summaryrefslogtreecommitdiff
path: root/Master/tlpkg
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-03-01 01:54:19 +0000
committerNorbert Preining <preining@logic.at>2010-03-01 01:54:19 +0000
commit904fd0757fe037dbfbf156b31f72e5ff5c7cd796 (patch)
tree36f000ab754854574aad17c01d9cd9ac739f1053 /Master/tlpkg
parent402bd194f686177d2dfca24f7c4766434c514141 (diff)
commit more files of the tlperl.straw dir, still not complete
git-svn-id: svn://tug.org/texlive/trunk@17244 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg')
-rw-r--r--Master/tlpkg/tlperl.straw/README.TeXLive32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/a2p.exebin0 -> 104448 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/bdf2gdfont.bat205
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/bdf2gdfont.pl189
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/c2ph.bat1383
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/config_data249
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/config_data.bat265
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/corelist272
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/corelist.bat288
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpan229
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpan.bat245
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpan2dist671
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpan2dist.bat687
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpandb272
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpandb.bat288
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpaninject137
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpaninject.bat153
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpanp104
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpanp-run-perl10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpanp-run-perl.bat27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpanp.bat120
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpansign95
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/cpansign.bat111
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/crc3231
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/crc32.bat47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/dbilogstrip50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/dbilogstrip.bat66
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/dbiprof263
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/dbiprof.bat279
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/dbiproxy184
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/dbiproxy.bat200
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/dprofpp.bat945
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/enc2xs1407
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/enc2xs.bat1423
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/exe_update.bat114
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/exe_update.pl98
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/exetype.bat124
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/find2perl.bat895
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/findrule138
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/findrule.bat154
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/gedi315
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/gedi.bat331
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/h2ph.bat959
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/h2xs.bat2203
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/instmodsh192
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/instmodsh.bat208
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/json_xs179
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/json_xs.bat195
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/largeprimes68
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/largeprimes.bat84
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/libnetcfg.bat737
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-download320
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-download.bat336
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-dump107
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-dump.bat123
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-mirror103
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-mirror.bat119
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-request531
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-request.bat547
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-rget607
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/lwp-rget.bat623
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/makerandom50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/makerandom.bat66
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/parinstallppd124
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/parinstallppd.bat140
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perl.exebin0 -> 9216 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perl5.10.1.exebin0 -> 9216 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perl510.dllbin0 -> 1324032 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perlbug.bat1478
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perldoc7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perldoc.bat23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perlglob.bat69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perlglob.exebin0 -> 6144 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perlivp.bat456
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/perlthanks.bat1478
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/piconv299
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/piconv.bat315
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pip23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pip.bat39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pl2bat.bat430
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pl2pm.bat394
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pler27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pler.bat43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pod2html.bat160
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pod2latex.bat398
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pod2man549
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pod2man.bat565
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pod2text273
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pod2text.bat289
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pod2usage.bat157
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/podchecker.bat161
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/podselect.bat120
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ppd2par167
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ppd2par.bat183
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ppm.bat1066
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ppm.pl1050
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/prove338
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/prove.bat354
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/psed.bat2018
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pstruct.bat1383
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptar114
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptar.bat130
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptardiff112
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptardiff.bat128
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptked368
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptked.bat384
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptksh730
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/ptksh.bat746
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pwhich141
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/pwhich.bat157
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/runperl.bat83
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/s2p.bat2018
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/search.bat1887
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/shasum268
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/shasum.bat284
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/splain.bat665
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/tkjpeg67
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/tkjpeg.bat83
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/widget608
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/widget.bat624
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/wperl.exebin0 -> 9216 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/bin/xsubpp.bat175
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Algorithm/Diff.pm1713
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Algorithm/DiffOld.pm305
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Algorithm/cdiff.pl385
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Algorithm/diff.pl47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Algorithm/diffnew.pl528
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Algorithm/htmldiff.pl100
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/AnyDBM_File.pm93
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Extract.pm1511
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Tar.pm2146
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Tar/Constant.pm86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Tar/File.pm660
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip.pm2059
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/Archive.pm978
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/BufferedFileHandle.pm131
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/DirectoryMember.pm80
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/FAQ.pod467
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/FileMember.pm64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/Member.pm1083
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/MemberRead.pm333
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/MockFileHandle.pm69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/NewFileMember.pm79
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/StringMember.pm64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/Tree.pm49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Archive/Zip/ZipFileMember.pm416
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Attribute/Handlers.pm924
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/AutoSplit.pm592
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/BerkeleyDB.pm1833
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/BerkeleyDB.pod2518
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Bundle/DBD/Pg.pm39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Bundle/DBD/mysql.pm30
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Bundle/DBI.pm51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Bundle/LWP.pm43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Apache.pm27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Carp.pm606
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Cookie.pm546
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Fast.pm220
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Pretty.pm312
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Push.pm325
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Switch.pm28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Util.pm365
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE.pod62
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/EXTERN.h61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/INTERN.h54
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/XSUB.h649
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/arpa/inet.h4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/av.h136
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/cc_runtime.h83
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/config.h4619
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/cop.h905
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/cv.h275
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/dirent.h53
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/dosish.h214
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/embed.h4778
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/embedvar.h848
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/fakesdio.h133
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/fakethr.h75
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/form.h27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/git_version.h8
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/gv.h227
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/handy.h912
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/hv.h577
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/intrpvar.h704
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/iperlsys.h1420
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/keywords.h269
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/libperl510.abin0 -> 1017186 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/malloc_ctl.h64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/mg.h72
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/mydtrace.h42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/netdb.h12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/nostdio.h136
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/op.h756
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/opcode.h1911
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/opnames.h433
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/overload.h88
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/pad.h360
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/parser.h118
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/patchlevel.h147
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perl.h6090
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perlapi.h835
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perlhost.h2456
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perlio.h394
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perliol.h297
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perlsdio.h164
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perlsfio.h84
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perlvars.h188
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/perly.h214
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/pp.h511
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/pp_proto.h410
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/proto.h6650
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/reentr.h1540
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/regcharclass.h454
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/regcomp.h846
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/regexp.h681
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/regnodes.h664
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/scope.h240
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/sv.h2144
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/sys/socket.h189
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/thread.h488
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/uconfig.h4595
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/unixish.h156
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/utf8.h352
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/utfebcdic.h494
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/util.h53
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/uudmap.h18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/vdir.h726
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/vmem.h1259
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/warnings.h123
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/win32.h588
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/win32iop-o.h340
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/win32iop.h340
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/win32thread.h197
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CORE/wince.h146
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/API/HOWTO.pod44
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Admin.pm230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Author.pm236
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Bundle.pm287
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/CacheMgr.pm246
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Checksums.pm432
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Complete.pm175
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Config.pm87
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Debug.pm79
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/DeferredCode.pm16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/DistnameInfo.pm194
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm3879
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Distroprefs.pm451
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Distrostatus.pm45
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Exception/RecursiveDependency.pm85
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Exception/blocked_urllist.pm46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Exception/yaml_not_installed.pm73
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/FTP.pm1074
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/FTP/netrc.pm63
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/FirstTime.pm1797
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/HandleConfig.pm735
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Index.pm619
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/InfoObj.pm224
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Inject.pm514
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Kwalify.pm136
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.dd150
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.yml92
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/LWP/UserAgent.pm135
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Mirrors.pm260
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Module.pm688
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Nox.pm51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Prompt.pm29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Queue.pm198
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite.pm323
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI.pm169
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Index.pm237
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Search.pm283
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/Index.pm264
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/Info.pm338
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/META.pm480
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/Populate.pm958
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/Search.pm520
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/State.pm410
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/SQLite/Util.pm367
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Shell.pm1974
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Tarzip.pm442
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/URL.pm31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPAN/Version.pm173
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CPANPLUS.pm271
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Carp.pm237
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Class/ErrorHandler.pm100
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Class/ISA.pm218
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Class/Loader.pm221
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Class/LoaderTest.pm41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Class/Struct.pm636
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Config.pm99
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Config.pod8824
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Config_heavy.pl1274
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm37
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm247
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1.pm444
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1.pod480
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm226
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/IO.pm261
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/_decode.pm675
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/_encode.pm406
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/parser.pm916
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/PEM.pm472
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm227
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Crypt/CAST5_PP/Tables.pm375
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Crypt/DES_EDE3.pm118
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Cwd.pm824
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DB.pm809
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Changes.pm2024
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ANSI.pm236
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ODBC.pm1363
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm105
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoType.pm54
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/DBD.pm3385
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/DBD/Metadata.pm493
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/FAQ.pm975
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Execute.pm900
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Request.pm200
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Response.pm218
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Base.pm64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/DataDumper.pm53
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Storable.pm59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/Base.pm176
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/pipeone.pm61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/stream.pm76
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Profile.pm943
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/ProfileData.pm737
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/ProfileDumper.pm342
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/ProfileDumper/Apache.pm230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/ProfileSubs.pm50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/ProxyServer.pm890
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/PurePerl.pm1205
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Roadmap.pm394
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/SQL/Nano.pm692
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Util/CacheMemory.pm117
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/Util/_accessor.pm65
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBI/W32ODBC.pm181
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DBM_Filter.pm605
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Buffer.pm465
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Compare.pm436
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Compare/Plugins.pod101
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Compare/Plugins/Scalar/Properties.pm94
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Dumper.pm1306
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Random.pm850
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Random/WordList.pm185
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Data/Random/dict45427
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest.pm316
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/BubbleBabble.pm105
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/HMAC.pm111
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/HMAC_MD5.pm71
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/HMAC_SHA1.pm71
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/MD2.pm72
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/MD5.pm376
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/SHA.pm669
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/SHA1.pm246
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/base.pm100
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Digest/file.pm85
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/DirHandle.pm92
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/English.pm230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Errno.pm2768
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Exporter/Heavy.pm251
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Fatal.pm1374
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Filter/Simple.pm797
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Filter/Util/Call.pm498
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/GDBM_File.pm86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Getopt/Long.pm2649
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Getopt/Std.pm295
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/Entities.pm500
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/Filter.pm112
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/Form.pm1551
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/HeadParser.pm301
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/LinkExtor.pm185
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/Parser.pm1240
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/PullParser.pm209
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/Tagset.pm471
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTML/TokeParser.pm369
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Config.pm436
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Cookies.pm781
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Cookies/Microsoft.pm329
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Cookies/Netscape.pm114
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Daemon.pm903
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Date.pm389
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Headers.pm827
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Headers/Auth.pm98
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Headers/ETag.pm94
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Headers/Util.pm199
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Message.pm1073
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Negotiate.pm529
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Request.pm242
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Request/Common.pm511
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Response.pm639
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/HTTP/Status.pm254
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Hash/Util.pm520
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Hash/Util/FieldHash.pm860
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/I18N/Collate.pm196
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/I18N/LangTags.pm887
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/I18N/LangTags/Detect.pm237
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/I18N/LangTags/List.pm1779
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IO.pm68
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Cmd.pm1646
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Open2.pm121
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Open3.pm376
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3.pm850
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm157
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm139
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm156
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm256
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm1076
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON.pm2088
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON/PP.pm2144
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON/PP/Boolean.pm26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON/PP5005.pm148
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON/PP56.pm198
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON/PP58.pm93
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON/XS.pm1478
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/JSON/XS/Boolean.pm26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/LWP.pm654
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Log/Message.pm600
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Log/Message/Config.pm197
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Log/Message/Handlers.pm191
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Log/Message/Item.pm192
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Log/Message/Simple.pm293
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/MIME/Base64.pm175
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/MIME/QuotedPrint.pm114
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigFloat.pm4402
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigFloat/Trace.pm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigInt.pm5115
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigInt/Calc.pm2612
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigInt/CalcEmu.pm329
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigInt/FastCalc.pm125
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigInt/GMP.pm157
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigInt/Trace.pm47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/BigRat.pm2020
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/Complex.pm2093
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/GMP.pm411
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/Pari.pm1195
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/PariInit.pm57
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/Trig.pm768
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/libPARI.dumb.pod8045
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Math/libPARI.pod8045
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Memoize/AnyDBM_File.pm31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Memoize/Expire.pm365
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Memoize/ExpireFile.pm52
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Memoize/ExpireTest.pm49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Memoize/NDBM_File.pm77
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Memoize/SDBM_File.pm75
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Memoize/Storable.pm72
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Opcode.pm590
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PAR.pm1244
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/POSIX.pm1042
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/POSIX.pod2210
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PPM/RelocPerl.pm85
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PPM/XML/Element.pm238
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PPM/XML/PPD.pm622
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PPM/XML/PPMConfig.pm425
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PPM/XML/RepositorySummary.pm31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PPM/XML/ValidatingElement.pm330
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Package/Constants.pm106
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Params/Check.pm712
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Params/Util.pm812
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Parse/Binary.pm960
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm319
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat/Variants.pm149
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Parse/CPAN/Meta.pm437
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PerlIO.pm344
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PerlIO/encoding.pm53
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PerlIO/scalar.pm41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PerlIO/via.pm243
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/PerlIO/via/QuotedPrint.pm94
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Checker.pm1268
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Escapes.pm721
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Find.pm535
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Functions.pm376
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Html.pm2233
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/InputObjects.pm936
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/LaTeX.pm1876
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Man.pm1764
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/ParseLink.pm192
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/ParseUtils.pm855
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Parser.pm1829
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc.pm1952
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/BaseTo.pm81
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/GetOptsOO.pm148
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToChecker.pm75
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToMan.pm190
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToNroff.pm103
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToPod.pm93
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToRtf.pm88
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToText.pm95
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToTk.pm132
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToXml.pm66
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/PlainText.pm738
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Plainer.pm100
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Select.pm746
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple.pm1535
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple.pod274
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/BlackBox.pm1946
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Checker.pm196
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Debug.pm178
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsText.pm155
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsXML.pm170
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/HTML.pm979
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLBatch.pm1372
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLLegacy.pm104
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/LinkSection.pm174
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Methody.pm152
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Progress.pm93
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/PullParser.pm844
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserEndToken.pm120
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserStartToken.pm161
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserTextToken.pm128
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserToken.pm163
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/RTF.pm699
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Search.pm1043
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/SimpleTree.pm180
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Subclassing.pod946
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Text.pm185
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/TextContent.pm112
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/TiedOutFH.pm105
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/Transcode.pm35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeDumb.pm63
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeSmart.pm44
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/XHTML.pm717
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Simple/XMLOutStream.pm185
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Text.pm878
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Text/Color.pm155
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Text/Overstrike.pm208
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Text/Termcap.pm195
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Pod/Usage.pm730
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Probe/Perl.pm272
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/SDBM_File.pm116
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Safe.pm663
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/SelfLoader.pm435
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Shell.pm270
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Sort/Versions.pm151
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Storable.pm1188
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Sys/Hostname.pm165
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Base.pm129
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/Base.pm449
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/Color.pm148
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/Console.pm91
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/ParallelSession.pm202
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/Session.pm219
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/File.pm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/File/Session.pm110
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Formatter/Session.pm183
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Harness.pm948
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Harness/Beyond.pod416
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Object.pm158
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser.pm1894
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Aggregator.pm416
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Grammar.pm582
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator.pm165
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Array.pm102
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Process.pm381
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Stream.pm108
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/IteratorFactory.pm342
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Multiplexer.pm195
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result.pm300
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Bailout.pm63
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Comment.pm61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Plan.pm120
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Pragma.pm63
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Test.pm274
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Unknown.pm51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Version.pm63
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Result/YAML.pm62
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/ResultFactory.pm189
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler.pm312
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Job.pm107
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Spinner.pm53
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Source.pm385
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Source/Perl.pm326
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler.pm194
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Executable.pm185
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/File.pm136
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Handle.pm125
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Perl.pm310
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/RawTAP.pm131
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/pgTAP.pm253
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/Utils.pm72
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Reader.pm333
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Writer.pm255
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/TASKS.pod55
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/ANSIColor.pm725
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/Cap.pm799
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/Complete.pm188
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/ReadKey.pm572
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/ReadLine.pm413
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/ReadLine/Perl.pm153
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/ReadLine/readline.pm4615
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/UI.pm620
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Term/UI/History.pm137
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Builder.pm2501
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Builder/IO/Scalar.pm658
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Builder/Module.pm173
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Builder/Tester.pm603
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Builder/Tester/Color.pm51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep.pm517
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep.pod932
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/All.pm64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Any.pm65
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Array.pm36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/ArrayEach.pm27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/ArrayElementsOnly.pm54
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLength.pm29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLengthOnly.pm60
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Blessed.pm47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Boolean.pm46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Cache.pm78
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Cache/Simple.pm81
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Class.pm29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Cmp.pm130
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Code.pm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Hash.pm104
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/HashEach.pm29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/HashElements.pm94
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/HashKeys.pm68
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm126
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Ignore.pm20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Isa.pm33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/ListMethods.pm24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/MM.pm64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Methods.pm78
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/NoTest.pm41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Number.pm80
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Ref.pm36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/RefType.pm46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Regexp.pm85
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/RegexpMatches.pm51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/RegexpOnly.pm47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRef.pm43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRefOnly.pm43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/RegexpVersion.pm13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRef.pm29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRefOnly.pm36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Set.pm185
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Shallow.pm51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/Stack.pm84
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Deep/String.pm34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Exception.pm464
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Harness.pm591
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Manifest.pm336
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/More.pm1776
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/NoWarnings.pm305
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/NoWarnings/Warning.pm79
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Script.pm238
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Simple.pm214
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Tester.pm645
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Tester/Capture.pm223
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Tester/CaptureRunner.pm76
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Tester/Delegate.pm32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Tutorial.pod604
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/Warn.pm535
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Test/YAML.pm270
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Thread/Queue.pm481
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Thread/Semaphore.pm170
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Array.pm287
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/EncryptedHash.pm451
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/File.pm2632
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Handle.pm201
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Hash.pm257
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Hash/NamedCapture.pm62
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Memoize.pm128
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/RefHash.pm274
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Registry.pm45
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Scalar.pm140
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/StdHandle.pm71
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/SubstrHash.pm215
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/Watch.pm560
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Time/HiRes.pm591
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Time/Local.pm371
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Time/Piece.pm874
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Time/Seconds.pm230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Time/gmtime.pm91
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Time/localtime.pm86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Time/tm.pm33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/804delta.pod110
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Adjuster.pm438
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Adjuster.pod223
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/After.pm104
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Animation.pm230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Animation.pod92
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Balloon.pm633
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Balloon.pod282
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Bitmap.pm10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Bitmap.pod103
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pm522
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pod210
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Button.pm247
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Button.pod255
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Camel.xpm41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Canvas.pm1436
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Canvas.pod2393
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pm42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pod347
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Clipboard.pm122
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Clipboard.pod89
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/CmdLine.pm497
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/CmdLine.pod454
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ColorEdit.xpm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pm768
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pod120
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Common.pod16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Compound.pm40
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Compound.pod298
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Config.pm13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ConfigSpecs.pod262
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Configure.pm69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Credits7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DItem.pod439
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Derived.pm512
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Derived.pod89
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Dialog.pm68
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Dialog.pod107
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DialogBox.pm146
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DialogBox.pod156
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DirTree.pm259
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DirTree.pod172
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Dirlist.pm113
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop.pm332
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/Common.pm61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/LocalDrop.pm61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/Rect.pm110
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunConst.pm34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunDrop.pm200
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunSite.pm107
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Drop.pm8
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Site.pm50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDDrop.pm145
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDSite.pm159
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DropSite.pm257
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DropSite.pod33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/DummyEncode.pm46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/English.pm307
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Entry.pm615
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Entry.pod693
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Error.pod145
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ErrorDialog.pm125
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Event.pm14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Event/IO.pm132
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Eventloop.pod62
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/FBox.pm1063
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/FBox.pod67
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/FileSelect.pm577
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/FileSelect.pod146
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/FloatEntry.pm109
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Font.pm163
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Font.pod407
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Frame.pm378
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Frame.pod146
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/HList.pm685
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/HList.pod1050
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/IO.pm182
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/IO.pod51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/IconList.pm712
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/IconList.pod82
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Image.pm74
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Image.pod145
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/InputO.pod50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Internals.pod142
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ItemStyle.pm38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/JPEG.pm57
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/LabEntry.pm31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/LabFrame.pm138
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/LabFrame.pod110
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/LabRadio.pm63
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Label.pm21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Label.pod133
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Labelframe.pm16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Labelframe.pod206
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Listbox.pm910
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Listbox.pod794
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/MMtry.pm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/MMutil.pm602
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/MainWindow.pm212
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/MainWindow.pod85
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/MakeDepend.pm292
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Menu.pm1201
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Menu.pod876
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pm178
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pod96
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Menubar.pm15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Menubutton.pm401
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Menubutton.pod249
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Message.pm20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Message.pod151
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/MsgBox.pm505
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/MsgBox.pod83
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Mwm.pod109
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/NBFrame.pm20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/NoteBook.pm480
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/NoteBook.pod231
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pm128
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pod100
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/PNG.pm50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Pane.pm544
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pm221
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pod326
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Photo.pm22
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Photo.pod475
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Pixmap.pm19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Pixmap.pod64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Popup.pod89
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Pretty.pm93
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ProgressBar.pm498
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/README.Adjust77
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ROText.pm43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ROText.pod31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pm45
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pod333
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Region.pm182
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Reindex.pm233
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ReindexedROText.pm13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/ReindexedText.pm13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Scale.pm278
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Scale.pod356
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pm429
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pod429
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Scrolled.pod86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Spinbox.pm115
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Spinbox.pod819
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Stats.pm26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Submethods.pm45
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Submethods.pod27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/SunConst.pod18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TList.pm416
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TList.pod597
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Table.pm598
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Table.pod97
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Tcl-perl.pod200
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Text.pm1662
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Text.pod2215
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Text/Tag.pm46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TextEdit.pm509
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TextList.pm982
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TextUndo.pm1022
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TextUndo.pod73
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Tiler.pm203
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Tiler.pod32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TixGrid.pm1597
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TixGrid.pod539
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Tk.xbm44
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Tk.xpm41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/TkXSUB.def62
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Toplevel.pm211
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Toplevel.pod199
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Trace.pm405
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Tree.pm313
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Tree.pod274
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/UserGuide.pod493
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Widget.pm1770
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Widget.pod678
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/WidgetDemo.pod59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Wm.pm174
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Wm.pod668
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X.pm391
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X.pod373
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/X.h677
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/Xatom.h79
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/Xfuncproto.h60
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/Xlib.h1214
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/Xutil.h855
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/cursorfont.h79
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/keysym.h39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/keysymdef.h1169
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11/license.terms39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11Font.pm184
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/X11Font.pod88
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Xcamel.gifbin0 -> 4193 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Xlib.pm15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Xrm.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/Xrm.pod45
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/act_folder.xbm5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/act_folder.xpm22
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/after.pod168
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/anim.gifbin0 -> 2533 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/arrowdownwin.xbm5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/balArrow.xbm4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/bind.pod583
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/bindtags.pod107
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/callbacks.pod104
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/cbxarrow.xbm6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/chooseColor.pod64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/chooseDirectory.pod85
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/composite.pod171
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/LabEnLabRad.pm41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPB.xpm48
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPBa.xpm48
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/c.icon16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.curbin0 -> 326 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.mask6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.xbm8
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.icon16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.mask16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/earth.gifbin0 -> 51712 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/earthris.gifbin0 -> 6343 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/face173
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/flagdown27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/flagup27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.256
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.56
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/letters27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/mickey.gifbin0 -> 9344 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/ned.xpm69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/noletters27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/page.icon16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/page.mask16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/pattern6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/images/teapot.ppm31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Ball.pm143
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList.pl65
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList2.pl124
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Plot.pm198
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm130
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/arrows.pl242
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/balloon.pl168
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bind.pl65
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bitmaps.pl44
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bounce.pl274
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry.pl34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry2.pl39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/button.pl28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/check.pl44
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/choosedir.pl39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/clrpick.pl45
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/colors.pl85
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/cscroll.pl86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ctext.pl170
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog1.pl33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog2.pl33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dirtree.pl7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry1.pl28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry2.pl33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry3.pl199
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/filebox.pl106
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/floor.pl1324
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form.pl31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form_mgr.pl21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hello.pl51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hscale.pl48
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/icon.pl64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image1.pl28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image2.pl104
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/items.pl358
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/keysyms.pl20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labelframe.pl74
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labels.pl43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labframe.pl13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/mega.pl135
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menbut.pl122
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus.pl196
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus2.pl216
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/msgBox.pl82
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/notebook.pl59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned1.pl26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned2.pl65
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo1.pl30
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo2.pl156
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/plot.pl28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/progress.pl46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/puzzle.pl86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/radio.pl78
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ruler.pl146
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/sayings.pl48
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/search.pl177
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/showVars.pl37
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/slide.pl178
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/spin.pl36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/states.pl28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/style.pl154
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/texts.pl71
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace1.pl49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace2.pl188
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/transtile.pl113
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/twind.pl186
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/unicodeout.pl64
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/virtevents1.pl59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/vscale.pl48
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Gedi.pl429
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/TEMPLATE.pl92
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Tiler.pl15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/all.pl315
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/cursor.pl61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuzbin0 -> 26699 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/npuz.pl226
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/plop.pl381
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/event.pod417
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/exit.pod42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/file.xbm5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/file.xpm18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/fileevent.pod112
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/focus.pod166
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/folder.xbm5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/folder.xpm21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/form.pod397
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/getOpenFile.pod182
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/grab.pod140
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/grid.pod409
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/icon.gifbin0 -> 1924 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/install.pm37
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/license.terms35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/mega.pod423
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/messageBox.pod67
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/openfile.xbm5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/openfolder.xbm5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/openfolder.xpm21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/option.pod217
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/options.pod787
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/overview.pod138
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk.pod550
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.h206
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.m192
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.t217
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Lang_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Tcl-pTk260
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.h149
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.m661
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.t657
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/compat/limits.h22
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/compat/stdlib.h45
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/compat/unistd.h87
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/default.h36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/img.h41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.h75
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.m62
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.t93
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/ks_names.h925
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/mkVFunc427
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/moredefs.h131
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/port.h32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tcl.h2411
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.h4143
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.m538
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.t675
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntDecls.h1324
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntPlatDecls.h585
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclMath.h27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclPlatDecls.h197
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tclWinInt.h145
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tix.h512
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tix.m126
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tix.t170
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixBitmaps.h618
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixDef.h173
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixForm.h143
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrData.h88
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrid.h458
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixHList.h323
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.h134
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.m34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.t49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.h886
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.m171
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.t249
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixPort.h110
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixTList.h148
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinInt.h23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinPort.h40
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tix_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tk.h1859
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tk.m94
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tk.t151
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tk3d.h102
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkButton.h320
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvas.h334
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvases.h81
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkColor.h89
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkConfig.h11
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.h2277
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.m870
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.t1158
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.h122
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.m274
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.t304
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkFileFilter.h92
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkFont.h226
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.h36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.m55
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.t66
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkInitScript.h58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.h1200
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.m125
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.t182
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.h1572
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.m466
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.t642
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.h1227
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.m474
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.t845
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.h2436
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.m446
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.t1521
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenu.h588
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenubutton.h240
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.h17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.m26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.t26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.h300
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.m114
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.t190
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls_f.h15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkPort.h49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkScale.h257
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkScrollbar.h209
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkSelect.h187
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkText.h927
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkUndo.h90
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkVMacro.h69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkWin.h60
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinDefault.h525
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinInt.h209
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinPort.h156
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tkXrm.h12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/tk_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pTk/xbytes.h58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/pack.pod324
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/palette.pod89
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/place.pod271
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/prolog.ps284
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/reindex.pl33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/selection.pod159
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/send.pod118
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/srcfile.xpm18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/textfile.xpm18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tixWm.pod73
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tkGlue.def130
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tkGlue.h79
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tkGlue.m74
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tkGlue.t70
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tkGlue_f.h14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tkvars.pod107
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/tranicon.gifbin0 -> 1718 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/typemap96
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/vtab.def90
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/widgets.pm20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/widgets.pod20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/win.xbm6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/winfolder.xpm39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tk/wintext.xpm42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/URI.pm1102
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/User/grent.pm95
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/User/pwent.pm298
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32.pm793
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/API.pm778
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/API/Callback.pm174
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/API/Struct.pm532
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/API/Test.pm111
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/API/Type.pm453
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/DBIODBC.pm248
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/EventLog.pm471
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe.pm308
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm60
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm57
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm54
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm60
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Version.pm364
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm154
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm260
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/File.pm118
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/File/Object.pm450
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Process.pm219
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Shortcut.pm752
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/TieRegistry.pm3809
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/WinError.pm1017
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32API/File.pm3035
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32API/File/cFile.pc165
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32API/Registry.pm1772
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32API/Registry/cRegistry.pc87
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32CORE.pm38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML.pm2238
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML.pod515
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Attr.pod134
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Boolean.pm92
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/CDATASection.pod58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Comment.pod59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pm203
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pod129
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/DOM.pod142
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Document.pod696
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/DocumentFragment.pod40
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Dtd.pod102
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Element.pod384
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pm500
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pod27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pm229
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pod254
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/InputCallback.pod292
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Literal.pm109
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Namespace.pod143
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Node.pod752
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/NodeList.pm198
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Number.pm97
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/PI.pod87
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Parser.pod966
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Pattern.pod107
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pm212
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pod669
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/RegExp.pod71
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/RelaxNG.pod81
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pm97
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pod49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pm332
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pod51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Generator.pm157
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Parser.pm265
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Schema.pod78
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/Text.pod183
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pm146
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pod372
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXML/XPathExpression.pod65
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/LibXSLT.pm1008
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/NamespaceSupport.pm583
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser.pm840
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser/Expat.pm1230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser/LWPExternEnt.pl71
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser/Style/Debug.pm52
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser/Style/Objects.pm78
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser/Style/Stream.pm184
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser/Style/Subs.pm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/Parser/Style/Tree.pm90
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX.pm379
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/Base.pm3164
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/DocumentLocator.pm134
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/Exception.pm126
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/Intro.pod407
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/ParserDetails.ini10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/ParserFactory.pm230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl.pm751
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DTDDecls.pm603
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DebugHandler.pm95
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DocType.pm180
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/EncodingDetect.pm105
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Exception.pm67
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/NoUnicodeExt.pm28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Productions.pm147
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader.pm136
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm25
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/Stream.pm84
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/String.pm78
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/URI.pm57
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/UnicodeExt.pm23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/UnicodeExt.pm22
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/XMLDecl.pm129
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/SAX/placeholder.pl1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/XML/benchmark.pl268
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML.pm817
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Any.pm202
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Base.pm204
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Dumper.pm591
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Dumper/Base.pm142
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Error.pm226
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Loader.pm790
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Loader/Base.pm68
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Marshall.pm81
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Node.pm305
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Tag.pm52
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Tiny.pm1132
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/YAML/Types.pm265
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/assert.pl55
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/attributes.pm495
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Algorithm/Diff/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Archive/Extract/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Archive/Tar/.packlist7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Archive/Zip/.packlist15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Attribute/Handlers/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/AutoLoader/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/B/B.dllbin0 -> 120832 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/.packlist7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.dllbin0 -> 1519616 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CGI/.packlist9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CPAN/.packlist37
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CPAN/Checksums/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CPAN/DistnameInfo/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CPAN/Inject/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CPAN/SQLite/.packlist13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CPANPLUS/.packlist47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/CPANPLUS/Dist/Build/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Class/ErrorHandler/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Class/ISA/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Class/Loader/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.dllbin0 -> 113152 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.dllbin0 -> 81408 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.dllbin0 -> 120832 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/Zlib/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.dllbin0 -> 14848 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Convert/ASCII/Armour/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Convert/ASN1/.packlist7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Convert/PEM/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.dllbin0 -> 15872 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/autosplit.ix7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/decrypt.al47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/encrypt.al44
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/init.al69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/CBC/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/DES/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.dllbin0 -> 15360 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/DES_EDE3/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/DH/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/DSA/.packlist7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/.packlist5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.dllbin0 -> 10752 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/OpenPGP/.packlist39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Primes/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/.packlist5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.dllbin0 -> 17920 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/RSA/.packlist14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Random/.packlist9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.dllbin0 -> 18432 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/.packlist9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.dllbin0 -> 29184 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.dllbin0 -> 23040 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Cwd/.packlist12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.dllbin0 -> 12288 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/.packlist5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.dllbin0 -> 111104 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/Pg/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.dllbin0 -> 238080 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.dllbin0 -> 512000 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/mysql/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/mysql/libmysql.dllbin0 -> 2359296 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.dllbin0 -> 98816 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/.packlist66
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/DBI.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/DBI.dllbin0 -> 118784 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/DBIXS.h519
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/Driver.xst775
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/Driver_xst.h118
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/dbd_xsh.h58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/dbi_sql.h96
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/dbipport.h4954
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/dbivport.h52
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBI/dbixs_rev.h2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBIx/Simple/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DBM/Deep/.packlist8
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DB_File/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.dllbin0 -> 1341440 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DB_File/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Data/Buffer/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Data/Compare/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Data/Dumper/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.dllbin0 -> 33280 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Data/Random/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Devel/DProf/DProf.dllbin0 -> 16384 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Devel/PPPort/PPPort.dllbin0 -> 108032 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Devel/Peek/Peek.dllbin0 -> 15360 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/BubbleBabble/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/MD2/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.dllbin0 -> 13312 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/MD5/MD5.dllbin0 -> 15360 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/SHA/.packlist5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.dllbin0 -> 46592 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.dllbin0 -> 17408 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DynaLoader/autosplit.ix8
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_expandspec.al31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_find_symbol_anywhere.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_findfile.al86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/.packlist56
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.dllbin0 -> 110592 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.dllbin0 -> 742400 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.dllbin0 -> 17920 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Encode.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Encode.dllbin0 -> 31744 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.dllbin0 -> 858624 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.dllbin0 -> 813568 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.dllbin0 -> 22016 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.dllbin0 -> 759808 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.dllbin0 -> 20992 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/ExtUtils/CBuilder/.packlist13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/ExtUtils/MakeMaker/.packlist30
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/ExtUtils/Manifest/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/ExtUtils/ParseXS/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/FCGI/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.dllbin0 -> 51200 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Fcntl/Fcntl.dllbin0 -> 12288 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/Fetch/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/Find/Rule/.packlist5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/Glob/Glob.dllbin0 -> 16896 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/HomeDir/.packlist8
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/Path/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/Remove/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/Which/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/chmod/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/File/pushd/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Filter/Util/Call/Call.dllbin0 -> 13824 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/GD/.packlist12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/GD/GD.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/GD/GD.dllbin0 -> 118272 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/GD/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/GDBM_File/GDBM_File.dllbin0 -> 41984 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/HTML/Parser/.packlist9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.dllbin0 -> 44032 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/HTML/Tagset/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Hash/Util/FieldHash/FieldHash.dllbin0 -> 17408 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Hash/Util/Util.dllbin0 -> 10240 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/IO/IO.dllbin0 -> 16896 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/IO/Socket/SSL/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/IO/String/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/IO/Zlib/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/IPC/Cmd/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/IPC/Run3/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/IPC/System/Simple/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/.packlist84
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.dllbin0 -> 9728 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.dllbin0 -> 28160 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.dllbin0 -> 23040 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.dllbin0 -> 9728 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.dllbin0 -> 9728 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.dllbin0 -> 10752 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Imager.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Imager/Imager.dllbin0 -> 573440 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/JSON/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/JSON/XS/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.dllbin0 -> 55296 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/LWP/Online/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/List/Util/.packlist7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/List/Util/Util.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/List/Util/Util.dllbin0 -> 26112 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Locale/Maketext/Simple/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Log/Message/Simple/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/MIME/Base64/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.dllbin0 -> 12800 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/BigInt/FastCalc/FastCalc.dllbin0 -> 17920 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.dllbin0 -> 113152 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/BigRat/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/GMP/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.dllbin0 -> 124416 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/GMP/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/Pari/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.dllbin0 -> 2341376 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Module/Build/.packlist34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Module/CoreList/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Module/Load/Conditional/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Module/Loaded/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Module/Signature/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SMTP/TLS/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/.packlist79
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.dllbin0 -> 233472 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/autosplit.ix78
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/debug_read.al22
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https2.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https3.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https4.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx2.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx3.al43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx4.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/dump_peer_certificate.al29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http.al10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http3.al10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http4.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https.al10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https3.al10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https4.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx.al10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx3.al10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx4.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/http_cat.al34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/https_cat.al97
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/httpx_cat.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_form.al25
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_headers.al21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/new_x_ctx.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_proxy_tcp_connection.al31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_tcp_connection.al40
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx3.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx4.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/randomize.al31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_cert_and_key.al23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_proxy.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_server_cert_and_key.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_CRLF.al10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_all.al28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_until.al95
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_CRLF.al23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_all.al38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/sslcat.al99
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_CRLF.al11
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_all.al26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_until.al34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_CRLF.al23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_all.al36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpcat.al37
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpxcat.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_X509_lookup.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_nothing.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_read.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_write.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Number/Compare/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Object/Accessor/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Opcode/Opcode.dllbin0 -> 20992 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PAR/.packlist7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PAR/Dist/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PAR/Dist/FromPPD/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PAR/Dist/InstallPPD/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Client/.packlist5
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Query/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/POSIX.dllbin0 -> 88064 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/flags.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/handler.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/mask.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/new.al11
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/safe.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/CLEAR.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/DELETE.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/EXISTS.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/FETCH.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/SCALAR.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/STORE.al9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_check.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_croak.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_exist.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_getsig.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_init.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/new.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/abs.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/alarm.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/assert.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/atan2.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/atexit.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/atof.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/atoi.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/atol.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/autosplit.ix173
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/bsearch.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/calloc.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/chdir.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/chmod.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/chown.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/clearerr.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/closedir.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/cos.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/creat.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/div.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/errno.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/execl.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/execle.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/execlp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/execv.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/execve.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/execvp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/exit.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/exp.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fabs.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fclose.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fcntl.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fdopen.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/feof.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/ferror.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fflush.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fgetc.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fgetpos.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fgets.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fileno.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fopen.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fork.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fprintf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fputc.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fputs.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fread.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/free.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/freopen.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fscanf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fseek.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fsetpos.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fstat.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fsync.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/ftell.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/fwrite.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getc.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getchar.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getegid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getenv.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/geteuid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getgid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getgrgid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getgrnam.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getgroups.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getlogin.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getpgrp.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getpid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getppid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getpwnam.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getpwuid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/gets.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/getuid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/gmtime.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/isatty.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/kill.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/labs.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/ldiv.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/link.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/load_imports.al230
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/localtime.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/log.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/longjmp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/malloc.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/memchr.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/memcmp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/memcpy.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/memmove.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/memset.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/mkdir.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/offsetof.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/opendir.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/perror.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/pow.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/printf.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/putc.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/putchar.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/puts.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/qsort.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/raise.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/rand.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/readdir.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/realloc.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/redef.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/remove.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/rename.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/rewind.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/rewinddir.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/rmdir.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/scanf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/setbuf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/setjmp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/setvbuf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/siglongjmp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/sigsetjmp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/sin.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/sleep.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/sprintf.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/sqrt.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/srand.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/sscanf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/stat.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strcat.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strchr.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strcmp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strcpy.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strcspn.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strerror.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strlen.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strncat.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strncmp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strncpy.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strpbrk.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strrchr.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strspn.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strstr.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/strtok.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/system.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/time.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/tmpfile.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/tolower.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/toupper.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/umask.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/ungetc.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/unimpl.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/unlink.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/usage.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/utime.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/vfprintf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/vprintf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/vsprintf.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/wait.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/POSIX/waitpid.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PPM/.packlist10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Params/Util/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.dllbin0 -> 16384 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Parse/Binary/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Parse/CPAN/Meta/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PerlIO/encoding/encoding.dllbin0 -> 23552 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PerlIO/scalar/scalar.dllbin0 -> 10752 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/PerlIO/via/via.dllbin0 -> 17408 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Pod/Perldoc/.packlist14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Pod/Plainer/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Pod/Simple/.packlist32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Probe/Perl/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/SDBM_File/SDBM_File.dllbin0 -> 30208 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Safe/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Socket/Socket.dllbin0 -> 18944 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Sort/Versions/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/.packlist28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/BIN_VERSION_NV.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/BIN_WRITE_VERSION_NV.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/CAN_FLOCK.al21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/Storable.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/Storable.dllbin0 -> 72192 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/_freeze.al23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/_retrieve.al31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/_store.al41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/_store_fd.al27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/autosplit.ix28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/fd_retrieve.al25
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/file_magic.al21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/freeze.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/lock_nstore.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/lock_retrieve.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/lock_store.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/logcarp.al12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/logcroak.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/nfreeze.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/nstore.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/nstore_fd.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/read_magic.al69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/retrieve.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/show_file_magic.al30
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/store.al20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/store_fd.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Storable/thaw.al28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/String/CRC32/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.dllbin0 -> 9216 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Sub/Uplevel/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Switch/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/Hostname.dllbin0 -> 8192 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Term/ANSIColor/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.dllbin0 -> 21504 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Deep/.packlist42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Exception/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Harness/.packlist52
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Manifest/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/NoWarnings/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Script/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Simple/.packlist8
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Tester/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Test/Warn/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Text/Balanced/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Text/Diff/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Text/Glob/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Text/Soundex/Soundex.dllbin0 -> 9216 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tie/EncryptedHash/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Time/HiRes/HiRes.dllbin0 -> 20480 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Time/Piece/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.dllbin0 -> 21504 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/.packlist664
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/CancelRepeat.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.dllbin0 -> 153600 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/autosplit.ix6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/getSelected.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.dllbin0 -> 20480 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.dllbin0 -> 11264 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/EnterFocus.al27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.dllbin0 -> 41984 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Error.al20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.dllbin0 -> 57344 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/FirstMenu.al21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/FocusChildren.al35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/FocusOK.al36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/AddScrollbars.al52
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/FindMenu.al22
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/autosplit.ix24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/freeze_on_map.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/label.al24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelPack.al50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelVariable.al27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/packscrollbars.al86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/queuePack.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/sbset.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Frame/scrollbars.al24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.dllbin0 -> 52224 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.dllbin0 -> 12288 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/ImageNames.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/ImageTypes.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.dllbin0 -> 17408 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/AutoScan.al49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginExtend.al34
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginSelect.al46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginToggle.al40
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ButtonRelease_1.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/CLEAR.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cancel.al42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_End.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_Home.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_backslash.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DELETE.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DataExtend.al39
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXISTS.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXTEND.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ExtendUpDown.al36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCH.al56
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCHSIZE.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.dllbin0 -> 31744 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Motion.al77
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/POP.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/PUSH.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SHIFT.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SPLICE.al84
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/STORE.al80
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SelectAll.al32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SetList.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIEARRAY.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIESCALAR.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UNSHIFT.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UpDown.al41
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/autosplit.ix56
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/clipboardPaste.al21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/deleteSelected.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/getSelected.al24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/xyIndex.al29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.dllbin0 -> 21504 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.dllbin0 -> 22528 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.dllbin0 -> 16384 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.dllbin0 -> 26624 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Receive.al23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/RepeatId.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Activate.al33
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonDown.al40
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonUp.al16
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ControlPress.al31
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Drag.al29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/EndDrag.al23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Enter.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Increment.al61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Leave.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.dllbin0 -> 25088 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scale/autosplit.ix22
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonDown.al55
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonUp.al26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Drag.al43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/EndDrag.al28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Enter.al21
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Leave.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Motion.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByPages.al38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByUnits.al37
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlToPos.al35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlTopBottom.al32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.dllbin0 -> 20992 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Select.al59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/StartDrag.al38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/autosplit.ix30
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Selection.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.dllbin0 -> 28672 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Table/Create.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Table/Posn.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Table/autosplit.ix14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Table/see.al46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalColumns.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalRows.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.dllbin0 -> 114176 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Text/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/TextEdit/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/TextUndo/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.dllbin0 -> 52224 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Tk.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Tk.dllbin0 -> 807424 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindIn.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindOut.al20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Create.al56
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Destroy.al29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_In.al24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Out.al32
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/autosplit.ix10
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/TraverseToMenu.al27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/ASkludge.al30
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AltKeyInDialog.al20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AmpWidget.al36
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/FindAltKeyTarget.al38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/MasterMenu.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/RestoreFocusGrab.al59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetAmpText.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetFocusGrab.al38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/UnderlineAmpersand.al29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/autosplit.ix27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/bindDump.al87
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/clipboardKeysyms.al51
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Widget/pathname.al15
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Wm/AnchorAdjust.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Wm/FullScreen.al29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Popup.al50
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Post.al20
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Wm/autosplit.ix14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Wm/iconposition.al24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/X/X.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/X/X.dllbin0 -> 25088 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/X/autosplit.ix3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.dllbin0 -> 29696 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/autosplit.ix49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/break.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/focusFollowsMouse.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/focusNext.al18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/focusPrev.al28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/getEncoding.al43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/getNextFocus.al44
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/getPrevFocus.al54
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/interps.al14
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/lsearch.al19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/pTk/extralibs.ld1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/tabFocus.al13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tk/updateWidgets.al17
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Tree/DAG_Node/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/URI/.packlist52
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Unicode/Normalize/Normalize.dllbin0 -> 195072 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/API/.packlist9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/API/API.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/API/API.dllbin0 -> 21504 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.dllbin0 -> 16384 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.dllbin0 -> 24576 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Exe/.packlist28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/File/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/File/File.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/File/File.dllbin0 -> 10240 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/File/Object/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Process/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.dllbin0 -> 39936 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.dllbin0 -> 24576 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/TieRegistry/.packlist2
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/Win32.dllbin0 -> 44032 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/WinError/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.dllbin0 -> 68096 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32API/File/File.dllbin0 -> 83968 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.dllbin0 -> 187392 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/Win32CORE/extralibs.ld1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/LibXML/.packlist43
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.dllbin0 -> 333824 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/.packlist4
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.xs.dllbin0 -> 47104 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/NamespaceSupport/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/Parser/.packlist29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.dllbin0 -> 67072 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/XML/SAX/.packlist23
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/YAML/.packlist13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/YAML/Tiny/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/attrs/attrs.dllbin0 -> 9216 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/common/sense/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/constant/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/local/lib/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/mro/mro.dllbin0 -> 13824 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/parent/.packlist1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/pip/.packlist7
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/pler/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/re/re.dllbin0 -> 292864 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/sdbm/extralibs.ld1
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/threads/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/threads/shared/.packlist3
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.dllbin0 -> 31232 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/threads/threads.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/threads/threads.dllbin0 -> 34304 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/version/.packlist6
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.bs0
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.dllbin0 -> 27136 bytes
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/autouse.pm171
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/bigfloat.pl254
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/bigint.pm675
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/blib.pm97
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/bytes.pm88
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/charnames.pm554
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/common/sense.pm424
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/complete.pl120
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/constant.pm392
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/ctime.pl59
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/diagnostics.pm647
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/encoding.pm669
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/fields.pm327
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/filetest.pm117
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/finddepth.pl46
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/fix_4_os2.pl61
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/getopt.pl49
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/if.pm56
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/inc/latest.pm246
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/inc/latest/private.pm101
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/local/lib.pm832
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/lwptut.pod837
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/mro.pm381
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/newgetopt.pl75
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/open.pm258
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/open3.pl12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/ops.pm47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/overload/numbers.pm159
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/parent.pm136
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/perl5db.pl9542
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/perldoc.pod267
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/pler.pm482
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/ppm.xml18
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/pwd.pl67
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/re.pm514
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/sigtrap.pm289
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/stat.pl29
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/termcap.pl178
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/utf8.pm198
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/utf8_heavy.pl286
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/version.pm216
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/version.pod365
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/version/Internals.pod608
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/version/vxs.pm28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/vmsish.pm154
2140 files changed, 599469 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/README.TeXLive b/Master/tlpkg/tlperl.straw/README.TeXLive
new file mode 100644
index 00000000000..e604d8c87a4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/README.TeXLive
@@ -0,0 +1,32 @@
+
+This directory contains a subset of the Strawberry Perl distribution
+as distributed from http://strawberryperl.com/
+The currently used version is 5.10.1
+
+The only purpose of this package is to support programs shipped with
+TeX Live. It's not intended for general use.
+
+Changes:
+
+ * The only module that has been added is Perl/Tk.
+ Procedure:
+ - start the CPAN client
+ - at the prompt:
+ install Tk
+ install Win32::Shortcut
+
+ * After that the lib directories in
+ strawberry\perl\lib
+ strawberry\perl\vendor\lib
+ strawberry\perl\site\lib
+ have been merged into one directory (tlperl/lib)
+ and strawberry\perl\bin has been put into tlperl/bin.
+
+This version of Perl will not be installed on your system and will not
+interfere with other versions of Perl which might be installed already.
+
+If you need Perl for any other purpose than running the programs
+provided by TeX Live, we recommand to install the full version which
+can be downloaded from:
+
+ http://www.perl.org
diff --git a/Master/tlpkg/tlperl.straw/bin/a2p.exe b/Master/tlpkg/tlperl.straw/bin/a2p.exe
new file mode 100755
index 00000000000..b18a77b4a08
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/a2p.exe
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/bin/bdf2gdfont.bat b/Master/tlpkg/tlperl.straw/bin/bdf2gdfont.bat
new file mode 100755
index 00000000000..c87b4618745
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/bdf2gdfont.bat
@@ -0,0 +1,205 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+#
+# Simple convertor from bdf to loadable GD font format.
+#
+# Author: Lincoln Stein <lstein@cshl.edu>, heavily adopted from bdftogd from
+# Jan Pazdziora <adelton@fi.muni.cz>
+#
+# Example of use:
+# fstobdf -s fontserverhost:7100 -fn 8x16 | bdftofnt > myfont.fnt
+#
+
+use strict;
+our $VERSION = '1.00';
+
+if ($ARGV[0] =~ /^--?h/) {
+ exec "perldoc $0";
+}
+
+my ($width, $height);
+my (@data, @left, @bottom);
+my ($globalleft, $globaltop);
+
+my ($minchar, $maxchar);
+
+my ($copyright, $fontdef);
+
+my $currentchar;
+my $gobitmap = 0;
+
+foreach (@ARGV) {
+ $_ = "gunzip -c $_ |" if /\.gz$/;
+}
+
+while (<>)
+ {
+ chomp;
+ s/\r$//;
+ next unless $_;
+ my ($tag, $value) = split / /, $_, 2;
+ die "Font is not fixed width\n"
+ if $tag eq 'SPACING' and not $value =~ /[CM]/i;
+
+ $currentchar = $value if $tag eq 'ENCODING';
+ $minchar = $currentchar if not defined $minchar
+ or ($currentchar < $minchar && $currentchar >= 0);
+ $maxchar = $currentchar if not defined $maxchar
+ or ($currentchar > $maxchar && $currentchar >= 0);
+
+ if ($tag eq 'ENDCHAR')
+ {
+ next if $currentchar < 0;
+ $gobitmap = 0;
+ my $bottom = $globaltop - $bottom[$currentchar];
+
+
+ if ($bottom > 0)
+ { $data[$currentchar] = substr $data[$currentchar], 0, length($data[$currentchar]) - $bottom * $width; }
+ else
+ { $data[$currentchar] .= '0' x (-$bottom * $width); }
+ }
+
+ if ($tag eq 'FONTBOUNDINGBOX')
+ {
+ my ($tag, $wid, $hei, $left, $top) = split / /;
+ if (defined $top)
+ {
+ $globalleft = $left;
+ $globaltop = $top;
+ $height = $hei;
+ $width = $wid;
+ }
+ }
+ if ($tag eq 'FONT' and not defined $fontdef)
+ { $fontdef = $value; }
+ if ($tag eq 'COPYRIGHT' and not defined $copyright)
+ { $copyright = $value; }
+
+ if ($tag eq 'BBX')
+ {
+ my ($tag, $wid, $hei, $left, $bottom) = split / /;
+ if (defined $bottom)
+ {
+ $left[$currentchar] = $left;
+ $bottom[$currentchar] = $bottom;
+ }
+ }
+
+ if ($gobitmap)
+ {
+ my $value = pack 'H*', $_;
+ my $bits = unpack 'B*', $value;
+ $bits = ('0' x $left[$currentchar]) . $bits;
+ $bits .= '0' x ($width - length $bits);
+ $bits = substr $bits, 0, $width;
+ $data[$currentchar] .= $bits;
+ }
+
+ if ($tag eq 'BITMAP')
+ {
+ $gobitmap = 1;
+ $data[$currentchar] = '';
+ }
+ }
+
+$minchar = 0 unless defined $minchar;
+$maxchar = 255 unless defined $maxchar;
+
+binmode STDOUT; # for DOS/Windows systems
+my $length = $maxchar-$minchar+1;
+
+
+print pack ('VVVV',$length,$minchar,$width,$height); # header
+
+for (my $i = $minchar; $i <= $maxchar; $i++) {
+ $data[$i] = '' unless defined $data[$i];
+ $data[$i] = '0' x ($width * $height - length $data[$i]) . $data[$i];
+ print pack('C*',split '',$data[$i]);
+}
+
+print STDERR "Successfully converted $length ${width}x$}height} characters\n";
+
+__END__
+
+=head1 NAME
+
+bdf2gdfont.pl - Convert X11 "BDF" fonts into a loadable font format for GD.
+
+=head1 SYNOPSIS
+
+ % bdf2gdfont.pl courR12.bdf > courR12.fnt
+
+=head1 DESCRIPTION
+
+This script converts BDF-style X11 font files into a format that can
+be loaded by the GD module using the GD::Font->load() method. There
+are a number of ways to obtain BDF fonts.
+
+=over 4
+
+=item 1. The font is already present on your system.
+
+Some BDF fonts can be found in the standard X11R6 distribution. This
+script will automatically uncompress gzipped font files if their
+extension ends with .gz (the gunzip program must be on your path).
+
+=item 2. From a font server.
+
+The "fstobdf" utility, a standard X11 utility, will read a named font
+from the font server of your choice and return it in BDF format. You
+can pipe it to bdf2gdfont.pl:
+
+ fstobdf -s fontserverhost:7100 -fn 8x16 | bdf2gdfont.pl > newfont.fnt
+
+Use xlsfonts to find out what fonts are available. Most fonts will
+have long names like
+-B&H-LucidaTypewriter-Bold-R-Normal-Sans-18-180-75-75-M-110-ISO8859-10.
+
+=item 3. Using the pcf2bdf utility.
+
+Some fonts are only available in PCF (compiled) format. To obtain
+these, you can either turn on a font server and follow recipe (2), or
+use TAGA Nayuta's pcf2bdf utility. This utility is available from
+http://www.tsg.ne.jp/GANA/S/pcf2bdf/ (page is in Japanese, but you can
+find the download link).
+
+=back
+
+=head2 Limitations
+
+This font converter only works with fixed-width fonts. If used with a
+TrueType or proportional font it will die with an error message.
+
+=head1 SEE ALSO
+
+L<GD>
+
+=head1 AUTHOR
+
+Lincoln Stein <lstein@cshl.org>, heavily adapted from bdftogd from
+Jan Pazdziora <adelton@fi.muni.cz>.
+
+Copyright (c) 2004 Cold Spring Harbor Laboratory
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/bdf2gdfont.pl b/Master/tlpkg/tlperl.straw/bin/bdf2gdfont.pl
new file mode 100755
index 00000000000..e807b81137b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/bdf2gdfont.pl
@@ -0,0 +1,189 @@
+#!perl
+
+#
+# Simple convertor from bdf to loadable GD font format.
+#
+# Author: Lincoln Stein <lstein@cshl.edu>, heavily adopted from bdftogd from
+# Jan Pazdziora <adelton@fi.muni.cz>
+#
+# Example of use:
+# fstobdf -s fontserverhost:7100 -fn 8x16 | bdftofnt > myfont.fnt
+#
+
+use strict;
+our $VERSION = '1.00';
+
+if ($ARGV[0] =~ /^--?h/) {
+ exec "perldoc $0";
+}
+
+my ($width, $height);
+my (@data, @left, @bottom);
+my ($globalleft, $globaltop);
+
+my ($minchar, $maxchar);
+
+my ($copyright, $fontdef);
+
+my $currentchar;
+my $gobitmap = 0;
+
+foreach (@ARGV) {
+ $_ = "gunzip -c $_ |" if /\.gz$/;
+}
+
+while (<>)
+ {
+ chomp;
+ s/\r$//;
+ next unless $_;
+ my ($tag, $value) = split / /, $_, 2;
+ die "Font is not fixed width\n"
+ if $tag eq 'SPACING' and not $value =~ /[CM]/i;
+
+ $currentchar = $value if $tag eq 'ENCODING';
+ $minchar = $currentchar if not defined $minchar
+ or ($currentchar < $minchar && $currentchar >= 0);
+ $maxchar = $currentchar if not defined $maxchar
+ or ($currentchar > $maxchar && $currentchar >= 0);
+
+ if ($tag eq 'ENDCHAR')
+ {
+ next if $currentchar < 0;
+ $gobitmap = 0;
+ my $bottom = $globaltop - $bottom[$currentchar];
+
+
+ if ($bottom > 0)
+ { $data[$currentchar] = substr $data[$currentchar], 0, length($data[$currentchar]) - $bottom * $width; }
+ else
+ { $data[$currentchar] .= '0' x (-$bottom * $width); }
+ }
+
+ if ($tag eq 'FONTBOUNDINGBOX')
+ {
+ my ($tag, $wid, $hei, $left, $top) = split / /;
+ if (defined $top)
+ {
+ $globalleft = $left;
+ $globaltop = $top;
+ $height = $hei;
+ $width = $wid;
+ }
+ }
+ if ($tag eq 'FONT' and not defined $fontdef)
+ { $fontdef = $value; }
+ if ($tag eq 'COPYRIGHT' and not defined $copyright)
+ { $copyright = $value; }
+
+ if ($tag eq 'BBX')
+ {
+ my ($tag, $wid, $hei, $left, $bottom) = split / /;
+ if (defined $bottom)
+ {
+ $left[$currentchar] = $left;
+ $bottom[$currentchar] = $bottom;
+ }
+ }
+
+ if ($gobitmap)
+ {
+ my $value = pack 'H*', $_;
+ my $bits = unpack 'B*', $value;
+ $bits = ('0' x $left[$currentchar]) . $bits;
+ $bits .= '0' x ($width - length $bits);
+ $bits = substr $bits, 0, $width;
+ $data[$currentchar] .= $bits;
+ }
+
+ if ($tag eq 'BITMAP')
+ {
+ $gobitmap = 1;
+ $data[$currentchar] = '';
+ }
+ }
+
+$minchar = 0 unless defined $minchar;
+$maxchar = 255 unless defined $maxchar;
+
+binmode STDOUT; # for DOS/Windows systems
+my $length = $maxchar-$minchar+1;
+
+
+print pack ('VVVV',$length,$minchar,$width,$height); # header
+
+for (my $i = $minchar; $i <= $maxchar; $i++) {
+ $data[$i] = '' unless defined $data[$i];
+ $data[$i] = '0' x ($width * $height - length $data[$i]) . $data[$i];
+ print pack('C*',split '',$data[$i]);
+}
+
+print STDERR "Successfully converted $length ${width}x$}height} characters\n";
+
+__END__
+
+=head1 NAME
+
+bdf2gdfont.pl - Convert X11 "BDF" fonts into a loadable font format for GD.
+
+=head1 SYNOPSIS
+
+ % bdf2gdfont.pl courR12.bdf > courR12.fnt
+
+=head1 DESCRIPTION
+
+This script converts BDF-style X11 font files into a format that can
+be loaded by the GD module using the GD::Font->load() method. There
+are a number of ways to obtain BDF fonts.
+
+=over 4
+
+=item 1. The font is already present on your system.
+
+Some BDF fonts can be found in the standard X11R6 distribution. This
+script will automatically uncompress gzipped font files if their
+extension ends with .gz (the gunzip program must be on your path).
+
+=item 2. From a font server.
+
+The "fstobdf" utility, a standard X11 utility, will read a named font
+from the font server of your choice and return it in BDF format. You
+can pipe it to bdf2gdfont.pl:
+
+ fstobdf -s fontserverhost:7100 -fn 8x16 | bdf2gdfont.pl > newfont.fnt
+
+Use xlsfonts to find out what fonts are available. Most fonts will
+have long names like
+-B&H-LucidaTypewriter-Bold-R-Normal-Sans-18-180-75-75-M-110-ISO8859-10.
+
+=item 3. Using the pcf2bdf utility.
+
+Some fonts are only available in PCF (compiled) format. To obtain
+these, you can either turn on a font server and follow recipe (2), or
+use TAGA Nayuta's pcf2bdf utility. This utility is available from
+http://www.tsg.ne.jp/GANA/S/pcf2bdf/ (page is in Japanese, but you can
+find the download link).
+
+=back
+
+=head2 Limitations
+
+This font converter only works with fixed-width fonts. If used with a
+TrueType or proportional font it will die with an error message.
+
+=head1 SEE ALSO
+
+L<GD>
+
+=head1 AUTHOR
+
+Lincoln Stein <lstein@cshl.org>, heavily adapted from bdftogd from
+Jan Pazdziora <adelton@fi.muni.cz>.
+
+Copyright (c) 2004 Cold Spring Harbor Laboratory
+
+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.straw/bin/c2ph.bat b/Master/tlpkg/tlperl.straw/bin/c2ph.bat
new file mode 100755
index 00000000000..84937d17f3c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/c2ph.bat
@@ -0,0 +1,1383 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+#
+#
+# c2ph (aka pstruct)
+# Tom Christiansen, <tchrist@convex.com>
+#
+# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+# As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+# See the usage message for more. If this isn't enough, read the code.
+#
+
+=head1 NAME
+
+c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
+
+=head1 SYNOPSIS
+
+ c2ph [-dpnP] [var=val] [files ...]
+
+=head2 OPTIONS
+
+ Options:
+
+ -w wide; short for: type_width=45 member_width=35 offset_width=8
+ -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+ -n do not generate perl code (default when invoked as pstruct)
+ -p generate perl code (default when invoked as c2ph)
+ -v generate perl code, with C decls as comments
+
+ -i do NOT recompute sizes for intrinsic datatypes
+ -a dump information on intrinsics also
+
+ -t trace execution
+ -d spew reams of debugging output
+
+ -slist give comma-separated list a structures to dump
+
+=head1 DESCRIPTION
+
+The following is the old c2ph.doc documentation by Tom Christiansen
+<tchrist@perl.com>
+Date: 25 Jul 91 08:10:21 GMT
+
+Once upon a time, I wrote a program called pstruct. It was a perl
+program that tried to parse out C structures and display their member
+offsets for you. This was especially useful for people looking at
+binary dumps or poking around the kernel.
+
+Pstruct was not a pretty program. Neither was it particularly robust.
+The problem, you see, was that the C compiler was much better at parsing
+C than I could ever hope to be.
+
+So I got smart: I decided to be lazy and let the C compiler parse the C,
+which would spit out debugger stabs for me to read. These were much
+easier to parse. It's still not a pretty program, but at least it's more
+robust.
+
+Pstruct takes any .c or .h files, or preferably .s ones, since that's
+the format it is going to massage them into anyway, and spits out
+listings like this:
+
+ struct tty {
+ int tty.t_locker 000 4
+ int tty.t_mutex_index 004 4
+ struct tty * tty.t_tp_virt 008 4
+ struct clist tty.t_rawq 00c 20
+ int tty.t_rawq.c_cc 00c 4
+ int tty.t_rawq.c_cmax 010 4
+ int tty.t_rawq.c_cfx 014 4
+ int tty.t_rawq.c_clx 018 4
+ struct tty * tty.t_rawq.c_tp_cpu 01c 4
+ struct tty * tty.t_rawq.c_tp_iop 020 4
+ unsigned char * tty.t_rawq.c_buf_cpu 024 4
+ unsigned char * tty.t_rawq.c_buf_iop 028 4
+ struct clist tty.t_canq 02c 20
+ int tty.t_canq.c_cc 02c 4
+ int tty.t_canq.c_cmax 030 4
+ int tty.t_canq.c_cfx 034 4
+ int tty.t_canq.c_clx 038 4
+ struct tty * tty.t_canq.c_tp_cpu 03c 4
+ struct tty * tty.t_canq.c_tp_iop 040 4
+ unsigned char * tty.t_canq.c_buf_cpu 044 4
+ unsigned char * tty.t_canq.c_buf_iop 048 4
+ struct clist tty.t_outq 04c 20
+ int tty.t_outq.c_cc 04c 4
+ int tty.t_outq.c_cmax 050 4
+ int tty.t_outq.c_cfx 054 4
+ int tty.t_outq.c_clx 058 4
+ struct tty * tty.t_outq.c_tp_cpu 05c 4
+ struct tty * tty.t_outq.c_tp_iop 060 4
+ unsigned char * tty.t_outq.c_buf_cpu 064 4
+ unsigned char * tty.t_outq.c_buf_iop 068 4
+ (*int)() tty.t_oproc_cpu 06c 4
+ (*int)() tty.t_oproc_iop 070 4
+ (*int)() tty.t_stopproc_cpu 074 4
+ (*int)() tty.t_stopproc_iop 078 4
+ struct thread * tty.t_rsel 07c 4
+
+etc.
+
+
+Actually, this was generated by a particular set of options. You can control
+the formatting of each column, whether you prefer wide or fat, hex or decimal,
+leading zeroes or whatever.
+
+All you need to be able to use this is a C compiler than generates
+BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
+should get this for you.
+
+To learn more, just type a bogus option, like B<-\?>, and a long usage message
+will be provided. There are a fair number of possibilities.
+
+If you're only a C programmer, than this is the end of the message for you.
+You can quit right now, and if you care to, save off the source and run it
+when you feel like it. Or not.
+
+
+
+But if you're a perl programmer, then for you I have something much more
+wondrous than just a structure offset printer.
+
+You see, if you call pstruct by its other incybernation, c2ph, you have a code
+generator that translates C code into perl code! Well, structure and union
+declarations at least, but that's quite a bit.
+
+Prior to this point, anyone programming in perl who wanted to interact
+with C programs, like the kernel, was forced to guess the layouts of
+the C structures, and then hardwire these into his program. Of course,
+when you took your wonderfully crafted program to a system where the
+sgtty structure was laid out differently, your program broke. Which is
+a shame.
+
+We've had Larry's h2ph translator, which helped, but that only works on
+cpp symbols, not real C, which was also very much needed. What I offer
+you is a symbolic way of getting at all the C structures. I've couched
+them in terms of packages and functions. Consider the following program:
+
+ #!/usr/local/bin/perl
+
+ require 'syscall.ph';
+ require 'sys/time.ph';
+ require 'sys/resource.ph';
+
+ $ru = "\0" x &rusage'sizeof();
+
+ syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
+
+ @ru = unpack($t = &rusage'typedef(), $ru);
+
+ $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
+
+ $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
+
+ printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
+
+
+As you see, the name of the package is the name of the structure. Regular
+fields are just their own names. Plus the following accessor functions are
+provided for your convenience:
+
+ struct This takes no arguments, and is merely the number of first-level
+ elements in the structure. You would use this for indexing
+ into arrays of structures, perhaps like this
+
+
+ $usec = $u[ &user'u_utimer
+ + (&ITIMER_VIRTUAL * &itimerval'struct)
+ + &itimerval'it_value
+ + &timeval'tv_usec
+ ];
+
+ sizeof Returns the bytes in the structure, or the member if
+ you pass it an argument, such as
+
+ &rusage'sizeof(&rusage'ru_utime)
+
+ typedef This is the perl format definition for passing to pack and
+ unpack. If you ask for the typedef of a nothing, you get
+ the whole structure, otherwise you get that of the member
+ you ask for. Padding is taken care of, as is the magic to
+ guarantee that a union is unpacked into all its aliases.
+ Bitfields are not quite yet supported however.
+
+ offsetof This function is the byte offset into the array of that
+ member. You may wish to use this for indexing directly
+ into the packed structure with vec() if you're too lazy
+ to unpack it.
+
+ typeof Not to be confused with the typedef accessor function, this
+ one returns the C type of that field. This would allow
+ you to print out a nice structured pretty print of some
+ structure without knoning anything about it beforehand.
+ No args to this one is a noop. Someday I'll post such
+ a thing to dump out your u structure for you.
+
+
+The way I see this being used is like basically this:
+
+ % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
+ % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
+ % install
+
+It's a little tricker with c2ph because you have to get the includes right.
+I can't know this for your system, but it's not usually too terribly difficult.
+
+The code isn't pretty as I mentioned -- I never thought it would be a 1000-
+line program when I started, or I might not have begun. :-) But I would have
+been less cavalier in how the parts of the program communicated with each
+other, etc. It might also have helped if I didn't have to divine the makeup
+of the stabs on the fly, and then account for micro differences between my
+compiler and gcc.
+
+Anyway, here it is. Should run on perl v4 or greater. Maybe less.
+
+
+ --tom
+
+=cut
+
+$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
+
+use File::Temp;
+
+######################################################################
+
+# some handy data definitions. many of these can be reset later.
+
+$bitorder = 'b'; # ascending; set to B for descending bit fields
+
+%intrinsics =
+%template = (
+ 'char', 'c',
+ 'unsigned char', 'C',
+ 'short', 's',
+ 'short int', 's',
+ 'unsigned short', 'S',
+ 'unsigned short int', 'S',
+ 'short unsigned int', 'S',
+ 'int', 'i',
+ 'unsigned int', 'I',
+ 'long', 'l',
+ 'long int', 'l',
+ 'unsigned long', 'L',
+ 'unsigned long', 'L',
+ 'long unsigned int', 'L',
+ 'unsigned long int', 'L',
+ 'long long', 'q',
+ 'long long int', 'q',
+ 'unsigned long long', 'Q',
+ 'unsigned long long int', 'Q',
+ 'float', 'f',
+ 'double', 'd',
+ 'pointer', 'p',
+ 'null', 'x',
+ 'neganull', 'X',
+ 'bit', $bitorder,
+);
+
+&buildscrunchlist;
+delete $intrinsics{'neganull'};
+delete $intrinsics{'bit'};
+delete $intrinsics{'null'};
+
+# use -s to recompute sizes
+%sizeof = (
+ 'char', '1',
+ 'unsigned char', '1',
+ 'short', '2',
+ 'short int', '2',
+ 'unsigned short', '2',
+ 'unsigned short int', '2',
+ 'short unsigned int', '2',
+ 'int', '4',
+ 'unsigned int', '4',
+ 'long', '4',
+ 'long int', '4',
+ 'unsigned long', '4',
+ 'unsigned long int', '4',
+ 'long unsigned int', '4',
+ 'long long', '8',
+ 'long long int', '8',
+ 'unsigned long long', '8',
+ 'unsigned long long int', '8',
+ 'float', '4',
+ 'double', '8',
+ 'pointer', '4',
+);
+
+($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
+
+($offset_fmt, $size_fmt) = ('d', 'd');
+
+$indent = 2;
+
+$CC = 'cc';
+$CFLAGS = '-gstabs -S';
+$DEFINES = '';
+
+$perl++ if $0 =~ m#/?c2ph$#;
+
+require 'getopts.pl';
+
+use File::Temp 'tempdir';
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+&Getopts('aixdpvtnws:') || &usage(0);
+
+$opt_d && $debug++;
+$opt_t && $trace++;
+$opt_p && $perl++;
+$opt_v && $verbose++;
+$opt_n && ($perl = 0);
+
+if ($opt_w) {
+ ($type_width, $member_width, $offset_width) = (45, 35, 8);
+}
+if ($opt_x) {
+ ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
+}
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+sub PLUMBER {
+ select(STDERR);
+ print "oops, apperent pager foulup\n";
+ $isatty++;
+ &usage(1);
+}
+
+sub usage {
+ local($oops) = @_;
+ unless (-t STDOUT) {
+ select(STDERR);
+ } elsif (!$oops) {
+ $isatty++;
+ $| = 1;
+ print "hit <RETURN> for further explanation: ";
+ <STDIN>;
+ open (PIPE, "|". ($ENV{PAGER} || 'more'));
+ $SIG{PIPE} = PLUMBER;
+ select(PIPE);
+ }
+
+ print "usage: $0 [-dpnP] [var=val] [files ...]\n";
+
+ exit unless $isatty;
+
+ print <<EOF;
+
+Options:
+
+-w wide; short for: type_width=45 member_width=35 offset_width=8
+-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+-n do not generate perl code (default when invoked as pstruct)
+-p generate perl code (default when invoked as c2ph)
+-v generate perl code, with C decls as comments
+
+-i do NOT recompute sizes for intrinsic datatypes
+-a dump information on intrinsics also
+
+-t trace execution
+-d spew reams of debugging output
+
+-slist give comma-separated list a structures to dump
+
+
+Var Name Default Value Meaning
+
+EOF
+
+ &defvar('CC', 'which_compiler to call');
+ &defvar('CFLAGS', 'how to generate *.s files with stabs');
+ &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
+
+ print "\n";
+
+ &defvar('type_width', 'width of type field (column 1)');
+ &defvar('member_width', 'width of member field (column 2)');
+ &defvar('offset_width', 'width of offset field (column 3)');
+ &defvar('size_width', 'width of size field (column 4)');
+
+ print "\n";
+
+ &defvar('offset_fmt', 'sprintf format type for offset');
+ &defvar('size_fmt', 'sprintf format type for size');
+
+ print "\n";
+
+ &defvar('indent', 'how far to indent each nesting level');
+
+ print <<'EOF';
+
+ If any *.[ch] files are given, these will be catted together into
+ a temporary *.c file and sent through:
+ $CC $CFLAGS $DEFINES
+ and the resulting *.s groped for stab information. If no files are
+ supplied, then stdin is read directly with the assumption that it
+ contains stab information. All other lines will be ignored. At
+ most one *.s file should be supplied.
+
+EOF
+ close PIPE;
+ exit 1;
+}
+
+sub defvar {
+ local($var, $msg) = @_;
+ printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
+}
+
+sub safedir {
+ $SAFEDIR = File::Temp::tempdir("c2ph.XXXXXX", TMPDIR => 1, CLEANUP => 1)
+ unless (defined($SAFEDIR));
+}
+
+undef $SAFEDIR;
+
+$recurse = 1;
+
+if (@ARGV) {
+ if (grep(!/\.[csh]$/,@ARGV)) {
+ warn "Only *.[csh] files expected!\n";
+ &usage;
+ }
+ elsif (grep(/\.s$/,@ARGV)) {
+ if (@ARGV > 1) {
+ warn "Only one *.s file allowed!\n";
+ &usage;
+ }
+ }
+ elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
+ local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
+ $chdir = "cd $dir && " if $dir;
+ &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
+ $ARGV[0] =~ s/\.c$/.s/;
+ }
+ else {
+ &safedir;
+ $TMP = "$SAFEDIR/c2ph.$$.c";
+ &system("cat @ARGV > $TMP") && exit 1;
+ &system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1;
+ unlink $TMP;
+ $TMP =~ s/\.c$/.s/;
+ @ARGV = ($TMP);
+ }
+}
+
+if ($opt_s) {
+ for (split(/[\s,]+/, $opt_s)) {
+ $interested{$_}++;
+ }
+}
+
+
+$| = 1 if $debug;
+
+main: {
+
+ if ($trace) {
+ if (-t && !@ARGV) {
+ print STDERR "reading from your keyboard: ";
+ } else {
+ print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
+ }
+ }
+
+STAB: while (<>) {
+ if ($trace && !($. % 10)) {
+ $lineno = $..'';
+ print STDERR $lineno, "\b" x length($lineno);
+ }
+ next unless /^\s*\.stabs\s+/;
+ $line = $_;
+ s/^\s*\.stabs\s+//;
+ if (s/\\\\"[d,]+$//) {
+ $saveline .= $line;
+ $savebar = $_;
+ next STAB;
+ }
+ if ($saveline) {
+ s/^"//;
+ $_ = $savebar . $_;
+ $line = $saveline;
+ }
+ &stab;
+ $savebar = $saveline = undef;
+ }
+ print STDERR "$.\n" if $trace;
+ unlink $TMP if $TMP;
+
+ &compute_intrinsics if $perl && !$opt_i;
+
+ print STDERR "resolving types\n" if $trace;
+
+ &resolve_types;
+ &adjust_start_addrs;
+
+ $sum = 2 + $type_width + $member_width;
+ $pmask1 = "%-${type_width}s %-${member_width}s";
+ $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
+
+
+
+ if ($perl) {
+ # resolve template -- should be in stab define order, but even this isn't enough.
+ print STDERR "\nbuilding type templates: " if $trace;
+ for $i (reverse 0..$#type) {
+ next unless defined($name = $type[$i]);
+ next unless defined $struct{$name};
+ ($iname = $name) =~ s/\..*//;
+ $build_recursed = 0;
+ &build_template($name) unless defined $template{&psou($name)} ||
+ $opt_s && !$interested{$iname};
+ }
+ print STDERR "\n\n" if $trace;
+ }
+
+ print STDERR "dumping structs: " if $trace;
+
+ local($iam);
+
+
+
+ foreach $name (sort keys %struct) {
+ ($iname = $name) =~ s/\..*//;
+ next if $opt_s && !$interested{$iname};
+ print STDERR "$name " if $trace;
+
+ undef @sizeof;
+ undef @typedef;
+ undef @offsetof;
+ undef @indices;
+ undef @typeof;
+ undef @fieldnames;
+
+ $mname = &munge($name);
+
+ $fname = &psou($name);
+
+ print "# " if $perl && $verbose;
+ $pcode = '';
+ print "$fname {\n" if !$perl || $verbose;
+ $template{$fname} = &scrunch($template{$fname}) if $perl;
+ &pstruct($name,$name,0);
+ print "# " if $perl && $verbose;
+ print "}\n" if !$perl || $verbose;
+ print "\n" if $perl && $verbose;
+
+ if ($perl) {
+ print "$pcode";
+
+ printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
+
+ print <<EOF;
+sub ${mname}'typedef {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'typedef[\$${mname}'index]
+ : \$${mname}'typedef;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'sizeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'sizeof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'offsetof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'offsetof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'typeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'typeof[\$${mname}'index]
+ : '$name';
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'fieldnames {
+ \@${mname}'fieldnames;
+}
+EOF
+
+ $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
+
+ print <<EOF;
+sub ${mname}'isastruct {
+ '$iam';
+}
+EOF
+
+ print "\$${mname}'typedef = '" . &scrunch($template{$fname})
+ . "';\n";
+
+ print "\$${mname}'sizeof = $sizeof{$name};\n\n";
+
+
+ print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
+
+ print "\n";
+
+ print "\@${mname}'typedef[\@${mname}'indices] = (",
+ join("\n\t", '', @typedef), "\n );\n\n";
+ print "\@${mname}'sizeof[\@${mname}'indices] = (",
+ join("\n\t", '', @sizeof), "\n );\n\n";
+ print "\@${mname}'offsetof[\@${mname}'indices] = (",
+ join("\n\t", '', @offsetof), "\n );\n\n";
+ print "\@${mname}'typeof[\@${mname}'indices] = (",
+ join("\n\t", '', @typeof), "\n );\n\n";
+ print "\@${mname}'fieldnames[\@${mname}'indices] = (",
+ join("\n\t", '', @fieldnames), "\n );\n\n";
+
+ $template_printed{$fname}++;
+ $size_printed{$fname}++;
+ }
+ print "\n";
+ }
+
+ print STDERR "\n" if $trace;
+
+ unless ($perl && $opt_a) {
+ print "\n1;\n" if $perl;
+ exit;
+ }
+
+
+
+ foreach $name (sort bysizevalue keys %intrinsics) {
+ next if $size_printed{$name};
+ print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
+ }
+
+ print "\n";
+
+ sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
+
+
+ foreach $name (sort keys %intrinsics) {
+ print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
+ }
+
+ print "\n1;\n" if $perl;
+
+ exit;
+}
+
+########################################################################################
+
+
+sub stab {
+ next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
+ s/"// || next;
+ s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
+
+ next if /^\s*$/;
+
+ $size = $3 if $3;
+ $_ = $continued . $_ if length($continued);
+ if (s/\\\\$//) {
+ # if last 2 chars of string are '\\' then stab is continued
+ # in next stab entry
+ chop;
+ $continued = $_;
+ next;
+ }
+ $continued = '';
+
+
+ $line = $_;
+
+ if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
+ print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
+ &pdecl($pdecl);
+ next;
+ }
+
+
+
+ if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
+ local($ident) = $2;
+ push(@intrinsics, $ident);
+ $typeno = &typeno($3);
+ $type[$typeno] = $ident;
+ print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
+ next;
+ }
+
+ if (($name, $typeordef, $typeno, $extra, $struct, $_)
+ = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
+ {
+ $typeno = &typeno($typeno); # sun foolery
+ }
+ elsif (/^[\$\w]+:/) {
+ next; # variable
+ }
+ else {
+ warn "can't grok stab: <$_> in: $line " if $_;
+ next;
+ }
+
+ #warn "got size $size for $name\n";
+ $sizeof{$name} = $size if $size;
+
+ s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
+
+ $typenos{$name} = $typeno;
+
+ unless (defined $type[$typeno]) {
+ &panic("type 0??") unless $typeno;
+ $type[$typeno] = $name unless defined $type[$typeno];
+ printf "new type $typeno is $name" if $debug;
+ if ($extra =~ /\*/ && defined $type[$struct]) {
+ print ", a typedef for a pointer to " , $type[$struct] if $debug;
+ }
+ } else {
+ printf "%s is type %d", $name, $typeno if $debug;
+ print ", a typedef for " , $type[$typeno] if $debug;
+ }
+ print "\n" if $debug;
+ #next unless $extra =~ /[su*]/;
+
+ #$type[$struct] = $name;
+
+ if ($extra =~ /[us*]/) {
+ &sou($name, $extra);
+ $_ = &sdecl($name, $_, 0);
+ }
+ elsif (/^=ar/) {
+ print "it's a bare array typedef -- that's pretty sick\n" if $debug;
+ $_ = "$typeno$_";
+ $scripts = '';
+ $_ = &adecl($_,1);
+
+ }
+ elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
+ push(@intrinsics, $2);
+ $typeno = &typeno($3);
+ $type[$typeno] = $2;
+ print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
+ }
+ elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
+ &edecl;
+ }
+ else {
+ warn "Funny remainder for $name on line $_ left in $line " if $_;
+ }
+}
+
+sub typeno { # sun thinks types are (0,27) instead of just 27
+ local($_) = @_;
+ s/\(\d+,(\d+)\)/$1/;
+ $_;
+}
+
+sub pstruct {
+ local($what,$prefix,$base) = @_;
+ local($field, $fieldname, $typeno, $count, $offset, $entry);
+ local($fieldtype);
+ local($type, $tname);
+ local($mytype, $mycount, $entry2);
+ local($struct_count) = 0;
+ local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
+ local($bits,$bytes);
+ local($template);
+
+
+ local($mname) = &munge($name);
+
+ sub munge {
+ local($_) = @_;
+ s/[\s\$\.]/_/g;
+ $_;
+ }
+
+ local($sname) = &psou($what);
+
+ $nesting++;
+
+ for $field (split(/;/, $struct{$what})) {
+ $pad = $prepad = 0;
+ $entry = '';
+ ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
+
+ $type = $type[$typeno];
+
+ $type =~ /([^[]*)(\[.*\])?/;
+ $mytype = $1;
+ $count .= $2;
+ $fieldtype = &psou($mytype);
+
+ local($fname) = &psou($name);
+
+ if ($build_templates) {
+
+ $pad = ($offset - ($lastoffset + $lastlength))/8
+ if defined $lastoffset;
+
+ if (! $finished_template{$sname}) {
+ if ($isaunion{$what}) {
+ $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
+ } else {
+ $template{$sname} .= 'x' x $pad . ' ' if $pad;
+ }
+ }
+
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+
+ if (! $finished_template{$sname}) {
+ $template{$sname} .= $template;
+ }
+
+ $revpad = $length/8 if $isaunion{$what};
+
+ ($lastoffset, $lastlength) = ($offset, $length);
+
+ } else {
+ print '# ' if $perl && $verbose;
+ $entry = sprintf($pmask1,
+ ' ' x ($nesting * $indent) . $fieldtype,
+ "$prefix.$fieldname" . $count);
+
+ $entry =~ s/(\*+)( )/$2$1/;
+
+ printf $pmask2,
+ $entry,
+ ($base+$offset)/8,
+ ($bits = ($base+$offset)%8) ? ".$bits" : " ",
+ $length/8,
+ ($bits = $length % 8) ? ".$bits": ""
+ if !$perl || $verbose;
+
+ if ($perl) {
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+ }
+
+ if ($perl && $nesting == 1) {
+
+ push(@sizeof, int($length/8) .",\t# $fieldname");
+ push(@offsetof, int($offset/8) .",\t# $fieldname");
+ local($little) = &scrunch($template);
+ push(@typedef, "'$little', \t# $fieldname");
+ $type =~ s/(struct|union) //;
+ push(@typeof, "'$mytype" . ($count ? $count : '') .
+ "',\t# $fieldname");
+ push(@fieldnames, "'$fieldname',");
+ }
+
+ print ' ', ' ' x $indent x $nesting, $template
+ if $perl && $verbose;
+
+ print "\n" if !$perl || $verbose;
+
+ }
+ if ($perl) {
+ local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
+ $mycount *= &scripts2count($count) if $count;
+ if ($nesting==1 && !$build_templates) {
+ $pcode .= sprintf("sub %-32s { %4d; }\n",
+ "${mname}'${fieldname}", $struct_count);
+ push(@indices, $struct_count);
+ }
+ $struct_count += $mycount;
+ }
+
+
+ &pstruct($type, "$prefix.$fieldname", $base+$offset)
+ if $recurse && defined $struct{$type};
+ }
+
+ $countof{$what} = $struct_count unless defined $countof{$whati};
+
+ $template{$sname} .= '$' if $build_templates;
+ $finished_template{$sname}++;
+
+ if ($build_templates && !defined $sizeof{$name}) {
+ local($fmt) = &scrunch($template{$sname});
+ print STDERR "no size for $name, punting with $fmt..." if $debug;
+ eval '$sizeof{$name} = length(pack($fmt, ()))';
+ if ($@) {
+ chop $@;
+ warn "couldn't get size for \$name: $@";
+ } else {
+ print STDERR $sizeof{$name}, "\n" if $debUg;
+ }
+ }
+
+ --$nesting;
+}
+
+
+sub psize {
+ local($me) = @_;
+ local($amstruct) = $struct{$me} ? 'struct ' : '';
+
+ print '$sizeof{\'', $amstruct, $me, '\'} = ';
+ printf "%d;\n", $sizeof{$me};
+}
+
+sub pdecl {
+ local($pdecl) = @_;
+ local(@pdecls);
+ local($tname);
+
+ warn "pdecl: $pdecl\n" if $debug;
+
+ $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
+ $pdecl =~ s/\*//g;
+ @pdecls = split(/=/, $pdecl);
+ $typeno = $pdecls[0];
+ $tname = pop @pdecls;
+
+ if ($tname =~ s/^f//) { $tname = "$tname&"; }
+ #else { $tname = "$tname*"; }
+
+ for (reverse @pdecls) {
+ $tname .= s/^f// ? "&" : "*";
+ #$tname =~ s/^f(.*)/$1&/;
+ print "type[$_] is $tname\n" if $debug;
+ $type[$_] = $tname unless defined $type[$_];
+ }
+}
+
+
+
+sub adecl {
+ ($arraytype, $unknown, $lower, $upper) = ();
+ #local($typeno);
+ # global $typeno, @type
+ local($_, $typedef) = @_;
+
+ while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
+ ($arraytype, $unknown) = ($2, $3);
+ $arraytype = &typeno($arraytype);
+ $unknown = &typeno($unknown);
+ if (s/^(\d+);(\d+);//) {
+ ($lower, $upper) = ($1, $2);
+ $scripts .= '[' . ($upper+1) . ']';
+ } else {
+ warn "can't find array bounds: $_";
+ }
+ }
+ if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ $whatis = $1;
+ if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
+ $typeno = &typeno($1);
+ &pdecl($whatis);
+ } else {
+ $typeno = &typeno($whatis);
+ }
+ } elsif (s/^(\d+)(=[*suf]\d*)//) {
+ local($whatis) = $2;
+
+ if ($whatis =~ /[f*]/) {
+ &pdecl($whatis);
+ } elsif ($whatis =~ /[su]/) { #
+ print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
+ if $debug;
+ #$type[$typeno] = $name unless defined $type[$typeno];
+ ##printf "new type $typeno is $name" if $debug;
+ $typeno = $1;
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = $type[$typeno];
+ &sou($name, $whatis);
+ $_ = &sdecl($name, $_, $start+$offset);
+ 1;
+ $start = $start{$name};
+ $offset = $sizeof{$name};
+ $length = $offset;
+ } else {
+ warn "what's this? $whatis in $line ";
+ }
+ } elsif (/^\d+$/) {
+ $typeno = $_;
+ } else {
+ warn "bad array stab: $_ in $line ";
+ next STAB;
+ }
+ #local($wasdef) = defined($type[$typeno]) && $debug;
+ #if ($typedef) {
+ #print "redefining $type[$typeno] to " if $wasdef;
+ #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
+ #print "$type[$typeno]\n" if $wasdef;
+ #} else {
+ #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
+ #}
+ $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
+ print "type[$arraytype] is $type[$arraytype]\n" if $debug;
+ print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
+ $_;
+}
+
+
+
+sub sdecl {
+ local($prefix, $_, $offset) = @_;
+
+ local($fieldname, $scripts, $type, $arraytype, $unknown,
+ $whatis, $pdecl, $upper,$lower, $start,$length) = ();
+ local($typeno,$sou);
+
+
+SFIELD:
+ while (/^([^;]+);/) {
+ $scripts = '';
+ warn "sdecl $_\n" if $debug;
+ if (s/^([\$\w]+)://) {
+ $fieldname = $1;
+ } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
+ $typeno = &typeno($1);
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$2);
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $offset += $sizeof{$name};
+ #print "done with anon, start is $start, offset is $offset\n";
+ #next SFIELD;
+ } else {
+ warn "weird field $_ of $line" if $debug;
+ next STAB;
+ #$fieldname = &gensym;
+ #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ }
+
+ if (/^(\d+|\(\d+,\d+\))=ar/) {
+ $_ = &adecl($_);
+ }
+ elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
+ ($pdecl, $start, $length) = ($1,$5,$6);
+ &pdecl($pdecl);
+ }
+ elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
+ ($typeno, $sou) = ($1, $2);
+ $typeno = &typeno($typeno);
+ if (defined($type[$typeno])) {
+ warn "now how did we get type $1 in $fieldname of $line?";
+ } else {
+ print "anon type $typeno is $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
+ };
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$sou);
+ print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname";
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $length = $sizeof{$name};
+ }
+ else {
+ warn "can't grok stab for $name ($_) in line $line ";
+ next STAB;
+ }
+
+ &panic("no length for $prefix.$fieldname") unless $length;
+ $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
+ }
+ if (s/;\d*,(\d+),(\d+);//) {
+ local($start, $size) = ($1, $2);
+ $sizeof{$prefix} = $size;
+ print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
+ $start{$prefix} = $start;
+ }
+ $_;
+}
+
+sub edecl {
+ s/;$//;
+ $enum{$name} = $_;
+ $_ = '';
+}
+
+sub resolve_types {
+ local($sou);
+ for $i (0 .. $#type) {
+ next unless defined $type[$i];
+ $_ = $type[$i];
+ unless (/\d/) {
+ print "type[$i] $type[$i]\n" if $debug;
+ next;
+ }
+ print "type[$i] $_ ==> " if $debug;
+ s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
+ s/^(\d+)\&/&type($1)/e;
+ s/^(\d+)/&type($1)/e;
+ s/(\*+)([^*]+)(\*+)/$1$3$2/;
+ s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
+ s/^(\d+)([\*\[].*)/&type($1).$2/e;
+ #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
+ $type[$i] = $_;
+ print "$_\n" if $debug;
+ }
+}
+sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
+
+sub adjust_start_addrs {
+ for (sort keys %start) {
+ ($basename = $_) =~ s/\.[^.]+$//;
+ $start{$_} += $start{$basename};
+ print "start: $_ @ $start{$_}\n" if $debug;
+ }
+}
+
+sub sou {
+ local($what, $_) = @_;
+ /u/ && $isaunion{$what}++;
+ /s/ && $isastruct{$what}++;
+}
+
+sub psou {
+ local($what) = @_;
+ local($prefix) = '';
+ if ($isaunion{$what}) {
+ $prefix = 'union ';
+ } elsif ($isastruct{$what}) {
+ $prefix = 'struct ';
+ }
+ $prefix . $what;
+}
+
+sub scrunch {
+ local($_) = @_;
+
+ return '' if $_ eq '';
+
+ study;
+
+ s/\$//g;
+ s/ / /g;
+ 1 while s/(\w) \1/$1$1/g;
+
+ # i wanna say this, but perl resists my efforts:
+ # s/(\w)(\1+)/$2 . length($1)/ge;
+
+ &quick_scrunch;
+
+ s/ $//;
+
+ $_;
+}
+
+sub buildscrunchlist {
+ $scrunch_code = "sub quick_scrunch {\n";
+ for (values %intrinsics) {
+ $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
+ }
+ $scrunch_code .= "}\n";
+ print "$scrunch_code" if $debug;
+ eval $scrunch_code;
+ &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
+}
+
+sub fetch_template {
+ local($mytype) = @_;
+ local($fmt);
+ local($count) = 1;
+
+ &panic("why do you care?") unless $perl;
+
+ if ($mytype =~ s/(\[\d+\])+$//) {
+ $count .= $1;
+ }
+
+ if ($mytype =~ /\*/) {
+ $fmt = $template{'pointer'};
+ }
+ elsif (defined $template{$mytype}) {
+ $fmt = $template{$mytype};
+ }
+ elsif (defined $struct{$mytype}) {
+ if (!defined $template{&psou($mytype)}) {
+ &build_template($mytype) unless $mytype eq $name;
+ }
+ elsif ($template{&psou($mytype)} !~ /\$$/) {
+ #warn "incomplete template for $mytype\n";
+ }
+ $fmt = $template{&psou($mytype)} || '?';
+ }
+ else {
+ warn "unknown fmt for $mytype\n";
+ $fmt = '?';
+ }
+
+ $fmt x $count . ' ';
+}
+
+sub compute_intrinsics {
+ &safedir;
+ local($TMP) = "$SAFEDIR/c2ph-i.$$.c";
+ open (TMP, ">$TMP") || die "can't open $TMP: $!";
+ select(TMP);
+
+ print STDERR "computing intrinsic sizes: " if $trace;
+
+ undef %intrinsics;
+
+ print <<'EOF';
+main() {
+ char *mask = "%d %s\n";
+EOF
+
+ for $type (@intrinsics) {
+ next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
+ print <<"EOF";
+ printf(mask,sizeof($type), "$type");
+EOF
+ }
+
+ print <<'EOF';
+ printf(mask,sizeof(char *), "pointer");
+ exit(0);
+}
+EOF
+ close TMP;
+
+ select(STDOUT);
+ open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|");
+ while (<PIPE>) {
+ chop;
+ split(' ',$_,2);;
+ print "intrinsic $_[1] is size $_[0]\n" if $debug;
+ $sizeof{$_[1]} = $_[0];
+ $intrinsics{$_[1]} = $template{$_[0]};
+ }
+ close(PIPE) || die "couldn't read intrinsics!";
+ unlink($TMP, "$SAFEDIR/a.out");
+ print STDERR "done\n" if $trace;
+}
+
+sub scripts2count {
+ local($_) = @_;
+
+ s/^\[//;
+ s/\]$//;
+ s/\]\[/*/g;
+ $_ = eval;
+ &panic("$_: $@") if $@;
+ $_;
+}
+
+sub system {
+ print STDERR "@_\n" if $trace;
+ system @_;
+}
+
+sub build_template {
+ local($name) = @_;
+
+ &panic("already got a template for $name") if defined $template{$name};
+
+ local($build_templates) = 1;
+
+ local($lparen) = '(' x $build_recursed;
+ local($rparen) = ')' x $build_recursed;
+
+ print STDERR "$lparen$name$rparen " if $trace;
+ $build_recursed++;
+ &pstruct($name,$name,0);
+ print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
+ --$build_recursed;
+}
+
+
+sub panic {
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ local($i,$_);
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @DB'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(@sub, "$w&$s$a from file $f line $l\n");
+ last if $signal;
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+sub squishseq {
+ local($num);
+ local($last) = -1e8;
+ local($string);
+ local($seq) = '..';
+
+ while (defined($num = shift)) {
+ if ($num == ($last + 1)) {
+ $string .= $seq unless $inseq++;
+ $last = $num;
+ next;
+ } elsif ($inseq) {
+ $string .= $last unless $last == -1e8;
+ }
+
+ $string .= ',' if defined $string;
+ $string .= $num;
+ $last = $num;
+ $inseq = 0;
+ }
+ $string .= $last if $inseq && $last != -e18;
+ $string;
+}
+
+sub repeat_template {
+ # local($template, $scripts) = @_; have to change caller's values
+
+ if ( $_[1] ) {
+ local($ncount) = &scripts2count($_[1]);
+ if ($_[0] =~ /^\s*c\s*$/i) {
+ $_[0] = "A$ncount ";
+ $_[1] = '';
+ } else {
+ $_[0] = $template x $ncount;
+ }
+ }
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/config_data b/Master/tlpkg/tlperl.straw/bin/config_data
new file mode 100755
index 00000000000..532fe2406b0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/config_data
@@ -0,0 +1,249 @@
+#!C:\strawberry\perl\bin\perl.exe
+
+use strict;
+use Module::Build 0.25;
+use Getopt::Long;
+
+my %opt_defs = (
+ module => {type => '=s',
+ desc => 'The name of the module to configure (required)'},
+ feature => {type => ':s',
+ desc => 'Print the value of a feature or all features'},
+ config => {type => ':s',
+ desc => 'Print the value of a config option'},
+ set_feature => {type => '=s%',
+ desc => "Set a feature to 'true' or 'false'"},
+ set_config => {type => '=s%',
+ desc => 'Set a config option to the given value'},
+ eval => {type => '',
+ desc => 'eval() config values before setting'},
+ help => {type => '',
+ desc => 'Print a help message and exit'},
+ );
+
+my %opts;
+GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs);
+print usage(%opt_defs) and exit(0)
+ if $opts{help};
+
+my @exclusive = qw(feature config set_feature set_config);
+die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs)
+ unless grep(exists $opts{$_}, @exclusive) == 1;
+
+die "Option --module is required\n" . usage(%opt_defs)
+ unless $opts{module};
+
+my $cf = load_config($opts{module});
+
+if (exists $opts{feature}) {
+
+ if (length $opts{feature}) {
+ print $cf->feature($opts{feature});
+ } else {
+ my %auto;
+ # note: need to support older ConfigData.pm's
+ @auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names");
+
+ print " Features defined in $cf:\n";
+ foreach my $name (sort $cf->feature_names) {
+ print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n";
+ }
+ }
+
+} elsif (exists $opts{config}) {
+
+ require Data::Dumper;
+ local $Data::Dumper::Terse = 1;
+
+ if (length $opts{config}) {
+ print Data::Dumper::Dumper($cf->config($opts{config})), "\n";
+ } else {
+ print " Configuration defined in $cf:\n";
+ foreach my $name (sort $cf->config_names) {
+ print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n";
+ }
+ }
+
+} elsif (exists $opts{set_feature}) {
+ my %to_set = %{$opts{set_feature}};
+ while (my ($k, $v) = each %to_set) {
+ die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/;
+ $cf->set_feature($k, 0+$v); # Cast to a number, not a string
+ }
+ $cf->write;
+ print "Feature" . 's'x(keys(%to_set)>1) . " saved\n";
+
+} elsif (exists $opts{set_config}) {
+
+ my %to_set = %{$opts{set_config}};
+ while (my ($k, $v) = each %to_set) {
+ if ($opts{eval}) {
+ $v = eval($v);
+ die $@ if $@;
+ }
+ $cf->set_config($k, $v);
+ }
+ $cf->write;
+ print "Config value" . 's'x(keys(%to_set)>1) . " saved\n";
+}
+
+sub load_config {
+ my $mod = shift;
+
+ $mod =~ /^([\w:]+)$/
+ or die "Invalid module name '$mod'";
+
+ my $cf = $mod . "::ConfigData";
+ eval "require $cf";
+ die $@ if $@;
+
+ return $cf;
+}
+
+sub usage {
+ my %defs = @_;
+
+ my $out = "\nUsage: $0 [options]\n\n Options include:\n";
+
+ foreach my $name (sort keys %defs) {
+ $out .= " --$name";
+
+ for ($defs{$name}{type}) {
+ /^=s$/ and $out .= " <string>";
+ /^=s%$/ and $out .= " <string>=<value>";
+ }
+
+ pad_line($out, 35);
+ $out .= "$defs{$name}{desc}\n";
+ }
+
+ $out .= <<EOF;
+
+ Examples:
+ $0 --module Foo::Bar --feature bazzable
+ $0 --module Foo::Bar --config magic_number
+ $0 --module Foo::Bar --set_feature bazzable=1
+ $0 --module Foo::Bar --set_config magic_number=42
+
+EOF
+
+ return $out;
+}
+
+sub pad_line { $_[0] .= ' ' x ($_[1] - length($_[0]) + rindex($_[0], "\n")) }
+
+
+__END__
+
+=head1 NAME
+
+config_data - Query or change configuration of Perl modules
+
+=head1 SYNOPSIS
+
+ # Get config/feature values
+ config_data --module Foo::Bar --feature bazzable
+ config_data --module Foo::Bar --config magic_number
+
+ # Set config/feature values
+ config_data --module Foo::Bar --set_feature bazzable=1
+ config_data --module Foo::Bar --set_config magic_number=42
+
+ # Print a usage message
+ config_data --help
+
+=head1 DESCRIPTION
+
+The C<config_data> tool provides a command-line interface to the
+configuration of Perl modules. By "configuration", we mean something
+akin to "user preferences" or "local settings". This is a
+formalization and abstraction of the systems that people like Andreas
+Koenig (C<CPAN::Config>), Jon Swartz (C<HTML::Mason::Config>), Andy
+Wardley (C<Template::Config>), and Larry Wall (perl's own Config.pm)
+have developed independently.
+
+The configuration system emplyed here was developed in the context of
+C<Module::Build>. Under this system, configuration information for a
+module C<Foo>, for example, is stored in a module called
+C<Foo::ConfigData>) (I would have called it C<Foo::Config>, but that
+was taken by all those other systems mentioned in the previous
+paragraph...). These C<...::ConfigData> modules contain the
+configuration data, as well as publically accessible methods for
+querying and setting (yes, actually re-writing) the configuration
+data. The C<config_data> script (whose docs you are currently
+reading) is merely a front-end for those methods. If you wish, you
+may create alternate front-ends.
+
+The two types of data that may be stored are called C<config> values
+and C<feature> values. A C<config> value may be any perl scalar,
+including references to complex data structures. It must, however, be
+serializable using C<Data::Dumper>. A C<feature> is a boolean (1 or
+0) value.
+
+=head1 USAGE
+
+This script functions as a basic getter/setter wrapper around the
+configuration of a single module. On the command line, specify which
+module's configuration you're interested in, and pass options to get
+or set C<config> or C<feature> values. The following options are
+supported:
+
+=over 4
+
+=item module
+
+Specifies the name of the module to configure (required).
+
+=item feature
+
+When passed the name of a C<feature>, shows its value. The value will
+be 1 if the feature is enabled, 0 if the feature is not enabled, or
+empty if the feature is unknown. When no feature name is supplied,
+the names and values of all known features will be shown.
+
+=item config
+
+When passed the name of a C<config> entry, shows its value. The value
+will be displayed using C<Data::Dumper> (or similar) as perl code.
+When no config name is supplied, the names and values of all known
+config entries will be shown.
+
+=item set_feature
+
+Sets the given C<feature> to the given boolean value. Specify the value
+as either 1 or 0.
+
+=item set_config
+
+Sets the given C<config> entry to the given value.
+
+=item eval
+
+If the C<--eval> option is used, the values in C<set_config> will be
+evaluated as perl code before being stored. This allows moderately
+complicated data structures to be stored. For really complicated
+structures, you probably shouldn't use this command-line interface,
+just use the Perl API instead.
+
+=item help
+
+Prints a help message, including a few examples, and exits.
+
+=back
+
+=head1 AUTHOR
+
+Ken Williams, kwilliams@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (c) 1999, Ken Williams. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Module::Build(3), perl(1).
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/config_data.bat b/Master/tlpkg/tlperl.straw/bin/config_data.bat
new file mode 100755
index 00000000000..19604694e39
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/config_data.bat
@@ -0,0 +1,265 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!C:\strawberry\perl\bin\perl.exe
+#line 15
+
+use strict;
+use Module::Build 0.25;
+use Getopt::Long;
+
+my %opt_defs = (
+ module => {type => '=s',
+ desc => 'The name of the module to configure (required)'},
+ feature => {type => ':s',
+ desc => 'Print the value of a feature or all features'},
+ config => {type => ':s',
+ desc => 'Print the value of a config option'},
+ set_feature => {type => '=s%',
+ desc => "Set a feature to 'true' or 'false'"},
+ set_config => {type => '=s%',
+ desc => 'Set a config option to the given value'},
+ eval => {type => '',
+ desc => 'eval() config values before setting'},
+ help => {type => '',
+ desc => 'Print a help message and exit'},
+ );
+
+my %opts;
+GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs);
+print usage(%opt_defs) and exit(0)
+ if $opts{help};
+
+my @exclusive = qw(feature config set_feature set_config);
+die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs)
+ unless grep(exists $opts{$_}, @exclusive) == 1;
+
+die "Option --module is required\n" . usage(%opt_defs)
+ unless $opts{module};
+
+my $cf = load_config($opts{module});
+
+if (exists $opts{feature}) {
+
+ if (length $opts{feature}) {
+ print $cf->feature($opts{feature});
+ } else {
+ my %auto;
+ # note: need to support older ConfigData.pm's
+ @auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names");
+
+ print " Features defined in $cf:\n";
+ foreach my $name (sort $cf->feature_names) {
+ print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n";
+ }
+ }
+
+} elsif (exists $opts{config}) {
+
+ require Data::Dumper;
+ local $Data::Dumper::Terse = 1;
+
+ if (length $opts{config}) {
+ print Data::Dumper::Dumper($cf->config($opts{config})), "\n";
+ } else {
+ print " Configuration defined in $cf:\n";
+ foreach my $name (sort $cf->config_names) {
+ print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n";
+ }
+ }
+
+} elsif (exists $opts{set_feature}) {
+ my %to_set = %{$opts{set_feature}};
+ while (my ($k, $v) = each %to_set) {
+ die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/;
+ $cf->set_feature($k, 0+$v); # Cast to a number, not a string
+ }
+ $cf->write;
+ print "Feature" . 's'x(keys(%to_set)>1) . " saved\n";
+
+} elsif (exists $opts{set_config}) {
+
+ my %to_set = %{$opts{set_config}};
+ while (my ($k, $v) = each %to_set) {
+ if ($opts{eval}) {
+ $v = eval($v);
+ die $@ if $@;
+ }
+ $cf->set_config($k, $v);
+ }
+ $cf->write;
+ print "Config value" . 's'x(keys(%to_set)>1) . " saved\n";
+}
+
+sub load_config {
+ my $mod = shift;
+
+ $mod =~ /^([\w:]+)$/
+ or die "Invalid module name '$mod'";
+
+ my $cf = $mod . "::ConfigData";
+ eval "require $cf";
+ die $@ if $@;
+
+ return $cf;
+}
+
+sub usage {
+ my %defs = @_;
+
+ my $out = "\nUsage: $0 [options]\n\n Options include:\n";
+
+ foreach my $name (sort keys %defs) {
+ $out .= " --$name";
+
+ for ($defs{$name}{type}) {
+ /^=s$/ and $out .= " <string>";
+ /^=s%$/ and $out .= " <string>=<value>";
+ }
+
+ pad_line($out, 35);
+ $out .= "$defs{$name}{desc}\n";
+ }
+
+ $out .= <<EOF;
+
+ Examples:
+ $0 --module Foo::Bar --feature bazzable
+ $0 --module Foo::Bar --config magic_number
+ $0 --module Foo::Bar --set_feature bazzable=1
+ $0 --module Foo::Bar --set_config magic_number=42
+
+EOF
+
+ return $out;
+}
+
+sub pad_line { $_[0] .= ' ' x ($_[1] - length($_[0]) + rindex($_[0], "\n")) }
+
+
+__END__
+
+=head1 NAME
+
+config_data - Query or change configuration of Perl modules
+
+=head1 SYNOPSIS
+
+ # Get config/feature values
+ config_data --module Foo::Bar --feature bazzable
+ config_data --module Foo::Bar --config magic_number
+
+ # Set config/feature values
+ config_data --module Foo::Bar --set_feature bazzable=1
+ config_data --module Foo::Bar --set_config magic_number=42
+
+ # Print a usage message
+ config_data --help
+
+=head1 DESCRIPTION
+
+The C<config_data> tool provides a command-line interface to the
+configuration of Perl modules. By "configuration", we mean something
+akin to "user preferences" or "local settings". This is a
+formalization and abstraction of the systems that people like Andreas
+Koenig (C<CPAN::Config>), Jon Swartz (C<HTML::Mason::Config>), Andy
+Wardley (C<Template::Config>), and Larry Wall (perl's own Config.pm)
+have developed independently.
+
+The configuration system emplyed here was developed in the context of
+C<Module::Build>. Under this system, configuration information for a
+module C<Foo>, for example, is stored in a module called
+C<Foo::ConfigData>) (I would have called it C<Foo::Config>, but that
+was taken by all those other systems mentioned in the previous
+paragraph...). These C<...::ConfigData> modules contain the
+configuration data, as well as publically accessible methods for
+querying and setting (yes, actually re-writing) the configuration
+data. The C<config_data> script (whose docs you are currently
+reading) is merely a front-end for those methods. If you wish, you
+may create alternate front-ends.
+
+The two types of data that may be stored are called C<config> values
+and C<feature> values. A C<config> value may be any perl scalar,
+including references to complex data structures. It must, however, be
+serializable using C<Data::Dumper>. A C<feature> is a boolean (1 or
+0) value.
+
+=head1 USAGE
+
+This script functions as a basic getter/setter wrapper around the
+configuration of a single module. On the command line, specify which
+module's configuration you're interested in, and pass options to get
+or set C<config> or C<feature> values. The following options are
+supported:
+
+=over 4
+
+=item module
+
+Specifies the name of the module to configure (required).
+
+=item feature
+
+When passed the name of a C<feature>, shows its value. The value will
+be 1 if the feature is enabled, 0 if the feature is not enabled, or
+empty if the feature is unknown. When no feature name is supplied,
+the names and values of all known features will be shown.
+
+=item config
+
+When passed the name of a C<config> entry, shows its value. The value
+will be displayed using C<Data::Dumper> (or similar) as perl code.
+When no config name is supplied, the names and values of all known
+config entries will be shown.
+
+=item set_feature
+
+Sets the given C<feature> to the given boolean value. Specify the value
+as either 1 or 0.
+
+=item set_config
+
+Sets the given C<config> entry to the given value.
+
+=item eval
+
+If the C<--eval> option is used, the values in C<set_config> will be
+evaluated as perl code before being stored. This allows moderately
+complicated data structures to be stored. For really complicated
+structures, you probably shouldn't use this command-line interface,
+just use the Perl API instead.
+
+=item help
+
+Prints a help message, including a few examples, and exits.
+
+=back
+
+=head1 AUTHOR
+
+Ken Williams, kwilliams@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (c) 1999, Ken Williams. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Module::Build(3), perl(1).
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/corelist b/Master/tlpkg/tlperl.straw/bin/corelist
new file mode 100755
index 00000000000..b59aef34776
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/corelist
@@ -0,0 +1,272 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+corelist - a commandline frontend to Module::CoreList
+
+=head1 DESCRIPTION
+
+See L<Module::CoreList> for one.
+
+=head1 SYNOPSIS
+
+ corelist -v
+ corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
+ corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
+
+=head1 OPTIONS
+
+=over
+
+=item -a
+
+lists all versions of the given module (or the matching modules, in case you
+used a module regexp) in the perls Module::CoreList knows about.
+
+ corelist -a utf8
+
+ utf8 was first released with perl 5.006
+ 5.006 undef
+ 5.006001 undef
+ 5.006002 undef
+ 5.007003 1.00
+ 5.008 1.00
+ 5.008001 1.02
+ 5.008002 1.02
+ 5.008003 1.02
+ 5.008004 1.03
+ 5.008005 1.04
+ 5.008006 1.04
+ 5.008007 1.05
+ 5.008008 1.06
+ 5.009 1.02
+ 5.009001 1.02
+ 5.009002 1.04
+ 5.009003 1.06
+
+=item -d
+
+finds the first perl version where a module has been released by
+date, and not by version number (as is the default).
+
+=item -? or -help
+
+help! help! help! to see more help, try --man.
+
+=item -man
+
+all of the help
+
+=item -v
+
+lists all of the perl release versions we got the CoreList for.
+
+If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>),
+you get a list of all the modules and their respective versions.
+(If you have the C<version> module, you can also use new-style version numbers,
+like C<5.8.8>.)
+
+In module filtering context, it can be used as Perl version filter.
+
+=back
+
+As a special case, if you specify the module name C<Unicode>, you'll get
+the version number of the Unicode Character Database bundled with the
+requested perl versions.
+
+=cut
+
+use Module::CoreList;
+use Getopt::Long;
+use Pod::Usage;
+use strict;
+use warnings;
+
+my %Opts;
+
+GetOptions(\%Opts, qw[ help|?! man! v|version:f a! d ] );
+
+pod2usage(1) if $Opts{help};
+pod2usage(-verbose=>2) if $Opts{man};
+
+if(exists $Opts{v} ){
+ if( !$Opts{v} ) {
+ print "\nModule::CoreList has info on the following perl versions:\n";
+ print "$_\n" for sort keys %Module::CoreList::version;
+ print "\n";
+ exit 0;
+ }
+
+ $Opts{v} = numify_version( $Opts{v} );
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if( !$version_hash ) {
+ print "\nModule::CoreList has no info on perl v$Opts{v}\n\n";
+ exit 1;
+ }
+
+ if ( !@ARGV ) {
+ print "\nThe following modules were in perl v$Opts{v} CORE\n";
+ print "$_ ", $version_hash->{$_} || " ","\n"
+ for sort keys %$version_hash;
+ print "\n";
+ exit 0;
+ }
+}
+
+if ( !@ARGV ) {
+ pod2usage(0);
+}
+
+while (@ARGV) {
+ my ($mod, $ver);
+ if ($ARGV[0] =~ /=/) {
+ ($mod, $ver) = split /=/, shift @ARGV;
+ } else {
+ $mod = shift @ARGV;
+ $ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : "";
+ }
+
+ if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex
+ module_version($mod,$ver);
+ } else {
+ my $re;
+ eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex
+ if ($@) {
+ # regex errors are usually like 'Quantifier follow nothing in regex; marked by ...'
+ # then we drop text after ';' to shorten message
+ my $errmsg = $@ =~ /(.*);/ ? $1 : $@;
+ warn "\n$mod is a bad regex: $errmsg\n";
+ next;
+ }
+ my @mod = Module::CoreList->find_modules($re);
+ if (@mod) {
+ module_version($_, $ver) for @mod;
+ } else {
+ $ver |= '';
+ print "\n$mod $ver has no match in CORE (or so I think)\n";
+ }
+
+ }
+}
+
+exit();
+
+sub module_version {
+ my($mod,$ver) = @_;
+
+ if ( $Opts{v} ) {
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if ($version_hash) {
+ print $mod, " ", $version_hash->{$mod} || 'undef', "\n";
+ return;
+ }
+ else { die "Shouldn't happen" }
+ }
+
+ my $ret = $Opts{d}
+ ? Module::CoreList->first_release_by_date(@_)
+ : Module::CoreList->first_release(@_);
+ my $msg = $mod;
+ $msg .= " $ver" if $ver;
+
+ if( defined $ret ) {
+ $msg .= " was ";
+ $msg .= "first " unless $ver;
+ $msg .= "released with perl $ret"
+ } else {
+ $msg .= " was not in CORE (or so I think)";
+ }
+
+ print "\n",$msg,"\n";
+
+ if(defined $ret and exists $Opts{a} and $Opts{a}){
+ for my $v(
+ sort keys %Module::CoreList::version ){
+
+ printf " %-10s %-10s\n",
+ $v,
+ $Module::CoreList::version{$v}{$mod}
+ || 'undef'
+ if exists $Module::CoreList::version{$v}{$mod};
+ }
+ print "\n";
+ }
+}
+
+sub numify_version {
+ my $ver = shift;
+ if ($ver =~ /\..+\./) {
+ eval { require version ; 1 }
+ or die "You need to install version.pm to use dotted version numbers\n";
+ $ver = version->new($ver)->numify;
+ }
+ $ver += 0;
+ return $ver;
+}
+
+=head1 EXAMPLES
+
+ $ corelist File::Spec
+
+ File::Spec was first released with perl 5.005
+
+ $ corelist File::Spec 0.83
+
+ File::Spec 0.83 was released with perl 5.007003
+
+ $ corelist File::Spec 0.89
+
+ File::Spec 0.89 was not in CORE (or so I think)
+
+ $ corelist File::Spec::Aliens
+
+ File::Spec::Aliens was not in CORE (or so I think)
+
+ $ corelist /IPC::Open/
+
+ IPC::Open2 was first released with perl 5
+
+ IPC::Open3 was first released with perl 5
+
+ $ corelist /MANIFEST/i
+
+ ExtUtils::Manifest was first released with perl 5.001
+
+ $ corelist /Template/
+
+ /Template/ has no match in CORE (or so I think)
+
+ $ corelist -v 5.8.8 B
+
+ B 1.09_01
+
+ $ corelist -v 5.8.8 /^B::/
+
+ B::Asmdata 1.01
+ B::Assembler 0.07
+ B::Bblock 1.02_01
+ B::Bytecode 1.01_01
+ B::C 1.04_01
+ B::CC 1.00_01
+ B::Concise 0.66
+ B::Debug 1.02_01
+ B::Deparse 0.71
+ B::Disassembler 1.05
+ B::Lint 1.03
+ B::O 1.00
+ B::Showlex 1.02
+ B::Stackobj 1.00
+ B::Stash 1.00
+ B::Terse 1.03_01
+ B::Xref 1.01
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2007 by D.H. aka PodMaster
+
+Currently maintained by the perl 5 porters E<lt>perl5-porters@perl.orgE<gt>.
+
+This program is distributed under the same terms as perl itself.
+See http://perl.org/ or http://cpan.org/ for more info on that.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/corelist.bat b/Master/tlpkg/tlperl.straw/bin/corelist.bat
new file mode 100755
index 00000000000..f0cc991ff10
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/corelist.bat
@@ -0,0 +1,288 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+=head1 NAME
+
+corelist - a commandline frontend to Module::CoreList
+
+=head1 DESCRIPTION
+
+See L<Module::CoreList> for one.
+
+=head1 SYNOPSIS
+
+ corelist -v
+ corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
+ corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
+
+=head1 OPTIONS
+
+=over
+
+=item -a
+
+lists all versions of the given module (or the matching modules, in case you
+used a module regexp) in the perls Module::CoreList knows about.
+
+ corelist -a utf8
+
+ utf8 was first released with perl 5.006
+ 5.006 undef
+ 5.006001 undef
+ 5.006002 undef
+ 5.007003 1.00
+ 5.008 1.00
+ 5.008001 1.02
+ 5.008002 1.02
+ 5.008003 1.02
+ 5.008004 1.03
+ 5.008005 1.04
+ 5.008006 1.04
+ 5.008007 1.05
+ 5.008008 1.06
+ 5.009 1.02
+ 5.009001 1.02
+ 5.009002 1.04
+ 5.009003 1.06
+
+=item -d
+
+finds the first perl version where a module has been released by
+date, and not by version number (as is the default).
+
+=item -? or -help
+
+help! help! help! to see more help, try --man.
+
+=item -man
+
+all of the help
+
+=item -v
+
+lists all of the perl release versions we got the CoreList for.
+
+If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>),
+you get a list of all the modules and their respective versions.
+(If you have the C<version> module, you can also use new-style version numbers,
+like C<5.8.8>.)
+
+In module filtering context, it can be used as Perl version filter.
+
+=back
+
+As a special case, if you specify the module name C<Unicode>, you'll get
+the version number of the Unicode Character Database bundled with the
+requested perl versions.
+
+=cut
+
+use Module::CoreList;
+use Getopt::Long;
+use Pod::Usage;
+use strict;
+use warnings;
+
+my %Opts;
+
+GetOptions(\%Opts, qw[ help|?! man! v|version:f a! d ] );
+
+pod2usage(1) if $Opts{help};
+pod2usage(-verbose=>2) if $Opts{man};
+
+if(exists $Opts{v} ){
+ if( !$Opts{v} ) {
+ print "\nModule::CoreList has info on the following perl versions:\n";
+ print "$_\n" for sort keys %Module::CoreList::version;
+ print "\n";
+ exit 0;
+ }
+
+ $Opts{v} = numify_version( $Opts{v} );
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if( !$version_hash ) {
+ print "\nModule::CoreList has no info on perl v$Opts{v}\n\n";
+ exit 1;
+ }
+
+ if ( !@ARGV ) {
+ print "\nThe following modules were in perl v$Opts{v} CORE\n";
+ print "$_ ", $version_hash->{$_} || " ","\n"
+ for sort keys %$version_hash;
+ print "\n";
+ exit 0;
+ }
+}
+
+if ( !@ARGV ) {
+ pod2usage(0);
+}
+
+while (@ARGV) {
+ my ($mod, $ver);
+ if ($ARGV[0] =~ /=/) {
+ ($mod, $ver) = split /=/, shift @ARGV;
+ } else {
+ $mod = shift @ARGV;
+ $ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : "";
+ }
+
+ if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex
+ module_version($mod,$ver);
+ } else {
+ my $re;
+ eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex
+ if ($@) {
+ # regex errors are usually like 'Quantifier follow nothing in regex; marked by ...'
+ # then we drop text after ';' to shorten message
+ my $errmsg = $@ =~ /(.*);/ ? $1 : $@;
+ warn "\n$mod is a bad regex: $errmsg\n";
+ next;
+ }
+ my @mod = Module::CoreList->find_modules($re);
+ if (@mod) {
+ module_version($_, $ver) for @mod;
+ } else {
+ $ver |= '';
+ print "\n$mod $ver has no match in CORE (or so I think)\n";
+ }
+
+ }
+}
+
+exit();
+
+sub module_version {
+ my($mod,$ver) = @_;
+
+ if ( $Opts{v} ) {
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if ($version_hash) {
+ print $mod, " ", $version_hash->{$mod} || 'undef', "\n";
+ return;
+ }
+ else { die "Shouldn't happen" }
+ }
+
+ my $ret = $Opts{d}
+ ? Module::CoreList->first_release_by_date(@_)
+ : Module::CoreList->first_release(@_);
+ my $msg = $mod;
+ $msg .= " $ver" if $ver;
+
+ if( defined $ret ) {
+ $msg .= " was ";
+ $msg .= "first " unless $ver;
+ $msg .= "released with perl $ret"
+ } else {
+ $msg .= " was not in CORE (or so I think)";
+ }
+
+ print "\n",$msg,"\n";
+
+ if(defined $ret and exists $Opts{a} and $Opts{a}){
+ for my $v(
+ sort keys %Module::CoreList::version ){
+
+ printf " %-10s %-10s\n",
+ $v,
+ $Module::CoreList::version{$v}{$mod}
+ || 'undef'
+ if exists $Module::CoreList::version{$v}{$mod};
+ }
+ print "\n";
+ }
+}
+
+sub numify_version {
+ my $ver = shift;
+ if ($ver =~ /\..+\./) {
+ eval { require version ; 1 }
+ or die "You need to install version.pm to use dotted version numbers\n";
+ $ver = version->new($ver)->numify;
+ }
+ $ver += 0;
+ return $ver;
+}
+
+=head1 EXAMPLES
+
+ $ corelist File::Spec
+
+ File::Spec was first released with perl 5.005
+
+ $ corelist File::Spec 0.83
+
+ File::Spec 0.83 was released with perl 5.007003
+
+ $ corelist File::Spec 0.89
+
+ File::Spec 0.89 was not in CORE (or so I think)
+
+ $ corelist File::Spec::Aliens
+
+ File::Spec::Aliens was not in CORE (or so I think)
+
+ $ corelist /IPC::Open/
+
+ IPC::Open2 was first released with perl 5
+
+ IPC::Open3 was first released with perl 5
+
+ $ corelist /MANIFEST/i
+
+ ExtUtils::Manifest was first released with perl 5.001
+
+ $ corelist /Template/
+
+ /Template/ has no match in CORE (or so I think)
+
+ $ corelist -v 5.8.8 B
+
+ B 1.09_01
+
+ $ corelist -v 5.8.8 /^B::/
+
+ B::Asmdata 1.01
+ B::Assembler 0.07
+ B::Bblock 1.02_01
+ B::Bytecode 1.01_01
+ B::C 1.04_01
+ B::CC 1.00_01
+ B::Concise 0.66
+ B::Debug 1.02_01
+ B::Deparse 0.71
+ B::Disassembler 1.05
+ B::Lint 1.03
+ B::O 1.00
+ B::Showlex 1.02
+ B::Stackobj 1.00
+ B::Stash 1.00
+ B::Terse 1.03_01
+ B::Xref 1.01
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2007 by D.H. aka PodMaster
+
+Currently maintained by the perl 5 porters E<lt>perl5-porters@perl.orgE<gt>.
+
+This program is distributed under the same terms as perl itself.
+See http://perl.org/ or http://cpan.org/ for more info on that.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/cpan b/Master/tlpkg/tlperl.straw/bin/cpan
new file mode 100755
index 00000000000..5e5609555f6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpan
@@ -0,0 +1,229 @@
+#!/usr/local/bin/perl
+use strict;
+use vars qw($VERSION);
+
+use App::Cpan;
+$VERSION = '1.57';
+
+my $rc = App::Cpan->run( @ARGV );
+
+# will this work under Strawberry Perl?
+exit( $rc || 0 );
+
+=head1 NAME
+
+cpan - easily interact with CPAN from the command line
+
+=head1 SYNOPSIS
+
+ # with arguments and no switches, installs specified modules
+ cpan module_name [ module_name ... ]
+
+ # with switches, installs modules with extra behavior
+ cpan [-cfgimt] module_name [ module_name ... ]
+
+ # with just the dot, install from the distribution in the
+ # current directory
+ cpan .
+
+ # without arguments, starts CPAN.pm shell
+ cpan
+
+ # dump the configuration
+ cpan -J
+
+ # load a different configuration to install Module::Foo
+ cpan -j some/other/file Module::Foo
+
+ # without arguments, but some switches
+ cpan [-ahrvACDlLO]
+
+=head1 DESCRIPTION
+
+This script provides a command interface (not a shell) to CPAN. At the
+moment it uses CPAN.pm to do the work, but it is not a one-shot command
+runner for CPAN.pm.
+
+=head2 Options
+
+=over 4
+
+=item -a
+
+Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
+
+=item -A module [ module ... ]
+
+Shows the primary maintainers for the specified modules.
+
+=item -c module
+
+Runs a `make clean` in the specified module's directories.
+
+=item -C module [ module ... ]
+
+Show the F<Changes> files for the specified modules
+
+=item -D module [ module ... ]
+
+Show the module details. This prints one line for each out-of-date module
+(meaning, modules locally installed but have newer versions on CPAN).
+Each line has three columns: module name, local version, and CPAN
+version.
+
+=item -f
+
+Force the specified action, when it normally would have failed. Use this
+to install a module even if its tests fail. When you use this option,
+-i is not optional for installing a module when you need to force it:
+
+ % cpan -f -i Module::Foo
+
+=item -F
+
+Turn off CPAN.pm's attempts to lock anything. You should be careful with
+this since you might end up with multiple scripts trying to muck in the
+same directory. This isn't so much of a concern if you're loading a special
+config with C<-j>, and that config sets up its own work directories.
+
+=item -g module [ module ... ]
+
+Downloads to the current directory the latest distribution of the module.
+
+=item -G module [ module ... ]
+
+UNIMPLEMENTED
+
+Download to the current directory the latest distribution of the
+modules, unpack each distribution, and create a git repository for each
+distribution.
+
+If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
+distribution.
+
+=item -h
+
+Print a help message and exit. When you specify C<-h>, it ignores all
+of the other options and arguments.
+
+=item -i
+
+Install the specified modules.
+
+=item -j Config.pm
+
+Load the file that has the CPAN configuration data. This should have the
+same format as the standard F<CPAN/Config.pm> file, which defines
+C<$CPAN::Config> as an anonymous hash.
+
+=item -J
+
+Dump the configuration in the same format that CPAN.pm uses. This is useful
+for checking the configuration as well as using the dump as a starting point
+for a new, custom configuration.
+
+=item -L author [ author ... ]
+
+List the modules by the specified authors.
+
+=item -m
+
+Make the specified modules.
+
+=item -O
+
+Show the out-of-date modules.
+
+=item -t
+
+Run a `make test` on the specified modules.
+
+=item -r
+
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
+
+=item -v
+
+Print the script version and CPAN.pm version then exit.
+
+=back
+
+=head2 Examples
+
+ # print a help message
+ cpan -h
+
+ # print the version numbers
+ cpan -v
+
+ # create an autobundle
+ cpan -a
+
+ # recompile modules
+ cpan -r
+
+ # install modules ( sole -i is optional )
+ cpan -i Netscape::Booksmarks Business::ISBN
+
+ # force install modules ( must use -i )
+ cpan -fi CGI::Minimal URI
+
+=head1 EXIT VALUES
+
+The script exits with zero if it thinks that everything worked, or a
+positive number if it thinks that something failed. Note, however, that
+in some cases it has to divine a failure by the output of things it does
+not control. For now, the exit codes are vague:
+
+ 1 An unknown error
+
+ 2 The was an external problem
+
+ 4 There was an internal problem with the script
+
+ 8 A module failed to install
+
+=head1 TO DO
+
+* one shot configuration values from the command line
+
+
+
+=head1 BUGS
+
+* none noted
+
+=head1 SEE ALSO
+
+Most behaviour, including environment variables and configuration,
+comes directly from CPAN.pm.
+
+=head1 SOURCE AVAILABILITY
+
+This code is in Github:
+
+ git://github.com/briandfoy/cpan_script.git
+
+=head1 CREDITS
+
+Japheth Cleaver added the bits to allow a forced install (-f).
+
+Jim Brandt suggest and provided the initial implementation for the
+up-to-date and Changes features.
+
+Adam Kennedy pointed out that exit() causes problems on Windows
+where this script ends up with a .bat extension
+
+=head1 AUTHOR
+
+brian d foy, C<< <bdfoy@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
+
+You may redistribute this under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/bin/cpan.bat b/Master/tlpkg/tlperl.straw/bin/cpan.bat
new file mode 100755
index 00000000000..b96d7678fd2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpan.bat
@@ -0,0 +1,245 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl
+#line 15
+use strict;
+use vars qw($VERSION);
+
+use App::Cpan;
+$VERSION = '1.57';
+
+my $rc = App::Cpan->run( @ARGV );
+
+# will this work under Strawberry Perl?
+exit( $rc || 0 );
+
+=head1 NAME
+
+cpan - easily interact with CPAN from the command line
+
+=head1 SYNOPSIS
+
+ # with arguments and no switches, installs specified modules
+ cpan module_name [ module_name ... ]
+
+ # with switches, installs modules with extra behavior
+ cpan [-cfgimt] module_name [ module_name ... ]
+
+ # with just the dot, install from the distribution in the
+ # current directory
+ cpan .
+
+ # without arguments, starts CPAN.pm shell
+ cpan
+
+ # dump the configuration
+ cpan -J
+
+ # load a different configuration to install Module::Foo
+ cpan -j some/other/file Module::Foo
+
+ # without arguments, but some switches
+ cpan [-ahrvACDlLO]
+
+=head1 DESCRIPTION
+
+This script provides a command interface (not a shell) to CPAN. At the
+moment it uses CPAN.pm to do the work, but it is not a one-shot command
+runner for CPAN.pm.
+
+=head2 Options
+
+=over 4
+
+=item -a
+
+Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
+
+=item -A module [ module ... ]
+
+Shows the primary maintainers for the specified modules.
+
+=item -c module
+
+Runs a `make clean` in the specified module's directories.
+
+=item -C module [ module ... ]
+
+Show the F<Changes> files for the specified modules
+
+=item -D module [ module ... ]
+
+Show the module details. This prints one line for each out-of-date module
+(meaning, modules locally installed but have newer versions on CPAN).
+Each line has three columns: module name, local version, and CPAN
+version.
+
+=item -f
+
+Force the specified action, when it normally would have failed. Use this
+to install a module even if its tests fail. When you use this option,
+-i is not optional for installing a module when you need to force it:
+
+ % cpan -f -i Module::Foo
+
+=item -F
+
+Turn off CPAN.pm's attempts to lock anything. You should be careful with
+this since you might end up with multiple scripts trying to muck in the
+same directory. This isn't so much of a concern if you're loading a special
+config with C<-j>, and that config sets up its own work directories.
+
+=item -g module [ module ... ]
+
+Downloads to the current directory the latest distribution of the module.
+
+=item -G module [ module ... ]
+
+UNIMPLEMENTED
+
+Download to the current directory the latest distribution of the
+modules, unpack each distribution, and create a git repository for each
+distribution.
+
+If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
+distribution.
+
+=item -h
+
+Print a help message and exit. When you specify C<-h>, it ignores all
+of the other options and arguments.
+
+=item -i
+
+Install the specified modules.
+
+=item -j Config.pm
+
+Load the file that has the CPAN configuration data. This should have the
+same format as the standard F<CPAN/Config.pm> file, which defines
+C<$CPAN::Config> as an anonymous hash.
+
+=item -J
+
+Dump the configuration in the same format that CPAN.pm uses. This is useful
+for checking the configuration as well as using the dump as a starting point
+for a new, custom configuration.
+
+=item -L author [ author ... ]
+
+List the modules by the specified authors.
+
+=item -m
+
+Make the specified modules.
+
+=item -O
+
+Show the out-of-date modules.
+
+=item -t
+
+Run a `make test` on the specified modules.
+
+=item -r
+
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
+
+=item -v
+
+Print the script version and CPAN.pm version then exit.
+
+=back
+
+=head2 Examples
+
+ # print a help message
+ cpan -h
+
+ # print the version numbers
+ cpan -v
+
+ # create an autobundle
+ cpan -a
+
+ # recompile modules
+ cpan -r
+
+ # install modules ( sole -i is optional )
+ cpan -i Netscape::Booksmarks Business::ISBN
+
+ # force install modules ( must use -i )
+ cpan -fi CGI::Minimal URI
+
+=head1 EXIT VALUES
+
+The script exits with zero if it thinks that everything worked, or a
+positive number if it thinks that something failed. Note, however, that
+in some cases it has to divine a failure by the output of things it does
+not control. For now, the exit codes are vague:
+
+ 1 An unknown error
+
+ 2 The was an external problem
+
+ 4 There was an internal problem with the script
+
+ 8 A module failed to install
+
+=head1 TO DO
+
+* one shot configuration values from the command line
+
+
+
+=head1 BUGS
+
+* none noted
+
+=head1 SEE ALSO
+
+Most behaviour, including environment variables and configuration,
+comes directly from CPAN.pm.
+
+=head1 SOURCE AVAILABILITY
+
+This code is in Github:
+
+ git://github.com/briandfoy/cpan_script.git
+
+=head1 CREDITS
+
+Japheth Cleaver added the bits to allow a forced install (-f).
+
+Jim Brandt suggest and provided the initial implementation for the
+up-to-date and Changes features.
+
+Adam Kennedy pointed out that exit() causes problems on Windows
+where this script ends up with a .bat extension
+
+=head1 AUTHOR
+
+brian d foy, C<< <bdfoy@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
+
+You may redistribute this under the same terms as Perl itself.
+
+=cut
+
+1;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/cpan2dist b/Master/tlpkg/tlperl.straw/bin/cpan2dist
new file mode 100755
index 00000000000..5ba4556c529
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpan2dist
@@ -0,0 +1,671 @@
+#!/usr/bin/perl -w
+use strict;
+use CPANPLUS::Backend;
+use CPANPLUS::Dist;
+use CPANPLUS::Internals::Constants;
+use Data::Dumper;
+use Getopt::Long;
+use File::Spec;
+use File::Temp qw|tempfile|;
+use File::Basename;
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Data::Dumper::Indent = 1;
+
+use constant PREREQ_SKIP_CLASS => 'CPANPLUS::To::Dist::PREREQ_SKIP';
+use constant ALARM_CLASS => 'CPANPLUS::To::Dist::ALARM';
+
+### print when you can
+$|++;
+
+my $cb = CPANPLUS::Backend->new
+ or die loc("Could not create new CPANPLUS::Backend object");
+my $conf = $cb->configure_object;
+
+my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types;
+
+my $opts = {};
+GetOptions( $opts,
+ 'format=s', 'archive',
+ 'verbose!', 'force!',
+ 'skiptest!', 'keepsource!',
+ 'makefile!', 'buildprereq!',
+ 'help', 'flushcache',
+ 'ban=s@', 'banlist=s@',
+ 'ignore=s@', 'ignorelist=s@',
+ 'defaults', 'modulelist=s@',
+ 'logfile=s', 'timeout=s',
+ 'dist-opts=s%', 'set-config=s%',
+ 'default-banlist!', 'set-program=s%',
+ 'default-ignorelist!', 'edit-metafile!',
+ 'install!'
+ );
+
+die usage() if exists $opts->{'help'};
+
+### parse options
+my $tarball = $opts->{'archive'} || 0;
+my $keep = $opts->{'keepsource'} ? 1 : 0;
+my $prereqbuild = exists $opts->{'buildprereq'}
+ ? $opts->{'buildprereq'}
+ : 0;
+my $timeout = exists $opts->{'timeout'}
+ ? $opts->{'timeout'}
+ : 300;
+
+### use default answers?
+$ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0;
+
+my $format;
+### if provided, we go with the command line option, fall back to conf setting
+{ $format = $opts->{'format'} || $conf->get_conf('dist_type');
+ $conf->set_conf( dist_type => $format );
+
+ ### is this a valid format??
+ die loc("Invalid format: " . ($format || "[NONE]") ) . usage()
+ unless $formats{$format};
+
+ ### any options to fix config entries
+ { my $set_conf = $opts->{'set-config'} || {};
+ while( my($key,$val) = each %$set_conf ) {
+ $conf->set_conf( $key => $val );
+ }
+ }
+
+ ### any options to fix program entries
+ { my $set_prog = $opts->{'set-program'} || {};
+ while( my($key,$val) = each %$set_prog ) {
+ $conf->set_program( $key => $val );
+ }
+ }
+
+ ### any other options passed
+ { my %map = ( verbose => 'verbose',
+ force => 'force',
+ skiptest => 'skiptest',
+ makefile => 'prefer_makefile'
+ );
+
+ ### set config options from arguments
+ while (my($key,$val) = each %map) {
+ my $bool = exists $opts->{$key}
+ ? $opts->{$key}
+ : $conf->get_conf($val);
+ $conf->set_conf( $val => $bool );
+ }
+ }
+}
+
+my @modules = @ARGV;
+if( exists $opts->{'modulelist'} ) {
+ push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} };
+}
+
+die usage() unless @modules;
+
+### set up munge callback if requested
+{ if( $opts->{'edit-metafile'} ) {
+ my $editor = $conf->get_program('editor');
+
+ if( $editor ) {
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'munge_dist_metafile',
+ code => sub {
+ my $self = shift;
+ my $text = shift or return;
+
+ my($fh,$file) = tempfile( UNLINK => 1 );
+
+ unless( print $fh $text ) {
+ warn "Could not print metafile information: $!";
+ return;
+ }
+
+ close $fh;
+
+ system( $editor => $file );
+
+ my $cont = $cb->_get_file_contents( file => $file );
+
+ return $cont;
+ },
+ );
+
+ } else {
+ warn "No editor configured. Can not edit metafiles!\n";
+ }
+ }
+}
+
+my $fh;
+LOGFILE: {
+ if( my $file = $opts->{logfile} ) {
+ open $fh, ">$file" or (
+ warn loc("Could not open '%1' for writing: %2", $file,$!),
+ last LOGFILE
+ );
+
+ warn "Logging to '$file'\n";
+
+ *STDERR = $fh;
+ *STDOUT = $fh;
+ }
+}
+
+### reload indices if so desired
+$cb->reload_indices() if $opts->{'flushcache'};
+
+{ my @ban = exists $opts->{'ban'}
+ ? map { qr/$_/ } @{ $opts->{'ban'} }
+ : ();
+
+
+ if( exists $opts->{'banlist'} ) {
+ push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} };
+ }
+
+ push @ban, map { s/\s+//; $_ }
+ map { [split /\s*#\s*/]->[0] }
+ grep { /#/ }
+ map { split /\n/ } _default_ban_list()
+ if $opts->{'default-banlist'};
+
+ ### use our prereq install callback
+ $conf->set_conf( prereqs => PREREQ_ASK );
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'install_prerequisite',
+ code => \&__ask_about_install,
+ );
+
+
+ ### check for ban patterns when handling prereqs
+ sub __ask_about_install {
+
+ my $mod = shift or return;
+ my $prereq = shift or return;
+
+
+ ### die with an error object, so we can verify that
+ ### the die came from this location, and that it's an
+ ### 'acceptable' death
+ my $pat = ban_me( $prereq );
+ die bless sub { loc("Module '%1' requires '%2' to be installed " .
+ "but found in your ban list (%3) -- skipping",
+ $mod->module, $prereq->module, $pat )
+ }, PREREQ_SKIP_CLASS if $pat;
+ return 1;
+ }
+
+ ### should we skip this module?
+ sub ban_me {
+ my $mod = shift;
+
+ for my $pat ( @ban ) {
+ return $pat if $mod->module =~ /$pat/i;
+ }
+ return;
+ }
+}
+
+### patterns to strip from prereq lists
+{ my @ignore = exists $opts->{'ignore'}
+ ? map { qr/$_/ } @{ $opts->{'ignore'} }
+ : ();
+
+ if( exists $opts->{'ignorelist'} ) {
+ push @ignore, map { parse_file( $_, 1 ) } @{ $opts->{'ignorelist'} };
+ }
+
+ push @ignore, map { s/\s+//; $_ }
+ map { [split /\s*#\s*/]->[0] }
+ grep { /#/ }
+ map { split /\n/ } _default_ignore_list()
+ if $opts->{'default-ignorelist'};
+
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'filter_prereqs',
+ code => \&__filter_prereqs,
+ );
+
+ sub __filter_prereqs {
+ my $cb = shift;
+ my $href = shift;
+
+ for my $name ( keys %$href ) {
+ my $obj = $cb->parse_module( module => $name ) or (
+ warn "Cannot make a module object out of ".
+ "'$name' -- skipping\n",
+ next );
+
+ if( my $pat = ignore_me( $obj ) ) {
+ warn loc("'%1' found in your ignore list (%2) ".
+ "-- filtering it out\n", $name, $pat);
+
+ delete $href->{ $name };
+ }
+ }
+
+ return $href;
+ }
+
+ ### should we skip this module?
+ sub ignore_me {
+ my $mod = shift;
+
+ for my $pat ( @ignore ) {
+ return $pat if $mod->module =~ /$pat/i;
+ return $pat if $mod->package_name =~ /$pat/i;
+ }
+ return;
+ }
+}
+
+
+my %done;
+for my $name (@modules) {
+
+ my $obj;
+
+ ### is it a tarball? then we get it locally and transform it
+ ### and its dependencies into .debs
+ if( $tarball ) {
+ ### make sure we use an absolute path, so chdirs() dont
+ ### mess things up
+ $name = File::Spec->rel2abs( $name );
+
+ ### ENOTARBALL?
+ unless( -e $name ) {
+ warn loc("Archive '$name' does not exist");
+ next;
+ }
+
+ $obj = CPANPLUS::Module::Fake->new(
+ module => basename($name),
+ path => dirname($name),
+ package => basename($name),
+ );
+
+ ### if it's a traditional CPAN package, we can tidy
+ ### up the module name some
+ $obj->module( $obj->package_name ) if $obj->package_name;
+
+ ### get the version from the package name
+ $obj->version( $obj->package_version || 0 );
+
+ ### set the location of the tarball
+ $obj->status->fetch($name);
+
+ ### plain old cpan module?
+ } else {
+
+ ### find the corresponding module object ###
+ $obj = $cb->parse_module( module => $name ) or (
+ warn "Cannot make a module object out of ".
+ "'$name' -- skipping\n",
+ next );
+ }
+
+ ### you banned it?
+ if( my $pat = ban_me( $obj ) ) {
+ warn loc("'%1' found in your ban list (%2) -- skipping\n",
+ $obj->module, $pat );
+ next;
+ }
+
+ ### or just ignored it?
+ if( my $pat = ignore_me( $obj ) ) {
+ warn loc("'%1' found in your ignore list (%2) -- skipping\n",
+ $obj->module, $pat );
+ next;
+ }
+
+
+ my $target = $opts->{'install'} ? 'install' : 'create';
+ my $dist = eval {
+ local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS }
+ if $timeout;
+
+ alarm $timeout || 0;
+
+ my $dist_opts = $opts->{'dist-opts'} || {};
+
+ my $rv = $obj->install(
+ prereq_target => $target,
+ target => $target,
+ keep_source => $keep,
+ prereq_build => $prereqbuild,
+
+ ### any passed arbitrary options
+ %$dist_opts,
+ );
+
+ alarm 0;
+
+ $rv;
+ };
+
+ ### set here again, in case the install dies
+ alarm 0;
+
+ ### install failed due to a 'die' in our prereq skipper?
+ if( $@ and ref $@ and $@->isa( PREREQ_SKIP_CLASS ) ) {
+ warn loc("Dist creation of '%1' skipped: '%2'",
+ $obj->module, $@->() );
+ next;
+
+ } elsif ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
+ warn loc("\nDist creation of '%1' skipped, build time exceeded: ".
+ "%2 seconds\n", $obj->module, $timeout );
+ next;
+
+ ### died for some other reason? just report and skip
+ } elsif ( $@ ) {
+ warn loc("Dist creation of '%1' failed: '%2'",
+ $obj->module, $@ );
+ next;
+ }
+
+ ### we didn't get a dist object back?
+ unless ($dist and $obj->status->dist) {
+ warn loc("Unable to create '%1' dist of '%2'", $format, $obj->module);
+ next
+ }
+
+ print "Created '$format' distribution for ", $obj->module,
+ " to:\n\t", $obj->status->dist->status->dist, "\n";
+}
+
+
+sub parse_file {
+ my $file = shift or return;
+ my $qr = shift() ? 1 : 0;
+
+ my $fh = OPEN_FILE->( $file ) or return;
+
+ my @rv;
+ while( <$fh> ) {
+ chomp;
+ next if /^#/; # skip comments
+ next unless /\S/; # skip empty lines
+ s/^(\S+).*/$1/; # skip extra info
+ push @rv, $qr ? qr/$_/ : $_; # add pattern to the list
+ }
+
+ return @rv;
+}
+
+=head1 NAME
+
+cpan2dist - The CPANPLUS distribution creator
+
+=head1 DESCRIPTION
+
+This script will create distributions of C<CPAN> modules of the format
+you specify, including its prerequisites. These packages can then be
+installed using the corresponding package manager for the format.
+
+Note, you can also do this interactively from the default shell,
+C<CPANPLUS::Shell::Default>. See the C<CPANPLUS::Dist> documentation,
+as well as the documentation of your format of choice for any format
+specific documentation.
+
+=head1 USAGE
+
+=cut
+
+sub usage {
+ my $me = basename($0);
+ my $formats = join "\n", map { "\t\t$_" } sort keys %formats;
+
+ my $usage = << '=cut';
+=pod
+
+ Usage: cpan2dist [--format FMT] [OPTS] Mod::Name [Mod::Name, ...]
+ cpan2dist [--format FMT] [OPTS] --modulelist /tmp/mods.list
+ cpan2dist [--format FMT] [OPTS] --archive /tmp/dist [/tmp/dist2]
+
+ Will create a distribution of type FMT of the modules
+ specified on the command line, and all their prerequisites.
+
+ Can also create a distribution of type FMT from a local
+ archive and all of its prerequisites.
+
+=cut
+
+ $usage .= qq[
+ Possible formats are:
+$formats
+
+ You can install more formats from CPAN!
+ \n];
+
+ $usage .= << '=cut';
+=pod
+
+Options:
+
+ ### take no argument:
+ --help Show this help message
+ --install Install this package (and any prerequisites you built)
+ after building it.
+ --skiptest Skip tests. Can be negated using --noskiptest
+ --force Force operation. Can be negated using --noforce
+ --verbose Be verbose. Can be negated using --noverbose
+ --keepsource Keep sources after building distribution. Can be
+ negated by --nokeepsource. May not be supported
+ by all formats
+ --makefile Prefer Makefile.PL over Build.PL. Can be negated
+ using --nomakefile. Defaults to your config setting
+ --buildprereq Build packages of any prerequisites, even if they are
+ already uptodate on the local system. Can be negated
+ using --nobuildprereq. Defaults to false.
+ --archive Indicate that all modules listed are actually archives
+ --flushcache Update CPANPLUS' cache before commencing any operation
+ --defaults Instruct ExtUtils::MakeMaker and Module::Build to use
+ default answers during 'perl Makefile.PL' or 'perl
+ Build.PL' calls where possible
+ --edit-metafile Edit the distributions metafile(s) before the distribution
+ is built. Requires a configured editor.
+
+ ### take argument:
+ --format Installer format to use (defaults to config setting)
+ --ban Patterns of module names to skip during installation,
+ case-insensitive (affects prerequisites too)
+ May be given multiple times
+ --banlist File containing patterns that could be given to --ban
+ Are appended to the ban list built up by --ban
+ May be given multiple times.
+ --ignore Patterns of modules to exclude from prereq list. Useful
+ for when a prereq listed by a CPAN module is resolved
+ in another way than from its corresponding CPAN package
+ (Match is done on both module name, and package name of
+ the package the module is in, case-insensitive)
+ --ignorelist File containing patterns that may be given to --ignore.
+ Are appended to the ban list built up by --ignore.
+ May be given multiple times.
+ --modulelist File containing a list of modules that should be built.
+ Are appended to the list of command line modules.
+ May be given multiple times.
+ --logfile File to log all output to. By default, all output goes
+ to the console.
+ --timeout The allowed time for buliding a distribution before
+ aborting. This is useful to terminate any build that
+ hang or happen to be interactive despite being told not
+ to be. Defaults to 300 seconds. To turn off, you can
+ set it to 0.
+ --set-config Change any options as specified in your config for this
+ invocation only. See CPANPLUS::Config for a list of
+ supported options.
+ --set-program Change any programs as specified in your config for this
+ invocation only. See CPANPLUS::Config for a list of
+ supported programs.
+ --dist-opts Arbitrary options passed along to the chosen installer
+ format's prepare()/create() routine. Please see the
+ documentation of the installer of your choice for
+ options it accepts.
+
+ ### builtin lists
+ --default-banlist Use our builtin banlist. Works just like --ban
+ and --banlist, but with pre-set lists. See the
+ "Builtin Lists" section for details.
+ --default-ignorelist Use our builtin ignorelist. Works just like
+ --ignore and --ignorelist but with pre-set lists.
+ See the "Builtin Lists" section for details.
+
+Examples:
+
+ ### build a debian package of DBI and its prerequisites,
+ ### don't bother running tests
+ cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI
+
+ ### build a debian package of DBI and its prerequisites and install them
+ cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI
+
+ ### Build a package, whose format is determined by your config, of
+ ### the local tarball, reloading cpanplus' indices first and using
+ ### the tarballs Makefile.PL if it has one.
+ cpan2dist --makefile --flushcache --archive /path/to/Cwd-1.0.tgz
+
+ ### build a package from Net::FTP, but dont build any packages or
+ ### dependencies whose name match 'Foo', 'Bar' or any of the
+ ### patterns mentioned in /tmp/ban
+ cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP
+
+ ### build a package from Net::FTP, but ignore its listed dependency
+ ### on IO::Socket, as it's shipped per default with the OS we're on
+ cpan2dist --ignore IO::Socket Net::FTP
+
+ ### building all modules listed, plus their prerequisites
+ cpan2dist --ignorelist /tmp/modules.ignore --banlist /tmp/modules.ban
+ --modulelist /tmp/modules.list --buildprereq --flushcache
+ --makefile --defaults
+
+ ### pass arbitrary options to the format's prepare()/create() routine
+ cpan2dist --dist-opts deb_version=3 --dist-opts prefix=corp
+
+=cut
+
+ $usage .= qq[
+Builtin Lists:
+
+ Ignore list:] . _default_ignore_list() . qq[
+ Ban list:] . _default_ban_list();
+
+ ### strip the pod directives
+ $usage =~ s/=pod\n//g;
+
+ return $usage;
+}
+
+=pod
+
+=head1 Built-In Filter Lists
+
+Some modules you'd rather not package. Some because they
+are part of core-perl and you dont want a new package.
+Some because they won't build on your system. Some because
+your package manager of choice already packages them for you.
+
+There may be a myriad of reasons. You can use the C<--ignore>
+and C<--ban> options for this, but we provide some built-in
+lists that catch common cases. You can use these built-in lists
+if you like, or supply your own if need be.
+
+=head2 Built-In Ignore List
+
+=pod
+
+You can use this list of regexes to ignore modules matching
+to be listed as prerequisites of a package. Particulaly useful
+if they are bundled with core-perl anyway and they have known
+issues building.
+
+Toggle it by supplying the C<--default-ignorelist> option.
+
+=cut
+
+sub _default_ignore_list {
+
+ my $list = << '=cut';
+=pod
+
+ ^IO$ # Provided with core anyway
+ ^Cwd$ # Provided with core anyway
+ ^File::Spec # Provided with core anyway
+ ^Config$ # Perl's own config, not shipped separately
+ ^ExtUtils::MakeMaker$ # Shipped with perl, recent versions
+ # have bug 14721 (see rt.cpan.org)
+ ^ExtUtils::Install$ # Part of of EU::MM, same reason
+
+=cut
+
+ return $list;
+}
+
+=head2 Built-In Ban list
+
+You can use this list of regexes to disable building of these
+modules altogether.
+
+Toggle it by supplying the C<--default-banlist> option.
+
+=cut
+
+sub _default_ban_list {
+
+ my $list = << '=cut';
+=pod
+
+ ^GD$ # Needs c libaries
+ ^Berk.*DB # DB packages require specific options & linking
+ ^DBD:: # DBD drives require database files/headers
+ ^XML:: # XML modules usually require expat libraries
+ Apache # These usually require apache libraries
+ SSL # These usually require SSL certificates & libs
+ Image::Magick # Needs ImageMagick C libraries
+ Mail::ClamAV # Needs ClamAV C Libraries
+ ^Verilog # Needs Verilog C Libraries
+ ^Authen::PAM$ # Needs PAM C libraries & Headers
+
+=cut
+
+ return $list;
+}
+
+__END__
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Dist>, L<CPANPLUS::Module>, L<CPANPLUS::Shell::Default>,
+C<cpanp>
+
+=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.
+
+=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.straw/bin/cpan2dist.bat b/Master/tlpkg/tlperl.straw/bin/cpan2dist.bat
new file mode 100755
index 00000000000..aa670d75d28
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpan2dist.bat
@@ -0,0 +1,687 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+use strict;
+use CPANPLUS::Backend;
+use CPANPLUS::Dist;
+use CPANPLUS::Internals::Constants;
+use Data::Dumper;
+use Getopt::Long;
+use File::Spec;
+use File::Temp qw|tempfile|;
+use File::Basename;
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Data::Dumper::Indent = 1;
+
+use constant PREREQ_SKIP_CLASS => 'CPANPLUS::To::Dist::PREREQ_SKIP';
+use constant ALARM_CLASS => 'CPANPLUS::To::Dist::ALARM';
+
+### print when you can
+$|++;
+
+my $cb = CPANPLUS::Backend->new
+ or die loc("Could not create new CPANPLUS::Backend object");
+my $conf = $cb->configure_object;
+
+my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types;
+
+my $opts = {};
+GetOptions( $opts,
+ 'format=s', 'archive',
+ 'verbose!', 'force!',
+ 'skiptest!', 'keepsource!',
+ 'makefile!', 'buildprereq!',
+ 'help', 'flushcache',
+ 'ban=s@', 'banlist=s@',
+ 'ignore=s@', 'ignorelist=s@',
+ 'defaults', 'modulelist=s@',
+ 'logfile=s', 'timeout=s',
+ 'dist-opts=s%', 'set-config=s%',
+ 'default-banlist!', 'set-program=s%',
+ 'default-ignorelist!', 'edit-metafile!',
+ 'install!'
+ );
+
+die usage() if exists $opts->{'help'};
+
+### parse options
+my $tarball = $opts->{'archive'} || 0;
+my $keep = $opts->{'keepsource'} ? 1 : 0;
+my $prereqbuild = exists $opts->{'buildprereq'}
+ ? $opts->{'buildprereq'}
+ : 0;
+my $timeout = exists $opts->{'timeout'}
+ ? $opts->{'timeout'}
+ : 300;
+
+### use default answers?
+$ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0;
+
+my $format;
+### if provided, we go with the command line option, fall back to conf setting
+{ $format = $opts->{'format'} || $conf->get_conf('dist_type');
+ $conf->set_conf( dist_type => $format );
+
+ ### is this a valid format??
+ die loc("Invalid format: " . ($format || "[NONE]") ) . usage()
+ unless $formats{$format};
+
+ ### any options to fix config entries
+ { my $set_conf = $opts->{'set-config'} || {};
+ while( my($key,$val) = each %$set_conf ) {
+ $conf->set_conf( $key => $val );
+ }
+ }
+
+ ### any options to fix program entries
+ { my $set_prog = $opts->{'set-program'} || {};
+ while( my($key,$val) = each %$set_prog ) {
+ $conf->set_program( $key => $val );
+ }
+ }
+
+ ### any other options passed
+ { my %map = ( verbose => 'verbose',
+ force => 'force',
+ skiptest => 'skiptest',
+ makefile => 'prefer_makefile'
+ );
+
+ ### set config options from arguments
+ while (my($key,$val) = each %map) {
+ my $bool = exists $opts->{$key}
+ ? $opts->{$key}
+ : $conf->get_conf($val);
+ $conf->set_conf( $val => $bool );
+ }
+ }
+}
+
+my @modules = @ARGV;
+if( exists $opts->{'modulelist'} ) {
+ push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} };
+}
+
+die usage() unless @modules;
+
+### set up munge callback if requested
+{ if( $opts->{'edit-metafile'} ) {
+ my $editor = $conf->get_program('editor');
+
+ if( $editor ) {
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'munge_dist_metafile',
+ code => sub {
+ my $self = shift;
+ my $text = shift or return;
+
+ my($fh,$file) = tempfile( UNLINK => 1 );
+
+ unless( print $fh $text ) {
+ warn "Could not print metafile information: $!";
+ return;
+ }
+
+ close $fh;
+
+ system( $editor => $file );
+
+ my $cont = $cb->_get_file_contents( file => $file );
+
+ return $cont;
+ },
+ );
+
+ } else {
+ warn "No editor configured. Can not edit metafiles!\n";
+ }
+ }
+}
+
+my $fh;
+LOGFILE: {
+ if( my $file = $opts->{logfile} ) {
+ open $fh, ">$file" or (
+ warn loc("Could not open '%1' for writing: %2", $file,$!),
+ last LOGFILE
+ );
+
+ warn "Logging to '$file'\n";
+
+ *STDERR = $fh;
+ *STDOUT = $fh;
+ }
+}
+
+### reload indices if so desired
+$cb->reload_indices() if $opts->{'flushcache'};
+
+{ my @ban = exists $opts->{'ban'}
+ ? map { qr/$_/ } @{ $opts->{'ban'} }
+ : ();
+
+
+ if( exists $opts->{'banlist'} ) {
+ push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} };
+ }
+
+ push @ban, map { s/\s+//; $_ }
+ map { [split /\s*#\s*/]->[0] }
+ grep { /#/ }
+ map { split /\n/ } _default_ban_list()
+ if $opts->{'default-banlist'};
+
+ ### use our prereq install callback
+ $conf->set_conf( prereqs => PREREQ_ASK );
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'install_prerequisite',
+ code => \&__ask_about_install,
+ );
+
+
+ ### check for ban patterns when handling prereqs
+ sub __ask_about_install {
+
+ my $mod = shift or return;
+ my $prereq = shift or return;
+
+
+ ### die with an error object, so we can verify that
+ ### the die came from this location, and that it's an
+ ### 'acceptable' death
+ my $pat = ban_me( $prereq );
+ die bless sub { loc("Module '%1' requires '%2' to be installed " .
+ "but found in your ban list (%3) -- skipping",
+ $mod->module, $prereq->module, $pat )
+ }, PREREQ_SKIP_CLASS if $pat;
+ return 1;
+ }
+
+ ### should we skip this module?
+ sub ban_me {
+ my $mod = shift;
+
+ for my $pat ( @ban ) {
+ return $pat if $mod->module =~ /$pat/i;
+ }
+ return;
+ }
+}
+
+### patterns to strip from prereq lists
+{ my @ignore = exists $opts->{'ignore'}
+ ? map { qr/$_/ } @{ $opts->{'ignore'} }
+ : ();
+
+ if( exists $opts->{'ignorelist'} ) {
+ push @ignore, map { parse_file( $_, 1 ) } @{ $opts->{'ignorelist'} };
+ }
+
+ push @ignore, map { s/\s+//; $_ }
+ map { [split /\s*#\s*/]->[0] }
+ grep { /#/ }
+ map { split /\n/ } _default_ignore_list()
+ if $opts->{'default-ignorelist'};
+
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'filter_prereqs',
+ code => \&__filter_prereqs,
+ );
+
+ sub __filter_prereqs {
+ my $cb = shift;
+ my $href = shift;
+
+ for my $name ( keys %$href ) {
+ my $obj = $cb->parse_module( module => $name ) or (
+ warn "Cannot make a module object out of ".
+ "'$name' -- skipping\n",
+ next );
+
+ if( my $pat = ignore_me( $obj ) ) {
+ warn loc("'%1' found in your ignore list (%2) ".
+ "-- filtering it out\n", $name, $pat);
+
+ delete $href->{ $name };
+ }
+ }
+
+ return $href;
+ }
+
+ ### should we skip this module?
+ sub ignore_me {
+ my $mod = shift;
+
+ for my $pat ( @ignore ) {
+ return $pat if $mod->module =~ /$pat/i;
+ return $pat if $mod->package_name =~ /$pat/i;
+ }
+ return;
+ }
+}
+
+
+my %done;
+for my $name (@modules) {
+
+ my $obj;
+
+ ### is it a tarball? then we get it locally and transform it
+ ### and its dependencies into .debs
+ if( $tarball ) {
+ ### make sure we use an absolute path, so chdirs() dont
+ ### mess things up
+ $name = File::Spec->rel2abs( $name );
+
+ ### ENOTARBALL?
+ unless( -e $name ) {
+ warn loc("Archive '$name' does not exist");
+ next;
+ }
+
+ $obj = CPANPLUS::Module::Fake->new(
+ module => basename($name),
+ path => dirname($name),
+ package => basename($name),
+ );
+
+ ### if it's a traditional CPAN package, we can tidy
+ ### up the module name some
+ $obj->module( $obj->package_name ) if $obj->package_name;
+
+ ### get the version from the package name
+ $obj->version( $obj->package_version || 0 );
+
+ ### set the location of the tarball
+ $obj->status->fetch($name);
+
+ ### plain old cpan module?
+ } else {
+
+ ### find the corresponding module object ###
+ $obj = $cb->parse_module( module => $name ) or (
+ warn "Cannot make a module object out of ".
+ "'$name' -- skipping\n",
+ next );
+ }
+
+ ### you banned it?
+ if( my $pat = ban_me( $obj ) ) {
+ warn loc("'%1' found in your ban list (%2) -- skipping\n",
+ $obj->module, $pat );
+ next;
+ }
+
+ ### or just ignored it?
+ if( my $pat = ignore_me( $obj ) ) {
+ warn loc("'%1' found in your ignore list (%2) -- skipping\n",
+ $obj->module, $pat );
+ next;
+ }
+
+
+ my $target = $opts->{'install'} ? 'install' : 'create';
+ my $dist = eval {
+ local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS }
+ if $timeout;
+
+ alarm $timeout || 0;
+
+ my $dist_opts = $opts->{'dist-opts'} || {};
+
+ my $rv = $obj->install(
+ prereq_target => $target,
+ target => $target,
+ keep_source => $keep,
+ prereq_build => $prereqbuild,
+
+ ### any passed arbitrary options
+ %$dist_opts,
+ );
+
+ alarm 0;
+
+ $rv;
+ };
+
+ ### set here again, in case the install dies
+ alarm 0;
+
+ ### install failed due to a 'die' in our prereq skipper?
+ if( $@ and ref $@ and $@->isa( PREREQ_SKIP_CLASS ) ) {
+ warn loc("Dist creation of '%1' skipped: '%2'",
+ $obj->module, $@->() );
+ next;
+
+ } elsif ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
+ warn loc("\nDist creation of '%1' skipped, build time exceeded: ".
+ "%2 seconds\n", $obj->module, $timeout );
+ next;
+
+ ### died for some other reason? just report and skip
+ } elsif ( $@ ) {
+ warn loc("Dist creation of '%1' failed: '%2'",
+ $obj->module, $@ );
+ next;
+ }
+
+ ### we didn't get a dist object back?
+ unless ($dist and $obj->status->dist) {
+ warn loc("Unable to create '%1' dist of '%2'", $format, $obj->module);
+ next
+ }
+
+ print "Created '$format' distribution for ", $obj->module,
+ " to:\n\t", $obj->status->dist->status->dist, "\n";
+}
+
+
+sub parse_file {
+ my $file = shift or return;
+ my $qr = shift() ? 1 : 0;
+
+ my $fh = OPEN_FILE->( $file ) or return;
+
+ my @rv;
+ while( <$fh> ) {
+ chomp;
+ next if /^#/; # skip comments
+ next unless /\S/; # skip empty lines
+ s/^(\S+).*/$1/; # skip extra info
+ push @rv, $qr ? qr/$_/ : $_; # add pattern to the list
+ }
+
+ return @rv;
+}
+
+=head1 NAME
+
+cpan2dist - The CPANPLUS distribution creator
+
+=head1 DESCRIPTION
+
+This script will create distributions of C<CPAN> modules of the format
+you specify, including its prerequisites. These packages can then be
+installed using the corresponding package manager for the format.
+
+Note, you can also do this interactively from the default shell,
+C<CPANPLUS::Shell::Default>. See the C<CPANPLUS::Dist> documentation,
+as well as the documentation of your format of choice for any format
+specific documentation.
+
+=head1 USAGE
+
+=cut
+
+sub usage {
+ my $me = basename($0);
+ my $formats = join "\n", map { "\t\t$_" } sort keys %formats;
+
+ my $usage = << '=cut';
+=pod
+
+ Usage: cpan2dist [--format FMT] [OPTS] Mod::Name [Mod::Name, ...]
+ cpan2dist [--format FMT] [OPTS] --modulelist /tmp/mods.list
+ cpan2dist [--format FMT] [OPTS] --archive /tmp/dist [/tmp/dist2]
+
+ Will create a distribution of type FMT of the modules
+ specified on the command line, and all their prerequisites.
+
+ Can also create a distribution of type FMT from a local
+ archive and all of its prerequisites.
+
+=cut
+
+ $usage .= qq[
+ Possible formats are:
+$formats
+
+ You can install more formats from CPAN!
+ \n];
+
+ $usage .= << '=cut';
+=pod
+
+Options:
+
+ ### take no argument:
+ --help Show this help message
+ --install Install this package (and any prerequisites you built)
+ after building it.
+ --skiptest Skip tests. Can be negated using --noskiptest
+ --force Force operation. Can be negated using --noforce
+ --verbose Be verbose. Can be negated using --noverbose
+ --keepsource Keep sources after building distribution. Can be
+ negated by --nokeepsource. May not be supported
+ by all formats
+ --makefile Prefer Makefile.PL over Build.PL. Can be negated
+ using --nomakefile. Defaults to your config setting
+ --buildprereq Build packages of any prerequisites, even if they are
+ already uptodate on the local system. Can be negated
+ using --nobuildprereq. Defaults to false.
+ --archive Indicate that all modules listed are actually archives
+ --flushcache Update CPANPLUS' cache before commencing any operation
+ --defaults Instruct ExtUtils::MakeMaker and Module::Build to use
+ default answers during 'perl Makefile.PL' or 'perl
+ Build.PL' calls where possible
+ --edit-metafile Edit the distributions metafile(s) before the distribution
+ is built. Requires a configured editor.
+
+ ### take argument:
+ --format Installer format to use (defaults to config setting)
+ --ban Patterns of module names to skip during installation,
+ case-insensitive (affects prerequisites too)
+ May be given multiple times
+ --banlist File containing patterns that could be given to --ban
+ Are appended to the ban list built up by --ban
+ May be given multiple times.
+ --ignore Patterns of modules to exclude from prereq list. Useful
+ for when a prereq listed by a CPAN module is resolved
+ in another way than from its corresponding CPAN package
+ (Match is done on both module name, and package name of
+ the package the module is in, case-insensitive)
+ --ignorelist File containing patterns that may be given to --ignore.
+ Are appended to the ban list built up by --ignore.
+ May be given multiple times.
+ --modulelist File containing a list of modules that should be built.
+ Are appended to the list of command line modules.
+ May be given multiple times.
+ --logfile File to log all output to. By default, all output goes
+ to the console.
+ --timeout The allowed time for buliding a distribution before
+ aborting. This is useful to terminate any build that
+ hang or happen to be interactive despite being told not
+ to be. Defaults to 300 seconds. To turn off, you can
+ set it to 0.
+ --set-config Change any options as specified in your config for this
+ invocation only. See CPANPLUS::Config for a list of
+ supported options.
+ --set-program Change any programs as specified in your config for this
+ invocation only. See CPANPLUS::Config for a list of
+ supported programs.
+ --dist-opts Arbitrary options passed along to the chosen installer
+ format's prepare()/create() routine. Please see the
+ documentation of the installer of your choice for
+ options it accepts.
+
+ ### builtin lists
+ --default-banlist Use our builtin banlist. Works just like --ban
+ and --banlist, but with pre-set lists. See the
+ "Builtin Lists" section for details.
+ --default-ignorelist Use our builtin ignorelist. Works just like
+ --ignore and --ignorelist but with pre-set lists.
+ See the "Builtin Lists" section for details.
+
+Examples:
+
+ ### build a debian package of DBI and its prerequisites,
+ ### don't bother running tests
+ cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI
+
+ ### build a debian package of DBI and its prerequisites and install them
+ cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI
+
+ ### Build a package, whose format is determined by your config, of
+ ### the local tarball, reloading cpanplus' indices first and using
+ ### the tarballs Makefile.PL if it has one.
+ cpan2dist --makefile --flushcache --archive /path/to/Cwd-1.0.tgz
+
+ ### build a package from Net::FTP, but dont build any packages or
+ ### dependencies whose name match 'Foo', 'Bar' or any of the
+ ### patterns mentioned in /tmp/ban
+ cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP
+
+ ### build a package from Net::FTP, but ignore its listed dependency
+ ### on IO::Socket, as it's shipped per default with the OS we're on
+ cpan2dist --ignore IO::Socket Net::FTP
+
+ ### building all modules listed, plus their prerequisites
+ cpan2dist --ignorelist /tmp/modules.ignore --banlist /tmp/modules.ban
+ --modulelist /tmp/modules.list --buildprereq --flushcache
+ --makefile --defaults
+
+ ### pass arbitrary options to the format's prepare()/create() routine
+ cpan2dist --dist-opts deb_version=3 --dist-opts prefix=corp
+
+=cut
+
+ $usage .= qq[
+Builtin Lists:
+
+ Ignore list:] . _default_ignore_list() . qq[
+ Ban list:] . _default_ban_list();
+
+ ### strip the pod directives
+ $usage =~ s/=pod\n//g;
+
+ return $usage;
+}
+
+=pod
+
+=head1 Built-In Filter Lists
+
+Some modules you'd rather not package. Some because they
+are part of core-perl and you dont want a new package.
+Some because they won't build on your system. Some because
+your package manager of choice already packages them for you.
+
+There may be a myriad of reasons. You can use the C<--ignore>
+and C<--ban> options for this, but we provide some built-in
+lists that catch common cases. You can use these built-in lists
+if you like, or supply your own if need be.
+
+=head2 Built-In Ignore List
+
+=pod
+
+You can use this list of regexes to ignore modules matching
+to be listed as prerequisites of a package. Particulaly useful
+if they are bundled with core-perl anyway and they have known
+issues building.
+
+Toggle it by supplying the C<--default-ignorelist> option.
+
+=cut
+
+sub _default_ignore_list {
+
+ my $list = << '=cut';
+=pod
+
+ ^IO$ # Provided with core anyway
+ ^Cwd$ # Provided with core anyway
+ ^File::Spec # Provided with core anyway
+ ^Config$ # Perl's own config, not shipped separately
+ ^ExtUtils::MakeMaker$ # Shipped with perl, recent versions
+ # have bug 14721 (see rt.cpan.org)
+ ^ExtUtils::Install$ # Part of of EU::MM, same reason
+
+=cut
+
+ return $list;
+}
+
+=head2 Built-In Ban list
+
+You can use this list of regexes to disable building of these
+modules altogether.
+
+Toggle it by supplying the C<--default-banlist> option.
+
+=cut
+
+sub _default_ban_list {
+
+ my $list = << '=cut';
+=pod
+
+ ^GD$ # Needs c libaries
+ ^Berk.*DB # DB packages require specific options & linking
+ ^DBD:: # DBD drives require database files/headers
+ ^XML:: # XML modules usually require expat libraries
+ Apache # These usually require apache libraries
+ SSL # These usually require SSL certificates & libs
+ Image::Magick # Needs ImageMagick C libraries
+ Mail::ClamAV # Needs ClamAV C Libraries
+ ^Verilog # Needs Verilog C Libraries
+ ^Authen::PAM$ # Needs PAM C libraries & Headers
+
+=cut
+
+ return $list;
+}
+
+__END__
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Dist>, L<CPANPLUS::Module>, L<CPANPLUS::Shell::Default>,
+C<cpanp>
+
+=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.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/cpandb b/Master/tlpkg/tlperl.straw/bin/cpandb
new file mode 100755
index 00000000000..46c07b939a1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpandb
@@ -0,0 +1,272 @@
+#!C:\strawberry\perl\bin\perl.exe
+use strict;
+use warnings;
+use CPAN::SQLite;
+use CPAN::SQLite::Util qw(%chaps);
+use Getopt::Long;
+my ($CPAN, $setup, $help, $reindex, $index, $query,
+ $db_name, $db_dir, $module, $dist, $cpanid, $update);
+
+my $rc = GetOptions('CPAN=s' => \$CPAN,
+ 'db_name=s' => \$db_name,
+ 'db_dir=s' => \$db_dir,
+ 'setup' => \$setup,
+ 'update' => \$update,
+ 'help' => \$help,
+ 'module=s' => \$module,
+ 'dist=s' => \$dist,
+ 'cpanid=s' => \$cpanid,
+ 'reindex=s' => \$reindex);
+
+$query = ($module or $dist or $cpanid);
+$index = ($update or $reindex or $setup);
+
+if ($help or not $rc or not ($index or $query)) {
+ print <<"END";
+
+Setup, maintain, and search the CPAN::SQLite database
+Usage:
+ $^X $0 --setup
+ $^X $0 --update
+ $^X $0 --reindex dist_name
+
+ $^X $0 --module Mod::Name
+ $^X $0 --dist Distname
+ $^X $0 --cpanid CPANID
+
+ $^X $0 --help
+END
+ exit(1);
+}
+
+if (defined $setup and defined $reindex) {
+ die "Must reindex on an exisiting database";
+}
+
+if ($index) {
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ setup => $setup,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ reindex => $reindex,
+ );
+ $obj->index();
+}
+else {
+
+ my $max_results = 100;
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ max_results => $max_results);
+ my $results;
+
+ RESULTS : {
+ $module and do {
+ $obj->query(mode => 'module', name => $module);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo module by name of "$module" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{mod_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ my $chapter_desc = $results->{chapter_desc} || '';
+ print << "EOI";
+
+Module: $results->{mod_name}
+Abstract: $abs
+Version: $results->{mod_vers}
+Chapter: $chapter_desc
+Distribution: $results->{dist_name}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ last RESULTS;
+ };
+ $dist and do {
+ $obj->query(mode => 'dist', name => $dist);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo distribution by name of "$dist" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{dist_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ print << "EOI";
+
+Distribution: $results->{dist_name}
+Abstract: $abs
+Version: $results->{dist_vers}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ my $mods = $results->{mods};
+ if ($mods and (ref($mods) eq 'ARRAY')) {
+ print qq{\nProvided modules:\n};
+ foreach my $item(@$mods) {
+ my $abs = $item->{mod_abs} || '';
+ print qq{ $item->{mod_name}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ $cpanid and do {
+ $obj->query(mode => 'author', name => $cpanid);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo cpanid by name of "$cpanid" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ print << "EOI";
+
+CPANID: $results->{cpanid}
+Full Name: $results->{fullname}
+email: $results->{email}
+EOI
+ }
+ my $dists = $results->{dists};
+ if ($dists and (ref($dists) eq 'ARRAY')) {
+ print qq{\nAvailable distributions:\n};
+ foreach my $item(@$dists) {
+ my $abs = $item->{dist_abs} || '';
+ print qq{ $item->{dist_file}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ }
+}
+
+__END__
+
+=head1 NAME
+
+cpandb - interface to C<CPAN::SQLite>
+
+=head1 DESCRIPTION
+
+This script is an interface to the routines of
+L<CPAN::SQLite> for setting up, maintaining and
+searching a C<DBD::SQLite> database
+of CPAN. Available options can be grouped into
+three categories.
+
+=head2 Common options
+
+These are options which are common to both setting up
+and maintaining the database or performing queries on it.
+These are
+
+=over 3
+
+=item * C<--CPAN '/path/to/CPAN'>
+
+This specifies the path to where the index files are
+to be stored. This could be a local CPAN mirror,
+defined here by the presence of a F<MIRRORED.BY> file beneath
+this directory, or a local directory in which to store
+these files from a remote CPAN mirror. In the latter case,
+the index files are fetched from a remote CPAN mirror,
+using the same list that C<CPAN.pm> uses, if this is
+configured, and are updated if they are more than one
+day old.
+
+If the C<CPAN> option is not given, it will default
+to C<cpan_home> of L<CPAN>, if this is configured,
+with the sources being found under C<keep_source_where>.
+A fatal error results if such a directory isn't found.
+Updates to these index files are assumed here to be
+handled by C<CPAN.pm>.
+
+=item * C<--db_name 'cpan-sqlite'>
+
+This is the name of the database that C<DBD::SQLite>
+will use. If not given, this defaults to C<cpandb-sqlite>.
+
+=item * C<--db_dir '/path/to/db/dir'>
+
+This specifies the path to where the database file is
+found. If not given, it defaults to the
+C<cpan_home> directory of C<CPAN.pm>, if present, or to
+the directory in which the script was invoked.
+
+=back
+
+=head2 Indexing options
+
+These are options which are used for setting up and
+maintaining the database. These include
+
+=over 3
+
+=item * C<--setup>
+
+This specifies that the database is to be created and
+populated from the CPAN indices; any exisiting database
+will be overwritten.
+
+=item * C<--update>
+
+This is used to update an exisiting database,
+which must have first been created with the C<setup>
+option.
+
+=item * C<--reindex 'dist_name'>
+
+This specifies that the CPAN distribution C<dist_name>
+is to be reindexed.
+
+=back
+
+=head2 Querying options
+
+These options are used to query the database. Available
+options are
+
+=over 3
+
+=item * C<--module Mod::Name>
+
+This provides information on the specified module name.
+
+=item * C<--dist Dist-Name>
+
+This provides information on the specified distribution name.
+
+=item * C<--cpanid CPANID>
+
+This provides information on the specified CPAN author id
+
+=back
+
+All search terms are assumed to be exact matches in a
+case-insensitive manner.
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/bin/cpandb.bat b/Master/tlpkg/tlperl.straw/bin/cpandb.bat
new file mode 100755
index 00000000000..0eeeb422909
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpandb.bat
@@ -0,0 +1,288 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!C:\strawberry\perl\bin\perl.exe
+#line 15
+use strict;
+use warnings;
+use CPAN::SQLite;
+use CPAN::SQLite::Util qw(%chaps);
+use Getopt::Long;
+my ($CPAN, $setup, $help, $reindex, $index, $query,
+ $db_name, $db_dir, $module, $dist, $cpanid, $update);
+
+my $rc = GetOptions('CPAN=s' => \$CPAN,
+ 'db_name=s' => \$db_name,
+ 'db_dir=s' => \$db_dir,
+ 'setup' => \$setup,
+ 'update' => \$update,
+ 'help' => \$help,
+ 'module=s' => \$module,
+ 'dist=s' => \$dist,
+ 'cpanid=s' => \$cpanid,
+ 'reindex=s' => \$reindex);
+
+$query = ($module or $dist or $cpanid);
+$index = ($update or $reindex or $setup);
+
+if ($help or not $rc or not ($index or $query)) {
+ print <<"END";
+
+Setup, maintain, and search the CPAN::SQLite database
+Usage:
+ $^X $0 --setup
+ $^X $0 --update
+ $^X $0 --reindex dist_name
+
+ $^X $0 --module Mod::Name
+ $^X $0 --dist Distname
+ $^X $0 --cpanid CPANID
+
+ $^X $0 --help
+END
+ exit(1);
+}
+
+if (defined $setup and defined $reindex) {
+ die "Must reindex on an exisiting database";
+}
+
+if ($index) {
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ setup => $setup,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ reindex => $reindex,
+ );
+ $obj->index();
+}
+else {
+
+ my $max_results = 100;
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ max_results => $max_results);
+ my $results;
+
+ RESULTS : {
+ $module and do {
+ $obj->query(mode => 'module', name => $module);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo module by name of "$module" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{mod_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ my $chapter_desc = $results->{chapter_desc} || '';
+ print << "EOI";
+
+Module: $results->{mod_name}
+Abstract: $abs
+Version: $results->{mod_vers}
+Chapter: $chapter_desc
+Distribution: $results->{dist_name}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ last RESULTS;
+ };
+ $dist and do {
+ $obj->query(mode => 'dist', name => $dist);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo distribution by name of "$dist" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{dist_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ print << "EOI";
+
+Distribution: $results->{dist_name}
+Abstract: $abs
+Version: $results->{dist_vers}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ my $mods = $results->{mods};
+ if ($mods and (ref($mods) eq 'ARRAY')) {
+ print qq{\nProvided modules:\n};
+ foreach my $item(@$mods) {
+ my $abs = $item->{mod_abs} || '';
+ print qq{ $item->{mod_name}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ $cpanid and do {
+ $obj->query(mode => 'author', name => $cpanid);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo cpanid by name of "$cpanid" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ print << "EOI";
+
+CPANID: $results->{cpanid}
+Full Name: $results->{fullname}
+email: $results->{email}
+EOI
+ }
+ my $dists = $results->{dists};
+ if ($dists and (ref($dists) eq 'ARRAY')) {
+ print qq{\nAvailable distributions:\n};
+ foreach my $item(@$dists) {
+ my $abs = $item->{dist_abs} || '';
+ print qq{ $item->{dist_file}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ }
+}
+
+__END__
+
+=head1 NAME
+
+cpandb - interface to C<CPAN::SQLite>
+
+=head1 DESCRIPTION
+
+This script is an interface to the routines of
+L<CPAN::SQLite> for setting up, maintaining and
+searching a C<DBD::SQLite> database
+of CPAN. Available options can be grouped into
+three categories.
+
+=head2 Common options
+
+These are options which are common to both setting up
+and maintaining the database or performing queries on it.
+These are
+
+=over 3
+
+=item * C<--CPAN '/path/to/CPAN'>
+
+This specifies the path to where the index files are
+to be stored. This could be a local CPAN mirror,
+defined here by the presence of a F<MIRRORED.BY> file beneath
+this directory, or a local directory in which to store
+these files from a remote CPAN mirror. In the latter case,
+the index files are fetched from a remote CPAN mirror,
+using the same list that C<CPAN.pm> uses, if this is
+configured, and are updated if they are more than one
+day old.
+
+If the C<CPAN> option is not given, it will default
+to C<cpan_home> of L<CPAN>, if this is configured,
+with the sources being found under C<keep_source_where>.
+A fatal error results if such a directory isn't found.
+Updates to these index files are assumed here to be
+handled by C<CPAN.pm>.
+
+=item * C<--db_name 'cpan-sqlite'>
+
+This is the name of the database that C<DBD::SQLite>
+will use. If not given, this defaults to C<cpandb-sqlite>.
+
+=item * C<--db_dir '/path/to/db/dir'>
+
+This specifies the path to where the database file is
+found. If not given, it defaults to the
+C<cpan_home> directory of C<CPAN.pm>, if present, or to
+the directory in which the script was invoked.
+
+=back
+
+=head2 Indexing options
+
+These are options which are used for setting up and
+maintaining the database. These include
+
+=over 3
+
+=item * C<--setup>
+
+This specifies that the database is to be created and
+populated from the CPAN indices; any exisiting database
+will be overwritten.
+
+=item * C<--update>
+
+This is used to update an exisiting database,
+which must have first been created with the C<setup>
+option.
+
+=item * C<--reindex 'dist_name'>
+
+This specifies that the CPAN distribution C<dist_name>
+is to be reindexed.
+
+=back
+
+=head2 Querying options
+
+These options are used to query the database. Available
+options are
+
+=over 3
+
+=item * C<--module Mod::Name>
+
+This provides information on the specified module name.
+
+=item * C<--dist Dist-Name>
+
+This provides information on the specified distribution name.
+
+=item * C<--cpanid CPANID>
+
+This provides information on the specified CPAN author id
+
+=back
+
+All search terms are assumed to be exact matches in a
+case-insensitive manner.
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite>.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/cpaninject b/Master/tlpkg/tlperl.straw/bin/cpaninject
new file mode 100755
index 00000000000..12679fb1737
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpaninject
@@ -0,0 +1,137 @@
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME
+
+cpaninject - Inject a distribution for installation via the CPAN shell
+
+=head1 SYNOPSIS
+
+ # Add the distribution
+ cpaninject myperlmodule.tar.gz
+
+ # And then install it from the cpan shell
+ cpan> install LOCAL/myperlmodule.tar.gz
+
+=head1 DESCRIPTION
+
+B<cpaninject> is a small front-end application for the L<CPAN::Inject>
+module.
+
+It takes any arbitrary Perl distribution tarball (open source or
+otherwise) and injects it into the local CPAN file cache, smoothing
+some metadata files to make it look as if it came from CPAN.
+
+It makes use the officially blessed "Reserved Local CPAN Author" id
+"LOCAL" as the author the distributions are added under.
+
+To use the program, just run F<cpaninject> F<mytarball.tar.gz> to add it,
+then the CPAN shell to install it (with full automatic recursive
+dependency installation).
+
+The key here being the recursive dependency installation, which you are
+now able to do even for installing non-CPAN modules.
+
+This simplifies the installation process a little, and makes things easier
+on someone that just wants to install a single commercial or non-CPAN
+Perl module that might have a dozen or more CPAN dependencies.
+
+=cut
+
+package cpaninject;
+
+use strict;
+use Params::Util '_STRING';
+use CPAN::Inject;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '0.11';
+}
+
+
+
+
+
+#####################################################################
+# Configuration
+
+unless ( @ARGV ) {
+ error("Usage: cpaninject ./any/Perl-Distribution-1.00.tar.gz");
+}
+
+# Get the file name
+my $file = _STRING(shift @ARGV);
+unless ( $file ) {
+ error("Did not provide a file name");
+}
+unless ( -f $file ) {
+ error("File '$file' does not exist");
+}
+unless ( -r $file ) {
+ error("No permissions to read '$file'");
+}
+
+# Create the injector
+my $cpan = eval { CPAN::Inject->from_cpan_config };
+if ( $@ ) {
+ my $message = $@;
+ $message =~ s/^(.+)\s+at line.+$/$1/;
+ error( $message );
+}
+
+# Add the file
+my $path = $cpan->add( file => $file );
+message( "Injected $file ok.\n" );
+message( "The following command will install it from the CPAN shell.\n" );
+message( "\n" );
+message( "cpan> install $path\n" );
+message( "\n" );
+exit(0);
+
+
+
+
+
+#####################################################################
+# Support Functions
+
+sub message ($) {
+ print ' ' . $_[0];
+}
+
+sub error (@) {
+ print ' ' . join '', map { "$_\n" } ('', @_, '');
+ exit(255);
+}
+
+=pod
+
+=head1 SUPPORT
+
+All bugs should be filed via the bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPAN-Inject>
+
+For other issues, or commercial enhancement and support, contact the author
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<CPAN::Mini::Inject>
+
+=head1 COPYRIGHT
+
+Copyright 2006 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/cpaninject.bat b/Master/tlpkg/tlperl.straw/bin/cpaninject.bat
new file mode 100755
index 00000000000..ddbeeff5dd2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpaninject.bat
@@ -0,0 +1,153 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+=pod
+
+=head1 NAME
+
+cpaninject - Inject a distribution for installation via the CPAN shell
+
+=head1 SYNOPSIS
+
+ # Add the distribution
+ cpaninject myperlmodule.tar.gz
+
+ # And then install it from the cpan shell
+ cpan> install LOCAL/myperlmodule.tar.gz
+
+=head1 DESCRIPTION
+
+B<cpaninject> is a small front-end application for the L<CPAN::Inject>
+module.
+
+It takes any arbitrary Perl distribution tarball (open source or
+otherwise) and injects it into the local CPAN file cache, smoothing
+some metadata files to make it look as if it came from CPAN.
+
+It makes use the officially blessed "Reserved Local CPAN Author" id
+"LOCAL" as the author the distributions are added under.
+
+To use the program, just run F<cpaninject> F<mytarball.tar.gz> to add it,
+then the CPAN shell to install it (with full automatic recursive
+dependency installation).
+
+The key here being the recursive dependency installation, which you are
+now able to do even for installing non-CPAN modules.
+
+This simplifies the installation process a little, and makes things easier
+on someone that just wants to install a single commercial or non-CPAN
+Perl module that might have a dozen or more CPAN dependencies.
+
+=cut
+
+package cpaninject;
+
+use strict;
+use Params::Util '_STRING';
+use CPAN::Inject;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '0.11';
+}
+
+
+
+
+
+#####################################################################
+# Configuration
+
+unless ( @ARGV ) {
+ error("Usage: cpaninject ./any/Perl-Distribution-1.00.tar.gz");
+}
+
+# Get the file name
+my $file = _STRING(shift @ARGV);
+unless ( $file ) {
+ error("Did not provide a file name");
+}
+unless ( -f $file ) {
+ error("File '$file' does not exist");
+}
+unless ( -r $file ) {
+ error("No permissions to read '$file'");
+}
+
+# Create the injector
+my $cpan = eval { CPAN::Inject->from_cpan_config };
+if ( $@ ) {
+ my $message = $@;
+ $message =~ s/^(.+)\s+at line.+$/$1/;
+ error( $message );
+}
+
+# Add the file
+my $path = $cpan->add( file => $file );
+message( "Injected $file ok.\n" );
+message( "The following command will install it from the CPAN shell.\n" );
+message( "\n" );
+message( "cpan> install $path\n" );
+message( "\n" );
+exit(0);
+
+
+
+
+
+#####################################################################
+# Support Functions
+
+sub message ($) {
+ print ' ' . $_[0];
+}
+
+sub error (@) {
+ print ' ' . join '', map { "$_\n" } ('', @_, '');
+ exit(255);
+}
+
+=pod
+
+=head1 SUPPORT
+
+All bugs should be filed via the bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPAN-Inject>
+
+For other issues, or commercial enhancement and support, contact the author
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<CPAN::Mini::Inject>
+
+=head1 COPYRIGHT
+
+Copyright 2006 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/cpanp b/Master/tlpkg/tlperl.straw/bin/cpanp
new file mode 100755
index 00000000000..a493322cc29
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpanp
@@ -0,0 +1,104 @@
+#!/usr/bin/perl
+# $File: //depot/cpanplus/dist/bin/cpanp $
+# $Revision: #8 $ $Change: 8345 $ $DateTime: 2003/10/05 19:25:48 $
+
+use strict;
+use vars '$VERSION';
+
+use CPANPLUS;
+$VERSION = CPANPLUS->VERSION;
+
+use CPANPLUS::Shell qw[Default];
+my $shell = CPANPLUS::Shell->new;
+
+### if we're given a command, run it; otherwise, open a shell.
+if (@ARGV) {
+ ### take the command line arguments as a command
+ my $input = "@ARGV";
+ ### if they said "--help", fix it up to work.
+ $input = 'h' if $input =~ /^\s*--?h(?:elp)?\s*$/i;
+ ### strip the leading dash
+ $input =~ s/^\s*-//;
+ ### pass the command line to the shell
+ ### exit with a useful return value on return
+ exit not $shell->dispatch_on_input(input => $input, noninteractive => 1);
+} else {
+ ### open a shell for the user
+ $shell->shell();
+}
+
+=head1 NAME
+
+cpanp - The CPANPLUS launcher
+
+=head1 SYNOPSIS
+
+B<cpanp>
+
+B<cpanp> S<[-]B<a>> S<[ --[B<no>-]I<option>... ]> S< I<author>... >
+
+B<cpanp> S<[-]B<mfitulrcz>> S<[ --[B<no>-]I<option>... ]> S< I<module>... >
+
+B<cpanp> S<[-]B<d>> S<[ --[B<no>-]I<option>... ]> S<[ --B<fetchdir>=... ]> S< I<module>... >
+
+B<cpanp> S<[-]B<xb>> S<[ --[B<no>-]I<option>... ]>
+
+B<cpanp> S<[-]B<o>> S<[ --[B<no>-]I<option>... ]> S<[ I<module>... ]>
+
+=head1 DESCRIPTION
+
+This script launches the B<CPANPLUS> utility to perform various operations
+from the command line. If it's invoked without arguments, an interactive
+shell is executed by default.
+
+Optionally, it can take a single-letter switch and one or more argument,
+to perform the associated action on each arguments. A summary of the
+available commands is listed below; C<cpanp -h> provides a detailed list.
+
+ h # help information
+ v # version information
+
+ a AUTHOR ... # search by author(s)
+ m MODULE ... # search by module(s)
+ f MODULE ... # list all releases of a module
+
+ i MODULE ... # install module(s)
+ t MODULE ... # test module(s)
+ u MODULE ... # uninstall module(s)
+ d MODULE ... # download module(s)
+ l MODULE ... # display detailed information about module(s)
+ r MODULE ... # display README files of module(s)
+ c MODULE ... # check for module report(s) from cpan-testers
+ z MODULE ... # extract module(s) and open command prompt in it
+
+ x # reload CPAN indices
+
+ o [ MODULE ... ] # list installed module(s) that aren't up to date
+ b # write a bundle file for your configuration
+
+Each command may be followed by one or more I<options>. If preceded by C<no>,
+the corresponding option will be set to C<0>, otherwise it's set to C<1>.
+
+Example: To skip a module's tests,
+
+ cpanp -i --skiptest MODULE ...
+
+Valid options for most commands are C<cpantest>, C<debug>, C<flush>, C<force>,
+C<prereqs>, C<storable>, C<verbose>, C<md5>, C<signature>, and C<skiptest>; the
+'d' command also accepts C<fetchdir>. Please consult L<CPANPLUS::Configure>
+for an explanation to their meanings.
+
+Example: To download a module's tarball to the current directory,
+
+ cpanp -d --fetchdir=. MODULE ...
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/bin/cpanp-run-perl b/Master/tlpkg/tlperl.straw/bin/cpanp-run-perl
new file mode 100755
index 00000000000..34e62bddd04
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpanp-run-perl
@@ -0,0 +1,10 @@
+use strict;
+my $old = select STDERR; $|++; # turn on autoflush
+select $old; $|++; # turn on autoflush
+$0 = shift(@ARGV); # rename the script
+my $rv = do($0); # execute the file
+die $@ if $@; # die on parse/execute error
+
+### XXX 'do' returns last statement evaluated, which may be
+### undef as well. So don't die in that case.
+#die $! if not defined $rv; # die on execute error
diff --git a/Master/tlpkg/tlperl.straw/bin/cpanp-run-perl.bat b/Master/tlpkg/tlperl.straw/bin/cpanp-run-perl.bat
new file mode 100755
index 00000000000..b00cb8b2282
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpanp-run-perl.bat
@@ -0,0 +1,27 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+use strict;
+my $old = select STDERR; $|++; # turn on autoflush
+select $old; $|++; # turn on autoflush
+$0 = shift(@ARGV); # rename the script
+my $rv = do($0); # execute the file
+die $@ if $@; # die on parse/execute error
+
+### XXX 'do' returns last statement evaluated, which may be
+### undef as well. So don't die in that case.
+#die $! if not defined $rv; # die on execute error
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/cpanp.bat b/Master/tlpkg/tlperl.straw/bin/cpanp.bat
new file mode 100755
index 00000000000..af12a334b3e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpanp.bat
@@ -0,0 +1,120 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+# $File: //depot/cpanplus/dist/bin/cpanp $
+# $Revision: #8 $ $Change: 8345 $ $DateTime: 2003/10/05 19:25:48 $
+
+use strict;
+use vars '$VERSION';
+
+use CPANPLUS;
+$VERSION = CPANPLUS->VERSION;
+
+use CPANPLUS::Shell qw[Default];
+my $shell = CPANPLUS::Shell->new;
+
+### if we're given a command, run it; otherwise, open a shell.
+if (@ARGV) {
+ ### take the command line arguments as a command
+ my $input = "@ARGV";
+ ### if they said "--help", fix it up to work.
+ $input = 'h' if $input =~ /^\s*--?h(?:elp)?\s*$/i;
+ ### strip the leading dash
+ $input =~ s/^\s*-//;
+ ### pass the command line to the shell
+ ### exit with a useful return value on return
+ exit not $shell->dispatch_on_input(input => $input, noninteractive => 1);
+} else {
+ ### open a shell for the user
+ $shell->shell();
+}
+
+=head1 NAME
+
+cpanp - The CPANPLUS launcher
+
+=head1 SYNOPSIS
+
+B<cpanp>
+
+B<cpanp> S<[-]B<a>> S<[ --[B<no>-]I<option>... ]> S< I<author>... >
+
+B<cpanp> S<[-]B<mfitulrcz>> S<[ --[B<no>-]I<option>... ]> S< I<module>... >
+
+B<cpanp> S<[-]B<d>> S<[ --[B<no>-]I<option>... ]> S<[ --B<fetchdir>=... ]> S< I<module>... >
+
+B<cpanp> S<[-]B<xb>> S<[ --[B<no>-]I<option>... ]>
+
+B<cpanp> S<[-]B<o>> S<[ --[B<no>-]I<option>... ]> S<[ I<module>... ]>
+
+=head1 DESCRIPTION
+
+This script launches the B<CPANPLUS> utility to perform various operations
+from the command line. If it's invoked without arguments, an interactive
+shell is executed by default.
+
+Optionally, it can take a single-letter switch and one or more argument,
+to perform the associated action on each arguments. A summary of the
+available commands is listed below; C<cpanp -h> provides a detailed list.
+
+ h # help information
+ v # version information
+
+ a AUTHOR ... # search by author(s)
+ m MODULE ... # search by module(s)
+ f MODULE ... # list all releases of a module
+
+ i MODULE ... # install module(s)
+ t MODULE ... # test module(s)
+ u MODULE ... # uninstall module(s)
+ d MODULE ... # download module(s)
+ l MODULE ... # display detailed information about module(s)
+ r MODULE ... # display README files of module(s)
+ c MODULE ... # check for module report(s) from cpan-testers
+ z MODULE ... # extract module(s) and open command prompt in it
+
+ x # reload CPAN indices
+
+ o [ MODULE ... ] # list installed module(s) that aren't up to date
+ b # write a bundle file for your configuration
+
+Each command may be followed by one or more I<options>. If preceded by C<no>,
+the corresponding option will be set to C<0>, otherwise it's set to C<1>.
+
+Example: To skip a module's tests,
+
+ cpanp -i --skiptest MODULE ...
+
+Valid options for most commands are C<cpantest>, C<debug>, C<flush>, C<force>,
+C<prereqs>, C<storable>, C<verbose>, C<md5>, C<signature>, and C<skiptest>; the
+'d' command also accepts C<fetchdir>. Please consult L<CPANPLUS::Configure>
+for an explanation to their meanings.
+
+Example: To download a module's tarball to the current directory,
+
+ cpanp -d --fetchdir=. MODULE ...
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/cpansign b/Master/tlpkg/tlperl.straw/bin/cpansign
new file mode 100755
index 00000000000..64fb87ed8f2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpansign
@@ -0,0 +1,95 @@
+#!/usr/bin/perl
+
+$VERSION = '0.06';
+
+=head1 NAME
+
+cpansign - CPAN signature management utility
+
+=head1 SYNOPSIS
+
+ % cpansign # verify an existing SIGNATURE, or
+ # make a new one if none exists
+
+ % cpansign file.par # verify or sign a PAR file
+
+ % cpansign sign # make signature; overwrites existing one
+ % cpansign -s # same thing
+
+ % cpansign verify # verify a signature
+ % cpansign -v # same thing
+ % cpansign -v --skip # ignore files in MANIFEST.SKIP
+
+ % cpansign help # display this documentation
+ % cpansign -h # same thing
+
+=head1 DESCRIPTION
+
+This utility lets you create and verify SIGNATURE files.
+
+=cut
+
+use strict;
+use Module::Signature;
+
+$Module::Signature::Verbose = 1;
+
+my %cmd = (
+ s => 'sign',
+ v => 'verify',
+ h => 'help',
+);
+
+my $op = $ARGV[0]; $op =~ s/^--?// if defined $op;
+my $dwim;
+if (!$op or $op eq 'skip' or -e $op) {
+ $op = (-e 'SIGNATURE' ? 'verify' : 'sign');
+ $dwim = 1;
+}
+
+my $cmd = $cmd{substr($op, 0, 1)};
+(system("perldoc $0"), exit) if $cmd eq 'help';
+my @args;
+push @args, (overwrite => '1') if $cmd eq 'sign';
+push @args, (skip => '0') unless grep /^-?-?skip/, @ARGV;
+
+if (my $sub = Module::Signature->can($cmd)) {
+ if (@ARGV and -e $ARGV[-1]) {
+ require PAR::Dist;
+ PAR::Dist::_verify_or_sign(
+ dist => $ARGV[-1],
+ $dwim ? () : (action => $cmd, @args)
+ );
+ }
+ else {
+ #if ($cmd eq 'sign') {
+ # exit unless Module::Signature::verify();
+ #}
+ exit($sub->(@args));
+ }
+}
+else {
+ die "Unknown command: '$op'.\n".
+ "Available actions: " . (join(', ', sort values %cmd)) . ".\n";
+}
+
+exit;
+
+=head1 SEE ALSO
+
+L<Module::Signature>
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>autrijus@autrijus.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002, 2003, 2006 by Audrey Tang.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/cpansign.bat b/Master/tlpkg/tlperl.straw/bin/cpansign.bat
new file mode 100755
index 00000000000..512befb81d8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/cpansign.bat
@@ -0,0 +1,111 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+$VERSION = '0.06';
+
+=head1 NAME
+
+cpansign - CPAN signature management utility
+
+=head1 SYNOPSIS
+
+ % cpansign # verify an existing SIGNATURE, or
+ # make a new one if none exists
+
+ % cpansign file.par # verify or sign a PAR file
+
+ % cpansign sign # make signature; overwrites existing one
+ % cpansign -s # same thing
+
+ % cpansign verify # verify a signature
+ % cpansign -v # same thing
+ % cpansign -v --skip # ignore files in MANIFEST.SKIP
+
+ % cpansign help # display this documentation
+ % cpansign -h # same thing
+
+=head1 DESCRIPTION
+
+This utility lets you create and verify SIGNATURE files.
+
+=cut
+
+use strict;
+use Module::Signature;
+
+$Module::Signature::Verbose = 1;
+
+my %cmd = (
+ s => 'sign',
+ v => 'verify',
+ h => 'help',
+);
+
+my $op = $ARGV[0]; $op =~ s/^--?// if defined $op;
+my $dwim;
+if (!$op or $op eq 'skip' or -e $op) {
+ $op = (-e 'SIGNATURE' ? 'verify' : 'sign');
+ $dwim = 1;
+}
+
+my $cmd = $cmd{substr($op, 0, 1)};
+(system("perldoc $0"), exit) if $cmd eq 'help';
+my @args;
+push @args, (overwrite => '1') if $cmd eq 'sign';
+push @args, (skip => '0') unless grep /^-?-?skip/, @ARGV;
+
+if (my $sub = Module::Signature->can($cmd)) {
+ if (@ARGV and -e $ARGV[-1]) {
+ require PAR::Dist;
+ PAR::Dist::_verify_or_sign(
+ dist => $ARGV[-1],
+ $dwim ? () : (action => $cmd, @args)
+ );
+ }
+ else {
+ #if ($cmd eq 'sign') {
+ # exit unless Module::Signature::verify();
+ #}
+ exit($sub->(@args));
+ }
+}
+else {
+ die "Unknown command: '$op'.\n".
+ "Available actions: " . (join(', ', sort values %cmd)) . ".\n";
+}
+
+exit;
+
+=head1 SEE ALSO
+
+L<Module::Signature>
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>autrijus@autrijus.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002, 2003, 2006 by Audrey Tang.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/crc32 b/Master/tlpkg/tlperl.straw/bin/crc32
new file mode 100755
index 00000000000..aa7da02a8ad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/crc32
@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+
+# Computes and prints to stdout the CRC-32 values of the given files
+
+use strict;
+use lib qw( blib/lib lib );
+use Archive::Zip;
+use FileHandle;
+
+my $totalFiles = scalar(@ARGV);
+foreach my $file (@ARGV) {
+ if ( -d $file ) {
+ warn "$0: ${file}: Is a directory\n";
+ next;
+ }
+ my $fh = FileHandle->new();
+ if ( !$fh->open( $file, 'r' ) ) {
+ warn "$0: $!\n";
+ next;
+ }
+ binmode($fh);
+ my $buffer;
+ my $bytesRead;
+ my $crc = 0;
+ while ( $bytesRead = $fh->read( $buffer, 32768 ) ) {
+ $crc = Archive::Zip::computeCRC32( $buffer, $crc );
+ }
+ printf( "%08x", $crc );
+ print("\t$file") if ( $totalFiles > 1 );
+ print("\n");
+}
diff --git a/Master/tlpkg/tlperl.straw/bin/crc32.bat b/Master/tlpkg/tlperl.straw/bin/crc32.bat
new file mode 100755
index 00000000000..623a893a786
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/crc32.bat
@@ -0,0 +1,47 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+# Computes and prints to stdout the CRC-32 values of the given files
+
+use strict;
+use lib qw( blib/lib lib );
+use Archive::Zip;
+use FileHandle;
+
+my $totalFiles = scalar(@ARGV);
+foreach my $file (@ARGV) {
+ if ( -d $file ) {
+ warn "$0: ${file}: Is a directory\n";
+ next;
+ }
+ my $fh = FileHandle->new();
+ if ( !$fh->open( $file, 'r' ) ) {
+ warn "$0: $!\n";
+ next;
+ }
+ binmode($fh);
+ my $buffer;
+ my $bytesRead;
+ my $crc = 0;
+ while ( $bytesRead = $fh->read( $buffer, 32768 ) ) {
+ $crc = Archive::Zip::computeCRC32( $buffer, $crc );
+ }
+ printf( "%08x", $crc );
+ print("\t$file") if ( $totalFiles > 1 );
+ print("\n");
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/dbilogstrip b/Master/tlpkg/tlperl.straw/bin/dbilogstrip
new file mode 100755
index 00000000000..36623718308
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/dbilogstrip
@@ -0,0 +1,50 @@
+#!perl
+
+=head1 NAME
+
+dbilogstrip - filter to normalize DBI trace logs for diff'ing
+
+=head1 SYNOPSIS
+
+Read DBI trace file C<dbitrace.log> and write out a stripped version to C<dbitrace_stripped.log>
+
+ dbilogstrip dbitrace.log > dbitrace_stripped.log
+
+Run C<yourscript.pl> twice, each with different sets of arguments, with
+DBI_TRACE enabled. Filter the output and trace through C<dbilogstrip> into a
+separate file for each run. Then compare using diff. (This example assumes
+you're using a standard shell.)
+
+ DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log
+ DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log
+ diff -u dbitrace1.log dbitrace2.log
+
+=head1 DESCRIPTION
+
+Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>.
+
+Replaces any references to process id or thread id, like C<pid#6254> with C<pidN>.
+
+So a DBI trace line like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400
+
+will look like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN
+
+=cut
+
+use strict;
+
+while (<>) {
+ # normalize hex addresses: 0xDEADHEAD => 0xN
+ s/ \b 0x [0-9a-f]+ /0xN/gx;
+ # normalize process and thread id number
+ s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx;
+
+} continue {
+ print or die "-p destination: $!\n";
+}
+
+
diff --git a/Master/tlpkg/tlperl.straw/bin/dbilogstrip.bat b/Master/tlpkg/tlperl.straw/bin/dbilogstrip.bat
new file mode 100755
index 00000000000..f5f852aaee6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/dbilogstrip.bat
@@ -0,0 +1,66 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+=head1 NAME
+
+dbilogstrip - filter to normalize DBI trace logs for diff'ing
+
+=head1 SYNOPSIS
+
+Read DBI trace file C<dbitrace.log> and write out a stripped version to C<dbitrace_stripped.log>
+
+ dbilogstrip dbitrace.log > dbitrace_stripped.log
+
+Run C<yourscript.pl> twice, each with different sets of arguments, with
+DBI_TRACE enabled. Filter the output and trace through C<dbilogstrip> into a
+separate file for each run. Then compare using diff. (This example assumes
+you're using a standard shell.)
+
+ DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log
+ DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log
+ diff -u dbitrace1.log dbitrace2.log
+
+=head1 DESCRIPTION
+
+Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>.
+
+Replaces any references to process id or thread id, like C<pid#6254> with C<pidN>.
+
+So a DBI trace line like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400
+
+will look like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN
+
+=cut
+
+use strict;
+
+while (<>) {
+ # normalize hex addresses: 0xDEADHEAD => 0xN
+ s/ \b 0x [0-9a-f]+ /0xN/gx;
+ # normalize process and thread id number
+ s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx;
+
+} continue {
+ print or die "-p destination: $!\n";
+}
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/dbiprof b/Master/tlpkg/tlperl.straw/bin/dbiprof
new file mode 100755
index 00000000000..af238db7e7a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/dbiprof
@@ -0,0 +1,263 @@
+#!perl
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 9874 $ =~ /(\d+)/o);
+
+use Data::Dumper;
+use DBI::ProfileData;
+use Getopt::Long;
+
+# default options
+my $number = 10;
+my $sort = 'total';
+my $filename = 'dbi.prof';
+my $reverse = 0;
+my $case_sensitive = 0;
+my (%match, %exclude);
+
+# get options from command line
+GetOptions(
+ 'version' => sub { die "dbiprof $VERSION\n" },
+ 'help' => sub { exit usage() },
+ 'number=i' => \$number,
+ 'sort=s' => \$sort,
+ 'dumpnodes!' => \my $dumpnodes,
+ 'reverse' => \$reverse,
+ 'match=s' => \%match,
+ 'exclude=s' => \%exclude,
+ 'case-sensitive' => \$case_sensitive,
+ 'delete!' => \my $opt_delete,
+) or exit usage();
+
+sub usage {
+ print <<EOS;
+dbiprof [options] [files]
+
+Reads and merges DBI profile data from files and prints a summary.
+
+files: defaults to $filename
+
+options:
+
+ -number=N show top N, defaults to $number
+ -sort=S sort by S, defaults to $sort
+ -reverse reverse the sort
+ -match=K=V for filtering, see docs
+ -exclude=K=V for filtering, see docs
+ -case_sensitive for -match and -exclude
+ -delete rename files before reading then delete afterwards
+ -version print version number and exit
+ -help print this help
+
+EOS
+ return 1;
+}
+
+# list of files defaults to dbi.prof
+my @files = @ARGV ? @ARGV : ('dbi.prof');
+
+
+# instantiate ProfileData object
+my $prof = eval {
+ DBI::ProfileData->new(
+ Files => \@files,
+ DeleteFiles => $opt_delete,
+ );
+};
+die "Unable to load profile data: $@\n" if $@;
+
+if (%match) { # handle matches
+ while (my ($key, $val) = each %match) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->match($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+if (%exclude) { # handle excludes
+ while (my ($key, $val) = each %exclude) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->exclude($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+# sort the data
+$prof->sort(field => $sort, reverse => $reverse);
+
+# all done, print it out
+if ($dumpnodes) {
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Useqq = 1;
+ $Data::Dumper::Deparse = 0;
+ print Dumper($prof->nodes);
+}
+else {
+ print $prof->report(number => $number);
+}
+exit 0;
+
+__END__
+
+=head1 NAME
+
+dbiprof - command-line client for DBI::ProfileData
+
+=head1 SYNOPSIS
+
+See a report of the ten queries with the longest total runtime in the
+profile dump file F<prof1.out>:
+
+ dbiprof prof1.out
+
+See the top 10 most frequently run queries in the profile file
+F<dbi.prof> (the default):
+
+ dbiprof --sort count
+
+See the same report with 15 entries:
+
+ dbiprof --sort count --number 15
+
+=head1 DESCRIPTION
+
+This tool is a command-line client for the DBI::ProfileData. It
+allows you to analyze the profile data file produced by
+DBI::ProfileDumper and produce various useful reports.
+
+=head1 OPTIONS
+
+This program accepts the following options:
+
+=over 4
+
+=item --number N
+
+Produce this many items in the report. Defaults to 10. If set to
+"all" then all results are shown.
+
+=item --sort field
+
+Sort results by the given field. Sorting by multiple fields isn't currently
+supported (patches welcome). The available sort fields are:
+
+=over 4
+
+=item total
+
+Sorts by total time run time across all runs. This is the default
+sort.
+
+=item longest
+
+Sorts by the longest single run.
+
+=item count
+
+Sorts by total number of runs.
+
+=item first
+
+Sorts by the time taken in the first run.
+
+=item shortest
+
+Sorts by the shortest single run.
+
+=item key1
+
+Sorts by the value of the first element in the Path, which should be numeric.
+You can also sort by C<key2> and C<key3>.
+
+=back
+
+=item --reverse
+
+Reverses the selected sort. For example, to see a report of the
+shortest overall time:
+
+ dbiprof --sort total --reverse
+
+=item --match keyN=value
+
+Consider only items where the specified key matches the given value.
+Keys are numbered from 1. For example, let's say you used a
+DBI::Profile Path of:
+
+ [ DBIprofile_Statement, DBIprofile_Methodname ]
+
+And called dbiprof as in:
+
+ dbiprof --match key2=execute
+
+Your report would only show execute queries, leaving out prepares,
+fetches, etc.
+
+If the value given starts and ends with slashes (C</>) then it will be
+treated as a regular expression. For example, to only include SELECT
+queries where key1 is the statement:
+
+ dbiprof --match key1=/^SELECT/
+
+By default the match expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --exclude keyN=value
+
+Remove items for where the specified key matches the given value. For
+example, to exclude all prepare entries where key2 is the method name:
+
+ dbiprof --exclude key2=prepare
+
+Like C<--match>, If the value given starts and ends with slashes
+(C</>) then it will be treated as a regular expression. For example,
+to exclude UPDATE queries where key1 is the statement:
+
+ dbiprof --match key1=/^UPDATE/
+
+By default the exclude expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --case-sensitive
+
+Using this option causes --match and --exclude to work
+case-sensitively. Defaults to off.
+
+=item --delete
+
+Sets the C<DeleteFiles> option to L<DBI::ProfileData> which causes the
+files to be deleted after reading. See L<DBI::ProfileData> for more details.
+
+=item --dumpnodes
+
+Print the list of nodes in the form of a perl data structure.
+Use the C<-sort> option if you want the list sorted.
+
+=item --version
+
+Print the dbiprof version number and exit.
+
+=back
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=head1 SEE ALSO
+
+L<DBI::ProfileDumper|DBI::ProfileDumper>,
+L<DBI::Profile|DBI::Profile>, L<DBI|DBI>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/bin/dbiprof.bat b/Master/tlpkg/tlperl.straw/bin/dbiprof.bat
new file mode 100755
index 00000000000..7dc86ee2ab0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/dbiprof.bat
@@ -0,0 +1,279 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 9874 $ =~ /(\d+)/o);
+
+use Data::Dumper;
+use DBI::ProfileData;
+use Getopt::Long;
+
+# default options
+my $number = 10;
+my $sort = 'total';
+my $filename = 'dbi.prof';
+my $reverse = 0;
+my $case_sensitive = 0;
+my (%match, %exclude);
+
+# get options from command line
+GetOptions(
+ 'version' => sub { die "dbiprof $VERSION\n" },
+ 'help' => sub { exit usage() },
+ 'number=i' => \$number,
+ 'sort=s' => \$sort,
+ 'dumpnodes!' => \my $dumpnodes,
+ 'reverse' => \$reverse,
+ 'match=s' => \%match,
+ 'exclude=s' => \%exclude,
+ 'case-sensitive' => \$case_sensitive,
+ 'delete!' => \my $opt_delete,
+) or exit usage();
+
+sub usage {
+ print <<EOS;
+dbiprof [options] [files]
+
+Reads and merges DBI profile data from files and prints a summary.
+
+files: defaults to $filename
+
+options:
+
+ -number=N show top N, defaults to $number
+ -sort=S sort by S, defaults to $sort
+ -reverse reverse the sort
+ -match=K=V for filtering, see docs
+ -exclude=K=V for filtering, see docs
+ -case_sensitive for -match and -exclude
+ -delete rename files before reading then delete afterwards
+ -version print version number and exit
+ -help print this help
+
+EOS
+ return 1;
+}
+
+# list of files defaults to dbi.prof
+my @files = @ARGV ? @ARGV : ('dbi.prof');
+
+
+# instantiate ProfileData object
+my $prof = eval {
+ DBI::ProfileData->new(
+ Files => \@files,
+ DeleteFiles => $opt_delete,
+ );
+};
+die "Unable to load profile data: $@\n" if $@;
+
+if (%match) { # handle matches
+ while (my ($key, $val) = each %match) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->match($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+if (%exclude) { # handle excludes
+ while (my ($key, $val) = each %exclude) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->exclude($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+# sort the data
+$prof->sort(field => $sort, reverse => $reverse);
+
+# all done, print it out
+if ($dumpnodes) {
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Useqq = 1;
+ $Data::Dumper::Deparse = 0;
+ print Dumper($prof->nodes);
+}
+else {
+ print $prof->report(number => $number);
+}
+exit 0;
+
+__END__
+
+=head1 NAME
+
+dbiprof - command-line client for DBI::ProfileData
+
+=head1 SYNOPSIS
+
+See a report of the ten queries with the longest total runtime in the
+profile dump file F<prof1.out>:
+
+ dbiprof prof1.out
+
+See the top 10 most frequently run queries in the profile file
+F<dbi.prof> (the default):
+
+ dbiprof --sort count
+
+See the same report with 15 entries:
+
+ dbiprof --sort count --number 15
+
+=head1 DESCRIPTION
+
+This tool is a command-line client for the DBI::ProfileData. It
+allows you to analyze the profile data file produced by
+DBI::ProfileDumper and produce various useful reports.
+
+=head1 OPTIONS
+
+This program accepts the following options:
+
+=over 4
+
+=item --number N
+
+Produce this many items in the report. Defaults to 10. If set to
+"all" then all results are shown.
+
+=item --sort field
+
+Sort results by the given field. Sorting by multiple fields isn't currently
+supported (patches welcome). The available sort fields are:
+
+=over 4
+
+=item total
+
+Sorts by total time run time across all runs. This is the default
+sort.
+
+=item longest
+
+Sorts by the longest single run.
+
+=item count
+
+Sorts by total number of runs.
+
+=item first
+
+Sorts by the time taken in the first run.
+
+=item shortest
+
+Sorts by the shortest single run.
+
+=item key1
+
+Sorts by the value of the first element in the Path, which should be numeric.
+You can also sort by C<key2> and C<key3>.
+
+=back
+
+=item --reverse
+
+Reverses the selected sort. For example, to see a report of the
+shortest overall time:
+
+ dbiprof --sort total --reverse
+
+=item --match keyN=value
+
+Consider only items where the specified key matches the given value.
+Keys are numbered from 1. For example, let's say you used a
+DBI::Profile Path of:
+
+ [ DBIprofile_Statement, DBIprofile_Methodname ]
+
+And called dbiprof as in:
+
+ dbiprof --match key2=execute
+
+Your report would only show execute queries, leaving out prepares,
+fetches, etc.
+
+If the value given starts and ends with slashes (C</>) then it will be
+treated as a regular expression. For example, to only include SELECT
+queries where key1 is the statement:
+
+ dbiprof --match key1=/^SELECT/
+
+By default the match expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --exclude keyN=value
+
+Remove items for where the specified key matches the given value. For
+example, to exclude all prepare entries where key2 is the method name:
+
+ dbiprof --exclude key2=prepare
+
+Like C<--match>, If the value given starts and ends with slashes
+(C</>) then it will be treated as a regular expression. For example,
+to exclude UPDATE queries where key1 is the statement:
+
+ dbiprof --match key1=/^UPDATE/
+
+By default the exclude expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --case-sensitive
+
+Using this option causes --match and --exclude to work
+case-sensitively. Defaults to off.
+
+=item --delete
+
+Sets the C<DeleteFiles> option to L<DBI::ProfileData> which causes the
+files to be deleted after reading. See L<DBI::ProfileData> for more details.
+
+=item --dumpnodes
+
+Print the list of nodes in the form of a perl data structure.
+Use the C<-sort> option if you want the list sorted.
+
+=item --version
+
+Print the dbiprof version number and exit.
+
+=back
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=head1 SEE ALSO
+
+L<DBI::ProfileDumper|DBI::ProfileDumper>,
+L<DBI::Profile|DBI::Profile>, L<DBI|DBI>.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/dbiproxy b/Master/tlpkg/tlperl.straw/bin/dbiproxy
new file mode 100755
index 00000000000..0ce06af6065
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/dbiproxy
@@ -0,0 +1,184 @@
+#!perl
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 10720 $ =~ /(\d+)/o);
+
+my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test';
+$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//;
+
+require DBI::ProxyServer;
+
+# XXX these should probably be moved into DBI::ProxyServer
+delete $ENV{IFS};
+delete $ENV{CDPATH};
+delete $ENV{ENV};
+delete $ENV{BASH_ENV};
+
+if ($arg_test) {
+ require RPC::PlServer::Test;
+ @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI);
+}
+
+DBI::ProxyServer::main(@ARGV);
+
+exit(0);
+
+
+__END__
+
+=head1 NAME
+
+dbiproxy - A proxy server for the DBD::Proxy driver
+
+=head1 SYNOPSIS
+
+ dbiproxy <options> --localport=<port>
+
+
+=head1 DESCRIPTION
+
+This tool is just a front end for the DBI::ProxyServer package. All it
+does is picking options from the command line and calling
+DBI::ProxyServer::main(). See L<DBI::ProxyServer> for details.
+
+Available options include:
+
+=over 4
+
+=item B<--chroot=dir>
+
+(UNIX only) After doing a bind(), change root directory to the given
+directory by doing a chroot(). This is useful for security, but it
+restricts the environment a lot. For example, you need to load DBI
+drivers in the config file or you have to create hard links to Unix
+sockets, if your drivers are using them. For example, with MySQL, a
+config file might contain the following lines:
+
+ my $rootdir = '/var/dbiproxy';
+ my $unixsockdir = '/tmp';
+ my $unixsockfile = 'mysql.sock';
+ foreach $dir ($rootdir, "$rootdir$unixsockdir") {
+ mkdir 0755, $dir;
+ }
+ link("$unixsockdir/$unixsockfile",
+ "$rootdir$unixsockdir/$unixsockfile");
+ require DBD::mysql;
+
+ {
+ 'chroot' => $rootdir,
+ ...
+ }
+
+If you don't know chroot(), think of an FTP server where you can see a
+certain directory tree only after logging in. See also the --group and
+--user options.
+
+=item B<--configfile=file>
+
+Config files are assumed to return a single hash ref that overrides the
+arguments of the new method. However, command line arguments in turn take
+precedence over the config file. See the "CONFIGURATION FILE" section
+in the L<DBI::ProxyServer> documentation for details on the config file.
+
+=item B<--debug>
+
+Turn debugging mode on. Mainly this asserts that logging messages of
+level "debug" are created.
+
+=item B<--facility=mode>
+
+(UNIX only) Facility to use for L<Sys::Syslog>. The default is
+B<daemon>.
+
+=item B<--group=gid>
+
+After doing a bind(), change the real and effective GID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --user option.
+
+GID's can be passed as group names or numeric values.
+
+=item B<--localaddr=ip>
+
+By default a daemon is listening to any IP number that a machine
+has. This attribute allows to restrict the server to the given
+IP number.
+
+=item B<--localport=port>
+
+This attribute sets the port on which the daemon is listening. It
+must be given somehow, as there's no default.
+
+=item B<--logfile=file>
+
+Be default logging messages will be written to the syslog (Unix) or
+to the event log (Windows NT). On other operating systems you need to
+specify a log file. The special value "STDERR" forces logging to
+stderr. See L<Net::Daemon::Log> for details.
+
+=item B<--mode=modename>
+
+The server can run in three different modes, depending on the environment.
+
+If you are running Perl 5.005 and did compile it for threads, then the
+server will create a new thread for each connection. The thread will
+execute the server's Run() method and then terminate. This mode is the
+default, you can force it with "--mode=threads".
+
+If threads are not available, but you have a working fork(), then the
+server will behave similar by creating a new process for each connection.
+This mode will be used automatically in the absence of threads or if
+you use the "--mode=fork" option.
+
+Finally there's a single-connection mode: If the server has accepted a
+connection, he will enter the Run() method. No other connections are
+accepted until the Run() method returns (if the client disconnects).
+This operation mode is useful if you have neither threads nor fork(),
+for example on the Macintosh. For debugging purposes you can force this
+mode with "--mode=single".
+
+=item B<--pidfile=file>
+
+(UNIX only) If this option is present, a PID file will be created at the
+given location. Default is to not create a pidfile.
+
+=item B<--user=uid>
+
+After doing a bind(), change the real and effective UID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --group and the --chroot options.
+
+UID's can be passed as group names or numeric values.
+
+=item B<--version>
+
+Supresses startup of the server; instead the version string will
+be printed and the program exits immediately.
+
+=back
+
+
+=head1 AUTHOR
+
+ Copyright (c) 1997 Jochen Wiedmann
+ Am Eisteich 9
+ 72555 Metzingen
+ Germany
+
+ Email: joe@ispsoft.de
+ Phone: +49 7123 14881
+
+The DBI::ProxyServer module is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself. In particular
+permission is granted to Tim Bunce for distributing this as a part of
+the DBI.
+
+
+=head1 SEE ALSO
+
+L<DBI::ProxyServer>, L<DBD::Proxy>, L<DBI>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/dbiproxy.bat b/Master/tlpkg/tlperl.straw/bin/dbiproxy.bat
new file mode 100755
index 00000000000..1199ebbfa92
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/dbiproxy.bat
@@ -0,0 +1,200 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 10720 $ =~ /(\d+)/o);
+
+my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test';
+$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//;
+
+require DBI::ProxyServer;
+
+# XXX these should probably be moved into DBI::ProxyServer
+delete $ENV{IFS};
+delete $ENV{CDPATH};
+delete $ENV{ENV};
+delete $ENV{BASH_ENV};
+
+if ($arg_test) {
+ require RPC::PlServer::Test;
+ @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI);
+}
+
+DBI::ProxyServer::main(@ARGV);
+
+exit(0);
+
+
+__END__
+
+=head1 NAME
+
+dbiproxy - A proxy server for the DBD::Proxy driver
+
+=head1 SYNOPSIS
+
+ dbiproxy <options> --localport=<port>
+
+
+=head1 DESCRIPTION
+
+This tool is just a front end for the DBI::ProxyServer package. All it
+does is picking options from the command line and calling
+DBI::ProxyServer::main(). See L<DBI::ProxyServer> for details.
+
+Available options include:
+
+=over 4
+
+=item B<--chroot=dir>
+
+(UNIX only) After doing a bind(), change root directory to the given
+directory by doing a chroot(). This is useful for security, but it
+restricts the environment a lot. For example, you need to load DBI
+drivers in the config file or you have to create hard links to Unix
+sockets, if your drivers are using them. For example, with MySQL, a
+config file might contain the following lines:
+
+ my $rootdir = '/var/dbiproxy';
+ my $unixsockdir = '/tmp';
+ my $unixsockfile = 'mysql.sock';
+ foreach $dir ($rootdir, "$rootdir$unixsockdir") {
+ mkdir 0755, $dir;
+ }
+ link("$unixsockdir/$unixsockfile",
+ "$rootdir$unixsockdir/$unixsockfile");
+ require DBD::mysql;
+
+ {
+ 'chroot' => $rootdir,
+ ...
+ }
+
+If you don't know chroot(), think of an FTP server where you can see a
+certain directory tree only after logging in. See also the --group and
+--user options.
+
+=item B<--configfile=file>
+
+Config files are assumed to return a single hash ref that overrides the
+arguments of the new method. However, command line arguments in turn take
+precedence over the config file. See the "CONFIGURATION FILE" section
+in the L<DBI::ProxyServer> documentation for details on the config file.
+
+=item B<--debug>
+
+Turn debugging mode on. Mainly this asserts that logging messages of
+level "debug" are created.
+
+=item B<--facility=mode>
+
+(UNIX only) Facility to use for L<Sys::Syslog>. The default is
+B<daemon>.
+
+=item B<--group=gid>
+
+After doing a bind(), change the real and effective GID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --user option.
+
+GID's can be passed as group names or numeric values.
+
+=item B<--localaddr=ip>
+
+By default a daemon is listening to any IP number that a machine
+has. This attribute allows to restrict the server to the given
+IP number.
+
+=item B<--localport=port>
+
+This attribute sets the port on which the daemon is listening. It
+must be given somehow, as there's no default.
+
+=item B<--logfile=file>
+
+Be default logging messages will be written to the syslog (Unix) or
+to the event log (Windows NT). On other operating systems you need to
+specify a log file. The special value "STDERR" forces logging to
+stderr. See L<Net::Daemon::Log> for details.
+
+=item B<--mode=modename>
+
+The server can run in three different modes, depending on the environment.
+
+If you are running Perl 5.005 and did compile it for threads, then the
+server will create a new thread for each connection. The thread will
+execute the server's Run() method and then terminate. This mode is the
+default, you can force it with "--mode=threads".
+
+If threads are not available, but you have a working fork(), then the
+server will behave similar by creating a new process for each connection.
+This mode will be used automatically in the absence of threads or if
+you use the "--mode=fork" option.
+
+Finally there's a single-connection mode: If the server has accepted a
+connection, he will enter the Run() method. No other connections are
+accepted until the Run() method returns (if the client disconnects).
+This operation mode is useful if you have neither threads nor fork(),
+for example on the Macintosh. For debugging purposes you can force this
+mode with "--mode=single".
+
+=item B<--pidfile=file>
+
+(UNIX only) If this option is present, a PID file will be created at the
+given location. Default is to not create a pidfile.
+
+=item B<--user=uid>
+
+After doing a bind(), change the real and effective UID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --group and the --chroot options.
+
+UID's can be passed as group names or numeric values.
+
+=item B<--version>
+
+Supresses startup of the server; instead the version string will
+be printed and the program exits immediately.
+
+=back
+
+
+=head1 AUTHOR
+
+ Copyright (c) 1997 Jochen Wiedmann
+ Am Eisteich 9
+ 72555 Metzingen
+ Germany
+
+ Email: joe@ispsoft.de
+ Phone: +49 7123 14881
+
+The DBI::ProxyServer module is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself. In particular
+permission is granted to Tim Bunce for distributing this as a part of
+the DBI.
+
+
+=head1 SEE ALSO
+
+L<DBI::ProxyServer>, L<DBD::Proxy>, L<DBI>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/dprofpp.bat b/Master/tlpkg/tlperl.straw/bin/dprofpp.bat
new file mode 100755
index 00000000000..ee8f9e3be95
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/dprofpp.bat
@@ -0,0 +1,945 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+
+require 5.003;
+
+my $VERSION = '20080331.00';
+my $stty = undef;
+
+=head1 NAME
+
+dprofpp - display perl profile data
+
+=head1 SYNOPSIS
+
+dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
+
+dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-G> <regexp> [B<-P>] [profile]
+
+dprofpp B<-p script> [B<-Q>] [other opts]
+
+dprofpp B<-V> [profile]
+
+=head1 DESCRIPTION
+
+The I<dprofpp> command interprets profile data produced by a profiler, such
+as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and
+display the 15 subroutines which are using the most time. By default
+the times for each subroutine are given exclusive of the times of their
+child subroutines.
+
+To profile a Perl script run the perl interpreter with the B<-d> switch. So
+to profile script F<test.pl> with Devel::DProf use the following:
+
+ $ perl5 -d:DProf test.pl
+
+Then run dprofpp to analyze the profile. The output of dprofpp depends
+on the flags to the program and the version of Perl you're using.
+
+ $ dprofpp -u
+ Total Elapsed Time = 1.67 Seconds
+ User Time = 0.61 Seconds
+ Exclusive Times
+ %Time Seconds #Calls sec/call Name
+ 52.4 0.320 2 0.1600 main::foo
+ 45.9 0.280 200 0.0014 main::bar
+ 0.00 0.000 1 0.0000 DynaLoader::import
+ 0.00 0.000 1 0.0000 main::baz
+
+The dprofpp tool can also run the profiler before analyzing the profile
+data. The above two commands can be executed with one dprofpp command.
+
+ $ dprofpp -u -p test.pl
+
+Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
+
+=head1 OUTPUT
+
+Columns are:
+
+=over 4
+
+=item %Time
+
+Percentage of time spent in this routine.
+
+=item #Calls
+
+Number of calls to this routine.
+
+=item sec/call
+
+Average number of seconds per call to this routine.
+
+=item Name
+
+Name of routine.
+
+=item CumulS
+
+Time (in seconds) spent in this routine and routines called from it.
+
+=item ExclSec
+
+Time (in seconds) spent in this routine (not including those called
+from it).
+
+=item Csec/c
+
+Average time (in seconds) spent in each call of this routine
+(including those called from it).
+
+=back
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-a>
+
+Sort alphabetically by subroutine names.
+
+=item B<-d>
+
+Reverse whatever sort is used
+
+=item B<-A>
+
+Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
+Otherwise the time to autoload it is counted as time of the subroutine
+itself (there is no way to separate autoload time from run time).
+
+This is going to be irrelevant with newer Perls. They will inform
+C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
+so a separate statistics for C<AUTOLOAD> will be collected no matter
+whether this option is set.
+
+=item B<-R>
+
+Count anonymous subroutines defined in the same package separately.
+
+=item B<-E>
+
+(default) Display all subroutine times exclusive of child subroutine times.
+
+=item B<-F>
+
+Force the generation of fake exit timestamps if dprofpp reports that the
+profile is garbled. This is only useful if dprofpp determines that the
+profile is garbled due to missing exit timestamps. You're on your own if
+you do this. Consult the BUGS section.
+
+=item B<-I>
+
+Display all subroutine times inclusive of child subroutine times.
+
+=item B<-l>
+
+Sort by number of calls to the subroutines. This may help identify
+candidates for inlining.
+
+=item B<-O cnt>
+
+Show only I<cnt> subroutines. The default is 15.
+
+=item B<-p script>
+
+Tells dprofpp that it should profile the given script and then interpret its
+profile data. See B<-Q>.
+
+=item B<-Q>
+
+Used with B<-p> to tell dprofpp to quit after profiling the script, without
+interpreting the data.
+
+=item B<-q>
+
+Do not display column headers.
+
+=item B<-r>
+
+Display elapsed real times rather than user+system times.
+
+=item B<-s>
+
+Display system times rather than user+system times.
+
+=item B<-T>
+
+Display subroutine call tree to stdout. Subroutine statistics are
+not displayed.
+
+=item B<-t>
+
+Display subroutine call tree to stdout. Subroutine statistics are not
+displayed. When a function is called multiple consecutive times at the same
+calling level then it is displayed once with a repeat count.
+
+=item B<-S>
+
+Display I<merged> subroutine call tree to stdout. Statistics are
+displayed for each branch of the tree.
+
+When a function is called multiple (I<not necessarily consecutive>)
+times in the same branch then all these calls go into one branch of
+the next level. A repeat count is output together with combined
+inclusive, exclusive and kids time.
+
+Branches are sorted with regard to inclusive time.
+
+=item B<-U>
+
+Do not sort. Display in the order found in the raw profile.
+
+=item B<-u>
+
+Display user times rather than user+system times.
+
+=item B<-V>
+
+Print dprofpp's version number and exit. If a raw profile is found then its
+XS_VERSION variable will be displayed, too.
+
+=item B<-v>
+
+Sort by average time spent in subroutines during each call. This may help
+identify candidates for inlining.
+
+=item B<-z>
+
+(default) Sort by amount of user+system time used. The first few lines
+should show you which subroutines are using the most time.
+
+=item B<-g> C<subroutine>
+
+Ignore subroutines except C<subroutine> and whatever is called from it.
+
+=item B<-G> <regexp>
+
+Aggregate "Group" all calls matching the pattern together.
+For example this can be used to group all calls of a set of packages
+
+ -G "(package1::)|(package2::)|(package3::)"
+
+or to group subroutines by name:
+
+ -G "getNum"
+
+=item B<-P>
+
+Used with -G to aggregate "Pull" together all calls that did not match -G.
+
+=item B<-f> <regexp>
+
+Filter all calls matching the pattern.
+
+=item B<-h>
+
+Display brief help and exit.
+
+=item B<-H>
+
+Display long help and exit.
+
+=back
+
+=head1 ENVIRONMENT
+
+The environment variable B<DPROFPP_OPTS> can be set to a string containing
+options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
+if you want B<-F> on all the time.
+
+This was added fairly lazily, so there are some undesirable side effects.
+Options on the commandline should override options in DPROFPP_OPTS--but
+don't count on that in this version.
+
+=head1 BUGS
+
+Applications which call _exit() or exec() from within a subroutine
+will leave an incomplete profile. See the B<-F> option.
+
+Any bugs in Devel::DProf, or any profiler generating the profile data, could
+be visible here. See L<Devel::DProf/BUGS>.
+
+Mail bug reports and feature requests to the perl5-porters mailing list at
+F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
+output of the B<-V> option.
+
+=head1 FILES
+
+ dprofpp - profile processor
+ tmon.out - raw profile
+
+=head1 SEE ALSO
+
+L<perl>, L<Devel::DProf>, times(2)
+
+=cut
+
+sub shortusage {
+ print <<'EOF';
+dprofpp [options] [profile]
+
+ -A Count autoloaded to *AUTOLOAD.
+ -a Sort by alphabetic name of subroutines.
+ -d Reverse sort.
+ -E Sub times are reported exclusive of child times. (default)
+ -f Filter all calls matching the pattern.
+ -G Group all calls matching the pattern together.
+ -g subr Count only subs who are SUBR or called from SUBR.
+ -H Display long manual page.
+ -h Display this short usage message.
+ -I Sub times are reported inclusive of child times.
+ -l Sort by number of calls to subroutines.
+ -O cnt Specifies maximum number of subroutines to display.
+ -P Used with -G to pull all other calls together.
+ -p script Specifies name of script to be profiled.
+ -Q Used with -p to indicate that dprofpp should quit
+ after profiling the script, without interpreting the data.
+ -q Do not print column headers.
+ -R Count anonymous subs separately even if from the same package.
+ -r Use real elapsed time rather than user+system time.
+ -S Create statistics for all the depths.
+ -s Use system time rather than user+system time.
+ -T Show call tree.
+ -t Show call tree, compressed.
+ -U Do not sort subroutines.
+ -u Use user time rather than user+system time.
+ -V Print dprofpp's version.
+ -v Sort by average amount of time spent in subroutines.
+ -z Sort by user+system time spent in subroutines. (default)
+EOF
+}
+
+use Getopt::Std 'getopts';
+use Config '%Config';
+
+Setup: {
+ my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
+
+ $Monfile = 'tmon.out';
+ if( exists $ENV{DPROFPP_OPTS} ){
+ my @tmpargv = @ARGV;
+ @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
+ getopts( $options );
+ if( @ARGV ){
+ # there was a filename.
+ $Monfile = shift;
+ }
+ @ARGV = @tmpargv;
+ }
+
+ getopts( $options ) or die "Try 'dprofpp -h' for help.\n";
+ if( @ARGV ){
+ # there was a filename, it overrides any earlier name.
+ $Monfile = shift;
+ }
+
+ if ( defined $opt_h ) {
+ shortusage();
+ exit;
+ }
+ if ( defined $opt_H ) {
+ require Pod::Usage;
+ Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
+ exit;
+ }
+
+ if( defined $opt_V ){
+ my $fh = 'main::fh';
+ print "$0 version: $VERSION\n";
+ open( $fh, "<$Monfile" ) && do {
+ local $XS_VERSION = 'early';
+ header($fh);
+ close( $fh );
+ print "XS_VERSION: $XS_VERSION\n";
+ };
+ exit(0);
+ }
+ $cnt = $opt_O || 15;
+ $sort = 'by_time';
+ $sort = 'by_ctime' if defined $opt_I;
+ $sort = 'by_calls' if defined $opt_l;
+ $sort = 'by_alpha' if defined $opt_a;
+ $sort = 'by_avgcpu' if defined $opt_v;
+
+ if(defined $opt_d){
+ $sort = "r".$sort;
+ }
+ $incl_excl = 'Exclusive';
+ $incl_excl = 'Inclusive' if defined $opt_I;
+ $whichtime = 'User+System';
+ $whichtime = 'System' if defined $opt_s;
+ $whichtime = 'Real' if defined $opt_r;
+ $whichtime = 'User' if defined $opt_u;
+
+ if( defined $opt_p ){
+ my $prof = 'DProf';
+ my $startperl = $Config{'startperl'};
+
+ $startperl =~ s/^#!//; # remove shebang
+ run_profiler( $opt_p, $prof, $startperl );
+ $Monfile = 'tmon.out'; # because that's where it is
+ exit(0) if defined $opt_Q;
+ }
+ elsif( defined $opt_Q ){
+ die "-Q is meaningful only when used with -p\n";
+ }
+}
+
+Main: {
+ my $monout = $Monfile;
+ my $fh = 'main::fh';
+ local $names = {};
+ local $times = {}; # times in hz
+ local $ctimes = {}; # Cumulative times in hz
+ local $calls = {};
+ local $persecs = {}; # times in seconds
+ local $idkeys = [];
+ local $runtime; # runtime in seconds
+ my @a = ();
+ my $a;
+ local $rrun_utime = 0; # user time in hz
+ local $rrun_stime = 0; # system time in hz
+ local $rrun_rtime = 0; # elapsed run time in hz
+ local $rrun_ustime = 0; # user+system time in hz
+ local $hz = 0;
+ local $deep_times = {count => 0 , kids => {}, incl_time => 0};
+ local $time_precision = 2;
+ local $overhead = 0;
+
+ open( $fh, "<$monout" ) || die "Unable to open $monout\n";
+
+ header($fh);
+
+ $rrun_ustime = $rrun_utime + $rrun_stime;
+
+ $~ = 'STAT';
+ if( ! $opt_q ){
+ $^ = 'CSTAT_top';
+ }
+
+ parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
+
+ #filter calls
+ if( $opt_f ){
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_f/){
+ splice(@$idkeys, $i, 1);
+ $runtime -= $$times{$key};
+ next;
+ }
+ $i++;
+ }
+ }
+
+ if( $opt_G ){
+ group($names, $calls, $times, $ctimes, $idkeys );
+ }
+
+ settime( \$runtime, $hz ) unless $opt_g;
+
+ exit(0) if $opt_T || $opt_t;
+
+ if( $opt_v ){
+ percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
+ }
+ if( ! $opt_U ){
+ @a = sort $sort @$idkeys;
+ $a = \@a;
+ }
+ else {
+ $a = $idkeys;
+ }
+ display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
+ $deep_times);
+}
+
+sub group{
+ my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
+ print "Option G Grouping: [$opt_G]\n";
+ # create entries to store grouping
+ $$names{$opt_G} = $opt_G;
+ $$calls{$opt_G} = 0;
+ $$times{$opt_G} = 0;
+ $$ctimes{$opt_G} = 0;
+ $$idkeys[@$idkeys] = $opt_G;
+ # Sum calls for the grouping
+
+ my $other = "other";
+ if($opt_P){
+ $$names{$other} = $other;
+ $$calls{$other} = 0;
+ $$times{$other} = 0;
+ $$ctimes{$other} = 0;
+ $$idkeys[@$idkeys] = $other;
+ }
+
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_G/){
+ $$calls{$opt_G} += $$calls{$key};
+ $$times{$opt_G} += $$times{$key};
+ $$ctimes{$opt_G} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }else{
+ if($opt_P){
+ $$calls{$other} += $$calls{$key};
+ $$times{$other} += $$times{$key};
+ $$ctimes{$other} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }
+ }
+ $i++;
+ }
+ print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
+ "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
+ "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
+}
+
+# Sets $runtime to user, system, real, or user+system time. The
+# result is given in seconds.
+#
+sub settime {
+ my( $runtime, $hz ) = @_;
+
+ $hz ||= 1;
+
+ if( $opt_r ){
+ $$runtime = ($rrun_rtime - $overhead)/$hz;
+ }
+ elsif( $opt_s ){
+ $$runtime = ($rrun_stime - $overhead)/$hz;
+ }
+ elsif( $opt_u ){
+ $$runtime = ($rrun_utime - $overhead)/$hz;
+ }
+ else{
+ $$runtime = ($rrun_ustime - $overhead)/$hz;
+ }
+ $$runtime = 0 unless $$runtime > 0;
+}
+
+sub exclusives_in_tree {
+ my( $deep_times ) = @_;
+ my $kids_time = 0;
+ my $kid;
+ # When summing, take into account non-rounded-up kids time.
+ for $kid (keys %{$deep_times->{kids}}) {
+ $kids_time += $deep_times->{kids}{$kid}{incl_time};
+ }
+ $kids_time = 0 unless $kids_time >= 0;
+ $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
+ $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
+ for $kid (keys %{$deep_times->{kids}}) {
+ exclusives_in_tree($deep_times->{kids}{$kid});
+ }
+ $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
+ $deep_times->{kids_time} = $kids_time;
+}
+
+sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
+ or $a cmp $b }
+
+sub display_tree {
+ my( $deep_times, $name, $level ) = @_;
+ exclusives_in_tree($deep_times);
+
+ my $kid;
+
+ my $time;
+ if (%{$deep_times->{kids}}) {
+ $time = sprintf '%.*fs = (%.*f + %.*f)',
+ $time_precision, $deep_times->{incl_time}/$hz,
+ $time_precision, $deep_times->{excl_time}/$hz,
+ $time_precision, $deep_times->{kids_time}/$hz;
+ } else {
+ $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
+ }
+ print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
+ if $deep_times->{count};
+
+ for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
+ display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
+ }
+}
+
+# Report the times in seconds.
+sub display {
+ my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
+ $idkeys, $deep_times ) = @_;
+ my( $x, $key, $s, $cs );
+ #format: $ncalls, $name, $secs, $percall, $pcnt
+
+ if ($opt_S) {
+ display_tree( $deep_times, 'toplevel', -1 )
+ } else {
+ for( $x = 0; $x < @$idkeys; ++$x ){
+ $key = $idkeys->[$x];
+ $ncalls = $calls->{$key};
+ $name = $names->{$key};
+ $s = $times->{$key}/$hz;
+ $secs = sprintf("%.3f", $s );
+ $cs = $ctimes->{$key}/$hz;
+ $csecs = sprintf("%.3f", $cs );
+ $percall = sprintf("%.4f", $s/$ncalls );
+ $cpercall = sprintf("%.4f", $cs/$ncalls );
+ $pcnt = sprintf("%.2f",
+ $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
+ write;
+ $pcnt = $secs = $ncalls = $percall = "";
+ write while( length $name );
+ last unless --$cnt;
+ }
+ }
+}
+
+sub move_keys {
+ my ($source, $dest) = @_;
+
+ for my $kid_name (keys %$source) {
+ my $source_kid = delete $source->{$kid_name};
+
+ if (my $dest_kid = $dest->{$kid_name}) {
+ $dest_kid->{count} += $source_kid->{count};
+ $dest_kid->{incl_time} += $source_kid->{incl_time};
+ move_keys($source_kid->{kids},$dest_kid->{kids});
+ } else {
+ $dest->{$kid_name} = $source_kid;
+ }
+ }
+}
+
+sub add_to_tree {
+ my ($curdeep_times, $name, $t) = @_;
+ if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
+ $name = $curdeep_times->[-1]{name};
+ }
+ die "Shorted?!" unless @$curdeep_times >= 2;
+ my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
+ count => 0,
+ kids => {},
+ incl_time => 0,
+ };
+ # Now transfer to the new node (could not do earlier, since name can change)
+ $entry->{count}++;
+ $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
+ # Merge the kids?
+ move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
+ pop @$curdeep_times;
+}
+
+
+sub parsestack {
+ my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
+ my( $dir, $name );
+ my( $t, $syst, $realt, $usert );
+ my( $x, $z, $c, $id, $pack );
+ my @stack = ();
+ my @tstack = ();
+ my %outer;
+ my $tab = 3;
+ my $in = 0;
+
+ # remember last call depth and function name
+ my $l_in = $in;
+ my $l_name = '';
+ my $repcnt = 0;
+ my $repstr = '';
+ my $dprof_stamp;
+ my %cv_hash;
+ my $in_level = not defined $opt_g; # Level deep in report grouping
+ my $curdeep_times = [$deep_times];
+
+ my $over_per_call;
+ if ( $opt_u ) { $over_per_call = $over_utime }
+ elsif( $opt_s ) { $over_per_call = $over_stime }
+ elsif( $opt_r ) { $over_per_call = $over_rtime }
+ else { $over_per_call = $over_utime + $over_stime }
+ $over_per_call /= 2*$over_tests; # distribute over entry and exit
+
+ while(<$fh>){
+ next if /^#/;
+ last if /^PART/;
+
+ chop;
+ if (/^&/) {
+ ($dir, $id, $pack, $name) = split;
+ if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
+ $name .= "($id)";
+ }
+ $cv_hash{$id} = "$pack\::$name";
+ next;
+ }
+ ($dir, $usert, $syst, $realt, $name) = split;
+
+ my $ot = $t;
+ if ( $dir eq '/' ) {
+ $syst = $stack[-1][0] if scalar @stack;
+ $usert = '&';
+ $dir = '-';
+ #warn("Inserted exit for $stack[-1][0].\n")
+ }
+ if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
+ if ( $opt_u ) { $t = $usert }
+ elsif( $opt_s ) { $t = $syst }
+ elsif( $opt_r ) { $t = $realt }
+ else { $t = $usert + $syst }
+ $t += $ot, next if $dir eq '@'; # Increments there
+ } else {
+ # "- id" or "- & name"
+ $name = defined $syst ? $syst : $cv_hash{$usert};
+ }
+
+ next unless $in_level or $name eq $opt_g;
+ if ( $dir eq '-' or $dir eq '*' ) {
+ my $ename = $dir eq '*' ? $stack[-1][0] : $name;
+ $overhead += $over_per_call;
+ if ($name eq "Devel::DProf::write") {
+ $overhead += $t - $dprof_stamp;
+ next;
+ } elsif (defined $opt_g and $ename eq $opt_g) {
+ $in_level--;
+ }
+ add_to_tree($curdeep_times, $ename,
+ $t - $overhead) if $opt_S;
+ exitstamp( \@stack, \@tstack,
+ $t - $overhead,
+ $times, $ctimes, $name, \$in, $tab,
+ $curdeep_times, \%outer );
+ }
+ next unless $in_level or $name eq $opt_g;
+ if( $dir eq '+' or $dir eq '*' ){
+ if ($name eq "Devel::DProf::write") {
+ $dprof_stamp = $t;
+ next;
+ } elsif (defined $opt_g and $name eq $opt_g) {
+ $in_level++;
+ }
+ $overhead += $over_per_call;
+ if( $opt_T ){
+ print ' ' x $in, "$name\n";
+ $in += $tab;
+ }
+ elsif( $opt_t ){
+ # suppress output on same function if the
+ # same calling level is called.
+ if ($l_in == $in and $l_name eq $name) {
+ $repcnt++;
+ } else {
+ $repstr = ' ('.++$repcnt.'x)'
+ if $repcnt;
+ print ' ' x $l_in, "$l_name$repstr\n"
+ if $l_name ne '';
+ $repstr = '';
+ $repcnt = 0;
+ $l_in = $in;
+ $l_name = $name;
+ }
+ $in += $tab;
+ }
+ if( ! defined $names->{$name} ){
+ $names->{$name} = $name;
+ $times->{$name} = 0;
+ $ctimes->{$name} = 0;
+ push( @$idkeys, $name );
+ }
+ $calls->{$name}++;
+ $outer{$name}++;
+ push @$curdeep_times, { kids => {},
+ name => $name,
+ enter_stamp => $t - $overhead,
+ } if $opt_S;
+ $x = [ $name, $t - $overhead ];
+ push( @stack, $x );
+
+ # my children will put their time here
+ push( @tstack, 0 );
+ } elsif ($dir ne '-'){
+ die "Bad profile: $_";
+ }
+ }
+ if( $opt_t ){
+ $repstr = ' ('.++$repcnt.'x)' if $repcnt;
+ print ' ' x $l_in, "$l_name$repstr\n";
+ }
+
+ while (my ($key, $count) = each %outer) {
+ next unless $count;
+ warn "$key has $count unstacked calls in outer\n";
+ }
+
+ if( @stack ){
+ if( ! $opt_F ){
+ warn "Garbled profile is missing some exit time stamps:\n";
+ foreach $x (@stack) {
+ print $x->[0],"\n";
+ }
+ die "Try rerunning dprofpp with -F.\n";
+ # I don't want -F to be default behavior--yet
+ # 9/18/95 dmr
+ }
+ else{
+ warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
+ foreach $x ( reverse @stack ){
+ $name = $x->[0];
+ exitstamp( \@stack, \@tstack,
+ $t - $overhead, $times,
+ $ctimes, $name, \$in, $tab,
+ $curdeep_times, \%outer );
+ add_to_tree($curdeep_times, $name,
+ $t - $overhead)
+ if $opt_S;
+ }
+ }
+ }
+ if (defined $opt_g) {
+ $runtime = $ctimes->{$opt_g}/$hz;
+ $runtime = 0 unless $runtime > 0;
+ }
+}
+
+sub exitstamp {
+ my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
+ my( $x, $c, $z );
+
+ $x = pop( @$stack );
+ if( ! defined $x ){
+ die "Garbled profile, missing an enter time stamp";
+ }
+ if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
+ if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
+ if ($opt_A) {
+ $name = $x->[0];
+ }
+ } elsif ( $opt_F ) {
+ warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
+ $name = $x->[0];
+ } else {
+ foreach $z (@stack, $x) {
+ print $z->[0],"\n";
+ }
+ die "Garbled profile, unexpected exit time stamp";
+ }
+ }
+ if( $opt_T || $opt_t ){
+ $$in -= $tab;
+ }
+ # collect childtime
+ $c = pop( @$tstack );
+ # total time this func has been active
+ $z = $t - $x->[1];
+ $ctimes->{$name} += $z
+ unless --$outer->{$name};
+ $times->{$name} += $z - $c;
+ # pass my time to my parent
+ if( @$tstack ){
+ $c = pop( @$tstack );
+ push( @$tstack, $c + $z );
+ }
+}
+
+
+sub header {
+ my $fh = shift;
+ chop($_ = <$fh>);
+ if( ! /^#fOrTyTwO$/ ){
+ die "Not a perl profile";
+ }
+ while(<$fh>){
+ next if /^#/;
+ last if /^PART/;
+ eval;
+ }
+ $over_tests = 1 unless $over_tests;
+ $time_precision = length int ($hz - 1); # log ;-)
+}
+
+
+# Report avg time-per-function in seconds
+sub percalc {
+ my( $calls, $times, $persecs, $idkeys ) = @_;
+ my( $x, $t, $n, $key );
+
+ for( $x = 0; $x < @$idkeys; ++$x ){
+ $key = $idkeys->[$x];
+ $n = $calls->{$key};
+ $t = $times->{$key} / $hz;
+ $persecs->{$key} = $t ? $t / $n : 0;
+ }
+}
+
+
+# Runs the given script with the given profiler and the given perl.
+sub run_profiler {
+ my $script = shift;
+ my $profiler = shift;
+ my $startperl = shift;
+ my @script_parts = split /\s+/, $script;
+
+ system $startperl, "-d:$profiler", @script_parts;
+ if( $? / 256 > 0 ){
+ my $cmd = join ' ', @script_parts;
+ die "Failed: $startperl -d:$profiler $cmd: $!";
+ }
+}
+
+
+sub by_time { $times->{$b} <=> $times->{$a} }
+sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
+sub by_calls { $calls->{$b} <=> $calls->{$a} }
+sub by_alpha { $names->{$a} cmp $names->{$b} }
+sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
+# Reversed
+sub rby_time { $times->{$a} <=> $times->{$b} }
+sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
+sub rby_calls { $calls->{$a} <=> $calls->{$b} }
+sub rby_alpha { $names->{$b} cmp $names->{$a} }
+sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
+
+
+format CSTAT_top =
+Total Elapsed Time = @>>>>>>> Seconds
+(($rrun_rtime - $overhead) / $hz)
+ @>>>>>>>>>> Time = @>>>>>>> Seconds
+$whichtime, $runtime
+@<<<<<<<< Times
+$incl_excl
+%Time ExclSec CumulS #Calls sec/call Csec/c Name
+.
+
+BEGIN {
+ my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
+ if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
+ {
+ $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
+ }
+
+ eval "format STAT = \n$fmt" . '
+$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
+.';
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/enc2xs b/Master/tlpkg/tlperl.straw/bin/enc2xs
new file mode 100755
index 00000000000..773c0a09fba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/enc2xs
@@ -0,0 +1,1407 @@
+#!./perl
+BEGIN {
+ # @INC poking no longer needed w/ new MakeMaker and Makefile.PL's
+ # with $ENV{PERL_CORE} set
+ # In case we need it in future...
+ require Config; import Config;
+}
+use strict;
+use warnings;
+use Getopt::Std;
+use Config;
+my @orig_ARGV = @ARGV;
+our $VERSION = do { my @r = (q$Revision: 2.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+# These may get re-ordered.
+# RAW is a do_now as inserted by &enter
+# AGG is an aggreagated do_now, as built up by &process
+
+use constant {
+ RAW_NEXT => 0,
+ RAW_IN_LEN => 1,
+ RAW_OUT_BYTES => 2,
+ RAW_FALLBACK => 3,
+
+ AGG_MIN_IN => 0,
+ AGG_MAX_IN => 1,
+ AGG_OUT_BYTES => 2,
+ AGG_NEXT => 3,
+ AGG_IN_LEN => 4,
+ AGG_OUT_LEN => 5,
+ AGG_FALLBACK => 6,
+};
+
+# (See the algorithm in encengine.c - we're building structures for it)
+
+# There are two sorts of structures.
+# "do_now" (an array, two variants of what needs storing) is whatever we need
+# to do now we've read an input byte.
+# It's housed in a "do_next" (which is how we got to it), and in turn points
+# to a "do_next" which contains all the "do_now"s for the next input byte.
+
+# There will be a "do_next" which is the start state.
+# For a single byte encoding it's the only "do_next" - each "do_now" points
+# back to it, and each "do_now" will cause bytes. There is no state.
+
+# For a multi-byte encoding where all characters in the input are the same
+# length, then there will be a tree of "do_now"->"do_next"->"do_now"
+# branching out from the start state, one step for each input byte.
+# The leaf "do_now"s will all be at the same distance from the start state,
+# only the leaf "do_now"s cause output bytes, and they in turn point back to
+# the start state.
+
+# For an encoding where there are varaible length input byte sequences, you
+# will encounter a leaf "do_now" sooner for the shorter input sequences, but
+# as before the leaves will point back to the start state.
+
+# The system will cope with escape encodings (imagine them as a mostly
+# self-contained tree for each escape state, and cross links between trees
+# at the state-switching characters) but so far no input format defines these.
+
+# The system will also cope with having output "leaves" in the middle of
+# the bifurcating branches, not just at the extremities, but again no
+# input format does this yet.
+
+# There are two variants of the "do_now" structure. The first, smaller variant
+# is generated by &enter as the input file is read. There is one structure
+# for each input byte. Say we are mapping a single byte encoding to a
+# single byte encoding, with "ABCD" going "abcd". There will be
+# 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
+
+# &process then walks the tree, building aggregate "do_now" structres for
+# adjacent bytes where possible. The aggregate is for a contiguous range of
+# bytes which each produce the same length of output, each move to the
+# same next state, and each have the same fallback flag.
+# So our 4 RAW "do_now"s above become replaced by a single structure
+# containing:
+# ["A", "D", "abcd", 1, ...]
+# ie, for an input byte $_ in "A".."D", output 1 byte, found as
+# substr ("abcd", (ord $_ - ord "A") * 1, 1)
+# which maps very nicely into pointer arithmetic in C for encengine.c
+
+sub encode_U
+{
+ # UTF-8 encode long hand - only covers part of perl's range
+ ## my $uv = shift;
+ # chr() works in native space so convert value from table
+ # into that space before using chr().
+ my $ch = chr(utf8::unicode_to_native($_[0]));
+ # Now get core perl to encode that the way it likes.
+ utf8::encode($ch);
+ return $ch;
+}
+
+sub encode_S
+{
+ # encode single byte
+ ## my ($ch,$page) = @_; return chr($ch);
+ return chr $_[0];
+}
+
+sub encode_D
+{
+ # encode double byte MS byte first
+ ## my ($ch,$page) = @_; return chr($page).chr($ch);
+ return chr ($_[1]) . chr $_[0];
+}
+
+sub encode_M
+{
+ # encode Multi-byte - single for 0..255 otherwise double
+ ## my ($ch,$page) = @_;
+ ## return &encode_D if $page;
+ ## return &encode_S;
+ return chr ($_[1]) . chr $_[0] if $_[1];
+ return chr $_[0];
+}
+
+my %encode_types = (U => \&encode_U,
+ S => \&encode_S,
+ D => \&encode_D,
+ M => \&encode_M,
+ );
+
+# Win32 does not expand globs on command line
+eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
+
+my %opt;
+# I think these are:
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+getopts('CM:SQqOo:f:n:',\%opt);
+
+$opt{M} and make_makefile_pl($opt{M}, @ARGV);
+$opt{C} and make_configlocal_pm($opt{C}, @ARGV);
+
+# This really should go first, else the die here causes empty (non-erroneous)
+# output files to be written.
+my @encfiles;
+if (exists $opt{'f'}) {
+ # -F is followed by name of file containing list of filenames
+ my $flist = $opt{'f'};
+ open(FLIST,$flist) || die "Cannot open $flist:$!";
+ chomp(@encfiles = <FLIST>);
+ close(FLIST);
+} else {
+ @encfiles = @ARGV;
+}
+
+my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
+chmod(0666,$cname) if -f $cname && !-w $cname;
+open(C,">$cname") || die "Cannot open $cname:$!";
+
+my $dname = $cname;
+my $hname = $cname;
+
+my ($doC,$doEnc,$doUcm,$doPet);
+
+if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
+ {
+ $doC = 1;
+ $dname =~ s/(\.[^\.]*)?$/.exh/;
+ chmod(0666,$dname) if -f $cname && !-w $dname;
+ open(D,">$dname") || die "Cannot open $dname:$!";
+ $hname =~ s/(\.[^\.]*)?$/.h/;
+ chmod(0666,$hname) if -f $cname && !-w $hname;
+ open(H,">$hname") || die "Cannot open $hname:$!";
+
+ foreach my $fh (\*C,\*D,\*H)
+ {
+ print $fh <<"END" unless $opt{'q'};
+/*
+ !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file was autogenerated by:
+ $^X $0 @orig_ARGV
+ enc2xs VERSION $VERSION
+*/
+END
+ }
+
+ if ($cname =~ /(\w+)\.xs$/)
+ {
+ print C "#include <EXTERN.h>\n";
+ print C "#include <perl.h>\n";
+ print C "#include <XSUB.h>\n";
+ print C "#define U8 U8\n";
+ }
+ print C "#include \"encode.h\"\n\n";
+
+ }
+elsif ($cname =~ /\.enc$/)
+ {
+ $doEnc = 1;
+ }
+elsif ($cname =~ /\.ucm$/)
+ {
+ $doUcm = 1;
+ }
+elsif ($cname =~ /\.pet$/)
+ {
+ $doPet = 1;
+ }
+
+my %encoding;
+my %strings;
+my $string_acc;
+my %strings_in_acc;
+
+my $saved = 0;
+my $subsave = 0;
+my $strings = 0;
+
+sub cmp_name
+{
+ if ($a =~ /^.*-(\d+)/)
+ {
+ my $an = $1;
+ if ($b =~ /^.*-(\d+)/)
+ {
+ my $r = $an <=> $1;
+ return $r if $r;
+ }
+ }
+ return $a cmp $b;
+}
+
+
+foreach my $enc (sort cmp_name @encfiles)
+ {
+ my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
+ $name = $opt{'n'} if exists $opt{'n'};
+ if (open(E,$enc))
+ {
+ if ($sfx eq 'enc')
+ {
+ compile_enc(\*E,lc($name));
+ }
+ else
+ {
+ compile_ucm(\*E,lc($name));
+ }
+ }
+ else
+ {
+ warn "Cannot open $enc for $name:$!";
+ }
+ }
+
+if ($doC)
+ {
+ print STDERR "Writing compiled form\n";
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ process($name.'_utf8',$e2u);
+ addstrings(\*C,$e2u);
+
+ process('utf8_'.$name,$u2e);
+ addstrings(\*C,$u2e);
+ }
+ outbigstring(\*C,"enctable");
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ outtable(\*C,$e2u, "enctable");
+ outtable(\*C,$u2e, "enctable");
+
+ # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
+ }
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $exta = $cpp ? 'extern "C" ' : "static";
+ my $extb = $cpp ? 'extern "C" ' : "";
+ foreach my $enc (sort cmp_name keys %encoding)
+ {
+ # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
+ my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
+ #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
+ my $replen = 0;
+ $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
+ my $sym = "${enc}_encoding";
+ $sym =~ s/\W+/_/g;
+ my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen,
+ $min_el,$max_el);
+ print C "${exta} const U8 ${sym}_rep_character[] = \"$rep\";\n";
+ print C "${exta} const char ${sym}_enc_name[] = \"$enc\";\n\n";
+ print C "${extb} const encode_t $sym = \n";
+ # This is to make null encoding work -- dankogai
+ for (my $i = (scalar @info) - 1; $i >= 0; --$i){
+ $info[$i] ||= 1;
+ }
+ # end of null tweak -- dankogai
+ print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n";
+ }
+
+ foreach my $enc (sort cmp_name keys %encoding)
+ {
+ my $sym = "${enc}_encoding";
+ $sym =~ s/\W+/_/g;
+ print H "extern encode_t $sym;\n";
+ print D " Encode_XSEncoding(aTHX_ &$sym);\n";
+ }
+
+ if ($cname =~ /(\w+)\.xs$/)
+ {
+ my $mod = $1;
+ print C <<'END';
+
+static void
+Encode_XSEncoding(pTHX_ encode_t *enc)
+{
+ dSP;
+ HV *stash = gv_stashpv("Encode::XS", TRUE);
+ SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
+ int i = 0;
+ PUSHMARK(sp);
+ XPUSHs(sv);
+ while (enc->name[i])
+ {
+ const char *name = enc->name[i++];
+ XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
+ }
+ PUTBACK;
+ call_pv("Encode::define_encoding",G_DISCARD);
+ SvREFCNT_dec(sv);
+}
+
+END
+
+ print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
+ print C "BOOT:\n{\n";
+ print C "#include \"$dname\"\n";
+ print C "}\n";
+ }
+ # Close in void context is bad, m'kay
+ close(D) or warn "Error closing '$dname': $!";
+ close(H) or warn "Error closing '$hname': $!";
+
+ my $perc_saved = $saved/($strings + $saved) * 100;
+ my $perc_subsaved = $subsave/($strings + $subsave) * 100;
+ printf STDERR "%d bytes in string tables\n",$strings;
+ printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
+ $saved, $perc_saved if $saved;
+ printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
+ $subsave, $perc_subsaved if $subsave;
+ }
+elsif ($doEnc)
+ {
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ output_enc(\*C,$name,$e2u);
+ }
+ }
+elsif ($doUcm)
+ {
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
+ }
+ }
+
+# writing half meg files and then not checking to see if you just filled the
+# disk is bad, m'kay
+close(C) or die "Error closing '$cname': $!";
+
+# End of the main program.
+
+sub compile_ucm
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+ my $cs;
+ my %attr;
+ while (<$fh>)
+ {
+ s/#.*$//;
+ last if /^\s*CHARMAP\s*$/i;
+ if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
+ {
+ $attr{$1} = $2;
+ }
+ }
+ if (!defined($cs = $attr{'code_set_name'}))
+ {
+ warn "No <code_set_name> in $name\n";
+ }
+ else
+ {
+ $name = $cs unless exists $opt{'n'};
+ }
+ my $erep;
+ my $urep;
+ my $max_el;
+ my $min_el;
+ if (exists $attr{'subchar'})
+ {
+ #my @byte;
+ #$attr{'subchar'} =~ /^\s*/cg;
+ #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
+ #$erep = join('',map(chr(hex($_)),@byte));
+ $erep = $attr{'subchar'};
+ $erep =~ s/^\s+//; $erep =~ s/\s+$//;
+ }
+ print "Reading $name ($cs)\n";
+ my $nfb = 0;
+ my $hfb = 0;
+ while (<$fh>)
+ {
+ s/#.*$//;
+ last if /^\s*END\s+CHARMAP\s*$/i;
+ next if /^\s*$/;
+ my (@uni, @byte) = ();
+ my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
+ or die "Bad line: $_";
+ while ($uni =~ m/\G<([U0-9a-fA-F\+]+)>/g){
+ push @uni, map { substr($_, 1) } split(/\+/, $1);
+ }
+ while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
+ push @byte, $1;
+ }
+ if (@uni)
+ {
+ my $uch = join('', map { encode_U(hex($_)) } @uni );
+ my $ech = join('',map(chr(hex($_)),@byte));
+ my $el = length($ech);
+ $max_el = $el if (!defined($max_el) || $el > $max_el);
+ $min_el = $el if (!defined($min_el) || $el < $min_el);
+ if (length($fb))
+ {
+ $fb = substr($fb,1);
+ $hfb++;
+ }
+ else
+ {
+ $nfb++;
+ $fb = '0';
+ }
+ # $fb is fallback flag
+ # 0 - round trip safe
+ # 1 - fallback for unicode -> enc
+ # 2 - skip sub-char mapping
+ # 3 - fallback enc -> unicode
+ enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
+ enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
+ }
+ else
+ {
+ warn $_;
+ }
+ }
+ if ($nfb && $hfb)
+ {
+ die "$nfb entries without fallback, $hfb entries with\n";
+ }
+ $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
+}
+
+
+
+sub compile_enc
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+
+ my $type;
+ while ($type = <$fh>)
+ {
+ last if $type !~ /^\s*#/;
+ }
+ chomp($type);
+ return if $type eq 'E';
+ # Do the hash lookup once, rather than once per function call. 4% speedup.
+ my $type_func = $encode_types{$type};
+ my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
+ warn "$type encoded $name\n";
+ my $rep = '';
+ # Save a defined test by setting these to defined values.
+ my $min_el = ~0; # A very big integer
+ my $max_el = 0; # Anything must be longer than 0
+ {
+ my $v = hex($def);
+ $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
+ }
+ my $errors;
+ my $seen;
+ # use -Q to silence the seen test. Makefile.PL uses this by default.
+ $seen = {} unless $opt{Q};
+ do
+ {
+ my $line = <$fh>;
+ chomp($line);
+ my $page = hex($line);
+ my $ch = 0;
+ my $i = 16;
+ do
+ {
+ # So why is it 1% faster to leave the my here?
+ my $line = <$fh>;
+ $line =~ s/\r\n$/\n/;
+ die "$.:${line}Line should be exactly 65 characters long including
+ newline (".length($line).")" unless length ($line) == 65;
+ # Split line into groups of 4 hex digits, convert groups to ints
+ # This takes 65.35
+ # map {hex $_} $line =~ /(....)/g
+ # This takes 63.75 (2.5% less time)
+ # unpack "n*", pack "H*", $line
+ # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
+ # Doing it as while ($line =~ /(....)/g) took 74.63
+ foreach my $val (unpack "n*", pack "H*", $line)
+ {
+ next if $val == 0xFFFD;
+ my $ech = &$type_func($ch,$page);
+ if ($val || (!$ch && !$page))
+ {
+ my $el = length($ech);
+ $max_el = $el if $el > $max_el;
+ $min_el = $el if $el < $min_el;
+ my $uch = encode_U($val);
+ if ($seen) {
+ # We're doing the test.
+ # We don't need to read this quickly, so storing it as a scalar,
+ # rather than 3 (anon array, plus the 2 scalars it holds) saves
+ # RAM and may make us faster on low RAM systems. [see __END__]
+ if (exists $seen->{$uch})
+ {
+ warn sprintf("U%04X is %02X%02X and %04X\n",
+ $val,$page,$ch,$seen->{$uch});
+ $errors++;
+ }
+ else
+ {
+ $seen->{$uch} = $page << 8 | $ch;
+ }
+ }
+ # Passing 2 extra args each time is 3.6% slower!
+ # Even with having to add $fallback ||= 0 later
+ enter_fb0($e2u,$ech,$uch);
+ enter_fb0($u2e,$uch,$ech);
+ }
+ else
+ {
+ # No character at this position
+ # enter($e2u,$ech,undef,$e2u);
+ }
+ $ch++;
+ }
+ } while --$i;
+ } while --$pages;
+ die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
+ if $min_el > $max_el;
+ die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
+ $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
+}
+
+# my ($a,$s,$d,$t,$fb) = @_;
+sub enter {
+ my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
+ # state we shift to after this (multibyte) input character defaults to same
+ # as current state.
+ $next ||= $current;
+ # Making sure it is defined seems to be faster than {no warnings;} in
+ # &process, or passing it in as 0 explicity.
+ # XXX $fallback ||= 0;
+
+ # Start at the beginning and work forwards through the string to zero.
+ # effectively we are removing 1 character from the front each time
+ # but we don't actually edit the string. [this alone seems to be 14% speedup]
+ # Hence -$pos is the length of the remaining string.
+ my $pos = -length $inbytes;
+ while (1) {
+ my $byte = substr $inbytes, $pos, 1;
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ # to unicode an array would seem to be better, because the pages are dense.
+ # from unicode can be very sparse, favouring a hash.
+ # hash using the bytes (all length 1) as keys rather than ord value,
+ # as it's easier to sort these in &process.
+
+ # It's faster to always add $fallback even if it's undef, rather than
+ # choosing between 3 and 4 element array. (hence why we set it defined
+ # above)
+ my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
+ # When $pos was -1 we were at the last input character.
+ unless (++$pos) {
+ $do_now->[RAW_OUT_BYTES] = $outbytes;
+ $do_now->[RAW_NEXT] = $next;
+ return;
+ }
+ # Tail recursion. The intermdiate state may not have a name yet.
+ $current = $do_now->[RAW_NEXT];
+ }
+}
+
+# This is purely for optimistation. It's just &enter hard coded for $fallback
+# of 0, using only a 3 entry array ref to save memory for every entry.
+sub enter_fb0 {
+ my ($current,$inbytes,$outbytes,$next) = @_;
+ $next ||= $current;
+
+ my $pos = -length $inbytes;
+ while (1) {
+ my $byte = substr $inbytes, $pos, 1;
+ my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
+ unless (++$pos) {
+ $do_now->[RAW_OUT_BYTES] = $outbytes;
+ $do_now->[RAW_NEXT] = $next;
+ return;
+ }
+ $current = $do_now->[RAW_NEXT];
+ }
+}
+
+sub process
+{
+ my ($name,$a) = @_;
+ $name =~ s/\W+/_/g;
+ $a->{Cname} = $name;
+ my $raw = $a->{Raw};
+ my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
+ my @ent;
+ $agg_max_in = 0;
+ foreach my $key (sort keys %$raw) {
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+ # Now we are converting from raw to aggregate, switch from 1 byte strings
+ # to numbers
+ my $b = ord $key;
+ $fallback ||= 0;
+ if ($l &&
+ # If this == fails, we're going to reset $agg_max_in below anyway.
+ $b == ++$agg_max_in &&
+ # References in numeric context give the pointer as an int.
+ $agg_next == $next &&
+ $agg_in_len == $in_len &&
+ $agg_out_len == length $out_bytes &&
+ $agg_fallback == $fallback
+ # && length($l->[AGG_OUT_BYTES]) < 16
+ ) {
+ # my $i = ord($b)-ord($l->[AGG_MIN_IN]);
+ # we can aggregate this byte onto the end.
+ $l->[AGG_MAX_IN] = $b;
+ $l->[AGG_OUT_BYTES] .= $out_bytes;
+ } else {
+ # AGG_MIN_IN => 0,
+ # AGG_MAX_IN => 1,
+ # AGG_OUT_BYTES => 2,
+ # AGG_NEXT => 3,
+ # AGG_IN_LEN => 4,
+ # AGG_OUT_LEN => 5,
+ # AGG_FALLBACK => 6,
+ # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
+ # (only gains .6% on euc-jp -- is it worth it?)
+ push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
+ $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
+ $agg_fallback = $fallback];
+ }
+ if (exists $next->{Cname}) {
+ $next->{'Forward'} = 1 if $next != $a;
+ } else {
+ process(sprintf("%s_%02x",$name,$b),$next);
+ }
+ }
+ # encengine.c rules say that last entry must be for 255
+ if ($agg_max_in < 255) {
+ push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
+ }
+ $a->{'Entries'} = \@ent;
+}
+
+
+sub addstrings
+{
+ my ($fh,$a) = @_;
+ my $name = $a->{'Cname'};
+ # String tables
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ next unless $b->[AGG_OUT_LEN];
+ $strings{$b->[AGG_OUT_BYTES]} = undef;
+ }
+ if ($a->{'Forward'})
+ {
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $^O eq 'MacOS' || $cpp ? 'extern' : 'static';
+ my $const = $cpp ? '' : 'const';
+ print $fh "$var $const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
+ }
+ $a->{'DoneStrings'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($s,$e,$out,$t,$end,$l) = @$b;
+ addstrings($fh,$t) unless $t->{'DoneStrings'};
+ }
+}
+
+sub outbigstring
+{
+ my ($fh,$name) = @_;
+
+ $string_acc = '';
+
+ # Make the big string in the string accumulator. Longest first, on the hope
+ # that this makes it more likely that we find the short strings later on.
+ # Not sure if it helps sorting strings of the same length lexcically.
+ foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
+ my $index = index $string_acc, $s;
+ if ($index >= 0) {
+ $saved += length($s);
+ $strings_in_acc{$s} = $index;
+ } else {
+ OPTIMISER: {
+ if ($opt{'O'}) {
+ my $sublength = length $s;
+ while (--$sublength > 0) {
+ # progressively lop characters off the end, to see if the start of
+ # the new string overlaps the end of the accumulator.
+ if (substr ($string_acc, -$sublength)
+ eq substr ($s, 0, $sublength)) {
+ $subsave += $sublength;
+ $strings_in_acc{$s} = length ($string_acc) - $sublength;
+ # append the last bit on the end.
+ $string_acc .= substr ($s, $sublength);
+ last OPTIMISER;
+ }
+ # or if the end of the new string overlaps the start of the
+ # accumulator
+ next unless substr ($string_acc, 0, $sublength)
+ eq substr ($s, -$sublength);
+ # well, the last $sublength characters of the accumulator match.
+ # so as we're prepending to the accumulator, need to shift all our
+ # existing offsets forwards
+ $_ += $sublength foreach values %strings_in_acc;
+ $subsave += $sublength;
+ $strings_in_acc{$s} = 0;
+ # append the first bit on the start.
+ $string_acc = substr ($s, 0, -$sublength) . $string_acc;
+ last OPTIMISER;
+ }
+ }
+ # Optimiser (if it ran) found nothing, so just going have to tack the
+ # whole thing on the end.
+ $strings_in_acc{$s} = length $string_acc;
+ $string_acc .= $s;
+ };
+ }
+ }
+
+ $strings = length $string_acc;
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $cpp ? '' : 'static';
+ my $definition = "\n$var const U8 $name\[$strings] = { " .
+ join(',',unpack "C*",$string_acc);
+ # We have a single long line. Split it at convenient commas.
+ print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
+ print $fh substr ($definition, pos $definition), " };\n";
+}
+
+sub findstring {
+ my ($name,$s) = @_;
+ my $offset = $strings_in_acc{$s};
+ die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
+ unless defined $offset;
+ "$name + $offset";
+}
+
+sub outtable
+{
+ my ($fh,$a,$bigname) = @_;
+ my $name = $a->{'Cname'};
+ $a->{'Done'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($s,$e,$out,$t,$end,$l) = @$b;
+ outtable($fh,$t,$bigname) unless $t->{'Done'};
+ }
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $cpp ? '' : 'static';
+ my $const = $cpp ? '' : 'const';
+ print $fh "\n$var $const encpage_t $name\[",
+ scalar(@{$a->{'Entries'}}), "] = {\n";
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
+ # $end |= 0x80 if $fb; # what the heck was on your mind, Nick? -- Dan
+ print $fh "{";
+ if ($l)
+ {
+ printf $fh findstring($bigname,$out);
+ }
+ else
+ {
+ print $fh "0";
+ }
+ print $fh ",",$t->{Cname};
+ printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
+ }
+ print $fh "};\n";
+}
+
+sub output_enc
+{
+ my ($fh,$name,$a) = @_;
+ die "Changed - fix me for new structure";
+ foreach my $b (sort keys %$a)
+ {
+ my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
+ }
+}
+
+sub decode_U
+{
+ my $s = shift;
+}
+
+my @uname;
+sub char_names
+{
+ my $s = do "unicore/Name.pl";
+ die "char_names: unicore/Name.pl: $!\n" unless defined $s;
+ pos($s) = 0;
+ while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
+ {
+ my $name = $3;
+ my $s = hex($1);
+ last if $s >= 0x10000;
+ my $e = length($2) ? hex($2) : $s;
+ for (my $i = $s; $i <= $e; $i++)
+ {
+ $uname[$i] = $name;
+# print sprintf("U%04X $name\n",$i);
+ }
+ }
+}
+
+sub output_ucm_page
+{
+ my ($cmap,$a,$t,$pre) = @_;
+ # warn sprintf("Page %x\n",$pre);
+ my $raw = $t->{Raw};
+ foreach my $key (sort keys %$raw) {
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+ my $u = ord $key;
+ $fallback ||= 0;
+
+ if ($next != $a && $next != $t) {
+ output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
+ } elsif (length $out_bytes) {
+ if ($pre) {
+ $u = $pre|($u &0x3f);
+ }
+ my $s = sprintf "<U%04X> ",$u;
+ #foreach my $c (split(//,$out_bytes)) {
+ # $s .= sprintf "\\x%02X",ord($c);
+ #}
+ # 9.5% faster changing that loop to this:
+ $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
+ $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
+ push(@$cmap,$s);
+ } else {
+ warn join(',',$u, @{$raw->{$key}},$a,$t);
+ }
+ }
+}
+
+sub output_ucm
+{
+ my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
+ print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
+ print $fh "<code_set_name> \"$name\"\n";
+ char_names();
+ if (defined $min_el)
+ {
+ print $fh "<mb_cur_min> $min_el\n";
+ }
+ if (defined $max_el)
+ {
+ print $fh "<mb_cur_max> $max_el\n";
+ }
+ if (defined $rep)
+ {
+ print $fh "<subchar> ";
+ foreach my $c (split(//,$rep))
+ {
+ printf $fh "\\x%02X",ord($c);
+ }
+ print $fh "\n";
+ }
+ my @cmap;
+ output_ucm_page(\@cmap,$h,$h,0);
+ print $fh "#\nCHARMAP\n";
+ foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
+ {
+ print $fh $line;
+ }
+ print $fh "END CHARMAP\n";
+}
+
+use vars qw(
+ $_Enc2xs
+ $_Version
+ $_Inc
+ $_E2X
+ $_Name
+ $_TableFiles
+ $_Now
+);
+
+sub find_e2x{
+ eval { require File::Find; };
+ my (@inc, %e2x_dir);
+ for my $inc (@INC){
+ push @inc, $inc unless $inc eq '.'; #skip current dir
+ }
+ File::Find::find(
+ sub {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = lstat($_) or return;
+ -f _ or return;
+ if (/^.*\.e2x$/o){
+ no warnings 'once';
+ $e2x_dir{$File::Find::dir} ||= $mtime;
+ }
+ return;
+ }, @inc);
+ warn join("\n", keys %e2x_dir), "\n";
+ for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
+ $_E2X = $d;
+ # warn "$_E2X => ", scalar localtime($e2x_dir{$d});
+ return $_E2X;
+ }
+}
+
+sub make_makefile_pl
+{
+ eval { require Encode; };
+ $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
+ # our used for variable expanstion
+ $_Enc2xs = $0;
+ $_Version = $VERSION;
+ $_E2X = find_e2x();
+ $_Name = shift;
+ $_TableFiles = join(",", map {qq('$_')} @_);
+ $_Now = scalar localtime();
+
+ eval { require File::Spec; };
+ _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
+ _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"), "$_Name.pm");
+ _print_expand(File::Spec->catfile($_E2X,"_T.e2x"), "t/$_Name.t");
+ _print_expand(File::Spec->catfile($_E2X,"README.e2x"), "README");
+ _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"), "Changes");
+ exit;
+}
+
+use vars qw(
+ $_ModLines
+ $_LocalVer
+ );
+
+sub make_configlocal_pm {
+ eval { require Encode; };
+ $@ and die "Unable to require Encode: $@\n";
+ eval { require File::Spec; };
+
+ # our used for variable expanstion
+ my %in_core = map { $_ => 1 } (
+ 'ascii', 'iso-8859-1', 'utf8',
+ 'ascii-ctrl', 'null', 'utf-8-strict'
+ );
+ my %LocalMod = ();
+ # check @enc;
+ use File::Find ();
+ my $wanted = sub{
+ -f $_ or return;
+ $File::Find::name =~ /\A\./ and return;
+ $File::Find::name =~ /\.pm\z/ or return;
+ $File::Find::name =~ m/\bEncode\b/ or return;
+ my $mod = $File::Find::name;
+ $mod =~ s/.*\bEncode\b/Encode/o;
+ $mod =~ s/\.pm\z//o;
+ $mod =~ s,/,::,og;
+ warn qq{ require $mod;\n};
+ eval qq{ require $mod; };
+ $@ and die "Can't require $mod: $@\n";
+ for my $enc ( Encode->encodings() ) {
+ no warnings;
+ $in_core{$enc} and next;
+ $Encode::Config::ExtModule{$enc} and next;
+ $LocalMod{$enc} ||= $mod;
+ }
+ };
+ File::Find::find({wanted => $wanted}, @INC);
+ $_ModLines = "";
+ for my $enc ( sort keys %LocalMod ) {
+ $_ModLines .=
+ qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n);
+ }
+ warn $_ModLines;
+ $_LocalVer = _mkversion();
+ $_E2X = find_e2x();
+ $_Inc = $INC{"Encode.pm"};
+ $_Inc =~ s/\.pm$//o;
+ _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ),
+ File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 );
+ exit;
+}
+
+sub _mkversion{
+ # v-string is now depreciated; use time() instead;
+ #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
+ #$yyyy += 1900, $mo +=1;
+ #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
+ return time();
+}
+
+sub _print_expand{
+ eval { require File::Basename; };
+ $@ and die "File::Basename needed. Are you on miniperl?;\nerror: $@\n";
+ File::Basename->import();
+ my ($src, $dst, $clobber) = @_;
+ if (!$clobber and -e $dst){
+ warn "$dst exists. skipping\n";
+ return;
+ }
+ warn "Generating $dst...\n";
+ open my $in, $src or die "$src : $!";
+ if ((my $d = dirname($dst)) ne '.'){
+ -d $d or mkdir $d, 0755 or die "mkdir $d : $!";
+ }
+ open my $out, ">$dst" or die "$!";
+ my $asis = 0;
+ while (<$in>){
+ if (/^#### END_OF_HEADER/){
+ $asis = 1; next;
+ }
+ s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
+ print $out $_;
+ }
+}
+__END__
+
+=head1 NAME
+
+enc2xs -- Perl Encode Module Generator
+
+=head1 SYNOPSIS
+
+ enc2xs -[options]
+ enc2xs -M ModName mapfiles...
+ enc2xs -C
+
+=head1 DESCRIPTION
+
+F<enc2xs> builds a Perl extension for use by Encode from either
+Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
+Besides being used internally during the build process of the Encode
+module, you can use F<enc2xs> to add your own encoding to perl.
+No knowledge of XS is necessary.
+
+=head1 Quick Guide
+
+If you want to know as little about Perl as possible but need to
+add a new encoding, just read this chapter and forget the rest.
+
+=over 4
+
+=item 0.
+
+Have a .ucm file ready. You can get it from somewhere or you can write
+your own from scratch or you can grab one from the Encode distribution
+and customize it. For the UCM format, see the next Chapter. In the
+example below, I'll call my theoretical encoding myascii, defined
+in I<my.ucm>. C<$> is a shell prompt.
+
+ $ ls -F
+ my.ucm
+
+=item 1.
+
+Issue a command as follows;
+
+ $ enc2xs -M My my.ucm
+ generating Makefile.PL
+ generating My.pm
+ generating README
+ generating Changes
+
+Now take a look at your current directory. It should look like this.
+
+ $ ls -F
+ Makefile.PL My.pm my.ucm t/
+
+The following files were created.
+
+ Makefile.PL - MakeMaker script
+ My.pm - Encode submodule
+ t/My.t - test file
+
+=over 4
+
+=item 1.1.
+
+If you want *.ucm installed together with the modules, do as follows;
+
+ $ mkdir Encode
+ $ mv *.ucm Encode
+ $ enc2xs -M My Encode/*ucm
+
+=back
+
+=item 2.
+
+Edit the files generated. You don't have to if you have no time AND no
+intention to give it to someone else. But it is a good idea to edit
+the pod and to add more tests.
+
+=item 3.
+
+Now issue a command all Perl Mongers love:
+
+ $ perl Makefile.PL
+ Writing Makefile for Encode::My
+
+=item 4.
+
+Now all you have to do is make.
+
+ $ make
+ cp My.pm blib/lib/Encode/My.pm
+ /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
+ -o encode_t.c -f encode_t.fnm
+ Reading myascii (myascii)
+ Writing compiled form
+ 128 bytes in string tables
+ 384 bytes (75%) saved spotting duplicates
+ 1 bytes (0.775%) saved using substrings
+ ....
+ chmod 644 blib/arch/auto/Encode/My/My.bs
+ $
+
+The time it takes varies depending on how fast your machine is and
+how large your encoding is. Unless you are working on something big
+like euc-tw, it won't take too long.
+
+=item 5.
+
+You can "make install" already but you should test first.
+
+ $ make test
+ PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
+ -e 'use Test::Harness qw(&runtests $verbose); \
+ $verbose=0; runtests @ARGV;' t/*.t
+ t/My....ok
+ All tests successful.
+ Files=1, Tests=2, 0 wallclock secs
+ ( 0.09 cusr + 0.01 csys = 0.09 CPU)
+
+=item 6.
+
+If you are content with the test result, just "make install"
+
+=item 7.
+
+If you want to add your encoding to Encode's demand-loading list
+(so you don't have to "use Encode::YourEncoding"), run
+
+ enc2xs -C
+
+to update Encode::ConfigLocal, a module that controls local settings.
+After that, "use Encode;" is enough to load your encodings on demand.
+
+=back
+
+=head1 The Unicode Character Map
+
+Encode uses the Unicode Character Map (UCM) format for source character
+mappings. This format is used by IBM's ICU package and was adopted
+by Nick Ing-Simmons for use with the Encode module. Since UCM is
+more flexible than Tcl's Encoding Map and far more user-friendly,
+this is the recommended format for Encode now.
+
+A UCM file looks like this.
+
+ #
+ # Comments
+ #
+ <code_set_name> "US-ascii" # Required
+ <code_set_alias> "ascii" # Optional
+ <mb_cur_min> 1 # Required; usually 1
+ <mb_cur_max> 1 # Max. # of bytes/char
+ <subchar> \x3F # Substitution char
+ #
+ CHARMAP
+ <U0000> \x00 |0 # <control>
+ <U0001> \x01 |0 # <control>
+ <U0002> \x02 |0 # <control>
+ ....
+ <U007C> \x7C |0 # VERTICAL LINE
+ <U007D> \x7D |0 # RIGHT CURLY BRACKET
+ <U007E> \x7E |0 # TILDE
+ <U007F> \x7F |0 # <control>
+ END CHARMAP
+
+=over 4
+
+=item *
+
+Anything that follows C<#> is treated as a comment.
+
+=item *
+
+The header section continues until a line containing the word
+CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
+pair per line. Strings used as values must be quoted. Barewords are
+treated as numbers. I<\xXX> represents a byte.
+
+Most of the keywords are self-explanatory. I<subchar> means
+substitution character, not subcharacter. When you decode a Unicode
+sequence to this encoding but no matching character is found, the byte
+sequence defined here will be used. For most cases, the value here is
+\x3F; in ASCII, this is a question mark.
+
+=item *
+
+CHARMAP starts the character map section. Each line has a form as
+follows:
+
+ <UXXXX> \xXX.. |0 # comment
+ ^ ^ ^
+ | | +- Fallback flag
+ | +-------- Encoded byte sequence
+ +-------------- Unicode Character ID in hex
+
+The format is roughly the same as a header section except for the
+fallback flag: | followed by 0..3. The meaning of the possible
+values is as follows:
+
+=over 4
+
+=item |0
+
+Round trip safe. A character decoded to Unicode encodes back to the
+same byte sequence. Most characters have this flag.
+
+=item |1
+
+Fallback for unicode -> encoding. When seen, enc2xs adds this
+character for the encode map only.
+
+=item |2
+
+Skip sub-char mapping should there be no code point.
+
+=item |3
+
+Fallback for encoding -> unicode. When seen, enc2xs adds this
+character for the decode map only.
+
+=back
+
+=item *
+
+And finally, END OF CHARMAP ends the section.
+
+=back
+
+When you are manually creating a UCM file, you should copy ascii.ucm
+or an existing encoding which is close to yours, rather than write
+your own from scratch.
+
+When you do so, make sure you leave at least B<U0000> to B<U0020> as
+is, unless your environment is EBCDIC.
+
+B<CAVEAT>: not all features in UCM are implemented. For example,
+icu:state is not used. Because of that, you need to write a perl
+module if you want to support algorithmical encodings, notably
+the ISO-2022 series. Such modules include L<Encode::JP::2022_JP>,
+L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
+
+=head2 Coping with duplicate mappings
+
+When you create a map, you SHOULD make your mappings round-trip safe.
+That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
+$data> stands for all characters that are marked as C<|0>. Here is
+how to make sure:
+
+=over 4
+
+=item *
+
+Sort your map in Unicode order.
+
+=item *
+
+When you have a duplicate entry, mark either one with '|1' or '|3'.
+
+=item *
+
+And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
+
+=back
+
+Here is an example from big5-eten.
+
+ <U2550> \xF9\xF9 |0
+ <U2550> \xA2\xA4 |3
+
+Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
+this;
+
+ E to U U to E
+ --------------------------------------
+ \xF9\xF9 => U2550 U2550 => \xF9\xF9
+ \xA2\xA4 => U2550
+
+So it is round-trip safe for \xF9\xF9. But if the line above is upside
+down, here is what happens.
+
+ E to U U to E
+ --------------------------------------
+ \xA2\xA4 => U2550 U2550 => \xF9\xF9
+ (\xF9\xF9 => U2550 is now overwritten!)
+
+The Encode package comes with F<ucmlint>, a crude but sufficient
+utility to check the integrity of a UCM file. Check under the
+Encode/bin directory for this.
+
+When in doubt, you can use F<ucmsort>, yet another utility under
+Encode/bin directory.
+
+=head1 Bookmarks
+
+=over 4
+
+=item *
+
+ICU Home Page
+L<http://www.icu-project.org/>
+
+=item *
+
+ICU Character Mapping Tables
+L<http://site.icu-project.org/charts/charset>
+
+=item *
+
+ICU:Conversion Data
+L<http://www.icu-project.org/userguide/conversion-data.html>
+
+=back
+
+=head1 SEE ALSO
+
+L<Encode>,
+L<perlmod>,
+L<perlpod>
+
+=cut
+
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+
+With %seen holding array refs:
+
+ 865.66 real 28.80 user 8.79 sys
+ 7904 maximum resident set size
+ 1356 average shared memory size
+ 18566 average unshared data size
+ 229 average unshared stack size
+ 46080 page reclaims
+ 33373 page faults
+
+With %seen holding simple scalars:
+
+ 342.16 real 27.11 user 3.54 sys
+ 8388 maximum resident set size
+ 1394 average shared memory size
+ 14969 average unshared data size
+ 236 average unshared stack size
+ 28159 page reclaims
+ 9839 page faults
+
+Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
+how %seen is storing things its seen. So it is pathalogically bad on a 16M
+RAM machine, but it's going to help even on modern machines.
+Swapping is bad, m'kay :-)
diff --git a/Master/tlpkg/tlperl.straw/bin/enc2xs.bat b/Master/tlpkg/tlperl.straw/bin/enc2xs.bat
new file mode 100755
index 00000000000..dfed5e1ec34
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/enc2xs.bat
@@ -0,0 +1,1423 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!./perl
+#line 15
+BEGIN {
+ # @INC poking no longer needed w/ new MakeMaker and Makefile.PL's
+ # with $ENV{PERL_CORE} set
+ # In case we need it in future...
+ require Config; import Config;
+}
+use strict;
+use warnings;
+use Getopt::Std;
+use Config;
+my @orig_ARGV = @ARGV;
+our $VERSION = do { my @r = (q$Revision: 2.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+# These may get re-ordered.
+# RAW is a do_now as inserted by &enter
+# AGG is an aggreagated do_now, as built up by &process
+
+use constant {
+ RAW_NEXT => 0,
+ RAW_IN_LEN => 1,
+ RAW_OUT_BYTES => 2,
+ RAW_FALLBACK => 3,
+
+ AGG_MIN_IN => 0,
+ AGG_MAX_IN => 1,
+ AGG_OUT_BYTES => 2,
+ AGG_NEXT => 3,
+ AGG_IN_LEN => 4,
+ AGG_OUT_LEN => 5,
+ AGG_FALLBACK => 6,
+};
+
+# (See the algorithm in encengine.c - we're building structures for it)
+
+# There are two sorts of structures.
+# "do_now" (an array, two variants of what needs storing) is whatever we need
+# to do now we've read an input byte.
+# It's housed in a "do_next" (which is how we got to it), and in turn points
+# to a "do_next" which contains all the "do_now"s for the next input byte.
+
+# There will be a "do_next" which is the start state.
+# For a single byte encoding it's the only "do_next" - each "do_now" points
+# back to it, and each "do_now" will cause bytes. There is no state.
+
+# For a multi-byte encoding where all characters in the input are the same
+# length, then there will be a tree of "do_now"->"do_next"->"do_now"
+# branching out from the start state, one step for each input byte.
+# The leaf "do_now"s will all be at the same distance from the start state,
+# only the leaf "do_now"s cause output bytes, and they in turn point back to
+# the start state.
+
+# For an encoding where there are varaible length input byte sequences, you
+# will encounter a leaf "do_now" sooner for the shorter input sequences, but
+# as before the leaves will point back to the start state.
+
+# The system will cope with escape encodings (imagine them as a mostly
+# self-contained tree for each escape state, and cross links between trees
+# at the state-switching characters) but so far no input format defines these.
+
+# The system will also cope with having output "leaves" in the middle of
+# the bifurcating branches, not just at the extremities, but again no
+# input format does this yet.
+
+# There are two variants of the "do_now" structure. The first, smaller variant
+# is generated by &enter as the input file is read. There is one structure
+# for each input byte. Say we are mapping a single byte encoding to a
+# single byte encoding, with "ABCD" going "abcd". There will be
+# 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
+
+# &process then walks the tree, building aggregate "do_now" structres for
+# adjacent bytes where possible. The aggregate is for a contiguous range of
+# bytes which each produce the same length of output, each move to the
+# same next state, and each have the same fallback flag.
+# So our 4 RAW "do_now"s above become replaced by a single structure
+# containing:
+# ["A", "D", "abcd", 1, ...]
+# ie, for an input byte $_ in "A".."D", output 1 byte, found as
+# substr ("abcd", (ord $_ - ord "A") * 1, 1)
+# which maps very nicely into pointer arithmetic in C for encengine.c
+
+sub encode_U
+{
+ # UTF-8 encode long hand - only covers part of perl's range
+ ## my $uv = shift;
+ # chr() works in native space so convert value from table
+ # into that space before using chr().
+ my $ch = chr(utf8::unicode_to_native($_[0]));
+ # Now get core perl to encode that the way it likes.
+ utf8::encode($ch);
+ return $ch;
+}
+
+sub encode_S
+{
+ # encode single byte
+ ## my ($ch,$page) = @_; return chr($ch);
+ return chr $_[0];
+}
+
+sub encode_D
+{
+ # encode double byte MS byte first
+ ## my ($ch,$page) = @_; return chr($page).chr($ch);
+ return chr ($_[1]) . chr $_[0];
+}
+
+sub encode_M
+{
+ # encode Multi-byte - single for 0..255 otherwise double
+ ## my ($ch,$page) = @_;
+ ## return &encode_D if $page;
+ ## return &encode_S;
+ return chr ($_[1]) . chr $_[0] if $_[1];
+ return chr $_[0];
+}
+
+my %encode_types = (U => \&encode_U,
+ S => \&encode_S,
+ D => \&encode_D,
+ M => \&encode_M,
+ );
+
+# Win32 does not expand globs on command line
+eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
+
+my %opt;
+# I think these are:
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+getopts('CM:SQqOo:f:n:',\%opt);
+
+$opt{M} and make_makefile_pl($opt{M}, @ARGV);
+$opt{C} and make_configlocal_pm($opt{C}, @ARGV);
+
+# This really should go first, else the die here causes empty (non-erroneous)
+# output files to be written.
+my @encfiles;
+if (exists $opt{'f'}) {
+ # -F is followed by name of file containing list of filenames
+ my $flist = $opt{'f'};
+ open(FLIST,$flist) || die "Cannot open $flist:$!";
+ chomp(@encfiles = <FLIST>);
+ close(FLIST);
+} else {
+ @encfiles = @ARGV;
+}
+
+my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
+chmod(0666,$cname) if -f $cname && !-w $cname;
+open(C,">$cname") || die "Cannot open $cname:$!";
+
+my $dname = $cname;
+my $hname = $cname;
+
+my ($doC,$doEnc,$doUcm,$doPet);
+
+if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
+ {
+ $doC = 1;
+ $dname =~ s/(\.[^\.]*)?$/.exh/;
+ chmod(0666,$dname) if -f $cname && !-w $dname;
+ open(D,">$dname") || die "Cannot open $dname:$!";
+ $hname =~ s/(\.[^\.]*)?$/.h/;
+ chmod(0666,$hname) if -f $cname && !-w $hname;
+ open(H,">$hname") || die "Cannot open $hname:$!";
+
+ foreach my $fh (\*C,\*D,\*H)
+ {
+ print $fh <<"END" unless $opt{'q'};
+/*
+ !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file was autogenerated by:
+ $^X $0 @orig_ARGV
+ enc2xs VERSION $VERSION
+*/
+END
+ }
+
+ if ($cname =~ /(\w+)\.xs$/)
+ {
+ print C "#include <EXTERN.h>\n";
+ print C "#include <perl.h>\n";
+ print C "#include <XSUB.h>\n";
+ print C "#define U8 U8\n";
+ }
+ print C "#include \"encode.h\"\n\n";
+
+ }
+elsif ($cname =~ /\.enc$/)
+ {
+ $doEnc = 1;
+ }
+elsif ($cname =~ /\.ucm$/)
+ {
+ $doUcm = 1;
+ }
+elsif ($cname =~ /\.pet$/)
+ {
+ $doPet = 1;
+ }
+
+my %encoding;
+my %strings;
+my $string_acc;
+my %strings_in_acc;
+
+my $saved = 0;
+my $subsave = 0;
+my $strings = 0;
+
+sub cmp_name
+{
+ if ($a =~ /^.*-(\d+)/)
+ {
+ my $an = $1;
+ if ($b =~ /^.*-(\d+)/)
+ {
+ my $r = $an <=> $1;
+ return $r if $r;
+ }
+ }
+ return $a cmp $b;
+}
+
+
+foreach my $enc (sort cmp_name @encfiles)
+ {
+ my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
+ $name = $opt{'n'} if exists $opt{'n'};
+ if (open(E,$enc))
+ {
+ if ($sfx eq 'enc')
+ {
+ compile_enc(\*E,lc($name));
+ }
+ else
+ {
+ compile_ucm(\*E,lc($name));
+ }
+ }
+ else
+ {
+ warn "Cannot open $enc for $name:$!";
+ }
+ }
+
+if ($doC)
+ {
+ print STDERR "Writing compiled form\n";
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ process($name.'_utf8',$e2u);
+ addstrings(\*C,$e2u);
+
+ process('utf8_'.$name,$u2e);
+ addstrings(\*C,$u2e);
+ }
+ outbigstring(\*C,"enctable");
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ outtable(\*C,$e2u, "enctable");
+ outtable(\*C,$u2e, "enctable");
+
+ # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
+ }
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $exta = $cpp ? 'extern "C" ' : "static";
+ my $extb = $cpp ? 'extern "C" ' : "";
+ foreach my $enc (sort cmp_name keys %encoding)
+ {
+ # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
+ my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
+ #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
+ my $replen = 0;
+ $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
+ my $sym = "${enc}_encoding";
+ $sym =~ s/\W+/_/g;
+ my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen,
+ $min_el,$max_el);
+ print C "${exta} const U8 ${sym}_rep_character[] = \"$rep\";\n";
+ print C "${exta} const char ${sym}_enc_name[] = \"$enc\";\n\n";
+ print C "${extb} const encode_t $sym = \n";
+ # This is to make null encoding work -- dankogai
+ for (my $i = (scalar @info) - 1; $i >= 0; --$i){
+ $info[$i] ||= 1;
+ }
+ # end of null tweak -- dankogai
+ print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n";
+ }
+
+ foreach my $enc (sort cmp_name keys %encoding)
+ {
+ my $sym = "${enc}_encoding";
+ $sym =~ s/\W+/_/g;
+ print H "extern encode_t $sym;\n";
+ print D " Encode_XSEncoding(aTHX_ &$sym);\n";
+ }
+
+ if ($cname =~ /(\w+)\.xs$/)
+ {
+ my $mod = $1;
+ print C <<'END';
+
+static void
+Encode_XSEncoding(pTHX_ encode_t *enc)
+{
+ dSP;
+ HV *stash = gv_stashpv("Encode::XS", TRUE);
+ SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
+ int i = 0;
+ PUSHMARK(sp);
+ XPUSHs(sv);
+ while (enc->name[i])
+ {
+ const char *name = enc->name[i++];
+ XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
+ }
+ PUTBACK;
+ call_pv("Encode::define_encoding",G_DISCARD);
+ SvREFCNT_dec(sv);
+}
+
+END
+
+ print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
+ print C "BOOT:\n{\n";
+ print C "#include \"$dname\"\n";
+ print C "}\n";
+ }
+ # Close in void context is bad, m'kay
+ close(D) or warn "Error closing '$dname': $!";
+ close(H) or warn "Error closing '$hname': $!";
+
+ my $perc_saved = $saved/($strings + $saved) * 100;
+ my $perc_subsaved = $subsave/($strings + $subsave) * 100;
+ printf STDERR "%d bytes in string tables\n",$strings;
+ printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
+ $saved, $perc_saved if $saved;
+ printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
+ $subsave, $perc_subsaved if $subsave;
+ }
+elsif ($doEnc)
+ {
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ output_enc(\*C,$name,$e2u);
+ }
+ }
+elsif ($doUcm)
+ {
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
+ }
+ }
+
+# writing half meg files and then not checking to see if you just filled the
+# disk is bad, m'kay
+close(C) or die "Error closing '$cname': $!";
+
+# End of the main program.
+
+sub compile_ucm
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+ my $cs;
+ my %attr;
+ while (<$fh>)
+ {
+ s/#.*$//;
+ last if /^\s*CHARMAP\s*$/i;
+ if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
+ {
+ $attr{$1} = $2;
+ }
+ }
+ if (!defined($cs = $attr{'code_set_name'}))
+ {
+ warn "No <code_set_name> in $name\n";
+ }
+ else
+ {
+ $name = $cs unless exists $opt{'n'};
+ }
+ my $erep;
+ my $urep;
+ my $max_el;
+ my $min_el;
+ if (exists $attr{'subchar'})
+ {
+ #my @byte;
+ #$attr{'subchar'} =~ /^\s*/cg;
+ #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
+ #$erep = join('',map(chr(hex($_)),@byte));
+ $erep = $attr{'subchar'};
+ $erep =~ s/^\s+//; $erep =~ s/\s+$//;
+ }
+ print "Reading $name ($cs)\n";
+ my $nfb = 0;
+ my $hfb = 0;
+ while (<$fh>)
+ {
+ s/#.*$//;
+ last if /^\s*END\s+CHARMAP\s*$/i;
+ next if /^\s*$/;
+ my (@uni, @byte) = ();
+ my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
+ or die "Bad line: $_";
+ while ($uni =~ m/\G<([U0-9a-fA-F\+]+)>/g){
+ push @uni, map { substr($_, 1) } split(/\+/, $1);
+ }
+ while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
+ push @byte, $1;
+ }
+ if (@uni)
+ {
+ my $uch = join('', map { encode_U(hex($_)) } @uni );
+ my $ech = join('',map(chr(hex($_)),@byte));
+ my $el = length($ech);
+ $max_el = $el if (!defined($max_el) || $el > $max_el);
+ $min_el = $el if (!defined($min_el) || $el < $min_el);
+ if (length($fb))
+ {
+ $fb = substr($fb,1);
+ $hfb++;
+ }
+ else
+ {
+ $nfb++;
+ $fb = '0';
+ }
+ # $fb is fallback flag
+ # 0 - round trip safe
+ # 1 - fallback for unicode -> enc
+ # 2 - skip sub-char mapping
+ # 3 - fallback enc -> unicode
+ enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
+ enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
+ }
+ else
+ {
+ warn $_;
+ }
+ }
+ if ($nfb && $hfb)
+ {
+ die "$nfb entries without fallback, $hfb entries with\n";
+ }
+ $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
+}
+
+
+
+sub compile_enc
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+
+ my $type;
+ while ($type = <$fh>)
+ {
+ last if $type !~ /^\s*#/;
+ }
+ chomp($type);
+ return if $type eq 'E';
+ # Do the hash lookup once, rather than once per function call. 4% speedup.
+ my $type_func = $encode_types{$type};
+ my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
+ warn "$type encoded $name\n";
+ my $rep = '';
+ # Save a defined test by setting these to defined values.
+ my $min_el = ~0; # A very big integer
+ my $max_el = 0; # Anything must be longer than 0
+ {
+ my $v = hex($def);
+ $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
+ }
+ my $errors;
+ my $seen;
+ # use -Q to silence the seen test. Makefile.PL uses this by default.
+ $seen = {} unless $opt{Q};
+ do
+ {
+ my $line = <$fh>;
+ chomp($line);
+ my $page = hex($line);
+ my $ch = 0;
+ my $i = 16;
+ do
+ {
+ # So why is it 1% faster to leave the my here?
+ my $line = <$fh>;
+ $line =~ s/\r\n$/\n/;
+ die "$.:${line}Line should be exactly 65 characters long including
+ newline (".length($line).")" unless length ($line) == 65;
+ # Split line into groups of 4 hex digits, convert groups to ints
+ # This takes 65.35
+ # map {hex $_} $line =~ /(....)/g
+ # This takes 63.75 (2.5% less time)
+ # unpack "n*", pack "H*", $line
+ # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
+ # Doing it as while ($line =~ /(....)/g) took 74.63
+ foreach my $val (unpack "n*", pack "H*", $line)
+ {
+ next if $val == 0xFFFD;
+ my $ech = &$type_func($ch,$page);
+ if ($val || (!$ch && !$page))
+ {
+ my $el = length($ech);
+ $max_el = $el if $el > $max_el;
+ $min_el = $el if $el < $min_el;
+ my $uch = encode_U($val);
+ if ($seen) {
+ # We're doing the test.
+ # We don't need to read this quickly, so storing it as a scalar,
+ # rather than 3 (anon array, plus the 2 scalars it holds) saves
+ # RAM and may make us faster on low RAM systems. [see __END__]
+ if (exists $seen->{$uch})
+ {
+ warn sprintf("U%04X is %02X%02X and %04X\n",
+ $val,$page,$ch,$seen->{$uch});
+ $errors++;
+ }
+ else
+ {
+ $seen->{$uch} = $page << 8 | $ch;
+ }
+ }
+ # Passing 2 extra args each time is 3.6% slower!
+ # Even with having to add $fallback ||= 0 later
+ enter_fb0($e2u,$ech,$uch);
+ enter_fb0($u2e,$uch,$ech);
+ }
+ else
+ {
+ # No character at this position
+ # enter($e2u,$ech,undef,$e2u);
+ }
+ $ch++;
+ }
+ } while --$i;
+ } while --$pages;
+ die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
+ if $min_el > $max_el;
+ die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
+ $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
+}
+
+# my ($a,$s,$d,$t,$fb) = @_;
+sub enter {
+ my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
+ # state we shift to after this (multibyte) input character defaults to same
+ # as current state.
+ $next ||= $current;
+ # Making sure it is defined seems to be faster than {no warnings;} in
+ # &process, or passing it in as 0 explicity.
+ # XXX $fallback ||= 0;
+
+ # Start at the beginning and work forwards through the string to zero.
+ # effectively we are removing 1 character from the front each time
+ # but we don't actually edit the string. [this alone seems to be 14% speedup]
+ # Hence -$pos is the length of the remaining string.
+ my $pos = -length $inbytes;
+ while (1) {
+ my $byte = substr $inbytes, $pos, 1;
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ # to unicode an array would seem to be better, because the pages are dense.
+ # from unicode can be very sparse, favouring a hash.
+ # hash using the bytes (all length 1) as keys rather than ord value,
+ # as it's easier to sort these in &process.
+
+ # It's faster to always add $fallback even if it's undef, rather than
+ # choosing between 3 and 4 element array. (hence why we set it defined
+ # above)
+ my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
+ # When $pos was -1 we were at the last input character.
+ unless (++$pos) {
+ $do_now->[RAW_OUT_BYTES] = $outbytes;
+ $do_now->[RAW_NEXT] = $next;
+ return;
+ }
+ # Tail recursion. The intermdiate state may not have a name yet.
+ $current = $do_now->[RAW_NEXT];
+ }
+}
+
+# This is purely for optimistation. It's just &enter hard coded for $fallback
+# of 0, using only a 3 entry array ref to save memory for every entry.
+sub enter_fb0 {
+ my ($current,$inbytes,$outbytes,$next) = @_;
+ $next ||= $current;
+
+ my $pos = -length $inbytes;
+ while (1) {
+ my $byte = substr $inbytes, $pos, 1;
+ my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
+ unless (++$pos) {
+ $do_now->[RAW_OUT_BYTES] = $outbytes;
+ $do_now->[RAW_NEXT] = $next;
+ return;
+ }
+ $current = $do_now->[RAW_NEXT];
+ }
+}
+
+sub process
+{
+ my ($name,$a) = @_;
+ $name =~ s/\W+/_/g;
+ $a->{Cname} = $name;
+ my $raw = $a->{Raw};
+ my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
+ my @ent;
+ $agg_max_in = 0;
+ foreach my $key (sort keys %$raw) {
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+ # Now we are converting from raw to aggregate, switch from 1 byte strings
+ # to numbers
+ my $b = ord $key;
+ $fallback ||= 0;
+ if ($l &&
+ # If this == fails, we're going to reset $agg_max_in below anyway.
+ $b == ++$agg_max_in &&
+ # References in numeric context give the pointer as an int.
+ $agg_next == $next &&
+ $agg_in_len == $in_len &&
+ $agg_out_len == length $out_bytes &&
+ $agg_fallback == $fallback
+ # && length($l->[AGG_OUT_BYTES]) < 16
+ ) {
+ # my $i = ord($b)-ord($l->[AGG_MIN_IN]);
+ # we can aggregate this byte onto the end.
+ $l->[AGG_MAX_IN] = $b;
+ $l->[AGG_OUT_BYTES] .= $out_bytes;
+ } else {
+ # AGG_MIN_IN => 0,
+ # AGG_MAX_IN => 1,
+ # AGG_OUT_BYTES => 2,
+ # AGG_NEXT => 3,
+ # AGG_IN_LEN => 4,
+ # AGG_OUT_LEN => 5,
+ # AGG_FALLBACK => 6,
+ # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
+ # (only gains .6% on euc-jp -- is it worth it?)
+ push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
+ $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
+ $agg_fallback = $fallback];
+ }
+ if (exists $next->{Cname}) {
+ $next->{'Forward'} = 1 if $next != $a;
+ } else {
+ process(sprintf("%s_%02x",$name,$b),$next);
+ }
+ }
+ # encengine.c rules say that last entry must be for 255
+ if ($agg_max_in < 255) {
+ push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
+ }
+ $a->{'Entries'} = \@ent;
+}
+
+
+sub addstrings
+{
+ my ($fh,$a) = @_;
+ my $name = $a->{'Cname'};
+ # String tables
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ next unless $b->[AGG_OUT_LEN];
+ $strings{$b->[AGG_OUT_BYTES]} = undef;
+ }
+ if ($a->{'Forward'})
+ {
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $^O eq 'MacOS' || $cpp ? 'extern' : 'static';
+ my $const = $cpp ? '' : 'const';
+ print $fh "$var $const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
+ }
+ $a->{'DoneStrings'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($s,$e,$out,$t,$end,$l) = @$b;
+ addstrings($fh,$t) unless $t->{'DoneStrings'};
+ }
+}
+
+sub outbigstring
+{
+ my ($fh,$name) = @_;
+
+ $string_acc = '';
+
+ # Make the big string in the string accumulator. Longest first, on the hope
+ # that this makes it more likely that we find the short strings later on.
+ # Not sure if it helps sorting strings of the same length lexcically.
+ foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
+ my $index = index $string_acc, $s;
+ if ($index >= 0) {
+ $saved += length($s);
+ $strings_in_acc{$s} = $index;
+ } else {
+ OPTIMISER: {
+ if ($opt{'O'}) {
+ my $sublength = length $s;
+ while (--$sublength > 0) {
+ # progressively lop characters off the end, to see if the start of
+ # the new string overlaps the end of the accumulator.
+ if (substr ($string_acc, -$sublength)
+ eq substr ($s, 0, $sublength)) {
+ $subsave += $sublength;
+ $strings_in_acc{$s} = length ($string_acc) - $sublength;
+ # append the last bit on the end.
+ $string_acc .= substr ($s, $sublength);
+ last OPTIMISER;
+ }
+ # or if the end of the new string overlaps the start of the
+ # accumulator
+ next unless substr ($string_acc, 0, $sublength)
+ eq substr ($s, -$sublength);
+ # well, the last $sublength characters of the accumulator match.
+ # so as we're prepending to the accumulator, need to shift all our
+ # existing offsets forwards
+ $_ += $sublength foreach values %strings_in_acc;
+ $subsave += $sublength;
+ $strings_in_acc{$s} = 0;
+ # append the first bit on the start.
+ $string_acc = substr ($s, 0, -$sublength) . $string_acc;
+ last OPTIMISER;
+ }
+ }
+ # Optimiser (if it ran) found nothing, so just going have to tack the
+ # whole thing on the end.
+ $strings_in_acc{$s} = length $string_acc;
+ $string_acc .= $s;
+ };
+ }
+ }
+
+ $strings = length $string_acc;
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $cpp ? '' : 'static';
+ my $definition = "\n$var const U8 $name\[$strings] = { " .
+ join(',',unpack "C*",$string_acc);
+ # We have a single long line. Split it at convenient commas.
+ print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
+ print $fh substr ($definition, pos $definition), " };\n";
+}
+
+sub findstring {
+ my ($name,$s) = @_;
+ my $offset = $strings_in_acc{$s};
+ die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
+ unless defined $offset;
+ "$name + $offset";
+}
+
+sub outtable
+{
+ my ($fh,$a,$bigname) = @_;
+ my $name = $a->{'Cname'};
+ $a->{'Done'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($s,$e,$out,$t,$end,$l) = @$b;
+ outtable($fh,$t,$bigname) unless $t->{'Done'};
+ }
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $cpp ? '' : 'static';
+ my $const = $cpp ? '' : 'const';
+ print $fh "\n$var $const encpage_t $name\[",
+ scalar(@{$a->{'Entries'}}), "] = {\n";
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
+ # $end |= 0x80 if $fb; # what the heck was on your mind, Nick? -- Dan
+ print $fh "{";
+ if ($l)
+ {
+ printf $fh findstring($bigname,$out);
+ }
+ else
+ {
+ print $fh "0";
+ }
+ print $fh ",",$t->{Cname};
+ printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
+ }
+ print $fh "};\n";
+}
+
+sub output_enc
+{
+ my ($fh,$name,$a) = @_;
+ die "Changed - fix me for new structure";
+ foreach my $b (sort keys %$a)
+ {
+ my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
+ }
+}
+
+sub decode_U
+{
+ my $s = shift;
+}
+
+my @uname;
+sub char_names
+{
+ my $s = do "unicore/Name.pl";
+ die "char_names: unicore/Name.pl: $!\n" unless defined $s;
+ pos($s) = 0;
+ while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
+ {
+ my $name = $3;
+ my $s = hex($1);
+ last if $s >= 0x10000;
+ my $e = length($2) ? hex($2) : $s;
+ for (my $i = $s; $i <= $e; $i++)
+ {
+ $uname[$i] = $name;
+# print sprintf("U%04X $name\n",$i);
+ }
+ }
+}
+
+sub output_ucm_page
+{
+ my ($cmap,$a,$t,$pre) = @_;
+ # warn sprintf("Page %x\n",$pre);
+ my $raw = $t->{Raw};
+ foreach my $key (sort keys %$raw) {
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+ my $u = ord $key;
+ $fallback ||= 0;
+
+ if ($next != $a && $next != $t) {
+ output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
+ } elsif (length $out_bytes) {
+ if ($pre) {
+ $u = $pre|($u &0x3f);
+ }
+ my $s = sprintf "<U%04X> ",$u;
+ #foreach my $c (split(//,$out_bytes)) {
+ # $s .= sprintf "\\x%02X",ord($c);
+ #}
+ # 9.5% faster changing that loop to this:
+ $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
+ $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
+ push(@$cmap,$s);
+ } else {
+ warn join(',',$u, @{$raw->{$key}},$a,$t);
+ }
+ }
+}
+
+sub output_ucm
+{
+ my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
+ print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
+ print $fh "<code_set_name> \"$name\"\n";
+ char_names();
+ if (defined $min_el)
+ {
+ print $fh "<mb_cur_min> $min_el\n";
+ }
+ if (defined $max_el)
+ {
+ print $fh "<mb_cur_max> $max_el\n";
+ }
+ if (defined $rep)
+ {
+ print $fh "<subchar> ";
+ foreach my $c (split(//,$rep))
+ {
+ printf $fh "\\x%02X",ord($c);
+ }
+ print $fh "\n";
+ }
+ my @cmap;
+ output_ucm_page(\@cmap,$h,$h,0);
+ print $fh "#\nCHARMAP\n";
+ foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
+ {
+ print $fh $line;
+ }
+ print $fh "END CHARMAP\n";
+}
+
+use vars qw(
+ $_Enc2xs
+ $_Version
+ $_Inc
+ $_E2X
+ $_Name
+ $_TableFiles
+ $_Now
+);
+
+sub find_e2x{
+ eval { require File::Find; };
+ my (@inc, %e2x_dir);
+ for my $inc (@INC){
+ push @inc, $inc unless $inc eq '.'; #skip current dir
+ }
+ File::Find::find(
+ sub {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = lstat($_) or return;
+ -f _ or return;
+ if (/^.*\.e2x$/o){
+ no warnings 'once';
+ $e2x_dir{$File::Find::dir} ||= $mtime;
+ }
+ return;
+ }, @inc);
+ warn join("\n", keys %e2x_dir), "\n";
+ for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
+ $_E2X = $d;
+ # warn "$_E2X => ", scalar localtime($e2x_dir{$d});
+ return $_E2X;
+ }
+}
+
+sub make_makefile_pl
+{
+ eval { require Encode; };
+ $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
+ # our used for variable expanstion
+ $_Enc2xs = $0;
+ $_Version = $VERSION;
+ $_E2X = find_e2x();
+ $_Name = shift;
+ $_TableFiles = join(",", map {qq('$_')} @_);
+ $_Now = scalar localtime();
+
+ eval { require File::Spec; };
+ _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
+ _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"), "$_Name.pm");
+ _print_expand(File::Spec->catfile($_E2X,"_T.e2x"), "t/$_Name.t");
+ _print_expand(File::Spec->catfile($_E2X,"README.e2x"), "README");
+ _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"), "Changes");
+ exit;
+}
+
+use vars qw(
+ $_ModLines
+ $_LocalVer
+ );
+
+sub make_configlocal_pm {
+ eval { require Encode; };
+ $@ and die "Unable to require Encode: $@\n";
+ eval { require File::Spec; };
+
+ # our used for variable expanstion
+ my %in_core = map { $_ => 1 } (
+ 'ascii', 'iso-8859-1', 'utf8',
+ 'ascii-ctrl', 'null', 'utf-8-strict'
+ );
+ my %LocalMod = ();
+ # check @enc;
+ use File::Find ();
+ my $wanted = sub{
+ -f $_ or return;
+ $File::Find::name =~ /\A\./ and return;
+ $File::Find::name =~ /\.pm\z/ or return;
+ $File::Find::name =~ m/\bEncode\b/ or return;
+ my $mod = $File::Find::name;
+ $mod =~ s/.*\bEncode\b/Encode/o;
+ $mod =~ s/\.pm\z//o;
+ $mod =~ s,/,::,og;
+ warn qq{ require $mod;\n};
+ eval qq{ require $mod; };
+ $@ and die "Can't require $mod: $@\n";
+ for my $enc ( Encode->encodings() ) {
+ no warnings;
+ $in_core{$enc} and next;
+ $Encode::Config::ExtModule{$enc} and next;
+ $LocalMod{$enc} ||= $mod;
+ }
+ };
+ File::Find::find({wanted => $wanted}, @INC);
+ $_ModLines = "";
+ for my $enc ( sort keys %LocalMod ) {
+ $_ModLines .=
+ qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n);
+ }
+ warn $_ModLines;
+ $_LocalVer = _mkversion();
+ $_E2X = find_e2x();
+ $_Inc = $INC{"Encode.pm"};
+ $_Inc =~ s/\.pm$//o;
+ _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ),
+ File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 );
+ exit;
+}
+
+sub _mkversion{
+ # v-string is now depreciated; use time() instead;
+ #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
+ #$yyyy += 1900, $mo +=1;
+ #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
+ return time();
+}
+
+sub _print_expand{
+ eval { require File::Basename; };
+ $@ and die "File::Basename needed. Are you on miniperl?;\nerror: $@\n";
+ File::Basename->import();
+ my ($src, $dst, $clobber) = @_;
+ if (!$clobber and -e $dst){
+ warn "$dst exists. skipping\n";
+ return;
+ }
+ warn "Generating $dst...\n";
+ open my $in, $src or die "$src : $!";
+ if ((my $d = dirname($dst)) ne '.'){
+ -d $d or mkdir $d, 0755 or die "mkdir $d : $!";
+ }
+ open my $out, ">$dst" or die "$!";
+ my $asis = 0;
+ while (<$in>){
+ if (/^#### END_OF_HEADER/){
+ $asis = 1; next;
+ }
+ s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
+ print $out $_;
+ }
+}
+__END__
+
+=head1 NAME
+
+enc2xs -- Perl Encode Module Generator
+
+=head1 SYNOPSIS
+
+ enc2xs -[options]
+ enc2xs -M ModName mapfiles...
+ enc2xs -C
+
+=head1 DESCRIPTION
+
+F<enc2xs> builds a Perl extension for use by Encode from either
+Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
+Besides being used internally during the build process of the Encode
+module, you can use F<enc2xs> to add your own encoding to perl.
+No knowledge of XS is necessary.
+
+=head1 Quick Guide
+
+If you want to know as little about Perl as possible but need to
+add a new encoding, just read this chapter and forget the rest.
+
+=over 4
+
+=item 0.
+
+Have a .ucm file ready. You can get it from somewhere or you can write
+your own from scratch or you can grab one from the Encode distribution
+and customize it. For the UCM format, see the next Chapter. In the
+example below, I'll call my theoretical encoding myascii, defined
+in I<my.ucm>. C<$> is a shell prompt.
+
+ $ ls -F
+ my.ucm
+
+=item 1.
+
+Issue a command as follows;
+
+ $ enc2xs -M My my.ucm
+ generating Makefile.PL
+ generating My.pm
+ generating README
+ generating Changes
+
+Now take a look at your current directory. It should look like this.
+
+ $ ls -F
+ Makefile.PL My.pm my.ucm t/
+
+The following files were created.
+
+ Makefile.PL - MakeMaker script
+ My.pm - Encode submodule
+ t/My.t - test file
+
+=over 4
+
+=item 1.1.
+
+If you want *.ucm installed together with the modules, do as follows;
+
+ $ mkdir Encode
+ $ mv *.ucm Encode
+ $ enc2xs -M My Encode/*ucm
+
+=back
+
+=item 2.
+
+Edit the files generated. You don't have to if you have no time AND no
+intention to give it to someone else. But it is a good idea to edit
+the pod and to add more tests.
+
+=item 3.
+
+Now issue a command all Perl Mongers love:
+
+ $ perl Makefile.PL
+ Writing Makefile for Encode::My
+
+=item 4.
+
+Now all you have to do is make.
+
+ $ make
+ cp My.pm blib/lib/Encode/My.pm
+ /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
+ -o encode_t.c -f encode_t.fnm
+ Reading myascii (myascii)
+ Writing compiled form
+ 128 bytes in string tables
+ 384 bytes (75%) saved spotting duplicates
+ 1 bytes (0.775%) saved using substrings
+ ....
+ chmod 644 blib/arch/auto/Encode/My/My.bs
+ $
+
+The time it takes varies depending on how fast your machine is and
+how large your encoding is. Unless you are working on something big
+like euc-tw, it won't take too long.
+
+=item 5.
+
+You can "make install" already but you should test first.
+
+ $ make test
+ PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
+ -e 'use Test::Harness qw(&runtests $verbose); \
+ $verbose=0; runtests @ARGV;' t/*.t
+ t/My....ok
+ All tests successful.
+ Files=1, Tests=2, 0 wallclock secs
+ ( 0.09 cusr + 0.01 csys = 0.09 CPU)
+
+=item 6.
+
+If you are content with the test result, just "make install"
+
+=item 7.
+
+If you want to add your encoding to Encode's demand-loading list
+(so you don't have to "use Encode::YourEncoding"), run
+
+ enc2xs -C
+
+to update Encode::ConfigLocal, a module that controls local settings.
+After that, "use Encode;" is enough to load your encodings on demand.
+
+=back
+
+=head1 The Unicode Character Map
+
+Encode uses the Unicode Character Map (UCM) format for source character
+mappings. This format is used by IBM's ICU package and was adopted
+by Nick Ing-Simmons for use with the Encode module. Since UCM is
+more flexible than Tcl's Encoding Map and far more user-friendly,
+this is the recommended format for Encode now.
+
+A UCM file looks like this.
+
+ #
+ # Comments
+ #
+ <code_set_name> "US-ascii" # Required
+ <code_set_alias> "ascii" # Optional
+ <mb_cur_min> 1 # Required; usually 1
+ <mb_cur_max> 1 # Max. # of bytes/char
+ <subchar> \x3F # Substitution char
+ #
+ CHARMAP
+ <U0000> \x00 |0 # <control>
+ <U0001> \x01 |0 # <control>
+ <U0002> \x02 |0 # <control>
+ ....
+ <U007C> \x7C |0 # VERTICAL LINE
+ <U007D> \x7D |0 # RIGHT CURLY BRACKET
+ <U007E> \x7E |0 # TILDE
+ <U007F> \x7F |0 # <control>
+ END CHARMAP
+
+=over 4
+
+=item *
+
+Anything that follows C<#> is treated as a comment.
+
+=item *
+
+The header section continues until a line containing the word
+CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
+pair per line. Strings used as values must be quoted. Barewords are
+treated as numbers. I<\xXX> represents a byte.
+
+Most of the keywords are self-explanatory. I<subchar> means
+substitution character, not subcharacter. When you decode a Unicode
+sequence to this encoding but no matching character is found, the byte
+sequence defined here will be used. For most cases, the value here is
+\x3F; in ASCII, this is a question mark.
+
+=item *
+
+CHARMAP starts the character map section. Each line has a form as
+follows:
+
+ <UXXXX> \xXX.. |0 # comment
+ ^ ^ ^
+ | | +- Fallback flag
+ | +-------- Encoded byte sequence
+ +-------------- Unicode Character ID in hex
+
+The format is roughly the same as a header section except for the
+fallback flag: | followed by 0..3. The meaning of the possible
+values is as follows:
+
+=over 4
+
+=item |0
+
+Round trip safe. A character decoded to Unicode encodes back to the
+same byte sequence. Most characters have this flag.
+
+=item |1
+
+Fallback for unicode -> encoding. When seen, enc2xs adds this
+character for the encode map only.
+
+=item |2
+
+Skip sub-char mapping should there be no code point.
+
+=item |3
+
+Fallback for encoding -> unicode. When seen, enc2xs adds this
+character for the decode map only.
+
+=back
+
+=item *
+
+And finally, END OF CHARMAP ends the section.
+
+=back
+
+When you are manually creating a UCM file, you should copy ascii.ucm
+or an existing encoding which is close to yours, rather than write
+your own from scratch.
+
+When you do so, make sure you leave at least B<U0000> to B<U0020> as
+is, unless your environment is EBCDIC.
+
+B<CAVEAT>: not all features in UCM are implemented. For example,
+icu:state is not used. Because of that, you need to write a perl
+module if you want to support algorithmical encodings, notably
+the ISO-2022 series. Such modules include L<Encode::JP::2022_JP>,
+L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
+
+=head2 Coping with duplicate mappings
+
+When you create a map, you SHOULD make your mappings round-trip safe.
+That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
+$data> stands for all characters that are marked as C<|0>. Here is
+how to make sure:
+
+=over 4
+
+=item *
+
+Sort your map in Unicode order.
+
+=item *
+
+When you have a duplicate entry, mark either one with '|1' or '|3'.
+
+=item *
+
+And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
+
+=back
+
+Here is an example from big5-eten.
+
+ <U2550> \xF9\xF9 |0
+ <U2550> \xA2\xA4 |3
+
+Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
+this;
+
+ E to U U to E
+ --------------------------------------
+ \xF9\xF9 => U2550 U2550 => \xF9\xF9
+ \xA2\xA4 => U2550
+
+So it is round-trip safe for \xF9\xF9. But if the line above is upside
+down, here is what happens.
+
+ E to U U to E
+ --------------------------------------
+ \xA2\xA4 => U2550 U2550 => \xF9\xF9
+ (\xF9\xF9 => U2550 is now overwritten!)
+
+The Encode package comes with F<ucmlint>, a crude but sufficient
+utility to check the integrity of a UCM file. Check under the
+Encode/bin directory for this.
+
+When in doubt, you can use F<ucmsort>, yet another utility under
+Encode/bin directory.
+
+=head1 Bookmarks
+
+=over 4
+
+=item *
+
+ICU Home Page
+L<http://www.icu-project.org/>
+
+=item *
+
+ICU Character Mapping Tables
+L<http://site.icu-project.org/charts/charset>
+
+=item *
+
+ICU:Conversion Data
+L<http://www.icu-project.org/userguide/conversion-data.html>
+
+=back
+
+=head1 SEE ALSO
+
+L<Encode>,
+L<perlmod>,
+L<perlpod>
+
+=cut
+
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+
+With %seen holding array refs:
+
+ 865.66 real 28.80 user 8.79 sys
+ 7904 maximum resident set size
+ 1356 average shared memory size
+ 18566 average unshared data size
+ 229 average unshared stack size
+ 46080 page reclaims
+ 33373 page faults
+
+With %seen holding simple scalars:
+
+ 342.16 real 27.11 user 3.54 sys
+ 8388 maximum resident set size
+ 1394 average shared memory size
+ 14969 average unshared data size
+ 236 average unshared stack size
+ 28159 page reclaims
+ 9839 page faults
+
+Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
+how %seen is storing things its seen. So it is pathalogically bad on a 16M
+RAM machine, but it's going to help even on modern machines.
+Swapping is bad, m'kay :-)
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/exe_update.bat b/Master/tlpkg/tlperl.straw/bin/exe_update.bat
new file mode 100755
index 00000000000..5c3ab156379
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/exe_update.bat
@@ -0,0 +1,114 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl
+#line 15
+# $File: //member/autrijus/Win32-Exe/script/exe_update.pl $ $Author: autrijus $
+# $Revision: #1 $ $Change: 9927 $ $DateTime: 2004/02/06 19:31:24 $
+
+use strict;
+use File::Basename;
+use Win32::Exe;
+use Getopt::Long;
+
+=head1 NAME
+
+exe_update.pl - Modify windows executable files
+
+=head1 SYNOPSIS
+
+B<exe_update.pl> S<[ B<--gui> | B<--console> ]> S<[ B<--icon> I<iconfile> ]>
+ S<[ B<--info> I<key=value;...> ]> I<exefile>
+
+=head1 DESCRIPTION
+
+This program rewrites PE headers in a Windows executable file. It can
+change whether the executable runs with a console window, as well as
+setting the icons and version information associated with it.
+
+=head1 OPTIONS
+
+Options are available in a I<short> form and a I<long> form. For
+example, the three lines below are all equivalent:
+
+ % exe_update.pl -i new.ico input.exe
+ % exe_update.pl --icon new.ico input.exe
+ % exe_update.pl --icon=new.ico input.exe
+
+=over 4
+
+=item B<-c>, B<--console>
+
+Set the executable to always display a console window.
+
+=item B<-g>, B<--gui>
+
+Set the executable so it does not have a console window.
+
+=item B<-i>, B<--icon>=I<FILE>
+
+Specify an icon file (in F<.ico>, F<.exe> or F<.dll> format) for the
+executable.
+
+=item B<-N>, B<--info>=I<KEY=VAL>
+
+Attach version information for the executable. The name/value pair is
+joined by C<=>. You may specify C<-N> multiple times, or use C<;> to
+link several pairs.
+
+These special C<KEY> names are recognized:
+
+ Comments CompanyName FileDescription FileVersion
+ InternalName LegalCopyright LegalTrademarks OriginalFilename
+ ProductName ProductVersion
+
+=back
+
+=cut
+
+my $Options = {};
+Getopt::Long::GetOptions( $Options,
+ 'g|gui', # No console window
+ 'c|console', # Use console window
+ 'i|icon:s', # Icon file
+ 'N|info:s@', # Executable header info
+);
+
+my $exe = shift or die "Usage: " . basename($0) .
+ " [--gui | --console] [--icon file.ico] [--info key=value] file.exe\n";
+
+Win32::Exe->new($exe)->update(
+ gui => $Options->{g},
+ console => $Options->{c},
+ icon => $Options->{i},
+ info => $Options->{N},
+) or die "Update of $exe failed!\n";
+
+__END__
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/exe_update.pl b/Master/tlpkg/tlperl.straw/bin/exe_update.pl
new file mode 100755
index 00000000000..dc43251ebff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/exe_update.pl
@@ -0,0 +1,98 @@
+#!/usr/local/bin/perl
+# $File: //member/autrijus/Win32-Exe/script/exe_update.pl $ $Author: autrijus $
+# $Revision: #1 $ $Change: 9927 $ $DateTime: 2004/02/06 19:31:24 $
+
+use strict;
+use File::Basename;
+use Win32::Exe;
+use Getopt::Long;
+
+=head1 NAME
+
+exe_update.pl - Modify windows executable files
+
+=head1 SYNOPSIS
+
+B<exe_update.pl> S<[ B<--gui> | B<--console> ]> S<[ B<--icon> I<iconfile> ]>
+ S<[ B<--info> I<key=value;...> ]> I<exefile>
+
+=head1 DESCRIPTION
+
+This program rewrites PE headers in a Windows executable file. It can
+change whether the executable runs with a console window, as well as
+setting the icons and version information associated with it.
+
+=head1 OPTIONS
+
+Options are available in a I<short> form and a I<long> form. For
+example, the three lines below are all equivalent:
+
+ % exe_update.pl -i new.ico input.exe
+ % exe_update.pl --icon new.ico input.exe
+ % exe_update.pl --icon=new.ico input.exe
+
+=over 4
+
+=item B<-c>, B<--console>
+
+Set the executable to always display a console window.
+
+=item B<-g>, B<--gui>
+
+Set the executable so it does not have a console window.
+
+=item B<-i>, B<--icon>=I<FILE>
+
+Specify an icon file (in F<.ico>, F<.exe> or F<.dll> format) for the
+executable.
+
+=item B<-N>, B<--info>=I<KEY=VAL>
+
+Attach version information for the executable. The name/value pair is
+joined by C<=>. You may specify C<-N> multiple times, or use C<;> to
+link several pairs.
+
+These special C<KEY> names are recognized:
+
+ Comments CompanyName FileDescription FileVersion
+ InternalName LegalCopyright LegalTrademarks OriginalFilename
+ ProductName ProductVersion
+
+=back
+
+=cut
+
+my $Options = {};
+Getopt::Long::GetOptions( $Options,
+ 'g|gui', # No console window
+ 'c|console', # Use console window
+ 'i|icon:s', # Icon file
+ 'N|info:s@', # Executable header info
+);
+
+my $exe = shift or die "Usage: " . basename($0) .
+ " [--gui | --console] [--icon file.ico] [--info key=value] file.exe\n";
+
+Win32::Exe->new($exe)->update(
+ gui => $Options->{g},
+ console => $Options->{c},
+ icon => $Options->{i},
+ info => $Options->{N},
+) or die "Update of $exe failed!\n";
+
+__END__
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/exetype.bat b/Master/tlpkg/tlperl.straw/bin/exetype.bat
new file mode 100755
index 00000000000..90e84330756
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/exetype.bat
@@ -0,0 +1,124 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use strict;
+
+# All the IMAGE_* structures are defined in the WINNT.H file
+# of the Microsoft Platform SDK.
+
+my %subsys = (NATIVE => 1,
+ WINDOWS => 2,
+ CONSOLE => 3,
+ POSIX => 7,
+ WINDOWSCE => 9);
+
+unless (0 < @ARGV && @ARGV < 3) {
+ printf "Usage: $0 exefile [%s]\n", join '|', sort keys %subsys;
+ exit;
+}
+
+$ARGV[1] = uc $ARGV[1] if $ARGV[1];
+unless (@ARGV == 1 || defined $subsys{$ARGV[1]}) {
+ (my $subsys = join(', ', sort keys %subsys)) =~ s/, (\w+)$/ or $1/;
+ print "Invalid subsystem $ARGV[1], please use $subsys\n";
+ exit;
+}
+
+my ($record,$magic,$signature,$offset,$size);
+open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!\n";
+binmode EXE;
+
+# read IMAGE_DOS_HEADER structure
+read EXE, $record, 64;
+($magic,$offset) = unpack "Sx58L", $record;
+
+die "$ARGV[0] is not an MSDOS executable file.\n"
+ unless $magic == 0x5a4d; # "MZ"
+
+# read signature, IMAGE_FILE_HEADER and first WORD of IMAGE_OPTIONAL_HEADER
+seek EXE, $offset, 0;
+read EXE, $record, 4+20+2;
+($signature,$size,$magic) = unpack "Lx16Sx2S", $record;
+
+die "PE header not found" unless $signature == 0x4550; # "PE\0\0"
+
+die "Optional header is neither in NT32 nor in NT64 format"
+ unless ($size == 224 && $magic == 0x10b) || # IMAGE_NT_OPTIONAL_HDR32_MAGIC
+ ($size == 240 && $magic == 0x20b); # IMAGE_NT_OPTIONAL_HDR64_MAGIC
+
+# Offset 68 in the IMAGE_OPTIONAL_HEADER(32|64) is the 16 bit subsystem code
+seek EXE, $offset+4+20+68, 0;
+if (@ARGV == 1) {
+ read EXE, $record, 2;
+ my ($subsys) = unpack "S", $record;
+ $subsys = {reverse %subsys}->{$subsys} || "UNKNOWN($subsys)";
+ print "$ARGV[0] uses the $subsys subsystem.\n";
+}
+else {
+ print EXE pack "S", $subsys{$ARGV[1]};
+}
+close EXE;
+__END__
+
+=head1 NAME
+
+exetype - Change executable subsystem type between "Console" and "Windows"
+
+=head1 SYNOPSIS
+
+ C:\perl\bin> copy perl.exe guiperl.exe
+ C:\perl\bin> exetype guiperl.exe windows
+
+=head1 DESCRIPTION
+
+This program edits an executable file to indicate which subsystem the
+operating system must invoke for execution.
+
+You can specify any of the following subsystems:
+
+=over
+
+=item CONSOLE
+
+The CONSOLE subsystem handles a Win32 character-mode application that
+use a console supplied by the operating system.
+
+=item WINDOWS
+
+The WINDOWS subsystem handles an application that does not require a
+console and creates its own windows, if required.
+
+=item NATIVE
+
+The NATIVE subsystem handles a Windows NT device driver.
+
+=item WINDOWSCE
+
+The WINDOWSCE subsystem handles Windows CE consumer electronics
+applications.
+
+=item POSIX
+
+The POSIX subsystem handles a POSIX application in Windows NT.
+
+=back
+
+=head1 AUTHOR
+
+Jan Dubois <jand@activestate.com>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/find2perl.bat b/Master/tlpkg/tlperl.straw/bin/find2perl.bat
new file mode 100755
index 00000000000..208ed40e9e7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/find2perl.bat
@@ -0,0 +1,895 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+(my $perlpath = <<'/../') =~ s/\s*\z//;
+C:\strawberry\perl\bin\perl.exe
+/../
+use strict;
+use vars qw/$statdone/;
+use File::Spec::Functions 'curdir';
+my $startperl = "#! $perlpath -w";
+
+sub tab ();
+sub n ($$);
+sub fileglob_to_re ($);
+sub quote ($);
+
+my @roots = ();
+while ($ARGV[0] =~ /^[^-!(]/) {
+ push(@roots, shift);
+}
+@roots = (curdir()) unless @roots;
+for (@roots) { $_ = quote($_) }
+my $roots = join(', ', @roots);
+
+my $find = "find";
+my $indent_depth = 1;
+my $stat = 'lstat';
+my $decl = '';
+my $flushall = '';
+my $initfile = '';
+my $initnewer = '';
+my $out = '';
+my $declaresubs = "sub wanted;\n";
+my %init = ();
+my ($follow_in_effect,$Skip_And) = (0,0);
+my $print_needed = 1;
+
+while (@ARGV) {
+ $_ = shift;
+ s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
+ if ($_ eq '(') {
+ $out .= tab . "(\n";
+ $indent_depth++;
+ next;
+ } elsif ($_ eq ')') {
+ --$indent_depth;
+ $out .= tab . ")";
+ } elsif ($_ eq 'follow') {
+ $follow_in_effect= 1;
+ $stat = 'stat';
+ $Skip_And= 1;
+ } elsif ($_ eq '!') {
+ $out .= tab . "!";
+ next;
+ } elsif (/^(i)?name$/) {
+ $out .= tab . '/' . fileglob_to_re(shift) . "/s$1";
+ } elsif (/^(i)?path$/) {
+ $out .= tab . '$File::Find::name =~ /' . fileglob_to_re(shift) . "/s$1";
+ } elsif ($_ eq 'perm') {
+ my $onum = shift;
+ $onum =~ /^-?[0-7]+$/
+ || die "Malformed -perm argument: $onum\n";
+ $out .= tab;
+ if ($onum =~ s/^-//) {
+ $onum = sprintf("0%o", oct($onum) & 07777);
+ $out .= "((\$mode & $onum) == $onum)";
+ } else {
+ $onum =~ s/^0*/0/;
+ $out .= "((\$mode & 0777) == $onum)";
+ }
+ } elsif ($_ eq 'type') {
+ (my $filetest = shift) =~ tr/s/S/;
+ $out .= tab . "-$filetest _";
+ } elsif ($_ eq 'print') {
+ $out .= tab . 'print("$name\n")';
+ $print_needed = 0;
+ } elsif ($_ eq 'print0') {
+ $out .= tab . 'print("$name\0")';
+ $print_needed = 0;
+ } elsif ($_ eq 'fstype') {
+ my $type = shift;
+ $out .= tab;
+ if ($type eq 'nfs') {
+ $out .= '($dev < 0)';
+ } else {
+ $out .= '($dev >= 0)'; #XXX
+ }
+ } elsif ($_ eq 'user') {
+ my $uname = shift;
+ $out .= tab . "(\$uid == \$uid{'$uname'})";
+ $init{user} = 1;
+ } elsif ($_ eq 'group') {
+ my $gname = shift;
+ $out .= tab . "(\$gid == \$gid{'$gname'})";
+ $init{group} = 1;
+ } elsif ($_ eq 'nouser') {
+ $out .= tab . '!exists $uid{$uid}';
+ $init{user} = 1;
+ } elsif ($_ eq 'nogroup') {
+ $out .= tab . '!exists $gid{$gid}';
+ $init{group} = 1;
+ } elsif ($_ eq 'links') {
+ $out .= tab . n('$nlink', shift);
+ } elsif ($_ eq 'inum') {
+ $out .= tab . n('$ino', shift);
+ } elsif ($_ eq 'size') {
+ $_ = shift;
+ my $n = 'int(((-s _) + 511) / 512)';
+ if (s/c\z//) {
+ $n = 'int(-s _)';
+ } elsif (s/k\z//) {
+ $n = 'int(((-s _) + 1023) / 1024)';
+ }
+ $out .= tab . n($n, $_);
+ } elsif ($_ eq 'atime') {
+ $out .= tab . n('int(-A _)', shift);
+ } elsif ($_ eq 'mtime') {
+ $out .= tab . n('int(-M _)', shift);
+ } elsif ($_ eq 'ctime') {
+ $out .= tab . n('int(-C _)', shift);
+ } elsif ($_ eq 'exec') {
+ my @cmd = ();
+ while (@ARGV && $ARGV[0] ne ';')
+ { push(@cmd, shift) }
+ shift;
+ $out .= tab;
+ if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
+ && $cmd[$#cmd] eq '{}'
+ && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
+ if (@cmd == 2) {
+ $out .= '(unlink($_) || warn "$name: $!\n")';
+ } elsif (!@ARGV) {
+ $out .= 'unlink($_)';
+ } else {
+ $out .= '(unlink($_) || 1)';
+ }
+ } else {
+ for (@cmd)
+ { s/'/\\'/g }
+ { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
+ $declaresubs .= "sub doexec (\$\@);\n";
+ $init{doexec} = 1;
+ }
+ $print_needed = 0;
+ } elsif ($_ eq 'ok') {
+ my @cmd = ();
+ while (@ARGV && $ARGV[0] ne ';')
+ { push(@cmd, shift) }
+ shift;
+ $out .= tab;
+ for (@cmd)
+ { s/'/\\'/g }
+ { local $" = "','"; $out .= "doexec(1, '@cmd')"; }
+ $declaresubs .= "sub doexec (\$\@);\n";
+ $init{doexec} = 1;
+ $print_needed = 0;
+ } elsif ($_ eq 'prune') {
+ $out .= tab . '($File::Find::prune = 1)';
+ } elsif ($_ eq 'xdev') {
+ $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
+;
+ } elsif ($_ eq 'newer') {
+ my $file = shift;
+ my $newername = 'AGE_OF' . $file;
+ $newername =~ s/\W/_/g;
+ $newername = '$' . $newername;
+ $out .= tab . "(-M _ < $newername)";
+ $initnewer .= "my $newername = -M " . quote($file) . ";\n";
+ } elsif ($_ eq 'eval') {
+ my $prog = shift;
+ $prog =~ s/'/\\'/g;
+ $out .= tab . "eval {$prog}";
+ $print_needed = 0;
+ } elsif ($_ eq 'depth') {
+ $find = 'finddepth';
+ next;
+ } elsif ($_ eq 'ls') {
+ $out .= tab . "ls";
+ $declaresubs .= "sub ls ();\n";
+ $init{ls} = 1;
+ $print_needed = 0;
+ } elsif ($_ eq 'tar') {
+ die "-tar must have a filename argument\n" unless @ARGV;
+ my $file = shift;
+ my $fh = 'FH' . $file;
+ $fh =~ s/\W/_/g;
+ $out .= tab . "tar(*$fh, \$name)";
+ $flushall .= "tflushall;\n";
+ $declaresubs .= "sub tar;\nsub tflushall ();\n";
+ $initfile .= "open($fh, " . quote('> ' . $file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $init{tar} = 1;
+ } elsif (/^(n?)cpio\z/) {
+ die "-$_ must have a filename argument\n" unless @ARGV;
+ my $file = shift;
+ my $fh = 'FH' . $file;
+ $fh =~ s/\W/_/g;
+ $out .= tab . "cpio(*$fh, \$name, '$1')";
+ $find = 'finddepth';
+ $flushall .= "cflushall;\n";
+ $declaresubs .= "sub cpio;\nsub cflushall ();\n";
+ $initfile .= "open($fh, " . quote('> ' . $file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $init{cpio} = 1;
+ } else {
+ die "Unrecognized switch: -$_\n";
+ }
+
+ if (@ARGV) {
+ if ($ARGV[0] eq '-o') {
+ { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
+ $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
+ $init{saw_or} = 1;
+ shift;
+ } else {
+ $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
+ $out .= "\n";
+ shift if $ARGV[0] eq '-a';
+ }
+ }
+}
+
+if ($print_needed) {
+ my $t = tab;
+ if ($t !~ /&&\s*$/) { $t .= '&& ' }
+ $out .= "\n" . $t . 'print("$name\n")';
+}
+
+
+print <<"END";
+$startperl
+ eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if 0; #\$running_under_some_shell
+
+use strict;
+use File::Find ();
+
+# Set the variable \$File::Find::dont_use_nlink if you're using AFS,
+# since AFS cheats.
+
+# for the convenience of &wanted calls, including -eval statements:
+use vars qw/*name *dir *prune/;
+*name = *File::Find::name;
+*dir = *File::Find::dir;
+*prune = *File::Find::prune;
+
+$declaresubs
+
+END
+
+if (exists $init{doexec}) {
+ print <<'END';
+use Cwd ();
+my $cwd = Cwd::cwd();
+
+END
+}
+
+if (exists $init{ls}) {
+ print <<'END';
+my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
+my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+
+END
+}
+
+if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
+ print "my (%uid, %user);\n";
+ print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
+ print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
+ if exists $init{user};
+ print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
+ if exists $init{ls} || exists $init{tar};
+ print "}\n\n";
+}
+
+if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
+ print "my (%gid, %group);\n";
+ print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
+ print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
+ if exists $init{group};
+ print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
+ if exists $init{ls} || exists $init{tar};
+ print "}\n\n";
+}
+
+print $initnewer, "\n" if $initnewer ne '';
+print $initfile, "\n" if $initfile ne '';
+$flushall .= "exit;\n";
+if (exists $init{declarestat}) {
+ $out = <<'END' . $out;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid);
+
+END
+}
+
+if ( $follow_in_effect ) {
+$out =~ s/lstat\(\$_\)/lstat(_)/;
+print <<"END";
+$decl
+# Traverse desired filesystems
+File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
+$flushall
+
+sub wanted {
+$out;
+}
+
+END
+} else {
+print <<"END";
+$decl
+# Traverse desired filesystems
+File::Find::$find({wanted => \\&wanted}, $roots);
+$flushall
+
+sub wanted {
+$out;
+}
+
+END
+}
+
+if (exists $init{doexec}) {
+ print <<'END';
+
+sub doexec ($@) {
+ my $ok = shift;
+ my @command = @_; # copy so we don't try to s/// aliases to constants
+ for my $word (@command)
+ { $word =~ s#{}#$name#g }
+ if ($ok) {
+ my $old = select(STDOUT);
+ $| = 1;
+ print "@command";
+ select($old);
+ return 0 unless <STDIN> =~ /^y/;
+ }
+ chdir $cwd; #sigh
+ system @command;
+ chdir $File::Find::dir;
+ return !$?;
+}
+
+END
+}
+
+if (exists $init{ls}) {
+ print <<'INTRO', <<"SUB", <<'END';
+
+sub sizemm {
+ my $rdev = shift;
+ sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
+}
+
+sub ls () {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+ my $pname = $name;
+
+ $blocks
+ or $blocks = int(($size + 1023) / 1024);
+
+ my $perms = $rwx[$mode & 7];
+ $mode >>= 3;
+ $perms = $rwx[$mode & 7] . $perms;
+ $mode >>= 3;
+ $perms = $rwx[$mode & 7] . $perms;
+ substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
+ substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
+ substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
+ if (-f _) { $perms = '-' . $perms; }
+ elsif (-d _) { $perms = 'd' . $perms; }
+ elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
+ elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
+ elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
+ elsif (-p _) { $perms = 'p' . $perms; }
+ elsif (-S _) { $perms = 's' . $perms; }
+ else { $perms = '?' . $perms; }
+
+ my $user = $user{$uid} || $uid;
+ my $group = $group{$gid} || $gid;
+
+ my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
+ if (-M _ > 365.25 / 2) {
+ $timeyear += 1900;
+ } else {
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
+ }
+
+ printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $size,
+ $moname[$mon],
+ $mday,
+ $timeyear,
+ $pname;
+ 1;
+}
+
+END
+}
+
+
+if (exists $init{cpio} || exists $init{tar}) {
+print <<'END';
+
+my %blocks = ();
+
+sub flush {
+ my ($fh, $varref, $blksz) = @_;
+
+ while (length($$varref) >= $blksz) {
+ no strict qw/refs/;
+ syswrite($fh, $$varref, $blksz);
+ substr($$varref, 0, $blksz) = '';
+ ++$blocks{$fh};
+ }
+}
+
+END
+}
+
+
+if (exists $init{cpio}) {
+ print <<'INTRO', <<"SUB", <<'END';
+
+my %cpout = ();
+my %nc = ();
+
+sub cpio {
+ my ($fh, $fname, $nc) = @_;
+ my $text = '';
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks);
+ local (*IN);
+
+ if ( ! defined $fname ) {
+ $fname = 'TRAILER!!!';
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
+ } else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $fname: $!\n";
+ return;
+ }
+ } else {
+ $text = readlink($_);
+ $size = 0 unless defined $text;
+ }
+ }
+
+ $fname =~ s#^\./##;
+ $nc{$fh} = $nc;
+ if ($nc eq 'n') {
+ $cpout{$fh} .=
+ sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
+ 070707,
+ $dev & 0777777,
+ $ino & 0777777,
+ $mode & 0777777,
+ $uid & 0777777,
+ $gid & 0777777,
+ $nlink & 0777777,
+ $rdev & 0177777,
+ $mtime,
+ length($fname)+1,
+ $size,
+ $fname);
+ } else {
+ $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
+ $cpout{$fh} .= pack("SSSSSSSSLSLa*",
+ 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
+ length($fname)+1, $size,
+ $fname . (length($fname) & 1 ? "\0" : "\0\0"));
+ }
+
+ if ($text ne '') {
+ $cpout{$fh} .= $text;
+ } elsif ($size) {
+ my $l;
+ flush($fh, \$cpout{$fh}, 5120)
+ while ($l = length($cpout{$fh})) >= 5120;
+ while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
+ flush($fh, \$cpout{$fh}, 5120);
+ $l = length($cpout{$fh});
+ }
+ close IN;
+ }
+}
+
+sub cflushall () {
+ for my $fh (keys %cpout) {
+ cpio($fh, undef, $nc{$fh});
+ $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
+ flush($fh, \$cpout{$fh}, 5120);
+ print $blocks{$fh} * 10, " blocks\n";
+ }
+}
+
+END
+}
+
+if (exists $init{tar}) {
+ print <<'INTRO', <<"SUB", <<'END';
+
+my %tarout = ();
+my %linkseen = ();
+
+sub tar {
+ my ($fh, $fname) = @_;
+ my $prefix = '';
+ my $typeflag = '0';
+ my $linkname;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+ local (*IN);
+
+ if ($nlink > 1) {
+ if ($linkname = $linkseen{$fh, $dev, $ino}) {
+ if (length($linkname) > 100) {
+ warn "$0: omitting file with linkname ",
+ "too long for tar output: $linkname\n";
+ return;
+ }
+ $typeflag = '1';
+ $size = 0;
+ } else {
+ $linkseen{$fh, $dev, $ino} = $fname;
+ }
+ }
+ if ($typeflag eq '0') {
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $fname: $!\n";
+ return;
+ }
+ } else {
+ $linkname = readlink($_);
+ if (defined $linkname) { $typeflag = '2' }
+ elsif (-c _) { $typeflag = '3' }
+ elsif (-b _) { $typeflag = '4' }
+ elsif (-d _) { $typeflag = '5' }
+ elsif (-p _) { $typeflag = '6' }
+ }
+ }
+
+ if (length($fname) > 100) {
+ ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
+ if (!defined($fname) || length($prefix) > 155) {
+ warn "$0: omitting file with name too long for tar output: ",
+ $fname, "\n";
+ return;
+ }
+ }
+
+ $size = 0 if $typeflag ne '0';
+ my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
+ $fname,
+ sprintf("%7o ", $mode & 0777),
+ sprintf("%7o ", $uid & 0777777),
+ sprintf("%7o ", $gid & 0777777),
+ sprintf("%11o ", $size),
+ sprintf("%11o ", $mtime),
+ ' 'x8,
+ $typeflag,
+ defined $linkname ? $linkname : '',
+ "ustar\0",
+ "00",
+ $user{$uid},
+ $group{$gid},
+ ($rdev >> 8) & 0xff,
+ $rdev & 0xff,
+ $prefix,
+ );
+ substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
+ my $l = length($header) % 512;
+ $tarout{$fh} .= $header;
+ $tarout{$fh} .= "\0" x (512 - $l) if $l;
+
+ if ($size) {
+ flush($fh, \$tarout{$fh}, 10240)
+ while ($l = length($tarout{$fh})) >= 10240;
+ while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
+ my $slop = length($tarout{$fh}) % 512;
+ $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
+ flush($fh, \$tarout{$fh}, 10240);
+ $l = length($tarout{$fh});
+ }
+ close IN;
+ }
+}
+
+sub tflushall () {
+ my $len;
+ for my $fh (keys %tarout) {
+ $len = 10240 - length($tarout{$fh});
+ $len += 10240 if $len < 1024;
+ $tarout{$fh} .= "\0" x $len;
+ flush($fh, \$tarout{$fh}, 10240);
+ }
+}
+
+END
+}
+
+exit;
+
+############################################################################
+
+sub tab () {
+ my $tabstring;
+
+ $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
+ if (!$statdone) {
+ if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
+ $init{delayedstat} = 1;
+ } else {
+ my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
+ . $stat . '($_))';
+ if (exists $init{saw_or}) {
+ $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
+ } else {
+ $tabstring .= "$statcall &&\n" . $tabstring;
+ }
+ $statdone = 1;
+ $init{declarestat} = 1;
+ }
+ }
+ $tabstring =~ s/^\s+/ / if $out =~ /!$/;
+ $tabstring;
+}
+
+sub fileglob_to_re ($) {
+ my $x = shift;
+ $x =~ s#([./^\$()+])#\\$1#g;
+ $x =~ s#([?*])#.$1#g;
+ "^$x\\z";
+}
+
+sub n ($$) {
+ my ($pre, $n) = @_;
+ $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
+ $n =~ s/ 0*(\d)/ $1/;
+ "($pre $n)";
+}
+
+sub quote ($) {
+ my $string = shift;
+ $string =~ s/\\/\\\\/g;
+ $string =~ s/'/\\'/g;
+ "'$string'";
+}
+
+__END__
+
+=head1 NAME
+
+find2perl - translate find command lines to Perl code
+
+=head1 SYNOPSIS
+
+ find2perl [paths] [predicates] | perl
+
+=head1 DESCRIPTION
+
+find2perl is a little translator to convert find command lines to
+equivalent Perl code. The resulting code is typically faster than
+running find itself.
+
+"paths" are a set of paths where find2perl will start its searches and
+"predicates" are taken from the following list.
+
+=over 4
+
+=item C<! PREDICATE>
+
+Negate the sense of the following predicate. The C<!> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<( PREDICATES )>
+
+Group the given PREDICATES. The parentheses must be passed as distinct
+arguments, so they may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<PREDICATE1 PREDICATE2>
+
+True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
+evaluated if PREDICATE1 is false.
+
+=item C<PREDICATE1 -o PREDICATE2>
+
+True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
+not evaluated if PREDICATE1 is true.
+
+=item C<-follow>
+
+Follow (dereference) symlinks. The checking of file attributes depends
+on the position of the C<-follow> option. If it precedes the file
+check option, an C<stat> is done which means the file check applies to the
+file the symbolic link is pointing to. If C<-follow> option follows the
+file check option, this now applies to the symbolic link itself, i.e.
+an C<lstat> is done.
+
+=item C<-depth>
+
+Change directory traversal algorithm from breadth-first to depth-first.
+
+=item C<-prune>
+
+Do not descend into the directory currently matched.
+
+=item C<-xdev>
+
+Do not traverse mount points (prunes search at mount-point directories).
+
+=item C<-name GLOB>
+
+File name matches specified GLOB wildcard pattern. GLOB may need to be
+quoted to avoid interpretation by the shell (just as with using
+C<find(1)>).
+
+=item C<-iname GLOB>
+
+Like C<-name>, but the match is case insensitive.
+
+=item C<-path GLOB>
+
+Path name matches specified GLOB wildcard pattern.
+
+=item C<-ipath GLOB>
+
+Like C<-path>, but the match is case insensitive.
+
+=item C<-perm PERM>
+
+Low-order 9 bits of permission match octal value PERM.
+
+=item C<-perm -PERM>
+
+The bits specified in PERM are all set in file's permissions.
+
+=item C<-type X>
+
+The file's type matches perl's C<-X> operator.
+
+=item C<-fstype TYPE>
+
+Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
+is implemented).
+
+=item C<-user USER>
+
+True if USER is owner of file.
+
+=item C<-group GROUP>
+
+True if file's group is GROUP.
+
+=item C<-nouser>
+
+True if file's owner is not in password database.
+
+=item C<-nogroup>
+
+True if file's group is not in group database.
+
+=item C<-inum INUM>
+
+True file's inode number is INUM.
+
+=item C<-links N>
+
+True if (hard) link count of file matches N (see below).
+
+=item C<-size N>
+
+True if file's size matches N (see below) N is normally counted in
+512-byte blocks, but a suffix of "c" specifies that size should be
+counted in characters (bytes) and a suffix of "k" specifies that
+size should be counted in 1024-byte blocks.
+
+=item C<-atime N>
+
+True if last-access time of file matches N (measured in days) (see
+below).
+
+=item C<-ctime N>
+
+True if last-changed time of file's inode matches N (measured in days,
+see below).
+
+=item C<-mtime N>
+
+True if last-modified time of file matches N (measured in days, see below).
+
+=item C<-newer FILE>
+
+True if last-modified time of file matches N.
+
+=item C<-print>
+
+Print out path of file (always true). If none of C<-exec>, C<-ls>,
+C<-print0>, or C<-ok> is specified, then C<-print> will be added
+implicitly.
+
+=item C<-print0>
+
+Like -print, but terminates with \0 instead of \n.
+
+=item C<-exec OPTIONS ;>
+
+exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
+OPTIONS will first be substituted with the path of the current
+file. Note that the command "rm" has been special-cased to use perl's
+unlink() function instead (as an optimization). The C<;> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<-ok OPTIONS ;>
+
+Like -exec, but first prompts user; if user's response does not begin
+with a y, skip the exec. The C<;> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<-eval EXPR>
+
+Has the perl script eval() the EXPR.
+
+=item C<-ls>
+
+Simulates C<-exec ls -dils {} ;>
+
+=item C<-tar FILE>
+
+Adds current output to tar-format FILE.
+
+=item C<-cpio FILE>
+
+Adds current output to old-style cpio-format FILE.
+
+=item C<-ncpio FILE>
+
+Adds current output to "new"-style cpio-format FILE.
+
+=back
+
+Predicates which take a numeric argument N can come in three forms:
+
+ * N is prefixed with a +: match values greater than N
+ * N is prefixed with a -: match values less than N
+ * N is not prefixed with either + or -: match only values equal to N
+
+=head1 SEE ALSO
+
+find, File::Find.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/findrule b/Master/tlpkg/tlperl.straw/bin/findrule
new file mode 100755
index 00000000000..6aa37d64f1c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/findrule
@@ -0,0 +1,138 @@
+#!perl -w
+use strict;
+use File::Find::Rule;
+use File::Spec::Functions qw(catdir);
+
+# bootstrap extensions
+for (@INC) {
+ my $dir = catdir($_, qw( File Find Rule ) );
+ next unless -d $dir;
+ my @pm = find( name => '*.pm', maxdepth => 1,
+ exec => sub { (my $name = $_) =~ s/\.pm$//;
+ eval "require File::Find::Rule::$name"; },
+ in => $dir );
+}
+
+# what directories are we searching in?
+my @where;
+while (@ARGV) {
+ local $_ = shift @ARGV;
+ if (/^-/) {
+ unshift @ARGV, $_;
+ last;
+ }
+ push @where, $_;
+}
+
+# parse arguments, build a rule object
+my $rule = new File::Find::Rule;
+while (@ARGV) {
+ my $clause = shift @ARGV;
+
+ unless ( $clause =~ s/^-// && $rule->can( $clause ) ) {
+ # not a known rule - complain about this
+ die "unknown option '$clause'\n"
+ }
+
+ # it was the last switch
+ unless (@ARGV) {
+ $rule->$clause();
+ next;
+ }
+
+ # consume the parameters
+ my $param = shift @ARGV;
+
+ if ($param =~ /^-/) {
+ # it's the next switch - put it back, and add one with no params
+ unshift @ARGV, $param;
+ $rule->$clause();
+ next;
+ }
+
+ if ($param eq '(') {
+ # multiple values - just look for the closing parenthesis
+ my @p;
+ while (@ARGV) {
+ my $val = shift @ARGV;
+ last if $val eq ')';
+ push @p, $val;
+ }
+ $rule->$clause( @p );
+ next;
+ }
+
+ # a single argument
+ $rule->$clause( $param );
+}
+
+# add a print rule so things happen faster
+$rule->exec( sub { print "$_[2]\n"; return; } );
+
+# profit
+$rule->in( @where ? @where : '.' );
+exit 0;
+
+__END__
+
+=head1 NAME
+
+findrule - command line wrapper to File::Find::Rule
+
+=head1 USAGE
+
+ findrule [path...] [expression]
+
+=head1 DESCRIPTION
+
+C<findrule> mostly borrows the interface from GNU find(1) to provide a
+command-line interface onto the File::Find::Rule heirarchy of modules.
+
+The syntax for expressions is the rule name, preceded by a dash,
+followed by an optional argument. If the argument is an opening
+parenthesis it is taken as a list of arguments, terminated by a
+closing parenthesis.
+
+Some examples:
+
+ find -file -name ( foo bar )
+
+files named C<foo> or C<bar>, below the current directory.
+
+ find -file -name foo -bar
+
+files named C<foo>, that have pubs (for this is what our ficticious
+C<bar> clause specifies), below the current directory.
+
+ find -file -name ( -bar )
+
+files named C<-bar>, below the current directory. In this case if
+we'd have omitted the parenthesis it would have parsed as a call to
+name with no arguments, followed by a call to -bar.
+
+=head2 Supported switches
+
+I'm very slack. Please consult the File::Find::Rule manpage for now,
+and prepend - to the commands that you want.
+
+=head2 Extra bonus switches
+
+findrule automatically loads all of your installed File::Find::Rule::*
+extension modules, so check the documentation to see what those would be.
+
+=head1 AUTHOR
+
+Richard Clamp <richardc@unixbeard.net> from a suggestion by Tatsuhiko Miyagawa
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002 Richard Clamp. All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<File::Find::Rule>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/findrule.bat b/Master/tlpkg/tlperl.straw/bin/findrule.bat
new file mode 100755
index 00000000000..82bfb986fba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/findrule.bat
@@ -0,0 +1,154 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use strict;
+use File::Find::Rule;
+use File::Spec::Functions qw(catdir);
+
+# bootstrap extensions
+for (@INC) {
+ my $dir = catdir($_, qw( File Find Rule ) );
+ next unless -d $dir;
+ my @pm = find( name => '*.pm', maxdepth => 1,
+ exec => sub { (my $name = $_) =~ s/\.pm$//;
+ eval "require File::Find::Rule::$name"; },
+ in => $dir );
+}
+
+# what directories are we searching in?
+my @where;
+while (@ARGV) {
+ local $_ = shift @ARGV;
+ if (/^-/) {
+ unshift @ARGV, $_;
+ last;
+ }
+ push @where, $_;
+}
+
+# parse arguments, build a rule object
+my $rule = new File::Find::Rule;
+while (@ARGV) {
+ my $clause = shift @ARGV;
+
+ unless ( $clause =~ s/^-// && $rule->can( $clause ) ) {
+ # not a known rule - complain about this
+ die "unknown option '$clause'\n"
+ }
+
+ # it was the last switch
+ unless (@ARGV) {
+ $rule->$clause();
+ next;
+ }
+
+ # consume the parameters
+ my $param = shift @ARGV;
+
+ if ($param =~ /^-/) {
+ # it's the next switch - put it back, and add one with no params
+ unshift @ARGV, $param;
+ $rule->$clause();
+ next;
+ }
+
+ if ($param eq '(') {
+ # multiple values - just look for the closing parenthesis
+ my @p;
+ while (@ARGV) {
+ my $val = shift @ARGV;
+ last if $val eq ')';
+ push @p, $val;
+ }
+ $rule->$clause( @p );
+ next;
+ }
+
+ # a single argument
+ $rule->$clause( $param );
+}
+
+# add a print rule so things happen faster
+$rule->exec( sub { print "$_[2]\n"; return; } );
+
+# profit
+$rule->in( @where ? @where : '.' );
+exit 0;
+
+__END__
+
+=head1 NAME
+
+findrule - command line wrapper to File::Find::Rule
+
+=head1 USAGE
+
+ findrule [path...] [expression]
+
+=head1 DESCRIPTION
+
+C<findrule> mostly borrows the interface from GNU find(1) to provide a
+command-line interface onto the File::Find::Rule heirarchy of modules.
+
+The syntax for expressions is the rule name, preceded by a dash,
+followed by an optional argument. If the argument is an opening
+parenthesis it is taken as a list of arguments, terminated by a
+closing parenthesis.
+
+Some examples:
+
+ find -file -name ( foo bar )
+
+files named C<foo> or C<bar>, below the current directory.
+
+ find -file -name foo -bar
+
+files named C<foo>, that have pubs (for this is what our ficticious
+C<bar> clause specifies), below the current directory.
+
+ find -file -name ( -bar )
+
+files named C<-bar>, below the current directory. In this case if
+we'd have omitted the parenthesis it would have parsed as a call to
+name with no arguments, followed by a call to -bar.
+
+=head2 Supported switches
+
+I'm very slack. Please consult the File::Find::Rule manpage for now,
+and prepend - to the commands that you want.
+
+=head2 Extra bonus switches
+
+findrule automatically loads all of your installed File::Find::Rule::*
+extension modules, so check the documentation to see what those would be.
+
+=head1 AUTHOR
+
+Richard Clamp <richardc@unixbeard.net> from a suggestion by Tatsuhiko Miyagawa
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002 Richard Clamp. All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<File::Find::Rule>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/gedi b/Master/tlpkg/tlperl.straw/bin/gedi
new file mode 100755
index 00000000000..c42bbb6fdd6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/gedi
@@ -0,0 +1,315 @@
+#!/usr/local/bin/perl -w
+
+###############################################################################
+# Copyright (c) 1999 Greg London
+# All rights reserved.
+# This program is free software.
+# You can redistribute it and/or modify it under the same terms as Perl itself.
+###############################################################################
+
+###############################################################################
+# This is a perl application, called gedi, implementing a text editor.
+# gedi is short for Greg's EDItor. The "g" being pronounced like a "j".
+###############################################################################
+
+
+require 5;
+use locale;
+use strict;
+
+use Tk;
+use Tk::widgets qw(TextEdit);
+use File::Basename;
+
+###########################################
+# check command line parameter.
+# if none, start with file called 'NewFile'
+# if -help, print help
+# if filename, open file or die
+# note, wildcard automatically gets handled by perl interpreter,
+# so that @ARGV contains list of matches.
+###########################################
+
+# Create MainWindow first to handle X11 options.
+my $top = MainWindow->new();
+
+my $argcount = @ARGV;
+my ($global_filename) = @ARGV;
+
+if ($argcount>1)
+ {
+ print "\n";
+ print "ERROR: too many files specified. \n";
+ die "\n";
+ }
+
+if ($argcount == 0)
+ {$global_filename = 'NoName';}
+
+if (
+ ($global_filename eq 'help') ||
+ ($global_filename eq '-help') ||
+ ($global_filename eq '-h') ||
+ ($global_filename eq '-?')
+ )
+ {
+ print "\n";
+ print "$0 expects one command line argument: \n";
+ print " the name of the file to edit \n";
+ die "\n";
+ }
+
+
+# want FileSelect to use the last used directory as the starting directory
+# store directory in $global_directory.
+my $global_directory = dirname($global_filename);
+
+##############################################
+##############################################
+## input parameters have been filtered.
+## set up three frames to put everything into.
+## menu_frame, text_frame, counter_frame
+##############################################
+##############################################
+# my $menu_frame = $top->Frame->pack(-anchor=>'nw');
+my $text_frame = $top->Frame->pack
+ (-anchor=>'nw', -expand=>'yes', -fill => 'both'); # autosizing
+my $counter_frame = $top->Frame->pack(-anchor=>'nw');
+
+##############################################
+##############################################
+## now set up text window with contents.
+##############################################
+##############################################
+
+## autosizing is set up such that when the outside window is
+## resized, the text box adjusts to fill everything else in.
+## the text frame and the text window in the frame are both
+## set up for autosizing.
+
+my $textwindow = $text_frame->Scrolled(
+ 'TextEdit',
+ -exportselection => 'true', # 'sel' tag is associated with selections
+ # initial height, if it isnt 1, then autosizing fails
+ # once window shrinks below height
+ # and the line counters go off the screen.
+ # seems to be a problem with the Tk::pack command;
+ -height => 1,
+ -background => 'white',
+ -wrap=> 'none',
+ -setgrid => 'true', # use this for autosizing
+ -scrollbars =>'se')
+ -> pack(-expand => 'yes' , -fill => 'both'); # autosizing
+
+#$textwindow->FileName($global_filename);
+
+
+$top->protocol('WM_DELETE_WINDOW'=>
+ sub{$textwindow->ConfirmExit;}
+ );
+
+$SIG{INT} = sub {$textwindow->ConfirmExit;};
+
+##############################################
+##############################################
+## set up current line number display
+##############################################
+##############################################
+my $current_line_label = $counter_frame
+ -> Label(-text=>'line: 1')
+ -> grid(-row=>1,-column=>1, -sticky=>'nw' );
+
+my $total_line_label = $counter_frame
+ -> Label(-text=>'total lines: 1')
+ -> grid(-row=>2,-column=>1, -sticky=>'nw' );
+
+my $current_column_label = $counter_frame
+ -> Label(-text=>'column: 0')
+ -> grid(-row=>3,-column=>1, -sticky=>'nw' );
+
+my $insert_overstrike_mode_label = $counter_frame
+ -> Label(-text=>' ')
+ -> grid(-row=>5,-column=>1, -sticky=>'nw' );
+
+sub update_indicators
+{
+ my ($line,$column)= split(/\./,$textwindow->index('insert'));
+ $current_line_label->configure (-text=> "line: $line");
+ $current_column_label->configure (-text=> "column: $column");
+
+ my ($last_line,$last_col) = split(/\./,$textwindow->index('end'));
+ $total_line_label->configure (-text=> "total lines: $last_line");
+
+ my $mode = $textwindow->OverstrikeMode;
+ my $overstrke_insert='Insert Mode';
+ if ($mode)
+ {$overstrke_insert='Overstrike Mode';}
+ $insert_overstrike_mode_label->configure
+ (-text=> "$overstrke_insert");
+
+ my $filename = $textwindow->FileName;
+ $filename = 'NoName' unless(defined($filename));
+ my $edit_flag='';
+ if($textwindow->numberChanges)
+ {$edit_flag='edited';}
+ $top->configure(-title => "Gedi $edit_flag $filename");
+ $textwindow->idletasks;
+
+}
+
+$textwindow->SetGUICallbacks (
+ [
+ \&update_indicators,
+ sub{$textwindow->HighlightAllPairsBracketingCursor}
+ ]
+);
+
+
+##############################################
+##############################################
+# call back functions
+##############################################
+##############################################
+
+########################################################################
+my $about_pop_up_reference;
+sub about_pop_up
+{
+ my $name = ref($about_pop_up_reference);
+ if (defined($about_pop_up_reference))
+ {
+ $about_pop_up_reference->raise;
+ $about_pop_up_reference->focus;
+ }
+ else
+ {
+ my $pop = $top->Toplevel();
+ $pop->title("About");
+
+ $pop->Label(-text=>"Gedi (Gregs EDItor)")->pack();
+ $pop->Label(-text=>"Ver. 1.0")->pack();
+ $pop->Label(-text=>"Copyright 1999")->pack();
+ $pop->Label(-text=>"Greg London")->pack();
+ $pop->Label(-text=>"All Rights Reserved.")->pack();
+ $pop->Label(-text=>"This program is free software.")->pack();
+ $pop->Label(-text=>"You can redistribute it and/or")->pack();
+ $pop->Label(-text=>"modify it under the same terms")->pack();
+ $pop->Label(-text=>"as Perl itself.")->pack();
+ $pop->Label(-text=>"Special Thanks to")->pack();
+ $pop->Label(-text=>"Nick Ing-Simmons.")->pack();
+
+ my $button_ok = $pop->Button(-text=>'OK',
+ -command => sub {$pop->destroy();
+ $about_pop_up_reference = undef;
+ } )
+ ->pack();
+ $pop->resizable('no','no');
+ $about_pop_up_reference = $pop;
+ }
+}
+
+##############################################
+##############################################
+## now set up menu bar
+##############################################
+##############################################
+
+my $menu = $textwindow->menu;
+$top->configure(-menu => $menu);
+
+##############################################
+# help menu
+##############################################
+my $help_menu = $menu->cascade(-label=>'~Help', -tearoff => 0, -menuitems => [
+ [Command => 'A~bout', -command => \&about_pop_up]
+ ]);
+
+##############################################
+# debug menu
+##############################################
+
+if (0)
+ {
+ my $debug_menu = $menu->cascade(-label=>'debug', -underline=>0);
+
+
+ $debug_menu->command(-label => 'Tag names', -underline=> 0 ,
+ -command =>
+ sub{
+ my @tags = $textwindow->tagNames();
+ print " @tags\n";
+
+ foreach my $tag (@tags)
+ {
+ my @ranges = $textwindow->tagRanges($tag);
+ print "tag: $tag ranges: @ranges \n";
+ }
+
+ print "\n\n\n";
+ my @marks = $textwindow->markNames;
+ print " @marks \n";
+ foreach my $mark (@marks)
+ {
+ my $mark_location = $textwindow->index($mark);
+ print "$mark is at $mark_location\n";
+ }
+
+
+ print "\n\n\n";
+ my @dump = $textwindow->dump ( '-tag', '1.0', '465.0' );
+ print "@dump \n";
+
+ print "\n\n\n";
+ print "showing tops children:";
+ my @children = $top->children();
+ print "@children\n";
+
+ foreach my $child (@children)
+ {
+ my $junk = ref($child);
+ print "ref of $child is $junk \n";
+ }
+
+ my $overstrike = $textwindow->OverstrikeMode;
+ print "Overstrike is $overstrike \n";
+
+ $textwindow->dump_array($textwindow);
+ });
+ }
+
+##############################################
+# set the window to a normal size and set the minimum size
+$top->minsize(30,1);
+$top->geometry("80x24");
+
+#############################################################################
+#############################################################################
+#############################################################################
+#############################################################################
+
+
+
+
+##############################################
+## this line for debug
+## $top->bind('<Key>', [sub{print "ARGS: @_\n";}, Ev('k'), Ev('K') ] );
+
+##########################################
+## fill the text window with initial file.
+
+if ($argcount)
+ {
+ if (-e $global_filename) # if it doesn't exist, make it empty
+ {
+ # it may be a big file, draw the window, and then load it
+ # so that we know something is happening.
+ $top->update;
+ $textwindow->Load($global_filename);
+ }
+ }
+
+
+##############################################
+$textwindow->CallNextGUICallback;
+
+MainLoop();
diff --git a/Master/tlpkg/tlperl.straw/bin/gedi.bat b/Master/tlpkg/tlperl.straw/bin/gedi.bat
new file mode 100755
index 00000000000..bf0a7d28ebf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/gedi.bat
@@ -0,0 +1,331 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+
+###############################################################################
+# Copyright (c) 1999 Greg London
+# All rights reserved.
+# This program is free software.
+# You can redistribute it and/or modify it under the same terms as Perl itself.
+###############################################################################
+
+###############################################################################
+# This is a perl application, called gedi, implementing a text editor.
+# gedi is short for Greg's EDItor. The "g" being pronounced like a "j".
+###############################################################################
+
+
+require 5;
+use locale;
+use strict;
+
+use Tk;
+use Tk::widgets qw(TextEdit);
+use File::Basename;
+
+###########################################
+# check command line parameter.
+# if none, start with file called 'NewFile'
+# if -help, print help
+# if filename, open file or die
+# note, wildcard automatically gets handled by perl interpreter,
+# so that @ARGV contains list of matches.
+###########################################
+
+# Create MainWindow first to handle X11 options.
+my $top = MainWindow->new();
+
+my $argcount = @ARGV;
+my ($global_filename) = @ARGV;
+
+if ($argcount>1)
+ {
+ print "\n";
+ print "ERROR: too many files specified. \n";
+ die "\n";
+ }
+
+if ($argcount == 0)
+ {$global_filename = 'NoName';}
+
+if (
+ ($global_filename eq 'help') ||
+ ($global_filename eq '-help') ||
+ ($global_filename eq '-h') ||
+ ($global_filename eq '-?')
+ )
+ {
+ print "\n";
+ print "$0 expects one command line argument: \n";
+ print " the name of the file to edit \n";
+ die "\n";
+ }
+
+
+# want FileSelect to use the last used directory as the starting directory
+# store directory in $global_directory.
+my $global_directory = dirname($global_filename);
+
+##############################################
+##############################################
+## input parameters have been filtered.
+## set up three frames to put everything into.
+## menu_frame, text_frame, counter_frame
+##############################################
+##############################################
+# my $menu_frame = $top->Frame->pack(-anchor=>'nw');
+my $text_frame = $top->Frame->pack
+ (-anchor=>'nw', -expand=>'yes', -fill => 'both'); # autosizing
+my $counter_frame = $top->Frame->pack(-anchor=>'nw');
+
+##############################################
+##############################################
+## now set up text window with contents.
+##############################################
+##############################################
+
+## autosizing is set up such that when the outside window is
+## resized, the text box adjusts to fill everything else in.
+## the text frame and the text window in the frame are both
+## set up for autosizing.
+
+my $textwindow = $text_frame->Scrolled(
+ 'TextEdit',
+ -exportselection => 'true', # 'sel' tag is associated with selections
+ # initial height, if it isnt 1, then autosizing fails
+ # once window shrinks below height
+ # and the line counters go off the screen.
+ # seems to be a problem with the Tk::pack command;
+ -height => 1,
+ -background => 'white',
+ -wrap=> 'none',
+ -setgrid => 'true', # use this for autosizing
+ -scrollbars =>'se')
+ -> pack(-expand => 'yes' , -fill => 'both'); # autosizing
+
+#$textwindow->FileName($global_filename);
+
+
+$top->protocol('WM_DELETE_WINDOW'=>
+ sub{$textwindow->ConfirmExit;}
+ );
+
+$SIG{INT} = sub {$textwindow->ConfirmExit;};
+
+##############################################
+##############################################
+## set up current line number display
+##############################################
+##############################################
+my $current_line_label = $counter_frame
+ -> Label(-text=>'line: 1')
+ -> grid(-row=>1,-column=>1, -sticky=>'nw' );
+
+my $total_line_label = $counter_frame
+ -> Label(-text=>'total lines: 1')
+ -> grid(-row=>2,-column=>1, -sticky=>'nw' );
+
+my $current_column_label = $counter_frame
+ -> Label(-text=>'column: 0')
+ -> grid(-row=>3,-column=>1, -sticky=>'nw' );
+
+my $insert_overstrike_mode_label = $counter_frame
+ -> Label(-text=>' ')
+ -> grid(-row=>5,-column=>1, -sticky=>'nw' );
+
+sub update_indicators
+{
+ my ($line,$column)= split(/\./,$textwindow->index('insert'));
+ $current_line_label->configure (-text=> "line: $line");
+ $current_column_label->configure (-text=> "column: $column");
+
+ my ($last_line,$last_col) = split(/\./,$textwindow->index('end'));
+ $total_line_label->configure (-text=> "total lines: $last_line");
+
+ my $mode = $textwindow->OverstrikeMode;
+ my $overstrke_insert='Insert Mode';
+ if ($mode)
+ {$overstrke_insert='Overstrike Mode';}
+ $insert_overstrike_mode_label->configure
+ (-text=> "$overstrke_insert");
+
+ my $filename = $textwindow->FileName;
+ $filename = 'NoName' unless(defined($filename));
+ my $edit_flag='';
+ if($textwindow->numberChanges)
+ {$edit_flag='edited';}
+ $top->configure(-title => "Gedi $edit_flag $filename");
+ $textwindow->idletasks;
+
+}
+
+$textwindow->SetGUICallbacks (
+ [
+ \&update_indicators,
+ sub{$textwindow->HighlightAllPairsBracketingCursor}
+ ]
+);
+
+
+##############################################
+##############################################
+# call back functions
+##############################################
+##############################################
+
+########################################################################
+my $about_pop_up_reference;
+sub about_pop_up
+{
+ my $name = ref($about_pop_up_reference);
+ if (defined($about_pop_up_reference))
+ {
+ $about_pop_up_reference->raise;
+ $about_pop_up_reference->focus;
+ }
+ else
+ {
+ my $pop = $top->Toplevel();
+ $pop->title("About");
+
+ $pop->Label(-text=>"Gedi (Gregs EDItor)")->pack();
+ $pop->Label(-text=>"Ver. 1.0")->pack();
+ $pop->Label(-text=>"Copyright 1999")->pack();
+ $pop->Label(-text=>"Greg London")->pack();
+ $pop->Label(-text=>"All Rights Reserved.")->pack();
+ $pop->Label(-text=>"This program is free software.")->pack();
+ $pop->Label(-text=>"You can redistribute it and/or")->pack();
+ $pop->Label(-text=>"modify it under the same terms")->pack();
+ $pop->Label(-text=>"as Perl itself.")->pack();
+ $pop->Label(-text=>"Special Thanks to")->pack();
+ $pop->Label(-text=>"Nick Ing-Simmons.")->pack();
+
+ my $button_ok = $pop->Button(-text=>'OK',
+ -command => sub {$pop->destroy();
+ $about_pop_up_reference = undef;
+ } )
+ ->pack();
+ $pop->resizable('no','no');
+ $about_pop_up_reference = $pop;
+ }
+}
+
+##############################################
+##############################################
+## now set up menu bar
+##############################################
+##############################################
+
+my $menu = $textwindow->menu;
+$top->configure(-menu => $menu);
+
+##############################################
+# help menu
+##############################################
+my $help_menu = $menu->cascade(-label=>'~Help', -tearoff => 0, -menuitems => [
+ [Command => 'A~bout', -command => \&about_pop_up]
+ ]);
+
+##############################################
+# debug menu
+##############################################
+
+if (0)
+ {
+ my $debug_menu = $menu->cascade(-label=>'debug', -underline=>0);
+
+
+ $debug_menu->command(-label => 'Tag names', -underline=> 0 ,
+ -command =>
+ sub{
+ my @tags = $textwindow->tagNames();
+ print " @tags\n";
+
+ foreach my $tag (@tags)
+ {
+ my @ranges = $textwindow->tagRanges($tag);
+ print "tag: $tag ranges: @ranges \n";
+ }
+
+ print "\n\n\n";
+ my @marks = $textwindow->markNames;
+ print " @marks \n";
+ foreach my $mark (@marks)
+ {
+ my $mark_location = $textwindow->index($mark);
+ print "$mark is at $mark_location\n";
+ }
+
+
+ print "\n\n\n";
+ my @dump = $textwindow->dump ( '-tag', '1.0', '465.0' );
+ print "@dump \n";
+
+ print "\n\n\n";
+ print "showing tops children:";
+ my @children = $top->children();
+ print "@children\n";
+
+ foreach my $child (@children)
+ {
+ my $junk = ref($child);
+ print "ref of $child is $junk \n";
+ }
+
+ my $overstrike = $textwindow->OverstrikeMode;
+ print "Overstrike is $overstrike \n";
+
+ $textwindow->dump_array($textwindow);
+ });
+ }
+
+##############################################
+# set the window to a normal size and set the minimum size
+$top->minsize(30,1);
+$top->geometry("80x24");
+
+#############################################################################
+#############################################################################
+#############################################################################
+#############################################################################
+
+
+
+
+##############################################
+## this line for debug
+## $top->bind('<Key>', [sub{print "ARGS: @_\n";}, Ev('k'), Ev('K') ] );
+
+##########################################
+## fill the text window with initial file.
+
+if ($argcount)
+ {
+ if (-e $global_filename) # if it doesn't exist, make it empty
+ {
+ # it may be a big file, draw the window, and then load it
+ # so that we know something is happening.
+ $top->update;
+ $textwindow->Load($global_filename);
+ }
+ }
+
+
+##############################################
+$textwindow->CallNextGUICallback;
+
+MainLoop();
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/h2ph.bat b/Master/tlpkg/tlperl.straw/bin/h2ph.bat
new file mode 100755
index 00000000000..eb1f7862961
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/h2ph.bat
@@ -0,0 +1,959 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+use strict;
+
+use Config;
+use File::Path qw(mkpath);
+use Getopt::Std;
+
+# Make sure read permissions for all are set:
+if (defined umask && (umask() & 0444)) {
+ umask (umask() & ~0444);
+}
+
+getopts('Dd:rlhaQe');
+use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
+die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
+my @inc_dirs = inc_dirs() if $opt_a;
+
+my $Exit = 0;
+
+my $Dest_dir = $opt_d || $Config{installsitearch};
+die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
+ unless -d $Dest_dir;
+
+my @isatype = qw(
+ char uchar u_char
+ short ushort u_short
+ int uint u_int
+ long ulong u_long
+ FILE key_t caddr_t
+ float double size_t
+);
+
+my %isatype;
+@isatype{@isatype} = (1) x @isatype;
+my $inif = 0;
+my %Is_converted;
+my %bad_file = ();
+
+@ARGV = ('-') unless @ARGV;
+
+build_preamble_if_necessary();
+
+sub reindent($) {
+ my($text) = shift;
+ $text =~ s/\n/\n /g;
+ $text =~ s/ /\t/g;
+ $text;
+}
+
+my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
+my ($incl, $incl_type, $incl_quote, $next);
+while (defined (my $file = next_file())) {
+ if (-l $file and -d $file) {
+ link_if_possible($file) if ($opt_l);
+ next;
+ }
+
+ # Recover from header files with unbalanced cpp directives
+ $t = '';
+ $tab = 0;
+
+ # $eval_index goes into ``#line'' directives, to help locate syntax errors:
+ $eval_index = 1;
+
+ if ($file eq '-') {
+ open(IN, "-");
+ open(OUT, ">-");
+ } else {
+ ($outfile = $file) =~ s/\.h$/.ph/ || next;
+ print "$file -> $outfile\n" unless $opt_Q;
+ if ($file =~ m|^(.*)/|) {
+ $dir = $1;
+ mkpath "$Dest_dir/$dir";
+ }
+
+ if ($opt_a) { # automagic mode: locate header file in @inc_dirs
+ foreach (@inc_dirs) {
+ chdir $_;
+ last if -f $file;
+ }
+ }
+
+ open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
+ open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
+ }
+
+ print OUT
+ "require '_h2ph_pre.ph';\n\n",
+ "no warnings qw(redefine misc);\n\n";
+
+ while (defined (local $_ = next_line($file))) {
+ if (s/^\s*\#\s*//) {
+ if (s/^define\s+(\w+)//) {
+ $name = $1;
+ $new = '';
+ s/\s+$//;
+ s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
+ if (s/^\(([\w,\s]*)\)//) {
+ $args = $1;
+ my $proto = '() ';
+ if ($args ne '') {
+ $proto = '';
+ foreach my $arg (split(/,\s*/,$args)) {
+ $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
+ $curargs{$arg} = 1;
+ }
+ $args =~ s/\b(\w)/\$$1/g;
+ $args = "my($args) = \@_;\n$t ";
+ }
+ s/^\s+//;
+ expr();
+ $new =~ s/(["\\])/\\$1/g; #"]);
+ EMIT:
+ $new = reindent($new);
+ $args = reindent($args);
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g; #']);
+ if ($opt_h) {
+ print OUT $t,
+ "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,
+ "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+ }
+ } else {
+ print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
+ }
+ %curargs = ();
+ } else {
+ s/^\s+//;
+ expr();
+ $new = 1 if $new eq '';
+ $new = reindent($new);
+ $args = reindent($args);
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g; #']);
+
+ if ($opt_h) {
+ print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ }
+ } else {
+ # Shunt around such directives as `#define FOO FOO':
+ next if " \&$name" eq $new;
+
+ print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
+ }
+ }
+ } elsif (/^(include|import|include_next)\s*([<\"])(.*)[>\"]/) {
+ $incl_type = $1;
+ $incl_quote = $2;
+ $incl = $3;
+ if (($incl_type eq 'include_next') ||
+ ($opt_e && exists($bad_file{$incl}))) {
+ $incl =~ s/\.h$/.ph/;
+ print OUT ($t,
+ "eval {\n");
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT ($t, "my(\@REM);\n");
+ if ($incl_type eq 'include_next') {
+ print OUT ($t,
+ "my(\%INCD) = map { \$INC{\$_} => 1 } ",
+ "(grep { \$_ eq \"$incl\" } ",
+ "keys(\%INC));\n");
+ print OUT ($t,
+ "\@REM = map { \"\$_/$incl\" } ",
+ "(grep { not exists(\$INCD{\"\$_/$incl\"})",
+ " and -f \"\$_/$incl\" } \@INC);\n");
+ } else {
+ print OUT ($t,
+ "\@REM = map { \"\$_/$incl\" } ",
+ "(grep {-r \"\$_/$incl\" } \@INC);\n");
+ }
+ print OUT ($t,
+ "require \"\$REM[0]\" if \@REM;\n");
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT ($t,
+ "};\n");
+ print OUT ($t,
+ "warn(\$\@) if \$\@;\n");
+ } else {
+ $incl =~ s/\.h$/.ph/;
+ # copy the prefix in the quote syntax (#include "x.h") case
+ if ($incl !~ m|/| && $incl_quote eq q{"} && $file =~ m|^(.*)/|) {
+ $incl = "$1/$incl";
+ }
+ print OUT $t,"require '$incl';\n";
+ }
+ } elsif (/^ifdef\s+(\w+)/) {
+ print OUT $t,"if(defined(&$1)) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^ifndef\s+(\w+)/) {
+ print OUT $t,"unless(defined(&$1)) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (s/^if\s+//) {
+ $new = '';
+ $inif = 1;
+ expr();
+ $inif = 0;
+ print OUT $t,"if($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (s/^elif\s+//) {
+ $new = '';
+ $inif = 1;
+ expr();
+ $inif = 0;
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n elsif($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^else/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"} else {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^endif/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n";
+ } elsif(/^undef\s+(\w+)/) {
+ print OUT $t, "undef(&$1) if defined(&$1);\n";
+ } elsif(/^error\s+(".*")/) {
+ print OUT $t, "die($1);\n";
+ } elsif(/^error\s+(.*)/) {
+ print OUT $t, "die(\"", quotemeta($1), "\");\n";
+ } elsif(/^warning\s+(.*)/) {
+ print OUT $t, "warn(\"", quotemeta($1), "\");\n";
+ } elsif(/^ident\s+(.*)/) {
+ print OUT $t, "# $1\n";
+ }
+ } elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi
+ until(/\{[^}]*\}.*;/ || /;/) {
+ last unless defined ($next = next_line($file));
+ chomp $next;
+ # drop "#define FOO FOO" in enums
+ $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
+ # #defines in enums (aliases)
+ $next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
+ $_ .= $next;
+ print OUT "# $next\n" if $opt_D;
+ }
+ s/#\s*if.*?#\s*endif//g; # drop #ifdefs
+ s@/\*.*?\*/@@g;
+ s/\s+/ /g;
+ next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
+ (my $enum_subs = $3) =~ s/\s//g;
+ my @enum_subs = split(/,/, $enum_subs);
+ my $enum_val = -1;
+ foreach my $enum (@enum_subs) {
+ my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
+ $enum_name or next;
+ $enum_value =~ s/^=//;
+ $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
+ if ($opt_h) {
+ print OUT ($t,
+ "eval(\"\\n#line $eval_index $outfile\\n",
+ "sub $enum_name () \{ $enum_val; \}\") ",
+ "unless defined(\&$enum_name);\n");
+ ++ $eval_index;
+ } else {
+ print OUT ($t,
+ "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
+ "unless defined(\&$enum_name);\n");
+ }
+ }
+ } elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
+ and !/;\s*$/ and !/{\s*}\s*$/)
+ { # { for vi
+ # This is a hack to parse the inline functions in the glibc headers.
+ # Warning: massive kludge ahead. We suppose inline functions
+ # are mainly constructed like macros.
+ while (1) {
+ last unless defined ($next = next_line($file));
+ chomp $next;
+ undef $_, last if $next =~ /__THROW\s*;/
+ or $next =~ /^(__extension__|extern|static)\b/;
+ $_ .= " $next";
+ print OUT "# $next\n" if $opt_D;
+ last if $next =~ /^}|^{.*}\s*$/;
+ }
+ next if not defined; # because it's only a prototype
+ s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
+ # violently drop #ifdefs
+ s/#\s*if.*?#\s*endif//g
+ and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
+ if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
+ $name = $1;
+ } else {
+ warn "name not found"; next; # shouldn't occur...
+ }
+ my @args;
+ if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
+ for my $arg (split /,/, $1) {
+ if ($arg =~ /(\w+)\s*$/) {
+ $curargs{$1} = 1;
+ push @args, $1;
+ }
+ }
+ }
+ $args = (
+ @args
+ ? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t "
+ : ""
+ );
+ my $proto = @args ? '' : '() ';
+ $new = '';
+ s/\breturn\b//g; # "return" doesn't occur in macros usually...
+ expr();
+ # try to find and perlify local C variables
+ our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
+ {
+ use re "eval";
+ my $typelist = join '|', keys %isatype;
+ $new =~ s['
+ (?:(?:__)?const(?:__)?\s+)?
+ (?:(?:un)?signed\s+)?
+ (?:long\s+)?
+ (?:$typelist)\s+
+ (\w+)
+ (?{ push @local_variables, $1 })
+ ']
+ [my \$$1]gx;
+ $new =~ s['
+ (?:(?:__)?const(?:__)?\s+)?
+ (?:(?:un)?signed\s+)?
+ (?:long\s+)?
+ (?:$typelist)\s+
+ ' \s+ &(\w+) \s* ;
+ (?{ push @local_variables, $1 })
+ ]
+ [my \$$1;]gx;
+ }
+ $new =~ s/&$_\b/\$$_/g for @local_variables;
+ $new =~ s/(["\\])/\\$1/g; #"]);
+ # now that's almost like a macro (we hope)
+ goto EMIT;
+ }
+ }
+ $Is_converted{$file} = 1;
+ if ($opt_e && exists($bad_file{$file})) {
+ unlink($Dest_dir . '/' . $outfile);
+ $next = '';
+ } else {
+ print OUT "1;\n";
+ queue_includes_from($file) if $opt_a;
+ }
+}
+
+if ($opt_e && (scalar(keys %bad_file) > 0)) {
+ warn "Was unable to convert the following files:\n";
+ warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
+}
+
+exit $Exit;
+
+sub expr {
+ $new = '"(assembly code)"' and return if /\b__asm__\b/; # freak out.
+ my $joined_args;
+ if(keys(%curargs)) {
+ $joined_args = join('|', keys(%curargs));
+ }
+ while ($_ ne '') {
+ s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
+ s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
+ s/^(\s+)// && do {$new .= ' '; next;};
+ s/^0X([0-9A-F]+)[UL]*//i
+ && do {my $hex = $1;
+ $hex =~ s/^0+//;
+ if (length $hex > 8 && !$Config{use64bitint}) {
+ # Croak if nv_preserves_uv_bits < 64 ?
+ $new .= hex(substr($hex, -8)) +
+ 2**32 * hex(substr($hex, 0, -8));
+ # The above will produce "errorneus" code
+ # if the hex constant was e.g. inside UINT64_C
+ # macro, but then again, h2ph is an approximation.
+ } else {
+ $new .= lc("0x$hex");
+ }
+ next;};
+ s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
+ s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
+ s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
+ s/^'((\\"|[^"])*)'// && do {
+ if ($curargs{$1}) {
+ $new .= "ord('\$$1')";
+ } else {
+ $new .= "ord('$1')";
+ }
+ next;
+ };
+ # replace "sizeof(foo)" with "{foo}"
+ # also, remove * (C dereference operator) to avoid perl syntax
+ # problems. Where the %sizeof array comes from is anyone's
+ # guess (c2ph?), but this at least avoids fatal syntax errors.
+ # Behavior is undefined if sizeof() delimiters are unbalanced.
+ # This code was modified to able to handle constructs like this:
+ # sizeof(*(p)), which appear in the HP-UX 10.01 header files.
+ s/^sizeof\s*\(// && do {
+ $new .= '$sizeof';
+ my $lvl = 1; # already saw one open paren
+ # tack { on the front, and skip it in the loop
+ $_ = "{" . "$_";
+ my $index = 1;
+ # find balanced closing paren
+ while ($index <= length($_) && $lvl > 0) {
+ $lvl++ if substr($_, $index, 1) eq "(";
+ $lvl-- if substr($_, $index, 1) eq ")";
+ $index++;
+ }
+ # tack } on the end, replacing )
+ substr($_, $index - 1, 1) = "}";
+ # remove pesky * operators within the sizeof argument
+ substr($_, 0, $index - 1) =~ s/\*//g;
+ next;
+ };
+ # Eliminate typedefs
+ /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
+ my $doit = 1;
+ foreach (split /\s+/, $1) { # Make sure all the words are types,
+ unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
+ $doit = 0;
+ last;
+ }
+ }
+ if( $doit ){
+ s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
+ }
+ };
+ # struct/union member, including arrays:
+ s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
+ my $id = $1;
+ $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
+ $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
+ while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
+ my($index) = $1;
+ $index =~ s/\s//g;
+ if(exists($curargs{$index})) {
+ $index = "\$$index";
+ } else {
+ $index = "&$index";
+ }
+ $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
+ }
+ $new .= " (\$$id)";
+ };
+ s/^([_a-zA-Z]\w*)// && do {
+ my $id = $1;
+ if ($id eq 'struct' || $id eq 'union') {
+ s/^\s+(\w+)//;
+ $id .= ' ' . $1;
+ $isatype{$id} = 1;
+ } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
+ while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
+ $isatype{$id} = 1;
+ }
+ if ($curargs{$id}) {
+ $new .= "\$$id";
+ $new .= '->' if /^[\[\{]/;
+ } elsif ($id eq 'defined') {
+ $new .= 'defined';
+ } elsif (/^\s*\(/) {
+ s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
+ $new .= " &$id";
+ } elsif ($isatype{$id}) {
+ if ($new =~ /{\s*$/) {
+ $new .= "'$id'";
+ } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
+ $new =~ s/\(\s*$//;
+ s/^[\s*]*\)//;
+ } else {
+ $new .= q(').$id.q(');
+ }
+ } else {
+ if ($inif && $new !~ /defined\s*\($/) {
+ $new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)';
+ } elsif (/^\[/) {
+ $new .= " \$$id";
+ } else {
+ $new .= ' &' . $id;
+ }
+ }
+ next;
+ };
+ s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
+ }
+}
+
+
+sub next_line
+{
+ my $file = shift;
+ my ($in, $out);
+ my $pre_sub_tri_graphs = 1;
+
+ READ: while (not eof IN) {
+ $in .= <IN>;
+ chomp $in;
+ next unless length $in;
+
+ while (length $in) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ $in =~ s/\?\?=/#/g; # | ??=| #|
+ $in =~ s/\?\?\!/|/g; # | ??!| ||
+ $in =~ s/\?\?'/^/g; # | ??'| ^|
+ $in =~ s/\?\?\(/[/g; # | ??(| [|
+ $in =~ s/\?\?\)/]/g; # | ??)| ]|
+ $in =~ s/\?\?\-/~/g; # | ??-| ~|
+ $in =~ s/\?\?\//\\/g; # | ??/| \|
+ $in =~ s/\?\?</{/g; # | ??<| {|
+ $in =~ s/\?\?>/}/g; # | ??>| }|
+ }
+ if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
+ # Tru64 disassembler.h evilness: mixed C and Pascal.
+ while (<IN>) {
+ last if /^\#endif/;
+ }
+ $in = "";
+ next READ;
+ }
+ if ($in =~ /^extern inline / && # Inlined assembler.
+ $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
+ while (<IN>) {
+ last if /^}/;
+ }
+ $in = "";
+ next READ;
+ }
+ if ($in =~ s/\\$//) { # \-newline
+ $out .= ' ';
+ next READ;
+ } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
+ $out .= $1;
+ } elsif ($in =~ s/^(\\.)//) { # \...
+ $out .= $1;
+ } elsif ($in =~ /^'/) { # '...
+ if ($in =~ s/^('(\\.|[^'\\])*')//) {
+ $out .= $1;
+ } else {
+ next READ;
+ }
+ } elsif ($in =~ /^"/) { # "...
+ if ($in =~ s/^("(\\.|[^"\\])*")//) {
+ $out .= $1;
+ } else {
+ next READ;
+ }
+ } elsif ($in =~ s/^\/\/.*//) { # //...
+ # fall through
+ } elsif ($in =~ m/^\/\*/) { # /*...
+ # C comment removal adapted from perlfaq6:
+ if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
+ $out .= ' ';
+ } else { # Incomplete /* */
+ next READ;
+ }
+ } elsif ($in =~ s/^(\/)//) { # /...
+ $out .= $1;
+ } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
+ $out .= $1;
+ } elsif ($^O eq 'linux' &&
+ $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
+ $in =~ s!\'T KNOW!!) {
+ $out =~ s!I DON$!I_DO_NOT_KNOW!;
+ } else {
+ if ($opt_e) {
+ warn "Cannot parse $file:\n$in\n";
+ $bad_file{$file} = 1;
+ $in = '';
+ $out = undef;
+ last READ;
+ } else {
+ die "Cannot parse:\n$in\n";
+ }
+ }
+ }
+
+ last READ if $out =~ /\S/;
+ }
+
+ return $out;
+}
+
+
+# Handle recursive subdirectories without getting a grotesquely big stack.
+# Could this be implemented using File::Find?
+sub next_file
+{
+ my $file;
+
+ while (@ARGV) {
+ $file = shift @ARGV;
+
+ if ($file eq '-' or -f $file or -l $file) {
+ return $file;
+ } elsif (-d $file) {
+ if ($opt_r) {
+ expand_glob($file);
+ } else {
+ print STDERR "Skipping directory `$file'\n";
+ }
+ } elsif ($opt_a) {
+ return $file;
+ } else {
+ print STDERR "Skipping `$file': not a file or directory\n";
+ }
+ }
+
+ return undef;
+}
+
+
+# Put all the files in $directory into @ARGV for processing.
+sub expand_glob
+{
+ my ($directory) = @_;
+
+ $directory =~ s:/$::;
+
+ opendir DIR, $directory;
+ foreach (readdir DIR) {
+ next if ($_ eq '.' or $_ eq '..');
+
+ # expand_glob() is going to be called until $ARGV[0] isn't a
+ # directory; so push directories, and unshift everything else.
+ if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
+ else { unshift @ARGV, "$directory/$_" }
+ }
+ closedir DIR;
+}
+
+
+# Given $file, a symbolic link to a directory in the C include directory,
+# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
+# Otherwise, just duplicate the file or directory.
+sub link_if_possible
+{
+ my ($dirlink) = @_;
+ my $target = eval 'readlink($dirlink)';
+
+ if ($target =~ m:^\.\./: or $target =~ m:^/:) {
+ # The target of a parent or absolute link could leave the $Dest_dir
+ # hierarchy, so let's put all of the contents of $dirlink (actually,
+ # the contents of $target) into @ARGV; as a side effect down the
+ # line, $dirlink will get created as an _actual_ directory.
+ expand_glob($dirlink);
+ } else {
+ if (-l "$Dest_dir/$dirlink") {
+ unlink "$Dest_dir/$dirlink" or
+ print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
+ }
+
+ if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
+ print "Linking $target -> $Dest_dir/$dirlink\n";
+
+ # Make sure that the link _links_ to something:
+ if (! -e "$Dest_dir/$target") {
+ mkpath("$Dest_dir/$target", 0755) or
+ print STDERR "Could not create $Dest_dir/$target/\n";
+ }
+ } else {
+ print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
+ }
+ }
+}
+
+
+# Push all #included files in $file onto our stack, except for STDIN
+# and files we've already processed.
+sub queue_includes_from
+{
+ my ($file) = @_;
+ my $line;
+
+ return if ($file eq "-");
+
+ open HEADER, $file or return;
+ while (defined($line = <HEADER>)) {
+ while (/\\$/) { # Handle continuation lines
+ chop $line;
+ $line .= <HEADER>;
+ }
+
+ if ($line =~ /^#\s*include\s+([<"])(.*?)[>"]/) {
+ my ($delimiter, $new_file) = ($1, $2);
+ # copy the prefix in the quote syntax (#include "x.h") case
+ if ($delimiter eq q{"} && $file =~ m|^(.*)/|) {
+ $new_file = "$1/$new_file";
+ }
+ push(@ARGV, $new_file) unless $Is_converted{$new_file};
+ }
+ }
+ close HEADER;
+}
+
+
+# Determine include directories; $Config{usrinc} should be enough for (all
+# non-GCC?) C compilers, but gcc uses additional include directories.
+sub inc_dirs
+{
+ my $from_gcc = `LC_ALL=C $Config{cc} -v 2>&1`;
+ if( !( $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s ) )
+ { # gcc-4+ :
+ $from_gcc = `LC_ALL=C $Config{cc} -print-search-dirs 2>&1`;
+ if ( !($from_gcc =~ s/^install:\s*([^\s]+[^\s\/])([\s\/]*).*$/$1\/include/s) )
+ {
+ $from_gcc = '';
+ };
+ };
+ length($from_gcc) ? ($from_gcc, $from_gcc . "-fixed", $Config{usrinc}) : ($Config{usrinc});
+}
+
+
+# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
+# version of h2ph.
+sub build_preamble_if_necessary
+{
+ # Increment $VERSION every time this function is modified:
+ my $VERSION = 2;
+ my $preamble = "$Dest_dir/_h2ph_pre.ph";
+
+ # Can we skip building the preamble file?
+ if (-r $preamble) {
+ # Extract version number from first line of preamble:
+ open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
+ my $line = <PREAMBLE>;
+ $line =~ /(\b\d+\b)/;
+ close PREAMBLE or die "Cannot close $preamble: $!";
+
+ # Don't build preamble if a compatible preamble exists:
+ return if $1 == $VERSION;
+ }
+
+ my (%define) = _extract_cc_defines();
+
+ open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
+ print PREAMBLE "# This file was created by h2ph version $VERSION\n";
+
+ foreach (sort keys %define) {
+ if ($opt_D) {
+ print PREAMBLE "# $_=$define{$_}\n";
+ }
+ if ($define{$_} =~ /^\((.*)\)$/) {
+ # parenthesized value: d=(v)
+ $define{$_} = $1;
+ }
+ if ($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
+ # float:
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { $1 } }\n\n";
+ } elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
+ # integer:
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { $1 } }\n\n";
+ } elsif ($define{$_} =~ /^\w+$/) {
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
+ } else {
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { \"",
+ quotemeta($define{$_}), "\" } }\n\n";
+ }
+ }
+ print PREAMBLE "\n1;\n"; # avoid 'did not return a true value' when empty
+ close PREAMBLE or die "Cannot close $preamble: $!";
+}
+
+
+# %Config contains information on macros that are pre-defined by the
+# system's compiler. We need this information to make the .ph files
+# function with perl as the .h files do with cc.
+sub _extract_cc_defines
+{
+ my %define;
+ my $allsymbols = join " ",
+ @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
+
+ # Split compiler pre-definitions into `key=value' pairs:
+ while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
+ $define{$1} = $2;
+ if ($opt_D) {
+ print STDERR "$_: $1 -> $2\n";
+ }
+ }
+
+ return %define;
+}
+
+
+1;
+
+##############################################################################
+__END__
+
+=head1 NAME
+
+h2ph - convert .h C header files to .ph Perl header files
+
+=head1 SYNOPSIS
+
+B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
+
+=head1 DESCRIPTION
+
+I<h2ph>
+converts any C header files specified to the corresponding Perl header file
+format.
+It is most easily run while in /usr/include:
+
+ cd /usr/include; h2ph * sys/*
+
+or
+
+ cd /usr/include; h2ph * sys/* arpa/* netinet/*
+
+or
+
+ cd /usr/include; h2ph -r -l .
+
+The output files are placed in the hierarchy rooted at Perl's
+architecture dependent library directory. You can specify a different
+hierarchy with a B<-d> switch.
+
+If run with no arguments, filters standard input to standard output.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -d destination_dir
+
+Put the resulting B<.ph> files beneath B<destination_dir>, instead of
+beneath the default Perl library location (C<$Config{'installsitearch'}>).
+
+=item -r
+
+Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
+on all files in those directories (and their subdirectories, etc.). B<-r>
+and B<-a> are mutually exclusive.
+
+=item -a
+
+Run automagically; convert B<headerfiles>, as well as any B<.h> files
+which they include. This option will search for B<.h> files in all
+directories which your C compiler ordinarily uses. B<-a> and B<-r> are
+mutually exclusive.
+
+=item -l
+
+Symbolic links will be replicated in the destination directory. If B<-l>
+is not specified, then links are skipped over.
+
+=item -h
+
+Put ``hints'' in the .ph files which will help in locating problems with
+I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
+errors, instead of the cryptic
+
+ [ some error condition ] at (eval mmm) line nnn
+
+you will see the slightly more helpful
+
+ [ some error condition ] at filename.ph line nnn
+
+However, the B<.ph> files almost double in size when built using B<-h>.
+
+=item -D
+
+Include the code from the B<.h> file as a comment in the B<.ph> file.
+This is primarily used for debugging I<h2ph>.
+
+=item -Q
+
+``Quiet'' mode; don't print out the names of the files being converted.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 FILES
+
+ /usr/include/*.h
+ /usr/include/sys/*.h
+
+etc.
+
+=head1 AUTHOR
+
+Larry Wall
+
+=head1 SEE ALSO
+
+perl(1)
+
+=head1 DIAGNOSTICS
+
+The usual warnings if it can't read or write the files involved.
+
+=head1 BUGS
+
+Doesn't construct the %sizeof array for you.
+
+It doesn't handle all C constructs, but it does attempt to isolate
+definitions inside evals so that you can get at the definitions
+that it can translate.
+
+It's only intended as a rough tool.
+You may need to dicker with the files produced.
+
+You have to run this program by hand; it's not run as part of the Perl
+installation.
+
+Doesn't handle complicated expressions built piecemeal, a la:
+
+ enum {
+ FIRST_VALUE,
+ SECOND_VALUE,
+ #ifdef ABC
+ THIRD_VALUE
+ #endif
+ };
+
+Doesn't necessarily locate all of your C compiler's internally-defined
+symbols.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/h2xs.bat b/Master/tlpkg/tlperl.straw/bin/h2xs.bat
new file mode 100755
index 00000000000..136eeea2fad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/h2xs.bat
@@ -0,0 +1,2203 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+use warnings;
+
+=head1 NAME
+
+h2xs - convert .h C header files to Perl extensions
+
+=head1 SYNOPSIS
+
+B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
+
+B<h2xs> B<-h>|B<-?>|B<--help>
+
+=head1 DESCRIPTION
+
+I<h2xs> builds a Perl extension from C header files. The extension
+will include functions which can be used to retrieve the value of any
+#define statement which was in the C header files.
+
+The I<module_name> will be used for the name of the extension. If
+module_name is not supplied then the name of the first header file
+will be used, with the first character capitalized.
+
+If the extension might need extra libraries, they should be included
+here. The extension Makefile.PL will take care of checking whether
+the libraries actually exist and how they should be loaded. The extra
+libraries should be specified in the form -lm -lposix, etc, just as on
+the cc command line. By default, the Makefile.PL will search through
+the library path determined by Configure. That path can be augmented
+by including arguments of the form B<-L/another/library/path> in the
+extra-libraries argument.
+
+In spite of its name, I<h2xs> may also be used to create a skeleton pure
+Perl module. See the B<-X> option.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-A>, B<--omit-autoload>
+
+Omit all autoload facilities. This is the same as B<-c> but also
+removes the S<C<use AutoLoader>> statement from the .pm file.
+
+=item B<-B>, B<--beta-version>
+
+Use an alpha/beta style version number. Causes version number to
+be "0.00_01" unless B<-v> is specified.
+
+=item B<-C>, B<--omit-changes>
+
+Omits creation of the F<Changes> file, and adds a HISTORY section to
+the POD template.
+
+=item B<-F>, B<--cpp-flags>=I<addflags>
+
+Additional flags to specify to C preprocessor when scanning header for
+function declarations. Writes these options in the generated F<Makefile.PL>
+too.
+
+=item B<-M>, B<--func-mask>=I<regular expression>
+
+selects functions/macros to process.
+
+=item B<-O>, B<--overwrite-ok>
+
+Allows a pre-existing extension directory to be overwritten.
+
+=item B<-P>, B<--omit-pod>
+
+Omit the autogenerated stub POD section.
+
+=item B<-X>, B<--omit-XS>
+
+Omit the XS portion. Used to generate a skeleton pure Perl module.
+C<-c> and C<-f> are implicitly enabled.
+
+=item B<-a>, B<--gen-accessors>
+
+Generate an accessor method for each element of structs and unions. The
+generated methods are named after the element name; will return the current
+value of the element if called without additional arguments; and will set
+the element to the supplied value (and return the new value) if called with
+an additional argument. Embedded structures and unions are returned as a
+pointer rather than the complete structure, to facilitate chained calls.
+
+These methods all apply to the Ptr type for the structure; additionally
+two methods are constructed for the structure type itself, C<_to_ptr>
+which returns a Ptr type pointing to the same structure, and a C<new>
+method to construct and return a new structure, initialised to zeroes.
+
+=item B<-b>, B<--compat-version>=I<version>
+
+Generates a .pm file which is backwards compatible with the specified
+perl version.
+
+For versions < 5.6.0, the changes are.
+ - no use of 'our' (uses 'use vars' instead)
+ - no 'use warnings'
+
+Specifying a compatibility version higher than the version of perl you
+are using to run h2xs will have no effect. If unspecified h2xs will default
+to compatibility with the version of perl you are using to run h2xs.
+
+=item B<-c>, B<--omit-constant>
+
+Omit C<constant()> from the .xs file and corresponding specialised
+C<AUTOLOAD> from the .pm file.
+
+=item B<-d>, B<--debugging>
+
+Turn on debugging messages.
+
+=item B<-e>, B<--omit-enums>=[I<regular expression>]
+
+If I<regular expression> is not given, skip all constants that are defined in
+a C enumeration. Otherwise skip only those constants that are defined in an
+enum whose name matches I<regular expression>.
+
+Since I<regular expression> is optional, make sure that this switch is followed
+by at least one other switch if you omit I<regular expression> and have some
+pending arguments such as header-file names. This is ok:
+
+ h2xs -e -n Module::Foo foo.h
+
+This is not ok:
+
+ h2xs -n Module::Foo -e foo.h
+
+In the latter, foo.h is taken as I<regular expression>.
+
+=item B<-f>, B<--force>
+
+Allows an extension to be created for a header even if that header is
+not found in standard include directories.
+
+=item B<-g>, B<--global>
+
+Include code for safely storing static data in the .xs file.
+Extensions that do no make use of static data can ignore this option.
+
+=item B<-h>, B<-?>, B<--help>
+
+Print the usage, help and version for this h2xs and exit.
+
+=item B<-k>, B<--omit-const-func>
+
+For function arguments declared as C<const>, omit the const attribute in the
+generated XS code.
+
+=item B<-m>, B<--gen-tied-var>
+
+B<Experimental>: for each variable declared in the header file(s), declare
+a perl variable of the same name magically tied to the C variable.
+
+=item B<-n>, B<--name>=I<module_name>
+
+Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
+
+=item B<-o>, B<--opaque-re>=I<regular expression>
+
+Use "opaque" data type for the C types matched by the regular
+expression, even if these types are C<typedef>-equivalent to types
+from typemaps. Should not be used without B<-x>.
+
+This may be useful since, say, types which are C<typedef>-equivalent
+to integers may represent OS-related handles, and one may want to work
+with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
+Use C<-o .> if you want to handle all the C<typedef>ed types as opaque
+types.
+
+The type-to-match is whitewashed (except for commas, which have no
+whitespace before them, and multiple C<*> which have no whitespace
+between them).
+
+=item B<-p>, B<--remove-prefix>=I<prefix>
+
+Specify a prefix which should be removed from the Perl function names,
+e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
+the prefix from functions that are autoloaded via the C<constant()>
+mechanism.
+
+=item B<-s>, B<--const-subs>=I<sub1,sub2>
+
+Create a perl subroutine for the specified macros rather than autoload
+with the constant() subroutine. These macros are assumed to have a
+return type of B<char *>, e.g.,
+S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
+
+=item B<-t>, B<--default-type>=I<type>
+
+Specify the internal type that the constant() mechanism uses for macros.
+The default is IV (signed integer). Currently all macros found during the
+header scanning process will be assumed to have this type. Future versions
+of C<h2xs> may gain the ability to make educated guesses.
+
+=item B<--use-new-tests>
+
+When B<--compat-version> (B<-b>) is present the generated tests will use
+C<Test::More> rather than C<Test> which is the default for versions before
+5.7.2 . C<Test::More> will be added to PREREQ_PM in the generated
+C<Makefile.PL>.
+
+=item B<--use-old-tests>
+
+Will force the generation of test code that uses the older C<Test> module.
+
+=item B<--skip-exporter>
+
+Do not use C<Exporter> and/or export any symbol.
+
+=item B<--skip-ppport>
+
+Do not use C<Devel::PPPort>: no portability to older version.
+
+=item B<--skip-autoloader>
+
+Do not use the module C<AutoLoader>; but keep the constant() function
+and C<sub AUTOLOAD> for constants.
+
+=item B<--skip-strict>
+
+Do not use the pragma C<strict>.
+
+=item B<--skip-warnings>
+
+Do not use the pragma C<warnings>.
+
+=item B<-v>, B<--version>=I<version>
+
+Specify a version number for this extension. This version number is added
+to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified.
+The version specified should be numeric.
+
+=item B<-x>, B<--autogen-xsubs>
+
+Automatically generate XSUBs basing on function declarations in the
+header file. The package C<C::Scan> should be installed. If this
+option is specified, the name of the header file may look like
+C<NAME1,NAME2>. In this case NAME1 is used instead of the specified
+string, but XSUBs are emitted only for the declarations included from
+file NAME2.
+
+Note that some types of arguments/return-values for functions may
+result in XSUB-declarations/typemap-entries which need
+hand-editing. Such may be objects which cannot be converted from/to a
+pointer (like C<long long>), pointers to functions, or arrays. See
+also the section on L<LIMITATIONS of B<-x>>.
+
+=back
+
+=head1 EXAMPLES
+
+
+ # Default behavior, extension is Rusers
+ h2xs rpcsvc/rusers
+
+ # Same, but extension is RUSERS
+ h2xs -n RUSERS rpcsvc/rusers
+
+ # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
+ h2xs rpcsvc::rusers
+
+ # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
+ h2xs -n ONC::RPC rpcsvc/rusers
+
+ # Without constant() or AUTOLOAD
+ h2xs -c rpcsvc/rusers
+
+ # Creates templates for an extension named RPC
+ h2xs -cfn RPC
+
+ # Extension is ONC::RPC.
+ h2xs -cfn ONC::RPC
+
+ # Extension is a pure Perl module with no XS code.
+ h2xs -X My::Module
+
+ # Extension is Lib::Foo which works at least with Perl5.005_03.
+ # Constants are created for all #defines and enums h2xs can find
+ # in foo.h.
+ h2xs -b 5.5.3 -n Lib::Foo foo.h
+
+ # Extension is Lib::Foo which works at least with Perl5.005_03.
+ # Constants are created for all #defines but only for enums
+ # whose names do not start with 'bar_'.
+ h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h
+
+ # Makefile.PL will look for library -lrpc in
+ # additional directory /opt/net/lib
+ h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
+
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
+
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ # subroutines are created for sec_rgy_wildcard_name and
+ # sec_rgy_wildcard_sid
+ h2xs -n DCE::rgynbase -p sec_rgy_ \
+ -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
+
+ # Make XS without defines in perl.h, but with function declarations
+ # visible from perl.h. Name of the extension is perl1.
+ # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
+ # Extra backslashes below because the string is passed to shell.
+ # Note that a directory with perl header files would
+ # be added automatically to include path.
+ h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
+
+ # Same with function declaration in proto.h as visible from perl.h.
+ h2xs -xAn perl2 perl.h,proto.h
+
+ # Same but select only functions which match /^av_/
+ h2xs -M '^av_' -xAn perl2 perl.h,proto.h
+
+ # Same but treat SV* etc as "opaque" types
+ h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
+
+=head2 Extension based on F<.h> and F<.c> files
+
+Suppose that you have some C files implementing some functionality,
+and the corresponding header files. How to create an extension which
+makes this functionality accessible in Perl? The example below
+assumes that the header files are F<interface_simple.h> and
+I<interface_hairy.h>, and you want the perl module be named as
+C<Ext::Ension>. If you need some preprocessor directives and/or
+linking with external libraries, see the flags C<-F>, C<-L> and C<-l>
+in L<"OPTIONS">.
+
+=over
+
+=item Find the directory name
+
+Start with a dummy run of h2xs:
+
+ h2xs -Afn Ext::Ension
+
+The only purpose of this step is to create the needed directories, and
+let you know the names of these directories. From the output you can
+see that the directory for the extension is F<Ext/Ension>.
+
+=item Copy C files
+
+Copy your header files and C files to this directory F<Ext/Ension>.
+
+=item Create the extension
+
+Run h2xs, overwriting older autogenerated files:
+
+ h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h
+
+h2xs looks for header files I<after> changing to the extension
+directory, so it will find your header files OK.
+
+=item Archive and test
+
+As usual, run
+
+ cd Ext/Ension
+ perl Makefile.PL
+ make dist
+ make
+ make test
+
+=item Hints
+
+It is important to do C<make dist> as early as possible. This way you
+can easily merge(1) your changes to autogenerated files if you decide
+to edit your C<.h> files and rerun h2xs.
+
+Do not forget to edit the documentation in the generated F<.pm> file.
+
+Consider the autogenerated files as skeletons only, you may invent
+better interfaces than what h2xs could guess.
+
+Consider this section as a guideline only, some other options of h2xs
+may better suit your needs.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 AUTHOR
+
+Larry Wall and others
+
+=head1 SEE ALSO
+
+L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
+
+=head1 DIAGNOSTICS
+
+The usual warnings if it cannot read or write the files involved.
+
+=head1 LIMITATIONS of B<-x>
+
+F<h2xs> would not distinguish whether an argument to a C function
+which is of the form, say, C<int *>, is an input, output, or
+input/output parameter. In particular, argument declarations of the
+form
+
+ int
+ foo(n)
+ int *n
+
+should be better rewritten as
+
+ int
+ foo(n)
+ int &n
+
+if C<n> is an input parameter.
+
+Additionally, F<h2xs> has no facilities to intuit that a function
+
+ int
+ foo(addr,l)
+ char *addr
+ int l
+
+takes a pair of address and length of data at this address, so it is better
+to rewrite this function as
+
+ int
+ foo(sv)
+ SV *addr
+ PREINIT:
+ STRLEN len;
+ char *s;
+ CODE:
+ s = SvPV(sv,len);
+ RETVAL = foo(s, len);
+ OUTPUT:
+ RETVAL
+
+or alternately
+
+ static int
+ my_foo(SV *sv)
+ {
+ STRLEN len;
+ char *s = SvPV(sv,len);
+
+ return foo(s, len);
+ }
+
+ MODULE = foo PACKAGE = foo PREFIX = my_
+
+ int
+ foo(sv)
+ SV *sv
+
+See L<perlxs> and L<perlxstut> for additional details.
+
+=cut
+
+# ' # Grr
+use strict;
+
+
+my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/;
+my $TEMPLATE_VERSION = '0.01';
+my @ARGS = @ARGV;
+my $compat_version = $];
+
+use Getopt::Long;
+use Config;
+use Text::Wrap;
+$Text::Wrap::huge = 'overflow';
+$Text::Wrap::columns = 80;
+use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);
+use File::Compare;
+use File::Path;
+
+sub usage {
+ warn "@_\n" if @_;
+ die <<EOFUSAGE;
+h2xs [OPTIONS ... ] [headerfile [extra_libraries]]
+version: $H2XS_VERSION
+OPTIONS:
+ -A, --omit-autoload Omit all autoloading facilities (implies -c).
+ -B, --beta-version Use beta \$VERSION of 0.00_01 (ignored if -v).
+ -C, --omit-changes Omit creating the Changes file, add HISTORY heading
+ to stub POD.
+ -F, --cpp-flags Additional flags for C preprocessor/compile.
+ -M, --func-mask Mask to select C functions/macros
+ (default is select all).
+ -O, --overwrite-ok Allow overwriting of a pre-existing extension directory.
+ -P, --omit-pod Omit the stub POD section.
+ -X, --omit-XS Omit the XS portion (implies both -c and -f).
+ -a, --gen-accessors Generate get/set accessors for struct and union members
+ (used with -x).
+ -b, --compat-version Specify a perl version to be backwards compatibile with.
+ -c, --omit-constant Omit the constant() function and specialised AUTOLOAD
+ from the XS file.
+ -d, --debugging Turn on debugging messages.
+ -e, --omit-enums Omit constants from enums in the constant() function.
+ If a pattern is given, only the matching enums are
+ ignored.
+ -f, --force Force creation of the extension even if the C header
+ does not exist.
+ -g, --global Include code for safely storing static data in the .xs file.
+ -h, -?, --help Display this help message.
+ -k, --omit-const-func Omit 'const' attribute on function arguments
+ (used with -x).
+ -m, --gen-tied-var Generate tied variables for access to declared
+ variables.
+ -n, --name Specify a name to use for the extension (recommended).
+ -o, --opaque-re Regular expression for \"opaque\" types.
+ -p, --remove-prefix Specify a prefix which should be removed from the
+ Perl function names.
+ -s, --const-subs Create subroutines for specified macros.
+ -t, --default-type Default type for autoloaded constants (default is IV).
+ --use-new-tests Use Test::More in backward compatible modules.
+ --use-old-tests Use the module Test rather than Test::More.
+ --skip-exporter Do not export symbols.
+ --skip-ppport Do not use portability layer.
+ --skip-autoloader Do not use the module C<AutoLoader>.
+ --skip-strict Do not use the pragma C<strict>.
+ --skip-warnings Do not use the pragma C<warnings>.
+ -v, --version Specify a version number for this extension.
+ -x, --autogen-xsubs Autogenerate XSUBs using C::Scan.
+ --use-xsloader Use XSLoader in backward compatible modules (ignored
+ when used with -X).
+
+extra_libraries
+ are any libraries that might be needed for loading the
+ extension, e.g. -lm would try to link in the math library.
+EOFUSAGE
+}
+
+my ($opt_A,
+ $opt_B,
+ $opt_C,
+ $opt_F,
+ $opt_M,
+ $opt_O,
+ $opt_P,
+ $opt_X,
+ $opt_a,
+ $opt_c,
+ $opt_d,
+ $opt_e,
+ $opt_f,
+ $opt_g,
+ $opt_h,
+ $opt_k,
+ $opt_m,
+ $opt_n,
+ $opt_o,
+ $opt_p,
+ $opt_s,
+ $opt_v,
+ $opt_x,
+ $opt_b,
+ $opt_t,
+ $new_test,
+ $old_test,
+ $skip_exporter,
+ $skip_ppport,
+ $skip_autoloader,
+ $skip_strict,
+ $skip_warnings,
+ $use_xsloader
+ );
+
+Getopt::Long::Configure('bundling');
+Getopt::Long::Configure('pass_through');
+
+my %options = (
+ 'omit-autoload|A' => \$opt_A,
+ 'beta-version|B' => \$opt_B,
+ 'omit-changes|C' => \$opt_C,
+ 'cpp-flags|F=s' => \$opt_F,
+ 'func-mask|M=s' => \$opt_M,
+ 'overwrite_ok|O' => \$opt_O,
+ 'omit-pod|P' => \$opt_P,
+ 'omit-XS|X' => \$opt_X,
+ 'gen-accessors|a' => \$opt_a,
+ 'compat-version|b=s' => \$opt_b,
+ 'omit-constant|c' => \$opt_c,
+ 'debugging|d' => \$opt_d,
+ 'omit-enums|e:s' => \$opt_e,
+ 'force|f' => \$opt_f,
+ 'global|g' => \$opt_g,
+ 'help|h|?' => \$opt_h,
+ 'omit-const-func|k' => \$opt_k,
+ 'gen-tied-var|m' => \$opt_m,
+ 'name|n=s' => \$opt_n,
+ 'opaque-re|o=s' => \$opt_o,
+ 'remove-prefix|p=s' => \$opt_p,
+ 'const-subs|s=s' => \$opt_s,
+ 'default-type|t=s' => \$opt_t,
+ 'version|v=s' => \$opt_v,
+ 'autogen-xsubs|x' => \$opt_x,
+ 'use-new-tests' => \$new_test,
+ 'use-old-tests' => \$old_test,
+ 'skip-exporter' => \$skip_exporter,
+ 'skip-ppport' => \$skip_ppport,
+ 'skip-autoloader' => \$skip_autoloader,
+ 'skip-warnings' => \$skip_warnings,
+ 'skip-strict' => \$skip_strict,
+ 'use-xsloader' => \$use_xsloader,
+ );
+
+GetOptions(%options) || usage;
+
+usage if $opt_h;
+
+if( $opt_b ){
+ usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
+ $opt_b =~ /^v?(\d+)\.(\d+)\.(\d+)/ ||
+ usage "You must provide the backwards compatibility version in X.Y.Z form. "
+ . "(i.e. 5.5.0)\n";
+ my ($maj,$min,$sub) = ($1,$2,$3);
+ if ($maj < 5 || ($maj == 5 && $min < 6)) {
+ $compat_version =
+ $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :
+ sprintf("%d.%03d", $maj,$min);
+ } else {
+ $compat_version = sprintf("%d.%03d%03d",$maj,$min,$sub);
+ }
+} else {
+ my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
+ $sub ||= 0;
+ warn sprintf <<'EOF', $maj,$min,$sub;
+Defaulting to backwards compatibility with perl %d.%d.%d
+If you intend this module to be compatible with earlier perl versions, please
+specify a minimum perl version with the -b option.
+
+EOF
+}
+
+if( $opt_B ){
+ $TEMPLATE_VERSION = '0.00_01';
+}
+
+if( $opt_v ){
+ $TEMPLATE_VERSION = $opt_v;
+
+ # check if it is numeric
+ my $temp_version = $TEMPLATE_VERSION;
+ my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
+ my $notnum;
+ {
+ local $SIG{__WARN__} = sub { $notnum = 1 };
+ use warnings 'numeric';
+ $temp_version = 0+$temp_version;
+ }
+
+ if ($notnum) {
+ my $module = $opt_n || 'Your::Module';
+ warn <<"EOF";
+You have specified a non-numeric version. Unless you supply an
+appropriate VERSION class method, users may not be able to specify a
+minimum required version with C<use $module versionnum>.
+
+EOF
+ }
+ else {
+ $opt_B = $beta_version;
+ }
+}
+
+# -A implies -c.
+$skip_autoloader = $opt_c = 1 if $opt_A;
+
+# -X implies -c and -f
+$opt_c = $opt_f = 1 if $opt_X;
+
+$opt_t ||= 'IV';
+
+my %const_xsub;
+%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+
+my $extralibs = '';
+
+my @path_h;
+
+while (my $arg = shift) {
+ if ($arg =~ /^-l/i) {
+ $extralibs .= "$arg ";
+ next;
+ }
+ last if $extralibs;
+ push(@path_h, $arg);
+}
+
+usage "Must supply header file or module name\n"
+ unless (@path_h or $opt_n);
+
+my $fmask;
+my $tmask;
+
+$fmask = qr{$opt_M} if defined $opt_M;
+$tmask = qr{$opt_o} if defined $opt_o;
+my $tmask_all = $tmask && $opt_o eq '.';
+
+if ($opt_x) {
+ eval {require C::Scan; 1}
+ or die <<EOD;
+C::Scan required if you use -x option.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ unless ($tmask_all) {
+ $C::Scan::VERSION >= 0.70
+ or die <<EOD;
+C::Scan v. 0.70 or later required unless you use -o . option.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ }
+ if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
+ die <<EOD;
+C::Scan v. 0.73 or later required to use -m or -a options.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ }
+}
+elsif ($opt_o or $opt_F) {
+ warn <<EOD if $opt_o;
+Option -o does not make sense without -x.
+EOD
+ warn <<EOD if $opt_F and $opt_X ;
+Option -F does not make sense with -X.
+EOD
+}
+
+my @path_h_ini = @path_h;
+my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
+
+my $module = $opt_n;
+
+if( @path_h ){
+ use File::Spec;
+ my @paths;
+ my $pre_sub_tri_graphs = 1;
+ if ($^O eq 'VMS') { # Consider overrides of default location
+ # XXXX This is not equivalent to what the older version did:
+ # it was looking at $hadsys header-file per header-file...
+ my($hadsys) = grep s!^sys/!!i , @path_h;
+ @paths = qw( Sys$Library VAXC$Include );
+ push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
+ push @paths, qw( DECC$Library_Include DECC$System_Include );
+ }
+ else {
+ @paths = (File::Spec->curdir(), $Config{usrinc},
+ (split ' ', $Config{locincpth}), '/usr/include');
+ }
+ foreach my $path_h (@path_h) {
+ $name ||= $path_h;
+ $module ||= do {
+ $name =~ s/\.h$//;
+ if ( $name !~ /::/ ) {
+ $name =~ s#^.*/##;
+ $name = "\u$name";
+ }
+ $name;
+ };
+
+ if( $path_h =~ s#::#/#g && $opt_n ){
+ warn "Nesting of headerfile ignored with -n\n";
+ }
+ $path_h .= ".h" unless $path_h =~ /\.h$/;
+ my $fullpath = $path_h;
+ $path_h =~ s/,.*$// if $opt_x;
+ $fullpath{$path_h} = $fullpath;
+
+ # Minor trickery: we can't chdir() before we processed the headers
+ # (so know the name of the extension), but the header may be in the
+ # extension directory...
+ my $tmp_path_h = $path_h;
+ my $rel_path_h = $path_h;
+ my @dirs = @paths;
+ if (not -f $path_h) {
+ my $found;
+ for my $dir (@paths) {
+ $found++, last
+ if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
+ }
+ if ($found) {
+ $rel_path_h = $path_h;
+ $fullpath{$path_h} = $fullpath;
+ } else {
+ (my $epath = $module) =~ s,::,/,g;
+ $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
+ $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
+ $path_h = $tmp_path_h; # Used during -x
+ push @dirs, $epath;
+ }
+ }
+
+ if (!$opt_c) {
+ die "Can't find $tmp_path_h in @dirs\n"
+ if ( ! $opt_f && ! -f "$rel_path_h" );
+ # Scan the header file (we should deal with nested header files)
+ # Record the names of simple #define constants into const_names
+ # Function prototypes are processed below.
+ open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
+ defines:
+ while (<CH>) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ s/\?\?=/#/g; # | ??=| #|
+ s/\?\?\!/|/g; # | ??!| ||
+ s/\?\?'/^/g; # | ??'| ^|
+ s/\?\?\(/[/g; # | ??(| [|
+ s/\?\?\)/]/g; # | ??)| ]|
+ s/\?\?\-/~/g; # | ??-| ~|
+ s/\?\?\//\\/g; # | ??/| \|
+ s/\?\?</{/g; # | ??<| {|
+ s/\?\?>/}/g; # | ??>| }|
+ }
+ if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
+ my $def = $1;
+ my $rest = $2;
+ $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
+ $rest =~ s/^\s+//;
+ $rest =~ s/\s+$//;
+ # Cannot do: (-1) and ((LHANDLE)3) are OK:
+ #print("Skip non-wordy $def => $rest\n"),
+ # next defines if $rest =~ /[^\w\$]/;
+ if ($rest =~ /"/) {
+ print("Skip stringy $def => $rest\n") if $opt_d;
+ next defines;
+ }
+ print "Matched $_ ($def)\n" if $opt_d;
+ $seen_define{$def} = $rest;
+ $_ = $def;
+ next if /^_.*_h_*$/i; # special case, but for what?
+ if (defined $opt_p) {
+ if (!/^$opt_p(\d)/) {
+ ++$prefix{$_} if s/^$opt_p//;
+ }
+ else {
+ warn "can't remove $opt_p prefix from '$_'!\n";
+ }
+ }
+ $prefixless{$def} = $_;
+ if (!$fmask or /$fmask/) {
+ print "... Passes mask of -M.\n" if $opt_d and $fmask;
+ $const_names{$_}++;
+ }
+ }
+ }
+ if (defined $opt_e and !$opt_e) {
+ close(CH);
+ }
+ else {
+ # Work from miniperl too - on "normal" systems
+ my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0;
+ seek CH, 0, $SEEK_SET;
+ my $src = do { local $/; <CH> };
+ close CH;
+ no warnings 'uninitialized';
+
+ # Remove C and C++ comments
+ $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
+ $src =~ s#//.*$##gm;
+
+ while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {
+ my ($enum_name, $enum_body) = ($1, $2);
+ # skip enums matching $opt_e
+ next if $opt_e && $enum_name =~ /$opt_e/;
+ my $val = 0;
+ for my $item (split /,/, $enum_body) {
+ next if $item =~ /\A\s*\Z/;
+ my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;
+ $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;
+ $seen_define{$key} = $val;
+ $const_names{$key} = { name => $key, macro => 1 };
+ }
+ } # while (...)
+ } # if (!defined $opt_e or $opt_e)
+ }
+ }
+}
+
+# Save current directory so that C::Scan can use it
+my $cwd = File::Spec->rel2abs( File::Spec->curdir );
+
+# As Ilya suggested, use a name that contains - and then it can't clash with
+# the names of any packages. A directory 'fallback' will clash with any
+# new pragmata down the fallback:: tree, but that seems unlikely.
+my $constscfname = 'const-c.inc';
+my $constsxsfname = 'const-xs.inc';
+my $fallbackdirname = 'fallback';
+
+my $ext = chdir 'ext' ? 'ext/' : '';
+
+my @modparts = split(/::/,$module);
+my $modpname = join('-', @modparts);
+my $modfname = pop @modparts;
+my $modpmdir = join '/', 'lib', @modparts;
+my $modpmname = join '/', $modpmdir, $modfname.'.pm';
+
+if ($opt_O) {
+ warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
+}
+else {
+ die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
+}
+-d "$modpname" || mkpath([$modpname], 0, 0775);
+chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
+
+my %types_seen;
+my %std_types;
+my $fdecls = [];
+my $fdecls_parsed = [];
+my $typedef_rex;
+my %typedefs_pre;
+my %known_fnames;
+my %structs;
+
+my @fnames;
+my @fnames_no_prefix;
+my %vdecl_hash;
+my @vdecls;
+
+if( ! $opt_X ){ # use XS, unless it was disabled
+ unless ($skip_ppport) {
+ require Devel::PPPort;
+ warn "Writing $ext$modpname/ppport.h\n";
+ Devel::PPPort::WriteFile('ppport.h')
+ || die "Can't create $ext$modpname/ppport.h: $!\n";
+ }
+ open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
+ if ($opt_x) {
+ warn "Scanning typemaps...\n";
+ get_typemap();
+ my @td;
+ my @good_td;
+ my $addflags = $opt_F || '';
+
+ foreach my $filename (@path_h) {
+ my $c;
+ my $filter;
+
+ if ($fullpath{$filename} =~ /,/) {
+ $filename = $`;
+ $filter = $';
+ }
+ warn "Scanning $filename for functions...\n";
+ my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
+ $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
+ 'add_cppflags' => $addflags, 'c_styles' => \@styles;
+ $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
+
+ $c->get('keywords')->{'__restrict'} = 1;
+
+ push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
+ push(@$fdecls, @{$c->get('fdecls')});
+
+ push @td, @{$c->get('typedefs_maybe')};
+ if ($opt_a) {
+ my $structs = $c->get('typedef_structs');
+ @structs{keys %$structs} = values %$structs;
+ }
+
+ if ($opt_m) {
+ %vdecl_hash = %{ $c->get('vdecl_hash') };
+ @vdecls = sort keys %vdecl_hash;
+ for (local $_ = 0; $_ < @vdecls; ++$_) {
+ my $var = $vdecls[$_];
+ my($type, $post) = @{ $vdecl_hash{$var} };
+ if (defined $post) {
+ warn "Can't handle variable '$type $var $post', skipping.\n";
+ splice @vdecls, $_, 1;
+ redo;
+ }
+ $type = normalize_type($type);
+ $vdecl_hash{$var} = $type;
+ }
+ }
+
+ unless ($tmask_all) {
+ warn "Scanning $filename for typedefs...\n";
+ my $td = $c->get('typedef_hash');
+ # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
+ my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
+ push @good_td, @f_good_td;
+ @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
+ }
+ }
+ { local $" = '|';
+ $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
+ }
+ %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
+ if ($fmask) {
+ my @good;
+ for my $i (0..$#$fdecls_parsed) {
+ next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
+ push @good, $i;
+ print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
+ if $opt_d;
+ }
+ $fdecls = [@$fdecls[@good]];
+ $fdecls_parsed = [@$fdecls_parsed[@good]];
+ }
+ @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
+ # Sort declarations:
+ {
+ my %h = map( ($_->[1], $_), @$fdecls_parsed);
+ $fdecls_parsed = [ @h{@fnames} ];
+ }
+ @fnames_no_prefix = @fnames;
+ @fnames_no_prefix
+ = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
+ if defined $opt_p;
+ # Remove macros which expand to typedefs
+ print "Typedefs are @td.\n" if $opt_d;
+ my %td = map {($_, $_)} @td;
+ # Add some other possible but meaningless values for macros
+ for my $k (qw(char double float int long short unsigned signed void)) {
+ $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
+ }
+ # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
+ my $n = 0;
+ my %bad_macs;
+ while (keys %td > $n) {
+ $n = keys %td;
+ my ($k, $v);
+ while (($k, $v) = each %seen_define) {
+ # print("found '$k'=>'$v'\n"),
+ $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
+ }
+ }
+ # Now %bad_macs contains names of bad macros
+ for my $k (keys %bad_macs) {
+ delete $const_names{$prefixless{$k}};
+ print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
+ }
+ }
+}
+my (@const_specs, @const_names);
+
+for (sort(keys(%const_names))) {
+ my $v = $const_names{$_};
+
+ push(@const_specs, ref($v) ? $v : $_);
+ push(@const_names, $_);
+}
+
+-d $modpmdir || mkpath([$modpmdir], 0, 0775);
+open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
+
+$" = "\n\t";
+warn "Writing $ext$modpname/$modpmname\n";
+
+print PM <<"END";
+package $module;
+
+use $compat_version;
+END
+
+print PM <<"END" unless $skip_strict;
+use strict;
+END
+
+print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
+
+unless( $opt_X || $opt_c || $opt_A ){
+ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
+ # will want Carp.
+ print PM <<'END';
+use Carp;
+END
+}
+
+print PM <<'END' unless $skip_exporter;
+
+require Exporter;
+END
+
+my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader);
+print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled
+require DynaLoader;
+END
+
+
+# Are we using AutoLoader or not?
+unless ($skip_autoloader) { # no autoloader whatsoever.
+ unless ($opt_c) { # we're doing the AUTOLOAD
+ print PM "use AutoLoader;\n";
+ }
+ else {
+ print PM "use AutoLoader qw(AUTOLOAD);\n"
+ }
+}
+
+if ( $compat_version < 5.006 ) {
+ my $vars = '$VERSION @ISA';
+ $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
+ $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
+ $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
+ print PM "use vars qw($vars);";
+}
+
+# Determine @ISA.
+my @modISA;
+push @modISA, 'Exporter' unless $skip_exporter;
+push @modISA, 'DynaLoader' if $use_Dyna; # no XS
+my $myISA = "our \@ISA = qw(@modISA);";
+$myISA =~ s/^our // if $compat_version < 5.006;
+
+print PM "\n$myISA\n\n";
+
+my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
+
+my $tmp='';
+$tmp .= <<"END" unless $skip_exporter;
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# This allows declaration use $module ':all';
+# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+ @exported_names
+) ] );
+
+our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
+
+our \@EXPORT = qw(
+ @const_names
+);
+
+END
+
+$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
+if ($opt_B) {
+ $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
+ $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n";
+}
+$tmp .= "\n";
+
+$tmp =~ s/^our //mg if $compat_version < 5.006;
+print PM $tmp;
+
+if (@vdecls) {
+ printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
+}
+
+
+print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
+
+if( ! $opt_X ){ # print bootstrap, unless XS is disabled
+ if ($use_Dyna) {
+ $tmp = <<"END";
+bootstrap $module \$VERSION;
+END
+ } else {
+ $tmp = <<"END";
+require XSLoader;
+XSLoader::load('$module', \$VERSION);
+END
+ }
+ $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
+ print PM $tmp;
+}
+
+# tying the variables can happen only after bootstrap
+if (@vdecls) {
+ printf PM <<END;
+{
+@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
+}
+
+END
+}
+
+my $after;
+if( $opt_P ){ # if POD is disabled
+ $after = '__END__';
+}
+else {
+ $after = '=cut';
+}
+
+print PM <<"END";
+
+# Preloaded methods go here.
+END
+
+print PM <<"END" unless $opt_A;
+
+# Autoload methods go after $after, and are processed by the autosplit program.
+END
+
+print PM <<"END";
+
+1;
+__END__
+END
+
+my ($email,$author,$licence);
+
+eval {
+ my $username;
+ ($username,$author) = (getpwuid($>))[0,6];
+ if (defined $username && defined $author) {
+ $author =~ s/,.*$//; # in case of sub fields
+ my $domain = $Config{'mydomain'};
+ $domain =~ s/^\.//;
+ $email = "$username\@$domain";
+ }
+ };
+
+$author =~ s/'/\\'/g if defined $author;
+$author ||= "A. U. Thor";
+$email ||= 'a.u.thor@a.galaxy.far.far.away';
+
+$licence = sprintf << "DEFAULT", $^V;
+Copyright (C) ${\(1900 + (localtime) [5])} by $author
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version %vd or,
+at your option, any later version of Perl 5 you may have available.
+DEFAULT
+
+my $revhist = '';
+$revhist = <<EOT if $opt_C;
+#
+#=head1 HISTORY
+#
+#=over 8
+#
+#=item $TEMPLATE_VERSION
+#
+#Original version; created by h2xs $H2XS_VERSION with options
+#
+# @ARGS
+#
+#=back
+#
+EOT
+
+my $exp_doc = $skip_exporter ? '' : <<EOD;
+#
+#=head2 EXPORT
+#
+#None by default.
+#
+EOD
+
+if (@const_names and not $opt_P) {
+ $exp_doc .= <<EOD unless $skip_exporter;
+#=head2 Exportable constants
+#
+# @{[join "\n ", @const_names]}
+#
+EOD
+}
+
+if (defined $fdecls and @$fdecls and not $opt_P) {
+ $exp_doc .= <<EOD unless $skip_exporter;
+#=head2 Exportable functions
+#
+EOD
+
+# $exp_doc .= <<EOD if $opt_p;
+#When accessing these functions from Perl, prefix C<$opt_p> should be removed.
+#
+#EOD
+ $exp_doc .= <<EOD unless $skip_exporter;
+# @{[join "\n ", @known_fnames{@fnames}]}
+#
+EOD
+}
+
+my $meth_doc = '';
+
+if ($opt_x && $opt_a) {
+ my($name, $struct);
+ $meth_doc .= accessor_docs($name, $struct)
+ while ($name, $struct) = each %structs;
+}
+
+# Prefix the default licence with hash symbols.
+# Is this just cargo cult - it seems that the first thing that happens to this
+# block is that all the hashes are then s///g out.
+my $licence_hash = $licence;
+$licence_hash =~ s/^/#/gm;
+
+my $pod;
+$pod = <<"END" unless $opt_P;
+## Below is stub documentation for your module. You'd better edit it!
+#
+#=head1 NAME
+#
+#$module - Perl extension for blah blah blah
+#
+#=head1 SYNOPSIS
+#
+# use $module;
+# blah blah blah
+#
+#=head1 DESCRIPTION
+#
+#Stub documentation for $module, created by h2xs. It looks like the
+#author of the extension was negligent enough to leave the stub
+#unedited.
+#
+#Blah blah blah.
+$exp_doc$meth_doc$revhist
+#
+#=head1 SEE ALSO
+#
+#Mention other useful documentation such as the documentation of
+#related modules or operating system documentation (such as man pages
+#in UNIX), or any relevant external documentation such as RFCs or
+#standards.
+#
+#If you have a mailing list set up for your module, mention it here.
+#
+#If you have a web site set up for your module, mention it here.
+#
+#=head1 AUTHOR
+#
+#$author, E<lt>${email}E<gt>
+#
+#=head1 COPYRIGHT AND LICENSE
+#
+$licence_hash
+#
+#=cut
+END
+
+$pod =~ s/^\#//gm unless $opt_P;
+print PM $pod unless $opt_P;
+
+close PM;
+
+
+if( ! $opt_X ){ # print XS, unless it is disabled
+warn "Writing $ext$modpname/$modfname.xs\n";
+
+print XS <<"END";
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+END
+
+print XS <<"END" unless $skip_ppport;
+#include "ppport.h"
+
+END
+
+if( @path_h ){
+ foreach my $path_h (@path_h_ini) {
+ my($h) = $path_h;
+ $h =~ s#^/usr/include/##;
+ if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
+ print XS qq{#include <$h>\n};
+ }
+ print XS "\n";
+}
+
+print XS <<"END" if $opt_g;
+
+/* Global Data */
+
+#define MY_CXT_KEY "${module}::_guts" XS_VERSION
+
+typedef struct {
+ /* Put Global Data in here */
+ int dummy; /* you can access this elsewhere as MY_CXT.dummy */
+} my_cxt_t;
+
+START_MY_CXT
+
+END
+
+my %pointer_typedefs;
+my %struct_typedefs;
+
+sub td_is_pointer {
+ my $type = shift;
+ my $out = $pointer_typedefs{$type};
+ return $out if defined $out;
+ my $otype = $type;
+ $out = ($type =~ /\*$/);
+ # This converts only the guys which do not have trailing part in the typedef
+ if (not $out
+ and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type($type);
+ print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
+ if $opt_d;
+ $out = td_is_pointer($type);
+ }
+ return ($pointer_typedefs{$otype} = $out);
+}
+
+sub td_is_struct {
+ my $type = shift;
+ my $out = $struct_typedefs{$type};
+ return $out if defined $out;
+ my $otype = $type;
+ $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
+ # This converts only the guys which do not have trailing part in the typedef
+ if (not $out
+ and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type($type);
+ print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
+ if $opt_d;
+ $out = td_is_struct($type);
+ }
+ return ($struct_typedefs{$otype} = $out);
+}
+
+print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
+
+if( ! $opt_c ) {
+ # We write the "sample" files used when this module is built by perl without
+ # ExtUtils::Constant.
+ # h2xs will later check that these are the same as those generated by the
+ # code embedded into Makefile.PL
+ unless (-d $fallbackdirname) {
+ mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
+ }
+ warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
+ warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
+ my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
+ my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
+ WriteConstants ( C_FILE => $cfallback,
+ XS_FILE => $xsfallback,
+ DEFAULT_TYPE => $opt_t,
+ NAME => $module,
+ NAMES => \@const_specs,
+ );
+ print XS "#include \"$constscfname\"\n";
+}
+
+
+my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
+
+# Now switch from C to XS by issuing the first MODULE declaration:
+print XS <<"END";
+
+MODULE = $module PACKAGE = $module $prefix
+
+END
+
+# If a constant() function was #included then output a corresponding
+# XS declaration:
+print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
+
+print XS <<"END" if $opt_g;
+
+BOOT:
+{
+ MY_CXT_INIT;
+ /* If any of the fields in the my_cxt_t struct need
+ to be initialised, do it here.
+ */
+}
+
+END
+
+foreach (sort keys %const_xsub) {
+ print XS <<"END";
+char *
+$_()
+
+ CODE:
+#ifdef $_
+ RETVAL = $_;
+#else
+ croak("Your vendor has not defined the $module macro $_");
+#endif
+
+ OUTPUT:
+ RETVAL
+
+END
+}
+
+my %seen_decl;
+my %typemap;
+
+sub print_decl {
+ my $fh = shift;
+ my $decl = shift;
+ my ($type, $name, $args) = @$decl;
+ return if $seen_decl{$name}++; # Need to do the same for docs as well?
+
+ my @argnames = map {$_->[1]} @$args;
+ my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
+ if ($opt_k) {
+ s/^\s*const\b\s*// for @argtypes;
+ }
+ my @argarrays = map { $_->[4] || '' } @$args;
+ my $numargs = @$args;
+ if ($numargs and $argtypes[-1] eq '...') {
+ $numargs--;
+ $argnames[-1] = '...';
+ }
+ local $" = ', ';
+ $type = normalize_type($type, 1);
+
+ print $fh <<"EOP";
+
+$type
+$name(@argnames)
+EOP
+
+ for my $arg (0 .. $numargs - 1) {
+ print $fh <<"EOP";
+ $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
+EOP
+ }
+}
+
+sub print_tievar_subs {
+ my($fh, $name, $type) = @_;
+ print $fh <<END;
+I32
+_get_$name(IV index, SV *sv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(sv);
+ PUTBACK;
+ (void)call_pv("$module\::_get_$name", G_DISCARD);
+ return (I32)0;
+}
+
+I32
+_set_$name(IV index, SV *sv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(sv);
+ PUTBACK;
+ (void)call_pv("$module\::_set_$name", G_DISCARD);
+ return (I32)0;
+}
+
+END
+}
+
+sub print_tievar_xsubs {
+ my($fh, $name, $type) = @_;
+ print $fh <<END;
+void
+_tievar_$name(sv)
+ SV* sv
+ PREINIT:
+ struct ufuncs uf;
+ CODE:
+ uf.uf_val = &_get_$name;
+ uf.uf_set = &_set_$name;
+ uf.uf_index = (IV)&_get_$name;
+ sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
+
+void
+_get_$name(THIS)
+ $type THIS = NO_INIT
+ CODE:
+ THIS = $name;
+ OUTPUT:
+ SETMAGIC: DISABLE
+ THIS
+
+void
+_set_$name(THIS)
+ $type THIS
+ CODE:
+ $name = THIS;
+
+END
+}
+
+sub print_accessors {
+ my($fh, $name, $struct) = @_;
+ return unless defined $struct && $name !~ /\s|_ANON/;
+ $name = normalize_type($name);
+ my $ptrname = normalize_type("$name *");
+ print $fh <<"EOF";
+
+MODULE = $module PACKAGE = ${name} $prefix
+
+$name *
+_to_ptr(THIS)
+ $name THIS = NO_INIT
+ PROTOTYPE: \$
+ CODE:
+ if (sv_derived_from(ST(0), "$name")) {
+ STRLEN len;
+ char *s = SvPV((SV*)SvRV(ST(0)), len);
+ if (len != sizeof(THIS))
+ croak("Size \%d of packed data != expected \%d",
+ len, sizeof(THIS));
+ RETVAL = ($name *)s;
+ }
+ else
+ croak("THIS is not of type $name");
+ OUTPUT:
+ RETVAL
+
+$name
+new(CLASS)
+ char *CLASS = NO_INIT
+ PROTOTYPE: \$
+ CODE:
+ Zero((void*)&RETVAL, sizeof(RETVAL), char);
+ OUTPUT:
+ RETVAL
+
+MODULE = $module PACKAGE = ${name}Ptr $prefix
+
+EOF
+ my @items = @$struct;
+ while (@items) {
+ my $item = shift @items;
+ if ($item->[0] =~ /_ANON/) {
+ if (defined $item->[2]) {
+ push @items, map [
+ @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
+ ], @{ $structs{$item->[0]} };
+ } else {
+ push @items, @{ $structs{$item->[0]} };
+ }
+ } else {
+ my $type = normalize_type($item->[0]);
+ my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
+ print $fh <<"EOF";
+$ttype
+$item->[2](THIS, __value = NO_INIT)
+ $ptrname THIS
+ $type __value
+ PROTOTYPE: \$;\$
+ CODE:
+ if (items > 1)
+ THIS->$item->[-1] = __value;
+ RETVAL = @{[
+ $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
+ ]};
+ OUTPUT:
+ RETVAL
+
+EOF
+ }
+ }
+}
+
+sub accessor_docs {
+ my($name, $struct) = @_;
+ return unless defined $struct && $name !~ /\s|_ANON/;
+ $name = normalize_type($name);
+ my $ptrname = $name . 'Ptr';
+ my @items = @$struct;
+ my @list;
+ while (@items) {
+ my $item = shift @items;
+ if ($item->[0] =~ /_ANON/) {
+ if (defined $item->[2]) {
+ push @items, map [
+ @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
+ ], @{ $structs{$item->[0]} };
+ } else {
+ push @items, @{ $structs{$item->[0]} };
+ }
+ } else {
+ push @list, $item->[2];
+ }
+ }
+ my $methods = (join '(...)>, C<', @list) . '(...)';
+
+ my $pod = <<"EOF";
+#
+#=head2 Object and class methods for C<$name>/C<$ptrname>
+#
+#The principal Perl representation of a C object of type C<$name> is an
+#object of class C<$ptrname> which is a reference to an integer
+#representation of a C pointer. To create such an object, one may use
+#a combination
+#
+# my \$buffer = $name->new();
+# my \$obj = \$buffer->_to_ptr();
+#
+#This exersizes the following two methods, and an additional class
+#C<$name>, the internal representation of which is a reference to a
+#packed string with the C structure. Keep in mind that \$buffer should
+#better survive longer than \$obj.
+#
+#=over
+#
+#=item C<\$object_of_type_$name-E<gt>_to_ptr()>
+#
+#Converts an object of type C<$name> to an object of type C<$ptrname>.
+#
+#=item C<$name-E<gt>new()>
+#
+#Creates an empty object of type C<$name>. The corresponding packed
+#string is zeroed out.
+#
+#=item C<$methods>
+#
+#return the current value of the corresponding element if called
+#without additional arguments. Set the element to the supplied value
+#(and return the new value) if called with an additional argument.
+#
+#Applicable to objects of type C<$ptrname>.
+#
+#=back
+#
+EOF
+ $pod =~ s/^\#//gm;
+ return $pod;
+}
+
+# Should be called before any actual call to normalize_type().
+sub get_typemap {
+ # We do not want to read ./typemap by obvios reasons.
+ my @tm = qw(../../../typemap ../../typemap ../typemap);
+ my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
+ unshift @tm, $stdtypemap;
+ my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
+
+ # Start with useful default values
+ $typemap{float} = 'T_NV';
+
+ foreach my $typemap (@tm) {
+ next unless -e $typemap ;
+ # skip directories, binary files etc.
+ warn " Scanning $typemap\n";
+ warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
+ unless -T $typemap ;
+ open(TYPEMAP, $typemap)
+ or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
+ my $mode = 'Typemap';
+ while (<TYPEMAP>) {
+ next if /^\s*\#/;
+ if (/^INPUT\s*$/) { $mode = 'Input'; next; }
+ elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
+ elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
+ elsif ($mode eq 'Typemap') {
+ next if /^\s*($|\#)/ ;
+ my ($type, $image);
+ if ( ($type, $image) =
+ /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
+ # This may reference undefined functions:
+ and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
+ $typemap{normalize_type($type)} = $image;
+ }
+ }
+ }
+ close(TYPEMAP) or die "Cannot close $typemap: $!";
+ }
+ %std_types = %types_seen;
+ %types_seen = ();
+}
+
+
+sub normalize_type { # Second arg: do not strip const's before \*
+ my $type = shift;
+ my $do_keep_deep_const = shift;
+ # If $do_keep_deep_const this is heuristical only
+ my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
+ my $ignore_mods
+ = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
+ if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
+ $type =~ s/$ignore_mods//go;
+ }
+ else {
+ $type =~ s/$ignore_mods//go;
+ }
+ $type =~ s/([^\s\w])/ $1 /g;
+ $type =~ s/\s+$//;
+ $type =~ s/^\s+//;
+ $type =~ s/\s+/ /g;
+ $type =~ s/\* (?=\*)/*/g;
+ $type =~ s/\. \. \./.../g;
+ $type =~ s/ ,/,/g;
+ $types_seen{$type}++
+ unless $type eq '...' or $type eq 'void' or $std_types{$type};
+ $type;
+}
+
+my $need_opaque;
+
+sub assign_typemap_entry {
+ my $type = shift;
+ my $otype = $type;
+ my $entry;
+ if ($tmask and $type =~ /$tmask/) {
+ print "Type $type matches -o mask\n" if $opt_d;
+ $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+ }
+ elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type $type;
+ print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
+ $entry = assign_typemap_entry($type);
+ }
+ # XXX good do better if our UV happens to be long long
+ return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
+ $entry ||= $typemap{$otype}
+ || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+ $typemap{$otype} = $entry;
+ $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
+ return $entry;
+}
+
+for (@vdecls) {
+ print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
+}
+
+if ($opt_x) {
+ for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+ if ($opt_a) {
+ while (my($name, $struct) = each %structs) {
+ print_accessors(\*XS, $name, $struct);
+ }
+ }
+}
+
+close XS;
+
+if (%types_seen) {
+ my $type;
+ warn "Writing $ext$modpname/typemap\n";
+ open TM, ">typemap" or die "Cannot open typemap file for write: $!";
+
+ for $type (sort keys %types_seen) {
+ my $entry = assign_typemap_entry $type;
+ print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
+ }
+
+ print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
+#############################################################################
+INPUT
+T_OPAQUE_STRUCT
+ if (sv_derived_from($arg, \"${ntype}\")) {
+ STRLEN len;
+ char *s = SvPV((SV*)SvRV($arg), len);
+
+ if (len != sizeof($var))
+ croak(\"Size %d of packed data != expected %d\",
+ len, sizeof($var));
+ $var = *($type *)s;
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+#############################################################################
+OUTPUT
+T_OPAQUE_STRUCT
+ sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
+EOP
+
+ close TM or die "Cannot close typemap file for write: $!";
+}
+
+} # if( ! $opt_X )
+
+warn "Writing $ext$modpname/Makefile.PL\n";
+open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
+
+my $prereq_pm = '';
+
+if ( $compat_version < 5.00702 and $new_test )
+{
+ $prereq_pm .= q%'Test::More' => 0, %;
+}
+
+if ( $compat_version < 5.00600 and !$opt_X and $use_xsloader)
+{
+ $prereq_pm .= q%'XSLoader' => 0, %;
+}
+
+print PL <<"END";
+use $compat_version;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => '$module',
+ VERSION_FROM => '$modpmname', # finds \$VERSION
+ PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1
+ (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module
+ AUTHOR => '$author <$email>') : ()),
+END
+if (!$opt_X) { # print C stuff, unless XS is disabled
+ $opt_F = '' unless defined $opt_F;
+ my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
+ my $Ihelp = ($I ? '-I. ' : '');
+ my $Icomment = ($I ? '' : <<EOC);
+ # Insert -I. if you add *.h files later:
+EOC
+
+ print PL <<END;
+ LIBS => ['$extralibs'], # e.g., '-lm'
+ DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING'
+$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other'
+END
+
+ my $C = grep {$_ ne "$modfname.c"}
+ (glob '*.c'), (glob '*.cc'), (glob '*.C');
+ my $Cpre = ($C ? '' : '# ');
+ my $Ccomment = ($C ? '' : <<EOC);
+ # Un-comment this if you add C files to link with later:
+EOC
+
+ print PL <<END;
+$Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too
+END
+} # ' # Grr
+print PL ");\n";
+if (!$opt_c) {
+ my $generate_code =
+ WriteMakefileSnippet ( C_FILE => $constscfname,
+ XS_FILE => $constsxsfname,
+ DEFAULT_TYPE => $opt_t,
+ NAME => $module,
+ NAMES => \@const_specs,
+ );
+ print PL <<"END";
+if (eval {require ExtUtils::Constant; 1}) {
+ # If you edit these definitions to change the constants used by this module,
+ # you will need to use the generated $constscfname and $constsxsfname
+ # files to replace their "fallback" counterparts before distributing your
+ # changes.
+$generate_code
+}
+else {
+ use File::Copy;
+ use File::Spec;
+ foreach my \$file ('$constscfname', '$constsxsfname') {
+ my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
+ copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
+ }
+}
+END
+
+ eval $generate_code;
+ if ($@) {
+ warn <<"EOM";
+Attempting to test constant code in $ext$modpname/Makefile.PL:
+$generate_code
+__END__
+gave unexpected error $@
+Please report the circumstances of this bug in h2xs version $H2XS_VERSION
+using the perlbug script.
+EOM
+ } else {
+ my $fail;
+
+ foreach my $file ($constscfname, $constsxsfname) {
+ my $fallback = File::Spec->catfile($fallbackdirname, $file);
+ if (compare($file, $fallback)) {
+ warn << "EOM";
+Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
+EOM
+ $fail++;
+ }
+ }
+ if ($fail) {
+ warn fill ('','', <<"EOM") . "\n";
+It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
+the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
+correctly.
+
+Please report the circumstances of this bug in h2xs version $H2XS_VERSION
+using the perlbug script.
+EOM
+ } else {
+ unlink $constscfname, $constsxsfname;
+ }
+ }
+}
+close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
+
+# Create a simple README since this is a CPAN requirement
+# and it doesnt hurt to have one
+warn "Writing $ext$modpname/README\n";
+open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
+my $thisyear = (gmtime)[5] + 1900;
+my $rmhead = "$modpname version $TEMPLATE_VERSION";
+my $rmheadeq = "=" x length($rmhead);
+
+my $rm_prereq;
+
+if ( $compat_version < 5.00702 and $new_test )
+{
+ $rm_prereq = 'Test::More';
+}
+else
+{
+ $rm_prereq = 'blah blah blah';
+}
+
+print RM <<_RMEND_;
+$rmhead
+$rmheadeq
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ $rm_prereq
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+$licence
+
+_RMEND_
+close(RM) || die "Can't close $ext$modpname/README: $!\n";
+
+my $testdir = "t";
+my $testfile = "$testdir/$modpname.t";
+unless (-d "$testdir") {
+ mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
+}
+warn "Writing $ext$modpname/$testfile\n";
+my $tests = @const_names ? 2 : 1;
+
+open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
+
+print EX <<_END_;
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl $modpname.t'
+
+#########################
+
+# change 'tests => $tests' to 'tests => last_test_to_print';
+
+_END_
+
+my $test_mod = 'Test::More';
+
+if ( $old_test or ($compat_version < 5.007 and not $new_test ))
+{
+ my $test_mod = 'Test';
+
+ print EX <<_END_;
+use Test;
+BEGIN { plan tests => $tests };
+use $module;
+ok(1); # If we made it this far, we're ok.
+
+_END_
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+my $fail;
+foreach my $constname (qw(
+_END_
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+}
+if (\$fail) {
+ print "not ok 2\\n";
+} else {
+ print "ok 2\\n";
+}
+
+_END_
+ }
+}
+else
+{
+ print EX <<_END_;
+use Test::More tests => $tests;
+BEGIN { use_ok('$module') };
+
+_END_
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+my $fail = 0;
+foreach my $constname (qw(
+_END_
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+
+}
+
+ok( \$fail == 0 , 'Constants' );
+_END_
+ }
+}
+
+print EX <<_END_;
+#########################
+
+# Insert your test code below, the $test_mod module is use()ed here so read
+# its man page ( perldoc $test_mod ) for help writing this test script.
+
+_END_
+
+close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
+
+unless ($opt_C) {
+ warn "Writing $ext$modpname/Changes\n";
+ $" = ' ';
+ open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
+ @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
+ print EX <<EOP;
+Revision history for Perl extension $module.
+
+$TEMPLATE_VERSION @{[scalar localtime]}
+\t- original version; created by h2xs $H2XS_VERSION with options
+\t\t@ARGS
+
+EOP
+ close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
+}
+
+warn "Writing $ext$modpname/MANIFEST\n";
+open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
+my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
+if (!@files) {
+ eval {opendir(D,'.');};
+ unless ($@) { @files = readdir(D); closedir(D); }
+}
+if (!@files) { @files = map {chomp && $_} `ls`; }
+if ($^O eq 'VMS') {
+ foreach (@files) {
+ # Clip trailing '.' for portability -- non-VMS OSs don't expect it
+ s%\.$%%;
+ # Fix up for case-sensitive file systems
+ s/$modfname/$modfname/i && next;
+ $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
+ $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
+ }
+}
+print MANI join("\n",@files), "\n";
+close MANI;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/instmodsh b/Master/tlpkg/tlperl.straw/bin/instmodsh
new file mode 100755
index 00000000000..5874aa61c7a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/instmodsh
@@ -0,0 +1,192 @@
+#!/usr/bin/perl -w
+
+use strict;
+use IO::File;
+use ExtUtils::Packlist;
+use ExtUtils::Installed;
+
+use vars qw($Inst @Modules);
+
+
+=head1 NAME
+
+instmodsh - A shell to examine installed modules
+
+=head1 SYNOPSIS
+
+ instmodsh
+
+=head1 DESCRIPTION
+
+A little interface to ExtUtils::Installed to examine installed modules,
+validate your packlists and even create a tarball from an installed module.
+
+=head1 SEE ALSO
+
+ExtUtils::Installed
+
+=cut
+
+
+my $Module_Help = <<EOF;
+Available commands are:
+ f [all|prog|doc] - List installed files of a given type
+ d [all|prog|doc] - List the directories used by a module
+ v - Validate the .packlist - check for missing files
+ t <tarfile> - Create a tar archive of the module
+ h - Display module help
+ q - Quit the module
+EOF
+
+my %Module_Commands = (
+ f => \&list_installed,
+ d => \&list_directories,
+ v => \&validate_packlist,
+ t => \&create_archive,
+ h => \&module_help,
+ );
+
+sub do_module($) {
+ my ($module) = @_;
+
+ print($Module_Help);
+ MODULE_CMD: while (1) {
+ print("$module cmd? ");
+
+ my $reply = <STDIN>; chomp($reply);
+ my($cmd) = $reply =~ /^(\w)\b/;
+
+ last if $cmd eq 'q';
+
+ if( $Module_Commands{$cmd} ) {
+ $Module_Commands{$cmd}->($reply, $module);
+ }
+ elsif( $cmd eq 'q' ) {
+ last MODULE_CMD;
+ }
+ else {
+ module_help();
+ }
+ }
+}
+
+
+sub list_installed {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @files;
+ if (eval { @files = $Inst->files($module, $class); }) {
+ print("$class files in $module are:\n ",
+ join("\n ", @files), "\n");
+ }
+ else {
+ print($@);
+ }
+};
+
+
+sub list_directories {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @dirs;
+ if (eval { @dirs = $Inst->directories($module, $class); }) {
+ print("$class directories in $module are:\n ",
+ join("\n ", @dirs), "\n");
+ }
+ else {
+ print($@);
+ }
+}
+
+
+sub create_archive {
+ my($reply, $module) = @_;
+
+ my $file = (split(' ', $reply))[1];
+
+ if( !(defined $file and length $file) ) {
+ print "No tar file specified\n";
+ }
+ elsif( eval { require Archive::Tar } ) {
+ Archive::Tar->create_archive($file, 0, $Inst->files($module));
+ }
+ else {
+ my($first, @rest) = $Inst->files($module);
+ system('tar', 'cvf', $file, $first);
+ for my $f (@rest) {
+ system('tar', 'rvf', $file, $f);
+ }
+ print "Can't use tar\n" if $?;
+ }
+}
+
+
+sub validate_packlist {
+ my($reply, $module) = @_;
+
+ if (my @missing = $Inst->validate($module)) {
+ print("Files missing from $module are:\n ",
+ join("\n ", @missing), "\n");
+ }
+ else {
+ print("$module has no missing files\n");
+ }
+}
+
+sub module_help {
+ print $Module_Help;
+}
+
+
+
+##############################################################################
+
+sub toplevel()
+{
+my $help = <<EOF;
+Available commands are:
+ l - List all installed modules
+ m <module> - Select a module
+ q - Quit the program
+EOF
+print($help);
+while (1)
+ {
+ print("cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply eq 'l' and do
+ {
+ print("Installed modules are:\n ", join("\n ", @Modules), "\n");
+ last CASE;
+ };
+ $reply =~ /^m\s+/ and do
+ {
+ do_module((split(' ', $reply))[1]);
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ exit(0);
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+
+###############################################################################
+
+$Inst = ExtUtils::Installed->new();
+@Modules = $Inst->modules();
+toplevel();
+
+###############################################################################
diff --git a/Master/tlpkg/tlperl.straw/bin/instmodsh.bat b/Master/tlpkg/tlperl.straw/bin/instmodsh.bat
new file mode 100755
index 00000000000..c72c0f22199
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/instmodsh.bat
@@ -0,0 +1,208 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+use strict;
+use IO::File;
+use ExtUtils::Packlist;
+use ExtUtils::Installed;
+
+use vars qw($Inst @Modules);
+
+
+=head1 NAME
+
+instmodsh - A shell to examine installed modules
+
+=head1 SYNOPSIS
+
+ instmodsh
+
+=head1 DESCRIPTION
+
+A little interface to ExtUtils::Installed to examine installed modules,
+validate your packlists and even create a tarball from an installed module.
+
+=head1 SEE ALSO
+
+ExtUtils::Installed
+
+=cut
+
+
+my $Module_Help = <<EOF;
+Available commands are:
+ f [all|prog|doc] - List installed files of a given type
+ d [all|prog|doc] - List the directories used by a module
+ v - Validate the .packlist - check for missing files
+ t <tarfile> - Create a tar archive of the module
+ h - Display module help
+ q - Quit the module
+EOF
+
+my %Module_Commands = (
+ f => \&list_installed,
+ d => \&list_directories,
+ v => \&validate_packlist,
+ t => \&create_archive,
+ h => \&module_help,
+ );
+
+sub do_module($) {
+ my ($module) = @_;
+
+ print($Module_Help);
+ MODULE_CMD: while (1) {
+ print("$module cmd? ");
+
+ my $reply = <STDIN>; chomp($reply);
+ my($cmd) = $reply =~ /^(\w)\b/;
+
+ last if $cmd eq 'q';
+
+ if( $Module_Commands{$cmd} ) {
+ $Module_Commands{$cmd}->($reply, $module);
+ }
+ elsif( $cmd eq 'q' ) {
+ last MODULE_CMD;
+ }
+ else {
+ module_help();
+ }
+ }
+}
+
+
+sub list_installed {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @files;
+ if (eval { @files = $Inst->files($module, $class); }) {
+ print("$class files in $module are:\n ",
+ join("\n ", @files), "\n");
+ }
+ else {
+ print($@);
+ }
+};
+
+
+sub list_directories {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @dirs;
+ if (eval { @dirs = $Inst->directories($module, $class); }) {
+ print("$class directories in $module are:\n ",
+ join("\n ", @dirs), "\n");
+ }
+ else {
+ print($@);
+ }
+}
+
+
+sub create_archive {
+ my($reply, $module) = @_;
+
+ my $file = (split(' ', $reply))[1];
+
+ if( !(defined $file and length $file) ) {
+ print "No tar file specified\n";
+ }
+ elsif( eval { require Archive::Tar } ) {
+ Archive::Tar->create_archive($file, 0, $Inst->files($module));
+ }
+ else {
+ my($first, @rest) = $Inst->files($module);
+ system('tar', 'cvf', $file, $first);
+ for my $f (@rest) {
+ system('tar', 'rvf', $file, $f);
+ }
+ print "Can't use tar\n" if $?;
+ }
+}
+
+
+sub validate_packlist {
+ my($reply, $module) = @_;
+
+ if (my @missing = $Inst->validate($module)) {
+ print("Files missing from $module are:\n ",
+ join("\n ", @missing), "\n");
+ }
+ else {
+ print("$module has no missing files\n");
+ }
+}
+
+sub module_help {
+ print $Module_Help;
+}
+
+
+
+##############################################################################
+
+sub toplevel()
+{
+my $help = <<EOF;
+Available commands are:
+ l - List all installed modules
+ m <module> - Select a module
+ q - Quit the program
+EOF
+print($help);
+while (1)
+ {
+ print("cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply eq 'l' and do
+ {
+ print("Installed modules are:\n ", join("\n ", @Modules), "\n");
+ last CASE;
+ };
+ $reply =~ /^m\s+/ and do
+ {
+ do_module((split(' ', $reply))[1]);
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ exit(0);
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+
+###############################################################################
+
+$Inst = ExtUtils::Installed->new();
+@Modules = $Inst->modules();
+toplevel();
+
+###############################################################################
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/json_xs b/Master/tlpkg/tlperl.straw/bin/json_xs
new file mode 100755
index 00000000000..8509f64cf9e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/json_xs
@@ -0,0 +1,179 @@
+#!/opt/bin/perl
+
+=head1 NAME
+
+json_xs - JSON::XS commandline utility
+
+=head1 SYNOPSIS
+
+ json_xs [-v] [-f inputformat] [-t outputformat]
+
+=head1 DESCRIPTION
+
+F<json_xs> converts between some input and output formats (one of them is
+JSON).
+
+The default input format is C<json> and the default output format is
+C<json-pretty>.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -v
+
+Be slightly more verbose.
+
+=item -f fromformat
+
+Read a file in the given format from STDIN.
+
+C<fromformat> can be one of:
+
+=over 4
+
+=item json - a json text encoded, either utf-8, utf16-be/le, utf32-be/le
+
+=item storable - a Storable frozen value
+
+=item storable-file - a Storable file (Storable has two incompatible formats)
+
+=item clzf - Compress::LZF format (requires that module to be installed)
+
+=item yaml - YAML (avoid at all costs, requires the YAML module :)
+
+=back
+
+=item -t toformat
+
+Write the file in the given format to STDOUT.
+
+C<fromformat> can be one of:
+
+=over 4
+
+=item json, json-utf-8 - json, utf-8 encoded
+
+=item json-pretty - as above, but pretty-printed
+
+=item json-utf-16le, json-utf-16be - little endian/big endian utf-16
+
+=item json-utf-32le, json-utf-32be - little endian/big endian utf-32
+
+=item storable - a Storable frozen value in network format
+
+=item storable-file - a Storable file in network format (Storable has two incompatible formats)
+
+=item clzf - Compress::LZF format
+
+=item yaml - YAML
+
+=back
+
+=back
+
+=head1 EXAMPLES
+
+ json_xs -t null <isitreally.json
+
+"JSON Lint" - tries to parse the file F<isitreally.json> as JSON - if it
+is valid JSON, the command outputs nothing, otherwise it will print an
+error message and exit with non-zero exit status.
+
+ <src.json json_xs >pretty.json
+
+Prettify the JSON file F<src.json> to F<dst.json>.
+
+ json_xs -f storable-file <file
+
+Read the serialised Storable file F<file> and print a human-readable JSON
+version of it to STDOUT.
+
+ json_xs -f storable-file -t yaml <file
+
+Same as above, but write YAML instead (not using JSON at all :)
+
+ lwp-request http://cpantesters.perl.org/show/JSON-XS.json | json_xs
+
+Fetch the cpan-testers result summary C<JSON::XS> and pretty-print it.
+
+=head1 AUTHOR
+
+Copyright (C) 2008 Marc Lehmann <json@schmorp.de>
+
+=cut
+
+use strict;
+
+use Getopt::Long;
+use Storable ();
+use Encode;
+
+use JSON::XS;
+
+my $opt_verbose;
+my $opt_from = "json";
+my $opt_to = "json-pretty";
+
+Getopt::Long::Configure ("bundling", "no_ignore_case", "require_order");
+
+GetOptions(
+ "v" => \$opt_verbose,
+ "f=s" => \$opt_from,
+ "t=s" => \$opt_to,
+) or die "Usage: $0 [-v] -f fromformat [-t toformat]\n";
+
+my %F = (
+ "json" => sub {
+ my $enc =
+ /^\x00\x00\x00/s ? "utf-32be"
+ : /^\x00.\x00/s ? "utf-16be"
+ : /^.\x00\x00\x00/s ? "utf-32le"
+ : /^.\x00.\x00/s ? "utf-16le"
+ : "utf-8";
+ warn "input text encoding is $enc\n" if $opt_verbose;
+ JSON::XS->new->decode (decode $enc, $_)
+ },
+ "storable" => sub { Storable::thaw $_ },
+ "storable-file" => sub { open my $fh, "<", \$_; Storable::fd_retrieve $fh },
+ "clzf" => sub { require Compress::LZF; Compress::LZF::sthaw ($_) },
+ "yaml" => sub { require YAML; YAML::Load ($_) },
+);
+
+my %T = (
+ "null" => sub { "" },
+ "json" => sub { encode_json $_ },
+ "json-utf-8" => sub { encode_json $_ },
+ "json-pretty" => sub { JSON::XS->new->utf8->pretty->encode ($_) },
+ "json-utf-16le" => sub { encode "utf-16le", JSON::XS->new->encode ($_) },
+ "json-utf-16be" => sub { encode "utf-16be", JSON::XS->new->encode ($_) },
+ "json-utf-32le" => sub { encode "utf-32le", JSON::XS->new->encode ($_) },
+ "json-utf-32be" => sub { encode "utf-32be", JSON::XS->new->encode ($_) },
+
+ "storable" => sub { Storable::nfreeze $_ },
+ "storable-file" => sub { open my $fh, ">", \my $buf; Storable::nstore_fd $_, $fh; $buf },
+
+ "clzf" => sub { require Compress::LZF; Compress::LZF::sfreeze_cr ($_) },
+ "yaml" => sub { require YAML; YAML::Dump ($_) },
+);
+
+$F{$opt_from}
+ or die "$opt_from: not a valid fromformat\n";
+
+$T{$opt_to}
+ or die "$opt_from: not a valid toformat\n";
+
+{
+ local $/;
+ binmode STDIN; # stupid perl sometimes thinks its funny
+ $_ = <STDIN>;
+}
+
+$_ = $F{$opt_from}->();
+$_ = $T{$opt_to}->();
+
+binmode STDOUT;
+print $_;
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/bin/json_xs.bat b/Master/tlpkg/tlperl.straw/bin/json_xs.bat
new file mode 100755
index 00000000000..306e47e0650
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/json_xs.bat
@@ -0,0 +1,195 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/opt/bin/perl
+#line 15
+
+=head1 NAME
+
+json_xs - JSON::XS commandline utility
+
+=head1 SYNOPSIS
+
+ json_xs [-v] [-f inputformat] [-t outputformat]
+
+=head1 DESCRIPTION
+
+F<json_xs> converts between some input and output formats (one of them is
+JSON).
+
+The default input format is C<json> and the default output format is
+C<json-pretty>.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -v
+
+Be slightly more verbose.
+
+=item -f fromformat
+
+Read a file in the given format from STDIN.
+
+C<fromformat> can be one of:
+
+=over 4
+
+=item json - a json text encoded, either utf-8, utf16-be/le, utf32-be/le
+
+=item storable - a Storable frozen value
+
+=item storable-file - a Storable file (Storable has two incompatible formats)
+
+=item clzf - Compress::LZF format (requires that module to be installed)
+
+=item yaml - YAML (avoid at all costs, requires the YAML module :)
+
+=back
+
+=item -t toformat
+
+Write the file in the given format to STDOUT.
+
+C<fromformat> can be one of:
+
+=over 4
+
+=item json, json-utf-8 - json, utf-8 encoded
+
+=item json-pretty - as above, but pretty-printed
+
+=item json-utf-16le, json-utf-16be - little endian/big endian utf-16
+
+=item json-utf-32le, json-utf-32be - little endian/big endian utf-32
+
+=item storable - a Storable frozen value in network format
+
+=item storable-file - a Storable file in network format (Storable has two incompatible formats)
+
+=item clzf - Compress::LZF format
+
+=item yaml - YAML
+
+=back
+
+=back
+
+=head1 EXAMPLES
+
+ json_xs -t null <isitreally.json
+
+"JSON Lint" - tries to parse the file F<isitreally.json> as JSON - if it
+is valid JSON, the command outputs nothing, otherwise it will print an
+error message and exit with non-zero exit status.
+
+ <src.json json_xs >pretty.json
+
+Prettify the JSON file F<src.json> to F<dst.json>.
+
+ json_xs -f storable-file <file
+
+Read the serialised Storable file F<file> and print a human-readable JSON
+version of it to STDOUT.
+
+ json_xs -f storable-file -t yaml <file
+
+Same as above, but write YAML instead (not using JSON at all :)
+
+ lwp-request http://cpantesters.perl.org/show/JSON-XS.json | json_xs
+
+Fetch the cpan-testers result summary C<JSON::XS> and pretty-print it.
+
+=head1 AUTHOR
+
+Copyright (C) 2008 Marc Lehmann <json@schmorp.de>
+
+=cut
+
+use strict;
+
+use Getopt::Long;
+use Storable ();
+use Encode;
+
+use JSON::XS;
+
+my $opt_verbose;
+my $opt_from = "json";
+my $opt_to = "json-pretty";
+
+Getopt::Long::Configure ("bundling", "no_ignore_case", "require_order");
+
+GetOptions(
+ "v" => \$opt_verbose,
+ "f=s" => \$opt_from,
+ "t=s" => \$opt_to,
+) or die "Usage: $0 [-v] -f fromformat [-t toformat]\n";
+
+my %F = (
+ "json" => sub {
+ my $enc =
+ /^\x00\x00\x00/s ? "utf-32be"
+ : /^\x00.\x00/s ? "utf-16be"
+ : /^.\x00\x00\x00/s ? "utf-32le"
+ : /^.\x00.\x00/s ? "utf-16le"
+ : "utf-8";
+ warn "input text encoding is $enc\n" if $opt_verbose;
+ JSON::XS->new->decode (decode $enc, $_)
+ },
+ "storable" => sub { Storable::thaw $_ },
+ "storable-file" => sub { open my $fh, "<", \$_; Storable::fd_retrieve $fh },
+ "clzf" => sub { require Compress::LZF; Compress::LZF::sthaw ($_) },
+ "yaml" => sub { require YAML; YAML::Load ($_) },
+);
+
+my %T = (
+ "null" => sub { "" },
+ "json" => sub { encode_json $_ },
+ "json-utf-8" => sub { encode_json $_ },
+ "json-pretty" => sub { JSON::XS->new->utf8->pretty->encode ($_) },
+ "json-utf-16le" => sub { encode "utf-16le", JSON::XS->new->encode ($_) },
+ "json-utf-16be" => sub { encode "utf-16be", JSON::XS->new->encode ($_) },
+ "json-utf-32le" => sub { encode "utf-32le", JSON::XS->new->encode ($_) },
+ "json-utf-32be" => sub { encode "utf-32be", JSON::XS->new->encode ($_) },
+
+ "storable" => sub { Storable::nfreeze $_ },
+ "storable-file" => sub { open my $fh, ">", \my $buf; Storable::nstore_fd $_, $fh; $buf },
+
+ "clzf" => sub { require Compress::LZF; Compress::LZF::sfreeze_cr ($_) },
+ "yaml" => sub { require YAML; YAML::Dump ($_) },
+);
+
+$F{$opt_from}
+ or die "$opt_from: not a valid fromformat\n";
+
+$T{$opt_to}
+ or die "$opt_from: not a valid toformat\n";
+
+{
+ local $/;
+ binmode STDIN; # stupid perl sometimes thinks its funny
+ $_ = <STDIN>;
+}
+
+$_ = $F{$opt_from}->();
+$_ = $T{$opt_to}->();
+
+binmode STDOUT;
+print $_;
+
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/largeprimes b/Master/tlpkg/tlperl.straw/bin/largeprimes
new file mode 100755
index 00000000000..498bfbe9462
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/largeprimes
@@ -0,0 +1,68 @@
+#!/usr/bin/perl -sI.. -I../lib/ -Ilib/
+##
+## largeprimes -- generates large provable primes, uniformally distributed
+## in random intervals, with maurer's recursive algorithm.
+##
+## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id$
+
+
+use Crypt::Primes;
+
+unless ( $bitsize ) {
+ print "$0 -bitsize=bits -num=number_of_primes -v=verbosity\n\n";
+ exit 0;
+}
+
+for ( $i=0; $i <= $num; $i++ ) {
+ my $prime = Crypt::Primes::maurer Size => $bitsize,
+ Verbosity => $v,
+ Generator => $generator;
+ my $g = 0;
+ if ( ref $prime eq 'HASH') {
+ $g = $prime->{Generator};
+ $prime = $prime->{Prime};
+ }
+
+ if ($t) { print "$prime\n" } else {
+ print "\n" if $v;
+ print "random $bitsize bit prime: $prime";
+ print ", $g" if $g;
+ print "\n";
+ }
+}
+
+=head1 NAME
+
+largeprimes -- generate large, random primes using Crypt::Primes.
+
+=head1 SYNOPSIS
+
+ largeprimes -bitsize=128 -v
+ largeprimes -bitsize=512 -v=2
+ largeprimes -bitsize=512 -v -num=10
+ largeprimes -bitsize=1024 -generator -v
+
+=head1 DESCRIPTION
+
+largeprimes generates a provable prime of specified bitsize and prints it on
+STDOUT. For more details see Crypt::Primes(3) manpage.
+
+=head1 SEE ALSO
+
+Crypt::Primes(3)
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, mail@vipul.net
+
+=head1 LICENSE
+
+Artistic.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/bin/largeprimes.bat b/Master/tlpkg/tlperl.straw/bin/largeprimes.bat
new file mode 100755
index 00000000000..81b48044af1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/largeprimes.bat
@@ -0,0 +1,84 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -sI.. -I../lib/ -Ilib/
+#line 15
+##
+## largeprimes -- generates large provable primes, uniformally distributed
+## in random intervals, with maurer's recursive algorithm.
+##
+## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id$
+
+
+use Crypt::Primes;
+
+unless ( $bitsize ) {
+ print "$0 -bitsize=bits -num=number_of_primes -v=verbosity\n\n";
+ exit 0;
+}
+
+for ( $i=0; $i <= $num; $i++ ) {
+ my $prime = Crypt::Primes::maurer Size => $bitsize,
+ Verbosity => $v,
+ Generator => $generator;
+ my $g = 0;
+ if ( ref $prime eq 'HASH') {
+ $g = $prime->{Generator};
+ $prime = $prime->{Prime};
+ }
+
+ if ($t) { print "$prime\n" } else {
+ print "\n" if $v;
+ print "random $bitsize bit prime: $prime";
+ print ", $g" if $g;
+ print "\n";
+ }
+}
+
+=head1 NAME
+
+largeprimes -- generate large, random primes using Crypt::Primes.
+
+=head1 SYNOPSIS
+
+ largeprimes -bitsize=128 -v
+ largeprimes -bitsize=512 -v=2
+ largeprimes -bitsize=512 -v -num=10
+ largeprimes -bitsize=1024 -generator -v
+
+=head1 DESCRIPTION
+
+largeprimes generates a provable prime of specified bitsize and prints it on
+STDOUT. For more details see Crypt::Primes(3) manpage.
+
+=head1 SEE ALSO
+
+Crypt::Primes(3)
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, mail@vipul.net
+
+=head1 LICENSE
+
+Artistic.
+
+=cut
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/libnetcfg.bat b/Master/tlpkg/tlperl.straw/bin/libnetcfg.bat
new file mode 100755
index 00000000000..aacd5fe7490
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/libnetcfg.bat
@@ -0,0 +1,737 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+=head1 NAME
+
+libnetcfg - configure libnet
+
+=head1 DESCRIPTION
+
+The libnetcfg utility can be used to configure the libnet.
+Starting from perl 5.8 libnet is part of the standard Perl
+distribution, but the libnetcfg can be used for any libnet
+installation.
+
+=head1 USAGE
+
+Without arguments libnetcfg displays the current configuration.
+
+ $ libnetcfg
+ # old config ./libnet.cfg
+ daytime_hosts ntp1.none.such
+ ftp_int_passive 0
+ ftp_testhost ftp.funet.fi
+ inet_domain none.such
+ nntp_hosts nntp.none.such
+ ph_hosts
+ pop3_hosts pop.none.such
+ smtp_hosts smtp.none.such
+ snpp_hosts
+ test_exist 1
+ test_hosts 1
+ time_hosts ntp.none.such
+ # libnetcfg -h for help
+ $
+
+It tells where the old configuration file was found (if found).
+
+The C<-h> option will show a usage message.
+
+To change the configuration you will need to use either the C<-c> or
+the C<-d> options.
+
+The default name of the old configuration file is by default
+"libnet.cfg", unless otherwise specified using the -i option,
+C<-i oldfile>, and it is searched first from the current directory,
+and then from your module path.
+
+The default name of the new configuration file is "libnet.cfg", and by
+default it is written to the current directory, unless otherwise
+specified using the -o option, C<-o newfile>.
+
+=head1 SEE ALSO
+
+L<Net::Config>, L<Net::libnetFAQ>
+
+=head1 AUTHORS
+
+Graham Barr, the original Configure script of libnet.
+
+Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
+
+=cut
+
+# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
+
+use strict;
+use IO::File;
+use Getopt::Std;
+use ExtUtils::MakeMaker qw(prompt);
+use File::Spec;
+
+use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
+
+##
+##
+##
+
+my %cfg = ();
+my @cfg = ();
+
+my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
+
+##
+##
+##
+
+sub valid_host
+{
+ my $h = shift;
+
+ defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
+}
+
+##
+##
+##
+
+sub test_hostnames (\@)
+{
+ my $hlist = shift;
+ my @h = ();
+ my $host;
+ my $err = 0;
+
+ foreach $host (@$hlist)
+ {
+ if(valid_host($host))
+ {
+ push(@h, $host);
+ next;
+ }
+ warn "Bad hostname: '$host'\n";
+ $err++;
+ }
+ @$hlist = @h;
+ $err ? join(" ",@h) : undef;
+}
+
+##
+##
+##
+
+sub Prompt
+{
+ my($prompt,$def) = @_;
+
+ $def = "" unless defined $def;
+
+ chomp($prompt);
+
+ if($opt_d)
+ {
+ print $prompt,," [",$def,"]\n";
+ return $def;
+ }
+ prompt($prompt,$def);
+}
+
+##
+##
+##
+
+sub get_host_list
+{
+ my($prompt,$def) = @_;
+
+ $def = join(" ",@$def) if ref($def);
+
+ my @hosts;
+
+ do
+ {
+ my $ans = Prompt($prompt,$def);
+
+ $ans =~ s/(\A\s+|\s+\Z)//g;
+
+ @hosts = split(/\s+/, $ans);
+ }
+ while(@hosts && defined($def = test_hostnames(@hosts)));
+
+ \@hosts;
+}
+
+##
+##
+##
+
+sub get_hostname
+{
+ my($prompt,$def) = @_;
+
+ my $host;
+
+ while(1)
+ {
+ my $ans = Prompt($prompt,$def);
+ $host = ($ans =~ /(\S*)/)[0];
+ last
+ if(!length($host) || valid_host($host));
+
+ $def =""
+ if $def eq $host;
+
+ print <<"EDQ";
+
+*** ERROR:
+ Hostname `$host' does not seem to exist, please enter again
+ or a single space to clear any default
+
+EDQ
+ }
+
+ length $host
+ ? $host
+ : undef;
+}
+
+##
+##
+##
+
+sub get_bool ($$)
+{
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my $val = Prompt($prompt,$def ? "yes" : "no");
+
+ $val =~ /^y/i ? 1 : 0;
+}
+
+##
+##
+##
+
+sub get_netmask ($$)
+{
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my %list;
+ @list{@$def} = ();
+
+MASK:
+ while(1) {
+ my $bad = 0;
+ my $ans = Prompt($prompt) or last;
+
+ if($ans eq '*') {
+ %list = ();
+ next;
+ }
+
+ if($ans eq '=') {
+ print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
+ next;
+ }
+
+ unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
+ warn "Bad netmask '$ans'\n";
+ next;
+ }
+
+ my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0);
+ if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ foreach my $byte (@ip) {
+ if ( $byte > 255 ) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ }
+
+ my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits);
+
+ if ($remove) {
+ delete $list{$mask};
+ }
+ else {
+ $list{$mask} = 1;
+ }
+
+ }
+
+ [ keys %list ];
+}
+
+##
+##
+##
+
+sub default_hostname
+{
+ my $host;
+ my @host;
+
+ foreach $host (@_)
+ {
+ if(defined($host) && valid_host($host))
+ {
+ return $host
+ unless wantarray;
+ push(@host,$host);
+ }
+ }
+
+ return wantarray ? @host : undef;
+}
+
+##
+##
+##
+
+getopts('dcho:i:');
+
+$libnet_cfg_in = "libnet.cfg"
+ unless(defined($libnet_cfg_in = $opt_i));
+
+$libnet_cfg_out = "libnet.cfg"
+ unless(defined($libnet_cfg_out = $opt_o));
+
+my %oldcfg = ();
+
+$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
+if( -f $libnet_cfg_in )
+ {
+ %oldcfg = ( %{ do $libnet_cfg_in } );
+ }
+elsif (eval { require Net::Config })
+ {
+ $have_old = 1;
+ %oldcfg = %Net::Config::NetConfig;
+ }
+
+map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
+
+#---------------------------------------------------------------------------
+
+if ($opt_h) {
+ print <<EOU;
+$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
+Without options, the old configuration is shown.
+
+ -c change the configuration
+ -d use defaults from the old config (implies -c, non-interactive)
+ -i use a specific file as the old config file
+ -o use a specific file as the new config file
+ -h show this help
+
+The default name of the old configuration file is by default
+"libnet.cfg", unless otherwise specified using the -i option,
+C<-i oldfile>, and it is searched first from the current directory,
+and then from your module path.
+
+The default name of the new configuration file is "libnet.cfg", and by
+default it is written to the current directory, unless otherwise
+specified using the -o option.
+
+EOU
+ exit(0);
+}
+
+#---------------------------------------------------------------------------
+
+{
+ my $oldcfgfile;
+ my @inc;
+ push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
+ push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB};
+ push @inc, @INC;
+ for (@inc) {
+ my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
+ if (-f $trycfgfile && -r $trycfgfile) {
+ $oldcfgfile = $trycfgfile;
+ last;
+ }
+ }
+ print "# old config $oldcfgfile\n" if defined $oldcfgfile;
+ for (sort keys %oldcfg) {
+ printf "%-20s %s\n", $_,
+ ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
+ }
+ unless ($opt_c || $opt_d) {
+ print "# $0 -h for help\n";
+ exit(0);
+ }
+}
+
+#---------------------------------------------------------------------------
+
+$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
+$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
+
+#---------------------------------------------------------------------------
+
+if($have_old && !$opt_d)
+ {
+ $msg = <<EDQ;
+
+Ah, I see you already have installed libnet before.
+
+Do you want to modify/update your configuration (y|n) ?
+EDQ
+
+ $opt_d = 1
+ unless get_bool($msg,0);
+ }
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+This script will prompt you to enter hostnames that can be used as
+defaults for some of the modules in the libnet distribution.
+
+To ensure that you do not enter an invalid hostname, I can perform a
+lookup on each hostname you enter. If your internet connection is via
+a dialup line then you may not want me to perform these lookups, as
+it will require you to be on-line.
+
+Do you want me to perform hostname lookups (y|n) ?
+EDQ
+
+$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
+
+print <<EDQ unless $cfg{'test_exist'};
+
+*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+
+OK I will not check if the hostnames you give are valid
+so be very cafeful
+
+*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+EDQ
+
+
+#---------------------------------------------------------------------------
+
+print <<EDQ;
+
+The following questions all require a list of host names, separated
+with spaces. If you do not have a host available for any of the
+services, then enter a single space, followed by <CR>. To accept the
+default, hit <CR>
+
+EDQ
+
+$msg = 'Enter a list of available NNTP hosts :';
+
+$def = $oldcfg{'nntp_hosts'} ||
+ [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
+
+$cfg{'nntp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available SMTP hosts :';
+
+$def = $oldcfg{'smtp_hosts'} ||
+ [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
+
+$cfg{'smtp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available POP3 hosts :';
+
+$def = $oldcfg{'pop3_hosts'} || [];
+
+$cfg{'pop3_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available SNPP hosts :';
+
+$def = $oldcfg{'snpp_hosts'} || [];
+
+$cfg{'snpp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available PH Hosts :' ;
+
+$def = $oldcfg{'ph_hosts'} ||
+ [ default_hostname('dirserv') ];
+
+$cfg{'ph_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available TIME Hosts :' ;
+
+$def = $oldcfg{'time_hosts'} || [];
+
+$cfg{'time_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available DAYTIME Hosts :' ;
+
+$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
+
+$cfg{'daytime_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+Do you have a firewall/ftp proxy between your machine and the internet
+
+If you use a SOCKS firewall answer no
+
+(y|n) ?
+EDQ
+
+if(get_bool($msg,0)) {
+
+ $msg = <<'EDQ';
+What series of FTP commands do you need to send to your
+firewall to connect to an external host.
+
+user/pass => external user & password
+fwuser/fwpass => firewall user & password
+
+0) None
+1) -----------------------
+ USER user@remote.host
+ PASS pass
+2) -----------------------
+ USER fwuser
+ PASS fwpass
+ USER user@remote.host
+ PASS pass
+3) -----------------------
+ USER fwuser
+ PASS fwpass
+ SITE remote.site
+ USER user
+ PASS pass
+4) -----------------------
+ USER fwuser
+ PASS fwpass
+ OPEN remote.site
+ USER user
+ PASS pass
+5) -----------------------
+ USER user@fwuser@remote.site
+ PASS pass@fwpass
+6) -----------------------
+ USER fwuser@remote.site
+ PASS fwpass
+ USER user
+ PASS pass
+7) -----------------------
+ USER user@remote.host
+ PASS pass
+ AUTH fwuser
+ RESP fwpass
+
+Choice:
+EDQ
+ $def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1;
+ $ans = Prompt($msg,$def);
+ $cfg{'ftp_firewall_type'} = 0+$ans;
+ $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
+
+ $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
+}
+else {
+ delete $cfg{'ftp_firewall'};
+}
+
+
+#---------------------------------------------------------------------------
+
+if (defined $cfg{'ftp_firewall'})
+ {
+ print <<EDQ;
+
+By default Net::FTP assumes that it only needs to use a firewall if it
+cannot resolve the name of the host given. This only works if your DNS
+system is setup to only resolve internal hostnames. If this is not the
+case and your DNS will resolve external hostnames, then another method
+is needed. Net::Config can do this if you provide the netmasks that
+describe your internal network. Each netmask should be entered in the
+form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
+
+EDQ
+$def = [];
+if(ref($oldcfg{'local_netmask'}))
+ {
+ $def = $oldcfg{'local_netmask'};
+ print "Your current netmasks are :\n\n\t",
+ join("\n\t",@{$def}),"\n\n";
+ }
+
+print "
+Enter one netmask at each prompt, prefix with a - to remove a netmask
+from the list, enter a '*' to clear the whole list, an '=' to show the
+current list and an empty line to continue with Configure.
+
+";
+
+ my $mask = get_netmask("netmask :",$def);
+ $cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
+ }
+
+#---------------------------------------------------------------------------
+
+###$msg =<<EDQ;
+###
+###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
+###then enter a list of hostames
+###
+###Enter a list of available SOCKS hosts :
+###EDQ
+###
+###$def = $cfg{'socks_hosts'} ||
+### [ default_hostname($ENV{SOCKS5_SERVER},
+### $ENV{SOCKS_SERVER},
+### $ENV{SOCKS4_SERVER}) ];
+###
+###$cfg{'socks_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+print <<EDQ;
+
+Normally when FTP needs a data connection the client tells the server
+a port to connect to, and the server initiates a connection to the client.
+
+Some setups, in particular firewall setups, can/do not work using this
+protocol. In these situations the client must make the connection to the
+server, this is called a passive transfer.
+EDQ
+
+if (defined $cfg{'ftp_firewall'}) {
+ $msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
+
+ $def = $oldcfg{'ftp_ext_passive'} || 0;
+
+ $cfg{'ftp_ext_passive'} = get_bool($msg,$def);
+
+ $msg = "\nShould all other FTP connections be passive (y|n) ?";
+
+}
+else {
+ $msg = "\nShould all FTP connections be passive (y|n) ?";
+}
+
+$def = $oldcfg{'ftp_int_passive'} || 0;
+
+$cfg{'ftp_int_passive'} = get_bool($msg,$def);
+
+
+#---------------------------------------------------------------------------
+
+$def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
+
+$ans = Prompt("\nWhat is your local internet domain name :",$def);
+
+$cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+If you specified some default hosts above, it is possible for me to
+do some basic tests when you run `make test'
+
+This will cause `make test' to be quite a bit slower and, if your
+internet connection is via dialup, will require you to be on-line
+unless the hosts are local.
+
+Do you want me to run these tests (y|n) ?
+EDQ
+
+$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+To allow Net::FTP to be tested I will need a hostname. This host
+should allow anonymous access and have a /pub directory
+
+What host can I use :
+EDQ
+
+$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
+ if $cfg{'test_hosts'};
+
+
+print "\n";
+
+#---------------------------------------------------------------------------
+
+my $fh = IO::File->new($libnet_cfg_out, "w") or
+ die "Cannot create `$libnet_cfg_out': $!";
+
+print "Writing $libnet_cfg_out\n";
+
+print $fh "{\n";
+
+my $key;
+foreach $key (keys %cfg) {
+ my $val = $cfg{$key};
+ if(!defined($val)) {
+ $val = "undef";
+ }
+ elsif(ref($val)) {
+ $val = '[' . join(",",
+ map {
+ my $v = "undef";
+ if(defined $_) {
+ ($v = $_) =~ s/'/\'/sog;
+ $v = "'" . $v . "'";
+ }
+ $v;
+ } @$val ) . ']';
+ }
+ else {
+ $val =~ s/'/\'/sog;
+ $val = "'" . $val . "'" if $val =~ /\D/;
+ }
+ print $fh "\t'",$key,"' => ",$val,",\n";
+}
+
+print $fh "}\n";
+
+$fh->close;
+
+############################################################################
+############################################################################
+
+exit 0;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-download b/Master/tlpkg/tlperl.straw/bin/lwp-download
new file mode 100755
index 00000000000..a85ac551d9f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-download
@@ -0,0 +1,320 @@
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+lwp-download - Fetch large files from the web
+
+=head1 SYNOPSIS
+
+B<lwp-download> [B<-a>] <I<url>> [<I<local path>>]
+
+=head1 DESCRIPTION
+
+The B<lwp-download> program will save the file at I<url> to a local
+file.
+
+If I<local path> is not specified, then the current directory is
+assumed.
+
+If I<local path> is a directory, then the basename of the file to save
+is picked up from the Content-Disposition header or the URL of the
+response. If the file already exists, then B<lwp-download> will
+prompt before it overwrites and will fail if its standard input is not
+a terminal. This form of invocation will also fail is no acceptable
+filename can be derived from the sources mentioned above.
+
+If I<local path> is not a directory, then it is simply used as the
+path to save into.
+
+The I<lwp-download> program is implemented using the I<libwww-perl>
+library. It is better suited to down load big files than the
+I<lwp-request> program because it does not store the file in memory.
+Another benefit is that it will keep you updated about its progress
+and that you don't have much options to worry about.
+
+Use the C<-a> option to save the file in text (ascii) mode. Might
+make a difference on dosish systems.
+
+=head1 EXAMPLE
+
+Fetch the newest and greatest perl version:
+
+ $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz
+ Saving to 'latest.tar.gz'...
+ 11.4 MB received in 8 seconds (1.43 MB/sec)
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+#' get emacs out of quote mode
+
+use strict;
+
+use LWP::UserAgent ();
+use LWP::MediaTypes qw(guess_media_type media_suffix);
+use URI ();
+use HTTP::Date ();
+
+my $progname = $0;
+$progname =~ s,.*/,,; # only basename left in progname
+$progname =~ s,.*\\,, if $^O eq "MSWin32";
+$progname =~ s/\.\w*$//; # strip extension if any
+
+#parse option
+use Getopt::Std;
+my %opt;
+unless (getopts('a', \%opt)) {
+ usage();
+}
+
+my $url = URI->new(shift || usage());
+my $argfile = shift;
+usage() if defined($argfile) && !length($argfile);
+my $VERSION = "5.827";
+
+my $ua = LWP::UserAgent->new(
+ agent => "lwp-download/$VERSION ",
+ keep_alive => 1,
+ env_proxy => 1,
+);
+
+my $file; # name of file we download into
+my $length; # total number of bytes to download
+my $flength; # formatted length
+my $size = 0; # number of bytes received
+my $start_t; # start time of download
+my $last_dur; # time of last callback
+
+my $shown = 0; # have we called the show() function yet
+
+$SIG{INT} = sub { die "Interrupted\n"; };
+
+$| = 1; # autoflush
+
+my $res = $ua->request(HTTP::Request->new(GET => $url),
+ sub {
+ unless(defined $file) {
+ my $res = $_[1];
+
+ my $directory;
+ if (defined $argfile && -d $argfile) {
+ ($directory, $argfile) = ($argfile, undef);
+ }
+
+ unless (defined $argfile) {
+ # find a suitable name to use
+ $file = $res->filename;
+
+ # if this fails we try to make something from the URL
+ unless ($file) {
+ my $req = $res->request; # not always there
+ my $rurl = $req ? $req->uri : $url;
+
+ $file = ($rurl->path_segments)[-1];
+ if (!defined($file) || !length($file)) {
+ $file = "index";
+ my $suffix = media_suffix($res->content_type);
+ $file .= ".$suffix" if $suffix;
+ }
+ elsif ($rurl->scheme eq 'ftp' ||
+ $file =~ /\.t[bg]z$/ ||
+ $file =~ /\.tar(\.(Z|gz|bz2?))?$/
+ ) {
+ # leave the filename as it was
+ }
+ else {
+ my $ct = guess_media_type($file);
+ unless ($ct eq $res->content_type) {
+ # need a better suffix for this type
+ my $suffix = media_suffix($res->content_type);
+ $file .= ".$suffix" if $suffix;
+ }
+ }
+ }
+
+ # validate that we don't have a harmful filename now. The server
+ # might try to trick us into doing something bad.
+ if (!length($file) ||
+ $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge)
+ {
+ die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n";
+ }
+
+ if (defined $directory) {
+ require File::Spec;
+ $file = File::Spec->catfile($directory, $file);
+ }
+
+ # Check if the file is already present
+ if (-l $file) {
+ die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n";
+ }
+ elsif (-f _) {
+ die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n"
+ unless -t;
+ $shown = 1;
+ print "Overwrite $file? [y] ";
+ my $ans = <STDIN>;
+ unless (defined($ans) && $ans =~ /^y?\n/) {
+ if (defined $ans) {
+ print "Ok, aborting.\n";
+ }
+ else {
+ print "\nAborting.\n";
+ }
+ exit 1;
+ }
+ $shown = 0;
+ }
+ elsif (-e _) {
+ die "Will not save <$url> as \"$file\". Path exists.\n";
+ }
+ else {
+ print "Saving to '$file'...\n";
+ }
+ }
+ else {
+ $file = $argfile;
+ }
+ open(FILE, ">$file") || die "Can't open $file: $!\n";
+ binmode FILE unless $opt{a};
+ $length = $res->content_length;
+ $flength = fbytes($length) if defined $length;
+ $start_t = time;
+ $last_dur = 0;
+ }
+
+ print FILE $_[0] or die "Can't write to $file: $!\n";
+ $size += length($_[0]);
+
+ if (defined $length) {
+ my $dur = time - $start_t;
+ if ($dur != $last_dur) { # don't update too often
+ $last_dur = $dur;
+ my $perc = $size / $length;
+ my $speed;
+ $speed = fbytes($size/$dur) . "/sec" if $dur > 3;
+ my $secs_left = fduration($dur/$perc - $dur);
+ $perc = int($perc*100);
+ my $show = "$perc% of $flength";
+ $show .= " (at $speed, $secs_left remaining)" if $speed;
+ show($show, 1);
+ }
+ }
+ else {
+ show( fbytes($size) . " received");
+ }
+ }
+);
+
+if (fileno(FILE)) {
+ close(FILE) || die "Can't write to $file: $!\n";
+
+ show(""); # clear text
+ print "\r";
+ print fbytes($size);
+ print " of ", fbytes($length) if defined($length) && $length != $size;
+ print " received";
+ my $dur = time - $start_t;
+ if ($dur) {
+ my $speed = fbytes($size/$dur) . "/sec";
+ print " in ", fduration($dur), " ($speed)";
+ }
+ print "\n";
+
+ if (my $mtime = $res->last_modified) {
+ utime time, $mtime, $file;
+ }
+
+ if ($res->header("X-Died") || !$res->is_success) {
+ if (my $died = $res->header("X-Died")) {
+ print "$died\n";
+ }
+ if (-t) {
+ print "Transfer aborted. Delete $file? [n] ";
+ my $ans = <STDIN>;
+ if (defined($ans) && $ans =~ /^y\n/) {
+ unlink($file) && print "Deleted.\n";
+ }
+ elsif ($length > $size) {
+ print "Truncated file kept: ", fbytes($length - $size), " missing\n";
+ }
+ else {
+ print "File kept.\n";
+ }
+ exit 1;
+ }
+ else {
+ print "Transfer aborted, $file kept\n";
+ }
+ }
+ exit 0;
+}
+
+# Did not manage to create any file
+print "\n" if $shown;
+if (my $xdied = $res->header("X-Died")) {
+ print "$progname: Aborted\n$xdied\n";
+}
+else {
+ print "$progname: ", $res->status_line, "\n";
+}
+exit 1;
+
+
+sub fbytes
+{
+ my $n = int(shift);
+ if ($n >= 1024 * 1024) {
+ return sprintf "%.3g MB", $n / (1024.0 * 1024);
+ }
+ elsif ($n >= 1024) {
+ return sprintf "%.3g KB", $n / 1024.0;
+ }
+ else {
+ return "$n bytes";
+ }
+}
+
+sub fduration
+{
+ use integer;
+ my $secs = int(shift);
+ my $hours = $secs / (60*60);
+ $secs -= $hours * 60*60;
+ my $mins = $secs / 60;
+ $secs %= 60;
+ if ($hours) {
+ return "$hours hours $mins minutes";
+ }
+ elsif ($mins >= 2) {
+ return "$mins minutes";
+ }
+ else {
+ $secs += $mins * 60;
+ return "$secs seconds";
+ }
+}
+
+
+BEGIN {
+ my @ani = qw(- \ | /);
+ my $ani = 0;
+
+ sub show
+ {
+ my($mess, $show_ani) = @_;
+ print "\r$mess" . (" " x (75 - length $mess));
+ print $show_ani ? "$ani[$ani++]\b" : " ";
+ $ani %= @ani;
+ $shown++;
+ }
+}
+
+sub usage
+{
+ die "Usage: $progname [-a] <url> [<lpath>]\n";
+}
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-download.bat b/Master/tlpkg/tlperl.straw/bin/lwp-download.bat
new file mode 100755
index 00000000000..ec045baf4e9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-download.bat
@@ -0,0 +1,336 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+=head1 NAME
+
+lwp-download - Fetch large files from the web
+
+=head1 SYNOPSIS
+
+B<lwp-download> [B<-a>] <I<url>> [<I<local path>>]
+
+=head1 DESCRIPTION
+
+The B<lwp-download> program will save the file at I<url> to a local
+file.
+
+If I<local path> is not specified, then the current directory is
+assumed.
+
+If I<local path> is a directory, then the basename of the file to save
+is picked up from the Content-Disposition header or the URL of the
+response. If the file already exists, then B<lwp-download> will
+prompt before it overwrites and will fail if its standard input is not
+a terminal. This form of invocation will also fail is no acceptable
+filename can be derived from the sources mentioned above.
+
+If I<local path> is not a directory, then it is simply used as the
+path to save into.
+
+The I<lwp-download> program is implemented using the I<libwww-perl>
+library. It is better suited to down load big files than the
+I<lwp-request> program because it does not store the file in memory.
+Another benefit is that it will keep you updated about its progress
+and that you don't have much options to worry about.
+
+Use the C<-a> option to save the file in text (ascii) mode. Might
+make a difference on dosish systems.
+
+=head1 EXAMPLE
+
+Fetch the newest and greatest perl version:
+
+ $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz
+ Saving to 'latest.tar.gz'...
+ 11.4 MB received in 8 seconds (1.43 MB/sec)
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+#' get emacs out of quote mode
+
+use strict;
+
+use LWP::UserAgent ();
+use LWP::MediaTypes qw(guess_media_type media_suffix);
+use URI ();
+use HTTP::Date ();
+
+my $progname = $0;
+$progname =~ s,.*/,,; # only basename left in progname
+$progname =~ s,.*\\,, if $^O eq "MSWin32";
+$progname =~ s/\.\w*$//; # strip extension if any
+
+#parse option
+use Getopt::Std;
+my %opt;
+unless (getopts('a', \%opt)) {
+ usage();
+}
+
+my $url = URI->new(shift || usage());
+my $argfile = shift;
+usage() if defined($argfile) && !length($argfile);
+my $VERSION = "5.827";
+
+my $ua = LWP::UserAgent->new(
+ agent => "lwp-download/$VERSION ",
+ keep_alive => 1,
+ env_proxy => 1,
+);
+
+my $file; # name of file we download into
+my $length; # total number of bytes to download
+my $flength; # formatted length
+my $size = 0; # number of bytes received
+my $start_t; # start time of download
+my $last_dur; # time of last callback
+
+my $shown = 0; # have we called the show() function yet
+
+$SIG{INT} = sub { die "Interrupted\n"; };
+
+$| = 1; # autoflush
+
+my $res = $ua->request(HTTP::Request->new(GET => $url),
+ sub {
+ unless(defined $file) {
+ my $res = $_[1];
+
+ my $directory;
+ if (defined $argfile && -d $argfile) {
+ ($directory, $argfile) = ($argfile, undef);
+ }
+
+ unless (defined $argfile) {
+ # find a suitable name to use
+ $file = $res->filename;
+
+ # if this fails we try to make something from the URL
+ unless ($file) {
+ my $req = $res->request; # not always there
+ my $rurl = $req ? $req->uri : $url;
+
+ $file = ($rurl->path_segments)[-1];
+ if (!defined($file) || !length($file)) {
+ $file = "index";
+ my $suffix = media_suffix($res->content_type);
+ $file .= ".$suffix" if $suffix;
+ }
+ elsif ($rurl->scheme eq 'ftp' ||
+ $file =~ /\.t[bg]z$/ ||
+ $file =~ /\.tar(\.(Z|gz|bz2?))?$/
+ ) {
+ # leave the filename as it was
+ }
+ else {
+ my $ct = guess_media_type($file);
+ unless ($ct eq $res->content_type) {
+ # need a better suffix for this type
+ my $suffix = media_suffix($res->content_type);
+ $file .= ".$suffix" if $suffix;
+ }
+ }
+ }
+
+ # validate that we don't have a harmful filename now. The server
+ # might try to trick us into doing something bad.
+ if (!length($file) ||
+ $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge)
+ {
+ die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n";
+ }
+
+ if (defined $directory) {
+ require File::Spec;
+ $file = File::Spec->catfile($directory, $file);
+ }
+
+ # Check if the file is already present
+ if (-l $file) {
+ die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n";
+ }
+ elsif (-f _) {
+ die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n"
+ unless -t;
+ $shown = 1;
+ print "Overwrite $file? [y] ";
+ my $ans = <STDIN>;
+ unless (defined($ans) && $ans =~ /^y?\n/) {
+ if (defined $ans) {
+ print "Ok, aborting.\n";
+ }
+ else {
+ print "\nAborting.\n";
+ }
+ exit 1;
+ }
+ $shown = 0;
+ }
+ elsif (-e _) {
+ die "Will not save <$url> as \"$file\". Path exists.\n";
+ }
+ else {
+ print "Saving to '$file'...\n";
+ }
+ }
+ else {
+ $file = $argfile;
+ }
+ open(FILE, ">$file") || die "Can't open $file: $!\n";
+ binmode FILE unless $opt{a};
+ $length = $res->content_length;
+ $flength = fbytes($length) if defined $length;
+ $start_t = time;
+ $last_dur = 0;
+ }
+
+ print FILE $_[0] or die "Can't write to $file: $!\n";
+ $size += length($_[0]);
+
+ if (defined $length) {
+ my $dur = time - $start_t;
+ if ($dur != $last_dur) { # don't update too often
+ $last_dur = $dur;
+ my $perc = $size / $length;
+ my $speed;
+ $speed = fbytes($size/$dur) . "/sec" if $dur > 3;
+ my $secs_left = fduration($dur/$perc - $dur);
+ $perc = int($perc*100);
+ my $show = "$perc% of $flength";
+ $show .= " (at $speed, $secs_left remaining)" if $speed;
+ show($show, 1);
+ }
+ }
+ else {
+ show( fbytes($size) . " received");
+ }
+ }
+);
+
+if (fileno(FILE)) {
+ close(FILE) || die "Can't write to $file: $!\n";
+
+ show(""); # clear text
+ print "\r";
+ print fbytes($size);
+ print " of ", fbytes($length) if defined($length) && $length != $size;
+ print " received";
+ my $dur = time - $start_t;
+ if ($dur) {
+ my $speed = fbytes($size/$dur) . "/sec";
+ print " in ", fduration($dur), " ($speed)";
+ }
+ print "\n";
+
+ if (my $mtime = $res->last_modified) {
+ utime time, $mtime, $file;
+ }
+
+ if ($res->header("X-Died") || !$res->is_success) {
+ if (my $died = $res->header("X-Died")) {
+ print "$died\n";
+ }
+ if (-t) {
+ print "Transfer aborted. Delete $file? [n] ";
+ my $ans = <STDIN>;
+ if (defined($ans) && $ans =~ /^y\n/) {
+ unlink($file) && print "Deleted.\n";
+ }
+ elsif ($length > $size) {
+ print "Truncated file kept: ", fbytes($length - $size), " missing\n";
+ }
+ else {
+ print "File kept.\n";
+ }
+ exit 1;
+ }
+ else {
+ print "Transfer aborted, $file kept\n";
+ }
+ }
+ exit 0;
+}
+
+# Did not manage to create any file
+print "\n" if $shown;
+if (my $xdied = $res->header("X-Died")) {
+ print "$progname: Aborted\n$xdied\n";
+}
+else {
+ print "$progname: ", $res->status_line, "\n";
+}
+exit 1;
+
+
+sub fbytes
+{
+ my $n = int(shift);
+ if ($n >= 1024 * 1024) {
+ return sprintf "%.3g MB", $n / (1024.0 * 1024);
+ }
+ elsif ($n >= 1024) {
+ return sprintf "%.3g KB", $n / 1024.0;
+ }
+ else {
+ return "$n bytes";
+ }
+}
+
+sub fduration
+{
+ use integer;
+ my $secs = int(shift);
+ my $hours = $secs / (60*60);
+ $secs -= $hours * 60*60;
+ my $mins = $secs / 60;
+ $secs %= 60;
+ if ($hours) {
+ return "$hours hours $mins minutes";
+ }
+ elsif ($mins >= 2) {
+ return "$mins minutes";
+ }
+ else {
+ $secs += $mins * 60;
+ return "$secs seconds";
+ }
+}
+
+
+BEGIN {
+ my @ani = qw(- \ | /);
+ my $ani = 0;
+
+ sub show
+ {
+ my($mess, $show_ani) = @_;
+ print "\r$mess" . (" " x (75 - length $mess));
+ print $show_ani ? "$ani[$ani++]\b" : " ";
+ $ani %= @ani;
+ $shown++;
+ }
+}
+
+sub usage
+{
+ die "Usage: $progname [-a] <url> [<lpath>]\n";
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-dump b/Master/tlpkg/tlperl.straw/bin/lwp-dump
new file mode 100755
index 00000000000..1805eb56138
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-dump
@@ -0,0 +1,107 @@
+#!/usr/bin/perl -w
+
+use strict;
+use LWP::UserAgent ();
+use Getopt::Long qw(GetOptions);
+
+my $VERSION = "5.827";
+
+GetOptions(\my %opt,
+ 'parse-head',
+ 'max-length=n',
+ 'keep-client-headers',
+ 'method=s',
+ 'agent=s',
+) || usage();
+
+my $url = shift || usage();
+@ARGV && usage();
+
+sub usage {
+ (my $progname = $0) =~ s,.*/,,;
+ die <<"EOT";
+Usage: $progname [options] <url>
+
+Recognized options are:
+ --agent <str>
+ --keep-client-headers
+ --max-length <n>
+ --method <str>
+ --parse-head
+
+EOT
+}
+
+my $ua = LWP::UserAgent->new(
+ parse_head => $opt{'parse-head'} || 0,
+ keep_alive => 1,
+ env_proxy => 1,
+ agent => $opt{agent} || "lwp-dump/$VERSION ",
+);
+
+my $req = HTTP::Request->new($opt{method} || 'GET' => $url);
+my $res = $ua->simple_request($req);
+$res->remove_header(grep /^Client-/, $res->header_field_names)
+ unless $opt{'keep-client-headers'} or
+ ($res->header("Client-Warning") || "") eq "Internal response";
+
+$res->dump(maxlength => $opt{'max-length'});
+
+__END__
+
+=head1 NAME
+
+lwp-dump - See what headers and content is returned for a URL
+
+=head1 SYNOPSIS
+
+B<lwp-dump> [ I<options> ] I<URL>
+
+=head1 DESCRIPTION
+
+The B<lwp-dump> program will get the resource indentified by the URL and then
+dump the response object to STDOUT. This will display the headers returned and
+the initial part of the content, escaped so that it's safe to display even
+binary content. The escapes syntax used is the same as for Perl's double
+quoted strings. If there is no content the string "(no content)" is shown in
+its place.
+
+The following options are recognized:
+
+=over
+
+=item B<--agent> I<str>
+
+Override the user agent string passed to the server.
+
+=item B<--keep-client-headers>
+
+LWP internally generate various C<Client-*> headers that are stripped by
+B<lwp-dump> in order to show the headers exactly as the server provided them.
+This option will suppress this.
+
+=item B<--max-length> I<n>
+
+How much of the content to show. The default is 512. Set this
+to 0 for unlimited.
+
+If the content is longer then the string is chopped at the
+limit and the string "...\n(### more bytes not shown)"
+appended.
+
+=item B<--method> I<str>
+
+Use the given method for the request instead of the default "GET".
+
+=item B<--parse-head>
+
+By default B<lwp-dump> will not try to initialize headers by looking at the
+head section of HTML documents. This option enables this. This corresponds to
+L<LWP::UserAgent/"parse_head">.
+
+=back
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>, L<HTTP::Message/"dump">
+
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-dump.bat b/Master/tlpkg/tlperl.straw/bin/lwp-dump.bat
new file mode 100755
index 00000000000..fcd6ac64baf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-dump.bat
@@ -0,0 +1,123 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+use strict;
+use LWP::UserAgent ();
+use Getopt::Long qw(GetOptions);
+
+my $VERSION = "5.827";
+
+GetOptions(\my %opt,
+ 'parse-head',
+ 'max-length=n',
+ 'keep-client-headers',
+ 'method=s',
+ 'agent=s',
+) || usage();
+
+my $url = shift || usage();
+@ARGV && usage();
+
+sub usage {
+ (my $progname = $0) =~ s,.*/,,;
+ die <<"EOT";
+Usage: $progname [options] <url>
+
+Recognized options are:
+ --agent <str>
+ --keep-client-headers
+ --max-length <n>
+ --method <str>
+ --parse-head
+
+EOT
+}
+
+my $ua = LWP::UserAgent->new(
+ parse_head => $opt{'parse-head'} || 0,
+ keep_alive => 1,
+ env_proxy => 1,
+ agent => $opt{agent} || "lwp-dump/$VERSION ",
+);
+
+my $req = HTTP::Request->new($opt{method} || 'GET' => $url);
+my $res = $ua->simple_request($req);
+$res->remove_header(grep /^Client-/, $res->header_field_names)
+ unless $opt{'keep-client-headers'} or
+ ($res->header("Client-Warning") || "") eq "Internal response";
+
+$res->dump(maxlength => $opt{'max-length'});
+
+__END__
+
+=head1 NAME
+
+lwp-dump - See what headers and content is returned for a URL
+
+=head1 SYNOPSIS
+
+B<lwp-dump> [ I<options> ] I<URL>
+
+=head1 DESCRIPTION
+
+The B<lwp-dump> program will get the resource indentified by the URL and then
+dump the response object to STDOUT. This will display the headers returned and
+the initial part of the content, escaped so that it's safe to display even
+binary content. The escapes syntax used is the same as for Perl's double
+quoted strings. If there is no content the string "(no content)" is shown in
+its place.
+
+The following options are recognized:
+
+=over
+
+=item B<--agent> I<str>
+
+Override the user agent string passed to the server.
+
+=item B<--keep-client-headers>
+
+LWP internally generate various C<Client-*> headers that are stripped by
+B<lwp-dump> in order to show the headers exactly as the server provided them.
+This option will suppress this.
+
+=item B<--max-length> I<n>
+
+How much of the content to show. The default is 512. Set this
+to 0 for unlimited.
+
+If the content is longer then the string is chopped at the
+limit and the string "...\n(### more bytes not shown)"
+appended.
+
+=item B<--method> I<str>
+
+Use the given method for the request instead of the default "GET".
+
+=item B<--parse-head>
+
+By default B<lwp-dump> will not try to initialize headers by looking at the
+head section of HTML documents. This option enables this. This corresponds to
+L<LWP::UserAgent/"parse_head">.
+
+=back
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>, L<HTTP::Message/"dump">
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-mirror b/Master/tlpkg/tlperl.straw/bin/lwp-mirror
new file mode 100755
index 00000000000..13da7971242
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-mirror
@@ -0,0 +1,103 @@
+#!/usr/bin/perl -w
+
+# Simple mirror utility using LWP
+
+=head1 NAME
+
+lwp-mirror - Simple mirror utility
+
+=head1 SYNOPSIS
+
+ lwp-mirror [-v] [-t timeout] <url> <local file>
+
+=head1 DESCRIPTION
+
+This program can be used to mirror a document from a WWW server. The
+document is only transfered if the remote copy is newer than the local
+copy. If the local copy is newer nothing happens.
+
+Use the C<-v> option to print the version number of this program.
+
+The timeout value specified with the C<-t> option. The timeout value
+is the time that the program will wait for response from the remote
+server before it fails. The default unit for the timeout value is
+seconds. You might append "m" or "h" to the timeout value to make it
+minutes or hours, respectively.
+
+Because this program is implemented using the LWP library, it only
+supports the protocols that LWP supports.
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+
+use LWP::Simple qw(mirror is_success status_message $ua);
+use Getopt::Std;
+
+$progname = $0;
+$progname =~ s,.*/,,; # use basename only
+$progname =~ s/\.\w*$//; #strip extension if any
+
+$VERSION = "5.810";
+
+$opt_h = undef; # print usage
+$opt_v = undef; # print version
+$opt_t = undef; # timeout
+
+unless (getopts("hvt:")) {
+ usage();
+}
+
+if ($opt_v) {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ die <<"EOT";
+This is lwp-mirror version $VERSION ($DISTNAME)
+
+Copyright 1995-1999, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+}
+
+$url = shift or usage();
+$file = shift or usage();
+usage() if $opt_h or @ARGV;
+
+if (defined $opt_t) {
+ $opt_t =~ /^(\d+)([smh])?/;
+ die "$progname: Illegal timeout value!\n" unless defined $1;
+ $timeout = $1;
+ $timeout *= 60 if ($2 eq "m");
+ $timeout *= 3600 if ($2 eq "h");
+ $ua->timeout($timeout);
+}
+
+$rc = mirror($url, $file);
+
+if ($rc == 304) {
+ print STDERR "$progname: $file is up to date\n"
+}
+elsif (!is_success($rc)) {
+ print STDERR "$progname: $rc ", status_message($rc), " ($url)\n";
+ exit 1;
+}
+exit;
+
+
+sub usage
+{
+ die <<"EOT";
+Usage: $progname [-options] <url> <file>
+ -v print version number of program
+ -t <timeout> Set timeout value
+EOT
+}
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-mirror.bat b/Master/tlpkg/tlperl.straw/bin/lwp-mirror.bat
new file mode 100755
index 00000000000..87beb3aa103
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-mirror.bat
@@ -0,0 +1,119 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+# Simple mirror utility using LWP
+
+=head1 NAME
+
+lwp-mirror - Simple mirror utility
+
+=head1 SYNOPSIS
+
+ lwp-mirror [-v] [-t timeout] <url> <local file>
+
+=head1 DESCRIPTION
+
+This program can be used to mirror a document from a WWW server. The
+document is only transfered if the remote copy is newer than the local
+copy. If the local copy is newer nothing happens.
+
+Use the C<-v> option to print the version number of this program.
+
+The timeout value specified with the C<-t> option. The timeout value
+is the time that the program will wait for response from the remote
+server before it fails. The default unit for the timeout value is
+seconds. You might append "m" or "h" to the timeout value to make it
+minutes or hours, respectively.
+
+Because this program is implemented using the LWP library, it only
+supports the protocols that LWP supports.
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+
+use LWP::Simple qw(mirror is_success status_message $ua);
+use Getopt::Std;
+
+$progname = $0;
+$progname =~ s,.*/,,; # use basename only
+$progname =~ s/\.\w*$//; #strip extension if any
+
+$VERSION = "5.810";
+
+$opt_h = undef; # print usage
+$opt_v = undef; # print version
+$opt_t = undef; # timeout
+
+unless (getopts("hvt:")) {
+ usage();
+}
+
+if ($opt_v) {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ die <<"EOT";
+This is lwp-mirror version $VERSION ($DISTNAME)
+
+Copyright 1995-1999, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+}
+
+$url = shift or usage();
+$file = shift or usage();
+usage() if $opt_h or @ARGV;
+
+if (defined $opt_t) {
+ $opt_t =~ /^(\d+)([smh])?/;
+ die "$progname: Illegal timeout value!\n" unless defined $1;
+ $timeout = $1;
+ $timeout *= 60 if ($2 eq "m");
+ $timeout *= 3600 if ($2 eq "h");
+ $ua->timeout($timeout);
+}
+
+$rc = mirror($url, $file);
+
+if ($rc == 304) {
+ print STDERR "$progname: $file is up to date\n"
+}
+elsif (!is_success($rc)) {
+ print STDERR "$progname: $rc ", status_message($rc), " ($url)\n";
+ exit 1;
+}
+exit;
+
+
+sub usage
+{
+ die <<"EOT";
+Usage: $progname [-options] <url> <file>
+ -v print version number of program
+ -t <timeout> Set timeout value
+EOT
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-request b/Master/tlpkg/tlperl.straw/bin/lwp-request
new file mode 100755
index 00000000000..ee9dbf88ea7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-request
@@ -0,0 +1,531 @@
+#!/usr/bin/perl -w
+
+# Simple user agent using LWP library.
+
+=head1 NAME
+
+lwp-request, GET, POST, HEAD - Simple command line user agent
+
+=head1 SYNOPSIS
+
+B<lwp-request> [B<-afPuUsSedvhx>] [B<-m> I<method>] [B<-b> I<base URL>] [B<-t> I<timeout>]
+ [B<-i> I<if-modified-since>] [B<-c> I<content-type>]
+ [B<-C> I<credentials>] [B<-p> I<proxy-url>] [B<-o> I<format>] I<url>...
+
+=head1 DESCRIPTION
+
+This program can be used to send requests to WWW servers and your
+local file system. The request content for POST and PUT
+methods is read from stdin. The content of the response is printed on
+stdout. Error messages are printed on stderr. The program returns a
+status value indicating the number of URLs that failed.
+
+The options are:
+
+=over 4
+
+=item -m <method>
+
+Set which method to use for the request. If this option is not used,
+then the method is derived from the name of the program.
+
+=item -f
+
+Force request through, even if the program believes that the method is
+illegal. The server might reject the request eventually.
+
+=item -b <uri>
+
+This URI will be used as the base URI for resolving all relative URIs
+given as argument.
+
+=item -t <timeout>
+
+Set the timeout value for the requests. The timeout is the amount of
+time that the program will wait for a response from the remote server
+before it fails. The default unit for the timeout value is seconds.
+You might append "m" or "h" to the timeout value to make it minutes or
+hours, respectively. The default timeout is '3m', i.e. 3 minutes.
+
+=item -i <time>
+
+Set the If-Modified-Since header in the request. If I<time> is the
+name of a file, use the modification timestamp for this file. If
+I<time> is not a file, it is parsed as a literal date. Take a look at
+L<HTTP::Date> for recognized formats.
+
+=item -c <content-type>
+
+Set the Content-Type for the request. This option is only allowed for
+requests that take a content, i.e. POST and PUT. You can
+force methods to take content by using the C<-f> option together with
+C<-c>. The default Content-Type for POST is
+C<application/x-www-form-urlencoded>. The default Content-type for
+the others is C<text/plain>.
+
+=item -p <proxy-url>
+
+Set the proxy to be used for the requests. The program also loads
+proxy settings from the environment. You can disable this with the
+C<-P> option.
+
+=item -P
+
+Don't load proxy settings from environment.
+
+=item -H <header>
+
+Send this HTTP header with each request. You can specify several, e.g.:
+
+ lwp-request \
+ -H 'Referer: http://other.url/' \
+ -H 'Host: somehost' \
+ http://this.url/
+
+=item -C <username>:<password>
+
+Provide credentials for documents that are protected by Basic
+Authentication. If the document is protected and you did not specify
+the username and password with this option, then you will be prompted
+to provide these values.
+
+=back
+
+The following options controls what is displayed by the program:
+
+=over 4
+
+=item -u
+
+Print request method and absolute URL as requests are made.
+
+=item -U
+
+Print request headers in addition to request method and absolute URL.
+
+=item -s
+
+Print response status code. This option is always on for HEAD requests.
+
+=item -S
+
+Print response status chain. This shows redirect and authorization
+requests that are handled by the library.
+
+=item -e
+
+Print response headers. This option is always on for HEAD requests.
+
+=item -d
+
+Do B<not> print the content of the response.
+
+=item -o <format>
+
+Process HTML content in various ways before printing it. If the
+content type of the response is not HTML, then this option has no
+effect. The legal format values are; I<text>, I<ps>, I<links>,
+I<html> and I<dump>.
+
+If you specify the I<text> format then the HTML will be formatted as
+plain latin1 text. If you specify the I<ps> format then it will be
+formatted as Postscript.
+
+The I<links> format will output all links found in the HTML document.
+Relative links will be expanded to absolute ones.
+
+The I<html> format will reformat the HTML code and the I<dump> format
+will just dump the HTML syntax tree.
+
+Note that the C<HTML-Tree> distribution needs to be installed for this
+option to work. In addition the C<HTML-Format> distribution needs to
+be installed for I<-o text> or I<-o ps> to work.
+
+=item -v
+
+Print the version number of the program and quit.
+
+=item -h
+
+Print usage message and quit.
+
+=item -a
+
+Set text(ascii) mode for content input and output. If this option is not
+used, content input and output is done in binary mode.
+
+=back
+
+Because this program is implemented using the LWP library, it will
+only support the protocols that LWP supports.
+
+=head1 SEE ALSO
+
+L<lwp-mirror>, L<LWP>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1999 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+$progname = $0;
+$progname =~ s,.*[\\/],,; # use basename only
+$progname =~ s/\.\w*$//; # strip extension, if any
+
+$VERSION = "5.834";
+
+
+require LWP;
+
+use URI;
+use URI::Heuristic qw(uf_uri);
+
+use HTTP::Status qw(status_message);
+use HTTP::Date qw(time2str str2time);
+
+
+# This table lists the methods that are allowed. It should really be
+# a superset for all methods supported for every scheme that may be
+# supported by the library. Currently it might be a bit too HTTP
+# specific. You might use the -f option to force a method through.
+#
+# "" = No content in request, "C" = Needs content in request
+#
+%allowed_methods = (
+ GET => "",
+ HEAD => "",
+ POST => "C",
+ PUT => "C",
+ DELETE => "",
+ TRACE => "",
+ OPTIONS => "",
+);
+
+
+# We make our own specialization of LWP::UserAgent that asks for
+# user/password if document is protected.
+{
+ package RequestAgent;
+ @ISA = qw(LWP::UserAgent);
+
+ sub new
+ {
+ my $self = LWP::UserAgent::new(@_);
+ $self->agent("lwp-request/$main::VERSION ");
+ $self;
+ }
+
+ sub get_basic_credentials
+ {
+ my($self, $realm, $uri) = @_;
+ if ($main::options{'C'}) {
+ return split(':', $main::options{'C'}, 2);
+ }
+ elsif (-t) {
+ my $netloc = $uri->host_port;
+ print STDERR "Enter username for $realm at $netloc: ";
+ my $user = <STDIN>;
+ chomp($user);
+ return (undef, undef) unless length $user;
+ print STDERR "Password: ";
+ system("stty -echo");
+ my $password = <STDIN>;
+ system("stty echo");
+ print STDERR "\n"; # because we disabled echo
+ chomp($password);
+ return ($user, $password);
+ }
+ else {
+ return (undef, undef)
+ }
+ }
+}
+
+$method = uc(lc($progname) eq "lwp-request" ? "GET" : $progname);
+
+# Parse command line
+use Getopt::Long;
+
+my @getopt_args = (
+ 'a', # content i/o in text(ascii) mode
+ 'm=s', # set method
+ 'f', # make request even if method is not in %allowed_methods
+ 'b=s', # base url
+ 't=s', # timeout
+ 'i=s', # if-modified-since
+ 'c=s', # content type for POST
+ 'C=s', # credentials for basic authorization
+ 'H=s@', # extra headers, form "Header: value string"
+ #
+ 'u', # display method, URL and headers of request
+ 'U', # display request headers also
+ 's', # display status code
+ 'S', # display whole chain of status codes
+ 'e', # display response headers (default for HEAD)
+ 'd', # don't display content
+ #
+ 'h', # print usage
+ 'v', # print version
+ #
+ 'p=s', # proxy URL
+ 'P', # don't load proxy setting from environment
+ #
+ 'o=s', # output format
+);
+
+Getopt::Long::config("noignorecase", "bundling");
+unless (GetOptions(\%options, @getopt_args)) {
+ usage();
+}
+if ($options{'v'}) {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ die <<"EOT";
+This is lwp-request version $VERSION ($DISTNAME)
+
+Copyright 1995-1999, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+}
+
+usage() if $options{'h'} || !@ARGV;
+
+# Create the user agent object
+$ua = RequestAgent->new;
+
+# Load proxy settings from *_proxy environment variables.
+$ua->env_proxy unless $options{'P'};
+
+$method = uc($options{'m'}) if defined $options{'m'};
+
+if ($options{'f'}) {
+ if ($options{'c'}) {
+ $allowed_methods{$method} = "C"; # force content
+ }
+ else {
+ $allowed_methods{$method} = "";
+ }
+}
+elsif (!defined $allowed_methods{$method}) {
+ die "$progname: $method is not an allowed method\n";
+}
+
+if ($method eq "HEAD") {
+ $options{'s'} = 1;
+ $options{'e'} = 1 unless $options{'d'};
+ $options{'d'} = 1;
+}
+
+if (defined $options{'t'}) {
+ $options{'t'} =~ /^(\d+)([smh])?/;
+ die "$progname: Illegal timeout value!\n" unless defined $1;
+ $timeout = $1;
+ if (defined $2) {
+ $timeout *= 60 if $2 eq "m";
+ $timeout *= 3600 if $2 eq "h";
+ }
+ $ua->timeout($timeout);
+}
+
+if (defined $options{'i'}) {
+ if (-e $options{'i'}) {
+ $time = (stat _)[9];
+ }
+ else {
+ $time = str2time($options{'i'});
+ die "$progname: Illegal time syntax for -i option\n"
+ unless defined $time;
+ }
+ $options{'i'} = time2str($time);
+}
+
+$content = undef;
+if ($allowed_methods{$method} eq "C") {
+ # This request needs some content
+ unless (defined $options{'c'}) {
+ # set default content type
+ $options{'c'} = ($method eq "POST") ?
+ "application/x-www-form-urlencoded"
+ : "text/plain";
+ }
+ else {
+ die "$progname: Illegal Content-type format\n"
+ unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,
+ }
+ print STDERR "Please enter content ($options{'c'}) to be ${method}ed:\n"
+ if -t;
+ binmode STDIN unless -t or $options{'a'};
+ $content = join("", <STDIN>);
+}
+else {
+ die "$progname: Can't set Content-type for $method requests\n"
+ if defined $options{'c'};
+}
+
+# Set up a request. We will use the same request object for all URLs.
+$request = HTTP::Request->new($method);
+$request->header('If-Modified-Since', $options{'i'}) if defined $options{'i'};
+for my $user_header (@{ $options{'H'} || [] }) {
+ my ($header_name, $header_value) = split /:\s*/, $user_header, 2;
+ $request->header($header_name, $header_value);
+ $ua->agent($header_value) if lc($header_name) eq "user-agent"; # Ugh!
+}
+#$request->header('Accept', '*/*');
+if ($options{'c'}) { # will always be set for request that wants content
+ $request->header('Content-Type', $options{'c'});
+ $request->header('Content-Length', length $content); # Not really needed
+ $request->content($content);
+}
+
+$errors = 0;
+
+# Ok, now we perform the requests, one URL at a time
+while ($url = shift) {
+ # Create the URL object, but protect us against bad URLs
+ eval {
+ if ($url =~ /^\w+:/ || $options{'b'}) { # is there any scheme specification
+ $url = URI->new($url, $options{'b'});
+ $url = $url->abs($options{'b'}) if $options{'b'};
+ }
+ else {
+ $url = uf_uri($url);
+ }
+ };
+ if ($@) {
+ $@ =~ s/ at .* line \d+.*//;
+ print STDERR $@;
+ $errors++;
+ next;
+ }
+
+ $ua->proxy($url->scheme, $options{'p'}) if $options{'p'};
+
+ # Send the request and get a response back from the server
+ $request->uri($url);
+ $response = $ua->request($request);
+
+ if ($options{'u'} || $options{'U'}) {
+ my $url = $response->request->uri->as_string;
+ print "$method $url\n";
+ print $response->request->headers_as_string, "\n" if $options{'U'};
+ }
+
+ if ($options{'S'}) {
+ for my $r ($response->redirects, $response) {
+ my $method = $r->request->method;
+ my $url = $r->request->uri->as_string;
+ print "$method $url --> ", $r->status_line, "\n";
+ }
+ }
+ elsif ($options{'s'}) {
+ print $response->status_line, "\n";
+ }
+
+ if ($options{'e'}) {
+ # Display headers
+ print $response->headers_as_string;
+ print "\n"; # separate headers and content
+ }
+
+ unless ($options{'d'}) {
+ if ($options{'o'} &&
+ $response->content_type eq 'text/html') {
+ eval {
+ require HTML::Parse;
+ };
+ if ($@) {
+ if ($@ =~ m,^Can't locate HTML/Parse.pm in \@INC,) {
+ die "The HTML-Tree distribution need to be installed for the -o option to be used.\n";
+ }
+ else {
+ die $@;
+ }
+ }
+ my $html = HTML::Parse::parse_html($response->content);
+ {
+ $options{'o'} eq 'ps' && do {
+ require HTML::FormatPS;
+ my $f = HTML::FormatPS->new;
+ print $f->format($html);
+ last;
+ };
+ $options{'o'} eq 'text' && do {
+ require HTML::FormatText;
+ my $f = HTML::FormatText->new;
+ print $f->format($html);
+ last;
+ };
+ $options{'o'} eq 'html' && do {
+ print $html->as_HTML;
+ last;
+ };
+ $options{'o'} eq 'links' && do {
+ my $base = $response->base;
+ $base = $options{'b'} if $options{'b'};
+ for ( @{ $html->extract_links } ) {
+ my($link, $elem) = @$_;
+ my $tag = uc $elem->tag;
+ $link = URI->new($link)->abs($base)->as_string;
+ print "$tag\t$link\n";
+ }
+ last;
+ };
+ $options{'o'} eq 'dump' && do {
+ $html->dump;
+ last;
+ };
+ # It is bad to not notice this before now :-(
+ die "Illegal -o option value ($options{'o'})\n";
+ }
+ }
+ else {
+ binmode STDOUT unless $options{'a'};
+ print $response->content;
+ }
+ }
+
+ $errors++ unless $response->is_success;
+}
+
+exit $errors;
+
+
+sub usage
+{
+ die <<"EOT";
+Usage: $progname [-options] <url>...
+ -m <method> use method for the request (default is '$method')
+ -f make request even if $progname believes method is illegal
+ -b <base> Use the specified URL as base
+ -t <timeout> Set timeout value
+ -i <time> Set the If-Modified-Since header on the request
+ -c <conttype> use this content-type for POST, PUT, CHECKIN
+ -a Use text mode for content I/O
+ -p <proxyurl> use this as a proxy
+ -P don't load proxy settings from environment
+ -H <header> send this HTTP header (you can specify several)
+ -C <username>:<password>
+ provide credentials for basic authentication
+
+ -u Display method and URL before any response
+ -U Display request headers (implies -u)
+ -s Display response status code
+ -S Display response status chain
+ -e Display response headers
+ -d Do not display content
+ -o <format> Process HTML content in various ways
+
+ -v Show program version
+ -h Print this message
+EOT
+}
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-request.bat b/Master/tlpkg/tlperl.straw/bin/lwp-request.bat
new file mode 100755
index 00000000000..0b447c29fd0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-request.bat
@@ -0,0 +1,547 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+# Simple user agent using LWP library.
+
+=head1 NAME
+
+lwp-request, GET, POST, HEAD - Simple command line user agent
+
+=head1 SYNOPSIS
+
+B<lwp-request> [B<-afPuUsSedvhx>] [B<-m> I<method>] [B<-b> I<base URL>] [B<-t> I<timeout>]
+ [B<-i> I<if-modified-since>] [B<-c> I<content-type>]
+ [B<-C> I<credentials>] [B<-p> I<proxy-url>] [B<-o> I<format>] I<url>...
+
+=head1 DESCRIPTION
+
+This program can be used to send requests to WWW servers and your
+local file system. The request content for POST and PUT
+methods is read from stdin. The content of the response is printed on
+stdout. Error messages are printed on stderr. The program returns a
+status value indicating the number of URLs that failed.
+
+The options are:
+
+=over 4
+
+=item -m <method>
+
+Set which method to use for the request. If this option is not used,
+then the method is derived from the name of the program.
+
+=item -f
+
+Force request through, even if the program believes that the method is
+illegal. The server might reject the request eventually.
+
+=item -b <uri>
+
+This URI will be used as the base URI for resolving all relative URIs
+given as argument.
+
+=item -t <timeout>
+
+Set the timeout value for the requests. The timeout is the amount of
+time that the program will wait for a response from the remote server
+before it fails. The default unit for the timeout value is seconds.
+You might append "m" or "h" to the timeout value to make it minutes or
+hours, respectively. The default timeout is '3m', i.e. 3 minutes.
+
+=item -i <time>
+
+Set the If-Modified-Since header in the request. If I<time> is the
+name of a file, use the modification timestamp for this file. If
+I<time> is not a file, it is parsed as a literal date. Take a look at
+L<HTTP::Date> for recognized formats.
+
+=item -c <content-type>
+
+Set the Content-Type for the request. This option is only allowed for
+requests that take a content, i.e. POST and PUT. You can
+force methods to take content by using the C<-f> option together with
+C<-c>. The default Content-Type for POST is
+C<application/x-www-form-urlencoded>. The default Content-type for
+the others is C<text/plain>.
+
+=item -p <proxy-url>
+
+Set the proxy to be used for the requests. The program also loads
+proxy settings from the environment. You can disable this with the
+C<-P> option.
+
+=item -P
+
+Don't load proxy settings from environment.
+
+=item -H <header>
+
+Send this HTTP header with each request. You can specify several, e.g.:
+
+ lwp-request \
+ -H 'Referer: http://other.url/' \
+ -H 'Host: somehost' \
+ http://this.url/
+
+=item -C <username>:<password>
+
+Provide credentials for documents that are protected by Basic
+Authentication. If the document is protected and you did not specify
+the username and password with this option, then you will be prompted
+to provide these values.
+
+=back
+
+The following options controls what is displayed by the program:
+
+=over 4
+
+=item -u
+
+Print request method and absolute URL as requests are made.
+
+=item -U
+
+Print request headers in addition to request method and absolute URL.
+
+=item -s
+
+Print response status code. This option is always on for HEAD requests.
+
+=item -S
+
+Print response status chain. This shows redirect and authorization
+requests that are handled by the library.
+
+=item -e
+
+Print response headers. This option is always on for HEAD requests.
+
+=item -d
+
+Do B<not> print the content of the response.
+
+=item -o <format>
+
+Process HTML content in various ways before printing it. If the
+content type of the response is not HTML, then this option has no
+effect. The legal format values are; I<text>, I<ps>, I<links>,
+I<html> and I<dump>.
+
+If you specify the I<text> format then the HTML will be formatted as
+plain latin1 text. If you specify the I<ps> format then it will be
+formatted as Postscript.
+
+The I<links> format will output all links found in the HTML document.
+Relative links will be expanded to absolute ones.
+
+The I<html> format will reformat the HTML code and the I<dump> format
+will just dump the HTML syntax tree.
+
+Note that the C<HTML-Tree> distribution needs to be installed for this
+option to work. In addition the C<HTML-Format> distribution needs to
+be installed for I<-o text> or I<-o ps> to work.
+
+=item -v
+
+Print the version number of the program and quit.
+
+=item -h
+
+Print usage message and quit.
+
+=item -a
+
+Set text(ascii) mode for content input and output. If this option is not
+used, content input and output is done in binary mode.
+
+=back
+
+Because this program is implemented using the LWP library, it will
+only support the protocols that LWP supports.
+
+=head1 SEE ALSO
+
+L<lwp-mirror>, L<LWP>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1999 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+$progname = $0;
+$progname =~ s,.*[\\/],,; # use basename only
+$progname =~ s/\.\w*$//; # strip extension, if any
+
+$VERSION = "5.834";
+
+
+require LWP;
+
+use URI;
+use URI::Heuristic qw(uf_uri);
+
+use HTTP::Status qw(status_message);
+use HTTP::Date qw(time2str str2time);
+
+
+# This table lists the methods that are allowed. It should really be
+# a superset for all methods supported for every scheme that may be
+# supported by the library. Currently it might be a bit too HTTP
+# specific. You might use the -f option to force a method through.
+#
+# "" = No content in request, "C" = Needs content in request
+#
+%allowed_methods = (
+ GET => "",
+ HEAD => "",
+ POST => "C",
+ PUT => "C",
+ DELETE => "",
+ TRACE => "",
+ OPTIONS => "",
+);
+
+
+# We make our own specialization of LWP::UserAgent that asks for
+# user/password if document is protected.
+{
+ package RequestAgent;
+ @ISA = qw(LWP::UserAgent);
+
+ sub new
+ {
+ my $self = LWP::UserAgent::new(@_);
+ $self->agent("lwp-request/$main::VERSION ");
+ $self;
+ }
+
+ sub get_basic_credentials
+ {
+ my($self, $realm, $uri) = @_;
+ if ($main::options{'C'}) {
+ return split(':', $main::options{'C'}, 2);
+ }
+ elsif (-t) {
+ my $netloc = $uri->host_port;
+ print STDERR "Enter username for $realm at $netloc: ";
+ my $user = <STDIN>;
+ chomp($user);
+ return (undef, undef) unless length $user;
+ print STDERR "Password: ";
+ system("stty -echo");
+ my $password = <STDIN>;
+ system("stty echo");
+ print STDERR "\n"; # because we disabled echo
+ chomp($password);
+ return ($user, $password);
+ }
+ else {
+ return (undef, undef)
+ }
+ }
+}
+
+$method = uc(lc($progname) eq "lwp-request" ? "GET" : $progname);
+
+# Parse command line
+use Getopt::Long;
+
+my @getopt_args = (
+ 'a', # content i/o in text(ascii) mode
+ 'm=s', # set method
+ 'f', # make request even if method is not in %allowed_methods
+ 'b=s', # base url
+ 't=s', # timeout
+ 'i=s', # if-modified-since
+ 'c=s', # content type for POST
+ 'C=s', # credentials for basic authorization
+ 'H=s@', # extra headers, form "Header: value string"
+ #
+ 'u', # display method, URL and headers of request
+ 'U', # display request headers also
+ 's', # display status code
+ 'S', # display whole chain of status codes
+ 'e', # display response headers (default for HEAD)
+ 'd', # don't display content
+ #
+ 'h', # print usage
+ 'v', # print version
+ #
+ 'p=s', # proxy URL
+ 'P', # don't load proxy setting from environment
+ #
+ 'o=s', # output format
+);
+
+Getopt::Long::config("noignorecase", "bundling");
+unless (GetOptions(\%options, @getopt_args)) {
+ usage();
+}
+if ($options{'v'}) {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ die <<"EOT";
+This is lwp-request version $VERSION ($DISTNAME)
+
+Copyright 1995-1999, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+}
+
+usage() if $options{'h'} || !@ARGV;
+
+# Create the user agent object
+$ua = RequestAgent->new;
+
+# Load proxy settings from *_proxy environment variables.
+$ua->env_proxy unless $options{'P'};
+
+$method = uc($options{'m'}) if defined $options{'m'};
+
+if ($options{'f'}) {
+ if ($options{'c'}) {
+ $allowed_methods{$method} = "C"; # force content
+ }
+ else {
+ $allowed_methods{$method} = "";
+ }
+}
+elsif (!defined $allowed_methods{$method}) {
+ die "$progname: $method is not an allowed method\n";
+}
+
+if ($method eq "HEAD") {
+ $options{'s'} = 1;
+ $options{'e'} = 1 unless $options{'d'};
+ $options{'d'} = 1;
+}
+
+if (defined $options{'t'}) {
+ $options{'t'} =~ /^(\d+)([smh])?/;
+ die "$progname: Illegal timeout value!\n" unless defined $1;
+ $timeout = $1;
+ if (defined $2) {
+ $timeout *= 60 if $2 eq "m";
+ $timeout *= 3600 if $2 eq "h";
+ }
+ $ua->timeout($timeout);
+}
+
+if (defined $options{'i'}) {
+ if (-e $options{'i'}) {
+ $time = (stat _)[9];
+ }
+ else {
+ $time = str2time($options{'i'});
+ die "$progname: Illegal time syntax for -i option\n"
+ unless defined $time;
+ }
+ $options{'i'} = time2str($time);
+}
+
+$content = undef;
+if ($allowed_methods{$method} eq "C") {
+ # This request needs some content
+ unless (defined $options{'c'}) {
+ # set default content type
+ $options{'c'} = ($method eq "POST") ?
+ "application/x-www-form-urlencoded"
+ : "text/plain";
+ }
+ else {
+ die "$progname: Illegal Content-type format\n"
+ unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,
+ }
+ print STDERR "Please enter content ($options{'c'}) to be ${method}ed:\n"
+ if -t;
+ binmode STDIN unless -t or $options{'a'};
+ $content = join("", <STDIN>);
+}
+else {
+ die "$progname: Can't set Content-type for $method requests\n"
+ if defined $options{'c'};
+}
+
+# Set up a request. We will use the same request object for all URLs.
+$request = HTTP::Request->new($method);
+$request->header('If-Modified-Since', $options{'i'}) if defined $options{'i'};
+for my $user_header (@{ $options{'H'} || [] }) {
+ my ($header_name, $header_value) = split /:\s*/, $user_header, 2;
+ $request->header($header_name, $header_value);
+ $ua->agent($header_value) if lc($header_name) eq "user-agent"; # Ugh!
+}
+#$request->header('Accept', '*/*');
+if ($options{'c'}) { # will always be set for request that wants content
+ $request->header('Content-Type', $options{'c'});
+ $request->header('Content-Length', length $content); # Not really needed
+ $request->content($content);
+}
+
+$errors = 0;
+
+# Ok, now we perform the requests, one URL at a time
+while ($url = shift) {
+ # Create the URL object, but protect us against bad URLs
+ eval {
+ if ($url =~ /^\w+:/ || $options{'b'}) { # is there any scheme specification
+ $url = URI->new($url, $options{'b'});
+ $url = $url->abs($options{'b'}) if $options{'b'};
+ }
+ else {
+ $url = uf_uri($url);
+ }
+ };
+ if ($@) {
+ $@ =~ s/ at .* line \d+.*//;
+ print STDERR $@;
+ $errors++;
+ next;
+ }
+
+ $ua->proxy($url->scheme, $options{'p'}) if $options{'p'};
+
+ # Send the request and get a response back from the server
+ $request->uri($url);
+ $response = $ua->request($request);
+
+ if ($options{'u'} || $options{'U'}) {
+ my $url = $response->request->uri->as_string;
+ print "$method $url\n";
+ print $response->request->headers_as_string, "\n" if $options{'U'};
+ }
+
+ if ($options{'S'}) {
+ for my $r ($response->redirects, $response) {
+ my $method = $r->request->method;
+ my $url = $r->request->uri->as_string;
+ print "$method $url --> ", $r->status_line, "\n";
+ }
+ }
+ elsif ($options{'s'}) {
+ print $response->status_line, "\n";
+ }
+
+ if ($options{'e'}) {
+ # Display headers
+ print $response->headers_as_string;
+ print "\n"; # separate headers and content
+ }
+
+ unless ($options{'d'}) {
+ if ($options{'o'} &&
+ $response->content_type eq 'text/html') {
+ eval {
+ require HTML::Parse;
+ };
+ if ($@) {
+ if ($@ =~ m,^Can't locate HTML/Parse.pm in \@INC,) {
+ die "The HTML-Tree distribution need to be installed for the -o option to be used.\n";
+ }
+ else {
+ die $@;
+ }
+ }
+ my $html = HTML::Parse::parse_html($response->content);
+ {
+ $options{'o'} eq 'ps' && do {
+ require HTML::FormatPS;
+ my $f = HTML::FormatPS->new;
+ print $f->format($html);
+ last;
+ };
+ $options{'o'} eq 'text' && do {
+ require HTML::FormatText;
+ my $f = HTML::FormatText->new;
+ print $f->format($html);
+ last;
+ };
+ $options{'o'} eq 'html' && do {
+ print $html->as_HTML;
+ last;
+ };
+ $options{'o'} eq 'links' && do {
+ my $base = $response->base;
+ $base = $options{'b'} if $options{'b'};
+ for ( @{ $html->extract_links } ) {
+ my($link, $elem) = @$_;
+ my $tag = uc $elem->tag;
+ $link = URI->new($link)->abs($base)->as_string;
+ print "$tag\t$link\n";
+ }
+ last;
+ };
+ $options{'o'} eq 'dump' && do {
+ $html->dump;
+ last;
+ };
+ # It is bad to not notice this before now :-(
+ die "Illegal -o option value ($options{'o'})\n";
+ }
+ }
+ else {
+ binmode STDOUT unless $options{'a'};
+ print $response->content;
+ }
+ }
+
+ $errors++ unless $response->is_success;
+}
+
+exit $errors;
+
+
+sub usage
+{
+ die <<"EOT";
+Usage: $progname [-options] <url>...
+ -m <method> use method for the request (default is '$method')
+ -f make request even if $progname believes method is illegal
+ -b <base> Use the specified URL as base
+ -t <timeout> Set timeout value
+ -i <time> Set the If-Modified-Since header on the request
+ -c <conttype> use this content-type for POST, PUT, CHECKIN
+ -a Use text mode for content I/O
+ -p <proxyurl> use this as a proxy
+ -P don't load proxy settings from environment
+ -H <header> send this HTTP header (you can specify several)
+ -C <username>:<password>
+ provide credentials for basic authentication
+
+ -u Display method and URL before any response
+ -U Display request headers (implies -u)
+ -s Display response status code
+ -S Display response status chain
+ -e Display response headers
+ -d Do not display content
+ -o <format> Process HTML content in various ways
+
+ -v Show program version
+ -h Print this message
+EOT
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-rget b/Master/tlpkg/tlperl.straw/bin/lwp-rget
new file mode 100755
index 00000000000..2ac798f4bb0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-rget
@@ -0,0 +1,607 @@
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+lwp-rget - Retrieve web documents recursively
+
+=head1 SYNOPSIS
+
+ lwp-rget [--verbose] [--auth=USER:PASS] [--depth=N] [--hier] [--iis]
+ [--keepext=mime/type[,mime/type]] [--limit=N] [--nospace]
+ [--prefix=URL] [--referer=URL] [--sleep=N] [--tolower] <URL>
+ lwp-rget --version
+
+=head1 DESCRIPTION
+
+This program will retrieve a document and store it in a local file. It
+will follow any links found in the document and store these documents
+as well, patching links so that they refer to these local copies.
+This process continues until there are no more unvisited links or the
+process is stopped by the one or more of the limits which can be
+controlled by the command line arguments.
+
+This program is useful if you want to make a local copy of a
+collection of documents or want to do web reading off-line.
+
+All documents are stored as plain files in the current directory. The
+file names chosen are derived from the last component of URL paths.
+
+The options are:
+
+=over 3
+
+=item --auth=USER:PASS<n>
+
+Set the authentication credentials to user "USER" and password "PASS" if
+any restricted parts of the web site are hit. If there are restricted
+parts of the web site and authentication credentials are not available,
+those pages will not be downloaded.
+
+=item --depth=I<n>
+
+Limit the recursive level. Embedded images are always loaded, even if
+they fall outside the I<--depth>. This means that one can use
+I<--depth=0> in order to fetch a single document together with all
+inline graphics.
+
+The default depth is 5.
+
+=item --hier
+
+Download files into a hierarchy that mimics the web site structure.
+The default is to put all files in the current directory.
+
+=item --referer=I<URI>
+
+Set the value of the Referer header for the initial request. The
+special value C<"NONE"> can be used to suppress the Referer header in
+any of subsequent requests. The Referer header will always be suppressed
+in all normal C<http> requests if the referring page was transmitted over
+C<https> as recommended in RFC 2616.
+
+=item --iis
+
+Sends an "Accept: */*" on all URL requests as a workaround for a bug in
+IIS 2.0. If no Accept MIME header is present, IIS 2.0 returns with a
+"406 No acceptable objects were found" error. Also converts any back
+slashes (\\) in URLs to forward slashes (/).
+
+=item --keepext=I<mime/type[,mime/type]>
+
+Keeps the current extension for the list MIME types. Useful when
+downloading text/plain documents that shouldn't all be translated to
+*.txt files.
+
+=item --limit=I<n>
+
+Limit the number of documents to get. The default limit is 50.
+
+=item --nospace
+
+Changes spaces in all URLs to underscore characters (_). Useful when
+downloading files from sites serving URLs with spaces in them. Does not
+remove spaces from fragments, e.g., "file.html#somewhere in here".
+
+=item --prefix=I<url_prefix>
+
+Limit the links to follow. Only URLs that start the prefix string are
+followed.
+
+The default prefix is set as the "directory" of the initial URL to
+follow. For instance if we start lwp-rget with the URL
+C<http://www.sn.no/foo/bar.html>, then prefix will be set to
+C<http://www.sn.no/foo/>.
+
+Use C<--prefix=''> if you don't want the fetching to be limited by any
+prefix.
+
+=item --sleep=I<n>
+
+Sleep I<n> seconds before retrieving each document. This options allows
+you to go slowly, not loading the server you visiting too much.
+
+=item --tolower
+
+Translates all links to lowercase. Useful when downloading files from
+IIS since it does not serve files in a case sensitive manner.
+
+=item --verbose
+
+Make more noise while running.
+
+=item --quiet
+
+Don't make any noise.
+
+=item --version
+
+Print program version number and quit.
+
+=item --help
+
+Print the usage message and quit.
+
+=back
+
+Before the program exits the name of the file, where the initial URL
+is stored, is printed on stdout. All used filenames are also printed
+on stderr as they are loaded. This printing can be suppressed with
+the I<--quiet> option.
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>
+
+=head1 AUTHOR
+
+Gisle Aas <aas@sn.no>
+
+=cut
+
+use strict;
+
+use Getopt::Long qw(GetOptions);
+use URI::URL qw(url);
+use LWP::MediaTypes qw(media_suffix);
+use HTML::Entities ();
+
+use vars qw($VERSION);
+use vars qw($MAX_DEPTH $MAX_DOCS $PREFIX $REFERER $VERBOSE $QUIET $SLEEP $HIER $AUTH $IIS $TOLOWER $NOSPACE %KEEPEXT);
+
+my $progname = $0;
+$progname =~ s|.*/||; # only basename left
+$progname =~ s/\.\w*$//; #strip extension if any
+
+$VERSION = "5.827";
+
+#$Getopt::Long::debug = 1;
+#$Getopt::Long::ignorecase = 0;
+
+# Defaults
+$MAX_DEPTH = 5;
+$MAX_DOCS = 50;
+
+GetOptions('version' => \&print_version,
+ 'help' => \&usage,
+ 'depth=i' => \$MAX_DEPTH,
+ 'limit=i' => \$MAX_DOCS,
+ 'verbose!' => \$VERBOSE,
+ 'quiet!' => \$QUIET,
+ 'sleep=i' => \$SLEEP,
+ 'prefix:s' => \$PREFIX,
+ 'referer:s'=> \$REFERER,
+ 'hier' => \$HIER,
+ 'auth=s' => \$AUTH,
+ 'iis' => \$IIS,
+ 'tolower' => \$TOLOWER,
+ 'nospace' => \$NOSPACE,
+ 'keepext=s' => \$KEEPEXT{'OPT'},
+ ) || usage();
+
+sub print_version {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ print <<"EOT";
+This is lwp-rget version $VERSION ($DISTNAME)
+
+Copyright 1996-1998, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+ exit 0;
+}
+
+my $start_url = shift || usage();
+usage() if @ARGV;
+
+require LWP::UserAgent;
+my $ua = new LWP::UserAgent;
+$ua->agent("$progname/$VERSION ");
+$ua->env_proxy;
+
+unless (defined $PREFIX) {
+ $PREFIX = url($start_url); # limit to URLs below this one
+ eval {
+ $PREFIX->eparams(undef);
+ $PREFIX->equery(undef);
+ };
+
+ $_ = $PREFIX->epath;
+ s|[^/]+$||;
+ $PREFIX->epath($_);
+ $PREFIX = $PREFIX->as_string;
+}
+
+%KEEPEXT = map { lc($_) => 1 } split(/\s*,\s*/, ($KEEPEXT{'OPT'}||0));
+
+my $SUPPRESS_REFERER;
+$SUPPRESS_REFERER++ if ($REFERER || "") eq "NONE";
+
+print <<"" if $VERBOSE;
+START = $start_url
+MAX_DEPTH = $MAX_DEPTH
+MAX_DOCS = $MAX_DOCS
+PREFIX = $PREFIX
+
+my $no_docs = 0;
+my %seen = (); # mapping from URL => local_file
+
+my $filename = fetch($start_url, undef, $REFERER);
+print "$filename\n" unless $QUIET;
+
+sub fetch
+{
+ my($url, $type, $referer, $depth) = @_;
+
+ # Fix http://sitename.com/../blah/blah.html to
+ # http://sitename.com/blah/blah.html
+ $url = $url->as_string if (ref($url));
+ while ($url =~ s#(https?://[^/]+/)\.\.\/#$1#) {}
+
+ # Fix backslashes (\) in URL if $IIS defined
+ $url = fix_backslashes($url) if (defined $IIS);
+
+ $url = url($url);
+ $type ||= 'a';
+ # Might be the background attribute
+ $type = 'img' if ($type eq 'body' || $type eq 'td');
+ $depth ||= 0;
+
+ # Print the URL before we start checking...
+ my $out = (" " x $depth) . $url . " ";
+ $out .= "." x (60 - length($out));
+ print STDERR $out . " " if $VERBOSE;
+
+ # Can't get mailto things
+ if ($url->scheme eq 'mailto') {
+ print STDERR "*skipping mailto*\n" if $VERBOSE;
+ return $url->as_string;
+ }
+
+ # The $plain_url is a URL without the fragment part
+ my $plain_url = $url->clone;
+ $plain_url->frag(undef);
+
+ # Check PREFIX, but not for <IMG ...> links
+ if ($type ne 'img' and $url->as_string !~ /^\Q$PREFIX/o) {
+ print STDERR "*outsider*\n" if $VERBOSE;
+ return $url->as_string;
+ }
+
+ # Translate URL to lowercase if $TOLOWER defined
+ $plain_url = to_lower($plain_url) if (defined $TOLOWER);
+
+ # If we already have it, then there is nothing to be done
+ my $seen = $seen{$plain_url->as_string};
+ if ($seen) {
+ my $frag = $url->frag;
+ $seen .= "#$frag" if defined($frag);
+ $seen = protect_frag_spaces($seen);
+ print STDERR "$seen (again)\n" if $VERBOSE;
+ return $seen;
+ }
+
+ # Too much or too deep
+ if ($depth > $MAX_DEPTH and $type ne 'img') {
+ print STDERR "*too deep*\n" if $VERBOSE;
+ return $url;
+ }
+ if ($no_docs > $MAX_DOCS) {
+ print STDERR "*too many*\n" if $VERBOSE;
+ return $url;
+ }
+
+ # Fetch document
+ $no_docs++;
+ sleep($SLEEP) if $SLEEP;
+ my $req = HTTP::Request->new(GET => $url);
+ # See: http://ftp.sunet.se/pub/NT/mirror-microsoft/kb/Q163/7/74.TXT
+ $req->header ('Accept', '*/*') if (defined $IIS); # GIF/JPG from IIS 2.0
+ $req->authorization_basic(split (/:/, $AUTH)) if (defined $AUTH);
+ if ($referer && !$SUPPRESS_REFERER) {
+ if ($req->uri->scheme eq 'http') {
+ # RFC 2616, section 15.1.3
+ $referer = url($referer) unless ref($referer);
+ undef $referer if ($referer->scheme || '') eq 'https';
+ }
+ $req->referer($referer) if $referer;
+ }
+ my $res = $ua->request($req);
+
+ # Check outcome
+ if ($res->is_success) {
+ my $doc = $res->content;
+ my $ct = $res->content_type;
+ my $name = find_name($res->request->uri, $ct);
+ print STDERR "$name\n" unless $QUIET;
+ $seen{$plain_url->as_string} = $name;
+
+ # If the file is HTML, then we look for internal links
+ if ($ct eq "text/html") {
+ # Save an unprosessed version of the HTML document. This
+ # both reserves the name used, and it also ensures that we
+ # don't loose everything if this program is killed before
+ # we finish.
+ save($name, $doc);
+ my $base = $res->base;
+
+ # Follow and substitute links...
+ $doc =~
+s/
+ (
+ <(img|a|body|area|frame|td)\b # some interesting tag
+ [^>]+ # still inside tag (not strictly correct)
+ \b(?:src|href|background) # some link attribute
+ \s*=\s* # =
+ )
+ (?: # scope of OR-ing
+ (")([^"]*)" | # value in double quotes OR
+ (')([^']*)' | # value in single quotes OR
+ ([^\s>]+) # quoteless value
+ )
+/
+ new_link($1, lc($2), $3||$5, HTML::Entities::decode($4||$6||$7),
+ $base, $name, "$url", $depth+1)
+/giex;
+ # XXX
+ # The regular expression above is not strictly correct.
+ # It is not really possible to parse HTML with a single
+ # regular expression, but it is faster. Tags that might
+ # confuse us include:
+ # <a alt="href" href=link.html>
+ # <a alt=">" href="link.html">
+ #
+ }
+ save($name, $doc);
+ return $name;
+ }
+ else {
+ print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE;
+ $seen{$plain_url->as_string} = $url->as_string;
+ return $url->as_string;
+ }
+}
+
+sub new_link
+{
+ my($pre, $type, $quote, $url, $base, $localbase, $referer, $depth) = @_;
+
+ $url = protect_frag_spaces($url);
+
+ $url = fetch(url($url, $base)->abs, $type, $referer, $depth);
+ $url = url("file:$url", "file:$localbase")->rel
+ unless $url =~ /^[.+\-\w]+:/;
+
+ $url = unprotect_frag_spaces($url);
+
+ return $pre . $quote . $url . $quote;
+}
+
+
+sub protect_frag_spaces
+{
+ my ($url) = @_;
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/^([^#]*#)(.+)$/)
+ {
+ my ($base, $frag) = ($1, $2);
+ $frag =~ s/ /%20/g;
+ $url = $base . $frag;
+ }
+
+ return $url;
+}
+
+
+sub unprotect_frag_spaces
+{
+ my ($url) = @_;
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/^([^#]*#)(.+)$/)
+ {
+ my ($base, $frag) = ($1, $2);
+ $frag =~ s/%20/ /g;
+ $url = $base . $frag;
+ }
+
+ return $url;
+}
+
+
+sub fix_backslashes
+{
+ my ($url) = @_;
+ my ($base, $frag);
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ ($base, $frag) = ($1, $2);
+ }
+ else
+ {
+ $base = $url;
+ $frag = "";
+ }
+
+ $base =~ tr/\\/\//;
+ $base =~ s/%5[cC]/\//g; # URL-encoded back slash is %5C
+
+ return $base . $frag;
+}
+
+
+sub to_lower
+{
+ my ($url) = @_;
+ my $was_object = 0;
+
+ if (ref($url))
+ {
+ $url = $url->as_string;
+ $was_object = 1;
+ }
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ $url = lc($1) . $2;
+ }
+ else
+ {
+ $url = lc($url);
+ }
+
+ if ($was_object == 1)
+ {
+ return url($url);
+ }
+ else
+ {
+ return $url;
+ }
+}
+
+
+sub translate_spaces
+{
+ my ($url) = @_;
+ my ($base, $frag);
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ ($base, $frag) = ($1, $2);
+ }
+ else
+ {
+ $base = $url;
+ $frag = "";
+ }
+
+ $base =~ s/^ *//; # Remove initial spaces from base
+ $base =~ s/ *$//; # Remove trailing spaces from base
+
+ $base =~ tr/ /_/;
+ $base =~ s/%20/_/g; # URL-encoded space is %20
+
+ return $base . $frag;
+}
+
+
+sub mkdirp
+{
+ my($directory, $mode) = @_;
+ my @dirs = split(/\//, $directory);
+ my $path = shift(@dirs); # build it as we go
+ my $result = 1; # assume it will work
+
+ unless (-d $path) {
+ $result &&= mkdir($path, $mode);
+ }
+
+ foreach (@dirs) {
+ $path .= "/$_";
+ if ( ! -d $path) {
+ $result &&= mkdir($path, $mode);
+ }
+ }
+
+ return $result;
+}
+
+
+sub find_name
+{
+ my($url, $type) = @_;
+ #print "find_name($url, $type)\n";
+
+ # Translate spaces in URL to underscores (_) if $NOSPACE defined
+ $url = translate_spaces($url) if (defined $NOSPACE);
+
+ # Translate URL to lowercase if $TOLOWER defined
+ $url = to_lower($url) if (defined $TOLOWER);
+
+ $url = url($url) unless ref($url);
+
+ my $path = $url->path;
+
+ # trim path until only the basename is left
+ $path =~ s|(.*/)||;
+ my $dirname = ".$1";
+ if (!$HIER) {
+ $dirname = "";
+ }
+ elsif (! -d $dirname) {
+ mkdirp($dirname, 0775);
+ }
+
+ my $extra = ""; # something to make the name unique
+ my $suffix;
+
+ if ($KEEPEXT{lc($type)}) {
+ $suffix = ($path =~ m/\.(.*)/) ? $1 : "";
+ }
+ else {
+ $suffix = media_suffix($type);
+ }
+
+ $path =~ s|\..*||; # trim suffix
+ $path = "index" unless length $path;
+
+ while (1) {
+ # Construct a new file name
+ my $file = $dirname . $path . $extra;
+ $file .= ".$suffix" if $suffix;
+ # Check if it is unique
+ return $file unless -f $file;
+
+ # Try something extra
+ unless ($extra) {
+ $extra = "001";
+ next;
+ }
+ $extra++;
+ }
+}
+
+
+sub save
+{
+ my $name = shift;
+ #print "save($name,...)\n";
+ open(FILE, ">$name") || die "Can't save $name: $!";
+ binmode FILE;
+ print FILE $_[0];
+ close(FILE);
+}
+
+
+sub usage
+{
+ print <<""; exit 1;
+Usage: $progname [options] <URL>
+Allowed options are:
+ --auth=USER:PASS Set authentication credentials for web site
+ --depth=N Maximum depth to traverse (default is $MAX_DEPTH)
+ --hier Download into hierarchy (not all files into cwd)
+ --referer=URI Set initial referer header (or "NONE")
+ --iis Workaround IIS 2.0 bug by sending "Accept: */*" MIME
+ header; translates backslashes (\\) to forward slashes (/)
+ --keepext=type Keep file extension for MIME types (comma-separated list)
+ --limit=N A limit on the number documents to get (default is $MAX_DOCS)
+ --nospace Translate spaces URLs (not #fragments) to underscores (_)
+ --version Print version number and quit
+ --verbose More output
+ --quiet No output
+ --sleep=SECS Sleep between gets, ie. go slowly
+ --prefix=PREFIX Limit URLs to follow to those which begin with PREFIX
+ --tolower Translate all URLs to lowercase (useful with IIS servers)
+
+}
diff --git a/Master/tlpkg/tlperl.straw/bin/lwp-rget.bat b/Master/tlpkg/tlperl.straw/bin/lwp-rget.bat
new file mode 100755
index 00000000000..34b097d1f2c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/lwp-rget.bat
@@ -0,0 +1,623 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+=head1 NAME
+
+lwp-rget - Retrieve web documents recursively
+
+=head1 SYNOPSIS
+
+ lwp-rget [--verbose] [--auth=USER:PASS] [--depth=N] [--hier] [--iis]
+ [--keepext=mime/type[,mime/type]] [--limit=N] [--nospace]
+ [--prefix=URL] [--referer=URL] [--sleep=N] [--tolower] <URL>
+ lwp-rget --version
+
+=head1 DESCRIPTION
+
+This program will retrieve a document and store it in a local file. It
+will follow any links found in the document and store these documents
+as well, patching links so that they refer to these local copies.
+This process continues until there are no more unvisited links or the
+process is stopped by the one or more of the limits which can be
+controlled by the command line arguments.
+
+This program is useful if you want to make a local copy of a
+collection of documents or want to do web reading off-line.
+
+All documents are stored as plain files in the current directory. The
+file names chosen are derived from the last component of URL paths.
+
+The options are:
+
+=over 3
+
+=item --auth=USER:PASS<n>
+
+Set the authentication credentials to user "USER" and password "PASS" if
+any restricted parts of the web site are hit. If there are restricted
+parts of the web site and authentication credentials are not available,
+those pages will not be downloaded.
+
+=item --depth=I<n>
+
+Limit the recursive level. Embedded images are always loaded, even if
+they fall outside the I<--depth>. This means that one can use
+I<--depth=0> in order to fetch a single document together with all
+inline graphics.
+
+The default depth is 5.
+
+=item --hier
+
+Download files into a hierarchy that mimics the web site structure.
+The default is to put all files in the current directory.
+
+=item --referer=I<URI>
+
+Set the value of the Referer header for the initial request. The
+special value C<"NONE"> can be used to suppress the Referer header in
+any of subsequent requests. The Referer header will always be suppressed
+in all normal C<http> requests if the referring page was transmitted over
+C<https> as recommended in RFC 2616.
+
+=item --iis
+
+Sends an "Accept: */*" on all URL requests as a workaround for a bug in
+IIS 2.0. If no Accept MIME header is present, IIS 2.0 returns with a
+"406 No acceptable objects were found" error. Also converts any back
+slashes (\\) in URLs to forward slashes (/).
+
+=item --keepext=I<mime/type[,mime/type]>
+
+Keeps the current extension for the list MIME types. Useful when
+downloading text/plain documents that shouldn't all be translated to
+*.txt files.
+
+=item --limit=I<n>
+
+Limit the number of documents to get. The default limit is 50.
+
+=item --nospace
+
+Changes spaces in all URLs to underscore characters (_). Useful when
+downloading files from sites serving URLs with spaces in them. Does not
+remove spaces from fragments, e.g., "file.html#somewhere in here".
+
+=item --prefix=I<url_prefix>
+
+Limit the links to follow. Only URLs that start the prefix string are
+followed.
+
+The default prefix is set as the "directory" of the initial URL to
+follow. For instance if we start lwp-rget with the URL
+C<http://www.sn.no/foo/bar.html>, then prefix will be set to
+C<http://www.sn.no/foo/>.
+
+Use C<--prefix=''> if you don't want the fetching to be limited by any
+prefix.
+
+=item --sleep=I<n>
+
+Sleep I<n> seconds before retrieving each document. This options allows
+you to go slowly, not loading the server you visiting too much.
+
+=item --tolower
+
+Translates all links to lowercase. Useful when downloading files from
+IIS since it does not serve files in a case sensitive manner.
+
+=item --verbose
+
+Make more noise while running.
+
+=item --quiet
+
+Don't make any noise.
+
+=item --version
+
+Print program version number and quit.
+
+=item --help
+
+Print the usage message and quit.
+
+=back
+
+Before the program exits the name of the file, where the initial URL
+is stored, is printed on stdout. All used filenames are also printed
+on stderr as they are loaded. This printing can be suppressed with
+the I<--quiet> option.
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>
+
+=head1 AUTHOR
+
+Gisle Aas <aas@sn.no>
+
+=cut
+
+use strict;
+
+use Getopt::Long qw(GetOptions);
+use URI::URL qw(url);
+use LWP::MediaTypes qw(media_suffix);
+use HTML::Entities ();
+
+use vars qw($VERSION);
+use vars qw($MAX_DEPTH $MAX_DOCS $PREFIX $REFERER $VERBOSE $QUIET $SLEEP $HIER $AUTH $IIS $TOLOWER $NOSPACE %KEEPEXT);
+
+my $progname = $0;
+$progname =~ s|.*/||; # only basename left
+$progname =~ s/\.\w*$//; #strip extension if any
+
+$VERSION = "5.827";
+
+#$Getopt::Long::debug = 1;
+#$Getopt::Long::ignorecase = 0;
+
+# Defaults
+$MAX_DEPTH = 5;
+$MAX_DOCS = 50;
+
+GetOptions('version' => \&print_version,
+ 'help' => \&usage,
+ 'depth=i' => \$MAX_DEPTH,
+ 'limit=i' => \$MAX_DOCS,
+ 'verbose!' => \$VERBOSE,
+ 'quiet!' => \$QUIET,
+ 'sleep=i' => \$SLEEP,
+ 'prefix:s' => \$PREFIX,
+ 'referer:s'=> \$REFERER,
+ 'hier' => \$HIER,
+ 'auth=s' => \$AUTH,
+ 'iis' => \$IIS,
+ 'tolower' => \$TOLOWER,
+ 'nospace' => \$NOSPACE,
+ 'keepext=s' => \$KEEPEXT{'OPT'},
+ ) || usage();
+
+sub print_version {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ print <<"EOT";
+This is lwp-rget version $VERSION ($DISTNAME)
+
+Copyright 1996-1998, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+ exit 0;
+}
+
+my $start_url = shift || usage();
+usage() if @ARGV;
+
+require LWP::UserAgent;
+my $ua = new LWP::UserAgent;
+$ua->agent("$progname/$VERSION ");
+$ua->env_proxy;
+
+unless (defined $PREFIX) {
+ $PREFIX = url($start_url); # limit to URLs below this one
+ eval {
+ $PREFIX->eparams(undef);
+ $PREFIX->equery(undef);
+ };
+
+ $_ = $PREFIX->epath;
+ s|[^/]+$||;
+ $PREFIX->epath($_);
+ $PREFIX = $PREFIX->as_string;
+}
+
+%KEEPEXT = map { lc($_) => 1 } split(/\s*,\s*/, ($KEEPEXT{'OPT'}||0));
+
+my $SUPPRESS_REFERER;
+$SUPPRESS_REFERER++ if ($REFERER || "") eq "NONE";
+
+print <<"" if $VERBOSE;
+START = $start_url
+MAX_DEPTH = $MAX_DEPTH
+MAX_DOCS = $MAX_DOCS
+PREFIX = $PREFIX
+
+my $no_docs = 0;
+my %seen = (); # mapping from URL => local_file
+
+my $filename = fetch($start_url, undef, $REFERER);
+print "$filename\n" unless $QUIET;
+
+sub fetch
+{
+ my($url, $type, $referer, $depth) = @_;
+
+ # Fix http://sitename.com/../blah/blah.html to
+ # http://sitename.com/blah/blah.html
+ $url = $url->as_string if (ref($url));
+ while ($url =~ s#(https?://[^/]+/)\.\.\/#$1#) {}
+
+ # Fix backslashes (\) in URL if $IIS defined
+ $url = fix_backslashes($url) if (defined $IIS);
+
+ $url = url($url);
+ $type ||= 'a';
+ # Might be the background attribute
+ $type = 'img' if ($type eq 'body' || $type eq 'td');
+ $depth ||= 0;
+
+ # Print the URL before we start checking...
+ my $out = (" " x $depth) . $url . " ";
+ $out .= "." x (60 - length($out));
+ print STDERR $out . " " if $VERBOSE;
+
+ # Can't get mailto things
+ if ($url->scheme eq 'mailto') {
+ print STDERR "*skipping mailto*\n" if $VERBOSE;
+ return $url->as_string;
+ }
+
+ # The $plain_url is a URL without the fragment part
+ my $plain_url = $url->clone;
+ $plain_url->frag(undef);
+
+ # Check PREFIX, but not for <IMG ...> links
+ if ($type ne 'img' and $url->as_string !~ /^\Q$PREFIX/o) {
+ print STDERR "*outsider*\n" if $VERBOSE;
+ return $url->as_string;
+ }
+
+ # Translate URL to lowercase if $TOLOWER defined
+ $plain_url = to_lower($plain_url) if (defined $TOLOWER);
+
+ # If we already have it, then there is nothing to be done
+ my $seen = $seen{$plain_url->as_string};
+ if ($seen) {
+ my $frag = $url->frag;
+ $seen .= "#$frag" if defined($frag);
+ $seen = protect_frag_spaces($seen);
+ print STDERR "$seen (again)\n" if $VERBOSE;
+ return $seen;
+ }
+
+ # Too much or too deep
+ if ($depth > $MAX_DEPTH and $type ne 'img') {
+ print STDERR "*too deep*\n" if $VERBOSE;
+ return $url;
+ }
+ if ($no_docs > $MAX_DOCS) {
+ print STDERR "*too many*\n" if $VERBOSE;
+ return $url;
+ }
+
+ # Fetch document
+ $no_docs++;
+ sleep($SLEEP) if $SLEEP;
+ my $req = HTTP::Request->new(GET => $url);
+ # See: http://ftp.sunet.se/pub/NT/mirror-microsoft/kb/Q163/7/74.TXT
+ $req->header ('Accept', '*/*') if (defined $IIS); # GIF/JPG from IIS 2.0
+ $req->authorization_basic(split (/:/, $AUTH)) if (defined $AUTH);
+ if ($referer && !$SUPPRESS_REFERER) {
+ if ($req->uri->scheme eq 'http') {
+ # RFC 2616, section 15.1.3
+ $referer = url($referer) unless ref($referer);
+ undef $referer if ($referer->scheme || '') eq 'https';
+ }
+ $req->referer($referer) if $referer;
+ }
+ my $res = $ua->request($req);
+
+ # Check outcome
+ if ($res->is_success) {
+ my $doc = $res->content;
+ my $ct = $res->content_type;
+ my $name = find_name($res->request->uri, $ct);
+ print STDERR "$name\n" unless $QUIET;
+ $seen{$plain_url->as_string} = $name;
+
+ # If the file is HTML, then we look for internal links
+ if ($ct eq "text/html") {
+ # Save an unprosessed version of the HTML document. This
+ # both reserves the name used, and it also ensures that we
+ # don't loose everything if this program is killed before
+ # we finish.
+ save($name, $doc);
+ my $base = $res->base;
+
+ # Follow and substitute links...
+ $doc =~
+s/
+ (
+ <(img|a|body|area|frame|td)\b # some interesting tag
+ [^>]+ # still inside tag (not strictly correct)
+ \b(?:src|href|background) # some link attribute
+ \s*=\s* # =
+ )
+ (?: # scope of OR-ing
+ (")([^"]*)" | # value in double quotes OR
+ (')([^']*)' | # value in single quotes OR
+ ([^\s>]+) # quoteless value
+ )
+/
+ new_link($1, lc($2), $3||$5, HTML::Entities::decode($4||$6||$7),
+ $base, $name, "$url", $depth+1)
+/giex;
+ # XXX
+ # The regular expression above is not strictly correct.
+ # It is not really possible to parse HTML with a single
+ # regular expression, but it is faster. Tags that might
+ # confuse us include:
+ # <a alt="href" href=link.html>
+ # <a alt=">" href="link.html">
+ #
+ }
+ save($name, $doc);
+ return $name;
+ }
+ else {
+ print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE;
+ $seen{$plain_url->as_string} = $url->as_string;
+ return $url->as_string;
+ }
+}
+
+sub new_link
+{
+ my($pre, $type, $quote, $url, $base, $localbase, $referer, $depth) = @_;
+
+ $url = protect_frag_spaces($url);
+
+ $url = fetch(url($url, $base)->abs, $type, $referer, $depth);
+ $url = url("file:$url", "file:$localbase")->rel
+ unless $url =~ /^[.+\-\w]+:/;
+
+ $url = unprotect_frag_spaces($url);
+
+ return $pre . $quote . $url . $quote;
+}
+
+
+sub protect_frag_spaces
+{
+ my ($url) = @_;
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/^([^#]*#)(.+)$/)
+ {
+ my ($base, $frag) = ($1, $2);
+ $frag =~ s/ /%20/g;
+ $url = $base . $frag;
+ }
+
+ return $url;
+}
+
+
+sub unprotect_frag_spaces
+{
+ my ($url) = @_;
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/^([^#]*#)(.+)$/)
+ {
+ my ($base, $frag) = ($1, $2);
+ $frag =~ s/%20/ /g;
+ $url = $base . $frag;
+ }
+
+ return $url;
+}
+
+
+sub fix_backslashes
+{
+ my ($url) = @_;
+ my ($base, $frag);
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ ($base, $frag) = ($1, $2);
+ }
+ else
+ {
+ $base = $url;
+ $frag = "";
+ }
+
+ $base =~ tr/\\/\//;
+ $base =~ s/%5[cC]/\//g; # URL-encoded back slash is %5C
+
+ return $base . $frag;
+}
+
+
+sub to_lower
+{
+ my ($url) = @_;
+ my $was_object = 0;
+
+ if (ref($url))
+ {
+ $url = $url->as_string;
+ $was_object = 1;
+ }
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ $url = lc($1) . $2;
+ }
+ else
+ {
+ $url = lc($url);
+ }
+
+ if ($was_object == 1)
+ {
+ return url($url);
+ }
+ else
+ {
+ return $url;
+ }
+}
+
+
+sub translate_spaces
+{
+ my ($url) = @_;
+ my ($base, $frag);
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ ($base, $frag) = ($1, $2);
+ }
+ else
+ {
+ $base = $url;
+ $frag = "";
+ }
+
+ $base =~ s/^ *//; # Remove initial spaces from base
+ $base =~ s/ *$//; # Remove trailing spaces from base
+
+ $base =~ tr/ /_/;
+ $base =~ s/%20/_/g; # URL-encoded space is %20
+
+ return $base . $frag;
+}
+
+
+sub mkdirp
+{
+ my($directory, $mode) = @_;
+ my @dirs = split(/\//, $directory);
+ my $path = shift(@dirs); # build it as we go
+ my $result = 1; # assume it will work
+
+ unless (-d $path) {
+ $result &&= mkdir($path, $mode);
+ }
+
+ foreach (@dirs) {
+ $path .= "/$_";
+ if ( ! -d $path) {
+ $result &&= mkdir($path, $mode);
+ }
+ }
+
+ return $result;
+}
+
+
+sub find_name
+{
+ my($url, $type) = @_;
+ #print "find_name($url, $type)\n";
+
+ # Translate spaces in URL to underscores (_) if $NOSPACE defined
+ $url = translate_spaces($url) if (defined $NOSPACE);
+
+ # Translate URL to lowercase if $TOLOWER defined
+ $url = to_lower($url) if (defined $TOLOWER);
+
+ $url = url($url) unless ref($url);
+
+ my $path = $url->path;
+
+ # trim path until only the basename is left
+ $path =~ s|(.*/)||;
+ my $dirname = ".$1";
+ if (!$HIER) {
+ $dirname = "";
+ }
+ elsif (! -d $dirname) {
+ mkdirp($dirname, 0775);
+ }
+
+ my $extra = ""; # something to make the name unique
+ my $suffix;
+
+ if ($KEEPEXT{lc($type)}) {
+ $suffix = ($path =~ m/\.(.*)/) ? $1 : "";
+ }
+ else {
+ $suffix = media_suffix($type);
+ }
+
+ $path =~ s|\..*||; # trim suffix
+ $path = "index" unless length $path;
+
+ while (1) {
+ # Construct a new file name
+ my $file = $dirname . $path . $extra;
+ $file .= ".$suffix" if $suffix;
+ # Check if it is unique
+ return $file unless -f $file;
+
+ # Try something extra
+ unless ($extra) {
+ $extra = "001";
+ next;
+ }
+ $extra++;
+ }
+}
+
+
+sub save
+{
+ my $name = shift;
+ #print "save($name,...)\n";
+ open(FILE, ">$name") || die "Can't save $name: $!";
+ binmode FILE;
+ print FILE $_[0];
+ close(FILE);
+}
+
+
+sub usage
+{
+ print <<""; exit 1;
+Usage: $progname [options] <URL>
+Allowed options are:
+ --auth=USER:PASS Set authentication credentials for web site
+ --depth=N Maximum depth to traverse (default is $MAX_DEPTH)
+ --hier Download into hierarchy (not all files into cwd)
+ --referer=URI Set initial referer header (or "NONE")
+ --iis Workaround IIS 2.0 bug by sending "Accept: */*" MIME
+ header; translates backslashes (\\) to forward slashes (/)
+ --keepext=type Keep file extension for MIME types (comma-separated list)
+ --limit=N A limit on the number documents to get (default is $MAX_DOCS)
+ --nospace Translate spaces URLs (not #fragments) to underscores (_)
+ --version Print version number and quit
+ --verbose More output
+ --quiet No output
+ --sleep=SECS Sleep between gets, ie. go slowly
+ --prefix=PREFIX Limit URLs to follow to those which begin with PREFIX
+ --tolower Translate all URLs to lowercase (useful with IIS servers)
+
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/makerandom b/Master/tlpkg/tlperl.straw/bin/makerandom
new file mode 100755
index 00000000000..29b21c6608c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/makerandom
@@ -0,0 +1,50 @@
+#!/usr/bin/perl -sI../lib -Ilib/
+##
+## makerandom - interface to crypt::random
+##
+## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: makerandom,v 1.1.1.1 2001/06/21 15:34:49 vipul Exp $
+
+use Crypt::Random qw( makerandom makerandom_itv );
+
+unless ( $size || $lower ) {
+ my $name = $0;
+ $name =~ s:.*/::;
+ print "usage: $name [options] \
+ -size=bitsize \
+ -strength=[01] \
+ -dev=device \
+ -lower=lower_bound \
+ -upper=upper_bound \
+ -num=quantity\n\n";
+ exit 0;
+}
+
+
+$strength = 0 unless $strength;
+my $i = 1;
+ $num = 1 unless $num;
+
+while ( $i++ <= $num ) {
+
+my $r;
+
+if ( $size ) {
+ $r = makerandom Size => $size,
+ Strength => $strength,
+ Device => $dev;
+}
+
+if ( $lower ) {
+ $r = makerandom_itv Lower => $lower,
+ Upper => $upper,
+ Strength => $strength,
+ Device => $dev;
+}
+
+print "$r\n";
+
+}
diff --git a/Master/tlpkg/tlperl.straw/bin/makerandom.bat b/Master/tlpkg/tlperl.straw/bin/makerandom.bat
new file mode 100755
index 00000000000..672a5dd6812
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/makerandom.bat
@@ -0,0 +1,66 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -sI../lib -Ilib/
+#line 15
+##
+## makerandom - interface to crypt::random
+##
+## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: makerandom,v 1.1.1.1 2001/06/21 15:34:49 vipul Exp $
+
+use Crypt::Random qw( makerandom makerandom_itv );
+
+unless ( $size || $lower ) {
+ my $name = $0;
+ $name =~ s:.*/::;
+ print "usage: $name [options] \
+ -size=bitsize \
+ -strength=[01] \
+ -dev=device \
+ -lower=lower_bound \
+ -upper=upper_bound \
+ -num=quantity\n\n";
+ exit 0;
+}
+
+
+$strength = 0 unless $strength;
+my $i = 1;
+ $num = 1 unless $num;
+
+while ( $i++ <= $num ) {
+
+my $r;
+
+if ( $size ) {
+ $r = makerandom Size => $size,
+ Strength => $strength,
+ Device => $dev;
+}
+
+if ( $lower ) {
+ $r = makerandom_itv Lower => $lower,
+ Upper => $upper,
+ Strength => $strength,
+ Device => $dev;
+}
+
+print "$r\n";
+
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/parinstallppd b/Master/tlpkg/tlperl.straw/bin/parinstallppd
new file mode 100755
index 00000000000..ea4c6385a66
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/parinstallppd
@@ -0,0 +1,124 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Getopt::Long qw/GetOptions/;
+use PAR::Dist::InstallPPD;
+
+our $VERSION = '0.02';
+
+=pod
+
+=head1 NAME
+
+parinstallppd - Install PPD/PPM packages using PAR
+
+=head1 SYNOPSIS
+
+parinstallppd --help
+
+parinstallppd [-v ...] -u PPD-URI-OR-FILE
+
+=head1 DESCRIPTION
+
+This script converts packages for the I<Perl Package Manager>
+which is specific to ActiveState's perl distributions to F<.par>
+files and installs those using L<PAR::Dist>.
+
+It works much the same way as the L<ppd2par> tool but with an additional
+installation step after the conversion.
+
+=head2 Parameters
+
+ -u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+ -v --verbose
+ Sets the verbose mode.
+
+ --sa --selectarch
+ Regexp for selecting the implementation based on architecture.
+ Defaults to the currently running architecture.
+ --sp --selectperl
+ Regexp for selecting the implementation based on perl version.
+ Defaults to the currently running perl version (e.g. 5.8.8) and falls
+ back to the main version (e.g. 5.8) and then other sub-versions
+ (e.g. 5.8.7)
+
+=head1 SEE ALSO
+
+This tool is implemented using the L<PAR::Dist::InstallPPD> module. Please
+refer to that module's documentation for details on how this all works.
+
+PAR has a mailing list, <par@perl.org>, that you can write to; send
+an empty mail to <par-subscribe@perl.org> to join the list and
+participate in the discussion.
+
+Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>.
+
+The official PAR website may be of help, too: http://par.perl.org
+
+For details on the I<Perl Package Manager>, please refer to ActiveState's
+website at L<http://activestate.com>.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by Steffen Mueller
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+my $usage = <<"HERE";
+$0 --help # for help
+
+$0 [-v --no-docs] -u PPD-URI-OR-FILE
+
+This script converts packages for the I<Perl Package Manager>
+which is specific to ActiveState's perl distributions to F<.par>
+files and installs those using L<PAR::Dist>.
+
+It works much the same way as the L<ppd2par> tool but with an additional
+installation step after the conversion.
+
+-u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+-v --verbose
+ Sets the verbose mode.
+
+--sa --selectarch
+ Regexp for selecting the implementation based on architecture.
+ Defaults to the currently running architecture.
+--sp --selectperl
+ Regexp for selecting the implementation based on perl version.
+ Defaults to the currently running perl version (e.g. 5.8.8) and
+ falls back to the main version (e.g. 5.8) and then other
+ sub-versions (e.g. 5.8.7)
+HERE
+
+my $uri;
+my $v = 0;
+my $sperl;
+my $sarch;
+GetOptions(
+ 'sa|selectarch=s' => \$sarch,
+ 'sp|selectperl=s' => \$sperl,
+ 'h|help' => sub { print $usage; exit(1) },
+ 'u|uri=s' => \$uri,
+ 'v|verbose' => \$v,
+);
+
+par_install_ppd(
+ uri => $uri,
+ ($v ? (verbose => 1 ) : ()),
+ ($sarch ? (selectarch => $sarch ) : ()),
+ ($sperl ? (selectperl => $sperl ) : ()),
+);
+
diff --git a/Master/tlpkg/tlperl.straw/bin/parinstallppd.bat b/Master/tlpkg/tlperl.straw/bin/parinstallppd.bat
new file mode 100755
index 00000000000..1a7478353b7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/parinstallppd.bat
@@ -0,0 +1,140 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+use strict;
+use warnings;
+
+use Getopt::Long qw/GetOptions/;
+use PAR::Dist::InstallPPD;
+
+our $VERSION = '0.02';
+
+=pod
+
+=head1 NAME
+
+parinstallppd - Install PPD/PPM packages using PAR
+
+=head1 SYNOPSIS
+
+parinstallppd --help
+
+parinstallppd [-v ...] -u PPD-URI-OR-FILE
+
+=head1 DESCRIPTION
+
+This script converts packages for the I<Perl Package Manager>
+which is specific to ActiveState's perl distributions to F<.par>
+files and installs those using L<PAR::Dist>.
+
+It works much the same way as the L<ppd2par> tool but with an additional
+installation step after the conversion.
+
+=head2 Parameters
+
+ -u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+ -v --verbose
+ Sets the verbose mode.
+
+ --sa --selectarch
+ Regexp for selecting the implementation based on architecture.
+ Defaults to the currently running architecture.
+ --sp --selectperl
+ Regexp for selecting the implementation based on perl version.
+ Defaults to the currently running perl version (e.g. 5.8.8) and falls
+ back to the main version (e.g. 5.8) and then other sub-versions
+ (e.g. 5.8.7)
+
+=head1 SEE ALSO
+
+This tool is implemented using the L<PAR::Dist::InstallPPD> module. Please
+refer to that module's documentation for details on how this all works.
+
+PAR has a mailing list, <par@perl.org>, that you can write to; send
+an empty mail to <par-subscribe@perl.org> to join the list and
+participate in the discussion.
+
+Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>.
+
+The official PAR website may be of help, too: http://par.perl.org
+
+For details on the I<Perl Package Manager>, please refer to ActiveState's
+website at L<http://activestate.com>.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by Steffen Mueller
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+my $usage = <<"HERE";
+$0 --help # for help
+
+$0 [-v --no-docs] -u PPD-URI-OR-FILE
+
+This script converts packages for the I<Perl Package Manager>
+which is specific to ActiveState's perl distributions to F<.par>
+files and installs those using L<PAR::Dist>.
+
+It works much the same way as the L<ppd2par> tool but with an additional
+installation step after the conversion.
+
+-u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+-v --verbose
+ Sets the verbose mode.
+
+--sa --selectarch
+ Regexp for selecting the implementation based on architecture.
+ Defaults to the currently running architecture.
+--sp --selectperl
+ Regexp for selecting the implementation based on perl version.
+ Defaults to the currently running perl version (e.g. 5.8.8) and
+ falls back to the main version (e.g. 5.8) and then other
+ sub-versions (e.g. 5.8.7)
+HERE
+
+my $uri;
+my $v = 0;
+my $sperl;
+my $sarch;
+GetOptions(
+ 'sa|selectarch=s' => \$sarch,
+ 'sp|selectperl=s' => \$sperl,
+ 'h|help' => sub { print $usage; exit(1) },
+ 'u|uri=s' => \$uri,
+ 'v|verbose' => \$v,
+);
+
+par_install_ppd(
+ uri => $uri,
+ ($v ? (verbose => 1 ) : ()),
+ ($sarch ? (selectarch => $sarch ) : ()),
+ ($sperl ? (selectperl => $sperl ) : ()),
+);
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/perl.exe b/Master/tlpkg/tlperl.straw/bin/perl.exe
new file mode 100755
index 00000000000..e66a18bb962
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perl.exe
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/bin/perl5.10.1.exe b/Master/tlpkg/tlperl.straw/bin/perl5.10.1.exe
new file mode 100755
index 00000000000..e66a18bb962
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perl5.10.1.exe
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/bin/perl510.dll b/Master/tlpkg/tlperl.straw/bin/perl510.dll
new file mode 100755
index 00000000000..4a533b76803
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perl510.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/bin/perlbug.bat b/Master/tlpkg/tlperl.straw/bin/perlbug.bat
new file mode 100755
index 00000000000..2d37b78d2ba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perlbug.bat
@@ -0,0 +1,1478 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+my $config_tag1 = '5.10.1 - Wed Jan 27 23:29:27 2010';
+
+my $patchlevel_date = 1250639291;
+my $patch_tags = '';
+my @patches = (
+ ''
+);
+
+use warnings;
+no warnings 'once'; # Eventually, the $::opt_ stuff should get cleaned up
+use strict;
+use Config;
+use File::Spec; # keep perlbug Perl 5.005 compatible
+use Getopt::Std;
+use File::Basename 'basename';
+
+sub paraprint;
+
+BEGIN {
+ eval { require Mail::Send;};
+ $::HaveSend = ($@ eq "");
+ eval { require Mail::Util; } ;
+ $::HaveUtil = ($@ eq "");
+ # use secure tempfiles wherever possible
+ eval { require File::Temp; };
+ $::HaveTemp = ($@ eq "");
+ eval { require Module::CoreList; };
+ $::HaveCoreList = ($@ eq "");
+};
+
+my $Version = "1.39";
+
+# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
+# Changed in 1.07 to see more sendmail execs, and added pipe output.
+# Changed in 1.08 to use correct address for sendmail.
+# Changed in 1.09 to close the REP file before calling it up in the editor.
+# Also removed some old comments duplicated elsewhere.
+# Changed in 1.10 to run under VMS without Mail::Send; also fixed
+# temp filename generation.
+# Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
+# Changed in 1.12 to check for editor errors, make save/send distinction
+# clearer and add $ENV{REPLYTO}.
+# Changed in 1.13 to hopefully make it more difficult to accidentally
+# send mail
+# Changed in 1.14 to make the prompts a little more clear on providing
+# helpful information. Also let file read fail gracefully.
+# Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
+# Also report selected environment variables.
+# Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
+# Changed in 1.17 Win32 support added. GSAR 97-04-12
+# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
+# Changed in 1.19 '-ok' default not '-v'
+# add local patch information
+# warn on '-ok' if this is an old system; add '-okay'
+# Changed in 1.20 Added patchlevel.h reading and version/config checks
+# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
+# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
+# Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
+# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
+# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
+# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
+# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
+# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
+# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
+# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
+# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
+# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
+# Changed in 1.33 Don't require -t STDOUT for -ok.
+# Changed in 1.34 Added Message-Id RFOLEY 18-06-2002
+# Changed in 1.35 Use File::Temp (patch from Solar Designer) NWCLARK 28-02-2004
+# Changed in 1.36 Initial Module::CoreList support Alexandr Ciornii 11-07-2007
+# Changed in 1.37 Killed some string evals, rewrote most prose JESSE 2008-06-08
+# Changed in 1.38 Actually enforce the CoreList check,
+# Record the module the user enters if they do so
+# Refactor prompts to use common code JESSE 2008-06-08
+# Changed in 1.39 Trap mail sending failures (simple ones) so JESSE 2008-06-08
+# users might be able to recover their bug reports
+# Refactor mail sending routines
+# Unify message building code
+# Unify message header building
+# Fix "module" prompting to not squish "category" prompting
+# use warnings; (except 'once' warnings)
+# Unified report fingerprint/change detection code
+# Removed some labeled 'gotos'
+#TODO:
+# make sure failure (transmission-wise) of Mail::Send is accounted for.
+# (This may work now. Unsure of the original author's issue -JESSE 2008-06-08)
+# - Test -b option
+
+my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress,
+ $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile,
+ $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname,
+ $Is_MacOS, $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD,
+ $report_about_module, $category, $severity,
+
+);
+
+my $perl_version = $^V ? sprintf("%vd", $^V) : $];
+
+my $config_tag2 = "$perl_version - $Config{cf_time}";
+
+Init();
+
+if ($::opt_h) { Help(); exit; }
+if ($::opt_d) { Dump(*STDOUT); exit; }
+if (!-t STDIN && !($ok and not $::opt_n)) {
+ paraprint <<"EOF";
+Please use $progname interactively. If you want to
+include a file, you can use the -f switch.
+EOF
+ die "\n";
+}
+
+Query();
+Edit() unless $usefile || ($ok and not $::opt_n);
+NowWhat();
+if ($outfile) {
+ save_message_to_disk($outfile);
+} else {
+ Send();
+ if ($thanks) {
+ print "\nThank you for taking the time to send a thank-you message!\n\n";
+ } else {
+ print "\nThank you for taking the time to file a bug report!\n\n";
+ }
+}
+
+exit;
+
+sub ask_for_alternatives { # (category|severity)
+ my $name = shift;
+ my %alts = (
+ 'category' => {
+ 'default' => 'core',
+ 'ok' => 'install',
+ # Inevitably some of these will end up in RT whatever we do:
+ 'thanks' => 'thanks',
+ 'opts' => [qw(core docs install library utilities)], # patch, notabug
+ },
+ 'severity' => {
+ 'default' => 'low',
+ 'ok' => 'none',
+ 'thanks' => 'none',
+ 'opts' => [qw(critical high medium low wishlist none)], # zero
+ },
+ );
+ die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts);
+ my $alt = "";
+ my $what = $ok || $thanks;
+ if ($what) {
+ $alt = $alts{$name}{$what};
+ } else {
+ my @alts = @{$alts{$name}{'opts'}};
+ print "\n\n";
+ paraprint <<EOF;
+Please pick a $name from the following list:
+
+ @alts
+EOF
+ my $err = 0;
+ do {
+ if ($err++ > 5) {
+ die "Invalid $name: aborting.\n";
+ }
+ $alt = _prompt('', "\u$name", $alts{$name}{'default'});
+ $alt ||= $alts{$name}{'default'};
+ } while !((($alt) = grep(/^$alt/i, @alts)));
+ }
+ lc $alt;
+}
+
+sub Init {
+ # -------- Setup --------
+
+ $Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_VMS = $^O eq 'VMS';
+ $Is_Linux = lc($^O) eq 'linux';
+ $Is_OpenBSD = lc($^O) eq 'openbsd';
+ $Is_MacOS = $^O eq 'MacOS';
+
+ @ARGV = split m/\s+/,
+ MacPerl::Ask('Provide command line args here (-h for help):')
+ if $Is_MacOS && $MacPerl::Version =~ /App/;
+
+ if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T")) { Help(); exit; };
+
+ # This comment is needed to notify metaconfig that we are
+ # using the $perladmin, $cf_by, and $cf_time definitions.
+
+ # -------- Configuration ---------
+
+ # perlbug address
+ $bugaddress = 'perlbug@perl.org';
+
+ # Test address
+ $testaddress = 'perlbug-test@perl.org';
+
+ # Thanks address
+ $thanksaddress = 'perl-thanks@perl.org';
+
+ if (basename ($0) =~ /^perlthanks/i) {
+ # invoked as perlthanks
+ $::opt_T = 1;
+ $::opt_C = 1; # don't send a copy to the local admin
+ }
+
+ if ($::opt_T) {
+ $thanks = 'thanks';
+ }
+
+ $progname = $thanks ? 'perlthanks' : 'perlbug';
+ # Target address
+ $address = $::opt_a || ($::opt_t ? $testaddress
+ : $thanks ? $thanksaddress : $bugaddress);
+
+ # Users address, used in message and in Reply-To header
+ $from = $::opt_r || "";
+
+ # Include verbose configuration information
+ $verbose = $::opt_v || 0;
+
+ # Subject of bug-report message
+ $subject = $::opt_s || "";
+
+ # Send a file
+ $usefile = ($::opt_f || 0);
+
+ # File to send as report
+ $file = $::opt_f || "";
+
+ # File to output to
+ $outfile = $::opt_F || "";
+
+ # Body of report
+ $body = $::opt_b || "";
+
+ # Editor
+ $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
+ || ($Is_VMS && "edit/tpu")
+ || ($Is_MSWin32 && "notepad")
+ || ($Is_MacOS && '')
+ || "vi";
+
+ # Not OK - provide build failure template by finessing OK report
+ if ($::opt_n) {
+ if (substr($::opt_n, 0, 2) eq 'ok' ) {
+ $::opt_o = substr($::opt_n, 1);
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # OK - send "OK" report for build on this system
+ $ok = '';
+ if ($::opt_o) {
+ if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
+ my $age = time - $patchlevel_date;
+ if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
+ my $date = localtime $patchlevel_date;
+ print <<"EOF";
+"perlbug -ok" and "perlbug -nok" do not report on Perl versions which
+are more than 60 days old. This Perl version was constructed on
+$date. If you really want to report this, use
+"perlbug -okay" or "perlbug -nokay".
+EOF
+ exit();
+ }
+ # force these options
+ unless ($::opt_n) {
+ $::opt_S = 1; # don't prompt for send
+ $::opt_b = 1; # we have a body
+ $body = "Perl reported to build OK on this system.\n";
+ }
+ $::opt_C = 1; # don't send a copy to the local admin
+ $::opt_s = 1; # we have a subject line
+ $subject = ($::opt_n ? 'Not ' : '')
+ . "OK: perl $perl_version ${patch_tags}on"
+ ." $::Config{'archname'} $::Config{'osvers'} $subject";
+ $ok = 'ok';
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # Possible administrator addresses, in order of confidence
+ # (Note that cf_email is not mentioned to metaconfig, since
+ # we don't really want it. We'll just take it if we have to.)
+ #
+ # This has to be after the $ok stuff above because of the way
+ # that $::opt_C is forced.
+ $cc = $::opt_C ? "" : (
+ $::opt_c || $::Config{'perladmin'}
+ || $::Config{'cf_email'} || $::Config{'cf_by'}
+ );
+
+ if ($::HaveUtil) {
+ $domain = Mail::Util::maildomain();
+ } elsif ($Is_MSWin32) {
+ $domain = $ENV{'USERDOMAIN'};
+ } else {
+ require Sys::Hostname;
+ $domain = Sys::Hostname::hostname();
+ }
+
+ # Message-Id - rjsf
+ $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>";
+
+ # My username
+ $me = $Is_MSWin32 ? $ENV{'USERNAME'}
+ : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
+ : $Is_MacOS ? $ENV{'USER'}
+ : eval { getpwuid($<) }; # May be missing
+
+ $from = $::Config{'cf_email'}
+ if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
+ ($me eq $::Config{'cf_by'});
+} # sub Init
+
+sub Query {
+ # Explain what perlbug is
+ unless ($ok) {
+ if ($thanks) {
+ paraprint <<'EOF';
+This program provides an easy way to send a thank-you message back to the
+authors and maintainers of perl.
+
+If you wish to submit a bug report, please run it without the -T flag
+(or run the program perlbug rather than perlthanks)
+EOF
+ } else {
+ paraprint <<"EOF";
+This program provides an easy way to create a message reporting a
+bug in the core perl distribution (along with tests or patches)
+to the volunteers who maintain perl at $address. To send a thank-you
+note to $thanksaddress instead of a bug report, please run 'perlthanks'.
+
+Please do not use $0 to send test messages, test whether perl
+works, or to report bugs in perl modules from CPAN.
+
+For help using perl, try posting to the Usenet newsgroup
+comp.lang.perl.misc.
+EOF
+ }
+ }
+
+ # Prompt for subject of message, if needed
+
+ if ($subject && TrivialSubject($subject)) {
+ $subject = '';
+ }
+
+ unless ($subject) {
+ print
+"First of all, please provide a subject for the message.\n";
+ if ( not $thanks) {
+ paraprint <<EOF;
+This should be a concise description of your bug or problem
+which will help the volunteers working to improve perl to categorize
+and resolve the issue. Be as specific and descriptive as
+you can. A subject like "perl bug" or "perl problem" will make it
+much less likely that your issue gets the attention it deserves.
+EOF
+ }
+
+ my $err = 0;
+ do {
+ $subject = _prompt('','Subject');
+ if ($err++ == 5) {
+ if ($thanks) {
+ $subject = 'Thanks for Perl';
+ } else {
+ die "Aborting.\n";
+ }
+ }
+ } while (TrivialSubject($subject));
+ }
+
+ # Prompt for return address, if needed
+ unless ($from) {
+ # Try and guess return address
+ my $guess;
+
+ $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
+ if ($Is_MacOS) {
+ require Mac::InternetConfig;
+ $guess = $Mac::InternetConfig::InternetConfig{
+ Mac::InternetConfig::kICEmail()
+ };
+ }
+
+ unless ($guess) {
+ # move $domain to where we can use it elsewhere
+ if ($domain) {
+ if ($Is_VMS && !$::Config{'d_socket'}) {
+ $guess = "$domain\:\:$me";
+ } else {
+ $guess = "$me\@$domain" if $domain;
+ }
+ }
+ }
+
+ if ($guess) {
+ unless ($ok) {
+ paraprint <<EOF;
+Perl's developers may need your email address to contact you for
+further information about your issue or to inform you when it is
+resolved. If the default shown is not your email address, please
+correct it.
+EOF
+ }
+ } else {
+ paraprint <<EOF;
+Please enter your full internet email address so that Perl's
+developers can contact you with questions about your issue or to
+inform you that it has been resolved.
+EOF
+ }
+
+ if ($ok && $guess) {
+ # use it
+ $from = $guess;
+ } else {
+ # verify it
+ $from = _prompt('','Your address',$guess);
+ $from = $guess if $from eq '';
+ }
+ }
+
+ if ($from eq $cc or $me eq $cc) {
+ # Try not to copy ourselves
+ $cc = "yourself";
+ }
+
+ # Prompt for administrator address, unless an override was given
+ if( !$::opt_C and !$::opt_c ) {
+ my $description = <<EOF;
+$0 can send a copy of this report to your local perl
+administrator. If the address below is wrong, please correct it,
+or enter 'none' or 'yourself' to not send a copy.
+EOF
+ my $entry = _prompt($description, "Local perl administrator", $cc);
+
+ if ($entry ne "") {
+ $cc = $entry;
+ $cc = '' if $me eq $cc;
+ }
+ }
+
+ $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
+ if ($cc) {
+ $andcc = " and $cc"
+ } else {
+ $andcc = ''
+ }
+
+ # Prompt for editor, if no override is given
+editor:
+ unless ($::opt_e || $::opt_f || $::opt_b) {
+
+ my $description;
+
+ chomp (my $common_end = <<"EOF");
+You will probably want to use a text editor to enter the body of
+your report. If "$ed" is the editor you want to use, then just press
+Enter, otherwise type in the name of the editor you would like to
+use.
+
+If you have already composed the body of your report, you may enter
+"file", and $0 will prompt you to enter the name of the file
+containing your report.
+EOF
+
+ if ($thanks) {
+ $description = <<"EOF";
+It's now time to compose your thank-you message.
+
+Some information about your local perl configuration will automatically
+be included at the end of your message, because we're curious about
+the different ways that people build and use perl. If you'd rather
+not share this information, you're welcome to delete it.
+
+$common_end
+EOF
+ } else {
+ $description = <<"EOF";
+It's now time to compose your bug report. Try to make the report
+concise but descriptive. Please include any detail which you think
+might be relevant or might help the volunteers working to improve
+perl. If you are reporting something that does not work as you think
+it should, please try to include examples of the actual result and of
+what you expected.
+
+Some information about your local perl configuration will automatically
+be included at the end of your report. If you are using an unusual
+version of perl, it would be useful if you could confirm that you
+can replicate the problem on a standard build of perl as well.
+
+$common_end
+EOF
+ }
+
+ my $entry = _prompt($description, "Editor", $ed);
+ $usefile = 0;
+ if ($entry eq "file") {
+ $usefile = 1;
+ } elsif ($entry ne "") {
+ $ed = $entry;
+ }
+ }
+ if ($::HaveCoreList && !$ok && !$thanks) {
+ my $description = <<EOF;
+If your bug is about a Perl module rather than a core language
+feature, please enter its name here. If it's not, just hit Enter
+to skip this question.
+EOF
+
+ my $entry = '';
+ while ($entry eq '') {
+ $entry = _prompt($description, 'Module');
+ my $first_release = Module::CoreList->first_release($entry);
+ if ($entry and not $first_release) {
+ paraprint <<EOF;
+$entry is not a "core" Perl module. Please check that you entered
+its name correctly. If it is correct, quit this program, try searching
+for $entry on http://rt.cpan.org, and report your issue there.
+EOF
+
+ $entry = '';
+ } elsif ($entry) {
+ $category ||= 'library';
+ $report_about_module = $entry;
+ last;
+ } else {
+ last;
+ }
+ }
+ }
+
+ # Prompt for category of bug
+ $category ||= ask_for_alternatives('category');
+
+ # Prompt for severity of bug
+ $severity ||= ask_for_alternatives('severity');
+
+ # Generate scratch file to edit report in
+ $filename = filename();
+
+ # Prompt for file to read report from, if needed
+ if ($usefile and !$file) {
+filename:
+ my $description = <<EOF;
+What is the name of the file that contains your report?
+EOF
+ my $entry = _prompt($description, "Filename");
+
+ if ($entry eq "") {
+ paraprint <<EOF;
+It seems you didn't enter a filename. Please choose to use a text
+editor or enter a filename.
+EOF
+ goto editor;
+ }
+
+ unless (-f $entry and -r $entry) {
+ paraprint <<EOF;
+'$entry' doesn't seem to be a readable file. You may have mistyped
+its name or may not have permission to read it.
+
+If you don't want to use a file as the content of your report, just
+hit Enter and you'll be able to select a text editor instead.
+EOF
+ goto filename;
+ }
+ $file = $entry;
+ }
+
+ # Generate report
+ open(REP,">$filename") or die "Unable to create report file '$filename': $!\n";
+ my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug')
+ : $::opt_n ? "build failure" : "success";
+
+ print REP <<EOF;
+This is a $reptype report for perl from $from,
+generated with the help of perlbug $Version running under perl $perl_version.
+
+EOF
+
+ if ($body) {
+ print REP $body;
+ } elsif ($usefile) {
+ open(F, "<$file")
+ or die "Unable to read report file from '$file': $!\n";
+ while (<F>) {
+ print REP $_
+ }
+ close(F) or die "Error closing '$file': $!";
+ } else {
+ if ($thanks) {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please enter your thank-you message here]
+
+
+
+[You're welcome to delete anything below this line]
+-----------------------------------------------------------------
+EOF
+ } else {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please describe your issue here]
+
+
+
+[Please do not change anything below this line]
+-----------------------------------------------------------------
+EOF
+ }
+ }
+ Dump(*REP);
+ close(REP) or die "Error closing report file: $!";
+
+ # Set up an initial report fingerprint so we can compare it later
+ _fingerprint_lines_in_report();
+
+} # sub Query
+
+sub Dump {
+ local(*OUT) = @_;
+
+ print OUT <<EFF;
+---
+Flags:
+ category=$category
+ severity=$severity
+EFF
+
+ if ($report_about_module ) {
+ print OUT <<EFF;
+ module=$report_about_module
+EFF
+ }
+ if ($::opt_A) {
+ print OUT <<EFF;
+ ack=no
+EFF
+ }
+ print OUT <<EFF;
+---
+EFF
+ print OUT "This perlbug was built using Perl $config_tag1\n",
+ "It is being executed now by Perl $config_tag2.\n\n"
+ if $config_tag2 ne $config_tag1;
+
+ print OUT <<EOF;
+Site configuration information for perl $perl_version:
+
+EOF
+ if ($::Config{cf_by} and $::Config{cf_time}) {
+ print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
+ }
+ print OUT Config::myconfig;
+
+ if (@patches) {
+ print OUT join "\n ", "Locally applied patches:", @patches;
+ print OUT "\n";
+ };
+
+ print OUT <<EOF;
+
+---
+\@INC for perl $perl_version:
+EOF
+ for my $i (@INC) {
+ print OUT " $i\n";
+ }
+
+ print OUT <<EOF;
+
+---
+Environment for perl $perl_version:
+EOF
+ my @env =
+ qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
+ push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
+ push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
+ my %env;
+ @env{@env} = @env;
+ for my $env (sort keys %env) {
+ print OUT " $env",
+ exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
+ "\n";
+ }
+ if ($verbose) {
+ print OUT "\nComplete configuration data for perl $perl_version:\n\n";
+ my $value;
+ foreach (sort keys %::Config) {
+ $value = $::Config{$_};
+ $value =~ s/'/\\'/g;
+ print OUT "$_='$value'\n";
+ }
+ }
+} # sub Dump
+
+sub Edit {
+ # Edit the report
+ if ($usefile || $body) {
+ my $description = "Please make sure that the name of the editor you want to use is correct.";
+ my $entry = _prompt($description, 'Editor', $ed);
+ $ed = $entry unless $entry eq '';
+ }
+
+ _edit_file($ed);
+}
+
+sub _edit_file {
+ my $editor = shift;
+
+ my $report_written = 0;
+
+ while ( !$report_written ) {
+ if ($Is_MacOS) {
+ require ExtUtils::MakeMaker;
+ ExtUtils::MM_MacOS::launch_file($filename);
+ _prompt('', "Press Enter when done." );
+ } else { # we're not on oldschool mac os
+ my $exit_status = system("$editor $filename");
+ if ($exit_status) {
+ my $desc = <<EOF;
+The editor you chose ('$editor') could not be run!
+
+If you mistyped its name, please enter it now, otherwise just press Enter.
+EOF
+ my $entry = _prompt( $desc, 'Editor', $editor );
+ if ( $entry ne "" ) {
+ $editor = $entry;
+ next;
+ } else {
+ paraprint <<EOF;
+You may want to save your report to a file, so you can edit and
+mail it later.
+EOF
+ return;
+ }
+ }
+ }
+ return if ( $ok and not $::opt_n ) || $body;
+
+ # Check that we have a report that has some, eh, report in it.
+
+ unless ( _fingerprint_lines_in_report() ) {
+ my $description = <<EOF;
+It looks like you didn't enter a report. You may [r]etry your edit
+or [c]ancel this report.
+EOF
+ my $action = _prompt( $description, "Action (Retry/Cancel) " );
+ if ( $action =~ /^[re]/i ) { # <R>etry <E>dit
+ next;
+ } elsif ( $action =~ /^[cq]/i ) { # <C>ancel, <Q>uit
+ Cancel(); # cancel exits
+ }
+ }
+ # Ok. the user did what they needed to;
+ return;
+
+ }
+}
+
+
+sub Cancel {
+ 1 while unlink($filename); # remove all versions under VMS
+ print "\nQuitting without sending your message.\n";
+ exit(0);
+}
+
+sub NowWhat {
+ # Report is done, prompt for further action
+ if( !$::opt_S ) {
+ while(1) {
+ my $menu = <<EOF;
+
+
+You have finished composing your message. At this point, you have
+a few options. You can:
+
+ * [Se]end the message to $address$andcc,
+ * [D]isplay the message on the screen,
+ * [R]e-edit the message
+ * Display or change the message's [su]bject
+ * Save the message to a [f]ile to mail at another time
+ * [Q]uit without sending a message
+
+EOF
+ retry:
+ print $menu;
+ my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)");;
+ print "\n";
+ if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
+ if ( SaveMessage() ) { exit }
+ } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
+ # Display the message
+ open(REP, "<$filename") or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { print $_ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ } elsif ($action =~ /^su/i) { # <Su>bject
+ my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject");
+ if ($reply ne '') {
+ unless (TrivialSubject($reply)) {
+ $subject = $reply;
+ print "Subject: $subject\n";
+ }
+ }
+ } elsif ($action =~ /^se/i) { # <S>end
+ # Send the message
+ my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no');
+ if ($reply =~ /^yes$/) {
+ last;
+ } else {
+ paraprint <<EOF;
+You didn't type "yes", so your message has not yet been sent.
+EOF
+ }
+ } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
+ # edit the message
+ Edit();
+ } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
+ Cancel();
+ } elsif ($action =~ /^s/i) {
+ paraprint <<EOF;
+The command you entered was ambiguous. Please type "send", "save" or "subject".
+EOF
+ }
+ }
+ }
+} # sub NowWhat
+
+sub TrivialSubject {
+ my $subject = shift;
+ if ($subject =~
+ /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
+ length($subject) < 4 ||
+ $subject !~ /\s/) {
+ print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n";
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub SaveMessage {
+ my $file_save = $outfile || "$progname.rep";
+ my $file = _prompt( '', "Name of file to save message in", $file_save );
+ save_message_to_disk($file) || return undef;
+ print "\n";
+ paraprint <<EOF;
+A copy of your message has been saved in '$file' for you to
+send to '$address' with your normal mail client.
+EOF
+}
+
+sub Send {
+
+ # Message has been accepted for transmission -- Send the message
+
+ # on linux certain "mail" implementations won't accept the subject
+ # as "~s subject" and thus the Subject header will be corrupted
+ # so don't use Mail::Send to be safe
+ eval {
+ if ( $::HaveSend && !$Is_Linux && !$Is_OpenBSD ) {
+ _send_message_mailsend();
+ } elsif ($Is_VMS) {
+ _send_message_vms();
+ } else {
+ _send_message_sendmail();
+ }
+ };
+
+ if ( my $error = $@ ) {
+ paraprint <<EOF;
+$0 has detected an error while trying to send your message: $error.
+
+Your message may not have been sent. You will now have a chance to save a copy to disk.
+EOF
+ SaveMessage();
+ return;
+ }
+
+ 1 while unlink($filename); # remove all versions under VMS
+} # sub Send
+
+sub Help {
+ print <<EOF;
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run "$0" interactively from a command
+line without any special arguments and follow the prompts.
+
+Advanced usage:
+
+$0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
+ [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
+$0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
+
+
+Options:
+
+ -v Include Verbose configuration data in the report
+ -f File containing the body of the report. Use this to
+ quickly send a prepared message.
+ -F File to output the resulting mail message to, instead of mailing.
+ -S Send without asking for confirmation.
+ -a Address to send the report to. Defaults to '$address'.
+ -c Address to send copy of report to. Defaults to '$cc'.
+ -C Don't send copy to administrator.
+ -s Subject to include with the message. You will be prompted
+ if you don't supply one on the command line.
+ -b Body of the report. If not included on the command line, or
+ in a file with -f, you will get a chance to edit the message.
+ -r Your return address. The program will ask you to confirm
+ this if you don't give it here.
+ -e Editor to use.
+ -t Test mode. The target address defaults to '$testaddress'.
+ -T Thank-you mode. The target address defaults to '$thanksaddress'.
+ -d Data mode. This prints out your configuration data, without mailing
+ anything. You can use this with -v to get more complete data.
+ -A Don't send a bug received acknowledgement to the return address.
+ -ok Report successful build on this system to perl porters
+ (use alone or with -v). Only use -ok if *everything* was ok:
+ if there were *any* problems at all, use -nok.
+ -okay As -ok but allow report from old builds.
+ -nok Report unsuccessful build on this system to perl porters
+ (use alone or with -v). You must describe what went wrong
+ in the body of the report which you will be asked to edit.
+ -nokay As -nok but allow report from old builds.
+ -h Print this help message.
+
+EOF
+}
+
+sub filename {
+ if ($::HaveTemp) {
+ # Good. Use a secure temp file
+ my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
+ close($fh);
+ return $filename;
+ } else {
+ # Bah. Fall back to doing things less securely.
+ my $dir = File::Spec->tmpdir();
+ $filename = "bugrep0$$";
+ $filename++ while -e File::Spec->catfile($dir, $filename);
+ $filename = File::Spec->catfile($dir, $filename);
+ }
+}
+
+sub paraprint {
+ my @paragraphs = split /\n{2,}/, "@_";
+ for (@paragraphs) { # implicit local $_
+ s/(\S)\s*\n/$1 /g;
+ write;
+ print "\n";
+ }
+}
+
+sub _prompt {
+ my ($explanation, $prompt, $default) = (@_);
+ if ($explanation) {
+ print "\n\n";
+ paraprint $explanation;
+ }
+ print $prompt. ($default ? " [$default]" :''). ": ";
+ my $result = scalar(<>);
+ chomp($result);
+ $result =~ s/^\s*(.*?)\s*$/$1/s;
+ if ($default && $result eq '') {
+ return $default;
+ } else {
+ return $result;
+ }
+}
+
+sub _build_header {
+ my %attr = (@_);
+
+ my $head = '';
+ for my $header (keys %attr) {
+ $head .= "$header: ".$attr{$header}."\n";
+ }
+ return $head;
+}
+
+sub _message_headers {
+ my %headers = ( To => $address, Subject => $subject );
+ $headers{'Cc'} = $cc if ($cc);
+ $headers{'Message-Id'} = $messageid if ($messageid);
+ $headers{'Reply-To'} = $from if ($from);
+ return \%headers;
+}
+
+sub build_complete_message {
+ my $content = _build_header(%{_message_headers()}) . "\n\n";
+ open( REP, "<$filename" ) or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { $content .= $_; }
+ close(REP) or die "Error closing report file '$filename': $!";
+ return $content;
+}
+
+sub save_message_to_disk {
+ my $file = shift;
+
+ open OUTFILE, ">$file" or do { warn "Couldn't open '$file': $!\n"; return undef};
+ print OUTFILE build_complete_message();
+ close(OUTFILE) or do { warn "Error closing $file: $!"; return undef };
+ print "\nMessage saved.\n";
+ return 1;
+}
+
+sub _send_message_vms {
+ if ( ( $address =~ /@/ and $address !~ /^\w+%"/ )
+ or ( $cc =~ /@/ and $cc !~ /^\w+%"/ ) ) {
+ my $prefix;
+ foreach ( qw[ IN MX SMTP UCX PONY WINS ], '' ) {
+ $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
+ }
+ $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
+ $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
+ }
+ $subject =~ s/"/""/g;
+ $address =~ s/"/""/g;
+ $cc =~ s/"/""/g;
+ my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
+ if ($sts) {
+ die "Can't spawn off mail (leaving bug report in $filename): $sts";
+ }
+}
+
+sub _send_message_mailsend {
+ my $msg = Mail::Send->new();
+ my %headers = %{_message_headers()};
+ for my $key ( keys %headers) {
+ $msg->add($key => $headers{$key});
+ }
+
+ $fh = $msg->open;
+ open(REP, "<$filename") or die "Couldn't open '$filename': $!\n";
+ while (<REP>) { print $fh $_ }
+ close(REP) or die "Error closing $filename: $!";
+ $fh->close;
+
+ print "\nMessage sent.\n";
+}
+
+sub _probe_for_sendmail {
+ my $sendmail = "";
+ for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
+ $sendmail = $_, last if -e $_;
+ }
+ if ( $^O eq 'os2' and $sendmail eq "" ) {
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/:;
+ my @path = split /$Config{'path_sep'}/, $path;
+ for (@path) {
+ $sendmail = "$_/sendmail", last if -e "$_/sendmail";
+ $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
+ }
+ }
+ return $sendmail;
+}
+
+sub _send_message_sendmail {
+ my $sendmail = _probe_for_sendmail();
+ unless ($sendmail) {
+ paraprint(<<"EOF"), die "\n";
+It appears that there is no program which looks like "sendmail" on
+your system and that the Mail::Send library from CPAN isn't available.
+Because of this, there's no easy way to automatically send your
+message.
+
+A copy of your message has been saved in '$filename' for you to
+send to '$address' with your normal mail client.
+EOF
+ }
+
+ open( SENDMAIL, "|$sendmail -t -oi" )
+ || die "'|$sendmail -t -oi' failed: $!";
+ print SENDMAIL build_complete_message();
+ if ( close(SENDMAIL) ) {
+ print "\nMessage sent\n";
+ } else {
+ warn "\nSendmail returned status '", $? >> 8, "'\n";
+ }
+}
+
+
+
+# a strange way to check whether any significant editing
+# has been done: check whether any new non-empty lines
+# have been added.
+
+sub _fingerprint_lines_in_report {
+ my $new_lines = 0;
+ # read in the report template once so that
+ # we can track whether the user does any editing.
+ # yes, *all* whitespace is ignored.
+
+ open(REP, "<$filename") or die "Unable to open report file '$filename': $!\n";
+ while (my $line = <REP>) {
+ $line =~ s/\s+//g;
+ $new_lines++ if (!$REP{$line});
+
+ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ # returns the number of lines with content that wasn't there when last we looked
+ return $new_lines;
+}
+
+
+
+format STDOUT =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+$_
+.
+
+__END__
+
+=head1 NAME
+
+perlbug - how to submit bug reports on Perl
+
+=head1 SYNOPSIS
+
+B<perlbug>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
+S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
+S<[ B<-r> I<returnaddress> ]>
+S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
+S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
+ S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+
+B<perlthanks>
+
+=head1 DESCRIPTION
+
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run it interactively from a command
+line without any special arguments and follow the prompts.
+
+If you have found a bug with a non-standard port (one that was not
+part of the I<standard distribution>), a binary distribution, or a
+non-core module (such as Tk, DBI, etc), then please see the
+documentation that came with that distribution to determine the
+correct place to report bugs.
+
+If you are unable to send your report using B<perlbug> (most likely
+because your system doesn't have a way to send mail that perlbug
+recognizes), you may be able to use this tool to compose your report
+and save it to a file which you can then send to B<perlbug@perl.org>
+using your regular mail client.
+
+In extreme cases, B<perlbug> may not work well enough on your system
+to guide you through composing a bug report. In those cases, you
+may be able to use B<perlbug -d> to get system configuration
+information to include in a manually composed bug report to
+B<perlbug@perl.org>.
+
+
+When reporting a bug, please run through this checklist:
+
+=over 4
+
+=item What version of Perl you are running?
+
+Type C<perl -v> at the command line to find out.
+
+=item Are you running the latest released version of perl?
+
+Look at http://www.perl.org/ to find out. If you are not using the
+latest released version, please try to replicate your bug on the
+latest stable release.
+
+Note that reports about bugs in old versions of Perl, especially
+those which indicate you haven't also tested the current stable
+release of Perl, are likely to receive less attention from the
+volunteers who build and maintain Perl than reports about bugs in
+the current release.
+
+This tool isn't apropriate for reporting bugs in any version
+prior to Perl 5.0.
+
+=item Are you sure what you have is a bug?
+
+A significant number of the bug reports we get turn out to be
+documented features in Perl. Make sure the issue you've run into
+isn't intentional by glancing through the documentation that comes
+with the Perl distribution.
+
+Given the sheer volume of Perl documentation, this isn't a trivial
+undertaking, but if you can point to documentation that suggests
+the behaviour you're seeing is I<wrong>, your issue is likely to
+receive more attention. You may want to start with B<perldoc>
+L<perltrap> for pointers to common traps that new (and experienced)
+Perl programmers run into.
+
+If you're unsure of the meaning of an error message you've run
+across, B<perldoc> L<perldiag> for an explanation. If the message
+isn't in perldiag, it probably isn't generated by Perl. You may
+have luck consulting your operating system documentation instead.
+
+If you are on a non-UNIX platform B<perldoc> L<perlport>, as some
+features may be unimplemented or work differently.
+
+You may be able to figure out what's going wrong using the Perl
+debugger. For information about how to use the debugger B<perldoc>
+L<perldebug>.
+
+=item Do you have a proper test case?
+
+The easier it is to reproduce your bug, the more likely it will be
+fixed -- if nobody can duplicate your problem, it probably won't be
+addressed.
+
+A good test case has most of these attributes: short, simple code;
+few dependencies on external commands, modules, or libraries; no
+platform-dependent code (unless it's a platform-specific bug);
+clear, simple documentation.
+
+A good test case is almost always a good candidate to be included in
+Perl's test suite. If you have the time, consider writing your test case so
+that it can be easily included into the standard test suite.
+
+=item Have you included all relevant information?
+
+Be sure to include the B<exact> error messages, if any.
+"Perl gave an error" is not an exact error message.
+
+If you get a core dump (or equivalent), you may use a debugger
+(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
+report.
+
+NOTE: unless your Perl has been compiled with debug info
+(often B<-g>), the stack trace is likely to be somewhat hard to use
+because it will most probably contain only the function names and not
+their arguments. If possible, recompile your Perl with debug info and
+reproduce the crash and the stack trace.
+
+=item Can you describe the bug in plain English?
+
+The easier it is to understand a reproducible bug, the more likely
+it will be fixed. Any insight you can provide into the problem
+will help a great deal. In other words, try to analyze the problem
+(to the extent you can) and report your discoveries.
+
+=item Can you fix the bug yourself?
+
+A bug report which I<includes a patch to fix it> will almost
+definitely be fixed. When sending a patch, please use the C<diff>
+program with the C<-u> option to generate "unified" diff files.
+Bug reports with patches are likely to receive significantly more
+attention and interest than those without patches.
+
+Your patch may be returned with requests for changes, or requests for more
+detailed explanations about your fix.
+
+Here are a few hints for creating high-quality patches:
+
+Make sure the patch is not reversed (the first argument to diff is
+typically the original file, the second argument your changed file).
+Make sure you test your patch by applying it with the C<patch>
+program before you send it on its way. Try to follow the same style
+as the code you are trying to patch. Make sure your patch really
+does work (C<make test>, if the thing you're patching is covered
+by Perl's test suite).
+
+=item Can you use C<perlbug> to submit the report?
+
+B<perlbug> will, amongst other things, ensure your report includes
+crucial information about your version of perl. If C<perlbug> is
+unable to mail your report after you have typed it in, you may have
+to compose the message yourself, add the output produced by C<perlbug
+-d> and email it to B<perlbug@perl.org>. If, for some reason, you
+cannot run C<perlbug> at all on your system, be sure to include the
+entire output produced by running C<perl -V> (note the uppercase V).
+
+Whether you use C<perlbug> or send the email manually, please make
+your Subject line informative. "a bug" is not informative. Neither
+is "perl crashes" nor is "HELP!!!". These don't help. A compact
+description of what's wrong is fine.
+
+=item Can you use C<perlbug> to submit a thank-you note?
+
+Yes, you can do this by either using the C<-T> option, or by invoking
+the program as C<perlthanks>. Thank-you notes are good. It makes people
+smile.
+
+=back
+
+Having done your bit, please be prepared to wait, to be told the
+bug is in your code, or possibly to get no reply at all. The
+volunteers who maintain Perl are busy folks, so if your problem is
+an obvious bug in your own code, is difficult to understand or is
+a duplicate of an existing report, you may not receive a personal
+reply.
+
+If it is important to you that your bug be fixed, do monitor the
+perl5-porters@perl.org mailing list and the commit logs to development
+versions of Perl, and encourage the maintainers with kind words or
+offers of frosty beverages. (Please do be kind to the maintainers.
+Harassing or flaming them is likely to have the opposite effect of
+the one you want.)
+
+Feel free to update the ticket about your bug on http://rt.perl.org
+if a new version of Perl is released and your bug is still present.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a>
+
+Address to send the report to. Defaults to B<perlbug@perl.org>.
+
+=item B<-A>
+
+Don't send a bug received acknowledgement to the reply address.
+Generally it is only a sensible to use this option if you are a
+perl maintainer actively watching perl porters for your message to
+arrive.
+
+=item B<-b>
+
+Body of the report. If not included on the command line, or
+in a file with B<-f>, you will get a chance to edit the message.
+
+=item B<-C>
+
+Don't send copy to administrator.
+
+=item B<-c>
+
+Address to send copy of report to. Defaults to the address of the
+local perl administrator (recorded when perl was built).
+
+=item B<-d>
+
+Data mode (the default if you redirect or pipe output). This prints out
+your configuration data, without mailing anything. You can use this
+with B<-v> to get more complete data.
+
+=item B<-e>
+
+Editor to use.
+
+=item B<-f>
+
+File containing the body of the report. Use this to quickly send a
+prepared message.
+
+=item B<-F>
+
+File to output the results to instead of sending as an email. Useful
+particularly when running perlbug on a machine with no direct internet
+connection.
+
+=item B<-h>
+
+Prints a brief summary of the options.
+
+=item B<-ok>
+
+Report successful build on this system to perl porters. Forces B<-S>
+and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
+prompts for a return address if it cannot guess it (for use with
+B<make>). Honors return address specified with B<-r>. You can use this
+with B<-v> to get more complete data. Only makes a report if this
+system is less than 60 days old.
+
+=item B<-okay>
+
+As B<-ok> except it will report on older systems.
+
+=item B<-nok>
+
+Report unsuccessful build on this system. Forces B<-C>. Forces and
+supplies a value for B<-s>, then requires you to edit the report
+and say what went wrong. Alternatively, a prepared report may be
+supplied using B<-f>. Only prompts for a return address if it
+cannot guess it (for use with B<make>). Honors return address
+specified with B<-r>. You can use this with B<-v> to get more
+complete data. Only makes a report if this system is less than 60
+days old.
+
+=item B<-nokay>
+
+As B<-nok> except it will report on older systems.
+
+=item B<-r>
+
+Your return address. The program will ask you to confirm its default
+if you don't use this option.
+
+=item B<-S>
+
+Send without asking for confirmation.
+
+=item B<-s>
+
+Subject to include with the message. You will be prompted if you don't
+supply one on the command line.
+
+=item B<-t>
+
+Test mode. The target address defaults to B<perlbug-test@perl.org>.
+
+=item B<-T>
+
+Send a thank-you note instead of a bug report.
+
+=item B<-v>
+
+Include verbose configuration data in the report.
+
+=back
+
+=head1 AUTHORS
+
+Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently
+I<doc>tored by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>),
+Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington
+(E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>),
+Mike Guy (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop
+(E<lt>domo@computer.orgE<gt>), Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
+(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
+Richard Foley (E<lt>richard.foley@rfi.netE<gt>), and Jesse Vincent
+(E<lt>jesse@bestpractical.com<gt>).
+
+=head1 SEE ALSO
+
+perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
+diff(1), patch(1), dbx(1), gdb(1)
+
+=head1 BUGS
+
+None known (guess what must have been used to report them?)
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/perldoc b/Master/tlpkg/tlperl.straw/bin/perldoc
new file mode 100755
index 00000000000..48f9b79ba42
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perldoc
@@ -0,0 +1,7 @@
+#!/usr/bin/perl
+
+require 5;
+BEGIN { $^W = 1 if $ENV{'PERLDOCDEBUG'} }
+use Pod::Perldoc;
+exit( Pod::Perldoc->run() );
+
diff --git a/Master/tlpkg/tlperl.straw/bin/perldoc.bat b/Master/tlpkg/tlperl.straw/bin/perldoc.bat
new file mode 100755
index 00000000000..a6fc80ed1da
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perldoc.bat
@@ -0,0 +1,23 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+require 5;
+BEGIN { $^W = 1 if $ENV{'PERLDOCDEBUG'} }
+use Pod::Perldoc;
+exit( Pod::Perldoc->run() );
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/perlglob.bat b/Master/tlpkg/tlperl.straw/bin/perlglob.bat
new file mode 100755
index 00000000000..f4a81850873
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perlglob.bat
@@ -0,0 +1,69 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use File::DosGlob;
+$| = 1;
+while (@ARGV) {
+ my $arg = shift;
+ my @m = File::DosGlob::doglob(1,$arg);
+ print (@m ? join("\0", sort @m) : $arg);
+ print "\0" if @ARGV;
+}
+__END__
+
+=head1 NAME
+
+perlglob.bat - a more capable perlglob.exe replacement
+
+=head1 SYNOPSIS
+
+ @perlfiles = glob "..\\pe?l/*.p?";
+ print <..\\pe?l/*.p?>;
+
+ # more efficient version
+ > perl -MFile::DosGlob=glob -e "print <../pe?l/*.p?>"
+
+=head1 DESCRIPTION
+
+This file is a portable replacement for perlglob.exe. It
+is largely compatible with perlglob.exe (the Microsoft setargv.obj
+version) in all but one respect--it understands wildcards in
+directory components.
+
+It prints null-separated filenames to standard output.
+
+For details of the globbing features implemented, see
+L<File::DosGlob>.
+
+While one may replace perlglob.exe with this, usage by overriding
+CORE::glob with File::DosGlob::glob should be much more efficient,
+because it avoids launching a separate process, and is therefore
+strongly recommended. See L<perlsub> for details of overriding
+builtins.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy <gsar@activestate.com>
+
+=head1 SEE ALSO
+
+perl
+
+File::DosGlob
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/perlglob.exe b/Master/tlpkg/tlperl.straw/bin/perlglob.exe
new file mode 100755
index 00000000000..ba5b1d47623
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perlglob.exe
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/bin/perlivp.bat b/Master/tlpkg/tlperl.straw/bin/perlivp.bat
new file mode 100755
index 00000000000..c44e6a85615
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perlivp.bat
@@ -0,0 +1,456 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# perlivp v5.10.1
+
+sub usage {
+ warn "@_\n" if @_;
+ print << " EOUSAGE";
+Usage:
+
+ $0 [-a] [-p] [-v] | [-h]
+
+ -a Run all tests (default is to skip .ph tests)
+ -p Print a preface before each test telling what it will test.
+ -v Verbose mode in which extra information about test results
+ is printed. Test failures always print out some extra information
+ regardless of whether or not this switch is set.
+ -h Prints this help message.
+ EOUSAGE
+ exit;
+}
+
+use vars qw(%opt); # allow testing with older versions (do not use our)
+
+@opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
+
+while ($ARGV[0] =~ /^-/) {
+ $ARGV[0] =~ s/^-//;
+ for my $flag (split(//,$ARGV[0])) {
+ usage() if '?' =~ /\Q$flag/;
+ usage() if 'h' =~ /\Q$flag/;
+ usage() if 'H' =~ /\Q$flag/;
+ usage("unknown flag: `$flag'") unless 'HhPpVva' =~ /\Q$flag/;
+ warn "$0: `$flag' flag already set\n" if $opt{$flag}++;
+ }
+ shift;
+}
+
+$opt{p}++ if $opt{P};
+$opt{v}++ if $opt{V};
+
+my $pass__total = 0;
+my $error_total = 0;
+my $tests_total = 0;
+
+my $perlpath = 'C:\strawberry\perl\bin\perl.exe';
+my $useithreads = 'define';
+
+print "## Checking Perl binary via variable `\$perlpath' = $perlpath.\n" if $opt{'p'};
+
+if (-x $perlpath) {
+ print "## Perl binary `$perlpath' appears executable.\n" if $opt{'v'};
+ print "ok 1\n";
+ $pass__total++;
+}
+else {
+ print "# Perl binary `$perlpath' does not appear executable.\n";
+ print "not ok 1\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking Perl version via variable `\$]'.\n" if $opt{'p'};
+
+my $ivp_VERSION = "5.010001";
+
+if ($ivp_VERSION eq $]) {
+ print "## Perl version `$]' appears installed as expected.\n" if $opt{'v'};
+ print "ok 2\n";
+ $pass__total++;
+}
+else {
+ print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
+ print "not ok 2\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking roots of the Perl library directory tree via variable `\@INC'.\n" if $opt{'p'};
+
+my $INC_total = 0;
+my $INC_there = 0;
+foreach (@INC) {
+ next if $_ eq '.'; # skip -d test here
+ if ($^O eq 'MacOS') {
+ next if $_ eq ':'; # skip -d test here
+ next if $_ eq 'Dev:Pseudo:'; # why is this in @INC?
+ }
+ if (-d $_) {
+ print "## Perl \@INC directory `$_' exists.\n" if $opt{'v'};
+ $INC_there++;
+ }
+ else {
+ print "# Perl \@INC directory `$_' does not appear to exist.\n";
+ }
+ $INC_total++;
+}
+if ($INC_total == $INC_there) {
+ print "ok 3\n";
+ $pass__total++;
+}
+else {
+ print "not ok 3\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
+
+my $needed_total = 0;
+my $needed_there = 0;
+foreach (qw(Config.pm ExtUtils/Installed.pm)) {
+ $@ = undef;
+ $needed_total++;
+ eval "require \"$_\";";
+ if (!$@) {
+ print "## Module `$_' appears to be installed.\n" if $opt{'v'};
+ $needed_there++;
+ }
+ else {
+ print "# Needed module `$_' does not appear to be properly installed.\n";
+ }
+ $@ = undef;
+}
+if ($needed_total == $needed_there) {
+ print "ok 4\n";
+ $pass__total++;
+}
+else {
+ print "not ok 4\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
+
+use Config;
+
+my $extensions_total = 0;
+my $extensions_there = 0;
+if (defined($Config{'extensions'})) {
+ my @extensions = split(/\s+/,$Config{'extensions'});
+ foreach (@extensions) {
+ next if ($_ eq '');
+ if ( $useithreads !~ /define/i ) {
+ next if ($_ eq 'threads');
+ next if ($_ eq 'threads/shared');
+ }
+ # that's a distribution name, not a module name
+ next if $_ eq 'IO/Compress';
+ next if $_ eq 'Devel/DProf';
+ # test modules
+ next if $_ eq 'XS/APItest';
+ next if $_ eq 'XS/Typemap';
+ # VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
+ # \NT> perl -e "eval \"require 'Devel/DProf.pm'\"; print $@"
+ # DProf: run perl with -d to use DProf.
+ # Compilation failed in require at (eval 1) line 1.
+ eval " require \"$_.pm\"; ";
+ if (!$@) {
+ print "## Module `$_' appears to be installed.\n" if $opt{'v'};
+ $extensions_there++;
+ }
+ else {
+ print "# Required module `$_' does not appear to be properly installed.\n";
+ $@ = undef;
+ }
+ $extensions_total++;
+ }
+
+ # A silly name for a module (that hopefully won't ever exist).
+ # Note that this test serves more as a check of the validity of the
+ # actuall required module tests above.
+ my $unnecessary = 'bLuRfle';
+
+ if (!grep(/$unnecessary/, @extensions)) {
+ $@ = undef;
+ eval " require \"$unnecessary.pm\"; ";
+ if ($@) {
+ print "## Unnecessary module `$unnecessary' does not appear to be installed.\n" if $opt{'v'};
+ }
+ else {
+ print "# Unnecessary module `$unnecessary' appears to be installed.\n";
+ $extensions_there++;
+ }
+ }
+ $@ = undef;
+}
+if ($extensions_total == $extensions_there) {
+ print "ok 5\n";
+ $pass__total++;
+}
+else {
+ print "not ok 5\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of later additional extensions.\n" if $opt{'p'};
+
+use ExtUtils::Installed;
+
+my $installed_total = 0;
+my $installed_there = 0;
+my $version_check = 0;
+my $installed = ExtUtils::Installed -> new();
+my @modules = $installed -> modules();
+my @missing = ();
+my $version = undef;
+for (@modules) {
+ $installed_total++;
+ # Consider it there if it contains one or more files,
+ # and has zero missing files,
+ # and has a defined version
+ $version = undef;
+ $version = $installed -> version($_);
+ if ($version) {
+ print "## $_; $version\n" if $opt{'v'};
+ $version_check++;
+ }
+ else {
+ print "# $_; NO VERSION\n" if $opt{'v'};
+ }
+ $version = undef;
+ @missing = ();
+ @missing = $installed -> validate($_);
+
+ # .bs files are optional
+ @missing = grep { ! /\.bs$/ } @missing;
+ # man files are often compressed
+ @missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
+
+ if ($#missing >= 0) {
+ print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
+ print '# ',join(' ',@missing),"\n";
+ }
+ elsif ($#missing == -1) {
+ $installed_there++;
+ }
+ @missing = ();
+}
+if (($installed_total == $installed_there) &&
+ ($installed_total == $version_check)) {
+ print "ok 6\n";
+ $pass__total++;
+}
+else {
+ print "not ok 6\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+if ($opt{'a'}) {
+print "## Checking installations of *.h -> *.ph header files.\n" if $opt{'p'};
+my $ph_there = 0;
+my $var = undef;
+my $val = undef;
+my $h_file = undef;
+# Just about "any" C implementation ought to have a stdio.h (even if
+# Config.pm may not list a i_stdio var).
+my @ph_files = qw(stdio.ph);
+# Add the ones that we know that perl thinks are there:
+while (($var, $val) = each %Config) {
+ if ($var =~ m/i_(.+)/ && $val eq 'define') {
+ $h_file = $1;
+ # Some header and symbol names don't match for hysterical raisins.
+ $h_file = 'arpa/inet' if $h_file eq 'arpainet';
+ $h_file = 'netinet/in' if $h_file eq 'niin';
+ $h_file = 'netinet/tcp' if $h_file eq 'netinettcp';
+ $h_file = 'sys/resource' if $h_file eq 'sysresrc';
+ $h_file = 'sys/select' if $h_file eq 'sysselct';
+ $h_file = 'sys/security' if $h_file eq 'syssecrt';
+ $h_file = 'rpcsvc/dbm' if $h_file eq 'rpcsvcdbm';
+ # This ought to distinguish syslog from sys/syslog.
+ # (NB syslog.ph is heavily used for the DBI pre-requisites).
+ $h_file =~ s{^sys(\w.+)}{sys/$1} unless $h_file eq 'syslog';
+ push(@ph_files, "$h_file.ph");
+ }
+}
+#foreach (qw(stdio.ph syslog.ph)) {
+foreach (@ph_files) {
+ $@ = undef;
+ eval "require \"$_\";";
+ if (!$@) {
+ print "## Perl header `$_' appears to be installed.\n" if $opt{'v'};
+ $ph_there++;
+ }
+ else {
+ print "# Perl header `$_' does not appear to be properly installed.\n";
+ }
+ $@ = undef;
+}
+
+if (scalar(@ph_files) == $ph_there) {
+ print "ok 7\n";
+ $pass__total++;
+}
+else {
+ print "not ok 7\n";
+ $error_total++;
+}
+$tests_total++;
+}
+else {
+ print "## Skip checking of *.ph header files.\n" if $opt{'p'};
+}
+
+# Final report (rather than feed ousrselves to Test::Harness::runtests()
+# we simply format some output on our own to keep things simple and
+# easier to "fix" - at least for now.
+
+if ($error_total == 0 && $tests_total) {
+ print "All tests successful.\n";
+} elsif ($tests_total==0){
+ die "FAILED--no tests were run for some reason.\n";
+} else {
+ my $rate = 0.0;
+ if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
+ printf " %d/%d subtests failed, %.2f%% okay.\n",
+ $error_total, $tests_total, $rate;
+}
+
+=head1 NAME
+
+perlivp - Perl Installation Verification Procedure
+
+=head1 SYNOPSIS
+
+B<perlivp> [B<-a>] [B<-p>] [B<-v>] [B<-h>]
+
+=head1 DESCRIPTION
+
+The B<perlivp> program is set up at Perl source code build time to test the
+Perl version it was built under. It can be used after running:
+
+ make install
+
+(or your platform's equivalent procedure) to verify that B<perl> and its
+libraries have been installed correctly. A correct installation is verified
+by output that looks like:
+
+ ok 1
+ ok 2
+
+etc.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-h> help
+
+Prints out a brief help message.
+
+=item B<-a> run all tests
+
+Normally tests for optional features are skipped. With -a all tests
+are executed.
+
+=item B<-p> print preface
+
+Gives a description of each test prior to performing it.
+
+=item B<-v> verbose
+
+Gives more detailed information about each test, after it has been performed.
+Note that any failed tests ought to print out some extra information whether
+or not -v is thrown.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item * print "# Perl binary `$perlpath' does not appear executable.\n";
+
+Likely to occur for a perl binary that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
+
+Likely to occur for a perl that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Perl \@INC directory `$_' does not appear to exist.\n";
+
+Likely to occur for a perl library tree that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Needed module `$_' does not appear to be properly installed.\n";
+
+One of the two modules that is used by perlivp was not present in the
+installation. This is a serious error since it adversely affects perlivp's
+ability to function. You may be able to correct this by performing a
+proper perl installation.
+
+=item * print "# Required module `$_' does not appear to be properly installed.\n";
+
+An attempt to C<eval "require $module"> failed, even though the list of
+extensions indicated that it should succeed. Correct by conducting a proper
+installation.
+
+=item * print "# Unnecessary module `bLuRfle' appears to be installed.\n";
+
+This test not coming out ok could indicate that you have in fact installed
+a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
+test may give misleading results with your installation of perl. If yours
+is the latter case then please let the author know.
+
+=item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
+
+One or more files turned up missing according to a run of
+C<ExtUtils::Installed -E<gt> validate()> over your installation.
+Correct by conducting a proper installation.
+
+=item * print "# Perl header `$_' does not appear to be properly installed.\n";
+
+Correct by running B<h2ph> over your system's C header files. If necessary,
+edit the resulting *.ph files to eliminate perl syntax errors.
+
+=back
+
+For further information on how to conduct a proper installation consult the
+INSTALL file that comes with the perl source and the README file for your
+platform.
+
+=head1 AUTHOR
+
+Peter Prymmer
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/perlthanks.bat b/Master/tlpkg/tlperl.straw/bin/perlthanks.bat
new file mode 100755
index 00000000000..2d37b78d2ba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/perlthanks.bat
@@ -0,0 +1,1478 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+my $config_tag1 = '5.10.1 - Wed Jan 27 23:29:27 2010';
+
+my $patchlevel_date = 1250639291;
+my $patch_tags = '';
+my @patches = (
+ ''
+);
+
+use warnings;
+no warnings 'once'; # Eventually, the $::opt_ stuff should get cleaned up
+use strict;
+use Config;
+use File::Spec; # keep perlbug Perl 5.005 compatible
+use Getopt::Std;
+use File::Basename 'basename';
+
+sub paraprint;
+
+BEGIN {
+ eval { require Mail::Send;};
+ $::HaveSend = ($@ eq "");
+ eval { require Mail::Util; } ;
+ $::HaveUtil = ($@ eq "");
+ # use secure tempfiles wherever possible
+ eval { require File::Temp; };
+ $::HaveTemp = ($@ eq "");
+ eval { require Module::CoreList; };
+ $::HaveCoreList = ($@ eq "");
+};
+
+my $Version = "1.39";
+
+# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
+# Changed in 1.07 to see more sendmail execs, and added pipe output.
+# Changed in 1.08 to use correct address for sendmail.
+# Changed in 1.09 to close the REP file before calling it up in the editor.
+# Also removed some old comments duplicated elsewhere.
+# Changed in 1.10 to run under VMS without Mail::Send; also fixed
+# temp filename generation.
+# Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
+# Changed in 1.12 to check for editor errors, make save/send distinction
+# clearer and add $ENV{REPLYTO}.
+# Changed in 1.13 to hopefully make it more difficult to accidentally
+# send mail
+# Changed in 1.14 to make the prompts a little more clear on providing
+# helpful information. Also let file read fail gracefully.
+# Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
+# Also report selected environment variables.
+# Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
+# Changed in 1.17 Win32 support added. GSAR 97-04-12
+# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
+# Changed in 1.19 '-ok' default not '-v'
+# add local patch information
+# warn on '-ok' if this is an old system; add '-okay'
+# Changed in 1.20 Added patchlevel.h reading and version/config checks
+# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
+# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
+# Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
+# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
+# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
+# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
+# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
+# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
+# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
+# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
+# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
+# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
+# Changed in 1.33 Don't require -t STDOUT for -ok.
+# Changed in 1.34 Added Message-Id RFOLEY 18-06-2002
+# Changed in 1.35 Use File::Temp (patch from Solar Designer) NWCLARK 28-02-2004
+# Changed in 1.36 Initial Module::CoreList support Alexandr Ciornii 11-07-2007
+# Changed in 1.37 Killed some string evals, rewrote most prose JESSE 2008-06-08
+# Changed in 1.38 Actually enforce the CoreList check,
+# Record the module the user enters if they do so
+# Refactor prompts to use common code JESSE 2008-06-08
+# Changed in 1.39 Trap mail sending failures (simple ones) so JESSE 2008-06-08
+# users might be able to recover their bug reports
+# Refactor mail sending routines
+# Unify message building code
+# Unify message header building
+# Fix "module" prompting to not squish "category" prompting
+# use warnings; (except 'once' warnings)
+# Unified report fingerprint/change detection code
+# Removed some labeled 'gotos'
+#TODO:
+# make sure failure (transmission-wise) of Mail::Send is accounted for.
+# (This may work now. Unsure of the original author's issue -JESSE 2008-06-08)
+# - Test -b option
+
+my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress,
+ $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile,
+ $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname,
+ $Is_MacOS, $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD,
+ $report_about_module, $category, $severity,
+
+);
+
+my $perl_version = $^V ? sprintf("%vd", $^V) : $];
+
+my $config_tag2 = "$perl_version - $Config{cf_time}";
+
+Init();
+
+if ($::opt_h) { Help(); exit; }
+if ($::opt_d) { Dump(*STDOUT); exit; }
+if (!-t STDIN && !($ok and not $::opt_n)) {
+ paraprint <<"EOF";
+Please use $progname interactively. If you want to
+include a file, you can use the -f switch.
+EOF
+ die "\n";
+}
+
+Query();
+Edit() unless $usefile || ($ok and not $::opt_n);
+NowWhat();
+if ($outfile) {
+ save_message_to_disk($outfile);
+} else {
+ Send();
+ if ($thanks) {
+ print "\nThank you for taking the time to send a thank-you message!\n\n";
+ } else {
+ print "\nThank you for taking the time to file a bug report!\n\n";
+ }
+}
+
+exit;
+
+sub ask_for_alternatives { # (category|severity)
+ my $name = shift;
+ my %alts = (
+ 'category' => {
+ 'default' => 'core',
+ 'ok' => 'install',
+ # Inevitably some of these will end up in RT whatever we do:
+ 'thanks' => 'thanks',
+ 'opts' => [qw(core docs install library utilities)], # patch, notabug
+ },
+ 'severity' => {
+ 'default' => 'low',
+ 'ok' => 'none',
+ 'thanks' => 'none',
+ 'opts' => [qw(critical high medium low wishlist none)], # zero
+ },
+ );
+ die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts);
+ my $alt = "";
+ my $what = $ok || $thanks;
+ if ($what) {
+ $alt = $alts{$name}{$what};
+ } else {
+ my @alts = @{$alts{$name}{'opts'}};
+ print "\n\n";
+ paraprint <<EOF;
+Please pick a $name from the following list:
+
+ @alts
+EOF
+ my $err = 0;
+ do {
+ if ($err++ > 5) {
+ die "Invalid $name: aborting.\n";
+ }
+ $alt = _prompt('', "\u$name", $alts{$name}{'default'});
+ $alt ||= $alts{$name}{'default'};
+ } while !((($alt) = grep(/^$alt/i, @alts)));
+ }
+ lc $alt;
+}
+
+sub Init {
+ # -------- Setup --------
+
+ $Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_VMS = $^O eq 'VMS';
+ $Is_Linux = lc($^O) eq 'linux';
+ $Is_OpenBSD = lc($^O) eq 'openbsd';
+ $Is_MacOS = $^O eq 'MacOS';
+
+ @ARGV = split m/\s+/,
+ MacPerl::Ask('Provide command line args here (-h for help):')
+ if $Is_MacOS && $MacPerl::Version =~ /App/;
+
+ if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T")) { Help(); exit; };
+
+ # This comment is needed to notify metaconfig that we are
+ # using the $perladmin, $cf_by, and $cf_time definitions.
+
+ # -------- Configuration ---------
+
+ # perlbug address
+ $bugaddress = 'perlbug@perl.org';
+
+ # Test address
+ $testaddress = 'perlbug-test@perl.org';
+
+ # Thanks address
+ $thanksaddress = 'perl-thanks@perl.org';
+
+ if (basename ($0) =~ /^perlthanks/i) {
+ # invoked as perlthanks
+ $::opt_T = 1;
+ $::opt_C = 1; # don't send a copy to the local admin
+ }
+
+ if ($::opt_T) {
+ $thanks = 'thanks';
+ }
+
+ $progname = $thanks ? 'perlthanks' : 'perlbug';
+ # Target address
+ $address = $::opt_a || ($::opt_t ? $testaddress
+ : $thanks ? $thanksaddress : $bugaddress);
+
+ # Users address, used in message and in Reply-To header
+ $from = $::opt_r || "";
+
+ # Include verbose configuration information
+ $verbose = $::opt_v || 0;
+
+ # Subject of bug-report message
+ $subject = $::opt_s || "";
+
+ # Send a file
+ $usefile = ($::opt_f || 0);
+
+ # File to send as report
+ $file = $::opt_f || "";
+
+ # File to output to
+ $outfile = $::opt_F || "";
+
+ # Body of report
+ $body = $::opt_b || "";
+
+ # Editor
+ $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
+ || ($Is_VMS && "edit/tpu")
+ || ($Is_MSWin32 && "notepad")
+ || ($Is_MacOS && '')
+ || "vi";
+
+ # Not OK - provide build failure template by finessing OK report
+ if ($::opt_n) {
+ if (substr($::opt_n, 0, 2) eq 'ok' ) {
+ $::opt_o = substr($::opt_n, 1);
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # OK - send "OK" report for build on this system
+ $ok = '';
+ if ($::opt_o) {
+ if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
+ my $age = time - $patchlevel_date;
+ if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
+ my $date = localtime $patchlevel_date;
+ print <<"EOF";
+"perlbug -ok" and "perlbug -nok" do not report on Perl versions which
+are more than 60 days old. This Perl version was constructed on
+$date. If you really want to report this, use
+"perlbug -okay" or "perlbug -nokay".
+EOF
+ exit();
+ }
+ # force these options
+ unless ($::opt_n) {
+ $::opt_S = 1; # don't prompt for send
+ $::opt_b = 1; # we have a body
+ $body = "Perl reported to build OK on this system.\n";
+ }
+ $::opt_C = 1; # don't send a copy to the local admin
+ $::opt_s = 1; # we have a subject line
+ $subject = ($::opt_n ? 'Not ' : '')
+ . "OK: perl $perl_version ${patch_tags}on"
+ ." $::Config{'archname'} $::Config{'osvers'} $subject";
+ $ok = 'ok';
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # Possible administrator addresses, in order of confidence
+ # (Note that cf_email is not mentioned to metaconfig, since
+ # we don't really want it. We'll just take it if we have to.)
+ #
+ # This has to be after the $ok stuff above because of the way
+ # that $::opt_C is forced.
+ $cc = $::opt_C ? "" : (
+ $::opt_c || $::Config{'perladmin'}
+ || $::Config{'cf_email'} || $::Config{'cf_by'}
+ );
+
+ if ($::HaveUtil) {
+ $domain = Mail::Util::maildomain();
+ } elsif ($Is_MSWin32) {
+ $domain = $ENV{'USERDOMAIN'};
+ } else {
+ require Sys::Hostname;
+ $domain = Sys::Hostname::hostname();
+ }
+
+ # Message-Id - rjsf
+ $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>";
+
+ # My username
+ $me = $Is_MSWin32 ? $ENV{'USERNAME'}
+ : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
+ : $Is_MacOS ? $ENV{'USER'}
+ : eval { getpwuid($<) }; # May be missing
+
+ $from = $::Config{'cf_email'}
+ if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
+ ($me eq $::Config{'cf_by'});
+} # sub Init
+
+sub Query {
+ # Explain what perlbug is
+ unless ($ok) {
+ if ($thanks) {
+ paraprint <<'EOF';
+This program provides an easy way to send a thank-you message back to the
+authors and maintainers of perl.
+
+If you wish to submit a bug report, please run it without the -T flag
+(or run the program perlbug rather than perlthanks)
+EOF
+ } else {
+ paraprint <<"EOF";
+This program provides an easy way to create a message reporting a
+bug in the core perl distribution (along with tests or patches)
+to the volunteers who maintain perl at $address. To send a thank-you
+note to $thanksaddress instead of a bug report, please run 'perlthanks'.
+
+Please do not use $0 to send test messages, test whether perl
+works, or to report bugs in perl modules from CPAN.
+
+For help using perl, try posting to the Usenet newsgroup
+comp.lang.perl.misc.
+EOF
+ }
+ }
+
+ # Prompt for subject of message, if needed
+
+ if ($subject && TrivialSubject($subject)) {
+ $subject = '';
+ }
+
+ unless ($subject) {
+ print
+"First of all, please provide a subject for the message.\n";
+ if ( not $thanks) {
+ paraprint <<EOF;
+This should be a concise description of your bug or problem
+which will help the volunteers working to improve perl to categorize
+and resolve the issue. Be as specific and descriptive as
+you can. A subject like "perl bug" or "perl problem" will make it
+much less likely that your issue gets the attention it deserves.
+EOF
+ }
+
+ my $err = 0;
+ do {
+ $subject = _prompt('','Subject');
+ if ($err++ == 5) {
+ if ($thanks) {
+ $subject = 'Thanks for Perl';
+ } else {
+ die "Aborting.\n";
+ }
+ }
+ } while (TrivialSubject($subject));
+ }
+
+ # Prompt for return address, if needed
+ unless ($from) {
+ # Try and guess return address
+ my $guess;
+
+ $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
+ if ($Is_MacOS) {
+ require Mac::InternetConfig;
+ $guess = $Mac::InternetConfig::InternetConfig{
+ Mac::InternetConfig::kICEmail()
+ };
+ }
+
+ unless ($guess) {
+ # move $domain to where we can use it elsewhere
+ if ($domain) {
+ if ($Is_VMS && !$::Config{'d_socket'}) {
+ $guess = "$domain\:\:$me";
+ } else {
+ $guess = "$me\@$domain" if $domain;
+ }
+ }
+ }
+
+ if ($guess) {
+ unless ($ok) {
+ paraprint <<EOF;
+Perl's developers may need your email address to contact you for
+further information about your issue or to inform you when it is
+resolved. If the default shown is not your email address, please
+correct it.
+EOF
+ }
+ } else {
+ paraprint <<EOF;
+Please enter your full internet email address so that Perl's
+developers can contact you with questions about your issue or to
+inform you that it has been resolved.
+EOF
+ }
+
+ if ($ok && $guess) {
+ # use it
+ $from = $guess;
+ } else {
+ # verify it
+ $from = _prompt('','Your address',$guess);
+ $from = $guess if $from eq '';
+ }
+ }
+
+ if ($from eq $cc or $me eq $cc) {
+ # Try not to copy ourselves
+ $cc = "yourself";
+ }
+
+ # Prompt for administrator address, unless an override was given
+ if( !$::opt_C and !$::opt_c ) {
+ my $description = <<EOF;
+$0 can send a copy of this report to your local perl
+administrator. If the address below is wrong, please correct it,
+or enter 'none' or 'yourself' to not send a copy.
+EOF
+ my $entry = _prompt($description, "Local perl administrator", $cc);
+
+ if ($entry ne "") {
+ $cc = $entry;
+ $cc = '' if $me eq $cc;
+ }
+ }
+
+ $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
+ if ($cc) {
+ $andcc = " and $cc"
+ } else {
+ $andcc = ''
+ }
+
+ # Prompt for editor, if no override is given
+editor:
+ unless ($::opt_e || $::opt_f || $::opt_b) {
+
+ my $description;
+
+ chomp (my $common_end = <<"EOF");
+You will probably want to use a text editor to enter the body of
+your report. If "$ed" is the editor you want to use, then just press
+Enter, otherwise type in the name of the editor you would like to
+use.
+
+If you have already composed the body of your report, you may enter
+"file", and $0 will prompt you to enter the name of the file
+containing your report.
+EOF
+
+ if ($thanks) {
+ $description = <<"EOF";
+It's now time to compose your thank-you message.
+
+Some information about your local perl configuration will automatically
+be included at the end of your message, because we're curious about
+the different ways that people build and use perl. If you'd rather
+not share this information, you're welcome to delete it.
+
+$common_end
+EOF
+ } else {
+ $description = <<"EOF";
+It's now time to compose your bug report. Try to make the report
+concise but descriptive. Please include any detail which you think
+might be relevant or might help the volunteers working to improve
+perl. If you are reporting something that does not work as you think
+it should, please try to include examples of the actual result and of
+what you expected.
+
+Some information about your local perl configuration will automatically
+be included at the end of your report. If you are using an unusual
+version of perl, it would be useful if you could confirm that you
+can replicate the problem on a standard build of perl as well.
+
+$common_end
+EOF
+ }
+
+ my $entry = _prompt($description, "Editor", $ed);
+ $usefile = 0;
+ if ($entry eq "file") {
+ $usefile = 1;
+ } elsif ($entry ne "") {
+ $ed = $entry;
+ }
+ }
+ if ($::HaveCoreList && !$ok && !$thanks) {
+ my $description = <<EOF;
+If your bug is about a Perl module rather than a core language
+feature, please enter its name here. If it's not, just hit Enter
+to skip this question.
+EOF
+
+ my $entry = '';
+ while ($entry eq '') {
+ $entry = _prompt($description, 'Module');
+ my $first_release = Module::CoreList->first_release($entry);
+ if ($entry and not $first_release) {
+ paraprint <<EOF;
+$entry is not a "core" Perl module. Please check that you entered
+its name correctly. If it is correct, quit this program, try searching
+for $entry on http://rt.cpan.org, and report your issue there.
+EOF
+
+ $entry = '';
+ } elsif ($entry) {
+ $category ||= 'library';
+ $report_about_module = $entry;
+ last;
+ } else {
+ last;
+ }
+ }
+ }
+
+ # Prompt for category of bug
+ $category ||= ask_for_alternatives('category');
+
+ # Prompt for severity of bug
+ $severity ||= ask_for_alternatives('severity');
+
+ # Generate scratch file to edit report in
+ $filename = filename();
+
+ # Prompt for file to read report from, if needed
+ if ($usefile and !$file) {
+filename:
+ my $description = <<EOF;
+What is the name of the file that contains your report?
+EOF
+ my $entry = _prompt($description, "Filename");
+
+ if ($entry eq "") {
+ paraprint <<EOF;
+It seems you didn't enter a filename. Please choose to use a text
+editor or enter a filename.
+EOF
+ goto editor;
+ }
+
+ unless (-f $entry and -r $entry) {
+ paraprint <<EOF;
+'$entry' doesn't seem to be a readable file. You may have mistyped
+its name or may not have permission to read it.
+
+If you don't want to use a file as the content of your report, just
+hit Enter and you'll be able to select a text editor instead.
+EOF
+ goto filename;
+ }
+ $file = $entry;
+ }
+
+ # Generate report
+ open(REP,">$filename") or die "Unable to create report file '$filename': $!\n";
+ my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug')
+ : $::opt_n ? "build failure" : "success";
+
+ print REP <<EOF;
+This is a $reptype report for perl from $from,
+generated with the help of perlbug $Version running under perl $perl_version.
+
+EOF
+
+ if ($body) {
+ print REP $body;
+ } elsif ($usefile) {
+ open(F, "<$file")
+ or die "Unable to read report file from '$file': $!\n";
+ while (<F>) {
+ print REP $_
+ }
+ close(F) or die "Error closing '$file': $!";
+ } else {
+ if ($thanks) {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please enter your thank-you message here]
+
+
+
+[You're welcome to delete anything below this line]
+-----------------------------------------------------------------
+EOF
+ } else {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please describe your issue here]
+
+
+
+[Please do not change anything below this line]
+-----------------------------------------------------------------
+EOF
+ }
+ }
+ Dump(*REP);
+ close(REP) or die "Error closing report file: $!";
+
+ # Set up an initial report fingerprint so we can compare it later
+ _fingerprint_lines_in_report();
+
+} # sub Query
+
+sub Dump {
+ local(*OUT) = @_;
+
+ print OUT <<EFF;
+---
+Flags:
+ category=$category
+ severity=$severity
+EFF
+
+ if ($report_about_module ) {
+ print OUT <<EFF;
+ module=$report_about_module
+EFF
+ }
+ if ($::opt_A) {
+ print OUT <<EFF;
+ ack=no
+EFF
+ }
+ print OUT <<EFF;
+---
+EFF
+ print OUT "This perlbug was built using Perl $config_tag1\n",
+ "It is being executed now by Perl $config_tag2.\n\n"
+ if $config_tag2 ne $config_tag1;
+
+ print OUT <<EOF;
+Site configuration information for perl $perl_version:
+
+EOF
+ if ($::Config{cf_by} and $::Config{cf_time}) {
+ print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
+ }
+ print OUT Config::myconfig;
+
+ if (@patches) {
+ print OUT join "\n ", "Locally applied patches:", @patches;
+ print OUT "\n";
+ };
+
+ print OUT <<EOF;
+
+---
+\@INC for perl $perl_version:
+EOF
+ for my $i (@INC) {
+ print OUT " $i\n";
+ }
+
+ print OUT <<EOF;
+
+---
+Environment for perl $perl_version:
+EOF
+ my @env =
+ qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
+ push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
+ push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
+ my %env;
+ @env{@env} = @env;
+ for my $env (sort keys %env) {
+ print OUT " $env",
+ exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
+ "\n";
+ }
+ if ($verbose) {
+ print OUT "\nComplete configuration data for perl $perl_version:\n\n";
+ my $value;
+ foreach (sort keys %::Config) {
+ $value = $::Config{$_};
+ $value =~ s/'/\\'/g;
+ print OUT "$_='$value'\n";
+ }
+ }
+} # sub Dump
+
+sub Edit {
+ # Edit the report
+ if ($usefile || $body) {
+ my $description = "Please make sure that the name of the editor you want to use is correct.";
+ my $entry = _prompt($description, 'Editor', $ed);
+ $ed = $entry unless $entry eq '';
+ }
+
+ _edit_file($ed);
+}
+
+sub _edit_file {
+ my $editor = shift;
+
+ my $report_written = 0;
+
+ while ( !$report_written ) {
+ if ($Is_MacOS) {
+ require ExtUtils::MakeMaker;
+ ExtUtils::MM_MacOS::launch_file($filename);
+ _prompt('', "Press Enter when done." );
+ } else { # we're not on oldschool mac os
+ my $exit_status = system("$editor $filename");
+ if ($exit_status) {
+ my $desc = <<EOF;
+The editor you chose ('$editor') could not be run!
+
+If you mistyped its name, please enter it now, otherwise just press Enter.
+EOF
+ my $entry = _prompt( $desc, 'Editor', $editor );
+ if ( $entry ne "" ) {
+ $editor = $entry;
+ next;
+ } else {
+ paraprint <<EOF;
+You may want to save your report to a file, so you can edit and
+mail it later.
+EOF
+ return;
+ }
+ }
+ }
+ return if ( $ok and not $::opt_n ) || $body;
+
+ # Check that we have a report that has some, eh, report in it.
+
+ unless ( _fingerprint_lines_in_report() ) {
+ my $description = <<EOF;
+It looks like you didn't enter a report. You may [r]etry your edit
+or [c]ancel this report.
+EOF
+ my $action = _prompt( $description, "Action (Retry/Cancel) " );
+ if ( $action =~ /^[re]/i ) { # <R>etry <E>dit
+ next;
+ } elsif ( $action =~ /^[cq]/i ) { # <C>ancel, <Q>uit
+ Cancel(); # cancel exits
+ }
+ }
+ # Ok. the user did what they needed to;
+ return;
+
+ }
+}
+
+
+sub Cancel {
+ 1 while unlink($filename); # remove all versions under VMS
+ print "\nQuitting without sending your message.\n";
+ exit(0);
+}
+
+sub NowWhat {
+ # Report is done, prompt for further action
+ if( !$::opt_S ) {
+ while(1) {
+ my $menu = <<EOF;
+
+
+You have finished composing your message. At this point, you have
+a few options. You can:
+
+ * [Se]end the message to $address$andcc,
+ * [D]isplay the message on the screen,
+ * [R]e-edit the message
+ * Display or change the message's [su]bject
+ * Save the message to a [f]ile to mail at another time
+ * [Q]uit without sending a message
+
+EOF
+ retry:
+ print $menu;
+ my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)");;
+ print "\n";
+ if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
+ if ( SaveMessage() ) { exit }
+ } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
+ # Display the message
+ open(REP, "<$filename") or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { print $_ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ } elsif ($action =~ /^su/i) { # <Su>bject
+ my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject");
+ if ($reply ne '') {
+ unless (TrivialSubject($reply)) {
+ $subject = $reply;
+ print "Subject: $subject\n";
+ }
+ }
+ } elsif ($action =~ /^se/i) { # <S>end
+ # Send the message
+ my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no');
+ if ($reply =~ /^yes$/) {
+ last;
+ } else {
+ paraprint <<EOF;
+You didn't type "yes", so your message has not yet been sent.
+EOF
+ }
+ } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
+ # edit the message
+ Edit();
+ } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
+ Cancel();
+ } elsif ($action =~ /^s/i) {
+ paraprint <<EOF;
+The command you entered was ambiguous. Please type "send", "save" or "subject".
+EOF
+ }
+ }
+ }
+} # sub NowWhat
+
+sub TrivialSubject {
+ my $subject = shift;
+ if ($subject =~
+ /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
+ length($subject) < 4 ||
+ $subject !~ /\s/) {
+ print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n";
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub SaveMessage {
+ my $file_save = $outfile || "$progname.rep";
+ my $file = _prompt( '', "Name of file to save message in", $file_save );
+ save_message_to_disk($file) || return undef;
+ print "\n";
+ paraprint <<EOF;
+A copy of your message has been saved in '$file' for you to
+send to '$address' with your normal mail client.
+EOF
+}
+
+sub Send {
+
+ # Message has been accepted for transmission -- Send the message
+
+ # on linux certain "mail" implementations won't accept the subject
+ # as "~s subject" and thus the Subject header will be corrupted
+ # so don't use Mail::Send to be safe
+ eval {
+ if ( $::HaveSend && !$Is_Linux && !$Is_OpenBSD ) {
+ _send_message_mailsend();
+ } elsif ($Is_VMS) {
+ _send_message_vms();
+ } else {
+ _send_message_sendmail();
+ }
+ };
+
+ if ( my $error = $@ ) {
+ paraprint <<EOF;
+$0 has detected an error while trying to send your message: $error.
+
+Your message may not have been sent. You will now have a chance to save a copy to disk.
+EOF
+ SaveMessage();
+ return;
+ }
+
+ 1 while unlink($filename); # remove all versions under VMS
+} # sub Send
+
+sub Help {
+ print <<EOF;
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run "$0" interactively from a command
+line without any special arguments and follow the prompts.
+
+Advanced usage:
+
+$0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
+ [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
+$0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
+
+
+Options:
+
+ -v Include Verbose configuration data in the report
+ -f File containing the body of the report. Use this to
+ quickly send a prepared message.
+ -F File to output the resulting mail message to, instead of mailing.
+ -S Send without asking for confirmation.
+ -a Address to send the report to. Defaults to '$address'.
+ -c Address to send copy of report to. Defaults to '$cc'.
+ -C Don't send copy to administrator.
+ -s Subject to include with the message. You will be prompted
+ if you don't supply one on the command line.
+ -b Body of the report. If not included on the command line, or
+ in a file with -f, you will get a chance to edit the message.
+ -r Your return address. The program will ask you to confirm
+ this if you don't give it here.
+ -e Editor to use.
+ -t Test mode. The target address defaults to '$testaddress'.
+ -T Thank-you mode. The target address defaults to '$thanksaddress'.
+ -d Data mode. This prints out your configuration data, without mailing
+ anything. You can use this with -v to get more complete data.
+ -A Don't send a bug received acknowledgement to the return address.
+ -ok Report successful build on this system to perl porters
+ (use alone or with -v). Only use -ok if *everything* was ok:
+ if there were *any* problems at all, use -nok.
+ -okay As -ok but allow report from old builds.
+ -nok Report unsuccessful build on this system to perl porters
+ (use alone or with -v). You must describe what went wrong
+ in the body of the report which you will be asked to edit.
+ -nokay As -nok but allow report from old builds.
+ -h Print this help message.
+
+EOF
+}
+
+sub filename {
+ if ($::HaveTemp) {
+ # Good. Use a secure temp file
+ my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
+ close($fh);
+ return $filename;
+ } else {
+ # Bah. Fall back to doing things less securely.
+ my $dir = File::Spec->tmpdir();
+ $filename = "bugrep0$$";
+ $filename++ while -e File::Spec->catfile($dir, $filename);
+ $filename = File::Spec->catfile($dir, $filename);
+ }
+}
+
+sub paraprint {
+ my @paragraphs = split /\n{2,}/, "@_";
+ for (@paragraphs) { # implicit local $_
+ s/(\S)\s*\n/$1 /g;
+ write;
+ print "\n";
+ }
+}
+
+sub _prompt {
+ my ($explanation, $prompt, $default) = (@_);
+ if ($explanation) {
+ print "\n\n";
+ paraprint $explanation;
+ }
+ print $prompt. ($default ? " [$default]" :''). ": ";
+ my $result = scalar(<>);
+ chomp($result);
+ $result =~ s/^\s*(.*?)\s*$/$1/s;
+ if ($default && $result eq '') {
+ return $default;
+ } else {
+ return $result;
+ }
+}
+
+sub _build_header {
+ my %attr = (@_);
+
+ my $head = '';
+ for my $header (keys %attr) {
+ $head .= "$header: ".$attr{$header}."\n";
+ }
+ return $head;
+}
+
+sub _message_headers {
+ my %headers = ( To => $address, Subject => $subject );
+ $headers{'Cc'} = $cc if ($cc);
+ $headers{'Message-Id'} = $messageid if ($messageid);
+ $headers{'Reply-To'} = $from if ($from);
+ return \%headers;
+}
+
+sub build_complete_message {
+ my $content = _build_header(%{_message_headers()}) . "\n\n";
+ open( REP, "<$filename" ) or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { $content .= $_; }
+ close(REP) or die "Error closing report file '$filename': $!";
+ return $content;
+}
+
+sub save_message_to_disk {
+ my $file = shift;
+
+ open OUTFILE, ">$file" or do { warn "Couldn't open '$file': $!\n"; return undef};
+ print OUTFILE build_complete_message();
+ close(OUTFILE) or do { warn "Error closing $file: $!"; return undef };
+ print "\nMessage saved.\n";
+ return 1;
+}
+
+sub _send_message_vms {
+ if ( ( $address =~ /@/ and $address !~ /^\w+%"/ )
+ or ( $cc =~ /@/ and $cc !~ /^\w+%"/ ) ) {
+ my $prefix;
+ foreach ( qw[ IN MX SMTP UCX PONY WINS ], '' ) {
+ $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
+ }
+ $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
+ $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
+ }
+ $subject =~ s/"/""/g;
+ $address =~ s/"/""/g;
+ $cc =~ s/"/""/g;
+ my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
+ if ($sts) {
+ die "Can't spawn off mail (leaving bug report in $filename): $sts";
+ }
+}
+
+sub _send_message_mailsend {
+ my $msg = Mail::Send->new();
+ my %headers = %{_message_headers()};
+ for my $key ( keys %headers) {
+ $msg->add($key => $headers{$key});
+ }
+
+ $fh = $msg->open;
+ open(REP, "<$filename") or die "Couldn't open '$filename': $!\n";
+ while (<REP>) { print $fh $_ }
+ close(REP) or die "Error closing $filename: $!";
+ $fh->close;
+
+ print "\nMessage sent.\n";
+}
+
+sub _probe_for_sendmail {
+ my $sendmail = "";
+ for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
+ $sendmail = $_, last if -e $_;
+ }
+ if ( $^O eq 'os2' and $sendmail eq "" ) {
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/:;
+ my @path = split /$Config{'path_sep'}/, $path;
+ for (@path) {
+ $sendmail = "$_/sendmail", last if -e "$_/sendmail";
+ $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
+ }
+ }
+ return $sendmail;
+}
+
+sub _send_message_sendmail {
+ my $sendmail = _probe_for_sendmail();
+ unless ($sendmail) {
+ paraprint(<<"EOF"), die "\n";
+It appears that there is no program which looks like "sendmail" on
+your system and that the Mail::Send library from CPAN isn't available.
+Because of this, there's no easy way to automatically send your
+message.
+
+A copy of your message has been saved in '$filename' for you to
+send to '$address' with your normal mail client.
+EOF
+ }
+
+ open( SENDMAIL, "|$sendmail -t -oi" )
+ || die "'|$sendmail -t -oi' failed: $!";
+ print SENDMAIL build_complete_message();
+ if ( close(SENDMAIL) ) {
+ print "\nMessage sent\n";
+ } else {
+ warn "\nSendmail returned status '", $? >> 8, "'\n";
+ }
+}
+
+
+
+# a strange way to check whether any significant editing
+# has been done: check whether any new non-empty lines
+# have been added.
+
+sub _fingerprint_lines_in_report {
+ my $new_lines = 0;
+ # read in the report template once so that
+ # we can track whether the user does any editing.
+ # yes, *all* whitespace is ignored.
+
+ open(REP, "<$filename") or die "Unable to open report file '$filename': $!\n";
+ while (my $line = <REP>) {
+ $line =~ s/\s+//g;
+ $new_lines++ if (!$REP{$line});
+
+ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ # returns the number of lines with content that wasn't there when last we looked
+ return $new_lines;
+}
+
+
+
+format STDOUT =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+$_
+.
+
+__END__
+
+=head1 NAME
+
+perlbug - how to submit bug reports on Perl
+
+=head1 SYNOPSIS
+
+B<perlbug>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
+S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
+S<[ B<-r> I<returnaddress> ]>
+S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
+S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
+ S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+
+B<perlthanks>
+
+=head1 DESCRIPTION
+
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run it interactively from a command
+line without any special arguments and follow the prompts.
+
+If you have found a bug with a non-standard port (one that was not
+part of the I<standard distribution>), a binary distribution, or a
+non-core module (such as Tk, DBI, etc), then please see the
+documentation that came with that distribution to determine the
+correct place to report bugs.
+
+If you are unable to send your report using B<perlbug> (most likely
+because your system doesn't have a way to send mail that perlbug
+recognizes), you may be able to use this tool to compose your report
+and save it to a file which you can then send to B<perlbug@perl.org>
+using your regular mail client.
+
+In extreme cases, B<perlbug> may not work well enough on your system
+to guide you through composing a bug report. In those cases, you
+may be able to use B<perlbug -d> to get system configuration
+information to include in a manually composed bug report to
+B<perlbug@perl.org>.
+
+
+When reporting a bug, please run through this checklist:
+
+=over 4
+
+=item What version of Perl you are running?
+
+Type C<perl -v> at the command line to find out.
+
+=item Are you running the latest released version of perl?
+
+Look at http://www.perl.org/ to find out. If you are not using the
+latest released version, please try to replicate your bug on the
+latest stable release.
+
+Note that reports about bugs in old versions of Perl, especially
+those which indicate you haven't also tested the current stable
+release of Perl, are likely to receive less attention from the
+volunteers who build and maintain Perl than reports about bugs in
+the current release.
+
+This tool isn't apropriate for reporting bugs in any version
+prior to Perl 5.0.
+
+=item Are you sure what you have is a bug?
+
+A significant number of the bug reports we get turn out to be
+documented features in Perl. Make sure the issue you've run into
+isn't intentional by glancing through the documentation that comes
+with the Perl distribution.
+
+Given the sheer volume of Perl documentation, this isn't a trivial
+undertaking, but if you can point to documentation that suggests
+the behaviour you're seeing is I<wrong>, your issue is likely to
+receive more attention. You may want to start with B<perldoc>
+L<perltrap> for pointers to common traps that new (and experienced)
+Perl programmers run into.
+
+If you're unsure of the meaning of an error message you've run
+across, B<perldoc> L<perldiag> for an explanation. If the message
+isn't in perldiag, it probably isn't generated by Perl. You may
+have luck consulting your operating system documentation instead.
+
+If you are on a non-UNIX platform B<perldoc> L<perlport>, as some
+features may be unimplemented or work differently.
+
+You may be able to figure out what's going wrong using the Perl
+debugger. For information about how to use the debugger B<perldoc>
+L<perldebug>.
+
+=item Do you have a proper test case?
+
+The easier it is to reproduce your bug, the more likely it will be
+fixed -- if nobody can duplicate your problem, it probably won't be
+addressed.
+
+A good test case has most of these attributes: short, simple code;
+few dependencies on external commands, modules, or libraries; no
+platform-dependent code (unless it's a platform-specific bug);
+clear, simple documentation.
+
+A good test case is almost always a good candidate to be included in
+Perl's test suite. If you have the time, consider writing your test case so
+that it can be easily included into the standard test suite.
+
+=item Have you included all relevant information?
+
+Be sure to include the B<exact> error messages, if any.
+"Perl gave an error" is not an exact error message.
+
+If you get a core dump (or equivalent), you may use a debugger
+(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
+report.
+
+NOTE: unless your Perl has been compiled with debug info
+(often B<-g>), the stack trace is likely to be somewhat hard to use
+because it will most probably contain only the function names and not
+their arguments. If possible, recompile your Perl with debug info and
+reproduce the crash and the stack trace.
+
+=item Can you describe the bug in plain English?
+
+The easier it is to understand a reproducible bug, the more likely
+it will be fixed. Any insight you can provide into the problem
+will help a great deal. In other words, try to analyze the problem
+(to the extent you can) and report your discoveries.
+
+=item Can you fix the bug yourself?
+
+A bug report which I<includes a patch to fix it> will almost
+definitely be fixed. When sending a patch, please use the C<diff>
+program with the C<-u> option to generate "unified" diff files.
+Bug reports with patches are likely to receive significantly more
+attention and interest than those without patches.
+
+Your patch may be returned with requests for changes, or requests for more
+detailed explanations about your fix.
+
+Here are a few hints for creating high-quality patches:
+
+Make sure the patch is not reversed (the first argument to diff is
+typically the original file, the second argument your changed file).
+Make sure you test your patch by applying it with the C<patch>
+program before you send it on its way. Try to follow the same style
+as the code you are trying to patch. Make sure your patch really
+does work (C<make test>, if the thing you're patching is covered
+by Perl's test suite).
+
+=item Can you use C<perlbug> to submit the report?
+
+B<perlbug> will, amongst other things, ensure your report includes
+crucial information about your version of perl. If C<perlbug> is
+unable to mail your report after you have typed it in, you may have
+to compose the message yourself, add the output produced by C<perlbug
+-d> and email it to B<perlbug@perl.org>. If, for some reason, you
+cannot run C<perlbug> at all on your system, be sure to include the
+entire output produced by running C<perl -V> (note the uppercase V).
+
+Whether you use C<perlbug> or send the email manually, please make
+your Subject line informative. "a bug" is not informative. Neither
+is "perl crashes" nor is "HELP!!!". These don't help. A compact
+description of what's wrong is fine.
+
+=item Can you use C<perlbug> to submit a thank-you note?
+
+Yes, you can do this by either using the C<-T> option, or by invoking
+the program as C<perlthanks>. Thank-you notes are good. It makes people
+smile.
+
+=back
+
+Having done your bit, please be prepared to wait, to be told the
+bug is in your code, or possibly to get no reply at all. The
+volunteers who maintain Perl are busy folks, so if your problem is
+an obvious bug in your own code, is difficult to understand or is
+a duplicate of an existing report, you may not receive a personal
+reply.
+
+If it is important to you that your bug be fixed, do monitor the
+perl5-porters@perl.org mailing list and the commit logs to development
+versions of Perl, and encourage the maintainers with kind words or
+offers of frosty beverages. (Please do be kind to the maintainers.
+Harassing or flaming them is likely to have the opposite effect of
+the one you want.)
+
+Feel free to update the ticket about your bug on http://rt.perl.org
+if a new version of Perl is released and your bug is still present.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a>
+
+Address to send the report to. Defaults to B<perlbug@perl.org>.
+
+=item B<-A>
+
+Don't send a bug received acknowledgement to the reply address.
+Generally it is only a sensible to use this option if you are a
+perl maintainer actively watching perl porters for your message to
+arrive.
+
+=item B<-b>
+
+Body of the report. If not included on the command line, or
+in a file with B<-f>, you will get a chance to edit the message.
+
+=item B<-C>
+
+Don't send copy to administrator.
+
+=item B<-c>
+
+Address to send copy of report to. Defaults to the address of the
+local perl administrator (recorded when perl was built).
+
+=item B<-d>
+
+Data mode (the default if you redirect or pipe output). This prints out
+your configuration data, without mailing anything. You can use this
+with B<-v> to get more complete data.
+
+=item B<-e>
+
+Editor to use.
+
+=item B<-f>
+
+File containing the body of the report. Use this to quickly send a
+prepared message.
+
+=item B<-F>
+
+File to output the results to instead of sending as an email. Useful
+particularly when running perlbug on a machine with no direct internet
+connection.
+
+=item B<-h>
+
+Prints a brief summary of the options.
+
+=item B<-ok>
+
+Report successful build on this system to perl porters. Forces B<-S>
+and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
+prompts for a return address if it cannot guess it (for use with
+B<make>). Honors return address specified with B<-r>. You can use this
+with B<-v> to get more complete data. Only makes a report if this
+system is less than 60 days old.
+
+=item B<-okay>
+
+As B<-ok> except it will report on older systems.
+
+=item B<-nok>
+
+Report unsuccessful build on this system. Forces B<-C>. Forces and
+supplies a value for B<-s>, then requires you to edit the report
+and say what went wrong. Alternatively, a prepared report may be
+supplied using B<-f>. Only prompts for a return address if it
+cannot guess it (for use with B<make>). Honors return address
+specified with B<-r>. You can use this with B<-v> to get more
+complete data. Only makes a report if this system is less than 60
+days old.
+
+=item B<-nokay>
+
+As B<-nok> except it will report on older systems.
+
+=item B<-r>
+
+Your return address. The program will ask you to confirm its default
+if you don't use this option.
+
+=item B<-S>
+
+Send without asking for confirmation.
+
+=item B<-s>
+
+Subject to include with the message. You will be prompted if you don't
+supply one on the command line.
+
+=item B<-t>
+
+Test mode. The target address defaults to B<perlbug-test@perl.org>.
+
+=item B<-T>
+
+Send a thank-you note instead of a bug report.
+
+=item B<-v>
+
+Include verbose configuration data in the report.
+
+=back
+
+=head1 AUTHORS
+
+Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently
+I<doc>tored by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>),
+Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington
+(E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>),
+Mike Guy (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop
+(E<lt>domo@computer.orgE<gt>), Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
+(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
+Richard Foley (E<lt>richard.foley@rfi.netE<gt>), and Jesse Vincent
+(E<lt>jesse@bestpractical.com<gt>).
+
+=head1 SEE ALSO
+
+perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
+diff(1), patch(1), dbx(1), gdb(1)
+
+=head1 BUGS
+
+None known (guess what must have been used to report them?)
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/piconv b/Master/tlpkg/tlperl.straw/bin/piconv
new file mode 100755
index 00000000000..9fdebd193cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/piconv
@@ -0,0 +1,299 @@
+#!./perl
+# $Id: piconv,v 2.4 2009/07/08 13:34:15 dankogai Exp $
+#
+use 5.8.0;
+use strict;
+use Encode ;
+use Encode::Alias;
+my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio);
+
+use File::Basename;
+my $name = basename($0);
+
+use Getopt::Long qw(:config no_ignore_case);
+
+my %Opt;
+
+help()
+ unless
+ GetOptions(\%Opt,
+ 'from|f=s',
+ 'to|t=s',
+ 'list|l',
+ 'string|s=s',
+ 'check|C=i',
+ 'c',
+ 'perlqq|p',
+ 'htmlcref',
+ 'xmlcref',
+ 'debug|D',
+ 'scheme|S=s',
+ 'resolve|r=s',
+ 'help',
+ );
+
+$Opt{help} and help();
+$Opt{list} and list_encodings();
+my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG};
+defined $Opt{resolve} and resolve_encoding($Opt{resolve});
+$Opt{from} || $Opt{to} || help();
+my $from = $Opt{from} || $locale or help("from_encoding unspecified");
+my $to = $Opt{to} || $locale or help("to_encoding unspecified");
+$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit;
+my $scheme = do {
+ if (defined $Opt{scheme}) {
+ if (!exists $Scheme{$Opt{scheme}}) {
+ warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n";
+ 'from_to';
+ } else {
+ $Opt{scheme};
+ }
+ } else {
+ 'from_to';
+ }
+};
+
+$Opt{check} ||= $Opt{c};
+$Opt{perlqq} and $Opt{check} = Encode::PERLQQ;
+$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF;
+$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF;
+
+if ($Opt{debug}){
+ my $cfrom = Encode->getEncoding($from)->name;
+ my $cto = Encode->getEncoding($to)->name;
+ print <<"EOT";
+Scheme: $scheme
+From: $from => $cfrom
+To: $to => $cto
+EOT
+}
+
+my %use_bom = map { $_ => 1 } qw/UTF-16 UTF-32/;
+
+# we do not use <> (or ARGV) for the sake of binmode()
+@ARGV or push @ARGV, \*STDIN;
+
+unless ( $scheme eq 'perlio' ) {
+ binmode STDOUT;
+ my $need2slurp = $use_bom{ find_encoding($to)->name };
+ for my $argv (@ARGV) {
+ my $ifh = ref $argv ? $argv : undef;
+ $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
+ $ifh or open $ifh, "<", $argv or next;
+ binmode $ifh;
+ if ( $scheme eq 'from_to' ) { # default
+ if ($need2slurp){
+ local $/;
+ $_ = <$ifh>;
+ Encode::from_to( $_, $from, $to, $Opt{check} );
+ print;
+ }else{
+ while (<$ifh>) {
+ Encode::from_to( $_, $from, $to, $Opt{check} );
+ print;
+ }
+ }
+ }
+ elsif ( $scheme eq 'decode_encode' ) { # step-by-step
+ if ($need2slurp){
+ local $/;
+ $_ = <$ifh>;
+ my $decoded = decode( $from, $_, $Opt{check} );
+ my $encoded = encode( $to, $decoded );
+ print $encoded;
+ }else{
+ while (<$ifh>) {
+ my $decoded = decode( $from, $_, $Opt{check} );
+ my $encoded = encode( $to, $decoded );
+ print $encoded;
+ }
+ }
+ }
+ else { # won't reach
+ die "$name: unknown scheme: $scheme";
+ }
+ }
+}
+else {
+
+ # NI-S favorite
+ binmode STDOUT => "raw:encoding($to)";
+ for my $argv (@ARGV) {
+ my $ifh = ref $argv ? $argv : undef;
+ $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
+ $ifh or open $ifh, "<", $argv or next;
+ binmode $ifh => "raw:encoding($from)";
+ print while (<$ifh>);
+ }
+}
+
+sub list_encodings {
+ print join( "\n", Encode->encodings(":all") ), "\n";
+ exit 0;
+}
+
+sub resolve_encoding {
+ if ( my $alias = Encode::resolve_alias( $_[0] ) ) {
+ print $alias, "\n";
+ exit 0;
+ }
+ else {
+ warn "$name: $_[0] is not known to Encode\n";
+ exit 1;
+ }
+}
+
+sub help {
+ my $message = shift;
+ $message and print STDERR "$name error: $message\n";
+ print STDERR <<"EOT";
+$name [-f from_encoding] [-t to_encoding] [-s string] [files...]
+$name -l
+$name -r encoding_alias
+ -l,--list
+ lists all available encodings
+ -r,--resolve encoding_alias
+ resolve encoding to its (Encode) canonical name
+ -f,--from from_encoding
+ when omitted, the current locale will be used
+ -t,--to to_encoding
+ when omitted, the current locale will be used
+ -s,--string string
+ "string" will be the input instead of STDIN or files
+The following are mainly of interest to Encode hackers:
+ -D,--debug show debug information
+ -C N | -c check the validity of the input
+ -S,--scheme scheme use the scheme for conversion
+Those are handy when you can only see ascii characters:
+ -p,--perlqq
+ --htmlcref
+ --xmlcref
+EOT
+ exit;
+}
+
+__END__
+
+=head1 NAME
+
+piconv -- iconv(1), reinvented in perl
+
+=head1 SYNOPSIS
+
+ piconv [-f from_encoding] [-t to_encoding] [-s string] [files...]
+ piconv -l
+ piconv [-C N|-c|-p]
+ piconv -S scheme ...
+ piconv -r encoding
+ piconv -D ...
+ piconv -h
+
+=head1 DESCRIPTION
+
+B<piconv> is perl version of B<iconv>, a character encoding converter
+widely available for various Unixen today. This script was primarily
+a technology demonstrator for Perl 5.8.0, but you can use piconv in the
+place of iconv for virtually any case.
+
+piconv converts the character encoding of either STDIN or files
+specified in the argument and prints out to STDOUT.
+
+Here is the list of options. Each option can be in short format (-f)
+or long (--from).
+
+=over 4
+
+=item -f,--from from_encoding
+
+Specifies the encoding you are converting from. Unlike B<iconv>,
+this option can be omitted. In such cases, the current locale is used.
+
+=item -t,--to to_encoding
+
+Specifies the encoding you are converting to. Unlike B<iconv>,
+this option can be omitted. In such cases, the current locale is used.
+
+Therefore, when both -f and -t are omitted, B<piconv> just acts
+like B<cat>.
+
+=item -s,--string I<string>
+
+uses I<string> instead of file for the source of text.
+
+=item -l,--list
+
+Lists all available encodings, one per line, in case-insensitive
+order. Note that only the canonical names are listed; many aliases
+exist. For example, the names are case-insensitive, and many standard
+and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850"
+instead of "cp850", or "winlatin1" for "cp1252". See L<Encode::Supported>
+for a full discussion.
+
+=item -C,--check I<N>
+
+Check the validity of the stream if I<N> = 1. When I<N> = -1, something
+interesting happens when it encounters an invalid character.
+
+=item -c
+
+Same as C<-C 1>.
+
+=item -p,--perlqq
+
+=item --htmlcref
+
+=item --xmlcref
+
+Applies PERLQQ, HTMLCREF, XMLCREF, respectively. Try
+
+ piconv -f utf8 -t ascii --perlqq
+
+To see what it does.
+
+=item -h,--help
+
+Show usage.
+
+=item -D,--debug
+
+Invokes debugging mode. Primarily for Encode hackers.
+
+=item -S,--scheme scheme
+
+Selects which scheme is to be used for conversion. Available schemes
+are as follows:
+
+=over 4
+
+=item from_to
+
+Uses Encode::from_to for conversion. This is the default.
+
+=item decode_encode
+
+Input strings are decode()d then encode()d. A straight two-step
+implementation.
+
+=item perlio
+
+The new perlIO layer is used. NI-S' favorite.
+
+You should use this option if you are using UTF-16 and others which
+linefeed is not $/.
+
+=back
+
+Like the I<-D> option, this is also for Encode hackers.
+
+=back
+
+=head1 SEE ALSO
+
+L<iconv(1)>
+L<locale(3)>
+L<Encode>
+L<Encode::Supported>
+L<Encode::Alias>
+L<PerlIO>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/piconv.bat b/Master/tlpkg/tlperl.straw/bin/piconv.bat
new file mode 100755
index 00000000000..a255687f2af
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/piconv.bat
@@ -0,0 +1,315 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!./perl
+#line 15
+# $Id: piconv,v 2.4 2009/07/08 13:34:15 dankogai Exp $
+#
+use 5.8.0;
+use strict;
+use Encode ;
+use Encode::Alias;
+my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio);
+
+use File::Basename;
+my $name = basename($0);
+
+use Getopt::Long qw(:config no_ignore_case);
+
+my %Opt;
+
+help()
+ unless
+ GetOptions(\%Opt,
+ 'from|f=s',
+ 'to|t=s',
+ 'list|l',
+ 'string|s=s',
+ 'check|C=i',
+ 'c',
+ 'perlqq|p',
+ 'htmlcref',
+ 'xmlcref',
+ 'debug|D',
+ 'scheme|S=s',
+ 'resolve|r=s',
+ 'help',
+ );
+
+$Opt{help} and help();
+$Opt{list} and list_encodings();
+my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG};
+defined $Opt{resolve} and resolve_encoding($Opt{resolve});
+$Opt{from} || $Opt{to} || help();
+my $from = $Opt{from} || $locale or help("from_encoding unspecified");
+my $to = $Opt{to} || $locale or help("to_encoding unspecified");
+$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit;
+my $scheme = do {
+ if (defined $Opt{scheme}) {
+ if (!exists $Scheme{$Opt{scheme}}) {
+ warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n";
+ 'from_to';
+ } else {
+ $Opt{scheme};
+ }
+ } else {
+ 'from_to';
+ }
+};
+
+$Opt{check} ||= $Opt{c};
+$Opt{perlqq} and $Opt{check} = Encode::PERLQQ;
+$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF;
+$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF;
+
+if ($Opt{debug}){
+ my $cfrom = Encode->getEncoding($from)->name;
+ my $cto = Encode->getEncoding($to)->name;
+ print <<"EOT";
+Scheme: $scheme
+From: $from => $cfrom
+To: $to => $cto
+EOT
+}
+
+my %use_bom = map { $_ => 1 } qw/UTF-16 UTF-32/;
+
+# we do not use <> (or ARGV) for the sake of binmode()
+@ARGV or push @ARGV, \*STDIN;
+
+unless ( $scheme eq 'perlio' ) {
+ binmode STDOUT;
+ my $need2slurp = $use_bom{ find_encoding($to)->name };
+ for my $argv (@ARGV) {
+ my $ifh = ref $argv ? $argv : undef;
+ $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
+ $ifh or open $ifh, "<", $argv or next;
+ binmode $ifh;
+ if ( $scheme eq 'from_to' ) { # default
+ if ($need2slurp){
+ local $/;
+ $_ = <$ifh>;
+ Encode::from_to( $_, $from, $to, $Opt{check} );
+ print;
+ }else{
+ while (<$ifh>) {
+ Encode::from_to( $_, $from, $to, $Opt{check} );
+ print;
+ }
+ }
+ }
+ elsif ( $scheme eq 'decode_encode' ) { # step-by-step
+ if ($need2slurp){
+ local $/;
+ $_ = <$ifh>;
+ my $decoded = decode( $from, $_, $Opt{check} );
+ my $encoded = encode( $to, $decoded );
+ print $encoded;
+ }else{
+ while (<$ifh>) {
+ my $decoded = decode( $from, $_, $Opt{check} );
+ my $encoded = encode( $to, $decoded );
+ print $encoded;
+ }
+ }
+ }
+ else { # won't reach
+ die "$name: unknown scheme: $scheme";
+ }
+ }
+}
+else {
+
+ # NI-S favorite
+ binmode STDOUT => "raw:encoding($to)";
+ for my $argv (@ARGV) {
+ my $ifh = ref $argv ? $argv : undef;
+ $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
+ $ifh or open $ifh, "<", $argv or next;
+ binmode $ifh => "raw:encoding($from)";
+ print while (<$ifh>);
+ }
+}
+
+sub list_encodings {
+ print join( "\n", Encode->encodings(":all") ), "\n";
+ exit 0;
+}
+
+sub resolve_encoding {
+ if ( my $alias = Encode::resolve_alias( $_[0] ) ) {
+ print $alias, "\n";
+ exit 0;
+ }
+ else {
+ warn "$name: $_[0] is not known to Encode\n";
+ exit 1;
+ }
+}
+
+sub help {
+ my $message = shift;
+ $message and print STDERR "$name error: $message\n";
+ print STDERR <<"EOT";
+$name [-f from_encoding] [-t to_encoding] [-s string] [files...]
+$name -l
+$name -r encoding_alias
+ -l,--list
+ lists all available encodings
+ -r,--resolve encoding_alias
+ resolve encoding to its (Encode) canonical name
+ -f,--from from_encoding
+ when omitted, the current locale will be used
+ -t,--to to_encoding
+ when omitted, the current locale will be used
+ -s,--string string
+ "string" will be the input instead of STDIN or files
+The following are mainly of interest to Encode hackers:
+ -D,--debug show debug information
+ -C N | -c check the validity of the input
+ -S,--scheme scheme use the scheme for conversion
+Those are handy when you can only see ascii characters:
+ -p,--perlqq
+ --htmlcref
+ --xmlcref
+EOT
+ exit;
+}
+
+__END__
+
+=head1 NAME
+
+piconv -- iconv(1), reinvented in perl
+
+=head1 SYNOPSIS
+
+ piconv [-f from_encoding] [-t to_encoding] [-s string] [files...]
+ piconv -l
+ piconv [-C N|-c|-p]
+ piconv -S scheme ...
+ piconv -r encoding
+ piconv -D ...
+ piconv -h
+
+=head1 DESCRIPTION
+
+B<piconv> is perl version of B<iconv>, a character encoding converter
+widely available for various Unixen today. This script was primarily
+a technology demonstrator for Perl 5.8.0, but you can use piconv in the
+place of iconv for virtually any case.
+
+piconv converts the character encoding of either STDIN or files
+specified in the argument and prints out to STDOUT.
+
+Here is the list of options. Each option can be in short format (-f)
+or long (--from).
+
+=over 4
+
+=item -f,--from from_encoding
+
+Specifies the encoding you are converting from. Unlike B<iconv>,
+this option can be omitted. In such cases, the current locale is used.
+
+=item -t,--to to_encoding
+
+Specifies the encoding you are converting to. Unlike B<iconv>,
+this option can be omitted. In such cases, the current locale is used.
+
+Therefore, when both -f and -t are omitted, B<piconv> just acts
+like B<cat>.
+
+=item -s,--string I<string>
+
+uses I<string> instead of file for the source of text.
+
+=item -l,--list
+
+Lists all available encodings, one per line, in case-insensitive
+order. Note that only the canonical names are listed; many aliases
+exist. For example, the names are case-insensitive, and many standard
+and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850"
+instead of "cp850", or "winlatin1" for "cp1252". See L<Encode::Supported>
+for a full discussion.
+
+=item -C,--check I<N>
+
+Check the validity of the stream if I<N> = 1. When I<N> = -1, something
+interesting happens when it encounters an invalid character.
+
+=item -c
+
+Same as C<-C 1>.
+
+=item -p,--perlqq
+
+=item --htmlcref
+
+=item --xmlcref
+
+Applies PERLQQ, HTMLCREF, XMLCREF, respectively. Try
+
+ piconv -f utf8 -t ascii --perlqq
+
+To see what it does.
+
+=item -h,--help
+
+Show usage.
+
+=item -D,--debug
+
+Invokes debugging mode. Primarily for Encode hackers.
+
+=item -S,--scheme scheme
+
+Selects which scheme is to be used for conversion. Available schemes
+are as follows:
+
+=over 4
+
+=item from_to
+
+Uses Encode::from_to for conversion. This is the default.
+
+=item decode_encode
+
+Input strings are decode()d then encode()d. A straight two-step
+implementation.
+
+=item perlio
+
+The new perlIO layer is used. NI-S' favorite.
+
+You should use this option if you are using UTF-16 and others which
+linefeed is not $/.
+
+=back
+
+Like the I<-D> option, this is also for Encode hackers.
+
+=back
+
+=head1 SEE ALSO
+
+L<iconv(1)>
+L<locale(3)>
+L<Encode>
+L<Encode::Supported>
+L<Encode::Alias>
+L<PerlIO>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pip b/Master/tlpkg/tlperl.straw/bin/pip
new file mode 100755
index 00000000000..f7f5a41df7d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pip
@@ -0,0 +1,23 @@
+#!/usr/bin/perl
+
+use 5.00503;
+use strict;
+use pip;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.16';
+}
+
+eval {
+ pip::main( @ARGV );
+};
+
+if ( $@ ) {
+ my $errstr = $@;
+ $errstr =~ s/\sat line\b.+$//;
+ print "Unexpected Error: $errstr\n";
+ exit(255);
+}
+
+exit(0);
diff --git a/Master/tlpkg/tlperl.straw/bin/pip.bat b/Master/tlpkg/tlperl.straw/bin/pip.bat
new file mode 100755
index 00000000000..eea5b74873c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pip.bat
@@ -0,0 +1,39 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use 5.00503;
+use strict;
+use pip;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.16';
+}
+
+eval {
+ pip::main( @ARGV );
+};
+
+if ( $@ ) {
+ my $errstr = $@;
+ $errstr =~ s/\sat line\b.+$//;
+ print "Unexpected Error: $errstr\n";
+ exit(255);
+}
+
+exit(0);
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pl2bat.bat b/Master/tlpkg/tlperl.straw/bin/pl2bat.bat
new file mode 100755
index 00000000000..64887875c96
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pl2bat.bat
@@ -0,0 +1,430 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -x -S "$0" ${1+"$@"}'
+ if 0; # In case running under some shell
+
+require 5;
+use Getopt::Std;
+use Config;
+
+$0 =~ s|.*[/\\]||;
+
+my $usage = <<EOT;
+Usage: $0 [-h]
+ or: $0 [-w] [-u] [-a argstring] [-s stripsuffix] [files]
+ or: $0 [-w] [-u] [-n ntargs] [-o otherargs] [-s stripsuffix] [files]
+ -n ntargs arguments to invoke perl with in generated file
+ when run from Windows NT. Defaults to
+ '-x -S %0 %*'.
+ -o otherargs arguments to invoke perl with in generated file
+ other than when run from Windows NT. Defaults
+ to '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9'.
+ -a argstring arguments to invoke perl with in generated file
+ ignoring operating system (for compatibility
+ with previous pl2bat versions).
+ -u update files that may have already been processed
+ by (some version of) pl2bat.
+ -w include "-w" on the /^#!.*perl/ line (unless
+ a /^#!.*perl/ line was already present).
+ -s stripsuffix strip this suffix from file before appending ".bat"
+ Not case-sensitive
+ Can be a regex if it begins with `/'
+ Defaults to "/\.plx?/"
+ -h show this help
+EOT
+
+my %OPT = ();
+warn($usage), exit(0) if !getopts('whun:o:a:s:',\%OPT) or $OPT{'h'};
+# NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
+$OPT{'n'} = '-x -S %0 %*' unless exists $OPT{'n'};
+$OPT{'o'} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $OPT{'o'};
+$OPT{'s'} = '/\\.plx?/' unless exists $OPT{'s'};
+$OPT{'s'} = ($OPT{'s'} =~ m#^/([^/]*[^/\$]|)\$?/?$# ? $1 : "\Q$OPT{'s'}\E");
+
+my $head;
+if( defined( $OPT{'a'} ) ) {
+ $head = <<EOT;
+ \@rem = '--*-Perl-*--
+ \@echo off
+ perl $OPT{'a'}
+ goto endofperl
+ \@rem ';
+EOT
+} else {
+ $head = <<EOT;
+ \@rem = '--*-Perl-*--
+ \@echo off
+ if "%OS%" == "Windows_NT" goto WinNT
+ perl $OPT{'o'}
+ goto endofperl
+ :WinNT
+ perl $OPT{'n'}
+ if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
+ if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+ if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+ goto endofperl
+ \@rem ';
+EOT
+}
+$head =~ s/^\t//gm;
+my $headlines = 2 + ($head =~ tr/\n/\n/);
+my $tail = "\n__END__\n:endofperl\n";
+
+@ARGV = ('-') unless @ARGV;
+
+foreach ( @ARGV ) {
+ process($_);
+}
+
+sub process {
+ my( $file )= @_;
+ my $myhead = $head;
+ my $linedone = 0;
+ my $taildone = 0;
+ my $linenum = 0;
+ my $skiplines = 0;
+ my $line;
+ my $start= $Config{startperl};
+ $start= "#!perl" unless $start =~ /^#!.*perl/;
+ open( FILE, $file ) or die "$0: Can't open $file: $!";
+ @file = <FILE>;
+ foreach $line ( @file ) {
+ $linenum++;
+ if ( $line =~ /^:endofperl\b/ ) {
+ if( ! exists $OPT{'u'} ) {
+ warn "$0: $file has already been converted to a batch file!\n";
+ return;
+ }
+ $taildone++;
+ }
+ if ( not $linedone and $line =~ /^#!.*perl/ ) {
+ if( exists $OPT{'u'} ) {
+ $skiplines = $linenum - 1;
+ $line .= "#line ".(1+$headlines)."\n";
+ } else {
+ $line .= "#line ".($linenum+$headlines)."\n";
+ }
+ $linedone++;
+ }
+ if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
+ $line = "";
+ }
+ }
+ close( FILE );
+ $file =~ s/$OPT{'s'}$//oi;
+ $file .= '.bat' unless $file =~ /\.bat$/i or $file =~ /^-$/;
+ open( FILE, ">$file" ) or die "Can't open $file: $!";
+ print FILE $myhead;
+ print FILE $start, ( $OPT{'w'} ? " -w" : "" ),
+ "\n#line ", ($headlines+1), "\n" unless $linedone;
+ print FILE @file[$skiplines..$#file];
+ print FILE $tail unless $taildone;
+ close( FILE );
+}
+__END__
+
+=head1 NAME
+
+pl2bat - wrap perl code into a batch file
+
+=head1 SYNOPSIS
+
+B<pl2bat> B<-h>
+
+B<pl2bat> [B<-w>] S<[B<-a> I<argstring>]> S<[B<-s> I<stripsuffix>]> [files]
+
+B<pl2bat> [B<-w>] S<[B<-n> I<ntargs>]> S<[B<-o> I<otherargs>]> S<[B<-s> I<stripsuffix>]> [files]
+
+=head1 DESCRIPTION
+
+This utility converts a perl script into a batch file that can be
+executed on DOS-like operating systems. This is intended to allow
+you to use a Perl script like regular programs and batch files where
+you just enter the name of the script [probably minus the extension]
+plus any command-line arguments and the script is found in your B<PATH>
+and run.
+
+=head2 ADVANTAGES
+
+There are several alternatives to this method of running a Perl script.
+They each have disadvantages that help you understand the motivation
+for using B<pl2bat>.
+
+=over
+
+=item 1
+
+ C:> perl x:/path/to/script.pl [args]
+
+=item 2
+
+ C:> perl -S script.pl [args]
+
+=item 3
+
+ C:> perl -S script [args]
+
+=item 4
+
+ C:> ftype Perl=perl.exe "%1" %*
+ C:> assoc .pl=Perl
+ then
+ C:> script.pl [args]
+
+=item 5
+
+ C:> ftype Perl=perl.exe "%1" %*
+ C:> assoc .pl=Perl
+ C:> set PathExt=%PathExt%;.PL
+ then
+ C:> script [args]
+
+=back
+
+B<1> and B<2> are the most basic invocation methods that should work on
+any system [DOS-like or not]. They require extra typing and require
+that the script user know that the script is written in Perl. This
+is a pain when you have lots of scripts, some written in Perl and some
+not. It can be quite difficult to keep track of which scripts need to
+be run through Perl and which do not. Even worse, scripts often get
+rewritten from simple batch files into more powerful Perl scripts in
+which case these methods would require all existing users of the scripts
+be updated.
+
+B<3> works on modern Win32 versions of Perl. It allows the user to
+omit the ".pl" or ".bat" file extension, which is a minor improvement.
+
+B<4> and B<5> work on some Win32 operating systems with some command
+shells. One major disadvantage with both is that you can't use them
+in pipelines nor with file redirection. For example, none of the
+following will work properly if you used method B<4> or B<5>:
+
+ C:> script.pl <infile
+ C:> script.pl >outfile
+ C:> echo y | script.pl
+ C:> script.pl | more
+
+This is due to a Win32 bug which Perl has no control over. This bug
+is the major motivation for B<pl2bat> [which was originally written
+for DOS] being used on Win32 systems.
+
+Note also that B<5> works on a smaller range of combinations of Win32
+systems and command shells while B<4> requires that the user know
+that the script is a Perl script [because the ".pl" extension must
+be entered]. This makes it hard to standardize on either of these
+methods.
+
+=head2 DISADVANTAGES
+
+There are several potential traps you should be aware of when you
+use B<pl2bat>.
+
+The generated batch file is initially processed as a batch file each
+time it is run. This means that, to use it from within another batch
+file you should precede it with C<call> or else the calling batch
+file will not run any commands after the script:
+
+ call script [args]
+
+Except under Windows NT, if you specify more than 9 arguments to
+the generated batch file then the 10th and subsequent arguments
+are silently ignored.
+
+Except when using F<CMD.EXE> under Windows NT, if F<perl.exe> is not
+in your B<PATH>, then trying to run the script will give you a generic
+"Command not found"-type of error message that will probably make you
+think that the script itself is not in your B<PATH>. When using
+F<CMD.EXE> under Windows NT, the generic error message is followed by
+"You do not have Perl in your PATH", to make this clearer.
+
+On most DOS-like operating systems, the only way to exit a batch file
+is to "fall off the end" of the file. B<pl2bat> implements this by
+doing C<goto :endofperl> and adding C<__END__> and C<:endofperl> as
+the last two lines of the generated batch file. This means:
+
+=over
+
+=item No line of your script should start with a colon.
+
+In particular, for this version of B<pl2bat>, C<:endofperl>,
+C<:WinNT>, and C<:script_failed_so_exit_with_non_zero_val> should not
+be used.
+
+=item Care must be taken when using C<__END__> and the C<DATA> file handle.
+
+One approach is:
+
+ . #!perl
+ . while( <DATA> ) {
+ . last if /^__END__$/;
+ . [...]
+ . }
+ . __END__
+ . lines of data
+ . to be processed
+ . __END__
+ . :endofperl
+
+The dots in the first column are only there to prevent F<cmd.exe> to interpret
+the C<:endofperl> line in this documentation. Otherwise F<pl2bat.bat> itself
+wouldn't work. See the previous item. :-)
+
+=item The batch file always "succeeds"
+
+The following commands illustrate the problem:
+
+ C:> echo exit(99); >fail.pl
+ C:> pl2bat fail.pl
+ C:> perl -e "print system('perl fail.pl')"
+ 99
+ C:> perl -e "print system('fail.bat')"
+ 0
+
+So F<fail.bat> always reports that it completed successfully. Actually,
+under Windows NT, we have:
+
+ C:> perl -e "print system('fail.bat')"
+ 1
+
+So, for Windows NT, F<fail.bat> fails when the Perl script fails, but
+the return code is always C<1>, not the return code from the Perl script.
+
+=back
+
+=head2 FUNCTION
+
+By default, the ".pl" suffix will be stripped before adding a ".bat" suffix
+to the supplied file names. This can be controlled with the C<-s> option.
+
+The default behavior is to have the batch file compare the C<OS>
+environment variable against C<"Windows_NT">. If they match, it
+uses the C<%*> construct to refer to all the command line arguments
+that were given to it, so you'll need to make sure that works on your
+variant of the command shell. It is known to work in the F<CMD.EXE> shell
+under Windows NT. 4DOS/NT users will want to put a C<ParameterChar = *>
+line in their initialization file, or execute C<setdos /p*> in
+the shell startup file.
+
+On Windows95 and other platforms a nine-argument limit is imposed
+on command-line arguments given to the generated batch file, since
+they may not support C<%*> in batch files.
+
+These can be overridden using the C<-n> and C<-o> options or the
+deprecated C<-a> option.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-n> I<ntargs>
+
+Arguments to invoke perl with in generated batch file when run from
+Windows NT (or Windows 98, probably). Defaults to S<'-x -S %0 %*'>.
+
+=item B<-o> I<otherargs>
+
+Arguments to invoke perl with in generated batch file except when
+run from Windows NT (ie. when run from DOS, Windows 3.1, or Windows 95).
+Defaults to S<'-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9'>.
+
+=item B<-a> I<argstring>
+
+Arguments to invoke perl with in generated batch file. Specifying
+B<-a> prevents the batch file from checking the C<OS> environment
+variable to determine which operating system it is being run from.
+
+=item B<-s> I<stripsuffix>
+
+Strip a suffix string from file name before appending a ".bat"
+suffix. The suffix is not case-sensitive. It can be a regex if
+it begins with `/' (the trailing '/' is optional and a trailing
+C<$> is always assumed). Defaults to C</.plx?/>.
+
+=item B<-w>
+
+If no line matching C</^#!.*perl/> is found in the script, then such
+a line is inserted just after the new preamble. The exact line
+depends on C<$Config{startperl}> [see L<Config>]. With the B<-w>
+option, C<" -w"> is added after the value of C<$Config{startperl}>.
+If a line matching C</^#!.*perl/> already exists in the script,
+then it is not changed and the B<-w> option is ignored.
+
+=item B<-u>
+
+If the script appears to have already been processed by B<pl2bat>,
+then the script is skipped and not processed unless B<-u> was
+specified. If B<-u> is specified, the existing preamble is replaced.
+
+=item B<-h>
+
+Show command line usage.
+
+=back
+
+=head1 EXAMPLES
+
+ C:\> pl2bat foo.pl bar.PM
+ [..creates foo.bat, bar.PM.bat..]
+
+ C:\> pl2bat -s "/\.pl|\.pm/" foo.pl bar.PM
+ [..creates foo.bat, bar.bat..]
+
+ C:\> pl2bat < somefile > another.bat
+
+ C:\> pl2bat > another.bat
+ print scalar reverse "rekcah lrep rehtona tsuj\n";
+ ^Z
+ [..another.bat is now a certified japh application..]
+
+ C:\> ren *.bat *.pl
+ C:\> pl2bat -u *.pl
+ [..updates the wrapping of some previously wrapped scripts..]
+
+ C:\> pl2bat -u -s .bat *.bat
+ [..same as previous example except more dangerous..]
+
+=head1 BUGS
+
+C<$0> will contain the full name, including the ".bat" suffix
+when the generated batch file runs. If you don't like this,
+see runperl.bat for an alternative way to invoke perl scripts.
+
+Default behavior is to invoke Perl with the B<-S> flag, so Perl will
+search the B<PATH> to find the script. This may have undesirable
+effects.
+
+On really old versions of Win32 Perl, you can't run the script
+via
+
+ C:> script.bat [args]
+
+and must use
+
+ C:> script [args]
+
+A loop should be used to build up the argument list when not on
+Windows NT so more than 9 arguments can be processed.
+
+See also L</Disadvantages>.
+
+=head1 SEE ALSO
+
+perl, perlwin32, runperl.bat
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pl2pm.bat b/Master/tlpkg/tlperl.straw/bin/pl2pm.bat
new file mode 100755
index 00000000000..ec126bdf156
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pl2pm.bat
@@ -0,0 +1,394 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+=head1 NAME
+
+pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.
+
+=head1 SYNOPSIS
+
+B<pl2pm> F<files>
+
+=head1 DESCRIPTION
+
+B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl
+library files to Perl5-style library modules. Usually, your old .pl
+file will still work fine and you should only use this tool if you
+plan to update your library to use some of the newer Perl 5 features,
+such as AutoLoading.
+
+=head1 LIMITATIONS
+
+It's just a first step, but it's usually a good first step.
+
+=head1 AUTHOR
+
+Larry Wall <larry@wall.org>
+
+=cut
+
+use strict;
+use warnings;
+
+my %keyword = ();
+
+while (<DATA>) {
+ chomp;
+ $keyword{$_} = 1;
+}
+
+local $/;
+
+while (<>) {
+ my $newname = $ARGV;
+ $newname =~ s/\.pl$/.pm/ || next;
+ $newname =~ s#(.*/)?(\w+)#$1\u$2#;
+ if (-f $newname) {
+ warn "Won't overwrite existing $newname\n";
+ next;
+ }
+ my $oldpack = $2;
+ my $newpack = "\u$2";
+ my @export = ();
+
+ s/\bstd(in|out|err)\b/\U$&/g;
+ s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
+ if (/sub\s+\w+'/) {
+ @export = m/sub\s+\w+'(\w+)/g;
+ s/(sub\s+)main'(\w+)/$1$2/g;
+ }
+ else {
+ @export = m/sub\s+([A-Za-z]\w*)/g;
+ }
+ my @export_ok = grep($keyword{$_}, @export);
+ @export = grep(!$keyword{$_}, @export);
+
+ my %export = ();
+ @export{@export} = (1) x @export;
+
+ s/(^\s*);#/$1#/g;
+ s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
+ s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
+ s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
+ s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
+ if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
+ s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
+ s/\$\[\s*\+\s*//g;
+ s/\s*\+\s*\$\[//g;
+ s/\$\[/0/g;
+ }
+ s/open\s+(\w+)/open($1)/g;
+
+ my $export_ok = '';
+ my $carp ='';
+
+
+ if (s/\bdie\b/croak/g) {
+ $carp = "use Carp;\n";
+ s/croak "([^"]*)\\n"/croak "$1"/g;
+ }
+
+ if (@export_ok) {
+ $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
+ }
+
+ if ( open(PM, ">$newname") ) {
+ print PM <<"END";
+package $newpack;
+use 5.006;
+require Exporter;
+$carp
+\@ISA = qw(Exporter);
+\@EXPORT = qw(@export);
+$export_ok
+$_
+END
+ }
+ else {
+ warn "Can't create $newname: $!\n";
+ }
+}
+
+sub xlate {
+ my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
+
+ my $xlated ;
+ if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
+ $xlated = "${pack}'$ident";
+ }
+ elsif ($pack eq '' || $pack eq 'main') {
+ if ($export->{$ident}) {
+ $xlated = "$prefix$ident";
+ }
+ else {
+ $xlated = "$prefix${pack}::$ident";
+ }
+ }
+ elsif ($pack eq $oldpack) {
+ $xlated = "$prefix${newpack}::$ident";
+ }
+ else {
+ $xlated = "$prefix${pack}::$ident";
+ }
+
+ return $xlated;
+}
+__END__
+AUTOLOAD
+BEGIN
+CHECK
+CORE
+DESTROY
+END
+INIT
+UNITCHECK
+abs
+accept
+alarm
+and
+atan2
+bind
+binmode
+bless
+caller
+chdir
+chmod
+chomp
+chop
+chown
+chr
+chroot
+close
+closedir
+cmp
+connect
+continue
+cos
+crypt
+dbmclose
+dbmopen
+defined
+delete
+die
+do
+dump
+each
+else
+elsif
+endgrent
+endhostent
+endnetent
+endprotoent
+endpwent
+endservent
+eof
+eq
+eval
+exec
+exists
+exit
+exp
+fcntl
+fileno
+flock
+for
+foreach
+fork
+format
+formline
+ge
+getc
+getgrent
+getgrgid
+getgrnam
+gethostbyaddr
+gethostbyname
+gethostent
+getlogin
+getnetbyaddr
+getnetbyname
+getnetent
+getpeername
+getpgrp
+getppid
+getpriority
+getprotobyname
+getprotobynumber
+getprotoent
+getpwent
+getpwnam
+getpwuid
+getservbyname
+getservbyport
+getservent
+getsockname
+getsockopt
+glob
+gmtime
+goto
+grep
+gt
+hex
+if
+index
+int
+ioctl
+join
+keys
+kill
+last
+lc
+lcfirst
+le
+length
+link
+listen
+local
+localtime
+lock
+log
+lstat
+lt
+m
+map
+mkdir
+msgctl
+msgget
+msgrcv
+msgsnd
+my
+ne
+next
+no
+not
+oct
+open
+opendir
+or
+ord
+our
+pack
+package
+pipe
+pop
+pos
+print
+printf
+prototype
+push
+q
+qq
+qr
+quotemeta
+qw
+qx
+rand
+read
+readdir
+readline
+readlink
+readpipe
+recv
+redo
+ref
+rename
+require
+reset
+return
+reverse
+rewinddir
+rindex
+rmdir
+s
+scalar
+seek
+seekdir
+select
+semctl
+semget
+semop
+send
+setgrent
+sethostent
+setnetent
+setpgrp
+setpriority
+setprotoent
+setpwent
+setservent
+setsockopt
+shift
+shmctl
+shmget
+shmread
+shmwrite
+shutdown
+sin
+sleep
+socket
+socketpair
+sort
+splice
+split
+sprintf
+sqrt
+srand
+stat
+study
+sub
+substr
+symlink
+syscall
+sysopen
+sysread
+sysseek
+system
+syswrite
+tell
+telldir
+tie
+tied
+time
+times
+tr
+truncate
+uc
+ucfirst
+umask
+undef
+unless
+unlink
+unpack
+unshift
+untie
+until
+use
+utime
+values
+vec
+wait
+waitpid
+wantarray
+warn
+while
+write
+x
+xor
+y
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pler b/Master/tlpkg/tlperl.straw/bin/pler
new file mode 100755
index 00000000000..01002aa034b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pler
@@ -0,0 +1,27 @@
+#!/usr/bin/perl
+
+use 5.00503;
+use strict;
+
+# On some platforms (mostly Windows), we get errors because
+# of Term::Cap issues. To avoid this, set TERM=dumb if the
+# user does not have a TERM value already.
+# This doesn't remove all possible errors, just the most
+# annoying and common ones.
+BEGIN {
+ $ENV{TERM} ||= 'dumb';
+}
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.05';
+}
+
+use pler ();
+
+unless ( $VERSION eq $pler::VERSION ) {
+ die "Error: Version mismatch (launch script $VERSION using module $pler::VERSION)";
+}
+pler::main(@ARGV);
+
+exit(0);
diff --git a/Master/tlpkg/tlperl.straw/bin/pler.bat b/Master/tlpkg/tlperl.straw/bin/pler.bat
new file mode 100755
index 00000000000..924a81f64fd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pler.bat
@@ -0,0 +1,43 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use 5.00503;
+use strict;
+
+# On some platforms (mostly Windows), we get errors because
+# of Term::Cap issues. To avoid this, set TERM=dumb if the
+# user does not have a TERM value already.
+# This doesn't remove all possible errors, just the most
+# annoying and common ones.
+BEGIN {
+ $ENV{TERM} ||= 'dumb';
+}
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.05';
+}
+
+use pler ();
+
+unless ( $VERSION eq $pler::VERSION ) {
+ die "Error: Version mismatch (launch script $VERSION using module $pler::VERSION)";
+}
+pler::main(@ARGV);
+
+exit(0);
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pod2html.bat b/Master/tlpkg/tlperl.straw/bin/pod2html.bat
new file mode 100755
index 00000000000..75cf111f655
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pod2html.bat
@@ -0,0 +1,160 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+=pod
+
+=head1 NAME
+
+pod2html - convert .pod files to .html files
+
+=head1 SYNOPSIS
+
+ pod2html --help --htmlroot=<name> --infile=<name> --outfile=<name>
+ --podpath=<name>:...:<name> --podroot=<name>
+ --libpods=<name>:...:<name> --recurse --norecurse --verbose
+ --index --noindex --title=<name>
+
+=head1 DESCRIPTION
+
+Converts files from pod format (see L<perlpod>) to HTML format.
+
+=head1 ARGUMENTS
+
+pod2html takes the following arguments:
+
+=over 4
+
+=item help
+
+ --help
+
+Displays the usage message.
+
+=item htmlroot
+
+ --htmlroot=name
+
+Sets the base URL for the HTML files. When cross-references are made,
+the HTML root is prepended to the URL.
+
+=item infile
+
+ --infile=name
+
+Specify the pod file to convert. Input is taken from STDIN if no
+infile is specified.
+
+=item outfile
+
+ --outfile=name
+
+Specify the HTML file to create. Output goes to STDOUT if no outfile
+is specified.
+
+=item podroot
+
+ --podroot=name
+
+Specify the base directory for finding library pods.
+
+=item podpath
+
+ --podpath=name:...:name
+
+Specify which subdirectories of the podroot contain pod files whose
+HTML converted forms can be linked-to in cross-references.
+
+=item libpods
+
+ --libpods=name:...:name
+
+List of page names (eg, "perlfunc") which contain linkable C<=item>s.
+
+=item netscape
+
+ --netscape
+
+Use Netscape HTML directives when applicable.
+
+=item nonetscape
+
+ --nonetscape
+
+Do not use Netscape HTML directives (default).
+
+=item index
+
+ --index
+
+Generate an index at the top of the HTML file (default behaviour).
+
+=item noindex
+
+ --noindex
+
+Do not generate an index at the top of the HTML file.
+
+
+=item recurse
+
+ --recurse
+
+Recurse into subdirectories specified in podpath (default behaviour).
+
+=item norecurse
+
+ --norecurse
+
+Do not recurse into subdirectories specified in podpath.
+
+=item title
+
+ --title=title
+
+Specify the title of the resulting HTML file.
+
+=item verbose
+
+ --verbose
+
+Display progress messages.
+
+=back
+
+=head1 AUTHOR
+
+Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
+
+=head1 BUGS
+
+See L<Pod::Html> for a list of known bugs in the translator.
+
+=head1 SEE ALSO
+
+L<perlpod>, L<Pod::Html>
+
+=head1 COPYRIGHT
+
+This program is distributed under the Artistic License.
+
+=cut
+
+use Pod::Html;
+
+pod2html @ARGV;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pod2latex.bat b/Master/tlpkg/tlperl.straw/bin/pod2latex.bat
new file mode 100755
index 00000000000..3cc895461a4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pod2latex.bat
@@ -0,0 +1,398 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2latex conversion program
+
+use strict;
+use Pod::LaTeX;
+use Pod::Find qw/ pod_find /;
+use Pod::Usage;
+use Getopt::Long;
+use File::Basename;
+use Symbol;
+
+my $VERSION = "1.01";
+
+# return the entire contents of a text file
+# whose name is given as argument
+sub _get {
+ my $fn = shift;
+ my $infh = gensym;
+ open $infh, $fn
+ or die "Could not open file $fn: $!\n";
+ local $/;
+ return <$infh>;
+}
+
+# Read command line arguments
+
+my %options = (
+ "help" => 0,
+ "man" => 0,
+ "sections" => [],
+ "full" => 0,
+ "out" => undef,
+ "verbose" => 0,
+ "modify" => 0,
+ "h1level" => 1, # section is equivalent to H1
+ "preamble" => [],
+ "postamble" => [],
+ );
+# "prefile" is just like "preamble", but the argument
+# comes from the file named by the argument
+$options{"prefile"} = sub { shift; push @{$options{"preamble"}}, _get(shift) };
+# the same between "postfile" and "postamble"
+$options{"postfile"} = sub { shift; push @{$options{"postamble"}}, _get(shift) };
+
+GetOptions(\%options,
+ "help",
+ "man",
+ "verbose",
+ "full",
+ "sections=s@",
+ "out=s",
+ "modify",
+ "h1level=i",
+ "preamble=s@",
+ "postamble=s@",
+ "prefile=s",
+ "postfile=s"
+ ) || pod2usage(2);
+
+pod2usage(1) if ($options{help});
+pod2usage(-verbose => 2) if ($options{man});
+
+
+# Read all the files from the command line
+my @files = @ARGV;
+
+# Now find which ones are real pods and convert
+# directories to their contents.
+
+# Extract the pods from each arg since some of them might
+# be directories
+# This is not as efficient as using pod_find to search through
+# everything at once but it allows us to preserve the order
+# supplied by the user
+
+my @pods;
+foreach my $arg (@files) {
+ my %pods = pod_find($arg);
+ push(@pods, sort keys %pods);
+}
+
+# Abort if nothing to do
+if ($#pods == -1) {
+ warn "None of the supplied Pod files actually exist\n";
+ exit;
+}
+
+# Only want to override the preamble and postamble if we have
+# been given values.
+my %User;
+$User{UserPreamble} = join("\n", @{$options{'preamble'}})
+ if ($options{preamble} && @{$options{preamble}});
+$User{UserPostamble} = join("\n", @{$options{'postamble'}})
+ if ($options{postamble} && @{$options{postamble}});
+
+
+
+# If $options{'out'} is set we are processing to a single output file
+my $multi_documents;
+if (exists $options{'out'} && defined $options{'out'}) {
+ $multi_documents = 0;
+} else {
+ $multi_documents = 1;
+}
+
+# If the output file is not specified it is assumed that
+# a single output file is required per input file using
+# a .tex extension rather than any exisiting extension
+
+if ($multi_documents) {
+
+ # Case where we just generate one input per output
+
+ foreach my $pod (@pods) {
+
+ if (-f $pod) {
+
+ my $output = $pod;
+ $output = basename($output, '.pm', '.pod','.pl') . '.tex';
+
+ # Create a new parser object
+ my $parser = new Pod::LaTeX(
+ AddPreamble => $options{'full'},
+ AddPostamble => $options{'full'},
+ MakeIndex => $options{'full'},
+ TableOfContents => $options{'full'},
+ ReplaceNAMEwithSection => $options{'modify'},
+ UniqueLabels => $options{'modify'},
+ Head1Level => $options{'h1level'},
+ LevelNoNum => $options{'h1level'} + 1,
+ %User,
+ );
+
+ # Select sections if supplied
+ $parser->select(@{ $options{'sections'}})
+ if @{$options{'sections'}};
+
+ # Derive the input file from the output file
+ $parser->parse_from_file($pod, $output);
+
+ print "Written output to $output\n" if $options{'verbose'};
+
+ } else {
+ warn "File $pod not found\n";
+ }
+
+ }
+} else {
+
+ # Case where we want everything to be in a single document
+
+ # Need to open the output file ourselves
+ my $output = $options{'out'};
+ $output .= '.tex' unless $output =~ /\.tex$/;
+
+ # Use auto-vivified file handle in perl 5.6
+ my $outfh = gensym;
+ open ($outfh, ">$output") || die "Could not open output file: $!\n";
+
+ # Flag to indicate whether we have converted at least one file
+ # indicates how many files have been converted
+ my $converted = 0;
+
+ # Loop over the input files
+ foreach my $pod (@pods) {
+
+ if (-f $pod) {
+
+ warn "Converting $pod\n" if $options{'verbose'};
+
+ # Open the file (need the handle)
+ # Use auto-vivified handle in perl 5.6
+ my $podfh = gensym;
+ open ($podfh, "<$pod") || die "Could not open pod file $pod: $!\n";
+
+ # if this is the first file to be converted we may want to add
+ # a preamble (controlled by command line option)
+ my $preamble = 0;
+ $preamble = 1 if ($converted == 0 && $options{'full'});
+
+ # if this is the last file to be converted may want to add
+ # a postamble (controlled by command line option)
+ # relies on a previous pass to check existence of all pods we
+ # are converting.
+ my $postamble = ( ($converted == $#pods && $options{'full'}) ? 1 : 0 );
+
+ # Open parser object
+ # May want to start with a preamble for the first one and
+ # end with an index for the last
+ my $parser = new Pod::LaTeX(
+ MakeIndex => $options{'full'},
+ TableOfContents => $preamble,
+ ReplaceNAMEwithSection => $options{'modify'},
+ UniqueLabels => $options{'modify'},
+ StartWithNewPage => $options{'full'},
+ AddPreamble => $preamble,
+ AddPostamble => $postamble,
+ Head1Level => $options{'h1level'},
+ LevelNoNum => $options{'h1level'} + 1,
+ %User
+ );
+
+ # Store the file name for error messages
+ # This is a kluge that breaks the data hiding of the object
+ $parser->{_INFILE} = $pod;
+
+ # Select sections if supplied
+ $parser->select(@{ $options{'sections'}})
+ if @{$options{'sections'}};
+
+ # Parse it
+ $parser->parse_from_filehandle($podfh, $outfh);
+
+ # We have converted at least one file
+ $converted++;
+
+ } else {
+ warn "File $pod not found\n";
+ }
+
+ }
+
+ # Should unlink the file if we didn't convert anything!
+ # dont check for return status of unlink
+ # since there is not a lot to be done if the unlink failed
+ # and the program does not rely upon it.
+ unlink "$output" unless $converted;
+
+ # If verbose
+ warn "Converted $converted files\n" if $options{'verbose'};
+
+}
+
+exit;
+
+__END__
+
+=head1 NAME
+
+pod2latex - convert pod documentation to latex format
+
+=head1 SYNOPSIS
+
+ pod2latex *.pm
+
+ pod2latex -out mytex.tex *.pod
+
+ pod2latex -full -sections 'DESCRIPTION|NAME' SomeDir
+
+ pod2latex -prefile h.tex -postfile t.tex my.pod
+
+=head1 DESCRIPTION
+
+C<pod2latex> is a program to convert POD format documentation
+(L<perlpod>) into latex. It can process multiple input documents at a
+time and either generate a latex file per input document or a single
+combined output file.
+
+=head1 OPTIONS AND ARGUMENTS
+
+This section describes the supported command line options. Minimum
+matching is supported.
+
+=over 4
+
+=item B<-out>
+
+Name of the output file to be used. If there are multiple input pods
+it is assumed that the intention is to write all translated output
+into a single file. C<.tex> is appended if not present. If the
+argument is not supplied, a single document will be created for each
+input file.
+
+=item B<-full>
+
+Creates a complete C<latex> file that can be processed immediately
+(unless C<=for/=begin> directives are used that rely on extra packages).
+Table of contents and index generation commands are included in the
+wrapper C<latex> code.
+
+=item B<-sections>
+
+Specify pod sections to include (or remove if negated) in the
+translation. See L<Pod::Select/"SECTION SPECIFICATIONS"> for the
+format to use for I<section-spec>. This option may be given multiple
+times on the command line.This is identical to the similar option in
+the C<podselect()> command.
+
+=item B<-modify>
+
+This option causes the output C<latex> to be slightly
+modified from the input pod such that when a C<=head1 NAME>
+is encountered a section is created containing the actual
+pod name (rather than B<NAME>) and all subsequent C<=head1>
+directives are treated as subsections. This has the advantage
+that the description of a module will be in its own section
+which is helpful for including module descriptions in documentation.
+Also forces C<latex> label and index entries to be prefixed by the
+name of the module.
+
+=item B<-h1level>
+
+Specifies the C<latex> section that is equivalent to a C<H1> pod
+directive. This is an integer between 0 and 5 with 0 equivalent to a
+C<latex> chapter, 1 equivalent to a C<latex> section etc. The default
+is 1 (C<H1> equivalent to a latex section).
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print the manual page and exit.
+
+=item B<-verbose>
+
+Print information messages as each document is processed.
+
+=item B<-preamble>
+
+A user-supplied preamble for the LaTeX code. Multiple values
+are supported and appended in order separated by "\n".
+See B<-prefile> for reading the preamble from a file.
+
+=item B<-postamble>
+
+A user supplied postamble for the LaTeX code. Multiple values
+are supported and appended in order separated by "\n".
+See B<-postfile> for reading the postamble from a file.
+
+=item B<-prefile>
+
+A user-supplied preamble for the LaTeX code to be read from the
+named file. Multiple values are supported and appended in
+order. See B<-preamble>.
+
+=item B<-postfile>
+
+A user-supplied postamble for the LaTeX code to be read from the
+named file. Multiple values are supported and appended in
+order. See B<-postamble>.
+
+=back
+
+=head1 BUGS
+
+Known bugs are:
+
+=over 4
+
+=item *
+
+Cross references between documents are not resolved when multiple
+pod documents are converted into a single output C<latex> file.
+
+=item *
+
+Functions and variables are not automatically recognized
+and they will therefore not be marked up in any special way
+unless instructed by an explicit pod command.
+
+=back
+
+=head1 SEE ALSO
+
+L<Pod::LaTeX>
+
+=head1 AUTHOR
+
+Tim Jenness E<lt>tjenness@cpan.orgE<gt>
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+Copyright (C) 2000, 2003, 2004 Tim Jenness. All Rights Reserved.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pod2man b/Master/tlpkg/tlperl.straw/bin/pod2man
new file mode 100755
index 00000000000..1eff3ca275f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pod2man
@@ -0,0 +1,549 @@
+#!perl
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2man -- Convert POD data to formatted *roff input.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Man ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin.
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options, trying to retain backward compatibility with pod2man but
+# allowing short forms as well. --lax is currently ignored.
+my %options;
+$options{errors} = 'pod';
+Getopt::Long::config ('bundling_override');
+GetOptions (\%options, 'center|c=s', 'date|d=s', 'fixed=s', 'fixedbold=s',
+ 'fixeditalic=s', 'fixedbolditalic=s', 'help|h', 'lax|l',
+ 'name|n=s', 'official|o', 'quotes|q=s', 'release|r:s',
+ 'section|s=s', 'stderr', 'verbose|v', 'utf8|u') or exit 1;
+pod2usage (0) if $options{help};
+
+# Official sets --center, but don't override things explicitly set.
+if ($options{official} && !defined $options{center}) {
+ $options{center} = 'Perl Programmers Reference Guide';
+}
+
+# Verbose is only our flag, not a Pod::Man flag.
+my $verbose = $options{verbose};
+delete $options{verbose};
+
+# This isn't a valid Pod::Man option and is only accepted for backward
+# compatibility.
+delete $options{lax};
+
+# Initialize and run the formatter, pulling a pair of input and output off at
+# a time.
+my $parser = Pod::Man->new (%options);
+my @files;
+do {
+ @files = splice (@ARGV, 0, 2);
+ print " $files[1]\n" if $verbose;
+ $parser->parse_from_file (@files);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2man - Convert POD data to formatted *roff input
+
+=for stopwords
+en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris
+URL troff troff-specific formatters uppercased Christiansen
+
+=head1 SYNOPSIS
+
+pod2man [B<--center>=I<string>] [B<--date>=I<string>]
+ [B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
+ [B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--official>]
+ [B<--quotes>=I<quotes>] [B<--release>[=I<version>]]
+ [B<--section>=I<manext>] [B<--stderr>] [B<--utf8>] [B<--verbose>]
+ [I<input> [I<output>] ...]
+
+pod2man B<--help>
+
+=head1 DESCRIPTION
+
+B<pod2man> is a front-end for Pod::Man, using it to generate *roff input
+from POD source. The resulting *roff code is suitable for display on a
+terminal using nroff(1), normally via man(1), or printing using troff(1).
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2man> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can
+be used to set the headers and footers to use; if not given, Pod::Man will
+assume various defaults. See below or L<Pod::Man> for details.
+
+B<pod2man> assumes that your *roff formatters have a fixed-width font
+named C<CW>. If yours is called something else (like C<CR>), use
+B<--fixed> to specify it. This generally only matters for troff output
+for printing. Similarly, you can set the fonts used for bold, italic, and
+bold italic fixed-width output.
+
+Besides the obvious pod conversions, Pod::Man, and therefore pod2man also
+takes care of formatting func(), func(n), and simple variable references
+like $foo or @bar so you don't have to use code escapes for them; complex
+expressions like C<$fred{'stuff'}> will still need to be escaped, though.
+It also translates dashes that aren't used as hyphens into en dashes, makes
+long dashes--like this--into proper em dashes, fixes "paired quotes," and
+takes care of several other troff-specific tweaks. See L<Pod::Man> for
+complete information.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-c> I<string>, B<--center>=I<string>
+
+Sets the centered page header to I<string>. The default is "User
+Contributed Perl Documentation", but also see B<--official> below.
+
+=item B<-d> I<string>, B<--date>=I<string>
+
+Set the left-hand footer string to this value. By default, the modification
+date of the input file will be used, or the current date if input comes from
+C<STDIN>.
+
+=item B<--fixed>=I<font>
+
+The fixed-width font to use for verbatim text and code. Defaults to
+C<CW>. Some systems may want C<CR> instead. Only matters for troff(1)
+output.
+
+=item B<--fixedbold>=I<font>
+
+Bold version of the fixed-width font. Defaults to C<CB>. Only matters
+for troff(1) output.
+
+=item B<--fixeditalic>=I<font>
+
+Italic version of the fixed-width font (actually, something of a misnomer,
+since most fixed-width fonts only have an oblique version, not an italic
+version). Defaults to C<CI>. Only matters for troff(1) output.
+
+=item B<--fixedbolditalic>=I<font>
+
+Bold italic (probably actually oblique) version of the fixed-width font.
+Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
+systems (such as Solaris) have this font available as C<CX>. Only matters
+for troff(1) output.
+
+=item B<-h>, B<--help>
+
+Print out usage information.
+
+=item B<-l>, B<--lax>
+
+No longer used. B<pod2man> used to check its input for validity as a
+manual page, but this should now be done by L<podchecker(1)> instead.
+Accepted for backward compatibility; this option no longer does anything.
+
+=item B<-n> I<name>, B<--name>=I<name>
+
+Set the name of the manual page to I<name>. Without this option, the manual
+name is set to the uppercased base name of the file being converted unless
+the manual section is 3, in which case the path is parsed to see if it is a
+Perl module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted
+into a name like C<Pod::Man>. This option, if given, overrides any
+automatic determination of the name.
+
+Note that this option is probably not useful when converting multiple POD
+files at once. The convention for Unix man pages for commands is for the
+man page title to be in all-uppercase even if the command isn't.
+
+=item B<-o>, B<--official>
+
+Set the default header to indicate that this page is part of the standard
+Perl release, if B<--center> is not also given.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> may also be set to the special value C<none>, in which case no
+quote marks are added around CE<lt>> text (but the font is still changed for
+troff output).
+
+=item B<-r>, B<--release>
+
+Set the centered footer. By default, this is the version of Perl you run
+B<pod2man> under. Note that some system an macro sets assume that the
+centered footer will be a modification date and will prepend something like
+"Last modified: "; if this is the case, you may want to set B<--release> to
+the last modified date and B<--date> to the version number.
+
+=item B<-s>, B<--section>
+
+Set the section for the C<.TH> macro. The standard section numbering
+convention is to use 1 for user commands, 2 for system calls, 3 for
+functions, 4 for devices, 5 for file formats, 6 for games, 7 for
+miscellaneous information, and 8 for administrator commands. There is a lot
+of variation here, however; some systems (like Solaris) use 4 for file
+formats, 5 for miscellaneous information, and 7 for devices. Still others
+use 1m instead of 8, or some mix of both. About the only section numbers
+that are reliably consistent are 1, 2, and 3.
+
+By default, section 1 will be used unless the file ends in C<.pm>, in
+which case section 3 will be selected.
+
+=item B<--stderr>
+
+By default, B<pod2man> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2man> produces the most conservative possible *roff
+output to try to ensure that it will work with as many different *roff
+implementations as possible. Many *roff implementations cannot handle
+non-ASCII characters, so this means all non-ASCII characters are converted
+either to a *roff escape sequence that tries to create a properly accented
+character (at least for troff output) or to C<X>.
+
+This option says to instead output literal UTF-8 characters. If your
+*roff implementation can handle it, this is the best output format to use
+and avoids corruption of documents containing non-ASCII characters.
+However, be warned that *roff source with literal UTF-8 characters is not
+supported by many implementations and may even result in segfaults and
+other bad behavior.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-v>, B<--verbose>
+
+Print out the name of each output file as it is being generated.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Simple> for
+information about what those errors might mean.
+
+=head1 EXAMPLES
+
+ pod2man program > program.1
+ pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
+ pod2man --section=7 note.pod > note.7
+
+If you would like to print out a lot of man page continuously, you probably
+want to set the C and D registers to set contiguous page numbering and
+even/odd paging, at least on some versions of man(7).
+
+ troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
+
+To get index entries on C<STDERR>, turn on the F register, as in:
+
+ troff -man -rF1 perl.1
+
+The indexing merely outputs messages via C<.tm> for each major page,
+section, subsection, item, and any C<XE<lt>E<gt>> directives. See
+L<Pod::Man> for more details.
+
+=head1 BUGS
+
+Lots of this documentation is duplicated from L<Pod::Man>.
+
+=head1 NOTES
+
+For those not sure of the proper layout of a man page, here are some notes
+on writing a proper man page.
+
+The name of the program being documented is conventionally written in bold
+(using BE<lt>E<gt>) wherever it occurs, as are all program options.
+Arguments should be written in italics (IE<lt>E<gt>). Functions are
+traditionally written in italics; if you write a function as function(),
+Pod::Man will take care of this for you. Literal code or commands should
+be in CE<lt>E<gt>. References to other man pages should be in the form
+C<manpage(section)>, and Pod::Man will automatically format those
+appropriately. As an exception, it's traditional not to use this form when
+referring to module documentation; use C<LE<lt>Module::NameE<gt>> instead.
+
+References to other programs or functions are normally in the form of man
+page references so that cross-referencing tools can provide the user with
+links and the like. It's possible to overdo this, though, so be careful not
+to clutter your documentation with too much markup.
+
+The major headers should be set out using a C<=head1> directive, and are
+historically written in the rather startling ALL UPPER CASE format, although
+this is not mandatory. Minor headers may be included using C<=head2>, and
+are typically in mixed case.
+
+The standard sections of a manual page are:
+
+=over 4
+
+=item NAME
+
+Mandatory section; should be a comma-separated list of programs or functions
+documented by this POD page, such as:
+
+ foo, bar - programs to do something
+
+Manual page indexers are often extremely picky about the format of this
+section, so don't put anything in it except this line. A single dash, and
+only a single dash, should separate the list of programs or functions from
+the description. Do not use any markup such as CE<lt>E<gt> or
+BE<lt>E<gt>. Functions should not be qualified with C<()> or the like.
+The description should ideally fit on a single line, even if a man program
+replaces the dash with a few tabs.
+
+=item SYNOPSIS
+
+A short usage summary for programs and functions. This section is mandatory
+for section 3 pages.
+
+=item DESCRIPTION
+
+Extended description and discussion of the program or functions, or the body
+of the documentation for man pages that document something else. If
+particularly long, it's a good idea to break this up into subsections
+C<=head2> directives like:
+
+ =head2 Normal Usage
+
+ =head2 Advanced Features
+
+ =head2 Writing Configuration Files
+
+or whatever is appropriate for your documentation.
+
+=item OPTIONS
+
+Detailed description of each of the command-line options taken by the
+program. This should be separate from the description for the use of things
+like L<Pod::Usage|Pod::Usage>. This is normally presented as a list, with
+each option as a separate C<=item>. The specific option string should be
+enclosed in BE<lt>E<gt>. Any values that the option takes should be
+enclosed in IE<lt>E<gt>. For example, the section for the option
+B<--section>=I<manext> would be introduced with:
+
+ =item B<--section>=I<manext>
+
+Synonymous options (like both the short and long forms) are separated by a
+comma and a space on the same C<=item> line, or optionally listed as their
+own item with a reference to the canonical name. For example, since
+B<--section> can also be written as B<-s>, the above would be:
+
+ =item B<-s> I<manext>, B<--section>=I<manext>
+
+(Writing the short option first is arguably easier to read, since the long
+option is long enough to draw the eye to it anyway and the short option can
+otherwise get lost in visual noise.)
+
+=item RETURN VALUE
+
+What the program or function returns, if successful. This section can be
+omitted for programs whose precise exit codes aren't important, provided
+they return 0 on success as is standard. It should always be present for
+functions.
+
+=item ERRORS
+
+Exceptions, error return codes, exit statuses, and errno settings.
+Typically used for function documentation; program documentation uses
+DIAGNOSTICS instead. The general rule of thumb is that errors printed to
+C<STDOUT> or C<STDERR> and intended for the end user are documented in
+DIAGNOSTICS while errors passed internal to the calling program and
+intended for other programmers are documented in ERRORS. When documenting
+a function that sets errno, a full list of the possible errno values
+should be given here.
+
+=item DIAGNOSTICS
+
+All possible messages the program can print out--and what they mean. You
+may wish to follow the same documentation style as the Perl documentation;
+see perldiag(1) for more details (and look at the POD source as well).
+
+If applicable, please include details on what the user should do to correct
+the error; documenting an error as indicating "the input buffer is too
+small" without telling the user how to increase the size of the input buffer
+(or at least telling them that it isn't possible) aren't very useful.
+
+=item EXAMPLES
+
+Give some example uses of the program or function. Don't skimp; users often
+find this the most useful part of the documentation. The examples are
+generally given as verbatim paragraphs.
+
+Don't just present an example without explaining what it does. Adding a
+short paragraph saying what the example will do can increase the value of
+the example immensely.
+
+=item ENVIRONMENT
+
+Environment variables that the program cares about, normally presented as a
+list using C<=over>, C<=item>, and C<=back>. For example:
+
+ =over 6
+
+ =item HOME
+
+ Used to determine the user's home directory. F<.foorc> in this
+ directory is read for configuration details, if it exists.
+
+ =back
+
+Since environment variables are normally in all uppercase, no additional
+special formatting is generally needed; they're glaring enough as it is.
+
+=item FILES
+
+All files used by the program or function, normally presented as a list, and
+what it uses them for. File names should be enclosed in FE<lt>E<gt>. It's
+particularly important to document files that will be potentially modified.
+
+=item CAVEATS
+
+Things to take special care with, sometimes called WARNINGS.
+
+=item BUGS
+
+Things that are broken or just don't work quite right.
+
+=item RESTRICTIONS
+
+Bugs you don't plan to fix. :-)
+
+=item NOTES
+
+Miscellaneous commentary.
+
+=item AUTHOR
+
+Who wrote it (use AUTHORS for multiple people). Including your current
+e-mail address (or some e-mail address to which bug reports should be sent)
+so that users have a way of contacting you is a good idea. Remember that
+program documentation tends to roam the wild for far longer than you expect
+and pick an e-mail address that's likely to last if possible.
+
+=item HISTORY
+
+Programs derived from other sources sometimes have this, or you might keep
+a modification log here. If the log gets overly long or detailed,
+consider maintaining it in a separate file, though.
+
+=item COPYRIGHT AND LICENSE
+
+For copyright
+
+ Copyright YEAR(s) by YOUR NAME(s)
+
+(No, (C) is not needed. No, "all rights reserved" is not needed.)
+
+For licensing the easiest way is to use the same licensing as Perl itself:
+
+ This library is free software; you may redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+This makes it easy for people to use your module with Perl. Note that
+this licensing is neither an endorsement or a requirement, you are of
+course free to choose any licensing.
+
+=item SEE ALSO
+
+Other man pages to check out, like man(1), man(7), makewhatis(8), or
+catman(8). Normally a simple list of man pages separated by commas, or a
+paragraph giving the name of a reference work. Man page references, if they
+use the standard C<name(section)> form, don't have to be enclosed in
+LE<lt>E<gt> (although it's recommended), but other things in this section
+probably should be when appropriate.
+
+If the package has a mailing list, include a URL or subscription
+instructions here.
+
+If the package has a web site, include a URL here.
+
+=back
+
+In addition, some systems use CONFORMING TO to note conformance to relevant
+standards and MT-LEVEL to note safeness for use in threaded programs or
+signal handlers. These headings are primarily useful when documenting parts
+of a C library. Documentation of object-oriented libraries or modules may
+use CONSTRUCTORS and METHODS sections for detailed documentation of the
+parts of the library and save the DESCRIPTION section for an overview; other
+large modules may use FUNCTIONS for similar reasons. Some people use
+OVERVIEW to summarize the description if it's quite long.
+
+Section ordering varies, although NAME should I<always> be the first section
+(you'll break some man page systems otherwise), and NAME, SYNOPSIS,
+DESCRIPTION, and OPTIONS generally always occur first and in that order if
+present. In general, SEE ALSO, AUTHOR, and similar material should be left
+for last. Some systems also move WARNINGS and NOTES to last. The order
+given above should be reasonable for most purposes.
+
+Finally, as a general note, try not to use an excessive amount of markup.
+As documented here and in L<Pod::Man>, you can safely leave Perl variables,
+function names, man page references, and the like unadorned by markup and
+the POD translators will figure it out for you. This makes it much easier
+to later edit the documentation. Note that many existing translators
+(including this one currently) will do the wrong thing with e-mail addresses
+when wrapped in LE<lt>E<gt>, so don't do that.
+
+For additional information that may be more accurate for your specific
+system, see either L<man(5)> or L<man(7)> depending on your system manual
+section numbering conventions.
+
+=head1 SEE ALSO
+
+L<Pod::Man>, L<Pod::Simple>, L<man(1)>, L<nroff(1)>, L<perlpod(1)>,
+L<podchecker(1)>, L<troff(1)>, L<man(7)>
+
+The man page documenting the an macro set may be L<man(5)> instead of
+L<man(7)> on your system.
+
+The current version of this script is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
+B<pod2man> by Larry Wall and Tom Christiansen. Large portions of this
+documentation, particularly the sections on the anatomy of a proper man
+page, are taken from the B<pod2man> documentation by Tom.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery
+<rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/pod2man.bat b/Master/tlpkg/tlperl.straw/bin/pod2man.bat
new file mode 100755
index 00000000000..f2555659bc3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pod2man.bat
@@ -0,0 +1,565 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2man -- Convert POD data to formatted *roff input.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Man ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin.
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options, trying to retain backward compatibility with pod2man but
+# allowing short forms as well. --lax is currently ignored.
+my %options;
+$options{errors} = 'pod';
+Getopt::Long::config ('bundling_override');
+GetOptions (\%options, 'center|c=s', 'date|d=s', 'fixed=s', 'fixedbold=s',
+ 'fixeditalic=s', 'fixedbolditalic=s', 'help|h', 'lax|l',
+ 'name|n=s', 'official|o', 'quotes|q=s', 'release|r:s',
+ 'section|s=s', 'stderr', 'verbose|v', 'utf8|u') or exit 1;
+pod2usage (0) if $options{help};
+
+# Official sets --center, but don't override things explicitly set.
+if ($options{official} && !defined $options{center}) {
+ $options{center} = 'Perl Programmers Reference Guide';
+}
+
+# Verbose is only our flag, not a Pod::Man flag.
+my $verbose = $options{verbose};
+delete $options{verbose};
+
+# This isn't a valid Pod::Man option and is only accepted for backward
+# compatibility.
+delete $options{lax};
+
+# Initialize and run the formatter, pulling a pair of input and output off at
+# a time.
+my $parser = Pod::Man->new (%options);
+my @files;
+do {
+ @files = splice (@ARGV, 0, 2);
+ print " $files[1]\n" if $verbose;
+ $parser->parse_from_file (@files);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2man - Convert POD data to formatted *roff input
+
+=for stopwords
+en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris
+URL troff troff-specific formatters uppercased Christiansen
+
+=head1 SYNOPSIS
+
+pod2man [B<--center>=I<string>] [B<--date>=I<string>]
+ [B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
+ [B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--official>]
+ [B<--quotes>=I<quotes>] [B<--release>[=I<version>]]
+ [B<--section>=I<manext>] [B<--stderr>] [B<--utf8>] [B<--verbose>]
+ [I<input> [I<output>] ...]
+
+pod2man B<--help>
+
+=head1 DESCRIPTION
+
+B<pod2man> is a front-end for Pod::Man, using it to generate *roff input
+from POD source. The resulting *roff code is suitable for display on a
+terminal using nroff(1), normally via man(1), or printing using troff(1).
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2man> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can
+be used to set the headers and footers to use; if not given, Pod::Man will
+assume various defaults. See below or L<Pod::Man> for details.
+
+B<pod2man> assumes that your *roff formatters have a fixed-width font
+named C<CW>. If yours is called something else (like C<CR>), use
+B<--fixed> to specify it. This generally only matters for troff output
+for printing. Similarly, you can set the fonts used for bold, italic, and
+bold italic fixed-width output.
+
+Besides the obvious pod conversions, Pod::Man, and therefore pod2man also
+takes care of formatting func(), func(n), and simple variable references
+like $foo or @bar so you don't have to use code escapes for them; complex
+expressions like C<$fred{'stuff'}> will still need to be escaped, though.
+It also translates dashes that aren't used as hyphens into en dashes, makes
+long dashes--like this--into proper em dashes, fixes "paired quotes," and
+takes care of several other troff-specific tweaks. See L<Pod::Man> for
+complete information.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-c> I<string>, B<--center>=I<string>
+
+Sets the centered page header to I<string>. The default is "User
+Contributed Perl Documentation", but also see B<--official> below.
+
+=item B<-d> I<string>, B<--date>=I<string>
+
+Set the left-hand footer string to this value. By default, the modification
+date of the input file will be used, or the current date if input comes from
+C<STDIN>.
+
+=item B<--fixed>=I<font>
+
+The fixed-width font to use for verbatim text and code. Defaults to
+C<CW>. Some systems may want C<CR> instead. Only matters for troff(1)
+output.
+
+=item B<--fixedbold>=I<font>
+
+Bold version of the fixed-width font. Defaults to C<CB>. Only matters
+for troff(1) output.
+
+=item B<--fixeditalic>=I<font>
+
+Italic version of the fixed-width font (actually, something of a misnomer,
+since most fixed-width fonts only have an oblique version, not an italic
+version). Defaults to C<CI>. Only matters for troff(1) output.
+
+=item B<--fixedbolditalic>=I<font>
+
+Bold italic (probably actually oblique) version of the fixed-width font.
+Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
+systems (such as Solaris) have this font available as C<CX>. Only matters
+for troff(1) output.
+
+=item B<-h>, B<--help>
+
+Print out usage information.
+
+=item B<-l>, B<--lax>
+
+No longer used. B<pod2man> used to check its input for validity as a
+manual page, but this should now be done by L<podchecker(1)> instead.
+Accepted for backward compatibility; this option no longer does anything.
+
+=item B<-n> I<name>, B<--name>=I<name>
+
+Set the name of the manual page to I<name>. Without this option, the manual
+name is set to the uppercased base name of the file being converted unless
+the manual section is 3, in which case the path is parsed to see if it is a
+Perl module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted
+into a name like C<Pod::Man>. This option, if given, overrides any
+automatic determination of the name.
+
+Note that this option is probably not useful when converting multiple POD
+files at once. The convention for Unix man pages for commands is for the
+man page title to be in all-uppercase even if the command isn't.
+
+=item B<-o>, B<--official>
+
+Set the default header to indicate that this page is part of the standard
+Perl release, if B<--center> is not also given.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> may also be set to the special value C<none>, in which case no
+quote marks are added around CE<lt>> text (but the font is still changed for
+troff output).
+
+=item B<-r>, B<--release>
+
+Set the centered footer. By default, this is the version of Perl you run
+B<pod2man> under. Note that some system an macro sets assume that the
+centered footer will be a modification date and will prepend something like
+"Last modified: "; if this is the case, you may want to set B<--release> to
+the last modified date and B<--date> to the version number.
+
+=item B<-s>, B<--section>
+
+Set the section for the C<.TH> macro. The standard section numbering
+convention is to use 1 for user commands, 2 for system calls, 3 for
+functions, 4 for devices, 5 for file formats, 6 for games, 7 for
+miscellaneous information, and 8 for administrator commands. There is a lot
+of variation here, however; some systems (like Solaris) use 4 for file
+formats, 5 for miscellaneous information, and 7 for devices. Still others
+use 1m instead of 8, or some mix of both. About the only section numbers
+that are reliably consistent are 1, 2, and 3.
+
+By default, section 1 will be used unless the file ends in C<.pm>, in
+which case section 3 will be selected.
+
+=item B<--stderr>
+
+By default, B<pod2man> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2man> produces the most conservative possible *roff
+output to try to ensure that it will work with as many different *roff
+implementations as possible. Many *roff implementations cannot handle
+non-ASCII characters, so this means all non-ASCII characters are converted
+either to a *roff escape sequence that tries to create a properly accented
+character (at least for troff output) or to C<X>.
+
+This option says to instead output literal UTF-8 characters. If your
+*roff implementation can handle it, this is the best output format to use
+and avoids corruption of documents containing non-ASCII characters.
+However, be warned that *roff source with literal UTF-8 characters is not
+supported by many implementations and may even result in segfaults and
+other bad behavior.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-v>, B<--verbose>
+
+Print out the name of each output file as it is being generated.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Simple> for
+information about what those errors might mean.
+
+=head1 EXAMPLES
+
+ pod2man program > program.1
+ pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
+ pod2man --section=7 note.pod > note.7
+
+If you would like to print out a lot of man page continuously, you probably
+want to set the C and D registers to set contiguous page numbering and
+even/odd paging, at least on some versions of man(7).
+
+ troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
+
+To get index entries on C<STDERR>, turn on the F register, as in:
+
+ troff -man -rF1 perl.1
+
+The indexing merely outputs messages via C<.tm> for each major page,
+section, subsection, item, and any C<XE<lt>E<gt>> directives. See
+L<Pod::Man> for more details.
+
+=head1 BUGS
+
+Lots of this documentation is duplicated from L<Pod::Man>.
+
+=head1 NOTES
+
+For those not sure of the proper layout of a man page, here are some notes
+on writing a proper man page.
+
+The name of the program being documented is conventionally written in bold
+(using BE<lt>E<gt>) wherever it occurs, as are all program options.
+Arguments should be written in italics (IE<lt>E<gt>). Functions are
+traditionally written in italics; if you write a function as function(),
+Pod::Man will take care of this for you. Literal code or commands should
+be in CE<lt>E<gt>. References to other man pages should be in the form
+C<manpage(section)>, and Pod::Man will automatically format those
+appropriately. As an exception, it's traditional not to use this form when
+referring to module documentation; use C<LE<lt>Module::NameE<gt>> instead.
+
+References to other programs or functions are normally in the form of man
+page references so that cross-referencing tools can provide the user with
+links and the like. It's possible to overdo this, though, so be careful not
+to clutter your documentation with too much markup.
+
+The major headers should be set out using a C<=head1> directive, and are
+historically written in the rather startling ALL UPPER CASE format, although
+this is not mandatory. Minor headers may be included using C<=head2>, and
+are typically in mixed case.
+
+The standard sections of a manual page are:
+
+=over 4
+
+=item NAME
+
+Mandatory section; should be a comma-separated list of programs or functions
+documented by this POD page, such as:
+
+ foo, bar - programs to do something
+
+Manual page indexers are often extremely picky about the format of this
+section, so don't put anything in it except this line. A single dash, and
+only a single dash, should separate the list of programs or functions from
+the description. Do not use any markup such as CE<lt>E<gt> or
+BE<lt>E<gt>. Functions should not be qualified with C<()> or the like.
+The description should ideally fit on a single line, even if a man program
+replaces the dash with a few tabs.
+
+=item SYNOPSIS
+
+A short usage summary for programs and functions. This section is mandatory
+for section 3 pages.
+
+=item DESCRIPTION
+
+Extended description and discussion of the program or functions, or the body
+of the documentation for man pages that document something else. If
+particularly long, it's a good idea to break this up into subsections
+C<=head2> directives like:
+
+ =head2 Normal Usage
+
+ =head2 Advanced Features
+
+ =head2 Writing Configuration Files
+
+or whatever is appropriate for your documentation.
+
+=item OPTIONS
+
+Detailed description of each of the command-line options taken by the
+program. This should be separate from the description for the use of things
+like L<Pod::Usage|Pod::Usage>. This is normally presented as a list, with
+each option as a separate C<=item>. The specific option string should be
+enclosed in BE<lt>E<gt>. Any values that the option takes should be
+enclosed in IE<lt>E<gt>. For example, the section for the option
+B<--section>=I<manext> would be introduced with:
+
+ =item B<--section>=I<manext>
+
+Synonymous options (like both the short and long forms) are separated by a
+comma and a space on the same C<=item> line, or optionally listed as their
+own item with a reference to the canonical name. For example, since
+B<--section> can also be written as B<-s>, the above would be:
+
+ =item B<-s> I<manext>, B<--section>=I<manext>
+
+(Writing the short option first is arguably easier to read, since the long
+option is long enough to draw the eye to it anyway and the short option can
+otherwise get lost in visual noise.)
+
+=item RETURN VALUE
+
+What the program or function returns, if successful. This section can be
+omitted for programs whose precise exit codes aren't important, provided
+they return 0 on success as is standard. It should always be present for
+functions.
+
+=item ERRORS
+
+Exceptions, error return codes, exit statuses, and errno settings.
+Typically used for function documentation; program documentation uses
+DIAGNOSTICS instead. The general rule of thumb is that errors printed to
+C<STDOUT> or C<STDERR> and intended for the end user are documented in
+DIAGNOSTICS while errors passed internal to the calling program and
+intended for other programmers are documented in ERRORS. When documenting
+a function that sets errno, a full list of the possible errno values
+should be given here.
+
+=item DIAGNOSTICS
+
+All possible messages the program can print out--and what they mean. You
+may wish to follow the same documentation style as the Perl documentation;
+see perldiag(1) for more details (and look at the POD source as well).
+
+If applicable, please include details on what the user should do to correct
+the error; documenting an error as indicating "the input buffer is too
+small" without telling the user how to increase the size of the input buffer
+(or at least telling them that it isn't possible) aren't very useful.
+
+=item EXAMPLES
+
+Give some example uses of the program or function. Don't skimp; users often
+find this the most useful part of the documentation. The examples are
+generally given as verbatim paragraphs.
+
+Don't just present an example without explaining what it does. Adding a
+short paragraph saying what the example will do can increase the value of
+the example immensely.
+
+=item ENVIRONMENT
+
+Environment variables that the program cares about, normally presented as a
+list using C<=over>, C<=item>, and C<=back>. For example:
+
+ =over 6
+
+ =item HOME
+
+ Used to determine the user's home directory. F<.foorc> in this
+ directory is read for configuration details, if it exists.
+
+ =back
+
+Since environment variables are normally in all uppercase, no additional
+special formatting is generally needed; they're glaring enough as it is.
+
+=item FILES
+
+All files used by the program or function, normally presented as a list, and
+what it uses them for. File names should be enclosed in FE<lt>E<gt>. It's
+particularly important to document files that will be potentially modified.
+
+=item CAVEATS
+
+Things to take special care with, sometimes called WARNINGS.
+
+=item BUGS
+
+Things that are broken or just don't work quite right.
+
+=item RESTRICTIONS
+
+Bugs you don't plan to fix. :-)
+
+=item NOTES
+
+Miscellaneous commentary.
+
+=item AUTHOR
+
+Who wrote it (use AUTHORS for multiple people). Including your current
+e-mail address (or some e-mail address to which bug reports should be sent)
+so that users have a way of contacting you is a good idea. Remember that
+program documentation tends to roam the wild for far longer than you expect
+and pick an e-mail address that's likely to last if possible.
+
+=item HISTORY
+
+Programs derived from other sources sometimes have this, or you might keep
+a modification log here. If the log gets overly long or detailed,
+consider maintaining it in a separate file, though.
+
+=item COPYRIGHT AND LICENSE
+
+For copyright
+
+ Copyright YEAR(s) by YOUR NAME(s)
+
+(No, (C) is not needed. No, "all rights reserved" is not needed.)
+
+For licensing the easiest way is to use the same licensing as Perl itself:
+
+ This library is free software; you may redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+This makes it easy for people to use your module with Perl. Note that
+this licensing is neither an endorsement or a requirement, you are of
+course free to choose any licensing.
+
+=item SEE ALSO
+
+Other man pages to check out, like man(1), man(7), makewhatis(8), or
+catman(8). Normally a simple list of man pages separated by commas, or a
+paragraph giving the name of a reference work. Man page references, if they
+use the standard C<name(section)> form, don't have to be enclosed in
+LE<lt>E<gt> (although it's recommended), but other things in this section
+probably should be when appropriate.
+
+If the package has a mailing list, include a URL or subscription
+instructions here.
+
+If the package has a web site, include a URL here.
+
+=back
+
+In addition, some systems use CONFORMING TO to note conformance to relevant
+standards and MT-LEVEL to note safeness for use in threaded programs or
+signal handlers. These headings are primarily useful when documenting parts
+of a C library. Documentation of object-oriented libraries or modules may
+use CONSTRUCTORS and METHODS sections for detailed documentation of the
+parts of the library and save the DESCRIPTION section for an overview; other
+large modules may use FUNCTIONS for similar reasons. Some people use
+OVERVIEW to summarize the description if it's quite long.
+
+Section ordering varies, although NAME should I<always> be the first section
+(you'll break some man page systems otherwise), and NAME, SYNOPSIS,
+DESCRIPTION, and OPTIONS generally always occur first and in that order if
+present. In general, SEE ALSO, AUTHOR, and similar material should be left
+for last. Some systems also move WARNINGS and NOTES to last. The order
+given above should be reasonable for most purposes.
+
+Finally, as a general note, try not to use an excessive amount of markup.
+As documented here and in L<Pod::Man>, you can safely leave Perl variables,
+function names, man page references, and the like unadorned by markup and
+the POD translators will figure it out for you. This makes it much easier
+to later edit the documentation. Note that many existing translators
+(including this one currently) will do the wrong thing with e-mail addresses
+when wrapped in LE<lt>E<gt>, so don't do that.
+
+For additional information that may be more accurate for your specific
+system, see either L<man(5)> or L<man(7)> depending on your system manual
+section numbering conventions.
+
+=head1 SEE ALSO
+
+L<Pod::Man>, L<Pod::Simple>, L<man(1)>, L<nroff(1)>, L<perlpod(1)>,
+L<podchecker(1)>, L<troff(1)>, L<man(7)>
+
+The man page documenting the an macro set may be L<man(5)> instead of
+L<man(7)> on your system.
+
+The current version of this script is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
+B<pod2man> by Larry Wall and Tom Christiansen. Large portions of this
+documentation, particularly the sections on the anatomy of a proper man
+page, are taken from the B<pod2man> documentation by Tom.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery
+<rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pod2text b/Master/tlpkg/tlperl.straw/bin/pod2text
new file mode 100755
index 00000000000..d1f230fd90d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pod2text
@@ -0,0 +1,273 @@
+#!perl
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2text -- Convert POD data to formatted ASCII text.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
+# invoked by perldoc -t among other things.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Text ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Take an initial pass through our options, looking for one of the form
+# -<number>. We turn that into -w <number> for compatibility with the
+# original pod2text script.
+for (my $i = 0; $i < @ARGV; $i++) {
+ last if $ARGV[$i] =~ /^--$/;
+ if ($ARGV[$i] =~ /^-(\d+)$/) {
+ splice (@ARGV, $i++, 1, '-w', $1);
+ }
+}
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Simple
+# does correctly).
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options. Use the same names as Pod::Text for simplicity, and
+# default to sentence boundaries turned off for compatibility.
+my %options;
+$options{sentence} = 0;
+Getopt::Long::config ('bundling');
+GetOptions (\%options, 'alt|a', 'code', 'color|c', 'help|h', 'indent|i=i',
+ 'loose|l', 'margin|left-margin|m=i', 'overstrike|o',
+ 'quotes|q=s', 'sentence|s', 'stderr', 'termcap|t', 'utf8|u',
+ 'width|w=i')
+ or exit 1;
+pod2usage (1) if $options{help};
+
+# Figure out what formatter we're going to use. -c overrides -t.
+my $formatter = 'Pod::Text';
+if ($options{color}) {
+ $formatter = 'Pod::Text::Color';
+ eval { require Term::ANSIColor };
+ if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" }
+ require Pod::Text::Color;
+} elsif ($options{termcap}) {
+ $formatter = 'Pod::Text::Termcap';
+ require Pod::Text::Termcap;
+} elsif ($options{overstrike}) {
+ $formatter = 'Pod::Text::Overstrike';
+ require Pod::Text::Overstrike;
+}
+delete @options{'color', 'termcap', 'overstrike'};
+
+# Initialize and run the formatter.
+my $parser = $formatter->new (%options);
+do {
+ my ($input, $output) = splice (@ARGV, 0, 2);
+ $parser->parse_from_file ($input, $output);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2text - Convert POD data to formatted ASCII text
+
+=for stopwords
+-aclostu --alt --stderr Allbery --overstrike overstrike --termcap --utf8
+UTF-8
+
+=head1 SYNOPSIS
+
+pod2text [B<-aclostu>] [B<--code>] [B<-i> I<indent>] S<[B<-q> I<quotes>]>
+ [B<--stderr>] S<[B<-w> I<width>]> [I<input> [I<output> ...]]
+
+pod2text B<-h>
+
+=head1 DESCRIPTION
+
+B<pod2text> is a front-end for Pod::Text and its subclasses. It uses them
+to generate formatted ASCII text from POD source. It can optionally use
+either termcap sequences or ANSI color escape sequences to format the text.
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2text> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>, B<--alt>
+
+Use an alternate output format that, among other things, uses a different
+heading style and marks C<=item> entries with a colon in the left margin.
+
+=item B<--code>
+
+Include any non-POD text from the input file in the output as well. Useful
+for viewing code documented with POD blocks with the POD rendered and the
+code left intact.
+
+=item B<-c>, B<--color>
+
+Format the output with ANSI color escape sequences. Using this option
+requires that Term::ANSIColor be installed on your system.
+
+=item B<-i> I<indent>, B<--indent=>I<indent>
+
+Set the number of spaces to indent regular text, and the default indentation
+for C<=over> blocks. Defaults to 4 spaces if this option isn't given.
+
+=item B<-h>, B<--help>
+
+Print out usage information and exit.
+
+=item B<-l>, B<--loose>
+
+Print a blank line after a C<=head1> heading. Normally, no blank line is
+printed after C<=head1>, although one is still printed after C<=head2>,
+because this is the expected formatting for manual pages; if you're
+formatting arbitrary text documents, using this option is recommended.
+
+=item B<-m> I<width>, B<--left-margin>=I<width>, B<--margin>=I<width>
+
+The width of the left margin in spaces. Defaults to 0. This is the margin
+for all text, including headings, not the amount by which regular text is
+indented; for the latter, see B<-i> option.
+
+=item B<-o>, B<--overstrike>
+
+Format the output with overstrike printing. Bold text is rendered as
+character, backspace, character. Italics and file names are rendered as
+underscore, backspace, character. Many pagers, such as B<less>, know how
+to convert this to bold or underlined text.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> may also be set to the special value C<none>, in which case no
+quote marks are added around CE<lt>> text.
+
+=item B<-s>, B<--sentence>
+
+Assume each sentence ends with two spaces and try to preserve that spacing.
+Without this option, all consecutive whitespace in non-verbatim paragraphs
+is compressed into a single space.
+
+=item B<--stderr>
+
+By default, B<pod2text> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-t>, B<--termcap>
+
+Try to determine the width of the screen and the bold and underline
+sequences for the terminal from termcap, and use that information in
+formatting the output. Output will be wrapped at two columns less than the
+width of your terminal device. Using this option requires that your system
+have a termcap file somewhere where Term::Cap can find it and requires that
+your system support termios. With this option, the output of B<pod2text>
+will contain terminal control sequences for your current terminal type.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2text> tries to use the same output encoding as its input
+encoding (to be backward-compatible with older versions). This option
+says to instead force the output encoding to UTF-8.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-w>, B<--width=>I<width>, B<->I<width>
+
+The column at which to wrap text on the right-hand side. Defaults to 76,
+unless B<-t> is given, in which case it's two columns less than the width of
+your terminal device.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Simple> for
+information about what those errors might mean. Internally, it can also
+produce the following diagnostics:
+
+=over 4
+
+=item -c (--color) requires Term::ANSIColor be installed
+
+(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be
+loaded.
+
+=item Unknown option: %s
+
+(F) An unknown command line option was given.
+
+=back
+
+In addition, other L<Getopt::Long> error messages may result from invalid
+command-line options.
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item COLUMNS
+
+If B<-t> is given, B<pod2text> will take the current width of your screen
+from this environment variable, if available. It overrides terminal width
+information in TERMCAP.
+
+=item TERMCAP
+
+If B<-t> is given, B<pod2text> will use the contents of this environment
+variable if available to determine the correct formatting sequences for your
+current terminal device.
+
+=back
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Text::Overstrike>,
+L<Pod::Text::Termcap>, L<Pod::Simple>, L<perlpod(1)>
+
+The current version of this script is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery
+<rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/pod2text.bat b/Master/tlpkg/tlperl.straw/bin/pod2text.bat
new file mode 100755
index 00000000000..2ef787155af
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pod2text.bat
@@ -0,0 +1,289 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2text -- Convert POD data to formatted ASCII text.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
+# invoked by perldoc -t among other things.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Text ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Take an initial pass through our options, looking for one of the form
+# -<number>. We turn that into -w <number> for compatibility with the
+# original pod2text script.
+for (my $i = 0; $i < @ARGV; $i++) {
+ last if $ARGV[$i] =~ /^--$/;
+ if ($ARGV[$i] =~ /^-(\d+)$/) {
+ splice (@ARGV, $i++, 1, '-w', $1);
+ }
+}
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Simple
+# does correctly).
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options. Use the same names as Pod::Text for simplicity, and
+# default to sentence boundaries turned off for compatibility.
+my %options;
+$options{sentence} = 0;
+Getopt::Long::config ('bundling');
+GetOptions (\%options, 'alt|a', 'code', 'color|c', 'help|h', 'indent|i=i',
+ 'loose|l', 'margin|left-margin|m=i', 'overstrike|o',
+ 'quotes|q=s', 'sentence|s', 'stderr', 'termcap|t', 'utf8|u',
+ 'width|w=i')
+ or exit 1;
+pod2usage (1) if $options{help};
+
+# Figure out what formatter we're going to use. -c overrides -t.
+my $formatter = 'Pod::Text';
+if ($options{color}) {
+ $formatter = 'Pod::Text::Color';
+ eval { require Term::ANSIColor };
+ if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" }
+ require Pod::Text::Color;
+} elsif ($options{termcap}) {
+ $formatter = 'Pod::Text::Termcap';
+ require Pod::Text::Termcap;
+} elsif ($options{overstrike}) {
+ $formatter = 'Pod::Text::Overstrike';
+ require Pod::Text::Overstrike;
+}
+delete @options{'color', 'termcap', 'overstrike'};
+
+# Initialize and run the formatter.
+my $parser = $formatter->new (%options);
+do {
+ my ($input, $output) = splice (@ARGV, 0, 2);
+ $parser->parse_from_file ($input, $output);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2text - Convert POD data to formatted ASCII text
+
+=for stopwords
+-aclostu --alt --stderr Allbery --overstrike overstrike --termcap --utf8
+UTF-8
+
+=head1 SYNOPSIS
+
+pod2text [B<-aclostu>] [B<--code>] [B<-i> I<indent>] S<[B<-q> I<quotes>]>
+ [B<--stderr>] S<[B<-w> I<width>]> [I<input> [I<output> ...]]
+
+pod2text B<-h>
+
+=head1 DESCRIPTION
+
+B<pod2text> is a front-end for Pod::Text and its subclasses. It uses them
+to generate formatted ASCII text from POD source. It can optionally use
+either termcap sequences or ANSI color escape sequences to format the text.
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2text> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>, B<--alt>
+
+Use an alternate output format that, among other things, uses a different
+heading style and marks C<=item> entries with a colon in the left margin.
+
+=item B<--code>
+
+Include any non-POD text from the input file in the output as well. Useful
+for viewing code documented with POD blocks with the POD rendered and the
+code left intact.
+
+=item B<-c>, B<--color>
+
+Format the output with ANSI color escape sequences. Using this option
+requires that Term::ANSIColor be installed on your system.
+
+=item B<-i> I<indent>, B<--indent=>I<indent>
+
+Set the number of spaces to indent regular text, and the default indentation
+for C<=over> blocks. Defaults to 4 spaces if this option isn't given.
+
+=item B<-h>, B<--help>
+
+Print out usage information and exit.
+
+=item B<-l>, B<--loose>
+
+Print a blank line after a C<=head1> heading. Normally, no blank line is
+printed after C<=head1>, although one is still printed after C<=head2>,
+because this is the expected formatting for manual pages; if you're
+formatting arbitrary text documents, using this option is recommended.
+
+=item B<-m> I<width>, B<--left-margin>=I<width>, B<--margin>=I<width>
+
+The width of the left margin in spaces. Defaults to 0. This is the margin
+for all text, including headings, not the amount by which regular text is
+indented; for the latter, see B<-i> option.
+
+=item B<-o>, B<--overstrike>
+
+Format the output with overstrike printing. Bold text is rendered as
+character, backspace, character. Italics and file names are rendered as
+underscore, backspace, character. Many pagers, such as B<less>, know how
+to convert this to bold or underlined text.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> may also be set to the special value C<none>, in which case no
+quote marks are added around CE<lt>> text.
+
+=item B<-s>, B<--sentence>
+
+Assume each sentence ends with two spaces and try to preserve that spacing.
+Without this option, all consecutive whitespace in non-verbatim paragraphs
+is compressed into a single space.
+
+=item B<--stderr>
+
+By default, B<pod2text> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-t>, B<--termcap>
+
+Try to determine the width of the screen and the bold and underline
+sequences for the terminal from termcap, and use that information in
+formatting the output. Output will be wrapped at two columns less than the
+width of your terminal device. Using this option requires that your system
+have a termcap file somewhere where Term::Cap can find it and requires that
+your system support termios. With this option, the output of B<pod2text>
+will contain terminal control sequences for your current terminal type.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2text> tries to use the same output encoding as its input
+encoding (to be backward-compatible with older versions). This option
+says to instead force the output encoding to UTF-8.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-w>, B<--width=>I<width>, B<->I<width>
+
+The column at which to wrap text on the right-hand side. Defaults to 76,
+unless B<-t> is given, in which case it's two columns less than the width of
+your terminal device.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Simple> for
+information about what those errors might mean. Internally, it can also
+produce the following diagnostics:
+
+=over 4
+
+=item -c (--color) requires Term::ANSIColor be installed
+
+(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be
+loaded.
+
+=item Unknown option: %s
+
+(F) An unknown command line option was given.
+
+=back
+
+In addition, other L<Getopt::Long> error messages may result from invalid
+command-line options.
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item COLUMNS
+
+If B<-t> is given, B<pod2text> will take the current width of your screen
+from this environment variable, if available. It overrides terminal width
+information in TERMCAP.
+
+=item TERMCAP
+
+If B<-t> is given, B<pod2text> will use the contents of this environment
+variable if available to determine the correct formatting sequences for your
+current terminal device.
+
+=back
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Text::Overstrike>,
+L<Pod::Text::Termcap>, L<Pod::Simple>, L<perlpod(1)>
+
+The current version of this script is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery
+<rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pod2usage.bat b/Master/tlpkg/tlperl.straw/bin/pod2usage.bat
new file mode 100755
index 00000000000..94d50856f08
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pod2usage.bat
@@ -0,0 +1,157 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+
+#############################################################################
+# pod2usage -- command to print usage messages from embedded pod docs
+#
+# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+use strict;
+#use diagnostics;
+
+=head1 NAME
+
+pod2usage - print usage messages from embedded pod docs in files
+
+=head1 SYNOPSIS
+
+=over 12
+
+=item B<pod2usage>
+
+[B<-help>]
+[B<-man>]
+[B<-exit>S< >I<exitval>]
+[B<-output>S< >I<outfile>]
+[B<-verbose> I<level>]
+[B<-pathlist> I<dirlist>]
+I<file>
+
+=back
+
+=head1 OPTIONS AND ARGUMENTS
+
+=over 8
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print this command's manual page and exit.
+
+=item B<-exit> I<exitval>
+
+The exit status value to return.
+
+=item B<-output> I<outfile>
+
+The output file to print to. If the special names "-" or ">&1" or ">&STDOUT"
+are used then standard output is used. If ">&2" or ">&STDERR" is used then
+standard error is used.
+
+=item B<-verbose> I<level>
+
+The desired level of verbosity to use:
+
+ 1 : print SYNOPSIS only
+ 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections
+ 3 : print the entire manpage (similar to running pod2text)
+
+=item B<-pathlist> I<dirlist>
+
+Specifies one or more directories to search for the input file if it
+was not supplied with an absolute path. Each directory path in the given
+list should be separated by a ':' on Unix (';' on MSWin32 and DOS).
+
+=item I<file>
+
+The pathname of a file containing pod documentation to be output in
+usage message format (defaults to standard input).
+
+=back
+
+=head1 DESCRIPTION
+
+B<pod2usage> will read the given input file looking for pod
+documentation and will print the corresponding usage message.
+If no input file is specified then standard input is read.
+
+B<pod2usage> invokes the B<pod2usage()> function in the B<Pod::Usage>
+module. Please see L<Pod::Usage/pod2usage()>.
+
+=head1 SEE ALSO
+
+L<Pod::Usage>, L<pod2text(1)>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+Based on code for B<pod2text(1)> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+use Pod::Usage;
+use Getopt::Long;
+
+## Define options
+my %options = ();
+my @opt_specs = (
+ 'help',
+ 'man',
+ 'exit=i',
+ 'output=s',
+ 'pathlist=s',
+ 'verbose=i',
+);
+
+## Parse options
+GetOptions(\%options, @opt_specs) || pod2usage(2);
+pod2usage(1) if ($options{help});
+pod2usage(VERBOSE => 2) if ($options{man});
+
+## Dont default to STDIN if connected to a terminal
+pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
+
+@ARGV = ('-') unless (@ARGV);
+if (@ARGV > 1) {
+ print STDERR "pod2usage: Too many filenames given\n\n";
+ pod2usage(2);
+}
+
+my %usage = ();
+$usage{-input} = shift(@ARGV);
+$usage{-exitval} = $options{'exit'} if (defined $options{'exit'});
+$usage{-output} = $options{'output'} if (defined $options{'output'});
+$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'});
+$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'});
+
+pod2usage(\%usage);
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/podchecker.bat b/Master/tlpkg/tlperl.straw/bin/podchecker.bat
new file mode 100755
index 00000000000..4763503eca9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/podchecker.bat
@@ -0,0 +1,161 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+#############################################################################
+# podchecker -- command to invoke the podchecker function in Pod::Checker
+#
+# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+use strict;
+#use diagnostics;
+
+=head1 NAME
+
+podchecker - check the syntax of POD format documentation files
+
+=head1 SYNOPSIS
+
+B<podchecker> [B<-help>] [B<-man>] [B<-(no)warnings>] [I<file>S< >...]
+
+=head1 OPTIONS AND ARGUMENTS
+
+=over 8
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print the manual page and exit.
+
+=item B<-warnings> B<-nowarnings>
+
+Turn on/off printing of warnings. Repeating B<-warnings> increases the
+warning level, i.e. more warnings are printed. Currently increasing to
+level two causes flagging of unescaped "E<lt>,E<gt>" characters.
+
+=item I<file>
+
+The pathname of a POD file to syntax-check (defaults to standard input).
+
+=back
+
+=head1 DESCRIPTION
+
+B<podchecker> will read the given input files looking for POD
+syntax errors in the POD documentation and will print any errors
+it find to STDERR. At the end, it will print a status message
+indicating the number of errors found.
+
+Directories are ignored, an appropriate warning message is printed.
+
+B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker>
+Please see L<Pod::Checker/podchecker()> for more details.
+
+=head1 RETURN VALUE
+
+B<podchecker> returns a 0 (zero) exit status if all specified
+POD files are ok.
+
+=head1 ERRORS
+
+B<podchecker> returns the exit status 1 if at least one of
+the given POD files has syntax errors.
+
+The status 2 indicates that at least one of the specified
+files does not contain I<any> POD commands.
+
+Status 1 overrides status 2. If you want unambiguous
+results, call B<podchecker> with one single argument only.
+
+=head1 SEE ALSO
+
+L<Pod::Parser> and L<Pod::Checker>
+
+=head1 AUTHORS
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>,
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>
+
+Based on code for B<Pod::Text::pod2text(1)> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+
+use Pod::Checker;
+use Pod::Usage;
+use Getopt::Long;
+
+## Define options
+my %options;
+
+## Parse options
+GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2);
+pod2usage(1) if ($options{help});
+pod2usage(-verbose => 2) if ($options{man});
+
+if($options{nowarnings}) {
+ $options{warnings} = 0;
+}
+elsif(!defined $options{warnings}) {
+ $options{warnings} = 1; # default is warnings on
+}
+
+## Dont default to STDIN if connected to a terminal
+pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
+
+## Invoke podchecker()
+my $status = 0;
+@ARGV = qw(-) unless(@ARGV);
+for my $podfile (@ARGV) {
+ if($podfile eq '-') {
+ $podfile = '<&STDIN';
+ }
+ elsif(-d $podfile) {
+ warn "podchecker: Warning: Ignoring directory '$podfile'\n";
+ next;
+ }
+ my $errors =
+ podchecker($podfile, undef, '-warnings' => $options{warnings});
+ if($errors > 0) {
+ # errors occurred
+ $status = 1;
+ printf STDERR ("%s has %d pod syntax %s.\n",
+ $podfile, $errors,
+ ($errors == 1) ? 'error' : 'errors');
+ }
+ elsif($errors < 0) {
+ # no pod found
+ $status = 2 unless($status);
+ print STDERR "$podfile does not contain any pod commands.\n";
+ }
+ else {
+ print STDERR "$podfile pod syntax OK.\n";
+ }
+}
+exit $status;
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/podselect.bat b/Master/tlpkg/tlperl.straw/bin/podselect.bat
new file mode 100755
index 00000000000..d9d05ec85c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/podselect.bat
@@ -0,0 +1,120 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+
+#############################################################################
+# podselect -- command to invoke the podselect function in Pod::Select
+#
+# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+use strict;
+#use diagnostics;
+
+=head1 NAME
+
+podselect - print selected sections of pod documentation on standard output
+
+=head1 SYNOPSIS
+
+B<podselect> [B<-help>] [B<-man>] [B<-section>S< >I<section-spec>]
+[I<file>S< >...]
+
+=head1 OPTIONS AND ARGUMENTS
+
+=over 8
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print the manual page and exit.
+
+=item B<-section>S< >I<section-spec>
+
+Specify a section to include in the output.
+See L<Pod::Parser/"SECTION SPECIFICATIONS">
+for the format to use for I<section-spec>.
+This option may be given multiple times on the command line.
+
+=item I<file>
+
+The pathname of a file from which to select sections of pod
+documentation (defaults to standard input).
+
+=back
+
+=head1 DESCRIPTION
+
+B<podselect> will read the given input files looking for pod
+documentation and will print out (in raw pod format) all sections that
+match one ore more of the given section specifications. If no section
+specifications are given than all pod sections encountered are output.
+
+B<podselect> invokes the B<podselect()> function exported by B<Pod::Select>
+Please see L<Pod::Select/podselect()> for more details.
+
+=head1 SEE ALSO
+
+L<Pod::Parser> and L<Pod::Select>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+Based on code for B<Pod::Text::pod2text(1)> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+use Pod::Select;
+use Pod::Usage;
+use Getopt::Long;
+
+## Define options
+my %options = (
+ 'help' => 0,
+ 'man' => 0,
+ 'sections' => [],
+);
+
+## Parse options
+GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2);
+pod2usage(1) if ($options{help});
+pod2usage(-verbose => 2) if ($options{man});
+
+## Dont default to STDIN if connected to a terminal
+pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
+
+## Invoke podselect().
+if (@{ $options{'sections'} } > 0) {
+ podselect({ -sections => $options{'sections'} }, @ARGV);
+}
+else {
+ podselect(@ARGV);
+}
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/ppd2par b/Master/tlpkg/tlperl.straw/bin/ppd2par
new file mode 100755
index 00000000000..64bcb5dc3c7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ppd2par
@@ -0,0 +1,167 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Getopt::Long qw/GetOptions/;
+use PAR::Dist::FromPPD;
+
+our $VERSION = '0.01';
+
+=pod
+
+=head1 NAME
+
+ppd2par - Create PAR distributions from PPD XML files
+
+=head1 SYNOPSIS
+
+ppd2par --help
+
+ppd2par [-v -o DIR ...] -u PPD-URI-OR-FILE
+
+=head1 DESCRIPTION
+
+This script creates PAR distributions from packages for the
+I<Perl Package Manager> which is specific to ActiveState's
+perl distributions. In order to do this, F<ppd2par> parses
+a PPD document (which is XML). The PPD document
+contains meta data and URIs for the actual F<.tar.gz> packages
+of the PPM package.
+
+=head2 Parameters
+
+ -u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+ -v --verbose
+ Sets the verbose mode.
+ -o --out
+ Sets the output directory. (default: .)
+ --no-docs
+ Strip all documentation (man pages, html documentation) from the
+ resulting PAR distribution.
+ (This step is carried out at the end. If something goes wrong,
+ it will be skipped.)
+
+You can also set various bits of meta data by hand:
+
+ -n --distname
+ Distribution name
+ --dv --distversion
+ Distribution version (Note: This is not -v!)
+ -p --perlversion
+ Perl version (can be set to 'any_version')
+ -a --arch
+ Architecture string (can be set to 'any_arch')
+ --sa --selectarch
+ Regexp for selecting the implementation based on architecture
+ --sp --selectperl
+ Regexp for selecting the implementation based on perl version
+
+=head1 SEE ALSO
+
+This tool is implemented using the L<PAR::Dist::FromPPD> module. Please
+refer to that module's documentation for details on how this all works.
+
+PAR has a mailing list, <par@perl.org>, that you can write to; send
+an empty mail to <par-subscribe@perl.org> to join the list and
+participate in the discussion.
+
+Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>.
+
+The official PAR website may be of help, too: http://par.perl.org
+
+For details on the I<Perl Package Manager>, please refer to ActiveState's
+website at L<http://activestate.com>.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by Steffen Mueller
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+my $usage = <<"HERE";
+$0 --help # for help
+
+$0 [-v -o DIR --no-docs] -u PPD-URI-OR-FILE
+
+This script creates PAR distributions from packages for the
+Perl Package Manager which is specific to ActiveState's
+perl distributions. In order to do this, it parses
+a PPD document (which is XML). The PPD document
+contains meta data and URIs for the actual .tar.gz packages
+of the PPM package.
+
+-u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+-v --verbose
+ Sets the verbose mode.
+-o --out
+ Sets the output directory. (default: .)
+--no-docs
+ Strip all documentation (man pages, html documentation) from the
+ resulting PAR distribution.
+ (This step is carried out at the end. If something goes wrong,
+ it will be skipped.)
+
+You can also set various bits of meta data by hand:
+-n --distname
+ Distribution name
+--dv --distversion
+ Distribution version (Note: This is not -v!)
+-p --perlversion
+ Perl version (can be set to 'any_version')
+-a --arch
+ Architecture string (can be set to 'any_arch')
+--sa --selectarch
+ Regexp for selecting the implementation based on architecture
+--sp --selectperl
+ Regexp for selecting the implementation based on perl version
+HERE
+
+my $uri;
+my $outdir = '.';
+my $v = 0;
+my $nodocs = 0;
+my $distname;
+my $distversion;
+my $arch;
+my $perl;
+my $sperl;
+my $sarch;
+GetOptions(
+ 'n|distname=s' => \$distname,
+ 'dv|distversion=s' => \$distversion,
+ 'a|arch=s' => \$arch,
+ 'p|perlversion=s' => \$perl,
+ 'sa|selectarch=s' => \$sarch,
+ 'sp|selectperl=s' => \$sperl,
+ 'h|help' => sub { print $usage; exit(1) },
+ 'o|out=s' => \$outdir,
+ 'u|uri=s' => \$uri,
+ 'v|verbose' => \$v,
+ 'no-docs' => \$nodocs,
+);
+
+ppd_to_par(
+ uri => $uri,
+ ($v ? (verbose => 1 ) : ()),
+ (defined($outdir) ? (out => $outdir ) : ()),
+ ($nodocs ? (strip_docs => 1 ) : ()),
+ ($distname ? (distname => $distname ) : ()),
+ ($distversion ? (distversion => $distversion ) : ()),
+ ($arch ? (arch => $arch ) : ()),
+ ($perl ? (perlversion => $perl ) : ()),
+ ($sarch ? (selectarch => $sarch ) : ()),
+ ($sperl ? (selectperl => $sperl ) : ()),
+);
+
diff --git a/Master/tlpkg/tlperl.straw/bin/ppd2par.bat b/Master/tlpkg/tlperl.straw/bin/ppd2par.bat
new file mode 100755
index 00000000000..eecd3c79243
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ppd2par.bat
@@ -0,0 +1,183 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+use strict;
+use warnings;
+
+use Getopt::Long qw/GetOptions/;
+use PAR::Dist::FromPPD;
+
+our $VERSION = '0.01';
+
+=pod
+
+=head1 NAME
+
+ppd2par - Create PAR distributions from PPD XML files
+
+=head1 SYNOPSIS
+
+ppd2par --help
+
+ppd2par [-v -o DIR ...] -u PPD-URI-OR-FILE
+
+=head1 DESCRIPTION
+
+This script creates PAR distributions from packages for the
+I<Perl Package Manager> which is specific to ActiveState's
+perl distributions. In order to do this, F<ppd2par> parses
+a PPD document (which is XML). The PPD document
+contains meta data and URIs for the actual F<.tar.gz> packages
+of the PPM package.
+
+=head2 Parameters
+
+ -u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+ -v --verbose
+ Sets the verbose mode.
+ -o --out
+ Sets the output directory. (default: .)
+ --no-docs
+ Strip all documentation (man pages, html documentation) from the
+ resulting PAR distribution.
+ (This step is carried out at the end. If something goes wrong,
+ it will be skipped.)
+
+You can also set various bits of meta data by hand:
+
+ -n --distname
+ Distribution name
+ --dv --distversion
+ Distribution version (Note: This is not -v!)
+ -p --perlversion
+ Perl version (can be set to 'any_version')
+ -a --arch
+ Architecture string (can be set to 'any_arch')
+ --sa --selectarch
+ Regexp for selecting the implementation based on architecture
+ --sp --selectperl
+ Regexp for selecting the implementation based on perl version
+
+=head1 SEE ALSO
+
+This tool is implemented using the L<PAR::Dist::FromPPD> module. Please
+refer to that module's documentation for details on how this all works.
+
+PAR has a mailing list, <par@perl.org>, that you can write to; send
+an empty mail to <par-subscribe@perl.org> to join the list and
+participate in the discussion.
+
+Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>.
+
+The official PAR website may be of help, too: http://par.perl.org
+
+For details on the I<Perl Package Manager>, please refer to ActiveState's
+website at L<http://activestate.com>.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by Steffen Mueller
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+my $usage = <<"HERE";
+$0 --help # for help
+
+$0 [-v -o DIR --no-docs] -u PPD-URI-OR-FILE
+
+This script creates PAR distributions from packages for the
+Perl Package Manager which is specific to ActiveState's
+perl distributions. In order to do this, it parses
+a PPD document (which is XML). The PPD document
+contains meta data and URIs for the actual .tar.gz packages
+of the PPM package.
+
+-u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+-v --verbose
+ Sets the verbose mode.
+-o --out
+ Sets the output directory. (default: .)
+--no-docs
+ Strip all documentation (man pages, html documentation) from the
+ resulting PAR distribution.
+ (This step is carried out at the end. If something goes wrong,
+ it will be skipped.)
+
+You can also set various bits of meta data by hand:
+-n --distname
+ Distribution name
+--dv --distversion
+ Distribution version (Note: This is not -v!)
+-p --perlversion
+ Perl version (can be set to 'any_version')
+-a --arch
+ Architecture string (can be set to 'any_arch')
+--sa --selectarch
+ Regexp for selecting the implementation based on architecture
+--sp --selectperl
+ Regexp for selecting the implementation based on perl version
+HERE
+
+my $uri;
+my $outdir = '.';
+my $v = 0;
+my $nodocs = 0;
+my $distname;
+my $distversion;
+my $arch;
+my $perl;
+my $sperl;
+my $sarch;
+GetOptions(
+ 'n|distname=s' => \$distname,
+ 'dv|distversion=s' => \$distversion,
+ 'a|arch=s' => \$arch,
+ 'p|perlversion=s' => \$perl,
+ 'sa|selectarch=s' => \$sarch,
+ 'sp|selectperl=s' => \$sperl,
+ 'h|help' => sub { print $usage; exit(1) },
+ 'o|out=s' => \$outdir,
+ 'u|uri=s' => \$uri,
+ 'v|verbose' => \$v,
+ 'no-docs' => \$nodocs,
+);
+
+ppd_to_par(
+ uri => $uri,
+ ($v ? (verbose => 1 ) : ()),
+ (defined($outdir) ? (out => $outdir ) : ()),
+ ($nodocs ? (strip_docs => 1 ) : ()),
+ ($distname ? (distname => $distname ) : ()),
+ ($distversion ? (distversion => $distversion ) : ()),
+ ($arch ? (arch => $arch ) : ()),
+ ($perl ? (perlversion => $perl ) : ()),
+ ($sarch ? (selectarch => $sarch ) : ()),
+ ($sperl ? (selectperl => $sperl ) : ()),
+);
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/ppm.bat b/Master/tlpkg/tlperl.straw/bin/ppm.bat
new file mode 100755
index 00000000000..a02cf726d6c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ppm.bat
@@ -0,0 +1,1066 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use Getopt::Long;
+use File::Basename;
+use Config;
+use strict;
+
+use PPM;
+
+$PPM::VERSION = '0.01_01';
+
+my %help;
+
+# mapping of POD sections to command topics
+my %topic = (
+ 'Error Recovery' => 'genconfig',
+ 'Installing' => 'install',
+ 'Querying' => 'query',
+ 'Removing' => 'remove',
+ 'Searching' => 'search',
+ 'Summarizing' => 'summary',
+ 'Verifying' => 'verify',
+ 'Synopsis' => 'usage',
+ 'Options' => 'set',
+);
+
+$help{'help'} = <<'EOT';
+Commands:
+ exit - leave the program.
+ help [command] - prints this screen, or help on 'command'.
+ install PACKAGES - installs specified PACKAGES.
+ quit - leave the program.
+ query [options] - query information about installed packages.
+ remove PACKAGES - removes the specified PACKAGES from the system.
+ search [options] - search information about available packages.
+ set [options] - set/display current options.
+ verify [options] - verifies current install is up to date.
+ version - displays PPM version number
+
+EOT
+
+# Build the rest of the online help from the POD
+$/ = "\n=";
+while (<DATA>) {
+ next unless my ($topic,$text) = /^(?:item|head[12]) ([^\n]+)\n\n(.*)=/s;
+ next unless $topic{$topic};
+ ($help{$topic{$topic}} = "\n$text"); # =~ s/\n *([^\n])/\n $1/sg;
+}
+$/ = "\n";
+
+# Need to do this here, because the user's config file is probably
+# hosed.
+if ($#ARGV == 0 && $ARGV[0] eq 'genconfig') {
+ &genconfig;
+ exit 0;
+}
+
+if ($#ARGV == 0 && $ARGV[0] eq 'getconfig') {
+ print $PPM::PPMdat;
+ exit 0;
+}
+
+my %options = PPM::GetPPMOptions();
+my $location;
+
+my $moremsg = "[Press return to continue or 'q' to quit] ";
+my $interactive = 0;
+
+my %repositories = PPM::ListOfRepositories();
+
+my $prefix_pattern = $^O eq "MSWin32" ? '(--|-|\+|/)' : '(--|-|\+)';
+
+$PPM::PPMShell = 1;
+
+Getopt::Long::Configure("prefix_pattern=$prefix_pattern");
+
+if ($#ARGV == -1 || ($#ARGV == 0 && $ARGV[0] =~ /^${prefix_pattern}location/)) {
+ my $prompt = 'PPM> ';
+ $interactive = 1;
+ GetOptions("location=s" => \$location);
+
+ print "PPM interactive shell ($PPM::VERSION) - type 'help' for available commands.\n";
+ $| = 1;
+ while () {
+ print $prompt;
+ last unless defined ($_ = <> );
+ chomp;
+ s/^\s+//;
+ @ARGV = split(/\s+/, $_);
+ next unless @ARGV;
+ # exit/quit
+ if (command($ARGV[0], "qu|it") or command($ARGV[0], "|exit")) {
+ print "Quit!\n";
+ last;
+ }
+ exec_command();
+ }
+ exit 0;
+}
+
+exit exec_command();
+
+sub exec_command
+{
+ my $cmd = lc shift @ARGV;
+
+ for (@ARGV) {
+ s/::/-/g;
+ }
+
+ # help
+ if (command($cmd, "|help")) {
+ help(@ARGV);
+ }
+ # query
+ elsif (command($cmd, "qu|ery")) {
+ GetOptions("case!" => \my $case, "abstract" => \my $abstract,
+ "author" => \my $author );
+
+ my %summary = InstalledPackageProperties();
+ if (@ARGV) {
+ my $searchtag;
+ if ($abstract || $author) {
+ $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR');
+ }
+ my $RE = shift @ARGV;
+ eval { $RE =~ /$RE/ };
+ if ($@) {
+ print "'$RE': invalid regular expression.\n";
+ return 1;
+ }
+ $case = !$options{'IGNORECASE'} unless defined $case;
+ $RE = "(?i)$RE" if ($case == 0);
+ foreach(keys %summary) {
+ if ($searchtag) {
+ delete $summary{$_} unless $summary{$_}{$searchtag} =~ /$RE/;
+ }
+ else {
+ delete $summary{$_} unless /$RE/;
+ }
+ }
+ }
+ print_formatted(1, %summary);
+ }
+ # install
+ elsif (command($cmd, "in|stall")) {
+ my $location = $location;
+ GetOptions("location=s" => \$location);
+ unless (@ARGV) {
+ if (!$interactive && -d "blib" && -f "Makefile") {
+ return if InstallPackage(location => $location);
+ print "Error installing blib: $PPM::PPMERR\n";
+ return 1;
+ }
+ print "Package not specified.\n";
+ return 1;
+ }
+
+ my %installed = InstalledPackageProperties();
+ foreach my $package (@ARGV) {
+ $package =~ s/::/-/g;
+ if (my $pkg = (grep {/^$package$/i} keys %installed)[0]) {
+ my $version = $installed{$pkg}{'VERSION'};
+ $version =~ s/(,0)*$//;
+ $version =~ tr/,/./;
+ print "Version $version of '$pkg' is already installed.\n" .
+ "Remove it, or use 'verify --upgrade $pkg'.\n";
+ next;
+ }
+ elsif ($interactive && $options{'CONFIRM'}) {
+ print "Install package '$package?' (y/N): ";
+ next unless <> =~ /^[yY]/;
+ }
+ print "Installing package '$package'...\n";
+ if(!InstallPackage("package" => $package, "location" => $location)) {
+ print "Error installing package '$package': $PPM::PPMERR\n";
+ }
+ }
+ }
+ # remove
+ elsif (command($cmd, "|remove")) {
+ unless (@ARGV) {
+ print "Package not specified.\n";
+ return 1;
+ }
+ foreach my $package (@ARGV) {
+ $package =~ s/::/-/g;
+ if ($interactive && $options{'CONFIRM'}) {
+ print "Remove package '$package?' (y/N): ";
+ next unless <> =~ /[yY]/;
+ }
+ unless (RemovePackage("package" => $package)) {
+ print "Error removing $package: $PPM::PPMERR\n";
+ }
+ }
+ }
+ # search
+ elsif (command($cmd, "se|arch")) {
+ my (%summary, $searchtag);
+ my $location = $location;
+ GetOptions("case!" => \my $case, "location=s" => \$location,
+ "abstract" => \my $abstract, "author" => \my $author );
+ my $searchRE = shift @ARGV;
+ if (defined $searchRE) {
+ eval { $searchRE =~ /$searchRE/ };
+ if ($@) {
+ print "'$searchRE': invalid regular expression.\n";
+ return 1;
+ }
+ }
+ $case = !$options{'IGNORECASE'} unless defined $case;
+ if ($abstract || $author) {
+ $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR');
+ }
+ %summary = search_PPDs("location" => $location, "ignorecase" => !$case,
+ "searchtag" => $searchtag, "searchRE" => $searchRE);
+ foreach (keys %summary) {
+ print "Packages available from $_:\n";
+ print_formatted(2, %{$summary{$_}});
+ }
+ }
+ # set
+ elsif (command($cmd, "se|t")) {
+ unless (set(@ARGV) || $interactive) {
+ PPM::SetPPMOptions("options" => \%options, "save" => 1);
+ }
+ }
+ # verify
+ elsif (command($cmd, "ver|ify")) {
+ my $location = $location;
+ GetOptions("force" => \my $force, "location=s" => \$location,
+ "upgrade" => \my $upgrade);
+ if ($interactive && $upgrade && $options{'CONFIRM'}) {
+ printf "Upgrade package%s? (y/N): ", @ARGV == 1 ? " '$ARGV[0]'" : "s";
+ return unless <> =~ /^[yY]/;
+ }
+ verify_packages("packages" => \@ARGV, "location" => $location,
+ "upgrade" => $upgrade, "force" => $force);
+ }
+ elsif (command($cmd, "ver|sion")) {
+ print "$PPM::VERSION\n";
+ }
+ elsif ($cmd eq "purge") {
+ my %summary = InstalledPackageProperties();
+ foreach(keys %summary) {
+ print "Purging $_\n";
+ RemovePackage("package" => $_, "force" => 1);
+ }
+ }
+ elsif ($cmd eq 'refresh') {
+ my %summary = InstalledPackageProperties();
+ foreach(keys %summary) {
+ print "Refreshing $_\n";
+ InstallPackage("package" => $_);
+ }
+ }
+ else {
+ print "Unknown or ambiguous command '$cmd'; type 'help' for commands.\n";
+ }
+}
+
+sub help {
+ my $topic = @_ && $help{lc $_[0]} ? lc $_[0] : 'help';
+ my $help = $help{$topic};
+ $help =~ s/^(\s*)ppm\s+/$1/mg if $interactive;
+ print $help;
+}
+
+sub more
+{
+ my ($lines) = shift @_;
+ if (++$$lines >= $options{'MORE'}) {
+ print $moremsg;
+ $_ = <>;
+ $$lines = $_ eq "q\n" ? -1 : 1;
+ }
+}
+
+# This nasty piece of business splits $pattern into a required prefix
+# and a "match any of this substring" suffix. E.g. "in|stall" will
+# match a $cmd of "ins", "inst", ..., "install".
+sub command
+{
+ my ($cmd, $pattern) = @_;
+ my @pattern = split(/\|/, $pattern);
+ if ($pattern[1]) {
+ my @optchars = split(//, $pattern[1]);
+ # build up a "foo(b|ba|bar)" string
+ $pattern = "$pattern[0](";
+ $pattern[1] = shift @optchars;
+ $pattern[1] .= "|$pattern[1]$_" foreach @optchars;
+ $pattern .= "$pattern[1])";
+ }
+ return ($cmd =~ /^${pattern}$/i);
+}
+
+# This routine prints the output for query and search
+# in a nicely formatted way, if $options{'VERBOSE'} is set.
+sub print_formatted
+{
+ my ($lines, %summary) = @_;
+ my $package;
+
+ unless ($options{'VERBOSE'}) {
+ foreach $package (sort keys %summary) {
+ print "$package\n";
+ &more(\$lines) if $options{'MORE'} && $interactive;
+ last if $lines == -1;
+ }
+ return;
+ }
+
+ my ($maxname, $maxversion) = (0, 0);
+ # find the longest package name and version strings, so we can
+ # format them nicely
+ $maxname < length($_) and $maxname = length($_) for keys %summary;
+ foreach $package (keys %summary) {
+ $summary{$package}{'VERSION'} =~ s/(,0)*$//;
+ $summary{$package}{'VERSION'} =~ tr/,/./;
+ $maxversion = length $summary{$package}{'VERSION'} > $maxversion ?
+ length $summary{$package}{'VERSION'} : $maxversion;
+ }
+ my $columns = $ENV{COLUMNS} ? $ENV{COLUMNS} : 80;
+ my $namefield = "@" . "<" x ($maxname - 1);
+ my $versionfield = "@" . "<" x ($maxversion - 1);
+ my $abstractfield = "^" . "<" x ($columns - (6 + $maxname + $maxversion));
+ my $abstractpad = " " x ($maxname + $maxversion + 3);
+
+ foreach $package (sort keys %summary) {
+ eval "format STDOUT = \n"
+ . "$namefield [$versionfield] $abstractfield\n"
+ . '$package, $summary{$package}{VERSION}, $summary{$package}{ABSTRACT}'
+ . "\n"
+ . "$abstractpad $abstractfield~~\n"
+ . '$summary{$package}{ABSTRACT}'
+ . "\n"
+ . ".\n";
+
+ my $diff = $-;
+ write;
+ $diff -= $-;
+ $lines += ($diff - 1) if $diff > 1;
+ &more(\$lines) if $options{'MORE'} && $interactive;
+ last if $lines == -1;
+ }
+}
+
+sub set
+{
+ my $option = lc shift @_;
+
+ unless ($option) {
+ print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") .
+ "be confirmed.\n";
+ print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") .
+ "be deleted.\n";
+ print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ?
+ "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" :
+ "not be updated.\n");
+ print "Case-" . ($options{'IGNORECASE'} ? "in" : "") .
+ "sensitive searches will be performed.\n";
+ print "Package installations will " .
+ ($options{'FORCE_INSTALL'} ? "" : "not ") .
+ "continue if a dependency cannot be installed.\n";
+ print "Tracing info will " . (($options{'TRACE'} > 0 ) ?
+ "be written to '$options{'TRACEFILE'}'.\n" : "not be written.\n");
+ print "Screens will " . ($options{'MORE'} > 0 ?
+ "pause after $options{'MORE'} lines.\n" : "not pause.\n");
+ print "Query/search results will " .
+ ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n";
+ if (defined $location) { print "Current PPD repository: $location\n"; }
+ else {
+ print "Current PPD repository paths:\n";
+ foreach $_ (keys %repositories) {
+ print "\t$_: $repositories{$_}\n";
+ }
+ }
+ print "Packages will be installed under: $options{'ROOT'}\n"
+ if ($options{'ROOT'});
+ print "Packages will be built under: $options{'BUILDDIR'}\n"
+ if ($options{'BUILDDIR'});
+ return;
+ }
+
+ my $value = shift @_;
+ if (command($option, "r|epository")) {
+ if ($value =~ /${prefix_pattern}remove/i) {
+ $value = join(" ", @_);
+ print "Location not specified.\n" and return 1
+ unless (defined $value);
+ PPM::RemoveRepository("repository" => $value);
+ %repositories = PPM::ListOfRepositories();
+ }
+ else {
+ my $location = shift @_;
+ print "Repository not specified.\n" and return 1
+ unless (defined $value and defined $location);
+ PPM::AddRepository("repository" => $value,
+ "location" => $location);
+ %repositories = PPM::ListOfRepositories();
+ }
+ }
+ else {
+ if (command($option, "c|onfirm")) {
+ $options{'CONFIRM'} = defined $value ?
+ ($value != 0) : ($options{'CONFIRM'} ? 0 : 1);
+ print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") .
+ "be confirmed.\n";
+ }
+ elsif (command($option, "|save")) {
+ PPM::SetPPMOptions("options" => \%options, "save" => 1);
+ return 0;
+ }
+ elsif (command($option, "c|ase")) {
+ $options{'IGNORECASE'} = defined $value ?
+ ($value == 0) : ($options{'IGNORECASE'} ? 0 : 1);
+ print "Case-" . ($options{'IGNORECASE'} ? "in" : "") .
+ "sensitive searches will be performed.\n";
+ }
+ elsif (command($option, "r|oot")) {
+ my $old_root;
+ print "Directory not specified.\n" and return 1 unless ($value);
+ print "$PPM::PPMERR" and return 1
+ unless ($old_root = PPM::chroot("location" => $value));
+ $options{'ROOT'} = $value;
+ print "Root is now $value [was $old_root].\n";
+ }
+ elsif (command($option, "|build")) {
+ print "Directory not specified.\n" and return 1 unless ($value);
+ print "Directory '$value' does not exist.\n" and return 1
+ unless (-d $value);
+ $options{'BUILDDIR'} = $value;
+ print "Build directory is now $value.\n";
+ }
+ elsif (command($option, "|force_install")) {
+ $options{'FORCE_INSTALL'} = defined $value ? ($value != 0) :
+ ($options{'FORCE_INSTALL'} ? 0 : 1);
+ print "Package installations will " .
+ ($options{'FORCE_INSTALL'} ? "" : "not ") .
+ "continue if a dependency cannot be installed.\n";
+ }
+ elsif (command($option, "c|lean")) {
+ $options{'CLEAN'} = defined $value ?
+ ($value != 0) : ($options{'CLEAN'} ? 0 : 1);
+ print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") .
+ "be deleted.\n";
+ }
+ elsif (command($option, "|downloadstatus")) {
+ print "Numeric value must be given.\n" and return 1
+ unless (defined $value && $value =~ /^\d+$/);
+ $options{'DOWNLOADSTATUS'} = $value;
+ print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ?
+ "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" :
+ "not be updated.\n");
+ }
+ elsif (command($option, "|more")) {
+ print "Numeric value must be given.\n" and return 1
+ unless (defined $value && $value =~ /^\d+$/);
+ $options{'MORE'} = $value;
+ print "Screens will " . ($options{'MORE'} > 0 ?
+ "pause after $options{'MORE'} lines.\n" : "not pause.\n");
+ }
+ elsif (command($option, "trace|file")) {
+ print "Filename not specified.\n" and return 1 unless ($value);
+ $options{'TRACEFILE'} = $value;
+ print "Tracing info will be written to $options{'TRACEFILE'}.\n";
+ }
+ elsif (command($option, "trace")) {
+ print "Numeric value between 0 and 4 must be given.\n" and return 1
+ unless (defined $value &&
+ $value =~ /^\d+$/ && $value >= 0 && $value <= 4);
+ $options{'TRACE'} = $value;
+ print "Tracing info will " . ($options{'TRACE'} > 0 ?
+ "be written to $options{'TRACEFILE'}.\n" : "not be written.\n");
+ }
+ elsif (command($option, "|verbose")) {
+ $options{'VERBOSE'} = defined $value ?
+ ($value != 0) : ($options{'VERBOSE'} ? 0 : 1);
+ print "Query/search results will " .
+ ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n";
+ }
+ else {
+ print "Unknown or ambiguous option '$option'; see 'help set' for available options.\n";
+ return 1;
+ }
+ PPM::SetPPMOptions("options" => \%options);
+ }
+ return;
+}
+
+sub search_PPDs
+{
+ my %argv = @_;
+ my @locations = $argv{'location'} || $location;
+ my $searchtag = $argv{'searchtag'};
+ my $ignorecase = defined $argv{'ignorecase'} ?
+ $argv{'ignorecase'} : $options{'IGNORECASE'};
+ my $searchRE = $argv{'searchRE'};
+ if (defined $searchRE) {
+ eval { $searchRE =~ /$searchRE/ };
+ if ($@) {
+ print "'$searchRE': invalid regular expression.\n";
+ return;
+ }
+ $searchRE = "(?i)$searchRE" if $ignorecase;
+ }
+
+ my %packages;
+ unless (defined $locations[0]) {
+ my %reps = PPM::ListOfRepositories;
+ @locations = values %reps;
+ }
+ foreach my $loc (@locations) {
+ my %summary;
+
+ # see if the repository has server-side searching
+ if (defined $searchRE && (%summary = ServerSearch('location' => $loc,
+ 'searchRE' => $searchRE, 'searchtag' => $searchtag))) {
+ # XXX: clean this up
+ foreach my $package (keys %{$summary{$loc}}) {
+ $packages{$loc}{$package} = \%{$summary{$loc}{$package}};
+ }
+ next;
+ }
+
+ # see if a summary file is available
+ %summary = RepositorySummary("location" => $loc);
+ if (%summary) {
+ foreach my $package (keys %{$summary{$loc}}) {
+ next if (defined $searchtag &&
+ $summary{$loc}{$package}{$searchtag} !~ /$searchRE/);
+ next if (!defined $searchtag &&
+ defined $searchRE && $package !~ /$searchRE/);
+ $packages{$loc}{$package} = \%{$summary{$loc}{$package}};
+ }
+ }
+ else {
+ my %ppds = PPM::RepositoryPackages("location" => $loc);
+ # No summary: oh my, nothing but 'Net
+ foreach my $package (@{$ppds{$loc}}) {
+ my %package_details = RepositoryPackageProperties(
+ "package" => $package, "location" => $loc);
+ next unless %package_details;
+ next if (defined $searchtag &&
+ $package_details{$searchtag} !~ /$searchRE/);
+ next if (!defined $searchtag &&
+ defined $searchRE && $package !~ /$searchRE/);
+ $packages{$loc}{$package} = \%package_details;
+ }
+ }
+ }
+ return %packages;
+}
+
+sub verify_packages
+{
+ my %argv = @_;
+ my @packages = @{$argv{'packages'}};
+ my $upgrade = $argv{'upgrade'};
+ my $force = $argv{'force'};
+ my $location = $argv{'location'} || $location;
+ unless ($packages[0]) {
+ my %info = QueryInstalledPackages();
+ @packages = sort keys %info;
+ }
+
+ my $package = shift @packages;
+ while ($package) {
+ my $status = VerifyPackage("package" => $package,
+ "location" => $location, "upgrade" => $upgrade, "force" => $force);
+ if (defined $status) {
+ if ($status eq "0") {
+ print "Package \'$package\' is up to date.\n";
+ }
+ elsif ($upgrade) {
+ print "Package $package upgraded to version $status\n";
+ }
+ else {
+ print "An upgrade to package \'$package\' is available.\n";
+ }
+ }
+ else {
+ # Couldn't find a PPD to compare it with.
+ print "Package \'$package\' is up to date.\n";
+ }
+ $package = shift @packages;
+ }
+}
+
+sub genconfig
+{
+ my $repositories =
+ {'5.6' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.ActiveState.com/cgibin/PPM/ppmserver.pl?urn:/PPMServer',
+ summaryfile => 'fetch_summary',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://theoryx5.uwinnipeg.ca/cgi-bin/ppmserver?urn:/PPMServer',
+ summaryfile => 'fetch_summary',
+ },
+ },
+ '5.8' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.activestate.com/PPMPackages/5.8-windows',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://theoryx5.uwinnipeg.ca/ppms',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Trouchelle' =>
+ {location => 'http://trouchelle.com/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ },
+ '5.10' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.activestate.com/PPMPackages/5.10-windows',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://cpan.uwinnipeg.ca/PPMPackages/10xx',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Trouchelle' =>
+ {location => 'http://trouchelle.com/ppm10',
+ summaryfile => 'package.xml',
+ },
+ },
+ };
+ my ($perl_version);
+ PERLV: {
+ ($] < 5.008) and do {
+ $perl_version = '5.6';
+ last PERLV;
+ };
+ ($] < 5.01) and do {
+ $perl_version = '5.8';
+ last PERLV;
+ };
+ $perl_version = '5.10';
+ }
+ my $reps = $repositories->{$perl_version};
+ my $PerlDir = $Config{'prefix'};
+
+print <<"EOF";
+<PPMCONFIG>
+ <PPMVER>2,1,8,0</PPMVER>
+ <PLATFORM CPU="x86" OSVALUE="$Config{'osname'}" OSVERSION="0,0,0,0" />
+ <OPTIONS BUILDDIR="$ENV{'TEMP'}" CLEAN="1" CONFIRM="1" DOWNLOADSTATUS="16384" FORCEINSTALL="1" IGNORECASE="1" MORE="0" ROOT="$PerlDir" TRACE="0" TRACEFILE="PPM.LOG" VERBOSE="1" />
+EOF
+ foreach my $name(sort keys %$reps) {
+ my $loc = $reps->{$name}->{location};
+ my $sf = $reps->{$name}->{summaryfile};
+ print << "EOF";
+ <REPOSITORY LOCATION="$loc" NAME="$name" SUMMARYFILE="$sf" />
+EOF
+ }
+ print <<"EOF";
+ <PPMPRECIOUS>Compress-Zlib;Archive-Tar;Digest-MD5;File-CounterFile;Font-AFM;HTML-Parser;HTML-Tree;MIME-Base64;URI;XML-Element;libwww-perl;XML-Parser;SOAP-Lite;PPM;libnet;libwin32</PPMPRECIOUS>
+</PPMCONFIG>
+EOF
+}
+
+__DATA__
+
+=head1 NAME
+
+PPM - Perl Package Manager: locate, install, upgrade software packages.
+
+=head1 SYNOPSIS
+
+ ppm genconfig
+ ppm help [command]
+ ppm install [--location=location] package1 [... packageN]
+ ppm query [--case|nocase] [--abstract|author] PATTERN
+ ppm remove package1 [... packageN]
+ ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN
+ ppm set [option]
+ ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN]
+ ppm version
+ ppm [--location=location]
+
+=head1 DESCRIPTION
+
+ppm is a utility intended to simplify the tasks of locating, installing,
+upgrading and removing software packages. It is a front-end to the
+functionality provided in PPM.pm. It can determine if the most recent
+version of a software package is installed on a system, and can install
+or upgrade that package from a local or remote host.
+
+ppm runs in one of two modes: an interactive shell from which commands
+may be entered; and command-line mode, in which one specific action is
+performed per invocation of the program.
+
+ppm uses files containing an extended form of the Open Software
+Description (OSD) specification for information about software packages.
+These description files, which are written in Extensible Markup
+Language (XML) code, are referred to as 'PPD' files. Information about
+OSD can be found at the W3C web site (at the time of this writing,
+http://www.w3.org/TR/NOTE-OSD.html). The extensions to OSD used by ppm
+are documented in PPM.ppd.
+
+=head1 Using PPM
+
+=over 4
+
+=item Interactive mode
+
+If ppm is invoked with no command specified, it is started in interactive
+mode. If the '--location' argument is specified, it is used as the
+search location, otherwise the repositories specified in the PPM data file
+are used.
+
+The syntax of PPM commands is the same in interactive mode as it is in
+command-line mode. The 'help' command lists the available commands.
+
+ppm commands may be abbreviated to their shortest unique form.
+
+=item Installing
+
+ ppm install [--location=location] package1 [... packageN]
+
+Installs the specified software packages. Attempts to install from the
+URL or directory 'location' if the '--location' option is specfied.
+
+The 'package' arguments may be either package names ('foo'), pathnames
+(p:/packages/foo.ppd) or URLs (http://www.ActiveState.com/packages/foo.ppd)
+to specific PPD files.
+
+In the case where a package name is specified, and the '--location'
+option is not used, ppm will refer to the default repository locations.
+
+See also: 'confirm' option.
+
+=item Removing
+
+ ppm remove package1 [... packageN]
+
+Reads information from the PPD file for the named software package and
+removes the package from the system.
+
+See also: 'confirm' option.
+
+=item Verifying
+
+ ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN]
+
+Verifies that the currently installed packages are up to date. If no
+packages are specified as arguments, all installed packages will be verified.
+
+If the '--upgrade' option is specified, any package for which an upgrade
+is available will be upgraded.
+
+If the '--location' option is specified, upgrades will be looked for at
+the specified URL or directory.
+
+If the '--force' option is specified, all currently installed packages will
+be reinstalled regardless of whether they are out of date or not.
+
+See also: 'confirm' option.
+
+=item Querying
+
+ ppm query [--case|nocase] [--abstract|author] PATTERN
+
+Searches for 'PATTERN' (a regular expression) in the name of any installed
+package. If a search is successful, information about the matching
+package(s) is displayed. If 'PATTERN' is omitted, information about
+all installed packages will be displayed.
+
+If either '--abstract' or '--author' is specified, PATTERN will be
+searched for in the <ABSTRACT> or <AUTHOR> tags of the installed packages.
+
+The '--case' and '--nocase' options can be used to override the default
+case-sensitivity search settings.
+
+See also: 'case' option.
+
+=item Searching
+
+ ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN
+
+Displays a list of any packages matching 'PATTERN' (a regular expression)
+available from the specified location. If 'PATTERN' is omitted, information
+about all available packages will be displayed.
+
+If the '--location' option is specified, the specified URL or directory
+will be searched. If '--location' is not specified, the repository location
+as specified in the PPM data file will be searched.
+
+If either '--abstract' or '--author' is specified, PATTERN will be
+searched for in the <ABSTRACT> or <AUTHOR> tags of the available packages.
+
+The '--case' and '--nocase' options can be used to override the default
+case-sensitivity search settings.
+
+See also: 'case' option.
+
+=item Error Recovery
+
+ ppm genconfig
+ ppm getconfig
+
+The genconfig command will print a valid PPM config file (ppm.xml) to STDOUT.
+This can be useful if the PPM config file ever gets damaged leaving PPM
+unusable.
+
+If required, this command should be run from a shell prompt:
+
+ C:\Perl\site\lib> ppm genconfig > ppm.xml
+
+The getconfig command prints the location of the PPM configuration file
+used at PPM startup.
+
+=item Options
+
+ ppm set [option value]
+
+Sets or displays current options. With no arguments, current option
+settings are displayed.
+
+Available options:
+
+ build DIRECTORY
+ - Changes the package build directory.
+
+ case [1|0]
+ - Sets case-sensitive searches. If one of '1' or '0' is
+ not specified, the current setting is toggled.
+
+ clean [1|0]
+ - Sets removal of temporary files from package's build
+ area, on successful installation of a package. If one of
+ '1' or '0' is not specified, the current setting is
+ toggled.
+
+ confirm [1|0]
+ - Sets confirmation of 'install', 'remove' and 'upgrade'.
+ If one of '1' or '0' is not specified, the current
+ setting is toggled.
+
+ downloadstatus NUMBER
+ - If non-zero, updates the download status after each NUMBER
+ of bytes transferred during an 'install'. This can be
+ reassuring when installing a large package (e.g. Tk) over
+ a low-speed connection.
+
+ force_install [1|0]
+ - Continue installing a package even if a dependency cannot
+ be installed.
+
+ more NUMBER
+ - Causes output to pause after NUMBER lines have been
+ displayed. Specifying '0' turns off this capability.
+
+ set repository --remove NAME
+ - Removes the repository 'NAME' from the list of repositories.
+
+ set repository NAME LOCATION
+ - Adds a repository to the list of PPD repositories for this
+ session. 'NAME' is the name by which this repository will
+ be referred; 'LOCATION' is a URL or directory name.
+
+ root DIRECTORY
+ - Changes the install root directory. Packages will be
+ installed under this new root.
+
+ save
+ - Saves the current options as default options for future
+ sessions.
+
+ trace
+ - Tracing level--default is 1, maximum is 4, 0 indicates
+ no tracing.
+
+ tracefile
+ - File to contain tracing information, default is 'PPM.LOG'.
+
+ verbose [1|0]
+ - Display additional package information for 'query' and
+ 'search' commands.
+
+=back
+
+=head1 EXAMPLES
+
+=over 4
+
+=item ppm
+
+Starts ppm in interactive mode, using the repository locations specified
+in the PPM data file. A session might look like this:
+
+ [show all available packages]
+ PPM> search
+ Packages available from P:\PACKAGES:
+ bar [2.91 ] supplies bar methods for perl5.
+ bax [0.072] module for manipulation of bax archives.
+ baz [1.03 ] Interface to baz library
+ foo [2.23 ] Foo parser class
+
+ [list what has already been installed]
+ PPM> query
+ bax [0.071] module for manipulation of bax archives.
+ baz [1.02 ] Interface to baz library
+
+ [install a package]
+ PPM> install foo
+ Install package foo? (y/N): y
+ [...]
+
+ [toggle confirmations]
+ PPM> set confirm
+ Commands will not be confirmed.
+
+ [see if 'baz' is up-to-date]
+ PPM> verify baz
+ An upgrade to package 'baz' is available.
+
+ [upgrade 'baz']
+ PPM> verify --upgrade baz
+ [...]
+
+ [forced upgrade of 'baz']
+ PPM> verify --upgrade --force baz
+ [...]
+
+ [toggle case-sensitive searches]
+ PPM> set case
+ Case-sensitive searches will be performed.
+
+ [display all available packages beginning with 'b']
+ PPM> search ^b
+ bar [2.91 ] supplies bar methods for perl5.
+ bax [0.072] module for manipulation of bax archives.
+ baz [1.03 ] Interface to baz library
+
+ [search for installed packages containing 'baz' in the ABSTRACT tag]
+ PPM> query --abstract baz
+ Matching packages found at P:\PACKAGES:
+ baz [1.03 ] Interface to baz library
+ PPM> quit
+
+=item ppm install http://www.ActiveState.com/packages/foo.ppd
+
+Installs the software package 'foo' based on the information in the PPD
+obtained from the specified URL.
+
+=item ppm verify --upgrade foo
+
+Compares the currently installed version of the software package 'foo'
+to the one available according to the PPD obtained from the location
+specified for this package in the PPM data file, and upgrades
+to a newer version if available.
+
+=item ppm verify --location=P:\PACKAGES --upgrade foo
+
+Compares the currently installed version of the software package 'foo'
+to the one available according to the PPD obtained from the specified
+directory, and upgrades to a newer version if available.
+
+=item ppm verify --upgrade --force
+
+Forces verification and reinstalls every installed package on the system,
+using upgrade locations specified in the PPM data file.
+
+=item ppm search --location=http://ppm.ActiveState.com/PPMpackages/5.6
+
+Displays the packages with PPD files available at the specified location.
+
+=item ppm search --location=P:\PACKAGES --author ActiveState
+
+Searches the specified location for any package with an <AUTHOR> tag
+containing the string 'ActiveState'. On a successful search, the package
+name and the matching string are displayed.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES
+
+=over 4
+
+=item HTTP_proxy
+
+If the environment variable 'HTTP_proxy' is set, then it will
+be used as the address of a proxy server for accessing the Internet.
+
+The value should be of the form: 'http://proxy:port'.
+
+=back
+
+=head1 FILES
+
+The following files are fully described in the 'Files' section of PPM:ppm.
+
+=over 4
+
+=item package.ppd
+
+A description of a software package, in extended Open Software Description
+(OSD) format. More information on this file format can be found in
+PPM::ppd.
+
+=item ppm.xml - PPM data file.
+
+An XML format file containing information about the local system,
+specifics regarding the locations from which PPM obtains PPD files, and
+the installation details for any package installed by ppm.
+
+This file usually resides in '[perl]/site/lib'. If the environment
+variable 'PPM_DAT' is set, its value will be used as the full pathname
+to a PPM data file. If all else fails, ppm will look for a data file
+in the current directory.
+
+=back
+
+=head1 AUTHOR
+
+Murray Nesbitt, E<lt>F<murray@cpan.org>E<gt>
+
+=head1 CREDITS
+
+=over 4
+
+=item *
+
+The "geek-pit" at ActiveState.
+
+=item *
+
+Paul Kulchenko for his SOAP-Lite package, and for his enthusiastic
+assistance in getting PPM to work with SOAP-Lite.
+
+=back
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/ppm.pl b/Master/tlpkg/tlperl.straw/bin/ppm.pl
new file mode 100755
index 00000000000..9773e9470c1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ppm.pl
@@ -0,0 +1,1050 @@
+#!/usr/bin/perl
+
+use Getopt::Long;
+use File::Basename;
+use Config;
+use strict;
+
+use PPM;
+
+$PPM::VERSION = '0.01_01';
+
+my %help;
+
+# mapping of POD sections to command topics
+my %topic = (
+ 'Error Recovery' => 'genconfig',
+ 'Installing' => 'install',
+ 'Querying' => 'query',
+ 'Removing' => 'remove',
+ 'Searching' => 'search',
+ 'Summarizing' => 'summary',
+ 'Verifying' => 'verify',
+ 'Synopsis' => 'usage',
+ 'Options' => 'set',
+);
+
+$help{'help'} = <<'EOT';
+Commands:
+ exit - leave the program.
+ help [command] - prints this screen, or help on 'command'.
+ install PACKAGES - installs specified PACKAGES.
+ quit - leave the program.
+ query [options] - query information about installed packages.
+ remove PACKAGES - removes the specified PACKAGES from the system.
+ search [options] - search information about available packages.
+ set [options] - set/display current options.
+ verify [options] - verifies current install is up to date.
+ version - displays PPM version number
+
+EOT
+
+# Build the rest of the online help from the POD
+$/ = "\n=";
+while (<DATA>) {
+ next unless my ($topic,$text) = /^(?:item|head[12]) ([^\n]+)\n\n(.*)=/s;
+ next unless $topic{$topic};
+ ($help{$topic{$topic}} = "\n$text"); # =~ s/\n *([^\n])/\n $1/sg;
+}
+$/ = "\n";
+
+# Need to do this here, because the user's config file is probably
+# hosed.
+if ($#ARGV == 0 && $ARGV[0] eq 'genconfig') {
+ &genconfig;
+ exit 0;
+}
+
+if ($#ARGV == 0 && $ARGV[0] eq 'getconfig') {
+ print $PPM::PPMdat;
+ exit 0;
+}
+
+my %options = PPM::GetPPMOptions();
+my $location;
+
+my $moremsg = "[Press return to continue or 'q' to quit] ";
+my $interactive = 0;
+
+my %repositories = PPM::ListOfRepositories();
+
+my $prefix_pattern = $^O eq "MSWin32" ? '(--|-|\+|/)' : '(--|-|\+)';
+
+$PPM::PPMShell = 1;
+
+Getopt::Long::Configure("prefix_pattern=$prefix_pattern");
+
+if ($#ARGV == -1 || ($#ARGV == 0 && $ARGV[0] =~ /^${prefix_pattern}location/)) {
+ my $prompt = 'PPM> ';
+ $interactive = 1;
+ GetOptions("location=s" => \$location);
+
+ print "PPM interactive shell ($PPM::VERSION) - type 'help' for available commands.\n";
+ $| = 1;
+ while () {
+ print $prompt;
+ last unless defined ($_ = <> );
+ chomp;
+ s/^\s+//;
+ @ARGV = split(/\s+/, $_);
+ next unless @ARGV;
+ # exit/quit
+ if (command($ARGV[0], "qu|it") or command($ARGV[0], "|exit")) {
+ print "Quit!\n";
+ last;
+ }
+ exec_command();
+ }
+ exit 0;
+}
+
+exit exec_command();
+
+sub exec_command
+{
+ my $cmd = lc shift @ARGV;
+
+ for (@ARGV) {
+ s/::/-/g;
+ }
+
+ # help
+ if (command($cmd, "|help")) {
+ help(@ARGV);
+ }
+ # query
+ elsif (command($cmd, "qu|ery")) {
+ GetOptions("case!" => \my $case, "abstract" => \my $abstract,
+ "author" => \my $author );
+
+ my %summary = InstalledPackageProperties();
+ if (@ARGV) {
+ my $searchtag;
+ if ($abstract || $author) {
+ $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR');
+ }
+ my $RE = shift @ARGV;
+ eval { $RE =~ /$RE/ };
+ if ($@) {
+ print "'$RE': invalid regular expression.\n";
+ return 1;
+ }
+ $case = !$options{'IGNORECASE'} unless defined $case;
+ $RE = "(?i)$RE" if ($case == 0);
+ foreach(keys %summary) {
+ if ($searchtag) {
+ delete $summary{$_} unless $summary{$_}{$searchtag} =~ /$RE/;
+ }
+ else {
+ delete $summary{$_} unless /$RE/;
+ }
+ }
+ }
+ print_formatted(1, %summary);
+ }
+ # install
+ elsif (command($cmd, "in|stall")) {
+ my $location = $location;
+ GetOptions("location=s" => \$location);
+ unless (@ARGV) {
+ if (!$interactive && -d "blib" && -f "Makefile") {
+ return if InstallPackage(location => $location);
+ print "Error installing blib: $PPM::PPMERR\n";
+ return 1;
+ }
+ print "Package not specified.\n";
+ return 1;
+ }
+
+ my %installed = InstalledPackageProperties();
+ foreach my $package (@ARGV) {
+ $package =~ s/::/-/g;
+ if (my $pkg = (grep {/^$package$/i} keys %installed)[0]) {
+ my $version = $installed{$pkg}{'VERSION'};
+ $version =~ s/(,0)*$//;
+ $version =~ tr/,/./;
+ print "Version $version of '$pkg' is already installed.\n" .
+ "Remove it, or use 'verify --upgrade $pkg'.\n";
+ next;
+ }
+ elsif ($interactive && $options{'CONFIRM'}) {
+ print "Install package '$package?' (y/N): ";
+ next unless <> =~ /^[yY]/;
+ }
+ print "Installing package '$package'...\n";
+ if(!InstallPackage("package" => $package, "location" => $location)) {
+ print "Error installing package '$package': $PPM::PPMERR\n";
+ }
+ }
+ }
+ # remove
+ elsif (command($cmd, "|remove")) {
+ unless (@ARGV) {
+ print "Package not specified.\n";
+ return 1;
+ }
+ foreach my $package (@ARGV) {
+ $package =~ s/::/-/g;
+ if ($interactive && $options{'CONFIRM'}) {
+ print "Remove package '$package?' (y/N): ";
+ next unless <> =~ /[yY]/;
+ }
+ unless (RemovePackage("package" => $package)) {
+ print "Error removing $package: $PPM::PPMERR\n";
+ }
+ }
+ }
+ # search
+ elsif (command($cmd, "se|arch")) {
+ my (%summary, $searchtag);
+ my $location = $location;
+ GetOptions("case!" => \my $case, "location=s" => \$location,
+ "abstract" => \my $abstract, "author" => \my $author );
+ my $searchRE = shift @ARGV;
+ if (defined $searchRE) {
+ eval { $searchRE =~ /$searchRE/ };
+ if ($@) {
+ print "'$searchRE': invalid regular expression.\n";
+ return 1;
+ }
+ }
+ $case = !$options{'IGNORECASE'} unless defined $case;
+ if ($abstract || $author) {
+ $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR');
+ }
+ %summary = search_PPDs("location" => $location, "ignorecase" => !$case,
+ "searchtag" => $searchtag, "searchRE" => $searchRE);
+ foreach (keys %summary) {
+ print "Packages available from $_:\n";
+ print_formatted(2, %{$summary{$_}});
+ }
+ }
+ # set
+ elsif (command($cmd, "se|t")) {
+ unless (set(@ARGV) || $interactive) {
+ PPM::SetPPMOptions("options" => \%options, "save" => 1);
+ }
+ }
+ # verify
+ elsif (command($cmd, "ver|ify")) {
+ my $location = $location;
+ GetOptions("force" => \my $force, "location=s" => \$location,
+ "upgrade" => \my $upgrade);
+ if ($interactive && $upgrade && $options{'CONFIRM'}) {
+ printf "Upgrade package%s? (y/N): ", @ARGV == 1 ? " '$ARGV[0]'" : "s";
+ return unless <> =~ /^[yY]/;
+ }
+ verify_packages("packages" => \@ARGV, "location" => $location,
+ "upgrade" => $upgrade, "force" => $force);
+ }
+ elsif (command($cmd, "ver|sion")) {
+ print "$PPM::VERSION\n";
+ }
+ elsif ($cmd eq "purge") {
+ my %summary = InstalledPackageProperties();
+ foreach(keys %summary) {
+ print "Purging $_\n";
+ RemovePackage("package" => $_, "force" => 1);
+ }
+ }
+ elsif ($cmd eq 'refresh') {
+ my %summary = InstalledPackageProperties();
+ foreach(keys %summary) {
+ print "Refreshing $_\n";
+ InstallPackage("package" => $_);
+ }
+ }
+ else {
+ print "Unknown or ambiguous command '$cmd'; type 'help' for commands.\n";
+ }
+}
+
+sub help {
+ my $topic = @_ && $help{lc $_[0]} ? lc $_[0] : 'help';
+ my $help = $help{$topic};
+ $help =~ s/^(\s*)ppm\s+/$1/mg if $interactive;
+ print $help;
+}
+
+sub more
+{
+ my ($lines) = shift @_;
+ if (++$$lines >= $options{'MORE'}) {
+ print $moremsg;
+ $_ = <>;
+ $$lines = $_ eq "q\n" ? -1 : 1;
+ }
+}
+
+# This nasty piece of business splits $pattern into a required prefix
+# and a "match any of this substring" suffix. E.g. "in|stall" will
+# match a $cmd of "ins", "inst", ..., "install".
+sub command
+{
+ my ($cmd, $pattern) = @_;
+ my @pattern = split(/\|/, $pattern);
+ if ($pattern[1]) {
+ my @optchars = split(//, $pattern[1]);
+ # build up a "foo(b|ba|bar)" string
+ $pattern = "$pattern[0](";
+ $pattern[1] = shift @optchars;
+ $pattern[1] .= "|$pattern[1]$_" foreach @optchars;
+ $pattern .= "$pattern[1])";
+ }
+ return ($cmd =~ /^${pattern}$/i);
+}
+
+# This routine prints the output for query and search
+# in a nicely formatted way, if $options{'VERBOSE'} is set.
+sub print_formatted
+{
+ my ($lines, %summary) = @_;
+ my $package;
+
+ unless ($options{'VERBOSE'}) {
+ foreach $package (sort keys %summary) {
+ print "$package\n";
+ &more(\$lines) if $options{'MORE'} && $interactive;
+ last if $lines == -1;
+ }
+ return;
+ }
+
+ my ($maxname, $maxversion) = (0, 0);
+ # find the longest package name and version strings, so we can
+ # format them nicely
+ $maxname < length($_) and $maxname = length($_) for keys %summary;
+ foreach $package (keys %summary) {
+ $summary{$package}{'VERSION'} =~ s/(,0)*$//;
+ $summary{$package}{'VERSION'} =~ tr/,/./;
+ $maxversion = length $summary{$package}{'VERSION'} > $maxversion ?
+ length $summary{$package}{'VERSION'} : $maxversion;
+ }
+ my $columns = $ENV{COLUMNS} ? $ENV{COLUMNS} : 80;
+ my $namefield = "@" . "<" x ($maxname - 1);
+ my $versionfield = "@" . "<" x ($maxversion - 1);
+ my $abstractfield = "^" . "<" x ($columns - (6 + $maxname + $maxversion));
+ my $abstractpad = " " x ($maxname + $maxversion + 3);
+
+ foreach $package (sort keys %summary) {
+ eval "format STDOUT = \n"
+ . "$namefield [$versionfield] $abstractfield\n"
+ . '$package, $summary{$package}{VERSION}, $summary{$package}{ABSTRACT}'
+ . "\n"
+ . "$abstractpad $abstractfield~~\n"
+ . '$summary{$package}{ABSTRACT}'
+ . "\n"
+ . ".\n";
+
+ my $diff = $-;
+ write;
+ $diff -= $-;
+ $lines += ($diff - 1) if $diff > 1;
+ &more(\$lines) if $options{'MORE'} && $interactive;
+ last if $lines == -1;
+ }
+}
+
+sub set
+{
+ my $option = lc shift @_;
+
+ unless ($option) {
+ print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") .
+ "be confirmed.\n";
+ print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") .
+ "be deleted.\n";
+ print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ?
+ "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" :
+ "not be updated.\n");
+ print "Case-" . ($options{'IGNORECASE'} ? "in" : "") .
+ "sensitive searches will be performed.\n";
+ print "Package installations will " .
+ ($options{'FORCE_INSTALL'} ? "" : "not ") .
+ "continue if a dependency cannot be installed.\n";
+ print "Tracing info will " . (($options{'TRACE'} > 0 ) ?
+ "be written to '$options{'TRACEFILE'}'.\n" : "not be written.\n");
+ print "Screens will " . ($options{'MORE'} > 0 ?
+ "pause after $options{'MORE'} lines.\n" : "not pause.\n");
+ print "Query/search results will " .
+ ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n";
+ if (defined $location) { print "Current PPD repository: $location\n"; }
+ else {
+ print "Current PPD repository paths:\n";
+ foreach $_ (keys %repositories) {
+ print "\t$_: $repositories{$_}\n";
+ }
+ }
+ print "Packages will be installed under: $options{'ROOT'}\n"
+ if ($options{'ROOT'});
+ print "Packages will be built under: $options{'BUILDDIR'}\n"
+ if ($options{'BUILDDIR'});
+ return;
+ }
+
+ my $value = shift @_;
+ if (command($option, "r|epository")) {
+ if ($value =~ /${prefix_pattern}remove/i) {
+ $value = join(" ", @_);
+ print "Location not specified.\n" and return 1
+ unless (defined $value);
+ PPM::RemoveRepository("repository" => $value);
+ %repositories = PPM::ListOfRepositories();
+ }
+ else {
+ my $location = shift @_;
+ print "Repository not specified.\n" and return 1
+ unless (defined $value and defined $location);
+ PPM::AddRepository("repository" => $value,
+ "location" => $location);
+ %repositories = PPM::ListOfRepositories();
+ }
+ }
+ else {
+ if (command($option, "c|onfirm")) {
+ $options{'CONFIRM'} = defined $value ?
+ ($value != 0) : ($options{'CONFIRM'} ? 0 : 1);
+ print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") .
+ "be confirmed.\n";
+ }
+ elsif (command($option, "|save")) {
+ PPM::SetPPMOptions("options" => \%options, "save" => 1);
+ return 0;
+ }
+ elsif (command($option, "c|ase")) {
+ $options{'IGNORECASE'} = defined $value ?
+ ($value == 0) : ($options{'IGNORECASE'} ? 0 : 1);
+ print "Case-" . ($options{'IGNORECASE'} ? "in" : "") .
+ "sensitive searches will be performed.\n";
+ }
+ elsif (command($option, "r|oot")) {
+ my $old_root;
+ print "Directory not specified.\n" and return 1 unless ($value);
+ print "$PPM::PPMERR" and return 1
+ unless ($old_root = PPM::chroot("location" => $value));
+ $options{'ROOT'} = $value;
+ print "Root is now $value [was $old_root].\n";
+ }
+ elsif (command($option, "|build")) {
+ print "Directory not specified.\n" and return 1 unless ($value);
+ print "Directory '$value' does not exist.\n" and return 1
+ unless (-d $value);
+ $options{'BUILDDIR'} = $value;
+ print "Build directory is now $value.\n";
+ }
+ elsif (command($option, "|force_install")) {
+ $options{'FORCE_INSTALL'} = defined $value ? ($value != 0) :
+ ($options{'FORCE_INSTALL'} ? 0 : 1);
+ print "Package installations will " .
+ ($options{'FORCE_INSTALL'} ? "" : "not ") .
+ "continue if a dependency cannot be installed.\n";
+ }
+ elsif (command($option, "c|lean")) {
+ $options{'CLEAN'} = defined $value ?
+ ($value != 0) : ($options{'CLEAN'} ? 0 : 1);
+ print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") .
+ "be deleted.\n";
+ }
+ elsif (command($option, "|downloadstatus")) {
+ print "Numeric value must be given.\n" and return 1
+ unless (defined $value && $value =~ /^\d+$/);
+ $options{'DOWNLOADSTATUS'} = $value;
+ print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ?
+ "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" :
+ "not be updated.\n");
+ }
+ elsif (command($option, "|more")) {
+ print "Numeric value must be given.\n" and return 1
+ unless (defined $value && $value =~ /^\d+$/);
+ $options{'MORE'} = $value;
+ print "Screens will " . ($options{'MORE'} > 0 ?
+ "pause after $options{'MORE'} lines.\n" : "not pause.\n");
+ }
+ elsif (command($option, "trace|file")) {
+ print "Filename not specified.\n" and return 1 unless ($value);
+ $options{'TRACEFILE'} = $value;
+ print "Tracing info will be written to $options{'TRACEFILE'}.\n";
+ }
+ elsif (command($option, "trace")) {
+ print "Numeric value between 0 and 4 must be given.\n" and return 1
+ unless (defined $value &&
+ $value =~ /^\d+$/ && $value >= 0 && $value <= 4);
+ $options{'TRACE'} = $value;
+ print "Tracing info will " . ($options{'TRACE'} > 0 ?
+ "be written to $options{'TRACEFILE'}.\n" : "not be written.\n");
+ }
+ elsif (command($option, "|verbose")) {
+ $options{'VERBOSE'} = defined $value ?
+ ($value != 0) : ($options{'VERBOSE'} ? 0 : 1);
+ print "Query/search results will " .
+ ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n";
+ }
+ else {
+ print "Unknown or ambiguous option '$option'; see 'help set' for available options.\n";
+ return 1;
+ }
+ PPM::SetPPMOptions("options" => \%options);
+ }
+ return;
+}
+
+sub search_PPDs
+{
+ my %argv = @_;
+ my @locations = $argv{'location'} || $location;
+ my $searchtag = $argv{'searchtag'};
+ my $ignorecase = defined $argv{'ignorecase'} ?
+ $argv{'ignorecase'} : $options{'IGNORECASE'};
+ my $searchRE = $argv{'searchRE'};
+ if (defined $searchRE) {
+ eval { $searchRE =~ /$searchRE/ };
+ if ($@) {
+ print "'$searchRE': invalid regular expression.\n";
+ return;
+ }
+ $searchRE = "(?i)$searchRE" if $ignorecase;
+ }
+
+ my %packages;
+ unless (defined $locations[0]) {
+ my %reps = PPM::ListOfRepositories;
+ @locations = values %reps;
+ }
+ foreach my $loc (@locations) {
+ my %summary;
+
+ # see if the repository has server-side searching
+ if (defined $searchRE && (%summary = ServerSearch('location' => $loc,
+ 'searchRE' => $searchRE, 'searchtag' => $searchtag))) {
+ # XXX: clean this up
+ foreach my $package (keys %{$summary{$loc}}) {
+ $packages{$loc}{$package} = \%{$summary{$loc}{$package}};
+ }
+ next;
+ }
+
+ # see if a summary file is available
+ %summary = RepositorySummary("location" => $loc);
+ if (%summary) {
+ foreach my $package (keys %{$summary{$loc}}) {
+ next if (defined $searchtag &&
+ $summary{$loc}{$package}{$searchtag} !~ /$searchRE/);
+ next if (!defined $searchtag &&
+ defined $searchRE && $package !~ /$searchRE/);
+ $packages{$loc}{$package} = \%{$summary{$loc}{$package}};
+ }
+ }
+ else {
+ my %ppds = PPM::RepositoryPackages("location" => $loc);
+ # No summary: oh my, nothing but 'Net
+ foreach my $package (@{$ppds{$loc}}) {
+ my %package_details = RepositoryPackageProperties(
+ "package" => $package, "location" => $loc);
+ next unless %package_details;
+ next if (defined $searchtag &&
+ $package_details{$searchtag} !~ /$searchRE/);
+ next if (!defined $searchtag &&
+ defined $searchRE && $package !~ /$searchRE/);
+ $packages{$loc}{$package} = \%package_details;
+ }
+ }
+ }
+ return %packages;
+}
+
+sub verify_packages
+{
+ my %argv = @_;
+ my @packages = @{$argv{'packages'}};
+ my $upgrade = $argv{'upgrade'};
+ my $force = $argv{'force'};
+ my $location = $argv{'location'} || $location;
+ unless ($packages[0]) {
+ my %info = QueryInstalledPackages();
+ @packages = sort keys %info;
+ }
+
+ my $package = shift @packages;
+ while ($package) {
+ my $status = VerifyPackage("package" => $package,
+ "location" => $location, "upgrade" => $upgrade, "force" => $force);
+ if (defined $status) {
+ if ($status eq "0") {
+ print "Package \'$package\' is up to date.\n";
+ }
+ elsif ($upgrade) {
+ print "Package $package upgraded to version $status\n";
+ }
+ else {
+ print "An upgrade to package \'$package\' is available.\n";
+ }
+ }
+ else {
+ # Couldn't find a PPD to compare it with.
+ print "Package \'$package\' is up to date.\n";
+ }
+ $package = shift @packages;
+ }
+}
+
+sub genconfig
+{
+ my $repositories =
+ {'5.6' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.ActiveState.com/cgibin/PPM/ppmserver.pl?urn:/PPMServer',
+ summaryfile => 'fetch_summary',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://theoryx5.uwinnipeg.ca/cgi-bin/ppmserver?urn:/PPMServer',
+ summaryfile => 'fetch_summary',
+ },
+ },
+ '5.8' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.activestate.com/PPMPackages/5.8-windows',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://theoryx5.uwinnipeg.ca/ppms',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Trouchelle' =>
+ {location => 'http://trouchelle.com/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ },
+ '5.10' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.activestate.com/PPMPackages/5.10-windows',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://cpan.uwinnipeg.ca/PPMPackages/10xx',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Trouchelle' =>
+ {location => 'http://trouchelle.com/ppm10',
+ summaryfile => 'package.xml',
+ },
+ },
+ };
+ my ($perl_version);
+ PERLV: {
+ ($] < 5.008) and do {
+ $perl_version = '5.6';
+ last PERLV;
+ };
+ ($] < 5.01) and do {
+ $perl_version = '5.8';
+ last PERLV;
+ };
+ $perl_version = '5.10';
+ }
+ my $reps = $repositories->{$perl_version};
+ my $PerlDir = $Config{'prefix'};
+
+print <<"EOF";
+<PPMCONFIG>
+ <PPMVER>2,1,8,0</PPMVER>
+ <PLATFORM CPU="x86" OSVALUE="$Config{'osname'}" OSVERSION="0,0,0,0" />
+ <OPTIONS BUILDDIR="$ENV{'TEMP'}" CLEAN="1" CONFIRM="1" DOWNLOADSTATUS="16384" FORCEINSTALL="1" IGNORECASE="1" MORE="0" ROOT="$PerlDir" TRACE="0" TRACEFILE="PPM.LOG" VERBOSE="1" />
+EOF
+ foreach my $name(sort keys %$reps) {
+ my $loc = $reps->{$name}->{location};
+ my $sf = $reps->{$name}->{summaryfile};
+ print << "EOF";
+ <REPOSITORY LOCATION="$loc" NAME="$name" SUMMARYFILE="$sf" />
+EOF
+ }
+ print <<"EOF";
+ <PPMPRECIOUS>Compress-Zlib;Archive-Tar;Digest-MD5;File-CounterFile;Font-AFM;HTML-Parser;HTML-Tree;MIME-Base64;URI;XML-Element;libwww-perl;XML-Parser;SOAP-Lite;PPM;libnet;libwin32</PPMPRECIOUS>
+</PPMCONFIG>
+EOF
+}
+
+__DATA__
+
+=head1 NAME
+
+PPM - Perl Package Manager: locate, install, upgrade software packages.
+
+=head1 SYNOPSIS
+
+ ppm genconfig
+ ppm help [command]
+ ppm install [--location=location] package1 [... packageN]
+ ppm query [--case|nocase] [--abstract|author] PATTERN
+ ppm remove package1 [... packageN]
+ ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN
+ ppm set [option]
+ ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN]
+ ppm version
+ ppm [--location=location]
+
+=head1 DESCRIPTION
+
+ppm is a utility intended to simplify the tasks of locating, installing,
+upgrading and removing software packages. It is a front-end to the
+functionality provided in PPM.pm. It can determine if the most recent
+version of a software package is installed on a system, and can install
+or upgrade that package from a local or remote host.
+
+ppm runs in one of two modes: an interactive shell from which commands
+may be entered; and command-line mode, in which one specific action is
+performed per invocation of the program.
+
+ppm uses files containing an extended form of the Open Software
+Description (OSD) specification for information about software packages.
+These description files, which are written in Extensible Markup
+Language (XML) code, are referred to as 'PPD' files. Information about
+OSD can be found at the W3C web site (at the time of this writing,
+http://www.w3.org/TR/NOTE-OSD.html). The extensions to OSD used by ppm
+are documented in PPM.ppd.
+
+=head1 Using PPM
+
+=over 4
+
+=item Interactive mode
+
+If ppm is invoked with no command specified, it is started in interactive
+mode. If the '--location' argument is specified, it is used as the
+search location, otherwise the repositories specified in the PPM data file
+are used.
+
+The syntax of PPM commands is the same in interactive mode as it is in
+command-line mode. The 'help' command lists the available commands.
+
+ppm commands may be abbreviated to their shortest unique form.
+
+=item Installing
+
+ ppm install [--location=location] package1 [... packageN]
+
+Installs the specified software packages. Attempts to install from the
+URL or directory 'location' if the '--location' option is specfied.
+
+The 'package' arguments may be either package names ('foo'), pathnames
+(p:/packages/foo.ppd) or URLs (http://www.ActiveState.com/packages/foo.ppd)
+to specific PPD files.
+
+In the case where a package name is specified, and the '--location'
+option is not used, ppm will refer to the default repository locations.
+
+See also: 'confirm' option.
+
+=item Removing
+
+ ppm remove package1 [... packageN]
+
+Reads information from the PPD file for the named software package and
+removes the package from the system.
+
+See also: 'confirm' option.
+
+=item Verifying
+
+ ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN]
+
+Verifies that the currently installed packages are up to date. If no
+packages are specified as arguments, all installed packages will be verified.
+
+If the '--upgrade' option is specified, any package for which an upgrade
+is available will be upgraded.
+
+If the '--location' option is specified, upgrades will be looked for at
+the specified URL or directory.
+
+If the '--force' option is specified, all currently installed packages will
+be reinstalled regardless of whether they are out of date or not.
+
+See also: 'confirm' option.
+
+=item Querying
+
+ ppm query [--case|nocase] [--abstract|author] PATTERN
+
+Searches for 'PATTERN' (a regular expression) in the name of any installed
+package. If a search is successful, information about the matching
+package(s) is displayed. If 'PATTERN' is omitted, information about
+all installed packages will be displayed.
+
+If either '--abstract' or '--author' is specified, PATTERN will be
+searched for in the <ABSTRACT> or <AUTHOR> tags of the installed packages.
+
+The '--case' and '--nocase' options can be used to override the default
+case-sensitivity search settings.
+
+See also: 'case' option.
+
+=item Searching
+
+ ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN
+
+Displays a list of any packages matching 'PATTERN' (a regular expression)
+available from the specified location. If 'PATTERN' is omitted, information
+about all available packages will be displayed.
+
+If the '--location' option is specified, the specified URL or directory
+will be searched. If '--location' is not specified, the repository location
+as specified in the PPM data file will be searched.
+
+If either '--abstract' or '--author' is specified, PATTERN will be
+searched for in the <ABSTRACT> or <AUTHOR> tags of the available packages.
+
+The '--case' and '--nocase' options can be used to override the default
+case-sensitivity search settings.
+
+See also: 'case' option.
+
+=item Error Recovery
+
+ ppm genconfig
+ ppm getconfig
+
+The genconfig command will print a valid PPM config file (ppm.xml) to STDOUT.
+This can be useful if the PPM config file ever gets damaged leaving PPM
+unusable.
+
+If required, this command should be run from a shell prompt:
+
+ C:\Perl\site\lib> ppm genconfig > ppm.xml
+
+The getconfig command prints the location of the PPM configuration file
+used at PPM startup.
+
+=item Options
+
+ ppm set [option value]
+
+Sets or displays current options. With no arguments, current option
+settings are displayed.
+
+Available options:
+
+ build DIRECTORY
+ - Changes the package build directory.
+
+ case [1|0]
+ - Sets case-sensitive searches. If one of '1' or '0' is
+ not specified, the current setting is toggled.
+
+ clean [1|0]
+ - Sets removal of temporary files from package's build
+ area, on successful installation of a package. If one of
+ '1' or '0' is not specified, the current setting is
+ toggled.
+
+ confirm [1|0]
+ - Sets confirmation of 'install', 'remove' and 'upgrade'.
+ If one of '1' or '0' is not specified, the current
+ setting is toggled.
+
+ downloadstatus NUMBER
+ - If non-zero, updates the download status after each NUMBER
+ of bytes transferred during an 'install'. This can be
+ reassuring when installing a large package (e.g. Tk) over
+ a low-speed connection.
+
+ force_install [1|0]
+ - Continue installing a package even if a dependency cannot
+ be installed.
+
+ more NUMBER
+ - Causes output to pause after NUMBER lines have been
+ displayed. Specifying '0' turns off this capability.
+
+ set repository --remove NAME
+ - Removes the repository 'NAME' from the list of repositories.
+
+ set repository NAME LOCATION
+ - Adds a repository to the list of PPD repositories for this
+ session. 'NAME' is the name by which this repository will
+ be referred; 'LOCATION' is a URL or directory name.
+
+ root DIRECTORY
+ - Changes the install root directory. Packages will be
+ installed under this new root.
+
+ save
+ - Saves the current options as default options for future
+ sessions.
+
+ trace
+ - Tracing level--default is 1, maximum is 4, 0 indicates
+ no tracing.
+
+ tracefile
+ - File to contain tracing information, default is 'PPM.LOG'.
+
+ verbose [1|0]
+ - Display additional package information for 'query' and
+ 'search' commands.
+
+=back
+
+=head1 EXAMPLES
+
+=over 4
+
+=item ppm
+
+Starts ppm in interactive mode, using the repository locations specified
+in the PPM data file. A session might look like this:
+
+ [show all available packages]
+ PPM> search
+ Packages available from P:\PACKAGES:
+ bar [2.91 ] supplies bar methods for perl5.
+ bax [0.072] module for manipulation of bax archives.
+ baz [1.03 ] Interface to baz library
+ foo [2.23 ] Foo parser class
+
+ [list what has already been installed]
+ PPM> query
+ bax [0.071] module for manipulation of bax archives.
+ baz [1.02 ] Interface to baz library
+
+ [install a package]
+ PPM> install foo
+ Install package foo? (y/N): y
+ [...]
+
+ [toggle confirmations]
+ PPM> set confirm
+ Commands will not be confirmed.
+
+ [see if 'baz' is up-to-date]
+ PPM> verify baz
+ An upgrade to package 'baz' is available.
+
+ [upgrade 'baz']
+ PPM> verify --upgrade baz
+ [...]
+
+ [forced upgrade of 'baz']
+ PPM> verify --upgrade --force baz
+ [...]
+
+ [toggle case-sensitive searches]
+ PPM> set case
+ Case-sensitive searches will be performed.
+
+ [display all available packages beginning with 'b']
+ PPM> search ^b
+ bar [2.91 ] supplies bar methods for perl5.
+ bax [0.072] module for manipulation of bax archives.
+ baz [1.03 ] Interface to baz library
+
+ [search for installed packages containing 'baz' in the ABSTRACT tag]
+ PPM> query --abstract baz
+ Matching packages found at P:\PACKAGES:
+ baz [1.03 ] Interface to baz library
+ PPM> quit
+
+=item ppm install http://www.ActiveState.com/packages/foo.ppd
+
+Installs the software package 'foo' based on the information in the PPD
+obtained from the specified URL.
+
+=item ppm verify --upgrade foo
+
+Compares the currently installed version of the software package 'foo'
+to the one available according to the PPD obtained from the location
+specified for this package in the PPM data file, and upgrades
+to a newer version if available.
+
+=item ppm verify --location=P:\PACKAGES --upgrade foo
+
+Compares the currently installed version of the software package 'foo'
+to the one available according to the PPD obtained from the specified
+directory, and upgrades to a newer version if available.
+
+=item ppm verify --upgrade --force
+
+Forces verification and reinstalls every installed package on the system,
+using upgrade locations specified in the PPM data file.
+
+=item ppm search --location=http://ppm.ActiveState.com/PPMpackages/5.6
+
+Displays the packages with PPD files available at the specified location.
+
+=item ppm search --location=P:\PACKAGES --author ActiveState
+
+Searches the specified location for any package with an <AUTHOR> tag
+containing the string 'ActiveState'. On a successful search, the package
+name and the matching string are displayed.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES
+
+=over 4
+
+=item HTTP_proxy
+
+If the environment variable 'HTTP_proxy' is set, then it will
+be used as the address of a proxy server for accessing the Internet.
+
+The value should be of the form: 'http://proxy:port'.
+
+=back
+
+=head1 FILES
+
+The following files are fully described in the 'Files' section of PPM:ppm.
+
+=over 4
+
+=item package.ppd
+
+A description of a software package, in extended Open Software Description
+(OSD) format. More information on this file format can be found in
+PPM::ppd.
+
+=item ppm.xml - PPM data file.
+
+An XML format file containing information about the local system,
+specifics regarding the locations from which PPM obtains PPD files, and
+the installation details for any package installed by ppm.
+
+This file usually resides in '[perl]/site/lib'. If the environment
+variable 'PPM_DAT' is set, its value will be used as the full pathname
+to a PPM data file. If all else fails, ppm will look for a data file
+in the current directory.
+
+=back
+
+=head1 AUTHOR
+
+Murray Nesbitt, E<lt>F<murray@cpan.org>E<gt>
+
+=head1 CREDITS
+
+=over 4
+
+=item *
+
+The "geek-pit" at ActiveState.
+
+=item *
+
+Paul Kulchenko for his SOAP-Lite package, and for his enthusiastic
+assistance in getting PPM to work with SOAP-Lite.
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/prove b/Master/tlpkg/tlperl.straw/bin/prove
new file mode 100755
index 00000000000..bb419ed2db7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/prove
@@ -0,0 +1,338 @@
+#!C:\strawberry\perl\bin\perl.exe -w
+
+use strict;
+use App::Prove;
+
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+exit( $app->run ? 0 : 1 );
+
+__END__
+
+=head1 NAME
+
+prove - Run tests through a TAP harness.
+
+=head1 USAGE
+
+ prove [options] [files or directories]
+
+=head1 OPTIONS
+
+Boolean options:
+
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' and 'blib/arch' to the path for
+ your tests
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ --count Show the X/Y test count when not verbose
+ (default)
+ --nocount Disable the X/Y test count.
+ -D --dry Dry run. Show test that would have run.
+ --ext Set the extension for tests (default '.t')
+ -f, --failures Show failed tests.
+ -o, --comments Show comments.
+ --ignore-exit Ignore exit status from test scripts.
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ --normalize Normalize TAP output in verbose output
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+ --norc Don't process default .proverc
+
+Options that take arguments:
+
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled
+ tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See FORMATTERS.
+ --source Load and/or configure a SourceHandler. See
+ SOURCE HANDLERS.
+ -a, --archive out.tgz Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+ --state=opts Control prove's persistent state.
+ --rc=rcfile Process options from rcfile
+
+=head1 NOTES
+
+=head2 .proverc
+
+If F<~/.proverc> or F<./.proverc> exist they will be read and any
+options they contain processed before the command line options. Options
+in F<.proverc> are specified in the same way as command line options:
+
+ # .proverc
+ --state=hot,fast,save
+ -j9
+
+Additional option files may be specified with the C<--rc> option.
+Default option file processing is disabled by the C<--norc> option.
+
+Under Windows and VMS the option file is named F<_proverc> rather than
+F<.proverc> and is sought only in the current directory.
+
+=head2 Reading from C<STDIN>
+
+If you have a list of tests (or URLs, or anything else you want to test) in a
+file, you can add them to your tests by using a '-':
+
+ prove - < my_list_of_things_to_test.txt
+
+See the C<README> in the C<examples> directory of this distribution.
+
+=head2 Default Test Directory
+
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
+
+=head2 Colored Test Output
+
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
+
+Color support requires L<Term::ANSIColor> on Unix-like platforms and
+L<Win32::Console> windows. If the necessary module is not installed
+colored output will not be available.
+
+=head2 Exit Code
+
+If the tests fail C<prove> will exit with non-zero status.
+
+=head2 Arguments to Tests
+
+It is possible to supply arguments to tests. To do so separate them from
+prove's own arguments with the arisdottle, '::'. For example
+
+ prove -v t/mytest.t :: --url http://example.com
+
+would run F<t/mytest.t> with the options '--url http://example.com'.
+When running multiple tests they will each receive the same arguments.
+
+=head2 C<--exec>
+
+Normally you can just pass a list of Perl tests and the harness will know how
+to execute them. However, if your tests are not written in Perl or if you
+want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
+switch:
+
+ prove --exec '/usr/bin/ruby -w' t/
+ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
+ prove --exec '/path/to/my/customer/exec'
+
+=head2 C<--merge>
+
+If you need to make sure your diagnostics are displayed in the correct
+order relative to test results you can use the C<--merge> option to
+merge the test scripts' STDERR into their STDOUT.
+
+This guarantees that STDOUT (where the test results appear) and STDOUT
+(where the diagnostics appear) will stay in sync. The harness will
+display any diagnostics your tests emit on STDERR.
+
+Caveat: this is a bit of a kludge. In particular note that if anything
+that appears on STDERR looks like a test result the test harness will
+get confused. Use this option only if you understand the consequences
+and can live with the risk.
+
+=head2 C<--state>
+
+You can ask C<prove> to remember the state of previous test runs and
+select and/or order the tests to be run based on that saved state.
+
+The C<--state> switch requires an argument which must be a comma
+separated list of one or more of the following options.
+
+=over
+
+=item C<last>
+
+Run the same tests as the last time the state was saved. This makes it
+possible, for example, to recreate the ordering of a shuffled test.
+
+ # Run all tests in random order
+ $ prove -b --state=save --shuffle
+
+ # Run them again in the same order
+ $ prove -b --state=last
+
+=item C<failed>
+
+Run only the tests that failed on the last run.
+
+ # Run all tests
+ $ prove -b --state=save
+
+ # Run failures
+ $ prove -b --state=failed
+
+If you also specify the C<save> option newly passing tests will be
+excluded from subsequent runs.
+
+ # Repeat until no more failures
+ $ prove -b --state=failed,save
+
+=item C<passed>
+
+Run only the passed tests from last time. Useful to make sure that no
+new problems have been introduced.
+
+=item C<all>
+
+Run all tests in normal order. Multple options may be specified, so to
+run all tests with the failures from last time first:
+
+ $ prove -b --state=failed,all,save
+
+=item C<hot>
+
+Run the tests that most recently failed first. The last failure time of
+each test is stored. The C<hot> option causes tests to be run in most-recent-
+failure order.
+
+ $ prove -b --state=hot,save
+
+Tests that have never failed will not be selected. To run all tests with
+the most recently failed first use
+
+ $ prove -b --state=hot,all,save
+
+This combination of options may also be specified thus
+
+ $ prove -b --state=adrian
+
+=item C<todo>
+
+Run any tests with todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order. This is useful in conjunction
+with the C<-j> parallel testing switch to ensure that your slowest tests
+start running first.
+
+ $ prove -b --state=slow -j9
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order based on the modification times
+of the test scripts.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<fresh>
+
+Run those test scripts that have been modified since the last test run.
+
+=item C<save>
+
+Save the state on exit. The state is stored in a file called F<.prove>
+(F<_prove> on Windows and VMS) in the current directory.
+
+=back
+
+The C<--state> switch may be used more than once.
+
+ $ prove -b --state=hot --state=all,save
+
+=head2 @INC
+
+prove introduces a separation between "options passed to the perl which
+runs prove" and "options passed to the perl which runs tests"; this
+distinction is by design. Thus the perl which is running a test starts
+with the default C<@INC>. Additional library directories can be added
+via the C<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or
+via the C<-Ilib> option to F<prove>.
+
+=head2 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> prove passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even when prove is run in taint mode.
+
+
+=head1 FORMATTERS
+
+You can load a custom L<TAP::Parser::Formatter>:
+
+ prove --formatter MyFormatter
+
+=head1 SOURCE HANDLERS
+
+You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
+parser interprets particular I<sources> of TAP.
+
+ prove --source MyHandler --source YetAnother t
+
+If you want to provide config to the source you can use:
+
+ prove --source MyCustom \
+ --source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
+ --source File --file-option extensions=.txt --file-option extensions=.tmp t
+
+Each C<--$source-option> option must specify a key/value pair separated by an
+C<=>. If an option can take multiple values, just specify it multiple times,
+as with the C<extensions=> examples above.
+
+All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
+C<sources> parameter.
+
+See L<TAP::Parser::IteratorFactory> for more details on how configuration is
+passed to I<SourceHandlers>.
+
+=head1 PLUGINS
+
+Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
+plugin name:
+
+ prove -PMyPlugin=fou,du,fafa
+
+Please check individual plugin documentation for more details.
+
+=head2 Available Plugins
+
+For an up-to-date list of plugins available, please check CPAN:
+
+L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
+
+=head2 Writing Plugins
+
+Please see L<App::Prove/PLUGINS>.
+
+=cut
+
+# vim:ts=4:sw=4:et:sta
diff --git a/Master/tlpkg/tlperl.straw/bin/prove.bat b/Master/tlpkg/tlperl.straw/bin/prove.bat
new file mode 100755
index 00000000000..ef4ca66182b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/prove.bat
@@ -0,0 +1,354 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!C:\strawberry\perl\bin\perl.exe -w
+#line 15
+
+use strict;
+use App::Prove;
+
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+exit( $app->run ? 0 : 1 );
+
+__END__
+
+=head1 NAME
+
+prove - Run tests through a TAP harness.
+
+=head1 USAGE
+
+ prove [options] [files or directories]
+
+=head1 OPTIONS
+
+Boolean options:
+
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' and 'blib/arch' to the path for
+ your tests
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ --count Show the X/Y test count when not verbose
+ (default)
+ --nocount Disable the X/Y test count.
+ -D --dry Dry run. Show test that would have run.
+ --ext Set the extension for tests (default '.t')
+ -f, --failures Show failed tests.
+ -o, --comments Show comments.
+ --ignore-exit Ignore exit status from test scripts.
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ --normalize Normalize TAP output in verbose output
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+ --norc Don't process default .proverc
+
+Options that take arguments:
+
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled
+ tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See FORMATTERS.
+ --source Load and/or configure a SourceHandler. See
+ SOURCE HANDLERS.
+ -a, --archive out.tgz Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+ --state=opts Control prove's persistent state.
+ --rc=rcfile Process options from rcfile
+
+=head1 NOTES
+
+=head2 .proverc
+
+If F<~/.proverc> or F<./.proverc> exist they will be read and any
+options they contain processed before the command line options. Options
+in F<.proverc> are specified in the same way as command line options:
+
+ # .proverc
+ --state=hot,fast,save
+ -j9
+
+Additional option files may be specified with the C<--rc> option.
+Default option file processing is disabled by the C<--norc> option.
+
+Under Windows and VMS the option file is named F<_proverc> rather than
+F<.proverc> and is sought only in the current directory.
+
+=head2 Reading from C<STDIN>
+
+If you have a list of tests (or URLs, or anything else you want to test) in a
+file, you can add them to your tests by using a '-':
+
+ prove - < my_list_of_things_to_test.txt
+
+See the C<README> in the C<examples> directory of this distribution.
+
+=head2 Default Test Directory
+
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
+
+=head2 Colored Test Output
+
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
+
+Color support requires L<Term::ANSIColor> on Unix-like platforms and
+L<Win32::Console> windows. If the necessary module is not installed
+colored output will not be available.
+
+=head2 Exit Code
+
+If the tests fail C<prove> will exit with non-zero status.
+
+=head2 Arguments to Tests
+
+It is possible to supply arguments to tests. To do so separate them from
+prove's own arguments with the arisdottle, '::'. For example
+
+ prove -v t/mytest.t :: --url http://example.com
+
+would run F<t/mytest.t> with the options '--url http://example.com'.
+When running multiple tests they will each receive the same arguments.
+
+=head2 C<--exec>
+
+Normally you can just pass a list of Perl tests and the harness will know how
+to execute them. However, if your tests are not written in Perl or if you
+want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
+switch:
+
+ prove --exec '/usr/bin/ruby -w' t/
+ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
+ prove --exec '/path/to/my/customer/exec'
+
+=head2 C<--merge>
+
+If you need to make sure your diagnostics are displayed in the correct
+order relative to test results you can use the C<--merge> option to
+merge the test scripts' STDERR into their STDOUT.
+
+This guarantees that STDOUT (where the test results appear) and STDOUT
+(where the diagnostics appear) will stay in sync. The harness will
+display any diagnostics your tests emit on STDERR.
+
+Caveat: this is a bit of a kludge. In particular note that if anything
+that appears on STDERR looks like a test result the test harness will
+get confused. Use this option only if you understand the consequences
+and can live with the risk.
+
+=head2 C<--state>
+
+You can ask C<prove> to remember the state of previous test runs and
+select and/or order the tests to be run based on that saved state.
+
+The C<--state> switch requires an argument which must be a comma
+separated list of one or more of the following options.
+
+=over
+
+=item C<last>
+
+Run the same tests as the last time the state was saved. This makes it
+possible, for example, to recreate the ordering of a shuffled test.
+
+ # Run all tests in random order
+ $ prove -b --state=save --shuffle
+
+ # Run them again in the same order
+ $ prove -b --state=last
+
+=item C<failed>
+
+Run only the tests that failed on the last run.
+
+ # Run all tests
+ $ prove -b --state=save
+
+ # Run failures
+ $ prove -b --state=failed
+
+If you also specify the C<save> option newly passing tests will be
+excluded from subsequent runs.
+
+ # Repeat until no more failures
+ $ prove -b --state=failed,save
+
+=item C<passed>
+
+Run only the passed tests from last time. Useful to make sure that no
+new problems have been introduced.
+
+=item C<all>
+
+Run all tests in normal order. Multple options may be specified, so to
+run all tests with the failures from last time first:
+
+ $ prove -b --state=failed,all,save
+
+=item C<hot>
+
+Run the tests that most recently failed first. The last failure time of
+each test is stored. The C<hot> option causes tests to be run in most-recent-
+failure order.
+
+ $ prove -b --state=hot,save
+
+Tests that have never failed will not be selected. To run all tests with
+the most recently failed first use
+
+ $ prove -b --state=hot,all,save
+
+This combination of options may also be specified thus
+
+ $ prove -b --state=adrian
+
+=item C<todo>
+
+Run any tests with todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order. This is useful in conjunction
+with the C<-j> parallel testing switch to ensure that your slowest tests
+start running first.
+
+ $ prove -b --state=slow -j9
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order based on the modification times
+of the test scripts.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<fresh>
+
+Run those test scripts that have been modified since the last test run.
+
+=item C<save>
+
+Save the state on exit. The state is stored in a file called F<.prove>
+(F<_prove> on Windows and VMS) in the current directory.
+
+=back
+
+The C<--state> switch may be used more than once.
+
+ $ prove -b --state=hot --state=all,save
+
+=head2 @INC
+
+prove introduces a separation between "options passed to the perl which
+runs prove" and "options passed to the perl which runs tests"; this
+distinction is by design. Thus the perl which is running a test starts
+with the default C<@INC>. Additional library directories can be added
+via the C<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or
+via the C<-Ilib> option to F<prove>.
+
+=head2 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> prove passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even when prove is run in taint mode.
+
+
+=head1 FORMATTERS
+
+You can load a custom L<TAP::Parser::Formatter>:
+
+ prove --formatter MyFormatter
+
+=head1 SOURCE HANDLERS
+
+You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
+parser interprets particular I<sources> of TAP.
+
+ prove --source MyHandler --source YetAnother t
+
+If you want to provide config to the source you can use:
+
+ prove --source MyCustom \
+ --source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
+ --source File --file-option extensions=.txt --file-option extensions=.tmp t
+
+Each C<--$source-option> option must specify a key/value pair separated by an
+C<=>. If an option can take multiple values, just specify it multiple times,
+as with the C<extensions=> examples above.
+
+All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
+C<sources> parameter.
+
+See L<TAP::Parser::IteratorFactory> for more details on how configuration is
+passed to I<SourceHandlers>.
+
+=head1 PLUGINS
+
+Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
+plugin name:
+
+ prove -PMyPlugin=fou,du,fafa
+
+Please check individual plugin documentation for more details.
+
+=head2 Available Plugins
+
+For an up-to-date list of plugins available, please check CPAN:
+
+L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
+
+=head2 Writing Plugins
+
+Please see L<App::Prove/PLUGINS>.
+
+=cut
+
+# vim:ts=4:sw=4:et:sta
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/psed.bat b/Master/tlpkg/tlperl.straw/bin/psed.bat
new file mode 100755
index 00000000000..aaf9845505b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/psed.bat
@@ -0,0 +1,2018 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+my $startperl;
+my $perlpath;
+($startperl = <<'/../') =~ s/\s*\z//;
+#!perl
+/../
+($perlpath = <<'/../') =~ s/\s*\z//;
+C:\strawberry\perl\bin\perl.exe
+/../
+
+$0 =~ s/^.*?(\w+)[\.\w]*$/$1/;
+
+# (p)sed - a stream editor
+# History: Aug 12 2000: Original version.
+# Mar 25 2002: Rearrange generated Perl program.
+# Jul 23 2007: Fix bug in regex stripping (M.Thorland)
+
+use strict;
+use integer;
+use Symbol;
+
+=head1 NAME
+
+psed - a stream editor
+
+=head1 SYNOPSIS
+
+ psed [-an] script [file ...]
+ psed [-an] [-e script] [-f script-file] [file ...]
+
+ s2p [-an] [-e script] [-f script-file]
+
+=head1 DESCRIPTION
+
+A stream editor reads the input stream consisting of the specified files
+(or standard input, if none are given), processes is line by line by
+applying a script consisting of edit commands, and writes resulting lines
+to standard output. The filename `C<->' may be used to read standard input.
+
+The edit script is composed from arguments of B<-e> options and
+script-files, in the given order. A single script argument may be specified
+as the first parameter.
+
+If this program is invoked with the name F<s2p>, it will act as a
+sed-to-Perl translator. See L<"sed Script Translation">.
+
+B<sed> returns an exit code of 0 on success or >0 if an error occurred.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>
+
+A file specified as argument to the B<w> edit command is by default
+opened before input processing starts. Using B<-a>, opening of such
+files is delayed until the first line is actually written to the file.
+
+=item B<-e> I<script>
+
+The editing commands defined by I<script> are appended to the script.
+Multiple commands must be separated by newlines.
+
+=item B<-f> I<script-file>
+
+Editing commands from the specified I<script-file> are read and appended
+to the script.
+
+=item B<-n>
+
+By default, a line is written to standard output after the editing script
+has been applied to it. The B<-n> option suppresses automatic printing.
+
+=back
+
+=head1 COMMANDS
+
+B<sed> command syntax is defined as
+
+Z<> Z<> Z<> Z<>[I<address>[B<,>I<address>]][B<!>]I<function>[I<argument>]
+
+with whitespace being permitted before or after addresses, and between
+the function character and the argument. The I<address>es and the
+address inverter (C<!>) are used to restrict the application of a
+command to the selected line(s) of input.
+
+Each command must be on a line of its own, except where noted in
+the synopses below.
+
+The edit cycle performed on each input line consist of reading the line
+(without its trailing newline character) into the I<pattern space>,
+applying the applicable commands of the edit script, writing the final
+contents of the pattern space and a newline to the standard output.
+A I<hold space> is provided for saving the contents of the
+pattern space for later use.
+
+=head2 Addresses
+
+A sed address is either a line number or a pattern, which may be combined
+arbitrarily to construct ranges. Lines are numbered across all input files.
+
+Any address may be followed by an exclamation mark (`C<!>'), selecting
+all lines not matching that address.
+
+=over 4
+
+=item I<number>
+
+The line with the given number is selected.
+
+=item B<$>
+
+A dollar sign (C<$>) is the line number of the last line of the input stream.
+
+=item B</>I<regular expression>B</>
+
+A pattern address is a basic regular expression (see
+L<"Basic Regular Expressions">), between the delimiting character C</>.
+Any other character except C<\> or newline may be used to delimit a
+pattern address when the initial delimiter is prefixed with a
+backslash (`C<\>').
+
+=back
+
+If no address is given, the command selects every line.
+
+If one address is given, it selects the line (or lines) matching the
+address.
+
+Two addresses select a range that begins whenever the first address
+matches, and ends (including that line) when the second address matches.
+If the first (second) address is a matching pattern, the second
+address is not applied to the very same line to determine the end of
+the range. Likewise, if the second address is a matching pattern, the
+first address is not applied to the very same line to determine the
+begin of another range. If both addresses are line numbers,
+and the second line number is less than the first line number, then
+only the first line is selected.
+
+
+=head2 Functions
+
+The maximum permitted number of addresses is indicated with each
+function synopsis below.
+
+The argument I<text> consists of one or more lines following the command.
+Embedded newlines in I<text> must be preceded with a backslash. Other
+backslashes in I<text> are deleted and the following character is taken
+literally.
+
+=over 4
+
+=cut
+
+my %ComTab;
+my %GenKey;
+#--------------------------------------------------------------------------
+$ComTab{'a'}=[ 1, 'txt', \&Emit, '{ push( @Q, <<'."'TheEnd' ) }\n" ]; #ok
+
+=item [1addr]B<a\> I<text>
+
+Write I<text> (which must start on the line following the command)
+to standard output immediately before reading the next line
+of input, either by executing the B<N> function or by beginning a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'b'}=[ 2, 'str', \&Branch, '{ goto XXX; }' ]; #ok
+
+=item [2addr]B<b> [I<label>]
+
+Branch to the B<:> function with the specified I<label>. If no label
+is given, branch to the end of the script.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'c'}=[ 2, 'txt', \&Change, <<'-X-' ]; #ok
+{ print <<'TheEnd'; } $doPrint = 0; goto EOS;
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<c\> I<text>
+
+The line, or range of lines, selected by the address is deleted.
+The I<text> (which must start on the line following the command)
+is written to standard output. With an address range, this occurs at
+the end of the range.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'d'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ $doPrint = 0;
+ goto EOS;
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<d>
+
+Deletes the pattern space and starts the next cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'D'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ s/^.*\n?//;
+ if(length($_)){ goto BOS } else { goto EOS }
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<D>
+
+Deletes the pattern space through the first embedded newline or to the end.
+If the pattern space becomes empty, a new cycle is started, otherwise
+execution of the script is restarted.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'g'}=[ 2, '', \&Emit, '{ $_ = $Hold };' ]; #ok
+
+=item [2addr]B<g>
+
+Replace the contents of the pattern space with the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'G'}=[ 2, '', \&Emit, '{ $_ .= "\n"; $_ .= $Hold };' ]; #ok
+
+=item [2addr]B<G>
+
+Append a newline and the contents of the hold space to the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'h'}=[ 2, '', \&Emit, '{ $Hold = $_ }' ]; #ok
+
+=item [2addr]B<h>
+
+Replace the contents of the hold space with the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'H'}=[ 2, '', \&Emit, '{ $Hold .= "\n"; $Hold .= $_; }' ]; #ok
+
+=item [2addr]B<H>
+
+Append a newline and the contents of the pattern space to the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'i'}=[ 1, 'txt', \&Emit, '{ print <<'."'TheEnd' }\n" ]; #ok
+
+=item [1addr]B<i\> I<text>
+
+Write the I<text> (which must start on the line following the command)
+to standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'l'}=[ 2, '', \&Emit, '{ _l() }' ]; #okUTF8
+
+=item [2addr]B<l>
+
+Print the contents of the pattern space: non-printable characters are
+shown in C-style escaped form; long lines are split and have a trailing
+`C<\>' at the point of the split; the true end of a line is marked with
+a `C<$>'. Escapes are: `\a', `\t', `\n', `\f', `\r', `\e' for
+BEL, HT, LF, FF, CR, ESC, respectively, and `\' followed by a three-digit
+octal number for all other non-printable characters.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'n'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV();
+ chomp();
+}
+-X-
+
+=item [2addr]B<n>
+
+If automatic printing is enabled, write the pattern space to the standard
+output. Replace the pattern space with the next line of input. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'N'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV( $h );
+ chomp( $h );
+ $_ .= "\n$h";
+}
+-X-
+
+=item [2addr]B<N>
+
+Append a newline and the next line of input to the pattern space. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'p'}=[ 2, '', \&Emit, '{ print $_, "\n"; }' ]; #ok
+
+=item [2addr]B<p>
+
+Print the pattern space to the standard output. (Use the B<-n> option
+to suppress automatic printing at the end of a cycle if you want to
+avoid double printing of lines.)
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'P'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ if( /^(.*)/ ){ print $1, "\n"; } }
+-X-
+
+=item [2addr]B<P>
+
+Prints the pattern space through the first embedded newline or to the end.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'q'}=[ 1, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ last CYCLE;
+}
+-X-
+
+=item [1addr]B<q>
+
+Branch to the end of the script and quit without starting a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'r'}=[ 1, 'str', \&Emit, "{ _r( '-X-' ) }" ]; #ok
+
+=item [1addr]B<r> I<file>
+
+Copy the contents of the I<file> to standard output immediately before
+the next attempt to read a line of input. Any error encountered while
+reading I<file> is silently ignored.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'s'}=[ 2, 'sub', \&Emit, '' ]; #ok
+
+=item [2addr]B<s/>I<regular expression>B</>I<replacement>B</>I<flags>
+
+Substitute the I<replacement> string for the first substring in
+the pattern space that matches the I<regular expression>.
+Any character other than backslash or newline can be used instead of a
+slash to delimit the regular expression and the replacement.
+To use the delimiter as a literal character within the regular expression
+and the replacement, precede the character by a backslash (`C<\>').
+
+Literal newlines may be embedded in the replacement string by
+preceding a newline with a backslash.
+
+Within the replacement, an ampersand (`C<&>') is replaced by the string
+matching the regular expression. The strings `C<\1>' through `C<\9>' are
+replaced by the corresponding subpattern (see L<"Basic Regular Expressions">).
+To get a literal `C<&>' or `C<\>' in the replacement text, precede it
+by a backslash.
+
+The following I<flags> modify the behaviour of the B<s> command:
+
+=over 8
+
+=item B<g>
+
+The replacement is performed for all matching, non-overlapping substrings
+of the pattern space.
+
+=item B<1>..B<9>
+
+Replace only the n-th matching substring of the pattern space.
+
+=item B<p>
+
+If the substitution was made, print the new value of the pattern space.
+
+=item B<w> I<file>
+
+If the substitution was made, write the new value of the pattern space
+to the specified file.
+
+=back
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'t'}=[ 2, 'str', \&Branch, '{ goto XXX if _t() }' ]; #ok
+
+=item [2addr]B<t> [I<label>]
+
+Branch to the B<:> function with the specified I<label> if any B<s>
+substitutions have been made since the most recent reading of an input line
+or execution of a B<t> function. If no label is given, branch to the end of
+the script.
+
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'w'}=[ 2, 'str', \&Write, "{ _w( '-X-' ) }" ]; #ok
+
+=item [2addr]B<w> I<file>
+
+The contents of the pattern space are written to the I<file>.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'x'}=[ 2, '', \&Emit, '{ ($Hold, $_) = ($_, $Hold) }' ]; #ok
+
+=item [2addr]B<x>
+
+Swap the contents of the pattern space and the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'y'}=[ 2, 'tra', \&Emit, '' ]; #ok
+=item [2addr]B<y>B</>I<string1>B</>I<string2>B</>
+
+In the pattern space, replace all characters occuring in I<string1> by the
+character at the corresponding position in I<string2>. It is possible
+to use any character (other than a backslash or newline) instead of a
+slash to delimit the strings. Within I<string1> and I<string2>, a
+backslash followed by any character other than a newline is that literal
+character, and a backslash followed by an `n' is replaced by a newline
+character.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'='}=[ 1, '', \&Emit, '{ print "$.\n" }' ]; #ok
+
+=item [1addr]B<=>
+
+Prints the current line number on the standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{':'}=[ 0, 'str', \&Label, '' ]; #ok
+
+=item [0addr]B<:> [I<label>]
+
+The command specifies the position of the I<label>. It has no other effect.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'{'}=[ 2, '', \&BeginBlock, '{' ]; #ok
+$ComTab{'}'}=[ 0, '', \&EndBlock, ';}' ]; #ok
+# ';' to avoid warning on empty {}-block
+
+=item [2addr]B<{> [I<command>]
+
+=item [0addr]B<}>
+
+These two commands begin and end a command list. The first command may
+be given on the same line as the opening B<{> command. The commands
+within the list are jointly selected by the address(es) given on the
+B<{> command (but may still have individual addresses).
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'#'}=[ 0, 'str', \&Comment, '' ]; #ok
+
+=item [0addr]B<#> [I<comment>]
+
+The entire line is ignored (treated as a comment). If, however, the first
+two characters in the script are `C<#n>', automatic printing of output is
+suppressed, as if the B<-n> option were given on the command line.
+
+=back
+
+=cut
+
+use vars qw{ $isEOF $Hold %wFiles @Q $CondReg $doPrint };
+
+my $useDEBUG = exists( $ENV{PSEDDEBUG} );
+my $useEXTBRE = $ENV{PSEDEXTBRE} || '';
+$useEXTBRE =~ s/[^<>wWyB]//g; # gawk RE's handle these
+
+my $doAutoPrint = 1; # automatic printing of pattern space (-n => 0)
+my $doOpenWrite = 1; # open w command output files at start (-a => 0)
+my $svOpenWrite = 0; # save $doOpenWrite
+
+# lower case $0 below as a VMSism. The VMS build procedure creates the
+# s2p file traditionally in upper case on the disk. When VMS is in a
+# case preserved or case sensitive mode, $0 will be returned in the exact
+# case which will be on the disk, and that is not predictable at this time.
+
+my $doGenerate = lc($0) eq 's2p';
+
+# Collected and compiled script
+#
+my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code, $Func );
+$Code = '';
+
+##################
+# Compile Time
+#
+# Labels
+#
+# Error handling
+#
+sub Warn($;$){
+ my( $msg, $loc ) = @_;
+ $loc ||= '';
+ $loc .= ': ' if length( $loc );
+ warn( "$0: $loc$msg\n" );
+}
+
+$labNum = 0;
+sub newLabel(){
+ return 'L_'.++$labNum;
+}
+
+# safeHere: create safe here delimiter and modify opcode and argument
+#
+sub safeHere($$){
+ my( $codref, $argref ) = @_;
+ my $eod = 'EOD000';
+ while( $$argref =~ /^$eod$/m ){
+ $eod++;
+ }
+ $$codref =~ s/TheEnd/$eod/e;
+ $$argref .= "$eod\n";
+}
+
+# Emit: create address logic and emit command
+#
+sub Emit($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $cond = '';
+ if( defined( $addr1 ) ){
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ $cond = $negated ? "unless( $addr1 )\n" : "if( $addr1 )\n";
+ }
+
+ if( $opcode eq '' ){
+ $Code .= "$cond$arg\n";
+
+ } elsif( $opcode =~ s/-X-/$arg/e ){
+ $Code .= "$cond$opcode\n";
+
+ } elsif( $opcode =~ /TheEnd/ ){
+ safeHere( \$opcode, \$arg );
+ $Code .= "$cond$opcode$arg";
+
+ } else {
+ $Code .= "$cond$opcode\n";
+ }
+ 0;
+}
+
+# Write (w command, w flag): store pathname
+#
+sub Write($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $path, $fl ) = @_;
+ $wFiles{$path} = '';
+ Emit( $addr1, $addr2, $negated, $opcode, $path, $fl );
+}
+
+
+# Label (: command): label definition
+#
+sub Label($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ my $rc = 0;
+ $lab =~ s/\s+//;
+ if( length( $lab ) ){
+ my $h;
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ if( exists( $Label{$lab}{defined} ) ){
+ my $dl = $Label{$lab}{defined};
+ Warn( "duplicate label $lab (first defined at $dl)", $fl );
+ $rc = 1;
+ }
+ }
+ $Label{$lab}{defined} = $fl;
+ $Code .= "$h:;\n";
+ }
+ $rc;
+}
+
+# BeginBlock ({ command): push block start
+#
+sub BeginBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ push( @BlockStack, [ $fl, $addr1, $addr2, $negated ] );
+ Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+}
+
+# EndBlock (} command): check proper nesting
+#
+sub EndBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $rc;
+ my $jcom = pop( @BlockStack );
+ if( defined( $jcom ) ){
+ $rc = Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+ } else {
+ Warn( "unexpected `}'", $fl );
+ $rc = 1;
+ }
+ $rc;
+}
+
+# Branch (t, b commands): check or create label, substitute default
+#
+sub Branch($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ $lab =~ s/\s+//; # no spaces at end
+ my $h;
+ if( length( $lab ) ){
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ }
+ push( @{$Label{$lab}{used}}, $fl );
+ } else {
+ $h = 'EOS';
+ }
+ $opcode =~ s/XXX/$h/e;
+ Emit( $addr1, $addr2, $negated, $opcode, '', $fl );
+}
+
+# Change (c command): is special due to range end watching
+#
+sub Change($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $kwd = $negated ? 'unless' : 'if';
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ if( ! $negated ){
+ $addr1 = '$icnt = ('.$addr1.')';
+ $opcode = 'if( $icnt =~ /E0$/ )' . $opcode;
+ }
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ safeHere( \$opcode, \$arg );
+ $Code .= "$kwd( $addr1 ){\n $opcode$arg}\n";
+ 0;
+}
+
+
+# Comment (# command): A no-op. Who would've thought that!
+#
+sub Comment($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+### $Code .= "# $arg\n";
+ 0;
+}
+
+# stripRegex from the current command. If we're in the first
+# part of s///, trailing spaces have to be kept as the initial
+# part of the replacement string.
+#
+sub stripRegex($$;$){
+ my( $del, $sref, $sub ) = @_;
+ my $regex = $del;
+ print "stripRegex:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E(\s*)}{}s ){
+ my $sl = $2;
+ $regex .= $1.$sl.$del;
+ if( length( $sl ) % 2 == 0 ){
+ if( $sub && (length( $3 ) > 0) ){
+ $$sref = $3 . $$sref;
+ }
+ return $regex;
+ }
+ $regex .= $3;
+ }
+ undef();
+}
+
+# stripTrans: take a <del> terminated string from y command
+# honoring and cleaning up of \-escaped <del>'s
+#
+sub stripTrans($$){
+ my( $del, $sref ) = @_;
+ my $t = '';
+ print "stripTrans:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E}{}s ){
+ my $sl = $2;
+ $t .= $1;
+ if( length( $sl ) % 2 == 0 ){
+ $t .= $sl;
+ $t =~ s/\\\\/\\/g;
+ return $t;
+ }
+ chop( $sl );
+ $t .= $sl.$del.$3;
+ }
+ undef();
+}
+
+# makey - construct Perl y/// from sed y///
+#
+sub makey($$$){
+ my( $fr, $to, $fl ) = @_;
+ my $error = 0;
+
+ # Ensure that any '-' is up front.
+ # Diagnose duplicate contradicting mappings
+ my %tr;
+ for( my $i = 0; $i < length($fr); $i++ ){
+ my $fc = substr($fr,$i,1);
+ my $tc = substr($to,$i,1);
+ if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){
+ Warn( "ambiguous translation for character `$fc' in `y' command",
+ $fl );
+ $error++;
+ }
+ $tr{$fc} = $tc;
+ }
+ $fr = $to = '';
+ if( exists( $tr{'-'} ) ){
+ ( $fr, $to ) = ( '-', $tr{'-'} );
+ delete( $tr{'-'} );
+ } else {
+ $fr = $to = '';
+ }
+ # might just as well sort it...
+ for my $fc ( sort keys( %tr ) ){
+ $fr .= $fc;
+ $to .= $tr{$fc};
+ }
+ # make embedded delimiters and newlines safe
+ $fr =~ s/([{}])/\$1/g;
+ $to =~ s/([{}])/\$1/g;
+ $fr =~ s/\n/\\n/g;
+ $to =~ s/\n/\\n/g;
+ return $error ? undef() : "{ y{$fr}{$to}; }";
+}
+
+######
+# makes - construct Perl s/// from sed s///
+#
+sub makes($$$$$$$){
+ my( $regex, $subst, $path, $global, $print, $nmatch, $fl ) = @_;
+
+ # make embedded newlines safe
+ $regex =~ s/\n/\\n/g;
+ $subst =~ s/\n/\\n/g;
+
+ my $code;
+ # n-th occurrence
+ #
+ if( length( $nmatch ) ){
+ $code = <<TheEnd;
+{ \$n = $nmatch;
+ while( --\$n && ( \$s = m ${regex}g ) ){}
+ \$s = ( substr( \$_, pos() ) =~ s ${regex}${subst}s ) if \$s;
+ \$CondReg ||= \$s;
+TheEnd
+ } else {
+ $code = <<TheEnd;
+{ \$s = s ${regex}${subst}s${global};
+ \$CondReg ||= \$s;
+TheEnd
+ }
+ if( $print ){
+ $code .= ' print $_, "\n" if $s;'."\n";
+ }
+ if( defined( $path ) ){
+ $wFiles{$path} = '';
+ $code .= " _w( '$path' ) if \$s;\n";
+ $GenKey{'w'} = 1;
+ }
+ $code .= "}";
+}
+
+=head1 BASIC REGULAR EXPRESSIONS
+
+A I<Basic Regular Expression> (BRE), as defined in POSIX 1003.2, consists
+of I<atoms>, for matching parts of a string, and I<bounds>, specifying
+repetitions of a preceding atom.
+
+=head2 Atoms
+
+The possible atoms of a BRE are: B<.>, matching any single character;
+B<^> and B<$>, matching the null string at the beginning or end
+of a string, respectively; a I<bracket expressions>, enclosed
+in B<[> and B<]> (see below); and any single character with no
+other significance (matching that character). A B<\> before one
+of: B<.>, B<^>, B<$>, B<[>, B<*>, B<\>, matching the character
+after the backslash. A sequence of atoms enclosed in B<\(> and B<\)>
+becomes an atom and establishes the target for a I<backreference>,
+consisting of the substring that actually matches the enclosed atoms.
+Finally, B<\> followed by one of the digits B<0> through B<9> is a
+backreference.
+
+A B<^> that is not first, or a B<$> that is not last does not have
+a special significance and need not be preceded by a backslash to
+become literal. The same is true for a B<]>, that does not terminate
+a bracket expression.
+
+An unescaped backslash cannot be last in a BRE.
+
+=head2 Bounds
+
+The BRE bounds are: B<*>, specifying 0 or more matches of the preceding
+atom; B<\{>I<count>B<\}>, specifying that many repetitions;
+B<\{>I<minimum>B<,\}>, giving a lower limit; and
+B<\{>I<minimum>B<,>I<maximum>B<\}> finally defines a lower and upper
+bound.
+
+A bound appearing as the first item in a BRE is taken literally.
+
+=head2 Bracket Expressions
+
+A I<bracket expression> is a list of characters, character ranges
+and character classes enclosed in B<[> and B<]> and matches any
+single character from the represented set of characters.
+
+A character range is written as two characters separated by B<-> and
+represents all characters (according to the character collating sequence)
+that are not less than the first and not greater than the second.
+(Ranges are very collating-sequence-dependent, and portable programs
+should avoid relying on them.)
+
+A character class is one of the class names
+
+ alnum digit punct
+ alpha graph space
+ blank lower upper
+ cntrl print xdigit
+
+enclosed in B<[:> and B<:]> and represents the set of characters
+as defined in ctype(3).
+
+If the first character after B<[> is B<^>, the sense of matching is
+inverted.
+
+To include a literal `C<^>', place it anywhere else but first. To
+include a literal 'C<]>' place it first or immediately after an
+initial B<^>. To include a literal `C<->' make it the first (or
+second after B<^>) or last character, or the second endpoint of
+a range.
+
+The special bracket expression constructs C<[[:E<lt>:]]> and C<[[:E<gt>:]]>
+match the null string at the beginning and end of a word respectively.
+(Note that neither is identical to Perl's `\b' atom.)
+
+=head2 Additional Atoms
+
+Since some sed implementations provide additional regular expression
+atoms (not defined in POSIX 1003.2), B<psed> is capable of translating
+the following backslash escapes:
+
+=over 4
+
+=item B<\E<lt>> This is the same as C<[[:E<gt>:]]>.
+
+=item B<\E<gt>> This is the same as C<[[:E<lt>:]]>.
+
+=item B<\w> This is an abbreviation for C<[[:alnum:]_]>.
+
+=item B<\W> This is an abbreviation for C<[^[:alnum:]_]>.
+
+=item B<\y> Match the empty string at a word boundary.
+
+=item B<\B> Match the empty string between any two either word or non-word characters.
+
+=back
+
+To enable this feature, the environment variable PSEDEXTBRE must be set
+to a string containing the requested characters, e.g.:
+C<PSEDEXTBRE='E<lt>E<gt>wW'>.
+
+=cut
+
+#####
+# bre2p - convert BRE to Perl RE
+#
+sub peek(\$$){
+ my( $pref, $ic ) = @_;
+ $ic < length($$pref)-1 ? substr( $$pref, $ic+1, 1 ) : '';
+}
+
+sub bre2p($$$){
+ my( $del, $pat, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $pat = substr( $pat, 1, length($pat) - 2 );
+ my $res = '';
+ my $bracklev = 0;
+ my $backref = 0;
+ my $parlev = 0;
+ for( my $ic = 0; $ic < length( $pat ); $ic++ ){
+ my $c = substr( $pat, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($pat,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in pattern", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc eq $del ){ ## \<pattern del> => \<pattern del>
+ $res .= "\\$del";
+
+ } elsif( $nc =~ /([[.*\\n])/ ){
+ ## check for \-escaped magics and \n:
+ ## \[ \. \* \\ \n stay as they are
+ $res .= '\\'.$nc;
+
+ } elsif( $nc eq '(' ){ ## \( => (
+ $parlev++;
+ $res .= '(';
+
+ } elsif( $nc eq ')' ){ ## \) => )
+ $parlev--;
+ $backref++;
+ if( $parlev < 0 ){
+ Warn( "unmatched `\\)'", $fl );
+ return undef();
+ }
+ $res .= ')';
+
+ } elsif( $nc eq '{' ){ ## repetition factor \{<i>[,[<j>]]\}
+ my $endpos = index( $pat, '\\}', $ic );
+ if( $endpos < 0 ){
+ Warn( "unmatched `\\{'", $fl );
+ return undef();
+ }
+ my $rep = substr( $pat, $ic+1, $endpos-($ic+1) );
+ $ic = $endpos + 1;
+
+ if( $res =~ /^\^?$/ ){
+ $res .= "\\{$rep\}";
+ } elsif( $rep =~ /^(\d+)(,?)(\d*)?$/ ){
+ my $min = $1;
+ my $com = $2 || '';
+ my $max = $3;
+ if( length( $max ) ){
+ if( $max < $min ){
+ Warn( "maximum less than minimum in `\\{$rep\\}'",
+ $fl );
+ return undef();
+ }
+ } else {
+ $max = '';
+ }
+ # simplify some
+ if( $min == 0 && $max eq '1' ){
+ $res .= '?';
+ } elsif( $min == 1 && "$com$max" eq ',' ){
+ $res .= '+';
+ } elsif( $min == 0 && "$com$max" eq ',' ){
+ $res .= '*';
+ } else {
+ $res .= "{$min$com$max}";
+ }
+ } else {
+ Warn( "invalid repeat clause `\\{$rep\\}'", $fl );
+ return undef();
+ }
+
+ } elsif( $nc =~ /^[1-9]$/ ){
+ ## \1 .. \9 => \1 .. \9, but check for a following digit
+ if( $nc > $backref ){
+ Warn( "invalid backreference ($nc)", $fl );
+ return undef();
+ }
+ $res .= "\\$nc";
+ if( peek($pat,$ic) =~ /[0-9]/ ){
+ $res .= '(?:)';
+ }
+
+ } elsif( $useEXTBRE && ( $nc =~ /[$useEXTBRE]/ ) ){
+ ## extensions - at most <>wWyB - not in POSIX
+ if( $nc eq '<' ){ ## \< => \b(?=\w), be precise
+ $res .= '\\b(?<=\\W)';
+ } elsif( $nc eq '>' ){ ## \> => \b(?=\W), be precise
+ $res .= '\\b(?=\\W)';
+ } elsif( $nc eq 'y' ){ ## \y => \b
+ $res .= '\\b';
+ } else { ## \B, \w, \W remain the same
+ $res .= "\\$nc";
+ }
+ } elsif( $nc eq $led ){
+ ## \<closing bracketing-delimiter> - keep '\'
+ $res .= "\\$nc";
+
+ } else { ## \ <char> => <char> ("as if `\' were not present")
+ $res .= $nc;
+ }
+
+ } elsif( $c eq '.' ){ ## . => .
+ $res .= $c;
+
+ } elsif( $c eq '*' ){ ## * => * but \* if there's nothing preceding it
+ if( $res =~ /^\^?$/ ){
+ $res .= '\\*';
+ } elsif( substr( $res, -1, 1 ) ne '*' ){
+ $res .= $c;
+ }
+
+ } elsif( $c eq '[' ){
+ ## parse []: [^...] [^]...] [-...]
+ my $add = '[';
+ if( peek($pat,$ic) eq '^' ){
+ $ic++;
+ $add .= '^';
+ }
+ my $nc = peek($pat,$ic);
+ if( $nc eq ']' || $nc eq '-' ){
+ $add .= $nc;
+ $ic++;
+ }
+ # check that [ is not trailing
+ if( $ic >= length( $pat ) - 1 ){
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+ # look for [:...:] and x-y
+ my $rstr = substr( $pat, $ic+1 );
+ if( $rstr =~ /^((?:\[:\(\w+|[><]\):\]|[^]-](?:-[^]])?)*)/ ){
+ my $cnt = $1;
+ $ic += length( $cnt );
+ $cnt =~ s/([\\\$])/\\$1/g; # `\', `$' are magic in Perl []
+ # try some simplifications
+ my $red = $cnt;
+ if( $red =~ s/0-9// ){
+ $cnt = $red.'\d';
+ if( $red =~ s/A-Z// && $red =~ s/a-z// && $red =~ s/_// ){
+ $cnt = $red.'\w';
+ }
+ }
+ $add .= $cnt;
+
+ # POSIX 1003.2 has this (optional) for begin/end word
+ $add = '\\b(?=\\W)' if $add eq '[[:<:]]';
+ $add = '\\b(?<=\\W)' if $add eq '[[:>:]]';
+
+ }
+
+ ## may have a trailing `-' before `]'
+ if( $ic < length($pat) - 1 &&
+ substr( $pat, $ic+1 ) =~ /^(-?])/ ){
+ $ic += length( $1 );
+ $add .= $1;
+ # another simplification
+ $add =~ s/^\[(\^?)(\\[dw])]$/ $1 eq '^' ? uc($2) : $2 /e;
+ $res .= $add;
+ } else {
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+
+ } elsif( $c eq $led ){ ## unescaped <closing bracketing-delimiter>
+ $res .= "\\$c";
+
+ } elsif( $c eq ']' ){ ## unmatched ] is not magic
+ $res .= ']';
+
+ } elsif( $c =~ /[|+?{}()]/ ){ ## not magic in BRE, but in Perl: \-quote
+ $res .= "\\$c";
+
+ } elsif( $c eq '^' ){ ## not magic unless 1st, but in Perl: \-quote
+ $res .= length( $res ) ? '\\^' : '^';
+
+ } elsif( $c eq '$' ){ ## not magic unless last, but in Perl: \-quote
+ $res .= $ic == length( $pat ) - 1 ? '$' : '\\$';
+
+ } else {
+ $res .= $c;
+ }
+ }
+
+ if( $parlev ){
+ Warn( "unmatched `\\('", $fl );
+ return undef();
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return $del . $res . ( $led ? $led : $del );
+}
+
+
+#####
+# sub2p - convert sed substitution to Perl substitution
+#
+sub sub2p($$$){
+ my( $del, $subst, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $subst = substr( $subst, 1, length($subst) - 2 );
+ my $res = '';
+
+ for( my $ic = 0; $ic < length( $subst ); $ic++ ){
+ my $c = substr( $subst, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($subst,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in substitution", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc =~ /[\\$del$led]/ ){ ## \ and delimiter
+ $res .= '\\' . $nc;
+ } elsif( $nc =~ /[1-9]/ ){ ## \1 - \9 => ${1} - ${9}
+ $res .= '${' . $nc . '}';
+ } else { ## everything else (includes &): omit \
+ $res .= $nc;
+ }
+ } elsif( $c eq '&' ){ ## & => $&
+ $res .= '$&';
+ } elsif( $c =~ /[\$\@$led]/ ){ ## magic in Perl's substitution string
+ $res .= '\\' . $c;
+ } else {
+ $res .= $c;
+ }
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return ( $led ? $del : $led ) . $res . ( $led ? $led : $del );
+}
+
+
+sub Parse(){
+ my $error = 0;
+ my( $pdef, $pfil, $plin );
+ for( my $icom = 0; $icom < @Commands; $icom++ ){
+ my $cmd = $Commands[$icom];
+ print "Parse:$cmd:\n" if $useDEBUG;
+ $cmd =~ s/^\s+//;
+ next unless length( $cmd );
+ my $scom = $icom;
+ if( exists( $Defined{$icom} ) ){
+ $pdef = $Defined{$icom};
+ if( $pdef =~ /^ #(\d+)/ ){
+ $pfil = 'expression #';
+ $plin = $1;
+ } else {
+ $pfil = "$pdef l.";
+ $plin = 1;
+ }
+ } else {
+ $plin++;
+ }
+ my $fl = "$pfil$plin";
+
+ # insert command as comment in gnerated code
+ #
+ $Code .= "# $cmd\n" if $doGenerate;
+
+ # The Address(es)
+ #
+ my( $negated, $naddr, $addr1, $addr2 );
+ $naddr = 0;
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr1 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr1 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr1 = 'm '.bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 1st address", $fl );
+ $error++;
+ next;
+ }
+ }
+ if( defined( $addr1 ) && $cmd =~ s/,\s*// ){
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr2 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr2 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr2 = 'm '. bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 2nd address", $fl );
+ $error++;
+ next;
+ }
+ } else {
+ Warn( "invalid address after `,'", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # address modifier `!'
+ #
+ $negated = $cmd =~ s/^!\s*//;
+ if( defined( $addr1 ) ){
+ print "Parse: addr1=$addr1" if $useDEBUG;
+ if( defined( $addr2 ) ){
+ print ", addr2=$addr2 " if $useDEBUG;
+ # both numeric and addr1 > addr2 => eliminate addr2
+ undef( $addr2 ) if $addr1 =~ /^\d+$/ &&
+ $addr2 =~ /^\d+$/ && $addr1 > $addr2;
+ }
+ }
+ print 'negated' if $useDEBUG && $negated;
+ print " command:$cmd\n" if $useDEBUG;
+
+ # The Command
+ #
+ if( $cmd !~ s/^([:#={}abcdDgGhHilnNpPqrstwxy])\s*// ){
+ my $h = substr( $cmd, 0, 1 );
+ Warn( "unknown command `$h'", $fl );
+ $error++;
+ next;
+ }
+ my $key = $1;
+
+ my $tabref = $ComTab{$key};
+ $GenKey{$key} = 1;
+ if( $naddr > $tabref->[0] ){
+ Warn( "excess address(es)", $fl );
+ $error++;
+ next;
+ }
+
+ my $arg = '';
+ if( $tabref->[1] eq 'str' ){
+ # take remainder - don't care if it is empty
+ $arg = $cmd;
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'txt' ){
+ # multi-line text
+ my $goon = $cmd =~ /(.*)\\$/;
+ if( length( $1 ) ){
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ }
+ while( $goon ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd = $Commands[$icom];
+ $Code .= "# $cmd\n" if $doGenerate;
+ $goon = $cmd =~ s/\\$//;
+ $cmd =~ s/\\(.)/$1/g;
+ $arg .= "\n" if length( $arg );
+ $arg .= $cmd;
+ }
+ $arg .= "\n" if length( $arg );
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'sub' ){
+ # s///
+ if( ! length( $cmd ) ){
+ Warn( "`s' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ if( $cmd =~ s{^([^\\\n])}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd, "s" );
+ if( ! defined( $regex ) ){
+ Warn( "malformed regular expression", $fl );
+ $error++;
+ next;
+ }
+ $regex = bre2p( $del, $regex, $fl );
+
+ # a trailing \ indicates embedded NL (in replacement string)
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+
+ my $subst = stripRegex( $del, \$cmd );
+ if( ! defined( $regex ) ){
+ Warn( "malformed substitution expression", $fl );
+ $error++;
+ next;
+ }
+ $subst = sub2p( $del, $subst, $fl );
+
+ # parse s/// modifier: g|p|0-9|w <file>
+ my( $global, $nmatch, $print, $write ) =
+ ( '', '', 0, undef );
+ while( $cmd =~ s/^([gp0-9])// ){
+ $1 eq 'g' ? ( $global = 'g' ) :
+ $1 eq 'p' ? ( $print = $1 ) : ( $nmatch .= $1 );
+ }
+ $write = $1 if $cmd =~ s/w\s*(.*)$//;
+ ### $nmatch =~ s/^(\d)\1*$/$1/; ### may be dangerous?
+ if( $global && length( $nmatch ) || length( $nmatch ) > 1 ){
+ Warn( "conflicting flags `$global$nmatch'", $fl );
+ $error++;
+ next;
+ }
+
+ $arg = makes( $regex, $subst,
+ $write, $global, $print, $nmatch, $fl );
+ if( ! defined( $arg ) ){
+ $error++;
+ next;
+ }
+
+ } else {
+ Warn( "improper delimiter in s command", $fl );
+ $error++;
+ next;
+ }
+
+ } elsif( $tabref->[1] eq 'tra' ){
+ # y///
+ # a trailing \ indicates embedded newline
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+ if( ! length( $cmd ) ){
+ Warn( "`y' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ my $d = substr( $cmd, 0, 1 ); $cmd = substr( $cmd, 1 );
+ if( $d eq '\\' ){
+ Warn( "`\\' not valid as delimiter in `y' command", $fl );
+ $error++;
+ next;
+ }
+ my $fr = stripTrans( $d, \$cmd );
+ if( ! defined( $fr ) || ! length( $cmd ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ my $to = stripTrans( $d, \$cmd );
+ if( ! defined( $to ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ if( length($fr) != length($to) ){
+ Warn( "string lengths in `y' command differ", $fl );
+ $error++;
+ next;
+ }
+ if( ! defined( $arg = makey( $fr, $to, $fl ) ) ){
+ $error++;
+ next;
+ }
+
+ }
+
+ # $cmd must be now empty - exception is {
+ if( $cmd !~ /^\s*$/ ){
+ if( $key eq '{' ){
+ # dirty hack to process command on '{' line
+ $Commands[$icom--] = $cmd;
+ } else {
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # Make Code
+ #
+ if( &{$tabref->[2]}( $addr1, $addr2, $negated,
+ $tabref->[3], $arg, $fl ) ){
+ $error++;
+ }
+ }
+
+ while( @BlockStack ){
+ my $bl = pop( @BlockStack );
+ Warn( "start of unterminated `{'", $bl );
+ $error++;
+ }
+
+ for my $lab ( keys( %Label ) ){
+ if( ! exists( $Label{$lab}{defined} ) ){
+ for my $used ( @{$Label{$lab}{used}} ){
+ Warn( "undefined label `$lab'", $used );
+ $error++;
+ }
+ }
+ }
+
+ exit( 1 ) if $error;
+}
+
+
+##############
+#### MAIN ####
+##############
+
+sub usage(){
+ print STDERR "Usage: sed [-an] command [file...]\n";
+ print STDERR " [-an] [-e command] [-f script-file] [file...]\n";
+}
+
+###################
+# Here we go again...
+#
+my $expr = 0;
+while( @ARGV && $ARGV[0] =~ /^-(.)(.*)$/ ){
+ my $opt = $1;
+ my $arg = $2;
+ shift( @ARGV );
+ if( $opt eq 'e' ){
+ if( length( $arg ) ){
+ push( @Commands, split( "\n", $arg ) );
+ } elsif( @ARGV ){
+ push( @Commands, shift( @ARGV ) );
+ } else {
+ Warn( "option -e requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ $expr++;
+ $Defined{$#Commands} = " #$expr";
+ next;
+ }
+ if( $opt eq 'f' ){
+ my $path;
+ if( length( $arg ) ){
+ $path = $arg;
+ } elsif( @ARGV ){
+ $path = shift( @ARGV );
+ } else {
+ Warn( "option -f requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ my $fst = $#Commands + 1;
+ open( SCRIPT, "<$path" ) || die( "$0: $path: could not open ($!)\n" );
+ my $cmd;
+ while( defined( $cmd = <SCRIPT> ) ){
+ chomp( $cmd );
+ push( @Commands, $cmd );
+ }
+ close( SCRIPT );
+ if( $#Commands >= $fst ){
+ $Defined{$fst} = "$path";
+ }
+ next;
+ }
+ if( $opt eq '-' && $arg eq '' ){
+ last;
+ }
+ if( $opt eq 'h' || $opt eq '?' ){
+ usage();
+ exit( 0 );
+ }
+ if( $opt eq 'n' ){
+ $doAutoPrint = 0;
+ } elsif( $opt eq 'a' ){
+ $doOpenWrite = 0;
+ } else {
+ Warn( "illegal option `$opt'" );
+ usage();
+ exit( 1 );
+ }
+ if( length( $arg ) ){
+ unshift( @ARGV, "-$arg" );
+ }
+}
+
+# A singleton command may be the 1st argument when there are no options.
+#
+if( @Commands == 0 ){
+ if( @ARGV == 0 ){
+ Warn( "no script command given" );
+ usage();
+ exit( 1 );
+ }
+ push( @Commands, split( "\n", shift( @ARGV ) ) );
+ $Defined{0} = ' #1';
+}
+
+print STDERR "Files: @ARGV\n" if $useDEBUG;
+
+# generate leading code
+#
+$Func = <<'[TheEnd]';
+
+# openARGV: open 1st input file
+#
+sub openARGV(){
+ unshift( @ARGV, '-' ) unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+}
+
+# getsARGV: Read another input line into argument (default: $_).
+# Move on to next input file, and reset EOF flag $isEOF.
+sub getsARGV(;\$){
+ my $argref = @_ ? shift() : \$_;
+ while( $isEOF || ! defined( $$argref = <ARG> ) ){
+ close( ARG );
+ return 0 unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+ }
+ 1;
+}
+
+# eofARGV: end-of-file test
+#
+sub eofARGV(){
+ return @ARGV == 0 && ( $isEOF = eof( ARG ) );
+}
+
+# makeHandle: Generates another file handle for some file (given by its path)
+# to be written due to a w command or an s command's w flag.
+sub makeHandle($){
+ my( $path ) = @_;
+ my $handle;
+ if( ! exists( $wFiles{$path} ) || $wFiles{$path} eq '' ){
+ $handle = $wFiles{$path} = gensym();
+ if( $doOpenWrite ){
+ if( ! open( $handle, ">$path" ) ){
+ die( "$0: can't open $path for writing: ($!)\n" );
+ }
+ }
+ } else {
+ $handle = $wFiles{$path};
+ }
+ return $handle;
+}
+
+# printQ: Print queued output which is either a string or a reference
+# to a pathname.
+sub printQ(){
+ for my $q ( @Q ){
+ if( ref( $q ) ){
+ # flush open w files so that reading this file gets it all
+ if( exists( $wFiles{$$q} ) && $wFiles{$$q} ne '' ){
+ open( $wFiles{$$q}, ">>$$q" );
+ }
+ # copy file to stdout: slow, but safe
+ if( open( RF, "<$$q" ) ){
+ while( defined( my $line = <RF> ) ){
+ print $line;
+ }
+ close( RF );
+ }
+ } else {
+ print $q;
+ }
+ }
+ undef( @Q );
+}
+
+[TheEnd]
+
+# generate the sed loop
+#
+$Code .= <<'[TheEnd]';
+sub openARGV();
+sub getsARGV(;\$);
+sub eofARGV();
+sub printQ();
+
+# Run: the sed loop reading input and applying the script
+#
+sub Run(){
+ my( $h, $icnt, $s, $n );
+ # hack (not unbreakable :-/) to avoid // matching an empty string
+ my $z = "\000"; $z =~ /$z/;
+ # Initialize.
+ openARGV();
+ $Hold = '';
+ $CondReg = 0;
+ $doPrint = $doAutoPrint;
+CYCLE:
+ while( getsARGV() ){
+ chomp();
+ $CondReg = 0; # cleared on t
+BOS:;
+[TheEnd]
+
+ # parse - avoid opening files when doing s2p
+ #
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+ Parse();
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+
+ # append trailing code
+ #
+ $Code .= <<'[TheEnd]';
+EOS: if( $doPrint ){
+ print $_, "\n";
+ } else {
+ $doPrint = $doAutoPrint;
+ }
+ printQ() if @Q;
+ }
+
+ exit( 0 );
+}
+[TheEnd]
+
+
+# append optional functions, prepend prototypes
+#
+my $Proto = "# prototypes\n";
+if( $GenKey{'l'} ){
+ $Proto .= "sub _l();\n";
+ $Func .= <<'[TheEnd]';
+# _l: l command processing
+#
+sub _l(){
+ my $h = $_;
+ my $mcpl = 70;
+ # transform non printing chars into escape notation
+ $h =~ s/\\/\\\\/g;
+ if( $h =~ /[^[:print:]]/ ){
+ $h =~ s/\a/\\a/g;
+ $h =~ s/\f/\\f/g;
+ $h =~ s/\n/\\n/g;
+ $h =~ s/\t/\\t/g;
+ $h =~ s/\r/\\r/g;
+ $h =~ s/\e/\\e/g;
+ $h =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge;
+ }
+ # split into lines of length $mcpl
+ while( length( $h ) > $mcpl ){
+ my $l = substr( $h, 0, $mcpl-1 );
+ $h = substr( $h, $mcpl );
+ # remove incomplete \-escape from end of line
+ if( $l =~ s/(?<!\\)(\\[0-7]{0,2})$// ){
+ $h = $1 . $h;
+ }
+ print $l, "\\\n";
+ }
+ print "$h\$\n";
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'r'} ){
+ $Proto .= "sub _r(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _r: r command processing: Save a reference to the pathname.
+#
+sub _r($){
+ my $path = shift();
+ push( @Q, \$path );
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'t'} ){
+ $Proto .= "sub _t();\n";
+ $Func .= <<'[TheEnd]';
+# _t: t command - condition register test/reset
+#
+sub _t(){
+ my $res = $CondReg;
+ $CondReg = 0;
+ $res;
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'w'} ){
+ $Proto .= "sub _w(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _w: w command and s command's w flag - write to file
+#
+sub _w($){
+ my $path = shift();
+ my $handle = $wFiles{$path};
+ if( ! $doOpenWrite && ! defined( fileno( $handle ) ) ){
+ open( $handle, ">$path" )
+ || die( "$0: $path: cannot open ($!)\n" );
+ }
+ print $handle $_, "\n";
+}
+
+[TheEnd]
+}
+
+$Code = $Proto . $Code;
+
+# magic "#n" - same as -n option
+#
+$doAutoPrint = 0 if substr( $Commands[0], 0, 2 ) eq '#n';
+
+# eval code - check for errors
+#
+print "Code:\n$Code$Func" if $useDEBUG;
+eval $Code . $Func;
+if( $@ ){
+ print "Code:\n$Code$Func";
+ die( "$0: internal error - generated incorrect Perl code: $@\n" );
+}
+
+if( $doGenerate ){
+
+ # write full Perl program
+ #
+
+ # bang line, declarations, prototypes
+ print <<TheEnd;
+#!$perlpath -w
+eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if 0;
+\$0 =~ s/^.*?(\\w+)\[\\.\\w+\]*\$/\$1/;
+
+use strict;
+use Symbol;
+use vars qw{ \$isEOF \$Hold \%wFiles \@Q \$CondReg
+ \$doAutoPrint \$doOpenWrite \$doPrint };
+\$doAutoPrint = $doAutoPrint;
+\$doOpenWrite = $doOpenWrite;
+TheEnd
+
+ my $wf = "'" . join( "', '", keys( %wFiles ) ) . "'";
+ if( $wf ne "''" ){
+ print <<TheEnd;
+sub makeHandle(\$);
+for my \$p ( $wf ){
+ exit( 1 ) unless makeHandle( \$p );
+}
+TheEnd
+ }
+
+ print $Code;
+ print "Run();\n";
+ print $Func;
+ exit( 0 );
+
+} else {
+
+ # execute: make handles (and optionally open) all w files; run!
+ for my $p ( keys( %wFiles ) ){
+ exit( 1 ) unless makeHandle( $p );
+ }
+ Run();
+}
+
+
+=head1 ENVIRONMENT
+
+The environment variable C<PSEDEXTBRE> may be set to extend BREs.
+See L<"Additional Atoms">.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item ambiguous translation for character `%s' in `y' command
+
+The indicated character appears twice, with different translations.
+
+=item `[' cannot be last in pattern
+
+A `[' in a BRE indicates the beginning of a I<bracket expression>.
+
+=item `\' cannot be last in pattern
+
+A `\' in a BRE is used to make the subsequent character literal.
+
+=item `\' cannot be last in substitution
+
+A `\' in a subsitution string is used to make the subsequent character literal.
+
+=item conflicting flags `%s'
+
+In an B<s> command, either the `g' flag and an n-th occurrence flag, or
+multiple n-th occurrence flags are specified. Note that only the digits
+`1' through `9' are permitted.
+
+=item duplicate label %s (first defined at %s)
+
+=item excess address(es)
+
+The command has more than the permitted number of addresses.
+
+=item extra characters after command (%s)
+
+=item illegal option `%s'
+
+=item improper delimiter in s command
+
+The BRE and substitution may not be delimited with `\' or newline.
+
+=item invalid address after `,'
+
+=item invalid backreference (%s)
+
+The specified backreference number exceeds the number of backreferences
+in the BRE.
+
+=item invalid repeat clause `\{%s\}'
+
+The repeat clause does not contain a valid integer value, or pair of
+values.
+
+=item malformed regex, 1st address
+
+=item malformed regex, 2nd address
+
+=item malformed regular expression
+
+=item malformed substitution expression
+
+=item malformed `y' command argument
+
+The first or second string of a B<y> command is syntactically incorrect.
+
+=item maximum less than minimum in `\{%s\}'
+
+=item no script command given
+
+There must be at least one B<-e> or one B<-f> option specifying a
+script or script file.
+
+=item `\' not valid as delimiter in `y' command
+
+=item option -e requires an argument
+
+=item option -f requires an argument
+
+=item `s' command requires argument
+
+=item start of unterminated `{'
+
+=item string lengths in `y' command differ
+
+The translation table strings in a B<y> command must have equal lengths.
+
+=item undefined label `%s'
+
+=item unexpected `}'
+
+A B<}> command without a preceding B<{> command was encountered.
+
+=item unexpected end of script
+
+The end of the script was reached although a text line after a
+B<a>, B<c> or B<i> command indicated another line.
+
+=item unknown command `%s'
+
+=item unterminated `['
+
+A BRE contains an unterminated bracket expression.
+
+=item unterminated `\('
+
+A BRE contains an unterminated backreference.
+
+=item `\{' without closing `\}'
+
+A BRE contains an unterminated bounds specification.
+
+=item `\)' without preceding `\('
+
+=item `y' command requires argument
+
+=back
+
+=head1 EXAMPLE
+
+The basic material for the preceding section was generated by running
+the sed script
+
+ #no autoprint
+ s/^.*Warn( *"\([^"]*\)".*$/\1/
+ t process
+ b
+ :process
+ s/$!/%s/g
+ s/$[_[:alnum:]]\{1,\}/%s/g
+ s/\\\\/\\/g
+ s/^/=item /
+ p
+
+on the program's own text, and piping the output into C<sort -u>.
+
+
+=head1 SED SCRIPT TRANSLATION
+
+If this program is invoked with the name F<s2p> it will act as a
+sed-to-Perl translator. After option processing (all other
+arguments are ignored), a Perl program is printed on standard
+output, which will process the input stream (as read from all
+arguments) in the way defined by the sed script and the option setting
+used for the translation.
+
+=head1 SEE ALSO
+
+perl(1), re_format(7)
+
+=head1 BUGS
+
+The B<l> command will show escape characters (ESC) as `C<\e>', but
+a vertical tab (VT) in octal.
+
+Trailing spaces are truncated from labels in B<:>, B<t> and B<b> commands.
+
+The meaning of an empty regular expression (`C<//>'), as defined by B<sed>,
+is "the last pattern used, at run time". This deviates from the Perl
+interpretation, which will re-use the "last last successfully executed
+regular expression". Since keeping track of pattern usage would create
+terribly cluttered code, and differences would only appear in obscure
+context (where other B<sed> implementations appear to deviate, too),
+the Perl semantics was adopted. Note that common usage of this feature,
+such as in C</abc/s//xyz/>, will work as expected.
+
+Collating elements (of bracket expressions in BREs) are not implemented.
+
+=head1 STANDARDS
+
+This B<sed> implementation conforms to the IEEE Std1003.2-1992 ("POSIX.2")
+definition of B<sed>, and is compatible with the I<OpenBSD>
+implementation, except where otherwise noted (see L<"BUGS">).
+
+=head1 AUTHOR
+
+This Perl implementation of I<sed> was written by Wolfgang Laun,
+I<Wolfgang.Laun@alcatel.at>.
+
+=head1 COPYRIGHT and LICENSE
+
+This program is free and open software. You may use, modify,
+distribute, and sell this program (and any modified variants) in any
+way you wish, provided you do not restrict others from doing the same.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pstruct.bat b/Master/tlpkg/tlperl.straw/bin/pstruct.bat
new file mode 100755
index 00000000000..84937d17f3c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pstruct.bat
@@ -0,0 +1,1383 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+#
+#
+# c2ph (aka pstruct)
+# Tom Christiansen, <tchrist@convex.com>
+#
+# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+# As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+# See the usage message for more. If this isn't enough, read the code.
+#
+
+=head1 NAME
+
+c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
+
+=head1 SYNOPSIS
+
+ c2ph [-dpnP] [var=val] [files ...]
+
+=head2 OPTIONS
+
+ Options:
+
+ -w wide; short for: type_width=45 member_width=35 offset_width=8
+ -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+ -n do not generate perl code (default when invoked as pstruct)
+ -p generate perl code (default when invoked as c2ph)
+ -v generate perl code, with C decls as comments
+
+ -i do NOT recompute sizes for intrinsic datatypes
+ -a dump information on intrinsics also
+
+ -t trace execution
+ -d spew reams of debugging output
+
+ -slist give comma-separated list a structures to dump
+
+=head1 DESCRIPTION
+
+The following is the old c2ph.doc documentation by Tom Christiansen
+<tchrist@perl.com>
+Date: 25 Jul 91 08:10:21 GMT
+
+Once upon a time, I wrote a program called pstruct. It was a perl
+program that tried to parse out C structures and display their member
+offsets for you. This was especially useful for people looking at
+binary dumps or poking around the kernel.
+
+Pstruct was not a pretty program. Neither was it particularly robust.
+The problem, you see, was that the C compiler was much better at parsing
+C than I could ever hope to be.
+
+So I got smart: I decided to be lazy and let the C compiler parse the C,
+which would spit out debugger stabs for me to read. These were much
+easier to parse. It's still not a pretty program, but at least it's more
+robust.
+
+Pstruct takes any .c or .h files, or preferably .s ones, since that's
+the format it is going to massage them into anyway, and spits out
+listings like this:
+
+ struct tty {
+ int tty.t_locker 000 4
+ int tty.t_mutex_index 004 4
+ struct tty * tty.t_tp_virt 008 4
+ struct clist tty.t_rawq 00c 20
+ int tty.t_rawq.c_cc 00c 4
+ int tty.t_rawq.c_cmax 010 4
+ int tty.t_rawq.c_cfx 014 4
+ int tty.t_rawq.c_clx 018 4
+ struct tty * tty.t_rawq.c_tp_cpu 01c 4
+ struct tty * tty.t_rawq.c_tp_iop 020 4
+ unsigned char * tty.t_rawq.c_buf_cpu 024 4
+ unsigned char * tty.t_rawq.c_buf_iop 028 4
+ struct clist tty.t_canq 02c 20
+ int tty.t_canq.c_cc 02c 4
+ int tty.t_canq.c_cmax 030 4
+ int tty.t_canq.c_cfx 034 4
+ int tty.t_canq.c_clx 038 4
+ struct tty * tty.t_canq.c_tp_cpu 03c 4
+ struct tty * tty.t_canq.c_tp_iop 040 4
+ unsigned char * tty.t_canq.c_buf_cpu 044 4
+ unsigned char * tty.t_canq.c_buf_iop 048 4
+ struct clist tty.t_outq 04c 20
+ int tty.t_outq.c_cc 04c 4
+ int tty.t_outq.c_cmax 050 4
+ int tty.t_outq.c_cfx 054 4
+ int tty.t_outq.c_clx 058 4
+ struct tty * tty.t_outq.c_tp_cpu 05c 4
+ struct tty * tty.t_outq.c_tp_iop 060 4
+ unsigned char * tty.t_outq.c_buf_cpu 064 4
+ unsigned char * tty.t_outq.c_buf_iop 068 4
+ (*int)() tty.t_oproc_cpu 06c 4
+ (*int)() tty.t_oproc_iop 070 4
+ (*int)() tty.t_stopproc_cpu 074 4
+ (*int)() tty.t_stopproc_iop 078 4
+ struct thread * tty.t_rsel 07c 4
+
+etc.
+
+
+Actually, this was generated by a particular set of options. You can control
+the formatting of each column, whether you prefer wide or fat, hex or decimal,
+leading zeroes or whatever.
+
+All you need to be able to use this is a C compiler than generates
+BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
+should get this for you.
+
+To learn more, just type a bogus option, like B<-\?>, and a long usage message
+will be provided. There are a fair number of possibilities.
+
+If you're only a C programmer, than this is the end of the message for you.
+You can quit right now, and if you care to, save off the source and run it
+when you feel like it. Or not.
+
+
+
+But if you're a perl programmer, then for you I have something much more
+wondrous than just a structure offset printer.
+
+You see, if you call pstruct by its other incybernation, c2ph, you have a code
+generator that translates C code into perl code! Well, structure and union
+declarations at least, but that's quite a bit.
+
+Prior to this point, anyone programming in perl who wanted to interact
+with C programs, like the kernel, was forced to guess the layouts of
+the C structures, and then hardwire these into his program. Of course,
+when you took your wonderfully crafted program to a system where the
+sgtty structure was laid out differently, your program broke. Which is
+a shame.
+
+We've had Larry's h2ph translator, which helped, but that only works on
+cpp symbols, not real C, which was also very much needed. What I offer
+you is a symbolic way of getting at all the C structures. I've couched
+them in terms of packages and functions. Consider the following program:
+
+ #!/usr/local/bin/perl
+
+ require 'syscall.ph';
+ require 'sys/time.ph';
+ require 'sys/resource.ph';
+
+ $ru = "\0" x &rusage'sizeof();
+
+ syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
+
+ @ru = unpack($t = &rusage'typedef(), $ru);
+
+ $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
+
+ $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
+
+ printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
+
+
+As you see, the name of the package is the name of the structure. Regular
+fields are just their own names. Plus the following accessor functions are
+provided for your convenience:
+
+ struct This takes no arguments, and is merely the number of first-level
+ elements in the structure. You would use this for indexing
+ into arrays of structures, perhaps like this
+
+
+ $usec = $u[ &user'u_utimer
+ + (&ITIMER_VIRTUAL * &itimerval'struct)
+ + &itimerval'it_value
+ + &timeval'tv_usec
+ ];
+
+ sizeof Returns the bytes in the structure, or the member if
+ you pass it an argument, such as
+
+ &rusage'sizeof(&rusage'ru_utime)
+
+ typedef This is the perl format definition for passing to pack and
+ unpack. If you ask for the typedef of a nothing, you get
+ the whole structure, otherwise you get that of the member
+ you ask for. Padding is taken care of, as is the magic to
+ guarantee that a union is unpacked into all its aliases.
+ Bitfields are not quite yet supported however.
+
+ offsetof This function is the byte offset into the array of that
+ member. You may wish to use this for indexing directly
+ into the packed structure with vec() if you're too lazy
+ to unpack it.
+
+ typeof Not to be confused with the typedef accessor function, this
+ one returns the C type of that field. This would allow
+ you to print out a nice structured pretty print of some
+ structure without knoning anything about it beforehand.
+ No args to this one is a noop. Someday I'll post such
+ a thing to dump out your u structure for you.
+
+
+The way I see this being used is like basically this:
+
+ % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
+ % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
+ % install
+
+It's a little tricker with c2ph because you have to get the includes right.
+I can't know this for your system, but it's not usually too terribly difficult.
+
+The code isn't pretty as I mentioned -- I never thought it would be a 1000-
+line program when I started, or I might not have begun. :-) But I would have
+been less cavalier in how the parts of the program communicated with each
+other, etc. It might also have helped if I didn't have to divine the makeup
+of the stabs on the fly, and then account for micro differences between my
+compiler and gcc.
+
+Anyway, here it is. Should run on perl v4 or greater. Maybe less.
+
+
+ --tom
+
+=cut
+
+$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
+
+use File::Temp;
+
+######################################################################
+
+# some handy data definitions. many of these can be reset later.
+
+$bitorder = 'b'; # ascending; set to B for descending bit fields
+
+%intrinsics =
+%template = (
+ 'char', 'c',
+ 'unsigned char', 'C',
+ 'short', 's',
+ 'short int', 's',
+ 'unsigned short', 'S',
+ 'unsigned short int', 'S',
+ 'short unsigned int', 'S',
+ 'int', 'i',
+ 'unsigned int', 'I',
+ 'long', 'l',
+ 'long int', 'l',
+ 'unsigned long', 'L',
+ 'unsigned long', 'L',
+ 'long unsigned int', 'L',
+ 'unsigned long int', 'L',
+ 'long long', 'q',
+ 'long long int', 'q',
+ 'unsigned long long', 'Q',
+ 'unsigned long long int', 'Q',
+ 'float', 'f',
+ 'double', 'd',
+ 'pointer', 'p',
+ 'null', 'x',
+ 'neganull', 'X',
+ 'bit', $bitorder,
+);
+
+&buildscrunchlist;
+delete $intrinsics{'neganull'};
+delete $intrinsics{'bit'};
+delete $intrinsics{'null'};
+
+# use -s to recompute sizes
+%sizeof = (
+ 'char', '1',
+ 'unsigned char', '1',
+ 'short', '2',
+ 'short int', '2',
+ 'unsigned short', '2',
+ 'unsigned short int', '2',
+ 'short unsigned int', '2',
+ 'int', '4',
+ 'unsigned int', '4',
+ 'long', '4',
+ 'long int', '4',
+ 'unsigned long', '4',
+ 'unsigned long int', '4',
+ 'long unsigned int', '4',
+ 'long long', '8',
+ 'long long int', '8',
+ 'unsigned long long', '8',
+ 'unsigned long long int', '8',
+ 'float', '4',
+ 'double', '8',
+ 'pointer', '4',
+);
+
+($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
+
+($offset_fmt, $size_fmt) = ('d', 'd');
+
+$indent = 2;
+
+$CC = 'cc';
+$CFLAGS = '-gstabs -S';
+$DEFINES = '';
+
+$perl++ if $0 =~ m#/?c2ph$#;
+
+require 'getopts.pl';
+
+use File::Temp 'tempdir';
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+&Getopts('aixdpvtnws:') || &usage(0);
+
+$opt_d && $debug++;
+$opt_t && $trace++;
+$opt_p && $perl++;
+$opt_v && $verbose++;
+$opt_n && ($perl = 0);
+
+if ($opt_w) {
+ ($type_width, $member_width, $offset_width) = (45, 35, 8);
+}
+if ($opt_x) {
+ ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
+}
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+sub PLUMBER {
+ select(STDERR);
+ print "oops, apperent pager foulup\n";
+ $isatty++;
+ &usage(1);
+}
+
+sub usage {
+ local($oops) = @_;
+ unless (-t STDOUT) {
+ select(STDERR);
+ } elsif (!$oops) {
+ $isatty++;
+ $| = 1;
+ print "hit <RETURN> for further explanation: ";
+ <STDIN>;
+ open (PIPE, "|". ($ENV{PAGER} || 'more'));
+ $SIG{PIPE} = PLUMBER;
+ select(PIPE);
+ }
+
+ print "usage: $0 [-dpnP] [var=val] [files ...]\n";
+
+ exit unless $isatty;
+
+ print <<EOF;
+
+Options:
+
+-w wide; short for: type_width=45 member_width=35 offset_width=8
+-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+-n do not generate perl code (default when invoked as pstruct)
+-p generate perl code (default when invoked as c2ph)
+-v generate perl code, with C decls as comments
+
+-i do NOT recompute sizes for intrinsic datatypes
+-a dump information on intrinsics also
+
+-t trace execution
+-d spew reams of debugging output
+
+-slist give comma-separated list a structures to dump
+
+
+Var Name Default Value Meaning
+
+EOF
+
+ &defvar('CC', 'which_compiler to call');
+ &defvar('CFLAGS', 'how to generate *.s files with stabs');
+ &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
+
+ print "\n";
+
+ &defvar('type_width', 'width of type field (column 1)');
+ &defvar('member_width', 'width of member field (column 2)');
+ &defvar('offset_width', 'width of offset field (column 3)');
+ &defvar('size_width', 'width of size field (column 4)');
+
+ print "\n";
+
+ &defvar('offset_fmt', 'sprintf format type for offset');
+ &defvar('size_fmt', 'sprintf format type for size');
+
+ print "\n";
+
+ &defvar('indent', 'how far to indent each nesting level');
+
+ print <<'EOF';
+
+ If any *.[ch] files are given, these will be catted together into
+ a temporary *.c file and sent through:
+ $CC $CFLAGS $DEFINES
+ and the resulting *.s groped for stab information. If no files are
+ supplied, then stdin is read directly with the assumption that it
+ contains stab information. All other lines will be ignored. At
+ most one *.s file should be supplied.
+
+EOF
+ close PIPE;
+ exit 1;
+}
+
+sub defvar {
+ local($var, $msg) = @_;
+ printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
+}
+
+sub safedir {
+ $SAFEDIR = File::Temp::tempdir("c2ph.XXXXXX", TMPDIR => 1, CLEANUP => 1)
+ unless (defined($SAFEDIR));
+}
+
+undef $SAFEDIR;
+
+$recurse = 1;
+
+if (@ARGV) {
+ if (grep(!/\.[csh]$/,@ARGV)) {
+ warn "Only *.[csh] files expected!\n";
+ &usage;
+ }
+ elsif (grep(/\.s$/,@ARGV)) {
+ if (@ARGV > 1) {
+ warn "Only one *.s file allowed!\n";
+ &usage;
+ }
+ }
+ elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
+ local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
+ $chdir = "cd $dir && " if $dir;
+ &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
+ $ARGV[0] =~ s/\.c$/.s/;
+ }
+ else {
+ &safedir;
+ $TMP = "$SAFEDIR/c2ph.$$.c";
+ &system("cat @ARGV > $TMP") && exit 1;
+ &system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1;
+ unlink $TMP;
+ $TMP =~ s/\.c$/.s/;
+ @ARGV = ($TMP);
+ }
+}
+
+if ($opt_s) {
+ for (split(/[\s,]+/, $opt_s)) {
+ $interested{$_}++;
+ }
+}
+
+
+$| = 1 if $debug;
+
+main: {
+
+ if ($trace) {
+ if (-t && !@ARGV) {
+ print STDERR "reading from your keyboard: ";
+ } else {
+ print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
+ }
+ }
+
+STAB: while (<>) {
+ if ($trace && !($. % 10)) {
+ $lineno = $..'';
+ print STDERR $lineno, "\b" x length($lineno);
+ }
+ next unless /^\s*\.stabs\s+/;
+ $line = $_;
+ s/^\s*\.stabs\s+//;
+ if (s/\\\\"[d,]+$//) {
+ $saveline .= $line;
+ $savebar = $_;
+ next STAB;
+ }
+ if ($saveline) {
+ s/^"//;
+ $_ = $savebar . $_;
+ $line = $saveline;
+ }
+ &stab;
+ $savebar = $saveline = undef;
+ }
+ print STDERR "$.\n" if $trace;
+ unlink $TMP if $TMP;
+
+ &compute_intrinsics if $perl && !$opt_i;
+
+ print STDERR "resolving types\n" if $trace;
+
+ &resolve_types;
+ &adjust_start_addrs;
+
+ $sum = 2 + $type_width + $member_width;
+ $pmask1 = "%-${type_width}s %-${member_width}s";
+ $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
+
+
+
+ if ($perl) {
+ # resolve template -- should be in stab define order, but even this isn't enough.
+ print STDERR "\nbuilding type templates: " if $trace;
+ for $i (reverse 0..$#type) {
+ next unless defined($name = $type[$i]);
+ next unless defined $struct{$name};
+ ($iname = $name) =~ s/\..*//;
+ $build_recursed = 0;
+ &build_template($name) unless defined $template{&psou($name)} ||
+ $opt_s && !$interested{$iname};
+ }
+ print STDERR "\n\n" if $trace;
+ }
+
+ print STDERR "dumping structs: " if $trace;
+
+ local($iam);
+
+
+
+ foreach $name (sort keys %struct) {
+ ($iname = $name) =~ s/\..*//;
+ next if $opt_s && !$interested{$iname};
+ print STDERR "$name " if $trace;
+
+ undef @sizeof;
+ undef @typedef;
+ undef @offsetof;
+ undef @indices;
+ undef @typeof;
+ undef @fieldnames;
+
+ $mname = &munge($name);
+
+ $fname = &psou($name);
+
+ print "# " if $perl && $verbose;
+ $pcode = '';
+ print "$fname {\n" if !$perl || $verbose;
+ $template{$fname} = &scrunch($template{$fname}) if $perl;
+ &pstruct($name,$name,0);
+ print "# " if $perl && $verbose;
+ print "}\n" if !$perl || $verbose;
+ print "\n" if $perl && $verbose;
+
+ if ($perl) {
+ print "$pcode";
+
+ printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
+
+ print <<EOF;
+sub ${mname}'typedef {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'typedef[\$${mname}'index]
+ : \$${mname}'typedef;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'sizeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'sizeof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'offsetof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'offsetof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'typeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'typeof[\$${mname}'index]
+ : '$name';
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'fieldnames {
+ \@${mname}'fieldnames;
+}
+EOF
+
+ $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
+
+ print <<EOF;
+sub ${mname}'isastruct {
+ '$iam';
+}
+EOF
+
+ print "\$${mname}'typedef = '" . &scrunch($template{$fname})
+ . "';\n";
+
+ print "\$${mname}'sizeof = $sizeof{$name};\n\n";
+
+
+ print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
+
+ print "\n";
+
+ print "\@${mname}'typedef[\@${mname}'indices] = (",
+ join("\n\t", '', @typedef), "\n );\n\n";
+ print "\@${mname}'sizeof[\@${mname}'indices] = (",
+ join("\n\t", '', @sizeof), "\n );\n\n";
+ print "\@${mname}'offsetof[\@${mname}'indices] = (",
+ join("\n\t", '', @offsetof), "\n );\n\n";
+ print "\@${mname}'typeof[\@${mname}'indices] = (",
+ join("\n\t", '', @typeof), "\n );\n\n";
+ print "\@${mname}'fieldnames[\@${mname}'indices] = (",
+ join("\n\t", '', @fieldnames), "\n );\n\n";
+
+ $template_printed{$fname}++;
+ $size_printed{$fname}++;
+ }
+ print "\n";
+ }
+
+ print STDERR "\n" if $trace;
+
+ unless ($perl && $opt_a) {
+ print "\n1;\n" if $perl;
+ exit;
+ }
+
+
+
+ foreach $name (sort bysizevalue keys %intrinsics) {
+ next if $size_printed{$name};
+ print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
+ }
+
+ print "\n";
+
+ sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
+
+
+ foreach $name (sort keys %intrinsics) {
+ print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
+ }
+
+ print "\n1;\n" if $perl;
+
+ exit;
+}
+
+########################################################################################
+
+
+sub stab {
+ next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
+ s/"// || next;
+ s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
+
+ next if /^\s*$/;
+
+ $size = $3 if $3;
+ $_ = $continued . $_ if length($continued);
+ if (s/\\\\$//) {
+ # if last 2 chars of string are '\\' then stab is continued
+ # in next stab entry
+ chop;
+ $continued = $_;
+ next;
+ }
+ $continued = '';
+
+
+ $line = $_;
+
+ if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
+ print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
+ &pdecl($pdecl);
+ next;
+ }
+
+
+
+ if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
+ local($ident) = $2;
+ push(@intrinsics, $ident);
+ $typeno = &typeno($3);
+ $type[$typeno] = $ident;
+ print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
+ next;
+ }
+
+ if (($name, $typeordef, $typeno, $extra, $struct, $_)
+ = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
+ {
+ $typeno = &typeno($typeno); # sun foolery
+ }
+ elsif (/^[\$\w]+:/) {
+ next; # variable
+ }
+ else {
+ warn "can't grok stab: <$_> in: $line " if $_;
+ next;
+ }
+
+ #warn "got size $size for $name\n";
+ $sizeof{$name} = $size if $size;
+
+ s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
+
+ $typenos{$name} = $typeno;
+
+ unless (defined $type[$typeno]) {
+ &panic("type 0??") unless $typeno;
+ $type[$typeno] = $name unless defined $type[$typeno];
+ printf "new type $typeno is $name" if $debug;
+ if ($extra =~ /\*/ && defined $type[$struct]) {
+ print ", a typedef for a pointer to " , $type[$struct] if $debug;
+ }
+ } else {
+ printf "%s is type %d", $name, $typeno if $debug;
+ print ", a typedef for " , $type[$typeno] if $debug;
+ }
+ print "\n" if $debug;
+ #next unless $extra =~ /[su*]/;
+
+ #$type[$struct] = $name;
+
+ if ($extra =~ /[us*]/) {
+ &sou($name, $extra);
+ $_ = &sdecl($name, $_, 0);
+ }
+ elsif (/^=ar/) {
+ print "it's a bare array typedef -- that's pretty sick\n" if $debug;
+ $_ = "$typeno$_";
+ $scripts = '';
+ $_ = &adecl($_,1);
+
+ }
+ elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
+ push(@intrinsics, $2);
+ $typeno = &typeno($3);
+ $type[$typeno] = $2;
+ print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
+ }
+ elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
+ &edecl;
+ }
+ else {
+ warn "Funny remainder for $name on line $_ left in $line " if $_;
+ }
+}
+
+sub typeno { # sun thinks types are (0,27) instead of just 27
+ local($_) = @_;
+ s/\(\d+,(\d+)\)/$1/;
+ $_;
+}
+
+sub pstruct {
+ local($what,$prefix,$base) = @_;
+ local($field, $fieldname, $typeno, $count, $offset, $entry);
+ local($fieldtype);
+ local($type, $tname);
+ local($mytype, $mycount, $entry2);
+ local($struct_count) = 0;
+ local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
+ local($bits,$bytes);
+ local($template);
+
+
+ local($mname) = &munge($name);
+
+ sub munge {
+ local($_) = @_;
+ s/[\s\$\.]/_/g;
+ $_;
+ }
+
+ local($sname) = &psou($what);
+
+ $nesting++;
+
+ for $field (split(/;/, $struct{$what})) {
+ $pad = $prepad = 0;
+ $entry = '';
+ ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
+
+ $type = $type[$typeno];
+
+ $type =~ /([^[]*)(\[.*\])?/;
+ $mytype = $1;
+ $count .= $2;
+ $fieldtype = &psou($mytype);
+
+ local($fname) = &psou($name);
+
+ if ($build_templates) {
+
+ $pad = ($offset - ($lastoffset + $lastlength))/8
+ if defined $lastoffset;
+
+ if (! $finished_template{$sname}) {
+ if ($isaunion{$what}) {
+ $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
+ } else {
+ $template{$sname} .= 'x' x $pad . ' ' if $pad;
+ }
+ }
+
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+
+ if (! $finished_template{$sname}) {
+ $template{$sname} .= $template;
+ }
+
+ $revpad = $length/8 if $isaunion{$what};
+
+ ($lastoffset, $lastlength) = ($offset, $length);
+
+ } else {
+ print '# ' if $perl && $verbose;
+ $entry = sprintf($pmask1,
+ ' ' x ($nesting * $indent) . $fieldtype,
+ "$prefix.$fieldname" . $count);
+
+ $entry =~ s/(\*+)( )/$2$1/;
+
+ printf $pmask2,
+ $entry,
+ ($base+$offset)/8,
+ ($bits = ($base+$offset)%8) ? ".$bits" : " ",
+ $length/8,
+ ($bits = $length % 8) ? ".$bits": ""
+ if !$perl || $verbose;
+
+ if ($perl) {
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+ }
+
+ if ($perl && $nesting == 1) {
+
+ push(@sizeof, int($length/8) .",\t# $fieldname");
+ push(@offsetof, int($offset/8) .",\t# $fieldname");
+ local($little) = &scrunch($template);
+ push(@typedef, "'$little', \t# $fieldname");
+ $type =~ s/(struct|union) //;
+ push(@typeof, "'$mytype" . ($count ? $count : '') .
+ "',\t# $fieldname");
+ push(@fieldnames, "'$fieldname',");
+ }
+
+ print ' ', ' ' x $indent x $nesting, $template
+ if $perl && $verbose;
+
+ print "\n" if !$perl || $verbose;
+
+ }
+ if ($perl) {
+ local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
+ $mycount *= &scripts2count($count) if $count;
+ if ($nesting==1 && !$build_templates) {
+ $pcode .= sprintf("sub %-32s { %4d; }\n",
+ "${mname}'${fieldname}", $struct_count);
+ push(@indices, $struct_count);
+ }
+ $struct_count += $mycount;
+ }
+
+
+ &pstruct($type, "$prefix.$fieldname", $base+$offset)
+ if $recurse && defined $struct{$type};
+ }
+
+ $countof{$what} = $struct_count unless defined $countof{$whati};
+
+ $template{$sname} .= '$' if $build_templates;
+ $finished_template{$sname}++;
+
+ if ($build_templates && !defined $sizeof{$name}) {
+ local($fmt) = &scrunch($template{$sname});
+ print STDERR "no size for $name, punting with $fmt..." if $debug;
+ eval '$sizeof{$name} = length(pack($fmt, ()))';
+ if ($@) {
+ chop $@;
+ warn "couldn't get size for \$name: $@";
+ } else {
+ print STDERR $sizeof{$name}, "\n" if $debUg;
+ }
+ }
+
+ --$nesting;
+}
+
+
+sub psize {
+ local($me) = @_;
+ local($amstruct) = $struct{$me} ? 'struct ' : '';
+
+ print '$sizeof{\'', $amstruct, $me, '\'} = ';
+ printf "%d;\n", $sizeof{$me};
+}
+
+sub pdecl {
+ local($pdecl) = @_;
+ local(@pdecls);
+ local($tname);
+
+ warn "pdecl: $pdecl\n" if $debug;
+
+ $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
+ $pdecl =~ s/\*//g;
+ @pdecls = split(/=/, $pdecl);
+ $typeno = $pdecls[0];
+ $tname = pop @pdecls;
+
+ if ($tname =~ s/^f//) { $tname = "$tname&"; }
+ #else { $tname = "$tname*"; }
+
+ for (reverse @pdecls) {
+ $tname .= s/^f// ? "&" : "*";
+ #$tname =~ s/^f(.*)/$1&/;
+ print "type[$_] is $tname\n" if $debug;
+ $type[$_] = $tname unless defined $type[$_];
+ }
+}
+
+
+
+sub adecl {
+ ($arraytype, $unknown, $lower, $upper) = ();
+ #local($typeno);
+ # global $typeno, @type
+ local($_, $typedef) = @_;
+
+ while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
+ ($arraytype, $unknown) = ($2, $3);
+ $arraytype = &typeno($arraytype);
+ $unknown = &typeno($unknown);
+ if (s/^(\d+);(\d+);//) {
+ ($lower, $upper) = ($1, $2);
+ $scripts .= '[' . ($upper+1) . ']';
+ } else {
+ warn "can't find array bounds: $_";
+ }
+ }
+ if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ $whatis = $1;
+ if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
+ $typeno = &typeno($1);
+ &pdecl($whatis);
+ } else {
+ $typeno = &typeno($whatis);
+ }
+ } elsif (s/^(\d+)(=[*suf]\d*)//) {
+ local($whatis) = $2;
+
+ if ($whatis =~ /[f*]/) {
+ &pdecl($whatis);
+ } elsif ($whatis =~ /[su]/) { #
+ print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
+ if $debug;
+ #$type[$typeno] = $name unless defined $type[$typeno];
+ ##printf "new type $typeno is $name" if $debug;
+ $typeno = $1;
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = $type[$typeno];
+ &sou($name, $whatis);
+ $_ = &sdecl($name, $_, $start+$offset);
+ 1;
+ $start = $start{$name};
+ $offset = $sizeof{$name};
+ $length = $offset;
+ } else {
+ warn "what's this? $whatis in $line ";
+ }
+ } elsif (/^\d+$/) {
+ $typeno = $_;
+ } else {
+ warn "bad array stab: $_ in $line ";
+ next STAB;
+ }
+ #local($wasdef) = defined($type[$typeno]) && $debug;
+ #if ($typedef) {
+ #print "redefining $type[$typeno] to " if $wasdef;
+ #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
+ #print "$type[$typeno]\n" if $wasdef;
+ #} else {
+ #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
+ #}
+ $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
+ print "type[$arraytype] is $type[$arraytype]\n" if $debug;
+ print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
+ $_;
+}
+
+
+
+sub sdecl {
+ local($prefix, $_, $offset) = @_;
+
+ local($fieldname, $scripts, $type, $arraytype, $unknown,
+ $whatis, $pdecl, $upper,$lower, $start,$length) = ();
+ local($typeno,$sou);
+
+
+SFIELD:
+ while (/^([^;]+);/) {
+ $scripts = '';
+ warn "sdecl $_\n" if $debug;
+ if (s/^([\$\w]+)://) {
+ $fieldname = $1;
+ } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
+ $typeno = &typeno($1);
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$2);
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $offset += $sizeof{$name};
+ #print "done with anon, start is $start, offset is $offset\n";
+ #next SFIELD;
+ } else {
+ warn "weird field $_ of $line" if $debug;
+ next STAB;
+ #$fieldname = &gensym;
+ #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ }
+
+ if (/^(\d+|\(\d+,\d+\))=ar/) {
+ $_ = &adecl($_);
+ }
+ elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
+ ($pdecl, $start, $length) = ($1,$5,$6);
+ &pdecl($pdecl);
+ }
+ elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
+ ($typeno, $sou) = ($1, $2);
+ $typeno = &typeno($typeno);
+ if (defined($type[$typeno])) {
+ warn "now how did we get type $1 in $fieldname of $line?";
+ } else {
+ print "anon type $typeno is $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
+ };
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$sou);
+ print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname";
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $length = $sizeof{$name};
+ }
+ else {
+ warn "can't grok stab for $name ($_) in line $line ";
+ next STAB;
+ }
+
+ &panic("no length for $prefix.$fieldname") unless $length;
+ $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
+ }
+ if (s/;\d*,(\d+),(\d+);//) {
+ local($start, $size) = ($1, $2);
+ $sizeof{$prefix} = $size;
+ print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
+ $start{$prefix} = $start;
+ }
+ $_;
+}
+
+sub edecl {
+ s/;$//;
+ $enum{$name} = $_;
+ $_ = '';
+}
+
+sub resolve_types {
+ local($sou);
+ for $i (0 .. $#type) {
+ next unless defined $type[$i];
+ $_ = $type[$i];
+ unless (/\d/) {
+ print "type[$i] $type[$i]\n" if $debug;
+ next;
+ }
+ print "type[$i] $_ ==> " if $debug;
+ s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
+ s/^(\d+)\&/&type($1)/e;
+ s/^(\d+)/&type($1)/e;
+ s/(\*+)([^*]+)(\*+)/$1$3$2/;
+ s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
+ s/^(\d+)([\*\[].*)/&type($1).$2/e;
+ #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
+ $type[$i] = $_;
+ print "$_\n" if $debug;
+ }
+}
+sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
+
+sub adjust_start_addrs {
+ for (sort keys %start) {
+ ($basename = $_) =~ s/\.[^.]+$//;
+ $start{$_} += $start{$basename};
+ print "start: $_ @ $start{$_}\n" if $debug;
+ }
+}
+
+sub sou {
+ local($what, $_) = @_;
+ /u/ && $isaunion{$what}++;
+ /s/ && $isastruct{$what}++;
+}
+
+sub psou {
+ local($what) = @_;
+ local($prefix) = '';
+ if ($isaunion{$what}) {
+ $prefix = 'union ';
+ } elsif ($isastruct{$what}) {
+ $prefix = 'struct ';
+ }
+ $prefix . $what;
+}
+
+sub scrunch {
+ local($_) = @_;
+
+ return '' if $_ eq '';
+
+ study;
+
+ s/\$//g;
+ s/ / /g;
+ 1 while s/(\w) \1/$1$1/g;
+
+ # i wanna say this, but perl resists my efforts:
+ # s/(\w)(\1+)/$2 . length($1)/ge;
+
+ &quick_scrunch;
+
+ s/ $//;
+
+ $_;
+}
+
+sub buildscrunchlist {
+ $scrunch_code = "sub quick_scrunch {\n";
+ for (values %intrinsics) {
+ $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
+ }
+ $scrunch_code .= "}\n";
+ print "$scrunch_code" if $debug;
+ eval $scrunch_code;
+ &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
+}
+
+sub fetch_template {
+ local($mytype) = @_;
+ local($fmt);
+ local($count) = 1;
+
+ &panic("why do you care?") unless $perl;
+
+ if ($mytype =~ s/(\[\d+\])+$//) {
+ $count .= $1;
+ }
+
+ if ($mytype =~ /\*/) {
+ $fmt = $template{'pointer'};
+ }
+ elsif (defined $template{$mytype}) {
+ $fmt = $template{$mytype};
+ }
+ elsif (defined $struct{$mytype}) {
+ if (!defined $template{&psou($mytype)}) {
+ &build_template($mytype) unless $mytype eq $name;
+ }
+ elsif ($template{&psou($mytype)} !~ /\$$/) {
+ #warn "incomplete template for $mytype\n";
+ }
+ $fmt = $template{&psou($mytype)} || '?';
+ }
+ else {
+ warn "unknown fmt for $mytype\n";
+ $fmt = '?';
+ }
+
+ $fmt x $count . ' ';
+}
+
+sub compute_intrinsics {
+ &safedir;
+ local($TMP) = "$SAFEDIR/c2ph-i.$$.c";
+ open (TMP, ">$TMP") || die "can't open $TMP: $!";
+ select(TMP);
+
+ print STDERR "computing intrinsic sizes: " if $trace;
+
+ undef %intrinsics;
+
+ print <<'EOF';
+main() {
+ char *mask = "%d %s\n";
+EOF
+
+ for $type (@intrinsics) {
+ next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
+ print <<"EOF";
+ printf(mask,sizeof($type), "$type");
+EOF
+ }
+
+ print <<'EOF';
+ printf(mask,sizeof(char *), "pointer");
+ exit(0);
+}
+EOF
+ close TMP;
+
+ select(STDOUT);
+ open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|");
+ while (<PIPE>) {
+ chop;
+ split(' ',$_,2);;
+ print "intrinsic $_[1] is size $_[0]\n" if $debug;
+ $sizeof{$_[1]} = $_[0];
+ $intrinsics{$_[1]} = $template{$_[0]};
+ }
+ close(PIPE) || die "couldn't read intrinsics!";
+ unlink($TMP, "$SAFEDIR/a.out");
+ print STDERR "done\n" if $trace;
+}
+
+sub scripts2count {
+ local($_) = @_;
+
+ s/^\[//;
+ s/\]$//;
+ s/\]\[/*/g;
+ $_ = eval;
+ &panic("$_: $@") if $@;
+ $_;
+}
+
+sub system {
+ print STDERR "@_\n" if $trace;
+ system @_;
+}
+
+sub build_template {
+ local($name) = @_;
+
+ &panic("already got a template for $name") if defined $template{$name};
+
+ local($build_templates) = 1;
+
+ local($lparen) = '(' x $build_recursed;
+ local($rparen) = ')' x $build_recursed;
+
+ print STDERR "$lparen$name$rparen " if $trace;
+ $build_recursed++;
+ &pstruct($name,$name,0);
+ print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
+ --$build_recursed;
+}
+
+
+sub panic {
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ local($i,$_);
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @DB'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(@sub, "$w&$s$a from file $f line $l\n");
+ last if $signal;
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+sub squishseq {
+ local($num);
+ local($last) = -1e8;
+ local($string);
+ local($seq) = '..';
+
+ while (defined($num = shift)) {
+ if ($num == ($last + 1)) {
+ $string .= $seq unless $inseq++;
+ $last = $num;
+ next;
+ } elsif ($inseq) {
+ $string .= $last unless $last == -1e8;
+ }
+
+ $string .= ',' if defined $string;
+ $string .= $num;
+ $last = $num;
+ $inseq = 0;
+ }
+ $string .= $last if $inseq && $last != -e18;
+ $string;
+}
+
+sub repeat_template {
+ # local($template, $scripts) = @_; have to change caller's values
+
+ if ( $_[1] ) {
+ local($ncount) = &scripts2count($_[1]);
+ if ($_[0] =~ /^\s*c\s*$/i) {
+ $_[0] = "A$ncount ";
+ $_[1] = '';
+ } else {
+ $_[0] = $template x $ncount;
+ }
+ }
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/ptar b/Master/tlpkg/tlperl.straw/bin/ptar
new file mode 100755
index 00000000000..6a3c1bcd2ec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptar
@@ -0,0 +1,114 @@
+#!/usr/bin/perl
+use strict;
+
+use File::Find;
+use Getopt::Std;
+use Archive::Tar;
+use Data::Dumper;
+
+my $opts = {};
+getopts('Ddcvzthxf:I', $opts) or die usage();
+
+### show the help message ###
+die usage() if $opts->{h};
+
+### enable debugging (undocumented feature)
+local $Archive::Tar::DEBUG = 1 if $opts->{d};
+
+### enable insecure extracting.
+local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I};
+
+### sanity checks ###
+unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
+ die "You need exactly one of 'x', 't' or 'c' options: " . usage();
+}
+
+my $compress = $opts->{z} ? 1 : 0;
+my $verbose = $opts->{v} ? 1 : 0;
+my $file = $opts->{f} ? $opts->{f} : 'default.tar';
+my $tar = Archive::Tar->new();
+
+
+if( $opts->{c} ) {
+ my @files;
+ find( sub { push @files, $File::Find::name;
+ print $File::Find::name.$/ if $verbose }, @ARGV );
+
+ if ($file eq '-') {
+ use IO::Handle;
+ $file = IO::Handle->new();
+ $file->fdopen(fileno(STDOUT),"w");
+ }
+
+ Archive::Tar->create_archive( $file, $compress, @files );
+
+} else {
+ if ($file eq '-') {
+ use IO::Handle;
+ $file = IO::Handle->new();
+ $file->fdopen(fileno(STDIN),"r");
+ }
+
+ ### print the files we're finding?
+ my $print = $verbose || $opts->{'t'} || 0;
+
+ my $iter = Archive::Tar->iter( $file );
+
+ while( my $f = $iter->() ) {
+ print $f->full_path . $/ if $print;
+
+ ### data dumper output
+ print Dumper( $f ) if $opts->{'D'};
+
+ ### extract it
+ $f->extract if $opts->{'x'};
+ }
+}
+
+### pod & usage in one
+sub usage {
+ my $usage .= << '=cut';
+=pod
+
+=head1 NAME
+
+ ptar - a tar-like program written in perl
+
+=head1 DESCRIPTION
+
+ ptar is a small, tar look-alike program that uses the perl module
+ Archive::Tar to extract, create and list tar archives.
+
+=head1 SYNOPSIS
+
+ ptar -c [-v] [-z] [-f ARCHIVE_FILE | -] FILE FILE ...
+ ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
+ ptar -t [-z] [-f ARCHIVE_FILE | -]
+ ptar -h
+
+=head1 OPTIONS
+
+ c Create ARCHIVE_FILE or STDOUT (-) from FILE
+ x Extract from ARCHIVE_FILE or STDIN (-)
+ t List the contents of ARCHIVE_FILE or STDIN (-)
+ f Name of the ARCHIVE_FILE to use. Default is './default.tar'
+ z Read/Write zlib compressed ARCHIVE_FILE (not always available)
+ v Print filenames as they are added or extraced from ARCHIVE_FILE
+ h Prints this help message
+
+=head1 SEE ALSO
+
+ tar(1), L<Archive::Tar>.
+
+=cut
+
+ ### strip the pod directives
+ $usage =~ s/=pod\n//g;
+ $usage =~ s/=head1 //g;
+
+ ### add some newlines
+ $usage .= $/.$/;
+
+ return $usage;
+}
+
diff --git a/Master/tlpkg/tlperl.straw/bin/ptar.bat b/Master/tlpkg/tlperl.straw/bin/ptar.bat
new file mode 100755
index 00000000000..6c439e086dc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptar.bat
@@ -0,0 +1,130 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+use strict;
+
+use File::Find;
+use Getopt::Std;
+use Archive::Tar;
+use Data::Dumper;
+
+my $opts = {};
+getopts('Ddcvzthxf:I', $opts) or die usage();
+
+### show the help message ###
+die usage() if $opts->{h};
+
+### enable debugging (undocumented feature)
+local $Archive::Tar::DEBUG = 1 if $opts->{d};
+
+### enable insecure extracting.
+local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I};
+
+### sanity checks ###
+unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
+ die "You need exactly one of 'x', 't' or 'c' options: " . usage();
+}
+
+my $compress = $opts->{z} ? 1 : 0;
+my $verbose = $opts->{v} ? 1 : 0;
+my $file = $opts->{f} ? $opts->{f} : 'default.tar';
+my $tar = Archive::Tar->new();
+
+
+if( $opts->{c} ) {
+ my @files;
+ find( sub { push @files, $File::Find::name;
+ print $File::Find::name.$/ if $verbose }, @ARGV );
+
+ if ($file eq '-') {
+ use IO::Handle;
+ $file = IO::Handle->new();
+ $file->fdopen(fileno(STDOUT),"w");
+ }
+
+ Archive::Tar->create_archive( $file, $compress, @files );
+
+} else {
+ if ($file eq '-') {
+ use IO::Handle;
+ $file = IO::Handle->new();
+ $file->fdopen(fileno(STDIN),"r");
+ }
+
+ ### print the files we're finding?
+ my $print = $verbose || $opts->{'t'} || 0;
+
+ my $iter = Archive::Tar->iter( $file );
+
+ while( my $f = $iter->() ) {
+ print $f->full_path . $/ if $print;
+
+ ### data dumper output
+ print Dumper( $f ) if $opts->{'D'};
+
+ ### extract it
+ $f->extract if $opts->{'x'};
+ }
+}
+
+### pod & usage in one
+sub usage {
+ my $usage .= << '=cut';
+=pod
+
+=head1 NAME
+
+ ptar - a tar-like program written in perl
+
+=head1 DESCRIPTION
+
+ ptar is a small, tar look-alike program that uses the perl module
+ Archive::Tar to extract, create and list tar archives.
+
+=head1 SYNOPSIS
+
+ ptar -c [-v] [-z] [-f ARCHIVE_FILE | -] FILE FILE ...
+ ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
+ ptar -t [-z] [-f ARCHIVE_FILE | -]
+ ptar -h
+
+=head1 OPTIONS
+
+ c Create ARCHIVE_FILE or STDOUT (-) from FILE
+ x Extract from ARCHIVE_FILE or STDIN (-)
+ t List the contents of ARCHIVE_FILE or STDIN (-)
+ f Name of the ARCHIVE_FILE to use. Default is './default.tar'
+ z Read/Write zlib compressed ARCHIVE_FILE (not always available)
+ v Print filenames as they are added or extraced from ARCHIVE_FILE
+ h Prints this help message
+
+=head1 SEE ALSO
+
+ tar(1), L<Archive::Tar>.
+
+=cut
+
+ ### strip the pod directives
+ $usage =~ s/=pod\n//g;
+ $usage =~ s/=head1 //g;
+
+ ### add some newlines
+ $usage .= $/.$/;
+
+ return $usage;
+}
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/ptardiff b/Master/tlpkg/tlperl.straw/bin/ptardiff
new file mode 100755
index 00000000000..21e7d6cce59
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptardiff
@@ -0,0 +1,112 @@
+#!/usr/bin/perl
+
+use strict;
+use Archive::Tar;
+use Getopt::Std;
+
+my $opts = {};
+getopts('h:', $opts) or die usage();
+
+die usages() if $opts->{h};
+
+### need Text::Diff -- give a polite error (not a standard prereq)
+unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) {
+ die "\n\t This tool requires the 'Text::Diff' module to be installed\n";
+}
+
+my $arch = shift or die usage();
+my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!";
+
+
+foreach my $file ( $tar->get_files ) {
+ next unless $file->is_file;
+ my $name = $file->name;
+
+ diff( \($file->get_content), $name,
+ { FILENAME_A => $name,
+ MTIME_A => $file->mtime,
+ OUTPUT => \*STDOUT
+ }
+ );
+}
+
+
+
+
+sub usage {
+ return q[
+
+Usage: ptardiff ARCHIVE_FILE
+ ptardiff -h
+
+ ptardiff is a small program that diffs an extracted archive
+ against an unextracted one, using the perl module Archive::Tar.
+
+ This effectively lets you view changes made to an archives contents.
+
+ Provide the progam with an ARCHIVE_FILE and it will look up all
+ the files with in the archive, scan the current working directory
+ for a file with the name and diff it against the contents of the
+ archive.
+
+
+Options:
+ h Prints this help message
+
+
+Sample Usage:
+
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ vi Acme-Buffy-1.3/README
+
+ [...]
+
+ $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
+
+
+See Also:
+ tar(1)
+ ptar
+ Archive::Tar
+
+ ] . $/;
+}
+
+
+
+=head1 NAME
+
+ptardiff - program that diffs an extracted archive against an unextracted one
+
+=head1 DESCRIPTION
+
+ ptardiff is a small program that diffs an extracted archive
+ against an unextracted one, using the perl module Archive::Tar.
+
+ This effectively lets you view changes made to an archives contents.
+
+ Provide the progam with an ARCHIVE_FILE and it will look up all
+ the files with in the archive, scan the current working directory
+ for a file with the name and diff it against the contents of the
+ archive.
+
+=head1 SYNOPSIS
+
+ ptardiff ARCHIVE_FILE
+ ptardiff -h
+
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ vi Acme-Buffy-1.3/README
+ [...]
+ $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
+
+
+=head1 OPTIONS
+
+ h Prints this help message
+
+=head1 SEE ALSO
+
+tar(1), L<Archive::Tar>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/ptardiff.bat b/Master/tlpkg/tlperl.straw/bin/ptardiff.bat
new file mode 100755
index 00000000000..85ac7896610
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptardiff.bat
@@ -0,0 +1,128 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use strict;
+use Archive::Tar;
+use Getopt::Std;
+
+my $opts = {};
+getopts('h:', $opts) or die usage();
+
+die usages() if $opts->{h};
+
+### need Text::Diff -- give a polite error (not a standard prereq)
+unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) {
+ die "\n\t This tool requires the 'Text::Diff' module to be installed\n";
+}
+
+my $arch = shift or die usage();
+my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!";
+
+
+foreach my $file ( $tar->get_files ) {
+ next unless $file->is_file;
+ my $name = $file->name;
+
+ diff( \($file->get_content), $name,
+ { FILENAME_A => $name,
+ MTIME_A => $file->mtime,
+ OUTPUT => \*STDOUT
+ }
+ );
+}
+
+
+
+
+sub usage {
+ return q[
+
+Usage: ptardiff ARCHIVE_FILE
+ ptardiff -h
+
+ ptardiff is a small program that diffs an extracted archive
+ against an unextracted one, using the perl module Archive::Tar.
+
+ This effectively lets you view changes made to an archives contents.
+
+ Provide the progam with an ARCHIVE_FILE and it will look up all
+ the files with in the archive, scan the current working directory
+ for a file with the name and diff it against the contents of the
+ archive.
+
+
+Options:
+ h Prints this help message
+
+
+Sample Usage:
+
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ vi Acme-Buffy-1.3/README
+
+ [...]
+
+ $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
+
+
+See Also:
+ tar(1)
+ ptar
+ Archive::Tar
+
+ ] . $/;
+}
+
+
+
+=head1 NAME
+
+ptardiff - program that diffs an extracted archive against an unextracted one
+
+=head1 DESCRIPTION
+
+ ptardiff is a small program that diffs an extracted archive
+ against an unextracted one, using the perl module Archive::Tar.
+
+ This effectively lets you view changes made to an archives contents.
+
+ Provide the progam with an ARCHIVE_FILE and it will look up all
+ the files with in the archive, scan the current working directory
+ for a file with the name and diff it against the contents of the
+ archive.
+
+=head1 SYNOPSIS
+
+ ptardiff ARCHIVE_FILE
+ ptardiff -h
+
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ vi Acme-Buffy-1.3/README
+ [...]
+ $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
+
+
+=head1 OPTIONS
+
+ h Prints this help message
+
+=head1 SEE ALSO
+
+tar(1), L<Archive::Tar>.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/ptked b/Master/tlpkg/tlperl.straw/bin/ptked
new file mode 100755
index 00000000000..e0c537d96f4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptked
@@ -0,0 +1,368 @@
+#!/usr/local/bin/perl -w
+use strict;
+use Socket;
+use IO::Socket;
+use Cwd;
+use Getopt::Long;
+
+use vars qw($VERSION $portfile);
+$VERSION = sprintf '4.%03d', q$Revision: #29 $ =~ /\D(\d+)\s*$/;
+
+my %opt;
+INIT
+ {
+ my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'};
+ $portfile = "$home/.ptkedsn";
+ my $port = $ENV{'PTKEDPORT'};
+ return if $^C;
+ GetOptions(\%opt,qw(server! encoding=s));
+ unless (defined $port)
+ {
+ if (open(SN,"$portfile"))
+ {
+ $port = <SN>;
+ close(SN);
+ }
+ }
+ if (defined $port)
+ {
+ my $sock = IO::Socket::INET->new(PeerAddr => 'localhost',
+ PeerPort => $port, Proto => 'tcp');
+ if ($sock)
+ {
+ binmode($sock);
+ $sock->autoflush;
+ foreach my $file (@ARGV)
+ {
+ unless (print $sock "$file\n")
+ {
+ die "Cannot print $file to socket:$!";
+ }
+ print "Requested '$file'\n";
+ }
+ $sock->close || die "Cannot close socket:$!";
+ exit(0);
+ }
+ else
+ {
+ warn "Cannot connect to server on $port:$!";
+ }
+ }
+ }
+
+use Tk;
+use Tk::DropSite qw(XDND Sun);
+use Tk::DragDrop qw(XDND Sun);
+use Tk::widgets qw(TextUndo Scrollbar Menu Dialog);
+# use Tk::ErrorDialog;
+
+{
+ package Tk::TextUndoPtked;
+ @Tk::TextUndoPtked::ISA = qw(Tk::TextUndo);
+ Construct Tk::Widget 'TextUndoPtked';
+
+ sub Save {
+ my $w = shift;
+ $w->SUPER::Save(@_);
+ $w->toplevel->title($w->FileName);
+ }
+
+ sub Load {
+ my $w = shift;
+ $w->SUPER::Load(@_);
+ $w->toplevel->title($w->FileName);
+ }
+
+ sub MenuLabels { shift->SUPER::MenuLabels, 'Encoding' }
+
+ sub Encoding
+ {
+ my ($w,$enc) = @_;
+ if (@_ > 1)
+ {
+ $enc = $w->getEncoding($enc) unless ref($enc);
+ $w->{ENCODING} = $enc;
+ $enc = $enc->name;
+ $w->{ENCODINGNAME} = $enc;
+ $w->PerlIO_layers(":encoding($enc)");
+ }
+ return $w->{ENCODING};
+ }
+
+ sub EncodingMenuItems
+ {
+ my ($w) = @_;
+ my @menu;
+ my @encoding_defs = ( # use canonical encoding names for radiobutton value
+ ['Unicode (UTF-8)', 'utf-8-strict'],
+ ['Western (iso-8859-1)', 'iso-8859-1'],
+ ['Western (Windows-1252)', 'cp1252'],
+ ["Western with \x{20ac} (iso-8859-15)", 'iso-8859-15'],
+ ['Central European (Windows-1250)', 'cp1250'],
+ );
+ if (!grep { $_->[1] eq Tk::SystemEncoding()->name } @encoding_defs)
+ {
+ unshift @encoding_defs, ['System', Tk::SystemEncoding()->name];
+ }
+
+ for my $encoding_def (@encoding_defs)
+ {
+ my($label, $encoding) = @$encoding_def;
+ push @menu, [ radiobutton => $label,
+ -command => [ $w, Encoding => $encoding ],
+ -variable => \$w->{ENCODINGNAME},
+ -value => $encoding ];
+ }
+ return [ @menu ];
+ }
+
+}
+
+my $top = MainWindow->new();
+
+if ($opt{'server'})
+ {
+ my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp');
+ die "Cannot open listen socket:$!" unless defined $sock;
+ binmode($sock);
+
+ my $port = $sock->sockport;
+ $ENV{'PTKEDPORT'} = $port;
+ open(SN,">$portfile") || die "Cannot open $portfile:$!";
+ print SN $port;
+ close(SN);
+ print "Accepting connections on $port\n";
+ $top->fileevent($sock,'readable',
+ sub
+ {
+ print "accepting $sock\n";
+ my $client = $sock->accept;
+ if (defined $client)
+ {
+ binmode($client);
+ print "Connection $client\n";
+ $top->fileevent($client,'readable',[\&EditRequest,$client]);
+ }
+ });
+ }
+
+Tk::Event::HandleSignals();
+$SIG{'INT'} = sub { $top->WmDeleteWindow };
+
+$top->iconify;
+$top->optionAdd('*TextUndoPtked.Background' => '#fff5e1');
+$top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12),
+ -weight => 'normal', -slant => 'roman');
+$top->optionAdd('*TextUndoPtked.Font' => 'ptked');
+
+if (@ARGV)
+ {
+ foreach my $file (@ARGV)
+ {
+ Create_Edit($file);
+ }
+ }
+else
+ {
+ Create_Edit();
+ }
+
+sub EditRequest
+{
+ my ($client) = @_;
+ local $_;
+ while (<$client>)
+ {
+ chomp($_);
+ print "'$_'\n",
+ Create_Edit($_);
+ }
+ warn "Odd $!" unless eof($client);
+ $top->fileevent($client,'readable','');
+ print "Close $client\n";
+ $client->close;
+}
+
+MainLoop;
+unlink("$portfile");
+exit(0);
+
+sub Create_Edit
+{
+ my $path = shift;
+ my $ed = $top->Toplevel(-title => $path);
+ $ed->withdraw;
+ $top->{'Edits'}++;
+ $ed->OnDestroy([\&RemoveEdit,$top]);
+ my $t = $ed->Scrolled('TextUndoPtked', -wrap => 'none',
+ -scrollbars => 'se', # both required till optional fixed!
+ );
+ $t->pack(-expand => 1, -fill => 'both');
+ $t = $t->Subwidget('scrolled');
+
+ $t->Encoding($opt{encoding} || Tk::SystemEncoding()->name);
+
+ my $menu = $t->menu;
+ $menu->cascade(-label => '~Help', -menuitems => [
+ [Button => '~About...', -command => [\&About,$ed]],
+ ]);
+ $ed->configure(-menu => $menu);
+ my $dd = $t->DragDrop(-event => '<Meta-B1-Motion>');
+ $t->bind(ref($t),'<Meta-B1-Motion>',\&Ouch);
+ $t->bind(ref($t),'<Meta-ButtonPress>',\&Ouch);
+ $t->bind(ref($t),'<Meta-ButtonRelease>',\&Ouch);
+ $dd->configure(-startcommand =>
+ sub
+ {
+ return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')});
+ $dd->configure(-text => $t->get('sel.first','sel.last'));
+ });
+
+ $t->DropSite(-motioncommand =>
+ sub
+ { my ($x,$y) = @_;
+ $t->markSet(insert => "\@$x,$y");
+ },
+ -dropcommand => [\&HandleDrop,$t],
+ );
+
+
+
+ $ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]);
+ $t->bind('<F3>',\&DoFind);
+
+ $ed->idletasks;
+ if (defined $path && -e $path)
+ {
+ $t->Load($path);
+ }
+ else
+ {
+ $t->FileName($path);
+ }
+ $ed->deiconify;
+ $t->update;
+ $t->focus;
+}
+
+sub Ouch
+{
+ warn join(',','Ouch',@_);
+}
+
+sub RemoveEdit
+{
+ my $top = shift;
+ if (--$top->{'Edits'} == 0)
+ {
+ $top->destroy unless $opt{'s'};
+ }
+}
+
+sub HandleDrop
+{my ($t,$seln,$x,$y) = @_;
+ # warn join(',',Drop => @_);
+ my $string;
+ Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') };
+ if ($@)
+ {
+ Tk::catch { $string = $t->SelectionGet(-selection => $seln) };
+ if ($@)
+ {
+ my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS');
+ $t->messageBox(-text => "Targets : ".join(' ',@targets));
+ }
+ else
+ {
+ $t->markSet(insert => "\@$x,$y");
+ $t->insert(insert => $string);
+ }
+ }
+ else
+ {
+ Create_Edit($string);
+ }
+}
+
+
+my $str;
+
+sub DoFind
+{
+ my $t = shift;
+ $str = shift if (@_);
+ my $posn = $t->index('insert+1c');
+ $t->tag('remove','sel','1.0','end');
+ local $_;
+ while ($t->compare($posn,'<','end'))
+ {
+ my ($line,$col) = split(/\./,$posn);
+ $_ = $t->get("$line.0","$posn lineend");
+ pos($_) = $col;
+ if (/\G(.*)$str/g)
+ {
+ $col += length($1);
+ $posn = "$line.$col";
+ $t->SetCursor($posn);
+ $t->tag('add','sel',$posn,"$line.".pos($_));
+ $t->focus;
+ return;
+ }
+ $posn = $t->index("$posn lineend + 1c");
+ }
+}
+
+sub AskFind
+{
+ my ($t) = @_;
+ unless (exists $t->{'AskFind'})
+ {
+ my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw');
+ $d->title('Find...');
+ $d->withdraw;
+ $d->transient($t->toplevel);
+ my $e = $d->Entry->pack;
+ $e->bind('<Return>', sub { $d->withdraw; DoFind($t,$e->get); });
+ $d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]);
+ }
+ $t->{'AskFind'}->Popup;
+ $t->update;
+ $t->{'AskFind'}->focusNext;
+}
+
+sub About
+{
+ my $mw = shift;
+
+ $mw->Dialog(-text => <<"END",-popover => $mw)->Show;
+$0 version $VERSION
+perl$]/Tk$Tk::VERSION
+
+Copyright © 1995-2004 Nick Ing-Simmons. All rights reserved.
+This package is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+END
+}
+
+__END__
+
+=head1 NAME
+
+ptked - an editor in Perl/Tk
+
+=head1 SYNOPSIS
+
+S< >B<ptked> [I<file-to-edit>]
+
+=head1 DESCRIPTION
+
+B<ptked> is a simple text editor based on perl/Tk's TextUndo widget.
+
+=cut
+
+
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/bin/ptked.bat b/Master/tlpkg/tlperl.straw/bin/ptked.bat
new file mode 100755
index 00000000000..390178b1916
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptked.bat
@@ -0,0 +1,384 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+use strict;
+use Socket;
+use IO::Socket;
+use Cwd;
+use Getopt::Long;
+
+use vars qw($VERSION $portfile);
+$VERSION = sprintf '4.%03d', q$Revision: #29 $ =~ /\D(\d+)\s*$/;
+
+my %opt;
+INIT
+ {
+ my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'};
+ $portfile = "$home/.ptkedsn";
+ my $port = $ENV{'PTKEDPORT'};
+ return if $^C;
+ GetOptions(\%opt,qw(server! encoding=s));
+ unless (defined $port)
+ {
+ if (open(SN,"$portfile"))
+ {
+ $port = <SN>;
+ close(SN);
+ }
+ }
+ if (defined $port)
+ {
+ my $sock = IO::Socket::INET->new(PeerAddr => 'localhost',
+ PeerPort => $port, Proto => 'tcp');
+ if ($sock)
+ {
+ binmode($sock);
+ $sock->autoflush;
+ foreach my $file (@ARGV)
+ {
+ unless (print $sock "$file\n")
+ {
+ die "Cannot print $file to socket:$!";
+ }
+ print "Requested '$file'\n";
+ }
+ $sock->close || die "Cannot close socket:$!";
+ exit(0);
+ }
+ else
+ {
+ warn "Cannot connect to server on $port:$!";
+ }
+ }
+ }
+
+use Tk;
+use Tk::DropSite qw(XDND Sun);
+use Tk::DragDrop qw(XDND Sun);
+use Tk::widgets qw(TextUndo Scrollbar Menu Dialog);
+# use Tk::ErrorDialog;
+
+{
+ package Tk::TextUndoPtked;
+ @Tk::TextUndoPtked::ISA = qw(Tk::TextUndo);
+ Construct Tk::Widget 'TextUndoPtked';
+
+ sub Save {
+ my $w = shift;
+ $w->SUPER::Save(@_);
+ $w->toplevel->title($w->FileName);
+ }
+
+ sub Load {
+ my $w = shift;
+ $w->SUPER::Load(@_);
+ $w->toplevel->title($w->FileName);
+ }
+
+ sub MenuLabels { shift->SUPER::MenuLabels, 'Encoding' }
+
+ sub Encoding
+ {
+ my ($w,$enc) = @_;
+ if (@_ > 1)
+ {
+ $enc = $w->getEncoding($enc) unless ref($enc);
+ $w->{ENCODING} = $enc;
+ $enc = $enc->name;
+ $w->{ENCODINGNAME} = $enc;
+ $w->PerlIO_layers(":encoding($enc)");
+ }
+ return $w->{ENCODING};
+ }
+
+ sub EncodingMenuItems
+ {
+ my ($w) = @_;
+ my @menu;
+ my @encoding_defs = ( # use canonical encoding names for radiobutton value
+ ['Unicode (UTF-8)', 'utf-8-strict'],
+ ['Western (iso-8859-1)', 'iso-8859-1'],
+ ['Western (Windows-1252)', 'cp1252'],
+ ["Western with \x{20ac} (iso-8859-15)", 'iso-8859-15'],
+ ['Central European (Windows-1250)', 'cp1250'],
+ );
+ if (!grep { $_->[1] eq Tk::SystemEncoding()->name } @encoding_defs)
+ {
+ unshift @encoding_defs, ['System', Tk::SystemEncoding()->name];
+ }
+
+ for my $encoding_def (@encoding_defs)
+ {
+ my($label, $encoding) = @$encoding_def;
+ push @menu, [ radiobutton => $label,
+ -command => [ $w, Encoding => $encoding ],
+ -variable => \$w->{ENCODINGNAME},
+ -value => $encoding ];
+ }
+ return [ @menu ];
+ }
+
+}
+
+my $top = MainWindow->new();
+
+if ($opt{'server'})
+ {
+ my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp');
+ die "Cannot open listen socket:$!" unless defined $sock;
+ binmode($sock);
+
+ my $port = $sock->sockport;
+ $ENV{'PTKEDPORT'} = $port;
+ open(SN,">$portfile") || die "Cannot open $portfile:$!";
+ print SN $port;
+ close(SN);
+ print "Accepting connections on $port\n";
+ $top->fileevent($sock,'readable',
+ sub
+ {
+ print "accepting $sock\n";
+ my $client = $sock->accept;
+ if (defined $client)
+ {
+ binmode($client);
+ print "Connection $client\n";
+ $top->fileevent($client,'readable',[\&EditRequest,$client]);
+ }
+ });
+ }
+
+Tk::Event::HandleSignals();
+$SIG{'INT'} = sub { $top->WmDeleteWindow };
+
+$top->iconify;
+$top->optionAdd('*TextUndoPtked.Background' => '#fff5e1');
+$top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12),
+ -weight => 'normal', -slant => 'roman');
+$top->optionAdd('*TextUndoPtked.Font' => 'ptked');
+
+if (@ARGV)
+ {
+ foreach my $file (@ARGV)
+ {
+ Create_Edit($file);
+ }
+ }
+else
+ {
+ Create_Edit();
+ }
+
+sub EditRequest
+{
+ my ($client) = @_;
+ local $_;
+ while (<$client>)
+ {
+ chomp($_);
+ print "'$_'\n",
+ Create_Edit($_);
+ }
+ warn "Odd $!" unless eof($client);
+ $top->fileevent($client,'readable','');
+ print "Close $client\n";
+ $client->close;
+}
+
+MainLoop;
+unlink("$portfile");
+exit(0);
+
+sub Create_Edit
+{
+ my $path = shift;
+ my $ed = $top->Toplevel(-title => $path);
+ $ed->withdraw;
+ $top->{'Edits'}++;
+ $ed->OnDestroy([\&RemoveEdit,$top]);
+ my $t = $ed->Scrolled('TextUndoPtked', -wrap => 'none',
+ -scrollbars => 'se', # both required till optional fixed!
+ );
+ $t->pack(-expand => 1, -fill => 'both');
+ $t = $t->Subwidget('scrolled');
+
+ $t->Encoding($opt{encoding} || Tk::SystemEncoding()->name);
+
+ my $menu = $t->menu;
+ $menu->cascade(-label => '~Help', -menuitems => [
+ [Button => '~About...', -command => [\&About,$ed]],
+ ]);
+ $ed->configure(-menu => $menu);
+ my $dd = $t->DragDrop(-event => '<Meta-B1-Motion>');
+ $t->bind(ref($t),'<Meta-B1-Motion>',\&Ouch);
+ $t->bind(ref($t),'<Meta-ButtonPress>',\&Ouch);
+ $t->bind(ref($t),'<Meta-ButtonRelease>',\&Ouch);
+ $dd->configure(-startcommand =>
+ sub
+ {
+ return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')});
+ $dd->configure(-text => $t->get('sel.first','sel.last'));
+ });
+
+ $t->DropSite(-motioncommand =>
+ sub
+ { my ($x,$y) = @_;
+ $t->markSet(insert => "\@$x,$y");
+ },
+ -dropcommand => [\&HandleDrop,$t],
+ );
+
+
+
+ $ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]);
+ $t->bind('<F3>',\&DoFind);
+
+ $ed->idletasks;
+ if (defined $path && -e $path)
+ {
+ $t->Load($path);
+ }
+ else
+ {
+ $t->FileName($path);
+ }
+ $ed->deiconify;
+ $t->update;
+ $t->focus;
+}
+
+sub Ouch
+{
+ warn join(',','Ouch',@_);
+}
+
+sub RemoveEdit
+{
+ my $top = shift;
+ if (--$top->{'Edits'} == 0)
+ {
+ $top->destroy unless $opt{'s'};
+ }
+}
+
+sub HandleDrop
+{my ($t,$seln,$x,$y) = @_;
+ # warn join(',',Drop => @_);
+ my $string;
+ Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') };
+ if ($@)
+ {
+ Tk::catch { $string = $t->SelectionGet(-selection => $seln) };
+ if ($@)
+ {
+ my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS');
+ $t->messageBox(-text => "Targets : ".join(' ',@targets));
+ }
+ else
+ {
+ $t->markSet(insert => "\@$x,$y");
+ $t->insert(insert => $string);
+ }
+ }
+ else
+ {
+ Create_Edit($string);
+ }
+}
+
+
+my $str;
+
+sub DoFind
+{
+ my $t = shift;
+ $str = shift if (@_);
+ my $posn = $t->index('insert+1c');
+ $t->tag('remove','sel','1.0','end');
+ local $_;
+ while ($t->compare($posn,'<','end'))
+ {
+ my ($line,$col) = split(/\./,$posn);
+ $_ = $t->get("$line.0","$posn lineend");
+ pos($_) = $col;
+ if (/\G(.*)$str/g)
+ {
+ $col += length($1);
+ $posn = "$line.$col";
+ $t->SetCursor($posn);
+ $t->tag('add','sel',$posn,"$line.".pos($_));
+ $t->focus;
+ return;
+ }
+ $posn = $t->index("$posn lineend + 1c");
+ }
+}
+
+sub AskFind
+{
+ my ($t) = @_;
+ unless (exists $t->{'AskFind'})
+ {
+ my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw');
+ $d->title('Find...');
+ $d->withdraw;
+ $d->transient($t->toplevel);
+ my $e = $d->Entry->pack;
+ $e->bind('<Return>', sub { $d->withdraw; DoFind($t,$e->get); });
+ $d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]);
+ }
+ $t->{'AskFind'}->Popup;
+ $t->update;
+ $t->{'AskFind'}->focusNext;
+}
+
+sub About
+{
+ my $mw = shift;
+
+ $mw->Dialog(-text => <<"END",-popover => $mw)->Show;
+$0 version $VERSION
+perl$]/Tk$Tk::VERSION
+
+Copyright © 1995-2004 Nick Ing-Simmons. All rights reserved.
+This package is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+END
+}
+
+__END__
+
+=head1 NAME
+
+ptked - an editor in Perl/Tk
+
+=head1 SYNOPSIS
+
+S< >B<ptked> [I<file-to-edit>]
+
+=head1 DESCRIPTION
+
+B<ptked> is a simple text editor based on perl/Tk's TextUndo widget.
+
+=cut
+
+
+
+
+
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/ptksh b/Master/tlpkg/tlperl.straw/bin/ptksh
new file mode 100755
index 00000000000..a606f0b6a8f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptksh
@@ -0,0 +1,730 @@
+#!perl -w
+#
+# PTKSH 2.0
+#
+# A graphical user interface for testing Perl/Tk commands and scripts.
+#
+# VERSION HISTORY:
+# ...truncated earlier stuff...
+# 4/23/98 V1.7 Achim Bohnet -- some fixes to "o" command
+# 6/08/98 V2.01 M. Beller -- merge in GUI code for "wish"-like interface
+#
+# 2.01d1 6/6/98 First development version
+#
+# 2.01d2 6/7/98
+# - apply A.B. patch for pod and -option
+# - fix "use of uninitialized variable" in END{ } block (for -c option)
+# - support h and ? only for help
+# - misc. pod fixes (PITFALLS)
+# - use default fonts and default colors ## NOT YET--still working on it
+# - get rid of Data::Dumper for history
+#
+# 2.01d3 6/8/98
+# - Remove "use Data::Dumper" line
+# - Put in hack for unix vs. win32 window manager focus problem
+# - Achim's pod and histfile patch
+#
+# 2.01d4 6/18/98
+# - Slaven's patch to make <Home> work properly
+# - Add help message to banner (per Steve Lydie)
+# - Fix horizontal scrolling (turn off wrapping in console window)
+# - Clarify <Up> in docs and help means "up arrow"
+# - Use HOMEDRIVE/HOMEPATH on Win32
+#
+# For more history look at the various Changes files in the Perl/Tk
+# distribution.
+
+=head1 NAME
+
+ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk
+commands and scripts.
+
+=head1 SYNOPSIS
+
+ % ptksh ?scriptfile?
+ ... version information ...
+ ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'})
+ ptksh> $b->pack
+ ptksh> o $b
+ ... list of options ...
+ ptksh> help
+ ... help information ...
+ ptksh> exit
+ %
+
+
+=head1 DESCRIPTION
+
+ptksh is a perl/Tk shell to enter perl commands
+interactively. When one starts ptksh a L<MainWindow|Tk::MainWindow>
+is automaticly created, along with a ptksh command window.
+One can access the main window by typing commands using the
+variable $mw at the 'ptksh> ' prompt of the command window.
+
+ptksh supports command line editing and history. Just type "<Up>" at
+the command prompt to see a history list. The last 50 commands entered
+are saved, then reloaded into history list the next time you start ptksh.
+
+ptksh supports some convenient commands for inspecting Tk widgets. See below.
+
+To exit ptksh use: C<exit>.
+
+ptksh is B<*not*> a full symbolic debugger.
+To debug perl/Tk programs at a low level use the more powerful
+L<perl debugger|perldebug>. (Just enter ``O tk'' on debuggers
+command line to start the Tk eventloop.)
+
+=head1 FEATURES
+
+=head2 History
+
+Press <Up> (the Up Arrow) in the perlwish window to obtain a gui-based history list.
+Press <Enter> on any history line to enter it into the perlwish window.
+Then hit return. So, for example, repeat last command is <Up><Enter><Enter>.
+You can quit the history window with <Escape>. NOTE: history is only saved
+if exit is "graceful" (i.e. by the "exit" command from the console or by
+quitting all main windows--NOT by interrupt).
+
+=head2 Debugging Support
+
+ptksh provides some convenience function to make browsing
+in perl/Tk widget easier:
+
+=over 4
+
+=item B<?>, or B<h>
+
+displays a short help summary.
+
+=item B<d>, or B<x> ?I<args>, ...?
+
+Dumps recursively arguments to stdout. (see L<Data::Dumper>).
+You must have <Data::Dumper> installed to support this feature.
+
+B<x> was introduced for perl debugger compatibility.
+
+=item B<p> ?I<arg>, ...?
+
+appends "|\n" to each of it's arguments and prints it.
+If value is B<undef>, '(undef)' is printed to stdout.
+
+=item B<o> I<$widget> ?I<-option> ...?
+
+prints the option(s) of I<$widget> one on each line.
+If no options are given all options of the widget are
+listed. See L<Tk::options> for more details on the
+format and contents of the returned list.
+
+=item B<o> I<$widget> B</>I<regexp>B</>
+
+Lists options of I<$widget> matching the
+L<regular expression|perlre> I<regexp>.
+
+=item B<u> ?I<class>?
+
+If no argument is given it lists the modules loaded
+by the commands you executed or since the last time you
+called C<u>.
+
+If argument is the empty string lists all modules that are
+loaded by ptksh.
+
+If argument is a string, ``text'' it tries to do a ``use Tk::Text;''.
+
+=back
+
+=head2 Packages
+
+Ptksh compiles into package Tk::ptksh. Your code is eval'ed into package
+main. The coolness of this is that your eval code should not interfere with
+ptksh itself.
+
+=head2 Multiline Commands
+
+ptksh will accept multiline commands. Simply put a "\" character immediately
+before the newline, and ptksh will continue your command onto the next line.
+
+=head2 Source File Support
+
+If you have a perl/Tk script that you want to do debugging on, try running the
+command
+
+ ptksh> do 'myscript';
+
+ -- or (at shell command prompt) --
+
+ % ptksh myscript
+
+Then use the perl/Tk commands to try out different operations on your script.
+
+=head1 ENVIRONMENT
+
+Looks for your .ptksh_history in the directory specified by
+the $HOME environment variable ($HOMEPATH on Win32 systems).
+
+=head1 FILES
+
+=over 4
+
+=item F<.ptksh_init>
+
+If found in current directory it is read in an evaluated
+after the mainwindow I<$mw> is created. F<.ptksh_init>
+can contain any valid perl code.
+
+=item F<~/.ptksh_history>
+
+Contains the last 50 lines entered in ptksh session(s).
+
+=back
+
+=head1 PITFALLS
+
+It is best not to use "my" in the commands you type into ptksh.
+For example "my $v" will make $v local just to the command or commands
+entered until <Return> is pressed.
+For a related reason, there are no file-scopy "my" variables in the
+ptksh code itself (else the user might trounce on them by accident).
+
+=head1 BUGS
+
+B<Tk::MainLoop> function interactively entered or sourced in a
+init or script file will block ptksh.
+
+=head1 SEE ALSO
+
+L<Tk|Tk>
+L<perldebug|perldebug>
+
+=head1 VERSION
+
+VERSION 2.03
+
+=head1 AUTHORS
+
+Mike Beller <beller@penvision.com>,
+Achim Bohnet <ach@mpe.mpg.de>
+
+Copyright (c) 1996 - 1998 Achim Bohnet and Mike Beller. 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 Tk::ptksh;
+require 5.004;
+use strict;
+use Tk;
+
+##### Constants
+
+use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE);
+
+$NAME = 'ptksh';
+$VERSION = '2.03';
+$WIN32 = 1 if $^O =~ /Win32/;
+$HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/";
+@FONT = ($WIN32 ? (-font => 'systemfixed') : () );
+#@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () );
+$HISTFILE = "${HOME}.${NAME}_history";
+$HISTSAVE = 50;
+$INITFILE = ".${NAME}_init";
+$PROMPT = "$NAME> ";
+
+sub Win32Fix { my $p = shift; $p =~ s'\\'/'g; $p =~ s'/$''; return $p }
+
+use vars qw($mw $st $t @hist $hist $list $isStartOfCommand);
+
+# NOTE: mainwindow creation order seems to impact who gets focus, and
+# order is different on Win32 & *nix!! So hack is to create the windows
+# in an order dependent on the OS!
+
+$mw = Tk::MainWindow->new unless $WIN32; # &&& hack to work around focus problem
+
+##### set up user's main window
+package main;
+$main::mw = Tk::MainWindow->new;
+$main::mw->title('$mw');
+$main::mw->geometry("+1+1");
+package Tk::ptksh;
+
+##### Set up ptksh windows
+$mw = Tk::MainWindow->new if $WIN32; # &&& hack to work around focus problem
+$mw->title($NAME);
+$st = $mw->Scrolled('Text', -scrollbars => 'osoe',
+ -wrap => 'none',
+ -width => 80, -height => 25, @FONT);
+$t = $st->Subwidget('scrolled');
+$st->pack(-fill => 'both', -expand => 'true');
+# $mw_mapped assures that Center is only called exactly twice: first time
+# will determine geometry of window, second time centering will work.
+# I observed a couple of further <Map> events, which are now ignored
+# and thus window creation seems to be faster now.
+my $mw_mapped;
+$mw->bind('<Map>', sub {return if $mw_mapped && $mw_mapped>=2; Center($mw); $mw_mapped++;} );
+
+# Event bindings
+$t->bindtags([$t, ref($t), $t->toplevel, 'all']); # take first crack at events
+$t->bind('<Return>', \&EvalInput);
+$t->bind('<BackSpace>', \&BackSpace);
+$t->bind('<Escape>', \&HistKill);
+$t->bind('<Up>', \&History);
+$t->bind('<Control-a>', \&BeginLine);
+$t->bind('<Home>', \&BeginLine);
+$t->bind('<Any-KeyPress>', [\&Key, Tk::Ev('K'), Tk::Ev('A')]);
+
+my $default_font = $t->cget(-font);
+my %default_font = $t->fontActual($default_font);
+my $normal_font;
+if (!$t->fontMetrics($default_font, '-fixed')) {
+ $normal_font = $t->fontCreate(%default_font, -family => "courier");
+ $t->configure(-font => $normal_font);
+} else {
+ $normal_font = $default_font;
+}
+my %normal_font = $t->fontActual($normal_font);
+my $bold_font = $t->fontCreate(%normal_font, -weight => "bold");
+
+# Set up different colors for the various window outputs
+#$t->tagConfigure('prompt', -underline => 'true');
+$t->tagConfigure('prompt', -foreground => 'blue', -font => $bold_font);
+$t->tagConfigure('result', -foreground => 'purple');
+$t->tagConfigure('error', -foreground => 'red');
+$t->tagConfigure('output', -foreground => 'blue');
+
+# The tag 'limit' is the beginning of the input command line
+$t->markSet('limit', 'insert');
+$t->markGravity('limit', 'left');
+
+# redirect stdout
+#tie (*STDOUT, 'Tk::Text', $t);
+tie (*STDOUT, 'Tk::ptksh');
+#tie (*STDERR, 'Tk::ptksh');
+
+# Print banner
+print "$NAME V$VERSION";
+print " perl V$] Tk V$Tk::VERSION MainWindow -> \$mw\n";
+print "\n\t\@INC:\n";
+foreach (@INC) { print "\t $_\n" };
+print "Type 'h<Return>' at the prompt for help\n";
+
+##### Read .ptkshinit
+if ( -r $INITFILE)
+ {
+ print "Reading $INITFILE ...\n";
+ package main;
+ do $Tk::ptksh::INITFILE;
+ package Tk::ptksh;
+ }
+
+###### Source the file if given as argument 0
+if (defined($ARGV[0]) && -r $ARGV[0])
+ {
+ print "Reading $ARGV[0] ...\n";
+ package main;
+ do $ARGV[0];
+ package Tk::ptksh;
+ }
+
+##### Read history
+@hist = ();
+if ( -r $HISTFILE and open(HIST, $HISTFILE) ) {
+ print "Reading history ...\n";
+ my $c = "";
+ while (<HIST>) {
+ chomp;
+ $c .= $_;
+ if ($_ !~ /\\$/) { #end of command if no trailing "\"
+ push @hist, $c;
+ $c = "";
+ } else {
+ chop $c; # kill trailing "\"
+ $c .= "\n";
+ }
+ }
+ close HIST;
+}
+
+##### Initial prompt
+Prompt($PROMPT);
+$Tk::ptksh::mw->focus;
+$t->focus;
+#$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;});
+
+##### Now enter main loop
+#$mw->afterIdle(sub {Center($mw);});
+MainLoop();
+
+####### Callbacks/etc.
+
+# EvalInput -- Eval the input area (between 'limit' and 'insert')
+# in package main;
+use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval'
+sub EvalInput {
+ # If return is hit when not inside the command entry range, reprompt
+ if ($t->compare('insert', '<=', 'limit')) {
+ $t->markSet('insert', 'end');
+ Prompt($PROMPT);
+ Tk->break;
+ }
+
+ # Support multi-line commands
+ if ($t->get('insert-1c', 'insert') eq "\\") {
+ $t->insert('insert', "\n");
+ $t->insert('insert', "> ", 'prompt'); # must use this pattern for continue
+ $t->see('insert');
+ Tk->break;
+ }
+
+ # Get the command and strip out continuations
+ $command = $t->get('limit','end');
+ $t->markSet('insert','end');
+ $command =~ s/\\\n>\s/\n/mg;
+
+ # Eval it
+ if ( $command !~ /^\s*$/) {
+ chomp $command;
+ push(@hist, $command)
+ unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy
+
+ $t->insert('insert', "\n");
+
+ $isStartOfCommand = 1;
+
+ $command = PtkshCommand($command);
+
+ exit if ($command eq 'exit');
+
+ package main;
+ no strict;
+ $Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;";
+ use strict;
+ package Tk::ptksh;
+
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+ if ($@) {
+ $t->insert('insert', '## ' . $@, 'error');
+ } else {
+ $result = "" if !defined($result);
+ $t->insert('insert', '# ' . $result, 'result');
+ }
+ }
+
+ Prompt($PROMPT);
+
+ Tk->break;
+}
+
+sub Prompt {
+ my $pr = shift;
+
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+
+ $t->insert('insert', $pr, 'prompt');
+ $t->see('insert');
+ $t->markSet('limit', 'insert');
+
+}
+
+sub BackSpace {
+ if ($t->tagNextrange('sel', '1.0', 'end')) {
+ $t->delete('sel.first', 'sel.last');
+ } elsif ($t->compare('insert', '>', 'limit')) {
+ $t->delete('insert-1c');
+ $t->see('insert');
+ }
+ Tk->break;
+}
+
+sub BeginLine {
+ $t->SetCursor('limit');
+ $t->break;
+}
+
+sub Key {
+ my ($self, $k, $a) = @_;
+ #print "key event: ", $k, "\n";
+ if ($t->compare('insert', '<', 'limit')) {
+ $t->markSet('insert', 'end');
+ }
+ #$t->break; #for testing bindtags
+}
+
+sub History {
+ Tk->break if defined($hist);
+
+ $hist = $mw->Toplevel;
+ $hist->title('History');
+ $list = $hist->ScrlListbox(-scrollbars => 'oe',
+ -width => 30, -height => 10, @FONT)->pack(qw(-fill both -expand 1));
+ Center($hist);
+ $list->insert('end', @hist);
+ $list->see('end');
+ $list->activate('end');
+ $hist->bind('<Double-1>', \&HistPick);
+ $hist->bind('<Return>', \&HistPick);
+ $hist->bind('<Escape>', \&HistKill);
+ my $hist_mapped; # see above for $mw_mapped
+ $hist->bind('<Map>', sub {return if $hist_mapped && $hist_mapped>=2; Center($hist); $hist_mapped++;} );
+ $hist->bind('<Destroy>', \&HistDestroy);
+ $hist->focus;
+ $list->focus;
+ $hist->grab;
+ #$mw->afterIdle(sub {Center($hist);});
+ Tk->break;
+}
+
+sub HistPick {
+ my $item = $list->get('active');
+ return if (!$item);
+ $t->markSet('insert', 'end');
+ $t->insert('insert',$item);
+ $t->see('insert');
+ $mw->focus;
+ $t->focus;
+ HistKill();
+}
+
+sub HistKill {
+ if ($hist) {
+ $hist->grabRelease;
+ $hist->destroy;
+ }
+}
+
+# Called from destroy event mapping
+sub HistDestroy {
+ if (defined($hist) && (shift == $hist)) {
+ $hist = undef;
+ $mw->focus;
+ $t->focus;
+ }
+}
+
+sub LastCommand {
+ if ($t->compare('insert', '==', 'limit')) {
+ $t->insert('insert', $hist[$#hist]);
+ $t->break;
+ }
+}
+
+# Center a toplevel on screen or above parent
+sub Center {
+ my $w = shift;
+ my ($x, $y);
+
+ if ($w->parent) {
+ #print STDERR $w->screenwidth, " ", $w->width, "\n";
+ $x = $w->parent->x + ($w->parent->width - $w->width)/2;
+ $y = $w->parent->y + ($w->parent->height - $w->height)/2;
+ } else {
+ #print STDERR $w->screenwidth, " ", $w->width, "\n";
+ $x = ($w->screenwidth - $w->width)/2;
+ $y = ($w->screenheight - $w->height)/2;
+ }
+ $x = int($x);
+ $y = int($y);
+ my $g = "+$x+$y";
+ #print STDERR "Setting geometry to $g\n";
+ $w->geometry($g);
+}
+
+# To deal with "TIE".
+# We have to make sure the prints don't go into the command entry range.
+
+sub TIEHANDLE { # just to capture the tied calls
+ my $self = [];
+ return bless $self;
+
+}
+
+sub PRINT {
+ my ($bogus) = shift;
+
+ $t->markSet('insert', 'end');
+
+ if ($isStartOfCommand) { # Then no prints have happened in this command yet so...
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+ # set flag so we know at least one print happened in this eval
+ $isStartOfCommand = 0;
+ }
+
+ while (@_) {
+ $t->insert('end', shift, 'output');
+ }
+
+ $t->see('insert');
+
+ $t->markSet('limit', 'insert'); # don't interpret print as an input command
+}
+
+sub PRINTF
+{
+ my $w = shift;
+ $w->PRINT(sprintf(shift,@_));
+}
+
+###
+### Utility function
+###
+
+sub _o
+ {
+ my $w = shift;
+ my $what = shift;
+
+ $what =~ s/^\s+//;
+ $what =~ s/\s+$//;
+ my (@opt) = split " ", $what;
+
+ print 'o(', join('|', @opt), ")\n";
+ require Tk::Pretty;
+
+ # check for regexp
+ if ($opt[0] =~ s|^/(.*)/$|$1|)
+ {
+ print "options matching /$opt[0]/:\n";
+ foreach ($w->configure())
+ {
+ print Tk::Pretty::Pretty($_),"\n" if $_->[0] =~ /\Q$opt[0]\E/;
+ }
+ return;
+ }
+
+ # list of options (allow as bar words)
+ foreach (@opt)
+ {
+ s/^['"]//;
+ s/,$//;
+ s/['"]$//;
+ s/^([^-])/-$1/;
+ }
+ if (length $what)
+ {
+ foreach (@opt)
+ {
+ print Tk::Pretty::Pretty($w->configure($_)),"\n";
+ }
+ }
+ else
+ {
+ foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" }
+ }
+ }
+
+sub _p {
+ foreach (@_) { print $_, "|\n"; }
+}
+
+use vars qw($u_init %u_last $u_cnt);
+$u_init = 0;
+%u_last = ();
+sub _u {
+ my $module = shift;
+ if (defined($module) and $module ne '') {
+ $module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/;
+ print " --- Loading $module ---\n";
+ require "$module";
+ print $@ if $@;
+ } else {
+ %u_last = () if defined $module;
+ $u_cnt = 0;
+ foreach (sort keys %INC) {
+ next if exists $u_last{$_};
+ $u_cnt++;
+ $u_last{$_} = 1;
+ #next if m,^/, and m,\.ix$,; # Ignore autoloader files
+ #next if m,\.ix$,; # Ignore autoloader files
+
+ if (length($_) < 20 ) {
+ printf "%-20s -> %s\n", $_, $INC{$_};
+ } else {
+ print "$_ -> $INC{$_}\n";
+ }
+ }
+ print STDERR "No modules loaded since last 'u' command (or startup)\n"
+ unless $u_cnt;
+ }
+}
+
+sub _d
+ {
+ require Data::Dumper;
+ local $Data::Dumper::Deparse;
+ $Data::Dumper::Deparse = 1;
+ print Data::Dumper::Dumper(@_);
+ }
+
+sub _h
+ {
+ print <<'EOT';
+
+ ? or h print this message
+ d or x arg,... calls Data::Dumper::Dumper
+ p arg,... print args, each on a line and "|\n"
+ o $w /regexp/ print options of widget matching regexp
+ o $w [opt ...] print (all) options of widget
+ u xxx xxx = string : load Tk::Xxx
+ = '' : list all modules loaded
+ = undef : list modules loaded since last u call
+ (or after ptksh startup)
+
+ Press <Up> (the "up arrow" key) for command history
+ Press <Escape> to leave command history window
+ Type "exit" to quit (saves history)
+ Type \<Return> for continuation of command to following line
+
+EOT
+}
+
+
+# Substitute our special commands into the command line
+sub PtkshCommand {
+ $_ = shift;
+
+ foreach ($_) {
+ last if s/^\?\s*$/Tk::ptksh::_h /;
+ last if s/^h\s*$/Tk::ptksh::_h /;
+ last if s/^u(\s+|$)/Tk::ptksh::_u /;
+ last if s/^[dx]\s+/Tk::ptksh::_d /;
+ last if s/^u\s+(\S+)/Tk::ptksh::_u('$1')/;
+ last if s/^p\s+(.*)$/Tk::ptksh::_p $1;/;
+ last if s/^o\s+(\S+)\s*?$/Tk::ptksh::_o $1;/;
+ last if s/^o\s+(\S+)\s*,?\s+(.*)?$/Tk::ptksh::_o $1, '$2';/;
+ }
+ %u_last = %INC unless $u_init++;
+
+ # print STDERR "Command is: $_\n";
+
+ $_;
+}
+
+###
+### Save History -- use Data::Dumper to preserve multiline commands
+###
+
+END {
+ if ($HISTFILE) { # because this is probably perl -c if $HISTFILE is not set
+ $#hist-- if $hist[-1] =~ /^(q$|x$|\s*exit\b)/; # chop off the exit command
+
+ @hist = @hist[($#hist-$HISTSAVE)..($#hist)] if $#hist > $HISTSAVE;
+
+ if( open HIST, ">$HISTFILE" ) {
+ while ($_ = shift(@hist)) {
+ s/\n/\\\n/mg;
+ print HIST "$_\n";
+ }
+ close HIST;
+ } else {
+ print STDERR "Error: Unable to open history file '$HISTFILE'\n";
+ }
+ }
+}
+
+1; # just in case we decide to be "use"'able in the future.
diff --git a/Master/tlpkg/tlperl.straw/bin/ptksh.bat b/Master/tlpkg/tlperl.straw/bin/ptksh.bat
new file mode 100755
index 00000000000..ff42a69076f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/ptksh.bat
@@ -0,0 +1,746 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+#
+# PTKSH 2.0
+#
+# A graphical user interface for testing Perl/Tk commands and scripts.
+#
+# VERSION HISTORY:
+# ...truncated earlier stuff...
+# 4/23/98 V1.7 Achim Bohnet -- some fixes to "o" command
+# 6/08/98 V2.01 M. Beller -- merge in GUI code for "wish"-like interface
+#
+# 2.01d1 6/6/98 First development version
+#
+# 2.01d2 6/7/98
+# - apply A.B. patch for pod and -option
+# - fix "use of uninitialized variable" in END{ } block (for -c option)
+# - support h and ? only for help
+# - misc. pod fixes (PITFALLS)
+# - use default fonts and default colors ## NOT YET--still working on it
+# - get rid of Data::Dumper for history
+#
+# 2.01d3 6/8/98
+# - Remove "use Data::Dumper" line
+# - Put in hack for unix vs. win32 window manager focus problem
+# - Achim's pod and histfile patch
+#
+# 2.01d4 6/18/98
+# - Slaven's patch to make <Home> work properly
+# - Add help message to banner (per Steve Lydie)
+# - Fix horizontal scrolling (turn off wrapping in console window)
+# - Clarify <Up> in docs and help means "up arrow"
+# - Use HOMEDRIVE/HOMEPATH on Win32
+#
+# For more history look at the various Changes files in the Perl/Tk
+# distribution.
+
+=head1 NAME
+
+ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk
+commands and scripts.
+
+=head1 SYNOPSIS
+
+ % ptksh ?scriptfile?
+ ... version information ...
+ ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'})
+ ptksh> $b->pack
+ ptksh> o $b
+ ... list of options ...
+ ptksh> help
+ ... help information ...
+ ptksh> exit
+ %
+
+
+=head1 DESCRIPTION
+
+ptksh is a perl/Tk shell to enter perl commands
+interactively. When one starts ptksh a L<MainWindow|Tk::MainWindow>
+is automaticly created, along with a ptksh command window.
+One can access the main window by typing commands using the
+variable $mw at the 'ptksh> ' prompt of the command window.
+
+ptksh supports command line editing and history. Just type "<Up>" at
+the command prompt to see a history list. The last 50 commands entered
+are saved, then reloaded into history list the next time you start ptksh.
+
+ptksh supports some convenient commands for inspecting Tk widgets. See below.
+
+To exit ptksh use: C<exit>.
+
+ptksh is B<*not*> a full symbolic debugger.
+To debug perl/Tk programs at a low level use the more powerful
+L<perl debugger|perldebug>. (Just enter ``O tk'' on debuggers
+command line to start the Tk eventloop.)
+
+=head1 FEATURES
+
+=head2 History
+
+Press <Up> (the Up Arrow) in the perlwish window to obtain a gui-based history list.
+Press <Enter> on any history line to enter it into the perlwish window.
+Then hit return. So, for example, repeat last command is <Up><Enter><Enter>.
+You can quit the history window with <Escape>. NOTE: history is only saved
+if exit is "graceful" (i.e. by the "exit" command from the console or by
+quitting all main windows--NOT by interrupt).
+
+=head2 Debugging Support
+
+ptksh provides some convenience function to make browsing
+in perl/Tk widget easier:
+
+=over 4
+
+=item B<?>, or B<h>
+
+displays a short help summary.
+
+=item B<d>, or B<x> ?I<args>, ...?
+
+Dumps recursively arguments to stdout. (see L<Data::Dumper>).
+You must have <Data::Dumper> installed to support this feature.
+
+B<x> was introduced for perl debugger compatibility.
+
+=item B<p> ?I<arg>, ...?
+
+appends "|\n" to each of it's arguments and prints it.
+If value is B<undef>, '(undef)' is printed to stdout.
+
+=item B<o> I<$widget> ?I<-option> ...?
+
+prints the option(s) of I<$widget> one on each line.
+If no options are given all options of the widget are
+listed. See L<Tk::options> for more details on the
+format and contents of the returned list.
+
+=item B<o> I<$widget> B</>I<regexp>B</>
+
+Lists options of I<$widget> matching the
+L<regular expression|perlre> I<regexp>.
+
+=item B<u> ?I<class>?
+
+If no argument is given it lists the modules loaded
+by the commands you executed or since the last time you
+called C<u>.
+
+If argument is the empty string lists all modules that are
+loaded by ptksh.
+
+If argument is a string, ``text'' it tries to do a ``use Tk::Text;''.
+
+=back
+
+=head2 Packages
+
+Ptksh compiles into package Tk::ptksh. Your code is eval'ed into package
+main. The coolness of this is that your eval code should not interfere with
+ptksh itself.
+
+=head2 Multiline Commands
+
+ptksh will accept multiline commands. Simply put a "\" character immediately
+before the newline, and ptksh will continue your command onto the next line.
+
+=head2 Source File Support
+
+If you have a perl/Tk script that you want to do debugging on, try running the
+command
+
+ ptksh> do 'myscript';
+
+ -- or (at shell command prompt) --
+
+ % ptksh myscript
+
+Then use the perl/Tk commands to try out different operations on your script.
+
+=head1 ENVIRONMENT
+
+Looks for your .ptksh_history in the directory specified by
+the $HOME environment variable ($HOMEPATH on Win32 systems).
+
+=head1 FILES
+
+=over 4
+
+=item F<.ptksh_init>
+
+If found in current directory it is read in an evaluated
+after the mainwindow I<$mw> is created. F<.ptksh_init>
+can contain any valid perl code.
+
+=item F<~/.ptksh_history>
+
+Contains the last 50 lines entered in ptksh session(s).
+
+=back
+
+=head1 PITFALLS
+
+It is best not to use "my" in the commands you type into ptksh.
+For example "my $v" will make $v local just to the command or commands
+entered until <Return> is pressed.
+For a related reason, there are no file-scopy "my" variables in the
+ptksh code itself (else the user might trounce on them by accident).
+
+=head1 BUGS
+
+B<Tk::MainLoop> function interactively entered or sourced in a
+init or script file will block ptksh.
+
+=head1 SEE ALSO
+
+L<Tk|Tk>
+L<perldebug|perldebug>
+
+=head1 VERSION
+
+VERSION 2.03
+
+=head1 AUTHORS
+
+Mike Beller <beller@penvision.com>,
+Achim Bohnet <ach@mpe.mpg.de>
+
+Copyright (c) 1996 - 1998 Achim Bohnet and Mike Beller. 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 Tk::ptksh;
+require 5.004;
+use strict;
+use Tk;
+
+##### Constants
+
+use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE);
+
+$NAME = 'ptksh';
+$VERSION = '2.03';
+$WIN32 = 1 if $^O =~ /Win32/;
+$HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/";
+@FONT = ($WIN32 ? (-font => 'systemfixed') : () );
+#@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () );
+$HISTFILE = "${HOME}.${NAME}_history";
+$HISTSAVE = 50;
+$INITFILE = ".${NAME}_init";
+$PROMPT = "$NAME> ";
+
+sub Win32Fix { my $p = shift; $p =~ s'\\'/'g; $p =~ s'/$''; return $p }
+
+use vars qw($mw $st $t @hist $hist $list $isStartOfCommand);
+
+# NOTE: mainwindow creation order seems to impact who gets focus, and
+# order is different on Win32 & *nix!! So hack is to create the windows
+# in an order dependent on the OS!
+
+$mw = Tk::MainWindow->new unless $WIN32; # &&& hack to work around focus problem
+
+##### set up user's main window
+package main;
+$main::mw = Tk::MainWindow->new;
+$main::mw->title('$mw');
+$main::mw->geometry("+1+1");
+package Tk::ptksh;
+
+##### Set up ptksh windows
+$mw = Tk::MainWindow->new if $WIN32; # &&& hack to work around focus problem
+$mw->title($NAME);
+$st = $mw->Scrolled('Text', -scrollbars => 'osoe',
+ -wrap => 'none',
+ -width => 80, -height => 25, @FONT);
+$t = $st->Subwidget('scrolled');
+$st->pack(-fill => 'both', -expand => 'true');
+# $mw_mapped assures that Center is only called exactly twice: first time
+# will determine geometry of window, second time centering will work.
+# I observed a couple of further <Map> events, which are now ignored
+# and thus window creation seems to be faster now.
+my $mw_mapped;
+$mw->bind('<Map>', sub {return if $mw_mapped && $mw_mapped>=2; Center($mw); $mw_mapped++;} );
+
+# Event bindings
+$t->bindtags([$t, ref($t), $t->toplevel, 'all']); # take first crack at events
+$t->bind('<Return>', \&EvalInput);
+$t->bind('<BackSpace>', \&BackSpace);
+$t->bind('<Escape>', \&HistKill);
+$t->bind('<Up>', \&History);
+$t->bind('<Control-a>', \&BeginLine);
+$t->bind('<Home>', \&BeginLine);
+$t->bind('<Any-KeyPress>', [\&Key, Tk::Ev('K'), Tk::Ev('A')]);
+
+my $default_font = $t->cget(-font);
+my %default_font = $t->fontActual($default_font);
+my $normal_font;
+if (!$t->fontMetrics($default_font, '-fixed')) {
+ $normal_font = $t->fontCreate(%default_font, -family => "courier");
+ $t->configure(-font => $normal_font);
+} else {
+ $normal_font = $default_font;
+}
+my %normal_font = $t->fontActual($normal_font);
+my $bold_font = $t->fontCreate(%normal_font, -weight => "bold");
+
+# Set up different colors for the various window outputs
+#$t->tagConfigure('prompt', -underline => 'true');
+$t->tagConfigure('prompt', -foreground => 'blue', -font => $bold_font);
+$t->tagConfigure('result', -foreground => 'purple');
+$t->tagConfigure('error', -foreground => 'red');
+$t->tagConfigure('output', -foreground => 'blue');
+
+# The tag 'limit' is the beginning of the input command line
+$t->markSet('limit', 'insert');
+$t->markGravity('limit', 'left');
+
+# redirect stdout
+#tie (*STDOUT, 'Tk::Text', $t);
+tie (*STDOUT, 'Tk::ptksh');
+#tie (*STDERR, 'Tk::ptksh');
+
+# Print banner
+print "$NAME V$VERSION";
+print " perl V$] Tk V$Tk::VERSION MainWindow -> \$mw\n";
+print "\n\t\@INC:\n";
+foreach (@INC) { print "\t $_\n" };
+print "Type 'h<Return>' at the prompt for help\n";
+
+##### Read .ptkshinit
+if ( -r $INITFILE)
+ {
+ print "Reading $INITFILE ...\n";
+ package main;
+ do $Tk::ptksh::INITFILE;
+ package Tk::ptksh;
+ }
+
+###### Source the file if given as argument 0
+if (defined($ARGV[0]) && -r $ARGV[0])
+ {
+ print "Reading $ARGV[0] ...\n";
+ package main;
+ do $ARGV[0];
+ package Tk::ptksh;
+ }
+
+##### Read history
+@hist = ();
+if ( -r $HISTFILE and open(HIST, $HISTFILE) ) {
+ print "Reading history ...\n";
+ my $c = "";
+ while (<HIST>) {
+ chomp;
+ $c .= $_;
+ if ($_ !~ /\\$/) { #end of command if no trailing "\"
+ push @hist, $c;
+ $c = "";
+ } else {
+ chop $c; # kill trailing "\"
+ $c .= "\n";
+ }
+ }
+ close HIST;
+}
+
+##### Initial prompt
+Prompt($PROMPT);
+$Tk::ptksh::mw->focus;
+$t->focus;
+#$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;});
+
+##### Now enter main loop
+#$mw->afterIdle(sub {Center($mw);});
+MainLoop();
+
+####### Callbacks/etc.
+
+# EvalInput -- Eval the input area (between 'limit' and 'insert')
+# in package main;
+use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval'
+sub EvalInput {
+ # If return is hit when not inside the command entry range, reprompt
+ if ($t->compare('insert', '<=', 'limit')) {
+ $t->markSet('insert', 'end');
+ Prompt($PROMPT);
+ Tk->break;
+ }
+
+ # Support multi-line commands
+ if ($t->get('insert-1c', 'insert') eq "\\") {
+ $t->insert('insert', "\n");
+ $t->insert('insert', "> ", 'prompt'); # must use this pattern for continue
+ $t->see('insert');
+ Tk->break;
+ }
+
+ # Get the command and strip out continuations
+ $command = $t->get('limit','end');
+ $t->markSet('insert','end');
+ $command =~ s/\\\n>\s/\n/mg;
+
+ # Eval it
+ if ( $command !~ /^\s*$/) {
+ chomp $command;
+ push(@hist, $command)
+ unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy
+
+ $t->insert('insert', "\n");
+
+ $isStartOfCommand = 1;
+
+ $command = PtkshCommand($command);
+
+ exit if ($command eq 'exit');
+
+ package main;
+ no strict;
+ $Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;";
+ use strict;
+ package Tk::ptksh;
+
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+ if ($@) {
+ $t->insert('insert', '## ' . $@, 'error');
+ } else {
+ $result = "" if !defined($result);
+ $t->insert('insert', '# ' . $result, 'result');
+ }
+ }
+
+ Prompt($PROMPT);
+
+ Tk->break;
+}
+
+sub Prompt {
+ my $pr = shift;
+
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+
+ $t->insert('insert', $pr, 'prompt');
+ $t->see('insert');
+ $t->markSet('limit', 'insert');
+
+}
+
+sub BackSpace {
+ if ($t->tagNextrange('sel', '1.0', 'end')) {
+ $t->delete('sel.first', 'sel.last');
+ } elsif ($t->compare('insert', '>', 'limit')) {
+ $t->delete('insert-1c');
+ $t->see('insert');
+ }
+ Tk->break;
+}
+
+sub BeginLine {
+ $t->SetCursor('limit');
+ $t->break;
+}
+
+sub Key {
+ my ($self, $k, $a) = @_;
+ #print "key event: ", $k, "\n";
+ if ($t->compare('insert', '<', 'limit')) {
+ $t->markSet('insert', 'end');
+ }
+ #$t->break; #for testing bindtags
+}
+
+sub History {
+ Tk->break if defined($hist);
+
+ $hist = $mw->Toplevel;
+ $hist->title('History');
+ $list = $hist->ScrlListbox(-scrollbars => 'oe',
+ -width => 30, -height => 10, @FONT)->pack(qw(-fill both -expand 1));
+ Center($hist);
+ $list->insert('end', @hist);
+ $list->see('end');
+ $list->activate('end');
+ $hist->bind('<Double-1>', \&HistPick);
+ $hist->bind('<Return>', \&HistPick);
+ $hist->bind('<Escape>', \&HistKill);
+ my $hist_mapped; # see above for $mw_mapped
+ $hist->bind('<Map>', sub {return if $hist_mapped && $hist_mapped>=2; Center($hist); $hist_mapped++;} );
+ $hist->bind('<Destroy>', \&HistDestroy);
+ $hist->focus;
+ $list->focus;
+ $hist->grab;
+ #$mw->afterIdle(sub {Center($hist);});
+ Tk->break;
+}
+
+sub HistPick {
+ my $item = $list->get('active');
+ return if (!$item);
+ $t->markSet('insert', 'end');
+ $t->insert('insert',$item);
+ $t->see('insert');
+ $mw->focus;
+ $t->focus;
+ HistKill();
+}
+
+sub HistKill {
+ if ($hist) {
+ $hist->grabRelease;
+ $hist->destroy;
+ }
+}
+
+# Called from destroy event mapping
+sub HistDestroy {
+ if (defined($hist) && (shift == $hist)) {
+ $hist = undef;
+ $mw->focus;
+ $t->focus;
+ }
+}
+
+sub LastCommand {
+ if ($t->compare('insert', '==', 'limit')) {
+ $t->insert('insert', $hist[$#hist]);
+ $t->break;
+ }
+}
+
+# Center a toplevel on screen or above parent
+sub Center {
+ my $w = shift;
+ my ($x, $y);
+
+ if ($w->parent) {
+ #print STDERR $w->screenwidth, " ", $w->width, "\n";
+ $x = $w->parent->x + ($w->parent->width - $w->width)/2;
+ $y = $w->parent->y + ($w->parent->height - $w->height)/2;
+ } else {
+ #print STDERR $w->screenwidth, " ", $w->width, "\n";
+ $x = ($w->screenwidth - $w->width)/2;
+ $y = ($w->screenheight - $w->height)/2;
+ }
+ $x = int($x);
+ $y = int($y);
+ my $g = "+$x+$y";
+ #print STDERR "Setting geometry to $g\n";
+ $w->geometry($g);
+}
+
+# To deal with "TIE".
+# We have to make sure the prints don't go into the command entry range.
+
+sub TIEHANDLE { # just to capture the tied calls
+ my $self = [];
+ return bless $self;
+
+}
+
+sub PRINT {
+ my ($bogus) = shift;
+
+ $t->markSet('insert', 'end');
+
+ if ($isStartOfCommand) { # Then no prints have happened in this command yet so...
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+ # set flag so we know at least one print happened in this eval
+ $isStartOfCommand = 0;
+ }
+
+ while (@_) {
+ $t->insert('end', shift, 'output');
+ }
+
+ $t->see('insert');
+
+ $t->markSet('limit', 'insert'); # don't interpret print as an input command
+}
+
+sub PRINTF
+{
+ my $w = shift;
+ $w->PRINT(sprintf(shift,@_));
+}
+
+###
+### Utility function
+###
+
+sub _o
+ {
+ my $w = shift;
+ my $what = shift;
+
+ $what =~ s/^\s+//;
+ $what =~ s/\s+$//;
+ my (@opt) = split " ", $what;
+
+ print 'o(', join('|', @opt), ")\n";
+ require Tk::Pretty;
+
+ # check for regexp
+ if ($opt[0] =~ s|^/(.*)/$|$1|)
+ {
+ print "options matching /$opt[0]/:\n";
+ foreach ($w->configure())
+ {
+ print Tk::Pretty::Pretty($_),"\n" if $_->[0] =~ /\Q$opt[0]\E/;
+ }
+ return;
+ }
+
+ # list of options (allow as bar words)
+ foreach (@opt)
+ {
+ s/^['"]//;
+ s/,$//;
+ s/['"]$//;
+ s/^([^-])/-$1/;
+ }
+ if (length $what)
+ {
+ foreach (@opt)
+ {
+ print Tk::Pretty::Pretty($w->configure($_)),"\n";
+ }
+ }
+ else
+ {
+ foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" }
+ }
+ }
+
+sub _p {
+ foreach (@_) { print $_, "|\n"; }
+}
+
+use vars qw($u_init %u_last $u_cnt);
+$u_init = 0;
+%u_last = ();
+sub _u {
+ my $module = shift;
+ if (defined($module) and $module ne '') {
+ $module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/;
+ print " --- Loading $module ---\n";
+ require "$module";
+ print $@ if $@;
+ } else {
+ %u_last = () if defined $module;
+ $u_cnt = 0;
+ foreach (sort keys %INC) {
+ next if exists $u_last{$_};
+ $u_cnt++;
+ $u_last{$_} = 1;
+ #next if m,^/, and m,\.ix$,; # Ignore autoloader files
+ #next if m,\.ix$,; # Ignore autoloader files
+
+ if (length($_) < 20 ) {
+ printf "%-20s -> %s\n", $_, $INC{$_};
+ } else {
+ print "$_ -> $INC{$_}\n";
+ }
+ }
+ print STDERR "No modules loaded since last 'u' command (or startup)\n"
+ unless $u_cnt;
+ }
+}
+
+sub _d
+ {
+ require Data::Dumper;
+ local $Data::Dumper::Deparse;
+ $Data::Dumper::Deparse = 1;
+ print Data::Dumper::Dumper(@_);
+ }
+
+sub _h
+ {
+ print <<'EOT';
+
+ ? or h print this message
+ d or x arg,... calls Data::Dumper::Dumper
+ p arg,... print args, each on a line and "|\n"
+ o $w /regexp/ print options of widget matching regexp
+ o $w [opt ...] print (all) options of widget
+ u xxx xxx = string : load Tk::Xxx
+ = '' : list all modules loaded
+ = undef : list modules loaded since last u call
+ (or after ptksh startup)
+
+ Press <Up> (the "up arrow" key) for command history
+ Press <Escape> to leave command history window
+ Type "exit" to quit (saves history)
+ Type \<Return> for continuation of command to following line
+
+EOT
+}
+
+
+# Substitute our special commands into the command line
+sub PtkshCommand {
+ $_ = shift;
+
+ foreach ($_) {
+ last if s/^\?\s*$/Tk::ptksh::_h /;
+ last if s/^h\s*$/Tk::ptksh::_h /;
+ last if s/^u(\s+|$)/Tk::ptksh::_u /;
+ last if s/^[dx]\s+/Tk::ptksh::_d /;
+ last if s/^u\s+(\S+)/Tk::ptksh::_u('$1')/;
+ last if s/^p\s+(.*)$/Tk::ptksh::_p $1;/;
+ last if s/^o\s+(\S+)\s*?$/Tk::ptksh::_o $1;/;
+ last if s/^o\s+(\S+)\s*,?\s+(.*)?$/Tk::ptksh::_o $1, '$2';/;
+ }
+ %u_last = %INC unless $u_init++;
+
+ # print STDERR "Command is: $_\n";
+
+ $_;
+}
+
+###
+### Save History -- use Data::Dumper to preserve multiline commands
+###
+
+END {
+ if ($HISTFILE) { # because this is probably perl -c if $HISTFILE is not set
+ $#hist-- if $hist[-1] =~ /^(q$|x$|\s*exit\b)/; # chop off the exit command
+
+ @hist = @hist[($#hist-$HISTSAVE)..($#hist)] if $#hist > $HISTSAVE;
+
+ if( open HIST, ">$HISTFILE" ) {
+ while ($_ = shift(@hist)) {
+ s/\n/\\\n/mg;
+ print HIST "$_\n";
+ }
+ close HIST;
+ } else {
+ print STDERR "Error: Unable to open history file '$HISTFILE'\n";
+ }
+ }
+}
+
+1; # just in case we decide to be "use"'able in the future.
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/pwhich b/Master/tlpkg/tlperl.straw/bin/pwhich
new file mode 100755
index 00000000000..a20dc07fff0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pwhich
@@ -0,0 +1,141 @@
+#!/usr/bin/perl
+
+use 5.004;
+use strict;
+use File::Which ();
+use Getopt::Std ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.09';
+}
+
+# Handle options
+my %opts = ();
+Getopt::Std::getopts('av', \%opts);
+
+if ( $opts{v} ) {
+ print <<"END_TEXT";
+This is pwhich running File::Which version $File::Which::VERSION
+
+Copyright 2002 Per Einar Ellefsen.
+
+Some parts copyright 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+END_TEXT
+
+ exit(0);
+}
+
+unless ( @ARGV ) {
+ print <<"END_TEXT";
+Usage: $0 [-a] [-v] programname [programname ...]
+ -a Print all matches in PATH, not just the first.
+ -v Prints version and exits
+
+END_TEXT
+
+ exit(0);
+}
+
+foreach my $file ( @ARGV ) {
+ my @result = $opts{a}
+ ? File::Which::which($file)
+ # Need to force scalar
+ : scalar File::Which::which($file);
+
+ # We might end up with @result = (undef) -> 1 elem
+ @result = () unless defined $result[0];
+ foreach my $result ( @result ) {
+ print "$result\n" if $result;
+ }
+ unless ( @result ) {
+ print STDERR "pwhich: no $file in PATH\n";
+ exit(255);
+ }
+}
+
+exit(0);
+
+__END__
+
+=pod
+
+=head1 NAME
+
+pwhich - Perl-only `which'
+
+=head1 SYNOPSIS
+
+ $ pwhich perl
+ $ pwhich -a perl # print all matches
+ $ pwhich perl perldoc ... # look for multiple programs
+ $ pwhich -a perl perldoc ...
+
+=head1 DESCRIPTION
+
+`pwhich' is a command-line utility program for finding paths to other
+programs based on the user's C<PATH>. It is similar to the usualy Unix
+tool `which', and tries to emulate its functionality, but is written
+purely in Perl (uses the module C<File::Which>), so is portable.
+
+=head2 Calling syntax
+
+ $ pwhich [-a] [-v] programname [programname ...]
+
+=head2 Options
+
+=over
+
+=item -a
+
+The option I<-a> will make C<pwhich> print all matches found in the
+C<PATH> variable instead of just the first one. Each match is printed
+on a separate line.
+
+=item -v
+
+Prints version (of C<File::Which>) and copyright notice and exits.
+
+=back
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which>
+
+For other issues, contact the maintainer.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt>
+
+Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet
+(for the mod_perl site) and Win32-awareness by me, with slight modifications
+by Stas Bekman, then extracted to create C<File::Which>.
+
+Version 0.04 had some significant platform-related changes, taken from
+the Perl Power Tools C<`which'> implementation by Abigail with
+enhancements from Peter Prymmer. See
+L<http://www.perl.com/language/ppt/src/which/index.html> for more
+information.
+
+=head1 COPYRIGHT
+
+Copyright 2002 Per Einar Ellefsen.
+
+Some parts copyright 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<perl>, L<File::Which>, L<which(1)>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/pwhich.bat b/Master/tlpkg/tlperl.straw/bin/pwhich.bat
new file mode 100755
index 00000000000..191949207d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/pwhich.bat
@@ -0,0 +1,157 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use 5.004;
+use strict;
+use File::Which ();
+use Getopt::Std ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.09';
+}
+
+# Handle options
+my %opts = ();
+Getopt::Std::getopts('av', \%opts);
+
+if ( $opts{v} ) {
+ print <<"END_TEXT";
+This is pwhich running File::Which version $File::Which::VERSION
+
+Copyright 2002 Per Einar Ellefsen.
+
+Some parts copyright 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+END_TEXT
+
+ exit(0);
+}
+
+unless ( @ARGV ) {
+ print <<"END_TEXT";
+Usage: $0 [-a] [-v] programname [programname ...]
+ -a Print all matches in PATH, not just the first.
+ -v Prints version and exits
+
+END_TEXT
+
+ exit(0);
+}
+
+foreach my $file ( @ARGV ) {
+ my @result = $opts{a}
+ ? File::Which::which($file)
+ # Need to force scalar
+ : scalar File::Which::which($file);
+
+ # We might end up with @result = (undef) -> 1 elem
+ @result = () unless defined $result[0];
+ foreach my $result ( @result ) {
+ print "$result\n" if $result;
+ }
+ unless ( @result ) {
+ print STDERR "pwhich: no $file in PATH\n";
+ exit(255);
+ }
+}
+
+exit(0);
+
+__END__
+
+=pod
+
+=head1 NAME
+
+pwhich - Perl-only `which'
+
+=head1 SYNOPSIS
+
+ $ pwhich perl
+ $ pwhich -a perl # print all matches
+ $ pwhich perl perldoc ... # look for multiple programs
+ $ pwhich -a perl perldoc ...
+
+=head1 DESCRIPTION
+
+`pwhich' is a command-line utility program for finding paths to other
+programs based on the user's C<PATH>. It is similar to the usualy Unix
+tool `which', and tries to emulate its functionality, but is written
+purely in Perl (uses the module C<File::Which>), so is portable.
+
+=head2 Calling syntax
+
+ $ pwhich [-a] [-v] programname [programname ...]
+
+=head2 Options
+
+=over
+
+=item -a
+
+The option I<-a> will make C<pwhich> print all matches found in the
+C<PATH> variable instead of just the first one. Each match is printed
+on a separate line.
+
+=item -v
+
+Prints version (of C<File::Which>) and copyright notice and exits.
+
+=back
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which>
+
+For other issues, contact the maintainer.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt>
+
+Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet
+(for the mod_perl site) and Win32-awareness by me, with slight modifications
+by Stas Bekman, then extracted to create C<File::Which>.
+
+Version 0.04 had some significant platform-related changes, taken from
+the Perl Power Tools C<`which'> implementation by Abigail with
+enhancements from Peter Prymmer. See
+L<http://www.perl.com/language/ppt/src/which/index.html> for more
+information.
+
+=head1 COPYRIGHT
+
+Copyright 2002 Per Einar Ellefsen.
+
+Some parts copyright 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<perl>, L<File::Which>, L<which(1)>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/runperl.bat b/Master/tlpkg/tlperl.straw/bin/runperl.bat
new file mode 100755
index 00000000000..8e8eb1ea948
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/runperl.bat
@@ -0,0 +1,83 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+$0 =~ s|\.bat||i;
+unless (-f $0) {
+ $0 =~ s|.*[/\\]||;
+ for (".", split ';', $ENV{PATH}) {
+ $_ = "." if $_ eq "";
+ $0 = "$_/$0" , goto doit if -f "$_/$0";
+ }
+ die "`$0' not found.\n";
+}
+doit: exec "perl", "-x", $0, @ARGV;
+die "Failed to exec `$0': $!";
+__END__
+
+=head1 NAME
+
+runperl.bat - "universal" batch file to run perl scripts
+
+=head1 SYNOPSIS
+
+ C:\> copy runperl.bat foo.bat
+ C:\> foo
+ [..runs the perl script `foo'..]
+
+ C:\> foo.bat
+ [..runs the perl script `foo'..]
+
+
+=head1 DESCRIPTION
+
+This file can be copied to any file name ending in the ".bat" suffix.
+When executed on a DOS-like operating system, it will invoke the perl
+script of the same name, but without the ".bat" suffix. It will
+look for the script in the same directory as itself, and then in
+the current directory, and then search the directories in your PATH.
+
+It relies on the C<exec()> operator, so you will need to make sure
+that works in your perl.
+
+This method of invoking perl scripts has some advantages over
+batch-file wrappers like C<pl2bat.bat>: it avoids duplication
+of all the code; it ensures C<$0> contains the same name as the
+executing file, without any egregious ".bat" suffix; it allows
+you to separate your perl scripts from the wrapper used to
+run them; since the wrapper is generic, you can use symbolic
+links to simply link to C<runperl.bat>, if you are serving your
+files on a filesystem that supports that.
+
+On the other hand, if the batch file is invoked with the ".bat"
+suffix, it does an extra C<exec()>. This may be a performance
+issue. You can avoid this by running it without specifying
+the ".bat" suffix.
+
+Perl is invoked with the -x flag, so the script must contain
+a C<#!perl> line. Any flags found on that line will be honored.
+
+=head1 BUGS
+
+Perl is invoked with the -S flag, so it will search the PATH to find
+the script. This may have undesirable effects.
+
+=head1 SEE ALSO
+
+perl, perlwin32, pl2bat.bat
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/s2p.bat b/Master/tlpkg/tlperl.straw/bin/s2p.bat
new file mode 100755
index 00000000000..aaf9845505b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/s2p.bat
@@ -0,0 +1,2018 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+my $startperl;
+my $perlpath;
+($startperl = <<'/../') =~ s/\s*\z//;
+#!perl
+/../
+($perlpath = <<'/../') =~ s/\s*\z//;
+C:\strawberry\perl\bin\perl.exe
+/../
+
+$0 =~ s/^.*?(\w+)[\.\w]*$/$1/;
+
+# (p)sed - a stream editor
+# History: Aug 12 2000: Original version.
+# Mar 25 2002: Rearrange generated Perl program.
+# Jul 23 2007: Fix bug in regex stripping (M.Thorland)
+
+use strict;
+use integer;
+use Symbol;
+
+=head1 NAME
+
+psed - a stream editor
+
+=head1 SYNOPSIS
+
+ psed [-an] script [file ...]
+ psed [-an] [-e script] [-f script-file] [file ...]
+
+ s2p [-an] [-e script] [-f script-file]
+
+=head1 DESCRIPTION
+
+A stream editor reads the input stream consisting of the specified files
+(or standard input, if none are given), processes is line by line by
+applying a script consisting of edit commands, and writes resulting lines
+to standard output. The filename `C<->' may be used to read standard input.
+
+The edit script is composed from arguments of B<-e> options and
+script-files, in the given order. A single script argument may be specified
+as the first parameter.
+
+If this program is invoked with the name F<s2p>, it will act as a
+sed-to-Perl translator. See L<"sed Script Translation">.
+
+B<sed> returns an exit code of 0 on success or >0 if an error occurred.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>
+
+A file specified as argument to the B<w> edit command is by default
+opened before input processing starts. Using B<-a>, opening of such
+files is delayed until the first line is actually written to the file.
+
+=item B<-e> I<script>
+
+The editing commands defined by I<script> are appended to the script.
+Multiple commands must be separated by newlines.
+
+=item B<-f> I<script-file>
+
+Editing commands from the specified I<script-file> are read and appended
+to the script.
+
+=item B<-n>
+
+By default, a line is written to standard output after the editing script
+has been applied to it. The B<-n> option suppresses automatic printing.
+
+=back
+
+=head1 COMMANDS
+
+B<sed> command syntax is defined as
+
+Z<> Z<> Z<> Z<>[I<address>[B<,>I<address>]][B<!>]I<function>[I<argument>]
+
+with whitespace being permitted before or after addresses, and between
+the function character and the argument. The I<address>es and the
+address inverter (C<!>) are used to restrict the application of a
+command to the selected line(s) of input.
+
+Each command must be on a line of its own, except where noted in
+the synopses below.
+
+The edit cycle performed on each input line consist of reading the line
+(without its trailing newline character) into the I<pattern space>,
+applying the applicable commands of the edit script, writing the final
+contents of the pattern space and a newline to the standard output.
+A I<hold space> is provided for saving the contents of the
+pattern space for later use.
+
+=head2 Addresses
+
+A sed address is either a line number or a pattern, which may be combined
+arbitrarily to construct ranges. Lines are numbered across all input files.
+
+Any address may be followed by an exclamation mark (`C<!>'), selecting
+all lines not matching that address.
+
+=over 4
+
+=item I<number>
+
+The line with the given number is selected.
+
+=item B<$>
+
+A dollar sign (C<$>) is the line number of the last line of the input stream.
+
+=item B</>I<regular expression>B</>
+
+A pattern address is a basic regular expression (see
+L<"Basic Regular Expressions">), between the delimiting character C</>.
+Any other character except C<\> or newline may be used to delimit a
+pattern address when the initial delimiter is prefixed with a
+backslash (`C<\>').
+
+=back
+
+If no address is given, the command selects every line.
+
+If one address is given, it selects the line (or lines) matching the
+address.
+
+Two addresses select a range that begins whenever the first address
+matches, and ends (including that line) when the second address matches.
+If the first (second) address is a matching pattern, the second
+address is not applied to the very same line to determine the end of
+the range. Likewise, if the second address is a matching pattern, the
+first address is not applied to the very same line to determine the
+begin of another range. If both addresses are line numbers,
+and the second line number is less than the first line number, then
+only the first line is selected.
+
+
+=head2 Functions
+
+The maximum permitted number of addresses is indicated with each
+function synopsis below.
+
+The argument I<text> consists of one or more lines following the command.
+Embedded newlines in I<text> must be preceded with a backslash. Other
+backslashes in I<text> are deleted and the following character is taken
+literally.
+
+=over 4
+
+=cut
+
+my %ComTab;
+my %GenKey;
+#--------------------------------------------------------------------------
+$ComTab{'a'}=[ 1, 'txt', \&Emit, '{ push( @Q, <<'."'TheEnd' ) }\n" ]; #ok
+
+=item [1addr]B<a\> I<text>
+
+Write I<text> (which must start on the line following the command)
+to standard output immediately before reading the next line
+of input, either by executing the B<N> function or by beginning a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'b'}=[ 2, 'str', \&Branch, '{ goto XXX; }' ]; #ok
+
+=item [2addr]B<b> [I<label>]
+
+Branch to the B<:> function with the specified I<label>. If no label
+is given, branch to the end of the script.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'c'}=[ 2, 'txt', \&Change, <<'-X-' ]; #ok
+{ print <<'TheEnd'; } $doPrint = 0; goto EOS;
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<c\> I<text>
+
+The line, or range of lines, selected by the address is deleted.
+The I<text> (which must start on the line following the command)
+is written to standard output. With an address range, this occurs at
+the end of the range.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'d'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ $doPrint = 0;
+ goto EOS;
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<d>
+
+Deletes the pattern space and starts the next cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'D'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ s/^.*\n?//;
+ if(length($_)){ goto BOS } else { goto EOS }
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<D>
+
+Deletes the pattern space through the first embedded newline or to the end.
+If the pattern space becomes empty, a new cycle is started, otherwise
+execution of the script is restarted.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'g'}=[ 2, '', \&Emit, '{ $_ = $Hold };' ]; #ok
+
+=item [2addr]B<g>
+
+Replace the contents of the pattern space with the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'G'}=[ 2, '', \&Emit, '{ $_ .= "\n"; $_ .= $Hold };' ]; #ok
+
+=item [2addr]B<G>
+
+Append a newline and the contents of the hold space to the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'h'}=[ 2, '', \&Emit, '{ $Hold = $_ }' ]; #ok
+
+=item [2addr]B<h>
+
+Replace the contents of the hold space with the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'H'}=[ 2, '', \&Emit, '{ $Hold .= "\n"; $Hold .= $_; }' ]; #ok
+
+=item [2addr]B<H>
+
+Append a newline and the contents of the pattern space to the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'i'}=[ 1, 'txt', \&Emit, '{ print <<'."'TheEnd' }\n" ]; #ok
+
+=item [1addr]B<i\> I<text>
+
+Write the I<text> (which must start on the line following the command)
+to standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'l'}=[ 2, '', \&Emit, '{ _l() }' ]; #okUTF8
+
+=item [2addr]B<l>
+
+Print the contents of the pattern space: non-printable characters are
+shown in C-style escaped form; long lines are split and have a trailing
+`C<\>' at the point of the split; the true end of a line is marked with
+a `C<$>'. Escapes are: `\a', `\t', `\n', `\f', `\r', `\e' for
+BEL, HT, LF, FF, CR, ESC, respectively, and `\' followed by a three-digit
+octal number for all other non-printable characters.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'n'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV();
+ chomp();
+}
+-X-
+
+=item [2addr]B<n>
+
+If automatic printing is enabled, write the pattern space to the standard
+output. Replace the pattern space with the next line of input. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'N'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV( $h );
+ chomp( $h );
+ $_ .= "\n$h";
+}
+-X-
+
+=item [2addr]B<N>
+
+Append a newline and the next line of input to the pattern space. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'p'}=[ 2, '', \&Emit, '{ print $_, "\n"; }' ]; #ok
+
+=item [2addr]B<p>
+
+Print the pattern space to the standard output. (Use the B<-n> option
+to suppress automatic printing at the end of a cycle if you want to
+avoid double printing of lines.)
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'P'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ if( /^(.*)/ ){ print $1, "\n"; } }
+-X-
+
+=item [2addr]B<P>
+
+Prints the pattern space through the first embedded newline or to the end.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'q'}=[ 1, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ last CYCLE;
+}
+-X-
+
+=item [1addr]B<q>
+
+Branch to the end of the script and quit without starting a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'r'}=[ 1, 'str', \&Emit, "{ _r( '-X-' ) }" ]; #ok
+
+=item [1addr]B<r> I<file>
+
+Copy the contents of the I<file> to standard output immediately before
+the next attempt to read a line of input. Any error encountered while
+reading I<file> is silently ignored.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'s'}=[ 2, 'sub', \&Emit, '' ]; #ok
+
+=item [2addr]B<s/>I<regular expression>B</>I<replacement>B</>I<flags>
+
+Substitute the I<replacement> string for the first substring in
+the pattern space that matches the I<regular expression>.
+Any character other than backslash or newline can be used instead of a
+slash to delimit the regular expression and the replacement.
+To use the delimiter as a literal character within the regular expression
+and the replacement, precede the character by a backslash (`C<\>').
+
+Literal newlines may be embedded in the replacement string by
+preceding a newline with a backslash.
+
+Within the replacement, an ampersand (`C<&>') is replaced by the string
+matching the regular expression. The strings `C<\1>' through `C<\9>' are
+replaced by the corresponding subpattern (see L<"Basic Regular Expressions">).
+To get a literal `C<&>' or `C<\>' in the replacement text, precede it
+by a backslash.
+
+The following I<flags> modify the behaviour of the B<s> command:
+
+=over 8
+
+=item B<g>
+
+The replacement is performed for all matching, non-overlapping substrings
+of the pattern space.
+
+=item B<1>..B<9>
+
+Replace only the n-th matching substring of the pattern space.
+
+=item B<p>
+
+If the substitution was made, print the new value of the pattern space.
+
+=item B<w> I<file>
+
+If the substitution was made, write the new value of the pattern space
+to the specified file.
+
+=back
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'t'}=[ 2, 'str', \&Branch, '{ goto XXX if _t() }' ]; #ok
+
+=item [2addr]B<t> [I<label>]
+
+Branch to the B<:> function with the specified I<label> if any B<s>
+substitutions have been made since the most recent reading of an input line
+or execution of a B<t> function. If no label is given, branch to the end of
+the script.
+
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'w'}=[ 2, 'str', \&Write, "{ _w( '-X-' ) }" ]; #ok
+
+=item [2addr]B<w> I<file>
+
+The contents of the pattern space are written to the I<file>.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'x'}=[ 2, '', \&Emit, '{ ($Hold, $_) = ($_, $Hold) }' ]; #ok
+
+=item [2addr]B<x>
+
+Swap the contents of the pattern space and the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'y'}=[ 2, 'tra', \&Emit, '' ]; #ok
+=item [2addr]B<y>B</>I<string1>B</>I<string2>B</>
+
+In the pattern space, replace all characters occuring in I<string1> by the
+character at the corresponding position in I<string2>. It is possible
+to use any character (other than a backslash or newline) instead of a
+slash to delimit the strings. Within I<string1> and I<string2>, a
+backslash followed by any character other than a newline is that literal
+character, and a backslash followed by an `n' is replaced by a newline
+character.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'='}=[ 1, '', \&Emit, '{ print "$.\n" }' ]; #ok
+
+=item [1addr]B<=>
+
+Prints the current line number on the standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{':'}=[ 0, 'str', \&Label, '' ]; #ok
+
+=item [0addr]B<:> [I<label>]
+
+The command specifies the position of the I<label>. It has no other effect.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'{'}=[ 2, '', \&BeginBlock, '{' ]; #ok
+$ComTab{'}'}=[ 0, '', \&EndBlock, ';}' ]; #ok
+# ';' to avoid warning on empty {}-block
+
+=item [2addr]B<{> [I<command>]
+
+=item [0addr]B<}>
+
+These two commands begin and end a command list. The first command may
+be given on the same line as the opening B<{> command. The commands
+within the list are jointly selected by the address(es) given on the
+B<{> command (but may still have individual addresses).
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'#'}=[ 0, 'str', \&Comment, '' ]; #ok
+
+=item [0addr]B<#> [I<comment>]
+
+The entire line is ignored (treated as a comment). If, however, the first
+two characters in the script are `C<#n>', automatic printing of output is
+suppressed, as if the B<-n> option were given on the command line.
+
+=back
+
+=cut
+
+use vars qw{ $isEOF $Hold %wFiles @Q $CondReg $doPrint };
+
+my $useDEBUG = exists( $ENV{PSEDDEBUG} );
+my $useEXTBRE = $ENV{PSEDEXTBRE} || '';
+$useEXTBRE =~ s/[^<>wWyB]//g; # gawk RE's handle these
+
+my $doAutoPrint = 1; # automatic printing of pattern space (-n => 0)
+my $doOpenWrite = 1; # open w command output files at start (-a => 0)
+my $svOpenWrite = 0; # save $doOpenWrite
+
+# lower case $0 below as a VMSism. The VMS build procedure creates the
+# s2p file traditionally in upper case on the disk. When VMS is in a
+# case preserved or case sensitive mode, $0 will be returned in the exact
+# case which will be on the disk, and that is not predictable at this time.
+
+my $doGenerate = lc($0) eq 's2p';
+
+# Collected and compiled script
+#
+my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code, $Func );
+$Code = '';
+
+##################
+# Compile Time
+#
+# Labels
+#
+# Error handling
+#
+sub Warn($;$){
+ my( $msg, $loc ) = @_;
+ $loc ||= '';
+ $loc .= ': ' if length( $loc );
+ warn( "$0: $loc$msg\n" );
+}
+
+$labNum = 0;
+sub newLabel(){
+ return 'L_'.++$labNum;
+}
+
+# safeHere: create safe here delimiter and modify opcode and argument
+#
+sub safeHere($$){
+ my( $codref, $argref ) = @_;
+ my $eod = 'EOD000';
+ while( $$argref =~ /^$eod$/m ){
+ $eod++;
+ }
+ $$codref =~ s/TheEnd/$eod/e;
+ $$argref .= "$eod\n";
+}
+
+# Emit: create address logic and emit command
+#
+sub Emit($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $cond = '';
+ if( defined( $addr1 ) ){
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ $cond = $negated ? "unless( $addr1 )\n" : "if( $addr1 )\n";
+ }
+
+ if( $opcode eq '' ){
+ $Code .= "$cond$arg\n";
+
+ } elsif( $opcode =~ s/-X-/$arg/e ){
+ $Code .= "$cond$opcode\n";
+
+ } elsif( $opcode =~ /TheEnd/ ){
+ safeHere( \$opcode, \$arg );
+ $Code .= "$cond$opcode$arg";
+
+ } else {
+ $Code .= "$cond$opcode\n";
+ }
+ 0;
+}
+
+# Write (w command, w flag): store pathname
+#
+sub Write($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $path, $fl ) = @_;
+ $wFiles{$path} = '';
+ Emit( $addr1, $addr2, $negated, $opcode, $path, $fl );
+}
+
+
+# Label (: command): label definition
+#
+sub Label($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ my $rc = 0;
+ $lab =~ s/\s+//;
+ if( length( $lab ) ){
+ my $h;
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ if( exists( $Label{$lab}{defined} ) ){
+ my $dl = $Label{$lab}{defined};
+ Warn( "duplicate label $lab (first defined at $dl)", $fl );
+ $rc = 1;
+ }
+ }
+ $Label{$lab}{defined} = $fl;
+ $Code .= "$h:;\n";
+ }
+ $rc;
+}
+
+# BeginBlock ({ command): push block start
+#
+sub BeginBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ push( @BlockStack, [ $fl, $addr1, $addr2, $negated ] );
+ Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+}
+
+# EndBlock (} command): check proper nesting
+#
+sub EndBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $rc;
+ my $jcom = pop( @BlockStack );
+ if( defined( $jcom ) ){
+ $rc = Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+ } else {
+ Warn( "unexpected `}'", $fl );
+ $rc = 1;
+ }
+ $rc;
+}
+
+# Branch (t, b commands): check or create label, substitute default
+#
+sub Branch($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ $lab =~ s/\s+//; # no spaces at end
+ my $h;
+ if( length( $lab ) ){
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ }
+ push( @{$Label{$lab}{used}}, $fl );
+ } else {
+ $h = 'EOS';
+ }
+ $opcode =~ s/XXX/$h/e;
+ Emit( $addr1, $addr2, $negated, $opcode, '', $fl );
+}
+
+# Change (c command): is special due to range end watching
+#
+sub Change($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $kwd = $negated ? 'unless' : 'if';
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ if( ! $negated ){
+ $addr1 = '$icnt = ('.$addr1.')';
+ $opcode = 'if( $icnt =~ /E0$/ )' . $opcode;
+ }
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ safeHere( \$opcode, \$arg );
+ $Code .= "$kwd( $addr1 ){\n $opcode$arg}\n";
+ 0;
+}
+
+
+# Comment (# command): A no-op. Who would've thought that!
+#
+sub Comment($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+### $Code .= "# $arg\n";
+ 0;
+}
+
+# stripRegex from the current command. If we're in the first
+# part of s///, trailing spaces have to be kept as the initial
+# part of the replacement string.
+#
+sub stripRegex($$;$){
+ my( $del, $sref, $sub ) = @_;
+ my $regex = $del;
+ print "stripRegex:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E(\s*)}{}s ){
+ my $sl = $2;
+ $regex .= $1.$sl.$del;
+ if( length( $sl ) % 2 == 0 ){
+ if( $sub && (length( $3 ) > 0) ){
+ $$sref = $3 . $$sref;
+ }
+ return $regex;
+ }
+ $regex .= $3;
+ }
+ undef();
+}
+
+# stripTrans: take a <del> terminated string from y command
+# honoring and cleaning up of \-escaped <del>'s
+#
+sub stripTrans($$){
+ my( $del, $sref ) = @_;
+ my $t = '';
+ print "stripTrans:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E}{}s ){
+ my $sl = $2;
+ $t .= $1;
+ if( length( $sl ) % 2 == 0 ){
+ $t .= $sl;
+ $t =~ s/\\\\/\\/g;
+ return $t;
+ }
+ chop( $sl );
+ $t .= $sl.$del.$3;
+ }
+ undef();
+}
+
+# makey - construct Perl y/// from sed y///
+#
+sub makey($$$){
+ my( $fr, $to, $fl ) = @_;
+ my $error = 0;
+
+ # Ensure that any '-' is up front.
+ # Diagnose duplicate contradicting mappings
+ my %tr;
+ for( my $i = 0; $i < length($fr); $i++ ){
+ my $fc = substr($fr,$i,1);
+ my $tc = substr($to,$i,1);
+ if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){
+ Warn( "ambiguous translation for character `$fc' in `y' command",
+ $fl );
+ $error++;
+ }
+ $tr{$fc} = $tc;
+ }
+ $fr = $to = '';
+ if( exists( $tr{'-'} ) ){
+ ( $fr, $to ) = ( '-', $tr{'-'} );
+ delete( $tr{'-'} );
+ } else {
+ $fr = $to = '';
+ }
+ # might just as well sort it...
+ for my $fc ( sort keys( %tr ) ){
+ $fr .= $fc;
+ $to .= $tr{$fc};
+ }
+ # make embedded delimiters and newlines safe
+ $fr =~ s/([{}])/\$1/g;
+ $to =~ s/([{}])/\$1/g;
+ $fr =~ s/\n/\\n/g;
+ $to =~ s/\n/\\n/g;
+ return $error ? undef() : "{ y{$fr}{$to}; }";
+}
+
+######
+# makes - construct Perl s/// from sed s///
+#
+sub makes($$$$$$$){
+ my( $regex, $subst, $path, $global, $print, $nmatch, $fl ) = @_;
+
+ # make embedded newlines safe
+ $regex =~ s/\n/\\n/g;
+ $subst =~ s/\n/\\n/g;
+
+ my $code;
+ # n-th occurrence
+ #
+ if( length( $nmatch ) ){
+ $code = <<TheEnd;
+{ \$n = $nmatch;
+ while( --\$n && ( \$s = m ${regex}g ) ){}
+ \$s = ( substr( \$_, pos() ) =~ s ${regex}${subst}s ) if \$s;
+ \$CondReg ||= \$s;
+TheEnd
+ } else {
+ $code = <<TheEnd;
+{ \$s = s ${regex}${subst}s${global};
+ \$CondReg ||= \$s;
+TheEnd
+ }
+ if( $print ){
+ $code .= ' print $_, "\n" if $s;'."\n";
+ }
+ if( defined( $path ) ){
+ $wFiles{$path} = '';
+ $code .= " _w( '$path' ) if \$s;\n";
+ $GenKey{'w'} = 1;
+ }
+ $code .= "}";
+}
+
+=head1 BASIC REGULAR EXPRESSIONS
+
+A I<Basic Regular Expression> (BRE), as defined in POSIX 1003.2, consists
+of I<atoms>, for matching parts of a string, and I<bounds>, specifying
+repetitions of a preceding atom.
+
+=head2 Atoms
+
+The possible atoms of a BRE are: B<.>, matching any single character;
+B<^> and B<$>, matching the null string at the beginning or end
+of a string, respectively; a I<bracket expressions>, enclosed
+in B<[> and B<]> (see below); and any single character with no
+other significance (matching that character). A B<\> before one
+of: B<.>, B<^>, B<$>, B<[>, B<*>, B<\>, matching the character
+after the backslash. A sequence of atoms enclosed in B<\(> and B<\)>
+becomes an atom and establishes the target for a I<backreference>,
+consisting of the substring that actually matches the enclosed atoms.
+Finally, B<\> followed by one of the digits B<0> through B<9> is a
+backreference.
+
+A B<^> that is not first, or a B<$> that is not last does not have
+a special significance and need not be preceded by a backslash to
+become literal. The same is true for a B<]>, that does not terminate
+a bracket expression.
+
+An unescaped backslash cannot be last in a BRE.
+
+=head2 Bounds
+
+The BRE bounds are: B<*>, specifying 0 or more matches of the preceding
+atom; B<\{>I<count>B<\}>, specifying that many repetitions;
+B<\{>I<minimum>B<,\}>, giving a lower limit; and
+B<\{>I<minimum>B<,>I<maximum>B<\}> finally defines a lower and upper
+bound.
+
+A bound appearing as the first item in a BRE is taken literally.
+
+=head2 Bracket Expressions
+
+A I<bracket expression> is a list of characters, character ranges
+and character classes enclosed in B<[> and B<]> and matches any
+single character from the represented set of characters.
+
+A character range is written as two characters separated by B<-> and
+represents all characters (according to the character collating sequence)
+that are not less than the first and not greater than the second.
+(Ranges are very collating-sequence-dependent, and portable programs
+should avoid relying on them.)
+
+A character class is one of the class names
+
+ alnum digit punct
+ alpha graph space
+ blank lower upper
+ cntrl print xdigit
+
+enclosed in B<[:> and B<:]> and represents the set of characters
+as defined in ctype(3).
+
+If the first character after B<[> is B<^>, the sense of matching is
+inverted.
+
+To include a literal `C<^>', place it anywhere else but first. To
+include a literal 'C<]>' place it first or immediately after an
+initial B<^>. To include a literal `C<->' make it the first (or
+second after B<^>) or last character, or the second endpoint of
+a range.
+
+The special bracket expression constructs C<[[:E<lt>:]]> and C<[[:E<gt>:]]>
+match the null string at the beginning and end of a word respectively.
+(Note that neither is identical to Perl's `\b' atom.)
+
+=head2 Additional Atoms
+
+Since some sed implementations provide additional regular expression
+atoms (not defined in POSIX 1003.2), B<psed> is capable of translating
+the following backslash escapes:
+
+=over 4
+
+=item B<\E<lt>> This is the same as C<[[:E<gt>:]]>.
+
+=item B<\E<gt>> This is the same as C<[[:E<lt>:]]>.
+
+=item B<\w> This is an abbreviation for C<[[:alnum:]_]>.
+
+=item B<\W> This is an abbreviation for C<[^[:alnum:]_]>.
+
+=item B<\y> Match the empty string at a word boundary.
+
+=item B<\B> Match the empty string between any two either word or non-word characters.
+
+=back
+
+To enable this feature, the environment variable PSEDEXTBRE must be set
+to a string containing the requested characters, e.g.:
+C<PSEDEXTBRE='E<lt>E<gt>wW'>.
+
+=cut
+
+#####
+# bre2p - convert BRE to Perl RE
+#
+sub peek(\$$){
+ my( $pref, $ic ) = @_;
+ $ic < length($$pref)-1 ? substr( $$pref, $ic+1, 1 ) : '';
+}
+
+sub bre2p($$$){
+ my( $del, $pat, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $pat = substr( $pat, 1, length($pat) - 2 );
+ my $res = '';
+ my $bracklev = 0;
+ my $backref = 0;
+ my $parlev = 0;
+ for( my $ic = 0; $ic < length( $pat ); $ic++ ){
+ my $c = substr( $pat, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($pat,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in pattern", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc eq $del ){ ## \<pattern del> => \<pattern del>
+ $res .= "\\$del";
+
+ } elsif( $nc =~ /([[.*\\n])/ ){
+ ## check for \-escaped magics and \n:
+ ## \[ \. \* \\ \n stay as they are
+ $res .= '\\'.$nc;
+
+ } elsif( $nc eq '(' ){ ## \( => (
+ $parlev++;
+ $res .= '(';
+
+ } elsif( $nc eq ')' ){ ## \) => )
+ $parlev--;
+ $backref++;
+ if( $parlev < 0 ){
+ Warn( "unmatched `\\)'", $fl );
+ return undef();
+ }
+ $res .= ')';
+
+ } elsif( $nc eq '{' ){ ## repetition factor \{<i>[,[<j>]]\}
+ my $endpos = index( $pat, '\\}', $ic );
+ if( $endpos < 0 ){
+ Warn( "unmatched `\\{'", $fl );
+ return undef();
+ }
+ my $rep = substr( $pat, $ic+1, $endpos-($ic+1) );
+ $ic = $endpos + 1;
+
+ if( $res =~ /^\^?$/ ){
+ $res .= "\\{$rep\}";
+ } elsif( $rep =~ /^(\d+)(,?)(\d*)?$/ ){
+ my $min = $1;
+ my $com = $2 || '';
+ my $max = $3;
+ if( length( $max ) ){
+ if( $max < $min ){
+ Warn( "maximum less than minimum in `\\{$rep\\}'",
+ $fl );
+ return undef();
+ }
+ } else {
+ $max = '';
+ }
+ # simplify some
+ if( $min == 0 && $max eq '1' ){
+ $res .= '?';
+ } elsif( $min == 1 && "$com$max" eq ',' ){
+ $res .= '+';
+ } elsif( $min == 0 && "$com$max" eq ',' ){
+ $res .= '*';
+ } else {
+ $res .= "{$min$com$max}";
+ }
+ } else {
+ Warn( "invalid repeat clause `\\{$rep\\}'", $fl );
+ return undef();
+ }
+
+ } elsif( $nc =~ /^[1-9]$/ ){
+ ## \1 .. \9 => \1 .. \9, but check for a following digit
+ if( $nc > $backref ){
+ Warn( "invalid backreference ($nc)", $fl );
+ return undef();
+ }
+ $res .= "\\$nc";
+ if( peek($pat,$ic) =~ /[0-9]/ ){
+ $res .= '(?:)';
+ }
+
+ } elsif( $useEXTBRE && ( $nc =~ /[$useEXTBRE]/ ) ){
+ ## extensions - at most <>wWyB - not in POSIX
+ if( $nc eq '<' ){ ## \< => \b(?=\w), be precise
+ $res .= '\\b(?<=\\W)';
+ } elsif( $nc eq '>' ){ ## \> => \b(?=\W), be precise
+ $res .= '\\b(?=\\W)';
+ } elsif( $nc eq 'y' ){ ## \y => \b
+ $res .= '\\b';
+ } else { ## \B, \w, \W remain the same
+ $res .= "\\$nc";
+ }
+ } elsif( $nc eq $led ){
+ ## \<closing bracketing-delimiter> - keep '\'
+ $res .= "\\$nc";
+
+ } else { ## \ <char> => <char> ("as if `\' were not present")
+ $res .= $nc;
+ }
+
+ } elsif( $c eq '.' ){ ## . => .
+ $res .= $c;
+
+ } elsif( $c eq '*' ){ ## * => * but \* if there's nothing preceding it
+ if( $res =~ /^\^?$/ ){
+ $res .= '\\*';
+ } elsif( substr( $res, -1, 1 ) ne '*' ){
+ $res .= $c;
+ }
+
+ } elsif( $c eq '[' ){
+ ## parse []: [^...] [^]...] [-...]
+ my $add = '[';
+ if( peek($pat,$ic) eq '^' ){
+ $ic++;
+ $add .= '^';
+ }
+ my $nc = peek($pat,$ic);
+ if( $nc eq ']' || $nc eq '-' ){
+ $add .= $nc;
+ $ic++;
+ }
+ # check that [ is not trailing
+ if( $ic >= length( $pat ) - 1 ){
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+ # look for [:...:] and x-y
+ my $rstr = substr( $pat, $ic+1 );
+ if( $rstr =~ /^((?:\[:\(\w+|[><]\):\]|[^]-](?:-[^]])?)*)/ ){
+ my $cnt = $1;
+ $ic += length( $cnt );
+ $cnt =~ s/([\\\$])/\\$1/g; # `\', `$' are magic in Perl []
+ # try some simplifications
+ my $red = $cnt;
+ if( $red =~ s/0-9// ){
+ $cnt = $red.'\d';
+ if( $red =~ s/A-Z// && $red =~ s/a-z// && $red =~ s/_// ){
+ $cnt = $red.'\w';
+ }
+ }
+ $add .= $cnt;
+
+ # POSIX 1003.2 has this (optional) for begin/end word
+ $add = '\\b(?=\\W)' if $add eq '[[:<:]]';
+ $add = '\\b(?<=\\W)' if $add eq '[[:>:]]';
+
+ }
+
+ ## may have a trailing `-' before `]'
+ if( $ic < length($pat) - 1 &&
+ substr( $pat, $ic+1 ) =~ /^(-?])/ ){
+ $ic += length( $1 );
+ $add .= $1;
+ # another simplification
+ $add =~ s/^\[(\^?)(\\[dw])]$/ $1 eq '^' ? uc($2) : $2 /e;
+ $res .= $add;
+ } else {
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+
+ } elsif( $c eq $led ){ ## unescaped <closing bracketing-delimiter>
+ $res .= "\\$c";
+
+ } elsif( $c eq ']' ){ ## unmatched ] is not magic
+ $res .= ']';
+
+ } elsif( $c =~ /[|+?{}()]/ ){ ## not magic in BRE, but in Perl: \-quote
+ $res .= "\\$c";
+
+ } elsif( $c eq '^' ){ ## not magic unless 1st, but in Perl: \-quote
+ $res .= length( $res ) ? '\\^' : '^';
+
+ } elsif( $c eq '$' ){ ## not magic unless last, but in Perl: \-quote
+ $res .= $ic == length( $pat ) - 1 ? '$' : '\\$';
+
+ } else {
+ $res .= $c;
+ }
+ }
+
+ if( $parlev ){
+ Warn( "unmatched `\\('", $fl );
+ return undef();
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return $del . $res . ( $led ? $led : $del );
+}
+
+
+#####
+# sub2p - convert sed substitution to Perl substitution
+#
+sub sub2p($$$){
+ my( $del, $subst, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $subst = substr( $subst, 1, length($subst) - 2 );
+ my $res = '';
+
+ for( my $ic = 0; $ic < length( $subst ); $ic++ ){
+ my $c = substr( $subst, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($subst,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in substitution", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc =~ /[\\$del$led]/ ){ ## \ and delimiter
+ $res .= '\\' . $nc;
+ } elsif( $nc =~ /[1-9]/ ){ ## \1 - \9 => ${1} - ${9}
+ $res .= '${' . $nc . '}';
+ } else { ## everything else (includes &): omit \
+ $res .= $nc;
+ }
+ } elsif( $c eq '&' ){ ## & => $&
+ $res .= '$&';
+ } elsif( $c =~ /[\$\@$led]/ ){ ## magic in Perl's substitution string
+ $res .= '\\' . $c;
+ } else {
+ $res .= $c;
+ }
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return ( $led ? $del : $led ) . $res . ( $led ? $led : $del );
+}
+
+
+sub Parse(){
+ my $error = 0;
+ my( $pdef, $pfil, $plin );
+ for( my $icom = 0; $icom < @Commands; $icom++ ){
+ my $cmd = $Commands[$icom];
+ print "Parse:$cmd:\n" if $useDEBUG;
+ $cmd =~ s/^\s+//;
+ next unless length( $cmd );
+ my $scom = $icom;
+ if( exists( $Defined{$icom} ) ){
+ $pdef = $Defined{$icom};
+ if( $pdef =~ /^ #(\d+)/ ){
+ $pfil = 'expression #';
+ $plin = $1;
+ } else {
+ $pfil = "$pdef l.";
+ $plin = 1;
+ }
+ } else {
+ $plin++;
+ }
+ my $fl = "$pfil$plin";
+
+ # insert command as comment in gnerated code
+ #
+ $Code .= "# $cmd\n" if $doGenerate;
+
+ # The Address(es)
+ #
+ my( $negated, $naddr, $addr1, $addr2 );
+ $naddr = 0;
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr1 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr1 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr1 = 'm '.bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 1st address", $fl );
+ $error++;
+ next;
+ }
+ }
+ if( defined( $addr1 ) && $cmd =~ s/,\s*// ){
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr2 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr2 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr2 = 'm '. bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 2nd address", $fl );
+ $error++;
+ next;
+ }
+ } else {
+ Warn( "invalid address after `,'", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # address modifier `!'
+ #
+ $negated = $cmd =~ s/^!\s*//;
+ if( defined( $addr1 ) ){
+ print "Parse: addr1=$addr1" if $useDEBUG;
+ if( defined( $addr2 ) ){
+ print ", addr2=$addr2 " if $useDEBUG;
+ # both numeric and addr1 > addr2 => eliminate addr2
+ undef( $addr2 ) if $addr1 =~ /^\d+$/ &&
+ $addr2 =~ /^\d+$/ && $addr1 > $addr2;
+ }
+ }
+ print 'negated' if $useDEBUG && $negated;
+ print " command:$cmd\n" if $useDEBUG;
+
+ # The Command
+ #
+ if( $cmd !~ s/^([:#={}abcdDgGhHilnNpPqrstwxy])\s*// ){
+ my $h = substr( $cmd, 0, 1 );
+ Warn( "unknown command `$h'", $fl );
+ $error++;
+ next;
+ }
+ my $key = $1;
+
+ my $tabref = $ComTab{$key};
+ $GenKey{$key} = 1;
+ if( $naddr > $tabref->[0] ){
+ Warn( "excess address(es)", $fl );
+ $error++;
+ next;
+ }
+
+ my $arg = '';
+ if( $tabref->[1] eq 'str' ){
+ # take remainder - don't care if it is empty
+ $arg = $cmd;
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'txt' ){
+ # multi-line text
+ my $goon = $cmd =~ /(.*)\\$/;
+ if( length( $1 ) ){
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ }
+ while( $goon ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd = $Commands[$icom];
+ $Code .= "# $cmd\n" if $doGenerate;
+ $goon = $cmd =~ s/\\$//;
+ $cmd =~ s/\\(.)/$1/g;
+ $arg .= "\n" if length( $arg );
+ $arg .= $cmd;
+ }
+ $arg .= "\n" if length( $arg );
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'sub' ){
+ # s///
+ if( ! length( $cmd ) ){
+ Warn( "`s' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ if( $cmd =~ s{^([^\\\n])}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd, "s" );
+ if( ! defined( $regex ) ){
+ Warn( "malformed regular expression", $fl );
+ $error++;
+ next;
+ }
+ $regex = bre2p( $del, $regex, $fl );
+
+ # a trailing \ indicates embedded NL (in replacement string)
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+
+ my $subst = stripRegex( $del, \$cmd );
+ if( ! defined( $regex ) ){
+ Warn( "malformed substitution expression", $fl );
+ $error++;
+ next;
+ }
+ $subst = sub2p( $del, $subst, $fl );
+
+ # parse s/// modifier: g|p|0-9|w <file>
+ my( $global, $nmatch, $print, $write ) =
+ ( '', '', 0, undef );
+ while( $cmd =~ s/^([gp0-9])// ){
+ $1 eq 'g' ? ( $global = 'g' ) :
+ $1 eq 'p' ? ( $print = $1 ) : ( $nmatch .= $1 );
+ }
+ $write = $1 if $cmd =~ s/w\s*(.*)$//;
+ ### $nmatch =~ s/^(\d)\1*$/$1/; ### may be dangerous?
+ if( $global && length( $nmatch ) || length( $nmatch ) > 1 ){
+ Warn( "conflicting flags `$global$nmatch'", $fl );
+ $error++;
+ next;
+ }
+
+ $arg = makes( $regex, $subst,
+ $write, $global, $print, $nmatch, $fl );
+ if( ! defined( $arg ) ){
+ $error++;
+ next;
+ }
+
+ } else {
+ Warn( "improper delimiter in s command", $fl );
+ $error++;
+ next;
+ }
+
+ } elsif( $tabref->[1] eq 'tra' ){
+ # y///
+ # a trailing \ indicates embedded newline
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+ if( ! length( $cmd ) ){
+ Warn( "`y' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ my $d = substr( $cmd, 0, 1 ); $cmd = substr( $cmd, 1 );
+ if( $d eq '\\' ){
+ Warn( "`\\' not valid as delimiter in `y' command", $fl );
+ $error++;
+ next;
+ }
+ my $fr = stripTrans( $d, \$cmd );
+ if( ! defined( $fr ) || ! length( $cmd ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ my $to = stripTrans( $d, \$cmd );
+ if( ! defined( $to ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ if( length($fr) != length($to) ){
+ Warn( "string lengths in `y' command differ", $fl );
+ $error++;
+ next;
+ }
+ if( ! defined( $arg = makey( $fr, $to, $fl ) ) ){
+ $error++;
+ next;
+ }
+
+ }
+
+ # $cmd must be now empty - exception is {
+ if( $cmd !~ /^\s*$/ ){
+ if( $key eq '{' ){
+ # dirty hack to process command on '{' line
+ $Commands[$icom--] = $cmd;
+ } else {
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # Make Code
+ #
+ if( &{$tabref->[2]}( $addr1, $addr2, $negated,
+ $tabref->[3], $arg, $fl ) ){
+ $error++;
+ }
+ }
+
+ while( @BlockStack ){
+ my $bl = pop( @BlockStack );
+ Warn( "start of unterminated `{'", $bl );
+ $error++;
+ }
+
+ for my $lab ( keys( %Label ) ){
+ if( ! exists( $Label{$lab}{defined} ) ){
+ for my $used ( @{$Label{$lab}{used}} ){
+ Warn( "undefined label `$lab'", $used );
+ $error++;
+ }
+ }
+ }
+
+ exit( 1 ) if $error;
+}
+
+
+##############
+#### MAIN ####
+##############
+
+sub usage(){
+ print STDERR "Usage: sed [-an] command [file...]\n";
+ print STDERR " [-an] [-e command] [-f script-file] [file...]\n";
+}
+
+###################
+# Here we go again...
+#
+my $expr = 0;
+while( @ARGV && $ARGV[0] =~ /^-(.)(.*)$/ ){
+ my $opt = $1;
+ my $arg = $2;
+ shift( @ARGV );
+ if( $opt eq 'e' ){
+ if( length( $arg ) ){
+ push( @Commands, split( "\n", $arg ) );
+ } elsif( @ARGV ){
+ push( @Commands, shift( @ARGV ) );
+ } else {
+ Warn( "option -e requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ $expr++;
+ $Defined{$#Commands} = " #$expr";
+ next;
+ }
+ if( $opt eq 'f' ){
+ my $path;
+ if( length( $arg ) ){
+ $path = $arg;
+ } elsif( @ARGV ){
+ $path = shift( @ARGV );
+ } else {
+ Warn( "option -f requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ my $fst = $#Commands + 1;
+ open( SCRIPT, "<$path" ) || die( "$0: $path: could not open ($!)\n" );
+ my $cmd;
+ while( defined( $cmd = <SCRIPT> ) ){
+ chomp( $cmd );
+ push( @Commands, $cmd );
+ }
+ close( SCRIPT );
+ if( $#Commands >= $fst ){
+ $Defined{$fst} = "$path";
+ }
+ next;
+ }
+ if( $opt eq '-' && $arg eq '' ){
+ last;
+ }
+ if( $opt eq 'h' || $opt eq '?' ){
+ usage();
+ exit( 0 );
+ }
+ if( $opt eq 'n' ){
+ $doAutoPrint = 0;
+ } elsif( $opt eq 'a' ){
+ $doOpenWrite = 0;
+ } else {
+ Warn( "illegal option `$opt'" );
+ usage();
+ exit( 1 );
+ }
+ if( length( $arg ) ){
+ unshift( @ARGV, "-$arg" );
+ }
+}
+
+# A singleton command may be the 1st argument when there are no options.
+#
+if( @Commands == 0 ){
+ if( @ARGV == 0 ){
+ Warn( "no script command given" );
+ usage();
+ exit( 1 );
+ }
+ push( @Commands, split( "\n", shift( @ARGV ) ) );
+ $Defined{0} = ' #1';
+}
+
+print STDERR "Files: @ARGV\n" if $useDEBUG;
+
+# generate leading code
+#
+$Func = <<'[TheEnd]';
+
+# openARGV: open 1st input file
+#
+sub openARGV(){
+ unshift( @ARGV, '-' ) unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+}
+
+# getsARGV: Read another input line into argument (default: $_).
+# Move on to next input file, and reset EOF flag $isEOF.
+sub getsARGV(;\$){
+ my $argref = @_ ? shift() : \$_;
+ while( $isEOF || ! defined( $$argref = <ARG> ) ){
+ close( ARG );
+ return 0 unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+ }
+ 1;
+}
+
+# eofARGV: end-of-file test
+#
+sub eofARGV(){
+ return @ARGV == 0 && ( $isEOF = eof( ARG ) );
+}
+
+# makeHandle: Generates another file handle for some file (given by its path)
+# to be written due to a w command or an s command's w flag.
+sub makeHandle($){
+ my( $path ) = @_;
+ my $handle;
+ if( ! exists( $wFiles{$path} ) || $wFiles{$path} eq '' ){
+ $handle = $wFiles{$path} = gensym();
+ if( $doOpenWrite ){
+ if( ! open( $handle, ">$path" ) ){
+ die( "$0: can't open $path for writing: ($!)\n" );
+ }
+ }
+ } else {
+ $handle = $wFiles{$path};
+ }
+ return $handle;
+}
+
+# printQ: Print queued output which is either a string or a reference
+# to a pathname.
+sub printQ(){
+ for my $q ( @Q ){
+ if( ref( $q ) ){
+ # flush open w files so that reading this file gets it all
+ if( exists( $wFiles{$$q} ) && $wFiles{$$q} ne '' ){
+ open( $wFiles{$$q}, ">>$$q" );
+ }
+ # copy file to stdout: slow, but safe
+ if( open( RF, "<$$q" ) ){
+ while( defined( my $line = <RF> ) ){
+ print $line;
+ }
+ close( RF );
+ }
+ } else {
+ print $q;
+ }
+ }
+ undef( @Q );
+}
+
+[TheEnd]
+
+# generate the sed loop
+#
+$Code .= <<'[TheEnd]';
+sub openARGV();
+sub getsARGV(;\$);
+sub eofARGV();
+sub printQ();
+
+# Run: the sed loop reading input and applying the script
+#
+sub Run(){
+ my( $h, $icnt, $s, $n );
+ # hack (not unbreakable :-/) to avoid // matching an empty string
+ my $z = "\000"; $z =~ /$z/;
+ # Initialize.
+ openARGV();
+ $Hold = '';
+ $CondReg = 0;
+ $doPrint = $doAutoPrint;
+CYCLE:
+ while( getsARGV() ){
+ chomp();
+ $CondReg = 0; # cleared on t
+BOS:;
+[TheEnd]
+
+ # parse - avoid opening files when doing s2p
+ #
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+ Parse();
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+
+ # append trailing code
+ #
+ $Code .= <<'[TheEnd]';
+EOS: if( $doPrint ){
+ print $_, "\n";
+ } else {
+ $doPrint = $doAutoPrint;
+ }
+ printQ() if @Q;
+ }
+
+ exit( 0 );
+}
+[TheEnd]
+
+
+# append optional functions, prepend prototypes
+#
+my $Proto = "# prototypes\n";
+if( $GenKey{'l'} ){
+ $Proto .= "sub _l();\n";
+ $Func .= <<'[TheEnd]';
+# _l: l command processing
+#
+sub _l(){
+ my $h = $_;
+ my $mcpl = 70;
+ # transform non printing chars into escape notation
+ $h =~ s/\\/\\\\/g;
+ if( $h =~ /[^[:print:]]/ ){
+ $h =~ s/\a/\\a/g;
+ $h =~ s/\f/\\f/g;
+ $h =~ s/\n/\\n/g;
+ $h =~ s/\t/\\t/g;
+ $h =~ s/\r/\\r/g;
+ $h =~ s/\e/\\e/g;
+ $h =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge;
+ }
+ # split into lines of length $mcpl
+ while( length( $h ) > $mcpl ){
+ my $l = substr( $h, 0, $mcpl-1 );
+ $h = substr( $h, $mcpl );
+ # remove incomplete \-escape from end of line
+ if( $l =~ s/(?<!\\)(\\[0-7]{0,2})$// ){
+ $h = $1 . $h;
+ }
+ print $l, "\\\n";
+ }
+ print "$h\$\n";
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'r'} ){
+ $Proto .= "sub _r(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _r: r command processing: Save a reference to the pathname.
+#
+sub _r($){
+ my $path = shift();
+ push( @Q, \$path );
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'t'} ){
+ $Proto .= "sub _t();\n";
+ $Func .= <<'[TheEnd]';
+# _t: t command - condition register test/reset
+#
+sub _t(){
+ my $res = $CondReg;
+ $CondReg = 0;
+ $res;
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'w'} ){
+ $Proto .= "sub _w(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _w: w command and s command's w flag - write to file
+#
+sub _w($){
+ my $path = shift();
+ my $handle = $wFiles{$path};
+ if( ! $doOpenWrite && ! defined( fileno( $handle ) ) ){
+ open( $handle, ">$path" )
+ || die( "$0: $path: cannot open ($!)\n" );
+ }
+ print $handle $_, "\n";
+}
+
+[TheEnd]
+}
+
+$Code = $Proto . $Code;
+
+# magic "#n" - same as -n option
+#
+$doAutoPrint = 0 if substr( $Commands[0], 0, 2 ) eq '#n';
+
+# eval code - check for errors
+#
+print "Code:\n$Code$Func" if $useDEBUG;
+eval $Code . $Func;
+if( $@ ){
+ print "Code:\n$Code$Func";
+ die( "$0: internal error - generated incorrect Perl code: $@\n" );
+}
+
+if( $doGenerate ){
+
+ # write full Perl program
+ #
+
+ # bang line, declarations, prototypes
+ print <<TheEnd;
+#!$perlpath -w
+eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if 0;
+\$0 =~ s/^.*?(\\w+)\[\\.\\w+\]*\$/\$1/;
+
+use strict;
+use Symbol;
+use vars qw{ \$isEOF \$Hold \%wFiles \@Q \$CondReg
+ \$doAutoPrint \$doOpenWrite \$doPrint };
+\$doAutoPrint = $doAutoPrint;
+\$doOpenWrite = $doOpenWrite;
+TheEnd
+
+ my $wf = "'" . join( "', '", keys( %wFiles ) ) . "'";
+ if( $wf ne "''" ){
+ print <<TheEnd;
+sub makeHandle(\$);
+for my \$p ( $wf ){
+ exit( 1 ) unless makeHandle( \$p );
+}
+TheEnd
+ }
+
+ print $Code;
+ print "Run();\n";
+ print $Func;
+ exit( 0 );
+
+} else {
+
+ # execute: make handles (and optionally open) all w files; run!
+ for my $p ( keys( %wFiles ) ){
+ exit( 1 ) unless makeHandle( $p );
+ }
+ Run();
+}
+
+
+=head1 ENVIRONMENT
+
+The environment variable C<PSEDEXTBRE> may be set to extend BREs.
+See L<"Additional Atoms">.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item ambiguous translation for character `%s' in `y' command
+
+The indicated character appears twice, with different translations.
+
+=item `[' cannot be last in pattern
+
+A `[' in a BRE indicates the beginning of a I<bracket expression>.
+
+=item `\' cannot be last in pattern
+
+A `\' in a BRE is used to make the subsequent character literal.
+
+=item `\' cannot be last in substitution
+
+A `\' in a subsitution string is used to make the subsequent character literal.
+
+=item conflicting flags `%s'
+
+In an B<s> command, either the `g' flag and an n-th occurrence flag, or
+multiple n-th occurrence flags are specified. Note that only the digits
+`1' through `9' are permitted.
+
+=item duplicate label %s (first defined at %s)
+
+=item excess address(es)
+
+The command has more than the permitted number of addresses.
+
+=item extra characters after command (%s)
+
+=item illegal option `%s'
+
+=item improper delimiter in s command
+
+The BRE and substitution may not be delimited with `\' or newline.
+
+=item invalid address after `,'
+
+=item invalid backreference (%s)
+
+The specified backreference number exceeds the number of backreferences
+in the BRE.
+
+=item invalid repeat clause `\{%s\}'
+
+The repeat clause does not contain a valid integer value, or pair of
+values.
+
+=item malformed regex, 1st address
+
+=item malformed regex, 2nd address
+
+=item malformed regular expression
+
+=item malformed substitution expression
+
+=item malformed `y' command argument
+
+The first or second string of a B<y> command is syntactically incorrect.
+
+=item maximum less than minimum in `\{%s\}'
+
+=item no script command given
+
+There must be at least one B<-e> or one B<-f> option specifying a
+script or script file.
+
+=item `\' not valid as delimiter in `y' command
+
+=item option -e requires an argument
+
+=item option -f requires an argument
+
+=item `s' command requires argument
+
+=item start of unterminated `{'
+
+=item string lengths in `y' command differ
+
+The translation table strings in a B<y> command must have equal lengths.
+
+=item undefined label `%s'
+
+=item unexpected `}'
+
+A B<}> command without a preceding B<{> command was encountered.
+
+=item unexpected end of script
+
+The end of the script was reached although a text line after a
+B<a>, B<c> or B<i> command indicated another line.
+
+=item unknown command `%s'
+
+=item unterminated `['
+
+A BRE contains an unterminated bracket expression.
+
+=item unterminated `\('
+
+A BRE contains an unterminated backreference.
+
+=item `\{' without closing `\}'
+
+A BRE contains an unterminated bounds specification.
+
+=item `\)' without preceding `\('
+
+=item `y' command requires argument
+
+=back
+
+=head1 EXAMPLE
+
+The basic material for the preceding section was generated by running
+the sed script
+
+ #no autoprint
+ s/^.*Warn( *"\([^"]*\)".*$/\1/
+ t process
+ b
+ :process
+ s/$!/%s/g
+ s/$[_[:alnum:]]\{1,\}/%s/g
+ s/\\\\/\\/g
+ s/^/=item /
+ p
+
+on the program's own text, and piping the output into C<sort -u>.
+
+
+=head1 SED SCRIPT TRANSLATION
+
+If this program is invoked with the name F<s2p> it will act as a
+sed-to-Perl translator. After option processing (all other
+arguments are ignored), a Perl program is printed on standard
+output, which will process the input stream (as read from all
+arguments) in the way defined by the sed script and the option setting
+used for the translation.
+
+=head1 SEE ALSO
+
+perl(1), re_format(7)
+
+=head1 BUGS
+
+The B<l> command will show escape characters (ESC) as `C<\e>', but
+a vertical tab (VT) in octal.
+
+Trailing spaces are truncated from labels in B<:>, B<t> and B<b> commands.
+
+The meaning of an empty regular expression (`C<//>'), as defined by B<sed>,
+is "the last pattern used, at run time". This deviates from the Perl
+interpretation, which will re-use the "last last successfully executed
+regular expression". Since keeping track of pattern usage would create
+terribly cluttered code, and differences would only appear in obscure
+context (where other B<sed> implementations appear to deviate, too),
+the Perl semantics was adopted. Note that common usage of this feature,
+such as in C</abc/s//xyz/>, will work as expected.
+
+Collating elements (of bracket expressions in BREs) are not implemented.
+
+=head1 STANDARDS
+
+This B<sed> implementation conforms to the IEEE Std1003.2-1992 ("POSIX.2")
+definition of B<sed>, and is compatible with the I<OpenBSD>
+implementation, except where otherwise noted (see L<"BUGS">).
+
+=head1 AUTHOR
+
+This Perl implementation of I<sed> was written by Wolfgang Laun,
+I<Wolfgang.Laun@alcatel.at>.
+
+=head1 COPYRIGHT and LICENSE
+
+This program is free and open software. You may use, modify,
+distribute, and sell this program (and any modified variants) in any
+way you wish, provided you do not restrict others from doing the same.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/search.bat b/Master/tlpkg/tlperl.straw/bin/search.bat
new file mode 100755
index 00000000000..963cb269213
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/search.bat
@@ -0,0 +1,1887 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+'di';
+'ig00';
+##############################################################################
+##
+## search
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp), Dec 1994.
+## Copyright 19.... ah hell, just take it.
+##
+## BLURB:
+## A combo of find and grep -- more or less do a 'grep' on a whole
+## directory tree. Fast, with lots of options. Much more powerful than
+## the simple "find ... | xargs grep ....". Has a full man page.
+## Powerfully customizable.
+##
+## This file is big, but mostly comments and man page.
+##
+## See man page for usage info.
+## Return value: 2=error, 1=nothing found, 0=something found.
+##
+
+$version = "950918.5";
+##
+## "950918.5";
+## Changed all 'sysread' to 'read' because Linux perl's don't seem
+## to like sysread()
+##
+## "941227.4";
+## Added -n, -u
+##
+## "941222.3"
+## Added -nice (due to Lionel Cons <Lionel.Cons@cern.ch>)
+## Removed any leading "./" from name.
+## Added default flags for ~/.search, including TTY, -nice, -list, etc.
+## Program name now has path removed when printed in diagnostics.
+## Added simple tilde-expansion to -dir arg.
+## Added -dskip, etc. Fixed -iregex bug.
+## Changed -dir to be additive, adding -ddir.
+## Now screen out devices, pipes, and sockets.
+## More tidying and lots of expanding of the man page
+##
+##
+## "941217.2";
+## initial release.
+
+$stripped=0;
+
+&init;
+if (exists $ENV{'HOME'}) {
+ $rc_file = join('/', $ENV{'HOME'}, ".search");
+}
+else {
+ $rc_file = "";
+}
+
+&check_args;
+
+## Make sure we've got a regex.
+## Don't need one if -find or -showrc was specified.
+$!=2, die "expecting regex arguments.\n"
+ if $FIND_ONLY == 0 && $showrc == 0 && @ARGV == 0;
+
+&prepare_to_search($rc_file);
+
+&import_program if !defined &dodir; ## BIG key to speed.
+
+## do search while there are directories to be done.
+&dodir(shift(@todo)) while @todo;
+
+&clear_message if $VERBOSE && $STDERR_IS_TTY;
+exit($retval);
+###############################################################################
+
+sub init
+{
+ ## initialize variables that might be reset by command-line args
+ $DOREP=0; ## set true by -dorep (redo multi-hardlink files)
+ $DOREP=1 if $^O eq 'MSWin32';
+ $DO_SORT=0; ## set by -sort (sort files in a dir before checking)
+ $FIND_ONLY=0; ## set by -find (don't search files)
+ $LIST_ONLY=0; ## set true by -l (list filenames only)
+ $NEWER=0; ## set by -newer, "-mtime -###"
+ $NICE=0; ## set by -nice (print human-readable output)
+ $NOLINKS=0; ## set true by -nolinks (don't follow symlinks)
+ $OLDER=0; ## set by -older, "-mtime ###"
+ $PREPEND_FILENAME=1; ## set false by -h (don't prefix lines with filename)
+ $REPORT_LINENUM=0; ## set true by -n (show line numbers)
+ $VERBOSE=0; ## set to a value by -v, -vv, etc. (verbose messages)
+ $WHY=0; ## set true by -why, -vvv+ (report why skipped)
+ $XDEV=0; ## set true by -xdev (stay on one filesystem)
+ $all=0; ## set true by -all (don't skip many kinds of files)
+ $iflag = ''; ## set to 'i' by -i (ignore case);
+ $norc=0; ## set by -norc (don't load rc file)
+ $showrc=0; ## set by -showrc (show what happens with rc file)
+ $underlineOK=0; ## set true by -u (watch for underline stuff)
+ $words=0; ## set true by -w (match whole-words only)
+ $DELAY=0; ## inter-file delay (seconds)
+ $retval=1; ## will set to 0 if we find anything.
+
+ ## various elements of stat() that we might access
+ $STAT_DEV = 1;
+ $STAT_INODE = 2;
+ $STAT_MTIME = 9;
+
+ $VV_PRINT_COUNT = 50; ## with -vv, print every VV_PRINT_COUNT files, or...
+ $VV_SIZE = 1024*1024; ## ...every VV_SIZE bytes searched
+ $vv_print = $vv_size = 0; ## running totals.
+
+ ## set default options, in case the rc file wants them
+ $opt{'TTY'}= 1 if -t STDOUT;
+
+ ## want to know this for debugging message stuff
+ $STDERR_IS_TTY = -t STDERR ? 1 : 0;
+ $STDERR_SCREWS_STDOUT = ($STDERR_IS_TTY && -t STDOUT) ? 1 : 0;
+
+ $0 =~ s,.*/,,; ## clean up $0 for any diagnostics we'll be printing.
+}
+
+##
+## Check arguments.
+##
+sub check_args
+{
+ while (@ARGV && $ARGV[0] =~ m/^-/)
+ {
+ $arg = shift(@ARGV);
+
+ if ($arg eq '-version' || ($VERBOSE && $arg eq '-help')) {
+ print qq/Jeffrey's file search, version "$version".\n/;
+ exit(0) unless $arg eq '-help';
+ }
+ if ($arg eq '-help') {
+ print <<INLINE_LITERAL_TEXT;
+usage: $0 [options] [-e] [PerlRegex ....]
+OPTIONS TELLING *WHERE* TO SEARCH:
+ -dir DIR start search at the named directory (default is current dir).
+ -xdev stay on starting file system.
+ -sort sort the files in each directory before processing.
+ -nolinks don't follow symbolic links.
+OPTIONS TELLING WHICH FILES TO EVEN CONSIDER:
+ -mtime # consider files modified > # days ago (-# for < # days old)
+ -newer FILE consider files modified more recently than FILE (also -older)
+ -name GLOB consider files whose name matches pattern (also -regex).
+ -skip GLOB opposite of -name: identifies files to not consider.
+ -path GLOB like -name, but for files whose whole path is described.
+ -dpath/-dregex/-dskip versions for selecting or pruning directories.
+ -all don't skip any files marked to be skipped by the startup file.
+ -x<SPECIAL> (see manual, and/or try -showrc).
+ -why report why a file isn't checked (also implied by -vvvv).
+OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED:
+ -f | -find just list files (PerlRegex ignored). Default is to grep them.
+ -ff | -ffind Does a faster -find (implies -find -all -dorep)
+OPTIONS CONTROLLING HOW THE SEARCH IS DONE (AND WHAT IS PRINTED):
+ -l | -list only list files with matches, not the lines themselves.
+ -nice | -nnice print more "human readable" output.
+ -n prefix each output line with its line number in the file.
+ -h don't prefix output lines with file name.
+ -u also look "inside" manpage-style underlined text
+ -i do case-insensitive searching.
+ -w match words only (as defined by perl's \\b).
+OTHER OPTIONS:
+ -v, -vv, -vvv various levels of message verbosity.
+ -e end of options (in case a regex looks like an option).
+ -showrc show what the rc file sets, then exit.
+ -norc don't load the rc file.
+ -dorep check files with multiple hard links multiple times.
+INLINE_LITERAL_TEXT
+ print "Use -v -help for more verbose help.\n" unless $VERBOSE;
+ print "This script file is also a man page.\n" unless $stripped;
+ print <<INLINE_LITERAL_TEXT if $VERBOSE;
+
+If -f (or -find) given, PerlRegex is optional and ignored.
+Otherwise, will search for files with lines matching any of the given regexes.
+
+Combining things like -name and -mtime implies boolean AND.
+However, duplicating things (such as -name '*.c' -name '*.txt') implies OR.
+
+-mtime may be given floating point (i.e. 1.5 is a day and a half).
+-iskip/-idskip/-ipath/... etc are case-insensitive versions.
+
+If any letter in -newer/-older is upper case, "or equal" is
+inserted into the test.
+
+You can always find the latest version on the World Wide Web in
+ http://www.wg.omron.co.jp/~jfriedl/perl/
+INLINE_LITERAL_TEXT
+ exit(0);
+ }
+ $DOREP=1, next if $arg eq '-dorep'; ## do repeats
+ $DO_SORT=1, next if $arg eq '-sort'; ## sort files
+ $NOLINKS=1, next if $arg eq '-nolinks'; ## no sym. links
+ $PREPEND_FILENAME=0, next if $arg eq '-h'; ## no filename prefix
+ $REPORT_LINENUM=1, next if $arg eq '-n'; ## show line numbers
+ $WHY=1, next if $arg eq '-why'; ## tell why skipped
+ $XDEV=1, next if $arg eq '-xdev'; ## don't leave F.S.
+ $all=1,$opt{'-all'}=1,next if $arg eq '-all'; ## don't skip *.Z, etc
+ $iflag='i', next if $arg eq '-i'; ## ignore case
+ $norc=1, next if $arg eq '-norc'; ## don't load rc file
+ $showrc=1, next if $arg eq '-showrc'; ## show rc file
+ $underlineOK=1, next if $arg eq '-u'; ## look throuh underln.
+ $words=1, next if $arg eq '-w'; ## match "words" only
+ &strip if $arg eq '-strip'; ## dump this program
+ last if $arg eq '-e';
+ $DELAY=$1, next if $arg =~ m/-delay(\d+)/;
+
+ $FIND_ONLY=1, next if $arg =~/^-f(ind)?$/;## do "find" only
+
+ $FIND_ONLY=1, $DOREP=1, $all=1,
+ next if $arg =~/^-ff(ind)?$/;## fast -find
+ $LIST_ONLY=1,$opt{'-list'}=1,
+ next if $arg =~/^-l(ist)?$/;## only list files
+
+ if ($arg =~ m/^-(v+)$/) { ## verbosity
+ $VERBOSE =length($1);
+ foreach $len (1..$VERBOSE) { $opt{'-'.('v' x $len)}=1 }
+ next;
+ }
+ if ($arg =~ m/^-(n+)ice$/) { ## "nice" output
+ $NICE =length($1);
+ foreach $len (1..$NICE) { $opt{'-'.('n' x $len).'ice'}=1 }
+ next;
+ }
+
+ if ($arg =~ m/^-(i?)(d?)skip$/) {
+ local($i) = $1 eq 'i';
+ local($d) = $2 eq 'd';
+ $! = 2, die qq/$0: expecting glob arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ if ($d) {
+ $idskip{$_}=1 if $i;
+ $dskip{$_}=1;
+ } else {
+ $iskip{$_}=1 if $i;
+ $skip{$_}=1;
+ }
+ }
+ next;
+ }
+
+
+ if ($arg =~ m/^-(i?)(d?)(regex|path|name)$/) {
+ local($i) = $1 eq 'i';
+ $! = 2, die qq/$0: expecting arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ $iname{join(',', $arg, $_)}=1 if $i;
+ $name{join(',', $arg, $_)}=1;
+ }
+ next;
+ }
+
+ if ($arg =~ m/^-d?dir$/) {
+ $opt{'-dir'}=1;
+ $! = 2, die qq/$0: expecting filename arg to -$arg\n/ unless @ARGV;
+ $start = shift(@ARGV);
+ $start =~ s#^~(/+|$)#$ENV{'HOME'}$1# if defined $ENV{'HOME'};
+ $! = 2, die qq/$0: can't find ${arg}'s "$start"\n/ unless -e $start;
+ $! = 2, die qq/$0: ${arg}'s "$start" not a directory.\n/ unless -d _;
+ undef(@todo), $opt{'-ddir'}=1 if $arg eq '-ddir';
+ push(@todo, $start);
+ next;
+ }
+
+ if ($arg =~ m/^-(new|old)er$/i) {
+ $! = 2, die "$0: expecting filename arg to -$arg\n" unless @ARGV;
+ local($file, $time) = shift(@ARGV);
+ $! = 2, die qq/$0: can't stat -${arg}'s "$file"./
+ unless $time = (stat($file))[$STAT_MTIME];
+ local($upper) = $arg =~ tr/A-Z//;
+ if ($arg =~ m/new/i) {
+ $time++ unless $upper;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ $time-- unless $upper;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ if ($arg =~ m/-mtime/) {
+ $! = 2, die "$0: expecting numerical arg to -$arg\n" unless @ARGV;
+ local($days) = shift(@ARGV);
+ $! = 2, die qq/$0: inappropriate arg ($days) to $arg\n/ if $days==0;
+ $days *= 3600 * 24;
+ if ($days < 0) {
+ local($time) = $^T + $days;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ local($time) = $^T - $days;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ ## special user options
+ if ($arg =~ m/^-x(.+)/) {
+ foreach (split(/[\s,]+/, $1)) { $user_opt{$_} = $opt{$_}= 1; }
+ next;
+ }
+
+ $! = 2, die "$0: unknown arg [$arg]\n";
+ }
+}
+
+##
+## Given a filename glob, return a regex.
+## If the glob has no globbing chars (no * ? or [..]), then
+## prepend an effective '*' to it.
+##
+sub glob_to_regex
+{
+ local($glob) = @_;
+ local(@parts) = $glob =~ m/\\.|[*?]|\[]?[^]]*]|[^[\\*?]+/g;
+ local($trueglob)=0;
+ foreach (@parts) {
+ if ($_ eq '*' || $_ eq '?') {
+ $_ = ".$_";
+ $trueglob=1; ## * and ? are a real glob
+ } elsif (substr($_, 0, 1) eq '[') {
+ $trueglob=1; ## [..] is a real glob
+ } else {
+ s/^\\//; ## remove any leading backslash;
+ s/\W/\\$&/g; ## now quote anything dangerous;
+ }
+ }
+ unshift(@parts, '.*') unless $trueglob;
+ join('', '^', @parts, '$');
+}
+
+sub prepare_to_search
+{
+ local($rc_file) = @_;
+
+ $HEADER_BYTES=0; ## Might be set nonzero in &read_rc;
+ $last_message_length = 0; ## For &message and &clear_message.
+
+ &read_rc($rc_file, $showrc) unless $norc;
+ exit(0) if $showrc;
+
+ $NEXT_DIR_ENTRY = $DO_SORT ? 'shift @files' : 'readdir(DIR)';
+ $WHY = 1 if $VERBOSE > 3; ## Arg -vvvv or above implies -why.
+ @todo = ('.') if @todo == 0; ## Where we'll start looking
+
+ ## see if any user options were specified that weren't accounted for
+ foreach $opt (keys %user_opt) {
+ next if defined $seen_opt{$opt};
+ warn "warning: -x$opt never considered.\n";
+ }
+
+ die "$0: multiple time constraints exclude all possible files.\n"
+ if ($NEWER && $OLDER) && ($NEWER > $OLDER);
+
+ ##
+ ## Process any -skip/-iskip args that had been given
+ ##
+ local(@skip_test);
+ foreach $glob (keys %skip) {
+ $i = defined($iskip{$glob}) ? 'i': '';
+ push(@skip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@skip_test) {
+ $SKIP_TEST = join('||',@skip_test);
+ $DO_SKIP_TEST = 1;
+ } else {
+ $DO_SKIP_TEST = $SKIP_TEST = 0;
+ }
+
+ ##
+ ## Process any -dskip/-idskip args that had been given
+ ##
+ local(@dskip_test);
+ foreach $glob (keys %dskip) {
+ $i = defined($idskip{$glob}) ? 'i': '';
+ push(@dskip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@dskip_test) {
+ $DSKIP_TEST = join('||',@dskip_test);
+ $DO_DSKIP_TEST = 1;
+ } else {
+ $DO_DSKIP_TEST = $DSKIP_TEST = 0;
+ }
+
+
+ ##
+ ## Process any -name, -path, -regex, etc. args that had been given.
+ ##
+ undef @name_test;
+ undef @dname_test;
+ foreach $key (keys %name) {
+ local($type, $pat) = split(/,/, $key, 2);
+ local($i) = defined($iname{$key}) ? 'i' : '';
+ if ($type =~ /regex/) {
+ $pat =~ s/!/\\!/g;
+ $test = "\$name =~ m!^$pat\$!$i";
+ } else {
+ local($var) = $type eq 'name' ? '$name' : '$file';
+ $test = "$var =~ m/". &glob_to_regex($pat). "/$i";
+ }
+ if ($type =~ m/^-i?d/) {
+ push(@dname_test, $test);
+ } else {
+ push(@name_test, $test);
+ }
+ }
+ if (@name_test) {
+ $GLOB_TESTS = join('||', @name_test);
+
+ $DO_GLOB_TESTS = 1;
+ } else {
+ $GLOB_TESTS = $DO_GLOB_TESTS = 0;
+ }
+ if (@dname_test) {
+ $DGLOB_TESTS = join('||', @dname_test);
+ $DO_DGLOB_TESTS = 1;
+ } else {
+ $DGLOB_TESTS = $DO_DGLOB_TESTS = 0;
+ }
+
+
+ ##
+ ## Process any 'magic' things from the startup file.
+ ##
+ if (@magic_tests && $HEADER_BYTES) {
+ ## the $magic' one is for when &dodir is not inlined
+ $tests = join('||',@magic_tests);
+ $MAGIC_TESTS = " { package magic; \$val = ($tests) }";
+ $DO_MAGIC_TESTS = 1;
+ } else {
+ $MAGIC_TESTS = 1;
+ $DO_MAGIC_TESTS = 0;
+ }
+
+ ##
+ ## Prepare regular expressions.
+ ##
+ {
+ local(@regex_tests);
+
+ if ($LIST_ONLY) {
+ $mflag = '';
+ ## need to have $* set, but perl5 just won''t shut up about it.
+ if ($] >= 5) {
+ $mflag = 'm';
+ } else {
+ eval ' $* = 1 ';
+ }
+ }
+
+ ##
+ ## Until I figure out a better way to deal with it,
+ ## We have to worry about a regex like [^xyz] when doing $LIST_ONLY.
+ ## Such a regex *will* match \n, and if I'm pulling in multiple
+ ## lines, it can allow lines to match that would otherwise not match.
+ ##
+ ## Therefore, if there is a '[^' in a regex, we can NOT take a chance
+ ## an use the fast listonly.
+ ##
+ $CAN_USE_FAST_LISTONLY = $LIST_ONLY;
+
+ local(@extra);
+ local($underline_glue) = ($] >= 5) ? '(:?_\cH)?' : '(_\cH)?';
+ while (@ARGV) {
+ $regex = shift(@ARGV);
+ ##
+ ## If watching for underlined things too, add another regex.
+ ##
+ if ($underlineOK) {
+ if ($regex =~ m/[?*+{}()\\.|^\$[]/) {
+ warn "$0: warning, can't underline-safe ``$regex''.\n";
+ } else {
+ $regex = join($underline_glue, split(//, $regex));
+ }
+ }
+
+ ## If nothing special in the regex, just use index...
+ ## is quite a bit faster.
+ if (($iflag eq '') && ($words == 0) &&
+ $regex !~ m/[?*+{}()\\.|^\$[]/)
+ {
+ push(@regex_tests, "(index(\$_, q+$regex+)>=0)");
+
+ } else {
+ $regex =~ s#[\$\@\/]\w#\\$&#;
+ if ($words) {
+ if ($regex =~ m/\|/) {
+ ## could be dangerous -- see if we can wrap in parens.
+ if ($regex =~ m/\\\d/) {
+ warn "warning: -w and a | in a regex is dangerous.\n"
+ } else {
+ $regex = join($regex, '(', ')');
+ }
+ }
+ $regex = join($regex, '\b', '\b');
+ }
+ $CAN_USE_FAST_LISTONLY = 0 if substr($regex, "[^") >= 0;
+ push(@regex_tests, "m/$regex/$iflag$mflag");
+ }
+
+ ## If we're done, but still have @extra to do, get set for that.
+ if (@ARGV == 0 && @extra) {
+ @ARGV = @extra; ## now deal with the extra stuff.
+ $underlineOK = 0; ## but no more of this.
+ undef @extra; ## or this.
+ }
+ }
+ if (@regex_tests) {
+ $REGEX_TEST = join('||', @regex_tests);
+ ## print STDERR $REGEX_TEST, "\n"; exit;
+ } else {
+ ## must be doing -find -- just give something syntactically correct.
+ $REGEX_TEST = 1;
+ }
+ }
+
+ ##
+ ## Make sure we can read the first item(s).
+ ##
+ foreach $start (@todo) {
+ $! = 2, die qq/$0: can't stat "$start"\n/
+ unless ($dev,$inode) = (stat($start))[$STAT_DEV,$STAT_INODE];
+
+ if (defined $dir_done{"$dev,$inode"}) {
+ ## ignore the repeat.
+ warn(qq/ignoring "$start" (same as "$dir_done{"$dev,$inode"}").\n/)
+ if $VERBOSE;
+ next;
+ }
+
+ ## if -xdev was given, remember the device.
+ $xdev{$dev} = 1 if $XDEV;
+
+ ## Note that we won't want to do it again
+ $dir_done{"$dev,$inode"} = $start;
+ }
+}
+
+
+##
+## See the comment above the __END__ above the 'sub dodir' below.
+##
+sub import_program
+{
+ sub bad {
+ print STDERR "$0: internal error (@_)\n";
+ exit 2;
+ }
+
+ ## Read from data, up to next __END__. This will be &dodir.
+ local($/) = "\n__END__";
+ $prog = <DATA>;
+ close(DATA);
+
+ $prog =~ s/\beval\b//g; ## remove any 'eval'
+
+ ## Inline uppercase $-variables by their current values.
+ if ($] >= 5) {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/
+ &bad($1) if !defined ${$main::{$1}}; ${$main::{$1}};/eg;
+ } else {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/local(*VAR) = $_main{$1};
+ &bad($1) if !defined $VAR; $VAR;/eg;
+ }
+
+ eval $prog; ## now do it. This will define &dodir;
+ $!=2, die "$0 internal error: $@\n" if $@;
+}
+
+###########################################################################
+
+##
+## Read the .search file:
+## Blank lines and lines that are only #-comments ignored.
+## Newlines may be escaped to create long lines
+## Other lines are directives.
+##
+## A directive may begin with an optional tag in the form <...>
+## Things inside the <...> are evaluated as with:
+## <(this || that) && must>
+## will be true if
+## -xmust -xthis or -xmust -xthat
+## were specified on the command line (order doesn't matter, though)
+## A directive is not done if there is a tag and it's false.
+## Any characters but whitespace and &|()>,! may appear after an -x
+## (although "-xdev" is special). -xmust,this is the same as -xmust -xthis.
+## Something like -x~ would make <~> true, and <!~> false.
+##
+## Directives are in the form:
+## option: STRING
+## magic : NUMBYTES : EXPR
+##
+## With option:
+## The STRING is parsed like a Bourne shell command line, and the
+## options are used as if given on the command line.
+## No comments are allowed on 'option' lines.
+## Examples:
+## # skip objects and libraries
+## option: -skip '.o .a'
+## # skip emacs *~ and *# files, unless -x~ given:
+## <!~> option: -skip '~ #'
+##
+## With magic:
+## EXPR can be pretty much any perl (comments allowed!).
+## If it evaluates to true for any particular file, it is skipped.
+## The only info you'll have about a file is the variable $H, which
+## will have at least the first NUMBYTES of the file (less if the file
+## is shorter than that, of course, and maybe more). You'll also have
+## any variables you set in previous 'magic' lines.
+## Examples:
+## magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+## magic: 6 : $x6 eq 'GIF89a'
+##
+## magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a' ## old gif \
+## || $x6 eq 'GIF89a' ## new gif
+## (the above two sets are the same)
+## ## Check the first 32 bytes for "binarish" looking bytes.
+## ## Don't blindly dump on any high-bit set, as non-ASCII text
+## ## often has them set. \x80 and \xff seem to be special, though.
+## ## Require two in a row to not get things like perl's $^T.
+## ## This is known to get *.Z, *.gz, pkzip, *.elc and about any
+## ## executable you'll find.
+## magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+##
+sub read_rc
+{
+ local($file, $show) = @_;
+ local($line_num, $ln, $tag) = 0;
+ local($use_default, @default) = 0;
+
+ { package magic; $^W= 0; } ## turn off warnings for when we run EXPR's
+
+ unless (open(RC, "$file")) {
+ $use_default=1;
+ $file = "<internal default startup file>";
+ ## no RC file -- use this default.
+ @default = split(/\n/,<<'--------INLINE_LITERAL_TEXT');
+ magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+ option: -skip '.a .elc .gz .o .pbm .xbm .dvi'
+ option: -iskip '.com .exe .lib .pdb .tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+--------INLINE_LITERAL_TEXT
+ }
+
+ ##
+ ## Make an eval error pretty.
+ ##
+ sub clean_eval_error {
+ local($_) = @_;
+ s/ in file \(eval\) at line \d+,//g; ## perl4-style error
+ s/ at \(eval \d+\) line \d+,//g; ## perl5-style error
+ $_ = $` if m/\n/; ## remove all but first line
+ "$_\n";
+ }
+
+ print "reading RC file: $file\n" if $show;
+
+ while (defined($_ = ($use_default ? shift(@default) : <RC>))) {
+ $ln = ++$line_num; ## note starting line num.
+ $_ .= <RC>, $line_num++ while s/\\\n?$/\n/; ## allow continuations
+ next if /^\s*(#.*)?$/; ## skip blank or comment-only lines.
+ $do = '';
+
+ ## look for an initial <...> tag.
+ if (s/^\s*<([^>]*)>//) {
+ ## This simple s// will make the tag ready to eval.
+ ($tag = $msg = $1) =~
+ s/[^\s&|(!)]+/
+ $seen_opt{$&}=1; ## note seen option
+ "defined(\$opt{q>$&>})" ## (q>> is safe quoting here)
+ /eg;
+
+ ## see if the tag is true or not, abort this line if not.
+ $dothis = (eval $tag);
+ $!=2, die "$file $ln <$msg>: $_".&clean_eval_error($@) if $@;
+
+ if ($show) {
+ $msg =~ s/[^\s&|(!)]+/-x$&/;
+ $msg =~ s/\s*!\s*/ no /g;
+ $msg =~ s/\s*&&\s*/ and /g;
+ $msg =~ s/\s*\|\|\s*/ or /g;
+ $msg =~ s/^\s+//; $msg =~ s/\s+$//;
+ $do = $dothis ? "(doing because $msg)" :
+ "(do if $msg)";
+ } elsif (!$dothis) {
+ next;
+ }
+ }
+
+ if (m/^\s*option\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($_) = $';
+ s/\n$//;
+ local($orig) = $_;
+ print " $do option: $_\n" if $show;
+ local($0) = "$0 ($file)"; ## for any error message.
+ local(@ARGV);
+ local($this);
+ ##
+ ## Parse $_ as a Bourne shell line -- fill @ARGV
+ ##
+ while (length) {
+ if (s/^\s+//) {
+ push(@ARGV, $this) if defined $this;
+ undef $this;
+ next;
+ }
+ $this = '' if !defined $this;
+ $this .= $1 while s/^'([^']*)'// ||
+ s/^"([^"]*)"// ||
+ s/^([^'"\s\\]+)//||
+ s/^(\\[\D\d])//;
+ die "$file $ln: error parsing $orig at $_\n" if m/^\S/;
+ }
+ push(@ARGV, $this) if defined $this;
+ &check_args;
+ die qq/$file $ln: unused arg "@ARGV".\n/ if @ARGV;
+ next;
+ }
+
+ if (m/^\s*magic\s*:\s*(\d+)\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($bytes, $check) = ($1, $');
+
+ if ($show) {
+ $check =~ s/\n?$/\n/;
+ print " $do contents: $check";
+ }
+ ## Check to make sure the thing at least compiles.
+ eval "package magic; (\$H = '1'x \$main'bytes) && (\n$check\n)\n";
+ $! = 2, die "$file $ln: ".&clean_eval_error($@) if $@;
+
+ $HEADER_BYTES = $bytes if $bytes > $HEADER_BYTES;
+ push(@magic_tests, "(\n$check\n)");
+ next;
+ }
+ $! = 2, die "$file $ln: unknown command\n";
+ }
+ close(RC);
+}
+
+sub message
+{
+ if (!$STDERR_IS_TTY) {
+ print STDERR $_[0], "\n";
+ } else {
+ local($text) = @_;
+ $thislength = length($text);
+ if ($thislength >= $last_message_length) {
+ print STDERR $text, "\r";
+ } else {
+ print STDERR $text, ' 'x ($last_message_length-$thislength),"\r";
+ }
+ $last_message_length = $thislength;
+ }
+}
+
+sub clear_message
+{
+ print STDERR ' ' x $last_message_length, "\r" if $last_message_length;
+ $vv_print = $vv_size = $last_message_length = 0;
+}
+
+##
+## Output a copy of this program with comments, extra whitespace, and
+## the trailing man page removed. On an ultra slow machine, such a copy
+## might load faster (but I can't tell any difference on my machine).
+##
+sub strip {
+ seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
+ while(<DATA>) {
+ print, next if /INLINE_LITERAL_TEXT/.../INLINE_LITERAL_TEXT/;
+ ## must mention INLINE_LITERAL_TEXT on this line!
+ s/\#\#.*|^\s+|\s+$//; ## remove cruft
+ last if $_ eq '.00;';
+ next if ($_ eq '') || ($_ eq "'di'") || ($_ eq "'ig00'");
+ s/\$stripped=0;/\$stripped=1;/;
+ s/\s\s+/ /; ## squish multiple whitespaces down to one.
+ print $_, "\n";
+ }
+ exit(0);
+}
+
+##
+## Just to shut up -w. Never executed.
+##
+sub dummy {
+
+ 1 || &dummy || &dir_done || &bad || &message || $NEXT_DIR_ENTRY ||
+ $DELAY || $VV_SIZE || $VV_PRINT_COUNT || $STDERR_SCREWS_STDOUT ||
+ @files || @files || $magic'H || $magic'H || $xdev{''} || &clear_message;
+
+}
+
+##
+## If the following __END__ is in place, what follows will be
+## inlined when the program first starts up. Any $ variable name
+## all in upper case, specifically, any string matching
+## \$([A-Z][A-Z0-9_]{2,}\b
+## will have the true value for that variable inlined. Also, any 'eval' is
+## removed
+##
+## The idea is that when the whole thing is then eval'ed to define &dodir,
+## the perl optimizer will make all the decisions that are based upon
+## command-line options (such as $VERBOSE), since they'll be inlined as
+## constants
+##
+## Also, and here's the big win, the tests for matching the regex, and a
+## few others, are all inlined. Should be blinding speed here.
+##
+## See the read from <DATA> above for where all this takes place.
+## But all-in-all, you *want* the __END__ here. Comment it out only for
+## debugging....
+##
+
+__END__
+
+##
+## Given a directory, check all "appropriate" files in it.
+## Shove any subdirectories into the global @todo, so they'll be done
+## later.
+##
+## Be careful about adding any upper-case variables, as they are subject
+## to being inlined. See comments above the __END__ above.
+##
+sub dodir
+{
+ local($dir) = @_;
+ $dir =~ s,/+$,,; ## remove any trailing slash.
+ unless (opendir(DIR, "$dir/.")) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq($0: can't opendir "$dir/".\n);
+ return;
+ }
+
+ if ($VERBOSE) {
+ &message($dir);
+ $vv_print = $vv_size = 0;
+ }
+
+ @files = sort readdir(DIR) if $DO_SORT;
+
+ while (defined($name = eval $NEXT_DIR_ENTRY))
+ {
+ next if $name eq '.' || $name eq '..'; ## never follow these.
+
+ ## create full relative pathname.
+ $file = $dir eq '.' ? $name : "$dir/$name";
+
+ ## if link and skipping them, do so.
+ if ($NOLINKS && -l $file) {
+ warn qq/skip (symlink): $file\n/ if $WHY;
+ next;
+ }
+
+ ## skip things unless files or directories
+ unless (-f $file || -d _) {
+ if ($WHY) {
+ $why = (-S _ && "socket") ||
+ (-p _ && "pipe") ||
+ (-b _ && "block special")||
+ (-c _ && "char special") || "somekinda special";
+ warn qq/skip ($why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things we can't read
+ unless (-r _) {
+ if ($WHY) {
+ $why = (-l $file) ? "follow" : "read";
+ warn qq/skip (can't $why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things that are empty
+ unless (-s _ || -d _) {
+ warn qq/skip (empty): $file\n/ if $WHY;
+ next;
+ }
+
+ ## Note file device & inode. If -xdev, skip if appropriate.
+ ($dev, $inode) = (stat(_))[$STAT_DEV, $STAT_INODE];
+ if ($XDEV && defined $xdev{$dev}) {
+ warn qq/skip (other device): $file\n/ if $WHY;
+ next;
+ }
+ $id = "$dev,$inode";
+
+ ## special work for a directory
+ if (-d _) {
+ ## Do checks for directory file endings.
+ if ($DO_DSKIP_TEST && (eval $DSKIP_TEST)) {
+ warn qq/skip (-dskip): $file\n/ if $WHY;
+ next;
+ }
+ ## do checks for -name/-regex/-path tests
+ if ($DO_DGLOB_TESTS && !(eval $DGLOB_TESTS)) {
+ warn qq/skip (dirname): $file\n/ if $WHY;
+ next;
+ }
+
+ ## _never_ redo a directory
+ if (defined $dir_done{$id} and $^O ne 'MSWin32') {
+ warn qq/skip (did as "$dir_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $dir_done{$id} = $file; ## mark it done.
+ unshift(@todo, $file); ## add to the list to do.
+ next;
+ }
+ if ($WHY == 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ ## do time-related tests
+ if ($NEWER || $OLDER) {
+ $_ = (stat(_))[$STAT_MTIME];
+ if ($NEWER && $_ < $NEWER) {
+ warn qq/skip (too old): $file\n/ if $WHY;
+ next;
+ }
+ if ($OLDER && $_ > $OLDER) {
+ warn qq/skip (too new): $file\n/ if $WHY;
+ next;
+ }
+ }
+
+ ## do checks for file endings
+ if ($DO_SKIP_TEST && (eval $SKIP_TEST)) {
+ warn qq/skip (-skip): $file\n/ if $WHY;
+ next;
+ }
+
+ ## do checks for -name/-regex/-path tests
+ if ($DO_GLOB_TESTS && !(eval $GLOB_TESTS)) {
+ warn qq/skip (filename): $file\n/ if $WHY;
+ next;
+ }
+
+
+ ## If we're not repeating files,
+ ## skip this one if we've done it, or note we're doing it.
+ unless ($DOREP) {
+ if (defined $file_done{$id}) {
+ warn qq/skip (did as "$file_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $file_done{$id} = $file;
+ }
+
+ if ($DO_MAGIC_TESTS) {
+ if (!open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ unless (read(FILE_IN, $magic'H, $HEADER_BYTES)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't read from "$file"\n"/;
+ close(FILE_IN);
+ next;
+ }
+
+ eval $MAGIC_TESTS;
+ if ($magic'val) {
+ close(FILE_IN);
+ warn qq/skip (magic): $file\n/ if $WHY;
+ next;
+ }
+ seek(FILE_IN, 0, 0); ## reset for later <FILE_IN>
+ }
+
+ if ($WHY != 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ if ($DELAY) {
+ sleep($DELAY);
+ }
+
+ if ($FIND_ONLY) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+ close(FILE_IN) if $DO_MAGIC_TESTS;
+ next;
+ } else {
+ ## if we weren't doing magic tests, file won't be open yet...
+ if (!$DO_MAGIC_TESTS && !open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ if ($LIST_ONLY && $CAN_USE_FAST_LISTONLY) {
+ ##
+ ## This is rather complex, but buys us a LOT when we're just
+ ## listing files and not the individual internal lines.
+ ##
+ local($size) = 4096; ## block-size in which to do reads
+ local($nl); ## will point to $_'s ending newline.
+ local($read); ## will be how many bytes read.
+ local($_) = ''; ## Starts out empty
+ local($hold); ## (see below)
+
+ while (($read = read(FILE_IN,$_,$size,length($_)))||length($_))
+ {
+ undef @parts;
+ ## if read a full block, but no newline, need to read more.
+ while ($read == $size && ($nl = rindex($_, "\n")) < 0) {
+ push(@parts, $_); ## save that part
+ $read = read(FILE_IN, $_, $size); ## keep trying
+ }
+
+ ##
+ ## If we had to save parts, must now combine them together.
+ ## adjusting $nl to reflect the now-larger $_. This should
+ ## be a lot more efficient than using any kind of .= in the
+ ## loop above.
+ ##
+ if (@parts) {
+ local($lastlen) = length($_); #only need if $nl >= 0
+ $_ = join('', @parts, $_);
+ $nl = length($_) - ($lastlen - $nl) if $nl >= 0;
+ }
+
+ ##
+ ## If we're at the end of the file, then we can use $_ as
+ ## is. Otherwise, we need to remove the final partial-line
+ ## and save it so that it'll be at the beginning of the
+ ## next read (where the rest of the line will be layed in
+ ## right after it). $hold will be what we should save
+ ## until next time.
+ ##
+ if ($read != $size || $nl < 0) {
+ $hold = '';
+ } else {
+ $hold = substr($_, $nl + 1);
+ substr($_, $nl + 1) = '';
+ }
+
+ ##
+ ## Now have a bunch of full lines in $_. Use it.
+ ##
+ if (eval $REGEX_TEST) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+
+ last;
+ }
+
+ ## Prepare for next read....
+ $_ = $hold;
+ }
+
+ } else { ## else not using faster block scanning.....
+
+ $lines_printed = 0 if $NICE;
+ while (<FILE_IN>) {
+ study;
+ next unless (eval $REGEX_TEST);
+
+ ##
+ ## We found a matching line.
+ ##
+ $retval=0;
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ if ($LIST_ONLY) {
+ print $file, "\n";
+ last;
+ } else {
+ ## prepare to print line.
+ if ($NICE && $lines_printed++ == 0) {
+ print '-' x 70, "\n" if $NICE > 1;
+ print $file, ":\n";
+ }
+
+ ##
+ ## Print all the prelim stuff. This looks less efficient
+ ## than it needs to be, but that's so that when the eval
+ ## is compiled (and the tests are optimized away), the
+ ## result will be less actual PRINTs than the more natural
+ ## way of doing these tests....
+ ##
+ if ($NICE) {
+ if ($REPORT_LINENUM) {
+ print " line $.: ";
+ } else {
+ print " ";
+ }
+ } elsif ($REPORT_LINENUM && $PREPEND_FILENAME) {
+ print "$file,:$.: ";
+ } elsif ($PREPEND_FILENAME) {
+ print "$file: ";
+ } elsif ($REPORT_LINENUM) {
+ print "$.: ";
+ }
+ print $_;
+ print "\n" unless m/\n$/;
+ }
+ }
+ print "\n" if ($NICE > 1) && $lines_printed;
+ }
+ close(FILE_IN);
+ }
+ }
+ closedir(DIR);
+}
+
+__END__
+.00; ## finish .ig
+
+'di \" finish diversion--previous line must be blank
+.nr nl 0-1 \" fake up transition to first page again
+.nr % 0 \" start at page 1
+.\"__________________NORMAL_MAN_PAGE_BELOW_________________
+.ll+10n
+.TH search 1 "Dec 17, 1994"
+.SH SEARCH
+search \- search files (a'la grep) in a whole directory tree.
+.SH SYNOPSIS
+search [ grep-like and find-like options] [regex ....]
+.SH DESCRIPTION
+.I Search
+is more or less a combo of 'find' and 'grep' (although the regular
+expression flavor is that of the perl being used, which is closer to
+egrep's than grep's).
+
+.I Search
+does generally the same kind of thing that
+.nf
+ find <blah blah> | xargs egrep <blah blah>
+.fi
+does, but is
+.I much
+more powerful and efficient (and intuitive, I think).
+
+This manual describes
+.I search
+as of version "941227.4". You can always find the latest version at
+.nf
+ http://www.wg.omron.co.jp/~jfriedl/perl/index.html
+.fi
+
+.SH "QUICK EXAMPLE"
+Basic use is simple:
+.nf
+ % search jeff
+.fi
+will search files in the current directory, and all sub directories, for
+files that have "jeff" in them. The lines will be listed with the
+containing file's name prepended.
+.PP
+If you list more than one regex, such as with
+.nf
+ % search jeff Larry Randal+ 'Stoc?k' 'C.*son'
+.fi
+then a line containing any of the regexes will be listed.
+This makes it effectively the same as
+.nf
+ % search 'jeff|Larry|Randal+|Stoc?k|C.*son'
+.fi
+However, listing them separately is much more efficient (and is easier
+to type).
+.PP
+Note that in the case of these examples, the
+.B \-w
+(list whole-words only) option would be useful.
+.PP
+Normally, various kinds of files are automatically removed from consideration.
+If it has has a certain ending (such as ".tar", ".Z", ".o", .etc), or if
+the beginning of the file looks like a binary, it'll be excluded.
+You can control exactly how this works -- see below. One quick way to
+override this is to use the
+.B \-all
+option, which means to consider all the files that would normally be
+automatically excluded.
+Or, if you're curious, you can use
+.B \-why
+to have notes about what files are skipped (and why) printed to stderr.
+
+.SH "BASIC OVERVIEW"
+Normally, the search starts in the current directory, considering files in
+all subdirectories.
+
+You can use the
+.I ~/.search
+file to control ways to automatically exclude files.
+If you don't have this file, a default one will kick in, which automatically
+add
+.nf
+ -skip .o .Z .gif
+.fi
+(among others) to exclude those kinds of files (which you probably want to
+skip when searching for text, as is normal).
+Files that look to be be binary will also be excluded.
+
+Files ending with "#" and "~" will also be excluded unless the
+.B -x~
+option is given.
+
+You can use
+.B -showrc
+to show what kinds of files will normally be skipped.
+See the section on the startup file
+for more info.
+
+You can use the
+.B -all
+option to indicate you want to consider all files that would otherwise be
+skipped by the startup file.
+
+Based upon various other flags (see "WHICH FILES TO CONSIDER" below),
+more files might be removed from consideration. For example
+.nf
+ -mtime 3
+.fi
+will exclude files that aren't at least three days old (change the 3 to -3
+to exclude files that are more than three days old), while
+.nf
+ -skip .*
+.fi
+would exclude any file beginning with a dot (of course, '.' and '..' are
+special and always excluded).
+
+If you'd like to see what files are being excluded, and why, you can get the
+list via the
+.B \-why
+option.
+
+If a file makes it past all the checks, it is then "considered".
+This usually means it is greped for the regular expressions you gave
+on the command line.
+
+If any of the regexes match a line, the line is printed.
+However, if
+.B -list
+is given, just the filename is printed. Or, if
+.B -nice
+is given, a somewhat more (human-)readable output is generated.
+
+If you're searching a huge tree and want to keep informed about how
+the search is progressing,
+.B -v
+will print (to stderr) the current directory being searched.
+Using
+.B -vv
+will also print the current file "every so often", which could be useful
+if a directory is huge. Using
+.B -vvv
+will print the update with every file.
+
+Below is the full listing of options.
+
+.SH "OPTIONS TELLING *WHERE* TO SEARCH"
+.TP
+.BI -dir " DIR"
+Start searching at the named directory instead of the current directory.
+If multiple
+.B -dir
+arguments are given, multiple trees will be searched.
+.TP
+.BI -ddir " DIR"
+Like
+.B -dir
+except it flushes any previous
+.B -dir
+directories (i.e. "-dir A -dir B -dir C" will search A, B, and C, while
+"-dir A -ddir B -dir C" will search only B and C. This might be of use
+in the startup file (see that section below).
+.TP
+.B -xdev
+Stay on the same filesystem as the starting directory/directories.
+.TP
+.B -sort
+Sort the items in a directory before processing them.
+Normally they are processed in whatever order they happen to be read from
+the directory.
+.TP
+.B -nolinks
+Don't follow symbolic links. Normally they're followed.
+
+.SH "OPTIONS CONTROLLING WHICH FILES TO CONSIDER AND EXCLUDE"
+.TP
+.BI -mtime " NUM"
+Only consider files that were last changed more than
+.I NUM
+days ago
+(less than
+.I NUM
+days if
+.I NUM
+has '-' prepended, i.e. "-mtime -2.5" means to consider files that
+have been changed in the last two and a half days).
+.TP
+.B -older FILE
+Only consider files that have not changed since
+.I FILE
+was last changed.
+If there is any upper case in the "-older", "or equal" is added to the sense
+of the test. Therefore, "search -older ./file regex" will never consider
+"./file", while "search -Older ./file regex" will.
+
+If a file is a symbolic link, the time used is that of the file and not the
+link.
+.TP
+.BI -newer " FILE"
+Opposite of
+.BR -older .
+.TP
+.BI -name " GLOB"
+Only consider files that match the shell filename pattern
+.IR GLOB .
+The check is only done on a file's name (use
+.B -path
+to check the whole path, and use
+.B -dname
+to check directory names).
+
+Multiple specifications can be given by separating them with spaces, a'la
+.nf
+ -name '*.c *.h'
+.fi
+to consider C source and header files.
+If
+.I GLOB
+doesn't contain any special pattern characters, a '*' is prepended.
+This last example could have been given as
+.nf
+ -name '.c .h'
+.fi
+It could also be given as
+.nf
+ -name .c -name .h
+.fi
+or
+.nf
+ -name '*.c' -name '*.h'
+.fi
+or
+.nf
+ -name '*.[ch]'
+.fi
+(among others)
+but in this last case, you have to be sure to supply the leading '*'.
+.TP
+.BI -path " GLOB"
+Like
+.B -name
+except the entire path is checked against the pattern.
+.TP
+.B -regex " REGEX"
+Considers files whose names (not paths) match the given perl regex
+exactly.
+.TP
+.BI -iname " GLOB"
+Case-insensitive version of
+.BR -name .
+.TP
+.BI -ipath " GLOB"
+Case-insensitive version of
+.BR -path .
+.TP
+.BI -iregex " REGEX"
+Case-insensitive version of
+.BR -regex .
+
+.TP
+.BI -dpath " GLOB"
+Only search down directories whose path matches the given pattern (this
+doesn't apply to the initial directory given by
+.BI -dir ,
+of course).
+Something like
+.nf
+ -dir /usr/man -dpath /usr/man/man*
+.fi
+would completely skip
+"/usr/man/cat1", "/usr/man/cat2", etc.
+.TP
+.BI -dskip " GLOB"
+Skips directories whose name (not path) matches the given pattern.
+Something like
+.nf
+ -dir /usr/man -dskip cat*
+.fi
+would completely skip any directory in the tree whose name begins with "cat"
+(including "/usr/man/cat1", "/usr/man/cat2", etc.).
+.TP
+.BI -dregex " REGEX"
+Like
+.BI -dpath ,
+but the pattern is a full perl regex. Note that this quite different
+from
+.B -regex
+which considers only file names (not paths). This option considers
+full directory paths (not just names). It's much more useful this way.
+Sorry if it's confusing.
+.TP
+.BI -dpath " GLOB"
+This option exists, but is probably not very useful. It probably wants to
+be like the '-below' or something I mention in the "TODO" section.
+.TP
+.BI -idpath " GLOB"
+Case-insensitive version of
+.BR -dpath .
+.TP
+.BI -idskip " GLOB"
+Case-insensitive version of
+.BR -dskip .
+.TP
+.BI -idregex " REGEX"
+Case-insensitive version of
+.BR -dregex .
+.TP
+.B -all
+Ignore any 'magic' or 'option' lines in the startup file.
+The effect is that all files that would otherwise be automatically
+excluded are considered.
+.TP
+.BI -x SPECIAL
+Arguments starting with
+.B -x
+(except
+.BR -xdev ,
+explained elsewhere) do special interaction with the
+.I ~/.search
+startup file. Something like
+.nf
+ -xflag1 -xflag2
+.fi
+will turn on "flag1" and "flag2" in the startup file (and is
+the same as "-xflag1,flag2"). You can use this to write your own
+rules for what kinds of files are to be considered.
+
+For example, the internal-default startup file contains the line
+.nf
+ <!~> option: -skip '~ #'
+.fi
+This means that if the
+.B -x~
+flag is
+.I not
+seen, the option
+.nf
+ -skip '~ #'
+.fi
+should be done.
+The effect is that emacs temp and backup files are not normally
+considered, but you can included them with the -x~ flag.
+
+You can write your own rules to customize
+.I search
+in powerful ways. See the STARTUP FILE section below.
+.TP
+.B -why
+Print a message (to stderr) when and why a file is not considered.
+
+.SH "OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED"
+.TP
+.B -find
+(you can use
+.B -f
+as well).
+This option changes the basic action of
+.IR search .
+
+Normally, if a file is considered, it is searched
+for the regular expressions as described earlier. However, if this option
+is given, the filename is printed and no searching takes place. This turns
+.I search
+into a 'find' of some sorts.
+
+In this case, no regular expressions are needed on the command line
+(any that are there are silently ignored).
+
+This is not intended to be a replacement for the 'find' program,
+but to aid
+you in understanding just what files are getting past the exclusion checks.
+If you really want to use it as a sort of replacement for the 'find' program,
+you might want to use
+.B -all
+so that it doesn't waste time checking to see if the file is binary, etc
+(unless you really want that, of course).
+
+If you use
+.BR -find ,
+none of the "GREP-LIKE OPTIONS" (below) matter.
+
+As a replacement for 'find',
+.I search
+is probably a bit slower (or in the case of GNU find, a lot slower --
+GNU find is
+.I unbelievably
+fast).
+However, "search -ffind"
+might be more useful than 'find' when options such as
+.B -skip
+are used (at least until 'find' gets such functionality).
+.TP
+.B -ffind
+(or
+.BR -ff )
+A faster more 'find'-like find. Does
+.nf
+ -find -all -dorep
+.fi
+.SH "GREP-LIKE OPTIONS"
+These options control how a searched file is accessed,
+and how things are printed.
+.TP
+.B -i
+Ignore letter case when matching.
+.TP
+.B -w
+Consider only whole-word matches ("whole word" as defined by perl's "\\b"
+regex).
+.TP
+.B -u
+If the regex(es) is/are simple, try to modify them so that they'll work
+in manpage-like underlined text (i.e. like _^Ht_^Hh_^Hi_^Hs).
+This is very rudimentary at the moment.
+.TP
+.B -list
+(you can use
+.B -l
+too).
+Don't print matching lines, but the names of files that contain matching
+lines. This will likely be *much* faster, as special optimizations are
+made -- particularly with large files.
+.TP
+.B -n
+Pepfix each line by its line number.
+.TP
+.B -nice
+Not a grep-like option, but similar to
+.BR -list ,
+so included here.
+.B -nice
+will have the output be a bit more human-readable, with matching lines printed
+slightly indented after the filename, a'la
+.nf
+
+ % search foo
+ somedir/somefile: line with foo in it
+ somedir/somefile: some food for thought
+ anotherdir/x: don't be a buffoon!
+ %
+
+.fi
+will become
+.nf
+
+ % search -nice foo
+ somedir/somefile:
+ line with foo in it
+ some food for thought
+ anotherdir/x:
+ don't be a buffoon!
+ %
+
+.fi
+This option due to Lionel Cons.
+.TP
+.B -nnice
+Be a bit nicer than
+.BR -nice .
+Prefix each file's output by a rule line, and follow with an extra blank line.
+.TP
+.B -h
+Don't prepend each output line with the name of the file
+(meaningless when
+.B -find
+or
+.B -l
+are given).
+
+.SH "OTHER OPTIONS"
+.TP
+.B -help
+Print the usage information.
+.TP
+.B -version
+Print the version information and quit.
+.TP
+.B -v
+Set the level of message verbosity.
+.B -v
+will print a note whenever a new directory is entered.
+.B -vv
+will also print a note "every so often". This can be useful to see
+what's happening when searching huge directories.
+.B -vvv
+will print a new with every file.
+.B -vvvv
+is
+-vvv
+plus
+.BR -why .
+.TP
+.B -e
+This ends the options, and can be useful if the regex begins with '-'.
+.TP
+.B -showrc
+Shows what is being considered in the startup file, then exits.
+.TP
+.B -dorep
+Normally, an identical file won't be checked twice (even with multiple
+hard or symbolic links). If you're just trying to do a fast
+.BR -find ,
+the bookkeeping to remember which files have been seen is not desirable,
+so you can eliminate the bookkeeping with this flag.
+
+.SH "STARTUP FILE"
+When
+.I search
+starts up, it processes the directives in
+.IR ~/.search .
+If no such file exists, a default
+internal version is used.
+
+The internal version looks like:
+.nf
+
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+ option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
+ option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+
+.fi
+If you wish to create your own "~/.search",
+you might consider copying the above, and then working from there.
+
+There are two kinds of directives in a startup file: "magic" and "option".
+.RS 0n
+.TP
+OPTION
+Option lines will automatically do the command-line options given.
+For example, the line
+.nf
+ option: -v
+.fi
+in you startup file will turn on -v every time, without needing to type it
+on the command line.
+
+The text on the line after the "option:" directive is processed
+like the Bourne shell, so make sure to pay attention to quoting.
+.nf
+ option: -skip .exe .com
+.fi
+will give an error (".com" by itself isn't a valid option), while
+.nf
+ option: -skip ".exe .com"
+.fi
+will properly include it as part of -skip's argument.
+
+.TP
+MAGIC
+Magic lines are used to determine if a file should be considered a binary
+or not (the term "magic" refers to checking a file's magic number). These
+are described in more detail below.
+.RE
+
+Blank lines and comments (lines beginning with '#') are allowed.
+
+If a line begins with <...>, then it's a check to see if the
+directive on the line should be done or not. The stuff inside the <...>
+can contain perl's && (and), || (or), ! (not), and parens for grouping,
+along with "flags" that might be indicated by the user with
+.BI -x flag
+options.
+
+For example, using "-xfoo" will cause "foo" to be true inside the <...>
+blocks. Therefore, a line beginning with "<foo>" would be done only when
+"-xfoo" had been specified, while a line beginning with "<!foo>" would be
+done only when "-xfoo" is not specified (of course, a line without any <...>
+is done in either case).
+
+A realistic example might be
+.nf
+ <!v> -vv
+.fi
+This will cause -vv messages to be the default, but allow "-xv" to override.
+
+There are a few flags that are set automatically:
+.RS
+.TP
+.B TTY
+true if the output is to the screen (as opposed to being redirected to a file).
+You can force this (as with all the other automatic flags) with -xTTY.
+.TP
+.B -v
+True if -v was specified. If -vv was specified, both
+.B -v
+and
+.B -vv
+flags are true (and so on).
+.TP
+.B -nice
+True if -nice was specified. Same thing about -nnice as for -vv.
+.PP
+.TP
+.B -list
+true if -list (or -l) was given.
+.TP
+.B -dir
+true if -dir was given.
+.RE
+
+Using this info, you might change the last example to
+.nf
+
+ <!v && !-v> option: -vv
+
+.fi
+The added "&& !-v" means "and if the '-v' option not given".
+This will allow you to use "-v" alone on the command line, and not
+have this directive add the more verbose "-vv" automatically.
+
+.RS 0
+Some other examples:
+.TP
+<!-dir && !here> option: -dir ~/
+Effectively make the default directory your home directory (instead of the
+current directory). Using -dir or -xhere will undo this.
+.TP
+<tex> option: -name .tex -dir ~/pub
+Create '-xtex' to search only "*.tex" files in your ~/pub directory tree.
+Actually, this could be made a bit better. If you combine '-xtex' and '-dir'
+on the command line, this directive will add ~/pub to the list, when you
+probably want to use the -dir directory only. You could do
+.nf
+
+ <tex> option: -name .tex
+ <tex && !-dir> option: -dir ~/pub
+.fi
+
+to will allow '-xtex' to work as before, but allow a command-line "-dir"
+to take precedence with respect to ~/pub.
+.TP
+<fluff> option: -nnice -sort -i -vvv
+Combine a few user-friendly options into one '-xfluff' option.
+.TP
+<man> option: -ddir /usr/man -v -w
+When the '-xman' option is given, search "/usr/man" for whole-words
+(of whatever regex or regexes are given on the command line), with -v.
+.RE
+
+The lines in the startup file are executed from top to bottom, so something
+like
+.nf
+
+ <both> option: -xflag1 -xflag2
+ <flag1> option: ...whatever...
+ <flag2> option: ...whatever...
+
+.fi
+will allow '-xboth' to be the same as '-xflag1 -xflag2' (or '-xflag1,flag2'
+for that matter). However, if you put the "<both>" line below the others,
+they will not be true when encountered, so the result would be different
+(and probably undesired).
+
+The "magic" directives are used to determine if a file looks to be binary
+or not. The form of a magic line is
+.nf
+ magic: \fISIZE\fP : \fIPERLCODE\fP
+.fi
+where
+.I SIZE
+is the number of bytes of the file you need to check, and
+.I PERLCODE
+is the code to do the check. Within
+.IR PERLCODE ,
+the variable $H will hold at least the first
+.I SIZE
+bytes of the file (unless the file is shorter than that, of course).
+It might hold more bytes. The perl should evaluate to true if the file
+should be considered a binary.
+
+An example might be
+.nf
+ magic: 6 : substr($H, 0, 6) eq 'GIF87a'
+.fi
+to test for a GIF ("-iskip .gif" is better, but this might be useful
+if you have images in files without the ".gif" extension).
+
+Since the startup file is checked from top to bottom, you can be a bit
+efficient:
+.nf
+ magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+ magic: 6 : $x6 eq 'GIF89a'
+.fi
+You could also write the same thing as
+.nf
+ magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a') || ## an old gif, or.. \e
+ $x6 eq 'GIF89a' ## .. a new one.
+.fi
+since newlines may be escaped.
+
+The default internal startup file includes
+.nf
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+.fi
+which checks for certain non-printable characters, and catches a large
+number of binary files, including most system's executables, linkable
+objects, compressed, tarred, and otherwise folded, spindled, and mutilated
+files.
+
+Another example might be
+.nf
+ ## an archive library
+ magic: 17 : substr($H, 0, 17) eq "!<arch>\en__.SYMDEF"
+.fi
+
+.SH "RETURN VALUE"
+.I Search
+returns zero if lines (or files, if appropriate) were found,
+or if no work was requested (such as with
+.BR -help ).
+Returns 1 if no lines (or files) were found.
+Returns 2 on error.
+
+.SH TODO
+Things I'd like to add some day:
+.nf
+ + show surrounding lines (context).
+ + highlight matched portions of lines.
+ + add '-and', which can go between regexes to override
+ the default logical or of the regexes.
+ + add something like
+ -below GLOB
+ which will examine a tree and only consider files that
+ lie in a directory deeper than one named by the pattern.
+ + add 'warning' and 'error' directives.
+ + add 'help' directive.
+.fi
+.SH BUGS
+If -xdev and multiple -dir arguments are given, any file in any of the
+target filesystems are allowed. It would be better to allow each filesystem
+for each separate tree.
+
+Multiple -dir args might also cause some confusing effects. Doing
+.nf
+ -dir some/dir -dir other
+.fi
+will search "some/dir" completely, then search "other" completely. This
+is good. However, something like
+.nf
+ -dir some/dir -dir some/dir/more/specific
+.fi
+will search "some/dir" completely *except for* "some/dir/more/specific",
+after which it will return and be searched. Not really a bug, but just sort
+of odd.
+
+File times (for -newer, etc.) of symbolic links are for the file, not the
+link. This could cause some misunderstandings.
+
+Probably more. Please let me know.
+.SH AUTHOR
+Jeffrey Friedl, Omron Corp (jfriedl@omron.co.jp)
+.br
+http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html
+
+.SH "LATEST SOURCE"
+See http://www.wg.omron.co.jp/~jfriedl/perl/index.html
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/shasum b/Master/tlpkg/tlperl.straw/bin/shasum
new file mode 100755
index 00000000000..3c0185892fa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/shasum
@@ -0,0 +1,268 @@
+#!perl -w
+
+ # shasum: filter for computing SHA digests (analogous to sha1sum)
+ #
+ # Copyright (C) 2003-2010 Mark Shelor, All Rights Reserved
+ #
+ # Version: 5.48
+ # Mon Jan 4 16:32:52 MST 2010
+
+=head1 NAME
+
+shasum - Print or Check SHA Checksums
+
+=head1 SYNOPSIS
+
+ Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
+ Print or check SHA checksums.
+ With no FILE, or when FILE is -, read standard input.
+
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
+ produces same digest on Windows/Unix/Mac
+ -t, --text read files in text mode (default)
+
+ The following two options are useful only when verifying checksums:
+
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
+
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+
+ The sums are computed as described in FIPS PUB 180-2. When checking,
+ the input should be a former output of this program. The default mode
+ is to print a line with checksum, a character indicating type (`*'
+ for binary, `?' for portable, ` ' for text), and name for each FILE.
+
+=head1 DESCRIPTION
+
+The I<shasum> script provides the easiest and most convenient way to
+compute SHA message digests. Rather than writing a program, the user
+simply feeds data to the script via the command line, and waits for
+the results to be printed on standard output. Data can be fed to
+I<shasum> through files, standard input, or both.
+
+The following command shows how easy it is to compute digests for typical
+inputs such as the NIST test vector "abc":
+
+ perl -e "print qq(abc)" | shasum
+
+Or, if you want to use SHA-256 instead of the default SHA-1, simply say:
+
+ perl -e "print qq(abc)" | shasum -a 256
+
+Since I<shasum> uses the same interface employed by the familiar
+I<sha1sum> program (and its somewhat outmoded anscestor I<md5sum>),
+you can install this script as a convenient drop-in replacement.
+
+=head1 AUTHOR
+
+Copyright (c) 2003-2010 Mark Shelor <mshelor@cpan.org>.
+
+=head1 SEE ALSO
+
+shasum is implemented using the Perl module L<Digest::SHA> or
+L<Digest::SHA::PurePerl>.
+
+=cut
+
+use strict;
+use FileHandle;
+use Getopt::Long;
+
+my $VERSION = "5.48";
+
+
+ # Try to use Digest::SHA, since it's faster. If not installed,
+ # use Digest::SHA::PurePerl instead.
+
+my $MOD_PREFER = "Digest::SHA";
+my $MOD_SECOND = "Digest::SHA::PurePerl";
+
+my $module = $MOD_PREFER;
+eval "require $module";
+if ($@) {
+ $module = $MOD_SECOND;
+ eval "require $module";
+ die "Unable to find $MOD_PREFER or $MOD_SECOND\n" if $@;
+}
+
+
+ # Usage statement adapted from Ulrich Drepper's md5sum.
+ # Include an "-a" option for algorithm selection,
+ # and a "-p" option for portable digest computation.
+
+sub usage {
+ my($err, $msg) = @_;
+
+ $msg = "" unless defined $msg;
+ if ($err) {
+ warn($msg . "Type shasum -h for help\n");
+ exit($err);
+ }
+ print <<'END_OF_USAGE';
+Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
+Print or check SHA checksums.
+With no FILE, or when FILE is -, read standard input.
+
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
+ produces same digest on Windows/Unix/Mac
+ -t, --text read files in text mode (default)
+
+The following two options are useful only when verifying checksums:
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
+
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+
+The sums are computed as described in FIPS PUB 180-2. When checking, the
+input should be a former output of this program. The default mode is to
+print a line with checksum, a character indicating type (`*' for binary,
+`?' for portable, ` ' for text), and name for each FILE.
+
+Report bugs to <mshelor@cpan.org>.
+END_OF_USAGE
+ exit($err);
+}
+
+
+ # Collect options from command line
+
+my ($alg, $binary, $check, $text, $status, $warn, $help, $version);
+my ($portable);
+
+eval { Getopt::Long::Configure ("bundling") };
+GetOptions(
+ 'b|binary' => \$binary, 'c|check' => \$check,
+ 't|text' => \$text, 'a|algorithm=i' => \$alg,
+ 's|status' => \$status, 'w|warn' => \$warn,
+ 'h|help' => \$help, 'v|version' => \$version,
+ 'p|portable' => \$portable
+) or usage(1, "");
+
+
+ # Deal with help requests and incorrect uses
+
+usage(0)
+ if $help;
+usage(1, "shasum: Ambiguous file mode\n")
+ if scalar(grep { defined $_ } ($binary, $portable, $text)) > 1;
+usage(1, "shasum: --warn option used only when verifying checksums\n")
+ if $warn && !$check;
+usage(1, "shasum: --status option used only when verifying checksums\n")
+ if $status && !$check;
+
+
+ # Default to SHA-1 unless overriden by command line option
+
+$alg = 1 unless defined $alg;
+grep { $_ == $alg } (1, 224, 256, 384, 512)
+ or usage(1, "shasum: Unrecognized algorithm\n");
+
+
+ # Display version information if requested
+
+if ($version) {
+ print "$VERSION\n";
+ exit(0);
+}
+
+
+ # Try to figure out if the OS is DOS-like. If it is,
+ # default to binary mode when reading files, unless
+ # explicitly overriden by command line "--text" or
+ # "--portable" options.
+
+my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin)$/);
+if ($isDOSish) { $binary = 1 unless $text || $portable }
+
+my $modesym = $binary ? '*' : ($portable ? '?' : ' ');
+
+
+ # Read from STDIN (-) if no files listed on command line
+
+@ARGV = ("-") unless @ARGV;
+
+
+ # sumfile($file): computes SHA digest of $file
+
+sub sumfile {
+ my $file = shift;
+
+ my $mode = $portable ? 'p' : ($binary ? 'b' : '');
+ my $digest = eval { $module->new($alg)->addfile($file, $mode) };
+ if ($@) {
+ warn "shasum: $file: $!\n";
+ return;
+ }
+
+ $digest->hexdigest;
+}
+
+
+ # %len2alg: maps hex digest length to SHA algorithm
+
+my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512);
+
+
+ # Verify checksums if requested
+
+if ($check) {
+ my $checkfile = shift(@ARGV);
+ my ($err, $read_errs, $match_errs) = (0, 0, 0);
+ my ($num_files, $num_checksums) = (0, 0);
+ my ($fh, $sum, $fname, $rsp, $digest);
+
+ die "shasum: $checkfile: $!\n"
+ unless $fh = FileHandle->new($checkfile, "r");
+ while (<$fh>) {
+ s/\s+$//;
+ ($sum, $modesym, $fname) = /^(\S+) (.)(.*)$/;
+ ($binary, $portable, $text) =
+ map { $_ eq $modesym } ('*', '?', ' ');
+ unless ($alg = $len2alg{length($sum)}) {
+ warn("shasum: $checkfile: $.: improperly " .
+ "formatted SHA checksum line\n") if $warn;
+ next;
+ }
+ $rsp = "$fname: "; $num_files++;
+ unless ($digest = sumfile($fname)) {
+ $rsp .= "FAILED open or read\n";
+ $err = 1; $read_errs++;
+ }
+ else {
+ $num_checksums++;
+ if (lc($sum) eq $digest) { $rsp .= "OK\n" }
+ else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
+ }
+ print $rsp unless $status;
+ }
+ $fh->close;
+ unless ($status) {
+ warn("shasum: WARNING: $read_errs of $num_files listed " .
+ "files could not be read\n") if $read_errs;
+ warn("shasum: WARNING: $match_errs of $num_checksums " .
+ "computed checksums did NOT match\n") if $match_errs;
+ }
+ exit($err);
+}
+
+
+ # Compute and display SHA checksums of requested files
+
+my($file, $digest);
+
+for $file (@ARGV) {
+ if ($digest = sumfile($file)) {
+ print "$digest $modesym", "$file\n";
+ }
+}
diff --git a/Master/tlpkg/tlperl.straw/bin/shasum.bat b/Master/tlpkg/tlperl.straw/bin/shasum.bat
new file mode 100755
index 00000000000..79baeebc5b9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/shasum.bat
@@ -0,0 +1,284 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+
+ # shasum: filter for computing SHA digests (analogous to sha1sum)
+ #
+ # Copyright (C) 2003-2010 Mark Shelor, All Rights Reserved
+ #
+ # Version: 5.48
+ # Mon Jan 4 16:32:52 MST 2010
+
+=head1 NAME
+
+shasum - Print or Check SHA Checksums
+
+=head1 SYNOPSIS
+
+ Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
+ Print or check SHA checksums.
+ With no FILE, or when FILE is -, read standard input.
+
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
+ produces same digest on Windows/Unix/Mac
+ -t, --text read files in text mode (default)
+
+ The following two options are useful only when verifying checksums:
+
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
+
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+
+ The sums are computed as described in FIPS PUB 180-2. When checking,
+ the input should be a former output of this program. The default mode
+ is to print a line with checksum, a character indicating type (`*'
+ for binary, `?' for portable, ` ' for text), and name for each FILE.
+
+=head1 DESCRIPTION
+
+The I<shasum> script provides the easiest and most convenient way to
+compute SHA message digests. Rather than writing a program, the user
+simply feeds data to the script via the command line, and waits for
+the results to be printed on standard output. Data can be fed to
+I<shasum> through files, standard input, or both.
+
+The following command shows how easy it is to compute digests for typical
+inputs such as the NIST test vector "abc":
+
+ perl -e "print qq(abc)" | shasum
+
+Or, if you want to use SHA-256 instead of the default SHA-1, simply say:
+
+ perl -e "print qq(abc)" | shasum -a 256
+
+Since I<shasum> uses the same interface employed by the familiar
+I<sha1sum> program (and its somewhat outmoded anscestor I<md5sum>),
+you can install this script as a convenient drop-in replacement.
+
+=head1 AUTHOR
+
+Copyright (c) 2003-2010 Mark Shelor <mshelor@cpan.org>.
+
+=head1 SEE ALSO
+
+shasum is implemented using the Perl module L<Digest::SHA> or
+L<Digest::SHA::PurePerl>.
+
+=cut
+
+use strict;
+use FileHandle;
+use Getopt::Long;
+
+my $VERSION = "5.48";
+
+
+ # Try to use Digest::SHA, since it's faster. If not installed,
+ # use Digest::SHA::PurePerl instead.
+
+my $MOD_PREFER = "Digest::SHA";
+my $MOD_SECOND = "Digest::SHA::PurePerl";
+
+my $module = $MOD_PREFER;
+eval "require $module";
+if ($@) {
+ $module = $MOD_SECOND;
+ eval "require $module";
+ die "Unable to find $MOD_PREFER or $MOD_SECOND\n" if $@;
+}
+
+
+ # Usage statement adapted from Ulrich Drepper's md5sum.
+ # Include an "-a" option for algorithm selection,
+ # and a "-p" option for portable digest computation.
+
+sub usage {
+ my($err, $msg) = @_;
+
+ $msg = "" unless defined $msg;
+ if ($err) {
+ warn($msg . "Type shasum -h for help\n");
+ exit($err);
+ }
+ print <<'END_OF_USAGE';
+Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
+Print or check SHA checksums.
+With no FILE, or when FILE is -, read standard input.
+
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
+ produces same digest on Windows/Unix/Mac
+ -t, --text read files in text mode (default)
+
+The following two options are useful only when verifying checksums:
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
+
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+
+The sums are computed as described in FIPS PUB 180-2. When checking, the
+input should be a former output of this program. The default mode is to
+print a line with checksum, a character indicating type (`*' for binary,
+`?' for portable, ` ' for text), and name for each FILE.
+
+Report bugs to <mshelor@cpan.org>.
+END_OF_USAGE
+ exit($err);
+}
+
+
+ # Collect options from command line
+
+my ($alg, $binary, $check, $text, $status, $warn, $help, $version);
+my ($portable);
+
+eval { Getopt::Long::Configure ("bundling") };
+GetOptions(
+ 'b|binary' => \$binary, 'c|check' => \$check,
+ 't|text' => \$text, 'a|algorithm=i' => \$alg,
+ 's|status' => \$status, 'w|warn' => \$warn,
+ 'h|help' => \$help, 'v|version' => \$version,
+ 'p|portable' => \$portable
+) or usage(1, "");
+
+
+ # Deal with help requests and incorrect uses
+
+usage(0)
+ if $help;
+usage(1, "shasum: Ambiguous file mode\n")
+ if scalar(grep { defined $_ } ($binary, $portable, $text)) > 1;
+usage(1, "shasum: --warn option used only when verifying checksums\n")
+ if $warn && !$check;
+usage(1, "shasum: --status option used only when verifying checksums\n")
+ if $status && !$check;
+
+
+ # Default to SHA-1 unless overriden by command line option
+
+$alg = 1 unless defined $alg;
+grep { $_ == $alg } (1, 224, 256, 384, 512)
+ or usage(1, "shasum: Unrecognized algorithm\n");
+
+
+ # Display version information if requested
+
+if ($version) {
+ print "$VERSION\n";
+ exit(0);
+}
+
+
+ # Try to figure out if the OS is DOS-like. If it is,
+ # default to binary mode when reading files, unless
+ # explicitly overriden by command line "--text" or
+ # "--portable" options.
+
+my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin)$/);
+if ($isDOSish) { $binary = 1 unless $text || $portable }
+
+my $modesym = $binary ? '*' : ($portable ? '?' : ' ');
+
+
+ # Read from STDIN (-) if no files listed on command line
+
+@ARGV = ("-") unless @ARGV;
+
+
+ # sumfile($file): computes SHA digest of $file
+
+sub sumfile {
+ my $file = shift;
+
+ my $mode = $portable ? 'p' : ($binary ? 'b' : '');
+ my $digest = eval { $module->new($alg)->addfile($file, $mode) };
+ if ($@) {
+ warn "shasum: $file: $!\n";
+ return;
+ }
+
+ $digest->hexdigest;
+}
+
+
+ # %len2alg: maps hex digest length to SHA algorithm
+
+my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512);
+
+
+ # Verify checksums if requested
+
+if ($check) {
+ my $checkfile = shift(@ARGV);
+ my ($err, $read_errs, $match_errs) = (0, 0, 0);
+ my ($num_files, $num_checksums) = (0, 0);
+ my ($fh, $sum, $fname, $rsp, $digest);
+
+ die "shasum: $checkfile: $!\n"
+ unless $fh = FileHandle->new($checkfile, "r");
+ while (<$fh>) {
+ s/\s+$//;
+ ($sum, $modesym, $fname) = /^(\S+) (.)(.*)$/;
+ ($binary, $portable, $text) =
+ map { $_ eq $modesym } ('*', '?', ' ');
+ unless ($alg = $len2alg{length($sum)}) {
+ warn("shasum: $checkfile: $.: improperly " .
+ "formatted SHA checksum line\n") if $warn;
+ next;
+ }
+ $rsp = "$fname: "; $num_files++;
+ unless ($digest = sumfile($fname)) {
+ $rsp .= "FAILED open or read\n";
+ $err = 1; $read_errs++;
+ }
+ else {
+ $num_checksums++;
+ if (lc($sum) eq $digest) { $rsp .= "OK\n" }
+ else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
+ }
+ print $rsp unless $status;
+ }
+ $fh->close;
+ unless ($status) {
+ warn("shasum: WARNING: $read_errs of $num_files listed " .
+ "files could not be read\n") if $read_errs;
+ warn("shasum: WARNING: $match_errs of $num_checksums " .
+ "computed checksums did NOT match\n") if $match_errs;
+ }
+ exit($err);
+}
+
+
+ # Compute and display SHA checksums of requested files
+
+my($file, $digest);
+
+for $file (@ARGV) {
+ if ($digest = sumfile($file)) {
+ print "$digest $modesym", "$file\n";
+ }
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/splain.bat b/Master/tlpkg/tlperl.straw/bin/splain.bat
new file mode 100755
index 00000000000..389ef1879a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/splain.bat
@@ -0,0 +1,665 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+=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.17;
+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 $_;
+
+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+)?s)/, $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] eq '%s' ){
+ $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
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/tkjpeg b/Master/tlpkg/tlperl.straw/bin/tkjpeg
new file mode 100755
index 00000000000..b2b5619726c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/tkjpeg
@@ -0,0 +1,67 @@
+#!/usr/local/bin/perl -w
+use strict;
+use Tk;
+use Tk::JPEG;
+use Getopt::Std;
+eval { require Tk::PNG; };
+
+my $mw = MainWindow->new();
+print "vis=",$mw->visual," d=",$mw->depth,"\n";
+my ($vis) = grep(!/\b8\b/,grep(/truecolor/,$mw->visualsavailable));
+my @args = ();
+if ($vis)
+ {
+ # print $vis,"\n";
+ $mw->destroy;
+ $mw = MainWindow->new(-visual => $vis);
+ }
+else
+ {
+ @args = (-palette => '4/4/4');
+ }
+# print "vis=",$mw->visual," d=",$mw->depth,' "',join('" "',$mw->visualsavailable),"\"\n";
+my %opt;
+getopts('f:',\%opt);
+if ($opt{'f'})
+ {
+ push(@args,'-format' => $opt{'f'});
+ }
+unless (@ARGV)
+ {
+ warn "usage $0 [-f format] <imagefile>\n";
+ exit 1;
+ }
+my $file = shift;
+my $image = $mw->Photo(-file => $file, @args);
+#print join(' ',$image->formats),"\n";
+print "w=",$image->width," h=",$image->height,"\n";
+$mw->Label(-image => $image)->pack(-expand => 1, -fill => 'both');
+$mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack;
+MainLoop;
+
+__END__
+
+=head1 NAME
+
+tkjpeg - simple JPEG viewer using perl/Tk
+
+=head1 SYNOPSIS
+
+ tkjpeg imagefile.jpg
+
+=head1 DESCRIPTION
+
+Very simplistic image viewer that loads JPEG image, (well actually
+anything for which Photo has a handler) and puts it into a
+Label for display.
+
+It tries to find a fullcolour visual to use if display is deeper than
+8-bit. (On 8-bit it uses a 4/4/4 palette.)
+
+=head1 AUTHOR
+
+Nick Ing-Simmons <nick@ing-simmons.net>
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/bin/tkjpeg.bat b/Master/tlpkg/tlperl.straw/bin/tkjpeg.bat
new file mode 100755
index 00000000000..a09abd6075a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/tkjpeg.bat
@@ -0,0 +1,83 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+use strict;
+use Tk;
+use Tk::JPEG;
+use Getopt::Std;
+eval { require Tk::PNG; };
+
+my $mw = MainWindow->new();
+print "vis=",$mw->visual," d=",$mw->depth,"\n";
+my ($vis) = grep(!/\b8\b/,grep(/truecolor/,$mw->visualsavailable));
+my @args = ();
+if ($vis)
+ {
+ # print $vis,"\n";
+ $mw->destroy;
+ $mw = MainWindow->new(-visual => $vis);
+ }
+else
+ {
+ @args = (-palette => '4/4/4');
+ }
+# print "vis=",$mw->visual," d=",$mw->depth,' "',join('" "',$mw->visualsavailable),"\"\n";
+my %opt;
+getopts('f:',\%opt);
+if ($opt{'f'})
+ {
+ push(@args,'-format' => $opt{'f'});
+ }
+unless (@ARGV)
+ {
+ warn "usage $0 [-f format] <imagefile>\n";
+ exit 1;
+ }
+my $file = shift;
+my $image = $mw->Photo(-file => $file, @args);
+#print join(' ',$image->formats),"\n";
+print "w=",$image->width," h=",$image->height,"\n";
+$mw->Label(-image => $image)->pack(-expand => 1, -fill => 'both');
+$mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack;
+MainLoop;
+
+__END__
+
+=head1 NAME
+
+tkjpeg - simple JPEG viewer using perl/Tk
+
+=head1 SYNOPSIS
+
+ tkjpeg imagefile.jpg
+
+=head1 DESCRIPTION
+
+Very simplistic image viewer that loads JPEG image, (well actually
+anything for which Photo has a handler) and puts it into a
+Label for display.
+
+It tries to find a fullcolour visual to use if display is deeper than
+8-bit. (On 8-bit it uses a 4/4/4 palette.)
+
+=head1 AUTHOR
+
+Nick Ing-Simmons <nick@ing-simmons.net>
+
+=cut
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/widget b/Master/tlpkg/tlperl.straw/bin/widget
new file mode 100755
index 00000000000..05af2dcd320
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/widget
@@ -0,0 +1,608 @@
+#!/usr/local/bin/perl -w
+
+use 5.008;
+use Config;
+use Tk 804.000;
+use lib Tk->findINC( 'demos/widget_lib' );
+use Tk::widgets qw/ DialogBox ErrorDialog LabEntry ROText /;
+use Tk::Config ();
+use WidgetDemo;
+use subs qw/
+ build_about_dialog demos invoke lsearch
+ see_code see_vars show_stat view_widget
+/;
+use vars qw/ $MW $FONT $BOLD_FONT $LARGE_FONT $MONOSPACE_FONT $WIDTRIB /;
+use vars qw/ $CODE $CODE_RERUN $CODE_TEXT $VARS $VIEW $VIEW_TEXT /;
+use vars qw/ $ALIGN $BRAKES $LIGHTS $OIL $SOBER $TRANS $WIPERS /;
+use vars qw/ $COLOR $FONT_STYLE $POINT_SIZE $DEMO_FILE %DEMO_DESCRIPTION $XFT /;
+use strict;
+
+$XFT = $Tk::Config::xlib =~ /-lXft\b/;
+
+$MW = Tk::MainWindow->new;
+$MW->configure(-menu => my $menubar = $MW->Menu);
+
+{
+ package WidgetWrap;
+ @WidgetWrap::ISA = qw/Tk::MainWindow/;
+
+ # This magic conspires with widget's AUTOLOAD subroutine to make user
+ # contributed demonstrations that don't use WidgetDemo embed properly.
+ # The trick works because widget creates a superclass of Tk::MainWindow
+ # which invokes WidgetDemo() implicitly. You loose if you bypass the
+ # inheritance mechanism and call Tk::MainWindow directly.
+
+ sub new {
+ my ($name) = $::DEMO_FILE =~ m#([^/]+).pl$#;
+ $::MW->WidgetDemo(-name => $name, -text => $::DEMO_DESCRIPTION{$name});
+ }
+}
+
+@MainWindow::ISA = 'WidgetWrap';
+
+$MW->title('Perl/Tk Widget Demonstration');
+$MW->iconname('widget');
+
+my $DEFAULT_FONT_FAMILY = $XFT ? "sans-serif" : "Helvetica";
+{
+ $FONT = "$DEFAULT_FONT_FAMILY 12";
+ $BOLD_FONT = "$DEFAULT_FONT_FAMILY 12 bold";
+ $LARGE_FONT = "$DEFAULT_FONT_FAMILY 18";
+ $MONOSPACE_FONT = "Courier 12";
+ my $l = $MW->Label;
+ my $default_font = $l->cget(-font);
+ if ($default_font) {
+ my %default_font = $MW->fontActual($default_font);
+ $FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY);
+ $BOLD_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold");
+ $LARGE_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold", -size => -18);
+ $MONOSPACE_FONT = $MW->fontCreate(%default_font, -family => $XFT ? "monospace" : "Courier");
+ $MW->optionAdd("*font", $FONT);
+ }
+ $l->destroy;
+}
+
+my $widget_lib = Tk->findINC('demos/widget_lib');
+my $wd = "$widget_lib/WidgetDemo.pm";
+$WIDTRIB = Tk->findINC('demos/widtrib');
+unless (Tk::tainting) {
+ $WIDTRIB = $ENV{WIDTRIB} if defined $ENV{WIDTRIB};
+ $WIDTRIB = $ARGV[0] if defined $ARGV[0];
+}
+
+# The code below creates the main window, consisting of a menu bar
+# and a text widget that explains how to use the program, plus lists
+# all of the demos as hypertext items.
+
+my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ =>
+ [
+ [cascade => '~View', -menuitems =>
+ [
+ [command => '~widget', -command => [\&view_widget, __FILE__]],
+ [command => '~WidgetDemo', -command => [\&view_widget, $wd]],
+ ], # end cascade menuitems
+ ], # end view cascade
+ '',
+ [command => '~Quit', -command => [\&exit], -accelerator => 'Ctrl-Q'],
+ ]);
+
+my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ =>
+ [
+ [command => '~About'],
+ ]);
+
+my $T = $MW->Scrolled('ROText',
+ -scrollbars => 'e',
+ -wrap => 'word',
+ -width => 70,
+ -height => 30,
+ -font => $FONT,
+ -setgrid => 1,
+ -highlightthickness => 0,
+ -padx => 4,
+ -pady => 2,
+ -takefocus => 0,
+)->grid(qw/-sticky nsew/);
+$MW->gridRowconfigure( 0, -weight => 1); # allow expansion in both ...
+$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions
+
+$MW->bind('<Control-q>' => \&exit);
+
+my $STATUS_VAR;
+my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/);
+$status->grid(qw/-sticky ew/);
+
+# Create a bunch of tags to use in the text widget, such as those for
+# section titles and demo descriptions. Also define the bindings for
+# tags.
+
+$T->tagConfigure(qw/title -font/, $LARGE_FONT);
+$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/);
+
+if ($MW->depth == 1) {
+ $T->tagConfigure(qw/hot -background black -foreground white/);
+ $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/);
+} else {
+ $T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/);
+ $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ =>
+ '#303080');
+}
+$T->tagConfigure('bold', -font => $BOLD_FONT);
+
+$T->tagBind(qw/demo <ButtonRelease-1>/ => \&invoke);
+my $last_line = '';
+$T->tagBind(qw/demo <Enter>/ => [sub {
+ my($text, $sv) = @_;
+ my $e = $text->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $last_line = $text->index("\@$x,$y linestart");
+ $text->tagAdd('hot', $last_line, "$last_line lineend");
+ $text->configure(qw/-cursor hand2/);
+ show_stat $sv, $text, $text->index('current');
+ }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Leave>/ => [sub {
+ my($text, $sv) = @_;
+ $text->tagRemove(qw/hot 1.0 end/);
+ $text->configure(qw/-cursor xterm/);
+ $$sv = '';
+ }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Motion>/ => [sub {
+ my($text, $sv) = @_;
+ my $e = $text->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ my $new_line = $text->index("\@$x,$y linestart");
+ if ($new_line ne $last_line) {
+ $text->tagRemove(qw/hot 1.0 end/);
+ $last_line = $new_line;
+ $text->tagAdd('hot', $last_line, "$last_line lineend");
+ }
+ show_stat $sv, $text, $text->index('current');
+ }, \$STATUS_VAR]
+);
+
+# Create the text for the text widget.
+
+$T->insert('end', "Perl/Tk Widget Demonstrations\n", 'title');
+$T->insert('end',
+"\nThis application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the ", '', 'See Code', 'bold', " button to see the Perl/Tk code that created the demonstration. If you wish, you can edit the code and click the ", '', "Rerun Demo", 'bold', " button in the code window to reinvoke the demonstration with the modified code.\n"
+);
+
+demos 'Getting Started', (
+ 'hello' => 'An introduction to Perl/Tk',
+);
+
+demos 'Labels, buttons, checkbuttons, and radiobuttons', (
+ 'labels' => 'Labels (text and images)',
+ 'unicodeout' => 'Labels and Unicode text',
+ 'button' => 'Buttons',
+ 'check' => 'Checkbuttons (select any of a group)',
+ 'radio' => 'Radiobuttons (select one of a group)',
+ 'puzzle' => 'A 15-puzzle game made out of buttons',
+ 'icon' => 'Iconic buttons that use bitmaps',
+ 'image1' => 'Two labels displaying images',
+ 'image2' => 'A simple user interface for viewing images',
+ 'labelframe' => 'Labelled frames',
+);
+
+demos 'Listboxes', (
+ 'states' => 'The 50 states',
+ 'colors' => 'Change widget\'s color scheme',
+ 'sayings' => 'A collection of famous and infamous sayings',
+);
+
+demos 'Entries and Spin-boxes', (
+ 'entry1' => 'Entries without scrollbars',
+ 'entry2' => 'Entries with scrollbars',
+ 'entry3' => 'Validated entries and password fields',
+ 'spin' => 'Spin-boxes',
+ 'form' => 'Simple Rolodex-like form',
+);
+
+demos 'Text', (
+ 'texts' => 'Basic editable text',
+ 'style' => 'Text display styles',
+ 'bind' => 'Hypertext (tag bindings)',
+ 'twind' => 'A text widget with embedded windows',
+ 'search' => 'A search tool built with a text widget',
+);
+
+demos 'Canvases', (
+ 'items' => 'The canvas item types',
+ 'plot' => 'A simple 2-D plot',
+ 'ctext' => 'Text items in canvases',
+ 'arrows' => 'An editor for arrowheads on canvas lines',
+ 'ruler' => 'A ruler with adjustable tab stops',
+ 'floor' => 'A building floor plan',
+ 'cscroll' => 'A simple scrollable canvas',
+ 'transtile' => 'Tiles and transparent images',
+);
+
+demos 'Scales', (
+ 'hscale' => 'Horizontal scale',
+ 'vscale' => 'Vertical scale',
+);
+
+demos 'Paned Windows', (
+ 'paned1' => 'Horizontal paned window',
+ 'paned2' => 'Vertical paned window',
+);
+
+demos 'Photos and Images', (
+ 'photo1' => 'Transparent pixels',
+ 'photo2' => 'Alpha channel compositing',
+);
+
+demos 'Menus', (
+ 'menus' => 'Menus and cascades (sub-menus)',
+ 'menus2' => 'As above, but using Perl/Tk -menuitems',
+ 'menbut' => 'Menubuttons',
+);
+
+demos 'Common Dialogs', (
+ 'msgBox' => 'Message boxes',
+ 'filebox' => 'File selection dialog',
+ 'choosedir' => 'Directory selection dialog',
+ 'clrpick' => 'Color picker',
+);
+
+demos 'Tix Widgets', (
+ 'balloon' => 'Popup help window when mouse lingers over widget',
+ 'browseentry' => 'Entry with Listbox to select list values',
+ 'browseentry2' => 'Another BrowseEntry example',
+ 'dirtree' => 'Display a directory tree',
+ 'form_mgr' => 'The form geometry manager',
+ 'HList' => 'A hierarchical listbox widget',
+ 'HList2' => 'Multicolumn listbox with individual cell styles',
+ 'labframe' => 'A Frame with embedded label',
+);
+
+demos 'Simulations', (
+ 'bounce' => 'Balls bouncing in a cavity',
+);
+
+demos 'Sample Perl Mega-Widgets', (
+ 'mega' => 'Introduction to writing pure Perl mega-widgets',
+ 'slide' => 'Composite Tk::SlideSwitch - binary on/off switch',
+ 'trace2' => 'Derived Tk::TraceText - Text contents defined by a traced variable',
+);
+
+demos 'Miscellaneous', (
+ 'bitmaps' => 'The built-in bitmaps',
+ 'dialog1' => 'A dialog box with a local grab',
+ 'dialog2' => 'A dialog box with a global grab',
+ 'trace1' => 'Trace a variable\'s value',
+ 'progress' => 'Various ProgressBar widgets',
+ 'keysyms' => 'Show keyboard symbols',
+ 'virtevents1' => 'Synthesizing events',
+);
+
+$T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title');
+opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!";
+my(@dirent) = grep /^.+\.pl$/, sort(readdir C);
+closedir C;
+unshift @dirent, 'TEMPLATE.pl'; # I want it first
+my $i = 0;
+while ($_ = shift @dirent) {
+ next if /TEMPLATE\.pl/ and $i != 0;
+ unless (open(C, "$WIDTRIB/$_")) {
+ warn "Cannot open $_: $!" unless /TEMPLATE\.pl/;
+ next;
+ }
+ my($name) = /^(.*)\.pl$/;
+ $_ = <C>;
+ my($title) = /^#\s*(.*)$/;
+ $title =~ s{\r}{}g; # strip DOS newlines
+ $DEMO_DESCRIPTION{$name} = $title;
+ close C;
+ $T->insert('end', ++$i . ". $title\n", ['demo', "demo-$name"]);
+}
+
+build_about_dialog $help;
+$T->focus;
+
+MainLoop;
+
+sub AUTOLOAD {
+
+ # This routine handles the loading of most demo methods.
+
+ my($demo) = @_;
+
+ $T->Busy;
+ {
+ $DEMO_FILE = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl";
+ $DEMO_FILE = "$widget_lib/${demo}.pl" if -f "$widget_lib/${demo}.pl";
+ do $DEMO_FILE;
+ warn $@ if $@;
+ }
+ $T->Unbusy;
+ goto &$::AUTOLOAD if defined &$::AUTOLOAD;
+
+} # end AUTOLOAD
+
+sub build_about_dialog {
+
+ my $help = shift;
+
+ my $dialog = $MW->DialogBox(
+ -title => "Perl/Tk, based on Tcl/Tk ${Tk::version}.x",
+ -default_button => 'OK',
+ -buttons => ['OK'],
+ );
+ my $df = $dialog->add( 'Labelframe', -text => ' 2006 - Oct - 31 ' );
+ $df->pack( qw/ -fill both -expand 1 / );
+ my( $change ) = $Tk::CHANGE =~ /Change:\s+(.*)/;
+ my( $tk_date ) = scalar localtime( ( stat $Tk::library )[9] );
+ my( $tk ) = "$Tk::VERSION ($change), $tk_date";
+
+ foreach my $item (
+ [ 'Perl', "$], $Config{cf_time}" ],
+ [ 'Tk', $tk ],
+ [ 'Platform', $Tk::platform ],
+ [ 'Library', $Tk::library ],
+ ) {
+ my $l = $item->[0] . ':';
+ my $le = $df->LabEntry(
+ -font => $FONT,
+ -label => ' ' x (13 - length $l) . $l,
+ -labelPack => [qw/-side left -anchor w/],
+ -labelFont => 'Courier 12 bold',
+ -relief => 'flat',
+ -takefocus => 0,
+ -textvariable => $item->[1],
+ -width => 45,
+ );
+ $le->pack(qw/ -fill x -expand 1/);
+ $le->Subwidget( 'entry' )->bindtags( [ ] );
+ }
+
+ $help->cget(-menu)->entryconfigure('About',
+ -command => [$dialog => 'Show'],
+ );
+
+} # end build_about_dialog
+
+sub demos {
+
+ # Generate one demo section.
+
+ my ($title, @demos) = @_;
+
+ $T->insert('end', "\n", '', "$title\n", 'title');
+
+ for (my $n = 0; $n <= $#demos; $n += 2) {
+ $T->insert('end', $n / 2 + 1 . '. ' . $demos[$n + 1] . ".\n",
+ ['demo', 'demo-' . $demos[$n]]);
+ }
+
+} # end demos
+
+sub invoke {
+
+ # This procedure is called when the user clicks on a demo description.
+
+ my($text) = @_;
+
+ my $index = $text->index('current');
+ my @tags = $T->tagNames($index);
+ my $i = lsearch('demo\-.*', @tags);
+ return if $i < 0;
+ my($demo) = $tags[$i] =~ /demo-(.*)/;
+ $T->tagAdd('visited', "$index linestart", "$index lineend");
+ {
+ no strict 'refs';
+ $SIG{__WARN__} = sub {
+ print @_ unless $_[0] =~ /Subroutine \S+ redefined at/;
+ };
+ &$demo($demo);
+ }
+
+} # end invoke
+
+sub lsearch {
+
+ # Search the list using the supplied regular expression and return it's
+ # ordinal, or -1 if not found.
+
+ my($regexp, @list) = @_;
+ my($i);
+
+ for ($i=0; $i<=$#list; $i++) {
+ return $i if $list[$i] =~ /$regexp/;
+ }
+ return -1;
+
+} # end lsearch
+
+sub see_code {
+
+ # This procedure creates a toplevel window that displays the code for
+ # a demonstration and allows it to be edited and reinvoked.
+
+ my($demo) = @_;
+
+ my $file;
+ $file = ( $demo =~ /\.pl$/ ) ? $demo : "${demo}.pl";
+ if (not Exists $CODE) {
+ $CODE = $MW->Toplevel;
+ my $code_buttons = $CODE->Frame;
+ $code_buttons->pack(qw/-side bottom -fill x/);
+ my $code_buttons_dismiss = $code_buttons->Button(
+ -text => 'Dismiss',
+ -command => [$CODE => 'withdraw'],
+ );
+ $CODE_RERUN = $code_buttons->Button(-text => 'Rerun Demo');
+ $CODE_TEXT = $CODE->Scrolled('Text', qw/ -height 40 -scrollbars oe -font /, $MONOSPACE_FONT);
+ $code_buttons_dismiss->pack(qw/-side left -expand 1/);
+ $CODE_RERUN->pack(qw/-side left -expand 1/);
+ $CODE_TEXT->pack(qw/-side left -expand 1 -fill both/);
+ } else {
+ $CODE->deiconify;
+ $CODE->raise;
+ }
+ $CODE_RERUN->configure(-command => sub {
+ eval $CODE_TEXT->get(qw/1.0 end/);
+ {
+ no strict 'refs';
+ &$demo($demo);
+ }
+ });
+ $CODE->iconname($file);
+ $file = "$WIDTRIB/$file" if -f "$WIDTRIB/$file";
+ $file = "$widget_lib/$file" if -f "$widget_lib/$file";
+ $CODE->title("Demo code: $file");
+ $CODE_TEXT->delete(qw/1.0 end/);
+ open(CODE, "<$file") or warn "Cannot open demo file $file: $!";
+ {
+ local $/ = undef;
+ $CODE_TEXT->insert('1.0', <CODE>);
+ }
+ close CODE;
+ $CODE_TEXT->markSet(qw/insert 1.0/);
+ $CODE_TEXT->focus;
+
+} # end see_code
+
+sub see_vars {
+
+ # Create a top-level window that displays a bunch of global variable values
+ # and keeps the display up-to-date even when the variables change value.
+ # $args is a pointer to a list of list of 2:
+ #
+ # ["variable description", \$VAR]
+ #
+ # The old trick of passing a string to serve as the description and a soft
+ # reference to the variable no longer works with lexicals and use strict.
+
+ my($parent, $args) = @_;
+
+ $VARS->destroy if Exists($VARS);
+ $VARS = $parent->Toplevel;
+ $VARS->geometry('+300+300');
+ $VARS->title('Variable Values');
+ $VARS->iconname('Variables');
+
+ my $title = $VARS->Label(
+ -text => 'Variable Values:',
+ -width => 20,
+ -anchor => 'center',
+ -font => $LARGE_FONT,
+ );
+ $title->pack(qw/-side top -fill x/);
+ my($label, $var);
+ foreach my $i (@$args) {
+ ($label, $var) = @$i;
+ my $wf = $VARS->Frame->pack(qw/-anchor w/);
+ $wf->Label(-text => "$label: ")->pack(qw/-side left/);
+ $wf->Label(-textvariable => $var)->pack(qw/-side left/);
+ }
+ $VARS->Button(-text => 'OK', -command => [$VARS => 'destroy'])->
+ pack(qw/-side bottom -pady 2/);
+
+} # end see_vars
+
+sub show_stat {
+
+ # Display name of current demonstration. $sv is a reference to the
+ # status Label -textvariable, $text is the Text widget reference and
+ # $index is the demonstration index in the Text widget.
+
+ my($sv, $text, $index) = @_;
+
+ my @tags = $text->tagNames($index);
+ my $i = lsearch('demo\-.*', @tags);
+ return if $i < 0;
+ my($demo) = $tags[$i] =~ /demo-(.*)/;
+ $$sv = "Click Button-1 to run the \"$demo\" demonstration.";
+
+} # end show_stat
+
+sub view_widget {
+
+ # Expose a file's innards to the world too, but only for viewing.
+
+ my($widget) = @_;
+
+ if (not Exists $VIEW) {
+ $VIEW = $MW->Toplevel;
+ $VIEW->iconname('widget');
+ my $view_buttons = $VIEW->Frame;
+ $view_buttons->pack(qw/-side bottom -fill x/);
+ my $view_buttons_dismiss = $view_buttons->Button(
+ -text => 'Dismiss',
+ -command => [$VIEW => 'withdraw'],
+ );
+ $view_buttons_dismiss->pack(qw/-side left -expand 1/);
+ $VIEW_TEXT = $VIEW->Scrolled('Text', qw/ -height 40 -scrollbars oe /);
+ $VIEW_TEXT->pack(qw/-side left -expand 1 -fill both/);
+ } else {
+ $VIEW->deiconify;
+ $VIEW->raise;
+ }
+ $VIEW->title("Demo code: $widget");
+ $VIEW_TEXT->configure(qw/-state normal/);
+ $VIEW_TEXT->delete(qw/1.0 end/);
+ open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $!";
+ {
+ local $/ = undef;
+ $VIEW_TEXT->insert('1.0', <VIEW>);
+ }
+ close VIEW;
+ $VIEW_TEXT->markSet(qw/insert 1.0/);
+ $VIEW_TEXT->configure(qw/-state disabled/);
+
+} # end view_widget
+
+=head1 NAME
+
+widget - Demonstration of Perl/Tk widgets
+
+=head1 SYNOPSYS
+
+ widget [ directory ]
+
+=head1 DESCRIPTION
+
+This script demonstrates the various widgets provided by Tk, along with
+many of the features of the Tk toolkit. This file only contains code to
+generate the main window for the application, which invokes individual
+demonstrations. The code for the actual demonstrations is contained in
+separate ".pl" files in the "widget_lib" directory, which are autoloaded
+by this script as needed.
+
+widget looks in the directory specified on the command line to load user
+contributed demonstrations. If no directory name is specified when widget is
+invoked and the environment variable WIDTRIB is defined then demonstrations
+are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget
+defaults to the released user contributed directory, "widtrib".
+
+=head2 History
+
+ #
+ # Stephen O. Lidie, LUCC, 96/03/11. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/01/01. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/02/11. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/06/07. lusol@Lehigh.EDU
+ # Update for Tk402.00x. Total revamp: WidgetDemo, Scrolled, released
+ # composites, -menuitems, qw//, etcetera. Perl 5.004 required.
+ # Stephen O. Lidie, LUCC, 98/03/10. lusol@Lehigh.EDU
+ # Update for Tk8.
+ # Stephen O. Lidie, LUCC, 98/06/26. Stephen.O.Lidie@Lehigh.EDU
+ # Add Common Dialogs for Tk800.007.
+ # Stephen.O.Lidie@Lehigh.EDU, 1999/11/29, Lehigh University.
+ # Demo some "dash patch" changes.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/01/11, Lehigh University.
+ # Update menubar to Tk 8, fix color palette Menubutton demo.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/07/06, Lehigh University.
+ # Remove inswt() from widget and styles.pl to show the proper Perl/Tk
+ # idiom for inserting Text tags. Various and sundry cleanups.
+ # sol0@lehigh.edu, 2003/07/29, Lehigh University Computing Center.
+ # Update for Tk 8.4.4.
+
+=head1 AUTHOR
+
+Steve Lidie <sol0@Lehigh.EDU>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/bin/widget.bat b/Master/tlpkg/tlperl.straw/bin/widget.bat
new file mode 100755
index 00000000000..ab5b6283bbc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/widget.bat
@@ -0,0 +1,624 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+
+use 5.008;
+use Config;
+use Tk 804.000;
+use lib Tk->findINC( 'demos/widget_lib' );
+use Tk::widgets qw/ DialogBox ErrorDialog LabEntry ROText /;
+use Tk::Config ();
+use WidgetDemo;
+use subs qw/
+ build_about_dialog demos invoke lsearch
+ see_code see_vars show_stat view_widget
+/;
+use vars qw/ $MW $FONT $BOLD_FONT $LARGE_FONT $MONOSPACE_FONT $WIDTRIB /;
+use vars qw/ $CODE $CODE_RERUN $CODE_TEXT $VARS $VIEW $VIEW_TEXT /;
+use vars qw/ $ALIGN $BRAKES $LIGHTS $OIL $SOBER $TRANS $WIPERS /;
+use vars qw/ $COLOR $FONT_STYLE $POINT_SIZE $DEMO_FILE %DEMO_DESCRIPTION $XFT /;
+use strict;
+
+$XFT = $Tk::Config::xlib =~ /-lXft\b/;
+
+$MW = Tk::MainWindow->new;
+$MW->configure(-menu => my $menubar = $MW->Menu);
+
+{
+ package WidgetWrap;
+ @WidgetWrap::ISA = qw/Tk::MainWindow/;
+
+ # This magic conspires with widget's AUTOLOAD subroutine to make user
+ # contributed demonstrations that don't use WidgetDemo embed properly.
+ # The trick works because widget creates a superclass of Tk::MainWindow
+ # which invokes WidgetDemo() implicitly. You loose if you bypass the
+ # inheritance mechanism and call Tk::MainWindow directly.
+
+ sub new {
+ my ($name) = $::DEMO_FILE =~ m#([^/]+).pl$#;
+ $::MW->WidgetDemo(-name => $name, -text => $::DEMO_DESCRIPTION{$name});
+ }
+}
+
+@MainWindow::ISA = 'WidgetWrap';
+
+$MW->title('Perl/Tk Widget Demonstration');
+$MW->iconname('widget');
+
+my $DEFAULT_FONT_FAMILY = $XFT ? "sans-serif" : "Helvetica";
+{
+ $FONT = "$DEFAULT_FONT_FAMILY 12";
+ $BOLD_FONT = "$DEFAULT_FONT_FAMILY 12 bold";
+ $LARGE_FONT = "$DEFAULT_FONT_FAMILY 18";
+ $MONOSPACE_FONT = "Courier 12";
+ my $l = $MW->Label;
+ my $default_font = $l->cget(-font);
+ if ($default_font) {
+ my %default_font = $MW->fontActual($default_font);
+ $FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY);
+ $BOLD_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold");
+ $LARGE_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold", -size => -18);
+ $MONOSPACE_FONT = $MW->fontCreate(%default_font, -family => $XFT ? "monospace" : "Courier");
+ $MW->optionAdd("*font", $FONT);
+ }
+ $l->destroy;
+}
+
+my $widget_lib = Tk->findINC('demos/widget_lib');
+my $wd = "$widget_lib/WidgetDemo.pm";
+$WIDTRIB = Tk->findINC('demos/widtrib');
+unless (Tk::tainting) {
+ $WIDTRIB = $ENV{WIDTRIB} if defined $ENV{WIDTRIB};
+ $WIDTRIB = $ARGV[0] if defined $ARGV[0];
+}
+
+# The code below creates the main window, consisting of a menu bar
+# and a text widget that explains how to use the program, plus lists
+# all of the demos as hypertext items.
+
+my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ =>
+ [
+ [cascade => '~View', -menuitems =>
+ [
+ [command => '~widget', -command => [\&view_widget, __FILE__]],
+ [command => '~WidgetDemo', -command => [\&view_widget, $wd]],
+ ], # end cascade menuitems
+ ], # end view cascade
+ '',
+ [command => '~Quit', -command => [\&exit], -accelerator => 'Ctrl-Q'],
+ ]);
+
+my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ =>
+ [
+ [command => '~About'],
+ ]);
+
+my $T = $MW->Scrolled('ROText',
+ -scrollbars => 'e',
+ -wrap => 'word',
+ -width => 70,
+ -height => 30,
+ -font => $FONT,
+ -setgrid => 1,
+ -highlightthickness => 0,
+ -padx => 4,
+ -pady => 2,
+ -takefocus => 0,
+)->grid(qw/-sticky nsew/);
+$MW->gridRowconfigure( 0, -weight => 1); # allow expansion in both ...
+$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions
+
+$MW->bind('<Control-q>' => \&exit);
+
+my $STATUS_VAR;
+my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/);
+$status->grid(qw/-sticky ew/);
+
+# Create a bunch of tags to use in the text widget, such as those for
+# section titles and demo descriptions. Also define the bindings for
+# tags.
+
+$T->tagConfigure(qw/title -font/, $LARGE_FONT);
+$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/);
+
+if ($MW->depth == 1) {
+ $T->tagConfigure(qw/hot -background black -foreground white/);
+ $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/);
+} else {
+ $T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/);
+ $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ =>
+ '#303080');
+}
+$T->tagConfigure('bold', -font => $BOLD_FONT);
+
+$T->tagBind(qw/demo <ButtonRelease-1>/ => \&invoke);
+my $last_line = '';
+$T->tagBind(qw/demo <Enter>/ => [sub {
+ my($text, $sv) = @_;
+ my $e = $text->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $last_line = $text->index("\@$x,$y linestart");
+ $text->tagAdd('hot', $last_line, "$last_line lineend");
+ $text->configure(qw/-cursor hand2/);
+ show_stat $sv, $text, $text->index('current');
+ }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Leave>/ => [sub {
+ my($text, $sv) = @_;
+ $text->tagRemove(qw/hot 1.0 end/);
+ $text->configure(qw/-cursor xterm/);
+ $$sv = '';
+ }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Motion>/ => [sub {
+ my($text, $sv) = @_;
+ my $e = $text->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ my $new_line = $text->index("\@$x,$y linestart");
+ if ($new_line ne $last_line) {
+ $text->tagRemove(qw/hot 1.0 end/);
+ $last_line = $new_line;
+ $text->tagAdd('hot', $last_line, "$last_line lineend");
+ }
+ show_stat $sv, $text, $text->index('current');
+ }, \$STATUS_VAR]
+);
+
+# Create the text for the text widget.
+
+$T->insert('end', "Perl/Tk Widget Demonstrations\n", 'title');
+$T->insert('end',
+"\nThis application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the ", '', 'See Code', 'bold', " button to see the Perl/Tk code that created the demonstration. If you wish, you can edit the code and click the ", '', "Rerun Demo", 'bold', " button in the code window to reinvoke the demonstration with the modified code.\n"
+);
+
+demos 'Getting Started', (
+ 'hello' => 'An introduction to Perl/Tk',
+);
+
+demos 'Labels, buttons, checkbuttons, and radiobuttons', (
+ 'labels' => 'Labels (text and images)',
+ 'unicodeout' => 'Labels and Unicode text',
+ 'button' => 'Buttons',
+ 'check' => 'Checkbuttons (select any of a group)',
+ 'radio' => 'Radiobuttons (select one of a group)',
+ 'puzzle' => 'A 15-puzzle game made out of buttons',
+ 'icon' => 'Iconic buttons that use bitmaps',
+ 'image1' => 'Two labels displaying images',
+ 'image2' => 'A simple user interface for viewing images',
+ 'labelframe' => 'Labelled frames',
+);
+
+demos 'Listboxes', (
+ 'states' => 'The 50 states',
+ 'colors' => 'Change widget\'s color scheme',
+ 'sayings' => 'A collection of famous and infamous sayings',
+);
+
+demos 'Entries and Spin-boxes', (
+ 'entry1' => 'Entries without scrollbars',
+ 'entry2' => 'Entries with scrollbars',
+ 'entry3' => 'Validated entries and password fields',
+ 'spin' => 'Spin-boxes',
+ 'form' => 'Simple Rolodex-like form',
+);
+
+demos 'Text', (
+ 'texts' => 'Basic editable text',
+ 'style' => 'Text display styles',
+ 'bind' => 'Hypertext (tag bindings)',
+ 'twind' => 'A text widget with embedded windows',
+ 'search' => 'A search tool built with a text widget',
+);
+
+demos 'Canvases', (
+ 'items' => 'The canvas item types',
+ 'plot' => 'A simple 2-D plot',
+ 'ctext' => 'Text items in canvases',
+ 'arrows' => 'An editor for arrowheads on canvas lines',
+ 'ruler' => 'A ruler with adjustable tab stops',
+ 'floor' => 'A building floor plan',
+ 'cscroll' => 'A simple scrollable canvas',
+ 'transtile' => 'Tiles and transparent images',
+);
+
+demos 'Scales', (
+ 'hscale' => 'Horizontal scale',
+ 'vscale' => 'Vertical scale',
+);
+
+demos 'Paned Windows', (
+ 'paned1' => 'Horizontal paned window',
+ 'paned2' => 'Vertical paned window',
+);
+
+demos 'Photos and Images', (
+ 'photo1' => 'Transparent pixels',
+ 'photo2' => 'Alpha channel compositing',
+);
+
+demos 'Menus', (
+ 'menus' => 'Menus and cascades (sub-menus)',
+ 'menus2' => 'As above, but using Perl/Tk -menuitems',
+ 'menbut' => 'Menubuttons',
+);
+
+demos 'Common Dialogs', (
+ 'msgBox' => 'Message boxes',
+ 'filebox' => 'File selection dialog',
+ 'choosedir' => 'Directory selection dialog',
+ 'clrpick' => 'Color picker',
+);
+
+demos 'Tix Widgets', (
+ 'balloon' => 'Popup help window when mouse lingers over widget',
+ 'browseentry' => 'Entry with Listbox to select list values',
+ 'browseentry2' => 'Another BrowseEntry example',
+ 'dirtree' => 'Display a directory tree',
+ 'form_mgr' => 'The form geometry manager',
+ 'HList' => 'A hierarchical listbox widget',
+ 'HList2' => 'Multicolumn listbox with individual cell styles',
+ 'labframe' => 'A Frame with embedded label',
+);
+
+demos 'Simulations', (
+ 'bounce' => 'Balls bouncing in a cavity',
+);
+
+demos 'Sample Perl Mega-Widgets', (
+ 'mega' => 'Introduction to writing pure Perl mega-widgets',
+ 'slide' => 'Composite Tk::SlideSwitch - binary on/off switch',
+ 'trace2' => 'Derived Tk::TraceText - Text contents defined by a traced variable',
+);
+
+demos 'Miscellaneous', (
+ 'bitmaps' => 'The built-in bitmaps',
+ 'dialog1' => 'A dialog box with a local grab',
+ 'dialog2' => 'A dialog box with a global grab',
+ 'trace1' => 'Trace a variable\'s value',
+ 'progress' => 'Various ProgressBar widgets',
+ 'keysyms' => 'Show keyboard symbols',
+ 'virtevents1' => 'Synthesizing events',
+);
+
+$T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title');
+opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!";
+my(@dirent) = grep /^.+\.pl$/, sort(readdir C);
+closedir C;
+unshift @dirent, 'TEMPLATE.pl'; # I want it first
+my $i = 0;
+while ($_ = shift @dirent) {
+ next if /TEMPLATE\.pl/ and $i != 0;
+ unless (open(C, "$WIDTRIB/$_")) {
+ warn "Cannot open $_: $!" unless /TEMPLATE\.pl/;
+ next;
+ }
+ my($name) = /^(.*)\.pl$/;
+ $_ = <C>;
+ my($title) = /^#\s*(.*)$/;
+ $title =~ s{\r}{}g; # strip DOS newlines
+ $DEMO_DESCRIPTION{$name} = $title;
+ close C;
+ $T->insert('end', ++$i . ". $title\n", ['demo', "demo-$name"]);
+}
+
+build_about_dialog $help;
+$T->focus;
+
+MainLoop;
+
+sub AUTOLOAD {
+
+ # This routine handles the loading of most demo methods.
+
+ my($demo) = @_;
+
+ $T->Busy;
+ {
+ $DEMO_FILE = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl";
+ $DEMO_FILE = "$widget_lib/${demo}.pl" if -f "$widget_lib/${demo}.pl";
+ do $DEMO_FILE;
+ warn $@ if $@;
+ }
+ $T->Unbusy;
+ goto &$::AUTOLOAD if defined &$::AUTOLOAD;
+
+} # end AUTOLOAD
+
+sub build_about_dialog {
+
+ my $help = shift;
+
+ my $dialog = $MW->DialogBox(
+ -title => "Perl/Tk, based on Tcl/Tk ${Tk::version}.x",
+ -default_button => 'OK',
+ -buttons => ['OK'],
+ );
+ my $df = $dialog->add( 'Labelframe', -text => ' 2006 - Oct - 31 ' );
+ $df->pack( qw/ -fill both -expand 1 / );
+ my( $change ) = $Tk::CHANGE =~ /Change:\s+(.*)/;
+ my( $tk_date ) = scalar localtime( ( stat $Tk::library )[9] );
+ my( $tk ) = "$Tk::VERSION ($change), $tk_date";
+
+ foreach my $item (
+ [ 'Perl', "$], $Config{cf_time}" ],
+ [ 'Tk', $tk ],
+ [ 'Platform', $Tk::platform ],
+ [ 'Library', $Tk::library ],
+ ) {
+ my $l = $item->[0] . ':';
+ my $le = $df->LabEntry(
+ -font => $FONT,
+ -label => ' ' x (13 - length $l) . $l,
+ -labelPack => [qw/-side left -anchor w/],
+ -labelFont => 'Courier 12 bold',
+ -relief => 'flat',
+ -takefocus => 0,
+ -textvariable => $item->[1],
+ -width => 45,
+ );
+ $le->pack(qw/ -fill x -expand 1/);
+ $le->Subwidget( 'entry' )->bindtags( [ ] );
+ }
+
+ $help->cget(-menu)->entryconfigure('About',
+ -command => [$dialog => 'Show'],
+ );
+
+} # end build_about_dialog
+
+sub demos {
+
+ # Generate one demo section.
+
+ my ($title, @demos) = @_;
+
+ $T->insert('end', "\n", '', "$title\n", 'title');
+
+ for (my $n = 0; $n <= $#demos; $n += 2) {
+ $T->insert('end', $n / 2 + 1 . '. ' . $demos[$n + 1] . ".\n",
+ ['demo', 'demo-' . $demos[$n]]);
+ }
+
+} # end demos
+
+sub invoke {
+
+ # This procedure is called when the user clicks on a demo description.
+
+ my($text) = @_;
+
+ my $index = $text->index('current');
+ my @tags = $T->tagNames($index);
+ my $i = lsearch('demo\-.*', @tags);
+ return if $i < 0;
+ my($demo) = $tags[$i] =~ /demo-(.*)/;
+ $T->tagAdd('visited', "$index linestart", "$index lineend");
+ {
+ no strict 'refs';
+ $SIG{__WARN__} = sub {
+ print @_ unless $_[0] =~ /Subroutine \S+ redefined at/;
+ };
+ &$demo($demo);
+ }
+
+} # end invoke
+
+sub lsearch {
+
+ # Search the list using the supplied regular expression and return it's
+ # ordinal, or -1 if not found.
+
+ my($regexp, @list) = @_;
+ my($i);
+
+ for ($i=0; $i<=$#list; $i++) {
+ return $i if $list[$i] =~ /$regexp/;
+ }
+ return -1;
+
+} # end lsearch
+
+sub see_code {
+
+ # This procedure creates a toplevel window that displays the code for
+ # a demonstration and allows it to be edited and reinvoked.
+
+ my($demo) = @_;
+
+ my $file;
+ $file = ( $demo =~ /\.pl$/ ) ? $demo : "${demo}.pl";
+ if (not Exists $CODE) {
+ $CODE = $MW->Toplevel;
+ my $code_buttons = $CODE->Frame;
+ $code_buttons->pack(qw/-side bottom -fill x/);
+ my $code_buttons_dismiss = $code_buttons->Button(
+ -text => 'Dismiss',
+ -command => [$CODE => 'withdraw'],
+ );
+ $CODE_RERUN = $code_buttons->Button(-text => 'Rerun Demo');
+ $CODE_TEXT = $CODE->Scrolled('Text', qw/ -height 40 -scrollbars oe -font /, $MONOSPACE_FONT);
+ $code_buttons_dismiss->pack(qw/-side left -expand 1/);
+ $CODE_RERUN->pack(qw/-side left -expand 1/);
+ $CODE_TEXT->pack(qw/-side left -expand 1 -fill both/);
+ } else {
+ $CODE->deiconify;
+ $CODE->raise;
+ }
+ $CODE_RERUN->configure(-command => sub {
+ eval $CODE_TEXT->get(qw/1.0 end/);
+ {
+ no strict 'refs';
+ &$demo($demo);
+ }
+ });
+ $CODE->iconname($file);
+ $file = "$WIDTRIB/$file" if -f "$WIDTRIB/$file";
+ $file = "$widget_lib/$file" if -f "$widget_lib/$file";
+ $CODE->title("Demo code: $file");
+ $CODE_TEXT->delete(qw/1.0 end/);
+ open(CODE, "<$file") or warn "Cannot open demo file $file: $!";
+ {
+ local $/ = undef;
+ $CODE_TEXT->insert('1.0', <CODE>);
+ }
+ close CODE;
+ $CODE_TEXT->markSet(qw/insert 1.0/);
+ $CODE_TEXT->focus;
+
+} # end see_code
+
+sub see_vars {
+
+ # Create a top-level window that displays a bunch of global variable values
+ # and keeps the display up-to-date even when the variables change value.
+ # $args is a pointer to a list of list of 2:
+ #
+ # ["variable description", \$VAR]
+ #
+ # The old trick of passing a string to serve as the description and a soft
+ # reference to the variable no longer works with lexicals and use strict.
+
+ my($parent, $args) = @_;
+
+ $VARS->destroy if Exists($VARS);
+ $VARS = $parent->Toplevel;
+ $VARS->geometry('+300+300');
+ $VARS->title('Variable Values');
+ $VARS->iconname('Variables');
+
+ my $title = $VARS->Label(
+ -text => 'Variable Values:',
+ -width => 20,
+ -anchor => 'center',
+ -font => $LARGE_FONT,
+ );
+ $title->pack(qw/-side top -fill x/);
+ my($label, $var);
+ foreach my $i (@$args) {
+ ($label, $var) = @$i;
+ my $wf = $VARS->Frame->pack(qw/-anchor w/);
+ $wf->Label(-text => "$label: ")->pack(qw/-side left/);
+ $wf->Label(-textvariable => $var)->pack(qw/-side left/);
+ }
+ $VARS->Button(-text => 'OK', -command => [$VARS => 'destroy'])->
+ pack(qw/-side bottom -pady 2/);
+
+} # end see_vars
+
+sub show_stat {
+
+ # Display name of current demonstration. $sv is a reference to the
+ # status Label -textvariable, $text is the Text widget reference and
+ # $index is the demonstration index in the Text widget.
+
+ my($sv, $text, $index) = @_;
+
+ my @tags = $text->tagNames($index);
+ my $i = lsearch('demo\-.*', @tags);
+ return if $i < 0;
+ my($demo) = $tags[$i] =~ /demo-(.*)/;
+ $$sv = "Click Button-1 to run the \"$demo\" demonstration.";
+
+} # end show_stat
+
+sub view_widget {
+
+ # Expose a file's innards to the world too, but only for viewing.
+
+ my($widget) = @_;
+
+ if (not Exists $VIEW) {
+ $VIEW = $MW->Toplevel;
+ $VIEW->iconname('widget');
+ my $view_buttons = $VIEW->Frame;
+ $view_buttons->pack(qw/-side bottom -fill x/);
+ my $view_buttons_dismiss = $view_buttons->Button(
+ -text => 'Dismiss',
+ -command => [$VIEW => 'withdraw'],
+ );
+ $view_buttons_dismiss->pack(qw/-side left -expand 1/);
+ $VIEW_TEXT = $VIEW->Scrolled('Text', qw/ -height 40 -scrollbars oe /);
+ $VIEW_TEXT->pack(qw/-side left -expand 1 -fill both/);
+ } else {
+ $VIEW->deiconify;
+ $VIEW->raise;
+ }
+ $VIEW->title("Demo code: $widget");
+ $VIEW_TEXT->configure(qw/-state normal/);
+ $VIEW_TEXT->delete(qw/1.0 end/);
+ open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $!";
+ {
+ local $/ = undef;
+ $VIEW_TEXT->insert('1.0', <VIEW>);
+ }
+ close VIEW;
+ $VIEW_TEXT->markSet(qw/insert 1.0/);
+ $VIEW_TEXT->configure(qw/-state disabled/);
+
+} # end view_widget
+
+=head1 NAME
+
+widget - Demonstration of Perl/Tk widgets
+
+=head1 SYNOPSYS
+
+ widget [ directory ]
+
+=head1 DESCRIPTION
+
+This script demonstrates the various widgets provided by Tk, along with
+many of the features of the Tk toolkit. This file only contains code to
+generate the main window for the application, which invokes individual
+demonstrations. The code for the actual demonstrations is contained in
+separate ".pl" files in the "widget_lib" directory, which are autoloaded
+by this script as needed.
+
+widget looks in the directory specified on the command line to load user
+contributed demonstrations. If no directory name is specified when widget is
+invoked and the environment variable WIDTRIB is defined then demonstrations
+are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget
+defaults to the released user contributed directory, "widtrib".
+
+=head2 History
+
+ #
+ # Stephen O. Lidie, LUCC, 96/03/11. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/01/01. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/02/11. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/06/07. lusol@Lehigh.EDU
+ # Update for Tk402.00x. Total revamp: WidgetDemo, Scrolled, released
+ # composites, -menuitems, qw//, etcetera. Perl 5.004 required.
+ # Stephen O. Lidie, LUCC, 98/03/10. lusol@Lehigh.EDU
+ # Update for Tk8.
+ # Stephen O. Lidie, LUCC, 98/06/26. Stephen.O.Lidie@Lehigh.EDU
+ # Add Common Dialogs for Tk800.007.
+ # Stephen.O.Lidie@Lehigh.EDU, 1999/11/29, Lehigh University.
+ # Demo some "dash patch" changes.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/01/11, Lehigh University.
+ # Update menubar to Tk 8, fix color palette Menubutton demo.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/07/06, Lehigh University.
+ # Remove inswt() from widget and styles.pl to show the proper Perl/Tk
+ # idiom for inserting Text tags. Various and sundry cleanups.
+ # sol0@lehigh.edu, 2003/07/29, Lehigh University Computing Center.
+ # Update for Tk 8.4.4.
+
+=head1 AUTHOR
+
+Steve Lidie <sol0@Lehigh.EDU>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/bin/wperl.exe b/Master/tlpkg/tlperl.straw/bin/wperl.exe
new file mode 100755
index 00000000000..bd2c649bdc2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/wperl.exe
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/bin/xsubpp.bat b/Master/tlpkg/tlperl.straw/bin/xsubpp.bat
new file mode 100755
index 00000000000..672a905c9e8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/bin/xsubpp.bat
@@ -0,0 +1,175 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+#!./miniperl
+
+require 5.002;
+use ExtUtils::ParseXS qw(process_file);
+use Getopt::Long;
+
+my %args = ();
+
+my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n";
+
+Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case);
+
+@ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility
+GetOptions(\%args, qw(hiertype!
+ prototypes!
+ versioncheck!
+ linenumbers!
+ optimize!
+ inout!
+ argtypes!
+ object_capi!
+ except!
+ v
+ typemap=s@
+ output=s
+ s=s
+ csuffix=s
+ ))
+ or die $usage;
+
+if ($args{v}) {
+ print "xsubpp version $ExtUtils::ParseXS::VERSION\n";
+ exit;
+}
+
+@ARGV == 1 or die $usage;
+
+$args{filename} = shift @ARGV;
+
+process_file(%args);
+exit( ExtUtils::ParseXS::errors() ? 1 : 0 );
+
+__END__
+
+=head1 NAME
+
+xsubpp - compiler to convert Perl XS code into C code
+
+=head1 SYNOPSIS
+
+B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs
+
+=head1 DESCRIPTION
+
+This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>.
+
+I<xsubpp> will compile XS code into C code by embedding the constructs
+necessary to let C functions manipulate Perl values and creates the glue
+necessary to let Perl access those functions. The compiler uses typemaps to
+determine how to map C function parameters and variables to Perl values.
+
+The compiler will search for typemap files called I<typemap>. It will use
+the following search path to find default typemaps, with the rightmost
+typemap taking precedence.
+
+ ../../../typemap:../../typemap:../typemap:typemap
+
+It will also use a default typemap installed as C<ExtUtils::typemap>.
+
+=head1 OPTIONS
+
+Note that the C<XSOPT> MakeMaker option may be used to add these options to
+any makefiles generated by MakeMaker.
+
+=over 5
+
+=item B<-hiertype>
+
+Retains '::' in type names so that C++ hierarchical types can be mapped.
+
+=item B<-except>
+
+Adds exception handling stubs to the C code.
+
+=item B<-typemap typemap>
+
+Indicates that a user-supplied typemap should take precedence over the
+default typemaps. This option may be used multiple times, with the last
+typemap having the highest precedence.
+
+=item B<-output filename>
+
+Specifies the name of the output file to generate. If no file is
+specified, output will be written to standard output.
+
+=item B<-v>
+
+Prints the I<xsubpp> version number to standard output, then exits.
+
+=item B<-prototypes>
+
+By default I<xsubpp> will not automatically generate prototype code for
+all xsubs. This flag will enable prototypes.
+
+=item B<-noversioncheck>
+
+Disables the run time test that determines if the object file (derived
+from the C<.xs> file) and the C<.pm> files have the same version
+number.
+
+=item B<-nolinenumbers>
+
+Prevents the inclusion of `#line' directives in the output.
+
+=item B<-nooptimize>
+
+Disables certain optimizations. The only optimization that is currently
+affected is the use of I<target>s by the output C code (see L<perlguts>).
+This may significantly slow down the generated code, but this is the way
+B<xsubpp> of 5.005 and earlier operated.
+
+=item B<-noinout>
+
+Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.
+
+=item B<-noargtypes>
+
+Disable recognition of ANSI-like descriptions of function signature.
+
+=item B<-C++>
+
+Currently doesn't do anything at all. This flag has been a no-op for
+many versions of perl, at least as far back as perl5.003_07. It's
+allowed here for backwards compatibility.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 AUTHOR
+
+Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module
+by Ken Williams.
+
+=head1 MODIFICATION HISTORY
+
+See the file F<Changes>.
+
+=head1 SEE ALSO
+
+perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl.straw/lib/Algorithm/Diff.pm b/Master/tlpkg/tlperl.straw/lib/Algorithm/Diff.pm
new file mode 100755
index 00000000000..c3ceeade42e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Algorithm/Diff.pm
@@ -0,0 +1,1713 @@
+package Algorithm::Diff;
+# Skip to first "=head" line for documentation.
+use strict;
+
+use integer; # see below in _replaceNextLargerWith() for mod to make
+ # if you don't use this
+use vars qw( $VERSION @EXPORT_OK );
+$VERSION = 1.19_02;
+# ^ ^^ ^^-- Incremented at will
+# | \+----- Incremented for non-trivial changes to features
+# \-------- Incremented for fundamental changes
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(
+ prepare LCS LCSidx LCS_length
+ diff sdiff compact_diff
+ traverse_sequences traverse_balanced
+);
+
+# McIlroy-Hunt diff algorithm
+# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
+# by Ned Konz, perl@bike-nomad.com
+# Updates by Tye McQueen, http://perlmonks.org/?node=tye
+
+# Create a hash that maps each element of $aCollection to the set of
+# positions it occupies in $aCollection, restricted to the elements
+# within the range of indexes specified by $start and $end.
+# The fourth parameter is a subroutine reference that will be called to
+# generate a string to use as a key.
+# Additional parameters, if any, will be passed to this subroutine.
+#
+# my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
+
+sub _withPositionsOfInInterval
+{
+ my $aCollection = shift; # array ref
+ my $start = shift;
+ my $end = shift;
+ my $keyGen = shift;
+ my %d;
+ my $index;
+ for ( $index = $start ; $index <= $end ; $index++ )
+ {
+ my $element = $aCollection->[$index];
+ my $key = &$keyGen( $element, @_ );
+ if ( exists( $d{$key} ) )
+ {
+ unshift ( @{ $d{$key} }, $index );
+ }
+ else
+ {
+ $d{$key} = [$index];
+ }
+ }
+ return wantarray ? %d : \%d;
+}
+
+# Find the place at which aValue would normally be inserted into the
+# array. If that place is already occupied by aValue, do nothing, and
+# return undef. If the place does not exist (i.e., it is off the end of
+# the array), add it to the end, otherwise replace the element at that
+# point with aValue. It is assumed that the array's values are numeric.
+# This is where the bulk (75%) of the time is spent in this module, so
+# try to make it fast!
+
+sub _replaceNextLargerWith
+{
+ my ( $array, $aValue, $high ) = @_;
+ $high ||= $#$array;
+
+ # off the end?
+ if ( $high == -1 || $aValue > $array->[-1] )
+ {
+ push ( @$array, $aValue );
+ return $high + 1;
+ }
+
+ # binary search for insertion point...
+ my $low = 0;
+ my $index;
+ my $found;
+ while ( $low <= $high )
+ {
+ $index = ( $high + $low ) / 2;
+
+ # $index = int(( $high + $low ) / 2); # without 'use integer'
+ $found = $array->[$index];
+
+ if ( $aValue == $found )
+ {
+ return undef;
+ }
+ elsif ( $aValue > $found )
+ {
+ $low = $index + 1;
+ }
+ else
+ {
+ $high = $index - 1;
+ }
+ }
+
+ # now insertion point is in $low.
+ $array->[$low] = $aValue; # overwrite next larger
+ return $low;
+}
+
+# This method computes the longest common subsequence in $a and $b.
+
+# Result is array or ref, whose contents is such that
+# $a->[ $i ] == $b->[ $result[ $i ] ]
+# foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
+
+# An additional argument may be passed; this is a hash or key generating
+# function that should return a string that uniquely identifies the given
+# element. It should be the case that if the key is the same, the elements
+# will compare the same. If this parameter is undef or missing, the key
+# will be the element as a string.
+
+# By default, comparisons will use "eq" and elements will be turned into keys
+# using the default stringizing operator '""'.
+
+# Additional parameters, if any, will be passed to the key generation
+# routine.
+
+sub _longestCommonSubsequence
+{
+ my $a = shift; # array ref or hash ref
+ my $b = shift; # array ref or hash ref
+ my $counting = shift; # scalar
+ my $keyGen = shift; # code ref
+ my $compare; # code ref
+
+ if ( ref($a) eq 'HASH' )
+ { # prepared hash must be in $b
+ my $tmp = $b;
+ $b = $a;
+ $a = $tmp;
+ }
+
+ # Check for bogus (non-ref) argument values
+ if ( !ref($a) || !ref($b) )
+ {
+ my @callerInfo = caller(1);
+ die 'error: must pass array or hash references to ' . $callerInfo[3];
+ }
+
+ # set up code refs
+ # Note that these are optimized.
+ if ( !defined($keyGen) ) # optimize for strings
+ {
+ $keyGen = sub { $_[0] };
+ $compare = sub { my ( $a, $b ) = @_; $a eq $b };
+ }
+ else
+ {
+ $compare = sub {
+ my $a = shift;
+ my $b = shift;
+ &$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
+ };
+ }
+
+ my ( $aStart, $aFinish, $matchVector ) = ( 0, $#$a, [] );
+ my ( $prunedCount, $bMatches ) = ( 0, {} );
+
+ if ( ref($b) eq 'HASH' ) # was $bMatches prepared for us?
+ {
+ $bMatches = $b;
+ }
+ else
+ {
+ my ( $bStart, $bFinish ) = ( 0, $#$b );
+
+ # First we prune off any common elements at the beginning
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[$aStart], $b->[$bStart], @_ ) )
+ {
+ $matchVector->[ $aStart++ ] = $bStart++;
+ $prunedCount++;
+ }
+
+ # now the end
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) )
+ {
+ $matchVector->[ $aFinish-- ] = $bFinish--;
+ $prunedCount++;
+ }
+
+ # Now compute the equivalence classes of positions of elements
+ $bMatches =
+ _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
+ }
+ my $thresh = [];
+ my $links = [];
+
+ my ( $i, $ai, $j, $k );
+ for ( $i = $aStart ; $i <= $aFinish ; $i++ )
+ {
+ $ai = &$keyGen( $a->[$i], @_ );
+ if ( exists( $bMatches->{$ai} ) )
+ {
+ $k = 0;
+ for $j ( @{ $bMatches->{$ai} } )
+ {
+
+ # optimization: most of the time this will be true
+ if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
+ {
+ $thresh->[$k] = $j;
+ }
+ else
+ {
+ $k = _replaceNextLargerWith( $thresh, $j, $k );
+ }
+
+ # oddly, it's faster to always test this (CPU cache?).
+ if ( defined($k) )
+ {
+ $links->[$k] =
+ [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
+ }
+ }
+ }
+ }
+
+ if (@$thresh)
+ {
+ return $prunedCount + @$thresh if $counting;
+ for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
+ {
+ $matchVector->[ $link->[1] ] = $link->[2];
+ }
+ }
+ elsif ($counting)
+ {
+ return $prunedCount;
+ }
+
+ return wantarray ? @$matchVector : $matchVector;
+}
+
+sub traverse_sequences
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $callbacks = shift || {};
+ my $keyGen = shift;
+ my $matchCallback = $callbacks->{'MATCH'} || sub { };
+ my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
+ my $finishedACallback = $callbacks->{'A_FINISHED'};
+ my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
+ my $finishedBCallback = $callbacks->{'B_FINISHED'};
+ my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
+
+ # Process all the lines in @$matchVector
+ my $lastA = $#$a;
+ my $lastB = $#$b;
+ my $bi = 0;
+ my $ai;
+
+ for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
+ {
+ my $bLine = $matchVector->[$ai];
+ if ( defined($bLine) ) # matched
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
+ &$matchCallback( $ai, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai, $bi, @_ );
+ }
+ }
+
+ # The last entry (if any) processed was a match.
+ # $ai and $bi point just past the last matching lines in their sequences.
+
+ while ( $ai <= $lastA or $bi <= $lastB )
+ {
+
+ # last A?
+ if ( $ai == $lastA + 1 and $bi <= $lastB )
+ {
+ if ( defined($finishedACallback) )
+ {
+ &$finishedACallback( $lastA, @_ );
+ $finishedACallback = undef;
+ }
+ else
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
+ }
+ }
+
+ # last B?
+ if ( $bi == $lastB + 1 and $ai <= $lastA )
+ {
+ if ( defined($finishedBCallback) )
+ {
+ &$finishedBCallback( $lastB, @_ );
+ $finishedBCallback = undef;
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
+ }
+ }
+
+ &$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
+ &$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
+ }
+
+ return 1;
+}
+
+sub traverse_balanced
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $callbacks = shift || {};
+ my $keyGen = shift;
+ my $matchCallback = $callbacks->{'MATCH'} || sub { };
+ my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
+ my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
+ my $changeCallback = $callbacks->{'CHANGE'};
+ my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
+
+ # Process all the lines in match vector
+ my $lastA = $#$a;
+ my $lastB = $#$b;
+ my $bi = 0;
+ my $ai = 0;
+ my $ma = -1;
+ my $mb;
+
+ while (1)
+ {
+
+ # Find next match indices $ma and $mb
+ do {
+ $ma++;
+ } while(
+ $ma <= $#$matchVector
+ && !defined $matchVector->[$ma]
+ );
+
+ last if $ma > $#$matchVector; # end of matchVector?
+ $mb = $matchVector->[$ma];
+
+ # Proceed with discard a/b or change events until
+ # next match
+ while ( $ai < $ma || $bi < $mb )
+ {
+
+ if ( $ai < $ma && $bi < $mb )
+ {
+
+ # Change
+ if ( defined $changeCallback )
+ {
+ &$changeCallback( $ai++, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+ elsif ( $ai < $ma )
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ }
+ else
+ {
+
+ # $bi < $mb
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+
+ # Match
+ &$matchCallback( $ai++, $bi++, @_ );
+ }
+
+ while ( $ai <= $lastA || $bi <= $lastB )
+ {
+ if ( $ai <= $lastA && $bi <= $lastB )
+ {
+
+ # Change
+ if ( defined $changeCallback )
+ {
+ &$changeCallback( $ai++, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+ elsif ( $ai <= $lastA )
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ }
+ else
+ {
+
+ # $bi <= $lastB
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+
+ return 1;
+}
+
+sub prepare
+{
+ my $a = shift; # array ref
+ my $keyGen = shift; # code ref
+
+ # set up code ref
+ $keyGen = sub { $_[0] } unless defined($keyGen);
+
+ return scalar _withPositionsOfInInterval( $a, 0, $#$a, $keyGen, @_ );
+}
+
+sub LCS
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref or hash ref
+ my $matchVector = _longestCommonSubsequence( $a, $b, 0, @_ );
+ my @retval;
+ my $i;
+ for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
+ {
+ if ( defined( $matchVector->[$i] ) )
+ {
+ push ( @retval, $a->[$i] );
+ }
+ }
+ return wantarray ? @retval : \@retval;
+}
+
+sub LCS_length
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref or hash ref
+ return _longestCommonSubsequence( $a, $b, 1, @_ );
+}
+
+sub LCSidx
+{
+ my $a= shift @_;
+ my $b= shift @_;
+ my $match= _longestCommonSubsequence( $a, $b, 0, @_ );
+ my @am= grep defined $match->[$_], 0..$#$match;
+ my @bm= @{$match}[@am];
+ return \@am, \@bm;
+}
+
+sub compact_diff
+{
+ my $a= shift @_;
+ my $b= shift @_;
+ my( $am, $bm )= LCSidx( $a, $b, @_ );
+ my @cdiff;
+ my( $ai, $bi )= ( 0, 0 );
+ push @cdiff, $ai, $bi;
+ while( 1 ) {
+ while( @$am && $ai == $am->[0] && $bi == $bm->[0] ) {
+ shift @$am;
+ shift @$bm;
+ ++$ai, ++$bi;
+ }
+ push @cdiff, $ai, $bi;
+ last if ! @$am;
+ $ai = $am->[0];
+ $bi = $bm->[0];
+ push @cdiff, $ai, $bi;
+ }
+ push @cdiff, 0+@$a, 0+@$b
+ if $ai < @$a || $bi < @$b;
+ return wantarray ? @cdiff : \@cdiff;
+}
+
+sub diff
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $retval = [];
+ my $hunk = [];
+ my $discard = sub {
+ push @$hunk, [ '-', $_[0], $a->[ $_[0] ] ];
+ };
+ my $add = sub {
+ push @$hunk, [ '+', $_[1], $b->[ $_[1] ] ];
+ };
+ my $match = sub {
+ push @$retval, $hunk
+ if 0 < @$hunk;
+ $hunk = []
+ };
+ traverse_sequences( $a, $b,
+ { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
+ &$match();
+ return wantarray ? @$retval : $retval;
+}
+
+sub sdiff
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $retval = [];
+ my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
+ my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
+ my $change = sub {
+ push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
+ };
+ my $match = sub {
+ push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
+ };
+ traverse_balanced(
+ $a,
+ $b,
+ {
+ MATCH => $match,
+ DISCARD_A => $discard,
+ DISCARD_B => $add,
+ CHANGE => $change,
+ },
+ @_
+ );
+ return wantarray ? @$retval : $retval;
+}
+
+########################################
+my $Root= __PACKAGE__;
+package Algorithm::Diff::_impl;
+use strict;
+
+sub _Idx() { 0 } # $me->[_Idx]: Ref to array of hunk indices
+ # 1 # $me->[1]: Ref to first sequence
+ # 2 # $me->[2]: Ref to second sequence
+sub _End() { 3 } # $me->[_End]: Diff between forward and reverse pos
+sub _Same() { 4 } # $me->[_Same]: 1 if pos 1 contains unchanged items
+sub _Base() { 5 } # $me->[_Base]: Added to range's min and max
+sub _Pos() { 6 } # $me->[_Pos]: Which hunk is currently selected
+sub _Off() { 7 } # $me->[_Off]: Offset into _Idx for current position
+sub _Min() { -2 } # Added to _Off to get min instead of max+1
+
+sub Die
+{
+ require Carp;
+ Carp::confess( @_ );
+}
+
+sub _ChkPos
+{
+ my( $me )= @_;
+ return if $me->[_Pos];
+ my $meth= ( caller(1) )[3];
+ Die( "Called $meth on 'reset' object" );
+}
+
+sub _ChkSeq
+{
+ my( $me, $seq )= @_;
+ return $seq + $me->[_Off]
+ if 1 == $seq || 2 == $seq;
+ my $meth= ( caller(1) )[3];
+ Die( "$meth: Invalid sequence number ($seq); must be 1 or 2" );
+}
+
+sub getObjPkg
+{
+ my( $us )= @_;
+ return ref $us if ref $us;
+ return $us . "::_obj";
+}
+
+sub new
+{
+ my( $us, $seq1, $seq2, $opts ) = @_;
+ my @args;
+ for( $opts->{keyGen} ) {
+ push @args, $_ if $_;
+ }
+ for( $opts->{keyGenArgs} ) {
+ push @args, @$_ if $_;
+ }
+ my $cdif= Algorithm::Diff::compact_diff( $seq1, $seq2, @args );
+ my $same= 1;
+ if( 0 == $cdif->[2] && 0 == $cdif->[3] ) {
+ $same= 0;
+ splice @$cdif, 0, 2;
+ }
+ my @obj= ( $cdif, $seq1, $seq2 );
+ $obj[_End] = (1+@$cdif)/2;
+ $obj[_Same] = $same;
+ $obj[_Base] = 0;
+ my $me = bless \@obj, $us->getObjPkg();
+ $me->Reset( 0 );
+ return $me;
+}
+
+sub Reset
+{
+ my( $me, $pos )= @_;
+ $pos= int( $pos || 0 );
+ $pos += $me->[_End]
+ if $pos < 0;
+ $pos= 0
+ if $pos < 0 || $me->[_End] <= $pos;
+ $me->[_Pos]= $pos || !1;
+ $me->[_Off]= 2*$pos - 1;
+ return $me;
+}
+
+sub Base
+{
+ my( $me, $base )= @_;
+ my $oldBase= $me->[_Base];
+ $me->[_Base]= 0+$base if defined $base;
+ return $oldBase;
+}
+
+sub Copy
+{
+ my( $me, $pos, $base )= @_;
+ my @obj= @$me;
+ my $you= bless \@obj, ref($me);
+ $you->Reset( $pos ) if defined $pos;
+ $you->Base( $base );
+ return $you;
+}
+
+sub Next {
+ my( $me, $steps )= @_;
+ $steps= 1 if ! defined $steps;
+ if( $steps ) {
+ my $pos= $me->[_Pos];
+ my $new= $pos + $steps;
+ $new= 0 if $pos && $new < 0;
+ $me->Reset( $new )
+ }
+ return $me->[_Pos];
+}
+
+sub Prev {
+ my( $me, $steps )= @_;
+ $steps= 1 if ! defined $steps;
+ my $pos= $me->Next(-$steps);
+ $pos -= $me->[_End] if $pos;
+ return $pos;
+}
+
+sub Diff {
+ my( $me )= @_;
+ $me->_ChkPos();
+ return 0 if $me->[_Same] == ( 1 & $me->[_Pos] );
+ my $ret= 0;
+ my $off= $me->[_Off];
+ for my $seq ( 1, 2 ) {
+ $ret |= $seq
+ if $me->[_Idx][ $off + $seq + _Min ]
+ < $me->[_Idx][ $off + $seq ];
+ }
+ return $ret;
+}
+
+sub Min {
+ my( $me, $seq, $base )= @_;
+ $me->_ChkPos();
+ my $off= $me->_ChkSeq($seq);
+ $base= $me->[_Base] if !defined $base;
+ return $base + $me->[_Idx][ $off + _Min ];
+}
+
+sub Max {
+ my( $me, $seq, $base )= @_;
+ $me->_ChkPos();
+ my $off= $me->_ChkSeq($seq);
+ $base= $me->[_Base] if !defined $base;
+ return $base + $me->[_Idx][ $off ] -1;
+}
+
+sub Range {
+ my( $me, $seq, $base )= @_;
+ $me->_ChkPos();
+ my $off = $me->_ChkSeq($seq);
+ if( !wantarray ) {
+ return $me->[_Idx][ $off ]
+ - $me->[_Idx][ $off + _Min ];
+ }
+ $base= $me->[_Base] if !defined $base;
+ return ( $base + $me->[_Idx][ $off + _Min ] )
+ .. ( $base + $me->[_Idx][ $off ] - 1 );
+}
+
+sub Items {
+ my( $me, $seq )= @_;
+ $me->_ChkPos();
+ my $off = $me->_ChkSeq($seq);
+ if( !wantarray ) {
+ return $me->[_Idx][ $off ]
+ - $me->[_Idx][ $off + _Min ];
+ }
+ return
+ @{$me->[$seq]}[
+ $me->[_Idx][ $off + _Min ]
+ .. ( $me->[_Idx][ $off ] - 1 )
+ ];
+}
+
+sub Same {
+ my( $me )= @_;
+ $me->_ChkPos();
+ return wantarray ? () : 0
+ if $me->[_Same] != ( 1 & $me->[_Pos] );
+ return $me->Items(1);
+}
+
+my %getName;
+BEGIN {
+ %getName= (
+ same => \&Same,
+ diff => \&Diff,
+ base => \&Base,
+ min => \&Min,
+ max => \&Max,
+ range=> \&Range,
+ items=> \&Items, # same thing
+ );
+}
+
+sub Get
+{
+ my $me= shift @_;
+ $me->_ChkPos();
+ my @value;
+ for my $arg ( @_ ) {
+ for my $word ( split ' ', $arg ) {
+ my $meth;
+ if( $word !~ /^(-?\d+)?([a-zA-Z]+)([12])?$/
+ || not $meth= $getName{ lc $2 }
+ ) {
+ Die( $Root, ", Get: Invalid request ($word)" );
+ }
+ my( $base, $name, $seq )= ( $1, $2, $3 );
+ push @value, scalar(
+ 4 == length($name)
+ ? $meth->( $me )
+ : $meth->( $me, $seq, $base )
+ );
+ }
+ }
+ if( wantarray ) {
+ return @value;
+ } elsif( 1 == @value ) {
+ return $value[0];
+ }
+ Die( 0+@value, " values requested from ",
+ $Root, "'s Get in scalar context" );
+}
+
+
+my $Obj= getObjPkg($Root);
+no strict 'refs';
+
+for my $meth ( qw( new getObjPkg ) ) {
+ *{$Root."::".$meth} = \&{$meth};
+ *{$Obj ."::".$meth} = \&{$meth};
+}
+for my $meth ( qw(
+ Next Prev Reset Copy Base Diff
+ Same Items Range Min Max Get
+ _ChkPos _ChkSeq
+) ) {
+ *{$Obj."::".$meth} = \&{$meth};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Algorithm::Diff - Compute `intelligent' differences between two files / lists
+
+=head1 SYNOPSIS
+
+ require Algorithm::Diff;
+
+ # This example produces traditional 'diff' output:
+
+ my $diff = Algorithm::Diff->new( \@seq1, \@seq2 );
+
+ $diff->Base( 1 ); # Return line numbers, not indices
+ while( $diff->Next() ) {
+ next if $diff->Same();
+ my $sep = '';
+ if( ! $diff->Items(2) ) {
+ printf "%d,%dd%d\n",
+ $diff->Get(qw( Min1 Max1 Max2 ));
+ } elsif( ! $diff->Items(1) ) {
+ printf "%da%d,%d\n",
+ $diff->Get(qw( Max1 Min2 Max2 ));
+ } else {
+ $sep = "---\n";
+ printf "%d,%dc%d,%d\n",
+ $diff->Get(qw( Min1 Max1 Min2 Max2 ));
+ }
+ print "< $_" for $diff->Items(1);
+ print $sep;
+ print "> $_" for $diff->Items(2);
+ }
+
+
+ # Alternate interfaces:
+
+ use Algorithm::Diff qw(
+ LCS LCS_length LCSidx
+ diff sdiff compact_diff
+ traverse_sequences traverse_balanced );
+
+ @lcs = LCS( \@seq1, \@seq2 );
+ $lcsref = LCS( \@seq1, \@seq2 );
+ $count = LCS_length( \@seq1, \@seq2 );
+
+ ( $seq1idxref, $seq2idxref ) = LCSidx( \@seq1, \@seq2 );
+
+
+ # Complicated interfaces:
+
+ @diffs = diff( \@seq1, \@seq2 );
+
+ @sdiffs = sdiff( \@seq1, \@seq2 );
+
+ @cdiffs = compact_diff( \@seq1, \@seq2 );
+
+ traverse_sequences(
+ \@seq1,
+ \@seq2,
+ { MATCH => \&callback1,
+ DISCARD_A => \&callback2,
+ DISCARD_B => \&callback3,
+ },
+ \&key_generator,
+ @extra_args,
+ );
+
+ traverse_balanced(
+ \@seq1,
+ \@seq2,
+ { MATCH => \&callback1,
+ DISCARD_A => \&callback2,
+ DISCARD_B => \&callback3,
+ CHANGE => \&callback4,
+ },
+ \&key_generator,
+ @extra_args,
+ );
+
+
+=head1 INTRODUCTION
+
+(by Mark-Jason Dominus)
+
+I once read an article written by the authors of C<diff>; they said
+that they worked very hard on the algorithm until they found the
+right one.
+
+I think what they ended up using (and I hope someone will correct me,
+because I am not very confident about this) was the `longest common
+subsequence' method. In the LCS problem, you have two sequences of
+items:
+
+ a b c d f g h j q z
+
+ a b c d e f g i j k r x y z
+
+and you want to find the longest sequence of items that is present in
+both original sequences in the same order. That is, you want to find
+a new sequence I<S> which can be obtained from the first sequence by
+deleting some items, and from the secend sequence by deleting other
+items. You also want I<S> to be as long as possible. In this case I<S>
+is
+
+ a b c d f g j z
+
+From there it's only a small step to get diff-like output:
+
+ e h i k q r x y
+ + - + + - + + +
+
+This module solves the LCS problem. It also includes a canned function
+to generate C<diff>-like output.
+
+It might seem from the example above that the LCS of two sequences is
+always pretty obvious, but that's not always the case, especially when
+the two sequences have many repeated elements. For example, consider
+
+ a x b y c z p d q
+ a b c a x b y c z
+
+A naive approach might start by matching up the C<a> and C<b> that
+appear at the beginning of each sequence, like this:
+
+ a x b y c z p d q
+ a b c a b y c z
+
+This finds the common subsequence C<a b c z>. But actually, the LCS
+is C<a x b y c z>:
+
+ a x b y c z p d q
+ a b c a x b y c z
+
+or
+
+ a x b y c z p d q
+ a b c a x b y c z
+
+=head1 USAGE
+
+(See also the README file and several example
+scripts include with this module.)
+
+This module now provides an object-oriented interface that uses less
+memory and is easier to use than most of the previous procedural
+interfaces. It also still provides several exportable functions. We'll
+deal with these in ascending order of difficulty: C<LCS>,
+C<LCS_length>, C<LCSidx>, OO interface, C<prepare>, C<diff>, C<sdiff>,
+C<traverse_sequences>, and C<traverse_balanced>.
+
+=head2 C<LCS>
+
+Given references to two lists of items, LCS returns an array containing
+their longest common subsequence. In scalar context, it returns a
+reference to such a list.
+
+ @lcs = LCS( \@seq1, \@seq2 );
+ $lcsref = LCS( \@seq1, \@seq2 );
+
+C<LCS> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+ @lcs = LCS( \@seq1, \@seq2, \&keyGen, @args );
+ $lcsref = LCS( \@seq1, \@seq2, \&keyGen, @args );
+
+Additional parameters, if any, will be passed to the key generation
+routine.
+
+=head2 C<LCS_length>
+
+This is just like C<LCS> except it only returns the length of the
+longest common subsequence. This provides a performance gain of about
+9% compared to C<LCS>.
+
+=head2 C<LCSidx>
+
+Like C<LCS> except it returns references to two arrays. The first array
+contains the indices into @seq1 where the LCS items are located. The
+second array contains the indices into @seq2 where the LCS items are located.
+
+Therefore, the following three lists will contain the same values:
+
+ my( $idx1, $idx2 ) = LCSidx( \@seq1, \@seq2 );
+ my @list1 = @seq1[ @$idx1 ];
+ my @list2 = @seq2[ @$idx2 ];
+ my @list3 = LCS( \@seq1, \@seq2 );
+
+=head2 C<new>
+
+ $diff = Algorithm::Diffs->new( \@seq1, \@seq2 );
+ $diff = Algorithm::Diffs->new( \@seq1, \@seq2, \%opts );
+
+C<new> computes the smallest set of additions and deletions necessary
+to turn the first sequence into the second and compactly records them
+in the object.
+
+You use the object to iterate over I<hunks>, where each hunk represents
+a contiguous section of items which should be added, deleted, replaced,
+or left unchanged.
+
+=over 4
+
+The following summary of all of the methods looks a lot like Perl code
+but some of the symbols have different meanings:
+
+ [ ] Encloses optional arguments
+ : Is followed by the default value for an optional argument
+ | Separates alternate return results
+
+Method summary:
+
+ $obj = Algorithm::Diff->new( \@seq1, \@seq2, [ \%opts ] );
+ $pos = $obj->Next( [ $count : 1 ] );
+ $revPos = $obj->Prev( [ $count : 1 ] );
+ $obj = $obj->Reset( [ $pos : 0 ] );
+ $copy = $obj->Copy( [ $pos, [ $newBase ] ] );
+ $oldBase = $obj->Base( [ $newBase ] );
+
+Note that all of the following methods C<die> if used on an object that
+is "reset" (not currently pointing at any hunk).
+
+ $bits = $obj->Diff( );
+ @items|$cnt = $obj->Same( );
+ @items|$cnt = $obj->Items( $seqNum );
+ @idxs |$cnt = $obj->Range( $seqNum, [ $base ] );
+ $minIdx = $obj->Min( $seqNum, [ $base ] );
+ $maxIdx = $obj->Max( $seqNum, [ $base ] );
+ @values = $obj->Get( @names );
+
+Passing in C<undef> for an optional argument is always treated the same
+as if no argument were passed in.
+
+=item C<Next>
+
+ $pos = $diff->Next(); # Move forward 1 hunk
+ $pos = $diff->Next( 2 ); # Move forward 2 hunks
+ $pos = $diff->Next(-5); # Move backward 5 hunks
+
+C<Next> moves the object to point at the next hunk. The object starts
+out "reset", which means it isn't pointing at any hunk. If the object
+is reset, then C<Next()> moves to the first hunk.
+
+C<Next> returns a true value iff the move didn't go past the last hunk.
+So C<Next(0)> will return true iff the object is not reset.
+
+Actually, C<Next> returns the object's new position, which is a number
+between 1 and the number of hunks (inclusive), or returns a false value.
+
+=item C<Prev>
+
+C<Prev($N)> is almost identical to C<Next(-$N)>; it moves to the $Nth
+previous hunk. On a 'reset' object, C<Prev()> [and C<Next(-1)>] move
+to the last hunk.
+
+The position returned by C<Prev> is relative to the I<end> of the
+hunks; -1 for the last hunk, -2 for the second-to-last, etc.
+
+=item C<Reset>
+
+ $diff->Reset(); # Reset the object's position
+ $diff->Reset($pos); # Move to the specified hunk
+ $diff->Reset(1); # Move to the first hunk
+ $diff->Reset(-1); # Move to the last hunk
+
+C<Reset> returns the object, so, for example, you could use
+C<< $diff->Reset()->Next(-1) >> to get the number of hunks.
+
+=item C<Copy>
+
+ $copy = $diff->Copy( $newPos, $newBase );
+
+C<Copy> returns a copy of the object. The copy and the orignal object
+share most of their data, so making copies takes very little memory.
+The copy maintains its own position (separate from the original), which
+is the main purpose of copies. It also maintains its own base.
+
+By default, the copy's position starts out the same as the original
+object's position. But C<Copy> takes an optional first argument to set the
+new position, so the following three snippets are equivalent:
+
+ $copy = $diff->Copy($pos);
+
+ $copy = $diff->Copy();
+ $copy->Reset($pos);
+
+ $copy = $diff->Copy()->Reset($pos);
+
+C<Copy> takes an optional second argument to set the base for
+the copy. If you wish to change the base of the copy but leave
+the position the same as in the original, here are two
+equivalent ways:
+
+ $copy = $diff->Copy();
+ $copy->Base( 0 );
+
+ $copy = $diff->Copy(undef,0);
+
+Here are two equivalent way to get a "reset" copy:
+
+ $copy = $diff->Copy(0);
+
+ $copy = $diff->Copy()->Reset();
+
+=item C<Diff>
+
+ $bits = $obj->Diff();
+
+C<Diff> returns a true value iff the current hunk contains items that are
+different between the two sequences. It actually returns one of the
+follow 4 values:
+
+=over 4
+
+=item 3
+
+C<3==(1|2)>. This hunk contains items from @seq1 and the items
+from @seq2 that should replace them. Both sequence 1 and 2
+contain changed items so both the 1 and 2 bits are set.
+
+=item 2
+
+This hunk only contains items from @seq2 that should be inserted (not
+items from @seq1). Only sequence 2 contains changed items so only the 2
+bit is set.
+
+=item 1
+
+This hunk only contains items from @seq1 that should be deleted (not
+items from @seq2). Only sequence 1 contains changed items so only the 1
+bit is set.
+
+=item 0
+
+This means that the items in this hunk are the same in both sequences.
+Neither sequence 1 nor 2 contain changed items so neither the 1 nor the
+2 bits are set.
+
+=back
+
+=item C<Same>
+
+C<Same> returns a true value iff the current hunk contains items that
+are the same in both sequences. It actually returns the list of items
+if they are the same or an emty list if they aren't. In a scalar
+context, it returns the size of the list.
+
+=item C<Items>
+
+ $count = $diff->Items(2);
+ @items = $diff->Items($seqNum);
+
+C<Items> returns the (number of) items from the specified sequence that
+are part of the current hunk.
+
+If the current hunk contains only insertions, then
+C<< $diff->Items(1) >> will return an empty list (0 in a scalar conext).
+If the current hunk contains only deletions, then C<< $diff->Items(2) >>
+will return an empty list (0 in a scalar conext).
+
+If the hunk contains replacements, then both C<< $diff->Items(1) >> and
+C<< $diff->Items(2) >> will return different, non-empty lists.
+
+Otherwise, the hunk contains identical items and all of the following
+will return the same lists:
+
+ @items = $diff->Items(1);
+ @items = $diff->Items(2);
+ @items = $diff->Same();
+
+=item C<Range>
+
+ $count = $diff->Range( $seqNum );
+ @indices = $diff->Range( $seqNum );
+ @indices = $diff->Range( $seqNum, $base );
+
+C<Range> is like C<Items> except that it returns a list of I<indices> to
+the items rather than the items themselves. By default, the index of
+the first item (in each sequence) is 0 but this can be changed by
+calling the C<Base> method. So, by default, the following two snippets
+return the same lists:
+
+ @list = $diff->Items(2);
+ @list = @seq2[ $diff->Range(2) ];
+
+You can also specify the base to use as the second argument. So the
+following two snippets I<always> return the same lists:
+
+ @list = $diff->Items(1);
+ @list = @seq1[ $diff->Range(1,0) ];
+
+=item C<Base>
+
+ $curBase = $diff->Base();
+ $oldBase = $diff->Base($newBase);
+
+C<Base> sets and/or returns the current base (usually 0 or 1) that is
+used when you request range information. The base defaults to 0 so
+that range information is returned as array indices. You can set the
+base to 1 if you want to report traditional line numbers instead.
+
+=item C<Min>
+
+ $min1 = $diff->Min(1);
+ $min = $diff->Min( $seqNum, $base );
+
+C<Min> returns the first value that C<Range> would return (given the
+same arguments) or returns C<undef> if C<Range> would return an empty
+list.
+
+=item C<Max>
+
+C<Max> returns the last value that C<Range> would return or C<undef>.
+
+=item C<Get>
+
+ ( $n, $x, $r ) = $diff->Get(qw( min1 max1 range1 ));
+ @values = $diff->Get(qw( 0min2 1max2 range2 same base ));
+
+C<Get> returns one or more scalar values. You pass in a list of the
+names of the values you want returned. Each name must match one of the
+following regexes:
+
+ /^(-?\d+)?(min|max)[12]$/i
+ /^(range[12]|same|diff|base)$/i
+
+The 1 or 2 after a name says which sequence you want the information
+for (and where allowed, it is required). The optional number before
+"min" or "max" is the base to use. So the following equalities hold:
+
+ $diff->Get('min1') == $diff->Min(1)
+ $diff->Get('0min2') == $diff->Min(2,0)
+
+Using C<Get> in a scalar context when you've passed in more than one
+name is a fatal error (C<die> is called).
+
+=back
+
+=head2 C<prepare>
+
+Given a reference to a list of items, C<prepare> returns a reference
+to a hash which can be used when comparing this sequence to other
+sequences with C<LCS> or C<LCS_length>.
+
+ $prep = prepare( \@seq1 );
+ for $i ( 0 .. 10_000 )
+ {
+ @lcs = LCS( $prep, $seq[$i] );
+ # do something useful with @lcs
+ }
+
+C<prepare> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+ $prep = prepare( \@seq1, \&keyGen );
+ for $i ( 0 .. 10_000 )
+ {
+ @lcs = LCS( $seq[$i], $prep, \&keyGen );
+ # do something useful with @lcs
+ }
+
+Using C<prepare> provides a performance gain of about 50% when calling LCS
+many times compared with not preparing.
+
+=head2 C<diff>
+
+ @diffs = diff( \@seq1, \@seq2 );
+ $diffs_ref = diff( \@seq1, \@seq2 );
+
+C<diff> computes the smallest set of additions and deletions necessary
+to turn the first sequence into the second, and returns a description
+of these changes. The description is a list of I<hunks>; each hunk
+represents a contiguous section of items which should be added,
+deleted, or replaced. (Hunks containing unchanged items are not
+included.)
+
+The return value of C<diff> is a list of hunks, or, in scalar context, a
+reference to such a list. If there are no differences, the list will be
+empty.
+
+Here is an example. Calling C<diff> for the following two sequences:
+
+ a b c e h j l m n p
+ b c d e f j k l m r s t
+
+would produce the following list:
+
+ (
+ [ [ '-', 0, 'a' ] ],
+
+ [ [ '+', 2, 'd' ] ],
+
+ [ [ '-', 4, 'h' ],
+ [ '+', 4, 'f' ] ],
+
+ [ [ '+', 6, 'k' ] ],
+
+ [ [ '-', 8, 'n' ],
+ [ '-', 9, 'p' ],
+ [ '+', 9, 'r' ],
+ [ '+', 10, 's' ],
+ [ '+', 11, 't' ] ],
+ )
+
+There are five hunks here. The first hunk says that the C<a> at
+position 0 of the first sequence should be deleted (C<->). The second
+hunk says that the C<d> at position 2 of the second sequence should
+be inserted (C<+>). The third hunk says that the C<h> at position 4
+of the first sequence should be removed and replaced with the C<f>
+from position 4 of the second sequence. And so on.
+
+C<diff> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+Additional parameters, if any, will be passed to the key generation
+routine.
+
+=head2 C<sdiff>
+
+ @sdiffs = sdiff( \@seq1, \@seq2 );
+ $sdiffs_ref = sdiff( \@seq1, \@seq2 );
+
+C<sdiff> computes all necessary components to show two sequences
+and their minimized differences side by side, just like the
+Unix-utility I<sdiff> does:
+
+ same same
+ before | after
+ old < -
+ - > new
+
+It returns a list of array refs, each pointing to an array of
+display instructions. In scalar context it returns a reference
+to such a list. If there are no differences, the list will have one
+entry per item, each indicating that the item was unchanged.
+
+Display instructions consist of three elements: A modifier indicator
+(C<+>: Element added, C<->: Element removed, C<u>: Element unmodified,
+C<c>: Element changed) and the value of the old and new elements, to
+be displayed side-by-side.
+
+An C<sdiff> of the following two sequences:
+
+ a b c e h j l m n p
+ b c d e f j k l m r s t
+
+results in
+
+ ( [ '-', 'a', '' ],
+ [ 'u', 'b', 'b' ],
+ [ 'u', 'c', 'c' ],
+ [ '+', '', 'd' ],
+ [ 'u', 'e', 'e' ],
+ [ 'c', 'h', 'f' ],
+ [ 'u', 'j', 'j' ],
+ [ '+', '', 'k' ],
+ [ 'u', 'l', 'l' ],
+ [ 'u', 'm', 'm' ],
+ [ 'c', 'n', 'r' ],
+ [ 'c', 'p', 's' ],
+ [ '+', '', 't' ],
+ )
+
+C<sdiff> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+Additional parameters, if any, will be passed to the key generation
+routine.
+
+=head2 C<compact_diff>
+
+C<compact_diff> is much like C<sdiff> except it returns a much more
+compact description consisting of just one flat list of indices. An
+example helps explain the format:
+
+ my @a = qw( a b c e h j l m n p );
+ my @b = qw( b c d e f j k l m r s t );
+ @cdiff = compact_diff( \@a, \@b );
+ # Returns:
+ # @a @b @a @b
+ # start start values values
+ ( 0, 0, # =
+ 0, 0, # a !
+ 1, 0, # b c = b c
+ 3, 2, # ! d
+ 3, 3, # e = e
+ 4, 4, # f ! h
+ 5, 5, # j = j
+ 6, 6, # ! k
+ 6, 7, # l m = l m
+ 8, 9, # n p ! r s t
+ 10, 12, #
+ );
+
+The 0th, 2nd, 4th, etc. entries are all indices into @seq1 (@a in the
+above example) indicating where a hunk begins. The 1st, 3rd, 5th, etc.
+entries are all indices into @seq2 (@b in the above example) indicating
+where the same hunk begins.
+
+So each pair of indices (except the last pair) describes where a hunk
+begins (in each sequence). Since each hunk must end at the item just
+before the item that starts the next hunk, the next pair of indices can
+be used to determine where the hunk ends.
+
+So, the first 4 entries (0..3) describe the first hunk. Entries 0 and 1
+describe where the first hunk begins (and so are always both 0).
+Entries 2 and 3 describe where the next hunk begins, so subtracting 1
+from each tells us where the first hunk ends. That is, the first hunk
+contains items C<$diff[0]> through C<$diff[2] - 1> of the first sequence
+and contains items C<$diff[1]> through C<$diff[3] - 1> of the second
+sequence.
+
+In other words, the first hunk consists of the following two lists of items:
+
+ # 1st pair 2nd pair
+ # of indices of indices
+ @list1 = @a[ $cdiff[0] .. $cdiff[2]-1 ];
+ @list2 = @b[ $cdiff[1] .. $cdiff[3]-1 ];
+ # Hunk start Hunk end
+
+Note that the hunks will always alternate between those that are part of
+the LCS (those that contain unchanged items) and those that contain
+changes. This means that all we need to be told is whether the first
+hunk is a 'same' or 'diff' hunk and we can determine which of the other
+hunks contain 'same' items or 'diff' items.
+
+By convention, we always make the first hunk contain unchanged items.
+So the 1st, 3rd, 5th, etc. hunks (all odd-numbered hunks if you start
+counting from 1) all contain unchanged items. And the 2nd, 4th, 6th,
+etc. hunks (all even-numbered hunks if you start counting from 1) all
+contain changed items.
+
+Since @a and @b don't begin with the same value, the first hunk in our
+example is empty (otherwise we'd violate the above convention). Note
+that the first 4 index values in our example are all zero. Plug these
+values into our previous code block and we get:
+
+ @hunk1a = @a[ 0 .. 0-1 ];
+ @hunk1b = @b[ 0 .. 0-1 ];
+
+And C<0..-1> returns the empty list.
+
+Move down one pair of indices (2..5) and we get the offset ranges for
+the second hunk, which contains changed items.
+
+Since C<@diff[2..5]> contains (0,0,1,0) in our example, the second hunk
+consists of these two lists of items:
+
+ @hunk2a = @a[ $cdiff[2] .. $cdiff[4]-1 ];
+ @hunk2b = @b[ $cdiff[3] .. $cdiff[5]-1 ];
+ # or
+ @hunk2a = @a[ 0 .. 1-1 ];
+ @hunk2b = @b[ 0 .. 0-1 ];
+ # or
+ @hunk2a = @a[ 0 .. 0 ];
+ @hunk2b = @b[ 0 .. -1 ];
+ # or
+ @hunk2a = ( 'a' );
+ @hunk2b = ( );
+
+That is, we would delete item 0 ('a') from @a.
+
+Since C<@diff[4..7]> contains (1,0,3,2) in our example, the third hunk
+consists of these two lists of items:
+
+ @hunk3a = @a[ $cdiff[4] .. $cdiff[6]-1 ];
+ @hunk3a = @b[ $cdiff[5] .. $cdiff[7]-1 ];
+ # or
+ @hunk3a = @a[ 1 .. 3-1 ];
+ @hunk3a = @b[ 0 .. 2-1 ];
+ # or
+ @hunk3a = @a[ 1 .. 2 ];
+ @hunk3a = @b[ 0 .. 1 ];
+ # or
+ @hunk3a = qw( b c );
+ @hunk3a = qw( b c );
+
+Note that this third hunk contains unchanged items as our convention demands.
+
+You can continue this process until you reach the last two indices,
+which will always be the number of items in each sequence. This is
+required so that subtracting one from each will give you the indices to
+the last items in each sequence.
+
+=head2 C<traverse_sequences>
+
+C<traverse_sequences> used to be the most general facility provided by
+this module (the new OO interface is more powerful and much easier to
+use).
+
+Imagine that there are two arrows. Arrow A points to an element of
+sequence A, and arrow B points to an element of the sequence B.
+Initially, the arrows point to the first elements of the respective
+sequences. C<traverse_sequences> will advance the arrows through the
+sequences one element at a time, calling an appropriate user-specified
+callback function before each advance. It willadvance the arrows in
+such a way that if there are equal elements C<$A[$i]> and C<$B[$j]>
+which are equal and which are part of the LCS, there will be some moment
+during the execution of C<traverse_sequences> when arrow A is pointing
+to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this happens,
+C<traverse_sequences> will call the C<MATCH> callback function and then
+it will advance both arrows.
+
+Otherwise, one of the arrows is pointing to an element of its sequence
+that is not part of the LCS. C<traverse_sequences> will advance that
+arrow and will call the C<DISCARD_A> or the C<DISCARD_B> callback,
+depending on which arrow it advanced. If both arrows point to elements
+that are not part of the LCS, then C<traverse_sequences> will advance
+one of them and call the appropriate callback, but it is not specified
+which it will call.
+
+The arguments to C<traverse_sequences> are the two sequences to
+traverse, and a hash which specifies the callback functions, like this:
+
+ traverse_sequences(
+ \@seq1, \@seq2,
+ { MATCH => $callback_1,
+ DISCARD_A => $callback_2,
+ DISCARD_B => $callback_3,
+ }
+ );
+
+Callbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least
+the indices of the two arrows as their arguments. They are not expected
+to return any values. If a callback is omitted from the table, it is
+not called.
+
+Callbacks for A_FINISHED and B_FINISHED are invoked with at least the
+corresponding index in A or B.
+
+If arrow A reaches the end of its sequence, before arrow B does,
+C<traverse_sequences> will call the C<A_FINISHED> callback when it
+advances arrow B, if there is such a function; if not it will call
+C<DISCARD_B> instead. Similarly if arrow B finishes first.
+C<traverse_sequences> returns when both arrows are at the ends of their
+respective sequences. It returns true on success and false on failure.
+At present there is no way to fail.
+
+C<traverse_sequences> may be passed an optional fourth parameter; this
+is a CODE reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+Additional parameters, if any, will be passed to the key generation function.
+
+If you want to pass additional parameters to your callbacks, but don't
+need a custom key generation function, you can get the default by
+passing undef:
+
+ traverse_sequences(
+ \@seq1, \@seq2,
+ { MATCH => $callback_1,
+ DISCARD_A => $callback_2,
+ DISCARD_B => $callback_3,
+ },
+ undef, # default key-gen
+ $myArgument1,
+ $myArgument2,
+ $myArgument3,
+ );
+
+C<traverse_sequences> does not have a useful return value; you are
+expected to plug in the appropriate behavior with the callback
+functions.
+
+=head2 C<traverse_balanced>
+
+C<traverse_balanced> is an alternative to C<traverse_sequences>. It
+uses a different algorithm to iterate through the entries in the
+computed LCS. Instead of sticking to one side and showing element changes
+as insertions and deletions only, it will jump back and forth between
+the two sequences and report I<changes> occurring as deletions on one
+side followed immediatly by an insertion on the other side.
+
+In addition to the C<DISCARD_A>, C<DISCARD_B>, and C<MATCH> callbacks
+supported by C<traverse_sequences>, C<traverse_balanced> supports
+a C<CHANGE> callback indicating that one element got C<replaced> by another:
+
+ traverse_balanced(
+ \@seq1, \@seq2,
+ { MATCH => $callback_1,
+ DISCARD_A => $callback_2,
+ DISCARD_B => $callback_3,
+ CHANGE => $callback_4,
+ }
+ );
+
+If no C<CHANGE> callback is specified, C<traverse_balanced>
+will map C<CHANGE> events to C<DISCARD_A> and C<DISCARD_B> actions,
+therefore resulting in a similar behaviour as C<traverse_sequences>
+with different order of events.
+
+C<traverse_balanced> might be a bit slower than C<traverse_sequences>,
+noticable only while processing huge amounts of data.
+
+The C<sdiff> function of this module
+is implemented as call to C<traverse_balanced>.
+
+C<traverse_balanced> does not have a useful return value; you are expected to
+plug in the appropriate behavior with the callback functions.
+
+=head1 KEY GENERATION FUNCTIONS
+
+Most of the functions accept an optional extra parameter. This is a
+CODE reference to a key generating (hashing) function that should return
+a string that uniquely identifies a given element. It should be the
+case that if two elements are to be considered equal, their keys should
+be the same (and the other way around). If no key generation function
+is provided, the key will be the element as a string.
+
+By default, comparisons will use "eq" and elements will be turned into keys
+using the default stringizing operator '""'.
+
+Where this is important is when you're comparing something other than
+strings. If it is the case that you have multiple different objects
+that should be considered to be equal, you should supply a key
+generation function. Otherwise, you have to make sure that your arrays
+contain unique references.
+
+For instance, consider this example:
+
+ package Person;
+
+ sub new
+ {
+ my $package = shift;
+ return bless { name => '', ssn => '', @_ }, $package;
+ }
+
+ sub clone
+ {
+ my $old = shift;
+ my $new = bless { %$old }, ref($old);
+ }
+
+ sub hash
+ {
+ return shift()->{'ssn'};
+ }
+
+ my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );
+ my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );
+ my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );
+ my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );
+ my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );
+
+If you did this:
+
+ my $array1 = [ $person1, $person2, $person4 ];
+ my $array2 = [ $person1, $person3, $person4, $person5 ];
+ Algorithm::Diff::diff( $array1, $array2 );
+
+everything would work out OK (each of the objects would be converted
+into a string like "Person=HASH(0x82425b0)" for comparison).
+
+But if you did this:
+
+ my $array1 = [ $person1, $person2, $person4 ];
+ my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
+ Algorithm::Diff::diff( $array1, $array2 );
+
+$person4 and $person4->clone() (which have the same name and SSN)
+would be seen as different objects. If you wanted them to be considered
+equivalent, you would have to pass in a key generation function:
+
+ my $array1 = [ $person1, $person2, $person4 ];
+ my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
+ Algorithm::Diff::diff( $array1, $array2, \&Person::hash );
+
+This would use the 'ssn' field in each Person as a comparison key, and
+so would consider $person4 and $person4->clone() as equal.
+
+You may also pass additional parameters to the key generation function
+if you wish.
+
+=head1 ERROR CHECKING
+
+If you pass these routines a non-reference and they expect a reference,
+they will die with a message.
+
+=head1 AUTHOR
+
+This version released by Tye McQueen (http://perlmonks.org/?node=tye).
+
+=head1 LICENSE
+
+Parts Copyright (c) 2000-2004 Ned Konz. All rights reserved.
+Parts by Tye McQueen.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl.
+
+=head1 MAILING LIST
+
+Mark-Jason still maintains a mailing list. To join a low-volume mailing
+list for announcements related to diff and Algorithm::Diff, send an
+empty mail message to mjd-perl-diff-request@plover.com.
+
+=head1 CREDITS
+
+Versions through 0.59 (and much of this documentation) were written by:
+
+Mark-Jason Dominus, mjd-perl-diff@plover.com
+
+This version borrows some documentation and routine names from
+Mark-Jason's, but Diff.pm's code was completely replaced.
+
+This code was adapted from the Smalltalk code of Mario Wolczko
+<mario@wolczko.com>, which is available at
+ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
+
+C<sdiff> and C<traverse_balanced> were written by Mike Schilli
+<m@perlmeister.com>.
+
+The algorithm is that described in
+I<A Fast Algorithm for Computing Longest Common Subsequences>,
+CACM, vol.20, no.5, pp.350-353, May 1977, with a few
+minor improvements to improve the speed.
+
+Much work was done by Ned Konz (perl@bike-nomad.com).
+
+The OO interface and some other changes are by Tye McQueen.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Algorithm/DiffOld.pm b/Master/tlpkg/tlperl.straw/lib/Algorithm/DiffOld.pm
new file mode 100755
index 00000000000..511741ae352
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Algorithm/DiffOld.pm
@@ -0,0 +1,305 @@
+# This is a version of Algorithm::Diff that uses only a comparison function,
+# like versions <= 0.59 used to.
+# $Revision: 1.3 $
+
+package Algorithm::DiffOld;
+use strict;
+use vars qw($VERSION @EXPORT_OK @ISA @EXPORT);
+use integer; # see below in _replaceNextLargerWith() for mod to make
+ # if you don't use this
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw();
+@EXPORT_OK = qw(LCS diff traverse_sequences);
+$VERSION = 1.10; # manually tracking Algorithm::Diff
+
+# McIlroy-Hunt diff algorithm
+# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
+# by Ned Konz, perl@bike-nomad.com
+
+=head1 NAME
+
+Algorithm::DiffOld - Compute `intelligent' differences between two files / lists
+but use the old (<=0.59) interface.
+
+=head1 NOTE
+
+This has been provided as part of the Algorithm::Diff package by Ned Konz.
+This particular module is B<ONLY> for people who B<HAVE> to have the old
+interface, which uses a comparison function rather than a key generating
+function.
+
+Because each of the lines in one array have to be compared with each
+of the lines in the other array, this does M*N comparisions. This can
+be very slow. I clocked it at taking 18 times as long as the stock
+version of Algorithm::Diff for a 4000-line file. It will get worse
+quadratically as array sizes increase.
+
+=head1 SYNOPSIS
+
+ use Algorithm::DiffOld qw(diff LCS traverse_sequences);
+
+ @lcs = LCS( \@seq1, \@seq2, $comparison_function );
+
+ $lcsref = LCS( \@seq1, \@seq2, $comparison_function );
+
+ @diffs = diff( \@seq1, \@seq2, $comparison_function );
+
+ traverse_sequences( \@seq1, \@seq2,
+ { MATCH => $callback,
+ DISCARD_A => $callback,
+ DISCARD_B => $callback,
+ },
+ $comparison_function );
+
+=head1 COMPARISON FUNCTIONS
+
+Each of the main routines should be passed a comparison function. If you
+aren't passing one in, B<use Algorithm::Diff instead>.
+
+These functions should return a true value when two items should compare
+as equal.
+
+For instance,
+
+ @lcs = LCS( \@seq1, \@seq2, sub { my ($a, $b) = @_; $a eq $b } );
+
+but if that is all you're doing with your comparison function, just use
+Algorithm::Diff and let it do this (this is its default).
+
+Or:
+
+ sub someFunkyComparisonFunction
+ {
+ my ($a, $b) = @_;
+ $a =~ m{$b};
+ }
+
+ @diffs = diff( \@lines, \@patterns, \&someFunkyComparisonFunction );
+
+which would allow you to diff an array @lines which consists of text
+lines with an array @patterns which consists of regular expressions.
+
+This is actually the reason I wrote this version -- there is no way
+to do this with a key generation function as in the stock Algorithm::Diff.
+
+=cut
+
+# Find the place at which aValue would normally be inserted into the array. If
+# that place is already occupied by aValue, do nothing, and return undef. If
+# the place does not exist (i.e., it is off the end of the array), add it to
+# the end, otherwise replace the element at that point with aValue.
+# It is assumed that the array's values are numeric.
+# This is where the bulk (75%) of the time is spent in this module, so try to
+# make it fast!
+
+sub _replaceNextLargerWith
+{
+ my ( $array, $aValue, $high ) = @_;
+ $high ||= $#$array;
+
+ # off the end?
+ if ( $high == -1 || $aValue > $array->[ -1 ] )
+ {
+ push( @$array, $aValue );
+ return $high + 1;
+ }
+
+ # binary search for insertion point...
+ my $low = 0;
+ my $index;
+ my $found;
+ while ( $low <= $high )
+ {
+ $index = ( $high + $low ) / 2;
+# $index = int(( $high + $low ) / 2); # without 'use integer'
+ $found = $array->[ $index ];
+
+ if ( $aValue == $found )
+ {
+ return undef;
+ }
+ elsif ( $aValue > $found )
+ {
+ $low = $index + 1;
+ }
+ else
+ {
+ $high = $index - 1;
+ }
+ }
+
+ # now insertion point is in $low.
+ $array->[ $low ] = $aValue; # overwrite next larger
+ return $low;
+}
+
+# This method computes the longest common subsequence in $a and $b.
+
+# Result is array or ref, whose contents is such that
+# $a->[ $i ] == $b->[ $result[ $i ] ]
+# foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
+
+# An additional argument may be passed; this is a CODE ref to a comparison
+# routine. By default, comparisons will use "eq" .
+# Note that this routine will be called as many as M*N times, so make it fast!
+
+# Additional parameters, if any, will be passed to the key generation routine.
+
+sub _longestCommonSubsequence
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $compare = shift || sub { my $a = shift; my $b = shift; $a eq $b };
+
+ my $aStart = 0;
+ my $aFinish = $#$a;
+ my $bStart = 0;
+ my $bFinish = $#$b;
+ my $matchVector = [];
+
+ # First we prune off any common elements at the beginning
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[ $aStart ], $b->[ $bStart ], @_ ) )
+ {
+ $matchVector->[ $aStart++ ] = $bStart++;
+ }
+
+ # now the end
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[ $aFinish ], $b->[ $bFinish ], @_ ) )
+ {
+ $matchVector->[ $aFinish-- ] = $bFinish--;
+ }
+
+ my $thresh = [];
+ my $links = [];
+
+ my ( $i, $ai, $j, $k );
+ for ( $i = $aStart; $i <= $aFinish; $i++ )
+ {
+ $k = 0;
+ # look for each element of @b between $bStart and $bFinish
+ # that matches $a->[ $i ], in reverse order
+ for ($j = $bFinish; $j >= $bStart; $j--)
+ {
+ next if ! &$compare( $a->[$i], $b->[$j], @_ );
+ # optimization: most of the time this will be true
+ if ( $k
+ and $thresh->[ $k ] > $j
+ and $thresh->[ $k - 1 ] < $j )
+ {
+ $thresh->[ $k ] = $j;
+ }
+ else
+ {
+ $k = _replaceNextLargerWith( $thresh, $j, $k );
+ }
+
+ # oddly, it's faster to always test this (CPU cache?).
+ if ( defined( $k ) )
+ {
+ $links->[ $k ] =
+ [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
+ }
+ }
+ }
+
+ if ( @$thresh )
+ {
+ for ( my $link = $links->[ $#$thresh ]; $link; $link = $link->[ 0 ] )
+ {
+ $matchVector->[ $link->[ 1 ] ] = $link->[ 2 ];
+ }
+ }
+
+ return wantarray ? @$matchVector : $matchVector;
+}
+
+sub traverse_sequences
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $callbacks = shift || { };
+ my $compare = shift;
+ my $matchCallback = $callbacks->{'MATCH'} || sub { };
+ my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
+ my $finishedACallback = $callbacks->{'A_FINISHED'};
+ my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
+ my $finishedBCallback = $callbacks->{'B_FINISHED'};
+ my $matchVector = _longestCommonSubsequence( $a, $b, $compare, @_ );
+ # Process all the lines in match vector
+ my $lastA = $#$a;
+ my $lastB = $#$b;
+ my $bi = 0;
+ my $ai;
+ for ( $ai = 0; $ai <= $#$matchVector; $ai++ )
+ {
+ my $bLine = $matchVector->[ $ai ];
+ if ( defined( $bLine ) ) # matched
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
+ &$matchCallback( $ai, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai, $bi, @_ );
+ }
+ }
+ # the last entry (if any) processed was a match.
+
+ if ( defined( $finishedBCallback ) && $ai <= $lastA )
+ {
+ &$finishedBCallback( $bi, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ ) while ( $ai <= $lastA );
+ }
+
+ if ( defined( $finishedACallback ) && $bi <= $lastB )
+ {
+ &$finishedACallback( $ai, @_ );
+ }
+ else
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while ( $bi <= $lastB );
+ }
+ return 1;
+}
+
+sub LCS
+{
+ my $a = shift; # array ref
+ my $matchVector = _longestCommonSubsequence( $a, @_ );
+ my @retval;
+ my $i;
+ for ( $i = 0; $i <= $#$matchVector; $i++ )
+ {
+ if ( defined( $matchVector->[ $i ] ) )
+ {
+ push( @retval, $a->[ $i ] );
+ }
+ }
+ return wantarray ? @retval : \@retval;
+}
+
+sub diff
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $retval = [];
+ my $hunk = [];
+ my $discard = sub { push( @$hunk, [ '-', $_[ 0 ], $a->[ $_[ 0 ] ] ] ) };
+ my $add = sub { push( @$hunk, [ '+', $_[ 1 ], $b->[ $_[ 1 ] ] ] ) };
+ my $match = sub { push( @$retval, $hunk ) if scalar(@$hunk); $hunk = [] };
+ traverse_sequences( $a, $b,
+ { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add },
+ @_ );
+ &$match();
+ return wantarray ? @$retval : $retval;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Algorithm/cdiff.pl b/Master/tlpkg/tlperl.straw/lib/Algorithm/cdiff.pl
new file mode 100755
index 00000000000..7c9140ba12f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Algorithm/cdiff.pl
@@ -0,0 +1,385 @@
+#!/usr/bin/perl -w
+#
+# `Diff' program in Perl
+# Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# Altered to output in `context diff' format (but without context)
+# September 1998 Christian Murphy (cpm@muc.de)
+#
+# Command-line arguments and context lines feature added
+# September 1998 Amir D. Karger (karger@bead.aecom.yu.edu)
+#
+# In this file, "item" usually means "line of text", and "item number" usually
+# means "line number". But theoretically the code could be used more generally
+use strict;
+
+use Algorithm::Diff qw(diff);
+use File::stat;
+use vars qw ($opt_C $opt_c $opt_u $opt_U);
+use Getopt::Std;
+
+my $usage = << "ENDUSAGE";
+Usage: $0 [{-c | -u}] [{-C | -U} lines] oldfile newfile
+ -c will do a context diff with 3 lines of context
+ -C will do a context diff with 'lines' lines of context
+ -u will do a unified diff with 3 lines of context
+ -U will do a unified diff with 'lines' lines of context
+ENDUSAGE
+
+getopts('U:C:cu') or bag("$usage");
+bag("$usage") unless @ARGV == 2;
+my ($file1, $file2) = @ARGV;
+if (defined $opt_C || defined $opt_c) {
+ $opt_c = ""; # -c on if -C given on command line
+ $opt_u = undef;
+} elsif (defined $opt_U || defined $opt_u) {
+ $opt_u = ""; # -u on if -U given on command line
+ $opt_c = undef;
+} else {
+ $opt_c = ""; # by default, do context diff, not old diff
+}
+
+my ($char1, $char2); # string to print before file names
+my $Context_Lines; # lines of context to print
+if (defined $opt_c) {
+ $Context_Lines = defined $opt_C ? $opt_C : 3;
+ $char1 = '*' x 3; $char2 = '-' x 3;
+} elsif (defined $opt_u) {
+ $Context_Lines = defined $opt_U ? $opt_U : 3;
+ $char1 = '-' x 3; $char2 = '+' x 3;
+}
+
+# After we've read up to a certain point in each file, the number of items
+# we've read from each file will differ by $FLD (could be 0)
+my $File_Length_Difference = 0;
+
+open (F1, $file1) or bag("Couldn't open $file1: $!");
+open (F2, $file2) or bag("Couldn't open $file2: $!");
+my (@f1, @f2);
+chomp(@f1 = <F1>);
+close F1;
+chomp(@f2 = <F2>);
+close F2;
+
+# diff yields lots of pieces, each of which is basically a Block object
+my $diffs = diff(\@f1, \@f2);
+exit 0 unless @$diffs;
+
+my $st = stat($file1);
+print "$char1 $file1\t", scalar localtime($st->mtime), "\n";
+$st = stat($file2);
+print "$char2 $file2\t", scalar localtime($st->mtime), "\n";
+
+my ($hunk,$oldhunk);
+# Loop over hunks. If a hunk overlaps with the last hunk, join them.
+# Otherwise, print out the old one.
+foreach my $piece (@$diffs) {
+ $hunk = new Hunk ($piece, $Context_Lines);
+ next unless $oldhunk;
+
+ if ($hunk->does_overlap($oldhunk)) {
+ $hunk->prepend_hunk($oldhunk);
+ } else {
+ $oldhunk->output_diff(\@f1, \@f2);
+ }
+
+} continue {
+ $oldhunk = $hunk;
+}
+
+# print the last hunk
+$oldhunk->output_diff(\@f1, \@f2);
+exit 1;
+# END MAIN PROGRAM
+
+sub bag {
+ my $msg = shift;
+ $msg .= "\n";
+ warn $msg;
+ exit 2;
+}
+
+# Package Hunk. A Hunk is a group of Blocks which overlap because of the
+# context surrounding each block. (So if we're not using context, every
+# hunk will contain one block.)
+{
+package Hunk;
+
+sub new {
+# Arg1 is output from &LCS::diff (which corresponds to one Block)
+# Arg2 is the number of items (lines, e.g.,) of context around each block
+#
+# This subroutine changes $File_Length_Difference
+#
+# Fields in a Hunk:
+# blocks - a list of Block objects
+# start - index in file 1 where first block of the hunk starts
+# end - index in file 1 where last block of the hunk ends
+#
+# Variables:
+# before_diff - how much longer file 2 is than file 1 due to all hunks
+# until but NOT including this one
+# after_diff - difference due to all hunks including this one
+ my ($class, $piece, $context_items) = @_;
+
+ my $block = new Block ($piece); # this modifies $FLD!
+
+ my $before_diff = $File_Length_Difference; # BEFORE this hunk
+ my $after_diff = $before_diff + $block->{"length_diff"};
+ $File_Length_Difference += $block->{"length_diff"};
+
+ # @remove_array and @insert_array hold the items to insert and remove
+ # Save the start & beginning of each array. If the array doesn't exist
+ # though (e.g., we're only adding items in this block), then figure
+ # out the line number based on the line number of the other file and
+ # the current difference in file lenghts
+ my @remove_array = $block->remove;
+ my @insert_array = $block->insert;
+ my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
+ $a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
+ $a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
+ $b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
+ $b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;
+
+ $start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
+ $end1 = $a2 == -1 ? $b2 - $after_diff : $a2;
+ $start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
+ $end2 = $b2 == -1 ? $a2 + $after_diff : $b2;
+
+ # At first, a hunk will have just one Block in it
+ my $hunk = {
+ "start1" => $start1,
+ "start2" => $start2,
+ "end1" => $end1,
+ "end2" => $end2,
+ "blocks" => [$block],
+ };
+ bless $hunk, $class;
+
+ $hunk->flag_context($context_items);
+
+ return $hunk;
+}
+
+# Change the "start" and "end" fields to note that context should be added
+# to this hunk
+sub flag_context {
+ my ($hunk, $context_items) = @_;
+ return unless $context_items; # no context
+
+ # add context before
+ my $start1 = $hunk->{"start1"};
+ my $num_added = $context_items > $start1 ? $start1 : $context_items;
+ $hunk->{"start1"} -= $num_added;
+ $hunk->{"start2"} -= $num_added;
+
+ # context after
+ my $end1 = $hunk->{"end1"};
+ $num_added = ($end1+$context_items > $#f1) ?
+ $#f1 - $end1 :
+ $context_items;
+ $hunk->{"end1"} += $num_added;
+ $hunk->{"end2"} += $num_added;
+}
+
+# Is there an overlap between hunk arg0 and old hunk arg1?
+# Note: if end of old hunk is one less than beginning of second, they overlap
+sub does_overlap {
+ my ($hunk, $oldhunk) = @_;
+ return "" unless $oldhunk; # first time through, $oldhunk is empty
+
+ # Do I actually need to test both?
+ return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
+ $hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
+}
+
+# Prepend hunk arg1 to hunk arg0
+# Note that arg1 isn't updated! Only arg0 is.
+sub prepend_hunk {
+ my ($hunk, $oldhunk) = @_;
+
+ $hunk->{"start1"} = $oldhunk->{"start1"};
+ $hunk->{"start2"} = $oldhunk->{"start2"};
+
+ unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
+}
+
+
+# DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...
+sub output_diff {
+ if (defined $main::opt_u) {&output_unified_diff(@_)}
+ elsif (defined $main::opt_c) {&output_context_diff(@_)}
+ else {die "unknown diff"}
+}
+
+sub output_unified_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ # Calculate item number range.
+ my $range1 = $hunk->unified_range(1);
+ my $range2 = $hunk->unified_range(2);
+ print "@@ -$range1 +$range2 @@\n";
+
+ # Outlist starts containing the hunk of file 1.
+ # Removing an item just means putting a '-' in front of it.
+ # Inserting an item requires getting it from file2 and splicing it in.
+ # We splice in $num_added items. Remove blocks use $num_added because
+ # splicing changed the length of outlist.
+ # We remove $num_removed items. Insert blocks use $num_removed because
+ # their item numbers---corresponding to positions in file *2*--- don't take
+ # removed items into account.
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ my ($num_added, $num_removed) = (0,0);
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+
+ foreach my $block (@{$hunk->{"blocks"}}) {
+ foreach my $item ($block->remove) {
+ my $op = $item->{"sign"}; # -
+ my $offset = $item->{"item_no"} - $low + $num_added;
+ $outlist[$offset] =~ s/^ /$op/;
+ $num_removed++;
+ }
+ foreach my $item ($block->insert) {
+ my $op = $item->{"sign"}; # +
+ my $i = $item->{"item_no"};
+ my $offset = $i - $hunk->{"start2"} + $num_removed;
+ splice(@outlist,$offset,0,"$op$$fileref2[$i]");
+ $num_added++;
+ }
+ }
+
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+
+}
+
+sub output_context_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ print "***************\n";
+ # Calculate item number range.
+ my $range1 = $hunk->context_range(1);
+ my $range2 = $hunk->context_range(2);
+
+ # Print out file 1 part for each block in context diff format if there are
+ # any blocks that remove items
+ print "*** $range1 ****\n";
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ if (@blocklist = grep {$_->remove} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # - or !
+ foreach my $item ($block->remove) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+
+ print "--- $range2 ----\n";
+ $low = $hunk->{"start2"};
+ $hi = $hunk->{"end2"};
+ if (@blocklist = grep {$_->insert} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref2[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # + or !
+ foreach my $item ($block->insert) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+}
+
+sub context_range {
+# Generate a range of item numbers to print. Only print 1 number if the range
+# has only one item in it. Otherwise, it's 'start,end'
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $range = ($start < $end) ? "$start,$end" : $end;
+ return $range;
+}
+
+sub unified_range {
+# Generate a range of item numbers to print for unified diff
+# Print number where block starts, followed by number of lines in the block
+# (don't print number of lines if it's 1)
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $length = $end - $start + 1;
+ my $first = $length < 2 ? $end : $start; # strange, but correct...
+ my $range = $length== 1 ? $first : "$first,$length";
+ return $range;
+}
+} # end Package Hunk
+
+# Package Block. A block is an operation removing, adding, or changing
+# a group of items. Basically, this is just a list of changes, where each
+# change adds or deletes a single item.
+# (Change could be a separate class, but it didn't seem worth it)
+{
+package Block;
+sub new {
+# Input is a chunk from &Algorithm::LCS::diff
+# Fields in a block:
+# length_diff - how much longer file 2 is than file 1 due to this block
+# Each change has:
+# sign - '+' for insert, '-' for remove
+# item_no - number of the item in the file (e.g., line number)
+# We don't bother storing the text of the item
+#
+ my ($class,$chunk) = @_;
+ my @changes = ();
+
+# This just turns each change into a hash.
+ foreach my $item (@$chunk) {
+ my ($sign, $item_no, $text) = @$item;
+ my $hashref = {"sign" => $sign, "item_no" => $item_no};
+ push @changes, $hashref;
+ }
+
+ my $block = { "changes" => \@changes };
+ bless $block, $class;
+
+ $block->{"length_diff"} = $block->insert - $block->remove;
+ return $block;
+}
+
+
+# LOW LEVEL FUNCTIONS
+sub op {
+# what kind of block is this?
+ my $block = shift;
+ my $insert = $block->insert;
+ my $remove = $block->remove;
+
+ $remove && $insert and return '!';
+ $remove and return '-';
+ $insert and return '+';
+ warn "unknown block type";
+ return '^'; # context block
+}
+
+# Returns a list of the changes in this block that remove items
+# (or the number of removals if called in scalar context)
+sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }
+
+# Returns a list of the changes in this block that insert items
+sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }
+
+} # end of package Block
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Algorithm/diff.pl b/Master/tlpkg/tlperl.straw/lib/Algorithm/diff.pl
new file mode 100755
index 00000000000..9bddb15df6b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Algorithm/diff.pl
@@ -0,0 +1,47 @@
+#!/usr/bin/perl
+#
+# `Diff' program in Perl
+# Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+
+use Algorithm::Diff qw(diff);
+
+bag("Usage: $0 oldfile newfile") unless @ARGV == 2;
+
+my ($file1, $file2) = @ARGV;
+
+# -f $file1 or bag("$file1: not a regular file");
+# -f $file2 or bag("$file2: not a regular file");
+
+-T $file1 or bag("$file1: binary");
+-T $file2 or bag("$file2: binary");
+
+open (F1, $file1) or bag("Couldn't open $file1: $!");
+open (F2, $file2) or bag("Couldn't open $file2: $!");
+chomp(@f1 = <F1>);
+close F1;
+chomp(@f2 = <F2>);
+close F2;
+
+$diffs = diff(\@f1, \@f2);
+exit 0 unless @$diffs;
+
+foreach $chunk (@$diffs) {
+
+ foreach $line (@$chunk) {
+ my ($sign, $lineno, $text) = @$line;
+ printf "%4d$sign %s\n", $lineno+1, $text;
+ }
+ print "--------\n";
+}
+exit 1;
+
+sub bag {
+ my $msg = shift;
+ $msg .= "\n";
+ warn $msg;
+ exit 2;
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/Algorithm/diffnew.pl b/Master/tlpkg/tlperl.straw/lib/Algorithm/diffnew.pl
new file mode 100755
index 00000000000..492e52b932b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Algorithm/diffnew.pl
@@ -0,0 +1,528 @@
+#!/usr/bin/perl
+#
+# `Diff' program in Perl
+# Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# Altered to output in `context diff' format (but without context)
+# September 1998 Christian Murphy (cpm@muc.de)
+#
+# Context lines feature added
+# Unified, "Old" (Standard UNIX), Ed diff added September 1998
+# Reverse_Ed (-f option) added March 1999
+# Amir D. Karger (karger@bead.aecom.yu.edu)
+#
+# Modular functions integrated into program
+# February 1999 M-J. Dominus (mjd-perl-diff@plover.com)
+#
+# In this file, "item" usually means "line of text", and "item number" usually
+# means "line number". But theoretically the code could be used more generally
+use strict;
+use Algorithm::Diff qw(diff);
+
+# GLOBAL VARIABLES ####
+# After we've read up to a certain point in each file, the number of items
+# we've read from each file will differ by $FLD (could be 0)
+my $File_Length_Difference = 0;
+
+#ed diff outputs hunks *backwards*, so we need to save hunks when doing ed diff
+my @Ed_Hunks = ();
+########################
+
+my $usage = << "ENDUSAGE";
+Usage: $0 [{-c | -C lines -e | -f | -u | -U lines}] oldfile newfile
+ -c do a context diff with 3 lines of context
+ -C do a context diff with 'lines' lines of context (implies -c)
+ -e create a script for the ed editor to change oldfile to newfile
+ -f like -e but in reverse order
+ -u do a unified diff with 3 lines of context
+ -U do a unified diff with 'lines' lines of context (implies -u)
+ -q report only whether or not the files differ
+
+By default it will do an "old-style" diff, with output like UNIX diff
+ENDUSAGE
+
+my $Context_Lines = 0; # lines of context to print. 0 for old-style diff
+my $Diff_Type = "OLD"; # by default, do standard UNIX diff
+my ($opt_c, $opt_u, $opt_e, $opt_f, $opt_q);
+while ($ARGV[0] =~ /^-/) {
+ my $opt = shift;
+ last if $opt eq '--';
+ if ($opt =~ /^-C(.*)/) {
+ $Context_Lines = $1 || shift;
+ $opt_c = 1;
+ $Diff_Type = "CONTEXT";
+ } elsif ($opt =~ /^-c$/) {
+ $Context_Lines = 3;
+ $opt_c = 1;
+ $Diff_Type = "CONTEXT";
+ } elsif ($opt =~ /^-e$/) {
+ $opt_e = 1;
+ $Diff_Type = "ED";
+ } elsif ($opt =~ /^-f$/) {
+ $opt_f = 1;
+ $Diff_Type = "REVERSE_ED";
+ } elsif ($opt =~ /^-U(.*)$/) {
+ $Context_Lines = $1 || shift;
+ $opt_u = 1;
+ $Diff_Type = "UNIFIED";
+ } elsif ($opt =~ /^-u$/) {
+ $Context_Lines = 3;
+ $opt_u = 1;
+ $Diff_Type = "UNIFIED";
+ } elsif ($opt =~ /^-q$/) {
+ $Context_Lines = 0;
+ $opt_q = 1;
+ $opt_e = 1;
+ $Diff_Type = "ED";
+ } else {
+ $opt =~ s/^-//;
+ bag("Illegal option -- $opt");
+ }
+}
+
+if ($opt_q and grep($_,($opt_c, $opt_f, $opt_u)) > 1) {
+ bag("Combining -q with other options is nonsensical");
+}
+
+if (grep($_,($opt_c, $opt_e, $opt_f, $opt_u)) > 1) {
+ bag("Only one of -c, -u, -f, -e are allowed");
+}
+
+bag($usage) unless @ARGV == 2;
+
+######## DO THE DIFF!
+my ($file1, $file2) = @ARGV;
+
+my ($char1, $char2); # string to print before file names
+if ($Diff_Type eq "CONTEXT") {
+ $char1 = '*' x 3; $char2 = '-' x 3;
+} elsif ($Diff_Type eq "UNIFIED") {
+ $char1 = '-' x 3; $char2 = '+' x 3;
+}
+
+open (F1, $file1) or bag("Couldn't open $file1: $!");
+open (F2, $file2) or bag("Couldn't open $file2: $!");
+my (@f1, @f2);
+chomp(@f1 = <F1>);
+close F1;
+chomp(@f2 = <F2>);
+close F2;
+
+# diff yields lots of pieces, each of which is basically a Block object
+my $diffs = diff(\@f1, \@f2);
+exit 0 unless @$diffs;
+
+if ($opt_q and @$diffs) {
+ print "Files $file1 and $file2 differ\n";
+ exit 1;
+}
+
+if ($Diff_Type =~ /UNIFIED|CONTEXT/) {
+ my @st = stat($file1);
+ my $MTIME = 9;
+ print "$char1 $file1\t", scalar localtime($st[$MTIME]), "\n";
+ @st = stat($file2);
+ print "$char2 $file2\t", scalar localtime($st[$MTIME]), "\n";
+}
+
+my ($hunk,$oldhunk);
+# Loop over hunks. If a hunk overlaps with the last hunk, join them.
+# Otherwise, print out the old one.
+foreach my $piece (@$diffs) {
+ $hunk = new Hunk ($piece, $Context_Lines);
+ next unless $oldhunk; # first time through
+
+ # Don't need to check for overlap if blocks have no context lines
+ if ($Context_Lines && $hunk->does_overlap($oldhunk)) {
+ $hunk->prepend_hunk($oldhunk);
+ } else {
+ $oldhunk->output_diff(\@f1, \@f2, $Diff_Type);
+ }
+
+} continue {
+ $oldhunk = $hunk;
+}
+
+# print the last hunk
+$oldhunk->output_diff(\@f1, \@f2, $Diff_Type);
+
+# Print hunks backwards if we're doing an ed diff
+map {$_->output_ed_diff(\@f1, \@f2, $Diff_Type)} @Ed_Hunks if @Ed_Hunks;
+
+exit 1;
+# END MAIN PROGRAM
+
+sub bag {
+ my $msg = shift;
+ $msg .= "\n";
+ warn $msg;
+ exit 2;
+}
+
+########
+# Package Hunk. A Hunk is a group of Blocks which overlap because of the
+# context surrounding each block. (So if we're not using context, every
+# hunk will contain one block.)
+{
+package Hunk;
+
+sub new {
+# Arg1 is output from &LCS::diff (which corresponds to one Block)
+# Arg2 is the number of items (lines, e.g.,) of context around each block
+#
+# This subroutine changes $File_Length_Difference
+#
+# Fields in a Hunk:
+# blocks - a list of Block objects
+# start - index in file 1 where first block of the hunk starts
+# end - index in file 1 where last block of the hunk ends
+#
+# Variables:
+# before_diff - how much longer file 2 is than file 1 due to all hunks
+# until but NOT including this one
+# after_diff - difference due to all hunks including this one
+ my ($class, $piece, $context_items) = @_;
+
+ my $block = new Block ($piece); # this modifies $FLD!
+
+ my $before_diff = $File_Length_Difference; # BEFORE this hunk
+ my $after_diff = $before_diff + $block->{"length_diff"};
+ $File_Length_Difference += $block->{"length_diff"};
+
+ # @remove_array and @insert_array hold the items to insert and remove
+ # Save the start & beginning of each array. If the array doesn't exist
+ # though (e.g., we're only adding items in this block), then figure
+ # out the line number based on the line number of the other file and
+ # the current difference in file lenghts
+ my @remove_array = $block->remove;
+ my @insert_array = $block->insert;
+ my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
+ $a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
+ $a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
+ $b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
+ $b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;
+
+ $start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
+ $end1 = $a2 == -1 ? $b2 - $after_diff : $a2;
+ $start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
+ $end2 = $b2 == -1 ? $a2 + $after_diff : $b2;
+
+ # At first, a hunk will have just one Block in it
+ my $hunk = {
+ "start1" => $start1,
+ "start2" => $start2,
+ "end1" => $end1,
+ "end2" => $end2,
+ "blocks" => [$block],
+ };
+ bless $hunk, $class;
+
+ $hunk->flag_context($context_items);
+
+ return $hunk;
+}
+
+# Change the "start" and "end" fields to note that context should be added
+# to this hunk
+sub flag_context {
+ my ($hunk, $context_items) = @_;
+ return unless $context_items; # no context
+
+ # add context before
+ my $start1 = $hunk->{"start1"};
+ my $num_added = $context_items > $start1 ? $start1 : $context_items;
+ $hunk->{"start1"} -= $num_added;
+ $hunk->{"start2"} -= $num_added;
+
+ # context after
+ my $end1 = $hunk->{"end1"};
+ $num_added = ($end1+$context_items > $#f1) ?
+ $#f1 - $end1 :
+ $context_items;
+ $hunk->{"end1"} += $num_added;
+ $hunk->{"end2"} += $num_added;
+}
+
+# Is there an overlap between hunk arg0 and old hunk arg1?
+# Note: if end of old hunk is one less than beginning of second, they overlap
+sub does_overlap {
+ my ($hunk, $oldhunk) = @_;
+ return "" unless $oldhunk; # first time through, $oldhunk is empty
+
+ # Do I actually need to test both?
+ return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
+ $hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
+}
+
+# Prepend hunk arg1 to hunk arg0
+# Note that arg1 isn't updated! Only arg0 is.
+sub prepend_hunk {
+ my ($hunk, $oldhunk) = @_;
+
+ $hunk->{"start1"} = $oldhunk->{"start1"};
+ $hunk->{"start2"} = $oldhunk->{"start2"};
+
+ unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
+}
+
+
+# DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...
+sub output_diff {
+# First arg is the current hunk of course
+# Next args are refs to the files
+# last arg is type of diff
+ my $diff_type = $_[-1];
+ my %funchash = ("OLD" => \&output_old_diff,
+ "CONTEXT" => \&output_context_diff,
+ "ED" => \&store_ed_diff,
+ "REVERSE_ED" => \&output_ed_diff,
+ "UNIFIED" => \&output_unified_diff,
+ );
+ if (exists $funchash{$diff_type}) {
+ &{$funchash{$diff_type}}(@_); # pass in all args
+ } else {die "unknown diff type $diff_type"}
+}
+
+sub output_old_diff {
+# Note that an old diff can't have any context. Therefore, we know that
+# there's only one block in the hunk.
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');
+
+ my @blocklist = @{$hunk->{"blocks"}};
+ warn ("Expecting one block in an old diff hunk!") if scalar @blocklist != 1;
+ my $block = $blocklist[0];
+ my $op = $block->op; # +, -, or !
+
+ # Calculate item number range.
+ # old diff range is just like a context diff range, except the ranges
+ # are on one line with the action between them.
+ my $range1 = $hunk->context_range(1);
+ my $range2 = $hunk->context_range(2);
+ my $action = $op_hash{$op} || warn "unknown op $op";
+ print "$range1$action$range2\n";
+
+ # If removing anything, just print out all the remove lines in the hunk
+ # which is just all the remove lines in the block
+ if ($block->remove) {
+ my @outlist = @$fileref1[$hunk->{"start1"}..$hunk->{"end1"}];
+ map {$_ = "< $_\n"} @outlist; # all lines will be '< text\n'
+ print @outlist;
+ }
+
+ print "---\n" if $op eq '!'; # only if inserting and removing
+ if ($block->insert) {
+ my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
+ map {$_ = "> $_\n"} @outlist; # all lines will be '> text\n'
+ print @outlist;
+ }
+}
+
+sub output_unified_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ # Calculate item number range.
+ my $range1 = $hunk->unified_range(1);
+ my $range2 = $hunk->unified_range(2);
+ print "@@ -$range1 +$range2 @@\n";
+
+ # Outlist starts containing the hunk of file 1.
+ # Removing an item just means putting a '-' in front of it.
+ # Inserting an item requires getting it from file2 and splicing it in.
+ # We splice in $num_added items. Remove blocks use $num_added because
+ # splicing changed the length of outlist.
+ # We remove $num_removed items. Insert blocks use $num_removed because
+ # their item numbers---corresponding to positions in file *2*--- don't take
+ # removed items into account.
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ my ($num_added, $num_removed) = (0,0);
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+
+ foreach my $block (@{$hunk->{"blocks"}}) {
+ foreach my $item ($block->remove) {
+ my $op = $item->{"sign"}; # -
+ my $offset = $item->{"item_no"} - $low + $num_added;
+ $outlist[$offset] =~ s/^ /$op/;
+ $num_removed++;
+ }
+ foreach my $item ($block->insert) {
+ my $op = $item->{"sign"}; # +
+ my $i = $item->{"item_no"};
+ my $offset = $i - $hunk->{"start2"} + $num_removed;
+ splice(@outlist,$offset,0,"$op$$fileref2[$i]");
+ $num_added++;
+ }
+ }
+
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+
+}
+
+sub output_context_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ print "***************\n";
+ # Calculate item number range.
+ my $range1 = $hunk->context_range(1);
+ my $range2 = $hunk->context_range(2);
+
+ # Print out file 1 part for each block in context diff format if there are
+ # any blocks that remove items
+ print "*** $range1 ****\n";
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ if (@blocklist = grep {$_->remove} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # - or !
+ foreach my $item ($block->remove) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+
+ print "--- $range2 ----\n";
+ $low = $hunk->{"start2"};
+ $hi = $hunk->{"end2"};
+ if (@blocklist = grep {$_->insert} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref2[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # + or !
+ foreach my $item ($block->insert) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+}
+
+sub store_ed_diff {
+# ed diff prints out diffs *backwards*. So save them while we're generating
+# them, then print them out at the end
+ my $hunk = shift;
+ unshift @Ed_Hunks, $hunk;
+}
+
+sub output_ed_diff {
+# This sub is used for ed ('diff -e') OR reverse_ed ('diff -f').
+# last arg is type of diff
+ my $diff_type = $_[-1];
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');
+
+ # Can't be any context for this kind of diff, so each hunk has one block
+ my @blocklist = @{$hunk->{"blocks"}};
+ warn ("Expecting one block in an ed diff hunk!") if scalar @blocklist != 1;
+ my $block = $blocklist[0];
+ my $op = $block->op; # +, -, or !
+
+ # Calculate item number range.
+ # old diff range is just like a context diff range, except the ranges
+ # are on one line with the action between them.
+ my $range1 = $hunk->context_range(1);
+ $range1 =~ s/,/ / if $diff_type eq "REVERSE_ED";
+ my $action = $op_hash{$op} || warn "unknown op $op";
+ print ($diff_type eq "ED" ? "$range1$action\n" : "$action$range1\n");
+
+ if ($block->insert) {
+ my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ print ".\n"; # end of ed 'c' or 'a' command
+ }
+}
+
+sub context_range {
+# Generate a range of item numbers to print. Only print 1 number if the range
+# has only one item in it. Otherwise, it's 'start,end'
+# Flag is the number of the file (1 or 2)
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $range = ($start < $end) ? "$start,$end" : $end;
+ return $range;
+}
+
+sub unified_range {
+# Generate a range of item numbers to print for unified diff
+# Print number where block starts, followed by number of lines in the block
+# (don't print number of lines if it's 1)
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $length = $end - $start + 1;
+ my $first = $length < 2 ? $end : $start; # strange, but correct...
+ my $range = $length== 1 ? $first : "$first,$length";
+ return $range;
+}
+} # end Package Hunk
+
+########
+# Package Block. A block is an operation removing, adding, or changing
+# a group of items. Basically, this is just a list of changes, where each
+# change adds or deletes a single item.
+# (Change could be a separate class, but it didn't seem worth it)
+{
+package Block;
+sub new {
+# Input is a chunk from &Algorithm::LCS::diff
+# Fields in a block:
+# length_diff - how much longer file 2 is than file 1 due to this block
+# Each change has:
+# sign - '+' for insert, '-' for remove
+# item_no - number of the item in the file (e.g., line number)
+# We don't bother storing the text of the item
+#
+ my ($class,$chunk) = @_;
+ my @changes = ();
+
+# This just turns each change into a hash.
+ foreach my $item (@$chunk) {
+ my ($sign, $item_no, $text) = @$item;
+ my $hashref = {"sign" => $sign, "item_no" => $item_no};
+ push @changes, $hashref;
+ }
+
+ my $block = { "changes" => \@changes };
+ bless $block, $class;
+
+ $block->{"length_diff"} = $block->insert - $block->remove;
+ return $block;
+}
+
+
+# LOW LEVEL FUNCTIONS
+sub op {
+# what kind of block is this?
+ my $block = shift;
+ my $insert = $block->insert;
+ my $remove = $block->remove;
+
+ $remove && $insert and return '!';
+ $remove and return '-';
+ $insert and return '+';
+ warn "unknown block type";
+ return '^'; # context block
+}
+
+# Returns a list of the changes in this block that remove items
+# (or the number of removals if called in scalar context)
+sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }
+
+# Returns a list of the changes in this block that insert items
+sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }
+
+} # end of package Block
diff --git a/Master/tlpkg/tlperl.straw/lib/Algorithm/htmldiff.pl b/Master/tlpkg/tlperl.straw/lib/Algorithm/htmldiff.pl
new file mode 100755
index 00000000000..fdc81021582
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Algorithm/htmldiff.pl
@@ -0,0 +1,100 @@
+#!/usr/bin/perl -w
+# diffs two files and writes an HTML output file.
+use strict;
+use CGI qw(:standard :html3);
+use Algorithm::Diff 'traverse_sequences';
+use Text::Tabs;
+
+my ( @a, @b );
+
+# Take care of whitespace.
+sub preprocess
+{
+ my $arrayRef = shift;
+ chomp(@$arrayRef);
+ @$arrayRef = expand(@$arrayRef);
+}
+
+# This will be called with both lines are the same
+sub match
+{
+ my ( $ia, $ib ) = @_;
+ print pre( $a[$ia] ), "\n";
+}
+
+# This will be called when there is a line in A that isn't in B
+sub only_a
+{
+ my ( $ia, $ib ) = @_;
+ print pre( { -class => 'onlyA' }, $a[$ia] ), "\n";
+}
+
+# This will be called when there is a line in B that isn't in A
+sub only_b
+{
+ my ( $ia, $ib ) = @_;
+ print pre( { -class => 'onlyB' }, $b[$ib] ), "\n";
+}
+
+# MAIN PROGRAM
+
+# Check for two arguments.
+print "usage: $0 file1 file2 > diff.html\n" if @ARGV != 2;
+
+$tabstop = 4; # For Text::Tabs
+
+# Read each file into an array.
+open FH, $ARGV[0];
+@a = <FH>;
+close FH;
+
+open FH, $ARGV[1];
+@b = <FH>;
+close FH;
+
+# Expand whitespace
+preprocess( \@a );
+preprocess( \@b );
+
+# inline style
+my $style = <<EOS;
+ PRE {
+ margin-left: 24pt;
+ font-size: 12pt;
+ font-family: Courier, monospaced;
+ white-space: pre
+ }
+ PRE.onlyA { color: red }
+ PRE.onlyB { color: blue }
+EOS
+
+# Print out the starting HTML
+print
+
+ # header(),
+ start_html(
+ {
+ -title => "$ARGV[0] vs. $ARGV[1]",
+ -style => { -code => $style }
+ }
+ ),
+ h1(
+ { -style => 'margin-left: 24pt' },
+ span( { -style => 'color: red' }, $ARGV[0] ),
+ span(" <i>vs.</i> "),
+ span( { -style => 'color: blue' }, $ARGV[1] )
+ ),
+ "\n";
+
+# And compare the arrays
+traverse_sequences(
+ \@a, # first sequence
+ \@b, # second sequence
+ {
+ MATCH => \&match, # callback on identical lines
+ DISCARD_A => \&only_a, # callback on A-only
+ DISCARD_B => \&only_b, # callback on B-only
+ }
+);
+
+print end_html();
diff --git a/Master/tlpkg/tlperl.straw/lib/AnyDBM_File.pm b/Master/tlpkg/tlperl.straw/lib/AnyDBM_File.pm
new file mode 100755
index 00000000000..d73abab0f9e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Archive/Extract.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Extract.pm
new file mode 100755
index 00000000000..08676fb1e08
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Extract.pm
@@ -0,0 +1,1511 @@
+package Archive::Extract;
+
+use strict;
+
+use Cwd qw[cwd chdir];
+use Carp qw[carp];
+use IPC::Cmd qw[run can_run];
+use FileHandle;
+use File::Path qw[mkpath];
+use File::Spec;
+use File::Basename qw[dirname basename];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load check_install];
+use Locale::Maketext::Simple Style => 'gettext';
+
+### solaris has silly /bin/tar output ###
+use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0;
+use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 };
+
+### VMS may require quoting upper case command options
+use constant ON_VMS => $^O eq 'VMS' ? 1 : 0;
+
+### Windows needs special treatment of Tar options
+use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
+
+### we can't use this extraction method, because of missing
+### modules/binaries:
+use constant METHOD_NA => [];
+
+### If these are changed, update @TYPES and the new() POD
+use constant TGZ => 'tgz';
+use constant TAR => 'tar';
+use constant GZ => 'gz';
+use constant ZIP => 'zip';
+use constant BZ2 => 'bz2';
+use constant TBZ => 'tbz';
+use constant Z => 'Z';
+use constant LZMA => 'lzma';
+
+use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
+ $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
+ ];
+
+$VERSION = '0.38';
+$PREFER_BIN = 0;
+$WARN = 1;
+$DEBUG = 0;
+$_ALLOW_PURE_PERL = 1; # allow pure perl extractors
+$_ALLOW_BIN = 1; # allow binary extractors
+$_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available
+
+# same as all constants
+my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA );
+
+local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+Archive::Extract - A generic archive extracting mechanism
+
+=head1 SYNOPSIS
+
+ use Archive::Extract;
+
+ ### build an Archive::Extract object ###
+ my $ae = Archive::Extract->new( archive => 'foo.tgz' );
+
+ ### extract to cwd() ###
+ my $ok = $ae->extract;
+
+ ### extract to /tmp ###
+ my $ok = $ae->extract( to => '/tmp' );
+
+ ### what if something went wrong?
+ my $ok = $ae->extract or die $ae->error;
+
+ ### files from the archive ###
+ my $files = $ae->files;
+
+ ### dir that was extracted to ###
+ my $outdir = $ae->extract_path;
+
+
+ ### quick check methods ###
+ $ae->is_tar # is it a .tar file?
+ $ae->is_tgz # is it a .tar.gz or .tgz file?
+ $ae->is_gz; # is it a .gz file?
+ $ae->is_zip; # is it a .zip file?
+ $ae->is_bz2; # is it a .bz2 file?
+ $ae->is_tbz; # is it a .tar.bz2 or .tbz file?
+ $ae->is_lzma; # is it a .lzma file?
+
+ ### absolute path to the archive you provided ###
+ $ae->archive;
+
+ ### commandline tools, if found ###
+ $ae->bin_tar # path to /bin/tar, if found
+ $ae->bin_gzip # path to /bin/gzip, if found
+ $ae->bin_unzip # path to /bin/unzip, if found
+ $ae->bin_bunzip2 # path to /bin/bunzip2 if found
+ $ae->bin_unlzma # path to /bin/unlzma if found
+
+=head1 DESCRIPTION
+
+Archive::Extract is a generic archive extraction mechanism.
+
+It allows you to extract any archive file of the type .tar, .tar.gz,
+.gz, .Z, tar.bz2, .tbz, .bz2, .zip or .lzma without having to worry how it
+does so, or use different interfaces for each type by using either
+perl modules, or commandline tools on your system.
+
+See the C<HOW IT WORKS> section further down for details.
+
+=cut
+
+
+### see what /bin/programs are available ###
+$PROGRAMS = {};
+for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) {
+ $PROGRAMS->{$pgm} = can_run($pgm);
+}
+
+### mapping from types to extractor methods ###
+my $Mapping = { # binary program # pure perl module
+ is_tgz => { bin => '_untar_bin', pp => '_untar_at' },
+ is_tar => { bin => '_untar_bin', pp => '_untar_at' },
+ is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' },
+ is_zip => { bin => '_unzip_bin', pp => '_unzip_az' },
+ is_tbz => { bin => '_untar_bin', pp => '_untar_at' },
+ is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'},
+ is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' },
+ is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' },
+};
+
+{ ### use subs so we re-generate array refs etc for the no-overide flags
+ ### if we don't, then we reuse the same arrayref, meaning objects store
+ ### previous errors
+ my $tmpl = {
+ archive => sub { { required => 1, allow => FILE_EXISTS } },
+ type => sub { { default => '', allow => [ @Types ] } },
+ _error_msg => sub { { no_override => 1, default => [] } },
+ _error_msg_long => sub { { no_override => 1, default => [] } },
+ };
+
+ ### build accesssors ###
+ for my $method( keys %$tmpl,
+ qw[_extractor _gunzip_to files extract_path],
+ ) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method} = $_[0] if @_;
+ return $self->{$method};
+ }
+ }
+
+=head1 METHODS
+
+=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE])
+
+Creates a new C<Archive::Extract> object based on the archive file you
+passed it. Automatically determines the type of archive based on the
+extension, but you can override that by explicitly providing the
+C<type> argument.
+
+Valid values for C<type> are:
+
+=over 4
+
+=item tar
+
+Standard tar files, as produced by, for example, C</bin/tar>.
+Corresponds to a C<.tar> suffix.
+
+=item tgz
+
+Gzip compressed tar files, as produced by, for example C</bin/tar -z>.
+Corresponds to a C<.tgz> or C<.tar.gz> suffix.
+
+=item gz
+
+Gzip compressed file, as produced by, for example C</bin/gzip>.
+Corresponds to a C<.gz> suffix.
+
+=item Z
+
+Lempel-Ziv compressed file, as produced by, for example C</bin/compress>.
+Corresponds to a C<.Z> suffix.
+
+=item zip
+
+Zip compressed file, as produced by, for example C</bin/zip>.
+Corresponds to a C<.zip>, C<.jar> or C<.par> suffix.
+
+=item bz2
+
+Bzip2 compressed file, as produced by, for example, C</bin/bzip2>.
+Corresponds to a C<.bz2> suffix.
+
+=item tbz
+
+Bzip2 compressed tar file, as produced by, for exmample C</bin/tar -j>.
+Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
+
+=item lzma
+
+Lzma compressed file, as produced by C</bin/lzma>.
+Corresponds to a C<.lzma> suffix.
+
+=back
+
+Returns a C<Archive::Extract> object on success, or false on failure.
+
+=cut
+
+ ### constructor ###
+ sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ ### see above why we use subs here and generate the template;
+ ### it's basically to not re-use arrayrefs
+ my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl;
+
+ my $parsed = check( \%utmpl, \%hash ) or return;
+
+ ### make sure we have an absolute path ###
+ my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} );
+
+ ### figure out the type, if it wasn't already specified ###
+ unless ( $parsed->{type} ) {
+ $parsed->{type} =
+ $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ :
+ $ar =~ /.+?\.gz$/i ? GZ :
+ $ar =~ /.+?\.tar$/i ? TAR :
+ $ar =~ /.+?\.(zip|jar|par)$/i ? ZIP :
+ $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
+ $ar =~ /.+?\.bz2$/i ? BZ2 :
+ $ar =~ /.+?\.Z$/ ? Z :
+ $ar =~ /.+?\.lzma$/ ? LZMA :
+ '';
+
+ }
+
+ bless $parsed, $class;
+
+ ### don't know what type of file it is
+ ### XXX this *has* to be an object call, not a package call
+ return $parsed->_error(loc("Cannot determine file type for '%1'",
+ $parsed->{archive} )) unless $parsed->{type};
+ return $parsed;
+ }
+}
+
+=head2 $ae->extract( [to => '/output/path'] )
+
+Extracts the archive represented by the C<Archive::Extract> object to
+the path of your choice as specified by the C<to> argument. Defaults to
+C<cwd()>.
+
+Since C<.gz> files never hold a directory, but only a single file; if
+the C<to> argument is an existing directory, the file is extracted
+there, with its C<.gz> suffix stripped.
+If the C<to> argument is not an existing directory, the C<to> argument
+is understood to be a filename, if the archive type is C<gz>.
+In the case that you did not specify a C<to> argument, the output
+file will be the name of the archive file, stripped from its C<.gz>
+suffix, in the current working directory.
+
+C<extract> will try a pure perl solution first, and then fall back to
+commandline tools if they are available. See the C<GLOBAL VARIABLES>
+section below on how to alter this behaviour.
+
+It will return true on success, and false on failure.
+
+On success, it will also set the follow attributes in the object:
+
+=over 4
+
+=item $ae->extract_path
+
+This is the directory that the files where extracted to.
+
+=item $ae->files
+
+This is an array ref with the paths of all the files in the archive,
+relative to the C<to> argument you specified.
+To get the full path to an extracted file, you would use:
+
+ File::Spec->catfile( $to, $ae->files->[0] );
+
+Note that all files from a tar archive will be in unix format, as per
+the tar specification.
+
+=back
+
+=cut
+
+sub extract {
+ my $self = shift;
+ my %hash = @_;
+
+ ### reset error messages
+ $self->_error_msg( [] );
+ $self->_error_msg_long( [] );
+
+ my $to;
+ my $tmpl = {
+ to => { default => '.', store => \$to }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### so 'to' could be a file or a dir, depending on whether it's a .gz
+ ### file, or basically anything else.
+ ### so, check that, then act accordingly.
+ ### set an accessor specifically so _gunzip can know what file to extract
+ ### to.
+ my $dir;
+ { ### a foo.gz file
+ if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma ) {
+
+ my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma)$//i;
+
+ ### to is a dir?
+ if ( -d $to ) {
+ $dir = $to;
+ $self->_gunzip_to( basename($cp) );
+
+ ### then it's a filename
+ } else {
+ $dir = dirname($to);
+ $self->_gunzip_to( basename($to) );
+ }
+
+ ### not a foo.gz file
+ } else {
+ $dir = $to;
+ }
+ }
+
+ ### make the dir if it doesn't exist ###
+ unless( -d $dir ) {
+ eval { mkpath( $dir ) };
+
+ return $self->_error(loc("Could not create path '%1': %2", $dir, $@))
+ if $@;
+ }
+
+ ### get the current dir, to restore later ###
+ my $cwd = cwd();
+
+ my $ok = 1;
+ EXTRACT: {
+
+ ### chdir to the target dir ###
+ unless( chdir $dir ) {
+ $self->_error(loc("Could not chdir to '%1': %2", $dir, $!));
+ $ok = 0; last EXTRACT;
+ }
+
+ ### set files to an empty array ref, so there's always an array
+ ### ref IN the accessor, to avoid errors like:
+ ### Can't use an undefined value as an ARRAY reference at
+ ### ../lib/Archive/Extract.pm line 742. (rt #19815)
+ $self->files( [] );
+
+ ### find out the dispatch methods needed for this type of
+ ### archive. Do a $self->is_XXX to figure out the type, then
+ ### get the hashref with bin + pure perl dispatchers.
+ my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping;
+
+ ### add pure perl extractor if allowed & add bin extractor if allowed
+ my @methods;
+ push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL;
+ push @methods, $map->{'bin'} if $_ALLOW_BIN;
+
+ ### reverse it if we prefer bin extractors
+ @methods = reverse @methods if $PREFER_BIN;
+
+ my($na, $fail);
+ for my $method (@methods) {
+ print "# Extracting with ->$method\n" if $DEBUG;
+
+ my $rv = $self->$method;
+
+ ### a positive extraction
+ if( $rv and $rv ne METHOD_NA ) {
+ print "# Extraction succeeded\n" if $DEBUG;
+ $self->_extractor($method);
+ last;
+
+ ### method is not available
+ } elsif ( $rv and $rv eq METHOD_NA ) {
+ print "# Extraction method not available\n" if $DEBUG;
+ $na++;
+ } else {
+ print "# Extraction method failed\n" if $DEBUG;
+ $fail++;
+ }
+ }
+
+ ### warn something went wrong if we didn't get an extractor
+ unless( $self->_extractor ) {
+ my $diag = $fail ? loc("Extract failed due to errors") :
+ $na ? loc("Extract failed; no extractors available") :
+ '';
+
+ $self->_error($diag);
+ $ok = 0;
+ }
+ }
+
+ ### and chdir back ###
+ unless( chdir $cwd ) {
+ $self->_error(loc("Could not chdir back to start dir '%1': %2'",
+ $cwd, $!));
+ }
+
+ return $ok;
+}
+
+=pod
+
+=head1 ACCESSORS
+
+=head2 $ae->error([BOOL])
+
+Returns the last encountered error as string.
+Pass it a true value to get the C<Carp::longmess()> output instead.
+
+=head2 $ae->extract_path
+
+This is the directory the archive got extracted to.
+See C<extract()> for details.
+
+=head2 $ae->files
+
+This is an array ref holding all the paths from the archive.
+See C<extract()> for details.
+
+=head2 $ae->archive
+
+This is the full path to the archive file represented by this
+C<Archive::Extract> object.
+
+=head2 $ae->type
+
+This is the type of archive represented by this C<Archive::Extract>
+object. See accessors below for an easier way to use this.
+See the C<new()> method for details.
+
+=head2 $ae->types
+
+Returns a list of all known C<types> for C<Archive::Extract>'s
+C<new> method.
+
+=cut
+
+sub types { return @Types }
+
+=head2 $ae->is_tgz
+
+Returns true if the file is of type C<.tar.gz>.
+See the C<new()> method for details.
+
+=head2 $ae->is_tar
+
+Returns true if the file is of type C<.tar>.
+See the C<new()> method for details.
+
+=head2 $ae->is_gz
+
+Returns true if the file is of type C<.gz>.
+See the C<new()> method for details.
+
+=head2 $ae->is_Z
+
+Returns true if the file is of type C<.Z>.
+See the C<new()> method for details.
+
+=head2 $ae->is_zip
+
+Returns true if the file is of type C<.zip>.
+See the C<new()> method for details.
+
+=head2 $ae->is_lzma
+
+Returns true if the file is of type C<.lzma>.
+See the C<new()> method for details.
+
+=cut
+
+### quick check methods ###
+sub is_tgz { return $_[0]->type eq TGZ }
+sub is_tar { return $_[0]->type eq TAR }
+sub is_gz { return $_[0]->type eq GZ }
+sub is_zip { return $_[0]->type eq ZIP }
+sub is_tbz { return $_[0]->type eq TBZ }
+sub is_bz2 { return $_[0]->type eq BZ2 }
+sub is_Z { return $_[0]->type eq Z }
+sub is_lzma { return $_[0]->type eq LZMA }
+
+=pod
+
+=head2 $ae->bin_tar
+
+Returns the full path to your tar binary, if found.
+
+=head2 $ae->bin_gzip
+
+Returns the full path to your gzip binary, if found
+
+=head2 $ae->bin_unzip
+
+Returns the full path to your unzip binary, if found
+
+=head2 $ae->bin_unlzma
+
+Returns the full path to your unlzma binary, if found
+
+=cut
+
+### paths to commandline tools ###
+sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} }
+sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} }
+sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} }
+sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
+sub bin_uncompress { return $PROGRAMS->{'uncompress'}
+ if $PROGRAMS->{'uncompress'} }
+sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} }
+
+=head2 $bool = $ae->have_old_bunzip2
+
+Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
+require all archive names to end in C<.bz2> or it will not extract
+them. This method checks if you have a recent version of C<bunzip2>
+that allows any extension, or an older one that doesn't.
+
+=cut
+
+sub have_old_bunzip2 {
+ my $self = shift;
+
+ ### no bunzip2? no old bunzip2 either :)
+ return unless $self->bin_bunzip2;
+
+ ### if we can't run this, we can't be sure if it's too old or not
+ ### XXX stupid stupid stupid bunzip2 doesn't understand --version
+ ### is not a request to extract data:
+ ### $ bunzip2 --version
+ ### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001.
+ ### [...]
+ ### bunzip2: I won't read compressed data from a terminal.
+ ### bunzip2: For help, type: `bunzip2 --help'.
+ ### $ echo $?
+ ### 1
+ ### HATEFUL!
+
+ ### double hateful: bunzip2 --version also hangs if input is a pipe
+ ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH]
+ ### So, we have to provide *another* argument which is a fake filename,
+ ### just so it wont try to read from stdin to print its version..
+ ### *sigh*
+ ### Even if the file exists, it won't clobber or change it.
+ my $buffer;
+ scalar run(
+ command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
+ verbose => 0,
+ buffer => \$buffer
+ );
+
+ ### no output
+ return unless $buffer;
+
+ my ($version) = $buffer =~ /version \s+ (\d+)/ix;
+
+ return 1 if $version < 1;
+ return;
+}
+
+#################################
+#
+# Untar code
+#
+#################################
+
+### annoying issue with (gnu) tar on win32, as illustrated by this
+### bug: https://rt.cpan.org/Ticket/Display.html?id=40138
+### which shows that (gnu) tar will interpret a file name with a :
+### in it as a remote file name, so C:\tmp\foo.txt is interpreted
+### as a remote shell, and the extract fails.
+{ my @ExtraTarFlags;
+ if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) {
+
+ ### if this is gnu tar we are running, we need to use --force-local
+ push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i;
+ }
+
+
+ ### use /bin/tar to extract ###
+ sub _untar_bin {
+ my $self = shift;
+
+ ### check for /bin/tar ###
+ ### check for /bin/gzip if we need it ###
+ ### if any of the binaries are not available, return NA
+ { my $diag = not $self->bin_tar ?
+ loc("No '%1' program found", '/bin/tar') :
+ $self->is_tgz && !$self->bin_gzip ?
+ loc("No '%1' program found", '/bin/gzip') :
+ $self->is_tbz && !$self->bin_bunzip2 ?
+ loc("No '%1' program found", '/bin/bunzip2') :
+ '';
+
+ if( $diag ) {
+ $self->_error( $diag );
+ return METHOD_NA;
+ }
+ }
+
+ ### XXX figure out how to make IPC::Run do this in one call --
+ ### currently i don't know how to get output of a command after a pipe
+ ### trapped in a scalar. Mailed barries about this 5th of june 2004.
+
+ ### see what command we should run, based on whether
+ ### it's a .tgz or .tar
+
+ ### XXX solaris tar and bsdtar are having different outputs
+ ### depending whether you run with -x or -t
+ ### compensate for this insanity by running -t first, then -x
+ { my $cmd =
+ $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
+ $self->bin_tar, '-tf', '-'] :
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
+ $self->bin_tar, '-tf', '-'] :
+ [$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive];
+
+ ### run the command
+ ### newer versions of 'tar' (1.21 and up) now print record size
+ ### to STDERR as well if v OR t is given (used to be both). This
+ ### is a 'feature' according to the changelog, so we must now only
+ ### inspect STDOUT, otherwise, failures like these occur:
+ ### nntp.perl.org/group/perl.cpan.testers/2009/02/msg3230366.html
+ my $buffer = '';
+ my @out = run( command => $cmd,
+ buffer => \$buffer,
+ verbose => $DEBUG );
+
+ ### command was unsuccessful
+ unless( $out[0] ) {
+ return $self->_error(loc(
+ "Error listing contents of archive '%1': %2",
+ $self->archive, $buffer ));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_files( $self->archive ) );
+
+ } else {
+ ### if we're on solaris we /might/ be using /bin/tar, which has
+ ### a weird output format... we might also be using
+ ### /usr/local/bin/tar, which is gnu tar, which is perfectly
+ ### fine... so we have to do some guessing here =/
+ my @files = map { chomp;
+ !ON_SOLARIS ? $_
+ : (m|^ x \s+ # 'xtract' -- sigh
+ (.+?), # the actual file name
+ \s+ [\d,.]+ \s bytes,
+ \s+ [\d,.]+ \s tape \s blocks
+ |x ? $1 : $_);
+
+ ### only STDOUT, see above. Sometims, extra whitespace
+ ### is present, so make sure we only pick lines with
+ ### a length
+ } grep { length } map { split $/, $_ } @{$out[3]};
+
+ ### store the files that are in the archive ###
+ $self->files(\@files);
+ }
+ }
+
+ ### now actually extract it ###
+ { my $cmd =
+ $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
+ $self->bin_tar, '-xf', '-'] :
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
+ $self->bin_tar, '-xf', '-'] :
+ [$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive];
+
+ my $buffer = '';
+ unless( scalar run( command => $cmd,
+ buffer => \$buffer,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Error extracting archive '%1': %2",
+ $self->archive, $buffer ));
+ }
+
+ ### we might not have them, due to lack of buffers
+ if( $self->files ) {
+ ### now that we've extracted, figure out where we extracted to
+ my $dir = $self->__get_extract_dir( $self->files );
+
+ ### store the extraction dir ###
+ $self->extract_path( $dir );
+ }
+ }
+
+ ### we got here, no error happened
+ return 1;
+ }
+}
+
+
+### use archive::tar to extract ###
+sub _untar_at {
+ my $self = shift;
+
+ ### Loading Archive::Tar is going to set it to 1, so make it local
+ ### within this block, starting with its initial value. Whatever
+ ### Achive::Tar does will be undone when we return.
+ ###
+ ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN
+ ### so users don't have to even think about this variable. If they
+ ### do, they still get their set value outside of this call.
+ local $Archive::Tar::WARN = $Archive::Tar::WARN;
+
+ ### we definitely need Archive::Tar, so load that first
+ { my $use_list = { 'Archive::Tar' => '0.0' };
+
+ unless( can_load( modules => $use_list ) ) {
+
+ $self->_error(loc("You do not have '%1' installed - " .
+ "Please install it as soon as possible.",
+ 'Archive::Tar'));
+
+ return METHOD_NA;
+ }
+ }
+
+ ### we might pass it a filehandle if it's a .tbz file..
+ my $fh_to_read = $self->archive;
+
+ ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib
+ ### if A::T's version is 0.99 or higher
+ if( $self->is_tgz ) {
+ my $use_list = { 'Compress::Zlib' => '0.0' };
+ $use_list->{ 'IO::Zlib' } = '0.0'
+ if $Archive::Tar::VERSION >= '0.99';
+
+ unless( can_load( modules => $use_list ) ) {
+ my $which = join '/', sort keys %$use_list;
+
+ $self->_error(loc(
+ "You do not have '%1' installed - Please ".
+ "install it as soon as possible.", $which)
+ );
+
+ return METHOD_NA;
+ }
+
+ } elsif ( $self->is_tbz ) {
+ my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc(
+ "You do not have '%1' installed - Please " .
+ "install it as soon as possible.",
+ 'IO::Uncompress::Bunzip2')
+ );
+
+ return METHOD_NA;
+ }
+
+ my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
+ return $self->_error(loc("Unable to open '%1': %2",
+ $self->archive,
+ $IO::Uncompress::Bunzip2::Bunzip2Error));
+
+ $fh_to_read = $bz;
+ }
+
+ my @files;
+ {
+ ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
+ ### localized $Archive::Tar::WARN already.
+ $Archive::Tar::WARN = $Archive::Extract::WARN;
+
+ ### only tell it it's compressed if it's a .tgz, as we give it a file
+ ### handle if it's a .tbz
+ my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) );
+
+ ### for version of Archive::Tar > 1.04
+ local $Archive::Tar::CHOWN = 0;
+
+ ### use the iterator if we can. it's a feature of A::T 1.40 and up
+ if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) {
+
+ my $next;
+ unless ( $next = Archive::Tar->iter( @read ) ) {
+ return $self->_error(loc(
+ "Unable to read '%1': %2", $self->archive,
+ $Archive::Tar::error));
+ }
+
+ while ( my $file = $next->() ) {
+ push @files, $file->full_path;
+
+ $file->extract or return $self->_error(loc(
+ "Unable to read '%1': %2",
+ $self->archive,
+ $Archive::Tar::error));
+ }
+
+ ### older version, read the archive into memory
+ } else {
+
+ my $tar = Archive::Tar->new();
+
+ unless( $tar->read( @read ) ) {
+ return $self->_error(loc("Unable to read '%1': %2",
+ $self->archive, $Archive::Tar::error));
+ }
+
+ ### workaround to prevent Archive::Tar from setting uid, which
+ ### is a potential security hole. -autrijus
+ ### have to do it here, since A::T needs to be /loaded/ first ###
+ { no strict 'refs'; local $^W;
+
+ ### older versions of archive::tar <= 0.23
+ *Archive::Tar::chown = sub {};
+ }
+
+ { local $^W; # quell 'splice() offset past end of array' warnings
+ # on older versions of A::T
+
+ ### older archive::tar always returns $self, return value
+ ### slightly fux0r3d because of it.
+ $tar->extract or return $self->_error(loc(
+ "Unable to extract '%1': %2",
+ $self->archive, $Archive::Tar::error ));
+ }
+
+ @files = $tar->list_files;
+ }
+ }
+
+ my $dir = $self->__get_extract_dir( \@files );
+
+ ### store the files that are in the archive ###
+ $self->files(\@files);
+
+ ### store the extraction dir ###
+ $self->extract_path( $dir );
+
+ ### check if the dir actually appeared ###
+ return 1 if -d $self->extract_path;
+
+ ### no dir, we failed ###
+ return $self->_error(loc("Unable to extract '%1': %2",
+ $self->archive, $Archive::Tar::error ));
+}
+
+#################################
+#
+# Gunzip code
+#
+#################################
+
+sub _gunzip_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip -- we need it ###
+ unless( $self->bin_gzip ) {
+ $self->_error(loc("No '%1' program found", '/bin/gzip'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to gunzip '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+sub _gunzip_cz {
+ my $self = shift;
+
+ my $use_list = { 'Compress::Zlib' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Compress::Zlib'));
+ return METHOD_NA;
+ }
+
+ my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or
+ return $self->_error(loc("Unable to open '%1': %2",
+ $self->archive, $Compress::Zlib::gzerrno));
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $buffer;
+ $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0;
+ $fh->close;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+#################################
+#
+# Uncompress code
+#
+#################################
+
+sub _uncompress_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip -- we need it ###
+ unless( $self->bin_uncompress ) {
+ $self->_error(loc("No '%1' program found", '/bin/uncompress'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $cmd = [ $self->bin_uncompress, '-c', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to uncompress '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+
+#################################
+#
+# Unzip code
+#
+#################################
+
+
+sub _unzip_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip if we need it ###
+ unless( $self->bin_unzip ) {
+ $self->_error(loc("No '%1' program found", '/bin/unzip'));
+ return METHOD_NA;
+ }
+
+ ### first, get the files.. it must be 2 different commands with 'unzip' :(
+ { ### on VMS, capital letter options have to be quoted. This is
+ ### peported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11
+ ### Subject: [patch@31735]Archive Extract fix on VMS.
+ my $opt = ON_VMS ? '"-Z"' : '-Z';
+ my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ];
+
+ my $buffer = '';
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to unzip '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_files( $self->archive ) );
+
+ } else {
+ $self->files( [split $/, $buffer] );
+ }
+ }
+
+ ### now, extract the archive ###
+ { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to unzip '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ if( scalar @{$self->files} ) {
+ my $files = $self->files;
+ my $dir = $self->__get_extract_dir( $files );
+
+ $self->extract_path( $dir );
+ }
+ }
+
+ return 1;
+}
+
+sub _unzip_az {
+ my $self = shift;
+
+ my $use_list = { 'Archive::Zip' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Archive::Zip'));
+ return METHOD_NA;
+ }
+
+ my $zip = Archive::Zip->new();
+
+ unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) {
+ return $self->_error(loc("Unable to read '%1'", $self->archive));
+ }
+
+ my @files;
+
+
+ ### Address: #43278: Explicitly tell Archive::Zip where to put the files:
+ ### "In my BackPAN indexing, Archive::Zip was extracting things
+ ### in my script's directory instead of the current working directory.
+ ### I traced this back through Archive::Zip::_asLocalName which
+ ### eventually calls File::Spec::Win32::rel2abs which on Windows might
+ ### call Cwd::getdcwd. getdcwd returns the wrong directory in my
+ ### case, even though I think I'm on the same drive.
+ ###
+ ### To fix this, I pass the optional second argument to
+ ### extractMember using the cwd from Archive::Extract." --bdfoy
+
+ ## store cwd() before looping; calls to cwd() can be expensive, and
+ ### it won't change during the loop
+ my $extract_dir = cwd();
+
+ ### have to extract every member individually ###
+ for my $member ($zip->members) {
+ push @files, $member->{fileName};
+
+ ### file to extact to, to avoid the above problem
+ my $to = File::Spec->catfile( $extract_dir, $member->{fileName} );
+
+ unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) {
+ return $self->_error(loc("Extraction of '%1' from '%2' failed",
+ $member->{fileName}, $self->archive ));
+ }
+ }
+
+ my $dir = $self->__get_extract_dir( \@files );
+
+ ### set what files where extract, and where they went ###
+ $self->files( \@files );
+ $self->extract_path( File::Spec->rel2abs($dir) );
+
+ return 1;
+}
+
+sub __get_extract_dir {
+ my $self = shift;
+ my $files = shift || [];
+
+ return unless scalar @$files;
+
+ my($dir1, $dir2);
+ for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
+ my($dir,$pos) = @$aref;
+
+ ### add a catdir(), so that any trailing slashes get
+ ### take care of (removed)
+ ### also, a catdir() normalises './dir/foo' to 'dir/foo';
+ ### which was the problem in bug #23999
+ my $res = -d $files->[$pos]
+ ? File::Spec->catdir( $files->[$pos], '' )
+ : File::Spec->catdir( dirname( $files->[$pos] ) );
+
+ $$dir = $res;
+ }
+
+ ### if the first and last dir don't match, make sure the
+ ### dirname is not set wrongly
+ my $dir;
+
+ ### dirs are the same, so we know for sure what the extract dir is
+ if( $dir1 eq $dir2 ) {
+ $dir = $dir1;
+
+ ### dirs are different.. do they share the base dir?
+ ### if so, use that, if not, fall back to '.'
+ } else {
+ my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
+ my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
+
+ $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
+ }
+
+ return File::Spec->rel2abs( $dir );
+}
+
+#################################
+#
+# Bunzip2 code
+#
+#################################
+
+sub _bunzip2_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip -- we need it ###
+ unless( $self->bin_bunzip2 ) {
+ $self->_error(loc("No '%1' program found", '/bin/bunzip2'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ ### guard against broken bunzip2. See ->have_old_bunzip2()
+ ### for details
+ if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) {
+ return $self->_error(loc("Your bunzip2 version is too old and ".
+ "can only extract files ending in '%1'",
+ '.bz2'));
+ }
+
+ my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to bunzip2 '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+### using cz2, the compact versions... this we use mainly in archive::tar
+### extractor..
+# sub _bunzip2_cz1 {
+# my $self = shift;
+#
+# my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
+# unless( can_load( modules => $use_list ) ) {
+# return $self->_error(loc("You do not have '%1' installed - Please " .
+# "install it as soon as possible.",
+# 'IO::Uncompress::Bunzip2'));
+# }
+#
+# my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
+# return $self->_error(loc("Unable to open '%1': %2",
+# $self->archive,
+# $IO::Uncompress::Bunzip2::Bunzip2Error));
+#
+# my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+# return $self->_error(loc("Could not open '%1' for writing: %2",
+# $self->_gunzip_to, $! ));
+#
+# my $buffer;
+# $fh->print($buffer) while $bz->read($buffer) > 0;
+# $fh->close;
+#
+# ### set what files where extract, and where they went ###
+# $self->files( [$self->_gunzip_to] );
+# $self->extract_path( File::Spec->rel2abs(cwd()) );
+#
+# return 1;
+# }
+
+sub _bunzip2_bz2 {
+ my $self = shift;
+
+ my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.",
+ 'IO::Uncompress::Bunzip2'));
+ return METHOD_NA;
+ }
+
+ IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to)
+ or return $self->_error(loc("Unable to uncompress '%1': %2",
+ $self->archive,
+ $IO::Uncompress::Bunzip2::Bunzip2Error));
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+
+#################################
+#
+# unlzma code
+#
+#################################
+
+sub _unlzma_bin {
+ my $self = shift;
+
+ ### check for /bin/unlzma -- we need it ###
+ unless( $self->bin_unlzma ) {
+ $self->_error(loc("No '%1' program found", '/bin/unlzma'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $cmd = [ $self->bin_unlzma, '-c', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to unlzma '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+sub _unlzma_cz {
+ my $self = shift;
+
+ my $use_list = { 'Compress::unLZMA' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Compress::unLZMA'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $buffer;
+ $buffer = Compress::unLZMA::uncompressfile( $self->archive );
+ unless ( defined $buffer ) {
+ return $self->_error(loc("Could not unlzma '%1': %2",
+ $self->archive, $@));
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+#################################
+#
+# Error code
+#
+#################################
+
+# For printing binaries that avoids interfering globals
+sub _print {
+ my $self = shift;
+ my $fh = shift;
+
+ local( $\, $", $, ) = ( undef, ' ', '' );
+ return print $fh @_;
+}
+
+sub _error {
+ my $self = shift;
+ my $error = shift;
+ my $lerror = Carp::longmess($error);
+
+ push @{$self->_error_msg}, $error;
+ push @{$self->_error_msg_long}, $lerror;
+
+ ### set $Archive::Extract::WARN to 0 to disable printing
+ ### of errors
+ if( $WARN ) {
+ carp $DEBUG ? $lerror : $error;
+ }
+
+ return;
+}
+
+sub error {
+ my $self = shift;
+
+ ### make sure we have a fallback aref
+ my $aref = do {
+ shift()
+ ? $self->_error_msg_long
+ : $self->_error_msg
+ } || [];
+
+ return join $/, @$aref;
+}
+
+sub _no_buffer_files {
+ my $self = shift;
+ my $file = shift or return;
+ return loc("No buffer captured, unable to tell ".
+ "extracted files or extraction dir for '%1'", $file);
+}
+
+sub _no_buffer_content {
+ my $self = shift;
+ my $file = shift or return;
+ return loc("No buffer captured, unable to get content for '%1'", $file);
+}
+1;
+
+=pod
+
+=head1 HOW IT WORKS
+
+C<Archive::Extract> tries first to determine what type of archive you
+are passing it, by inspecting its suffix. It does not do this by using
+Mime magic, or something related. See C<CAVEATS> below.
+
+Once it has determined the file type, it knows which extraction methods
+it can use on the archive. It will try a perl solution first, then fall
+back to a commandline tool if that fails. If that also fails, it will
+return false, indicating it was unable to extract the archive.
+See the section on C<GLOBAL VARIABLES> to see how to alter this order.
+
+=head1 CAVEATS
+
+=head2 File Extensions
+
+C<Archive::Extract> trusts on the extension of the archive to determine
+what type it is, and what extractor methods therefore can be used. If
+your archives do not have any of the extensions as described in the
+C<new()> method, you will have to specify the type explicitly, or
+C<Archive::Extract> will not be able to extract the archive for you.
+
+=head2 Supporting Very Large Files
+
+C<Archive::Extract> can use either pure perl modules or command line
+programs under the hood. Some of the pure perl modules (like
+C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory,
+which may not be feasible on your system. Consider setting the global
+variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
+the use of command line programs and won't consume so much memory.
+
+See the C<GLOBAL VARIABLES> section below for details.
+
+=head2 Bunzip2 support of arbitrary extensions.
+
+Older versions of C</bin/bunzip2> do not support arbitrary file
+extensions and insist on a C<.bz2> suffix. Although we do our best
+to guard against this, if you experience a bunzip2 error, it may
+be related to this. For details, please see the C<have_old_bunzip2>
+method.
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Archive::Extract::DEBUG
+
+Set this variable to C<true> to have all calls to command line tools
+be printed out, including all their output.
+This also enables C<Carp::longmess> errors, instead of the regular
+C<carp> errors.
+
+Good for tracking down why things don't work with your particular
+setup.
+
+Defaults to C<false>.
+
+=head2 $Archive::Extract::WARN
+
+This variable controls whether errors encountered internally by
+C<Archive::Extract> should be C<carp>'d or not.
+
+Set to false to silence warnings. Inspect the output of the C<error()>
+method manually to see what went wrong.
+
+Defaults to C<true>.
+
+=head2 $Archive::Extract::PREFER_BIN
+
+This variables controls whether C<Archive::Extract> should prefer the
+use of perl modules, or commandline tools to extract archives.
+
+Set to C<true> to have C<Archive::Extract> prefer commandline tools.
+
+Defaults to C<false>.
+
+=head1 TODO / CAVEATS
+
+=over 4
+
+=item Mime magic support
+
+Maybe this module should use something like C<File::Type> to determine
+the type, rather than blindly trust the suffix.
+
+=item Thread safety
+
+Currently, C<Archive::Extract> does a C<chdir> to the extraction dir before
+extraction, and a C<chdir> back again after. This is not necessarily
+thread safe. See C<rt.cpan.org> bug C<#45671> for details.
+
+=back
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Tar.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Tar.pm
new file mode 100755
index 00000000000..006edbd5c3e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Tar.pm
@@ -0,0 +1,2146 @@
+### the gnu tar specification:
+### http://www.gnu.org/software/tar/manual/tar.html
+###
+### and the pax format spec, which tar derives from:
+### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html
+
+package Archive::Tar;
+require 5.005_03;
+
+use Cwd;
+use IO::Zlib;
+use IO::File;
+use Carp qw(carp croak);
+use File::Spec ();
+use File::Spec::Unix ();
+use File::Path ();
+
+use Archive::Tar::File;
+use Archive::Tar::Constant;
+
+require Exporter;
+
+use strict;
+use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
+ $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS
+ $INSECURE_EXTRACT_MODE @ISA @EXPORT
+ ];
+
+@ISA = qw[Exporter];
+@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP ];
+$DEBUG = 0;
+$WARN = 1;
+$FOLLOW_SYMLINK = 0;
+$VERSION = "1.54";
+$CHOWN = 1;
+$CHMOD = 1;
+$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
+$DO_NOT_USE_PREFIX = 0;
+$INSECURE_EXTRACT_MODE = 0;
+
+BEGIN {
+ use Config;
+ $HAS_PERLIO = $Config::Config{useperlio};
+
+ ### try and load IO::String anyway, so you can dynamically
+ ### switch between perlio and IO::String
+ $HAS_IO_STRING = eval {
+ require IO::String;
+ import IO::String;
+ 1;
+ } || 0;
+}
+
+=head1 NAME
+
+Archive::Tar - module for manipulations of tar archives
+
+=head1 SYNOPSIS
+
+ use Archive::Tar;
+ my $tar = Archive::Tar->new;
+
+ $tar->read('origin.tgz');
+ $tar->extract();
+
+ $tar->add_files('file/foo.pl', 'docs/README');
+ $tar->add_data('file/baz.txt', 'This is the contents now');
+
+ $tar->rename('oldname', 'new/file/name');
+
+ $tar->write('files.tar'); # plain tar
+ $tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed
+ $tar->write('files.tbz', COMPRESS_BZIP); # bzip2 compressed
+
+=head1 DESCRIPTION
+
+Archive::Tar provides an object oriented mechanism for handling tar
+files. It provides class methods for quick and easy files handling
+while also allowing for the creation of tar file objects for custom
+manipulation. If you have the IO::Zlib module installed,
+Archive::Tar will also support compressed or gzipped tar files.
+
+An object of class Archive::Tar represents a .tar(.gz) archive full
+of files and things.
+
+=head1 Object Methods
+
+=head2 Archive::Tar->new( [$file, $compressed] )
+
+Returns a new Tar object. If given any arguments, C<new()> calls the
+C<read()> method automatically, passing on the arguments provided to
+the C<read()> method.
+
+If C<new()> is invoked with arguments and the C<read()> method fails
+for any reason, C<new()> returns undef.
+
+=cut
+
+my $tmpl = {
+ _data => [ ],
+ _file => 'Unknown',
+};
+
+### install get/set accessors for this object.
+for my $key ( keys %$tmpl ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ my $self = shift;
+ $self->{$key} = $_[0] if @_;
+ return $self->{$key};
+ }
+}
+
+sub new {
+ my $class = shift;
+ $class = ref $class if ref $class;
+
+ ### copying $tmpl here since a shallow copy makes it use the
+ ### same aref, causing for files to remain in memory always.
+ my $obj = bless { _data => [ ], _file => 'Unknown', _error => '' }, $class;
+
+ if (@_) {
+ unless ( $obj->read( @_ ) ) {
+ $obj->_error(qq[No data could be read from file]);
+ return;
+ }
+ }
+
+ return $obj;
+}
+
+=head2 $tar->read ( $filename|$handle, [$compressed, {opt => 'val'}] )
+
+Read the given tar file into memory.
+The first argument can either be the name of a file or a reference to
+an already open filehandle (or an IO::Zlib object if it's compressed)
+
+The C<read> will I<replace> any previous content in C<$tar>!
+
+The second argument may be considered optional, but remains for
+backwards compatibility. Archive::Tar now looks at the file
+magic to determine what class should be used to open the file
+and will transparently Do The Right Thing.
+
+Archive::Tar will warn if you try to pass a bzip2 compressed file and the
+IO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return.
+
+Note that you can currently B<not> pass a C<gzip> compressed
+filehandle, which is not opened with C<IO::Zlib>, a C<bzip2> compressed
+filehandle, which is not opened with C<IO::Uncompress::Bunzip2>, nor a string
+containing the full archive information (either compressed or
+uncompressed). These are worth while features, but not currently
+implemented. See the C<TODO> section.
+
+The third argument can be a hash reference with options. Note that
+all options are case-sensitive.
+
+=over 4
+
+=item limit
+
+Do not read more than C<limit> files. This is useful if you have
+very big archives, and are only interested in the first few files.
+
+=item filter
+
+Can be set to a regular expression. Only files with names that match
+the expression will be read.
+
+=item extract
+
+If set to true, immediately extract entries when reading them. This
+gives you the same memory break as the C<extract_archive> function.
+Note however that entries will not be read into memory, but written
+straight to disk. This means no C<Archive::Tar::File> objects are
+created for you to inspect.
+
+=back
+
+All files are stored internally as C<Archive::Tar::File> objects.
+Please consult the L<Archive::Tar::File> documentation for details.
+
+Returns the number of files read in scalar context, and a list of
+C<Archive::Tar::File> objects in list context.
+
+=cut
+
+sub read {
+ my $self = shift;
+ my $file = shift;
+ my $gzip = shift || 0;
+ my $opts = shift || {};
+
+ unless( defined $file ) {
+ $self->_error( qq[No file to read from!] );
+ return;
+ } else {
+ $self->_file( $file );
+ }
+
+ my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) )
+ or return;
+
+ my $data = $self->_read_tar( $handle, $opts ) or return;
+
+ $self->_data( $data );
+
+ return wantarray ? @$data : scalar @$data;
+}
+
+sub _get_handle {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ return $file if ref $file;
+ my $compress = shift || 0;
+ my $mode = shift || READ_ONLY->( ZLIB ); # default to read only
+
+
+ ### get a FH opened to the right class, so we can use it transparently
+ ### throughout the program
+ my $fh;
+ { ### reading magic only makes sense if we're opening a file for
+ ### reading. otherwise, just use what the user requested.
+ my $magic = '';
+ if( MODE_READ->($mode) ) {
+ open my $tmp, $file or do {
+ $self->_error( qq[Could not open '$file' for reading: $!] );
+ return;
+ };
+
+ ### read the first 4 bites of the file to figure out which class to
+ ### use to open the file.
+ sysread( $tmp, $magic, 4 );
+ close $tmp;
+ }
+
+ ### is it bzip?
+ ### if you asked specifically for bzip compression, or if we're in
+ ### read mode and the magic numbers add up, use bzip
+ if( BZIP and (
+ ($compress eq COMPRESS_BZIP) or
+ ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM )
+ )
+ ) {
+
+ ### different reader/writer modules, different error vars... sigh
+ if( MODE_READ->($mode) ) {
+ $fh = IO::Uncompress::Bunzip2->new( $file ) or do {
+ $self->_error( qq[Could not read '$file': ] .
+ $IO::Uncompress::Bunzip2::Bunzip2Error
+ );
+ return;
+ };
+
+ } else {
+ $fh = IO::Compress::Bzip2->new( $file ) or do {
+ $self->_error( qq[Could not write to '$file': ] .
+ $IO::Compress::Bzip2::Bzip2Error
+ );
+ return;
+ };
+ }
+
+ ### is it gzip?
+ ### if you asked for compression, if you wanted to read or the gzip
+ ### magic number is present (redundant with read)
+ } elsif( ZLIB and (
+ $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM
+ )
+ ) {
+ $fh = IO::Zlib->new;
+
+ unless( $fh->open( $file, $mode ) ) {
+ $self->_error(qq[Could not create filehandle for '$file': $!]);
+ return;
+ }
+
+ ### is it plain tar?
+ } else {
+ $fh = IO::File->new;
+
+ unless( $fh->open( $file, $mode ) ) {
+ $self->_error(qq[Could not create filehandle for '$file': $!]);
+ return;
+ }
+
+ ### enable bin mode on tar archives
+ binmode $fh;
+ }
+ }
+
+ return $fh;
+}
+
+
+sub _read_tar {
+ my $self = shift;
+ my $handle = shift or return;
+ my $opts = shift || {};
+
+ my $count = $opts->{limit} || 0;
+ my $filter = $opts->{filter};
+ my $extract = $opts->{extract} || 0;
+
+ ### set a cap on the amount of files to extract ###
+ my $limit = 0;
+ $limit = 1 if $count > 0;
+
+ my $tarfile = [ ];
+ my $chunk;
+ my $read = 0;
+ my $real_name; # to set the name of a file when
+ # we're encountering @longlink
+ my $data;
+
+ LOOP:
+ while( $handle->read( $chunk, HEAD ) ) {
+ ### IO::Zlib doesn't support this yet
+ my $offset = eval { tell $handle } || 'unknown';
+
+ unless( $read++ ) {
+ my $gzip = GZIP_MAGIC_NUM;
+ if( $chunk =~ /$gzip/ ) {
+ $self->_error( qq[Cannot read compressed format in tar-mode] );
+ return;
+ }
+
+ ### size is < HEAD, which means a corrupted file, as the minimum
+ ### length is _at least_ HEAD
+ if (length $chunk != HEAD) {
+ $self->_error( qq[Cannot read enough bytes from the tarfile] );
+ return;
+ }
+ }
+
+ ### if we can't read in all bytes... ###
+ last if length $chunk != HEAD;
+
+ ### Apparently this should really be two blocks of 512 zeroes,
+ ### but GNU tar sometimes gets it wrong. See comment in the
+ ### source code (tar.c) to GNU cpio.
+ next if $chunk eq TAR_END;
+
+ ### according to the posix spec, the last 12 bytes of the header are
+ ### null bytes, to pad it to a 512 byte block. That means if these
+ ### bytes are NOT null bytes, it's a corrrupt header. See:
+ ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx
+ ### line 111
+ { my $nulls = join '', "\0" x 12;
+ unless( $nulls eq substr( $chunk, 500, 12 ) ) {
+ $self->_error( qq[Invalid header block at offset $offset] );
+ next LOOP;
+ }
+ }
+
+ ### pass the realname, so we can set it 'proper' right away
+ ### some of the heuristics are done on the name, so important
+ ### to set it ASAP
+ my $entry;
+ { my %extra_args = ();
+ $extra_args{'name'} = $$real_name if defined $real_name;
+
+ unless( $entry = Archive::Tar::File->new( chunk => $chunk,
+ %extra_args )
+ ) {
+ $self->_error( qq[Couldn't read chunk at offset $offset] );
+ next LOOP;
+ }
+ }
+
+ ### ignore labels:
+ ### http://www.gnu.org/manual/tar/html_node/tar_139.html
+ next if $entry->is_label;
+
+ if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) {
+
+ if ( $entry->is_file && !$entry->validate ) {
+ ### sometimes the chunk is rather fux0r3d and a whole 512
+ ### bytes ends up in the ->name area.
+ ### clean it up, if need be
+ my $name = $entry->name;
+ $name = substr($name, 0, 100) if length $name > 100;
+ $name =~ s/\n/ /g;
+
+ $self->_error( $name . qq[: checksum error] );
+ next LOOP;
+ }
+
+ my $block = BLOCK_SIZE->( $entry->size );
+
+ $data = $entry->get_content_by_ref;
+
+ ### just read everything into memory
+ ### can't do lazy loading since IO::Zlib doesn't support 'seek'
+ ### this is because Compress::Zlib doesn't support it =/
+ ### this reads in the whole data in one read() call.
+ if( $handle->read( $$data, $block ) < $block ) {
+ $self->_error( qq[Read error on tarfile (missing data) '].
+ $entry->full_path ."' at offset $offset" );
+ next LOOP;
+ }
+
+ ### throw away trailing garbage ###
+ substr ($$data, $entry->size) = "" if defined $$data;
+
+ ### part II of the @LongLink munging -- need to do /after/
+ ### the checksum check.
+ if( $entry->is_longlink ) {
+ ### weird thing in tarfiles -- if the file is actually a
+ ### @LongLink, the data part seems to have a trailing ^@
+ ### (unprintable) char. to display, pipe output through less.
+ ### but that doesn't *always* happen.. so check if the last
+ ### character is a control character, and if so remove it
+ ### at any rate, we better remove that character here, or tests
+ ### like 'eq' and hashlook ups based on names will SO not work
+ ### remove it by calculating the proper size, and then
+ ### tossing out everything that's longer than that size.
+
+ ### count number of nulls
+ my $nulls = $$data =~ tr/\0/\0/;
+
+ ### cut data + size by that many bytes
+ $entry->size( $entry->size - $nulls );
+ substr ($$data, $entry->size) = "";
+ }
+ }
+
+ ### clean up of the entries.. posix tar /apparently/ has some
+ ### weird 'feature' that allows for filenames > 255 characters
+ ### they'll put a header in with as name '././@LongLink' and the
+ ### contents will be the name of the /next/ file in the archive
+ ### pretty crappy and kludgy if you ask me
+
+ ### set the name for the next entry if this is a @LongLink;
+ ### this is one ugly hack =/ but needed for direct extraction
+ if( $entry->is_longlink ) {
+ $real_name = $data;
+ next LOOP;
+ } elsif ( defined $real_name ) {
+ $entry->name( $$real_name );
+ $entry->prefix('');
+ undef $real_name;
+ }
+
+ ### skip this entry if we're filtering
+ if ($filter && $entry->name !~ $filter) {
+ next LOOP;
+
+ ### skip this entry if it's a pax header. This is a special file added
+ ### by, among others, git-generated tarballs. It holds comments and is
+ ### not meant for extracting. See #38932: pax_global_header extracted
+ } elsif ( $entry->name eq PAX_HEADER ) {
+ next LOOP;
+ }
+
+ $self->_extract_file( $entry ) if $extract
+ && !$entry->is_longlink
+ && !$entry->is_unknown
+ && !$entry->is_label;
+
+ ### Guard against tarfiles with garbage at the end
+ last LOOP if $entry->name eq '';
+
+ ### push only the name on the rv if we're extracting
+ ### -- for extract_archive
+ push @$tarfile, ($extract ? $entry->name : $entry);
+
+ if( $limit ) {
+ $count-- unless $entry->is_longlink || $entry->is_dir;
+ last LOOP unless $count;
+ }
+ } continue {
+ undef $data;
+ }
+
+ return $tarfile;
+}
+
+=head2 $tar->contains_file( $filename )
+
+Check if the archive contains a certain file.
+It will return true if the file is in the archive, false otherwise.
+
+Note however, that this function does an exact match using C<eq>
+on the full path. So it cannot compensate for case-insensitive file-
+systems or compare 2 paths to see if they would point to the same
+underlying file.
+
+=cut
+
+sub contains_file {
+ my $self = shift;
+ my $full = shift;
+
+ return unless defined $full;
+
+ ### don't warn if the entry isn't there.. that's what this function
+ ### is for after all.
+ local $WARN = 0;
+ return 1 if $self->_find_entry($full);
+ return;
+}
+
+=head2 $tar->extract( [@filenames] )
+
+Write files whose names are equivalent to any of the names in
+C<@filenames> to disk, creating subdirectories as necessary. This
+might not work too well under VMS.
+Under MacPerl, the file's modification time will be converted to the
+MacOS zero of time, and appropriate conversions will be done to the
+path. However, the length of each element of the path is not
+inspected to see whether it's longer than MacOS currently allows (32
+characters).
+
+If C<extract> is called without a list of file names, the entire
+contents of the archive are extracted.
+
+Returns a list of filenames extracted.
+
+=cut
+
+sub extract {
+ my $self = shift;
+ my @args = @_;
+ my @files;
+
+ # use the speed optimization for all extracted files
+ local($self->{cwd}) = cwd() unless $self->{cwd};
+
+ ### you requested the extraction of only certian files
+ if( @args ) {
+ for my $file ( @args ) {
+
+ ### it's already an object?
+ if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
+ push @files, $file;
+ next;
+
+ ### go find it then
+ } else {
+
+ my $found;
+ for my $entry ( @{$self->_data} ) {
+ next unless $file eq $entry->full_path;
+
+ ### we found the file you're looking for
+ push @files, $entry;
+ $found++;
+ }
+
+ unless( $found ) {
+ return $self->_error(
+ qq[Could not find '$file' in archive] );
+ }
+ }
+ }
+
+ ### just grab all the file items
+ } else {
+ @files = $self->get_files;
+ }
+
+ ### nothing found? that's an error
+ unless( scalar @files ) {
+ $self->_error( qq[No files found for ] . $self->_file );
+ return;
+ }
+
+ ### now extract them
+ for my $entry ( @files ) {
+ unless( $self->_extract_file( $entry ) ) {
+ $self->_error(q[Could not extract ']. $entry->full_path .q['] );
+ return;
+ }
+ }
+
+ return @files;
+}
+
+=head2 $tar->extract_file( $file, [$extract_path] )
+
+Write an entry, whose name is equivalent to the file name provided to
+disk. Optionally takes a second parameter, which is the full native
+path (including filename) the entry will be written to.
+
+For example:
+
+ $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );
+
+ $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' );
+
+Returns true on success, false on failure.
+
+=cut
+
+sub extract_file {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ my $alt = shift;
+
+ my $entry = $self->_find_entry( $file )
+ or $self->_error( qq[Could not find an entry for '$file'] ), return;
+
+ return $self->_extract_file( $entry, $alt );
+}
+
+sub _extract_file {
+ my $self = shift;
+ my $entry = shift or return;
+ my $alt = shift;
+
+ ### you wanted an alternate extraction location ###
+ my $name = defined $alt ? $alt : $entry->full_path;
+
+ ### splitpath takes a bool at the end to indicate
+ ### that it's splitting a dir
+ my ($vol,$dirs,$file);
+ if ( defined $alt ) { # It's a local-OS path
+ ($vol,$dirs,$file) = File::Spec->splitpath( $alt,
+ $entry->is_dir );
+ } else {
+ ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name,
+ $entry->is_dir );
+ }
+
+ my $dir;
+ ### is $name an absolute path? ###
+ if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) {
+
+ ### absolute names are not allowed to be in tarballs under
+ ### strict mode, so only allow it if a user tells us to do it
+ if( not defined $alt and not $INSECURE_EXTRACT_MODE ) {
+ $self->_error(
+ q[Entry ']. $entry->full_path .q[' is an absolute path. ].
+ q[Not extracting absolute paths under SECURE EXTRACT MODE]
+ );
+ return;
+ }
+
+ ### user asked us to, it's fine.
+ $dir = File::Spec->catpath( $vol, $dirs, "" );
+
+ ### it's a relative path ###
+ } else {
+ my $cwd = (ref $self and defined $self->{cwd})
+ ? $self->{cwd}
+ : cwd();
+
+ my @dirs = defined $alt
+ ? File::Spec->splitdir( $dirs ) # It's a local-OS path
+ : File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely
+ # straight from the tarball
+
+ if( not defined $alt and
+ not $INSECURE_EXTRACT_MODE
+ ) {
+
+ ### paths that leave the current directory are not allowed under
+ ### strict mode, so only allow it if a user tells us to do this.
+ if( grep { $_ eq '..' } @dirs ) {
+
+ $self->_error(
+ q[Entry ']. $entry->full_path .q[' is attempting to leave ].
+ q[the current working directory. Not extracting under ].
+ q[SECURE EXTRACT MODE]
+ );
+ return;
+ }
+
+ ### the archive may be asking us to extract into a symlink. This
+ ### is not sane and a possible security issue, as outlined here:
+ ### https://rt.cpan.org/Ticket/Display.html?id=30380
+ ### https://bugzilla.redhat.com/show_bug.cgi?id=295021
+ ### https://issues.rpath.com/browse/RPL-1716
+ my $full_path = $cwd;
+ for my $d ( @dirs ) {
+ $full_path = File::Spec->catdir( $full_path, $d );
+
+ ### we've already checked this one, and it's safe. Move on.
+ next if ref $self and $self->{_link_cache}->{$full_path};
+
+ if( -l $full_path ) {
+ my $to = readlink $full_path;
+ my $diag = "symlinked directory ($full_path => $to)";
+
+ $self->_error(
+ q[Entry ']. $entry->full_path .q[' is attempting to ].
+ qq[extract to a $diag. This is considered a security ].
+ q[vulnerability and not allowed under SECURE EXTRACT ].
+ q[MODE]
+ );
+ return;
+ }
+
+ ### XXX keep a cache if possible, so the stats become cheaper:
+ $self->{_link_cache}->{$full_path} = 1 if ref $self;
+ }
+ }
+
+ ### '.' is the directory delimiter on VMS, which has to be escaped
+ ### or changed to '_' on vms. vmsify is used, because older versions
+ ### of vmspath do not handle this properly.
+ ### Must not add a '/' to an empty directory though.
+ map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS;
+
+ my ($cwd_vol,$cwd_dir,$cwd_file)
+ = File::Spec->splitpath( $cwd );
+ my @cwd = File::Spec->splitdir( $cwd_dir );
+ push @cwd, $cwd_file if length $cwd_file;
+
+ ### We need to pass '' as the last elemant to catpath. Craig Berry
+ ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
+ ### The root problem is that splitpath on UNIX always returns the
+ ### final path element as a file even if it is a directory, and of
+ ### course there is no way it can know the difference without checking
+ ### against the filesystem, which it is documented as not doing. When
+ ### you turn around and call catpath, on VMS you have to know which bits
+ ### are directory bits and which bits are file bits. In this case we
+ ### know the result should be a directory. I had thought you could omit
+ ### the file argument to catpath in such a case, but apparently on UNIX
+ ### you can't.
+ $dir = File::Spec->catpath(
+ $cwd_vol, File::Spec->catdir( @cwd, @dirs ), ''
+ );
+
+ ### catdir() returns undef if the path is longer than 255 chars on
+ ### older VMS systems.
+ unless ( defined $dir ) {
+ $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
+ return;
+ }
+
+ }
+
+ if( -e $dir && !-d _ ) {
+ $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
+ return;
+ }
+
+ unless ( -d _ ) {
+ eval { File::Path::mkpath( $dir, 0, 0777 ) };
+ if( $@ ) {
+ my $fp = $entry->full_path;
+ $self->_error(qq[Could not create directory '$dir' for '$fp': $@]);
+ return;
+ }
+
+ ### XXX chown here? that might not be the same as in the archive
+ ### as we're only chown'ing to the owner of the file we're extracting
+ ### not to the owner of the directory itself, which may or may not
+ ### be another entry in the archive
+ ### Answer: no, gnu tar doesn't do it either, it'd be the wrong
+ ### way to go.
+ #if( $CHOWN && CAN_CHOWN ) {
+ # chown $entry->uid, $entry->gid, $dir or
+ # $self->_error( qq[Could not set uid/gid on '$dir'] );
+ #}
+ }
+
+ ### we're done if we just needed to create a dir ###
+ return 1 if $entry->is_dir;
+
+ my $full = File::Spec->catfile( $dir, $file );
+
+ if( $entry->is_unknown ) {
+ $self->_error( qq[Unknown file type for file '$full'] );
+ return;
+ }
+
+ if( length $entry->type && $entry->is_file ) {
+ my $fh = IO::File->new;
+ $fh->open( '>' . $full ) or (
+ $self->_error( qq[Could not open file '$full': $!] ),
+ return
+ );
+
+ if( $entry->size ) {
+ binmode $fh;
+ syswrite $fh, $entry->data or (
+ $self->_error( qq[Could not write data to '$full'] ),
+ return
+ );
+ }
+
+ close $fh or (
+ $self->_error( qq[Could not close file '$full'] ),
+ return
+ );
+
+ } else {
+ $self->_make_special_file( $entry, $full ) or return;
+ }
+
+ ### only update the timestamp if it's not a symlink; that will change the
+ ### timestamp of the original. This addresses bug #33669: Could not update
+ ### timestamp warning on symlinks
+ if( not -l $full ) {
+ utime time, $entry->mtime - TIME_OFFSET, $full or
+ $self->_error( qq[Could not update timestamp] );
+ }
+
+ if( $CHOWN && CAN_CHOWN->() ) {
+ chown $entry->uid, $entry->gid, $full or
+ $self->_error( qq[Could not set uid/gid on '$full'] );
+ }
+
+ ### only chmod if we're allowed to, but never chmod symlinks, since they'll
+ ### change the perms on the file they're linking too...
+ if( $CHMOD and not -l $full ) {
+ my $mode = $entry->mode;
+ unless ($SAME_PERMISSIONS) {
+ $mode &= ~(oct(7000) | umask);
+ }
+ chmod $mode, $full or
+ $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
+ }
+
+ return 1;
+}
+
+sub _make_special_file {
+ my $self = shift;
+ my $entry = shift or return;
+ my $file = shift; return unless defined $file;
+
+ my $err;
+
+ if( $entry->is_symlink ) {
+ my $fail;
+ if( ON_UNIX ) {
+ symlink( $entry->linkname, $file ) or $fail++;
+
+ } else {
+ $self->_extract_special_file_as_plain_file( $entry, $file )
+ or $fail++;
+ }
+
+ $err = qq[Making symbolic link '$file' to '] .
+ $entry->linkname .q[' failed] if $fail;
+
+ } elsif ( $entry->is_hardlink ) {
+ my $fail;
+ if( ON_UNIX ) {
+ link( $entry->linkname, $file ) or $fail++;
+
+ } else {
+ $self->_extract_special_file_as_plain_file( $entry, $file )
+ or $fail++;
+ }
+
+ $err = qq[Making hard link from '] . $entry->linkname .
+ qq[' to '$file' failed] if $fail;
+
+ } elsif ( $entry->is_fifo ) {
+ ON_UNIX && !system('mknod', $file, 'p') or
+ $err = qq[Making fifo ']. $entry->name .qq[' failed];
+
+ } elsif ( $entry->is_blockdev or $entry->is_chardev ) {
+ my $mode = $entry->is_blockdev ? 'b' : 'c';
+
+ ON_UNIX && !system('mknod', $file, $mode,
+ $entry->devmajor, $entry->devminor) or
+ $err = qq[Making block device ']. $entry->name .qq[' (maj=] .
+ $entry->devmajor . qq[ min=] . $entry->devminor .
+ qq[) failed.];
+
+ } elsif ( $entry->is_socket ) {
+ ### the original doesn't do anything special for sockets.... ###
+ 1;
+ }
+
+ return $err ? $self->_error( $err ) : 1;
+}
+
+### don't know how to make symlinks, let's just extract the file as
+### a plain file
+sub _extract_special_file_as_plain_file {
+ my $self = shift;
+ my $entry = shift or return;
+ my $file = shift; return unless defined $file;
+
+ my $err;
+ TRY: {
+ my $orig = $self->_find_entry( $entry->linkname );
+
+ unless( $orig ) {
+ $err = qq[Could not find file '] . $entry->linkname .
+ qq[' in memory.];
+ last TRY;
+ }
+
+ ### clone the entry, make it appear as a normal file ###
+ my $clone = $entry->clone;
+ $clone->_downgrade_to_plainfile;
+ $self->_extract_file( $clone, $file ) or last TRY;
+
+ return 1;
+ }
+
+ return $self->_error($err);
+}
+
+=head2 $tar->list_files( [\@properties] )
+
+Returns a list of the names of all the files in the archive.
+
+If C<list_files()> is passed an array reference as its first argument
+it returns a list of hash references containing the requested
+properties of each file. The following list of properties is
+supported: name, size, mtime (last modified date), mode, uid, gid,
+linkname, uname, gname, devmajor, devminor, prefix.
+
+Passing an array reference containing only one element, 'name', is
+special cased to return a list of names rather than a list of hash
+references, making it equivalent to calling C<list_files> without
+arguments.
+
+=cut
+
+sub list_files {
+ my $self = shift;
+ my $aref = shift || [ ];
+
+ unless( $self->_data ) {
+ $self->read() or return;
+ }
+
+ if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
+ return map { $_->full_path } @{$self->_data};
+ } else {
+
+ #my @rv;
+ #for my $obj ( @{$self->_data} ) {
+ # push @rv, { map { $_ => $obj->$_() } @$aref };
+ #}
+ #return @rv;
+
+ ### this does the same as the above.. just needs a +{ }
+ ### to make sure perl doesn't confuse it for a block
+ return map { my $o=$_;
+ +{ map { $_ => $o->$_() } @$aref }
+ } @{$self->_data};
+ }
+}
+
+sub _find_entry {
+ my $self = shift;
+ my $file = shift;
+
+ unless( defined $file ) {
+ $self->_error( qq[No file specified] );
+ return;
+ }
+
+ ### it's an object already
+ return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
+
+ for my $entry ( @{$self->_data} ) {
+ my $path = $entry->full_path;
+ return $entry if $path eq $file;
+ }
+
+ $self->_error( qq[No such file in archive: '$file'] );
+ return;
+}
+
+=head2 $tar->get_files( [@filenames] )
+
+Returns the C<Archive::Tar::File> objects matching the filenames
+provided. If no filename list was passed, all C<Archive::Tar::File>
+objects in the current Tar object are returned.
+
+Please refer to the C<Archive::Tar::File> documentation on how to
+handle these objects.
+
+=cut
+
+sub get_files {
+ my $self = shift;
+
+ return @{ $self->_data } unless @_;
+
+ my @list;
+ for my $file ( @_ ) {
+ push @list, grep { defined } $self->_find_entry( $file );
+ }
+
+ return @list;
+}
+
+=head2 $tar->get_content( $file )
+
+Return the content of the named file.
+
+=cut
+
+sub get_content {
+ my $self = shift;
+ my $entry = $self->_find_entry( shift ) or return;
+
+ return $entry->data;
+}
+
+=head2 $tar->replace_content( $file, $content )
+
+Make the string $content be the content for the file named $file.
+
+=cut
+
+sub replace_content {
+ my $self = shift;
+ my $entry = $self->_find_entry( shift ) or return;
+
+ return $entry->replace_content( shift );
+}
+
+=head2 $tar->rename( $file, $new_name )
+
+Rename the file of the in-memory archive to $new_name.
+
+Note that you must specify a Unix path for $new_name, since per tar
+standard, all files in the archive must be Unix paths.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub rename {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ my $new = shift; return unless defined $new;
+
+ my $entry = $self->_find_entry( $file ) or return;
+
+ return $entry->rename( $new );
+}
+
+=head2 $tar->remove (@filenamelist)
+
+Removes any entries with names matching any of the given filenames
+from the in-memory archive. Returns a list of C<Archive::Tar::File>
+objects that remain.
+
+=cut
+
+sub remove {
+ my $self = shift;
+ my @list = @_;
+
+ my %seen = map { $_->full_path => $_ } @{$self->_data};
+ delete $seen{ $_ } for @list;
+
+ $self->_data( [values %seen] );
+
+ return values %seen;
+}
+
+=head2 $tar->clear
+
+C<clear> clears the current in-memory archive. This effectively gives
+you a 'blank' object, ready to be filled again. Note that C<clear>
+only has effect on the object, not the underlying tarfile.
+
+=cut
+
+sub clear {
+ my $self = shift or return;
+
+ $self->_data( [] );
+ $self->_file( '' );
+
+ return 1;
+}
+
+
+=head2 $tar->write ( [$file, $compressed, $prefix] )
+
+Write the in-memory archive to disk. The first argument can either
+be the name of a file or a reference to an already open filehandle (a
+GLOB reference).
+
+The second argument is used to indicate compression. You can either
+compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
+to be the C<gzip> compression level (between 1 and 9), but the use of
+constants is prefered:
+
+ # write a gzip compressed file
+ $tar->write( 'out.tgz', COMPRESS_GZIP );
+
+ # write a bzip compressed file
+ $tar->write( 'out.tbz', COMPRESS_BZIP );
+
+Note that when you pass in a filehandle, the compression argument
+is ignored, as all files are printed verbatim to your filehandle.
+If you wish to enable compression with filehandles, use an
+C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
+
+The third argument is an optional prefix. All files will be tucked
+away in the directory you specify as prefix. So if you have files
+'a' and 'b' in your archive, and you specify 'foo' as prefix, they
+will be written to the archive as 'foo/a' and 'foo/b'.
+
+If no arguments are given, C<write> returns the entire formatted
+archive as a string, which could be useful if you'd like to stuff the
+archive into a socket or a pipe to gzip or something.
+
+
+=cut
+
+sub write {
+ my $self = shift;
+ my $file = shift; $file = '' unless defined $file;
+ my $gzip = shift || 0;
+ my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
+ my $dummy = '';
+
+ ### only need a handle if we have a file to print to ###
+ my $handle = length($file)
+ ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
+ or return )
+ : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h }
+ : $HAS_IO_STRING ? IO::String->new
+ : __PACKAGE__->no_string_support();
+
+ ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a
+ ### corrupt TAR file. Must clear out $\ to make sure no garbage is
+ ### printed to the archive
+ local $\;
+
+ for my $entry ( @{$self->_data} ) {
+ ### entries to be written to the tarfile ###
+ my @write_me;
+
+ ### only now will we change the object to reflect the current state
+ ### of the name and prefix fields -- this needs to be limited to
+ ### write() only!
+ my $clone = $entry->clone;
+
+
+ ### so, if you don't want use to use the prefix, we'll stuff
+ ### everything in the name field instead
+ if( $DO_NOT_USE_PREFIX ) {
+
+ ### you might have an extended prefix, if so, set it in the clone
+ ### XXX is ::Unix right?
+ $clone->name( length $ext_prefix
+ ? File::Spec::Unix->catdir( $ext_prefix,
+ $clone->full_path)
+ : $clone->full_path );
+ $clone->prefix( '' );
+
+ ### otherwise, we'll have to set it properly -- prefix part in the
+ ### prefix and name part in the name field.
+ } else {
+
+ ### split them here, not before!
+ my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path );
+
+ ### you might have an extended prefix, if so, set it in the clone
+ ### XXX is ::Unix right?
+ $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix )
+ if length $ext_prefix;
+
+ $clone->prefix( $prefix );
+ $clone->name( $name );
+ }
+
+ ### names are too long, and will get truncated if we don't add a
+ ### '@LongLink' file...
+ my $make_longlink = ( length($clone->name) > NAME_LENGTH or
+ length($clone->prefix) > PREFIX_LENGTH
+ ) || 0;
+
+ ### perhaps we need to make a longlink file?
+ if( $make_longlink ) {
+ my $longlink = Archive::Tar::File->new(
+ data => LONGLINK_NAME,
+ $clone->full_path,
+ { type => LONGLINK }
+ );
+
+ unless( $longlink ) {
+ $self->_error( qq[Could not create 'LongLink' entry for ] .
+ qq[oversize file '] . $clone->full_path ."'" );
+ return;
+ };
+
+ push @write_me, $longlink;
+ }
+
+ push @write_me, $clone;
+
+ ### write the one, optionally 2 a::t::file objects to the handle
+ for my $clone (@write_me) {
+
+ ### if the file is a symlink, there are 2 options:
+ ### either we leave the symlink intact, but then we don't write any
+ ### data OR we follow the symlink, which means we actually make a
+ ### copy. if we do the latter, we have to change the TYPE of the
+ ### clone to 'FILE'
+ my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK;
+ my $data_ok = !$clone->is_symlink && $clone->has_content;
+
+ ### downgrade to a 'normal' file if it's a symlink we're going to
+ ### treat as a regular file
+ $clone->_downgrade_to_plainfile if $link_ok;
+
+ ### get the header for this block
+ my $header = $self->_format_tar_entry( $clone );
+ unless( $header ) {
+ $self->_error(q[Could not format header for: ] .
+ $clone->full_path );
+ return;
+ }
+
+ unless( print $handle $header ) {
+ $self->_error(q[Could not write header for: ] .
+ $clone->full_path);
+ return;
+ }
+
+ if( $link_ok or $data_ok ) {
+ unless( print $handle $clone->data ) {
+ $self->_error(q[Could not write data for: ] .
+ $clone->full_path);
+ return;
+ }
+
+ ### pad the end of the clone if required ###
+ print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK
+ }
+
+ } ### done writing these entries
+ }
+
+ ### write the end markers ###
+ print $handle TAR_END x 2 or
+ return $self->_error( qq[Could not write tar end markers] );
+
+ ### did you want it written to a file, or returned as a string? ###
+ my $rv = length($file) ? 1
+ : $HAS_PERLIO ? $dummy
+ : do { seek $handle, 0, 0; local $/; <$handle> };
+
+ ### make sure to close the handle;
+ close $handle;
+
+ return $rv;
+}
+
+sub _format_tar_entry {
+ my $self = shift;
+ my $entry = shift or return;
+ my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
+ my $no_prefix = shift || 0;
+
+ my $file = $entry->name;
+ my $prefix = $entry->prefix; $prefix = '' unless defined $prefix;
+
+ ### remove the prefix from the file name
+ ### not sure if this is still neeeded --kane
+ ### no it's not -- Archive::Tar::File->_new_from_file will take care of
+ ### this for us. Even worse, this would break if we tried to add a file
+ ### like x/x.
+ #if( length $prefix ) {
+ # $file =~ s/^$match//;
+ #}
+
+ $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix)
+ if length $ext_prefix;
+
+ ### not sure why this is... ###
+ my $l = PREFIX_LENGTH; # is ambiguous otherwise...
+ substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
+
+ my $f1 = "%06o"; my $f2 = "%11o";
+
+ ### this might be optimizable with a 'changed' flag in the file objects ###
+ my $tar = pack (
+ PACK,
+ $file,
+
+ (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
+ (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
+
+ "", # checksum field - space padded a bit down
+
+ (map { $entry->$_() } qw[type linkname magic]),
+
+ $entry->version || TAR_VERSION,
+
+ (map { $entry->$_() } qw[uname gname]),
+ (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
+
+ ($no_prefix ? '' : $prefix)
+ );
+
+ ### add the checksum ###
+ substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
+
+ return $tar;
+}
+
+=head2 $tar->add_files( @filenamelist )
+
+Takes a list of filenames and adds them to the in-memory archive.
+
+The path to the file is automatically converted to a Unix like
+equivalent for use in the archive, and, if on MacOS, the file's
+modification time is converted from the MacOS epoch to the Unix epoch.
+So tar archives created on MacOS with B<Archive::Tar> can be read
+both with I<tar> on Unix and applications like I<suntar> or
+I<Stuffit Expander> on MacOS.
+
+Be aware that the file's type/creator and resource fork will be lost,
+which is usually what you want in cross-platform archives.
+
+Instead of a filename, you can also pass it an existing C<Archive::Tar::File>
+object from, for example, another archive. The object will be clone, and
+effectively be a copy of the original, not an alias.
+
+Returns a list of C<Archive::Tar::File> objects that were just added.
+
+=cut
+
+sub add_files {
+ my $self = shift;
+ my @files = @_ or return;
+
+ my @rv;
+ for my $file ( @files ) {
+
+ ### you passed an Archive::Tar::File object
+ ### clone it so we don't accidentally have a reference to
+ ### an object from another archive
+ if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) {
+ push @rv, $file->clone;
+ next;
+ }
+
+ unless( -e $file || -l $file ) {
+ $self->_error( qq[No such file: '$file'] );
+ next;
+ }
+
+ my $obj = Archive::Tar::File->new( file => $file );
+ unless( $obj ) {
+ $self->_error( qq[Unable to add file: '$file'] );
+ next;
+ }
+
+ push @rv, $obj;
+ }
+
+ push @{$self->{_data}}, @rv;
+
+ return @rv;
+}
+
+=head2 $tar->add_data ( $filename, $data, [$opthashref] )
+
+Takes a filename, a scalar full of data and optionally a reference to
+a hash with specific options.
+
+Will add a file to the in-memory archive, with name C<$filename> and
+content C<$data>. Specific properties can be set using C<$opthashref>.
+The following list of properties is supported: name, size, mtime
+(last modified date), mode, uid, gid, linkname, uname, gname,
+devmajor, devminor, prefix, type. (On MacOS, the file's path and
+modification times are converted to Unix equivalents.)
+
+Valid values for the file type are the following constants defined in
+Archive::Tar::Constants:
+
+=over 4
+
+=item FILE
+
+Regular file.
+
+=item HARDLINK
+
+=item SYMLINK
+
+Hard and symbolic ("soft") links; linkname should specify target.
+
+=item CHARDEV
+
+=item BLOCKDEV
+
+Character and block devices. devmajor and devminor should specify the major
+and minor device numbers.
+
+=item DIR
+
+Directory.
+
+=item FIFO
+
+FIFO (named pipe).
+
+=item SOCKET
+
+Socket.
+
+=back
+
+Returns the C<Archive::Tar::File> object that was just added, or
+C<undef> on failure.
+
+=cut
+
+sub add_data {
+ my $self = shift;
+ my ($file, $data, $opt) = @_;
+
+ my $obj = Archive::Tar::File->new( data => $file, $data, $opt );
+ unless( $obj ) {
+ $self->_error( qq[Unable to add file: '$file'] );
+ return;
+ }
+
+ push @{$self->{_data}}, $obj;
+
+ return $obj;
+}
+
+=head2 $tar->error( [$BOOL] )
+
+Returns the current errorstring (usually, the last error reported).
+If a true value was specified, it will give the C<Carp::longmess>
+equivalent of the error, in effect giving you a stacktrace.
+
+For backwards compatibility, this error is also available as
+C<$Archive::Tar::error> although it is much recommended you use the
+method call instead.
+
+=cut
+
+{
+ $error = '';
+ my $longmess;
+
+ sub _error {
+ my $self = shift;
+ my $msg = $error = shift;
+ $longmess = Carp::longmess($error);
+ if (ref $self) {
+ $self->{_error} = $error;
+ $self->{_longmess} = $longmess;
+ }
+
+ ### set Archive::Tar::WARN to 0 to disable printing
+ ### of errors
+ if( $WARN ) {
+ carp $DEBUG ? $longmess : $msg;
+ }
+
+ return;
+ }
+
+ sub error {
+ my $self = shift;
+ if (ref $self) {
+ return shift() ? $self->{_longmess} : $self->{_error};
+ } else {
+ return shift() ? $longmess : $error;
+ }
+ }
+}
+
+=head2 $tar->setcwd( $cwd );
+
+C<Archive::Tar> needs to know the current directory, and it will run
+C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
+tarfile and saves it in the file system. (As of version 1.30, however,
+C<Archive::Tar> will use the speed optimization described below
+automatically, so it's only relevant if you're using C<extract_file()>).
+
+Since C<Archive::Tar> doesn't change the current directory internally
+while it is extracting the items in a tarball, all calls to C<Cwd::cwd()>
+can be avoided if we can guarantee that the current directory doesn't
+get changed externally.
+
+To use this performance boost, set the current directory via
+
+ use Cwd;
+ $tar->setcwd( cwd() );
+
+once before calling a function like C<extract_file> and
+C<Archive::Tar> will use the current directory setting from then on
+and won't call C<Cwd::cwd()> internally.
+
+To switch back to the default behaviour, use
+
+ $tar->setcwd( undef );
+
+and C<Archive::Tar> will call C<Cwd::cwd()> internally again.
+
+If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
+be called for you.
+
+=cut
+
+sub setcwd {
+ my $self = shift;
+ my $cwd = shift;
+
+ $self->{cwd} = $cwd;
+}
+
+=head1 Class Methods
+
+=head2 Archive::Tar->create_archive($file, $compressed, @filelist)
+
+Creates a tar file from the list of files provided. The first
+argument can either be the name of the tar file to create or a
+reference to an open file handle (e.g. a GLOB reference).
+
+The second argument is used to indicate compression. You can either
+compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
+to be the C<gzip> compression level (between 1 and 9), but the use of
+constants is prefered:
+
+ # write a gzip compressed file
+ Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist );
+
+ # write a bzip compressed file
+ Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist );
+
+Note that when you pass in a filehandle, the compression argument
+is ignored, as all files are printed verbatim to your filehandle.
+If you wish to enable compression with filehandles, use an
+C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
+
+The remaining arguments list the files to be included in the tar file.
+These files must all exist. Any files which don't exist or can't be
+read are silently ignored.
+
+If the archive creation fails for any reason, C<create_archive> will
+return false. Please use the C<error> method to find the cause of the
+failure.
+
+Note that this method does not write C<on the fly> as it were; it
+still reads all the files into memory before writing out the archive.
+Consult the FAQ below if this is a problem.
+
+=cut
+
+sub create_archive {
+ my $class = shift;
+
+ my $file = shift; return unless defined $file;
+ my $gzip = shift || 0;
+ my @files = @_;
+
+ unless( @files ) {
+ return $class->_error( qq[Cowardly refusing to create empty archive!] );
+ }
+
+ my $tar = $class->new;
+ $tar->add_files( @files );
+ return $tar->write( $file, $gzip );
+}
+
+=head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] )
+
+Returns an iterator function that reads the tar file without loading
+it all in memory. Each time the function is called it will return the
+next file in the tarball. The files are returned as
+C<Archive::Tar::File> objects. The iterator function returns the
+empty list once it has exhausted the files contained.
+
+The second argument can be a hash reference with options, which are
+identical to the arguments passed to C<read()>.
+
+Example usage:
+
+ my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} );
+
+ while( my $f = $next->() ) {
+ print $f->name, "\n";
+
+ $f->extract or warn "Extraction failed";
+
+ # ....
+ }
+
+=cut
+
+
+sub iter {
+ my $class = shift;
+ my $filename = shift or return;
+ my $compressed = shift or 0;
+ my $opts = shift || {};
+
+ ### get a handle to read from.
+ my $handle = $class->_get_handle(
+ $filename,
+ $compressed,
+ READ_ONLY->( ZLIB )
+ ) or return;
+
+ my @data;
+ return sub {
+ return shift(@data) if @data; # more than one file returned?
+ return unless $handle; # handle exhausted?
+
+ ### read data, should only return file
+ my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 });
+ @data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY';
+
+ ### return one piece of data
+ return shift(@data) if @data;
+
+ ### data is exhausted, free the filehandle
+ undef $handle;
+ return;
+ };
+}
+
+=head2 Archive::Tar->list_archive($file, $compressed, [\@properties])
+
+Returns a list of the names of all the files in the archive. The
+first argument can either be the name of the tar file to list or a
+reference to an open file handle (e.g. a GLOB reference).
+
+If C<list_archive()> is passed an array reference as its third
+argument it returns a list of hash references containing the requested
+properties of each file. The following list of properties is
+supported: full_path, name, size, mtime (last modified date), mode,
+uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
+
+See C<Archive::Tar::File> for details about supported properties.
+
+Passing an array reference containing only one element, 'name', is
+special cased to return a list of names rather than a list of hash
+references.
+
+=cut
+
+sub list_archive {
+ my $class = shift;
+ my $file = shift; return unless defined $file;
+ my $gzip = shift || 0;
+
+ my $tar = $class->new($file, $gzip);
+ return unless $tar;
+
+ return $tar->list_files( @_ );
+}
+
+=head2 Archive::Tar->extract_archive($file, $compressed)
+
+Extracts the contents of the tar file. The first argument can either
+be the name of the tar file to create or a reference to an open file
+handle (e.g. a GLOB reference). All relative paths in the tar file will
+be created underneath the current working directory.
+
+C<extract_archive> will return a list of files it extracted.
+If the archive extraction fails for any reason, C<extract_archive>
+will return false. Please use the C<error> method to find the cause
+of the failure.
+
+=cut
+
+sub extract_archive {
+ my $class = shift;
+ my $file = shift; return unless defined $file;
+ my $gzip = shift || 0;
+
+ my $tar = $class->new( ) or return;
+
+ return $tar->read( $file, $gzip, { extract => 1 } );
+}
+
+=head2 $bool = Archive::Tar->has_io_string
+
+Returns true if we currently have C<IO::String> support loaded.
+
+Either C<IO::String> or C<perlio> support is needed to support writing
+stringified archives. Currently, C<perlio> is the preferred method, if
+available.
+
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
+
+=cut
+
+sub has_io_string { return $HAS_IO_STRING; }
+
+=head2 $bool = Archive::Tar->has_perlio
+
+Returns true if we currently have C<perlio> support loaded.
+
+This requires C<perl-5.8> or higher, compiled with C<perlio>
+
+Either C<IO::String> or C<perlio> support is needed to support writing
+stringified archives. Currently, C<perlio> is the preferred method, if
+available.
+
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
+
+=cut
+
+sub has_perlio { return $HAS_PERLIO; }
+
+=head2 $bool = Archive::Tar->has_zlib_support
+
+Returns true if C<Archive::Tar> can extract C<zlib> compressed archives
+
+=cut
+
+sub has_zlib_support { return ZLIB }
+
+=head2 $bool = Archive::Tar->has_bzip2_support
+
+Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives
+
+=cut
+
+sub has_bzip2_support { return BZIP }
+
+=head2 Archive::Tar->can_handle_compressed_files
+
+A simple checking routine, which will return true if C<Archive::Tar>
+is able to uncompress compressed archives on the fly with C<IO::Zlib>
+and C<IO::Compress::Bzip2> or false if not both are installed.
+
+You can use this as a shortcut to determine whether C<Archive::Tar>
+will do what you think before passing compressed archives to its
+C<read> method.
+
+=cut
+
+sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 }
+
+sub no_string_support {
+ croak("You have to install IO::String to support writing archives to strings");
+}
+
+1;
+
+__END__
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Archive::Tar::FOLLOW_SYMLINK
+
+Set this variable to C<1> to make C<Archive::Tar> effectively make a
+copy of the file when extracting. Default is C<0>, which
+means the symlink stays intact. Of course, you will have to pack the
+file linked to as well.
+
+This option is checked when you write out the tarfile using C<write>
+or C<create_archive>.
+
+This works just like C</bin/tar>'s C<-h> option.
+
+=head2 $Archive::Tar::CHOWN
+
+By default, C<Archive::Tar> will try to C<chown> your files if it is
+able to. In some cases, this may not be desired. In that case, set
+this variable to C<0> to disable C<chown>-ing, even if it were
+possible.
+
+The default is C<1>.
+
+=head2 $Archive::Tar::CHMOD
+
+By default, C<Archive::Tar> will try to C<chmod> your files to
+whatever mode was specified for the particular file in the archive.
+In some cases, this may not be desired. In that case, set this
+variable to C<0> to disable C<chmod>-ing.
+
+The default is C<1>.
+
+=head2 $Archive::Tar::SAME_PERMISSIONS
+
+When, C<$Archive::Tar::CHMOD> is enabled, this setting controls whether
+the permissions on files from the archive are used without modification
+of if they are filtered by removing any setid bits and applying the
+current umask.
+
+The default is C<1> for the root user and C<0> for normal users.
+
+=head2 $Archive::Tar::DO_NOT_USE_PREFIX
+
+By default, C<Archive::Tar> will try to put paths that are over
+100 characters in the C<prefix> field of your tar header, as
+defined per POSIX-standard. However, some (older) tar programs
+do not implement this spec. To retain compatibility with these older
+or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX>
+variable to a true value, and C<Archive::Tar> will use an alternate
+way of dealing with paths over 100 characters by using the
+C<GNU Extended Header> feature.
+
+Note that clients who do not support the C<GNU Extended Header>
+feature will not be able to read these archives. Such clients include
+tars on C<Solaris>, C<Irix> and C<AIX>.
+
+The default is C<0>.
+
+=head2 $Archive::Tar::DEBUG
+
+Set this variable to C<1> to always get the C<Carp::longmess> output
+of the warnings, instead of the regular C<carp>. This is the same
+message you would get by doing:
+
+ $tar->error(1);
+
+Defaults to C<0>.
+
+=head2 $Archive::Tar::WARN
+
+Set this variable to C<0> if you do not want any warnings printed.
+Personally I recommend against doing this, but people asked for the
+option. Also, be advised that this is of course not threadsafe.
+
+Defaults to C<1>.
+
+=head2 $Archive::Tar::error
+
+Holds the last reported error. Kept for historical reasons, but its
+use is very much discouraged. Use the C<error()> method instead:
+
+ warn $tar->error unless $tar->extract;
+
+Note that in older versions of this module, the C<error()> method
+would return an effectively global value even when called an instance
+method as above. This has since been fixed, and multiple instances of
+C<Archive::Tar> now have separate error strings.
+
+=head2 $Archive::Tar::INSECURE_EXTRACT_MODE
+
+This variable indicates whether C<Archive::Tar> should allow
+files to be extracted outside their current working directory.
+
+Allowing this could have security implications, as a malicious
+tar archive could alter or replace any file the extracting user
+has permissions to. Therefor, the default is to not allow
+insecure extractions.
+
+If you trust the archive, or have other reasons to allow the
+archive to write files outside your current working directory,
+set this variable to C<true>.
+
+Note that this is a backwards incompatible change from version
+C<1.36> and before.
+
+=head2 $Archive::Tar::HAS_PERLIO
+
+This variable holds a boolean indicating if we currently have
+C<perlio> support loaded. This will be enabled for any perl
+greater than C<5.8> compiled with C<perlio>.
+
+If you feel strongly about disabling it, set this variable to
+C<false>. Note that you will then need C<IO::String> installed
+to support writing stringified archives.
+
+Don't change this variable unless you B<really> know what you're
+doing.
+
+=head2 $Archive::Tar::HAS_IO_STRING
+
+This variable holds a boolean indicating if we currently have
+C<IO::String> support loaded. This will be enabled for any perl
+that has a loadable C<IO::String> module.
+
+If you feel strongly about disabling it, set this variable to
+C<false>. Note that you will then need C<perlio> support from
+your perl to be able to write stringified archives.
+
+Don't change this variable unless you B<really> know what you're
+doing.
+
+=head1 FAQ
+
+=over 4
+
+=item What's the minimum perl version required to run Archive::Tar?
+
+You will need perl version 5.005_03 or newer.
+
+=item Isn't Archive::Tar slow?
+
+Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar>
+However, it's very portable. If speed is an issue, consider using
+C</bin/tar> instead.
+
+=item Isn't Archive::Tar heavier on memory than /bin/tar?
+
+Yes it is, see previous answer. Since C<Compress::Zlib> and therefore
+C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little
+choice but to read the archive into memory.
+This is ok if you want to do in-memory manipulation of the archive.
+
+If you just want to extract, use the C<extract_archive> class method
+instead. It will optimize and write to disk immediately.
+
+Another option is to use the C<iter> class method to iterate over
+the files in the tarball without reading them all in memory at once.
+
+=item Can you lazy-load data instead?
+
+In some cases, yes. You can use the C<iter> class method to iterate
+over the files in the tarball without reading them all in memory at once.
+
+=item How much memory will an X kb tar file need?
+
+Probably more than X kb, since it will all be read into memory. If
+this is a problem, and you don't need to do in memory manipulation
+of the archive, consider using the C<iter> class method, or C</bin/tar>
+instead.
+
+=item What do you do with unsupported filetypes in an archive?
+
+C<Unix> has a few filetypes that aren't supported on other platforms,
+like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just
+try to make a copy of the original file, rather than throwing an error.
+
+This does require you to read the entire archive in to memory first,
+since otherwise we wouldn't know what data to fill the copy with.
+(This means that you cannot use the class methods, including C<iter>
+on archives that have incompatible filetypes and still expect things
+to work).
+
+For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that
+the extraction of this particular item didn't work.
+
+=item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly!
+
+By default, C<Archive::Tar> is in a completely POSIX-compatible
+mode, which uses the POSIX-specification of C<tar> to store files.
+For paths greather than 100 characters, this is done using the
+C<POSIX header prefix>. Non-POSIX-compatible clients may not support
+this part of the specification, and may only support the C<GNU Extended
+Header> functionality. To facilitate those clients, you can set the
+C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the
+C<GLOBAL VARIABLES> section for details on this variable.
+
+Note that GNU tar earlier than version 1.14 does not cope well with
+the C<POSIX header prefix>. If you use such a version, consider setting
+the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>.
+
+=item How do I extract only files that have property X from an archive?
+
+Sometimes, you might not wish to extract a complete archive, just
+the files that are relevant to you, based on some criteria.
+
+You can do this by filtering a list of C<Archive::Tar::File> objects
+based on your criteria. For example, to extract only files that have
+the string C<foo> in their title, you would use:
+
+ $tar->extract(
+ grep { $_->full_path =~ /foo/ } $tar->get_files
+ );
+
+This way, you can filter on any attribute of the files in the archive.
+Consult the C<Archive::Tar::File> documentation on how to use these
+objects.
+
+=item How do I access .tar.Z files?
+
+The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
+the C<IO::Zlib> module) to access tar files that have been compressed
+with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
+utility cannot be read by C<Compress::Zlib> and so cannot be directly
+accesses by C<Archive::Tar>.
+
+If the C<uncompress> or C<gunzip> programs are available, you can use
+one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
+
+Firstly with C<uncompress>
+
+ use Archive::Tar;
+
+ open F, "uncompress -c $filename |";
+ my $tar = Archive::Tar->new(*F);
+ ...
+
+and this with C<gunzip>
+
+ use Archive::Tar;
+
+ open F, "gunzip -c $filename |";
+ my $tar = Archive::Tar->new(*F);
+ ...
+
+Similarly, if the C<compress> program is available, you can use this to
+write a C<.tar.Z> file
+
+ use Archive::Tar;
+ use IO::File;
+
+ my $fh = new IO::File "| compress -c >$filename";
+ my $tar = Archive::Tar->new();
+ ...
+ $tar->write($fh);
+ $fh->close ;
+
+=item How do I handle Unicode strings?
+
+C<Archive::Tar> uses byte semantics for any files it reads from or writes
+to disk. This is not a problem if you only deal with files and never
+look at their content or work solely with byte strings. But if you use
+Unicode strings with character semantics, some additional steps need
+to be taken.
+
+For example, if you add a Unicode string like
+
+ # Problem
+ $tar->add_data('file.txt', "Euro: \x{20AC}");
+
+then there will be a problem later when the tarfile gets written out
+to disk via C<$tar->write()>:
+
+ Wide character in print at .../Archive/Tar.pm line 1014.
+
+The data was added as a Unicode string and when writing it out to disk,
+the C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl
+tried to convert the string to ISO-8859 and failed. The written file
+now contains garbage.
+
+For this reason, Unicode strings need to be converted to UTF-8-encoded
+bytestrings before they are handed off to C<add_data()>:
+
+ use Encode;
+ my $data = "Accented character: \x{20AC}";
+ $data = encode('utf8', $data);
+
+ $tar->add_data('file.txt', $data);
+
+A opposite problem occurs if you extract a UTF8-encoded file from a
+tarball. Using C<get_content()> on the C<Archive::Tar::File> object
+will return its content as a bytestring, not as a Unicode string.
+
+If you want it to be a Unicode string (because you want character
+semantics with operations like regular expression matching), you need
+to decode the UTF8-encoded content and have Perl convert it into
+a Unicode string:
+
+ use Encode;
+ my $data = $tar->get_content();
+
+ # Make it a Unicode string
+ $data = decode('utf8', $data);
+
+There is no easy way to provide this functionality in C<Archive::Tar>,
+because a tarball can contain many files, and each of which could be
+encoded in a different way.
+
+=back
+
+=head1 CAVEATS
+
+The AIX tar does not fill all unused space in the tar archive with 0x00.
+This sometimes leads to warning messages from C<Archive::Tar>.
+
+ Invalid header block at offset nnn
+
+A fix for that problem is scheduled to be released in the following levels
+of AIX, all of which should be coming out in the 4th quarter of 2009:
+
+ AIX 5.3 TL7 SP10
+ AIX 5.3 TL8 SP8
+ AIX 5.3 TL9 SP5
+ AIX 5.3 TL10 SP2
+
+ AIX 6.1 TL0 SP11
+ AIX 6.1 TL1 SP7
+ AIX 6.1 TL2 SP6
+ AIX 6.1 TL3 SP3
+
+The IBM APAR number for this problem is IZ50240 (Reported component ID:
+5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
+If you need an ifix please contact your local IBM AIX support.
+
+=head1 TODO
+
+=over 4
+
+=item Check if passed in handles are open for read/write
+
+Currently I don't know of any portable pure perl way to do this.
+Suggestions welcome.
+
+=item Allow archives to be passed in as string
+
+Currently, we only allow opened filehandles or filenames, but
+not strings. The internals would need some reworking to facilitate
+stringified archives.
+
+=item Facilitate processing an opened filehandle of a compressed archive
+
+Currently, we only support this if the filehandle is an IO::Zlib object.
+Environments, like apache, will present you with an opened filehandle
+to an uploaded file, which might be a compressed archive.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item The GNU tar specification
+
+C<http://www.gnu.org/software/tar/manual/tar.html>
+
+=item The PAX format specication
+
+The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html>
+
+=item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html>
+
+=item GNU tar intends to switch to POSIX compatibility
+
+GNU Tar authors have expressed their intention to become completely
+POSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html>
+
+=item A Comparison between various tar implementations
+
+Lists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs>
+
+=back
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+Please reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas,
+Rainer Tammer and especially Andrew Savige for their help and suggestions.
+
+=head1 COPYRIGHT
+
+This module is copyright (c) 2002 - 2009 Jos Boumans
+E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Tar/Constant.pm
new file mode 100755
index 00000000000..aef1d623fa8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Tar/Constant.pm
@@ -0,0 +1,86 @@
+package Archive::Tar::Constant;
+
+BEGIN {
+ require Exporter;
+
+ $VERSION = '0.02';
+ @ISA = qw[Exporter];
+
+ require Time::Local if $^O eq "MacOS";
+}
+
+use Package::Constants;
+@EXPORT = Package::Constants->list( __PACKAGE__ );
+
+use constant FILE => 0;
+use constant HARDLINK => 1;
+use constant SYMLINK => 2;
+use constant CHARDEV => 3;
+use constant BLOCKDEV => 4;
+use constant DIR => 5;
+use constant FIFO => 6;
+use constant SOCKET => 8;
+use constant UNKNOWN => 9;
+use constant LONGLINK => 'L';
+use constant LABEL => 'V';
+
+use constant BUFFER => 4096;
+use constant HEAD => 512;
+use constant BLOCK => 512;
+
+use constant COMPRESS_GZIP => 9;
+use constant COMPRESS_BZIP => 'bzip2';
+
+use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
+use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
+use constant TAR_END => "\0" x BLOCK;
+
+use constant READ_ONLY => sub { shift() ? 'rb' : 'r' };
+use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' };
+use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 };
+
+# Pointless assignment to make -w shut up
+my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
+my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
+use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
+use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
+use constant UID => $>;
+use constant GID => (split ' ', $) )[0];
+
+use constant MODE => do { 0666 & (0777 & ~umask) };
+use constant STRIP_MODE => sub { shift() & 0777 };
+use constant CHECK_SUM => " ";
+
+use constant UNPACK => 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12';
+use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
+use constant NAME_LENGTH => 100;
+use constant PREFIX_LENGTH => 155;
+
+use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
+use constant MAGIC => "ustar";
+use constant TAR_VERSION => "00";
+use constant LONGLINK_NAME => '././@LongLink';
+use constant PAX_HEADER => 'pax_global_header';
+
+ ### allow ZLIB to be turned off using ENV: DEBUG only
+use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
+ eval { require IO::Zlib };
+ $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
+ };
+
+ ### allow BZIP to be turned off using ENV: DEBUG only
+use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
+ eval { require IO::Uncompress::Bunzip2;
+ require IO::Compress::Bzip2; };
+ $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
+ };
+
+use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
+use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
+
+use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
+use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
+use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
+use constant ON_VMS => $^O eq 'VMS';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Tar/File.pm
new file mode 100755
index 00000000000..0815bb67620
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Tar/File.pm
@@ -0,0 +1,660 @@
+package Archive::Tar::File;
+use strict;
+
+use Carp ();
+use IO::File;
+use File::Spec::Unix ();
+use File::Spec ();
+use File::Basename ();
+
+### avoid circular use, so only require;
+require Archive::Tar;
+use Archive::Tar::Constant;
+
+use vars qw[@ISA $VERSION];
+#@ISA = qw[Archive::Tar];
+$VERSION = '0.02';
+
+### set value to 1 to oct() it during the unpack ###
+my $tmpl = [
+ name => 0, # string
+ mode => 1, # octal
+ uid => 1, # octal
+ gid => 1, # octal
+ size => 1, # octal
+ mtime => 1, # octal
+ chksum => 1, # octal
+ type => 0, # character
+ linkname => 0, # string
+ magic => 0, # string
+ version => 0, # 2 bytes
+ uname => 0, # string
+ gname => 0, # string
+ devmajor => 1, # octal
+ devminor => 1, # octal
+ prefix => 0,
+
+### end UNPACK items ###
+ raw => 0, # the raw data chunk
+ data => 0, # the data associated with the file --
+ # This might be very memory intensive
+];
+
+### install get/set accessors for this object.
+for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
+ my $key = $tmpl->[$i];
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ my $self = shift;
+ $self->{$key} = $_[0] if @_;
+
+ ### just in case the key is not there or undef or something ###
+ { local $^W = 0;
+ return $self->{$key};
+ }
+ }
+}
+
+=head1 NAME
+
+Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
+
+=head1 SYNOPSIS
+
+ my @items = $tar->get_files;
+
+ print $_->name, ' ', $_->size, "\n" for @items;
+
+ print $object->get_content;
+ $object->replace_content('new content');
+
+ $object->rename( 'new/full/path/to/file.c' );
+
+=head1 DESCRIPTION
+
+Archive::Tar::Files provides a neat little object layer for in-memory
+extracted files. It's mostly used internally in Archive::Tar to tidy
+up the code, but there's no reason users shouldn't use this API as
+well.
+
+=head2 Accessors
+
+A lot of the methods in this package are accessors to the various
+fields in the tar header:
+
+=over 4
+
+=item name
+
+The file's name
+
+=item mode
+
+The file's mode
+
+=item uid
+
+The user id owning the file
+
+=item gid
+
+The group id owning the file
+
+=item size
+
+File size in bytes
+
+=item mtime
+
+Modification time. Adjusted to mac-time on MacOS if required
+
+=item chksum
+
+Checksum field for the tar header
+
+=item type
+
+File type -- numeric, but comparable to exported constants -- see
+Archive::Tar's documentation
+
+=item linkname
+
+If the file is a symlink, the file it's pointing to
+
+=item magic
+
+Tar magic string -- not useful for most users
+
+=item version
+
+Tar version string -- not useful for most users
+
+=item uname
+
+The user name that owns the file
+
+=item gname
+
+The group name that owns the file
+
+=item devmajor
+
+Device major number in case of a special file
+
+=item devminor
+
+Device minor number in case of a special file
+
+=item prefix
+
+Any directory to prefix to the extraction path, if any
+
+=item raw
+
+Raw tar header -- not useful for most users
+
+=back
+
+=head1 Methods
+
+=head2 Archive::Tar::File->new( file => $path )
+
+Returns a new Archive::Tar::File object from an existing file.
+
+Returns undef on failure.
+
+=head2 Archive::Tar::File->new( data => $path, $data, $opt )
+
+Returns a new Archive::Tar::File object from data.
+
+C<$path> defines the file name (which need not exist), C<$data> the
+file contents, and C<$opt> is a reference to a hash of attributes
+which may be used to override the default attributes (fields in the
+tar header), which are described above in the Accessors section.
+
+Returns undef on failure.
+
+=head2 Archive::Tar::File->new( chunk => $chunk )
+
+Returns a new Archive::Tar::File object from a raw 512-byte tar
+archive chunk.
+
+Returns undef on failure.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $what = shift;
+
+ my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
+ ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
+ ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
+ undef;
+
+ return $obj;
+}
+
+### copies the data, creates a clone ###
+sub clone {
+ my $self = shift;
+ return bless { %$self }, ref $self;
+}
+
+sub _new_from_chunk {
+ my $class = shift;
+ my $chunk = shift or return; # 512 bytes of tar header
+ my %hash = @_;
+
+ ### filter any arguments on defined-ness of values.
+ ### this allows overriding from what the tar-header is saying
+ ### about this tar-entry. Particularly useful for @LongLink files
+ my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
+
+ ### makes it start at 0 actually... :) ###
+ my $i = -1;
+ my %entry = map {
+ $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
+ } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
+
+ my $obj = bless { %entry, %args }, $class;
+
+ ### magic is a filetype string.. it should have something like 'ustar' or
+ ### something similar... if the chunk is garbage, skip it
+ return unless $obj->magic !~ /\W/;
+
+ ### store the original chunk ###
+ $obj->raw( $chunk );
+
+ $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
+ $obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
+
+
+ return $obj;
+
+}
+
+sub _new_from_file {
+ my $class = shift;
+ my $path = shift;
+
+ ### path has to at least exist
+ return unless defined $path;
+
+ my $type = __PACKAGE__->_filetype($path);
+ my $data = '';
+
+ READ: {
+ unless ($type == DIR ) {
+ my $fh = IO::File->new;
+
+ unless( $fh->open($path) ) {
+ ### dangling symlinks are fine, stop reading but continue
+ ### creating the object
+ last READ if $type == SYMLINK;
+
+ ### otherwise, return from this function --
+ ### anything that's *not* a symlink should be
+ ### resolvable
+ return;
+ }
+
+ ### binmode needed to read files properly on win32 ###
+ binmode $fh;
+ $data = do { local $/; <$fh> };
+ close $fh;
+ }
+ }
+
+ my @items = qw[mode uid gid size mtime];
+ my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
+
+ if (ON_VMS) {
+ ### VMS has two UID modes, traditional and POSIX. Normally POSIX is
+ ### not used. We currently do not have an easy way to see if we are in
+ ### POSIX mode. In traditional mode, the UID is actually the VMS UIC.
+ ### The VMS UIC has the upper 16 bits is the GID, which in many cases
+ ### the VMS UIC will be larger than 209715, the largest that TAR can
+ ### handle. So for now, assume it is traditional if the UID is larger
+ ### than 0x10000.
+
+ if ($hash{uid} > 0x10000) {
+ $hash{uid} = $hash{uid} & 0xFFFF;
+ }
+
+ ### The file length from stat() is the physical length of the file
+ ### However the amount of data read in may be more for some file types.
+ ### Fixed length files are read past the logical EOF to end of the block
+ ### containing. Other file types get expanded on read because record
+ ### delimiters are added.
+
+ my $data_len = length $data;
+ $hash{size} = $data_len if $hash{size} < $data_len;
+
+ }
+ ### you *must* set size == 0 on symlinks, or the next entry will be
+ ### though of as the contents of the symlink, which is wrong.
+ ### this fixes bug #7937
+ $hash{size} = 0 if ($type == DIR or $type == SYMLINK);
+ $hash{mtime} -= TIME_OFFSET;
+
+ ### strip the high bits off the mode, which we don't need to store
+ $hash{mode} = STRIP_MODE->( $hash{mode} );
+
+
+ ### probably requires some file path munging here ... ###
+ ### name and prefix are set later
+ my $obj = {
+ %hash,
+ name => '',
+ chksum => CHECK_SUM,
+ type => $type,
+ linkname => ($type == SYMLINK and CAN_READLINK)
+ ? readlink $path
+ : '',
+ magic => MAGIC,
+ version => TAR_VERSION,
+ uname => UNAME->( $hash{uid} ),
+ gname => GNAME->( $hash{gid} ),
+ devmajor => 0, # not handled
+ devminor => 0, # not handled
+ prefix => '',
+ data => $data,
+ };
+
+ bless $obj, $class;
+
+ ### fix up the prefix and file from the path
+ my($prefix,$file) = $obj->_prefix_and_file( $path );
+ $obj->prefix( $prefix );
+ $obj->name( $file );
+
+ return $obj;
+}
+
+sub _new_from_data {
+ my $class = shift;
+ my $path = shift; return unless defined $path;
+ my $data = shift; return unless defined $data;
+ my $opt = shift;
+
+ my $obj = {
+ data => $data,
+ name => '',
+ mode => MODE,
+ uid => UID,
+ gid => GID,
+ size => length $data,
+ mtime => time - TIME_OFFSET,
+ chksum => CHECK_SUM,
+ type => FILE,
+ linkname => '',
+ magic => MAGIC,
+ version => TAR_VERSION,
+ uname => UNAME->( UID ),
+ gname => GNAME->( GID ),
+ devminor => 0,
+ devmajor => 0,
+ prefix => '',
+ };
+
+ ### overwrite with user options, if provided ###
+ if( $opt and ref $opt eq 'HASH' ) {
+ for my $key ( keys %$opt ) {
+
+ ### don't write bogus options ###
+ next unless exists $obj->{$key};
+ $obj->{$key} = $opt->{$key};
+ }
+ }
+
+ bless $obj, $class;
+
+ ### fix up the prefix and file from the path
+ my($prefix,$file) = $obj->_prefix_and_file( $path );
+ $obj->prefix( $prefix );
+ $obj->name( $file );
+
+ return $obj;
+}
+
+sub _prefix_and_file {
+ my $self = shift;
+ my $path = shift;
+
+ my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
+ my @dirs = File::Spec->splitdir( $dirs );
+
+ ### so sometimes the last element is '' -- probably when trailing
+ ### dir slashes are encountered... this is of course pointless,
+ ### so remove it
+ pop @dirs while @dirs and not length $dirs[-1];
+
+ ### if it's a directory, then $file might be empty
+ $file = pop @dirs if $self->is_dir and not length $file;
+
+ ### splitting ../ gives you the relative path in native syntax
+ map { $_ = '..' if $_ eq '-' } @dirs if ON_VMS;
+
+ my $prefix = File::Spec::Unix->catdir(
+ grep { length } $vol, @dirs
+ );
+ return( $prefix, $file );
+}
+
+sub _filetype {
+ my $self = shift;
+ my $file = shift;
+
+ return unless defined $file;
+
+ return SYMLINK if (-l $file); # Symlink
+
+ return FILE if (-f _); # Plain file
+
+ return DIR if (-d _); # Directory
+
+ return FIFO if (-p _); # Named pipe
+
+ return SOCKET if (-S _); # Socket
+
+ return BLOCKDEV if (-b _); # Block special
+
+ return CHARDEV if (-c _); # Character special
+
+ ### shouldn't happen, this is when making archives, not reading ###
+ return LONGLINK if ( $file eq LONGLINK_NAME );
+
+ return UNKNOWN; # Something else (like what?)
+
+}
+
+### this method 'downgrades' a file to plain file -- this is used for
+### symlinks when FOLLOW_SYMLINKS is true.
+sub _downgrade_to_plainfile {
+ my $entry = shift;
+ $entry->type( FILE );
+ $entry->mode( MODE );
+ $entry->linkname('');
+
+ return 1;
+}
+
+=head2 $bool = $file->extract( [ $alternative_name ] )
+
+Extract this object, optionally to an alternative name.
+
+See C<< Archive::Tar->extract_file >> for details.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub extract {
+ my $self = shift;
+
+ local $Carp::CarpLevel += 1;
+
+ return Archive::Tar->_extract_file( $self, @_ );
+}
+
+=head2 $path = $file->full_path
+
+Returns the full path from the tar header; this is basically a
+concatenation of the C<prefix> and C<name> fields.
+
+=cut
+
+sub full_path {
+ my $self = shift;
+
+ ### if prefix field is emtpy
+ return $self->name unless defined $self->prefix and length $self->prefix;
+
+ ### or otherwise, catfile'd
+ return File::Spec::Unix->catfile( $self->prefix, $self->name );
+}
+
+
+=head2 $bool = $file->validate
+
+Done by Archive::Tar internally when reading the tar file:
+validate the header against the checksum to ensure integer tar file.
+
+Returns true on success, false on failure
+
+=cut
+
+sub validate {
+ my $self = shift;
+
+ my $raw = $self->raw;
+
+ ### don't know why this one is different from the one we /write/ ###
+ substr ($raw, 148, 8) = " ";
+
+ ### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
+ ### like GNU tar does. See here for details:
+ ### http://www.gnu.org/software/tar/manual/tar.html#SEC139
+ ### so we do both a signed AND unsigned validate. if one succeeds, that's
+ ### good enough
+ return ( (unpack ("%16C*", $raw) == $self->chksum)
+ or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
+}
+
+=head2 $bool = $file->has_content
+
+Returns a boolean to indicate whether the current object has content.
+Some special files like directories and so on never will have any
+content. This method is mainly to make sure you don't get warnings
+for using uninitialized values when looking at an object's content.
+
+=cut
+
+sub has_content {
+ my $self = shift;
+ return defined $self->data() && length $self->data() ? 1 : 0;
+}
+
+=head2 $content = $file->get_content
+
+Returns the current content for the in-memory file
+
+=cut
+
+sub get_content {
+ my $self = shift;
+ $self->data( );
+}
+
+=head2 $cref = $file->get_content_by_ref
+
+Returns the current content for the in-memory file as a scalar
+reference. Normal users won't need this, but it will save memory if
+you are dealing with very large data files in your tar archive, since
+it will pass the contents by reference, rather than make a copy of it
+first.
+
+=cut
+
+sub get_content_by_ref {
+ my $self = shift;
+
+ return \$self->{data};
+}
+
+=head2 $bool = $file->replace_content( $content )
+
+Replace the current content of the file with the new content. This
+only affects the in-memory archive, not the on-disk version until
+you write it.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub replace_content {
+ my $self = shift;
+ my $data = shift || '';
+
+ $self->data( $data );
+ $self->size( length $data );
+ return 1;
+}
+
+=head2 $bool = $file->rename( $new_name )
+
+Rename the current file to $new_name.
+
+Note that you must specify a Unix path for $new_name, since per tar
+standard, all files in the archive must be Unix paths.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub rename {
+ my $self = shift;
+ my $path = shift;
+
+ return unless defined $path;
+
+ my ($prefix,$file) = $self->_prefix_and_file( $path );
+
+ $self->name( $file );
+ $self->prefix( $prefix );
+
+ return 1;
+}
+
+=head1 Convenience methods
+
+To quickly check the type of a C<Archive::Tar::File> object, you can
+use the following methods:
+
+=over 4
+
+=item $file->is_file
+
+Returns true if the file is of type C<file>
+
+=item $file->is_dir
+
+Returns true if the file is of type C<dir>
+
+=item $file->is_hardlink
+
+Returns true if the file is of type C<hardlink>
+
+=item $file->is_symlink
+
+Returns true if the file is of type C<symlink>
+
+=item $file->is_chardev
+
+Returns true if the file is of type C<chardev>
+
+=item $file->is_blockdev
+
+Returns true if the file is of type C<blockdev>
+
+=item $file->is_fifo
+
+Returns true if the file is of type C<fifo>
+
+=item $file->is_socket
+
+Returns true if the file is of type C<socket>
+
+=item $file->is_longlink
+
+Returns true if the file is of type C<LongLink>.
+Should not happen after a successful C<read>.
+
+=item $file->is_label
+
+Returns true if the file is of type C<Label>.
+Should not happen after a successful C<read>.
+
+=item $file->is_unknown
+
+Returns true if the file type is C<unknown>
+
+=back
+
+=cut
+
+#stupid perl5.5.3 needs to warn if it's not numeric
+sub is_file { local $^W; FILE == $_[0]->type }
+sub is_dir { local $^W; DIR == $_[0]->type }
+sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
+sub is_symlink { local $^W; SYMLINK == $_[0]->type }
+sub is_chardev { local $^W; CHARDEV == $_[0]->type }
+sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
+sub is_fifo { local $^W; FIFO == $_[0]->type }
+sub is_socket { local $^W; SOCKET == $_[0]->type }
+sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
+sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
+sub is_label { local $^W; LABEL eq $_[0]->type }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip.pm
new file mode 100755
index 00000000000..8fd86c93b72
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip.pm
@@ -0,0 +1,2059 @@
+package Archive::Zip;
+
+use strict;
+BEGIN {
+ require 5.003_96;
+}
+use UNIVERSAL ();
+use Carp ();
+use Cwd ();
+use IO::File ();
+use IO::Seekable ();
+use Compress::Raw::Zlib ();
+use File::Spec ();
+use File::Temp ();
+use FileHandle ();
+
+use vars qw( $VERSION @ISA );
+BEGIN {
+ $VERSION = '1.30';
+
+ require Exporter;
+ @ISA = qw( Exporter );
+}
+
+use vars qw( $ChunkSize $ErrorHandler );
+BEGIN {
+ # This is the size we'll try to read, write, and (de)compress.
+ # You could set it to something different if you had lots of memory
+ # and needed more speed.
+ $ChunkSize ||= 32768;
+
+ $ErrorHandler = \&Carp::carp;
+}
+
+# BEGIN block is necessary here so that other modules can use the constants.
+use vars qw( @EXPORT_OK %EXPORT_TAGS );
+BEGIN {
+ @EXPORT_OK = ('computeCRC32');
+ %EXPORT_TAGS = (
+ CONSTANTS => [ qw(
+ FA_MSDOS
+ FA_UNIX
+ GPBF_ENCRYPTED_MASK
+ GPBF_DEFLATING_COMPRESSION_MASK
+ GPBF_HAS_DATA_DESCRIPTOR_MASK
+ COMPRESSION_STORED
+ COMPRESSION_DEFLATED
+ COMPRESSION_LEVEL_NONE
+ COMPRESSION_LEVEL_DEFAULT
+ COMPRESSION_LEVEL_FASTEST
+ COMPRESSION_LEVEL_BEST_COMPRESSION
+ IFA_TEXT_FILE_MASK
+ IFA_TEXT_FILE
+ IFA_BINARY_FILE
+ ) ],
+
+ MISC_CONSTANTS => [ qw(
+ FA_AMIGA
+ FA_VAX_VMS
+ FA_VM_CMS
+ FA_ATARI_ST
+ FA_OS2_HPFS
+ FA_MACINTOSH
+ FA_Z_SYSTEM
+ FA_CPM
+ FA_TOPS20
+ FA_WINDOWS_NTFS
+ FA_QDOS
+ FA_ACORN
+ FA_VFAT
+ FA_MVS
+ FA_BEOS
+ FA_TANDEM
+ FA_THEOS
+ GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
+ GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
+ GPBF_IS_COMPRESSED_PATCHED_DATA_MASK
+ COMPRESSION_SHRUNK
+ DEFLATING_COMPRESSION_NORMAL
+ DEFLATING_COMPRESSION_MAXIMUM
+ DEFLATING_COMPRESSION_FAST
+ DEFLATING_COMPRESSION_SUPER_FAST
+ COMPRESSION_REDUCED_1
+ COMPRESSION_REDUCED_2
+ COMPRESSION_REDUCED_3
+ COMPRESSION_REDUCED_4
+ COMPRESSION_IMPLODED
+ COMPRESSION_TOKENIZED
+ COMPRESSION_DEFLATED_ENHANCED
+ COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED
+ ) ],
+
+ ERROR_CODES => [ qw(
+ AZ_OK
+ AZ_STREAM_END
+ AZ_ERROR
+ AZ_FORMAT_ERROR
+ AZ_IO_ERROR
+ ) ],
+
+ # For Internal Use Only
+ PKZIP_CONSTANTS => [ qw(
+ SIGNATURE_FORMAT
+ SIGNATURE_LENGTH
+ LOCAL_FILE_HEADER_SIGNATURE
+ LOCAL_FILE_HEADER_FORMAT
+ LOCAL_FILE_HEADER_LENGTH
+ CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
+ DATA_DESCRIPTOR_FORMAT
+ DATA_DESCRIPTOR_LENGTH
+ DATA_DESCRIPTOR_SIGNATURE
+ DATA_DESCRIPTOR_FORMAT_NO_SIG
+ DATA_DESCRIPTOR_LENGTH_NO_SIG
+ CENTRAL_DIRECTORY_FILE_HEADER_FORMAT
+ CENTRAL_DIRECTORY_FILE_HEADER_LENGTH
+ END_OF_CENTRAL_DIRECTORY_SIGNATURE
+ END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING
+ END_OF_CENTRAL_DIRECTORY_FORMAT
+ END_OF_CENTRAL_DIRECTORY_LENGTH
+ ) ],
+
+ # For Internal Use Only
+ UTILITY_METHODS => [ qw(
+ _error
+ _printError
+ _ioError
+ _formatError
+ _subclassResponsibility
+ _binmode
+ _isSeekable
+ _newFileHandle
+ _readSignature
+ _asZipDirName
+ ) ],
+ );
+
+ # Add all the constant names and error code names to @EXPORT_OK
+ Exporter::export_ok_tags( qw(
+ CONSTANTS
+ ERROR_CODES
+ PKZIP_CONSTANTS
+ UTILITY_METHODS
+ MISC_CONSTANTS
+ ) );
+
+}
+
+# Error codes
+use constant AZ_OK => 0;
+use constant AZ_STREAM_END => 1;
+use constant AZ_ERROR => 2;
+use constant AZ_FORMAT_ERROR => 3;
+use constant AZ_IO_ERROR => 4;
+
+# File types
+# Values of Archive::Zip::Member->fileAttributeFormat()
+
+use constant FA_MSDOS => 0;
+use constant FA_AMIGA => 1;
+use constant FA_VAX_VMS => 2;
+use constant FA_UNIX => 3;
+use constant FA_VM_CMS => 4;
+use constant FA_ATARI_ST => 5;
+use constant FA_OS2_HPFS => 6;
+use constant FA_MACINTOSH => 7;
+use constant FA_Z_SYSTEM => 8;
+use constant FA_CPM => 9;
+use constant FA_TOPS20 => 10;
+use constant FA_WINDOWS_NTFS => 11;
+use constant FA_QDOS => 12;
+use constant FA_ACORN => 13;
+use constant FA_VFAT => 14;
+use constant FA_MVS => 15;
+use constant FA_BEOS => 16;
+use constant FA_TANDEM => 17;
+use constant FA_THEOS => 18;
+
+# general-purpose bit flag masks
+# Found in Archive::Zip::Member->bitFlag()
+
+use constant GPBF_ENCRYPTED_MASK => 1 << 0;
+use constant GPBF_DEFLATING_COMPRESSION_MASK => 3 << 1;
+use constant GPBF_HAS_DATA_DESCRIPTOR_MASK => 1 << 3;
+
+# deflating compression types, if compressionMethod == COMPRESSION_DEFLATED
+# ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK )
+
+use constant DEFLATING_COMPRESSION_NORMAL => 0 << 1;
+use constant DEFLATING_COMPRESSION_MAXIMUM => 1 << 1;
+use constant DEFLATING_COMPRESSION_FAST => 2 << 1;
+use constant DEFLATING_COMPRESSION_SUPER_FAST => 3 << 1;
+
+# compression method
+
+# these two are the only ones supported in this module
+use constant COMPRESSION_STORED => 0; # file is stored (no compression)
+use constant COMPRESSION_DEFLATED => 8; # file is Deflated
+use constant COMPRESSION_LEVEL_NONE => 0;
+use constant COMPRESSION_LEVEL_DEFAULT => -1;
+use constant COMPRESSION_LEVEL_FASTEST => 1;
+use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9;
+
+# internal file attribute bits
+# Found in Archive::Zip::Member::internalFileAttributes()
+
+use constant IFA_TEXT_FILE_MASK => 1;
+use constant IFA_TEXT_FILE => 1;
+use constant IFA_BINARY_FILE => 0;
+
+# PKZIP file format miscellaneous constants (for internal use only)
+use constant SIGNATURE_FORMAT => "V";
+use constant SIGNATURE_LENGTH => 4;
+
+# these lengths are without the signature.
+use constant LOCAL_FILE_HEADER_SIGNATURE => 0x04034b50;
+use constant LOCAL_FILE_HEADER_FORMAT => "v3 V4 v2";
+use constant LOCAL_FILE_HEADER_LENGTH => 26;
+
+# PKZIP docs don't mention the signature, but Info-Zip writes it.
+use constant DATA_DESCRIPTOR_SIGNATURE => 0x08074b50;
+use constant DATA_DESCRIPTOR_FORMAT => "V3";
+use constant DATA_DESCRIPTOR_LENGTH => 12;
+
+# but the signature is apparently optional.
+use constant DATA_DESCRIPTOR_FORMAT_NO_SIG => "V2";
+use constant DATA_DESCRIPTOR_LENGTH_NO_SIG => 8;
+
+use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50;
+use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2";
+use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42;
+
+use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50;
+use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING =>
+ pack( "V", END_OF_CENTRAL_DIRECTORY_SIGNATURE );
+use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v";
+use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18;
+
+use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK => 1 << 1;
+use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK => 1 << 2;
+use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK => 1 << 5;
+
+# the rest of these are not supported in this module
+use constant COMPRESSION_SHRUNK => 1; # file is Shrunk
+use constant COMPRESSION_REDUCED_1 => 2; # file is Reduced CF=1
+use constant COMPRESSION_REDUCED_2 => 3; # file is Reduced CF=2
+use constant COMPRESSION_REDUCED_3 => 4; # file is Reduced CF=3
+use constant COMPRESSION_REDUCED_4 => 5; # file is Reduced CF=4
+use constant COMPRESSION_IMPLODED => 6; # file is Imploded
+use constant COMPRESSION_TOKENIZED => 7; # reserved for Tokenizing compr.
+use constant COMPRESSION_DEFLATED_ENHANCED => 9; # reserved for enh. Deflating
+use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10;
+
+# Load the various required classes
+require Archive::Zip::Archive;
+require Archive::Zip::Member;
+require Archive::Zip::FileMember;
+require Archive::Zip::DirectoryMember;
+require Archive::Zip::ZipFileMember;
+require Archive::Zip::NewFileMember;
+require Archive::Zip::StringMember;
+
+use constant ZIPARCHIVECLASS => 'Archive::Zip::Archive';
+use constant ZIPMEMBERCLASS => 'Archive::Zip::Member';
+
+# Convenience functions
+
+sub _ISA ($$) {
+ # Can't rely on Scalar::Util, so use the next best way
+ local $@;
+ !! eval { ref $_[0] and $_[0]->isa($_[1]) };
+}
+
+sub _CAN ($$) {
+ local $@;
+ !! eval { ref $_[0] and $_[0]->can($_[1]) };
+}
+
+
+
+
+
+#####################################################################
+# Methods
+
+sub new {
+ my $class = shift;
+ return $class->ZIPARCHIVECLASS->new(@_);
+}
+
+sub computeCRC32 {
+ my ( $data, $crc );
+
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $data = $_[0]->{string};
+ $crc = $_[0]->{checksum};
+ }
+ else {
+ $data = shift;
+ $data = shift if ref($data);
+ $crc = shift;
+ }
+
+ return Compress::Raw::Zlib::crc32( $data, $crc );
+}
+
+# Report or change chunk size used for reading and writing.
+# Also sets Zlib's default buffer size (eventually).
+sub setChunkSize {
+ shift if ref( $_[0] ) eq 'Archive::Zip::Archive';
+ my $chunkSize = ( ref( $_[0] ) eq 'HASH' ) ? shift->{chunkSize} : shift;
+ my $oldChunkSize = $Archive::Zip::ChunkSize;
+ $Archive::Zip::ChunkSize = $chunkSize if ($chunkSize);
+ return $oldChunkSize;
+}
+
+sub chunkSize {
+ return $Archive::Zip::ChunkSize;
+}
+
+sub setErrorHandler {
+ my $errorHandler = ( ref( $_[0] ) eq 'HASH' ) ? shift->{subroutine} : shift;
+ $errorHandler = \&Carp::carp unless defined($errorHandler);
+ my $oldErrorHandler = $Archive::Zip::ErrorHandler;
+ $Archive::Zip::ErrorHandler = $errorHandler;
+ return $oldErrorHandler;
+}
+
+
+
+
+
+######################################################################
+# Private utility functions (not methods).
+
+sub _printError {
+ my $string = join ( ' ', @_, "\n" );
+ my $oldCarpLevel = $Carp::CarpLevel;
+ $Carp::CarpLevel += 2;
+ &{$ErrorHandler} ($string);
+ $Carp::CarpLevel = $oldCarpLevel;
+}
+
+# This is called on format errors.
+sub _formatError {
+ shift if ref( $_[0] );
+ _printError( 'format error:', @_ );
+ return AZ_FORMAT_ERROR;
+}
+
+# This is called on IO errors.
+sub _ioError {
+ shift if ref( $_[0] );
+ _printError( 'IO error:', @_, ':', $! );
+ return AZ_IO_ERROR;
+}
+
+# This is called on generic errors.
+sub _error {
+ shift if ref( $_[0] );
+ _printError( 'error:', @_ );
+ return AZ_ERROR;
+}
+
+# Called when a subclass should have implemented
+# something but didn't
+sub _subclassResponsibility {
+ Carp::croak("subclass Responsibility\n");
+}
+
+# Try to set the given file handle or object into binary mode.
+sub _binmode {
+ my $fh = shift;
+ return _CAN( $fh, 'binmode' ) ? $fh->binmode() : binmode($fh);
+}
+
+# Attempt to guess whether file handle is seekable.
+# Because of problems with Windows, this only returns true when
+# the file handle is a real file.
+sub _isSeekable {
+ my $fh = shift;
+ return 0 unless ref $fh;
+ if ( _ISA($fh, 'IO::Scalar') ) {
+ # IO::Scalar objects are brokenly-seekable
+ return 0;
+ }
+ if ( _ISA($fh, 'IO::String') ) {
+ return 1;
+ }
+ if ( _ISA($fh, 'IO::Seekable') ) {
+ # Unfortunately, some things like FileHandle objects
+ # return true for Seekable, but AREN'T!!!!!
+ if ( _ISA($fh, 'FileHandle') ) {
+ return 0;
+ } else {
+ return 1;
+ }
+ }
+ if ( _CAN($fh, 'stat') ) {
+ return -f $fh;
+ }
+ return (
+ _CAN($fh, 'seek') and _CAN($fh, 'tell')
+ ) ? 1 : 0;
+}
+
+# Print to the filehandle, while making sure the pesky Perl special global
+# variables don't interfere.
+sub _print
+{
+ my ($self, $fh, @data) = @_;
+
+ local $\;
+
+ return $fh->print(@data);
+}
+
+# Return an opened IO::Handle
+# my ( $status, fh ) = _newFileHandle( 'fileName', 'w' );
+# Can take a filename, file handle, or ref to GLOB
+# Or, if given something that is a ref but not an IO::Handle,
+# passes back the same thing.
+sub _newFileHandle {
+ my $fd = shift;
+ my $status = 1;
+ my $handle;
+
+ if ( ref($fd) ) {
+ if ( _ISA($fd, 'IO::Scalar') or _ISA($fd, 'IO::String') ) {
+ $handle = $fd;
+ } elsif ( _ISA($fd, 'IO::Handle') or ref($fd) eq 'GLOB' ) {
+ $handle = IO::File->new;
+ $status = $handle->fdopen( $fd, @_ );
+ } else {
+ $handle = $fd;
+ }
+ } else {
+ $handle = IO::File->new;
+ $status = $handle->open( $fd, @_ );
+ }
+
+ return ( $status, $handle );
+}
+
+# Returns next signature from given file handle, leaves
+# file handle positioned afterwards.
+# In list context, returns ($status, $signature)
+# ( $status, $signature) = _readSignature( $fh, $fileName );
+
+sub _readSignature {
+ my $fh = shift;
+ my $fileName = shift;
+ my $expectedSignature = shift; # optional
+
+ my $signatureData;
+ my $bytesRead = $fh->read( $signatureData, SIGNATURE_LENGTH );
+ if ( $bytesRead != SIGNATURE_LENGTH ) {
+ return _ioError("reading header signature");
+ }
+ my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
+ my $status = AZ_OK;
+
+ # compare with expected signature, if any, or any known signature.
+ if ( ( defined($expectedSignature) && $signature != $expectedSignature )
+ || ( !defined($expectedSignature)
+ && $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
+ && $signature != LOCAL_FILE_HEADER_SIGNATURE
+ && $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE
+ && $signature != DATA_DESCRIPTOR_SIGNATURE ) )
+ {
+ my $errmsg = sprintf( "bad signature: 0x%08x", $signature );
+ if ( _isSeekable($fh) )
+ {
+ $errmsg .=
+ sprintf( " at offset %d", $fh->tell() - SIGNATURE_LENGTH );
+ }
+
+ $status = _formatError("$errmsg in file $fileName");
+ }
+
+ return ( $status, $signature );
+}
+
+# Utility method to make and open a temp file.
+# Will create $temp_dir if it doesn't exist.
+# Returns file handle and name:
+#
+# my ($fh, $name) = Archive::Zip::tempFile();
+# my ($fh, $name) = Archive::Zip::tempFile('mytempdir');
+#
+
+sub tempFile {
+ my $dir = ( ref( $_[0] ) eq 'HASH' ) ? shift->{tempDir} : shift;
+ my ( $fh, $filename ) = File::Temp::tempfile(
+ SUFFIX => '.zip',
+ UNLINK => 0, # we will delete it!
+ $dir ? ( DIR => $dir ) : ()
+ );
+ return ( undef, undef ) unless $fh;
+ my ( $status, $newfh ) = _newFileHandle( $fh, 'w+' );
+ return ( $newfh, $filename );
+}
+
+# Return the normalized directory name as used in a zip file (path
+# separators become slashes, etc.).
+# Will translate internal slashes in path components (i.e. on Macs) to
+# underscores. Discards volume names.
+# When $forceDir is set, returns paths with trailing slashes (or arrays
+# with trailing blank members).
+#
+# If third argument is a reference, returns volume information there.
+#
+# input output
+# . ('.') '.'
+# ./a ('a') a
+# ./a/b ('a','b') a/b
+# ./a/b/ ('a','b') a/b
+# a/b/ ('a','b') a/b
+# /a/b/ ('','a','b') /a/b
+# c:\a\b\c.doc ('','a','b','c.doc') /a/b/c.doc # on Windoze
+# "i/o maps:whatever" ('i_o maps', 'whatever') "i_o maps/whatever" # on Macs
+sub _asZipDirName
+{
+ my $name = shift;
+ my $forceDir = shift;
+ my $volReturn = shift;
+ my ( $volume, $directories, $file ) =
+ File::Spec->splitpath( File::Spec->canonpath($name), $forceDir );
+ $$volReturn = $volume if ( ref($volReturn) );
+ my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec->splitdir($directories);
+ if ( @dirs > 0 ) { pop (@dirs) unless $dirs[-1] } # remove empty component
+ push ( @dirs, defined($file) ? $file : '' );
+ #return wantarray ? @dirs : join ( '/', @dirs );
+ return join ( '/', @dirs );
+}
+
+# Return an absolute local name for a zip name.
+# Assume a directory if zip name has trailing slash.
+# Takes an optional volume name in FS format (like 'a:').
+#
+sub _asLocalName
+{
+ my $name = shift; # zip format
+ my $volume = shift;
+ $volume = '' unless defined($volume); # local FS format
+
+ my @paths = split ( /\//, $name );
+ my $filename = pop (@paths);
+ $filename = '' unless defined($filename);
+ my $localDirs = @paths ? File::Spec->catdir(@paths) : '';
+ my $localName = File::Spec->catpath( $volume, $localDirs, $filename );
+ unless ( $volume ) {
+ $localName = File::Spec->rel2abs( $localName, Cwd::getcwd() );
+ }
+ return $localName;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Archive::Zip - Provide an interface to ZIP archive files.
+
+=head1 SYNOPSIS
+
+ # Create a Zip file
+ use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
+ my $zip = Archive::Zip->new();
+
+ # Add a directory
+ my $dir_member = $zip->addDirectory( 'dirname/' );
+
+ # Add a file from a string with compression
+ my $string_member = $zip->addString( 'This is a test', 'stringMember.txt' );
+ $string_member->desiredCompressionMethod( COMPRESSION_DEFLATED );
+
+ # Add a file from disk
+ my $file_member = $zip->addFile( 'xyz.pl', 'AnotherName.pl' );
+
+ # Save the Zip file
+ unless ( $zip->writeToFileNamed('someZip.zip') == AZ_OK ) {
+ die 'write error';
+ }
+
+ # Read a Zip file
+ my $somezip = Archive::Zip->new();
+ unless ( $somezip->read( 'someZip.zip' ) == AZ_OK ) {
+ die 'read error';
+ }
+
+ # Change the compression type for a file in the Zip
+ my $member = $somezip->memberNamed( 'stringMember.txt' );
+ $member->desiredCompressionMethod( COMPRESSION_STORED );
+ unless ( $zip->writeToFileNamed( 'someOtherZip.zip' ) == AZ_OK ) {
+ die 'write error';
+ }
+
+=head1 DESCRIPTION
+
+The Archive::Zip module allows a Perl program to create, manipulate, read,
+and write Zip archive files.
+
+Zip archives can be created, or you can read from existing zip files.
+
+Once created, they can be written to files, streams, or strings. Members
+can be added, removed, extracted, replaced, rearranged, and enumerated.
+They can also be renamed or have their dates, comments, or other attributes
+queried or modified. Their data can be compressed or uncompressed as needed.
+
+Members can be created from members in existing Zip files, or from existing
+directories, files, or strings.
+
+This module uses the L<Compress::Raw::Zlib> library to read and write the
+compressed streams inside the files.
+
+One can use L<Archive::Zip::MemberRead> to read the zip file archive members
+as if they were files.
+
+=head2 File Naming
+
+Regardless of what your local file system uses for file naming, names in a
+Zip file are in Unix format (I<forward> slashes (/) separating directory
+names, etc.).
+
+C<Archive::Zip> tries to be consistent with file naming conventions, and will
+translate back and forth between native and Zip file names.
+
+However, it can't guess which format names are in. So two rules control what
+kind of file name you must pass various routines:
+
+=over 4
+
+=item Names of files are in local format.
+
+C<File::Spec> and C<File::Basename> are used for various file
+operations. When you're referring to a file on your system, use its
+file naming conventions.
+
+=item Names of archive members are in Unix format.
+
+This applies to every method that refers to an archive member, or
+provides a name for new archive members. The C<extract()> methods
+that can take one or two names will convert from local to zip names
+if you call them with a single name.
+
+=back
+
+=head2 Archive::Zip Object Model
+
+=head2 Overview
+
+Archive::Zip::Archive objects are what you ordinarily deal with.
+These maintain the structure of a zip file, without necessarily
+holding data. When a zip is read from a disk file, the (possibly
+compressed) data still lives in the file, not in memory. Archive
+members hold information about the individual members, but not
+(usually) the actual member data. When the zip is written to a
+(different) file, the member data is compressed or copied as needed.
+It is possible to make archive members whose data is held in a string
+in memory, but this is not done when a zip file is read. Directory
+members don't have any data.
+
+=head2 Inheritance
+
+ Exporter
+ Archive::Zip Common base class, has defs.
+ Archive::Zip::Archive A Zip archive.
+ Archive::Zip::Member Abstract superclass for all members.
+ Archive::Zip::StringMember Member made from a string
+ Archive::Zip::FileMember Member made from an external file
+ Archive::Zip::ZipFileMember Member that lives in a zip file
+ Archive::Zip::NewFileMember Member whose data is in a file
+ Archive::Zip::DirectoryMember Member that is a directory
+
+=head1 EXPORTS
+
+=over 4
+
+=item :CONSTANTS
+
+Exports the following constants:
+
+FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK
+GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK
+COMPRESSION_STORED COMPRESSION_DEFLATED IFA_TEXT_FILE_MASK
+IFA_TEXT_FILE IFA_BINARY_FILE COMPRESSION_LEVEL_NONE
+COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST
+COMPRESSION_LEVEL_BEST_COMPRESSION
+
+=item :MISC_CONSTANTS
+
+Exports the following constants (only necessary for extending the
+module):
+
+FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST FA_OS2_HPFS
+FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS
+GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
+GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
+GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK
+DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM
+DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST
+COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3
+COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED
+COMPRESSION_DEFLATED_ENHANCED
+COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED
+
+=item :ERROR_CODES
+
+Explained below. Returned from most methods.
+
+AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR
+
+=back
+
+=head1 ERROR CODES
+
+Many of the methods in Archive::Zip return error codes. These are implemented
+as inline subroutines, using the C<use constant> pragma. They can be imported
+into your namespace using the C<:ERROR_CODES> tag:
+
+ use Archive::Zip qw( :ERROR_CODES );
+
+ ...
+
+ unless ( $zip->read( 'myfile.zip' ) == AZ_OK ) {
+ die "whoops!";
+ }
+
+=over 4
+
+=item AZ_OK (0)
+
+Everything is fine.
+
+=item AZ_STREAM_END (1)
+
+The read stream (or central directory) ended normally.
+
+=item AZ_ERROR (2)
+
+There was some generic kind of error.
+
+=item AZ_FORMAT_ERROR (3)
+
+There is a format error in a ZIP file being read.
+
+=item AZ_IO_ERROR (4)
+
+There was an IO error.
+
+=back
+
+=head2 Compression
+
+Archive::Zip allows each member of a ZIP file to be compressed (using the
+Deflate algorithm) or uncompressed.
+
+Other compression algorithms that some versions of ZIP have been able to
+produce are not supported. Each member has two compression methods: the
+one it's stored as (this is always COMPRESSION_STORED for string and external
+file members), and the one you desire for the member in the zip file.
+
+These can be different, of course, so you can make a zip member that is not
+compressed out of one that is, and vice versa.
+
+You can inquire about the current compression and set the desired
+compression method:
+
+ my $member = $zip->memberNamed( 'xyz.txt' );
+ $member->compressionMethod(); # return current compression
+
+ # set to read uncompressed
+ $member->desiredCompressionMethod( COMPRESSION_STORED );
+
+ # set to read compressed
+ $member->desiredCompressionMethod( COMPRESSION_DEFLATED );
+
+There are two different compression methods:
+
+=over 4
+
+=item COMPRESSION_STORED
+
+File is stored (no compression)
+
+=item COMPRESSION_DEFLATED
+
+File is Deflated
+
+=back
+
+=head2 Compression Levels
+
+If a member's desiredCompressionMethod is COMPRESSION_DEFLATED, you
+can choose different compression levels. This choice may affect the
+speed of compression and decompression, as well as the size of the
+compressed member data.
+
+ $member->desiredCompressionLevel( 9 );
+
+The levels given can be:
+
+=over 4
+
+=item 0 or COMPRESSION_LEVEL_NONE
+
+This is the same as saying
+
+ $member->desiredCompressionMethod( COMPRESSION_STORED );
+
+=item 1 .. 9
+
+1 gives the best speed and worst compression, and 9 gives the
+best compression and worst speed.
+
+=item COMPRESSION_LEVEL_FASTEST
+
+This is a synonym for level 1.
+
+=item COMPRESSION_LEVEL_BEST_COMPRESSION
+
+This is a synonym for level 9.
+
+=item COMPRESSION_LEVEL_DEFAULT
+
+This gives a good compromise between speed and compression,
+and is currently equivalent to 6 (this is in the zlib code).
+This is the level that will be used if not specified.
+
+=back
+
+=head1 Archive::Zip Methods
+
+The Archive::Zip class (and its invisible subclass Archive::Zip::Archive)
+implement generic zip file functionality. Creating a new Archive::Zip object
+actually makes an Archive::Zip::Archive object, but you don't have to worry
+about this unless you're subclassing.
+
+=head2 Constructor
+
+=over 4
+
+=item new( [$fileName] )
+
+Make a new, empty zip archive.
+
+ my $zip = Archive::Zip->new();
+
+If an additional argument is passed, new() will call read()
+to read the contents of an archive:
+
+ my $zip = Archive::Zip->new( 'xyz.zip' );
+
+If a filename argument is passed and the read fails for any
+reason, new will return undef. For this reason, it may be
+better to call read separately.
+
+=back
+
+=head2 Zip Archive Utility Methods
+
+These Archive::Zip methods may be called as functions or as object
+methods. Do not call them as class methods:
+
+ $zip = Archive::Zip->new();
+ $crc = Archive::Zip::computeCRC32( 'ghijkl' ); # OK
+ $crc = $zip->computeCRC32( 'ghijkl' ); # also OK
+ $crc = Archive::Zip->computeCRC32( 'ghijkl' ); # NOT OK
+
+=over 4
+
+=item Archive::Zip::computeCRC32( $string [, $crc] )
+
+This is a utility function that uses the Compress::Raw::Zlib CRC
+routine to compute a CRC-32. You can get the CRC of a string:
+
+ $crc = Archive::Zip::computeCRC32( $string );
+
+Or you can compute the running CRC:
+
+ $crc = 0;
+ $crc = Archive::Zip::computeCRC32( 'abcdef', $crc );
+ $crc = Archive::Zip::computeCRC32( 'ghijkl', $crc );
+
+=item Archive::Zip::setChunkSize( $number )
+
+Report or change chunk size used for reading and writing.
+This can make big differences in dealing with large files.
+Currently, this defaults to 32K. This also changes the chunk
+size used for Compress::Raw::Zlib. You must call setChunkSize()
+before reading or writing. This is not exportable, so you
+must call it like:
+
+ Archive::Zip::setChunkSize( 4096 );
+
+or as a method on a zip (though this is a global setting).
+Returns old chunk size.
+
+=item Archive::Zip::chunkSize()
+
+Returns the current chunk size:
+
+ my $chunkSize = Archive::Zip::chunkSize();
+
+=item Archive::Zip::setErrorHandler( \&subroutine )
+
+Change the subroutine called with error strings. This
+defaults to \&Carp::carp, but you may want to change it to
+get the error strings. This is not exportable, so you must
+call it like:
+
+ Archive::Zip::setErrorHandler( \&myErrorHandler );
+
+If myErrorHandler is undef, resets handler to default.
+Returns old error handler. Note that if you call Carp::carp
+or a similar routine or if you're chaining to the default
+error handler from your error handler, you may want to
+increment the number of caller levels that are skipped (do
+not just set it to a number):
+
+ $Carp::CarpLevel++;
+
+=item Archive::Zip::tempFile( [$tmpdir] )
+
+Create a uniquely named temp file. It will be returned open
+for read/write. If C<$tmpdir> is given, it is used as the
+name of a directory to create the file in. If not given,
+creates the file using C<File::Spec::tmpdir()>. Generally, you can
+override this choice using the
+
+ $ENV{TMPDIR}
+
+environment variable. But see the L<File::Spec|File::Spec>
+documentation for your system. Note that on many systems, if you're
+running in taint mode, then you must make sure that C<$ENV{TMPDIR}> is
+untainted for it to be used.
+Will I<NOT> create C<$tmpdir> if it doesn't exist (this is a change
+from prior versions!). Returns file handle and name:
+
+ my ($fh, $name) = Archive::Zip::tempFile();
+ my ($fh, $name) = Archive::Zip::tempFile('myTempDir');
+ my $fh = Archive::Zip::tempFile(); # if you don't need the name
+
+=back
+
+=head2 Zip Archive Accessors
+
+=over 4
+
+=item members()
+
+Return a copy of the members array
+
+ my @members = $zip->members();
+
+=item numberOfMembers()
+
+Return the number of members I have
+
+=item memberNames()
+
+Return a list of the (internal) file names of the zip members
+
+=item memberNamed( $string )
+
+Return ref to member whose filename equals given filename or
+undef. C<$string> must be in Zip (Unix) filename format.
+
+=item membersMatching( $regex )
+
+Return array of members whose filenames match given regular
+expression in list context. Returns number of matching
+members in scalar context.
+
+ my @textFileMembers = $zip->membersMatching( '.*\.txt' );
+ # or
+ my $numberOfTextFiles = $zip->membersMatching( '.*\.txt' );
+
+=item diskNumber()
+
+Return the disk that I start on. Not used for writing zips,
+but might be interesting if you read a zip in. This should be
+0, as Archive::Zip does not handle multi-volume archives.
+
+=item diskNumberWithStartOfCentralDirectory()
+
+Return the disk number that holds the beginning of the
+central directory. Not used for writing zips, but might be
+interesting if you read a zip in. This should be 0, as
+Archive::Zip does not handle multi-volume archives.
+
+=item numberOfCentralDirectoriesOnThisDisk()
+
+Return the number of CD structures in the zipfile last read in.
+Not used for writing zips, but might be interesting if you read a zip
+in.
+
+=item numberOfCentralDirectories()
+
+Return the number of CD structures in the zipfile last read in.
+Not used for writing zips, but might be interesting if you read a zip
+in.
+
+=item centralDirectorySize()
+
+Returns central directory size, as read from an external zip
+file. Not used for writing zips, but might be interesting if
+you read a zip in.
+
+=item centralDirectoryOffsetWRTStartingDiskNumber()
+
+Returns the offset into the zip file where the CD begins. Not
+used for writing zips, but might be interesting if you read a
+zip in.
+
+=item zipfileComment( [$string] )
+
+Get or set the zipfile comment. Returns the old comment.
+
+ print $zip->zipfileComment();
+ $zip->zipfileComment( 'New Comment' );
+
+=item eocdOffset()
+
+Returns the (unexpected) number of bytes between where the
+EOCD was found and where it expected to be. This is normally
+0, but would be positive if something (a virus, perhaps) had
+added bytes somewhere before the EOCD. Not used for writing
+zips, but might be interesting if you read a zip in. Here is
+an example of how you can diagnose this:
+
+ my $zip = Archive::Zip->new('somefile.zip');
+ if ($zip->eocdOffset())
+ {
+ warn "A virus has added ", $zip->eocdOffset, " bytes of garbage\n";
+ }
+
+The C<eocdOffset()> is used to adjust the starting position of member
+headers, if necessary.
+
+=item fileName()
+
+Returns the name of the file last read from. If nothing has
+been read yet, returns an empty string; if read from a file
+handle, returns the handle in string form.
+
+=back
+
+=head2 Zip Archive Member Operations
+
+Various operations on a zip file modify members. When a member is
+passed as an argument, you can either use a reference to the member
+itself, or the name of a member. Of course, using the name requires
+that names be unique within a zip (this is not enforced).
+
+=over 4
+
+=item removeMember( $memberOrName )
+
+Remove and return the given member, or match its name and
+remove it. Returns undef if member or name doesn't exist in this
+Zip. No-op if member does not belong to this zip.
+
+=item replaceMember( $memberOrName, $newMember )
+
+Remove and return the given member, or match its name and
+remove it. Replace with new member. Returns undef if member or
+name doesn't exist in this Zip, or if C<$newMember> is undefined.
+
+It is an (undiagnosed) error to provide a C<$newMember> that is a
+member of the zip being modified.
+
+ my $member1 = $zip->removeMember( 'xyz' );
+ my $member2 = $zip->replaceMember( 'abc', $member1 );
+ # now, $member2 (named 'abc') is not in $zip,
+ # and $member1 (named 'xyz') is, having taken $member2's place.
+
+=item extractMember( $memberOrName [, $extractedName ] )
+
+Extract the given member, or match its name and extract it.
+Returns undef if member doesn't exist in this Zip. If
+optional second arg is given, use it as the name of the
+extracted member. Otherwise, the internal filename of the
+member is used as the name of the extracted file or
+directory.
+If you pass C<$extractedName>, it should be in the local file
+system's format.
+All necessary directories will be created. Returns C<AZ_OK>
+on success.
+
+=item extractMemberWithoutPaths( $memberOrName [, $extractedName ] )
+
+Extract the given member, or match its name and extract it.
+Does not use path information (extracts into the current
+directory). Returns undef if member doesn't exist in this
+Zip.
+If optional second arg is given, use it as the name of the
+extracted member (its paths will be deleted too). Otherwise,
+the internal filename of the member (minus paths) is used as
+the name of the extracted file or directory. Returns C<AZ_OK>
+on success.
+
+=item addMember( $member )
+
+Append a member (possibly from another zip file) to the zip
+file. Returns the new member. Generally, you will use
+addFile(), addDirectory(), addFileOrDirectory(), addString(),
+or read() to add members.
+
+ # Move member named 'abc' to end of zip:
+ my $member = $zip->removeMember( 'abc' );
+ $zip->addMember( $member );
+
+=item updateMember( $memberOrName, $fileName )
+
+Update a single member from the file or directory named C<$fileName>.
+Returns the (possibly added or updated) member, if any; C<undef> on
+errors.
+The comparison is based on C<lastModTime()> and (in the case of a
+non-directory) the size of the file.
+
+=item addFile( $fileName [, $newName ] )
+
+Append a member whose data comes from an external file,
+returning the member or undef. The member will have its file
+name set to the name of the external file, and its
+desiredCompressionMethod set to COMPRESSION_DEFLATED. The
+file attributes and last modification time will be set from
+the file.
+If the name given does not represent a readable plain file or
+symbolic link, undef will be returned. C<$fileName> must be
+in the format required for the local file system.
+The optional C<$newName> argument sets the internal file name
+to something different than the given $fileName. C<$newName>,
+if given, must be in Zip name format (i.e. Unix).
+The text mode bit will be set if the contents appears to be
+text (as returned by the C<-T> perl operator).
+
+
+I<NOTE> that you shouldn't (generally) use absolute path names
+in zip member names, as this will cause problems with some zip
+tools as well as introduce a security hole and make the zip
+harder to use.
+
+=item addDirectory( $directoryName [, $fileName ] )
+
+
+
+Append a member created from the given directory name. The
+directory name does not have to name an existing directory.
+If the named directory exists, the file modification time and
+permissions are set from the existing directory, otherwise
+they are set to now and permissive default permissions.
+C<$directoryName> must be in local file system format.
+The optional second argument sets the name of the archive
+member (which defaults to C<$directoryName>). If given, it
+must be in Zip (Unix) format.
+Returns the new member.
+
+=item addFileOrDirectory( $name [, $newName ] )
+
+
+
+Append a member from the file or directory named $name. If
+$newName is given, use it for the name of the new member.
+Will add or remove trailing slashes from $newName as needed.
+C<$name> must be in local file system format.
+The optional second argument sets the name of the archive
+member (which defaults to C<$name>). If given, it must be in
+Zip (Unix) format.
+
+=item addString( $stringOrStringRef, $name )
+
+
+
+Append a member created from the given string or string
+reference. The name is given by the second argument.
+Returns the new member. The last modification time will be
+set to now, and the file attributes will be set to permissive
+defaults.
+
+ my $member = $zip->addString( 'This is a test', 'test.txt' );
+
+=item contents( $memberOrMemberName [, $newContents ] )
+
+
+
+Returns the uncompressed data for a particular member, or
+undef.
+
+ print "xyz.txt contains " . $zip->contents( 'xyz.txt' );
+
+Also can change the contents of a member:
+
+ $zip->contents( 'xyz.txt', 'This is the new contents' );
+
+If called expecting an array as the return value, it will include
+the status as the second value in the array.
+
+ ($content, $status) = $zip->contents( 'xyz.txt');
+
+=back
+
+=head2 Zip Archive I/O operations
+
+
+A Zip archive can be written to a file or file handle, or read from
+one.
+
+=over 4
+
+=item writeToFileNamed( $fileName )
+
+
+
+Write a zip archive to named file. Returns C<AZ_OK> on
+success.
+
+ my $status = $zip->writeToFileNamed( 'xx.zip' );
+ die "error somewhere" if $status != AZ_OK;
+
+Note that if you use the same name as an existing zip file
+that you read in, you will clobber ZipFileMembers. So
+instead, write to a different file name, then delete the
+original.
+If you use the C<overwrite()> or C<overwriteAs()> methods, you can
+re-write the original zip in this way.
+C<$fileName> should be a valid file name on your system.
+
+=item writeToFileHandle( $fileHandle [, $seekable] )
+
+Write a zip archive to a file handle. Return AZ_OK on
+success. The optional second arg tells whether or not to try
+to seek backwards to re-write headers. If not provided, it is
+set if the Perl C<-f> test returns true. This could fail on
+some operating systems, though.
+
+ my $fh = IO::File->new( 'someFile.zip', 'w' );
+ unless ( $zip->writeToFileHandle( $fh ) == AZ_OK ) {
+ # error handling
+ }
+
+If you pass a file handle that is not seekable (like if
+you're writing to a pipe or a socket), pass a false second
+argument:
+
+ my $fh = IO::File->new( '| cat > somefile.zip', 'w' );
+ $zip->writeToFileHandle( $fh, 0 ); # fh is not seekable
+
+If this method fails during the write of a member, that
+member and all following it will return false from
+C<wasWritten()>. See writeCentralDirectory() for a way to
+deal with this.
+If you want, you can write data to the file handle before
+passing it to writeToFileHandle(); this could be used (for
+instance) for making self-extracting archives. However, this
+only works reliably when writing to a real file (as opposed
+to STDOUT or some other possible non-file).
+
+See examples/selfex.pl for how to write a self-extracting
+archive.
+
+=item writeCentralDirectory( $fileHandle [, $offset ] )
+
+Writes the central directory structure to the given file
+handle.
+
+Returns AZ_OK on success. If given an $offset, will
+seek to that point before writing. This can be used for
+recovery in cases where writeToFileHandle or writeToFileNamed
+returns an IO error because of running out of space on the
+destination file.
+
+You can truncate the zip by seeking backwards and then writing the
+directory:
+
+ my $fh = IO::File->new( 'someFile.zip', 'w' );
+ my $retval = $zip->writeToFileHandle( $fh );
+ if ( $retval == AZ_IO_ERROR ) {
+ my @unwritten = grep { not $_->wasWritten() } $zip->members();
+ if (@unwritten) {
+ $zip->removeMember( $member ) foreach my $member ( @unwritten );
+ $zip->writeCentralDirectory( $fh,
+ $unwritten[0]->writeLocalHeaderRelativeOffset());
+ }
+ }
+
+=item overwriteAs( $newName )
+
+Write the zip to the specified file, as safely as possible.
+This is done by first writing to a temp file, then renaming
+the original if it exists, then renaming the temp file, then
+deleting the renamed original if it exists. Returns AZ_OK if
+successful.
+
+=item overwrite()
+
+Write back to the original zip file. See overwriteAs() above.
+If the zip was not ever read from a file, this generates an
+error.
+
+=item read( $fileName )
+
+Read zipfile headers from a zip file, appending new members.
+Returns C<AZ_OK> or error code.
+
+ my $zipFile = Archive::Zip->new();
+ my $status = $zipFile->read( '/some/FileName.zip' );
+
+=item readFromFileHandle( $fileHandle, $filename )
+
+Read zipfile headers from an already-opened file handle,
+appending new members. Does not close the file handle.
+Returns C<AZ_OK> or error code. Note that this requires a
+seekable file handle; reading from a stream is not yet
+supported.
+
+ my $fh = IO::File->new( '/some/FileName.zip', 'r' );
+ my $zip1 = Archive::Zip->new();
+ my $status = $zip1->readFromFileHandle( $fh );
+ my $zip2 = Archive::Zip->new();
+ $status = $zip2->readFromFileHandle( $fh );
+
+=back
+
+=head2 Zip Archive Tree operations
+
+These used to be in Archive::Zip::Tree but got moved into
+Archive::Zip. They enable operation on an entire tree of members or
+files.
+A usage example:
+
+ use Archive::Zip;
+ my $zip = Archive::Zip->new();
+
+ # add all readable files and directories below . as xyz/*
+ $zip->addTree( '.', 'xyz' );
+
+ # add all readable plain files below /abc as def/*
+ $zip->addTree( '/abc', 'def', sub { -f && -r } );
+
+ # add all .c files below /tmp as stuff/*
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' );
+
+ # add all .o files below /tmp as stuff/* if they aren't writable
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } );
+
+ # add all .so files below /tmp that are smaller than 200 bytes as stuff/*
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } );
+
+ # and write them into a file
+ $zip->writeToFileNamed('xxx.zip');
+
+ # now extract the same files into /tmpx
+ $zip->extractTree( 'stuff', '/tmpx' );
+
+=over 4
+
+=item $zip->addTree( $root, $dest [,$pred] ) -- Add tree of files to a zip
+
+C<$root> is the root of the tree of files and directories to be
+added. It is a valid directory name on your system. C<$dest> is
+the name for the root in the zip file (undef or blank means
+to use relative pathnames). It is a valid ZIP directory name
+(that is, it uses forward slashes (/) for separating
+directory components). C<$pred> is an optional subroutine
+reference to select files: it is passed the name of the
+prospective file or directory using C<$_>, and if it returns
+true, the file or directory will be included. The default is
+to add all readable files and directories. For instance,
+using
+
+ my $pred = sub { /\.txt/ };
+ $zip->addTree( '.', '', $pred );
+
+will add all the .txt files in and below the current
+directory, using relative names, and making the names
+identical in the zipfile:
+
+ original name zip member name
+ ./xyz xyz
+ ./a/ a/
+ ./a/b a/b
+
+To translate absolute to relative pathnames, just pass them
+in: $zip->addTree( '/c/d', 'a' );
+
+ original name zip member name
+ /c/d/xyz a/xyz
+ /c/d/a/ a/a/
+ /c/d/a/b a/a/b
+
+Returns AZ_OK on success. Note that this will not follow
+symbolic links to directories. Note also that this does not
+check for the validity of filenames.
+
+Note that you generally I<don't> want to make zip archive member names
+absolute.
+
+=item $zip->addTreeMatching( $root, $dest, $pattern [,$pred] )
+
+$root is the root of the tree of files and directories to be
+added $dest is the name for the root in the zip file (undef
+means to use relative pathnames) $pattern is a (non-anchored)
+regular expression for filenames to match $pred is an
+optional subroutine reference to select files: it is passed
+the name of the prospective file or directory in C<$_>, and
+if it returns true, the file or directory will be included.
+The default is to add all readable files and directories. To
+add all files in and below the current dirctory whose names
+end in C<.pl>, and make them extract into a subdirectory
+named C<xyz>, do this:
+
+ $zip->addTreeMatching( '.', 'xyz', '\.pl$' )
+
+To add all I<writable> files in and below the dirctory named
+C</abc> whose names end in C<.pl>, and make them extract into
+a subdirectory named C<xyz>, do this:
+
+ $zip->addTreeMatching( '/abc', 'xyz', '\.pl$', sub { -w } )
+
+Returns AZ_OK on success. Note that this will not follow
+symbolic links to directories.
+
+=item $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
+
+
+
+Update a zip file from a directory tree.
+
+C<updateTree()> takes the same arguments as C<addTree()>, but first
+checks to see whether the file or directory already exists in the zip
+file, and whether it has been changed.
+
+If the fourth argument C<$mirror> is true, then delete all my members
+if corresponding files weren't found.
+
+
+Returns an error code or AZ_OK if all is well.
+
+=item $zip->extractTree()
+
+
+
+=item $zip->extractTree( $root )
+
+
+
+=item $zip->extractTree( $root, $dest )
+
+
+
+=item $zip->extractTree( $root, $dest, $volume )
+
+
+
+If you don't give any arguments at all, will extract all the
+files in the zip with their original names.
+
+
+If you supply one argument for C<$root>, C<extractTree> will extract
+all the members whose names start with C<$root> into the current
+directory, stripping off C<$root> first.
+C<$root> is in Zip (Unix) format.
+For instance,
+
+ $zip->extractTree( 'a' );
+
+when applied to a zip containing the files:
+a/x a/b/c ax/d/e d/e will extract:
+
+
+a/x as ./x
+
+
+a/b/c as ./b/c
+
+
+If you give two arguments, C<extractTree> extracts all the members
+whose names start with C<$root>. It will translate C<$root> into
+C<$dest> to construct the destination file name.
+C<$root> and C<$dest> are in Zip (Unix) format.
+For instance,
+
+ $zip->extractTree( 'a', 'd/e' );
+
+when applied to a zip containing the files:
+a/x a/b/c ax/d/e d/e will extract:
+
+
+a/x to d/e/x
+
+
+a/b/c to d/e/b/c and ignore ax/d/e and d/e
+
+
+If you give three arguments, C<extractTree> extracts all the members
+whose names start with C<$root>. It will translate C<$root> into
+C<$dest> to construct the destination file name, and then it will
+convert to local file system format, using C<$volume> as the name of
+the destination volume.
+
+
+C<$root> and C<$dest> are in Zip (Unix) format.
+
+
+C<$volume> is in local file system format.
+
+
+For instance, under Windows,
+
+ $zip->extractTree( 'a', 'd/e', 'f:' );
+
+when applied to a zip containing the files:
+a/x a/b/c ax/d/e d/e will extract:
+
+
+a/x to f:d/e/x
+
+
+a/b/c to f:d/e/b/c and ignore ax/d/e and d/e
+
+
+If you want absolute paths (the prior example used paths relative to
+the current directory on the destination volume, you can specify these
+in C<$dest>:
+
+ $zip->extractTree( 'a', '/d/e', 'f:' );
+
+when applied to a zip containing the files:
+a/x a/b/c ax/d/e d/e will extract:
+
+
+a/x to f:\d\e\x
+
+
+a/b/c to f:\d\e\b\c and ignore ax/d/e and d/e
+
+Returns an error code or AZ_OK if everything worked OK.
+
+=back
+
+=head1 MEMBER OPERATIONS
+
+
+=head2 Member Class Methods
+
+
+Several constructors allow you to construct members without adding
+them to a zip archive. These work the same as the addFile(),
+addDirectory(), and addString() zip instance methods described above,
+but they don't add the new members to a zip.
+
+=over 4
+
+=item Archive::Zip::Member->newFromString( $stringOrStringRef [, $fileName] )
+
+
+
+Construct a new member from the given string. Returns undef
+on error.
+
+ my $member = Archive::Zip::Member->newFromString( 'This is a test',
+ 'xyz.txt' );
+
+=item newFromFile( $fileName )
+
+
+
+Construct a new member from the given file. Returns undef on
+error.
+
+ my $member = Archive::Zip::Member->newFromFile( 'xyz.txt' );
+
+=item newDirectoryNamed( $directoryName [, $zipname ] )
+
+
+
+Construct a new member from the given directory.
+C<$directoryName> must be a valid name on your file system; it doesn't
+have to exist.
+
+
+If given, C<$zipname> will be the name of the zip member; it must be a
+valid Zip (Unix) name. If not given, it will be converted from
+C<$directoryName>.
+
+
+Returns undef on error.
+
+ my $member = Archive::Zip::Member->newDirectoryNamed( 'CVS/' );
+
+=back
+
+=head2 Member Simple accessors
+
+
+These methods get (and/or set) member attribute values.
+
+=over 4
+
+=item versionMadeBy()
+
+
+
+Gets the field from the member header.
+
+=item fileAttributeFormat( [$format] )
+
+
+
+Gets or sets the field from the member header. These are
+C<FA_*> values.
+
+=item versionNeededToExtract()
+
+
+
+Gets the field from the member header.
+
+=item bitFlag()
+
+
+
+Gets the general purpose bit field from the member header.
+This is where the C<GPBF_*> bits live.
+
+=item compressionMethod()
+
+
+
+Returns the member compression method. This is the method
+that is currently being used to compress the member data.
+This will be COMPRESSION_STORED for added string or file
+members, or any of the C<COMPRESSION_*> values for members
+from a zip file. However, this module can only handle members
+whose data is in COMPRESSION_STORED or COMPRESSION_DEFLATED
+format.
+
+=item desiredCompressionMethod( [$method] )
+
+
+
+Get or set the member's C<desiredCompressionMethod>. This is
+the compression method that will be used when the member is
+written. Returns prior desiredCompressionMethod. Only
+COMPRESSION_DEFLATED or COMPRESSION_STORED are valid
+arguments. Changing to COMPRESSION_STORED will change the
+member desiredCompressionLevel to 0; changing to
+COMPRESSION_DEFLATED will change the member
+desiredCompressionLevel to COMPRESSION_LEVEL_DEFAULT.
+
+=item desiredCompressionLevel( [$method] )
+
+
+
+Get or set the member's desiredCompressionLevel This is the
+method that will be used to write. Returns prior
+desiredCompressionLevel. Valid arguments are 0 through 9,
+COMPRESSION_LEVEL_NONE, COMPRESSION_LEVEL_DEFAULT,
+COMPRESSION_LEVEL_BEST_COMPRESSION, and
+COMPRESSION_LEVEL_FASTEST. 0 or COMPRESSION_LEVEL_NONE will
+change the desiredCompressionMethod to COMPRESSION_STORED.
+All other arguments will change the desiredCompressionMethod
+to COMPRESSION_DEFLATED.
+
+=item externalFileName()
+
+
+
+Return the member's external file name, if any, or undef.
+
+=item fileName()
+
+
+
+Get or set the member's internal filename. Returns the
+(possibly new) filename. Names will have backslashes
+converted to forward slashes, and will have multiple
+consecutive slashes converted to single ones.
+
+=item lastModFileDateTime()
+
+
+
+Return the member's last modification date/time stamp in
+MS-DOS format.
+
+=item lastModTime()
+
+
+
+Return the member's last modification date/time stamp,
+converted to unix localtime format.
+
+ print "Mod Time: " . scalar( localtime( $member->lastModTime() ) );
+
+=item setLastModFileDateTimeFromUnix()
+
+Set the member's lastModFileDateTime from the given unix
+time.
+
+ $member->setLastModFileDateTimeFromUnix( time() );
+
+=item internalFileAttributes()
+
+Return the internal file attributes field from the zip
+header. This is only set for members read from a zip file.
+
+=item externalFileAttributes()
+
+Return member attributes as read from the ZIP file. Note that
+these are NOT UNIX!
+
+=item unixFileAttributes( [$newAttributes] )
+
+Get or set the member's file attributes using UNIX file
+attributes. Returns old attributes.
+
+ my $oldAttribs = $member->unixFileAttributes( 0666 );
+
+Note that the return value has more than just the file
+permissions, so you will have to mask off the lowest bits for
+comparisions.
+
+=item localExtraField( [$newField] )
+
+Gets or sets the extra field that was read from the local
+header. This is not set for a member from a zip file until
+after the member has been written out. The extra field must
+be in the proper format.
+
+=item cdExtraField( [$newField] )
+
+Gets or sets the extra field that was read from the central
+directory header. The extra field must be in the proper
+format.
+
+=item extraFields()
+
+Return both local and CD extra fields, concatenated.
+
+=item fileComment( [$newComment] )
+
+Get or set the member's file comment.
+
+=item hasDataDescriptor()
+
+Get or set the data descriptor flag. If this is set, the
+local header will not necessarily have the correct data
+sizes. Instead, a small structure will be stored at the end
+of the member data with these values. This should be
+transparent in normal operation.
+
+=item crc32()
+
+Return the CRC-32 value for this member. This will not be set
+for members that were constructed from strings or external
+files until after the member has been written.
+
+=item crc32String()
+
+Return the CRC-32 value for this member as an 8 character
+printable hex string. This will not be set for members that
+were constructed from strings or external files until after
+the member has been written.
+
+=item compressedSize()
+
+Return the compressed size for this member. This will not be
+set for members that were constructed from strings or
+external files until after the member has been written.
+
+=item uncompressedSize()
+
+Return the uncompressed size for this member.
+
+=item isEncrypted()
+
+Return true if this member is encrypted. The Archive::Zip
+module does not currently create or extract encrypted
+members.
+
+=item isTextFile( [$flag] )
+
+Returns true if I am a text file. Also can set the status if
+given an argument (then returns old state). Note that this
+module does not currently do anything with this flag upon
+extraction or storage. That is, bytes are stored in native
+format whether or not they came from a text file.
+
+=item isBinaryFile()
+
+Returns true if I am a binary file. Also can set the status
+if given an argument (then returns old state). Note that this
+module does not currently do anything with this flag upon
+extraction or storage. That is, bytes are stored in native
+format whether or not they came from a text file.
+
+=item extractToFileNamed( $fileName )
+
+Extract me to a file with the given name. The file will be
+created with default modes. Directories will be created as
+needed.
+The C<$fileName> argument should be a valid file name on your
+file system.
+Returns AZ_OK on success.
+
+=item isDirectory()
+
+Returns true if I am a directory.
+
+=item writeLocalHeaderRelativeOffset()
+
+Returns the file offset in bytes the last time I was written.
+
+=item wasWritten()
+
+Returns true if I was successfully written. Reset at the
+beginning of a write attempt.
+
+=back
+
+=head2 Low-level member data reading
+
+It is possible to use lower-level routines to access member data
+streams, rather than the extract* methods and contents(). For
+instance, here is how to print the uncompressed contents of a member
+in chunks using these methods:
+
+ my ( $member, $status, $bufferRef );
+ $member = $zip->memberNamed( 'xyz.txt' );
+ $member->desiredCompressionMethod( COMPRESSION_STORED );
+ $status = $member->rewindData();
+ die "error $status" unless $status == AZ_OK;
+ while ( ! $member->readIsDone() )
+ {
+ ( $bufferRef, $status ) = $member->readChunk();
+ die "error $status"
+ if $status != AZ_OK && $status != AZ_STREAM_END;
+ # do something with $bufferRef:
+ print $$bufferRef;
+ }
+ $member->endRead();
+
+=over 4
+
+=item readChunk( [$chunkSize] )
+
+This reads the next chunk of given size from the member's
+data stream and compresses or uncompresses it as necessary,
+returning a reference to the bytes read and a status. If size
+argument is not given, defaults to global set by
+Archive::Zip::setChunkSize. Status is AZ_OK on success until
+the last chunk, where it returns AZ_STREAM_END. Returns C<(
+\$bytes, $status)>.
+
+ my ( $outRef, $status ) = $self->readChunk();
+ print $$outRef if $status != AZ_OK && $status != AZ_STREAM_END;
+
+=item rewindData()
+
+Rewind data and set up for reading data streams or writing
+zip files. Can take options for C<inflateInit()> or
+C<deflateInit()>, but this isn't likely to be necessary.
+Subclass overrides should call this method. Returns C<AZ_OK>
+on success.
+
+=item endRead()
+
+Reset the read variables and free the inflater or deflater.
+Must be called to close files, etc. Returns AZ_OK on success.
+
+=item readIsDone()
+
+Return true if the read has run out of data or errored out.
+
+=item contents()
+
+Return the entire uncompressed member data or undef in scalar
+context. When called in array context, returns C<( $string,
+$status )>; status will be AZ_OK on success:
+
+ my $string = $member->contents();
+ # or
+ my ( $string, $status ) = $member->contents();
+ die "error $status" unless $status == AZ_OK;
+
+Can also be used to set the contents of a member (this may
+change the class of the member):
+
+ $member->contents( "this is my new contents" );
+
+=item extractToFileHandle( $fh )
+
+Extract (and uncompress, if necessary) the member's contents
+to the given file handle. Return AZ_OK on success.
+
+=back
+
+=head1 Archive::Zip::FileMember methods
+
+The Archive::Zip::FileMember class extends Archive::Zip::Member. It is the
+base class for both ZipFileMember and NewFileMember classes. This class adds
+an C<externalFileName> and an C<fh> member to keep track of the external
+file.
+
+=over 4
+
+=item externalFileName()
+
+Return the member's external filename.
+
+=item fh()
+
+Return the member's read file handle. Automatically opens file if
+necessary.
+
+=back
+
+=head1 Archive::Zip::ZipFileMember methods
+
+The Archive::Zip::ZipFileMember class represents members that have been read
+from external zip files.
+
+=over 4
+
+=item diskNumberStart()
+
+Returns the disk number that the member's local header resides in.
+Should be 0.
+
+=item localHeaderRelativeOffset()
+
+Returns the offset into the zip file where the member's local header
+is.
+
+=item dataOffset()
+
+Returns the offset from the beginning of the zip file to the member's
+data.
+
+=back
+
+=head1 REQUIRED MODULES
+
+L<Archive::Zip> requires several other modules:
+
+L<Carp>
+
+L<Compress::Raw::Zlib>
+
+L<Cwd>
+
+L<File::Basename>
+
+L<File::Copy>
+
+L<File::Find>
+
+L<File::Path>
+
+L<File::Spec>
+
+L<IO::File>
+
+L<IO::Seekable>
+
+L<Time::Local>
+
+=head1 BUGS AND CAVEATS
+
+=head2 When not to use Archive::Zip
+
+If you are just going to be extracting zips (and/or other archives) you
+are recommended to look at using L<Archive::Extract> instead, as it is much
+easier to use and factors out archive-specific functionality.
+
+=head2 Try to avoid IO::Scalar
+
+One of the most common ways to use Archive::Zip is to generate Zip files
+in-memory. Most people have use L<IO::Scalar> for this purpose.
+
+Unfortunately, as of 1.11 this module no longer works with L<IO::Scalar>
+as it incorrectly implements seeking.
+
+Anybody using L<IO::Scalar> should consider porting to L<IO::String>,
+which is smaller, lighter, and is implemented to be perfectly compatible
+with regular seekable filehandles.
+
+Support for L<IO::Scalar> most likely will B<not> be restored in the
+future, as L<IO::Scalar> itself cannot change the way it is implemented
+due to back-compatibility issues.
+
+=head1 TO DO
+
+* auto-choosing storing vs compression
+
+* extra field hooks (see notes.txt)
+
+* check for dups on addition/renaming?
+
+* Text file extraction (line end translation)
+
+* Reading zip files from non-seekable inputs
+ (Perhaps by proxying through IO::String?)
+
+* separate unused constants into separate module
+
+* cookbook style docs
+
+* Handle tainted paths correctly
+
+* Work on better compatability with other IO:: modules
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Archive-Zip>
+
+For other issues contact the maintainer
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+Previously maintained by Steve Peters E<lt>steve@fisharerojo.orgE<gt>.
+
+File attributes code by Maurice Aubrey E<lt>maurice@lovelyfilth.comE<gt>.
+
+Originally by Ned Konz E<lt>nedkonz@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+Some parts copyright 2006 - 2009 Adam Kennedy.
+
+Some parts copyright 2005 Steve Peters.
+
+Original work copyright 2000 - 2004 Ned Konz.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Look at L<Archive::Zip::MemberRead> which is a wrapper that allows one to
+read Zip archive members as if they were files.
+
+L<Compress::Raw::Zlib>, L<Archive::Tar>, L<Archive::Extract>
+
+There is a Japanese translation of this
+document at L<http://www.memb.jp/~deq/perl/doc-ja/Archive-Zip.html>
+that was done by DEQ E<lt>deq@oct.zaq.ne.jpE<gt> . Thanks!
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Archive.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Archive.pm
new file mode 100755
index 00000000000..d9fd02e5e02
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Archive.pm
@@ -0,0 +1,978 @@
+package Archive::Zip::Archive;
+
+# Represents a generic ZIP archive
+
+use strict;
+use File::Path;
+use File::Find ();
+use File::Spec ();
+use File::Copy ();
+use File::Basename;
+use Cwd;
+
+use vars qw( $VERSION @ISA );
+
+BEGIN {
+ $VERSION = '1.30';
+ @ISA = qw( Archive::Zip );
+}
+
+use Archive::Zip qw(
+ :CONSTANTS
+ :ERROR_CODES
+ :PKZIP_CONSTANTS
+ :UTILITY_METHODS
+);
+
+# Note that this returns undef on read errors, else new zip object.
+
+sub new {
+ my $class = shift;
+ my $self = bless(
+ {
+ 'diskNumber' => 0,
+ 'diskNumberWithStartOfCentralDirectory' => 0,
+ 'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members
+ 'numberOfCentralDirectories' => 0, # shld be # of members
+ 'centralDirectorySize' => 0, # must re-compute on write
+ 'centralDirectoryOffsetWRTStartingDiskNumber' =>
+ 0, # must re-compute
+ 'writeEOCDOffset' => 0,
+ 'writeCentralDirectoryOffset' => 0,
+ 'zipfileComment' => '',
+ 'eocdOffset' => 0,
+ 'fileName' => ''
+ },
+ $class
+ );
+ $self->{'members'} = [];
+ my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift;
+ if ($fileName) {
+ my $status = $self->read($fileName);
+ return $status == AZ_OK ? $self : undef;
+ }
+ return $self;
+}
+
+sub storeSymbolicLink {
+ my $self = shift;
+ $self->{'storeSymbolicLink'} = shift;
+}
+
+sub members {
+ @{ shift->{'members'} };
+}
+
+sub numberOfMembers {
+ scalar( shift->members() );
+}
+
+sub memberNames {
+ my $self = shift;
+ return map { $_->fileName() } $self->members();
+}
+
+# return ref to member with given name or undef
+sub memberNamed {
+ my $self = shift;
+ my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{zipName} : shift;
+ foreach my $member ( $self->members() ) {
+ return $member if $member->fileName() eq $fileName;
+ }
+ return undef;
+}
+
+sub membersMatching {
+ my $self = shift;
+ my $pattern = ( ref( $_[0] ) eq 'HASH' ) ? shift->{regex} : shift;
+ return grep { $_->fileName() =~ /$pattern/ } $self->members();
+}
+
+sub diskNumber {
+ shift->{'diskNumber'};
+}
+
+sub diskNumberWithStartOfCentralDirectory {
+ shift->{'diskNumberWithStartOfCentralDirectory'};
+}
+
+sub numberOfCentralDirectoriesOnThisDisk {
+ shift->{'numberOfCentralDirectoriesOnThisDisk'};
+}
+
+sub numberOfCentralDirectories {
+ shift->{'numberOfCentralDirectories'};
+}
+
+sub centralDirectorySize {
+ shift->{'centralDirectorySize'};
+}
+
+sub centralDirectoryOffsetWRTStartingDiskNumber {
+ shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
+}
+
+sub zipfileComment {
+ my $self = shift;
+ my $comment = $self->{'zipfileComment'};
+ if (@_) {
+ my $new_comment = ( ref( $_[0] ) eq 'HASH' ) ? shift->{comment} : shift;
+ $self->{'zipfileComment'} = pack( 'C0a*', $new_comment ); # avoid unicode
+ }
+ return $comment;
+}
+
+sub eocdOffset {
+ shift->{'eocdOffset'};
+}
+
+# Return the name of the file last read.
+sub fileName {
+ shift->{'fileName'};
+}
+
+sub removeMember {
+ my $self = shift;
+ my $member = ( ref( $_[0] ) eq 'HASH' ) ? shift->{memberOrZipName} : shift;
+ $member = $self->memberNamed($member) unless ref($member);
+ return undef unless $member;
+ my @newMembers = grep { $_ != $member } $self->members();
+ $self->{'members'} = \@newMembers;
+ return $member;
+}
+
+sub replaceMember {
+ my $self = shift;
+
+ my ( $oldMember, $newMember );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $oldMember = $_[0]->{memberOrZipName};
+ $newMember = $_[0]->{newMember};
+ }
+ else {
+ ( $oldMember, $newMember ) = @_;
+ }
+
+ $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
+ return undef unless $oldMember;
+ return undef unless $newMember;
+ my @newMembers =
+ map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
+ $self->{'members'} = \@newMembers;
+ return $oldMember;
+}
+
+sub extractMember {
+ my $self = shift;
+
+ my ( $member, $name );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $member = $_[0]->{memberOrZipName};
+ $name = $_[0]->{name};
+ }
+ else {
+ ( $member, $name ) = @_;
+ }
+
+ $member = $self->memberNamed($member) unless ref($member);
+ return _error('member not found') unless $member;
+ my $originalSize = $member->compressedSize();
+ my ( $volumeName, $dirName, $fileName );
+ if ( defined($name) ) {
+ ( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
+ $dirName = File::Spec->catpath( $volumeName, $dirName, '' );
+ }
+ else {
+ $name = $member->fileName();
+ ( $dirName = $name ) =~ s{[^/]*$}{};
+ $dirName = Archive::Zip::_asLocalName($dirName);
+ $name = Archive::Zip::_asLocalName($name);
+ }
+ if ( $dirName && !-d $dirName ) {
+ mkpath($dirName);
+ return _ioError("can't create dir $dirName") if ( !-d $dirName );
+ }
+ my $rc = $member->extractToFileNamed( $name, @_ );
+
+ # TODO refactor this fix into extractToFileNamed()
+ $member->{'compressedSize'} = $originalSize;
+ return $rc;
+}
+
+sub extractMemberWithoutPaths {
+ my $self = shift;
+
+ my ( $member, $name );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $member = $_[0]->{memberOrZipName};
+ $name = $_[0]->{name};
+ }
+ else {
+ ( $member, $name ) = @_;
+ }
+
+ $member = $self->memberNamed($member) unless ref($member);
+ return _error('member not found') unless $member;
+ my $originalSize = $member->compressedSize();
+ return AZ_OK if $member->isDirectory();
+ unless ($name) {
+ $name = $member->fileName();
+ $name =~ s{.*/}{}; # strip off directories, if any
+ $name = Archive::Zip::_asLocalName($name);
+ }
+ my $rc = $member->extractToFileNamed( $name, @_ );
+ $member->{'compressedSize'} = $originalSize;
+ return $rc;
+}
+
+sub addMember {
+ my $self = shift;
+ my $newMember = ( ref( $_[0] ) eq 'HASH' ) ? shift->{member} : shift;
+ push( @{ $self->{'members'} }, $newMember ) if $newMember;
+ return $newMember;
+}
+
+sub addFile {
+ my $self = shift;
+
+ my ( $fileName, $newName, $compressionLevel );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $fileName = $_[0]->{filename};
+ $newName = $_[0]->{zipName};
+ $compressionLevel = $_[0]->{compressionLevel};
+ }
+ else {
+ ( $fileName, $newName, $compressionLevel ) = @_;
+ }
+
+ my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
+ $newMember->desiredCompressionLevel($compressionLevel);
+ if ( $self->{'storeSymbolicLink'} && -l $fileName ) {
+ my $newMember = $self->ZIPMEMBERCLASS->newFromString(readlink $fileName, $newName);
+ # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
+ $newMember->{'externalFileAttributes'} = 0xA1FF0000;
+ $self->addMember($newMember);
+ } else {
+ $self->addMember($newMember);
+ }
+ return $newMember;
+}
+
+sub addString {
+ my $self = shift;
+
+ my ( $stringOrStringRef, $name, $compressionLevel );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $stringOrStringRef = $_[0]->{string};
+ $name = $_[0]->{zipName};
+ $compressionLevel = $_[0]->{compressionLevel};
+ }
+ else {
+ ( $stringOrStringRef, $name, $compressionLevel ) = @_;;
+ }
+
+ my $newMember = $self->ZIPMEMBERCLASS->newFromString(
+ $stringOrStringRef, $name
+ );
+ $newMember->desiredCompressionLevel($compressionLevel);
+ return $self->addMember($newMember);
+}
+
+sub addDirectory {
+ my $self = shift;
+
+ my ( $name, $newName );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $name = $_[0]->{directoryName};
+ $newName = $_[0]->{zipName};
+ }
+ else {
+ ( $name, $newName ) = @_;
+ }
+
+ my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
+ if ( $self->{'storeSymbolicLink'} && -l $name ) {
+ my $link = readlink $name;
+ ( $newName =~ s{/$}{} ) if $newName; # Strip trailing /
+ my $newMember = $self->ZIPMEMBERCLASS->newFromString($link, $newName);
+ # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
+ $newMember->{'externalFileAttributes'} = 0xA1FF0000;
+ $self->addMember($newMember);
+ } else {
+ $self->addMember($newMember);
+ }
+ return $newMember;
+}
+
+# add either a file or a directory.
+
+sub addFileOrDirectory {
+ my $self = shift;
+
+ my ( $name, $newName, $compressionLevel );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $name = $_[0]->{name};
+ $newName = $_[0]->{zipName};
+ $compressionLevel = $_[0]->{compressionLevel};
+ }
+ else {
+ ( $name, $newName, $compressionLevel ) = @_;
+ }
+
+ $name =~ s{/$}{};
+ if ( $newName ) {
+ $newName =~ s{/$}{};
+ } else {
+ $newName = $name;
+ }
+ if ( -f $name ) {
+ return $self->addFile( $name, $newName, $compressionLevel );
+ }
+ elsif ( -d $name ) {
+ return $self->addDirectory( $name, $newName );
+ }
+ else {
+ return _error("$name is neither a file nor a directory");
+ }
+}
+
+sub contents {
+ my $self = shift;
+
+ my ( $member, $newContents );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $member = $_[0]->{memberOrZipName};
+ $newContents = $_[0]->{contents};
+ }
+ else {
+ ( $member, $newContents ) = @_;
+ }
+
+ return _error('No member name given') unless $member;
+ $member = $self->memberNamed($member) unless ref($member);
+ return undef unless $member;
+ return $member->contents($newContents);
+}
+
+sub writeToFileNamed {
+ my $self = shift;
+ my $fileName =
+ ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift; # local FS format
+ foreach my $member ( $self->members() ) {
+ if ( $member->_usesFileNamed($fileName) ) {
+ return _error( "$fileName is needed by member "
+ . $member->fileName()
+ . "; consider using overwrite() or overwriteAs() instead." );
+ }
+ }
+ my ( $status, $fh ) = _newFileHandle( $fileName, 'w' );
+ return _ioError("Can't open $fileName for write") unless $status;
+ my $retval = $self->writeToFileHandle( $fh, 1 );
+ $fh->close();
+ $fh = undef;
+
+ return $retval;
+}
+
+# It is possible to write data to the FH before calling this,
+# perhaps to make a self-extracting archive.
+sub writeToFileHandle {
+ my $self = shift;
+
+ my ( $fh, $fhIsSeekable );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $fh = $_[0]->{fileHandle};
+ $fhIsSeekable =
+ exists( $_[0]->{seek} ) ? $_[0]->{seek} : _isSeekable($fh);
+ }
+ else {
+ $fh = shift;
+ $fhIsSeekable = @_ ? shift : _isSeekable($fh);
+ }
+
+ return _error('No filehandle given') unless $fh;
+ return _ioError('filehandle not open') unless $fh->opened();
+ _binmode($fh);
+
+ # Find out where the current position is.
+ my $offset = $fhIsSeekable ? $fh->tell() : 0;
+ $offset = 0 if $offset < 0;
+
+ foreach my $member ( $self->members() ) {
+ my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
+ $member->endRead();
+ return $retval if $retval != AZ_OK;
+ $offset += $member->_localHeaderSize() + $member->_writeOffset();
+ $offset +=
+ $member->hasDataDescriptor()
+ ? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH
+ : 0;
+
+ # changed this so it reflects the last successful position
+ $self->{'writeCentralDirectoryOffset'} = $offset;
+ }
+ return $self->writeCentralDirectory($fh);
+}
+
+# Write zip back to the original file,
+# as safely as possible.
+# Returns AZ_OK if successful.
+sub overwrite {
+ my $self = shift;
+ return $self->overwriteAs( $self->{'fileName'} );
+}
+
+# Write zip to the specified file,
+# as safely as possible.
+# Returns AZ_OK if successful.
+sub overwriteAs {
+ my $self = shift;
+ my $zipName = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{filename} : shift;
+ return _error("no filename in overwriteAs()") unless defined($zipName);
+
+ my ( $fh, $tempName ) = Archive::Zip::tempFile();
+ return _error( "Can't open temp file", $! ) unless $fh;
+
+ ( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
+
+ my $status = $self->writeToFileHandle($fh);
+ $fh->close();
+ $fh = undef;
+
+ if ( $status != AZ_OK ) {
+ unlink($tempName);
+ _printError("Can't write to $tempName");
+ return $status;
+ }
+
+ my $err;
+
+ # rename the zip
+ if ( -f $zipName && !rename( $zipName, $backupName ) ) {
+ $err = $!;
+ unlink($tempName);
+ return _error( "Can't rename $zipName as $backupName", $err );
+ }
+
+ # move the temp to the original name (possibly copying)
+ unless ( File::Copy::move( $tempName, $zipName ) ) {
+ $err = $!;
+ rename( $backupName, $zipName );
+ unlink($tempName);
+ return _error( "Can't move $tempName to $zipName", $err );
+ }
+
+ # unlink the backup
+ if ( -f $backupName && !unlink($backupName) ) {
+ $err = $!;
+ return _error( "Can't unlink $backupName", $err );
+ }
+
+ return AZ_OK;
+}
+
+# Used only during writing
+sub _writeCentralDirectoryOffset {
+ shift->{'writeCentralDirectoryOffset'};
+}
+
+sub _writeEOCDOffset {
+ shift->{'writeEOCDOffset'};
+}
+
+# Expects to have _writeEOCDOffset() set
+sub _writeEndOfCentralDirectory {
+ my ( $self, $fh ) = @_;
+
+ $self->_print($fh, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
+ or return _ioError('writing EOCD Signature');
+ my $zipfileCommentLength = length( $self->zipfileComment() );
+
+ my $header = pack(
+ END_OF_CENTRAL_DIRECTORY_FORMAT,
+ 0, # {'diskNumber'},
+ 0, # {'diskNumberWithStartOfCentralDirectory'},
+ $self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'},
+ $self->numberOfMembers(), # {'numberOfCentralDirectories'},
+ $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
+ $self->_writeCentralDirectoryOffset(),
+ $zipfileCommentLength
+ );
+ $self->_print($fh, $header)
+ or return _ioError('writing EOCD header');
+ if ($zipfileCommentLength) {
+ $self->_print($fh, $self->zipfileComment() )
+ or return _ioError('writing zipfile comment');
+ }
+ return AZ_OK;
+}
+
+# $offset can be specified to truncate a zip file.
+sub writeCentralDirectory {
+ my $self = shift;
+
+ my ( $fh, $offset );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $fh = $_[0]->{fileHandle};
+ $offset = $_[0]->{offset};
+ }
+ else {
+ ( $fh, $offset ) = @_;
+ }
+
+ if ( defined($offset) ) {
+ $self->{'writeCentralDirectoryOffset'} = $offset;
+ $fh->seek( $offset, IO::Seekable::SEEK_SET )
+ or return _ioError('seeking to write central directory');
+ }
+ else {
+ $offset = $self->_writeCentralDirectoryOffset();
+ }
+
+ foreach my $member ( $self->members() ) {
+ my $status = $member->_writeCentralDirectoryFileHeader($fh);
+ return $status if $status != AZ_OK;
+ $offset += $member->_centralDirectoryHeaderSize();
+ $self->{'writeEOCDOffset'} = $offset;
+ }
+ return $self->_writeEndOfCentralDirectory($fh);
+}
+
+sub read {
+ my $self = shift;
+ my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift;
+ return _error('No filename given') unless $fileName;
+ my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
+ return _ioError("opening $fileName for read") unless $status;
+
+ $status = $self->readFromFileHandle( $fh, $fileName );
+ return $status if $status != AZ_OK;
+
+ $fh->close();
+ $self->{'fileName'} = $fileName;
+ return AZ_OK;
+}
+
+sub readFromFileHandle {
+ my $self = shift;
+
+ my ( $fh, $fileName );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $fh = $_[0]->{fileHandle};
+ $fileName = $_[0]->{filename};
+ }
+ else {
+ ( $fh, $fileName ) = @_;
+ }
+
+ $fileName = $fh unless defined($fileName);
+ return _error('No filehandle given') unless $fh;
+ return _ioError('filehandle not open') unless $fh->opened();
+
+ _binmode($fh);
+ $self->{'fileName'} = "$fh";
+
+ # TODO: how to support non-seekable zips?
+ return _error('file not seekable')
+ unless _isSeekable($fh);
+
+ $fh->seek( 0, 0 ); # rewind the file
+
+ my $status = $self->_findEndOfCentralDirectory($fh);
+ return $status if $status != AZ_OK;
+
+ my $eocdPosition = $fh->tell();
+
+ $status = $self->_readEndOfCentralDirectory($fh);
+ return $status if $status != AZ_OK;
+
+ $fh->seek( $eocdPosition - $self->centralDirectorySize(),
+ IO::Seekable::SEEK_SET )
+ or return _ioError("Can't seek $fileName");
+
+ # Try to detect garbage at beginning of archives
+ # This should be 0
+ $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
+ - $self->centralDirectoryOffsetWRTStartingDiskNumber();
+
+ for ( ; ; ) {
+ my $newMember =
+ $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
+ $self->eocdOffset() );
+ my $signature;
+ ( $status, $signature ) = _readSignature( $fh, $fileName );
+ return $status if $status != AZ_OK;
+ last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
+ $status = $newMember->_readCentralDirectoryFileHeader();
+ return $status if $status != AZ_OK;
+ $status = $newMember->endRead();
+ return $status if $status != AZ_OK;
+ $newMember->_becomeDirectoryIfNecessary();
+ push( @{ $self->{'members'} }, $newMember );
+ }
+
+ return AZ_OK;
+}
+
+# Read EOCD, starting from position before signature.
+# Return AZ_OK on success.
+sub _readEndOfCentralDirectory {
+ my $self = shift;
+ my $fh = shift;
+
+ # Skip past signature
+ $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
+ or return _ioError("Can't seek past EOCD signature");
+
+ my $header = '';
+ my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH );
+ if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH ) {
+ return _ioError("reading end of central directory");
+ }
+
+ my $zipfileCommentLength;
+ (
+ $self->{'diskNumber'},
+ $self->{'diskNumberWithStartOfCentralDirectory'},
+ $self->{'numberOfCentralDirectoriesOnThisDisk'},
+ $self->{'numberOfCentralDirectories'},
+ $self->{'centralDirectorySize'},
+ $self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
+ $zipfileCommentLength
+ ) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header );
+
+ if ($zipfileCommentLength) {
+ my $zipfileComment = '';
+ $bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
+ if ( $bytesRead != $zipfileCommentLength ) {
+ return _ioError("reading zipfile comment");
+ }
+ $self->{'zipfileComment'} = $zipfileComment;
+ }
+
+ return AZ_OK;
+}
+
+# Seek in my file to the end, then read backwards until we find the
+# signature of the central directory record. Leave the file positioned right
+# before the signature. Returns AZ_OK if success.
+sub _findEndOfCentralDirectory {
+ my $self = shift;
+ my $fh = shift;
+ my $data = '';
+ $fh->seek( 0, IO::Seekable::SEEK_END )
+ or return _ioError("seeking to end");
+
+ my $fileLength = $fh->tell();
+ if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 ) {
+ return _formatError("file is too short");
+ }
+
+ my $seekOffset = 0;
+ my $pos = -1;
+ for ( ; ; ) {
+ $seekOffset += 512;
+ $seekOffset = $fileLength if ( $seekOffset > $fileLength );
+ $fh->seek( -$seekOffset, IO::Seekable::SEEK_END )
+ or return _ioError("seek failed");
+ my $bytesRead = $fh->read( $data, $seekOffset );
+ if ( $bytesRead != $seekOffset ) {
+ return _ioError("read failed");
+ }
+ $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
+ last
+ if ( $pos >= 0
+ or $seekOffset == $fileLength
+ or $seekOffset >= $Archive::Zip::ChunkSize );
+ }
+
+ if ( $pos >= 0 ) {
+ $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
+ or return _ioError("seeking to EOCD");
+ return AZ_OK;
+ }
+ else {
+ return _formatError("can't find EOCD signature");
+ }
+}
+
+# Used to avoid taint problems when chdir'ing.
+# Not intended to increase security in any way; just intended to shut up the -T
+# complaints. If your Cwd module is giving you unreliable returns from cwd()
+# you have bigger problems than this.
+sub _untaintDir {
+ my $dir = shift;
+ $dir =~ m/\A(.+)\z/s;
+ return $1;
+}
+
+sub addTree {
+ my $self = shift;
+
+ my ( $root, $dest, $pred, $compressionLevel );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $root = $_[0]->{root};
+ $dest = $_[0]->{zipName};
+ $pred = $_[0]->{select};
+ $compressionLevel = $_[0]->{compressionLevel};
+ }
+ else {
+ ( $root, $dest, $pred, $compressionLevel ) = @_;
+ }
+
+ return _error("root arg missing in call to addTree()")
+ unless defined($root);
+ $dest = '' unless defined($dest);
+ $pred = sub { -r } unless defined($pred);
+
+ my @files;
+ my $startDir = _untaintDir( cwd() );
+
+ return _error( 'undef returned by _untaintDir on cwd ', cwd() )
+ unless $startDir;
+
+ # This avoids chdir'ing in Find, in a way compatible with older
+ # versions of File::Find.
+ my $wanted = sub {
+ local $main::_ = $File::Find::name;
+ my $dir = _untaintDir($File::Find::dir);
+ chdir($startDir);
+ push( @files, $File::Find::name ) if (&$pred);
+ chdir($dir);
+ };
+
+ File::Find::find( $wanted, $root );
+
+ my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
+ my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
+
+ $dest = _asZipDirName( $dest, 1 ); # with trailing slash
+
+ foreach my $fileName (@files) {
+ my $isDir = -d $fileName;
+
+ # normalize, remove leading ./
+ my $archiveName = _asZipDirName( $fileName, $isDir );
+ if ( $archiveName eq $rootZipName ) { $archiveName = $dest }
+ else { $archiveName =~ s{$pattern}{$dest} }
+ next if $archiveName =~ m{^\.?/?$}; # skip current dir
+ my $member = $isDir
+ ? $self->addDirectory( $fileName, $archiveName )
+ : $self->addFile( $fileName, $archiveName );
+ $member->desiredCompressionLevel($compressionLevel);
+
+ return _error("add $fileName failed in addTree()") if !$member;
+ }
+ return AZ_OK;
+}
+
+sub addTreeMatching {
+ my $self = shift;
+
+ my ( $root, $dest, $pattern, $pred, $compressionLevel );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $root = $_[0]->{root};
+ $dest = $_[0]->{zipName};
+ $pattern = $_[0]->{pattern};
+ $pred = $_[0]->{select};
+ $compressionLevel = $_[0]->{compressionLevel};
+ }
+ else {
+ ( $root, $dest, $pattern, $pred, $compressionLevel ) = @_;
+ }
+
+ return _error("root arg missing in call to addTreeMatching()")
+ unless defined($root);
+ $dest = '' unless defined($dest);
+ return _error("pattern missing in call to addTreeMatching()")
+ unless defined($pattern);
+ my $matcher =
+ $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
+ return $self->addTree( $root, $dest, $matcher, $compressionLevel );
+}
+
+# $zip->extractTree( $root, $dest [, $volume] );
+#
+# $root and $dest are Unix-style.
+# $volume is in local FS format.
+#
+sub extractTree {
+ my $self = shift;
+
+ my ( $root, $dest, $volume );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $root = $_[0]->{root};
+ $dest = $_[0]->{zipName};
+ $volume = $_[0]->{volume};
+ }
+ else {
+ ( $root, $dest, $volume ) = @_;
+ }
+
+ $root = '' unless defined($root);
+ $dest = './' unless defined($dest);
+ my $pattern = "^\Q$root";
+ my @members = $self->membersMatching($pattern);
+
+ foreach my $member (@members) {
+ my $fileName = $member->fileName(); # in Unix format
+ $fileName =~ s{$pattern}{$dest}; # in Unix format
+ # convert to platform format:
+ $fileName = Archive::Zip::_asLocalName( $fileName, $volume );
+ my $status = $member->extractToFileNamed($fileName);
+ return $status if $status != AZ_OK;
+ }
+ return AZ_OK;
+}
+
+# $zip->updateMember( $memberOrName, $fileName );
+# Returns (possibly updated) member, if any; undef on errors.
+
+sub updateMember {
+ my $self = shift;
+
+ my ( $oldMember, $fileName );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $oldMember = $_[0]->{memberOrZipName};
+ $fileName = $_[0]->{name};
+ }
+ else {
+ ( $oldMember, $fileName ) = @_;
+ }
+
+ if ( !defined($fileName) ) {
+ _error("updateMember(): missing fileName argument");
+ return undef;
+ }
+
+ my @newStat = stat($fileName);
+ if ( !@newStat ) {
+ _ioError("Can't stat $fileName");
+ return undef;
+ }
+
+ my $isDir = -d _;
+
+ my $memberName;
+
+ if ( ref($oldMember) ) {
+ $memberName = $oldMember->fileName();
+ }
+ else {
+ $oldMember = $self->memberNamed( $memberName = $oldMember )
+ || $self->memberNamed( $memberName =
+ _asZipDirName( $oldMember, $isDir ) );
+ }
+
+ unless ( defined($oldMember)
+ && $oldMember->lastModTime() == $newStat[9]
+ && $oldMember->isDirectory() == $isDir
+ && ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
+ {
+
+ # create the new member
+ my $newMember = $isDir
+ ? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
+ : $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
+
+ unless ( defined($newMember) ) {
+ _error("creation of member $fileName failed in updateMember()");
+ return undef;
+ }
+
+ # replace old member or append new one
+ if ( defined($oldMember) ) {
+ $self->replaceMember( $oldMember, $newMember );
+ }
+ else { $self->addMember($newMember); }
+
+ return $newMember;
+ }
+
+ return $oldMember;
+}
+
+# $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
+#
+# This takes the same arguments as addTree, but first checks to see
+# whether the file or directory already exists in the zip file.
+#
+# If the fourth argument $mirror is true, then delete all my members
+# if corresponding files weren't found.
+
+sub updateTree {
+ my $self = shift;
+
+ my ( $root, $dest, $pred, $mirror, $compressionLevel );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $root = $_[0]->{root};
+ $dest = $_[0]->{zipName};
+ $pred = $_[0]->{select};
+ $mirror = $_[0]->{mirror};
+ $compressionLevel = $_[0]->{compressionLevel};
+ }
+ else {
+ ( $root, $dest, $pred, $mirror, $compressionLevel ) = @_;
+ }
+
+ return _error("root arg missing in call to updateTree()")
+ unless defined($root);
+ $dest = '' unless defined($dest);
+ $pred = sub { -r } unless defined($pred);
+
+ $dest = _asZipDirName( $dest, 1 );
+ my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
+ my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
+
+ my @files;
+ my $startDir = _untaintDir( cwd() );
+
+ return _error( 'undef returned by _untaintDir on cwd ', cwd() )
+ unless $startDir;
+
+ # This avoids chdir'ing in Find, in a way compatible with older
+ # versions of File::Find.
+ my $wanted = sub {
+ local $main::_ = $File::Find::name;
+ my $dir = _untaintDir($File::Find::dir);
+ chdir($startDir);
+ push( @files, $File::Find::name ) if (&$pred);
+ chdir($dir);
+ };
+
+ File::Find::find( $wanted, $root );
+
+ # Now @files has all the files that I could potentially be adding to
+ # the zip. Only add the ones that are necessary.
+ # For each file (updated or not), add its member name to @done.
+ my %done;
+ foreach my $fileName (@files) {
+ my @newStat = stat($fileName);
+ my $isDir = -d _;
+
+ # normalize, remove leading ./
+ my $memberName = _asZipDirName( $fileName, $isDir );
+ if ( $memberName eq $rootZipName ) { $memberName = $dest }
+ else { $memberName =~ s{$pattern}{$dest} }
+ next if $memberName =~ m{^\.?/?$}; # skip current dir
+
+ $done{$memberName} = 1;
+ my $changedMember = $self->updateMember( $memberName, $fileName );
+ $changedMember->desiredCompressionLevel($compressionLevel);
+ return _error("updateTree failed to update $fileName")
+ unless ref($changedMember);
+ }
+
+ # @done now has the archive names corresponding to all the found files.
+ # If we're mirroring, delete all those members that aren't in @done.
+ if ($mirror) {
+ foreach my $member ( $self->members() ) {
+ $self->removeMember($member)
+ unless $done{ $member->fileName() };
+ }
+ }
+
+ return AZ_OK;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/BufferedFileHandle.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/BufferedFileHandle.pm
new file mode 100755
index 00000000000..4e56f9f007c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/BufferedFileHandle.pm
@@ -0,0 +1,131 @@
+package Archive::Zip::BufferedFileHandle;
+
+# File handle that uses a string internally and can seek
+# This is given as a demo for getting a zip file written
+# to a string.
+# I probably should just use IO::Scalar instead.
+# Ned Konz, March 2000
+
+use strict;
+use IO::File;
+use Carp;
+
+use vars qw{$VERSION};
+
+BEGIN {
+ $VERSION = '1.30';
+ $VERSION = eval $VERSION;
+}
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ $class = ref($class) || $class;
+ my $self = bless(
+ {
+ content => '',
+ position => 0,
+ size => 0
+ },
+ $class
+ );
+ return $self;
+}
+
+# Utility method to read entire file
+sub readFromFile {
+ my $self = shift;
+ my $fileName = shift;
+ my $fh = IO::File->new( $fileName, "r" );
+ CORE::binmode($fh);
+ if ( !$fh ) {
+ Carp::carp("Can't open $fileName: $!\n");
+ return undef;
+ }
+ local $/ = undef;
+ $self->{content} = <$fh>;
+ $self->{size} = length( $self->{content} );
+ return $self;
+}
+
+sub contents {
+ my $self = shift;
+ if (@_) {
+ $self->{content} = shift;
+ $self->{size} = length( $self->{content} );
+ }
+ return $self->{content};
+}
+
+sub binmode { 1 }
+
+sub close { 1 }
+
+sub opened { 1 }
+
+sub eof {
+ my $self = shift;
+ return $self->{position} >= $self->{size};
+}
+
+sub seek {
+ my $self = shift;
+ my $pos = shift;
+ my $whence = shift;
+
+ # SEEK_SET
+ if ( $whence == 0 ) { $self->{position} = $pos; }
+
+ # SEEK_CUR
+ elsif ( $whence == 1 ) { $self->{position} += $pos; }
+
+ # SEEK_END
+ elsif ( $whence == 2 ) { $self->{position} = $self->{size} + $pos; }
+ else { return 0; }
+
+ return 1;
+}
+
+sub tell { return shift->{position}; }
+
+# Copy my data to given buffer
+sub read {
+ my $self = shift;
+ my $buf = \( $_[0] );
+ shift;
+ my $len = shift;
+ my $offset = shift || 0;
+
+ $$buf = '' if not defined($$buf);
+ my $bytesRead =
+ ( $self->{position} + $len > $self->{size} )
+ ? ( $self->{size} - $self->{position} )
+ : $len;
+ substr( $$buf, $offset, $bytesRead ) =
+ substr( $self->{content}, $self->{position}, $bytesRead );
+ $self->{position} += $bytesRead;
+ return $bytesRead;
+}
+
+# Copy given buffer to me
+sub write {
+ my $self = shift;
+ my $buf = \( $_[0] );
+ shift;
+ my $len = shift;
+ my $offset = shift || 0;
+
+ $$buf = '' if not defined($$buf);
+ my $bufLen = length($$buf);
+ my $bytesWritten =
+ ( $offset + $len > $bufLen )
+ ? $bufLen - $offset
+ : $len;
+ substr( $self->{content}, $self->{position}, $bytesWritten ) =
+ substr( $$buf, $offset, $bytesWritten );
+ $self->{size} = length( $self->{content} );
+ return $bytesWritten;
+}
+
+sub clearerr() { 1 }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/DirectoryMember.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/DirectoryMember.pm
new file mode 100755
index 00000000000..c9d3705f08f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/DirectoryMember.pm
@@ -0,0 +1,80 @@
+package Archive::Zip::DirectoryMember;
+
+use strict;
+use File::Path;
+
+use vars qw( $VERSION @ISA );
+
+BEGIN {
+ $VERSION = '1.30';
+ @ISA = qw( Archive::Zip::Member );
+}
+
+use Archive::Zip qw(
+ :ERROR_CODES
+ :UTILITY_METHODS
+);
+
+sub _newNamed {
+ my $class = shift;
+ my $fileName = shift; # FS name
+ my $newName = shift; # Zip name
+ $newName = _asZipDirName($fileName) unless $newName;
+ my $self = $class->new(@_);
+ $self->{'externalFileName'} = $fileName;
+ $self->fileName($newName);
+
+ if ( -e $fileName ) {
+
+ # -e does NOT do a full stat, so we need to do one now
+ if ( -d _ ) {
+ my @stat = stat(_);
+ $self->unixFileAttributes( $stat[2] );
+ my $mod_t = $stat[9];
+ if ( $^O eq 'MSWin32' and !$mod_t ) {
+ $mod_t = time();
+ }
+ $self->setLastModFileDateTimeFromUnix($mod_t);
+
+ } else { # hmm.. trying to add a non-directory?
+ _error( $fileName, ' exists but is not a directory' );
+ return undef;
+ }
+ } else {
+ $self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS );
+ $self->setLastModFileDateTimeFromUnix( time() );
+ }
+ return $self;
+}
+
+sub externalFileName {
+ shift->{'externalFileName'};
+}
+
+sub isDirectory {
+ return 1;
+}
+
+sub extractToFileNamed {
+ my $self = shift;
+ my $name = shift; # local FS name
+ my $attribs = $self->unixFileAttributes() & 07777;
+ mkpath( $name, 0, $attribs ); # croaks on error
+ utime( $self->lastModTime(), $self->lastModTime(), $name );
+ return AZ_OK;
+}
+
+sub fileName {
+ my $self = shift;
+ my $newName = shift;
+ $newName =~ s{/?$}{/} if defined($newName);
+ return $self->SUPER::fileName($newName);
+}
+
+# So people don't get too confused. This way it looks like the problem
+# is in their code...
+sub contents {
+ return wantarray ? ( undef, AZ_OK ) : undef;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/FAQ.pod b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/FAQ.pod
new file mode 100755
index 00000000000..2b2d8ed9e88
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/FAQ.pod
@@ -0,0 +1,467 @@
+
+=head1 NAME
+
+
+Archive::Zip::FAQ - Answers to a few frequently asked questions about Archive::Zip
+
+=head1 DESCRIPTION
+
+
+It seems that I keep answering the same questions over and over again. I
+assume that this is because my documentation is deficient, rather than that
+people don't read the documentation.
+
+
+So this FAQ is an attempt to cut down on the number of personal answers I have
+to give. At least I can now say "You I<did> read the FAQ, right?".
+
+
+The questions are not in any particular order. The answers assume the current
+version of Archive::Zip; some of the answers depend on newly added/fixed
+functionality.
+
+=head1 Install problems on RedHat 8 or 9 with Perl 5.8.0
+
+
+B<Q:> Archive::Zip won't install on my RedHat 9 system! It's broke!
+
+
+B<A:> This has become something of a FAQ.
+Basically, RedHat broke some versions of Perl by setting LANG to UTF8.
+They apparently have a fixed version out as an update.
+
+You might try running CPAN or creating your Makefile after exporting the LANG
+environment variable as
+
+C<LANG=C>
+
+L<https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=87682>
+
+
+=head1 Why is my zip file so big?
+
+
+B<Q:> My zip file is actually bigger than what I stored in it! Why?
+
+
+B<A:> Some things to make sure of:
+
+=over 4
+
+=item Make sure that you are requesting COMPRESSION_DEFLATED if you are storing strings.
+
+
+
+
+$member->desiredCompressionMethod( COMPRESSION_DEFLATED );
+
+
+=item Don't make lots of little files if you can help it.
+
+
+
+Since zip computes the compression tables for each member, small
+members without much entropy won't compress well. Instead, if you've
+got lots of repeated strings in your data, try to combine them into
+one big member.
+
+
+=item Make sure that you are requesting COMPRESSION_STORED if you are storing things that are already compressed.
+
+
+
+If you're storing a .zip, .jpg, .mp3, or other compressed file in a zip,
+then don't compress them again. They'll get bigger.
+
+=back
+
+=head1 Sample code?
+
+
+B<Q:> Can you send me code to do (whatever)?
+
+
+B<A:> Have you looked in the C<examples/> directory yet? It contains:
+
+=over 4
+
+=item examples/calcSizes.pl -- How to find out how big a Zip file will be before writing it
+
+
+
+=item examples/copy.pl -- Copies one Zip file to another
+
+
+
+=item examples/extract.pl -- extract file(s) from a Zip
+
+
+
+=item examples/mailZip.pl -- make and mail a zip file
+
+
+
+=item examples/mfh.pl -- demo for use of MockFileHandle
+
+
+
+=item examples/readScalar.pl -- shows how to use IO::Scalar as the source of a Zip read
+
+
+
+=item examples/selfex.pl -- a brief example of a self-extracting Zip
+
+
+
+=item examples/unzipAll.pl -- uses Archive::Zip::Tree to unzip an entire Zip
+
+
+
+=item examples/updateZip.pl -- shows how to read/modify/write a Zip
+
+
+
+=item examples/updateTree.pl -- shows how to update a Zip in place
+
+
+
+=item examples/writeScalar.pl -- shows how to use IO::Scalar as the destination of a Zip write
+
+
+
+=item examples/writeScalar2.pl -- shows how to use IO::String as the destination of a Zip write
+
+
+
+=item examples/zip.pl -- Constructs a Zip file
+
+
+
+=item examples/zipcheck.pl -- One way to check a Zip file for validity
+
+
+
+=item examples/zipinfo.pl -- Prints out information about a Zip archive file
+
+
+
+=item examples/zipGrep.pl -- Searches for text in Zip files
+
+
+
+=item examples/ziptest.pl -- Lists a Zip file and checks member CRCs
+
+
+
+=item examples/ziprecent.pl -- Puts recent files into a zipfile
+
+
+
+=item examples/ziptest.pl -- Another way to check a Zip file for validity
+
+
+
+=back
+
+=head1 Can't Read/modify/write same Zip file
+
+
+B<Q:> Why can't I open a Zip file, add a member, and write it back? I get an
+error message when I try.
+
+
+B<A:> Because Archive::Zip doesn't (and can't, generally) read file contents into memory,
+the original Zip file is required to stay around until the writing of the new
+file is completed.
+
+
+The best way to do this is to write the Zip to a temporary file and then
+rename the temporary file to have the old name (possibly after deleting the
+old one).
+
+
+Archive::Zip v1.02 added the archive methods C<overwrite()> and
+C<overwriteAs()> to do this simply and carefully.
+
+
+See C<examples/updateZip.pl> for an example of this technique.
+
+=head1 File creation time not set
+
+
+B<Q:> Upon extracting files, I see that their modification (and access) times are
+set to the time in the Zip archive. However, their creation time is not set to
+the same time. Why?
+
+
+B<A:> Mostly because Perl doesn't give cross-platform access to I<creation time>.
+Indeed, many systems (like Unix) don't support such a concept.
+However, if yours does, you can easily set it. Get the modification time from
+the member using C<lastModTime()>.
+
+=head1 Can't use Archive::Zip on gzip files
+
+
+B<Q:> Can I use Archive::Zip to extract Unix gzip files?
+
+
+B<A:> No.
+
+
+There is a distinction between Unix gzip files, and Zip archives that
+also can use the gzip compression.
+
+
+Depending on the format of the gzip file, you can use L<Compress::Raw::Zlib>, or
+L<Archive::Tar> to decompress it (and de-archive it in the case of Tar files).
+
+
+You can unzip PKZIP/WinZip/etc/ archives using Archive::Zip (that's what
+it's for) as long as any compressed members are compressed using
+Deflate compression.
+
+=head1 Add a directory/tree to a Zip
+
+
+B<Q:> How can I add a directory (or tree) full of files to a Zip?
+
+
+B<A:> You can use the Archive::Zip::addTree*() methods:
+
+ use Archive::Zip;
+ my $zip = Archive::Zip->new();
+ # add all readable files and directories below . as xyz/*
+ $zip->addTree( '.', 'xyz' );
+ # add all readable plain files below /abc as def/*
+ $zip->addTree( '/abc', 'def', sub { -f && -r } );
+ # add all .c files below /tmp as stuff/*
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' );
+ # add all .o files below /tmp as stuff/* if they aren't writable
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } );
+ # add all .so files below /tmp that are smaller than 200 bytes as stuff/*
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } );
+ # and write them into a file
+ $zip->writeToFileNamed('xxx.zip');
+
+=head1 Extract a directory/tree
+
+
+B<Q:> How can I extract some (or all) files from a Zip into a different
+directory?
+
+
+B<A:> You can use the Archive::Zip::extractTree() method:
+??? ||
+
+
+ # now extract the same files into /tmpx
+ $zip->extractTree( 'stuff', '/tmpx' );
+
+=head1 Update a directory/tree
+
+
+B<Q:> How can I update a Zip from a directory tree, adding or replacing only
+the newer files?
+
+
+B<A:> You can use the Archive::Zip::updateTree() method that was added in version 1.09.
+
+=head1 Zip times might be off by 1 second
+
+
+B<Q:> It bothers me greatly that my file times are wrong by one second about half
+the time. Why don't you do something about it?
+
+
+B<A:> Get over it. This is a result of the Zip format storing times in DOS
+format, which has a resolution of only two seconds.
+
+=head1 Zip times don't include time zone information
+
+
+B<Q:> My file times don't respect time zones. What gives?
+
+
+B<A:> If this is important to you, please submit patches to read the various
+Extra Fields that encode times with time zones. I'm just using the DOS
+Date/Time, which doesn't have a time zone.
+
+=head1 How do I make a self-extracting Zip
+
+
+B<Q:> I want to make a self-extracting Zip file. Can I do this?
+
+
+B<A:> Yes. You can write a self-extracting archive stub (that is, a version of
+unzip) to the output filehandle that you pass to writeToFileHandle(). See
+examples/selfex.pl for how to write a self-extracting archive.
+
+
+However, you should understand that this will only work on one kind of
+platform (the one for which the stub was compiled).
+
+=head1 How can I deal with Zips with prepended garbage (i.e. from Sircam)
+
+
+B<Q:> How can I tell if a Zip has been damaged by adding garbage to the
+beginning or inside the file?
+
+
+B<A:> I added code for this for the Amavis virus scanner. You can query archives
+for their 'eocdOffset' property, which should be 0:
+
+
+ if ($zip->eocdOffset > 0)
+ { warn($zip->eocdOffset . " bytes of garbage at beginning or within Zip") }
+
+
+When members are extracted, this offset will be used to adjust the start of
+the member if necessary.
+
+=head1 Can't extract Shrunk files
+
+
+B<Q:> I'm trying to extract a file out of a Zip produced by PKZIP, and keep
+getting this error message:
+
+
+ error: Unsupported compression combination: read 6, write 0
+
+
+B<A:> You can't uncompress this archive member. Archive::Zip only supports uncompressed
+members, and compressed members that are compressed using the compression
+supported by Compress::Raw::Zlib. That means only Deflated and Stored members.
+
+
+Your file is compressed using the Shrink format, which isn't supported by
+Compress::Raw::Zlib.
+
+
+You could, perhaps, use a command-line UnZip program (like the Info-Zip
+one) to extract this.
+
+=head1 Can't do decryption
+
+
+B<Q:> How do I decrypt encrypted Zip members?
+
+
+B<A:> With some other program or library. Archive::Zip doesn't support decryption,
+and probably never will (unless I<you> write it).
+
+=head1 How to test file integrity?
+
+
+B<Q:> How can Archive::Zip can test the validity of a Zip file?
+
+
+B<A:> If you try to decompress the file, the gzip streams will report errors
+if you have garbage. Most of the time.
+
+If you try to open the file and a central directory structure can't be
+found, an error will be reported.
+
+When a file is being read, if we can't find a proper PK.. signature in
+the right places we report a format error.
+
+If there is added garbage at the beginning of a Zip file (as inserted
+by some viruses), you can find out about it, but Archive::Zip will ignore it,
+and you can still use the archive. When it gets written back out the
+added stuff will be gone.
+
+
+There are two ready-to-use utilities in the examples directory that can
+be used to test file integrity, or that you can use as examples
+for your own code:
+
+=over 4
+
+=item examples/zipcheck.pl shows how to use an attempted extraction to test a file.
+
+
+
+=item examples/ziptest.pl shows how to test CRCs in a file.
+
+
+
+=back
+
+=head1 Duplicate files in Zip?
+
+
+B<Q:> Archive::Zip let me put the same file in my Zip twice! Why don't you prevent this?
+
+
+B<A:> As far as I can tell, this is not disallowed by the Zip spec. If you
+think it's a bad idea, check for it yourself:
+
+
+ $zip->addFile($someFile, $someName) unless $zip->memberNamed($someName);
+
+
+I can even imagine cases where this might be useful (for instance, multiple
+versions of files).
+
+=head1 File ownership/permissions/ACLS/etc
+
+
+B<Q:> Why doesn't Archive::Zip deal with file ownership, ACLs, etc.?
+
+
+B<A:> There is no standard way to represent these in the Zip file format. If
+you want to send me code to properly handle the various extra fields that
+have been used to represent these through the years, I'll look at it.
+
+=head1 I can't compile but ActiveState only has an old version of Archive::Zip
+
+
+B<Q:> I've only installed modules using ActiveState's PPM program and
+repository. But they have a much older version of Archive::Zip than is in CPAN. Will
+you send me a newer PPM?
+
+
+B<A:> Probably not, unless I get lots of extra time. But there's no reason you
+can't install the version from CPAN. Archive::Zip is pure Perl, so all you need is
+NMAKE, which you can get for free from Microsoft (see the FAQ in the
+ActiveState documentation for details on how to install CPAN modules).
+
+=head1 My JPEGs (or MP3's) don't compress when I put them into Zips!
+
+
+B<Q:> How come my JPEGs and MP3's don't compress much when I put them into Zips?
+
+
+B<A:> Because they're already compressed.
+
+=head1 Under Windows, things lock up/get damaged
+
+
+B<Q:> I'm using Windows. When I try to use Archive::Zip, my machine locks up/makes
+funny sounds/displays a BSOD/corrupts data. How can I fix this?
+
+
+B<A:> First, try the newest version of Compress::Raw::Zlib. I know of
+Windows-related problems prior to v1.14 of that library.
+
+
+If that doesn't get rid of the problem, fix your computer or get rid of
+Windows.
+
+=head1 Zip contents in a scalar
+
+
+B<Q:> I want to read a Zip file from (or write one to) a scalar variable instead
+of a file. How can I do this?
+
+
+B<A:> Use C<IO::String> and the C<readFromFileHandle()> and
+C<writeToFileHandle()> methods.
+See C<examples/readScalar.pl> and C<examples/writeScalar.pl>.
+
+=head1 Reading from streams
+
+
+B<Q:> How do I read from a stream (like for the Info-Zip C<funzip> program)?
+
+
+B<A:> This isn't currently supported, though writing to a stream is.
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/FileMember.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/FileMember.pm
new file mode 100755
index 00000000000..a9b8cf5d7be
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/FileMember.pm
@@ -0,0 +1,64 @@
+package Archive::Zip::FileMember;
+
+use strict;
+use vars qw( $VERSION @ISA );
+
+BEGIN {
+ $VERSION = '1.30';
+ @ISA = qw ( Archive::Zip::Member );
+}
+
+use Archive::Zip qw(
+ :UTILITY_METHODS
+);
+
+sub externalFileName {
+ shift->{'externalFileName'};
+}
+
+# Return true if I depend on the named file
+sub _usesFileNamed {
+ my $self = shift;
+ my $fileName = shift;
+ my $xfn = $self->externalFileName();
+ return undef if ref($xfn);
+ return $xfn eq $fileName;
+}
+
+sub fh {
+ my $self = shift;
+ $self->_openFile()
+ if !defined( $self->{'fh'} ) || !$self->{'fh'}->opened();
+ return $self->{'fh'};
+}
+
+# opens my file handle from my file name
+sub _openFile {
+ my $self = shift;
+ my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' );
+ if ( !$status ) {
+ _ioError( "Can't open", $self->externalFileName() );
+ return undef;
+ }
+ $self->{'fh'} = $fh;
+ _binmode($fh);
+ return $fh;
+}
+
+# Make sure I close my file handle
+sub endRead {
+ my $self = shift;
+ undef $self->{'fh'}; # _closeFile();
+ return $self->SUPER::endRead(@_);
+}
+
+sub _become {
+ my $self = shift;
+ my $newClass = shift;
+ return $self if ref($self) eq $newClass;
+ delete( $self->{'externalFileName'} );
+ delete( $self->{'fh'} );
+ return $self->SUPER::_become($newClass);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Member.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Member.pm
new file mode 100755
index 00000000000..f86ef75d55d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Member.pm
@@ -0,0 +1,1083 @@
+package Archive::Zip::Member;
+
+# A generic membet of an archive
+
+use strict;
+use vars qw( $VERSION @ISA );
+
+BEGIN {
+ $VERSION = '1.30';
+ @ISA = qw( Archive::Zip );
+}
+
+use Archive::Zip qw(
+ :CONSTANTS
+ :MISC_CONSTANTS
+ :ERROR_CODES
+ :PKZIP_CONSTANTS
+ :UTILITY_METHODS
+);
+
+use Time::Local ();
+use Compress::Raw::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
+use File::Path;
+use File::Basename;
+
+use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember';
+use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember';
+use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember';
+use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember';
+
+# Unix perms for default creation of files/dirs.
+use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
+use constant DEFAULT_FILE_PERMISSIONS => 0100666;
+use constant DIRECTORY_ATTRIB => 040000;
+use constant FILE_ATTRIB => 0100000;
+
+# Returns self if successful, else undef
+# Assumes that fh is positioned at beginning of central directory file header.
+# Leaves fh positioned immediately after file header or EOCD signature.
+sub _newFromZipFile {
+ my $class = shift;
+ my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_);
+ return $self;
+}
+
+sub newFromString {
+ my $class = shift;
+
+ my ( $stringOrStringRef, $fileName );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $stringOrStringRef = $_[0]->{string};
+ $fileName = $_[0]->{zipName};
+ }
+ else {
+ ( $stringOrStringRef, $fileName ) = @_;
+ }
+
+ my $self = $class->STRINGMEMBERCLASS->_newFromString( $stringOrStringRef,
+ $fileName );
+ return $self;
+}
+
+sub newFromFile {
+ my $class = shift;
+
+ my ( $fileName, $zipName );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $fileName = $_[0]->{fileName};
+ $zipName = $_[0]->{zipName};
+ }
+ else {
+ ( $fileName, $zipName ) = @_;
+ }
+
+ my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed( $fileName,
+ $zipName );
+ return $self;
+}
+
+sub newDirectoryNamed {
+ my $class = shift;
+
+ my ( $directoryName, $newName );
+ if ( ref( $_[0] ) eq 'HASH' ) {
+ $directoryName = $_[0]->{directoryName};
+ $newName = $_[0]->{zipName};
+ }
+ else {
+ ( $directoryName, $newName ) = @_;
+ }
+
+ my $self = $class->DIRECTORYMEMBERCLASS->_newNamed( $directoryName,
+ $newName );
+ return $self;
+}
+
+sub new {
+ my $class = shift;
+ my $self = {
+ 'lastModFileDateTime' => 0,
+ 'fileAttributeFormat' => FA_UNIX,
+ 'versionMadeBy' => 20,
+ 'versionNeededToExtract' => 20,
+ 'bitFlag' => 0,
+ 'compressionMethod' => COMPRESSION_STORED,
+ 'desiredCompressionMethod' => COMPRESSION_STORED,
+ 'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
+ 'internalFileAttributes' => 0,
+ 'externalFileAttributes' => 0, # set later
+ 'fileName' => '',
+ 'cdExtraField' => '',
+ 'localExtraField' => '',
+ 'fileComment' => '',
+ 'crc32' => 0,
+ 'compressedSize' => 0,
+ 'uncompressedSize' => 0,
+ 'isSymbolicLink' => 0,
+ @_
+ };
+ bless( $self, $class );
+ $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
+ return $self;
+}
+
+sub _becomeDirectoryIfNecessary {
+ my $self = shift;
+ $self->_become(DIRECTORYMEMBERCLASS)
+ if $self->isDirectory();
+ return $self;
+}
+
+# Morph into given class (do whatever cleanup I need to do)
+sub _become {
+ return bless( $_[0], $_[1] );
+}
+
+sub versionMadeBy {
+ shift->{'versionMadeBy'};
+}
+
+sub fileAttributeFormat {
+ my $self = shift;
+
+ if (@_) {
+ $self->{fileAttributeFormat} = ( ref( $_[0] ) eq 'HASH' )
+ ? $_[0]->{format} : $_[0];
+ }
+ else {
+ return $self->{fileAttributeFormat};
+ }
+}
+
+sub versionNeededToExtract {
+ shift->{'versionNeededToExtract'};
+}
+
+sub bitFlag {
+ my $self = shift;
+
+ # Set General Purpose Bit Flags according to the desiredCompressionLevel setting
+ if ( $self->desiredCompressionLevel == 1 || $self->desiredCompressionLevel == 2 ) {
+ $self->{'bitFlag'} = DEFLATING_COMPRESSION_FAST;
+ } elsif ( $self->desiredCompressionLevel == 3 || $self->desiredCompressionLevel == 4
+ || $self->desiredCompressionLevel == 5 || $self->desiredCompressionLevel == 6
+ || $self->desiredCompressionLevel == 7 ) {
+ $self->{'bitFlag'} = DEFLATING_COMPRESSION_NORMAL;
+ } elsif ( $self->desiredCompressionLevel == 8 || $self->desiredCompressionLevel == 9 ) {
+ $self->{'bitFlag'} = DEFLATING_COMPRESSION_MAXIMUM;
+ }
+ $self->{'bitFlag'};
+}
+
+sub compressionMethod {
+ shift->{'compressionMethod'};
+}
+
+sub desiredCompressionMethod {
+ my $self = shift;
+ my $newDesiredCompressionMethod =
+ ( ref( $_[0] ) eq 'HASH' ) ? shift->{compressionMethod} : shift;
+ my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
+ if ( defined($newDesiredCompressionMethod) ) {
+ $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
+ if ( $newDesiredCompressionMethod == COMPRESSION_STORED ) {
+ $self->{'desiredCompressionLevel'} = 0;
+ $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
+
+ } elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) {
+ $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
+ }
+ }
+ return $oldDesiredCompressionMethod;
+}
+
+sub desiredCompressionLevel {
+ my $self = shift;
+ my $newDesiredCompressionLevel =
+ ( ref( $_[0] ) eq 'HASH' ) ? shift->{compressionLevel} : shift;
+ my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
+ if ( defined($newDesiredCompressionLevel) ) {
+ $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
+ $self->{'desiredCompressionMethod'} = (
+ $newDesiredCompressionLevel
+ ? COMPRESSION_DEFLATED
+ : COMPRESSION_STORED
+ );
+ }
+ return $oldDesiredCompressionLevel;
+}
+
+sub fileName {
+ my $self = shift;
+ my $newName = shift;
+ if ($newName) {
+ $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems
+ $self->{'fileName'} = $newName;
+ }
+ return $self->{'fileName'};
+}
+
+sub lastModFileDateTime {
+ my $modTime = shift->{'lastModFileDateTime'};
+ $modTime =~ m/^(\d+)$/; # untaint
+ return $1;
+}
+
+sub lastModTime {
+ my $self = shift;
+ return _dosToUnixTime( $self->lastModFileDateTime() );
+}
+
+sub setLastModFileDateTimeFromUnix {
+ my $self = shift;
+ my $time_t = shift;
+ $self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
+}
+
+sub internalFileAttributes {
+ shift->{'internalFileAttributes'};
+}
+
+sub externalFileAttributes {
+ shift->{'externalFileAttributes'};
+}
+
+# Convert UNIX permissions into proper value for zip file
+# Usable as a function or a method
+sub _mapPermissionsFromUnix {
+ my $self = shift;
+ my $mode = shift;
+ my $attribs = $mode << 16;
+
+ # Microsoft Windows Explorer needs this bit set for directories
+ if ( $mode & DIRECTORY_ATTRIB ) {
+ $attribs |= 16;
+ }
+
+ return $attribs;
+
+ # TODO: map more MS-DOS perms
+}
+
+# Convert ZIP permissions into Unix ones
+#
+# This was taken from Info-ZIP group's portable UnZip
+# zipfile-extraction program, version 5.50.
+# http://www.info-zip.org/pub/infozip/
+#
+# See the mapattr() function in unix/unix.c
+# See the attribute format constants in unzpriv.h
+#
+# XXX Note that there's one situation that isn't implemented
+# yet that depends on the "extra field."
+sub _mapPermissionsToUnix {
+ my $self = shift;
+
+ my $format = $self->{'fileAttributeFormat'};
+ my $attribs = $self->{'externalFileAttributes'};
+
+ my $mode = 0;
+
+ if ( $format == FA_AMIGA ) {
+ $attribs = $attribs >> 17 & 7; # Amiga RWE bits
+ $mode = $attribs << 6 | $attribs << 3 | $attribs;
+ return $mode;
+ }
+
+ if ( $format == FA_THEOS ) {
+ $attribs &= 0xF1FFFFFF;
+ if ( ( $attribs & 0xF0000000 ) != 0x40000000 ) {
+ $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits
+ }
+ else {
+ $attribs &= 0x41FFFFFF; # leave directory bit as set
+ }
+ }
+
+ if ( $format == FA_UNIX
+ || $format == FA_VAX_VMS
+ || $format == FA_ACORN
+ || $format == FA_ATARI_ST
+ || $format == FA_BEOS
+ || $format == FA_QDOS
+ || $format == FA_TANDEM )
+ {
+ $mode = $attribs >> 16;
+ return $mode if $mode != 0 or not $self->localExtraField;
+
+ # warn("local extra field is: ", $self->localExtraField, "\n");
+
+ # XXX This condition is not implemented
+ # I'm just including the comments from the info-zip section for now.
+
+ # Some (non-Info-ZIP) implementations of Zip for Unix and
+ # VMS (and probably others ??) leave 0 in the upper 16-bit
+ # part of the external_file_attributes field. Instead, they
+ # store file permission attributes in some extra field.
+ # As a work-around, we search for the presence of one of
+ # these extra fields and fall back to the MSDOS compatible
+ # part of external_file_attributes if one of the known
+ # e.f. types has been detected.
+ # Later, we might implement extraction of the permission
+ # bits from the VMS extra field. But for now, the work-around
+ # should be sufficient to provide "readable" extracted files.
+ # (For ASI Unix e.f., an experimental remap from the e.f.
+ # mode value IS already provided!)
+ }
+
+ # PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the
+ # Unix attributes in the upper 16 bits of the external attributes
+ # field, just like Info-ZIP's Zip for Unix. We try to use that
+ # value, after a check for consistency with the MSDOS attribute
+ # bits (see below).
+ if ( $format == FA_MSDOS ) {
+ $mode = $attribs >> 16;
+ }
+
+ # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
+ $attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4;
+
+ # keep previous $mode setting when its "owner"
+ # part appears to be consistent with DOS attribute flags!
+ return $mode if ( $mode & 0700 ) == ( 0400 | $attribs << 6 );
+ $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
+ return $mode;
+}
+
+sub unixFileAttributes {
+ my $self = shift;
+ my $oldPerms = $self->_mapPermissionsToUnix;
+
+ my $perms;
+ if ( @_ ) {
+ $perms = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{attributes} : $_[0];
+
+ if ( $self->isDirectory ) {
+ $perms &= ~FILE_ATTRIB;
+ $perms |= DIRECTORY_ATTRIB;
+ } else {
+ $perms &= ~DIRECTORY_ATTRIB;
+ $perms |= FILE_ATTRIB;
+ }
+ $self->{externalFileAttributes} = $self->_mapPermissionsFromUnix($perms);
+ }
+
+ return $oldPerms;
+}
+
+sub localExtraField {
+ my $self = shift;
+
+ if (@_) {
+ $self->{localExtraField} = ( ref( $_[0] ) eq 'HASH' )
+ ? $_[0]->{field} : $_[0];
+ }
+ else {
+ return $self->{localExtraField};
+ }
+}
+
+sub cdExtraField {
+ my $self = shift;
+
+ if (@_) {
+ $self->{cdExtraField} = ( ref( $_[0] ) eq 'HASH' )
+ ? $_[0]->{field} : $_[0];
+ }
+ else {
+ return $self->{cdExtraField};
+ }
+}
+
+sub extraFields {
+ my $self = shift;
+ return $self->localExtraField() . $self->cdExtraField();
+}
+
+sub fileComment {
+ my $self = shift;
+
+ if (@_) {
+ $self->{fileComment} = ( ref( $_[0] ) eq 'HASH' )
+ ? pack( 'C0a*', $_[0]->{comment} ) : pack( 'C0a*', $_[0] );
+ }
+ else {
+ return $self->{fileComment};
+ }
+}
+
+sub hasDataDescriptor {
+ my $self = shift;
+ if (@_) {
+ my $shouldHave = shift;
+ if ($shouldHave) {
+ $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
+ }
+ else {
+ $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
+ }
+ }
+ return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
+}
+
+sub crc32 {
+ shift->{'crc32'};
+}
+
+sub crc32String {
+ sprintf( "%08x", shift->{'crc32'} );
+}
+
+sub compressedSize {
+ shift->{'compressedSize'};
+}
+
+sub uncompressedSize {
+ shift->{'uncompressedSize'};
+}
+
+sub isEncrypted {
+ shift->bitFlag() & GPBF_ENCRYPTED_MASK;
+}
+
+sub isTextFile {
+ my $self = shift;
+ my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
+ if (@_) {
+ my $flag = ( ref( $_[0] ) eq 'HASH' ) ? shift->{flag} : shift;
+ $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
+ $self->{'internalFileAttributes'} |=
+ ( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE );
+ }
+ return $bit == IFA_TEXT_FILE;
+}
+
+sub isBinaryFile {
+ my $self = shift;
+ my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
+ if (@_) {
+ my $flag = shift;
+ $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
+ $self->{'internalFileAttributes'} |=
+ ( $flag ? IFA_BINARY_FILE: IFA_TEXT_FILE );
+ }
+ return $bit == IFA_BINARY_FILE;
+}
+
+sub extractToFileNamed {
+ my $self = shift;
+
+ # local FS name
+ my $name = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{name} : $_[0];
+ $self->{'isSymbolicLink'} = 0;
+
+ # Check if the file / directory is a symbolic link or not
+ if ( $self->{'externalFileAttributes'} == 0xA1FF0000 ) {
+ $self->{'isSymbolicLink'} = 1;
+ $self->{'newName'} = $name;
+ my ( $status, $fh ) = _newFileHandle( $name, 'r' );
+ my $retval = $self->extractToFileHandle($fh);
+ $fh->close();
+ } else {
+ #return _writeSymbolicLink($self, $name) if $self->isSymbolicLink();
+ return _error("encryption unsupported") if $self->isEncrypted();
+ mkpath( dirname($name) ); # croaks on error
+ my ( $status, $fh ) = _newFileHandle( $name, 'w' );
+ return _ioError("Can't open file $name for write") unless $status;
+ my $retval = $self->extractToFileHandle($fh);
+ $fh->close();
+ chmod ($self->unixFileAttributes(), $name)
+ or return _error("Can't chmod() ${name}: $!");
+ utime( $self->lastModTime(), $self->lastModTime(), $name );
+ return $retval;
+ }
+}
+
+sub _writeSymbolicLink {
+ my $self = shift;
+ my $name = shift;
+ my $chunkSize = $Archive::Zip::ChunkSize;
+ #my ( $outRef, undef ) = $self->readChunk($chunkSize);
+ my $fh;
+ my $retval = $self->extractToFileHandle($fh);
+ my ( $outRef, undef ) = $self->readChunk(100);
+}
+
+sub isSymbolicLink {
+ my $self = shift;
+ if ( $self->{'externalFileAttributes'} == 0xA1FF0000 ) {
+ $self->{'isSymbolicLink'} = 1;
+ } else {
+ return 0;
+ }
+ 1;
+}
+
+sub isDirectory {
+ return 0;
+}
+
+sub externalFileName {
+ return undef;
+}
+
+# The following are used when copying data
+sub _writeOffset {
+ shift->{'writeOffset'};
+}
+
+sub _readOffset {
+ shift->{'readOffset'};
+}
+
+sub writeLocalHeaderRelativeOffset {
+ shift->{'writeLocalHeaderRelativeOffset'};
+}
+
+sub wasWritten { shift->{'wasWritten'} }
+
+sub _dataEnded {
+ shift->{'dataEnded'};
+}
+
+sub _readDataRemaining {
+ shift->{'readDataRemaining'};
+}
+
+sub _inflater {
+ shift->{'inflater'};
+}
+
+sub _deflater {
+ shift->{'deflater'};
+}
+
+# Return the total size of my local header
+sub _localHeaderSize {
+ my $self = shift;
+ return SIGNATURE_LENGTH + LOCAL_FILE_HEADER_LENGTH +
+ length( $self->fileName() ) + length( $self->localExtraField() );
+}
+
+# Return the total size of my CD header
+sub _centralDirectoryHeaderSize {
+ my $self = shift;
+ return SIGNATURE_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH +
+ length( $self->fileName() ) + length( $self->cdExtraField() ) +
+ length( $self->fileComment() );
+}
+
+# DOS date/time format
+# 0-4 (5) Second divided by 2
+# 5-10 (6) Minute (0-59)
+# 11-15 (5) Hour (0-23 on a 24-hour clock)
+# 16-20 (5) Day of the month (1-31)
+# 21-24 (4) Month (1 = January, 2 = February, etc.)
+# 25-31 (7) Year offset from 1980 (add 1980 to get actual year)
+
+# Convert DOS date/time format to unix time_t format
+# NOT AN OBJECT METHOD!
+sub _dosToUnixTime {
+ my $dt = shift;
+ return time() unless defined($dt);
+
+ my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
+ my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
+ my $mday = ( ( $dt >> 16 ) & 0x1f );
+
+ my $hour = ( ( $dt >> 11 ) & 0x1f );
+ my $min = ( ( $dt >> 5 ) & 0x3f );
+ my $sec = ( ( $dt << 1 ) & 0x3e );
+
+ # catch errors
+ my $time_t =
+ eval { Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); };
+ return time() if ($@);
+ return $time_t;
+}
+
+# Note, this isn't exactly UTC 1980, it's 1980 + 12 hours and 1
+# minute so that nothing timezoney can muck us up.
+my $safe_epoch = 315576060;
+
+# convert a unix time to DOS date/time
+# NOT AN OBJECT METHOD!
+sub _unixToDosTime {
+ my $time_t = shift;
+ unless ($time_t) {
+ _error("Tried to add member with zero or undef value for time");
+ $time_t = $safe_epoch;
+ }
+ if ( $time_t < $safe_epoch ) {
+ _ioError("Unsupported date before 1980 encountered, moving to 1980");
+ $time_t = $safe_epoch;
+ }
+ my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
+ my $dt = 0;
+ $dt += ( $sec >> 1 );
+ $dt += ( $min << 5 );
+ $dt += ( $hour << 11 );
+ $dt += ( $mday << 16 );
+ $dt += ( ( $mon + 1 ) << 21 );
+ $dt += ( ( $year - 80 ) << 25 );
+ return $dt;
+}
+
+# Write my local header to a file handle.
+# Stores the offset to the start of the header in my
+# writeLocalHeaderRelativeOffset member.
+# Returns AZ_OK on success.
+sub _writeLocalFileHeader {
+ my $self = shift;
+ my $fh = shift;
+
+ my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
+ $self->_print($fh, $signatureData)
+ or return _ioError("writing local header signature");
+
+ my $header = pack(
+ LOCAL_FILE_HEADER_FORMAT,
+ $self->versionNeededToExtract(),
+ $self->bitFlag(),
+ $self->desiredCompressionMethod(),
+ $self->lastModFileDateTime(),
+ $self->crc32(),
+ $self->compressedSize(), # may need to be re-written later
+ $self->uncompressedSize(),
+ length( $self->fileName() ),
+ length( $self->localExtraField() )
+ );
+
+ $self->_print($fh, $header) or return _ioError("writing local header");
+
+ # Check for a valid filename or a filename equal to a literal `0'
+ if ( $self->fileName() || $self->fileName eq '0' ) {
+ $self->_print($fh, $self->fileName() )
+ or return _ioError("writing local header filename");
+ }
+ if ( $self->localExtraField() ) {
+ $self->_print($fh, $self->localExtraField() )
+ or return _ioError("writing local extra field");
+ }
+
+ return AZ_OK;
+}
+
+sub _writeCentralDirectoryFileHeader {
+ my $self = shift;
+ my $fh = shift;
+
+ my $sigData =
+ pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
+ $self->_print($fh, $sigData)
+ or return _ioError("writing central directory header signature");
+
+ my $fileNameLength = length( $self->fileName() );
+ my $extraFieldLength = length( $self->cdExtraField() );
+ my $fileCommentLength = length( $self->fileComment() );
+
+ my $header = pack(
+ CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
+ $self->versionMadeBy(),
+ $self->fileAttributeFormat(),
+ $self->versionNeededToExtract(),
+ $self->bitFlag(),
+ $self->desiredCompressionMethod(),
+ $self->lastModFileDateTime(),
+ $self->crc32(), # these three fields should have been updated
+ $self->_writeOffset(), # by writing the data stream out
+ $self->uncompressedSize(), #
+ $fileNameLength,
+ $extraFieldLength,
+ $fileCommentLength,
+ 0, # {'diskNumberStart'},
+ $self->internalFileAttributes(),
+ $self->externalFileAttributes(),
+ $self->writeLocalHeaderRelativeOffset()
+ );
+
+ $self->_print($fh, $header)
+ or return _ioError("writing central directory header");
+ if ($fileNameLength) {
+ $self->_print($fh, $self->fileName() )
+ or return _ioError("writing central directory header signature");
+ }
+ if ($extraFieldLength) {
+ $self->_print($fh, $self->cdExtraField() )
+ or return _ioError("writing central directory extra field");
+ }
+ if ($fileCommentLength) {
+ $self->_print($fh, $self->fileComment() )
+ or return _ioError("writing central directory file comment");
+ }
+
+ return AZ_OK;
+}
+
+# This writes a data descriptor to the given file handle.
+# Assumes that crc32, writeOffset, and uncompressedSize are
+# set correctly (they should be after a write).
+# Further, the local file header should have the
+# GPBF_HAS_DATA_DESCRIPTOR_MASK bit set.
+sub _writeDataDescriptor {
+ my $self = shift;
+ my $fh = shift;
+ my $header = pack(
+ SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT,
+ DATA_DESCRIPTOR_SIGNATURE,
+ $self->crc32(),
+ $self->_writeOffset(), # compressed size
+ $self->uncompressedSize()
+ );
+
+ $self->_print($fh, $header)
+ or return _ioError("writing data descriptor");
+ return AZ_OK;
+}
+
+# Re-writes the local file header with new crc32 and compressedSize fields.
+# To be called after writing the data stream.
+# Assumes that filename and extraField sizes didn't change since last written.
+sub _refreshLocalFileHeader {
+ my $self = shift;
+ my $fh = shift;
+
+ my $here = $fh->tell();
+ $fh->seek( $self->writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH,
+ IO::Seekable::SEEK_SET )
+ or return _ioError("seeking to rewrite local header");
+
+ my $header = pack(
+ LOCAL_FILE_HEADER_FORMAT,
+ $self->versionNeededToExtract(),
+ $self->bitFlag(),
+ $self->desiredCompressionMethod(),
+ $self->lastModFileDateTime(),
+ $self->crc32(),
+ $self->_writeOffset(), # compressed size
+ $self->uncompressedSize(),
+ length( $self->fileName() ),
+ length( $self->localExtraField() )
+ );
+
+ $self->_print($fh, $header)
+ or return _ioError("re-writing local header");
+ $fh->seek( $here, IO::Seekable::SEEK_SET )
+ or return _ioError("seeking after rewrite of local header");
+
+ return AZ_OK;
+}
+
+sub readChunk {
+ my $self = shift;
+ my $chunkSize = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{chunkSize} : $_[0];
+
+ if ( $self->readIsDone() ) {
+ $self->endRead();
+ my $dummy = '';
+ return ( \$dummy, AZ_STREAM_END );
+ }
+
+ $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
+ $chunkSize = $self->_readDataRemaining()
+ if $chunkSize > $self->_readDataRemaining();
+
+ my $buffer = '';
+ my $outputRef;
+ my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize );
+ return ( \$buffer, $status ) unless $status == AZ_OK;
+
+ $self->{'readDataRemaining'} -= $bytesRead;
+ $self->{'readOffset'} += $bytesRead;
+
+ if ( $self->compressionMethod() == COMPRESSION_STORED ) {
+ $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
+ }
+
+ ( $outputRef, $status ) = &{ $self->{'chunkHandler'} }( $self, \$buffer );
+ $self->{'writeOffset'} += length($$outputRef);
+
+ $self->endRead()
+ if $self->readIsDone();
+
+ return ( $outputRef, $status );
+}
+
+# Read the next raw chunk of my data. Subclasses MUST implement.
+# my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize );
+sub _readRawChunk {
+ my $self = shift;
+ return $self->_subclassResponsibility();
+}
+
+# A place holder to catch rewindData errors if someone ignores
+# the error code.
+sub _noChunk {
+ my $self = shift;
+ return ( \undef, _error("trying to copy chunk when init failed") );
+}
+
+# Basically a no-op so that I can have a consistent interface.
+# ( $outputRef, $status) = $self->_copyChunk( \$buffer );
+sub _copyChunk {
+ my ( $self, $dataRef ) = @_;
+ return ( $dataRef, AZ_OK );
+}
+
+# ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
+sub _deflateChunk {
+ my ( $self, $buffer ) = @_;
+ my ( $status ) = $self->_deflater()->deflate( $buffer, my $out );
+
+ if ( $self->_readDataRemaining() == 0 ) {
+ my $extraOutput;
+ ( $status ) = $self->_deflater()->flush($extraOutput);
+ $out .= $extraOutput;
+ $self->endRead();
+ return ( \$out, AZ_STREAM_END );
+ }
+ elsif ( $status == Z_OK ) {
+ return ( \$out, AZ_OK );
+ }
+ else {
+ $self->endRead();
+ my $retval = _error( 'deflate error', $status );
+ my $dummy = '';
+ return ( \$dummy, $retval );
+ }
+}
+
+# ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
+sub _inflateChunk {
+ my ( $self, $buffer ) = @_;
+ my ( $status ) = $self->_inflater()->inflate( $buffer, my $out );
+ my $retval;
+ $self->endRead() unless $status == Z_OK;
+ if ( $status == Z_OK || $status == Z_STREAM_END ) {
+ $retval = ( $status == Z_STREAM_END ) ? AZ_STREAM_END: AZ_OK;
+ return ( \$out, $retval );
+ }
+ else {
+ $retval = _error( 'inflate error', $status );
+ my $dummy = '';
+ return ( \$dummy, $retval );
+ }
+}
+
+sub rewindData {
+ my $self = shift;
+ my $status;
+
+ # set to trap init errors
+ $self->{'chunkHandler'} = $self->can('_noChunk');
+
+ # Work around WinZip bug with 0-length DEFLATED files
+ $self->desiredCompressionMethod(COMPRESSION_STORED)
+ if $self->uncompressedSize() == 0;
+
+ # assume that we're going to read the whole file, and compute the CRC anew.
+ $self->{'crc32'} = 0
+ if ( $self->compressionMethod() == COMPRESSION_STORED );
+
+ # These are the only combinations of methods we deal with right now.
+ if ( $self->compressionMethod() == COMPRESSION_STORED
+ and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
+ {
+ ( $self->{'deflater'}, $status ) = Compress::Raw::Zlib::Deflate->new(
+ '-Level' => $self->desiredCompressionLevel(),
+ '-WindowBits' => -MAX_WBITS(), # necessary magic
+ '-Bufsize' => $Archive::Zip::ChunkSize,
+ @_
+ ); # pass additional options
+ return _error( 'deflateInit error:', $status )
+ unless $status == Z_OK;
+ $self->{'chunkHandler'} = $self->can('_deflateChunk');
+ }
+ elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
+ and $self->desiredCompressionMethod() == COMPRESSION_STORED )
+ {
+ ( $self->{'inflater'}, $status ) = Compress::Raw::Zlib::Inflate->new(
+ '-WindowBits' => -MAX_WBITS(), # necessary magic
+ '-Bufsize' => $Archive::Zip::ChunkSize,
+ @_
+ ); # pass additional options
+ return _error( 'inflateInit error:', $status )
+ unless $status == Z_OK;
+ $self->{'chunkHandler'} = $self->can('_inflateChunk');
+ }
+ elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() ) {
+ $self->{'chunkHandler'} = $self->can('_copyChunk');
+ }
+ else {
+ return _error(
+ sprintf(
+ "Unsupported compression combination: read %d, write %d",
+ $self->compressionMethod(),
+ $self->desiredCompressionMethod()
+ )
+ );
+ }
+
+ $self->{'readDataRemaining'} =
+ ( $self->compressionMethod() == COMPRESSION_STORED )
+ ? $self->uncompressedSize()
+ : $self->compressedSize();
+ $self->{'dataEnded'} = 0;
+ $self->{'readOffset'} = 0;
+
+ return AZ_OK;
+}
+
+sub endRead {
+ my $self = shift;
+ delete $self->{'inflater'};
+ delete $self->{'deflater'};
+ $self->{'dataEnded'} = 1;
+ $self->{'readDataRemaining'} = 0;
+ return AZ_OK;
+}
+
+sub readIsDone {
+ my $self = shift;
+ return ( $self->_dataEnded() or !$self->_readDataRemaining() );
+}
+
+sub contents {
+ my $self = shift;
+ my $newContents = shift;
+
+ if ( defined($newContents) ) {
+
+ # change our type and call the subclass contents method.
+ $self->_become(STRINGMEMBERCLASS);
+ return $self->contents( pack( 'C0a*', $newContents ) )
+ ; # in case of Unicode
+ }
+ else {
+ my $oldCompression =
+ $self->desiredCompressionMethod(COMPRESSION_STORED);
+ my $status = $self->rewindData(@_);
+ if ( $status != AZ_OK ) {
+ $self->endRead();
+ return $status;
+ }
+ my $retval = '';
+ while ( $status == AZ_OK ) {
+ my $ref;
+ ( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() );
+
+ # did we get it in one chunk?
+ if ( length($$ref) == $self->uncompressedSize() ) {
+ $retval = $$ref;
+ }
+ else { $retval .= $$ref }
+ }
+ $self->desiredCompressionMethod($oldCompression);
+ $self->endRead();
+ $status = AZ_OK if $status == AZ_STREAM_END;
+ $retval = undef unless $status == AZ_OK;
+ return wantarray ? ( $retval, $status ) : $retval;
+ }
+}
+
+sub extractToFileHandle {
+ my $self = shift;
+ return _error("encryption unsupported") if $self->isEncrypted();
+ my $fh = ( ref( $_[0] ) eq 'HASH' ) ? shift->{fileHandle} : shift;
+ _binmode($fh);
+ my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
+ my $status = $self->rewindData(@_);
+ $status = $self->_writeData($fh) if $status == AZ_OK;
+ $self->desiredCompressionMethod($oldCompression);
+ $self->endRead();
+ return $status;
+}
+
+# write local header and data stream to file handle
+sub _writeToFileHandle {
+ my $self = shift;
+ my $fh = shift;
+ my $fhIsSeekable = shift;
+ my $offset = shift;
+
+ return _error("no member name given for $self")
+ if $self->fileName() eq '';
+
+ $self->{'writeLocalHeaderRelativeOffset'} = $offset;
+ $self->{'wasWritten'} = 0;
+
+ # Determine if I need to write a data descriptor
+ # I need to do this if I can't refresh the header
+ # and I don't know compressed size or crc32 fields.
+ my $headerFieldsUnknown = (
+ ( $self->uncompressedSize() > 0 )
+ and ($self->compressionMethod() == COMPRESSION_STORED
+ or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
+ );
+
+ my $shouldWriteDataDescriptor =
+ ( $headerFieldsUnknown and not $fhIsSeekable );
+
+ $self->hasDataDescriptor(1)
+ if ($shouldWriteDataDescriptor);
+
+ $self->{'writeOffset'} = 0;
+
+ my $status = $self->rewindData();
+ ( $status = $self->_writeLocalFileHeader($fh) )
+ if $status == AZ_OK;
+ ( $status = $self->_writeData($fh) )
+ if $status == AZ_OK;
+ if ( $status == AZ_OK ) {
+ $self->{'wasWritten'} = 1;
+ if ( $self->hasDataDescriptor() ) {
+ $status = $self->_writeDataDescriptor($fh);
+ }
+ elsif ($headerFieldsUnknown) {
+ $status = $self->_refreshLocalFileHeader($fh);
+ }
+ }
+
+ return $status;
+}
+
+# Copy my (possibly compressed) data to given file handle.
+# Returns C<AZ_OK> on success
+sub _writeData {
+ my $self = shift;
+ my $writeFh = shift;
+
+ # If symbolic link, just create one if the operating system is Linux, Unix, BSD or VMS
+ # TODO: Add checks for other operating systems
+ if ( $self->{'isSymbolicLink'} == 1 && $^O eq 'linux' ) {
+ my $chunkSize = $Archive::Zip::ChunkSize;
+ my ( $outRef, $status ) = $self->readChunk($chunkSize);
+ symlink $$outRef, $self->{'newName'};
+ } else {
+ return AZ_OK if ( $self->uncompressedSize() == 0 );
+ my $status;
+ my $chunkSize = $Archive::Zip::ChunkSize;
+ while ( $self->_readDataRemaining() > 0 ) {
+ my $outRef;
+ ( $outRef, $status ) = $self->readChunk($chunkSize);
+ return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
+
+ if ( length($$outRef) > 0 ) {
+ $self->_print($writeFh, $$outRef)
+ or return _ioError("write error during copy");
+ }
+
+ last if $status == AZ_STREAM_END;
+ }
+ $self->{'compressedSize'} = $self->_writeOffset();
+ }
+ return AZ_OK;
+}
+
+# Return true if I depend on the named file
+sub _usesFileNamed {
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/MemberRead.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/MemberRead.pm
new file mode 100755
index 00000000000..a27bfdc45f0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/MemberRead.pm
@@ -0,0 +1,333 @@
+package Archive::Zip::MemberRead;
+
+=head1 NAME
+
+Archive::Zip::MemberRead - A wrapper that lets you read Zip archive members as if they were files.
+
+=cut
+
+=head1 SYNOPSIS
+
+ use Archive::Zip;
+ use Archive::Zip::MemberRead;
+ $zip = Archive::Zip->new("file.zip");
+ $fh = Archive::Zip::MemberRead->new($zip, "subdir/abc.txt");
+ while (defined($line = $fh->getline()))
+ {
+ print $fh->input_line_number . "#: $line\n";
+ }
+
+ $read = $fh->read($buffer, 32*1024);
+ print "Read $read bytes as :$buffer:\n";
+
+=head1 DESCRIPTION
+
+The Archive::Zip::MemberRead module lets you read Zip archive member data
+just like you read data from files.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+use strict;
+
+use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
+
+use vars qw{$VERSION};
+
+my $nl;
+
+BEGIN {
+ $VERSION = '1.30';
+ $VERSION = eval $VERSION;
+ # Requirement for newline conversion. Should check for e.g., DOS and OS/2 as well, but am too lazy.
+ $nl = $^O eq 'MSWin32' ? "\r\n" : "\n";
+}
+
+=item Archive::Zip::Member::readFileHandle()
+
+You can get a C<Archive::Zip::MemberRead> from an archive member by
+calling C<readFileHandle()>:
+
+ my $member = $zip->memberNamed('abc/def.c');
+ my $fh = $member->readFileHandle();
+ while (defined($line = $fh->getline()))
+ {
+ # ...
+ }
+ $fh->close();
+
+=cut
+
+sub Archive::Zip::Member::readFileHandle {
+ return Archive::Zip::MemberRead->new( shift() );
+}
+
+=item Archive::Zip::MemberRead->new($zip, $fileName)
+
+=item Archive::Zip::MemberRead->new($zip, $member)
+
+=item Archive::Zip::MemberRead->new($member)
+
+Construct a new Archive::Zip::MemberRead on the specified member.
+
+ my $fh = Archive::Zip::MemberRead->new($zip, 'fred.c')
+
+=cut
+
+sub new {
+ my ( $class, $zip, $file ) = @_;
+ my ( $self, $member );
+
+ if ( $zip && $file ) # zip and filename, or zip and member
+ {
+ $member = ref($file) ? $file : $zip->memberNamed($file);
+ }
+ elsif ( $zip && !$file && ref($zip) ) # just member
+ {
+ $member = $zip;
+ }
+ else {
+ die(
+'Archive::Zip::MemberRead::new needs a zip and filename, zip and member, or member'
+ );
+ }
+
+ $self = {};
+ bless( $self, $class );
+ $self->set_member($member);
+ return $self;
+}
+
+sub set_member {
+ my ( $self, $member ) = @_;
+
+ $self->{member} = $member;
+ $self->set_compression(COMPRESSION_STORED);
+ $self->rewind();
+}
+
+sub set_compression {
+ my ( $self, $compression ) = @_;
+ $self->{member}->desiredCompressionMethod($compression) if $self->{member};
+}
+
+=item setLineEnd(expr)
+
+Set the line end character to use. This is set to \n by default
+except on Windows systems where it is set to \r\n. You will
+only need to set this on systems which are not Windows or Unix
+based and require a line end diffrent from \n.
+This is a class method so call as C<Archive::Zip::MemberRead>->C<setLineEnd($nl)>
+
+=cut
+
+sub setLineEnd {
+ shift;
+ $nl = shift;
+}
+
+=item rewind()
+
+Rewinds an C<Archive::Zip::MemberRead> so that you can read from it again
+starting at the beginning.
+
+=cut
+
+sub rewind {
+ my $self = shift;
+
+ $self->_reset_vars();
+ $self->{member}->rewindData() if $self->{member};
+}
+
+sub _reset_vars {
+ my $self = shift;
+
+ $self->{line_no} = 0;
+ $self->{at_end} = 0;
+
+ delete $self->{buffer};
+}
+
+=item input_record_separator(expr)
+
+If the argumnet is given, input_record_separator for this
+instance is set to it. The current setting (which may be
+the global $/) is always returned.
+
+=cut
+
+sub input_record_separator {
+ my $self = shift;
+ if (@_) {
+ $self->{sep} = shift;
+ $self->{sep_re} = _sep_as_re($self->{sep}); # Cache the RE as an optimization
+ }
+ return exists $self->{sep} ? $self->{sep} : $/;
+}
+
+# Return the input_record_separator in use as an RE fragment
+# Note that if we have a per-instance input_record_separator
+# we can just return the already converted value. Otherwise,
+# the conversion must be done on $/ every time since we cannot
+# know whether it has changed or not.
+sub _sep_re {
+ my $self = shift;
+ # Important to phrase this way: sep's value may be undef.
+ return exists $self->{sep} ? $self->{sep_re} : _sep_as_re($/);
+}
+
+# Convert the input record separator into an RE and return it.
+sub _sep_as_re {
+ my $sep = shift;
+ if (defined $sep) {
+ if ($sep eq '') {
+ return "(?:$nl){2,}";
+ } else {
+ $sep =~ s/\n/$nl/og;
+ return quotemeta $sep;
+ }
+ } else {
+ return undef;
+ }
+}
+
+=item input_line_number()
+
+Returns the current line number, but only if you're using C<getline()>.
+Using C<read()> will not update the line number.
+
+=cut
+
+sub input_line_number {
+ my $self = shift;
+ return $self->{line_no};
+}
+
+=item close()
+
+Closes the given file handle.
+
+=cut
+
+sub close {
+ my $self = shift;
+
+ $self->_reset_vars();
+ $self->{member}->endRead();
+}
+
+=item buffer_size([ $size ])
+
+Gets or sets the buffer size used for reads.
+Default is the chunk size used by Archive::Zip.
+
+=cut
+
+sub buffer_size {
+ my ( $self, $size ) = @_;
+
+ if ( !$size ) {
+ return $self->{chunkSize} || Archive::Zip::chunkSize();
+ }
+ else {
+ $self->{chunkSize} = $size;
+ }
+}
+
+=item getline()
+
+Returns the next line from the currently open member.
+Makes sense only for text files.
+A read error is considered fatal enough to die.
+Returns undef on eof. All subsequent calls would return undef,
+unless a rewind() is called.
+Note: The line returned has the input_record_separator (default: newline) removed.
+
+=cut
+
+sub getline {
+ my $self = shift;
+ my $size = $self->buffer_size();
+ my $sep = $self->_sep_re();
+
+ for (;;) {
+ if ( $sep
+ && defined($self->{buffer})
+ && $self->{buffer} =~ s/^(.*?)$sep//s
+ ) {
+ $self->{line_no}++;
+ return $1;
+ } elsif ($self->{at_end}) {
+ $self->{line_no}++ if $self->{buffer};
+ return delete $self->{buffer};
+ }
+ my ($temp,$status) = $self->{member}->readChunk($size);
+ if ($status != AZ_OK && $status != AZ_STREAM_END) {
+ die "ERROR: Error reading chunk from archive - $status";
+ }
+ $self->{at_end} = $status == AZ_STREAM_END;
+ $self->{buffer} .= $$temp;
+ }
+}
+
+=item read($buffer, $num_bytes_to_read)
+
+Simulates a normal C<read()> system call.
+Returns the no. of bytes read. C<undef> on error, 0 on eof, I<e.g.>:
+
+ $fh = Archive::Zip::MemberRead->new($zip, "sreeji/secrets.bin");
+ while (1)
+ {
+ $read = $fh->read($buffer, 1024);
+ die "FATAL ERROR reading my secrets !\n" if (!defined($read));
+ last if (!$read);
+ # Do processing.
+ ....
+ }
+
+=cut
+
+#
+# All these $_ are required to emulate read().
+#
+sub read {
+ my $self = $_[0];
+ my $size = $_[2];
+ my ( $temp, $status, $ret );
+
+ ( $temp, $status ) = $self->{member}->readChunk($size);
+ if ( $status != AZ_OK && $status != AZ_STREAM_END ) {
+ $_[1] = undef;
+ $ret = undef;
+ }
+ else {
+ $_[1] = $$temp;
+ $ret = length($$temp);
+ }
+ return $ret;
+}
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Sreeji K. Das, <sreeji_k@yahoo.com>
+See L<Archive::Zip> by Ned Konz without which this module does not make
+any sense!
+
+Minor mods by Ned Konz.
+
+=head1 COPYRIGHT
+
+Copyright 2002 Sreeji K. Das.
+
+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.straw/lib/Archive/Zip/MockFileHandle.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/MockFileHandle.pm
new file mode 100755
index 00000000000..bceb181ae13
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/MockFileHandle.pm
@@ -0,0 +1,69 @@
+package Archive::Zip::MockFileHandle;
+
+# Output file handle that calls a custom write routine
+# Ned Konz, March 2000
+# This is provided to help with writing zip files
+# when you have to process them a chunk at a time.
+
+use strict;
+
+use vars qw{$VERSION};
+
+BEGIN {
+ $VERSION = '1.30';
+ $VERSION = eval $VERSION;
+}
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ $class = ref($class) || $class;
+ my $self = bless(
+ {
+ 'position' => 0,
+ 'size' => 0
+ },
+ $class
+ );
+ return $self;
+}
+
+sub eof {
+ my $self = shift;
+ return $self->{'position'} >= $self->{'size'};
+}
+
+# Copy given buffer to me
+sub print {
+ my $self = shift;
+ my $bytes = join( '', @_ );
+ my $bytesWritten = $self->writeHook($bytes);
+ if ( $self->{'position'} + $bytesWritten > $self->{'size'} ) {
+ $self->{'size'} = $self->{'position'} + $bytesWritten;
+ }
+ $self->{'position'} += $bytesWritten;
+ return $bytesWritten;
+}
+
+# Called on each write.
+# Override in subclasses.
+# Return number of bytes written (0 on error).
+sub writeHook {
+ my $self = shift;
+ my $bytes = shift;
+ return length($bytes);
+}
+
+sub binmode { 1 }
+
+sub close { 1 }
+
+sub clearerr { 1 }
+
+# I'm write-only!
+sub read { 0 }
+
+sub tell { return shift->{'position'} }
+
+sub opened { 1 }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/NewFileMember.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/NewFileMember.pm
new file mode 100755
index 00000000000..79178082151
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/NewFileMember.pm
@@ -0,0 +1,79 @@
+package Archive::Zip::NewFileMember;
+
+use strict;
+use vars qw( $VERSION @ISA );
+
+BEGIN {
+ $VERSION = '1.30';
+ @ISA = qw ( Archive::Zip::FileMember );
+}
+
+use Archive::Zip qw(
+ :CONSTANTS
+ :ERROR_CODES
+ :UTILITY_METHODS
+);
+
+# Given a file name, set up for eventual writing.
+sub _newFromFileNamed {
+ my $class = shift;
+ my $fileName = shift; # local FS format
+ my $newName = shift;
+ $newName = _asZipDirName($fileName) unless defined($newName);
+ return undef unless ( stat($fileName) && -r _ && !-d _ );
+ my $self = $class->new(@_);
+ $self->{'fileName'} = $newName;
+ $self->{'externalFileName'} = $fileName;
+ $self->{'compressionMethod'} = COMPRESSION_STORED;
+ my @stat = stat(_);
+ $self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7];
+ $self->desiredCompressionMethod(
+ ( $self->compressedSize() > 0 )
+ ? COMPRESSION_DEFLATED
+ : COMPRESSION_STORED
+ );
+ $self->unixFileAttributes( $stat[2] );
+ $self->setLastModFileDateTimeFromUnix( $stat[9] );
+ $self->isTextFile( -T _ );
+ return $self;
+}
+
+sub rewindData {
+ my $self = shift;
+
+ my $status = $self->SUPER::rewindData(@_);
+ return $status unless $status == AZ_OK;
+
+ return AZ_IO_ERROR unless $self->fh();
+ $self->fh()->clearerr();
+ $self->fh()->seek( 0, IO::Seekable::SEEK_SET )
+ or return _ioError( "rewinding", $self->externalFileName() );
+ return AZ_OK;
+}
+
+# Return bytes read. Note that first parameter is a ref to a buffer.
+# my $data;
+# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
+sub _readRawChunk {
+ my ( $self, $dataRef, $chunkSize ) = @_;
+ return ( 0, AZ_OK ) unless $chunkSize;
+ my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
+ or return ( 0, _ioError("reading data") );
+ return ( $bytesRead, AZ_OK );
+}
+
+# If I already exist, extraction is a no-op.
+sub extractToFileNamed {
+ my $self = shift;
+ my $name = shift; # local FS name
+ if ( File::Spec->rel2abs($name) eq
+ File::Spec->rel2abs( $self->externalFileName() ) and -r $name )
+ {
+ return AZ_OK;
+ }
+ else {
+ return $self->SUPER::extractToFileNamed( $name, @_ );
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/StringMember.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/StringMember.pm
new file mode 100755
index 00000000000..fe6760849ac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/StringMember.pm
@@ -0,0 +1,64 @@
+package Archive::Zip::StringMember;
+
+use strict;
+use vars qw( $VERSION @ISA );
+
+BEGIN {
+ $VERSION = '1.30';
+ @ISA = qw( Archive::Zip::Member );
+}
+
+use Archive::Zip qw(
+ :CONSTANTS
+ :ERROR_CODES
+);
+
+# Create a new string member. Default is COMPRESSION_STORED.
+# Can take a ref to a string as well.
+sub _newFromString {
+ my $class = shift;
+ my $string = shift;
+ my $name = shift;
+ my $self = $class->new(@_);
+ $self->contents($string);
+ $self->fileName($name) if defined($name);
+
+ # Set the file date to now
+ $self->setLastModFileDateTimeFromUnix( time() );
+ $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
+ return $self;
+}
+
+sub _become {
+ my $self = shift;
+ my $newClass = shift;
+ return $self if ref($self) eq $newClass;
+ delete( $self->{'contents'} );
+ return $self->SUPER::_become($newClass);
+}
+
+# Get or set my contents. Note that we do not call the superclass
+# version of this, because it calls us.
+sub contents {
+ my $self = shift;
+ my $string = shift;
+ if ( defined($string) ) {
+ $self->{'contents'} =
+ pack( 'C0a*', ( ref($string) eq 'SCALAR' ) ? $$string : $string );
+ $self->{'uncompressedSize'} = $self->{'compressedSize'} =
+ length( $self->{'contents'} );
+ $self->{'compressionMethod'} = COMPRESSION_STORED;
+ }
+ return $self->{'contents'};
+}
+
+# Return bytes read. Note that first parameter is a ref to a buffer.
+# my $data;
+# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
+sub _readRawChunk {
+ my ( $self, $dataRef, $chunkSize ) = @_;
+ $$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize );
+ return ( length($$dataRef), AZ_OK );
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Tree.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Tree.pm
new file mode 100755
index 00000000000..fb8bc0b3c7e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/Tree.pm
@@ -0,0 +1,49 @@
+package Archive::Zip::Tree;
+
+use strict;
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.30';
+}
+
+use Archive::Zip;
+
+warn(
+"Archive::Zip::Tree is deprecated; its methods have been moved into Archive::Zip."
+) if $^W;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Archive::Zip::Tree - (DEPRECATED) methods for adding/extracting trees using Archive::Zip
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This module is deprecated, because all its methods were moved into the main
+Archive::Zip module.
+
+It is included in the distribution merely to avoid breaking old code.
+
+See L<Archive::Zip>.
+
+=head1 AUTHOR
+
+Ned Konz, perl@bike-nomad.com
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000-2002 Ned Konz. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=head1 SEE ALSO
+
+L<Archive::Zip>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Archive/Zip/ZipFileMember.pm b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/ZipFileMember.pm
new file mode 100755
index 00000000000..cc606697b15
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Archive/Zip/ZipFileMember.pm
@@ -0,0 +1,416 @@
+package Archive::Zip::ZipFileMember;
+
+use strict;
+use vars qw( $VERSION @ISA );
+
+BEGIN {
+ $VERSION = '1.30';
+ @ISA = qw ( Archive::Zip::FileMember );
+}
+
+use Archive::Zip qw(
+ :CONSTANTS
+ :ERROR_CODES
+ :PKZIP_CONSTANTS
+ :UTILITY_METHODS
+);
+
+# Create a new Archive::Zip::ZipFileMember
+# given a filename and optional open file handle
+#
+sub _newFromZipFile {
+ my $class = shift;
+ my $fh = shift;
+ my $externalFileName = shift;
+ my $possibleEocdOffset = shift; # normally 0
+
+ my $self = $class->new(
+ 'crc32' => 0,
+ 'diskNumberStart' => 0,
+ 'localHeaderRelativeOffset' => 0,
+ 'dataOffset' => 0, # localHeaderRelativeOffset + header length
+ @_
+ );
+ $self->{'externalFileName'} = $externalFileName;
+ $self->{'fh'} = $fh;
+ $self->{'possibleEocdOffset'} = $possibleEocdOffset;
+ return $self;
+}
+
+sub isDirectory {
+ my $self = shift;
+ return (
+ substr( $self->fileName, -1, 1 ) eq '/'
+ and
+ $self->uncompressedSize == 0
+ );
+}
+
+# Seek to the beginning of the local header, just past the signature.
+# Verify that the local header signature is in fact correct.
+# Update the localHeaderRelativeOffset if necessary by adding the possibleEocdOffset.
+# Returns status.
+
+sub _seekToLocalHeader {
+ my $self = shift;
+ my $where = shift; # optional
+ my $previousWhere = shift; # optional
+
+ $where = $self->localHeaderRelativeOffset() unless defined($where);
+
+ # avoid loop on certain corrupt files (from Julian Field)
+ return _formatError("corrupt zip file")
+ if defined($previousWhere) && $where == $previousWhere;
+
+ my $status;
+ my $signature;
+
+ $status = $self->fh()->seek( $where, IO::Seekable::SEEK_SET );
+ return _ioError("seeking to local header") unless $status;
+
+ ( $status, $signature ) =
+ _readSignature( $self->fh(), $self->externalFileName(),
+ LOCAL_FILE_HEADER_SIGNATURE );
+ return $status if $status == AZ_IO_ERROR;
+
+ # retry with EOCD offset if any was given.
+ if ( $status == AZ_FORMAT_ERROR && $self->{'possibleEocdOffset'} ) {
+ $status = $self->_seekToLocalHeader(
+ $self->localHeaderRelativeOffset() + $self->{'possibleEocdOffset'},
+ $where
+ );
+ if ( $status == AZ_OK ) {
+ $self->{'localHeaderRelativeOffset'} +=
+ $self->{'possibleEocdOffset'};
+ $self->{'possibleEocdOffset'} = 0;
+ }
+ }
+
+ return $status;
+}
+
+# Because I'm going to delete the file handle, read the local file
+# header if the file handle is seekable. If it isn't, I assume that
+# I've already read the local header.
+# Return ( $status, $self )
+
+sub _become {
+ my $self = shift;
+ my $newClass = shift;
+ return $self if ref($self) eq $newClass;
+
+ my $status = AZ_OK;
+
+ if ( _isSeekable( $self->fh() ) ) {
+ my $here = $self->fh()->tell();
+ $status = $self->_seekToLocalHeader();
+ $status = $self->_readLocalFileHeader() if $status == AZ_OK;
+ $self->fh()->seek( $here, IO::Seekable::SEEK_SET );
+ return $status unless $status == AZ_OK;
+ }
+
+ delete( $self->{'eocdCrc32'} );
+ delete( $self->{'diskNumberStart'} );
+ delete( $self->{'localHeaderRelativeOffset'} );
+ delete( $self->{'dataOffset'} );
+
+ return $self->SUPER::_become($newClass);
+}
+
+sub diskNumberStart {
+ shift->{'diskNumberStart'};
+}
+
+sub localHeaderRelativeOffset {
+ shift->{'localHeaderRelativeOffset'};
+}
+
+sub dataOffset {
+ shift->{'dataOffset'};
+}
+
+# Skip local file header, updating only extra field stuff.
+# Assumes that fh is positioned before signature.
+sub _skipLocalFileHeader {
+ my $self = shift;
+ my $header;
+ my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
+ if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH ) {
+ return _ioError("reading local file header");
+ }
+ my $fileNameLength;
+ my $extraFieldLength;
+ my $bitFlag;
+ (
+ undef, # $self->{'versionNeededToExtract'},
+ $bitFlag,
+ undef, # $self->{'compressionMethod'},
+ undef, # $self->{'lastModFileDateTime'},
+ undef, # $crc32,
+ undef, # $compressedSize,
+ undef, # $uncompressedSize,
+ $fileNameLength,
+ $extraFieldLength
+ ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
+
+ if ($fileNameLength) {
+ $self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR )
+ or return _ioError("skipping local file name");
+ }
+
+ if ($extraFieldLength) {
+ $bytesRead =
+ $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
+ if ( $bytesRead != $extraFieldLength ) {
+ return _ioError("reading local extra field");
+ }
+ }
+
+ $self->{'dataOffset'} = $self->fh()->tell();
+
+ if ( $bitFlag & GPBF_HAS_DATA_DESCRIPTOR_MASK ) {
+
+ # Read the crc32, compressedSize, and uncompressedSize from the
+ # extended data descriptor, which directly follows the compressed data.
+ #
+ # Skip over the compressed file data (assumes that EOCD compressedSize
+ # was correct)
+ $self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
+ or return _ioError("seeking to extended local header");
+
+ # these values should be set correctly from before.
+ my $oldCrc32 = $self->{'eocdCrc32'};
+ my $oldCompressedSize = $self->{'compressedSize'};
+ my $oldUncompressedSize = $self->{'uncompressedSize'};
+
+ my $status = $self->_readDataDescriptor();
+ return $status unless $status == AZ_OK;
+
+ return _formatError(
+ "CRC or size mismatch while skipping data descriptor")
+ if ( $oldCrc32 != $self->{'crc32'}
+ || $oldUncompressedSize != $self->{'uncompressedSize'} );
+ }
+
+ return AZ_OK;
+}
+
+# Read from a local file header into myself. Returns AZ_OK if successful.
+# Assumes that fh is positioned after signature.
+# Note that crc32, compressedSize, and uncompressedSize will be 0 if
+# GPBF_HAS_DATA_DESCRIPTOR_MASK is set in the bitFlag.
+
+sub _readLocalFileHeader {
+ my $self = shift;
+ my $header;
+ my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
+ if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH ) {
+ return _ioError("reading local file header");
+ }
+ my $fileNameLength;
+ my $crc32;
+ my $compressedSize;
+ my $uncompressedSize;
+ my $extraFieldLength;
+ (
+ $self->{'versionNeededToExtract'}, $self->{'bitFlag'},
+ $self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
+ $crc32, $compressedSize,
+ $uncompressedSize, $fileNameLength,
+ $extraFieldLength
+ ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
+
+ if ($fileNameLength) {
+ my $fileName;
+ $bytesRead = $self->fh()->read( $fileName, $fileNameLength );
+ if ( $bytesRead != $fileNameLength ) {
+ return _ioError("reading local file name");
+ }
+ $self->fileName($fileName);
+ }
+
+ if ($extraFieldLength) {
+ $bytesRead =
+ $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
+ if ( $bytesRead != $extraFieldLength ) {
+ return _ioError("reading local extra field");
+ }
+ }
+
+ $self->{'dataOffset'} = $self->fh()->tell();
+
+ if ( $self->hasDataDescriptor() ) {
+
+ # Read the crc32, compressedSize, and uncompressedSize from the
+ # extended data descriptor.
+ # Skip over the compressed file data (assumes that EOCD compressedSize
+ # was correct)
+ $self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
+ or return _ioError("seeking to extended local header");
+
+ my $status = $self->_readDataDescriptor();
+ return $status unless $status == AZ_OK;
+ }
+ else {
+ return _formatError(
+ "CRC or size mismatch after reading data descriptor")
+ if ( $self->{'crc32'} != $crc32
+ || $self->{'uncompressedSize'} != $uncompressedSize );
+ }
+
+ return AZ_OK;
+}
+
+# This will read the data descriptor, which is after the end of compressed file
+# data in members that that have GPBF_HAS_DATA_DESCRIPTOR_MASK set in their
+# bitFlag.
+# The only reliable way to find these is to rely on the EOCD compressedSize.
+# Assumes that file is positioned immediately after the compressed data.
+# Returns status; sets crc32, compressedSize, and uncompressedSize.
+sub _readDataDescriptor {
+ my $self = shift;
+ my $signatureData;
+ my $header;
+ my $crc32;
+ my $compressedSize;
+ my $uncompressedSize;
+
+ my $bytesRead = $self->fh()->read( $signatureData, SIGNATURE_LENGTH );
+ return _ioError("reading header signature")
+ if $bytesRead != SIGNATURE_LENGTH;
+ my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
+
+ # unfortunately, the signature appears to be optional.
+ if ( $signature == DATA_DESCRIPTOR_SIGNATURE
+ && ( $signature != $self->{'crc32'} ) )
+ {
+ $bytesRead = $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH );
+ return _ioError("reading data descriptor")
+ if $bytesRead != DATA_DESCRIPTOR_LENGTH;
+
+ ( $crc32, $compressedSize, $uncompressedSize ) =
+ unpack( DATA_DESCRIPTOR_FORMAT, $header );
+ }
+ else {
+ $bytesRead =
+ $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH_NO_SIG );
+ return _ioError("reading data descriptor")
+ if $bytesRead != DATA_DESCRIPTOR_LENGTH_NO_SIG;
+
+ $crc32 = $signature;
+ ( $compressedSize, $uncompressedSize ) =
+ unpack( DATA_DESCRIPTOR_FORMAT_NO_SIG, $header );
+ }
+
+ $self->{'eocdCrc32'} = $self->{'crc32'}
+ unless defined( $self->{'eocdCrc32'} );
+ $self->{'crc32'} = $crc32;
+ $self->{'compressedSize'} = $compressedSize;
+ $self->{'uncompressedSize'} = $uncompressedSize;
+
+ return AZ_OK;
+}
+
+# Read a Central Directory header. Return AZ_OK on success.
+# Assumes that fh is positioned right after the signature.
+
+sub _readCentralDirectoryFileHeader {
+ my $self = shift;
+ my $fh = $self->fh();
+ my $header = '';
+ my $bytesRead = $fh->read( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH );
+ if ( $bytesRead != CENTRAL_DIRECTORY_FILE_HEADER_LENGTH ) {
+ return _ioError("reading central dir header");
+ }
+ my ( $fileNameLength, $extraFieldLength, $fileCommentLength );
+ (
+ $self->{'versionMadeBy'},
+ $self->{'fileAttributeFormat'},
+ $self->{'versionNeededToExtract'},
+ $self->{'bitFlag'},
+ $self->{'compressionMethod'},
+ $self->{'lastModFileDateTime'},
+ $self->{'crc32'},
+ $self->{'compressedSize'},
+ $self->{'uncompressedSize'},
+ $fileNameLength,
+ $extraFieldLength,
+ $fileCommentLength,
+ $self->{'diskNumberStart'},
+ $self->{'internalFileAttributes'},
+ $self->{'externalFileAttributes'},
+ $self->{'localHeaderRelativeOffset'}
+ ) = unpack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header );
+
+ $self->{'eocdCrc32'} = $self->{'crc32'};
+
+ if ($fileNameLength) {
+ $bytesRead = $fh->read( $self->{'fileName'}, $fileNameLength );
+ if ( $bytesRead != $fileNameLength ) {
+ _ioError("reading central dir filename");
+ }
+ }
+ if ($extraFieldLength) {
+ $bytesRead = $fh->read( $self->{'cdExtraField'}, $extraFieldLength );
+ if ( $bytesRead != $extraFieldLength ) {
+ return _ioError("reading central dir extra field");
+ }
+ }
+ if ($fileCommentLength) {
+ $bytesRead = $fh->read( $self->{'fileComment'}, $fileCommentLength );
+ if ( $bytesRead != $fileCommentLength ) {
+ return _ioError("reading central dir file comment");
+ }
+ }
+
+ # NK 10/21/04: added to avoid problems with manipulated headers
+ if ( $self->{'uncompressedSize'} != $self->{'compressedSize'}
+ and $self->{'compressionMethod'} == COMPRESSION_STORED )
+ {
+ $self->{'uncompressedSize'} = $self->{'compressedSize'};
+ }
+
+ $self->desiredCompressionMethod( $self->compressionMethod() );
+
+ return AZ_OK;
+}
+
+sub rewindData {
+ my $self = shift;
+
+ my $status = $self->SUPER::rewindData(@_);
+ return $status unless $status == AZ_OK;
+
+ return AZ_IO_ERROR unless $self->fh();
+
+ $self->fh()->clearerr();
+
+ # Seek to local file header.
+ # The only reason that I'm doing this this way is that the extraField
+ # length seems to be different between the CD header and the LF header.
+ $status = $self->_seekToLocalHeader();
+ return $status unless $status == AZ_OK;
+
+ # skip local file header
+ $status = $self->_skipLocalFileHeader();
+ return $status unless $status == AZ_OK;
+
+ # Seek to beginning of file data
+ $self->fh()->seek( $self->dataOffset(), IO::Seekable::SEEK_SET )
+ or return _ioError("seeking to beginning of file data");
+
+ return AZ_OK;
+}
+
+# Return bytes read. Note that first parameter is a ref to a buffer.
+# my $data;
+# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
+sub _readRawChunk {
+ my ( $self, $dataRef, $chunkSize ) = @_;
+ return ( 0, AZ_OK ) unless $chunkSize;
+ my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
+ or return ( 0, _ioError("reading data") );
+ return ( $bytesRead, AZ_OK );
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Attribute/Handlers.pm b/Master/tlpkg/tlperl.straw/lib/Attribute/Handlers.pm
new file mode 100755
index 00000000000..ea11b8f7ed6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Attribute/Handlers.pm
@@ -0,0 +1,924 @@
+package Attribute::Handlers;
+use 5.006;
+use Carp;
+use warnings;
+use strict;
+use vars qw($VERSION $AUTOLOAD);
+$VERSION = '0.87'; # remember to update version in POD!
+# $DB::single=1;
+
+my %symcache;
+sub findsym {
+ my ($pkg, $ref, $type) = @_;
+ return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
+ $type ||= ref($ref);
+ no strict 'refs';
+ foreach my $sym ( values %{$pkg."::"} ) {
+ use strict;
+ next unless ref ( \$sym ) eq 'GLOB';
+ return $symcache{$pkg,$ref} = \$sym
+ if *{$sym}{$type} && *{$sym}{$type} == $ref;
+ }
+}
+
+my %validtype = (
+ VAR => [qw[SCALAR ARRAY HASH]],
+ ANY => [qw[SCALAR ARRAY HASH CODE]],
+ "" => [qw[SCALAR ARRAY HASH CODE]],
+ SCALAR => [qw[SCALAR]],
+ ARRAY => [qw[ARRAY]],
+ HASH => [qw[HASH]],
+ CODE => [qw[CODE]],
+);
+my %lastattr;
+my @declarations;
+my %raw;
+my %phase;
+my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
+my $global_phase = 0;
+my %global_phases = (
+ BEGIN => 0,
+ CHECK => 1,
+ INIT => 2,
+ END => 3,
+);
+my @global_phases = qw(BEGIN CHECK INIT END);
+
+sub _usage_AH_ {
+ croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
+}
+
+my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
+
+sub import {
+ my $class = shift @_;
+ return unless $class eq "Attribute::Handlers";
+ while (@_) {
+ my $cmd = shift;
+ if ($cmd =~ /^autotie((?:ref)?)$/) {
+ my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
+ my $mapping = shift;
+ _usage_AH_ $class unless ref($mapping) eq 'HASH';
+ while (my($attr, $tieclass) = each %$mapping) {
+ $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
+ my $args = $3||'()';
+ _usage_AH_ $class unless $attr =~ $qual_id
+ && $tieclass =~ $qual_id
+ && eval "use base q\0$tieclass\0; 1";
+ if ($tieclass->isa('Exporter')) {
+ local $Exporter::ExportLevel = 2;
+ $tieclass->import(eval $args);
+ }
+ $attr =~ s/__CALLER__/caller(1)/e;
+ $attr = caller()."::".$attr unless $attr =~ /::/;
+ eval qq{
+ sub $attr : ATTR(VAR) {
+ my (\$ref, \$data) = \@_[2,4];
+ my \$was_arrayref = ref \$data eq 'ARRAY';
+ \$data = [ \$data ] unless \$was_arrayref;
+ my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
+ (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
+ :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
+ :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
+ : die "Can't autotie a \$type\n"
+ } 1
+ } or die "Internal error: $@";
+ }
+ }
+ else {
+ croak "Can't understand $_";
+ }
+ }
+}
+
+# On older perls, code attribute handlers run before the sub gets placed
+# in its package. Since the :ATTR handlers need to know the name of the
+# sub they're applied to, the name lookup (via findsym) needs to be
+# delayed: we do it immediately before we might need to find attribute
+# handlers from their name. However, on newer perls (which fix some
+# problems relating to attribute application), a sub gets placed in its
+# package before its attributes are processed. In this case, the
+# delayed name lookup might be too late, because the sub we're looking
+# for might have already been replaced. So we need to detect which way
+# round this perl does things, and time the name lookup accordingly.
+BEGIN {
+ my $delayed;
+ sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
+ $delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
+ return ();
+ }
+ sub Attribute::Handlers::_TEST_::t :T { }
+ *_delayed_name_resolution = sub() { $delayed };
+ undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
+ undef &Attribute::Handlers::_TEST_::t;
+}
+
+sub _resolve_lastattr {
+ return unless $lastattr{ref};
+ my $sym = findsym @lastattr{'pkg','ref'}
+ or die "Internal error: $lastattr{pkg} symbol went missing";
+ my $name = *{$sym}{NAME};
+ warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
+ if $^W and $name !~ /[A-Z]/;
+ foreach ( @{$validtype{$lastattr{type}}} ) {
+ no strict 'refs';
+ *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
+ }
+ %lastattr = ();
+}
+
+sub AUTOLOAD {
+ return if $AUTOLOAD =~ /::DESTROY$/;
+ my ($class) = $AUTOLOAD =~ m/(.*)::/g;
+ $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
+ croak "Can't locate class method '$AUTOLOAD' via package '$class'";
+ croak "Attribute handler '$2' doesn't handle $1 attributes";
+}
+
+my $builtin = qr/lvalue|method|locked|unique|shared/;
+
+sub _gen_handler_AH_() {
+ return sub {
+ _resolve_lastattr if _delayed_name_resolution;
+ my ($pkg, $ref, @attrs) = @_;
+ my (undef, $filename, $linenum) = caller 2;
+ foreach (@attrs) {
+ my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
+ if ($attr eq 'ATTR') {
+ no strict 'refs';
+ $data ||= "ANY";
+ $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
+ $phase{$ref}{BEGIN} = 1
+ if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
+ $phase{$ref}{INIT} = 1
+ if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
+ $phase{$ref}{END} = 1
+ if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
+ $phase{$ref}{CHECK} = 1
+ if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
+ || ! keys %{$phase{$ref}};
+ # Added for cleanup to not pollute next call.
+ (%lastattr = ()),
+ croak "Can't have two ATTR specifiers on one subroutine"
+ if keys %lastattr;
+ croak "Bad attribute type: ATTR($data)"
+ unless $validtype{$data};
+ %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
+ _resolve_lastattr unless _delayed_name_resolution;
+ }
+ else {
+ my $type = ref $ref;
+ my $handler = $pkg->can("_ATTR_${type}_${attr}");
+ next unless $handler;
+ my $decl = [$pkg, $ref, $attr, $data,
+ $raw{$handler}, $phase{$handler}, $filename, $linenum];
+ foreach my $gphase (@global_phases) {
+ _apply_handler_AH_($decl,$gphase)
+ if $global_phases{$gphase} <= $global_phase;
+ }
+ if ($global_phase != 0) {
+ # if _gen_handler_AH_ is being called after
+ # CHECK it's for a lexical, so make sure
+ # it didn't want to run anything later
+
+ local $Carp::CarpLevel = 2;
+ carp "Won't be able to apply END handler"
+ if $phase{$handler}{END};
+ }
+ else {
+ push @declarations, $decl
+ }
+ }
+ $_ = undef;
+ }
+ return grep {defined && !/$builtin/} @attrs;
+ }
+}
+
+{
+ no strict 'refs';
+ *{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
+ _gen_handler_AH_ foreach @{$validtype{ANY}};
+}
+push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
+ unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
+
+sub _apply_handler_AH_ {
+ my ($declaration, $phase) = @_;
+ my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
+ return unless $handlerphase->{$phase};
+ # print STDERR "Handling $attr on $ref in $phase with [$data]\n";
+ my $type = ref $ref;
+ my $handler = "_ATTR_${type}_${attr}";
+ my $sym = findsym($pkg, $ref);
+ $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
+ no warnings;
+ if (!$raw && defined($data)) {
+ if ($data ne '') {
+ my $evaled = eval("package $pkg; no warnings; no strict;
+ local \$SIG{__WARN__}=sub{die}; [$data]");
+ $data = $evaled unless $@;
+ }
+ else { $data = undef }
+ }
+ $pkg->$handler($sym,
+ (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
+ $attr,
+ $data,
+ $phase,
+ $filename,
+ $linenum,
+ );
+ return 1;
+}
+
+{
+ no warnings 'void';
+ CHECK {
+ $global_phase++;
+ _resolve_lastattr if _delayed_name_resolution;
+ _apply_handler_AH_($_,'CHECK') foreach @declarations;
+ }
+
+ INIT {
+ $global_phase++;
+ _apply_handler_AH_($_,'INIT') foreach @declarations
+ }
+}
+
+END { $global_phase++; _apply_handler_AH_($_,'END') foreach @declarations }
+
+1;
+__END__
+
+=head1 NAME
+
+Attribute::Handlers - Simpler definition of attribute handlers
+
+=head1 VERSION
+
+This document describes version 0.87 of Attribute::Handlers,
+released September 21, 2009.
+
+=head1 SYNOPSIS
+
+ package MyClass;
+ require 5.006;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+
+ sub Good : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+
+ # Invoked for any scalar variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+
+ # Do whatever to $referent here (executed in CHECK phase).
+ ...
+ }
+
+ sub Bad : ATTR(SCALAR) {
+ # Invoked for any scalar variable with a :Bad attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(ARRAY) {
+ # Invoked for any array variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(HASH) {
+ # Invoked for any hash variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Ugly : ATTR(CODE) {
+ # Invoked for any subroutine declared in MyClass (or a
+ # derived class) with an :Ugly attribute.
+ ...
+ }
+
+ sub Omni : ATTR {
+ # Invoked for any scalar, array, hash, or subroutine
+ # with an :Omni attribute, provided the variable or
+ # subroutine was declared in MyClass (or a derived class)
+ # or the variable was typed to MyClass.
+ # Use ref($_[2]) to determine what kind of referent it was.
+ ...
+ }
+
+
+ use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+
+ my $next : Cycle(['A'..'Z']);
+
+
+=head1 DESCRIPTION
+
+This module, when inherited by a package, allows that package's class to
+define attribute handler subroutines for specific attributes. Variables
+and subroutines subsequently defined in that package, or in packages
+derived from that package may be given attributes with the same names as
+the attribute handler subroutines, which will then be called in one of
+the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
+block). (C<UNITCHECK> blocks don't correspond to a global compilation
+phase, so they can't be specified here.)
+
+To create a handler, define it as a subroutine with the same name as
+the desired attribute, and declare the subroutine itself with the
+attribute C<:ATTR>. For example:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub Loud :ATTR {
+ my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+ print STDERR
+ ref($referent), " ",
+ *{$symbol}{NAME}, " ",
+ "($referent) ", "was just declared ",
+ "and ascribed the ${attr} attribute ",
+ "with data ($data)\n",
+ "in phase $phase\n",
+ "in file $filename at line $linenum\n";
+ }
+
+This creates a handler for the attribute C<:Loud> in the class LoudDecl.
+Thereafter, any subroutine declared with a C<:Loud> attribute in the class
+LoudDecl:
+
+ package LoudDecl;
+
+ sub foo: Loud {...}
+
+causes the above handler to be invoked, and passed:
+
+=over
+
+=item [0]
+
+the name of the package into which it was declared;
+
+=item [1]
+
+a reference to the symbol table entry (typeglob) containing the subroutine;
+
+=item [2]
+
+a reference to the subroutine;
+
+=item [3]
+
+the name of the attribute;
+
+=item [4]
+
+any data associated with that attribute;
+
+=item [5]
+
+the name of the phase in which the handler is being invoked;
+
+=item [6]
+
+the filename in which the handler is being invoked;
+
+=item [7]
+
+the line number in this file.
+
+=back
+
+Likewise, declaring any variables with the C<:Loud> attribute within the
+package:
+
+ package LoudDecl;
+
+ my $foo :Loud;
+ my @foo :Loud;
+ my %foo :Loud;
+
+will cause the handler to be called with a similar argument list (except,
+of course, that C<$_[2]> will be a reference to the variable).
+
+The package name argument will typically be the name of the class into
+which the subroutine was declared, but it may also be the name of a derived
+class (since handlers are inherited).
+
+If a lexical variable is given an attribute, there is no symbol table to
+which it belongs, so the symbol table argument (C<$_[1]>) is set to the
+string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
+an anonymous subroutine results in a symbol table argument of C<'ANON'>.
+
+The data argument passes in the value (if any) associated with the
+attribute. For example, if C<&foo> had been declared:
+
+ sub foo :Loud("turn it up to 11, man!") {...}
+
+then a reference to an array containing the string
+C<"turn it up to 11, man!"> would be passed as the last argument.
+
+Attribute::Handlers makes strenuous efforts to convert
+the data argument (C<$_[4]>) to a useable form before passing it to
+the handler (but see L<"Non-interpretive attribute handlers">).
+If those efforts succeed, the interpreted data is passed in an array
+reference; if they fail, the raw data is passed as a string.
+For example, all of these:
+
+ sub foo :Loud(till=>ears=>are=>bleeding) {...}
+ sub foo :Loud(qw/till ears are bleeding/) {...}
+ sub foo :Loud(qw/my, ears, are, bleeding/) {...}
+ sub foo :Loud(till,ears,are,bleeding) {...}
+
+causes it to pass C<['till','ears','are','bleeding']> as the handler's
+data argument. While:
+
+ sub foo :Loud(['till','ears','are','bleeding']) {...}
+
+causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
+reference specified in the data being passed inside the standard
+array reference indicating successful interpretation.
+
+However, if the data can't be parsed as valid Perl, then
+it is passed as an uninterpreted string. For example:
+
+ sub foo :Loud(my,ears,are,bleeding) {...}
+ sub foo :Loud(qw/my ears are bleeding) {...}
+
+cause the strings C<'my,ears,are,bleeding'> and
+C<'qw/my ears are bleeding'> respectively to be passed as the
+data argument.
+
+If no value is associated with the attribute, C<undef> is passed.
+
+=head2 Typed lexicals
+
+Regardless of the package in which it is declared, if a lexical variable is
+ascribed an attribute, the handler that is invoked is the one belonging to
+the package to which it is typed. For example, the following declarations:
+
+ package OtherClass;
+
+ my LoudDecl $loudobj : Loud;
+ my LoudDecl @loudobjs : Loud;
+ my LoudDecl %loudobjex : Loud;
+
+causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
+defines a handler for C<:Loud> attributes).
+
+
+=head2 Type-specific attribute handlers
+
+If an attribute handler is declared and the C<:ATTR> specifier is
+given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
+the handler is only applied to declarations of that type. For example,
+the following definition:
+
+ package LoudDecl;
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+
+creates an attribute handler that applies only to scalars:
+
+
+ package Painful;
+ use base LoudDecl;
+
+ my $metal : RealLoud; # invokes &LoudDecl::RealLoud
+ my @metal : RealLoud; # error: unknown attribute
+ my %metal : RealLoud; # error: unknown attribute
+ sub metal : RealLoud {...} # error: unknown attribute
+
+You can, of course, declare separate handlers for these types as well
+(but you'll need to specify C<no warnings 'redefine'> to do it quietly):
+
+ package LoudDecl;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+ sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
+ sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
+ sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
+
+You can also explicitly indicate that a single handler is meant to be
+used for all types of referents like so:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
+
+(I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
+
+
+=head2 Non-interpretive attribute handlers
+
+Occasionally the strenuous efforts Attribute::Handlers makes to convert
+the data argument (C<$_[4]>) to a useable form before passing it to
+the handler get in the way.
+
+You can turn off that eagerness-to-help by declaring
+an attribute handler with the keyword C<RAWDATA>. For example:
+
+ sub Raw : ATTR(RAWDATA) {...}
+ sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
+ sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
+
+Then the handler makes absolutely no attempt to interpret the data it
+receives and simply passes it as a string:
+
+ my $power : Raw(1..100); # handlers receives "1..100"
+
+=head2 Phase-specific attribute handlers
+
+By default, attribute handlers are called at the end of the compilation
+phase (in a C<CHECK> block). This seems to be optimal in most cases because
+most things that can be defined are defined by that point but nothing has
+been executed.
+
+However, it is possible to set up attribute handlers that are called at
+other points in the program's compilation or execution, by explicitly
+stating the phase (or phases) in which you wish the attribute handler to
+be called. For example:
+
+ sub Early :ATTR(SCALAR,BEGIN) {...}
+ sub Normal :ATTR(SCALAR,CHECK) {...}
+ sub Late :ATTR(SCALAR,INIT) {...}
+ sub Final :ATTR(SCALAR,END) {...}
+ sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
+
+As the last example indicates, a handler may be set up to be (re)called in
+two or more phases. The phase name is passed as the handler's final argument.
+
+Note that attribute handlers that are scheduled for the C<BEGIN> phase
+are handled as soon as the attribute is detected (i.e. before any
+subsequently defined C<BEGIN> blocks are executed).
+
+
+=head2 Attributes as C<tie> interfaces
+
+Attributes make an excellent and intuitive interface through which to tie
+variables. For example:
+
+ use Attribute::Handlers;
+ use Tie::Cycle;
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+ tie $$referent, 'Tie::Cycle', $data;
+ }
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle('A'..'Z'); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+ }
+
+Note that, because the C<Cycle> attribute receives its arguments in the
+C<$data> variable, if the attribute is given a list of arguments, C<$data>
+will consist of a single array reference; otherwise, it will consist of the
+single argument directly. Since Tie::Cycle requires its cycling values to
+be passed as an array reference, this means that we need to wrap
+non-array-reference arguments in an array constructor:
+
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+
+Typically, however, things are the other way around: the tieable class expects
+its arguments as a flattened list, so the attribute looks like:
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ my @data = ref $data eq 'ARRAY' ? @$data : $data;
+ tie $$referent, 'Tie::Whatever', @data;
+ }
+
+
+This software pattern is so widely applicable that Attribute::Handlers
+provides a way to automate it: specifying C<'autotie'> in the
+C<use Attribute::Handlers> statement. So, the cycling example,
+could also be written:
+
+ use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle(['A'..'Z']); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+
+Note that we now have to pass the cycling values as an array reference,
+since the C<autotie> mechanism passes C<tie> a list of arguments as a list
+(as in the Tie::Whatever example), I<not> as an array reference (as in
+the original Tie::Cycle example at the start of this section).
+
+The argument after C<'autotie'> is a reference to a hash in which each key is
+the name of an attribute to be created, and each value is the class to which
+variables ascribed that attribute should be tied.
+
+Note that there is no longer any need to import the Tie::Cycle module --
+Attribute::Handlers takes care of that automagically. You can even pass
+arguments to the module's C<import> subroutine, by appending them to the
+class name. For example:
+
+ use Attribute::Handlers
+ autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+If the attribute name is unqualified, the attribute is installed in the
+current package. Otherwise it is installed in the qualifier's package:
+
+ package Here;
+
+ use Attribute::Handlers autotie => {
+ Other::Good => Tie::SecureHash, # tie attr installed in Other::
+ Bad => Tie::Taxes, # tie attr installed in Here::
+ UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
+ };
+
+Autoties are most commonly used in the module to which they actually tie,
+and need to export their attributes to any module that calls them. To
+facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
+C<__CALLER__>, which may be specified as the qualifier of an attribute:
+
+ package Tie::Me::Kangaroo:Down::Sport;
+
+ use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ };
+
+This causes Attribute::Handlers to define the C<Roo> attribute in the package
+that imports the Tie::Me::Kangaroo:Down::Sport module.
+
+Note that it is important to quote the __CALLER__::Roo identifier because
+a bug in perl 5.8 will refuse to parse it and cause an unknown error.
+
+=head3 Passing the tied object to C<tie>
+
+Occasionally it is important to pass a reference to the object being tied
+to the TIESCALAR, TIEHASH, etc. that ties it.
+
+The C<autotie> mechanism supports this too. The following code:
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+has the same effect as:
+
+ tie my $var, 'Tie::Selfish', @args;
+
+But when C<"autotieref"> is used instead of C<"autotie">:
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+the effect is to pass the C<tie> call an extra reference to the variable
+being tied:
+
+ tie my $var, 'Tie::Selfish', \$var, @args;
+
+
+
+=head1 EXAMPLES
+
+If the class shown in L<SYNOPSIS> were placed in the MyClass.pm
+module, then the following code:
+
+ package main;
+ use MyClass;
+
+ my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ package SomeOtherClass;
+ use base MyClass;
+
+ sub tent { 'acle' }
+
+ sub fn :Ugly(sister) :Omni('po',tent()) {...}
+ my @arr :Good :Omni(s/cie/nt/);
+ my %hsh :Good(q/bye/) :Omni(q/bus/);
+
+
+would cause the following handlers to be invoked:
+
+ # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Bad', # attr name
+ 0 # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Omni', # attr name
+ '-vorous' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # sub fn :Ugly(sister) :Omni('po',tent()) {...}
+
+ MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Ugly', # attr name
+ 'sister' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Omni', # attr name
+ ['po','acle'] # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my @arr :Good :Omni(s/cie/nt/);
+
+ MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Omni', # attr name
+ "" # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my %hsh :Good(q/bye) :Omni(q/bus/);
+
+ MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Good', # attr name
+ 'q/bye' # raw attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Omni', # attr name
+ 'bus' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+Installing handlers into UNIVERSAL, makes them...err..universal.
+For example:
+
+ package Descriptions;
+ use Attribute::Handlers;
+
+ my %name;
+ sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
+
+ sub UNIVERSAL::Name :ATTR {
+ $name{$_[2]} = $_[4];
+ }
+
+ sub UNIVERSAL::Purpose :ATTR {
+ print STDERR "Purpose of ", &name, " is $_[4]\n";
+ }
+
+ sub UNIVERSAL::Unit :ATTR {
+ print STDERR &name, " measured in $_[4]\n";
+ }
+
+Let's you write:
+
+ use Descriptions;
+
+ my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+
+ package Other;
+
+ sub foo : Purpose(to foo all data before barring it) { }
+
+ # etc.
+
+=head1 UTILITY FUNCTIONS
+
+This module offers a single utility function, C<findsym()>.
+
+=over 4
+
+=item findsym
+
+ my $symbol = Attribute::Handlers::findsym($package, $referent);
+
+The function looks in the symbol table of C<$package> for the typeglob for
+C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
+HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
+undef. Note that C<findsym> memoizes the typeglobs it has previously
+successfully found, so subsequent calls with the same arguments should be
+must faster.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over
+
+=item C<Bad attribute type: ATTR(%s)>
+
+An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
+type of referent it was defined to handle wasn't one of the five permitted:
+C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
+
+=item C<Attribute handler %s doesn't handle %s attributes>
+
+A handler for attributes of the specified name I<was> defined, but not
+for the specified type of declaration. Typically encountered whe trying
+to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
+attribute handler to some other type of variable.
+
+=item C<Declaration of %s attribute in package %s may clash with future reserved word>
+
+A handler for an attributes with an all-lowercase name was declared. An
+attribute with an all-lowercase name might have a meaning to Perl
+itself some day, even though most don't yet. Use a mixed-case attribute
+name, instead.
+
+=item C<Can't have two ATTR specifiers on one subroutine>
+
+You just can't, okay?
+Instead, put all the specifications together with commas between them
+in a single C<ATTR(I<specification>)>.
+
+=item C<Can't autotie a %s>
+
+You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
+C<"HASH">. They're the only things (apart from typeglobs -- which are
+not declarable) that Perl can tie.
+
+=item C<Internal error: %s symbol went missing>
+
+Something is rotten in the state of the program. An attributed
+subroutine ceased to exist between the point it was declared and the point
+at which its attribute handler(s) would have been called.
+
+=item C<Won't be able to apply END handler>
+
+You have defined an END handler for an attribute that is being applied
+to a lexical variable. Since the variable may not be available during END
+this won't happen.
+
+=back
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
+Garcia-Suarez (rgarciasuarez@gmail.com).
+
+Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
+Contact him with technical difficulties with respect to the packaging of the
+CPAN module.
+
+=head1 BUGS
+
+There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+Bug reports and other feedback are most welcome.
+
+=head1 COPYRIGHT AND LICENSE
+
+ Copyright (c) 2001-2009, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl.straw/lib/AutoSplit.pm b/Master/tlpkg/tlperl.straw/lib/AutoSplit.pm
new file mode 100755
index 00000000000..c093f2dd24b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/BerkeleyDB.pm b/Master/tlpkg/tlperl.straw/lib/BerkeleyDB.pm
new file mode 100755
index 00000000000..8269f8efa93
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/BerkeleyDB.pm
@@ -0,0 +1,1833 @@
+
+package BerkeleyDB;
+
+
+# Copyright (c) 1997-2010 Paul Marquess. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+
+# The documentation for this module is at the bottom of this file,
+# after the line __END__.
+
+BEGIN { require 5.005 }
+
+use strict;
+use Carp;
+use vars qw($VERSION @ISA @EXPORT $AUTOLOAD
+ $use_XSLoader);
+
+$VERSION = '0.41';
+
+require Exporter;
+#require DynaLoader;
+require AutoLoader;
+
+BEGIN {
+ $use_XSLoader = 1 ;
+ { local $SIG{__DIE__} ; eval { require XSLoader } ; }
+
+ if ($@) {
+ $use_XSLoader = 0 ;
+ require DynaLoader;
+ @ISA = qw(DynaLoader);
+ }
+}
+
+@ISA = qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# NOTE -- Do not add to @EXPORT directly. It is written by mkconsts
+@EXPORT = qw(
+ DB_AFTER
+ DB_AGGRESSIVE
+ DB_ALREADY_ABORTED
+ DB_APPEND
+ DB_APPLY_LOGREG
+ DB_APP_INIT
+ DB_ARCH_ABS
+ DB_ARCH_DATA
+ DB_ARCH_LOG
+ DB_ARCH_REMOVE
+ DB_ASSOC_IMMUTABLE_KEY
+ DB_AUTO_COMMIT
+ DB_BEFORE
+ DB_BTREE
+ DB_BTREEMAGIC
+ DB_BTREEOLDVER
+ DB_BTREEVERSION
+ DB_BUFFER_SMALL
+ DB_CACHED_COUNTS
+ DB_CDB_ALLDB
+ DB_CHECKPOINT
+ DB_CHKSUM
+ DB_CHKSUM_SHA1
+ DB_CKP_INTERNAL
+ DB_CLIENT
+ DB_CL_WRITER
+ DB_COMMIT
+ DB_COMPACT_FLAGS
+ DB_CONSUME
+ DB_CONSUME_WAIT
+ DB_CREATE
+ DB_CURLSN
+ DB_CURRENT
+ DB_CURSOR_BULK
+ DB_CURSOR_TRANSIENT
+ DB_CXX_NO_EXCEPTIONS
+ DB_DEGREE_2
+ DB_DELETED
+ DB_DELIMITER
+ DB_DIRECT
+ DB_DIRECT_DB
+ DB_DIRECT_LOG
+ DB_DIRTY_READ
+ DB_DONOTINDEX
+ DB_DSYNC_DB
+ DB_DSYNC_LOG
+ DB_DUP
+ DB_DUPCURSOR
+ DB_DUPSORT
+ DB_DURABLE_UNKNOWN
+ DB_EID_BROADCAST
+ DB_EID_INVALID
+ DB_ENCRYPT
+ DB_ENCRYPT_AES
+ DB_ENV_APPINIT
+ DB_ENV_AUTO_COMMIT
+ DB_ENV_CDB
+ DB_ENV_CDB_ALLDB
+ DB_ENV_CREATE
+ DB_ENV_DBLOCAL
+ DB_ENV_DIRECT_DB
+ DB_ENV_DIRECT_LOG
+ DB_ENV_DSYNC_DB
+ DB_ENV_DSYNC_LOG
+ DB_ENV_FAILCHK
+ DB_ENV_FATAL
+ DB_ENV_LOCKDOWN
+ DB_ENV_LOCKING
+ DB_ENV_LOGGING
+ DB_ENV_LOG_AUTOREMOVE
+ DB_ENV_LOG_INMEMORY
+ DB_ENV_MULTIVERSION
+ DB_ENV_NOLOCKING
+ DB_ENV_NOMMAP
+ DB_ENV_NOPANIC
+ DB_ENV_NO_OUTPUT_SET
+ DB_ENV_OPEN_CALLED
+ DB_ENV_OVERWRITE
+ DB_ENV_PANIC_OK
+ DB_ENV_PRIVATE
+ DB_ENV_RECOVER_FATAL
+ DB_ENV_REF_COUNTED
+ DB_ENV_REGION_INIT
+ DB_ENV_REP_CLIENT
+ DB_ENV_REP_LOGSONLY
+ DB_ENV_REP_MASTER
+ DB_ENV_RPCCLIENT
+ DB_ENV_RPCCLIENT_GIVEN
+ DB_ENV_STANDALONE
+ DB_ENV_SYSTEM_MEM
+ DB_ENV_THREAD
+ DB_ENV_TIME_NOTGRANTED
+ DB_ENV_TXN
+ DB_ENV_TXN_NOSYNC
+ DB_ENV_TXN_NOT_DURABLE
+ DB_ENV_TXN_NOWAIT
+ DB_ENV_TXN_SNAPSHOT
+ DB_ENV_TXN_WRITE_NOSYNC
+ DB_ENV_USER_ALLOC
+ DB_ENV_YIELDCPU
+ DB_EVENT_NOT_HANDLED
+ DB_EVENT_NO_SUCH_EVENT
+ DB_EVENT_PANIC
+ DB_EVENT_REG_ALIVE
+ DB_EVENT_REG_PANIC
+ DB_EVENT_REP_CLIENT
+ DB_EVENT_REP_ELECTED
+ DB_EVENT_REP_MASTER
+ DB_EVENT_REP_NEWMASTER
+ DB_EVENT_REP_PERM_FAILED
+ DB_EVENT_REP_STARTUPDONE
+ DB_EVENT_WRITE_FAILED
+ DB_EXCL
+ DB_EXTENT
+ DB_FAILCHK
+ DB_FAST_STAT
+ DB_FCNTL_LOCKING
+ DB_FILEOPEN
+ DB_FILE_ID_LEN
+ DB_FIRST
+ DB_FIXEDLEN
+ DB_FLUSH
+ DB_FORCE
+ DB_FOREIGN_ABORT
+ DB_FOREIGN_CASCADE
+ DB_FOREIGN_CONFLICT
+ DB_FOREIGN_NULLIFY
+ DB_FREELIST_ONLY
+ DB_FREE_SPACE
+ DB_GETREC
+ DB_GET_BOTH
+ DB_GET_BOTHC
+ DB_GET_BOTH_LTE
+ DB_GET_BOTH_RANGE
+ DB_GET_RECNO
+ DB_GID_SIZE
+ DB_HANDLE_LOCK
+ DB_HASH
+ DB_HASHMAGIC
+ DB_HASHOLDVER
+ DB_HASHVERSION
+ DB_IGNORE_LEASE
+ DB_IMMUTABLE_KEY
+ DB_INCOMPLETE
+ DB_INIT_CDB
+ DB_INIT_LOCK
+ DB_INIT_LOG
+ DB_INIT_MPOOL
+ DB_INIT_REP
+ DB_INIT_TXN
+ DB_INORDER
+ DB_JAVA_CALLBACK
+ DB_JOINENV
+ DB_JOIN_ITEM
+ DB_JOIN_NOSORT
+ DB_KEYEMPTY
+ DB_KEYEXIST
+ DB_KEYFIRST
+ DB_KEYLAST
+ DB_LAST
+ DB_LOCKDOWN
+ DB_LOCKMAGIC
+ DB_LOCKVERSION
+ DB_LOCK_ABORT
+ DB_LOCK_CONFLICT
+ DB_LOCK_DEADLOCK
+ DB_LOCK_DEFAULT
+ DB_LOCK_DUMP
+ DB_LOCK_EXPIRE
+ DB_LOCK_FREE_LOCKER
+ DB_LOCK_GET
+ DB_LOCK_GET_TIMEOUT
+ DB_LOCK_INHERIT
+ DB_LOCK_MAXLOCKS
+ DB_LOCK_MAXWRITE
+ DB_LOCK_MINLOCKS
+ DB_LOCK_MINWRITE
+ DB_LOCK_NORUN
+ DB_LOCK_NOTEXIST
+ DB_LOCK_NOTGRANTED
+ DB_LOCK_NOTHELD
+ DB_LOCK_NOWAIT
+ DB_LOCK_OLDEST
+ DB_LOCK_PUT
+ DB_LOCK_PUT_ALL
+ DB_LOCK_PUT_OBJ
+ DB_LOCK_PUT_READ
+ DB_LOCK_RANDOM
+ DB_LOCK_RECORD
+ DB_LOCK_REMOVE
+ DB_LOCK_RIW_N
+ DB_LOCK_RW_N
+ DB_LOCK_SET_TIMEOUT
+ DB_LOCK_SWITCH
+ DB_LOCK_TIMEOUT
+ DB_LOCK_TRADE
+ DB_LOCK_UPGRADE
+ DB_LOCK_UPGRADE_WRITE
+ DB_LOCK_YOUNGEST
+ DB_LOGCHKSUM
+ DB_LOGC_BUF_SIZE
+ DB_LOGFILEID_INVALID
+ DB_LOGMAGIC
+ DB_LOGOLDVER
+ DB_LOGVERSION
+ DB_LOGVERSION_LATCHING
+ DB_LOG_AUTOREMOVE
+ DB_LOG_AUTO_REMOVE
+ DB_LOG_BUFFER_FULL
+ DB_LOG_CHKPNT
+ DB_LOG_COMMIT
+ DB_LOG_DIRECT
+ DB_LOG_DISK
+ DB_LOG_DSYNC
+ DB_LOG_INMEMORY
+ DB_LOG_IN_MEMORY
+ DB_LOG_LOCKED
+ DB_LOG_NOCOPY
+ DB_LOG_NOT_DURABLE
+ DB_LOG_PERM
+ DB_LOG_RESEND
+ DB_LOG_SILENT_ERR
+ DB_LOG_WRNOSYNC
+ DB_LOG_ZERO
+ DB_MAX_PAGES
+ DB_MAX_RECORDS
+ DB_MPOOL_CLEAN
+ DB_MPOOL_CREATE
+ DB_MPOOL_DIRTY
+ DB_MPOOL_DISCARD
+ DB_MPOOL_EDIT
+ DB_MPOOL_EXTENT
+ DB_MPOOL_FREE
+ DB_MPOOL_LAST
+ DB_MPOOL_NEW
+ DB_MPOOL_NEW_GROUP
+ DB_MPOOL_NOFILE
+ DB_MPOOL_NOLOCK
+ DB_MPOOL_PRIVATE
+ DB_MPOOL_TRY
+ DB_MPOOL_UNLINK
+ DB_MULTIPLE
+ DB_MULTIPLE_KEY
+ DB_MULTIVERSION
+ DB_MUTEXDEBUG
+ DB_MUTEXLOCKS
+ DB_MUTEX_ALLOCATED
+ DB_MUTEX_LOCKED
+ DB_MUTEX_LOGICAL_LOCK
+ DB_MUTEX_PROCESS_ONLY
+ DB_MUTEX_SELF_BLOCK
+ DB_MUTEX_SHARED
+ DB_MUTEX_THREAD
+ DB_NEEDSPLIT
+ DB_NEXT
+ DB_NEXT_DUP
+ DB_NEXT_NODUP
+ DB_NOCOPY
+ DB_NODUPDATA
+ DB_NOLOCKING
+ DB_NOMMAP
+ DB_NOORDERCHK
+ DB_NOOVERWRITE
+ DB_NOPANIC
+ DB_NORECURSE
+ DB_NOSERVER
+ DB_NOSERVER_HOME
+ DB_NOSERVER_ID
+ DB_NOSYNC
+ DB_NOTFOUND
+ DB_NO_AUTO_COMMIT
+ DB_ODDFILESIZE
+ DB_OK_BTREE
+ DB_OK_HASH
+ DB_OK_QUEUE
+ DB_OK_RECNO
+ DB_OLD_VERSION
+ DB_OPEN_CALLED
+ DB_OPFLAGS_MASK
+ DB_ORDERCHKONLY
+ DB_OVERWRITE
+ DB_OVERWRITE_DUP
+ DB_PAD
+ DB_PAGEYIELD
+ DB_PAGE_LOCK
+ DB_PAGE_NOTFOUND
+ DB_PANIC_ENVIRONMENT
+ DB_PERMANENT
+ DB_POSITION
+ DB_POSITIONI
+ DB_PREV
+ DB_PREV_DUP
+ DB_PREV_NODUP
+ DB_PRINTABLE
+ DB_PRIORITY_DEFAULT
+ DB_PRIORITY_HIGH
+ DB_PRIORITY_LOW
+ DB_PRIORITY_UNCHANGED
+ DB_PRIORITY_VERY_HIGH
+ DB_PRIORITY_VERY_LOW
+ DB_PRIVATE
+ DB_PR_HEADERS
+ DB_PR_PAGE
+ DB_PR_RECOVERYTEST
+ DB_QAMMAGIC
+ DB_QAMOLDVER
+ DB_QAMVERSION
+ DB_QUEUE
+ DB_RDONLY
+ DB_RDWRMASTER
+ DB_READ_COMMITTED
+ DB_READ_UNCOMMITTED
+ DB_RECNO
+ DB_RECNUM
+ DB_RECORDCOUNT
+ DB_RECORD_LOCK
+ DB_RECOVER
+ DB_RECOVER_FATAL
+ DB_REGION_ANON
+ DB_REGION_INIT
+ DB_REGION_MAGIC
+ DB_REGION_NAME
+ DB_REGISTER
+ DB_REGISTERED
+ DB_RENAMEMAGIC
+ DB_RENUMBER
+ DB_REPFLAGS_MASK
+ DB_REPMGR_ACKS_ALL
+ DB_REPMGR_ACKS_ALL_PEERS
+ DB_REPMGR_ACKS_NONE
+ DB_REPMGR_ACKS_ONE
+ DB_REPMGR_ACKS_ONE_PEER
+ DB_REPMGR_ACKS_QUORUM
+ DB_REPMGR_CONF_2SITE_STRICT
+ DB_REPMGR_CONNECTED
+ DB_REPMGR_DISCONNECTED
+ DB_REPMGR_PEER
+ DB_REP_ACK_TIMEOUT
+ DB_REP_ANYWHERE
+ DB_REP_BULKOVF
+ DB_REP_CHECKPOINT_DELAY
+ DB_REP_CLIENT
+ DB_REP_CONF_BULK
+ DB_REP_CONF_DELAYCLIENT
+ DB_REP_CONF_INMEM
+ DB_REP_CONF_LEASE
+ DB_REP_CONF_NOAUTOINIT
+ DB_REP_CONF_NOWAIT
+ DB_REP_CONNECTION_RETRY
+ DB_REP_CREATE
+ DB_REP_DEFAULT_PRIORITY
+ DB_REP_DUPMASTER
+ DB_REP_EGENCHG
+ DB_REP_ELECTION
+ DB_REP_ELECTION_RETRY
+ DB_REP_ELECTION_TIMEOUT
+ DB_REP_FULL_ELECTION
+ DB_REP_FULL_ELECTION_TIMEOUT
+ DB_REP_HANDLE_DEAD
+ DB_REP_HEARTBEAT_MONITOR
+ DB_REP_HEARTBEAT_SEND
+ DB_REP_HOLDELECTION
+ DB_REP_IGNORE
+ DB_REP_ISPERM
+ DB_REP_JOIN_FAILURE
+ DB_REP_LEASE_EXPIRED
+ DB_REP_LEASE_TIMEOUT
+ DB_REP_LOCKOUT
+ DB_REP_LOGREADY
+ DB_REP_LOGSONLY
+ DB_REP_MASTER
+ DB_REP_NEWMASTER
+ DB_REP_NEWSITE
+ DB_REP_NOBUFFER
+ DB_REP_NOTPERM
+ DB_REP_OUTDATED
+ DB_REP_PAGEDONE
+ DB_REP_PAGELOCKED
+ DB_REP_PERMANENT
+ DB_REP_REREQUEST
+ DB_REP_STARTUPDONE
+ DB_REP_UNAVAIL
+ DB_REVSPLITOFF
+ DB_RMW
+ DB_RPCCLIENT
+ DB_RPC_SERVERPROG
+ DB_RPC_SERVERVERS
+ DB_RUNRECOVERY
+ DB_SALVAGE
+ DB_SA_SKIPFIRSTKEY
+ DB_SA_UNKNOWNKEY
+ DB_SECONDARY_BAD
+ DB_SEQUENCE_OLDVER
+ DB_SEQUENCE_VERSION
+ DB_SEQUENTIAL
+ DB_SEQ_DEC
+ DB_SEQ_INC
+ DB_SEQ_RANGE_SET
+ DB_SEQ_WRAP
+ DB_SEQ_WRAPPED
+ DB_SET
+ DB_SET_LOCK_TIMEOUT
+ DB_SET_LTE
+ DB_SET_RANGE
+ DB_SET_RECNO
+ DB_SET_REG_TIMEOUT
+ DB_SET_TXN_NOW
+ DB_SET_TXN_TIMEOUT
+ DB_SHALLOW_DUP
+ DB_SNAPSHOT
+ DB_SPARE_FLAG
+ DB_STAT_ALL
+ DB_STAT_CLEAR
+ DB_STAT_LOCK_CONF
+ DB_STAT_LOCK_LOCKERS
+ DB_STAT_LOCK_OBJECTS
+ DB_STAT_LOCK_PARAMS
+ DB_STAT_MEMP_HASH
+ DB_STAT_MEMP_NOERROR
+ DB_STAT_NOERROR
+ DB_STAT_SUBSYSTEM
+ DB_ST_DUPOK
+ DB_ST_DUPSET
+ DB_ST_DUPSORT
+ DB_ST_IS_RECNO
+ DB_ST_OVFL_LEAF
+ DB_ST_RECNUM
+ DB_ST_RELEN
+ DB_ST_TOPLEVEL
+ DB_SURPRISE_KID
+ DB_SWAPBYTES
+ DB_SYSTEM_MEM
+ DB_TEMPORARY
+ DB_TEST_ELECTINIT
+ DB_TEST_ELECTSEND
+ DB_TEST_ELECTVOTE1
+ DB_TEST_ELECTVOTE2
+ DB_TEST_ELECTWAIT1
+ DB_TEST_ELECTWAIT2
+ DB_TEST_POSTDESTROY
+ DB_TEST_POSTLOG
+ DB_TEST_POSTLOGMETA
+ DB_TEST_POSTOPEN
+ DB_TEST_POSTRENAME
+ DB_TEST_POSTSYNC
+ DB_TEST_PREDESTROY
+ DB_TEST_PREOPEN
+ DB_TEST_PRERENAME
+ DB_TEST_RECYCLE
+ DB_TEST_SUBDB_LOCKS
+ DB_THREAD
+ DB_THREADID_STRLEN
+ DB_TIMEOUT
+ DB_TIME_NOTGRANTED
+ DB_TRUNCATE
+ DB_TXNMAGIC
+ DB_TXNVERSION
+ DB_TXN_ABORT
+ DB_TXN_APPLY
+ DB_TXN_BACKWARD_ROLL
+ DB_TXN_CKP
+ DB_TXN_FORWARD_ROLL
+ DB_TXN_LOCK
+ DB_TXN_LOCK_2PL
+ DB_TXN_LOCK_MASK
+ DB_TXN_LOCK_OPTIMIST
+ DB_TXN_LOCK_OPTIMISTIC
+ DB_TXN_LOG_MASK
+ DB_TXN_LOG_REDO
+ DB_TXN_LOG_UNDO
+ DB_TXN_LOG_UNDOREDO
+ DB_TXN_NOSYNC
+ DB_TXN_NOT_DURABLE
+ DB_TXN_NOWAIT
+ DB_TXN_OPENFILES
+ DB_TXN_POPENFILES
+ DB_TXN_PRINT
+ DB_TXN_REDO
+ DB_TXN_SNAPSHOT
+ DB_TXN_SYNC
+ DB_TXN_UNDO
+ DB_TXN_WAIT
+ DB_TXN_WRITE_NOSYNC
+ DB_UNKNOWN
+ DB_UNREF
+ DB_UPDATE_SECONDARY
+ DB_UPGRADE
+ DB_USERCOPY_GETDATA
+ DB_USERCOPY_SETDATA
+ DB_USE_ENVIRON
+ DB_USE_ENVIRON_ROOT
+ DB_VERB_CHKPOINT
+ DB_VERB_DEADLOCK
+ DB_VERB_FILEOPS
+ DB_VERB_FILEOPS_ALL
+ DB_VERB_RECOVERY
+ DB_VERB_REGISTER
+ DB_VERB_REPLICATION
+ DB_VERB_REPMGR_CONNFAIL
+ DB_VERB_REPMGR_MISC
+ DB_VERB_REP_ELECT
+ DB_VERB_REP_LEASE
+ DB_VERB_REP_MISC
+ DB_VERB_REP_MSGS
+ DB_VERB_REP_SYNC
+ DB_VERB_REP_TEST
+ DB_VERB_WAITSFOR
+ DB_VERIFY
+ DB_VERIFY_BAD
+ DB_VERIFY_FATAL
+ DB_VERIFY_PARTITION
+ DB_VERSION_MAJOR
+ DB_VERSION_MINOR
+ DB_VERSION_MISMATCH
+ DB_VERSION_PATCH
+ DB_VERSION_STRING
+ DB_VRFY_FLAGMASK
+ DB_WRITECURSOR
+ DB_WRITELOCK
+ DB_WRITEOPEN
+ DB_WRNOSYNC
+ DB_XA_CREATE
+ DB_XIDDATASIZE
+ DB_YIELDCPU
+ DB_debug_FLAG
+ DB_user_BEGIN
+ );
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
+
+#bootstrap BerkeleyDB $VERSION;
+if ($use_XSLoader)
+ { XSLoader::load("BerkeleyDB", $VERSION)}
+else
+ { bootstrap BerkeleyDB $VERSION }
+
+# Preloaded methods go here.
+
+
+sub ParseParameters($@)
+{
+ my ($default, @rest) = @_ ;
+ my (%got) = %$default ;
+ my (@Bad) ;
+ my ($key, $value) ;
+ my $sub = (caller(1))[3] ;
+ my %options = () ;
+ local ($Carp::CarpLevel) = 1 ;
+
+ # allow the options to be passed as a hash reference or
+ # as the complete hash.
+ if (@rest == 1) {
+
+ croak "$sub: parameter is not a reference to a hash"
+ if ref $rest[0] ne "HASH" ;
+
+ %options = %{ $rest[0] } ;
+ }
+ elsif (@rest >= 2 && @rest % 2 == 0) {
+ %options = @rest ;
+ }
+ elsif (@rest > 0) {
+ croak "$sub: malformed option list";
+ }
+
+ while (($key, $value) = each %options)
+ {
+ $key =~ s/^-// ;
+
+ if (exists $default->{$key})
+ { $got{$key} = $value }
+ else
+ { push (@Bad, $key) }
+ }
+
+ if (@Bad) {
+ my ($bad) = join(", ", @Bad) ;
+ croak "unknown key value(s) $bad" ;
+ }
+
+ return \%got ;
+}
+
+sub parseEncrypt
+{
+ my $got = shift ;
+
+
+ if (defined $got->{Encrypt}) {
+ croak("Encrypt parameter must be a hash reference")
+ if !ref $got->{Encrypt} || ref $got->{Encrypt} ne 'HASH' ;
+
+ my %config = %{ $got->{Encrypt} } ;
+
+ my $p = BerkeleyDB::ParseParameters({
+ Password => undef,
+ Flags => undef,
+ }, %config);
+
+ croak("Must specify Password and Flags with Encrypt parameter")
+ if ! (defined $p->{Password} && defined $p->{Flags});
+
+ $got->{"Enc_Passwd"} = $p->{Password};
+ $got->{"Enc_Flags"} = $p->{Flags};
+ }
+}
+
+use UNIVERSAL ;
+
+sub env_remove
+{
+ # Usage:
+ #
+ # $env = BerkeleyDB::env_remove
+ # [ -Home => $path, ]
+ # [ -Config => { name => value, name => value }
+ # [ -Flags => DB_INIT_LOCK| ]
+ # ;
+
+ my $got = BerkeleyDB::ParseParameters({
+ Home => undef,
+ Flags => 0,
+ Config => undef,
+ }, @_) ;
+
+ if (defined $got->{Config}) {
+ croak("Config parameter must be a hash reference")
+ if ! ref $got->{Config} eq 'HASH' ;
+
+ @BerkeleyDB::a = () ;
+ my $k = "" ; my $v = "" ;
+ while (($k, $v) = each %{$got->{Config}}) {
+ push @BerkeleyDB::a, "$k\t$v" ;
+ }
+
+ $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef)
+ if @BerkeleyDB::a ;
+ }
+
+ return _env_remove($got) ;
+}
+
+sub db_remove
+{
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ Filename => undef,
+ Subname => undef,
+ Flags => 0,
+ Env => undef,
+ Txn => undef,
+ }, @_) ;
+
+ croak("Must specify a filename")
+ if ! defined $got->{Filename} ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ return _db_remove($got);
+}
+
+sub db_rename
+{
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ Filename => undef,
+ Subname => undef,
+ Newname => undef,
+ Flags => 0,
+ Env => undef,
+ Txn => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Must specify a filename")
+ if ! defined $got->{Filename} ;
+
+ #croak("Must specify a Subname")
+ #if ! defined $got->{Subname} ;
+
+ croak("Must specify a Newname")
+ if ! defined $got->{Newname} ;
+
+ return _db_rename($got);
+}
+
+sub db_verify
+{
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ Filename => undef,
+ Subname => undef,
+ Outfile => undef,
+ Flags => 0,
+ Env => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Must specify a filename")
+ if ! defined $got->{Filename} ;
+
+ return _db_verify($got);
+}
+
+package BerkeleyDB::Env ;
+
+use UNIVERSAL ;
+use Carp ;
+use IO::File;
+use vars qw( %valid_config_keys ) ;
+
+sub isaFilehandle
+{
+ my $fh = shift ;
+
+ return ((UNIVERSAL::isa($fh,'GLOB') or UNIVERSAL::isa(\$fh,'GLOB')) and defined fileno($fh) )
+
+}
+
+%valid_config_keys = map { $_, 1 } qw( DB_DATA_DIR DB_LOG_DIR DB_TEMP_DIR
+DB_TMP_DIR ) ;
+
+sub new
+{
+ # Usage:
+ #
+ # $env = new BerkeleyDB::Env
+ # [ -Home => $path, ]
+ # [ -Mode => mode, ]
+ # [ -Config => { name => value, name => value }
+ # [ -ErrFile => filename, ]
+ # [ -ErrPrefix => "string", ]
+ # [ -Flags => DB_INIT_LOCK| ]
+ # [ -Set_Flags => $flags,]
+ # [ -Cachesize => number ]
+ # [ -LockDetect => ]
+ # [ -Verbose => boolean ]
+ # [ -Encrypt => { Password => string, Flags => value}
+ #
+ # ;
+
+ my $pkg = shift ;
+ my $got = BerkeleyDB::ParseParameters({
+ Home => undef,
+ Server => undef,
+ Mode => 0666,
+ ErrFile => undef,
+ MsgFile => undef,
+ ErrPrefix => undef,
+ Flags => 0,
+ SetFlags => 0,
+ Cachesize => 0,
+ LockDetect => 0,
+ TxMax => 0,
+ LogConfig => 0,
+ MaxLockers => 0,
+ MaxLocks => 0,
+ MaxObjects => 0,
+ Verbose => 0,
+ Config => undef,
+ Encrypt => undef,
+ SharedMemKey => undef,
+ ThreadCount => 0,
+ }, @_) ;
+
+ my $errfile = $got->{ErrFile} ;
+ if (defined $got->{ErrFile}) {
+ if (!isaFilehandle($got->{ErrFile})) {
+ my $handle = new IO::File ">$got->{ErrFile}"
+ or croak "Cannot open file $got->{ErrFile}: $!\n" ;
+ $errfile = $got->{ErrFile} = $handle ;
+ }
+ }
+
+ if (defined $got->{MsgFile}) {
+ my $msgfile = $got->{MsgFile} ;
+ if (!isaFilehandle($msgfile)) {
+ my $handle = new IO::File ">$msgfile"
+ or croak "Cannot open file $msgfile: $!\n" ;
+ $got->{MsgFile} = $handle ;
+ }
+ }
+
+ my %config ;
+ if (defined $got->{Config}) {
+ croak("Config parameter must be a hash reference")
+ if ! ref $got->{Config} eq 'HASH' ;
+
+ %config = %{ $got->{Config} } ;
+ @BerkeleyDB::a = () ;
+ my $k = "" ; my $v = "" ;
+ while (($k, $v) = each %config) {
+ if ($BerkeleyDB::db_version >= 3.1 && ! $valid_config_keys{$k} ){
+ $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ;
+ croak $BerkeleyDB::Error ;
+ }
+ push @BerkeleyDB::a, "$k\t$v" ;
+ $got->{$k} = $v;
+ }
+
+ $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef)
+ if @BerkeleyDB::a ;
+ }
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr) = _db_appinit($pkg, $got, $errfile);
+ my $obj ;
+ $obj = bless [$addr] , $pkg if $addr ;
+# if ($obj && $BerkeleyDB::db_version >= 3.1 && keys %config) {
+# my ($k, $v);
+# while (($k, $v) = each %config) {
+# if ($k eq 'DB_DATA_DIR')
+# { $obj->set_data_dir($v) }
+# elsif ($k eq 'DB_LOG_DIR')
+# { $obj->set_lg_dir($v) }
+# elsif ($k eq 'DB_TEMP_DIR' || $k eq 'DB_TMP_DIR')
+# { $obj->set_tmp_dir($v) }
+# else {
+# $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ;
+# croak $BerkeleyDB::Error
+# }
+# }
+# }
+ return $obj ;
+}
+
+
+sub TxnMgr
+{
+ my $env = shift ;
+ my ($addr) = $env->_TxnMgr() ;
+ my $obj ;
+ $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ;
+ return $obj ;
+}
+
+sub txn_begin
+{
+ my $env = shift ;
+ my ($addr) = $env->_txn_begin(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $env] , "BerkeleyDB::Txn" if $addr ;
+ return $obj ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+
+package BerkeleyDB::Hash ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Hash specific
+ Ffactor => 0,
+ Nelem => 0,
+ Hash => undef,
+ DupCompare => undef,
+
+ # BerkeleyDB specific
+ ReadKey => undef,
+ WriteKey => undef,
+ ReadValue => undef,
+ WriteValue => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("-Tie needs a reference to a hash")
+ if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr) = _db_open_hash($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*TIEHASH = \&new ;
+
+
+package BerkeleyDB::Btree ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Btree specific
+ Minkey => 0,
+ Compare => undef,
+ DupCompare => undef,
+ Prefix => undef,
+ set_bt_compress => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("-Tie needs a reference to a hash")
+ if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
+
+# if (defined $got->{set_bt_compress} )
+# {
+#
+# croak("-set_bt_compress needs a reference to a 2-element array")
+# if $got->{set_bt_compress} !~ /ARRAY/ ||
+#
+# croak("-set_bt_compress needs a reference to a 2-element array")
+# if $got->{set_bt_compress} !~ /ARRAY/ ||
+# @{ $got->{set_bt_compress} } != 2;
+#
+# $got->{"_btcompress1"} = $got->{set_bt_compress}[0]
+# if defined $got->{set_bt_compress}[0];
+#
+# $got->{"_btcompress2"} = $got->{set_bt_compress}[1]
+# if defined $got->{set_bt_compress}[1];
+# }
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr) = _db_open_btree($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*BerkeleyDB::Btree::TIEHASH = \&BerkeleyDB::Btree::new ;
+
+
+package BerkeleyDB::Recno ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Recno specific
+ Delim => undef,
+ Len => undef,
+ Pad => undef,
+ Source => undef,
+ ArrayBase => 1, # lowest index in array
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("Tie needs a reference to an array")
+ if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
+
+ croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
+ if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;
+
+
+ BerkeleyDB::parseEncrypt($got);
+
+ $got->{Fname} = $got->{Filename} if defined $got->{Filename} ;
+
+ my ($addr) = _db_open_recno($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*BerkeleyDB::Recno::TIEARRAY = \&BerkeleyDB::Recno::new ;
+*BerkeleyDB::Recno::db_stat = \&BerkeleyDB::Btree::db_stat ;
+
+package BerkeleyDB::Queue ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Queue specific
+ Len => undef,
+ Pad => undef,
+ ArrayBase => 1, # lowest index in array
+ ExtentSize => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("Tie needs a reference to an array")
+ if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
+
+ croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
+ if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;
+
+ BerkeleyDB::parseEncrypt($got);
+
+ $got->{Fname} = $got->{Filename} if defined $got->{Filename} ;
+
+ my ($addr) = _db_open_queue($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*BerkeleyDB::Queue::TIEARRAY = \&BerkeleyDB::Queue::new ;
+
+sub UNSHIFT
+{
+ my $self = shift;
+ croak "unshift is unsupported with Queue databases";
+}
+
+## package BerkeleyDB::Text ;
+##
+## use vars qw(@ISA) ;
+## @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+## use UNIVERSAL ;
+## use Carp ;
+##
+## sub new
+## {
+## my $self = shift ;
+## my $got = BerkeleyDB::ParseParameters(
+## {
+## # Generic Stuff
+## Filename => undef,
+## #Flags => BerkeleyDB::DB_CREATE(),
+## Flags => 0,
+## Property => 0,
+## Mode => 0666,
+## Cachesize => 0,
+## Lorder => 0,
+## Pagesize => 0,
+## Env => undef,
+## #Tie => undef,
+## Txn => undef,
+##
+## # Recno specific
+## Delim => undef,
+## Len => undef,
+## Pad => undef,
+## Btree => undef,
+## }, @_) ;
+##
+## croak("Env not of type BerkeleyDB::Env")
+## if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
+##
+## croak("Txn not of type BerkeleyDB::Txn")
+## if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
+##
+## croak("-Tie needs a reference to an array")
+## if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
+##
+## # rearange for recno
+## $got->{Source} = $got->{Filename} if defined $got->{Filename} ;
+## delete $got->{Filename} ;
+## $got->{Fname} = $got->{Btree} if defined $got->{Btree} ;
+## return BerkeleyDB::Recno::_db_open_recno($self, $got);
+## }
+##
+## *BerkeleyDB::Text::TIEARRAY = \&BerkeleyDB::Text::new ;
+## *BerkeleyDB::Text::db_stat = \&BerkeleyDB::Btree::db_stat ;
+
+package BerkeleyDB::Unknown ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("-Tie needs a reference to a hash")
+ if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr, $type) = _db_open_unknown($got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr], "BerkeleyDB::$type" ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+
+package BerkeleyDB::_tiedHash ;
+
+use Carp ;
+
+#sub TIEHASH
+#{
+# my $self = shift ;
+# my $db_object = shift ;
+#
+#print "Tiehash REF=[$self] [" . (ref $self) . "]\n" ;
+#
+# return bless { Obj => $db_object}, $self ;
+#}
+
+sub Tie
+{
+ # Usage:
+ #
+ # $db->Tie \%hash ;
+ #
+
+ my $self = shift ;
+
+ #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ;
+
+ croak("usage \$x->Tie \\%hash\n") unless @_ ;
+ my $ref = shift ;
+
+ croak("Tie needs a reference to a hash")
+ if defined $ref and $ref !~ /HASH/ ;
+
+ #tie %{ $ref }, ref($self), $self ;
+ tie %{ $ref }, "BerkeleyDB::_tiedHash", $self ;
+ return undef ;
+}
+
+
+sub TIEHASH
+{
+ my $self = shift ;
+ my $db_object = shift ;
+ #return bless $db_object, 'BerkeleyDB::Common' ;
+ return $db_object ;
+}
+
+sub STORE
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ $self->db_put($key, $value) ;
+}
+
+sub FETCH
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = undef ;
+ $self->db_get($key, $value) ;
+
+ return $value ;
+}
+
+sub EXISTS
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = undef ;
+ $self->db_get($key, $value) == 0 ;
+}
+
+sub DELETE
+{
+ my $self = shift ;
+ my $key = shift ;
+ $self->db_del($key) ;
+}
+
+sub CLEAR
+{
+ my $self = shift ;
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0)
+ { $cursor->c_del() }
+}
+
+#sub DESTROY
+#{
+# my $self = shift ;
+# print "BerkeleyDB::_tieHash::DESTROY\n" ;
+# $self->{Cursor}->c_close() if $self->{Cursor} ;
+#}
+
+package BerkeleyDB::_tiedArray ;
+
+use Carp ;
+
+sub Tie
+{
+ # Usage:
+ #
+ # $db->Tie \@array ;
+ #
+
+ my $self = shift ;
+
+ #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ;
+
+ croak("usage \$x->Tie \\%hash\n") unless @_ ;
+ my $ref = shift ;
+
+ croak("Tie needs a reference to an array")
+ if defined $ref and $ref !~ /ARRAY/ ;
+
+ #tie %{ $ref }, ref($self), $self ;
+ tie @{ $ref }, "BerkeleyDB::_tiedArray", $self ;
+ return undef ;
+}
+
+
+#sub TIEARRAY
+#{
+# my $self = shift ;
+# my $db_object = shift ;
+#
+#print "Tiearray REF=[$self] [" . (ref $self) . "]\n" ;
+#
+# return bless { Obj => $db_object}, $self ;
+#}
+
+sub TIEARRAY
+{
+ my $self = shift ;
+ my $db_object = shift ;
+ #return bless $db_object, 'BerkeleyDB::Common' ;
+ return $db_object ;
+}
+
+sub STORE
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ $self->db_put($key, $value) ;
+}
+
+sub FETCH
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = undef ;
+ $self->db_get($key, $value) ;
+
+ return $value ;
+}
+
+*CLEAR = \&BerkeleyDB::_tiedHash::CLEAR ;
+*FIRSTKEY = \&BerkeleyDB::_tiedHash::FIRSTKEY ;
+*NEXTKEY = \&BerkeleyDB::_tiedHash::NEXTKEY ;
+
+sub EXTEND {} # don't do anything with EXTEND
+
+
+sub SHIFT
+{
+ my $self = shift;
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) != 0 ;
+ return undef if $cursor->c_del() != 0 ;
+
+ return $value ;
+}
+
+
+sub UNSHIFT
+{
+ my $self = shift;
+ if (@_)
+ {
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) ;
+ if ($status == 0)
+ {
+ foreach $value (reverse @_)
+ {
+ $key = 0 ;
+ $cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ;
+ }
+ }
+ elsif ($status == BerkeleyDB::DB_NOTFOUND())
+ {
+ $key = 0 ;
+ foreach $value (@_)
+ {
+ $self->db_put($key++, $value) ;
+ }
+ }
+ }
+}
+
+sub PUSH
+{
+ my $self = shift;
+ if (@_)
+ {
+ my ($key, $value) = (-1, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) ;
+ if ($status == 0 || $status == BerkeleyDB::DB_NOTFOUND())
+ {
+ $key = -1 if $status != 0 and $self->type != BerkeleyDB::DB_RECNO() ;
+ foreach $value (@_)
+ {
+ ++ $key ;
+ $status = $self->db_put($key, $value) ;
+ }
+ }
+
+# can use this when DB_APPEND is fixed.
+# foreach $value (@_)
+# {
+# my $status = $cursor->c_put($key, $value, BerkeleyDB::DB_AFTER()) ;
+#print "[$status]\n" ;
+# }
+ }
+}
+
+sub POP
+{
+ my $self = shift;
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) != 0 ;
+ return undef if $cursor->c_del() != 0 ;
+
+ return $value ;
+}
+
+sub SPLICE
+{
+ my $self = shift;
+ croak "SPLICE is not implemented yet" ;
+}
+
+*shift = \&SHIFT ;
+*unshift = \&UNSHIFT ;
+*push = \&PUSH ;
+*pop = \&POP ;
+*clear = \&CLEAR ;
+*length = \&FETCHSIZE ;
+
+sub STORESIZE
+{
+ croak "STORESIZE is not implemented yet" ;
+#print "STORESIZE @_\n" ;
+# my $self = shift;
+# my $length = shift ;
+# my $current_length = $self->FETCHSIZE() ;
+#print "length is $current_length\n";
+#
+# if ($length < $current_length) {
+#print "Make smaller $length < $current_length\n" ;
+# my $key ;
+# for ($key = $current_length - 1 ; $key >= $length ; -- $key)
+# { $self->db_del($key) }
+# }
+# elsif ($length > $current_length) {
+#print "Make larger $length > $current_length\n" ;
+# $self->db_put($length-1, "") ;
+# }
+# else { print "stay the same\n" }
+
+}
+
+
+
+#sub DESTROY
+#{
+# my $self = shift ;
+# print "BerkeleyDB::_tieArray::DESTROY\n" ;
+#}
+
+
+package BerkeleyDB::Common ;
+
+
+use Carp ;
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+
+sub Txn
+{
+ my $self = shift ;
+ my $txn = shift ;
+ #print "BerkeleyDB::Common::Txn db [$self] txn [$txn]\n" ;
+ if ($txn) {
+ $self->_Txn($txn) ;
+ push @{ $txn }, $self ;
+ }
+ else {
+ $self->_Txn() ;
+ }
+ #print "end BerkeleyDB::Common::Txn \n";
+}
+
+
+sub get_dup
+{
+ croak "Usage: \$db->get_dup(key [,flag])\n"
+ unless @_ == 2 or @_ == 3 ;
+
+ my $db = shift ;
+ my $key = shift ;
+ my $flag = shift ;
+ my $value = 0 ;
+ my $origkey = $key ;
+ my $wantarray = wantarray ;
+ my %values = () ;
+ my @values = () ;
+ my $counter = 0 ;
+ my $status = 0 ;
+ my $cursor = $db->db_cursor() ;
+
+ # iterate through the database until either EOF ($status == 0)
+ # or a different key is encountered ($key ne $origkey).
+ for ($status = $cursor->c_get($key, $value, BerkeleyDB::DB_SET()) ;
+ $status == 0 and $key eq $origkey ;
+ $status = $cursor->c_get($key, $value, BerkeleyDB::DB_NEXT()) ) {
+ # save the value or count number of matches
+ if ($wantarray) {
+ if ($flag)
+ { ++ $values{$value} }
+ else
+ { push (@values, $value) }
+ }
+ else
+ { ++ $counter }
+
+ }
+
+ return ($wantarray ? ($flag ? %values : @values) : $counter) ;
+}
+
+sub db_cursor
+{
+ my $db = shift ;
+ my ($addr) = $db->_db_cursor(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+sub _db_write_cursor
+{
+ my $db = shift ;
+ my ($addr) = $db->__db_write_cursor(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+sub db_join
+{
+ croak 'Usage: $db->BerkeleyDB::db_join([cursors], flags=0)'
+ if @_ < 2 || @_ > 3 ;
+ my $db = shift ;
+ croak 'db_join: first parameter is not an array reference'
+ if ! ref $_[0] || ref $_[0] ne 'ARRAY';
+ my ($addr) = $db->_db_join(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $db, $_[0]] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+package BerkeleyDB::Cursor ;
+
+sub c_close
+{
+ my $cursor = shift ;
+ $cursor->[1] = "" ;
+ return $cursor->_c_close() ;
+}
+
+sub c_dup
+{
+ my $cursor = shift ;
+ my ($addr) = $cursor->_c_dup(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $cursor->[1]] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+
+package BerkeleyDB::TxnMgr ;
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+
+sub txn_begin
+{
+ my $txnmgr = shift ;
+ my ($addr) = $txnmgr->_txn_begin(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $txnmgr] , "BerkeleyDB::Txn" if $addr ;
+ return $obj ;
+}
+
+package BerkeleyDB::Txn ;
+
+sub Txn
+{
+ my $self = shift ;
+ my $db ;
+ # keep a reference to each db in the txn object
+ foreach $db (@_) {
+ $db->_Txn($self) ;
+ push @{ $self}, $db ;
+ }
+}
+
+sub txn_commit
+{
+ my $self = shift ;
+ $self->disassociate() ;
+ my $status = $self->_txn_commit() ;
+ return $status ;
+}
+
+sub txn_abort
+{
+ my $self = shift ;
+ $self->disassociate() ;
+ my $status = $self->_txn_abort() ;
+ return $status ;
+}
+
+sub disassociate
+{
+ my $self = shift ;
+ my $db ;
+ while ( @{ $self } > 2) {
+ $db = pop @{ $self } ;
+ $db->Txn() ;
+ }
+ #print "end disassociate\n" ;
+}
+
+
+sub DESTROY
+{
+ my $self = shift ;
+
+ $self->disassociate() ;
+ # first close the close the transaction
+ $self->_DESTROY() ;
+}
+
+package BerkeleyDB::CDS::Lock;
+
+use vars qw(%Object %Count);
+use Carp;
+
+sub BerkeleyDB::Common::cds_lock
+{
+ my $db = shift ;
+
+ # fatal error if database not opened in CDS mode
+ croak("CDS not enabled for this database\n")
+ if ! $db->cds_enabled();
+
+ if ( ! defined $Object{"$db"})
+ {
+ $Object{"$db"} = $db->_db_write_cursor()
+ || return undef ;
+ }
+
+ ++ $Count{"$db"} ;
+
+ return bless [$db, 1], "BerkeleyDB::CDS::Lock" ;
+}
+
+sub cds_unlock
+{
+ my $self = shift ;
+ my $db = $self->[0] ;
+
+ if ($self->[1])
+ {
+ $self->[1] = 0 ;
+ -- $Count{"$db"} if $Count{"$db"} > 0 ;
+
+ if ($Count{"$db"} == 0)
+ {
+ $Object{"$db"}->c_close() ;
+ undef $Object{"$db"};
+ }
+
+ return 1 ;
+ }
+
+ return undef ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->cds_unlock() ;
+}
+
+package BerkeleyDB::Term ;
+
+END
+{
+ close_everything() ;
+}
+
+
+package BerkeleyDB ;
+
+
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/BerkeleyDB.pod b/Master/tlpkg/tlperl.straw/lib/BerkeleyDB.pod
new file mode 100755
index 00000000000..fc88667b3f3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/BerkeleyDB.pod
@@ -0,0 +1,2518 @@
+=head1 NAME
+
+BerkeleyDB - Perl extension for Berkeley DB version 2, 3 or 4
+
+=head1 SYNOPSIS
+
+ use BerkeleyDB;
+
+ $env = new BerkeleyDB::Env [OPTIONS] ;
+
+ $db = tie %hash, 'BerkeleyDB::Hash', [OPTIONS] ;
+ $db = new BerkeleyDB::Hash [OPTIONS] ;
+
+ $db = tie %hash, 'BerkeleyDB::Btree', [OPTIONS] ;
+ $db = new BerkeleyDB::Btree [OPTIONS] ;
+
+ $db = tie @array, 'BerkeleyDB::Recno', [OPTIONS] ;
+ $db = new BerkeleyDB::Recno [OPTIONS] ;
+
+ $db = tie @array, 'BerkeleyDB::Queue', [OPTIONS] ;
+ $db = new BerkeleyDB::Queue [OPTIONS] ;
+
+ $db = new BerkeleyDB::Unknown [OPTIONS] ;
+
+ $status = BerkeleyDB::db_remove [OPTIONS]
+ $status = BerkeleyDB::db_rename [OPTIONS]
+ $status = BerkeleyDB::db_verify [OPTIONS]
+
+ $hash{$key} = $value ;
+ $value = $hash{$key} ;
+ each %hash ;
+ keys %hash ;
+ values %hash ;
+
+ $status = $db->db_get()
+ $status = $db->db_put() ;
+ $status = $db->db_del() ;
+ $status = $db->db_sync() ;
+ $status = $db->db_close() ;
+ $status = $db->db_pget()
+ $hash_ref = $db->db_stat() ;
+ $status = $db->db_key_range();
+ $type = $db->type() ;
+ $status = $db->status() ;
+ $boolean = $db->byteswapped() ;
+ $status = $db->truncate($count) ;
+ $status = $db->compact($start, $stop, $c_data, $flags, $end);
+
+ $bool = $env->cds_enabled();
+ $bool = $db->cds_enabled();
+ $lock = $db->cds_lock();
+ $lock->cds_unlock();
+
+ ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
+ ($flag, $old_offset, $old_length) = $db->partial_clear() ;
+
+ $cursor = $db->db_cursor([$flags]) ;
+ $newcursor = $cursor->c_dup([$flags]);
+ $status = $cursor->c_get() ;
+ $status = $cursor->c_put() ;
+ $status = $cursor->c_del() ;
+ $status = $cursor->c_count() ;
+ $status = $cursor->c_pget() ;
+ $status = $cursor->status() ;
+ $status = $cursor->c_close() ;
+
+ $cursor = $db->db_join() ;
+ $status = $cursor->c_get() ;
+ $status = $cursor->c_close() ;
+
+ $status = $env->txn_checkpoint()
+ $hash_ref = $env->txn_stat()
+ $status = $env->setmutexlocks()
+ $status = $env->set_flags()
+ $status = $env->set_timeout()
+ $status = $env->lsn_reset()
+
+ $txn = $env->txn_begin() ;
+ $db->Txn($txn);
+ $txn->Txn($db1, $db2,...);
+ $status = $txn->txn_prepare()
+ $status = $txn->txn_commit()
+ $status = $txn->txn_abort()
+ $status = $txn->txn_id()
+ $status = $txn->txn_discard()
+ $status = $txn->set_timeout()
+
+ $status = $env->set_lg_dir();
+ $status = $env->set_lg_bsize();
+ $status = $env->set_lg_max();
+
+ $status = $env->set_data_dir() ;
+ $status = $env->set_tmp_dir() ;
+ $status = $env->set_verbose() ;
+ $db_env_ptr = $env->DB_ENV() ;
+
+ $BerkeleyDB::Error
+ $BerkeleyDB::db_version
+
+ # DBM Filters
+ $old_filter = $db->filter_store_key ( sub { ... } ) ;
+ $old_filter = $db->filter_store_value( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_key ( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
+ # deprecated, but supported
+ $txn_mgr = $env->TxnMgr();
+ $status = $txn_mgr->txn_checkpoint()
+ $hash_ref = $txn_mgr->txn_stat()
+ $txn = $txn_mgr->txn_begin() ;
+
+=head1 DESCRIPTION
+
+B<NOTE: This document is still under construction. Expect it to be
+incomplete in places.>
+
+This Perl module provides an interface to most of the functionality
+available in Berkeley DB versions 2, 3 and 4. In general it is safe to assume
+that the interface provided here to be identical to the Berkeley DB
+interface. The main changes have been to make the Berkeley DB API work
+in a Perl way. Note that if you are using Berkeley DB 2.x, the new
+features available in Berkeley DB 3.x or DB 4.x are not available via
+this module.
+
+The reader is expected to be familiar with the Berkeley DB
+documentation. Where the interface provided here is identical to the
+Berkeley DB library and the... TODO
+
+The B<db_appinit>, B<db_cursor>, B<db_open> and B<db_txn> man pages are
+particularly relevant.
+
+The interface to Berkeley DB is implemented with a number of Perl
+classes.
+
+=head1 The BerkeleyDB::Env Class
+
+The B<BerkeleyDB::Env> class provides an interface to the Berkeley DB
+function B<db_appinit> in Berkeley DB 2.x or B<db_env_create> and
+B<DBENV-E<gt>open> in Berkeley DB 3.x/4.x. Its purpose is to initialise a
+number of sub-systems that can then be used in a consistent way in all
+the databases you make use of in the environment.
+
+If you don't intend using transactions, locking or logging, then you
+shouldn't need to make use of B<BerkeleyDB::Env>.
+
+Note that an environment consists of a number of files that Berkeley DB
+manages behind the scenes for you. When you first use an environment, it
+needs to be explicitly created. This is done by including C<DB_CREATE>
+with the C<Flags> parameter, described below.
+
+=head2 Synopsis
+
+ $env = new BerkeleyDB::Env
+ [ -Home => $path, ]
+ [ -Server => $name, ]
+ [ -CacheSize => $number, ]
+ [ -Config => { name => value, name => value }, ]
+ [ -ErrFile => filename, ]
+ [ -MsgFile => filename, ]
+ [ -ErrPrefix => "string", ]
+ [ -Flags => number, ]
+ [ -SetFlags => bitmask, ]
+ [ -LockDetect => number, ]
+ [ -TxMax => number, ]
+ [ -LogConfig => number, ]
+ [ -MaxLockers => number, ]
+ [ -MaxLocks => number, ]
+ [ -MaxObjects => number, ]
+ [ -SharedMemKey => number, ]
+ [ -Verbose => boolean, ]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ]
+
+All the parameters to the BerkeleyDB::Env constructor are optional.
+
+=over 5
+
+=item -Home
+
+If present, this parameter should point to an existing directory. Any
+files that I<aren't> specified with an absolute path in the sub-systems
+that are initialised by the BerkeleyDB::Env class will be assumed to
+live in the B<Home> directory.
+
+For example, in the code fragment below the database "fred.db" will be
+opened in the directory "/home/databases" because it was specified as a
+relative path, but "joe.db" will be opened in "/other" because it was
+part of an absolute path.
+
+ $env = new BerkeleyDB::Env
+ -Home => "/home/databases"
+ ...
+
+ $db1 = new BerkeleyDB::Hash
+ -Filename => "fred.db",
+ -Env => $env
+ ...
+
+ $db2 = new BerkeleyDB::Hash
+ -Filename => "/other/joe.db",
+ -Env => $env
+ ...
+
+=item -Server
+
+If present, this parameter should be the hostname of a server that is running
+the Berkeley DB RPC server. All databases will be accessed via the RPC server.
+
+=item -Encrypt
+
+If present, this parameter will enable encryption of all data before
+it is written to the database. This parameters must be given a hash
+reference. The format is shown below.
+
+ -Encrypt => { -Password => "abc", Flags => DB_ENCRYPT_AES }
+
+Valid values for the Flags are 0 or C<DB_ENCRYPT_AES>.
+
+This option requires Berkeley DB 4.1 or better.
+
+=item -Cachesize
+
+If present, this parameter sets the size of the environments shared memory
+buffer pool.
+
+=item -TxMax
+
+If present, this parameter sets the number of simultaneous
+transactions that are allowed. Default 100. This default is
+definitely too low for programs using the MVCC capabilities.
+
+=item -LogConfig
+
+If present, this parameter is used to configure log options.
+
+=item -MaxLockers
+
+If present, this parameter is used to configure the maximum number of
+processes doing locking on the database. Default 1000.
+
+=item -MaxLocks
+
+If present, this parameter is used to configure the maximum number of
+locks on the database. Default 1000. This is often lower than required.
+
+=item -MaxObjects
+
+If present, this parameter is used to configure the maximum number of
+locked objects. Default 1000. This is often lower than required.
+
+=item -SharedMemKey
+
+If present, this parameter sets the base segment ID for the shared memory
+region used by Berkeley DB.
+
+This option requires Berkeley DB 3.1 or better.
+
+Use C<$env-E<gt>get_shm_key($id)> to find out the base segment ID used
+once the environment is open.
+
+=item -ThreadCount
+
+If present, this parameter declares the approximate number of threads that
+will be used in the database environment. This parameter is only necessary
+when the $env->failchk method will be used. It does not actually set the
+maximum number of threads but rather is used to determine memory sizing.
+
+This option requires Berkeley DB 4.4 or better. It is only supported on
+Unix/Linux.
+
+=item -Config
+
+This is a variation on the C<-Home> parameter, but it allows finer
+control of where specific types of files will be stored.
+
+The parameter expects a reference to a hash. Valid keys are:
+B<DB_DATA_DIR>, B<DB_LOG_DIR> and B<DB_TMP_DIR>
+
+The code below shows an example of how it can be used.
+
+ $env = new BerkeleyDB::Env
+ -Config => { DB_DATA_DIR => "/home/databases",
+ DB_LOG_DIR => "/home/logs",
+ DB_TMP_DIR => "/home/tmp"
+ }
+ ...
+
+=item -ErrFile
+
+Expects a filename or filenhandle. Any errors generated internally by
+Berkeley DB will be logged to this file. A useful debug setting is to
+open environments with either
+
+ -ErrFile => *STDOUT
+
+or
+
+ -ErrFile => *STDERR
+
+=item -ErrPrefix
+
+Allows a prefix to be added to the error messages before they are sent
+to B<-ErrFile>.
+
+=item -Flags
+
+The B<Flags> parameter specifies both which sub-systems to initialise,
+as well as a number of environment-wide options.
+See the Berkeley DB documentation for more details of these options.
+
+Any of the following can be specified by OR'ing them:
+
+B<DB_CREATE>
+
+If any of the files specified do not already exist, create them.
+
+B<DB_INIT_CDB>
+
+Initialise the Concurrent Access Methods
+
+B<DB_INIT_LOCK>
+
+Initialise the Locking sub-system.
+
+B<DB_INIT_LOG>
+
+Initialise the Logging sub-system.
+
+B<DB_INIT_MPOOL>
+
+Initialise the ...
+
+B<DB_INIT_TXN>
+
+Initialise the ...
+
+B<DB_MPOOL_PRIVATE>
+
+Initialise the ...
+
+B<DB_INIT_MPOOL> is also specified.
+
+Initialise the ...
+
+B<DB_NOMMAP>
+
+Initialise the ...
+
+B<DB_RECOVER>
+
+
+
+B<DB_RECOVER_FATAL>
+
+B<DB_THREAD>
+
+B<DB_TXN_NOSYNC>
+
+B<DB_USE_ENVIRON>
+
+B<DB_USE_ENVIRON_ROOT>
+
+=item -SetFlags
+
+Calls ENV->set_flags with the supplied bitmask. Use this when you need to make
+use of DB_ENV->set_flags before DB_ENV->open is called.
+
+Only valid when Berkeley DB 3.x or better is used.
+
+=item -LockDetect
+
+Specifies what to do when a lock conflict occurs. The value should be one of
+
+B<DB_LOCK_DEFAULT>
+
+B<DB_LOCK_OLDEST>
+
+B<DB_LOCK_RANDOM>
+
+B<DB_LOCK_YOUNGEST>
+
+=item -Verbose
+
+Add extra debugging information to the messages sent to B<-ErrFile>.
+
+=back
+
+=head2 Methods
+
+The environment class has the following methods:
+
+=over 5
+
+=item $env->errPrefix("string") ;
+
+This method is identical to the B<-ErrPrefix> flag. It allows the
+error prefix string to be changed dynamically.
+
+=item $env->set_flags(bitmask, 1|0);
+
+=item $txn = $env->TxnMgr()
+
+Constructor for creating a B<TxnMgr> object.
+See L<"TRANSACTIONS"> for more details of using transactions.
+
+This method is deprecated. Access the transaction methods using the B<txn_>
+methods below from the environment object directly.
+
+=item $env->txn_begin()
+
+TODO
+
+=item $env->txn_stat()
+
+TODO
+
+=item $env->txn_checkpoint()
+
+TODO
+
+=item $env->status()
+
+Returns the status of the last BerkeleyDB::Env method.
+
+
+=item $env->DB_ENV()
+
+Returns a pointer to the underlying DB_ENV data structure that Berkeley
+DB uses.
+
+=item $env->get_shm_key($id)
+
+Writes the base segment ID for the shared memory region used by the
+Berkeley DB environment into C<$id>. Returns 0 on success.
+
+This option requires Berkeley DB 4.2 or better.
+
+Use the C<-SharedMemKey> option when opening the environemt to set the
+base segment ID.
+
+=item $env->set_isalive()
+
+Set the callback that determines if the thread of control, identified by
+the pid and tid arguments, is still running. This method should only be
+used in combination with $env->failchk.
+
+This option requires Berkeley DB 4.4 or better.
+
+=item $env->failchk($flags)
+
+The $env->failchk method checks for threads of control (either a true
+thread or a process) that have exited while manipulating Berkeley DB
+library data structures, while holding a logical database lock, or with an
+unresolved transaction (that is, a transaction that was never aborted or
+committed).
+
+If $env->failchk determines a thread of control exited while holding
+database read locks, it will release those locks. If $env->failchk
+determines a thread of control exited with an unresolved transaction, the
+transaction will be aborted.
+
+Applications calling the $env->failchk method must have already called the
+$env->set_isalive method, on the same DB environement, and must have
+configured their database environment using the -ThreadCount flag. The
+ThreadCount flag cannot be used on an environment that wasn't previously
+initialized with it.
+
+This option requires Berkeley DB 4.4 or better.
+
+=item $env->stat_print
+
+Prints statistical information.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=item $env->lock_stat_print
+
+Prints locking subsystem statistics.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=item $env->mutex_stat_print
+
+Prints mutex subsystem statistics.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.4 or better.
+
+
+=item $env->set_timeout($timeout, $flags)
+
+=item $env->status()
+
+Returns the status of the last BerkeleyDB::Env method.
+
+=back
+
+=head2 Examples
+
+TODO.
+
+=head1 Global Classes
+
+ $status = BerkeleyDB::db_remove [OPTIONS]
+ $status = BerkeleyDB::db_rename [OPTIONS]
+ $status = BerkeleyDB::db_verify [OPTIONS]
+
+=head1 THE DATABASE CLASSES
+
+B<BerkeleyDB> supports the following database formats:
+
+=over 5
+
+=item B<BerkeleyDB::Hash>
+
+This database type allows arbitrary key/value pairs to be stored in data
+files. This is equivalent to the functionality provided by other
+hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
+the files created using B<BerkeleyDB::Hash> are not compatible with any
+of the other packages mentioned.
+
+A default hashing algorithm, which will be adequate for most applications,
+is built into BerkeleyDB. If you do need to use your own hashing algorithm
+it is possible to write your own in Perl and have B<BerkeleyDB> use
+it instead.
+
+=item B<BerkeleyDB::Btree>
+
+The Btree format allows arbitrary key/value pairs to be stored in a
+B+tree.
+
+As with the B<BerkeleyDB::Hash> format, it is possible to provide a
+user defined Perl routine to perform the comparison of keys. By default,
+though, the keys are stored in lexical order.
+
+=item B<BerkeleyDB::Recno>
+
+TODO.
+
+
+=item B<BerkeleyDB::Queue>
+
+TODO.
+
+=item B<BerkeleyDB::Unknown>
+
+This isn't a database format at all. It is used when you want to open an
+existing Berkeley DB database without having to know what type is it.
+
+=back
+
+
+Each of the database formats described above is accessed via a
+corresponding B<BerkeleyDB> class. These will be described in turn in
+the next sections.
+
+=head1 BerkeleyDB::Hash
+
+Equivalent to calling B<db_open> with type B<DB_HASH> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_HASH> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Hash
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Hash specific
+ [ -Ffactor => number,]
+ [ -Nelem => number,]
+ [ -Hash => code reference,]
+ [ -DupCompare => code reference,]
+
+and this
+
+ [$db =] tie %hash, 'BerkeleyDB::Hash',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Hash specific
+ [ -Ffactor => number,]
+ [ -Nelem => number,]
+ [ -Hash => code reference,]
+ [ -DupCompare => code reference,]
+
+
+When the "tie" interface is used, reading from and writing to the database
+is achieved via the tied hash. In this case the database operates like
+a Perl associative array that happens to be stored on disk.
+
+In addition to the high-level tied hash interface, it is possible to
+make use of the underlying methods provided by Berkeley DB
+
+=head2 Options
+
+In addition to the standard set of options (see L<COMMON OPTIONS>)
+B<BerkeleyDB::Hash> supports these options:
+
+=over 5
+
+=item -Property
+
+Used to specify extra flags when opening a database. The following
+flags may be specified by bitwise OR'ing together one or more of the
+following values:
+
+B<DB_DUP>
+
+When creating a new database, this flag enables the storing of duplicate
+keys in the database. If B<DB_DUPSORT> is not specified as well, the
+duplicates are stored in the order they are created in the database.
+
+B<DB_DUPSORT>
+
+Enables the sorting of duplicate keys in the database. Ignored if
+B<DB_DUP> isn't also specified.
+
+=item -Ffactor
+
+=item -Nelem
+
+See the Berkeley DB documentation for details of these options.
+
+=item -Hash
+
+Allows you to provide a user defined hash function. If not specified,
+a default hash function is used. Here is a template for a user-defined
+hash function
+
+ sub hash
+ {
+ my ($data) = shift ;
+ ...
+ # return the hash value for $data
+ return $hash ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Hash => \&hash,
+ ...
+
+See L<""> for an example.
+
+=item -DupCompare
+
+Used in conjunction with the B<DB_DUPOSRT> flag.
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Property => DB_DUP|DB_DUPSORT,
+ -DupCompare => \&compare,
+ ...
+
+=back
+
+
+=head2 Methods
+
+B<BerkeleyDB::Hash> only supports the standard database methods.
+See L<COMMON DATABASE METHODS>.
+
+=head2 A Simple Tied Hash Example
+
+ use strict ;
+ use BerkeleyDB ;
+ use vars qw( %h $k $v ) ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+here is the output:
+
+ Banana Exists
+
+ orange -> orange
+ tomato -> red
+ banana -> yellow
+
+Note that the like ordinary associative arrays, the order of the keys
+retrieved from a Hash database are in an apparently random order.
+
+=head2 Another Simple Hash Example
+
+Do the same as the previous example but not using tie.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("apple", "red") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("banana", "yellow") ;
+ $db->db_put("tomato", "red") ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
+
+ # Delete a key/value pair.
+ $db->db_del("apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+
+=head2 Duplicate keys
+
+The code below is a variation on the examples above. This time the hash has
+been inverted. The key this time is colour and the value is the fruit name.
+The B<DB_DUP> flag has been specified to allow duplicates.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+
+here is the output:
+
+ orange -> orange
+ yellow -> banana
+ red -> apple
+ red -> tomato
+ green -> banana
+ green -> apple
+
+=head2 Sorting Duplicate Keys
+
+In the previous example, when there were duplicate keys, the values are
+sorted in the order they are stored in. The code below is
+identical to the previous example except the B<DB_DUPSORT> flag is
+specified.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP | DB_DUPSORT
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+
+Notice that in the output below the duplicate values are sorted.
+
+ orange -> orange
+ yellow -> banana
+ red -> apple
+ red -> tomato
+ green -> apple
+ green -> banana
+
+=head2 Custom Sorting Duplicate Keys
+
+Another variation
+
+TODO
+
+=head2 Changing the hash
+
+TODO
+
+=head2 Using db_stat
+
+TODO
+
+=head1 BerkeleyDB::Btree
+
+Equivalent to calling B<db_open> with type B<DB_BTREE> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_BTREE> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+
+ $db = new BerkeleyDB::Btree
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Btree specific
+ [ -Minkey => number,]
+ [ -Compare => code reference,]
+ [ -DupCompare => code reference,]
+ [ -Prefix => code reference,]
+
+and this
+
+ [$db =] tie %hash, 'BerkeleyDB::Btree',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Btree specific
+ [ -Minkey => number,]
+ [ -Compare => code reference,]
+ [ -DupCompare => code reference,]
+ [ -Prefix => code reference,]
+
+=head2 Options
+
+In addition to the standard set of options (see L<COMMON OPTIONS>)
+B<BerkeleyDB::Btree> supports these options:
+
+=over 5
+
+=item -Property
+
+Used to specify extra flags when opening a database. The following
+flags may be specified by bitwise OR'ing together one or more of the
+following values:
+
+B<DB_DUP>
+
+When creating a new database, this flag enables the storing of duplicate
+keys in the database. If B<DB_DUPSORT> is not specified as well, the
+duplicates are stored in the order they are created in the database.
+
+B<DB_DUPSORT>
+
+Enables the sorting of duplicate keys in the database. Ignored if
+B<DB_DUP> isn't also specified.
+
+=item Minkey
+
+TODO
+
+=item Compare
+
+Allow you to override the default sort order used in the database. See
+L<"Changing the sort order"> for an example.
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Compare => \&compare,
+ ...
+
+=item Prefix
+
+ sub prefix
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return number of bytes of $key2 which are
+ # necessary to determine that it is greater than $key1
+ return $bytes ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Prefix => \&prefix,
+ ...
+=item DupCompare
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -DupCompare => \&compare,
+ ...
+
+=item set_bt_compress
+
+Enabled compression of the btree data. The callback interface is not
+supported at present. Need Berkeley DB 4.8 or better.
+
+=back
+
+=head2 Methods
+
+B<BerkeleyDB::Btree> supports the following database methods.
+See also L<COMMON DATABASE METHODS>.
+
+All the methods below return 0 to indicate success.
+
+=over 5
+
+=item $status = $db->db_key_range($key, $less, $equal, $greater [, $flags])
+
+Given a key, C<$key>, this method returns the proportion of keys less than
+C<$key> in C<$less>, the proportion equal to C<$key> in C<$equal> and the
+proportion greater than C<$key> in C<$greater>.
+
+The proportion is returned as a double in the range 0.0 to 1.0.
+
+=back
+
+=head2 A Simple Btree Example
+
+The code below is a simple example of using a btree database.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+Here is the output from the code above. The keys have been sorted using
+Berkeley DB's default sorting algorithm.
+
+ Smith
+ Wall
+ mouse
+
+
+=head2 Changing the sort order
+
+It is possible to supply your own sorting algorithm if the one that Berkeley
+DB used isn't suitable. The code below is identical to the previous example
+except for the case insensitive compare function.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Compare => sub { lc $_[0] cmp lc $_[1] }
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+Here is the output from the code above.
+
+ mouse
+ Smith
+ Wall
+
+There are a few point to bear in mind if you want to change the
+ordering in a BTREE database:
+
+=over 5
+
+=item 1.
+
+The new compare function must be specified when you create the database.
+
+=item 2.
+
+You cannot change the ordering once the database has been created. Thus
+you must use the same compare function every time you access the
+database.
+
+=back
+
+=head2 Using db_stat
+
+TODO
+
+=head1 BerkeleyDB::Recno
+
+Equivalent to calling B<db_open> with type B<DB_RECNO> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_RECNO> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Recno
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Recno specific
+ [ -Delim => byte,]
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -Source => filename,]
+
+and this
+
+ [$db =] tie @arry, 'BerkeleyDB::Recno',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Recno specific
+ [ -Delim => byte,]
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -Source => filename,]
+
+=head2 A Recno Example
+
+Here is a simple example that uses RECNO (if you are using a version
+of Perl earlier than 5.004_57 this example won't work -- see
+L<Extra RECNO Methods> for a workaround).
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ untie @h ;
+
+Here is the output from the script:
+
+ The array contains 5 entries
+ popped black
+ shifted white
+ Element 1 Exists with value blue
+ The last element is green
+ The 2nd last element is yellow
+
+=head1 BerkeleyDB::Queue
+
+Equivalent to calling B<db_create> followed by B<DB-E<gt>open> with
+type B<DB_QUEUE> in Berkeley DB 3.x or greater. This database format
+isn't available if you use Berkeley DB 2.x.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Queue
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Queue specific
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -ExtentSize => number, ]
+
+and this
+
+ [$db =] tie @arry, 'BerkeleyDB::Queue',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Queue specific
+ [ -Len => number,]
+ [ -Pad => byte,]
+
+
+=head1 BerkeleyDB::Unknown
+
+This class is used to open an existing database.
+
+Equivalent to calling B<db_open> with type B<DB_UNKNOWN> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_UNKNOWN> in
+Berkeley DB 3.x or greater.
+
+The constructor looks like this:
+
+ $db = new BerkeleyDB::Unknown
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+
+
+=head2 An example
+
+=head1 COMMON OPTIONS
+
+All database access class constructors support the common set of
+options defined below. All are optional.
+
+=over 5
+
+=item -Filename
+
+The database filename. If no filename is specified, a temporary file will
+be created and removed once the program terminates.
+
+=item -Subname
+
+Specifies the name of the sub-database to open.
+This option is only valid if you are using Berkeley DB 3.x or greater.
+
+=item -Flags
+
+Specify how the database will be opened/created. The valid flags are:
+
+B<DB_CREATE>
+
+Create any underlying files, as necessary. If the files do not already
+exist and the B<DB_CREATE> flag is not specified, the call will fail.
+
+B<DB_NOMMAP>
+
+Not supported by BerkeleyDB.
+
+B<DB_RDONLY>
+
+Opens the database in read-only mode.
+
+B<DB_THREAD>
+
+Not supported by BerkeleyDB.
+
+B<DB_TRUNCATE>
+
+If the database file already exists, remove all the data before
+opening it.
+
+=item -Mode
+
+Determines the file protection when the database is created. Defaults
+to 0666.
+
+=item -Cachesize
+
+=item -Lorder
+
+=item -Pagesize
+
+=item -Env
+
+When working under a Berkeley DB environment, this parameter
+
+Defaults to no environment.
+
+=item -Encrypt
+
+If present, this parameter will enable encryption of all data before
+it is written to the database. This parameters must be given a hash
+reference. The format is shown below.
+
+ -Encrypt => { -Password => "abc", Flags => DB_ENCRYPT_AES }
+
+Valid values for the Flags are 0 or C<DB_ENCRYPT_AES>.
+
+This option requires Berkeley DB 4.1 or better.
+
+=item -Txn
+
+TODO.
+
+=back
+
+=head1 COMMON DATABASE METHODS
+
+All the database interfaces support the common set of methods defined
+below.
+
+All the methods below return 0 to indicate success.
+
+=head2 $status = $db->db_get($key, $value [, $flags])
+
+Given a key (C<$key>) this method reads the value associated with it
+from the database. If it exists, the value read from the database is
+returned in the C<$value> parameter.
+
+The B<$flags> parameter is optional. If present, it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_GET_BOTH>
+
+When the B<DB_GET_BOTH> flag is specified, B<db_get> checks for the
+existence of B<both> the C<$key> B<and> C<$value> in the database.
+
+=item B<DB_SET_RECNO>
+
+TODO.
+
+=back
+
+In addition, the following value may be set by bitwise OR'ing it into
+the B<$flags> parameter:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO
+
+=back
+
+The variant C<db_pget> allows you to query a secondary database:
+
+ $status = $sdb->db_pget($skey, $pkey, $value);
+
+using the key C<$skey> in the secondary db to lookup C<$pkey> and C<$value>
+from the primary db.
+
+
+=head2 $status = $db->db_put($key, $value [, $flags])
+
+Stores a key/value pair in the database.
+
+The B<$flags> parameter is optional. If present it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_APPEND>
+
+This flag is only applicable when accessing a B<BerkeleyDB::Recno>
+database.
+
+TODO.
+
+
+=item B<DB_NOOVERWRITE>
+
+If this flag is specified and C<$key> already exists in the database,
+the call to B<db_put> will return B<DB_KEYEXIST>.
+
+=back
+
+=head2 $status = $db->db_del($key [, $flags])
+
+Deletes a key/value pair in the database associated with C<$key>.
+If duplicate keys are enabled in the database, B<db_del> will delete
+B<all> key/value pairs with key C<$key>.
+
+The B<$flags> parameter is optional and is currently unused.
+
+=head2 $status = $env->stat_print([$flags])
+
+Prints statistical information.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=head2 $status = $db->db_sync()
+
+If any parts of the database are in memory, write them to the database.
+
+=head2 $cursor = $db->db_cursor([$flags])
+
+Creates a cursor object. This is used to access the contents of the
+database sequentially. See L<CURSORS> for details of the methods
+available when working with cursors.
+
+The B<$flags> parameter is optional. If present it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO.
+
+=back
+
+=head2 ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
+
+TODO
+
+=head2 ($flag, $old_offset, $old_length) = $db->partial_clear() ;
+
+TODO
+
+=head2 $db->byteswapped()
+
+TODO
+
+=head2 $db->type()
+
+Returns the type of the database. The possible return code are B<DB_HASH>
+for a B<BerkeleyDB::Hash> database, B<DB_BTREE> for a B<BerkeleyDB::Btree>
+database and B<DB_RECNO> for a B<BerkeleyDB::Recno> database. This method
+is typically used when a database has been opened with
+B<BerkeleyDB::Unknown>.
+
+=head2 $bool = $env->cds_enabled();
+
+Returns true if the Berkeley DB environment C<$env> has been opened on
+CDS mode.
+
+=head2 $bool = $db->cds_enabled();
+
+Returns true if the database C<$db> has been opened on CDS mode.
+
+=head2 $lock = $db->cds_lock();
+
+Creates a CDS write lock object C<$lock>.
+
+It is a fatal error to attempt to create a cds_lock if the Berkeley DB
+environment has not been opened in CDS mode.
+
+=head2 $lock->cds_unlock();
+
+Removes a CDS lock. The destruction of the CDS lock object automatically
+calls this method.
+
+Note that if multiple CDS lock objects are created, the underlying write
+lock will not be released until all CDS lock objects are either explictly
+unlocked with this method, or the CDS lock objects have been destroyed.
+
+=head2 $ref = $db->db_stat()
+
+Returns a reference to an associative array containing information about
+the database. The keys of the associative array correspond directly to the
+names of the fields defined in the Berkeley DB documentation. For example,
+in the DB documentation, the field B<bt_version> stores the version of the
+Btree database. Assuming you called B<db_stat> on a Btree database the
+equivalent field would be accessed as follows:
+
+ $version = $ref->{'bt_version'} ;
+
+If you are using Berkeley DB 3.x or better, this method will work will
+all database formats. When DB 2.x is used, it only works with
+B<BerkeleyDB::Btree>.
+
+=head2 $status = $db->status()
+
+Returns the status of the last C<$db> method called.
+
+=head2 $status = $db->truncate($count)
+
+Truncates the datatabase and returns the number or records deleted
+in C<$count>.
+
+=head2 $status = $db->compact($start, $stop, $c_data, $flags, $end);
+
+Compacts the database C<$db>.
+
+All the parameters are optional - if only want to make use of some of them,
+use C<undef> for those you don't want. Trailing unusused parameters can be
+omitted. For example, if you only want to use the C<$c_data> parameter to
+set the C<compact_fillpercent>, write you code like this
+
+ my %hash;
+ $hash{compact_fillpercent} = 50;
+ $db->compact(undef, undef, \%hash);
+
+The parameters operate identically to the C equivalent of this method.
+The C<$c_data> needs a bit of explanation - it must be a hash reference.
+The values of the following keys can be set before calling C<compact> and
+will affect the operation of the compaction.
+
+=over 5
+
+=item * compact_fillpercent
+
+=item * compact_timeout
+
+=back
+
+The following keys, along with associated values, will be created in the
+hash reference if the C<compact> operation was successful.
+
+=over 5
+
+=item * compact_deadlock
+
+=item * compact_levels
+
+=item * compact_pages_free
+
+=item * compact_pages_examine
+
+=item * compact_pages_truncated
+
+=back
+
+You need to be running Berkeley DB 4.4 or better if you want to make use of
+C<compact>.
+
+=head2 $status = $db->associate($secondary, \&key_callback)
+
+Associate C<$db> with the secondary DB C<$secondary>
+
+New key/value pairs inserted to the database will be passed to the callback
+which must set its third argument to the secondary key to allow lookup. If
+an array reference is set multiple keys secondary keys will be associated
+with the primary database entry.
+
+Data may be retrieved fro the secondary database using C<db_pget> to also
+obtain the primary key.
+
+Secondary databased are maintained automatically.
+
+=head2 $status = $db->associate_foreign($secondary, callback, $flags)
+
+Associate a foreign key database C<$db> with the secondary DB
+C<$secondary>.
+
+The second parameter must be a reference to a sub or C<undef>.
+
+The C<$flags> parameter must be either C<DB_FOREIGN_CASCADE>,
+C<DB_FOREIGN_ABORT> or C<DB_FOREIGN_NULLIFY>.
+
+When the flags parameter is C<DB_FOREIGN_NULLIFY> the second parameter is a
+reference to a sub of the form
+
+ sub foreign_cb
+ {
+ my $key = \$_[0];
+ my $value = \$_[1];
+ my $foreignkey = \$_[2];
+ my $changed = \$_[3] ;
+
+ # for ... set $$value and set $$changed to 1
+
+ return 0;
+ }
+
+ $foreign_db->associate_foreign($secondary, \&foreign_cb, DB_FOREIGN_NULLIFY);
+
+=head1 CURSORS
+
+A cursor is used whenever you want to access the contents of a database
+in sequential order.
+A cursor object is created with the C<db_cursor>
+
+A cursor object has the following methods available:
+
+=head2 $newcursor = $cursor->c_dup($flags)
+
+Creates a duplicate of C<$cursor>. This method needs Berkeley DB 3.0.x or better.
+
+The C<$flags> parameter is optional and can take the following value:
+
+=over 5
+
+=item DB_POSITION
+
+When present this flag will position the new cursor at the same place as the
+existing cursor.
+
+=back
+
+=head2 $status = $cursor->c_get($key, $value, $flags)
+
+Reads a key/value pair from the database, returning the data in C<$key>
+and C<$value>. The key/value pair actually read is controlled by the
+C<$flags> parameter, which can take B<one> of the following values:
+
+=over 5
+
+=item B<DB_FIRST>
+
+Set the cursor to point to the first key/value pair in the
+database. Return the key/value pair in C<$key> and C<$value>.
+
+=item B<DB_LAST>
+
+Set the cursor to point to the last key/value pair in the database. Return
+the key/value pair in C<$key> and C<$value>.
+
+=item B<DB_NEXT>
+
+If the cursor is already pointing to a key/value pair, it will be
+incremented to point to the next key/value pair and return its contents.
+
+If the cursor isn't initialised, B<DB_NEXT> works just like B<DB_FIRST>.
+
+If the cursor is already positioned at the last key/value pair, B<c_get>
+will return B<DB_NOTFOUND>.
+
+=item B<DB_NEXT_DUP>
+
+This flag is only valid when duplicate keys have been enabled in
+a database.
+If the cursor is already pointing to a key/value pair and the key of
+the next key/value pair is identical, the cursor will be incremented to
+point to it and their contents returned.
+
+=item B<DB_PREV>
+
+If the cursor is already pointing to a key/value pair, it will be
+decremented to point to the previous key/value pair and return its
+contents.
+
+If the cursor isn't initialised, B<DB_PREV> works just like B<DB_LAST>.
+
+If the cursor is already positioned at the first key/value pair, B<c_get>
+will return B<DB_NOTFOUND>.
+
+=item B<DB_CURRENT>
+
+If the cursor has been set to point to a key/value pair, return their
+contents.
+If the key/value pair referenced by the cursor has been deleted, B<c_get>
+will return B<DB_KEYEMPTY>.
+
+=item B<DB_SET>
+
+Set the cursor to point to the key/value pair referenced by B<$key>
+and return the value in B<$value>.
+
+=item B<DB_SET_RANGE>
+
+This flag is a variation on the B<DB_SET> flag. As well as returning
+the value, it also returns the key, via B<$key>.
+When used with a B<BerkeleyDB::Btree> database the key matched by B<c_get>
+will be the shortest key (in length) which is greater than or equal to
+the key supplied, via B<$key>. This allows partial key searches.
+See ??? for an example of how to use this flag.
+
+=item B<DB_GET_BOTH>
+
+Another variation on B<DB_SET>. This one returns both the key and
+the value.
+
+=item B<DB_SET_RECNO>
+
+TODO.
+
+=item B<DB_GET_RECNO>
+
+TODO.
+
+=back
+
+In addition, the following value may be set by bitwise OR'ing it into
+the B<$flags> parameter:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO.
+
+=back
+
+=head2 $status = $cursor->c_put($key, $value, $flags)
+
+Stores the key/value pair in the database. The position that the data is
+stored in the database is controlled by the C<$flags> parameter, which
+must take B<one> of the following values:
+
+=over 5
+
+=item B<DB_AFTER>
+
+When used with a Btree or Hash database, a duplicate of the key referenced
+by the current cursor position will be created and the contents of
+B<$value> will be associated with it - B<$key> is ignored.
+The new key/value pair will be stored immediately after the current
+cursor position.
+Obviously the database has to have been opened with B<DB_DUP>.
+
+When used with a Recno ... TODO
+
+
+=item B<DB_BEFORE>
+
+When used with a Btree or Hash database, a duplicate of the key referenced
+by the current cursor position will be created and the contents of
+B<$value> will be associated with it - B<$key> is ignored.
+The new key/value pair will be stored immediately before the current
+cursor position.
+Obviously the database has to have been opened with B<DB_DUP>.
+
+When used with a Recno ... TODO
+
+=item B<DB_CURRENT>
+
+If the cursor has been initialised, replace the value of the key/value
+pair stored in the database with the contents of B<$value>.
+
+=item B<DB_KEYFIRST>
+
+Only valid with a Btree or Hash database. This flag is only really
+used when duplicates are enabled in the database and sorted duplicates
+haven't been specified.
+In this case the key/value pair will be inserted as the first entry in
+the duplicates for the particular key.
+
+=item B<DB_KEYLAST>
+
+Only valid with a Btree or Hash database. This flag is only really
+used when duplicates are enabled in the database and sorted duplicates
+haven't been specified.
+In this case the key/value pair will be inserted as the last entry in
+the duplicates for the particular key.
+
+=back
+
+=head2 $status = $cursor->c_del([$flags])
+
+This method deletes the key/value pair associated with the current cursor
+position. The cursor position will not be changed by this operation, so
+any subsequent cursor operation must first initialise the cursor to
+point to a valid key/value pair.
+
+If the key/value pair associated with the cursor have already been
+deleted, B<c_del> will return B<DB_KEYEMPTY>.
+
+The B<$flags> parameter is not used at present.
+
+=head2 $status = $cursor->c_count($cnt [, $flags])
+
+Stores the number of duplicates at the current cursor position in B<$cnt>.
+
+The B<$flags> parameter is not used at present. This method needs
+Berkeley DB 3.1 or better.
+
+=head2 $status = $cursor->status()
+
+Returns the status of the last cursor method as a dual type.
+
+=head2 $status = $cursor->c_pget() ;
+
+See C<db_pget>
+
+=head2 $status = $cursor->c_close()
+
+Closes the cursor B<$cursor>.
+
+=head2 Cursor Examples
+
+TODO
+
+Iterating from first to last, then in reverse.
+
+examples of each of the flags.
+
+=head1 JOIN
+
+Join support for BerkeleyDB is in progress. Watch this space.
+
+TODO
+
+=head1 TRANSACTIONS
+
+Transactions are created using the C<txn_begin> method on L<BerkeleyDB::Env>:
+
+ my $txn = $env->txn_begin;
+
+If this is a nested transaction, supply the parent transaction as an
+argument:
+
+ my $child_txn = $env->txn_begin($parent_txn);
+
+Then in order to work with the transaction, you must set it as the current
+transaction on the database handles you want to work with:
+
+ $db->Txn($txn);
+
+Or for multiple handles:
+
+ $txn->Txn(@handles);
+
+The current transaction is given by BerkeleyDB each time to the various BDB
+operations. In the C api it is required explicitly as an argument to every
+operation.
+
+To commit a transaction call the C<commit> method on it:
+
+ $txn->commit;
+
+and to roll back call abort:
+
+ $txn->abort
+
+After committing or aborting a child transaction you need to set the active
+transaction again using C<Txn>.
+
+
+=head1 Berkeley DB Concurrent Data Store (CDS)
+
+The Berkeley DB I<Concurrent Data Store> (CDS) is a lightweight locking
+mechanism that is useful in scenarios where transactions are overkill.
+
+=head2 What is CDS?
+
+The Berkeley DB CDS interface is a simple lightweight locking mechanism
+that allows safe concurrent access to Berkeley DB databases. Your
+application can have multiple reader and write processes, but Berkeley DB
+will arrange it so that only one process can have a write lock against the
+database at a time, i.e. multiple processes can read from a database
+concurrently, but all write processes will be serialised.
+
+=head2 Should I use it?
+
+Whilst this simple locking model is perfectly adequate for some
+applications, it will be too restrictive for others. Before deciding on
+using CDS mode, you need to be sure that it is suitable for the expected
+behaviour of your application.
+
+The key features of this model are
+
+=over 5
+
+=item *
+
+All writes operations are serialised.
+
+=item *
+
+A write operation will block until all reads have finished.
+
+=back
+
+There are a few of the attributes of your application that you need to be
+aware of before choosing to use CDS.
+
+Firstly, if you application needs either recoverability or transaction
+support, then CDS will not be suitable.
+
+Next what is the ratio of read operation to write operations will your
+application have?
+
+If it is carrying out mostly read operations, and very few writes, then CDS
+may be appropriate.
+
+What is the expected throughput of reads/writes in your application?
+
+If you application does 90% writes and 10% reads, but on average you only
+have a transaction every 5 seconds, then the fact that all writes are
+serialised will not matter, because there will hardly ever be multiple
+writes processes blocking.
+
+In summary CDS mode may be appropriate for your application if it performs
+mostly reads and very few writes or there is a low throughput. Also, if
+you do not need to be able to roll back a series of database operations if
+an error occurs, then CDS is ok.
+
+If any of these is not the case you will need to use Berkeley DB
+transactions. That is outside the scope of this document.
+
+=head2 Locking Used
+
+Berkeley DB implements CDS mode using two kinds of lock behind the scenes -
+namely read locks and write locks. A read lock allows multiple processes to
+access the database for reading at the same time. A write lock will only
+get access to the database when there are no read or write locks active.
+The write lock will block until the process holding the lock releases it.
+
+Multiple processes with read locks can all access the database at the same
+time as long as no process has a write lock. A process with a write lock
+can only access the database if there are no other active read or write
+locks.
+
+The majority of the time the Berkeley DB CDS mode will handle all locking
+without your application having to do anything. There are a couple of
+exceptions you need to be aware of though - these will be discussed in
+L<Safely Updating Records> and L<Implicit Cursors> below.
+
+A Berkeley DB Cursor (created with C<< $db->db_cursor >>) will by hold a
+lock on the database until it is either explicitly closed or destroyed.
+This means the lock has the potential to be long lived.
+
+By default Berkeley DB cursors create a read lock, but it is possible to
+create a cursor that holds a write lock, thus
+
+ $cursor = $db->db_cursor(DB_WRITECURSOR);
+
+
+Whilst either a read or write cursor is active, it will block any other
+processes that wants to write to the database.
+
+To avoid blocking problems, only keep cursors open as long as they are
+needed. The same is true when you use the C<cursor> method or the
+C<cds_lock> method.
+
+For full information on CDS see the "Berkeley DB Concurrent Data Store
+applications" section in the Berkeley DB Reference Guide.
+
+
+=head2 Opening a database for CDS
+
+Here is the typical signature that is used when opening a database in CDS
+mode.
+
+ use BerkeleyDB ;
+
+ my $env = new BerkeleyDB::Env
+ -Home => "./home" ,
+ -Flags => DB_CREATE| DB_INIT_CDB | DB_INIT_MPOOL
+ or die "cannot open environment: $BerkeleyDB::Error\n";
+
+ my $db = new BerkeleyDB::Hash
+ -Filename => 'test1.db',
+ -Flags => DB_CREATE,
+ -Env => $env
+ or die "cannot open database: $BerkeleyDB::Error\n";
+
+or this, if you use the tied interface
+
+ tie %hash, "BerkeleyDB::Hash",
+ -Filename => 'test2.db',
+ -Flags => DB_CREATE,
+ -Env => $env
+ or die "cannot open database: $BerkeleyDB::Error\n";
+
+The first thing to note is that you B<MUST> always use a Berkeley DB
+environment if you want to use locking with Berkeley DB.
+
+Remember, that apart from the actual database files you explicitly create
+yourself, Berkeley DB will create a few behind the scenes to handle locking
+- they usually have names like "__db.001". It is therefore a good idea to
+use the C<-Home> option, unless you are happy for all these files to be
+written in the current directory.
+
+Next, remember to include the C<DB_CREATE> flag when opening the
+environment for the first time. A common mistake is to forget to add this
+option and then wonder why the application doesn't work.
+
+Finally, it is vital that all processes that are going to access the
+database files use the same Berkeley DB environment.
+
+
+=head2 Safely Updating a Record
+
+One of the main gotchas when using CDS is if you want to update a record in
+a database, i.e. you want to retrieve a record from a database, modify it
+in some way and put it back in the database.
+
+For example, say you are writing a web application and you want to keep a
+record of the number of times your site is accessed in a Berkeley DB
+database. So your code will have a line of code like this (assume, of
+course, that C<%hash> has been tied to a Berkeley DB database):
+
+ $hash{Counter} ++ ;
+
+That may look innocent enough, but there is a race condition lurking in
+there. If I rewrite the line of code using the low-level Berkeley DB API,
+which is what will actually be executed, the race condition may be more
+apparent:
+
+ $db->db_get("Counter", $value);
+ ++ $value ;
+ $db->db_put("Counter", $value);
+
+Consider what happens behind the scenes when you execute the commands
+above. Firstly, the existing value for the key "Counter" is fetched from
+the database using C<db_get>. A read lock will be used for this part of the
+update. The value is then incremented, and the new value is written back
+to the database using C<db_put>. This time a write lock will be used.
+
+Here's the problem - there is nothing to stop two (or more) processes
+executing the read part at the same time. Remember multiple processes can
+hold a read lock on the database at the same time. So both will fetch the
+same value, let's say 7, from the database. Both increment the value to 8
+and attempt to write it to the database. Berkeley DB will ensure that only
+one of the processes gets a write lock, while the other will be blocked. So
+the process that happened to get the write lock will store the value 8 to
+the database and release the write lock. Now the other process will be
+unblocked, and it too will write the value 8 to the database. The result,
+in this example, is we have missed a hit in the counter.
+
+To deal with this kind of scenario, you need to make the update atomic. A
+convenience method, called C<cds_lock>, is supplied with the BerkeleyDB
+module for this purpose. Using C<cds_lock>, the counter update code can now
+be rewritten thus:
+
+ my $lk = $dbh->cds_lock() ;
+ $hash{Counter} ++ ;
+ $lk->cds_unlock;
+
+or this, where scoping is used to limit the lifetime of the lock object
+
+ {
+ my $lk = $dbh->cds_lock() ;
+ $hash{Counter} ++ ;
+ }
+
+Similarly, C<cds_lock> can be used with the native Berkeley DB API
+
+ my $lk = $dbh->cds_lock() ;
+ $db->db_get("Counter", $value);
+ ++ $value ;
+ $db->db_put("Counter", $value);
+ $lk->unlock;
+
+
+The C<cds_lock> method will ensure that the current process has exclusive
+access to the database until the lock is either explicitly released, via
+the C<< $lk->cds_unlock() >> or by the lock object being destroyed.
+
+If you are interested, all that C<cds_lock> does is open a "write" cursor.
+This has the useful side-effect of holding a write-lock on the database
+until the cursor is deleted. This is how you create a write-cursor
+
+ $cursor = $db->db_cursor(DB_WRITECURSOR);
+
+If you have instantiated multiple C<cds_lock> objects for one database
+within a single process, that process will hold a write-lock on the
+database until I<ALL> C<cds_lock> objects have been destroyed.
+
+As with all write-cursors, you should try to limit the scope of the
+C<cds_lock> to as short a time as possible. Remember the complete database
+will be locked to other process whilst the write lock is in place.
+
+=head2 Cannot write with a read cursor while a write cursor is active
+
+This issue is easier to demonstrate with an example, so consider the code
+below. The intention of the code is to increment the values of all the
+elements in a database by one.
+
+ # Assume $db is a database opened in a CDS environment.
+
+ # Create a write-lock
+ my $lock = $db->db_cursor(DB_WRITECURSOR);
+ # or
+ # my $lock = $db->cds_lock();
+
+
+ my $cursor = $db->db_cursor();
+
+ # Now loop through the database, and increment
+ # each value using c_put.
+ while ($cursor->c_get($key, $value, DB_NEXT) == 0)
+ {
+ $cursor->c_put($key, $value+1, DB_CURRENT) == 0
+ or die "$BerkeleyDB::Error\n";
+ }
+
+
+When this code is run, it will fail on the C<c_put> line with this error
+
+ Write attempted on read-only cursor
+
+The read cursor has automatically disallowed a write operation to prevent a
+deadlock.
+
+
+So the rule is -- you B<CANNOT> carry out a write operation using a
+read-only cursor (i.e. you cannot use C<c_put> or C<c_del>) whilst another
+write-cursor is already active.
+
+The workaround for this issue is to just use C<db_put> instead of C<c_put>,
+like this
+
+ # Assume $db is a database opened in a CDS environment.
+
+ # Create a write-lock
+ my $lock = $db->db_cursor(DB_WRITECURSOR);
+ # or
+ # my $lock = $db->cds_lock();
+
+
+ my $cursor = $db->db_cursor();
+
+ # Now loop through the database, and increment
+ # each value using c_put.
+ while ($cursor->c_get($key, $value, DB_NEXT) == 0)
+ {
+ $db->db_put($key, $value+1) == 0
+ or die "$BerkeleyDB::Error\n";
+ }
+
+
+
+=head2 Implicit Cursors
+
+All Berkeley DB cursors will hold either a read lock or a write lock on the
+database for the existence of the cursor. In order to prevent blocking of
+other processes you need to make sure that they are not long lived.
+
+There are a number of instances where the Perl interface to Berkeley DB
+will create a cursor behind the scenes without you being aware of it. Most
+of these are very short-lived and will not affect the running of your
+script, but there are a few notable exceptions.
+
+Consider this snippet of code
+
+ while (my ($k, $v) = each %hash)
+ {
+ # do something
+ }
+
+
+To implement the "each" functionality, a read cursor will be created behind
+the scenes to allow you to iterate through the tied hash, C<%hash>. While
+that cursor is still active, a read lock will obviously be held against the
+database. If your application has any other writing processes, these will
+be blocked until the read cursor is closed. That won't happen until the
+loop terminates.
+
+To avoid blocking problems, only keep cursors open as long as they are
+needed. The same is true when you use the C<cursor> method or the
+C<cds_lock> method.
+
+
+The locking behaviour of the C<values> or C<keys> functions, shown below,
+is subtly different.
+
+ foreach my $k (keys %hash)
+ {
+ # do something
+ }
+
+ foreach my $v (values %hash)
+ {
+ # do something
+ }
+
+
+Just as in the C<each> function, a read cursor will be created to iterate
+over the database in both of these cases. Where C<keys> and C<values>
+differ is the place where the cursor carries out the iteration through the
+database. Whilst C<each> carried out a single iteration every time it was
+invoked, the C<keys> and C<values> functions will iterate through the
+entire database in one go -- the complete database will be read into memory
+before the first iteration of the loop.
+
+Apart from the fact that a read lock will be held for the amount of time
+required to iterate through the database, the use of C<keys> and C<values>
+is B<not> recommended because it will result in the complete database being
+read into memory.
+
+
+=head2 Avoiding Deadlock with multiple databases
+
+If your CDS application uses multiple database files, and you need to write
+to more than one of them, you need to be careful you don't create a
+deadlock.
+
+For example, say you have two databases, D1 and D2, and two processes, P1
+and P2. Assume you want to write a record to each database. If P1 writes
+the records to the databases in the order D1, D2 while process P2 writes
+the records in the order D2, D1, there is the potential for a deadlock to
+occur.
+
+This scenario can be avoided by either always acquiring the write locks in
+exactly the same order in your application code, or by using the
+C<DB_CDB_ALLDB> flag when opening the environment. This flag will make a
+write-lock apply to all the databases in the environment.
+
+Add example here
+
+=head1 DBM Filters
+
+A DBM Filter is a piece of code that is be used when you I<always>
+want to make the same transformation to all keys and/or values in a DBM
+database. All of the database classes (BerkeleyDB::Hash,
+BerkeleyDB::Btree and BerkeleyDB::Recno) support DBM Filters.
+
+There are four methods associated with DBM Filters. All work
+identically, and each is used to install (or uninstall) a single DBM
+Filter. Each expects a single parameter, namely a reference to a sub.
+The only difference between them is the place that the filter is
+installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods, from none, to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+Consider the following scenario. You have a DBM database that you need
+to share with a third-party C application. The C application assumes
+that I<all> keys and values are NULL terminated. Unfortunately when
+Perl writes to DBM databases it doesn't use NULL termination, so your
+Perl application will have to manage NULL termination itself. When you
+write to the database you will have to use something like this:
+
+ $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+the database and have them removed when you read from the database. As I'm
+sure you have already guessed, this is a problem that DBM Filters can
+fix very easily.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+ my $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+ $hash{12345} = "something" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+ use strict ;
+ use BerkeleyDB ;
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
+=head1 Using BerkeleyDB with MLDBM
+
+Both BerkeleyDB::Hash and BerkeleyDB::Btree can be used with the MLDBM
+module. The code fragment below shows how to open associate MLDBM with
+BerkeleyDB::Btree. To use BerkeleyDB::Hash just replace
+BerkeleyDB::Btree with BerkeleyDB::Hash.
+
+ use strict ;
+ use BerkeleyDB ;
+ use MLDBM qw(BerkeleyDB::Btree) ;
+ use Data::Dumper;
+
+ my $filename = 'testmldbm' ;
+ my %o ;
+
+ unlink $filename ;
+ tie %o, 'MLDBM', -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open database '$filename: $!\n";
+
+See the MLDBM documentation for information on how to use the module
+and for details of its limitations.
+
+=head1 EXAMPLES
+
+TODO.
+
+=head1 HINTS & TIPS
+
+=head2 Sharing Databases With C Applications
+
+There is no technical reason why a Berkeley DB database cannot be
+shared by both a Perl and a C application.
+
+The vast majority of problems that are reported in this area boil down
+to the fact that C strings are NULL terminated, whilst Perl strings
+are not. See L<An Example -- the NULL termination problem.> in the DBM
+FILTERS section for a generic way to work around this problem.
+
+
+=head2 The untie Gotcha
+
+TODO
+
+=head1 COMMON QUESTIONS
+
+This section attempts to answer some of the more common questions that
+I get asked.
+
+
+=head2 Relationship with DB_File
+
+Before Berkeley DB 2.x was written there was only one Perl module that
+interfaced to Berkeley DB. That module is called B<DB_File>. Although
+B<DB_File> can be build with Berkeley DB 1.x, 2.x, 3.x or 4.x, it only
+provides an interface to the functionality available in Berkeley DB
+1.x. That means that it doesn't support transactions, locking or any of
+the other new features available in DB 2.x or better.
+
+=head2 How do I store Perl data structures with BerkeleyDB?
+
+See L<Using BerkeleyDB with MLDBM>.
+
+=head1 HISTORY
+
+See the Changes file.
+
+=head1 AVAILABILITY
+
+The most recent version of B<BerkeleyDB> can always be found
+on CPAN (see L<perlmod/CPAN> for details), in the directory
+F<modules/by-module/BerkeleyDB>.
+
+The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2004 Paul Marquess. All rights reserved. This program
+is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+Although B<BerkeleyDB> is covered by the Perl license, the library it
+makes use of, namely Berkeley DB, is not. Berkeley DB has its own
+copyright and its own license. Please take the time to read it.
+
+Here are few words taken from the Berkeley DB FAQ (at
+F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
+
+ Do I have to license DB to use it in Perl scripts?
+
+ No. The Berkeley DB license requires that software that uses
+ Berkeley DB be freely redistributable. In the case of Perl, that
+ software is Perl, and not your scripts. Any Perl scripts that you
+ write are your property, including scripts that make use of Berkeley
+ DB. Neither the Perl license nor the Berkeley DB license
+ place any restriction on what you may do with them.
+
+If you are in any doubt about the license situation, contact either the
+Berkeley DB authors or the author of BerkeleyDB.
+See L<"AUTHOR"> for details.
+
+
+=head1 AUTHOR
+
+Paul Marquess E<lt>pmqs@cpan.orgE<gt>.
+
+
+=head1 SEE ALSO
+
+perl(1), DB_File, Berkeley DB.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Bundle/DBD/Pg.pm b/Master/tlpkg/tlperl.straw/lib/Bundle/DBD/Pg.pm
new file mode 100755
index 00000000000..7f603cb1823
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Bundle/DBD/Pg.pm
@@ -0,0 +1,39 @@
+
+package Bundle::DBD::Pg;
+
+use strict;
+use warnings;
+
+$VERSION = '2.16.1';
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bundle::DBD::Pg - A bundle to install all DBD::Pg related modules
+
+=head1 SYNOPSIS
+
+C<perl -MCPAN -e 'install Bundle::DBD::Pg'>
+
+=head1 CONTENTS
+
+DBI
+
+DBD::Pg
+
+=head1 DESCRIPTION
+
+This bundle includes all the modules needed for DBD::Pg (the Perl
+interface to the Postgres database system). Please feel free to
+ask for help or report any problems to dbd-pg@perl.org.
+
+=cut
+
+=head1 AUTHOR
+
+Greg Sabino Mullane E<lt>F<greg@turnstep.com>E<gt>
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Bundle/DBD/mysql.pm b/Master/tlpkg/tlperl.straw/lib/Bundle/DBD/mysql.pm
new file mode 100755
index 00000000000..0934674949f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Bundle/DBD/mysql.pm
@@ -0,0 +1,30 @@
+# -*- perl -*-
+
+package Bundle::DBD::mysql;
+
+$VERSION = '4.004';
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bundle::DBD::mysql - A bundle to install Perl drivers for MySQL
+
+=head1 SYNOPSIS
+
+C<perl -MCPAN -e 'install Bundle::DBD::mysql'>
+
+=head1 CONTENTS
+
+DBI
+
+DBD::mysql
+
+=head1 DESCRIPTION
+
+This bundle includes all that is needed to connect with a MySQL server using
+DBI.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Bundle/DBI.pm b/Master/tlpkg/tlperl.straw/lib/Bundle/DBI.pm
new file mode 100755
index 00000000000..50375a361d1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Bundle/DBI.pm
@@ -0,0 +1,51 @@
+# -*- perl -*-
+
+package Bundle::DBI;
+
+our $VERSION = sprintf("12.%06d", q$Revision: 8695 $ =~ /(\d+)/o);
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bundle::DBI - A bundle to install DBI and required modules.
+
+=head1 SYNOPSIS
+
+ perl -MCPAN -e 'install Bundle::DBI'
+
+=head1 CONTENTS
+
+DBI - for to get to know thyself
+
+DBI::Shell 11.91 - the DBI command line shell
+
+Storable 2.06 - for DBD::Proxy, DBI::ProxyServer, DBD::Forward
+
+Net::Daemon 0.37 - for DBD::Proxy and DBI::ProxyServer
+
+RPC::PlServer 0.2016 - for DBD::Proxy and DBI::ProxyServer
+
+DBD::Multiplex 1.19 - treat multiple db handles as one
+
+=head1 DESCRIPTION
+
+This bundle includes all the modules used by the Perl Database
+Interface (DBI) module, created by Tim Bunce.
+
+A I<Bundle> is a module that simply defines a collection of other
+modules. It is used by the L<CPAN> module to automate the fetching,
+building and installing of modules from the CPAN ftp archive sites.
+
+This bundle does not deal with the various database drivers (e.g.
+DBD::Informix, DBD::Oracle etc), most of which require software from
+sources other than CPAN. You'll need to fetch and build those drivers
+yourself.
+
+=head1 AUTHORS
+
+Jonathan Leffler, Jochen Wiedmann and Tim Bunce.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Bundle/LWP.pm b/Master/tlpkg/tlperl.straw/lib/Bundle/LWP.pm
new file mode 100755
index 00000000000..0beb2d8a2ff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Bundle/LWP.pm
@@ -0,0 +1,43 @@
+package Bundle::LWP;
+
+$VERSION = "5.810";
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bundle::LWP - install all libwww-perl related modules
+
+=head1 SYNOPSIS
+
+ perl -MCPAN -e 'install Bundle::LWP'
+
+=head1 CONTENTS
+
+MIME::Base64 - Used in authentication headers
+
+Digest::MD5 - Needed to do Digest authentication
+
+URI 1.10 - There are URIs everywhere
+
+Net::FTP 2.58 - If you want ftp://-support
+
+HTML::Tagset - Needed by HTML::Parser
+
+HTML::Parser - Need by HTML::HeadParser
+
+HTML::HeadParser - To get the correct $res->base
+
+LWP - The reason why you need the modules above
+
+=head1 DESCRIPTION
+
+This bundle defines all prereq modules for libwww-perl. Bundles have
+special meaning for the CPAN module. When you install the bundle
+module all modules mentioned in L</CONTENTS> will be installed instead.
+
+=head1 SEE ALSO
+
+L<CPAN/Bundles>
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Apache.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Apache.pm
new file mode 100755
index 00000000000..e055e305551
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Apache.pm
@@ -0,0 +1,27 @@
+package CGI::Apache;
+use CGI;
+
+$VERSION = '1.01';
+
+1;
+__END__
+
+=head1 NAME
+
+CGI::Apache - Backward compatibility module for CGI.pm
+
+=head1 SYNOPSIS
+
+Do not use this module. It is deprecated.
+
+=head1 ABSTRACT
+
+=head1 DESCRIPTION
+
+=head1 AUTHOR INFORMATION
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Carp.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Carp.pm
new file mode 100755
index 00000000000..381635e87e0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Carp.pm
@@ -0,0 +1,606 @@
+package CGI::Carp;
+
+=head1 NAME
+
+B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
+
+=head1 SYNOPSIS
+
+ use CGI::Carp;
+
+ croak "We're outta here!";
+ confess "It was my fault: $!";
+ carp "It was your fault!";
+ warn "I'm confused";
+ die "I'm dying.\n";
+
+ use CGI::Carp qw(cluck);
+ cluck "I wouldn't do that if I were you";
+
+ use CGI::Carp qw(fatalsToBrowser);
+ die "Fatal error messages are now sent to browser";
+
+=head1 DESCRIPTION
+
+CGI scripts have a nasty habit of leaving warning messages in the error
+logs that are neither time stamped nor fully identified. Tracking down
+the script that caused the error is a pain. This fixes that. Replace
+the usual
+
+ use Carp;
+
+with
+
+ use CGI::Carp
+
+And the standard warn(), die (), croak(), confess() and carp() calls
+will automagically be replaced with functions that write out nicely
+time-stamped messages to the HTTP server error log.
+
+For example:
+
+ [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
+ [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
+ [Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
+
+=head1 REDIRECTING ERROR MESSAGES
+
+By default, error messages are sent to STDERR. Most HTTPD servers
+direct STDERR to the server's error log. Some applications may wish
+to keep private error logs, distinct from the server's error log, or
+they may wish to direct error messages to STDOUT so that the browser
+will receive them.
+
+The C<carpout()> function is provided for this purpose. Since
+carpout() is not exported by default, you must import it explicitly by
+saying
+
+ use CGI::Carp qw(carpout);
+
+The carpout() function requires one argument, which should be a
+reference to an open filehandle for writing errors. It should be
+called in a C<BEGIN> block at the top of the CGI application so that
+compiler errors will be caught. Example:
+
+ BEGIN {
+ use CGI::Carp qw(carpout);
+ open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
+ die("Unable to open mycgi-log: $!\n");
+ carpout(LOG);
+ }
+
+carpout() does not handle file locking on the log for you at this point.
+Also, note that carpout() does not work with in-memory file handles, although
+a patch would be welcome to address that.
+
+The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some
+servers, when dealing with CGI scripts, close their connection to the
+browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to
+prevent this from happening prematurely.
+
+You can pass filehandles to carpout() in a variety of ways. The "correct"
+way according to Tom Christiansen is to pass a reference to a filehandle
+GLOB:
+
+ carpout(\*LOG);
+
+This looks weird to mere mortals however, so the following syntaxes are
+accepted as well:
+
+ carpout(LOG);
+ carpout(main::LOG);
+ carpout(main'LOG);
+ carpout(\LOG);
+ carpout(\'main::LOG');
+
+ ... and so on
+
+FileHandle and other objects work as well.
+
+Use of carpout() is not great for performance, so it is recommended
+for debugging purposes or for moderate-use applications. A future
+version of this module may delay redirecting STDERR until one of the
+CGI::Carp methods is called to prevent the performance hit.
+
+=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
+
+If you want to send fatal (die, confess) errors to the browser, ask to
+import the special "fatalsToBrowser" subroutine:
+
+ use CGI::Carp qw(fatalsToBrowser);
+ die "Bad error here";
+
+Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp
+arranges to send a minimal HTTP header to the browser so that even errors that
+occur in the early compile phase will be seen.
+Nonfatal errors will still be directed to the log file only (unless redirected
+with carpout).
+
+Note that fatalsToBrowser does B<not> work with mod_perl version 2.0
+and higher.
+
+=head2 Changing the default message
+
+By default, the software error message is followed by a note to
+contact the Webmaster by e-mail with the time and date of the error.
+If this message is not to your liking, you can change it using the
+set_message() routine. This is not imported by default; you should
+import it on the use() line:
+
+ use CGI::Carp qw(fatalsToBrowser set_message);
+ set_message("It's not a bug, it's a feature!");
+
+You may also pass in a code reference in order to create a custom
+error message. At run time, your code will be called with the text
+of the error message that caused the script to die. Example:
+
+ use CGI::Carp qw(fatalsToBrowser set_message);
+ BEGIN {
+ sub handle_errors {
+ my $msg = shift;
+ print "<h1>Oh gosh</h1>";
+ print "<p>Got an error: $msg</p>";
+ }
+ set_message(\&handle_errors);
+ }
+
+In order to correctly intercept compile-time errors, you should call
+set_message() from within a BEGIN{} block.
+
+=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
+
+If fatalsToBrowser in conjunction with set_message does not provide
+you with all of the functionality you need, you can go one step
+further by specifying a function to be executed any time a script
+calls "die", has a syntax error, or dies unexpectedly at runtime
+with a line like "undef->explode();".
+
+ use CGI::Carp qw(set_die_handler);
+ BEGIN {
+ sub handle_errors {
+ my $msg = shift;
+ print "content-type: text/html\n\n";
+ print "<h1>Oh gosh</h1>";
+ print "<p>Got an error: $msg</p>";
+
+ #proceed to send an email to a system administrator,
+ #write a detailed message to the browser and/or a log,
+ #etc....
+ }
+ set_die_handler(\&handle_errors);
+ }
+
+Notice that if you use set_die_handler(), you must handle sending
+HTML headers to the browser yourself if you are printing a message.
+
+If you use set_die_handler(), you will most likely interfere with
+the behavior of fatalsToBrowser, so you must use this or that, not
+both.
+
+Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
+and there is only one SIG{__DIE__}. This means that if you are
+attempting to set SIG{__DIE__} yourself, you may interfere with
+this module's functionality, or this module may interfere with
+your module's functionality.
+
+=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
+
+It is now also possible to make non-fatal errors appear as HTML
+comments embedded in the output of your program. To enable this
+feature, export the new "warningsToBrowser" subroutine. Since sending
+warnings to the browser before the HTTP headers have been sent would
+cause an error, any warnings are stored in an internal buffer until
+you call the warningsToBrowser() subroutine with a true argument:
+
+ use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
+ use CGI qw(:standard);
+ print header();
+ warningsToBrowser(1);
+
+You may also give a false argument to warningsToBrowser() to prevent
+warnings from being sent to the browser while you are printing some
+content where HTML comments are not allowed:
+
+ warningsToBrowser(0); # disable warnings
+ print "<script type=\"text/javascript\"><!--\n";
+ print_some_javascript_code();
+ print "//--></script>\n";
+ warningsToBrowser(1); # re-enable warnings
+
+Note: In this respect warningsToBrowser() differs fundamentally from
+fatalsToBrowser(), which you should never call yourself!
+
+=head1 OVERRIDING THE NAME OF THE PROGRAM
+
+CGI::Carp includes the name of the program that generated the error or
+warning in the messages written to the log and the browser window.
+Sometimes, Perl can get confused about what the actual name of the
+executed program was. In these cases, you can override the program
+name that CGI::Carp will use for all messages.
+
+The quick way to do that is to tell CGI::Carp the name of the program
+in its use statement. You can do that by adding
+"name=cgi_carp_log_name" to your "use" statement. For example:
+
+ use CGI::Carp qw(name=cgi_carp_log_name);
+
+. If you want to change the program name partway through the program,
+you can use the C<set_progname()> function instead. It is not
+exported by default, you must import it explicitly by saying
+
+ use CGI::Carp qw(set_progname);
+
+Once you've done that, you can change the logged name of the program
+at any time by calling
+
+ set_progname(new_program_name);
+
+You can set the program back to the default by calling
+
+ set_progname(undef);
+
+Note that this override doesn't happen until after the program has
+compiled, so any compile-time errors will still show up with the
+non-overridden program name
+
+=head1 CHANGE LOG
+
+1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp
+ not behaving correctly in an eval() context.
+
+1.05 carpout() added and minor corrections by Marc Hedlund
+ <hedlund@best.com> on 11/26/95.
+
+1.06 fatalsToBrowser() no longer aborts for fatal errors within
+ eval() statements.
+
+1.08 set_message() added and carpout() expanded to allow for FileHandle
+ objects.
+
+1.09 set_message() now allows users to pass a code REFERENCE for
+ really custom error messages. croak and carp are now
+ exported by default. Thanks to Gunther Birznieks for the
+ patches.
+
+1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
+ module to run correctly under mod_perl.
+
+1.11 Changed order of &gt; and &lt; escapes.
+
+1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
+
+1.13 Added cluck() to make the module orthogonal with Carp.
+ More mod_perl related fixes.
+
+1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added
+ warningsToBrowser(). Replaced <CODE> tags with <PRE> in
+ fatalsToBrowser() output.
+
+1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
+ (hack alert!) in order to accommodate various combinations of Perl and
+ mod_perl.
+
+1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
+ for overriding program name.
+
+1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
+ former isn't working in some people's hands. There is no such thing
+ as reliable exception handling in Perl.
+
+1.27 Replaced tell STDOUT with bytes=tell STDOUT.
+
+=head1 AUTHORS
+
+Copyright 1995-2002, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 SEE ALSO
+
+Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
+CGI::Response
+
+=cut
+
+require 5.000;
+use Exporter;
+#use Carp;
+BEGIN {
+ require Carp;
+ *CORE::GLOBAL::die = \&CGI::Carp::die;
+}
+
+use File::Spec;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(confess croak carp);
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die);
+
+$main::SIG{__WARN__}=\&CGI::Carp::warn;
+
+$CGI::Carp::VERSION = '3.45';
+$CGI::Carp::CUSTOM_MSG = undef;
+$CGI::Carp::DIE_HANDLER = undef;
+
+
+# fancy import routine detects and handles 'errorWrap' specially.
+sub import {
+ my $pkg = shift;
+ my(%routines);
+ my(@name);
+ if (@name=grep(/^name=/,@_))
+ {
+ my($n) = (split(/=/,$name[0]))[1];
+ set_progname($n);
+ @_=grep(!/^name=/,@_);
+ }
+
+ grep($routines{$_}++,@_,@EXPORT);
+ $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
+ $WARN++ if $routines{'warningsToBrowser'};
+ my($oldlevel) = $Exporter::ExportLevel;
+ $Exporter::ExportLevel = 1;
+ Exporter::import($pkg,keys %routines);
+ $Exporter::ExportLevel = $oldlevel;
+ $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
+# $pkg->export('CORE::GLOBAL','die');
+}
+
+# These are the originals
+sub realwarn { CORE::warn(@_); }
+sub realdie { CORE::die(@_); }
+
+sub id {
+ my $level = shift;
+ my($pack,$file,$line,$sub) = caller($level);
+ my($dev,$dirs,$id) = File::Spec->splitpath($file);
+ return ($file,$line,$id);
+}
+
+sub stamp {
+ my $time = scalar(localtime);
+ my $frame = 0;
+ my ($id,$pack,$file,$dev,$dirs);
+ if (defined($CGI::Carp::PROGNAME)) {
+ $id = $CGI::Carp::PROGNAME;
+ } else {
+ do {
+ $id = $file;
+ ($pack,$file) = caller($frame++);
+ } until !$file;
+ }
+ ($dev,$dirs,$id) = File::Spec->splitpath($id);
+ return "[$time] $id: ";
+}
+
+sub set_progname {
+ $CGI::Carp::PROGNAME = shift;
+ return $CGI::Carp::PROGNAME;
+}
+
+
+sub warn {
+ my $message = shift;
+ my($file,$line,$id) = id(1);
+ $message .= " at $file line $line.\n" unless $message=~/\n$/;
+ _warn($message) if $WARN;
+ my $stamp = stamp;
+ $message=~s/^/$stamp/gm;
+ realwarn $message;
+}
+
+sub _warn {
+ my $msg = shift;
+ if ($EMIT_WARNINGS) {
+ # We need to mangle the message a bit to make it a valid HTML
+ # comment. This is done by substituting similar-looking ISO
+ # 8859-1 characters for <, > and -. This is a hack.
+ $msg =~ tr/<>-/\253\273\255/;
+ chomp $msg;
+ print STDOUT "<!-- warning: $msg -->\n";
+ } else {
+ push @WARNINGS, $msg;
+ }
+}
+
+
+# The mod_perl package Apache::Registry loads CGI programs by calling
+# eval. These evals don't count when looking at the stack backtrace.
+sub _longmess {
+ my $message = Carp::longmess();
+ $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s
+ if exists $ENV{MOD_PERL};
+ return $message;
+}
+
+sub ineval {
+ (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
+}
+
+sub die {
+ my ($arg,@rest) = @_;
+
+ if ($DIE_HANDLER) {
+ &$DIE_HANDLER($arg,@rest);
+ }
+
+ if ( ineval() ) {
+ if (!ref($arg)) {
+ $arg = join("",($arg,@rest)) || "Died";
+ my($file,$line,$id) = id(1);
+ $arg .= " at $file line $line.\n" unless $arg=~/\n$/;
+ realdie($arg);
+ }
+ else {
+ realdie($arg,@rest);
+ }
+ }
+
+ if (!ref($arg)) {
+ $arg = join("", ($arg,@rest));
+ my($file,$line,$id) = id(1);
+ $arg .= " at $file line $line." unless $arg=~/\n$/;
+ &fatalsToBrowser($arg) if $WRAP;
+ if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) {
+ my $stamp = stamp;
+ $arg=~s/^/$stamp/gm;
+ }
+ if ($arg !~ /\n$/) {
+ $arg .= "\n";
+ }
+ }
+ realdie $arg;
+}
+
+sub set_message {
+ $CGI::Carp::CUSTOM_MSG = shift;
+ return $CGI::Carp::CUSTOM_MSG;
+}
+
+sub set_die_handler {
+
+ my ($handler) = shift;
+
+ #setting SIG{__DIE__} here is necessary to catch runtime
+ #errors which are not called by literally saying "die",
+ #such as the line "undef->explode();". however, doing this
+ #will interfere with fatalsToBrowser, which also sets
+ #SIG{__DIE__} in the import() function above (or the
+ #import() function above may interfere with this). for
+ #this reason, you should choose to either set the die
+ #handler here, or use fatalsToBrowser, not both.
+ $main::SIG{__DIE__} = $handler;
+
+ $CGI::Carp::DIE_HANDLER = $handler;
+
+ return $CGI::Carp::DIE_HANDLER;
+}
+
+sub confess { CGI::Carp::die Carp::longmess @_; }
+sub croak { CGI::Carp::die Carp::shortmess @_; }
+sub carp { CGI::Carp::warn Carp::shortmess @_; }
+sub cluck { CGI::Carp::warn Carp::longmess @_; }
+
+# We have to be ready to accept a filehandle as a reference
+# or a string.
+sub carpout {
+ my($in) = @_;
+ my($no) = fileno(to_filehandle($in));
+ realdie("Invalid filehandle $in\n") unless defined $no;
+
+ open(SAVEERR, ">&STDERR");
+ open(STDERR, ">&$no") or
+ ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
+}
+
+sub warningsToBrowser {
+ $EMIT_WARNINGS = @_ ? shift : 1;
+ _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
+}
+
+# headers
+sub fatalsToBrowser {
+ my($msg) = @_;
+ $msg=~s/&/&amp;/g;
+ $msg=~s/>/&gt;/g;
+ $msg=~s/</&lt;/g;
+ $msg=~s/\"/&quot;/g;
+ my($wm) = $ENV{SERVER_ADMIN} ?
+ qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
+ "this site's webmaster";
+ my ($outer_message) = <<END;
+For help, please send mail to $wm, giving this error message
+and the time and date of the error.
+END
+ ;
+ my $mod_perl = exists $ENV{MOD_PERL};
+
+ if ($CUSTOM_MSG) {
+ if (ref($CUSTOM_MSG) eq 'CODE') {
+ print STDOUT "Content-type: text/html\n\n"
+ unless $mod_perl;
+ eval {
+ &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
+ };
+ if ($@) { print STDERR q(error while executing the error handler: $@); }
+
+ return;
+ } else {
+ $outer_message = $CUSTOM_MSG;
+ }
+ }
+
+ my $mess = <<END;
+<h1>Software error:</h1>
+<pre>$msg</pre>
+<p>
+$outer_message
+</p>
+END
+ ;
+
+ if ($mod_perl) {
+ my $r;
+ if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $mod_perl = 2;
+ require Apache2::RequestRec;
+ require Apache2::RequestIO;
+ require Apache2::RequestUtil;
+ require APR::Pool;
+ require ModPerl::Util;
+ require Apache2::Response;
+ $r = Apache2::RequestUtil->request;
+ }
+ else {
+ $r = Apache->request;
+ }
+ # If bytes have already been sent, then
+ # we print the message out directly.
+ # Otherwise we make a custom error
+ # handler to produce the doc for us.
+ if ($r->bytes_sent) {
+ $r->print($mess);
+ $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
+ } else {
+ # MSIE won't display a custom 500 response unless it is >512 bytes!
+ if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
+ $mess = "<!-- " . (' ' x 513) . " -->\n$mess";
+ }
+ $r->custom_response(500,$mess);
+ }
+ } else {
+ my $bytes_written = eval{tell STDOUT};
+ if (defined $bytes_written && $bytes_written > 0) {
+ print STDOUT $mess;
+ }
+ else {
+ print STDOUT "Status: 500\n";
+ print STDOUT "Content-type: text/html\n\n";
+ print STDOUT $mess;
+ }
+ }
+
+ warningsToBrowser(1); # emit warnings before dying
+}
+
+# Cut and paste from CGI.pm so that we don't have the overhead of
+# always loading the entire CGI module.
+sub to_filehandle {
+ my $thingy = shift;
+ return undef unless $thingy;
+ return $thingy if UNIVERSAL::isa($thingy,'GLOB');
+ return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
+ if (!ref($thingy)) {
+ my $caller = 1;
+ while (my $package = caller($caller++)) {
+ my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
+ return $tmp if defined(fileno($tmp));
+ }
+ }
+ return undef;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Cookie.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Cookie.pm
new file mode 100755
index 00000000000..85a07f0bc05
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Cookie.pm
@@ -0,0 +1,546 @@
+package CGI::Cookie;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995-1999, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+$CGI::Cookie::VERSION='1.29';
+
+use CGI::Util qw(rearrange unescape escape);
+use CGI;
+use overload '""' => \&as_string,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
+
+my $PERLEX = 0;
+# Turn on special checking for ActiveState's PerlEx
+$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
+# Turn on special checking for Doug MacEachern's modperl
+# PerlEx::DBI tries to fool DBI by setting MOD_PERL
+my $MOD_PERL = 0;
+if (exists $ENV{MOD_PERL} && ! $PERLEX) {
+ if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $MOD_PERL = 2;
+ require Apache2::RequestUtil;
+ require APR::Table;
+ } else {
+ $MOD_PERL = 1;
+ require Apache;
+ }
+}
+
+# fetch a list of cookies from the environment and
+# return as a hash. the cookies are parsed as normal
+# escaped URL data.
+sub fetch {
+ my $class = shift;
+ my $raw_cookie = get_raw_cookie(@_) or return;
+ return $class->parse($raw_cookie);
+}
+
+# Fetch a list of cookies from the environment or the incoming headers and
+# return as a hash. The cookie values are not unescaped or altered in any way.
+ sub raw_fetch {
+ my $class = shift;
+ my $raw_cookie = get_raw_cookie(@_) or return;
+ my %results;
+ my($key,$value);
+
+ my @pairs = split("[;,] ?",$raw_cookie);
+ foreach (@pairs) {
+ s/\s*(.*?)\s*/$1/;
+ if (/^([^=]+)=(.*)/) {
+ $key = $1;
+ $value = $2;
+ }
+ else {
+ $key = $_;
+ $value = '';
+ }
+ $results{$key} = $value;
+ }
+ return \%results unless wantarray;
+ return %results;
+}
+
+sub get_raw_cookie {
+ my $r = shift;
+ $r ||= eval { $MOD_PERL == 2 ?
+ Apache2::RequestUtil->request() :
+ Apache->request } if $MOD_PERL;
+ if ($r) {
+ $raw_cookie = $r->headers_in->{'Cookie'};
+ } else {
+ if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) {
+ die "Run $r->subprocess_env; before calling fetch()";
+ }
+ $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
+ }
+}
+
+
+sub parse {
+ my ($self,$raw_cookie) = @_;
+ my %results;
+
+ my @pairs = split("[;,] ?",$raw_cookie);
+ foreach (@pairs) {
+ s/\s*(.*?)\s*/$1/;
+ my($key,$value) = split("=",$_,2);
+
+ # Some foreign cookies are not in name=value format, so ignore
+ # them.
+ next if !defined($value);
+ my @values = ();
+ if ($value ne '') {
+ @values = map unescape($_),split(/[&;]/,$value.'&dmy');
+ pop @values;
+ }
+ $key = unescape($key);
+ # A bug in Netscape can cause several cookies with same name to
+ # appear. The FIRST one in HTTP_COOKIE is the most recent version.
+ $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+ }
+ return \%results unless wantarray;
+ return %results;
+}
+
+sub new {
+ my $class = shift;
+ $class = ref($class) if ref($class);
+ # Ignore mod_perl request object--compatability with Apache::Cookie.
+ shift if ref $_[0]
+ && eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@_);
+
+ # Pull out our parameters.
+ my @values;
+ if (ref($value)) {
+ if (ref($value) eq 'ARRAY') {
+ @values = @$value;
+ } elsif (ref($value) eq 'HASH') {
+ @values = %$value;
+ }
+ } else {
+ @values = ($value);
+ }
+
+ bless my $self = {
+ 'name'=>$name,
+ 'value'=>[@values],
+ },$class;
+
+ # IE requires the path and domain to be present for some reason.
+ $path ||= "/";
+ # however, this breaks networks which use host tables without fully qualified
+ # names, so we comment it out.
+ # $domain = CGI::virtual_host() unless defined $domain;
+
+ $self->path($path) if defined $path;
+ $self->domain($domain) if defined $domain;
+ $self->secure($secure) if defined $secure;
+ $self->expires($expires) if defined $expires;
+ $self->httponly($httponly) if defined $httponly;
+# $self->max_age($expires) if defined $expires;
+ return $self;
+}
+
+sub as_string {
+ my $self = shift;
+ return "" unless $self->name;
+
+ my(@constant_values,$domain,$path,$expires,$max_age,$secure,$httponly);
+
+ push(@constant_values,"domain=$domain") if $domain = $self->domain;
+ push(@constant_values,"path=$path") if $path = $self->path;
+ push(@constant_values,"expires=$expires") if $expires = $self->expires;
+ push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
+ push(@constant_values,"secure") if $secure = $self->secure;
+ push(@constant_values,"HttpOnly") if $httponly = $self->httponly;
+
+ my($key) = escape($self->name);
+ my($cookie) = join("=",(defined $key ? $key : ''),join("&",map escape(defined $_ ? $_ : ''),$self->value));
+ return join("; ",$cookie,@constant_values);
+}
+
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+
+sub bake {
+ my ($self, $r) = @_;
+
+ $r ||= eval {
+ $MOD_PERL == 2
+ ? Apache2::RequestUtil->request()
+ : Apache->request
+ } if $MOD_PERL;
+ if ($r) {
+ $r->headers_out->add('Set-Cookie' => $self->as_string);
+ } else {
+ print CGI::header(-cookie => $self);
+ }
+
+}
+
+# accessors
+sub name {
+ my $self = shift;
+ my $name = shift;
+ $self->{'name'} = $name if defined $name;
+ return $self->{'name'};
+}
+
+sub value {
+ my $self = shift;
+ my $value = shift;
+ if (defined $value) {
+ my @values;
+ if (ref($value)) {
+ if (ref($value) eq 'ARRAY') {
+ @values = @$value;
+ } elsif (ref($value) eq 'HASH') {
+ @values = %$value;
+ }
+ } else {
+ @values = ($value);
+ }
+ $self->{'value'} = [@values];
+ }
+ return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
+}
+
+sub domain {
+ my $self = shift;
+ my $domain = shift;
+ $self->{'domain'} = lc $domain if defined $domain;
+ return $self->{'domain'};
+}
+
+sub secure {
+ my $self = shift;
+ my $secure = shift;
+ $self->{'secure'} = $secure if defined $secure;
+ return $self->{'secure'};
+}
+
+sub expires {
+ my $self = shift;
+ my $expires = shift;
+ $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
+ return $self->{'expires'};
+}
+
+sub max_age {
+ my $self = shift;
+ my $expires = shift;
+ $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires;
+ return $self->{'max-age'};
+}
+
+sub path {
+ my $self = shift;
+ my $path = shift;
+ $self->{'path'} = $path if defined $path;
+ return $self->{'path'};
+}
+
+
+sub httponly { # HttpOnly
+ my $self = shift;
+ my $httponly = shift;
+ $self->{'httponly'} = $httponly if defined $httponly;
+ return $self->{'httponly'};
+}
+
+1;
+
+=head1 NAME
+
+CGI::Cookie - Interface to Netscape Cookies
+
+=head1 SYNOPSIS
+
+ use CGI qw/:standard/;
+ use CGI::Cookie;
+
+ # Create new cookies and send them
+ $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
+ $cookie2 = new CGI::Cookie(-name=>'preferences',
+ -value=>{ font => Helvetica,
+ size => 12 }
+ );
+ print header(-cookie=>[$cookie1,$cookie2]);
+
+ # fetch existing cookies
+ %cookies = fetch CGI::Cookie;
+ $id = $cookies{'ID'}->value;
+
+ # create cookies returned from an external source
+ %cookies = parse CGI::Cookie($ENV{COOKIE});
+
+=head1 DESCRIPTION
+
+CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
+innovation that allows Web servers to store persistent information on
+the browser's side of the connection. Although CGI::Cookie is
+intended to be used in conjunction with CGI.pm (and is in fact used by
+it internally), you can use this module independently.
+
+For full information on cookies see
+
+ http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
+
+=head1 USING CGI::Cookie
+
+CGI::Cookie is object oriented. Each cookie object has a name and a
+value. The name is any scalar value. The value is any scalar or
+array value (associative arrays are also allowed). Cookies also have
+several optional attributes, including:
+
+=over 4
+
+=item B<1. expiration date>
+
+The expiration date tells the browser how long to hang on to the
+cookie. If the cookie specifies an expiration date in the future, the
+browser will store the cookie information in a disk file and return it
+to the server every time the user reconnects (until the expiration
+date is reached). If the cookie species an expiration date in the
+past, the browser will remove the cookie from the disk file. If the
+expiration date is not specified, the cookie will persist only until
+the user quits the browser.
+
+=item B<2. domain>
+
+This is a partial or complete domain name for which the cookie is
+valid. The browser will return the cookie to any host that matches
+the partial domain name. For example, if you specify a domain name
+of ".capricorn.com", then Netscape will return the cookie to
+Web servers running on any of the machines "www.capricorn.com",
+"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
+must contain at least two periods to prevent attempts to match
+on top level domains like ".edu". If no domain is specified, then
+the browser will only return the cookie to servers on the host the
+cookie originated from.
+
+=item B<3. path>
+
+If you provide a cookie path attribute, the browser will check it
+against your script's URL before returning the cookie. For example,
+if you specify the path "/cgi-bin", then the cookie will be returned
+to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
+"/cgi-bin/customer_service/complain.pl", but not to the script
+"/cgi-private/site_admin.pl". By default, the path is set to "/", so
+that all scripts at your site will receive the cookie.
+
+=item B<4. secure flag>
+
+If the "secure" attribute is set, the cookie will only be sent to your
+script if the CGI request is occurring on a secure channel, such as SSL.
+
+=item B<4. httponly flag>
+
+If the "httponly" attribute is set, the cookie will only be accessible
+through HTTP Requests. This cookie will be inaccessible via JavaScript
+(to prevent XSS attacks).
+
+But, currently this feature only used and recognised by
+MS Internet Explorer 6 Service Pack 1 and later.
+
+See this URL for more information:
+
+L<http://msdn.microsoft.com/en-us/library/ms533046%28VS.85%29.aspx>
+
+=back
+
+=head2 Creating New Cookies
+
+ my $c = new CGI::Cookie(-name => 'foo',
+ -value => 'bar',
+ -expires => '+3M',
+ -domain => '.capricorn.com',
+ -path => '/cgi-bin/database',
+ -secure => 1
+ );
+
+Create cookies from scratch with the B<new> method. The B<-name> and
+B<-value> parameters are required. The name must be a scalar value.
+The value can be a scalar, an array reference, or a hash reference.
+(At some point in the future cookies will support one of the Perl
+object serialization protocols for full generality).
+
+B<-expires> accepts any of the relative or absolute date formats
+recognized by CGI.pm, for example "+3M" for three months in the
+future. See CGI.pm's documentation for details.
+
+B<-domain> points to a domain name or to a fully qualified host name.
+If not specified, the cookie will be returned only to the Web server
+that created it.
+
+B<-path> points to a partial URL on the current server. The cookie
+will be returned to all URLs beginning with the specified path. If
+not specified, it defaults to '/', which returns the cookie to all
+pages at your site.
+
+B<-secure> if set to a true value instructs the browser to return the
+cookie only when a cryptographic protocol is in use.
+
+B<-httponly> if set to a true value, the cookie will not be accessible
+via JavaScript.
+
+For compatibility with Apache::Cookie, you may optionally pass in
+a mod_perl request object as the first argument to C<new()>. It will
+simply be ignored:
+
+ my $c = new CGI::Cookie($r,
+ -name => 'foo',
+ -value => ['bar','baz']);
+
+=head2 Sending the Cookie to the Browser
+
+The simplest way to send a cookie to the browser is by calling the bake()
+method:
+
+ $c->bake;
+
+Under mod_perl, pass in an Apache request object:
+
+ $c->bake($r);
+
+If you want to set the cookie yourself, Within a CGI script you can send
+a cookie to the browser by creating one or more Set-Cookie: fields in the
+HTTP header. Here is a typical sequence:
+
+ my $c = new CGI::Cookie(-name => 'foo',
+ -value => ['bar','baz'],
+ -expires => '+3M');
+
+ print "Set-Cookie: $c\n";
+ print "Content-Type: text/html\n\n";
+
+To send more than one cookie, create several Set-Cookie: fields.
+
+If you are using CGI.pm, you send cookies by providing a -cookie
+argument to the header() method:
+
+ print header(-cookie=>$c);
+
+Mod_perl users can set cookies using the request object's header_out()
+method:
+
+ $r->headers_out->set('Set-Cookie' => $c);
+
+Internally, Cookie overloads the "" operator to call its as_string()
+method when incorporated into the HTTP header. as_string() turns the
+Cookie's internal representation into an RFC-compliant text
+representation. You may call as_string() yourself if you prefer:
+
+ print "Set-Cookie: ",$c->as_string,"\n";
+
+=head2 Recovering Previous Cookies
+
+ %cookies = fetch CGI::Cookie;
+
+B<fetch> returns an associative array consisting of all cookies
+returned by the browser. The keys of the array are the cookie names. You
+can iterate through the cookies this way:
+
+ %cookies = fetch CGI::Cookie;
+ foreach (keys %cookies) {
+ do_something($cookies{$_});
+ }
+
+In a scalar context, fetch() returns a hash reference, which may be more
+efficient if you are manipulating multiple cookies.
+
+CGI.pm uses the URL escaping methods to save and restore reserved characters
+in its cookies. If you are trying to retrieve a cookie set by a foreign server,
+this escaping method may trip you up. Use raw_fetch() instead, which has the
+same semantics as fetch(), but performs no unescaping.
+
+You may also retrieve cookies that were stored in some external
+form using the parse() class method:
+
+ $COOKIES = `cat /usr/tmp/Cookie_stash`;
+ %cookies = parse CGI::Cookie($COOKIES);
+
+If you are in a mod_perl environment, you can save some overhead by
+passing the request object to fetch() like this:
+
+ CGI::Cookie->fetch($r);
+
+=head2 Manipulating Cookies
+
+Cookie objects have a series of accessor methods to get and set cookie
+attributes. Each accessor has a similar syntax. Called without
+arguments, the accessor returns the current value of the attribute.
+Called with an argument, the accessor changes the attribute and
+returns its new value.
+
+=over 4
+
+=item B<name()>
+
+Get or set the cookie's name. Example:
+
+ $name = $c->name;
+ $new_name = $c->name('fred');
+
+=item B<value()>
+
+Get or set the cookie's value. Example:
+
+ $value = $c->value;
+ @new_value = $c->value(['a','b','c','d']);
+
+B<value()> is context sensitive. In a list context it will return
+the current value of the cookie as an array. In a scalar context it
+will return the B<first> value of a multivalued cookie.
+
+=item B<domain()>
+
+Get or set the cookie's domain.
+
+=item B<path()>
+
+Get or set the cookie's path.
+
+=item B<expires()>
+
+Get or set the cookie's expiration time.
+
+=back
+
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1997-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Fast.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Fast.pm
new file mode 100755
index 00000000000..67d67ee6856
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Fast.pm
@@ -0,0 +1,220 @@
+package CGI::Fast;
+use strict;
+$^W=1; # A way to say "use warnings" that's compatible with even older perls.
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+$CGI::Fast::VERSION='1.07';
+
+use CGI;
+use FCGI;
+# use vars works like "our", but is compatible with older Perls.
+use vars qw(
+ @ISA
+ $ignore
+);
+@ISA = ('CGI');
+
+# workaround for known bug in libfcgi
+while (($ignore) = each %ENV) { }
+
+# override the initialization behavior so that
+# state is NOT maintained between invocations
+sub save_request {
+ # no-op
+}
+
+# If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle
+# in this package variable.
+use vars qw($Ext_Request);
+BEGIN {
+ # If ENV{FCGI_SOCKET_PATH} is given, explicitly open the socket,
+ # and keep the request handle around from which to call Accept().
+ if ($ENV{FCGI_SOCKET_PATH}) {
+ my $path = $ENV{FCGI_SOCKET_PATH};
+ my $backlog = $ENV{FCGI_LISTEN_QUEUE} || 100;
+ my $socket = FCGI::OpenSocket( $path, $backlog );
+ $Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR,
+ \%ENV, $socket, 1 );
+ }
+}
+
+# New is slightly different in that it calls FCGI's
+# accept() method.
+sub new {
+ my ($self, $initializer, @param) = @_;
+ unless (defined $initializer) {
+ if ($Ext_Request) {
+ return undef unless $Ext_Request->Accept() >= 0;
+ } else {
+ return undef unless FCGI::accept() >= 0;
+ }
+ }
+ CGI->_reset_globals;
+ $self->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
+ return $CGI::Q = $self->SUPER::new($initializer, @param);
+}
+
+1;
+
+=head1 NAME
+
+CGI::Fast - CGI Interface for Fast CGI
+
+=head1 SYNOPSIS
+
+ use CGI::Fast qw(:standard);
+ $COUNTER = 0;
+ while (new CGI::Fast) {
+ print header;
+ print start_html("Fast CGI Rocks");
+ print
+ h1("Fast CGI Rocks"),
+ "Invocation number ",b($COUNTER++),
+ " PID ",b($$),".",
+ hr;
+ print end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Fast is a subclass of the CGI object created by CGI.pm. It is
+specialized to work well FCGI module, which greatly speeds up CGI
+scripts by turning them into persistently running server processes.
+Scripts that perform time-consuming initialization processes, such as
+loading large modules or opening persistent database connections, will
+see large performance improvements.
+
+=head1 OTHER PIECES OF THE PUZZLE
+
+In order to use CGI::Fast you'll need the FCGI module. See
+http://www.cpan.org/ for details.
+
+=head1 WRITING FASTCGI PERL SCRIPTS
+
+FastCGI scripts are persistent: one or more copies of the script
+are started up when the server initializes, and stay around until
+the server exits or they die a natural death. After performing
+whatever one-time initialization it needs, the script enters a
+loop waiting for incoming connections, processing the request, and
+waiting some more.
+
+A typical FastCGI script will look like this:
+
+ #!/usr/bin/perl
+ use CGI::Fast;
+ &do_some_initialization();
+ while ($q = new CGI::Fast) {
+ &process_request($q);
+ }
+
+Each time there's a new request, CGI::Fast returns a
+CGI object to your loop. The rest of the time your script
+waits in the call to new(). When the server requests that
+your script be terminated, new() will return undef. You can
+of course exit earlier if you choose. A new version of the
+script will be respawned to take its place (this may be
+necessary in order to avoid Perl memory leaks in long-running
+scripts).
+
+CGI.pm's default CGI object mode also works. Just modify the loop
+this way:
+
+ while (new CGI::Fast) {
+ &process_request;
+ }
+
+Calls to header(), start_form(), etc. will all operate on the
+current request.
+
+=head1 INSTALLING FASTCGI SCRIPTS
+
+See the FastCGI developer's kit documentation for full details. On
+the Apache server, the following line must be added to srm.conf:
+
+ AddType application/x-httpd-fcgi .fcgi
+
+FastCGI scripts must end in the extension .fcgi. For each script you
+install, you must add something like the following to srm.conf:
+
+ FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
+
+This instructs Apache to launch two copies of file_upload.fcgi at
+startup time.
+
+=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
+
+Any script that works correctly as a FastCGI script will also work
+correctly when installed as a vanilla CGI script. However it will
+not see any performance benefit.
+
+=head1 EXTERNAL FASTCGI SERVER INVOCATION
+
+FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run
+external to the webserver, perhaps on a remote machine. To configure the
+webserver to connect to an external FastCGI server, you would add the following
+to your srm.conf:
+
+ FastCgiExternalServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -host sputnik:8888
+
+Two environment variables affect how the C<CGI::Fast> object is created,
+allowing C<CGI::Fast> to be used as an external FastCGI server. (See C<FCGI>
+documentation for C<FCGI::OpenSocket> for more information.)
+
+=over
+
+=item FCGI_SOCKET_PATH
+
+The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI
+script to which bind an listen for incoming connections from the web server.
+
+=item FCGI_LISTEN_QUEUE
+
+Maximum length of the queue of pending connections.
+
+=back
+
+For example:
+
+ #!/usr/local/bin/perl # must be a FastCGI version of perl!
+ use CGI::Fast;
+ &do_some_initialization();
+ $ENV{FCGI_SOCKET_PATH} = "sputnik:8888";
+ $ENV{FCGI_LISTEN_QUEUE} = 100;
+ while ($q = new CGI::Fast) {
+ &process_request($q);
+ }
+
+=head1 CAVEATS
+
+I haven't tested this very much.
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1996-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Pretty.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Pretty.pm
new file mode 100755
index 00000000000..356747824d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Pretty.pm
@@ -0,0 +1,312 @@
+package CGI::Pretty;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+use strict;
+use CGI ();
+
+$CGI::Pretty::VERSION = '3.46';
+$CGI::DefaultClass = __PACKAGE__;
+$CGI::Pretty::AutoloadClass = 'CGI';
+@CGI::Pretty::ISA = qw( CGI );
+
+initialize_globals();
+
+sub _prettyPrint {
+ my $input = shift;
+ return if !$$input;
+ return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT;
+
+# print STDERR "'", $$input, "'\n";
+
+ foreach my $i ( @CGI::Pretty::AS_IS ) {
+ if ( $$input =~ m{</$i>}si ) {
+ my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si;
+ next if !$b;
+ $a ||= "";
+ $c ||= "";
+
+ _prettyPrint( \$a ) if $a;
+ _prettyPrint( \$c ) if $c;
+
+ $b ||= "";
+ $$input = "$a$b$c";
+ return;
+ }
+ }
+ $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g;
+}
+
+sub comment {
+ my($self,@p) = CGI::self_or_CGI(@_);
+
+ my $s = "@p";
+ $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK;
+
+ return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK;
+}
+
+sub _make_tag_func {
+ my ($self,$tagname) = @_;
+
+ # As Lincoln as noted, the last else clause is VERY hairy, and it
+ # took me a while to figure out what I was trying to do.
+ # What it does is look for tags that shouldn't be indented (e.g. PRE)
+ # and makes sure that when we nest tags, those tags don't get
+ # indented.
+ # For an example, try print td( pre( "hello\nworld" ) );
+ # If we didn't care about stuff like that, the code would be
+ # MUCH simpler. BTW: I won't claim to be a regular expression
+ # guru, so if anybody wants to contribute something that would
+ # be quicker, easier to read, etc, I would be more than
+ # willing to put it in - Brian
+
+ my $func = qq"
+ sub $tagname {";
+
+ $func .= q'
+ shift if $_[0] &&
+ (ref($_[0]) &&
+ (substr(ref($_[0]),0,3) eq "CGI" ||
+ UNIVERSAL::isa($_[0],"CGI")));
+ my($attr) = "";
+ if (ref($_[0]) && ref($_[0]) eq "HASH") {
+ my(@attr) = make_attributes(shift()||undef,1);
+ $attr = " @attr" if @attr;
+ }';
+
+ if ($tagname=~/start_(\w+)/i) {
+ $func .= qq!
+ return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq!
+ return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !;
+ } else {
+ $func .= qq#
+ return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) .
+ \$CGI::Pretty::LINEBREAK unless \@_;
+ my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E");
+
+ my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS;
+ my \@args;
+ if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) {
+ if(ref(\$_[0]) eq 'ARRAY') {
+ \@args = \@{\$_[0]}
+ } else {
+ foreach (\@_) {
+ \$args[0] .= \$_;
+ \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0;
+ chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" };
+
+ \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1;
+ }
+ chop \$args[0] unless \$" eq "";
+ }
+ }
+ else {
+ \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_";
+ }
+
+ my \@result;
+ if ( exists \$ASIS{ "\L$tagname\E" } ) {
+ \@result = map { "\$tag\$_\$untag" } \@args;
+ }
+ else {
+ \@result = map {
+ chomp;
+ my \$tmp = \$_;
+ CGI::Pretty::_prettyPrint( \\\$tmp );
+ \$tag . \$CGI::Pretty::LINEBREAK .
+ \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK .
+ \$untag . \$CGI::Pretty::LINEBREAK
+ } \@args;
+ }
+ if (\$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT) {
+ return join ("", \@result);
+ } else {
+ return "\@result";
+ }
+ }#;
+ }
+
+ return $func;
+}
+
+sub start_html {
+ return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
+}
+
+sub end_html {
+ return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
+}
+
+sub new {
+ my $class = shift;
+ my $this = $class->SUPER::new( @_ );
+
+ if ($CGI::MOD_PERL) {
+ if ($CGI::MOD_PERL == 1) {
+ my $r = Apache->request;
+ $r->register_cleanup(\&CGI::Pretty::_reset_globals);
+ }
+ else {
+ my $r = Apache2::RequestUtil->request;
+ $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals);
+ }
+ }
+ $class->_reset_globals if $CGI::PERLEX;
+
+ return bless $this, $class;
+}
+
+sub initialize_globals {
+ # This is the string used for indentation of tags
+ $CGI::Pretty::INDENT = "\t";
+
+ # This is the string used for seperation between tags
+ $CGI::Pretty::LINEBREAK = $/;
+
+ # These tags are not prettify'd.
+ # When this list is updated, also update the docs.
+ @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
+
+ 1;
+}
+sub _reset_globals { initialize_globals(); }
+
+# ugly, but quick fix
+sub import {
+ my $self = shift;
+ no strict 'refs';
+ ${ "$self\::AutoloadClass" } = 'CGI';
+
+ # This causes modules to clash.
+ undef %CGI::EXPORT;
+ undef %CGI::EXPORT;
+
+ $self->_setup_symbols(@_);
+ my ($callpack, $callfile, $callline) = caller;
+
+ # To allow overriding, search through the packages
+ # Till we find one in which the correct subroutine is defined.
+ my @packages = ($self,@{"$self\:\:ISA"});
+ foreach my $sym (keys %CGI::EXPORT) {
+ my $pck;
+ my $def = ${"$self\:\:AutoloadClass"} || $CGI::DefaultClass;
+ foreach $pck (@packages) {
+ if (defined(&{"$pck\:\:$sym"})) {
+ $def = $pck;
+ last;
+ }
+ }
+ *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
+ }
+}
+
+1;
+
+=head1 NAME
+
+CGI::Pretty - module to produce nicely formatted HTML code
+
+=head1 SYNOPSIS
+
+ use CGI::Pretty qw( :html3 );
+
+ # Print a table with a single data element
+ print table( TR( td( "foo" ) ) );
+
+=head1 DESCRIPTION
+
+CGI::Pretty is a module that derives from CGI. It's sole function is to
+allow users of CGI to output nicely formatted HTML code.
+
+When using the CGI module, the following code:
+ print table( TR( td( "foo" ) ) );
+
+produces the following output:
+ <TABLE><TR><TD>foo</TD></TR></TABLE>
+
+If a user were to create a table consisting of many rows and many columns,
+the resultant HTML code would be quite difficult to read since it has no
+carriage returns or indentation.
+
+CGI::Pretty fixes this problem. What it does is add a carriage
+return and indentation to the HTML code so that one can easily read
+it.
+
+ print table( TR( td( "foo" ) ) );
+
+now produces the following output:
+ <TABLE>
+ <TR>
+ <TD>foo</TD>
+ </TR>
+ </TABLE>
+
+=head2 Recommendation for when to use CGI::Pretty
+
+CGI::Pretty is far slower than using CGI.pm directly. A benchmark showed that
+it could be about 10 times slower. Adding newslines and spaces may alter the
+rendered appearance of HTML. Also, the extra newlines and spaces also make the
+file size larger, making the files take longer to download.
+
+With all those considerations, it is recommended that CGI::Pretty be used
+primarily for debugging.
+
+=head2 Tags that won't be formatted
+
+The following tags are not formatted: <a>, <pre>, <code>, <script>, <textarea>, and <td>.
+If these tags were formatted, the
+user would see the extra indentation on the web browser causing the page to
+look different than what would be expected. If you wish to add more tags to
+the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
+
+ push @CGI::Pretty::AS_IS,qw(XMP);
+
+=head2 Customizing the Indenting
+
+If you wish to have your own personal style of indenting, you can change the
+C<$INDENT> variable:
+
+ $CGI::Pretty::INDENT = "\t\t";
+
+would cause the indents to be two tabs.
+
+Similarly, if you wish to have more space between lines, you may change the
+C<$LINEBREAK> variable:
+
+ $CGI::Pretty::LINEBREAK = "\n\n";
+
+would create two carriage returns between lines.
+
+If you decide you want to use the regular CGI indenting, you can easily do
+the following:
+
+ $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
+
+=head1 AUTHOR
+
+Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
+Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
+distribution.
+
+Copyright 1999, Brian Paulsen. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Bug reports and comments to Brian@ThePaulsens.com. You can also write
+to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
+sure I understand it!
+
+=head1 SEE ALSO
+
+L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Push.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Push.pm
new file mode 100755
index 00000000000..9e72abda550
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Push.pm
@@ -0,0 +1,325 @@
+package CGI::Push;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995-2000, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://stein.cshl.org/WWW/software/CGI/
+
+$CGI::Push::VERSION='1.04';
+use CGI;
+use CGI::Util 'rearrange';
+@ISA = ('CGI');
+
+$CGI::DefaultClass = 'CGI::Push';
+$CGI::Push::AutoloadClass = 'CGI';
+
+# add do_push() and push_delay() to exported tags
+push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
+
+sub do_push {
+ my ($self,@p) = CGI::self_or_default(@_);
+
+ # unbuffer output
+ $| = 1;
+ srand;
+ my ($random) = sprintf("%08.0f",rand()*1E8);
+ my ($boundary) = "----=_NeXtPaRt$random";
+
+ my (@header);
+ my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+ $type = 'text/html' unless $type;
+ $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
+ $delay = 1 unless defined($delay);
+ $self->push_delay($delay);
+ $nph = 1 unless defined($nph);
+
+ my(@o);
+ foreach (@other) { push(@o,split("=")); }
+ push(@o,'-Target'=>$target) if defined($target);
+ push(@o,'-Cookie'=>$cookie) if defined($cookie);
+ push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\"");
+ push(@o,'-Server'=>"CGI.pm Push Module") if $nph;
+ push(@o,'-Status'=>'200 OK');
+ push(@o,'-nph'=>1) if $nph;
+ print $self->header(@o);
+
+ $boundary = "$CGI::CRLF--$boundary";
+
+ print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF";
+
+ my (@contents) = &$callback($self,++$COUNTER);
+
+ # now we enter a little loop
+ while (1) {
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+ print @contents;
+ @contents = &$callback($self,++$COUNTER);
+ if ((@contents) && defined($contents[0])) {
+ print "${boundary}$CGI::CRLF";
+ do_sleep($self->push_delay()) if $self->push_delay();
+ } else {
+ if ($last_page && ref($last_page) eq 'CODE') {
+ print "${boundary}$CGI::CRLF";
+ do_sleep($self->push_delay()) if $self->push_delay();
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+ print &$last_page($self,$COUNTER);
+ }
+ print "${boundary}--$CGI::CRLF";
+ last;
+ }
+ }
+ print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF";
+}
+
+sub simple_counter {
+ my ($self,$count) = @_;
+ return $self->start_html("CGI::Push Default Counter"),
+ $self->h1("CGI::Push Default Counter"),
+ "This page has been updated ",$self->strong($count)," times.",
+ $self->hr(),
+ $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
+ $self->end_html;
+}
+
+sub do_sleep {
+ my $delay = shift;
+ if ( ($delay >= 1) && ($delay!~/\./) ){
+ sleep($delay);
+ } else {
+ select(undef,undef,undef,$delay);
+ }
+}
+
+sub push_delay {
+ my ($self,$delay) = CGI::self_or_default(@_);
+ return defined($delay) ? $self->{'.delay'} =
+ $delay : $self->{'.delay'};
+}
+
+1;
+
+=head1 NAME
+
+CGI::Push - Simple Interface to Server Push
+
+=head1 SYNOPSIS
+
+ use CGI::Push qw(:standard);
+
+ do_push(-next_page=>\&next_page,
+ -last_page=>\&last_page,
+ -delay=>0.5);
+
+ sub next_page {
+ my($q,$counter) = @_;
+ return undef if $counter >= 10;
+ return start_html('Test'),
+ h1('Visible'),"\n",
+ "This page has been called ", strong($counter)," times",
+ end_html();
+ }
+
+ sub last_page {
+ my($q,$counter) = @_;
+ return start_html('Done'),
+ h1('Finished'),
+ strong($counter - 1),' iterations.',
+ end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Push is a subclass of the CGI object created by CGI.pm. It is
+specialized for server push operations, which allow you to create
+animated pages whose content changes at regular intervals.
+
+You provide CGI::Push with a pointer to a subroutine that will draw
+one page. Every time your subroutine is called, it generates a new
+page. The contents of the page will be transmitted to the browser
+in such a way that it will replace what was there beforehand. The
+technique will work with HTML pages as well as with graphics files,
+allowing you to create animated GIFs.
+
+Only Netscape Navigator supports server push. Internet Explorer
+browsers do not.
+
+=head1 USING CGI::Push
+
+CGI::Push adds one new method to the standard CGI suite, do_push().
+When you call this method, you pass it a reference to a subroutine
+that is responsible for drawing each new page, an interval delay, and
+an optional subroutine for drawing the last page. Other optional
+parameters include most of those recognized by the CGI header()
+method.
+
+You may call do_push() in the object oriented manner or not, as you
+prefer:
+
+ use CGI::Push;
+ $q = new CGI::Push;
+ $q->do_push(-next_page=>\&draw_a_page);
+
+ -or-
+
+ use CGI::Push qw(:standard);
+ do_push(-next_page=>\&draw_a_page);
+
+Parameters are as follows:
+
+=over 4
+
+=item -next_page
+
+ do_push(-next_page=>\&my_draw_routine);
+
+This required parameter points to a reference to a subroutine responsible for
+drawing each new page. The subroutine should expect two parameters
+consisting of the CGI object and a counter indicating the number
+of times the subroutine has been called. It should return the
+contents of the page as an B<array> of one or more items to print.
+It can return a false value (or an empty array) in order to abort the
+redrawing loop and print out the final page (if any)
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return undef if $counter > 100;
+ return start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+You are of course free to refer to create and use global variables
+within your draw routine in order to achieve special effects.
+
+=item -last_page
+
+This optional parameter points to a reference to the subroutine
+responsible for drawing the last page of the series. It is called
+after the -next_page routine returns a false value. The subroutine
+itself should have exactly the same calling conventions as the
+-next_page routine.
+
+=item -type
+
+This optional parameter indicates the content type of each page. It
+defaults to "text/html". Normally the module assumes that each page
+is of a homogenous MIME type. However if you provide either of the
+magic values "heterogeneous" or "dynamic" (the latter provided for the
+convenience of those who hate long parameter names), you can specify
+the MIME type -- and other header fields -- on a per-page basis. See
+"heterogeneous pages" for more details.
+
+=item -delay
+
+This indicates the delay, in seconds, between frames. Smaller delays
+refresh the page faster. Fractional values are allowed.
+
+B<If not specified, -delay will default to 1 second>
+
+=item -cookie, -target, -expires, -nph
+
+These have the same meaning as the like-named parameters in
+CGI::header().
+
+If not specified, -nph will default to 1 (as needed for many servers, see below).
+
+=back
+
+=head2 Heterogeneous Pages
+
+Ordinarily all pages displayed by CGI::Push share a common MIME type.
+However by providing a value of "heterogeneous" or "dynamic" in the
+do_push() -type parameter, you can specify the MIME type of each page
+on a case-by-case basis.
+
+If you use this option, you will be responsible for producing the
+HTTP header for each page. Simply modify your draw routine to
+look like this:
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return header('text/html'), # note we're producing the header here
+ start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+You can add any header fields that you like, but some (cookies and
+status fields included) may not be interpreted by the browser. One
+interesting effect is to display a series of pages, then, after the
+last page, to redirect the browser to a new URL. Because redirect()
+does b<not> work, the easiest way is with a -refresh header field,
+as shown below:
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return undef if $counter > 10;
+ return header('text/html'), # note we're producing the header here
+ start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+ sub my_last_page {
+ return header(-refresh=>'5; URL=http://somewhere.else/finished.html',
+ -type=>'text/html'),
+ start_html('Moved'),
+ h1('This is the last page'),
+ 'Goodbye!'
+ hr,
+ end_html;
+ }
+
+=head2 Changing the Page Delay on the Fly
+
+If you would like to control the delay between pages on a page-by-page
+basis, call push_delay() from within your draw routine. push_delay()
+takes a single numeric argument representing the number of seconds you
+wish to delay after the current page is displayed and before
+displaying the next one. The delay may be fractional. Without
+parameters, push_delay() just returns the current delay.
+
+=head1 INSTALLING CGI::Push SCRIPTS
+
+Server push scripts must be installed as no-parsed-header (NPH)
+scripts in order to work correctly on many servers. On Unix systems,
+this is most often accomplished by prefixing the script's name with "nph-".
+Recognition of NPH scripts happens automatically with WebSTAR and
+Microsoft IIS. Users of other servers should see their documentation
+for help.
+
+Apache web server from version 1.3b2 on does not need server
+push scripts installed as NPH scripts: the -nph parameter to do_push()
+may be set to a false value to disable the extra headers needed by an
+NPH script.
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Switch.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Switch.pm
new file mode 100755
index 00000000000..a311080e49f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Switch.pm
@@ -0,0 +1,28 @@
+package CGI::Switch;
+use CGI;
+
+$VERSION = '1.01';
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Switch - Backward compatibility module for defunct CGI::Switch
+
+=head1 SYNOPSIS
+
+Do not use this module. It is deprecated.
+
+=head1 ABSTRACT
+
+=head1 DESCRIPTION
+
+=head1 AUTHOR INFORMATION
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Util.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Util.pm
new file mode 100755
index 00000000000..1f4201d0648
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Util.pm
@@ -0,0 +1,365 @@
+package CGI::Util;
+
+use strict;
+use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
+ expires ebcdic2ascii ascii2ebcdic);
+
+$VERSION = '3.48';
+
+$EBCDIC = "\t" ne "\011";
+# (ord('^') == 95) for codepage 1047 as on os390, vmesa
+@A2E = (
+ 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
+ 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
+ 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
+ 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
+ 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
+ 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
+ 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
+ 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
+ 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
+ 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
+ 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
+ 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
+ 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
+ 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
+ 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
+ );
+@E2A = (
+ 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
+ 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
+ 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
+ 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
+ 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
+ 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
+ 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
+ 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
+ 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
+ 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
+ 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
+ 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
+ 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
+ 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
+ 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
+ );
+
+if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
+ $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
+ $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
+ $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
+ $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
+ $A2E[249] = 192;
+
+ $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
+ $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
+ $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
+ $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
+ $E2A[255] = 126;
+ }
+elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
+ $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
+ $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
+
+ $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
+ $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
+}
+
+# Smart rearrangement of parameters to allow named parameter
+# calling. We do the rearrangement if:
+# the first parameter begins with a -
+
+sub rearrange {
+ my ($order,@param) = @_;
+ my ($result, $leftover) = _rearrange_params( $order, @param );
+ push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
+ if keys %$leftover;
+ @$result;
+}
+
+sub rearrange_header {
+ my ($order,@param) = @_;
+
+ my ($result,$leftover) = _rearrange_params( $order, @param );
+ push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
+
+ @$result;
+}
+
+sub _rearrange_params {
+ my($order,@param) = @_;
+ return [] unless @param;
+
+ if (ref($param[0]) eq 'HASH') {
+ @param = %{$param[0]};
+ } else {
+ return \@param
+ unless (defined($param[0]) && substr($param[0],0,1) eq '-');
+ }
+
+ # map parameters into positional indices
+ my ($i,%pos);
+ $i = 0;
+ foreach (@$order) {
+ foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
+ $i++;
+ }
+
+ my (@result,%leftover);
+ $#result = $#$order; # preextend
+ while (@param) {
+ my $key = lc(shift(@param));
+ $key =~ s/^\-//;
+ if (exists $pos{$key}) {
+ $result[$pos{$key}] = shift(@param);
+ } else {
+ $leftover{$key} = shift(@param);
+ }
+ }
+
+ return \@result, \%leftover;
+}
+
+sub make_attributes {
+ my $attr = shift;
+ return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
+ my $escape = shift || 0;
+ my $do_not_quote = shift;
+
+ my $quote = $do_not_quote ? '' : '"';
+
+ my(@att);
+ foreach (keys %{$attr}) {
+ my($key) = $_;
+ $key=~s/^\-//; # get rid of initial - if present
+
+ # old way: breaks EBCDIC!
+ # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
+
+ ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
+
+ my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
+ push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
+ }
+ return @att;
+}
+
+sub simple_escape {
+ return unless defined(my $toencode = shift);
+ $toencode =~ s{&}{&amp;}gso;
+ $toencode =~ s{<}{&lt;}gso;
+ $toencode =~ s{>}{&gt;}gso;
+ $toencode =~ s{\"}{&quot;}gso;
+# Doesn't work. Can't work. forget it.
+# $toencode =~ s{\x8b}{&#139;}gso;
+# $toencode =~ s{\x9b}{&#155;}gso;
+ $toencode;
+}
+
+sub utf8_chr {
+ my $c = shift(@_);
+ if ($] >= 5.006){
+ require utf8;
+ my $u = chr($c);
+ utf8::encode($u); # drop utf8 flag
+ return $u;
+ }
+ if ($c < 0x80) {
+ return sprintf("%c", $c);
+ } elsif ($c < 0x800) {
+ return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
+ } elsif ($c < 0x10000) {
+ return sprintf("%c%c%c",
+ 0xe0 | ($c >> 12),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+ } elsif ($c < 0x200000) {
+ return sprintf("%c%c%c%c",
+ 0xf0 | ($c >> 18),
+ 0x80 | (($c >> 12) & 0x3f),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+ } elsif ($c < 0x4000000) {
+ return sprintf("%c%c%c%c%c",
+ 0xf8 | ($c >> 24),
+ 0x80 | (($c >> 18) & 0x3f),
+ 0x80 | (($c >> 12) & 0x3f),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+
+ } elsif ($c < 0x80000000) {
+ return sprintf("%c%c%c%c%c%c",
+ 0xfc | ($c >> 30),
+ 0x80 | (($c >> 24) & 0x3f),
+ 0x80 | (($c >> 18) & 0x3f),
+ 0x80 | (($c >> 12) & 0x3f),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+ } else {
+ return utf8_chr(0xfffd);
+ }
+}
+
+# unescape URL-encoded data
+sub unescape {
+ shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
+ my $todecode = shift;
+ return undef unless defined($todecode);
+ $todecode =~ tr/+/ /; # pluses become spaces
+ if ($EBCDIC) {
+ $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
+ } else {
+ # handle surrogate pairs first -- dankogai
+ $todecode =~ s{
+ %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
+ %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
+ }{
+ utf8_chr(
+ 0x10000
+ + (hex($1) - 0xD800) * 0x400
+ + (hex($2) - 0xDC00)
+ )
+ }gex;
+ $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
+ defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
+ }
+ return $todecode;
+}
+
+# URL-encode data
+#
+# We cannot use the %u escapes, they were rejected by W3C, so the official
+# way is %XX-escaped utf-8 encoding.
+# Naturally, Unicode strings have to be converted to their utf-8 byte
+# representation. (No action is required on 5.6.)
+# Byte strings were traditionally used directly as a sequence of octets.
+# This worked if they actually represented binary data (i.e. in CGI::Compress).
+# This also worked if these byte strings were actually utf-8 encoded; e.g.,
+# when the source file used utf-8 without the apropriate "use utf8;".
+# This fails if the byte string is actually a Latin 1 encoded string, but it
+# was always so and cannot be fixed without breaking the binary data case.
+# -- Stepan Kasal <skasal@redhat.com>
+#
+sub escape {
+ shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
+ my $toencode = shift;
+ return undef unless defined($toencode);
+ utf8::encode($toencode) if ($] > 5.008001 && utf8::is_utf8($toencode));
+ if ($EBCDIC) {
+ $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
+ } else {
+ $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
+ }
+ return $toencode;
+}
+
+# This internal routine creates date strings suitable for use in
+# cookies and HTTP headers. (They differ, unfortunately.)
+# Thanks to Mark Fisher for this.
+sub expires {
+ my($time,$format) = @_;
+ $format ||= 'http';
+
+ my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+ my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
+
+ # pass through preformatted dates for the sake of expire_calc()
+ $time = expire_calc($time);
+ return $time unless $time =~ /^\d+$/;
+
+ # make HTTP/cookie date string from GMT'ed time
+ # (cookies use '-' as date separator, HTTP uses ' ')
+ my($sc) = ' ';
+ $sc = '-' if $format eq "cookie";
+ my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
+ $year += 1900;
+ return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
+ $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+}
+
+# This internal routine creates an expires time exactly some number of
+# hours from the current time. It incorporates modifications from
+# Mark Fisher.
+sub expire_calc {
+ my($time) = @_;
+ my(%mult) = ('s'=>1,
+ 'm'=>60,
+ 'h'=>60*60,
+ 'd'=>60*60*24,
+ 'M'=>60*60*24*30,
+ 'y'=>60*60*24*365);
+ # format for time can be in any of the forms...
+ # "now" -- expire immediately
+ # "+180s" -- in 180 seconds
+ # "+2m" -- in 2 minutes
+ # "+12h" -- in 12 hours
+ # "+1d" -- in 1 day
+ # "+3M" -- in 3 months
+ # "+2y" -- in 2 years
+ # "-3m" -- 3 minutes ago(!)
+ # If you don't supply one of these forms, we assume you are
+ # specifying the date yourself
+ my($offset);
+ if (!$time || (lc($time) eq 'now')) {
+ $offset = 0;
+ } elsif ($time=~/^\d+/) {
+ return $time;
+ } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
+ $offset = ($mult{$2} || 1)*$1;
+ } else {
+ return $time;
+ }
+ return (time+$offset);
+}
+
+sub ebcdic2ascii {
+ my $data = shift;
+ $data =~ s/(.)/chr $E2A[ord($1)]/ge;
+ $data;
+}
+
+sub ascii2ebcdic {
+ my $data = shift;
+ $data =~ s/(.)/chr $A2E[ord($1)]/ge;
+ $data;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Util - Internal utilities used by CGI module
+
+=head1 SYNOPSIS
+
+none
+
+=head1 DESCRIPTION
+
+no public subroutines
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org. When sending
+bug reports, please provide the version of CGI.pm, the version of
+Perl, the name and version of your Web server, and the name and
+version of the operating system you are using. If the problem is even
+remotely browser dependent, please provide information about the
+affected browers as well.
+
+=head1 SEE ALSO
+
+L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE.pod b/Master/tlpkg/tlperl.straw/lib/CORE.pod
new file mode 100755
index 00000000000..c917bba44a0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/CORE/EXTERN.h b/Master/tlpkg/tlperl.straw/lib/CORE/EXTERN.h
new file mode 100755
index 00000000000..58ca37a47ff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/EXTERN.h
@@ -0,0 +1,61 @@
+/* EXTERN.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * EXT designates a global var which is defined in perl.h
+ * dEXT designates a global var which is defined in another
+ * file, so we can't count on finding it in perl.h
+ * (this practice should be avoided).
+ */
+#undef EXT
+#undef dEXT
+#undef EXTCONST
+#undef dEXTCONST
+#if defined(VMS) && !defined(__GNUC__)
+ /* Suppress portability warnings from DECC for VMS-specific extensions */
+# ifdef __DECC
+# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT)
+# endif
+# define EXT globalref
+# define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare
+# define EXTCONST globalref
+# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
+#else
+# if (defined(WIN32) || defined(__SYMBIAN32__)) && !defined(PERL_STATIC_SYMS)
+# if defined(PERLDLL) || defined(__SYMBIAN32__)
+# define EXT extern __declspec(dllexport)
+# define dEXT
+# define EXTCONST extern __declspec(dllexport) const
+# define dEXTCONST const
+# else
+# define EXT extern __declspec(dllimport)
+# define dEXT
+# define EXTCONST extern __declspec(dllimport) const
+# define dEXTCONST const
+# endif
+# else
+# if defined(__CYGWIN__) && defined(USEIMPORTLIB)
+# define EXT extern __declspec(dllimport)
+# define dEXT
+# define EXTCONST extern __declspec(dllimport) const
+# define dEXTCONST const
+# else
+# define EXT extern
+# define dEXT
+# define EXTCONST extern const
+# define dEXTCONST const
+# endif
+# endif
+#endif
+
+#undef INIT
+#define INIT(x)
+
+#undef DOINIT
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/INTERN.h b/Master/tlpkg/tlperl.straw/lib/CORE/INTERN.h
new file mode 100755
index 00000000000..da3057a83c6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/INTERN.h
@@ -0,0 +1,54 @@
+/* INTERN.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1995, 1996, 1998, 2000, 2001,
+ * by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * EXT designates a global var which is defined in perl.h
+ * dEXT designates a global var which is defined in another
+ * file, so we can't count on finding it in perl.h
+ * (this practice should be avoided).
+ */
+#undef EXT
+#undef dEXT
+#undef EXTCONST
+#undef dEXTCONST
+#if defined(VMS) && !defined(__GNUC__)
+ /* Suppress portability warnings from DECC for VMS-specific extensions */
+# ifdef __DECC
+# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT)
+# endif
+# define EXT globaldef {"$GLOBAL_RW_VARS"} noshare
+# define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare
+# define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
+# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
+#else
+# if (defined(WIN32) && defined(__MINGW32__)) || defined(__SYMBIAN32__)
+# define EXT __declspec(dllexport)
+# define dEXT
+# define EXTCONST __declspec(dllexport) const
+# define dEXTCONST const
+# else
+# ifdef __cplusplus
+# define EXT
+# define dEXT
+# define EXTCONST extern const
+# define dEXTCONST const
+# else
+# define EXT
+# define dEXT
+# define EXTCONST const
+# define dEXTCONST const
+# endif
+# endif
+#endif
+
+#undef INIT
+#define INIT(x) = x
+
+#define DOINIT
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/XSUB.h b/Master/tlpkg/tlperl.straw/lib/CORE/XSUB.h
new file mode 100755
index 00000000000..5334cfc4f27
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/XSUB.h
@@ -0,0 +1,649 @@
+/* XSUB.h
+ *
+ * Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+ * 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifndef _INC_PERL_XSUB_H
+#define _INC_PERL_XSUB_H 1
+
+/* first, some documentation for xsubpp-generated items */
+
+/*
+=head1 Variables created by C<xsubpp> and C<xsubpp> internal functions
+
+=for apidoc Amn|char*|CLASS
+Variable which is setup by C<xsubpp> to indicate the
+class name for a C++ XS constructor. This is always a C<char*>. See C<THIS>.
+
+=for apidoc Amn|(whatever)|RETVAL
+Variable which is setup by C<xsubpp> to hold the return value for an
+XSUB. This is always the proper type for the XSUB. See
+L<perlxs/"The RETVAL Variable">.
+
+=for apidoc Amn|(whatever)|THIS
+Variable which is setup by C<xsubpp> to designate the object in a C++
+XSUB. This is always the proper type for the C++ object. See C<CLASS> and
+L<perlxs/"Using XS With C++">.
+
+=for apidoc Amn|I32|ax
+Variable which is setup by C<xsubpp> to indicate the stack base offset,
+used by the C<ST>, C<XSprePUSH> and C<XSRETURN> macros. The C<dMARK> macro
+must be called prior to setup the C<MARK> variable.
+
+=for apidoc Amn|I32|items
+Variable which is setup by C<xsubpp> to indicate the number of
+items on the stack. See L<perlxs/"Variable-length Parameter Lists">.
+
+=for apidoc Amn|I32|ix
+Variable which is setup by C<xsubpp> to indicate which of an
+XSUB's aliases was used to invoke it. See L<perlxs/"The ALIAS: Keyword">.
+
+=for apidoc Am|SV*|ST|int ix
+Used to access elements on the XSUB's stack.
+
+=for apidoc AmU||XS
+Macro to declare an XSUB and its C parameter list. This is handled by
+C<xsubpp>.
+
+=for apidoc Ams||dAX
+Sets up the C<ax> variable.
+This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
+
+=for apidoc Ams||dAXMARK
+Sets up the C<ax> variable and stack marker variable C<mark>.
+This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
+
+=for apidoc Ams||dITEMS
+Sets up the C<items> variable.
+This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
+
+=for apidoc Ams||dXSARGS
+Sets up stack and mark pointers for an XSUB, calling dSP and dMARK.
+Sets up the C<ax> and C<items> variables by calling C<dAX> and C<dITEMS>.
+This is usually handled automatically by C<xsubpp>.
+
+=for apidoc Ams||dXSI32
+Sets up the C<ix> variable for an XSUB which has aliases. This is usually
+handled automatically by C<xsubpp>.
+
+=for apidoc Ams||dUNDERBAR
+Sets up the C<padoff_du> variable for an XSUB that wishes to use
+C<UNDERBAR>.
+
+=for apidoc AmU||UNDERBAR
+The SV* corresponding to the $_ variable. Works even if there
+is a lexical $_ in scope.
+
+=cut
+*/
+
+#ifndef PERL_UNUSED_ARG
+# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
+# include <note.h>
+# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
+# else
+# define PERL_UNUSED_ARG(x) ((void)x)
+# endif
+#endif
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(x) ((void)x)
+#endif
+
+#define ST(off) PL_stack_base[ax + (off)]
+
+/* XSPROTO() is also used by SWIG like this:
+ *
+ * typedef XSPROTO(SwigPerlWrapper);
+ * typedef SwigPerlWrapper *SwigPerlWrapperPtr;
+ *
+ * This code needs to be compilable under both C and C++.
+ *
+ * Don't forget to change the __attribute__unused__ version of XS()
+ * below too if you change XSPROTO() here.
+ */
+#define XSPROTO(name) void name(pTHX_ CV* cv)
+
+#undef XS
+#if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
+# define XS(name) __declspec(dllexport) XSPROTO(name)
+#endif
+#if defined(__SYMBIAN32__)
+# define XS(name) EXPORT_C XSPROTO(name)
+#endif
+#ifndef XS
+# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
+# define XS(name) void name(pTHX_ CV* cv __attribute__unused__)
+# else
+# ifdef __cplusplus
+# define XS(name) extern "C" XSPROTO(name)
+# else
+# define XS(name) XSPROTO(name)
+# endif
+# endif
+#endif
+
+#define dAX const I32 ax = (I32)(MARK - PL_stack_base + 1)
+
+#define dAXMARK \
+ I32 ax = POPMARK; \
+ register SV **mark = PL_stack_base + ax++
+
+#define dITEMS I32 items = (I32)(SP - MARK)
+
+#if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
+# define dXSARGS \
+ NOTE(ARGUNUSED(cv)) \
+ dSP; dAXMARK; dITEMS
+#else
+# define dXSARGS \
+ dSP; dAXMARK; dITEMS
+#endif
+
+#define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
+ ? PAD_SV(PL_op->op_targ) : sv_newmortal())
+
+/* Should be used before final PUSHi etc. if not in PPCODE section. */
+#define XSprePUSH (sp = PL_stack_base + ax - 1)
+
+#define XSANY CvXSUBANY(cv)
+
+#define dXSI32 I32 ix = XSANY.any_i32
+
+#ifdef __cplusplus
+# define XSINTERFACE_CVT(ret,name) ret (*name)(...)
+# define XSINTERFACE_CVT_ANON(ret) ret (*)(...)
+#else
+# define XSINTERFACE_CVT(ret,name) ret (*name)()
+# define XSINTERFACE_CVT_ANON(ret) ret (*)()
+#endif
+#define dXSFUNCTION(ret) XSINTERFACE_CVT(ret,XSFUNCTION)
+#define XSINTERFACE_FUNC(ret,cv,f) ((XSINTERFACE_CVT_ANON(ret))(f))
+#define XSINTERFACE_FUNC_SET(cv,f) \
+ CvXSUBANY(cv).any_dxptr = (void (*) (pTHX_ void*))(f)
+
+#define dUNDERBAR PADOFFSET padoff_du = find_rundefsvoffset()
+#define UNDERBAR ((padoff_du == NOT_IN_PAD \
+ || PAD_COMPNAME_FLAGS_isOUR(padoff_du)) \
+ ? DEFSV : PAD_SVl(padoff_du))
+
+/* Simple macros to put new mortal values onto the stack. */
+/* Typically used to return values from XS functions. */
+
+/*
+=head1 Stack Manipulation Macros
+
+=for apidoc Am|void|XST_mIV|int pos|IV iv
+Place an integer into the specified position C<pos> on the stack. The
+value is stored in a new mortal SV.
+
+=for apidoc Am|void|XST_mNV|int pos|NV nv
+Place a double into the specified position C<pos> on the stack. The value
+is stored in a new mortal SV.
+
+=for apidoc Am|void|XST_mPV|int pos|char* str
+Place a copy of a string into the specified position C<pos> on the stack.
+The value is stored in a new mortal SV.
+
+=for apidoc Am|void|XST_mNO|int pos
+Place C<&PL_sv_no> into the specified position C<pos> on the
+stack.
+
+=for apidoc Am|void|XST_mYES|int pos
+Place C<&PL_sv_yes> into the specified position C<pos> on the
+stack.
+
+=for apidoc Am|void|XST_mUNDEF|int pos
+Place C<&PL_sv_undef> into the specified position C<pos> on the
+stack.
+
+=for apidoc Am|void|XSRETURN|int nitems
+Return from XSUB, indicating number of items on the stack. This is usually
+handled by C<xsubpp>.
+
+=for apidoc Am|void|XSRETURN_IV|IV iv
+Return an integer from an XSUB immediately. Uses C<XST_mIV>.
+
+=for apidoc Am|void|XSRETURN_UV|IV uv
+Return an integer from an XSUB immediately. Uses C<XST_mUV>.
+
+=for apidoc Am|void|XSRETURN_NV|NV nv
+Return a double from an XSUB immediately. Uses C<XST_mNV>.
+
+=for apidoc Am|void|XSRETURN_PV|char* str
+Return a copy of a string from an XSUB immediately. Uses C<XST_mPV>.
+
+=for apidoc Ams||XSRETURN_NO
+Return C<&PL_sv_no> from an XSUB immediately. Uses C<XST_mNO>.
+
+=for apidoc Ams||XSRETURN_YES
+Return C<&PL_sv_yes> from an XSUB immediately. Uses C<XST_mYES>.
+
+=for apidoc Ams||XSRETURN_UNDEF
+Return C<&PL_sv_undef> from an XSUB immediately. Uses C<XST_mUNDEF>.
+
+=for apidoc Ams||XSRETURN_EMPTY
+Return an empty list from an XSUB immediately.
+
+=head1 Variables created by C<xsubpp> and C<xsubpp> internal functions
+
+=for apidoc AmU||newXSproto|char* name|XSUBADDR_t f|char* filename|const char *proto
+Used by C<xsubpp> to hook up XSUBs as Perl subs. Adds Perl prototypes to
+the subs.
+
+=for apidoc AmU||XS_VERSION
+The version identifier for an XS module. This is usually
+handled automatically by C<ExtUtils::MakeMaker>. See C<XS_VERSION_BOOTCHECK>.
+
+=for apidoc Ams||XS_VERSION_BOOTCHECK
+Macro to verify that a PM module's $VERSION variable matches the XS
+module's C<XS_VERSION> variable. This is usually handled automatically by
+C<xsubpp>. See L<perlxs/"The VERSIONCHECK: Keyword">.
+
+=head1 Simple Exception Handling Macros
+
+=for apidoc Ams||dXCPT
+Set up necessary local variables for exception handling.
+See L<perlguts/"Exception Handling">.
+
+=for apidoc AmU||XCPT_TRY_START
+Starts a try block. See L<perlguts/"Exception Handling">.
+
+=for apidoc AmU||XCPT_TRY_END
+Ends a try block. See L<perlguts/"Exception Handling">.
+
+=for apidoc AmU||XCPT_CATCH
+Introduces a catch block. See L<perlguts/"Exception Handling">.
+
+=for apidoc Ams||XCPT_RETHROW
+Rethrows a previously caught exception. See L<perlguts/"Exception Handling">.
+
+=cut
+*/
+
+#define XST_mIV(i,v) (ST(i) = sv_2mortal(newSViv(v)) )
+#define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
+#define XST_mNV(i,v) (ST(i) = sv_2mortal(newSVnv(v)) )
+#define XST_mPV(i,v) (ST(i) = sv_2mortal(newSVpv(v,0)))
+#define XST_mPVN(i,v,n) (ST(i) = newSVpvn_flags(v,n, SVs_TEMP))
+#define XST_mNO(i) (ST(i) = &PL_sv_no )
+#define XST_mYES(i) (ST(i) = &PL_sv_yes )
+#define XST_mUNDEF(i) (ST(i) = &PL_sv_undef)
+
+#define XSRETURN(off) \
+ STMT_START { \
+ const IV tmpXSoff = (off); \
+ PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); \
+ return; \
+ } STMT_END
+
+#define XSRETURN_IV(v) STMT_START { XST_mIV(0,v); XSRETURN(1); } STMT_END
+#define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
+#define XSRETURN_NV(v) STMT_START { XST_mNV(0,v); XSRETURN(1); } STMT_END
+#define XSRETURN_PV(v) STMT_START { XST_mPV(0,v); XSRETURN(1); } STMT_END
+#define XSRETURN_PVN(v,n) STMT_START { XST_mPVN(0,v,n); XSRETURN(1); } STMT_END
+#define XSRETURN_NO STMT_START { XST_mNO(0); XSRETURN(1); } STMT_END
+#define XSRETURN_YES STMT_START { XST_mYES(0); XSRETURN(1); } STMT_END
+#define XSRETURN_UNDEF STMT_START { XST_mUNDEF(0); XSRETURN(1); } STMT_END
+#define XSRETURN_EMPTY STMT_START { XSRETURN(0); } STMT_END
+
+#define newXSproto(a,b,c,d) newXS_flags(a,b,c,d,0)
+
+#ifdef XS_VERSION
+# define XS_VERSION_BOOTCHECK \
+ STMT_START { \
+ SV *_sv; \
+ const char *vn = NULL, *module = SvPV_nolen_const(ST(0)); \
+ if (items >= 2) /* version supplied as bootstrap arg */ \
+ _sv = ST(1); \
+ else { \
+ /* XXX GV_ADDWARN */ \
+ _sv = get_sv(Perl_form(aTHX_ "%s::%s", module, \
+ vn = "XS_VERSION"), FALSE); \
+ if (!_sv || !SvOK(_sv)) \
+ _sv = get_sv(Perl_form(aTHX_ "%s::%s", module, \
+ vn = "VERSION"), FALSE); \
+ } \
+ if (_sv) { \
+ SV *xssv = Perl_newSVpv(aTHX_ XS_VERSION, 0); \
+ xssv = new_version(xssv); \
+ if ( !sv_derived_from(_sv, "version") ) \
+ _sv = new_version(_sv); \
+ if ( vcmp(_sv,xssv) ) \
+ Perl_croak(aTHX_ "%s object version %"SVf" does not match %s%s%s%s %"SVf,\
+ module, SVfARG(vstringify(xssv)), \
+ vn ? "$" : "", vn ? module : "", vn ? "::" : "", \
+ vn ? vn : "bootstrap parameter", SVfARG(vstringify(_sv)));\
+ } \
+ } STMT_END
+#else
+# define XS_VERSION_BOOTCHECK
+#endif
+
+#ifdef NO_XSLOCKS
+# define dXCPT dJMPENV; int rEtV = 0
+# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
+# define XCPT_TRY_END JMPENV_POP;
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW JMPENV_JUMP(rEtV)
+#endif
+
+/*
+ The DBM_setFilter & DBM_ckFilter macros are only used by
+ the *DB*_File modules
+*/
+
+#define DBM_setFilter(db_type,code) \
+ STMT_START { \
+ if (db_type) \
+ RETVAL = sv_mortalcopy(db_type) ; \
+ ST(0) = RETVAL ; \
+ if (db_type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db_type) ; \
+ db_type = NULL ; \
+ } \
+ else if (code) { \
+ if (db_type) \
+ sv_setsv(db_type, code) ; \
+ else \
+ db_type = newSVsv(code) ; \
+ } \
+ } STMT_END
+
+#define DBM_ckFilter(arg,type,name) \
+ STMT_START { \
+ if (db->type) { \
+ if (db->filtering) { \
+ croak("recursion detected in %s", name) ; \
+ } \
+ ENTER ; \
+ SAVETMPS ; \
+ SAVEINT(db->filtering) ; \
+ db->filtering = TRUE ; \
+ SAVE_DEFSV ; \
+ if (name[7] == 's') \
+ arg = newSVsv(arg); \
+ DEFSV_set(arg) ; \
+ SvTEMP_off(arg) ; \
+ PUSHMARK(SP) ; \
+ PUTBACK ; \
+ (void) perl_call_sv(db->type, G_DISCARD); \
+ SPAGAIN ; \
+ PUTBACK ; \
+ FREETMPS ; \
+ LEAVE ; \
+ if (name[7] == 's'){ \
+ arg = sv_2mortal(arg); \
+ } \
+ } } STMT_END
+
+#if 1 /* for compatibility */
+# define VTBL_sv &PL_vtbl_sv
+# define VTBL_env &PL_vtbl_env
+# define VTBL_envelem &PL_vtbl_envelem
+# define VTBL_sig &PL_vtbl_sig
+# define VTBL_sigelem &PL_vtbl_sigelem
+# define VTBL_pack &PL_vtbl_pack
+# define VTBL_packelem &PL_vtbl_packelem
+# define VTBL_dbline &PL_vtbl_dbline
+# define VTBL_isa &PL_vtbl_isa
+# define VTBL_isaelem &PL_vtbl_isaelem
+# define VTBL_arylen &PL_vtbl_arylen
+# define VTBL_glob &PL_vtbl_glob
+# define VTBL_mglob &PL_vtbl_mglob
+# define VTBL_nkeys &PL_vtbl_nkeys
+# define VTBL_taint &PL_vtbl_taint
+# define VTBL_substr &PL_vtbl_substr
+# define VTBL_vec &PL_vtbl_vec
+# define VTBL_pos &PL_vtbl_pos
+# define VTBL_bm &PL_vtbl_bm
+# define VTBL_fm &PL_vtbl_fm
+# define VTBL_uvar &PL_vtbl_uvar
+# define VTBL_defelem &PL_vtbl_defelem
+# define VTBL_regexp &PL_vtbl_regexp
+# define VTBL_regdata &PL_vtbl_regdata
+# define VTBL_regdatum &PL_vtbl_regdatum
+# ifdef USE_LOCALE_COLLATE
+# define VTBL_collxfrm &PL_vtbl_collxfrm
+# endif
+# define VTBL_amagic &PL_vtbl_amagic
+# define VTBL_amagicelem &PL_vtbl_amagicelem
+#endif
+
+#include "perlapi.h"
+
+#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_GET_CONTEXT) && !defined(PERL_CORE)
+# undef aTHX
+# undef aTHX_
+# define aTHX PERL_GET_THX
+# define aTHX_ aTHX,
+#endif
+
+#if defined(PERL_IMPLICIT_SYS) && !defined(PERL_CORE)
+# ifndef NO_XSLOCKS
+# if defined (NETWARE) && defined (USE_STDIO)
+# define times PerlProc_times
+# define setuid PerlProc_setuid
+# define setgid PerlProc_setgid
+# define getpid PerlProc_getpid
+# define pause PerlProc_pause
+# define exit PerlProc_exit
+# define _exit PerlProc__exit
+# else
+# undef closedir
+# undef opendir
+# undef stdin
+# undef stdout
+# undef stderr
+# undef feof
+# undef ferror
+# undef fgetpos
+# undef ioctl
+# undef getlogin
+# undef setjmp
+# undef getc
+# undef ungetc
+# undef fileno
+
+/* Following symbols were giving redefinition errors while building extensions - sgp 17th Oct 2000 */
+#ifdef NETWARE
+# undef readdir
+# undef fstat
+# undef stat
+# undef longjmp
+# undef endhostent
+# undef endnetent
+# undef endprotoent
+# undef endservent
+# undef gethostbyaddr
+# undef gethostbyname
+# undef gethostent
+# undef getnetbyaddr
+# undef getnetbyname
+# undef getnetent
+# undef getprotobyname
+# undef getprotobynumber
+# undef getprotoent
+# undef getservbyname
+# undef getservbyport
+# undef getservent
+# undef inet_ntoa
+# undef sethostent
+# undef setnetent
+# undef setprotoent
+# undef setservent
+#endif /* NETWARE */
+
+# undef socketpair
+
+# define mkdir PerlDir_mkdir
+# define chdir PerlDir_chdir
+# define rmdir PerlDir_rmdir
+# define closedir PerlDir_close
+# define opendir PerlDir_open
+# define readdir PerlDir_read
+# define rewinddir PerlDir_rewind
+# define seekdir PerlDir_seek
+# define telldir PerlDir_tell
+# define putenv PerlEnv_putenv
+# define getenv PerlEnv_getenv
+# define uname PerlEnv_uname
+# define stdin PerlSIO_stdin
+# define stdout PerlSIO_stdout
+# define stderr PerlSIO_stderr
+# define fopen PerlSIO_fopen
+# define fclose PerlSIO_fclose
+# define feof PerlSIO_feof
+# define ferror PerlSIO_ferror
+# define clearerr PerlSIO_clearerr
+# define getc PerlSIO_getc
+# define fputc PerlSIO_fputc
+# define fputs PerlSIO_fputs
+# define fflush PerlSIO_fflush
+# define ungetc PerlSIO_ungetc
+# define fileno PerlSIO_fileno
+# define fdopen PerlSIO_fdopen
+# define freopen PerlSIO_freopen
+# define fread PerlSIO_fread
+# define fwrite PerlSIO_fwrite
+# define setbuf PerlSIO_setbuf
+# define setvbuf PerlSIO_setvbuf
+# define setlinebuf PerlSIO_setlinebuf
+# define stdoutf PerlSIO_stdoutf
+# define vfprintf PerlSIO_vprintf
+# define ftell PerlSIO_ftell
+# define fseek PerlSIO_fseek
+# define fgetpos PerlSIO_fgetpos
+# define fsetpos PerlSIO_fsetpos
+# define frewind PerlSIO_rewind
+# define tmpfile PerlSIO_tmpfile
+# define access PerlLIO_access
+# define chmod PerlLIO_chmod
+# define chsize PerlLIO_chsize
+# define close PerlLIO_close
+# define dup PerlLIO_dup
+# define dup2 PerlLIO_dup2
+# define flock PerlLIO_flock
+# define fstat PerlLIO_fstat
+# define ioctl PerlLIO_ioctl
+# define isatty PerlLIO_isatty
+# define link PerlLIO_link
+# define lseek PerlLIO_lseek
+# define lstat PerlLIO_lstat
+# define mktemp PerlLIO_mktemp
+# define open PerlLIO_open
+# define read PerlLIO_read
+# define rename PerlLIO_rename
+# define setmode PerlLIO_setmode
+# define stat(buf,sb) PerlLIO_stat(buf,sb)
+# define tmpnam PerlLIO_tmpnam
+# define umask PerlLIO_umask
+# define unlink PerlLIO_unlink
+# define utime PerlLIO_utime
+# define write PerlLIO_write
+# define malloc PerlMem_malloc
+# define realloc PerlMem_realloc
+# define free PerlMem_free
+# define abort PerlProc_abort
+# define exit PerlProc_exit
+# define _exit PerlProc__exit
+# define execl PerlProc_execl
+# define execv PerlProc_execv
+# define execvp PerlProc_execvp
+# define getuid PerlProc_getuid
+# define geteuid PerlProc_geteuid
+# define getgid PerlProc_getgid
+# define getegid PerlProc_getegid
+# define getlogin PerlProc_getlogin
+# define kill PerlProc_kill
+# define killpg PerlProc_killpg
+# define pause PerlProc_pause
+# define popen PerlProc_popen
+# define pclose PerlProc_pclose
+# define pipe PerlProc_pipe
+# define setuid PerlProc_setuid
+# define setgid PerlProc_setgid
+# define sleep PerlProc_sleep
+# define times PerlProc_times
+# define wait PerlProc_wait
+# define setjmp PerlProc_setjmp
+# define longjmp PerlProc_longjmp
+# define signal PerlProc_signal
+# define getpid PerlProc_getpid
+# define gettimeofday PerlProc_gettimeofday
+# define htonl PerlSock_htonl
+# define htons PerlSock_htons
+# define ntohl PerlSock_ntohl
+# define ntohs PerlSock_ntohs
+# define accept PerlSock_accept
+# define bind PerlSock_bind
+# define connect PerlSock_connect
+# define endhostent PerlSock_endhostent
+# define endnetent PerlSock_endnetent
+# define endprotoent PerlSock_endprotoent
+# define endservent PerlSock_endservent
+# define gethostbyaddr PerlSock_gethostbyaddr
+# define gethostbyname PerlSock_gethostbyname
+# define gethostent PerlSock_gethostent
+# define gethostname PerlSock_gethostname
+# define getnetbyaddr PerlSock_getnetbyaddr
+# define getnetbyname PerlSock_getnetbyname
+# define getnetent PerlSock_getnetent
+# define getpeername PerlSock_getpeername
+# define getprotobyname PerlSock_getprotobyname
+# define getprotobynumber PerlSock_getprotobynumber
+# define getprotoent PerlSock_getprotoent
+# define getservbyname PerlSock_getservbyname
+# define getservbyport PerlSock_getservbyport
+# define getservent PerlSock_getservent
+# define getsockname PerlSock_getsockname
+# define getsockopt PerlSock_getsockopt
+# define inet_addr PerlSock_inet_addr
+# define inet_ntoa PerlSock_inet_ntoa
+# define listen PerlSock_listen
+# define recv PerlSock_recv
+# define recvfrom PerlSock_recvfrom
+# define select PerlSock_select
+# define send PerlSock_send
+# define sendto PerlSock_sendto
+# define sethostent PerlSock_sethostent
+# define setnetent PerlSock_setnetent
+# define setprotoent PerlSock_setprotoent
+# define setservent PerlSock_setservent
+# define setsockopt PerlSock_setsockopt
+# define shutdown PerlSock_shutdown
+# define socket PerlSock_socket
+# define socketpair PerlSock_socketpair
+# endif /* NETWARE && USE_STDIO */
+
+# ifdef USE_SOCKETS_AS_HANDLES
+# undef fd_set
+# undef FD_SET
+# undef FD_CLR
+# undef FD_ISSET
+# undef FD_ZERO
+# define fd_set Perl_fd_set
+# define FD_SET(n,p) PERL_FD_SET(n,p)
+# define FD_CLR(n,p) PERL_FD_CLR(n,p)
+# define FD_ISSET(n,p) PERL_FD_ISSET(n,p)
+# define FD_ZERO(p) PERL_FD_ZERO(p)
+# endif /* USE_SOCKETS_AS_HANDLES */
+
+# endif /* NO_XSLOCKS */
+#endif /* PERL_IMPLICIT_SYS && !PERL_CORE */
+
+#endif /* _INC_PERL_XSUB_H */ /* include guard */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/arpa/inet.h b/Master/tlpkg/tlperl.straw/lib/CORE/arpa/inet.h
new file mode 100755
index 00000000000..0303df0876b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/arpa/inet.h
@@ -0,0 +1,4 @@
+/*
+ * this is a dummy header file for Socket.xs
+ */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/av.h b/Master/tlpkg/tlperl.straw/lib/CORE/av.h
new file mode 100755
index 00000000000..fb064b3d943
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/av.h
@@ -0,0 +1,136 @@
+/* av.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2005, 2006, 2007, 2008, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+struct xpvav {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ SSize_t xav_fill; /* Index of last element present */
+ SSize_t xav_max; /* max index for which array has space */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+};
+
+typedef struct {
+ SSize_t xav_fill; /* Index of last element present */
+ SSize_t xav_max; /* max index for which array has space */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+} xpvav_allocated;
+
+/* SV** xav_alloc; */
+#define xav_alloc xiv_u.xivu_p1
+/* SV* xav_arylen; */
+
+/* SVpav_REAL is set for all AVs whose xav_array contents are refcounted.
+ * Some things like "@_" and the scratchpad list do not set this, to
+ * indicate that they are cheating (for efficiency) by not refcounting
+ * the AV's contents.
+ *
+ * SVpav_REIFY is only meaningful on such "fake" AVs (i.e. where SVpav_REAL
+ * is not set). It indicates that the fake AV is capable of becoming
+ * real if the array needs to be modified in some way. Functions that
+ * modify fake AVs check both flags to call av_reify() as appropriate.
+ *
+ * Note that the Perl stack and @DB::args have neither flag set. (Thus,
+ * items that go on the stack are never refcounted.)
+ *
+ * These internal details are subject to change any time. AV
+ * manipulations external to perl should not care about any of this.
+ * GSAR 1999-09-10
+ */
+
+/*
+=head1 Handy Values
+
+=for apidoc AmU||Nullav
+Null AV pointer.
+
+=head1 Array Manipulation Functions
+
+=for apidoc Am|int|AvFILL|AV* av
+Same as C<av_len()>. Deprecated, use C<av_len()> instead.
+
+=cut
+*/
+
+#define Nullav Null(AV*)
+
+#define AvARRAY(av) ((av)->sv_u.svu_array)
+#define AvALLOC(av) (*((SV***)&((XPVAV*) SvANY(av))->xav_alloc))
+#define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max
+#define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill
+#define AvARYLEN(av) (*Perl_av_arylen_p(aTHX_ MUTABLE_AV(av)))
+
+#define AvREAL(av) (SvFLAGS(av) & SVpav_REAL)
+#define AvREAL_on(av) (SvFLAGS(av) |= SVpav_REAL)
+#define AvREAL_off(av) (SvFLAGS(av) &= ~SVpav_REAL)
+#define AvREAL_only(av) (AvREIFY_off(av), SvFLAGS(av) |= SVpav_REAL)
+#define AvREIFY(av) (SvFLAGS(av) & SVpav_REIFY)
+#define AvREIFY_on(av) (SvFLAGS(av) |= SVpav_REIFY)
+#define AvREIFY_off(av) (SvFLAGS(av) &= ~SVpav_REIFY)
+#define AvREIFY_only(av) (AvREAL_off(av), SvFLAGS(av) |= SVpav_REIFY)
+
+#define AvREALISH(av) (SvFLAGS(av) & (SVpav_REAL|SVpav_REIFY))
+
+#define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \
+ ? mg_size(MUTABLE_SV(av)) : AvFILLp(av))
+
+#define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
+
+/*
+=for apidoc newAV
+
+Creates a new AV. The reference count is set to 1.
+
+=cut
+*/
+
+#define newAV() MUTABLE_AV(newSV_type(SVt_PVAV))
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/cc_runtime.h b/Master/tlpkg/tlperl.straw/lib/CORE/cc_runtime.h
new file mode 100755
index 00000000000..b384fd27035
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/cc_runtime.h
@@ -0,0 +1,83 @@
+/* cc_runtime.h
+ *
+ * Copyright (C) 1999, 2000, 2001, 2004, 2006, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#define DOOP(ppname) PUTBACK; PL_op = ppname(aTHX); SPAGAIN
+#define CCPP(s) OP * s(pTHX)
+
+#define PP_LIST(g) do { \
+ dMARK; \
+ if (g != G_ARRAY) { \
+ if (++MARK <= SP) \
+ *MARK = *SP; \
+ else \
+ *MARK = &PL_sv_undef; \
+ SP = MARK; \
+ } \
+ } while (0)
+
+#define MAYBE_TAINT_SASSIGN_SRC(sv) \
+ if (PL_tainting && PL_tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || \
+ !((mg=mg_find(left, PERL_MAGIC_taint)) && mg->mg_len & 1)))\
+ TAINT_NOT
+
+#define PP_PREINC(sv) do { \
+ if (SvIOK(sv)) { \
+ ++SvIVX(sv); \
+ SvFLAGS(sv) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); \
+ } \
+ else \
+ sv_inc(sv); \
+ SvSETMAGIC(sv); \
+ } while (0)
+
+#define PP_UNSTACK do { \
+ TAINT_NOT; \
+ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; \
+ FREETMPS; \
+ oldsave = PL_scopestack[PL_scopestack_ix - 1]; \
+ LEAVE_SCOPE(oldsave); \
+ SPAGAIN; \
+ } while(0)
+
+/* Anyone using eval "" deserves this mess */
+#define PP_EVAL(ppaddr, nxt) do { \
+ dJMPENV; \
+ int ret; \
+ PUTBACK; \
+ JMPENV_PUSH(ret); \
+ switch (ret) { \
+ case 0: \
+ PL_op = ppaddr(aTHX); \
+ if (PL_op != nxt) CALLRUNOPS(aTHX); \
+ JMPENV_POP; \
+ break; \
+ case 1: JMPENV_POP; JMPENV_JUMP(1); \
+ case 2: JMPENV_POP; JMPENV_JUMP(2); \
+ case 3: \
+ JMPENV_POP; \
+ if (PL_restartop && PL_restartop != nxt) \
+ JMPENV_JUMP(3); \
+ } \
+ PL_op = nxt; \
+ SPAGAIN; \
+ } while (0)
+
+
+#define PP_ENTERTRY(jmpbuf,label) \
+ STMT_START { \
+ int ret; \
+ JMPENV_PUSH_ENV(jmpbuf,ret); \
+ switch (ret) { \
+ case 1: JMPENV_POP_ENV(jmpbuf); JMPENV_JUMP(1);\
+ case 2: JMPENV_POP_ENV(jmpbuf); JMPENV_JUMP(2);\
+ case 3: JMPENV_POP_ENV(jmpbuf); SPAGAIN; goto label;\
+ } \
+ } STMT_END
+#define PP_LEAVETRY \
+ STMT_START{ PL_top_env=PL_top_env->je_prev; }STMT_END
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/config.h b/Master/tlpkg/tlperl.straw/lib/CORE/config.h
new file mode 100755
index 00000000000..dd62bed3835
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/config.h
@@ -0,0 +1,4619 @@
+/*
+ * This file was produced by running the config_h.SH script, which
+ * gets its values from undef, which is generally produced by
+ * running Configure.
+ *
+ * Feel free to modify any of this as the need arises. Note, however,
+ * that running config_h.SH again will wipe out any changes you've made.
+ * For a more permanent change edit undef and rerun config_h.SH.
+ *
+ * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $
+ */
+
+/*
+ * Package name : perl5
+ * Source directory :
+ * Configuration time: Wed Jan 27 23:29:27 2010
+ * Configured by : 1
+ * Target system : Win32 strawberryperl 5.10.1.1 #1 1264655466 i386
+ */
+
+#ifndef _config_h_
+#define _config_h_
+
+/* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "" /**/
+
+/* HAS_ALARM:
+ * This symbol, if defined, indicates that the alarm routine is
+ * available.
+ */
+#define HAS_ALARM /**/
+
+/* HAS_BCMP:
+ * This symbol is defined if the bcmp() routine is available to
+ * compare blocks of memory.
+ */
+/*#define HAS_BCMP /**/
+
+/* HAS_BCOPY:
+ * This symbol is defined if the bcopy() routine is available to
+ * copy blocks of memory.
+ */
+/*#define HAS_BCOPY /**/
+
+/* HAS_BZERO:
+ * This symbol is defined if the bzero() routine is available to
+ * set a memory block to 0.
+ */
+/*#define HAS_BZERO /**/
+
+/* HAS_CHOWN:
+ * This symbol, if defined, indicates that the chown routine is
+ * available.
+ */
+/*#define HAS_CHOWN /**/
+
+/* HAS_CHROOT:
+ * This symbol, if defined, indicates that the chroot routine is
+ * available.
+ */
+/*#define HAS_CHROOT /**/
+
+/* HAS_CHSIZE:
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+#define HAS_CHSIZE /**/
+
+/* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+#define HAS_CRYPT /**/
+
+/* HAS_CTERMID:
+ * This symbol, if defined, indicates that the ctermid routine is
+ * available to generate filename for terminal.
+ */
+/*#define HAS_CTERMID /**/
+
+/* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+/*#define HAS_CUSERID /**/
+
+/* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+#define HAS_DBL_DIG /**/
+
+/* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+#define HAS_DIFFTIME /**/
+
+/* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+#define HAS_DLERROR /**/
+
+/* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+#define HAS_DUP2 /**/
+
+/* HAS_FCHMOD:
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+/*#define HAS_FCHMOD /**/
+
+/* HAS_FCHOWN:
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+/*#define HAS_FCHOWN /**/
+
+/* HAS_FCNTL:
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+/*#define HAS_FCNTL /**/
+
+/* HAS_FGETPOS:
+ * This symbol, if defined, indicates that the fgetpos routine is
+ * available to get the file position indicator, similar to ftell().
+ */
+#define HAS_FGETPOS /**/
+
+/* HAS_FLOCK:
+ * This symbol, if defined, indicates that the flock routine is
+ * available to do file locking.
+ */
+#define HAS_FLOCK /**/
+
+/* HAS_FORK:
+ * This symbol, if defined, indicates that the fork routine is
+ * available.
+ */
+/*#define HAS_FORK /**/
+
+/* HAS_FSETPOS:
+ * This symbol, if defined, indicates that the fsetpos routine is
+ * available to set the file position indicator, similar to fseek().
+ */
+#define HAS_FSETPOS /**/
+
+/* HAS_GETTIMEOFDAY:
+ * This symbol, if defined, indicates that the gettimeofday() system
+ * call is available for a sub-second accuracy clock. Usually, the file
+ * <sys/resource.h> needs to be included (see I_SYS_RESOURCE).
+ * The type "Timeval" should be used to refer to "struct timeval".
+ */
+#define HAS_GETTIMEOFDAY /**/
+#ifdef HAS_GETTIMEOFDAY
+#define Timeval struct timeval /* Structure used by gettimeofday() */
+#endif
+
+/* HAS_GETGROUPS:
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+/*#define HAS_GETGROUPS /**/
+
+/* HAS_GETLOGIN:
+ * This symbol, if defined, indicates that the getlogin routine is
+ * available to get the login name.
+ */
+#define HAS_GETLOGIN /**/
+
+/* HAS_GETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the getpgid(pid) function is available to get the
+ * process group id.
+ */
+/*#define HAS_GETPGID /**/
+
+/* HAS_GETPGRP2:
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+/*#define HAS_GETPGRP2 /**/
+
+/* HAS_GETPPID:
+ * This symbol, if defined, indicates that the getppid routine is
+ * available to get the parent process ID.
+ */
+/*#define HAS_GETPPID /**/
+
+/* HAS_GETPRIORITY:
+ * This symbol, if defined, indicates that the getpriority routine is
+ * available to get a process's priority.
+ */
+/*#define HAS_GETPRIORITY /**/
+
+/* HAS_INET_ATON:
+ * This symbol, if defined, indicates to the C program that the
+ * inet_aton() function is available to parse IP address "dotted-quad"
+ * strings.
+ */
+/*#define HAS_INET_ATON /**/
+
+/* HAS_KILLPG:
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+#define HAS_KILLPG /**/
+
+/* HAS_LINK:
+ * This symbol, if defined, indicates that the link routine is
+ * available to create hard links.
+ */
+#define HAS_LINK /**/
+
+/* HAS_LOCALECONV:
+ * This symbol, if defined, indicates that the localeconv routine is
+ * available for numeric and monetary formatting conventions.
+ */
+#define HAS_LOCALECONV /**/
+
+/* HAS_LOCKF:
+ * This symbol, if defined, indicates that the lockf routine is
+ * available to do file locking.
+ */
+/*#define HAS_LOCKF /**/
+
+/* HAS_LSTAT:
+ * This symbol, if defined, indicates that the lstat routine is
+ * available to do file stats on symbolic links.
+ */
+/*#define HAS_LSTAT /**/
+
+/* HAS_MBLEN:
+ * This symbol, if defined, indicates that the mblen routine is available
+ * to find the number of bytes in a multibye character.
+ */
+#define HAS_MBLEN /**/
+
+/* HAS_MBSTOWCS:
+ * This symbol, if defined, indicates that the mbstowcs routine is
+ * available to covert a multibyte string into a wide character string.
+ */
+#define HAS_MBSTOWCS /**/
+
+/* HAS_MBTOWC:
+ * This symbol, if defined, indicates that the mbtowc routine is available
+ * to covert a multibyte to a wide character.
+ */
+#define HAS_MBTOWC /**/
+
+/* HAS_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory.
+ */
+#define HAS_MEMCMP /**/
+
+/* HAS_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory.
+ */
+#define HAS_MEMCPY /**/
+
+/* HAS_MEMMOVE:
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to copy potentially overlapping blocks of memory. This should be used
+ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your
+ * own version.
+ */
+#define HAS_MEMMOVE /**/
+
+/* HAS_MEMSET:
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set blocks of memory.
+ */
+#define HAS_MEMSET /**/
+
+/* HAS_MKDIR:
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+#define HAS_MKDIR /**/
+
+/* HAS_MKFIFO:
+ * This symbol, if defined, indicates that the mkfifo routine is
+ * available to create FIFOs. Otherwise, mknod should be able to
+ * do it for you. However, if mkfifo is there, mknod might require
+ * super-user privileges which mkfifo will not.
+ */
+/*#define HAS_MKFIFO /**/
+
+/* HAS_MKTIME:
+ * This symbol, if defined, indicates that the mktime routine is
+ * available.
+ */
+#define HAS_MKTIME /**/
+
+/* HAS_MSYNC:
+ * This symbol, if defined, indicates that the msync system call is
+ * available to synchronize a mapped file.
+ */
+/*#define HAS_MSYNC /**/
+
+/* HAS_MUNMAP:
+ * This symbol, if defined, indicates that the munmap system call is
+ * available to unmap a region, usually mapped by mmap().
+ */
+/*#define HAS_MUNMAP /**/
+
+/* HAS_NICE:
+ * This symbol, if defined, indicates that the nice routine is
+ * available.
+ */
+/*#define HAS_NICE /**/
+
+/* HAS_PATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given filename.
+ */
+/* HAS_FPATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given open file descriptor.
+ */
+/*#define HAS_PATHCONF /**/
+/*#define HAS_FPATHCONF /**/
+
+/* HAS_PAUSE:
+ * This symbol, if defined, indicates that the pause routine is
+ * available to suspend a process until a signal is received.
+ */
+#define HAS_PAUSE /**/
+
+/* HAS_PIPE:
+ * This symbol, if defined, indicates that the pipe routine is
+ * available to create an inter-process channel.
+ */
+#define HAS_PIPE /**/
+
+/* HAS_POLL:
+ * This symbol, if defined, indicates that the poll routine is
+ * available to poll active file descriptors. Please check I_POLL and
+ * I_SYS_POLL to know which header should be included as well.
+ */
+/*#define HAS_POLL /**/
+
+/* HAS_READDIR:
+ * This symbol, if defined, indicates that the readdir routine is
+ * available to read directory entries. You may have to include
+ * <dirent.h>. See I_DIRENT.
+ */
+#define HAS_READDIR /**/
+
+/* HAS_SEEKDIR:
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#define HAS_SEEKDIR /**/
+
+/* HAS_TELLDIR:
+ * This symbol, if defined, indicates that the telldir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#define HAS_TELLDIR /**/
+
+/* HAS_REWINDDIR:
+ * This symbol, if defined, indicates that the rewinddir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#define HAS_REWINDDIR /**/
+
+/* HAS_READLINK:
+ * This symbol, if defined, indicates that the readlink routine is
+ * available to read the value of a symbolic link.
+ */
+/*#define HAS_READLINK /**/
+
+/* HAS_RENAME:
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+#define HAS_RENAME /**/
+
+/* HAS_RMDIR:
+ * This symbol, if defined, indicates that the rmdir routine is
+ * available to remove directories. Otherwise you should fork off a
+ * new process to exec /bin/rmdir.
+ */
+#define HAS_RMDIR /**/
+
+/* HAS_SELECT:
+ * This symbol, if defined, indicates that the select routine is
+ * available to select active file descriptors. If the timeout field
+ * is used, <sys/time.h> may need to be included.
+ */
+#define HAS_SELECT /**/
+
+/* HAS_SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+/*#define HAS_SETEGID /**/
+
+/* HAS_SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+/*#define HAS_SETEUID /**/
+
+/* HAS_SETGROUPS:
+ * This symbol, if defined, indicates that the setgroups() routine is
+ * available to set the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+/*#define HAS_SETGROUPS /**/
+
+/* HAS_SETLINEBUF:
+ * This symbol, if defined, indicates that the setlinebuf routine is
+ * available to change stderr or stdout from block-buffered or unbuffered
+ * to a line-buffered mode.
+ */
+/*#define HAS_SETLINEBUF /**/
+
+/* HAS_SETLOCALE:
+ * This symbol, if defined, indicates that the setlocale routine is
+ * available to handle locale-specific ctype implementations.
+ */
+#define HAS_SETLOCALE /**/
+
+/* HAS_SETPGID:
+ * This symbol, if defined, indicates that the setpgid(pid, gpid)
+ * routine is available to set process group ID.
+ */
+/*#define HAS_SETPGID /**/
+
+/* HAS_SETPGRP2:
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+/*#define HAS_SETPGRP2 /**/
+
+/* HAS_SETPRIORITY:
+ * This symbol, if defined, indicates that the setpriority routine is
+ * available to set a process's priority.
+ */
+/*#define HAS_SETPRIORITY /**/
+
+/* HAS_SETREGID:
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current
+ * process.
+ */
+/* HAS_SETRESGID:
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * process.
+ */
+/*#define HAS_SETREGID /**/
+/*#define HAS_SETRESGID /**/
+
+/* HAS_SETREUID:
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current
+ * process.
+ */
+/* HAS_SETRESUID:
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * process.
+ */
+/*#define HAS_SETREUID /**/
+/*#define HAS_SETRESUID /**/
+
+/* HAS_SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+/*#define HAS_SETRGID /**/
+
+/* HAS_SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+/*#define HAS_SETRUID /**/
+
+/* HAS_SETSID:
+ * This symbol, if defined, indicates that the setsid routine is
+ * available to set the process group ID.
+ */
+/*#define HAS_SETSID /**/
+
+/* HAS_STRCHR:
+ * This symbol is defined to indicate that the strchr()/strrchr()
+ * functions are available for string searching. If not, try the
+ * index()/rindex() pair.
+ */
+/* HAS_INDEX:
+ * This symbol is defined to indicate that the index()/rindex()
+ * functions are available for string searching.
+ */
+#define HAS_STRCHR /**/
+/*#define HAS_INDEX /**/
+
+/* HAS_STRCOLL:
+ * This symbol, if defined, indicates that the strcoll routine is
+ * available to compare strings using collating information.
+ */
+#define HAS_STRCOLL /**/
+
+/* HAS_STRTOD:
+ * This symbol, if defined, indicates that the strtod routine is
+ * available to provide better numeric string conversion than atof().
+ */
+#define HAS_STRTOD /**/
+
+/* HAS_STRTOL:
+ * This symbol, if defined, indicates that the strtol routine is available
+ * to provide better numeric string conversion than atoi() and friends.
+ */
+#define HAS_STRTOL /**/
+
+/* HAS_STRXFRM:
+ * This symbol, if defined, indicates that the strxfrm() routine is
+ * available to transform strings.
+ */
+#define HAS_STRXFRM /**/
+
+/* HAS_SYMLINK:
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+/*#define HAS_SYMLINK /**/
+
+/* HAS_SYSCALL:
+ * This symbol, if defined, indicates that the syscall routine is
+ * available to call arbitrary system calls. If undefined, that's tough.
+ */
+/*#define HAS_SYSCALL /**/
+
+/* HAS_SYSCONF:
+ * This symbol, if defined, indicates that sysconf() is available
+ * to determine system related limits and options.
+ */
+/*#define HAS_SYSCONF /**/
+
+/* HAS_SYSTEM:
+ * This symbol, if defined, indicates that the system routine is
+ * available to issue a shell command.
+ */
+#define HAS_SYSTEM /**/
+
+/* HAS_TCGETPGRP:
+ * This symbol, if defined, indicates that the tcgetpgrp routine is
+ * available to get foreground process group ID.
+ */
+/*#define HAS_TCGETPGRP /**/
+
+/* HAS_TCSETPGRP:
+ * This symbol, if defined, indicates that the tcsetpgrp routine is
+ * available to set foreground process group ID.
+ */
+/*#define HAS_TCSETPGRP /**/
+
+/* HAS_TRUNCATE:
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+/*#define HAS_TRUNCATE /**/
+
+/* HAS_TZNAME:
+ * This symbol, if defined, indicates that the tzname[] array is
+ * available to access timezone names.
+ */
+#define HAS_TZNAME /**/
+
+/* HAS_UMASK:
+ * This symbol, if defined, indicates that the umask routine is
+ * available to set and get the value of the file creation mask.
+ */
+#define HAS_UMASK /**/
+
+/* HAS_USLEEP:
+ * This symbol, if defined, indicates that the usleep routine is
+ * available to let the process sleep on a sub-second accuracy.
+ */
+/*#define HAS_USLEEP /**/
+
+/* HAS_WAIT4:
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+/*#define HAS_WAIT4 /**/
+
+/* HAS_WAITPID:
+ * This symbol, if defined, indicates that the waitpid routine is
+ * available to wait for child process.
+ */
+#define HAS_WAITPID /**/
+
+/* HAS_WCSTOMBS:
+ * This symbol, if defined, indicates that the wcstombs routine is
+ * available to convert wide character strings to multibyte strings.
+ */
+#define HAS_WCSTOMBS /**/
+
+/* HAS_WCTOMB:
+ * This symbol, if defined, indicates that the wctomb routine is available
+ * to covert a wide character to a multibyte.
+ */
+#define HAS_WCTOMB /**/
+
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * getgroups() and setgroups(). Usually, this is the same as
+ * gidtype (gid_t) , but sometimes it isn't.
+ * It can be int, ushort, gid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
+ * typedef'ed information. This is only required if you have
+ * getgroups() or setgroups()..
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */
+#endif
+
+/* I_ARPA_INET:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <arpa/inet.h> to get inet_addr and friends declarations.
+ */
+#define I_ARPA_INET /**/
+
+/* I_DBM:
+ * This symbol, if defined, indicates that <dbm.h> exists and should
+ * be included.
+ */
+/* I_RPCSVC_DBM:
+ * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
+ * should be included.
+ */
+/*#define I_DBM /**/
+#define I_RPCSVC_DBM /**/
+
+/* I_DLFCN:
+ * This symbol, if defined, indicates that <dlfcn.h> exists and should
+ * be included.
+ */
+#define I_DLFCN /**/
+
+/* I_FCNTL:
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+#define I_FCNTL /**/
+
+/* I_FLOAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <float.h> to get definition of symbols like DBL_MAX or
+ * DBL_MIN, i.e. machine dependent floating point values.
+ */
+#define I_FLOAT /**/
+
+/* I_GDBM:
+ * This symbol, if defined, indicates that <gdbm.h> exists and should
+ * be included.
+ */
+#define I_GDBM /**/
+
+/* I_LIMITS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <limits.h> to get definition of symbols like WORD_BIT or
+ * LONG_MAX, i.e. machine dependant limitations.
+ */
+#define I_LIMITS /**/
+
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#define I_LOCALE /**/
+
+/* I_MATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <math.h>.
+ */
+#define I_MATH /**/
+
+/* I_MEMORY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <memory.h>.
+ */
+/*#define I_MEMORY /**/
+
+/* I_NETINET_IN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/in.h>. Otherwise, you may try <sys/in.h>.
+ */
+/*#define I_NETINET_IN /**/
+
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+/*#define I_SFIO /**/
+
+/* I_STDDEF:
+ * This symbol, if defined, indicates that <stddef.h> exists and should
+ * be included.
+ */
+#define I_STDDEF /**/
+
+/* I_STDLIB:
+ * This symbol, if defined, indicates that <stdlib.h> exists and should
+ * be included.
+ */
+#define I_STDLIB /**/
+
+/* I_STRING:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <string.h> (USG systems) instead of <strings.h> (BSD systems).
+ */
+#define I_STRING /**/
+
+/* I_SYS_DIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/dir.h>.
+ */
+/*#define I_SYS_DIR /**/
+
+/* I_SYS_FILE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/file.h> to get definition of R_OK and friends.
+ */
+/*#define I_SYS_FILE /**/
+
+/* I_SYS_IOCTL:
+ * This symbol, if defined, indicates that <sys/ioctl.h> exists and should
+ * be included. Otherwise, include <sgtty.h> or <termio.h>.
+ */
+/* I_SYS_SOCKIO:
+ * This symbol, if defined, indicates the <sys/sockio.h> should be included
+ * to get socket ioctl options, like SIOCATMARK.
+ */
+/*#define I_SYS_IOCTL /**/
+/*#define I_SYS_SOCKIO /**/
+
+/* I_SYS_NDIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/ndir.h>.
+ */
+/*#define I_SYS_NDIR /**/
+
+/* I_SYS_PARAM:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/param.h>.
+ */
+/*#define I_SYS_PARAM /**/
+
+/* I_SYS_POLL:
+ * This symbol, if defined, indicates that the program may include
+ * <sys/poll.h>. When I_POLL is also defined, it's probably safest
+ * to only include <poll.h>.
+ */
+/*#define I_SYS_POLL /**/
+
+/* I_SYS_RESOURCE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/resource.h>.
+ */
+/*#define I_SYS_RESOURCE /**/
+
+/* I_SYS_SELECT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/select.h> in order to get definition of struct timeval.
+ */
+/*#define I_SYS_SELECT /**/
+
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+/* I_SYS_TIMES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/times.h>.
+ */
+/*#define I_SYS_TIMES /**/
+
+/* I_SYS_TYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/types.h>.
+ */
+#define I_SYS_TYPES /**/
+
+/* I_SYS_UN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/un.h> to get UNIX domain socket definitions.
+ */
+/*#define I_SYS_UN /**/
+
+/* I_SYS_WAIT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/wait.h>.
+ */
+/*#define I_SYS_WAIT /**/
+
+/* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+/* I_TERMIOS:
+ * This symbol, if defined, indicates that the program should include
+ * the POSIX termios.h rather than sgtty.h or termio.h.
+ * There are also differences in the ioctl() calls that depend on the
+ * value of this symbol.
+ */
+/* I_SGTTY:
+ * This symbol, if defined, indicates that the program should include
+ * <sgtty.h> rather than <termio.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+/*#define I_TERMIO /**/
+/*#define I_TERMIOS /**/
+/*#define I_SGTTY /**/
+
+/* I_UNISTD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <unistd.h>.
+ */
+/*#define I_UNISTD /**/
+
+/* I_UTIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <utime.h>.
+ */
+#define I_UTIME /**/
+
+/* I_VALUES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <values.h> to get definition of symbols like MINFLOAT or
+ * MAXLONG, i.e. machine dependant limitations. Probably, you
+ * should use <limits.h> instead, if it is available.
+ */
+/*#define I_VALUES /**/
+
+/* I_VFORK:
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+/*#define I_VFORK /**/
+
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+#define LONGSIZE 4 /**/
+#define SHORTSIZE 2 /**/
+
+/* MULTIARCH:
+ * This symbol, if defined, signifies that the build
+ * process will produce some binary files that are going to be
+ * used in a cross-platform environment. This is the case for
+ * example with the NeXT "fat" binaries that contain executables
+ * for several CPUs.
+ */
+/*#define MULTIARCH /**/
+
+/* HAS_QUAD:
+ * This symbol, if defined, tells that there's a 64-bit integer type,
+ * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one
+ * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T.
+ */
+#define HAS_QUAD /**/
+#ifdef HAS_QUAD
+# define Quad_t long long /**/
+# define Uquad_t unsigned long long /**/
+# define QUADKIND 3 /**/
+# define QUAD_IS_INT 1
+# define QUAD_IS_LONG 2
+# define QUAD_IS_LONG_LONG 3
+# define QUAD_IS_INT64_T 4
+#endif
+
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+/* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+#define OSNAME "MSWin32" /**/
+#define OSVERS "5.1" /**/
+
+/* ARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user wants to put architecture-dependent public
+ * library files for perl5. It is most often a local directory
+ * such as /usr/local/lib. Programs using this variable must be
+ * prepared to deal with filename expansion. If ARCHLIB is the
+ * same as PRIVLIB, it is not defined, since presumably the
+ * program already searches PRIVLIB.
+ */
+/* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define ARCHLIB "C:\\strawberry\\perl\\lib" /**/
+/*#define ARCHLIB_EXP "" /**/
+
+/* ARCHNAME:
+ * This symbol holds a string representing the architecture name.
+ * It may be used to construct an architecture-dependant pathname
+ * where library files may be held under a private library, for
+ * instance.
+ */
+#define ARCHNAME "MSWin32-x86-multi-thread" /**/
+
+/* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+/* BIN_EXP:
+ * This symbol is the filename expanded version of the BIN symbol, for
+ * programs that do not want to deal with that at run-time.
+ */
+/* PERL_RELOCATABLE_INC:
+ * This symbol, if defined, indicates that we'd like to relocate entries
+ * in @INC at run time based on the location of the perl binary.
+ */
+#define BIN "C:\\strawberry\\perl\\bin" /**/
+#define BIN_EXP "C:\\strawberry\\perl\\bin" /**/
+#define PERL_RELOCATABLE_INC "undef" /**/
+
+/* CAT2:
+ * This macro concatenates 2 tokens together.
+ */
+/* STRINGIFY:
+ * This macro surrounds its token with double quotes.
+ */
+#if 42 == 1
+#define CAT2(a,b) a/**/b
+#define STRINGIFY(a) "a"
+#endif
+#if 42 == 42
+#define PeRl_CaTiFy(a, b) a ## b
+#define PeRl_StGiFy(a) #a
+#define CAT2(a,b) PeRl_CaTiFy(a,b)
+#define StGiFy(a) PeRl_StGiFy(a)
+#define STRINGIFY(a) PeRl_StGiFy(a)
+#endif
+#if 42 != 1 && 42 != 42
+#include "Bletch: How does this C preprocessor concatenate tokens?"
+#endif
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+/* CPPRUN:
+ * This symbol contains the string which will invoke a C preprocessor on
+ * the standard input and produce to standard output. It needs to end
+ * with CPPLAST, after all other preprocessor flags have been specified.
+ * The main difference with CPPSTDIN is that this program will never be a
+ * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is
+ * available directly to the user. Note that it may well be different from
+ * the preprocessor used to compile the C program.
+ */
+/* CPPLAST:
+ * This symbol is intended to be used along with CPPRUN in the same manner
+ * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
+ */
+#define CPPSTDIN "gcc -E"
+#define CPPMINUS "-"
+#define CPPRUN "gcc -E"
+#define CPPLAST ""
+
+/* HAS_ACCESS:
+ * This manifest constant lets the C program know that the access()
+ * system call is available to check for accessibility using real UID/GID.
+ * (always present on UNIX.)
+ */
+#define HAS_ACCESS /**/
+
+/* HAS_ACCESSX:
+ * This symbol, if defined, indicates that the accessx routine is
+ * available to do extended access checks.
+ */
+/*#define HAS_ACCESSX /**/
+
+/* HAS_ASCTIME_R:
+ * This symbol, if defined, indicates that the asctime_r routine
+ * is available to asctime re-entrantly.
+ */
+/* ASCTIME_R_PROTO:
+ * This symbol encodes the prototype of asctime_r.
+ * It is zero if d_asctime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r
+ * is defined.
+ */
+/*#define HAS_ASCTIME_R /**/
+#define ASCTIME_R_PROTO 0 /**/
+
+/* HASATTRIBUTE_FORMAT:
+ * Can we handle GCC attribute for checking printf-style formats
+ */
+/* PRINTF_FORMAT_NULL_OK:
+ * Allows __printf__ format to be null when checking printf-style
+ */
+/* HASATTRIBUTE_MALLOC:
+ * Can we handle GCC attribute for malloc-style functions.
+ */
+/* HASATTRIBUTE_NONNULL:
+ * Can we handle GCC attribute for nonnull function parms.
+ */
+/* HASATTRIBUTE_NORETURN:
+ * Can we handle GCC attribute for functions that do not return
+ */
+/* HASATTRIBUTE_PURE:
+ * Can we handle GCC attribute for pure functions
+ */
+/* HASATTRIBUTE_UNUSED:
+ * Can we handle GCC attribute for unused variables and arguments
+ */
+/* HASATTRIBUTE_DEPRECATED:
+ * Can we handle GCC attribute for marking deprecated APIs
+ */
+/* HASATTRIBUTE_WARN_UNUSED_RESULT:
+ * Can we handle GCC attribute for warning on unused results
+ */
+/*#define HASATTRIBUTE_DEPRECATED /**/
+/*#define HASATTRIBUTE_FORMAT /**/
+/*#define PRINTF_FORMAT_NULL_OK /**/
+/*#define HASATTRIBUTE_NORETURN /**/
+/*#define HASATTRIBUTE_MALLOC /**/
+/*#define HASATTRIBUTE_NONNULL /**/
+/*#define HASATTRIBUTE_PURE /**/
+/*#define HASATTRIBUTE_UNUSED /**/
+/*#define HASATTRIBUTE_WARN_UNUSED_RESULT /**/
+
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+#define HASCONST /**/
+#ifndef HASCONST
+#define const
+#endif
+
+/* HAS_CRYPT_R:
+ * This symbol, if defined, indicates that the crypt_r routine
+ * is available to crypt re-entrantly.
+ */
+/* CRYPT_R_PROTO:
+ * This symbol encodes the prototype of crypt_r.
+ * It is zero if d_crypt_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r
+ * is defined.
+ */
+/*#define HAS_CRYPT_R /**/
+#define CRYPT_R_PROTO 0 /**/
+
+/* HAS_CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ */
+/* CSH:
+ * This symbol, if defined, contains the full pathname of csh.
+ */
+/*#define HAS_CSH /**/
+#ifdef HAS_CSH
+#define CSH "" /**/
+#endif
+
+/* HAS_CTERMID_R:
+ * This symbol, if defined, indicates that the ctermid_r routine
+ * is available to ctermid re-entrantly.
+ */
+/* CTERMID_R_PROTO:
+ * This symbol encodes the prototype of ctermid_r.
+ * It is zero if d_ctermid_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r
+ * is defined.
+ */
+/*#define HAS_CTERMID_R /**/
+#define CTERMID_R_PROTO 0 /**/
+
+/* HAS_CTIME_R:
+ * This symbol, if defined, indicates that the ctime_r routine
+ * is available to ctime re-entrantly.
+ */
+/* CTIME_R_PROTO:
+ * This symbol encodes the prototype of ctime_r.
+ * It is zero if d_ctime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r
+ * is defined.
+ */
+/*#define HAS_CTIME_R /**/
+#define CTIME_R_PROTO 0 /**/
+
+/* HAS_DRAND48_R:
+ * This symbol, if defined, indicates that the drand48_r routine
+ * is available to drand48 re-entrantly.
+ */
+/* DRAND48_R_PROTO:
+ * This symbol encodes the prototype of drand48_r.
+ * It is zero if d_drand48_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r
+ * is defined.
+ */
+/*#define HAS_DRAND48_R /**/
+#define DRAND48_R_PROTO 0 /**/
+
+/* HAS_DRAND48_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the drand48() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern double drand48(void);
+ */
+/*#define HAS_DRAND48_PROTO /**/
+
+/* HAS_EACCESS:
+ * This symbol, if defined, indicates that the eaccess routine is
+ * available to do extended access checks.
+ */
+/*#define HAS_EACCESS /**/
+
+/* HAS_ENDGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the group database.
+ */
+/*#define HAS_ENDGRENT /**/
+
+/* HAS_ENDGRENT_R:
+ * This symbol, if defined, indicates that the endgrent_r routine
+ * is available to endgrent re-entrantly.
+ */
+/* ENDGRENT_R_PROTO:
+ * This symbol encodes the prototype of endgrent_r.
+ * It is zero if d_endgrent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r
+ * is defined.
+ */
+/*#define HAS_ENDGRENT_R /**/
+#define ENDGRENT_R_PROTO 0 /**/
+
+/* HAS_ENDHOSTENT:
+ * This symbol, if defined, indicates that the endhostent() routine is
+ * available to close whatever was being used for host queries.
+ */
+/*#define HAS_ENDHOSTENT /**/
+
+/* HAS_ENDHOSTENT_R:
+ * This symbol, if defined, indicates that the endhostent_r routine
+ * is available to endhostent re-entrantly.
+ */
+/* ENDHOSTENT_R_PROTO:
+ * This symbol encodes the prototype of endhostent_r.
+ * It is zero if d_endhostent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r
+ * is defined.
+ */
+/*#define HAS_ENDHOSTENT_R /**/
+#define ENDHOSTENT_R_PROTO 0 /**/
+
+/* HAS_ENDNETENT:
+ * This symbol, if defined, indicates that the endnetent() routine is
+ * available to close whatever was being used for network queries.
+ */
+/*#define HAS_ENDNETENT /**/
+
+/* HAS_ENDNETENT_R:
+ * This symbol, if defined, indicates that the endnetent_r routine
+ * is available to endnetent re-entrantly.
+ */
+/* ENDNETENT_R_PROTO:
+ * This symbol encodes the prototype of endnetent_r.
+ * It is zero if d_endnetent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r
+ * is defined.
+ */
+/*#define HAS_ENDNETENT_R /**/
+#define ENDNETENT_R_PROTO 0 /**/
+
+/* HAS_ENDPROTOENT:
+ * This symbol, if defined, indicates that the endprotoent() routine is
+ * available to close whatever was being used for protocol queries.
+ */
+/*#define HAS_ENDPROTOENT /**/
+
+/* HAS_ENDPROTOENT_R:
+ * This symbol, if defined, indicates that the endprotoent_r routine
+ * is available to endprotoent re-entrantly.
+ */
+/* ENDPROTOENT_R_PROTO:
+ * This symbol encodes the prototype of endprotoent_r.
+ * It is zero if d_endprotoent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r
+ * is defined.
+ */
+/*#define HAS_ENDPROTOENT_R /**/
+#define ENDPROTOENT_R_PROTO 0 /**/
+
+/* HAS_ENDPWENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the passwd database.
+ */
+/*#define HAS_ENDPWENT /**/
+
+/* HAS_ENDPWENT_R:
+ * This symbol, if defined, indicates that the endpwent_r routine
+ * is available to endpwent re-entrantly.
+ */
+/* ENDPWENT_R_PROTO:
+ * This symbol encodes the prototype of endpwent_r.
+ * It is zero if d_endpwent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r
+ * is defined.
+ */
+/*#define HAS_ENDPWENT_R /**/
+#define ENDPWENT_R_PROTO 0 /**/
+
+/* HAS_ENDSERVENT:
+ * This symbol, if defined, indicates that the endservent() routine is
+ * available to close whatever was being used for service queries.
+ */
+/*#define HAS_ENDSERVENT /**/
+
+/* HAS_ENDSERVENT_R:
+ * This symbol, if defined, indicates that the endservent_r routine
+ * is available to endservent re-entrantly.
+ */
+/* ENDSERVENT_R_PROTO:
+ * This symbol encodes the prototype of endservent_r.
+ * It is zero if d_endservent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r
+ * is defined.
+ */
+/*#define HAS_ENDSERVENT_R /**/
+#define ENDSERVENT_R_PROTO 0 /**/
+
+/* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+#define FLEXFILENAMES /**/
+
+/* HAS_GETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for sequential access of the group database.
+ */
+/*#define HAS_GETGRENT /**/
+
+/* HAS_GETGRENT_R:
+ * This symbol, if defined, indicates that the getgrent_r routine
+ * is available to getgrent re-entrantly.
+ */
+/* GETGRENT_R_PROTO:
+ * This symbol encodes the prototype of getgrent_r.
+ * It is zero if d_getgrent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r
+ * is defined.
+ */
+/*#define HAS_GETGRENT_R /**/
+#define GETGRENT_R_PROTO 0 /**/
+
+/* HAS_GETGRGID_R:
+ * This symbol, if defined, indicates that the getgrgid_r routine
+ * is available to getgrgid re-entrantly.
+ */
+/* GETGRGID_R_PROTO:
+ * This symbol encodes the prototype of getgrgid_r.
+ * It is zero if d_getgrgid_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r
+ * is defined.
+ */
+/*#define HAS_GETGRGID_R /**/
+#define GETGRGID_R_PROTO 0 /**/
+
+/* HAS_GETGRNAM_R:
+ * This symbol, if defined, indicates that the getgrnam_r routine
+ * is available to getgrnam re-entrantly.
+ */
+/* GETGRNAM_R_PROTO:
+ * This symbol encodes the prototype of getgrnam_r.
+ * It is zero if d_getgrnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r
+ * is defined.
+ */
+/*#define HAS_GETGRNAM_R /**/
+#define GETGRNAM_R_PROTO 0 /**/
+
+/* HAS_GETHOSTBYADDR:
+ * This symbol, if defined, indicates that the gethostbyaddr() routine is
+ * available to look up hosts by their IP addresses.
+ */
+#define HAS_GETHOSTBYADDR /**/
+
+/* HAS_GETHOSTBYNAME:
+ * This symbol, if defined, indicates that the gethostbyname() routine is
+ * available to look up host names in some data base or other.
+ */
+#define HAS_GETHOSTBYNAME /**/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to look up host names in some data base or another.
+ */
+/*#define HAS_GETHOSTENT /**/
+
+/* HAS_GETHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * gethostname() routine to derive the host name. See also HAS_UNAME
+ * and PHOSTNAME.
+ */
+/* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+/* PHOSTNAME:
+ * This symbol, if defined, indicates the command to feed to the
+ * popen() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and HAS_UNAME. Note that the command uses a fully qualified path,
+ * so that it is safe even if used by a process with super-user
+ * privileges.
+ */
+/* HAS_PHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * contents of PHOSTNAME as a command to feed to the popen() routine
+ * to derive the host name.
+ */
+#define HAS_GETHOSTNAME /**/
+#define HAS_UNAME /**/
+/*#define HAS_PHOSTNAME /**/
+#ifdef HAS_PHOSTNAME
+#define PHOSTNAME "" /* How to get the host name */
+#endif
+
+/* HAS_GETHOSTBYADDR_R:
+ * This symbol, if defined, indicates that the gethostbyaddr_r routine
+ * is available to gethostbyaddr re-entrantly.
+ */
+/* GETHOSTBYADDR_R_PROTO:
+ * This symbol encodes the prototype of gethostbyaddr_r.
+ * It is zero if d_gethostbyaddr_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r
+ * is defined.
+ */
+/*#define HAS_GETHOSTBYADDR_R /**/
+#define GETHOSTBYADDR_R_PROTO 0 /**/
+
+/* HAS_GETHOSTBYNAME_R:
+ * This symbol, if defined, indicates that the gethostbyname_r routine
+ * is available to gethostbyname re-entrantly.
+ */
+/* GETHOSTBYNAME_R_PROTO:
+ * This symbol encodes the prototype of gethostbyname_r.
+ * It is zero if d_gethostbyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r
+ * is defined.
+ */
+/*#define HAS_GETHOSTBYNAME_R /**/
+#define GETHOSTBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETHOSTENT_R:
+ * This symbol, if defined, indicates that the gethostent_r routine
+ * is available to gethostent re-entrantly.
+ */
+/* GETHOSTENT_R_PROTO:
+ * This symbol encodes the prototype of gethostent_r.
+ * It is zero if d_gethostent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r
+ * is defined.
+ */
+/*#define HAS_GETHOSTENT_R /**/
+#define GETHOSTENT_R_PROTO 0 /**/
+
+/* HAS_GETHOST_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for gethostent(), gethostbyname(), and
+ * gethostbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#define HAS_GETHOST_PROTOS /**/
+
+/* HAS_GETLOGIN_R:
+ * This symbol, if defined, indicates that the getlogin_r routine
+ * is available to getlogin re-entrantly.
+ */
+/* GETLOGIN_R_PROTO:
+ * This symbol encodes the prototype of getlogin_r.
+ * It is zero if d_getlogin_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r
+ * is defined.
+ */
+/*#define HAS_GETLOGIN_R /**/
+#define GETLOGIN_R_PROTO 0 /**/
+
+/* HAS_GETNETBYADDR:
+ * This symbol, if defined, indicates that the getnetbyaddr() routine is
+ * available to look up networks by their IP addresses.
+ */
+/*#define HAS_GETNETBYADDR /**/
+
+/* HAS_GETNETBYNAME:
+ * This symbol, if defined, indicates that the getnetbyname() routine is
+ * available to look up networks by their names.
+ */
+/*#define HAS_GETNETBYNAME /**/
+
+/* HAS_GETNETENT:
+ * This symbol, if defined, indicates that the getnetent() routine is
+ * available to look up network names in some data base or another.
+ */
+/*#define HAS_GETNETENT /**/
+
+/* HAS_GETNETBYADDR_R:
+ * This symbol, if defined, indicates that the getnetbyaddr_r routine
+ * is available to getnetbyaddr re-entrantly.
+ */
+/* GETNETBYADDR_R_PROTO:
+ * This symbol encodes the prototype of getnetbyaddr_r.
+ * It is zero if d_getnetbyaddr_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r
+ * is defined.
+ */
+/*#define HAS_GETNETBYADDR_R /**/
+#define GETNETBYADDR_R_PROTO 0 /**/
+
+/* HAS_GETNETBYNAME_R:
+ * This symbol, if defined, indicates that the getnetbyname_r routine
+ * is available to getnetbyname re-entrantly.
+ */
+/* GETNETBYNAME_R_PROTO:
+ * This symbol encodes the prototype of getnetbyname_r.
+ * It is zero if d_getnetbyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r
+ * is defined.
+ */
+/*#define HAS_GETNETBYNAME_R /**/
+#define GETNETBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETNETENT_R:
+ * This symbol, if defined, indicates that the getnetent_r routine
+ * is available to getnetent re-entrantly.
+ */
+/* GETNETENT_R_PROTO:
+ * This symbol encodes the prototype of getnetent_r.
+ * It is zero if d_getnetent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r
+ * is defined.
+ */
+/*#define HAS_GETNETENT_R /**/
+#define GETNETENT_R_PROTO 0 /**/
+
+/* HAS_GETNET_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getnetent(), getnetbyname(), and
+ * getnetbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETNET_PROTOS /**/
+
+/* HAS_GETPROTOENT:
+ * This symbol, if defined, indicates that the getprotoent() routine is
+ * available to look up protocols in some data base or another.
+ */
+/*#define HAS_GETPROTOENT /**/
+
+/* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+/*#define HAS_GETPGRP /**/
+/*#define USE_BSD_GETPGRP /**/
+
+/* HAS_GETPROTOBYNAME:
+ * This symbol, if defined, indicates that the getprotobyname()
+ * routine is available to look up protocols by their name.
+ */
+/* HAS_GETPROTOBYNUMBER:
+ * This symbol, if defined, indicates that the getprotobynumber()
+ * routine is available to look up protocols by their number.
+ */
+#define HAS_GETPROTOBYNAME /**/
+#define HAS_GETPROTOBYNUMBER /**/
+
+/* HAS_GETPROTOBYNAME_R:
+ * This symbol, if defined, indicates that the getprotobyname_r routine
+ * is available to getprotobyname re-entrantly.
+ */
+/* GETPROTOBYNAME_R_PROTO:
+ * This symbol encodes the prototype of getprotobyname_r.
+ * It is zero if d_getprotobyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r
+ * is defined.
+ */
+/*#define HAS_GETPROTOBYNAME_R /**/
+#define GETPROTOBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETPROTOBYNUMBER_R:
+ * This symbol, if defined, indicates that the getprotobynumber_r routine
+ * is available to getprotobynumber re-entrantly.
+ */
+/* GETPROTOBYNUMBER_R_PROTO:
+ * This symbol encodes the prototype of getprotobynumber_r.
+ * It is zero if d_getprotobynumber_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r
+ * is defined.
+ */
+/*#define HAS_GETPROTOBYNUMBER_R /**/
+#define GETPROTOBYNUMBER_R_PROTO 0 /**/
+
+/* HAS_GETPROTOENT_R:
+ * This symbol, if defined, indicates that the getprotoent_r routine
+ * is available to getprotoent re-entrantly.
+ */
+/* GETPROTOENT_R_PROTO:
+ * This symbol encodes the prototype of getprotoent_r.
+ * It is zero if d_getprotoent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r
+ * is defined.
+ */
+/*#define HAS_GETPROTOENT_R /**/
+#define GETPROTOENT_R_PROTO 0 /**/
+
+/* HAS_GETPROTO_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getprotoent(), getprotobyname(), and
+ * getprotobyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#define HAS_GETPROTO_PROTOS /**/
+
+/* HAS_GETPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for sequential access of the passwd database.
+ * If this is not available, the older getpw() function may be available.
+ */
+/*#define HAS_GETPWENT /**/
+
+/* HAS_GETPWENT_R:
+ * This symbol, if defined, indicates that the getpwent_r routine
+ * is available to getpwent re-entrantly.
+ */
+/* GETPWENT_R_PROTO:
+ * This symbol encodes the prototype of getpwent_r.
+ * It is zero if d_getpwent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r
+ * is defined.
+ */
+/*#define HAS_GETPWENT_R /**/
+#define GETPWENT_R_PROTO 0 /**/
+
+/* HAS_GETPWNAM_R:
+ * This symbol, if defined, indicates that the getpwnam_r routine
+ * is available to getpwnam re-entrantly.
+ */
+/* GETPWNAM_R_PROTO:
+ * This symbol encodes the prototype of getpwnam_r.
+ * It is zero if d_getpwnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r
+ * is defined.
+ */
+/*#define HAS_GETPWNAM_R /**/
+#define GETPWNAM_R_PROTO 0 /**/
+
+/* HAS_GETPWUID_R:
+ * This symbol, if defined, indicates that the getpwuid_r routine
+ * is available to getpwuid re-entrantly.
+ */
+/* GETPWUID_R_PROTO:
+ * This symbol encodes the prototype of getpwuid_r.
+ * It is zero if d_getpwuid_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r
+ * is defined.
+ */
+/*#define HAS_GETPWUID_R /**/
+#define GETPWUID_R_PROTO 0 /**/
+
+/* HAS_GETSERVENT:
+ * This symbol, if defined, indicates that the getservent() routine is
+ * available to look up network services in some data base or another.
+ */
+/*#define HAS_GETSERVENT /**/
+
+/* HAS_GETSERVBYNAME_R:
+ * This symbol, if defined, indicates that the getservbyname_r routine
+ * is available to getservbyname re-entrantly.
+ */
+/* GETSERVBYNAME_R_PROTO:
+ * This symbol encodes the prototype of getservbyname_r.
+ * It is zero if d_getservbyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r
+ * is defined.
+ */
+/*#define HAS_GETSERVBYNAME_R /**/
+#define GETSERVBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETSERVBYPORT_R:
+ * This symbol, if defined, indicates that the getservbyport_r routine
+ * is available to getservbyport re-entrantly.
+ */
+/* GETSERVBYPORT_R_PROTO:
+ * This symbol encodes the prototype of getservbyport_r.
+ * It is zero if d_getservbyport_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r
+ * is defined.
+ */
+/*#define HAS_GETSERVBYPORT_R /**/
+#define GETSERVBYPORT_R_PROTO 0 /**/
+
+/* HAS_GETSERVENT_R:
+ * This symbol, if defined, indicates that the getservent_r routine
+ * is available to getservent re-entrantly.
+ */
+/* GETSERVENT_R_PROTO:
+ * This symbol encodes the prototype of getservent_r.
+ * It is zero if d_getservent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r
+ * is defined.
+ */
+/*#define HAS_GETSERVENT_R /**/
+#define GETSERVENT_R_PROTO 0 /**/
+
+/* HAS_GETSERV_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getservent(), getservbyname(), and
+ * getservbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#define HAS_GETSERV_PROTOS /**/
+
+/* HAS_GETSPNAM_R:
+ * This symbol, if defined, indicates that the getspnam_r routine
+ * is available to getspnam re-entrantly.
+ */
+/* GETSPNAM_R_PROTO:
+ * This symbol encodes the prototype of getspnam_r.
+ * It is zero if d_getspnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r
+ * is defined.
+ */
+/*#define HAS_GETSPNAM_R /**/
+#define GETSPNAM_R_PROTO 0 /**/
+
+/* HAS_GETSERVBYNAME:
+ * This symbol, if defined, indicates that the getservbyname()
+ * routine is available to look up services by their name.
+ */
+/* HAS_GETSERVBYPORT:
+ * This symbol, if defined, indicates that the getservbyport()
+ * routine is available to look up services by their port.
+ */
+#define HAS_GETSERVBYNAME /**/
+#define HAS_GETSERVBYPORT /**/
+
+/* HAS_GMTIME_R:
+ * This symbol, if defined, indicates that the gmtime_r routine
+ * is available to gmtime re-entrantly.
+ */
+/* GMTIME_R_PROTO:
+ * This symbol encodes the prototype of gmtime_r.
+ * It is zero if d_gmtime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r
+ * is defined.
+ */
+/*#define HAS_GMTIME_R /**/
+#define GMTIME_R_PROTO 0 /**/
+
+/* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+#define HAS_HTONL /**/
+#define HAS_HTONS /**/
+#define HAS_NTOHL /**/
+#define HAS_NTOHS /**/
+
+/* HAS_LOCALTIME_R:
+ * This symbol, if defined, indicates that the localtime_r routine
+ * is available to localtime re-entrantly.
+ */
+/* LOCALTIME_R_NEEDS_TZSET:
+ * Many libc's localtime_r implementations do not call tzset,
+ * making them differ from localtime(), and making timezone
+ * changes using \undef{TZ} without explicitly calling tzset
+ * impossible. This symbol makes us call tzset before localtime_r
+ */
+/*#define LOCALTIME_R_NEEDS_TZSET /**/
+#ifdef LOCALTIME_R_NEEDS_TZSET
+#define L_R_TZSET tzset(),
+#else
+#define L_R_TZSET
+#endif
+
+/* LOCALTIME_R_PROTO:
+ * This symbol encodes the prototype of localtime_r.
+ * It is zero if d_localtime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r
+ * is defined.
+ */
+/*#define HAS_LOCALTIME_R /**/
+#define LOCALTIME_R_PROTO 0 /**/
+
+/* HAS_LONG_DOUBLE:
+ * This symbol will be defined if the C compiler supports long
+ * doubles.
+ */
+/* LONG_DOUBLESIZE:
+ * This symbol contains the size of a long double, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long doubles.
+ */
+#define HAS_LONG_DOUBLE /**/
+#ifdef HAS_LONG_DOUBLE
+#define LONG_DOUBLESIZE 12 /**/
+#endif
+
+/* HAS_LONG_LONG:
+ * This symbol will be defined if the C compiler supports long long.
+ */
+/* LONGLONGSIZE:
+ * This symbol contains the size of a long long, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long long.
+ */
+/*#define HAS_LONG_LONG /**/
+#ifdef HAS_LONG_LONG
+#define LONGLONGSIZE 8 /**/
+#endif
+
+/* HAS_LSEEK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the lseek() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern off_t lseek(int, off_t, int);
+ */
+#define HAS_LSEEK_PROTO /**/
+
+/* HAS_MEMCHR:
+ * This symbol, if defined, indicates that the memchr routine is available
+ * to locate characters within a C string.
+ */
+#define HAS_MEMCHR /**/
+
+/* HAS_MKSTEMP:
+ * This symbol, if defined, indicates that the mkstemp routine is
+ * available to exclusively create and open a uniquely named
+ * temporary file.
+ */
+/*#define HAS_MKSTEMP /**/
+
+/* HAS_MMAP:
+ * This symbol, if defined, indicates that the mmap system call is
+ * available to map a file into memory.
+ */
+/* Mmap_t:
+ * This symbol holds the return type of the mmap() system call
+ * (and simultaneously the type of the first argument).
+ * Usually set to 'void *' or 'caddr_t'.
+ */
+/*#define HAS_MMAP /**/
+#define Mmap_t void * /**/
+
+/* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+/*#define HAS_MSG /**/
+
+/* OLD_PTHREAD_CREATE_JOINABLE:
+ * This symbol, if defined, indicates how to create pthread
+ * in joinable (aka undetached) state. NOTE: not defined
+ * if pthread.h already has defined PTHREAD_CREATE_JOINABLE
+ * (the new version of the constant).
+ * If defined, known values are PTHREAD_CREATE_UNDETACHED
+ * and __UNDETACHED.
+ */
+/*#define OLD_PTHREAD_CREATE_JOINABLE /**/
+
+/* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available to setup fork handlers.
+ */
+/*#define HAS_PTHREAD_ATFORK /**/
+
+/* HAS_PTHREAD_YIELD:
+ * This symbol, if defined, indicates that the pthread_yield
+ * routine is available to yield the execution of the current
+ * thread. sched_yield is preferable to pthread_yield.
+ */
+/* SCHED_YIELD:
+ * This symbol defines the way to yield the execution of
+ * the current thread. Known ways are sched_yield,
+ * pthread_yield, and pthread_yield with NULL.
+ */
+/* HAS_SCHED_YIELD:
+ * This symbol, if defined, indicates that the sched_yield
+ * routine is available to yield the execution of the current
+ * thread. sched_yield is preferable to pthread_yield.
+ */
+/*#define HAS_PTHREAD_YIELD /**/
+#define SCHED_YIELD /**/
+/*#define HAS_SCHED_YIELD /**/
+
+/* HAS_RANDOM_R:
+ * This symbol, if defined, indicates that the random_r routine
+ * is available to random re-entrantly.
+ */
+/* RANDOM_R_PROTO:
+ * This symbol encodes the prototype of random_r.
+ * It is zero if d_random_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r
+ * is defined.
+ */
+/*#define HAS_RANDOM_R /**/
+#define RANDOM_R_PROTO 0 /**/
+
+/* HAS_READDIR64_R:
+ * This symbol, if defined, indicates that the readdir64_r routine
+ * is available to readdir64 re-entrantly.
+ */
+/* READDIR64_R_PROTO:
+ * This symbol encodes the prototype of readdir64_r.
+ * It is zero if d_readdir64_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r
+ * is defined.
+ */
+/*#define HAS_READDIR64_R /**/
+#define READDIR64_R_PROTO 0 /**/
+
+/* HAS_READDIR_R:
+ * This symbol, if defined, indicates that the readdir_r routine
+ * is available to readdir re-entrantly.
+ */
+/* READDIR_R_PROTO:
+ * This symbol encodes the prototype of readdir_r.
+ * It is zero if d_readdir_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r
+ * is defined.
+ */
+/*#define HAS_READDIR_R /**/
+#define READDIR_R_PROTO 0 /**/
+
+/* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+/*#define HAS_SEM /**/
+
+/* HAS_SETGRENT:
+ * This symbol, if defined, indicates that the setgrent routine is
+ * available for initializing sequential access of the group database.
+ */
+/*#define HAS_SETGRENT /**/
+
+/* HAS_SETGRENT_R:
+ * This symbol, if defined, indicates that the setgrent_r routine
+ * is available to setgrent re-entrantly.
+ */
+/* SETGRENT_R_PROTO:
+ * This symbol encodes the prototype of setgrent_r.
+ * It is zero if d_setgrent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r
+ * is defined.
+ */
+/*#define HAS_SETGRENT_R /**/
+#define SETGRENT_R_PROTO 0 /**/
+
+/* HAS_SETHOSTENT:
+ * This symbol, if defined, indicates that the sethostent() routine is
+ * available.
+ */
+/*#define HAS_SETHOSTENT /**/
+
+/* HAS_SETHOSTENT_R:
+ * This symbol, if defined, indicates that the sethostent_r routine
+ * is available to sethostent re-entrantly.
+ */
+/* SETHOSTENT_R_PROTO:
+ * This symbol encodes the prototype of sethostent_r.
+ * It is zero if d_sethostent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r
+ * is defined.
+ */
+/*#define HAS_SETHOSTENT_R /**/
+#define SETHOSTENT_R_PROTO 0 /**/
+
+/* HAS_SETLOCALE_R:
+ * This symbol, if defined, indicates that the setlocale_r routine
+ * is available to setlocale re-entrantly.
+ */
+/* SETLOCALE_R_PROTO:
+ * This symbol encodes the prototype of setlocale_r.
+ * It is zero if d_setlocale_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r
+ * is defined.
+ */
+/*#define HAS_SETLOCALE_R /**/
+#define SETLOCALE_R_PROTO 0 /**/
+
+/* HAS_SETNETENT:
+ * This symbol, if defined, indicates that the setnetent() routine is
+ * available.
+ */
+/*#define HAS_SETNETENT /**/
+
+/* HAS_SETNETENT_R:
+ * This symbol, if defined, indicates that the setnetent_r routine
+ * is available to setnetent re-entrantly.
+ */
+/* SETNETENT_R_PROTO:
+ * This symbol encodes the prototype of setnetent_r.
+ * It is zero if d_setnetent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r
+ * is defined.
+ */
+/*#define HAS_SETNETENT_R /**/
+#define SETNETENT_R_PROTO 0 /**/
+
+/* HAS_SETPROTOENT:
+ * This symbol, if defined, indicates that the setprotoent() routine is
+ * available.
+ */
+/*#define HAS_SETPROTOENT /**/
+
+/* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+/*#define HAS_SETPGRP /**/
+/*#define USE_BSD_SETPGRP /**/
+
+/* HAS_SETPROTOENT_R:
+ * This symbol, if defined, indicates that the setprotoent_r routine
+ * is available to setprotoent re-entrantly.
+ */
+/* SETPROTOENT_R_PROTO:
+ * This symbol encodes the prototype of setprotoent_r.
+ * It is zero if d_setprotoent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r
+ * is defined.
+ */
+/*#define HAS_SETPROTOENT_R /**/
+#define SETPROTOENT_R_PROTO 0 /**/
+
+/* HAS_SETPWENT:
+ * This symbol, if defined, indicates that the setpwent routine is
+ * available for initializing sequential access of the passwd database.
+ */
+/*#define HAS_SETPWENT /**/
+
+/* HAS_SETPWENT_R:
+ * This symbol, if defined, indicates that the setpwent_r routine
+ * is available to setpwent re-entrantly.
+ */
+/* SETPWENT_R_PROTO:
+ * This symbol encodes the prototype of setpwent_r.
+ * It is zero if d_setpwent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r
+ * is defined.
+ */
+/*#define HAS_SETPWENT_R /**/
+#define SETPWENT_R_PROTO 0 /**/
+
+/* HAS_SETSERVENT:
+ * This symbol, if defined, indicates that the setservent() routine is
+ * available.
+ */
+/*#define HAS_SETSERVENT /**/
+
+/* HAS_SETSERVENT_R:
+ * This symbol, if defined, indicates that the setservent_r routine
+ * is available to setservent re-entrantly.
+ */
+/* SETSERVENT_R_PROTO:
+ * This symbol encodes the prototype of setservent_r.
+ * It is zero if d_setservent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r
+ * is defined.
+ */
+/*#define HAS_SETSERVENT_R /**/
+#define SETSERVENT_R_PROTO 0 /**/
+
+/* HAS_SETVBUF:
+ * This symbol, if defined, indicates that the setvbuf routine is
+ * available to change buffering on an open stdio stream.
+ * to a line-buffered mode.
+ */
+#define HAS_SETVBUF /**/
+
+/* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+/*#define HAS_SHM /**/
+
+/* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+/* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+#define Shmat_t void * /**/
+/*#define HAS_SHMAT_PROTOTYPE /**/
+
+/* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+/* HAS_MSG_CTRUNC:
+ * This symbol, if defined, indicates that the MSG_CTRUNC is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_DONTROUTE:
+ * This symbol, if defined, indicates that the MSG_DONTROUTE is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_OOB:
+ * This symbol, if defined, indicates that the MSG_OOB is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PEEK:
+ * This symbol, if defined, indicates that the MSG_PEEK is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PROXY:
+ * This symbol, if defined, indicates that the MSG_PROXY is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_SCM_RIGHTS:
+ * This symbol, if defined, indicates that the SCM_RIGHTS is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+#define HAS_SOCKET /**/
+/*#define HAS_SOCKETPAIR /**/
+/*#define HAS_MSG_CTRUNC /**/
+/*#define HAS_MSG_DONTROUTE /**/
+/*#define HAS_MSG_OOB /**/
+/*#define HAS_MSG_PEEK /**/
+/*#define HAS_MSG_PROXY /**/
+/*#define HAS_SCM_RIGHTS /**/
+
+/* HAS_SRAND48_R:
+ * This symbol, if defined, indicates that the srand48_r routine
+ * is available to srand48 re-entrantly.
+ */
+/* SRAND48_R_PROTO:
+ * This symbol encodes the prototype of srand48_r.
+ * It is zero if d_srand48_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r
+ * is defined.
+ */
+/*#define HAS_SRAND48_R /**/
+#define SRAND48_R_PROTO 0 /**/
+
+/* HAS_SRANDOM_R:
+ * This symbol, if defined, indicates that the srandom_r routine
+ * is available to srandom re-entrantly.
+ */
+/* SRANDOM_R_PROTO:
+ * This symbol encodes the prototype of srandom_r.
+ * It is zero if d_srandom_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r
+ * is defined.
+ */
+/*#define HAS_SRANDOM_R /**/
+#define SRANDOM_R_PROTO 0 /**/
+
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#ifndef USE_STAT_BLOCKS
+/*#define USE_STAT_BLOCKS /**/
+#endif
+
+/* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+#define USE_STRUCT_COPY /**/
+
+/* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+/* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+/* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+#define HAS_STRERROR /**/
+#define HAS_SYS_ERRLIST /**/
+#define Strerror(e) strerror(e)
+
+/* HAS_STRERROR_R:
+ * This symbol, if defined, indicates that the strerror_r routine
+ * is available to strerror re-entrantly.
+ */
+/* STRERROR_R_PROTO:
+ * This symbol encodes the prototype of strerror_r.
+ * It is zero if d_strerror_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r
+ * is defined.
+ */
+/*#define HAS_STRERROR_R /**/
+#define STRERROR_R_PROTO 0 /**/
+
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+#define HAS_STRTOUL /**/
+
+/* HAS_TIME:
+ * This symbol, if defined, indicates that the time() routine exists.
+ */
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define HAS_TIME /**/
+#define Time_t time_t /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+#define HAS_TIMES /**/
+
+/* HAS_TMPNAM_R:
+ * This symbol, if defined, indicates that the tmpnam_r routine
+ * is available to tmpnam re-entrantly.
+ */
+/* TMPNAM_R_PROTO:
+ * This symbol encodes the prototype of tmpnam_r.
+ * It is zero if d_tmpnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r
+ * is defined.
+ */
+/*#define HAS_TMPNAM_R /**/
+#define TMPNAM_R_PROTO 0 /**/
+
+/* HAS_TTYNAME_R:
+ * This symbol, if defined, indicates that the ttyname_r routine
+ * is available to ttyname re-entrantly.
+ */
+/* TTYNAME_R_PROTO:
+ * This symbol encodes the prototype of ttyname_r.
+ * It is zero if d_ttyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r
+ * is defined.
+ */
+/*#define HAS_TTYNAME_R /**/
+#define TTYNAME_R_PROTO 0 /**/
+
+/* HAS_UNION_SEMUN:
+ * This symbol, if defined, indicates that the union semun is
+ * defined by including <sys/sem.h>. If not, the user code
+ * probably needs to define it as:
+ * union semun {
+ * int val;
+ * struct semid_ds *buf;
+ * unsigned short *array;
+ * }
+ */
+/* USE_SEMCTL_SEMUN:
+ * This symbol, if defined, indicates that union semun is
+ * used for semctl IPC_STAT.
+ */
+/* USE_SEMCTL_SEMID_DS:
+ * This symbol, if defined, indicates that struct semid_ds * is
+ * used for semctl IPC_STAT.
+ */
+#define HAS_UNION_SEMUN /**/
+/*#define USE_SEMCTL_SEMUN /**/
+/*#define USE_SEMCTL_SEMID_DS /**/
+
+/* HAS_VFORK:
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+/*#define HAS_VFORK /**/
+
+/* HAS_PSEUDOFORK:
+ * This symbol, if defined, indicates that an emulation of the
+ * fork routine is available.
+ */
+#define HAS_PSEUDOFORK /**/
+
+/* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+#define Signal_t void /* Signal handler's return type */
+
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#define HASVOLATILE /**/
+#ifndef HASVOLATILE
+#define volatile
+#endif
+
+/* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Fpos_t fpos_t /* File position type */
+
+/* Gid_t_f:
+ * This symbol defines the format string used for printing a Gid_t.
+ */
+#define Gid_t_f "ld" /**/
+
+/* Gid_t_sign:
+ * This symbol holds the signedess of a Gid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Gid_t_sign -1 /* GID sign */
+
+/* Gid_t_size:
+ * This symbol holds the size of a Gid_t in bytes.
+ */
+#define Gid_t_size 4 /* GID size */
+
+/* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * gid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+#define Gid_t gid_t /* Type for getgid(), etc... */
+
+/* I_DIRENT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <dirent.h>. Using this symbol also triggers the definition
+ * of the Direntry_t define which ends up being 'struct dirent' or
+ * 'struct direct' depending on the availability of <dirent.h>.
+ */
+/* DIRNAMLEN:
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+/* Direntry_t:
+ * This symbol is set to 'struct direct' or 'struct dirent' depending on
+ * whether dirent is available or not. You should use this pseudo type to
+ * portably declare your directory entries.
+ */
+#define I_DIRENT /**/
+#define DIRNAMLEN /**/
+#define Direntry_t struct direct
+
+/* I_GRP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <grp.h>.
+ */
+/* GRPASSWD:
+ * This symbol, if defined, indicates to the C program that struct group
+ * in <grp.h> contains gr_passwd.
+ */
+/*#define I_GRP /**/
+/*#define GRPASSWD /**/
+
+/* I_MACH_CTHREADS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <mach/cthreads.h>.
+ */
+/*#define I_MACH_CTHREADS /**/
+
+/* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+/* I_GDBMNDBM:
+ * This symbol, if defined, indicates that <gdbm/ndbm.h> exists and should
+ * be included. This was the location of the ndbm.h compatibility file
+ * in RedHat 7.1.
+ */
+/* I_GDBM_NDBM:
+ * This symbol, if defined, indicates that <gdbm-ndbm.h> exists and should
+ * be included. This is the location of the ndbm.h compatibility file
+ * in Debian 4.0.
+ */
+/* NDBM_H_USES_PROTOTYPES:
+ * This symbol, if defined, indicates that <ndbm.h> uses real ANSI C
+ * prototypes instead of K&R style function declarations without any
+ * parameter information. While ANSI C prototypes are supported in C++,
+ * K&R style function declarations will yield errors.
+ */
+/* GDBMNDBM_H_USES_PROTOTYPES:
+ * This symbol, if defined, indicates that <gdbm/ndbm.h> uses real ANSI C
+ * prototypes instead of K&R style function declarations without any
+ * parameter information. While ANSI C prototypes are supported in C++,
+ * K&R style function declarations will yield errors.
+ */
+/* GDBM_NDBM_H_USES_PROTOTYPES:
+ * This symbol, if defined, indicates that <gdbm-ndbm.h> uses real ANSI C
+ * prototypes instead of K&R style function declarations without any
+ * parameter information. While ANSI C prototypes are supported in C++,
+ * K&R style function declarations will yield errors.
+ */
+/*#define I_NDBM /**/
+/*#define I_GDBMNDBM /**/
+/*#define I_GDBM_NDBM /**/
+/*#define NDBM_H_USES_PROTOTYPES /**/
+/*#define GDBMNDBM_H_USES_PROTOTYPES /**/
+/*#define GDBM_NDBM_H_USES_PROTOTYPES /**/
+
+/* I_NETDB:
+ * This symbol, if defined, indicates that <netdb.h> exists and
+ * should be included.
+ */
+/*#define I_NETDB /**/
+
+/* I_NET_ERRNO:
+ * This symbol, if defined, indicates that <net/errno.h> exists and
+ * should be included.
+ */
+/*#define I_NET_ERRNO /**/
+
+/* I_PTHREAD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pthread.h>.
+ */
+/*#define I_PTHREAD /**/
+
+/* I_PWD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pwd.h>.
+ */
+/* PWQUOTA:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+/* PWAGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+/* PWCHANGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+/* PWCLASS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+/* PWEXPIRE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+/* PWCOMMENT:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+/* PWGECOS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_gecos.
+ */
+/* PWPASSWD:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_passwd.
+ */
+/*#define I_PWD /**/
+/*#define PWQUOTA /**/
+/*#define PWAGE /**/
+/*#define PWCHANGE /**/
+/*#define PWCLASS /**/
+/*#define PWEXPIRE /**/
+/*#define PWCOMMENT /**/
+/*#define PWGECOS /**/
+/*#define PWPASSWD /**/
+
+/* I_SYS_ACCESS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/access.h>.
+ */
+/*#define I_SYS_ACCESS /**/
+
+/* I_SYS_SECURITY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/security.h>.
+ */
+/*#define I_SYS_SECURITY /**/
+
+/* I_SYSUIO:
+ * This symbol, if defined, indicates that <sys/uio.h> exists and
+ * should be included.
+ */
+/*#define I_SYSUIO /**/
+
+/* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+/* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+#define I_STDARG /**/
+/*#define I_VARARGS /**/
+
+/* PERL_INC_VERSION_LIST:
+ * This variable specifies the list of subdirectories in over
+ * which perl.c:incpush() and lib/lib.pm will automatically
+ * search when adding directories to @INC, in a format suitable
+ * for a C initialization string. See the inc_version_list entry
+ * in Porting/Glossary for more details.
+ */
+/*#define PERL_INC_VERSION_LIST 0 /**/
+
+/* INSTALL_USR_BIN_PERL:
+ * This symbol, if defined, indicates that Perl is to be installed
+ * also as /usr/bin/perl.
+ */
+/*#define INSTALL_USR_BIN_PERL /**/
+
+/* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+/* LSEEKSIZE:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+/* Off_t_size:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+#define Off_t long long /* <offset> type */
+#define LSEEKSIZE 8 /* <offset> size */
+#define Off_t_size 8 /* <offset> size */
+
+/* Free_t:
+ * This variable contains the return type of free(). It is usually
+ * void, but occasionally int.
+ */
+/* Malloc_t:
+ * This symbol is the type of pointer returned by malloc and realloc.
+ */
+#define Malloc_t void * /**/
+#define Free_t void /**/
+
+/* PERL_MALLOC_WRAP:
+ * This symbol, if defined, indicates that we'd like malloc wrap checks.
+ */
+#define PERL_MALLOC_WRAP /**/
+
+/* MYMALLOC:
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+/*#define MYMALLOC /**/
+
+/* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+#define Mode_t mode_t /* file mode parameter for system calls */
+
+/* Netdb_host_t:
+ * This symbol holds the type used for the 1st argument
+ * to gethostbyaddr().
+ */
+/* Netdb_hlen_t:
+ * This symbol holds the type used for the 2nd argument
+ * to gethostbyaddr().
+ */
+/* Netdb_name_t:
+ * This symbol holds the type used for the argument to
+ * gethostbyname().
+ */
+/* Netdb_net_t:
+ * This symbol holds the type used for the 1st argument to
+ * getnetbyaddr().
+ */
+#define Netdb_host_t char * /**/
+#define Netdb_hlen_t int /**/
+#define Netdb_name_t char * /**/
+#define Netdb_net_t long /**/
+
+/* PERL_OTHERLIBDIRS:
+ * 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 @INC.
+ * Perl will automatically search below each path for version-
+ * and architecture-specific directories. See PERL_INC_VERSION_LIST
+ * for more details.
+ */
+/*#define PERL_OTHERLIBDIRS "" /**/
+
+/* Pid_t:
+ * This symbol holds the type used to declare process ids in the kernel.
+ * It can be int, uint, pid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Pid_t int /* PID type */
+
+/* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+/* PRIVLIB_EXP:
+ * This symbol contains the ~name expanded version of PRIVLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define PRIVLIB "C:\\strawberry\\perl\\lib" /**/
+#define PRIVLIB_EXP (win32_get_privlib("5.10.1")) /**/
+
+/* CAN_PROTOTYPE:
+ * If defined, this macro indicates that the C compiler can handle
+ * function prototypes.
+ */
+/* _:
+ * This macro is used to declare function parameters for folks who want
+ * to make declarations with prototypes using a different style than
+ * the above macros. Use double parentheses. For example:
+ *
+ * int main _((int argc, char *argv[]));
+ */
+#define CAN_PROTOTYPE /**/
+#ifdef CAN_PROTOTYPE
+#define _(args) args
+#else
+#define _(args) ()
+#endif
+
+/* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+#define Select_fd_set_t Perl_fd_set * /**/
+
+/* SH_PATH:
+ * This symbol contains the full pathname to the shell used on this
+ * on this system to execute Bourne shell scripts. Usually, this will be
+ * /bin/sh, though it's possible that some systems will have /bin/ksh,
+ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ * D:/bin/sh.exe.
+ */
+#define SH_PATH "cmd /x /c" /**/
+
+/* SIG_NAME:
+ * This symbol contains a list of signal names in order of
+ * signal number. This is intended
+ * to be used as a static array initialization, like this:
+ * char *sig_name[] = { SIG_NAME };
+ * The signals in the list are separated with commas, and each signal
+ * is surrounded by double quotes. There is no leading SIG in the signal
+ * name, i.e. SIGQUIT is known as "QUIT".
+ * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn,
+ * etc., where nn is the actual signal number (e.g. NUM37).
+ * The signal number for sig_name[i] is stored in sig_num[i].
+ * The last element is 0 to terminate the list with a NULL. This
+ * corresponds to the 0 at the end of the sig_name_init list.
+ * Note that this variable is initialized from the sig_name_init,
+ * not from sig_name (which is unused).
+ */
+/* SIG_NUM:
+ * This symbol contains a list of signal numbers, in the same order as the
+ * SIG_NAME list. It is suitable for static array initialization, as in:
+ * int sig_num[] = { SIG_NUM };
+ * The signals in the list are separated with commas, and the indices
+ * within that list and the SIG_NAME list match, so it's easy to compute
+ * the signal name from a number or vice versa at the price of a small
+ * dynamic linear lookup.
+ * Duplicates are allowed, but are moved to the end of the list.
+ * The signal number corresponding to sig_name[i] is sig_number[i].
+ * if (i < NSIG) then sig_number[i] == i.
+ * The last element is 0, corresponding to the 0 at the end of
+ * the sig_name_init list.
+ * Note that this variable is initialized from the sig_num_init,
+ * not from sig_num (which is unused).
+ */
+/* SIG_SIZE:
+ * This variable contains the number of elements of the SIG_NAME
+ * and SIG_NUM arrays, excluding the final NULL entry.
+ */
+#define 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", 0 /**/
+#define 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, 0 /**/
+#define SIG_SIZE 27 /**/
+
+/* SITEARCH:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * 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 Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITEARCH_EXP:
+ * This symbol contains the ~name expanded version of SITEARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define SITEARCH "C:\\strawberry\\perl\\site\\lib" /**/
+/*#define SITEARCH_EXP "" /**/
+
+/* SITELIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * 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 Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* SITELIB_STEM:
+ * This define is SITELIB_EXP with any trailing version-specific component
+ * removed. The elements in inc_version_list (inc_version_list.U) can
+ * be tacked onto this variable to generate a list of directories to search.
+ */
+#define SITELIB "C:\\strawberry\\perl\\site\\lib" /**/
+#define SITELIB_EXP (win32_get_sitelib("5.10.1")) /**/
+#define SITELIB_STEM "" /**/
+
+/* Size_t_size:
+ * This symbol holds the size of a Size_t in bytes.
+ */
+#define Size_t_size 4 /**/
+
+/* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Size_t size_t /* length paramater for string functions */
+
+/* Sock_size_t:
+ * This symbol holds the type used for the size argument of
+ * various socket calls (just the base type, not the pointer-to).
+ */
+#define Sock_size_t int /**/
+
+/* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR char /**/
+
+/* Uid_t_f:
+ * This symbol defines the format string used for printing a Uid_t.
+ */
+#define Uid_t_f "ld" /**/
+
+/* Uid_t_sign:
+ * This symbol holds the signedess of a Uid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Uid_t_sign -1 /* UID sign */
+
+/* Uid_t_size:
+ * This symbol holds the size of a Uid_t in bytes.
+ */
+#define Uid_t_size 4 /* UID size */
+
+/* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Uid_t uid_t /* UID type */
+
+/* USE_ITHREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the interpreter-based threading implementation.
+ */
+/* USE_5005THREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the 5.005-based threading implementation.
+ * Only valid up to 5.8.x.
+ */
+/* OLD_PTHREADS_API:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use the old draft POSIX threads API.
+ */
+/* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
+/*#define USE_5005THREADS /**/
+#define USE_ITHREADS /**/
+#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
+#define USE_THREADS /* until src is revised*/
+#endif
+/*#define OLD_PTHREADS_API /**/
+/*#define USE_REENTRANT_API /**/
+
+/* PERL_VENDORARCH:
+ * If defined, this symbol contains the name of a private library.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world.
+ * It may have a ~ 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 Makefile.PL INSTALLDIRS=vendor
+ * or equivalent. See INSTALL for details.
+ */
+/* PERL_VENDORARCH_EXP:
+ * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define PERL_VENDORARCH "C:\\strawberry\\perl\\vendor\\lib" /**/
+#define PERL_VENDORARCH_EXP "C:\\strawberry\\perl\\vendor\\lib" /**/
+
+/* PERL_VENDORLIB_EXP:
+ * This symbol contains the ~name expanded version of VENDORLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* PERL_VENDORLIB_STEM:
+ * This define is PERL_VENDORLIB_EXP with any trailing version-specific component
+ * removed. The elements in inc_version_list (inc_version_list.U) can
+ * be tacked onto this variable to generate a list of directories to search.
+ */
+#define PERL_VENDORLIB_EXP "C:\\strawberry\\perl\\vendor\\lib" /**/
+#define PERL_VENDORLIB_STEM "" /**/
+
+/* VOIDFLAGS:
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ * 8 = suports declaration of generic void pointers
+ *
+ * The package designer should define VOIDUSED to indicate the requirements
+ * of the package. This can be done either by #defining VOIDUSED before
+ * including config.h, or by defining defvoidused in Myinit.U. If the
+ * latter approach is taken, only those flags will be tested. If the
+ * level of void support necessary is not present, defines void to int.
+ */
+#ifndef VOIDUSED
+#define VOIDUSED 15
+#endif
+#define VOIDFLAGS 15
+#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define void int /* is void to be avoided? */
+#define M_VOID /* Xenix strikes again */
+#endif
+
+/* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+/* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+#ifndef USE_CROSS_COMPILE
+/*#define USE_CROSS_COMPILE /**/
+#define PERL_TARGETARCH "" /**/
+#endif
+
+/* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double, or a long double when applicable. Usual values are 2,
+ * 4 and 8. The default is eight, for safety.
+ */
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# define MEM_ALIGNBYTES 8
+#else
+#define MEM_ALIGNBYTES 8
+#endif
+
+/* BYTEORDER:
+ * This symbol holds the hexadecimal constant defined in byteorder,
+ * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc...
+ * If the compiler supports cross-compiling or multiple-architecture
+ * binaries (eg. on NeXT systems), use compiler-defined macros to
+ * determine the byte order.
+ * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
+ * Binaries (MAB) on either big endian or little endian machines.
+ * The endian-ness is available at compile-time. This only matters
+ * for perl, where the config.h can be generated and installed on
+ * one system, and used by a different architecture to build an
+ * extension. Older versions of NeXT that might not have
+ * defined either *_ENDIAN__ were all on Motorola 680x0 series,
+ * so the default case (for NeXT) is big endian to catch them.
+ * This might matter for NeXT 3.0.
+ */
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# ifdef __LITTLE_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x1234
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x12345678
+# endif
+# endif
+# else
+# ifdef __BIG_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x4321
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x87654321
+# endif
+# endif
+# endif
+# endif
+# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
+# define BYTEORDER 0x4321
+# endif
+#else
+#define BYTEORDER 0x1234 /* large digits for MSB */
+#endif /* NeXT */
+
+/* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+#define CASTI32 /**/
+
+/* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+/* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+#define CASTNEGFLOAT /**/
+#define CASTFLAGS 0 /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+/*#define VOID_CLOSEDIR /**/
+
+/* HAS_FD_SET:
+ * This symbol, when defined, indicates presence of the fd_set typedef
+ * in <sys/types.h>
+ */
+#define HAS_FD_SET /**/
+
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * The usual values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
+/* HAS_GETPAGESIZE:
+ * This symbol, if defined, indicates that the getpagesize system call
+ * is available to get system page size, which is the granularity of
+ * many memory management calls.
+ */
+/*#define HAS_GETPAGESIZE /**/
+
+/* HAS_GNULIBC:
+ * This symbol, if defined, indicates to the C program that
+ * the GNU C library is being used. A better check is to use
+ * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc.
+ */
+/*#define HAS_GNULIBC /**/
+#if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
+# define _GNU_SOURCE
+#endif
+
+/* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#define HAS_ISASCII /**/
+
+/* HAS_LCHOWN:
+ * This symbol, if defined, indicates that the lchown routine is
+ * available to operate on a symbolic link (instead of following the
+ * link).
+ */
+/*#define HAS_LCHOWN /**/
+
+/* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+/*#define HAS_OPEN3 /**/
+
+/* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Normally, you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+/*#define HAS_SAFE_BCOPY /**/
+
+/* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. If you need to
+ * copy overlapping memory blocks, you should check HAS_MEMMOVE and
+ * use memmove() instead, if available.
+ */
+/*#define HAS_SAFE_MEMCPY /**/
+
+/* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * and can be used to compare relative magnitudes of chars with their high
+ * bits set. If it is not defined, roll your own version.
+ */
+#define HAS_SANE_MEMCMP /**/
+
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+/*#define HAS_SIGACTION /**/
+
+/* HAS_SIGSETJMP:
+ * This variable indicates to the C program that the sigsetjmp()
+ * routine is available to save the calling process's registers
+ * and stack environment for later use by siglongjmp(), and
+ * to optionally save the process's signal mask. See
+ * Sigjmp_buf, Sigsetjmp, and Siglongjmp.
+ */
+/* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+/* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/*#define HAS_SIGSETJMP /**/
+#ifdef HAS_SIGSETJMP
+#define Sigjmp_buf sigjmp_buf
+#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
+#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
+#else
+#define Sigjmp_buf jmp_buf
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
+#endif
+
+/* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+/* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+/* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+/* STDIO_PTR_LVAL_SETS_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n has the side effect of decreasing the
+ * value of File_cnt(fp) by n.
+ */
+/* STDIO_PTR_LVAL_NOCHANGE_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n leaves File_cnt(fp) unchanged.
+ */
+#define USE_STDIO_PTR /**/
+#ifdef USE_STDIO_PTR
+#define FILE_ptr(fp) ((fp)->_ptr)
+#define STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) ((fp)->_cnt)
+#define STDIO_CNT_LVALUE /**/
+/*#define STDIO_PTR_LVAL_SETS_CNT /**/
+#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
+#endif
+
+/* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+/* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+/* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+#define USE_STDIO_BASE /**/
+#ifdef USE_STDIO_BASE
+#define FILE_base(fp) ((fp)->_base)
+#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
+#endif
+
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+/*#define USE_CHAR_VSPRINTF /**/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE 8 /**/
+
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+/* HAS_TM_TM_ZONE:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_zone field.
+ */
+/* HAS_TM_TM_GMTOFF:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_gmtoff field.
+ */
+#define I_TIME /**/
+/*#define I_SYS_TIME /**/
+/*#define I_SYS_TIME_KERNEL /**/
+/*#define HAS_TM_TM_ZONE /**/
+/*#define HAS_TM_TM_GMTOFF /**/
+
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#define EOF_NONBLOCK
+
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE 4 /**/
+
+/* Drand01:
+ * This macro is to be used to generate uniformly distributed
+ * random numbers over the range [0., 1.[. You may have to supply
+ * an 'extern double drand48();' in your program since SunOS 4.1.3
+ * doesn't provide you with anything relevant in its headers.
+ * See HAS_DRAND48_PROTO.
+ */
+/* Rand_seed_t:
+ * This symbol defines the type of the argument of the
+ * random seed function.
+ */
+/* seedDrand01:
+ * This symbol defines the macro to be used in seeding the
+ * random number generator (see Drand01).
+ */
+/* RANDBITS:
+ * This symbol indicates how many bits are produced by the
+ * function used to generate normalized random numbers.
+ * Values include 15, 16, 31, and 48.
+ */
+#define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) /**/
+#define Rand_seed_t unsigned /**/
+#define seedDrand01(x) srand((Rand_seed_t)x) /**/
+#define RANDBITS 15 /**/
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t int /* signed count of bytes */
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+/*#define EBCDIC /**/
+
+/* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+/*#define DOSUID /**/
+
+/* PERL_USE_DEVEL:
+ * This symbol, if defined, indicates that Perl was configured with
+ * -Dusedevel, to enable development features. This should not be
+ * done for production builds.
+ */
+/*#define PERL_USE_DEVEL /**/
+
+/* HAS_ATOLF:
+ * This symbol, if defined, indicates that the atolf routine is
+ * available to convert strings into long doubles.
+ */
+/*#define HAS_ATOLF /**/
+
+/* HAS_ATOLL:
+ * This symbol, if defined, indicates that the atoll routine is
+ * available to convert strings into long longs.
+ */
+/*#define HAS_ATOLL /**/
+
+/* HAS__FWALK:
+ * This symbol, if defined, indicates that the _fwalk system call is
+ * available to apply a function to all the file handles.
+ */
+/*#define HAS__FWALK /**/
+
+/* HAS_AINTL:
+ * This symbol, if defined, indicates that the aintl routine is
+ * available. If copysignl is also present we can emulate modfl.
+ */
+/*#define HAS_AINTL /**/
+
+/* HAS_BUILTIN_CHOOSE_EXPR:
+ * Can we handle GCC builtin for compile-time ternary-like expressions
+ */
+/* HAS_BUILTIN_EXPECT:
+ * Can we handle GCC builtin for telling that certain values are more
+ * likely
+ */
+/*#define HAS_BUILTIN_EXPECT /**/
+/*#define HAS_BUILTIN_CHOOSE_EXPR /**/
+
+/* HAS_C99_VARIADIC_MACROS:
+ * If defined, the compiler supports C99 variadic macros.
+ */
+/*#define HAS_C99_VARIADIC_MACROS /**/
+
+/* HAS_CLASS:
+ * This symbol, if defined, indicates that the class routine is
+ * available to classify doubles. Available for example in AIX.
+ * The returned values are defined in <float.h> and are:
+ *
+ * FP_PLUS_NORM Positive normalized, nonzero
+ * FP_MINUS_NORM Negative normalized, nonzero
+ * FP_PLUS_DENORM Positive denormalized, nonzero
+ * FP_MINUS_DENORM Negative denormalized, nonzero
+ * FP_PLUS_ZERO +0.0
+ * FP_MINUS_ZERO -0.0
+ * FP_PLUS_INF +INF
+ * FP_MINUS_INF -INF
+ * FP_NANS Signaling Not a Number (NaNS)
+ * FP_NANQ Quiet Not a Number (NaNQ)
+ */
+/*#define HAS_CLASS /**/
+
+/* HAS_CLEARENV:
+ * This symbol, if defined, indicates that the clearenv () routine is
+ * available for use.
+ */
+/*#define HAS_CLEARENV /**/
+
+/* HAS_STRUCT_CMSGHDR:
+ * This symbol, if defined, indicates that the struct cmsghdr
+ * is supported.
+ */
+/*#define HAS_STRUCT_CMSGHDR /**/
+
+/* HAS_COPYSIGNL:
+ * This symbol, if defined, indicates that the copysignl routine is
+ * available. If aintl is also present we can emulate modfl.
+ */
+/*#define HAS_COPYSIGNL /**/
+
+/* USE_CPLUSPLUS:
+ * This symbol, if defined, indicates that a C++ compiler was
+ * used to compiled Perl and will be used to compile extensions.
+ */
+/*#define USE_CPLUSPLUS /**/
+
+/* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+/*#define HAS_DBMINIT_PROTO /**/
+
+/* HAS_DIR_DD_FD:
+ * This symbol, if defined, indicates that the the DIR* dirstream
+ * structure contains a member variable named dd_fd.
+ */
+/*#define HAS_DIR_DD_FD /**/
+
+/* HAS_DIRFD:
+ * This manifest constant lets the C program know that dirfd
+ * is available.
+ */
+/*#define HAS_DIRFD /**/
+
+/* DLSYM_NEEDS_UNDERSCORE:
+ * This symbol, if defined, indicates that we need to prepend an
+ * underscore to the symbol name before calling dlsym(). This only
+ * makes sense if you *have* dlsym, which we will presume is the
+ * case if you're using dl_dlopen.xs.
+ */
+/*#define DLSYM_NEEDS_UNDERSCORE /**/
+
+/* HAS_FAST_STDIO:
+ * This symbol, if defined, indicates that the "fast stdio"
+ * is available to manipulate the stdio buffers directly.
+ */
+#define HAS_FAST_STDIO /**/
+
+/* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+/*#define HAS_FCHDIR /**/
+
+/* FCNTL_CAN_LOCK:
+ * This symbol, if defined, indicates that fcntl() can be used
+ * for file locking. Normally on Unix systems this is defined.
+ * It may be undefined on VMS.
+ */
+/*#define FCNTL_CAN_LOCK /**/
+
+/* HAS_FINITE:
+ * This symbol, if defined, indicates that the finite routine is
+ * available to check whether a double is finite (non-infinity non-NaN).
+ */
+/*#define HAS_FINITE /**/
+
+/* HAS_FINITEL:
+ * This symbol, if defined, indicates that the finitel routine is
+ * available to check whether a long double is finite
+ * (non-infinity non-NaN).
+ */
+/*#define HAS_FINITEL /**/
+
+/* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+#define HAS_FLOCK_PROTO /**/
+
+/* HAS_FP_CLASS:
+ * This symbol, if defined, indicates that the fp_class routine is
+ * available to classify doubles. Available for example in Digital UNIX.
+ * The returned values are defined in <math.h> and are:
+ *
+ * FP_SNAN Signaling NaN (Not-a-Number)
+ * FP_QNAN Quiet NaN (Not-a-Number)
+ * FP_POS_INF +infinity
+ * FP_NEG_INF -infinity
+ * FP_POS_NORM Positive normalized
+ * FP_NEG_NORM Negative normalized
+ * FP_POS_DENORM Positive denormalized
+ * FP_NEG_DENORM Negative denormalized
+ * FP_POS_ZERO +0.0 (positive zero)
+ * FP_NEG_ZERO -0.0 (negative zero)
+ */
+/*#define HAS_FP_CLASS /**/
+
+/* HAS_FPCLASS:
+ * This symbol, if defined, indicates that the fpclass routine is
+ * available to classify doubles. Available for example in Solaris/SVR4.
+ * The returned values are defined in <ieeefp.h> and are:
+ *
+ * FP_SNAN signaling NaN
+ * FP_QNAN quiet NaN
+ * FP_NINF negative infinity
+ * FP_PINF positive infinity
+ * FP_NDENORM negative denormalized non-zero
+ * FP_PDENORM positive denormalized non-zero
+ * FP_NZERO negative zero
+ * FP_PZERO positive zero
+ * FP_NNORM negative normalized non-zero
+ * FP_PNORM positive normalized non-zero
+ */
+/*#define HAS_FPCLASS /**/
+
+/* HAS_FPCLASSIFY:
+ * This symbol, if defined, indicates that the fpclassify routine is
+ * available to classify doubles. Available for example in HP-UX.
+ * The returned values are defined in <math.h> and are
+ *
+ * FP_NORMAL Normalized
+ * FP_ZERO Zero
+ * FP_INFINITE Infinity
+ * FP_SUBNORMAL Denormalized
+ * FP_NAN NaN
+ *
+ */
+/*#define HAS_FPCLASSIFY /**/
+
+/* HAS_FPCLASSL:
+ * This symbol, if defined, indicates that the fpclassl routine is
+ * available to classify long doubles. Available for example in IRIX.
+ * The returned values are defined in <ieeefp.h> and are:
+ *
+ * FP_SNAN signaling NaN
+ * FP_QNAN quiet NaN
+ * FP_NINF negative infinity
+ * FP_PINF positive infinity
+ * FP_NDENORM negative denormalized non-zero
+ * FP_PDENORM positive denormalized non-zero
+ * FP_NZERO negative zero
+ * FP_PZERO positive zero
+ * FP_NNORM negative normalized non-zero
+ * FP_PNORM positive normalized non-zero
+ */
+/*#define HAS_FPCLASSL /**/
+
+/* HAS_FPOS64_T:
+ * This symbol will be defined if the C compiler supports fpos64_t.
+ */
+/*#define HAS_FPOS64_T /**/
+
+/* HAS_FREXPL:
+ * This symbol, if defined, indicates that the frexpl routine is
+ * available to break a long double floating-point number into
+ * a normalized fraction and an integral power of 2.
+ */
+/*#define HAS_FREXPL /**/
+
+/* HAS_STRUCT_FS_DATA:
+ * This symbol, if defined, indicates that the struct fs_data
+ * to do statfs() is supported.
+ */
+/*#define HAS_STRUCT_FS_DATA /**/
+
+/* HAS_FSEEKO:
+ * This symbol, if defined, indicates that the fseeko routine is
+ * available to fseek beyond 32 bits (useful for ILP32 hosts).
+ */
+/*#define HAS_FSEEKO /**/
+
+/* HAS_FSTATFS:
+ * This symbol, if defined, indicates that the fstatfs routine is
+ * available to stat filesystems by file descriptors.
+ */
+/*#define HAS_FSTATFS /**/
+
+/* HAS_FSYNC:
+ * This symbol, if defined, indicates that the fsync routine is
+ * available to write a file's modified data and attributes to
+ * permanent storage.
+ */
+/*#define HAS_FSYNC /**/
+
+/* HAS_FTELLO:
+ * This symbol, if defined, indicates that the ftello routine is
+ * available to ftell beyond 32 bits (useful for ILP32 hosts).
+ */
+/*#define HAS_FTELLO /**/
+
+/* HAS_FUTIMES:
+ * This symbol, if defined, indicates that the futimes routine is
+ * available to change file descriptor time stamps with struct timevals.
+ */
+/*#define HAS_FUTIMES /**/
+
+/* HAS_GETADDRINFO:
+ * This symbol, if defined, indicates that the getaddrinfo() function
+ * is available for use.
+ */
+/*#define HAS_GETADDRINFO /**/
+
+/* HAS_GETCWD:
+ * This symbol, if defined, indicates that the getcwd routine is
+ * available to get the current working directory.
+ */
+#define HAS_GETCWD /**/
+
+/* HAS_GETESPWNAM:
+ * This symbol, if defined, indicates that the getespwnam system call is
+ * available to retrieve enchanced (shadow) password entries by name.
+ */
+/*#define HAS_GETESPWNAM /**/
+
+/* HAS_GETFSSTAT:
+ * This symbol, if defined, indicates that the getfsstat routine is
+ * available to stat filesystems in bulk.
+ */
+/*#define HAS_GETFSSTAT /**/
+
+/* HAS_GETITIMER:
+ * This symbol, if defined, indicates that the getitimer routine is
+ * available to return interval timers.
+ */
+/*#define HAS_GETITIMER /**/
+
+/* HAS_GETMNT:
+ * This symbol, if defined, indicates that the getmnt routine is
+ * available to get filesystem mount info by filename.
+ */
+/*#define HAS_GETMNT /**/
+
+/* HAS_GETMNTENT:
+ * This symbol, if defined, indicates that the getmntent routine is
+ * available to iterate through mounted file systems to get their info.
+ */
+/*#define HAS_GETMNTENT /**/
+
+/* HAS_GETNAMEINFO:
+ * This symbol, if defined, indicates that the getnameinfo() function
+ * is available for use.
+ */
+/*#define HAS_GETNAMEINFO /**/
+
+/* HAS_GETPRPWNAM:
+ * This symbol, if defined, indicates that the getprpwnam system call is
+ * available to retrieve protected (shadow) password entries by name.
+ */
+/*#define HAS_GETPRPWNAM /**/
+
+/* HAS_GETSPNAM:
+ * This symbol, if defined, indicates that the getspnam system call is
+ * available to retrieve SysV shadow password entries by name.
+ */
+/*#define HAS_GETSPNAM /**/
+
+/* HAS_HASMNTOPT:
+ * This symbol, if defined, indicates that the hasmntopt routine is
+ * available to query the mount options of file systems.
+ */
+/*#define HAS_HASMNTOPT /**/
+
+/* HAS_ILOGBL:
+ * This symbol, if defined, indicates that the ilogbl routine is
+ * available. If scalbnl is also present we can emulate frexpl.
+ */
+/*#define HAS_ILOGBL /**/
+
+/* HAS_INETNTOP:
+ * This symbol, if defined, indicates that the inet_ntop() function
+ * is available to parse IPv4 and IPv6 strings.
+ */
+/*#define HAS_INETNTOP /**/
+
+/* HAS_INETPTON:
+ * This symbol, if defined, indicates that the inet_pton() function
+ * is available to parse IPv4 and IPv6 strings.
+ */
+/*#define HAS_INETPTON /**/
+
+/* HAS_INT64_T:
+ * This symbol will defined if the C compiler supports int64_t.
+ * Usually the <inttypes.h> needs to be included, but sometimes
+ * <sys/types.h> is enough.
+ */
+/*#define HAS_INT64_T /**/
+
+/* HAS_ISFINITE:
+ * This symbol, if defined, indicates that the isfinite routine is
+ * available to check whether a double is finite (non-infinity non-NaN).
+ */
+/*#define HAS_ISFINITE /**/
+
+/* HAS_ISINF:
+ * This symbol, if defined, indicates that the isinf routine is
+ * available to check whether a double is an infinity.
+ */
+/*#define HAS_ISINF /**/
+
+/* HAS_ISNAN:
+ * This symbol, if defined, indicates that the isnan routine is
+ * available to check whether a double is a NaN.
+ */
+#define HAS_ISNAN /**/
+
+/* HAS_ISNANL:
+ * This symbol, if defined, indicates that the isnanl routine is
+ * available to check whether a long double is a NaN.
+ */
+/*#define HAS_ISNANL /**/
+
+/* HAS_LDBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol LDBL_DIG, which is the number
+ * of significant digits in a long double precision number. Unlike
+ * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined.
+ */
+#define HAS_LDBL_DIG /**/
+
+/* LIBM_LIB_VERSION:
+ * This symbol, if defined, indicates that libm exports _LIB_VERSION
+ * and that math.h defines the enum to manipulate it.
+ */
+/*#define LIBM_LIB_VERSION /**/
+
+/* HAS_MADVISE:
+ * This symbol, if defined, indicates that the madvise system call is
+ * available to map a file into memory.
+ */
+/*#define HAS_MADVISE /**/
+
+/* HAS_MALLOC_SIZE:
+ * This symbol, if defined, indicates that the malloc_size
+ * routine is available for use.
+ */
+/*#define HAS_MALLOC_SIZE /**/
+
+/* HAS_MALLOC_GOOD_SIZE:
+ * This symbol, if defined, indicates that the malloc_good_size
+ * routine is available for use.
+ */
+/*#define HAS_MALLOC_GOOD_SIZE /**/
+
+/* HAS_MKDTEMP:
+ * This symbol, if defined, indicates that the mkdtemp routine is
+ * available to exclusively create a uniquely named temporary directory.
+ */
+/*#define HAS_MKDTEMP /**/
+
+/* HAS_MKSTEMPS:
+ * This symbol, if defined, indicates that the mkstemps routine is
+ * available to excluslvely create and open a uniquely named
+ * (with a suffix) temporary file.
+ */
+/*#define HAS_MKSTEMPS /**/
+
+/* HAS_MODFL:
+ * This symbol, if defined, indicates that the modfl routine is
+ * available to split a long double x into a fractional part f and
+ * an integer part i such that |f| < 1.0 and (f + i) = x.
+ */
+/* HAS_MODFL_PROTO:
+ * 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.
+ */
+/* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine 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.
+ */
+/*#define HAS_MODFL /**/
+/*#define HAS_MODFL_PROTO /**/
+/*#define HAS_MODFL_POW32_BUG /**/
+
+/* HAS_MPROTECT:
+ * This symbol, if defined, indicates that the mprotect system call is
+ * available to modify the access protection of a memory mapped file.
+ */
+/*#define HAS_MPROTECT /**/
+
+/* HAS_STRUCT_MSGHDR:
+ * This symbol, if defined, indicates that the struct msghdr
+ * is supported.
+ */
+/*#define HAS_STRUCT_MSGHDR /**/
+
+/* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+/*#define HAS_NL_LANGINFO /**/
+
+/* HAS_OFF64_T:
+ * This symbol will be defined if the C compiler supports off64_t.
+ */
+/*#define HAS_OFF64_T /**/
+
+/* HAS_PROCSELFEXE:
+ * This symbol is defined if PROCSELFEXE_PATH is a symlink
+ * to the absolute pathname of the executing program.
+ */
+/* PROCSELFEXE_PATH:
+ * If HAS_PROCSELFEXE is defined this symbol is the filename
+ * of the symbolic link pointing to the absolute pathname of
+ * the executing program.
+ */
+/*#define HAS_PROCSELFEXE /**/
+#if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH)
+#define PROCSELFEXE_PATH /**/
+#endif
+
+/* HAS_PTHREAD_ATTR_SETSCOPE:
+ * This symbol, if defined, indicates that the pthread_attr_setscope
+ * system call is available to set the contention scope attribute of
+ * a thread attribute object.
+ */
+/*#define HAS_PTHREAD_ATTR_SETSCOPE /**/
+
+/* HAS_READV:
+ * This symbol, if defined, indicates that the readv routine is
+ * available to do gather reads. You will also need <sys/uio.h>
+ * and there I_SYSUIO.
+ */
+/*#define HAS_READV /**/
+
+/* HAS_RECVMSG:
+ * This symbol, if defined, indicates that the recvmsg routine is
+ * available to send structured socket messages.
+ */
+/*#define HAS_RECVMSG /**/
+
+/* HAS_SBRK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sbrk() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern void* sbrk(int);
+ * extern void* sbrk(size_t);
+ */
+/*#define HAS_SBRK_PROTO /**/
+
+/* HAS_SCALBNL:
+ * This symbol, if defined, indicates that the scalbnl routine is
+ * available. If ilogbl is also present we can emulate frexpl.
+ */
+/*#define HAS_SCALBNL /**/
+
+/* HAS_SENDMSG:
+ * This symbol, if defined, indicates that the sendmsg routine is
+ * available to send structured socket messages.
+ */
+/*#define HAS_SENDMSG /**/
+
+/* HAS_SETITIMER:
+ * This symbol, if defined, indicates that the setitimer routine is
+ * available to set interval timers.
+ */
+/*#define HAS_SETITIMER /**/
+
+/* HAS_SETPROCTITLE:
+ * This symbol, if defined, indicates that the setproctitle routine is
+ * available to set process title.
+ */
+/*#define HAS_SETPROCTITLE /**/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+/*#define USE_SFIO /**/
+
+/* HAS_SIGNBIT:
+ * This symbol, if defined, indicates that the signbit routine is
+ * available to check if the given number has the sign bit set.
+ * This should include correct testing of -0.0. This will only be set
+ * if the signbit() routine is safe to use with the NV type used internally
+ * in perl. Users should call Perl_signbit(), which will be #defined to
+ * the system's signbit() function or macro if this symbol is defined.
+ */
+/*#define HAS_SIGNBIT /**/
+
+/* HAS_SIGPROCMASK:
+ * This symbol, if defined, indicates that the sigprocmask
+ * system call is available to examine or change the signal mask
+ * of the calling process.
+ */
+/*#define HAS_SIGPROCMASK /**/
+
+/* USE_SITECUSTOMIZE:
+ * This symbol, if defined, indicates that sitecustomize should
+ * be used.
+ */
+#ifndef USE_SITECUSTOMIZE
+#define USE_SITECUSTOMIZE /**/
+#endif
+
+/* HAS_SNPRINTF:
+ * This symbol, if defined, indicates that the snprintf () library
+ * function is available for use.
+ */
+/* HAS_VSNPRINTF:
+ * This symbol, if defined, indicates that the vsnprintf () library
+ * function is available for use.
+ */
+#define HAS_SNPRINTF /**/
+#define HAS_VSNPRINTF /**/
+
+/* HAS_SOCKATMARK:
+ * This symbol, if defined, indicates that the sockatmark routine is
+ * available to test whether a socket is at the out-of-band mark.
+ */
+/*#define HAS_SOCKATMARK /**/
+
+/* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark(int);
+ */
+/*#define HAS_SOCKATMARK_PROTO /**/
+
+/* HAS_SOCKS5_INIT:
+ * This symbol, if defined, indicates that the socks5_init routine is
+ * available to initialize SOCKS 5.
+ */
+/*#define HAS_SOCKS5_INIT /**/
+
+/* SPRINTF_RETURNS_STRLEN:
+ * This variable defines whether sprintf returns the length of the string
+ * (as per the ANSI spec). Some C libraries retain compatibility with
+ * pre-ANSI C and return a pointer to the passed in buffer; for these
+ * this variable will be undef.
+ */
+#define SPRINTF_RETURNS_STRLEN /**/
+
+/* HAS_SQRTL:
+ * This symbol, if defined, indicates that the sqrtl routine is
+ * available to do long double square roots.
+ */
+/*#define HAS_SQRTL /**/
+
+/* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+/*#define HAS_SETRESGID_PROTO /**/
+
+/* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+/*#define HAS_SETRESUID_PROTO /**/
+
+/* HAS_STRUCT_STATFS_F_FLAGS:
+ * This symbol, if defined, indicates that the struct statfs
+ * does have the f_flags member containing the mount flags of
+ * the filesystem containing the file.
+ * This kind of struct statfs is coming from <sys/mount.h> (BSD 4.3),
+ * not from <sys/statfs.h> (SYSV). Older BSDs (like Ultrix) do not
+ * have statfs() and struct statfs, they have ustat() and getmnt()
+ * with struct ustat and struct fs_data.
+ */
+/*#define HAS_STRUCT_STATFS_F_FLAGS /**/
+
+/* HAS_STRUCT_STATFS:
+ * This symbol, if defined, indicates that the struct statfs
+ * to do statfs() is supported.
+ */
+/*#define HAS_STRUCT_STATFS /**/
+
+/* HAS_FSTATVFS:
+ * This symbol, if defined, indicates that the fstatvfs routine is
+ * available to stat filesystems by file descriptors.
+ */
+/*#define HAS_FSTATVFS /**/
+
+/* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+#define HAS_STRFTIME /**/
+
+/* HAS_STRLCAT:
+ * This symbol, if defined, indicates that the strlcat () routine is
+ * available to do string concatenation.
+ */
+/*#define HAS_STRLCAT /**/
+
+/* HAS_STRLCPY:
+ * This symbol, if defined, indicates that the strlcpy () routine is
+ * available to do string copying.
+ */
+/*#define HAS_STRLCPY /**/
+
+/* HAS_STRTOLD:
+ * This symbol, if defined, indicates that the strtold routine is
+ * available to convert strings to long doubles.
+ */
+/*#define HAS_STRTOLD /**/
+
+/* HAS_STRTOLL:
+ * This symbol, if defined, indicates that the strtoll routine is
+ * available to convert strings to long longs.
+ */
+/*#define HAS_STRTOLL /**/
+
+/* HAS_STRTOQ:
+ * This symbol, if defined, indicates that the strtoq routine is
+ * available to convert strings to long longs (quads).
+ */
+/*#define HAS_STRTOQ /**/
+
+/* HAS_STRTOULL:
+ * This symbol, if defined, indicates that the strtoull routine is
+ * available to convert strings to unsigned long longs.
+ */
+/*#define HAS_STRTOULL /**/
+
+/* HAS_STRTOUQ:
+ * This symbol, if defined, indicates that the strtouq routine is
+ * available to convert strings to unsigned long longs (quads).
+ */
+/*#define HAS_STRTOUQ /**/
+
+/* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+/*#define HAS_SYSCALL_PROTO /**/
+
+/* HAS_TELLDIR_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the telldir() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern long telldir(DIR*);
+ */
+#define HAS_TELLDIR_PROTO /**/
+
+/* HAS_CTIME64:
+ * This symbol, if defined, indicates that the ctime64 () routine is
+ * available to do the 64bit variant of ctime ()
+ */
+/* HAS_LOCALTIME64:
+ * This symbol, if defined, indicates that the localtime64 () routine is
+ * available to do the 64bit variant of localtime ()
+ */
+/* HAS_GMTIME64:
+ * This symbol, if defined, indicates that the gmtime64 () routine is
+ * available to do the 64bit variant of gmtime ()
+ */
+/* HAS_MKTIME64:
+ * This symbol, if defined, indicates that the mktime64 () routine is
+ * available to do the 64bit variant of mktime ()
+ */
+/* HAS_DIFFTIME64:
+ * This symbol, if defined, indicates that the difftime64 () routine is
+ * available to do the 64bit variant of difftime ()
+ */
+/* HAS_ASCTIME64:
+ * This symbol, if defined, indicates that the asctime64 () routine is
+ * available to do the 64bit variant of asctime ()
+ */
+/*#define HAS_CTIME64 /**/
+/*#define HAS_LOCALTIME64 /**/
+/*#define HAS_GMTIME64 /**/
+/*#define HAS_MKTIME64 /**/
+/*#define HAS_DIFFTIME64 /**/
+/*#define HAS_ASCTIME64 /**/
+
+/* HAS_TIMEGM:
+ * This symbol, if defined, indicates that the timegm routine is
+ * available to do the opposite of gmtime ()
+ */
+/*#define HAS_TIMEGM /**/
+
+/* U32_ALIGNMENT_REQUIRED:
+ * This symbol, if defined, indicates that you must access
+ * character data through U32-aligned pointers.
+ */
+#ifndef U32_ALIGNMENT_REQUIRED
+#define U32_ALIGNMENT_REQUIRED /**/
+#endif
+
+/* HAS_UALARM:
+ * This symbol, if defined, indicates that the ualarm routine is
+ * available to do alarms with microsecond granularity.
+ */
+/*#define HAS_UALARM /**/
+
+/* HAS_UNORDERED:
+ * This symbol, if defined, indicates that the unordered routine is
+ * available to check whether two doubles are unordered
+ * (effectively: whether either of them is NaN)
+ */
+/*#define HAS_UNORDERED /**/
+
+/* HAS_UNSETENV:
+ * This symbol, if defined, indicates that the unsetenv () routine is
+ * available for use.
+ */
+/*#define HAS_UNSETENV /**/
+
+/* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+/*#define HAS_USLEEP_PROTO /**/
+
+/* HAS_USTAT:
+ * This symbol, if defined, indicates that the ustat system call is
+ * available to query file system statistics by dev_t.
+ */
+/*#define HAS_USTAT /**/
+
+/* HAS_WRITEV:
+ * This symbol, if defined, indicates that the writev routine is
+ * available to do scatter writes.
+ */
+/*#define HAS_WRITEV /**/
+
+/* USE_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+#define USE_DYNAMIC_LOADING /**/
+
+/* FFLUSH_NULL:
+ * This symbol, if defined, tells that fflush(NULL) does flush
+ * all pending stdio output.
+ */
+/* FFLUSH_ALL:
+ * 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.
+ */
+#define FFLUSH_NULL /**/
+/*#define FFLUSH_ALL /**/
+
+/* I_ASSERT:
+ * This symbol, if defined, indicates that <assert.h> exists and
+ * could be included by the C program to get the assert() macro.
+ */
+#define I_ASSERT /**/
+
+/* I_CRYPT:
+ * This symbol, if defined, indicates that <crypt.h> exists and
+ * should be included.
+ */
+/*#define I_CRYPT /**/
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+/* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+/* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+/* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+#define DB_Hash_t int /**/
+#define DB_Prefix_t int /**/
+#define DB_VERSION_MAJOR_CFG 0 /**/
+#define DB_VERSION_MINOR_CFG 0 /**/
+#define DB_VERSION_PATCH_CFG 0 /**/
+
+/* I_FP:
+ * This symbol, if defined, indicates that <fp.h> exists and
+ * should be included.
+ */
+/*#define I_FP /**/
+
+/* I_FP_CLASS:
+ * This symbol, if defined, indicates that <fp_class.h> exists and
+ * should be included.
+ */
+/*#define I_FP_CLASS /**/
+
+/* I_IEEEFP:
+ * This symbol, if defined, indicates that <ieeefp.h> exists and
+ * should be included.
+ */
+/*#define I_IEEEFP /**/
+
+/* I_INTTYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <inttypes.h>.
+ */
+/*#define I_INTTYPES /**/
+
+/* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+/*#define I_LANGINFO /**/
+
+/* I_LIBUTIL:
+ * This symbol, if defined, indicates that <libutil.h> exists and
+ * should be included.
+ */
+/*#define I_LIBUTIL /**/
+
+/* I_MALLOCMALLOC:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <malloc/malloc.h>.
+ */
+/*#define I_MALLOCMALLOC /**/
+
+/* I_MNTENT:
+ * This symbol, if defined, indicates that <mntent.h> exists and
+ * should be included.
+ */
+/*#define I_MNTENT /**/
+
+/* I_NETINET_TCP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/tcp.h>.
+ */
+/*#define I_NETINET_TCP /**/
+
+/* I_POLL:
+ * This symbol, if defined, indicates that <poll.h> exists and
+ * should be included. (see also HAS_POLL)
+ */
+/*#define I_POLL /**/
+
+/* I_PROT:
+ * This symbol, if defined, indicates that <prot.h> exists and
+ * should be included.
+ */
+/*#define I_PROT /**/
+
+/* I_SHADOW:
+ * This symbol, if defined, indicates that <shadow.h> exists and
+ * should be included.
+ */
+/*#define I_SHADOW /**/
+
+/* I_SOCKS:
+ * This symbol, if defined, indicates that <socks.h> exists and
+ * should be included.
+ */
+/*#define I_SOCKS /**/
+
+/* I_SUNMATH:
+ * This symbol, if defined, indicates that <sunmath.h> exists and
+ * should be included.
+ */
+/*#define I_SUNMATH /**/
+
+/* I_SYSLOG:
+ * This symbol, if defined, indicates that <syslog.h> exists and
+ * should be included.
+ */
+/*#define I_SYSLOG /**/
+
+/* I_SYSMODE:
+ * This symbol, if defined, indicates that <sys/mode.h> exists and
+ * should be included.
+ */
+/*#define I_SYSMODE /**/
+
+/* I_SYS_MOUNT:
+ * This symbol, if defined, indicates that <sys/mount.h> exists and
+ * should be included.
+ */
+/*#define I_SYS_MOUNT /**/
+
+/* I_SYS_STATFS:
+ * This symbol, if defined, indicates that <sys/statfs.h> exists.
+ */
+/*#define I_SYS_STATFS /**/
+
+/* I_SYS_STATVFS:
+ * This symbol, if defined, indicates that <sys/statvfs.h> exists and
+ * should be included.
+ */
+/*#define I_SYS_STATVFS /**/
+
+/* I_SYSUTSNAME:
+ * This symbol, if defined, indicates that <sys/utsname.h> exists and
+ * should be included.
+ */
+/*#define I_SYSUTSNAME /**/
+
+/* I_SYS_VFS:
+ * This symbol, if defined, indicates that <sys/vfs.h> exists and
+ * should be included.
+ */
+/*#define I_SYS_VFS /**/
+
+/* I_USTAT:
+ * This symbol, if defined, indicates that <ustat.h> exists and
+ * should be included.
+ */
+/*#define I_USTAT /**/
+
+/* PERL_PRIfldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'f') for output.
+ */
+/* PERL_PRIgldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'g') for output.
+ */
+/* PERL_PRIeldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'e') for output.
+ */
+/* PERL_SCNfldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'f') for input.
+ */
+/*#define PERL_PRIfldbl "f" /**/
+/*#define PERL_PRIgldbl "g" /**/
+/*#define PERL_PRIeldbl "e" /**/
+/*#define PERL_SCNfldbl "f" /**/
+
+/* PERL_MAD:
+ * This symbol, if defined, indicates that the Misc Attribution
+ * Declaration code should be conditionally compiled.
+ */
+/*#define PERL_MAD /**/
+
+/* NEED_VA_COPY:
+ * 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, handy.h defines a platform-
+ * independent macro, Perl_va_copy(src, dst), to do the job.
+ */
+/*#define NEED_VA_COPY /**/
+
+/* IVTYPE:
+ * This symbol defines the C type used for Perl's IV.
+ */
+/* UVTYPE:
+ * This symbol defines the C type used for Perl's UV.
+ */
+/* I8TYPE:
+ * This symbol defines the C type used for Perl's I8.
+ */
+/* U8TYPE:
+ * This symbol defines the C type used for Perl's U8.
+ */
+/* I16TYPE:
+ * This symbol defines the C type used for Perl's I16.
+ */
+/* U16TYPE:
+ * This symbol defines the C type used for Perl's U16.
+ */
+/* I32TYPE:
+ * This symbol defines the C type used for Perl's I32.
+ */
+/* U32TYPE:
+ * This symbol defines the C type used for Perl's U32.
+ */
+/* I64TYPE:
+ * This symbol defines the C type used for Perl's I64.
+ */
+/* U64TYPE:
+ * This symbol defines the C type used for Perl's U64.
+ */
+/* NVTYPE:
+ * This symbol defines the C type used for Perl's NV.
+ */
+/* IVSIZE:
+ * This symbol contains the sizeof(IV).
+ */
+/* UVSIZE:
+ * This symbol contains the sizeof(UV).
+ */
+/* I8SIZE:
+ * This symbol contains the sizeof(I8).
+ */
+/* U8SIZE:
+ * This symbol contains the sizeof(U8).
+ */
+/* I16SIZE:
+ * This symbol contains the sizeof(I16).
+ */
+/* U16SIZE:
+ * This symbol contains the sizeof(U16).
+ */
+/* I32SIZE:
+ * This symbol contains the sizeof(I32).
+ */
+/* U32SIZE:
+ * This symbol contains the sizeof(U32).
+ */
+/* I64SIZE:
+ * This symbol contains the sizeof(I64).
+ */
+/* U64SIZE:
+ * This symbol contains the sizeof(U64).
+ */
+/* NVSIZE:
+ * This symbol contains the sizeof(NV).
+ */
+/* NV_PRESERVES_UV:
+ * This symbol, if defined, indicates that a variable of type NVTYPE
+ * can preserve all the bits of a variable of type UVTYPE.
+ */
+/* NV_PRESERVES_UV_BITS:
+ * This symbol contains the number of bits a variable of type NVTYPE
+ * can preserve of a variable of type UVTYPE.
+ */
+/* NV_OVERFLOWS_INTEGERS_AT:
+ * This symbol gives the largest integer value that NVs can hold. This
+ * value + 1.0 cannot be stored accurately. It is expressed as constant
+ * floating point expression to reduce the chance of decimale/binary
+ * conversion issues. If it can not be determined, the value 0 is given.
+ */
+/* NV_ZERO_IS_ALLBITS_ZERO:
+ * This symbol, if defined, indicates that a variable of type NVTYPE
+ * stores 0.0 in memory as all bits zero.
+ */
+#define IVTYPE long /**/
+#define UVTYPE unsigned long /**/
+#define I8TYPE char /**/
+#define U8TYPE unsigned char /**/
+#define I16TYPE short /**/
+#define U16TYPE unsigned short /**/
+#define I32TYPE long /**/
+#define U32TYPE unsigned long /**/
+#ifdef HAS_QUAD
+#define I64TYPE long long /**/
+#define U64TYPE unsigned long long /**/
+#endif
+#define NVTYPE double /**/
+#define IVSIZE 4 /**/
+#define UVSIZE 4 /**/
+#define I8SIZE 1 /**/
+#define U8SIZE 1 /**/
+#define I16SIZE 2 /**/
+#define U16SIZE 2 /**/
+#define I32SIZE 4 /**/
+#define U32SIZE 4 /**/
+#ifdef HAS_QUAD
+#define I64SIZE 8 /**/
+#define U64SIZE 8 /**/
+#endif
+#define NVSIZE 8 /**/
+#define NV_PRESERVES_UV
+#define NV_PRESERVES_UV_BITS 32
+#define 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
+#define NV_ZERO_IS_ALLBITS_ZERO
+#if UVSIZE == 8
+# ifdef BYTEORDER
+# if BYTEORDER == 0x1234
+# undef BYTEORDER
+# define BYTEORDER 0x12345678
+# else
+# if BYTEORDER == 0x4321
+# undef BYTEORDER
+# define BYTEORDER 0x87654321
+# endif
+# endif
+# endif
+#endif
+
+/* IVdf:
+ * This symbol defines the format string used for printing a Perl IV
+ * as a signed decimal integer.
+ */
+/* UVuf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned decimal integer.
+ */
+/* UVof:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned octal integer.
+ */
+/* UVxf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned hexadecimal integer in lowercase abcdef.
+ */
+/* UVXf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned hexadecimal integer in uppercase ABCDEF.
+ */
+/* NVef:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %e-ish floating point format.
+ */
+/* NVff:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %f-ish floating point format.
+ */
+/* NVgf:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %g-ish floating point format.
+ */
+#define IVdf "ld" /**/
+#define UVuf "lu" /**/
+#define UVof "lo" /**/
+#define UVxf "lx" /**/
+#define UVXf "lX" /**/
+#define NVef "e" /**/
+#define NVff "f" /**/
+#define NVgf "g" /**/
+
+/* SELECT_MIN_BITS:
+ * This symbol 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(n/32), especially many little-endians do
+ * the latter. This is only useful if you have select(), naturally.
+ */
+#define SELECT_MIN_BITS 32 /**/
+
+/* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+#define STARTPERL "#!perl" /**/
+
+/* HAS_STDIO_STREAM_ARRAY:
+ * This symbol, if defined, tells that there is an array
+ * holding the stdio streams.
+ */
+/* STDIO_STREAM_ARRAY:
+ * This symbol tells the name of the array holding the stdio streams.
+ * Usual values include _iob, __iob, and __sF.
+ */
+/*#define HAS_STDIO_STREAM_ARRAY /**/
+#ifdef HAS_STDIO_STREAM_ARRAY
+#define STDIO_STREAM_ARRAY
+#endif
+
+/* GMTIME_MAX:
+ * This symbol contains the maximum value for the time_t offset that
+ * the system function gmtime () accepts, and defaults to 0
+ */
+/* GMTIME_MIN:
+ * This symbol contains the minimum value for the time_t offset that
+ * the system function gmtime () accepts, and defaults to 0
+ */
+/* LOCALTIME_MAX:
+ * This symbol contains the maximum value for the time_t offset that
+ * the system function localtime () accepts, and defaults to 0
+ */
+/* LOCALTIME_MIN:
+ * This symbol contains the minimum value for the time_t offset that
+ * the system function localtime () accepts, and defaults to 0
+ */
+#define GMTIME_MAX 2147483647 /**/
+#define GMTIME_MIN 0 /**/
+#define LOCALTIME_MAX 2147483647 /**/
+#define LOCALTIME_MIN 0 /**/
+
+/* USE_64_BIT_INT:
+ * This symbol, if defined, indicates that 64-bit integers should
+ * be used when available. If not defined, the native integers
+ * will be employed (be they 32 or 64 bits). The minimal possible
+ * 64-bitness is used, 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.
+ */
+/* USE_64_BIT_ALL:
+ * This symbol, if defined, indicates that 64-bit integers should
+ * be used when available. If not defined, the native integers
+ * will be used (be they 32 or 64 bits). 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 CPU at all or
+ * you may need at least to reboot your OS to 64-bit mode.
+ */
+#ifndef USE_64_BIT_INT
+/*#define USE_64_BIT_INT /**/
+#endif
+#ifndef USE_64_BIT_ALL
+/*#define USE_64_BIT_ALL /**/
+#endif
+
+/* USE_DTRACE:
+ * This symbol, if defined, indicates that Perl should
+ * be built with support for DTrace.
+ */
+/*#define USE_DTRACE /**/
+
+/* USE_FAST_STDIO:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use 'fast stdio'.
+ * Defaults to define in Perls 5.8 and earlier, to undef later.
+ */
+#ifndef USE_FAST_STDIO
+/*#define USE_FAST_STDIO /**/
+#endif
+
+/* USE_LARGE_FILES:
+ * This symbol, if defined, indicates that large file support
+ * should be used when available.
+ */
+#ifndef USE_LARGE_FILES
+#define USE_LARGE_FILES /**/
+#endif
+
+/* USE_LONG_DOUBLE:
+ * This symbol, if defined, indicates that long doubles should
+ * be used when available.
+ */
+#ifndef USE_LONG_DOUBLE
+/*#define USE_LONG_DOUBLE /**/
+#endif
+
+/* USE_MORE_BITS:
+ * This symbol, if defined, indicates that 64-bit interfaces and
+ * long doubles should be used when available.
+ */
+#ifndef USE_MORE_BITS
+/*#define USE_MORE_BITS /**/
+#endif
+
+/* MULTIPLICITY:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use multiplicity.
+ */
+#ifndef MULTIPLICITY
+#define MULTIPLICITY /**/
+#endif
+
+/* USE_PERLIO:
+ * This symbol, if defined, indicates that the PerlIO abstraction should
+ * be used throughout. If not defined, stdio should be
+ * used in a fully backward compatible manner.
+ */
+#ifndef USE_PERLIO
+#define USE_PERLIO /**/
+#endif
+
+/* USE_SOCKS:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use socks.
+ */
+#ifndef USE_SOCKS
+/*#define USE_SOCKS /**/
+#endif
+
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/cop.h b/Master/tlpkg/tlperl.straw/lib/CORE/cop.h
new file mode 100755
index 00000000000..f14fbf5ddb6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/cop.h
@@ -0,0 +1,905 @@
+/* cop.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * Control ops (cops) are one of the three ops OP_NEXTSTATE, OP_DBSTATE,
+ * and OP_SETSTATE that (loosely speaking) are separate statements.
+ * They hold information important for lexical state and error reporting.
+ * At run time, PL_curcop is set to point to the most recently executed cop,
+ * and thus can be used to determine our current state.
+ */
+
+/* A jmpenv packages the state required to perform a proper non-local jump.
+ * Note that there is a start_env initialized when perl starts, and top_env
+ * points to this initially, so top_env should always be non-null.
+ *
+ * Existence of a non-null top_env->je_prev implies it is valid to call
+ * longjmp() at that runlevel (we make sure start_env.je_prev is always
+ * null to ensure this).
+ *
+ * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+ * establish a local jmpenv to handle exception traps. Care must be taken
+ * to restore the previous value of je_mustcatch before exiting the
+ * stack frame iff JMPENV_PUSH was not called in that stack frame.
+ * GSAR 97-03-27
+ */
+
+struct jmpenv {
+ struct jmpenv * je_prev;
+ Sigjmp_buf je_buf; /* only for use if !je_throw */
+ int je_ret; /* last exception thrown */
+ bool je_mustcatch; /* need to call longjmp()? */
+};
+
+typedef struct jmpenv JMPENV;
+
+#ifdef OP_IN_REGISTER
+#define OP_REG_TO_MEM PL_opsave = op
+#define OP_MEM_TO_REG op = PL_opsave
+#else
+#define OP_REG_TO_MEM NOOP
+#define OP_MEM_TO_REG NOOP
+#endif
+
+/*
+ * How to build the first jmpenv.
+ *
+ * top_env needs to be non-zero. It points to an area
+ * in which longjmp() stuff is stored, as C callstack
+ * info there at least is thread specific this has to
+ * be per-thread. Otherwise a 'die' in a thread gives
+ * that thread the C stack of last thread to do an eval {}!
+ */
+
+#define JMPENV_BOOTSTRAP \
+ STMT_START { \
+ Zero(&PL_start_env, 1, JMPENV); \
+ PL_start_env.je_ret = -1; \
+ PL_start_env.je_mustcatch = TRUE; \
+ PL_top_env = &PL_start_env; \
+ } STMT_END
+
+/*
+ * PERL_FLEXIBLE_EXCEPTIONS
+ *
+ * All the flexible exceptions code has been removed.
+ * See the following threads for details:
+ *
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
+ *
+ * Joshua's original patches (which weren't applied) and discussion:
+ *
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
+ *
+ * Chip's reworked patch and discussion:
+ *
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
+ *
+ * The flaw in these patches (which went unnoticed at the time) was
+ * that they moved some code that could potentially die() out of the
+ * region protected by the setjmp()s. This caused exceptions within
+ * END blocks and such to not be handled by the correct setjmp().
+ *
+ * The original patches that introduces flexible exceptions were:
+ *
+ * http://public.activestate.com/cgi-bin/perlbrowse?patch=3386
+ * http://public.activestate.com/cgi-bin/perlbrowse?patch=5162
+ */
+
+#define dJMPENV JMPENV cur_env
+
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
+ (void*)&cur_env, (void*)PL_top_env)); \
+ cur_env.je_prev = PL_top_env; \
+ OP_REG_TO_MEM; \
+ cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
+ OP_MEM_TO_REG; \
+ PL_top_env = &cur_env; \
+ cur_env.je_mustcatch = FALSE; \
+ (v) = cur_env.je_ret; \
+ } STMT_END
+
+#define JMPENV_POP \
+ STMT_START { \
+ DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n", \
+ (void*)PL_top_env, (void*)cur_env.je_prev)); \
+ PL_top_env = cur_env.je_prev; \
+ } STMT_END
+
+#define JMPENV_JUMP(v) \
+ STMT_START { \
+ OP_REG_TO_MEM; \
+ if (PL_top_env->je_prev) \
+ PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ if ((v) == 2) \
+ PerlProc_exit(STATUS_EXIT); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ PerlProc_exit(1); \
+ } STMT_END
+
+#define CATCH_GET (PL_top_env->je_mustcatch)
+#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
+
+
+#include "mydtrace.h"
+
+struct cop {
+ BASEOP
+ /* On LP64 putting this here takes advantage of the fact that BASEOP isn't
+ an exact multiple of 8 bytes to save structure padding. */
+ line_t cop_line; /* line # of this command */
+ char * cop_label; /* label for this construct */
+#ifdef USE_ITHREADS
+ char * cop_stashpv; /* package line was compiled in */
+ char * cop_file; /* file name the following line # is from */
+#else
+ HV * cop_stash; /* package line was compiled in */
+ GV * cop_filegv; /* file the following line # is from */
+#endif
+ U32 cop_hints; /* hints bits from pragmata */
+ U32 cop_seq; /* parse sequence number */
+ /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *: */
+ STRLEN * cop_warnings; /* lexical warnings bitmask */
+ /* compile time state of %^H. See the comment in op.c for how this is
+ used to recreate a hash to return from caller. */
+ struct refcounted_he * cop_hints_hash;
+};
+
+#ifdef USE_ITHREADS
+# define CopFILE(c) ((c)->cop_file)
+# define CopFILEGV(c) (CopFILE(c) \
+ ? gv_fetchfile(CopFILE(c)) : NULL)
+
+# ifdef NETWARE
+# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
+# define CopFILE_setn(c,pv,l) ((c)->cop_file = savepv((pv),(l)))
+# else
+# define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv))
+# define CopFILE_setn(c,pv,l) ((c)->cop_file = savesharedpvn((pv),(l)))
+# endif
+
+# define CopFILESV(c) (CopFILE(c) \
+ ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
+# define CopFILEAV(c) (CopFILE(c) \
+ ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
+# ifdef DEBUGGING
+# define CopFILEAVx(c) (assert(CopFILE(c)), \
+ GvAV(gv_fetchfile(CopFILE(c))))
+# else
+# define CopFILEAVx(c) (GvAV(gv_fetchfile(CopFILE(c))))
+# endif
+# define CopSTASHPV(c) ((c)->cop_stashpv)
+
+# ifdef NETWARE
+# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
+# else
+# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv))
+# endif
+
+# define CopSTASH(c) (CopSTASHPV(c) \
+ ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
+# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
+# define CopSTASH_eq(c,hv) ((hv) && stashpv_hvname_match(c,hv))
+# define CopLABEL(c) ((c)->cop_label)
+# define CopLABEL_set(c,pv) (CopLABEL(c) = (pv))
+# ifdef NETWARE
+# define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
+# define CopFILE_free(c) SAVECOPFILE_FREE(c)
+# define CopLABEL_free(c) SAVECOPLABEL_FREE(c)
+# define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
+# else
+# define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c))
+# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
+# define CopLABEL_free(c) (PerlMemShared_free(CopLABEL(c)),(CopLABEL(c) = NULL))
+# define CopLABEL_alloc(pv) ((pv)?savesharedpv(pv):NULL)
+# endif
+#else
+# define CopFILEGV(c) ((c)->cop_filegv)
+# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
+# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
+# define CopFILE_setn(c,pv,l) CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0))
+# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
+# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
+# ifdef DEBUGGING
+# define CopFILEAVx(c) (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
+# else
+# define CopFILEAVx(c) (GvAV(CopFILEGV(c)))
+# endif
+# define CopFILE(c) (CopFILEGV(c) && GvSV(CopFILEGV(c)) \
+ ? SvPVX(GvSV(CopFILEGV(c))) : NULL)
+# define CopSTASH(c) ((c)->cop_stash)
+# define CopLABEL(c) ((c)->cop_label)
+# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
+# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
+ /* cop_stash is not refcounted */
+# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
+# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
+# define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
+# define CopLABEL_set(c,pv) (CopLABEL(c) = (pv))
+# define CopSTASH_free(c)
+# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
+# define CopLABEL_free(c) (Safefree(CopLABEL(c)),(CopLABEL(c) = NULL))
+
+#endif /* USE_ITHREADS */
+
+#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
+#define CopLINE(c) ((c)->cop_line)
+#define CopLINE_inc(c) (++CopLINE(c))
+#define CopLINE_dec(c) (--CopLINE(c))
+#define CopLINE_set(c,l) (CopLINE(c) = (l))
+
+/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
+#ifdef MACOS_TRADITIONAL
+# define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
+#else
+# define OutCopFILE(c) CopFILE(c)
+#endif
+
+/* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
+ HINT_ARYBASE is set to indicate this.
+ Setting it is ineficient due to the need to create 2 mortal SVs, but as
+ using $[ is highly discouraged, no sane Perl code will be using it. */
+#define CopARYBASE_get(c) \
+ ((CopHINTS_get(c) & HINT_ARYBASE) \
+ ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0, \
+ "$[", 2, 0, 0)) \
+ : 0)
+#define CopARYBASE_set(c, b) STMT_START { \
+ if (b || ((c)->cop_hints & HINT_ARYBASE)) { \
+ (c)->cop_hints |= HINT_ARYBASE; \
+ if ((c) == &PL_compiling) \
+ PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE; \
+ (c)->cop_hints_hash \
+ = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \
+ newSVpvs_flags("$[", SVs_TEMP), \
+ sv_2mortal(newSViv(b))); \
+ } \
+ } STMT_END
+
+/* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */
+#define CopHINTS_get(c) ((c)->cop_hints + 0)
+#define CopHINTS_set(c, h) STMT_START { \
+ (c)->cop_hints = (h); \
+ } STMT_END
+
+/*
+ * Here we have some enormously heavy (or at least ponderous) wizardry.
+ */
+
+/* subroutine context */
+struct block_sub {
+ CV * cv;
+ GV * gv;
+ GV * dfoutgv;
+ AV * savearray;
+ AV * argarray;
+ I32 olddepth;
+ U8 hasargs;
+ U8 lval; /* XXX merge lval and hasargs? */
+ PAD *oldcomppad;
+ OP * retop; /* op to execute on exit from sub */
+};
+
+/* base for the next two macros. Don't use directly.
+ * Note that the refcnt of the cv is incremented twice; The CX one is
+ * decremented by LEAVESUB, the other by LEAVE. */
+
+#define PUSHSUB_BASE(cx) \
+ ENTRY_PROBE(GvENAME(CvGV(cv)), \
+ CopFILE((const COP *)CvSTART(cv)), \
+ CopLINE((const COP *)CvSTART(cv))); \
+ \
+ cx->blk_sub.cv = cv; \
+ cx->blk_sub.olddepth = CvDEPTH(cv); \
+ cx->blk_sub.hasargs = hasargs; \
+ cx->blk_sub.retop = NULL; \
+ if (!CvDEPTH(cv)) { \
+ SvREFCNT_inc_simple_void_NN(cv); \
+ SvREFCNT_inc_simple_void_NN(cv); \
+ SAVEFREESV(cv); \
+ }
+
+
+#define PUSHSUB(cx) \
+ PUSHSUB_BASE(cx) \
+ cx->blk_sub.lval = PL_op->op_private & \
+ (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
+
+/* variant for use by OP_DBSTATE, where op_private holds hint bits */
+#define PUSHSUB_DB(cx) \
+ PUSHSUB_BASE(cx) \
+ cx->blk_sub.lval = 0;
+
+
+#define PUSHFORMAT(cx) \
+ cx->blk_sub.cv = cv; \
+ cx->blk_sub.gv = gv; \
+ cx->blk_sub.retop = NULL; \
+ cx->blk_sub.hasargs = 0; \
+ cx->blk_sub.dfoutgv = PL_defoutgv; \
+ SvREFCNT_inc_void(cx->blk_sub.dfoutgv)
+
+#define POP_SAVEARRAY() \
+ STMT_START { \
+ SvREFCNT_dec(GvAV(PL_defgv)); \
+ GvAV(PL_defgv) = cx->blk_sub.savearray; \
+ } STMT_END
+
+/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
+ * leave any (a fast av_clear(ary), basically) */
+#define CLEAR_ARGARRAY(ary) \
+ STMT_START { \
+ AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \
+ AvARRAY(ary) = AvALLOC(ary); \
+ AvFILLp(ary) = -1; \
+ } STMT_END
+
+#define POPSUB(cx,sv) \
+ STMT_START { \
+ RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)), \
+ CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \
+ CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \
+ \
+ if (CxHASARGS(cx)) { \
+ POP_SAVEARRAY(); \
+ /* abandon @_ if it got reified */ \
+ if (AvREAL(cx->blk_sub.argarray)) { \
+ const SSize_t fill = AvFILLp(cx->blk_sub.argarray); \
+ SvREFCNT_dec(cx->blk_sub.argarray); \
+ cx->blk_sub.argarray = newAV(); \
+ av_extend(cx->blk_sub.argarray, fill); \
+ AvREIFY_only(cx->blk_sub.argarray); \
+ CX_CURPAD_SV(cx->blk_sub, 0) = MUTABLE_SV(cx->blk_sub.argarray); \
+ } \
+ else { \
+ CLEAR_ARGARRAY(cx->blk_sub.argarray); \
+ } \
+ } \
+ sv = MUTABLE_SV(cx->blk_sub.cv); \
+ if (sv && (CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth)) \
+ sv = NULL; \
+ } STMT_END
+
+#define LEAVESUB(sv) \
+ STMT_START { \
+ if (sv) \
+ SvREFCNT_dec(sv); \
+ } STMT_END
+
+#define POPFORMAT(cx) \
+ setdefout(cx->blk_sub.dfoutgv); \
+ SvREFCNT_dec(cx->blk_sub.dfoutgv);
+
+/* eval context */
+struct block_eval {
+ U8 old_in_eval;
+ U16 old_op_type;
+ SV * old_namesv;
+ OP * old_eval_root;
+ SV * cur_text;
+ CV * cv;
+ OP * retop; /* op to execute on exit from eval */
+ JMPENV * cur_top_env; /* value of PL_top_env when eval CX created */
+};
+
+#define CxOLD_IN_EVAL(cx) (0 + (cx)->blk_eval.old_in_eval)
+#define CxOLD_OP_TYPE(cx) (0 + (cx)->blk_eval.old_op_type)
+
+#define PUSHEVAL(cx,n,fgv) \
+ STMT_START { \
+ cx->blk_eval.old_in_eval = PL_in_eval; \
+ cx->blk_eval.old_op_type = PL_op->op_type; \
+ cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL); \
+ cx->blk_eval.old_eval_root = PL_eval_root; \
+ cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL; \
+ cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */ \
+ cx->blk_eval.retop = NULL; \
+ cx->blk_eval.cur_top_env = PL_top_env; \
+ } STMT_END
+
+#define POPEVAL(cx) \
+ STMT_START { \
+ PL_in_eval = CxOLD_IN_EVAL(cx); \
+ optype = CxOLD_OP_TYPE(cx); \
+ PL_eval_root = cx->blk_eval.old_eval_root; \
+ if (cx->blk_eval.old_namesv) \
+ sv_2mortal(cx->blk_eval.old_namesv); \
+ } STMT_END
+
+/* loop context */
+struct block_loop {
+ char * label;
+ I32 resetsp;
+ LOOP * my_op; /* My op, that contains redo, next and last ops. */
+ /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
+ why next_op is conditionally defined below.) */
+#ifdef USE_ITHREADS
+ void * iterdata;
+ PAD *oldcomppad;
+#else
+ OP * next_op;
+ SV ** itervar;
+#endif
+ /* Eliminated in blead by change 33080, but for binary compatibility
+ reasons we can't remove it from the middle of a struct in a maintenance
+ release, so it gets to stay, and be set to NULL. */
+ SV * itersave;
+ /* (from inspection of source code) for a .. range of strings this is the
+ current string. */
+ SV * iterlval;
+ /* (from inspection of source code) for a foreach loop this is the array
+ being iterated over. For a .. range of numbers it's the current value.
+ A check is often made on the SvTYPE of iterary to determine whether
+ we are iterating over an array or a range. (numbers or strings) */
+ AV * iterary;
+ IV iterix;
+ /* (from inspection of source code) for a .. range of numbers this is the
+ maximum value. */
+ IV itermax;
+};
+/* It might be possible to squeeze this structure further. As best I can tell
+ itermax and iterlval are never used at the same time, so it might be possible
+ to make them into a union. However, I'm not confident that there are enough
+ flag bits/NULLable pointers in this structure alone to encode which is
+ active. There is, however, U8 of space free in struct block, which could be
+ used. Right now it may not be worth squeezing this structure further, as it's
+ the largest part of struct block, and currently struct block is 64 bytes on
+ an ILP32 system, which will give good cache alignment.
+*/
+
+#ifdef USE_ITHREADS
+# define CxITERVAR(c) \
+ ((c)->blk_loop.iterdata \
+ ? (CxPADLOOP(cx) \
+ ? &CX_CURPAD_SV( (c)->blk_loop, \
+ INT2PTR(PADOFFSET, (c)->blk_loop.iterdata)) \
+ : &GvSV((GV*)(c)->blk_loop.iterdata)) \
+ : (SV**)NULL)
+# define CX_ITERDATA_SET(cx,idata) \
+ CX_CURPAD_SAVE(cx->blk_loop); \
+ cx->blk_loop.itersave = NULL; \
+ cx->blk_loop.iterdata = (idata);
+#else
+# define CxITERVAR(c) ((c)->blk_loop.itervar)
+# define CX_ITERDATA_SET(cx,ivar) \
+ cx->blk_loop.itersave = NULL; \
+ cx->blk_loop.itervar = (SV**)(ivar);
+#endif
+#define CxLABEL(c) (0 + (c)->blk_loop.label)
+#define CxHASARGS(c) (0 + (c)->blk_sub.hasargs)
+#define CxLVAL(c) (0 + (c)->blk_sub.lval)
+
+#ifdef USE_ITHREADS
+# define PUSHLOOP_OP_NEXT /* No need to do anything. */
+# define CX_LOOP_NEXTOP_GET(cx) ((cx)->blk_loop.my_op->op_nextop + 0)
+#else
+# define PUSHLOOP_OP_NEXT cx->blk_loop.next_op = cLOOP->op_nextop
+# define CX_LOOP_NEXTOP_GET(cx) ((cx)->blk_loop.next_op + 0)
+#endif
+
+#define PUSHLOOP(cx, dat, s) \
+ cx->blk_loop.label = PL_curcop->cop_label; \
+ cx->blk_loop.resetsp = s - PL_stack_base; \
+ cx->blk_loop.my_op = cLOOP; \
+ PUSHLOOP_OP_NEXT; \
+ cx->blk_loop.iterlval = NULL; \
+ cx->blk_loop.iterary = NULL; \
+ cx->blk_loop.iterix = -1; \
+ CX_ITERDATA_SET(cx,dat);
+
+#define POPLOOP(cx) \
+ SvREFCNT_dec(cx->blk_loop.iterlval); \
+ if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
+ SvREFCNT_dec(cx->blk_loop.iterary);
+
+/* given/when context */
+struct block_givwhen {
+ OP *leave_op;
+};
+
+#define PUSHGIVEN(cx) \
+ cx->blk_givwhen.leave_op = cLOGOP->op_other;
+
+#define PUSHWHEN PUSHGIVEN
+
+/* context common to subroutines, evals and loops */
+struct block {
+ U16 blku_type; /* what kind of context this is */
+ U8 blku_gimme; /* is this block running in list context? */
+ U8 blku_spare; /* Padding to match with struct subst */
+ I32 blku_oldsp; /* stack pointer to copy stuff down to */
+ COP * blku_oldcop; /* old curcop pointer */
+ I32 blku_oldmarksp; /* mark stack index */
+ I32 blku_oldscopesp; /* scope stack index */
+ PMOP * blku_oldpm; /* values of pattern match vars */
+
+ union {
+ struct block_sub blku_sub;
+ struct block_eval blku_eval;
+ struct block_loop blku_loop;
+ struct block_givwhen blku_givwhen;
+ } blk_u;
+};
+#define blk_oldsp cx_u.cx_blk.blku_oldsp
+#define blk_oldcop cx_u.cx_blk.blku_oldcop
+#define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp
+#define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp
+#define blk_oldpm cx_u.cx_blk.blku_oldpm
+#define blk_gimme cx_u.cx_blk.blku_gimme
+#define blk_sub cx_u.cx_blk.blk_u.blku_sub
+#define blk_eval cx_u.cx_blk.blk_u.blku_eval
+#define blk_loop cx_u.cx_blk.blk_u.blku_loop
+#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
+
+/* Enter a block. */
+#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
+ cx->cx_type = t, \
+ cx->blk_oldsp = sp - PL_stack_base, \
+ cx->blk_oldcop = PL_curcop, \
+ cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \
+ cx->blk_oldscopesp = PL_scopestack_ix, \
+ cx->blk_oldpm = PL_curpm, \
+ cx->blk_gimme = (U8)gimme; \
+ DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
+ (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
+
+/* Exit a block (RETURN and LAST). */
+#define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \
+ newsp = PL_stack_base + cx->blk_oldsp, \
+ PL_curcop = cx->blk_oldcop, \
+ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
+ PL_scopestack_ix = cx->blk_oldscopesp, \
+ pm = cx->blk_oldpm, \
+ gimme = cx->blk_gimme; \
+ DEBUG_SCOPE("POPBLOCK"); \
+ DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n", \
+ (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
+
+/* Continue a block elsewhere (NEXT and REDO). */
+#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
+ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
+ PL_scopestack_ix = cx->blk_oldscopesp, \
+ PL_curpm = cx->blk_oldpm; \
+ DEBUG_SCOPE("TOPBLOCK");
+
+/* substitution context */
+struct subst {
+ U16 sbu_type; /* what kind of context this is */
+ U8 sbu_once; /* Actually both booleans, but U8 to matches */
+ U8 sbu_rxtainted; /* struct block */
+ I32 sbu_iters;
+ I32 sbu_maxiters;
+ I32 sbu_rflags;
+ I32 sbu_oldsave;
+ char * sbu_orig;
+ SV * sbu_dstr;
+ SV * sbu_targ;
+ char * sbu_s;
+ char * sbu_m;
+ char * sbu_strend;
+ void * sbu_rxres;
+ REGEXP * sbu_rx;
+};
+#define sb_iters cx_u.cx_subst.sbu_iters
+#define sb_maxiters cx_u.cx_subst.sbu_maxiters
+#define sb_rflags cx_u.cx_subst.sbu_rflags
+#define sb_oldsave cx_u.cx_subst.sbu_oldsave
+#define sb_once cx_u.cx_subst.sbu_once
+#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted
+#define sb_orig cx_u.cx_subst.sbu_orig
+#define sb_dstr cx_u.cx_subst.sbu_dstr
+#define sb_targ cx_u.cx_subst.sbu_targ
+#define sb_s cx_u.cx_subst.sbu_s
+#define sb_m cx_u.cx_subst.sbu_m
+#define sb_strend cx_u.cx_subst.sbu_strend
+#define sb_rxres cx_u.cx_subst.sbu_rxres
+#define sb_rx cx_u.cx_subst.sbu_rx
+
+#define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
+ cx->sb_iters = iters, \
+ cx->sb_maxiters = maxiters, \
+ cx->sb_rflags = r_flags, \
+ cx->sb_oldsave = oldsave, \
+ cx->sb_once = once, \
+ cx->sb_rxtainted = rxtainted, \
+ cx->sb_orig = orig, \
+ cx->sb_dstr = dstr, \
+ cx->sb_targ = targ, \
+ cx->sb_s = s, \
+ cx->sb_m = m, \
+ cx->sb_strend = strend, \
+ cx->sb_rxres = NULL, \
+ cx->sb_rx = rx, \
+ cx->cx_type = CXt_SUBST; \
+ rxres_save(&cx->sb_rxres, rx); \
+ (void)ReREFCNT_inc(rx)
+
+#define CxONCE(cx) (0 + cx->sb_once)
+
+#define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \
+ rxres_free(&cx->sb_rxres); \
+ ReREFCNT_dec(cx->sb_rx)
+
+struct context {
+ union {
+ struct block cx_blk;
+ struct subst cx_subst;
+ } cx_u;
+};
+#define cx_type cx_u.cx_subst.sbu_type
+
+#define CXTYPEMASK 0xff
+#define CXt_NULL 0
+#define CXt_SUB 1
+#define CXt_EVAL 2
+#define CXt_LOOP 3
+#define CXt_SUBST 4
+#define CXt_BLOCK 5
+#define CXt_FORMAT 6
+#define CXt_GIVEN 7
+#define CXt_WHEN 8
+
+/* private flags for CXt_SUB and CXt_NULL */
+#define CXp_MULTICALL 0x00000400 /* part of a multicall (so don't
+ tear down context on exit). */
+
+/* private flags for CXt_EVAL */
+#define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */
+#define CXp_TRYBLOCK 0x00000200 /* eval{}, not eval'' or similar */
+
+/* private flags for CXt_LOOP */
+#define CXp_FOREACH 0x00000200 /* a foreach loop */
+#define CXp_FOR_DEF 0x00000400 /* foreach using $_ */
+#ifdef USE_ITHREADS
+# define CXp_PADVAR 0x00000100 /* itervar lives on pad, iterdata
+ has pad offset; if not set,
+ iterdata holds GV* */
+# define CxPADLOOP(c) (((c)->cx_type & (CXt_LOOP|CXp_PADVAR)) \
+ == (CXt_LOOP|CXp_PADVAR))
+#endif
+
+#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
+#define CxMULTICALL(c) (((c)->cx_type & CXp_MULTICALL) \
+ == CXp_MULTICALL)
+#define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \
+ == (CXt_EVAL|CXp_REAL))
+#define CxTRYBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK)) \
+ == (CXt_EVAL|CXp_TRYBLOCK))
+#define CxFOREACH(c) (((c)->cx_type & (CXTYPEMASK|CXp_FOREACH)) \
+ == (CXt_LOOP|CXp_FOREACH))
+#define CxFOREACHDEF(c) (((c)->cx_type & (CXTYPEMASK|CXp_FOREACH|CXp_FOR_DEF))\
+ == (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))
+
+#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
+
+/*
+=head1 "Gimme" Values
+*/
+
+/*
+=for apidoc AmU||G_SCALAR
+Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and
+L<perlcall>.
+
+=for apidoc AmU||G_ARRAY
+Used to indicate list context. See C<GIMME_V>, C<GIMME> and
+L<perlcall>.
+
+=for apidoc AmU||G_VOID
+Used to indicate void context. See C<GIMME_V> and L<perlcall>.
+
+=for apidoc AmU||G_DISCARD
+Indicates that arguments returned from a callback should be discarded. See
+L<perlcall>.
+
+=for apidoc AmU||G_EVAL
+
+Used to force a Perl C<eval> wrapper around a callback. See
+L<perlcall>.
+
+=for apidoc AmU||G_NOARGS
+
+Indicates that no arguments are being sent to a callback. See
+L<perlcall>.
+
+=cut
+*/
+
+#define G_SCALAR 0
+#define G_ARRAY 1
+#define G_VOID 128 /* skip this bit when adding flags below */
+#define G_WANT (128|1)
+
+/* extra flags for Perl_call_* routines */
+#define G_DISCARD 2 /* Call FREETMPS.
+ Don't change this without consulting the
+ hash actions codes defined in hv.h */
+#define G_EVAL 4 /* Assume eval {} around subroutine call. */
+#define G_NOARGS 8 /* Don't construct a @_ array. */
+#define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */
+#define G_NODEBUG 32 /* Disable debugging at toplevel. */
+#define G_METHOD 64 /* Calling method. */
+#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or
+ fold_constants. */
+
+/* flag bits for PL_in_eval */
+#define EVAL_NULL 0 /* not in an eval */
+#define EVAL_INEVAL 1 /* some enclosing scope is an eval */
+#define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */
+#define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */
+#define EVAL_INREQUIRE 8 /* The code is being required. */
+
+/* Support for switching (stack and block) contexts.
+ * This ensures magic doesn't invalidate local stack and cx pointers.
+ */
+
+#define PERLSI_UNKNOWN -1
+#define PERLSI_UNDEF 0
+#define PERLSI_MAIN 1
+#define PERLSI_MAGIC 2
+#define PERLSI_SORT 3
+#define PERLSI_SIGNAL 4
+#define PERLSI_OVERLOAD 5
+#define PERLSI_DESTROY 6
+#define PERLSI_WARNHOOK 7
+#define PERLSI_DIEHOOK 8
+#define PERLSI_REQUIRE 9
+
+struct stackinfo {
+ AV * si_stack; /* stack for current runlevel */
+ PERL_CONTEXT * si_cxstack; /* context stack for runlevel */
+ struct stackinfo * si_prev;
+ struct stackinfo * si_next;
+ I32 si_cxix; /* current context index */
+ I32 si_cxmax; /* maximum allocated index */
+ I32 si_type; /* type of runlevel */
+ I32 si_markoff; /* offset where markstack begins for us.
+ * currently used only with DEBUGGING,
+ * but not #ifdef-ed for bincompat */
+};
+
+typedef struct stackinfo PERL_SI;
+
+#define cxstack (PL_curstackinfo->si_cxstack)
+#define cxstack_ix (PL_curstackinfo->si_cxix)
+#define cxstack_max (PL_curstackinfo->si_cxmax)
+
+#ifdef DEBUGGING
+# define SET_MARK_OFFSET \
+ PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
+#else
+# define SET_MARK_OFFSET NOOP
+#endif
+
+#define PUSHSTACKi(type) \
+ STMT_START { \
+ PERL_SI *next = PL_curstackinfo->si_next; \
+ if (!next) { \
+ next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
+ next->si_prev = PL_curstackinfo; \
+ PL_curstackinfo->si_next = next; \
+ } \
+ next->si_type = type; \
+ next->si_cxix = -1; \
+ AvFILLp(next->si_stack) = 0; \
+ SWITCHSTACK(PL_curstack,next->si_stack); \
+ PL_curstackinfo = next; \
+ SET_MARK_OFFSET; \
+ } STMT_END
+
+#define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
+
+/* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
+ * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
+#define POPSTACK \
+ STMT_START { \
+ dSP; \
+ PERL_SI * const prev = PL_curstackinfo->si_prev; \
+ if (!prev) { \
+ PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); \
+ my_exit(1); \
+ } \
+ SWITCHSTACK(PL_curstack,prev->si_stack); \
+ /* don't free prev here, free them all at the END{} */ \
+ PL_curstackinfo = prev; \
+ } STMT_END
+
+#define POPSTACK_TO(s) \
+ STMT_START { \
+ while (PL_curstack != s) { \
+ dounwind(-1); \
+ POPSTACK; \
+ } \
+ } STMT_END
+
+#define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
+#define IN_PERL_RUNTIME (PL_curcop != &PL_compiling)
+
+/*
+=head1 Multicall Functions
+
+=for apidoc Ams||dMULTICALL
+Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||PUSH_MULTICALL
+Opening bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||MULTICALL
+Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||POP_MULTICALL
+Closing bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=cut
+*/
+
+#define dMULTICALL \
+ SV **newsp; /* set by POPBLOCK */ \
+ PERL_CONTEXT *cx; \
+ CV *multicall_cv; \
+ OP *multicall_cop; \
+ bool multicall_oldcatch; \
+ U8 hasargs = 0 /* used by PUSHSUB */
+
+#define PUSH_MULTICALL(the_cv) \
+ STMT_START { \
+ CV * const _nOnclAshIngNamE_ = the_cv; \
+ CV * const cv = _nOnclAshIngNamE_; \
+ AV * const padlist = CvPADLIST(cv); \
+ ENTER; \
+ multicall_oldcatch = CATCH_GET; \
+ SAVETMPS; SAVEVPTR(PL_op); \
+ CATCH_SET(TRUE); \
+ PUSHSTACKi(PERLSI_SORT); \
+ PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp); \
+ PUSHSUB(cx); \
+ if (++CvDEPTH(cv) >= 2) { \
+ PERL_STACK_OVERFLOW_CHECK(); \
+ Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
+ } \
+ SAVECOMPPAD(); \
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
+ multicall_cv = cv; \
+ multicall_cop = CvSTART(cv); \
+ } STMT_END
+
+#define MULTICALL \
+ STMT_START { \
+ PL_op = multicall_cop; \
+ CALLRUNOPS(aTHX); \
+ } STMT_END
+
+#define POP_MULTICALL \
+ STMT_START { \
+ LEAVESUB(multicall_cv); \
+ CvDEPTH(multicall_cv)--; \
+ POPBLOCK(cx,PL_curpm); \
+ POPSTACK; \
+ CATCH_SET(multicall_oldcatch); \
+ LEAVE; \
+ SPAGAIN; \
+ } STMT_END
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/cv.h b/Master/tlpkg/tlperl.straw/lib/CORE/cv.h
new file mode 100755
index 00000000000..24f59023b0a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/cv.h
@@ -0,0 +1,275 @@
+/* cv.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999, 2000, 2001,
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/* This structure must the beginning of XPVFM in sv.h */
+
+struct xpvcv {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv;
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32; /* depth, >= 2 indicates recursive call */
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ union {
+ OP * xcv_start;
+ ANY xcv_xsubany;
+ } xcv_start_u;
+ union {
+ OP * xcv_root;
+ void (*xcv_xsub) (pTHX_ CV*);
+ } xcv_root_u;
+ GV * xcv_gv;
+ char * xcv_file;
+ PADLIST * xcv_padlist;
+ CV * xcv_outside;
+ U32 xcv_outside_seq; /* the COP sequence (at the point of our
+ * compilation) in the lexically enclosing
+ * sub */
+ cv_flags_t xcv_flags;
+};
+
+typedef struct {
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv;
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32; /* depth, >= 2 indicates recursive call */
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ union {
+ OP * xcv_start;
+ ANY xcv_xsubany;
+ } xcv_start_u;
+ union {
+ OP * xcv_root;
+ void (*xcv_xsub) (pTHX_ CV*);
+ } xcv_root_u;
+ GV * xcv_gv;
+ char * xcv_file;
+ PADLIST * xcv_padlist;
+ CV * xcv_outside;
+ U32 xcv_outside_seq; /* the COP sequence (at the point of our
+ * compilation) in the lexically enclosing
+ * sub */
+ cv_flags_t xcv_flags;
+} xpvcv_allocated;
+
+/*
+=head1 Handy Values
+
+=for apidoc AmU||Nullcv
+Null CV pointer.
+
+=head1 CV Manipulation Functions
+
+=for apidoc Am|HV*|CvSTASH|CV* cv
+Returns the stash of the CV.
+
+=cut
+*/
+
+#define Nullcv Null(CV*)
+
+#define CvSTASH(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_stash
+#define CvSTART(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_start
+#define CvROOT(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_root
+#define CvXSUB(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_xsub
+#define CvXSUBANY(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_xsubany
+#define CvGV(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv
+#define CvFILE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file
+#ifdef USE_ITHREADS
+# define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = savepv(CopFILE(cop)))
+#else
+# define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = CopFILE(cop))
+#endif
+#define CvFILEGV(sv) (gv_fetchfile(CvFILE(sv)))
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define CvDEPTH(sv) (*({const CV *const _cvdepth = (const CV *)sv; \
+ assert(SvTYPE(_cvdepth) == SVt_PVCV); \
+ &((XPVCV*)SvANY(_cvdepth))->xiv_u.xivu_i32; \
+ }))
+#else
+# define CvDEPTH(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xiv_u.xivu_i32
+#endif
+#define CvPADLIST(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist
+#define CvOUTSIDE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside
+#define CvFLAGS(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_flags
+#define CvOUTSIDE_SEQ(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside_seq
+
+#define CVf_METHOD 0x0001 /* CV is explicitly marked as a method */
+#define CVf_LOCKED 0x0002 /* CV locks itself or first arg on entry */
+#define CVf_LVALUE 0x0004 /* CV return value can be used as lvalue */
+
+#define CVf_WEAKOUTSIDE 0x0010 /* CvOUTSIDE isn't ref counted */
+#define CVf_CLONE 0x0020 /* anon CV uses external lexicals */
+#define CVf_CLONED 0x0040 /* a clone of one of those */
+#define CVf_ANON 0x0080 /* CvGV() can't be trusted */
+#define CVf_UNIQUE 0x0100 /* sub is only called once (eg PL_main_cv,
+ * require, eval). */
+#define CVf_NODEBUG 0x0200 /* no DB::sub indirection for this CV
+ (esp. useful for special XSUBs) */
+#define CVf_CONST 0x0400 /* inlinable sub */
+#define CVf_ISXSUB 0x0800 /* CV is an XSUB, not pure perl. */
+
+/* This symbol for optimised communication between toke.c and op.c: */
+#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)
+
+#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE)
+#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE)
+#define CvCLONE_off(cv) (CvFLAGS(cv) &= ~CVf_CLONE)
+
+#define CvCLONED(cv) (CvFLAGS(cv) & CVf_CLONED)
+#define CvCLONED_on(cv) (CvFLAGS(cv) |= CVf_CLONED)
+#define CvCLONED_off(cv) (CvFLAGS(cv) &= ~CVf_CLONED)
+
+#define CvANON(cv) (CvFLAGS(cv) & CVf_ANON)
+#define CvANON_on(cv) (CvFLAGS(cv) |= CVf_ANON)
+#define CvANON_off(cv) (CvFLAGS(cv) &= ~CVf_ANON)
+
+#define CvUNIQUE(cv) (CvFLAGS(cv) & CVf_UNIQUE)
+#define CvUNIQUE_on(cv) (CvFLAGS(cv) |= CVf_UNIQUE)
+#define CvUNIQUE_off(cv) (CvFLAGS(cv) &= ~CVf_UNIQUE)
+
+#define CvNODEBUG(cv) (CvFLAGS(cv) & CVf_NODEBUG)
+#define CvNODEBUG_on(cv) (CvFLAGS(cv) |= CVf_NODEBUG)
+#define CvNODEBUG_off(cv) (CvFLAGS(cv) &= ~CVf_NODEBUG)
+
+#define CvMETHOD(cv) (CvFLAGS(cv) & CVf_METHOD)
+#define CvMETHOD_on(cv) (CvFLAGS(cv) |= CVf_METHOD)
+#define CvMETHOD_off(cv) (CvFLAGS(cv) &= ~CVf_METHOD)
+
+#define CvLOCKED(cv) (CvFLAGS(cv) & CVf_LOCKED)
+#define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED)
+#define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED)
+
+#define CvLVALUE(cv) (CvFLAGS(cv) & CVf_LVALUE)
+#define CvLVALUE_on(cv) (CvFLAGS(cv) |= CVf_LVALUE)
+#define CvLVALUE_off(cv) (CvFLAGS(cv) &= ~CVf_LVALUE)
+
+#define CvEVAL(cv) (CvUNIQUE(cv) && !SvFAKE(cv))
+#define CvEVAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_off(cv))
+#define CvEVAL_off(cv) CvUNIQUE_off(cv)
+
+/* BEGIN|CHECK|INIT|UNITCHECK|END */
+#define CvSPECIAL(cv) (CvUNIQUE(cv) && SvFAKE(cv))
+#define CvSPECIAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_on(cv))
+#define CvSPECIAL_off(cv) (CvUNIQUE_off(cv),SvFAKE_off(cv))
+
+#define CvCONST(cv) (CvFLAGS(cv) & CVf_CONST)
+#define CvCONST_on(cv) (CvFLAGS(cv) |= CVf_CONST)
+#define CvCONST_off(cv) (CvFLAGS(cv) &= ~CVf_CONST)
+
+#define CvWEAKOUTSIDE(cv) (CvFLAGS(cv) & CVf_WEAKOUTSIDE)
+#define CvWEAKOUTSIDE_on(cv) (CvFLAGS(cv) |= CVf_WEAKOUTSIDE)
+#define CvWEAKOUTSIDE_off(cv) (CvFLAGS(cv) &= ~CVf_WEAKOUTSIDE)
+
+#define CvISXSUB(cv) (CvFLAGS(cv) & CVf_ISXSUB)
+#define CvISXSUB_on(cv) (CvFLAGS(cv) |= CVf_ISXSUB)
+#define CvISXSUB_off(cv) (CvFLAGS(cv) &= ~CVf_ISXSUB)
+
+/* Flags for newXS_flags */
+#define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */
+
+/*
+=head1 CV reference counts and CvOUTSIDE
+
+=for apidoc m|bool|CvWEAKOUTSIDE|CV *cv
+
+Each CV has a pointer, C<CvOUTSIDE()>, to its lexically enclosing
+CV (if any). Because pointers to anonymous sub prototypes are
+stored in C<&> pad slots, it is a possible to get a circular reference,
+with the parent pointing to the child and vice-versa. To avoid the
+ensuing memory leak, we do not increment the reference count of the CV
+pointed to by C<CvOUTSIDE> in the I<one specific instance> that the parent
+has a C<&> pad slot pointing back to us. In this case, we set the
+C<CvWEAKOUTSIDE> flag in the child. This allows us to determine under what
+circumstances we should decrement the refcount of the parent when freeing
+the child.
+
+There is a further complication with non-closure anonymous subs (i.e. those
+that do not refer to any lexicals outside that sub). In this case, the
+anonymous prototype is shared rather than being cloned. This has the
+consequence that the parent may be freed while there are still active
+children, eg
+
+ BEGIN { $a = sub { eval '$x' } }
+
+In this case, the BEGIN is freed immediately after execution since there
+are no active references to it: the anon sub prototype has
+C<CvWEAKOUTSIDE> set since it's not a closure, and $a points to the same
+CV, so it doesn't contribute to BEGIN's refcount either. When $a is
+executed, the C<eval '$x'> causes the chain of C<CvOUTSIDE>s to be followed,
+and the freed BEGIN is accessed.
+
+To avoid this, whenever a CV and its associated pad is freed, any
+C<&> entries in the pad are explicitly removed from the pad, and if the
+refcount of the pointed-to anon sub is still positive, then that
+child's C<CvOUTSIDE> is set to point to its grandparent. This will only
+occur in the single specific case of a non-closure anon prototype
+having one or more active references (such as C<$a> above).
+
+One other thing to consider is that a CV may be merely undefined
+rather than freed, eg C<undef &foo>. In this case, its refcount may
+not have reached zero, but we still delete its pad and its C<CvROOT> etc.
+Since various children may still have their C<CvOUTSIDE> pointing at this
+undefined CV, we keep its own C<CvOUTSIDE> for the time being, so that
+the chain of lexical scopes is unbroken. For example, the following
+should print 123:
+
+ my $x = 123;
+ sub tmp { sub { eval '$x' } }
+ my $a = tmp();
+ undef &tmp;
+ print $a->();
+
+=cut
+*/
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/dirent.h b/Master/tlpkg/tlperl.straw/lib/CORE/dirent.h
new file mode 100755
index 00000000000..50378254257
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/dirent.h
@@ -0,0 +1,53 @@
+/* dirent.h */
+
+/* djl
+ * Provide UNIX compatibility
+ */
+
+#ifndef _INC_DIRENT
+#define _INC_DIRENT
+
+/*
+ * NT versions of readdir(), etc
+ * From the MSDOS implementation
+ */
+
+/* Directory entry size */
+#ifdef DIRSIZ
+#undef DIRSIZ
+#endif
+#define DIRSIZ(rp) (sizeof(struct direct))
+
+/* needed to compile directory stuff */
+#define DIRENT direct
+
+/* structure of a directory entry */
+typedef struct direct
+{
+ long d_ino; /* inode number (not used by MS-DOS) */
+ long d_namlen; /* name length */
+ char d_name[257]; /* file name */
+} _DIRECT;
+
+/* structure for dir operations */
+typedef struct _dir_struc
+{
+ char *start; /* starting position */
+ char *curr; /* current position */
+ long size; /* allocated size of string table */
+ long nfiles; /* number of filenames in table */
+ struct direct dirstr; /* directory structure to return */
+ void* handle; /* system handle */
+ char *end; /* position after last filename */
+} DIR;
+
+#if 0 /* these have moved to win32iop.h */
+DIR * win32_opendir(const char *filename);
+struct direct * win32_readdir(DIR *dirp);
+long win32_telldir(DIR *dirp);
+void win32_seekdir(DIR *dirp,long loc);
+void win32_rewinddir(DIR *dirp);
+int win32_closedir(DIR *dirp);
+#endif
+
+#endif /* _INC_DIRENT */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/dosish.h b/Master/tlpkg/tlperl.straw/lib/CORE/dosish.h
new file mode 100755
index 00000000000..59bf122859b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/dosish.h
@@ -0,0 +1,214 @@
+/* dosish.h
+ *
+ * Copyright (C) 1993, 1994, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2007, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+#define ABORT() abort();
+
+#ifndef SH_PATH
+#define SH_PATH "/bin/sh"
+#endif
+
+#ifdef DJGPP
+# define BIT_BUCKET "nul"
+# define OP_BINARY O_BINARY
+# define PERL_SYS_INIT_BODY(c,v) \
+ MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v); PERLIO_INIT
+# define init_os_extras Perl_init_os_extras
+# define HAS_UTIME
+# define HAS_KILL
+ char *djgpp_pathexp (const char*);
+ void Perl_DJGPP_init (int *argcp,char ***argvp);
+# if (DJGPP==2 && DJGPP_MINOR < 2)
+# define NO_LOCALECONV_MON_THOUSANDS_SEP
+# endif
+# ifndef PERL_CORE
+# define PERL_FS_VER_FMT "%d_%d_%d"
+# endif
+# define PERL_FS_VERSION STRINGIFY(PERL_REVISION) "_" \
+ STRINGIFY(PERL_VERSION) "_" \
+ STRINGIFY(PERL_SUBVERSION)
+#else /* DJGPP */
+# ifdef WIN32
+# define PERL_SYS_INIT_BODY(c,v) \
+ MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v); PERLIO_INIT
+# define PERL_SYS_TERM_BODY() Perl_win32_term()
+# define BIT_BUCKET "nul"
+# else
+# ifdef NETWARE
+# define PERL_SYS_INIT_BODY(c,v) \
+ MALLOC_CHECK_TAINT2(*c,*v) Perl_nw5_init(c,v); PERLIO_INIT
+# define BIT_BUCKET "nwnul"
+# else
+# define PERL_SYS_INIT_BODY(c,v) \
+ MALLOC_CHECK_TAINT2(*c,*v); PERLIO_INIT
+# define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */
+# endif /* NETWARE */
+# endif
+#endif /* DJGPP */
+
+#ifndef PERL_SYS_TERM_BODY
+# define PERL_SYS_TERM_BODY() HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM
+#endif
+#define dXSUB_SYS
+
+/*
+ * 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were
+ * running on DOS, *and* if we had to cope with 16 bit memory addressing
+ * constraints, *and* we need to have memory allocated as unsigned long.
+ *
+ * with the advent of *real* compilers for DOS, they are not locked together.
+ * MSDOS means "I am running on MSDOS". HAS_64K_LIMIT means "I have
+ * 16 bit memory addressing constraints".
+ *
+ * if you need the last, try #DEFINE MEM_SIZE unsigned long.
+ */
+#ifdef MSDOS
+# ifndef DJGPP
+# define HAS_64K_LIMIT
+# endif
+#endif
+
+/* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+#undef USEMYBINMODE
+
+/* Stat_t:
+ * This symbol holds the type used to declare buffers for information
+ * returned by stat(). It's usually just struct stat. It may be necessary
+ * to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ * information.
+ */
+#if defined(WIN64) || defined(USE_LARGE_FILES)
+# if defined(__BORLANDC__) /* buk */
+# include <sys\stat.h>
+# define Stat_t struct stati64
+# else
+#define Stat_t struct _stati64
+# endif
+#else
+#if defined(UNDER_CE)
+#define Stat_t struct xcestat
+#else
+#define Stat_t struct stat
+#endif
+#endif
+
+/* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+#define USE_STAT_RDEV /**/
+
+/* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+#undef ACME_MESS /**/
+
+/* ALTERNATE_SHEBANG:
+ * This symbol, if defined, contains a "magic" string which may be used
+ * as the first line of a Perl program designed to be executed directly
+ * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG
+ * begins with a character other then #, then Perl will only treat
+ * it as a command line if it finds the string "perl" in the first
+ * word; otherwise it's treated as the first line of code in the script.
+ * (IOW, Perl won't hand off to another interpreter via an alternate
+ * shebang sequence that might be legal Perl code.)
+ */
+/* #define ALTERNATE_SHEBANG "#!" / **/
+
+#include <signal.h>
+
+/*
+ * fwrite1() should be a routine with the same calling sequence as fwrite(),
+ * but which outputs all of the bytes requested as a single stream (unlike
+ * fwrite() itself, which on some systems outputs several distinct records
+ * if the number_of_items parameter is >1).
+ */
+#define fwrite1 fwrite
+
+#define Fstat(fd,bufptr) fstat((fd),(bufptr))
+#ifdef DJGPP
+# define Fflush(fp) djgpp_fflush(fp)
+#else
+# define Fflush(fp) fflush(fp)
+#endif
+#define Mkdir(path,mode) mkdir((path),(mode))
+
+#ifndef WIN32
+# define Stat(fname,bufptr) stat((fname),(bufptr))
+#else
+# define HAS_IOCTL
+# define HAS_UTIME
+# define HAS_KILL
+# define HAS_WAIT
+# define HAS_CHOWN
+#endif /* WIN32 */
+
+/*
+ * <rich@phekda.freeserve.co.uk>: The DJGPP port has code that converts
+ * the return code of system() into the form that Unixy wait usually
+ * returns:
+ *
+ * - signal number in bits 0-6;
+ * - core dump flag in bit 7;
+ * - exit code in bits 8-15.
+ *
+ * Bits 0-7 are always zero for DJGPP, because it uses system().
+ * See djgpp.c.
+ *
+ * POSIX::W* use the W* macros from <sys/wait.h> to decode
+ * the return code. Unfortunately the W* macros for DJGPP use
+ * a different format than Unixy wait does. So there's a mismatch
+ * and, say, WEXITSTATUS($?) will return bogus values.
+ *
+ * So here we add hack to redefine the W* macros from DJGPP's <sys/wait.h>
+ * to work with our return-code conversion.
+ */
+
+#ifdef DJGPP
+
+#include <sys/wait.h>
+
+#undef WEXITSTATUS
+#undef WIFEXITED
+#undef WIFSIGNALED
+#undef WIFSTOPPED
+#undef WNOHANG
+#undef WSTOPSIG
+#undef WTERMSIG
+#undef WUNTRACED
+
+#define WEXITSTATUS(stat_val) ((stat_val) >> 8)
+#define WIFEXITED(stat_val) 0
+#define WIFSIGNALED(stat_val) 0
+#define WIFSTOPPED(stat_val) 0
+#define WNOHANG 0
+#define WSTOPSIG(stat_val) 0
+#define WTERMSIG(stat_val) 0
+#define WUNTRACED 0
+
+#endif
+
+/* Don't go reading from /dev/urandom */
+#define PERL_NO_DEV_RANDOM
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/embed.h b/Master/tlpkg/tlperl.straw/lib/CORE/embed.h
new file mode 100755
index 00000000000..e968707b08d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/embed.h
@@ -0,0 +1,4778 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * embed.h
+ *
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by embed.pl from data in embed.fnc, embed.pl,
+ * pp.sym, intrpvar.h, and perlvars.h.
+ * Any changes made here will be lost!
+ *
+ * Edit those files and run 'make regen_headers' to effect changes.
+ */
+
+/* (Doing namespace management portably in C is really gross.) */
+
+/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
+ * (like warn instead of Perl_warn) for the API are not defined.
+ * Not defining the short forms is a good thing for cleaner embedding. */
+
+#ifndef PERL_NO_SHORT_NAMES
+
+/* Hide global symbols */
+
+#if !defined(PERL_IMPLICIT_CONTEXT)
+
+#if defined(PERL_IMPLICIT_SYS)
+#endif
+#define doing_taint Perl_doing_taint
+#if defined(USE_ITHREADS)
+# if defined(PERL_IMPLICIT_SYS)
+# endif
+#endif
+#if defined(MYMALLOC)
+#ifdef PERL_CORE
+#define malloced_size Perl_malloced_size
+#define malloc_good_size Perl_malloc_good_size
+#endif
+#endif
+#define get_context Perl_get_context
+#define set_context Perl_set_context
+#define amagic_call Perl_amagic_call
+#define Gv_AMupdate Perl_Gv_AMupdate
+#define gv_handler Perl_gv_handler
+#ifdef PERL_CORE
+#define append_elem Perl_append_elem
+#define append_list Perl_append_list
+#define apply Perl_apply
+#endif
+#define apply_attrs_string Perl_apply_attrs_string
+#define av_clear Perl_av_clear
+#define av_delete Perl_av_delete
+#define av_exists Perl_av_exists
+#define av_extend Perl_av_extend
+#ifdef PERL_CORE
+#define av_fake Perl_av_fake
+#endif
+#define av_fetch Perl_av_fetch
+#define av_fill Perl_av_fill
+#define av_len Perl_av_len
+#define av_make Perl_av_make
+#define av_pop Perl_av_pop
+#define av_push Perl_av_push
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define av_reify Perl_av_reify
+#endif
+#define av_shift Perl_av_shift
+#define av_store Perl_av_store
+#define av_undef Perl_av_undef
+#define av_unshift Perl_av_unshift
+#ifdef PERL_CORE
+#define bind_match Perl_bind_match
+#define block_end Perl_block_end
+#endif
+#define block_gimme Perl_block_gimme
+#ifdef PERL_CORE
+#define block_start Perl_block_start
+#define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL
+#define boot_core_PerlIO Perl_boot_core_PerlIO
+#endif
+#define call_list Perl_call_list
+#ifdef PERL_CORE
+#define cando Perl_cando
+#endif
+#define cast_ulong Perl_cast_ulong
+#define cast_i32 Perl_cast_i32
+#define cast_iv Perl_cast_iv
+#define cast_uv Perl_cast_uv
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
+#define my_chsize Perl_my_chsize
+#endif
+#ifdef PERL_CORE
+#define convert Perl_convert
+#define create_eval_scope Perl_create_eval_scope
+#endif
+#define croak Perl_croak
+#define vcroak Perl_vcroak
+#define croak_xs_usage Perl_croak_xs_usage
+#if defined(PERL_IMPLICIT_CONTEXT)
+#define croak_nocontext Perl_croak_nocontext
+#define die_nocontext Perl_die_nocontext
+#define deb_nocontext Perl_deb_nocontext
+#define form_nocontext Perl_form_nocontext
+#define load_module_nocontext Perl_load_module_nocontext
+#define mess_nocontext Perl_mess_nocontext
+#define warn_nocontext Perl_warn_nocontext
+#define warner_nocontext Perl_warner_nocontext
+#define newSVpvf_nocontext Perl_newSVpvf_nocontext
+#define sv_catpvf_nocontext Perl_sv_catpvf_nocontext
+#define sv_setpvf_nocontext Perl_sv_setpvf_nocontext
+#define sv_catpvf_mg_nocontext Perl_sv_catpvf_mg_nocontext
+#define sv_setpvf_mg_nocontext Perl_sv_setpvf_mg_nocontext
+#define fprintf_nocontext Perl_fprintf_nocontext
+#define printf_nocontext Perl_printf_nocontext
+#endif
+#ifdef PERL_CORE
+#define cv_ckproto Perl_cv_ckproto
+#define cv_ckproto_len Perl_cv_ckproto_len
+#define cv_clone Perl_cv_clone
+#endif
+#define gv_const_sv Perl_gv_const_sv
+#define cv_const_sv Perl_cv_const_sv
+#ifdef PERL_CORE
+#define op_const_sv Perl_op_const_sv
+#endif
+#define cv_undef Perl_cv_undef
+#define cx_dump Perl_cx_dump
+#define filter_add Perl_filter_add
+#define filter_del Perl_filter_del
+#define filter_read Perl_filter_read
+#define get_op_descs Perl_get_op_descs
+#define get_op_names Perl_get_op_names
+#ifdef PERL_CORE
+#define get_no_modify Perl_get_no_modify
+#define get_opargs Perl_get_opargs
+#endif
+#define get_ppaddr Perl_get_ppaddr
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define cxinc Perl_cxinc
+#endif
+#define deb Perl_deb
+#define vdeb Perl_vdeb
+#define debprofdump Perl_debprofdump
+#define debop Perl_debop
+#define debstack Perl_debstack
+#define debstackptrs Perl_debstackptrs
+#define delimcpy Perl_delimcpy
+#ifdef PERL_CORE
+#define delete_eval_scope Perl_delete_eval_scope
+#define deprecate Perl_deprecate
+#define deprecate_old Perl_deprecate_old
+#endif
+#define die Perl_die
+#ifdef PERL_CORE
+#define vdie Perl_vdie
+#define die_where Perl_die_where
+#endif
+#define dounwind Perl_dounwind
+#ifdef PERL_CORE
+#define do_aexec5 Perl_do_aexec5
+#endif
+#define do_binmode Perl_do_binmode
+#ifdef PERL_CORE
+#define do_chop Perl_do_chop
+#endif
+#define do_close Perl_do_close
+#ifdef PERL_CORE
+#define do_eof Perl_do_eof
+#endif
+#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+#else
+#ifdef PERL_CORE
+#define do_exec Perl_do_exec
+#endif
+#endif
+#if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS)
+#define do_aspawn Perl_do_aspawn
+#define do_spawn Perl_do_spawn
+#define do_spawn_nowait Perl_do_spawn_nowait
+#endif
+#if !defined(WIN32)
+#ifdef PERL_CORE
+#define do_exec3 Perl_do_exec3
+#endif
+#endif
+#ifdef PERL_CORE
+#define do_execfree Perl_do_execfree
+#endif
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define exec_failed S_exec_failed
+#endif
+#endif
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+#ifdef PERL_CORE
+#define do_ipcctl Perl_do_ipcctl
+#define do_ipcget Perl_do_ipcget
+#define do_msgrcv Perl_do_msgrcv
+#define do_msgsnd Perl_do_msgsnd
+#define do_semop Perl_do_semop
+#define do_shmio Perl_do_shmio
+#endif
+#endif
+#define do_join Perl_do_join
+#ifdef PERL_CORE
+#define do_kv Perl_do_kv
+#endif
+#define do_open9 Perl_do_open9
+#define do_openn Perl_do_openn
+#ifdef PERL_CORE
+#define do_print Perl_do_print
+#define do_readline Perl_do_readline
+#define do_chomp Perl_do_chomp
+#define do_seek Perl_do_seek
+#endif
+#define do_sprintf Perl_do_sprintf
+#ifdef PERL_CORE
+#define do_sysseek Perl_do_sysseek
+#define do_tell Perl_do_tell
+#define do_trans Perl_do_trans
+#define do_vecget Perl_do_vecget
+#define do_vecset Perl_do_vecset
+#define do_vop Perl_do_vop
+#define dofile Perl_dofile
+#endif
+#define dowantarray Perl_dowantarray
+#define dump_all Perl_dump_all
+#define dump_eval Perl_dump_eval
+#if defined(DUMP_FDS)
+#define dump_fds Perl_dump_fds
+#endif
+#define dump_form Perl_dump_form
+#define gv_dump Perl_gv_dump
+#define op_dump Perl_op_dump
+#define pmop_dump Perl_pmop_dump
+#define dump_packsubs Perl_dump_packsubs
+#define dump_sub Perl_dump_sub
+#define fbm_compile Perl_fbm_compile
+#define fbm_instr Perl_fbm_instr
+#ifdef PERL_CORE
+#define find_script Perl_find_script
+#define force_list Perl_force_list
+#define fold_constants Perl_fold_constants
+#endif
+#define form Perl_form
+#define vform Perl_vform
+#define free_tmps Perl_free_tmps
+#ifdef PERL_CORE
+#define gen_constant_list Perl_gen_constant_list
+#endif
+#if !defined(HAS_GETENV_LEN)
+#ifdef PERL_CORE
+#define getenv_len Perl_getenv_len
+#endif
+#endif
+#define gp_free Perl_gp_free
+#define gp_ref Perl_gp_ref
+#define gv_AVadd Perl_gv_AVadd
+#define gv_HVadd Perl_gv_HVadd
+#define gv_IOadd Perl_gv_IOadd
+#define gv_autoload4 Perl_gv_autoload4
+#define gv_check Perl_gv_check
+#define gv_efullname Perl_gv_efullname
+#define gv_efullname4 Perl_gv_efullname4
+#define gv_fetchfile Perl_gv_fetchfile
+#define gv_fetchfile_flags Perl_gv_fetchfile_flags
+#define gv_fetchmeth Perl_gv_fetchmeth
+#define gv_fetchmeth_autoload Perl_gv_fetchmeth_autoload
+#define gv_fetchmethod_autoload Perl_gv_fetchmethod_autoload
+#define gv_fetchpv Perl_gv_fetchpv
+#define gv_fullname Perl_gv_fullname
+#define gv_fullname4 Perl_gv_fullname4
+#define gv_init Perl_gv_init
+#define gv_name_set Perl_gv_name_set
+#define gv_stashpv Perl_gv_stashpv
+#define gv_stashpvn Perl_gv_stashpvn
+#define gv_stashsv Perl_gv_stashsv
+#define hv_clear Perl_hv_clear
+#define hv_delayfree_ent Perl_hv_delayfree_ent
+#define hv_common Perl_hv_common
+#define hv_common_key_len Perl_hv_common_key_len
+#define hv_free_ent Perl_hv_free_ent
+#define hv_iterinit Perl_hv_iterinit
+#define hv_iterkey Perl_hv_iterkey
+#define hv_iterkeysv Perl_hv_iterkeysv
+#define hv_iternextsv Perl_hv_iternextsv
+#define hv_iternext_flags Perl_hv_iternext_flags
+#define hv_iterval Perl_hv_iterval
+#define hv_ksplit Perl_hv_ksplit
+#define hv_undef Perl_hv_undef
+#define ibcmp Perl_ibcmp
+#define ibcmp_locale Perl_ibcmp_locale
+#define ibcmp_utf8 Perl_ibcmp_utf8
+#ifdef PERL_CORE
+#define ingroup Perl_ingroup
+#define init_argv_symbols Perl_init_argv_symbols
+#define init_debugger Perl_init_debugger
+#endif
+#define init_stacks Perl_init_stacks
+#define init_tm Perl_init_tm
+#ifdef PERL_CORE
+#define intro_my Perl_intro_my
+#endif
+#define instr Perl_instr
+#ifdef PERL_CORE
+#define io_close Perl_io_close
+#define invert Perl_invert
+#define is_gv_magical Perl_is_gv_magical
+#endif
+#define is_lvalue_sub Perl_is_lvalue_sub
+#define to_uni_upper_lc Perl_to_uni_upper_lc
+#define to_uni_title_lc Perl_to_uni_title_lc
+#define to_uni_lower_lc Perl_to_uni_lower_lc
+#define is_uni_alnum Perl_is_uni_alnum
+#define is_uni_alnumc Perl_is_uni_alnumc
+#define is_uni_idfirst Perl_is_uni_idfirst
+#define is_uni_alpha Perl_is_uni_alpha
+#define is_uni_ascii Perl_is_uni_ascii
+#define is_uni_space Perl_is_uni_space
+#define is_uni_cntrl Perl_is_uni_cntrl
+#define is_uni_graph Perl_is_uni_graph
+#define is_uni_digit Perl_is_uni_digit
+#define is_uni_upper Perl_is_uni_upper
+#define is_uni_lower Perl_is_uni_lower
+#define is_uni_print Perl_is_uni_print
+#define is_uni_punct Perl_is_uni_punct
+#define is_uni_xdigit Perl_is_uni_xdigit
+#define to_uni_upper Perl_to_uni_upper
+#define to_uni_title Perl_to_uni_title
+#define to_uni_lower Perl_to_uni_lower
+#define to_uni_fold Perl_to_uni_fold
+#define is_uni_alnum_lc Perl_is_uni_alnum_lc
+#define is_uni_alnumc_lc Perl_is_uni_alnumc_lc
+#define is_uni_idfirst_lc Perl_is_uni_idfirst_lc
+#define is_uni_alpha_lc Perl_is_uni_alpha_lc
+#define is_uni_ascii_lc Perl_is_uni_ascii_lc
+#define is_uni_space_lc Perl_is_uni_space_lc
+#define is_uni_cntrl_lc Perl_is_uni_cntrl_lc
+#define is_uni_graph_lc Perl_is_uni_graph_lc
+#define is_uni_digit_lc Perl_is_uni_digit_lc
+#define is_uni_upper_lc Perl_is_uni_upper_lc
+#define is_uni_lower_lc Perl_is_uni_lower_lc
+#define is_uni_print_lc Perl_is_uni_print_lc
+#define is_uni_punct_lc Perl_is_uni_punct_lc
+#define is_uni_xdigit_lc Perl_is_uni_xdigit_lc
+#define is_utf8_char Perl_is_utf8_char
+#define is_utf8_string Perl_is_utf8_string
+#define is_utf8_string_loclen Perl_is_utf8_string_loclen
+#define is_utf8_alnum Perl_is_utf8_alnum
+#define is_utf8_alnumc Perl_is_utf8_alnumc
+#define is_utf8_idfirst Perl_is_utf8_idfirst
+#define is_utf8_idcont Perl_is_utf8_idcont
+#define is_utf8_alpha Perl_is_utf8_alpha
+#define is_utf8_ascii Perl_is_utf8_ascii
+#define is_utf8_space Perl_is_utf8_space
+#define is_utf8_cntrl Perl_is_utf8_cntrl
+#define is_utf8_digit Perl_is_utf8_digit
+#define is_utf8_graph Perl_is_utf8_graph
+#define is_utf8_upper Perl_is_utf8_upper
+#define is_utf8_lower Perl_is_utf8_lower
+#define is_utf8_print Perl_is_utf8_print
+#define is_utf8_punct Perl_is_utf8_punct
+#define is_utf8_xdigit Perl_is_utf8_xdigit
+#define is_utf8_mark Perl_is_utf8_mark
+#ifdef PERL_CORE
+#define jmaybe Perl_jmaybe
+#define keyword Perl_keyword
+#endif
+#define leave_scope Perl_leave_scope
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define lex_end Perl_lex_end
+#endif
+#ifdef PERL_CORE
+#define lex_start Perl_lex_start
+#endif
+#define op_null Perl_op_null
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define op_clear Perl_op_clear
+#endif
+#define op_refcnt_lock Perl_op_refcnt_lock
+#define op_refcnt_unlock Perl_op_refcnt_unlock
+#ifdef PERL_CORE
+#define linklist Perl_linklist
+#define list Perl_list
+#define listkids Perl_listkids
+#endif
+#define load_module Perl_load_module
+#define vload_module Perl_vload_module
+#ifdef PERL_CORE
+#define localize Perl_localize
+#endif
+#define looks_like_number Perl_looks_like_number
+#define grok_bin Perl_grok_bin
+#define grok_hex Perl_grok_hex
+#define grok_number Perl_grok_number
+#define grok_numeric_radix Perl_grok_numeric_radix
+#define grok_oct Perl_grok_oct
+#ifdef PERL_CORE
+#define magic_clearenv Perl_magic_clearenv
+#define magic_clear_all_env Perl_magic_clear_all_env
+#define magic_clearhint Perl_magic_clearhint
+#define magic_clearisa Perl_magic_clearisa
+#define magic_clearpack Perl_magic_clearpack
+#define magic_clearsig Perl_magic_clearsig
+#define magic_existspack Perl_magic_existspack
+#define magic_freeregexp Perl_magic_freeregexp
+#define magic_freeovrld Perl_magic_freeovrld
+#define magic_get Perl_magic_get
+#define magic_getarylen Perl_magic_getarylen
+#define magic_getdefelem Perl_magic_getdefelem
+#define magic_getnkeys Perl_magic_getnkeys
+#define magic_getpack Perl_magic_getpack
+#define magic_getpos Perl_magic_getpos
+#define magic_getsig Perl_magic_getsig
+#define magic_getsubstr Perl_magic_getsubstr
+#define magic_gettaint Perl_magic_gettaint
+#define magic_getuvar Perl_magic_getuvar
+#define magic_getvec Perl_magic_getvec
+#define magic_len Perl_magic_len
+#define magic_nextpack Perl_magic_nextpack
+#define magic_regdata_cnt Perl_magic_regdata_cnt
+#define magic_regdatum_get Perl_magic_regdatum_get
+#define magic_regdatum_set Perl_magic_regdatum_set
+#define magic_set Perl_magic_set
+#define magic_setamagic Perl_magic_setamagic
+#define magic_setarylen Perl_magic_setarylen
+#define magic_freearylen_p Perl_magic_freearylen_p
+#endif
+#ifndef NO_MATHOMS
+#ifdef PERL_CORE
+#define magic_setbm Perl_magic_setbm
+#define magic_setfm Perl_magic_setfm
+#endif
+#endif
+#ifdef PERL_CORE
+#define magic_setdbline Perl_magic_setdbline
+#define magic_setdefelem Perl_magic_setdefelem
+#define magic_setenv Perl_magic_setenv
+#define magic_sethint Perl_magic_sethint
+#define magic_setisa Perl_magic_setisa
+#endif
+#ifndef NO_MATHOMS
+#ifdef PERL_CORE
+#define magic_setglob Perl_magic_setglob
+#endif
+#endif
+#ifdef PERL_CORE
+#define magic_setmglob Perl_magic_setmglob
+#define magic_setnkeys Perl_magic_setnkeys
+#define magic_setpack Perl_magic_setpack
+#define magic_setpos Perl_magic_setpos
+#define magic_setregexp Perl_magic_setregexp
+#define magic_setsig Perl_magic_setsig
+#define magic_setsubstr Perl_magic_setsubstr
+#define magic_settaint Perl_magic_settaint
+#define magic_setuvar Perl_magic_setuvar
+#define magic_setvec Perl_magic_setvec
+#define magic_setutf8 Perl_magic_setutf8
+#define magic_set_all_env Perl_magic_set_all_env
+#define magic_sizepack Perl_magic_sizepack
+#define magic_wipepack Perl_magic_wipepack
+#define magicname Perl_magicname
+#endif
+#define markstack_grow Perl_markstack_grow
+#if defined(USE_LOCALE_COLLATE)
+#ifdef PERL_CORE
+#define magic_setcollxfrm Perl_magic_setcollxfrm
+#define mem_collxfrm Perl_mem_collxfrm
+#endif
+#endif
+#define mess Perl_mess
+#define vmess Perl_vmess
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define qerror Perl_qerror
+#endif
+#define sortsv Perl_sortsv
+#define sortsv_flags Perl_sortsv_flags
+#define mg_clear Perl_mg_clear
+#define mg_copy Perl_mg_copy
+#ifdef PERL_CORE
+#define mg_localize Perl_mg_localize
+#endif
+#define mg_find Perl_mg_find
+#define mg_free Perl_mg_free
+#define mg_get Perl_mg_get
+#define mg_length Perl_mg_length
+#define mg_magical Perl_mg_magical
+#define mg_set Perl_mg_set
+#define mg_size Perl_mg_size
+#define mini_mktime Perl_mini_mktime
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define mod Perl_mod
+#endif
+#ifdef PERL_CORE
+#define mode_from_discipline Perl_mode_from_discipline
+#endif
+#define moreswitches Perl_moreswitches
+#ifdef PERL_CORE
+#define my Perl_my
+#endif
+#define my_atof Perl_my_atof
+#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
+#define my_bcopy Perl_my_bcopy
+#endif
+#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
+#define my_bzero Perl_my_bzero
+#endif
+#define my_exit Perl_my_exit
+#define my_failure_exit Perl_my_failure_exit
+#define my_fflush_all Perl_my_fflush_all
+#define my_fork Perl_my_fork
+#define atfork_lock Perl_atfork_lock
+#define atfork_unlock Perl_atfork_unlock
+#define my_lstat Perl_my_lstat
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
+#define my_memcmp Perl_my_memcmp
+#endif
+#if !defined(HAS_MEMSET)
+#define my_memset Perl_my_memset
+#endif
+#define my_pclose Perl_my_pclose
+#define my_popen Perl_my_popen
+#define my_popen_list Perl_my_popen_list
+#define my_setenv Perl_my_setenv
+#define my_stat Perl_my_stat
+#define my_strftime Perl_my_strftime
+#if defined(MYSWAP)
+#define my_swap Perl_my_swap
+#define my_htonl Perl_my_htonl
+#define my_ntohl Perl_my_ntohl
+#endif
+#ifdef PERL_CORE
+#define my_unexec Perl_my_unexec
+#endif
+#define newANONLIST Perl_newANONLIST
+#define newANONHASH Perl_newANONHASH
+#define newANONSUB Perl_newANONSUB
+#define newASSIGNOP Perl_newASSIGNOP
+#define newCONDOP Perl_newCONDOP
+#define newCONSTSUB Perl_newCONSTSUB
+#ifdef PERL_MAD
+#define newFORM Perl_newFORM
+#else
+#define newFORM Perl_newFORM
+#endif
+#define newFOROP Perl_newFOROP
+#define newGIVENOP Perl_newGIVENOP
+#define newLOGOP Perl_newLOGOP
+#define newLOOPEX Perl_newLOOPEX
+#define newLOOPOP Perl_newLOOPOP
+#define newNULLLIST Perl_newNULLLIST
+#define newOP Perl_newOP
+#define newPROG Perl_newPROG
+#define newRANGE Perl_newRANGE
+#define newSLICEOP Perl_newSLICEOP
+#define newSTATEOP Perl_newSTATEOP
+#define newSUB Perl_newSUB
+#define newXS_flags Perl_newXS_flags
+#define newXS Perl_newXS
+#define newAVREF Perl_newAVREF
+#define newBINOP Perl_newBINOP
+#define newCVREF Perl_newCVREF
+#define newGVOP Perl_newGVOP
+#define newGVgen Perl_newGVgen
+#define newGVREF Perl_newGVREF
+#define newHVREF Perl_newHVREF
+#define newHVhv Perl_newHVhv
+#define newIO Perl_newIO
+#define newLISTOP Perl_newLISTOP
+#ifdef USE_ITHREADS
+#define newPADOP Perl_newPADOP
+#endif
+#define newPMOP Perl_newPMOP
+#define newPVOP Perl_newPVOP
+#define newRV Perl_newRV
+#define newRV_noinc Perl_newRV_noinc
+#define newSV Perl_newSV
+#define newSVREF Perl_newSVREF
+#define newSVOP Perl_newSVOP
+#define newSViv Perl_newSViv
+#define newSVuv Perl_newSVuv
+#define newSVnv Perl_newSVnv
+#define newSVpv Perl_newSVpv
+#define newSVpvn Perl_newSVpvn
+#define newSVpvn_flags Perl_newSVpvn_flags
+#define newSVhek Perl_newSVhek
+#define newSVpvn_share Perl_newSVpvn_share
+#define newSVpvf Perl_newSVpvf
+#define vnewSVpvf Perl_vnewSVpvf
+#define newSVrv Perl_newSVrv
+#define newSVsv Perl_newSVsv
+#define newSV_type Perl_newSV_type
+#define newUNOP Perl_newUNOP
+#define newWHENOP Perl_newWHENOP
+#define newWHILEOP Perl_newWHILEOP
+#define new_stackinfo Perl_new_stackinfo
+#define scan_vstring Perl_scan_vstring
+#define scan_version Perl_scan_version
+#define new_version Perl_new_version
+#define upg_version Perl_upg_version
+#define vverify Perl_vverify
+#define vnumify Perl_vnumify
+#define vnormal Perl_vnormal
+#define vstringify Perl_vstringify
+#define vcmp Perl_vcmp
+#ifdef PERL_CORE
+#define nextargv Perl_nextargv
+#endif
+#define ninstr Perl_ninstr
+#ifdef PERL_CORE
+#define oopsCV Perl_oopsCV
+#endif
+#define op_free Perl_op_free
+#ifdef PERL_MAD
+#ifdef PERL_CORE
+#define package Perl_package
+#endif
+#else
+#ifdef PERL_CORE
+#define package Perl_package
+#endif
+#endif
+#ifdef PERL_CORE
+#define pad_alloc Perl_pad_alloc
+#define allocmy Perl_allocmy
+#define pad_findmy Perl_pad_findmy
+#endif
+#define find_rundefsvoffset Perl_find_rundefsvoffset
+#ifdef PERL_CORE
+#define oopsAV Perl_oopsAV
+#define oopsHV Perl_oopsHV
+#define pad_leavemy Perl_pad_leavemy
+#endif
+#define pad_sv Perl_pad_sv
+#ifdef PERL_CORE
+#define pad_free Perl_pad_free
+#define pad_reset Perl_pad_reset
+#define pad_swipe Perl_pad_swipe
+#define peep Perl_peep
+#endif
+#if defined(USE_REENTRANT_API)
+#define reentrant_size Perl_reentrant_size
+#define reentrant_init Perl_reentrant_init
+#define reentrant_free Perl_reentrant_free
+#define reentrant_retry Perl_reentrant_retry
+#endif
+#define call_atexit Perl_call_atexit
+#define call_argv Perl_call_argv
+#define call_method Perl_call_method
+#define call_pv Perl_call_pv
+#define call_sv Perl_call_sv
+#define despatch_signals Perl_despatch_signals
+#define doref Perl_doref
+#define eval_pv Perl_eval_pv
+#define eval_sv Perl_eval_sv
+#define get_sv Perl_get_sv
+#define get_av Perl_get_av
+#define get_hv Perl_get_hv
+#define get_cv Perl_get_cv
+#define get_cvn_flags Perl_get_cvn_flags
+#define init_i18nl10n Perl_init_i18nl10n
+#define init_i18nl14n Perl_init_i18nl14n
+#define new_collate Perl_new_collate
+#define new_ctype Perl_new_ctype
+#define new_numeric Perl_new_numeric
+#define set_numeric_local Perl_set_numeric_local
+#define set_numeric_radix Perl_set_numeric_radix
+#define set_numeric_standard Perl_set_numeric_standard
+#define require_pv Perl_require_pv
+#define pack_cat Perl_pack_cat
+#define packlist Perl_packlist
+#ifdef PERL_USES_PL_PIDSTATUS
+#ifdef PERL_CORE
+#define pidgone Perl_pidgone
+#endif
+#endif
+#define pmflag Perl_pmflag
+#ifdef PERL_CORE
+#define pmruntime Perl_pmruntime
+#define pmtrans Perl_pmtrans
+#endif
+#define pop_scope Perl_pop_scope
+#ifdef PERL_CORE
+#define prepend_elem Perl_prepend_elem
+#endif
+#define push_scope Perl_push_scope
+#ifdef PERL_CORE
+#define refkids Perl_refkids
+#endif
+#define regdump Perl_regdump
+#define regdump Perl_regdump
+#define regclass_swash Perl_regclass_swash
+#define pregexec Perl_pregexec
+#define pregfree Perl_pregfree
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_temp_copy Perl_reg_temp_copy
+#endif
+#define regfree_internal Perl_regfree_internal
+#define reg_stringify Perl_reg_stringify
+#if defined(USE_ITHREADS)
+#define regdupe_internal Perl_regdupe_internal
+#endif
+#define pregcomp Perl_pregcomp
+#define re_compile Perl_re_compile
+#define re_intuit_start Perl_re_intuit_start
+#define re_intuit_string Perl_re_intuit_string
+#define regexec_flags Perl_regexec_flags
+#define regnext Perl_regnext
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_named_buff Perl_reg_named_buff
+#define reg_named_buff_iter Perl_reg_named_buff_iter
+#endif
+#define reg_named_buff_fetch Perl_reg_named_buff_fetch
+#define reg_named_buff_exists Perl_reg_named_buff_exists
+#define reg_named_buff_firstkey Perl_reg_named_buff_firstkey
+#define reg_named_buff_nextkey Perl_reg_named_buff_nextkey
+#define reg_named_buff_scalar Perl_reg_named_buff_scalar
+#define reg_named_buff_all Perl_reg_named_buff_all
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_numbered_buff_fetch Perl_reg_numbered_buff_fetch
+#define reg_numbered_buff_store Perl_reg_numbered_buff_store
+#define reg_numbered_buff_length Perl_reg_numbered_buff_length
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_qr_package Perl_reg_qr_package
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regprop Perl_regprop
+#endif
+#define repeatcpy Perl_repeatcpy
+#define rninstr Perl_rninstr
+#define rsignal Perl_rsignal
+#ifdef PERL_CORE
+#define rsignal_restore Perl_rsignal_restore
+#define rsignal_save Perl_rsignal_save
+#endif
+#define rsignal_state Perl_rsignal_state
+#ifdef PERL_CORE
+#define rxres_free Perl_rxres_free
+#define rxres_restore Perl_rxres_restore
+#define rxres_save Perl_rxres_save
+#endif
+#if !defined(HAS_RENAME)
+#ifdef PERL_CORE
+#define same_dirent Perl_same_dirent
+#endif
+#endif
+#define savepv Perl_savepv
+#define savepvn Perl_savepvn
+#define savesharedpv Perl_savesharedpv
+#define savesharedpvn Perl_savesharedpvn
+#define savesvpv Perl_savesvpv
+#define savestack_grow Perl_savestack_grow
+#define savestack_grow_cnt Perl_savestack_grow_cnt
+#define save_aelem Perl_save_aelem
+#define save_alloc Perl_save_alloc
+#define save_aptr Perl_save_aptr
+#define save_ary Perl_save_ary
+#define save_bool Perl_save_bool
+#define save_clearsv Perl_save_clearsv
+#define save_delete Perl_save_delete
+#define save_destructor Perl_save_destructor
+#define save_destructor_x Perl_save_destructor_x
+#define save_generic_svref Perl_save_generic_svref
+#define save_generic_pvref Perl_save_generic_pvref
+#define save_shared_pvref Perl_save_shared_pvref
+#define save_gp Perl_save_gp
+#define save_hash Perl_save_hash
+#ifdef PERL_CORE
+#define save_hints Perl_save_hints
+#endif
+#define save_helem Perl_save_helem
+#define save_hptr Perl_save_hptr
+#define save_I16 Perl_save_I16
+#define save_I32 Perl_save_I32
+#define save_I8 Perl_save_I8
+#define save_int Perl_save_int
+#define save_item Perl_save_item
+#define save_iv Perl_save_iv
+#define save_list Perl_save_list
+#define save_long Perl_save_long
+#define save_nogv Perl_save_nogv
+#define save_scalar Perl_save_scalar
+#define save_pptr Perl_save_pptr
+#define save_vptr Perl_save_vptr
+#define save_re_context Perl_save_re_context
+#define save_padsv Perl_save_padsv
+#define save_padsv_and_mortalize Perl_save_padsv_and_mortalize
+#define save_sptr Perl_save_sptr
+#define save_svref Perl_save_svref
+#define save_pushptr Perl_save_pushptr
+#ifdef PERL_CORE
+#define save_pushi32ptr Perl_save_pushi32ptr
+#define save_pushptrptr Perl_save_pushptrptr
+#endif
+#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define save_pushptri32ptr S_save_pushptri32ptr
+#endif
+#endif
+#ifdef PERL_CORE
+#define sawparens Perl_sawparens
+#define scalar Perl_scalar
+#define scalarkids Perl_scalarkids
+#define scalarseq Perl_scalarseq
+#define scalarvoid Perl_scalarvoid
+#endif
+#define scan_bin Perl_scan_bin
+#define scan_hex Perl_scan_hex
+#define scan_num Perl_scan_num
+#define scan_oct Perl_scan_oct
+#ifdef PERL_CORE
+#define scope Perl_scope
+#endif
+#define screaminstr Perl_screaminstr
+#if !defined(VMS)
+#ifdef PERL_CORE
+#define setenv_getix Perl_setenv_getix
+#endif
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define setdefout Perl_setdefout
+#endif
+#define share_hek Perl_share_hek
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+#ifdef PERL_CORE
+#define sighandler Perl_sighandler
+#endif
+#define csighandler Perl_csighandler
+#else
+#ifdef PERL_CORE
+#define sighandler Perl_sighandler
+#endif
+#define csighandler Perl_csighandler
+#endif
+#define stack_grow Perl_stack_grow
+#define start_subparse Perl_start_subparse
+#ifdef PERL_CORE
+#define sub_crush_depth Perl_sub_crush_depth
+#endif
+#define sv_2bool Perl_sv_2bool
+#define sv_2cv Perl_sv_2cv
+#define sv_2io Perl_sv_2io
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define glob_2number S_glob_2number
+#define glob_2pv S_glob_2pv
+#endif
+#endif
+#define sv_2iv_flags Perl_sv_2iv_flags
+#define sv_2mortal Perl_sv_2mortal
+#define sv_2nv Perl_sv_2nv
+#ifdef PERL_CORE
+#define sv_2num Perl_sv_2num
+#endif
+#define sv_2pv_flags Perl_sv_2pv_flags
+#define sv_2pvutf8 Perl_sv_2pvutf8
+#define sv_2pvbyte Perl_sv_2pvbyte
+#define sv_pvn_nomg Perl_sv_pvn_nomg
+#define sv_2uv_flags Perl_sv_2uv_flags
+#define sv_iv Perl_sv_iv
+#define sv_uv Perl_sv_uv
+#define sv_nv Perl_sv_nv
+#define sv_pvn Perl_sv_pvn
+#define sv_pvutf8n Perl_sv_pvutf8n
+#define sv_pvbyten Perl_sv_pvbyten
+#define sv_true Perl_sv_true
+#ifdef PERL_CORE
+#define sv_add_arena Perl_sv_add_arena
+#endif
+#define sv_backoff Perl_sv_backoff
+#define sv_bless Perl_sv_bless
+#define sv_catpvf Perl_sv_catpvf
+#define sv_vcatpvf Perl_sv_vcatpvf
+#define sv_catpv Perl_sv_catpv
+#define sv_chop Perl_sv_chop
+#ifdef PERL_CORE
+#define sv_clean_all Perl_sv_clean_all
+#define sv_clean_objs Perl_sv_clean_objs
+#endif
+#define sv_clear Perl_sv_clear
+#define sv_cmp Perl_sv_cmp
+#define sv_cmp_locale Perl_sv_cmp_locale
+#if defined(USE_LOCALE_COLLATE)
+#define sv_collxfrm Perl_sv_collxfrm
+#endif
+#define sv_compile_2op Perl_sv_compile_2op
+#define getcwd_sv Perl_getcwd_sv
+#define sv_dec Perl_sv_dec
+#define sv_dump Perl_sv_dump
+#define sv_derived_from Perl_sv_derived_from
+#define sv_does Perl_sv_does
+#define sv_eq Perl_sv_eq
+#define sv_free Perl_sv_free
+#ifdef PERL_CORE
+#define sv_free_arenas Perl_sv_free_arenas
+#endif
+#define sv_gets Perl_sv_gets
+#define sv_grow Perl_sv_grow
+#define sv_inc Perl_sv_inc
+#define sv_insert_flags Perl_sv_insert_flags
+#define sv_isa Perl_sv_isa
+#define sv_isobject Perl_sv_isobject
+#define sv_len Perl_sv_len
+#define sv_len_utf8 Perl_sv_len_utf8
+#define sv_magic Perl_sv_magic
+#define sv_magicext Perl_sv_magicext
+#define sv_mortalcopy Perl_sv_mortalcopy
+#define sv_newmortal Perl_sv_newmortal
+#define sv_newref Perl_sv_newref
+#define sv_peek Perl_sv_peek
+#define sv_pos_u2b Perl_sv_pos_u2b
+#define sv_pos_b2u Perl_sv_pos_b2u
+#define sv_pvutf8n_force Perl_sv_pvutf8n_force
+#define sv_pvbyten_force Perl_sv_pvbyten_force
+#define sv_recode_to_utf8 Perl_sv_recode_to_utf8
+#define sv_cat_decode Perl_sv_cat_decode
+#define sv_reftype Perl_sv_reftype
+#define sv_replace Perl_sv_replace
+#define sv_report_used Perl_sv_report_used
+#define sv_reset Perl_sv_reset
+#define sv_setpvf Perl_sv_setpvf
+#define sv_vsetpvf Perl_sv_vsetpvf
+#define sv_setiv Perl_sv_setiv
+#define sv_setpviv Perl_sv_setpviv
+#define sv_setuv Perl_sv_setuv
+#define sv_setnv Perl_sv_setnv
+#define sv_setref_iv Perl_sv_setref_iv
+#define sv_setref_uv Perl_sv_setref_uv
+#define sv_setref_nv Perl_sv_setref_nv
+#define sv_setref_pv Perl_sv_setref_pv
+#define sv_setref_pvn Perl_sv_setref_pvn
+#define sv_setpv Perl_sv_setpv
+#define sv_setpvn Perl_sv_setpvn
+#define sv_tainted Perl_sv_tainted
+#define sv_unmagic Perl_sv_unmagic
+#define sv_unref_flags Perl_sv_unref_flags
+#define sv_untaint Perl_sv_untaint
+#define sv_upgrade Perl_sv_upgrade
+#define sv_usepvn_flags Perl_sv_usepvn_flags
+#define sv_vcatpvfn Perl_sv_vcatpvfn
+#define sv_vsetpvfn Perl_sv_vsetpvfn
+#define str_to_version Perl_str_to_version
+#define swash_init Perl_swash_init
+#define swash_fetch Perl_swash_fetch
+#define taint_env Perl_taint_env
+#define taint_proper Perl_taint_proper
+#define to_utf8_case Perl_to_utf8_case
+#define to_utf8_lower Perl_to_utf8_lower
+#define to_utf8_upper Perl_to_utf8_upper
+#define to_utf8_title Perl_to_utf8_title
+#define to_utf8_fold Perl_to_utf8_fold
+#if defined(UNLINK_ALL_VERSIONS)
+#define unlnk Perl_unlnk
+#endif
+#define unpack_str Perl_unpack_str
+#define unpackstring Perl_unpackstring
+#define unsharepvn Perl_unsharepvn
+#ifdef PERL_CORE
+#define unshare_hek Perl_unshare_hek
+#endif
+#ifdef PERL_MAD
+#ifdef PERL_CORE
+#define utilize Perl_utilize
+#endif
+#else
+#ifdef PERL_CORE
+#define utilize Perl_utilize
+#endif
+#endif
+#define utf16_to_utf8 Perl_utf16_to_utf8
+#define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#define utf8_length Perl_utf8_length
+#define utf8_distance Perl_utf8_distance
+#define utf8_hop Perl_utf8_hop
+#define utf8_to_bytes Perl_utf8_to_bytes
+#define bytes_from_utf8 Perl_bytes_from_utf8
+#define bytes_to_utf8 Perl_bytes_to_utf8
+#define utf8_to_uvchr Perl_utf8_to_uvchr
+#define utf8_to_uvuni Perl_utf8_to_uvuni
+#ifdef EBCDIC
+#define utf8n_to_uvchr Perl_utf8n_to_uvchr
+#else
+#endif
+#define utf8n_to_uvuni Perl_utf8n_to_uvuni
+#ifdef EBCDIC
+#define uvchr_to_utf8 Perl_uvchr_to_utf8
+#else
+#endif
+#define uvchr_to_utf8_flags Perl_uvchr_to_utf8_flags
+#define uvuni_to_utf8_flags Perl_uvuni_to_utf8_flags
+#define pv_uni_display Perl_pv_uni_display
+#define sv_uni_display Perl_sv_uni_display
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define vivify_defelem Perl_vivify_defelem
+#endif
+#ifdef PERL_CORE
+#define vivify_ref Perl_vivify_ref
+#define wait4pid Perl_wait4pid
+#define parse_unicode_opts Perl_parse_unicode_opts
+#endif
+#define seed Perl_seed
+#ifdef PERL_CORE
+#define get_hash_seed Perl_get_hash_seed
+#define report_evil_fh Perl_report_evil_fh
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define report_uninit Perl_report_uninit
+#endif
+#define warn Perl_warn
+#define vwarn Perl_vwarn
+#define warner Perl_warner
+#define vwarner Perl_vwarner
+#ifdef PERL_CORE
+#define watch Perl_watch
+#endif
+#define whichsig Perl_whichsig
+#ifdef PERL_CORE
+#define write_to_stderr Perl_write_to_stderr
+#define yyerror Perl_yyerror
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define yylex Perl_yylex
+#endif
+#ifdef PERL_CORE
+#define yyparse Perl_yyparse
+#define parser_free Perl_parser_free
+#define yywarn Perl_yywarn
+#endif
+#if defined(MYMALLOC)
+#define dump_mstats Perl_dump_mstats
+#define get_mstats Perl_get_mstats
+#endif
+#define safesysmalloc Perl_safesysmalloc
+#define safesyscalloc Perl_safesyscalloc
+#define safesysrealloc Perl_safesysrealloc
+#define safesysfree Perl_safesysfree
+#if defined(PERL_GLOBAL_STRUCT)
+#define GetVars Perl_GetVars
+#define init_global_struct Perl_init_global_struct
+#define free_global_struct Perl_free_global_struct
+#endif
+#define runops_standard Perl_runops_standard
+#define runops_debug Perl_runops_debug
+#define sv_catpvf_mg Perl_sv_catpvf_mg
+#define sv_vcatpvf_mg Perl_sv_vcatpvf_mg
+#define sv_catpv_mg Perl_sv_catpv_mg
+#define sv_setpvf_mg Perl_sv_setpvf_mg
+#define sv_vsetpvf_mg Perl_sv_vsetpvf_mg
+#define sv_setiv_mg Perl_sv_setiv_mg
+#define sv_setpviv_mg Perl_sv_setpviv_mg
+#define sv_setuv_mg Perl_sv_setuv_mg
+#define sv_setnv_mg Perl_sv_setnv_mg
+#define sv_setpv_mg Perl_sv_setpv_mg
+#define sv_setpvn_mg Perl_sv_setpvn_mg
+#define sv_setsv_mg Perl_sv_setsv_mg
+#define get_vtbl Perl_get_vtbl
+#define pv_display Perl_pv_display
+#define pv_escape Perl_pv_escape
+#define pv_pretty Perl_pv_pretty
+#define dump_indent Perl_dump_indent
+#define dump_vindent Perl_dump_vindent
+#define do_gv_dump Perl_do_gv_dump
+#define do_gvgv_dump Perl_do_gvgv_dump
+#define do_hv_dump Perl_do_hv_dump
+#define do_magic_dump Perl_do_magic_dump
+#define do_op_dump Perl_do_op_dump
+#define do_pmop_dump Perl_do_pmop_dump
+#define do_sv_dump Perl_do_sv_dump
+#define magic_dump Perl_magic_dump
+#define reginitcolors Perl_reginitcolors
+#define sv_utf8_downgrade Perl_sv_utf8_downgrade
+#define sv_utf8_encode Perl_sv_utf8_encode
+#define sv_utf8_decode Perl_sv_utf8_decode
+#define sv_force_normal_flags Perl_sv_force_normal_flags
+#define tmps_grow Perl_tmps_grow
+#define sv_rvweaken Perl_sv_rvweaken
+#ifdef PERL_CORE
+#define magic_killbackrefs Perl_magic_killbackrefs
+#endif
+#define newANONATTRSUB Perl_newANONATTRSUB
+#define newATTRSUB Perl_newATTRSUB
+#ifdef PERL_MAD
+#define newMYSUB Perl_newMYSUB
+#else
+#define newMYSUB Perl_newMYSUB
+#endif
+#ifdef PERL_CORE
+#define my_attrs Perl_my_attrs
+#define boot_core_xsutils Perl_boot_core_xsutils
+#endif
+#if defined(USE_ITHREADS)
+#define cx_dup Perl_cx_dup
+#define si_dup Perl_si_dup
+#define ss_dup Perl_ss_dup
+#define any_dup Perl_any_dup
+#define he_dup Perl_he_dup
+#define hek_dup Perl_hek_dup
+#define re_dup Perl_re_dup
+#define fp_dup Perl_fp_dup
+#define dirp_dup Perl_dirp_dup
+#define gp_dup Perl_gp_dup
+#define mg_dup Perl_mg_dup
+#define sv_dup Perl_sv_dup
+#define rvpv_dup Perl_rvpv_dup
+#define parser_dup Perl_parser_dup
+#endif
+#define ptr_table_new Perl_ptr_table_new
+#define ptr_table_fetch Perl_ptr_table_fetch
+#define ptr_table_store Perl_ptr_table_store
+#define ptr_table_split Perl_ptr_table_split
+#define ptr_table_clear Perl_ptr_table_clear
+#define ptr_table_free Perl_ptr_table_free
+#if defined(USE_ITHREADS)
+# if defined(HAVE_INTERP_INTERN)
+#define sys_intern_dup Perl_sys_intern_dup
+# endif
+#endif
+#if defined(HAVE_INTERP_INTERN)
+#define sys_intern_clear Perl_sys_intern_clear
+#define sys_intern_init Perl_sys_intern_init
+#endif
+#define custom_op_name Perl_custom_op_name
+#define custom_op_desc Perl_custom_op_desc
+#define sv_nosharing Perl_sv_nosharing
+#define sv_destroyable Perl_sv_destroyable
+#ifdef NO_MATHOMS
+#else
+#define sv_nounlocking Perl_sv_nounlocking
+#endif
+#define nothreadhook Perl_nothreadhook
+#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define do_trans_simple S_do_trans_simple
+#define do_trans_count S_do_trans_count
+#define do_trans_complex S_do_trans_complex
+#define do_trans_simple_utf8 S_do_trans_simple_utf8
+#define do_trans_count_utf8 S_do_trans_count_utf8
+#define do_trans_complex_utf8 S_do_trans_complex_utf8
+#endif
+#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define gv_init_sv S_gv_init_sv
+#define gv_get_super_pkg S_gv_get_super_pkg
+#define require_tie_mod S_require_tie_mod
+#endif
+#endif
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define hsplit S_hsplit
+#define hfreeentries S_hfreeentries
+#define new_he S_new_he
+#define save_hek_flags S_save_hek_flags
+#define hv_magic_check S_hv_magic_check
+#define unshare_hek_or_pvn S_unshare_hek_or_pvn
+#define share_hek_flags S_share_hek_flags
+#define hv_notallowed S_hv_notallowed
+#define hv_auxinit S_hv_auxinit
+#define hv_delete_common S_hv_delete_common
+#define clear_placeholders S_clear_placeholders
+#define refcounted_he_value S_refcounted_he_value
+#endif
+#endif
+#if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define save_magic S_save_magic
+#define magic_methpack S_magic_methpack
+#define magic_methcall S_magic_methcall
+#define restore_magic S_restore_magic
+#define unwind_handler_stack S_unwind_handler_stack
+#endif
+#endif
+#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define ck_anoncode Perl_ck_anoncode
+#define ck_bitop Perl_ck_bitop
+#define ck_concat Perl_ck_concat
+#define ck_defined Perl_ck_defined
+#define ck_delete Perl_ck_delete
+#define ck_die Perl_ck_die
+#define ck_eof Perl_ck_eof
+#define ck_eval Perl_ck_eval
+#define ck_exec Perl_ck_exec
+#define ck_exists Perl_ck_exists
+#define ck_exit Perl_ck_exit
+#define ck_ftst Perl_ck_ftst
+#define ck_fun Perl_ck_fun
+#define ck_glob Perl_ck_glob
+#define ck_grep Perl_ck_grep
+#define ck_index Perl_ck_index
+#define ck_join Perl_ck_join
+#define ck_lengthconst Perl_ck_lengthconst
+#define ck_lfun Perl_ck_lfun
+#define ck_listiob Perl_ck_listiob
+#define ck_match Perl_ck_match
+#define ck_method Perl_ck_method
+#define ck_null Perl_ck_null
+#define ck_open Perl_ck_open
+#define ck_readline Perl_ck_readline
+#define ck_repeat Perl_ck_repeat
+#define ck_require Perl_ck_require
+#define ck_return Perl_ck_return
+#define ck_rfun Perl_ck_rfun
+#define ck_rvconst Perl_ck_rvconst
+#define ck_sassign Perl_ck_sassign
+#define ck_select Perl_ck_select
+#define ck_shift Perl_ck_shift
+#define ck_sort Perl_ck_sort
+#define ck_spair Perl_ck_spair
+#define ck_split Perl_ck_split
+#define ck_subr Perl_ck_subr
+#define ck_substr Perl_ck_substr
+#define ck_svconst Perl_ck_svconst
+#define ck_trunc Perl_ck_trunc
+#define ck_unpack Perl_ck_unpack
+#define is_handle_constructor S_is_handle_constructor
+#define is_list_assignment S_is_list_assignment
+#endif
+# ifdef USE_ITHREADS
+# else
+# endif
+#ifdef PERL_CORE
+#define find_and_forget_pmops S_find_and_forget_pmops
+#define cop_free S_cop_free
+#define modkids S_modkids
+#define scalarboolean S_scalarboolean
+#define newDEFSVOP S_newDEFSVOP
+#define search_const S_search_const
+#define new_logop S_new_logop
+#define simplify_sort S_simplify_sort
+#define gv_ename S_gv_ename
+#define scalar_mod_type S_scalar_mod_type
+#define my_kid S_my_kid
+#define dup_attrlist S_dup_attrlist
+#define apply_attrs S_apply_attrs
+#define apply_attrs_my S_apply_attrs_my
+#define bad_type S_bad_type
+#define no_bareword_allowed S_no_bareword_allowed
+#define no_fh_allowed S_no_fh_allowed
+#define too_few_arguments S_too_few_arguments
+#define too_many_arguments S_too_many_arguments
+#define looks_like_bool S_looks_like_bool
+#define newGIVWHENOP S_newGIVWHENOP
+#define ref_array_or_hash S_ref_array_or_hash
+#define process_special_blocks S_process_special_blocks
+#endif
+#endif
+#if defined(PL_OP_SLAB_ALLOC)
+#define Slab_Alloc Perl_Slab_Alloc
+#define Slab_Free Perl_Slab_Free
+# if defined(PERL_DEBUG_READONLY_OPS)
+# if defined(PERL_IN_OP_C)
+#ifdef PERL_CORE
+#define Slab_to_rw S_Slab_to_rw
+#endif
+# endif
+# endif
+#endif
+#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define find_beginning S_find_beginning
+#define forbid_setid S_forbid_setid
+#define incpush S_incpush
+#define init_interp S_init_interp
+#define init_ids S_init_ids
+#define init_main_stash S_init_main_stash
+#define init_perllib S_init_perllib
+#define init_postdump_symbols S_init_postdump_symbols
+#define init_predump_symbols S_init_predump_symbols
+#define my_exit_jump S_my_exit_jump
+#define nuke_stacks S_nuke_stacks
+#define open_script S_open_script
+#define usage S_usage
+#endif
+#ifdef DOSUID
+# ifdef IAMSUID
+# else
+# endif
+#else
+# ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+# endif
+#endif
+# if defined(IAMSUID)
+#ifdef PERL_CORE
+#define fd_on_nosuid_fs S_fd_on_nosuid_fs
+#endif
+# endif
+#ifdef PERL_CORE
+#define parse_body S_parse_body
+#define run_body S_run_body
+#define incpush_if_exists S_incpush_if_exists
+#endif
+#endif
+#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define refto S_refto
+#endif
+#endif
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
+#endif
+#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define unpack_rec S_unpack_rec
+#define pack_rec S_pack_rec
+#define mul128 S_mul128
+#define measure_struct S_measure_struct
+#define next_symbol S_next_symbol
+#define is_an_int S_is_an_int
+#define div128 S_div128
+#define group_end S_group_end
+#define get_num S_get_num
+#define need_utf8 S_need_utf8
+#define first_symbol S_first_symbol
+#define sv_exp_grow S_sv_exp_grow
+#define bytes_to_uni S_bytes_to_uni
+#endif
+#endif
+#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define docatch S_docatch
+#define dofindlabel S_dofindlabel
+#define doparseform S_doparseform
+#define num_overflow S_num_overflow
+#define dopoptoeval S_dopoptoeval
+#define dopoptogiven S_dopoptogiven
+#define dopoptolabel S_dopoptolabel
+#define dopoptoloop S_dopoptoloop
+#define dopoptosub_at S_dopoptosub_at
+#define dopoptowhen S_dopoptowhen
+#define save_lines S_save_lines
+#define doeval S_doeval
+#define check_type_and_open S_check_type_and_open
+#endif
+#ifndef PERL_DISABLE_PMC
+#ifdef PERL_CORE
+#define doopen_pm S_doopen_pm
+#endif
+#endif
+#ifdef PERL_CORE
+#define path_is_absolute S_path_is_absolute
+#define run_user_filter S_run_user_filter
+#define make_matcher S_make_matcher
+#define matcher_matches_sv S_matcher_matches_sv
+#define destroy_matcher S_destroy_matcher
+#define do_smartmatch S_do_smartmatch
+#endif
+#endif
+#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define do_oddball S_do_oddball
+#define method_common S_method_common
+#endif
+#endif
+#if defined(PERL_IN_PP_SORT_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define sv_ncmp S_sv_ncmp
+#define sv_i_ncmp S_sv_i_ncmp
+#define amagic_ncmp S_amagic_ncmp
+#define amagic_i_ncmp S_amagic_i_ncmp
+#define amagic_cmp S_amagic_cmp
+#define amagic_cmp_locale S_amagic_cmp_locale
+#define sortcv S_sortcv
+#define sortcv_xsub S_sortcv_xsub
+#define sortcv_stacked S_sortcv_stacked
+#define qsortsvu S_qsortsvu
+#endif
+#endif
+#if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define doform S_doform
+#endif
+# if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
+#ifdef PERL_CORE
+#define dooneliner S_dooneliner
+#endif
+# endif
+#ifdef PERL_CORE
+#define space_join_names_mortal S_space_join_names_mortal
+#endif
+#endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg S_reg
+#define reganode S_reganode
+#define regatom S_regatom
+#define regbranch S_regbranch
+#define reguni S_reguni
+#define regclass S_regclass
+#define regcurly S_regcurly
+#define reg_node S_reg_node
+#define reg_recode S_reg_recode
+#define regpiece S_regpiece
+#define reg_namedseq S_reg_namedseq
+#define reginsert S_reginsert
+#define regtail S_regtail
+#define reg_scan_name S_reg_scan_name
+#define join_exact S_join_exact
+#define regwhite S_regwhite
+#define nextchar S_nextchar
+#define reg_skipcomment S_reg_skipcomment
+#define scan_commit S_scan_commit
+#define cl_anything S_cl_anything
+#define cl_is_anything S_cl_is_anything
+#define cl_init S_cl_init
+#define cl_init_zero S_cl_init_zero
+#define cl_and S_cl_and
+#define cl_or S_cl_or
+#define study_chunk S_study_chunk
+#define add_data S_add_data
+#endif
+#ifdef PERL_CORE
+#define re_croak2 S_re_croak2
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regpposixcc S_regpposixcc
+#define checkposixcc S_checkposixcc
+#define make_trie S_make_trie
+#define make_trie_failtable S_make_trie_failtable
+#endif
+# ifdef DEBUGGING
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regdump_extflags S_regdump_extflags
+#define dumpuntil S_dumpuntil
+#define put_byte S_put_byte
+#define dump_trie S_dump_trie
+#define dump_trie_interim_list S_dump_trie_interim_list
+#define dump_trie_interim_table S_dump_trie_interim_table
+#define regtail_study S_regtail_study
+#endif
+# endif
+#endif
+#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regmatch S_regmatch
+#define regrepeat S_regrepeat
+#define regtry S_regtry
+#define reginclass S_reginclass
+#define regcppush S_regcppush
+#define regcppop S_regcppop
+#define reghop3 S_reghop3
+#endif
+#ifdef XXX_dmq
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reghop4 S_reghop4
+#endif
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reghopmaybe3 S_reghopmaybe3
+#define find_byclass S_find_byclass
+#define swap_match_buff S_swap_match_buff
+#define to_utf8_substr S_to_utf8_substr
+#define to_byte_substr S_to_byte_substr
+#define reg_check_named_buff_matched S_reg_check_named_buff_matched
+#endif
+# ifdef DEBUGGING
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define dump_exec_pos S_dump_exec_pos
+#define debug_start_match S_debug_start_match
+#endif
+# endif
+#endif
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define deb_curcv S_deb_curcv
+#define debprof S_debprof
+#define sequence S_sequence
+#define sequence_tail S_sequence_tail
+#define sequence_num S_sequence_num
+#define pm_description S_pm_description
+#endif
+#endif
+#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define save_scalar_at S_save_scalar_at
+#endif
+#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#endif
+#if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define uiv_2buf S_uiv_2buf
+#define sv_unglob S_sv_unglob
+#define not_a_number S_not_a_number
+#define visit S_visit
+#define sv_del_backref S_sv_del_backref
+#define varname S_varname
+#endif
+# ifdef DEBUGGING
+#ifdef PERL_CORE
+#define del_sv S_del_sv
+#endif
+# endif
+# if !defined(NV_PRESERVES_UV)
+# ifdef DEBUGGING
+#ifdef PERL_CORE
+#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
+#endif
+# else
+#ifdef PERL_CORE
+#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
+#endif
+# endif
+# endif
+#ifdef PERL_CORE
+#define expect_number S_expect_number
+#endif
+#ifdef PERL_CORE
+#define sv_pos_u2b_forwards S_sv_pos_u2b_forwards
+#define sv_pos_u2b_midway S_sv_pos_u2b_midway
+#define sv_pos_u2b_cached S_sv_pos_u2b_cached
+#define utf8_mg_pos_cache_update S_utf8_mg_pos_cache_update
+#define sv_pos_b2u_midway S_sv_pos_b2u_midway
+#define F0convert S_F0convert
+#endif
+# if defined(PERL_OLD_COPY_ON_WRITE)
+#ifdef PERL_CORE
+#define sv_release_COW S_sv_release_COW
+#endif
+# endif
+#ifdef PERL_CORE
+#define more_sv S_more_sv
+#define more_bodies S_more_bodies
+#define sv_2iuv_common S_sv_2iuv_common
+#define glob_assign_glob S_glob_assign_glob
+#define glob_assign_ref S_glob_assign_ref
+#define ptr_table_find S_ptr_table_find
+#endif
+#endif
+#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define check_uni S_check_uni
+#define force_next S_force_next
+#define force_version S_force_version
+#define force_word S_force_word
+#define tokeq S_tokeq
+#define readpipe_override S_readpipe_override
+#define scan_const S_scan_const
+#define scan_formline S_scan_formline
+#define scan_heredoc S_scan_heredoc
+#define scan_ident S_scan_ident
+#define scan_inputsymbol S_scan_inputsymbol
+#define scan_pat S_scan_pat
+#define scan_str S_scan_str
+#define scan_subst S_scan_subst
+#define scan_trans S_scan_trans
+#define scan_word S_scan_word
+#define update_debugger_info S_update_debugger_info
+#define skipspace S_skipspace
+#define swallow_bom S_swallow_bom
+#define checkcomma S_checkcomma
+#define feature_is_enabled S_feature_is_enabled
+#define force_ident S_force_ident
+#define incline S_incline
+#define intuit_method S_intuit_method
+#define intuit_more S_intuit_more
+#define lop S_lop
+#define missingterm S_missingterm
+#define no_op S_no_op
+#define sublex_done S_sublex_done
+#define sublex_push S_sublex_push
+#define sublex_start S_sublex_start
+#define filter_gets S_filter_gets
+#define find_in_my_stash S_find_in_my_stash
+#define tokenize_use S_tokenize_use
+#endif
+#ifdef PERL_CORE
+#define ao S_ao
+#endif
+# if defined(PERL_CR_FILTER)
+#ifdef PERL_CORE
+#define cr_textfilter S_cr_textfilter
+#define strip_return S_strip_return
+#endif
+# endif
+# if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define tokereport S_tokereport
+#define printbuf S_printbuf
+#endif
+# endif
+#endif
+#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define isa_lookup S_isa_lookup
+#endif
+#endif
+#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
+#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE)
+#ifdef PERL_CORE
+#define stdize_locale S_stdize_locale
+#endif
+#endif
+#endif
+#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define closest_cop S_closest_cop
+#define mess_alloc S_mess_alloc
+#define vdie_croak_common S_vdie_croak_common
+#define vdie_common S_vdie_common
+#define write_no_mem S_write_no_mem
+#endif
+#if defined(PERL_MEM_LOG) && defined(PERL_MEM_LOG_STDERR)
+#ifdef PERL_CORE
+#define mem_log_common S_mem_log_common
+#endif
+#endif
+#endif
+#if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define mulexp10 S_mulexp10
+#endif
+#endif
+#if defined(PERL_IN_UTF8_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define is_utf8_char_slow S_is_utf8_char_slow
+#define is_utf8_common S_is_utf8_common
+#define swash_get S_swash_get
+#endif
+#endif
+#define sv_setsv_flags Perl_sv_setsv_flags
+#define sv_catpvn_flags Perl_sv_catpvn_flags
+#define sv_catsv_flags Perl_sv_catsv_flags
+#define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags
+#define sv_pvn_force_flags Perl_sv_pvn_force_flags
+#define sv_copypv Perl_sv_copypv
+#define my_atof2 Perl_my_atof2
+#define my_socketpair Perl_my_socketpair
+#define my_dirfd Perl_my_dirfd
+#ifdef PERL_OLD_COPY_ON_WRITE
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define sv_setsv_cow Perl_sv_setsv_cow
+#endif
+#endif
+#if defined(USE_PERLIO) && !defined(USE_SFIO)
+#define PerlIO_close Perl_PerlIO_close
+#define PerlIO_fill Perl_PerlIO_fill
+#define PerlIO_fileno Perl_PerlIO_fileno
+#define PerlIO_eof Perl_PerlIO_eof
+#define PerlIO_error Perl_PerlIO_error
+#define PerlIO_flush Perl_PerlIO_flush
+#define PerlIO_clearerr Perl_PerlIO_clearerr
+#define PerlIO_set_cnt Perl_PerlIO_set_cnt
+#define PerlIO_set_ptrcnt Perl_PerlIO_set_ptrcnt
+#define PerlIO_setlinebuf Perl_PerlIO_setlinebuf
+#define PerlIO_read Perl_PerlIO_read
+#define PerlIO_write Perl_PerlIO_write
+#define PerlIO_unread Perl_PerlIO_unread
+#define PerlIO_tell Perl_PerlIO_tell
+#define PerlIO_seek Perl_PerlIO_seek
+#define PerlIO_get_base Perl_PerlIO_get_base
+#define PerlIO_get_ptr Perl_PerlIO_get_ptr
+#define PerlIO_get_bufsiz Perl_PerlIO_get_bufsiz
+#define PerlIO_get_cnt Perl_PerlIO_get_cnt
+#define PerlIO_stdin Perl_PerlIO_stdin
+#define PerlIO_stdout Perl_PerlIO_stdout
+#define PerlIO_stderr Perl_PerlIO_stderr
+#endif /* PERLIO_LAYERS */
+#ifdef PERL_CORE
+#define deb_stack_all Perl_deb_stack_all
+#endif
+#if defined(PERL_IN_DEB_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define deb_stack_n S_deb_stack_n
+#endif
+#endif
+#ifdef PERL_CORE
+#define pad_new Perl_pad_new
+#define pad_undef Perl_pad_undef
+#define pad_add_name Perl_pad_add_name
+#define pad_add_anon Perl_pad_add_anon
+#define pad_check_dup Perl_pad_check_dup
+#endif
+#ifdef DEBUGGING
+#ifdef PERL_CORE
+#define pad_setsv Perl_pad_setsv
+#endif
+#endif
+#ifdef PERL_CORE
+#define pad_block_start Perl_pad_block_start
+#define pad_tidy Perl_pad_tidy
+#define do_dump_pad Perl_do_dump_pad
+#define pad_fixup_inner_anons Perl_pad_fixup_inner_anons
+#endif
+#ifdef PERL_CORE
+#define pad_push Perl_pad_push
+#define pad_compname_type Perl_pad_compname_type
+#endif
+#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define pad_findlex S_pad_findlex
+#endif
+# if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define cv_dump S_cv_dump
+#endif
+# endif
+#endif
+#define find_runcv Perl_find_runcv
+#ifdef PERL_CORE
+#define free_tied_hv_pool Perl_free_tied_hv_pool
+#endif
+#if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define get_debug_opts Perl_get_debug_opts
+#endif
+#endif
+#define save_set_svflags Perl_save_set_svflags
+#define hv_scalar Perl_hv_scalar
+#define hv_name_set Perl_hv_name_set
+#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#endif
+#define hv_clear_placeholders Perl_hv_clear_placeholders
+#ifdef PERL_CORE
+#define magic_scalarpack Perl_magic_scalarpack
+#endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define find_hash_subscript S_find_hash_subscript
+#define find_array_subscript S_find_array_subscript
+#define find_uninit_var S_find_uninit_var
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLE16
+#ifdef PERL_CORE
+#define my_htole16 Perl_my_htole16
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOH16
+#ifdef PERL_CORE
+#define my_letoh16 Perl_my_letoh16
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE16
+#ifdef PERL_CORE
+#define my_htobe16 Perl_my_htobe16
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOH16
+#ifdef PERL_CORE
+#define my_betoh16 Perl_my_betoh16
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLE32
+#ifdef PERL_CORE
+#define my_htole32 Perl_my_htole32
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOH32
+#ifdef PERL_CORE
+#define my_letoh32 Perl_my_letoh32
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE32
+#ifdef PERL_CORE
+#define my_htobe32 Perl_my_htobe32
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOH32
+#ifdef PERL_CORE
+#define my_betoh32 Perl_my_betoh32
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLE64
+#ifdef PERL_CORE
+#define my_htole64 Perl_my_htole64
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOH64
+#ifdef PERL_CORE
+#define my_letoh64 Perl_my_letoh64
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE64
+#ifdef PERL_CORE
+#define my_htobe64 Perl_my_htobe64
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOH64
+#ifdef PERL_CORE
+#define my_betoh64 Perl_my_betoh64
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLES
+#ifdef PERL_CORE
+#define my_htoles Perl_my_htoles
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOHS
+#ifdef PERL_CORE
+#define my_letohs Perl_my_letohs
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBES
+#ifdef PERL_CORE
+#define my_htobes Perl_my_htobes
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOHS
+#ifdef PERL_CORE
+#define my_betohs Perl_my_betohs
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLEI
+#ifdef PERL_CORE
+#define my_htolei Perl_my_htolei
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOHI
+#ifdef PERL_CORE
+#define my_letohi Perl_my_letohi
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBEI
+#ifdef PERL_CORE
+#define my_htobei Perl_my_htobei
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOHI
+#ifdef PERL_CORE
+#define my_betohi Perl_my_betohi
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLEL
+#ifdef PERL_CORE
+#define my_htolel Perl_my_htolel
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOHL
+#ifdef PERL_CORE
+#define my_letohl Perl_my_letohl
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBEL
+#ifdef PERL_CORE
+#define my_htobel Perl_my_htobel
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOHL
+#ifdef PERL_CORE
+#define my_betohl Perl_my_betohl
+#endif
+#endif
+#ifdef PERL_CORE
+#define my_swabn Perl_my_swabn
+#endif
+#define gv_fetchpvn_flags Perl_gv_fetchpvn_flags
+#define gv_fetchsv Perl_gv_fetchsv
+#ifdef PERL_CORE
+#define is_gv_magical_sv Perl_is_gv_magical_sv
+#endif
+#define stashpv_hvname_match Perl_stashpv_hvname_match
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+#ifdef PERL_CORE
+#define dump_sv_child Perl_dump_sv_child
+#endif
+#endif
+#ifdef PERL_DONT_CREATE_GVSV
+#define gv_SVadd Perl_gv_SVadd
+#endif
+#ifdef PERL_CORE
+#define offer_nice_chunk Perl_offer_nice_chunk
+#endif
+#ifndef SPRINTF_RETURNS_STRLEN
+#endif
+#ifdef PERL_CORE
+#define my_clearenv Perl_my_clearenv
+#endif
+#ifdef PERL_IMPLICIT_CONTEXT
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+#else
+#endif
+#endif
+#ifndef HAS_STRLCAT
+#endif
+#ifndef HAS_STRLCPY
+#endif
+#ifdef PERL_MAD
+#ifdef PERL_CORE
+#define pad_peg Perl_pad_peg
+#endif
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define xmldump_attr S_xmldump_attr
+#endif
+#endif
+#ifdef PERL_CORE
+#define xmldump_indent Perl_xmldump_indent
+#define xmldump_vindent Perl_xmldump_vindent
+#define xmldump_all Perl_xmldump_all
+#define xmldump_packsubs Perl_xmldump_packsubs
+#define xmldump_sub Perl_xmldump_sub
+#define xmldump_form Perl_xmldump_form
+#define xmldump_eval Perl_xmldump_eval
+#define sv_catxmlsv Perl_sv_catxmlsv
+#define sv_catxmlpvn Perl_sv_catxmlpvn
+#define sv_xmlpeek Perl_sv_xmlpeek
+#define do_pmop_xmldump Perl_do_pmop_xmldump
+#define pmop_xmldump Perl_pmop_xmldump
+#define do_op_xmldump Perl_do_op_xmldump
+#define op_xmldump Perl_op_xmldump
+#endif
+#ifdef PERL_CORE
+#define newTOKEN Perl_newTOKEN
+#define token_free Perl_token_free
+#define token_getmad Perl_token_getmad
+#define op_getmad_weak Perl_op_getmad_weak
+#define op_getmad Perl_op_getmad
+#define prepend_madprops Perl_prepend_madprops
+#define append_madprops Perl_append_madprops
+#define addmad Perl_addmad
+#define newMADsv Perl_newMADsv
+#define newMADPROP Perl_newMADPROP
+#define mad_free Perl_mad_free
+#endif
+# if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define skipspace0 S_skipspace0
+#define skipspace1 S_skipspace1
+#define skipspace2 S_skipspace2
+#define start_force S_start_force
+#define curmad S_curmad
+#endif
+# endif
+#ifdef PERL_CORE
+#define madlex Perl_madlex
+#define madparse Perl_madparse
+#endif
+#endif
+#if !defined(HAS_SIGNBIT)
+#endif
+#if defined(USE_ITHREADS)
+#ifdef PERL_CORE
+#define mro_meta_dup Perl_mro_meta_dup
+#endif
+#endif
+#define mro_get_linear_isa Perl_mro_get_linear_isa
+#if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define mro_get_linear_isa_dfs S_mro_get_linear_isa_dfs
+#endif
+#endif
+#ifdef PERL_CORE
+#define mro_isa_changed_in Perl_mro_isa_changed_in
+#endif
+#define mro_method_changed_in Perl_mro_method_changed_in
+#ifdef PERL_CORE
+#define boot_core_mro Perl_boot_core_mro
+#endif
+#define ck_anoncode Perl_ck_anoncode
+#define ck_bitop Perl_ck_bitop
+#define ck_chdir Perl_ck_chdir
+#define ck_concat Perl_ck_concat
+#define ck_defined Perl_ck_defined
+#define ck_delete Perl_ck_delete
+#define ck_die Perl_ck_die
+#define ck_eof Perl_ck_eof
+#define ck_eval Perl_ck_eval
+#define ck_exec Perl_ck_exec
+#define ck_exists Perl_ck_exists
+#define ck_exit Perl_ck_exit
+#define ck_ftst Perl_ck_ftst
+#define ck_fun Perl_ck_fun
+#define ck_glob Perl_ck_glob
+#define ck_grep Perl_ck_grep
+#define ck_index Perl_ck_index
+#define ck_join Perl_ck_join
+#define ck_lengthconst Perl_ck_lengthconst
+#define ck_lfun Perl_ck_lfun
+#define ck_listiob Perl_ck_listiob
+#define ck_match Perl_ck_match
+#define ck_method Perl_ck_method
+#define ck_null Perl_ck_null
+#define ck_open Perl_ck_open
+#define ck_readline Perl_ck_readline
+#define ck_repeat Perl_ck_repeat
+#define ck_require Perl_ck_require
+#define ck_return Perl_ck_return
+#define ck_rfun Perl_ck_rfun
+#define ck_rvconst Perl_ck_rvconst
+#define ck_sassign Perl_ck_sassign
+#define ck_select Perl_ck_select
+#define ck_shift Perl_ck_shift
+#define ck_smartmatch Perl_ck_smartmatch
+#define ck_sort Perl_ck_sort
+#define ck_spair Perl_ck_spair
+#define ck_split Perl_ck_split
+#define ck_subr Perl_ck_subr
+#define ck_substr Perl_ck_substr
+#define ck_svconst Perl_ck_svconst
+#define ck_trunc Perl_ck_trunc
+#define ck_unpack Perl_ck_unpack
+#define pp_aassign Perl_pp_aassign
+#define pp_abs Perl_pp_abs
+#define pp_accept Perl_pp_accept
+#define pp_add Perl_pp_add
+#define pp_aelem Perl_pp_aelem
+#define pp_aelemfast Perl_pp_aelemfast
+#define pp_alarm Perl_pp_alarm
+#define pp_and Perl_pp_and
+#define pp_andassign Perl_pp_andassign
+#define pp_anoncode Perl_pp_anoncode
+#define pp_anonhash Perl_pp_anonhash
+#define pp_anonlist Perl_pp_anonlist
+#define pp_aslice Perl_pp_aslice
+#define pp_atan2 Perl_pp_atan2
+#define pp_av2arylen Perl_pp_av2arylen
+#define pp_backtick Perl_pp_backtick
+#define pp_bind Perl_pp_bind
+#define pp_binmode Perl_pp_binmode
+#define pp_bit_and Perl_pp_bit_and
+#define pp_bit_or Perl_pp_bit_or
+#define pp_bit_xor Perl_pp_bit_xor
+#define pp_bless Perl_pp_bless
+#define pp_break Perl_pp_break
+#define pp_caller Perl_pp_caller
+#define pp_chdir Perl_pp_chdir
+#define pp_chmod Perl_pp_chmod
+#define pp_chomp Perl_pp_chomp
+#define pp_chop Perl_pp_chop
+#define pp_chown Perl_pp_chown
+#define pp_chr Perl_pp_chr
+#define pp_chroot Perl_pp_chroot
+#define pp_close Perl_pp_close
+#define pp_closedir Perl_pp_closedir
+#define pp_complement Perl_pp_complement
+#define pp_concat Perl_pp_concat
+#define pp_cond_expr Perl_pp_cond_expr
+#define pp_connect Perl_pp_connect
+#define pp_const Perl_pp_const
+#define pp_continue Perl_pp_continue
+#define pp_cos Perl_pp_cos
+#define pp_crypt Perl_pp_crypt
+#define pp_dbmclose Perl_pp_dbmclose
+#define pp_dbmopen Perl_pp_dbmopen
+#define pp_dbstate Perl_pp_dbstate
+#define pp_defined Perl_pp_defined
+#define pp_delete Perl_pp_delete
+#define pp_die Perl_pp_die
+#define pp_divide Perl_pp_divide
+#define pp_dofile Perl_pp_dofile
+#define pp_dor Perl_pp_dor
+#define pp_dorassign Perl_pp_dorassign
+#define pp_dump Perl_pp_dump
+#define pp_each Perl_pp_each
+#define pp_egrent Perl_pp_egrent
+#define pp_ehostent Perl_pp_ehostent
+#define pp_enetent Perl_pp_enetent
+#define pp_enter Perl_pp_enter
+#define pp_entereval Perl_pp_entereval
+#define pp_entergiven Perl_pp_entergiven
+#define pp_enteriter Perl_pp_enteriter
+#define pp_enterloop Perl_pp_enterloop
+#define pp_entersub Perl_pp_entersub
+#define pp_entertry Perl_pp_entertry
+#define pp_enterwhen Perl_pp_enterwhen
+#define pp_enterwrite Perl_pp_enterwrite
+#define pp_eof Perl_pp_eof
+#define pp_eprotoent Perl_pp_eprotoent
+#define pp_epwent Perl_pp_epwent
+#define pp_eq Perl_pp_eq
+#define pp_eservent Perl_pp_eservent
+#define pp_exec Perl_pp_exec
+#define pp_exists Perl_pp_exists
+#define pp_exit Perl_pp_exit
+#define pp_exp Perl_pp_exp
+#define pp_fcntl Perl_pp_fcntl
+#define pp_fileno Perl_pp_fileno
+#define pp_flip Perl_pp_flip
+#define pp_flock Perl_pp_flock
+#define pp_flop Perl_pp_flop
+#define pp_fork Perl_pp_fork
+#define pp_formline Perl_pp_formline
+#define pp_ftatime Perl_pp_ftatime
+#define pp_ftbinary Perl_pp_ftbinary
+#define pp_ftblk Perl_pp_ftblk
+#define pp_ftchr Perl_pp_ftchr
+#define pp_ftctime Perl_pp_ftctime
+#define pp_ftdir Perl_pp_ftdir
+#define pp_fteexec Perl_pp_fteexec
+#define pp_fteowned Perl_pp_fteowned
+#define pp_fteread Perl_pp_fteread
+#define pp_ftewrite Perl_pp_ftewrite
+#define pp_ftfile Perl_pp_ftfile
+#define pp_ftis Perl_pp_ftis
+#define pp_ftlink Perl_pp_ftlink
+#define pp_ftmtime Perl_pp_ftmtime
+#define pp_ftpipe Perl_pp_ftpipe
+#define pp_ftrexec Perl_pp_ftrexec
+#define pp_ftrowned Perl_pp_ftrowned
+#define pp_ftrread Perl_pp_ftrread
+#define pp_ftrwrite Perl_pp_ftrwrite
+#define pp_ftsgid Perl_pp_ftsgid
+#define pp_ftsize Perl_pp_ftsize
+#define pp_ftsock Perl_pp_ftsock
+#define pp_ftsuid Perl_pp_ftsuid
+#define pp_ftsvtx Perl_pp_ftsvtx
+#define pp_fttext Perl_pp_fttext
+#define pp_fttty Perl_pp_fttty
+#define pp_ftzero Perl_pp_ftzero
+#define pp_ge Perl_pp_ge
+#define pp_gelem Perl_pp_gelem
+#define pp_getc Perl_pp_getc
+#define pp_getlogin Perl_pp_getlogin
+#define pp_getpeername Perl_pp_getpeername
+#define pp_getpgrp Perl_pp_getpgrp
+#define pp_getppid Perl_pp_getppid
+#define pp_getpriority Perl_pp_getpriority
+#define pp_getsockname Perl_pp_getsockname
+#define pp_ggrent Perl_pp_ggrent
+#define pp_ggrgid Perl_pp_ggrgid
+#define pp_ggrnam Perl_pp_ggrnam
+#define pp_ghbyaddr Perl_pp_ghbyaddr
+#define pp_ghbyname Perl_pp_ghbyname
+#define pp_ghostent Perl_pp_ghostent
+#define pp_glob Perl_pp_glob
+#define pp_gmtime Perl_pp_gmtime
+#define pp_gnbyaddr Perl_pp_gnbyaddr
+#define pp_gnbyname Perl_pp_gnbyname
+#define pp_gnetent Perl_pp_gnetent
+#define pp_goto Perl_pp_goto
+#define pp_gpbyname Perl_pp_gpbyname
+#define pp_gpbynumber Perl_pp_gpbynumber
+#define pp_gprotoent Perl_pp_gprotoent
+#define pp_gpwent Perl_pp_gpwent
+#define pp_gpwnam Perl_pp_gpwnam
+#define pp_gpwuid Perl_pp_gpwuid
+#define pp_grepstart Perl_pp_grepstart
+#define pp_grepwhile Perl_pp_grepwhile
+#define pp_gsbyname Perl_pp_gsbyname
+#define pp_gsbyport Perl_pp_gsbyport
+#define pp_gservent Perl_pp_gservent
+#define pp_gsockopt Perl_pp_gsockopt
+#define pp_gt Perl_pp_gt
+#define pp_gv Perl_pp_gv
+#define pp_gvsv Perl_pp_gvsv
+#define pp_helem Perl_pp_helem
+#define pp_hex Perl_pp_hex
+#define pp_hslice Perl_pp_hslice
+#define pp_i_add Perl_pp_i_add
+#define pp_i_divide Perl_pp_i_divide
+#define pp_i_eq Perl_pp_i_eq
+#define pp_i_ge Perl_pp_i_ge
+#define pp_i_gt Perl_pp_i_gt
+#define pp_i_le Perl_pp_i_le
+#define pp_i_lt Perl_pp_i_lt
+#define pp_i_modulo Perl_pp_i_modulo
+#define pp_i_multiply Perl_pp_i_multiply
+#define pp_i_ncmp Perl_pp_i_ncmp
+#define pp_i_ne Perl_pp_i_ne
+#define pp_i_negate Perl_pp_i_negate
+#define pp_i_subtract Perl_pp_i_subtract
+#define pp_index Perl_pp_index
+#define pp_int Perl_pp_int
+#define pp_ioctl Perl_pp_ioctl
+#define pp_iter Perl_pp_iter
+#define pp_join Perl_pp_join
+#define pp_keys Perl_pp_keys
+#define pp_kill Perl_pp_kill
+#define pp_last Perl_pp_last
+#define pp_lc Perl_pp_lc
+#define pp_lcfirst Perl_pp_lcfirst
+#define pp_le Perl_pp_le
+#define pp_leave Perl_pp_leave
+#define pp_leaveeval Perl_pp_leaveeval
+#define pp_leavegiven Perl_pp_leavegiven
+#define pp_leaveloop Perl_pp_leaveloop
+#define pp_leavesub Perl_pp_leavesub
+#define pp_leavesublv Perl_pp_leavesublv
+#define pp_leavetry Perl_pp_leavetry
+#define pp_leavewhen Perl_pp_leavewhen
+#define pp_leavewrite Perl_pp_leavewrite
+#define pp_left_shift Perl_pp_left_shift
+#define pp_length Perl_pp_length
+#define pp_lineseq Perl_pp_lineseq
+#define pp_link Perl_pp_link
+#define pp_list Perl_pp_list
+#define pp_listen Perl_pp_listen
+#define pp_localtime Perl_pp_localtime
+#define pp_lock Perl_pp_lock
+#define pp_log Perl_pp_log
+#define pp_lslice Perl_pp_lslice
+#define pp_lstat Perl_pp_lstat
+#define pp_lt Perl_pp_lt
+#define pp_mapstart Perl_pp_mapstart
+#define pp_mapwhile Perl_pp_mapwhile
+#define pp_match Perl_pp_match
+#define pp_method Perl_pp_method
+#define pp_method_named Perl_pp_method_named
+#define pp_mkdir Perl_pp_mkdir
+#define pp_modulo Perl_pp_modulo
+#define pp_msgctl Perl_pp_msgctl
+#define pp_msgget Perl_pp_msgget
+#define pp_msgrcv Perl_pp_msgrcv
+#define pp_msgsnd Perl_pp_msgsnd
+#define pp_multiply Perl_pp_multiply
+#define pp_ncmp Perl_pp_ncmp
+#define pp_ne Perl_pp_ne
+#define pp_negate Perl_pp_negate
+#define pp_next Perl_pp_next
+#define pp_nextstate Perl_pp_nextstate
+#define pp_not Perl_pp_not
+#define pp_null Perl_pp_null
+#define pp_oct Perl_pp_oct
+#define pp_once Perl_pp_once
+#define pp_open Perl_pp_open
+#define pp_open_dir Perl_pp_open_dir
+#define pp_or Perl_pp_or
+#define pp_orassign Perl_pp_orassign
+#define pp_ord Perl_pp_ord
+#define pp_pack Perl_pp_pack
+#define pp_padany Perl_pp_padany
+#define pp_padav Perl_pp_padav
+#define pp_padhv Perl_pp_padhv
+#define pp_padsv Perl_pp_padsv
+#define pp_pipe_op Perl_pp_pipe_op
+#define pp_pop Perl_pp_pop
+#define pp_pos Perl_pp_pos
+#define pp_postdec Perl_pp_postdec
+#define pp_postinc Perl_pp_postinc
+#define pp_pow Perl_pp_pow
+#define pp_predec Perl_pp_predec
+#define pp_preinc Perl_pp_preinc
+#define pp_print Perl_pp_print
+#define pp_prototype Perl_pp_prototype
+#define pp_prtf Perl_pp_prtf
+#define pp_push Perl_pp_push
+#define pp_pushmark Perl_pp_pushmark
+#define pp_pushre Perl_pp_pushre
+#define pp_qr Perl_pp_qr
+#define pp_quotemeta Perl_pp_quotemeta
+#define pp_rand Perl_pp_rand
+#define pp_range Perl_pp_range
+#define pp_rcatline Perl_pp_rcatline
+#define pp_read Perl_pp_read
+#define pp_readdir Perl_pp_readdir
+#define pp_readline Perl_pp_readline
+#define pp_readlink Perl_pp_readlink
+#define pp_recv Perl_pp_recv
+#define pp_redo Perl_pp_redo
+#define pp_ref Perl_pp_ref
+#define pp_refgen Perl_pp_refgen
+#define pp_regcmaybe Perl_pp_regcmaybe
+#define pp_regcomp Perl_pp_regcomp
+#define pp_regcreset Perl_pp_regcreset
+#define pp_rename Perl_pp_rename
+#define pp_repeat Perl_pp_repeat
+#define pp_require Perl_pp_require
+#define pp_reset Perl_pp_reset
+#define pp_return Perl_pp_return
+#define pp_reverse Perl_pp_reverse
+#define pp_rewinddir Perl_pp_rewinddir
+#define pp_right_shift Perl_pp_right_shift
+#define pp_rindex Perl_pp_rindex
+#define pp_rmdir Perl_pp_rmdir
+#define pp_rv2av Perl_pp_rv2av
+#define pp_rv2cv Perl_pp_rv2cv
+#define pp_rv2gv Perl_pp_rv2gv
+#define pp_rv2hv Perl_pp_rv2hv
+#define pp_rv2sv Perl_pp_rv2sv
+#define pp_sassign Perl_pp_sassign
+#define pp_say Perl_pp_say
+#define pp_scalar Perl_pp_scalar
+#define pp_schomp Perl_pp_schomp
+#define pp_schop Perl_pp_schop
+#define pp_scmp Perl_pp_scmp
+#define pp_scope Perl_pp_scope
+#define pp_seek Perl_pp_seek
+#define pp_seekdir Perl_pp_seekdir
+#define pp_select Perl_pp_select
+#define pp_semctl Perl_pp_semctl
+#define pp_semget Perl_pp_semget
+#define pp_semop Perl_pp_semop
+#define pp_send Perl_pp_send
+#define pp_seq Perl_pp_seq
+#define pp_setpgrp Perl_pp_setpgrp
+#define pp_setpriority Perl_pp_setpriority
+#define pp_setstate Perl_pp_setstate
+#define pp_sge Perl_pp_sge
+#define pp_sgrent Perl_pp_sgrent
+#define pp_sgt Perl_pp_sgt
+#define pp_shift Perl_pp_shift
+#define pp_shmctl Perl_pp_shmctl
+#define pp_shmget Perl_pp_shmget
+#define pp_shmread Perl_pp_shmread
+#define pp_shmwrite Perl_pp_shmwrite
+#define pp_shostent Perl_pp_shostent
+#define pp_shutdown Perl_pp_shutdown
+#define pp_sin Perl_pp_sin
+#define pp_sle Perl_pp_sle
+#define pp_sleep Perl_pp_sleep
+#define pp_slt Perl_pp_slt
+#define pp_smartmatch Perl_pp_smartmatch
+#define pp_sne Perl_pp_sne
+#define pp_snetent Perl_pp_snetent
+#define pp_socket Perl_pp_socket
+#define pp_sockpair Perl_pp_sockpair
+#define pp_sort Perl_pp_sort
+#define pp_splice Perl_pp_splice
+#define pp_split Perl_pp_split
+#define pp_sprintf Perl_pp_sprintf
+#define pp_sprotoent Perl_pp_sprotoent
+#define pp_spwent Perl_pp_spwent
+#define pp_sqrt Perl_pp_sqrt
+#define pp_srand Perl_pp_srand
+#define pp_srefgen Perl_pp_srefgen
+#define pp_sselect Perl_pp_sselect
+#define pp_sservent Perl_pp_sservent
+#define pp_ssockopt Perl_pp_ssockopt
+#define pp_stat Perl_pp_stat
+#define pp_stringify Perl_pp_stringify
+#define pp_stub Perl_pp_stub
+#define pp_study Perl_pp_study
+#define pp_subst Perl_pp_subst
+#define pp_substcont Perl_pp_substcont
+#define pp_substr Perl_pp_substr
+#define pp_subtract Perl_pp_subtract
+#define pp_symlink Perl_pp_symlink
+#define pp_syscall Perl_pp_syscall
+#define pp_sysopen Perl_pp_sysopen
+#define pp_sysread Perl_pp_sysread
+#define pp_sysseek Perl_pp_sysseek
+#define pp_system Perl_pp_system
+#define pp_syswrite Perl_pp_syswrite
+#define pp_tell Perl_pp_tell
+#define pp_telldir Perl_pp_telldir
+#define pp_tie Perl_pp_tie
+#define pp_tied Perl_pp_tied
+#define pp_time Perl_pp_time
+#define pp_tms Perl_pp_tms
+#define pp_trans Perl_pp_trans
+#define pp_truncate Perl_pp_truncate
+#define pp_uc Perl_pp_uc
+#define pp_ucfirst Perl_pp_ucfirst
+#define pp_umask Perl_pp_umask
+#define pp_undef Perl_pp_undef
+#define pp_unlink Perl_pp_unlink
+#define pp_unpack Perl_pp_unpack
+#define pp_unshift Perl_pp_unshift
+#define pp_unstack Perl_pp_unstack
+#define pp_untie Perl_pp_untie
+#define pp_utime Perl_pp_utime
+#define pp_values Perl_pp_values
+#define pp_vec Perl_pp_vec
+#define pp_wait Perl_pp_wait
+#define pp_waitpid Perl_pp_waitpid
+#define pp_wantarray Perl_pp_wantarray
+#define pp_warn Perl_pp_warn
+#define pp_xor Perl_pp_xor
+
+#else /* PERL_IMPLICIT_CONTEXT */
+
+#if defined(PERL_IMPLICIT_SYS)
+#endif
+#define doing_taint Perl_doing_taint
+#if defined(USE_ITHREADS)
+# if defined(PERL_IMPLICIT_SYS)
+# endif
+#endif
+#if defined(MYMALLOC)
+#ifdef PERL_CORE
+#define malloced_size Perl_malloced_size
+#define malloc_good_size Perl_malloc_good_size
+#endif
+#endif
+#define get_context Perl_get_context
+#define set_context Perl_set_context
+#define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d)
+#define Gv_AMupdate(a) Perl_Gv_AMupdate(aTHX_ a)
+#define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b)
+#ifdef PERL_CORE
+#define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c)
+#define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c)
+#define apply(a,b,c) Perl_apply(aTHX_ a,b,c)
+#endif
+#define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d)
+#define av_clear(a) Perl_av_clear(aTHX_ a)
+#define av_delete(a,b,c) Perl_av_delete(aTHX_ a,b,c)
+#define av_exists(a,b) Perl_av_exists(aTHX_ a,b)
+#define av_extend(a,b) Perl_av_extend(aTHX_ a,b)
+#ifdef PERL_CORE
+#define av_fake(a,b) Perl_av_fake(aTHX_ a,b)
+#endif
+#define av_fetch(a,b,c) Perl_av_fetch(aTHX_ a,b,c)
+#define av_fill(a,b) Perl_av_fill(aTHX_ a,b)
+#define av_len(a) Perl_av_len(aTHX_ a)
+#define av_make(a,b) Perl_av_make(aTHX_ a,b)
+#define av_pop(a) Perl_av_pop(aTHX_ a)
+#define av_push(a,b) Perl_av_push(aTHX_ a,b)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define av_reify(a) Perl_av_reify(aTHX_ a)
+#endif
+#define av_shift(a) Perl_av_shift(aTHX_ a)
+#define av_store(a,b,c) Perl_av_store(aTHX_ a,b,c)
+#define av_undef(a) Perl_av_undef(aTHX_ a)
+#define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b)
+#ifdef PERL_CORE
+#define bind_match(a,b,c) Perl_bind_match(aTHX_ a,b,c)
+#define block_end(a,b) Perl_block_end(aTHX_ a,b)
+#endif
+#define block_gimme() Perl_block_gimme(aTHX)
+#ifdef PERL_CORE
+#define block_start(a) Perl_block_start(aTHX_ a)
+#define boot_core_UNIVERSAL() Perl_boot_core_UNIVERSAL(aTHX)
+#define boot_core_PerlIO() Perl_boot_core_PerlIO(aTHX)
+#endif
+#define call_list(a,b) Perl_call_list(aTHX_ a,b)
+#ifdef PERL_CORE
+#define cando(a,b,c) Perl_cando(aTHX_ a,b,c)
+#endif
+#define cast_ulong(a) Perl_cast_ulong(aTHX_ a)
+#define cast_i32(a) Perl_cast_i32(aTHX_ a)
+#define cast_iv(a) Perl_cast_iv(aTHX_ a)
+#define cast_uv(a) Perl_cast_uv(aTHX_ a)
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
+#define my_chsize(a,b) Perl_my_chsize(aTHX_ a,b)
+#endif
+#ifdef PERL_CORE
+#define convert(a,b,c) Perl_convert(aTHX_ a,b,c)
+#define create_eval_scope(a) Perl_create_eval_scope(aTHX_ a)
+#endif
+#define vcroak(a,b) Perl_vcroak(aTHX_ a,b)
+#define croak_xs_usage(a,b) Perl_croak_xs_usage(aTHX_ a,b)
+#if defined(PERL_IMPLICIT_CONTEXT)
+#endif
+#ifdef PERL_CORE
+#define cv_ckproto(a,b,c) Perl_cv_ckproto(aTHX_ a,b,c)
+#define cv_ckproto_len(a,b,c,d) Perl_cv_ckproto_len(aTHX_ a,b,c,d)
+#define cv_clone(a) Perl_cv_clone(aTHX_ a)
+#endif
+#define gv_const_sv(a) Perl_gv_const_sv(aTHX_ a)
+#define cv_const_sv(a) Perl_cv_const_sv(aTHX_ a)
+#ifdef PERL_CORE
+#define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b)
+#endif
+#define cv_undef(a) Perl_cv_undef(aTHX_ a)
+#define cx_dump(a) Perl_cx_dump(aTHX_ a)
+#define filter_add(a,b) Perl_filter_add(aTHX_ a,b)
+#define filter_del(a) Perl_filter_del(aTHX_ a)
+#define filter_read(a,b,c) Perl_filter_read(aTHX_ a,b,c)
+#define get_op_descs() Perl_get_op_descs(aTHX)
+#define get_op_names() Perl_get_op_names(aTHX)
+#ifdef PERL_CORE
+#define get_no_modify() Perl_get_no_modify(aTHX)
+#define get_opargs() Perl_get_opargs(aTHX)
+#endif
+#define get_ppaddr() Perl_get_ppaddr(aTHX)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define cxinc() Perl_cxinc(aTHX)
+#endif
+#define vdeb(a,b) Perl_vdeb(aTHX_ a,b)
+#define debprofdump() Perl_debprofdump(aTHX)
+#define debop(a) Perl_debop(aTHX_ a)
+#define debstack() Perl_debstack(aTHX)
+#define debstackptrs() Perl_debstackptrs(aTHX)
+#define delimcpy(a,b,c,d,e,f) Perl_delimcpy(aTHX_ a,b,c,d,e,f)
+#ifdef PERL_CORE
+#define delete_eval_scope() Perl_delete_eval_scope(aTHX)
+#define deprecate(a) Perl_deprecate(aTHX_ a)
+#define deprecate_old(a) Perl_deprecate_old(aTHX_ a)
+#endif
+#ifdef PERL_CORE
+#define vdie(a,b) Perl_vdie(aTHX_ a,b)
+#define die_where(a,b) Perl_die_where(aTHX_ a,b)
+#endif
+#define dounwind(a) Perl_dounwind(aTHX_ a)
+#ifdef PERL_CORE
+#define do_aexec5(a,b,c,d,e) Perl_do_aexec5(aTHX_ a,b,c,d,e)
+#endif
+#define do_binmode(a,b,c) Perl_do_binmode(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define do_chop(a,b) Perl_do_chop(aTHX_ a,b)
+#endif
+#define do_close(a,b) Perl_do_close(aTHX_ a,b)
+#ifdef PERL_CORE
+#define do_eof(a) Perl_do_eof(aTHX_ a)
+#endif
+#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+#ifdef PERL_CORE
+#endif
+#else
+#ifdef PERL_CORE
+#define do_exec(a) Perl_do_exec(aTHX_ a)
+#endif
+#endif
+#if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS)
+#define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c)
+#define do_spawn(a) Perl_do_spawn(aTHX_ a)
+#define do_spawn_nowait(a) Perl_do_spawn_nowait(aTHX_ a)
+#endif
+#if !defined(WIN32)
+#ifdef PERL_CORE
+#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
+#endif
+#endif
+#ifdef PERL_CORE
+#define do_execfree() Perl_do_execfree(aTHX)
+#endif
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define exec_failed(a,b,c) S_exec_failed(aTHX_ a,b,c)
+#endif
+#endif
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+#ifdef PERL_CORE
+#define do_ipcctl(a,b,c) Perl_do_ipcctl(aTHX_ a,b,c)
+#define do_ipcget(a,b,c) Perl_do_ipcget(aTHX_ a,b,c)
+#define do_msgrcv(a,b) Perl_do_msgrcv(aTHX_ a,b)
+#define do_msgsnd(a,b) Perl_do_msgsnd(aTHX_ a,b)
+#define do_semop(a,b) Perl_do_semop(aTHX_ a,b)
+#define do_shmio(a,b,c) Perl_do_shmio(aTHX_ a,b,c)
+#endif
+#endif
+#define do_join(a,b,c,d) Perl_do_join(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#define do_kv() Perl_do_kv(aTHX)
+#endif
+#define do_open9(a,b,c,d,e,f,g,h,i) Perl_do_open9(aTHX_ a,b,c,d,e,f,g,h,i)
+#define do_openn(a,b,c,d,e,f,g,h,i) Perl_do_openn(aTHX_ a,b,c,d,e,f,g,h,i)
+#ifdef PERL_CORE
+#define do_print(a,b) Perl_do_print(aTHX_ a,b)
+#define do_readline() Perl_do_readline(aTHX)
+#define do_chomp(a) Perl_do_chomp(aTHX_ a)
+#define do_seek(a,b,c) Perl_do_seek(aTHX_ a,b,c)
+#endif
+#define do_sprintf(a,b,c) Perl_do_sprintf(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define do_sysseek(a,b,c) Perl_do_sysseek(aTHX_ a,b,c)
+#define do_tell(a) Perl_do_tell(aTHX_ a)
+#define do_trans(a) Perl_do_trans(aTHX_ a)
+#define do_vecget(a,b,c) Perl_do_vecget(aTHX_ a,b,c)
+#define do_vecset(a) Perl_do_vecset(aTHX_ a)
+#define do_vop(a,b,c,d) Perl_do_vop(aTHX_ a,b,c,d)
+#define dofile(a,b) Perl_dofile(aTHX_ a,b)
+#endif
+#define dowantarray() Perl_dowantarray(aTHX)
+#define dump_all() Perl_dump_all(aTHX)
+#define dump_eval() Perl_dump_eval(aTHX)
+#if defined(DUMP_FDS)
+#define dump_fds(a) Perl_dump_fds(aTHX_ a)
+#endif
+#define dump_form(a) Perl_dump_form(aTHX_ a)
+#define gv_dump(a) Perl_gv_dump(aTHX_ a)
+#define op_dump(a) Perl_op_dump(aTHX_ a)
+#define pmop_dump(a) Perl_pmop_dump(aTHX_ a)
+#define dump_packsubs(a) Perl_dump_packsubs(aTHX_ a)
+#define dump_sub(a) Perl_dump_sub(aTHX_ a)
+#define fbm_compile(a,b) Perl_fbm_compile(aTHX_ a,b)
+#define fbm_instr(a,b,c,d) Perl_fbm_instr(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#define find_script(a,b,c,d) Perl_find_script(aTHX_ a,b,c,d)
+#define force_list(a) Perl_force_list(aTHX_ a)
+#define fold_constants(a) Perl_fold_constants(aTHX_ a)
+#endif
+#define vform(a,b) Perl_vform(aTHX_ a,b)
+#define free_tmps() Perl_free_tmps(aTHX)
+#ifdef PERL_CORE
+#define gen_constant_list(a) Perl_gen_constant_list(aTHX_ a)
+#endif
+#if !defined(HAS_GETENV_LEN)
+#ifdef PERL_CORE
+#define getenv_len(a,b) Perl_getenv_len(aTHX_ a,b)
+#endif
+#endif
+#ifdef PERL_CORE
+#endif
+#define gp_free(a) Perl_gp_free(aTHX_ a)
+#define gp_ref(a) Perl_gp_ref(aTHX_ a)
+#define gv_AVadd(a) Perl_gv_AVadd(aTHX_ a)
+#define gv_HVadd(a) Perl_gv_HVadd(aTHX_ a)
+#define gv_IOadd(a) Perl_gv_IOadd(aTHX_ a)
+#define gv_autoload4(a,b,c,d) Perl_gv_autoload4(aTHX_ a,b,c,d)
+#define gv_check(a) Perl_gv_check(aTHX_ a)
+#define gv_efullname(a,b) Perl_gv_efullname(aTHX_ a,b)
+#define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
+#define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a)
+#define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c)
+#define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d)
+#define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
+#define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
+#define gv_fetchpv(a,b,c) Perl_gv_fetchpv(aTHX_ a,b,c)
+#define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b)
+#define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#endif
+#define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e)
+#define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d)
+#define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b)
+#define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c)
+#define gv_stashsv(a,b) Perl_gv_stashsv(aTHX_ a,b)
+#define hv_clear(a) Perl_hv_clear(aTHX_ a)
+#ifdef PERL_CORE
+#endif
+#define hv_delayfree_ent(a,b) Perl_hv_delayfree_ent(aTHX_ a,b)
+#define hv_common(a,b,c,d,e,f,g,h) Perl_hv_common(aTHX_ a,b,c,d,e,f,g,h)
+#define hv_common_key_len(a,b,c,d,e,f) Perl_hv_common_key_len(aTHX_ a,b,c,d,e,f)
+#define hv_free_ent(a,b) Perl_hv_free_ent(aTHX_ a,b)
+#define hv_iterinit(a) Perl_hv_iterinit(aTHX_ a)
+#define hv_iterkey(a,b) Perl_hv_iterkey(aTHX_ a,b)
+#define hv_iterkeysv(a) Perl_hv_iterkeysv(aTHX_ a)
+#define hv_iternextsv(a,b,c) Perl_hv_iternextsv(aTHX_ a,b,c)
+#define hv_iternext_flags(a,b) Perl_hv_iternext_flags(aTHX_ a,b)
+#define hv_iterval(a,b) Perl_hv_iterval(aTHX_ a,b)
+#define hv_ksplit(a,b) Perl_hv_ksplit(aTHX_ a,b)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#endif
+#ifdef PERL_CORE
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#endif
+#define hv_undef(a) Perl_hv_undef(aTHX_ a)
+#define ibcmp(a,b,c) Perl_ibcmp(aTHX_ a,b,c)
+#define ibcmp_locale(a,b,c) Perl_ibcmp_locale(aTHX_ a,b,c)
+#define ibcmp_utf8(a,b,c,d,e,f,g,h) Perl_ibcmp_utf8(aTHX_ a,b,c,d,e,f,g,h)
+#ifdef PERL_CORE
+#define ingroup(a,b) Perl_ingroup(aTHX_ a,b)
+#define init_argv_symbols(a,b) Perl_init_argv_symbols(aTHX_ a,b)
+#define init_debugger() Perl_init_debugger(aTHX)
+#endif
+#define init_stacks() Perl_init_stacks(aTHX)
+#define init_tm(a) Perl_init_tm(aTHX_ a)
+#ifdef PERL_CORE
+#define intro_my() Perl_intro_my(aTHX)
+#endif
+#define instr(a,b) Perl_instr(aTHX_ a,b)
+#ifdef PERL_CORE
+#define io_close(a,b) Perl_io_close(aTHX_ a,b)
+#define invert(a) Perl_invert(aTHX_ a)
+#define is_gv_magical(a,b,c) Perl_is_gv_magical(aTHX_ a,b,c)
+#endif
+#define is_lvalue_sub() Perl_is_lvalue_sub(aTHX)
+#define to_uni_upper_lc(a) Perl_to_uni_upper_lc(aTHX_ a)
+#define to_uni_title_lc(a) Perl_to_uni_title_lc(aTHX_ a)
+#define to_uni_lower_lc(a) Perl_to_uni_lower_lc(aTHX_ a)
+#define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a)
+#define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a)
+#define is_uni_idfirst(a) Perl_is_uni_idfirst(aTHX_ a)
+#define is_uni_alpha(a) Perl_is_uni_alpha(aTHX_ a)
+#define is_uni_ascii(a) Perl_is_uni_ascii(aTHX_ a)
+#define is_uni_space(a) Perl_is_uni_space(aTHX_ a)
+#define is_uni_cntrl(a) Perl_is_uni_cntrl(aTHX_ a)
+#define is_uni_graph(a) Perl_is_uni_graph(aTHX_ a)
+#define is_uni_digit(a) Perl_is_uni_digit(aTHX_ a)
+#define is_uni_upper(a) Perl_is_uni_upper(aTHX_ a)
+#define is_uni_lower(a) Perl_is_uni_lower(aTHX_ a)
+#define is_uni_print(a) Perl_is_uni_print(aTHX_ a)
+#define is_uni_punct(a) Perl_is_uni_punct(aTHX_ a)
+#define is_uni_xdigit(a) Perl_is_uni_xdigit(aTHX_ a)
+#define to_uni_upper(a,b,c) Perl_to_uni_upper(aTHX_ a,b,c)
+#define to_uni_title(a,b,c) Perl_to_uni_title(aTHX_ a,b,c)
+#define to_uni_lower(a,b,c) Perl_to_uni_lower(aTHX_ a,b,c)
+#define to_uni_fold(a,b,c) Perl_to_uni_fold(aTHX_ a,b,c)
+#define is_uni_alnum_lc(a) Perl_is_uni_alnum_lc(aTHX_ a)
+#define is_uni_alnumc_lc(a) Perl_is_uni_alnumc_lc(aTHX_ a)
+#define is_uni_idfirst_lc(a) Perl_is_uni_idfirst_lc(aTHX_ a)
+#define is_uni_alpha_lc(a) Perl_is_uni_alpha_lc(aTHX_ a)
+#define is_uni_ascii_lc(a) Perl_is_uni_ascii_lc(aTHX_ a)
+#define is_uni_space_lc(a) Perl_is_uni_space_lc(aTHX_ a)
+#define is_uni_cntrl_lc(a) Perl_is_uni_cntrl_lc(aTHX_ a)
+#define is_uni_graph_lc(a) Perl_is_uni_graph_lc(aTHX_ a)
+#define is_uni_digit_lc(a) Perl_is_uni_digit_lc(aTHX_ a)
+#define is_uni_upper_lc(a) Perl_is_uni_upper_lc(aTHX_ a)
+#define is_uni_lower_lc(a) Perl_is_uni_lower_lc(aTHX_ a)
+#define is_uni_print_lc(a) Perl_is_uni_print_lc(aTHX_ a)
+#define is_uni_punct_lc(a) Perl_is_uni_punct_lc(aTHX_ a)
+#define is_uni_xdigit_lc(a) Perl_is_uni_xdigit_lc(aTHX_ a)
+#define is_utf8_char(a) Perl_is_utf8_char(aTHX_ a)
+#define is_utf8_string(a,b) Perl_is_utf8_string(aTHX_ a,b)
+#define is_utf8_string_loclen(a,b,c,d) Perl_is_utf8_string_loclen(aTHX_ a,b,c,d)
+#define is_utf8_alnum(a) Perl_is_utf8_alnum(aTHX_ a)
+#define is_utf8_alnumc(a) Perl_is_utf8_alnumc(aTHX_ a)
+#define is_utf8_idfirst(a) Perl_is_utf8_idfirst(aTHX_ a)
+#define is_utf8_idcont(a) Perl_is_utf8_idcont(aTHX_ a)
+#define is_utf8_alpha(a) Perl_is_utf8_alpha(aTHX_ a)
+#define is_utf8_ascii(a) Perl_is_utf8_ascii(aTHX_ a)
+#define is_utf8_space(a) Perl_is_utf8_space(aTHX_ a)
+#define is_utf8_cntrl(a) Perl_is_utf8_cntrl(aTHX_ a)
+#define is_utf8_digit(a) Perl_is_utf8_digit(aTHX_ a)
+#define is_utf8_graph(a) Perl_is_utf8_graph(aTHX_ a)
+#define is_utf8_upper(a) Perl_is_utf8_upper(aTHX_ a)
+#define is_utf8_lower(a) Perl_is_utf8_lower(aTHX_ a)
+#define is_utf8_print(a) Perl_is_utf8_print(aTHX_ a)
+#define is_utf8_punct(a) Perl_is_utf8_punct(aTHX_ a)
+#define is_utf8_xdigit(a) Perl_is_utf8_xdigit(aTHX_ a)
+#define is_utf8_mark(a) Perl_is_utf8_mark(aTHX_ a)
+#ifdef PERL_CORE
+#define jmaybe(a) Perl_jmaybe(aTHX_ a)
+#define keyword(a,b,c) Perl_keyword(aTHX_ a,b,c)
+#endif
+#define leave_scope(a) Perl_leave_scope(aTHX_ a)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define lex_end() Perl_lex_end(aTHX)
+#endif
+#ifdef PERL_CORE
+#define lex_start(a,b,c) Perl_lex_start(aTHX_ a,b,c)
+#endif
+#define op_null(a) Perl_op_null(aTHX_ a)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define op_clear(a) Perl_op_clear(aTHX_ a)
+#endif
+#define op_refcnt_lock() Perl_op_refcnt_lock(aTHX)
+#define op_refcnt_unlock() Perl_op_refcnt_unlock(aTHX)
+#ifdef PERL_CORE
+#define linklist(a) Perl_linklist(aTHX_ a)
+#define list(a) Perl_list(aTHX_ a)
+#define listkids(a) Perl_listkids(aTHX_ a)
+#endif
+#define vload_module(a,b,c,d) Perl_vload_module(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#define localize(a,b) Perl_localize(aTHX_ a,b)
+#endif
+#define looks_like_number(a) Perl_looks_like_number(aTHX_ a)
+#define grok_bin(a,b,c,d) Perl_grok_bin(aTHX_ a,b,c,d)
+#define grok_hex(a,b,c,d) Perl_grok_hex(aTHX_ a,b,c,d)
+#define grok_number(a,b,c) Perl_grok_number(aTHX_ a,b,c)
+#define grok_numeric_radix(a,b) Perl_grok_numeric_radix(aTHX_ a,b)
+#define grok_oct(a,b,c,d) Perl_grok_oct(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#define magic_clearenv(a,b) Perl_magic_clearenv(aTHX_ a,b)
+#define magic_clear_all_env(a,b) Perl_magic_clear_all_env(aTHX_ a,b)
+#define magic_clearhint(a,b) Perl_magic_clearhint(aTHX_ a,b)
+#define magic_clearisa(a,b) Perl_magic_clearisa(aTHX_ a,b)
+#define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b)
+#define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b)
+#define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b)
+#define magic_freeregexp(a,b) Perl_magic_freeregexp(aTHX_ a,b)
+#define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b)
+#define magic_get(a,b) Perl_magic_get(aTHX_ a,b)
+#define magic_getarylen(a,b) Perl_magic_getarylen(aTHX_ a,b)
+#define magic_getdefelem(a,b) Perl_magic_getdefelem(aTHX_ a,b)
+#define magic_getnkeys(a,b) Perl_magic_getnkeys(aTHX_ a,b)
+#define magic_getpack(a,b) Perl_magic_getpack(aTHX_ a,b)
+#define magic_getpos(a,b) Perl_magic_getpos(aTHX_ a,b)
+#define magic_getsig(a,b) Perl_magic_getsig(aTHX_ a,b)
+#define magic_getsubstr(a,b) Perl_magic_getsubstr(aTHX_ a,b)
+#define magic_gettaint(a,b) Perl_magic_gettaint(aTHX_ a,b)
+#define magic_getuvar(a,b) Perl_magic_getuvar(aTHX_ a,b)
+#define magic_getvec(a,b) Perl_magic_getvec(aTHX_ a,b)
+#define magic_len(a,b) Perl_magic_len(aTHX_ a,b)
+#define magic_nextpack(a,b,c) Perl_magic_nextpack(aTHX_ a,b,c)
+#define magic_regdata_cnt(a,b) Perl_magic_regdata_cnt(aTHX_ a,b)
+#define magic_regdatum_get(a,b) Perl_magic_regdatum_get(aTHX_ a,b)
+#define magic_regdatum_set(a,b) Perl_magic_regdatum_set(aTHX_ a,b)
+#define magic_set(a,b) Perl_magic_set(aTHX_ a,b)
+#define magic_setamagic(a,b) Perl_magic_setamagic(aTHX_ a,b)
+#define magic_setarylen(a,b) Perl_magic_setarylen(aTHX_ a,b)
+#define magic_freearylen_p(a,b) Perl_magic_freearylen_p(aTHX_ a,b)
+#endif
+#ifndef NO_MATHOMS
+#ifdef PERL_CORE
+#define magic_setbm(a,b) Perl_magic_setbm(aTHX_ a,b)
+#define magic_setfm(a,b) Perl_magic_setfm(aTHX_ a,b)
+#endif
+#endif
+#ifdef PERL_CORE
+#define magic_setdbline(a,b) Perl_magic_setdbline(aTHX_ a,b)
+#define magic_setdefelem(a,b) Perl_magic_setdefelem(aTHX_ a,b)
+#define magic_setenv(a,b) Perl_magic_setenv(aTHX_ a,b)
+#define magic_sethint(a,b) Perl_magic_sethint(aTHX_ a,b)
+#define magic_setisa(a,b) Perl_magic_setisa(aTHX_ a,b)
+#endif
+#ifndef NO_MATHOMS
+#ifdef PERL_CORE
+#define magic_setglob(a,b) Perl_magic_setglob(aTHX_ a,b)
+#endif
+#endif
+#ifdef PERL_CORE
+#define magic_setmglob(a,b) Perl_magic_setmglob(aTHX_ a,b)
+#define magic_setnkeys(a,b) Perl_magic_setnkeys(aTHX_ a,b)
+#define magic_setpack(a,b) Perl_magic_setpack(aTHX_ a,b)
+#define magic_setpos(a,b) Perl_magic_setpos(aTHX_ a,b)
+#define magic_setregexp(a,b) Perl_magic_setregexp(aTHX_ a,b)
+#define magic_setsig(a,b) Perl_magic_setsig(aTHX_ a,b)
+#define magic_setsubstr(a,b) Perl_magic_setsubstr(aTHX_ a,b)
+#define magic_settaint(a,b) Perl_magic_settaint(aTHX_ a,b)
+#define magic_setuvar(a,b) Perl_magic_setuvar(aTHX_ a,b)
+#define magic_setvec(a,b) Perl_magic_setvec(aTHX_ a,b)
+#define magic_setutf8(a,b) Perl_magic_setutf8(aTHX_ a,b)
+#define magic_set_all_env(a,b) Perl_magic_set_all_env(aTHX_ a,b)
+#define magic_sizepack(a,b) Perl_magic_sizepack(aTHX_ a,b)
+#define magic_wipepack(a,b) Perl_magic_wipepack(aTHX_ a,b)
+#define magicname(a,b,c) Perl_magicname(aTHX_ a,b,c)
+#endif
+#define markstack_grow() Perl_markstack_grow(aTHX)
+#if defined(USE_LOCALE_COLLATE)
+#ifdef PERL_CORE
+#define magic_setcollxfrm(a,b) Perl_magic_setcollxfrm(aTHX_ a,b)
+#define mem_collxfrm(a,b,c) Perl_mem_collxfrm(aTHX_ a,b,c)
+#endif
+#endif
+#define vmess(a,b) Perl_vmess(aTHX_ a,b)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define qerror(a) Perl_qerror(aTHX_ a)
+#endif
+#define sortsv(a,b,c) Perl_sortsv(aTHX_ a,b,c)
+#define sortsv_flags(a,b,c,d) Perl_sortsv_flags(aTHX_ a,b,c,d)
+#define mg_clear(a) Perl_mg_clear(aTHX_ a)
+#define mg_copy(a,b,c,d) Perl_mg_copy(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#define mg_localize(a,b) Perl_mg_localize(aTHX_ a,b)
+#endif
+#define mg_find(a,b) Perl_mg_find(aTHX_ a,b)
+#define mg_free(a) Perl_mg_free(aTHX_ a)
+#define mg_get(a) Perl_mg_get(aTHX_ a)
+#define mg_length(a) Perl_mg_length(aTHX_ a)
+#define mg_magical(a) Perl_mg_magical(aTHX_ a)
+#define mg_set(a) Perl_mg_set(aTHX_ a)
+#define mg_size(a) Perl_mg_size(aTHX_ a)
+#define mini_mktime(a) Perl_mini_mktime(aTHX_ a)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define mod(a,b) Perl_mod(aTHX_ a,b)
+#endif
+#ifdef PERL_CORE
+#define mode_from_discipline(a) Perl_mode_from_discipline(aTHX_ a)
+#endif
+#define moreswitches(a) Perl_moreswitches(aTHX_ a)
+#ifdef PERL_CORE
+#define my(a) Perl_my(aTHX_ a)
+#endif
+#define my_atof(a) Perl_my_atof(aTHX_ a)
+#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
+#define my_bcopy Perl_my_bcopy
+#endif
+#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
+#define my_bzero Perl_my_bzero
+#endif
+#define my_exit(a) Perl_my_exit(aTHX_ a)
+#define my_failure_exit() Perl_my_failure_exit(aTHX)
+#define my_fflush_all() Perl_my_fflush_all(aTHX)
+#define my_fork Perl_my_fork
+#define atfork_lock Perl_atfork_lock
+#define atfork_unlock Perl_atfork_unlock
+#define my_lstat() Perl_my_lstat(aTHX)
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
+#define my_memcmp Perl_my_memcmp
+#endif
+#if !defined(HAS_MEMSET)
+#define my_memset Perl_my_memset
+#endif
+#define my_pclose(a) Perl_my_pclose(aTHX_ a)
+#define my_popen(a,b) Perl_my_popen(aTHX_ a,b)
+#define my_popen_list(a,b,c) Perl_my_popen_list(aTHX_ a,b,c)
+#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b)
+#define my_stat() Perl_my_stat(aTHX)
+#define my_strftime(a,b,c,d,e,f,g,h,i,j) Perl_my_strftime(aTHX_ a,b,c,d,e,f,g,h,i,j)
+#if defined(MYSWAP)
+#define my_swap(a) Perl_my_swap(aTHX_ a)
+#define my_htonl(a) Perl_my_htonl(aTHX_ a)
+#define my_ntohl(a) Perl_my_ntohl(aTHX_ a)
+#endif
+#ifdef PERL_CORE
+#define my_unexec() Perl_my_unexec(aTHX)
+#endif
+#define newANONLIST(a) Perl_newANONLIST(aTHX_ a)
+#define newANONHASH(a) Perl_newANONHASH(aTHX_ a)
+#define newANONSUB(a,b,c) Perl_newANONSUB(aTHX_ a,b,c)
+#define newASSIGNOP(a,b,c,d) Perl_newASSIGNOP(aTHX_ a,b,c,d)
+#define newCONDOP(a,b,c,d) Perl_newCONDOP(aTHX_ a,b,c,d)
+#define newCONSTSUB(a,b,c) Perl_newCONSTSUB(aTHX_ a,b,c)
+#ifdef PERL_MAD
+#define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c)
+#else
+#define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c)
+#endif
+#define newFOROP(a,b,c,d,e,f,g) Perl_newFOROP(aTHX_ a,b,c,d,e,f,g)
+#define newGIVENOP(a,b,c) Perl_newGIVENOP(aTHX_ a,b,c)
+#define newLOGOP(a,b,c,d) Perl_newLOGOP(aTHX_ a,b,c,d)
+#define newLOOPEX(a,b) Perl_newLOOPEX(aTHX_ a,b)
+#define newLOOPOP(a,b,c,d) Perl_newLOOPOP(aTHX_ a,b,c,d)
+#define newNULLLIST() Perl_newNULLLIST(aTHX)
+#define newOP(a,b) Perl_newOP(aTHX_ a,b)
+#define newPROG(a) Perl_newPROG(aTHX_ a)
+#define newRANGE(a,b,c) Perl_newRANGE(aTHX_ a,b,c)
+#define newSLICEOP(a,b,c) Perl_newSLICEOP(aTHX_ a,b,c)
+#define newSTATEOP(a,b,c) Perl_newSTATEOP(aTHX_ a,b,c)
+#define newSUB(a,b,c,d) Perl_newSUB(aTHX_ a,b,c,d)
+#define newXS_flags(a,b,c,d,e) Perl_newXS_flags(aTHX_ a,b,c,d,e)
+#define newXS(a,b,c) Perl_newXS(aTHX_ a,b,c)
+#define newAVREF(a) Perl_newAVREF(aTHX_ a)
+#define newBINOP(a,b,c,d) Perl_newBINOP(aTHX_ a,b,c,d)
+#define newCVREF(a,b) Perl_newCVREF(aTHX_ a,b)
+#define newGVOP(a,b,c) Perl_newGVOP(aTHX_ a,b,c)
+#define newGVgen(a) Perl_newGVgen(aTHX_ a)
+#define newGVREF(a,b) Perl_newGVREF(aTHX_ a,b)
+#define newHVREF(a) Perl_newHVREF(aTHX_ a)
+#define newHVhv(a) Perl_newHVhv(aTHX_ a)
+#define newIO() Perl_newIO(aTHX)
+#define newLISTOP(a,b,c,d) Perl_newLISTOP(aTHX_ a,b,c,d)
+#ifdef USE_ITHREADS
+#define newPADOP(a,b,c) Perl_newPADOP(aTHX_ a,b,c)
+#endif
+#define newPMOP(a,b) Perl_newPMOP(aTHX_ a,b)
+#define newPVOP(a,b,c) Perl_newPVOP(aTHX_ a,b,c)
+#define newRV(a) Perl_newRV(aTHX_ a)
+#define newRV_noinc(a) Perl_newRV_noinc(aTHX_ a)
+#define newSV(a) Perl_newSV(aTHX_ a)
+#define newSVREF(a) Perl_newSVREF(aTHX_ a)
+#define newSVOP(a,b,c) Perl_newSVOP(aTHX_ a,b,c)
+#define newSViv(a) Perl_newSViv(aTHX_ a)
+#define newSVuv(a) Perl_newSVuv(aTHX_ a)
+#define newSVnv(a) Perl_newSVnv(aTHX_ a)
+#define newSVpv(a,b) Perl_newSVpv(aTHX_ a,b)
+#define newSVpvn(a,b) Perl_newSVpvn(aTHX_ a,b)
+#define newSVpvn_flags(a,b,c) Perl_newSVpvn_flags(aTHX_ a,b,c)
+#define newSVhek(a) Perl_newSVhek(aTHX_ a)
+#define newSVpvn_share(a,b,c) Perl_newSVpvn_share(aTHX_ a,b,c)
+#define vnewSVpvf(a,b) Perl_vnewSVpvf(aTHX_ a,b)
+#define newSVrv(a,b) Perl_newSVrv(aTHX_ a,b)
+#define newSVsv(a) Perl_newSVsv(aTHX_ a)
+#define newSV_type(a) Perl_newSV_type(aTHX_ a)
+#define newUNOP(a,b,c) Perl_newUNOP(aTHX_ a,b,c)
+#define newWHENOP(a,b) Perl_newWHENOP(aTHX_ a,b)
+#define newWHILEOP(a,b,c,d,e,f,g,h) Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g,h)
+#define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b)
+#define scan_vstring(a,b,c) Perl_scan_vstring(aTHX_ a,b,c)
+#define scan_version(a,b,c) Perl_scan_version(aTHX_ a,b,c)
+#define new_version(a) Perl_new_version(aTHX_ a)
+#define upg_version(a,b) Perl_upg_version(aTHX_ a,b)
+#define vverify(a) Perl_vverify(aTHX_ a)
+#define vnumify(a) Perl_vnumify(aTHX_ a)
+#define vnormal(a) Perl_vnormal(aTHX_ a)
+#define vstringify(a) Perl_vstringify(aTHX_ a)
+#define vcmp(a,b) Perl_vcmp(aTHX_ a,b)
+#ifdef PERL_CORE
+#define nextargv(a) Perl_nextargv(aTHX_ a)
+#endif
+#define ninstr(a,b,c,d) Perl_ninstr(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#define oopsCV(a) Perl_oopsCV(aTHX_ a)
+#endif
+#define op_free(a) Perl_op_free(aTHX_ a)
+#ifdef PERL_MAD
+#ifdef PERL_CORE
+#define package(a) Perl_package(aTHX_ a)
+#endif
+#else
+#ifdef PERL_CORE
+#define package(a) Perl_package(aTHX_ a)
+#endif
+#endif
+#ifdef PERL_CORE
+#define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b)
+#define allocmy(a) Perl_allocmy(aTHX_ a)
+#define pad_findmy(a) Perl_pad_findmy(aTHX_ a)
+#endif
+#define find_rundefsvoffset() Perl_find_rundefsvoffset(aTHX)
+#ifdef PERL_CORE
+#define oopsAV(a) Perl_oopsAV(aTHX_ a)
+#define oopsHV(a) Perl_oopsHV(aTHX_ a)
+#define pad_leavemy() Perl_pad_leavemy(aTHX)
+#endif
+#define pad_sv(a) Perl_pad_sv(aTHX_ a)
+#ifdef PERL_CORE
+#define pad_free(a) Perl_pad_free(aTHX_ a)
+#define pad_reset() Perl_pad_reset(aTHX)
+#define pad_swipe(a,b) Perl_pad_swipe(aTHX_ a,b)
+#define peep(a) Perl_peep(aTHX_ a)
+#endif
+#if defined(USE_REENTRANT_API)
+#define reentrant_size() Perl_reentrant_size(aTHX)
+#define reentrant_init() Perl_reentrant_init(aTHX)
+#define reentrant_free() Perl_reentrant_free(aTHX)
+#endif
+#define call_atexit(a,b) Perl_call_atexit(aTHX_ a,b)
+#define call_argv(a,b,c) Perl_call_argv(aTHX_ a,b,c)
+#define call_method(a,b) Perl_call_method(aTHX_ a,b)
+#define call_pv(a,b) Perl_call_pv(aTHX_ a,b)
+#define call_sv(a,b) Perl_call_sv(aTHX_ a,b)
+#define despatch_signals() Perl_despatch_signals(aTHX)
+#define doref(a,b,c) Perl_doref(aTHX_ a,b,c)
+#define eval_pv(a,b) Perl_eval_pv(aTHX_ a,b)
+#define eval_sv(a,b) Perl_eval_sv(aTHX_ a,b)
+#define get_sv(a,b) Perl_get_sv(aTHX_ a,b)
+#define get_av(a,b) Perl_get_av(aTHX_ a,b)
+#define get_hv(a,b) Perl_get_hv(aTHX_ a,b)
+#define get_cv(a,b) Perl_get_cv(aTHX_ a,b)
+#define get_cvn_flags(a,b,c) Perl_get_cvn_flags(aTHX_ a,b,c)
+#define init_i18nl10n(a) Perl_init_i18nl10n(aTHX_ a)
+#define init_i18nl14n(a) Perl_init_i18nl14n(aTHX_ a)
+#define new_collate(a) Perl_new_collate(aTHX_ a)
+#define new_ctype(a) Perl_new_ctype(aTHX_ a)
+#define new_numeric(a) Perl_new_numeric(aTHX_ a)
+#define set_numeric_local() Perl_set_numeric_local(aTHX)
+#define set_numeric_radix() Perl_set_numeric_radix(aTHX)
+#define set_numeric_standard() Perl_set_numeric_standard(aTHX)
+#define require_pv(a) Perl_require_pv(aTHX_ a)
+#define pack_cat(a,b,c,d,e,f,g) Perl_pack_cat(aTHX_ a,b,c,d,e,f,g)
+#define packlist(a,b,c,d,e) Perl_packlist(aTHX_ a,b,c,d,e)
+#ifdef PERL_USES_PL_PIDSTATUS
+#ifdef PERL_CORE
+#define pidgone(a,b) Perl_pidgone(aTHX_ a,b)
+#endif
+#endif
+#define pmflag(a,b) Perl_pmflag(aTHX_ a,b)
+#ifdef PERL_CORE
+#define pmruntime(a,b,c) Perl_pmruntime(aTHX_ a,b,c)
+#define pmtrans(a,b,c) Perl_pmtrans(aTHX_ a,b,c)
+#endif
+#define pop_scope() Perl_pop_scope(aTHX)
+#ifdef PERL_CORE
+#define prepend_elem(a,b,c) Perl_prepend_elem(aTHX_ a,b,c)
+#endif
+#define push_scope() Perl_push_scope(aTHX)
+#ifdef PERL_CORE
+#define refkids(a,b) Perl_refkids(aTHX_ a,b)
+#endif
+#define regdump(a) Perl_regdump(aTHX_ a)
+#define regdump(a) Perl_regdump(aTHX_ a)
+#define regclass_swash(a,b,c,d,e) Perl_regclass_swash(aTHX_ a,b,c,d,e)
+#define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g)
+#define pregfree(a) Perl_pregfree(aTHX_ a)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_temp_copy(a) Perl_reg_temp_copy(aTHX_ a)
+#endif
+#define regfree_internal(a) Perl_regfree_internal(aTHX_ a)
+#define reg_stringify(a,b,c,d) Perl_reg_stringify(aTHX_ a,b,c,d)
+#if defined(USE_ITHREADS)
+#define regdupe_internal(a,b) Perl_regdupe_internal(aTHX_ a,b)
+#endif
+#define pregcomp(a,b) Perl_pregcomp(aTHX_ a,b)
+#define re_compile(a,b) Perl_re_compile(aTHX_ a,b)
+#define re_intuit_start(a,b,c,d,e,f) Perl_re_intuit_start(aTHX_ a,b,c,d,e,f)
+#define re_intuit_string(a) Perl_re_intuit_string(aTHX_ a)
+#define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
+#define regnext(a) Perl_regnext(aTHX_ a)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_named_buff(a,b,c,d) Perl_reg_named_buff(aTHX_ a,b,c,d)
+#define reg_named_buff_iter(a,b,c) Perl_reg_named_buff_iter(aTHX_ a,b,c)
+#endif
+#define reg_named_buff_fetch(a,b,c) Perl_reg_named_buff_fetch(aTHX_ a,b,c)
+#define reg_named_buff_exists(a,b,c) Perl_reg_named_buff_exists(aTHX_ a,b,c)
+#define reg_named_buff_firstkey(a,b) Perl_reg_named_buff_firstkey(aTHX_ a,b)
+#define reg_named_buff_nextkey(a,b) Perl_reg_named_buff_nextkey(aTHX_ a,b)
+#define reg_named_buff_scalar(a,b) Perl_reg_named_buff_scalar(aTHX_ a,b)
+#define reg_named_buff_all(a,b) Perl_reg_named_buff_all(aTHX_ a,b)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_numbered_buff_fetch(a,b,c) Perl_reg_numbered_buff_fetch(aTHX_ a,b,c)
+#define reg_numbered_buff_store(a,b,c) Perl_reg_numbered_buff_store(aTHX_ a,b,c)
+#define reg_numbered_buff_length(a,b,c) Perl_reg_numbered_buff_length(aTHX_ a,b,c)
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_qr_package(a) Perl_reg_qr_package(aTHX_ a)
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regprop(a,b,c) Perl_regprop(aTHX_ a,b,c)
+#endif
+#define repeatcpy(a,b,c,d) Perl_repeatcpy(aTHX_ a,b,c,d)
+#define rninstr(a,b,c,d) Perl_rninstr(aTHX_ a,b,c,d)
+#define rsignal(a,b) Perl_rsignal(aTHX_ a,b)
+#ifdef PERL_CORE
+#define rsignal_restore(a,b) Perl_rsignal_restore(aTHX_ a,b)
+#define rsignal_save(a,b,c) Perl_rsignal_save(aTHX_ a,b,c)
+#endif
+#define rsignal_state(a) Perl_rsignal_state(aTHX_ a)
+#ifdef PERL_CORE
+#define rxres_free(a) Perl_rxres_free(aTHX_ a)
+#define rxres_restore(a,b) Perl_rxres_restore(aTHX_ a,b)
+#define rxres_save(a,b) Perl_rxres_save(aTHX_ a,b)
+#endif
+#if !defined(HAS_RENAME)
+#ifdef PERL_CORE
+#define same_dirent(a,b) Perl_same_dirent(aTHX_ a,b)
+#endif
+#endif
+#define savepv(a) Perl_savepv(aTHX_ a)
+#define savepvn(a,b) Perl_savepvn(aTHX_ a,b)
+#define savesharedpv(a) Perl_savesharedpv(aTHX_ a)
+#define savesharedpvn(a,b) Perl_savesharedpvn(aTHX_ a,b)
+#define savesvpv(a) Perl_savesvpv(aTHX_ a)
+#define savestack_grow() Perl_savestack_grow(aTHX)
+#define savestack_grow_cnt(a) Perl_savestack_grow_cnt(aTHX_ a)
+#define save_aelem(a,b,c) Perl_save_aelem(aTHX_ a,b,c)
+#define save_alloc(a,b) Perl_save_alloc(aTHX_ a,b)
+#define save_aptr(a) Perl_save_aptr(aTHX_ a)
+#define save_ary(a) Perl_save_ary(aTHX_ a)
+#define save_bool(a) Perl_save_bool(aTHX_ a)
+#define save_clearsv(a) Perl_save_clearsv(aTHX_ a)
+#define save_delete(a,b,c) Perl_save_delete(aTHX_ a,b,c)
+#define save_destructor(a,b) Perl_save_destructor(aTHX_ a,b)
+#define save_destructor_x(a,b) Perl_save_destructor_x(aTHX_ a,b)
+#ifdef PERL_CORE
+#endif
+#define save_generic_svref(a) Perl_save_generic_svref(aTHX_ a)
+#define save_generic_pvref(a) Perl_save_generic_pvref(aTHX_ a)
+#define save_shared_pvref(a) Perl_save_shared_pvref(aTHX_ a)
+#define save_gp(a,b) Perl_save_gp(aTHX_ a,b)
+#define save_hash(a) Perl_save_hash(aTHX_ a)
+#ifdef PERL_CORE
+#define save_hints() Perl_save_hints(aTHX)
+#endif
+#define save_helem(a,b,c) Perl_save_helem(aTHX_ a,b,c)
+#define save_hptr(a) Perl_save_hptr(aTHX_ a)
+#define save_I16(a) Perl_save_I16(aTHX_ a)
+#define save_I32(a) Perl_save_I32(aTHX_ a)
+#define save_I8(a) Perl_save_I8(aTHX_ a)
+#define save_int(a) Perl_save_int(aTHX_ a)
+#define save_item(a) Perl_save_item(aTHX_ a)
+#define save_iv(a) Perl_save_iv(aTHX_ a)
+#define save_list(a,b) Perl_save_list(aTHX_ a,b)
+#define save_long(a) Perl_save_long(aTHX_ a)
+#define save_nogv(a) Perl_save_nogv(aTHX_ a)
+#ifdef PERL_CORE
+#endif
+#define save_scalar(a) Perl_save_scalar(aTHX_ a)
+#define save_pptr(a) Perl_save_pptr(aTHX_ a)
+#define save_vptr(a) Perl_save_vptr(aTHX_ a)
+#define save_re_context() Perl_save_re_context(aTHX)
+#define save_padsv(a) Perl_save_padsv(aTHX_ a)
+#define save_padsv_and_mortalize(a) Perl_save_padsv_and_mortalize(aTHX_ a)
+#define save_sptr(a) Perl_save_sptr(aTHX_ a)
+#define save_svref(a) Perl_save_svref(aTHX_ a)
+#define save_pushptr(a,b) Perl_save_pushptr(aTHX_ a,b)
+#ifdef PERL_CORE
+#define save_pushi32ptr(a,b,c) Perl_save_pushi32ptr(aTHX_ a,b,c)
+#define save_pushptrptr(a,b,c) Perl_save_pushptrptr(aTHX_ a,b,c)
+#endif
+#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define save_pushptri32ptr(a,b,c,d) S_save_pushptri32ptr(aTHX_ a,b,c,d)
+#endif
+#endif
+#ifdef PERL_CORE
+#define sawparens(a) Perl_sawparens(aTHX_ a)
+#define scalar(a) Perl_scalar(aTHX_ a)
+#define scalarkids(a) Perl_scalarkids(aTHX_ a)
+#define scalarseq(a) Perl_scalarseq(aTHX_ a)
+#define scalarvoid(a) Perl_scalarvoid(aTHX_ a)
+#endif
+#define scan_bin(a,b,c) Perl_scan_bin(aTHX_ a,b,c)
+#define scan_hex(a,b,c) Perl_scan_hex(aTHX_ a,b,c)
+#define scan_num(a,b) Perl_scan_num(aTHX_ a,b)
+#define scan_oct(a,b,c) Perl_scan_oct(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define scope(a) Perl_scope(aTHX_ a)
+#endif
+#define screaminstr(a,b,c,d,e,f) Perl_screaminstr(aTHX_ a,b,c,d,e,f)
+#if !defined(VMS)
+#ifdef PERL_CORE
+#define setenv_getix(a) Perl_setenv_getix(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define setdefout(a) Perl_setdefout(aTHX_ a)
+#endif
+#define share_hek(a,b,c) Perl_share_hek(aTHX_ a,b,c)
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+#ifdef PERL_CORE
+#define sighandler Perl_sighandler
+#endif
+#define csighandler Perl_csighandler
+#else
+#ifdef PERL_CORE
+#define sighandler Perl_sighandler
+#endif
+#define csighandler Perl_csighandler
+#endif
+#define stack_grow(a,b,c) Perl_stack_grow(aTHX_ a,b,c)
+#define start_subparse(a,b) Perl_start_subparse(aTHX_ a,b)
+#ifdef PERL_CORE
+#define sub_crush_depth(a) Perl_sub_crush_depth(aTHX_ a)
+#endif
+#define sv_2bool(a) Perl_sv_2bool(aTHX_ a)
+#define sv_2cv(a,b,c,d) Perl_sv_2cv(aTHX_ a,b,c,d)
+#define sv_2io(a) Perl_sv_2io(aTHX_ a)
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define glob_2number(a) S_glob_2number(aTHX_ a)
+#define glob_2pv(a,b) S_glob_2pv(aTHX_ a,b)
+#endif
+#endif
+#define sv_2iv_flags(a,b) Perl_sv_2iv_flags(aTHX_ a,b)
+#define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a)
+#define sv_2nv(a) Perl_sv_2nv(aTHX_ a)
+#ifdef PERL_CORE
+#define sv_2num(a) Perl_sv_2num(aTHX_ a)
+#endif
+#define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c)
+#define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b)
+#define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b)
+#define sv_pvn_nomg(a,b) Perl_sv_pvn_nomg(aTHX_ a,b)
+#define sv_2uv_flags(a,b) Perl_sv_2uv_flags(aTHX_ a,b)
+#define sv_iv(a) Perl_sv_iv(aTHX_ a)
+#define sv_uv(a) Perl_sv_uv(aTHX_ a)
+#define sv_nv(a) Perl_sv_nv(aTHX_ a)
+#define sv_pvn(a,b) Perl_sv_pvn(aTHX_ a,b)
+#define sv_pvutf8n(a,b) Perl_sv_pvutf8n(aTHX_ a,b)
+#define sv_pvbyten(a,b) Perl_sv_pvbyten(aTHX_ a,b)
+#define sv_true(a) Perl_sv_true(aTHX_ a)
+#ifdef PERL_CORE
+#define sv_add_arena(a,b,c) Perl_sv_add_arena(aTHX_ a,b,c)
+#endif
+#define sv_backoff(a) Perl_sv_backoff(aTHX_ a)
+#define sv_bless(a,b) Perl_sv_bless(aTHX_ a,b)
+#define sv_vcatpvf(a,b,c) Perl_sv_vcatpvf(aTHX_ a,b,c)
+#define sv_catpv(a,b) Perl_sv_catpv(aTHX_ a,b)
+#define sv_chop(a,b) Perl_sv_chop(aTHX_ a,b)
+#ifdef PERL_CORE
+#define sv_clean_all() Perl_sv_clean_all(aTHX)
+#define sv_clean_objs() Perl_sv_clean_objs(aTHX)
+#endif
+#define sv_clear(a) Perl_sv_clear(aTHX_ a)
+#define sv_cmp(a,b) Perl_sv_cmp(aTHX_ a,b)
+#define sv_cmp_locale(a,b) Perl_sv_cmp_locale(aTHX_ a,b)
+#if defined(USE_LOCALE_COLLATE)
+#define sv_collxfrm(a,b) Perl_sv_collxfrm(aTHX_ a,b)
+#endif
+#define sv_compile_2op(a,b,c,d) Perl_sv_compile_2op(aTHX_ a,b,c,d)
+#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
+#define sv_dec(a) Perl_sv_dec(aTHX_ a)
+#define sv_dump(a) Perl_sv_dump(aTHX_ a)
+#define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b)
+#define sv_does(a,b) Perl_sv_does(aTHX_ a,b)
+#define sv_eq(a,b) Perl_sv_eq(aTHX_ a,b)
+#define sv_free(a) Perl_sv_free(aTHX_ a)
+#ifdef PERL_CORE
+#define sv_free_arenas() Perl_sv_free_arenas(aTHX)
+#endif
+#define sv_gets(a,b,c) Perl_sv_gets(aTHX_ a,b,c)
+#define sv_grow(a,b) Perl_sv_grow(aTHX_ a,b)
+#define sv_inc(a) Perl_sv_inc(aTHX_ a)
+#define sv_insert_flags(a,b,c,d,e,f) Perl_sv_insert_flags(aTHX_ a,b,c,d,e,f)
+#define sv_isa(a,b) Perl_sv_isa(aTHX_ a,b)
+#define sv_isobject(a) Perl_sv_isobject(aTHX_ a)
+#define sv_len(a) Perl_sv_len(aTHX_ a)
+#define sv_len_utf8(a) Perl_sv_len_utf8(aTHX_ a)
+#define sv_magic(a,b,c,d,e) Perl_sv_magic(aTHX_ a,b,c,d,e)
+#define sv_magicext(a,b,c,d,e,f) Perl_sv_magicext(aTHX_ a,b,c,d,e,f)
+#define sv_mortalcopy(a) Perl_sv_mortalcopy(aTHX_ a)
+#define sv_newmortal() Perl_sv_newmortal(aTHX)
+#define sv_newref(a) Perl_sv_newref(aTHX_ a)
+#define sv_peek(a) Perl_sv_peek(aTHX_ a)
+#define sv_pos_u2b(a,b,c) Perl_sv_pos_u2b(aTHX_ a,b,c)
+#define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b)
+#define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b)
+#define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b)
+#define sv_recode_to_utf8(a,b) Perl_sv_recode_to_utf8(aTHX_ a,b)
+#define sv_cat_decode(a,b,c,d,e,f) Perl_sv_cat_decode(aTHX_ a,b,c,d,e,f)
+#define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b)
+#define sv_replace(a,b) Perl_sv_replace(aTHX_ a,b)
+#define sv_report_used() Perl_sv_report_used(aTHX)
+#define sv_reset(a,b) Perl_sv_reset(aTHX_ a,b)
+#define sv_vsetpvf(a,b,c) Perl_sv_vsetpvf(aTHX_ a,b,c)
+#define sv_setiv(a,b) Perl_sv_setiv(aTHX_ a,b)
+#define sv_setpviv(a,b) Perl_sv_setpviv(aTHX_ a,b)
+#define sv_setuv(a,b) Perl_sv_setuv(aTHX_ a,b)
+#define sv_setnv(a,b) Perl_sv_setnv(aTHX_ a,b)
+#define sv_setref_iv(a,b,c) Perl_sv_setref_iv(aTHX_ a,b,c)
+#define sv_setref_uv(a,b,c) Perl_sv_setref_uv(aTHX_ a,b,c)
+#define sv_setref_nv(a,b,c) Perl_sv_setref_nv(aTHX_ a,b,c)
+#define sv_setref_pv(a,b,c) Perl_sv_setref_pv(aTHX_ a,b,c)
+#define sv_setref_pvn(a,b,c,d) Perl_sv_setref_pvn(aTHX_ a,b,c,d)
+#define sv_setpv(a,b) Perl_sv_setpv(aTHX_ a,b)
+#define sv_setpvn(a,b,c) Perl_sv_setpvn(aTHX_ a,b,c)
+#define sv_tainted(a) Perl_sv_tainted(aTHX_ a)
+#define sv_unmagic(a,b) Perl_sv_unmagic(aTHX_ a,b)
+#define sv_unref_flags(a,b) Perl_sv_unref_flags(aTHX_ a,b)
+#define sv_untaint(a) Perl_sv_untaint(aTHX_ a)
+#define sv_upgrade(a,b) Perl_sv_upgrade(aTHX_ a,b)
+#define sv_usepvn_flags(a,b,c,d) Perl_sv_usepvn_flags(aTHX_ a,b,c,d)
+#define sv_vcatpvfn(a,b,c,d,e,f,g) Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g)
+#define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
+#define str_to_version(a) Perl_str_to_version(aTHX_ a)
+#define swash_init(a,b,c,d,e) Perl_swash_init(aTHX_ a,b,c,d,e)
+#define swash_fetch(a,b,c) Perl_swash_fetch(aTHX_ a,b,c)
+#define taint_env() Perl_taint_env(aTHX)
+#define taint_proper(a,b) Perl_taint_proper(aTHX_ a,b)
+#define to_utf8_case(a,b,c,d,e,f) Perl_to_utf8_case(aTHX_ a,b,c,d,e,f)
+#define to_utf8_lower(a,b,c) Perl_to_utf8_lower(aTHX_ a,b,c)
+#define to_utf8_upper(a,b,c) Perl_to_utf8_upper(aTHX_ a,b,c)
+#define to_utf8_title(a,b,c) Perl_to_utf8_title(aTHX_ a,b,c)
+#define to_utf8_fold(a,b,c) Perl_to_utf8_fold(aTHX_ a,b,c)
+#if defined(UNLINK_ALL_VERSIONS)
+#define unlnk(a) Perl_unlnk(aTHX_ a)
+#endif
+#define unpack_str(a,b,c,d,e,f,g,h) Perl_unpack_str(aTHX_ a,b,c,d,e,f,g,h)
+#define unpackstring(a,b,c,d,e) Perl_unpackstring(aTHX_ a,b,c,d,e)
+#define unsharepvn(a,b,c) Perl_unsharepvn(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define unshare_hek(a) Perl_unshare_hek(aTHX_ a)
+#endif
+#ifdef PERL_MAD
+#ifdef PERL_CORE
+#define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e)
+#endif
+#else
+#ifdef PERL_CORE
+#define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e)
+#endif
+#endif
+#define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d)
+#define utf16_to_utf8_reversed(a,b,c,d) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d)
+#define utf8_length(a,b) Perl_utf8_length(aTHX_ a,b)
+#define utf8_distance(a,b) Perl_utf8_distance(aTHX_ a,b)
+#define utf8_hop(a,b) Perl_utf8_hop(aTHX_ a,b)
+#define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b)
+#define bytes_from_utf8(a,b,c) Perl_bytes_from_utf8(aTHX_ a,b,c)
+#define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b)
+#define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
+#define utf8_to_uvuni(a,b) Perl_utf8_to_uvuni(aTHX_ a,b)
+#ifdef EBCDIC
+#define utf8n_to_uvchr(a,b,c,d) Perl_utf8n_to_uvchr(aTHX_ a,b,c,d)
+#else
+#endif
+#define utf8n_to_uvuni(a,b,c,d) Perl_utf8n_to_uvuni(aTHX_ a,b,c,d)
+#ifdef EBCDIC
+#define uvchr_to_utf8(a,b) Perl_uvchr_to_utf8(aTHX_ a,b)
+#else
+#endif
+#define uvchr_to_utf8_flags(a,b,c) Perl_uvchr_to_utf8_flags(aTHX_ a,b,c)
+#define uvuni_to_utf8_flags(a,b,c) Perl_uvuni_to_utf8_flags(aTHX_ a,b,c)
+#define pv_uni_display(a,b,c,d,e) Perl_pv_uni_display(aTHX_ a,b,c,d,e)
+#define sv_uni_display(a,b,c,d) Perl_sv_uni_display(aTHX_ a,b,c,d)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a)
+#endif
+#ifdef PERL_CORE
+#define vivify_ref(a,b) Perl_vivify_ref(aTHX_ a,b)
+#define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c)
+#define parse_unicode_opts(a) Perl_parse_unicode_opts(aTHX_ a)
+#endif
+#define seed() Perl_seed(aTHX)
+#ifdef PERL_CORE
+#define get_hash_seed() Perl_get_hash_seed(aTHX)
+#define report_evil_fh(a,b,c) Perl_report_evil_fh(aTHX_ a,b,c)
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define report_uninit(a) Perl_report_uninit(aTHX_ a)
+#endif
+#define vwarn(a,b) Perl_vwarn(aTHX_ a,b)
+#define vwarner(a,b,c) Perl_vwarner(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define watch(a) Perl_watch(aTHX_ a)
+#endif
+#define whichsig(a) Perl_whichsig(aTHX_ a)
+#ifdef PERL_CORE
+#define write_to_stderr(a,b) Perl_write_to_stderr(aTHX_ a,b)
+#define yyerror(a) Perl_yyerror(aTHX_ a)
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define yylex() Perl_yylex(aTHX)
+#endif
+#ifdef PERL_CORE
+#define yyparse() Perl_yyparse(aTHX)
+#define parser_free(a) Perl_parser_free(aTHX_ a)
+#define yywarn(a) Perl_yywarn(aTHX_ a)
+#endif
+#if defined(MYMALLOC)
+#define dump_mstats(a) Perl_dump_mstats(aTHX_ a)
+#define get_mstats(a,b,c) Perl_get_mstats(aTHX_ a,b,c)
+#endif
+#define safesysmalloc Perl_safesysmalloc
+#define safesyscalloc Perl_safesyscalloc
+#define safesysrealloc Perl_safesysrealloc
+#define safesysfree Perl_safesysfree
+#if defined(PERL_GLOBAL_STRUCT)
+#define GetVars() Perl_GetVars(aTHX)
+#define init_global_struct() Perl_init_global_struct(aTHX)
+#define free_global_struct(a) Perl_free_global_struct(aTHX_ a)
+#endif
+#define runops_standard() Perl_runops_standard(aTHX)
+#define runops_debug() Perl_runops_debug(aTHX)
+#define sv_vcatpvf_mg(a,b,c) Perl_sv_vcatpvf_mg(aTHX_ a,b,c)
+#define sv_catpv_mg(a,b) Perl_sv_catpv_mg(aTHX_ a,b)
+#define sv_vsetpvf_mg(a,b,c) Perl_sv_vsetpvf_mg(aTHX_ a,b,c)
+#define sv_setiv_mg(a,b) Perl_sv_setiv_mg(aTHX_ a,b)
+#define sv_setpviv_mg(a,b) Perl_sv_setpviv_mg(aTHX_ a,b)
+#define sv_setuv_mg(a,b) Perl_sv_setuv_mg(aTHX_ a,b)
+#define sv_setnv_mg(a,b) Perl_sv_setnv_mg(aTHX_ a,b)
+#define sv_setpv_mg(a,b) Perl_sv_setpv_mg(aTHX_ a,b)
+#define sv_setpvn_mg(a,b,c) Perl_sv_setpvn_mg(aTHX_ a,b,c)
+#define sv_setsv_mg(a,b) Perl_sv_setsv_mg(aTHX_ a,b)
+#define get_vtbl(a) Perl_get_vtbl(aTHX_ a)
+#define pv_display(a,b,c,d,e) Perl_pv_display(aTHX_ a,b,c,d,e)
+#define pv_escape(a,b,c,d,e,f) Perl_pv_escape(aTHX_ a,b,c,d,e,f)
+#define pv_pretty(a,b,c,d,e,f,g) Perl_pv_pretty(aTHX_ a,b,c,d,e,f,g)
+#define dump_vindent(a,b,c,d) Perl_dump_vindent(aTHX_ a,b,c,d)
+#define do_gv_dump(a,b,c,d) Perl_do_gv_dump(aTHX_ a,b,c,d)
+#define do_gvgv_dump(a,b,c,d) Perl_do_gvgv_dump(aTHX_ a,b,c,d)
+#define do_hv_dump(a,b,c,d) Perl_do_hv_dump(aTHX_ a,b,c,d)
+#define do_magic_dump(a,b,c,d,e,f,g) Perl_do_magic_dump(aTHX_ a,b,c,d,e,f,g)
+#define do_op_dump(a,b,c) Perl_do_op_dump(aTHX_ a,b,c)
+#define do_pmop_dump(a,b,c) Perl_do_pmop_dump(aTHX_ a,b,c)
+#define do_sv_dump(a,b,c,d,e,f,g) Perl_do_sv_dump(aTHX_ a,b,c,d,e,f,g)
+#define magic_dump(a) Perl_magic_dump(aTHX_ a)
+#define reginitcolors() Perl_reginitcolors(aTHX)
+#define sv_utf8_downgrade(a,b) Perl_sv_utf8_downgrade(aTHX_ a,b)
+#define sv_utf8_encode(a) Perl_sv_utf8_encode(aTHX_ a)
+#define sv_utf8_decode(a) Perl_sv_utf8_decode(aTHX_ a)
+#define sv_force_normal_flags(a,b) Perl_sv_force_normal_flags(aTHX_ a,b)
+#define tmps_grow(a) Perl_tmps_grow(aTHX_ a)
+#define sv_rvweaken(a) Perl_sv_rvweaken(aTHX_ a)
+#ifdef PERL_CORE
+#define magic_killbackrefs(a,b) Perl_magic_killbackrefs(aTHX_ a,b)
+#endif
+#define newANONATTRSUB(a,b,c,d) Perl_newANONATTRSUB(aTHX_ a,b,c,d)
+#define newATTRSUB(a,b,c,d,e) Perl_newATTRSUB(aTHX_ a,b,c,d,e)
+#ifdef PERL_MAD
+#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
+#else
+#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
+#endif
+#ifdef PERL_CORE
+#define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b)
+#define boot_core_xsutils() Perl_boot_core_xsutils(aTHX)
+#endif
+#if defined(USE_ITHREADS)
+#define cx_dup(a,b,c,d) Perl_cx_dup(aTHX_ a,b,c,d)
+#define si_dup(a,b) Perl_si_dup(aTHX_ a,b)
+#define ss_dup(a,b) Perl_ss_dup(aTHX_ a,b)
+#define any_dup(a,b) Perl_any_dup(aTHX_ a,b)
+#define he_dup(a,b,c) Perl_he_dup(aTHX_ a,b,c)
+#define hek_dup(a,b) Perl_hek_dup(aTHX_ a,b)
+#define re_dup(a,b) Perl_re_dup(aTHX_ a,b)
+#define fp_dup(a,b,c) Perl_fp_dup(aTHX_ a,b,c)
+#define dirp_dup(a) Perl_dirp_dup(aTHX_ a)
+#define gp_dup(a,b) Perl_gp_dup(aTHX_ a,b)
+#define mg_dup(a,b) Perl_mg_dup(aTHX_ a,b)
+#define sv_dup(a,b) Perl_sv_dup(aTHX_ a,b)
+#define rvpv_dup(a,b,c) Perl_rvpv_dup(aTHX_ a,b,c)
+#define parser_dup(a,b) Perl_parser_dup(aTHX_ a,b)
+#endif
+#define ptr_table_new() Perl_ptr_table_new(aTHX)
+#define ptr_table_fetch(a,b) Perl_ptr_table_fetch(aTHX_ a,b)
+#define ptr_table_store(a,b,c) Perl_ptr_table_store(aTHX_ a,b,c)
+#define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a)
+#define ptr_table_clear(a) Perl_ptr_table_clear(aTHX_ a)
+#define ptr_table_free(a) Perl_ptr_table_free(aTHX_ a)
+#if defined(USE_ITHREADS)
+# if defined(HAVE_INTERP_INTERN)
+#define sys_intern_dup(a,b) Perl_sys_intern_dup(aTHX_ a,b)
+# endif
+#endif
+#if defined(HAVE_INTERP_INTERN)
+#define sys_intern_clear() Perl_sys_intern_clear(aTHX)
+#define sys_intern_init() Perl_sys_intern_init(aTHX)
+#endif
+#define custom_op_name(a) Perl_custom_op_name(aTHX_ a)
+#define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a)
+#define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a)
+#define sv_destroyable(a) Perl_sv_destroyable(aTHX_ a)
+#ifdef NO_MATHOMS
+#else
+#define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a)
+#endif
+#define nothreadhook() Perl_nothreadhook(aTHX)
+#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define do_trans_simple(a) S_do_trans_simple(aTHX_ a)
+#define do_trans_count(a) S_do_trans_count(aTHX_ a)
+#define do_trans_complex(a) S_do_trans_complex(aTHX_ a)
+#define do_trans_simple_utf8(a) S_do_trans_simple_utf8(aTHX_ a)
+#define do_trans_count_utf8(a) S_do_trans_count_utf8(aTHX_ a)
+#define do_trans_complex_utf8(a) S_do_trans_complex_utf8(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b)
+#define gv_get_super_pkg(a,b) S_gv_get_super_pkg(aTHX_ a,b)
+#define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e)
+#endif
+#endif
+#ifdef PERL_CORE
+#endif
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define hsplit(a) S_hsplit(aTHX_ a)
+#define hfreeentries(a) S_hfreeentries(aTHX_ a)
+#define new_he() S_new_he(aTHX)
+#define save_hek_flags S_save_hek_flags
+#define hv_magic_check S_hv_magic_check
+#define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d)
+#define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d)
+#define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d)
+#define hv_auxinit S_hv_auxinit
+#define hv_delete_common(a,b,c,d,e,f,g) S_hv_delete_common(aTHX_ a,b,c,d,e,f,g)
+#define clear_placeholders(a,b) S_clear_placeholders(aTHX_ a,b)
+#define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define save_magic(a,b) S_save_magic(aTHX_ a,b)
+#define magic_methpack(a,b,c) S_magic_methpack(aTHX_ a,b,c)
+#define magic_methcall(a,b,c,d,e,f) S_magic_methcall(aTHX_ a,b,c,d,e,f)
+#define restore_magic(a) S_restore_magic(aTHX_ a)
+#define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
+#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
+#define ck_concat(a) Perl_ck_concat(aTHX_ a)
+#define ck_defined(a) Perl_ck_defined(aTHX_ a)
+#define ck_delete(a) Perl_ck_delete(aTHX_ a)
+#define ck_die(a) Perl_ck_die(aTHX_ a)
+#define ck_eof(a) Perl_ck_eof(aTHX_ a)
+#define ck_eval(a) Perl_ck_eval(aTHX_ a)
+#define ck_exec(a) Perl_ck_exec(aTHX_ a)
+#define ck_exists(a) Perl_ck_exists(aTHX_ a)
+#define ck_exit(a) Perl_ck_exit(aTHX_ a)
+#define ck_ftst(a) Perl_ck_ftst(aTHX_ a)
+#define ck_fun(a) Perl_ck_fun(aTHX_ a)
+#define ck_glob(a) Perl_ck_glob(aTHX_ a)
+#define ck_grep(a) Perl_ck_grep(aTHX_ a)
+#define ck_index(a) Perl_ck_index(aTHX_ a)
+#define ck_join(a) Perl_ck_join(aTHX_ a)
+#define ck_lengthconst(a) Perl_ck_lengthconst(aTHX_ a)
+#define ck_lfun(a) Perl_ck_lfun(aTHX_ a)
+#define ck_listiob(a) Perl_ck_listiob(aTHX_ a)
+#define ck_match(a) Perl_ck_match(aTHX_ a)
+#define ck_method(a) Perl_ck_method(aTHX_ a)
+#define ck_null(a) Perl_ck_null(aTHX_ a)
+#define ck_open(a) Perl_ck_open(aTHX_ a)
+#define ck_readline(a) Perl_ck_readline(aTHX_ a)
+#define ck_repeat(a) Perl_ck_repeat(aTHX_ a)
+#define ck_require(a) Perl_ck_require(aTHX_ a)
+#define ck_return(a) Perl_ck_return(aTHX_ a)
+#define ck_rfun(a) Perl_ck_rfun(aTHX_ a)
+#define ck_rvconst(a) Perl_ck_rvconst(aTHX_ a)
+#define ck_sassign(a) Perl_ck_sassign(aTHX_ a)
+#define ck_select(a) Perl_ck_select(aTHX_ a)
+#define ck_shift(a) Perl_ck_shift(aTHX_ a)
+#define ck_sort(a) Perl_ck_sort(aTHX_ a)
+#define ck_spair(a) Perl_ck_spair(aTHX_ a)
+#define ck_split(a) Perl_ck_split(aTHX_ a)
+#define ck_subr(a) Perl_ck_subr(aTHX_ a)
+#define ck_substr(a) Perl_ck_substr(aTHX_ a)
+#define ck_svconst(a) Perl_ck_svconst(aTHX_ a)
+#define ck_trunc(a) Perl_ck_trunc(aTHX_ a)
+#define ck_unpack(a) Perl_ck_unpack(aTHX_ a)
+#define is_handle_constructor S_is_handle_constructor
+#define is_list_assignment(a) S_is_list_assignment(aTHX_ a)
+#endif
+# ifdef USE_ITHREADS
+#ifdef PERL_CORE
+#endif
+# else
+#ifdef PERL_CORE
+#endif
+# endif
+#ifdef PERL_CORE
+#define find_and_forget_pmops(a) S_find_and_forget_pmops(aTHX_ a)
+#define cop_free(a) S_cop_free(aTHX_ a)
+#define modkids(a,b) S_modkids(aTHX_ a,b)
+#define scalarboolean(a) S_scalarboolean(aTHX_ a)
+#define newDEFSVOP() S_newDEFSVOP(aTHX)
+#define search_const(a) S_search_const(aTHX_ a)
+#define new_logop(a,b,c,d) S_new_logop(aTHX_ a,b,c,d)
+#define simplify_sort(a) S_simplify_sort(aTHX_ a)
+#define gv_ename(a) S_gv_ename(aTHX_ a)
+#define scalar_mod_type S_scalar_mod_type
+#define my_kid(a,b,c) S_my_kid(aTHX_ a,b,c)
+#define dup_attrlist(a) S_dup_attrlist(aTHX_ a)
+#define apply_attrs(a,b,c,d) S_apply_attrs(aTHX_ a,b,c,d)
+#define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d)
+#define bad_type(a,b,c,d) S_bad_type(aTHX_ a,b,c,d)
+#define no_bareword_allowed(a) S_no_bareword_allowed(aTHX_ a)
+#define no_fh_allowed(a) S_no_fh_allowed(aTHX_ a)
+#define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
+#define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b)
+#define looks_like_bool(a) S_looks_like_bool(aTHX_ a)
+#define newGIVWHENOP(a,b,c,d,e) S_newGIVWHENOP(aTHX_ a,b,c,d,e)
+#define ref_array_or_hash(a) S_ref_array_or_hash(aTHX_ a)
+#define process_special_blocks(a,b,c) S_process_special_blocks(aTHX_ a,b,c)
+#endif
+#endif
+#if defined(PL_OP_SLAB_ALLOC)
+#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a)
+#define Slab_Free(a) Perl_Slab_Free(aTHX_ a)
+# if defined(PERL_DEBUG_READONLY_OPS)
+#ifdef PERL_CORE
+#endif
+# if defined(PERL_IN_OP_C)
+#ifdef PERL_CORE
+#define Slab_to_rw(a) S_Slab_to_rw(aTHX_ a)
+#endif
+# endif
+# endif
+#endif
+#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define find_beginning(a,b) S_find_beginning(aTHX_ a,b)
+#define forbid_setid(a,b) S_forbid_setid(aTHX_ a,b)
+#define incpush(a,b,c,d,e) S_incpush(aTHX_ a,b,c,d,e)
+#define init_interp() S_init_interp(aTHX)
+#define init_ids() S_init_ids(aTHX)
+#define init_main_stash() S_init_main_stash(aTHX)
+#define init_perllib() S_init_perllib(aTHX)
+#define init_postdump_symbols(a,b,c) S_init_postdump_symbols(aTHX_ a,b,c)
+#define init_predump_symbols() S_init_predump_symbols(aTHX)
+#define my_exit_jump() S_my_exit_jump(aTHX)
+#define nuke_stacks() S_nuke_stacks(aTHX)
+#define open_script(a,b,c,d,e) S_open_script(aTHX_ a,b,c,d,e)
+#define usage(a) S_usage(aTHX_ a)
+#endif
+#ifdef DOSUID
+# ifdef IAMSUID
+#ifdef PERL_CORE
+#endif
+# else
+#ifdef PERL_CORE
+#endif
+# endif
+#else
+# ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef PERL_CORE
+#endif
+# endif
+#endif
+# if defined(IAMSUID)
+#ifdef PERL_CORE
+#define fd_on_nosuid_fs(a) S_fd_on_nosuid_fs(aTHX_ a)
+#endif
+# endif
+#ifdef PERL_CORE
+#define parse_body(a,b) S_parse_body(aTHX_ a,b)
+#define run_body(a) S_run_body(aTHX_ a)
+#define incpush_if_exists(a) S_incpush_if_exists(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define refto(a) S_refto(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#endif
+#endif
+#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define unpack_rec(a,b,c,d,e) S_unpack_rec(aTHX_ a,b,c,d,e)
+#define pack_rec(a,b,c,d) S_pack_rec(aTHX_ a,b,c,d)
+#define mul128(a,b) S_mul128(aTHX_ a,b)
+#define measure_struct(a) S_measure_struct(aTHX_ a)
+#define next_symbol(a) S_next_symbol(aTHX_ a)
+#define is_an_int(a,b) S_is_an_int(aTHX_ a,b)
+#define div128(a,b) S_div128(aTHX_ a,b)
+#define group_end(a,b,c) S_group_end(aTHX_ a,b,c)
+#define get_num(a,b) S_get_num(aTHX_ a,b)
+#define need_utf8 S_need_utf8
+#define first_symbol S_first_symbol
+#define sv_exp_grow(a,b) S_sv_exp_grow(aTHX_ a,b)
+#define bytes_to_uni S_bytes_to_uni
+#endif
+#endif
+#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define docatch(a) S_docatch(aTHX_ a)
+#define dofindlabel(a,b,c,d) S_dofindlabel(aTHX_ a,b,c,d)
+#define doparseform(a) S_doparseform(aTHX_ a)
+#define num_overflow S_num_overflow
+#define dopoptoeval(a) S_dopoptoeval(aTHX_ a)
+#define dopoptogiven(a) S_dopoptogiven(aTHX_ a)
+#define dopoptolabel(a) S_dopoptolabel(aTHX_ a)
+#define dopoptoloop(a) S_dopoptoloop(aTHX_ a)
+#define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b)
+#define dopoptowhen(a) S_dopoptowhen(aTHX_ a)
+#define save_lines(a,b) S_save_lines(aTHX_ a,b)
+#define doeval(a,b,c,d) S_doeval(aTHX_ a,b,c,d)
+#define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
+#endif
+#ifndef PERL_DISABLE_PMC
+#ifdef PERL_CORE
+#define doopen_pm(a,b) S_doopen_pm(aTHX_ a,b)
+#endif
+#endif
+#ifdef PERL_CORE
+#define path_is_absolute S_path_is_absolute
+#define run_user_filter(a,b,c) S_run_user_filter(aTHX_ a,b,c)
+#define make_matcher(a) S_make_matcher(aTHX_ a)
+#define matcher_matches_sv(a,b) S_matcher_matches_sv(aTHX_ a,b)
+#define destroy_matcher(a) S_destroy_matcher(aTHX_ a)
+#define do_smartmatch(a,b) S_do_smartmatch(aTHX_ a,b)
+#endif
+#endif
+#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define do_oddball(a,b,c) S_do_oddball(aTHX_ a,b,c)
+#define method_common(a,b) S_method_common(aTHX_ a,b)
+#endif
+#endif
+#if defined(PERL_IN_PP_SORT_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define sv_ncmp(a,b) S_sv_ncmp(aTHX_ a,b)
+#define sv_i_ncmp(a,b) S_sv_i_ncmp(aTHX_ a,b)
+#define amagic_ncmp(a,b) S_amagic_ncmp(aTHX_ a,b)
+#define amagic_i_ncmp(a,b) S_amagic_i_ncmp(aTHX_ a,b)
+#define amagic_cmp(a,b) S_amagic_cmp(aTHX_ a,b)
+#define amagic_cmp_locale(a,b) S_amagic_cmp_locale(aTHX_ a,b)
+#define sortcv(a,b) S_sortcv(aTHX_ a,b)
+#define sortcv_xsub(a,b) S_sortcv_xsub(aTHX_ a,b)
+#define sortcv_stacked(a,b) S_sortcv_stacked(aTHX_ a,b)
+#define qsortsvu(a,b,c) S_qsortsvu(aTHX_ a,b,c)
+#endif
+#endif
+#if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define doform(a,b,c) S_doform(aTHX_ a,b,c)
+#endif
+# if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
+#ifdef PERL_CORE
+#define dooneliner(a,b) S_dooneliner(aTHX_ a,b)
+#endif
+# endif
+#ifdef PERL_CORE
+#define space_join_names_mortal(a) S_space_join_names_mortal(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg(a,b,c,d) S_reg(aTHX_ a,b,c,d)
+#define reganode(a,b,c) S_reganode(aTHX_ a,b,c)
+#define regatom(a,b,c) S_regatom(aTHX_ a,b,c)
+#define regbranch(a,b,c,d) S_regbranch(aTHX_ a,b,c,d)
+#define reguni(a,b,c) S_reguni(aTHX_ a,b,c)
+#define regclass(a,b) S_regclass(aTHX_ a,b)
+#define regcurly S_regcurly
+#define reg_node(a,b) S_reg_node(aTHX_ a,b)
+#define reg_recode(a,b) S_reg_recode(aTHX_ a,b)
+#define regpiece(a,b,c) S_regpiece(aTHX_ a,b,c)
+#define reg_namedseq(a,b) S_reg_namedseq(aTHX_ a,b)
+#define reginsert(a,b,c,d) S_reginsert(aTHX_ a,b,c,d)
+#define regtail(a,b,c,d) S_regtail(aTHX_ a,b,c,d)
+#define reg_scan_name(a,b) S_reg_scan_name(aTHX_ a,b)
+#define join_exact(a,b,c,d,e,f) S_join_exact(aTHX_ a,b,c,d,e,f)
+#define regwhite S_regwhite
+#define nextchar(a) S_nextchar(aTHX_ a)
+#define reg_skipcomment(a) S_reg_skipcomment(aTHX_ a)
+#define scan_commit(a,b,c,d) S_scan_commit(aTHX_ a,b,c,d)
+#define cl_anything S_cl_anything
+#define cl_is_anything S_cl_is_anything
+#define cl_init S_cl_init
+#define cl_init_zero S_cl_init_zero
+#define cl_and S_cl_and
+#define cl_or S_cl_or
+#define study_chunk(a,b,c,d,e,f,g,h,i,j,k) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k)
+#define add_data S_add_data
+#endif
+#ifdef PERL_CORE
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regpposixcc(a,b) S_regpposixcc(aTHX_ a,b)
+#define checkposixcc(a) S_checkposixcc(aTHX_ a)
+#define make_trie(a,b,c,d,e,f,g,h) S_make_trie(aTHX_ a,b,c,d,e,f,g,h)
+#define make_trie_failtable(a,b,c,d) S_make_trie_failtable(aTHX_ a,b,c,d)
+#endif
+# ifdef DEBUGGING
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regdump_extflags(a,b) S_regdump_extflags(aTHX_ a,b)
+#define dumpuntil(a,b,c,d,e,f,g,h) S_dumpuntil(aTHX_ a,b,c,d,e,f,g,h)
+#define put_byte(a,b) S_put_byte(aTHX_ a,b)
+#define dump_trie(a,b,c,d) S_dump_trie(aTHX_ a,b,c,d)
+#define dump_trie_interim_list(a,b,c,d,e) S_dump_trie_interim_list(aTHX_ a,b,c,d,e)
+#define dump_trie_interim_table(a,b,c,d,e) S_dump_trie_interim_table(aTHX_ a,b,c,d,e)
+#define regtail_study(a,b,c,d) S_regtail_study(aTHX_ a,b,c,d)
+#endif
+# endif
+#endif
+#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define regmatch(a,b) S_regmatch(aTHX_ a,b)
+#define regrepeat(a,b,c,d) S_regrepeat(aTHX_ a,b,c,d)
+#define regtry(a,b) S_regtry(aTHX_ a,b)
+#define reginclass(a,b,c,d,e) S_reginclass(aTHX_ a,b,c,d,e)
+#define regcppush(a) S_regcppush(aTHX_ a)
+#define regcppop(a) S_regcppop(aTHX_ a)
+#define reghop3 S_reghop3
+#endif
+#ifdef XXX_dmq
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reghop4 S_reghop4
+#endif
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reghopmaybe3 S_reghopmaybe3
+#define find_byclass(a,b,c,d,e) S_find_byclass(aTHX_ a,b,c,d,e)
+#define swap_match_buff(a) S_swap_match_buff(aTHX_ a)
+#define to_utf8_substr(a) S_to_utf8_substr(aTHX_ a)
+#define to_byte_substr(a) S_to_byte_substr(aTHX_ a)
+#define reg_check_named_buff_matched(a,b) S_reg_check_named_buff_matched(aTHX_ a,b)
+#endif
+# ifdef DEBUGGING
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define dump_exec_pos(a,b,c,d,e,f) S_dump_exec_pos(aTHX_ a,b,c,d,e,f)
+#define debug_start_match(a,b,c,d,e) S_debug_start_match(aTHX_ a,b,c,d,e)
+#endif
+# endif
+#endif
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define deb_curcv(a) S_deb_curcv(aTHX_ a)
+#define debprof(a) S_debprof(aTHX_ a)
+#define sequence(a) S_sequence(aTHX_ a)
+#define sequence_tail(a) S_sequence_tail(aTHX_ a)
+#define sequence_num(a) S_sequence_num(aTHX_ a)
+#define pm_description(a) S_pm_description(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define save_scalar_at(a) S_save_scalar_at(aTHX_ a)
+#endif
+#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#endif
+#endif
+#if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#endif
+#endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define uiv_2buf S_uiv_2buf
+#define sv_unglob(a) S_sv_unglob(aTHX_ a)
+#define not_a_number(a) S_not_a_number(aTHX_ a)
+#define visit(a,b,c) S_visit(aTHX_ a,b,c)
+#define sv_del_backref(a,b) S_sv_del_backref(aTHX_ a,b)
+#define varname(a,b,c,d,e,f) S_varname(aTHX_ a,b,c,d,e,f)
+#endif
+# ifdef DEBUGGING
+#ifdef PERL_CORE
+#define del_sv(a) S_del_sv(aTHX_ a)
+#endif
+# endif
+# if !defined(NV_PRESERVES_UV)
+# ifdef DEBUGGING
+#ifdef PERL_CORE
+#define sv_2iuv_non_preserve(a,b) S_sv_2iuv_non_preserve(aTHX_ a,b)
+#endif
+# else
+#ifdef PERL_CORE
+#define sv_2iuv_non_preserve(a) S_sv_2iuv_non_preserve(aTHX_ a)
+#endif
+# endif
+# endif
+#ifdef PERL_CORE
+#define expect_number(a) S_expect_number(aTHX_ a)
+#endif
+#ifdef PERL_CORE
+#define sv_pos_u2b_forwards S_sv_pos_u2b_forwards
+#define sv_pos_u2b_midway S_sv_pos_u2b_midway
+#define sv_pos_u2b_cached(a,b,c,d,e,f,g) S_sv_pos_u2b_cached(aTHX_ a,b,c,d,e,f,g)
+#define utf8_mg_pos_cache_update(a,b,c,d,e) S_utf8_mg_pos_cache_update(aTHX_ a,b,c,d,e)
+#define sv_pos_b2u_midway(a,b,c,d) S_sv_pos_b2u_midway(aTHX_ a,b,c,d)
+#define F0convert S_F0convert
+#endif
+# if defined(PERL_OLD_COPY_ON_WRITE)
+#ifdef PERL_CORE
+#define sv_release_COW(a,b,c) S_sv_release_COW(aTHX_ a,b,c)
+#endif
+# endif
+#ifdef PERL_CORE
+#define more_sv() S_more_sv(aTHX)
+#define more_bodies(a) S_more_bodies(aTHX_ a)
+#define sv_2iuv_common(a) S_sv_2iuv_common(aTHX_ a)
+#define glob_assign_glob(a,b,c) S_glob_assign_glob(aTHX_ a,b,c)
+#define glob_assign_ref(a,b) S_glob_assign_ref(aTHX_ a,b)
+#define ptr_table_find S_ptr_table_find
+#endif
+#endif
+#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define check_uni() S_check_uni(aTHX)
+#define force_next(a) S_force_next(aTHX_ a)
+#define force_version(a,b) S_force_version(aTHX_ a,b)
+#define force_word(a,b,c,d,e) S_force_word(aTHX_ a,b,c,d,e)
+#define tokeq(a) S_tokeq(aTHX_ a)
+#define readpipe_override() S_readpipe_override(aTHX)
+#define scan_const(a) S_scan_const(aTHX_ a)
+#define scan_formline(a) S_scan_formline(aTHX_ a)
+#define scan_heredoc(a) S_scan_heredoc(aTHX_ a)
+#define scan_ident(a,b,c,d,e) S_scan_ident(aTHX_ a,b,c,d,e)
+#define scan_inputsymbol(a) S_scan_inputsymbol(aTHX_ a)
+#define scan_pat(a,b) S_scan_pat(aTHX_ a,b)
+#define scan_str(a,b,c) S_scan_str(aTHX_ a,b,c)
+#define scan_subst(a) S_scan_subst(aTHX_ a)
+#define scan_trans(a) S_scan_trans(aTHX_ a)
+#define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e)
+#define update_debugger_info(a,b,c) S_update_debugger_info(aTHX_ a,b,c)
+#define skipspace(a) S_skipspace(aTHX_ a)
+#define swallow_bom(a) S_swallow_bom(aTHX_ a)
+#define checkcomma(a,b,c) S_checkcomma(aTHX_ a,b,c)
+#define feature_is_enabled(a,b) S_feature_is_enabled(aTHX_ a,b)
+#define force_ident(a,b) S_force_ident(aTHX_ a,b)
+#define incline(a) S_incline(aTHX_ a)
+#define intuit_method(a,b,c) S_intuit_method(aTHX_ a,b,c)
+#define intuit_more(a) S_intuit_more(aTHX_ a)
+#define lop(a,b,c) S_lop(aTHX_ a,b,c)
+#define missingterm(a) S_missingterm(aTHX_ a)
+#define no_op(a,b) S_no_op(aTHX_ a,b)
+#define sublex_done() S_sublex_done(aTHX)
+#define sublex_push() S_sublex_push(aTHX)
+#define sublex_start() S_sublex_start(aTHX)
+#define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c)
+#define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b)
+#define tokenize_use(a,b) S_tokenize_use(aTHX_ a,b)
+#define ao(a) S_ao(aTHX_ a)
+#endif
+# if defined(PERL_CR_FILTER)
+#ifdef PERL_CORE
+#define cr_textfilter(a,b,c) S_cr_textfilter(aTHX_ a,b,c)
+#define strip_return(a) S_strip_return(aTHX_ a)
+#endif
+# endif
+# if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define tokereport(a,b) S_tokereport(aTHX_ a,b)
+#define printbuf(a,b) S_printbuf(aTHX_ a,b)
+#endif
+# endif
+#endif
+#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define isa_lookup(a,b) S_isa_lookup(aTHX_ a,b)
+#endif
+#endif
+#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
+#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE)
+#ifdef PERL_CORE
+#define stdize_locale(a) S_stdize_locale(aTHX_ a)
+#endif
+#endif
+#endif
+#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define closest_cop(a,b) S_closest_cop(aTHX_ a,b)
+#define mess_alloc() S_mess_alloc(aTHX)
+#define vdie_croak_common(a,b,c,d) S_vdie_croak_common(aTHX_ a,b,c,d)
+#define vdie_common(a,b,c,d) S_vdie_common(aTHX_ a,b,c,d)
+#define write_no_mem() S_write_no_mem(aTHX)
+#endif
+#if defined(PERL_MEM_LOG) && defined(PERL_MEM_LOG_STDERR)
+#ifdef PERL_CORE
+#define mem_log_common S_mem_log_common
+#endif
+#endif
+#endif
+#if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define mulexp10 S_mulexp10
+#endif
+#endif
+#if defined(PERL_IN_UTF8_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define is_utf8_char_slow S_is_utf8_char_slow
+#define is_utf8_common(a,b,c) S_is_utf8_common(aTHX_ a,b,c)
+#define swash_get(a,b,c) S_swash_get(aTHX_ a,b,c)
+#endif
+#endif
+#define sv_setsv_flags(a,b,c) Perl_sv_setsv_flags(aTHX_ a,b,c)
+#define sv_catpvn_flags(a,b,c,d) Perl_sv_catpvn_flags(aTHX_ a,b,c,d)
+#define sv_catsv_flags(a,b,c) Perl_sv_catsv_flags(aTHX_ a,b,c)
+#define sv_utf8_upgrade_flags(a,b) Perl_sv_utf8_upgrade_flags(aTHX_ a,b)
+#define sv_pvn_force_flags(a,b,c) Perl_sv_pvn_force_flags(aTHX_ a,b,c)
+#define sv_copypv(a,b) Perl_sv_copypv(aTHX_ a,b)
+#define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b)
+#define my_socketpair Perl_my_socketpair
+#define my_dirfd(a) Perl_my_dirfd(aTHX_ a)
+#ifdef PERL_OLD_COPY_ON_WRITE
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b)
+#endif
+#endif
+#if defined(USE_PERLIO) && !defined(USE_SFIO)
+#define PerlIO_close(a) Perl_PerlIO_close(aTHX_ a)
+#define PerlIO_fill(a) Perl_PerlIO_fill(aTHX_ a)
+#define PerlIO_fileno(a) Perl_PerlIO_fileno(aTHX_ a)
+#define PerlIO_eof(a) Perl_PerlIO_eof(aTHX_ a)
+#define PerlIO_error(a) Perl_PerlIO_error(aTHX_ a)
+#define PerlIO_flush(a) Perl_PerlIO_flush(aTHX_ a)
+#define PerlIO_clearerr(a) Perl_PerlIO_clearerr(aTHX_ a)
+#define PerlIO_set_cnt(a,b) Perl_PerlIO_set_cnt(aTHX_ a,b)
+#define PerlIO_set_ptrcnt(a,b,c) Perl_PerlIO_set_ptrcnt(aTHX_ a,b,c)
+#define PerlIO_setlinebuf(a) Perl_PerlIO_setlinebuf(aTHX_ a)
+#define PerlIO_read(a,b,c) Perl_PerlIO_read(aTHX_ a,b,c)
+#define PerlIO_write(a,b,c) Perl_PerlIO_write(aTHX_ a,b,c)
+#define PerlIO_unread(a,b,c) Perl_PerlIO_unread(aTHX_ a,b,c)
+#define PerlIO_tell(a) Perl_PerlIO_tell(aTHX_ a)
+#define PerlIO_seek(a,b,c) Perl_PerlIO_seek(aTHX_ a,b,c)
+#define PerlIO_get_base(a) Perl_PerlIO_get_base(aTHX_ a)
+#define PerlIO_get_ptr(a) Perl_PerlIO_get_ptr(aTHX_ a)
+#define PerlIO_get_bufsiz(a) Perl_PerlIO_get_bufsiz(aTHX_ a)
+#define PerlIO_get_cnt(a) Perl_PerlIO_get_cnt(aTHX_ a)
+#define PerlIO_stdin() Perl_PerlIO_stdin(aTHX)
+#define PerlIO_stdout() Perl_PerlIO_stdout(aTHX)
+#define PerlIO_stderr() Perl_PerlIO_stderr(aTHX)
+#endif /* PERLIO_LAYERS */
+#ifdef PERL_CORE
+#define deb_stack_all() Perl_deb_stack_all(aTHX)
+#endif
+#if defined(PERL_IN_DEB_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define deb_stack_n(a,b,c,d,e) S_deb_stack_n(aTHX_ a,b,c,d,e)
+#endif
+#endif
+#ifdef PERL_CORE
+#define pad_new(a) Perl_pad_new(aTHX_ a)
+#define pad_undef(a) Perl_pad_undef(aTHX_ a)
+#define pad_add_name(a,b,c,d,e) Perl_pad_add_name(aTHX_ a,b,c,d,e)
+#define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b)
+#define pad_check_dup(a,b,c) Perl_pad_check_dup(aTHX_ a,b,c)
+#endif
+#ifdef DEBUGGING
+#ifdef PERL_CORE
+#define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b)
+#endif
+#endif
+#ifdef PERL_CORE
+#define pad_block_start(a) Perl_pad_block_start(aTHX_ a)
+#define pad_tidy(a) Perl_pad_tidy(aTHX_ a)
+#define do_dump_pad(a,b,c,d) Perl_do_dump_pad(aTHX_ a,b,c,d)
+#define pad_fixup_inner_anons(a,b,c) Perl_pad_fixup_inner_anons(aTHX_ a,b,c)
+#endif
+#ifdef PERL_CORE
+#define pad_push(a,b) Perl_pad_push(aTHX_ a,b)
+#define pad_compname_type(a) Perl_pad_compname_type(aTHX_ a)
+#endif
+#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
+#endif
+# if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define cv_dump(a,b) S_cv_dump(aTHX_ a,b)
+#endif
+# endif
+#endif
+#define find_runcv(a) Perl_find_runcv(aTHX_ a)
+#ifdef PERL_CORE
+#define free_tied_hv_pool() Perl_free_tied_hv_pool(aTHX)
+#endif
+#if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define get_debug_opts(a,b) Perl_get_debug_opts(aTHX_ a,b)
+#endif
+#endif
+#define save_set_svflags(a,b,c) Perl_save_set_svflags(aTHX_ a,b,c)
+#define hv_scalar(a) Perl_hv_scalar(aTHX_ a)
+#define hv_name_set(a,b,c,d) Perl_hv_name_set(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#endif
+#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#endif
+#endif
+#define hv_clear_placeholders(a) Perl_hv_clear_placeholders(aTHX_ a)
+#ifdef PERL_CORE
+#define magic_scalarpack(a,b) Perl_magic_scalarpack(aTHX_ a,b)
+#endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define find_hash_subscript(a,b) S_find_hash_subscript(aTHX_ a,b)
+#define find_array_subscript(a,b) S_find_array_subscript(aTHX_ a,b)
+#define find_uninit_var(a,b,c) S_find_uninit_var(aTHX_ a,b,c)
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLE16
+#ifdef PERL_CORE
+#define my_htole16 Perl_my_htole16
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOH16
+#ifdef PERL_CORE
+#define my_letoh16 Perl_my_letoh16
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE16
+#ifdef PERL_CORE
+#define my_htobe16 Perl_my_htobe16
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOH16
+#ifdef PERL_CORE
+#define my_betoh16 Perl_my_betoh16
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLE32
+#ifdef PERL_CORE
+#define my_htole32 Perl_my_htole32
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOH32
+#ifdef PERL_CORE
+#define my_letoh32 Perl_my_letoh32
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE32
+#ifdef PERL_CORE
+#define my_htobe32 Perl_my_htobe32
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOH32
+#ifdef PERL_CORE
+#define my_betoh32 Perl_my_betoh32
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLE64
+#ifdef PERL_CORE
+#define my_htole64 Perl_my_htole64
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOH64
+#ifdef PERL_CORE
+#define my_letoh64 Perl_my_letoh64
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE64
+#ifdef PERL_CORE
+#define my_htobe64 Perl_my_htobe64
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOH64
+#ifdef PERL_CORE
+#define my_betoh64 Perl_my_betoh64
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLES
+#ifdef PERL_CORE
+#define my_htoles Perl_my_htoles
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOHS
+#ifdef PERL_CORE
+#define my_letohs Perl_my_letohs
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBES
+#ifdef PERL_CORE
+#define my_htobes Perl_my_htobes
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOHS
+#ifdef PERL_CORE
+#define my_betohs Perl_my_betohs
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLEI
+#ifdef PERL_CORE
+#define my_htolei Perl_my_htolei
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOHI
+#ifdef PERL_CORE
+#define my_letohi Perl_my_letohi
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBEI
+#ifdef PERL_CORE
+#define my_htobei Perl_my_htobei
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOHI
+#ifdef PERL_CORE
+#define my_betohi Perl_my_betohi
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOLEL
+#ifdef PERL_CORE
+#define my_htolel Perl_my_htolel
+#endif
+#endif
+#ifdef PERL_NEED_MY_LETOHL
+#ifdef PERL_CORE
+#define my_letohl Perl_my_letohl
+#endif
+#endif
+#ifdef PERL_NEED_MY_HTOBEL
+#ifdef PERL_CORE
+#define my_htobel Perl_my_htobel
+#endif
+#endif
+#ifdef PERL_NEED_MY_BETOHL
+#ifdef PERL_CORE
+#define my_betohl Perl_my_betohl
+#endif
+#endif
+#ifdef PERL_CORE
+#define my_swabn Perl_my_swabn
+#endif
+#define gv_fetchpvn_flags(a,b,c,d) Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
+#define gv_fetchsv(a,b,c) Perl_gv_fetchsv(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define is_gv_magical_sv(a,b) Perl_is_gv_magical_sv(aTHX_ a,b)
+#endif
+#define stashpv_hvname_match(a,b) Perl_stashpv_hvname_match(aTHX_ a,b)
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+#ifdef PERL_CORE
+#define dump_sv_child(a) Perl_dump_sv_child(aTHX_ a)
+#endif
+#endif
+#ifdef PERL_DONT_CREATE_GVSV
+#define gv_SVadd(a) Perl_gv_SVadd(aTHX_ a)
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#endif
+#ifdef PERL_CORE
+#define offer_nice_chunk(a,b) Perl_offer_nice_chunk(aTHX_ a,b)
+#endif
+#ifndef SPRINTF_RETURNS_STRLEN
+#endif
+#ifdef PERL_CORE
+#define my_clearenv() Perl_my_clearenv(aTHX)
+#endif
+#ifdef PERL_IMPLICIT_CONTEXT
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+#else
+#endif
+#endif
+#ifndef HAS_STRLCAT
+#endif
+#ifndef HAS_STRLCPY
+#endif
+#ifdef PERL_MAD
+#ifdef PERL_CORE
+#define pad_peg Perl_pad_peg
+#endif
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#endif
+#endif
+#ifdef PERL_CORE
+#define xmldump_vindent(a,b,c,d) Perl_xmldump_vindent(aTHX_ a,b,c,d)
+#define xmldump_all() Perl_xmldump_all(aTHX)
+#define xmldump_packsubs(a) Perl_xmldump_packsubs(aTHX_ a)
+#define xmldump_sub(a) Perl_xmldump_sub(aTHX_ a)
+#define xmldump_form(a) Perl_xmldump_form(aTHX_ a)
+#define xmldump_eval() Perl_xmldump_eval(aTHX)
+#define sv_catxmlsv(a,b) Perl_sv_catxmlsv(aTHX_ a,b)
+#define sv_catxmlpvn(a,b,c,d) Perl_sv_catxmlpvn(aTHX_ a,b,c,d)
+#define sv_xmlpeek(a) Perl_sv_xmlpeek(aTHX_ a)
+#define do_pmop_xmldump(a,b,c) Perl_do_pmop_xmldump(aTHX_ a,b,c)
+#define pmop_xmldump(a) Perl_pmop_xmldump(aTHX_ a)
+#define do_op_xmldump(a,b,c) Perl_do_op_xmldump(aTHX_ a,b,c)
+#define op_xmldump(a) Perl_op_xmldump(aTHX_ a)
+#endif
+#ifdef PERL_CORE
+#define newTOKEN(a,b,c) Perl_newTOKEN(aTHX_ a,b,c)
+#define token_free(a) Perl_token_free(aTHX_ a)
+#define token_getmad(a,b,c) Perl_token_getmad(aTHX_ a,b,c)
+#define op_getmad_weak(a,b,c) Perl_op_getmad_weak(aTHX_ a,b,c)
+#define op_getmad(a,b,c) Perl_op_getmad(aTHX_ a,b,c)
+#define prepend_madprops(a,b,c) Perl_prepend_madprops(aTHX_ a,b,c)
+#define append_madprops(a,b,c) Perl_append_madprops(aTHX_ a,b,c)
+#define addmad(a,b,c) Perl_addmad(aTHX_ a,b,c)
+#define newMADsv(a,b) Perl_newMADsv(aTHX_ a,b)
+#define newMADPROP(a,b,c,d) Perl_newMADPROP(aTHX_ a,b,c,d)
+#define mad_free(a) Perl_mad_free(aTHX_ a)
+#endif
+# if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define skipspace0(a) S_skipspace0(aTHX_ a)
+#define skipspace1(a) S_skipspace1(aTHX_ a)
+#define skipspace2(a,b) S_skipspace2(aTHX_ a,b)
+#define start_force(a) S_start_force(aTHX_ a)
+#define curmad(a,b) S_curmad(aTHX_ a,b)
+#endif
+# endif
+#ifdef PERL_CORE
+#define madlex() Perl_madlex(aTHX)
+#define madparse() Perl_madparse(aTHX)
+#endif
+#endif
+#if !defined(HAS_SIGNBIT)
+#endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#endif
+#ifdef PERL_CORE
+#endif
+#if defined(USE_ITHREADS)
+#ifdef PERL_CORE
+#define mro_meta_dup(a,b) Perl_mro_meta_dup(aTHX_ a,b)
+#endif
+#endif
+#define mro_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a)
+#if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b)
+#endif
+#endif
+#ifdef PERL_CORE
+#define mro_isa_changed_in(a) Perl_mro_isa_changed_in(aTHX_ a)
+#endif
+#define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a)
+#ifdef PERL_CORE
+#define boot_core_mro() Perl_boot_core_mro(aTHX)
+#endif
+#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
+#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
+#define ck_chdir(a) Perl_ck_chdir(aTHX_ a)
+#define ck_concat(a) Perl_ck_concat(aTHX_ a)
+#define ck_defined(a) Perl_ck_defined(aTHX_ a)
+#define ck_delete(a) Perl_ck_delete(aTHX_ a)
+#define ck_die(a) Perl_ck_die(aTHX_ a)
+#define ck_eof(a) Perl_ck_eof(aTHX_ a)
+#define ck_eval(a) Perl_ck_eval(aTHX_ a)
+#define ck_exec(a) Perl_ck_exec(aTHX_ a)
+#define ck_exists(a) Perl_ck_exists(aTHX_ a)
+#define ck_exit(a) Perl_ck_exit(aTHX_ a)
+#define ck_ftst(a) Perl_ck_ftst(aTHX_ a)
+#define ck_fun(a) Perl_ck_fun(aTHX_ a)
+#define ck_glob(a) Perl_ck_glob(aTHX_ a)
+#define ck_grep(a) Perl_ck_grep(aTHX_ a)
+#define ck_index(a) Perl_ck_index(aTHX_ a)
+#define ck_join(a) Perl_ck_join(aTHX_ a)
+#define ck_lengthconst(a) Perl_ck_lengthconst(aTHX_ a)
+#define ck_lfun(a) Perl_ck_lfun(aTHX_ a)
+#define ck_listiob(a) Perl_ck_listiob(aTHX_ a)
+#define ck_match(a) Perl_ck_match(aTHX_ a)
+#define ck_method(a) Perl_ck_method(aTHX_ a)
+#define ck_null(a) Perl_ck_null(aTHX_ a)
+#define ck_open(a) Perl_ck_open(aTHX_ a)
+#define ck_readline(a) Perl_ck_readline(aTHX_ a)
+#define ck_repeat(a) Perl_ck_repeat(aTHX_ a)
+#define ck_require(a) Perl_ck_require(aTHX_ a)
+#define ck_return(a) Perl_ck_return(aTHX_ a)
+#define ck_rfun(a) Perl_ck_rfun(aTHX_ a)
+#define ck_rvconst(a) Perl_ck_rvconst(aTHX_ a)
+#define ck_sassign(a) Perl_ck_sassign(aTHX_ a)
+#define ck_select(a) Perl_ck_select(aTHX_ a)
+#define ck_shift(a) Perl_ck_shift(aTHX_ a)
+#define ck_smartmatch(a) Perl_ck_smartmatch(aTHX_ a)
+#define ck_sort(a) Perl_ck_sort(aTHX_ a)
+#define ck_spair(a) Perl_ck_spair(aTHX_ a)
+#define ck_split(a) Perl_ck_split(aTHX_ a)
+#define ck_subr(a) Perl_ck_subr(aTHX_ a)
+#define ck_substr(a) Perl_ck_substr(aTHX_ a)
+#define ck_svconst(a) Perl_ck_svconst(aTHX_ a)
+#define ck_trunc(a) Perl_ck_trunc(aTHX_ a)
+#define ck_unpack(a) Perl_ck_unpack(aTHX_ a)
+#define pp_aassign() Perl_pp_aassign(aTHX)
+#define pp_abs() Perl_pp_abs(aTHX)
+#define pp_accept() Perl_pp_accept(aTHX)
+#define pp_add() Perl_pp_add(aTHX)
+#define pp_aelem() Perl_pp_aelem(aTHX)
+#define pp_aelemfast() Perl_pp_aelemfast(aTHX)
+#define pp_alarm() Perl_pp_alarm(aTHX)
+#define pp_and() Perl_pp_and(aTHX)
+#define pp_andassign() Perl_pp_andassign(aTHX)
+#define pp_anoncode() Perl_pp_anoncode(aTHX)
+#define pp_anonhash() Perl_pp_anonhash(aTHX)
+#define pp_anonlist() Perl_pp_anonlist(aTHX)
+#define pp_aslice() Perl_pp_aslice(aTHX)
+#define pp_atan2() Perl_pp_atan2(aTHX)
+#define pp_av2arylen() Perl_pp_av2arylen(aTHX)
+#define pp_backtick() Perl_pp_backtick(aTHX)
+#define pp_bind() Perl_pp_bind(aTHX)
+#define pp_binmode() Perl_pp_binmode(aTHX)
+#define pp_bit_and() Perl_pp_bit_and(aTHX)
+#define pp_bit_or() Perl_pp_bit_or(aTHX)
+#define pp_bit_xor() Perl_pp_bit_xor(aTHX)
+#define pp_bless() Perl_pp_bless(aTHX)
+#define pp_break() Perl_pp_break(aTHX)
+#define pp_caller() Perl_pp_caller(aTHX)
+#define pp_chdir() Perl_pp_chdir(aTHX)
+#define pp_chmod() Perl_pp_chmod(aTHX)
+#define pp_chomp() Perl_pp_chomp(aTHX)
+#define pp_chop() Perl_pp_chop(aTHX)
+#define pp_chown() Perl_pp_chown(aTHX)
+#define pp_chr() Perl_pp_chr(aTHX)
+#define pp_chroot() Perl_pp_chroot(aTHX)
+#define pp_close() Perl_pp_close(aTHX)
+#define pp_closedir() Perl_pp_closedir(aTHX)
+#define pp_complement() Perl_pp_complement(aTHX)
+#define pp_concat() Perl_pp_concat(aTHX)
+#define pp_cond_expr() Perl_pp_cond_expr(aTHX)
+#define pp_connect() Perl_pp_connect(aTHX)
+#define pp_const() Perl_pp_const(aTHX)
+#define pp_continue() Perl_pp_continue(aTHX)
+#define pp_cos() Perl_pp_cos(aTHX)
+#define pp_crypt() Perl_pp_crypt(aTHX)
+#define pp_dbmclose() Perl_pp_dbmclose(aTHX)
+#define pp_dbmopen() Perl_pp_dbmopen(aTHX)
+#define pp_dbstate() Perl_pp_dbstate(aTHX)
+#define pp_defined() Perl_pp_defined(aTHX)
+#define pp_delete() Perl_pp_delete(aTHX)
+#define pp_die() Perl_pp_die(aTHX)
+#define pp_divide() Perl_pp_divide(aTHX)
+#define pp_dofile() Perl_pp_dofile(aTHX)
+#define pp_dor() Perl_pp_dor(aTHX)
+#define pp_dorassign() Perl_pp_dorassign(aTHX)
+#define pp_dump() Perl_pp_dump(aTHX)
+#define pp_each() Perl_pp_each(aTHX)
+#define pp_egrent() Perl_pp_egrent(aTHX)
+#define pp_ehostent() Perl_pp_ehostent(aTHX)
+#define pp_enetent() Perl_pp_enetent(aTHX)
+#define pp_enter() Perl_pp_enter(aTHX)
+#define pp_entereval() Perl_pp_entereval(aTHX)
+#define pp_entergiven() Perl_pp_entergiven(aTHX)
+#define pp_enteriter() Perl_pp_enteriter(aTHX)
+#define pp_enterloop() Perl_pp_enterloop(aTHX)
+#define pp_entersub() Perl_pp_entersub(aTHX)
+#define pp_entertry() Perl_pp_entertry(aTHX)
+#define pp_enterwhen() Perl_pp_enterwhen(aTHX)
+#define pp_enterwrite() Perl_pp_enterwrite(aTHX)
+#define pp_eof() Perl_pp_eof(aTHX)
+#define pp_eprotoent() Perl_pp_eprotoent(aTHX)
+#define pp_epwent() Perl_pp_epwent(aTHX)
+#define pp_eq() Perl_pp_eq(aTHX)
+#define pp_eservent() Perl_pp_eservent(aTHX)
+#define pp_exec() Perl_pp_exec(aTHX)
+#define pp_exists() Perl_pp_exists(aTHX)
+#define pp_exit() Perl_pp_exit(aTHX)
+#define pp_exp() Perl_pp_exp(aTHX)
+#define pp_fcntl() Perl_pp_fcntl(aTHX)
+#define pp_fileno() Perl_pp_fileno(aTHX)
+#define pp_flip() Perl_pp_flip(aTHX)
+#define pp_flock() Perl_pp_flock(aTHX)
+#define pp_flop() Perl_pp_flop(aTHX)
+#define pp_fork() Perl_pp_fork(aTHX)
+#define pp_formline() Perl_pp_formline(aTHX)
+#define pp_ftatime() Perl_pp_ftatime(aTHX)
+#define pp_ftbinary() Perl_pp_ftbinary(aTHX)
+#define pp_ftblk() Perl_pp_ftblk(aTHX)
+#define pp_ftchr() Perl_pp_ftchr(aTHX)
+#define pp_ftctime() Perl_pp_ftctime(aTHX)
+#define pp_ftdir() Perl_pp_ftdir(aTHX)
+#define pp_fteexec() Perl_pp_fteexec(aTHX)
+#define pp_fteowned() Perl_pp_fteowned(aTHX)
+#define pp_fteread() Perl_pp_fteread(aTHX)
+#define pp_ftewrite() Perl_pp_ftewrite(aTHX)
+#define pp_ftfile() Perl_pp_ftfile(aTHX)
+#define pp_ftis() Perl_pp_ftis(aTHX)
+#define pp_ftlink() Perl_pp_ftlink(aTHX)
+#define pp_ftmtime() Perl_pp_ftmtime(aTHX)
+#define pp_ftpipe() Perl_pp_ftpipe(aTHX)
+#define pp_ftrexec() Perl_pp_ftrexec(aTHX)
+#define pp_ftrowned() Perl_pp_ftrowned(aTHX)
+#define pp_ftrread() Perl_pp_ftrread(aTHX)
+#define pp_ftrwrite() Perl_pp_ftrwrite(aTHX)
+#define pp_ftsgid() Perl_pp_ftsgid(aTHX)
+#define pp_ftsize() Perl_pp_ftsize(aTHX)
+#define pp_ftsock() Perl_pp_ftsock(aTHX)
+#define pp_ftsuid() Perl_pp_ftsuid(aTHX)
+#define pp_ftsvtx() Perl_pp_ftsvtx(aTHX)
+#define pp_fttext() Perl_pp_fttext(aTHX)
+#define pp_fttty() Perl_pp_fttty(aTHX)
+#define pp_ftzero() Perl_pp_ftzero(aTHX)
+#define pp_ge() Perl_pp_ge(aTHX)
+#define pp_gelem() Perl_pp_gelem(aTHX)
+#define pp_getc() Perl_pp_getc(aTHX)
+#define pp_getlogin() Perl_pp_getlogin(aTHX)
+#define pp_getpeername() Perl_pp_getpeername(aTHX)
+#define pp_getpgrp() Perl_pp_getpgrp(aTHX)
+#define pp_getppid() Perl_pp_getppid(aTHX)
+#define pp_getpriority() Perl_pp_getpriority(aTHX)
+#define pp_getsockname() Perl_pp_getsockname(aTHX)
+#define pp_ggrent() Perl_pp_ggrent(aTHX)
+#define pp_ggrgid() Perl_pp_ggrgid(aTHX)
+#define pp_ggrnam() Perl_pp_ggrnam(aTHX)
+#define pp_ghbyaddr() Perl_pp_ghbyaddr(aTHX)
+#define pp_ghbyname() Perl_pp_ghbyname(aTHX)
+#define pp_ghostent() Perl_pp_ghostent(aTHX)
+#define pp_glob() Perl_pp_glob(aTHX)
+#define pp_gmtime() Perl_pp_gmtime(aTHX)
+#define pp_gnbyaddr() Perl_pp_gnbyaddr(aTHX)
+#define pp_gnbyname() Perl_pp_gnbyname(aTHX)
+#define pp_gnetent() Perl_pp_gnetent(aTHX)
+#define pp_goto() Perl_pp_goto(aTHX)
+#define pp_gpbyname() Perl_pp_gpbyname(aTHX)
+#define pp_gpbynumber() Perl_pp_gpbynumber(aTHX)
+#define pp_gprotoent() Perl_pp_gprotoent(aTHX)
+#define pp_gpwent() Perl_pp_gpwent(aTHX)
+#define pp_gpwnam() Perl_pp_gpwnam(aTHX)
+#define pp_gpwuid() Perl_pp_gpwuid(aTHX)
+#define pp_grepstart() Perl_pp_grepstart(aTHX)
+#define pp_grepwhile() Perl_pp_grepwhile(aTHX)
+#define pp_gsbyname() Perl_pp_gsbyname(aTHX)
+#define pp_gsbyport() Perl_pp_gsbyport(aTHX)
+#define pp_gservent() Perl_pp_gservent(aTHX)
+#define pp_gsockopt() Perl_pp_gsockopt(aTHX)
+#define pp_gt() Perl_pp_gt(aTHX)
+#define pp_gv() Perl_pp_gv(aTHX)
+#define pp_gvsv() Perl_pp_gvsv(aTHX)
+#define pp_helem() Perl_pp_helem(aTHX)
+#define pp_hex() Perl_pp_hex(aTHX)
+#define pp_hslice() Perl_pp_hslice(aTHX)
+#define pp_i_add() Perl_pp_i_add(aTHX)
+#define pp_i_divide() Perl_pp_i_divide(aTHX)
+#define pp_i_eq() Perl_pp_i_eq(aTHX)
+#define pp_i_ge() Perl_pp_i_ge(aTHX)
+#define pp_i_gt() Perl_pp_i_gt(aTHX)
+#define pp_i_le() Perl_pp_i_le(aTHX)
+#define pp_i_lt() Perl_pp_i_lt(aTHX)
+#define pp_i_modulo() Perl_pp_i_modulo(aTHX)
+#define pp_i_multiply() Perl_pp_i_multiply(aTHX)
+#define pp_i_ncmp() Perl_pp_i_ncmp(aTHX)
+#define pp_i_ne() Perl_pp_i_ne(aTHX)
+#define pp_i_negate() Perl_pp_i_negate(aTHX)
+#define pp_i_subtract() Perl_pp_i_subtract(aTHX)
+#define pp_index() Perl_pp_index(aTHX)
+#define pp_int() Perl_pp_int(aTHX)
+#define pp_ioctl() Perl_pp_ioctl(aTHX)
+#define pp_iter() Perl_pp_iter(aTHX)
+#define pp_join() Perl_pp_join(aTHX)
+#define pp_keys() Perl_pp_keys(aTHX)
+#define pp_kill() Perl_pp_kill(aTHX)
+#define pp_last() Perl_pp_last(aTHX)
+#define pp_lc() Perl_pp_lc(aTHX)
+#define pp_lcfirst() Perl_pp_lcfirst(aTHX)
+#define pp_le() Perl_pp_le(aTHX)
+#define pp_leave() Perl_pp_leave(aTHX)
+#define pp_leaveeval() Perl_pp_leaveeval(aTHX)
+#define pp_leavegiven() Perl_pp_leavegiven(aTHX)
+#define pp_leaveloop() Perl_pp_leaveloop(aTHX)
+#define pp_leavesub() Perl_pp_leavesub(aTHX)
+#define pp_leavesublv() Perl_pp_leavesublv(aTHX)
+#define pp_leavetry() Perl_pp_leavetry(aTHX)
+#define pp_leavewhen() Perl_pp_leavewhen(aTHX)
+#define pp_leavewrite() Perl_pp_leavewrite(aTHX)
+#define pp_left_shift() Perl_pp_left_shift(aTHX)
+#define pp_length() Perl_pp_length(aTHX)
+#define pp_lineseq() Perl_pp_lineseq(aTHX)
+#define pp_link() Perl_pp_link(aTHX)
+#define pp_list() Perl_pp_list(aTHX)
+#define pp_listen() Perl_pp_listen(aTHX)
+#define pp_localtime() Perl_pp_localtime(aTHX)
+#define pp_lock() Perl_pp_lock(aTHX)
+#define pp_log() Perl_pp_log(aTHX)
+#define pp_lslice() Perl_pp_lslice(aTHX)
+#define pp_lstat() Perl_pp_lstat(aTHX)
+#define pp_lt() Perl_pp_lt(aTHX)
+#define pp_mapstart() Perl_pp_mapstart(aTHX)
+#define pp_mapwhile() Perl_pp_mapwhile(aTHX)
+#define pp_match() Perl_pp_match(aTHX)
+#define pp_method() Perl_pp_method(aTHX)
+#define pp_method_named() Perl_pp_method_named(aTHX)
+#define pp_mkdir() Perl_pp_mkdir(aTHX)
+#define pp_modulo() Perl_pp_modulo(aTHX)
+#define pp_msgctl() Perl_pp_msgctl(aTHX)
+#define pp_msgget() Perl_pp_msgget(aTHX)
+#define pp_msgrcv() Perl_pp_msgrcv(aTHX)
+#define pp_msgsnd() Perl_pp_msgsnd(aTHX)
+#define pp_multiply() Perl_pp_multiply(aTHX)
+#define pp_ncmp() Perl_pp_ncmp(aTHX)
+#define pp_ne() Perl_pp_ne(aTHX)
+#define pp_negate() Perl_pp_negate(aTHX)
+#define pp_next() Perl_pp_next(aTHX)
+#define pp_nextstate() Perl_pp_nextstate(aTHX)
+#define pp_not() Perl_pp_not(aTHX)
+#define pp_null() Perl_pp_null(aTHX)
+#define pp_oct() Perl_pp_oct(aTHX)
+#define pp_once() Perl_pp_once(aTHX)
+#define pp_open() Perl_pp_open(aTHX)
+#define pp_open_dir() Perl_pp_open_dir(aTHX)
+#define pp_or() Perl_pp_or(aTHX)
+#define pp_orassign() Perl_pp_orassign(aTHX)
+#define pp_ord() Perl_pp_ord(aTHX)
+#define pp_pack() Perl_pp_pack(aTHX)
+#define pp_padany() Perl_pp_padany(aTHX)
+#define pp_padav() Perl_pp_padav(aTHX)
+#define pp_padhv() Perl_pp_padhv(aTHX)
+#define pp_padsv() Perl_pp_padsv(aTHX)
+#define pp_pipe_op() Perl_pp_pipe_op(aTHX)
+#define pp_pop() Perl_pp_pop(aTHX)
+#define pp_pos() Perl_pp_pos(aTHX)
+#define pp_postdec() Perl_pp_postdec(aTHX)
+#define pp_postinc() Perl_pp_postinc(aTHX)
+#define pp_pow() Perl_pp_pow(aTHX)
+#define pp_predec() Perl_pp_predec(aTHX)
+#define pp_preinc() Perl_pp_preinc(aTHX)
+#define pp_print() Perl_pp_print(aTHX)
+#define pp_prototype() Perl_pp_prototype(aTHX)
+#define pp_prtf() Perl_pp_prtf(aTHX)
+#define pp_push() Perl_pp_push(aTHX)
+#define pp_pushmark() Perl_pp_pushmark(aTHX)
+#define pp_pushre() Perl_pp_pushre(aTHX)
+#define pp_qr() Perl_pp_qr(aTHX)
+#define pp_quotemeta() Perl_pp_quotemeta(aTHX)
+#define pp_rand() Perl_pp_rand(aTHX)
+#define pp_range() Perl_pp_range(aTHX)
+#define pp_rcatline() Perl_pp_rcatline(aTHX)
+#define pp_read() Perl_pp_read(aTHX)
+#define pp_readdir() Perl_pp_readdir(aTHX)
+#define pp_readline() Perl_pp_readline(aTHX)
+#define pp_readlink() Perl_pp_readlink(aTHX)
+#define pp_recv() Perl_pp_recv(aTHX)
+#define pp_redo() Perl_pp_redo(aTHX)
+#define pp_ref() Perl_pp_ref(aTHX)
+#define pp_refgen() Perl_pp_refgen(aTHX)
+#define pp_regcmaybe() Perl_pp_regcmaybe(aTHX)
+#define pp_regcomp() Perl_pp_regcomp(aTHX)
+#define pp_regcreset() Perl_pp_regcreset(aTHX)
+#define pp_rename() Perl_pp_rename(aTHX)
+#define pp_repeat() Perl_pp_repeat(aTHX)
+#define pp_require() Perl_pp_require(aTHX)
+#define pp_reset() Perl_pp_reset(aTHX)
+#define pp_return() Perl_pp_return(aTHX)
+#define pp_reverse() Perl_pp_reverse(aTHX)
+#define pp_rewinddir() Perl_pp_rewinddir(aTHX)
+#define pp_right_shift() Perl_pp_right_shift(aTHX)
+#define pp_rindex() Perl_pp_rindex(aTHX)
+#define pp_rmdir() Perl_pp_rmdir(aTHX)
+#define pp_rv2av() Perl_pp_rv2av(aTHX)
+#define pp_rv2cv() Perl_pp_rv2cv(aTHX)
+#define pp_rv2gv() Perl_pp_rv2gv(aTHX)
+#define pp_rv2hv() Perl_pp_rv2hv(aTHX)
+#define pp_rv2sv() Perl_pp_rv2sv(aTHX)
+#define pp_sassign() Perl_pp_sassign(aTHX)
+#define pp_say() Perl_pp_say(aTHX)
+#define pp_scalar() Perl_pp_scalar(aTHX)
+#define pp_schomp() Perl_pp_schomp(aTHX)
+#define pp_schop() Perl_pp_schop(aTHX)
+#define pp_scmp() Perl_pp_scmp(aTHX)
+#define pp_scope() Perl_pp_scope(aTHX)
+#define pp_seek() Perl_pp_seek(aTHX)
+#define pp_seekdir() Perl_pp_seekdir(aTHX)
+#define pp_select() Perl_pp_select(aTHX)
+#define pp_semctl() Perl_pp_semctl(aTHX)
+#define pp_semget() Perl_pp_semget(aTHX)
+#define pp_semop() Perl_pp_semop(aTHX)
+#define pp_send() Perl_pp_send(aTHX)
+#define pp_seq() Perl_pp_seq(aTHX)
+#define pp_setpgrp() Perl_pp_setpgrp(aTHX)
+#define pp_setpriority() Perl_pp_setpriority(aTHX)
+#define pp_setstate() Perl_pp_setstate(aTHX)
+#define pp_sge() Perl_pp_sge(aTHX)
+#define pp_sgrent() Perl_pp_sgrent(aTHX)
+#define pp_sgt() Perl_pp_sgt(aTHX)
+#define pp_shift() Perl_pp_shift(aTHX)
+#define pp_shmctl() Perl_pp_shmctl(aTHX)
+#define pp_shmget() Perl_pp_shmget(aTHX)
+#define pp_shmread() Perl_pp_shmread(aTHX)
+#define pp_shmwrite() Perl_pp_shmwrite(aTHX)
+#define pp_shostent() Perl_pp_shostent(aTHX)
+#define pp_shutdown() Perl_pp_shutdown(aTHX)
+#define pp_sin() Perl_pp_sin(aTHX)
+#define pp_sle() Perl_pp_sle(aTHX)
+#define pp_sleep() Perl_pp_sleep(aTHX)
+#define pp_slt() Perl_pp_slt(aTHX)
+#define pp_smartmatch() Perl_pp_smartmatch(aTHX)
+#define pp_sne() Perl_pp_sne(aTHX)
+#define pp_snetent() Perl_pp_snetent(aTHX)
+#define pp_socket() Perl_pp_socket(aTHX)
+#define pp_sockpair() Perl_pp_sockpair(aTHX)
+#define pp_sort() Perl_pp_sort(aTHX)
+#define pp_splice() Perl_pp_splice(aTHX)
+#define pp_split() Perl_pp_split(aTHX)
+#define pp_sprintf() Perl_pp_sprintf(aTHX)
+#define pp_sprotoent() Perl_pp_sprotoent(aTHX)
+#define pp_spwent() Perl_pp_spwent(aTHX)
+#define pp_sqrt() Perl_pp_sqrt(aTHX)
+#define pp_srand() Perl_pp_srand(aTHX)
+#define pp_srefgen() Perl_pp_srefgen(aTHX)
+#define pp_sselect() Perl_pp_sselect(aTHX)
+#define pp_sservent() Perl_pp_sservent(aTHX)
+#define pp_ssockopt() Perl_pp_ssockopt(aTHX)
+#define pp_stat() Perl_pp_stat(aTHX)
+#define pp_stringify() Perl_pp_stringify(aTHX)
+#define pp_stub() Perl_pp_stub(aTHX)
+#define pp_study() Perl_pp_study(aTHX)
+#define pp_subst() Perl_pp_subst(aTHX)
+#define pp_substcont() Perl_pp_substcont(aTHX)
+#define pp_substr() Perl_pp_substr(aTHX)
+#define pp_subtract() Perl_pp_subtract(aTHX)
+#define pp_symlink() Perl_pp_symlink(aTHX)
+#define pp_syscall() Perl_pp_syscall(aTHX)
+#define pp_sysopen() Perl_pp_sysopen(aTHX)
+#define pp_sysread() Perl_pp_sysread(aTHX)
+#define pp_sysseek() Perl_pp_sysseek(aTHX)
+#define pp_system() Perl_pp_system(aTHX)
+#define pp_syswrite() Perl_pp_syswrite(aTHX)
+#define pp_tell() Perl_pp_tell(aTHX)
+#define pp_telldir() Perl_pp_telldir(aTHX)
+#define pp_tie() Perl_pp_tie(aTHX)
+#define pp_tied() Perl_pp_tied(aTHX)
+#define pp_time() Perl_pp_time(aTHX)
+#define pp_tms() Perl_pp_tms(aTHX)
+#define pp_trans() Perl_pp_trans(aTHX)
+#define pp_truncate() Perl_pp_truncate(aTHX)
+#define pp_uc() Perl_pp_uc(aTHX)
+#define pp_ucfirst() Perl_pp_ucfirst(aTHX)
+#define pp_umask() Perl_pp_umask(aTHX)
+#define pp_undef() Perl_pp_undef(aTHX)
+#define pp_unlink() Perl_pp_unlink(aTHX)
+#define pp_unpack() Perl_pp_unpack(aTHX)
+#define pp_unshift() Perl_pp_unshift(aTHX)
+#define pp_unstack() Perl_pp_unstack(aTHX)
+#define pp_untie() Perl_pp_untie(aTHX)
+#define pp_utime() Perl_pp_utime(aTHX)
+#define pp_values() Perl_pp_values(aTHX)
+#define pp_vec() Perl_pp_vec(aTHX)
+#define pp_wait() Perl_pp_wait(aTHX)
+#define pp_waitpid() Perl_pp_waitpid(aTHX)
+#define pp_wantarray() Perl_pp_wantarray(aTHX)
+#define pp_warn() Perl_pp_warn(aTHX)
+#define pp_xor() Perl_pp_xor(aTHX)
+
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+#endif /* #ifndef PERL_NO_SHORT_NAMES */
+
+
+/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
+ disable them.
+ */
+
+#if !defined(PERL_CORE)
+# define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
+# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr))
+#endif
+
+#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
+
+/* Compatibility for various misnamed functions. All functions
+ in the API that begin with "perl_" (not "Perl_") take an explicit
+ interpreter context pointer.
+ The following are not like that, but since they had a "perl_"
+ prefix in previous versions, we provide compatibility macros.
+ */
+# define perl_atexit(a,b) call_atexit(a,b)
+# define perl_call_argv(a,b,c) call_argv(a,b,c)
+# define perl_call_pv(a,b) call_pv(a,b)
+# define perl_call_method(a,b) call_method(a,b)
+# define perl_call_sv(a,b) call_sv(a,b)
+# define perl_eval_sv(a,b) eval_sv(a,b)
+# define perl_eval_pv(a,b) eval_pv(a,b)
+# define perl_require_pv(a) require_pv(a)
+# define perl_get_sv(a,b) get_sv(a,b)
+# define perl_get_av(a,b) get_av(a,b)
+# define perl_get_hv(a,b) get_hv(a,b)
+# define perl_get_cv(a,b) get_cv(a,b)
+# define perl_init_i18nl10n(a) init_i18nl10n(a)
+# define perl_init_i18nl14n(a) init_i18nl14n(a)
+# define perl_new_ctype(a) new_ctype(a)
+# define perl_new_collate(a) new_collate(a)
+# define perl_new_numeric(a) new_numeric(a)
+
+/* varargs functions can't be handled with CPP macros. :-(
+ This provides a set of compatibility functions that don't take
+ an extra argument but grab the context pointer using the macro
+ dTHX.
+ */
+#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
+# define croak Perl_croak_nocontext
+# define deb Perl_deb_nocontext
+# define die Perl_die_nocontext
+# define form Perl_form_nocontext
+# define load_module Perl_load_module_nocontext
+# define mess Perl_mess_nocontext
+# define newSVpvf Perl_newSVpvf_nocontext
+# define sv_catpvf Perl_sv_catpvf_nocontext
+# define sv_setpvf Perl_sv_setpvf_nocontext
+# define warn Perl_warn_nocontext
+# define warner Perl_warner_nocontext
+# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
+# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
+#endif
+
+#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
+
+#if !defined(PERL_IMPLICIT_CONTEXT)
+/* undefined symbols, point them back at the usual ones */
+# define Perl_croak_nocontext Perl_croak
+# define Perl_die_nocontext Perl_die
+# define Perl_deb_nocontext Perl_deb
+# define Perl_form_nocontext Perl_form
+# define Perl_load_module_nocontext Perl_load_module
+# define Perl_mess_nocontext Perl_mess
+# define Perl_newSVpvf_nocontext Perl_newSVpvf
+# define Perl_sv_catpvf_nocontext Perl_sv_catpvf
+# define Perl_sv_setpvf_nocontext Perl_sv_setpvf
+# define Perl_warn_nocontext Perl_warn
+# define Perl_warner_nocontext Perl_warner
+# define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
+# define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
+#endif
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/embedvar.h b/Master/tlpkg/tlperl.straw/lib/CORE/embedvar.h
new file mode 100755
index 00000000000..8f95015cc19
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/embedvar.h
@@ -0,0 +1,848 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * embedvar.h
+ *
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by embed.pl from data in embed.fnc, embed.pl,
+ * pp.sym, intrpvar.h, and perlvars.h.
+ * Any changes made here will be lost!
+ *
+ * Edit those files and run 'make regen_headers' to effect changes.
+ */
+
+/* (Doing namespace management portably in C is really gross.) */
+
+/*
+ The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
+ are supported:
+ 1) none
+ 2) MULTIPLICITY # supported for compatibility
+ 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
+
+ All other combinations of these flags are errors.
+
+ only #3 is supported directly, while #2 is a special
+ case of #3 (supported by redefining vTHX appropriately).
+*/
+
+#if defined(MULTIPLICITY)
+/* cases 2 and 3 above */
+
+# if defined(PERL_IMPLICIT_CONTEXT)
+# define vTHX aTHX
+# else
+# define vTHX PERL_GET_INTERP
+# endif
+
+#define PL_Argv (vTHX->IArgv)
+#define PL_Cmd (vTHX->ICmd)
+#define PL_DBcv (vTHX->IDBcv)
+#define PL_DBgv (vTHX->IDBgv)
+#define PL_DBline (vTHX->IDBline)
+#define PL_DBsignal (vTHX->IDBsignal)
+#define PL_DBsingle (vTHX->IDBsingle)
+#define PL_DBsub (vTHX->IDBsub)
+#define PL_DBtrace (vTHX->IDBtrace)
+#define PL_Dir (vTHX->IDir)
+#define PL_Env (vTHX->IEnv)
+#define PL_LIO (vTHX->ILIO)
+#define PL_Mem (vTHX->IMem)
+#define PL_MemParse (vTHX->IMemParse)
+#define PL_MemShared (vTHX->IMemShared)
+#define PL_OpPtr (vTHX->IOpPtr)
+#define PL_OpSlab (vTHX->IOpSlab)
+#define PL_OpSpace (vTHX->IOpSpace)
+#define PL_Proc (vTHX->IProc)
+#define PL_Sock (vTHX->ISock)
+#define PL_StdIO (vTHX->IStdIO)
+#define PL_Sv (vTHX->ISv)
+#define PL_Xpv (vTHX->IXpv)
+#define PL_amagic_generation (vTHX->Iamagic_generation)
+#define PL_an (vTHX->Ian)
+#define PL_argvgv (vTHX->Iargvgv)
+#define PL_argvout_stack (vTHX->Iargvout_stack)
+#define PL_argvoutgv (vTHX->Iargvoutgv)
+#define PL_basetime (vTHX->Ibasetime)
+#define PL_beginav (vTHX->Ibeginav)
+#define PL_beginav_save (vTHX->Ibeginav_save)
+#define PL_bitcount (vTHX->Ibitcount)
+#define PL_body_arenas (vTHX->Ibody_arenas)
+#define PL_body_roots (vTHX->Ibody_roots)
+#define PL_bodytarget (vTHX->Ibodytarget)
+#define PL_breakable_sub_gen (vTHX->Ibreakable_sub_gen)
+#define PL_checkav (vTHX->Icheckav)
+#define PL_checkav_save (vTHX->Icheckav_save)
+#define PL_chopset (vTHX->Ichopset)
+#define PL_clocktick (vTHX->Iclocktick)
+#define PL_collation_ix (vTHX->Icollation_ix)
+#define PL_collation_name (vTHX->Icollation_name)
+#define PL_collation_standard (vTHX->Icollation_standard)
+#define PL_collxfrm_base (vTHX->Icollxfrm_base)
+#define PL_collxfrm_mult (vTHX->Icollxfrm_mult)
+#define PL_colors (vTHX->Icolors)
+#define PL_colorset (vTHX->Icolorset)
+#define PL_compcv (vTHX->Icompcv)
+#define PL_compiling (vTHX->Icompiling)
+#define PL_comppad (vTHX->Icomppad)
+#define PL_comppad_name (vTHX->Icomppad_name)
+#define PL_comppad_name_fill (vTHX->Icomppad_name_fill)
+#define PL_comppad_name_floor (vTHX->Icomppad_name_floor)
+#define PL_cop_seqmax (vTHX->Icop_seqmax)
+#define PL_cryptseen (vTHX->Icryptseen)
+#define PL_curcop (vTHX->Icurcop)
+#define PL_curcopdb (vTHX->Icurcopdb)
+#define PL_curpad (vTHX->Icurpad)
+#define PL_curpm (vTHX->Icurpm)
+#define PL_curstack (vTHX->Icurstack)
+#define PL_curstackinfo (vTHX->Icurstackinfo)
+#define PL_curstash (vTHX->Icurstash)
+#define PL_curstname (vTHX->Icurstname)
+#define PL_custom_op_descs (vTHX->Icustom_op_descs)
+#define PL_custom_op_names (vTHX->Icustom_op_names)
+#define PL_cv_has_eval (vTHX->Icv_has_eval)
+#define PL_dbargs (vTHX->Idbargs)
+#define PL_debstash (vTHX->Idebstash)
+#define PL_debug (vTHX->Idebug)
+#define PL_debug_pad (vTHX->Idebug_pad)
+#define PL_def_layerlist (vTHX->Idef_layerlist)
+#define PL_defgv (vTHX->Idefgv)
+#define PL_defoutgv (vTHX->Idefoutgv)
+#define PL_defstash (vTHX->Idefstash)
+#define PL_delaymagic (vTHX->Idelaymagic)
+#define PL_destroyhook (vTHX->Idestroyhook)
+#define PL_diehook (vTHX->Idiehook)
+#define PL_dirty (vTHX->Idirty)
+#define PL_doextract (vTHX->Idoextract)
+#define PL_doswitches (vTHX->Idoswitches)
+#define PL_dowarn (vTHX->Idowarn)
+#define PL_dumper_fd (vTHX->Idumper_fd)
+#define PL_dumpindent (vTHX->Idumpindent)
+#define PL_e_script (vTHX->Ie_script)
+#define PL_efloatbuf (vTHX->Iefloatbuf)
+#define PL_efloatsize (vTHX->Iefloatsize)
+#define PL_egid (vTHX->Iegid)
+#define PL_encoding (vTHX->Iencoding)
+#define PL_endav (vTHX->Iendav)
+#define PL_envgv (vTHX->Ienvgv)
+#define PL_errgv (vTHX->Ierrgv)
+#define PL_errors (vTHX->Ierrors)
+#define PL_euid (vTHX->Ieuid)
+#define PL_eval_root (vTHX->Ieval_root)
+#define PL_eval_start (vTHX->Ieval_start)
+#define PL_evalseq (vTHX->Ievalseq)
+#define PL_exit_flags (vTHX->Iexit_flags)
+#define PL_exitlist (vTHX->Iexitlist)
+#define PL_exitlistlen (vTHX->Iexitlistlen)
+#define PL_fdpid (vTHX->Ifdpid)
+#define PL_filemode (vTHX->Ifilemode)
+#define PL_firstgv (vTHX->Ifirstgv)
+#define PL_forkprocess (vTHX->Iforkprocess)
+#define PL_formfeed (vTHX->Iformfeed)
+#define PL_formtarget (vTHX->Iformtarget)
+#define PL_generation (vTHX->Igeneration)
+#define PL_gensym (vTHX->Igensym)
+#define PL_gid (vTHX->Igid)
+#define PL_glob_index (vTHX->Iglob_index)
+#define PL_globalstash (vTHX->Iglobalstash)
+#define PL_hash_seed (vTHX->Ihash_seed)
+#define PL_hintgv (vTHX->Ihintgv)
+#define PL_hints (vTHX->Ihints)
+#define PL_hv_fetch_ent_mh (vTHX->Ihv_fetch_ent_mh)
+#define PL_in_clean_all (vTHX->Iin_clean_all)
+#define PL_in_clean_objs (vTHX->Iin_clean_objs)
+#define PL_in_eval (vTHX->Iin_eval)
+#define PL_in_load_module (vTHX->Iin_load_module)
+#define PL_incgv (vTHX->Iincgv)
+#define PL_initav (vTHX->Iinitav)
+#define PL_inplace (vTHX->Iinplace)
+#define PL_isarev (vTHX->Iisarev)
+#define PL_known_layers (vTHX->Iknown_layers)
+#define PL_last_in_gv (vTHX->Ilast_in_gv)
+#define PL_last_swash_hv (vTHX->Ilast_swash_hv)
+#define PL_last_swash_key (vTHX->Ilast_swash_key)
+#define PL_last_swash_klen (vTHX->Ilast_swash_klen)
+#define PL_last_swash_slen (vTHX->Ilast_swash_slen)
+#define PL_last_swash_tmps (vTHX->Ilast_swash_tmps)
+#define PL_lastfd (vTHX->Ilastfd)
+#define PL_lastgotoprobe (vTHX->Ilastgotoprobe)
+#define PL_lastscream (vTHX->Ilastscream)
+#define PL_laststatval (vTHX->Ilaststatval)
+#define PL_laststype (vTHX->Ilaststype)
+#define PL_localizing (vTHX->Ilocalizing)
+#define PL_localpatches (vTHX->Ilocalpatches)
+#define PL_lockhook (vTHX->Ilockhook)
+#define PL_madskills (vTHX->Imadskills)
+#define PL_main_cv (vTHX->Imain_cv)
+#define PL_main_root (vTHX->Imain_root)
+#define PL_main_start (vTHX->Imain_start)
+#define PL_mainstack (vTHX->Imainstack)
+#define PL_markstack (vTHX->Imarkstack)
+#define PL_markstack_max (vTHX->Imarkstack_max)
+#define PL_markstack_ptr (vTHX->Imarkstack_ptr)
+#define PL_max_intro_pending (vTHX->Imax_intro_pending)
+#define PL_maxo (vTHX->Imaxo)
+#define PL_maxscream (vTHX->Imaxscream)
+#define PL_maxsysfd (vTHX->Imaxsysfd)
+#define PL_memory_debug_header (vTHX->Imemory_debug_header)
+#define PL_mess_sv (vTHX->Imess_sv)
+#define PL_min_intro_pending (vTHX->Imin_intro_pending)
+#define PL_minus_E (vTHX->Iminus_E)
+#define PL_minus_F (vTHX->Iminus_F)
+#define PL_minus_a (vTHX->Iminus_a)
+#define PL_minus_c (vTHX->Iminus_c)
+#define PL_minus_l (vTHX->Iminus_l)
+#define PL_minus_n (vTHX->Iminus_n)
+#define PL_minus_p (vTHX->Iminus_p)
+#define PL_modcount (vTHX->Imodcount)
+#define PL_modglobal (vTHX->Imodglobal)
+#define PL_my_cxt_keys (vTHX->Imy_cxt_keys)
+#define PL_my_cxt_list (vTHX->Imy_cxt_list)
+#define PL_my_cxt_size (vTHX->Imy_cxt_size)
+#define PL_na (vTHX->Ina)
+#define PL_nice_chunk (vTHX->Inice_chunk)
+#define PL_nice_chunk_size (vTHX->Inice_chunk_size)
+#define PL_nomemok (vTHX->Inomemok)
+#define PL_numeric_local (vTHX->Inumeric_local)
+#define PL_numeric_name (vTHX->Inumeric_name)
+#define PL_numeric_radix_sv (vTHX->Inumeric_radix_sv)
+#define PL_numeric_standard (vTHX->Inumeric_standard)
+#define PL_ofs_sv (vTHX->Iofs_sv)
+#define PL_oldname (vTHX->Ioldname)
+#define PL_op (vTHX->Iop)
+#define PL_op_mask (vTHX->Iop_mask)
+#define PL_opsave (vTHX->Iopsave)
+#define PL_origalen (vTHX->Iorigalen)
+#define PL_origargc (vTHX->Iorigargc)
+#define PL_origargv (vTHX->Iorigargv)
+#define PL_origenviron (vTHX->Iorigenviron)
+#define PL_origfilename (vTHX->Iorigfilename)
+#define PL_ors_sv (vTHX->Iors_sv)
+#define PL_osname (vTHX->Iosname)
+#define PL_pad_reset_pending (vTHX->Ipad_reset_pending)
+#define PL_padix (vTHX->Ipadix)
+#define PL_padix_floor (vTHX->Ipadix_floor)
+#define PL_parser (vTHX->Iparser)
+#define PL_patchlevel (vTHX->Ipatchlevel)
+#define PL_peepp (vTHX->Ipeepp)
+#define PL_perl_destruct_level (vTHX->Iperl_destruct_level)
+#define PL_perldb (vTHX->Iperldb)
+#define PL_perlio (vTHX->Iperlio)
+#define PL_pidstatus (vTHX->Ipidstatus)
+#define PL_ppid (vTHX->Ippid)
+#define PL_preambleav (vTHX->Ipreambleav)
+#define PL_preprocess (vTHX->Ipreprocess)
+#define PL_profiledata (vTHX->Iprofiledata)
+#define PL_psig_name (vTHX->Ipsig_name)
+#define PL_psig_pend (vTHX->Ipsig_pend)
+#define PL_psig_ptr (vTHX->Ipsig_ptr)
+#define PL_ptr_table (vTHX->Iptr_table)
+#define PL_reentrant_buffer (vTHX->Ireentrant_buffer)
+#define PL_reentrant_retint (vTHX->Ireentrant_retint)
+#define PL_reg_state (vTHX->Ireg_state)
+#define PL_regdummy (vTHX->Iregdummy)
+#define PL_regex_pad (vTHX->Iregex_pad)
+#define PL_regex_padav (vTHX->Iregex_padav)
+#define PL_reginterp_cnt (vTHX->Ireginterp_cnt)
+#define PL_registered_mros (vTHX->Iregistered_mros)
+#define PL_regmatch_slab (vTHX->Iregmatch_slab)
+#define PL_regmatch_state (vTHX->Iregmatch_state)
+#define PL_rehash_seed (vTHX->Irehash_seed)
+#define PL_rehash_seed_set (vTHX->Irehash_seed_set)
+#define PL_replgv (vTHX->Ireplgv)
+#define PL_restartop (vTHX->Irestartop)
+#define PL_rs (vTHX->Irs)
+#define PL_runops (vTHX->Irunops)
+#define PL_savebegin (vTHX->Isavebegin)
+#define PL_savestack (vTHX->Isavestack)
+#define PL_savestack_ix (vTHX->Isavestack_ix)
+#define PL_savestack_max (vTHX->Isavestack_max)
+#define PL_sawampersand (vTHX->Isawampersand)
+#define PL_scopestack (vTHX->Iscopestack)
+#define PL_scopestack_ix (vTHX->Iscopestack_ix)
+#define PL_scopestack_max (vTHX->Iscopestack_max)
+#define PL_screamfirst (vTHX->Iscreamfirst)
+#define PL_screamnext (vTHX->Iscreamnext)
+#define PL_secondgv (vTHX->Isecondgv)
+#define PL_sharehook (vTHX->Isharehook)
+#define PL_sig_pending (vTHX->Isig_pending)
+#define PL_sighandlerp (vTHX->Isighandlerp)
+#define PL_signals (vTHX->Isignals)
+#define PL_slab_count (vTHX->Islab_count)
+#define PL_slabs (vTHX->Islabs)
+#define PL_sort_RealCmp (vTHX->Isort_RealCmp)
+#define PL_sortcop (vTHX->Isortcop)
+#define PL_sortstash (vTHX->Isortstash)
+#define PL_splitstr (vTHX->Isplitstr)
+#define PL_srand_called (vTHX->Isrand_called)
+#define PL_stack_base (vTHX->Istack_base)
+#define PL_stack_max (vTHX->Istack_max)
+#define PL_stack_sp (vTHX->Istack_sp)
+#define PL_start_env (vTHX->Istart_env)
+#define PL_stashcache (vTHX->Istashcache)
+#define PL_statbuf (vTHX->Istatbuf)
+#define PL_statcache (vTHX->Istatcache)
+#define PL_statgv (vTHX->Istatgv)
+#define PL_statname (vTHX->Istatname)
+#define PL_statusvalue (vTHX->Istatusvalue)
+#define PL_statusvalue_posix (vTHX->Istatusvalue_posix)
+#define PL_statusvalue_vms (vTHX->Istatusvalue_vms)
+#define PL_stderrgv (vTHX->Istderrgv)
+#define PL_stdingv (vTHX->Istdingv)
+#define PL_strtab (vTHX->Istrtab)
+#define PL_sub_generation (vTHX->Isub_generation)
+#define PL_subline (vTHX->Isubline)
+#define PL_subname (vTHX->Isubname)
+#define PL_sv_arenaroot (vTHX->Isv_arenaroot)
+#define PL_sv_count (vTHX->Isv_count)
+#define PL_sv_no (vTHX->Isv_no)
+#define PL_sv_objcount (vTHX->Isv_objcount)
+#define PL_sv_root (vTHX->Isv_root)
+#define PL_sv_serial (vTHX->Isv_serial)
+#define PL_sv_undef (vTHX->Isv_undef)
+#define PL_sv_yes (vTHX->Isv_yes)
+#define PL_sys_intern (vTHX->Isys_intern)
+#define PL_taint_warn (vTHX->Itaint_warn)
+#define PL_tainted (vTHX->Itainted)
+#define PL_tainting (vTHX->Itainting)
+#define PL_threadhook (vTHX->Ithreadhook)
+#define PL_timesbuf (vTHX->Itimesbuf)
+#define PL_tmps_floor (vTHX->Itmps_floor)
+#define PL_tmps_ix (vTHX->Itmps_ix)
+#define PL_tmps_max (vTHX->Itmps_max)
+#define PL_tmps_stack (vTHX->Itmps_stack)
+#define PL_top_env (vTHX->Itop_env)
+#define PL_toptarget (vTHX->Itoptarget)
+#define PL_uid (vTHX->Iuid)
+#define PL_unicode (vTHX->Iunicode)
+#define PL_unitcheckav (vTHX->Iunitcheckav)
+#define PL_unitcheckav_save (vTHX->Iunitcheckav_save)
+#define PL_unlockhook (vTHX->Iunlockhook)
+#define PL_unsafe (vTHX->Iunsafe)
+#define PL_utf8_alnum (vTHX->Iutf8_alnum)
+#define PL_utf8_alnumc (vTHX->Iutf8_alnumc)
+#define PL_utf8_alpha (vTHX->Iutf8_alpha)
+#define PL_utf8_ascii (vTHX->Iutf8_ascii)
+#define PL_utf8_cntrl (vTHX->Iutf8_cntrl)
+#define PL_utf8_digit (vTHX->Iutf8_digit)
+#define PL_utf8_graph (vTHX->Iutf8_graph)
+#define PL_utf8_idcont (vTHX->Iutf8_idcont)
+#define PL_utf8_idstart (vTHX->Iutf8_idstart)
+#define PL_utf8_lower (vTHX->Iutf8_lower)
+#define PL_utf8_mark (vTHX->Iutf8_mark)
+#define PL_utf8_print (vTHX->Iutf8_print)
+#define PL_utf8_punct (vTHX->Iutf8_punct)
+#define PL_utf8_space (vTHX->Iutf8_space)
+#define PL_utf8_tofold (vTHX->Iutf8_tofold)
+#define PL_utf8_tolower (vTHX->Iutf8_tolower)
+#define PL_utf8_totitle (vTHX->Iutf8_totitle)
+#define PL_utf8_toupper (vTHX->Iutf8_toupper)
+#define PL_utf8_upper (vTHX->Iutf8_upper)
+#define PL_utf8_xdigit (vTHX->Iutf8_xdigit)
+#define PL_utf8cache (vTHX->Iutf8cache)
+#define PL_utf8locale (vTHX->Iutf8locale)
+#define PL_warnhook (vTHX->Iwarnhook)
+#define PL_watchaddr (vTHX->Iwatchaddr)
+#define PL_watchok (vTHX->Iwatchok)
+#define PL_xmlfp (vTHX->Ixmlfp)
+
+#else /* !MULTIPLICITY */
+
+/* case 1 above */
+
+#define PL_IArgv PL_Argv
+#define PL_ICmd PL_Cmd
+#define PL_IDBcv PL_DBcv
+#define PL_IDBgv PL_DBgv
+#define PL_IDBline PL_DBline
+#define PL_IDBsignal PL_DBsignal
+#define PL_IDBsingle PL_DBsingle
+#define PL_IDBsub PL_DBsub
+#define PL_IDBtrace PL_DBtrace
+#define PL_IDir PL_Dir
+#define PL_IEnv PL_Env
+#define PL_ILIO PL_LIO
+#define PL_IMem PL_Mem
+#define PL_IMemParse PL_MemParse
+#define PL_IMemShared PL_MemShared
+#define PL_IOpPtr PL_OpPtr
+#define PL_IOpSlab PL_OpSlab
+#define PL_IOpSpace PL_OpSpace
+#define PL_IProc PL_Proc
+#define PL_ISock PL_Sock
+#define PL_IStdIO PL_StdIO
+#define PL_ISv PL_Sv
+#define PL_IXpv PL_Xpv
+#define PL_Iamagic_generation PL_amagic_generation
+#define PL_Ian PL_an
+#define PL_Iargvgv PL_argvgv
+#define PL_Iargvout_stack PL_argvout_stack
+#define PL_Iargvoutgv PL_argvoutgv
+#define PL_Ibasetime PL_basetime
+#define PL_Ibeginav PL_beginav
+#define PL_Ibeginav_save PL_beginav_save
+#define PL_Ibitcount PL_bitcount
+#define PL_Ibody_arenas PL_body_arenas
+#define PL_Ibody_roots PL_body_roots
+#define PL_Ibodytarget PL_bodytarget
+#define PL_Ibreakable_sub_gen PL_breakable_sub_gen
+#define PL_Icheckav PL_checkav
+#define PL_Icheckav_save PL_checkav_save
+#define PL_Ichopset PL_chopset
+#define PL_Iclocktick PL_clocktick
+#define PL_Icollation_ix PL_collation_ix
+#define PL_Icollation_name PL_collation_name
+#define PL_Icollation_standard PL_collation_standard
+#define PL_Icollxfrm_base PL_collxfrm_base
+#define PL_Icollxfrm_mult PL_collxfrm_mult
+#define PL_Icolors PL_colors
+#define PL_Icolorset PL_colorset
+#define PL_Icompcv PL_compcv
+#define PL_Icompiling PL_compiling
+#define PL_Icomppad PL_comppad
+#define PL_Icomppad_name PL_comppad_name
+#define PL_Icomppad_name_fill PL_comppad_name_fill
+#define PL_Icomppad_name_floor PL_comppad_name_floor
+#define PL_Icop_seqmax PL_cop_seqmax
+#define PL_Icryptseen PL_cryptseen
+#define PL_Icurcop PL_curcop
+#define PL_Icurcopdb PL_curcopdb
+#define PL_Icurpad PL_curpad
+#define PL_Icurpm PL_curpm
+#define PL_Icurstack PL_curstack
+#define PL_Icurstackinfo PL_curstackinfo
+#define PL_Icurstash PL_curstash
+#define PL_Icurstname PL_curstname
+#define PL_Icustom_op_descs PL_custom_op_descs
+#define PL_Icustom_op_names PL_custom_op_names
+#define PL_Icv_has_eval PL_cv_has_eval
+#define PL_Idbargs PL_dbargs
+#define PL_Idebstash PL_debstash
+#define PL_Idebug PL_debug
+#define PL_Idebug_pad PL_debug_pad
+#define PL_Idef_layerlist PL_def_layerlist
+#define PL_Idefgv PL_defgv
+#define PL_Idefoutgv PL_defoutgv
+#define PL_Idefstash PL_defstash
+#define PL_Idelaymagic PL_delaymagic
+#define PL_Idestroyhook PL_destroyhook
+#define PL_Idiehook PL_diehook
+#define PL_Idirty PL_dirty
+#define PL_Idoextract PL_doextract
+#define PL_Idoswitches PL_doswitches
+#define PL_Idowarn PL_dowarn
+#define PL_Idumper_fd PL_dumper_fd
+#define PL_Idumpindent PL_dumpindent
+#define PL_Ie_script PL_e_script
+#define PL_Iefloatbuf PL_efloatbuf
+#define PL_Iefloatsize PL_efloatsize
+#define PL_Iegid PL_egid
+#define PL_Iencoding PL_encoding
+#define PL_Iendav PL_endav
+#define PL_Ienvgv PL_envgv
+#define PL_Ierrgv PL_errgv
+#define PL_Ierrors PL_errors
+#define PL_Ieuid PL_euid
+#define PL_Ieval_root PL_eval_root
+#define PL_Ieval_start PL_eval_start
+#define PL_Ievalseq PL_evalseq
+#define PL_Iexit_flags PL_exit_flags
+#define PL_Iexitlist PL_exitlist
+#define PL_Iexitlistlen PL_exitlistlen
+#define PL_Ifdpid PL_fdpid
+#define PL_Ifilemode PL_filemode
+#define PL_Ifirstgv PL_firstgv
+#define PL_Iforkprocess PL_forkprocess
+#define PL_Iformfeed PL_formfeed
+#define PL_Iformtarget PL_formtarget
+#define PL_Igeneration PL_generation
+#define PL_Igensym PL_gensym
+#define PL_Igid PL_gid
+#define PL_Iglob_index PL_glob_index
+#define PL_Iglobalstash PL_globalstash
+#define PL_Ihash_seed PL_hash_seed
+#define PL_Ihintgv PL_hintgv
+#define PL_Ihints PL_hints
+#define PL_Ihv_fetch_ent_mh PL_hv_fetch_ent_mh
+#define PL_Iin_clean_all PL_in_clean_all
+#define PL_Iin_clean_objs PL_in_clean_objs
+#define PL_Iin_eval PL_in_eval
+#define PL_Iin_load_module PL_in_load_module
+#define PL_Iincgv PL_incgv
+#define PL_Iinitav PL_initav
+#define PL_Iinplace PL_inplace
+#define PL_Iisarev PL_isarev
+#define PL_Iknown_layers PL_known_layers
+#define PL_Ilast_in_gv PL_last_in_gv
+#define PL_Ilast_swash_hv PL_last_swash_hv
+#define PL_Ilast_swash_key PL_last_swash_key
+#define PL_Ilast_swash_klen PL_last_swash_klen
+#define PL_Ilast_swash_slen PL_last_swash_slen
+#define PL_Ilast_swash_tmps PL_last_swash_tmps
+#define PL_Ilastfd PL_lastfd
+#define PL_Ilastgotoprobe PL_lastgotoprobe
+#define PL_Ilastscream PL_lastscream
+#define PL_Ilaststatval PL_laststatval
+#define PL_Ilaststype PL_laststype
+#define PL_Ilocalizing PL_localizing
+#define PL_Ilocalpatches PL_localpatches
+#define PL_Ilockhook PL_lockhook
+#define PL_Imadskills PL_madskills
+#define PL_Imain_cv PL_main_cv
+#define PL_Imain_root PL_main_root
+#define PL_Imain_start PL_main_start
+#define PL_Imainstack PL_mainstack
+#define PL_Imarkstack PL_markstack
+#define PL_Imarkstack_max PL_markstack_max
+#define PL_Imarkstack_ptr PL_markstack_ptr
+#define PL_Imax_intro_pending PL_max_intro_pending
+#define PL_Imaxo PL_maxo
+#define PL_Imaxscream PL_maxscream
+#define PL_Imaxsysfd PL_maxsysfd
+#define PL_Imemory_debug_header PL_memory_debug_header
+#define PL_Imess_sv PL_mess_sv
+#define PL_Imin_intro_pending PL_min_intro_pending
+#define PL_Iminus_E PL_minus_E
+#define PL_Iminus_F PL_minus_F
+#define PL_Iminus_a PL_minus_a
+#define PL_Iminus_c PL_minus_c
+#define PL_Iminus_l PL_minus_l
+#define PL_Iminus_n PL_minus_n
+#define PL_Iminus_p PL_minus_p
+#define PL_Imodcount PL_modcount
+#define PL_Imodglobal PL_modglobal
+#define PL_Imy_cxt_keys PL_my_cxt_keys
+#define PL_Imy_cxt_list PL_my_cxt_list
+#define PL_Imy_cxt_size PL_my_cxt_size
+#define PL_Ina PL_na
+#define PL_Inice_chunk PL_nice_chunk
+#define PL_Inice_chunk_size PL_nice_chunk_size
+#define PL_Inomemok PL_nomemok
+#define PL_Inumeric_local PL_numeric_local
+#define PL_Inumeric_name PL_numeric_name
+#define PL_Inumeric_radix_sv PL_numeric_radix_sv
+#define PL_Inumeric_standard PL_numeric_standard
+#define PL_Iofs_sv PL_ofs_sv
+#define PL_Ioldname PL_oldname
+#define PL_Iop PL_op
+#define PL_Iop_mask PL_op_mask
+#define PL_Iopsave PL_opsave
+#define PL_Iorigalen PL_origalen
+#define PL_Iorigargc PL_origargc
+#define PL_Iorigargv PL_origargv
+#define PL_Iorigenviron PL_origenviron
+#define PL_Iorigfilename PL_origfilename
+#define PL_Iors_sv PL_ors_sv
+#define PL_Iosname PL_osname
+#define PL_Ipad_reset_pending PL_pad_reset_pending
+#define PL_Ipadix PL_padix
+#define PL_Ipadix_floor PL_padix_floor
+#define PL_Iparser PL_parser
+#define PL_Ipatchlevel PL_patchlevel
+#define PL_Ipeepp PL_peepp
+#define PL_Iperl_destruct_level PL_perl_destruct_level
+#define PL_Iperldb PL_perldb
+#define PL_Iperlio PL_perlio
+#define PL_Ipidstatus PL_pidstatus
+#define PL_Ippid PL_ppid
+#define PL_Ipreambleav PL_preambleav
+#define PL_Ipreprocess PL_preprocess
+#define PL_Iprofiledata PL_profiledata
+#define PL_Ipsig_name PL_psig_name
+#define PL_Ipsig_pend PL_psig_pend
+#define PL_Ipsig_ptr PL_psig_ptr
+#define PL_Iptr_table PL_ptr_table
+#define PL_Ireentrant_buffer PL_reentrant_buffer
+#define PL_Ireentrant_retint PL_reentrant_retint
+#define PL_Ireg_state PL_reg_state
+#define PL_Iregdummy PL_regdummy
+#define PL_Iregex_pad PL_regex_pad
+#define PL_Iregex_padav PL_regex_padav
+#define PL_Ireginterp_cnt PL_reginterp_cnt
+#define PL_Iregistered_mros PL_registered_mros
+#define PL_Iregmatch_slab PL_regmatch_slab
+#define PL_Iregmatch_state PL_regmatch_state
+#define PL_Irehash_seed PL_rehash_seed
+#define PL_Irehash_seed_set PL_rehash_seed_set
+#define PL_Ireplgv PL_replgv
+#define PL_Irestartop PL_restartop
+#define PL_Irs PL_rs
+#define PL_Irunops PL_runops
+#define PL_Isavebegin PL_savebegin
+#define PL_Isavestack PL_savestack
+#define PL_Isavestack_ix PL_savestack_ix
+#define PL_Isavestack_max PL_savestack_max
+#define PL_Isawampersand PL_sawampersand
+#define PL_Iscopestack PL_scopestack
+#define PL_Iscopestack_ix PL_scopestack_ix
+#define PL_Iscopestack_max PL_scopestack_max
+#define PL_Iscreamfirst PL_screamfirst
+#define PL_Iscreamnext PL_screamnext
+#define PL_Isecondgv PL_secondgv
+#define PL_Isharehook PL_sharehook
+#define PL_Isig_pending PL_sig_pending
+#define PL_Isighandlerp PL_sighandlerp
+#define PL_Isignals PL_signals
+#define PL_Islab_count PL_slab_count
+#define PL_Islabs PL_slabs
+#define PL_Isort_RealCmp PL_sort_RealCmp
+#define PL_Isortcop PL_sortcop
+#define PL_Isortstash PL_sortstash
+#define PL_Isplitstr PL_splitstr
+#define PL_Isrand_called PL_srand_called
+#define PL_Istack_base PL_stack_base
+#define PL_Istack_max PL_stack_max
+#define PL_Istack_sp PL_stack_sp
+#define PL_Istart_env PL_start_env
+#define PL_Istashcache PL_stashcache
+#define PL_Istatbuf PL_statbuf
+#define PL_Istatcache PL_statcache
+#define PL_Istatgv PL_statgv
+#define PL_Istatname PL_statname
+#define PL_Istatusvalue PL_statusvalue
+#define PL_Istatusvalue_posix PL_statusvalue_posix
+#define PL_Istatusvalue_vms PL_statusvalue_vms
+#define PL_Istderrgv PL_stderrgv
+#define PL_Istdingv PL_stdingv
+#define PL_Istrtab PL_strtab
+#define PL_Isub_generation PL_sub_generation
+#define PL_Isubline PL_subline
+#define PL_Isubname PL_subname
+#define PL_Isv_arenaroot PL_sv_arenaroot
+#define PL_Isv_count PL_sv_count
+#define PL_Isv_no PL_sv_no
+#define PL_Isv_objcount PL_sv_objcount
+#define PL_Isv_root PL_sv_root
+#define PL_Isv_serial PL_sv_serial
+#define PL_Isv_undef PL_sv_undef
+#define PL_Isv_yes PL_sv_yes
+#define PL_Isys_intern PL_sys_intern
+#define PL_Itaint_warn PL_taint_warn
+#define PL_Itainted PL_tainted
+#define PL_Itainting PL_tainting
+#define PL_Ithreadhook PL_threadhook
+#define PL_Itimesbuf PL_timesbuf
+#define PL_Itmps_floor PL_tmps_floor
+#define PL_Itmps_ix PL_tmps_ix
+#define PL_Itmps_max PL_tmps_max
+#define PL_Itmps_stack PL_tmps_stack
+#define PL_Itop_env PL_top_env
+#define PL_Itoptarget PL_toptarget
+#define PL_Iuid PL_uid
+#define PL_Iunicode PL_unicode
+#define PL_Iunitcheckav PL_unitcheckav
+#define PL_Iunitcheckav_save PL_unitcheckav_save
+#define PL_Iunlockhook PL_unlockhook
+#define PL_Iunsafe PL_unsafe
+#define PL_Iutf8_alnum PL_utf8_alnum
+#define PL_Iutf8_alnumc PL_utf8_alnumc
+#define PL_Iutf8_alpha PL_utf8_alpha
+#define PL_Iutf8_ascii PL_utf8_ascii
+#define PL_Iutf8_cntrl PL_utf8_cntrl
+#define PL_Iutf8_digit PL_utf8_digit
+#define PL_Iutf8_graph PL_utf8_graph
+#define PL_Iutf8_idcont PL_utf8_idcont
+#define PL_Iutf8_idstart PL_utf8_idstart
+#define PL_Iutf8_lower PL_utf8_lower
+#define PL_Iutf8_mark PL_utf8_mark
+#define PL_Iutf8_print PL_utf8_print
+#define PL_Iutf8_punct PL_utf8_punct
+#define PL_Iutf8_space PL_utf8_space
+#define PL_Iutf8_tofold PL_utf8_tofold
+#define PL_Iutf8_tolower PL_utf8_tolower
+#define PL_Iutf8_totitle PL_utf8_totitle
+#define PL_Iutf8_toupper PL_utf8_toupper
+#define PL_Iutf8_upper PL_utf8_upper
+#define PL_Iutf8_xdigit PL_utf8_xdigit
+#define PL_Iutf8cache PL_utf8cache
+#define PL_Iutf8locale PL_utf8locale
+#define PL_Iwarnhook PL_warnhook
+#define PL_Iwatchaddr PL_watchaddr
+#define PL_Iwatchok PL_watchok
+#define PL_Ixmlfp PL_xmlfp
+
+
+#endif /* MULTIPLICITY */
+
+#if defined(PERL_GLOBAL_STRUCT)
+
+#define PL_No (my_vars->GNo)
+#define PL_GNo (my_vars->GNo)
+#define PL_Yes (my_vars->GYes)
+#define PL_GYes (my_vars->GYes)
+#define PL_appctx (my_vars->Gappctx)
+#define PL_Gappctx (my_vars->Gappctx)
+#define PL_check (my_vars->Gcheck)
+#define PL_Gcheck (my_vars->Gcheck)
+#define PL_csighandlerp (my_vars->Gcsighandlerp)
+#define PL_Gcsighandlerp (my_vars->Gcsighandlerp)
+#define PL_curinterp (my_vars->Gcurinterp)
+#define PL_Gcurinterp (my_vars->Gcurinterp)
+#define PL_do_undump (my_vars->Gdo_undump)
+#define PL_Gdo_undump (my_vars->Gdo_undump)
+#define PL_dollarzero_mutex (my_vars->Gdollarzero_mutex)
+#define PL_Gdollarzero_mutex (my_vars->Gdollarzero_mutex)
+#define PL_fold_locale (my_vars->Gfold_locale)
+#define PL_Gfold_locale (my_vars->Gfold_locale)
+#define PL_global_struct_size (my_vars->Gglobal_struct_size)
+#define PL_Gglobal_struct_size (my_vars->Gglobal_struct_size)
+#define PL_hexdigit (my_vars->Ghexdigit)
+#define PL_Ghexdigit (my_vars->Ghexdigit)
+#define PL_hints_mutex (my_vars->Ghints_mutex)
+#define PL_Ghints_mutex (my_vars->Ghints_mutex)
+#define PL_interp_size (my_vars->Ginterp_size)
+#define PL_Ginterp_size (my_vars->Ginterp_size)
+#define PL_interp_size_5_10_0 (my_vars->Ginterp_size_5_10_0)
+#define PL_Ginterp_size_5_10_0 (my_vars->Ginterp_size_5_10_0)
+#define PL_malloc_mutex (my_vars->Gmalloc_mutex)
+#define PL_Gmalloc_mutex (my_vars->Gmalloc_mutex)
+#define PL_mmap_page_size (my_vars->Gmmap_page_size)
+#define PL_Gmmap_page_size (my_vars->Gmmap_page_size)
+#define PL_my_ctx_mutex (my_vars->Gmy_ctx_mutex)
+#define PL_Gmy_ctx_mutex (my_vars->Gmy_ctx_mutex)
+#define PL_my_cxt_index (my_vars->Gmy_cxt_index)
+#define PL_Gmy_cxt_index (my_vars->Gmy_cxt_index)
+#define PL_op_mutex (my_vars->Gop_mutex)
+#define PL_Gop_mutex (my_vars->Gop_mutex)
+#define PL_op_seq (my_vars->Gop_seq)
+#define PL_Gop_seq (my_vars->Gop_seq)
+#define PL_op_sequence (my_vars->Gop_sequence)
+#define PL_Gop_sequence (my_vars->Gop_sequence)
+#define PL_patleave (my_vars->Gpatleave)
+#define PL_Gpatleave (my_vars->Gpatleave)
+#define PL_perlio_debug_fd (my_vars->Gperlio_debug_fd)
+#define PL_Gperlio_debug_fd (my_vars->Gperlio_debug_fd)
+#define PL_perlio_fd_refcnt (my_vars->Gperlio_fd_refcnt)
+#define PL_Gperlio_fd_refcnt (my_vars->Gperlio_fd_refcnt)
+#define PL_perlio_fd_refcnt_size (my_vars->Gperlio_fd_refcnt_size)
+#define PL_Gperlio_fd_refcnt_size (my_vars->Gperlio_fd_refcnt_size)
+#define PL_perlio_mutex (my_vars->Gperlio_mutex)
+#define PL_Gperlio_mutex (my_vars->Gperlio_mutex)
+#define PL_ppaddr (my_vars->Gppaddr)
+#define PL_Gppaddr (my_vars->Gppaddr)
+#define PL_revision (my_vars->Grevision)
+#define PL_Grevision (my_vars->Grevision)
+#define PL_runops_dbg (my_vars->Grunops_dbg)
+#define PL_Grunops_dbg (my_vars->Grunops_dbg)
+#define PL_runops_std (my_vars->Grunops_std)
+#define PL_Grunops_std (my_vars->Grunops_std)
+#define PL_sh_path (my_vars->Gsh_path)
+#define PL_Gsh_path (my_vars->Gsh_path)
+#define PL_sig_defaulting (my_vars->Gsig_defaulting)
+#define PL_Gsig_defaulting (my_vars->Gsig_defaulting)
+#define PL_sig_handlers_initted (my_vars->Gsig_handlers_initted)
+#define PL_Gsig_handlers_initted (my_vars->Gsig_handlers_initted)
+#define PL_sig_ignoring (my_vars->Gsig_ignoring)
+#define PL_Gsig_ignoring (my_vars->Gsig_ignoring)
+#define PL_sig_sv (my_vars->Gsig_sv)
+#define PL_Gsig_sv (my_vars->Gsig_sv)
+#define PL_sig_trapped (my_vars->Gsig_trapped)
+#define PL_Gsig_trapped (my_vars->Gsig_trapped)
+#define PL_sigfpe_saved (my_vars->Gsigfpe_saved)
+#define PL_Gsigfpe_saved (my_vars->Gsigfpe_saved)
+#define PL_subversion (my_vars->Gsubversion)
+#define PL_Gsubversion (my_vars->Gsubversion)
+#define PL_sv_placeholder (my_vars->Gsv_placeholder)
+#define PL_Gsv_placeholder (my_vars->Gsv_placeholder)
+#define PL_thr_key (my_vars->Gthr_key)
+#define PL_Gthr_key (my_vars->Gthr_key)
+#define PL_timesbase (my_vars->Gtimesbase)
+#define PL_Gtimesbase (my_vars->Gtimesbase)
+#define PL_use_safe_putenv (my_vars->Guse_safe_putenv)
+#define PL_Guse_safe_putenv (my_vars->Guse_safe_putenv)
+#define PL_version (my_vars->Gversion)
+#define PL_Gversion (my_vars->Gversion)
+#define PL_veto_cleanup (my_vars->Gveto_cleanup)
+#define PL_Gveto_cleanup (my_vars->Gveto_cleanup)
+#define PL_watch_pvx (my_vars->Gwatch_pvx)
+#define PL_Gwatch_pvx (my_vars->Gwatch_pvx)
+
+#else /* !PERL_GLOBAL_STRUCT */
+
+#define PL_GNo PL_No
+#define PL_GYes PL_Yes
+#define PL_Gappctx PL_appctx
+#define PL_Gcheck PL_check
+#define PL_Gcsighandlerp PL_csighandlerp
+#define PL_Gcurinterp PL_curinterp
+#define PL_Gdo_undump PL_do_undump
+#define PL_Gdollarzero_mutex PL_dollarzero_mutex
+#define PL_Gfold_locale PL_fold_locale
+#define PL_Gglobal_struct_size PL_global_struct_size
+#define PL_Ghexdigit PL_hexdigit
+#define PL_Ghints_mutex PL_hints_mutex
+#define PL_Ginterp_size PL_interp_size
+#define PL_Ginterp_size_5_10_0 PL_interp_size_5_10_0
+#define PL_Gmalloc_mutex PL_malloc_mutex
+#define PL_Gmmap_page_size PL_mmap_page_size
+#define PL_Gmy_ctx_mutex PL_my_ctx_mutex
+#define PL_Gmy_cxt_index PL_my_cxt_index
+#define PL_Gop_mutex PL_op_mutex
+#define PL_Gop_seq PL_op_seq
+#define PL_Gop_sequence PL_op_sequence
+#define PL_Gpatleave PL_patleave
+#define PL_Gperlio_debug_fd PL_perlio_debug_fd
+#define PL_Gperlio_fd_refcnt PL_perlio_fd_refcnt
+#define PL_Gperlio_fd_refcnt_size PL_perlio_fd_refcnt_size
+#define PL_Gperlio_mutex PL_perlio_mutex
+#define PL_Gppaddr PL_ppaddr
+#define PL_Grevision PL_revision
+#define PL_Grunops_dbg PL_runops_dbg
+#define PL_Grunops_std PL_runops_std
+#define PL_Gsh_path PL_sh_path
+#define PL_Gsig_defaulting PL_sig_defaulting
+#define PL_Gsig_handlers_initted PL_sig_handlers_initted
+#define PL_Gsig_ignoring PL_sig_ignoring
+#define PL_Gsig_sv PL_sig_sv
+#define PL_Gsig_trapped PL_sig_trapped
+#define PL_Gsigfpe_saved PL_sigfpe_saved
+#define PL_Gsubversion PL_subversion
+#define PL_Gsv_placeholder PL_sv_placeholder
+#define PL_Gthr_key PL_thr_key
+#define PL_Gtimesbase PL_timesbase
+#define PL_Guse_safe_putenv PL_use_safe_putenv
+#define PL_Gversion PL_version
+#define PL_Gveto_cleanup PL_veto_cleanup
+#define PL_Gwatch_pvx PL_watch_pvx
+
+#endif /* PERL_GLOBAL_STRUCT */
+
+#ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
+
+#define DBassertion PL_DBassertion
+#define DBsingle PL_DBsingle
+#define DBsub PL_DBsub
+#define compiling PL_compiling
+#define curcop PL_curcop
+#define curstash PL_curstash
+#define debstash PL_debstash
+#define defgv PL_defgv
+#define diehook PL_diehook
+#define dirty PL_dirty
+#define dowarn PL_dowarn
+#define errgv PL_errgv
+#define na PL_na
+#define no_modify PL_no_modify
+#define perl_destruct_level PL_perl_destruct_level
+#define perldb PL_perldb
+#define ppaddr PL_ppaddr
+#define rsfp PL_rsfp
+#define rsfp_filters PL_rsfp_filters
+#define stack_base PL_stack_base
+#define stack_sp PL_stack_sp
+#define stdingv PL_stdingv
+#define sv_arenaroot PL_sv_arenaroot
+#define sv_no PL_sv_no
+#define sv_undef PL_sv_undef
+#define sv_yes PL_sv_yes
+#define tainted PL_tainted
+#define tainting PL_tainting
+
+#endif /* PERL_POLLUTE */
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/fakesdio.h b/Master/tlpkg/tlperl.straw/lib/CORE/fakesdio.h
new file mode 100755
index 00000000000..614438096e0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/fakesdio.h
@@ -0,0 +1,133 @@
+/* fakestdio.h
+ *
+ * Copyright (C) 2000, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * This is "source level" stdio compatibility mode.
+ * We try and #define stdio functions in terms of PerlIO.
+ */
+#define _CANNOT "CANNOT"
+#undef FILE
+#define FILE PerlIO
+#undef clearerr
+#undef fclose
+#undef fdopen
+#undef feof
+#undef ferror
+#undef fflush
+#undef fgetc
+#undef fgetpos
+#undef fgets
+#undef fileno
+#undef flockfile
+#undef fopen
+#undef fprintf
+#undef fputc
+#undef fputs
+#undef fread
+#undef freopen
+#undef fscanf
+#undef fseek
+#undef fsetpos
+#undef ftell
+#undef ftrylockfile
+#undef funlockfile
+#undef fwrite
+#undef getc
+#undef getc_unlocked
+#undef getw
+#undef pclose
+#undef popen
+#undef putc
+#undef putc_unlocked
+#undef putw
+#undef rewind
+#undef setbuf
+#undef setvbuf
+#undef stderr
+#undef stdin
+#undef stdout
+#undef tmpfile
+#undef ungetc
+#undef vfprintf
+#undef printf
+
+/* printf used to live in perl.h like this - more sophisticated
+ than the rest
+ */
+#if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
+#define printf(fmt,args...) PerlIO_stdoutf(fmt,##args)
+#else
+#define printf PerlIO_stdoutf
+#endif
+
+#define fprintf PerlIO_printf
+#define stdin PerlIO_stdin()
+#define stdout PerlIO_stdout()
+#define stderr PerlIO_stderr()
+#define tmpfile() PerlIO_tmpfile()
+#define fclose(f) PerlIO_close(f)
+#define fflush(f) PerlIO_flush(f)
+#define fopen(p,m) PerlIO_open(p,m)
+#define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a)
+#define fgetc(f) PerlIO_getc(f)
+#define fputc(c,f) PerlIO_putc(f,c)
+#define fputs(s,f) PerlIO_puts(f,s)
+#define getc(f) PerlIO_getc(f)
+#define getc_unlocked(f) PerlIO_getc(f)
+#define putc(c,f) PerlIO_putc(f,c)
+#define putc_unlocked(c,f) PerlIO_putc(c,f)
+#define ungetc(c,f) PerlIO_ungetc(f,c)
+#if 0
+/* return values of read/write need work */
+#define fread(b,s,c,f) PerlIO_read(f,b,(s*c))
+#define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c))
+#else
+#define fread(b,s,c,f) _CANNOT fread
+#define fwrite(b,s,c,f) _CANNOT fwrite
+#endif
+#define fseek(f,o,w) PerlIO_seek(f,o,w)
+#define ftell(f) PerlIO_tell(f)
+#define rewind(f) PerlIO_rewind(f)
+#define clearerr(f) PerlIO_clearerr(f)
+#define feof(f) PerlIO_eof(f)
+#define ferror(f) PerlIO_error(f)
+#define fdopen(fd,p) PerlIO_fdopen(fd,p)
+#define fileno(f) PerlIO_fileno(f)
+#define popen(c,m) my_popen(c,m)
+#define pclose(f) my_pclose(f)
+
+#define fsetpos(f,p) _CANNOT _fsetpos_
+#define fgetpos(f,p) _CANNOT _fgetpos_
+
+#define __filbuf(f) _CANNOT __filbuf_
+#define _filbuf(f) _CANNOT _filbuf_
+#define __flsbuf(c,f) _CANNOT __flsbuf_
+#define _flsbuf(c,f) _CANNOT _flsbuf_
+#define getw(f) _CANNOT _getw_
+#define putw(v,f) _CANNOT _putw_
+#if SFIO_VERSION < 20000101L
+#define flockfile(f) _CANNOT _flockfile_
+#define ftrylockfile(f) _CANNOT _ftrylockfile_
+#define funlockfile(f) _CANNOT _funlockfile_
+#endif
+#define freopen(p,m,f) _CANNOT _freopen_
+#define setbuf(f,b) _CANNOT _setbuf_
+#define setvbuf(f,b,x,s) _CANNOT _setvbuf_
+#define fscanf _CANNOT _fscanf_
+#define fgets(s,n,f) _CANNOT _fgets_
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/fakethr.h b/Master/tlpkg/tlperl.straw/lib/CORE/fakethr.h
new file mode 100755
index 00000000000..7c82aa6d691
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/fakethr.h
@@ -0,0 +1,75 @@
+/* fakethr.h
+ *
+ * Copyright (C) 1999, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+typedef int perl_mutex;
+typedef int perl_key;
+
+typedef struct perl_thread *perl_os_thread;
+/* With fake threads, thr is global(ish) so we don't need dTHR */
+#define dTHR extern int errno
+
+struct perl_wait_queue {
+ struct perl_thread * thread;
+ struct perl_wait_queue * next;
+};
+typedef struct perl_wait_queue *perl_cond;
+
+/* Ask thread.h to include our per-thread extras */
+#define HAVE_THREAD_INTERN
+struct thread_intern {
+ perl_os_thread next_run, prev_run; /* Linked list of runnable threads */
+ perl_cond wait_queue; /* Wait queue that we are waiting on */
+ IV private; /* Holds data across time slices */
+ I32 savemark; /* Holds MARK for thread join values */
+};
+
+#define init_thread_intern(t) \
+ STMT_START { \
+ t->self = (t); \
+ (t)->i.next_run = (t)->i.prev_run = (t); \
+ (t)->i.wait_queue = 0; \
+ (t)->i.private = 0; \
+ } STMT_END
+
+/*
+ * Note that SCHEDULE() is only callable from pp code (which
+ * must be expecting to be restarted). We'll have to do
+ * something a bit different for XS code.
+ */
+
+#define SCHEDULE() return schedule(), PL_op
+
+#define MUTEX_LOCK(m)
+#define MUTEX_UNLOCK(m)
+#define MUTEX_INIT(m)
+#define MUTEX_DESTROY(m)
+#define COND_INIT(c) perl_cond_init(c)
+#define COND_SIGNAL(c) perl_cond_signal(c)
+#define COND_BROADCAST(c) perl_cond_broadcast(c)
+#define COND_WAIT(c, m) \
+ STMT_START { \
+ perl_cond_wait(c); \
+ SCHEDULE(); \
+ } STMT_END
+#define COND_DESTROY(c)
+
+#define THREAD_CREATE(t, f) f((t))
+#define THREAD_POST_CREATE(t) NOOP
+
+#define YIELD NOOP
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/form.h b/Master/tlpkg/tlperl.straw/lib/CORE/form.h
new file mode 100755
index 00000000000..114d6d4475f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/form.h
@@ -0,0 +1,27 @@
+/* form.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 2000, 2004 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#define FF_END 0
+#define FF_LINEMARK 1
+#define FF_LITERAL 2
+#define FF_SKIP 3
+#define FF_FETCH 4
+#define FF_CHECKNL 5
+#define FF_CHECKCHOP 6
+#define FF_SPACE 7
+#define FF_HALFSPACE 8
+#define FF_ITEM 9
+#define FF_CHOP 10
+#define FF_LINEGLOB 11
+#define FF_DECIMAL 12
+#define FF_NEWLINE 13
+#define FF_BLANK 14
+#define FF_MORE 15
+#define FF_0DECIMAL 16
+#define FF_LINESNGL 17
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/git_version.h b/Master/tlpkg/tlperl.straw/lib/CORE/git_version.h
new file mode 100755
index 00000000000..707203d0f29
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/git_version.h
@@ -0,0 +1,8 @@
+/**************************************************************************
+* WARNING: 'git_version.h' is automatically generated by make_patchnum.pl
+* DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead
+***************************************************************************/
+#define PERL_GIT_UNCOMMITTED_CHANGES
+#define PERL_PATCHNUM ""
+#define PERL_GIT_UNPUSHED_COMMITS \
+/*no-op*//*leave-this-comment*/
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/gv.h b/Master/tlpkg/tlperl.straw/lib/CORE/gv.h
new file mode 100755
index 00000000000..afab66dd87e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/gv.h
@@ -0,0 +1,227 @@
+/* gv.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+struct gp {
+ SV * gp_sv; /* scalar value */
+ struct io * gp_io; /* filehandle value */
+ CV * gp_cv; /* subroutine value */
+ U32 gp_cvgen; /* generational validity of cached gv_cv */
+ U32 gp_refcnt; /* how many globs point to this? */
+ HV * gp_hv; /* hash value */
+ AV * gp_av; /* array value */
+ CV * gp_form; /* format value */
+ GV * gp_egv; /* effective gv, if *glob */
+ line_t gp_line; /* line first declared at (for -w) */
+ HEK * gp_file_hek; /* file first declared in (for -w) */
+};
+
+#define GvXPVGV(gv) ((XPVGV*)SvANY(gv))
+
+
+#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__INTEL_COMPILER)
+# define GvGP(gv) \
+ (*({GV *const _gvgp = (GV *) (gv); \
+ assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \
+ assert(isGV_with_GP(_gvgp)); \
+ &((_gvgp)->sv_u.svu_gp);}))
+# define GvFLAGS(gv) \
+ (*({GV *const _gvflags = (GV *) (gv); \
+ assert(SvTYPE(_gvflags) == SVt_PVGV || SvTYPE(_gvflags) == SVt_PVLV); \
+ assert(isGV_with_GP(_gvflags)); \
+ &(GvXPVGV(_gvflags)->xpv_cur);}))
+# define GvSTASH(gv) \
+ (*({ GV * const _gvstash = (GV *) (gv); \
+ assert(isGV_with_GP(_gvstash)); \
+ assert(SvTYPE(_gvstash) == SVt_PVGV || SvTYPE(_gvstash) >= SVt_PVLV); \
+ &(GvXPVGV(_gvstash)->xnv_u.xgv_stash); \
+ }))
+# define GvNAME_HEK(gv) \
+ (*({ GV * const _gvname_hek = (GV *) (gv); \
+ assert(isGV_with_GP(_gvname_hek)); \
+ assert(SvTYPE(_gvname_hek) == SVt_PVGV || SvTYPE(_gvname_hek) >= SVt_PVLV); \
+ assert(!SvVALID(_gvname_hek)); \
+ &(GvXPVGV(_gvname_hek)->xiv_u.xivu_namehek); \
+ }))
+# define GvNAME_get(gv) ({ assert(GvNAME_HEK(gv)); HEK_KEY(GvNAME_HEK(gv)); })
+# define GvNAMELEN_get(gv) ({ assert(GvNAME_HEK(gv)); HEK_LEN(GvNAME_HEK(gv)); })
+#else
+# define GvGP(gv) ((gv)->sv_u.svu_gp)
+# define GvFLAGS(gv) (GvXPVGV(gv)->xpv_cur)
+# define GvSTASH(gv) (GvXPVGV(gv)->xnv_u.xgv_stash)
+# define GvNAME_HEK(gv) (GvXPVGV(gv)->xiv_u.xivu_namehek)
+# define GvNAME_get(gv) HEK_KEY(GvNAME_HEK(gv))
+# define GvNAMELEN_get(gv) HEK_LEN(GvNAME_HEK(gv))
+#endif
+
+#define GvNAME(gv) GvNAME_get(gv)
+#define GvNAMELEN(gv) GvNAMELEN_get(gv)
+
+#define GvASSIGN_GENERATION(gv) (0 + ((XPV*) SvANY(gv))->xpv_len)
+#define GvASSIGN_GENERATION_set(gv,val) \
+ STMT_START { assert(SvTYPE(gv) == SVt_PVGV); \
+ (((XPV*) SvANY(gv))->xpv_len = (val)); } STMT_END
+
+/*
+=head1 GV Functions
+
+=for apidoc Am|SV*|GvSV|GV* gv
+
+Return the SV from the GV.
+
+=cut
+*/
+
+#define GvSV(gv) (GvGP(gv)->gp_sv)
+#ifdef PERL_DONT_CREATE_GVSV
+#define GvSVn(gv) (*(GvGP(gv)->gp_sv ? \
+ &(GvGP(gv)->gp_sv) : \
+ &(GvGP(gv_SVadd(gv))->gp_sv)))
+#else
+#define GvSVn(gv) GvSV(gv)
+#endif
+
+#define GvREFCNT(gv) (GvGP(gv)->gp_refcnt)
+#define GvIO(gv) ((gv) && SvTYPE((const SV*)gv) == SVt_PVGV && GvGP(gv) ? GvIOp(gv) : NULL)
+#define GvIOp(gv) (GvGP(gv)->gp_io)
+#define GvIOn(gv) (GvIO(gv) ? GvIOp(gv) : GvIOp(gv_IOadd(gv)))
+
+#define GvFORM(gv) (GvGP(gv)->gp_form)
+#define GvAV(gv) (GvGP(gv)->gp_av)
+
+/* This macro is deprecated. Do not use! */
+#define GvREFCNT_inc(gv) ((GV*)SvREFCNT_inc(gv)) /* DO NOT USE */
+
+#define GvAVn(gv) (GvGP(gv)->gp_av ? \
+ GvGP(gv)->gp_av : \
+ GvGP(gv_AVadd(gv))->gp_av)
+#define GvHV(gv) ((GvGP(gv))->gp_hv)
+
+#define GvHVn(gv) (GvGP(gv)->gp_hv ? \
+ GvGP(gv)->gp_hv : \
+ GvGP(gv_HVadd(gv))->gp_hv)
+
+#define GvCV(gv) (GvGP(gv)->gp_cv)
+#define GvCVGEN(gv) (GvGP(gv)->gp_cvgen)
+#define GvCVu(gv) (GvGP(gv)->gp_cvgen ? NULL : GvGP(gv)->gp_cv)
+
+#define GvLINE(gv) (GvGP(gv)->gp_line)
+#define GvFILE_HEK(gv) (GvGP(gv)->gp_file_hek)
+#define GvFILE(gv) (GvFILE_HEK(gv) ? HEK_KEY(GvFILE_HEK(gv)) : NULL)
+#define GvFILEGV(gv) (gv_fetchfile(GvFILE(gv)))
+
+#define GvEGV(gv) (GvGP(gv)->gp_egv)
+#define GvENAME(gv) GvNAME(GvEGV(gv) ? GvEGV(gv) : gv)
+#define GvESTASH(gv) GvSTASH(GvEGV(gv) ? GvEGV(gv) : gv)
+
+#define GVf_INTRO 0x01
+#define GVf_MULTI 0x02
+#define GVf_ASSUMECV 0x04
+#define GVf_IN_PAD 0x08
+#define GVf_IMPORTED 0xF0
+#define GVf_IMPORTED_SV 0x10
+#define GVf_IMPORTED_AV 0x20
+#define GVf_IMPORTED_HV 0x40
+#define GVf_IMPORTED_CV 0x80
+
+#define GvINTRO(gv) (GvFLAGS(gv) & GVf_INTRO)
+#define GvINTRO_on(gv) (GvFLAGS(gv) |= GVf_INTRO)
+#define GvINTRO_off(gv) (GvFLAGS(gv) &= ~GVf_INTRO)
+
+#define GvMULTI(gv) (GvFLAGS(gv) & GVf_MULTI)
+#define GvMULTI_on(gv) (GvFLAGS(gv) |= GVf_MULTI)
+#define GvMULTI_off(gv) (GvFLAGS(gv) &= ~GVf_MULTI)
+
+#define GvASSUMECV(gv) (GvFLAGS(gv) & GVf_ASSUMECV)
+#define GvASSUMECV_on(gv) (GvFLAGS(gv) |= GVf_ASSUMECV)
+#define GvASSUMECV_off(gv) (GvFLAGS(gv) &= ~GVf_ASSUMECV)
+
+#define GvIMPORTED(gv) (GvFLAGS(gv) & GVf_IMPORTED)
+#define GvIMPORTED_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED)
+#define GvIMPORTED_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED)
+
+#define GvIMPORTED_SV(gv) (GvFLAGS(gv) & GVf_IMPORTED_SV)
+#define GvIMPORTED_SV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_SV)
+#define GvIMPORTED_SV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_SV)
+
+#define GvIMPORTED_AV(gv) (GvFLAGS(gv) & GVf_IMPORTED_AV)
+#define GvIMPORTED_AV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_AV)
+#define GvIMPORTED_AV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_AV)
+
+#define GvIMPORTED_HV(gv) (GvFLAGS(gv) & GVf_IMPORTED_HV)
+#define GvIMPORTED_HV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_HV)
+#define GvIMPORTED_HV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_HV)
+
+#define GvIMPORTED_CV(gv) (GvFLAGS(gv) & GVf_IMPORTED_CV)
+#define GvIMPORTED_CV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_CV)
+#define GvIMPORTED_CV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_CV)
+
+#define GvIN_PAD(gv) (GvFLAGS(gv) & GVf_IN_PAD)
+#define GvIN_PAD_on(gv) (GvFLAGS(gv) |= GVf_IN_PAD)
+#define GvIN_PAD_off(gv) (GvFLAGS(gv) &= ~GVf_IN_PAD)
+
+#define GvUNIQUE(gv) 0
+#define GvUNIQUE_on(gv) NOOP
+#define GvUNIQUE_off(gv) NOOP
+
+#ifdef USE_ITHREADS
+#define GV_UNIQUE_CHECK
+#else
+#undef GV_UNIQUE_CHECK
+#endif
+
+#define Nullgv Null(GV*)
+
+#define DM_UID 0x003
+#define DM_RUID 0x001
+#define DM_EUID 0x002
+#define DM_ARRAY 0x004
+#define DM_GID 0x030
+#define DM_RGID 0x010
+#define DM_EGID 0x020
+#define DM_DELAY 0x100
+
+/*
+ * symbol creation flags, for use in gv_fetchpv() and get_*v()
+ */
+#define GV_ADD 0x01 /* add, if symbol not already there
+ For gv_name_set, adding a HEK for the first
+ time, so don't try to free what's there. */
+#define GV_ADDMULTI 0x02 /* add, pretending it has been added already */
+#define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */
+#define GV_ADDINEVAL 0x08 /* add, as though we're doing so within an eval */
+#define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */
+/* This is used by toke.c to avoid turing placeholder constants in the symbol
+ table into full PVGVs with attached constant subroutines. */
+#define GV_NOADD_NOINIT 0x20 /* Don't add the symbol if it's not there.
+ Don't init it if it is there but ! PVGV */
+#define GV_NOEXPAND 0x40 /* Don't expand SvOK() entries to PVGV */
+#define GV_NOTQUAL 0x80 /* A plain symbol name, not qualified with a
+ package (so skip checks for :: and ') */
+
+/* SVf_UTF8 (more accurately the return value from SvUTF8) is also valid
+ as a flag to gv_fetch_pvn_flags, so ensure it lies outside this range.
+*/
+
+#define GV_NOADD_MASK (SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL)
+/* The bit flags that don't cause gv_fetchpv() to add a symbol if not found */
+
+#define gv_fullname3(sv,gv,prefix) gv_fullname4(sv,gv,prefix,TRUE)
+#define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE)
+#define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE)
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/handy.h b/Master/tlpkg/tlperl.straw/lib/CORE/handy.h
new file mode 100755
index 00000000000..444b3ecc911
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/handy.h
@@ -0,0 +1,912 @@
+/* handy.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999, 2000,
+ * 2001, 2002, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#if !defined(__STDC__)
+#ifdef NULL
+#undef NULL
+#endif
+#ifndef I286
+# define NULL 0
+#else
+# define NULL 0L
+#endif
+#endif
+
+#define Null(type) ((type)NULL)
+
+/*
+=head1 Handy Values
+
+=for apidoc AmU||Nullch
+Null character pointer.
+
+=for apidoc AmU||Nullsv
+Null SV pointer.
+
+=cut
+*/
+
+#define Nullch Null(char*)
+#define Nullfp Null(PerlIO*)
+#define Nullsv Null(SV*)
+
+#ifdef TRUE
+#undef TRUE
+#endif
+#ifdef FALSE
+#undef FALSE
+#endif
+#define TRUE (1)
+#define FALSE (0)
+
+/* The MUTABLE_*() macros cast pointers to the types shown, in such a way
+ * (compiler permitting) that casting away const-ness will give a warning;
+ * e.g.:
+ *
+ * const SV *sv = ...;
+ * AV *av1 = (AV*)sv; <== BAD: the const has been silently cast away
+ * AV *av2 = MUTABLE_AV(sv); <== GOOD: it may warn
+ */
+
+/* For 5.10.x, disable the const cast checking that MUTABLE_PTR does in
+ * blead */
+#if 0 && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
+#else
+# define MUTABLE_PTR(p) ((void *) (p))
+#endif
+
+#define MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p))
+#define MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p))
+#define MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p))
+#define MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p))
+#define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p))
+#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
+
+/* XXX Configure ought to have a test for a boolean type, if I can
+ just figure out all the headers such a test needs.
+ Andy Dougherty August 1996
+*/
+/* bool is built-in for g++-2.6.3 and later, which might be used
+ for extensions. <_G_config.h> defines _G_HAVE_BOOL, but we can't
+ be sure _G_config.h will be included before this file. _G_config.h
+ also defines _G_HAVE_BOOL for both gcc and g++, but only g++
+ actually has bool. Hence, _G_HAVE_BOOL is pretty useless for us.
+ g++ can be identified by __GNUG__.
+ Andy Dougherty February 2000
+*/
+#ifdef __GNUG__ /* GNU g++ has bool built-in */
+# ifndef HAS_BOOL
+# define HAS_BOOL 1
+# endif
+#endif
+
+/* The NeXT dynamic loader headers will not build with the bool macro
+ So declare them now to clear confusion.
+*/
+#if defined(NeXT) || defined(__NeXT__)
+# undef FALSE
+# undef TRUE
+ typedef enum bool { FALSE = 0, TRUE = 1 } bool;
+# define ENUM_BOOL 1
+# ifndef HAS_BOOL
+# define HAS_BOOL 1
+# endif /* !HAS_BOOL */
+#endif /* NeXT || __NeXT__ */
+
+#ifndef HAS_BOOL
+# if defined(UTS) || defined(VMS)
+# define bool int
+# else
+# define bool char
+# endif
+# define HAS_BOOL 1
+#endif
+
+/* Try to figure out __func__ or __FUNCTION__ equivalent, if any.
+ * XXX Should really be a Configure probe, with HAS__FUNCTION__
+ * and FUNCTION__ as results.
+ * XXX Similarly, a Configure probe for __FILE__ and __LINE__ is needed. */
+#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || (defined(__SUNPRO_C)) /* C99 or close enough. */
+# define FUNCTION__ __func__
+#else
+# if (defined(_MSC_VER) && _MSC_VER < 1300) || /* Pre-MSVC 7.0 has neither __func__ nor __FUNCTION and no good workarounds, either. */ \
+ (defined(__DECC_VER)) /* Tru64 or VMS, and strict C89 being used, but not modern enough cc (in Tur64, -c99 not known, only -std1). */
+# define FUNCTION__ ""
+# else
+# define FUNCTION__ __FUNCTION__ /* Common extension. */
+# endif
+#endif
+
+/* XXX A note on the perl source internal type system. The
+ original intent was that I32 be *exactly* 32 bits.
+
+ Currently, we only guarantee that I32 is *at least* 32 bits.
+ Specifically, if int is 64 bits, then so is I32. (This is the case
+ for the Cray.) This has the advantage of meshing nicely with
+ standard library calls (where we pass an I32 and the library is
+ expecting an int), but the disadvantage that an I32 is not 32 bits.
+ Andy Dougherty August 1996
+
+ There is no guarantee that there is *any* integral type with
+ exactly 32 bits. It is perfectly legal for a system to have
+ sizeof(short) == sizeof(int) == sizeof(long) == 8.
+
+ Similarly, there is no guarantee that I16 and U16 have exactly 16
+ bits.
+
+ For dealing with issues that may arise from various 32/64-bit
+ systems, we will ask Configure to check out
+
+ SHORTSIZE == sizeof(short)
+ INTSIZE == sizeof(int)
+ LONGSIZE == sizeof(long)
+ LONGLONGSIZE == sizeof(long long) (if HAS_LONG_LONG)
+ PTRSIZE == sizeof(void *)
+ DOUBLESIZE == sizeof(double)
+ LONG_DOUBLESIZE == sizeof(long double) (if HAS_LONG_DOUBLE).
+
+*/
+
+#ifdef I_INTTYPES /* e.g. Linux has int64_t without <inttypes.h> */
+# include <inttypes.h>
+# ifdef INT32_MIN_BROKEN
+# undef INT32_MIN
+# define INT32_MIN (-2147483647-1)
+# endif
+# ifdef INT64_MIN_BROKEN
+# undef INT64_MIN
+# define INT64_MIN (-9223372036854775807LL-1)
+# endif
+#endif
+
+typedef I8TYPE I8;
+typedef U8TYPE U8;
+typedef I16TYPE I16;
+typedef U16TYPE U16;
+typedef I32TYPE I32;
+typedef U32TYPE U32;
+#ifdef PERL_CORE
+# ifdef HAS_QUAD
+typedef I64TYPE I64;
+typedef U64TYPE U64;
+# endif
+#endif /* PERL_CORE */
+
+#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
+# ifndef UINT64_C /* usually from <inttypes.h> */
+# if defined(HAS_LONG_LONG) && QUADKIND == QUAD_IS_LONG_LONG
+# define INT64_C(c) CAT2(c,LL)
+# define UINT64_C(c) CAT2(c,ULL)
+# else
+# if LONGSIZE == 8 && QUADKIND == QUAD_IS_LONG
+# define INT64_C(c) CAT2(c,L)
+# define UINT64_C(c) CAT2(c,UL)
+# else
+# define INT64_C(c) ((I64TYPE)(c))
+# define UINT64_C(c) ((U64TYPE)(c))
+# endif
+# endif
+# endif
+#endif
+
+/* HMB H.Merijn Brand - a placeholder for preparing Configure patches:
+ *
+ * USE_DTRACE HAS_PSEUDOFORK HAS_TIMEGM LOCALTIME_R_NEEDS_TZSET
+ * GMTIME_MAX GMTIME_MIN LOCALTIME_MAX LOCALTIME_MIN
+ * HAS_CTIME64 HAS_LOCALTIME64 HAS_GMTIME64 HAS_DIFFTIME64
+ * HAS_MKTIME64 HAS_ASCTIME64 HAS_GETADDRINFO HAS_GETNAMEINFO
+ * HAS_INETNTOP HAS_INETPTON
+ * Not (yet) used at top level, but mention them for metaconfig
+ */
+
+/* Mention I8SIZE, U8SIZE, I16SIZE, U16SIZE, I32SIZE, U32SIZE,
+ I64SIZE, and U64SIZE here so that metaconfig pulls them in. */
+
+#if defined(UINT8_MAX) && defined(INT16_MAX) && defined(INT32_MAX)
+
+/* I8_MAX and I8_MIN constants are not defined, as I8 is an ambiguous type.
+ Please search CHAR_MAX in perl.h for further details. */
+#define U8_MAX UINT8_MAX
+#define U8_MIN UINT8_MIN
+
+#define I16_MAX INT16_MAX
+#define I16_MIN INT16_MIN
+#define U16_MAX UINT16_MAX
+#define U16_MIN UINT16_MIN
+
+#define I32_MAX INT32_MAX
+#define I32_MIN INT32_MIN
+#ifndef UINT32_MAX_BROKEN /* e.g. HP-UX with gcc messes this up */
+# define U32_MAX UINT32_MAX
+#else
+# define U32_MAX 4294967295U
+#endif
+#define U32_MIN UINT32_MIN
+
+#else
+
+/* I8_MAX and I8_MIN constants are not defined, as I8 is an ambiguous type.
+ Please search CHAR_MAX in perl.h for further details. */
+#define U8_MAX PERL_UCHAR_MAX
+#define U8_MIN PERL_UCHAR_MIN
+
+#define I16_MAX PERL_SHORT_MAX
+#define I16_MIN PERL_SHORT_MIN
+#define U16_MAX PERL_USHORT_MAX
+#define U16_MIN PERL_USHORT_MIN
+
+#if LONGSIZE > 4
+# define I32_MAX PERL_INT_MAX
+# define I32_MIN PERL_INT_MIN
+# define U32_MAX PERL_UINT_MAX
+# define U32_MIN PERL_UINT_MIN
+#else
+# define I32_MAX PERL_LONG_MAX
+# define I32_MIN PERL_LONG_MIN
+# define U32_MAX PERL_ULONG_MAX
+# define U32_MIN PERL_ULONG_MIN
+#endif
+
+#endif
+
+/* log(2) is pretty close to 0.30103, just in case anyone is grepping for it */
+#define BIT_DIGITS(N) (((N)*146)/485 + 1) /* log2(10) =~ 146/485 */
+#define TYPE_DIGITS(T) BIT_DIGITS(sizeof(T) * 8)
+#define TYPE_CHARS(T) (TYPE_DIGITS(T) + 2) /* sign, NUL */
+
+#define Ctl(ch) ((ch) & 037)
+
+/*
+=head1 SV-Body Allocation
+
+=for apidoc Ama|SV*|newSVpvs|const char* s
+Like C<newSVpvn>, but takes a literal string instead of a string/length pair.
+
+=for apidoc Ama|SV*|newSVpvs_flags|const char* s|U32 flags
+Like C<newSVpvn_flags>, but takes a literal string instead of a string/length
+pair.
+
+=for apidoc Ama|SV*|newSVpvs_share|const char* s
+Like C<newSVpvn_share>, but takes a literal string instead of a string/length
+pair and omits the hash parameter.
+
+=for apidoc Am|void|sv_catpvs|SV* sv|const char* s
+Like C<sv_catpvn>, but takes a literal string instead of a string/length pair.
+
+=for apidoc Am|void|sv_setpvs|SV* sv|const char* s
+Like C<sv_setpvn>, but takes a literal string instead of a string/length pair.
+
+=head1 Memory Management
+
+=for apidoc Ama|char*|savepvs|const char* s
+Like C<savepvn>, but takes a literal string instead of a string/length pair.
+
+=head1 GV Functions
+
+=for apidoc Am|HV*|gv_stashpvs|const char* name|I32 create
+Like C<gv_stashpvn>, but takes a literal string instead of a string/length pair.
+
+=head1 Hash Manipulation Functions
+
+=for apidoc Am|SV**|hv_fetchs|HV* tb|const char* key|I32 lval
+Like C<hv_fetch>, but takes a literal string instead of a string/length pair.
+
+=for apidoc Am|SV**|hv_stores|HV* tb|const char* key|NULLOK SV* val
+Like C<hv_store>, but takes a literal string instead of a string/length pair
+and omits the hash parameter.
+
+=cut
+*/
+
+/* concatenating with "" ensures that only literal strings are accepted as argument */
+#define STR_WITH_LEN(s) ("" s ""), (sizeof(s)-1)
+
+/* note that STR_WITH_LEN() can't be used as argument to macros or functions that
+ * under some configurations might be macros, which means that it requires the full
+ * Perl_xxx(aTHX_ ...) form for any API calls where it's used.
+ */
+
+/* STR_WITH_LEN() shortcuts */
+#define newSVpvs(str) Perl_newSVpvn(aTHX_ STR_WITH_LEN(str))
+#define newSVpvs_flags(str,flags) \
+ Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN(str), flags)
+#define newSVpvs_share(str) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(str), 0)
+#define sv_catpvs(sv, str) Perl_sv_catpvn_flags(aTHX_ sv, STR_WITH_LEN(str), SV_GMAGIC)
+#define sv_setpvs(sv, str) Perl_sv_setpvn(aTHX_ sv, STR_WITH_LEN(str))
+#define savepvs(str) Perl_savepvn(aTHX_ STR_WITH_LEN(str))
+#define gv_stashpvs(str, create) Perl_gv_stashpvn(aTHX_ STR_WITH_LEN(str), create)
+#define gv_fetchpvs(namebeg, add, sv_type) Perl_gv_fetchpvn_flags(aTHX_ STR_WITH_LEN(namebeg), add, sv_type)
+#define hv_fetchs(hv,key,lval) \
+ ((SV **)Perl_hv_common(aTHX_ (hv), NULL, STR_WITH_LEN(key), 0, \
+ (lval) ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \
+ : HV_FETCH_JUST_SV, NULL, 0))
+
+#define hv_stores(hv,key,val) \
+ ((SV **)Perl_hv_common(aTHX_ (hv), NULL, STR_WITH_LEN(key), 0, \
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), 0))
+
+
+/*
+=head1 Miscellaneous Functions
+
+=for apidoc Am|bool|strNE|char* s1|char* s2
+Test two strings to see if they are different. Returns true or
+false.
+
+=for apidoc Am|bool|strEQ|char* s1|char* s2
+Test two strings to see if they are equal. Returns true or false.
+
+=for apidoc Am|bool|strLT|char* s1|char* s2
+Test two strings to see if the first, C<s1>, is less than the second,
+C<s2>. Returns true or false.
+
+=for apidoc Am|bool|strLE|char* s1|char* s2
+Test two strings to see if the first, C<s1>, is less than or equal to the
+second, C<s2>. Returns true or false.
+
+=for apidoc Am|bool|strGT|char* s1|char* s2
+Test two strings to see if the first, C<s1>, is greater than the second,
+C<s2>. Returns true or false.
+
+=for apidoc Am|bool|strGE|char* s1|char* s2
+Test two strings to see if the first, C<s1>, is greater than or equal to
+the second, C<s2>. Returns true or false.
+
+=for apidoc Am|bool|strnNE|char* s1|char* s2|STRLEN len
+Test two strings to see if they are different. The C<len> parameter
+indicates the number of bytes to compare. Returns true or false. (A
+wrapper for C<strncmp>).
+
+=for apidoc Am|bool|strnEQ|char* s1|char* s2|STRLEN len
+Test two strings to see if they are equal. The C<len> parameter indicates
+the number of bytes to compare. Returns true or false. (A wrapper for
+C<strncmp>).
+
+=cut
+*/
+
+#define strNE(s1,s2) (strcmp(s1,s2))
+#define strEQ(s1,s2) (!strcmp(s1,s2))
+#define strLT(s1,s2) (strcmp(s1,s2) < 0)
+#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
+#define strGT(s1,s2) (strcmp(s1,s2) > 0)
+#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
+#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
+#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
+
+#ifdef HAS_MEMCMP
+# define memNE(s1,s2,l) (memcmp(s1,s2,l))
+# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
+#else
+# define memNE(s1,s2,l) (bcmp(s1,s2,l))
+# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
+#endif
+
+#define memEQs(s1, l, s2) \
+ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1)))
+#define memNEs(s1, l, s2) !memEQs(s1, l, s2)
+
+/*
+ * Character classes.
+ *
+ * Unfortunately, the introduction of locales means that we
+ * can't trust isupper(), etc. to tell the truth. And when
+ * it comes to /\w+/ with tainting enabled, we *must* be able
+ * to trust our character classes.
+ *
+ * Therefore, the default tests in the text of Perl will be
+ * independent of locale. Any code that wants to depend on
+ * the current locale will use the tests that begin with "lc".
+ */
+
+#ifdef HAS_SETLOCALE /* XXX Is there a better test for this? */
+# ifndef CTYPE256
+# define CTYPE256
+# endif
+#endif
+
+/*
+
+=head1 Character classes
+
+=for apidoc Am|bool|isALNUM|char ch
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+alphanumeric character (including underscore) or digit.
+
+=for apidoc Am|bool|isALPHA|char ch
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+alphabetic character.
+
+=for apidoc Am|bool|isSPACE|char ch
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+whitespace.
+
+=for apidoc Am|bool|isDIGIT|char ch
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+digit.
+
+=for apidoc Am|bool|isUPPER|char ch
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+uppercase character.
+
+=for apidoc Am|bool|isLOWER|char ch
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+lowercase character.
+
+=for apidoc Am|char|toUPPER|char ch
+Converts the specified character to uppercase. Characters outside the
+US-ASCII (Basic Latin) range are viewed as not having any case.
+
+=for apidoc Am|char|toLOWER|char ch
+Converts the specified character to lowercase. Characters outside the
+US-ASCII (Basic Latin) range are viewed as not having any case.
+
+=cut
+*/
+
+#define isALNUM(c) (isALPHA(c) || isDIGIT(c) || (c) == '_')
+#define isIDFIRST(c) (isALPHA(c) || (c) == '_')
+#define isALPHA(c) (isUPPER(c) || isLOWER(c))
+#define isSPACE(c) \
+ ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f')
+#define isPSXSPC(c) (isSPACE(c) || (c) == '\v')
+#define isBLANK(c) ((c) == ' ' || (c) == '\t')
+#define isDIGIT(c) ((c) >= '0' && (c) <= '9')
+#ifdef EBCDIC
+ /* In EBCDIC we do not do locales: therefore() isupper() is fine. */
+# define isUPPER(c) isupper(c)
+# define isLOWER(c) islower(c)
+# define isALNUMC(c) isalnum(c)
+# define isASCII(c) isascii(c)
+# define isCNTRL(c) iscntrl(c)
+# define isGRAPH(c) isgraph(c)
+# define isPRINT(c) isprint(c)
+# define isPUNCT(c) ispunct(c)
+# define isXDIGIT(c) isxdigit(c)
+# define toUPPER(c) toupper(c)
+# define toLOWER(c) tolower(c)
+#else
+# define isUPPER(c) ((c) >= 'A' && (c) <= 'Z')
+# define isLOWER(c) ((c) >= 'a' && (c) <= 'z')
+# define isALNUMC(c) (isALPHA(c) || isDIGIT(c))
+# define isASCII(c) ((c) <= 127)
+# define isCNTRL(c) ((c) < ' ' || (c) == 127)
+# define isGRAPH(c) (isALNUM(c) || isPUNCT(c))
+# define isPRINT(c) (((c) >= 32 && (c) < 127))
+# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
+# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
+# define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c))
+# define toLOWER(c) (isUPPER(c) ? (c) + ('a' - 'A') : (c))
+#endif
+
+#ifdef USE_NEXT_CTYPE
+
+# define isALNUM_LC(c) \
+ (NXIsAlNum((unsigned int)(c)) || (char)(c) == '_')
+# define isIDFIRST_LC(c) \
+ (NXIsAlpha((unsigned int)(c)) || (char)(c) == '_')
+# define isALPHA_LC(c) NXIsAlpha((unsigned int)(c))
+# define isSPACE_LC(c) NXIsSpace((unsigned int)(c))
+# define isDIGIT_LC(c) NXIsDigit((unsigned int)(c))
+# define isUPPER_LC(c) NXIsUpper((unsigned int)(c))
+# define isLOWER_LC(c) NXIsLower((unsigned int)(c))
+# define isALNUMC_LC(c) NXIsAlNum((unsigned int)(c))
+# define isCNTRL_LC(c) NXIsCntrl((unsigned int)(c))
+# define isGRAPH_LC(c) NXIsGraph((unsigned int)(c))
+# define isPRINT_LC(c) NXIsPrint((unsigned int)(c))
+# define isPUNCT_LC(c) NXIsPunct((unsigned int)(c))
+# define toUPPER_LC(c) NXToUpper((unsigned int)(c))
+# define toLOWER_LC(c) NXToLower((unsigned int)(c))
+
+#else /* !USE_NEXT_CTYPE */
+
+# if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII))
+
+# define isALNUM_LC(c) (isalnum((unsigned char)(c)) || (char)(c) == '_')
+# define isIDFIRST_LC(c) (isalpha((unsigned char)(c)) || (char)(c) == '_')
+# define isALPHA_LC(c) isalpha((unsigned char)(c))
+# define isSPACE_LC(c) isspace((unsigned char)(c))
+# define isDIGIT_LC(c) isdigit((unsigned char)(c))
+# define isUPPER_LC(c) isupper((unsigned char)(c))
+# define isLOWER_LC(c) islower((unsigned char)(c))
+# define isALNUMC_LC(c) isalnum((unsigned char)(c))
+# define isCNTRL_LC(c) iscntrl((unsigned char)(c))
+# define isGRAPH_LC(c) isgraph((unsigned char)(c))
+# define isPRINT_LC(c) isprint((unsigned char)(c))
+# define isPUNCT_LC(c) ispunct((unsigned char)(c))
+# define toUPPER_LC(c) toupper((unsigned char)(c))
+# define toLOWER_LC(c) tolower((unsigned char)(c))
+
+# else
+
+# define isALNUM_LC(c) (isascii(c) && (isalnum(c) || (c) == '_'))
+# define isIDFIRST_LC(c) (isascii(c) && (isalpha(c) || (c) == '_'))
+# define isALPHA_LC(c) (isascii(c) && isalpha(c))
+# define isSPACE_LC(c) (isascii(c) && isspace(c))
+# define isDIGIT_LC(c) (isascii(c) && isdigit(c))
+# define isUPPER_LC(c) (isascii(c) && isupper(c))
+# define isLOWER_LC(c) (isascii(c) && islower(c))
+# define isALNUMC_LC(c) (isascii(c) && isalnum(c))
+# define isCNTRL_LC(c) (isascii(c) && iscntrl(c))
+# define isGRAPH_LC(c) (isascii(c) && isgraph(c))
+# define isPRINT_LC(c) (isascii(c) && isprint(c))
+# define isPUNCT_LC(c) (isascii(c) && ispunct(c))
+# define toUPPER_LC(c) toupper(c)
+# define toLOWER_LC(c) tolower(c)
+
+# endif
+#endif /* USE_NEXT_CTYPE */
+
+#define isPSXSPC_LC(c) (isSPACE_LC(c) || (c) == '\v')
+#define isBLANK_LC(c) isBLANK(c) /* could be wrong */
+
+#define isALNUM_uni(c) is_uni_alnum(c)
+#define isIDFIRST_uni(c) is_uni_idfirst(c)
+#define isALPHA_uni(c) is_uni_alpha(c)
+#define isSPACE_uni(c) is_uni_space(c)
+#define isDIGIT_uni(c) is_uni_digit(c)
+#define isUPPER_uni(c) is_uni_upper(c)
+#define isLOWER_uni(c) is_uni_lower(c)
+#define isALNUMC_uni(c) is_uni_alnumc(c)
+#define isASCII_uni(c) is_uni_ascii(c)
+#define isCNTRL_uni(c) is_uni_cntrl(c)
+#define isGRAPH_uni(c) is_uni_graph(c)
+#define isPRINT_uni(c) is_uni_print(c)
+#define isPUNCT_uni(c) is_uni_punct(c)
+#define isXDIGIT_uni(c) is_uni_xdigit(c)
+#define toUPPER_uni(c,s,l) to_uni_upper(c,s,l)
+#define toTITLE_uni(c,s,l) to_uni_title(c,s,l)
+#define toLOWER_uni(c,s,l) to_uni_lower(c,s,l)
+#define toFOLD_uni(c,s,l) to_uni_fold(c,s,l)
+
+#define isPSXSPC_uni(c) (isSPACE_uni(c) ||(c) == '\f')
+#define isBLANK_uni(c) isBLANK(c) /* could be wrong */
+
+#define isALNUM_LC_uvchr(c) (c < 256 ? isALNUM_LC(c) : is_uni_alnum_lc(c))
+#define isIDFIRST_LC_uvchr(c) (c < 256 ? isIDFIRST_LC(c) : is_uni_idfirst_lc(c))
+#define isALPHA_LC_uvchr(c) (c < 256 ? isALPHA_LC(c) : is_uni_alpha_lc(c))
+#define isSPACE_LC_uvchr(c) (c < 256 ? isSPACE_LC(c) : is_uni_space_lc(c))
+#define isDIGIT_LC_uvchr(c) (c < 256 ? isDIGIT_LC(c) : is_uni_digit_lc(c))
+#define isUPPER_LC_uvchr(c) (c < 256 ? isUPPER_LC(c) : is_uni_upper_lc(c))
+#define isLOWER_LC_uvchr(c) (c < 256 ? isLOWER_LC(c) : is_uni_lower_lc(c))
+#define isALNUMC_LC_uvchr(c) (c < 256 ? isALNUMC_LC(c) : is_uni_alnumc_lc(c))
+#define isCNTRL_LC_uvchr(c) (c < 256 ? isCNTRL_LC(c) : is_uni_cntrl_lc(c))
+#define isGRAPH_LC_uvchr(c) (c < 256 ? isGRAPH_LC(c) : is_uni_graph_lc(c))
+#define isPRINT_LC_uvchr(c) (c < 256 ? isPRINT_LC(c) : is_uni_print_lc(c))
+#define isPUNCT_LC_uvchr(c) (c < 256 ? isPUNCT_LC(c) : is_uni_punct_lc(c))
+
+#define isPSXSPC_LC_uni(c) (isSPACE_LC_uni(c) ||(c) == '\f')
+#define isBLANK_LC_uni(c) isBLANK(c) /* could be wrong */
+
+#define isALNUM_utf8(p) is_utf8_alnum(p)
+/* The ID_Start of Unicode is quite limiting: it assumes a L-class
+ * character (meaning that you cannot have, say, a CJK character).
+ * Instead, let's allow ID_Continue but not digits. */
+#define isIDFIRST_utf8(p) (is_utf8_idcont(p) && !is_utf8_digit(p))
+#define isALPHA_utf8(p) is_utf8_alpha(p)
+#define isSPACE_utf8(p) is_utf8_space(p)
+#define isDIGIT_utf8(p) is_utf8_digit(p)
+#define isUPPER_utf8(p) is_utf8_upper(p)
+#define isLOWER_utf8(p) is_utf8_lower(p)
+#define isALNUMC_utf8(p) is_utf8_alnumc(p)
+#define isASCII_utf8(p) is_utf8_ascii(p)
+#define isCNTRL_utf8(p) is_utf8_cntrl(p)
+#define isGRAPH_utf8(p) is_utf8_graph(p)
+#define isPRINT_utf8(p) is_utf8_print(p)
+#define isPUNCT_utf8(p) is_utf8_punct(p)
+#define isXDIGIT_utf8(p) is_utf8_xdigit(p)
+#define toUPPER_utf8(p,s,l) to_utf8_upper(p,s,l)
+#define toTITLE_utf8(p,s,l) to_utf8_title(p,s,l)
+#define toLOWER_utf8(p,s,l) to_utf8_lower(p,s,l)
+
+#define isPSXSPC_utf8(c) (isSPACE_utf8(c) ||(c) == '\f')
+#define isBLANK_utf8(c) isBLANK(c) /* could be wrong */
+
+#define isALNUM_LC_utf8(p) isALNUM_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isIDFIRST_LC_utf8(p) isIDFIRST_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isALPHA_LC_utf8(p) isALPHA_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isSPACE_LC_utf8(p) isSPACE_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isDIGIT_LC_utf8(p) isDIGIT_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isUPPER_LC_utf8(p) isUPPER_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isLOWER_LC_utf8(p) isLOWER_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isALNUMC_LC_utf8(p) isALNUMC_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isCNTRL_LC_utf8(p) isCNTRL_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isGRAPH_LC_utf8(p) isGRAPH_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isPRINT_LC_utf8(p) isPRINT_LC_uvchr(utf8_to_uvchr(p, 0))
+#define isPUNCT_LC_utf8(p) isPUNCT_LC_uvchr(utf8_to_uvchr(p, 0))
+
+#define isPSXSPC_LC_utf8(c) (isSPACE_LC_utf8(c) ||(c) == '\f')
+#define isBLANK_LC_utf8(c) isBLANK(c) /* could be wrong */
+
+#ifdef EBCDIC
+# ifdef PERL_IMPLICIT_CONTEXT
+# define toCTRL(c) Perl_ebcdic_control(aTHX_ c)
+# else
+# define toCTRL Perl_ebcdic_control
+# endif
+#else
+ /* This conversion works both ways, strangely enough. */
+# define toCTRL(c) (toUPPER(c) ^ 64)
+#endif
+
+/* Line numbers are unsigned, 32 bits. */
+typedef U32 line_t;
+#define NOLINE ((line_t) 4294967295UL)
+
+
+/*
+=head1 Memory Management
+
+=for apidoc Am|void|Newx|void* ptr|int nitems|type
+The XSUB-writer's interface to the C C<malloc> function.
+
+In 5.9.3, Newx() and friends replace the older New() API, and drops
+the first parameter, I<x>, a debug aid which allowed callers to identify
+themselves. This aid has been superseded by a new build option,
+PERL_MEM_LOG (see L<perlhack/PERL_MEM_LOG>). The older API is still
+there for use in XS modules supporting older perls.
+
+=for apidoc Am|void|Newxc|void* ptr|int nitems|type|cast
+The XSUB-writer's interface to the C C<malloc> function, with
+cast. See also C<Newx>.
+
+=for apidoc Am|void|Newxz|void* ptr|int nitems|type
+The XSUB-writer's interface to the C C<malloc> function. The allocated
+memory is zeroed with C<memzero>. See also C<Newx>.
+
+=for apidoc Am|void|Renew|void* ptr|int nitems|type
+The XSUB-writer's interface to the C C<realloc> function.
+
+=for apidoc Am|void|Renewc|void* ptr|int nitems|type|cast
+The XSUB-writer's interface to the C C<realloc> function, with
+cast.
+
+=for apidoc Am|void|Safefree|void* ptr
+The XSUB-writer's interface to the C C<free> function.
+
+=for apidoc Am|void|Move|void* src|void* dest|int nitems|type
+The XSUB-writer's interface to the C C<memmove> function. The C<src> is the
+source, C<dest> is the destination, C<nitems> is the number of items, and C<type> is
+the type. Can do overlapping moves. See also C<Copy>.
+
+=for apidoc Am|void *|MoveD|void* src|void* dest|int nitems|type
+Like C<Move> but returns dest. Useful for encouraging compilers to tail-call
+optimise.
+
+=for apidoc Am|void|Copy|void* src|void* dest|int nitems|type
+The XSUB-writer's interface to the C C<memcpy> function. The C<src> is the
+source, C<dest> is the destination, C<nitems> is the number of items, and C<type> is
+the type. May fail on overlapping copies. See also C<Move>.
+
+=for apidoc Am|void *|CopyD|void* src|void* dest|int nitems|type
+
+Like C<Copy> but returns dest. Useful for encouraging compilers to tail-call
+optimise.
+
+=for apidoc Am|void|Zero|void* dest|int nitems|type
+
+The XSUB-writer's interface to the C C<memzero> function. The C<dest> is the
+destination, C<nitems> is the number of items, and C<type> is the type.
+
+=for apidoc Am|void *|ZeroD|void* dest|int nitems|type
+
+Like C<Zero> but returns dest. Useful for encouraging compilers to tail-call
+optimise.
+
+=for apidoc Am|void|StructCopy|type src|type dest|type
+This is an architecture-independent macro to copy one structure to another.
+
+=for apidoc Am|void|PoisonWith|void* dest|int nitems|type|U8 byte
+
+Fill up memory with a byte pattern (a byte repeated over and over
+again) that hopefully catches attempts to access uninitialized memory.
+
+=for apidoc Am|void|PoisonNew|void* dest|int nitems|type
+
+PoisonWith(0xAB) for catching access to allocated but uninitialized memory.
+
+=for apidoc Am|void|PoisonFree|void* dest|int nitems|type
+
+PoisonWith(0xEF) for catching access to freed memory.
+
+=for apidoc Am|void|Poison|void* dest|int nitems|type
+
+PoisonWith(0xEF) for catching access to freed memory.
+
+=cut */
+
+/* Maintained for backwards-compatibility only. Use newSV() instead. */
+#ifndef PERL_CORE
+#define NEWSV(x,len) newSV(len)
+#endif
+
+#define MEM_SIZE_MAX ((MEM_SIZE)~0)
+
+/* The +0.0 in MEM_WRAP_CHECK_ is an attempt to foil
+ * overly eager compilers that will bleat about e.g.
+ * (U16)n > (size_t)~0/sizeof(U16) always being false. */
+#ifdef PERL_MALLOC_WRAP
+#define MEM_WRAP_CHECK(n,t) MEM_WRAP_CHECK_1(n,t,PL_memory_wrap)
+#define MEM_WRAP_CHECK_1(n,t,a) \
+ (void)(sizeof(t) > 1 && ((MEM_SIZE)(n)+0.0) > MEM_SIZE_MAX/sizeof(t) && (Perl_croak_nocontext("%s",(a)),0))
+#define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t),
+
+#define PERL_STRLEN_ROUNDUP(n) ((void)(((n) > MEM_SIZE_MAX - 2 * PERL_STRLEN_ROUNDUP_QUANTUM) ? (Perl_croak_nocontext("%s",PL_memory_wrap),0):0),((n-1+PERL_STRLEN_ROUNDUP_QUANTUM)&~((MEM_SIZE)PERL_STRLEN_ROUNDUP_QUANTUM-1)))
+
+#else
+
+#define MEM_WRAP_CHECK(n,t)
+#define MEM_WRAP_CHECK_1(n,t,a)
+#define MEM_WRAP_CHECK_2(n,t,a,b)
+#define MEM_WRAP_CHECK_(n,t)
+
+#define PERL_STRLEN_ROUNDUP(n) (((n-1+PERL_STRLEN_ROUNDUP_QUANTUM)&~((MEM_SIZE)PERL_STRLEN_ROUNDUP_QUANTUM-1)))
+
+#endif
+
+#ifdef PERL_MEM_LOG
+/*
+ * If PERL_MEM_LOG is defined, all Newx()s, Renew()s, and Safefree()s
+ * go through functions, which are handy for debugging breakpoints, but
+ * which more importantly get the immediate calling environment (file and
+ * line number, and C function name if available) passed in. This info can
+ * then be used for logging the calls, for which one gets a sample
+ * implementation if PERL_MEM_LOG_STDERR is defined.
+ *
+ * Known problems:
+ * - all memory allocs do not get logged, only those
+ * that go through Newx() and derivatives (while all
+ * Safefrees do get logged)
+ * - __FILE__ and __LINE__ do not work everywhere
+ * - __func__ or __FUNCTION__ even less so
+ * - I think more goes on after the perlio frees but
+ * the thing is that STDERR gets closed (as do all
+ * the file descriptors)
+ * - no deeper calling stack than the caller of the Newx()
+ * or the kind, but do I look like a C reflection/introspection
+ * utility to you?
+ * - the function prototypes for the logging functions
+ * probably should maybe be somewhere else than handy.h
+ * - one could consider inlining (macrofying) the logging
+ * for speed, but I am too lazy
+ * - one could imagine recording the allocations in a hash,
+ * (keyed by the allocation address?), and maintain that
+ * through reallocs and frees, but how to do that without
+ * any News() happening...?
+ */
+
+PERL_EXPORT_C Malloc_t Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname);
+
+PERL_EXPORT_C Malloc_t Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname);
+
+PERL_EXPORT_C Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname);
+
+# ifdef PERL_CORE
+# ifdef PERL_MEM_LOG_STDERR
+enum mem_log_type {
+ MLT_ALLOC,
+ MLT_REALLOC,
+ MLT_FREE,
+ MLT_NEW_SV,
+ MLT_DEL_SV
+};
+# endif
+# if defined(PERL_IN_SV_C) /* those are only used in sv.c */
+void Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname);
+void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname);
+# endif
+# endif
+
+#endif
+
+#ifdef PERL_MEM_LOG
+#define MEM_LOG_ALLOC(n,t,a) Perl_mem_log_alloc(n,sizeof(t),STRINGIFY(t),a,__FILE__,__LINE__,FUNCTION__)
+#define MEM_LOG_REALLOC(n,t,v,a) Perl_mem_log_realloc(n,sizeof(t),STRINGIFY(t),v,a,__FILE__,__LINE__,FUNCTION__)
+#define MEM_LOG_FREE(a) Perl_mem_log_free(a,__FILE__,__LINE__,FUNCTION__)
+#endif
+
+#ifndef MEM_LOG_ALLOC
+#define MEM_LOG_ALLOC(n,t,a) (a)
+#endif
+#ifndef MEM_LOG_REALLOC
+#define MEM_LOG_REALLOC(n,t,v,a) (a)
+#endif
+#ifndef MEM_LOG_FREE
+#define MEM_LOG_FREE(a) (a)
+#endif
+
+#define Newx(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_ALLOC(n,t,safemalloc((MEM_SIZE)((n)*sizeof(t))))))
+#define Newxc(v,n,t,c) (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_ALLOC(n,t,safemalloc((MEM_SIZE)((n)*sizeof(t))))))
+#define Newxz(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_ALLOC(n,t,safecalloc((n),sizeof(t)))))
+
+#ifndef PERL_CORE
+/* pre 5.9.x compatibility */
+#define New(x,v,n,t) Newx(v,n,t)
+#define Newc(x,v,n,t,c) Newxc(v,n,t,c)
+#define Newz(x,v,n,t) Newxz(v,n,t)
+#endif
+
+#define Renew(v,n,t) \
+ (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))))
+#define Renewc(v,n,t,c) \
+ (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))))
+
+#ifdef PERL_POISON
+#define Safefree(d) \
+ ((d) ? (void)(safefree(MEM_LOG_FREE((Malloc_t)(d))), Poison(&(d), 1, Malloc_t)) : (void) 0)
+#else
+#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
+#endif
+
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memzero((char*)(d), (n) * sizeof(t)))
+
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#ifdef HAS_MEMSET
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)))
+#else
+/* Using bzero(), which returns void. */
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)),d)
+#endif
+
+#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
+#define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB)
+#define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF)
+#define Poison(d,n,t) PoisonFree(d,n,t)
+
+#ifdef USE_STRUCT_COPY
+#define StructCopy(s,d,t) (*((t*)(d)) = *((t*)(s)))
+#else
+#define StructCopy(s,d,t) Copy(s,d,1,t)
+#endif
+
+#define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
+
+#ifdef NEED_VA_COPY
+# ifdef va_copy
+# define Perl_va_copy(s, d) va_copy(d, s)
+# else
+# if defined(__va_copy)
+# define Perl_va_copy(s, d) __va_copy(d, s)
+# else
+# define Perl_va_copy(s, d) Copy(s, d, 1, va_list)
+# endif
+# endif
+#endif
+
+/* convenience debug macros */
+#ifdef USE_ITHREADS
+#define pTHX_FORMAT "Perl interpreter: 0x%p"
+#define pTHX__FORMAT ", Perl interpreter: 0x%p"
+#define pTHX_VALUE_ (void *)my_perl,
+#define pTHX_VALUE (void *)my_perl
+#define pTHX__VALUE_ ,(void *)my_perl,
+#define pTHX__VALUE ,(void *)my_perl
+#else
+#define pTHX_FORMAT
+#define pTHX__FORMAT
+#define pTHX_VALUE_
+#define pTHX_VALUE
+#define pTHX__VALUE_
+#define pTHX__VALUE
+#endif /* USE_ITHREADS */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/hv.h b/Master/tlpkg/tlperl.straw/lib/CORE/hv.h
new file mode 100755
index 00000000000..3c16a385bc2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/hv.h
@@ -0,0 +1,577 @@
+/* hv.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2008, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/* entry in hash value chain */
+struct he {
+ /* Keep hent_next first in this structure, because sv_free_arenas take
+ advantage of this to share code between the he arenas and the SV
+ body arenas */
+ HE *hent_next; /* next entry in chain */
+ HEK *hent_hek; /* hash key */
+ union {
+ SV *hent_val; /* scalar value that was hashed */
+ Size_t hent_refcount; /* references for this shared hash key */
+ } he_valu;
+};
+
+/* hash key -- defined separately for use as shared pointer */
+struct hek {
+ U32 hek_hash; /* hash of key */
+ I32 hek_len; /* length of hash key */
+ char hek_key[1]; /* variable-length hash key */
+ /* the hash-key is \0-terminated */
+ /* after the \0 there is a byte for flags, such as whether the key
+ is UTF-8 */
+};
+
+struct shared_he {
+ struct he shared_he_he;
+ struct hek shared_he_hek;
+};
+
+/* Subject to change.
+ Don't access this directly.
+ Use the funcs in mro.c
+*/
+
+struct mro_alg {
+ AV *(*resolve)(pTHX_ HV* stash, U32 level);
+ const char *name;
+ U16 length;
+ U16 kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */
+ U32 hash; /* or 0 */
+};
+
+struct mro_meta {
+ /* repurposed as a hash holding the different MROs private data. */
+ AV *mro_linear_dfs; /* cached dfs @ISA linearization */
+ /* repurposed as a pointer directly to the current MROs private data. */
+ AV *mro_linear_c3; /* cached c3 @ISA linearization */
+ HV *mro_nextmethod; /* next::method caching */
+ U32 cache_gen; /* Bumping this invalidates our method cache */
+ U32 pkg_gen; /* Bumps when local methods/@ISA change */
+ const struct mro_alg *mro_which; /* which mro alg is in use? */
+ HV *isa; /* Everything this class @ISA */
+};
+
+#define MRO_GET_PRIVATE_DATA(smeta, which) \
+ (((smeta)->mro_which && (which) == (smeta)->mro_which) \
+ ? MUTABLE_SV((smeta)->mro_linear_c3) \
+ : Perl_mro_get_private_data(aTHX_ (smeta), (which)))
+
+/* Subject to change.
+ Don't access this directly.
+*/
+
+struct xpvhv_aux {
+ HEK *xhv_name; /* name, if a symbol table */
+ AV *xhv_backreferences; /* back references for weak references */
+ HE *xhv_eiter; /* current entry of iterator */
+ I32 xhv_riter; /* current root of iterator */
+ struct mro_meta *xhv_mro_meta;
+};
+
+/* hash structure: */
+/* This structure must match the beginning of struct xpvmg in sv.h. */
+struct xpvhv {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xhv_fill; /* how full xhv_array currently is */
+ STRLEN xhv_max; /* subscript of last element of xhv_array */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+};
+
+#define xhv_keys xiv_u.xivu_iv
+
+typedef struct {
+ STRLEN xhv_fill; /* how full xhv_array currently is */
+ STRLEN xhv_max; /* subscript of last element of xhv_array */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+} xpvhv_allocated;
+
+/* hash a key */
+/* FYI: This is the "One-at-a-Time" algorithm by Bob Jenkins
+ * from requirements by Colin Plumb.
+ * (http://burtleburtle.net/bob/hash/doobs.html) */
+/* The use of a temporary pointer and the casting games
+ * is needed to serve the dual purposes of
+ * (a) the hashed data being interpreted as "unsigned char" (new since 5.8,
+ * a "char" can be either signed or unsigned, depending on the compiler)
+ * (b) catering for old code that uses a "char"
+ *
+ * The "hash seed" feature was added in Perl 5.8.1 to perturb the results
+ * to avoid "algorithmic complexity attacks".
+ *
+ * If USE_HASH_SEED is defined, hash randomisation is done by default
+ * If USE_HASH_SEED_EXPLICIT is defined, hash randomisation is done
+ * only if the environment variable PERL_HASH_SEED is set.
+ * For maximal control, one can define PERL_HASH_SEED.
+ * (see also perl.c:perl_parse()).
+ */
+#ifndef PERL_HASH_SEED
+# if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
+# define PERL_HASH_SEED PL_hash_seed
+# else
+# define PERL_HASH_SEED 0
+# endif
+#endif
+#define PERL_HASH(hash,str,len) \
+ STMT_START { \
+ register const char * const s_PeRlHaSh_tmp = str; \
+ register const unsigned char *s_PeRlHaSh = (const unsigned char *)s_PeRlHaSh_tmp; \
+ register I32 i_PeRlHaSh = len; \
+ register U32 hash_PeRlHaSh = PERL_HASH_SEED; \
+ while (i_PeRlHaSh--) { \
+ hash_PeRlHaSh += *s_PeRlHaSh++; \
+ hash_PeRlHaSh += (hash_PeRlHaSh << 10); \
+ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 6); \
+ } \
+ hash_PeRlHaSh += (hash_PeRlHaSh << 3); \
+ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 11); \
+ (hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \
+ } STMT_END
+
+/* Only hv.c and mod_perl should be doing this. */
+#ifdef PERL_HASH_INTERNAL_ACCESS
+#define PERL_HASH_INTERNAL(hash,str,len) \
+ STMT_START { \
+ register const char * const s_PeRlHaSh_tmp = str; \
+ register const unsigned char *s_PeRlHaSh = (const unsigned char *)s_PeRlHaSh_tmp; \
+ register I32 i_PeRlHaSh = len; \
+ register U32 hash_PeRlHaSh = PL_rehash_seed; \
+ while (i_PeRlHaSh--) { \
+ hash_PeRlHaSh += *s_PeRlHaSh++; \
+ hash_PeRlHaSh += (hash_PeRlHaSh << 10); \
+ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 6); \
+ } \
+ hash_PeRlHaSh += (hash_PeRlHaSh << 3); \
+ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 11); \
+ (hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \
+ } STMT_END
+#endif
+
+/*
+=head1 Hash Manipulation Functions
+
+=for apidoc AmU||HEf_SVKEY
+This flag, used in the length slot of hash entries and magic structures,
+specifies the structure contains an C<SV*> pointer where a C<char*> pointer
+is to be expected. (For information only--not to be used).
+
+=head1 Handy Values
+
+=for apidoc AmU||Nullhv
+Null HV pointer.
+
+=head1 Hash Manipulation Functions
+
+=for apidoc Am|char*|HvNAME|HV* stash
+Returns the package name of a stash, or NULL if C<stash> isn't a stash.
+See C<SvSTASH>, C<CvSTASH>.
+
+=for apidoc Am|void*|HeKEY|HE* he
+Returns the actual pointer stored in the key slot of the hash entry. The
+pointer may be either C<char*> or C<SV*>, depending on the value of
+C<HeKLEN()>. Can be assigned to. The C<HePV()> or C<HeSVKEY()> macros are
+usually preferable for finding the value of a key.
+
+=for apidoc Am|STRLEN|HeKLEN|HE* he
+If this is negative, and amounts to C<HEf_SVKEY>, it indicates the entry
+holds an C<SV*> key. Otherwise, holds the actual length of the key. Can
+be assigned to. The C<HePV()> macro is usually preferable for finding key
+lengths.
+
+=for apidoc Am|SV*|HeVAL|HE* he
+Returns the value slot (type C<SV*>) stored in the hash entry.
+
+=for apidoc Am|U32|HeHASH|HE* he
+Returns the computed hash stored in the hash entry.
+
+=for apidoc Am|char*|HePV|HE* he|STRLEN len
+Returns the key slot of the hash entry as a C<char*> value, doing any
+necessary dereferencing of possibly C<SV*> keys. The length of the string
+is placed in C<len> (this is a macro, so do I<not> use C<&len>). If you do
+not care about what the length of the key is, you may use the global
+variable C<PL_na>, though this is rather less efficient than using a local
+variable. Remember though, that hash keys in perl are free to contain
+embedded nulls, so using C<strlen()> or similar is not a good way to find
+the length of hash keys. This is very similar to the C<SvPV()> macro
+described elsewhere in this document. See also C<HeUTF8>.
+
+If you are using C<HePV> to get values to pass to C<newSVpvn()> to create a
+new SV, you should consider using C<newSVhek(HeKEY_hek(he))> as it is more
+efficient.
+
+=for apidoc Am|char*|HeUTF8|HE* he|STRLEN len
+Returns whether the C<char *> value returned by C<HePV> is encoded in UTF-8,
+doing any necessary dereferencing of possibly C<SV*> keys. The value returned
+will be 0 or non-0, not necessarily 1 (or even a value with any low bits set),
+so B<do not> blindly assign this to a C<bool> variable, as C<bool> may be a
+typedef for C<char>.
+
+=for apidoc Am|SV*|HeSVKEY|HE* he
+Returns the key as an C<SV*>, or C<NULL> if the hash entry does not
+contain an C<SV*> key.
+
+=for apidoc Am|SV*|HeSVKEY_force|HE* he
+Returns the key as an C<SV*>. Will create and return a temporary mortal
+C<SV*> if the hash entry contains only a C<char*> key.
+
+=for apidoc Am|SV*|HeSVKEY_set|HE* he|SV* sv
+Sets the key to a given C<SV*>, taking care to set the appropriate flags to
+indicate the presence of an C<SV*> key, and returns the same
+C<SV*>.
+
+=cut
+*/
+
+/* these hash entry flags ride on hent_klen (for use only in magic/tied HVs) */
+#define HEf_SVKEY -2 /* hent_key is an SV* */
+
+
+#define Nullhv Null(HV*)
+#define HvARRAY(hv) ((hv)->sv_u.svu_hash)
+#define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill
+#define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max
+/* This quite intentionally does no flag checking first. That's your
+ responsibility. */
+#define HvAUX(hv) ((struct xpvhv_aux*)&(HvARRAY(hv)[HvMAX(hv)+1]))
+#define HvRITER(hv) (*Perl_hv_riter_p(aTHX_ MUTABLE_HV(hv)))
+#define HvEITER(hv) (*Perl_hv_eiter_p(aTHX_ MUTABLE_HV(hv)))
+#define HvRITER_set(hv,r) Perl_hv_riter_set(aTHX_ MUTABLE_HV(hv), r)
+#define HvEITER_set(hv,e) Perl_hv_eiter_set(aTHX_ MUTABLE_HV(hv), e)
+#define HvRITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
+#define HvEITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : NULL)
+#define HvNAME(hv) HvNAME_get(hv)
+
+/* Checking that hv is a valid package stash is the
+ caller's responsibility */
+#define HvMROMETA(hv) (HvAUX(hv)->xhv_mro_meta \
+ ? HvAUX(hv)->xhv_mro_meta \
+ : Perl_mro_meta_init(aTHX_ hv))
+
+/* FIXME - all of these should use a UTF8 aware API, which should also involve
+ getting the length. */
+/* This macro may go away without notice. */
+#define HvNAME_HEK(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_name : NULL)
+#define HvNAME_get(hv) ((SvOOK(hv) && (HvAUX(hv)->xhv_name)) \
+ ? HEK_KEY(HvAUX(hv)->xhv_name) : NULL)
+#define HvNAMELEN_get(hv) ((SvOOK(hv) && (HvAUX(hv)->xhv_name)) \
+ ? HEK_LEN(HvAUX(hv)->xhv_name) : 0)
+
+/* the number of keys (including any placeholers) */
+#define XHvTOTALKEYS(xhv) ((xhv)->xhv_keys)
+
+/*
+ * HvKEYS gets the number of keys that actually exist(), and is provided
+ * for backwards compatibility with old XS code. The core uses HvUSEDKEYS
+ * (keys, excluding placeholdes) and HvTOTALKEYS (including placeholders)
+ */
+#define HvKEYS(hv) HvUSEDKEYS(hv)
+#define HvUSEDKEYS(hv) (HvTOTALKEYS(hv) - HvPLACEHOLDERS_get(hv))
+#define HvTOTALKEYS(hv) XHvTOTALKEYS((XPVHV*) SvANY(hv))
+#define HvPLACEHOLDERS(hv) (*Perl_hv_placeholders_p(aTHX_ MUTABLE_HV(hv)))
+#define HvPLACEHOLDERS_get(hv) (SvMAGIC(hv) ? Perl_hv_placeholders_get(aTHX_ (HV *)hv) : 0)
+#define HvPLACEHOLDERS_set(hv,p) Perl_hv_placeholders_set(aTHX_ MUTABLE_HV(hv), p)
+
+#define HvSHAREKEYS(hv) (SvFLAGS(hv) & SVphv_SHAREKEYS)
+#define HvSHAREKEYS_on(hv) (SvFLAGS(hv) |= SVphv_SHAREKEYS)
+#define HvSHAREKEYS_off(hv) (SvFLAGS(hv) &= ~SVphv_SHAREKEYS)
+
+/* This is an optimisation flag. It won't be set if all hash keys have a 0
+ * flag. Currently the only flags relate to utf8.
+ * Hence it won't be set if all keys are 8 bit only. It will be set if any key
+ * is utf8 (including 8 bit keys that were entered as utf8, and need upgrading
+ * when retrieved during iteration. It may still be set when there are no longer
+ * any utf8 keys.
+ * See HVhek_ENABLEHVKFLAGS for the trigger.
+ */
+#define HvHASKFLAGS(hv) (SvFLAGS(hv) & SVphv_HASKFLAGS)
+#define HvHASKFLAGS_on(hv) (SvFLAGS(hv) |= SVphv_HASKFLAGS)
+#define HvHASKFLAGS_off(hv) (SvFLAGS(hv) &= ~SVphv_HASKFLAGS)
+
+#define HvLAZYDEL(hv) (SvFLAGS(hv) & SVphv_LAZYDEL)
+#define HvLAZYDEL_on(hv) (SvFLAGS(hv) |= SVphv_LAZYDEL)
+#define HvLAZYDEL_off(hv) (SvFLAGS(hv) &= ~SVphv_LAZYDEL)
+
+#define HvREHASH(hv) (SvFLAGS(hv) & SVphv_REHASH)
+#define HvREHASH_on(hv) (SvFLAGS(hv) |= SVphv_REHASH)
+#define HvREHASH_off(hv) (SvFLAGS(hv) &= ~SVphv_REHASH)
+
+#define Nullhe Null(HE*)
+#define HeNEXT(he) (he)->hent_next
+#define HeKEY_hek(he) (he)->hent_hek
+#define HeKEY(he) HEK_KEY(HeKEY_hek(he))
+#define HeKEY_sv(he) (*(SV**)HeKEY(he))
+#define HeKLEN(he) HEK_LEN(HeKEY_hek(he))
+#define HeKUTF8(he) HEK_UTF8(HeKEY_hek(he))
+#define HeKWASUTF8(he) HEK_WASUTF8(HeKEY_hek(he))
+#define HeKREHASH(he) HEK_REHASH(HeKEY_hek(he))
+#define HeKLEN_UTF8(he) (HeKUTF8(he) ? -HeKLEN(he) : HeKLEN(he))
+#define HeKFLAGS(he) HEK_FLAGS(HeKEY_hek(he))
+#define HeVAL(he) (he)->he_valu.hent_val
+#define HeHASH(he) HEK_HASH(HeKEY_hek(he))
+#define HePV(he,lp) ((HeKLEN(he) == HEf_SVKEY) ? \
+ SvPV(HeKEY_sv(he),lp) : \
+ ((lp = HeKLEN(he)), HeKEY(he)))
+#define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
+ SvUTF8(HeKEY_sv(he)) : \
+ (U32)HeKUTF8(he))
+
+#define HeSVKEY(he) ((HeKEY(he) && \
+ HeKLEN(he) == HEf_SVKEY) ? \
+ HeKEY_sv(he) : NULL)
+
+#define HeSVKEY_force(he) (HeKEY(he) ? \
+ ((HeKLEN(he) == HEf_SVKEY) ? \
+ HeKEY_sv(he) : \
+ newSVpvn_flags(HeKEY(he), \
+ HeKLEN(he), SVs_TEMP)) : \
+ &PL_sv_undef)
+#define HeSVKEY_set(he,sv) ((HeKLEN(he) = HEf_SVKEY), (HeKEY_sv(he) = sv))
+
+#define Nullhek Null(HEK*)
+#define HEK_BASESIZE STRUCT_OFFSET(HEK, hek_key[0])
+#define HEK_HASH(hek) (hek)->hek_hash
+#define HEK_LEN(hek) (hek)->hek_len
+#define HEK_KEY(hek) (hek)->hek_key
+#define HEK_FLAGS(hek) (*((unsigned char *)(HEK_KEY(hek))+HEK_LEN(hek)+1))
+
+#define HVhek_UTF8 0x01 /* Key is utf8 encoded. */
+#define HVhek_WASUTF8 0x02 /* Key is bytes here, but was supplied as utf8. */
+#define HVhek_REHASH 0x04 /* This key is in an hv using a custom HASH . */
+#define HVhek_UNSHARED 0x08 /* This key isn't a shared hash key. */
+#define HVhek_FREEKEY 0x100 /* Internal flag to say key is malloc()ed. */
+#define HVhek_PLACEHOLD 0x200 /* Internal flag to create placeholder.
+ * (may change, but Storable is a core module) */
+#define HVhek_KEYCANONICAL 0x400 /* Internal flag - key is in canonical form.
+ If the string is UTF-8, it cannot be
+ converted to bytes. */
+#define HVhek_MASK 0xFF
+
+/* Which flags enable HvHASKFLAGS? Somewhat a hack on a hack, as
+ HVhek_REHASH is only needed because the rehash flag has to be duplicated
+ into all keys as hv_iternext has no access to the hash flags. At this
+ point Storable's tests get upset, because sometimes hashes are "keyed"
+ and sometimes not, depending on the order of data insertion, and whether
+ it triggered rehashing. So currently HVhek_REHASH is exempt.
+ Similarly UNSHARED
+*/
+
+#define HVhek_ENABLEHVKFLAGS (HVhek_MASK & ~(HVhek_REHASH|HVhek_UNSHARED))
+
+#define HEK_UTF8(hek) (HEK_FLAGS(hek) & HVhek_UTF8)
+#define HEK_UTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_UTF8)
+#define HEK_UTF8_off(hek) (HEK_FLAGS(hek) &= ~HVhek_UTF8)
+#define HEK_WASUTF8(hek) (HEK_FLAGS(hek) & HVhek_WASUTF8)
+#define HEK_WASUTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_WASUTF8)
+#define HEK_WASUTF8_off(hek) (HEK_FLAGS(hek) &= ~HVhek_WASUTF8)
+#define HEK_REHASH(hek) (HEK_FLAGS(hek) & HVhek_REHASH)
+#define HEK_REHASH_on(hek) (HEK_FLAGS(hek) |= HVhek_REHASH)
+
+/* calculate HV array allocation */
+#ifndef PERL_USE_LARGE_HV_ALLOC
+/* Default to allocating the correct size - default to assuming that malloc()
+ is not broken and is efficient at allocating blocks sized at powers-of-two.
+*/
+# define PERL_HV_ARRAY_ALLOC_BYTES(size) ((size) * sizeof(HE*))
+#else
+# define MALLOC_OVERHEAD 16
+# define PERL_HV_ARRAY_ALLOC_BYTES(size) \
+ (((size) < 64) \
+ ? (size) * sizeof(HE*) \
+ : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD)
+#endif
+
+/* Flags for hv_iternext_flags. */
+#define HV_ITERNEXT_WANTPLACEHOLDERS 0x01 /* Don't skip placeholders. */
+
+#define hv_iternext(hv) hv_iternext_flags(hv, 0)
+#define hv_magic(hv, gv, how) sv_magic(MUTABLE_SV(hv), MUTABLE_SV(gv), how, NULL, 0)
+
+/* available as a function in hv.c */
+#define Perl_sharepvn(sv, len, hash) HEK_KEY(share_hek(sv, len, hash))
+#define sharepvn(sv, len, hash) Perl_sharepvn(sv, len, hash)
+
+#define share_hek_hek(hek) \
+ (++(((struct shared_he *)(((char *)hek) \
+ - STRUCT_OFFSET(struct shared_he, \
+ shared_he_hek))) \
+ ->shared_he_he.he_valu.hent_refcount), \
+ hek)
+
+#define hv_store_ent(hv, keysv, val, hash) \
+ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISSTORE, \
+ (val), (hash)))
+
+#define hv_exists_ent(hv, keysv, hash) \
+ (hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISEXISTS, 0, (hash)) \
+ ? TRUE : FALSE)
+#define hv_fetch_ent(hv, keysv, lval, hash) \
+ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, \
+ ((lval) ? HV_FETCH_LVALUE : 0), NULL, (hash)))
+#define hv_delete_ent(hv, key, flags, hash) \
+ (MUTABLE_SV(hv_common((hv), (key), NULL, 0, 0, (flags) | HV_DELETE, \
+ NULL, (hash))))
+
+#define hv_store_flags(hv, key, klen, val, hash, flags) \
+ ((SV**) hv_common((hv), NULL, (key), (klen), (flags), \
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), \
+ (hash)))
+
+#define hv_store(hv, key, klen, val, hash) \
+ ((SV**) hv_common_key_len((hv), (key), (klen), \
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), \
+ (val), (hash)))
+
+#define hv_exists(hv, key, klen) \
+ (hv_common_key_len((hv), (key), (klen), HV_FETCH_ISEXISTS, NULL, 0) \
+ ? TRUE : FALSE)
+
+#define hv_fetch(hv, key, klen, lval) \
+ ((SV**) hv_common_key_len((hv), (key), (klen), (lval) \
+ ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \
+ : HV_FETCH_JUST_SV, NULL, 0))
+
+#define hv_delete(hv, key, klen, flags) \
+ (MUTABLE_SV(hv_common_key_len((hv), (key), (klen), \
+ (flags) | HV_DELETE, NULL, 0)))
+
+/* This refcounted he structure is used for storing the hints used for lexical
+ pragmas. Without threads, it's basically struct he + refcount.
+ With threads, life gets more complex as the structure needs to be shared
+ between threads (because it hangs from OPs, which are shared), hence the
+ alternate definition and mutex. */
+
+struct refcounted_he;
+
+#ifdef PERL_CORE
+
+/* Gosh. This really isn't a good name any longer. */
+struct refcounted_he {
+ struct refcounted_he *refcounted_he_next; /* next entry in chain */
+#ifdef USE_ITHREADS
+ U32 refcounted_he_hash;
+ U32 refcounted_he_keylen;
+#else
+ HEK *refcounted_he_hek; /* hint key */
+#endif
+ union {
+ IV refcounted_he_u_iv;
+ UV refcounted_he_u_uv;
+ STRLEN refcounted_he_u_len;
+ void *refcounted_he_u_ptr; /* Might be useful in future */
+ } refcounted_he_val;
+ U32 refcounted_he_refcnt; /* reference count */
+ /* First byte is flags. Then NUL-terminated value. Then for ithreads,
+ non-NUL terminated key. */
+ char refcounted_he_data[1];
+};
+
+/* Flag bits are HVhek_UTF8, HVhek_WASUTF8, then */
+#define HVrhek_undef 0x00 /* Value is undef. */
+#define HVrhek_delete 0x10 /* Value is placeholder - signifies delete. */
+#define HVrhek_IV 0x20 /* Value is IV. */
+#define HVrhek_UV 0x30 /* Value is UV. */
+#define HVrhek_PV 0x40 /* Value is a (byte) string. */
+#define HVrhek_PV_UTF8 0x50 /* Value is a (utf8) string. */
+/* Two spare. As these have to live in the optree, you can't store anything
+ interpreter specific, such as SVs. :-( */
+#define HVrhek_typemask 0x70
+
+#ifdef USE_ITHREADS
+/* A big expression to find the key offset */
+#define REF_HE_KEY(chain) \
+ ((((chain->refcounted_he_data[0] & 0x60) == 0x40) \
+ ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \
+ + 1 + chain->refcounted_he_data)
+#endif
+
+# ifdef USE_ITHREADS
+# define HINTS_REFCNT_LOCK MUTEX_LOCK(&PL_hints_mutex)
+# define HINTS_REFCNT_UNLOCK MUTEX_UNLOCK(&PL_hints_mutex)
+# else
+# define HINTS_REFCNT_LOCK NOOP
+# define HINTS_REFCNT_UNLOCK NOOP
+# endif
+#endif
+
+#ifdef USE_ITHREADS
+# define HINTS_REFCNT_INIT MUTEX_INIT(&PL_hints_mutex)
+# define HINTS_REFCNT_TERM MUTEX_DESTROY(&PL_hints_mutex)
+#else
+# define HINTS_REFCNT_INIT NOOP
+# define HINTS_REFCNT_TERM NOOP
+#endif
+
+/* Hash actions
+ * Passed in PERL_MAGIC_uvar calls
+ */
+#define HV_DISABLE_UVAR_XKEY 0x01
+/* We need to ensure that these don't clash with G_DISCARD, which is 2, as it
+ is documented as being passed to hv_delete(). */
+#define HV_FETCH_ISSTORE 0x04
+#define HV_FETCH_ISEXISTS 0x08
+#define HV_FETCH_LVALUE 0x10
+#define HV_FETCH_JUST_SV 0x20
+#define HV_DELETE 0x40
+
+/*
+=for apidoc newHV
+
+Creates a new HV. The reference count is set to 1.
+
+=cut
+*/
+
+#define newHV() MUTABLE_HV(newSV_type(SVt_PVHV))
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/intrpvar.h b/Master/tlpkg/tlperl.straw/lib/CORE/intrpvar.h
new file mode 100755
index 00000000000..869316bad94
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/intrpvar.h
@@ -0,0 +1,704 @@
+/* intrpvar.h
+ *
+ * Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ * 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+=head1 Per-Interpreter Variables
+*/
+
+/* These variables are per-interpreter in threaded/multiplicity builds,
+ * global otherwise.
+
+ * Don't forget to re-run embed.pl to propagate changes! */
+
+/* New variables must be added to the very end for binary compatibility.
+ * XSUB.h provides wrapper functions via perlapi.h that make this
+ * irrelevant, but not all code may be expected to #include XSUB.h. */
+
+/* Don't forget to add your variable also to perl_clone()! */
+
+/* The 'I' prefix is only needed for vars that need appropriate #defines
+ * generated when built with or without MULTIPLICITY. It is also used
+ * to generate the appropriate export list for win32.
+ *
+ * When building without MULTIPLICITY, these variables will be truly global.
+ *
+ * Important ones in the first cache line (if alignment is done right) */
+
+PERLVAR(Istack_sp, SV **) /* top of the stack */
+#ifdef OP_IN_REGISTER
+PERLVAR(Iopsave, OP *)
+#else
+PERLVAR(Iop, OP *) /* currently executing op */
+#endif
+PERLVAR(Icurpad, SV **) /* active pad (lexicals+tmps) */
+
+PERLVAR(Istack_base, SV **)
+PERLVAR(Istack_max, SV **)
+
+PERLVAR(Iscopestack, I32 *) /* scopes we've ENTERed */
+PERLVAR(Iscopestack_ix, I32)
+PERLVAR(Iscopestack_max,I32)
+
+PERLVAR(Isavestack, ANY *) /* items that need to be restored when
+ LEAVEing scopes we've ENTERed */
+PERLVAR(Isavestack_ix, I32)
+PERLVAR(Isavestack_max, I32)
+
+PERLVAR(Itmps_stack, SV **) /* mortals we've made */
+PERLVARI(Itmps_ix, I32, -1)
+PERLVARI(Itmps_floor, I32, -1)
+PERLVAR(Itmps_max, I32)
+PERLVAR(Imodcount, I32) /* how much mod()ification in
+ assignment? */
+
+PERLVAR(Imarkstack, I32 *) /* stack_sp locations we're
+ remembering */
+PERLVAR(Imarkstack_ptr, I32 *)
+PERLVAR(Imarkstack_max, I32 *)
+
+PERLVAR(ISv, SV *) /* used to hold temporary values */
+PERLVAR(IXpv, XPV *) /* used to hold temporary values */
+
+/*
+=for apidoc Amn|STRLEN|PL_na
+
+A convenience variable which is typically used with C<SvPV> when one
+doesn't care about the length of the string. It is usually more efficient
+to either declare a local variable and use that instead or to use the
+C<SvPV_nolen> macro.
+
+=cut
+*/
+
+PERLVAR(Ina, STRLEN) /* for use in SvPV when length is
+ Not Applicable */
+
+/* stat stuff */
+PERLVAR(Istatbuf, Stat_t)
+PERLVAR(Istatcache, Stat_t) /* _ */
+PERLVAR(Istatgv, GV *)
+PERLVARI(Istatname, SV *, NULL)
+
+#ifdef HAS_TIMES
+PERLVAR(Itimesbuf, struct tms)
+#endif
+
+/* Fields used by magic variables such as $@, $/ and so on */
+PERLVAR(Icurpm, PMOP *) /* what to do \ interps in REs from */
+
+/*
+=for apidoc mn|SV*|PL_rs
+
+The input record separator - C<$/> in Perl space.
+
+=for apidoc mn|GV*|PL_last_in_gv
+
+The GV which was last used for a filehandle input operation. (C<< <FH> >>)
+
+=for apidoc mn|SV*|PL_ofs_sv
+
+The output field separator - C<$,> in Perl space.
+
+=cut
+*/
+
+PERLVAR(Irs, SV *) /* input record separator $/ */
+PERLVAR(Ilast_in_gv, GV *) /* GV used in last <FH> */
+PERLVAR(Iofs_sv, SV *) /* output field separator $, */
+PERLVAR(Idefoutgv, GV *) /* default FH for output */
+PERLVARI(Ichopset, const char *, " \n-") /* $: */
+PERLVAR(Iformtarget, SV *)
+PERLVAR(Ibodytarget, SV *)
+PERLVAR(Itoptarget, SV *)
+
+/* Stashes */
+PERLVAR(Idefstash, HV *) /* main symbol table */
+PERLVAR(Icurstash, HV *) /* symbol table for current package */
+
+PERLVAR(Irestartop, OP *) /* propagating an error from croak? */
+PERLVAR(Icurcop, COP * VOL)
+PERLVAR(Icurstack, AV *) /* THE STACK */
+PERLVAR(Icurstackinfo, PERL_SI *) /* current stack + context */
+PERLVAR(Imainstack, AV *) /* the stack when nothing funny is
+ happening */
+
+PERLVAR(Itop_env, JMPENV *) /* ptr to current sigjmp environment */
+PERLVAR(Istart_env, JMPENV) /* empty startup sigjmp environment */
+PERLVARI(Ierrors, SV *, NULL) /* outstanding queued errors */
+
+/* statics "owned" by various functions */
+PERLVAR(Ihv_fetch_ent_mh, HE*) /* owned by hv_fetch_ent() */
+
+PERLVAR(Ilastgotoprobe, OP*) /* from pp_ctl.c */
+
+/* sort stuff */
+PERLVAR(Isortcop, OP *) /* user defined sort routine */
+PERLVAR(Isortstash, HV *) /* which is in some package or other */
+PERLVAR(Ifirstgv, GV *) /* $a */
+PERLVAR(Isecondgv, GV *) /* $b */
+
+/* float buffer */
+PERLVAR(Iefloatbuf, char *)
+PERLVAR(Iefloatsize, STRLEN)
+
+/* regex stuff */
+
+PERLVAR(Iscreamfirst, I32 *)
+PERLVAR(Iscreamnext, I32 *)
+PERLVAR(Ilastscream, SV *)
+
+PERLVAR(Ireg_state, struct re_save_state)
+
+PERLVAR(Iregdummy, regnode) /* from regcomp.c */
+
+PERLVARI(Idumpindent, U16, 4) /* number of blanks per dump
+ indentation level */
+
+
+PERLVAR(Iutf8locale, bool) /* utf8 locale detected */
+PERLVARI(Irehash_seed_set, bool, FALSE) /* 582 hash initialized? */
+
+PERLVARA(Icolors,6, char *) /* from regcomp.c */
+
+PERLVARI(Ipeepp, peep_t, MEMBER_TO_FPTR(Perl_peep))
+ /* Pointer to peephole optimizer */
+
+PERLVARI(Imaxscream, I32, -1)
+PERLVARI(Ireginterp_cnt,I32, 0) /* Whether "Regexp" was interpolated. */
+PERLVARI(Iwatchaddr, char **, 0)
+PERLVAR(Iwatchok, char *)
+
+/* the currently active slab in a chain of slabs of regmatch states,
+ * and the currently active state within that slab */
+
+PERLVARI(Iregmatch_slab, regmatch_slab *, NULL)
+PERLVAR(Iregmatch_state, regmatch_state *)
+
+/* Put anything new that is pointer aligned here. */
+
+PERLVAR(Idelaymagic, U16) /* ($<,$>) = ... */
+PERLVAR(Ilocalizing, U8) /* are we processing a local() list? */
+PERLVAR(Icolorset, bool) /* from regcomp.c */
+PERLVARI(Idirty, bool, FALSE) /* in the middle of tearing things
+ down? */
+PERLVAR(Iin_eval, VOL U8) /* trap "fatal" errors? */
+PERLVAR(Itainted, bool) /* using variables controlled by $< */
+
+/* This value may be set when embedding for full cleanup */
+/* 0=none, 1=full, 2=full with checks */
+/* mod_perl is special, and also assigns a meaning -1 */
+PERLVARI(Iperl_destruct_level, signed char, 0)
+
+PERLVAR(Iperldb, U32)
+
+/* pseudo environmental stuff */
+PERLVAR(Iorigargc, int)
+PERLVAR(Iorigargv, char **)
+PERLVAR(Ienvgv, GV *)
+PERLVAR(Iincgv, GV *)
+PERLVAR(Ihintgv, GV *)
+PERLVAR(Iorigfilename, char *)
+PERLVAR(Idiehook, SV *)
+PERLVAR(Iwarnhook, SV *)
+
+/* switches */
+PERLVAR(Ipatchlevel, SV *)
+PERLVAR(Ilocalpatches, const char * const *)
+PERLVARI(Isplitstr, const char *, " ")
+
+PERLVAR(Iminus_c, bool)
+PERLVAR(Ipreprocess, bool)
+PERLVAR(Iminus_n, bool)
+PERLVAR(Iminus_p, bool)
+PERLVAR(Iminus_l, bool)
+PERLVAR(Iminus_a, bool)
+PERLVAR(Iminus_F, bool)
+PERLVAR(Idoswitches, bool)
+
+PERLVAR(Iminus_E, bool)
+
+/*
+
+=for apidoc mn|bool|PL_dowarn
+
+The C variable which corresponds to Perl's $^W warning variable.
+
+=cut
+*/
+
+PERLVAR(Idowarn, U8)
+PERLVAR(Idoextract, bool)
+PERLVAR(Isawampersand, bool) /* must save all match strings */
+PERLVAR(Iunsafe, bool)
+PERLVAR(Iexit_flags, U8) /* was exit() unexpected, etc. */
+PERLVAR(Isrand_called, bool)
+/* Part of internal state, but makes the 16th 1 byte variable in a row. */
+PERLVAR(Itainting, bool) /* doing taint checks */
+PERLVAR(Iinplace, char *)
+PERLVAR(Ie_script, SV *)
+
+/* magical thingies */
+PERLVAR(Ibasetime, Time_t) /* $^T */
+PERLVAR(Iformfeed, SV *) /* $^L */
+
+
+PERLVARI(Imaxsysfd, I32, MAXSYSFD)
+ /* top fd to pass to subprocesses */
+PERLVAR(Istatusvalue, I32) /* $? */
+#ifdef VMS
+PERLVAR(Istatusvalue_vms,U32)
+#else
+PERLVAR(Istatusvalue_posix,I32)
+#endif
+
+PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */
+PERLVAR(Ipsig_pend, int *) /* per-signal "count" of pending */
+
+/* shortcuts to various I/O objects */
+PERLVAR(Istdingv, GV *)
+PERLVAR(Istderrgv, GV *)
+PERLVAR(Idefgv, GV *)
+PERLVAR(Iargvgv, GV *)
+PERLVAR(Iargvoutgv, GV *)
+PERLVAR(Iargvout_stack, AV *)
+
+/* shortcuts to regexp stuff */
+PERLVAR(Ireplgv, GV *)
+
+/* shortcuts to misc objects */
+PERLVAR(Ierrgv, GV *)
+
+/* shortcuts to debugging objects */
+PERLVAR(IDBgv, GV *)
+PERLVAR(IDBline, GV *)
+
+/*
+=for apidoc mn|GV *|PL_DBsub
+When Perl is run in debugging mode, with the B<-d> switch, this GV contains
+the SV which holds the name of the sub being debugged. This is the C
+variable which corresponds to Perl's $DB::sub variable. See
+C<PL_DBsingle>.
+
+=for apidoc mn|SV *|PL_DBsingle
+When Perl is run in debugging mode, with the B<-d> switch, this SV is a
+boolean which indicates whether subs are being single-stepped.
+Single-stepping is automatically turned on after every step. This is the C
+variable which corresponds to Perl's $DB::single variable. See
+C<PL_DBsub>.
+
+=for apidoc mn|SV *|PL_DBtrace
+Trace variable used when Perl is run in debugging mode, with the B<-d>
+switch. This is the C variable which corresponds to Perl's $DB::trace
+variable. See C<PL_DBsingle>.
+
+=cut
+*/
+
+PERLVAR(IDBsub, GV *)
+PERLVAR(IDBsingle, SV *)
+PERLVAR(IDBtrace, SV *)
+PERLVAR(IDBsignal, SV *)
+PERLVAR(Idbargs, AV *) /* args to call listed by caller function */
+
+/* symbol tables */
+PERLVAR(Idebstash, HV *) /* symbol table for perldb package */
+PERLVAR(Iglobalstash, HV *) /* global keyword overrides imported here */
+PERLVAR(Icurstname, SV *) /* name of current package */
+PERLVAR(Ibeginav, AV *) /* names of BEGIN subroutines */
+PERLVAR(Iendav, AV *) /* names of END subroutines */
+PERLVAR(Iunitcheckav, AV *) /* names of UNITCHECK subroutines */
+PERLVAR(Icheckav, AV *) /* names of CHECK subroutines */
+PERLVAR(Iinitav, AV *) /* names of INIT subroutines */
+PERLVAR(Istrtab, HV *) /* shared string table */
+PERLVARI(Isub_generation,U32,1) /* incr to invalidate method cache */
+
+/* funky return mechanisms */
+PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */
+
+/* memory management */
+PERLVAR(Isv_count, I32) /* how many SV* are currently allocated */
+PERLVAR(Isv_objcount, I32) /* how many objects are currently allocated */
+PERLVAR(Isv_root, SV*) /* storage for SVs belonging to interp */
+PERLVAR(Isv_arenaroot, SV*) /* list of areas for garbage collection */
+
+/* subprocess state */
+PERLVAR(Ifdpid, AV *) /* keep fd-to-pid mappings for my_popen */
+
+/* internal state */
+PERLVARI(Iop_mask, char *, NULL) /* masked operations for safe evals */
+
+/* current interpreter roots */
+PERLVAR(Imain_cv, CV *)
+PERLVAR(Imain_root, OP *)
+PERLVAR(Imain_start, OP *)
+PERLVAR(Ieval_root, OP *)
+PERLVAR(Ieval_start, OP *)
+
+/* runtime control stuff */
+PERLVARI(Icurcopdb, COP *, NULL)
+
+PERLVAR(Ifilemode, int) /* so nextargv() can preserve mode */
+PERLVAR(Ilastfd, int) /* what to preserve mode on */
+PERLVAR(Ioldname, char *) /* what to preserve mode on */
+PERLVAR(IArgv, const char **) /* stuff to free from do_aexec, vfork safe */
+PERLVAR(ICmd, char *) /* stuff to free from do_aexec, vfork safe */
+/* Elements in this array have ';' appended and are injected as a single line
+ into the tokeniser. You can't put any (literal) newlines into any program
+ you stuff in into this array, as the point where it's injected is expecting
+ a single physical line. */
+PERLVAR(Ipreambleav, AV *)
+PERLVAR(Imess_sv, SV *)
+PERLVAR(Iors_sv, SV *) /* output record separator $\ */
+/* statics moved here for shared library purposes */
+PERLVARI(Igensym, I32, 0) /* next symbol for getsym() to define */
+PERLVARI(Icv_has_eval, bool, FALSE) /* PL_compcv includes an entereval or similar */
+PERLVAR(Itaint_warn, bool) /* taint warns instead of dying */
+PERLVARI(Ilaststype, U16, OP_STAT)
+PERLVARI(Ilaststatval, int, -1)
+
+/* interpreter atexit processing */
+PERLVARI(Iexitlistlen, I32, 0) /* length of same */
+PERLVARI(Iexitlist, PerlExitListEntry *, NULL)
+ /* list of exit functions */
+
+/*
+=for apidoc Amn|HV*|PL_modglobal
+
+C<PL_modglobal> is a general purpose, interpreter global HV for use by
+extensions that need to keep information on a per-interpreter basis.
+In a pinch, it can also be used as a symbol table for extensions
+to share data among each other. It is a good idea to use keys
+prefixed by the package name of the extension that owns the data.
+
+=cut
+*/
+
+PERLVAR(Imodglobal, HV *) /* per-interp module data */
+
+/* these used to be in global before 5.004_68 */
+PERLVARI(Iprofiledata, U32 *, NULL) /* table of ops, counts */
+
+PERLVAR(Icompiling, COP) /* compiling/done executing marker */
+
+PERLVAR(Icompcv, CV *) /* currently compiling subroutine */
+PERLVAR(Icomppad, AV *) /* storage for lexically scoped temporaries */
+PERLVAR(Icomppad_name, AV *) /* variable names for "my" variables */
+PERLVAR(Icomppad_name_fill, I32) /* last "introduced" variable offset */
+PERLVAR(Icomppad_name_floor, I32) /* start of vars in innermost block */
+
+#ifdef HAVE_INTERP_INTERN
+PERLVAR(Isys_intern, struct interp_intern)
+ /* platform internals */
+#endif
+
+/* more statics moved here */
+PERLVAR(IDBcv, CV *) /* from perl.c */
+PERLVARI(Igeneration, int, 100) /* from op.c */
+
+PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */
+PERLVARI(Iin_clean_all, bool, FALSE) /* from sv.c */
+PERLVAR(Inomemok, bool) /* let malloc context handle nomem */
+PERLVARI(Isavebegin, bool, FALSE) /* save BEGINs for compiler */
+
+PERLVAR(Iuid, Uid_t) /* current real user id */
+PERLVAR(Ieuid, Uid_t) /* current effective user id */
+PERLVAR(Igid, Gid_t) /* current real group id */
+PERLVAR(Iegid, Gid_t) /* current effective group id */
+PERLVARI(Ian, U32, 0) /* malloc sequence number */
+PERLVARI(Icop_seqmax, U32, 0) /* statement sequence number */
+PERLVARI(Ievalseq, U32, 0) /* eval sequence number */
+PERLVAR(Iorigalen, U32)
+PERLVAR(Iorigenviron, char **)
+#ifdef PERL_USES_PL_PIDSTATUS
+PERLVAR(Ipidstatus, HV *) /* pid-to-status mappings for waitpid */
+#endif
+PERLVAR(Iosname, char *) /* operating system */
+
+PERLVAR(Isighandlerp, Sighandler_t)
+
+PERLVARA(Ibody_roots, PERL_ARENA_ROOTS_SIZE, void*) /* array of body roots */
+
+PERLVAR(Inice_chunk, char *) /* a nice chunk of memory to reuse */
+PERLVAR(Inice_chunk_size, U32) /* how nice the chunk of memory is */
+
+PERLVARI(Imaxo, int, MAXO) /* maximum number of ops */
+
+PERLVARI(Irunops, runops_proc_t, MEMBER_TO_FPTR(RUNOPS_DEFAULT))
+
+/*
+=for apidoc Amn|SV|PL_sv_undef
+This is the C<undef> SV. Always refer to this as C<&PL_sv_undef>.
+
+=for apidoc Amn|SV|PL_sv_no
+This is the C<false> SV. See C<PL_sv_yes>. Always refer to this as
+C<&PL_sv_no>.
+
+=for apidoc Amn|SV|PL_sv_yes
+This is the C<true> SV. See C<PL_sv_no>. Always refer to this as
+C<&PL_sv_yes>.
+
+=cut
+*/
+
+PERLVAR(Isv_undef, SV)
+PERLVAR(Isv_no, SV)
+PERLVAR(Isv_yes, SV)
+
+PERLVAR(Isubname, SV *) /* name of current subroutine */
+
+PERLVAR(Isubline, I32) /* line this subroutine began on */
+PERLVAR(Imin_intro_pending, I32) /* start of vars to introduce */
+
+PERLVAR(Imax_intro_pending, I32) /* end of vars to introduce */
+PERLVAR(Ipadix, I32) /* max used index in current "register" pad */
+
+PERLVAR(Ipadix_floor, I32) /* how low may inner block reset padix */
+PERLVAR(Ipad_reset_pending, I32) /* reset pad on next attempted alloc */
+
+PERLVAR(Ihints, U32) /* pragma-tic compile-time flags */
+
+PERLVAR(Idebug, VOL U32) /* flags given to -D switch */
+
+PERLVARI(Iamagic_generation, long, 0)
+
+#ifdef USE_LOCALE_COLLATE
+PERLVAR(Icollation_name,char *) /* Name of current collation */
+PERLVAR(Icollxfrm_base, Size_t) /* Basic overhead in *xfrm() */
+PERLVARI(Icollxfrm_mult,Size_t, 2) /* Expansion factor in *xfrm() */
+PERLVARI(Icollation_ix, U32, 0) /* Collation generation index */
+PERLVARI(Icollation_standard, bool, TRUE)
+ /* Assume simple collation */
+#endif /* USE_LOCALE_COLLATE */
+
+
+#if defined (PERL_UTF8_CACHE_ASSERT) || defined (DEBUGGING)
+# define PERL___I -1
+#else
+# define PERL___I 1
+#endif
+PERLVARI(Iutf8cache, I8, PERL___I) /* Is the utf8 caching code enabled? */
+#undef PERL___I
+
+
+#ifdef USE_LOCALE_NUMERIC
+
+PERLVARI(Inumeric_standard, bool, TRUE)
+ /* Assume simple numerics */
+PERLVARI(Inumeric_local, bool, TRUE)
+ /* Assume local numerics */
+PERLVAR(Inumeric_name, char *) /* Name of current numeric locale */
+#endif /* !USE_LOCALE_NUMERIC */
+
+/* utf8 character classes */
+PERLVAR(Iutf8_alnum, SV *)
+PERLVAR(Iutf8_alnumc, SV *)
+PERLVAR(Iutf8_ascii, SV *)
+PERLVAR(Iutf8_alpha, SV *)
+PERLVAR(Iutf8_space, SV *)
+PERLVAR(Iutf8_cntrl, SV *)
+PERLVAR(Iutf8_graph, SV *)
+PERLVAR(Iutf8_digit, SV *)
+PERLVAR(Iutf8_upper, SV *)
+PERLVAR(Iutf8_lower, SV *)
+PERLVAR(Iutf8_print, SV *)
+PERLVAR(Iutf8_punct, SV *)
+PERLVAR(Iutf8_xdigit, SV *)
+PERLVAR(Iutf8_mark, SV *)
+PERLVAR(Iutf8_toupper, SV *)
+PERLVAR(Iutf8_totitle, SV *)
+PERLVAR(Iutf8_tolower, SV *)
+PERLVAR(Iutf8_tofold, SV *)
+PERLVAR(Ilast_swash_hv, HV *)
+PERLVAR(Ilast_swash_tmps, U8 *)
+PERLVAR(Ilast_swash_slen, STRLEN)
+PERLVARA(Ilast_swash_key,10, U8)
+PERLVAR(Ilast_swash_klen, U8) /* Only needs to store 0-10 */
+
+#ifdef FCRYPT
+PERLVARI(Icryptseen, bool, FALSE) /* has fast crypt() been initialized? */
+#endif
+
+/* Space for a U8 */
+
+PERLVARI(Iglob_index, int, 0)
+
+
+PERLVAR(Iparser, yy_parser *) /* current parser state */
+
+PERLVAR(Ibitcount, char *)
+
+/* Array of signal handlers, indexed by signal number, through which the C
+ signal handler dispatches. */
+PERLVAR(Ipsig_ptr, SV**)
+/* Array of names of signals, indexed by signal number, for (re)use as the first
+ argument to a signal handler. */
+PERLVAR(Ipsig_name, SV**)
+
+#if defined(PERL_IMPLICIT_SYS)
+PERLVAR(IMem, struct IPerlMem*)
+PERLVAR(IMemShared, struct IPerlMem*)
+PERLVAR(IMemParse, struct IPerlMem*)
+PERLVAR(IEnv, struct IPerlEnv*)
+PERLVAR(IStdIO, struct IPerlStdIO*)
+PERLVAR(ILIO, struct IPerlLIO*)
+PERLVAR(IDir, struct IPerlDir*)
+PERLVAR(ISock, struct IPerlSock*)
+PERLVAR(IProc, struct IPerlProc*)
+#endif
+
+PERLVAR(Iptr_table, PTR_TBL_t*)
+PERLVARI(Ibeginav_save, AV*, NULL) /* save BEGIN{}s when compiling */
+
+PERLVAR(Ibody_arenas, void*) /* pointer to list of body-arenas */
+
+
+#ifdef USE_LOCALE_NUMERIC
+
+PERLVAR(Inumeric_radix_sv, SV *) /* The radix separator if not '.' */
+
+#endif
+
+#if defined(USE_ITHREADS)
+PERLVAR(Iregex_pad, SV**) /* Shortcut into the array of
+ regex_padav */
+PERLVAR(Iregex_padav, AV*) /* All regex objects, indexed via the
+ values in op_pmoffset of pmop.
+ Entry 0 is an array of IVs listing
+ the now-free slots in the array */
+#endif
+
+#ifdef USE_REENTRANT_API
+PERLVAR(Ireentrant_buffer, REENTR*) /* here we store the _r buffers */
+#endif
+
+PERLVAR(Icustom_op_names, HV*) /* Names of user defined ops */
+PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */
+
+#ifdef PERLIO_LAYERS
+PERLVARI(Iperlio, PerlIO *,NULL)
+PERLVARI(Iknown_layers, PerlIO_list_t *,NULL)
+PERLVARI(Idef_layerlist, PerlIO_list_t *,NULL)
+#endif
+
+PERLVARI(Iencoding, SV*, NULL) /* character encoding */
+
+PERLVAR(Idebug_pad, struct perl_debug_pad) /* always needed because of the re extension */
+
+PERLVAR(Iutf8_idstart, SV *)
+PERLVAR(Iutf8_idcont, SV *)
+
+PERLVAR(Isort_RealCmp, SVCOMPARE_t)
+
+PERLVARI(Icheckav_save, AV*, NULL) /* save CHECK{}s when compiling */
+PERLVARI(Iunitcheckav_save, AV*, NULL) /* save UNITCHECK{}s when compiling */
+
+PERLVARI(Iclocktick, long, 0) /* this many times() ticks in a second */
+
+PERLVARI(Iin_load_module, int, 0) /* to prevent recursions in PerlIO_find_layer */
+
+PERLVAR(Iunicode, U32) /* Unicode features: $ENV{PERL_UNICODE} or -C */
+
+PERLVAR(Isignals, U32) /* Using which pre-5.8 signals */
+
+PERLVAR(Ireentrant_retint, int) /* Integer return value from reentrant functions */
+
+PERLVAR(Istashcache, HV *) /* Cache to speed up S_method_common */
+
+/* Hooks to shared SVs and locks. */
+PERLVARI(Isharehook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nosharing))
+PERLVARI(Ilockhook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nosharing))
+#ifdef NO_MATHOMS
+# define PERL_UNLOCK_HOOK Perl_sv_nosharing
+#else
+/* This reference ensures that the mathoms are linked with perl */
+# define PERL_UNLOCK_HOOK Perl_sv_nounlocking
+#endif
+PERLVARI(Iunlockhook, share_proc_t, MEMBER_TO_FPTR(PERL_UNLOCK_HOOK))
+
+PERLVARI(Ithreadhook, thrhook_proc_t, MEMBER_TO_FPTR(Perl_nothreadhook))
+
+PERLVARI(Ihash_seed, UV, 0) /* Hash initializer */
+
+PERLVARI(Irehash_seed, UV, 0) /* 582 hash initializer */
+
+PERLVARI(Iisarev, HV*, NULL) /* Reverse map of @ISA dependencies */
+
+/* The last unconditional member of the interpreter structure when 5.10.0 was
+ released. The offset of the end of this is baked into a global variable in
+ any shared perl library which will allow a sanity test in future perl
+ releases. */
+#define PERL_LAST_5_10_0_INTERP_MEMBER Iisarev
+
+#ifdef PERL_IMPLICIT_CONTEXT
+PERLVARI(Imy_cxt_size, int, 0) /* size of PL_my_cxt_list */
+PERLVARI(Imy_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+PERLVARI(Imy_cxt_keys, const char **, NULL) /* per-module array of pointers to MY_CXT_KEY constants */
+# endif
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+/* For use with the memory debugging code in util.c */
+PERLVAR(Imemory_debug_header, struct perl_memory_debug_header)
+#endif
+
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+/* File descriptor to talk to the child which dumps scalars. */
+PERLVARI(Idumper_fd, int, -1)
+#endif
+
+/* Stores the PPID */
+#ifdef THREADS_HAVE_PIDS
+PERLVARI(Ippid, IV, 0)
+#endif
+
+#ifdef PERL_MAD
+PERLVARI(Imadskills, bool, FALSE) /* preserve all syntactic info */
+ /* (MAD = Misc Attribute Decoration) */
+PERLVARI(Ixmlfp, PerlIO *,NULL)
+#endif
+
+#ifdef PL_OP_SLAB_ALLOC
+PERLVAR(IOpPtr,I32 **)
+PERLVARI(IOpSpace,I32,0)
+PERLVAR(IOpSlab,I32 *)
+#endif
+
+#ifdef PERL_DEBUG_READONLY_OPS
+PERLVARI(Islabs, I32**, NULL) /* Array of slabs that have been allocated */
+PERLVARI(Islab_count, U32, 0) /* Size of the array */
+#endif
+
+/* Can shared object be destroyed */
+PERLVARI(Idestroyhook, destroyable_proc_t, MEMBER_TO_FPTR(Perl_sv_destroyable))
+
+/* Perl_Ibreakable_sub_generation_ptr was too long for VMS, hence "gen" */
+PERLVARI(Ibreakable_sub_gen, U32, 0)
+
+#ifdef DEBUG_LEAKING_SCALARS
+PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */
+#endif
+
+/* Register of known Method Resolution Orders.
+ What this actually points to is an implementation detail (it may change to
+ a structure incorporating a reference count - use mro_get_from_name to
+ retrieve a C<struct mro_alg *> */
+PERLVAR(Iregistered_mros, HV *)
+
+/* If you are adding a U8 or U16, check to see if there are 'Space' comments
+ * above on where there are gaps which currently will be structure padding. */
+
+/* Within a stable branch, new variables must be added to the very end, before
+ * this comment, for binary compatibility (the offsets of the old members must
+ * not change).
+ * (Don't forget to add your variable also to perl_clone()!)
+ * XSUB.h provides wrapper functions via perlapi.h that make this
+ * irrelevant, but not all code may be expected to #include XSUB.h.
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/iperlsys.h b/Master/tlpkg/tlperl.straw/lib/CORE/iperlsys.h
new file mode 100755
index 00000000000..d7b764347ff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/iperlsys.h
@@ -0,0 +1,1420 @@
+/*
+ * iperlsys.h - Perl's interface to the system
+ *
+ * This file defines the system level functionality that perl needs.
+ *
+ * When using C, this definition is in the form of a set of macros
+ * that can be #defined to the system-level function (or a wrapper
+ * provided elsewhere).
+ *
+ * GSAR 21-JUN-98
+ */
+
+#ifndef __Inc__IPerl___
+#define __Inc__IPerl___
+
+/*
+ * PerlXXX_YYY explained - DickH and DougL @ ActiveState.com
+ *
+ * XXX := functional group
+ * YYY := stdlib/OS function name
+ *
+ * Continuing with the theme of PerlIO, all OS functionality was
+ * encapsulated into one of several interfaces.
+ *
+ * PerlIO - stdio
+ * PerlLIO - low level I/O
+ * PerlMem - malloc, realloc, free
+ * PerlDir - directory related
+ * PerlEnv - process environment handling
+ * PerlProc - process control
+ * PerlSock - socket functions
+ *
+ *
+ * The features of this are:
+ * 1. All OS dependant code is in the Perl Host and not the Perl Core.
+ * (At least this is the holy grail goal of this work)
+ * 2. The Perl Host (see perl.h for description) can provide a new and
+ * improved interface to OS functionality if required.
+ * 3. Developers can easily hook into the OS calls for instrumentation
+ * or diagnostic purposes.
+ *
+ * What was changed to do this:
+ * 1. All calls to OS functions were replaced with PerlXXX_YYY
+ *
+ */
+
+/*
+ Interface for perl stdio functions, or whatever we are Configure-d
+ to use.
+*/
+#include "perlio.h"
+
+#ifndef Sighandler_t
+# if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+typedef Signal_t (*Sighandler_t) (int, siginfo_t*, void*);
+# else
+typedef Signal_t (*Sighandler_t) (int);
+# endif
+#endif
+
+#if defined(PERL_IMPLICIT_SYS)
+
+/* IPerlStdIO */
+struct IPerlStdIO;
+struct IPerlStdIOInfo;
+typedef FILE* (*LPStdin)(struct IPerlStdIO*);
+typedef FILE* (*LPStdout)(struct IPerlStdIO*);
+typedef FILE* (*LPStderr)(struct IPerlStdIO*);
+typedef FILE* (*LPOpen)(struct IPerlStdIO*, const char*,
+ const char*);
+typedef int (*LPClose)(struct IPerlStdIO*, FILE*);
+typedef int (*LPEof)(struct IPerlStdIO*, FILE*);
+typedef int (*LPError)(struct IPerlStdIO*, FILE*);
+typedef void (*LPClearerr)(struct IPerlStdIO*, FILE*);
+typedef int (*LPGetc)(struct IPerlStdIO*, FILE*);
+typedef STDCHAR* (*LPGetBase)(struct IPerlStdIO*, FILE*);
+typedef int (*LPGetBufsiz)(struct IPerlStdIO*, FILE*);
+typedef int (*LPGetCnt)(struct IPerlStdIO*, FILE*);
+typedef STDCHAR* (*LPGetPtr)(struct IPerlStdIO*, FILE*);
+typedef char* (*LPGets)(struct IPerlStdIO*, FILE*, char*, int);
+typedef int (*LPPutc)(struct IPerlStdIO*, FILE*, int);
+typedef int (*LPPuts)(struct IPerlStdIO*, FILE*, const char*);
+typedef int (*LPFlush)(struct IPerlStdIO*, FILE*);
+typedef int (*LPUngetc)(struct IPerlStdIO*, int,FILE*);
+typedef int (*LPFileno)(struct IPerlStdIO*, FILE*);
+typedef FILE* (*LPFdopen)(struct IPerlStdIO*, int, const char*);
+typedef FILE* (*LPReopen)(struct IPerlStdIO*, const char*,
+ const char*, FILE*);
+typedef SSize_t (*LPRead)(struct IPerlStdIO*, void*, Size_t, Size_t, FILE *);
+typedef SSize_t (*LPWrite)(struct IPerlStdIO*, const void*, Size_t, Size_t, FILE *);
+typedef void (*LPSetBuf)(struct IPerlStdIO*, FILE*, char*);
+typedef int (*LPSetVBuf)(struct IPerlStdIO*, FILE*, char*, int,
+ Size_t);
+typedef void (*LPSetCnt)(struct IPerlStdIO*, FILE*, int);
+
+#ifndef NETWARE
+typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, STDCHAR*);
+#elif defined(NETWARE)
+typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, STDCHAR*, int);
+#endif
+
+typedef void (*LPSetlinebuf)(struct IPerlStdIO*, FILE*);
+typedef int (*LPPrintf)(struct IPerlStdIO*, FILE*, const char*,
+ ...);
+typedef int (*LPVprintf)(struct IPerlStdIO*, FILE*, const char*,
+ va_list);
+typedef Off_t (*LPTell)(struct IPerlStdIO*, FILE*);
+typedef int (*LPSeek)(struct IPerlStdIO*, FILE*, Off_t, int);
+typedef void (*LPRewind)(struct IPerlStdIO*, FILE*);
+typedef FILE* (*LPTmpfile)(struct IPerlStdIO*);
+typedef int (*LPGetpos)(struct IPerlStdIO*, FILE*, Fpos_t*);
+typedef int (*LPSetpos)(struct IPerlStdIO*, FILE*,
+ const Fpos_t*);
+typedef void (*LPInit)(struct IPerlStdIO*);
+typedef void (*LPInitOSExtras)(struct IPerlStdIO*);
+typedef FILE* (*LPFdupopen)(struct IPerlStdIO*, FILE*);
+
+struct IPerlStdIO
+{
+ LPStdin pStdin;
+ LPStdout pStdout;
+ LPStderr pStderr;
+ LPOpen pOpen;
+ LPClose pClose;
+ LPEof pEof;
+ LPError pError;
+ LPClearerr pClearerr;
+ LPGetc pGetc;
+ LPGetBase pGetBase;
+ LPGetBufsiz pGetBufsiz;
+ LPGetCnt pGetCnt;
+ LPGetPtr pGetPtr;
+ LPGets pGets;
+ LPPutc pPutc;
+ LPPuts pPuts;
+ LPFlush pFlush;
+ LPUngetc pUngetc;
+ LPFileno pFileno;
+ LPFdopen pFdopen;
+ LPReopen pReopen;
+ LPRead pRead;
+ LPWrite pWrite;
+ LPSetBuf pSetBuf;
+ LPSetVBuf pSetVBuf;
+ LPSetCnt pSetCnt;
+ LPSetPtr pSetPtr;
+ LPSetlinebuf pSetlinebuf;
+ LPPrintf pPrintf;
+ LPVprintf pVprintf;
+ LPTell pTell;
+ LPSeek pSeek;
+ LPRewind pRewind;
+ LPTmpfile pTmpfile;
+ LPGetpos pGetpos;
+ LPSetpos pSetpos;
+ LPInit pInit;
+ LPInitOSExtras pInitOSExtras;
+ LPFdupopen pFdupopen;
+};
+
+struct IPerlStdIOInfo
+{
+ unsigned long nCount; /* number of entries expected */
+ struct IPerlStdIO perlStdIOList;
+};
+
+/* These do not belong here ... NI-S, 14 Nov 2000 */
+
+#ifdef USE_STDIO_PTR
+# define PerlSIO_has_cntptr(f) 1
+# ifdef STDIO_PTR_LVALUE
+# ifdef STDIO_CNT_LVALUE
+# define PerlSIO_canset_cnt(f) 1
+# ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+# define PerlSIO_fast_gets(f) 1
+# endif
+# else /* STDIO_CNT_LVALUE */
+# define PerlSIO_canset_cnt(f) 0
+# endif
+# else /* STDIO_PTR_LVALUE */
+# ifdef STDIO_PTR_LVAL_SETS_CNT
+# define PerlSIO_fast_gets(f) 1
+# endif
+# endif
+#else /* USE_STDIO_PTR */
+# define PerlSIO_has_cntptr(f) 0
+# define PerlSIO_canset_cnt(f) 0
+#endif /* USE_STDIO_PTR */
+
+#ifndef PerlSIO_fast_gets
+#define PerlSIO_fast_gets(f) 0
+#endif
+
+#ifdef FILE_base
+#define PerlSIO_has_base(f) 1
+#else
+#define PerlSIO_has_base(f) 0
+#endif
+
+/* Now take FILE * via function table */
+
+#define PerlSIO_stdin \
+ (*PL_StdIO->pStdin)(PL_StdIO)
+#define PerlSIO_stdout \
+ (*PL_StdIO->pStdout)(PL_StdIO)
+#define PerlSIO_stderr \
+ (*PL_StdIO->pStderr)(PL_StdIO)
+#define PerlSIO_fopen(x,y) \
+ (*PL_StdIO->pOpen)(PL_StdIO, (x),(y))
+#define PerlSIO_fclose(f) \
+ (*PL_StdIO->pClose)(PL_StdIO, (f))
+#define PerlSIO_feof(f) \
+ (*PL_StdIO->pEof)(PL_StdIO, (f))
+#define PerlSIO_ferror(f) \
+ (*PL_StdIO->pError)(PL_StdIO, (f))
+#define PerlSIO_clearerr(f) \
+ (*PL_StdIO->pClearerr)(PL_StdIO, (f))
+#define PerlSIO_fgetc(f) \
+ (*PL_StdIO->pGetc)(PL_StdIO, (f))
+#define PerlSIO_get_base(f) \
+ (*PL_StdIO->pGetBase)(PL_StdIO, (f))
+#define PerlSIO_get_bufsiz(f) \
+ (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f))
+#define PerlSIO_get_cnt(f) \
+ (*PL_StdIO->pGetCnt)(PL_StdIO, (f))
+#define PerlSIO_get_ptr(f) \
+ (*PL_StdIO->pGetPtr)(PL_StdIO, (f))
+#define PerlSIO_fputc(f,c) \
+ (*PL_StdIO->pPutc)(PL_StdIO, (f),(c))
+#define PerlSIO_fputs(f,s) \
+ (*PL_StdIO->pPuts)(PL_StdIO, (f),(s))
+#define PerlSIO_fflush(f) \
+ (*PL_StdIO->pFlush)(PL_StdIO, (f))
+#define PerlSIO_fgets(s, n, fp) \
+ (*PL_StdIO->pGets)(PL_StdIO, (fp), s, n)
+#define PerlSIO_ungetc(c,f) \
+ (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f))
+#define PerlSIO_fileno(f) \
+ (*PL_StdIO->pFileno)(PL_StdIO, (f))
+#define PerlSIO_fdopen(f, s) \
+ (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s))
+#define PerlSIO_freopen(p, m, f) \
+ (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f))
+#define PerlSIO_fread(buf,sz,count,f) \
+ (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f))
+#define PerlSIO_fwrite(buf,sz,count,f) \
+ (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f))
+#define PerlSIO_setbuf(f,b) \
+ (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b))
+#define PerlSIO_setvbuf(f,b,t,s) \
+ (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s))
+#define PerlSIO_set_cnt(f,c) \
+ (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c))
+#define PerlSIO_set_ptr(f,p) \
+ (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p))
+#define PerlSIO_setlinebuf(f) \
+ (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f))
+#define PerlSIO_printf Perl_fprintf_nocontext
+#define PerlSIO_stdoutf Perl_printf_nocontext
+#define PerlSIO_vprintf(f,fmt,a) \
+ (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a)
+#define PerlSIO_ftell(f) \
+ (*PL_StdIO->pTell)(PL_StdIO, (f))
+#define PerlSIO_fseek(f,o,w) \
+ (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w))
+#define PerlSIO_fgetpos(f,p) \
+ (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p))
+#define PerlSIO_fsetpos(f,p) \
+ (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p))
+#define PerlSIO_rewind(f) \
+ (*PL_StdIO->pRewind)(PL_StdIO, (f))
+#define PerlSIO_tmpfile() \
+ (*PL_StdIO->pTmpfile)(PL_StdIO)
+#define PerlSIO_init() \
+ (*PL_StdIO->pInit)(PL_StdIO)
+#undef init_os_extras
+#define init_os_extras() \
+ (*PL_StdIO->pInitOSExtras)(PL_StdIO)
+#define PerlSIO_fdupopen(f) \
+ (*PL_StdIO->pFdupopen)(PL_StdIO, (f))
+
+#else /* PERL_IMPLICIT_SYS */
+
+#define PerlSIO_stdin stdin
+#define PerlSIO_stdout stdout
+#define PerlSIO_stderr stderr
+#define PerlSIO_fopen(x,y) fopen(x,y)
+#ifdef __VOS__
+/* Work around VOS bug posix-979, wrongly setting errno when at end of file. */
+#define PerlSIO_fclose(f) (((errno==1025)?errno=0:0),fclose(f))
+#define PerlSIO_feof(f) (((errno==1025)?errno=0:0),feof(f))
+#define PerlSIO_ferror(f) (((errno==1025)?errno=0:0),ferror(f))
+#else
+#define PerlSIO_fclose(f) fclose(f)
+#define PerlSIO_feof(f) feof(f)
+#define PerlSIO_ferror(f) ferror(f)
+#endif
+#define PerlSIO_clearerr(f) clearerr(f)
+#define PerlSIO_fgetc(f) fgetc(f)
+#ifdef FILE_base
+#define PerlSIO_get_base(f) FILE_base(f)
+#define PerlSIO_get_bufsiz(f) FILE_bufsiz(f)
+#else
+#define PerlSIO_get_base(f) NULL
+#define PerlSIO_get_bufsiz(f) 0
+#endif
+#ifdef USE_STDIO_PTR
+#define PerlSIO_get_cnt(f) FILE_cnt(f)
+#define PerlSIO_get_ptr(f) FILE_ptr(f)
+#else
+#define PerlSIO_get_cnt(f) 0
+#define PerlSIO_get_ptr(f) NULL
+#endif
+#define PerlSIO_fputc(f,c) fputc(c,f)
+#define PerlSIO_fputs(f,s) fputs(s,f)
+#define PerlSIO_fflush(f) Fflush(f)
+#define PerlSIO_fgets(s, n, fp) fgets(s,n,fp)
+#if defined(VMS) && defined(__DECC)
+ /* Unusual definition of ungetc() here to accomodate fast_sv_gets()'
+ * belief that it can mix getc/ungetc with reads from stdio buffer */
+ int decc$ungetc(int __c, FILE *__stream);
+# define PerlSIO_ungetc(c,f) ((c) == EOF ? EOF : \
+ ((*(f) && !((*(f))->_flag & _IONBF) && \
+ ((*(f))->_ptr > (*(f))->_base)) ? \
+ ((*(f))->_cnt++, *(--(*(f))->_ptr) = (c)) : decc$ungetc(c,f)))
+#else
+# define PerlSIO_ungetc(c,f) ungetc(c,f)
+#endif
+#define PerlSIO_fileno(f) fileno(f)
+#define PerlSIO_fdopen(f, s) fdopen(f,s)
+#define PerlSIO_freopen(p, m, f) freopen(p,m,f)
+#define PerlSIO_fread(buf,sz,count,f) fread(buf,sz,count,f)
+#define PerlSIO_fwrite(buf,sz,count,f) fwrite(buf,sz,count,f)
+#define PerlSIO_setbuf(f,b) setbuf(f,b)
+#define PerlSIO_setvbuf(f,b,t,s) setvbuf(f,b,t,s)
+#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
+#define PerlSIO_set_cnt(f,c) FILE_cnt(f) = (c)
+#else
+#define PerlSIO_set_cnt(f,c) PerlIOProc_abort()
+#endif
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
+#define PerlSIO_set_ptr(f,p) (FILE_ptr(f) = (p))
+#else
+#define PerlSIO_set_ptr(f,p) PerlIOProc_abort()
+#endif
+#define PerlSIO_setlinebuf(f) setlinebuf(f)
+#define PerlSIO_printf fprintf
+#define PerlSIO_stdoutf printf
+#define PerlSIO_vprintf(f,fmt,a) vfprintf(f,fmt,a)
+#define PerlSIO_ftell(f) ftell(f)
+#define PerlSIO_fseek(f,o,w) fseek(f,o,w)
+#define PerlSIO_fgetpos(f,p) fgetpos(f,p)
+#define PerlSIO_fsetpos(f,p) fsetpos(f,p)
+#define PerlSIO_rewind(f) rewind(f)
+#define PerlSIO_tmpfile() tmpfile()
+#define PerlSIO_fdupopen(f) (f)
+
+#endif /* PERL_IMPLICIT_SYS */
+
+/*
+ * Interface for directory functions
+ */
+
+#if defined(PERL_IMPLICIT_SYS)
+
+/* IPerlDir */
+struct IPerlDir;
+struct IPerlDirInfo;
+typedef int (*LPMakedir)(struct IPerlDir*, const char*, int);
+typedef int (*LPChdir)(struct IPerlDir*, const char*);
+typedef int (*LPRmdir)(struct IPerlDir*, const char*);
+typedef int (*LPDirClose)(struct IPerlDir*, DIR*);
+typedef DIR* (*LPDirOpen)(struct IPerlDir*, const char*);
+typedef struct direct* (*LPDirRead)(struct IPerlDir*, DIR*);
+typedef void (*LPDirRewind)(struct IPerlDir*, DIR*);
+typedef void (*LPDirSeek)(struct IPerlDir*, DIR*, long);
+typedef long (*LPDirTell)(struct IPerlDir*, DIR*);
+#ifdef WIN32
+typedef char* (*LPDirMapPathA)(struct IPerlDir*, const char*);
+typedef WCHAR* (*LPDirMapPathW)(struct IPerlDir*, const WCHAR*);
+#endif
+
+struct IPerlDir
+{
+ LPMakedir pMakedir;
+ LPChdir pChdir;
+ LPRmdir pRmdir;
+ LPDirClose pClose;
+ LPDirOpen pOpen;
+ LPDirRead pRead;
+ LPDirRewind pRewind;
+ LPDirSeek pSeek;
+ LPDirTell pTell;
+#ifdef WIN32
+ LPDirMapPathA pMapPathA;
+ LPDirMapPathW pMapPathW;
+#endif
+};
+
+struct IPerlDirInfo
+{
+ unsigned long nCount; /* number of entries expected */
+ struct IPerlDir perlDirList;
+};
+
+#define PerlDir_mkdir(name, mode) \
+ (*PL_Dir->pMakedir)(PL_Dir, (name), (mode))
+#define PerlDir_chdir(name) \
+ (*PL_Dir->pChdir)(PL_Dir, (name))
+#define PerlDir_rmdir(name) \
+ (*PL_Dir->pRmdir)(PL_Dir, (name))
+#define PerlDir_close(dir) \
+ (*PL_Dir->pClose)(PL_Dir, (dir))
+#define PerlDir_open(name) \
+ (*PL_Dir->pOpen)(PL_Dir, (name))
+#define PerlDir_read(dir) \
+ (*PL_Dir->pRead)(PL_Dir, (dir))
+#define PerlDir_rewind(dir) \
+ (*PL_Dir->pRewind)(PL_Dir, (dir))
+#define PerlDir_seek(dir, loc) \
+ (*PL_Dir->pSeek)(PL_Dir, (dir), (loc))
+#define PerlDir_tell(dir) \
+ (*PL_Dir->pTell)(PL_Dir, (dir))
+#ifdef WIN32
+#define PerlDir_mapA(dir) \
+ (*PL_Dir->pMapPathA)(PL_Dir, (dir))
+#define PerlDir_mapW(dir) \
+ (*PL_Dir->pMapPathW)(PL_Dir, (dir))
+#endif
+
+#else /* PERL_IMPLICIT_SYS */
+
+#define PerlDir_mkdir(name, mode) Mkdir((name), (mode))
+#ifdef VMS
+# define PerlDir_chdir(n) Chdir((n))
+#else
+# define PerlDir_chdir(name) chdir((name))
+#endif
+#define PerlDir_rmdir(name) rmdir((name))
+#define PerlDir_close(dir) closedir((dir))
+#define PerlDir_open(name) opendir((name))
+#define PerlDir_read(dir) readdir((dir))
+#define PerlDir_rewind(dir) rewinddir((dir))
+#define PerlDir_seek(dir, loc) seekdir((dir), (loc))
+#define PerlDir_tell(dir) telldir((dir))
+#ifdef WIN32
+#define PerlDir_mapA(dir) dir
+#define PerlDir_mapW(dir) dir
+#endif
+
+#endif /* PERL_IMPLICIT_SYS */
+
+/*
+ Interface for perl environment functions
+*/
+
+#if defined(PERL_IMPLICIT_SYS)
+
+/* IPerlEnv */
+struct IPerlEnv;
+struct IPerlEnvInfo;
+typedef char* (*LPEnvGetenv)(struct IPerlEnv*, const char*);
+typedef int (*LPEnvPutenv)(struct IPerlEnv*, const char*);
+typedef char* (*LPEnvGetenv_len)(struct IPerlEnv*,
+ const char *varname, unsigned long *len);
+typedef int (*LPEnvUname)(struct IPerlEnv*, struct utsname *name);
+typedef void (*LPEnvClearenv)(struct IPerlEnv*);
+typedef void* (*LPEnvGetChildenv)(struct IPerlEnv*);
+typedef void (*LPEnvFreeChildenv)(struct IPerlEnv*, void* env);
+typedef char* (*LPEnvGetChilddir)(struct IPerlEnv*);
+typedef void (*LPEnvFreeChilddir)(struct IPerlEnv*, char* dir);
+#ifdef HAS_ENVGETENV
+typedef char* (*LPENVGetenv)(struct IPerlEnv*, const char *varname);
+typedef char* (*LPENVGetenv_len)(struct IPerlEnv*,
+ const char *varname, unsigned long *len);
+#endif
+#ifdef WIN32
+typedef unsigned long (*LPEnvOsID)(struct IPerlEnv*);
+typedef char* (*LPEnvLibPath)(struct IPerlEnv*, const char*);
+typedef char* (*LPEnvSiteLibPath)(struct IPerlEnv*, const char*);
+typedef char* (*LPEnvVendorLibPath)(struct IPerlEnv*, const char*);
+typedef void (*LPEnvGetChildIO)(struct IPerlEnv*, child_IO_table*);
+#endif
+
+struct IPerlEnv
+{
+ LPEnvGetenv pGetenv;
+ LPEnvPutenv pPutenv;
+ LPEnvGetenv_len pGetenv_len;
+ LPEnvUname pEnvUname;
+ LPEnvClearenv pClearenv;
+ LPEnvGetChildenv pGetChildenv;
+ LPEnvFreeChildenv pFreeChildenv;
+ LPEnvGetChilddir pGetChilddir;
+ LPEnvFreeChilddir pFreeChilddir;
+#ifdef HAS_ENVGETENV
+ LPENVGetenv pENVGetenv;
+ LPENVGetenv_len pENVGetenv_len;
+#endif
+#ifdef WIN32
+ LPEnvOsID pEnvOsID;
+ LPEnvLibPath pLibPath;
+ LPEnvSiteLibPath pSiteLibPath;
+ LPEnvVendorLibPath pVendorLibPath;
+ LPEnvGetChildIO pGetChildIO;
+#endif
+};
+
+struct IPerlEnvInfo
+{
+ unsigned long nCount; /* number of entries expected */
+ struct IPerlEnv perlEnvList;
+};
+
+#define PerlEnv_putenv(str) \
+ (*PL_Env->pPutenv)(PL_Env,(str))
+#define PerlEnv_getenv(str) \
+ (*PL_Env->pGetenv)(PL_Env,(str))
+#define PerlEnv_getenv_len(str,l) \
+ (*PL_Env->pGetenv_len)(PL_Env,(str), (l))
+#define PerlEnv_clearenv() \
+ (*PL_Env->pClearenv)(PL_Env)
+#define PerlEnv_get_childenv() \
+ (*PL_Env->pGetChildenv)(PL_Env)
+#define PerlEnv_free_childenv(e) \
+ (*PL_Env->pFreeChildenv)(PL_Env, (e))
+#define PerlEnv_get_childdir() \
+ (*PL_Env->pGetChilddir)(PL_Env)
+#define PerlEnv_free_childdir(d) \
+ (*PL_Env->pFreeChilddir)(PL_Env, (d))
+#ifdef HAS_ENVGETENV
+# define PerlEnv_ENVgetenv(str) \
+ (*PL_Env->pENVGetenv)(PL_Env,(str))
+# define PerlEnv_ENVgetenv_len(str,l) \
+ (*PL_Env->pENVGetenv_len)(PL_Env,(str), (l))
+#else
+# define PerlEnv_ENVgetenv(str) \
+ PerlEnv_getenv((str))
+# define PerlEnv_ENVgetenv_len(str,l) \
+ PerlEnv_getenv_len((str),(l))
+#endif
+#define PerlEnv_uname(name) \
+ (*PL_Env->pEnvUname)(PL_Env,(name))
+#ifdef WIN32
+#define PerlEnv_os_id() \
+ (*PL_Env->pEnvOsID)(PL_Env)
+#define PerlEnv_lib_path(str) \
+ (*PL_Env->pLibPath)(PL_Env,(str))
+#define PerlEnv_sitelib_path(str) \
+ (*PL_Env->pSiteLibPath)(PL_Env,(str))
+#define PerlEnv_vendorlib_path(str) \
+ (*PL_Env->pVendorLibPath)(PL_Env,(str))
+#define PerlEnv_get_child_IO(ptr) \
+ (*PL_Env->pGetChildIO)(PL_Env, ptr)
+#endif
+
+#else /* PERL_IMPLICIT_SYS */
+
+#define PerlEnv_putenv(str) putenv((str))
+#define PerlEnv_getenv(str) getenv((str))
+#define PerlEnv_getenv_len(str,l) getenv_len((str), (l))
+#ifdef HAS_ENVGETENV
+# define PerlEnv_ENVgetenv(str) ENVgetenv((str))
+# define PerlEnv_ENVgetenv_len(str,l) ENVgetenv_len((str), (l))
+#else
+# define PerlEnv_ENVgetenv(str) PerlEnv_getenv((str))
+# define PerlEnv_ENVgetenv_len(str,l) PerlEnv_getenv_len((str), (l))
+#endif
+#define PerlEnv_uname(name) uname((name))
+
+#ifdef WIN32
+#define PerlEnv_os_id() win32_os_id()
+#define PerlEnv_lib_path(str) win32_get_privlib(str)
+#define PerlEnv_sitelib_path(str) win32_get_sitelib(str)
+#define PerlEnv_vendorlib_path(str) win32_get_vendorlib(str)
+#define PerlEnv_get_child_IO(ptr) win32_get_child_IO(ptr)
+#define PerlEnv_clearenv() win32_clearenv()
+#define PerlEnv_get_childenv() win32_get_childenv()
+#define PerlEnv_free_childenv(e) win32_free_childenv((e))
+#define PerlEnv_get_childdir() win32_get_childdir()
+#define PerlEnv_free_childdir(d) win32_free_childdir((d))
+#else
+#define PerlEnv_clearenv() clearenv()
+#define PerlEnv_get_childenv() get_childenv()
+#define PerlEnv_free_childenv(e) free_childenv((e))
+#define PerlEnv_get_childdir() get_childdir()
+#define PerlEnv_free_childdir(d) free_childdir((d))
+#endif
+
+#endif /* PERL_IMPLICIT_SYS */
+
+/*
+ Interface for perl low-level IO functions
+*/
+
+#if defined(PERL_IMPLICIT_SYS)
+
+/* IPerlLIO */
+struct IPerlLIO;
+struct IPerlLIOInfo;
+typedef int (*LPLIOAccess)(struct IPerlLIO*, const char*, int);
+typedef int (*LPLIOChmod)(struct IPerlLIO*, const char*, int);
+typedef int (*LPLIOChown)(struct IPerlLIO*, const char*, uid_t,
+ gid_t);
+typedef int (*LPLIOChsize)(struct IPerlLIO*, int, Off_t);
+typedef int (*LPLIOClose)(struct IPerlLIO*, int);
+typedef int (*LPLIODup)(struct IPerlLIO*, int);
+typedef int (*LPLIODup2)(struct IPerlLIO*, int, int);
+typedef int (*LPLIOFlock)(struct IPerlLIO*, int, int);
+typedef int (*LPLIOFileStat)(struct IPerlLIO*, int, Stat_t*);
+typedef int (*LPLIOIOCtl)(struct IPerlLIO*, int, unsigned int,
+ char*);
+typedef int (*LPLIOIsatty)(struct IPerlLIO*, int);
+typedef int (*LPLIOLink)(struct IPerlLIO*, const char*,
+ const char *);
+typedef Off_t (*LPLIOLseek)(struct IPerlLIO*, int, Off_t, int);
+typedef int (*LPLIOLstat)(struct IPerlLIO*, const char*,
+ Stat_t*);
+typedef char* (*LPLIOMktemp)(struct IPerlLIO*, char*);
+typedef int (*LPLIOOpen)(struct IPerlLIO*, const char*, int);
+typedef int (*LPLIOOpen3)(struct IPerlLIO*, const char*, int, int);
+typedef int (*LPLIORead)(struct IPerlLIO*, int, void*, unsigned int);
+typedef int (*LPLIORename)(struct IPerlLIO*, const char*,
+ const char*);
+#ifdef NETWARE
+typedef int (*LPLIOSetmode)(struct IPerlLIO*, FILE*, int);
+#else
+typedef int (*LPLIOSetmode)(struct IPerlLIO*, int, int);
+#endif /* NETWARE */
+typedef int (*LPLIONameStat)(struct IPerlLIO*, const char*,
+ Stat_t*);
+typedef char* (*LPLIOTmpnam)(struct IPerlLIO*, char*);
+typedef int (*LPLIOUmask)(struct IPerlLIO*, int);
+typedef int (*LPLIOUnlink)(struct IPerlLIO*, const char*);
+typedef int (*LPLIOUtime)(struct IPerlLIO*, const char*, struct utimbuf*);
+typedef int (*LPLIOWrite)(struct IPerlLIO*, int, const void*,
+ unsigned int);
+
+struct IPerlLIO
+{
+ LPLIOAccess pAccess;
+ LPLIOChmod pChmod;
+ LPLIOChown pChown;
+ LPLIOChsize pChsize;
+ LPLIOClose pClose;
+ LPLIODup pDup;
+ LPLIODup2 pDup2;
+ LPLIOFlock pFlock;
+ LPLIOFileStat pFileStat;
+ LPLIOIOCtl pIOCtl;
+ LPLIOIsatty pIsatty;
+ LPLIOLink pLink;
+ LPLIOLseek pLseek;
+ LPLIOLstat pLstat;
+ LPLIOMktemp pMktemp;
+ LPLIOOpen pOpen;
+ LPLIOOpen3 pOpen3;
+ LPLIORead pRead;
+ LPLIORename pRename;
+ LPLIOSetmode pSetmode;
+ LPLIONameStat pNameStat;
+ LPLIOTmpnam pTmpnam;
+ LPLIOUmask pUmask;
+ LPLIOUnlink pUnlink;
+ LPLIOUtime pUtime;
+ LPLIOWrite pWrite;
+};
+
+struct IPerlLIOInfo
+{
+ unsigned long nCount; /* number of entries expected */
+ struct IPerlLIO perlLIOList;
+};
+
+#define PerlLIO_access(file, mode) \
+ (*PL_LIO->pAccess)(PL_LIO, (file), (mode))
+#define PerlLIO_chmod(file, mode) \
+ (*PL_LIO->pChmod)(PL_LIO, (file), (mode))
+#define PerlLIO_chown(file, owner, group) \
+ (*PL_LIO->pChown)(PL_LIO, (file), (owner), (group))
+#define PerlLIO_chsize(fd, size) \
+ (*PL_LIO->pChsize)(PL_LIO, (fd), (size))
+#define PerlLIO_close(fd) \
+ (*PL_LIO->pClose)(PL_LIO, (fd))
+#define PerlLIO_dup(fd) \
+ (*PL_LIO->pDup)(PL_LIO, (fd))
+#define PerlLIO_dup2(fd1, fd2) \
+ (*PL_LIO->pDup2)(PL_LIO, (fd1), (fd2))
+#define PerlLIO_flock(fd, op) \
+ (*PL_LIO->pFlock)(PL_LIO, (fd), (op))
+#define PerlLIO_fstat(fd, buf) \
+ (*PL_LIO->pFileStat)(PL_LIO, (fd), (buf))
+#define PerlLIO_ioctl(fd, u, buf) \
+ (*PL_LIO->pIOCtl)(PL_LIO, (fd), (u), (buf))
+#define PerlLIO_isatty(fd) \
+ (*PL_LIO->pIsatty)(PL_LIO, (fd))
+#define PerlLIO_link(oldname, newname) \
+ (*PL_LIO->pLink)(PL_LIO, (oldname), (newname))
+#define PerlLIO_lseek(fd, offset, mode) \
+ (*PL_LIO->pLseek)(PL_LIO, (fd), (offset), (mode))
+#define PerlLIO_lstat(name, buf) \
+ (*PL_LIO->pLstat)(PL_LIO, (name), (buf))
+#define PerlLIO_mktemp(file) \
+ (*PL_LIO->pMktemp)(PL_LIO, (file))
+#define PerlLIO_open(file, flag) \
+ (*PL_LIO->pOpen)(PL_LIO, (file), (flag))
+#define PerlLIO_open3(file, flag, perm) \
+ (*PL_LIO->pOpen3)(PL_LIO, (file), (flag), (perm))
+#define PerlLIO_read(fd, buf, count) \
+ (*PL_LIO->pRead)(PL_LIO, (fd), (buf), (count))
+#define PerlLIO_rename(oname, newname) \
+ (*PL_LIO->pRename)(PL_LIO, (oname), (newname))
+#define PerlLIO_setmode(fd, mode) \
+ (*PL_LIO->pSetmode)(PL_LIO, (fd), (mode))
+#define PerlLIO_stat(name, buf) \
+ (*PL_LIO->pNameStat)(PL_LIO, (name), (buf))
+#define PerlLIO_tmpnam(str) \
+ (*PL_LIO->pTmpnam)(PL_LIO, (str))
+#define PerlLIO_umask(mode) \
+ (*PL_LIO->pUmask)(PL_LIO, (mode))
+#define PerlLIO_unlink(file) \
+ (*PL_LIO->pUnlink)(PL_LIO, (file))
+#define PerlLIO_utime(file, time) \
+ (*PL_LIO->pUtime)(PL_LIO, (file), (time))
+#define PerlLIO_write(fd, buf, count) \
+ (*PL_LIO->pWrite)(PL_LIO, (fd), (buf), (count))
+
+#else /* PERL_IMPLICIT_SYS */
+
+#define PerlLIO_access(file, mode) access((file), (mode))
+#define PerlLIO_chmod(file, mode) chmod((file), (mode))
+#define PerlLIO_chown(file, owner, grp) chown((file), (owner), (grp))
+#if defined(HAS_TRUNCATE)
+# define PerlLIO_chsize(fd, size) ftruncate((fd), (size))
+#elif defined(HAS_CHSIZE)
+# define PerlLIO_chsize(fd, size) chsize((fd), (size))
+#else
+# define PerlLIO_chsize(fd, size) my_chsize((fd), (size))
+#endif
+#define PerlLIO_close(fd) close((fd))
+#define PerlLIO_dup(fd) dup((fd))
+#define PerlLIO_dup2(fd1, fd2) dup2((fd1), (fd2))
+#define PerlLIO_flock(fd, op) FLOCK((fd), (op))
+#define PerlLIO_fstat(fd, buf) Fstat((fd), (buf))
+#define PerlLIO_ioctl(fd, u, buf) ioctl((fd), (u), (buf))
+#define PerlLIO_isatty(fd) isatty((fd))
+#define PerlLIO_link(oldname, newname) link((oldname), (newname))
+#define PerlLIO_lseek(fd, offset, mode) lseek((fd), (offset), (mode))
+#define PerlLIO_stat(name, buf) Stat((name), (buf))
+#ifdef HAS_LSTAT
+# define PerlLIO_lstat(name, buf) lstat((name), (buf))
+#else
+# define PerlLIO_lstat(name, buf) PerlLIO_stat((name), (buf))
+#endif
+#define PerlLIO_mktemp(file) mktemp((file))
+#define PerlLIO_mkstemp(file) mkstemp((file))
+#define PerlLIO_open(file, flag) open((file), (flag))
+#define PerlLIO_open3(file, flag, perm) open((file), (flag), (perm))
+#define PerlLIO_read(fd, buf, count) read((fd), (buf), (count))
+#define PerlLIO_rename(old, new) rename((old), (new))
+#define PerlLIO_setmode(fd, mode) setmode((fd), (mode))
+#define PerlLIO_tmpnam(str) tmpnam((str))
+#define PerlLIO_umask(mode) umask((mode))
+#define PerlLIO_unlink(file) unlink((file))
+#define PerlLIO_utime(file, time) utime((file), (time))
+#define PerlLIO_write(fd, buf, count) write((fd), (buf), (count))
+
+#endif /* PERL_IMPLICIT_SYS */
+
+/*
+ Interface for perl memory allocation
+*/
+
+#if defined(PERL_IMPLICIT_SYS)
+
+/* IPerlMem */
+struct IPerlMem;
+struct IPerlMemInfo;
+typedef void* (*LPMemMalloc)(struct IPerlMem*, size_t);
+typedef void* (*LPMemRealloc)(struct IPerlMem*, void*, size_t);
+typedef void (*LPMemFree)(struct IPerlMem*, void*);
+typedef void* (*LPMemCalloc)(struct IPerlMem*, size_t, size_t);
+typedef void (*LPMemGetLock)(struct IPerlMem*);
+typedef void (*LPMemFreeLock)(struct IPerlMem*);
+typedef int (*LPMemIsLocked)(struct IPerlMem*);
+
+struct IPerlMem
+{
+ LPMemMalloc pMalloc;
+ LPMemRealloc pRealloc;
+ LPMemFree pFree;
+ LPMemCalloc pCalloc;
+ LPMemGetLock pGetLock;
+ LPMemFreeLock pFreeLock;
+ LPMemIsLocked pIsLocked;
+};
+
+struct IPerlMemInfo
+{
+ unsigned long nCount; /* number of entries expected */
+ struct IPerlMem perlMemList;
+};
+
+/* Interpreter specific memory macros */
+#define PerlMem_malloc(size) \
+ (*PL_Mem->pMalloc)(PL_Mem, (size))
+#define PerlMem_realloc(buf, size) \
+ (*PL_Mem->pRealloc)(PL_Mem, (buf), (size))
+#define PerlMem_free(buf) \
+ (*PL_Mem->pFree)(PL_Mem, (buf))
+#define PerlMem_calloc(num, size) \
+ (*PL_Mem->pCalloc)(PL_Mem, (num), (size))
+#define PerlMem_get_lock() \
+ (*PL_Mem->pGetLock)(PL_Mem)
+#define PerlMem_free_lock() \
+ (*PL_Mem->pFreeLock)(PL_Mem)
+#define PerlMem_is_locked() \
+ (*PL_Mem->pIsLocked)(PL_Mem)
+
+/* Shared memory macros */
+#ifdef NETWARE
+
+#define PerlMemShared_malloc(size) \
+ (*PL_Mem->pMalloc)(PL_Mem, (size))
+#define PerlMemShared_realloc(buf, size) \
+ (*PL_Mem->pRealloc)(PL_Mem, (buf), (size))
+#define PerlMemShared_free(buf) \
+ (*PL_Mem->pFree)(PL_Mem, (buf))
+#define PerlMemShared_calloc(num, size) \
+ (*PL_Mem->pCalloc)(PL_Mem, (num), (size))
+#define PerlMemShared_get_lock() \
+ (*PL_Mem->pGetLock)(PL_Mem)
+#define PerlMemShared_free_lock() \
+ (*PL_Mem->pFreeLock)(PL_Mem)
+#define PerlMemShared_is_locked() \
+ (*PL_Mem->pIsLocked)(PL_Mem)
+
+#else
+
+#define PerlMemShared_malloc(size) \
+ (*PL_MemShared->pMalloc)(PL_MemShared, (size))
+#define PerlMemShared_realloc(buf, size) \
+ (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size))
+#define PerlMemShared_free(buf) \
+ (*PL_MemShared->pFree)(PL_MemShared, (buf))
+#define PerlMemShared_calloc(num, size) \
+ (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size))
+#define PerlMemShared_get_lock() \
+ (*PL_MemShared->pGetLock)(PL_MemShared)
+#define PerlMemShared_free_lock() \
+ (*PL_MemShared->pFreeLock)(PL_MemShared)
+#define PerlMemShared_is_locked() \
+ (*PL_MemShared->pIsLocked)(PL_MemShared)
+
+#endif
+
+/* Parse tree memory macros */
+#define PerlMemParse_malloc(size) \
+ (*PL_MemParse->pMalloc)(PL_MemParse, (size))
+#define PerlMemParse_realloc(buf, size) \
+ (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size))
+#define PerlMemParse_free(buf) \
+ (*PL_MemParse->pFree)(PL_MemParse, (buf))
+#define PerlMemParse_calloc(num, size) \
+ (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size))
+#define PerlMemParse_get_lock() \
+ (*PL_MemParse->pGetLock)(PL_MemParse)
+#define PerlMemParse_free_lock() \
+ (*PL_MemParse->pFreeLock)(PL_MemParse)
+#define PerlMemParse_is_locked() \
+ (*PL_MemParse->pIsLocked)(PL_MemParse)
+
+
+#else /* PERL_IMPLICIT_SYS */
+
+/* Interpreter specific memory macros */
+#define PerlMem_malloc(size) malloc((size))
+#define PerlMem_realloc(buf, size) realloc((buf), (size))
+#define PerlMem_free(buf) free((buf))
+#define PerlMem_calloc(num, size) calloc((num), (size))
+#define PerlMem_get_lock()
+#define PerlMem_free_lock()
+#define PerlMem_is_locked() 0
+
+/* Shared memory macros */
+#define PerlMemShared_malloc(size) malloc((size))
+#define PerlMemShared_realloc(buf, size) realloc((buf), (size))
+#define PerlMemShared_free(buf) free((buf))
+#define PerlMemShared_calloc(num, size) calloc((num), (size))
+#define PerlMemShared_get_lock()
+#define PerlMemShared_free_lock()
+#define PerlMemShared_is_locked() 0
+
+/* Parse tree memory macros */
+#define PerlMemParse_malloc(size) malloc((size))
+#define PerlMemParse_realloc(buf, size) realloc((buf), (size))
+#define PerlMemParse_free(buf) free((buf))
+#define PerlMemParse_calloc(num, size) calloc((num), (size))
+#define PerlMemParse_get_lock()
+#define PerlMemParse_free_lock()
+#define PerlMemParse_is_locked() 0
+
+#endif /* PERL_IMPLICIT_SYS */
+
+/*
+ Interface for perl process functions
+*/
+
+
+#if defined(PERL_IMPLICIT_SYS)
+
+#ifndef jmp_buf
+#include <setjmp.h>
+#endif
+
+/* IPerlProc */
+struct IPerlProc;
+struct IPerlProcInfo;
+typedef void (*LPProcAbort)(struct IPerlProc*);
+typedef char* (*LPProcCrypt)(struct IPerlProc*, const char*,
+ const char*);
+typedef void (*LPProcExit)(struct IPerlProc*, int)
+ __attribute__noreturn__;
+typedef void (*LPProc_Exit)(struct IPerlProc*, int)
+ __attribute__noreturn__;
+typedef int (*LPProcExecl)(struct IPerlProc*, const char*,
+ const char*, const char*, const char*,
+ const char*);
+typedef int (*LPProcExecv)(struct IPerlProc*, const char*,
+ const char*const*);
+typedef int (*LPProcExecvp)(struct IPerlProc*, const char*,
+ const char*const*);
+typedef uid_t (*LPProcGetuid)(struct IPerlProc*);
+typedef uid_t (*LPProcGeteuid)(struct IPerlProc*);
+typedef gid_t (*LPProcGetgid)(struct IPerlProc*);
+typedef gid_t (*LPProcGetegid)(struct IPerlProc*);
+typedef char* (*LPProcGetlogin)(struct IPerlProc*);
+typedef int (*LPProcKill)(struct IPerlProc*, int, int);
+typedef int (*LPProcKillpg)(struct IPerlProc*, int, int);
+typedef int (*LPProcPauseProc)(struct IPerlProc*);
+typedef PerlIO* (*LPProcPopen)(struct IPerlProc*, const char*,
+ const char*);
+typedef PerlIO* (*LPProcPopenList)(struct IPerlProc*, const char*,
+ IV narg, SV **args);
+typedef int (*LPProcPclose)(struct IPerlProc*, PerlIO*);
+typedef int (*LPProcPipe)(struct IPerlProc*, int*);
+typedef int (*LPProcSetuid)(struct IPerlProc*, uid_t);
+typedef int (*LPProcSetgid)(struct IPerlProc*, gid_t);
+typedef int (*LPProcSleep)(struct IPerlProc*, unsigned int);
+typedef int (*LPProcTimes)(struct IPerlProc*, struct tms*);
+typedef int (*LPProcWait)(struct IPerlProc*, int*);
+typedef int (*LPProcWaitpid)(struct IPerlProc*, int, int*, int);
+typedef Sighandler_t (*LPProcSignal)(struct IPerlProc*, int, Sighandler_t);
+typedef int (*LPProcFork)(struct IPerlProc*);
+typedef int (*LPProcGetpid)(struct IPerlProc*);
+#ifdef WIN32
+typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*);
+typedef void (*LPProcGetOSError)(struct IPerlProc*,
+ SV* sv, DWORD dwErr);
+typedef int (*LPProcSpawnvp)(struct IPerlProc*, int, const char*,
+ const char*const*);
+#endif
+typedef int (*LPProcLastHost)(struct IPerlProc*);
+typedef int (*LPProcGetTimeOfDay)(struct IPerlProc*,
+ struct timeval*, void*);
+
+struct IPerlProc
+{
+ LPProcAbort pAbort;
+ LPProcCrypt pCrypt;
+ LPProcExit pExit;
+ LPProc_Exit p_Exit;
+ LPProcExecl pExecl;
+ LPProcExecv pExecv;
+ LPProcExecvp pExecvp;
+ LPProcGetuid pGetuid;
+ LPProcGeteuid pGeteuid;
+ LPProcGetgid pGetgid;
+ LPProcGetegid pGetegid;
+ LPProcGetlogin pGetlogin;
+ LPProcKill pKill;
+ LPProcKillpg pKillpg;
+ LPProcPauseProc pPauseProc;
+ LPProcPopen pPopen;
+ LPProcPclose pPclose;
+ LPProcPipe pPipe;
+ LPProcSetuid pSetuid;
+ LPProcSetgid pSetgid;
+ LPProcSleep pSleep;
+ LPProcTimes pTimes;
+ LPProcWait pWait;
+ LPProcWaitpid pWaitpid;
+ LPProcSignal pSignal;
+ LPProcFork pFork;
+ LPProcGetpid pGetpid;
+#ifdef WIN32
+ LPProcDynaLoader pDynaLoader;
+ LPProcGetOSError pGetOSError;
+ LPProcSpawnvp pSpawnvp;
+#endif
+ LPProcLastHost pLastHost;
+ LPProcPopenList pPopenList;
+ LPProcGetTimeOfDay pGetTimeOfDay;
+};
+
+struct IPerlProcInfo
+{
+ unsigned long nCount; /* number of entries expected */
+ struct IPerlProc perlProcList;
+};
+
+#define PerlProc_abort() \
+ (*PL_Proc->pAbort)(PL_Proc)
+#define PerlProc_crypt(c,s) \
+ (*PL_Proc->pCrypt)(PL_Proc, (c), (s))
+#define PerlProc_exit(s) \
+ (*PL_Proc->pExit)(PL_Proc, (s))
+#define PerlProc__exit(s) \
+ (*PL_Proc->p_Exit)(PL_Proc, (s))
+#define PerlProc_execl(c, w, x, y, z) \
+ (*PL_Proc->pExecl)(PL_Proc, (c), (w), (x), (y), (z))
+#define PerlProc_execv(c, a) \
+ (*PL_Proc->pExecv)(PL_Proc, (c), (a))
+#define PerlProc_execvp(c, a) \
+ (*PL_Proc->pExecvp)(PL_Proc, (c), (a))
+#define PerlProc_getuid() \
+ (*PL_Proc->pGetuid)(PL_Proc)
+#define PerlProc_geteuid() \
+ (*PL_Proc->pGeteuid)(PL_Proc)
+#define PerlProc_getgid() \
+ (*PL_Proc->pGetgid)(PL_Proc)
+#define PerlProc_getegid() \
+ (*PL_Proc->pGetegid)(PL_Proc)
+#define PerlProc_getlogin() \
+ (*PL_Proc->pGetlogin)(PL_Proc)
+#define PerlProc_kill(i, a) \
+ (*PL_Proc->pKill)(PL_Proc, (i), (a))
+#define PerlProc_killpg(i, a) \
+ (*PL_Proc->pKillpg)(PL_Proc, (i), (a))
+#define PerlProc_pause() \
+ (*PL_Proc->pPauseProc)(PL_Proc)
+#define PerlProc_popen(c, m) \
+ (*PL_Proc->pPopen)(PL_Proc, (c), (m))
+#define PerlProc_popen_list(m, n, a) \
+ (*PL_Proc->pPopenList)(PL_Proc, (m), (n), (a))
+#define PerlProc_pclose(f) \
+ (*PL_Proc->pPclose)(PL_Proc, (f))
+#define PerlProc_pipe(fd) \
+ (*PL_Proc->pPipe)(PL_Proc, (fd))
+#define PerlProc_setuid(u) \
+ (*PL_Proc->pSetuid)(PL_Proc, (u))
+#define PerlProc_setgid(g) \
+ (*PL_Proc->pSetgid)(PL_Proc, (g))
+#define PerlProc_sleep(t) \
+ (*PL_Proc->pSleep)(PL_Proc, (t))
+#define PerlProc_times(t) \
+ (*PL_Proc->pTimes)(PL_Proc, (t))
+#define PerlProc_wait(t) \
+ (*PL_Proc->pWait)(PL_Proc, (t))
+#define PerlProc_waitpid(p,s,f) \
+ (*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f))
+#define PerlProc_signal(n, h) \
+ (*PL_Proc->pSignal)(PL_Proc, (n), (h))
+#define PerlProc_fork() \
+ (*PL_Proc->pFork)(PL_Proc)
+#define PerlProc_getpid() \
+ (*PL_Proc->pGetpid)(PL_Proc)
+#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n))
+#define PerlProc_longjmp(b, n) Siglongjmp((b), (n))
+
+#ifdef WIN32
+#define PerlProc_DynaLoad(f) \
+ (*PL_Proc->pDynaLoader)(PL_Proc, (f))
+#define PerlProc_GetOSError(s,e) \
+ (*PL_Proc->pGetOSError)(PL_Proc, (s), (e))
+#define PerlProc_spawnvp(m, c, a) \
+ (*PL_Proc->pSpawnvp)(PL_Proc, (m), (c), (a))
+#endif
+#define PerlProc_lasthost() \
+ (*PL_Proc->pLastHost)(PL_Proc)
+#define PerlProc_gettimeofday(t,z) \
+ (*PL_Proc->pGetTimeOfDay)(PL_Proc,(t),(z))
+
+#else /* PERL_IMPLICIT_SYS */
+
+#define PerlProc_abort() abort()
+#define PerlProc_crypt(c,s) crypt((c), (s))
+#define PerlProc_exit(s) exit((s))
+#define PerlProc__exit(s) _exit((s))
+#define PerlProc_execl(c,w,x,y,z) \
+ execl((c), (w), (x), (y), (z))
+#define PerlProc_execv(c, a) execv((c), (a))
+#define PerlProc_execvp(c, a) execvp((c), (a))
+#define PerlProc_getuid() getuid()
+#define PerlProc_geteuid() geteuid()
+#define PerlProc_getgid() getgid()
+#define PerlProc_getegid() getegid()
+#define PerlProc_getlogin() getlogin()
+#define PerlProc_kill(i, a) kill((i), (a))
+#define PerlProc_killpg(i, a) killpg((i), (a))
+#define PerlProc_pause() Pause()
+#define PerlProc_popen(c, m) my_popen((c), (m))
+#define PerlProc_popen_list(m,n,a) my_popen_list((m),(n),(a))
+#define PerlProc_pclose(f) my_pclose((f))
+#define PerlProc_pipe(fd) pipe((fd))
+#define PerlProc_setuid(u) setuid((u))
+#define PerlProc_setgid(g) setgid((g))
+#define PerlProc_sleep(t) sleep((t))
+#define PerlProc_times(t) times((t))
+#define PerlProc_wait(t) wait((t))
+#define PerlProc_waitpid(p,s,f) waitpid((p), (s), (f))
+#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n))
+#define PerlProc_longjmp(b, n) Siglongjmp((b), (n))
+#define PerlProc_signal(n, h) signal((n), (h))
+#define PerlProc_fork() my_fork()
+#define PerlProc_getpid() getpid()
+#define PerlProc_gettimeofday(t,z) gettimeofday((t),(z))
+
+#ifdef WIN32
+#define PerlProc_DynaLoad(f) \
+ win32_dynaload((f))
+#define PerlProc_GetOSError(s,e) \
+ win32_str_os_error((s), (e))
+#define PerlProc_spawnvp(m, c, a) \
+ win32_spawnvp((m), (c), (a))
+#undef PerlProc_signal
+#define PerlProc_signal(n, h) win32_signal((n), (h))
+#endif
+#endif /* PERL_IMPLICIT_SYS */
+
+/*
+ Interface for perl socket functions
+*/
+
+#if defined(PERL_IMPLICIT_SYS)
+
+/* PerlSock */
+struct IPerlSock;
+struct IPerlSockInfo;
+typedef u_long (*LPHtonl)(struct IPerlSock*, u_long);
+typedef u_short (*LPHtons)(struct IPerlSock*, u_short);
+typedef u_long (*LPNtohl)(struct IPerlSock*, u_long);
+typedef u_short (*LPNtohs)(struct IPerlSock*, u_short);
+typedef SOCKET (*LPAccept)(struct IPerlSock*, SOCKET,
+ struct sockaddr*, int*);
+typedef int (*LPBind)(struct IPerlSock*, SOCKET,
+ const struct sockaddr*, int);
+typedef int (*LPConnect)(struct IPerlSock*, SOCKET,
+ const struct sockaddr*, int);
+typedef void (*LPEndhostent)(struct IPerlSock*);
+typedef void (*LPEndnetent)(struct IPerlSock*);
+typedef void (*LPEndprotoent)(struct IPerlSock*);
+typedef void (*LPEndservent)(struct IPerlSock*);
+typedef int (*LPGethostname)(struct IPerlSock*, char*, int);
+typedef int (*LPGetpeername)(struct IPerlSock*, SOCKET,
+ struct sockaddr*, int*);
+typedef struct hostent* (*LPGethostbyaddr)(struct IPerlSock*, const char*,
+ int, int);
+typedef struct hostent* (*LPGethostbyname)(struct IPerlSock*, const char*);
+typedef struct hostent* (*LPGethostent)(struct IPerlSock*);
+typedef struct netent* (*LPGetnetbyaddr)(struct IPerlSock*, long, int);
+typedef struct netent* (*LPGetnetbyname)(struct IPerlSock*, const char*);
+typedef struct netent* (*LPGetnetent)(struct IPerlSock*);
+typedef struct protoent*(*LPGetprotobyname)(struct IPerlSock*, const char*);
+typedef struct protoent*(*LPGetprotobynumber)(struct IPerlSock*, int);
+typedef struct protoent*(*LPGetprotoent)(struct IPerlSock*);
+typedef struct servent* (*LPGetservbyname)(struct IPerlSock*, const char*,
+ const char*);
+typedef struct servent* (*LPGetservbyport)(struct IPerlSock*, int,
+ const char*);
+typedef struct servent* (*LPGetservent)(struct IPerlSock*);
+typedef int (*LPGetsockname)(struct IPerlSock*, SOCKET,
+ struct sockaddr*, int*);
+typedef int (*LPGetsockopt)(struct IPerlSock*, SOCKET, int, int,
+ char*, int*);
+typedef unsigned long (*LPInetAddr)(struct IPerlSock*, const char*);
+typedef char* (*LPInetNtoa)(struct IPerlSock*, struct in_addr);
+typedef int (*LPListen)(struct IPerlSock*, SOCKET, int);
+typedef int (*LPRecv)(struct IPerlSock*, SOCKET, char*, int, int);
+typedef int (*LPRecvfrom)(struct IPerlSock*, SOCKET, char*, int,
+ int, struct sockaddr*, int*);
+typedef int (*LPSelect)(struct IPerlSock*, int, char*, char*,
+ char*, const struct timeval*);
+typedef int (*LPSend)(struct IPerlSock*, SOCKET, const char*, int,
+ int);
+typedef int (*LPSendto)(struct IPerlSock*, SOCKET, const char*,
+ int, int, const struct sockaddr*, int);
+typedef void (*LPSethostent)(struct IPerlSock*, int);
+typedef void (*LPSetnetent)(struct IPerlSock*, int);
+typedef void (*LPSetprotoent)(struct IPerlSock*, int);
+typedef void (*LPSetservent)(struct IPerlSock*, int);
+typedef int (*LPSetsockopt)(struct IPerlSock*, SOCKET, int, int,
+ const char*, int);
+typedef int (*LPShutdown)(struct IPerlSock*, SOCKET, int);
+typedef SOCKET (*LPSocket)(struct IPerlSock*, int, int, int);
+typedef int (*LPSocketpair)(struct IPerlSock*, int, int, int,
+ int*);
+#ifdef WIN32
+typedef int (*LPClosesocket)(struct IPerlSock*, SOCKET s);
+#endif
+
+struct IPerlSock
+{
+ LPHtonl pHtonl;
+ LPHtons pHtons;
+ LPNtohl pNtohl;
+ LPNtohs pNtohs;
+ LPAccept pAccept;
+ LPBind pBind;
+ LPConnect pConnect;
+ LPEndhostent pEndhostent;
+ LPEndnetent pEndnetent;
+ LPEndprotoent pEndprotoent;
+ LPEndservent pEndservent;
+ LPGethostname pGethostname;
+ LPGetpeername pGetpeername;
+ LPGethostbyaddr pGethostbyaddr;
+ LPGethostbyname pGethostbyname;
+ LPGethostent pGethostent;
+ LPGetnetbyaddr pGetnetbyaddr;
+ LPGetnetbyname pGetnetbyname;
+ LPGetnetent pGetnetent;
+ LPGetprotobyname pGetprotobyname;
+ LPGetprotobynumber pGetprotobynumber;
+ LPGetprotoent pGetprotoent;
+ LPGetservbyname pGetservbyname;
+ LPGetservbyport pGetservbyport;
+ LPGetservent pGetservent;
+ LPGetsockname pGetsockname;
+ LPGetsockopt pGetsockopt;
+ LPInetAddr pInetAddr;
+ LPInetNtoa pInetNtoa;
+ LPListen pListen;
+ LPRecv pRecv;
+ LPRecvfrom pRecvfrom;
+ LPSelect pSelect;
+ LPSend pSend;
+ LPSendto pSendto;
+ LPSethostent pSethostent;
+ LPSetnetent pSetnetent;
+ LPSetprotoent pSetprotoent;
+ LPSetservent pSetservent;
+ LPSetsockopt pSetsockopt;
+ LPShutdown pShutdown;
+ LPSocket pSocket;
+ LPSocketpair pSocketpair;
+#ifdef WIN32
+ LPClosesocket pClosesocket;
+#endif
+};
+
+struct IPerlSockInfo
+{
+ unsigned long nCount; /* number of entries expected */
+ struct IPerlSock perlSockList;
+};
+
+#define PerlSock_htonl(x) \
+ (*PL_Sock->pHtonl)(PL_Sock, x)
+#define PerlSock_htons(x) \
+ (*PL_Sock->pHtons)(PL_Sock, x)
+#define PerlSock_ntohl(x) \
+ (*PL_Sock->pNtohl)(PL_Sock, x)
+#define PerlSock_ntohs(x) \
+ (*PL_Sock->pNtohs)(PL_Sock, x)
+#define PerlSock_accept(s, a, l) \
+ (*PL_Sock->pAccept)(PL_Sock, s, a, l)
+#define PerlSock_bind(s, n, l) \
+ (*PL_Sock->pBind)(PL_Sock, s, n, l)
+#define PerlSock_connect(s, n, l) \
+ (*PL_Sock->pConnect)(PL_Sock, s, n, l)
+#define PerlSock_endhostent() \
+ (*PL_Sock->pEndhostent)(PL_Sock)
+#define PerlSock_endnetent() \
+ (*PL_Sock->pEndnetent)(PL_Sock)
+#define PerlSock_endprotoent() \
+ (*PL_Sock->pEndprotoent)(PL_Sock)
+#define PerlSock_endservent() \
+ (*PL_Sock->pEndservent)(PL_Sock)
+#define PerlSock_gethostbyaddr(a, l, t) \
+ (*PL_Sock->pGethostbyaddr)(PL_Sock, a, l, t)
+#define PerlSock_gethostbyname(n) \
+ (*PL_Sock->pGethostbyname)(PL_Sock, n)
+#define PerlSock_gethostent() \
+ (*PL_Sock->pGethostent)(PL_Sock)
+#define PerlSock_gethostname(n, l) \
+ (*PL_Sock->pGethostname)(PL_Sock, n, l)
+#define PerlSock_getnetbyaddr(n, t) \
+ (*PL_Sock->pGetnetbyaddr)(PL_Sock, n, t)
+#define PerlSock_getnetbyname(c) \
+ (*PL_Sock->pGetnetbyname)(PL_Sock, c)
+#define PerlSock_getnetent() \
+ (*PL_Sock->pGetnetent)(PL_Sock)
+#define PerlSock_getpeername(s, n, l) \
+ (*PL_Sock->pGetpeername)(PL_Sock, s, n, l)
+#define PerlSock_getprotobyname(n) \
+ (*PL_Sock->pGetprotobyname)(PL_Sock, n)
+#define PerlSock_getprotobynumber(n) \
+ (*PL_Sock->pGetprotobynumber)(PL_Sock, n)
+#define PerlSock_getprotoent() \
+ (*PL_Sock->pGetprotoent)(PL_Sock)
+#define PerlSock_getservbyname(n, p) \
+ (*PL_Sock->pGetservbyname)(PL_Sock, n, p)
+#define PerlSock_getservbyport(port, p) \
+ (*PL_Sock->pGetservbyport)(PL_Sock, port, p)
+#define PerlSock_getservent() \
+ (*PL_Sock->pGetservent)(PL_Sock)
+#define PerlSock_getsockname(s, n, l) \
+ (*PL_Sock->pGetsockname)(PL_Sock, s, n, l)
+#define PerlSock_getsockopt(s,l,n,v,i) \
+ (*PL_Sock->pGetsockopt)(PL_Sock, s, l, n, v, i)
+#define PerlSock_inet_addr(c) \
+ (*PL_Sock->pInetAddr)(PL_Sock, c)
+#define PerlSock_inet_ntoa(i) \
+ (*PL_Sock->pInetNtoa)(PL_Sock, i)
+#define PerlSock_listen(s, b) \
+ (*PL_Sock->pListen)(PL_Sock, s, b)
+#define PerlSock_recv(s, b, l, f) \
+ (*PL_Sock->pRecv)(PL_Sock, s, b, l, f)
+#define PerlSock_recvfrom(s,b,l,f,from,fromlen) \
+ (*PL_Sock->pRecvfrom)(PL_Sock, s, b, l, f, from, fromlen)
+#define PerlSock_select(n, r, w, e, t) \
+ (*PL_Sock->pSelect)(PL_Sock, n, (char*)r, (char*)w, (char*)e, t)
+#define PerlSock_send(s, b, l, f) \
+ (*PL_Sock->pSend)(PL_Sock, s, b, l, f)
+#define PerlSock_sendto(s, b, l, f, t, tlen) \
+ (*PL_Sock->pSendto)(PL_Sock, s, b, l, f, t, tlen)
+#define PerlSock_sethostent(f) \
+ (*PL_Sock->pSethostent)(PL_Sock, f)
+#define PerlSock_setnetent(f) \
+ (*PL_Sock->pSetnetent)(PL_Sock, f)
+#define PerlSock_setprotoent(f) \
+ (*PL_Sock->pSetprotoent)(PL_Sock, f)
+#define PerlSock_setservent(f) \
+ (*PL_Sock->pSetservent)(PL_Sock, f)
+#define PerlSock_setsockopt(s, l, n, v, len) \
+ (*PL_Sock->pSetsockopt)(PL_Sock, s, l, n, v, len)
+#define PerlSock_shutdown(s, h) \
+ (*PL_Sock->pShutdown)(PL_Sock, s, h)
+#define PerlSock_socket(a, t, p) \
+ (*PL_Sock->pSocket)(PL_Sock, a, t, p)
+#define PerlSock_socketpair(a, t, p, f) \
+ (*PL_Sock->pSocketpair)(PL_Sock, a, t, p, f)
+
+#ifdef WIN32
+#define PerlSock_closesocket(s) \
+ (*PL_Sock->pClosesocket)(PL_Sock, s)
+#endif
+
+#else /* PERL_IMPLICIT_SYS */
+
+#define PerlSock_htonl(x) htonl(x)
+#define PerlSock_htons(x) htons(x)
+#define PerlSock_ntohl(x) ntohl(x)
+#define PerlSock_ntohs(x) ntohs(x)
+#define PerlSock_accept(s, a, l) accept(s, a, l)
+#define PerlSock_bind(s, n, l) bind(s, n, l)
+#define PerlSock_connect(s, n, l) connect(s, n, l)
+
+#define PerlSock_gethostbyaddr(a, l, t) gethostbyaddr(a, l, t)
+#define PerlSock_gethostbyname(n) gethostbyname(n)
+#define PerlSock_gethostent gethostent
+#define PerlSock_endhostent endhostent
+#define PerlSock_gethostname(n, l) gethostname(n, l)
+
+#define PerlSock_getnetbyaddr(n, t) getnetbyaddr(n, t)
+#define PerlSock_getnetbyname(n) getnetbyname(n)
+#define PerlSock_getnetent getnetent
+#define PerlSock_endnetent endnetent
+#define PerlSock_getpeername(s, n, l) getpeername(s, n, l)
+
+#define PerlSock_getprotobyname(n) getprotobyname(n)
+#define PerlSock_getprotobynumber(n) getprotobynumber(n)
+#define PerlSock_getprotoent getprotoent
+#define PerlSock_endprotoent endprotoent
+
+#define PerlSock_getservbyname(n, p) getservbyname(n, p)
+#define PerlSock_getservbyport(port, p) getservbyport(port, p)
+#define PerlSock_getservent getservent
+#define PerlSock_endservent endservent
+
+#define PerlSock_getsockname(s, n, l) getsockname(s, n, l)
+#define PerlSock_getsockopt(s,l,n,v,i) getsockopt(s, l, n, v, i)
+#define PerlSock_inet_addr(c) inet_addr(c)
+#define PerlSock_inet_ntoa(i) inet_ntoa(i)
+#define PerlSock_listen(s, b) listen(s, b)
+#define PerlSock_recv(s, b, l, f) recv(s, b, l, f)
+#define PerlSock_recvfrom(s, b, l, f, from, fromlen) \
+ recvfrom(s, b, l, f, from, fromlen)
+#define PerlSock_select(n, r, w, e, t) select(n, r, w, e, t)
+#define PerlSock_send(s, b, l, f) send(s, b, l, f)
+#define PerlSock_sendto(s, b, l, f, t, tlen) \
+ sendto(s, b, l, f, t, tlen)
+#define PerlSock_sethostent(f) sethostent(f)
+#define PerlSock_setnetent(f) setnetent(f)
+#define PerlSock_setprotoent(f) setprotoent(f)
+#define PerlSock_setservent(f) setservent(f)
+#define PerlSock_setsockopt(s, l, n, v, len) \
+ setsockopt(s, l, n, v, len)
+#define PerlSock_shutdown(s, h) shutdown(s, h)
+#define PerlSock_socket(a, t, p) socket(a, t, p)
+#define PerlSock_socketpair(a, t, p, f) socketpair(a, t, p, f)
+
+#ifdef WIN32
+#define PerlSock_closesocket(s) closesocket(s)
+#endif
+
+#endif /* PERL_IMPLICIT_SYS */
+
+#endif /* __Inc__IPerl___ */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/keywords.h b/Master/tlpkg/tlperl.straw/lib/CORE/keywords.h
new file mode 100755
index 00000000000..b2e996db886
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/keywords.h
@@ -0,0 +1,269 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * keywords.h
+ *
+ * Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2005,
+ * 2006, 2007, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by keywords.pl from its data. Any changes made here
+ * will be lost!
+ */
+#define KEY_NULL 0
+#define KEY___FILE__ 1
+#define KEY___LINE__ 2
+#define KEY___PACKAGE__ 3
+#define KEY___DATA__ 4
+#define KEY___END__ 5
+#define KEY_AUTOLOAD 6
+#define KEY_BEGIN 7
+#define KEY_UNITCHECK 8
+#define KEY_CORE 9
+#define KEY_DESTROY 10
+#define KEY_END 11
+#define KEY_INIT 12
+#define KEY_CHECK 13
+#define KEY_abs 14
+#define KEY_accept 15
+#define KEY_alarm 16
+#define KEY_and 17
+#define KEY_atan2 18
+#define KEY_bind 19
+#define KEY_binmode 20
+#define KEY_bless 21
+#define KEY_break 22
+#define KEY_caller 23
+#define KEY_chdir 24
+#define KEY_chmod 25
+#define KEY_chomp 26
+#define KEY_chop 27
+#define KEY_chown 28
+#define KEY_chr 29
+#define KEY_chroot 30
+#define KEY_close 31
+#define KEY_closedir 32
+#define KEY_cmp 33
+#define KEY_connect 34
+#define KEY_continue 35
+#define KEY_cos 36
+#define KEY_crypt 37
+#define KEY_dbmclose 38
+#define KEY_dbmopen 39
+#define KEY_default 40
+#define KEY_defined 41
+#define KEY_delete 42
+#define KEY_die 43
+#define KEY_do 44
+#define KEY_dump 45
+#define KEY_each 46
+#define KEY_else 47
+#define KEY_elsif 48
+#define KEY_endgrent 49
+#define KEY_endhostent 50
+#define KEY_endnetent 51
+#define KEY_endprotoent 52
+#define KEY_endpwent 53
+#define KEY_endservent 54
+#define KEY_eof 55
+#define KEY_eq 56
+#define KEY_eval 57
+#define KEY_exec 58
+#define KEY_exists 59
+#define KEY_exit 60
+#define KEY_exp 61
+#define KEY_fcntl 62
+#define KEY_fileno 63
+#define KEY_flock 64
+#define KEY_for 65
+#define KEY_foreach 66
+#define KEY_fork 67
+#define KEY_format 68
+#define KEY_formline 69
+#define KEY_ge 70
+#define KEY_getc 71
+#define KEY_getgrent 72
+#define KEY_getgrgid 73
+#define KEY_getgrnam 74
+#define KEY_gethostbyaddr 75
+#define KEY_gethostbyname 76
+#define KEY_gethostent 77
+#define KEY_getlogin 78
+#define KEY_getnetbyaddr 79
+#define KEY_getnetbyname 80
+#define KEY_getnetent 81
+#define KEY_getpeername 82
+#define KEY_getpgrp 83
+#define KEY_getppid 84
+#define KEY_getpriority 85
+#define KEY_getprotobyname 86
+#define KEY_getprotobynumber 87
+#define KEY_getprotoent 88
+#define KEY_getpwent 89
+#define KEY_getpwnam 90
+#define KEY_getpwuid 91
+#define KEY_getservbyname 92
+#define KEY_getservbyport 93
+#define KEY_getservent 94
+#define KEY_getsockname 95
+#define KEY_getsockopt 96
+#define KEY_given 97
+#define KEY_glob 98
+#define KEY_gmtime 99
+#define KEY_goto 100
+#define KEY_grep 101
+#define KEY_gt 102
+#define KEY_hex 103
+#define KEY_if 104
+#define KEY_index 105
+#define KEY_int 106
+#define KEY_ioctl 107
+#define KEY_join 108
+#define KEY_keys 109
+#define KEY_kill 110
+#define KEY_last 111
+#define KEY_lc 112
+#define KEY_lcfirst 113
+#define KEY_le 114
+#define KEY_length 115
+#define KEY_link 116
+#define KEY_listen 117
+#define KEY_local 118
+#define KEY_localtime 119
+#define KEY_lock 120
+#define KEY_log 121
+#define KEY_lstat 122
+#define KEY_lt 123
+#define KEY_m 124
+#define KEY_map 125
+#define KEY_mkdir 126
+#define KEY_msgctl 127
+#define KEY_msgget 128
+#define KEY_msgrcv 129
+#define KEY_msgsnd 130
+#define KEY_my 131
+#define KEY_ne 132
+#define KEY_next 133
+#define KEY_no 134
+#define KEY_not 135
+#define KEY_oct 136
+#define KEY_open 137
+#define KEY_opendir 138
+#define KEY_or 139
+#define KEY_ord 140
+#define KEY_our 141
+#define KEY_pack 142
+#define KEY_package 143
+#define KEY_pipe 144
+#define KEY_pop 145
+#define KEY_pos 146
+#define KEY_print 147
+#define KEY_printf 148
+#define KEY_prototype 149
+#define KEY_push 150
+#define KEY_q 151
+#define KEY_qq 152
+#define KEY_qr 153
+#define KEY_quotemeta 154
+#define KEY_qw 155
+#define KEY_qx 156
+#define KEY_rand 157
+#define KEY_read 158
+#define KEY_readdir 159
+#define KEY_readline 160
+#define KEY_readlink 161
+#define KEY_readpipe 162
+#define KEY_recv 163
+#define KEY_redo 164
+#define KEY_ref 165
+#define KEY_rename 166
+#define KEY_require 167
+#define KEY_reset 168
+#define KEY_return 169
+#define KEY_reverse 170
+#define KEY_rewinddir 171
+#define KEY_rindex 172
+#define KEY_rmdir 173
+#define KEY_s 174
+#define KEY_say 175
+#define KEY_scalar 176
+#define KEY_seek 177
+#define KEY_seekdir 178
+#define KEY_select 179
+#define KEY_semctl 180
+#define KEY_semget 181
+#define KEY_semop 182
+#define KEY_send 183
+#define KEY_setgrent 184
+#define KEY_sethostent 185
+#define KEY_setnetent 186
+#define KEY_setpgrp 187
+#define KEY_setpriority 188
+#define KEY_setprotoent 189
+#define KEY_setpwent 190
+#define KEY_setservent 191
+#define KEY_setsockopt 192
+#define KEY_shift 193
+#define KEY_shmctl 194
+#define KEY_shmget 195
+#define KEY_shmread 196
+#define KEY_shmwrite 197
+#define KEY_shutdown 198
+#define KEY_sin 199
+#define KEY_sleep 200
+#define KEY_socket 201
+#define KEY_socketpair 202
+#define KEY_sort 203
+#define KEY_splice 204
+#define KEY_split 205
+#define KEY_sprintf 206
+#define KEY_sqrt 207
+#define KEY_srand 208
+#define KEY_stat 209
+#define KEY_state 210
+#define KEY_study 211
+#define KEY_sub 212
+#define KEY_substr 213
+#define KEY_symlink 214
+#define KEY_syscall 215
+#define KEY_sysopen 216
+#define KEY_sysread 217
+#define KEY_sysseek 218
+#define KEY_system 219
+#define KEY_syswrite 220
+#define KEY_tell 221
+#define KEY_telldir 222
+#define KEY_tie 223
+#define KEY_tied 224
+#define KEY_time 225
+#define KEY_times 226
+#define KEY_tr 227
+#define KEY_truncate 228
+#define KEY_uc 229
+#define KEY_ucfirst 230
+#define KEY_umask 231
+#define KEY_undef 232
+#define KEY_unless 233
+#define KEY_unlink 234
+#define KEY_unpack 235
+#define KEY_unshift 236
+#define KEY_untie 237
+#define KEY_until 238
+#define KEY_use 239
+#define KEY_utime 240
+#define KEY_values 241
+#define KEY_vec 242
+#define KEY_wait 243
+#define KEY_waitpid 244
+#define KEY_wantarray 245
+#define KEY_warn 246
+#define KEY_when 247
+#define KEY_while 248
+#define KEY_write 249
+#define KEY_x 250
+#define KEY_xor 251
+#define KEY_y 252
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/libperl510.a b/Master/tlpkg/tlperl.straw/lib/CORE/libperl510.a
new file mode 100755
index 00000000000..48b937fd497
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/libperl510.a
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/malloc_ctl.h b/Master/tlpkg/tlperl.straw/lib/CORE/malloc_ctl.h
new file mode 100755
index 00000000000..7a6aed0db73
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/malloc_ctl.h
@@ -0,0 +1,64 @@
+#ifndef MALLOC_CTL_H
+# define MALLOC_CTL_H
+
+struct perl_mstats {
+ UV *nfree;
+ UV *ntotal;
+ IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain;
+ IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains;
+ IV minbucket;
+ /* Level 1 info */
+ UV *bucket_mem_size;
+ UV *bucket_available_size;
+ UV nbuckets;
+};
+typedef struct perl_mstats perl_mstats_t;
+
+START_EXTERN_C
+Malloc_t Perl_malloc (MEM_SIZE nbytes);
+Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size);
+Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes);
+/* 'mfree' rather than 'free', since there is already a 'perl_free'
+ * that causes clashes with case-insensitive linkers */
+Free_t Perl_mfree (Malloc_t where);
+END_EXTERN_C
+
+#ifndef NO_MALLOC_DYNAMIC_CFG
+
+/* IV configuration data */
+enum {
+ MallocCfg_FIRST_SBRK,
+ MallocCfg_MIN_SBRK,
+ MallocCfg_MIN_SBRK_FRAC1000,
+ MallocCfg_SBRK_ALLOW_FAILURES,
+ MallocCfg_SBRK_FAILURE_PRICE,
+ MallocCfg_sbrk_goodness,
+
+ MallocCfg_filldead,
+ MallocCfg_fillalive,
+ MallocCfg_fillcheck,
+
+ MallocCfg_skip_cfg_env,
+ MallocCfg_cfg_env_read,
+
+ MallocCfg_emergency_buffer_size,
+ MallocCfg_emergency_buffer_last_req,
+
+ MallocCfg_emergency_buffer_prepared_size,
+
+ MallocCfg_last
+};
+/* char* configuration data */
+enum {
+ MallocCfgP_emergency_buffer,
+ MallocCfgP_emergency_buffer_prepared,
+ MallocCfgP_last
+};
+START_EXTERN_C
+extern IV *MallocCfg_ptr;
+extern char **MallocCfgP_ptr;
+END_EXTERN_C
+
+#endif
+
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/mg.h b/Master/tlpkg/tlperl.straw/lib/CORE/mg.h
new file mode 100755
index 00000000000..2248365419e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/mg.h
@@ -0,0 +1,72 @@
+/* mg.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999,
+ * 2000, 2002, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifdef STRUCT_MGVTBL_DEFINITION
+STRUCT_MGVTBL_DEFINITION;
+#else
+struct mgvtbl {
+ int (CPERLscope(*svt_get)) (pTHX_ SV *sv, MAGIC* mg);
+ int (CPERLscope(*svt_set)) (pTHX_ SV *sv, MAGIC* mg);
+ U32 (CPERLscope(*svt_len)) (pTHX_ SV *sv, MAGIC* mg);
+ int (CPERLscope(*svt_clear))(pTHX_ SV *sv, MAGIC* mg);
+ int (CPERLscope(*svt_free)) (pTHX_ SV *sv, MAGIC* mg);
+ int (CPERLscope(*svt_copy)) (pTHX_ SV *sv, MAGIC* mg,
+ SV *nsv, const char *name, int namlen);
+ int (CPERLscope(*svt_dup)) (pTHX_ MAGIC *mg, CLONE_PARAMS *param);
+ int (CPERLscope(*svt_local))(pTHX_ SV *nsv, MAGIC *mg);
+};
+#endif
+
+struct magic {
+ MAGIC* mg_moremagic;
+ MGVTBL* mg_virtual; /* pointer to magic functions */
+ U16 mg_private;
+ char mg_type;
+ U8 mg_flags;
+ I32 mg_len;
+ SV* mg_obj;
+ char* mg_ptr;
+};
+
+#define MGf_TAINTEDDIR 1 /* PERL_MAGIC_envelem only */
+#define MGf_MINMATCH 1 /* PERL_MAGIC_regex_global only */
+#define MGf_REFCOUNTED 2
+#define MGf_GSKIP 4
+#define MGf_COPY 8 /* has an svt_copy MGVTBL entry */
+#define MGf_DUP 0x10 /* has an svt_dup MGVTBL entry */
+#define MGf_LOCAL 0x20 /* has an svt_local MGVTBL entry */
+
+#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR)
+
+#define MgPV(mg,lp) ((((int)(lp = (mg)->mg_len)) == HEf_SVKEY) ? \
+ SvPV(MUTABLE_SV((mg)->mg_ptr),lp) : \
+ (mg)->mg_ptr)
+#define MgPV_const(mg,lp) ((((int)(lp = (mg)->mg_len)) == HEf_SVKEY) ? \
+ SvPV_const(MUTABLE_SV((mg)->mg_ptr),lp) : \
+ (const char*)(mg)->mg_ptr)
+#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
+ SvPV_nolen_const(MUTABLE_SV((mg)->mg_ptr)) : \
+ (const char*)(mg)->mg_ptr)
+
+#define SvTIED_mg(sv,how) (SvRMAGICAL(sv) ? mg_find((sv),(how)) : NULL)
+#define SvTIED_obj(sv,mg) \
+ ((mg)->mg_obj ? (mg)->mg_obj : sv_2mortal(newRV(sv)))
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/mydtrace.h b/Master/tlpkg/tlperl.straw/lib/CORE/mydtrace.h
new file mode 100755
index 00000000000..daabcfa0b9c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/mydtrace.h
@@ -0,0 +1,42 @@
+/* mydtrace.h
+ *
+ * Copyright (C) 2008, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * Provides macros that wrap the various DTrace probes we use. We add
+ * an extra level of wrapping to encapsulate the _ENABLED tests.
+ */
+
+#if defined(USE_DTRACE) && defined(PERL_CORE)
+
+# include "perldtrace.h"
+
+# define ENTRY_PROBE(func, file, line) \
+ if (PERL_SUB_ENTRY_ENABLED()) { \
+ PERL_SUB_ENTRY(func, file, line); \
+ }
+
+# define RETURN_PROBE(func, file, line) \
+ if (PERL_SUB_RETURN_ENABLED()) { \
+ PERL_SUB_RETURN(func, file, line); \
+ }
+
+#else
+
+/* NOPs */
+# define ENTRY_PROBE(func, file, line)
+# define RETURN_PROBE(func, file, line)
+
+#endif
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/netdb.h b/Master/tlpkg/tlperl.straw/lib/CORE/netdb.h
new file mode 100755
index 00000000000..43c03c75446
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/netdb.h
@@ -0,0 +1,12 @@
+/* netdb.h */
+
+/* djl */
+/* Provide UNIX compatibility */
+
+
+#ifndef _INC_NETDB
+#define _INC_NETDB
+
+#include <sys/socket.h>
+
+#endif /* _INC_NETDB */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/nostdio.h b/Master/tlpkg/tlperl.straw/lib/CORE/nostdio.h
new file mode 100755
index 00000000000..f6a13b4998c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/nostdio.h
@@ -0,0 +1,136 @@
+/* nostdio.h
+ *
+ * Copyright (C) 1996, 2000, 2001, 2005, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * Strong denial of stdio - make all stdio calls (we can think of) errors
+ */
+/* This is a 1st attempt to stop other include files pulling
+ in real <stdio.h>.
+ A more ambitious set of possible symbols can be found in
+ sfio.h (inside an _cplusplus gard).
+ It is completely pointless as we have already included it ourselves.
+*/
+
+#if !defined(_STDIO_H) && !defined(FILE) && !defined(_STDIO_INCLUDED) && !defined(__STDIO_LOADED)
+#define _STDIO_H
+#define _STDIO_INCLUDED
+#define __STDIO_LOADED
+struct _FILE;
+#define FILE struct _FILE
+#endif
+
+#define _CANNOT "CANNOT"
+
+#undef clearerr
+#undef fclose
+#undef fdopen
+#undef feof
+#undef ferror
+#undef fflush
+#undef fgetc
+#undef fgetpos
+#undef fgets
+#undef fileno
+#undef flockfile
+#undef fopen
+#undef fprintf
+#undef fputc
+#undef fputs
+#undef fread
+#undef freopen
+#undef fscanf
+#undef fseek
+#undef fsetpos
+#undef ftell
+#undef ftrylockfile
+#undef funlockfile
+#undef fwrite
+#undef getc
+#undef getc_unlocked
+#undef getw
+#undef pclose
+#undef popen
+#undef putc
+#undef putc_unlocked
+#undef putw
+#undef rewind
+#undef setbuf
+#undef setvbuf
+#undef stderr
+#undef stdin
+#undef stdout
+#undef tmpfile
+#undef ungetc
+#undef vfprintf
+#undef printf
+
+#define fprintf _CANNOT _fprintf_
+#define printf _CANNOT _printf_
+#define stdin _CANNOT _stdin_
+#define stdout _CANNOT _stdout_
+#define stderr _CANNOT _stderr_
+#ifndef OS2
+#define tmpfile() _CANNOT _tmpfile_
+#endif
+#define fclose(f) _CANNOT _fclose_
+#define fflush(f) _CANNOT _fflush_
+#define fopen(p,m) _CANNOT _fopen_
+#define freopen(p,m,f) _CANNOT _freopen_
+#define setbuf(f,b) _CANNOT _setbuf_
+#define setvbuf(f,b,x,s) _CANNOT _setvbuf_
+#define fscanf _CANNOT _fscanf_
+#define vfprintf(f,fmt,a) _CANNOT _vfprintf_
+#define fgetc(f) _CANNOT _fgetc_
+#define fgets(s,n,f) _CANNOT _fgets_
+#define fputc(c,f) _CANNOT _fputc_
+#define fputs(s,f) _CANNOT _fputs_
+#define getc(f) _CANNOT _getc_
+#define putc(c,f) _CANNOT _putc_
+#ifndef OS2
+#define ungetc(c,f) _CANNOT _ungetc_
+#endif
+#define fread(b,s,c,f) _CANNOT _fread_
+#define fwrite(b,s,c,f) _CANNOT _fwrite_
+#define fgetpos(f,p) _CANNOT _fgetpos_
+#define fseek(f,o,w) _CANNOT _fseek_
+#define fsetpos(f,p) _CANNOT _fsetpos_
+#define ftell(f) _CANNOT _ftell_
+#define rewind(f) _CANNOT _rewind_
+#define clearerr(f) _CANNOT _clearerr_
+#define feof(f) _CANNOT _feof_
+#define ferror(f) _CANNOT _ferror_
+#define __filbuf(f) _CANNOT __filbuf_
+#define __flsbuf(c,f) _CANNOT __flsbuf_
+#define _filbuf(f) _CANNOT _filbuf_
+#define _flsbuf(c,f) _CANNOT _flsbuf_
+#define fdopen(fd,p) _CANNOT _fdopen_
+#define fileno(f) _CANNOT _fileno_
+#if defined(SFIO_VERSION) && SFIO_VERSION < 20000101L
+#define flockfile(f) _CANNOT _flockfile_
+#define ftrylockfile(f) _CANNOT _ftrylockfile_
+#define funlockfile(f) _CANNOT _funlockfile_
+#endif
+#define getc_unlocked(f) _CANNOT _getc_unlocked_
+#define putc_unlocked(c,f) _CANNOT _putc_unlocked_
+#define popen(c,m) _CANNOT _popen_
+#define getw(f) _CANNOT _getw_
+#define putw(v,f) _CANNOT _putw_
+#ifndef OS2
+#define pclose(f) _CANNOT _pclose_
+#endif
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/op.h b/Master/tlpkg/tlperl.straw/lib/CORE/op.h
new file mode 100755
index 00000000000..8b2275d11cc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/op.h
@@ -0,0 +1,756 @@
+/* op.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * The fields of BASEOP are:
+ * op_next Pointer to next ppcode to execute after this one.
+ * (Top level pre-grafted op points to first op,
+ * but this is replaced when op is grafted in, when
+ * this op will point to the real next op, and the new
+ * parent takes over role of remembering starting op.)
+ * op_ppaddr Pointer to current ppcode's function.
+ * op_type The type of the operation.
+ * op_opt Whether or not the op has been optimised by the
+ * peephole optimiser.
+ *
+ * See the comments in S_clear_yystack() for more
+ * details on the following three flags:
+ *
+ * op_latefree tell op_free() to clear this op (and free any kids)
+ * but not yet deallocate the struct. This means that
+ * the op may be safely op_free()d multiple times
+ * op_latefreed an op_latefree op has been op_free()d
+ * op_attached this op (sub)tree has been attached to a CV
+ *
+ * op_spare three spare bits!
+ * op_flags Flags common to all operations. See OPf_* below.
+ * op_private Flags peculiar to a particular operation (BUT,
+ * by default, set to the number of children until
+ * the operation is privatized by a check routine,
+ * which may or may not check number of children).
+ */
+
+#define OPCODE U16
+
+#ifdef PERL_MAD
+# define MADPROP_IN_BASEOP MADPROP* op_madprop;
+#else
+# define MADPROP_IN_BASEOP
+#endif
+
+typedef PERL_BITFIELD16 Optype;
+
+#ifdef BASEOP_DEFINITION
+#define BASEOP BASEOP_DEFINITION
+#else
+#define BASEOP \
+ OP* op_next; \
+ OP* op_sibling; \
+ OP* (CPERLscope(*op_ppaddr))(pTHX); \
+ MADPROP_IN_BASEOP \
+ PADOFFSET op_targ; \
+ PERL_BITFIELD16 op_type:9; \
+ PERL_BITFIELD16 op_opt:1; \
+ PERL_BITFIELD16 op_latefree:1; \
+ PERL_BITFIELD16 op_latefreed:1; \
+ PERL_BITFIELD16 op_attached:1; \
+ PERL_BITFIELD16 op_spare:3; \
+ U8 op_flags; \
+ U8 op_private;
+#endif
+
+/* If op_type:9 is changed to :10, also change PUSHEVAL in cop.h.
+ Also, if the type of op_type is ever changed (e.g. to PERL_BITFIELD32)
+ then all the other bit-fields before/after it should change their
+ types too to let VC pack them into the same 4 byte integer.*/
+
+#define OP_GIMME(op,dfl) \
+ (((op)->op_flags & OPf_WANT) == OPf_WANT_VOID ? G_VOID : \
+ ((op)->op_flags & OPf_WANT) == OPf_WANT_SCALAR ? G_SCALAR : \
+ ((op)->op_flags & OPf_WANT) == OPf_WANT_LIST ? G_ARRAY : \
+ dfl)
+
+#define OP_GIMME_REVERSE(flags) \
+ ((flags & G_VOID) ? OPf_WANT_VOID : \
+ (flags & G_ARRAY) ? OPf_WANT_LIST : \
+ OPf_WANT_SCALAR)
+
+/*
+=head1 "Gimme" Values
+
+=for apidoc Amn|U32|GIMME_V
+The XSUB-writer's equivalent to Perl's C<wantarray>. Returns C<G_VOID>,
+C<G_SCALAR> or C<G_ARRAY> for void, scalar or list context,
+respectively.
+
+=for apidoc Amn|U32|GIMME
+A backward-compatible version of C<GIMME_V> which can only return
+C<G_SCALAR> or C<G_ARRAY>; in a void context, it returns C<G_SCALAR>.
+Deprecated. Use C<GIMME_V> instead.
+
+=cut
+*/
+
+#define GIMME_V OP_GIMME(PL_op, block_gimme())
+
+/* Public flags */
+
+#define OPf_WANT 3 /* Mask for "want" bits: */
+#define OPf_WANT_VOID 1 /* Want nothing */
+#define OPf_WANT_SCALAR 2 /* Want single value */
+#define OPf_WANT_LIST 3 /* Want list of any length */
+#define OPf_KIDS 4 /* There is a firstborn child. */
+#define OPf_PARENS 8 /* This operator was parenthesized. */
+ /* (Or block needs explicit scope entry.) */
+#define OPf_REF 16 /* Certified reference. */
+ /* (Return container, not containee). */
+#define OPf_MOD 32 /* Will modify (lvalue). */
+#define OPf_STACKED 64 /* Some arg is arriving on the stack. */
+#define OPf_SPECIAL 128 /* Do something weird for this op: */
+ /* On local LVAL, don't init local value. */
+ /* On OP_CONST, value is the hints hash for
+ eval, so return a copy from pp_const() */
+ /* On OP_SORT, subroutine is inlined. */
+ /* On OP_NOT, inversion was implicit. */
+ /* On OP_LEAVE, don't restore curpm. */
+ /* On truncate, we truncate filehandle */
+ /* On control verbs, we saw no label */
+ /* On flipflop, we saw ... instead of .. */
+ /* On UNOPs, saw bare parens, e.g. eof(). */
+ /* On OP_ENTERSUB || OP_NULL, saw a "do". */
+ /* On OP_EXISTS, treat av as av, not avhv. */
+ /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */
+ /* On OP_ENTERITER, loop var is per-thread */
+ /* On pushre, rx is used as part of split, e.g. split " " */
+ /* On regcomp, "use re 'eval'" was in scope */
+ /* On OP_READLINE, was <$filehandle> */
+ /* On RV2[ACGHS]V, don't create GV--in
+ defined()*/
+ /* On OP_DBSTATE, indicates breakpoint
+ * (runtime property) */
+ /* On OP_AELEMFAST, indiciates pad var */
+ /* On OP_REQUIRE, was seen as CORE::require */
+ /* On OP_ENTERWHEN, there's no condition */
+ /* On OP_BREAK, an implicit break */
+ /* On OP_SMARTMATCH, an implicit smartmatch */
+ /* On OP_ANONHASH and OP_ANONLIST, create a
+ reference to the new anon hash or array */
+
+/* old names; don't use in new code, but don't break them, either */
+#define OPf_LIST OPf_WANT_LIST
+#define OPf_KNOW OPf_WANT
+
+#define GIMME \
+ (PL_op->op_flags & OPf_WANT \
+ ? ((PL_op->op_flags & OPf_WANT) == OPf_WANT_LIST \
+ ? G_ARRAY \
+ : G_SCALAR) \
+ : dowantarray())
+
+/* NOTE: OP_NEXTSTATE, OP_DBSTATE, and OP_SETSTATE (i.e. COPs) carry lower
+ * bits of PL_hints in op_private */
+
+/* Private for lvalues */
+#define OPpLVAL_INTRO 128 /* Lvalue must be localized or lvalue sub */
+
+/* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */
+#define OPpREFCOUNTED 64 /* op_targ carries a refcount */
+
+/* Private for OP_AASSIGN */
+#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
+
+/* Private for OP_SASSIGN */
+#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */
+#define OPpASSIGN_CV_TO_GV 128 /* Possible optimisation for constants. */
+
+/* Private for OP_MATCH and OP_SUBST{,CONST} */
+#define OPpRUNTIME 64 /* Pattern coming in on the stack */
+
+/* Private for OP_TRANS */
+#define OPpTRANS_FROM_UTF 1
+#define OPpTRANS_TO_UTF 2
+#define OPpTRANS_IDENTICAL 4 /* right side is same as left */
+#define OPpTRANS_SQUASH 8
+ /* 16 is used for OPpTARGET_MY */
+#define OPpTRANS_COMPLEMENT 32
+#define OPpTRANS_GROWS 64
+#define OPpTRANS_DELETE 128
+#define OPpTRANS_ALL (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE)
+
+/* Private for OP_REPEAT */
+#define OPpREPEAT_DOLIST 64 /* List replication. */
+
+/* Private for OP_RV2GV, OP_RV2SV, OP_AELEM, OP_HELEM, OP_PADSV */
+#define OPpDEREF (32|64) /* autovivify: Want ref to something: */
+#define OPpDEREF_AV 32 /* Want ref to AV. */
+#define OPpDEREF_HV 64 /* Want ref to HV. */
+#define OPpDEREF_SV (32|64) /* Want ref to SV. */
+ /* OP_ENTERSUB only */
+#define OPpENTERSUB_DB 16 /* Debug subroutine. */
+#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
+#define OPpENTERSUB_NOMOD 64 /* Immune to mod() for :attrlist. */
+ /* OP_ENTERSUB and OP_RV2CV only */
+#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
+#define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */
+#define OPpENTERSUB_INARGS 4 /* Lval used as arg to a sub. */
+ /* OP_GV only */
+#define OPpEARLY_CV 32 /* foo() called before sub foo was parsed */
+ /* OP_?ELEM only */
+#define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */
+ /* OP_RV2?V, OP_GVSV, OP_ENTERITER only */
+#define OPpOUR_INTRO 16 /* Variable was in an our() */
+ /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM */
+#define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */
+ /* OP_PADSV only */
+#define OPpPAD_STATE 16 /* is a "state" pad */
+ /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
+
+ /* OP_RV2GV only */
+#define OPpDONT_INIT_GV 4 /* Call gv_fetchpv with GV_NOINIT */
+/* (Therefore will return whatever is currently in the symbol table, not
+ guaranteed to be a PVGV) */
+
+ /* OP_RV2CV only */
+#define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */
+
+/* Private for OPs with TARGLEX */
+ /* (lower bits may carry MAXARG) */
+#define OPpTARGET_MY 16 /* Target is PADMY. */
+
+/* Private for OP_ENTERITER and OP_ITER */
+#define OPpITER_REVERSED 4 /* for (reverse ...) */
+#define OPpITER_DEF 8 /* for $_ or for my $_ */
+
+/* Private for OP_CONST */
+#define OPpCONST_NOVER 2 /* no 6; */
+#define OPpCONST_SHORTCIRCUIT 4 /* eg the constant 5 in (5 || foo) */
+#define OPpCONST_STRICT 8 /* bearword subject to strict 'subs' */
+#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
+#define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */
+#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
+#define OPpCONST_WARNING 128 /* Was a $^W translated to constant. */
+
+/* Private for OP_FLIP/FLOP */
+#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */
+
+/* Private for OP_LIST */
+#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */
+
+/* Private for OP_DELETE */
+#define OPpSLICE 64 /* Operating on a list of keys */
+
+/* Private for OP_EXISTS */
+#define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */
+
+/* Private for OP_SORT */
+#define OPpSORT_NUMERIC 1 /* Optimized away { $a <=> $b } */
+#define OPpSORT_INTEGER 2 /* Ditto while under "use integer" */
+#define OPpSORT_REVERSE 4 /* Reversed sort */
+#define OPpSORT_INPLACE 8 /* sort in-place; eg @a = sort @a */
+#define OPpSORT_DESCEND 16 /* Descending sort */
+#define OPpSORT_QSORT 32 /* Use quicksort (not mergesort) */
+#define OPpSORT_STABLE 64 /* Use a stable algorithm */
+
+/* Private for OP_OPEN and OP_BACKTICK */
+#define OPpOPEN_IN_RAW 16 /* binmode(F,":raw") on input fh */
+#define OPpOPEN_IN_CRLF 32 /* binmode(F,":crlf") on input fh */
+#define OPpOPEN_OUT_RAW 64 /* binmode(F,":raw") on output fh */
+#define OPpOPEN_OUT_CRLF 128 /* binmode(F,":crlf") on output fh */
+
+/* Private for OP_EXIT, HUSH also for OP_DIE */
+#define OPpHUSH_VMSISH 64 /* hush DCL exit msg vmsish mode*/
+#define OPpEXIT_VMSISH 128 /* exit(0) vs. exit(1) vmsish mode*/
+
+/* Private for OP_FTXXX */
+#define OPpFT_ACCESS 2 /* use filetest 'access' */
+#define OPpFT_STACKED 4 /* stacked filetest, as in "-f -x $f" */
+#define OP_IS_FILETEST_ACCESS(op) \
+ (((op)->op_type) == OP_FTRREAD || \
+ ((op)->op_type) == OP_FTRWRITE || \
+ ((op)->op_type) == OP_FTREXEC || \
+ ((op)->op_type) == OP_FTEREAD || \
+ ((op)->op_type) == OP_FTEWRITE || \
+ ((op)->op_type) == OP_FTEEXEC)
+
+/* Private for OP_(MAP|GREP)(WHILE|START) */
+#define OPpGREP_LEX 2 /* iterate over lexical $_ */
+
+/* Private for OP_ENTEREVAL */
+#define OPpEVAL_HAS_HH 2 /* Does it have a copy of %^H */
+
+struct op {
+ BASEOP
+};
+
+struct unop {
+ BASEOP
+ OP * op_first;
+};
+
+struct binop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+};
+
+struct logop {
+ BASEOP
+ OP * op_first;
+ OP * op_other;
+};
+
+struct listop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+};
+
+struct pmop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+#ifdef USE_ITHREADS
+ IV op_pmoffset;
+#else
+ REGEXP * op_pmregexp; /* compiled expression */
+#endif
+ U32 op_pmflags;
+ union {
+ OP * op_pmreplroot; /* For OP_SUBST */
+#ifdef USE_ITHREADS
+ PADOFFSET op_pmtargetoff; /* For OP_PUSHRE */
+#else
+ GV * op_pmtargetgv;
+#endif
+ } op_pmreplrootu;
+ union {
+ OP * op_pmreplstart; /* Only used in OP_SUBST */
+#ifdef USE_ITHREADS
+ char * op_pmstashpv; /* Only used in OP_MATCH, with PMf_ONCE set */
+#else
+ HV * op_pmstash;
+#endif
+ } op_pmstashstartu;
+};
+
+#ifdef USE_ITHREADS
+#define PM_GETRE(o) (INT2PTR(REGEXP*,SvIVX(PL_regex_pad[(o)->op_pmoffset])))
+/* The assignment is just to enforce type safety (or at least get a warning).
+ */
+#define PM_SETRE(o,r) STMT_START { \
+ const REGEXP *const slosh = (r); \
+ PM_SETRE_OFFSET((o), PTR2IV(slosh)); \
+ } STMT_END
+/* Actually you can assign any IV, not just an offset. And really should it be
+ UV? */
+#define PM_SETRE_OFFSET(o,iv) \
+ STMT_START { \
+ SV* const sv = PL_regex_pad[(o)->op_pmoffset]; \
+ sv_setiv(sv, (iv)); \
+ } STMT_END
+
+# ifndef PERL_CORE
+/* No longer used anywhere in the core. Migrate to Devel::PPPort? */
+#define PM_GETRE_SAFE(o) (PL_regex_pad ? PM_GETRE(o) : (REGEXP*)0)
+#define PM_SETRE_SAFE(o,r) if (PL_regex_pad) PM_SETRE(o,r)
+# endif
+#else
+#define PM_GETRE(o) ((o)->op_pmregexp)
+#define PM_SETRE(o,r) ((o)->op_pmregexp = (r))
+# ifndef PERL_CORE
+#define PM_GETRE_SAFE PM_GETRE
+#define PM_SETRE_SAFE PM_SETRE
+# endif
+#endif
+
+
+#define PMf_RETAINT 0x0001 /* taint $1 etc. if target tainted */
+#define PMf_ONCE 0x0002 /* match successfully only once per
+ reset, with related flag RXf_USED
+ in re->extflags holding state.
+ This is used only for ?? matches,
+ and only on OP_MATCH and OP_QR */
+
+#define PMf_UNUSED 0x0004 /* free for use */
+#define PMf_MAYBE_CONST 0x0008 /* replacement contains variables */
+
+#define PMf_USED 0x0010 /* PMf_ONCE has matched successfully.
+ Not used under threading. */
+
+#define PMf_CONST 0x0040 /* subst replacement is constant */
+#define PMf_KEEP 0x0080 /* keep 1st runtime pattern forever */
+#define PMf_GLOBAL 0x0100 /* pattern had a g modifier */
+#define PMf_CONTINUE 0x0200 /* don't reset pos() if //g fails */
+#define PMf_EVAL 0x0400 /* evaluating replacement as expr */
+
+/* The following flags have exact equivalents in regcomp.h with the prefix RXf_
+ * which are stored in the regexp->extflags member. If you change them here,
+ * you have to change them there, and vice versa.
+ */
+#define PMf_LOCALE 0x00800 /* use locale for character types */
+#define PMf_MULTILINE 0x01000 /* assume multiple lines */
+#define PMf_SINGLELINE 0x02000 /* assume single line */
+#define PMf_FOLD 0x04000 /* case insensitivity */
+#define PMf_EXTENDED 0x08000 /* chuck embedded whitespace */
+#define PMf_KEEPCOPY 0x10000 /* copy the string when matching */
+
+/* mask of bits that need to be transfered to re->extflags */
+#define PMf_COMPILETIME (PMf_MULTILINE|PMf_SINGLELINE|PMf_LOCALE|PMf_FOLD|PMf_EXTENDED|PMf_KEEPCOPY)
+
+#ifdef USE_ITHREADS
+
+# define PmopSTASHPV(o) \
+ (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstashpv : NULL)
+# if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define PmopSTASHPV_set(o,pv) ({ \
+ assert((o)->op_pmflags & PMf_ONCE); \
+ ((o)->op_pmstashstartu.op_pmstashpv = savesharedpv(pv)); \
+ })
+# else
+# define PmopSTASHPV_set(o,pv) \
+ ((o)->op_pmstashstartu.op_pmstashpv = savesharedpv(pv))
+# endif
+# define PmopSTASH(o) (PmopSTASHPV(o) \
+ ? gv_stashpv((o)->op_pmstashstartu.op_pmstashpv,GV_ADD) : NULL)
+# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, ((hv) ? HvNAME_get(hv) : NULL))
+# define PmopSTASH_free(o) PerlMemShared_free(PmopSTASHPV(o))
+
+#else
+# define PmopSTASH(o) \
+ (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstash : NULL)
+# if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define PmopSTASH_set(o,hv) ({ \
+ assert((o)->op_pmflags & PMf_ONCE); \
+ ((o)->op_pmstashstartu.op_pmstash = (hv)); \
+ })
+# else
+# define PmopSTASH_set(o,hv) ((o)->op_pmstashstartu.op_pmstash = (hv))
+# endif
+# define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : NULL)
+ /* op_pmstashstartu.op_pmstash is not refcounted */
+# define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
+/* Note that if this becomes non-empty, then S_forget_pmop in op.c will need
+ changing */
+# define PmopSTASH_free(o)
+#endif
+
+struct svop {
+ BASEOP
+ SV * op_sv;
+};
+
+struct padop {
+ BASEOP
+ PADOFFSET op_padix;
+};
+
+struct pvop {
+ BASEOP
+ char * op_pv;
+};
+
+struct loop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+ OP * op_redoop;
+ OP * op_nextop;
+ OP * op_lastop;
+};
+
+#define cUNOPx(o) ((UNOP*)o)
+#define cBINOPx(o) ((BINOP*)o)
+#define cLISTOPx(o) ((LISTOP*)o)
+#define cLOGOPx(o) ((LOGOP*)o)
+#define cPMOPx(o) ((PMOP*)o)
+#define cSVOPx(o) ((SVOP*)o)
+#define cPADOPx(o) ((PADOP*)o)
+#define cPVOPx(o) ((PVOP*)o)
+#define cCOPx(o) ((COP*)o)
+#define cLOOPx(o) ((LOOP*)o)
+
+#define cUNOP cUNOPx(PL_op)
+#define cBINOP cBINOPx(PL_op)
+#define cLISTOP cLISTOPx(PL_op)
+#define cLOGOP cLOGOPx(PL_op)
+#define cPMOP cPMOPx(PL_op)
+#define cSVOP cSVOPx(PL_op)
+#define cPADOP cPADOPx(PL_op)
+#define cPVOP cPVOPx(PL_op)
+#define cCOP cCOPx(PL_op)
+#define cLOOP cLOOPx(PL_op)
+
+#define cUNOPo cUNOPx(o)
+#define cBINOPo cBINOPx(o)
+#define cLISTOPo cLISTOPx(o)
+#define cLOGOPo cLOGOPx(o)
+#define cPMOPo cPMOPx(o)
+#define cSVOPo cSVOPx(o)
+#define cPADOPo cPADOPx(o)
+#define cPVOPo cPVOPx(o)
+#define cCOPo cCOPx(o)
+#define cLOOPo cLOOPx(o)
+
+#define kUNOP cUNOPx(kid)
+#define kBINOP cBINOPx(kid)
+#define kLISTOP cLISTOPx(kid)
+#define kLOGOP cLOGOPx(kid)
+#define kPMOP cPMOPx(kid)
+#define kSVOP cSVOPx(kid)
+#define kPADOP cPADOPx(kid)
+#define kPVOP cPVOPx(kid)
+#define kCOP cCOPx(kid)
+#define kLOOP cLOOPx(kid)
+
+
+#ifdef USE_ITHREADS
+# define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
+# define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && isGV_with_GP(v) \
+ && GvIN_PAD(v))
+# define IS_PADCONST(v) (v && SvREADONLY(v))
+# define cSVOPx_sv(v) (cSVOPx(v)->op_sv \
+ ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
+# define cSVOPx_svp(v) (cSVOPx(v)->op_sv \
+ ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ))
+#else
+# define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv)
+# define IS_PADGV(v) FALSE
+# define IS_PADCONST(v) FALSE
+# define cSVOPx_sv(v) (cSVOPx(v)->op_sv)
+# define cSVOPx_svp(v) (&cSVOPx(v)->op_sv)
+#endif
+
+#define cGVOP_gv cGVOPx_gv(PL_op)
+#define cGVOPo_gv cGVOPx_gv(o)
+#define kGVOP_gv cGVOPx_gv(kid)
+#define cSVOP_sv cSVOPx_sv(PL_op)
+#define cSVOPo_sv cSVOPx_sv(o)
+#define kSVOP_sv cSVOPx_sv(kid)
+
+#define Nullop ((OP*)NULL)
+
+/* Lowest byte-and-a-bit of PL_opargs */
+#define OA_MARK 1
+#define OA_FOLDCONST 2
+#define OA_RETSCALAR 4
+#define OA_TARGET 8
+#define OA_RETINTEGER 16
+#define OA_OTHERINT 32
+#define OA_DANGEROUS 64
+#define OA_DEFGV 128
+#define OA_TARGLEX 256
+
+/* The next 4 bits encode op class information */
+#define OCSHIFT 9
+
+#define OA_CLASS_MASK (15 << OCSHIFT)
+
+#define OA_BASEOP (0 << OCSHIFT)
+#define OA_UNOP (1 << OCSHIFT)
+#define OA_BINOP (2 << OCSHIFT)
+#define OA_LOGOP (3 << OCSHIFT)
+#define OA_LISTOP (4 << OCSHIFT)
+#define OA_PMOP (5 << OCSHIFT)
+#define OA_SVOP (6 << OCSHIFT)
+#define OA_PADOP (7 << OCSHIFT)
+#define OA_PVOP_OR_SVOP (8 << OCSHIFT)
+#define OA_LOOP (9 << OCSHIFT)
+#define OA_COP (10 << OCSHIFT)
+#define OA_BASEOP_OR_UNOP (11 << OCSHIFT)
+#define OA_FILESTATOP (12 << OCSHIFT)
+#define OA_LOOPEXOP (13 << OCSHIFT)
+
+#define OASHIFT 13
+
+/* Remaining nybbles of PL_opargs */
+#define OA_SCALAR 1
+#define OA_LIST 2
+#define OA_AVREF 3
+#define OA_HVREF 4
+#define OA_CVREF 5
+#define OA_FILEREF 6
+#define OA_SCALARREF 7
+#define OA_OPTIONAL 8
+
+/* Op_REFCNT is a reference count at the head of each op tree: needed
+ * since the tree is shared between threads, and between cloned closure
+ * copies in the same thread. OP_REFCNT_LOCK/UNLOCK is used when modifying
+ * this count.
+ * The same mutex is used to protect the refcounts of the reg_trie_data
+ * and reg_ac_data structures, which are shared between duplicated
+ * regexes.
+ */
+
+#ifdef USE_ITHREADS
+# define OP_REFCNT_INIT MUTEX_INIT(&PL_op_mutex)
+# ifdef PERL_CORE
+# define OP_REFCNT_LOCK MUTEX_LOCK(&PL_op_mutex)
+# define OP_REFCNT_UNLOCK MUTEX_UNLOCK(&PL_op_mutex)
+# else
+# define OP_REFCNT_LOCK op_refcnt_lock()
+# define OP_REFCNT_UNLOCK op_refcnt_unlock()
+# endif
+# define OP_REFCNT_TERM MUTEX_DESTROY(&PL_op_mutex)
+#else
+# define OP_REFCNT_INIT NOOP
+# define OP_REFCNT_LOCK NOOP
+# define OP_REFCNT_UNLOCK NOOP
+# define OP_REFCNT_TERM NOOP
+#endif
+
+#define OpREFCNT_set(o,n) ((o)->op_targ = (n))
+#ifdef PERL_DEBUG_READONLY_OPS
+# define OpREFCNT_inc(o) Perl_op_refcnt_inc(aTHX_ o)
+# define OpREFCNT_dec(o) Perl_op_refcnt_dec(aTHX_ o)
+#else
+# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : NULL)
+# define OpREFCNT_dec(o) (--(o)->op_targ)
+#endif
+
+/* flags used by Perl_load_module() */
+#define PERL_LOADMOD_DENY 0x1 /* no Module */
+#define PERL_LOADMOD_NOIMPORT 0x2 /* use Module () */
+#define PERL_LOADMOD_IMPORT_OPS 0x4 /* use Module (...) */
+
+#if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C)
+#define ref(o, type) doref(o, type, TRUE)
+#endif
+
+/* no longer used anywhere in core */
+#ifndef PERL_CORE
+#define cv_ckproto(cv, gv, p) \
+ cv_ckproto_len((cv), (gv), (p), (p) ? strlen(p) : 0)
+#endif
+
+#ifdef USE_REENTRANT_API
+#include "reentr.h"
+#endif
+
+#if defined(PL_OP_SLAB_ALLOC)
+#define NewOp(m,var,c,type) \
+ (var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type)))
+#define NewOpSz(m,var,size) \
+ (var = (OP *) Perl_Slab_Alloc(aTHX_ size))
+#define FreeOp(p) Perl_Slab_Free(aTHX_ p)
+#else
+#define NewOp(m, var, c, type) \
+ (var = (MEM_WRAP_CHECK_(c,type) \
+ (type*)PerlMemShared_calloc(c, sizeof(type))))
+#define NewOpSz(m, var, size) \
+ (var = (OP*)PerlMemShared_calloc(1, size))
+#define FreeOp(p) PerlMemShared_free(p)
+#endif
+
+#ifdef PERL_MAD
+# define MAD_NULL 1
+# define MAD_PV 2
+# define MAD_OP 3
+# define MAD_SV 4
+
+struct madprop {
+ MADPROP* mad_next;
+ const void *mad_val;
+ U32 mad_vlen;
+/* short mad_count; */
+ char mad_key;
+ char mad_type;
+};
+
+struct token {
+ I32 tk_type;
+ YYSTYPE tk_lval;
+ MADPROP* tk_mad;
+};
+#endif
+
+/*
+ * Values that can be held by mad_key :
+ * ^ unfilled head spot
+ * , literal ,
+ * ; literal ; (blank if implicit ; at end of block)
+ * : literal : from ?: or attr list
+ * + unary +
+ * ? literal ? from ?:
+ * ( literal (
+ * ) literal )
+ * [ literal [
+ * ] literal ]
+ * { literal {
+ * } literal }
+ * @ literal @ sigil
+ * $ literal $ sigil
+ * * literal * sigil
+ * ! use is source filtered
+ * & & or sub
+ * # whitespace/comment following ; or }
+ * # $# sigil
+ * 1 1st ; from for(;;)
+ * 1 retired protasis
+ * 2 2nd ; from for(;;)
+ * 2 retired apodosis
+ * 3 C-style for list
+ * a sub or var attributes
+ * a non-method arrow operator
+ * A method arrow operator
+ * A use import args
+ * b format block
+ * B retired stub block
+ * C constant conditional op
+ * d declarator
+ * D do block
+ * e unreached "else" (see C)
+ * e expression producing E
+ * E tr/E/R/, /E/
+ * f folded constant op
+ * F peg op for format
+ * g op was forced to be a word
+ * i if/unless modifier
+ * I if/elsif/unless statement
+ * k local declarator
+ * K retired kid op
+ * l last index of array ($#foo)
+ * L label
+ * m modifier on regex
+ * n sub or format name
+ * o current operator/declarator name
+ * o else/continue
+ * O generic optimized op
+ * p peg to hold extra whitespace at statement level
+ * P peg op for package declaration
+ * q opening quote
+ * = quoted material
+ * Q closing quote
+ * Q optimized qw//
+ * r expression producing R
+ * R tr/E/R/ s/E/R/
+ * s sub signature
+ * S use import stub (no import)
+ * S retired sort block
+ * t unreached "then" (see C)
+ * U use import op
+ * v private sv of for loop
+ * V use version
+ * w while/until modifier
+ * W while/for statement
+ * x optimized qw
+ * X random thing
+ * _ whitespace/comments preceding anything else
+ * ~ =~ operator
+ */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/opcode.h b/Master/tlpkg/tlperl.straw/lib/CORE/opcode.h
new file mode 100755
index 00000000000..5c71a5e2c3e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/opcode.h
@@ -0,0 +1,1911 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * opcode.h
+ *
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by opcode.pl from its data. Any changes made here
+ * will be lost!
+ */
+
+#ifndef PERL_GLOBAL_STRUCT_INIT
+
+#define Perl_pp_i_preinc Perl_pp_preinc
+#define Perl_pp_i_predec Perl_pp_predec
+#define Perl_pp_i_postinc Perl_pp_postinc
+#define Perl_pp_i_postdec Perl_pp_postdec
+
+PERL_PPDEF(Perl_unimplemented_op)
+
+START_EXTERN_C
+
+#define OP_NAME(o) ((o)->op_type == OP_CUSTOM ? custom_op_name(o) : \
+ PL_op_name[(o)->op_type])
+#define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \
+ PL_op_desc[(o)->op_type])
+
+#ifndef DOINIT
+EXTCONST char* const PL_op_name[];
+#else
+EXTCONST char* const PL_op_name[] = {
+ "null",
+ "stub",
+ "scalar",
+ "pushmark",
+ "wantarray",
+ "const",
+ "gvsv",
+ "gv",
+ "gelem",
+ "padsv",
+ "padav",
+ "padhv",
+ "padany",
+ "pushre",
+ "rv2gv",
+ "rv2sv",
+ "av2arylen",
+ "rv2cv",
+ "anoncode",
+ "prototype",
+ "refgen",
+ "srefgen",
+ "ref",
+ "bless",
+ "backtick",
+ "glob",
+ "readline",
+ "rcatline",
+ "regcmaybe",
+ "regcreset",
+ "regcomp",
+ "match",
+ "qr",
+ "subst",
+ "substcont",
+ "trans",
+ "sassign",
+ "aassign",
+ "chop",
+ "schop",
+ "chomp",
+ "schomp",
+ "defined",
+ "undef",
+ "study",
+ "pos",
+ "preinc",
+ "i_preinc",
+ "predec",
+ "i_predec",
+ "postinc",
+ "i_postinc",
+ "postdec",
+ "i_postdec",
+ "pow",
+ "multiply",
+ "i_multiply",
+ "divide",
+ "i_divide",
+ "modulo",
+ "i_modulo",
+ "repeat",
+ "add",
+ "i_add",
+ "subtract",
+ "i_subtract",
+ "concat",
+ "stringify",
+ "left_shift",
+ "right_shift",
+ "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",
+ "bit_and",
+ "bit_xor",
+ "bit_or",
+ "negate",
+ "i_negate",
+ "not",
+ "complement",
+ "smartmatch",
+ "atan2",
+ "sin",
+ "cos",
+ "rand",
+ "srand",
+ "exp",
+ "log",
+ "sqrt",
+ "int",
+ "hex",
+ "oct",
+ "abs",
+ "length",
+ "substr",
+ "vec",
+ "index",
+ "rindex",
+ "sprintf",
+ "formline",
+ "ord",
+ "chr",
+ "crypt",
+ "ucfirst",
+ "lcfirst",
+ "uc",
+ "lc",
+ "quotemeta",
+ "rv2av",
+ "aelemfast",
+ "aelem",
+ "aslice",
+ "each",
+ "values",
+ "keys",
+ "delete",
+ "exists",
+ "rv2hv",
+ "helem",
+ "hslice",
+ "unpack",
+ "pack",
+ "split",
+ "join",
+ "list",
+ "lslice",
+ "anonlist",
+ "anonhash",
+ "splice",
+ "push",
+ "pop",
+ "shift",
+ "unshift",
+ "sort",
+ "reverse",
+ "grepstart",
+ "grepwhile",
+ "mapstart",
+ "mapwhile",
+ "range",
+ "flip",
+ "flop",
+ "and",
+ "or",
+ "xor",
+ "dor",
+ "cond_expr",
+ "andassign",
+ "orassign",
+ "dorassign",
+ "method",
+ "entersub",
+ "leavesub",
+ "leavesublv",
+ "caller",
+ "warn",
+ "die",
+ "reset",
+ "lineseq",
+ "nextstate",
+ "dbstate",
+ "unstack",
+ "enter",
+ "leave",
+ "scope",
+ "enteriter",
+ "iter",
+ "enterloop",
+ "leaveloop",
+ "return",
+ "last",
+ "next",
+ "redo",
+ "dump",
+ "goto",
+ "exit",
+ "setstate",
+ "method_named",
+ "entergiven",
+ "leavegiven",
+ "enterwhen",
+ "leavewhen",
+ "break",
+ "continue",
+ "open",
+ "close",
+ "pipe_op",
+ "fileno",
+ "umask",
+ "binmode",
+ "tie",
+ "untie",
+ "tied",
+ "dbmopen",
+ "dbmclose",
+ "sselect",
+ "select",
+ "getc",
+ "read",
+ "enterwrite",
+ "leavewrite",
+ "prtf",
+ "print",
+ "say",
+ "sysopen",
+ "sysseek",
+ "sysread",
+ "syswrite",
+ "send",
+ "recv",
+ "eof",
+ "tell",
+ "seek",
+ "truncate",
+ "fcntl",
+ "ioctl",
+ "flock",
+ "socket",
+ "sockpair",
+ "bind",
+ "connect",
+ "listen",
+ "accept",
+ "shutdown",
+ "gsockopt",
+ "ssockopt",
+ "getsockname",
+ "getpeername",
+ "lstat",
+ "stat",
+ "ftrread",
+ "ftrwrite",
+ "ftrexec",
+ "fteread",
+ "ftewrite",
+ "fteexec",
+ "ftis",
+ "ftsize",
+ "ftmtime",
+ "ftatime",
+ "ftctime",
+ "ftrowned",
+ "fteowned",
+ "ftzero",
+ "ftsock",
+ "ftchr",
+ "ftblk",
+ "ftfile",
+ "ftdir",
+ "ftpipe",
+ "ftsuid",
+ "ftsgid",
+ "ftsvtx",
+ "ftlink",
+ "fttty",
+ "fttext",
+ "ftbinary",
+ "chdir",
+ "chown",
+ "chroot",
+ "unlink",
+ "chmod",
+ "utime",
+ "rename",
+ "link",
+ "symlink",
+ "readlink",
+ "mkdir",
+ "rmdir",
+ "open_dir",
+ "readdir",
+ "telldir",
+ "seekdir",
+ "rewinddir",
+ "closedir",
+ "fork",
+ "wait",
+ "waitpid",
+ "system",
+ "exec",
+ "kill",
+ "getppid",
+ "getpgrp",
+ "setpgrp",
+ "getpriority",
+ "setpriority",
+ "time",
+ "tms",
+ "localtime",
+ "gmtime",
+ "alarm",
+ "sleep",
+ "shmget",
+ "shmctl",
+ "shmread",
+ "shmwrite",
+ "msgget",
+ "msgctl",
+ "msgsnd",
+ "msgrcv",
+ "semop",
+ "semget",
+ "semctl",
+ "require",
+ "dofile",
+ "entereval",
+ "leaveeval",
+ "entertry",
+ "leavetry",
+ "ghbyname",
+ "ghbyaddr",
+ "ghostent",
+ "gnbyname",
+ "gnbyaddr",
+ "gnetent",
+ "gpbyname",
+ "gpbynumber",
+ "gprotoent",
+ "gsbyname",
+ "gsbyport",
+ "gservent",
+ "shostent",
+ "snetent",
+ "sprotoent",
+ "sservent",
+ "ehostent",
+ "enetent",
+ "eprotoent",
+ "eservent",
+ "gpwnam",
+ "gpwuid",
+ "gpwent",
+ "spwent",
+ "epwent",
+ "ggrnam",
+ "ggrgid",
+ "ggrent",
+ "sgrent",
+ "egrent",
+ "getlogin",
+ "syscall",
+ "lock",
+ "once",
+ "custom",
+};
+#endif
+
+#ifndef DOINIT
+EXTCONST char* const PL_op_desc[];
+#else
+EXTCONST char* const PL_op_desc[] = {
+ "null operation",
+ "stub",
+ "scalar",
+ "pushmark",
+ "wantarray",
+ "constant item",
+ "scalar variable",
+ "glob value",
+ "glob elem",
+ "private variable",
+ "private array",
+ "private hash",
+ "private value",
+ "push regexp",
+ "ref-to-glob cast",
+ "scalar dereference",
+ "array length",
+ "subroutine dereference",
+ "anonymous subroutine",
+ "subroutine prototype",
+ "reference constructor",
+ "single ref constructor",
+ "reference-type operator",
+ "bless",
+ "quoted execution (``, qx)",
+ "glob",
+ "<HANDLE>",
+ "append I/O operator",
+ "regexp internal guard",
+ "regexp internal reset",
+ "regexp compilation",
+ "pattern match (m//)",
+ "pattern quote (qr//)",
+ "substitution (s///)",
+ "substitution iterator",
+ "transliteration (tr///)",
+ "scalar assignment",
+ "list assignment",
+ "chop",
+ "scalar chop",
+ "chomp",
+ "scalar chomp",
+ "defined operator",
+ "undef operator",
+ "study",
+ "match position",
+ "preincrement (++)",
+ "integer preincrement (++)",
+ "predecrement (--)",
+ "integer predecrement (--)",
+ "postincrement (++)",
+ "integer postincrement (++)",
+ "postdecrement (--)",
+ "integer postdecrement (--)",
+ "exponentiation (**)",
+ "multiplication (*)",
+ "integer multiplication (*)",
+ "division (/)",
+ "integer division (/)",
+ "modulus (%)",
+ "integer modulus (%)",
+ "repeat (x)",
+ "addition (+)",
+ "integer addition (+)",
+ "subtraction (-)",
+ "integer subtraction (-)",
+ "concatenation (.) or string",
+ "string",
+ "left bitshift (<<)",
+ "right bitshift (>>)",
+ "numeric lt (<)",
+ "integer lt (<)",
+ "numeric gt (>)",
+ "integer gt (>)",
+ "numeric le (<=)",
+ "integer le (<=)",
+ "numeric ge (>=)",
+ "integer ge (>=)",
+ "numeric eq (==)",
+ "integer eq (==)",
+ "numeric ne (!=)",
+ "integer ne (!=)",
+ "numeric comparison (<=>)",
+ "integer comparison (<=>)",
+ "string lt",
+ "string gt",
+ "string le",
+ "string ge",
+ "string eq",
+ "string ne",
+ "string comparison (cmp)",
+ "bitwise and (&)",
+ "bitwise xor (^)",
+ "bitwise or (|)",
+ "negation (-)",
+ "integer negation (-)",
+ "not",
+ "1's complement (~)",
+ "smart match",
+ "atan2",
+ "sin",
+ "cos",
+ "rand",
+ "srand",
+ "exp",
+ "log",
+ "sqrt",
+ "int",
+ "hex",
+ "oct",
+ "abs",
+ "length",
+ "substr",
+ "vec",
+ "index",
+ "rindex",
+ "sprintf",
+ "formline",
+ "ord",
+ "chr",
+ "crypt",
+ "ucfirst",
+ "lcfirst",
+ "uc",
+ "lc",
+ "quotemeta",
+ "array dereference",
+ "constant array element",
+ "array element",
+ "array slice",
+ "each",
+ "values",
+ "keys",
+ "delete",
+ "exists",
+ "hash dereference",
+ "hash element",
+ "hash slice",
+ "unpack",
+ "pack",
+ "split",
+ "join or string",
+ "list",
+ "list slice",
+ "anonymous list ([])",
+ "anonymous hash ({})",
+ "splice",
+ "push",
+ "pop",
+ "shift",
+ "unshift",
+ "sort",
+ "reverse",
+ "grep",
+ "grep iterator",
+ "map",
+ "map iterator",
+ "flipflop",
+ "range (or flip)",
+ "range (or flop)",
+ "logical and (&&)",
+ "logical or (||)",
+ "logical xor",
+ "defined or (//)",
+ "conditional expression",
+ "logical and assignment (&&=)",
+ "logical or assignment (||=)",
+ "defined or assignment (//=)",
+ "method lookup",
+ "subroutine entry",
+ "subroutine exit",
+ "lvalue subroutine return",
+ "caller",
+ "warn",
+ "die",
+ "symbol reset",
+ "line sequence",
+ "next statement",
+ "debug next statement",
+ "iteration finalizer",
+ "block entry",
+ "block exit",
+ "block",
+ "foreach loop entry",
+ "foreach loop iterator",
+ "loop entry",
+ "loop exit",
+ "return",
+ "last",
+ "next",
+ "redo",
+ "dump",
+ "goto",
+ "exit",
+ "set statement info",
+ "method with known name",
+ "given()",
+ "leave given block",
+ "when()",
+ "leave when block",
+ "break",
+ "continue",
+ "open",
+ "close",
+ "pipe",
+ "fileno",
+ "umask",
+ "binmode",
+ "tie",
+ "untie",
+ "tied",
+ "dbmopen",
+ "dbmclose",
+ "select system call",
+ "select",
+ "getc",
+ "read",
+ "write",
+ "write exit",
+ "printf",
+ "print",
+ "say",
+ "sysopen",
+ "sysseek",
+ "sysread",
+ "syswrite",
+ "send",
+ "recv",
+ "eof",
+ "tell",
+ "seek",
+ "truncate",
+ "fcntl",
+ "ioctl",
+ "flock",
+ "socket",
+ "socketpair",
+ "bind",
+ "connect",
+ "listen",
+ "accept",
+ "shutdown",
+ "getsockopt",
+ "setsockopt",
+ "getsockname",
+ "getpeername",
+ "lstat",
+ "stat",
+ "-R",
+ "-W",
+ "-X",
+ "-r",
+ "-w",
+ "-x",
+ "-e",
+ "-s",
+ "-M",
+ "-A",
+ "-C",
+ "-O",
+ "-o",
+ "-z",
+ "-S",
+ "-c",
+ "-b",
+ "-f",
+ "-d",
+ "-p",
+ "-u",
+ "-g",
+ "-k",
+ "-l",
+ "-t",
+ "-T",
+ "-B",
+ "chdir",
+ "chown",
+ "chroot",
+ "unlink",
+ "chmod",
+ "utime",
+ "rename",
+ "link",
+ "symlink",
+ "readlink",
+ "mkdir",
+ "rmdir",
+ "opendir",
+ "readdir",
+ "telldir",
+ "seekdir",
+ "rewinddir",
+ "closedir",
+ "fork",
+ "wait",
+ "waitpid",
+ "system",
+ "exec",
+ "kill",
+ "getppid",
+ "getpgrp",
+ "setpgrp",
+ "getpriority",
+ "setpriority",
+ "time",
+ "times",
+ "localtime",
+ "gmtime",
+ "alarm",
+ "sleep",
+ "shmget",
+ "shmctl",
+ "shmread",
+ "shmwrite",
+ "msgget",
+ "msgctl",
+ "msgsnd",
+ "msgrcv",
+ "semop",
+ "semget",
+ "semctl",
+ "require",
+ "do \"file\"",
+ "eval \"string\"",
+ "eval \"string\" exit",
+ "eval {block}",
+ "eval {block} exit",
+ "gethostbyname",
+ "gethostbyaddr",
+ "gethostent",
+ "getnetbyname",
+ "getnetbyaddr",
+ "getnetent",
+ "getprotobyname",
+ "getprotobynumber",
+ "getprotoent",
+ "getservbyname",
+ "getservbyport",
+ "getservent",
+ "sethostent",
+ "setnetent",
+ "setprotoent",
+ "setservent",
+ "endhostent",
+ "endnetent",
+ "endprotoent",
+ "endservent",
+ "getpwnam",
+ "getpwuid",
+ "getpwent",
+ "setpwent",
+ "endpwent",
+ "getgrnam",
+ "getgrgid",
+ "getgrent",
+ "setgrent",
+ "endgrent",
+ "getlogin",
+ "syscall",
+ "lock",
+ "once",
+ "unknown custom operator",
+};
+#endif
+
+END_EXTERN_C
+
+#endif /* !PERL_GLOBAL_STRUCT_INIT */
+
+START_EXTERN_C
+
+#ifdef PERL_GLOBAL_STRUCT_INIT
+# define PERL_PPADDR_INITED
+static const Perl_ppaddr_t Gppaddr[]
+#else
+# ifndef PERL_GLOBAL_STRUCT
+# define PERL_PPADDR_INITED
+EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
+# endif
+#endif /* PERL_GLOBAL_STRUCT */
+#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT)
+# define PERL_PPADDR_INITED
+= {
+ MEMBER_TO_FPTR(Perl_pp_null),
+ MEMBER_TO_FPTR(Perl_pp_stub),
+ MEMBER_TO_FPTR(Perl_pp_null), /* Perl_pp_scalar */
+ MEMBER_TO_FPTR(Perl_pp_pushmark),
+ MEMBER_TO_FPTR(Perl_pp_wantarray),
+ MEMBER_TO_FPTR(Perl_pp_const),
+ MEMBER_TO_FPTR(Perl_pp_gvsv),
+ MEMBER_TO_FPTR(Perl_pp_gv),
+ MEMBER_TO_FPTR(Perl_pp_gelem),
+ MEMBER_TO_FPTR(Perl_pp_padsv),
+ MEMBER_TO_FPTR(Perl_pp_padav),
+ MEMBER_TO_FPTR(Perl_pp_padhv),
+ MEMBER_TO_FPTR(Perl_unimplemented_op), /* Perl_pp_padany */
+ MEMBER_TO_FPTR(Perl_pp_pushre),
+ MEMBER_TO_FPTR(Perl_pp_rv2gv),
+ MEMBER_TO_FPTR(Perl_pp_rv2sv),
+ MEMBER_TO_FPTR(Perl_pp_av2arylen),
+ MEMBER_TO_FPTR(Perl_pp_rv2cv),
+ MEMBER_TO_FPTR(Perl_pp_anoncode),
+ MEMBER_TO_FPTR(Perl_pp_prototype),
+ MEMBER_TO_FPTR(Perl_pp_refgen),
+ MEMBER_TO_FPTR(Perl_pp_srefgen),
+ MEMBER_TO_FPTR(Perl_pp_ref),
+ MEMBER_TO_FPTR(Perl_pp_bless),
+ MEMBER_TO_FPTR(Perl_pp_backtick),
+ MEMBER_TO_FPTR(Perl_pp_glob),
+ MEMBER_TO_FPTR(Perl_pp_readline),
+ MEMBER_TO_FPTR(Perl_pp_rcatline),
+ MEMBER_TO_FPTR(Perl_pp_null), /* Perl_pp_regcmaybe */
+ MEMBER_TO_FPTR(Perl_pp_regcreset),
+ MEMBER_TO_FPTR(Perl_pp_regcomp),
+ MEMBER_TO_FPTR(Perl_pp_match),
+ MEMBER_TO_FPTR(Perl_pp_qr),
+ MEMBER_TO_FPTR(Perl_pp_subst),
+ MEMBER_TO_FPTR(Perl_pp_substcont),
+ MEMBER_TO_FPTR(Perl_pp_trans),
+ MEMBER_TO_FPTR(Perl_pp_sassign),
+ MEMBER_TO_FPTR(Perl_pp_aassign),
+ MEMBER_TO_FPTR(Perl_pp_chop),
+ MEMBER_TO_FPTR(Perl_pp_schop),
+ MEMBER_TO_FPTR(Perl_pp_chomp),
+ MEMBER_TO_FPTR(Perl_pp_schomp),
+ MEMBER_TO_FPTR(Perl_pp_defined),
+ MEMBER_TO_FPTR(Perl_pp_undef),
+ MEMBER_TO_FPTR(Perl_pp_study),
+ MEMBER_TO_FPTR(Perl_pp_pos),
+ MEMBER_TO_FPTR(Perl_pp_preinc),
+ MEMBER_TO_FPTR(Perl_pp_i_preinc),
+ MEMBER_TO_FPTR(Perl_pp_predec),
+ MEMBER_TO_FPTR(Perl_pp_i_predec),
+ MEMBER_TO_FPTR(Perl_pp_postinc),
+ MEMBER_TO_FPTR(Perl_pp_i_postinc),
+ MEMBER_TO_FPTR(Perl_pp_postdec),
+ MEMBER_TO_FPTR(Perl_pp_i_postdec),
+ MEMBER_TO_FPTR(Perl_pp_pow),
+ MEMBER_TO_FPTR(Perl_pp_multiply),
+ MEMBER_TO_FPTR(Perl_pp_i_multiply),
+ MEMBER_TO_FPTR(Perl_pp_divide),
+ MEMBER_TO_FPTR(Perl_pp_i_divide),
+ MEMBER_TO_FPTR(Perl_pp_modulo),
+ MEMBER_TO_FPTR(Perl_pp_i_modulo),
+ MEMBER_TO_FPTR(Perl_pp_repeat),
+ MEMBER_TO_FPTR(Perl_pp_add),
+ MEMBER_TO_FPTR(Perl_pp_i_add),
+ MEMBER_TO_FPTR(Perl_pp_subtract),
+ MEMBER_TO_FPTR(Perl_pp_i_subtract),
+ MEMBER_TO_FPTR(Perl_pp_concat),
+ MEMBER_TO_FPTR(Perl_pp_stringify),
+ MEMBER_TO_FPTR(Perl_pp_left_shift),
+ MEMBER_TO_FPTR(Perl_pp_right_shift),
+ MEMBER_TO_FPTR(Perl_pp_lt),
+ MEMBER_TO_FPTR(Perl_pp_i_lt),
+ MEMBER_TO_FPTR(Perl_pp_gt),
+ MEMBER_TO_FPTR(Perl_pp_i_gt),
+ MEMBER_TO_FPTR(Perl_pp_le),
+ MEMBER_TO_FPTR(Perl_pp_i_le),
+ MEMBER_TO_FPTR(Perl_pp_ge),
+ MEMBER_TO_FPTR(Perl_pp_i_ge),
+ MEMBER_TO_FPTR(Perl_pp_eq),
+ MEMBER_TO_FPTR(Perl_pp_i_eq),
+ MEMBER_TO_FPTR(Perl_pp_ne),
+ MEMBER_TO_FPTR(Perl_pp_i_ne),
+ MEMBER_TO_FPTR(Perl_pp_ncmp),
+ MEMBER_TO_FPTR(Perl_pp_i_ncmp),
+ MEMBER_TO_FPTR(Perl_pp_sle), /* Perl_pp_slt */
+ MEMBER_TO_FPTR(Perl_pp_sle), /* Perl_pp_sgt */
+ MEMBER_TO_FPTR(Perl_pp_sle),
+ MEMBER_TO_FPTR(Perl_pp_sle), /* Perl_pp_sge */
+ MEMBER_TO_FPTR(Perl_pp_seq),
+ MEMBER_TO_FPTR(Perl_pp_sne),
+ MEMBER_TO_FPTR(Perl_pp_scmp),
+ MEMBER_TO_FPTR(Perl_pp_bit_and),
+ MEMBER_TO_FPTR(Perl_pp_bit_or), /* Perl_pp_bit_xor */
+ MEMBER_TO_FPTR(Perl_pp_bit_or),
+ MEMBER_TO_FPTR(Perl_pp_negate),
+ MEMBER_TO_FPTR(Perl_pp_i_negate),
+ MEMBER_TO_FPTR(Perl_pp_not),
+ MEMBER_TO_FPTR(Perl_pp_complement),
+ MEMBER_TO_FPTR(Perl_pp_smartmatch),
+ MEMBER_TO_FPTR(Perl_pp_atan2),
+ MEMBER_TO_FPTR(Perl_pp_sin),
+ MEMBER_TO_FPTR(Perl_pp_sin), /* Perl_pp_cos */
+ MEMBER_TO_FPTR(Perl_pp_rand),
+ MEMBER_TO_FPTR(Perl_pp_srand),
+ MEMBER_TO_FPTR(Perl_pp_sin), /* Perl_pp_exp */
+ MEMBER_TO_FPTR(Perl_pp_sin), /* Perl_pp_log */
+ MEMBER_TO_FPTR(Perl_pp_sin), /* Perl_pp_sqrt */
+ MEMBER_TO_FPTR(Perl_pp_int),
+ MEMBER_TO_FPTR(Perl_pp_oct), /* Perl_pp_hex */
+ MEMBER_TO_FPTR(Perl_pp_oct),
+ MEMBER_TO_FPTR(Perl_pp_abs),
+ MEMBER_TO_FPTR(Perl_pp_length),
+ MEMBER_TO_FPTR(Perl_pp_substr),
+ MEMBER_TO_FPTR(Perl_pp_vec),
+ MEMBER_TO_FPTR(Perl_pp_index),
+ MEMBER_TO_FPTR(Perl_pp_index), /* Perl_pp_rindex */
+ MEMBER_TO_FPTR(Perl_pp_sprintf),
+ MEMBER_TO_FPTR(Perl_pp_formline),
+ MEMBER_TO_FPTR(Perl_pp_ord),
+ MEMBER_TO_FPTR(Perl_pp_chr),
+ MEMBER_TO_FPTR(Perl_pp_crypt),
+ MEMBER_TO_FPTR(Perl_pp_ucfirst),
+ MEMBER_TO_FPTR(Perl_pp_ucfirst), /* Perl_pp_lcfirst */
+ MEMBER_TO_FPTR(Perl_pp_uc),
+ MEMBER_TO_FPTR(Perl_pp_lc),
+ MEMBER_TO_FPTR(Perl_pp_quotemeta),
+ MEMBER_TO_FPTR(Perl_pp_rv2av),
+ MEMBER_TO_FPTR(Perl_pp_aelemfast),
+ MEMBER_TO_FPTR(Perl_pp_aelem),
+ MEMBER_TO_FPTR(Perl_pp_aslice),
+ MEMBER_TO_FPTR(Perl_pp_each),
+ MEMBER_TO_FPTR(Perl_do_kv), /* Perl_pp_values */
+ MEMBER_TO_FPTR(Perl_do_kv), /* Perl_pp_keys */
+ MEMBER_TO_FPTR(Perl_pp_delete),
+ MEMBER_TO_FPTR(Perl_pp_exists),
+ MEMBER_TO_FPTR(Perl_pp_rv2av), /* Perl_pp_rv2hv */
+ MEMBER_TO_FPTR(Perl_pp_helem),
+ MEMBER_TO_FPTR(Perl_pp_hslice),
+ MEMBER_TO_FPTR(Perl_pp_unpack),
+ MEMBER_TO_FPTR(Perl_pp_pack),
+ MEMBER_TO_FPTR(Perl_pp_split),
+ MEMBER_TO_FPTR(Perl_pp_join),
+ MEMBER_TO_FPTR(Perl_pp_list),
+ MEMBER_TO_FPTR(Perl_pp_lslice),
+ MEMBER_TO_FPTR(Perl_pp_anonlist),
+ MEMBER_TO_FPTR(Perl_pp_anonhash),
+ MEMBER_TO_FPTR(Perl_pp_splice),
+ MEMBER_TO_FPTR(Perl_pp_push),
+ MEMBER_TO_FPTR(Perl_pp_shift), /* Perl_pp_pop */
+ MEMBER_TO_FPTR(Perl_pp_shift),
+ MEMBER_TO_FPTR(Perl_pp_unshift),
+ MEMBER_TO_FPTR(Perl_pp_sort),
+ MEMBER_TO_FPTR(Perl_pp_reverse),
+ MEMBER_TO_FPTR(Perl_pp_grepstart),
+ MEMBER_TO_FPTR(Perl_pp_grepwhile),
+ MEMBER_TO_FPTR(Perl_unimplemented_op), /* Perl_pp_mapstart */
+ MEMBER_TO_FPTR(Perl_pp_mapwhile),
+ MEMBER_TO_FPTR(Perl_pp_range),
+ MEMBER_TO_FPTR(Perl_pp_flip),
+ MEMBER_TO_FPTR(Perl_pp_flop),
+ MEMBER_TO_FPTR(Perl_pp_and),
+ MEMBER_TO_FPTR(Perl_pp_or),
+ MEMBER_TO_FPTR(Perl_pp_xor),
+ MEMBER_TO_FPTR(Perl_pp_defined), /* Perl_pp_dor */
+ MEMBER_TO_FPTR(Perl_pp_cond_expr),
+ MEMBER_TO_FPTR(Perl_pp_and), /* Perl_pp_andassign */
+ MEMBER_TO_FPTR(Perl_pp_or), /* Perl_pp_orassign */
+ MEMBER_TO_FPTR(Perl_pp_defined), /* Perl_pp_dorassign */
+ MEMBER_TO_FPTR(Perl_pp_method),
+ MEMBER_TO_FPTR(Perl_pp_entersub),
+ MEMBER_TO_FPTR(Perl_pp_leavesub),
+ MEMBER_TO_FPTR(Perl_pp_leavesublv),
+ MEMBER_TO_FPTR(Perl_pp_caller),
+ MEMBER_TO_FPTR(Perl_pp_warn),
+ MEMBER_TO_FPTR(Perl_pp_die),
+ MEMBER_TO_FPTR(Perl_pp_reset),
+ MEMBER_TO_FPTR(Perl_pp_null), /* Perl_pp_lineseq */
+ MEMBER_TO_FPTR(Perl_pp_nextstate),
+ MEMBER_TO_FPTR(Perl_pp_dbstate),
+ MEMBER_TO_FPTR(Perl_pp_unstack),
+ MEMBER_TO_FPTR(Perl_pp_enter),
+ MEMBER_TO_FPTR(Perl_pp_leave),
+ MEMBER_TO_FPTR(Perl_pp_null), /* Perl_pp_scope */
+ MEMBER_TO_FPTR(Perl_pp_enteriter),
+ MEMBER_TO_FPTR(Perl_pp_iter),
+ MEMBER_TO_FPTR(Perl_pp_enterloop),
+ MEMBER_TO_FPTR(Perl_pp_leaveloop),
+ MEMBER_TO_FPTR(Perl_pp_return),
+ MEMBER_TO_FPTR(Perl_pp_last),
+ MEMBER_TO_FPTR(Perl_pp_next),
+ MEMBER_TO_FPTR(Perl_pp_redo),
+ MEMBER_TO_FPTR(Perl_pp_goto), /* Perl_pp_dump */
+ MEMBER_TO_FPTR(Perl_pp_goto),
+ MEMBER_TO_FPTR(Perl_pp_exit),
+ MEMBER_TO_FPTR(Perl_pp_setstate),
+ MEMBER_TO_FPTR(Perl_pp_method_named),
+ MEMBER_TO_FPTR(Perl_pp_entergiven),
+ MEMBER_TO_FPTR(Perl_pp_leavegiven),
+ MEMBER_TO_FPTR(Perl_pp_enterwhen),
+ MEMBER_TO_FPTR(Perl_pp_leavewhen),
+ MEMBER_TO_FPTR(Perl_pp_break),
+ MEMBER_TO_FPTR(Perl_pp_continue),
+ MEMBER_TO_FPTR(Perl_pp_open),
+ MEMBER_TO_FPTR(Perl_pp_close),
+ MEMBER_TO_FPTR(Perl_pp_pipe_op),
+ MEMBER_TO_FPTR(Perl_pp_fileno),
+ MEMBER_TO_FPTR(Perl_pp_umask),
+ MEMBER_TO_FPTR(Perl_pp_binmode),
+ MEMBER_TO_FPTR(Perl_pp_tie),
+ MEMBER_TO_FPTR(Perl_pp_untie),
+ MEMBER_TO_FPTR(Perl_pp_tied),
+ MEMBER_TO_FPTR(Perl_pp_dbmopen),
+ MEMBER_TO_FPTR(Perl_pp_untie), /* Perl_pp_dbmclose */
+ MEMBER_TO_FPTR(Perl_pp_sselect),
+ MEMBER_TO_FPTR(Perl_pp_select),
+ MEMBER_TO_FPTR(Perl_pp_getc),
+ MEMBER_TO_FPTR(Perl_pp_sysread), /* Perl_pp_read */
+ MEMBER_TO_FPTR(Perl_pp_enterwrite),
+ MEMBER_TO_FPTR(Perl_pp_leavewrite),
+ MEMBER_TO_FPTR(Perl_pp_prtf),
+ MEMBER_TO_FPTR(Perl_pp_print),
+ MEMBER_TO_FPTR(Perl_pp_print), /* Perl_pp_say */
+ MEMBER_TO_FPTR(Perl_pp_sysopen),
+ MEMBER_TO_FPTR(Perl_pp_sysseek),
+ MEMBER_TO_FPTR(Perl_pp_sysread),
+ MEMBER_TO_FPTR(Perl_pp_send), /* Perl_pp_syswrite */
+ MEMBER_TO_FPTR(Perl_pp_send),
+ MEMBER_TO_FPTR(Perl_pp_sysread), /* Perl_pp_recv */
+ MEMBER_TO_FPTR(Perl_pp_eof),
+ MEMBER_TO_FPTR(Perl_pp_tell),
+ MEMBER_TO_FPTR(Perl_pp_sysseek), /* Perl_pp_seek */
+ MEMBER_TO_FPTR(Perl_pp_truncate),
+ MEMBER_TO_FPTR(Perl_pp_ioctl), /* Perl_pp_fcntl */
+ MEMBER_TO_FPTR(Perl_pp_ioctl),
+ MEMBER_TO_FPTR(Perl_pp_flock),
+ MEMBER_TO_FPTR(Perl_pp_socket),
+ MEMBER_TO_FPTR(Perl_pp_sockpair),
+ MEMBER_TO_FPTR(Perl_pp_bind),
+ MEMBER_TO_FPTR(Perl_pp_connect),
+ MEMBER_TO_FPTR(Perl_pp_listen),
+ MEMBER_TO_FPTR(Perl_pp_accept),
+ MEMBER_TO_FPTR(Perl_pp_shutdown),
+ MEMBER_TO_FPTR(Perl_pp_ssockopt), /* Perl_pp_gsockopt */
+ MEMBER_TO_FPTR(Perl_pp_ssockopt),
+ MEMBER_TO_FPTR(Perl_pp_getpeername), /* Perl_pp_getsockname */
+ MEMBER_TO_FPTR(Perl_pp_getpeername),
+ MEMBER_TO_FPTR(Perl_pp_stat), /* Perl_pp_lstat */
+ MEMBER_TO_FPTR(Perl_pp_stat),
+ MEMBER_TO_FPTR(Perl_pp_ftrread),
+ MEMBER_TO_FPTR(Perl_pp_ftrread), /* Perl_pp_ftrwrite */
+ MEMBER_TO_FPTR(Perl_pp_ftrread), /* Perl_pp_ftrexec */
+ MEMBER_TO_FPTR(Perl_pp_ftrread), /* Perl_pp_fteread */
+ MEMBER_TO_FPTR(Perl_pp_ftrread), /* Perl_pp_ftewrite */
+ MEMBER_TO_FPTR(Perl_pp_ftrread), /* Perl_pp_fteexec */
+ MEMBER_TO_FPTR(Perl_pp_ftis),
+ MEMBER_TO_FPTR(Perl_pp_ftis), /* Perl_pp_ftsize */
+ MEMBER_TO_FPTR(Perl_pp_ftis), /* Perl_pp_ftmtime */
+ MEMBER_TO_FPTR(Perl_pp_ftis), /* Perl_pp_ftatime */
+ MEMBER_TO_FPTR(Perl_pp_ftis), /* Perl_pp_ftctime */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned),
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_fteowned */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftzero */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftsock */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftchr */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftblk */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftfile */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftdir */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftpipe */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftsuid */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftsgid */
+ MEMBER_TO_FPTR(Perl_pp_ftrowned), /* Perl_pp_ftsvtx */
+ MEMBER_TO_FPTR(Perl_pp_ftlink),
+ MEMBER_TO_FPTR(Perl_pp_fttty),
+ MEMBER_TO_FPTR(Perl_pp_fttext),
+ MEMBER_TO_FPTR(Perl_pp_fttext), /* Perl_pp_ftbinary */
+ MEMBER_TO_FPTR(Perl_pp_chdir),
+ MEMBER_TO_FPTR(Perl_pp_chown),
+ MEMBER_TO_FPTR(Perl_pp_chroot),
+ MEMBER_TO_FPTR(Perl_pp_chown), /* Perl_pp_unlink */
+ MEMBER_TO_FPTR(Perl_pp_chown), /* Perl_pp_chmod */
+ MEMBER_TO_FPTR(Perl_pp_chown), /* Perl_pp_utime */
+ MEMBER_TO_FPTR(Perl_pp_rename),
+ MEMBER_TO_FPTR(Perl_pp_link),
+ MEMBER_TO_FPTR(Perl_pp_link), /* Perl_pp_symlink */
+ MEMBER_TO_FPTR(Perl_pp_readlink),
+ MEMBER_TO_FPTR(Perl_pp_mkdir),
+ MEMBER_TO_FPTR(Perl_pp_rmdir),
+ MEMBER_TO_FPTR(Perl_pp_open_dir),
+ MEMBER_TO_FPTR(Perl_pp_readdir),
+ MEMBER_TO_FPTR(Perl_pp_telldir),
+ MEMBER_TO_FPTR(Perl_pp_seekdir),
+ MEMBER_TO_FPTR(Perl_pp_rewinddir),
+ MEMBER_TO_FPTR(Perl_pp_closedir),
+ MEMBER_TO_FPTR(Perl_pp_fork),
+ MEMBER_TO_FPTR(Perl_pp_wait),
+ MEMBER_TO_FPTR(Perl_pp_waitpid),
+ MEMBER_TO_FPTR(Perl_pp_system),
+ MEMBER_TO_FPTR(Perl_pp_exec),
+ MEMBER_TO_FPTR(Perl_pp_chown), /* Perl_pp_kill */
+ MEMBER_TO_FPTR(Perl_pp_getppid),
+ MEMBER_TO_FPTR(Perl_pp_getpgrp),
+ MEMBER_TO_FPTR(Perl_pp_setpgrp),
+ MEMBER_TO_FPTR(Perl_pp_getpriority),
+ MEMBER_TO_FPTR(Perl_pp_setpriority),
+ MEMBER_TO_FPTR(Perl_pp_time),
+ MEMBER_TO_FPTR(Perl_pp_tms),
+ MEMBER_TO_FPTR(Perl_pp_gmtime), /* Perl_pp_localtime */
+ MEMBER_TO_FPTR(Perl_pp_gmtime),
+ MEMBER_TO_FPTR(Perl_pp_alarm),
+ MEMBER_TO_FPTR(Perl_pp_sleep),
+ MEMBER_TO_FPTR(Perl_pp_semget), /* Perl_pp_shmget */
+ MEMBER_TO_FPTR(Perl_pp_semctl), /* Perl_pp_shmctl */
+ MEMBER_TO_FPTR(Perl_pp_shmwrite), /* Perl_pp_shmread */
+ MEMBER_TO_FPTR(Perl_pp_shmwrite),
+ MEMBER_TO_FPTR(Perl_pp_semget), /* Perl_pp_msgget */
+ MEMBER_TO_FPTR(Perl_pp_semctl), /* Perl_pp_msgctl */
+ MEMBER_TO_FPTR(Perl_pp_shmwrite), /* Perl_pp_msgsnd */
+ MEMBER_TO_FPTR(Perl_pp_shmwrite), /* Perl_pp_msgrcv */
+ MEMBER_TO_FPTR(Perl_pp_shmwrite), /* Perl_pp_semop */
+ MEMBER_TO_FPTR(Perl_pp_semget),
+ MEMBER_TO_FPTR(Perl_pp_semctl),
+ MEMBER_TO_FPTR(Perl_pp_require),
+ MEMBER_TO_FPTR(Perl_pp_require), /* Perl_pp_dofile */
+ MEMBER_TO_FPTR(Perl_pp_entereval),
+ MEMBER_TO_FPTR(Perl_pp_leaveeval),
+ MEMBER_TO_FPTR(Perl_pp_entertry),
+ MEMBER_TO_FPTR(Perl_pp_leavetry),
+ MEMBER_TO_FPTR(Perl_pp_ghostent), /* Perl_pp_ghbyname */
+ MEMBER_TO_FPTR(Perl_pp_ghostent), /* Perl_pp_ghbyaddr */
+ MEMBER_TO_FPTR(Perl_pp_ghostent),
+ MEMBER_TO_FPTR(Perl_pp_gnetent), /* Perl_pp_gnbyname */
+ MEMBER_TO_FPTR(Perl_pp_gnetent), /* Perl_pp_gnbyaddr */
+ MEMBER_TO_FPTR(Perl_pp_gnetent),
+ MEMBER_TO_FPTR(Perl_pp_gprotoent), /* Perl_pp_gpbyname */
+ MEMBER_TO_FPTR(Perl_pp_gprotoent), /* Perl_pp_gpbynumber */
+ MEMBER_TO_FPTR(Perl_pp_gprotoent),
+ MEMBER_TO_FPTR(Perl_pp_gservent), /* Perl_pp_gsbyname */
+ MEMBER_TO_FPTR(Perl_pp_gservent), /* Perl_pp_gsbyport */
+ MEMBER_TO_FPTR(Perl_pp_gservent),
+ MEMBER_TO_FPTR(Perl_pp_shostent),
+ MEMBER_TO_FPTR(Perl_pp_snetent),
+ MEMBER_TO_FPTR(Perl_pp_sprotoent),
+ MEMBER_TO_FPTR(Perl_pp_sservent),
+ MEMBER_TO_FPTR(Perl_pp_ehostent),
+ MEMBER_TO_FPTR(Perl_pp_enetent),
+ MEMBER_TO_FPTR(Perl_pp_eprotoent),
+ MEMBER_TO_FPTR(Perl_pp_eservent),
+ MEMBER_TO_FPTR(Perl_pp_gpwent), /* Perl_pp_gpwnam */
+ MEMBER_TO_FPTR(Perl_pp_gpwent), /* Perl_pp_gpwuid */
+ MEMBER_TO_FPTR(Perl_pp_gpwent),
+ MEMBER_TO_FPTR(Perl_pp_spwent),
+ MEMBER_TO_FPTR(Perl_pp_epwent),
+ MEMBER_TO_FPTR(Perl_pp_ggrent), /* Perl_pp_ggrnam */
+ MEMBER_TO_FPTR(Perl_pp_ggrent), /* Perl_pp_ggrgid */
+ MEMBER_TO_FPTR(Perl_pp_ggrent),
+ MEMBER_TO_FPTR(Perl_pp_sgrent),
+ MEMBER_TO_FPTR(Perl_pp_egrent),
+ MEMBER_TO_FPTR(Perl_pp_getlogin),
+ MEMBER_TO_FPTR(Perl_pp_syscall),
+ MEMBER_TO_FPTR(Perl_pp_lock),
+ MEMBER_TO_FPTR(Perl_pp_once),
+ MEMBER_TO_FPTR(Perl_unimplemented_op), /* Perl_pp_custom */
+}
+#endif
+#ifdef PERL_PPADDR_INITED
+;
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT_INIT
+# define PERL_CHECK_INITED
+static const Perl_check_t Gcheck[]
+#else
+# ifndef PERL_GLOBAL_STRUCT
+# define PERL_CHECK_INITED
+EXT Perl_check_t PL_check[] /* or perlvars.h */
+# endif
+#endif
+#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT)
+# define PERL_CHECK_INITED
+= {
+ MEMBER_TO_FPTR(Perl_ck_null), /* null */
+ MEMBER_TO_FPTR(Perl_ck_null), /* stub */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* scalar */
+ MEMBER_TO_FPTR(Perl_ck_null), /* pushmark */
+ MEMBER_TO_FPTR(Perl_ck_null), /* wantarray */
+ MEMBER_TO_FPTR(Perl_ck_svconst), /* const */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gvsv */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gv */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gelem */
+ MEMBER_TO_FPTR(Perl_ck_null), /* padsv */
+ MEMBER_TO_FPTR(Perl_ck_null), /* padav */
+ MEMBER_TO_FPTR(Perl_ck_null), /* padhv */
+ MEMBER_TO_FPTR(Perl_ck_null), /* padany */
+ MEMBER_TO_FPTR(Perl_ck_null), /* pushre */
+ MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2gv */
+ MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2sv */
+ MEMBER_TO_FPTR(Perl_ck_null), /* av2arylen */
+ MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2cv */
+ MEMBER_TO_FPTR(Perl_ck_anoncode), /* anoncode */
+ MEMBER_TO_FPTR(Perl_ck_null), /* prototype */
+ MEMBER_TO_FPTR(Perl_ck_spair), /* refgen */
+ MEMBER_TO_FPTR(Perl_ck_null), /* srefgen */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ref */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* bless */
+ MEMBER_TO_FPTR(Perl_ck_open), /* backtick */
+ MEMBER_TO_FPTR(Perl_ck_glob), /* glob */
+ MEMBER_TO_FPTR(Perl_ck_readline), /* readline */
+ MEMBER_TO_FPTR(Perl_ck_null), /* rcatline */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* regcmaybe */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* regcreset */
+ MEMBER_TO_FPTR(Perl_ck_null), /* regcomp */
+ MEMBER_TO_FPTR(Perl_ck_match), /* match */
+ MEMBER_TO_FPTR(Perl_ck_match), /* qr */
+ MEMBER_TO_FPTR(Perl_ck_match), /* subst */
+ MEMBER_TO_FPTR(Perl_ck_null), /* substcont */
+ MEMBER_TO_FPTR(Perl_ck_match), /* trans */
+ MEMBER_TO_FPTR(Perl_ck_sassign), /* sassign */
+ MEMBER_TO_FPTR(Perl_ck_null), /* aassign */
+ MEMBER_TO_FPTR(Perl_ck_spair), /* chop */
+ MEMBER_TO_FPTR(Perl_ck_null), /* schop */
+ MEMBER_TO_FPTR(Perl_ck_spair), /* chomp */
+ MEMBER_TO_FPTR(Perl_ck_null), /* schomp */
+ MEMBER_TO_FPTR(Perl_ck_defined), /* defined */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* undef */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* study */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* pos */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* preinc */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* i_preinc */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* predec */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* i_predec */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* postinc */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* i_postinc */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* postdec */
+ MEMBER_TO_FPTR(Perl_ck_lfun), /* i_postdec */
+ MEMBER_TO_FPTR(Perl_ck_null), /* pow */
+ MEMBER_TO_FPTR(Perl_ck_null), /* multiply */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_multiply */
+ MEMBER_TO_FPTR(Perl_ck_null), /* divide */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_divide */
+ MEMBER_TO_FPTR(Perl_ck_null), /* modulo */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_modulo */
+ MEMBER_TO_FPTR(Perl_ck_repeat), /* repeat */
+ MEMBER_TO_FPTR(Perl_ck_null), /* add */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_add */
+ MEMBER_TO_FPTR(Perl_ck_null), /* subtract */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_subtract */
+ MEMBER_TO_FPTR(Perl_ck_concat), /* concat */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* stringify */
+ MEMBER_TO_FPTR(Perl_ck_bitop), /* left_shift */
+ MEMBER_TO_FPTR(Perl_ck_bitop), /* right_shift */
+ MEMBER_TO_FPTR(Perl_ck_null), /* lt */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_lt */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gt */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_gt */
+ MEMBER_TO_FPTR(Perl_ck_null), /* le */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_le */
+ MEMBER_TO_FPTR(Perl_ck_null), /* ge */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_ge */
+ MEMBER_TO_FPTR(Perl_ck_null), /* eq */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_eq */
+ MEMBER_TO_FPTR(Perl_ck_null), /* ne */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_ne */
+ MEMBER_TO_FPTR(Perl_ck_null), /* ncmp */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_ncmp */
+ MEMBER_TO_FPTR(Perl_ck_null), /* slt */
+ MEMBER_TO_FPTR(Perl_ck_null), /* sgt */
+ MEMBER_TO_FPTR(Perl_ck_null), /* sle */
+ MEMBER_TO_FPTR(Perl_ck_null), /* sge */
+ MEMBER_TO_FPTR(Perl_ck_null), /* seq */
+ MEMBER_TO_FPTR(Perl_ck_null), /* sne */
+ MEMBER_TO_FPTR(Perl_ck_null), /* scmp */
+ MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_and */
+ MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_xor */
+ MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_or */
+ MEMBER_TO_FPTR(Perl_ck_null), /* negate */
+ MEMBER_TO_FPTR(Perl_ck_null), /* i_negate */
+ MEMBER_TO_FPTR(Perl_ck_null), /* not */
+ MEMBER_TO_FPTR(Perl_ck_bitop), /* complement */
+ MEMBER_TO_FPTR(Perl_ck_smartmatch), /* smartmatch */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* atan2 */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sin */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* cos */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* rand */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* srand */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* exp */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* log */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sqrt */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* int */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* hex */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* oct */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* abs */
+ MEMBER_TO_FPTR(Perl_ck_lengthconst), /* length */
+ MEMBER_TO_FPTR(Perl_ck_substr), /* substr */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* vec */
+ MEMBER_TO_FPTR(Perl_ck_index), /* index */
+ MEMBER_TO_FPTR(Perl_ck_index), /* rindex */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sprintf */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* formline */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ord */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* chr */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* crypt */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ucfirst */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* lcfirst */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* uc */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* lc */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* quotemeta */
+ MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2av */
+ MEMBER_TO_FPTR(Perl_ck_null), /* aelemfast */
+ MEMBER_TO_FPTR(Perl_ck_null), /* aelem */
+ MEMBER_TO_FPTR(Perl_ck_null), /* aslice */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* each */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* values */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* keys */
+ MEMBER_TO_FPTR(Perl_ck_delete), /* delete */
+ MEMBER_TO_FPTR(Perl_ck_exists), /* exists */
+ MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2hv */
+ MEMBER_TO_FPTR(Perl_ck_null), /* helem */
+ MEMBER_TO_FPTR(Perl_ck_null), /* hslice */
+ MEMBER_TO_FPTR(Perl_ck_unpack), /* unpack */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* pack */
+ MEMBER_TO_FPTR(Perl_ck_split), /* split */
+ MEMBER_TO_FPTR(Perl_ck_join), /* join */
+ MEMBER_TO_FPTR(Perl_ck_null), /* list */
+ MEMBER_TO_FPTR(Perl_ck_null), /* lslice */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* anonlist */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* anonhash */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* splice */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* push */
+ MEMBER_TO_FPTR(Perl_ck_shift), /* pop */
+ MEMBER_TO_FPTR(Perl_ck_shift), /* shift */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* unshift */
+ MEMBER_TO_FPTR(Perl_ck_sort), /* sort */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* reverse */
+ MEMBER_TO_FPTR(Perl_ck_grep), /* grepstart */
+ MEMBER_TO_FPTR(Perl_ck_null), /* grepwhile */
+ MEMBER_TO_FPTR(Perl_ck_grep), /* mapstart */
+ MEMBER_TO_FPTR(Perl_ck_null), /* mapwhile */
+ MEMBER_TO_FPTR(Perl_ck_null), /* range */
+ MEMBER_TO_FPTR(Perl_ck_null), /* flip */
+ MEMBER_TO_FPTR(Perl_ck_null), /* flop */
+ MEMBER_TO_FPTR(Perl_ck_null), /* and */
+ MEMBER_TO_FPTR(Perl_ck_null), /* or */
+ MEMBER_TO_FPTR(Perl_ck_null), /* xor */
+ MEMBER_TO_FPTR(Perl_ck_null), /* dor */
+ MEMBER_TO_FPTR(Perl_ck_null), /* cond_expr */
+ MEMBER_TO_FPTR(Perl_ck_null), /* andassign */
+ MEMBER_TO_FPTR(Perl_ck_null), /* orassign */
+ MEMBER_TO_FPTR(Perl_ck_null), /* dorassign */
+ MEMBER_TO_FPTR(Perl_ck_method), /* method */
+ MEMBER_TO_FPTR(Perl_ck_subr), /* entersub */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leavesub */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leavesublv */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* caller */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* warn */
+ MEMBER_TO_FPTR(Perl_ck_die), /* die */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* reset */
+ MEMBER_TO_FPTR(Perl_ck_null), /* lineseq */
+ MEMBER_TO_FPTR(Perl_ck_null), /* nextstate */
+ MEMBER_TO_FPTR(Perl_ck_null), /* dbstate */
+ MEMBER_TO_FPTR(Perl_ck_null), /* unstack */
+ MEMBER_TO_FPTR(Perl_ck_null), /* enter */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leave */
+ MEMBER_TO_FPTR(Perl_ck_null), /* scope */
+ MEMBER_TO_FPTR(Perl_ck_null), /* enteriter */
+ MEMBER_TO_FPTR(Perl_ck_null), /* iter */
+ MEMBER_TO_FPTR(Perl_ck_null), /* enterloop */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leaveloop */
+ MEMBER_TO_FPTR(Perl_ck_return), /* return */
+ MEMBER_TO_FPTR(Perl_ck_null), /* last */
+ MEMBER_TO_FPTR(Perl_ck_null), /* next */
+ MEMBER_TO_FPTR(Perl_ck_null), /* redo */
+ MEMBER_TO_FPTR(Perl_ck_null), /* dump */
+ MEMBER_TO_FPTR(Perl_ck_null), /* goto */
+ MEMBER_TO_FPTR(Perl_ck_exit), /* exit */
+ MEMBER_TO_FPTR(Perl_ck_null), /* setstate */
+ MEMBER_TO_FPTR(Perl_ck_null), /* method_named */
+ MEMBER_TO_FPTR(Perl_ck_null), /* entergiven */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leavegiven */
+ MEMBER_TO_FPTR(Perl_ck_null), /* enterwhen */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leavewhen */
+ MEMBER_TO_FPTR(Perl_ck_null), /* break */
+ MEMBER_TO_FPTR(Perl_ck_null), /* continue */
+ MEMBER_TO_FPTR(Perl_ck_open), /* open */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* close */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* pipe_op */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* fileno */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* umask */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* binmode */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* tie */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* untie */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* tied */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* dbmopen */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* dbmclose */
+ MEMBER_TO_FPTR(Perl_ck_select), /* sselect */
+ MEMBER_TO_FPTR(Perl_ck_select), /* select */
+ MEMBER_TO_FPTR(Perl_ck_eof), /* getc */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* read */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* enterwrite */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leavewrite */
+ MEMBER_TO_FPTR(Perl_ck_listiob), /* prtf */
+ MEMBER_TO_FPTR(Perl_ck_listiob), /* print */
+ MEMBER_TO_FPTR(Perl_ck_listiob), /* say */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sysopen */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sysseek */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sysread */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* syswrite */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* send */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* recv */
+ MEMBER_TO_FPTR(Perl_ck_eof), /* eof */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* tell */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* seek */
+ MEMBER_TO_FPTR(Perl_ck_trunc), /* truncate */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* fcntl */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ioctl */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* flock */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* socket */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sockpair */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* bind */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* connect */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* listen */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* accept */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* shutdown */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gsockopt */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ssockopt */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* getsockname */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* getpeername */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* lstat */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* stat */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftrread */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftrwrite */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftrexec */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* fteread */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftewrite */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* fteexec */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftis */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftsize */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftmtime */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftatime */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftctime */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftrowned */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* fteowned */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftzero */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftsock */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftchr */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftblk */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftfile */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftdir */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftpipe */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftsuid */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftsgid */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftsvtx */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftlink */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* fttty */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* fttext */
+ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftbinary */
+ MEMBER_TO_FPTR(Perl_ck_chdir), /* chdir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* chown */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* chroot */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* unlink */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* chmod */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* utime */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* rename */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* link */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* symlink */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* readlink */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* mkdir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* rmdir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* open_dir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* readdir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* telldir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* seekdir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* rewinddir */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* closedir */
+ MEMBER_TO_FPTR(Perl_ck_null), /* fork */
+ MEMBER_TO_FPTR(Perl_ck_null), /* wait */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* waitpid */
+ MEMBER_TO_FPTR(Perl_ck_exec), /* system */
+ MEMBER_TO_FPTR(Perl_ck_exec), /* exec */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* kill */
+ MEMBER_TO_FPTR(Perl_ck_null), /* getppid */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* getpgrp */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* setpgrp */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* getpriority */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* setpriority */
+ MEMBER_TO_FPTR(Perl_ck_null), /* time */
+ MEMBER_TO_FPTR(Perl_ck_null), /* tms */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* localtime */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gmtime */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* alarm */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sleep */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* shmget */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* shmctl */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* shmread */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* shmwrite */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* msgget */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* msgctl */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* msgsnd */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* msgrcv */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* semop */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* semget */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* semctl */
+ MEMBER_TO_FPTR(Perl_ck_require), /* require */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* dofile */
+ MEMBER_TO_FPTR(Perl_ck_eval), /* entereval */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leaveeval */
+ MEMBER_TO_FPTR(Perl_ck_null), /* entertry */
+ MEMBER_TO_FPTR(Perl_ck_null), /* leavetry */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ghbyname */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ghbyaddr */
+ MEMBER_TO_FPTR(Perl_ck_null), /* ghostent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gnbyname */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gnbyaddr */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gnetent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gpbyname */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gpbynumber */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gprotoent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gsbyname */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gsbyport */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gservent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* shostent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* snetent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sprotoent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* sservent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* ehostent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* enetent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* eprotoent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* eservent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gpwnam */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* gpwuid */
+ MEMBER_TO_FPTR(Perl_ck_null), /* gpwent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* spwent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* epwent */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ggrnam */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* ggrgid */
+ MEMBER_TO_FPTR(Perl_ck_null), /* ggrent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* sgrent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* egrent */
+ MEMBER_TO_FPTR(Perl_ck_null), /* getlogin */
+ MEMBER_TO_FPTR(Perl_ck_fun), /* syscall */
+ MEMBER_TO_FPTR(Perl_ck_rfun), /* lock */
+ MEMBER_TO_FPTR(Perl_ck_null), /* once */
+ MEMBER_TO_FPTR(Perl_ck_null), /* custom */
+}
+#endif
+#ifdef PERL_CHECK_INITED
+;
+#endif /* #ifdef PERL_CHECK_INITED */
+
+#ifndef PERL_GLOBAL_STRUCT_INIT
+
+#ifndef DOINIT
+EXTCONST U32 PL_opargs[];
+#else
+EXTCONST U32 PL_opargs[] = {
+ 0x00000000, /* null */
+ 0x00000000, /* stub */
+ 0x00003604, /* scalar */
+ 0x00000004, /* pushmark */
+ 0x00000014, /* wantarray */
+ 0x00000c04, /* const */
+ 0x00000c44, /* gvsv */
+ 0x00000c44, /* gv */
+ 0x00022440, /* gelem */
+ 0x00000044, /* padsv */
+ 0x00000040, /* padav */
+ 0x00000040, /* padhv */
+ 0x00000040, /* padany */
+ 0x00000a40, /* pushre */
+ 0x00000244, /* rv2gv */
+ 0x00000244, /* rv2sv */
+ 0x00000214, /* av2arylen */
+ 0x00000240, /* rv2cv */
+ 0x00000c00, /* anoncode */
+ 0x00003604, /* prototype */
+ 0x00004201, /* refgen */
+ 0x00002206, /* srefgen */
+ 0x0001368c, /* ref */
+ 0x00122804, /* bless */
+ 0x00013688, /* backtick */
+ 0x00012808, /* glob */
+ 0x0001d608, /* readline */
+ 0x00000c08, /* rcatline */
+ 0x00002204, /* regcmaybe */
+ 0x00002204, /* regcreset */
+ 0x00002604, /* regcomp */
+ 0x00000a40, /* match */
+ 0x00000a04, /* qr */
+ 0x00002a54, /* subst */
+ 0x00000654, /* substcont */
+ 0x00003014, /* trans */
+ 0x00000004, /* sassign */
+ 0x00044408, /* aassign */
+ 0x0000560d, /* chop */
+ 0x0001368c, /* schop */
+ 0x0000570d, /* chomp */
+ 0x0001378c, /* schomp */
+ 0x00013694, /* defined */
+ 0x00013604, /* undef */
+ 0x00013684, /* study */
+ 0x0001368c, /* pos */
+ 0x00002264, /* preinc */
+ 0x00002254, /* i_preinc */
+ 0x00002264, /* predec */
+ 0x00002254, /* i_predec */
+ 0x0000226c, /* postinc */
+ 0x0000235c, /* i_postinc */
+ 0x0000226c, /* postdec */
+ 0x0000235c, /* i_postdec */
+ 0x0002250e, /* pow */
+ 0x0002252e, /* multiply */
+ 0x0002251e, /* i_multiply */
+ 0x0002252e, /* divide */
+ 0x0002251e, /* i_divide */
+ 0x0002253e, /* modulo */
+ 0x0002251e, /* i_modulo */
+ 0x00024409, /* repeat */
+ 0x0002252e, /* add */
+ 0x0002251e, /* i_add */
+ 0x0002252e, /* subtract */
+ 0x0002251e, /* i_subtract */
+ 0x0002250e, /* concat */
+ 0x0000290e, /* stringify */
+ 0x0002250e, /* left_shift */
+ 0x0002250e, /* right_shift */
+ 0x00022436, /* lt */
+ 0x00022416, /* i_lt */
+ 0x00022436, /* gt */
+ 0x00022416, /* i_gt */
+ 0x00022436, /* le */
+ 0x00022416, /* i_le */
+ 0x00022436, /* ge */
+ 0x00022416, /* i_ge */
+ 0x00022436, /* eq */
+ 0x00022416, /* i_eq */
+ 0x00022436, /* ne */
+ 0x00022416, /* i_ne */
+ 0x0002243e, /* ncmp */
+ 0x0002241e, /* i_ncmp */
+ 0x00022416, /* slt */
+ 0x00022416, /* sgt */
+ 0x00022416, /* sle */
+ 0x00022416, /* sge */
+ 0x00022416, /* seq */
+ 0x00022416, /* sne */
+ 0x0002241e, /* scmp */
+ 0x0002240e, /* bit_and */
+ 0x0002240e, /* bit_xor */
+ 0x0002240e, /* bit_or */
+ 0x0000222e, /* negate */
+ 0x0000231e, /* i_negate */
+ 0x00002216, /* not */
+ 0x0000220e, /* complement */
+ 0x00000404, /* smartmatch */
+ 0x0002290e, /* atan2 */
+ 0x0001378e, /* sin */
+ 0x0001378e, /* cos */
+ 0x0001370c, /* rand */
+ 0x00013604, /* srand */
+ 0x0001378e, /* exp */
+ 0x0001378e, /* log */
+ 0x0001378e, /* sqrt */
+ 0x0001378e, /* int */
+ 0x0001378e, /* hex */
+ 0x0001378e, /* oct */
+ 0x0001378e, /* abs */
+ 0x0001379e, /* length */
+ 0x1322280c, /* substr */
+ 0x0022281c, /* vec */
+ 0x0122291c, /* index */
+ 0x0122291c, /* rindex */
+ 0x0004280f, /* sprintf */
+ 0x00042805, /* formline */
+ 0x0001379e, /* ord */
+ 0x0001378e, /* chr */
+ 0x0002290e, /* crypt */
+ 0x0001368e, /* ucfirst */
+ 0x0001368e, /* lcfirst */
+ 0x0001368e, /* uc */
+ 0x0001368e, /* lc */
+ 0x0001368e, /* quotemeta */
+ 0x00000248, /* rv2av */
+ 0x00026c04, /* aelemfast */
+ 0x00026404, /* aelem */
+ 0x00046801, /* aslice */
+ 0x00009600, /* each */
+ 0x00009608, /* values */
+ 0x00009608, /* keys */
+ 0x00003600, /* delete */
+ 0x00003614, /* exists */
+ 0x00000248, /* rv2hv */
+ 0x00028404, /* helem */
+ 0x00048801, /* hslice */
+ 0x00122800, /* unpack */
+ 0x0004280d, /* pack */
+ 0x00222808, /* split */
+ 0x0004280d, /* join */
+ 0x00004801, /* list */
+ 0x00448400, /* lslice */
+ 0x00004805, /* anonlist */
+ 0x00004805, /* anonhash */
+ 0x05326801, /* splice */
+ 0x0004691d, /* push */
+ 0x00017604, /* pop */
+ 0x00017604, /* shift */
+ 0x0004691d, /* unshift */
+ 0x0005a841, /* sort */
+ 0x00004809, /* reverse */
+ 0x0004a841, /* grepstart */
+ 0x00000648, /* grepwhile */
+ 0x0004a841, /* mapstart */
+ 0x00000648, /* mapwhile */
+ 0x00022600, /* range */
+ 0x00022200, /* flip */
+ 0x00000200, /* flop */
+ 0x00000600, /* and */
+ 0x00000600, /* or */
+ 0x00022406, /* xor */
+ 0x00000600, /* dor */
+ 0x00000640, /* cond_expr */
+ 0x00000604, /* andassign */
+ 0x00000604, /* orassign */
+ 0x00000604, /* dorassign */
+ 0x00000240, /* method */
+ 0x00004249, /* entersub */
+ 0x00000200, /* leavesub */
+ 0x00000200, /* leavesublv */
+ 0x00013608, /* caller */
+ 0x0000481d, /* warn */
+ 0x0000485d, /* die */
+ 0x00013614, /* reset */
+ 0x00000800, /* lineseq */
+ 0x00001404, /* nextstate */
+ 0x00001404, /* dbstate */
+ 0x00000004, /* unstack */
+ 0x00000000, /* enter */
+ 0x00000800, /* leave */
+ 0x00000800, /* scope */
+ 0x00001240, /* enteriter */
+ 0x00000000, /* iter */
+ 0x00001240, /* enterloop */
+ 0x00000400, /* leaveloop */
+ 0x00004841, /* return */
+ 0x00001a44, /* last */
+ 0x00001a44, /* next */
+ 0x00001a44, /* redo */
+ 0x00001a44, /* dump */
+ 0x00001a44, /* goto */
+ 0x00013644, /* exit */
+ 0x00001404, /* setstate */
+ 0x00000c40, /* method_named */
+ 0x00000640, /* entergiven */
+ 0x00000200, /* leavegiven */
+ 0x00000640, /* enterwhen */
+ 0x00000200, /* leavewhen */
+ 0x00000000, /* break */
+ 0x00000000, /* continue */
+ 0x0052c81d, /* open */
+ 0x0001d614, /* close */
+ 0x000cc814, /* pipe_op */
+ 0x0000d61c, /* fileno */
+ 0x0001361c, /* umask */
+ 0x0012c804, /* binmode */
+ 0x0042e855, /* tie */
+ 0x0000f614, /* untie */
+ 0x0000f604, /* tied */
+ 0x00228814, /* dbmopen */
+ 0x00009614, /* dbmclose */
+ 0x02222808, /* sselect */
+ 0x0001c80c, /* select */
+ 0x0001d60c, /* getc */
+ 0x122ec81d, /* read */
+ 0x0001d654, /* enterwrite */
+ 0x00000200, /* leavewrite */
+ 0x0005c815, /* prtf */
+ 0x0005c815, /* print */
+ 0x0005c815, /* say */
+ 0x1222c804, /* sysopen */
+ 0x0022c804, /* sysseek */
+ 0x122ec81d, /* sysread */
+ 0x1322c81d, /* syswrite */
+ 0x1222c81d, /* send */
+ 0x022ec81d, /* recv */
+ 0x0001d614, /* eof */
+ 0x0001d60c, /* tell */
+ 0x0022c804, /* seek */
+ 0x00022814, /* truncate */
+ 0x0022c80c, /* fcntl */
+ 0x0022c80c, /* ioctl */
+ 0x0002c91c, /* flock */
+ 0x0222c814, /* socket */
+ 0x222cc814, /* sockpair */
+ 0x0002c814, /* bind */
+ 0x0002c814, /* connect */
+ 0x0002c814, /* listen */
+ 0x000cc81c, /* accept */
+ 0x0002c81c, /* shutdown */
+ 0x0022c814, /* gsockopt */
+ 0x0222c814, /* ssockopt */
+ 0x0000d614, /* getsockname */
+ 0x0000d614, /* getpeername */
+ 0x0000d880, /* lstat */
+ 0x0000d880, /* stat */
+ 0x0000d894, /* ftrread */
+ 0x0000d894, /* ftrwrite */
+ 0x0000d894, /* ftrexec */
+ 0x0000d894, /* fteread */
+ 0x0000d894, /* ftewrite */
+ 0x0000d894, /* fteexec */
+ 0x0000d894, /* ftis */
+ 0x0000d89c, /* ftsize */
+ 0x0000d88c, /* ftmtime */
+ 0x0000d88c, /* ftatime */
+ 0x0000d88c, /* ftctime */
+ 0x0000d894, /* ftrowned */
+ 0x0000d894, /* fteowned */
+ 0x0000d894, /* ftzero */
+ 0x0000d894, /* ftsock */
+ 0x0000d894, /* ftchr */
+ 0x0000d894, /* ftblk */
+ 0x0000d894, /* ftfile */
+ 0x0000d894, /* ftdir */
+ 0x0000d894, /* ftpipe */
+ 0x0000d894, /* ftsuid */
+ 0x0000d894, /* ftsgid */
+ 0x0000d894, /* ftsvtx */
+ 0x0000d894, /* ftlink */
+ 0x0000d814, /* fttty */
+ 0x0000d894, /* fttext */
+ 0x0000d894, /* ftbinary */
+ 0x0001371c, /* chdir */
+ 0x0000491d, /* chown */
+ 0x0001379c, /* chroot */
+ 0x0000499d, /* unlink */
+ 0x0000491d, /* chmod */
+ 0x0000491d, /* utime */
+ 0x0002291c, /* rename */
+ 0x0002291c, /* link */
+ 0x0002291c, /* symlink */
+ 0x0001368c, /* readlink */
+ 0x0013299c, /* mkdir */
+ 0x0001379c, /* rmdir */
+ 0x0002c814, /* open_dir */
+ 0x0000d600, /* readdir */
+ 0x0000d60c, /* telldir */
+ 0x0002c804, /* seekdir */
+ 0x0000d604, /* rewinddir */
+ 0x0000d614, /* closedir */
+ 0x0000001c, /* fork */
+ 0x0000011c, /* wait */
+ 0x0002291c, /* waitpid */
+ 0x0005291d, /* system */
+ 0x0005295d, /* exec */
+ 0x0000495d, /* kill */
+ 0x0000011c, /* getppid */
+ 0x0001371c, /* getpgrp */
+ 0x0013291c, /* setpgrp */
+ 0x0002291c, /* getpriority */
+ 0x0022291c, /* setpriority */
+ 0x0000011c, /* time */
+ 0x00000000, /* tms */
+ 0x00013608, /* localtime */
+ 0x00013608, /* gmtime */
+ 0x0001369c, /* alarm */
+ 0x0001371c, /* sleep */
+ 0x0022281d, /* shmget */
+ 0x0022281d, /* shmctl */
+ 0x0222281d, /* shmread */
+ 0x0222281d, /* shmwrite */
+ 0x0002281d, /* msgget */
+ 0x0022281d, /* msgctl */
+ 0x0022281d, /* msgsnd */
+ 0x2222281d, /* msgrcv */
+ 0x0002281d, /* semop */
+ 0x0022281d, /* semget */
+ 0x0222281d, /* semctl */
+ 0x000136c0, /* require */
+ 0x00002240, /* dofile */
+ 0x00003640, /* entereval */
+ 0x00002200, /* leaveeval */
+ 0x00000600, /* entertry */
+ 0x00000800, /* leavetry */
+ 0x00003600, /* ghbyname */
+ 0x00022800, /* ghbyaddr */
+ 0x00000000, /* ghostent */
+ 0x00003600, /* gnbyname */
+ 0x00022800, /* gnbyaddr */
+ 0x00000000, /* gnetent */
+ 0x00003600, /* gpbyname */
+ 0x00002800, /* gpbynumber */
+ 0x00000000, /* gprotoent */
+ 0x00022800, /* gsbyname */
+ 0x00022800, /* gsbyport */
+ 0x00000000, /* gservent */
+ 0x00003614, /* shostent */
+ 0x00003614, /* snetent */
+ 0x00003614, /* sprotoent */
+ 0x00003614, /* sservent */
+ 0x00000014, /* ehostent */
+ 0x00000014, /* enetent */
+ 0x00000014, /* eprotoent */
+ 0x00000014, /* eservent */
+ 0x00003600, /* gpwnam */
+ 0x00003600, /* gpwuid */
+ 0x00000000, /* gpwent */
+ 0x00000014, /* spwent */
+ 0x00000014, /* epwent */
+ 0x00003600, /* ggrnam */
+ 0x00003600, /* ggrgid */
+ 0x00000000, /* ggrent */
+ 0x00000014, /* sgrent */
+ 0x00000014, /* egrent */
+ 0x0000000c, /* getlogin */
+ 0x0004281d, /* syscall */
+ 0x0000f604, /* lock */
+ 0x00000600, /* once */
+ 0x00000000, /* custom */
+};
+#endif
+
+#endif /* !PERL_GLOBAL_STRUCT_INIT */
+
+END_EXTERN_C
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/opnames.h b/Master/tlpkg/tlperl.straw/lib/CORE/opnames.h
new file mode 100755
index 00000000000..099bda1dd2f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/opnames.h
@@ -0,0 +1,433 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * opnames.h
+ *
+ * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ * 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by opcode.pl from its data. Any changes made here
+ * will be lost!
+ */
+
+typedef enum opcode {
+ OP_NULL, /* 0 */
+ OP_STUB, /* 1 */
+ OP_SCALAR, /* 2 */
+ OP_PUSHMARK, /* 3 */
+ OP_WANTARRAY, /* 4 */
+ OP_CONST, /* 5 */
+ OP_GVSV, /* 6 */
+ OP_GV, /* 7 */
+ OP_GELEM, /* 8 */
+ OP_PADSV, /* 9 */
+ OP_PADAV, /* 10 */
+ OP_PADHV, /* 11 */
+ OP_PADANY, /* 12 */
+ OP_PUSHRE, /* 13 */
+ OP_RV2GV, /* 14 */
+ OP_RV2SV, /* 15 */
+ OP_AV2ARYLEN, /* 16 */
+ OP_RV2CV, /* 17 */
+ OP_ANONCODE, /* 18 */
+ OP_PROTOTYPE, /* 19 */
+ OP_REFGEN, /* 20 */
+ OP_SREFGEN, /* 21 */
+ OP_REF, /* 22 */
+ OP_BLESS, /* 23 */
+ OP_BACKTICK, /* 24 */
+ OP_GLOB, /* 25 */
+ OP_READLINE, /* 26 */
+ OP_RCATLINE, /* 27 */
+ OP_REGCMAYBE, /* 28 */
+ OP_REGCRESET, /* 29 */
+ OP_REGCOMP, /* 30 */
+ OP_MATCH, /* 31 */
+ OP_QR, /* 32 */
+ OP_SUBST, /* 33 */
+ OP_SUBSTCONT, /* 34 */
+ OP_TRANS, /* 35 */
+ OP_SASSIGN, /* 36 */
+ OP_AASSIGN, /* 37 */
+ OP_CHOP, /* 38 */
+ OP_SCHOP, /* 39 */
+ OP_CHOMP, /* 40 */
+ OP_SCHOMP, /* 41 */
+ OP_DEFINED, /* 42 */
+ OP_UNDEF, /* 43 */
+ OP_STUDY, /* 44 */
+ OP_POS, /* 45 */
+ OP_PREINC, /* 46 */
+ OP_I_PREINC, /* 47 */
+ OP_PREDEC, /* 48 */
+ OP_I_PREDEC, /* 49 */
+ OP_POSTINC, /* 50 */
+ OP_I_POSTINC, /* 51 */
+ OP_POSTDEC, /* 52 */
+ OP_I_POSTDEC, /* 53 */
+ OP_POW, /* 54 */
+ OP_MULTIPLY, /* 55 */
+ OP_I_MULTIPLY, /* 56 */
+ OP_DIVIDE, /* 57 */
+ OP_I_DIVIDE, /* 58 */
+ OP_MODULO, /* 59 */
+ OP_I_MODULO, /* 60 */
+ OP_REPEAT, /* 61 */
+ OP_ADD, /* 62 */
+ OP_I_ADD, /* 63 */
+ OP_SUBTRACT, /* 64 */
+ OP_I_SUBTRACT, /* 65 */
+ OP_CONCAT, /* 66 */
+ OP_STRINGIFY, /* 67 */
+ OP_LEFT_SHIFT, /* 68 */
+ OP_RIGHT_SHIFT, /* 69 */
+ OP_LT, /* 70 */
+ OP_I_LT, /* 71 */
+ OP_GT, /* 72 */
+ OP_I_GT, /* 73 */
+ OP_LE, /* 74 */
+ OP_I_LE, /* 75 */
+ OP_GE, /* 76 */
+ OP_I_GE, /* 77 */
+ OP_EQ, /* 78 */
+ OP_I_EQ, /* 79 */
+ OP_NE, /* 80 */
+ OP_I_NE, /* 81 */
+ OP_NCMP, /* 82 */
+ OP_I_NCMP, /* 83 */
+ OP_SLT, /* 84 */
+ OP_SGT, /* 85 */
+ OP_SLE, /* 86 */
+ OP_SGE, /* 87 */
+ OP_SEQ, /* 88 */
+ OP_SNE, /* 89 */
+ OP_SCMP, /* 90 */
+ OP_BIT_AND, /* 91 */
+ OP_BIT_XOR, /* 92 */
+ OP_BIT_OR, /* 93 */
+ OP_NEGATE, /* 94 */
+ OP_I_NEGATE, /* 95 */
+ OP_NOT, /* 96 */
+ OP_COMPLEMENT, /* 97 */
+ OP_SMARTMATCH, /* 98 */
+ OP_ATAN2, /* 99 */
+ OP_SIN, /* 100 */
+ OP_COS, /* 101 */
+ OP_RAND, /* 102 */
+ OP_SRAND, /* 103 */
+ OP_EXP, /* 104 */
+ OP_LOG, /* 105 */
+ OP_SQRT, /* 106 */
+ OP_INT, /* 107 */
+ OP_HEX, /* 108 */
+ OP_OCT, /* 109 */
+ OP_ABS, /* 110 */
+ OP_LENGTH, /* 111 */
+ OP_SUBSTR, /* 112 */
+ OP_VEC, /* 113 */
+ OP_INDEX, /* 114 */
+ OP_RINDEX, /* 115 */
+ OP_SPRINTF, /* 116 */
+ OP_FORMLINE, /* 117 */
+ OP_ORD, /* 118 */
+ OP_CHR, /* 119 */
+ OP_CRYPT, /* 120 */
+ OP_UCFIRST, /* 121 */
+ OP_LCFIRST, /* 122 */
+ OP_UC, /* 123 */
+ OP_LC, /* 124 */
+ OP_QUOTEMETA, /* 125 */
+ OP_RV2AV, /* 126 */
+ OP_AELEMFAST, /* 127 */
+ OP_AELEM, /* 128 */
+ OP_ASLICE, /* 129 */
+ OP_EACH, /* 130 */
+ OP_VALUES, /* 131 */
+ OP_KEYS, /* 132 */
+ OP_DELETE, /* 133 */
+ OP_EXISTS, /* 134 */
+ OP_RV2HV, /* 135 */
+ OP_HELEM, /* 136 */
+ OP_HSLICE, /* 137 */
+ OP_UNPACK, /* 138 */
+ OP_PACK, /* 139 */
+ OP_SPLIT, /* 140 */
+ OP_JOIN, /* 141 */
+ OP_LIST, /* 142 */
+ OP_LSLICE, /* 143 */
+ OP_ANONLIST, /* 144 */
+ OP_ANONHASH, /* 145 */
+ OP_SPLICE, /* 146 */
+ OP_PUSH, /* 147 */
+ OP_POP, /* 148 */
+ OP_SHIFT, /* 149 */
+ OP_UNSHIFT, /* 150 */
+ OP_SORT, /* 151 */
+ OP_REVERSE, /* 152 */
+ OP_GREPSTART, /* 153 */
+ OP_GREPWHILE, /* 154 */
+ OP_MAPSTART, /* 155 */
+ OP_MAPWHILE, /* 156 */
+ OP_RANGE, /* 157 */
+ OP_FLIP, /* 158 */
+ OP_FLOP, /* 159 */
+ OP_AND, /* 160 */
+ OP_OR, /* 161 */
+ OP_XOR, /* 162 */
+ OP_DOR, /* 163 */
+ OP_COND_EXPR, /* 164 */
+ OP_ANDASSIGN, /* 165 */
+ OP_ORASSIGN, /* 166 */
+ OP_DORASSIGN, /* 167 */
+ OP_METHOD, /* 168 */
+ OP_ENTERSUB, /* 169 */
+ OP_LEAVESUB, /* 170 */
+ OP_LEAVESUBLV, /* 171 */
+ OP_CALLER, /* 172 */
+ OP_WARN, /* 173 */
+ OP_DIE, /* 174 */
+ OP_RESET, /* 175 */
+ OP_LINESEQ, /* 176 */
+ OP_NEXTSTATE, /* 177 */
+ OP_DBSTATE, /* 178 */
+ OP_UNSTACK, /* 179 */
+ OP_ENTER, /* 180 */
+ OP_LEAVE, /* 181 */
+ OP_SCOPE, /* 182 */
+ OP_ENTERITER, /* 183 */
+ OP_ITER, /* 184 */
+ OP_ENTERLOOP, /* 185 */
+ OP_LEAVELOOP, /* 186 */
+ OP_RETURN, /* 187 */
+ OP_LAST, /* 188 */
+ OP_NEXT, /* 189 */
+ OP_REDO, /* 190 */
+ OP_DUMP, /* 191 */
+ OP_GOTO, /* 192 */
+ OP_EXIT, /* 193 */
+ OP_SETSTATE, /* 194 */
+ OP_METHOD_NAMED,/* 195 */
+ OP_ENTERGIVEN, /* 196 */
+ OP_LEAVEGIVEN, /* 197 */
+ OP_ENTERWHEN, /* 198 */
+ OP_LEAVEWHEN, /* 199 */
+ OP_BREAK, /* 200 */
+ OP_CONTINUE, /* 201 */
+ OP_OPEN, /* 202 */
+ OP_CLOSE, /* 203 */
+ OP_PIPE_OP, /* 204 */
+ OP_FILENO, /* 205 */
+ OP_UMASK, /* 206 */
+ OP_BINMODE, /* 207 */
+ OP_TIE, /* 208 */
+ OP_UNTIE, /* 209 */
+ OP_TIED, /* 210 */
+ OP_DBMOPEN, /* 211 */
+ OP_DBMCLOSE, /* 212 */
+ OP_SSELECT, /* 213 */
+ OP_SELECT, /* 214 */
+ OP_GETC, /* 215 */
+ OP_READ, /* 216 */
+ OP_ENTERWRITE, /* 217 */
+ OP_LEAVEWRITE, /* 218 */
+ OP_PRTF, /* 219 */
+ OP_PRINT, /* 220 */
+ OP_SAY, /* 221 */
+ OP_SYSOPEN, /* 222 */
+ OP_SYSSEEK, /* 223 */
+ OP_SYSREAD, /* 224 */
+ OP_SYSWRITE, /* 225 */
+ OP_SEND, /* 226 */
+ OP_RECV, /* 227 */
+ OP_EOF, /* 228 */
+ OP_TELL, /* 229 */
+ OP_SEEK, /* 230 */
+ OP_TRUNCATE, /* 231 */
+ OP_FCNTL, /* 232 */
+ OP_IOCTL, /* 233 */
+ OP_FLOCK, /* 234 */
+ OP_SOCKET, /* 235 */
+ OP_SOCKPAIR, /* 236 */
+ OP_BIND, /* 237 */
+ OP_CONNECT, /* 238 */
+ OP_LISTEN, /* 239 */
+ OP_ACCEPT, /* 240 */
+ OP_SHUTDOWN, /* 241 */
+ OP_GSOCKOPT, /* 242 */
+ OP_SSOCKOPT, /* 243 */
+ OP_GETSOCKNAME, /* 244 */
+ OP_GETPEERNAME, /* 245 */
+ OP_LSTAT, /* 246 */
+ OP_STAT, /* 247 */
+ OP_FTRREAD, /* 248 */
+ OP_FTRWRITE, /* 249 */
+ OP_FTREXEC, /* 250 */
+ OP_FTEREAD, /* 251 */
+ OP_FTEWRITE, /* 252 */
+ OP_FTEEXEC, /* 253 */
+ OP_FTIS, /* 254 */
+ OP_FTSIZE, /* 255 */
+ OP_FTMTIME, /* 256 */
+ OP_FTATIME, /* 257 */
+ OP_FTCTIME, /* 258 */
+ OP_FTROWNED, /* 259 */
+ OP_FTEOWNED, /* 260 */
+ OP_FTZERO, /* 261 */
+ OP_FTSOCK, /* 262 */
+ OP_FTCHR, /* 263 */
+ OP_FTBLK, /* 264 */
+ OP_FTFILE, /* 265 */
+ OP_FTDIR, /* 266 */
+ OP_FTPIPE, /* 267 */
+ OP_FTSUID, /* 268 */
+ OP_FTSGID, /* 269 */
+ OP_FTSVTX, /* 270 */
+ OP_FTLINK, /* 271 */
+ OP_FTTTY, /* 272 */
+ OP_FTTEXT, /* 273 */
+ OP_FTBINARY, /* 274 */
+ OP_CHDIR, /* 275 */
+ OP_CHOWN, /* 276 */
+ OP_CHROOT, /* 277 */
+ OP_UNLINK, /* 278 */
+ OP_CHMOD, /* 279 */
+ OP_UTIME, /* 280 */
+ OP_RENAME, /* 281 */
+ OP_LINK, /* 282 */
+ OP_SYMLINK, /* 283 */
+ OP_READLINK, /* 284 */
+ OP_MKDIR, /* 285 */
+ OP_RMDIR, /* 286 */
+ OP_OPEN_DIR, /* 287 */
+ OP_READDIR, /* 288 */
+ OP_TELLDIR, /* 289 */
+ OP_SEEKDIR, /* 290 */
+ OP_REWINDDIR, /* 291 */
+ OP_CLOSEDIR, /* 292 */
+ OP_FORK, /* 293 */
+ OP_WAIT, /* 294 */
+ OP_WAITPID, /* 295 */
+ OP_SYSTEM, /* 296 */
+ OP_EXEC, /* 297 */
+ OP_KILL, /* 298 */
+ OP_GETPPID, /* 299 */
+ OP_GETPGRP, /* 300 */
+ OP_SETPGRP, /* 301 */
+ OP_GETPRIORITY, /* 302 */
+ OP_SETPRIORITY, /* 303 */
+ OP_TIME, /* 304 */
+ OP_TMS, /* 305 */
+ OP_LOCALTIME, /* 306 */
+ OP_GMTIME, /* 307 */
+ OP_ALARM, /* 308 */
+ OP_SLEEP, /* 309 */
+ OP_SHMGET, /* 310 */
+ OP_SHMCTL, /* 311 */
+ OP_SHMREAD, /* 312 */
+ OP_SHMWRITE, /* 313 */
+ OP_MSGGET, /* 314 */
+ OP_MSGCTL, /* 315 */
+ OP_MSGSND, /* 316 */
+ OP_MSGRCV, /* 317 */
+ OP_SEMOP, /* 318 */
+ OP_SEMGET, /* 319 */
+ OP_SEMCTL, /* 320 */
+ OP_REQUIRE, /* 321 */
+ OP_DOFILE, /* 322 */
+ OP_ENTEREVAL, /* 323 */
+ OP_LEAVEEVAL, /* 324 */
+ OP_ENTERTRY, /* 325 */
+ OP_LEAVETRY, /* 326 */
+ OP_GHBYNAME, /* 327 */
+ OP_GHBYADDR, /* 328 */
+ OP_GHOSTENT, /* 329 */
+ OP_GNBYNAME, /* 330 */
+ OP_GNBYADDR, /* 331 */
+ OP_GNETENT, /* 332 */
+ OP_GPBYNAME, /* 333 */
+ OP_GPBYNUMBER, /* 334 */
+ OP_GPROTOENT, /* 335 */
+ OP_GSBYNAME, /* 336 */
+ OP_GSBYPORT, /* 337 */
+ OP_GSERVENT, /* 338 */
+ OP_SHOSTENT, /* 339 */
+ OP_SNETENT, /* 340 */
+ OP_SPROTOENT, /* 341 */
+ OP_SSERVENT, /* 342 */
+ OP_EHOSTENT, /* 343 */
+ OP_ENETENT, /* 344 */
+ OP_EPROTOENT, /* 345 */
+ OP_ESERVENT, /* 346 */
+ OP_GPWNAM, /* 347 */
+ OP_GPWUID, /* 348 */
+ OP_GPWENT, /* 349 */
+ OP_SPWENT, /* 350 */
+ OP_EPWENT, /* 351 */
+ OP_GGRNAM, /* 352 */
+ OP_GGRGID, /* 353 */
+ OP_GGRENT, /* 354 */
+ OP_SGRENT, /* 355 */
+ OP_EGRENT, /* 356 */
+ OP_GETLOGIN, /* 357 */
+ OP_SYSCALL, /* 358 */
+ OP_LOCK, /* 359 */
+ OP_ONCE, /* 360 */
+ OP_CUSTOM, /* 361 */
+ OP_max
+} opcode;
+
+#define MAXO 362
+#define OP_phoney_INPUT_ONLY -1
+#define OP_phoney_OUTPUT_ONLY -2
+
+
+#define OP_IS_SOCKET(op) \
+ ((op) == OP_ACCEPT || \
+ (op) == OP_BIND || \
+ (op) == OP_CONNECT || \
+ (op) == OP_GETPEERNAME || \
+ (op) == OP_GETSOCKNAME || \
+ (op) == OP_GSOCKOPT || \
+ (op) == OP_LISTEN || \
+ (op) == OP_RECV || \
+ (op) == OP_SEND || \
+ (op) == OP_SHUTDOWN || \
+ (op) == OP_SOCKET || \
+ (op) == OP_SOCKPAIR || \
+ (op) == OP_SSOCKOPT)
+
+
+#define OP_IS_FILETEST(op) \
+ ((op) == OP_FTATIME || \
+ (op) == OP_FTBINARY || \
+ (op) == OP_FTBLK || \
+ (op) == OP_FTCHR || \
+ (op) == OP_FTCTIME || \
+ (op) == OP_FTDIR || \
+ (op) == OP_FTEEXEC || \
+ (op) == OP_FTEOWNED || \
+ (op) == OP_FTEREAD || \
+ (op) == OP_FTEWRITE || \
+ (op) == OP_FTFILE || \
+ (op) == OP_FTIS || \
+ (op) == OP_FTLINK || \
+ (op) == OP_FTMTIME || \
+ (op) == OP_FTPIPE || \
+ (op) == OP_FTREXEC || \
+ (op) == OP_FTROWNED || \
+ (op) == OP_FTRREAD || \
+ (op) == OP_FTRWRITE || \
+ (op) == OP_FTSGID || \
+ (op) == OP_FTSIZE || \
+ (op) == OP_FTSOCK || \
+ (op) == OP_FTSUID || \
+ (op) == OP_FTSVTX || \
+ (op) == OP_FTTEXT || \
+ (op) == OP_FTTTY || \
+ (op) == OP_FTZERO)
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/overload.h b/Master/tlpkg/tlperl.straw/lib/CORE/overload.h
new file mode 100755
index 00000000000..17505851226
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/overload.h
@@ -0,0 +1,88 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * overload.h
+ *
+ * Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007 by Larry Wall
+ * and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by overload.pl
+ */
+
+enum {
+ fallback_amg,
+ to_sv_amg,
+ to_av_amg,
+ to_hv_amg,
+ to_gv_amg,
+ to_cv_amg,
+ inc_amg,
+ dec_amg,
+ bool__amg,
+ numer_amg,
+ string_amg,
+ not_amg,
+ copy_amg,
+ abs_amg,
+ neg_amg,
+ iter_amg,
+ int_amg,
+ lt_amg,
+ le_amg,
+ gt_amg,
+ ge_amg,
+ eq_amg,
+ ne_amg,
+ slt_amg,
+ sle_amg,
+ sgt_amg,
+ sge_amg,
+ seq_amg,
+ sne_amg,
+ nomethod_amg,
+ add_amg,
+ add_ass_amg,
+ subtr_amg,
+ subtr_ass_amg,
+ mult_amg,
+ mult_ass_amg,
+ div_amg,
+ div_ass_amg,
+ modulo_amg,
+ modulo_ass_amg,
+ pow_amg,
+ pow_ass_amg,
+ lshift_amg,
+ lshift_ass_amg,
+ rshift_amg,
+ rshift_ass_amg,
+ band_amg,
+ band_ass_amg,
+ bor_amg,
+ bor_ass_amg,
+ bxor_amg,
+ bxor_ass_amg,
+ ncmp_amg,
+ scmp_amg,
+ compl_amg,
+ atan2_amg,
+ cos_amg,
+ sin_amg,
+ exp_amg,
+ log_amg,
+ sqrt_amg,
+ repeat_amg,
+ repeat_ass_amg,
+ concat_amg,
+ concat_ass_amg,
+ smart_amg,
+ DESTROY_amg,
+ max_amg_code
+ /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
+};
+
+#define NofAMmeth max_amg_code
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/pad.h b/Master/tlpkg/tlperl.straw/lib/CORE/pad.h
new file mode 100755
index 00000000000..352a592f832
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/pad.h
@@ -0,0 +1,360 @@
+/* pad.h
+ *
+ * Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * This file defines the types and macros associated with the API for
+ * manipulating scratchpads, which are used by perl to store lexical
+ * variables, op targets and constants.
+ */
+
+
+
+
+/* a padlist is currently just an AV; but that might change,
+ * so hide the type. Ditto a pad. */
+
+typedef AV PADLIST;
+typedef AV PAD;
+
+
+/* offsets within a pad */
+
+#if PTRSIZE == 4
+typedef U32TYPE PADOFFSET;
+#else
+# if PTRSIZE == 8
+typedef U64TYPE PADOFFSET;
+# endif
+#endif
+#define NOT_IN_PAD ((PADOFFSET) -1)
+
+/* B.xs needs these for the benefit of B::Deparse */
+/* Low range end is exclusive (valid from the cop seq after this one) */
+/* High range end is inclusive (valid up to this cop seq) */
+
+#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define COP_SEQ_RANGE_LOW(sv) \
+ (({ const SV *const _sv_cop_seq_range_low = (const SV *) (sv); \
+ assert(SvTYPE(_sv_cop_seq_range_low) == SVt_NV \
+ || SvTYPE(_sv_cop_seq_range_low) >= SVt_PVNV); \
+ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVAV); \
+ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVHV); \
+ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVCV); \
+ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVFM); \
+ assert(!isGV_with_GP(_sv_cop_seq_range_low)); \
+ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_cop_seq_range_low)))->xnv_u.xpad_cop_seq.xlow; \
+ }))
+# define COP_SEQ_RANGE_HIGH(sv) \
+ (({ const SV *const _sv_cop_seq_range_high = (const SV *) (sv); \
+ assert(SvTYPE(_sv_cop_seq_range_high) == SVt_NV \
+ || SvTYPE(_sv_cop_seq_range_high) >= SVt_PVNV); \
+ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVAV); \
+ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVHV); \
+ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVCV); \
+ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVFM); \
+ assert(!isGV_with_GP(_sv_cop_seq_range_high)); \
+ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_cop_seq_range_high)))->xnv_u.xpad_cop_seq.xhigh; \
+ }))
+# define PARENT_PAD_INDEX(sv) \
+ (({ const SV *const _sv_parent_pad_index = (const SV *) (sv); \
+ assert(SvTYPE(_sv_parent_pad_index) == SVt_NV \
+ || SvTYPE(_sv_parent_pad_index) >= SVt_PVNV); \
+ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVAV); \
+ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVHV); \
+ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVCV); \
+ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVFM); \
+ assert(!isGV_with_GP(_sv_parent_pad_index)); \
+ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_parent_pad_index)))->xnv_u.xpad_cop_seq.xlow; \
+ }))
+# define PARENT_FAKELEX_FLAGS(sv) \
+ (({ const SV *const _sv_parent_fakelex_flags = (const SV *) (sv); \
+ assert(SvTYPE(_sv_parent_fakelex_flags) == SVt_NV \
+ || SvTYPE(_sv_parent_fakelex_flags) >= SVt_PVNV); \
+ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVAV); \
+ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVHV); \
+ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVCV); \
+ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVFM); \
+ assert(!isGV_with_GP(_sv_parent_fakelex_flags)); \
+ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_parent_fakelex_flags)))->xnv_u.xpad_cop_seq.xhigh; \
+ }))
+#else
+# define COP_SEQ_RANGE_LOW(sv) \
+ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xlow))
+# define COP_SEQ_RANGE_HIGH(sv) \
+ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xhigh))
+
+
+# define PARENT_PAD_INDEX(sv) \
+ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xlow))
+# define PARENT_FAKELEX_FLAGS(sv) \
+ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xhigh))
+#endif
+
+/* Flags set in the SvIVX field of FAKE namesvs */
+
+#define PAD_FAKELEX_ANON 1 /* the lex is declared in an ANON, or ... */
+#define PAD_FAKELEX_MULTI 2 /* the lex can be instantiated multiple times */
+
+/* flags for the pad_new() function */
+
+#define padnew_CLONE 1 /* this pad is for a cloned CV */
+#define padnew_SAVE 2 /* save old globals */
+#define padnew_SAVESUB 4 /* also save extra stuff for start of sub */
+
+/* values for the pad_tidy() function */
+
+typedef enum {
+ padtidy_SUB, /* tidy up a pad for a sub, */
+ padtidy_SUBCLONE, /* a cloned sub, */
+ padtidy_FORMAT /* or a format */
+} padtidy_type;
+
+/* ASSERT_CURPAD_LEGAL and ASSERT_CURPAD_ACTIVE respectively determine
+ * whether PL_comppad and PL_curpad are consistent and whether they have
+ * active values */
+
+#ifndef PERL_MAD
+# define pad_peg(label)
+#endif
+
+#ifdef DEBUGGING
+# define ASSERT_CURPAD_LEGAL(label) \
+ pad_peg(label); \
+ if (PL_comppad ? (AvARRAY(PL_comppad) != PL_curpad) : (PL_curpad != 0)) \
+ Perl_croak(aTHX_ "panic: illegal pad in %s: 0x%"UVxf"[0x%"UVxf"]",\
+ label, PTR2UV(PL_comppad), PTR2UV(PL_curpad));
+
+
+# define ASSERT_CURPAD_ACTIVE(label) \
+ pad_peg(label); \
+ if (!PL_comppad || (AvARRAY(PL_comppad) != PL_curpad)) \
+ Perl_croak(aTHX_ "panic: invalid pad in %s: 0x%"UVxf"[0x%"UVxf"]",\
+ label, PTR2UV(PL_comppad), PTR2UV(PL_curpad));
+#else
+# define ASSERT_CURPAD_LEGAL(label)
+# define ASSERT_CURPAD_ACTIVE(label)
+#endif
+
+
+
+/* Note: the following three macros are actually defined in scope.h, but
+ * they are documented here for completeness, since they directly or
+ * indirectly affect pads.
+
+=for apidoc m|void|SAVEPADSV |PADOFFSET po
+Save a pad slot (used to restore after an iteration)
+
+XXX DAPM it would make more sense to make the arg a PADOFFSET
+=for apidoc m|void|SAVECLEARSV |SV **svp
+Clear the pointed to pad value on scope exit. (i.e. the runtime action of 'my')
+
+=for apidoc m|void|SAVECOMPPAD
+save PL_comppad and PL_curpad
+
+
+
+
+
+=for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv
+Set the slot at offset C<po> in the current pad to C<sv>
+
+=for apidoc m|void|PAD_SV |PADOFFSET po
+Get the value at offset C<po> in the current pad
+
+=for apidoc m|SV *|PAD_SVl |PADOFFSET po
+Lightweight and lvalue version of C<PAD_SV>.
+Get or set the value at offset C<po> in the current pad.
+Unlike C<PAD_SV>, does not print diagnostics with -DX.
+For internal use only.
+
+=for apidoc m|SV *|PAD_BASE_SV |PADLIST padlist|PADOFFSET po
+Get the value from slot C<po> in the base (DEPTH=1) pad of a padlist
+
+=for apidoc m|void|PAD_SET_CUR |PADLIST padlist|I32 n
+Set the current pad to be pad C<n> in the padlist, saving
+the previous current pad. NB currently this macro expands to a string too
+long for some compilers, so it's best to replace it with
+
+ SAVECOMPPAD();
+ PAD_SET_CUR_NOSAVE(padlist,n);
+
+
+=for apidoc m|void|PAD_SET_CUR_NOSAVE |PADLIST padlist|I32 n
+like PAD_SET_CUR, but without the save
+
+=for apidoc m|void|PAD_SAVE_SETNULLPAD
+Save the current pad then set it to null.
+
+=for apidoc m|void|PAD_SAVE_LOCAL|PAD *opad|PAD *npad
+Save the current pad to the local variable opad, then make the
+current pad equal to npad
+
+=for apidoc m|void|PAD_RESTORE_LOCAL|PAD *opad
+Restore the old pad saved into the local variable opad by PAD_SAVE_LOCAL()
+
+=cut
+*/
+
+#ifdef DEBUGGING
+# define PAD_SV(po) pad_sv(po)
+# define PAD_SETSV(po,sv) pad_setsv(po,sv)
+#else
+# define PAD_SV(po) (PL_curpad[po])
+# define PAD_SETSV(po,sv) PL_curpad[po] = (sv)
+#endif
+
+#define PAD_SVl(po) (PL_curpad[po])
+
+#define PAD_BASE_SV(padlist, po) \
+ (AvARRAY(padlist)[1]) \
+ ? AvARRAY(MUTABLE_AV((AvARRAY(padlist)[1])))[po] : NULL;
+
+
+#define PAD_SET_CUR_NOSAVE(padlist,nth) \
+ PL_comppad = (PAD*) (AvARRAY(padlist)[nth]); \
+ PL_curpad = AvARRAY(PL_comppad); \
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log, \
+ "Pad 0x%"UVxf"[0x%"UVxf"] set_cur depth=%d\n", \
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), (int)(nth)));
+
+
+#define PAD_SET_CUR(padlist,nth) \
+ SAVECOMPPAD(); \
+ PAD_SET_CUR_NOSAVE(padlist,nth);
+
+
+#define PAD_SAVE_SETNULLPAD() SAVECOMPPAD(); \
+ PL_comppad = NULL; PL_curpad = NULL; \
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad set_null\n"));
+
+#define PAD_SAVE_LOCAL(opad,npad) \
+ opad = PL_comppad; \
+ PL_comppad = (npad); \
+ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log, \
+ "Pad 0x%"UVxf"[0x%"UVxf"] save_local\n", \
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad)));
+
+#define PAD_RESTORE_LOCAL(opad) \
+ PL_comppad = opad && SvIS_FREED(opad) ? NULL : opad; \
+ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log, \
+ "Pad 0x%"UVxf"[0x%"UVxf"] restore_local\n", \
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad)));
+
+
+/*
+=for apidoc m|void|CX_CURPAD_SAVE|struct context
+Save the current pad in the given context block structure.
+
+=for apidoc m|SV *|CX_CURPAD_SV|struct context|PADOFFSET po
+Access the SV at offset po in the saved current pad in the given
+context block structure (can be used as an lvalue).
+
+=cut
+*/
+
+#define CX_CURPAD_SAVE(block) (block).oldcomppad = PL_comppad
+#define CX_CURPAD_SV(block,po) (AvARRAY(MUTABLE_AV(((block).oldcomppad)))[po])
+
+
+/*
+=for apidoc m|U32|PAD_COMPNAME_FLAGS|PADOFFSET po
+Return the flags for the current compiling pad name
+at offset C<po>. Assumes a valid slot entry.
+
+=for apidoc m|char *|PAD_COMPNAME_PV|PADOFFSET po
+Return the name of the current compiling pad name
+at offset C<po>. Assumes a valid slot entry.
+
+=for apidoc m|HV *|PAD_COMPNAME_TYPE|PADOFFSET po
+Return the type (stash) of the current compiling pad name at offset
+C<po>. Must be a valid name. Returns null if not typed.
+
+=for apidoc m|HV *|PAD_COMPNAME_OURSTASH|PADOFFSET po
+Return the stash associated with an C<our> variable.
+Assumes the slot entry is a valid C<our> lexical.
+
+=for apidoc m|STRLEN|PAD_COMPNAME_GEN|PADOFFSET po
+The generation number of the name at offset C<po> in the current
+compiling pad (lvalue). Note that C<SvUVX> is hijacked for this purpose.
+
+=for apidoc m|STRLEN|PAD_COMPNAME_GEN_set|PADOFFSET po|int gen
+Sets the generation number of the name at offset C<po> in the current
+ling pad (lvalue) to C<gen>. Note that C<SvUV_set> is hijacked for this purpose.
+
+=cut
+
+*/
+
+#define PAD_COMPNAME_SV(po) (*av_fetch(PL_comppad_name, (po), FALSE))
+#define PAD_COMPNAME_FLAGS(po) SvFLAGS(PAD_COMPNAME_SV(po))
+#define PAD_COMPNAME_FLAGS_isOUR(po) \
+ ((PAD_COMPNAME_FLAGS(po) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+#define PAD_COMPNAME_PV(po) SvPV_nolen(PAD_COMPNAME_SV(po))
+
+#define PAD_COMPNAME_TYPE(po) pad_compname_type(po)
+
+#define PAD_COMPNAME_OURSTASH(po) \
+ (SvOURSTASH(PAD_COMPNAME_SV(po)))
+
+#define PAD_COMPNAME_GEN(po) ((STRLEN)SvUVX(AvARRAY(PL_comppad_name)[po]))
+
+#define PAD_COMPNAME_GEN_set(po, gen) SvUV_set(AvARRAY(PL_comppad_name)[po], (UV)(gen))
+
+
+/*
+=for apidoc m|void|PAD_DUP|PADLIST dstpad|PADLIST srcpad|CLONE_PARAMS* param
+Clone a padlist.
+
+=for apidoc m|void|PAD_CLONE_VARS|PerlInterpreter *proto_perl|CLONE_PARAMS* param
+Clone the state variables associated with running and compiling pads.
+
+=cut
+*/
+
+
+#define PAD_DUP(dstpad, srcpad, param) \
+ if ((srcpad) && !AvREAL(srcpad)) { \
+ /* XXX padlists are real, but pretend to be not */ \
+ AvREAL_on(srcpad); \
+ (dstpad) = av_dup_inc((srcpad), param); \
+ AvREAL_off(srcpad); \
+ AvREAL_off(dstpad); \
+ } \
+ else \
+ (dstpad) = av_dup_inc((srcpad), param);
+
+/* NB - we set PL_comppad to null unless it points at a value that
+ * has already been dup'ed, ie it points to part of an active padlist.
+ * Otherwise PL_comppad ends up being a leaked scalar in code like
+ * the following:
+ * threads->create(sub { threads->create(sub {...} ) } );
+ * where the second thread dups the outer sub's comppad but not the
+ * sub's CV or padlist. */
+
+#define PAD_CLONE_VARS(proto_perl, param) \
+ PL_comppad = MUTABLE_AV(ptr_table_fetch(PL_ptr_table, proto_perl->Icomppad)); \
+ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \
+ PL_comppad_name = av_dup(proto_perl->Icomppad_name, param); \
+ PL_comppad_name_fill = proto_perl->Icomppad_name_fill; \
+ PL_comppad_name_floor = proto_perl->Icomppad_name_floor; \
+ PL_min_intro_pending = proto_perl->Imin_intro_pending; \
+ PL_max_intro_pending = proto_perl->Imax_intro_pending; \
+ PL_padix = proto_perl->Ipadix; \
+ PL_padix_floor = proto_perl->Ipadix_floor; \
+ PL_pad_reset_pending = proto_perl->Ipad_reset_pending; \
+ PL_cop_seqmax = proto_perl->Icop_seqmax;
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/parser.h b/Master/tlpkg/tlperl.straw/lib/CORE/parser.h
new file mode 100755
index 00000000000..74d8ef2197b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/parser.h
@@ -0,0 +1,118 @@
+/* parser.h
+ *
+ * Copyright (c) 2006, 2007, 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.
+ *
+ * This file defines the layout of the parser object used by the parser
+ * and lexer (perly.c, toke,c).
+ */
+
+#define YYEMPTY (-2)
+
+typedef struct {
+ YYSTYPE val; /* semantic value */
+ short state;
+ I32 savestack_ix; /* size of savestack at this state */
+ AV *comppad; /* value of PL_comppad when this value was created */
+#ifdef DEBUGGING
+ const char *name; /* token/rule name for -Dpv */
+#endif
+} yy_stack_frame;
+
+typedef struct yy_parser {
+
+ /* parser state */
+
+ struct yy_parser *old_parser; /* previous value of PL_parser */
+ YYSTYPE yylval; /* value of lookahead symbol, set by yylex() */
+ int yychar; /* The lookahead symbol. */
+
+ /* Number of tokens to shift before error messages enabled. */
+ int yyerrstatus;
+
+ int stack_size;
+ int yylen; /* length of active reduction */
+ yy_stack_frame *stack; /* base of stack */
+ yy_stack_frame *ps; /* current stack frame */
+
+ /* lexer state */
+
+ I32 lex_brackets; /* bracket count */
+ I32 lex_casemods; /* casemod count */
+ char *lex_brackstack;/* what kind of brackets to pop */
+ char *lex_casestack; /* what kind of case mods in effect */
+ U8 lex_defer; /* state after determined token */
+ bool lex_dojoin; /* doing an array interpolation */
+ U8 lex_expect; /* expect after determined token */
+ U8 expect; /* how to interpret ambiguous tokens */
+ I32 lex_formbrack; /* bracket count at outer format level */
+ OP *lex_inpat; /* in pattern $) and $| are special */
+ OP *lex_op; /* extra info to pass back on op */
+ SV *lex_repl; /* runtime replacement from s/// */
+ U16 lex_inwhat; /* what kind of quoting are we in */
+ OPCODE last_lop_op; /* last list operator */
+ I32 lex_starts; /* how many interps done on level */
+ SV *lex_stuff; /* runtime pattern from m// or s/// */
+ I32 multi_start; /* 1st line of multi-line string */
+ I32 multi_end; /* last line of multi-line string */
+ char multi_open; /* delimiter of said string */
+ char multi_close; /* delimiter of said string */
+ char pending_ident; /* pending identifier lookup */
+ bool preambled;
+ /* XXX I32 space */
+ SUBLEXINFO sublex_info;
+ SV *linestr; /* current chunk of src text */
+ char *bufptr;
+ char *oldbufptr;
+ char *oldoldbufptr;
+ char *bufend;
+ char *linestart; /* beginning of most recently read line */
+ char *last_uni; /* position of last named-unary op */
+ char *last_lop; /* position of last list operator */
+ line_t copline; /* current line number */
+ U16 in_my; /* we're compiling a "my"/"our" declaration */
+ U8 lex_state; /* next token is determined */
+ U8 error_count; /* how many compile errors so far, max 10 */
+ HV *in_my_stash; /* declared class of this "my" declaration */
+ PerlIO *rsfp; /* current source file pointer */
+ AV *rsfp_filters; /* holds chain of active source filters */
+
+#ifdef PERL_MAD
+ SV *endwhite;
+ I32 faketokens;
+ I32 lasttoke;
+ SV *nextwhite;
+ I32 realtokenstart;
+ SV *skipwhite;
+ SV *thisclose;
+ MADPROP * thismad;
+ SV *thisopen;
+ SV *thisstuff;
+ SV *thistoken;
+ SV *thiswhite;
+
+/* What we know when we're in LEX_KNOWNEXT state. */
+ NEXTTOKE nexttoke[5]; /* value of next token, if any */
+ I32 curforce;
+#else
+ YYSTYPE nextval[5]; /* value of next token, if any */
+ I32 nexttype[5]; /* type of next token */
+ I32 nexttoke;
+#endif
+
+ COP *saved_curcop; /* the previous PL_curcop */
+ char tokenbuf[256];
+
+} yy_parser;
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/patchlevel.h b/Master/tlpkg/tlperl.straw/lib/CORE/patchlevel.h
new file mode 100755
index 00000000000..44424079921
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/patchlevel.h
@@ -0,0 +1,147 @@
+/* patchlevel.h
+ *
+ * Copyright (C) 1993, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+ * 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifndef __PATCHLEVEL_H_INCLUDED__
+
+/* do not adjust the whitespace! Configure expects the numbers to be
+ * exactly on the third column */
+
+#define PERL_REVISION 5 /* age */
+#define PERL_VERSION 10 /* epoch */
+#define PERL_SUBVERSION 1 /* generation */
+
+/* The following numbers describe the earliest compatible version of
+ Perl ("compatibility" here being defined as sufficient binary/API
+ compatibility to run XS code built with the older version).
+ Normally this should not change across maintenance releases.
+
+ Note that this only refers to an out-of-the-box build. Many non-default
+ options such as usemultiplicity tend to break binary compatibility
+ more often.
+
+ This is used by Configure et al to figure out
+ PERL_INC_VERSION_LIST, which lists version libraries
+ to include in @INC. See INSTALL for how this works.
+*/
+#define PERL_API_REVISION 5 /* Adjust manually as needed. */
+#define PERL_API_VERSION 10 /* Adjust manually as needed. */
+#define PERL_API_SUBVERSION 0 /* Adjust manually as needed. */
+/*
+ XXX Note: The selection of non-default Configure options, such
+ as -Duselonglong may invalidate these settings. Currently, Configure
+ does not adequately test for this. A.D. Jan 13, 2000
+*/
+
+#define __PATCHLEVEL_H_INCLUDED__
+#endif
+
+/*
+ local_patches -- list of locally applied less-than-subversion patches.
+ If you're distributing such a patch, please give it a name and a
+ one-line description, placed just before the last NULL in the array
+ below. If your patch fixes a bug in the perlbug database, please
+ mention the bugid. If your patch *IS* dependent on a prior patch,
+ please place your applied patch line after its dependencies. This
+ will help tracking of patch dependencies.
+
+ Please either use 'diff --unified=0' if your diff supports
+ that or edit the hunk of the diff output which adds your patch
+ to this list, to remove context lines which would give patch
+ problems. For instance, if the original context diff is
+
+ *** patchlevel.h.orig <date here>
+ --- patchlevel.h <date here>
+ *** 38,43 ***
+ --- 38,44 ---
+ ,"FOO1235 - some patch"
+ ,"BAR3141 - another patch"
+ ,"BAZ2718 - and another patch"
+ + ,"MINE001 - my new patch"
+ ,NULL
+ };
+
+ please change it to
+ *** patchlevel.h.orig <date here>
+ --- patchlevel.h <date here>
+ *** 41,43 ***
+ --- 41,44 ---
+ + ,"MINE001 - my new patch"
+ ,NULL
+ };
+
+ (Note changes to line numbers as well as removal of context lines.)
+ This will prevent patch from choking if someone has previously
+ applied different patches than you.
+
+ History has shown that nobody distributes patches that also
+ modify patchlevel.h. Do it yourself. The following perl
+ program can be used to add a comment to patchlevel.h:
+
+#!perl
+die "Usage: perl -x patchlevel.h comment ..." unless @ARGV;
+open PLIN, "patchlevel.h" or die "Couldn't open patchlevel.h : $!";
+open PLOUT, ">patchlevel.new" or die "Couldn't write on patchlevel.new : $!";
+my $seen=0;
+while (<PLIN>) {
+ if (/\t,NULL/ and $seen) {
+ while (my $c = shift @ARGV){
+ print PLOUT qq{\t,"$c"\n};
+ }
+ }
+ $seen++ if /local_patches\[\]/;
+ print PLOUT;
+}
+close PLOUT or die "Couldn't close filehandle writing to patchlevel.new : $!";
+close PLIN or die "Couldn't close filehandle reading from patchlevel.h : $!";
+close DATA; # needed to allow unlink to work win32.
+unlink "patchlevel.bak" or warn "Couldn't unlink patchlevel.bak : $!"
+ if -e "patchlevel.bak";
+rename "patchlevel.h", "patchlevel.bak" or
+ die "Couldn't rename patchlevel.h to patchlevel.bak : $!";
+rename "patchlevel.new", "patchlevel.h" or
+ die "Couldn't rename patchlevel.new to patchlevel.h : $!";
+__END__
+
+Please keep empty lines below so that context diffs of this file do
+not ever collect the lines belonging to local_patches() into the same
+hunk.
+
+ */
+
+#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
+# if defined(PERL_IS_MINIPERL)
+# define PERL_PATCHNUM "UNKNOWN-miniperl"
+# define PERL_GIT_UNCOMMITTED_CHANGES ,"UNKNOWN"
+# define PERL_GIT_UNPUSHED_COMMITS /*leave-this-comment*/
+# elif defined(PERL_MICRO)
+# define PERL_PATCHNUM "UNKNOWN-microperl"
+# define PERL_GIT_UNCOMMITTED_CHANGES ,"UNKNOWN"
+# define PERL_GIT_UNPUSHED_COMMITS /*leave-this-comment*/
+# else
+#include "git_version.h"
+# endif
+static const char * const local_patches[] = {
+ NULL
+ PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */
+ PERL_GIT_UNCOMMITTED_CHANGES /* do not remove this line */
+ ,NULL
+};
+
+
+
+/* Initial space prevents this variable from being inserted in config.sh */
+# define LOCAL_PATCH_COUNT \
+ ((int)(sizeof(local_patches)/sizeof(local_patches[0])-2))
+
+/* the old terms of reference, add them only when explicitly included */
+#define PATCHLEVEL PERL_VERSION
+#undef SUBVERSION /* OS/390 has a SUBVERSION in a system header */
+#define SUBVERSION PERL_SUBVERSION
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perl.h b/Master/tlpkg/tlperl.straw/lib/CORE/perl.h
new file mode 100755
index 00000000000..999d5fbc98a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perl.h
@@ -0,0 +1,6090 @@
+/* perl.h
+ *
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifndef H_PERL
+#define H_PERL 1
+
+#ifdef PERL_FOR_X2P
+/*
+ * This file is being used for x2p stuff.
+ * Above symbol is defined via -D in 'x2p/Makefile.SH'
+ * Decouple x2p stuff from some of perls more extreme eccentricities.
+ */
+#undef MULTIPLICITY
+#undef USE_STDIO
+#define USE_STDIO
+#endif /* PERL_FOR_X2P */
+
+#if defined(DGUX)
+#include <sys/fcntl.h>
+#endif
+
+#ifdef VOIDUSED
+# undef VOIDUSED
+#endif
+#define VOIDUSED 1
+
+#ifdef PERL_MICRO
+# include "uconfig.h"
+#else
+# ifndef USE_CROSS_COMPILE
+# include "config.h"
+# else
+# include "xconfig.h"
+# endif
+#endif
+
+/* This logic needs to come after reading config.h, but before including
+ proto.h */
+#ifdef IAMSUID
+# ifndef DOSUID
+# define DOSUID
+# endif
+#endif
+
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+# ifdef DOSUID
+# undef DOSUID
+# endif
+# ifdef IAMSUID
+# undef IAMSUID
+# define SETUID_SCRIPTS_ARE_SECURE_NOW_AND_IAMSUID
+# endif
+#endif
+
+/* See L<perlguts/"The Perl API"> for detailed notes on
+ * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */
+
+/* Note that from here --> to <-- the same logic is
+ * repeated in makedef.pl, so be certain to update
+ * both places when editing. */
+
+#ifdef PERL_IMPLICIT_SYS
+/* PERL_IMPLICIT_SYS implies PerlMemShared != PerlMem
+ so use slab allocator to avoid lots of MUTEX overhead
+ */
+# ifndef PL_OP_SLAB_ALLOC
+# define PL_OP_SLAB_ALLOC
+# endif
+#endif
+
+#ifdef USE_ITHREADS
+# if !defined(MULTIPLICITY)
+# define MULTIPLICITY
+# endif
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# ifndef PERL_GLOBAL_STRUCT
+# define PERL_GLOBAL_STRUCT
+# endif
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT
+# ifndef MULTIPLICITY
+# define MULTIPLICITY
+# endif
+#endif
+
+#ifdef MULTIPLICITY
+# ifndef PERL_IMPLICIT_CONTEXT
+# define PERL_IMPLICIT_CONTEXT
+# endif
+#endif
+
+/* undef WIN32 when building on Cygwin (for libwin32) - gph */
+#ifdef __CYGWIN__
+# undef WIN32
+# undef _WIN32
+#endif
+
+#if defined(__SYMBIAN32__) || (defined(__VC32__) && defined(WINS))
+# ifndef SYMBIAN
+# define SYMBIAN
+# endif
+#endif
+
+#ifdef __SYMBIAN32__
+# include "symbian/symbian_proto.h"
+#endif
+
+/* Any stack-challenged places. The limit varies (and often
+ * is configurable), but using more than a kilobyte of stack
+ * is usually dubious in these systems. */
+#if defined(EPOC) || defined(__SYMBIAN32__)
+/* EPOC/Symbian: need to work around the SDK features. *
+ * On WINS: MS VC5 generates calls to _chkstk, *
+ * if a "large" stack frame is allocated. *
+ * gcc on MARM does not generate calls like these. */
+# define USE_HEAP_INSTEAD_OF_STACK
+#endif
+
+#/* Use the reentrant APIs like localtime_r and getpwent_r */
+/* Win32 has naturally threadsafe libraries, no need to use any _r variants. */
+#if defined(USE_ITHREADS) && !defined(USE_REENTRANT_API) && !defined(NETWARE) && !defined(WIN32) && !defined(PERL_DARWIN)
+# define USE_REENTRANT_API
+#endif
+
+/* <--- here ends the logic shared by perl.h and makedef.pl */
+
+/*
+ * PERL_DARWIN for MacOSX (__APPLE__ exists but is not officially sanctioned)
+ * (The -DPERL_DARWIN comes from the hints/darwin.sh.)
+ * __bsdi__ for BSD/OS
+ */
+#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(PERL_DARWIN) || defined(__bsdi__) || defined(BSD41) || defined(BSD42) || defined(BSD43) || defined(BSD44)
+# ifndef BSDish
+# define BSDish
+# endif
+#endif
+
+#undef START_EXTERN_C
+#undef END_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C extern
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT
+# ifndef PERL_GET_VARS
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ EXTERN_C struct perl_vars* Perl_GetVarsPrivate();
+# define PERL_GET_VARS() Perl_GetVarsPrivate() /* see miniperlmain.c */
+# ifndef PERLIO_FUNCS_CONST
+# define PERLIO_FUNCS_CONST /* Can't have these lying around. */
+# endif
+# else
+# define PERL_GET_VARS() PL_VarsPtr
+# endif
+# endif
+#endif
+
+#define pVAR register struct perl_vars* my_vars PERL_UNUSED_DECL
+
+#ifdef PERL_GLOBAL_STRUCT
+# define dVAR pVAR = (struct perl_vars*)PERL_GET_VARS()
+#else
+# define dVAR dNOOP
+#endif
+
+#ifdef PERL_IMPLICIT_CONTEXT
+# ifndef MULTIPLICITY
+# define MULTIPLICITY
+# endif
+# define tTHX PerlInterpreter*
+# define pTHX register tTHX my_perl PERL_UNUSED_DECL
+# define aTHX my_perl
+# ifdef PERL_GLOBAL_STRUCT
+# define dTHXa(a) dVAR; pTHX = (tTHX)a
+# else
+# define dTHXa(a) pTHX = (tTHX)a
+# endif
+# ifdef PERL_GLOBAL_STRUCT
+# define dTHX dVAR; pTHX = PERL_GET_THX
+# else
+# define dTHX pTHX = PERL_GET_THX
+# endif
+# define pTHX_ pTHX,
+# define aTHX_ aTHX,
+# define pTHX_1 2
+# define pTHX_2 3
+# define pTHX_3 4
+# define pTHX_4 5
+# define pTHX_5 6
+# define pTHX_6 7
+# define pTHX_7 8
+# define pTHX_8 9
+# define pTHX_9 10
+# if defined(DEBUGGING) && !defined(PERL_TRACK_MEMPOOL)
+# define PERL_TRACK_MEMPOOL
+# endif
+#else
+# undef PERL_TRACK_MEMPOOL
+#endif
+
+#define STATIC static
+#define CPERLscope(x) x
+#define CPERLarg void
+#define CPERLarg_
+#define _CPERLarg
+#define PERL_OBJECT_THIS
+#define _PERL_OBJECT_THIS
+#define PERL_OBJECT_THIS_
+#define CALL_FPTR(fptr) (*fptr)
+
+#define CALLRUNOPS CALL_FPTR(PL_runops)
+
+#define CALLREGCOMP(sv, flags) Perl_pregcomp(aTHX_ (sv),(flags))
+
+#define CALLREGCOMP_ENG(prog, sv, flags) \
+ CALL_FPTR(((prog)->comp))(aTHX_ sv, flags)
+#define CALLREGEXEC(prog,stringarg,strend,strbeg,minend,screamer,data,flags) \
+ CALL_FPTR(RX_ENGINE(prog)->exec)(aTHX_ (prog),(stringarg),(strend), \
+ (strbeg),(minend),(screamer),(data),(flags))
+#define CALLREG_INTUIT_START(prog,sv,strpos,strend,flags,data) \
+ CALL_FPTR(RX_ENGINE(prog)->intuit)(aTHX_ (prog), (sv), (strpos), \
+ (strend),(flags),(data))
+#define CALLREG_INTUIT_STRING(prog) \
+ CALL_FPTR(RX_ENGINE(prog)->checkstr)(aTHX_ (prog))
+
+#define CALLREG_AS_STR(mg,lp,flags,haseval) \
+ Perl_reg_stringify(aTHX_ (mg), (lp), (flags), (haseval))
+#define CALLREG_STRINGIFY(mg,lp,flags) CALLREG_AS_STR(mg,lp,flags,0)
+
+#define CALLREGFREE(prog) \
+ Perl_pregfree(aTHX_ (prog))
+
+#define CALLREGFREE_PVT(prog) \
+ if(prog) CALL_FPTR(RX_ENGINE(prog)->free)(aTHX_ (prog))
+
+#define CALLREG_NUMBUF_FETCH(rx,paren,usesv) \
+ CALL_FPTR(RX_ENGINE(rx)->numbered_buff_FETCH)(aTHX_ (rx),(paren),(usesv))
+
+#define CALLREG_NUMBUF_STORE(rx,paren,value) \
+ CALL_FPTR(RX_ENGINE(rx)->numbered_buff_STORE)(aTHX_ (rx),(paren),(value))
+
+#define CALLREG_NUMBUF_LENGTH(rx,sv,paren) \
+ CALL_FPTR(RX_ENGINE(rx)->numbered_buff_LENGTH)(aTHX_ (rx),(sv),(paren))
+
+#define CALLREG_NAMED_BUFF_FETCH(rx, key, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXapif_FETCH))
+
+#define CALLREG_NAMED_BUFF_STORE(rx, key, value, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), (value), ((flags) | RXapif_STORE))
+
+#define CALLREG_NAMED_BUFF_DELETE(rx, key, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx),(key), NULL, ((flags) | RXapif_DELETE))
+
+#define CALLREG_NAMED_BUFF_CLEAR(rx, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_CLEAR))
+
+#define CALLREG_NAMED_BUFF_EXISTS(rx, key, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXapif_EXISTS))
+
+#define CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff_iter)(aTHX_ (rx), NULL, ((flags) | RXapif_FIRSTKEY))
+
+#define CALLREG_NAMED_BUFF_NEXTKEY(rx, lastkey, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff_iter)(aTHX_ (rx), (lastkey), ((flags) | RXapif_NEXTKEY))
+
+#define CALLREG_NAMED_BUFF_SCALAR(rx, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_SCALAR))
+
+#define CALLREG_NAMED_BUFF_COUNT(rx) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, RXapif_REGNAMES_COUNT)
+
+#define CALLREG_NAMED_BUFF_ALL(rx, flags) \
+ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, flags)
+
+#define CALLREG_PACKAGE(rx) \
+ CALL_FPTR(RX_ENGINE(rx)->qr_package)(aTHX_ (rx))
+
+#if defined(USE_ITHREADS)
+#define CALLREGDUPE(prog,param) \
+ Perl_re_dup(aTHX_ (prog),(param))
+
+#define CALLREGDUPE_PVT(prog,param) \
+ (prog ? CALL_FPTR(RX_ENGINE(prog)->dupe)(aTHX_ (prog),(param)) \
+ : (REGEXP *)NULL)
+#endif
+
+
+
+
+
+/*
+ * Because of backward compatibility reasons the PERL_UNUSED_DECL
+ * cannot be changed from postfix to PERL_UNUSED_DECL(x). Sigh.
+ *
+ * Note that there are C compilers such as MetroWerks CodeWarrior
+ * which do not have an "inlined" way (like the gcc __attribute__) of
+ * marking unused variables (they need e.g. a #pragma) and therefore
+ * cpp macros like PERL_UNUSED_DECL cannot work for this purpose, even
+ * if it were PERL_UNUSED_DECL(x), which it cannot be (see above).
+ *
+ */
+
+#if defined(__SYMBIAN32__) && defined(__GNUC__)
+# ifdef __cplusplus
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
+# define PERL_UNUSED_DECL __attribute__unused__
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+
+/* gcc -Wall:
+ * for silencing unused variables that are actually used most of the time,
+ * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs
+ */
+#ifndef PERL_UNUSED_ARG
+# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
+# include <note.h>
+# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
+# else
+# define PERL_UNUSED_ARG(x) ((void)x)
+# endif
+#endif
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(x) ((void)x)
+#endif
+
+#ifdef USE_ITHREADS
+# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
+#else
+# define PERL_UNUSED_CONTEXT
+#endif
+
+#define NOOP /*EMPTY*/(void)0
+#if !defined(HASATTRIBUTE_UNUSED) && defined(__cplusplus)
+#define dNOOP /*EMPTY*/(void)0 /* Older g++ has no __attribute((unused))__ */
+#else
+#define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef pTHX
+/* Don't bother defining tTHX and sTHX; using them outside
+ * code guarded by PERL_IMPLICIT_CONTEXT is an error.
+ */
+# define pTHX void
+# define pTHX_
+# define aTHX
+# define aTHX_
+# define dTHXa(a) dNOOP
+# define dTHX dNOOP
+# define pTHX_1 1
+# define pTHX_2 2
+# define pTHX_3 3
+# define pTHX_4 4
+# define pTHX_5 5
+# define pTHX_6 6
+# define pTHX_7 7
+# define pTHX_8 8
+# define pTHX_9 9
+#endif
+
+#ifndef dVAR
+# define dVAR dNOOP
+#endif
+
+/* these are only defined for compatibility; should not be used internally */
+#if !defined(pTHXo) && !defined(PERL_CORE)
+# define pTHXo pTHX
+# define pTHXo_ pTHX_
+# define aTHXo aTHX
+# define aTHXo_ aTHX_
+# define dTHXo dTHX
+# define dTHXoa(x) dTHXa(x)
+#endif
+
+#ifndef pTHXx
+# define pTHXx register PerlInterpreter *my_perl
+# define pTHXx_ pTHXx,
+# define aTHXx my_perl
+# define aTHXx_ aTHXx,
+# define dTHXx dTHX
+#endif
+
+/* Under PERL_IMPLICIT_SYS (used in Windows for fork emulation)
+ * PerlIO_foo() expands to PL_StdIO->pFOO(PL_StdIO, ...).
+ * dTHXs is therefore needed for all functions using PerlIO_foo(). */
+#ifdef PERL_IMPLICIT_SYS
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# define dTHXs dVAR; dTHX
+# else
+# define dTHXs dTHX
+# endif
+#else
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# define dTHXs dVAR
+# else
+# define dTHXs dNOOP
+# endif
+#endif
+
+/* Some platforms require marking function declarations
+ * for them to be exportable. Used in perlio.h, proto.h
+ * is handled either by the makedef.pl or by defining the
+ * PERL_CALLCONV to be something special. See also the
+ * definition of XS() in XSUB.h. */
+#ifndef PERL_EXPORT_C
+# ifdef __cplusplus
+# define PERL_EXPORT_C extern "C"
+# else
+# define PERL_EXPORT_C extern
+# endif
+#endif
+#ifndef PERL_XS_EXPORT_C
+# ifdef __cplusplus
+# define PERL_XS_EXPORT_C extern "C"
+# else
+# define PERL_XS_EXPORT_C
+# endif
+#endif
+
+#ifdef OP_IN_REGISTER
+# ifdef __GNUC__
+# define stringify_immed(s) #s
+# define stringify(s) stringify_immed(s)
+register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
+# endif
+#endif
+
+/* gcc (-ansi) -pedantic doesn't allow gcc statement expressions,
+ * g++ allows them but seems to have problems with them
+ * (insane errors ensue).
+ * g++ does not give insane errors now (RMB 2008-01-30, gcc 4.2.2).
+ */
+#if defined(PERL_GCC_PEDANTIC) || \
+ (defined(__GNUC__) && defined(__cplusplus) && \
+ ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2))))
+# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# endif
+#endif
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
+# ifndef PERL_USE_GCC_BRACE_GROUPS
+# define PERL_USE_GCC_BRACE_GROUPS
+# endif
+#endif
+
+/*
+ * STMT_START { statements; } STMT_END;
+ * can be used as a single statement, as in
+ * if (x) STMT_START { ... } STMT_END; else ...
+ *
+ * Trying to select a version that gives no warnings...
+ */
+#if !(defined(STMT_START) && defined(STMT_END))
+# ifdef PERL_USE_GCC_BRACE_GROUPS
+# define STMT_START (void)( /* gcc supports "({ STATEMENTS; })" */
+# define STMT_END )
+# else
+ /* Now which other defined()s do we need here ??? */
+# if (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
+# define STMT_START if (1)
+# define STMT_END else (void)0
+# else
+# define STMT_START do
+# define STMT_END while (0)
+# endif
+# endif
+#endif
+
+#define WITH_THX(s) STMT_START { dTHX; s; } STMT_END
+#define WITH_THR(s) WITH_THX(s)
+
+#ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */
+# define BYTEORDER 0x1234
+#endif
+
+/* Overall memory policy? */
+#ifndef CONSERVATIVE
+# define LIBERAL 1
+#endif
+
+#if 'A' == 65 && 'I' == 73 && 'J' == 74 && 'Z' == 90
+#define ASCIIish
+#else
+#undef ASCIIish
+#endif
+
+/*
+ * The following contortions are brought to you on behalf of all the
+ * standards, semi-standards, de facto standards, not-so-de-facto standards
+ * of the world, as well as all the other botches anyone ever thought of.
+ * The basic theory is that if we work hard enough here, the rest of the
+ * code can be a lot prettier. Well, so much for theory. Sorry, Henry...
+ */
+
+/* define this once if either system, instead of cluttering up the src */
+#if defined(MSDOS) || defined(atarist) || defined(WIN32) || defined(NETWARE)
+#define DOSISH 1
+#endif
+
+#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined(EPOC) || defined(NETWARE) || defined(__SYMBIAN32__)
+# define STANDARD_C 1
+#endif
+
+#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(__EMX__) || defined(__DGUX) || defined(EPOC) || defined(__QNX__) || defined(NETWARE) || defined(PERL_MICRO)
+# define DONT_DECLARE_STD 1
+#endif
+
+#if defined(HASVOLATILE) || defined(STANDARD_C)
+# define VOL volatile
+#else
+# define VOL
+#endif
+
+#define TAINT (PL_tainted = TRUE)
+#define TAINT_NOT (PL_tainted = FALSE)
+#define TAINT_IF(c) if (c) { PL_tainted = TRUE; }
+#define TAINT_ENV() if (PL_tainting) { taint_env(); }
+#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(NULL, s); }
+
+/* XXX All process group stuff is handled in pp_sys.c. Should these
+ defines move there? If so, I could simplify this a lot. --AD 9/96.
+*/
+/* Process group stuff changed from traditional BSD to POSIX.
+ perlfunc.pod documents the traditional BSD-style syntax, so we'll
+ try to preserve that, if possible.
+*/
+#ifdef HAS_SETPGID
+# define BSD_SETPGRP(pid, pgrp) setpgid((pid), (pgrp))
+#else
+# if defined(HAS_SETPGRP) && defined(USE_BSD_SETPGRP)
+# define BSD_SETPGRP(pid, pgrp) setpgrp((pid), (pgrp))
+# else
+# ifdef HAS_SETPGRP2 /* DG/UX */
+# define BSD_SETPGRP(pid, pgrp) setpgrp2((pid), (pgrp))
+# endif
+# endif
+#endif
+#if defined(BSD_SETPGRP) && !defined(HAS_SETPGRP)
+# define HAS_SETPGRP /* Well, effectively it does . . . */
+#endif
+
+/* getpgid isn't POSIX, but at least Solaris and Linux have it, and it makes
+ our life easier :-) so we'll try it.
+*/
+#ifdef HAS_GETPGID
+# define BSD_GETPGRP(pid) getpgid((pid))
+#else
+# if defined(HAS_GETPGRP) && defined(USE_BSD_GETPGRP)
+# define BSD_GETPGRP(pid) getpgrp((pid))
+# else
+# ifdef HAS_GETPGRP2 /* DG/UX */
+# define BSD_GETPGRP(pid) getpgrp2((pid))
+# endif
+# endif
+#endif
+#if defined(BSD_GETPGRP) && !defined(HAS_GETPGRP)
+# define HAS_GETPGRP /* Well, effectively it does . . . */
+#endif
+
+/* These are not exact synonyms, since setpgrp() and getpgrp() may
+ have different behaviors, but perl.h used to define USE_BSDPGRP
+ (prior to 5.003_05) so some extension might depend on it.
+*/
+#if defined(USE_BSD_SETPGRP) || defined(USE_BSD_GETPGRP)
+# ifndef USE_BSDPGRP
+# define USE_BSDPGRP
+# endif
+#endif
+
+/* HP-UX 10.X CMA (Common Multithreaded Architecure) insists that
+ pthread.h must be included before all other header files.
+*/
+#if defined(USE_ITHREADS) && defined(PTHREAD_H_FIRST) && defined(I_PTHREAD)
+# include <pthread.h>
+#endif
+
+#ifndef _TYPES_ /* If types.h defines this it's easy. */
+# ifndef major /* Does everyone's types.h define this? */
+# include <sys/types.h>
+# endif
+#endif
+
+#ifdef __cplusplus
+# ifndef I_STDARG
+# define I_STDARG 1
+# endif
+#endif
+
+#ifdef I_STDARG
+# include <stdarg.h>
+#else
+# ifdef I_VARARGS
+# include <varargs.h>
+# endif
+#endif
+
+#ifdef USE_NEXT_CTYPE
+
+#if NX_CURRENT_COMPILER_RELEASE >= 500
+# include <bsd/ctypes.h>
+#else
+# if NX_CURRENT_COMPILER_RELEASE >= 400
+# include <objc/NXCType.h>
+# else /* NX_CURRENT_COMPILER_RELEASE < 400 */
+# include <appkit/NXCType.h>
+# endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
+#endif /* NX_CURRENT_COMPILER_RELEASE >= 500 */
+
+#else /* !USE_NEXT_CTYPE */
+#include <ctype.h>
+#endif /* USE_NEXT_CTYPE */
+
+#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */
+#undef METHOD
+#endif
+
+#ifdef PERL_MICRO
+# define NO_LOCALE
+#endif
+
+#ifdef I_LOCALE
+# include <locale.h>
+#endif
+
+#if !defined(NO_LOCALE) && defined(HAS_SETLOCALE)
+# define USE_LOCALE
+# if !defined(NO_LOCALE_COLLATE) && defined(LC_COLLATE) \
+ && defined(HAS_STRXFRM)
+# define USE_LOCALE_COLLATE
+# endif
+# if !defined(NO_LOCALE_CTYPE) && defined(LC_CTYPE)
+# define USE_LOCALE_CTYPE
+# endif
+# if !defined(NO_LOCALE_NUMERIC) && defined(LC_NUMERIC)
+# define USE_LOCALE_NUMERIC
+# endif
+#endif /* !NO_LOCALE && HAS_SETLOCALE */
+
+#include <setjmp.h>
+
+#ifdef I_SYS_PARAM
+# ifdef PARAM_NEEDS_TYPES
+# include <sys/types.h>
+# endif
+# include <sys/param.h>
+#endif
+
+/* Use all the "standard" definitions? */
+#if defined(STANDARD_C) && defined(I_STDLIB)
+# include <stdlib.h>
+#endif
+
+/* If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+
+/* for WCOREDUMP */
+#ifdef I_SYS_WAIT
+# include <sys/wait.h>
+#endif
+
+#ifdef __SYMBIAN32__
+# undef _SC_ARG_MAX /* Symbian has _SC_ARG_MAX but no sysconf() */
+#endif
+
+#if defined(HAS_SYSCALL) && !defined(HAS_SYSCALL_PROTO) && !defined(PERL_MICRO)
+EXTERN_C int syscall(int, ...);
+#endif
+
+#if defined(HAS_USLEEP) && !defined(HAS_USLEEP_PROTO) && !defined(PERL_MICRO)
+EXTERN_C int usleep(unsigned int);
+#endif
+
+/* Funky places that do not have socket stuff. */
+#if defined(__LIBCATAMOUNT__)
+# define MYSWAP
+#endif
+
+#ifdef PERL_MICRO /* Last chance to export Perl_my_swap */
+# define MYSWAP
+#endif
+
+#ifdef PERL_CORE
+
+/* macros for correct constant construction */
+# if INTSIZE >= 2
+# define U16_CONST(x) ((U16)x##U)
+# else
+# define U16_CONST(x) ((U16)x##UL)
+# endif
+
+# if INTSIZE >= 4
+# define U32_CONST(x) ((U32)x##U)
+# else
+# define U32_CONST(x) ((U32)x##UL)
+# endif
+
+# ifdef HAS_QUAD
+# if INTSIZE >= 8
+# define U64_CONST(x) ((U64)x##U)
+# elif LONGSIZE >= 8
+# define U64_CONST(x) ((U64)x##UL)
+# elif QUADKIND == QUAD_IS_LONG_LONG
+# define U64_CONST(x) ((U64)x##ULL)
+# else /* best guess we can make */
+# define U64_CONST(x) ((U64)x##UL)
+# endif
+# endif
+
+/* byte-swapping functions for big-/little-endian conversion */
+# define _swab_16_(x) ((U16)( \
+ (((U16)(x) & U16_CONST(0x00ff)) << 8) | \
+ (((U16)(x) & U16_CONST(0xff00)) >> 8) ))
+
+# define _swab_32_(x) ((U32)( \
+ (((U32)(x) & U32_CONST(0x000000ff)) << 24) | \
+ (((U32)(x) & U32_CONST(0x0000ff00)) << 8) | \
+ (((U32)(x) & U32_CONST(0x00ff0000)) >> 8) | \
+ (((U32)(x) & U32_CONST(0xff000000)) >> 24) ))
+
+# ifdef HAS_QUAD
+# define _swab_64_(x) ((U64)( \
+ (((U64)(x) & U64_CONST(0x00000000000000ff)) << 56) | \
+ (((U64)(x) & U64_CONST(0x000000000000ff00)) << 40) | \
+ (((U64)(x) & U64_CONST(0x0000000000ff0000)) << 24) | \
+ (((U64)(x) & U64_CONST(0x00000000ff000000)) << 8) | \
+ (((U64)(x) & U64_CONST(0x000000ff00000000)) >> 8) | \
+ (((U64)(x) & U64_CONST(0x0000ff0000000000)) >> 24) | \
+ (((U64)(x) & U64_CONST(0x00ff000000000000)) >> 40) | \
+ (((U64)(x) & U64_CONST(0xff00000000000000)) >> 56) ))
+# endif
+
+/*----------------------------------------------------------------------------*/
+# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
+/*----------------------------------------------------------------------------*/
+# define my_htole16(x) (x)
+# define my_letoh16(x) (x)
+# define my_htole32(x) (x)
+# define my_letoh32(x) (x)
+# define my_htobe16(x) _swab_16_(x)
+# define my_betoh16(x) _swab_16_(x)
+# define my_htobe32(x) _swab_32_(x)
+# define my_betoh32(x) _swab_32_(x)
+# ifdef HAS_QUAD
+# define my_htole64(x) (x)
+# define my_letoh64(x) (x)
+# define my_htobe64(x) _swab_64_(x)
+# define my_betoh64(x) _swab_64_(x)
+# endif
+# define my_htoles(x) (x)
+# define my_letohs(x) (x)
+# define my_htolei(x) (x)
+# define my_letohi(x) (x)
+# define my_htolel(x) (x)
+# define my_letohl(x) (x)
+# if SHORTSIZE == 1
+# define my_htobes(x) (x)
+# define my_betohs(x) (x)
+# elif SHORTSIZE == 2
+# define my_htobes(x) _swab_16_(x)
+# define my_betohs(x) _swab_16_(x)
+# elif SHORTSIZE == 4
+# define my_htobes(x) _swab_32_(x)
+# define my_betohs(x) _swab_32_(x)
+# elif SHORTSIZE == 8
+# define my_htobes(x) _swab_64_(x)
+# define my_betohs(x) _swab_64_(x)
+# else
+# define PERL_NEED_MY_HTOBES
+# define PERL_NEED_MY_BETOHS
+# endif
+# if INTSIZE == 1
+# define my_htobei(x) (x)
+# define my_betohi(x) (x)
+# elif INTSIZE == 2
+# define my_htobei(x) _swab_16_(x)
+# define my_betohi(x) _swab_16_(x)
+# elif INTSIZE == 4
+# define my_htobei(x) _swab_32_(x)
+# define my_betohi(x) _swab_32_(x)
+# elif INTSIZE == 8
+# define my_htobei(x) _swab_64_(x)
+# define my_betohi(x) _swab_64_(x)
+# else
+# define PERL_NEED_MY_HTOBEI
+# define PERL_NEED_MY_BETOHI
+# endif
+# if LONGSIZE == 1
+# define my_htobel(x) (x)
+# define my_betohl(x) (x)
+# elif LONGSIZE == 2
+# define my_htobel(x) _swab_16_(x)
+# define my_betohl(x) _swab_16_(x)
+# elif LONGSIZE == 4
+# define my_htobel(x) _swab_32_(x)
+# define my_betohl(x) _swab_32_(x)
+# elif LONGSIZE == 8
+# define my_htobel(x) _swab_64_(x)
+# define my_betohl(x) _swab_64_(x)
+# else
+# define PERL_NEED_MY_HTOBEL
+# define PERL_NEED_MY_BETOHL
+# endif
+# define my_htolen(p,n) NOOP
+# define my_letohn(p,n) NOOP
+# define my_htoben(p,n) my_swabn(p,n)
+# define my_betohn(p,n) my_swabn(p,n)
+/*----------------------------------------------------------------------------*/
+# elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
+/*----------------------------------------------------------------------------*/
+# define my_htobe16(x) (x)
+# define my_betoh16(x) (x)
+# define my_htobe32(x) (x)
+# define my_betoh32(x) (x)
+# define my_htole16(x) _swab_16_(x)
+# define my_letoh16(x) _swab_16_(x)
+# define my_htole32(x) _swab_32_(x)
+# define my_letoh32(x) _swab_32_(x)
+# ifdef HAS_QUAD
+# define my_htobe64(x) (x)
+# define my_betoh64(x) (x)
+# define my_htole64(x) _swab_64_(x)
+# define my_letoh64(x) _swab_64_(x)
+# endif
+# define my_htobes(x) (x)
+# define my_betohs(x) (x)
+# define my_htobei(x) (x)
+# define my_betohi(x) (x)
+# define my_htobel(x) (x)
+# define my_betohl(x) (x)
+# if SHORTSIZE == 1
+# define my_htoles(x) (x)
+# define my_letohs(x) (x)
+# elif SHORTSIZE == 2
+# define my_htoles(x) _swab_16_(x)
+# define my_letohs(x) _swab_16_(x)
+# elif SHORTSIZE == 4
+# define my_htoles(x) _swab_32_(x)
+# define my_letohs(x) _swab_32_(x)
+# elif SHORTSIZE == 8
+# define my_htoles(x) _swab_64_(x)
+# define my_letohs(x) _swab_64_(x)
+# else
+# define PERL_NEED_MY_HTOLES
+# define PERL_NEED_MY_LETOHS
+# endif
+# if INTSIZE == 1
+# define my_htolei(x) (x)
+# define my_letohi(x) (x)
+# elif INTSIZE == 2
+# define my_htolei(x) _swab_16_(x)
+# define my_letohi(x) _swab_16_(x)
+# elif INTSIZE == 4
+# define my_htolei(x) _swab_32_(x)
+# define my_letohi(x) _swab_32_(x)
+# elif INTSIZE == 8
+# define my_htolei(x) _swab_64_(x)
+# define my_letohi(x) _swab_64_(x)
+# else
+# define PERL_NEED_MY_HTOLEI
+# define PERL_NEED_MY_LETOHI
+# endif
+# if LONGSIZE == 1
+# define my_htolel(x) (x)
+# define my_letohl(x) (x)
+# elif LONGSIZE == 2
+# define my_htolel(x) _swab_16_(x)
+# define my_letohl(x) _swab_16_(x)
+# elif LONGSIZE == 4
+# define my_htolel(x) _swab_32_(x)
+# define my_letohl(x) _swab_32_(x)
+# elif LONGSIZE == 8
+# define my_htolel(x) _swab_64_(x)
+# define my_letohl(x) _swab_64_(x)
+# else
+# define PERL_NEED_MY_HTOLEL
+# define PERL_NEED_MY_LETOHL
+# endif
+# define my_htolen(p,n) my_swabn(p,n)
+# define my_letohn(p,n) my_swabn(p,n)
+# define my_htoben(p,n) NOOP
+# define my_betohn(p,n) NOOP
+/*----------------------------------------------------------------------------*/
+# else /* all other byte-orders */
+/*----------------------------------------------------------------------------*/
+# define PERL_NEED_MY_HTOLE16
+# define PERL_NEED_MY_LETOH16
+# define PERL_NEED_MY_HTOBE16
+# define PERL_NEED_MY_BETOH16
+# define PERL_NEED_MY_HTOLE32
+# define PERL_NEED_MY_LETOH32
+# define PERL_NEED_MY_HTOBE32
+# define PERL_NEED_MY_BETOH32
+# ifdef HAS_QUAD
+# define PERL_NEED_MY_HTOLE64
+# define PERL_NEED_MY_LETOH64
+# define PERL_NEED_MY_HTOBE64
+# define PERL_NEED_MY_BETOH64
+# endif
+# define PERL_NEED_MY_HTOLES
+# define PERL_NEED_MY_LETOHS
+# define PERL_NEED_MY_HTOBES
+# define PERL_NEED_MY_BETOHS
+# define PERL_NEED_MY_HTOLEI
+# define PERL_NEED_MY_LETOHI
+# define PERL_NEED_MY_HTOBEI
+# define PERL_NEED_MY_BETOHI
+# define PERL_NEED_MY_HTOLEL
+# define PERL_NEED_MY_LETOHL
+# define PERL_NEED_MY_HTOBEL
+# define PERL_NEED_MY_BETOHL
+/*----------------------------------------------------------------------------*/
+# endif /* end of byte-order macros */
+/*----------------------------------------------------------------------------*/
+
+/* The old value was hard coded at 1008. (4096-16) seems to be a bit faster,
+ at least on FreeBSD. YMMV, so experiment. */
+#ifndef PERL_ARENA_SIZE
+#define PERL_ARENA_SIZE 4080
+#endif
+
+/* Maximum level of recursion */
+#ifndef PERL_SUB_DEPTH_WARN
+#define PERL_SUB_DEPTH_WARN 100
+#endif
+
+#endif /* PERL_CORE */
+
+/* We no longer default to creating a new SV for GvSV.
+ Do this before embed. */
+#ifndef PERL_CREATE_GVSV
+# ifndef PERL_DONT_CREATE_GVSV
+# define PERL_DONT_CREATE_GVSV
+# endif
+#endif
+
+#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#define PERL_USES_PL_PIDSTATUS
+#endif
+
+#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(__SYMBIAN32__) && !defined(MACOS_TRADITIONAL)
+#define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+#endif
+
+/* Cannot include embed.h here on Win32 as win32.h has not
+ yet been included and defines some config variables e.g. HAVE_INTERP_INTERN
+ */
+#if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS))
+# include "embed.h"
+# ifndef PERL_MAD
+# undef op_getmad
+# define op_getmad(arg,pegop,slot) NOOP
+# endif
+#endif
+
+#define MEM_SIZE Size_t
+
+/* Round all values passed to malloc up, by default to a multiple of
+ sizeof(size_t)
+*/
+#ifndef PERL_STRLEN_ROUNDUP_QUANTUM
+#define PERL_STRLEN_ROUNDUP_QUANTUM Size_t_size
+#endif
+
+#if defined(STANDARD_C) && defined(I_STDDEF)
+# include <stddef.h>
+# define STRUCT_OFFSET(s,m) offsetof(s,m)
+#else
+# define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m))
+#endif
+
+#ifndef __SYMBIAN32__
+# if defined(I_STRING) || defined(__cplusplus)
+# include <string.h>
+# else
+# include <strings.h>
+# endif
+#endif
+
+/* This comes after <stdlib.h> so we don't try to change the standard
+ * library prototypes; we'll use our own in proto.h instead. */
+
+#ifdef MYMALLOC
+# ifdef PERL_POLLUTE_MALLOC
+# ifndef PERL_EXTMALLOC_DEF
+# define Perl_malloc malloc
+# define Perl_calloc calloc
+# define Perl_realloc realloc
+# define Perl_mfree free
+# endif
+# else
+# define EMBEDMYMALLOC /* for compatibility */
+# endif
+
+# define safemalloc Perl_malloc
+# define safecalloc Perl_calloc
+# define saferealloc Perl_realloc
+# define safefree Perl_mfree
+# define CHECK_MALLOC_TOO_LATE_FOR_(code) STMT_START { \
+ if (!PL_tainting && MallocCfg_ptr[MallocCfg_cfg_env_read]) \
+ code; \
+ } STMT_END
+# define CHECK_MALLOC_TOO_LATE_FOR(ch) \
+ CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch))
+# define panic_write2(s) write(2, s, strlen(s))
+# define CHECK_MALLOC_TAINT(newval) \
+ CHECK_MALLOC_TOO_LATE_FOR_( \
+ if (newval) { \
+ panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n");\
+ exit(1); })
+# define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \
+ if (doing_taint(argc,argv,env)) { \
+ MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \
+ }} STMT_END;
+#else /* MYMALLOC */
+# define safemalloc safesysmalloc
+# define safecalloc safesyscalloc
+# define saferealloc safesysrealloc
+# define safefree safesysfree
+# define CHECK_MALLOC_TOO_LATE_FOR(ch) ((void)0)
+# define CHECK_MALLOC_TAINT(newval) ((void)0)
+# define MALLOC_CHECK_TAINT(argc,argv,env)
+#endif /* MYMALLOC */
+
+#define TOO_LATE_FOR_(ch,what) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line%s", (char)(ch), what)
+#define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "")
+#define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}")
+#define MALLOC_CHECK_TAINT2(argc,argv) MALLOC_CHECK_TAINT(argc,argv,NULL)
+
+#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr)
+#define strchr index
+#define strrchr rindex
+#endif
+
+#ifdef I_MEMORY
+# include <memory.h>
+#endif
+
+#ifdef HAS_MEMCPY
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memcpy
+ extern char * memcpy (char*, char*, int);
+# endif
+# endif
+#else
+# ifndef memcpy
+# ifdef HAS_BCOPY
+# define memcpy(d,s,l) bcopy(s,d,l)
+# else
+# define memcpy(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
+#endif /* HAS_MEMCPY */
+
+#ifdef HAS_MEMSET
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memset
+ extern char *memset (char*, int, int);
+# endif
+# endif
+#else
+# undef memset
+# define memset(d,c,l) my_memset(d,c,l)
+#endif /* HAS_MEMSET */
+
+#if !defined(HAS_MEMMOVE) && !defined(memmove)
+# if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
+# define memmove(d,s,l) bcopy(s,d,l)
+# else
+# if defined(HAS_MEMCPY) && defined(HAS_SAFE_MEMCPY)
+# define memmove(d,s,l) memcpy(d,s,l)
+# else
+# define memmove(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
+#endif
+
+#if defined(mips) && defined(ultrix) && !defined(__STDC__)
+# undef HAS_MEMCMP
+#endif
+
+#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP)
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memcmp
+ extern int memcmp (char*, char*, int);
+# endif
+# endif
+# ifdef BUGGY_MSC
+# pragma function(memcmp)
+# endif
+#else
+# ifndef memcmp
+# define memcmp my_memcmp
+# endif
+#endif /* HAS_MEMCMP && HAS_SANE_MEMCMP */
+
+#ifndef memzero
+# ifdef HAS_MEMSET
+# define memzero(d,l) memset(d,0,l)
+# else
+# ifdef HAS_BZERO
+# define memzero(d,l) bzero(d,l)
+# else
+# define memzero(d,l) my_bzero(d,l)
+# endif
+# endif
+#endif
+
+#ifndef PERL_MICRO
+#ifndef memchr
+# ifndef HAS_MEMCHR
+# define memchr(s,c,n) ninstr((char*)(s), ((char*)(s)) + n, &(c), &(c) + 1)
+# endif
+#endif
+#endif
+
+#ifndef HAS_BCMP
+# ifndef bcmp
+# define bcmp(s1,s2,l) memcmp(s1,s2,l)
+# endif
+#endif /* !HAS_BCMP */
+
+#ifdef I_NETINET_IN
+# include <netinet/in.h>
+#endif
+
+#ifdef I_ARPA_INET
+# include <arpa/inet.h>
+#endif
+
+#if defined(SF_APPEND) && defined(USE_SFIO) && defined(I_SFIO)
+/* <sfio.h> defines SF_APPEND and <sys/stat.h> might define SF_APPEND
+ * (the neo-BSD seem to do this). */
+# undef SF_APPEND
+#endif
+
+#ifdef I_SYS_STAT
+# include <sys/stat.h>
+#endif
+
+/* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives
+ like UTekV) are broken, sometimes giving false positives. Undefine
+ them here and let the code below set them to proper values.
+
+ The ghs macro stands for GreenHills Software C-1.8.5 which
+ is the C compiler for sysV88 and the various derivatives.
+ This header file bug is corrected in gcc-2.5.8 and later versions.
+ --Kaveh Ghazi (ghazi@noc.rutgers.edu) 10/3/94. */
+
+#if defined(uts) || (defined(m88k) && defined(ghs))
+# undef S_ISDIR
+# undef S_ISCHR
+# undef S_ISBLK
+# undef S_ISREG
+# undef S_ISFIFO
+# undef S_ISLNK
+#endif
+
+#ifdef I_TIME
+# include <time.h>
+#endif
+
+#ifdef I_SYS_TIME
+# ifdef I_SYS_TIME_KERNEL
+# define KERNEL
+# endif
+# include <sys/time.h>
+# ifdef I_SYS_TIME_KERNEL
+# undef KERNEL
+# endif
+#endif
+
+#if defined(HAS_TIMES) && defined(I_SYS_TIMES)
+# include <sys/times.h>
+#endif
+
+#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
+# undef HAS_STRERROR
+#endif
+
+#include <errno.h>
+
+#if defined(WIN32) && defined(PERL_IMPLICIT_SYS)
+# define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */
+#endif
+
+/* In Tru64 use the 4.4BSD struct msghdr, not the 4.3 one.
+ * This is important for using IPv6.
+ * For OSF/1 3.2, however, defining _SOCKADDR_LEN would be
+ * a bad idea since it breaks send() and recv(). */
+#if defined(__osf__) && defined(__alpha) && !defined(_SOCKADDR_LEN) && !defined(DEC_OSF1_3_X)
+# define _SOCKADDR_LEN
+#endif
+
+#if defined(HAS_SOCKET) && !defined(VMS) && !defined(WIN32) /* VMS/WIN32 handle sockets via vmsish.h/win32.h */
+# include <sys/socket.h>
+# if defined(USE_SOCKS) && defined(I_SOCKS)
+# if !defined(INCLUDE_PROTOTYPES)
+# define INCLUDE_PROTOTYPES /* for <socks.h> */
+# define PERL_SOCKS_NEED_PROTOTYPES
+# endif
+# include <socks.h>
+# ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */
+# undef INCLUDE_PROTOTYPES
+# undef PERL_SOCKS_NEED_PROTOTYPES
+# endif
+# endif
+# ifdef I_NETDB
+# ifdef NETWARE
+# include<stdio.h>
+# endif
+# include <netdb.h>
+# endif
+# ifndef ENOTSOCK
+# ifdef I_NET_ERRNO
+# include <net/errno.h>
+# endif
+# endif
+#endif
+
+/* sockatmark() is so new (2001) that many places might have it hidden
+ * behind some -D_BLAH_BLAH_SOURCE guard. The __THROW magic is required
+ * e.g. in Gentoo, see http://bugs.gentoo.org/show_bug.cgi?id=12605 */
+#if defined(HAS_SOCKATMARK) && !defined(HAS_SOCKATMARK_PROTO)
+# if defined(__THROW) && defined(__GLIBC__)
+int sockatmark(int) __THROW;
+# else
+int sockatmark(int);
+# endif
+#endif
+
+#if defined(__osf__) && defined(__cplusplus) && !defined(_XOPEN_SOURCE_EXTENDED) /* Tru64 "cxx" (C++), see hints/dec_osf.sh for why the _XOPEN_SOURCE_EXTENDED cannot be defined. */
+EXTERN_C int fchdir(int);
+EXTERN_C int flock(int, int);
+EXTERN_C int fseeko(FILE *, off_t, int);
+EXTERN_C off_t ftello(FILE *);
+#endif
+
+#if defined(__SUNPRO_CC) /* SUNWspro CC (C++) */
+EXTERN_C char *crypt(const char *, const char *);
+EXTERN_C char **environ;
+#endif
+
+#if defined(__cplusplus)
+# if defined(__OpenBSD__) || defined(__FreeBSD__) || defined(__NetBSD__)
+EXTERN_C char **environ;
+# elif defined(__CYGWIN__)
+EXTERN_C char *crypt(const char *, const char *);
+#endif
+#endif
+
+#ifdef SETERRNO
+# undef SETERRNO /* SOCKS might have defined this */
+#endif
+
+#ifdef VMS
+# define SETERRNO(errcode,vmserrcode) \
+ STMT_START { \
+ set_errno(errcode); \
+ set_vaxc_errno(vmserrcode); \
+ } STMT_END
+# define dSAVEDERRNO int saved_errno; unsigned saved_vms_errno
+# define dSAVE_ERRNO int saved_errno = errno; unsigned saved_vms_errno = vaxc$errno
+# define SAVE_ERRNO ( saved_errno = errno, saved_vms_errno = vaxc$errno )
+# define RESTORE_ERRNO SETERRNO(saved_errno, saved_vms_errno)
+
+# define LIB_INVARG LIB$_INVARG
+# define RMS_DIR RMS$_DIR
+# define RMS_FAC RMS$_FAC
+# define RMS_FEX RMS$_FEX
+# define RMS_FNF RMS$_FNF
+# define RMS_IFI RMS$_IFI
+# define RMS_ISI RMS$_ISI
+# define RMS_PRV RMS$_PRV
+# define SS_ACCVIO SS$_ACCVIO
+# define SS_DEVOFFLINE SS$_DEVOFFLINE
+# define SS_IVCHAN SS$_IVCHAN
+# define SS_NORMAL SS$_NORMAL
+#else
+# define SETERRNO(errcode,vmserrcode) (errno = (errcode))
+# define dSAVEDERRNO int saved_errno
+# define dSAVE_ERRNO int saved_errno = errno
+# define SAVE_ERRNO (saved_errno = errno)
+# define RESTORE_ERRNO (errno = saved_errno)
+
+# define LIB_INVARG 0
+# define RMS_DIR 0
+# define RMS_FAC 0
+# define RMS_FEX 0
+# define RMS_FNF 0
+# define RMS_IFI 0
+# define RMS_ISI 0
+# define RMS_PRV 0
+# define SS_ACCVIO 0
+# define SS_DEVOFFLINE 0
+# define SS_IVCHAN 0
+# define SS_NORMAL 0
+#endif
+
+#define ERRSV GvSV(PL_errgv)
+#ifdef PERL_CORE
+# define DEFSV (0 + GvSVn(PL_defgv))
+#else
+# define DEFSV GvSVn(PL_defgv)
+#endif
+#define DEFSV_set(sv) (GvSV(PL_defgv) = (sv))
+#define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+
+#define ERRHV GvHV(PL_errgv) /* XXX unused, here for compatibility */
+
+#ifndef errno
+ extern int errno; /* ANSI allows errno to be an lvalue expr.
+ * For example in multithreaded environments
+ * something like this might happen:
+ * extern int *_errno(void);
+ * #define errno (*_errno()) */
+#endif
+
+#ifdef HAS_STRERROR
+# ifdef VMS
+ char *strerror (int,...);
+# else
+#ifndef DONT_DECLARE_STD
+ char *strerror (int);
+#endif
+# endif
+# ifndef Strerror
+# define Strerror strerror
+# endif
+#else
+# ifdef HAS_SYS_ERRLIST
+ extern int sys_nerr;
+ extern char *sys_errlist[];
+# ifndef Strerror
+# define Strerror(e) \
+ ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e])
+# endif
+# endif
+#endif
+
+#ifdef I_SYS_IOCTL
+# ifndef _IOCTL_
+# include <sys/ioctl.h>
+# endif
+#endif
+
+#if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000)
+# ifdef HAS_SOCKETPAIR
+# undef HAS_SOCKETPAIR
+# endif
+# ifdef I_NDBM
+# undef I_NDBM
+# endif
+#endif
+
+#ifndef HAS_SOCKETPAIR
+# ifdef HAS_SOCKET
+# define socketpair Perl_my_socketpair
+# endif
+#endif
+
+#if INTSIZE == 2
+# define htoni htons
+# define ntohi ntohs
+#else
+# define htoni htonl
+# define ntohi ntohl
+#endif
+
+/* Configure already sets Direntry_t */
+#if defined(I_DIRENT)
+# include <dirent.h>
+ /* NeXT needs dirent + sys/dir.h */
+# if defined(I_SYS_DIR) && (defined(NeXT) || defined(__NeXT__))
+# include <sys/dir.h>
+# endif
+#else
+# ifdef I_SYS_NDIR
+# include <sys/ndir.h>
+# else
+# ifdef I_SYS_DIR
+# ifdef hp9000s500
+# include <ndir.h> /* may be wrong in the future */
+# else
+# include <sys/dir.h>
+# endif
+# endif
+# endif
+#endif
+
+#ifdef PERL_MICRO
+# ifndef DIR
+# define DIR void
+# endif
+#endif
+
+#ifdef FPUTS_BOTCH
+/* work around botch in SunOS 4.0.1 and 4.0.2 */
+# ifndef fputs
+# define fputs(sv,fp) fprintf(fp,"%s",sv)
+# endif
+#endif
+
+/*
+ * The following gobbledygook brought to you on behalf of __STDC__.
+ * (I could just use #ifndef __STDC__, but this is more bulletproof
+ * in the face of half-implementations.)
+ */
+
+#if defined(I_SYSMODE) && !defined(PERL_MICRO)
+#include <sys/mode.h>
+#endif
+
+#ifndef S_IFMT
+# ifdef _S_IFMT
+# define S_IFMT _S_IFMT
+# else
+# define S_IFMT 0170000
+# endif
+#endif
+
+#ifndef S_ISDIR
+# define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR)
+#endif
+
+#ifndef S_ISCHR
+# define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR)
+#endif
+
+#ifndef S_ISBLK
+# ifdef S_IFBLK
+# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK)
+# else
+# define S_ISBLK(m) (0)
+# endif
+#endif
+
+#ifndef S_ISREG
+# define S_ISREG(m) ((m & S_IFMT) == S_IFREG)
+#endif
+
+#ifndef S_ISFIFO
+# ifdef S_IFIFO
+# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO)
+# else
+# define S_ISFIFO(m) (0)
+# endif
+#endif
+
+#ifndef S_ISLNK
+# ifdef _S_ISLNK
+# define S_ISLNK(m) _S_ISLNK(m)
+# else
+# ifdef _S_IFLNK
+# define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK)
+# else
+# ifdef S_IFLNK
+# define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK)
+# else
+# define S_ISLNK(m) (0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef S_ISSOCK
+# ifdef _S_ISSOCK
+# define S_ISSOCK(m) _S_ISSOCK(m)
+# else
+# ifdef _S_IFSOCK
+# define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK)
+# else
+# ifdef S_IFSOCK
+# define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK)
+# else
+# define S_ISSOCK(m) (0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef S_IRUSR
+# ifdef S_IREAD
+# define S_IRUSR S_IREAD
+# define S_IWUSR S_IWRITE
+# define S_IXUSR S_IEXEC
+# else
+# define S_IRUSR 0400
+# define S_IWUSR 0200
+# define S_IXUSR 0100
+# endif
+#endif
+
+#ifndef S_IRGRP
+# ifdef S_IRUSR
+# define S_IRGRP (S_IRUSR>>3)
+# define S_IWGRP (S_IWUSR>>3)
+# define S_IXGRP (S_IXUSR>>3)
+# else
+# define S_IRGRP 0040
+# define S_IWGRP 0020
+# define S_IXGRP 0010
+# endif
+#endif
+
+#ifndef S_IROTH
+# ifdef S_IRUSR
+# define S_IROTH (S_IRUSR>>6)
+# define S_IWOTH (S_IWUSR>>6)
+# define S_IXOTH (S_IXUSR>>6)
+# else
+# define S_IROTH 0040
+# define S_IWOTH 0020
+# define S_IXOTH 0010
+# endif
+#endif
+
+#ifndef S_ISUID
+# define S_ISUID 04000
+#endif
+
+#ifndef S_ISGID
+# define S_ISGID 02000
+#endif
+
+#ifndef S_IRWXU
+# define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR)
+#endif
+
+#ifndef S_IRWXG
+# define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP)
+#endif
+
+#ifndef S_IRWXO
+# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH)
+#endif
+
+/* BeOS 5.0 and Haiku R1 seem to define S_IREAD and S_IWRITE in <posix/fcntl.h>
+ * which would get included through <sys/file.h >, but that is 3000
+ * lines in the future. --jhi */
+
+#if !defined(S_IREAD) && !(defined(__BEOS__) || defined(__HAIKU__))
+# define S_IREAD S_IRUSR
+#endif
+
+#if !defined(S_IWRITE) && !(defined(__BEOS__) || defined(__HAIKU__))
+# define S_IWRITE S_IWUSR
+#endif
+
+#ifndef S_IEXEC
+# define S_IEXEC S_IXUSR
+#endif
+
+#ifdef ff_next
+# undef ff_next
+#endif
+
+#if defined(cray) || defined(gould) || defined(i860) || defined(pyr)
+# define SLOPPYDIVIDE
+#endif
+
+#ifdef UV
+#undef UV
+#endif
+
+#ifdef SPRINTF_E_BUG
+# define sprintf UTS_sprintf_wrap
+#endif
+
+/* For the times when you want the return value of sprintf, and you want it
+ to be the length. Can't have a thread variable passed in, because C89 has
+ no varargs macros.
+*/
+#ifdef SPRINTF_RETURNS_STRLEN
+# define my_sprintf sprintf
+#else
+# define my_sprintf Perl_my_sprintf
+#endif
+
+/*
+ * If we have v?snprintf() and the C99 variadic macros, we can just
+ * use just the v?snprintf(). It is nice to try to trap the buffer
+ * overflow, however, so if we are DEBUGGING, and we cannot use the
+ * gcc statement expressions, then use the function wrappers which try
+ * to trap the overflow. If we can use the gcc statement expressions,
+ * we can try that even with the version that uses the C99 variadic
+ * macros.
+ */
+
+/* Note that we do not check against snprintf()/vsnprintf() returning
+ * negative values because that is non-standard behaviour and we use
+ * snprintf/vsnprintf only iff HAS_VSNPRINTF has been defined, and
+ * that should be true only if the snprintf()/vsnprintf() are true
+ * to the standard. */
+
+#if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
+# ifdef PERL_USE_GCC_BRACE_GROUPS
+# define my_snprintf(buffer, len, ...) ({ int __len__ = snprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak_nocontext("panic: snprintf buffer overflow"); __len__; })
+# define PERL_MY_SNPRINTF_GUARDED
+# else
+# define my_snprintf(buffer, len, ...) snprintf(buffer, len, __VA_ARGS__)
+# endif
+#else
+# define my_snprintf Perl_my_snprintf
+# define PERL_MY_SNPRINTF_GUARDED
+#endif
+
+#if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
+# ifdef PERL_USE_GCC_BRACE_GROUPS
+# define my_vsnprintf(buffer, len, ...) ({ int __len__ = vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak_nocontext("panic: vsnprintf buffer overflow"); __len__; })
+# define PERL_MY_VSNPRINTF_GUARDED
+# else
+# define my_vsnprintf(buffer, len, ...) vsnprintf(buffer, len, __VA_ARGS__)
+# endif
+#else
+# define my_vsnprintf Perl_my_vsnprintf
+# define PERL_MY_VSNPRINTF_GUARDED
+#endif
+
+#ifdef HAS_STRLCAT
+# define my_strlcat strlcat
+#else
+# define my_strlcat Perl_my_strlcat
+#endif
+
+#ifdef HAS_STRLCPY
+# define my_strlcpy strlcpy
+#else
+# define my_strlcpy Perl_my_strlcpy
+#endif
+
+/* Configure gets this right but the UTS compiler gets it wrong.
+ -- Hal Morris <hom00@utsglobal.com> */
+#ifdef UTS
+# undef UVTYPE
+# define UVTYPE unsigned
+#endif
+
+/*
+ The IV type is supposed to be long enough to hold any integral
+ value or a pointer.
+ --Andy Dougherty August 1996
+*/
+
+typedef IVTYPE IV;
+typedef UVTYPE UV;
+
+#if defined(USE_64_BIT_INT) && defined(HAS_QUAD)
+# if QUADKIND == QUAD_IS_INT64_T && defined(INT64_MAX)
+# define IV_MAX INT64_MAX
+# define IV_MIN INT64_MIN
+# define UV_MAX UINT64_MAX
+# ifndef UINT64_MIN
+# define UINT64_MIN 0
+# endif
+# define UV_MIN UINT64_MIN
+# else
+# define IV_MAX PERL_QUAD_MAX
+# define IV_MIN PERL_QUAD_MIN
+# define UV_MAX PERL_UQUAD_MAX
+# define UV_MIN PERL_UQUAD_MIN
+# endif
+# define IV_IS_QUAD
+# define UV_IS_QUAD
+#else
+# if defined(INT32_MAX) && IVSIZE == 4
+# define IV_MAX INT32_MAX
+# define IV_MIN INT32_MIN
+# ifndef UINT32_MAX_BROKEN /* e.g. HP-UX with gcc messes this up */
+# define UV_MAX UINT32_MAX
+# else
+# define UV_MAX 4294967295U
+# endif
+# ifndef UINT32_MIN
+# define UINT32_MIN 0
+# endif
+# define UV_MIN UINT32_MIN
+# else
+# define IV_MAX PERL_LONG_MAX
+# define IV_MIN PERL_LONG_MIN
+# define UV_MAX PERL_ULONG_MAX
+# define UV_MIN PERL_ULONG_MIN
+# endif
+# if IVSIZE == 8
+# define IV_IS_QUAD
+# define UV_IS_QUAD
+# ifndef HAS_QUAD
+# define HAS_QUAD
+# endif
+# else
+# undef IV_IS_QUAD
+# undef UV_IS_QUAD
+# undef HAS_QUAD
+# endif
+#endif
+
+#ifndef HAS_QUAD
+# undef PERL_NEED_MY_HTOLE64
+# undef PERL_NEED_MY_LETOH64
+# undef PERL_NEED_MY_HTOBE64
+# undef PERL_NEED_MY_BETOH64
+#endif
+
+#if defined(uts) || defined(UTS)
+# undef UV_MAX
+# define UV_MAX (4294967295u)
+#endif
+
+#define IV_DIG (BIT_DIGITS(IVSIZE * 8))
+#define UV_DIG (BIT_DIGITS(UVSIZE * 8))
+
+#ifndef NO_PERL_PRESERVE_IVUV
+#define PERL_PRESERVE_IVUV /* We like our integers to stay integers. */
+#endif
+
+/*
+ * The macros INT2PTR and NUM2PTR are (despite their names)
+ * bi-directional: they will convert int/float to or from pointers.
+ * However the conversion to int/float are named explicitly:
+ * PTR2IV, PTR2UV, PTR2NV.
+ *
+ * For int conversions we do not need two casts if pointers are
+ * the same size as IV and UV. Otherwise we need an explicit
+ * cast (PTRV) to avoid compiler warnings.
+ */
+#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+#else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# define PTR2ul(p) (unsigned long)(p)
+# else
+# define PTRV unsigned
+# endif
+#endif
+
+#ifndef INT2PTR
+# define INT2PTR(any,d) (any)(PTRV)(d)
+#endif
+
+#ifndef PTR2ul
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+#endif
+
+#define NUM2PTR(any,d) (any)(PTRV)(d)
+#define PTR2IV(p) INT2PTR(IV,p)
+#define PTR2UV(p) INT2PTR(UV,p)
+#define PTR2NV(p) NUM2PTR(NV,p)
+#define PTR2nat(p) (PTRV)(p) /* pointer to integer of PTRSIZE */
+
+/* According to strict ANSI C89 one cannot freely cast between
+ * data pointers and function (code) pointers. There are at least
+ * two ways around this. One (used below) is to do two casts,
+ * first the other pointer to an (unsigned) integer, and then
+ * the integer to the other pointer. The other way would be
+ * to use unions to "overlay" the pointers. For an example of
+ * the latter technique, see union dirpu in struct xpvio in sv.h.
+ * The only feasible use is probably temporarily storing
+ * function pointers in a data pointer (such as a void pointer). */
+
+#define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */
+#define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */
+
+#ifdef USE_LONG_DOUBLE
+# if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE
+# define LONG_DOUBLE_EQUALS_DOUBLE
+# endif
+# if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE))
+# undef USE_LONG_DOUBLE /* Ouch! */
+# endif
+#endif
+
+#ifdef OVR_DBL_DIG
+/* Use an overridden DBL_DIG */
+# ifdef DBL_DIG
+# undef DBL_DIG
+# endif
+# define DBL_DIG OVR_DBL_DIG
+#else
+/* The following is all to get DBL_DIG, in order to pick a nice
+ default value for printing floating point numbers in Gconvert
+ (see config.h). (It also has other uses, such as figuring out if
+ a given precision of printing can be done with a double instead of
+ a long double - Allen).
+*/
+#ifdef I_LIMITS
+#include <limits.h>
+#endif
+#ifdef I_FLOAT
+#include <float.h>
+#endif
+#ifndef HAS_DBL_DIG
+#define DBL_DIG 15 /* A guess that works lots of places */
+#endif
+#endif
+
+#ifdef OVR_LDBL_DIG
+/* Use an overridden LDBL_DIG */
+# ifdef LDBL_DIG
+# undef LDBL_DIG
+# endif
+# define LDBL_DIG OVR_LDBL_DIG
+#else
+/* The following is all to get LDBL_DIG, in order to pick a nice
+ default value for printing floating point numbers in Gconvert.
+ (see config.h)
+*/
+# ifdef I_LIMITS
+# include <limits.h>
+# endif
+# ifdef I_FLOAT
+# include <float.h>
+# endif
+# ifndef HAS_LDBL_DIG
+# if LONG_DOUBLESIZE == 10
+# define LDBL_DIG 18 /* assume IEEE */
+# else
+# if LONG_DOUBLESIZE == 12
+# define LDBL_DIG 18 /* gcc? */
+# else
+# if LONG_DOUBLESIZE == 16
+# define LDBL_DIG 33 /* assume IEEE */
+# else
+# if LONG_DOUBLESIZE == DOUBLESIZE
+# define LDBL_DIG DBL_DIG /* bummer */
+# endif
+# endif
+# endif
+# endif
+# endif
+#endif
+
+/*
+ * This is for making sure we have a good DBL_MAX value, if possible,
+ * either for usage as NV_MAX or for usage in figuring out if we can
+ * fit a given long double into a double, if bug-fixing makes it
+ * necessary to do so. - Allen <allens@cpan.org>
+ */
+
+#ifdef I_LIMITS
+# include <limits.h>
+#endif
+
+#ifdef I_VALUES
+# if !(defined(DBL_MIN) && defined(DBL_MAX) && defined(I_LIMITS))
+# include <values.h>
+# if defined(MAXDOUBLE) && !defined(DBL_MAX)
+# define DBL_MAX MAXDOUBLE
+# endif
+# if defined(MINDOUBLE) && !defined(DBL_MIN)
+# define DBL_MIN MINDOUBLE
+# endif
+# endif
+#endif /* defined(I_VALUES) */
+
+typedef NVTYPE NV;
+
+#ifdef I_IEEEFP
+# include <ieeefp.h>
+#endif
+
+#ifdef USE_LONG_DOUBLE
+# ifdef I_SUNMATH
+# include <sunmath.h>
+# endif
+# define NV_DIG LDBL_DIG
+# ifdef LDBL_MANT_DIG
+# define NV_MANT_DIG LDBL_MANT_DIG
+# endif
+# ifdef LDBL_MIN
+# define NV_MIN LDBL_MIN
+# endif
+# ifdef LDBL_MAX
+# define NV_MAX LDBL_MAX
+# endif
+# ifdef LDBL_MIN_10_EXP
+# define NV_MIN_10_EXP LDBL_MIN_10_EXP
+# endif
+# ifdef LDBL_MAX_10_EXP
+# define NV_MAX_10_EXP LDBL_MAX_10_EXP
+# endif
+# ifdef LDBL_EPSILON
+# define NV_EPSILON LDBL_EPSILON
+# endif
+# ifdef LDBL_MAX
+# define NV_MAX LDBL_MAX
+/* Having LDBL_MAX doesn't necessarily mean that we have LDBL_MIN... -Allen */
+# else
+# ifdef HUGE_VALL
+# define NV_MAX HUGE_VALL
+# else
+# ifdef HUGE_VAL
+# define NV_MAX ((NV)HUGE_VAL)
+# endif
+# endif
+# endif
+# ifdef HAS_SQRTL
+# define Perl_cos cosl
+# define Perl_sin sinl
+# define Perl_sqrt sqrtl
+# define Perl_exp expl
+# define Perl_log logl
+# define Perl_atan2 atan2l
+# define Perl_pow powl
+# define Perl_floor floorl
+# define Perl_ceil ceill
+# define Perl_fmod fmodl
+# endif
+/* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */
+# ifdef HAS_MODFL
+# define Perl_modf(x,y) modfl(x,y)
+/* eg glibc 2.2 series seems to provide modfl on ppc and arm, but has no
+ prototype in <math.h> */
+# ifndef HAS_MODFL_PROTO
+EXTERN_C long double modfl(long double, long double *);
+# endif
+# else
+# if defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
+ extern long double Perl_my_modfl(long double x, long double *ip);
+# define Perl_modf(x,y) Perl_my_modfl(x,y)
+# endif
+# endif
+# ifdef HAS_FREXPL
+# define Perl_frexp(x,y) frexpl(x,y)
+# else
+# if defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
+ extern long double Perl_my_frexpl(long double x, int *e);
+# define Perl_frexp(x,y) Perl_my_frexpl(x,y)
+# endif
+# endif
+# ifndef Perl_isnan
+# ifdef HAS_ISNANL
+# define Perl_isnan(x) isnanl(x)
+# endif
+# endif
+# ifndef Perl_isinf
+# ifdef HAS_FINITEL
+# define Perl_isinf(x) !(finitel(x)||Perl_isnan(x))
+# endif
+# endif
+#else
+# define NV_DIG DBL_DIG
+# ifdef DBL_MANT_DIG
+# define NV_MANT_DIG DBL_MANT_DIG
+# endif
+# ifdef DBL_MIN
+# define NV_MIN DBL_MIN
+# endif
+# ifdef DBL_MAX
+# define NV_MAX DBL_MAX
+# endif
+# ifdef DBL_MIN_10_EXP
+# define NV_MIN_10_EXP DBL_MIN_10_EXP
+# endif
+# ifdef DBL_MAX_10_EXP
+# define NV_MAX_10_EXP DBL_MAX_10_EXP
+# endif
+# ifdef DBL_EPSILON
+# define NV_EPSILON DBL_EPSILON
+# endif
+# ifdef DBL_MAX /* XXX Does DBL_MAX imply having DBL_MIN? */
+# define NV_MAX DBL_MAX
+# define NV_MIN DBL_MIN
+# else
+# ifdef HUGE_VAL
+# define NV_MAX HUGE_VAL
+# endif
+# endif
+# define Perl_cos cos
+# define Perl_sin sin
+# define Perl_sqrt sqrt
+# define Perl_exp exp
+# define Perl_log log
+# define Perl_atan2 atan2
+# define Perl_pow pow
+# define Perl_floor floor
+# define Perl_ceil ceil
+# define Perl_fmod fmod
+# define Perl_modf(x,y) modf(x,y)
+# define Perl_frexp(x,y) frexp(x,y)
+#endif
+
+/* rumor has it that Win32 has _fpclass() */
+
+/* SGI has fpclassl... but not with the same result values,
+ * and it's via a typedef (not via #define), so will need to redo Configure
+ * to use. Not worth the trouble, IMO, at least until the below is used
+ * more places. Also has fp_class_l, BTW, via fp_class.h. Feel free to check
+ * with me for the SGI manpages, SGI testing, etcetera, if you want to
+ * try getting this to work with IRIX. - Allen <allens@cpan.org> */
+
+#if !defined(Perl_fp_class) && (defined(HAS_FPCLASS)||defined(HAS_FPCLASSL))
+# ifdef I_IEEFP
+# include <ieeefp.h>
+# endif
+# ifdef I_FP
+# include <fp.h>
+# endif
+# if defined(USE_LONG_DOUBLE) && defined(HAS_FPCLASSL)
+# define Perl_fp_class() fpclassl(x)
+# else
+# define Perl_fp_class() fpclass(x)
+# endif
+# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN)
+# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN)
+# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_CLASS_SNAN||Perl_fp_class(x)==FP_CLASS_QNAN)
+# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF)
+# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF)
+# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_CLASS_NINF||Perl_fp_class(x)==FP_CLASS_PINF)
+# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM)
+# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM)
+# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_CLASS_NNORM||Perl_fp_class(x)==FP_CLASS_PNORM)
+# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM)
+# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM)
+# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM||Perl_fp_class(x)==FP_CLASS_PDENORM)
+# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO)
+# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO)
+# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_CLASS_NZERO||Perl_fp_class(x)==FP_CLASS_PZERO)
+#endif
+
+#if !defined(Perl_fp_class) && defined(HAS_FP_CLASS) && !defined(PERL_MICRO)
+# include <math.h>
+# if !defined(FP_SNAN) && defined(I_FP_CLASS)
+# include <fp_class.h>
+# endif
+# define Perl_fp_class(x) fp_class(x)
+# define Perl_fp_class_snan(x) (fp_class(x)==FP_SNAN)
+# define Perl_fp_class_qnan(x) (fp_class(x)==FP_QNAN)
+# define Perl_fp_class_nan(x) (fp_class(x)==FP_SNAN||fp_class(x)==FP_QNAN)
+# define Perl_fp_class_ninf(x) (fp_class(x)==FP_NEG_INF)
+# define Perl_fp_class_pinf(x) (fp_class(x)==FP_POS_INF)
+# define Perl_fp_class_inf(x) (fp_class(x)==FP_NEG_INF||fp_class(x)==FP_POS_INF)
+# define Perl_fp_class_nnorm(x) (fp_class(x)==FP_NEG_NORM)
+# define Perl_fp_class_pnorm(x) (fp_class(x)==FP_POS_NORM)
+# define Perl_fp_class_norm(x) (fp_class(x)==FP_NEG_NORM||fp_class(x)==FP_POS_NORM)
+# define Perl_fp_class_ndenorm(x) (fp_class(x)==FP_NEG_DENORM)
+# define Perl_fp_class_pdenorm(x) (fp_class(x)==FP_POS_DENORM)
+# define Perl_fp_class_denorm(x) (fp_class(x)==FP_NEG_DENORM||fp_class(x)==FP_POS_DENORM)
+# define Perl_fp_class_nzero(x) (fp_class(x)==FP_NEG_ZERO)
+# define Perl_fp_class_pzero(x) (fp_class(x)==FP_POS_ZERO)
+# define Perl_fp_class_zero(x) (fp_class(x)==FP_NEG_ZERO||fp_class(x)==FP_POS_ZERO)
+#endif
+
+#if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY)
+# include <math.h>
+# define Perl_fp_class(x) fpclassify(x)
+# define Perl_fp_class_nan(x) (fp_classify(x)==FP_SNAN||fp_classify(x)==FP_QNAN)
+# define Perl_fp_class_inf(x) (fp_classify(x)==FP_INFINITE)
+# define Perl_fp_class_norm(x) (fp_classify(x)==FP_NORMAL)
+# define Perl_fp_class_denorm(x) (fp_classify(x)==FP_SUBNORMAL)
+# define Perl_fp_class_zero(x) (fp_classify(x)==FP_ZERO)
+#endif
+
+#if !defined(Perl_fp_class) && defined(HAS_CLASS)
+# include <math.h>
+# ifndef _cplusplus
+# define Perl_fp_class(x) class(x)
+# else
+# define Perl_fp_class(x) _class(x)
+# endif
+# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS)
+# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ)
+# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_SNAN||Perl_fp_class(x)==FP_QNAN)
+# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF)
+# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF)
+# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_MINUS_INF||Perl_fp_class(x)==FP_PLUS_INF)
+# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM)
+# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM)
+# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_MINUS_NORM||Perl_fp_class(x)==FP_PLUS_NORM)
+# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM)
+# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM)
+# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM||Perl_fp_class(x)==FP_PLUS_DENORM)
+# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO)
+# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO)
+# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_MINUS_ZERO||Perl_fp_class(x)==FP_PLUS_ZERO)
+#endif
+
+/* rumor has it that Win32 has _isnan() */
+
+#ifndef Perl_isnan
+# ifdef HAS_ISNAN
+# define Perl_isnan(x) isnan((NV)x)
+# else
+# ifdef Perl_fp_class_nan
+# define Perl_isnan(x) Perl_fp_class_nan(x)
+# else
+# ifdef HAS_UNORDERED
+# define Perl_isnan(x) unordered((x), 0.0)
+# else
+# define Perl_isnan(x) ((x)!=(x))
+# endif
+# endif
+# endif
+#endif
+
+#ifdef UNDER_CE
+int isnan(double d);
+#endif
+
+#ifndef Perl_isinf
+# ifdef HAS_ISINF
+# define Perl_isinf(x) isinf((NV)x)
+# else
+# ifdef Perl_fp_class_inf
+# define Perl_isinf(x) Perl_fp_class_inf(x)
+# else
+# define Perl_isinf(x) ((x)==NV_INF)
+# endif
+# endif
+#endif
+
+#ifndef Perl_isfinite
+# ifdef HAS_FINITE
+# define Perl_isfinite(x) finite((NV)x)
+# else
+# ifdef HAS_ISFINITE
+# define Perl_isfinite(x) isfinite(x)
+# else
+# ifdef Perl_fp_class_finite
+# define Perl_isfinite(x) Perl_fp_class_finite(x)
+# else
+# define Perl_isfinite(x) !(Perl_is_inf(x)||Perl_is_nan(x))
+# endif
+# endif
+# endif
+#endif
+
+/* The default is to use Perl's own atof() implementation (in numeric.c).
+ * Usually that is the one to use but for some platforms (e.g. UNICOS)
+ * it is however best to use the native implementation of atof.
+ * You can experiment with using your native one by -DUSE_PERL_ATOF=0.
+ * Some good tests to try out with either setting are t/base/num.t,
+ * t/op/numconvert.t, and t/op/pack.t. Note that if using long doubles
+ * you may need to be using a different function than atof! */
+
+#ifndef USE_PERL_ATOF
+# ifndef _UNICOS
+# define USE_PERL_ATOF
+# endif
+#else
+# if USE_PERL_ATOF == 0
+# undef USE_PERL_ATOF
+# endif
+#endif
+
+#ifdef USE_PERL_ATOF
+# define Perl_atof(s) Perl_my_atof(s)
+# define Perl_atof2(s, n) Perl_my_atof2(aTHX_ (s), &(n))
+#else
+# define Perl_atof(s) (NV)atof(s)
+# define Perl_atof2(s, n) ((n) = atof(s))
+#endif
+
+/* Previously these definitions used hardcoded figures.
+ * It is hoped these formula are more portable, although
+ * no data one way or another is presently known to me.
+ * The "PERL_" names are used because these calculated constants
+ * do not meet the ANSI requirements for LONG_MAX, etc., which
+ * need to be constants acceptable to #if - kja
+ * define PERL_LONG_MAX 2147483647L
+ * define PERL_LONG_MIN (-LONG_MAX - 1)
+ * define PERL ULONG_MAX 4294967295L
+ */
+
+#ifdef I_LIMITS /* Needed for cast_xxx() functions below. */
+# include <limits.h>
+#endif
+/* Included values.h above if necessary; still including limits.h down here,
+ * despite doing above, because math.h might have overriden... XXX - Allen */
+
+/*
+ * Try to figure out max and min values for the integral types. THE CORRECT
+ * SOLUTION TO THIS MESS: ADAPT enquire.c FROM GCC INTO CONFIGURE. The
+ * following hacks are used if neither limits.h or values.h provide them:
+ * U<TYPE>_MAX: for types >= int: ~(unsigned TYPE)0
+ * for types < int: (unsigned TYPE)~(unsigned)0
+ * The argument to ~ must be unsigned so that later signed->unsigned
+ * conversion can't modify the value's bit pattern (e.g. -0 -> +0),
+ * and it must not be smaller than int because ~ does integral promotion.
+ * <type>_MAX: (<type>) (U<type>_MAX >> 1)
+ * <type>_MIN: -<type>_MAX - <is_twos_complement_architecture: (3 & -1) == 3>.
+ * The latter is a hack which happens to work on some machines but
+ * does *not* catch any random system, or things like integer types
+ * with NaN if that is possible.
+ *
+ * All of the types are explicitly cast to prevent accidental loss of
+ * numeric range, and in the hope that they will be less likely to confuse
+ * over-eager optimizers.
+ *
+ */
+
+#define PERL_UCHAR_MIN ((unsigned char)0)
+
+#ifdef UCHAR_MAX
+# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
+#else
+# ifdef MAXUCHAR
+# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
+# else
+# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
+# endif
+#endif
+
+/*
+ * CHAR_MIN and CHAR_MAX are not included here, as the (char) type may be
+ * ambiguous. It may be equivalent to (signed char) or (unsigned char)
+ * depending on local options. Until Configure detects this (or at least
+ * detects whether the "signed" keyword is available) the CHAR ranges
+ * will not be included. UCHAR functions normally.
+ * - kja
+ */
+
+#define PERL_USHORT_MIN ((unsigned short)0)
+
+#ifdef USHORT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
+#else
+# ifdef MAXUSHORT
+# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
+# else
+# ifdef USHRT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
+# else
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# endif
+# endif
+#endif
+
+#ifdef SHORT_MAX
+# define PERL_SHORT_MAX ((short)SHORT_MAX)
+#else
+# ifdef MAXSHORT /* Often used in <values.h> */
+# define PERL_SHORT_MAX ((short)MAXSHORT)
+# else
+# ifdef SHRT_MAX
+# define PERL_SHORT_MAX ((short)SHRT_MAX)
+# else
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+#else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# ifdef SHRT_MIN
+# define PERL_SHORT_MIN ((short)SHRT_MIN)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#ifdef UINT_MAX
+# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
+#else
+# ifdef MAXUINT
+# define PERL_UINT_MAX ((unsigned int)MAXUINT)
+# else
+# define PERL_UINT_MAX (~(unsigned int)0)
+# endif
+#endif
+
+#define PERL_UINT_MIN ((unsigned int)0)
+
+#ifdef INT_MAX
+# define PERL_INT_MAX ((int)INT_MAX)
+#else
+# ifdef MAXINT /* Often used in <values.h> */
+# define PERL_INT_MAX ((int)MAXINT)
+# else
+# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
+# endif
+#endif
+
+#ifdef INT_MIN
+# define PERL_INT_MIN ((int)INT_MIN)
+#else
+# ifdef MININT
+# define PERL_INT_MIN ((int)MININT)
+# else
+# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
+# endif
+#endif
+
+#ifdef ULONG_MAX
+# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
+#else
+# ifdef MAXULONG
+# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
+# else
+# define PERL_ULONG_MAX (~(unsigned long)0)
+# endif
+#endif
+
+#define PERL_ULONG_MIN ((unsigned long)0L)
+
+#ifdef LONG_MAX
+# define PERL_LONG_MAX ((long)LONG_MAX)
+#else
+# ifdef MAXLONG /* Often used in <values.h> */
+# define PERL_LONG_MAX ((long)MAXLONG)
+# else
+# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
+# endif
+#endif
+
+#ifdef LONG_MIN
+# define PERL_LONG_MIN ((long)LONG_MIN)
+#else
+# ifdef MINLONG
+# define PERL_LONG_MIN ((long)MINLONG)
+# else
+# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
+# endif
+#endif
+
+#ifdef UV_IS_QUAD
+
+# define PERL_UQUAD_MAX (~(UV)0)
+# define PERL_UQUAD_MIN ((UV)0)
+# define PERL_QUAD_MAX ((IV) (PERL_UQUAD_MAX >> 1))
+# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
+
+#endif
+
+#ifdef MYMALLOC
+# include "malloc_ctl.h"
+#endif
+
+struct RExC_state_t;
+struct _reg_trie_data;
+
+typedef MEM_SIZE STRLEN;
+
+#ifdef PERL_MAD
+typedef struct token TOKEN;
+typedef struct madprop MADPROP;
+typedef struct nexttoken NEXTTOKE;
+#endif
+typedef struct op OP;
+typedef struct cop COP;
+typedef struct unop UNOP;
+typedef struct binop BINOP;
+typedef struct listop LISTOP;
+typedef struct logop LOGOP;
+typedef struct pmop PMOP;
+typedef struct svop SVOP;
+typedef struct padop PADOP;
+typedef struct pvop PVOP;
+typedef struct loop LOOP;
+
+typedef struct interpreter PerlInterpreter;
+
+/* Amdahl's <ksync.h> has struct sv */
+/* SGI's <sys/sema.h> has struct sv */
+#if defined(UTS) || defined(__sgi)
+# define STRUCT_SV perl_sv
+#else
+# define STRUCT_SV sv
+#endif
+typedef struct STRUCT_SV SV;
+typedef struct av AV;
+typedef struct hv HV;
+typedef struct cv CV;
+typedef struct regexp REGEXP;
+typedef struct gp GP;
+typedef struct gv GV;
+typedef struct io IO;
+typedef struct context PERL_CONTEXT;
+typedef struct block BLOCK;
+
+typedef struct magic MAGIC;
+typedef struct xpv XPV;
+typedef struct xpviv XPVIV;
+typedef struct xpvuv XPVUV;
+typedef struct xpvnv XPVNV;
+typedef struct xpvmg XPVMG;
+typedef struct xpvlv XPVLV;
+typedef struct xpvav XPVAV;
+typedef struct xpvhv XPVHV;
+typedef struct xpvgv XPVGV;
+typedef struct xpvcv XPVCV;
+typedef struct xpvbm XPVBM;
+typedef struct xpvfm XPVFM;
+typedef struct xpvio XPVIO;
+typedef struct mgvtbl MGVTBL;
+typedef union any ANY;
+typedef struct ptr_tbl_ent PTR_TBL_ENT_t;
+typedef struct ptr_tbl PTR_TBL_t;
+typedef struct clone_params CLONE_PARAMS;
+
+#include "handy.h"
+
+#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO)
+# if LSEEKSIZE == 8 && !defined(USE_64_BIT_RAWIO)
+# define USE_64_BIT_RAWIO /* implicit */
+# endif
+#endif
+
+/* Notice the use of HAS_FSEEKO: now we are obligated to always use
+ * fseeko/ftello if possible. Don't go #defining ftell to ftello yourself,
+ * however, because operating systems like to do that themself. */
+#ifndef FSEEKSIZE
+# ifdef HAS_FSEEKO
+# define FSEEKSIZE LSEEKSIZE
+# else
+# define FSEEKSIZE LONGSIZE
+# endif
+#endif
+
+#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_STDIO)
+# if FSEEKSIZE == 8 && !defined(USE_64_BIT_STDIO)
+# define USE_64_BIT_STDIO /* implicit */
+# endif
+#endif
+
+#ifdef USE_64_BIT_RAWIO
+# ifdef HAS_OFF64_T
+# undef Off_t
+# define Off_t off64_t
+# undef LSEEKSIZE
+# define LSEEKSIZE 8
+# endif
+/* Most 64-bit environments have defines like _LARGEFILE_SOURCE that
+ * will trigger defines like the ones below. Some 64-bit environments,
+ * however, do not. Therefore we have to explicitly mix and match. */
+# if defined(USE_OPEN64)
+# define open open64
+# endif
+# if defined(USE_LSEEK64)
+# define lseek lseek64
+# else
+# if defined(USE_LLSEEK)
+# define lseek llseek
+# endif
+# endif
+# if defined(USE_STAT64)
+# define stat stat64
+# endif
+# if defined(USE_FSTAT64)
+# define fstat fstat64
+# endif
+# if defined(USE_LSTAT64)
+# define lstat lstat64
+# endif
+# if defined(USE_FLOCK64)
+# define flock flock64
+# endif
+# if defined(USE_LOCKF64)
+# define lockf lockf64
+# endif
+# if defined(USE_FCNTL64)
+# define fcntl fcntl64
+# endif
+# if defined(USE_TRUNCATE64)
+# define truncate truncate64
+# endif
+# if defined(USE_FTRUNCATE64)
+# define ftruncate ftruncate64
+# endif
+#endif
+
+#ifdef USE_64_BIT_STDIO
+# ifdef HAS_FPOS64_T
+# undef Fpos_t
+# define Fpos_t fpos64_t
+# endif
+/* Most 64-bit environments have defines like _LARGEFILE_SOURCE that
+ * will trigger defines like the ones below. Some 64-bit environments,
+ * however, do not. */
+# if defined(USE_FOPEN64)
+# define fopen fopen64
+# endif
+# if defined(USE_FSEEK64)
+# define fseek fseek64 /* don't do fseeko here, see perlio.c */
+# endif
+# if defined(USE_FTELL64)
+# define ftell ftell64 /* don't do ftello here, see perlio.c */
+# endif
+# if defined(USE_FSETPOS64)
+# define fsetpos fsetpos64
+# endif
+# if defined(USE_FGETPOS64)
+# define fgetpos fgetpos64
+# endif
+# if defined(USE_TMPFILE64)
+# define tmpfile tmpfile64
+# endif
+# if defined(USE_FREOPEN64)
+# define freopen freopen64
+# endif
+#endif
+
+#if defined(OS2) || defined(MACOS_TRADITIONAL)
+# include "iperlsys.h"
+#endif
+
+#if defined(__OPEN_VM)
+# include "vmesa/vmesaish.h"
+# define ISHISH "vmesa"
+#endif
+
+#ifdef DOSISH
+# if defined(OS2)
+# include "os2ish.h"
+# else
+# include "dosish.h"
+# endif
+# define ISHISH "dos"
+#endif
+
+#if defined(VMS)
+# include "vmsish.h"
+# include "embed.h"
+# ifndef PERL_MAD
+# undef op_getmad
+# define op_getmad(arg,pegop,slot) NOOP
+# endif
+# define ISHISH "vms"
+#endif
+
+#if defined(PLAN9)
+# include "./plan9/plan9ish.h"
+# define ISHISH "plan9"
+#endif
+
+#if defined(MPE)
+# include "mpeix/mpeixish.h"
+# define ISHISH "mpeix"
+#endif
+
+#if defined(__VOS__)
+# ifdef __GNUC__
+# include "./vos/vosish.h"
+# else
+# include "vos/vosish.h"
+# endif
+# define ISHISH "vos"
+#endif
+
+#if defined(EPOC)
+# include "epocish.h"
+# define ISHISH "epoc"
+#endif
+
+#ifdef __SYMBIAN32__
+# include "symbian/symbianish.h"
+# include "embed.h"
+# ifndef PERL_MAD
+# undef op_getmad
+# define op_getmad(arg,pegop,slot) NOOP
+# endif
+# define ISHISH "symbian"
+#endif
+
+#if defined(MACOS_TRADITIONAL)
+# include "macos/macish.h"
+# ifndef NO_ENVIRON_ARRAY
+# define NO_ENVIRON_ARRAY
+# endif
+# define ISHISH "macos classic"
+#endif
+
+#if defined(__HAIKU__)
+# include "haiku/haikuish.h"
+# define ISHISH "haiku"
+#elif defined(__BEOS__)
+# include "beos/beosish.h"
+# define ISHISH "beos"
+#endif
+
+#ifndef ISHISH
+# include "unixish.h"
+# define ISHISH "unix"
+#endif
+
+/* NSIG logic from Configure --> */
+/* Strange style to avoid deeply-nested #if/#else/#endif */
+#ifndef NSIG
+# ifdef _NSIG
+# define NSIG (_NSIG)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef SIGMAX
+# define NSIG (SIGMAX+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef SIG_MAX
+# define NSIG (SIG_MAX+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef _SIG_MAX
+# define NSIG (_SIG_MAX+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef MAXSIG
+# define NSIG (MAXSIG+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef MAX_SIG
+# define NSIG (MAX_SIG+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef SIGARRAYSIZE
+# define NSIG SIGARRAYSIZE /* Assume ary[SIGARRAYSIZE] */
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef _sys_nsig
+# define NSIG (_sys_nsig) /* Solaris 2.5 */
+# endif
+#endif
+
+/* Default to some arbitrary number that's big enough to get most
+ of the common signals.
+*/
+#ifndef NSIG
+# define NSIG 50
+#endif
+/* <-- NSIG logic from Configure */
+
+#ifndef NO_ENVIRON_ARRAY
+# define USE_ENVIRON_ARRAY
+#endif
+
+/*
+ * initialise to avoid floating-point exceptions from overflow, etc
+ */
+#ifndef PERL_FPU_INIT
+# ifdef HAS_FPSETMASK
+# if HAS_FLOATINGPOINT_H
+# include <floatingpoint.h>
+# endif
+/* Some operating systems have this as a macro, which in turn expands to a comma
+ expression, and the last sub-expression is something that gets calculated,
+ and then they have the gall to warn that a value computed is not used. Hence
+ cast to void. */
+# define PERL_FPU_INIT (void)fpsetmask(0)
+# else
+# if defined(SIGFPE) && defined(SIG_IGN) && !defined(PERL_MICRO)
+# define PERL_FPU_INIT PL_sigfpe_saved = (Sighandler_t) signal(SIGFPE, SIG_IGN)
+# define PERL_FPU_PRE_EXEC { Sigsave_t xfpe; rsignal_save(SIGFPE, PL_sigfpe_saved, &xfpe);
+# define PERL_FPU_POST_EXEC rsignal_restore(SIGFPE, &xfpe); }
+# else
+# define PERL_FPU_INIT
+
+# endif
+# endif
+#endif
+#ifndef PERL_FPU_PRE_EXEC
+# define PERL_FPU_PRE_EXEC {
+# define PERL_FPU_POST_EXEC }
+#endif
+
+#ifndef PERL_SYS_INIT3_BODY
+# define PERL_SYS_INIT3_BODY(argvp,argcp,envp) PERL_SYS_INIT_BODY(argvp,argcp)
+#endif
+
+/*
+=for apidoc Am|void|PERL_SYS_INIT|int argc|char** argv
+Provides system-specific tune up of the C runtime environment necessary to
+run Perl interpreters. This should be called only once, before creating
+any Perl interpreters.
+
+=for apidoc Am|void|PERL_SYS_INIT3|int argc|char** argv|char** env
+Provides system-specific tune up of the C runtime environment necessary to
+run Perl interpreters. This should be called only once, before creating
+any Perl interpreters.
+
+=for apidoc Am|void|PERL_SYS_TERM|
+Provides system-specific clean up of the C runtime environment after
+running Perl interpreters. This should be called only once, after
+freeing any remaining Perl interpreters.
+
+=cut
+ */
+
+#define PERL_SYS_INIT(argc, argv) Perl_sys_init(argc, argv)
+#define PERL_SYS_INIT3(argc, argv, env) Perl_sys_init3(argc, argv, env)
+#define PERL_SYS_TERM() Perl_sys_term()
+
+#ifndef PERL_WRITE_MSG_TO_CONSOLE
+# define PERL_WRITE_MSG_TO_CONSOLE(io, msg, len) PerlIO_write(io, msg, len)
+#endif
+
+#ifndef MAXPATHLEN
+# ifdef PATH_MAX
+# ifdef _POSIX_PATH_MAX
+# if PATH_MAX > _POSIX_PATH_MAX
+/* POSIX 1990 (and pre) was ambiguous about whether PATH_MAX
+ * included the null byte or not. Later amendments of POSIX,
+ * XPG4, the Austin Group, and the Single UNIX Specification
+ * all explicitly include the null byte in the PATH_MAX.
+ * Ditto for _POSIX_PATH_MAX. */
+# define MAXPATHLEN PATH_MAX
+# else
+# define MAXPATHLEN _POSIX_PATH_MAX
+# endif
+# else
+# define MAXPATHLEN (PATH_MAX+1)
+# endif
+# else
+# ifdef _POSIX_PATH_MAX
+# define MAXPATHLEN _POSIX_PATH_MAX
+# else
+# define MAXPATHLEN 1024 /* Err on the large side. */
+# endif
+# endif
+#endif
+
+/* In case Configure was not used (we are using a "canned config"
+ * such as Win32, or a cross-compilation setup, for example) try going
+ * by the gcc major and minor versions. One useful URL is
+ * http://www.ohse.de/uwe/articles/gcc-attributes.html,
+ * but contrary to this information warn_unused_result seems
+ * not to be in gcc 3.3.5, at least. --jhi
+ * Also, when building extensions with an installed perl, this allows
+ * the user to upgrade gcc and get the right attributes, rather than
+ * relying on the list generated at Configure time. --AD
+ * Set these up now otherwise we get confused when some of the <*thread.h>
+ * includes below indirectly pull in <perlio.h> (which needs to know if we
+ * have HASATTRIBUTE_FORMAT).
+ */
+
+#ifndef PERL_MICRO
+#if defined __GNUC__ && !defined(__INTEL_COMPILER)
+# if __GNUC__ == 3 && __GNUC_MINOR__ >= 1 || __GNUC__ > 3 /* 3.1 -> */
+# define HASATTRIBUTE_DEPRECATED
+# endif
+# if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */
+# define HASATTRIBUTE_FORMAT
+# if defined __MINGW32__
+# define PRINTF_FORMAT_NULL_OK
+# endif
+# endif
+# if __GNUC__ >= 3 /* 3.0 -> */
+# define HASATTRIBUTE_MALLOC
+# endif
+# if __GNUC__ == 3 && __GNUC_MINOR__ >= 3 || __GNUC__ > 3 /* 3.3 -> */
+# define HASATTRIBUTE_NONNULL
+# endif
+# if __GNUC__ == 2 && __GNUC_MINOR__ >= 5 || __GNUC__ > 2 /* 2.5 -> */
+# define HASATTRIBUTE_NORETURN
+# endif
+# if __GNUC__ >= 3 /* gcc 3.0 -> */
+# define HASATTRIBUTE_PURE
+# endif
+# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */
+# define HASATTRIBUTE_UNUSED
+# endif
+# if __GNUC__ == 3 && __GNUC_MINOR__ == 3 && !defined(__cplusplus)
+# define HASATTRIBUTE_UNUSED /* gcc-3.3, but not g++-3.3. */
+# endif
+# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */
+# define HASATTRIBUTE_WARN_UNUSED_RESULT
+# endif
+#endif
+#endif /* #ifndef PERL_MICRO */
+
+/* USE_5005THREADS needs to be after unixish.h as <pthread.h> includes
+ * <sys/signal.h> which defines NSIG - which will stop inclusion of <signal.h>
+ * this results in many functions being undeclared which bothers C++
+ * May make sense to have threads after "*ish.h" anyway
+ */
+
+#if defined(USE_ITHREADS)
+# ifdef NETWARE
+# include <nw5thread.h>
+# else
+# ifdef FAKE_THREADS
+# include "fakethr.h"
+# else
+# ifdef WIN32
+# include <win32thread.h>
+# else
+# ifdef OS2
+# include "os2thread.h"
+# else
+# ifdef I_MACH_CTHREADS
+# include <mach/cthreads.h>
+# if (defined(NeXT) || defined(__NeXT__)) && defined(PERL_POLLUTE_MALLOC)
+# define MUTEX_INIT_CALLS_MALLOC
+# endif
+typedef cthread_t perl_os_thread;
+typedef mutex_t perl_mutex;
+typedef condition_t perl_cond;
+typedef void * perl_key;
+# else /* Posix threads */
+# ifdef I_PTHREAD
+# include <pthread.h>
+# endif
+typedef pthread_t perl_os_thread;
+typedef pthread_mutex_t perl_mutex;
+typedef pthread_cond_t perl_cond;
+typedef pthread_key_t perl_key;
+# endif /* I_MACH_CTHREADS */
+# endif /* OS2 */
+# endif /* WIN32 */
+# endif /* FAKE_THREADS */
+#endif /* NETWARE */
+#endif /* USE_ITHREADS */
+
+#if defined(WIN32)
+# include "win32.h"
+#endif
+
+#ifdef NETWARE
+# include "netware.h"
+#endif
+
+#define STATUS_UNIX PL_statusvalue
+#ifdef VMS
+# define STATUS_NATIVE PL_statusvalue_vms
+/*
+ * vaxc$errno is only guaranteed to be valid if errno == EVMSERR, otherwise
+ * its contents can not be trusted. Unfortunately, Perl seems to check
+ * it on exit, so it when PL_statusvalue_vms is updated, vaxc$errno should
+ * be updated also.
+ */
+# include <stsdef.h>
+# include <ssdef.h>
+/* Presume this because if VMS changes it, it will require a new
+ * set of APIs for waiting on children for binary compatibility.
+ */
+# define child_offset_bits (8)
+# ifndef C_FAC_POSIX
+# define C_FAC_POSIX 0x35A000
+# endif
+
+/* STATUS_EXIT - validates and returns a NATIVE exit status code for the
+ * platform from the existing UNIX or Native status values.
+ */
+
+# define STATUS_EXIT \
+ (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \
+ (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0))
+
+
+/* STATUS_NATIVE_CHILD_SET - Calculate UNIX status that matches the child
+ * exit code and shifts the UNIX value over the correct number of bits to
+ * be a child status. Usually the number of bits is 8, but that could be
+ * platform dependent. The NATIVE status code is presumed to have either
+ * from a child process.
+ */
+
+/* This is complicated. The child processes return a true native VMS
+ status which must be saved. But there is an assumption in Perl that
+ the UNIX child status has some relationship to errno values, so
+ Perl tries to translate it to text in some of the tests.
+ In order to get the string translation correct, for the error, errno
+ must be EVMSERR, but that generates a different text message
+ than what the test programs are expecting. So an errno value must
+ be derived from the native status value when an error occurs.
+ That will hide the true native status message. With this version of
+ perl, the true native child status can always be retrieved so that
+ is not a problem. But in this case, Pl_statusvalue and errno may
+ have different values in them.
+ */
+
+# define STATUS_NATIVE_CHILD_SET(n) \
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ if (evalue == EVMSERR) { \
+ PL_statusvalue_vms = vaxc$errno; \
+ PL_statusvalue = evalue; \
+ } else { \
+ PL_statusvalue_vms = evalue; \
+ if (evalue == -1) { \
+ PL_statusvalue = -1; \
+ PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \
+ } else \
+ PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \
+ set_vaxc_errno(evalue); \
+ if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \
+ set_errno(EVMSERR); \
+ else set_errno(Perl_vms_status_to_unix(evalue, 0)); \
+ PL_statusvalue = PL_statusvalue << child_offset_bits; \
+ } \
+ } STMT_END
+
+# ifdef VMSISH_STATUS
+# define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX)
+# else
+# define STATUS_CURRENT STATUS_UNIX
+# endif
+
+ /* STATUS_UNIX_SET - takes a UNIX/POSIX errno value and attempts to update
+ * the NATIVE status to an equivalent value. Can not be used to translate
+ * exit code values as exit code values are not guaranteed to have any
+ * relationship at all to errno values.
+ * This is used when Perl is forcing errno to have a specific value.
+ */
+# define STATUS_UNIX_SET(n) \
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (PL_statusvalue != -1) { \
+ if (PL_statusvalue != EVMSERR) { \
+ PL_statusvalue &= 0xFFFF; \
+ if (MY_POSIX_EXIT) \
+ PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\
+ else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
+ } \
+ else { \
+ PL_statusvalue_vms = vaxc$errno; \
+ } \
+ } \
+ else PL_statusvalue_vms = SS$_ABORT; \
+ set_vaxc_errno(PL_statusvalue_vms); \
+ } STMT_END
+
+ /* STATUS_UNIX_EXIT_SET - Takes a UNIX/POSIX exit code and sets
+ * the NATIVE error status based on it.
+ *
+ * When in the default mode to comply with the Perl VMS documentation,
+ * 0 is a success and any other code sets the NATIVE status to a failure
+ * code of SS$_ABORT.
+ *
+ * In the new POSIX EXIT mode, native status will be set so that the
+ * actual exit code will can be retrieved by the calling program or
+ * shell.
+ *
+ * If the exit code is not clearly a UNIX parent or child exit status,
+ * it will be passed through as a VMS status.
+ */
+
+# define STATUS_UNIX_EXIT_SET(n) \
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (MY_POSIX_EXIT) { \
+ if (evalue <= 0xFF00) { \
+ if (evalue > 0xFF) \
+ evalue = (evalue >> child_offset_bits) & 0xFF; \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | \
+ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \
+ } else /* forgive them Perl, for they have sinned */ \
+ PL_statusvalue_vms = evalue; \
+ } else { \
+ if (evalue == 0) \
+ PL_statusvalue_vms = SS$_NORMAL; \
+ else if (evalue <= 0xFF00) \
+ PL_statusvalue_vms = SS$_ABORT; \
+ else { /* forgive them Perl, for they have sinned */ \
+ if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \
+ else PL_statusvalue_vms = vaxc$errno; \
+ /* And obviously used a VMS status value instead of UNIX */ \
+ PL_statusvalue = EVMSERR; \
+ } \
+ set_vaxc_errno(PL_statusvalue_vms); \
+ } \
+ } STMT_END
+
+
+ /* STATUS_EXIT_SET - Takes a NATIVE/UNIX/POSIX exit code
+ * and sets the NATIVE error status based on it. This special case
+ * is needed to maintain compatibility with past VMS behavior.
+ *
+ * In the default mode on VMS, this number is passed through as
+ * both the NATIVE and UNIX status. Which makes it different
+ * that the STATUS_UNIX_EXIT_SET.
+ *
+ * In the new POSIX EXIT mode, native status will be set so that the
+ * actual exit code will can be retrieved by the calling program or
+ * shell.
+ *
+ * A POSIX exit code is from 0 to 255. If the exit code is higher
+ * than this, it needs to be assumed that it is a VMS exit code and
+ * passed through.
+ */
+
+# define STATUS_EXIT_SET(n) \
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (MY_POSIX_EXIT) \
+ if (evalue > 255) PL_statusvalue_vms = evalue; else { \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | \
+ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \
+ else \
+ PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \
+ set_vaxc_errno(PL_statusvalue_vms); \
+ } STMT_END
+
+
+ /* This macro forces a success status */
+# define STATUS_ALL_SUCCESS \
+ (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL)
+
+ /* This macro forces a failure status */
+# define STATUS_ALL_FAILURE (PL_statusvalue = 1, \
+ vaxc$errno = PL_statusvalue_vms = MY_POSIX_EXIT ? \
+ (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT)
+
+#else
+# define STATUS_NATIVE PL_statusvalue_posix
+# if defined(WCOREDUMP)
+# define STATUS_NATIVE_CHILD_SET(n) \
+ STMT_START { \
+ PL_statusvalue_posix = (n); \
+ if (PL_statusvalue_posix == -1) \
+ PL_statusvalue = -1; \
+ else { \
+ PL_statusvalue = \
+ (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) | \
+ (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0) | \
+ (WIFSIGNALED(PL_statusvalue_posix) && WCOREDUMP(PL_statusvalue_posix) ? 0x80 : 0); \
+ } \
+ } STMT_END
+# elif defined(WIFEXITED)
+# define STATUS_NATIVE_CHILD_SET(n) \
+ STMT_START { \
+ PL_statusvalue_posix = (n); \
+ if (PL_statusvalue_posix == -1) \
+ PL_statusvalue = -1; \
+ else { \
+ PL_statusvalue = \
+ (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) | \
+ (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0); \
+ } \
+ } STMT_END
+# else
+# define STATUS_NATIVE_CHILD_SET(n) \
+ STMT_START { \
+ PL_statusvalue_posix = (n); \
+ if (PL_statusvalue_posix == -1) \
+ PL_statusvalue = -1; \
+ else { \
+ PL_statusvalue = \
+ PL_statusvalue_posix & 0xFFFF; \
+ } \
+ } STMT_END
+# endif
+# define STATUS_UNIX_SET(n) \
+ STMT_START { \
+ PL_statusvalue = (n); \
+ if (PL_statusvalue != -1) \
+ PL_statusvalue &= 0xFFFF; \
+ } STMT_END
+# define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n)
+# define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n)
+# define STATUS_CURRENT STATUS_UNIX
+# define STATUS_EXIT STATUS_UNIX
+# define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_posix = 0)
+# define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_posix = 1)
+#endif
+
+/* flags in PL_exit_flags for nature of exit() */
+#define PERL_EXIT_EXPECTED 0x01
+#define PERL_EXIT_DESTRUCT_END 0x02 /* Run END in perl_destruct */
+
+#ifndef MEMBER_TO_FPTR
+# define MEMBER_TO_FPTR(name) name
+#endif
+
+#ifndef PERL_CORE
+/* format to use for version numbers in file/directory names */
+/* XXX move to Configure? */
+/* This was only ever used for the current version, and that can be done at
+ compile time, as PERL_FS_VERSION, so should we just delete it? */
+# ifndef PERL_FS_VER_FMT
+# define PERL_FS_VER_FMT "%d.%d.%d"
+# endif
+#endif
+
+#ifndef PERL_FS_VERSION
+# define PERL_FS_VERSION PERL_VERSION_STRING
+#endif
+
+/* This defines a way to flush all output buffers. This may be a
+ * performance issue, so we allow people to disable it. Also, if
+ * we are using stdio, there are broken implementations of fflush(NULL)
+ * out there, Solaris being the most prominent.
+ */
+#ifndef PERL_FLUSHALL_FOR_CHILD
+# if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
+# define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL)
+# else
+# ifdef FFLUSH_ALL
+# define PERL_FLUSHALL_FOR_CHILD my_fflush_all()
+# else
+# define PERL_FLUSHALL_FOR_CHILD NOOP
+# endif
+# endif
+#endif
+
+#ifndef PERL_WAIT_FOR_CHILDREN
+# define PERL_WAIT_FOR_CHILDREN NOOP
+#endif
+
+/* the traditional thread-unsafe notion of "current interpreter". */
+#ifndef PERL_SET_INTERP
+# define PERL_SET_INTERP(i) (PL_curinterp = (PerlInterpreter*)(i))
+#endif
+
+#ifndef PERL_GET_INTERP
+# define PERL_GET_INTERP (PL_curinterp)
+#endif
+
+#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_GET_THX)
+# ifdef MULTIPLICITY
+# define PERL_GET_THX ((PerlInterpreter *)PERL_GET_CONTEXT)
+# endif
+# define PERL_SET_THX(t) PERL_SET_CONTEXT(t)
+#endif
+
+/*
+ This replaces the previous %_ "hack" by the "%p" hacks.
+ All that is required is that the perl source does not
+ use "%-p" or "%-<number>p" or "%<number>p" formats.
+ These formats will still work in perl code.
+ See comments in sv.c for futher details.
+
+ Robin Barker 2005-07-14
+
+ No longer use %1p for VDf = %vd. RMB 2007-10-19
+*/
+
+#ifndef SVf_
+# define SVf_(n) "-" STRINGIFY(n) "p"
+#endif
+
+#ifndef SVf
+# define SVf "-p"
+#endif
+
+#ifndef SVf32
+# define SVf32 SVf_(32)
+#endif
+
+#ifndef SVf256
+# define SVf256 SVf_(256)
+#endif
+
+#define SVfARG(p) ((void*)(p))
+
+#ifdef PERL_CORE
+/* not used; but needed for backward compatibilty with XS code? - RMB */
+# undef VDf
+#else
+# ifndef VDf
+# define VDf "vd"
+# endif
+#endif
+
+#ifdef PERL_CORE
+/* not used; but needed for backward compatibilty with XS code? - RMB */
+# undef UVf
+#else
+# ifndef UVf
+# define UVf UVuf
+# endif
+#endif
+
+#ifdef HASATTRIBUTE_DEPRECATED
+# define __attribute__deprecated__ __attribute__((deprecated))
+#endif
+#ifdef HASATTRIBUTE_FORMAT
+# define __attribute__format__(x,y,z) __attribute__((format(x,y,z)))
+#endif
+#ifdef HASATTRIBUTE_MALLOC
+# define __attribute__malloc__ __attribute__((__malloc__))
+#endif
+#ifdef HASATTRIBUTE_NONNULL
+# define __attribute__nonnull__(a) __attribute__((nonnull(a)))
+#endif
+#ifdef HASATTRIBUTE_NORETURN
+# define __attribute__noreturn__ __attribute__((noreturn))
+#endif
+#ifdef HASATTRIBUTE_PURE
+# define __attribute__pure__ __attribute__((pure))
+#endif
+#ifdef HASATTRIBUTE_UNUSED
+# define __attribute__unused__ __attribute__((unused))
+#endif
+#ifdef HASATTRIBUTE_WARN_UNUSED_RESULT
+# define __attribute__warn_unused_result__ __attribute__((warn_unused_result))
+#endif
+
+/* If we haven't defined the attributes yet, define them to blank. */
+#ifndef __attribute__deprecated__
+# define __attribute__deprecated__
+#endif
+#ifndef __attribute__format__
+# define __attribute__format__(x,y,z)
+#endif
+#ifndef __attribute__malloc__
+# define __attribute__malloc__
+#endif
+#ifndef __attribute__nonnull__
+# define __attribute__nonnull__(a)
+#endif
+#ifndef __attribute__noreturn__
+# define __attribute__noreturn__
+#endif
+#ifndef __attribute__pure__
+# define __attribute__pure__
+#endif
+#ifndef __attribute__unused__
+# define __attribute__unused__
+#endif
+#ifndef __attribute__warn_unused_result__
+# define __attribute__warn_unused_result__
+#endif
+
+/* For functions that are marked as __attribute__noreturn__, it's not
+ appropriate to call return. In either case, include the lint directive.
+ */
+#ifdef HASATTRIBUTE_NORETURN
+# define NORETURN_FUNCTION_END /* NOTREACHED */
+#else
+# define NORETURN_FUNCTION_END /* NOTREACHED */ return 0
+#endif
+
+/* Some OS warn on NULL format to printf */
+#ifdef PRINTF_FORMAT_NULL_OK
+# define __attribute__format__null_ok__(x,y,z) __attribute__format__(x,y,z)
+#else
+# define __attribute__format__null_ok__(x,y,z)
+#endif
+
+#ifdef HAS_BUILTIN_EXPECT
+# define EXPECT(expr,val) __builtin_expect(expr,val)
+#else
+# define EXPECT(expr,val) (expr)
+#endif
+#define LIKELY(cond) EXPECT(cond,1)
+#define UNLIKELY(cond) EXPECT(cond,0)
+#ifdef HAS_BUILTIN_CHOOSE_EXPR
+/* placeholder */
+#endif
+
+/* Some unistd.h's give a prototype for pause() even though
+ HAS_PAUSE ends up undefined. This causes the #define
+ below to be rejected by the compiler. Sigh.
+*/
+#ifdef HAS_PAUSE
+#define Pause pause
+#else
+#define Pause() sleep((32767<<16)+32767)
+#endif
+
+#ifndef IOCPARM_LEN
+# ifdef IOCPARM_MASK
+ /* on BSDish systems we're safe */
+# define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK)
+# else
+# if defined(_IOC_SIZE) && defined(__GLIBC__)
+ /* on Linux systems we're safe; except when we're not [perl #38223] */
+# define IOCPARM_LEN(x) (_IOC_SIZE(x) < 256 ? 256 : _IOC_SIZE(x))
+# else
+ /* otherwise guess at what's safe */
+# define IOCPARM_LEN(x) 256
+# endif
+# endif
+#endif
+
+#if defined(__CYGWIN__)
+/* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+# define USEMYBINMODE /**/
+# include <io.h> /* for setmode() prototype */
+# define my_binmode(fp, iotype, mode) \
+ (PerlLIO_setmode(fileno(fp), mode) != -1 ? TRUE : FALSE)
+#endif
+
+#ifdef __CYGWIN__
+void init_os_extras(void);
+#endif
+
+#ifdef UNION_ANY_DEFINITION
+UNION_ANY_DEFINITION;
+#else
+union any {
+ void* any_ptr;
+ I32 any_i32;
+ IV any_iv;
+ long any_long;
+ bool any_bool;
+ void (*any_dptr) (void*);
+ void (*any_dxptr) (pTHX_ void*);
+};
+#endif
+
+typedef I32 (*filter_t) (pTHX_ int, SV *, int);
+
+#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
+#define FILTER_DATA(idx) \
+ (PL_parser ? AvARRAY(PL_parser->rsfp_filters)[idx] : NULL)
+#define FILTER_ISREADER(idx) \
+ (PL_parser && PL_parser->rsfp_filters \
+ && idx >= AvFILLp(PL_parser->rsfp_filters))
+#define PERL_FILTER_EXISTS(i) \
+ (PL_parser && PL_parser->rsfp_filters \
+ && (i) <= av_len(PL_parser->rsfp_filters))
+
+#if defined(_AIX) && !defined(_AIX43)
+#if defined(USE_REENTRANT) || defined(_REENTRANT) || defined(_THREAD_SAFE)
+/* We cannot include <crypt.h> to get the struct crypt_data
+ * because of setkey prototype problems when threading */
+typedef struct crypt_data { /* straight from /usr/include/crypt.h */
+ /* From OSF, Not needed in AIX
+ char C[28], D[28];
+ */
+ char E[48];
+ char KS[16][48];
+ char block[66];
+ char iobuf[16];
+} CRYPTD;
+#endif /* threading */
+#endif /* AIX */
+
+#if !defined(OS2) && !defined(MACOS_TRADITIONAL)
+# include "iperlsys.h"
+#endif
+
+#ifdef __LIBCATAMOUNT__
+#undef HAS_PASSWD /* unixish.h but not unixish enough. */
+#undef HAS_GROUP
+#define FAKE_BIT_BUCKET
+#endif
+
+/* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0.
+ * Note that the USE_HASH_SEED and USE_HASH_SEED_EXPLICIT are *NOT*
+ * defined by Configure, despite their names being similar to the
+ * other defines like USE_ITHREADS. Configure in fact knows nothing
+ * about the randomised hashes. Therefore to enable/disable the hash
+ * randomisation defines use the Configure -Accflags=... instead. */
+#if !defined(NO_HASH_SEED) && !defined(USE_HASH_SEED) && !defined(USE_HASH_SEED_EXPLICIT)
+# define USE_HASH_SEED
+#endif
+
+/* Win32 defines a type 'WORD' in windef.h. This conflicts with the enumerator
+ * 'WORD' defined in perly.h. The yytokentype enum is only a debugging aid, so
+ * it's not really needed.
+ */
+#if defined(WIN32)
+# define YYTOKENTYPE
+#endif
+#include "perly.h"
+
+#ifdef PERL_MAD
+struct nexttoken {
+ YYSTYPE next_val; /* value of next token, if any */
+ I32 next_type; /* type of next token */
+ MADPROP *next_mad; /* everything else about that token */
+};
+#endif
+
+/* macros to define bit-fields in structs. */
+#ifndef PERL_BITFIELD8
+# define PERL_BITFIELD8 unsigned
+#endif
+#ifndef PERL_BITFIELD16
+# define PERL_BITFIELD16 unsigned
+#endif
+#ifndef PERL_BITFIELD32
+# define PERL_BITFIELD32 unsigned
+#endif
+
+#include "regexp.h"
+#include "sv.h"
+#include "util.h"
+#include "form.h"
+#include "gv.h"
+#include "pad.h"
+#include "cv.h"
+#include "opnames.h"
+#include "op.h"
+#include "hv.h"
+#include "cop.h"
+#include "av.h"
+#include "mg.h"
+#include "scope.h"
+#include "warnings.h"
+#include "utf8.h"
+
+
+typedef struct _sublex_info SUBLEXINFO;
+struct _sublex_info {
+ U8 super_state; /* lexer state to save */
+ U16 sub_inwhat; /* "lex_inwhat" to use */
+ OP *sub_op; /* "lex_op" to use */
+ char *super_bufptr; /* PL_parser->bufptr that was */
+ char *super_bufend; /* PL_parser->bufend that was */
+};
+
+#include "parser.h"
+
+typedef struct magic_state MGS; /* struct magic_state defined in mg.c */
+
+struct scan_data_t; /* Used in S_* functions in regcomp.c */
+struct regnode_charclass_class; /* Used in S_* functions in regcomp.c */
+
+/* Keep next first in this structure, because sv_free_arenas take
+ advantage of this to share code between the pte arenas and the SV
+ body arenas */
+struct ptr_tbl_ent {
+ struct ptr_tbl_ent* next;
+ const void* oldval;
+ void* newval;
+};
+
+struct ptr_tbl {
+ struct ptr_tbl_ent** tbl_ary;
+ UV tbl_max;
+ UV tbl_items;
+};
+
+#if defined(iAPX286) || defined(M_I286) || defined(I80286)
+# define I286
+#endif
+
+#if defined(htonl) && !defined(HAS_HTONL)
+#define HAS_HTONL
+#endif
+#if defined(htons) && !defined(HAS_HTONS)
+#define HAS_HTONS
+#endif
+#if defined(ntohl) && !defined(HAS_NTOHL)
+#define HAS_NTOHL
+#endif
+#if defined(ntohs) && !defined(HAS_NTOHS)
+#define HAS_NTOHS
+#endif
+#ifndef HAS_HTONL
+#if (BYTEORDER & 0xffff) != 0x4321
+#define HAS_HTONS
+#define HAS_HTONL
+#define HAS_NTOHS
+#define HAS_NTOHL
+#define MYSWAP
+#define htons my_swap
+#define htonl my_htonl
+#define ntohs my_swap
+#define ntohl my_ntohl
+#endif
+#else
+#if (BYTEORDER & 0xffff) == 0x4321
+#undef HAS_HTONS
+#undef HAS_HTONL
+#undef HAS_NTOHS
+#undef HAS_NTOHL
+#endif
+#endif
+
+/*
+ * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
+ * -DWS
+ */
+#if BYTEORDER != 0x1234
+# define HAS_VTOHL
+# define HAS_VTOHS
+# define HAS_HTOVL
+# define HAS_HTOVS
+# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
+# define vtohl(x) ((((x)&0xFF)<<24) \
+ +(((x)>>24)&0xFF) \
+ +(((x)&0x0000FF00)<<8) \
+ +(((x)&0x00FF0000)>>8) )
+# define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF))
+# define htovl(x) vtohl(x)
+# define htovs(x) vtohs(x)
+# endif
+ /* otherwise default to functions in util.c */
+#ifndef htovs
+short htovs(short n);
+short vtohs(short n);
+long htovl(long n);
+long vtohl(long n);
+#endif
+#endif
+
+/* *MAX Plus 1. A floating point value.
+ Hopefully expressed in a way that dodgy floating point can't mess up.
+ >> 2 rather than 1, so that value is safely less than I32_MAX after 1
+ is added to it
+ May find that some broken compiler will want the value cast to I32.
+ [after the shift, as signed >> may not be as secure as unsigned >>]
+*/
+#define I32_MAX_P1 (2.0 * (1 + (((U32)I32_MAX) >> 1)))
+#define U32_MAX_P1 (4.0 * (1 + ((U32_MAX) >> 2)))
+/* For compilers that can't correctly cast NVs over 0x7FFFFFFF (or
+ 0x7FFFFFFFFFFFFFFF) to an unsigned integer. In the future, sizeof(UV)
+ may be greater than sizeof(IV), so don't assume that half max UV is max IV.
+*/
+#define U32_MAX_P1_HALF (2.0 * (1 + ((U32_MAX) >> 2)))
+
+#define UV_MAX_P1 (4.0 * (1 + ((UV_MAX) >> 2)))
+#define IV_MAX_P1 (2.0 * (1 + (((UV)IV_MAX) >> 1)))
+#define UV_MAX_P1_HALF (2.0 * (1 + ((UV_MAX) >> 2)))
+
+/* This may look like unnecessary jumping through hoops, but converting
+ out of range floating point values to integers *is* undefined behaviour,
+ and it is starting to bite.
+*/
+#ifndef CAST_INLINE
+#define I_32(what) (cast_i32((NV)(what)))
+#define U_32(what) (cast_ulong((NV)(what)))
+#define I_V(what) (cast_iv((NV)(what)))
+#define U_V(what) (cast_uv((NV)(what)))
+#else
+#define I_32(n) ((n) < I32_MAX_P1 ? ((n) < I32_MIN ? I32_MIN : (I32) (n)) \
+ : ((n) < U32_MAX_P1 ? (I32)(U32) (n) \
+ : ((n) > 0 ? (I32) U32_MAX : 0 /* NaN */)))
+#define U_32(n) ((n) < 0.0 ? ((n) < I32_MIN ? (UV) I32_MIN : (U32)(I32) (n)) \
+ : ((n) < U32_MAX_P1 ? (U32) (n) \
+ : ((n) > 0 ? U32_MAX : 0 /* NaN */)))
+#define I_V(n) ((n) < IV_MAX_P1 ? ((n) < IV_MIN ? IV_MIN : (IV) (n)) \
+ : ((n) < UV_MAX_P1 ? (IV)(UV) (n) \
+ : ((n) > 0 ? (IV)UV_MAX : 0 /* NaN */)))
+#define U_V(n) ((n) < 0.0 ? ((n) < IV_MIN ? (UV) IV_MIN : (UV)(IV) (n)) \
+ : ((n) < UV_MAX_P1 ? (UV) (n) \
+ : ((n) > 0 ? UV_MAX : 0 /* NaN */)))
+#endif
+
+#define U_S(what) ((U16)U_32(what))
+#define U_I(what) ((unsigned int)U_32(what))
+#define U_L(what) U_32(what)
+
+#ifdef HAS_SIGNBIT
+# define Perl_signbit signbit
+#endif
+
+/* These do not care about the fractional part, only about the range. */
+#define NV_WITHIN_IV(nv) (I_V(nv) >= IV_MIN && I_V(nv) <= IV_MAX)
+#define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX)
+
+/* Used with UV/IV arguments: */
+ /* XXXX: need to speed it up */
+#define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv))
+#define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv))
+
+#ifndef MAXSYSFD
+# define MAXSYSFD 2
+#endif
+
+#ifndef __cplusplus
+#if !(defined(UNDER_CE) || defined(SYMBIAN))
+Uid_t getuid (void);
+Uid_t geteuid (void);
+Gid_t getgid (void);
+Gid_t getegid (void);
+#endif
+#endif
+
+#ifndef Perl_debug_log
+# define Perl_debug_log PerlIO_stderr()
+#endif
+
+#ifndef Perl_error_log
+# define Perl_error_log (PL_stderrgv \
+ && isGV(PL_stderrgv) \
+ && GvIOp(PL_stderrgv) \
+ && IoOFP(GvIOp(PL_stderrgv)) \
+ ? IoOFP(GvIOp(PL_stderrgv)) \
+ : PerlIO_stderr())
+#endif
+
+
+#define DEBUG_p_FLAG 0x00000001 /* 1 */
+#define DEBUG_s_FLAG 0x00000002 /* 2 */
+#define DEBUG_l_FLAG 0x00000004 /* 4 */
+#define DEBUG_t_FLAG 0x00000008 /* 8 */
+#define DEBUG_o_FLAG 0x00000010 /* 16 */
+#define DEBUG_c_FLAG 0x00000020 /* 32 */
+#define DEBUG_P_FLAG 0x00000040 /* 64 */
+#define DEBUG_m_FLAG 0x00000080 /* 128 */
+#define DEBUG_f_FLAG 0x00000100 /* 256 */
+#define DEBUG_r_FLAG 0x00000200 /* 512 */
+#define DEBUG_x_FLAG 0x00000400 /* 1024 */
+#define DEBUG_u_FLAG 0x00000800 /* 2048 */
+/* U is reserved for Unofficial, exploratory hacking */
+#define DEBUG_U_FLAG 0x00001000 /* 4096 */
+#define DEBUG_H_FLAG 0x00002000 /* 8192 */
+#define DEBUG_X_FLAG 0x00004000 /* 16384 */
+#define DEBUG_D_FLAG 0x00008000 /* 32768 */
+#define DEBUG_S_FLAG 0x00010000 /* 65536 */
+#define DEBUG_T_FLAG 0x00020000 /* 131072 */
+#define DEBUG_R_FLAG 0x00040000 /* 262144 */
+#define DEBUG_J_FLAG 0x00080000 /* 524288 */
+#define DEBUG_v_FLAG 0x00100000 /*1048576 */
+#define DEBUG_C_FLAG 0x00200000 /*2097152 */
+#define DEBUG_A_FLAG 0x00400000 /*4194304 */
+#define DEBUG_q_FLAG 0x00800000 /*8388608 */
+#define DEBUG_MASK 0x00FFEFFF /* mask of all the standard flags */
+
+#define DEBUG_DB_RECURSE_FLAG 0x40000000
+#define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal
+ that something was done? */
+
+# define DEBUG_p_TEST_ (PL_debug & DEBUG_p_FLAG)
+# define DEBUG_s_TEST_ (PL_debug & DEBUG_s_FLAG)
+# define DEBUG_l_TEST_ (PL_debug & DEBUG_l_FLAG)
+# define DEBUG_t_TEST_ (PL_debug & DEBUG_t_FLAG)
+# define DEBUG_o_TEST_ (PL_debug & DEBUG_o_FLAG)
+# define DEBUG_c_TEST_ (PL_debug & DEBUG_c_FLAG)
+# define DEBUG_P_TEST_ (PL_debug & DEBUG_P_FLAG)
+# define DEBUG_m_TEST_ (PL_debug & DEBUG_m_FLAG)
+# define DEBUG_f_TEST_ (PL_debug & DEBUG_f_FLAG)
+# define DEBUG_r_TEST_ (PL_debug & DEBUG_r_FLAG)
+# define DEBUG_x_TEST_ (PL_debug & DEBUG_x_FLAG)
+# define DEBUG_u_TEST_ (PL_debug & DEBUG_u_FLAG)
+# define DEBUG_U_TEST_ (PL_debug & DEBUG_U_FLAG)
+# define DEBUG_H_TEST_ (PL_debug & DEBUG_H_FLAG)
+# define DEBUG_X_TEST_ (PL_debug & DEBUG_X_FLAG)
+# define DEBUG_D_TEST_ (PL_debug & DEBUG_D_FLAG)
+# define DEBUG_S_TEST_ (PL_debug & DEBUG_S_FLAG)
+# define DEBUG_T_TEST_ (PL_debug & DEBUG_T_FLAG)
+# define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
+# define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
+# define DEBUG_v_TEST_ (PL_debug & DEBUG_v_FLAG)
+# define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG)
+# define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG)
+# define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG)
+# define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)
+# define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_)
+
+#ifdef DEBUGGING
+
+# define DEBUG_p_TEST DEBUG_p_TEST_
+# define DEBUG_s_TEST DEBUG_s_TEST_
+# define DEBUG_l_TEST DEBUG_l_TEST_
+# define DEBUG_t_TEST DEBUG_t_TEST_
+# define DEBUG_o_TEST DEBUG_o_TEST_
+# define DEBUG_c_TEST DEBUG_c_TEST_
+# define DEBUG_P_TEST DEBUG_P_TEST_
+# define DEBUG_m_TEST DEBUG_m_TEST_
+# define DEBUG_f_TEST DEBUG_f_TEST_
+# define DEBUG_r_TEST DEBUG_r_TEST_
+# define DEBUG_x_TEST DEBUG_x_TEST_
+# define DEBUG_u_TEST DEBUG_u_TEST_
+# define DEBUG_U_TEST DEBUG_U_TEST_
+# define DEBUG_H_TEST DEBUG_H_TEST_
+# define DEBUG_X_TEST DEBUG_X_TEST_
+# define DEBUG_D_TEST DEBUG_D_TEST_
+# define DEBUG_S_TEST DEBUG_S_TEST_
+# define DEBUG_T_TEST DEBUG_T_TEST_
+# define DEBUG_R_TEST DEBUG_R_TEST_
+# define DEBUG_J_TEST DEBUG_J_TEST_
+# define DEBUG_v_TEST DEBUG_v_TEST_
+# define DEBUG_C_TEST DEBUG_C_TEST_
+# define DEBUG_A_TEST DEBUG_A_TEST_
+# define DEBUG_q_TEST DEBUG_q_TEST_
+# define DEBUG_Xv_TEST DEBUG_Xv_TEST_
+# define DEBUG_Uv_TEST DEBUG_Uv_TEST_
+
+# define PERL_DEB(a) a
+# define PERL_DEBUG(a) if (PL_debug) a
+# define DEBUG_p(a) if (DEBUG_p_TEST) a
+# define DEBUG_s(a) if (DEBUG_s_TEST) a
+# define DEBUG_l(a) if (DEBUG_l_TEST) a
+# define DEBUG_t(a) if (DEBUG_t_TEST) a
+# define DEBUG_o(a) if (DEBUG_o_TEST) a
+# define DEBUG_c(a) if (DEBUG_c_TEST) a
+# define DEBUG_P(a) if (DEBUG_P_TEST) a
+
+ /* Temporarily turn off memory debugging in case the a
+ * does memory allocation, either directly or indirectly. */
+# define DEBUG_m(a) \
+ STMT_START { \
+ if (PERL_GET_INTERP) { dTHX; if (DEBUG_m_TEST) {PL_debug&=~DEBUG_m_FLAG; a; PL_debug|=DEBUG_m_FLAG;} } \
+ } STMT_END
+
+# define DEBUG__(t, a) \
+ STMT_START { \
+ if (t) STMT_START {a;} STMT_END; \
+ } STMT_END
+
+# define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a)
+#ifndef PERL_EXT_RE_BUILD
+# define DEBUG_r(a) DEBUG__(DEBUG_r_TEST, a)
+#else
+# define DEBUG_r(a) STMT_START {a;} STMT_END
+#endif /* PERL_EXT_RE_BUILD */
+# define DEBUG_x(a) DEBUG__(DEBUG_x_TEST, a)
+# define DEBUG_u(a) DEBUG__(DEBUG_u_TEST, a)
+# define DEBUG_U(a) DEBUG__(DEBUG_U_TEST, a)
+# define DEBUG_H(a) DEBUG__(DEBUG_H_TEST, a)
+# define DEBUG_X(a) DEBUG__(DEBUG_X_TEST, a)
+# define DEBUG_D(a) DEBUG__(DEBUG_D_TEST, a)
+# define DEBUG_Xv(a) DEBUG__(DEBUG_Xv_TEST, a)
+# define DEBUG_Uv(a) DEBUG__(DEBUG_Uv_TEST, a)
+
+# define DEBUG_S(a)
+
+# define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
+# define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
+# define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a)
+# define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a)
+# define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a)
+# define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a)
+
+#else /* DEBUGGING */
+
+# define DEBUG_p_TEST (0)
+# define DEBUG_s_TEST (0)
+# define DEBUG_l_TEST (0)
+# define DEBUG_t_TEST (0)
+# define DEBUG_o_TEST (0)
+# define DEBUG_c_TEST (0)
+# define DEBUG_P_TEST (0)
+# define DEBUG_m_TEST (0)
+# define DEBUG_f_TEST (0)
+# define DEBUG_r_TEST (0)
+# define DEBUG_x_TEST (0)
+# define DEBUG_u_TEST (0)
+# define DEBUG_U_TEST (0)
+# define DEBUG_H_TEST (0)
+# define DEBUG_X_TEST (0)
+# define DEBUG_D_TEST (0)
+# define DEBUG_S_TEST (0)
+# define DEBUG_T_TEST (0)
+# define DEBUG_R_TEST (0)
+# define DEBUG_J_TEST (0)
+# define DEBUG_v_TEST (0)
+# define DEBUG_C_TEST (0)
+# define DEBUG_A_TEST (0)
+# define DEBUG_q_TEST (0)
+# define DEBUG_Xv_TEST (0)
+# define DEBUG_Uv_TEST (0)
+
+# define PERL_DEB(a)
+# define PERL_DEBUG(a)
+# define DEBUG_p(a)
+# define DEBUG_s(a)
+# define DEBUG_l(a)
+# define DEBUG_t(a)
+# define DEBUG_o(a)
+# define DEBUG_c(a)
+# define DEBUG_P(a)
+# define DEBUG_m(a)
+# define DEBUG_f(a)
+# define DEBUG_r(a)
+# define DEBUG_x(a)
+# define DEBUG_u(a)
+# define DEBUG_U(a)
+# define DEBUG_H(a)
+# define DEBUG_X(a)
+# define DEBUG_D(a)
+# define DEBUG_S(a)
+# define DEBUG_T(a)
+# define DEBUG_R(a)
+# define DEBUG_v(a)
+# define DEBUG_C(a)
+# define DEBUG_A(a)
+# define DEBUG_q(a)
+# define DEBUG_Xv(a)
+# define DEBUG_Uv(a)
+#endif /* DEBUGGING */
+
+
+#define DEBUG_SCOPE(where) \
+ DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \
+ where, (long)PL_scopestack_ix, __FILE__, __LINE__)));
+
+
+
+
+/* These constants should be used in preference to raw characters
+ * when using magic. Note that some perl guts still assume
+ * certain character properties of these constants, namely that
+ * isUPPER() and toLOWER() may do useful mappings.
+ *
+ * Update the magic_names table in dump.c when adding/amending these
+ */
+
+#define PERL_MAGIC_sv '\0' /* Special scalar variable */
+#define PERL_MAGIC_overload 'A' /* %OVERLOAD hash */
+#define PERL_MAGIC_overload_elem 'a' /* %OVERLOAD hash element */
+#define PERL_MAGIC_overload_table 'c' /* Holds overload table (AMT) on stash */
+#define PERL_MAGIC_bm 'B' /* Boyer-Moore (fast string search) */
+#define PERL_MAGIC_regdata 'D' /* Regex match position data
+ (@+ and @- vars) */
+#define PERL_MAGIC_regdatum 'd' /* Regex match position data element */
+#define PERL_MAGIC_env 'E' /* %ENV hash */
+#define PERL_MAGIC_envelem 'e' /* %ENV hash element */
+#define PERL_MAGIC_fm 'f' /* Formline ('compiled' format) */
+#define PERL_MAGIC_regex_global 'g' /* m//g target / study()ed string */
+#define PERL_MAGIC_hints 'H' /* %^H hash */
+#define PERL_MAGIC_hintselem 'h' /* %^H hash element */
+#define PERL_MAGIC_isa 'I' /* @ISA array */
+#define PERL_MAGIC_isaelem 'i' /* @ISA array element */
+#define PERL_MAGIC_nkeys 'k' /* scalar(keys()) lvalue */
+#define PERL_MAGIC_dbfile 'L' /* Debugger %_<filename */
+#define PERL_MAGIC_dbline 'l' /* Debugger %_<filename element */
+#define PERL_MAGIC_shared 'N' /* Shared between threads */
+#define PERL_MAGIC_shared_scalar 'n' /* Shared between threads */
+#define PERL_MAGIC_collxfrm 'o' /* Locale transformation */
+#define PERL_MAGIC_tied 'P' /* Tied array or hash */
+#define PERL_MAGIC_tiedelem 'p' /* Tied array or hash element */
+#define PERL_MAGIC_tiedscalar 'q' /* Tied scalar or handle */
+#define PERL_MAGIC_qr 'r' /* precompiled qr// regex */
+#define PERL_MAGIC_sig 'S' /* %SIG hash */
+#define PERL_MAGIC_sigelem 's' /* %SIG hash element */
+#define PERL_MAGIC_taint 't' /* Taintedness */
+#define PERL_MAGIC_uvar 'U' /* Available for use by extensions */
+#define PERL_MAGIC_uvar_elem 'u' /* Reserved for use by extensions */
+#define PERL_MAGIC_vec 'v' /* vec() lvalue */
+#define PERL_MAGIC_vstring 'V' /* SV was vstring literal */
+#define PERL_MAGIC_utf8 'w' /* Cached UTF-8 information */
+#define PERL_MAGIC_substr 'x' /* substr() lvalue */
+#define PERL_MAGIC_defelem 'y' /* Shadow "foreach" iterator variable /
+ smart parameter vivification */
+#define PERL_MAGIC_arylen '#' /* Array length ($#ary) */
+#define PERL_MAGIC_pos '.' /* pos() lvalue */
+#define PERL_MAGIC_backref '<' /* for weak ref data */
+#define PERL_MAGIC_symtab ':' /* extra data for symbol tables */
+#define PERL_MAGIC_rhash '%' /* extra data for restricted hashes */
+#define PERL_MAGIC_arylen_p '@' /* to move arylen out of XPVAV */
+#define PERL_MAGIC_ext '~' /* Available for use by extensions */
+
+
+#ifndef assert /* <assert.h> might have been included somehow */
+#define assert(what) PERL_DEB( \
+ ((what) ? ((void) 0) : \
+ (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \
+ "\", line %d", STRINGIFY(what), __LINE__), \
+ (void) 0)))
+#endif
+
+struct ufuncs {
+ I32 (*uf_val)(pTHX_ IV, SV*);
+ I32 (*uf_set)(pTHX_ IV, SV*);
+ IV uf_index;
+};
+
+/* In pre-5.7-Perls the PERL_MAGIC_uvar magic didn't get the thread context.
+ * XS code wanting to be backward compatible can do something
+ * like the following:
+
+#ifndef PERL_MG_UFUNC
+#define PERL_MG_UFUNC(name,ix,sv) I32 name(IV ix, SV *sv)
+#endif
+
+static PERL_MG_UFUNC(foo_get, index, val)
+{
+ sv_setsv(val, ...);
+ return TRUE;
+}
+
+-- Doug MacEachern
+
+*/
+
+#ifndef PERL_MG_UFUNC
+#define PERL_MG_UFUNC(name,ix,sv) I32 name(pTHX_ IV ix, SV *sv)
+#endif
+
+/* Fix these up for __STDC__ */
+#ifndef DONT_DECLARE_STD
+char *mktemp (char*);
+#ifndef atof
+double atof (const char*);
+#endif
+#endif
+
+#ifndef STANDARD_C
+/* All of these are in stdlib.h or time.h for ANSI C */
+Time_t time();
+struct tm *gmtime(), *localtime();
+#if defined(OEMVS) || defined(__OPEN_VM)
+char *(strchr)(), *(strrchr)();
+char *(strcpy)(), *(strcat)();
+#else
+char *strchr(), *strrchr();
+char *strcpy(), *strcat();
+#endif
+#endif /* ! STANDARD_C */
+
+
+#ifdef I_MATH
+# include <math.h>
+#else
+START_EXTERN_C
+ double exp (double);
+ double log (double);
+ double log10 (double);
+ double sqrt (double);
+ double frexp (double,int*);
+ double ldexp (double,int);
+ double modf (double,double*);
+ double sin (double);
+ double cos (double);
+ double atan2 (double,double);
+ double pow (double,double);
+END_EXTERN_C
+#endif
+
+#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(LDBL_INFINITY)
+# define NV_INF LDBL_INFINITY
+#endif
+#if !defined(NV_INF) && defined(DBL_INFINITY)
+# define NV_INF (NV)DBL_INFINITY
+#endif
+#if !defined(NV_INF) && defined(INFINITY)
+# define NV_INF (NV)INFINITY
+#endif
+#if !defined(NV_INF) && defined(INF)
+# define NV_INF (NV)INF
+#endif
+#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
+# define NV_INF (NV)HUGE_VALL
+#endif
+#if !defined(NV_INF) && defined(HUGE_VAL)
+# define NV_INF (NV)HUGE_VAL
+#endif
+
+#if !defined(NV_NAN) && defined(USE_LONG_DOUBLE)
+# if !defined(NV_NAN) && defined(LDBL_NAN)
+# define NV_NAN LDBL_NAN
+# endif
+# if !defined(NV_NAN) && defined(LDBL_QNAN)
+# define NV_NAN LDBL_QNAN
+# endif
+# if !defined(NV_NAN) && defined(LDBL_SNAN)
+# define NV_NAN LDBL_SNAN
+# endif
+#endif
+#if !defined(NV_NAN) && defined(DBL_NAN)
+# define NV_NAN (NV)DBL_NAN
+#endif
+#if !defined(NV_NAN) && defined(DBL_QNAN)
+# define NV_NAN (NV)DBL_QNAN
+#endif
+#if !defined(NV_NAN) && defined(DBL_SNAN)
+# define NV_NAN (NV)DBL_SNAN
+#endif
+#if !defined(NV_NAN) && defined(QNAN)
+# define NV_NAN (NV)QNAN
+#endif
+#if !defined(NV_NAN) && defined(SNAN)
+# define NV_NAN (NV)SNAN
+#endif
+#if !defined(NV_NAN) && defined(NAN)
+# define NV_NAN (NV)NAN
+#endif
+
+#ifndef __cplusplus
+# if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */
+char *crypt (); /* Maybe more hosts will need the unprototyped version */
+# else
+# if !defined(WIN32) && !defined(VMS)
+#ifndef crypt
+char *crypt (const char*, const char*);
+#endif
+# endif /* !WIN32 */
+# endif /* !NeXT && !__NeXT__ */
+# ifndef DONT_DECLARE_STD
+# ifndef getenv
+char *getenv (const char*);
+# endif /* !getenv */
+# if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux)
+# ifdef _FILE_OFFSET_BITS
+# if _FILE_OFFSET_BITS == 64
+Off_t lseek (int,Off_t,int);
+# endif
+# endif
+# endif
+# endif /* !DONT_DECLARE_STD */
+#ifndef getlogin
+char *getlogin (void);
+#endif
+#endif /* !__cplusplus */
+
+/* Fixme on VMS. This needs to be a run-time, not build time options */
+/* Also rename() is affected by this */
+#ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */
+#define UNLINK unlnk
+I32 unlnk (pTHX_ const char*);
+#else
+#define UNLINK PerlLIO_unlink
+#endif
+
+/* some versions of glibc are missing the setresuid() proto */
+#if defined(HAS_SETRESUID) && !defined(HAS_SETRESUID_PROTO)
+int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+#endif
+/* some versions of glibc are missing the setresgid() proto */
+#if defined(HAS_SETRESGID) && !defined(HAS_SETRESGID_PROTO)
+int setresgid(gid_t rgid, gid_t egid, gid_t sgid);
+#endif
+
+#ifndef HAS_SETREUID
+# ifdef HAS_SETRESUID
+# define setreuid(r,e) setresuid(r,e,(Uid_t)-1)
+# define HAS_SETREUID
+# endif
+#endif
+#ifndef HAS_SETREGID
+# ifdef HAS_SETRESGID
+# define setregid(r,e) setresgid(r,e,(Gid_t)-1)
+# define HAS_SETREGID
+# endif
+#endif
+
+/* Sighandler_t defined in iperlsys.h */
+
+#ifdef HAS_SIGACTION
+typedef struct sigaction Sigsave_t;
+#else
+typedef Sighandler_t Sigsave_t;
+#endif
+
+#define SCAN_DEF 0
+#define SCAN_TR 1
+#define SCAN_REPL 2
+
+#ifdef DEBUGGING
+# ifndef register
+# define register
+# endif
+# define RUNOPS_DEFAULT Perl_runops_debug
+#else
+# define RUNOPS_DEFAULT Perl_runops_standard
+#endif
+
+#ifdef USE_PERLIO
+EXTERN_C void PerlIO_teardown(void);
+# ifdef USE_ITHREADS
+# define PERLIO_INIT MUTEX_INIT(&PL_perlio_mutex)
+# define PERLIO_TERM \
+ STMT_START { \
+ PerlIO_teardown(); \
+ MUTEX_DESTROY(&PL_perlio_mutex);\
+ } STMT_END
+# else
+# define PERLIO_INIT
+# define PERLIO_TERM PerlIO_teardown()
+# endif
+#else
+# define PERLIO_INIT
+# define PERLIO_TERM
+#endif
+
+#ifdef MYMALLOC
+# ifdef MUTEX_INIT_CALLS_MALLOC
+# define MALLOC_INIT \
+ STMT_START { \
+ PL_malloc_mutex = NULL; \
+ MUTEX_INIT(&PL_malloc_mutex); \
+ } STMT_END
+# define MALLOC_TERM \
+ STMT_START { \
+ perl_mutex tmp = PL_malloc_mutex; \
+ PL_malloc_mutex = NULL; \
+ MUTEX_DESTROY(&tmp); \
+ } STMT_END
+# else
+# define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex)
+# define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex)
+# endif
+#else
+# define MALLOC_INIT
+# define MALLOC_TERM
+#endif
+
+#if defined(PERL_IMPLICIT_CONTEXT)
+
+struct perl_memory_debug_header;
+struct perl_memory_debug_header {
+ tTHX interpreter;
+# ifdef PERL_POISON
+ MEM_SIZE size;
+# endif
+ struct perl_memory_debug_header *prev;
+ struct perl_memory_debug_header *next;
+};
+
+# define sTHX (sizeof(struct perl_memory_debug_header) + \
+ (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \
+ %MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
+
+#else
+# define sTHX 0
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+# define INIT_TRACK_MEMPOOL(header, interp) \
+ STMT_START { \
+ (header).interpreter = (interp); \
+ (header).prev = (header).next = &(header); \
+ } STMT_END
+# else
+# define INIT_TRACK_MEMPOOL(header, interp)
+#endif
+
+#ifdef I_MALLOCMALLOC
+/* Needed for malloc_size(), malloc_good_size() on some systems */
+# include <malloc/malloc.h>
+#endif
+
+#ifdef MYMALLOC
+# define Perl_safesysmalloc_size(where) Perl_malloced_size(where)
+#else
+# ifdef HAS_MALLOC_SIZE
+# ifdef PERL_TRACK_MEMPOOL
+# define Perl_safesysmalloc_size(where) \
+ (malloc_size(((char *)(where)) - sTHX) - sTHX)
+# else
+# define Perl_safesysmalloc_size(where) malloc_size(where)
+# endif
+# endif
+# ifdef HAS_MALLOC_GOOD_SIZE
+# ifdef PERL_TRACK_MEMPOOL
+# define Perl_malloc_good_size(how_much) \
+ (malloc_good_size((how_much) + sTHX) - sTHX)
+# else
+# define Perl_malloc_good_size(how_much) malloc_good_size(how_much)
+# endif
+# else
+/* Having this as the identity operation makes some code simpler. */
+# define Perl_malloc_good_size(how_much) (how_much)
+# endif
+#endif
+
+typedef int (CPERLscope(*runops_proc_t)) (pTHX);
+typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv);
+typedef int (CPERLscope(*thrhook_proc_t)) (pTHX);
+typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX);
+typedef bool (CPERLscope(*destroyable_proc_t)) (pTHX_ SV *sv);
+
+/* _ (for $_) must be first in the following list (DEFSV requires it) */
+#define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@"
+
+/* NeXT has problems with crt0.o globals */
+#if defined(__DYNAMIC__) && \
+ (defined(NeXT) || defined(__NeXT__) || defined(PERL_DARWIN))
+# if defined(NeXT) || defined(__NeXT)
+# include <mach-o/dyld.h>
+# define environ (*environ_pointer)
+EXT char *** environ_pointer;
+# else
+# if defined(PERL_DARWIN) && defined(PERL_CORE)
+# include <crt_externs.h> /* for the env array */
+# define environ (*_NSGetEnviron())
+# endif
+# endif
+#else
+ /* VMS and some other platforms don't use the environ array */
+# ifdef USE_ENVIRON_ARRAY
+# if !defined(DONT_DECLARE_STD) || \
+ (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \
+ defined(__sgi) || \
+ defined(__DGUX)
+extern char ** environ; /* environment variables supplied via exec */
+# endif
+# endif
+#endif
+
+START_EXTERN_C
+
+/* handy constants */
+EXTCONST char PL_warn_uninit[]
+ INIT("Use of uninitialized value%s%s%s");
+EXTCONST char PL_warn_nosemi[]
+ INIT("Semicolon seems to be missing");
+EXTCONST char PL_warn_reserved[]
+ INIT("Unquoted string \"%s\" may clash with future reserved word");
+EXTCONST char PL_warn_nl[]
+ INIT("Unsuccessful %s on filename containing newline");
+EXTCONST char PL_no_wrongref[]
+ INIT("Can't use %s ref as %s ref");
+EXTCONST char PL_no_symref[]
+ INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use");
+EXTCONST char PL_no_symref_sv[]
+ INIT("Can't use string (\"%" SVf32 "\") as %s ref while \"strict refs\" in use");
+EXTCONST char PL_no_usym[]
+ INIT("Can't use an undefined value as %s reference");
+EXTCONST char PL_no_aelem[]
+ INIT("Modification of non-creatable array value attempted, subscript %d");
+EXTCONST char PL_no_helem_sv[]
+ INIT("Modification of non-creatable hash value attempted, subscript \"%"SVf"\"");
+EXTCONST char PL_no_modify[]
+ INIT("Modification of a read-only value attempted");
+EXTCONST char PL_no_mem[]
+ INIT("Out of memory!\n");
+EXTCONST char PL_no_security[]
+ INIT("Insecure dependency in %s%s");
+EXTCONST char PL_no_sock_func[]
+ INIT("Unsupported socket function \"%s\" called");
+EXTCONST char PL_no_dir_func[]
+ INIT("Unsupported directory function \"%s\" called");
+EXTCONST char PL_no_func[]
+ INIT("The %s function is unimplemented");
+EXTCONST char PL_no_myglob[]
+ INIT("\"%s\" variable %s can't be in a package");
+EXTCONST char PL_no_localize_ref[]
+ INIT("Can't localize through a reference");
+EXTCONST char PL_memory_wrap[]
+ INIT("panic: memory wrap");
+
+#ifdef CSH
+EXTCONST char PL_cshname[]
+ INIT(CSH);
+# define PL_cshlen (sizeof(CSH "") - 1)
+#endif
+
+EXTCONST char PL_uuemap[65]
+ INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_");
+
+#ifdef DOINIT
+EXTCONST char PL_uudmap[256] =
+#include "uudmap.h"
+;
+EXTCONST char* const PL_sig_name[] = { SIG_NAME };
+EXTCONST int PL_sig_num[] = { SIG_NUM };
+#else
+EXTCONST char PL_uudmap[256];
+EXTCONST char* const PL_sig_name[];
+EXTCONST int PL_sig_num[];
+#endif
+
+/* fast conversion and case folding tables */
+
+#ifdef DOINIT
+#ifdef EBCDIC
+EXTCONST unsigned char PL_fold[] = { /* fast EBCDIC case folding table */
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 65, 66, 67, 68, 69, 70, 71,
+ 72, 73, 74, 75, 76, 77, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87,
+ 88, 89, 90, 91, 92, 93, 94, 95,
+ 96, 97, 98, 99, 100, 101, 102, 103,
+ 104, 105, 106, 107, 108, 109, 110, 111,
+ 112, 113, 114, 115, 116, 117, 118, 119,
+ 120, 121, 122, 123, 124, 125, 126, 127,
+ 128, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 138, 139, 140, 141, 142, 143,
+ 144, 'J', 'K', 'L', 'M', 'N', 'O', 'P',
+ 'Q', 'R', 154, 155, 156, 157, 158, 159,
+ 160, 161, 'S', 'T', 'U', 'V', 'W', 'X',
+ 'Y', 'Z', 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 202, 203, 204, 205, 206, 207,
+ 208, 'j', 'k', 'l', 'm', 'n', 'o', 'p',
+ 'q', 'r', 218, 219, 220, 221, 222, 223,
+ 224, 225, 's', 't', 'u', 'v', 'w', 'x',
+ 'y', 'z', 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#else /* ascii rather than ebcdic */
+EXTCONST unsigned char PL_fold[] = {
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#endif /* !EBCDIC */
+#else
+EXTCONST unsigned char PL_fold[];
+#endif
+
+#ifndef PERL_GLOBAL_STRUCT /* or perlvars.h */
+#ifdef DOINIT
+EXT unsigned char PL_fold_locale[] = { /* Unfortunately not EXTCONST. */
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#else
+EXT unsigned char PL_fold_locale[]; /* Unfortunately not EXTCONST. */
+#endif
+#endif /* !PERL_GLOBAL_STRUCT */
+
+#ifdef DOINIT
+#ifdef EBCDIC
+EXTCONST unsigned char PL_freq[] = {/* EBCDIC frequencies for mixed English/C */
+ 1, 2, 84, 151, 154, 155, 156, 157,
+ 165, 246, 250, 3, 158, 7, 18, 29,
+ 40, 51, 62, 73, 85, 96, 107, 118,
+ 129, 140, 147, 148, 149, 150, 152, 153,
+ 255, 6, 8, 9, 10, 11, 12, 13,
+ 14, 15, 24, 25, 26, 27, 28, 226,
+ 29, 30, 31, 32, 33, 43, 44, 45,
+ 46, 47, 48, 49, 50, 76, 77, 78,
+ 79, 80, 81, 82, 83, 84, 85, 86,
+ 87, 94, 95, 234, 181, 233, 187, 190,
+ 180, 96, 97, 98, 99, 100, 101, 102,
+ 104, 112, 182, 174, 236, 232, 229, 103,
+ 228, 226, 114, 115, 116, 117, 118, 119,
+ 120, 121, 122, 235, 176, 230, 194, 162,
+ 130, 131, 132, 133, 134, 135, 136, 137,
+ 138, 139, 201, 205, 163, 217, 220, 224,
+ 5, 248, 227, 244, 242, 255, 241, 231,
+ 240, 253, 16, 197, 19, 20, 21, 187,
+ 23, 169, 210, 245, 237, 249, 247, 239,
+ 168, 252, 34, 196, 36, 37, 38, 39,
+ 41, 42, 251, 254, 238, 223, 221, 213,
+ 225, 177, 52, 53, 54, 55, 56, 57,
+ 58, 59, 60, 61, 63, 64, 65, 66,
+ 67, 68, 69, 70, 71, 72, 74, 75,
+ 205, 208, 186, 202, 200, 218, 198, 179,
+ 178, 214, 88, 89, 90, 91, 92, 93,
+ 217, 166, 170, 207, 199, 209, 206, 204,
+ 160, 212, 105, 106, 108, 109, 110, 111,
+ 203, 113, 216, 215, 192, 175, 193, 243,
+ 172, 161, 123, 124, 125, 126, 127, 128,
+ 222, 219, 211, 195, 188, 193, 185, 184,
+ 191, 183, 141, 142, 143, 144, 145, 146
+};
+#else /* ascii rather than ebcdic */
+EXTCONST unsigned char PL_freq[] = { /* letter frequencies for mixed English/C */
+ 1, 2, 84, 151, 154, 155, 156, 157,
+ 165, 246, 250, 3, 158, 7, 18, 29,
+ 40, 51, 62, 73, 85, 96, 107, 118,
+ 129, 140, 147, 148, 149, 150, 152, 153,
+ 255, 182, 224, 205, 174, 176, 180, 217,
+ 233, 232, 236, 187, 235, 228, 234, 226,
+ 222, 219, 211, 195, 188, 193, 185, 184,
+ 191, 183, 201, 229, 181, 220, 194, 162,
+ 163, 208, 186, 202, 200, 218, 198, 179,
+ 178, 214, 166, 170, 207, 199, 209, 206,
+ 204, 160, 212, 216, 215, 192, 175, 173,
+ 243, 172, 161, 190, 203, 189, 164, 230,
+ 167, 248, 227, 244, 242, 255, 241, 231,
+ 240, 253, 169, 210, 245, 237, 249, 247,
+ 239, 168, 252, 251, 254, 238, 223, 221,
+ 213, 225, 177, 197, 171, 196, 159, 4,
+ 5, 6, 8, 9, 10, 11, 12, 13,
+ 14, 15, 16, 17, 19, 20, 21, 22,
+ 23, 24, 25, 26, 27, 28, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 41, 42, 43, 44, 45, 46, 47, 48,
+ 49, 50, 52, 53, 54, 55, 56, 57,
+ 58, 59, 60, 61, 63, 64, 65, 66,
+ 67, 68, 69, 70, 71, 72, 74, 75,
+ 76, 77, 78, 79, 80, 81, 82, 83,
+ 86, 87, 88, 89, 90, 91, 92, 93,
+ 94, 95, 97, 98, 99, 100, 101, 102,
+ 103, 104, 105, 106, 108, 109, 110, 111,
+ 112, 113, 114, 115, 116, 117, 119, 120,
+ 121, 122, 123, 124, 125, 126, 127, 128,
+ 130, 131, 132, 133, 134, 135, 136, 137,
+ 138, 139, 141, 142, 143, 144, 145, 146
+};
+#endif
+#else
+EXTCONST unsigned char PL_freq[];
+#endif
+
+#ifdef DEBUGGING
+#ifdef DOINIT
+EXTCONST char* const PL_block_type[] = {
+ "NULL",
+ "SUB",
+ "EVAL",
+ "LOOP",
+ "SUBST",
+ "BLOCK",
+ "FORMAT",
+ "GIVEN",
+ "WHEN"
+};
+#else
+EXTCONST char* PL_block_type[];
+#endif
+#endif
+
+/* These are all the compile time options that affect binary compatibility.
+ Other compile time options that are binary compatible are in perl.c
+ Both are combined for the output of perl -V
+ However, this string will be embedded in any shared perl library, which will
+ allow us add a comparison check in perlmain.c in the near future. */
+#ifdef DOINIT
+EXTCONST char PL_bincompat_options[] =
+# ifdef DEBUG_LEAKING_SCALARS
+ " DEBUG_LEAKING_SCALARS"
+# endif
+# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ " DEBUG_LEAKING_SCALARS_FORK_DUMP"
+# endif
+# ifdef FAKE_THREADS
+ " FAKE_THREADS"
+# endif
+# ifdef MULTIPLICITY
+ " MULTIPLICITY"
+# endif
+# ifdef MYMALLOC
+ " MYMALLOC"
+# endif
+# ifdef PERL_DEBUG_READONLY_OPS
+ " PERL_DEBUG_READONLY_OPS"
+# endif
+# ifdef PERL_GLOBAL_STRUCT
+ " PERL_GLOBAL_STRUCT"
+# endif
+# ifdef PERL_IMPLICIT_CONTEXT
+ " PERL_IMPLICIT_CONTEXT"
+# endif
+# ifdef PERL_IMPLICIT_SYS
+ " PERL_IMPLICIT_SYS"
+# endif
+# ifdef PERL_MAD
+ " PERL_MAD"
+# endif
+# ifdef PERL_NEED_APPCTX
+ " PERL_NEED_APPCTX"
+# endif
+# ifdef PERL_NEED_TIMESBASE
+ " PERL_NEED_TIMESBASE"
+# endif
+# ifdef PERL_OLD_COPY_ON_WRITE
+ " PERL_OLD_COPY_ON_WRITE"
+# endif
+# ifdef PERL_POISON
+ " PERL_POISON"
+# endif
+# ifdef PERL_TRACK_MEMPOOL
+ " PERL_TRACK_MEMPOOL"
+# endif
+# ifdef PERL_USES_PL_PIDSTATUS
+ " PERL_USES_PL_PIDSTATUS"
+# endif
+# ifdef PL_OP_SLAB_ALLOC
+ " PL_OP_SLAB_ALLOC"
+# endif
+# ifdef THREADS_HAVE_PIDS
+ " THREADS_HAVE_PIDS"
+# endif
+# ifdef USE_64_BIT_ALL
+ " USE_64_BIT_ALL"
+# endif
+# ifdef USE_64_BIT_INT
+ " USE_64_BIT_INT"
+# endif
+# ifdef USE_IEEE
+ " USE_IEEE"
+# endif
+# ifdef USE_ITHREADS
+ " USE_ITHREADS"
+# endif
+# ifdef USE_LARGE_FILES
+ " USE_LARGE_FILES"
+# endif
+# ifdef USE_LONG_DOUBLE
+ " USE_LONG_DOUBLE"
+# endif
+# ifdef USE_PERLIO
+ " USE_PERLIO"
+# endif
+# ifdef USE_REENTRANT_API
+ " USE_REENTRANT_API"
+# endif
+# ifdef USE_SFIO
+ " USE_SFIO"
+# endif
+# ifdef USE_SOCKS
+ " USE_SOCKS"
+# endif
+# ifdef VMS_DO_SOCKETS
+ " VMS_DO_SOCKETS"
+# ifdef DECCRTL_SOCKETS
+ " DECCRTL_SOCKETS"
+# endif
+# endif
+# ifdef VMS_WE_ARE_CASE_SENSITIVE
+ " VMS_SYMBOL_CASE_AS_IS"
+# endif
+ "";
+#else
+EXTCONST char PL_bincompat_options[];
+#endif
+
+END_EXTERN_C
+
+/*****************************************************************************/
+/* This lexer/parser stuff is currently global since yacc is hard to reenter */
+/*****************************************************************************/
+/* XXX This needs to be revisited, since BEGIN makes yacc re-enter... */
+
+#ifdef __Lynx__
+/* LynxOS defines these in scsi.h which is included via ioctl.h */
+#ifdef FORMAT
+#undef FORMAT
+#endif
+#ifdef SPACE
+#undef SPACE
+#endif
+#endif
+
+#define LEX_NOTPARSING 11 /* borrowed from toke.c */
+
+typedef enum {
+ XOPERATOR,
+ XTERM,
+ XREF,
+ XSTATE,
+ XBLOCK,
+ XATTRBLOCK,
+ XATTRTERM,
+ XTERMBLOCK,
+ XTERMORDORDOR /* evil hack */
+ /* update exp_name[] in toke.c if adding to this enum */
+} expectation;
+
+enum { /* pass one of these to get_vtbl */
+ want_vtbl_sv,
+ want_vtbl_env,
+ want_vtbl_envelem,
+ want_vtbl_sig,
+ want_vtbl_sigelem,
+ want_vtbl_pack,
+ want_vtbl_packelem,
+ want_vtbl_dbline,
+ want_vtbl_isa,
+ want_vtbl_isaelem,
+ want_vtbl_arylen,
+ want_vtbl_glob,
+ want_vtbl_mglob,
+ want_vtbl_nkeys,
+ want_vtbl_taint,
+ want_vtbl_substr,
+ want_vtbl_vec,
+ want_vtbl_pos,
+ want_vtbl_bm,
+ want_vtbl_fm,
+ want_vtbl_uvar,
+ want_vtbl_defelem,
+ want_vtbl_regexp,
+ want_vtbl_collxfrm,
+ want_vtbl_amagic,
+ want_vtbl_amagicelem,
+ want_vtbl_regdata,
+ want_vtbl_regdatum,
+ want_vtbl_backref,
+ want_vtbl_utf8,
+ want_vtbl_symtab,
+ want_vtbl_arylen_p,
+ want_vtbl_hintselem
+};
+
+
+/* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer
+ special and there is no need for HINT_PRIVATE_MASK for COPs
+ However, bitops store HINT_INTEGER in their op_private. */
+#define HINT_INTEGER 0x00000001 /* integer pragma */
+#define HINT_STRICT_REFS 0x00000002 /* strict pragma */
+#define HINT_LOCALE 0x00000004 /* locale pragma */
+#define HINT_BYTES 0x00000008 /* bytes pragma */
+#define HINT_ARYBASE 0x00000010 /* $[ is non-zero */
+ /* Note: 20,40,80 used for NATIVE_HINTS */
+ /* currently defined by vms/vmsish.h */
+
+#define HINT_BLOCK_SCOPE 0x00000100
+#define HINT_STRICT_SUBS 0x00000200 /* strict pragma */
+#define HINT_STRICT_VARS 0x00000400 /* strict pragma */
+
+/* The HINT_NEW_* constants are used by the overload pragma */
+#define HINT_NEW_INTEGER 0x00001000
+#define HINT_NEW_FLOAT 0x00002000
+#define HINT_NEW_BINARY 0x00004000
+#define HINT_NEW_STRING 0x00008000
+#define HINT_NEW_RE 0x00010000
+#define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */
+#define HINT_LEXICAL_IO_IN 0x00040000 /* ${^OPEN} is set for input */
+#define HINT_LEXICAL_IO_OUT 0x00080000 /* ${^OPEN} is set for output */
+
+#define HINT_RE_TAINT 0x00100000 /* re pragma */
+#define HINT_RE_EVAL 0x00200000 /* re pragma */
+
+#define HINT_FILETEST_ACCESS 0x00400000 /* filetest pragma */
+#define HINT_UTF8 0x00800000 /* utf8 pragma */
+
+#define HINT_NO_AMAGIC 0x01000000 /* overloading pragma */
+
+/* The following are stored in $^H{sort}, not in PL_hints */
+#define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */
+#define HINT_SORT_QUICKSORT 0x00000001
+#define HINT_SORT_MERGESORT 0x00000002
+#define HINT_SORT_STABLE 0x00000100 /* sort styles (currently one) */
+
+/* Various states of the input record separator SV (rs) */
+#define RsSNARF(sv) (! SvOK(sv))
+#define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv)))
+#define RsPARA(sv) (SvPOK(sv) && ! SvCUR(sv))
+#define RsRECORD(sv) (SvROK(sv) && (SvIV(SvRV(sv)) > 0))
+
+/* A struct for keeping various DEBUGGING related stuff,
+ * neatly packed. Currently only scratch variables for
+ * constructing debug output are included. Needed always,
+ * not just when DEBUGGING, though, because of the re extension. c*/
+struct perl_debug_pad {
+ SV pad[3];
+};
+
+#define PERL_DEBUG_PAD(i) &(PL_debug_pad.pad[i])
+#define PERL_DEBUG_PAD_ZERO(i) (SvPVX(PERL_DEBUG_PAD(i))[0] = 0, \
+ (((XPV*) SvANY(PERL_DEBUG_PAD(i)))->xpv_cur = 0), \
+ PERL_DEBUG_PAD(i))
+
+/* Enable variables which are pointers to functions */
+typedef void (CPERLscope(*peep_t))(pTHX_ OP* o);
+typedef regexp*(CPERLscope(*regcomp_t)) (pTHX_ char* exp, char* xend, PMOP* pm);
+typedef I32 (CPERLscope(*regexec_t)) (pTHX_ regexp* prog, char* stringarg,
+ char* strend, char* strbeg, I32 minend,
+ SV* screamer, void* data, U32 flags);
+typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv,
+ char *strpos, char *strend,
+ U32 flags,
+ re_scream_pos_data *d);
+typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog);
+typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r);
+typedef regexp*(CPERLscope(*regdupe_t)) (pTHX_ const regexp* r, CLONE_PARAMS *param);
+
+typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*);
+typedef void (*DESTRUCTORFUNC_t) (pTHX_ void*);
+typedef void (*SVFUNC_t) (pTHX_ SV*);
+typedef I32 (*SVCOMPARE_t) (pTHX_ SV*, SV*);
+typedef void (*XSINIT_t) (pTHX);
+typedef void (*ATEXIT_t) (pTHX_ void*);
+typedef void (*XSUBADDR_t) (pTHX_ CV *);
+
+/* Set up PERLVAR macros for populating structs */
+#define PERLVAR(var,type) type var;
+#define PERLVARA(var,n,type) type var[n];
+#define PERLVARI(var,type,init) type var;
+#define PERLVARIC(var,type,init) type var;
+#define PERLVARISC(var,init) const char var[sizeof(init)];
+
+typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
+typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
+
+/* Interpreter exitlist entry */
+typedef struct exitlistentry {
+ void (*fn) (pTHX_ void*);
+ void *ptr;
+} PerlExitListEntry;
+
+/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
+/* These have to be before perlvars.h */
+#if !defined(HAS_SIGACTION) && defined(VMS)
+# define FAKE_PERSISTENT_SIGNAL_HANDLERS
+#endif
+/* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
+#if defined(KILL_BY_SIGPRC)
+# define FAKE_DEFAULT_SIGNAL_HANDLERS
+#endif
+
+#define PERL_PATCHLEVEL_H_IMPLICIT
+#include "patchlevel.h"
+#undef PERL_PATCHLEVEL_H_IMPLICIT
+
+#define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \
+ STRINGIFY(PERL_VERSION) "." \
+ STRINGIFY(PERL_SUBVERSION)
+
+#ifdef PERL_GLOBAL_STRUCT
+struct perl_vars {
+# include "perlvars.h"
+};
+
+# ifdef PERL_CORE
+# ifndef PERL_GLOBAL_STRUCT_PRIVATE
+EXT struct perl_vars PL_Vars;
+EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars);
+# undef PERL_GET_VARS
+# define PERL_GET_VARS() PL_VarsPtr
+# endif /* !PERL_GLOBAL_STRUCT_PRIVATE */
+# else /* PERL_CORE */
+# if !defined(__GNUC__) || !defined(WIN32)
+EXT
+# endif /* WIN32 */
+struct perl_vars *PL_VarsPtr;
+# define PL_Vars (*((PL_VarsPtr) \
+ ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX))))
+# endif /* PERL_CORE */
+#endif /* PERL_GLOBAL_STRUCT */
+
+#if defined(MULTIPLICITY)
+/* If we have multiple interpreters define a struct
+ holding variables which must be per-interpreter
+ If we don't have threads anything that would have
+ be per-thread is per-interpreter.
+*/
+
+struct interpreter {
+# include "intrpvar.h"
+};
+
+#else
+struct interpreter {
+ char broiled;
+};
+#endif /* MULTIPLICITY */
+
+/* Done with PERLVAR macros for now ... */
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#undef PERLVARISC
+
+struct tempsym; /* defined in pp_pack.c */
+
+#include "thread.h"
+#include "pp.h"
+
+#ifndef PERL_CALLCONV
+# ifdef __cplusplus
+# define PERL_CALLCONV extern "C"
+# else
+# define PERL_CALLCONV
+# endif
+#endif
+#undef PERL_CKDEF
+#undef PERL_PPDEF
+#define PERL_CKDEF(s) PERL_CALLCONV OP *s (pTHX_ OP *o);
+#define PERL_PPDEF(s) PERL_CALLCONV OP *s (pTHX);
+
+#include "proto.h"
+
+/* this has structure inits, so it cannot be included before here */
+#include "opcode.h"
+
+/* The following must follow proto.h as #defines mess up syntax */
+
+#if !defined(PERL_FOR_X2P)
+# include "embedvar.h"
+#endif
+#ifndef PERL_MAD
+# undef PL_madskills
+# undef PL_xmlfp
+# define PL_madskills 0
+# define PL_xmlfp 0
+#endif
+
+/* Now include all the 'global' variables
+ * If we don't have threads or multiple interpreters
+ * these include variables that would have been their struct-s
+ */
+
+#define PERLVAR(var,type) EXT type PL_##var;
+#define PERLVARA(var,n,type) EXT type PL_##var[n];
+#define PERLVARI(var,type,init) EXT type PL_##var INIT(init);
+#define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init);
+#define PERLVARISC(var,init) EXTCONST char PL_##var[sizeof(init)] INIT(init);
+
+#if !defined(MULTIPLICITY)
+START_EXTERN_C
+# include "intrpvar.h"
+END_EXTERN_C
+#endif
+
+#if defined(WIN32)
+/* Now all the config stuff is setup we can include embed.h */
+# include "embed.h"
+# ifndef PERL_MAD
+# undef op_getmad
+# define op_getmad(arg,pegop,slot) NOOP
+# endif
+#endif
+
+#ifndef PERL_GLOBAL_STRUCT
+START_EXTERN_C
+
+# include "perlvars.h"
+
+END_EXTERN_C
+#endif
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+
+START_EXTERN_C
+
+/* PERL_GLOBAL_STRUCT_PRIVATE wants to keep global data like the
+ * magic vtables const, but this is incompatible with SWIG which
+ * does want to modify the vtables. */
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# define EXT_MGVTBL EXTCONST MGVTBL
+#else
+# define EXT_MGVTBL EXT MGVTBL
+#endif
+
+#ifdef DOINIT
+# define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var = {a,b,c,d,e,f,g,h}
+/* Like MGVTBL_SET but with the get magic having a const MG* */
+# define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var \
+ = {(int (*)(pTHX_ SV *, MAGIC *))a,b,c,d,e,f,g,h}
+#else
+# define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var
+# define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var
+#endif
+
+/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a
+ * pointer to data, whereas we're assigning pointers to functions, which are
+ * not the same beast. ANSI doesn't allow the assignment from one to the other.
+ * (although most, but not all, compilers are prepared to do it)
+ */
+MGVTBL_SET(
+ PL_vtbl_sv,
+ MEMBER_TO_FPTR(Perl_magic_get),
+ MEMBER_TO_FPTR(Perl_magic_set),
+ MEMBER_TO_FPTR(Perl_magic_len),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_env,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_set_all_env),
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_clear_all_env),
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_envelem,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setenv),
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_clearenv),
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+/* For now, hints magic will also use vtbl_sig, because it is all 0 */
+MGVTBL_SET(
+ PL_vtbl_sig,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+#ifdef PERL_MICRO
+MGVTBL_SET(
+ PL_vtbl_sigelem,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+#else
+MGVTBL_SET(
+ PL_vtbl_sigelem,
+ MEMBER_TO_FPTR(Perl_magic_getsig),
+ MEMBER_TO_FPTR(Perl_magic_setsig),
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_clearsig),
+ 0,
+ 0,
+ 0,
+ 0
+);
+#endif
+
+MGVTBL_SET(
+ PL_vtbl_pack,
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_sizepack),
+ MEMBER_TO_FPTR(Perl_magic_wipepack),
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_packelem,
+ MEMBER_TO_FPTR(Perl_magic_getpack),
+ MEMBER_TO_FPTR(Perl_magic_setpack),
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_clearpack),
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_dbline,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setdbline),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_isa,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setisa),
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_clearisa),
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_isaelem,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setisa),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET_CONST_MAGIC_GET(
+ PL_vtbl_arylen,
+ MEMBER_TO_FPTR(Perl_magic_getarylen),
+ MEMBER_TO_FPTR(Perl_magic_setarylen),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_arylen_p,
+ 0,
+ 0,
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_freearylen_p),
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_mglob,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setmglob),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_nkeys,
+ MEMBER_TO_FPTR(Perl_magic_getnkeys),
+ MEMBER_TO_FPTR(Perl_magic_setnkeys),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_taint,
+ MEMBER_TO_FPTR(Perl_magic_gettaint),
+ MEMBER_TO_FPTR(Perl_magic_settaint),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_substr,
+ MEMBER_TO_FPTR(Perl_magic_getsubstr),
+ MEMBER_TO_FPTR(Perl_magic_setsubstr),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_vec,
+ MEMBER_TO_FPTR(Perl_magic_getvec),
+ MEMBER_TO_FPTR(Perl_magic_setvec),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_pos,
+ MEMBER_TO_FPTR(Perl_magic_getpos),
+ MEMBER_TO_FPTR(Perl_magic_setpos),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_bm,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setregexp),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_fm,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setregexp),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_uvar,
+ MEMBER_TO_FPTR(Perl_magic_getuvar),
+ MEMBER_TO_FPTR(Perl_magic_setuvar),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_defelem,
+ MEMBER_TO_FPTR(Perl_magic_getdefelem),
+ MEMBER_TO_FPTR(Perl_magic_setdefelem),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_regexp,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setregexp),
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_freeregexp),
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_regdata,
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_regdata_cnt),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_regdatum,
+ MEMBER_TO_FPTR(Perl_magic_regdatum_get),
+ MEMBER_TO_FPTR(Perl_magic_regdatum_set),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_amagic,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setamagic),
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setamagic),
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_amagicelem,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setamagic),
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setamagic),
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_backref,
+ 0,
+ 0,
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_killbackrefs),
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_ovrld,
+ 0,
+ 0,
+ 0,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_freeovrld),
+ 0,
+ 0,
+ 0
+);
+
+MGVTBL_SET(
+ PL_vtbl_utf8,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setutf8),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+#ifdef USE_LOCALE_COLLATE
+MGVTBL_SET(
+ PL_vtbl_collxfrm,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_setcollxfrm),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+);
+#endif
+
+MGVTBL_SET(
+ PL_vtbl_hintselem,
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_sethint),
+ 0,
+ MEMBER_TO_FPTR(Perl_magic_clearhint),
+ 0,
+ 0,
+ 0,
+ 0
+);
+
+#include "overload.h"
+
+END_EXTERN_C
+
+struct am_table {
+ U32 flags;
+ U32 was_ok_sub;
+ long was_ok_am;
+ long fallback;
+ CV* table[NofAMmeth];
+};
+struct am_table_short {
+ U32 flags;
+ U32 was_ok_sub;
+ long was_ok_am;
+};
+typedef struct am_table AMT;
+typedef struct am_table_short AMTS;
+
+#define AMGfallNEVER 1
+#define AMGfallNO 2
+#define AMGfallYES 3
+
+#define AMTf_AMAGIC 1
+#define AMTf_OVERLOADED 2
+#define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC)
+#define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC)
+#define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC)
+#define AMT_OVERLOADED(amt) ((amt)->flags & AMTf_OVERLOADED)
+#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED)
+#define AMT_OVERLOADED_off(amt) ((amt)->flags &= ~AMTf_OVERLOADED)
+
+#define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg))
+
+/*
+ * some compilers like to redefine cos et alia as faster
+ * (and less accurate?) versions called F_cos et cetera (Quidquid
+ * latine dictum sit, altum viditur.) This trick collides with
+ * the Perl overloading (amg). The following #defines fool both.
+ */
+
+#ifdef _FASTMATH
+# ifdef atan2
+# define F_atan2_amg atan2_amg
+# endif
+# ifdef cos
+# define F_cos_amg cos_amg
+# endif
+# ifdef exp
+# define F_exp_amg exp_amg
+# endif
+# ifdef log
+# define F_log_amg log_amg
+# endif
+# ifdef pow
+# define F_pow_amg pow_amg
+# endif
+# ifdef sin
+# define F_sin_amg sin_amg
+# endif
+# ifdef sqrt
+# define F_sqrt_amg sqrt_amg
+# endif
+#endif /* _FASTMATH */
+
+#define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \
+ PERLDBf_NOOPT | PERLDBf_INTER | \
+ PERLDBf_SUBLINE| PERLDBf_SINGLE| \
+ PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \
+ PERLDBf_SAVESRC)
+ /* No _NONAME, _GOTO, _ASSERTION */
+#define PERLDBf_SUB 0x01 /* Debug sub enter/exit */
+#define PERLDBf_LINE 0x02 /* Keep line # */
+#define PERLDBf_NOOPT 0x04 /* Switch off optimizations */
+#define PERLDBf_INTER 0x08 /* Preserve more data for
+ later inspections */
+#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */
+#define PERLDBf_SINGLE 0x20 /* Start with single-step on */
+#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */
+#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */
+#define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */
+#define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */
+#define PERLDBf_SAVESRC 0x400 /* Save source lines into @{"_<$filename"} */
+#define PERLDBf_SAVESRC_NOSUBS 0x800 /* Including evals that generate no subrouties */
+#if 0 /* Not yet working. */
+#define PERLDBf_SAVESRC_INVALID 0x1000 /* Save source that did not compile */
+#endif
+
+#define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB))
+#define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE))
+#define PERLDB_NOOPT (PL_perldb && (PL_perldb & PERLDBf_NOOPT))
+#define PERLDB_INTER (PL_perldb && (PL_perldb & PERLDBf_INTER))
+#define PERLDB_SUBLINE (PL_perldb && (PL_perldb & PERLDBf_SUBLINE))
+#define PERLDB_SINGLE (PL_perldb && (PL_perldb & PERLDBf_SINGLE))
+#define PERLDB_SUB_NN (PL_perldb && (PL_perldb & (PERLDBf_NONAME)))
+#define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO))
+#define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL))
+#define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON))
+#define PERLDB_ASSERTION (PL_perldb && (PL_perldb & PERLDBf_ASSERTION))
+#define PERLDB_SAVESRC (PL_perldb && (PL_perldb & PERLDBf_SAVESRC))
+#define PERLDB_SAVESRC_NOSUBS (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_NOSUBS))
+#if 0 /* Not yet working. */
+#define PERLDB_SAVESRC_INVALID (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_INVALID))
+#endif
+
+#ifdef USE_LOCALE_NUMERIC
+
+#define SET_NUMERIC_STANDARD() \
+ set_numeric_standard();
+
+#define SET_NUMERIC_LOCAL() \
+ set_numeric_local();
+
+#define IN_LOCALE_RUNTIME (CopHINTS_get(PL_curcop) & HINT_LOCALE)
+#define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+
+#define IN_LOCALE \
+ (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+
+#define STORE_NUMERIC_LOCAL_SET_STANDARD() \
+ bool was_local = PL_numeric_local && IN_LOCALE; \
+ if (was_local) SET_NUMERIC_STANDARD();
+
+#define STORE_NUMERIC_STANDARD_SET_LOCAL() \
+ bool was_standard = PL_numeric_standard && IN_LOCALE; \
+ if (was_standard) SET_NUMERIC_LOCAL();
+
+#define RESTORE_NUMERIC_LOCAL() \
+ if (was_local) SET_NUMERIC_LOCAL();
+
+#define RESTORE_NUMERIC_STANDARD() \
+ if (was_standard) SET_NUMERIC_STANDARD();
+
+#define Atof my_atof
+
+#else /* !USE_LOCALE_NUMERIC */
+
+#define SET_NUMERIC_STANDARD() /**/
+#define SET_NUMERIC_LOCAL() /**/
+#define IS_NUMERIC_RADIX(a, b) (0)
+#define STORE_NUMERIC_LOCAL_SET_STANDARD() /**/
+#define STORE_NUMERIC_STANDARD_SET_LOCAL() /**/
+#define RESTORE_NUMERIC_LOCAL() /**/
+#define RESTORE_NUMERIC_STANDARD() /**/
+#define Atof my_atof
+#define IN_LOCALE_RUNTIME 0
+
+#endif /* !USE_LOCALE_NUMERIC */
+
+#if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG
+# ifdef __hpux
+# define strtoll __strtoll /* secret handshake */
+# endif
+# ifdef WIN64
+# define strtoll _strtoi64 /* secret handshake */
+# endif
+# if !defined(Strtol) && defined(HAS_STRTOLL)
+# define Strtol strtoll
+# endif
+# if !defined(Strtol) && defined(HAS_STRTOQ)
+# define Strtol strtoq
+# endif
+/* is there atoq() anywhere? */
+#endif
+#if !defined(Strtol) && defined(HAS_STRTOL)
+# define Strtol strtol
+#endif
+#ifndef Atol
+/* It would be more fashionable to use Strtol() to define atol()
+ * (as is done for Atoul(), see below) but for backward compatibility
+ * we just assume atol(). */
+# if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_ATOLL)
+# ifdef WIN64
+# define atoll _atoi64 /* secret handshake */
+# endif
+# define Atol atoll
+# else
+# define Atol atol
+# endif
+#endif
+
+#if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG
+# ifdef __hpux
+# define strtoull __strtoull /* secret handshake */
+# endif
+# ifdef WIN64
+# define strtoull _strtoui64 /* secret handshake */
+# endif
+# if !defined(Strtoul) && defined(HAS_STRTOULL)
+# define Strtoul strtoull
+# endif
+# if !defined(Strtoul) && defined(HAS_STRTOUQ)
+# define Strtoul strtouq
+# endif
+/* is there atouq() anywhere? */
+#endif
+#if !defined(Strtoul) && defined(HAS_STRTOUL)
+# define Strtoul strtoul
+#endif
+#if !defined(Strtoul) && defined(HAS_STRTOL) /* Last resort. */
+# define Strtoul(s, e, b) strchr((s), '-') ? ULONG_MAX : (unsigned long)strtol((s), (e), (b))
+#endif
+#ifndef Atoul
+# define Atoul(s) Strtoul(s, NULL, 10)
+#endif
+
+
+/* if these never got defined, they need defaults */
+#ifndef PERL_SET_CONTEXT
+# define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i)
+#endif
+
+#ifndef PERL_GET_CONTEXT
+# define PERL_GET_CONTEXT PERL_GET_INTERP
+#endif
+
+#ifndef PERL_GET_THX
+# define PERL_GET_THX ((void*)NULL)
+#endif
+
+#ifndef PERL_SET_THX
+# define PERL_SET_THX(t) NOOP
+#endif
+
+#ifndef PERL_SCRIPT_MODE
+#define PERL_SCRIPT_MODE "r"
+#endif
+
+/*
+ * Some operating systems are stingy with stack allocation,
+ * so perl may have to guard against stack overflow.
+ */
+#ifndef PERL_STACK_OVERFLOW_CHECK
+#define PERL_STACK_OVERFLOW_CHECK() NOOP
+#endif
+
+/*
+ * Some nonpreemptive operating systems find it convenient to
+ * check for asynchronous conditions after each op execution.
+ * Keep this check simple, or it may slow down execution
+ * massively.
+ */
+
+#ifndef PERL_MICRO
+# ifndef PERL_ASYNC_CHECK
+# define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+# endif
+#endif
+
+#ifndef PERL_ASYNC_CHECK
+# define PERL_ASYNC_CHECK() NOOP
+#endif
+
+/*
+ * On some operating systems, a memory allocation may succeed,
+ * but put the process too close to the system's comfort limit.
+ * In this case, PERL_ALLOC_CHECK frees the pointer and sets
+ * it to NULL.
+ */
+#ifndef PERL_ALLOC_CHECK
+#define PERL_ALLOC_CHECK(p) NOOP
+#endif
+
+#ifdef HAS_SEM
+# include <sys/ipc.h>
+# include <sys/sem.h>
+# ifndef HAS_UNION_SEMUN /* Provide the union semun. */
+ union semun {
+ int val;
+ struct semid_ds *buf;
+ unsigned short *array;
+ };
+# endif
+# ifdef USE_SEMCTL_SEMUN
+# ifdef IRIX32_SEMUN_BROKEN_BY_GCC
+ union gccbug_semun {
+ int val;
+ struct semid_ds *buf;
+ unsigned short *array;
+ char __dummy[5];
+ };
+# define semun gccbug_semun
+# endif
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun)
+# else
+# ifdef USE_SEMCTL_SEMID_DS
+# ifdef EXTRA_F_IN_SEMUN_BUF
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buff)
+# else
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf)
+# endif
+# endif
+# endif
+#endif
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See
+ * ext/XS/APItest/APItest.xs for an example of the use of these macros,
+ * and perlxs.pod for more.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g.
+ * "DynaLoader::_guts" XS_VERSION
+ * XXX in the current implementation, this string is ignored.
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(PERL_IMPLICIT_CONTEXT)
+
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+#define MY_CXT_INDEX Perl_my_cxt_index(aTHX_ MY_CXT_KEY)
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_KEY, sizeof(my_cxt_t))
+#define MY_CXT_INIT_INTERP(my_perl) \
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_KEY, sizeof(my_cxt_t))
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX]
+#define dMY_CXT_INTERP(my_perl) \
+ my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX]
+
+/* Clones the per-interpreter data. */
+#define MY_CXT_CLONE \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Copy(PL_my_cxt_list[MY_CXT_INDEX], my_cxtp, 1, my_cxt_t);\
+ PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp \
+
+#else /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT static int my_cxt_index = -1;
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[my_cxt_index]
+#define dMY_CXT_INTERP(my_perl) \
+ my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[my_cxt_index]
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(aTHX_ &my_cxt_index, sizeof(my_cxt_t))
+#define MY_CXT_INIT_INTERP(my_perl) \
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(my_perl, &my_cxt_index, sizeof(my_cxt_t))
+
+/* Clones the per-interpreter data. */
+#define MY_CXT_CLONE \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Copy(PL_my_cxt_list[my_cxt_index], my_cxtp, 1, my_cxt_t);\
+ PL_my_cxt_list[my_cxt_index] = my_cxtp \
+
+#endif /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* PERL_IMPLICIT_CONTEXT */
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define dMY_CXT_INTERP(my_perl) dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT_CLONE NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif /* !defined(PERL_IMPLICIT_CONTEXT) */
+
+#ifdef I_FCNTL
+# include <fcntl.h>
+#endif
+
+#ifdef __Lynx__
+# include <fcntl.h>
+#endif
+
+#ifdef I_SYS_FILE
+# include <sys/file.h>
+#endif
+
+#if defined(HAS_FLOCK) && !defined(HAS_FLOCK_PROTO)
+int flock(int fd, int op);
+#endif
+
+#ifndef O_RDONLY
+/* Assume UNIX defaults */
+# define O_RDONLY 0000
+# define O_WRONLY 0001
+# define O_RDWR 0002
+# define O_CREAT 0100
+#endif
+
+#ifndef O_BINARY
+# define O_BINARY 0
+#endif
+
+#ifndef O_TEXT
+# define O_TEXT 0
+#endif
+
+#if O_TEXT != O_BINARY
+ /* If you have different O_TEXT and O_BINARY and you are a CLRF shop,
+ * that is, you are somehow DOSish. */
+# if defined(__BEOS__) || defined(__HAIKU__) || defined(__VOS__) || \
+ defined(__CYGWIN__)
+ /* BeOS/Haiku has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect;
+ * BeOS/Haiku is always UNIXoid (LF), not DOSish (CRLF). */
+ /* VOS has O_TEXT != O_BINARY, and they have effect,
+ * but VOS always uses LF, never CRLF. */
+ /* If you have O_TEXT different from your O_BINARY but you still are
+ * not a CRLF shop. */
+# undef PERLIO_USING_CRLF
+# else
+ /* If you really are DOSish. */
+# define PERLIO_USING_CRLF 1
+# endif
+#endif
+
+#ifdef IAMSUID
+
+#ifdef I_SYS_STATVFS
+# if defined(PERL_SCO) && !defined(_SVID3)
+# define _SVID3
+# endif
+# include <sys/statvfs.h> /* for f?statvfs() */
+#endif
+#ifdef I_SYS_MOUNT
+# include <sys/mount.h> /* for *BSD f?statfs() */
+#endif
+#ifdef I_MNTENT
+# include <mntent.h> /* for getmntent() */
+#endif
+#ifdef I_SYS_STATFS
+# include <sys/statfs.h> /* for some statfs() */
+#endif
+#ifdef I_SYS_VFS
+# ifdef __sgi
+# define sv IRIX_sv /* kludge: IRIX has an sv of its own */
+# endif
+# include <sys/vfs.h> /* for some statfs() */
+# ifdef __sgi
+# undef IRIX_sv
+# endif
+#endif
+#ifdef I_USTAT
+# include <ustat.h> /* for ustat() */
+#endif
+
+#if !defined(PERL_MOUNT_NOSUID) && defined(MOUNT_NOSUID)
+# define PERL_MOUNT_NOSUID MOUNT_NOSUID
+#endif
+#if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
+# define PERL_MOUNT_NOSUID MNT_NOSUID
+#endif
+#if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
+# define PERL_MOUNT_NOSUID MS_NOSUID
+#endif
+#if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
+# define PERL_MOUNT_NOSUID M_NOSUID
+#endif
+
+#if !defined(PERL_MOUNT_NOEXEC) && defined(MOUNT_NOEXEC)
+# define PERL_MOUNT_NOEXEC MOUNT_NOEXEC
+#endif
+#if !defined(PERL_MOUNT_NOEXEC) && defined(MNT_NOEXEC)
+# define PERL_MOUNT_NOEXEC MNT_NOEXEC
+#endif
+#if !defined(PERL_MOUNT_NOEXEC) && defined(MS_NOEXEC)
+# define PERL_MOUNT_NOEXEC MS_NOEXEC
+#endif
+#if !defined(PERL_MOUNT_NOEXEC) && defined(M_NOEXEC)
+# define PERL_MOUNT_NOEXEC M_NOEXEC
+#endif
+
+#endif /* IAMSUID */
+
+#ifdef I_LIBUTIL
+# include <libutil.h> /* setproctitle() in some FreeBSDs */
+#endif
+
+#ifndef EXEC_ARGV_CAST
+#define EXEC_ARGV_CAST(x) (char **)x
+#endif
+
+#define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not
+ int). value returned in pointed-
+ to UV */
+#define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */
+#define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation */
+#define IS_NUMBER_NEG 0x08 /* leading minus sign */
+#define IS_NUMBER_INFINITY 0x10 /* this is big */
+#define IS_NUMBER_NAN 0x20 /* this is not */
+
+#define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
+
+/* Input flags: */
+#define PERL_SCAN_ALLOW_UNDERSCORES 0x01 /* grok_??? accept _ in numbers */
+#define PERL_SCAN_DISALLOW_PREFIX 0x02 /* grok_??? reject 0x in hex etc */
+#define PERL_SCAN_SILENT_ILLDIGIT 0x04 /* grok_??? not warn about illegal digits */
+/* Output flags: */
+#define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 /* should this merge with above? */
+
+/* to let user control profiling */
+#ifdef PERL_GPROF_CONTROL
+extern void moncontrol(int);
+#define PERL_GPROF_MONCONTROL(x) moncontrol(x)
+#else
+#define PERL_GPROF_MONCONTROL(x)
+#endif
+
+#ifdef UNDER_CE
+#include "wince.h"
+#endif
+
+/* ISO 6429 NEL - C1 control NExt Line */
+/* See http://www.unicode.org/unicode/reports/tr13/ */
+#ifdef EBCDIC /* In EBCDIC NEL is just an alias for LF */
+# if '^' == 95 /* CP 1047: MVS OpenEdition - OS/390 - z/OS */
+# define NEXT_LINE_CHAR 0x15
+# else /* CDRA */
+# define NEXT_LINE_CHAR 0x25
+# endif
+#else
+# define NEXT_LINE_CHAR 0x85
+#endif
+
+/* The UTF-8 bytes of the Unicode LS and PS, U+2028 and U+2029 */
+#define UNICODE_LINE_SEPA_0 0xE2
+#define UNICODE_LINE_SEPA_1 0x80
+#define UNICODE_LINE_SEPA_2 0xA8
+#define UNICODE_PARA_SEPA_0 0xE2
+#define UNICODE_PARA_SEPA_1 0x80
+#define UNICODE_PARA_SEPA_2 0xA9
+
+#ifndef PIPESOCK_MODE
+# define PIPESOCK_MODE
+#endif
+
+#ifndef SOCKET_OPEN_MODE
+# define SOCKET_OPEN_MODE PIPESOCK_MODE
+#endif
+
+#ifndef PIPE_OPEN_MODE
+# define PIPE_OPEN_MODE PIPESOCK_MODE
+#endif
+
+#define PERL_MAGIC_UTF8_CACHESIZE 2
+
+#define PERL_UNICODE_STDIN_FLAG 0x0001
+#define PERL_UNICODE_STDOUT_FLAG 0x0002
+#define PERL_UNICODE_STDERR_FLAG 0x0004
+#define PERL_UNICODE_IN_FLAG 0x0008
+#define PERL_UNICODE_OUT_FLAG 0x0010
+#define PERL_UNICODE_ARGV_FLAG 0x0020
+#define PERL_UNICODE_LOCALE_FLAG 0x0040
+#define PERL_UNICODE_WIDESYSCALLS_FLAG 0x0080 /* for Sarathy */
+#define PERL_UNICODE_UTF8CACHEASSERT_FLAG 0x0100
+
+#define PERL_UNICODE_STD_FLAG \
+ (PERL_UNICODE_STDIN_FLAG | \
+ PERL_UNICODE_STDOUT_FLAG | \
+ PERL_UNICODE_STDERR_FLAG)
+
+#define PERL_UNICODE_INOUT_FLAG \
+ (PERL_UNICODE_IN_FLAG | \
+ PERL_UNICODE_OUT_FLAG)
+
+#define PERL_UNICODE_DEFAULT_FLAGS \
+ (PERL_UNICODE_STD_FLAG | \
+ PERL_UNICODE_INOUT_FLAG | \
+ PERL_UNICODE_LOCALE_FLAG)
+
+#define PERL_UNICODE_ALL_FLAGS 0x01ff
+
+#define PERL_UNICODE_STDIN 'I'
+#define PERL_UNICODE_STDOUT 'O'
+#define PERL_UNICODE_STDERR 'E'
+#define PERL_UNICODE_STD 'S'
+#define PERL_UNICODE_IN 'i'
+#define PERL_UNICODE_OUT 'o'
+#define PERL_UNICODE_INOUT 'D'
+#define PERL_UNICODE_ARGV 'A'
+#define PERL_UNICODE_LOCALE 'L'
+#define PERL_UNICODE_WIDESYSCALLS 'W'
+#define PERL_UNICODE_UTF8CACHEASSERT 'a'
+
+#define PERL_SIGNALS_UNSAFE_FLAG 0x0001
+
+/* From sigaction(2) (FreeBSD man page):
+ * | Signal routines normally execute with the signal that
+ * | caused their invocation blocked, but other signals may
+ * | yet occur.
+ * Emulation of this behavior (from within Perl) is enabled
+ * by defining PERL_BLOCK_SIGNALS.
+ */
+#define PERL_BLOCK_SIGNALS
+
+#if defined(HAS_SIGPROCMASK) && defined(PERL_BLOCK_SIGNALS)
+# define PERL_BLOCKSIG_ADD(set,sig) \
+ sigset_t set; sigemptyset(&(set)); sigaddset(&(set), sig)
+# define PERL_BLOCKSIG_BLOCK(set) \
+ sigprocmask(SIG_BLOCK, &(set), NULL)
+# define PERL_BLOCKSIG_UNBLOCK(set) \
+ sigprocmask(SIG_UNBLOCK, &(set), NULL)
+#endif /* HAS_SIGPROCMASK && PERL_BLOCK_SIGNALS */
+
+/* How about the old style of sigblock()? */
+
+#ifndef PERL_BLOCKSIG_ADD
+# define PERL_BLOCKSIG_ADD(set, sig) NOOP
+#endif
+#ifndef PERL_BLOCKSIG_BLOCK
+# define PERL_BLOCKSIG_BLOCK(set) NOOP
+#endif
+#ifndef PERL_BLOCKSIG_UNBLOCK
+# define PERL_BLOCKSIG_UNBLOCK(set) NOOP
+#endif
+
+/* Use instead of abs() since abs() forces its argument to be an int,
+ * but also beware since this evaluates its argument twice, so no x++. */
+#define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
+
+#if defined(__DECC) && defined(__osf__)
+#pragma message disable (mainparm) /* Perl uses the envp in main(). */
+#endif
+
+#define do_open(g, n, l, a, rm, rp, sf) \
+ do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0)
+#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+# define do_exec(cmd) do_exec3(cmd,0,0)
+#endif
+#ifdef OS2
+# define do_aexec Perl_do_aexec
+#else
+# define do_aexec(really, mark,sp) do_aexec5(really, mark, sp, 0, 0)
+#endif
+
+#if defined(OEMVS)
+#define NO_ENV_ARRAY_IN_MAIN
+#endif
+
+/* These are used by Perl_pv_escape() and Perl_pv_pretty()
+ * are here so that they are available throughout the core
+ * NOTE that even though some are for _escape and some for _pretty
+ * there must not be any clashes as the flags from _pretty are
+ * passed straight through to _escape.
+ */
+
+#define PERL_PV_ESCAPE_QUOTE 0x0001
+#define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE
+
+#define PERL_PV_PRETTY_ELLIPSES 0x0002
+#define PERL_PV_PRETTY_LTGT 0x0004
+
+#define PERL_PV_ESCAPE_FIRSTCHAR 0x0008
+
+#define PERL_PV_ESCAPE_UNI 0x0100
+#define PERL_PV_ESCAPE_UNI_DETECT 0x0200
+
+#define PERL_PV_ESCAPE_ALL 0x1000
+#define PERL_PV_ESCAPE_NOBACKSLASH 0x2000
+#define PERL_PV_ESCAPE_NOCLEAR 0x4000
+#define PERL_PV_ESCAPE_RE 0x8000
+
+#define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR
+
+/* used by pv_display in dump.c*/
+#define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
+#define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
+
+/*
+
+ (KEEP THIS LAST IN perl.h!)
+
+ Mention
+
+ NV_PRESERVES_UV
+
+ HAS_MKSTEMP
+ HAS_MKSTEMPS
+ HAS_MKDTEMP
+
+ HAS_GETCWD
+
+ HAS_MMAP
+ HAS_MPROTECT
+ HAS_MSYNC
+ HAS_MADVISE
+ HAS_MUNMAP
+ I_SYSMMAN
+ Mmap_t
+
+ NVef
+ NVff
+ NVgf
+
+ HAS_UALARM
+ HAS_USLEEP
+
+ HAS_SETITIMER
+ HAS_GETITIMER
+
+ HAS_SENDMSG
+ HAS_RECVMSG
+ HAS_READV
+ HAS_WRITEV
+ I_SYSUIO
+ HAS_STRUCT_MSGHDR
+ HAS_STRUCT_CMSGHDR
+
+ HAS_NL_LANGINFO
+
+ HAS_DIRFD
+
+ so that Configure picks them up.
+
+ (KEEP THIS LAST IN perl.h!)
+
+*/
+
+#endif /* Include guard */
+
+#define CLEAR_ERRSV() STMT_START { sv_setpvn(ERRSV,"",0); if (SvMAGICAL(ERRSV)) { mg_free(ERRSV); } SvPOK_only(ERRSV); } STMT_END
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perlapi.h b/Master/tlpkg/tlperl.straw/lib/CORE/perlapi.h
new file mode 100755
index 00000000000..9622f96afeb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perlapi.h
@@ -0,0 +1,835 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * perlapi.h
+ *
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by embed.pl from data in embed.fnc, embed.pl,
+ * pp.sym, intrpvar.h, and perlvars.h.
+ * Any changes made here will be lost!
+ *
+ * Edit those files and run 'make regen_headers' to effect changes.
+ */
+
+/* declare accessor functions for Perl variables */
+#ifndef __perlapi_h__
+#define __perlapi_h__
+
+#if defined (MULTIPLICITY)
+
+START_EXTERN_C
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#undef PERLVARISC
+#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
+#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
+ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
+#define PERLVARI(v,t,i) PERLVAR(v,t)
+#define PERLVARIC(v,t,i) PERLVAR(v, const t)
+#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
+ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
+
+#include "intrpvar.h"
+#include "perlvars.h"
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#undef PERLVARISC
+
+#ifndef PERL_GLOBAL_STRUCT
+EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
+EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX);
+EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
+#define Perl_ppaddr_ptr Perl_Gppaddr_ptr
+#define Perl_check_ptr Perl_Gcheck_ptr
+#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
+#endif
+
+END_EXTERN_C
+
+#if defined(PERL_CORE)
+
+/* accessor functions for Perl variables (provide binary compatibility) */
+
+/* these need to be mentioned here, or most linkers won't put them in
+ the perl executable */
+
+#ifndef PERL_NO_FORCE_LINK
+
+START_EXTERN_C
+
+#ifndef DOINIT
+EXTCONST void * const PL_force_link_funcs[];
+#else
+EXTCONST void * const PL_force_link_funcs[] = {
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#define PERLVAR(v,t) (void*)Perl_##v##_ptr,
+#define PERLVARA(v,n,t) PERLVAR(v,t)
+#define PERLVARI(v,t,i) PERLVAR(v,t)
+#define PERLVARIC(v,t,i) PERLVAR(v,t)
+#define PERLVARISC(v,i) PERLVAR(v,char)
+
+/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
+ * cannot cast between void pointers and function pointers without
+ * info level warnings. The PL_force_link_funcs[] would cause a few
+ * hundred of those warnings. In code one can circumnavigate this by using
+ * unions that overlay the different pointers, but in declarations one
+ * cannot use this trick. Therefore we just disable the warning here
+ * for the duration of the PL_force_link_funcs[] declaration. */
+
+#if defined(__DECC) && defined(__osf__)
+#pragma message save
+#pragma message disable (nonstandcast)
+#endif
+
+#include "intrpvar.h"
+#include "perlvars.h"
+
+#if defined(__DECC) && defined(__osf__)
+#pragma message restore
+#endif
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#undef PERLVARISC
+};
+#endif /* DOINIT */
+
+END_EXTERN_C
+
+#endif /* PERL_NO_FORCE_LINK */
+
+#else /* !PERL_CORE */
+
+#undef PL_Argv
+#define PL_Argv (*Perl_IArgv_ptr(aTHX))
+#undef PL_Cmd
+#define PL_Cmd (*Perl_ICmd_ptr(aTHX))
+#undef PL_DBcv
+#define PL_DBcv (*Perl_IDBcv_ptr(aTHX))
+#undef PL_DBgv
+#define PL_DBgv (*Perl_IDBgv_ptr(aTHX))
+#undef PL_DBline
+#define PL_DBline (*Perl_IDBline_ptr(aTHX))
+#undef PL_DBsignal
+#define PL_DBsignal (*Perl_IDBsignal_ptr(aTHX))
+#undef PL_DBsingle
+#define PL_DBsingle (*Perl_IDBsingle_ptr(aTHX))
+#undef PL_DBsub
+#define PL_DBsub (*Perl_IDBsub_ptr(aTHX))
+#undef PL_DBtrace
+#define PL_DBtrace (*Perl_IDBtrace_ptr(aTHX))
+#undef PL_Dir
+#define PL_Dir (*Perl_IDir_ptr(aTHX))
+#undef PL_Env
+#define PL_Env (*Perl_IEnv_ptr(aTHX))
+#undef PL_LIO
+#define PL_LIO (*Perl_ILIO_ptr(aTHX))
+#undef PL_Mem
+#define PL_Mem (*Perl_IMem_ptr(aTHX))
+#undef PL_MemParse
+#define PL_MemParse (*Perl_IMemParse_ptr(aTHX))
+#undef PL_MemShared
+#define PL_MemShared (*Perl_IMemShared_ptr(aTHX))
+#undef PL_OpPtr
+#define PL_OpPtr (*Perl_IOpPtr_ptr(aTHX))
+#undef PL_OpSlab
+#define PL_OpSlab (*Perl_IOpSlab_ptr(aTHX))
+#undef PL_OpSpace
+#define PL_OpSpace (*Perl_IOpSpace_ptr(aTHX))
+#undef PL_Proc
+#define PL_Proc (*Perl_IProc_ptr(aTHX))
+#undef PL_Sock
+#define PL_Sock (*Perl_ISock_ptr(aTHX))
+#undef PL_StdIO
+#define PL_StdIO (*Perl_IStdIO_ptr(aTHX))
+#undef PL_Sv
+#define PL_Sv (*Perl_ISv_ptr(aTHX))
+#undef PL_Xpv
+#define PL_Xpv (*Perl_IXpv_ptr(aTHX))
+#undef PL_amagic_generation
+#define PL_amagic_generation (*Perl_Iamagic_generation_ptr(aTHX))
+#undef PL_an
+#define PL_an (*Perl_Ian_ptr(aTHX))
+#undef PL_argvgv
+#define PL_argvgv (*Perl_Iargvgv_ptr(aTHX))
+#undef PL_argvout_stack
+#define PL_argvout_stack (*Perl_Iargvout_stack_ptr(aTHX))
+#undef PL_argvoutgv
+#define PL_argvoutgv (*Perl_Iargvoutgv_ptr(aTHX))
+#undef PL_basetime
+#define PL_basetime (*Perl_Ibasetime_ptr(aTHX))
+#undef PL_beginav
+#define PL_beginav (*Perl_Ibeginav_ptr(aTHX))
+#undef PL_beginav_save
+#define PL_beginav_save (*Perl_Ibeginav_save_ptr(aTHX))
+#undef PL_bitcount
+#define PL_bitcount (*Perl_Ibitcount_ptr(aTHX))
+#undef PL_body_arenas
+#define PL_body_arenas (*Perl_Ibody_arenas_ptr(aTHX))
+#undef PL_body_roots
+#define PL_body_roots (*Perl_Ibody_roots_ptr(aTHX))
+#undef PL_bodytarget
+#define PL_bodytarget (*Perl_Ibodytarget_ptr(aTHX))
+#undef PL_breakable_sub_gen
+#define PL_breakable_sub_gen (*Perl_Ibreakable_sub_gen_ptr(aTHX))
+#undef PL_checkav
+#define PL_checkav (*Perl_Icheckav_ptr(aTHX))
+#undef PL_checkav_save
+#define PL_checkav_save (*Perl_Icheckav_save_ptr(aTHX))
+#undef PL_chopset
+#define PL_chopset (*Perl_Ichopset_ptr(aTHX))
+#undef PL_clocktick
+#define PL_clocktick (*Perl_Iclocktick_ptr(aTHX))
+#undef PL_collation_ix
+#define PL_collation_ix (*Perl_Icollation_ix_ptr(aTHX))
+#undef PL_collation_name
+#define PL_collation_name (*Perl_Icollation_name_ptr(aTHX))
+#undef PL_collation_standard
+#define PL_collation_standard (*Perl_Icollation_standard_ptr(aTHX))
+#undef PL_collxfrm_base
+#define PL_collxfrm_base (*Perl_Icollxfrm_base_ptr(aTHX))
+#undef PL_collxfrm_mult
+#define PL_collxfrm_mult (*Perl_Icollxfrm_mult_ptr(aTHX))
+#undef PL_colors
+#define PL_colors (*Perl_Icolors_ptr(aTHX))
+#undef PL_colorset
+#define PL_colorset (*Perl_Icolorset_ptr(aTHX))
+#undef PL_compcv
+#define PL_compcv (*Perl_Icompcv_ptr(aTHX))
+#undef PL_compiling
+#define PL_compiling (*Perl_Icompiling_ptr(aTHX))
+#undef PL_comppad
+#define PL_comppad (*Perl_Icomppad_ptr(aTHX))
+#undef PL_comppad_name
+#define PL_comppad_name (*Perl_Icomppad_name_ptr(aTHX))
+#undef PL_comppad_name_fill
+#define PL_comppad_name_fill (*Perl_Icomppad_name_fill_ptr(aTHX))
+#undef PL_comppad_name_floor
+#define PL_comppad_name_floor (*Perl_Icomppad_name_floor_ptr(aTHX))
+#undef PL_cop_seqmax
+#define PL_cop_seqmax (*Perl_Icop_seqmax_ptr(aTHX))
+#undef PL_cryptseen
+#define PL_cryptseen (*Perl_Icryptseen_ptr(aTHX))
+#undef PL_curcop
+#define PL_curcop (*Perl_Icurcop_ptr(aTHX))
+#undef PL_curcopdb
+#define PL_curcopdb (*Perl_Icurcopdb_ptr(aTHX))
+#undef PL_curpad
+#define PL_curpad (*Perl_Icurpad_ptr(aTHX))
+#undef PL_curpm
+#define PL_curpm (*Perl_Icurpm_ptr(aTHX))
+#undef PL_curstack
+#define PL_curstack (*Perl_Icurstack_ptr(aTHX))
+#undef PL_curstackinfo
+#define PL_curstackinfo (*Perl_Icurstackinfo_ptr(aTHX))
+#undef PL_curstash
+#define PL_curstash (*Perl_Icurstash_ptr(aTHX))
+#undef PL_curstname
+#define PL_curstname (*Perl_Icurstname_ptr(aTHX))
+#undef PL_custom_op_descs
+#define PL_custom_op_descs (*Perl_Icustom_op_descs_ptr(aTHX))
+#undef PL_custom_op_names
+#define PL_custom_op_names (*Perl_Icustom_op_names_ptr(aTHX))
+#undef PL_cv_has_eval
+#define PL_cv_has_eval (*Perl_Icv_has_eval_ptr(aTHX))
+#undef PL_dbargs
+#define PL_dbargs (*Perl_Idbargs_ptr(aTHX))
+#undef PL_debstash
+#define PL_debstash (*Perl_Idebstash_ptr(aTHX))
+#undef PL_debug
+#define PL_debug (*Perl_Idebug_ptr(aTHX))
+#undef PL_debug_pad
+#define PL_debug_pad (*Perl_Idebug_pad_ptr(aTHX))
+#undef PL_def_layerlist
+#define PL_def_layerlist (*Perl_Idef_layerlist_ptr(aTHX))
+#undef PL_defgv
+#define PL_defgv (*Perl_Idefgv_ptr(aTHX))
+#undef PL_defoutgv
+#define PL_defoutgv (*Perl_Idefoutgv_ptr(aTHX))
+#undef PL_defstash
+#define PL_defstash (*Perl_Idefstash_ptr(aTHX))
+#undef PL_delaymagic
+#define PL_delaymagic (*Perl_Idelaymagic_ptr(aTHX))
+#undef PL_destroyhook
+#define PL_destroyhook (*Perl_Idestroyhook_ptr(aTHX))
+#undef PL_diehook
+#define PL_diehook (*Perl_Idiehook_ptr(aTHX))
+#undef PL_dirty
+#define PL_dirty (*Perl_Idirty_ptr(aTHX))
+#undef PL_doextract
+#define PL_doextract (*Perl_Idoextract_ptr(aTHX))
+#undef PL_doswitches
+#define PL_doswitches (*Perl_Idoswitches_ptr(aTHX))
+#undef PL_dowarn
+#define PL_dowarn (*Perl_Idowarn_ptr(aTHX))
+#undef PL_dumper_fd
+#define PL_dumper_fd (*Perl_Idumper_fd_ptr(aTHX))
+#undef PL_dumpindent
+#define PL_dumpindent (*Perl_Idumpindent_ptr(aTHX))
+#undef PL_e_script
+#define PL_e_script (*Perl_Ie_script_ptr(aTHX))
+#undef PL_efloatbuf
+#define PL_efloatbuf (*Perl_Iefloatbuf_ptr(aTHX))
+#undef PL_efloatsize
+#define PL_efloatsize (*Perl_Iefloatsize_ptr(aTHX))
+#undef PL_egid
+#define PL_egid (*Perl_Iegid_ptr(aTHX))
+#undef PL_encoding
+#define PL_encoding (*Perl_Iencoding_ptr(aTHX))
+#undef PL_endav
+#define PL_endav (*Perl_Iendav_ptr(aTHX))
+#undef PL_envgv
+#define PL_envgv (*Perl_Ienvgv_ptr(aTHX))
+#undef PL_errgv
+#define PL_errgv (*Perl_Ierrgv_ptr(aTHX))
+#undef PL_errors
+#define PL_errors (*Perl_Ierrors_ptr(aTHX))
+#undef PL_euid
+#define PL_euid (*Perl_Ieuid_ptr(aTHX))
+#undef PL_eval_root
+#define PL_eval_root (*Perl_Ieval_root_ptr(aTHX))
+#undef PL_eval_start
+#define PL_eval_start (*Perl_Ieval_start_ptr(aTHX))
+#undef PL_evalseq
+#define PL_evalseq (*Perl_Ievalseq_ptr(aTHX))
+#undef PL_exit_flags
+#define PL_exit_flags (*Perl_Iexit_flags_ptr(aTHX))
+#undef PL_exitlist
+#define PL_exitlist (*Perl_Iexitlist_ptr(aTHX))
+#undef PL_exitlistlen
+#define PL_exitlistlen (*Perl_Iexitlistlen_ptr(aTHX))
+#undef PL_fdpid
+#define PL_fdpid (*Perl_Ifdpid_ptr(aTHX))
+#undef PL_filemode
+#define PL_filemode (*Perl_Ifilemode_ptr(aTHX))
+#undef PL_firstgv
+#define PL_firstgv (*Perl_Ifirstgv_ptr(aTHX))
+#undef PL_forkprocess
+#define PL_forkprocess (*Perl_Iforkprocess_ptr(aTHX))
+#undef PL_formfeed
+#define PL_formfeed (*Perl_Iformfeed_ptr(aTHX))
+#undef PL_formtarget
+#define PL_formtarget (*Perl_Iformtarget_ptr(aTHX))
+#undef PL_generation
+#define PL_generation (*Perl_Igeneration_ptr(aTHX))
+#undef PL_gensym
+#define PL_gensym (*Perl_Igensym_ptr(aTHX))
+#undef PL_gid
+#define PL_gid (*Perl_Igid_ptr(aTHX))
+#undef PL_glob_index
+#define PL_glob_index (*Perl_Iglob_index_ptr(aTHX))
+#undef PL_globalstash
+#define PL_globalstash (*Perl_Iglobalstash_ptr(aTHX))
+#undef PL_hash_seed
+#define PL_hash_seed (*Perl_Ihash_seed_ptr(aTHX))
+#undef PL_hintgv
+#define PL_hintgv (*Perl_Ihintgv_ptr(aTHX))
+#undef PL_hints
+#define PL_hints (*Perl_Ihints_ptr(aTHX))
+#undef PL_hv_fetch_ent_mh
+#define PL_hv_fetch_ent_mh (*Perl_Ihv_fetch_ent_mh_ptr(aTHX))
+#undef PL_in_clean_all
+#define PL_in_clean_all (*Perl_Iin_clean_all_ptr(aTHX))
+#undef PL_in_clean_objs
+#define PL_in_clean_objs (*Perl_Iin_clean_objs_ptr(aTHX))
+#undef PL_in_eval
+#define PL_in_eval (*Perl_Iin_eval_ptr(aTHX))
+#undef PL_in_load_module
+#define PL_in_load_module (*Perl_Iin_load_module_ptr(aTHX))
+#undef PL_incgv
+#define PL_incgv (*Perl_Iincgv_ptr(aTHX))
+#undef PL_initav
+#define PL_initav (*Perl_Iinitav_ptr(aTHX))
+#undef PL_inplace
+#define PL_inplace (*Perl_Iinplace_ptr(aTHX))
+#undef PL_isarev
+#define PL_isarev (*Perl_Iisarev_ptr(aTHX))
+#undef PL_known_layers
+#define PL_known_layers (*Perl_Iknown_layers_ptr(aTHX))
+#undef PL_last_in_gv
+#define PL_last_in_gv (*Perl_Ilast_in_gv_ptr(aTHX))
+#undef PL_last_swash_hv
+#define PL_last_swash_hv (*Perl_Ilast_swash_hv_ptr(aTHX))
+#undef PL_last_swash_key
+#define PL_last_swash_key (*Perl_Ilast_swash_key_ptr(aTHX))
+#undef PL_last_swash_klen
+#define PL_last_swash_klen (*Perl_Ilast_swash_klen_ptr(aTHX))
+#undef PL_last_swash_slen
+#define PL_last_swash_slen (*Perl_Ilast_swash_slen_ptr(aTHX))
+#undef PL_last_swash_tmps
+#define PL_last_swash_tmps (*Perl_Ilast_swash_tmps_ptr(aTHX))
+#undef PL_lastfd
+#define PL_lastfd (*Perl_Ilastfd_ptr(aTHX))
+#undef PL_lastgotoprobe
+#define PL_lastgotoprobe (*Perl_Ilastgotoprobe_ptr(aTHX))
+#undef PL_lastscream
+#define PL_lastscream (*Perl_Ilastscream_ptr(aTHX))
+#undef PL_laststatval
+#define PL_laststatval (*Perl_Ilaststatval_ptr(aTHX))
+#undef PL_laststype
+#define PL_laststype (*Perl_Ilaststype_ptr(aTHX))
+#undef PL_localizing
+#define PL_localizing (*Perl_Ilocalizing_ptr(aTHX))
+#undef PL_localpatches
+#define PL_localpatches (*Perl_Ilocalpatches_ptr(aTHX))
+#undef PL_lockhook
+#define PL_lockhook (*Perl_Ilockhook_ptr(aTHX))
+#undef PL_madskills
+#define PL_madskills (*Perl_Imadskills_ptr(aTHX))
+#undef PL_main_cv
+#define PL_main_cv (*Perl_Imain_cv_ptr(aTHX))
+#undef PL_main_root
+#define PL_main_root (*Perl_Imain_root_ptr(aTHX))
+#undef PL_main_start
+#define PL_main_start (*Perl_Imain_start_ptr(aTHX))
+#undef PL_mainstack
+#define PL_mainstack (*Perl_Imainstack_ptr(aTHX))
+#undef PL_markstack
+#define PL_markstack (*Perl_Imarkstack_ptr(aTHX))
+#undef PL_markstack_max
+#define PL_markstack_max (*Perl_Imarkstack_max_ptr(aTHX))
+#undef PL_markstack_ptr
+#define PL_markstack_ptr (*Perl_Imarkstack_ptr_ptr(aTHX))
+#undef PL_max_intro_pending
+#define PL_max_intro_pending (*Perl_Imax_intro_pending_ptr(aTHX))
+#undef PL_maxo
+#define PL_maxo (*Perl_Imaxo_ptr(aTHX))
+#undef PL_maxscream
+#define PL_maxscream (*Perl_Imaxscream_ptr(aTHX))
+#undef PL_maxsysfd
+#define PL_maxsysfd (*Perl_Imaxsysfd_ptr(aTHX))
+#undef PL_memory_debug_header
+#define PL_memory_debug_header (*Perl_Imemory_debug_header_ptr(aTHX))
+#undef PL_mess_sv
+#define PL_mess_sv (*Perl_Imess_sv_ptr(aTHX))
+#undef PL_min_intro_pending
+#define PL_min_intro_pending (*Perl_Imin_intro_pending_ptr(aTHX))
+#undef PL_minus_E
+#define PL_minus_E (*Perl_Iminus_E_ptr(aTHX))
+#undef PL_minus_F
+#define PL_minus_F (*Perl_Iminus_F_ptr(aTHX))
+#undef PL_minus_a
+#define PL_minus_a (*Perl_Iminus_a_ptr(aTHX))
+#undef PL_minus_c
+#define PL_minus_c (*Perl_Iminus_c_ptr(aTHX))
+#undef PL_minus_l
+#define PL_minus_l (*Perl_Iminus_l_ptr(aTHX))
+#undef PL_minus_n
+#define PL_minus_n (*Perl_Iminus_n_ptr(aTHX))
+#undef PL_minus_p
+#define PL_minus_p (*Perl_Iminus_p_ptr(aTHX))
+#undef PL_modcount
+#define PL_modcount (*Perl_Imodcount_ptr(aTHX))
+#undef PL_modglobal
+#define PL_modglobal (*Perl_Imodglobal_ptr(aTHX))
+#undef PL_my_cxt_keys
+#define PL_my_cxt_keys (*Perl_Imy_cxt_keys_ptr(aTHX))
+#undef PL_my_cxt_list
+#define PL_my_cxt_list (*Perl_Imy_cxt_list_ptr(aTHX))
+#undef PL_my_cxt_size
+#define PL_my_cxt_size (*Perl_Imy_cxt_size_ptr(aTHX))
+#undef PL_na
+#define PL_na (*Perl_Ina_ptr(aTHX))
+#undef PL_nice_chunk
+#define PL_nice_chunk (*Perl_Inice_chunk_ptr(aTHX))
+#undef PL_nice_chunk_size
+#define PL_nice_chunk_size (*Perl_Inice_chunk_size_ptr(aTHX))
+#undef PL_nomemok
+#define PL_nomemok (*Perl_Inomemok_ptr(aTHX))
+#undef PL_numeric_local
+#define PL_numeric_local (*Perl_Inumeric_local_ptr(aTHX))
+#undef PL_numeric_name
+#define PL_numeric_name (*Perl_Inumeric_name_ptr(aTHX))
+#undef PL_numeric_radix_sv
+#define PL_numeric_radix_sv (*Perl_Inumeric_radix_sv_ptr(aTHX))
+#undef PL_numeric_standard
+#define PL_numeric_standard (*Perl_Inumeric_standard_ptr(aTHX))
+#undef PL_ofs_sv
+#define PL_ofs_sv (*Perl_Iofs_sv_ptr(aTHX))
+#undef PL_oldname
+#define PL_oldname (*Perl_Ioldname_ptr(aTHX))
+#undef PL_op
+#define PL_op (*Perl_Iop_ptr(aTHX))
+#undef PL_op_mask
+#define PL_op_mask (*Perl_Iop_mask_ptr(aTHX))
+#undef PL_opsave
+#define PL_opsave (*Perl_Iopsave_ptr(aTHX))
+#undef PL_origalen
+#define PL_origalen (*Perl_Iorigalen_ptr(aTHX))
+#undef PL_origargc
+#define PL_origargc (*Perl_Iorigargc_ptr(aTHX))
+#undef PL_origargv
+#define PL_origargv (*Perl_Iorigargv_ptr(aTHX))
+#undef PL_origenviron
+#define PL_origenviron (*Perl_Iorigenviron_ptr(aTHX))
+#undef PL_origfilename
+#define PL_origfilename (*Perl_Iorigfilename_ptr(aTHX))
+#undef PL_ors_sv
+#define PL_ors_sv (*Perl_Iors_sv_ptr(aTHX))
+#undef PL_osname
+#define PL_osname (*Perl_Iosname_ptr(aTHX))
+#undef PL_pad_reset_pending
+#define PL_pad_reset_pending (*Perl_Ipad_reset_pending_ptr(aTHX))
+#undef PL_padix
+#define PL_padix (*Perl_Ipadix_ptr(aTHX))
+#undef PL_padix_floor
+#define PL_padix_floor (*Perl_Ipadix_floor_ptr(aTHX))
+#undef PL_parser
+#define PL_parser (*Perl_Iparser_ptr(aTHX))
+#undef PL_patchlevel
+#define PL_patchlevel (*Perl_Ipatchlevel_ptr(aTHX))
+#undef PL_peepp
+#define PL_peepp (*Perl_Ipeepp_ptr(aTHX))
+#undef PL_perl_destruct_level
+#define PL_perl_destruct_level (*Perl_Iperl_destruct_level_ptr(aTHX))
+#undef PL_perldb
+#define PL_perldb (*Perl_Iperldb_ptr(aTHX))
+#undef PL_perlio
+#define PL_perlio (*Perl_Iperlio_ptr(aTHX))
+#undef PL_pidstatus
+#define PL_pidstatus (*Perl_Ipidstatus_ptr(aTHX))
+#undef PL_ppid
+#define PL_ppid (*Perl_Ippid_ptr(aTHX))
+#undef PL_preambleav
+#define PL_preambleav (*Perl_Ipreambleav_ptr(aTHX))
+#undef PL_preprocess
+#define PL_preprocess (*Perl_Ipreprocess_ptr(aTHX))
+#undef PL_profiledata
+#define PL_profiledata (*Perl_Iprofiledata_ptr(aTHX))
+#undef PL_psig_name
+#define PL_psig_name (*Perl_Ipsig_name_ptr(aTHX))
+#undef PL_psig_pend
+#define PL_psig_pend (*Perl_Ipsig_pend_ptr(aTHX))
+#undef PL_psig_ptr
+#define PL_psig_ptr (*Perl_Ipsig_ptr_ptr(aTHX))
+#undef PL_ptr_table
+#define PL_ptr_table (*Perl_Iptr_table_ptr(aTHX))
+#undef PL_reentrant_buffer
+#define PL_reentrant_buffer (*Perl_Ireentrant_buffer_ptr(aTHX))
+#undef PL_reentrant_retint
+#define PL_reentrant_retint (*Perl_Ireentrant_retint_ptr(aTHX))
+#undef PL_reg_state
+#define PL_reg_state (*Perl_Ireg_state_ptr(aTHX))
+#undef PL_regdummy
+#define PL_regdummy (*Perl_Iregdummy_ptr(aTHX))
+#undef PL_regex_pad
+#define PL_regex_pad (*Perl_Iregex_pad_ptr(aTHX))
+#undef PL_regex_padav
+#define PL_regex_padav (*Perl_Iregex_padav_ptr(aTHX))
+#undef PL_reginterp_cnt
+#define PL_reginterp_cnt (*Perl_Ireginterp_cnt_ptr(aTHX))
+#undef PL_registered_mros
+#define PL_registered_mros (*Perl_Iregistered_mros_ptr(aTHX))
+#undef PL_regmatch_slab
+#define PL_regmatch_slab (*Perl_Iregmatch_slab_ptr(aTHX))
+#undef PL_regmatch_state
+#define PL_regmatch_state (*Perl_Iregmatch_state_ptr(aTHX))
+#undef PL_rehash_seed
+#define PL_rehash_seed (*Perl_Irehash_seed_ptr(aTHX))
+#undef PL_rehash_seed_set
+#define PL_rehash_seed_set (*Perl_Irehash_seed_set_ptr(aTHX))
+#undef PL_replgv
+#define PL_replgv (*Perl_Ireplgv_ptr(aTHX))
+#undef PL_restartop
+#define PL_restartop (*Perl_Irestartop_ptr(aTHX))
+#undef PL_rs
+#define PL_rs (*Perl_Irs_ptr(aTHX))
+#undef PL_runops
+#define PL_runops (*Perl_Irunops_ptr(aTHX))
+#undef PL_savebegin
+#define PL_savebegin (*Perl_Isavebegin_ptr(aTHX))
+#undef PL_savestack
+#define PL_savestack (*Perl_Isavestack_ptr(aTHX))
+#undef PL_savestack_ix
+#define PL_savestack_ix (*Perl_Isavestack_ix_ptr(aTHX))
+#undef PL_savestack_max
+#define PL_savestack_max (*Perl_Isavestack_max_ptr(aTHX))
+#undef PL_sawampersand
+#define PL_sawampersand (*Perl_Isawampersand_ptr(aTHX))
+#undef PL_scopestack
+#define PL_scopestack (*Perl_Iscopestack_ptr(aTHX))
+#undef PL_scopestack_ix
+#define PL_scopestack_ix (*Perl_Iscopestack_ix_ptr(aTHX))
+#undef PL_scopestack_max
+#define PL_scopestack_max (*Perl_Iscopestack_max_ptr(aTHX))
+#undef PL_screamfirst
+#define PL_screamfirst (*Perl_Iscreamfirst_ptr(aTHX))
+#undef PL_screamnext
+#define PL_screamnext (*Perl_Iscreamnext_ptr(aTHX))
+#undef PL_secondgv
+#define PL_secondgv (*Perl_Isecondgv_ptr(aTHX))
+#undef PL_sharehook
+#define PL_sharehook (*Perl_Isharehook_ptr(aTHX))
+#undef PL_sig_pending
+#define PL_sig_pending (*Perl_Isig_pending_ptr(aTHX))
+#undef PL_sighandlerp
+#define PL_sighandlerp (*Perl_Isighandlerp_ptr(aTHX))
+#undef PL_signals
+#define PL_signals (*Perl_Isignals_ptr(aTHX))
+#undef PL_slab_count
+#define PL_slab_count (*Perl_Islab_count_ptr(aTHX))
+#undef PL_slabs
+#define PL_slabs (*Perl_Islabs_ptr(aTHX))
+#undef PL_sort_RealCmp
+#define PL_sort_RealCmp (*Perl_Isort_RealCmp_ptr(aTHX))
+#undef PL_sortcop
+#define PL_sortcop (*Perl_Isortcop_ptr(aTHX))
+#undef PL_sortstash
+#define PL_sortstash (*Perl_Isortstash_ptr(aTHX))
+#undef PL_splitstr
+#define PL_splitstr (*Perl_Isplitstr_ptr(aTHX))
+#undef PL_srand_called
+#define PL_srand_called (*Perl_Isrand_called_ptr(aTHX))
+#undef PL_stack_base
+#define PL_stack_base (*Perl_Istack_base_ptr(aTHX))
+#undef PL_stack_max
+#define PL_stack_max (*Perl_Istack_max_ptr(aTHX))
+#undef PL_stack_sp
+#define PL_stack_sp (*Perl_Istack_sp_ptr(aTHX))
+#undef PL_start_env
+#define PL_start_env (*Perl_Istart_env_ptr(aTHX))
+#undef PL_stashcache
+#define PL_stashcache (*Perl_Istashcache_ptr(aTHX))
+#undef PL_statbuf
+#define PL_statbuf (*Perl_Istatbuf_ptr(aTHX))
+#undef PL_statcache
+#define PL_statcache (*Perl_Istatcache_ptr(aTHX))
+#undef PL_statgv
+#define PL_statgv (*Perl_Istatgv_ptr(aTHX))
+#undef PL_statname
+#define PL_statname (*Perl_Istatname_ptr(aTHX))
+#undef PL_statusvalue
+#define PL_statusvalue (*Perl_Istatusvalue_ptr(aTHX))
+#undef PL_statusvalue_posix
+#define PL_statusvalue_posix (*Perl_Istatusvalue_posix_ptr(aTHX))
+#undef PL_statusvalue_vms
+#define PL_statusvalue_vms (*Perl_Istatusvalue_vms_ptr(aTHX))
+#undef PL_stderrgv
+#define PL_stderrgv (*Perl_Istderrgv_ptr(aTHX))
+#undef PL_stdingv
+#define PL_stdingv (*Perl_Istdingv_ptr(aTHX))
+#undef PL_strtab
+#define PL_strtab (*Perl_Istrtab_ptr(aTHX))
+#undef PL_sub_generation
+#define PL_sub_generation (*Perl_Isub_generation_ptr(aTHX))
+#undef PL_subline
+#define PL_subline (*Perl_Isubline_ptr(aTHX))
+#undef PL_subname
+#define PL_subname (*Perl_Isubname_ptr(aTHX))
+#undef PL_sv_arenaroot
+#define PL_sv_arenaroot (*Perl_Isv_arenaroot_ptr(aTHX))
+#undef PL_sv_count
+#define PL_sv_count (*Perl_Isv_count_ptr(aTHX))
+#undef PL_sv_no
+#define PL_sv_no (*Perl_Isv_no_ptr(aTHX))
+#undef PL_sv_objcount
+#define PL_sv_objcount (*Perl_Isv_objcount_ptr(aTHX))
+#undef PL_sv_root
+#define PL_sv_root (*Perl_Isv_root_ptr(aTHX))
+#undef PL_sv_serial
+#define PL_sv_serial (*Perl_Isv_serial_ptr(aTHX))
+#undef PL_sv_undef
+#define PL_sv_undef (*Perl_Isv_undef_ptr(aTHX))
+#undef PL_sv_yes
+#define PL_sv_yes (*Perl_Isv_yes_ptr(aTHX))
+#undef PL_sys_intern
+#define PL_sys_intern (*Perl_Isys_intern_ptr(aTHX))
+#undef PL_taint_warn
+#define PL_taint_warn (*Perl_Itaint_warn_ptr(aTHX))
+#undef PL_tainted
+#define PL_tainted (*Perl_Itainted_ptr(aTHX))
+#undef PL_tainting
+#define PL_tainting (*Perl_Itainting_ptr(aTHX))
+#undef PL_threadhook
+#define PL_threadhook (*Perl_Ithreadhook_ptr(aTHX))
+#undef PL_timesbuf
+#define PL_timesbuf (*Perl_Itimesbuf_ptr(aTHX))
+#undef PL_tmps_floor
+#define PL_tmps_floor (*Perl_Itmps_floor_ptr(aTHX))
+#undef PL_tmps_ix
+#define PL_tmps_ix (*Perl_Itmps_ix_ptr(aTHX))
+#undef PL_tmps_max
+#define PL_tmps_max (*Perl_Itmps_max_ptr(aTHX))
+#undef PL_tmps_stack
+#define PL_tmps_stack (*Perl_Itmps_stack_ptr(aTHX))
+#undef PL_top_env
+#define PL_top_env (*Perl_Itop_env_ptr(aTHX))
+#undef PL_toptarget
+#define PL_toptarget (*Perl_Itoptarget_ptr(aTHX))
+#undef PL_uid
+#define PL_uid (*Perl_Iuid_ptr(aTHX))
+#undef PL_unicode
+#define PL_unicode (*Perl_Iunicode_ptr(aTHX))
+#undef PL_unitcheckav
+#define PL_unitcheckav (*Perl_Iunitcheckav_ptr(aTHX))
+#undef PL_unitcheckav_save
+#define PL_unitcheckav_save (*Perl_Iunitcheckav_save_ptr(aTHX))
+#undef PL_unlockhook
+#define PL_unlockhook (*Perl_Iunlockhook_ptr(aTHX))
+#undef PL_unsafe
+#define PL_unsafe (*Perl_Iunsafe_ptr(aTHX))
+#undef PL_utf8_alnum
+#define PL_utf8_alnum (*Perl_Iutf8_alnum_ptr(aTHX))
+#undef PL_utf8_alnumc
+#define PL_utf8_alnumc (*Perl_Iutf8_alnumc_ptr(aTHX))
+#undef PL_utf8_alpha
+#define PL_utf8_alpha (*Perl_Iutf8_alpha_ptr(aTHX))
+#undef PL_utf8_ascii
+#define PL_utf8_ascii (*Perl_Iutf8_ascii_ptr(aTHX))
+#undef PL_utf8_cntrl
+#define PL_utf8_cntrl (*Perl_Iutf8_cntrl_ptr(aTHX))
+#undef PL_utf8_digit
+#define PL_utf8_digit (*Perl_Iutf8_digit_ptr(aTHX))
+#undef PL_utf8_graph
+#define PL_utf8_graph (*Perl_Iutf8_graph_ptr(aTHX))
+#undef PL_utf8_idcont
+#define PL_utf8_idcont (*Perl_Iutf8_idcont_ptr(aTHX))
+#undef PL_utf8_idstart
+#define PL_utf8_idstart (*Perl_Iutf8_idstart_ptr(aTHX))
+#undef PL_utf8_lower
+#define PL_utf8_lower (*Perl_Iutf8_lower_ptr(aTHX))
+#undef PL_utf8_mark
+#define PL_utf8_mark (*Perl_Iutf8_mark_ptr(aTHX))
+#undef PL_utf8_print
+#define PL_utf8_print (*Perl_Iutf8_print_ptr(aTHX))
+#undef PL_utf8_punct
+#define PL_utf8_punct (*Perl_Iutf8_punct_ptr(aTHX))
+#undef PL_utf8_space
+#define PL_utf8_space (*Perl_Iutf8_space_ptr(aTHX))
+#undef PL_utf8_tofold
+#define PL_utf8_tofold (*Perl_Iutf8_tofold_ptr(aTHX))
+#undef PL_utf8_tolower
+#define PL_utf8_tolower (*Perl_Iutf8_tolower_ptr(aTHX))
+#undef PL_utf8_totitle
+#define PL_utf8_totitle (*Perl_Iutf8_totitle_ptr(aTHX))
+#undef PL_utf8_toupper
+#define PL_utf8_toupper (*Perl_Iutf8_toupper_ptr(aTHX))
+#undef PL_utf8_upper
+#define PL_utf8_upper (*Perl_Iutf8_upper_ptr(aTHX))
+#undef PL_utf8_xdigit
+#define PL_utf8_xdigit (*Perl_Iutf8_xdigit_ptr(aTHX))
+#undef PL_utf8cache
+#define PL_utf8cache (*Perl_Iutf8cache_ptr(aTHX))
+#undef PL_utf8locale
+#define PL_utf8locale (*Perl_Iutf8locale_ptr(aTHX))
+#undef PL_warnhook
+#define PL_warnhook (*Perl_Iwarnhook_ptr(aTHX))
+#undef PL_watchaddr
+#define PL_watchaddr (*Perl_Iwatchaddr_ptr(aTHX))
+#undef PL_watchok
+#define PL_watchok (*Perl_Iwatchok_ptr(aTHX))
+#undef PL_xmlfp
+#define PL_xmlfp (*Perl_Ixmlfp_ptr(aTHX))
+#undef PL_No
+#define PL_No (*Perl_GNo_ptr(NULL))
+#undef PL_Yes
+#define PL_Yes (*Perl_GYes_ptr(NULL))
+#undef PL_appctx
+#define PL_appctx (*Perl_Gappctx_ptr(NULL))
+#undef PL_check
+#define PL_check (*Perl_Gcheck_ptr(NULL))
+#undef PL_csighandlerp
+#define PL_csighandlerp (*Perl_Gcsighandlerp_ptr(NULL))
+#undef PL_curinterp
+#define PL_curinterp (*Perl_Gcurinterp_ptr(NULL))
+#undef PL_do_undump
+#define PL_do_undump (*Perl_Gdo_undump_ptr(NULL))
+#undef PL_dollarzero_mutex
+#define PL_dollarzero_mutex (*Perl_Gdollarzero_mutex_ptr(NULL))
+#undef PL_fold_locale
+#define PL_fold_locale (*Perl_Gfold_locale_ptr(NULL))
+#undef PL_global_struct_size
+#define PL_global_struct_size (*Perl_Gglobal_struct_size_ptr(NULL))
+#undef PL_hexdigit
+#define PL_hexdigit (*Perl_Ghexdigit_ptr(NULL))
+#undef PL_hints_mutex
+#define PL_hints_mutex (*Perl_Ghints_mutex_ptr(NULL))
+#undef PL_interp_size
+#define PL_interp_size (*Perl_Ginterp_size_ptr(NULL))
+#undef PL_interp_size_5_10_0
+#define PL_interp_size_5_10_0 (*Perl_Ginterp_size_5_10_0_ptr(NULL))
+#undef PL_malloc_mutex
+#define PL_malloc_mutex (*Perl_Gmalloc_mutex_ptr(NULL))
+#undef PL_mmap_page_size
+#define PL_mmap_page_size (*Perl_Gmmap_page_size_ptr(NULL))
+#undef PL_my_ctx_mutex
+#define PL_my_ctx_mutex (*Perl_Gmy_ctx_mutex_ptr(NULL))
+#undef PL_my_cxt_index
+#define PL_my_cxt_index (*Perl_Gmy_cxt_index_ptr(NULL))
+#undef PL_op_mutex
+#define PL_op_mutex (*Perl_Gop_mutex_ptr(NULL))
+#undef PL_op_seq
+#define PL_op_seq (*Perl_Gop_seq_ptr(NULL))
+#undef PL_op_sequence
+#define PL_op_sequence (*Perl_Gop_sequence_ptr(NULL))
+#undef PL_patleave
+#define PL_patleave (*Perl_Gpatleave_ptr(NULL))
+#undef PL_perlio_debug_fd
+#define PL_perlio_debug_fd (*Perl_Gperlio_debug_fd_ptr(NULL))
+#undef PL_perlio_fd_refcnt
+#define PL_perlio_fd_refcnt (*Perl_Gperlio_fd_refcnt_ptr(NULL))
+#undef PL_perlio_fd_refcnt_size
+#define PL_perlio_fd_refcnt_size (*Perl_Gperlio_fd_refcnt_size_ptr(NULL))
+#undef PL_perlio_mutex
+#define PL_perlio_mutex (*Perl_Gperlio_mutex_ptr(NULL))
+#undef PL_ppaddr
+#define PL_ppaddr (*Perl_Gppaddr_ptr(NULL))
+#undef PL_revision
+#define PL_revision (*Perl_Grevision_ptr(NULL))
+#undef PL_runops_dbg
+#define PL_runops_dbg (*Perl_Grunops_dbg_ptr(NULL))
+#undef PL_runops_std
+#define PL_runops_std (*Perl_Grunops_std_ptr(NULL))
+#undef PL_sh_path
+#define PL_sh_path (*Perl_Gsh_path_ptr(NULL))
+#undef PL_sig_defaulting
+#define PL_sig_defaulting (*Perl_Gsig_defaulting_ptr(NULL))
+#undef PL_sig_handlers_initted
+#define PL_sig_handlers_initted (*Perl_Gsig_handlers_initted_ptr(NULL))
+#undef PL_sig_ignoring
+#define PL_sig_ignoring (*Perl_Gsig_ignoring_ptr(NULL))
+#undef PL_sig_sv
+#define PL_sig_sv (*Perl_Gsig_sv_ptr(NULL))
+#undef PL_sig_trapped
+#define PL_sig_trapped (*Perl_Gsig_trapped_ptr(NULL))
+#undef PL_sigfpe_saved
+#define PL_sigfpe_saved (*Perl_Gsigfpe_saved_ptr(NULL))
+#undef PL_subversion
+#define PL_subversion (*Perl_Gsubversion_ptr(NULL))
+#undef PL_sv_placeholder
+#define PL_sv_placeholder (*Perl_Gsv_placeholder_ptr(NULL))
+#undef PL_thr_key
+#define PL_thr_key (*Perl_Gthr_key_ptr(NULL))
+#undef PL_timesbase
+#define PL_timesbase (*Perl_Gtimesbase_ptr(NULL))
+#undef PL_use_safe_putenv
+#define PL_use_safe_putenv (*Perl_Guse_safe_putenv_ptr(NULL))
+#undef PL_version
+#define PL_version (*Perl_Gversion_ptr(NULL))
+#undef PL_veto_cleanup
+#define PL_veto_cleanup (*Perl_Gveto_cleanup_ptr(NULL))
+#undef PL_watch_pvx
+#define PL_watch_pvx (*Perl_Gwatch_pvx_ptr(NULL))
+
+#endif /* !PERL_CORE */
+#endif /* MULTIPLICITY */
+
+#endif /* __perlapi_h__ */
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perlhost.h b/Master/tlpkg/tlperl.straw/lib/CORE/perlhost.h
new file mode 100755
index 00000000000..3bd3e16a5ac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perlhost.h
@@ -0,0 +1,2456 @@
+/* perlhost.h
+ *
+ * (c) 1999 Microsoft Corporation. All rights reserved.
+ * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+
+#ifndef UNDER_CE
+#define CHECK_HOST_INTERP
+#endif
+
+#ifndef ___PerlHost_H___
+#define ___PerlHost_H___
+
+#ifndef UNDER_CE
+#include <signal.h>
+#endif
+#include "iperlsys.h"
+#include "vmem.h"
+#include "vdir.h"
+
+#ifndef WC_NO_BEST_FIT_CHARS
+# define WC_NO_BEST_FIT_CHARS 0x00000400
+#endif
+
+START_EXTERN_C
+extern char * g_win32_get_privlib(const char *pl);
+extern char * g_win32_get_sitelib(const char *pl);
+extern char * g_win32_get_vendorlib(const char *pl);
+extern char * g_getlogin(void);
+END_EXTERN_C
+
+class CPerlHost
+{
+public:
+ /* Constructors */
+ CPerlHost(void);
+ CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc);
+ CPerlHost(CPerlHost& host);
+ ~CPerlHost(void);
+
+ static CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl);
+ static CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl);
+ static CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl);
+ static CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl);
+ static CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl);
+ static CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl);
+
+ BOOL PerlCreate(void);
+ int PerlParse(int argc, char** argv, char** env);
+ int PerlRun(void);
+ void PerlDestroy(void);
+
+/* IPerlMem */
+ /* Locks provided but should be unnecessary as this is private pool */
+ inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); };
+ inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); };
+ inline void Free(void* ptr) { m_pVMem->Free(ptr); };
+ inline void* Calloc(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = Malloc(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+ inline void GetLock(void) { m_pVMem->GetLock(); };
+ inline void FreeLock(void) { m_pVMem->FreeLock(); };
+ inline int IsLocked(void) { return m_pVMem->IsLocked(); };
+
+/* IPerlMemShared */
+ /* Locks used to serialize access to the pool */
+ inline void GetLockShared(void) { m_pVMemShared->GetLock(); };
+ inline void FreeLockShared(void) { m_pVMemShared->FreeLock(); };
+ inline int IsLockedShared(void) { return m_pVMemShared->IsLocked(); };
+ inline void* MallocShared(size_t size)
+ {
+ void *result;
+ GetLockShared();
+ result = m_pVMemShared->Malloc(size);
+ FreeLockShared();
+ return result;
+ };
+ inline void* ReallocShared(void* ptr, size_t size)
+ {
+ void *result;
+ GetLockShared();
+ result = m_pVMemShared->Realloc(ptr, size);
+ FreeLockShared();
+ return result;
+ };
+ inline void FreeShared(void* ptr)
+ {
+ GetLockShared();
+ m_pVMemShared->Free(ptr);
+ FreeLockShared();
+ };
+ inline void* CallocShared(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = MallocShared(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+
+/* IPerlMemParse */
+ /* Assume something else is using locks to mangaging serialize
+ on a batch basis
+ */
+ inline void GetLockParse(void) { m_pVMemParse->GetLock(); };
+ inline void FreeLockParse(void) { m_pVMemParse->FreeLock(); };
+ inline int IsLockedParse(void) { return m_pVMemParse->IsLocked(); };
+ inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); };
+ inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); };
+ inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); };
+ inline void* CallocParse(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = MallocParse(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+
+/* IPerlEnv */
+ char *Getenv(const char *varname);
+ int Putenv(const char *envstring);
+ inline char *Getenv(const char *varname, unsigned long *len)
+ {
+ *len = 0;
+ char *e = Getenv(varname);
+ if (e)
+ *len = strlen(e);
+ return e;
+ }
+ void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); };
+ void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); };
+ char* GetChildDir(void);
+ void FreeChildDir(char* pStr);
+ void Reset(void);
+ void Clearenv(void);
+
+ inline LPSTR GetIndex(DWORD &dwIndex)
+ {
+ if(dwIndex < m_dwEnvCount)
+ {
+ ++dwIndex;
+ return m_lppEnvList[dwIndex-1];
+ }
+ return NULL;
+ };
+
+protected:
+ LPSTR Find(LPCSTR lpStr);
+ void Add(LPCSTR lpStr);
+
+ LPSTR CreateLocalEnvironmentStrings(VDir &vDir);
+ void FreeLocalEnvironmentStrings(LPSTR lpStr);
+ LPSTR* Lookup(LPCSTR lpStr);
+ DWORD CalculateEnvironmentSpace(void);
+
+public:
+
+/* IPerlDIR */
+ virtual int Chdir(const char *dirname);
+
+/* IPerllProc */
+ void Abort(void);
+ void Exit(int status);
+ void _Exit(int status);
+ int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3);
+ int Execv(const char *cmdname, const char *const *argv);
+ int Execvp(const char *cmdname, const char *const *argv);
+
+ inline VMem* GetMemShared(void) { m_pVMemShared->AddRef(); return m_pVMemShared; };
+ inline VMem* GetMemParse(void) { m_pVMemParse->AddRef(); return m_pVMemParse; };
+ inline VDir* GetDir(void) { return m_pvDir; };
+
+public:
+
+ struct IPerlMem m_hostperlMem;
+ struct IPerlMem m_hostperlMemShared;
+ struct IPerlMem m_hostperlMemParse;
+ struct IPerlEnv m_hostperlEnv;
+ struct IPerlStdIO m_hostperlStdIO;
+ struct IPerlLIO m_hostperlLIO;
+ struct IPerlDir m_hostperlDir;
+ struct IPerlSock m_hostperlSock;
+ struct IPerlProc m_hostperlProc;
+
+ struct IPerlMem* m_pHostperlMem;
+ struct IPerlMem* m_pHostperlMemShared;
+ struct IPerlMem* m_pHostperlMemParse;
+ struct IPerlEnv* m_pHostperlEnv;
+ struct IPerlStdIO* m_pHostperlStdIO;
+ struct IPerlLIO* m_pHostperlLIO;
+ struct IPerlDir* m_pHostperlDir;
+ struct IPerlSock* m_pHostperlSock;
+ struct IPerlProc* m_pHostperlProc;
+
+ inline char* MapPathA(const char *pInName) { return m_pvDir->MapPathA(pInName); };
+ inline WCHAR* MapPathW(const WCHAR *pInName) { return m_pvDir->MapPathW(pInName); };
+protected:
+
+ VDir* m_pvDir;
+ VMem* m_pVMem;
+ VMem* m_pVMemShared;
+ VMem* m_pVMemParse;
+
+ DWORD m_dwEnvCount;
+ LPSTR* m_lppEnvList;
+ BOOL m_bTopLevel; // is this a toplevel host?
+ static long num_hosts;
+public:
+ inline int LastHost(void) { return num_hosts == 1L; };
+ struct interpreter *host_perl;
+};
+
+long CPerlHost::num_hosts = 0L;
+
+extern "C" void win32_checkTLS(struct interpreter *host_perl);
+
+#define STRUCT2RAWPTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
+#ifdef CHECK_HOST_INTERP
+inline CPerlHost* CheckInterp(CPerlHost *host)
+{
+ win32_checkTLS(host->host_perl);
+ return host;
+}
+#define STRUCT2PTR(x, y) CheckInterp(STRUCT2RAWPTR(x, y))
+#else
+#define STRUCT2PTR(x, y) STRUCT2RAWPTR(x, y)
+#endif
+
+inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2RAWPTR(piPerl, m_hostperlMem);
+}
+
+inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2RAWPTR(piPerl, m_hostperlMemShared);
+}
+
+inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2RAWPTR(piPerl, m_hostperlMemParse);
+}
+
+inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlEnv);
+}
+
+inline CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlStdIO);
+}
+
+inline CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlLIO);
+}
+
+inline CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlDir);
+}
+
+inline CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlSock);
+}
+
+inline CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlProc);
+}
+
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMem2Host(x)
+
+/* IPerlMem */
+void*
+PerlMemMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->Malloc(size);
+}
+void*
+PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->Realloc(ptr, size);
+}
+void
+PerlMemFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->Free(ptr);
+}
+void*
+PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->Calloc(num, size);
+}
+
+void
+PerlMemGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLock();
+}
+
+void
+PerlMemFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLock();
+}
+
+int
+PerlMemIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLocked();
+}
+
+struct IPerlMem perlMem =
+{
+ PerlMemMalloc,
+ PerlMemRealloc,
+ PerlMemFree,
+ PerlMemCalloc,
+ PerlMemGetLock,
+ PerlMemFreeLock,
+ PerlMemIsLocked,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMemShared2Host(x)
+
+/* IPerlMemShared */
+void*
+PerlMemSharedMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->MallocShared(size);
+}
+void*
+PerlMemSharedRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->ReallocShared(ptr, size);
+}
+void
+PerlMemSharedFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->FreeShared(ptr);
+}
+void*
+PerlMemSharedCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->CallocShared(num, size);
+}
+
+void
+PerlMemSharedGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLockShared();
+}
+
+void
+PerlMemSharedFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLockShared();
+}
+
+int
+PerlMemSharedIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLockedShared();
+}
+
+struct IPerlMem perlMemShared =
+{
+ PerlMemSharedMalloc,
+ PerlMemSharedRealloc,
+ PerlMemSharedFree,
+ PerlMemSharedCalloc,
+ PerlMemSharedGetLock,
+ PerlMemSharedFreeLock,
+ PerlMemSharedIsLocked,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMemParse2Host(x)
+
+/* IPerlMemParse */
+void*
+PerlMemParseMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->MallocParse(size);
+}
+void*
+PerlMemParseRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->ReallocParse(ptr, size);
+}
+void
+PerlMemParseFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->FreeParse(ptr);
+}
+void*
+PerlMemParseCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->CallocParse(num, size);
+}
+
+void
+PerlMemParseGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLockParse();
+}
+
+void
+PerlMemParseFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLockParse();
+}
+
+int
+PerlMemParseIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLockedParse();
+}
+
+struct IPerlMem perlMemParse =
+{
+ PerlMemParseMalloc,
+ PerlMemParseRealloc,
+ PerlMemParseFree,
+ PerlMemParseCalloc,
+ PerlMemParseGetLock,
+ PerlMemParseFreeLock,
+ PerlMemParseIsLocked,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlEnv2Host(x)
+
+/* IPerlEnv */
+char*
+PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname)
+{
+ return IPERL2HOST(piPerl)->Getenv(varname);
+};
+
+int
+PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring)
+{
+ return IPERL2HOST(piPerl)->Putenv(envstring);
+};
+
+char*
+PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len)
+{
+ return IPERL2HOST(piPerl)->Getenv(varname, len);
+}
+
+int
+PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name)
+{
+ return win32_uname(name);
+}
+
+void
+PerlEnvClearenv(struct IPerlEnv* piPerl)
+{
+ IPERL2HOST(piPerl)->Clearenv();
+}
+
+void*
+PerlEnvGetChildenv(struct IPerlEnv* piPerl)
+{
+ return IPERL2HOST(piPerl)->CreateChildEnv();
+}
+
+void
+PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv)
+{
+ IPERL2HOST(piPerl)->FreeChildEnv(childEnv);
+}
+
+char*
+PerlEnvGetChilddir(struct IPerlEnv* piPerl)
+{
+ return IPERL2HOST(piPerl)->GetChildDir();
+}
+
+void
+PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir)
+{
+ IPERL2HOST(piPerl)->FreeChildDir(childDir);
+}
+
+unsigned long
+PerlEnvOsId(struct IPerlEnv* piPerl)
+{
+ return win32_os_id();
+}
+
+char*
+PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl)
+{
+ return g_win32_get_privlib(pl);
+}
+
+char*
+PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl)
+{
+ return g_win32_get_sitelib(pl);
+}
+
+char*
+PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl)
+{
+ return g_win32_get_vendorlib(pl);
+}
+
+void
+PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr)
+{
+ win32_get_child_IO(ptr);
+}
+
+struct IPerlEnv perlEnv =
+{
+ PerlEnvGetenv,
+ PerlEnvPutenv,
+ PerlEnvGetenv_len,
+ PerlEnvUname,
+ PerlEnvClearenv,
+ PerlEnvGetChildenv,
+ PerlEnvFreeChildenv,
+ PerlEnvGetChilddir,
+ PerlEnvFreeChilddir,
+ PerlEnvOsId,
+ PerlEnvLibPath,
+ PerlEnvSiteLibPath,
+ PerlEnvVendorLibPath,
+ PerlEnvGetChildIO,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlStdIO2Host(x)
+
+/* PerlStdIO */
+FILE*
+PerlStdIOStdin(struct IPerlStdIO* piPerl)
+{
+ return win32_stdin();
+}
+
+FILE*
+PerlStdIOStdout(struct IPerlStdIO* piPerl)
+{
+ return win32_stdout();
+}
+
+FILE*
+PerlStdIOStderr(struct IPerlStdIO* piPerl)
+{
+ return win32_stderr();
+}
+
+FILE*
+PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode)
+{
+ return win32_fopen(path, mode);
+}
+
+int
+PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_fclose((pf));
+}
+
+int
+PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_feof(pf);
+}
+
+int
+PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_ferror(pf);
+}
+
+void
+PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ win32_clearerr(pf);
+}
+
+int
+PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_getc(pf);
+}
+
+STDCHAR*
+PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef FILE_base
+ FILE *f = pf;
+ return FILE_base(f);
+#else
+ return NULL;
+#endif
+}
+
+int
+PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef FILE_bufsiz
+ FILE *f = pf;
+ return FILE_bufsiz(f);
+#else
+ return (-1);
+#endif
+}
+
+int
+PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef USE_STDIO_PTR
+ FILE *f = pf;
+ return FILE_cnt(f);
+#else
+ return (-1);
+#endif
+}
+
+STDCHAR*
+PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef USE_STDIO_PTR
+ FILE *f = pf;
+ return FILE_ptr(f);
+#else
+ return NULL;
+#endif
+}
+
+char*
+PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n)
+{
+ return win32_fgets(s, n, pf);
+}
+
+int
+PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c)
+{
+ return win32_fputc(c, pf);
+}
+
+int
+PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s)
+{
+ return win32_fputs(s, pf);
+}
+
+int
+PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_fflush(pf);
+}
+
+int
+PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf)
+{
+ return win32_ungetc(c, pf);
+}
+
+int
+PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_fileno(pf);
+}
+
+FILE*
+PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode)
+{
+ return win32_fdopen(fd, mode);
+}
+
+FILE*
+PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf)
+{
+ return win32_freopen(path, mode, (FILE*)pf);
+}
+
+SSize_t
+PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf)
+{
+ return win32_fread(buffer, size, count, pf);
+}
+
+SSize_t
+PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf)
+{
+ return win32_fwrite(buffer, size, count, pf);
+}
+
+void
+PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer)
+{
+ win32_setbuf(pf, buffer);
+}
+
+int
+PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size)
+{
+ return win32_setvbuf(pf, buffer, type, size);
+}
+
+void
+PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n)
+{
+#ifdef STDIO_CNT_LVALUE
+ FILE *f = pf;
+ FILE_cnt(f) = n;
+#endif
+}
+
+void
+PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr)
+{
+#ifdef STDIO_PTR_LVALUE
+ FILE *f = pf;
+ FILE_ptr(f) = ptr;
+#endif
+}
+
+void
+PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ win32_setvbuf(pf, NULL, _IOLBF, 0);
+}
+
+int
+PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...)
+{
+ va_list(arglist);
+ va_start(arglist, format);
+ return win32_vfprintf(pf, format, arglist);
+}
+
+int
+PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist)
+{
+ return win32_vfprintf(pf, format, arglist);
+}
+
+Off_t
+PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_ftell(pf);
+}
+
+int
+PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, Off_t offset, int origin)
+{
+ return win32_fseek(pf, offset, origin);
+}
+
+void
+PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ win32_rewind(pf);
+}
+
+FILE*
+PerlStdIOTmpfile(struct IPerlStdIO* piPerl)
+{
+ return win32_tmpfile();
+}
+
+int
+PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p)
+{
+ return win32_fgetpos(pf, p);
+}
+
+int
+PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p)
+{
+ return win32_fsetpos(pf, p);
+}
+void
+PerlStdIOInit(struct IPerlStdIO* piPerl)
+{
+}
+
+void
+PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl)
+{
+ Perl_init_os_extras();
+}
+
+int
+PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, intptr_t osfhandle, int flags)
+{
+ return win32_open_osfhandle(osfhandle, flags);
+}
+
+intptr_t
+PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
+{
+ return win32_get_osfhandle(filenum);
+}
+
+FILE*
+PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifndef UNDER_CE
+ FILE* pfdup;
+ fpos_t pos;
+ char mode[3];
+ int fileno = win32_dup(win32_fileno(pf));
+
+ /* open the file in the same mode */
+#ifdef __BORLANDC__
+ if((pf)->flags & _F_READ) {
+ mode[0] = 'r';
+ mode[1] = 0;
+ }
+ else if((pf)->flags & _F_WRIT) {
+ mode[0] = 'a';
+ mode[1] = 0;
+ }
+ else if((pf)->flags & _F_RDWR) {
+ mode[0] = 'r';
+ mode[1] = '+';
+ mode[2] = 0;
+ }
+#else
+ if((pf)->_flag & _IOREAD) {
+ mode[0] = 'r';
+ mode[1] = 0;
+ }
+ else if((pf)->_flag & _IOWRT) {
+ mode[0] = 'a';
+ mode[1] = 0;
+ }
+ else if((pf)->_flag & _IORW) {
+ mode[0] = 'r';
+ mode[1] = '+';
+ mode[2] = 0;
+ }
+#endif
+
+ /* it appears that the binmode is attached to the
+ * file descriptor so binmode files will be handled
+ * correctly
+ */
+ pfdup = win32_fdopen(fileno, mode);
+
+ /* move the file pointer to the same position */
+ if (!fgetpos(pf, &pos)) {
+ fsetpos(pfdup, &pos);
+ }
+ return pfdup;
+#else
+ return 0;
+#endif
+}
+
+struct IPerlStdIO perlStdIO =
+{
+ PerlStdIOStdin,
+ PerlStdIOStdout,
+ PerlStdIOStderr,
+ PerlStdIOOpen,
+ PerlStdIOClose,
+ PerlStdIOEof,
+ PerlStdIOError,
+ PerlStdIOClearerr,
+ PerlStdIOGetc,
+ PerlStdIOGetBase,
+ PerlStdIOGetBufsiz,
+ PerlStdIOGetCnt,
+ PerlStdIOGetPtr,
+ PerlStdIOGets,
+ PerlStdIOPutc,
+ PerlStdIOPuts,
+ PerlStdIOFlush,
+ PerlStdIOUngetc,
+ PerlStdIOFileno,
+ PerlStdIOFdopen,
+ PerlStdIOReopen,
+ PerlStdIORead,
+ PerlStdIOWrite,
+ PerlStdIOSetBuf,
+ PerlStdIOSetVBuf,
+ PerlStdIOSetCnt,
+ PerlStdIOSetPtr,
+ PerlStdIOSetlinebuf,
+ PerlStdIOPrintf,
+ PerlStdIOVprintf,
+ PerlStdIOTell,
+ PerlStdIOSeek,
+ PerlStdIORewind,
+ PerlStdIOTmpfile,
+ PerlStdIOGetpos,
+ PerlStdIOSetpos,
+ PerlStdIOInit,
+ PerlStdIOInitOSExtras,
+ PerlStdIOFdupopen,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlLIO2Host(x)
+
+/* IPerlLIO */
+int
+PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode)
+{
+ return win32_access(path, mode);
+}
+
+int
+PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode)
+{
+ return win32_chmod(filename, pmode);
+}
+
+int
+PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group)
+{
+ return chown(filename, owner, group);
+}
+
+int
+PerlLIOChsize(struct IPerlLIO* piPerl, int handle, Off_t size)
+{
+ return win32_chsize(handle, size);
+}
+
+int
+PerlLIOClose(struct IPerlLIO* piPerl, int handle)
+{
+ return win32_close(handle);
+}
+
+int
+PerlLIODup(struct IPerlLIO* piPerl, int handle)
+{
+ return win32_dup(handle);
+}
+
+int
+PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2)
+{
+ return win32_dup2(handle1, handle2);
+}
+
+int
+PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
+{
+ return win32_flock(fd, oper);
+}
+
+int
+PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, Stat_t *buffer)
+{
+ return win32_fstat(handle, buffer);
+}
+
+int
+PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
+{
+ u_long u_long_arg;
+ int retval;
+
+ /* mauke says using memcpy avoids alignment issues */
+ memcpy(&u_long_arg, data, sizeof u_long_arg);
+ retval = win32_ioctlsocket((SOCKET)i, (long)u, &u_long_arg);
+ memcpy(data, &u_long_arg, sizeof u_long_arg);
+ return retval;
+}
+
+int
+PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
+{
+ return isatty(fd);
+}
+
+int
+PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
+{
+ return win32_link(oldname, newname);
+}
+
+Off_t
+PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin)
+{
+ return win32_lseek(handle, offset, origin);
+}
+
+int
+PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
+{
+ return win32_stat(path, buffer);
+}
+
+char*
+PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
+{
+ return mktemp(Template);
+}
+
+int
+PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
+{
+ return win32_open(filename, oflag);
+}
+
+int
+PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
+{
+ return win32_open(filename, oflag, pmode);
+}
+
+int
+PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
+{
+ return win32_read(handle, buffer, count);
+}
+
+int
+PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
+{
+ return win32_rename(OldFileName, newname);
+}
+
+int
+PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
+{
+ return win32_setmode(handle, mode);
+}
+
+int
+PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
+{
+ return win32_stat(path, buffer);
+}
+
+char*
+PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
+{
+ return tmpnam(string);
+}
+
+int
+PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
+{
+ return umask(pmode);
+}
+
+int
+PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
+{
+ return win32_unlink(filename);
+}
+
+int
+PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times)
+{
+ return win32_utime(filename, times);
+}
+
+int
+PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
+{
+ return win32_write(handle, buffer, count);
+}
+
+struct IPerlLIO perlLIO =
+{
+ PerlLIOAccess,
+ PerlLIOChmod,
+ PerlLIOChown,
+ PerlLIOChsize,
+ PerlLIOClose,
+ PerlLIODup,
+ PerlLIODup2,
+ PerlLIOFlock,
+ PerlLIOFileStat,
+ PerlLIOIOCtl,
+ PerlLIOIsatty,
+ PerlLIOLink,
+ PerlLIOLseek,
+ PerlLIOLstat,
+ PerlLIOMktemp,
+ PerlLIOOpen,
+ PerlLIOOpen3,
+ PerlLIORead,
+ PerlLIORename,
+ PerlLIOSetmode,
+ PerlLIONameStat,
+ PerlLIOTmpnam,
+ PerlLIOUmask,
+ PerlLIOUnlink,
+ PerlLIOUtime,
+ PerlLIOWrite,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlDir2Host(x)
+
+/* IPerlDIR */
+int
+PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
+{
+ return win32_mkdir(dirname, mode);
+}
+
+int
+PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
+{
+ return IPERL2HOST(piPerl)->Chdir(dirname);
+}
+
+int
+PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
+{
+ return win32_rmdir(dirname);
+}
+
+int
+PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_closedir(dirp);
+}
+
+DIR*
+PerlDirOpen(struct IPerlDir* piPerl, const char *filename)
+{
+ return win32_opendir(filename);
+}
+
+struct direct *
+PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_readdir(dirp);
+}
+
+void
+PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
+{
+ win32_rewinddir(dirp);
+}
+
+void
+PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
+{
+ win32_seekdir(dirp, loc);
+}
+
+long
+PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_telldir(dirp);
+}
+
+char*
+PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
+{
+ return IPERL2HOST(piPerl)->MapPathA(path);
+}
+
+WCHAR*
+PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
+{
+ return IPERL2HOST(piPerl)->MapPathW(path);
+}
+
+struct IPerlDir perlDir =
+{
+ PerlDirMakedir,
+ PerlDirChdir,
+ PerlDirRmdir,
+ PerlDirClose,
+ PerlDirOpen,
+ PerlDirRead,
+ PerlDirRewind,
+ PerlDirSeek,
+ PerlDirTell,
+ PerlDirMapPathA,
+ PerlDirMapPathW,
+};
+
+
+/* IPerlSock */
+u_long
+PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
+{
+ return win32_htonl(hostlong);
+}
+
+u_short
+PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
+{
+ return win32_htons(hostshort);
+}
+
+u_long
+PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
+{
+ return win32_ntohl(netlong);
+}
+
+u_short
+PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
+{
+ return win32_ntohs(netshort);
+}
+
+SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
+{
+ return win32_accept(s, addr, addrlen);
+}
+
+int
+PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_bind(s, name, namelen);
+}
+
+int
+PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_connect(s, name, namelen);
+}
+
+void
+PerlSockEndhostent(struct IPerlSock* piPerl)
+{
+ win32_endhostent();
+}
+
+void
+PerlSockEndnetent(struct IPerlSock* piPerl)
+{
+ win32_endnetent();
+}
+
+void
+PerlSockEndprotoent(struct IPerlSock* piPerl)
+{
+ win32_endprotoent();
+}
+
+void
+PerlSockEndservent(struct IPerlSock* piPerl)
+{
+ win32_endservent();
+}
+
+struct hostent*
+PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
+{
+ return win32_gethostbyaddr(addr, len, type);
+}
+
+struct hostent*
+PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
+{
+ return win32_gethostbyname(name);
+}
+
+struct hostent*
+PerlSockGethostent(struct IPerlSock* piPerl)
+{
+ dTHX;
+ Perl_croak(aTHX_ "gethostent not implemented!\n");
+ return NULL;
+}
+
+int
+PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
+{
+ return win32_gethostname(name, namelen);
+}
+
+struct netent *
+PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
+{
+ return win32_getnetbyaddr(net, type);
+}
+
+struct netent *
+PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
+{
+ return win32_getnetbyname((char*)name);
+}
+
+struct netent *
+PerlSockGetnetent(struct IPerlSock* piPerl)
+{
+ return win32_getnetent();
+}
+
+int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getpeername(s, name, namelen);
+}
+
+struct protoent*
+PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
+{
+ return win32_getprotobyname(name);
+}
+
+struct protoent*
+PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
+{
+ return win32_getprotobynumber(number);
+}
+
+struct protoent*
+PerlSockGetprotoent(struct IPerlSock* piPerl)
+{
+ return win32_getprotoent();
+}
+
+struct servent*
+PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
+{
+ return win32_getservbyname(name, proto);
+}
+
+struct servent*
+PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
+{
+ return win32_getservbyport(port, proto);
+}
+
+struct servent*
+PerlSockGetservent(struct IPerlSock* piPerl)
+{
+ return win32_getservent();
+}
+
+int
+PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getsockname(s, name, namelen);
+}
+
+int
+PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
+{
+ return win32_getsockopt(s, level, optname, optval, optlen);
+}
+
+unsigned long
+PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
+{
+ return win32_inet_addr(cp);
+}
+
+char*
+PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
+{
+ return win32_inet_ntoa(in);
+}
+
+int
+PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
+{
+ return win32_listen(s, backlog);
+}
+
+int
+PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
+{
+ return win32_recv(s, buffer, len, flags);
+}
+
+int
+PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
+{
+ return win32_recvfrom(s, buffer, len, flags, from, fromlen);
+}
+
+int
+PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
+{
+ return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
+}
+
+int
+PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
+{
+ return win32_send(s, buffer, len, flags);
+}
+
+int
+PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
+{
+ return win32_sendto(s, buffer, len, flags, to, tolen);
+}
+
+void
+PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_sethostent(stayopen);
+}
+
+void
+PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setnetent(stayopen);
+}
+
+void
+PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setprotoent(stayopen);
+}
+
+void
+PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setservent(stayopen);
+}
+
+int
+PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
+{
+ return win32_setsockopt(s, level, optname, optval, optlen);
+}
+
+int
+PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
+{
+ return win32_shutdown(s, how);
+}
+
+SOCKET
+PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
+{
+ return win32_socket(af, type, protocol);
+}
+
+int
+PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
+{
+ return Perl_my_socketpair(domain, type, protocol, fds);
+}
+
+int
+PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
+{
+ return win32_closesocket(s);
+}
+
+int
+PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
+{
+ return win32_ioctlsocket(s, cmd, argp);
+}
+
+struct IPerlSock perlSock =
+{
+ PerlSockHtonl,
+ PerlSockHtons,
+ PerlSockNtohl,
+ PerlSockNtohs,
+ PerlSockAccept,
+ PerlSockBind,
+ PerlSockConnect,
+ PerlSockEndhostent,
+ PerlSockEndnetent,
+ PerlSockEndprotoent,
+ PerlSockEndservent,
+ PerlSockGethostname,
+ PerlSockGetpeername,
+ PerlSockGethostbyaddr,
+ PerlSockGethostbyname,
+ PerlSockGethostent,
+ PerlSockGetnetbyaddr,
+ PerlSockGetnetbyname,
+ PerlSockGetnetent,
+ PerlSockGetprotobyname,
+ PerlSockGetprotobynumber,
+ PerlSockGetprotoent,
+ PerlSockGetservbyname,
+ PerlSockGetservbyport,
+ PerlSockGetservent,
+ PerlSockGetsockname,
+ PerlSockGetsockopt,
+ PerlSockInetAddr,
+ PerlSockInetNtoa,
+ PerlSockListen,
+ PerlSockRecv,
+ PerlSockRecvfrom,
+ PerlSockSelect,
+ PerlSockSend,
+ PerlSockSendto,
+ PerlSockSethostent,
+ PerlSockSetnetent,
+ PerlSockSetprotoent,
+ PerlSockSetservent,
+ PerlSockSetsockopt,
+ PerlSockShutdown,
+ PerlSockSocket,
+ PerlSockSocketpair,
+ PerlSockClosesocket,
+};
+
+
+/* IPerlProc */
+
+#define EXECF_EXEC 1
+#define EXECF_SPAWN 2
+
+void
+PerlProcAbort(struct IPerlProc* piPerl)
+{
+ win32_abort();
+}
+
+char *
+PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
+{
+ return win32_crypt(clear, salt);
+}
+
+void
+PerlProcExit(struct IPerlProc* piPerl, int status)
+{
+ exit(status);
+}
+
+void
+PerlProc_Exit(struct IPerlProc* piPerl, int status)
+{
+ _exit(status);
+}
+
+int
+PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
+{
+ return execl(cmdname, arg0, arg1, arg2, arg3);
+}
+
+int
+PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+int
+PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+uid_t
+PerlProcGetuid(struct IPerlProc* piPerl)
+{
+ return getuid();
+}
+
+uid_t
+PerlProcGeteuid(struct IPerlProc* piPerl)
+{
+ return geteuid();
+}
+
+gid_t
+PerlProcGetgid(struct IPerlProc* piPerl)
+{
+ return getgid();
+}
+
+gid_t
+PerlProcGetegid(struct IPerlProc* piPerl)
+{
+ return getegid();
+}
+
+char *
+PerlProcGetlogin(struct IPerlProc* piPerl)
+{
+ return g_getlogin();
+}
+
+int
+PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
+{
+ return win32_kill(pid, sig);
+}
+
+int
+PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
+{
+ return win32_kill(pid, -sig);
+}
+
+int
+PerlProcPauseProc(struct IPerlProc* piPerl)
+{
+ return win32_sleep((32767L << 16) + 32767);
+}
+
+PerlIO*
+PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
+{
+ dTHX;
+ PERL_FLUSHALL_FOR_CHILD;
+ return win32_popen(command, mode);
+}
+
+PerlIO*
+PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args)
+{
+ dTHX;
+ PERL_FLUSHALL_FOR_CHILD;
+ return win32_popenlist(mode, narg, args);
+}
+
+int
+PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
+{
+ return win32_pclose(stream);
+}
+
+int
+PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
+{
+ return win32_pipe(phandles, 512, O_BINARY);
+}
+
+int
+PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
+{
+ return setuid(u);
+}
+
+int
+PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
+{
+ return setgid(g);
+}
+
+int
+PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
+{
+ return win32_sleep(s);
+}
+
+int
+PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
+{
+ return win32_times(timebuf);
+}
+
+int
+PerlProcWait(struct IPerlProc* piPerl, int *status)
+{
+ return win32_wait(status);
+}
+
+int
+PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
+{
+ return win32_waitpid(pid, status, flags);
+}
+
+Sighandler_t
+PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
+{
+ return win32_signal(sig, subcode);
+}
+
+int
+PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z)
+{
+ return win32_gettimeofday(t, z);
+}
+
+#ifdef USE_ITHREADS
+static THREAD_RET_TYPE
+win32_start_child(LPVOID arg)
+{
+ PerlInterpreter *my_perl = (PerlInterpreter*)arg;
+ GV *tmpgv;
+ int status;
+ HWND parent_message_hwnd;
+#ifdef PERL_SYNC_FORK
+ static long sync_fork_id = 0;
+ long id = ++sync_fork_id;
+#endif
+
+
+ PERL_SET_THX(my_perl);
+ win32_checkTLS(my_perl);
+
+ /* set $$ to pseudo id */
+#ifdef PERL_SYNC_FORK
+ w32_pseudo_id = id;
+#else
+ w32_pseudo_id = GetCurrentThreadId();
+ if (IsWin95()) {
+ int pid = (int)w32_pseudo_id;
+ if (pid < 0)
+ w32_pseudo_id = -pid;
+ }
+#endif
+ if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
+ SV *sv = GvSV(tmpgv);
+ SvREADONLY_off(sv);
+ sv_setiv(sv, -(IV)w32_pseudo_id);
+ SvREADONLY_on(sv);
+ }
+#ifdef PERL_USES_PL_PIDSTATUS
+ hv_clear(PL_pidstatus);
+#endif
+
+ /* create message window and tell parent about it */
+ parent_message_hwnd = w32_message_hwnd;
+ w32_message_hwnd = win32_create_message_window();
+ if (parent_message_hwnd != NULL)
+ PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LONG)w32_message_hwnd);
+
+ /* push a zero on the stack (we are the child) */
+ {
+ dSP;
+ dTARGET;
+ PUSHi(0);
+ PUTBACK;
+ }
+
+ /* continue from next op */
+ PL_op = PL_op->op_next;
+
+ {
+ dJMPENV;
+ volatile int oldscope = PL_scopestack_ix;
+
+restart:
+ JMPENV_PUSH(status);
+ switch (status) {
+ case 0:
+ CALLRUNOPS(aTHX);
+ status = 0;
+ break;
+ case 2:
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ PL_curstash = PL_defstash;
+ if (PL_endav && !PL_minus_c)
+ call_list(oldscope, PL_endav);
+ status = STATUS_EXIT;
+ break;
+ case 3:
+ if (PL_restartop) {
+ POPSTACK_TO(PL_mainstack);
+ PL_op = PL_restartop;
+ PL_restartop = (OP*)NULL;
+ goto restart;
+ }
+ PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ FREETMPS;
+ status = 1;
+ break;
+ }
+ JMPENV_POP;
+
+ /* XXX hack to avoid perl_destruct() freeing optree */
+ win32_checkTLS(my_perl);
+ PL_main_root = (OP*)NULL;
+ }
+
+ win32_checkTLS(my_perl);
+ /* close the std handles to avoid fd leaks */
+ {
+ do_close(PL_stdingv, FALSE);
+ do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */
+ do_close(PL_stderrgv, FALSE);
+ }
+
+ /* destroy everything (waits for any pseudo-forked children) */
+ win32_checkTLS(my_perl);
+ perl_destruct(my_perl);
+ win32_checkTLS(my_perl);
+ perl_free(my_perl);
+
+#ifdef PERL_SYNC_FORK
+ return id;
+#else
+ return (DWORD)status;
+#endif
+}
+#endif /* USE_ITHREADS */
+
+int
+PerlProcFork(struct IPerlProc* piPerl)
+{
+ dTHX;
+#ifdef USE_ITHREADS
+ DWORD id;
+ HANDLE handle;
+ CPerlHost *h;
+
+ if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) {
+ errno = EAGAIN;
+ return -1;
+ }
+ h = new CPerlHost(*(CPerlHost*)w32_internal_host);
+ PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX, 1,
+ h->m_pHostperlMem,
+ h->m_pHostperlMemShared,
+ h->m_pHostperlMemParse,
+ h->m_pHostperlEnv,
+ h->m_pHostperlStdIO,
+ h->m_pHostperlLIO,
+ h->m_pHostperlDir,
+ h->m_pHostperlSock,
+ h->m_pHostperlProc
+ );
+ new_perl->Isys_intern.internal_host = h;
+ h->host_perl = new_perl;
+# ifdef PERL_SYNC_FORK
+ id = win32_start_child((LPVOID)new_perl);
+ PERL_SET_THX(aTHX);
+# else
+ if (w32_message_hwnd == INVALID_HANDLE_VALUE)
+ w32_message_hwnd = win32_create_message_window();
+ new_perl->Isys_intern.message_hwnd = w32_message_hwnd;
+ w32_pseudo_child_message_hwnds[w32_num_pseudo_children] =
+ (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE;
+# ifdef USE_RTL_THREAD_API
+ handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
+ (void*)new_perl, 0, (unsigned*)&id);
+# else
+ handle = CreateThread(NULL, 0, win32_start_child,
+ (LPVOID)new_perl, 0, &id);
+# endif
+ PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
+ if (!handle) {
+ errno = EAGAIN;
+ return -1;
+ }
+ if (IsWin95()) {
+ int pid = (int)id;
+ if (pid < 0)
+ id = -pid;
+ }
+ w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
+ w32_pseudo_child_pids[w32_num_pseudo_children] = id;
+ ++w32_num_pseudo_children;
+# endif
+ return -(int)id;
+#else
+ Perl_croak(aTHX_ "fork() not implemented!\n");
+ return -1;
+#endif /* USE_ITHREADS */
+}
+
+int
+PerlProcGetpid(struct IPerlProc* piPerl)
+{
+ return win32_getpid();
+}
+
+void*
+PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
+{
+ return win32_dynaload(filename);
+}
+
+void
+PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
+{
+ win32_str_os_error(sv, dwErr);
+}
+
+int
+PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
+{
+ return win32_spawnvp(mode, cmdname, argv);
+}
+
+int
+PerlProcLastHost(struct IPerlProc* piPerl)
+{
+ dTHX;
+ CPerlHost *h = (CPerlHost*)w32_internal_host;
+ return h->LastHost();
+}
+
+struct IPerlProc perlProc =
+{
+ PerlProcAbort,
+ PerlProcCrypt,
+ PerlProcExit,
+ PerlProc_Exit,
+ PerlProcExecl,
+ PerlProcExecv,
+ PerlProcExecvp,
+ PerlProcGetuid,
+ PerlProcGeteuid,
+ PerlProcGetgid,
+ PerlProcGetegid,
+ PerlProcGetlogin,
+ PerlProcKill,
+ PerlProcKillpg,
+ PerlProcPauseProc,
+ PerlProcPopen,
+ PerlProcPclose,
+ PerlProcPipe,
+ PerlProcSetuid,
+ PerlProcSetgid,
+ PerlProcSleep,
+ PerlProcTimes,
+ PerlProcWait,
+ PerlProcWaitpid,
+ PerlProcSignal,
+ PerlProcFork,
+ PerlProcGetpid,
+ PerlProcDynaLoader,
+ PerlProcGetOSError,
+ PerlProcSpawnvp,
+ PerlProcLastHost,
+ PerlProcPopenList,
+ PerlProcGetTimeOfDay
+};
+
+
+/*
+ * CPerlHost
+ */
+
+CPerlHost::CPerlHost(void)
+{
+ /* Construct a host from scratch */
+ InterlockedIncrement(&num_hosts);
+ m_pvDir = new VDir();
+ m_pVMem = new VMem();
+ m_pVMemShared = new VMem();
+ m_pVMemParse = new VMem();
+
+ m_pvDir->Init(NULL, m_pVMem);
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+ m_bTopLevel = TRUE;
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+
+ m_pHostperlMem = &m_hostperlMem;
+ m_pHostperlMemShared = &m_hostperlMemShared;
+ m_pHostperlMemParse = &m_hostperlMemParse;
+ m_pHostperlEnv = &m_hostperlEnv;
+ m_pHostperlStdIO = &m_hostperlStdIO;
+ m_pHostperlLIO = &m_hostperlLIO;
+ m_pHostperlDir = &m_hostperlDir;
+ m_pHostperlSock = &m_hostperlSock;
+ m_pHostperlProc = &m_hostperlProc;
+}
+
+#define SETUPEXCHANGE(xptr, iptr, table) \
+ STMT_START { \
+ if (xptr) { \
+ iptr = *xptr; \
+ *xptr = &table; \
+ } \
+ else { \
+ iptr = &table; \
+ } \
+ } STMT_END
+
+CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc)
+{
+ InterlockedIncrement(&num_hosts);
+ m_pvDir = new VDir(0);
+ m_pVMem = new VMem();
+ m_pVMemShared = new VMem();
+ m_pVMemParse = new VMem();
+
+ m_pvDir->Init(NULL, m_pVMem);
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+ m_bTopLevel = FALSE;
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+
+ SETUPEXCHANGE(ppMem, m_pHostperlMem, m_hostperlMem);
+ SETUPEXCHANGE(ppMemShared, m_pHostperlMemShared, m_hostperlMemShared);
+ SETUPEXCHANGE(ppMemParse, m_pHostperlMemParse, m_hostperlMemParse);
+ SETUPEXCHANGE(ppEnv, m_pHostperlEnv, m_hostperlEnv);
+ SETUPEXCHANGE(ppStdIO, m_pHostperlStdIO, m_hostperlStdIO);
+ SETUPEXCHANGE(ppLIO, m_pHostperlLIO, m_hostperlLIO);
+ SETUPEXCHANGE(ppDir, m_pHostperlDir, m_hostperlDir);
+ SETUPEXCHANGE(ppSock, m_pHostperlSock, m_hostperlSock);
+ SETUPEXCHANGE(ppProc, m_pHostperlProc, m_hostperlProc);
+}
+#undef SETUPEXCHANGE
+
+CPerlHost::CPerlHost(CPerlHost& host)
+{
+ /* Construct a host from another host */
+ InterlockedIncrement(&num_hosts);
+ m_pVMem = new VMem();
+ m_pVMemShared = host.GetMemShared();
+ m_pVMemParse = host.GetMemParse();
+
+ /* duplicate directory info */
+ m_pvDir = new VDir(0);
+ m_pvDir->Init(host.GetDir(), m_pVMem);
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+ m_pHostperlMem = &m_hostperlMem;
+ m_pHostperlMemShared = &m_hostperlMemShared;
+ m_pHostperlMemParse = &m_hostperlMemParse;
+ m_pHostperlEnv = &m_hostperlEnv;
+ m_pHostperlStdIO = &m_hostperlStdIO;
+ m_pHostperlLIO = &m_hostperlLIO;
+ m_pHostperlDir = &m_hostperlDir;
+ m_pHostperlSock = &m_hostperlSock;
+ m_pHostperlProc = &m_hostperlProc;
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+ m_bTopLevel = FALSE;
+
+ /* duplicate environment info */
+ LPSTR lpPtr;
+ DWORD dwIndex = 0;
+ while(lpPtr = host.GetIndex(dwIndex))
+ Add(lpPtr);
+}
+
+CPerlHost::~CPerlHost(void)
+{
+ Reset();
+ InterlockedDecrement(&num_hosts);
+ delete m_pvDir;
+ m_pVMemParse->Release();
+ m_pVMemShared->Release();
+ m_pVMem->Release();
+}
+
+LPSTR
+CPerlHost::Find(LPCSTR lpStr)
+{
+ LPSTR lpPtr;
+ LPSTR* lppPtr = Lookup(lpStr);
+ if(lppPtr != NULL) {
+ for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
+ ;
+
+ if(*lpPtr == '=')
+ ++lpPtr;
+
+ return lpPtr;
+ }
+ return NULL;
+}
+
+int
+lookup(const void *arg1, const void *arg2)
+{ // Compare strings
+ char*ptr1, *ptr2;
+ char c1,c2;
+
+ ptr1 = *(char**)arg1;
+ ptr2 = *(char**)arg2;
+ for(;;) {
+ c1 = *ptr1++;
+ c2 = *ptr2++;
+ if(c1 == '\0' || c1 == '=') {
+ if(c2 == '\0' || c2 == '=')
+ break;
+
+ return -1; // string 1 < string 2
+ }
+ else if(c2 == '\0' || c2 == '=')
+ return 1; // string 1 > string 2
+ else if(c1 != c2) {
+ c1 = toupper(c1);
+ c2 = toupper(c2);
+ if(c1 != c2) {
+ if(c1 < c2)
+ return -1; // string 1 < string 2
+
+ return 1; // string 1 > string 2
+ }
+ }
+ }
+ return 0;
+}
+
+LPSTR*
+CPerlHost::Lookup(LPCSTR lpStr)
+{
+#ifdef UNDER_CE
+ if (!m_lppEnvList || !m_dwEnvCount)
+ return NULL;
+#endif
+ if (!lpStr)
+ return NULL;
+ return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
+}
+
+int
+compare(const void *arg1, const void *arg2)
+{ // Compare strings
+ char*ptr1, *ptr2;
+ char c1,c2;
+
+ ptr1 = *(char**)arg1;
+ ptr2 = *(char**)arg2;
+ for(;;) {
+ c1 = *ptr1++;
+ c2 = *ptr2++;
+ if(c1 == '\0' || c1 == '=') {
+ if(c1 == c2)
+ break;
+
+ return -1; // string 1 < string 2
+ }
+ else if(c2 == '\0' || c2 == '=')
+ return 1; // string 1 > string 2
+ else if(c1 != c2) {
+ c1 = toupper(c1);
+ c2 = toupper(c2);
+ if(c1 != c2) {
+ if(c1 < c2)
+ return -1; // string 1 < string 2
+
+ return 1; // string 1 > string 2
+ }
+ }
+ }
+ return 0;
+}
+
+void
+CPerlHost::Add(LPCSTR lpStr)
+{
+ dTHX;
+ char szBuffer[1024];
+ LPSTR *lpPtr;
+ int index, length = strlen(lpStr)+1;
+
+ for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
+ szBuffer[index] = lpStr[index];
+
+ szBuffer[index] = '\0';
+
+ // replacing ?
+ lpPtr = Lookup(szBuffer);
+ if (lpPtr != NULL) {
+ // must allocate things via host memory allocation functions
+ // rather than perl's Renew() et al, as the perl interpreter
+ // may either not be initialized enough when we allocate these,
+ // or may already be dead when we go to free these
+ *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char));
+ strcpy(*lpPtr, lpStr);
+ }
+ else {
+ m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR));
+ if (m_lppEnvList) {
+ m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char));
+ if (m_lppEnvList[m_dwEnvCount] != NULL) {
+ strcpy(m_lppEnvList[m_dwEnvCount], lpStr);
+ ++m_dwEnvCount;
+ qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
+ }
+ }
+ }
+}
+
+DWORD
+CPerlHost::CalculateEnvironmentSpace(void)
+{
+ DWORD index;
+ DWORD dwSize = 0;
+ for(index = 0; index < m_dwEnvCount; ++index)
+ dwSize += strlen(m_lppEnvList[index]) + 1;
+
+ return dwSize;
+}
+
+void
+CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
+{
+ dTHX;
+ Safefree(lpStr);
+}
+
+char*
+CPerlHost::GetChildDir(void)
+{
+ dTHX;
+ char* ptr;
+ size_t length;
+
+ Newx(ptr, MAX_PATH+1, char);
+ m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
+ length = strlen(ptr);
+ if (length > 3) {
+ if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
+ ptr[length-1] = 0;
+ }
+ return ptr;
+}
+
+void
+CPerlHost::FreeChildDir(char* pStr)
+{
+ dTHX;
+ Safefree(pStr);
+}
+
+LPSTR
+CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
+{
+ dTHX;
+ LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
+ DWORD dwSize, dwEnvIndex;
+ int nLength, compVal;
+
+ // get the process environment strings
+ lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
+
+ // step over current directory stuff
+ while(*lpTmp == '=')
+ lpTmp += strlen(lpTmp) + 1;
+
+ // save the start of the environment strings
+ lpEnvPtr = lpTmp;
+ for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
+ // calculate the size of the environment strings
+ dwSize += strlen(lpTmp) + 1;
+ }
+
+ // add the size of current directories
+ dwSize += vDir.CalculateEnvironmentSpace();
+
+ // add the additional space used by changes made to the environment
+ dwSize += CalculateEnvironmentSpace();
+
+ Newx(lpStr, dwSize, char);
+ lpPtr = lpStr;
+ if(lpStr != NULL) {
+ // build the local environment
+ lpStr = vDir.BuildEnvironmentSpace(lpStr);
+
+ dwEnvIndex = 0;
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ while(*lpEnvPtr != '\0') {
+ if(!lpLocalEnv) {
+ // all environment overrides have been added
+ // so copy string into place
+ strcpy(lpStr, lpEnvPtr);
+ nLength = strlen(lpEnvPtr) + 1;
+ lpStr += nLength;
+ lpEnvPtr += nLength;
+ }
+ else {
+ // determine which string to copy next
+ compVal = compare(&lpEnvPtr, &lpLocalEnv);
+ if(compVal < 0) {
+ strcpy(lpStr, lpEnvPtr);
+ nLength = strlen(lpEnvPtr) + 1;
+ lpStr += nLength;
+ lpEnvPtr += nLength;
+ }
+ else {
+ char *ptr = strchr(lpLocalEnv, '=');
+ if(ptr && ptr[1]) {
+ strcpy(lpStr, lpLocalEnv);
+ lpStr += strlen(lpLocalEnv) + 1;
+ }
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ if(compVal == 0) {
+ // this string was replaced
+ lpEnvPtr += strlen(lpEnvPtr) + 1;
+ }
+ }
+ }
+ }
+
+ while(lpLocalEnv) {
+ // still have environment overrides to add
+ // so copy the strings into place if not an override
+ char *ptr = strchr(lpLocalEnv, '=');
+ if(ptr && ptr[1]) {
+ strcpy(lpStr, lpLocalEnv);
+ lpStr += strlen(lpLocalEnv) + 1;
+ }
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ }
+
+ // add final NULL
+ *lpStr = '\0';
+ }
+
+ // release the process environment strings
+ FreeEnvironmentStrings(lpAllocPtr);
+
+ return lpPtr;
+}
+
+void
+CPerlHost::Reset(void)
+{
+ dTHX;
+ if(m_lppEnvList != NULL) {
+ for(DWORD index = 0; index < m_dwEnvCount; ++index) {
+ Free(m_lppEnvList[index]);
+ m_lppEnvList[index] = NULL;
+ }
+ }
+ m_dwEnvCount = 0;
+ Free(m_lppEnvList);
+ m_lppEnvList = NULL;
+}
+
+void
+CPerlHost::Clearenv(void)
+{
+ dTHX;
+ char ch;
+ LPSTR lpPtr, lpStr, lpEnvPtr;
+ if (m_lppEnvList != NULL) {
+ /* set every entry to an empty string */
+ for(DWORD index = 0; index < m_dwEnvCount; ++index) {
+ char* ptr = strchr(m_lppEnvList[index], '=');
+ if(ptr) {
+ *++ptr = 0;
+ }
+ }
+ }
+
+ /* get the process environment strings */
+ lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
+
+ /* step over current directory stuff */
+ while(*lpStr == '=')
+ lpStr += strlen(lpStr) + 1;
+
+ while(*lpStr) {
+ lpPtr = strchr(lpStr, '=');
+ if(lpPtr) {
+ ch = *++lpPtr;
+ *lpPtr = 0;
+ Add(lpStr);
+ if (m_bTopLevel)
+ (void)win32_putenv(lpStr);
+ *lpPtr = ch;
+ }
+ lpStr += strlen(lpStr) + 1;
+ }
+
+ FreeEnvironmentStrings(lpEnvPtr);
+}
+
+
+char*
+CPerlHost::Getenv(const char *varname)
+{
+ dTHX;
+ if (!m_bTopLevel) {
+ char *pEnv = Find(varname);
+ if (pEnv && *pEnv)
+ return pEnv;
+ }
+ return win32_getenv(varname);
+}
+
+int
+CPerlHost::Putenv(const char *envstring)
+{
+ dTHX;
+ Add(envstring);
+ if (m_bTopLevel)
+ return win32_putenv(envstring);
+
+ return 0;
+}
+
+int
+CPerlHost::Chdir(const char *dirname)
+{
+ dTHX;
+ int ret;
+ if (!dirname) {
+ errno = ENOENT;
+ return -1;
+ }
+ ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
+ if(ret < 0) {
+ errno = ENOENT;
+ }
+ return ret;
+}
+
+#endif /* ___PerlHost_H___ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perlio.h b/Master/tlpkg/tlperl.straw/lib/CORE/perlio.h
new file mode 100755
index 00000000000..a6902d4a956
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perlio.h
@@ -0,0 +1,394 @@
+/* perlio.h
+ *
+ * Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifndef _PERLIO_H
+#define _PERLIO_H
+/*
+ Interface for perl to IO functions.
+ There is a hierarchy of Configure determined #define controls:
+ USE_STDIO - forces PerlIO_xxx() to be #define-d onto stdio functions.
+ This is used for x2p subdirectory and for conservative
+ builds - "just like perl5.00X used to be".
+ This dominates over the others.
+
+ USE_PERLIO - The primary Configure variable that enables PerlIO.
+ If USE_PERLIO is _NOT_ set
+ then USE_STDIO above will be set to be conservative.
+ If USE_PERLIO is set
+ then there are two modes determined by USE_SFIO:
+
+ USE_SFIO - If set causes PerlIO_xxx() to be #define-d onto sfio functions.
+ A backward compatability mode for some specialist applications.
+
+ If USE_SFIO is not set then PerlIO_xxx() are real functions
+ defined in perlio.c which implement extra functionality
+ required for utf8 support.
+
+ One further note - the table-of-functions scheme controlled
+ by PERL_IMPLICIT_SYS turns on USE_PERLIO so that iperlsys.h can
+ #define PerlIO_xxx() to go via the function table, without having
+ to #undef them from (say) stdio forms.
+
+*/
+
+#if defined(PERL_IMPLICIT_SYS)
+#ifndef USE_PERLIO
+#ifndef NETWARE
+/* # define USE_PERLIO */
+#endif
+#endif
+#endif
+
+#ifndef USE_PERLIO
+# define USE_STDIO
+#endif
+
+#ifdef USE_STDIO
+# ifndef PERLIO_IS_STDIO
+# define PERLIO_IS_STDIO
+# endif
+#endif
+
+/* -------------------- End of Configure controls ---------------------------- */
+
+/*
+ * Although we may not want stdio to be used including <stdio.h> here
+ * avoids issues where stdio.h has strange side effects
+ */
+#include <stdio.h>
+
+#ifdef __BEOS__
+int fseeko(FILE *stream, off_t offset, int whence);
+off_t ftello(FILE *stream);
+#endif
+
+#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
+#define ftell ftello
+#endif
+
+#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
+#define fseek fseeko
+#endif
+
+/* BS2000 includes are sometimes a bit non standard :-( */
+#if defined(POSIX_BC) && defined(O_BINARY) && !defined(O_TEXT)
+#undef O_BINARY
+#endif
+
+#ifdef PERLIO_IS_STDIO
+/* #define PerlIO_xxxx() as equivalent stdio function */
+#include "perlsdio.h"
+#else /* PERLIO_IS_STDIO */
+#ifdef USE_SFIO
+/* #define PerlIO_xxxx() as equivalent sfio function */
+#include "perlsfio.h"
+#endif /* USE_SFIO */
+#endif /* PERLIO_IS_STDIO */
+
+#ifndef PerlIO
+/* ----------- PerlIO implementation ---------- */
+/* PerlIO not #define-d to something else - define the implementation */
+
+typedef struct _PerlIO PerlIOl;
+typedef struct _PerlIO_funcs PerlIO_funcs;
+typedef PerlIOl *PerlIO;
+#define PerlIO PerlIO
+#define PERLIO_LAYERS 1
+
+/* Making the big PerlIO_funcs vtables const is good (enables placing
+ * them in the const section which is good for speed, security, and
+ * embeddability) but this cannot be done by default because of
+ * backward compatibility. */
+#ifdef PERLIO_FUNCS_CONST
+#define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
+#define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
+#else
+#define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
+#define PERLIO_FUNCS_CAST(funcs) (funcs)
+#endif
+
+PERL_EXPORT_C void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab);
+PERL_EXPORT_C PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name,
+ STRLEN len,
+ int load);
+PERL_EXPORT_C PerlIO *PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab),
+ const char *mode, SV *arg);
+PERL_EXPORT_C void PerlIO_pop(pTHX_ PerlIO *f);
+PERL_EXPORT_C AV* PerlIO_get_layers(pTHX_ PerlIO *f);
+PERL_EXPORT_C void PerlIO_clone(pTHX_ PerlInterpreter *proto,
+ CLONE_PARAMS *param);
+
+#endif /* PerlIO */
+
+/* ----------- End of implementation choices ---------- */
+
+#ifndef PERLIO_IS_STDIO
+/* Not using stdio _directly_ as PerlIO */
+
+/* We now need to determine what happens if source trys to use stdio.
+ * There are three cases based on PERLIO_NOT_STDIO which XS code
+ * can set how it wants.
+ */
+
+#ifdef PERL_CORE
+/* Make a choice for perl core code
+ - currently this is set to try and catch lingering raw stdio calls.
+ This is a known issue with some non UNIX ports which still use
+ "native" stdio features.
+*/
+#ifndef PERLIO_NOT_STDIO
+#define PERLIO_NOT_STDIO 1
+#endif
+#else
+#ifndef PERLIO_NOT_STDIO
+#define PERLIO_NOT_STDIO 0
+#endif
+#endif
+
+#ifdef PERLIO_NOT_STDIO
+#if PERLIO_NOT_STDIO
+/*
+ * PERLIO_NOT_STDIO #define'd as 1
+ * Case 1: Strong denial of stdio - make all stdio calls (we can think of) errors
+ */
+#include "nostdio.h"
+#else /* if PERLIO_NOT_STDIO */
+/*
+ * PERLIO_NOT_STDIO #define'd as 0
+ * Case 2: Declares that both PerlIO and stdio can be used
+ */
+#endif /* if PERLIO_NOT_STDIO */
+#else /* ifdef PERLIO_NOT_STDIO */
+/*
+ * PERLIO_NOT_STDIO not defined
+ * Case 3: Try and fake stdio calls as PerlIO calls
+ */
+#include "fakesdio.h"
+#endif /* ifndef PERLIO_NOT_STDIO */
+#endif /* PERLIO_IS_STDIO */
+
+/* ----------- fill in things that have not got #define'd ---------- */
+
+#ifndef Fpos_t
+#define Fpos_t Off_t
+#endif
+
+#ifndef EOF
+#define EOF (-1)
+#endif
+
+/* This is to catch case with no stdio */
+#ifndef BUFSIZ
+#define BUFSIZ 1024
+#endif
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#endif
+
+#ifndef SEEK_CUR
+#define SEEK_CUR 1
+#endif
+
+#ifndef SEEK_END
+#define SEEK_END 2
+#endif
+
+#define PERLIO_DUP_CLONE 1
+#define PERLIO_DUP_FD 2
+
+/* --------------------- Now prototypes for functions --------------- */
+
+START_EXTERN_C
+#ifndef __attribute__format__
+# ifdef HASATTRIBUTE_FORMAT
+# define __attribute__format__(x,y,z) __attribute__((format(x,y,z)))
+# else
+# define __attribute__format__(x,y,z)
+# endif
+#endif
+#ifndef PerlIO_init
+PERL_EXPORT_C void PerlIO_init(pTHX);
+#endif
+#ifndef PerlIO_stdoutf
+PERL_EXPORT_C int PerlIO_stdoutf(const char *, ...)
+ __attribute__format__(__printf__, 1, 2);
+#endif
+#ifndef PerlIO_puts
+PERL_EXPORT_C int PerlIO_puts(PerlIO *, const char *);
+#endif
+#ifndef PerlIO_open
+PERL_EXPORT_C PerlIO *PerlIO_open(const char *, const char *);
+#endif
+#ifndef PerlIO_openn
+PERL_EXPORT_C PerlIO *PerlIO_openn(pTHX_ const char *layers, const char *mode,
+ int fd, int imode, int perm, PerlIO *old,
+ int narg, SV **arg);
+#endif
+#ifndef PerlIO_eof
+PERL_EXPORT_C int PerlIO_eof(PerlIO *);
+#endif
+#ifndef PerlIO_error
+PERL_EXPORT_C int PerlIO_error(PerlIO *);
+#endif
+#ifndef PerlIO_clearerr
+PERL_EXPORT_C void PerlIO_clearerr(PerlIO *);
+#endif
+#ifndef PerlIO_getc
+PERL_EXPORT_C int PerlIO_getc(PerlIO *);
+#endif
+#ifndef PerlIO_putc
+PERL_EXPORT_C int PerlIO_putc(PerlIO *, int);
+#endif
+#ifndef PerlIO_ungetc
+PERL_EXPORT_C int PerlIO_ungetc(PerlIO *, int);
+#endif
+#ifndef PerlIO_fdopen
+PERL_EXPORT_C PerlIO *PerlIO_fdopen(int, const char *);
+#endif
+#ifndef PerlIO_importFILE
+PERL_EXPORT_C PerlIO *PerlIO_importFILE(FILE *, const char *);
+#endif
+#ifndef PerlIO_exportFILE
+PERL_EXPORT_C FILE *PerlIO_exportFILE(PerlIO *, const char *);
+#endif
+#ifndef PerlIO_findFILE
+PERL_EXPORT_C FILE *PerlIO_findFILE(PerlIO *);
+#endif
+#ifndef PerlIO_releaseFILE
+PERL_EXPORT_C void PerlIO_releaseFILE(PerlIO *, FILE *);
+#endif
+#ifndef PerlIO_read
+PERL_EXPORT_C SSize_t PerlIO_read(PerlIO *, void *, Size_t);
+#endif
+#ifndef PerlIO_unread
+PERL_EXPORT_C SSize_t PerlIO_unread(PerlIO *, const void *, Size_t);
+#endif
+#ifndef PerlIO_write
+PERL_EXPORT_C SSize_t PerlIO_write(PerlIO *, const void *, Size_t);
+#endif
+#ifndef PerlIO_setlinebuf
+PERL_EXPORT_C void PerlIO_setlinebuf(PerlIO *);
+#endif
+#ifndef PerlIO_printf
+PERL_EXPORT_C int PerlIO_printf(PerlIO *, const char *, ...)
+ __attribute__format__(__printf__, 2, 3);
+#endif
+#ifndef PerlIO_sprintf
+PERL_EXPORT_C int PerlIO_sprintf(char *, int, const char *, ...)
+ __attribute__format__(__printf__, 3, 4);
+#endif
+#ifndef PerlIO_vprintf
+PERL_EXPORT_C int PerlIO_vprintf(PerlIO *, const char *, va_list);
+#endif
+#ifndef PerlIO_tell
+PERL_EXPORT_C Off_t PerlIO_tell(PerlIO *);
+#endif
+#ifndef PerlIO_seek
+PERL_EXPORT_C int PerlIO_seek(PerlIO *, Off_t, int);
+#endif
+#ifndef PerlIO_rewind
+PERL_EXPORT_C void PerlIO_rewind(PerlIO *);
+#endif
+#ifndef PerlIO_has_base
+PERL_EXPORT_C int PerlIO_has_base(PerlIO *);
+#endif
+#ifndef PerlIO_has_cntptr
+PERL_EXPORT_C int PerlIO_has_cntptr(PerlIO *);
+#endif
+#ifndef PerlIO_fast_gets
+PERL_EXPORT_C int PerlIO_fast_gets(PerlIO *);
+#endif
+#ifndef PerlIO_canset_cnt
+PERL_EXPORT_C int PerlIO_canset_cnt(PerlIO *);
+#endif
+#ifndef PerlIO_get_ptr
+PERL_EXPORT_C STDCHAR *PerlIO_get_ptr(PerlIO *);
+#endif
+#ifndef PerlIO_get_cnt
+PERL_EXPORT_C int PerlIO_get_cnt(PerlIO *);
+#endif
+#ifndef PerlIO_set_cnt
+PERL_EXPORT_C void PerlIO_set_cnt(PerlIO *, int);
+#endif
+#ifndef PerlIO_set_ptrcnt
+PERL_EXPORT_C void PerlIO_set_ptrcnt(PerlIO *, STDCHAR *, int);
+#endif
+#ifndef PerlIO_get_base
+PERL_EXPORT_C STDCHAR *PerlIO_get_base(PerlIO *);
+#endif
+#ifndef PerlIO_get_bufsiz
+PERL_EXPORT_C int PerlIO_get_bufsiz(PerlIO *);
+#endif
+#ifndef PerlIO_tmpfile
+PERL_EXPORT_C PerlIO *PerlIO_tmpfile(void);
+#endif
+#ifndef PerlIO_stdin
+PERL_EXPORT_C PerlIO *PerlIO_stdin(void);
+#endif
+#ifndef PerlIO_stdout
+PERL_EXPORT_C PerlIO *PerlIO_stdout(void);
+#endif
+#ifndef PerlIO_stderr
+PERL_EXPORT_C PerlIO *PerlIO_stderr(void);
+#endif
+#ifndef PerlIO_getpos
+PERL_EXPORT_C int PerlIO_getpos(PerlIO *, SV *);
+#endif
+#ifndef PerlIO_setpos
+PERL_EXPORT_C int PerlIO_setpos(PerlIO *, SV *);
+#endif
+#ifndef PerlIO_fdupopen
+PERL_EXPORT_C PerlIO *PerlIO_fdupopen(pTHX_ PerlIO *, CLONE_PARAMS *, int);
+#endif
+#if !defined(PerlIO_modestr) && !defined(PERLIO_IS_STDIO)
+PERL_EXPORT_C char *PerlIO_modestr(PerlIO *, char *buf);
+#endif
+#ifndef PerlIO_isutf8
+PERL_EXPORT_C int PerlIO_isutf8(PerlIO *);
+#endif
+#ifndef PerlIO_apply_layers
+PERL_EXPORT_C int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode,
+ const char *names);
+#endif
+#ifndef PerlIO_binmode
+PERL_EXPORT_C int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int omode,
+ const char *names);
+#endif
+#ifndef PerlIO_getname
+PERL_EXPORT_C char *PerlIO_getname(PerlIO *, char *);
+#endif
+
+PERL_EXPORT_C void PerlIO_destruct(pTHX);
+
+PERL_EXPORT_C int PerlIO_intmode2str(int rawmode, char *mode, int *writing);
+
+#ifdef PERLIO_LAYERS
+PERL_EXPORT_C void PerlIO_cleanup(pTHX);
+
+PERL_EXPORT_C void PerlIO_debug(const char *fmt, ...)
+ __attribute__format__(__printf__, 1, 2);
+typedef struct PerlIO_list_s PerlIO_list_t;
+
+
+#endif
+
+END_EXTERN_C
+#endif /* _PERLIO_H */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perliol.h b/Master/tlpkg/tlperl.straw/lib/CORE/perliol.h
new file mode 100755
index 00000000000..6b714bb6efa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perliol.h
@@ -0,0 +1,297 @@
+#ifndef _PERLIOL_H
+#define _PERLIOL_H
+
+typedef struct {
+ PerlIO_funcs *funcs;
+ SV *arg;
+} PerlIO_pair_t;
+
+struct PerlIO_list_s {
+ IV refcnt;
+ IV cur;
+ IV len;
+ PerlIO_pair_t *array;
+};
+
+struct _PerlIO_funcs {
+ Size_t fsize;
+ const char *name;
+ Size_t size;
+ U32 kind;
+ IV (*Pushed) (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+ IV (*Popped) (pTHX_ PerlIO *f);
+ PerlIO *(*Open) (pTHX_ PerlIO_funcs *tab,
+ PerlIO_list_t *layers, IV n,
+ const char *mode,
+ int fd, int imode, int perm,
+ PerlIO *old, int narg, SV **args);
+ IV (*Binmode)(pTHX_ PerlIO *f);
+ SV *(*Getarg) (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags);
+ IV (*Fileno) (pTHX_ PerlIO *f);
+ PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
+ /* Unix-like functions - cf sfio line disciplines */
+ SSize_t(*Read) (pTHX_ PerlIO *f, void *vbuf, Size_t count);
+ SSize_t(*Unread) (pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+ SSize_t(*Write) (pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+ IV (*Seek) (pTHX_ PerlIO *f, Off_t offset, int whence);
+ Off_t(*Tell) (pTHX_ PerlIO *f);
+ IV (*Close) (pTHX_ PerlIO *f);
+ /* Stdio-like buffered IO functions */
+ IV (*Flush) (pTHX_ PerlIO *f);
+ IV (*Fill) (pTHX_ PerlIO *f);
+ IV (*Eof) (pTHX_ PerlIO *f);
+ IV (*Error) (pTHX_ PerlIO *f);
+ void (*Clearerr) (pTHX_ PerlIO *f);
+ void (*Setlinebuf) (pTHX_ PerlIO *f);
+ /* Perl's snooping functions */
+ STDCHAR *(*Get_base) (pTHX_ PerlIO *f);
+ Size_t(*Get_bufsiz) (pTHX_ PerlIO *f);
+ STDCHAR *(*Get_ptr) (pTHX_ PerlIO *f);
+ SSize_t(*Get_cnt) (pTHX_ PerlIO *f);
+ void (*Set_ptrcnt) (pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt);
+};
+
+/*--------------------------------------------------------------------------------------*/
+/* Kind values */
+#define PERLIO_K_RAW 0x00000001
+#define PERLIO_K_BUFFERED 0x00000002
+#define PERLIO_K_CANCRLF 0x00000004
+#define PERLIO_K_FASTGETS 0x00000008
+#define PERLIO_K_DUMMY 0x00000010
+#define PERLIO_K_UTF8 0x00008000
+#define PERLIO_K_DESTRUCT 0x00010000
+#define PERLIO_K_MULTIARG 0x00020000
+
+/*--------------------------------------------------------------------------------------*/
+struct _PerlIO {
+ PerlIOl *next; /* Lower layer */
+ PerlIO_funcs *tab; /* Functions for this layer */
+ U32 flags; /* Various flags for state */
+};
+
+/*--------------------------------------------------------------------------------------*/
+
+/* Flag values */
+#define PERLIO_F_EOF 0x00000100
+#define PERLIO_F_CANWRITE 0x00000200
+#define PERLIO_F_CANREAD 0x00000400
+#define PERLIO_F_ERROR 0x00000800
+#define PERLIO_F_TRUNCATE 0x00001000
+#define PERLIO_F_APPEND 0x00002000
+#define PERLIO_F_CRLF 0x00004000
+#define PERLIO_F_UTF8 0x00008000
+#define PERLIO_F_UNBUF 0x00010000
+#define PERLIO_F_WRBUF 0x00020000
+#define PERLIO_F_RDBUF 0x00040000
+#define PERLIO_F_LINEBUF 0x00080000
+#define PERLIO_F_TEMP 0x00100000
+#define PERLIO_F_OPEN 0x00200000
+#define PERLIO_F_FASTGETS 0x00400000
+#define PERLIO_F_TTY 0x00800000
+#define PERLIO_F_NOTREG 0x01000000
+
+#define PerlIOBase(f) (*(f))
+#define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
+#define PerlIONext(f) (&(PerlIOBase(f)->next))
+#define PerlIOValid(f) ((f) && *(f))
+
+/*--------------------------------------------------------------------------------------*/
+/* Data exports - EXTCONST rather than extern is needed for Cygwin */
+#undef EXTPERLIO
+#ifdef PERLIO_FUNCS_CONST
+#define EXTPERLIO EXTCONST
+#else
+#define EXTPERLIO EXT
+#endif
+EXTPERLIO PerlIO_funcs PerlIO_unix;
+EXTPERLIO PerlIO_funcs PerlIO_perlio;
+EXTPERLIO PerlIO_funcs PerlIO_stdio;
+EXTPERLIO PerlIO_funcs PerlIO_crlf;
+EXTPERLIO PerlIO_funcs PerlIO_utf8;
+EXTPERLIO PerlIO_funcs PerlIO_byte;
+EXTPERLIO PerlIO_funcs PerlIO_raw;
+EXTPERLIO PerlIO_funcs PerlIO_pending;
+#ifdef HAS_MMAP
+EXTPERLIO PerlIO_funcs PerlIO_mmap;
+#endif
+#ifdef WIN32
+EXTPERLIO PerlIO_funcs PerlIO_win32;
+#endif
+PERL_EXPORT_C PerlIO *PerlIO_allocate(pTHX);
+PERL_EXPORT_C SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n);
+#define PerlIOArg PerlIO_arg_fetch(layers,n)
+
+#ifdef PERLIO_USING_CRLF
+#define PERLIO_STDTEXT "t"
+#else
+#define PERLIO_STDTEXT ""
+#endif
+
+/*--------------------------------------------------------------------------------------*/
+/* perlio buffer layer
+ As this is reasonably generic its struct and "methods" are declared here
+ so they can be used to "inherit" from it.
+*/
+
+typedef struct {
+ struct _PerlIO base; /* Base "class" info */
+ STDCHAR *buf; /* Start of buffer */
+ STDCHAR *end; /* End of valid part of buffer */
+ STDCHAR *ptr; /* Current position in buffer */
+ Off_t posn; /* Offset of buf into the file */
+ Size_t bufsiz; /* Real size of buffer */
+ IV oneword; /* Emergency buffer */
+} PerlIOBuf;
+
+PERL_EXPORT_C int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
+ PerlIO_list_t *layers, IV n, IV max);
+PERL_EXPORT_C int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names);
+PERL_EXPORT_C PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def);
+
+
+PERL_EXPORT_C SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param);
+PERL_EXPORT_C void PerlIO_cleantable(pTHX_ PerlIO **tablep);
+PERL_EXPORT_C SV * PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab);
+PERL_EXPORT_C void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av);
+PERL_EXPORT_C void PerlIO_stdstreams(pTHX);
+PERL_EXPORT_C int PerlIO__close(pTHX_ PerlIO *f);
+PERL_EXPORT_C PerlIO_list_t * PerlIO_resolve_layers(pTHX_ const char *layers, const char *mode, int narg, SV **args);
+PERL_EXPORT_C PerlIO_funcs * PerlIO_default_layer(pTHX_ I32 n);
+PERL_EXPORT_C PerlIO_list_t * PerlIO_default_layers(pTHX);
+PERL_EXPORT_C PerlIO * PerlIO_reopen(const char *path, const char *mode, PerlIO *f);
+PERL_EXPORT_C int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
+ __attribute__format__(__printf__,3,0);
+
+PERL_EXPORT_C PerlIO_list_t *PerlIO_list_alloc(pTHX);
+PERL_EXPORT_C PerlIO_list_t *PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param);
+PERL_EXPORT_C void PerlIO_list_free(pTHX_ PerlIO_list_t *list);
+PERL_EXPORT_C void PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg);
+PERL_EXPORT_C void PerlIO_list_free(pTHX_ PerlIO_list_t *list);
+
+/* PerlIO_teardown doesn't need exporting, but the EXTERN_C is needed
+ * for compiling as C++. Must also match with what perl.h says. */
+EXTERN_C void PerlIO_teardown(void);
+
+/*--------------------------------------------------------------------------------------*/
+/* Generic, or stub layer functions */
+
+PERL_EXPORT_C IV PerlIOBase_binmode(pTHX_ PerlIO *f);
+PERL_EXPORT_C void PerlIOBase_clearerr(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBase_close(pTHX_ PerlIO *f);
+PERL_EXPORT_C PerlIO * PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
+PERL_EXPORT_C IV PerlIOBase_eof(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBase_error(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBase_fileno(pTHX_ PerlIO *f);
+PERL_EXPORT_C void PerlIOBase_flush_linebuf(pTHX);
+PERL_EXPORT_C IV PerlIOBase_noop_fail(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBase_noop_ok(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBase_popped(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+PERL_EXPORT_C SSize_t PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
+PERL_EXPORT_C void PerlIOBase_setlinebuf(pTHX_ PerlIO *f);
+PERL_EXPORT_C SSize_t PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+
+/* Buf */
+PERL_EXPORT_C Size_t PerlIOBuf_bufsiz(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBuf_close(pTHX_ PerlIO *f);
+PERL_EXPORT_C PerlIO * PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
+PERL_EXPORT_C IV PerlIOBuf_fill(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBuf_flush(pTHX_ PerlIO *f);
+PERL_EXPORT_C STDCHAR * PerlIOBuf_get_base(pTHX_ PerlIO *f);
+PERL_EXPORT_C SSize_t PerlIOBuf_get_cnt(pTHX_ PerlIO *f);
+PERL_EXPORT_C STDCHAR * PerlIOBuf_get_ptr(pTHX_ PerlIO *f);
+PERL_EXPORT_C PerlIO * PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args);
+PERL_EXPORT_C IV PerlIOBuf_popped(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+PERL_EXPORT_C SSize_t PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
+PERL_EXPORT_C IV PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence);
+PERL_EXPORT_C void PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt);
+PERL_EXPORT_C Off_t PerlIOBuf_tell(pTHX_ PerlIO *f);
+PERL_EXPORT_C SSize_t PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+PERL_EXPORT_C SSize_t PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+
+/* Crlf */
+PERL_EXPORT_C IV PerlIOCrlf_binmode(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOCrlf_flush(pTHX_ PerlIO *f);
+PERL_EXPORT_C SSize_t PerlIOCrlf_get_cnt(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+PERL_EXPORT_C void PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt);
+PERL_EXPORT_C SSize_t PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+PERL_EXPORT_C SSize_t PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+PERL_EXPORT_C SSize_t PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+
+/* Mmap */
+PERL_EXPORT_C IV PerlIOMmap_close(pTHX_ PerlIO *f);
+PERL_EXPORT_C PerlIO * PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
+PERL_EXPORT_C IV PerlIOMmap_fill(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOMmap_flush(pTHX_ PerlIO *f);
+PERL_EXPORT_C STDCHAR * PerlIOMmap_get_base(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOMmap_map(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOMmap_unmap(pTHX_ PerlIO *f);
+PERL_EXPORT_C SSize_t PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+PERL_EXPORT_C SSize_t PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+
+/* Pending */
+PERL_EXPORT_C IV PerlIOPending_close(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOPending_fill(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOPending_flush(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+PERL_EXPORT_C SSize_t PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
+PERL_EXPORT_C IV PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence);
+PERL_EXPORT_C void PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt);
+
+/* Pop */
+PERL_EXPORT_C IV PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+
+/* Raw */
+PERL_EXPORT_C PerlIO * PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args);
+PERL_EXPORT_C IV PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+
+/* Stdio */
+PERL_EXPORT_C void PerlIOStdio_clearerr(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOStdio_close(pTHX_ PerlIO *f);
+PERL_EXPORT_C PerlIO * PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
+PERL_EXPORT_C IV PerlIOStdio_eof(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOStdio_error(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOStdio_fileno(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOStdio_fill(pTHX_ PerlIO *f);
+PERL_EXPORT_C IV PerlIOStdio_flush(pTHX_ PerlIO *f);
+PERL_EXPORT_C STDCHAR * PerlIOStdio_get_base(pTHX_ PerlIO *f);
+PERL_EXPORT_C char * PerlIOStdio_mode(const char *mode, char *tmode);
+PERL_EXPORT_C PerlIO * PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args);
+PERL_EXPORT_C IV PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+PERL_EXPORT_C SSize_t PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
+PERL_EXPORT_C IV PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence);
+PERL_EXPORT_C void PerlIOStdio_setlinebuf(pTHX_ PerlIO *f);
+PERL_EXPORT_C Off_t PerlIOStdio_tell(pTHX_ PerlIO *f);
+PERL_EXPORT_C SSize_t PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+PERL_EXPORT_C SSize_t PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+
+/* Unix */
+PERL_EXPORT_C IV PerlIOUnix_close(pTHX_ PerlIO *f);
+PERL_EXPORT_C PerlIO * PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
+PERL_EXPORT_C IV PerlIOUnix_fileno(pTHX_ PerlIO *f);
+PERL_EXPORT_C int PerlIOUnix_oflags(const char *mode);
+PERL_EXPORT_C PerlIO * PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args);
+PERL_EXPORT_C IV PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+PERL_EXPORT_C SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
+PERL_EXPORT_C int PerlIOUnix_refcnt_dec(int fd);
+PERL_EXPORT_C void PerlIOUnix_refcnt_inc(int fd);
+PERL_EXPORT_C IV PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence);
+PERL_EXPORT_C Off_t PerlIOUnix_tell(pTHX_ PerlIO *f);
+PERL_EXPORT_C SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
+
+/* Utf8 */
+PERL_EXPORT_C IV PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
+
+#endif /* _PERLIOL_H */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perlsdio.h b/Master/tlpkg/tlperl.straw/lib/CORE/perlsdio.h
new file mode 100755
index 00000000000..1a6f2f01c4c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perlsdio.h
@@ -0,0 +1,164 @@
+/* perlsdio.h
+ *
+ * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001,
+ * 2002, 2003, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifdef PERLIO_IS_STDIO
+
+#ifdef NETWARE
+ #include "nwstdio.h"
+#else
+
+/*
+ * This file #define-s the PerlIO_xxx abstraction onto stdio functions.
+ * Make this as close to original stdio as possible.
+ */
+#define PerlIO FILE
+#define PerlIO_stderr() PerlSIO_stderr
+#define PerlIO_stdout() PerlSIO_stdout
+#define PerlIO_stdin() PerlSIO_stdin
+
+#define PerlIO_isutf8(f) 0
+
+#define PerlIO_printf PerlSIO_printf
+#define PerlIO_stdoutf PerlSIO_stdoutf
+#define PerlIO_vprintf(f,fmt,a) PerlSIO_vprintf(f,fmt,a)
+#define PerlIO_write(f,buf,count) PerlSIO_fwrite(buf,1,count,f)
+#define PerlIO_unread(f,buf,count) (-1)
+#define PerlIO_open PerlSIO_fopen
+#define PerlIO_fdopen PerlSIO_fdopen
+#define PerlIO_reopen PerlSIO_freopen
+#define PerlIO_close(f) PerlSIO_fclose(f)
+#define PerlIO_puts(f,s) PerlSIO_fputs(f,s)
+#define PerlIO_putc(f,c) PerlSIO_fputc(f,c)
+#if defined(VMS)
+# if defined(__DECC)
+ /* Unusual definition of ungetc() here to accomodate fast_sv_gets()'
+ * belief that it can mix getc/ungetc with reads from stdio buffer */
+ int decc$ungetc(int __c, FILE *__stream);
+# define PerlIO_ungetc(f,c) ((c) == EOF ? EOF : \
+ ((*(f) && !((*(f))->_flag & _IONBF) && \
+ ((*(f))->_ptr > (*(f))->_base)) ? \
+ ((*(f))->_cnt++, *(--(*(f))->_ptr) = (c)) : decc$ungetc(c,f)))
+# else
+# define PerlIO_ungetc(f,c) ungetc(c,f)
+# endif
+ /* Work around bug in DECCRTL/AXP (DECC v5.x) and some versions of old
+ * VAXCRTL which causes read from a pipe after EOF has been returned
+ * once to hang.
+ */
+# define PerlIO_getc(f) \
+ (feof(f) ? EOF : getc(f))
+# define PerlIO_read(f,buf,count) \
+ (feof(f) ? 0 : (SSize_t)fread(buf,1,count,f))
+# define PerlIO_tell(f) ftell(f)
+#else
+# define PerlIO_getc(f) PerlSIO_fgetc(f)
+# define PerlIO_ungetc(f,c) PerlSIO_ungetc(c,f)
+# define PerlIO_read(f,buf,count) (SSize_t)PerlSIO_fread(buf,1,count,f)
+# define PerlIO_tell(f) PerlSIO_ftell(f)
+#endif
+#define PerlIO_eof(f) PerlSIO_feof(f)
+#define PerlIO_getname(f,b) fgetname(f,b)
+#define PerlIO_error(f) PerlSIO_ferror(f)
+#define PerlIO_fileno(f) PerlSIO_fileno(f)
+#define PerlIO_clearerr(f) PerlSIO_clearerr(f)
+#define PerlIO_flush(f) PerlSIO_fflush(f)
+#if defined(VMS) && !defined(__DECC)
+/* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */
+#define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w))
+#else
+# define PerlIO_seek(f,o,w) PerlSIO_fseek(f,o,w)
+#endif
+
+#define PerlIO_rewind(f) PerlSIO_rewind(f)
+#define PerlIO_tmpfile() PerlSIO_tmpfile()
+
+#define PerlIO_importFILE(f,fl) (f)
+#define PerlIO_exportFILE(f,fl) (f)
+#define PerlIO_findFILE(f) (f)
+#define PerlIO_releaseFILE(p,f) ((void) 0)
+
+#ifdef HAS_SETLINEBUF
+#define PerlIO_setlinebuf(f) PerlSIO_setlinebuf(f);
+#else
+#define PerlIO_setlinebuf(f) PerlSIO_setvbuf(f, NULL, _IOLBF, 0);
+#endif
+
+/* Now our interface to Configure's FILE_xxx macros */
+
+#ifdef USE_STDIO_PTR
+#define PerlIO_has_cntptr(f) 1
+#define PerlIO_get_ptr(f) PerlSIO_get_ptr(f)
+#define PerlIO_get_cnt(f) PerlSIO_get_cnt(f)
+
+#ifdef STDIO_CNT_LVALUE
+#define PerlIO_canset_cnt(f) 1
+#define PerlIO_set_cnt(f,c) PerlSIO_set_cnt(f,c)
+#ifdef STDIO_PTR_LVALUE
+#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+#define PerlIO_fast_gets(f) 1
+#endif
+#endif /* STDIO_PTR_LVALUE */
+#else /* STDIO_CNT_LVALUE */
+#define PerlIO_canset_cnt(f) 0
+#define PerlIO_set_cnt(f,c) abort()
+#endif
+
+#ifdef STDIO_PTR_LVALUE
+#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+#define PerlIO_set_ptrcnt(f,p,c) STMT_START {PerlSIO_set_ptr(f,p), PerlIO_set_cnt(f,c);} STMT_END
+#else
+#ifdef STDIO_PTR_LVAL_SETS_CNT
+/* assert() may pre-process to ""; potential syntax error (FILE_ptr(), ) */
+#define PerlIO_set_ptrcnt(f,p,c) STMT_START {PerlSIO_set_ptr(f,p); assert(PerlSIO_get_cnt(f) == (c));} STMT_END
+#define PerlIO_fast_gets(f) 1
+#else
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+#endif
+#endif
+#endif
+
+#else /* USE_STDIO_PTR */
+
+#define PerlIO_has_cntptr(f) 0
+#define PerlIO_canset_cnt(f) 0
+#define PerlIO_get_cnt(f) (abort(),0)
+#define PerlIO_get_ptr(f) (abort(),(void *)0)
+#define PerlIO_set_cnt(f,c) abort()
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+
+#endif /* USE_STDIO_PTR */
+
+#ifndef PerlIO_fast_gets
+#define PerlIO_fast_gets(f) 0
+#endif
+
+
+#ifdef FILE_base
+#define PerlIO_has_base(f) 1
+#define PerlIO_get_base(f) PerlSIO_get_base(f)
+#define PerlIO_get_bufsiz(f) PerlSIO_get_bufsiz(f)
+#else
+#define PerlIO_has_base(f) 0
+#define PerlIO_get_base(f) (abort(),(void *)0)
+#define PerlIO_get_bufsiz(f) (abort(),0)
+#endif
+
+#endif /* NETWARE */
+#endif /* PERLIO_IS_STDIO */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perlsfio.h b/Master/tlpkg/tlperl.straw/lib/CORE/perlsfio.h
new file mode 100755
index 00000000000..2471753ad19
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perlsfio.h
@@ -0,0 +1,84 @@
+/* perlsfio.h
+ *
+ * Copyright (C) 1996, 1999, 2000, 2001, 2002, 2003, 2005, 2007,
+ * by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/* The next #ifdef should be redundant if Configure behaves ... */
+#ifndef FILE
+#define FILE FILE
+#endif
+#ifdef I_SFIO
+#include <sfio.h>
+#endif
+
+/* sfio 2000 changed _stdopen to _stdfdopen */
+#if SFIO_VERSION >= 20000101L
+#define _stdopen _stdfdopen
+#endif
+
+extern Sfio_t* _stdopen _ARG_((int, const char*));
+extern int _stdprintf _ARG_((const char*, ...));
+
+#define PerlIO Sfio_t
+#define PerlIO_stderr() sfstderr
+#define PerlIO_stdout() sfstdout
+#define PerlIO_stdin() sfstdin
+
+#define PerlIO_isutf8(f) 0
+
+#define PerlIO_printf sfprintf
+#define PerlIO_stdoutf _stdprintf
+#define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a)
+#define PerlIO_read(f,buf,count) sfread(f,buf,count)
+#define PerlIO_write(f,buf,count) sfwrite(f,buf,count)
+#define PerlIO_open(path,mode) sfopen(NULL,path,mode)
+#define PerlIO_fdopen(fd,mode) _stdopen(fd,mode)
+#define PerlIO_reopen(path,mode,f) sfopen(f,path,mode)
+#define PerlIO_close(f) sfclose(f)
+#define PerlIO_puts(f,s) sfputr(f,s,-1)
+#define PerlIO_putc(f,c) sfputc(f,c)
+#define PerlIO_ungetc(f,c) sfungetc(f,c)
+#define PerlIO_sprintf sfsprintf
+#define PerlIO_getc(f) sfgetc(f)
+#define PerlIO_eof(f) sfeof(f)
+#define PerlIO_error(f) sferror(f)
+#define PerlIO_fileno(f) sffileno(f)
+#define PerlIO_clearerr(f) sfclrerr(f)
+#define PerlIO_flush(f) sfsync(f)
+#define PerlIO_tell(f) sftell(f)
+#define PerlIO_seek(f,o,w) sfseek(f,o,w)
+#define PerlIO_rewind(f) (void) sfseek((f),0L,0)
+#define PerlIO_tmpfile() sftmp(0)
+#define PerlIO_exportFILE(f,fl) Perl_croak(aTHX_ "Export to FILE * unimplemented")
+#define PerlIO_releaseFILE(p,f) Perl_croak(aTHX_ "Release of FILE * unimplemented")
+
+#define PerlIO_setlinebuf(f) sfset(f,SF_LINE,1)
+
+/* Now our interface to equivalent of Configure's FILE_xxx macros */
+
+#define PerlIO_has_cntptr(f) 1
+#define PerlIO_get_ptr(f) ((f)->next)
+#define PerlIO_get_cnt(f) ((f)->endr - (f)->next)
+#define PerlIO_canset_cnt(f) 1
+#define PerlIO_fast_gets(f) 1
+#define PerlIO_set_ptrcnt(f,p,c) STMT_START {(f)->next = (unsigned char *)(p); assert(PerlIO_get_cnt(f) == (c));} STMT_END
+#define PerlIO_set_cnt(f,c) STMT_START {(f)->next = (f)->endr - (c);} STMT_END
+
+#define PerlIO_has_base(f) 1
+#define PerlIO_get_base(f) ((f)->data)
+#define PerlIO_get_bufsiz(f) ((f)->endr - (f)->data)
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perlvars.h b/Master/tlpkg/tlperl.straw/lib/CORE/perlvars.h
new file mode 100755
index 00000000000..49f4d5e31d1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perlvars.h
@@ -0,0 +1,188 @@
+/* perlvars.h
+ *
+ * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+ * by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/****************/
+/* Truly global */
+/****************/
+
+/* Don't forget to re-run embed.pl to propagate changes! */
+
+/* This file describes the "global" variables used by perl
+ * This used to be in perl.h directly but we want to abstract out into
+ * distinct files which are per-thread, per-interpreter or really global,
+ * and how they're initialized.
+ *
+ * The 'G' prefix is only needed for vars that need appropriate #defines
+ * generated in embed*.h. Such symbols are also used to generate
+ * the appropriate export list for win32. */
+
+/* global state */
+PERLVAR(Gcurinterp, PerlInterpreter *)
+ /* currently running interpreter
+ * (initial parent interpreter under
+ * useithreads) */
+#if defined(USE_ITHREADS)
+PERLVAR(Gthr_key, perl_key) /* key to retrieve per-thread struct */
+#endif
+
+/* constants (these are not literals to facilitate pointer comparisons)
+ * (PERLVARISC really does create variables, despite its looks) */
+PERLVARISC(GYes, "1")
+PERLVARISC(GNo, "")
+PERLVARISC(Ghexdigit, "0123456789abcdef0123456789ABCDEF")
+PERLVARISC(Gpatleave, "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}")
+
+/* XXX does anyone even use this? */
+PERLVARI(Gdo_undump, bool, FALSE) /* -u or dump seen? */
+
+#if defined(MYMALLOC) && defined(USE_ITHREADS)
+PERLVAR(Gmalloc_mutex, perl_mutex) /* Mutex for malloc */
+#endif
+
+#if defined(USE_ITHREADS)
+PERLVAR(Gop_mutex, perl_mutex) /* Mutex for op refcounting */
+#endif
+
+#ifdef USE_ITHREADS
+PERLVAR(Gdollarzero_mutex, perl_mutex) /* Modifying $0 */
+#endif
+
+
+/* This is constant on most architectures, a global on OS/2 */
+#ifdef OS2
+# define PERL___C
+#else
+# define PERL___C const
+#endif
+PERLVARI(Gsh_path, PERL___C char *, SH_PATH) /* full path of shell */
+#undef PERL___C
+
+#ifndef PERL_MICRO
+/* If Perl has to ignore SIGPFE, this is its saved state.
+ * See perl.h macros PERL_FPU_INIT and PERL_FPU_{PRE,POST}_EXEC. */
+PERLVAR(Gsigfpe_saved, Sighandler_t)
+#endif
+
+/* Restricted hashes placeholder value.
+ * The contents are never used, only the address. */
+PERLVAR(Gsv_placeholder, SV)
+
+#ifndef PERL_MICRO
+PERLVARI(Gcsighandlerp, Sighandler_t, Perl_csighandler) /* Pointer to C-level sighandler */
+#endif
+
+#ifndef PERL_USE_SAFE_PUTENV
+PERLVARI(Guse_safe_putenv, int, 1)
+#endif
+
+#ifdef USE_PERLIO
+PERLVARI(Gperlio_fd_refcnt, int*, 0) /* Pointer to array of fd refcounts. */
+PERLVARI(Gperlio_fd_refcnt_size, int, 0) /* Size of the array */
+PERLVARI(Gperlio_debug_fd, int, 0) /* the fd to write perlio debug into, 0 means not set yet */
+#endif
+
+#ifdef HAS_MMAP
+PERLVARI(Gmmap_page_size, IV, 0)
+#endif
+
+#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
+PERLVARI(Gsig_handlers_initted, int, 0)
+#endif
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
+PERLVARA(Gsig_ignoring, SIG_SIZE, int) /* which signals we are ignoring */
+#endif
+#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
+PERLVARA(Gsig_defaulting, SIG_SIZE, int)
+#endif
+
+#ifndef PERL_IMPLICIT_CONTEXT
+PERLVAR(Gsig_sv, SV*)
+#endif
+
+/* XXX signals are process-wide anyway, so we
+ * ignore the implications of this for threading */
+#ifndef HAS_SIGACTION
+PERLVARI(Gsig_trapped, int, 0)
+#endif
+
+#ifdef DEBUGGING
+PERLVAR(Gwatch_pvx, char*)
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT
+PERLVAR(Gppaddr, Perl_ppaddr_t*) /* or opcode.h */
+PERLVAR(Gcheck, Perl_check_t *) /* or opcode.h */
+PERLVARA(Gfold_locale, 256, unsigned char) /* or perl.h */
+#endif
+
+#ifdef PERL_NEED_APPCTX
+PERLVAR(Gappctx, void*) /* the application context */
+#endif
+
+PERLVAR(Gop_sequence, HV*) /* dump.c */
+PERLVARI(Gop_seq, UV, 0) /* dump.c */
+
+#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
+PERLVAR(Gtimesbase, struct tms)
+#endif
+
+/* allocate a unique index to every module that calls MY_CXT_INIT */
+
+#ifdef PERL_IMPLICIT_CONTEXT
+# ifdef USE_ITHREADS
+PERLVAR(Gmy_ctx_mutex, perl_mutex)
+# endif
+PERLVARI(Gmy_cxt_index, int, 0)
+#endif
+
+#if defined(USE_ITHREADS)
+PERLVAR(Ghints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */
+#endif
+
+#if defined(USE_ITHREADS)
+PERLVAR(Gperlio_mutex, perl_mutex) /* Mutex for perlio fd refcounts */
+#endif
+
+/* this is currently set without MUTEX protection, so keep it a type which
+ * can be set atomically (ie not a bit field) */
+PERLVARI(Gveto_cleanup, int, FALSE) /* exit without cleanup */
+
+/* dummy variables that hold pointers to both runops functions, thus forcing
+ * them *both* to get linked in (useful for Peek.xs, debugging etc) */
+
+PERLVARI(Grunops_std, runops_proc_t, MEMBER_TO_FPTR(Perl_runops_standard))
+PERLVARI(Grunops_dbg, runops_proc_t, MEMBER_TO_FPTR(Perl_runops_debug))
+
+
+/* These are baked at compile time into any shared perl library.
+ In future 5.10.x releases this will allow us in main() to sanity test the
+ library we're linking against. */
+
+PERLVARI(Grevision, U8, PERL_REVISION)
+PERLVARI(Gversion, U8, PERL_VERSION)
+PERLVARI(Gsubversion, U8, PERL_SUBVERSION)
+
+#if defined(MULTIPLICITY)
+# define PERL_INTERPRETER_SIZE_UPTO_MEMBER(member) \
+ STRUCT_OFFSET(struct interpreter, member) + \
+ sizeof(((struct interpreter*)0)->member)
+
+/* These might be useful. */
+PERLVARI(Ginterp_size, U16, sizeof(struct interpreter))
+#if defined(PERL_GLOBAL_STRUCT)
+PERLVARI(Gglobal_struct_size, U16, sizeof(struct perl_vars))
+#endif
+
+/* This will be useful for subsequent releases, because this has to be the
+ same in your libperl as in main(), else you have a mismatch and must abort.
+*/
+PERLVARI(Ginterp_size_5_10_0, U16,
+ PERL_INTERPRETER_SIZE_UPTO_MEMBER(PERL_LAST_5_10_0_INTERP_MEMBER))
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/perly.h b/Master/tlpkg/tlperl.straw/lib/CORE/perly.h
new file mode 100755
index 00000000000..f442416599c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/perly.h
@@ -0,0 +1,214 @@
+#ifdef PERL_CORE
+/* A Bison parser, made by GNU Bison 2.3. */
+
+/* Skeleton interface for Bison's Yacc-like parsers in C
+
+ Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ Boston, MA 02110-1301, USA. */
+
+/* As a special exception, you may create a larger work that contains
+ part or all of the Bison parser skeleton and distribute that work
+ under terms of your choice, so long as that work isn't itself a
+ parser generator using the skeleton or a modified version thereof
+ as a parser skeleton. Alternatively, if you modify or redistribute
+ the parser skeleton itself, you may (at your option) remove this
+ special exception, which will cause the skeleton and the resulting
+ Bison output files to be licensed under the GNU General Public
+ License without this special exception.
+
+ This special exception was added by the Free Software Foundation in
+ version 2.2 of Bison. */
+
+/* Tokens. */
+#ifndef YYTOKENTYPE
+# define YYTOKENTYPE
+ /* Put the tokens into the symbol table, so that GDB and other debuggers
+ know about them. */
+ enum yytokentype {
+ WORD = 258,
+ METHOD = 259,
+ FUNCMETH = 260,
+ THING = 261,
+ PMFUNC = 262,
+ PRIVATEREF = 263,
+ FUNC0SUB = 264,
+ UNIOPSUB = 265,
+ LSTOPSUB = 266,
+ LABEL = 267,
+ FORMAT = 268,
+ SUB = 269,
+ ANONSUB = 270,
+ PACKAGE = 271,
+ USE = 272,
+ WHILE = 273,
+ UNTIL = 274,
+ IF = 275,
+ UNLESS = 276,
+ ELSE = 277,
+ ELSIF = 278,
+ CONTINUE = 279,
+ FOR = 280,
+ GIVEN = 281,
+ WHEN = 282,
+ DEFAULT = 283,
+ LOOPEX = 284,
+ DOTDOT = 285,
+ FUNC0 = 286,
+ FUNC1 = 287,
+ FUNC = 288,
+ UNIOP = 289,
+ LSTOP = 290,
+ RELOP = 291,
+ EQOP = 292,
+ MULOP = 293,
+ ADDOP = 294,
+ DOLSHARP = 295,
+ DO = 296,
+ HASHBRACK = 297,
+ NOAMP = 298,
+ LOCAL = 299,
+ MY = 300,
+ MYSUB = 301,
+ REQUIRE = 302,
+ COLONATTR = 303,
+ PREC_LOW = 304,
+ DOROP = 305,
+ OROP = 306,
+ ANDOP = 307,
+ NOTOP = 308,
+ ASSIGNOP = 309,
+ DORDOR = 310,
+ OROR = 311,
+ ANDAND = 312,
+ BITOROP = 313,
+ BITANDOP = 314,
+ SHIFTOP = 315,
+ MATCHOP = 316,
+ REFGEN = 317,
+ UMINUS = 318,
+ POWOP = 319,
+ POSTDEC = 320,
+ POSTINC = 321,
+ PREDEC = 322,
+ PREINC = 323,
+ ARROW = 324,
+ PEG = 325
+ };
+#endif
+/* Tokens. */
+#define WORD 258
+#define METHOD 259
+#define FUNCMETH 260
+#define THING 261
+#define PMFUNC 262
+#define PRIVATEREF 263
+#define FUNC0SUB 264
+#define UNIOPSUB 265
+#define LSTOPSUB 266
+#define LABEL 267
+#define FORMAT 268
+#define SUB 269
+#define ANONSUB 270
+#define PACKAGE 271
+#define USE 272
+#define WHILE 273
+#define UNTIL 274
+#define IF 275
+#define UNLESS 276
+#define ELSE 277
+#define ELSIF 278
+#define CONTINUE 279
+#define FOR 280
+#define GIVEN 281
+#define WHEN 282
+#define DEFAULT 283
+#define LOOPEX 284
+#define DOTDOT 285
+#define FUNC0 286
+#define FUNC1 287
+#define FUNC 288
+#define UNIOP 289
+#define LSTOP 290
+#define RELOP 291
+#define EQOP 292
+#define MULOP 293
+#define ADDOP 294
+#define DOLSHARP 295
+#define DO 296
+#define HASHBRACK 297
+#define NOAMP 298
+#define LOCAL 299
+#define MY 300
+#define MYSUB 301
+#define REQUIRE 302
+#define COLONATTR 303
+#define PREC_LOW 304
+#define DOROP 305
+#define OROP 306
+#define ANDOP 307
+#define NOTOP 308
+#define ASSIGNOP 309
+#define DORDOR 310
+#define OROR 311
+#define ANDAND 312
+#define BITOROP 313
+#define BITANDOP 314
+#define SHIFTOP 315
+#define MATCHOP 316
+#define REFGEN 317
+#define UMINUS 318
+#define POWOP 319
+#define POSTDEC 320
+#define POSTINC 321
+#define PREDEC 322
+#define PREINC 323
+#define ARROW 324
+#define PEG 325
+
+
+
+
+#endif /* PERL_CORE */
+#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
+typedef union YYSTYPE
+{
+ I32 ival; /* __DEFAULT__ (marker for regen_perly.pl;
+ must always be 1st union member) */
+ char *pval;
+ OP *opval;
+ GV *gvval;
+#ifdef PERL_IN_MADLY_C
+ TOKEN* p_tkval;
+ TOKEN* i_tkval;
+#else
+ char *p_tkval;
+ I32 i_tkval;
+#endif
+#ifdef PERL_MAD
+ TOKEN* tkval;
+#endif
+}
+/* Line 1489 of yacc.c. */
+ YYSTYPE;
+# define yystype YYSTYPE /* obsolescent; will be withdrawn */
+# define YYSTYPE_IS_DECLARED 1
+# define YYSTYPE_IS_TRIVIAL 1
+#endif
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/pp.h b/Master/tlpkg/tlperl.straw/lib/CORE/pp.h
new file mode 100755
index 00000000000..6f0f258278a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/pp.h
@@ -0,0 +1,511 @@
+/* pp.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#define PP(s) OP * Perl_##s(pTHX)
+
+/*
+=head1 Stack Manipulation Macros
+
+=for apidoc AmU||SP
+Stack pointer. This is usually handled by C<xsubpp>. See C<dSP> and
+C<SPAGAIN>.
+
+=for apidoc AmU||MARK
+Stack marker variable for the XSUB. See C<dMARK>.
+
+=for apidoc Am|void|PUSHMARK|SP
+Opening bracket for arguments on a callback. See C<PUTBACK> and
+L<perlcall>.
+
+=for apidoc Ams||dSP
+Declares a local copy of perl's stack pointer for the XSUB, available via
+the C<SP> macro. See C<SP>.
+
+=for apidoc ms||djSP
+
+Declare Just C<SP>. This is actually identical to C<dSP>, and declares
+a local copy of perl's stack pointer, available via the C<SP> macro.
+See C<SP>. (Available for backward source code compatibility with the
+old (Perl 5.005) thread model.)
+
+=for apidoc Ams||dMARK
+Declare a stack marker variable, C<mark>, for the XSUB. See C<MARK> and
+C<dORIGMARK>.
+
+=for apidoc Ams||dORIGMARK
+Saves the original stack mark for the XSUB. See C<ORIGMARK>.
+
+=for apidoc AmU||ORIGMARK
+The original stack mark for the XSUB. See C<dORIGMARK>.
+
+=for apidoc Ams||SPAGAIN
+Refetch the stack pointer. Used after a callback. See L<perlcall>.
+
+=cut */
+
+#undef SP /* Solaris 2.7 i386 has this in /usr/include/sys/reg.h */
+#define SP sp
+#define MARK mark
+#define TARG targ
+
+#define PUSHMARK(p) \
+ STMT_START { \
+ if (++PL_markstack_ptr == PL_markstack_max) \
+ markstack_grow(); \
+ *PL_markstack_ptr = (I32)((p) - PL_stack_base);\
+ } STMT_END
+
+#define TOPMARK (*PL_markstack_ptr)
+#define POPMARK (*PL_markstack_ptr--)
+
+#define dSP SV **sp = PL_stack_sp
+#define djSP dSP
+#define dMARK register SV **mark = PL_stack_base + POPMARK
+#define dORIGMARK const I32 origmark = (I32)(mark - PL_stack_base)
+#define ORIGMARK (PL_stack_base + origmark)
+
+#define SPAGAIN sp = PL_stack_sp
+#define MSPAGAIN STMT_START { sp = PL_stack_sp; mark = ORIGMARK; } STMT_END
+
+#define GETTARGETSTACKED targ = (PL_op->op_flags & OPf_STACKED ? POPs : PAD_SV(PL_op->op_targ))
+#define dTARGETSTACKED SV * GETTARGETSTACKED
+
+#define GETTARGET targ = PAD_SV(PL_op->op_targ)
+#define dTARGET SV * GETTARGET
+
+#define GETATARGET targ = (PL_op->op_flags & OPf_STACKED ? sp[-1] : PAD_SV(PL_op->op_targ))
+#define dATARGET SV * GETATARGET
+
+#define dTARG SV *targ
+
+#define NORMAL PL_op->op_next
+#define DIE return Perl_die
+
+/*
+=for apidoc Ams||PUTBACK
+Closing bracket for XSUB arguments. This is usually handled by C<xsubpp>.
+See C<PUSHMARK> and L<perlcall> for other uses.
+
+=for apidoc Amn|SV*|POPs
+Pops an SV off the stack.
+
+=for apidoc Amn|char*|POPp
+Pops a string off the stack. Deprecated. New code should use POPpx.
+
+=for apidoc Amn|char*|POPpx
+Pops a string off the stack.
+
+=for apidoc Amn|char*|POPpbytex
+Pops a string off the stack which must consist of bytes i.e. characters < 256.
+
+=for apidoc Amn|NV|POPn
+Pops a double off the stack.
+
+=for apidoc Amn|IV|POPi
+Pops an integer off the stack.
+
+=for apidoc Amn|long|POPl
+Pops a long off the stack.
+
+=cut
+*/
+
+#define PUTBACK PL_stack_sp = sp
+#define RETURN return (PUTBACK, NORMAL)
+#define RETURNOP(o) return (PUTBACK, o)
+#define RETURNX(x) return (x, PUTBACK, NORMAL)
+
+#define POPs (*sp--)
+#define POPp (SvPVx(POPs, PL_na)) /* deprecated */
+#define POPpx (SvPVx_nolen(POPs))
+#define POPpconstx (SvPVx_nolen_const(POPs))
+#define POPpbytex (SvPVbytex_nolen(POPs))
+#define POPn (SvNVx(POPs))
+#define POPi ((IV)SvIVx(POPs))
+#define POPu ((UV)SvUVx(POPs))
+#define POPl ((long)SvIVx(POPs))
+#define POPul ((unsigned long)SvIVx(POPs))
+#ifdef HAS_QUAD
+#define POPq ((Quad_t)SvIVx(POPs))
+#define POPuq ((Uquad_t)SvUVx(POPs))
+#endif
+
+#define TOPs (*sp)
+#define TOPm1s (*(sp-1))
+#define TOPp1s (*(sp+1))
+#define TOPp (SvPV(TOPs, PL_na)) /* deprecated */
+#define TOPpx (SvPV_nolen(TOPs))
+#define TOPn (SvNV(TOPs))
+#define TOPi ((IV)SvIV(TOPs))
+#define TOPu ((UV)SvUV(TOPs))
+#define TOPl ((long)SvIV(TOPs))
+#define TOPul ((unsigned long)SvUV(TOPs))
+#ifdef HAS_QUAD
+#define TOPq ((Quad_t)SvIV(TOPs))
+#define TOPuq ((Uquad_t)SvUV(TOPs))
+#endif
+
+/* Go to some pains in the rare event that we must extend the stack. */
+
+/*
+=for apidoc Am|void|EXTEND|SP|int nitems
+Used to extend the argument stack for an XSUB's return values. Once
+used, guarantees that there is room for at least C<nitems> to be pushed
+onto the stack.
+
+=for apidoc Am|void|PUSHs|SV* sv
+Push an SV onto the stack. The stack must have room for this element.
+Does not handle 'set' magic. Does not use C<TARG>. See also C<PUSHmortal>,
+C<XPUSHs> and C<XPUSHmortal>.
+
+=for apidoc Am|void|PUSHp|char* str|STRLEN len
+Push a string onto the stack. The stack must have room for this element.
+The C<len> indicates the length of the string. Handles 'set' magic. Uses
+C<TARG>, so C<dTARGET> or C<dXSTARG> should be called to declare it. Do not
+call multiple C<TARG>-oriented macros to return lists from XSUB's - see
+C<mPUSHp> instead. See also C<XPUSHp> and C<mXPUSHp>.
+
+=for apidoc Am|void|PUSHn|NV nv
+Push a double onto the stack. The stack must have room for this element.
+Handles 'set' magic. Uses C<TARG>, so C<dTARGET> or C<dXSTARG> should be
+called to declare it. Do not call multiple C<TARG>-oriented macros to
+return lists from XSUB's - see C<mPUSHn> instead. See also C<XPUSHn> and
+C<mXPUSHn>.
+
+=for apidoc Am|void|PUSHi|IV iv
+Push an integer onto the stack. The stack must have room for this element.
+Handles 'set' magic. Uses C<TARG>, so C<dTARGET> or C<dXSTARG> should be
+called to declare it. Do not call multiple C<TARG>-oriented macros to
+return lists from XSUB's - see C<mPUSHi> instead. See also C<XPUSHi> and
+C<mXPUSHi>.
+
+=for apidoc Am|void|PUSHu|UV uv
+Push an unsigned integer onto the stack. The stack must have room for this
+element. Handles 'set' magic. Uses C<TARG>, so C<dTARGET> or C<dXSTARG>
+should be called to declare it. Do not call multiple C<TARG>-oriented
+macros to return lists from XSUB's - see C<mPUSHu> instead. See also
+C<XPUSHu> and C<mXPUSHu>.
+
+=for apidoc Am|void|XPUSHs|SV* sv
+Push an SV onto the stack, extending the stack if necessary. Does not
+handle 'set' magic. Does not use C<TARG>. See also C<XPUSHmortal>,
+C<PUSHs> and C<PUSHmortal>.
+
+=for apidoc Am|void|XPUSHp|char* str|STRLEN len
+Push a string onto the stack, extending the stack if necessary. The C<len>
+indicates the length of the string. Handles 'set' magic. Uses C<TARG>, so
+C<dTARGET> or C<dXSTARG> should be called to declare it. Do not call
+multiple C<TARG>-oriented macros to return lists from XSUB's - see
+C<mXPUSHp> instead. See also C<PUSHp> and C<mPUSHp>.
+
+=for apidoc Am|void|XPUSHn|NV nv
+Push a double onto the stack, extending the stack if necessary. Handles
+'set' magic. Uses C<TARG>, so C<dTARGET> or C<dXSTARG> should be called to
+declare it. Do not call multiple C<TARG>-oriented macros to return lists
+from XSUB's - see C<mXPUSHn> instead. See also C<PUSHn> and C<mPUSHn>.
+
+=for apidoc Am|void|XPUSHi|IV iv
+Push an integer onto the stack, extending the stack if necessary. Handles
+'set' magic. Uses C<TARG>, so C<dTARGET> or C<dXSTARG> should be called to
+declare it. Do not call multiple C<TARG>-oriented macros to return lists
+from XSUB's - see C<mXPUSHi> instead. See also C<PUSHi> and C<mPUSHi>.
+
+=for apidoc Am|void|XPUSHu|UV uv
+Push an unsigned integer onto the stack, extending the stack if necessary.
+Handles 'set' magic. Uses C<TARG>, so C<dTARGET> or C<dXSTARG> should be
+called to declare it. Do not call multiple C<TARG>-oriented macros to
+return lists from XSUB's - see C<mXPUSHu> instead. See also C<PUSHu> and
+C<mPUSHu>.
+
+=for apidoc Am|void|mPUSHs|SV* sv
+Push an SV onto the stack and mortalizes the SV. The stack must have room
+for this element. Does not use C<TARG>. See also C<PUSHs> and C<mXPUSHs>.
+
+=for apidoc Am|void|PUSHmortal
+Push a new mortal SV onto the stack. The stack must have room for this
+element. Does not use C<TARG>. See also C<PUSHs>, C<XPUSHmortal> and C<XPUSHs>.
+
+=for apidoc Am|void|mPUSHp|char* str|STRLEN len
+Push a string onto the stack. The stack must have room for this element.
+The C<len> indicates the length of the string. Does not use C<TARG>.
+See also C<PUSHp>, C<mXPUSHp> and C<XPUSHp>.
+
+=for apidoc Am|void|mPUSHn|NV nv
+Push a double onto the stack. The stack must have room for this element.
+Does not use C<TARG>. See also C<PUSHn>, C<mXPUSHn> and C<XPUSHn>.
+
+=for apidoc Am|void|mPUSHi|IV iv
+Push an integer onto the stack. The stack must have room for this element.
+Does not use C<TARG>. See also C<PUSHi>, C<mXPUSHi> and C<XPUSHi>.
+
+=for apidoc Am|void|mPUSHu|UV uv
+Push an unsigned integer onto the stack. The stack must have room for this
+element. Does not use C<TARG>. See also C<PUSHu>, C<mXPUSHu> and C<XPUSHu>.
+
+=for apidoc Am|void|mXPUSHs|SV* sv
+Push an SV onto the stack, extending the stack if necessary and mortalizes
+the SV. Does not use C<TARG>. See also C<XPUSHs> and C<mPUSHs>.
+
+=for apidoc Am|void|XPUSHmortal
+Push a new mortal SV onto the stack, extending the stack if necessary.
+Does not use C<TARG>. See also C<XPUSHs>, C<PUSHmortal> and C<PUSHs>.
+
+=for apidoc Am|void|mXPUSHp|char* str|STRLEN len
+Push a string onto the stack, extending the stack if necessary. The C<len>
+indicates the length of the string. Does not use C<TARG>. See also C<XPUSHp>,
+C<mPUSHp> and C<PUSHp>.
+
+=for apidoc Am|void|mXPUSHn|NV nv
+Push a double onto the stack, extending the stack if necessary.
+Does not use C<TARG>. See also C<XPUSHn>, C<mPUSHn> and C<PUSHn>.
+
+=for apidoc Am|void|mXPUSHi|IV iv
+Push an integer onto the stack, extending the stack if necessary.
+Does not use C<TARG>. See also C<XPUSHi>, C<mPUSHi> and C<PUSHi>.
+
+=for apidoc Am|void|mXPUSHu|UV uv
+Push an unsigned integer onto the stack, extending the stack if necessary.
+Does not use C<TARG>. See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
+
+=cut
+*/
+
+#define EXTEND(p,n) STMT_START { if (PL_stack_max - p < (int)(n)) { \
+ sp = stack_grow(sp,p, (int) (n)); \
+ } } STMT_END
+
+/* Same thing, but update mark register too. */
+#define MEXTEND(p,n) STMT_START {if (PL_stack_max - p < (int)(n)) { \
+ const int markoff = mark - PL_stack_base; \
+ sp = stack_grow(sp,p,(int) (n)); \
+ mark = PL_stack_base + markoff; \
+ } } STMT_END
+
+#define PUSHs(s) (*++sp = (s))
+#define PUSHTARG STMT_START { SvSETMAGIC(TARG); PUSHs(TARG); } STMT_END
+#define PUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); PUSHTARG; } STMT_END
+#define PUSHn(n) STMT_START { sv_setnv(TARG, (NV)(n)); PUSHTARG; } STMT_END
+#define PUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); PUSHTARG; } STMT_END
+#define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
+
+#define XPUSHs(s) STMT_START { EXTEND(sp,1); (*++sp = (s)); } STMT_END
+#define XPUSHTARG STMT_START { SvSETMAGIC(TARG); XPUSHs(TARG); } STMT_END
+#define XPUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } STMT_END
+#define XPUSHn(n) STMT_START { sv_setnv(TARG, (NV)(n)); XPUSHTARG; } STMT_END
+#define XPUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); XPUSHTARG; } STMT_END
+#define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
+#define XPUSHundef STMT_START { SvOK_off(TARG); XPUSHs(TARG); } STMT_END
+
+#define mPUSHs(s) PUSHs(sv_2mortal(s))
+#define PUSHmortal PUSHs(sv_newmortal())
+#define mPUSHp(p,l) PUSHs(newSVpvn_flags((p), (l), SVs_TEMP))
+#define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n))
+#define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i))
+#define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u))
+
+#define mXPUSHs(s) XPUSHs(sv_2mortal(s))
+#define XPUSHmortal XPUSHs(sv_newmortal())
+#define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); mPUSHp((p), (l)); } STMT_END
+#define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END
+#define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END
+#define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END
+
+#define SETs(s) (*sp = s)
+#define SETTARG STMT_START { SvSETMAGIC(TARG); SETs(TARG); } STMT_END
+#define SETp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); SETTARG; } STMT_END
+#define SETn(n) STMT_START { sv_setnv(TARG, (NV)(n)); SETTARG; } STMT_END
+#define SETi(i) STMT_START { sv_setiv(TARG, (IV)(i)); SETTARG; } STMT_END
+#define SETu(u) STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END
+
+#define dTOPss SV *sv = TOPs
+#define dPOPss SV *sv = POPs
+#define dTOPnv NV value = TOPn
+#define dPOPnv NV value = POPn
+#define dTOPiv IV value = TOPi
+#define dPOPiv IV value = POPi
+#define dTOPuv UV value = TOPu
+#define dPOPuv UV value = POPu
+#ifdef HAS_QUAD
+#define dTOPqv Quad_t value = TOPu
+#define dPOPqv Quad_t value = POPu
+#define dTOPuqv Uquad_t value = TOPuq
+#define dPOPuqv Uquad_t value = POPuq
+#endif
+
+#define dPOPXssrl(X) SV *right = POPs; SV *left = CAT2(X,s)
+#define dPOPXnnrl(X) NV right = POPn; NV left = CAT2(X,n)
+#define dPOPXiirl(X) IV right = POPi; IV left = CAT2(X,i)
+
+#define USE_LEFT(sv) \
+ (SvOK(sv) || SvGMAGICAL(sv) || !(PL_op->op_flags & OPf_STACKED))
+#define dPOPXnnrl_ul(X) \
+ NV right = POPn; \
+ SV *leftsv = CAT2(X,s); \
+ NV left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0
+#define dPOPXiirl_ul(X) \
+ IV right = POPi; \
+ SV *leftsv = CAT2(X,s); \
+ IV left = USE_LEFT(leftsv) ? SvIV(leftsv) : 0
+
+#define dPOPPOPssrl dPOPXssrl(POP)
+#define dPOPPOPnnrl dPOPXnnrl(POP)
+#define dPOPPOPnnrl_ul dPOPXnnrl_ul(POP)
+#define dPOPPOPiirl dPOPXiirl(POP)
+#define dPOPPOPiirl_ul dPOPXiirl_ul(POP)
+
+#define dPOPTOPssrl dPOPXssrl(TOP)
+#define dPOPTOPnnrl dPOPXnnrl(TOP)
+#define dPOPTOPnnrl_ul dPOPXnnrl_ul(TOP)
+#define dPOPTOPiirl dPOPXiirl(TOP)
+#define dPOPTOPiirl_ul dPOPXiirl_ul(TOP)
+
+#define RETPUSHYES RETURNX(PUSHs(&PL_sv_yes))
+#define RETPUSHNO RETURNX(PUSHs(&PL_sv_no))
+#define RETPUSHUNDEF RETURNX(PUSHs(&PL_sv_undef))
+
+#define RETSETYES RETURNX(SETs(&PL_sv_yes))
+#define RETSETNO RETURNX(SETs(&PL_sv_no))
+#define RETSETUNDEF RETURNX(SETs(&PL_sv_undef))
+
+#define ARGTARG PL_op->op_targ
+
+ /* See OPpTARGET_MY: */
+#define MAXARG (PL_op->op_private & 15)
+
+#define SWITCHSTACK(f,t) \
+ STMT_START { \
+ AvFILLp(f) = sp - PL_stack_base; \
+ PL_stack_base = AvARRAY(t); \
+ PL_stack_max = PL_stack_base + AvMAX(t); \
+ sp = PL_stack_sp = PL_stack_base + AvFILLp(t); \
+ PL_curstack = t; \
+ } STMT_END
+
+#define EXTEND_MORTAL(n) \
+ STMT_START { \
+ if (PL_tmps_ix + (n) >= PL_tmps_max) \
+ tmps_grow(n); \
+ } STMT_END
+
+#define AMGf_noright 1
+#define AMGf_noleft 2
+#define AMGf_assign 4
+#define AMGf_unary 8
+
+#define tryAMAGICbinW_var(meth_enum,assign,set) STMT_START { \
+ SV* const left = *(sp-1); \
+ SV* const right = *(sp); \
+ if ((SvAMAGIC(left)||SvAMAGIC(right))) {\
+ SV * const tmpsv = amagic_call(left, \
+ right, \
+ (meth_enum), \
+ (assign)? AMGf_assign: 0); \
+ if (tmpsv) { \
+ SPAGAIN; \
+ (void)POPs; set(tmpsv); RETURN; } \
+ } \
+ } STMT_END
+
+#define tryAMAGICbinW(meth,assign,set) \
+ tryAMAGICbinW_var(CAT2(meth,_amg),assign,set)
+
+#define tryAMAGICbin_var(meth_enum,assign) \
+ tryAMAGICbinW_var(meth_enum,assign,SETsv)
+#define tryAMAGICbin(meth,assign) \
+ tryAMAGICbin_var(CAT2(meth,_amg),assign)
+
+#define tryAMAGICbinSET(meth,assign) tryAMAGICbinW(meth,assign,SETs)
+
+#define tryAMAGICbinSET_var(meth_enum,assign) \
+ tryAMAGICbinW_var(meth_enum,assign,SETs)
+
+#define AMG_CALLun_var(sv,meth_enum) amagic_call(sv,&PL_sv_undef, \
+ meth_enum,AMGf_noright | AMGf_unary)
+#define AMG_CALLun(sv,meth) AMG_CALLun_var(sv,CAT2(meth,_amg))
+
+#define AMG_CALLbinL(left,right,meth) \
+ amagic_call(left,right,CAT2(meth,_amg),AMGf_noright)
+
+#define tryAMAGICunW_var(meth_enum,set,shift,ret) STMT_START { \
+ SV* tmpsv; \
+ SV* arg= sp[shift]; \
+ if(0) goto am_again; /* shut up unused warning */ \
+ am_again: \
+ if ((SvAMAGIC(arg))&&\
+ (tmpsv=AMG_CALLun_var(arg,(meth_enum)))) {\
+ SPAGAIN; if (shift) sp += shift; \
+ set(tmpsv); ret; } \
+ } STMT_END
+#define tryAMAGICunW(meth,set,shift,ret) \
+ tryAMAGICunW_var(CAT2(meth,_amg),set,shift,ret)
+
+#define FORCE_SETs(sv) STMT_START { sv_setsv(TARG, (sv)); SETTARG; } STMT_END
+
+#define tryAMAGICun_var(meth_enum) tryAMAGICunW_var(meth_enum,SETsvUN,0,RETURN)
+#define tryAMAGICun(meth) tryAMAGICun_var(CAT2(meth,_amg))
+#define tryAMAGICunSET(meth) tryAMAGICunW(meth,SETs,0,RETURN)
+#define tryAMAGICunTARGET(meth, shift) \
+ STMT_START { dSP; sp--; /* get TARGET from below PL_stack_sp */ \
+ { dTARGETSTACKED; \
+ { dSP; tryAMAGICunW(meth,FORCE_SETs,shift,RETURN);}}} STMT_END
+
+#define setAGAIN(ref) \
+ STMT_START { \
+ sv = ref; \
+ if (!SvROK(ref)) \
+ Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); \
+ if (ref != arg && SvRV(ref) != SvRV(arg)) { \
+ arg = ref; \
+ goto am_again; \
+ } \
+ } STMT_END
+
+#define tryAMAGICunDEREF(meth) tryAMAGICunW(meth,setAGAIN,0,(void)0)
+#define tryAMAGICunDEREF_var(meth_enum) \
+ tryAMAGICunW_var(meth_enum,setAGAIN,0,(void)0)
+
+#define opASSIGN (PL_op->op_flags & OPf_STACKED)
+#define SETsv(sv) STMT_START { \
+ if (opASSIGN || (SvFLAGS(TARG) & SVs_PADMY)) \
+ { sv_setsv(TARG, (sv)); SETTARG; } \
+ else SETs(sv); } STMT_END
+
+#define SETsvUN(sv) STMT_START { \
+ if (SvFLAGS(TARG) & SVs_PADMY) \
+ { sv_setsv(TARG, (sv)); SETTARG; } \
+ else SETs(sv); } STMT_END
+
+/* newSVsv does not behave as advertised, so we copy missing
+ * information by hand */
+
+/* SV* ref causes confusion with the member variable
+ changed SV* ref to SV* tmpRef */
+#define RvDEEPCP(rv) STMT_START { SV* tmpRef=SvRV(rv); SV* rv_copy; \
+ if (SvREFCNT(tmpRef)>1 && (rv_copy = AMG_CALLun(rv,copy))) { \
+ SvRV_set(rv, rv_copy); \
+ SvREFCNT_dec(tmpRef); \
+ } } STMT_END
+
+/*
+=for apidoc mU||LVRET
+True if this op will be the return value of an lvalue subroutine
+
+=cut */
+#define LVRET ((PL_op->op_private & OPpMAYBE_LVSUB) && is_lvalue_sub())
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/pp_proto.h b/Master/tlpkg/tlperl.straw/lib/CORE/pp_proto.h
new file mode 100755
index 00000000000..3a96e328377
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/pp_proto.h
@@ -0,0 +1,410 @@
+/* -*- buffer-read-only: t -*-
+ !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by opcode.pl from its data. Any changes made here
+ will be lost!
+*/
+
+PERL_CKDEF(Perl_ck_anoncode)
+PERL_CKDEF(Perl_ck_bitop)
+PERL_CKDEF(Perl_ck_chdir)
+PERL_CKDEF(Perl_ck_concat)
+PERL_CKDEF(Perl_ck_defined)
+PERL_CKDEF(Perl_ck_delete)
+PERL_CKDEF(Perl_ck_die)
+PERL_CKDEF(Perl_ck_eof)
+PERL_CKDEF(Perl_ck_eval)
+PERL_CKDEF(Perl_ck_exec)
+PERL_CKDEF(Perl_ck_exists)
+PERL_CKDEF(Perl_ck_exit)
+PERL_CKDEF(Perl_ck_ftst)
+PERL_CKDEF(Perl_ck_fun)
+PERL_CKDEF(Perl_ck_glob)
+PERL_CKDEF(Perl_ck_grep)
+PERL_CKDEF(Perl_ck_index)
+PERL_CKDEF(Perl_ck_join)
+PERL_CKDEF(Perl_ck_lengthconst)
+PERL_CKDEF(Perl_ck_lfun)
+PERL_CKDEF(Perl_ck_listiob)
+PERL_CKDEF(Perl_ck_match)
+PERL_CKDEF(Perl_ck_method)
+PERL_CKDEF(Perl_ck_null)
+PERL_CKDEF(Perl_ck_open)
+PERL_CKDEF(Perl_ck_readline)
+PERL_CKDEF(Perl_ck_repeat)
+PERL_CKDEF(Perl_ck_require)
+PERL_CKDEF(Perl_ck_return)
+PERL_CKDEF(Perl_ck_rfun)
+PERL_CKDEF(Perl_ck_rvconst)
+PERL_CKDEF(Perl_ck_sassign)
+PERL_CKDEF(Perl_ck_select)
+PERL_CKDEF(Perl_ck_shift)
+PERL_CKDEF(Perl_ck_smartmatch)
+PERL_CKDEF(Perl_ck_sort)
+PERL_CKDEF(Perl_ck_spair)
+PERL_CKDEF(Perl_ck_split)
+PERL_CKDEF(Perl_ck_subr)
+PERL_CKDEF(Perl_ck_substr)
+PERL_CKDEF(Perl_ck_svconst)
+PERL_CKDEF(Perl_ck_trunc)
+PERL_CKDEF(Perl_ck_unpack)
+
+
+PERL_PPDEF(Perl_pp_null)
+PERL_PPDEF(Perl_pp_stub)
+PERL_PPDEF(Perl_pp_scalar)
+PERL_PPDEF(Perl_pp_pushmark)
+PERL_PPDEF(Perl_pp_wantarray)
+PERL_PPDEF(Perl_pp_const)
+PERL_PPDEF(Perl_pp_gvsv)
+PERL_PPDEF(Perl_pp_gv)
+PERL_PPDEF(Perl_pp_gelem)
+PERL_PPDEF(Perl_pp_padsv)
+PERL_PPDEF(Perl_pp_padav)
+PERL_PPDEF(Perl_pp_padhv)
+PERL_PPDEF(Perl_pp_padany)
+PERL_PPDEF(Perl_pp_pushre)
+PERL_PPDEF(Perl_pp_rv2gv)
+PERL_PPDEF(Perl_pp_rv2sv)
+PERL_PPDEF(Perl_pp_av2arylen)
+PERL_PPDEF(Perl_pp_rv2cv)
+PERL_PPDEF(Perl_pp_anoncode)
+PERL_PPDEF(Perl_pp_prototype)
+PERL_PPDEF(Perl_pp_refgen)
+PERL_PPDEF(Perl_pp_srefgen)
+PERL_PPDEF(Perl_pp_ref)
+PERL_PPDEF(Perl_pp_bless)
+PERL_PPDEF(Perl_pp_backtick)
+PERL_PPDEF(Perl_pp_glob)
+PERL_PPDEF(Perl_pp_readline)
+PERL_PPDEF(Perl_pp_rcatline)
+PERL_PPDEF(Perl_pp_regcmaybe)
+PERL_PPDEF(Perl_pp_regcreset)
+PERL_PPDEF(Perl_pp_regcomp)
+PERL_PPDEF(Perl_pp_match)
+PERL_PPDEF(Perl_pp_qr)
+PERL_PPDEF(Perl_pp_subst)
+PERL_PPDEF(Perl_pp_substcont)
+PERL_PPDEF(Perl_pp_trans)
+PERL_PPDEF(Perl_pp_sassign)
+PERL_PPDEF(Perl_pp_aassign)
+PERL_PPDEF(Perl_pp_chop)
+PERL_PPDEF(Perl_pp_schop)
+PERL_PPDEF(Perl_pp_chomp)
+PERL_PPDEF(Perl_pp_schomp)
+PERL_PPDEF(Perl_pp_defined)
+PERL_PPDEF(Perl_pp_undef)
+PERL_PPDEF(Perl_pp_study)
+PERL_PPDEF(Perl_pp_pos)
+PERL_PPDEF(Perl_pp_preinc)
+PERL_PPDEF(Perl_pp_predec)
+PERL_PPDEF(Perl_pp_postinc)
+PERL_PPDEF(Perl_pp_postdec)
+PERL_PPDEF(Perl_pp_pow)
+PERL_PPDEF(Perl_pp_multiply)
+PERL_PPDEF(Perl_pp_i_multiply)
+PERL_PPDEF(Perl_pp_divide)
+PERL_PPDEF(Perl_pp_i_divide)
+PERL_PPDEF(Perl_pp_modulo)
+PERL_PPDEF(Perl_pp_i_modulo)
+PERL_PPDEF(Perl_pp_repeat)
+PERL_PPDEF(Perl_pp_add)
+PERL_PPDEF(Perl_pp_i_add)
+PERL_PPDEF(Perl_pp_subtract)
+PERL_PPDEF(Perl_pp_i_subtract)
+PERL_PPDEF(Perl_pp_concat)
+PERL_PPDEF(Perl_pp_stringify)
+PERL_PPDEF(Perl_pp_left_shift)
+PERL_PPDEF(Perl_pp_right_shift)
+PERL_PPDEF(Perl_pp_lt)
+PERL_PPDEF(Perl_pp_i_lt)
+PERL_PPDEF(Perl_pp_gt)
+PERL_PPDEF(Perl_pp_i_gt)
+PERL_PPDEF(Perl_pp_le)
+PERL_PPDEF(Perl_pp_i_le)
+PERL_PPDEF(Perl_pp_ge)
+PERL_PPDEF(Perl_pp_i_ge)
+PERL_PPDEF(Perl_pp_eq)
+PERL_PPDEF(Perl_pp_i_eq)
+PERL_PPDEF(Perl_pp_ne)
+PERL_PPDEF(Perl_pp_i_ne)
+PERL_PPDEF(Perl_pp_ncmp)
+PERL_PPDEF(Perl_pp_i_ncmp)
+PERL_PPDEF(Perl_pp_slt)
+PERL_PPDEF(Perl_pp_sgt)
+PERL_PPDEF(Perl_pp_sle)
+PERL_PPDEF(Perl_pp_sge)
+PERL_PPDEF(Perl_pp_seq)
+PERL_PPDEF(Perl_pp_sne)
+PERL_PPDEF(Perl_pp_scmp)
+PERL_PPDEF(Perl_pp_bit_and)
+PERL_PPDEF(Perl_pp_bit_xor)
+PERL_PPDEF(Perl_pp_bit_or)
+PERL_PPDEF(Perl_pp_negate)
+PERL_PPDEF(Perl_pp_i_negate)
+PERL_PPDEF(Perl_pp_not)
+PERL_PPDEF(Perl_pp_complement)
+PERL_PPDEF(Perl_pp_smartmatch)
+PERL_PPDEF(Perl_pp_atan2)
+PERL_PPDEF(Perl_pp_sin)
+PERL_PPDEF(Perl_pp_cos)
+PERL_PPDEF(Perl_pp_rand)
+PERL_PPDEF(Perl_pp_srand)
+PERL_PPDEF(Perl_pp_exp)
+PERL_PPDEF(Perl_pp_log)
+PERL_PPDEF(Perl_pp_sqrt)
+PERL_PPDEF(Perl_pp_int)
+PERL_PPDEF(Perl_pp_hex)
+PERL_PPDEF(Perl_pp_oct)
+PERL_PPDEF(Perl_pp_abs)
+PERL_PPDEF(Perl_pp_length)
+PERL_PPDEF(Perl_pp_substr)
+PERL_PPDEF(Perl_pp_vec)
+PERL_PPDEF(Perl_pp_index)
+PERL_PPDEF(Perl_pp_rindex)
+PERL_PPDEF(Perl_pp_sprintf)
+PERL_PPDEF(Perl_pp_formline)
+PERL_PPDEF(Perl_pp_ord)
+PERL_PPDEF(Perl_pp_chr)
+PERL_PPDEF(Perl_pp_crypt)
+PERL_PPDEF(Perl_pp_ucfirst)
+PERL_PPDEF(Perl_pp_lcfirst)
+PERL_PPDEF(Perl_pp_uc)
+PERL_PPDEF(Perl_pp_lc)
+PERL_PPDEF(Perl_pp_quotemeta)
+PERL_PPDEF(Perl_pp_rv2av)
+PERL_PPDEF(Perl_pp_aelemfast)
+PERL_PPDEF(Perl_pp_aelem)
+PERL_PPDEF(Perl_pp_aslice)
+PERL_PPDEF(Perl_pp_each)
+PERL_PPDEF(Perl_pp_values)
+PERL_PPDEF(Perl_pp_keys)
+PERL_PPDEF(Perl_pp_delete)
+PERL_PPDEF(Perl_pp_exists)
+PERL_PPDEF(Perl_pp_rv2hv)
+PERL_PPDEF(Perl_pp_helem)
+PERL_PPDEF(Perl_pp_hslice)
+PERL_PPDEF(Perl_pp_unpack)
+PERL_PPDEF(Perl_pp_pack)
+PERL_PPDEF(Perl_pp_split)
+PERL_PPDEF(Perl_pp_join)
+PERL_PPDEF(Perl_pp_list)
+PERL_PPDEF(Perl_pp_lslice)
+PERL_PPDEF(Perl_pp_anonlist)
+PERL_PPDEF(Perl_pp_anonhash)
+PERL_PPDEF(Perl_pp_splice)
+PERL_PPDEF(Perl_pp_push)
+PERL_PPDEF(Perl_pp_pop)
+PERL_PPDEF(Perl_pp_shift)
+PERL_PPDEF(Perl_pp_unshift)
+PERL_PPDEF(Perl_pp_sort)
+PERL_PPDEF(Perl_pp_reverse)
+PERL_PPDEF(Perl_pp_grepstart)
+PERL_PPDEF(Perl_pp_grepwhile)
+PERL_PPDEF(Perl_pp_mapstart)
+PERL_PPDEF(Perl_pp_mapwhile)
+PERL_PPDEF(Perl_pp_range)
+PERL_PPDEF(Perl_pp_flip)
+PERL_PPDEF(Perl_pp_flop)
+PERL_PPDEF(Perl_pp_and)
+PERL_PPDEF(Perl_pp_or)
+PERL_PPDEF(Perl_pp_xor)
+PERL_PPDEF(Perl_pp_dor)
+PERL_PPDEF(Perl_pp_cond_expr)
+PERL_PPDEF(Perl_pp_andassign)
+PERL_PPDEF(Perl_pp_orassign)
+PERL_PPDEF(Perl_pp_dorassign)
+PERL_PPDEF(Perl_pp_method)
+PERL_PPDEF(Perl_pp_entersub)
+PERL_PPDEF(Perl_pp_leavesub)
+PERL_PPDEF(Perl_pp_leavesublv)
+PERL_PPDEF(Perl_pp_caller)
+PERL_PPDEF(Perl_pp_warn)
+PERL_PPDEF(Perl_pp_die)
+PERL_PPDEF(Perl_pp_reset)
+PERL_PPDEF(Perl_pp_lineseq)
+PERL_PPDEF(Perl_pp_nextstate)
+PERL_PPDEF(Perl_pp_dbstate)
+PERL_PPDEF(Perl_pp_unstack)
+PERL_PPDEF(Perl_pp_enter)
+PERL_PPDEF(Perl_pp_leave)
+PERL_PPDEF(Perl_pp_scope)
+PERL_PPDEF(Perl_pp_enteriter)
+PERL_PPDEF(Perl_pp_iter)
+PERL_PPDEF(Perl_pp_enterloop)
+PERL_PPDEF(Perl_pp_leaveloop)
+PERL_PPDEF(Perl_pp_return)
+PERL_PPDEF(Perl_pp_last)
+PERL_PPDEF(Perl_pp_next)
+PERL_PPDEF(Perl_pp_redo)
+PERL_PPDEF(Perl_pp_dump)
+PERL_PPDEF(Perl_pp_goto)
+PERL_PPDEF(Perl_pp_exit)
+PERL_PPDEF(Perl_pp_setstate)
+PERL_PPDEF(Perl_pp_method_named)
+PERL_PPDEF(Perl_pp_entergiven)
+PERL_PPDEF(Perl_pp_leavegiven)
+PERL_PPDEF(Perl_pp_enterwhen)
+PERL_PPDEF(Perl_pp_leavewhen)
+PERL_PPDEF(Perl_pp_break)
+PERL_PPDEF(Perl_pp_continue)
+PERL_PPDEF(Perl_pp_open)
+PERL_PPDEF(Perl_pp_close)
+PERL_PPDEF(Perl_pp_pipe_op)
+PERL_PPDEF(Perl_pp_fileno)
+PERL_PPDEF(Perl_pp_umask)
+PERL_PPDEF(Perl_pp_binmode)
+PERL_PPDEF(Perl_pp_tie)
+PERL_PPDEF(Perl_pp_untie)
+PERL_PPDEF(Perl_pp_tied)
+PERL_PPDEF(Perl_pp_dbmopen)
+PERL_PPDEF(Perl_pp_dbmclose)
+PERL_PPDEF(Perl_pp_sselect)
+PERL_PPDEF(Perl_pp_select)
+PERL_PPDEF(Perl_pp_getc)
+PERL_PPDEF(Perl_pp_read)
+PERL_PPDEF(Perl_pp_enterwrite)
+PERL_PPDEF(Perl_pp_leavewrite)
+PERL_PPDEF(Perl_pp_prtf)
+PERL_PPDEF(Perl_pp_print)
+PERL_PPDEF(Perl_pp_say)
+PERL_PPDEF(Perl_pp_sysopen)
+PERL_PPDEF(Perl_pp_sysseek)
+PERL_PPDEF(Perl_pp_sysread)
+PERL_PPDEF(Perl_pp_syswrite)
+PERL_PPDEF(Perl_pp_send)
+PERL_PPDEF(Perl_pp_recv)
+PERL_PPDEF(Perl_pp_eof)
+PERL_PPDEF(Perl_pp_tell)
+PERL_PPDEF(Perl_pp_seek)
+PERL_PPDEF(Perl_pp_truncate)
+PERL_PPDEF(Perl_pp_fcntl)
+PERL_PPDEF(Perl_pp_ioctl)
+PERL_PPDEF(Perl_pp_flock)
+PERL_PPDEF(Perl_pp_socket)
+PERL_PPDEF(Perl_pp_sockpair)
+PERL_PPDEF(Perl_pp_bind)
+PERL_PPDEF(Perl_pp_connect)
+PERL_PPDEF(Perl_pp_listen)
+PERL_PPDEF(Perl_pp_accept)
+PERL_PPDEF(Perl_pp_shutdown)
+PERL_PPDEF(Perl_pp_gsockopt)
+PERL_PPDEF(Perl_pp_ssockopt)
+PERL_PPDEF(Perl_pp_getsockname)
+PERL_PPDEF(Perl_pp_getpeername)
+PERL_PPDEF(Perl_pp_lstat)
+PERL_PPDEF(Perl_pp_stat)
+PERL_PPDEF(Perl_pp_ftrread)
+PERL_PPDEF(Perl_pp_ftrwrite)
+PERL_PPDEF(Perl_pp_ftrexec)
+PERL_PPDEF(Perl_pp_fteread)
+PERL_PPDEF(Perl_pp_ftewrite)
+PERL_PPDEF(Perl_pp_fteexec)
+PERL_PPDEF(Perl_pp_ftis)
+PERL_PPDEF(Perl_pp_ftsize)
+PERL_PPDEF(Perl_pp_ftmtime)
+PERL_PPDEF(Perl_pp_ftatime)
+PERL_PPDEF(Perl_pp_ftctime)
+PERL_PPDEF(Perl_pp_ftrowned)
+PERL_PPDEF(Perl_pp_fteowned)
+PERL_PPDEF(Perl_pp_ftzero)
+PERL_PPDEF(Perl_pp_ftsock)
+PERL_PPDEF(Perl_pp_ftchr)
+PERL_PPDEF(Perl_pp_ftblk)
+PERL_PPDEF(Perl_pp_ftfile)
+PERL_PPDEF(Perl_pp_ftdir)
+PERL_PPDEF(Perl_pp_ftpipe)
+PERL_PPDEF(Perl_pp_ftsuid)
+PERL_PPDEF(Perl_pp_ftsgid)
+PERL_PPDEF(Perl_pp_ftsvtx)
+PERL_PPDEF(Perl_pp_ftlink)
+PERL_PPDEF(Perl_pp_fttty)
+PERL_PPDEF(Perl_pp_fttext)
+PERL_PPDEF(Perl_pp_ftbinary)
+PERL_PPDEF(Perl_pp_chdir)
+PERL_PPDEF(Perl_pp_chown)
+PERL_PPDEF(Perl_pp_chroot)
+PERL_PPDEF(Perl_pp_unlink)
+PERL_PPDEF(Perl_pp_chmod)
+PERL_PPDEF(Perl_pp_utime)
+PERL_PPDEF(Perl_pp_rename)
+PERL_PPDEF(Perl_pp_link)
+PERL_PPDEF(Perl_pp_symlink)
+PERL_PPDEF(Perl_pp_readlink)
+PERL_PPDEF(Perl_pp_mkdir)
+PERL_PPDEF(Perl_pp_rmdir)
+PERL_PPDEF(Perl_pp_open_dir)
+PERL_PPDEF(Perl_pp_readdir)
+PERL_PPDEF(Perl_pp_telldir)
+PERL_PPDEF(Perl_pp_seekdir)
+PERL_PPDEF(Perl_pp_rewinddir)
+PERL_PPDEF(Perl_pp_closedir)
+PERL_PPDEF(Perl_pp_fork)
+PERL_PPDEF(Perl_pp_wait)
+PERL_PPDEF(Perl_pp_waitpid)
+PERL_PPDEF(Perl_pp_system)
+PERL_PPDEF(Perl_pp_exec)
+PERL_PPDEF(Perl_pp_kill)
+PERL_PPDEF(Perl_pp_getppid)
+PERL_PPDEF(Perl_pp_getpgrp)
+PERL_PPDEF(Perl_pp_setpgrp)
+PERL_PPDEF(Perl_pp_getpriority)
+PERL_PPDEF(Perl_pp_setpriority)
+PERL_PPDEF(Perl_pp_time)
+PERL_PPDEF(Perl_pp_tms)
+PERL_PPDEF(Perl_pp_localtime)
+PERL_PPDEF(Perl_pp_gmtime)
+PERL_PPDEF(Perl_pp_alarm)
+PERL_PPDEF(Perl_pp_sleep)
+PERL_PPDEF(Perl_pp_shmget)
+PERL_PPDEF(Perl_pp_shmctl)
+PERL_PPDEF(Perl_pp_shmread)
+PERL_PPDEF(Perl_pp_shmwrite)
+PERL_PPDEF(Perl_pp_msgget)
+PERL_PPDEF(Perl_pp_msgctl)
+PERL_PPDEF(Perl_pp_msgsnd)
+PERL_PPDEF(Perl_pp_msgrcv)
+PERL_PPDEF(Perl_pp_semop)
+PERL_PPDEF(Perl_pp_semget)
+PERL_PPDEF(Perl_pp_semctl)
+PERL_PPDEF(Perl_pp_require)
+PERL_PPDEF(Perl_pp_dofile)
+PERL_PPDEF(Perl_pp_entereval)
+PERL_PPDEF(Perl_pp_leaveeval)
+PERL_PPDEF(Perl_pp_entertry)
+PERL_PPDEF(Perl_pp_leavetry)
+PERL_PPDEF(Perl_pp_ghbyname)
+PERL_PPDEF(Perl_pp_ghbyaddr)
+PERL_PPDEF(Perl_pp_ghostent)
+PERL_PPDEF(Perl_pp_gnbyname)
+PERL_PPDEF(Perl_pp_gnbyaddr)
+PERL_PPDEF(Perl_pp_gnetent)
+PERL_PPDEF(Perl_pp_gpbyname)
+PERL_PPDEF(Perl_pp_gpbynumber)
+PERL_PPDEF(Perl_pp_gprotoent)
+PERL_PPDEF(Perl_pp_gsbyname)
+PERL_PPDEF(Perl_pp_gsbyport)
+PERL_PPDEF(Perl_pp_gservent)
+PERL_PPDEF(Perl_pp_shostent)
+PERL_PPDEF(Perl_pp_snetent)
+PERL_PPDEF(Perl_pp_sprotoent)
+PERL_PPDEF(Perl_pp_sservent)
+PERL_PPDEF(Perl_pp_ehostent)
+PERL_PPDEF(Perl_pp_enetent)
+PERL_PPDEF(Perl_pp_eprotoent)
+PERL_PPDEF(Perl_pp_eservent)
+PERL_PPDEF(Perl_pp_gpwnam)
+PERL_PPDEF(Perl_pp_gpwuid)
+PERL_PPDEF(Perl_pp_gpwent)
+PERL_PPDEF(Perl_pp_spwent)
+PERL_PPDEF(Perl_pp_epwent)
+PERL_PPDEF(Perl_pp_ggrnam)
+PERL_PPDEF(Perl_pp_ggrgid)
+PERL_PPDEF(Perl_pp_ggrent)
+PERL_PPDEF(Perl_pp_sgrent)
+PERL_PPDEF(Perl_pp_egrent)
+PERL_PPDEF(Perl_pp_getlogin)
+PERL_PPDEF(Perl_pp_syscall)
+PERL_PPDEF(Perl_pp_lock)
+PERL_PPDEF(Perl_pp_once)
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/proto.h b/Master/tlpkg/tlperl.straw/lib/CORE/proto.h
new file mode 100755
index 00000000000..ce766bcd9b0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/proto.h
@@ -0,0 +1,6650 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * proto.h
+ *
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by embed.pl from data in embed.fnc, embed.pl,
+ * pp.sym, intrpvar.h, and perlvars.h.
+ * Any changes made here will be lost!
+ *
+ * Edit those files and run 'make regen_headers' to effect changes.
+ */
+
+START_EXTERN_C
+
+#if defined(PERL_IMPLICIT_SYS)
+PERL_CALLCONV PerlInterpreter* perl_alloc_using(struct IPerlMem *ipM, struct IPerlMem *ipMS, struct IPerlMem *ipMP, struct IPerlEnv *ipE, struct IPerlStdIO *ipStd, struct IPerlLIO *ipLIO, struct IPerlDir *ipD, struct IPerlSock *ipS, struct IPerlProc *ipP)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4)
+ __attribute__nonnull__(5)
+ __attribute__nonnull__(6)
+ __attribute__nonnull__(7)
+ __attribute__nonnull__(8)
+ __attribute__nonnull__(9);
+#define PERL_ARGS_ASSERT_PERL_ALLOC_USING \
+ assert(ipM); assert(ipMS); assert(ipMP); assert(ipE); assert(ipStd); assert(ipLIO); assert(ipD); assert(ipS); assert(ipP)
+
+#endif
+PERL_CALLCONV PerlInterpreter* perl_alloc(void);
+PERL_CALLCONV void perl_construct(PerlInterpreter *my_perl)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PERL_CONSTRUCT \
+ assert(my_perl)
+
+PERL_CALLCONV int perl_destruct(PerlInterpreter *my_perl)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PERL_DESTRUCT \
+ assert(my_perl)
+
+PERL_CALLCONV void perl_free(PerlInterpreter *my_perl)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PERL_FREE \
+ assert(my_perl)
+
+PERL_CALLCONV int perl_run(PerlInterpreter *my_perl)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PERL_RUN \
+ assert(my_perl)
+
+PERL_CALLCONV int perl_parse(PerlInterpreter *my_perl, XSINIT_t xsinit, int argc, char** argv, char** env)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PERL_PARSE \
+ assert(my_perl)
+
+PERL_CALLCONV bool Perl_doing_taint(int argc, char** argv, char** env)
+ __attribute__warn_unused_result__;
+
+#if defined(USE_ITHREADS)
+PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter *proto_perl, UV flags)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PERL_CLONE \
+ assert(proto_perl)
+
+# if defined(PERL_IMPLICIT_SYS)
+PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *proto_perl, UV flags, struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlMem* ipMP, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, struct IPerlProc* ipP)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4)
+ __attribute__nonnull__(5)
+ __attribute__nonnull__(6)
+ __attribute__nonnull__(7)
+ __attribute__nonnull__(8)
+ __attribute__nonnull__(9)
+ __attribute__nonnull__(10)
+ __attribute__nonnull__(11);
+#define PERL_ARGS_ASSERT_PERL_CLONE_USING \
+ assert(proto_perl); assert(ipM); assert(ipMS); assert(ipMP); assert(ipE); assert(ipStd); assert(ipLIO); assert(ipD); assert(ipS); assert(ipP)
+
+# endif
+#endif
+
+PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Free_t Perl_mfree(Malloc_t where);
+#if defined(MYMALLOC)
+PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_MALLOCED_SIZE \
+ assert(p)
+
+PERL_CALLCONV MEM_SIZE Perl_malloc_good_size(size_t nbytes)
+ __attribute__warn_unused_result__;
+
+#endif
+
+PERL_CALLCONV void* Perl_get_context(void)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_set_context(void *t)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SET_CONTEXT \
+ assert(t)
+
+
+END_EXTERN_C
+
+/* functions with flag 'n' should come before here */
+START_EXTERN_C
+# include "pp_proto.h"
+PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AMAGIC_CALL \
+ assert(left); assert(right)
+
+PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_AMUPDATE \
+ assert(stash)
+
+PERL_CALLCONV CV* Perl_gv_handler(pTHX_ HV* stash, I32 id)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* first, OP* last);
+PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last);
+PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_APPLY \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV void Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, const char *attrstr, STRLEN len)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_APPLY_ATTRS_STRING \
+ assert(stashpv); assert(cv); assert(attrstr)
+
+PERL_CALLCONV void Perl_av_clear(pTHX_ AV *av)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_CLEAR \
+ assert(av)
+
+PERL_CALLCONV SV* Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_DELETE \
+ assert(av)
+
+PERL_CALLCONV bool Perl_av_exists(pTHX_ AV *av, I32 key)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_EXISTS \
+ assert(av)
+
+PERL_CALLCONV void Perl_av_extend(pTHX_ AV *av, I32 key)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_EXTEND \
+ assert(av)
+
+PERL_CALLCONV AV* Perl_av_fake(pTHX_ I32 size, SV **strp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AV_FAKE \
+ assert(strp)
+
+PERL_CALLCONV SV** Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_FETCH \
+ assert(av)
+
+PERL_CALLCONV void Perl_av_fill(pTHX_ AV *av, I32 fill)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_FILL \
+ assert(av)
+
+PERL_CALLCONV I32 Perl_av_len(pTHX_ const AV *av)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_LEN \
+ assert(av)
+
+PERL_CALLCONV AV* Perl_av_make(pTHX_ I32 size, SV **strp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AV_MAKE \
+ assert(strp)
+
+PERL_CALLCONV SV* Perl_av_pop(pTHX_ AV *av)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_POP \
+ assert(av)
+
+PERL_CALLCONV void Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH \
+ assert(avp); assert(val)
+
+PERL_CALLCONV void Perl_av_push(pTHX_ AV *av, SV *val)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AV_PUSH \
+ assert(av); assert(val)
+
+PERL_CALLCONV void Perl_av_reify(pTHX_ AV *av)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_REIFY \
+ assert(av)
+
+PERL_CALLCONV SV* Perl_av_shift(pTHX_ AV *av)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_SHIFT \
+ assert(av)
+
+PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, I32 key, SV *val)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_STORE \
+ assert(av)
+
+PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_UNDEF \
+ assert(av)
+
+PERL_CALLCONV SV** Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE \
+ assert(avp); assert(val)
+
+PERL_CALLCONV void Perl_av_unshift(pTHX_ AV *av, I32 num)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_UNSHIFT \
+ assert(av)
+
+PERL_CALLCONV SV** Perl_av_arylen_p(pTHX_ AV *av)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_ARYLEN_P \
+ assert(av)
+
+PERL_CALLCONV OP* Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_BIND_MATCH \
+ assert(left); assert(right)
+
+PERL_CALLCONV OP* Perl_block_end(pTHX_ I32 floor, OP* seq)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV I32 Perl_block_gimme(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV int Perl_block_start(pTHX_ int full)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_boot_core_UNIVERSAL(pTHX);
+PERL_CALLCONV void Perl_boot_core_PerlIO(pTHX);
+PERL_CALLCONV void Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CALL_LIST \
+ assert(paramList)
+
+PERL_CALLCONV bool Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t* statbufp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CANDO \
+ assert(statbufp)
+
+PERL_CALLCONV U32 Perl_cast_ulong(pTHX_ NV f)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV I32 Perl_cast_i32(pTHX_ NV f)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV IV Perl_cast_iv(pTHX_ NV f)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV UV Perl_cast_uv(pTHX_ NV f)
+ __attribute__warn_unused_result__;
+
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
+PERL_CALLCONV I32 Perl_my_chsize(pTHX_ int fd, Off_t length)
+ __attribute__warn_unused_result__;
+
+#endif
+PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PERL_CONTEXT* Perl_create_eval_scope(pTHX_ U32 flags);
+PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...)
+ __attribute__noreturn__
+ __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
+
+PERL_CALLCONV void Perl_vcroak(pTHX_ const char* pat, va_list* args)
+ __attribute__noreturn__;
+
+PERL_CALLCONV void Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+ __attribute__noreturn__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE \
+ assert(cv); assert(params)
+
+
+#if defined(PERL_IMPLICIT_CONTEXT)
+PERL_CALLCONV void Perl_croak_nocontext(const char* pat, ...)
+ __attribute__noreturn__
+ __attribute__format__null_ok__(__printf__,1,2);
+
+PERL_CALLCONV OP* Perl_die_nocontext(const char* pat, ...)
+ __attribute__format__null_ok__(__printf__,1,2);
+
+PERL_CALLCONV void Perl_deb_nocontext(const char* pat, ...)
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_DEB_NOCONTEXT \
+ assert(pat)
+
+PERL_CALLCONV char* Perl_form_nocontext(const char* pat, ...)
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_FORM_NOCONTEXT \
+ assert(pat)
+
+PERL_CALLCONV void Perl_load_module_nocontext(U32 flags, SV* name, SV* ver, ...)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT \
+ assert(name)
+
+PERL_CALLCONV SV* Perl_mess_nocontext(const char* pat, ...)
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_MESS_NOCONTEXT \
+ assert(pat)
+
+PERL_CALLCONV void Perl_warn_nocontext(const char* pat, ...)
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_WARN_NOCONTEXT \
+ assert(pat)
+
+PERL_CALLCONV void Perl_warner_nocontext(U32 err, const char* pat, ...)
+ __attribute__format__(__printf__,2,3)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_WARNER_NOCONTEXT \
+ assert(pat)
+
+PERL_CALLCONV SV* Perl_newSVpvf_nocontext(const char* pat, ...)
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT \
+ assert(pat)
+
+PERL_CALLCONV void Perl_sv_catpvf_nocontext(SV* sv, const char* pat, ...)
+ __attribute__format__(__printf__,2,3)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_setpvf_nocontext(SV* sv, const char* pat, ...)
+ __attribute__format__(__printf__,2,3)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat, ...)
+ __attribute__format__(__printf__,2,3)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat, ...)
+ __attribute__format__(__printf__,2,3)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
+ __attribute__format__(__printf__,2,3)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT \
+ assert(stream); assert(format)
+
+PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...)
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PRINTF_NOCONTEXT \
+ assert(format)
+
+#endif
+PERL_CALLCONV void Perl_cv_ckproto(pTHX_ const CV* cv, const GV* gv, const char* p)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_CKPROTO \
+ assert(cv)
+
+PERL_CALLCONV void Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_CKPROTO_LEN \
+ assert(cv)
+
+PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_CLONE \
+ assert(proto)
+
+PERL_CALLCONV SV* Perl_gv_const_sv(pTHX_ GV* gv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_CONST_SV \
+ assert(gv)
+
+PERL_CALLCONV SV* Perl_cv_const_sv(pTHX_ CV* cv)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_UNDEF \
+ assert(cv)
+
+PERL_CALLCONV void Perl_cx_dump(pTHX_ PERL_CONTEXT* cx)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CX_DUMP \
+ assert(cx)
+
+PERL_CALLCONV SV* Perl_filter_add(pTHX_ filter_t funcp, SV* datasv);
+PERL_CALLCONV void Perl_filter_del(pTHX_ filter_t funcp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FILTER_DEL \
+ assert(funcp)
+
+PERL_CALLCONV I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_FILTER_READ \
+ assert(buf_sv)
+
+PERL_CALLCONV char** Perl_get_op_descs(pTHX)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV char** Perl_get_op_names(pTHX)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV const char* Perl_get_no_modify(pTHX)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV U32* Perl_get_opargs(pTHX)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV PPADDR_t* Perl_get_ppaddr(pTHX)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV I32 Perl_cxinc(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_deb(pTHX_ const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_1,pTHX_2)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DEB \
+ assert(pat)
+
+PERL_CALLCONV void Perl_vdeb(pTHX_ const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VDEB \
+ assert(pat)
+
+PERL_CALLCONV void Perl_debprofdump(pTHX);
+PERL_CALLCONV I32 Perl_debop(pTHX_ const OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DEBOP \
+ assert(o)
+
+PERL_CALLCONV I32 Perl_debstack(pTHX);
+PERL_CALLCONV I32 Perl_debstackptrs(pTHX);
+PERL_CALLCONV char* Perl_delimcpy(pTHX_ char* to, const char* toend, const char* from, const char* fromend, int delim, I32* retlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_6);
+#define PERL_ARGS_ASSERT_DELIMCPY \
+ assert(to); assert(toend); assert(from); assert(fromend); assert(retlen)
+
+PERL_CALLCONV void Perl_delete_eval_scope(pTHX);
+PERL_CALLCONV void Perl_deprecate(pTHX_ const char* s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DEPRECATE \
+ assert(s)
+
+PERL_CALLCONV void Perl_deprecate_old(pTHX_ const char* s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DEPRECATE_OLD \
+ assert(s)
+
+PERL_CALLCONV OP* Perl_die(pTHX_ const char* pat, ...)
+ __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
+
+PERL_CALLCONV OP* Perl_vdie(pTHX_ const char* pat, va_list* args);
+PERL_CALLCONV OP* Perl_die_where(pTHX_ const char* message, STRLEN msglen);
+PERL_CALLCONV void Perl_dounwind(pTHX_ I32 cxix);
+/* PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3); */
+#define PERL_ARGS_ASSERT_DO_AEXEC \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV bool Perl_do_aexec5(pTHX_ SV* really, SV** mark, SV** sp, int fd, int do_report)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_AEXEC5 \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_BINMODE \
+ assert(fp)
+
+PERL_CALLCONV void Perl_do_chop(pTHX_ SV *astr, SV *sv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_CHOP \
+ assert(astr); assert(sv)
+
+PERL_CALLCONV bool Perl_do_close(pTHX_ GV* gv, bool not_implicit);
+PERL_CALLCONV bool Perl_do_eof(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_EOF \
+ assert(gv)
+
+
+#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+/* PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_DO_EXEC \
+ assert(cmd)
+
+#else
+PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_EXEC \
+ assert(cmd)
+
+#endif
+
+#if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS)
+PERL_CALLCONV int Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_ASPAWN \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV int Perl_do_spawn(pTHX_ char* cmd)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_SPAWN \
+ assert(cmd)
+
+PERL_CALLCONV int Perl_do_spawn_nowait(pTHX_ char* cmd)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT \
+ assert(cmd)
+
+#endif
+#if !defined(WIN32)
+PERL_CALLCONV bool Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_EXEC3 \
+ assert(incmd)
+
+#endif
+PERL_CALLCONV void Perl_do_execfree(pTHX);
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+STATIC void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_EXEC_FAILED \
+ assert(cmd)
+
+#endif
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+PERL_CALLCONV I32 Perl_do_ipcctl(pTHX_ I32 optype, SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_IPCCTL \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV I32 Perl_do_ipcget(pTHX_ I32 optype, SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_IPCGET \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV I32 Perl_do_msgrcv(pTHX_ SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_MSGRCV \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV I32 Perl_do_msgsnd(pTHX_ SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_MSGSND \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV I32 Perl_do_semop(pTHX_ SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_SEMOP \
+ assert(mark); assert(sp)
+
+PERL_CALLCONV I32 Perl_do_shmio(pTHX_ I32 optype, SV** mark, SV** sp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_SHMIO \
+ assert(mark); assert(sp)
+
+#endif
+PERL_CALLCONV void Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_DO_JOIN \
+ assert(sv); assert(delim); assert(mark); assert(sp)
+
+PERL_CALLCONV OP* Perl_do_kv(pTHX);
+/* PERL_CALLCONV bool Perl_do_open(pTHX_ GV* gv, const char* name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_DO_OPEN \
+ assert(gv); assert(name)
+
+PERL_CALLCONV bool Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, I32 num)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_8);
+#define PERL_ARGS_ASSERT_DO_OPEN9 \
+ assert(gv); assert(name); assert(svs)
+
+PERL_CALLCONV bool Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, I32 num)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_OPENN \
+ assert(gv); assert(oname)
+
+PERL_CALLCONV bool Perl_do_print(pTHX_ SV* sv, PerlIO* fp)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_PRINT \
+ assert(fp)
+
+PERL_CALLCONV OP* Perl_do_readline(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV I32 Perl_do_chomp(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_CHOMP \
+ assert(sv)
+
+PERL_CALLCONV bool Perl_do_seek(pTHX_ GV* gv, Off_t pos, int whence);
+PERL_CALLCONV void Perl_do_sprintf(pTHX_ SV* sv, I32 len, SV** sarg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_SPRINTF \
+ assert(sv); assert(sarg)
+
+PERL_CALLCONV Off_t Perl_do_sysseek(pTHX_ GV* gv, Off_t pos, int whence)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_SYSSEEK \
+ assert(gv)
+
+PERL_CALLCONV Off_t Perl_do_tell(pTHX_ GV* gv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TELL \
+ assert(gv)
+
+PERL_CALLCONV I32 Perl_do_trans(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TRANS \
+ assert(sv)
+
+PERL_CALLCONV UV Perl_do_vecget(pTHX_ SV* sv, I32 offset, I32 size)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_VECGET \
+ assert(sv)
+
+PERL_CALLCONV void Perl_do_vecset(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_VECSET \
+ assert(sv)
+
+PERL_CALLCONV void Perl_do_vop(pTHX_ I32 optype, SV* sv, SV* left, SV* right)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_DO_VOP \
+ assert(sv); assert(left); assert(right)
+
+PERL_CALLCONV OP* Perl_dofile(pTHX_ OP* term, I32 force_builtin)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DOFILE \
+ assert(term)
+
+PERL_CALLCONV I32 Perl_dowantarray(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_dump_all(pTHX);
+PERL_CALLCONV void Perl_dump_eval(pTHX);
+#if defined(DUMP_FDS)
+PERL_CALLCONV void Perl_dump_fds(pTHX_ char* s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_FDS \
+ assert(s)
+
+#endif
+PERL_CALLCONV void Perl_dump_form(pTHX_ const GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_FORM \
+ assert(gv)
+
+PERL_CALLCONV void Perl_gv_dump(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_DUMP \
+ assert(gv)
+
+PERL_CALLCONV void Perl_op_dump(pTHX_ const OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_DUMP \
+ assert(o)
+
+PERL_CALLCONV void Perl_pmop_dump(pTHX_ PMOP* pm);
+PERL_CALLCONV void Perl_dump_packsubs(pTHX_ const HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_PACKSUBS \
+ assert(stash)
+
+PERL_CALLCONV void Perl_dump_sub(pTHX_ const GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_SUB \
+ assert(gv)
+
+PERL_CALLCONV void Perl_fbm_compile(pTHX_ SV* sv, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FBM_COMPILE \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_fbm_instr(pTHX_ unsigned char* big, unsigned char* bigend, SV* littlestr, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_FBM_INSTR \
+ assert(big); assert(bigend); assert(littlestr)
+
+PERL_CALLCONV char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FIND_SCRIPT \
+ assert(scriptname)
+
+PERL_CALLCONV OP* Perl_force_list(pTHX_ OP* arg);
+PERL_CALLCONV OP* Perl_fold_constants(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FOLD_CONSTANTS \
+ assert(o)
+
+PERL_CALLCONV char* Perl_form(pTHX_ const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_1,pTHX_2)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORM \
+ assert(pat)
+
+PERL_CALLCONV char* Perl_vform(pTHX_ const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VFORM \
+ assert(pat)
+
+PERL_CALLCONV void Perl_free_tmps(pTHX);
+PERL_CALLCONV OP* Perl_gen_constant_list(pTHX_ OP* o);
+#if !defined(HAS_GETENV_LEN)
+PERL_CALLCONV char* Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GETENV_LEN \
+ assert(env_elem); assert(len)
+
+#endif
+PERL_CALLCONV void Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GET_DB_SUB \
+ assert(cv)
+
+PERL_CALLCONV void Perl_gp_free(pTHX_ GV* gv);
+PERL_CALLCONV GP* Perl_gp_ref(pTHX_ GP* gp);
+PERL_CALLCONV GV* Perl_gv_AVadd(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_AVADD \
+ assert(gv)
+
+PERL_CALLCONV GV* Perl_gv_HVadd(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_HVADD \
+ assert(gv)
+
+PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_IOADD \
+ assert(gv)
+
+PERL_CALLCONV GV* Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_AUTOLOAD4 \
+ assert(name)
+
+PERL_CALLCONV void Perl_gv_check(pTHX_ const HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_CHECK \
+ assert(stash)
+
+PERL_CALLCONV void Perl_gv_efullname(pTHX_ SV* sv, const GV* gv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_EFULLNAME \
+ assert(sv); assert(gv)
+
+/* PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV* sv, const GV* gv, const char* prefix)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_GV_EFULLNAME3 \
+ assert(sv); assert(gv)
+
+PERL_CALLCONV void Perl_gv_efullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_EFULLNAME4 \
+ assert(sv); assert(gv)
+
+PERL_CALLCONV GV* Perl_gv_fetchfile(pTHX_ const char* name)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_FETCHFILE \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD \
+ assert(name)
+
+/* PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name, I32 autoload)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_FETCHPV \
+ assert(nambeg)
+
+PERL_CALLCONV void Perl_gv_fullname(pTHX_ SV* sv, const GV* gv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FULLNAME \
+ assert(sv); assert(gv)
+
+/* PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV* sv, const GV* gv, const char* prefix)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_GV_FULLNAME3 \
+ assert(sv); assert(gv)
+
+PERL_CALLCONV void Perl_gv_fullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FULLNAME4 \
+ assert(sv); assert(gv)
+
+PERL_CALLCONV GP * Perl_newGP(pTHX_ GV *const gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWGP \
+ assert(gv)
+
+PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GV_INIT \
+ assert(gv); assert(name)
+
+PERL_CALLCONV void Perl_gv_name_set(pTHX_ GV* gv, const char *name, U32 len, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_NAME_SET \
+ assert(gv); assert(name)
+
+PERL_CALLCONV HV* Perl_gv_stashpv(pTHX_ const char* name, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_STASHPV \
+ assert(name)
+
+PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_STASHPVN \
+ assert(name)
+
+PERL_CALLCONV HV* Perl_gv_stashsv(pTHX_ SV* sv, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_STASHSV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_hv_clear(pTHX_ HV* hv);
+PERL_CALLCONV HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv);
+PERL_CALLCONV void Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_DELAYFREE_ENT \
+ assert(hv)
+
+/* PERL_CALLCONV SV* Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_HV_DELETE \
+ assert(key)
+
+/* PERL_CALLCONV SV* Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_HV_DELETE_ENT \
+ assert(keysv)
+
+/* PERL_CALLCONV bool Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_HV_EXISTS \
+ assert(key)
+
+/* PERL_CALLCONV bool Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_HV_EXISTS_ENT \
+ assert(keysv)
+
+/* PERL_CALLCONV SV** Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_HV_FETCH \
+ assert(key)
+
+/* PERL_CALLCONV HE* Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_HV_FETCH_ENT \
+ assert(keysv)
+
+PERL_CALLCONV void* Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char* key, STRLEN klen, int flags, int action, SV *val, U32 hash);
+PERL_CALLCONV void* Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, const int action, SV *val, const U32 hash)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN \
+ assert(key)
+
+PERL_CALLCONV void Perl_hv_free_ent(pTHX_ HV *hv, HE *entryK)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_FREE_ENT \
+ assert(hv)
+
+PERL_CALLCONV I32 Perl_hv_iterinit(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_ITERINIT \
+ assert(hv)
+
+PERL_CALLCONV char* Perl_hv_iterkey(pTHX_ HE* entry, I32* retlen)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HV_ITERKEY \
+ assert(entry); assert(retlen)
+
+PERL_CALLCONV SV* Perl_hv_iterkeysv(pTHX_ HE* entry)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_ITERKEYSV \
+ assert(entry)
+
+/* PERL_CALLCONV HE* Perl_hv_iternext(pTHX_ HV *hv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_HV_ITERNEXT \
+ assert(hv)
+
+PERL_CALLCONV SV* Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_HV_ITERNEXTSV \
+ assert(hv); assert(key); assert(retlen)
+
+PERL_CALLCONV HE* Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS \
+ assert(hv)
+
+PERL_CALLCONV SV* Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HV_ITERVAL \
+ assert(hv); assert(entry)
+
+PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_KSPLIT \
+ assert(hv)
+
+/* PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_HV_MAGIC \
+ assert(hv)
+
+PERL_CALLCONV HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c);
+PERL_CALLCONV SV * Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, const char *key, STRLEN klen, int flags, U32 hash);
+PERL_CALLCONV void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he);
+PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value);
+/* PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash); */
+/* PERL_CALLCONV HE* Perl_hv_store_ent(pTHX_ HV *hv, SV *key, SV *val, U32 hash); */
+/* PERL_CALLCONV SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, int flags); */
+PERL_CALLCONV void Perl_hv_undef(pTHX_ HV *hv);
+PERL_CALLCONV I32 Perl_ibcmp(pTHX_ const char* a, const char* b, I32 len)
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_IBCMP \
+ assert(a); assert(b)
+
+PERL_CALLCONV I32 Perl_ibcmp_locale(pTHX_ const char* a, const char* b, I32 len)
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_IBCMP_LOCALE \
+ assert(a); assert(b)
+
+PERL_CALLCONV I32 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_IBCMP_UTF8 \
+ assert(s1); assert(s2)
+
+PERL_CALLCONV bool Perl_ingroup(pTHX_ Gid_t testgid, bool effective)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_init_argv_symbols(pTHX_ int argc, char **argv)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS \
+ assert(argv)
+
+PERL_CALLCONV void Perl_init_debugger(pTHX);
+PERL_CALLCONV void Perl_init_stacks(pTHX);
+PERL_CALLCONV void Perl_init_tm(pTHX_ struct tm *ptm)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INIT_TM \
+ assert(ptm)
+
+PERL_CALLCONV U32 Perl_intro_my(pTHX);
+PERL_CALLCONV char* Perl_instr(pTHX_ const char* big, const char* little)
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_INSTR \
+ assert(big); assert(little)
+
+PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IO_CLOSE \
+ assert(io)
+
+PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV bool Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_GV_MAGICAL \
+ assert(name)
+
+PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV U32 Perl_to_uni_upper_lc(pTHX_ U32 c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV U32 Perl_to_uni_title_lc(pTHX_ U32 c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV U32 Perl_to_uni_lower_lc(pTHX_ U32 c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_alnumc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_idfirst(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_alpha(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_ascii(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_space(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_cntrl(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_graph(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_digit(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_upper(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_lower(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_print(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_punct(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_xdigit(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV UV Perl_to_uni_upper(pTHX_ UV c, U8 *p, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_TO_UNI_UPPER \
+ assert(p); assert(lenp)
+
+PERL_CALLCONV UV Perl_to_uni_title(pTHX_ UV c, U8 *p, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_TO_UNI_TITLE \
+ assert(p); assert(lenp)
+
+PERL_CALLCONV UV Perl_to_uni_lower(pTHX_ UV c, U8 *p, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_TO_UNI_LOWER \
+ assert(p); assert(lenp)
+
+PERL_CALLCONV UV Perl_to_uni_fold(pTHX_ UV c, U8 *p, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_TO_UNI_FOLD \
+ assert(p); assert(lenp)
+
+PERL_CALLCONV bool Perl_is_uni_alnum_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_alnumc_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_idfirst_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_alpha_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_ascii_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_space_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_cntrl_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_graph_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_digit_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_upper_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_lower_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_print_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_punct_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_xdigit_lc(pTHX_ UV c)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV STRLEN Perl_is_utf8_char(pTHX_ const U8 *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_CHAR \
+ assert(s)
+
+PERL_CALLCONV bool Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_STRING \
+ assert(s)
+
+/* PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **p)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC \
+ assert(s)
+
+PERL_CALLCONV bool Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN \
+ assert(s)
+
+PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_ALNUM \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_alnumc(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_ALNUMC \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_idfirst(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_IDFIRST \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_idcont(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_IDCONT \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_alpha(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_ALPHA \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_ascii(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_ASCII \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_space(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_SPACE \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_cntrl(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_CNTRL \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_digit(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_DIGIT \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_graph(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_GRAPH \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_upper(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_UPPER \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_lower(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_LOWER \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_print(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_PRINT \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_punct(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_PUNCT \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_xdigit(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_XDIGIT \
+ assert(p)
+
+PERL_CALLCONV bool Perl_is_utf8_mark(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_UTF8_MARK \
+ assert(p)
+
+PERL_CALLCONV OP* Perl_jmaybe(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_JMAYBE \
+ assert(o)
+
+PERL_CALLCONV I32 Perl_keyword(pTHX_ const char *name, I32 len, bool all_keywords)
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_KEYWORD \
+ assert(name)
+
+PERL_CALLCONV void Perl_leave_scope(pTHX_ I32 base);
+PERL_CALLCONV void Perl_lex_end(pTHX);
+PERL_CALLCONV void Perl_lex_start(pTHX_ SV* line, PerlIO *rsfp, bool new_filter);
+PERL_CALLCONV void Perl_op_null(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_NULL \
+ assert(o)
+
+PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_CLEAR \
+ assert(o)
+
+PERL_CALLCONV void Perl_op_refcnt_lock(pTHX);
+PERL_CALLCONV void Perl_op_refcnt_unlock(pTHX);
+PERL_CALLCONV OP* Perl_linklist(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_LINKLIST \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_list(pTHX_ OP* o);
+PERL_CALLCONV OP* Perl_listkids(pTHX_ OP* o);
+PERL_CALLCONV void Perl_load_module(pTHX_ U32 flags, SV* name, SV* ver, ...)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_LOAD_MODULE \
+ assert(name)
+
+PERL_CALLCONV void Perl_vload_module(pTHX_ U32 flags, SV* name, SV* ver, va_list* args)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_VLOAD_MODULE \
+ assert(name)
+
+PERL_CALLCONV OP* Perl_localize(pTHX_ OP* o, I32 lex)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_LOCALIZE \
+ assert(o)
+
+PERL_CALLCONV I32 Perl_looks_like_number(pTHX_ SV* sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER \
+ assert(sv)
+
+PERL_CALLCONV UV Perl_grok_bin(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GROK_BIN \
+ assert(start); assert(len_p); assert(flags)
+
+PERL_CALLCONV UV Perl_grok_hex(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GROK_HEX \
+ assert(start); assert(len_p); assert(flags)
+
+PERL_CALLCONV int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GROK_NUMBER \
+ assert(pv)
+
+PERL_CALLCONV bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX \
+ assert(sp); assert(send)
+
+PERL_CALLCONV UV Perl_grok_oct(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GROK_OCT \
+ assert(start); assert(len_p); assert(flags)
+
+PERL_CALLCONV int Perl_magic_clearenv(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARENV \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_clear_all_env(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_clearhint(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARHINT \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_clearisa(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARISA \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_clearpack(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARPACK \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_clearsig(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARSIG \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_existspack(pTHX_ SV* sv, const MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_EXISTSPACK \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_freeregexp(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_FREEREGEXP \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_freeovrld(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_FREEOVRLD \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_get(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GET \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getarylen(pTHX_ SV* sv, const MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETARYLEN \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETDEFELEM \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getnkeys(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETNKEYS \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getpack(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETPACK \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getpos(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETPOS \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getsig(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETSIG \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getsubstr(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETSUBSTR \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_gettaint(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETTAINT \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getuvar(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETUVAR \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_getvec(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETVEC \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV U32 Perl_magic_len(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_LEN \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MAGIC_NEXTPACK \
+ assert(sv); assert(mg); assert(key)
+
+PERL_CALLCONV U32 Perl_magic_regdata_cnt(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_regdatum_get(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__noreturn__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_set(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SET \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setamagic(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETAMAGIC \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setarylen(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETARYLEN \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_freearylen_p(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P \
+ assert(sv); assert(mg)
+
+#ifndef NO_MATHOMS
+PERL_CALLCONV int Perl_magic_setbm(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETBM \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setfm(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETFM \
+ assert(sv); assert(mg)
+
+#endif
+PERL_CALLCONV int Perl_magic_setdbline(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETDBLINE \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setdefelem(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETDEFELEM \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setenv(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETENV \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_sethint(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETHINT \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setisa(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETISA \
+ assert(sv); assert(mg)
+
+#ifndef NO_MATHOMS
+PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETGLOB \
+ assert(sv); assert(mg)
+
+#endif
+PERL_CALLCONV int Perl_magic_setmglob(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETMGLOB \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setnkeys(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETNKEYS \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setpack(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETPACK \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setpos(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETPOS \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setregexp(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETREGEXP \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setsig(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETSIG \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setsubstr(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETSUBSTR \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_settaint(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETTAINT \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setuvar(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETUVAR \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setvec(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETVEC \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_setutf8(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETUTF8 \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_set_all_env(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV U32 Perl_magic_sizepack(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SIZEPACK \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int Perl_magic_wipepack(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_WIPEPACK \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV void Perl_magicname(pTHX_ const char* sym, const char* name, I32 namlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MAGICNAME \
+ assert(sym)
+
+PERL_CALLCONV void Perl_markstack_grow(pTHX);
+#if defined(USE_LOCALE_COLLATE)
+PERL_CALLCONV int Perl_magic_setcollxfrm(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV char* Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MEM_COLLXFRM \
+ assert(s); assert(xlen)
+
+#endif
+PERL_CALLCONV SV* Perl_mess(pTHX_ const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_1,pTHX_2)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MESS \
+ assert(pat)
+
+PERL_CALLCONV SV* Perl_vmess(pTHX_ const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VMESS \
+ assert(pat)
+
+PERL_CALLCONV void Perl_qerror(pTHX_ SV* err)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_QERROR \
+ assert(err)
+
+PERL_CALLCONV void Perl_sortsv(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t cmp)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SORTSV \
+ assert(cmp)
+
+PERL_CALLCONV void Perl_sortsv_flags(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t cmp, U32 flags)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SORTSV_FLAGS \
+ assert(cmp)
+
+PERL_CALLCONV int Perl_mg_clear(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_CLEAR \
+ assert(sv)
+
+PERL_CALLCONV int Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MG_COPY \
+ assert(sv); assert(nsv)
+
+PERL_CALLCONV void Perl_mg_localize(pTHX_ SV* sv, SV* nsv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MG_LOCALIZE \
+ assert(sv); assert(nsv)
+
+PERL_CALLCONV MAGIC* Perl_mg_find(pTHX_ const SV* sv, int type)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV int Perl_mg_free(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_FREE \
+ assert(sv)
+
+PERL_CALLCONV int Perl_mg_get(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_GET \
+ assert(sv)
+
+PERL_CALLCONV U32 Perl_mg_length(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_LENGTH \
+ assert(sv)
+
+PERL_CALLCONV void Perl_mg_magical(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_MAGICAL \
+ assert(sv)
+
+PERL_CALLCONV int Perl_mg_set(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_SET \
+ assert(sv)
+
+PERL_CALLCONV I32 Perl_mg_size(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_SIZE \
+ assert(sv)
+
+PERL_CALLCONV void Perl_mini_mktime(pTHX_ struct tm *ptm)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MINI_MKTIME \
+ assert(ptm)
+
+PERL_CALLCONV OP* Perl_mod(pTHX_ OP* o, I32 type);
+PERL_CALLCONV int Perl_mode_from_discipline(pTHX_ SV* discp);
+PERL_CALLCONV const char* Perl_moreswitches(pTHX_ const char* s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MORESWITCHES \
+ assert(s)
+
+PERL_CALLCONV OP* Perl_my(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MY \
+ assert(o)
+
+PERL_CALLCONV NV Perl_my_atof(pTHX_ const char *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MY_ATOF \
+ assert(s)
+
+#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
+PERL_CALLCONV char* Perl_my_bcopy(const char* from, char* to, I32 len)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_MY_BCOPY \
+ assert(from); assert(to)
+
+#endif
+#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
+PERL_CALLCONV char* Perl_my_bzero(char* loc, I32 len)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_MY_BZERO \
+ assert(loc)
+
+#endif
+PERL_CALLCONV void Perl_my_exit(pTHX_ U32 status)
+ __attribute__noreturn__;
+
+PERL_CALLCONV void Perl_my_failure_exit(pTHX)
+ __attribute__noreturn__;
+
+PERL_CALLCONV I32 Perl_my_fflush_all(pTHX);
+PERL_CALLCONV Pid_t Perl_my_fork(void);
+PERL_CALLCONV void Perl_atfork_lock(void);
+PERL_CALLCONV void Perl_atfork_unlock(void);
+PERL_CALLCONV I32 Perl_my_lstat(pTHX);
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
+PERL_CALLCONV I32 Perl_my_memcmp(const char* s1, const char* s2, I32 len)
+ __attribute__pure__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_MY_MEMCMP \
+ assert(s1); assert(s2)
+
+#endif
+#if !defined(HAS_MEMSET)
+PERL_CALLCONV void* Perl_my_memset(char* loc, I32 ch, I32 len)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_MY_MEMSET \
+ assert(loc)
+
+#endif
+PERL_CALLCONV I32 Perl_my_pclose(pTHX_ PerlIO* ptr);
+PERL_CALLCONV PerlIO* Perl_my_popen(pTHX_ const char* cmd, const char* mode)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MY_POPEN \
+ assert(cmd); assert(mode)
+
+PERL_CALLCONV PerlIO* Perl_my_popen_list(pTHX_ char* mode, int n, SV ** args)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MY_POPEN_LIST \
+ assert(mode); assert(args)
+
+PERL_CALLCONV void Perl_my_setenv(pTHX_ const char* nam, const char* val);
+PERL_CALLCONV I32 Perl_my_stat(pTHX);
+PERL_CALLCONV char * Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MY_STRFTIME \
+ assert(fmt)
+
+#if defined(MYSWAP)
+PERL_CALLCONV short Perl_my_swap(pTHX_ short s)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV long Perl_my_htonl(pTHX_ long l)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV long Perl_my_ntohl(pTHX_ long l)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+#endif
+PERL_CALLCONV void Perl_my_unexec(pTHX);
+PERL_CALLCONV OP* Perl_newANONLIST(pTHX_ OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newANONHASH(pTHX_ OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newANONSUB(pTHX_ I32 floor, OP* proto, OP* block);
+PERL_CALLCONV OP* Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* right)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newCONDOP(pTHX_ I32 flags, OP* first, OP* trueop, OP* falseop)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWCONDOP \
+ assert(first)
+
+PERL_CALLCONV CV* Perl_newCONSTSUB(pTHX_ HV* stash, const char* name, SV* sv);
+#ifdef PERL_MAD
+PERL_CALLCONV OP* Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block);
+#else
+PERL_CALLCONV void Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block);
+#endif
+PERL_CALLCONV OP* Perl_newFOROP(pTHX_ I32 flags, char* label, line_t forline, OP* sv, OP* expr, OP* block, OP* cont)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_NEWFOROP \
+ assert(expr)
+
+PERL_CALLCONV OP* Perl_newGIVENOP(pTHX_ OP* cond, OP* block, PADOFFSET defsv_off)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWGIVENOP \
+ assert(cond); assert(block)
+
+PERL_CALLCONV OP* Perl_newLOGOP(pTHX_ I32 optype, I32 flags, OP *first, OP *other)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_NEWLOGOP \
+ assert(first); assert(other)
+
+PERL_CALLCONV OP* Perl_newLOOPEX(pTHX_ I32 type, OP* label)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWLOOPEX \
+ assert(label)
+
+PERL_CALLCONV OP* Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP* expr, OP* block)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newNULLLIST(pTHX)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newOP(pTHX_ I32 optype, I32 flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_newPROG(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWPROG \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_newRANGE(pTHX_ I32 flags, OP* left, OP* right)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_NEWRANGE \
+ assert(left); assert(right)
+
+PERL_CALLCONV OP* Perl_newSLICEOP(pTHX_ I32 flags, OP* subscript, OP* listop)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newSTATEOP(pTHX_ I32 flags, char* label, OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV CV* Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
+PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_NEWXS_FLAGS \
+ assert(subaddr); assert(filename)
+
+PERL_CALLCONV CV* Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_NEWXS \
+ assert(subaddr); assert(filename)
+
+/* PERL_CALLCONV AV* Perl_newAV(pTHX)
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV OP* Perl_newAVREF(pTHX_ OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWAVREF \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_newBINOP(pTHX_ I32 type, I32 flags, OP* first, OP* last)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newCVREF(pTHX_ I32 flags, OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newGVOP(pTHX_ I32 type, I32 flags, GV* gv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_NEWGVOP \
+ assert(gv)
+
+PERL_CALLCONV GV* Perl_newGVgen(pTHX_ const char* pack)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWGVGEN \
+ assert(pack)
+
+PERL_CALLCONV OP* Perl_newGVREF(pTHX_ I32 type, OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newHVREF(pTHX_ OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWHVREF \
+ assert(o)
+
+/* PERL_CALLCONV HV* Perl_newHV(pTHX)
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV HV* Perl_newHVhv(pTHX_ HV *hv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV IO* Perl_newIO(pTHX)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP* first, OP* last)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+#ifdef USE_ITHREADS
+PERL_CALLCONV OP* Perl_newPADOP(pTHX_ I32 type, I32 flags, SV* sv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_NEWPADOP \
+ assert(sv)
+
+#endif
+PERL_CALLCONV OP* Perl_newPMOP(pTHX_ I32 type, I32 flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newPVOP(pTHX_ I32 type, I32 flags, char* pv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newRV(pTHX_ SV* sv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWRV \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_newRV_noinc(pTHX_ SV* sv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWRV_NOINC \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_newSV(pTHX_ STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newSVREF(pTHX_ OP* o)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWSVREF \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_newSVOP(pTHX_ I32 type, I32 flags, SV* sv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_NEWSVOP \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_newSViv(pTHX_ IV i)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVuv(pTHX_ UV u)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVnv(pTHX_ NV n)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVpv(pTHX_ const char* s, STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVpvn(pTHX_ const char* s, STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVpvn_flags(pTHX_ const char* s, STRLEN len, U32 flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVhek(pTHX_ const HEK *hek)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVpvn_share(pTHX_ const char* s, I32 len, U32 hash)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSVpvf(pTHX_ const char* pat, ...)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__format__(__printf__,pTHX_1,pTHX_2)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWSVPVF \
+ assert(pat)
+
+PERL_CALLCONV SV* Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VNEWSVPVF \
+ assert(pat)
+
+PERL_CALLCONV SV* Perl_newSVrv(pTHX_ SV* rv, const char* classname)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWSVRV \
+ assert(rv)
+
+PERL_CALLCONV SV* Perl_newSVsv(pTHX_ SV* old)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_newSV_type(pTHX_ svtype type)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV OP* Perl_newWHENOP(pTHX_ OP* cond, OP* block)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWWHENOP \
+ assert(block)
+
+PERL_CALLCONV OP* Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont, I32 has_my)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV char* Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SCAN_VSTRING \
+ assert(s); assert(e); assert(sv)
+
+PERL_CALLCONV const char* Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SCAN_VERSION \
+ assert(s); assert(rv)
+
+PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEW_VERSION \
+ assert(ver)
+
+PERL_CALLCONV SV* Perl_upg_version(pTHX_ SV *ver, bool qv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UPG_VERSION \
+ assert(ver)
+
+PERL_CALLCONV bool Perl_vverify(pTHX_ SV *vs)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VVERIFY \
+ assert(vs)
+
+PERL_CALLCONV SV* Perl_vnumify(pTHX_ SV *vs)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VNUMIFY \
+ assert(vs)
+
+PERL_CALLCONV SV* Perl_vnormal(pTHX_ SV *vs)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VNORMAL \
+ assert(vs)
+
+PERL_CALLCONV SV* Perl_vstringify(pTHX_ SV *vs)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VSTRINGIFY \
+ assert(vs)
+
+PERL_CALLCONV int Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_VCMP \
+ assert(lhv); assert(rhv)
+
+PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEXTARGV \
+ assert(gv)
+
+PERL_CALLCONV char* Perl_ninstr(pTHX_ const char* big, const char* bigend, const char* little, const char* lend)
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_NINSTR \
+ assert(big); assert(bigend); assert(little); assert(lend)
+
+PERL_CALLCONV OP* Perl_oopsCV(pTHX_ OP* o)
+ __attribute__noreturn__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OOPSCV \
+ assert(o)
+
+PERL_CALLCONV void Perl_op_free(pTHX_ OP* arg);
+#ifdef PERL_MAD
+PERL_CALLCONV OP* Perl_package(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PACKAGE \
+ assert(o)
+
+#else
+PERL_CALLCONV void Perl_package(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PACKAGE \
+ assert(o)
+
+#endif
+PERL_CALLCONV PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype);
+PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_ALLOCMY \
+ assert(name)
+
+PERL_CALLCONV PADOFFSET Perl_pad_findmy(pTHX_ const char* name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_FINDMY \
+ assert(name)
+
+PERL_CALLCONV PADOFFSET Perl_find_rundefsvoffset(pTHX);
+PERL_CALLCONV OP* Perl_oopsAV(pTHX_ OP* o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OOPSAV \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_oopsHV(pTHX_ OP* o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OOPSHV \
+ assert(o)
+
+PERL_CALLCONV void Perl_pad_leavemy(pTHX);
+PERL_CALLCONV SV* Perl_pad_sv(pTHX_ PADOFFSET po);
+PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po);
+PERL_CALLCONV void Perl_pad_reset(pTHX);
+PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust);
+PERL_CALLCONV void Perl_peep(pTHX_ OP* o);
+PERL_CALLCONV PerlIO* Perl_start_glob(pTHX_ SV *tmpglob, IO *io)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_START_GLOB \
+ assert(tmpglob); assert(io)
+
+#if defined(USE_REENTRANT_API)
+PERL_CALLCONV void Perl_reentrant_size(pTHX);
+PERL_CALLCONV void Perl_reentrant_init(pTHX);
+PERL_CALLCONV void Perl_reentrant_free(pTHX);
+PERL_CALLCONV void* Perl_reentrant_retry(const char *f, ...)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_REENTRANT_RETRY \
+ assert(f)
+
+#endif
+PERL_CALLCONV void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr);
+PERL_CALLCONV I32 Perl_call_argv(pTHX_ const char* sub_name, I32 flags, char** argv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CALL_ARGV \
+ assert(sub_name); assert(argv)
+
+PERL_CALLCONV I32 Perl_call_method(pTHX_ const char* methname, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CALL_METHOD \
+ assert(methname)
+
+PERL_CALLCONV I32 Perl_call_pv(pTHX_ const char* sub_name, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CALL_PV \
+ assert(sub_name)
+
+PERL_CALLCONV I32 Perl_call_sv(pTHX_ SV* sv, VOL I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CALL_SV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_despatch_signals(pTHX);
+PERL_CALLCONV OP * Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DOREF \
+ assert(o)
+
+PERL_CALLCONV SV* Perl_eval_pv(pTHX_ const char* p, I32 croak_on_error)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_EVAL_PV \
+ assert(p)
+
+PERL_CALLCONV I32 Perl_eval_sv(pTHX_ SV* sv, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_EVAL_SV \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_get_sv(pTHX_ const char *name, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_SV \
+ assert(name)
+
+PERL_CALLCONV AV* Perl_get_av(pTHX_ const char *name, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_AV \
+ assert(name)
+
+PERL_CALLCONV HV* Perl_get_hv(pTHX_ const char *name, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_HV \
+ assert(name)
+
+PERL_CALLCONV CV* Perl_get_cv(pTHX_ const char* name, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_CV \
+ assert(name)
+
+PERL_CALLCONV CV* Perl_get_cvn_flags(pTHX_ const char* name, STRLEN len, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_CVN_FLAGS \
+ assert(name)
+
+PERL_CALLCONV int Perl_init_i18nl10n(pTHX_ int printwarn);
+PERL_CALLCONV int Perl_init_i18nl14n(pTHX_ int printwarn);
+PERL_CALLCONV void Perl_new_collate(pTHX_ const char* newcoll);
+PERL_CALLCONV void Perl_new_ctype(pTHX_ const char* newctype)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEW_CTYPE \
+ assert(newctype)
+
+PERL_CALLCONV void Perl_new_numeric(pTHX_ const char* newcoll);
+PERL_CALLCONV void Perl_set_numeric_local(pTHX);
+PERL_CALLCONV void Perl_set_numeric_radix(pTHX);
+PERL_CALLCONV void Perl_set_numeric_standard(pTHX);
+PERL_CALLCONV void Perl_require_pv(pTHX_ const char* pv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REQUIRE_PV \
+ assert(pv)
+
+PERL_CALLCONV void Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5)
+ __attribute__nonnull__(pTHX_6);
+#define PERL_ARGS_ASSERT_PACK_CAT \
+ assert(cat); assert(pat); assert(patend); assert(beglist); assert(endlist); assert(next_in_list)
+
+PERL_CALLCONV void Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_PACKLIST \
+ assert(cat); assert(pat); assert(patend); assert(beglist); assert(endlist)
+
+#ifdef PERL_USES_PL_PIDSTATUS
+PERL_CALLCONV void Perl_pidgone(pTHX_ Pid_t pid, int status);
+#endif
+PERL_CALLCONV void Perl_pmflag(pTHX_ U32* pmfl, int ch)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PMFLAG \
+ assert(pmfl)
+
+PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PMRUNTIME \
+ assert(o); assert(expr)
+
+PERL_CALLCONV OP* Perl_pmtrans(pTHX_ OP* o, OP* expr, OP* repl)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_PMTRANS \
+ assert(o); assert(expr); assert(repl)
+
+PERL_CALLCONV void Perl_pop_scope(pTHX);
+PERL_CALLCONV OP* Perl_prepend_elem(pTHX_ I32 optype, OP* head, OP* tail);
+PERL_CALLCONV void Perl_push_scope(pTHX);
+/* PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type); */
+PERL_CALLCONV OP* Perl_refkids(pTHX_ OP* o, I32 type);
+PERL_CALLCONV void Perl_regdump(pTHX_ const regexp* r)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGDUMP \
+ assert(r)
+
+PERL_CALLCONV void Perl_regdump(pTHX_ const regexp* r)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGDUMP \
+ assert(r)
+
+PERL_CALLCONV SV* Perl_regclass_swash(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp, SV **altsvp)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGCLASS_SWASH \
+ assert(node)
+
+PERL_CALLCONV I32 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_6);
+#define PERL_ARGS_ASSERT_PREGEXEC \
+ assert(prog); assert(stringarg); assert(strend); assert(strbeg); assert(screamer)
+
+PERL_CALLCONV void Perl_pregfree(pTHX_ REGEXP* r);
+PERL_CALLCONV REGEXP* Perl_reg_temp_copy(pTHX_ REGEXP* r)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_TEMP_COPY \
+ assert(r)
+
+PERL_CALLCONV void Perl_regfree_internal(pTHX_ REGEXP *const r)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGFREE_INTERNAL \
+ assert(r)
+
+PERL_CALLCONV char * Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_STRINGIFY \
+ assert(mg)
+
+#if defined(USE_ITHREADS)
+PERL_CALLCONV void* Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS* param)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGDUPE_INTERNAL \
+ assert(r); assert(param)
+
+#endif
+PERL_CALLCONV REGEXP* Perl_pregcomp(pTHX_ const SV * const pattern, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PREGCOMP \
+ assert(pattern)
+
+PERL_CALLCONV REGEXP* Perl_re_compile(pTHX_ const SV * const pattern, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_RE_COMPILE \
+ assert(pattern)
+
+PERL_CALLCONV char* Perl_re_intuit_start(pTHX_ REGEXP * const prog, SV* sv, char* strpos, char* strend, const U32 flags, re_scream_pos_data *data)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_RE_INTUIT_START \
+ assert(prog); assert(strpos); assert(strend)
+
+PERL_CALLCONV SV* Perl_re_intuit_string(pTHX_ REGEXP *const prog)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_RE_INTUIT_STRING \
+ assert(prog)
+
+PERL_CALLCONV I32 Perl_regexec_flags(pTHX_ REGEXP *const prog, char *stringarg, char *strend, char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_6);
+#define PERL_ARGS_ASSERT_REGEXEC_FLAGS \
+ assert(prog); assert(stringarg); assert(strend); assert(strbeg); assert(sv)
+
+PERL_CALLCONV regnode* Perl_regnext(pTHX_ regnode* p)
+ __attribute__warn_unused_result__;
+
+
+PERL_CALLCONV SV* Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF \
+ assert(rx)
+
+PERL_CALLCONV SV* Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER \
+ assert(rx)
+
+PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH \
+ assert(rx); assert(namesv)
+
+PERL_CALLCONV bool Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS \
+ assert(rx); assert(key)
+
+PERL_CALLCONV SV* Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY \
+ assert(rx)
+
+PERL_CALLCONV SV* Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY \
+ assert(rx)
+
+PERL_CALLCONV SV* Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR \
+ assert(rx)
+
+PERL_CALLCONV SV* Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL \
+ assert(rx)
+
+
+PERL_CALLCONV void Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH \
+ assert(rx)
+
+PERL_CALLCONV void Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren, SV const * const value)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE \
+ assert(rx)
+
+PERL_CALLCONV I32 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv, const I32 paren)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH \
+ assert(rx); assert(sv)
+
+
+PERL_CALLCONV SV* Perl_reg_qr_package(pTHX_ REGEXP * const rx)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_QR_PACKAGE \
+ assert(rx)
+
+
+PERL_CALLCONV void Perl_regprop(pTHX_ const regexp *prog, SV* sv, const regnode* o)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_REGPROP \
+ assert(sv); assert(o)
+
+PERL_CALLCONV void Perl_repeatcpy(pTHX_ char* to, const char* from, I32 len, I32 count)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REPEATCPY \
+ assert(to); assert(from)
+
+PERL_CALLCONV char* Perl_rninstr(pTHX_ const char* big, const char* bigend, const char* little, const char* lend)
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_RNINSTR \
+ assert(big); assert(bigend); assert(little); assert(lend)
+
+PERL_CALLCONV Sighandler_t Perl_rsignal(pTHX_ int i, Sighandler_t t);
+PERL_CALLCONV int Perl_rsignal_restore(pTHX_ int i, Sigsave_t* t);
+PERL_CALLCONV int Perl_rsignal_save(pTHX_ int i, Sighandler_t t1, Sigsave_t* save)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_RSIGNAL_SAVE \
+ assert(save)
+
+PERL_CALLCONV Sighandler_t Perl_rsignal_state(pTHX_ int i);
+PERL_CALLCONV void Perl_rxres_free(pTHX_ void** rsp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_RXRES_FREE \
+ assert(rsp)
+
+PERL_CALLCONV void Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_RXRES_RESTORE \
+ assert(rsp); assert(rx)
+
+PERL_CALLCONV void Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_RXRES_SAVE \
+ assert(rsp); assert(rx)
+
+#if !defined(HAS_RENAME)
+PERL_CALLCONV I32 Perl_same_dirent(pTHX_ const char* a, const char* b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SAME_DIRENT \
+ assert(a); assert(b)
+
+#endif
+PERL_CALLCONV char* Perl_savepv(pTHX_ const char* pv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV char* Perl_savepvn(pTHX_ const char* pv, I32 len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV char* Perl_savesharedpv(pTHX_ const char* pv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV char* Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVESHAREDPVN \
+ assert(pv)
+
+PERL_CALLCONV char* Perl_savesvpv(pTHX_ SV* sv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVESVPV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_savestack_grow(pTHX);
+PERL_CALLCONV void Perl_savestack_grow_cnt(pTHX_ I32 need);
+PERL_CALLCONV void Perl_save_aelem(pTHX_ AV* av, I32 idx, SV **sptr)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SAVE_AELEM \
+ assert(av); assert(sptr)
+
+PERL_CALLCONV I32 Perl_save_alloc(pTHX_ I32 size, I32 pad);
+PERL_CALLCONV void Perl_save_aptr(pTHX_ AV** aptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_APTR \
+ assert(aptr)
+
+PERL_CALLCONV AV* Perl_save_ary(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_ARY \
+ assert(gv)
+
+PERL_CALLCONV void Perl_save_bool(pTHX_ bool* boolp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_BOOL \
+ assert(boolp)
+
+PERL_CALLCONV void Perl_save_clearsv(pTHX_ SV** svp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_CLEARSV \
+ assert(svp)
+
+PERL_CALLCONV void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SAVE_DELETE \
+ assert(hv); assert(key)
+
+PERL_CALLCONV void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SAVE_DESTRUCTOR \
+ assert(p)
+
+PERL_CALLCONV void Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p);
+/* PERL_CALLCONV void Perl_save_freesv(pTHX_ SV* sv); */
+/* PERL_CALLCONV void Perl_save_freeop(pTHX_ OP* o); */
+/* PERL_CALLCONV void Perl_save_freepv(pTHX_ char* pv); */
+PERL_CALLCONV void Perl_save_generic_svref(pTHX_ SV** sptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF \
+ assert(sptr)
+
+PERL_CALLCONV void Perl_save_generic_pvref(pTHX_ char** str)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF \
+ assert(str)
+
+PERL_CALLCONV void Perl_save_shared_pvref(pTHX_ char** str)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_SHARED_PVREF \
+ assert(str)
+
+PERL_CALLCONV void Perl_save_gp(pTHX_ GV* gv, I32 empty)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_GP \
+ assert(gv)
+
+PERL_CALLCONV HV* Perl_save_hash(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_HASH \
+ assert(gv)
+
+PERL_CALLCONV void Perl_save_hints(pTHX);
+PERL_CALLCONV void Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SAVE_HELEM \
+ assert(hv); assert(key); assert(sptr)
+
+PERL_CALLCONV void Perl_save_hptr(pTHX_ HV** hptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_HPTR \
+ assert(hptr)
+
+PERL_CALLCONV void Perl_save_I16(pTHX_ I16* intp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_I16 \
+ assert(intp)
+
+PERL_CALLCONV void Perl_save_I32(pTHX_ I32* intp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_I32 \
+ assert(intp)
+
+PERL_CALLCONV void Perl_save_I8(pTHX_ I8* bytep)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_I8 \
+ assert(bytep)
+
+PERL_CALLCONV void Perl_save_int(pTHX_ int* intp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_INT \
+ assert(intp)
+
+PERL_CALLCONV void Perl_save_item(pTHX_ SV* item)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_ITEM \
+ assert(item)
+
+PERL_CALLCONV void Perl_save_iv(pTHX_ IV *ivp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_IV \
+ assert(ivp)
+
+PERL_CALLCONV void Perl_save_list(pTHX_ SV** sarg, I32 maxsarg)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_LIST \
+ assert(sarg)
+
+PERL_CALLCONV void Perl_save_long(pTHX_ long* longp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_LONG \
+ assert(longp)
+
+/* PERL_CALLCONV void Perl_save_mortalizesv(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SAVE_MORTALIZESV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_save_nogv(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_NOGV \
+ assert(gv)
+
+/* PERL_CALLCONV void Perl_save_op(pTHX); */
+PERL_CALLCONV SV* Perl_save_scalar(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_SCALAR \
+ assert(gv)
+
+PERL_CALLCONV void Perl_save_pptr(pTHX_ char** pptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_PPTR \
+ assert(pptr)
+
+PERL_CALLCONV void Perl_save_vptr(pTHX_ void *ptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_VPTR \
+ assert(ptr)
+
+PERL_CALLCONV void Perl_save_re_context(pTHX);
+PERL_CALLCONV void Perl_save_padsv(pTHX_ PADOFFSET off);
+PERL_CALLCONV void Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off);
+PERL_CALLCONV void Perl_save_sptr(pTHX_ SV** sptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_SPTR \
+ assert(sptr)
+
+PERL_CALLCONV SV* Perl_save_svref(pTHX_ SV** sptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_SVREF \
+ assert(sptr)
+
+PERL_CALLCONV void Perl_save_pushptr(pTHX_ void *const ptr, const int type);
+PERL_CALLCONV void Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type);
+PERL_CALLCONV void Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type);
+#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
+STATIC void S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, const int type);
+#endif
+PERL_CALLCONV OP* Perl_sawparens(pTHX_ OP* o);
+PERL_CALLCONV OP* Perl_scalar(pTHX_ OP* o);
+PERL_CALLCONV OP* Perl_scalarkids(pTHX_ OP* o);
+PERL_CALLCONV OP* Perl_scalarseq(pTHX_ OP* o);
+PERL_CALLCONV OP* Perl_scalarvoid(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCALARVOID \
+ assert(o)
+
+PERL_CALLCONV NV Perl_scan_bin(pTHX_ const char* start, STRLEN len, STRLEN* retlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SCAN_BIN \
+ assert(start); assert(retlen)
+
+PERL_CALLCONV NV Perl_scan_hex(pTHX_ const char* start, STRLEN len, STRLEN* retlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SCAN_HEX \
+ assert(start); assert(retlen)
+
+PERL_CALLCONV char* Perl_scan_num(pTHX_ const char* s, YYSTYPE *lvalp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SCAN_NUM \
+ assert(s); assert(lvalp)
+
+PERL_CALLCONV NV Perl_scan_oct(pTHX_ const char* start, STRLEN len, STRLEN* retlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SCAN_OCT \
+ assert(start); assert(retlen)
+
+PERL_CALLCONV OP* Perl_scope(pTHX_ OP* o);
+PERL_CALLCONV char* Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_SCREAMINSTR \
+ assert(bigstr); assert(littlestr); assert(old_posp)
+
+#if !defined(VMS)
+PERL_CALLCONV I32 Perl_setenv_getix(pTHX_ const char* nam)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SETENV_GETIX \
+ assert(nam)
+
+#endif
+PERL_CALLCONV void Perl_setdefout(pTHX_ GV* gv);
+PERL_CALLCONV HEK* Perl_share_hek(pTHX_ const char* str, I32 len, U32 hash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SHARE_HEK \
+ assert(str)
+
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+PERL_CALLCONV Signal_t Perl_sighandler(int sig, siginfo_t *info, void *uap);
+PERL_CALLCONV Signal_t Perl_csighandler(int sig, siginfo_t *info, void *uap);
+#else
+PERL_CALLCONV Signal_t Perl_sighandler(int sig);
+PERL_CALLCONV Signal_t Perl_csighandler(int sig);
+#endif
+PERL_CALLCONV SV** Perl_stack_grow(pTHX_ SV** sp, SV** p, int n)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_STACK_GROW \
+ assert(sp); assert(p)
+
+PERL_CALLCONV I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags);
+PERL_CALLCONV void Perl_sub_crush_depth(pTHX_ CV* cv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH \
+ assert(cv)
+
+PERL_CALLCONV bool Perl_sv_2bool(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2BOOL \
+ assert(sv)
+
+PERL_CALLCONV CV* Perl_sv_2cv(pTHX_ SV* sv, HV** st, GV** gvp, I32 lref)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SV_2CV \
+ assert(st); assert(gvp)
+
+PERL_CALLCONV IO* Perl_sv_2io(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2IO \
+ assert(sv)
+
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+STATIC bool S_glob_2number(pTHX_ GV* const gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GLOB_2NUMBER \
+ assert(gv)
+
+STATIC char* S_glob_2pv(pTHX_ GV* const gv, STRLEN * const len)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GLOB_2PV \
+ assert(gv)
+
+#endif
+/* PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV* sv); */
+PERL_CALLCONV IV Perl_sv_2iv_flags(pTHX_ SV* sv, I32 flags);
+PERL_CALLCONV SV* Perl_sv_2mortal(pTHX_ SV* sv);
+PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV* sv);
+PERL_CALLCONV SV* Perl_sv_2num(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2NUM \
+ assert(sv)
+
+/* PERL_CALLCONV char* Perl_sv_2pv(pTHX_ SV* sv, STRLEN* lp); */
+PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
+PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV* sv, STRLEN* lp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2PVUTF8 \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV* sv, STRLEN* lp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2PVBYTE \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_sv_pvn_nomg(pTHX_ SV* sv, STRLEN* lp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_PVN_NOMG \
+ assert(sv)
+
+/* PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV* sv); */
+PERL_CALLCONV UV Perl_sv_2uv_flags(pTHX_ SV* sv, I32 flags);
+PERL_CALLCONV IV Perl_sv_iv(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_IV \
+ assert(sv)
+
+PERL_CALLCONV UV Perl_sv_uv(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UV \
+ assert(sv)
+
+PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_NV \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_PVN \
+ assert(sv); assert(lp)
+
+PERL_CALLCONV char* Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_PVUTF8N \
+ assert(sv); assert(lp)
+
+PERL_CALLCONV char* Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_PVBYTEN \
+ assert(sv); assert(lp)
+
+PERL_CALLCONV I32 Perl_sv_true(pTHX_ SV *sv);
+PERL_CALLCONV void Perl_sv_add_arena(pTHX_ char* ptr, U32 size, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_ADD_ARENA \
+ assert(ptr)
+
+PERL_CALLCONV int Perl_sv_backoff(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_BACKOFF \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_sv_bless(pTHX_ SV* sv, HV* stash)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_BLESS \
+ assert(sv); assert(stash)
+
+PERL_CALLCONV void Perl_sv_catpvf(pTHX_ SV* sv, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_2,pTHX_3)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_CATPVF \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_vcatpvf(pTHX_ SV* sv, const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VCATPVF \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_catpv(pTHX_ SV* sv, const char* ptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_CATPV \
+ assert(sv)
+
+/* PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char *sstr, STRLEN len)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_SV_CATPVN \
+ assert(dsv); assert(sstr)
+
+/* PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_CATSV \
+ assert(dstr)
+
+PERL_CALLCONV void Perl_sv_chop(pTHX_ SV* sv, const char* ptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_CHOP \
+ assert(sv)
+
+PERL_CALLCONV I32 Perl_sv_clean_all(pTHX);
+PERL_CALLCONV void Perl_sv_clean_objs(pTHX);
+PERL_CALLCONV void Perl_sv_clear(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_CLEAR \
+ assert(sv)
+
+PERL_CALLCONV I32 Perl_sv_cmp(pTHX_ SV* sv1, SV* sv2);
+PERL_CALLCONV I32 Perl_sv_cmp_locale(pTHX_ SV* sv1, SV* sv2);
+#if defined(USE_LOCALE_COLLATE)
+PERL_CALLCONV char* Perl_sv_collxfrm(pTHX_ SV* sv, STRLEN* nxp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_COLLXFRM \
+ assert(sv); assert(nxp)
+
+#endif
+PERL_CALLCONV OP* Perl_sv_compile_2op(pTHX_ SV *sv, OP **startop, const char *code, PAD **padp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_SV_COMPILE_2OP \
+ assert(sv); assert(startop); assert(code); assert(padp)
+
+PERL_CALLCONV int Perl_getcwd_sv(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GETCWD_SV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_dec(pTHX_ SV* sv);
+PERL_CALLCONV void Perl_sv_dump(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_DUMP \
+ assert(sv)
+
+PERL_CALLCONV bool Perl_sv_derived_from(pTHX_ SV* sv, const char* name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DERIVED_FROM \
+ assert(sv); assert(name)
+
+PERL_CALLCONV bool Perl_sv_does(pTHX_ SV* sv, const char* name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DOES \
+ assert(sv); assert(name)
+
+PERL_CALLCONV I32 Perl_sv_eq(pTHX_ SV* sv1, SV* sv2);
+PERL_CALLCONV void Perl_sv_free(pTHX_ SV* sv);
+PERL_CALLCONV void Perl_sv_free2(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_FREE2 \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_free_arenas(pTHX);
+PERL_CALLCONV char* Perl_sv_gets(pTHX_ SV* sv, PerlIO* fp, I32 append)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_GETS \
+ assert(sv); assert(fp)
+
+PERL_CALLCONV char* Perl_sv_grow(pTHX_ SV* sv, STRLEN newlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_GROW \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_inc(pTHX_ SV* sv);
+/* PERL_CALLCONV void Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_4); */
+#define PERL_ARGS_ASSERT_SV_INSERT \
+ assert(bigstr); assert(little)
+
+PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_SV_INSERT_FLAGS \
+ assert(bigstr); assert(little)
+
+PERL_CALLCONV int Perl_sv_isa(pTHX_ SV* sv, const char* name)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_ISA \
+ assert(name)
+
+PERL_CALLCONV int Perl_sv_isobject(pTHX_ SV* sv);
+PERL_CALLCONV STRLEN Perl_sv_len(pTHX_ SV* sv);
+PERL_CALLCONV STRLEN Perl_sv_len_utf8(pTHX_ SV* sv);
+PERL_CALLCONV void Perl_sv_magic(pTHX_ SV* sv, SV* obj, int how, const char* name, I32 namlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_MAGIC \
+ assert(sv)
+
+PERL_CALLCONV MAGIC * Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtbl, const char* name, I32 namlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_MAGICEXT \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV* oldsv)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_sv_newmortal(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl_sv_newref(pTHX_ SV* sv);
+PERL_CALLCONV char* Perl_sv_peek(pTHX_ SV* sv);
+PERL_CALLCONV void Perl_sv_pos_u2b(pTHX_ SV* sv, I32* offsetp, I32* lenp)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_POS_U2B \
+ assert(offsetp)
+
+PERL_CALLCONV void Perl_sv_pos_b2u(pTHX_ SV* sv, I32* offsetp)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_POS_B2U \
+ assert(offsetp)
+
+/* PERL_CALLCONV char* Perl_sv_pvn_force(pTHX_ SV* sv, STRLEN* lp)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_PVN_FORCE \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_sv_pvutf8n_force(pTHX_ SV* sv, STRLEN* lp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_sv_pvbyten_force(pTHX_ SV* sv, STRLEN* lp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_sv_recode_to_utf8(pTHX_ SV* sv, SV *encoding)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8 \
+ assert(sv); assert(encoding)
+
+PERL_CALLCONV bool Perl_sv_cat_decode(pTHX_ SV* dsv, SV *encoding, SV *ssv, int *offset, char* tstr, int tlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_SV_CAT_DECODE \
+ assert(dsv); assert(encoding); assert(ssv); assert(offset); assert(tstr)
+
+PERL_CALLCONV const char* Perl_sv_reftype(pTHX_ const SV* sv, int ob)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_REFTYPE \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_replace(pTHX_ SV* sv, SV* nsv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_REPLACE \
+ assert(sv); assert(nsv)
+
+PERL_CALLCONV void Perl_sv_report_used(pTHX);
+PERL_CALLCONV void Perl_sv_reset(pTHX_ const char* s, HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_RESET \
+ assert(s)
+
+PERL_CALLCONV void Perl_sv_setpvf(pTHX_ SV* sv, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_2,pTHX_3)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_SETPVF \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_vsetpvf(pTHX_ SV* sv, const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VSETPVF \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_setiv(pTHX_ SV* sv, IV num)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETIV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setpviv(pTHX_ SV* sv, IV num)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETPVIV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setuv(pTHX_ SV* sv, UV num)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETUV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setnv(pTHX_ SV* sv, NV num)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETNV \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_sv_setref_iv(pTHX_ SV* rv, const char* classname, IV iv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETREF_IV \
+ assert(rv)
+
+PERL_CALLCONV SV* Perl_sv_setref_uv(pTHX_ SV* rv, const char* classname, UV uv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETREF_UV \
+ assert(rv)
+
+PERL_CALLCONV SV* Perl_sv_setref_nv(pTHX_ SV* rv, const char* classname, NV nv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETREF_NV \
+ assert(rv)
+
+PERL_CALLCONV SV* Perl_sv_setref_pv(pTHX_ SV* rv, const char* classname, void* pv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETREF_PV \
+ assert(rv)
+
+PERL_CALLCONV SV* Perl_sv_setref_pvn(pTHX_ SV* rv, const char* classname, const char* pv, STRLEN n)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SV_SETREF_PVN \
+ assert(rv); assert(pv)
+
+PERL_CALLCONV void Perl_sv_setpv(pTHX_ SV* sv, const char* ptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETPV \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setpvn(pTHX_ SV* sv, const char* ptr, STRLEN len)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETPVN \
+ assert(sv)
+
+/* PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_SETSV \
+ assert(dstr)
+
+/* PERL_CALLCONV void Perl_sv_taint(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_TAINT \
+ assert(sv)
+
+PERL_CALLCONV bool Perl_sv_tainted(pTHX_ SV* sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_TAINTED \
+ assert(sv)
+
+PERL_CALLCONV int Perl_sv_unmagic(pTHX_ SV* sv, int type)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UNMAGIC \
+ assert(sv)
+
+/* PERL_CALLCONV void Perl_sv_unref(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_UNREF \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UNREF_FLAGS \
+ assert(ref)
+
+PERL_CALLCONV void Perl_sv_untaint(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UNTAINT \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_upgrade(pTHX_ SV* sv, svtype new_type)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UPGRADE \
+ assert(sv)
+
+/* PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_USEPVN \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_usepvn_flags(pTHX_ SV* sv, char* ptr, STRLEN len, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_USEPVN_FLAGS \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_vcatpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VCATPVFN \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VSETPVFN \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_STR_TO_VERSION \
+ assert(sv)
+
+PERL_CALLCONV SV* Perl_swash_init(pTHX_ const char* pkg, const char* name, SV* listsv, I32 minbits, I32 none)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SWASH_INIT \
+ assert(pkg); assert(name); assert(listsv)
+
+PERL_CALLCONV UV Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SWASH_FETCH \
+ assert(swash); assert(ptr)
+
+PERL_CALLCONV void Perl_taint_env(pTHX);
+PERL_CALLCONV void Perl_taint_proper(pTHX_ const char* f, const char* s)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TAINT_PROPER \
+ assert(s)
+
+PERL_CALLCONV UV Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5)
+ __attribute__nonnull__(pTHX_6);
+#define PERL_ARGS_ASSERT_TO_UTF8_CASE \
+ assert(p); assert(ustrp); assert(swashp); assert(normal); assert(special)
+
+PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TO_UTF8_LOWER \
+ assert(p); assert(ustrp)
+
+PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TO_UTF8_UPPER \
+ assert(p); assert(ustrp)
+
+PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TO_UTF8_TITLE \
+ assert(p); assert(ustrp)
+
+PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TO_UTF8_FOLD \
+ assert(p); assert(ustrp)
+
+#if defined(UNLINK_ALL_VERSIONS)
+PERL_CALLCONV I32 Perl_unlnk(pTHX_ const char* f)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UNLNK \
+ assert(f)
+
+#endif
+PERL_CALLCONV I32 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, const char *strbeg, const char *strend, char **new_s, I32 ocnt, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_UNPACK_STR \
+ assert(pat); assert(patend); assert(s); assert(strend)
+
+PERL_CALLCONV I32 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_UNPACKSTRING \
+ assert(pat); assert(patend); assert(s); assert(strend)
+
+PERL_CALLCONV void Perl_unsharepvn(pTHX_ const char* sv, I32 len, U32 hash);
+PERL_CALLCONV void Perl_unshare_hek(pTHX_ HEK* hek);
+#ifdef PERL_MAD
+PERL_CALLCONV OP * Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop, OP* arg)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_UTILIZE \
+ assert(idop)
+
+#else
+PERL_CALLCONV void Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop, OP* arg)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_UTILIZE \
+ assert(idop)
+
+#endif
+PERL_CALLCONV U8* Perl_utf16_to_utf8(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_UTF16_TO_UTF8 \
+ assert(p); assert(d); assert(newlen)
+
+PERL_CALLCONV U8* Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED \
+ assert(p); assert(d); assert(newlen)
+
+PERL_CALLCONV STRLEN Perl_utf8_length(pTHX_ const U8* s, const U8 *e)
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_UTF8_LENGTH \
+ assert(s); assert(e)
+
+PERL_CALLCONV IV Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_UTF8_DISTANCE \
+ assert(a); assert(b)
+
+PERL_CALLCONV U8* Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UTF8_HOP \
+ assert(s)
+
+PERL_CALLCONV U8* Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_UTF8_TO_BYTES \
+ assert(s); assert(len)
+
+PERL_CALLCONV U8* Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_BYTES_FROM_UTF8 \
+ assert(s); assert(len)
+
+PERL_CALLCONV U8* Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_BYTES_TO_UTF8 \
+ assert(s); assert(len)
+
+PERL_CALLCONV UV Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UTF8_TO_UVCHR \
+ assert(s)
+
+PERL_CALLCONV UV Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UTF8_TO_UVUNI \
+ assert(s)
+
+
+#ifdef EBCDIC
+PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UTF8N_TO_UVCHR \
+ assert(s)
+
+#else
+/* PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_UTF8N_TO_UVCHR \
+ assert(s)
+
+#endif
+
+PERL_CALLCONV UV Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UTF8N_TO_UVUNI \
+ assert(s)
+
+
+#ifdef EBCDIC
+PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UVCHR_TO_UTF8 \
+ assert(d)
+
+#else
+/* PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_UVCHR_TO_UTF8 \
+ assert(d)
+
+#endif
+
+/* PERL_CALLCONV U8* Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_UVUNI_TO_UTF8 \
+ assert(d)
+
+PERL_CALLCONV U8* Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS \
+ assert(d)
+
+PERL_CALLCONV U8* Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS \
+ assert(d)
+
+PERL_CALLCONV char* Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PV_UNI_DISPLAY \
+ assert(dsv); assert(spv)
+
+PERL_CALLCONV char* Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_UNI_DISPLAY \
+ assert(dsv); assert(ssv)
+
+PERL_CALLCONV void Perl_vivify_defelem(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VIVIFY_DEFELEM \
+ assert(sv)
+
+PERL_CALLCONV void Perl_vivify_ref(pTHX_ SV* sv, U32 to_what)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VIVIFY_REF \
+ assert(sv)
+
+PERL_CALLCONV I32 Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_WAIT4PID \
+ assert(statusp)
+
+PERL_CALLCONV U32 Perl_parse_unicode_opts(pTHX_ const char **popt)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS \
+ assert(popt)
+
+PERL_CALLCONV U32 Perl_seed(pTHX);
+PERL_CALLCONV UV Perl_get_hash_seed(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op);
+PERL_CALLCONV void Perl_report_uninit(pTHX_ SV* uninit_sv);
+PERL_CALLCONV void Perl_warn(pTHX_ const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_1,pTHX_2)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WARN \
+ assert(pat)
+
+PERL_CALLCONV void Perl_vwarn(pTHX_ const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VWARN \
+ assert(pat)
+
+PERL_CALLCONV void Perl_warner(pTHX_ U32 err, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_2,pTHX_3)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_WARNER \
+ assert(pat)
+
+PERL_CALLCONV void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_VWARNER \
+ assert(pat)
+
+PERL_CALLCONV void Perl_watch(pTHX_ char** addr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WATCH \
+ assert(addr)
+
+PERL_CALLCONV I32 Perl_whichsig(pTHX_ const char* sig)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WHICHSIG \
+ assert(sig)
+
+PERL_CALLCONV void Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WRITE_TO_STDERR \
+ assert(message)
+
+PERL_CALLCONV int Perl_yyerror(pTHX_ const char* s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_YYERROR \
+ assert(s)
+
+PERL_CALLCONV int Perl_yylex(pTHX);
+PERL_CALLCONV int Perl_yyparse(pTHX);
+PERL_CALLCONV void Perl_parser_free(pTHX_ const yy_parser *parser)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PARSER_FREE \
+ assert(parser)
+
+PERL_CALLCONV int Perl_yywarn(pTHX_ const char* s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_YYWARN \
+ assert(s)
+
+#if defined(MYMALLOC)
+PERL_CALLCONV void Perl_dump_mstats(pTHX_ char* s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_MSTATS \
+ assert(s)
+
+PERL_CALLCONV int Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_MSTATS \
+ assert(buf)
+
+#endif
+PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where);
+#if defined(PERL_GLOBAL_STRUCT)
+PERL_CALLCONV struct perl_vars * Perl_GetVars(pTHX);
+PERL_CALLCONV struct perl_vars* Perl_init_global_struct(pTHX);
+PERL_CALLCONV void Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT \
+ assert(plvarsp)
+
+#endif
+PERL_CALLCONV int Perl_runops_standard(pTHX);
+PERL_CALLCONV int Perl_runops_debug(pTHX);
+PERL_CALLCONV void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_2,pTHX_3)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_CATPVF_MG \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_vcatpvf_mg(pTHX_ SV* sv, const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VCATPVF_MG \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_catpv_mg(pTHX_ SV *sv, const char *ptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_CATPV_MG \
+ assert(sv)
+
+/* PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_SV_CATPVN_MG \
+ assert(sv); assert(ptr)
+
+/* PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_CATSV_MG \
+ assert(dsv)
+
+PERL_CALLCONV void Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_2,pTHX_3)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_SETPVF_MG \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_vsetpvf_mg(pTHX_ SV* sv, const char* pat, va_list* args)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VSETPVF_MG \
+ assert(sv); assert(pat)
+
+PERL_CALLCONV void Perl_sv_setiv_mg(pTHX_ SV *sv, IV i)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETIV_MG \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETPVIV_MG \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setuv_mg(pTHX_ SV *sv, UV u)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETUV_MG \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setnv_mg(pTHX_ SV *sv, NV num)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETNV_MG \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setpv_mg(pTHX_ SV *sv, const char *ptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETPV_MG \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_setpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_SETPVN_MG \
+ assert(sv); assert(ptr)
+
+PERL_CALLCONV void Perl_sv_setsv_mg(pTHX_ SV *dstr, SV *sstr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETSV_MG \
+ assert(dstr)
+
+/* PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_USEPVN_MG \
+ assert(sv)
+
+PERL_CALLCONV MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV char* Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PV_DISPLAY \
+ assert(dsv); assert(pv)
+
+PERL_CALLCONV char* Perl_pv_escape(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PV_ESCAPE \
+ assert(dsv); assert(str)
+
+PERL_CALLCONV char* Perl_pv_pretty(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PV_PRETTY \
+ assert(dsv); assert(str)
+
+PERL_CALLCONV void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_3,pTHX_4)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DUMP_INDENT \
+ assert(file); assert(pat)
+
+PERL_CALLCONV void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DUMP_VINDENT \
+ assert(file); assert(pat)
+
+PERL_CALLCONV void Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_GV_DUMP \
+ assert(file); assert(name)
+
+PERL_CALLCONV void Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_GVGV_DUMP \
+ assert(file); assert(name)
+
+PERL_CALLCONV void Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_HV_DUMP \
+ assert(file); assert(name)
+
+PERL_CALLCONV void Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_MAGIC_DUMP \
+ assert(file); assert(mg)
+
+PERL_CALLCONV void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_OP_DUMP \
+ assert(file)
+
+PERL_CALLCONV void Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_PMOP_DUMP \
+ assert(file)
+
+PERL_CALLCONV void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_SV_DUMP \
+ assert(file)
+
+PERL_CALLCONV void Perl_magic_dump(pTHX_ const MAGIC *mg);
+PERL_CALLCONV void Perl_reginitcolors(pTHX);
+/* PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_2PV_NOLEN \
+ assert(sv)
+
+/* PERL_CALLCONV char* Perl_sv_2pvutf8_nolen(pTHX_ SV* sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN \
+ assert(sv)
+
+/* PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN \
+ assert(sv)
+
+/* PERL_CALLCONV char* Perl_sv_pv(pTHX_ SV *sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_PV \
+ assert(sv)
+
+/* PERL_CALLCONV char* Perl_sv_pvutf8(pTHX_ SV *sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_PVUTF8 \
+ assert(sv)
+
+/* PERL_CALLCONV char* Perl_sv_pvbyte(pTHX_ SV *sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_PVBYTE \
+ assert(sv)
+
+/* PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_UTF8_UPGRADE \
+ assert(sv)
+
+PERL_CALLCONV bool Perl_sv_utf8_downgrade(pTHX_ SV *sv, bool fail_ok)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE \
+ assert(sv)
+
+/* PERL_CALLCONV STRLEN sv_utf8_upgrade_nomg(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1); */
+
+PERL_CALLCONV void Perl_sv_utf8_encode(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UTF8_ENCODE \
+ assert(sv)
+
+PERL_CALLCONV bool Perl_sv_utf8_decode(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UTF8_DECODE \
+ assert(sv)
+
+/* PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_SV_FORCE_NORMAL \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_force_normal_flags(pTHX_ SV *sv, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS \
+ assert(sv)
+
+PERL_CALLCONV void Perl_tmps_grow(pTHX_ I32 n);
+PERL_CALLCONV SV* Perl_sv_rvweaken(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_RVWEAKEN \
+ assert(sv)
+
+PERL_CALLCONV int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV OP* Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block);
+PERL_CALLCONV CV* Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block);
+#ifdef PERL_MAD
+PERL_CALLCONV OP * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+ __attribute__noreturn__;
+
+#else
+PERL_CALLCONV void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+ __attribute__noreturn__;
+
+#endif
+PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MY_ATTRS \
+ assert(o)
+
+PERL_CALLCONV void Perl_boot_core_xsutils(pTHX);
+#if defined(USE_ITHREADS)
+PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_CX_DUP \
+ assert(param)
+
+PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SI_DUP \
+ assert(param)
+
+PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl, CLONE_PARAMS* param)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SS_DUP \
+ assert(proto_perl); assert(param)
+
+PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, const PerlInterpreter* proto_perl)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ANY_DUP \
+ assert(proto_perl)
+
+PERL_CALLCONV HE* Perl_he_dup(pTHX_ const HE* e, bool shared, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_HE_DUP \
+ assert(param)
+
+PERL_CALLCONV HEK* Perl_hek_dup(pTHX_ HEK* e, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HEK_DUP \
+ assert(param)
+
+PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ const REGEXP* r, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_RE_DUP \
+ assert(param)
+
+PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type, CLONE_PARAMS* param)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_FP_DUP \
+ assert(param)
+
+PERL_CALLCONV DIR* Perl_dirp_dup(pTHX_ DIR* dp)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GP_DUP \
+ assert(param)
+
+PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC* mg, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MG_DUP \
+ assert(param)
+
+PERL_CALLCONV SV* Perl_sv_dup(pTHX_ const SV* sstr, CLONE_PARAMS* param)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DUP \
+ assert(param)
+
+PERL_CALLCONV void Perl_rvpv_dup(pTHX_ SV* dstr, const SV *sstr, CLONE_PARAMS* param)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_RVPV_DUP \
+ assert(dstr); assert(sstr); assert(param)
+
+PERL_CALLCONV yy_parser* Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PARSER_DUP \
+ assert(param)
+
+#endif
+PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PTR_TABLE_FETCH \
+ assert(tbl)
+
+PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_PTR_TABLE_STORE \
+ assert(tbl); assert(newsv)
+
+PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PTR_TABLE_SPLIT \
+ assert(tbl)
+
+PERL_CALLCONV void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl);
+PERL_CALLCONV void Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl);
+#if defined(USE_ITHREADS)
+# if defined(HAVE_INTERP_INTERN)
+PERL_CALLCONV void Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SYS_INTERN_DUP \
+ assert(src); assert(dst)
+
+# endif
+#endif
+#if defined(HAVE_INTERP_INTERN)
+PERL_CALLCONV void Perl_sys_intern_clear(pTHX);
+PERL_CALLCONV void Perl_sys_intern_init(pTHX);
+#endif
+
+PERL_CALLCONV const char * Perl_custom_op_name(pTHX_ const OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CUSTOM_OP_NAME \
+ assert(o)
+
+PERL_CALLCONV const char * Perl_custom_op_desc(pTHX_ const OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CUSTOM_OP_DESC \
+ assert(o)
+
+
+PERL_CALLCONV void Perl_sv_nosharing(pTHX_ SV *sv);
+/* PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv); */
+PERL_CALLCONV bool Perl_sv_destroyable(pTHX_ SV *sv);
+#ifdef NO_MATHOMS
+/* PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv); */
+#else
+PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv);
+#endif
+PERL_CALLCONV int Perl_nothreadhook(pTHX);
+
+END_EXTERN_C
+
+#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
+STATIC I32 S_do_trans_simple(pTHX_ SV * const sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TRANS_SIMPLE \
+ assert(sv)
+
+STATIC I32 S_do_trans_count(pTHX_ SV * const sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TRANS_COUNT \
+ assert(sv)
+
+STATIC I32 S_do_trans_complex(pTHX_ SV * const sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TRANS_COMPLEX \
+ assert(sv)
+
+STATIC I32 S_do_trans_simple_utf8(pTHX_ SV * const sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8 \
+ assert(sv)
+
+STATIC I32 S_do_trans_count_utf8(pTHX_ SV * const sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8 \
+ assert(sv)
+
+STATIC I32 S_do_trans_complex_utf8(pTHX_ SV * const sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8 \
+ assert(sv)
+
+#endif
+
+#if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
+STATIC void S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_INIT_SV \
+ assert(gv)
+
+STATIC HV* S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_GET_SUPER_PKG \
+ assert(name)
+
+STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_REQUIRE_TIE_MOD \
+ assert(gv); assert(varpv); assert(namesv); assert(methpv)
+
+#endif
+
+PERL_CALLCONV void* Perl_get_arena(pTHX_ size_t svtype, U32 misc)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+STATIC void S_hsplit(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HSPLIT \
+ assert(hv)
+
+STATIC void S_hfreeentries(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HFREEENTRIES \
+ assert(hv)
+
+STATIC HE* S_new_he(pTHX)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+STATIC HEK* S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \
+ assert(str)
+
+STATIC void S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_HV_MAGIC_CHECK \
+ assert(hv); assert(needs_copy); assert(needs_store)
+
+STATIC void S_unshare_hek_or_pvn(pTHX_ const HEK* hek, const char* str, I32 len, U32 hash);
+STATIC HEK* S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SHARE_HEK_FLAGS \
+ assert(str)
+
+STATIC void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg)
+ __attribute__noreturn__
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_HV_NOTALLOWED \
+ assert(key); assert(msg)
+
+STATIC struct xpvhv_aux* S_hv_auxinit(HV *hv)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_HV_AUXINIT \
+ assert(hv)
+
+STATIC SV* S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash);
+STATIC void S_clear_placeholders(pTHX_ HV *hv, U32 items)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS \
+ assert(hv)
+
+STATIC SV * S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE \
+ assert(he)
+
+#endif
+
+#if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
+STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SAVE_MAGIC \
+ assert(sv)
+
+STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MAGIC_METHPACK \
+ assert(sv); assert(mg); assert(meth)
+
+STATIC int S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 f, int n, SV *val)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MAGIC_METHCALL \
+ assert(sv); assert(mg); assert(meth)
+
+STATIC void S_restore_magic(pTHX_ const void *p);
+STATIC void S_unwind_handler_stack(pTHX_ const void *p)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK \
+ assert(p)
+
+
+#endif
+
+#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
+PERL_CALLCONV OP* Perl_ck_anoncode(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_ANONCODE \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_bitop(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_BITOP \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_concat(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_CONCAT \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_defined(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_DEFINED \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_delete(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_DELETE \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_die(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_DIE \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_eof(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_EOF \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_eval(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_EVAL \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_exec(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_EXEC \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_exists(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_EXISTS \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_exit(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_EXIT \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_ftst(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_FTST \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_fun(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_FUN \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_glob(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_GLOB \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_grep(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_GREP \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_index(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_INDEX \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_join(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_JOIN \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_lengthconst(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_LENGTHCONST \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_lfun(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_LFUN \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_listiob(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_LISTIOB \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_match(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_MATCH \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_method(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_METHOD \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_null(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_NULL \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_open(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_OPEN \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_readline(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_READLINE \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_repeat(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_REPEAT \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_require(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_REQUIRE \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_return(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_RETURN \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_rfun(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_RFUN \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_rvconst(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_RVCONST \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_sassign(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SASSIGN \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_select(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SELECT \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_shift(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SHIFT \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_sort(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SORT \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_spair(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SPAIR \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_split(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SPLIT \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_subr(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SUBR \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_substr(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SUBSTR \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_svconst(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_SVCONST \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_trunc(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_TRUNC \
+ assert(o)
+
+PERL_CALLCONV OP* Perl_ck_unpack(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_UNPACK \
+ assert(o)
+
+STATIC bool S_is_handle_constructor(const OP *o, I32 numargs)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR \
+ assert(o)
+
+STATIC I32 S_is_list_assignment(pTHX_ const OP *o)
+ __attribute__warn_unused_result__;
+
+# ifdef USE_ITHREADS
+STATIC void S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORGET_PMOP \
+ assert(o)
+
+# else
+STATIC void S_forget_pmop(pTHX_ PMOP *const o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORGET_PMOP \
+ assert(o)
+
+# endif
+STATIC void S_find_and_forget_pmops(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS \
+ assert(o)
+
+STATIC void S_cop_free(pTHX_ COP *cop)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_COP_FREE \
+ assert(cop)
+
+STATIC OP* S_modkids(pTHX_ OP *o, I32 type);
+STATIC OP* S_scalarboolean(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCALARBOOLEAN \
+ assert(o)
+
+STATIC OP* S_newDEFSVOP(pTHX)
+ __attribute__warn_unused_result__;
+
+STATIC OP* S_search_const(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SEARCH_CONST \
+ assert(o)
+
+STATIC OP* S_new_logop(pTHX_ I32 type, I32 flags, OP **firstp, OP **otherp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_NEW_LOGOP \
+ assert(firstp); assert(otherp)
+
+STATIC void S_simplify_sort(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SIMPLIFY_SORT \
+ assert(o)
+
+STATIC const char* S_gv_ename(pTHX_ GV *gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_ENAME \
+ assert(gv)
+
+STATIC bool S_scalar_mod_type(const OP *o, I32 type)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SCALAR_MOD_TYPE \
+ assert(o)
+
+STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MY_KID \
+ assert(imopsp)
+
+STATIC OP * S_dup_attrlist(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUP_ATTRLIST \
+ assert(o)
+
+STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_APPLY_ATTRS \
+ assert(stash); assert(target)
+
+STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_APPLY_ATTRS_MY \
+ assert(stash); assert(target); assert(imopsp)
+
+STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_BAD_TYPE \
+ assert(t); assert(name); assert(kid)
+
+STATIC void S_no_bareword_allowed(pTHX_ const OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED \
+ assert(o)
+
+STATIC OP* S_no_fh_allowed(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NO_FH_ALLOWED \
+ assert(o)
+
+STATIC OP* S_too_few_arguments(pTHX_ OP *o, const char* name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS \
+ assert(o); assert(name)
+
+STATIC OP* S_too_many_arguments(pTHX_ OP *o, const char* name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS \
+ assert(o); assert(name)
+
+STATIC bool S_looks_like_bool(pTHX_ const OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL \
+ assert(o)
+
+STATIC OP* S_newGIVWHENOP(pTHX_ OP* cond, OP *block, I32 enter_opcode, I32 leave_opcode, PADOFFSET entertarg)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWGIVWHENOP \
+ assert(block)
+
+STATIC OP* S_ref_array_or_hash(pTHX_ OP* cond);
+STATIC void S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS \
+ assert(fullname); assert(gv); assert(cv)
+
+#endif
+#if defined(PL_OP_SLAB_ALLOC)
+PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_FREE \
+ assert(op)
+
+# if defined(PERL_DEBUG_READONLY_OPS)
+PERL_CALLCONV void Perl_pending_Slabs_to_ro(pTHX);
+PERL_CALLCONV OP * Perl_op_refcnt_inc(pTHX_ OP *o);
+PERL_CALLCONV PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_REFCNT_DEC \
+ assert(o)
+
+# if defined(PERL_IN_OP_C)
+STATIC void S_Slab_to_rw(pTHX_ void *op)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_TO_RW \
+ assert(op)
+
+# endif
+# endif
+#endif
+
+#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
+STATIC void S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_FIND_BEGINNING \
+ assert(linestr_sv); assert(rsfp)
+
+STATIC void S_forbid_setid(pTHX_ const char flag, const bool suidscript);
+STATIC void S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, bool canrelocate);
+STATIC void S_init_interp(pTHX);
+STATIC void S_init_ids(pTHX);
+STATIC void S_init_main_stash(pTHX);
+STATIC void S_init_perllib(pTHX);
+STATIC void S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS \
+ assert(argv)
+
+STATIC void S_init_predump_symbols(pTHX);
+STATIC void S_my_exit_jump(pTHX)
+ __attribute__noreturn__;
+
+STATIC void S_nuke_stacks(pTHX);
+STATIC int S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, bool *suidscript, PerlIO **rsfpp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_OPEN_SCRIPT \
+ assert(scriptname); assert(sv); assert(suidscript); assert(rsfpp)
+
+STATIC void S_usage(pTHX_ const char *name)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_USAGE \
+ assert(name)
+
+#ifdef DOSUID
+# ifdef IAMSUID
+STATIC void S_validate_suid(pTHX_ const char *validarg, int fdscript, bool suidscript, SV* linestr_sv, PerlIO *rsfp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_VALIDATE_SUID \
+ assert(validarg); assert(linestr_sv); assert(rsfp)
+
+# else
+STATIC void S_validate_suid(pTHX_ const char *validarg, const char *scriptname, int fdscript, SV* linestr_sv, PerlIO *rsfp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_VALIDATE_SUID \
+ assert(validarg); assert(scriptname); assert(linestr_sv); assert(rsfp)
+
+# endif
+#else
+# ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+STATIC void S_validate_suid(pTHX_ PerlIO *rsfp)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VALIDATE_SUID \
+ assert(rsfp)
+
+# endif
+#endif
+
+# if defined(IAMSUID)
+STATIC int S_fd_on_nosuid_fs(pTHX_ int fd);
+# endif
+STATIC void* S_parse_body(pTHX_ char **env, XSINIT_t xsinit);
+STATIC void S_run_body(pTHX_ I32 oldscope)
+ __attribute__noreturn__;
+
+STATIC SV * S_incpush_if_exists(pTHX_ SV *dir)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS \
+ assert(dir)
+
+#endif
+
+#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
+STATIC SV* S_refto(pTHX_ SV* sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REFTO \
+ assert(sv)
+
+#endif
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
+PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type, SV ***spp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_SOFTREF2XV \
+ assert(sv); assert(what); assert(spp)
+
+#endif
+
+#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+STATIC I32 S_unpack_rec(pTHX_ struct tempsym* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_UNPACK_REC \
+ assert(symptr); assert(s); assert(strbeg); assert(strend)
+
+STATIC SV ** S_pack_rec(pTHX_ SV *cat, struct tempsym* symptr, SV **beglist, SV **endlist)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_PACK_REC \
+ assert(cat); assert(symptr); assert(beglist); assert(endlist)
+
+STATIC SV* S_mul128(pTHX_ SV *sv, U8 m)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MUL128 \
+ assert(sv)
+
+STATIC I32 S_measure_struct(pTHX_ struct tempsym* symptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MEASURE_STRUCT \
+ assert(symptr)
+
+STATIC bool S_next_symbol(pTHX_ struct tempsym* symptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEXT_SYMBOL \
+ assert(symptr)
+
+STATIC SV* S_is_an_int(pTHX_ const char *s, STRLEN l)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_AN_INT \
+ assert(s)
+
+STATIC int S_div128(pTHX_ SV *pnum, bool *done)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DIV128 \
+ assert(pnum); assert(done)
+
+STATIC const char * S_group_end(pTHX_ const char *patptr, const char *patend, char ender)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GROUP_END \
+ assert(patptr); assert(patend)
+
+STATIC const char * S_get_num(pTHX_ const char *patptr, I32 *lenptr)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GET_NUM \
+ assert(patptr); assert(lenptr)
+
+STATIC bool S_need_utf8(const char *pat, const char *patend)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_NEED_UTF8 \
+ assert(pat); assert(patend)
+
+STATIC char S_first_symbol(const char *pat, const char *patend)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_FIRST_SYMBOL \
+ assert(pat); assert(patend)
+
+STATIC char * S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_EXP_GROW \
+ assert(sv)
+
+STATIC char * S_bytes_to_uni(const U8 *start, STRLEN len, char *dest)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_BYTES_TO_UNI \
+ assert(start); assert(dest)
+
+#endif
+
+#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
+STATIC OP* S_docatch(pTHX_ OP *o)
+ __attribute__warn_unused_result__;
+
+STATIC OP* S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_DOFINDLABEL \
+ assert(o); assert(label); assert(opstack); assert(oplimit)
+
+STATIC OP* S_doparseform(pTHX_ SV *sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DOPARSEFORM \
+ assert(sv)
+
+STATIC bool S_num_overflow(NV value, I32 fldsize, I32 frcsize)
+ __attribute__warn_unused_result__;
+
+STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock)
+ __attribute__warn_unused_result__;
+
+STATIC I32 S_dopoptogiven(pTHX_ I32 startingblock)
+ __attribute__warn_unused_result__;
+
+STATIC I32 S_dopoptolabel(pTHX_ const char *label)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DOPOPTOLABEL \
+ assert(label)
+
+STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock)
+ __attribute__warn_unused_result__;
+
+STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT* cxstk, I32 startingblock)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DOPOPTOSUB_AT \
+ assert(cxstk)
+
+STATIC I32 S_dopoptowhen(pTHX_ I32 startingblock)
+ __attribute__warn_unused_result__;
+
+STATIC void S_save_lines(pTHX_ AV *array, SV *sv)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SAVE_LINES \
+ assert(sv)
+
+STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq);
+STATIC PerlIO * S_check_type_and_open(pTHX_ const char *name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN \
+ assert(name)
+
+#ifndef PERL_DISABLE_PMC
+STATIC PerlIO * S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DOOPEN_PM \
+ assert(name)
+
+#endif
+STATIC bool S_path_is_absolute(const char *name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE \
+ assert(name)
+
+STATIC I32 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_RUN_USER_FILTER \
+ assert(buf_sv)
+
+STATIC PMOP* S_make_matcher(pTHX_ REGEXP* re)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MAKE_MATCHER \
+ assert(re)
+
+STATIC bool S_matcher_matches_sv(pTHX_ PMOP* matcher, SV* sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MATCHER_MATCHES_SV \
+ assert(matcher); assert(sv)
+
+STATIC void S_destroy_matcher(pTHX_ PMOP* matcher)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DESTROY_MATCHER \
+ assert(matcher)
+
+STATIC OP* S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other);
+#endif
+
+#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
+STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DO_ODDBALL \
+ assert(hash); assert(relem); assert(firstrelem)
+
+STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_METHOD_COMMON \
+ assert(meth)
+
+#endif
+
+#if defined(PERL_IN_PP_SORT_C) || defined(PERL_DECL_PROT)
+STATIC I32 S_sv_ncmp(pTHX_ SV *a, SV *b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_NCMP \
+ assert(a); assert(b)
+
+STATIC I32 S_sv_i_ncmp(pTHX_ SV *a, SV *b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_I_NCMP \
+ assert(a); assert(b)
+
+STATIC I32 S_amagic_ncmp(pTHX_ SV *a, SV *b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AMAGIC_NCMP \
+ assert(a); assert(b)
+
+STATIC I32 S_amagic_i_ncmp(pTHX_ SV *a, SV *b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AMAGIC_I_NCMP \
+ assert(a); assert(b)
+
+STATIC I32 S_amagic_cmp(pTHX_ SV *str1, SV *str2)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AMAGIC_CMP \
+ assert(str1); assert(str2)
+
+STATIC I32 S_amagic_cmp_locale(pTHX_ SV *str1, SV *str2)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE \
+ assert(str1); assert(str2)
+
+STATIC I32 S_sortcv(pTHX_ SV *a, SV *b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SORTCV \
+ assert(a); assert(b)
+
+STATIC I32 S_sortcv_xsub(pTHX_ SV *a, SV *b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SORTCV_XSUB \
+ assert(a); assert(b)
+
+STATIC I32 S_sortcv_stacked(pTHX_ SV *a, SV *b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SORTCV_STACKED \
+ assert(a); assert(b)
+
+STATIC void S_qsortsvu(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t compare)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_QSORTSVU \
+ assert(compare)
+
+#endif
+
+#if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
+STATIC OP* S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DOFORM \
+ assert(cv); assert(gv); assert(retop)
+
+# if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
+STATIC int S_dooneliner(pTHX_ const char *cmd, const char *filename)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DOONELINER \
+ assert(cmd); assert(filename)
+
+# endif
+STATIC SV * S_space_join_names_mortal(pTHX_ char *const *array)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL \
+ assert(array)
+
+#endif
+
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
+STATIC regnode* S_reg(pTHX_ struct RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_REG \
+ assert(pRExC_state); assert(flagp)
+
+STATIC regnode* S_reganode(pTHX_ struct RExC_state_t *pRExC_state, U8 op, U32 arg)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGANODE \
+ assert(pRExC_state)
+
+STATIC regnode* S_regatom(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGATOM \
+ assert(pRExC_state); assert(flagp)
+
+STATIC regnode* S_regbranch(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGBRANCH \
+ assert(pRExC_state); assert(flagp)
+
+STATIC STRLEN S_reguni(pTHX_ const struct RExC_state_t *pRExC_state, UV uv, char *s)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_REGUNI \
+ assert(pRExC_state); assert(s)
+
+STATIC regnode* S_regclass(pTHX_ struct RExC_state_t *pRExC_state, U32 depth)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGCLASS \
+ assert(pRExC_state)
+
+STATIC I32 S_regcurly(const char *s)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_REGCURLY \
+ assert(s)
+
+STATIC regnode* S_reg_node(pTHX_ struct RExC_state_t *pRExC_state, U8 op)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NODE \
+ assert(pRExC_state)
+
+STATIC UV S_reg_recode(pTHX_ const char value, SV **encp)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REG_RECODE \
+ assert(encp)
+
+STATIC regnode* S_regpiece(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGPIECE \
+ assert(pRExC_state); assert(flagp)
+
+STATIC regnode* S_reg_namedseq(pTHX_ struct RExC_state_t *pRExC_state, UV *valuep)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_NAMEDSEQ \
+ assert(pRExC_state)
+
+STATIC void S_reginsert(pTHX_ struct RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_REGINSERT \
+ assert(pRExC_state); assert(opnd)
+
+STATIC void S_regtail(pTHX_ struct RExC_state_t *pRExC_state, regnode *p, const regnode *val, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_REGTAIL \
+ assert(pRExC_state); assert(p); assert(val)
+
+STATIC SV * S_reg_scan_name(pTHX_ struct RExC_state_t *pRExC_state, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_SCAN_NAME \
+ assert(pRExC_state)
+
+STATIC U32 S_join_exact(pTHX_ struct RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags, regnode *val, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_JOIN_EXACT \
+ assert(pRExC_state); assert(scan); assert(min)
+
+STATIC char * S_regwhite(struct RExC_state_t *pRExC_state, char *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_REGWHITE \
+ assert(pRExC_state); assert(p)
+
+STATIC char * S_nextchar(pTHX_ struct RExC_state_t *pRExC_state)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEXTCHAR \
+ assert(pRExC_state)
+
+STATIC bool S_reg_skipcomment(pTHX_ struct RExC_state_t *pRExC_state)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REG_SKIPCOMMENT \
+ assert(pRExC_state)
+
+STATIC void S_scan_commit(pTHX_ const struct RExC_state_t *pRExC_state, struct scan_data_t *data, I32 *minlenp, int is_inf)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SCAN_COMMIT \
+ assert(pRExC_state); assert(data); assert(minlenp)
+
+STATIC void S_cl_anything(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_CL_ANYTHING \
+ assert(pRExC_state); assert(cl)
+
+STATIC int S_cl_is_anything(const struct regnode_charclass_class *cl)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_CL_IS_ANYTHING \
+ assert(cl)
+
+STATIC void S_cl_init(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_CL_INIT \
+ assert(pRExC_state); assert(cl)
+
+STATIC void S_cl_init_zero(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_CL_INIT_ZERO \
+ assert(pRExC_state); assert(cl)
+
+STATIC void S_cl_and(struct regnode_charclass_class *cl, const struct regnode_charclass_class *and_with)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_CL_AND \
+ assert(cl); assert(and_with)
+
+STATIC void S_cl_or(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_CL_OR \
+ assert(pRExC_state); assert(cl); assert(or_with)
+
+STATIC I32 S_study_chunk(pTHX_ struct RExC_state_t *pRExC_state, regnode **scanp, I32 *minlenp, I32 *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U8* recursed, struct regnode_charclass_class *and_withp, U32 flags, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_STUDY_CHUNK \
+ assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
+
+STATIC U32 S_add_data(struct RExC_state_t *pRExC_state, U32 n, const char *s)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_ADD_DATA \
+ assert(pRExC_state); assert(s)
+
+STATIC void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...)
+ __attribute__noreturn__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_RE_CROAK2 \
+ assert(pat1); assert(pat2)
+
+STATIC I32 S_regpposixcc(pTHX_ struct RExC_state_t *pRExC_state, I32 value)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGPPOSIXCC \
+ assert(pRExC_state)
+
+STATIC void S_checkposixcc(pTHX_ struct RExC_state_t *pRExC_state)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CHECKPOSIXCC \
+ assert(pRExC_state)
+
+STATIC I32 S_make_trie(pTHX_ struct RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_MAKE_TRIE \
+ assert(pRExC_state); assert(startbranch); assert(first); assert(last); assert(tail)
+
+STATIC void S_make_trie_failtable(pTHX_ struct RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE \
+ assert(pRExC_state); assert(source); assert(stclass)
+
+# ifdef DEBUGGING
+STATIC void S_regdump_extflags(pTHX_ const char *lead, const U32 flags);
+STATIC const regnode* S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, const regnode *last, const regnode *plast, SV* sv, I32 indent, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_6);
+#define PERL_ARGS_ASSERT_DUMPUNTIL \
+ assert(r); assert(start); assert(node); assert(sv)
+
+STATIC void S_put_byte(pTHX_ SV* sv, int c)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PUT_BYTE \
+ assert(sv)
+
+STATIC void S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DUMP_TRIE \
+ assert(trie); assert(revcharmap)
+
+STATIC void S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 next_alloc, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST \
+ assert(trie); assert(revcharmap)
+
+STATIC void S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 next_alloc, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE \
+ assert(trie); assert(revcharmap)
+
+STATIC U8 S_regtail_study(pTHX_ struct RExC_state_t *pRExC_state, regnode *p, const regnode *val, U32 depth)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_REGTAIL_STUDY \
+ assert(pRExC_state); assert(p); assert(val)
+
+# endif
+#endif
+
+#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
+STATIC I32 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGMATCH \
+ assert(reginfo); assert(prog)
+
+STATIC I32 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGREPEAT \
+ assert(prog); assert(p)
+
+STATIC I32 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGTRY \
+ assert(reginfo); assert(startpos)
+
+STATIC bool S_reginclass(pTHX_ const regexp *prog, const regnode *n, const U8 *p, STRLEN *lenp, bool do_utf8sv_is_utf8)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_REGINCLASS \
+ assert(n); assert(p)
+
+STATIC CHECKPOINT S_regcppush(pTHX_ I32 parenfloor);
+STATIC char* S_regcppop(pTHX_ const regexp *rex)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGCPPOP \
+ assert(rex)
+
+STATIC U8* S_reghop3(U8 *s, I32 off, const U8 *lim)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_REGHOP3 \
+ assert(s); assert(lim)
+
+#ifdef XXX_dmq
+STATIC U8* S_reghop4(U8 *s, I32 off, const U8 *llim, const U8 *rlim)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4);
+#define PERL_ARGS_ASSERT_REGHOP4 \
+ assert(s); assert(llim); assert(rlim)
+
+#endif
+STATIC U8* S_reghopmaybe3(U8 *s, I32 off, const U8 *lim)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_REGHOPMAYBE3 \
+ assert(s); assert(lim)
+
+STATIC char* S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_FIND_BYCLASS \
+ assert(prog); assert(c); assert(s); assert(strend)
+
+STATIC void S_swap_match_buff(pTHX_ regexp * prog)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SWAP_MATCH_BUFF \
+ assert(prog)
+
+STATIC void S_to_utf8_substr(pTHX_ regexp * prog)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_TO_UTF8_SUBSTR \
+ assert(prog)
+
+STATIC void S_to_byte_substr(pTHX_ regexp * prog)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_TO_BYTE_SUBSTR \
+ assert(prog)
+
+STATIC I32 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED \
+ assert(rex); assert(scan)
+
+# ifdef DEBUGGING
+STATIC void S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const char *loc_regeol, const char *loc_bostr, const char *loc_reg_starttry, const bool do_utf8)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_DUMP_EXEC_POS \
+ assert(locinput); assert(scan); assert(loc_regeol); assert(loc_bostr); assert(loc_reg_starttry)
+
+STATIC void S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8, const char *start, const char *end, const char *blurb)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_DEBUG_START_MATCH \
+ assert(prog); assert(start); assert(end); assert(blurb)
+
+# endif
+#endif
+
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
+STATIC CV* S_deb_curcv(pTHX_ const I32 ix);
+STATIC void S_debprof(pTHX_ const OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DEBPROF \
+ assert(o)
+
+STATIC void S_sequence(pTHX_ const OP *o);
+STATIC void S_sequence_tail(pTHX_ const OP *o);
+STATIC UV S_sequence_num(pTHX_ const OP *o);
+STATIC SV* S_pm_description(pTHX_ const PMOP *pm)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PM_DESCRIPTION \
+ assert(pm)
+
+#endif
+
+#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
+STATIC SV* S_save_scalar_at(pTHX_ SV **sptr)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_SCALAR_AT \
+ assert(sptr)
+
+#endif
+
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+PERL_CALLCONV void Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_ADD_BACKREF \
+ assert(tsv); assert(sv)
+
+#endif
+
+#if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+PERL_CALLCONV int Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_KILL_BACKREFS \
+ assert(sv); assert(av)
+
+#endif
+
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+STATIC char * S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(5);
+#define PERL_ARGS_ASSERT_UIV_2BUF \
+ assert(buf); assert(peob)
+
+STATIC void S_sv_unglob(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UNGLOB \
+ assert(sv)
+
+STATIC void S_not_a_number(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NOT_A_NUMBER \
+ assert(sv)
+
+STATIC I32 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VISIT \
+ assert(f)
+
+STATIC void S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DEL_BACKREF \
+ assert(tsv); assert(sv)
+
+STATIC SV * S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, SV *keyname, I32 aindex, int subscript_type)
+ __attribute__warn_unused_result__;
+
+# ifdef DEBUGGING
+STATIC void S_del_sv(pTHX_ SV *p)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DEL_SV \
+ assert(p)
+
+# endif
+# if !defined(NV_PRESERVES_UV)
+# ifdef DEBUGGING
+STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *sv, I32 numtype)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE \
+ assert(sv)
+
+# else
+STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE \
+ assert(sv)
+
+# endif
+# endif
+STATIC I32 S_expect_number(pTHX_ char** pattern)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_EXPECT_NUMBER \
+ assert(pattern)
+
+#
+STATIC STRLEN S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, STRLEN uoffset)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS \
+ assert(start); assert(send)
+
+STATIC STRLEN S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, STRLEN uoffset, STRLEN uend)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY \
+ assert(start); assert(send)
+
+STATIC STRLEN S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, const U8 *const send, STRLEN uoffset, STRLEN uoffset0, STRLEN boffset0)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_SV_POS_U2B_CACHED \
+ assert(sv); assert(mgp); assert(start); assert(send)
+
+STATIC void S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, STRLEN blen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE \
+ assert(sv); assert(mgp)
+
+STATIC STRLEN S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end, STRLEN endu)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY \
+ assert(s); assert(target); assert(end)
+
+STATIC char * S_F0convert(NV nv, char *endbuf, STRLEN *len)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_F0CONVERT \
+ assert(endbuf); assert(len)
+
+# if defined(PERL_OLD_COPY_ON_WRITE)
+STATIC void S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SV_RELEASE_COW \
+ assert(sv); assert(pvx); assert(after)
+
+# endif
+STATIC SV * S_more_sv(pTHX);
+STATIC void * S_more_bodies(pTHX_ svtype sv_type);
+STATIC bool S_sv_2iuv_common(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_2IUV_COMMON \
+ assert(sv)
+
+STATIC void S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB \
+ assert(dstr); assert(sstr)
+
+STATIC void S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GLOB_ASSIGN_REF \
+ assert(dstr); assert(sstr)
+
+STATIC PTR_TBL_ENT_t * S_ptr_table_find(PTR_TBL_t *tbl, const void *sv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PTR_TABLE_FIND \
+ assert(tbl)
+
+#endif
+
+#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+STATIC void S_check_uni(pTHX);
+STATIC void S_force_next(pTHX_ I32 type);
+STATIC char* S_force_version(pTHX_ char *s, int guessing)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORCE_VERSION \
+ assert(s)
+
+STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_tick)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORCE_WORD \
+ assert(start)
+
+STATIC SV* S_tokeq(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_TOKEQ \
+ assert(sv)
+
+STATIC void S_readpipe_override(pTHX);
+STATIC char* S_scan_const(pTHX_ char *start)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_CONST \
+ assert(start)
+
+STATIC char* S_scan_formline(pTHX_ char *s)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_FORMLINE \
+ assert(s)
+
+STATIC char* S_scan_heredoc(pTHX_ char *s)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_HEREDOC \
+ assert(s)
+
+STATIC char* S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_SCAN_IDENT \
+ assert(s); assert(send); assert(dest)
+
+STATIC char* S_scan_inputsymbol(pTHX_ char *start)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL \
+ assert(start)
+
+STATIC char* S_scan_pat(pTHX_ char *start, I32 type)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_PAT \
+ assert(start)
+
+STATIC char* S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_STR \
+ assert(start)
+
+STATIC char* S_scan_subst(pTHX_ char *start)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_SUBST \
+ assert(start)
+
+STATIC char* S_scan_trans(pTHX_ char *start)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_TRANS \
+ assert(start)
+
+STATIC char* S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_SCAN_WORD \
+ assert(s); assert(dest); assert(slp)
+
+STATIC void S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len);
+STATIC char* S_skipspace(pTHX_ char *s)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SKIPSPACE \
+ assert(s)
+
+STATIC char* S_swallow_bom(pTHX_ U8 *s)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SWALLOW_BOM \
+ assert(s)
+
+STATIC void S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CHECKCOMMA \
+ assert(s); assert(name); assert(what)
+
+STATIC bool S_feature_is_enabled(pTHX_ const char* name, STRLEN namelen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FEATURE_IS_ENABLED \
+ assert(name)
+
+STATIC void S_force_ident(pTHX_ const char *s, int kind)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORCE_IDENT \
+ assert(s)
+
+STATIC void S_incline(pTHX_ const char *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INCLINE \
+ assert(s)
+
+STATIC int S_intuit_method(pTHX_ char *s, GV *gv, CV *cv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INTUIT_METHOD \
+ assert(s)
+
+STATIC int S_intuit_more(pTHX_ char *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INTUIT_MORE \
+ assert(s)
+
+STATIC I32 S_lop(pTHX_ I32 f, int x, char *s)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_LOP \
+ assert(s)
+
+STATIC void S_missingterm(pTHX_ char *s)
+ __attribute__noreturn__;
+
+STATIC void S_no_op(pTHX_ const char *what, char *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NO_OP \
+ assert(what)
+
+STATIC I32 S_sublex_done(pTHX)
+ __attribute__warn_unused_result__;
+
+STATIC I32 S_sublex_push(pTHX)
+ __attribute__warn_unused_result__;
+
+STATIC I32 S_sublex_start(pTHX)
+ __attribute__warn_unused_result__;
+
+STATIC char * S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_FILTER_GETS \
+ assert(sv); assert(fp)
+
+STATIC HV * S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FIND_IN_MY_STASH \
+ assert(pkgname)
+
+STATIC char * S_tokenize_use(pTHX_ int is_use, char *s)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOKENIZE_USE \
+ assert(s)
+
+STATIC SV* S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, SV *sv, SV *pv, const char *type, STRLEN typelen)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_NEW_CONSTANT \
+ assert(key); assert(sv)
+
+STATIC int S_ao(pTHX_ int toketype);
+# if defined(PERL_CR_FILTER)
+STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen);
+STATIC void S_strip_return(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_STRIP_RETURN \
+ assert(sv)
+
+# endif
+# if defined(DEBUGGING)
+STATIC int S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOKEREPORT \
+ assert(lvalp)
+
+STATIC void S_printbuf(pTHX_ const char* fmt, const char* s)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PRINTBUF \
+ assert(fmt); assert(s)
+
+# endif
+#endif
+
+#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
+STATIC bool S_isa_lookup(pTHX_ HV *stash, const char * const name)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ISA_LOOKUP \
+ assert(stash); assert(name)
+
+STATIC HV * S_get_isa_hash(pTHX_ HV *const stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_ISA_HASH \
+ assert(stash)
+
+#endif
+
+#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
+#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE)
+STATIC char* S_stdize_locale(pTHX_ char* locs)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_STDIZE_LOCALE \
+ assert(locs)
+
+#endif
+#endif
+
+#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+STATIC const COP* S_closest_cop(pTHX_ const COP *cop, const OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CLOSEST_COP \
+ assert(cop)
+
+STATIC SV* S_mess_alloc(pTHX);
+STATIC const char * S_vdie_croak_common(pTHX_ const char *pat, va_list *args, STRLEN *msglen, I32* utf8);
+STATIC bool S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn);
+STATIC char * S_write_no_mem(pTHX)
+ __attribute__noreturn__;
+
+#if defined(PERL_MEM_LOG) && defined(PERL_MEM_LOG_STDERR)
+STATIC void S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *type_name, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+ __attribute__nonnull__(4)
+ __attribute__nonnull__(8)
+ __attribute__nonnull__(10);
+#define PERL_ARGS_ASSERT_MEM_LOG_COMMON \
+ assert(type_name); assert(filename); assert(funcname)
+
+#endif
+#endif
+
+#if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT)
+STATIC NV S_mulexp10(NV value, I32 exponent);
+#endif
+
+#if defined(PERL_IN_UTF8_C) || defined(PERL_DECL_PROT)
+STATIC STRLEN S_is_utf8_char_slow(const U8 *s, const STRLEN len)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW \
+ assert(s)
+
+STATIC bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char * const swashname)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_IS_UTF8_COMMON \
+ assert(p); assert(swash); assert(swashname)
+
+STATIC SV* S_swash_get(pTHX_ SV* swash, UV start, UV span)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SWASH_GET \
+ assert(swash)
+
+#endif
+
+START_EXTERN_C
+
+PERL_CALLCONV void Perl_sv_setsv_flags(pTHX_ SV *dstr, SV *sstr, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETSV_FLAGS \
+ assert(dstr)
+
+PERL_CALLCONV void Perl_sv_catpvn_flags(pTHX_ SV *dstr, const char *sstr, STRLEN len, I32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_CATPVN_FLAGS \
+ assert(dstr); assert(sstr)
+
+PERL_CALLCONV void Perl_sv_catsv_flags(pTHX_ SV* dsv, SV* ssv, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_CATSV_FLAGS \
+ assert(dsv)
+
+PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ SV *sv, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS \
+ assert(sv)
+
+PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS \
+ assert(sv)
+
+PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV* dsv, SV* ssv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_COPYPV \
+ assert(dsv); assert(ssv)
+
+PERL_CALLCONV char* Perl_my_atof2(pTHX_ const char *s, NV* value)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MY_ATOF2 \
+ assert(s); assert(value)
+
+PERL_CALLCONV int Perl_my_socketpair(int family, int type, int protocol, int fd[2]);
+PERL_CALLCONV int Perl_my_dirfd(pTHX_ DIR* dir);
+#ifdef PERL_OLD_COPY_ON_WRITE
+PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_SETSV_COW \
+ assert(sstr)
+
+#endif
+
+PERL_CALLCONV const char * Perl_PerlIO_context_layers(pTHX_ const char *mode);
+
+#if defined(USE_PERLIO) && !defined(USE_SFIO)
+PERL_CALLCONV int Perl_PerlIO_close(pTHX_ PerlIO *f);
+PERL_CALLCONV int Perl_PerlIO_fill(pTHX_ PerlIO *f);
+PERL_CALLCONV int Perl_PerlIO_fileno(pTHX_ PerlIO *f);
+PERL_CALLCONV int Perl_PerlIO_eof(pTHX_ PerlIO *f);
+PERL_CALLCONV int Perl_PerlIO_error(pTHX_ PerlIO *f);
+PERL_CALLCONV int Perl_PerlIO_flush(pTHX_ PerlIO *f);
+PERL_CALLCONV void Perl_PerlIO_clearerr(pTHX_ PerlIO *f);
+PERL_CALLCONV void Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt);
+PERL_CALLCONV void Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, int cnt);
+PERL_CALLCONV void Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f);
+PERL_CALLCONV SSize_t Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PERLIO_READ \
+ assert(vbuf)
+
+PERL_CALLCONV SSize_t Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PERLIO_WRITE \
+ assert(vbuf)
+
+PERL_CALLCONV SSize_t Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PERLIO_UNREAD \
+ assert(vbuf)
+
+PERL_CALLCONV Off_t Perl_PerlIO_tell(pTHX_ PerlIO *f);
+PERL_CALLCONV int Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence);
+
+PERL_CALLCONV STDCHAR * Perl_PerlIO_get_base(pTHX_ PerlIO *f);
+PERL_CALLCONV STDCHAR * Perl_PerlIO_get_ptr(pTHX_ PerlIO *f);
+PERL_CALLCONV int Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV int Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
+ __attribute__warn_unused_result__;
+
+
+PERL_CALLCONV PerlIO * Perl_PerlIO_stdin(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PerlIO * Perl_PerlIO_stdout(pTHX)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PerlIO * Perl_PerlIO_stderr(pTHX)
+ __attribute__warn_unused_result__;
+
+#endif /* PERLIO_LAYERS */
+
+PERL_CALLCONV void Perl_deb_stack_all(pTHX);
+#if defined(PERL_IN_DEB_C) || defined(PERL_DECL_PROT)
+STATIC void S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I32 mark_min, I32 mark_max)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DEB_STACK_N \
+ assert(stack_base)
+
+#endif
+
+PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ int flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_UNDEF \
+ assert(cv)
+
+PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool clone, bool state)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_ADD_NAME \
+ assert(name)
+
+PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_ADD_ANON \
+ assert(sv)
+
+PERL_CALLCONV void Perl_pad_check_dup(pTHX_ const char* name, bool is_our, const HV* ourstash)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_PAD_CHECK_DUP \
+ assert(name); assert(ourstash)
+
+#ifdef DEBUGGING
+PERL_CALLCONV void Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PAD_SETSV \
+ assert(sv)
+
+#endif
+PERL_CALLCONV void Perl_pad_block_start(pTHX_ int full);
+PERL_CALLCONV void Perl_pad_tidy(pTHX_ padtidy_type type);
+PERL_CALLCONV void Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_DUMP_PAD \
+ assert(file)
+
+PERL_CALLCONV void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS \
+ assert(padlist); assert(old_cv); assert(new_cv)
+
+
+PERL_CALLCONV void Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_PUSH \
+ assert(padlist)
+
+PERL_CALLCONV HV* Perl_pad_compname_type(pTHX_ const PADOFFSET po)
+ __attribute__warn_unused_result__;
+
+
+#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+STATIC PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_6)
+ __attribute__nonnull__(pTHX_7);
+#define PERL_ARGS_ASSERT_PAD_FINDLEX \
+ assert(name); assert(cv); assert(out_name_sv); assert(out_flags)
+
+# if defined(DEBUGGING)
+STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CV_DUMP \
+ assert(cv); assert(title)
+
+# endif
+#endif
+PERL_CALLCONV CV* Perl_find_runcv(pTHX_ U32 *db_seqp)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_free_tied_hv_pool(pTHX);
+#if defined(DEBUGGING)
+PERL_CALLCONV int Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_DEBUG_OPTS \
+ assert(s)
+
+#endif
+PERL_CALLCONV void Perl_save_set_svflags(pTHX_ SV *sv, U32 mask, U32 val)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS \
+ assert(sv)
+
+PERL_CALLCONV void Perl_hv_assert(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_ASSERT \
+ assert(hv)
+
+
+PERL_CALLCONV SV* Perl_hv_scalar(pTHX_ HV *hv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_SCALAR \
+ assert(hv)
+
+PERL_CALLCONV I32* Perl_hv_riter_p(pTHX_ HV *hv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_RITER_P \
+ assert(hv)
+
+PERL_CALLCONV HE** Perl_hv_eiter_p(pTHX_ HV *hv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_EITER_P \
+ assert(hv)
+
+PERL_CALLCONV void Perl_hv_riter_set(pTHX_ HV *hv, I32 riter)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_RITER_SET \
+ assert(hv)
+
+PERL_CALLCONV void Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_EITER_SET \
+ assert(hv)
+
+PERL_CALLCONV void Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_NAME_SET \
+ assert(hv)
+
+PERL_CALLCONV AV** Perl_hv_backreferences_p(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_BACKREFERENCES_P \
+ assert(hv)
+
+#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+PERL_CALLCONV void Perl_hv_kill_backrefs(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_KILL_BACKREFS \
+ assert(hv)
+
+#endif
+PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS \
+ assert(hv)
+
+PERL_CALLCONV I32* Perl_hv_placeholders_p(pTHX_ HV *hv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P \
+ assert(hv)
+
+PERL_CALLCONV I32 Perl_hv_placeholders_get(pTHX_ HV *hv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET \
+ assert(hv)
+
+PERL_CALLCONV void Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET \
+ assert(hv)
+
+
+PERL_CALLCONV SV* Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SCALARPACK \
+ assert(hv); assert(mg)
+
+
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+STATIC SV * S_find_hash_subscript(pTHX_ HV *hv, SV *val)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT \
+ assert(val)
+
+STATIC I32 S_find_array_subscript(pTHX_ AV *av, SV *val)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT \
+ assert(val)
+
+STATIC SV* S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool top);
+#endif
+
+#ifdef PERL_NEED_MY_HTOLE16
+PERL_CALLCONV U16 Perl_my_htole16(U16 n);
+#endif
+#ifdef PERL_NEED_MY_LETOH16
+PERL_CALLCONV U16 Perl_my_letoh16(U16 n);
+#endif
+#ifdef PERL_NEED_MY_HTOBE16
+PERL_CALLCONV U16 Perl_my_htobe16(U16 n);
+#endif
+#ifdef PERL_NEED_MY_BETOH16
+PERL_CALLCONV U16 Perl_my_betoh16(U16 n);
+#endif
+#ifdef PERL_NEED_MY_HTOLE32
+PERL_CALLCONV U32 Perl_my_htole32(U32 n);
+#endif
+#ifdef PERL_NEED_MY_LETOH32
+PERL_CALLCONV U32 Perl_my_letoh32(U32 n);
+#endif
+#ifdef PERL_NEED_MY_HTOBE32
+PERL_CALLCONV U32 Perl_my_htobe32(U32 n);
+#endif
+#ifdef PERL_NEED_MY_BETOH32
+PERL_CALLCONV U32 Perl_my_betoh32(U32 n);
+#endif
+#ifdef PERL_NEED_MY_HTOLE64
+PERL_CALLCONV U64 Perl_my_htole64(U64 n);
+#endif
+#ifdef PERL_NEED_MY_LETOH64
+PERL_CALLCONV U64 Perl_my_letoh64(U64 n);
+#endif
+#ifdef PERL_NEED_MY_HTOBE64
+PERL_CALLCONV U64 Perl_my_htobe64(U64 n);
+#endif
+#ifdef PERL_NEED_MY_BETOH64
+PERL_CALLCONV U64 Perl_my_betoh64(U64 n);
+#endif
+
+#ifdef PERL_NEED_MY_HTOLES
+PERL_CALLCONV short Perl_my_htoles(short n);
+#endif
+#ifdef PERL_NEED_MY_LETOHS
+PERL_CALLCONV short Perl_my_letohs(short n);
+#endif
+#ifdef PERL_NEED_MY_HTOBES
+PERL_CALLCONV short Perl_my_htobes(short n);
+#endif
+#ifdef PERL_NEED_MY_BETOHS
+PERL_CALLCONV short Perl_my_betohs(short n);
+#endif
+#ifdef PERL_NEED_MY_HTOLEI
+PERL_CALLCONV int Perl_my_htolei(int n);
+#endif
+#ifdef PERL_NEED_MY_LETOHI
+PERL_CALLCONV int Perl_my_letohi(int n);
+#endif
+#ifdef PERL_NEED_MY_HTOBEI
+PERL_CALLCONV int Perl_my_htobei(int n);
+#endif
+#ifdef PERL_NEED_MY_BETOHI
+PERL_CALLCONV int Perl_my_betohi(int n);
+#endif
+#ifdef PERL_NEED_MY_HTOLEL
+PERL_CALLCONV long Perl_my_htolel(long n);
+#endif
+#ifdef PERL_NEED_MY_LETOHL
+PERL_CALLCONV long Perl_my_letohl(long n);
+#endif
+#ifdef PERL_NEED_MY_HTOBEL
+PERL_CALLCONV long Perl_my_htobel(long n);
+#endif
+#ifdef PERL_NEED_MY_BETOHL
+PERL_CALLCONV long Perl_my_betohl(long n);
+#endif
+
+PERL_CALLCONV void Perl_my_swabn(void* ptr, int n)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_MY_SWABN \
+ assert(ptr)
+
+
+PERL_CALLCONV GV* Perl_gv_fetchpvn_flags(pTHX_ const char* name, STRLEN len, I32 flags, I32 sv_type)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_FETCHSV \
+ assert(name)
+
+PERL_CALLCONV bool Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV \
+ assert(name)
+
+
+PERL_CALLCONV bool Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH \
+ assert(c); assert(hv)
+
+
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+PERL_CALLCONV void Perl_dump_sv_child(pTHX_ SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_SV_CHILD \
+ assert(sv)
+
+#endif
+
+#ifdef PERL_DONT_CREATE_GVSV
+PERL_CALLCONV GV* Perl_gv_SVadd(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_SVADD \
+ assert(gv)
+
+#endif
+PERL_CALLCONV bool Perl_ckwarn(pTHX_ U32 w);
+PERL_CALLCONV bool Perl_ckwarn_d(pTHX_ U32 w);
+PERL_CALLCONV STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD \
+ assert(bits)
+
+
+PERL_CALLCONV void Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OFFER_NICE_CHUNK \
+ assert(chunk)
+
+
+#ifndef SPRINTF_RETURNS_STRLEN
+PERL_CALLCONV int Perl_my_sprintf(char *buffer, const char *pat, ...)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_MY_SPRINTF \
+ assert(buffer); assert(pat)
+
+#endif
+
+PERL_CALLCONV int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
+ __attribute__format__(__printf__,3,4)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_MY_SNPRINTF \
+ assert(buffer); assert(format)
+
+PERL_CALLCONV int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_MY_VSNPRINTF \
+ assert(buffer); assert(format)
+
+
+PERL_CALLCONV void Perl_my_clearenv(pTHX);
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+PERL_CALLCONV void* Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MY_CXT_INIT \
+ assert(my_cxt_key)
+
+PERL_CALLCONV int Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MY_CXT_INDEX \
+ assert(my_cxt_key)
+
+#else
+PERL_CALLCONV void* Perl_my_cxt_init(pTHX_ int *index, size_t size)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MY_CXT_INIT \
+ assert(index)
+
+#endif
+#endif
+
+#ifndef HAS_STRLCAT
+PERL_CALLCONV Size_t Perl_my_strlcat(char *dst, const char *src, Size_t size);
+#endif
+
+#ifndef HAS_STRLCPY
+PERL_CALLCONV Size_t Perl_my_strlcpy(char *dst, const char *src, Size_t size);
+#endif
+
+#ifdef PERL_MAD
+PERL_CALLCONV void Perl_pad_peg(const char* s)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_PAD_PEG \
+ assert(s)
+
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
+STATIC void S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_3,pTHX_4)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_XMLDUMP_ATTR \
+ assert(file); assert(pat)
+
+#endif
+PERL_CALLCONV void Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
+ __attribute__format__(__printf__,pTHX_3,pTHX_4)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_XMLDUMP_INDENT \
+ assert(file); assert(pat)
+
+PERL_CALLCONV void Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_XMLDUMP_VINDENT \
+ assert(file); assert(pat)
+
+PERL_CALLCONV void Perl_xmldump_all(pTHX);
+PERL_CALLCONV void Perl_xmldump_packsubs(pTHX_ const HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS \
+ assert(stash)
+
+PERL_CALLCONV void Perl_xmldump_sub(pTHX_ const GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_XMLDUMP_SUB \
+ assert(gv)
+
+PERL_CALLCONV void Perl_xmldump_form(pTHX_ const GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_XMLDUMP_FORM \
+ assert(gv)
+
+PERL_CALLCONV void Perl_xmldump_eval(pTHX);
+PERL_CALLCONV char* Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_CATXMLSV \
+ assert(dsv); assert(ssv)
+
+PERL_CALLCONV char* Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_CATXMLPVN \
+ assert(dsv); assert(pv)
+
+PERL_CALLCONV char* Perl_sv_xmlpeek(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_XMLPEEK \
+ assert(sv)
+
+PERL_CALLCONV void Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP \
+ assert(file)
+
+PERL_CALLCONV void Perl_pmop_xmldump(pTHX_ const PMOP* pm);
+PERL_CALLCONV void Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_OP_XMLDUMP \
+ assert(file)
+
+PERL_CALLCONV void Perl_op_xmldump(pTHX_ const OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_XMLDUMP \
+ assert(o)
+
+
+PERL_CALLCONV TOKEN* Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop);
+PERL_CALLCONV void Perl_token_free(pTHX_ TOKEN *tk)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_TOKEN_FREE \
+ assert(tk)
+
+PERL_CALLCONV void Perl_token_getmad(pTHX_ TOKEN *tk, OP *o, char slot)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_TOKEN_GETMAD \
+ assert(tk)
+
+PERL_CALLCONV void Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot);
+PERL_CALLCONV void Perl_op_getmad(pTHX_ OP* from, OP* o, char slot);
+PERL_CALLCONV void Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot);
+PERL_CALLCONV void Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot);
+PERL_CALLCONV void Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot);
+PERL_CALLCONV MADPROP* Perl_newMADsv(pTHX_ char key, SV* sv)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWMADSV \
+ assert(sv)
+
+PERL_CALLCONV MADPROP* Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen);
+PERL_CALLCONV void Perl_mad_free(pTHX_ MADPROP* mp);
+
+# if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+STATIC char* S_skipspace0(pTHX_ char *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SKIPSPACE0 \
+ assert(s)
+
+STATIC char* S_skipspace1(pTHX_ char *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SKIPSPACE1 \
+ assert(s)
+
+STATIC char* S_skipspace2(pTHX_ char *s, SV **sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SKIPSPACE2 \
+ assert(s)
+
+STATIC void S_start_force(pTHX_ int where);
+STATIC void S_curmad(pTHX_ char slot, SV *sv);
+# endif
+PERL_CALLCONV int Perl_madlex(pTHX);
+PERL_CALLCONV int Perl_madparse(pTHX);
+#endif
+#if !defined(HAS_SIGNBIT)
+PERL_CALLCONV int Perl_signbit(NV f)
+ __attribute__pure__;
+
+#endif
+
+PERL_CALLCONV void Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_EMULATE_COP_IO \
+ assert(c); assert(sv)
+
+PERL_CALLCONV REGEXP * Perl_get_re_arg(pTHX_ SV *sv);
+
+PERL_CALLCONV SV* Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA \
+ assert(smeta); assert(which)
+
+PERL_CALLCONV SV* Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which, SV *const data)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA \
+ assert(smeta); assert(which); assert(data)
+
+PERL_CALLCONV const struct mro_alg * Perl_mro_get_from_name(pTHX_ SV *name)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_GET_FROM_NAME \
+ assert(name)
+
+PERL_CALLCONV void Perl_mro_register(pTHX_ const struct mro_alg *mro)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_REGISTER \
+ assert(mro)
+
+PERL_CALLCONV void Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MRO_SET_MRO \
+ assert(meta); assert(name)
+
+PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_META_INIT \
+ assert(stash)
+
+#if defined(USE_ITHREADS)
+PERL_CALLCONV struct mro_meta* Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MRO_META_DUP \
+ assert(smeta); assert(param)
+
+#endif
+PERL_CALLCONV AV* Perl_mro_get_linear_isa(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA \
+ assert(stash)
+
+#if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT)
+STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS \
+ assert(stash)
+
+#endif
+PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN \
+ assert(stash)
+
+PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \
+ assert(stash)
+
+PERL_CALLCONV void Perl_boot_core_mro(pTHX);
+PERL_CALLCONV void Perl_sys_init(int* argc, char*** argv)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_SYS_INIT \
+ assert(argc); assert(argv)
+
+PERL_CALLCONV void Perl_sys_init3(int* argc, char*** argv, char*** env)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_SYS_INIT3 \
+ assert(argc); assert(argv); assert(env)
+
+PERL_CALLCONV void Perl_sys_term(void);
+
+END_EXTERN_C
+/*
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/reentr.h b/Master/tlpkg/tlperl.straw/lib/CORE/reentr.h
new file mode 100755
index 00000000000..9715ef3e5c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/reentr.h
@@ -0,0 +1,1540 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * reentr.h
+ *
+ * Copyright (C) 2002, 2003, 2005, 2006, 2007 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by reentr.pl from data in reentr.pl.
+ */
+
+#ifndef REENTR_H
+#define REENTR_H
+
+/* If compiling for a threaded perl, we will macro-wrap the system/library
+ * interfaces (e.g. getpwent()) which have threaded versions
+ * (e.g. getpwent_r()), which will handle things correctly for
+ * the Perl interpreter, but otherwise (for XS) the wrapping does
+ * not take place. See L<perlxs/Thread-aware system interfaces>.
+ */
+
+#ifndef PERL_REENTR_API
+# if defined(PERL_CORE) || defined(PERL_EXT)
+# define PERL_REENTR_API 1
+# else
+# define PERL_REENTR_API 0
+# endif
+#endif
+
+#ifdef USE_REENTRANT_API
+
+/* Deprecations: some platforms have the said reentrant interfaces
+ * but they are declared obsolete and are not to be used. Often this
+ * means that the platform has threadsafed the interfaces (hopefully).
+ * All this is OS version dependent, so we are of course fooling ourselves.
+ * If you know of more deprecations on some platforms, please add your own
+ * (by editing reentr.pl, mind!) */
+
+#ifdef __hpux
+# undef HAS_CRYPT_R
+# undef HAS_DRAND48_R
+# undef HAS_ENDGRENT_R
+# undef HAS_ENDPWENT_R
+# undef HAS_GETGRENT_R
+# undef HAS_GETPWENT_R
+# undef HAS_SETLOCALE_R
+# undef HAS_SRAND48_R
+# undef HAS_STRERROR_R
+# define NETDB_R_OBSOLETE
+#endif
+
+#if defined(__osf__) && defined(__alpha) /* Tru64 aka Digital UNIX */
+# undef HAS_CRYPT_R
+# undef HAS_STRERROR_R
+# define NETDB_R_OBSOLETE
+#endif
+
+/*
+ * As of OpenBSD 3.7, reentrant functions are now working, they just are
+ * incompatible with everyone else. To make OpenBSD happy, we have to
+ * memzero out certain structures before calling the functions.
+ */
+#if defined(__OpenBSD__)
+# define REENTR_MEMZERO(a,b) memzero(a,b)
+#else
+# define REENTR_MEMZERO(a,b) 0
+#endif
+
+#ifdef NETDB_R_OBSOLETE
+# undef HAS_ENDHOSTENT_R
+# undef HAS_ENDNETENT_R
+# undef HAS_ENDPROTOENT_R
+# undef HAS_ENDSERVENT_R
+# undef HAS_GETHOSTBYADDR_R
+# undef HAS_GETHOSTBYNAME_R
+# undef HAS_GETHOSTENT_R
+# undef HAS_GETNETBYADDR_R
+# undef HAS_GETNETBYNAME_R
+# undef HAS_GETNETENT_R
+# undef HAS_GETPROTOBYNAME_R
+# undef HAS_GETPROTOBYNUMBER_R
+# undef HAS_GETPROTOENT_R
+# undef HAS_GETSERVBYNAME_R
+# undef HAS_GETSERVBYPORT_R
+# undef HAS_GETSERVENT_R
+# undef HAS_SETHOSTENT_R
+# undef HAS_SETNETENT_R
+# undef HAS_SETPROTOENT_R
+# undef HAS_SETSERVENT_R
+#endif
+
+#ifdef I_PWD
+# include <pwd.h>
+#endif
+#ifdef I_GRP
+# include <grp.h>
+#endif
+#ifdef I_NETDB
+# include <netdb.h>
+#endif
+#ifdef I_STDLIB
+# include <stdlib.h> /* drand48_data */
+#endif
+#ifdef I_CRYPT
+# ifdef I_CRYPT
+# include <crypt.h>
+# endif
+#endif
+#ifdef HAS_GETSPNAM_R
+# ifdef I_SHADOW
+# include <shadow.h>
+# endif
+#endif
+
+#define REENTRANT_PROTO_B_B 1
+#define REENTRANT_PROTO_B_BI 2
+#define REENTRANT_PROTO_B_BW 3
+#define REENTRANT_PROTO_B_CCD 4
+#define REENTRANT_PROTO_B_CCS 5
+#define REENTRANT_PROTO_B_IBI 6
+#define REENTRANT_PROTO_B_IBW 7
+#define REENTRANT_PROTO_B_SB 8
+#define REENTRANT_PROTO_B_SBI 9
+#define REENTRANT_PROTO_I_BI 10
+#define REENTRANT_PROTO_I_BW 11
+#define REENTRANT_PROTO_I_CCSBWR 12
+#define REENTRANT_PROTO_I_CCSD 13
+#define REENTRANT_PROTO_I_CII 14
+#define REENTRANT_PROTO_I_CIISD 15
+#define REENTRANT_PROTO_I_CSBI 16
+#define REENTRANT_PROTO_I_CSBIR 17
+#define REENTRANT_PROTO_I_CSBWR 18
+#define REENTRANT_PROTO_I_CSBWRE 19
+#define REENTRANT_PROTO_I_CSD 20
+#define REENTRANT_PROTO_I_CWISBWRE 21
+#define REENTRANT_PROTO_I_CWISD 22
+#define REENTRANT_PROTO_I_D 23
+#define REENTRANT_PROTO_I_H 24
+#define REENTRANT_PROTO_I_IBI 25
+#define REENTRANT_PROTO_I_IBW 26
+#define REENTRANT_PROTO_I_ICBI 27
+#define REENTRANT_PROTO_I_ICSBWR 28
+#define REENTRANT_PROTO_I_ICSD 29
+#define REENTRANT_PROTO_I_ID 30
+#define REENTRANT_PROTO_I_IISD 31
+#define REENTRANT_PROTO_I_ISBWR 32
+#define REENTRANT_PROTO_I_ISD 33
+#define REENTRANT_PROTO_I_LISBI 34
+#define REENTRANT_PROTO_I_LISD 35
+#define REENTRANT_PROTO_I_LS 36
+#define REENTRANT_PROTO_I_SB 37
+#define REENTRANT_PROTO_I_SBI 38
+#define REENTRANT_PROTO_I_SBIE 39
+#define REENTRANT_PROTO_I_SBIH 40
+#define REENTRANT_PROTO_I_SBIR 41
+#define REENTRANT_PROTO_I_SBWR 42
+#define REENTRANT_PROTO_I_SBWRE 43
+#define REENTRANT_PROTO_I_SD 44
+#define REENTRANT_PROTO_I_ST 45
+#define REENTRANT_PROTO_I_St 46
+#define REENTRANT_PROTO_I_TISD 47
+#define REENTRANT_PROTO_I_TS 48
+#define REENTRANT_PROTO_I_TSBI 49
+#define REENTRANT_PROTO_I_TSBIR 50
+#define REENTRANT_PROTO_I_TSBWR 51
+#define REENTRANT_PROTO_I_TSR 52
+#define REENTRANT_PROTO_I_TsISBWRE 53
+#define REENTRANT_PROTO_I_UISBWRE 54
+#define REENTRANT_PROTO_I_iS 55
+#define REENTRANT_PROTO_I_lS 56
+#define REENTRANT_PROTO_I_uISBWRE 57
+#define REENTRANT_PROTO_S_CBI 58
+#define REENTRANT_PROTO_S_CCSBI 59
+#define REENTRANT_PROTO_S_CIISBIE 60
+#define REENTRANT_PROTO_S_CSBI 61
+#define REENTRANT_PROTO_S_CSBIE 62
+#define REENTRANT_PROTO_S_CWISBIE 63
+#define REENTRANT_PROTO_S_CWISBWIE 64
+#define REENTRANT_PROTO_S_ICSBI 65
+#define REENTRANT_PROTO_S_ISBI 66
+#define REENTRANT_PROTO_S_LISBI 67
+#define REENTRANT_PROTO_S_SBI 68
+#define REENTRANT_PROTO_S_SBIE 69
+#define REENTRANT_PROTO_S_SBW 70
+#define REENTRANT_PROTO_S_TISBI 71
+#define REENTRANT_PROTO_S_TS 72
+#define REENTRANT_PROTO_S_TSBI 73
+#define REENTRANT_PROTO_S_TSBIE 74
+#define REENTRANT_PROTO_S_TWISBIE 75
+#define REENTRANT_PROTO_V_D 76
+#define REENTRANT_PROTO_V_H 77
+#define REENTRANT_PROTO_V_ID 78
+
+/* Defines for indicating which special features are supported. */
+
+/* The getgrent getgrgid getgrnam using buffer? */
+
+#if defined(HAS_GETGRENT_R) && (GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIR || GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBW || GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIH)
+# define GETGRENT_R_HAS_BUFFER
+#else
+# undef GETGRENT_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETGRGID_R) && (GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBWR || GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBIR || GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBI || GETGRGID_R_PROTO == REENTRANT_PROTO_S_TSBI)
+# define GETGRGID_R_HAS_BUFFER
+#else
+# undef GETGRGID_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETGRNAM_R) && (GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR || GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CBI || GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBI || GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CSBI)
+# define GETGRNAM_R_HAS_BUFFER
+#else
+# undef GETGRNAM_R_HAS_BUFFER
+#endif
+
+/* Any of the getgrent getgrgid getgrnam using buffer? */
+
+#if (defined(GETGRENT_R_HAS_BUFFER) || defined(GETGRGID_R_HAS_BUFFER) || defined(GETGRNAM_R_HAS_BUFFER))
+# define USE_GRENT_BUFFER
+#else
+# undef USE_GRENT_BUFFER
+#endif
+
+/* The getgrent getgrgid getgrnam using ptr? */
+
+#if defined(HAS_GETGRENT_R) && (GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIR)
+# define GETGRENT_R_HAS_PTR
+#else
+# undef GETGRENT_R_HAS_PTR
+#endif
+#if defined(HAS_GETGRGID_R) && (GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBWR || GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBIR)
+# define GETGRGID_R_HAS_PTR
+#else
+# undef GETGRGID_R_HAS_PTR
+#endif
+#if defined(HAS_GETGRNAM_R) && (GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR)
+# define GETGRNAM_R_HAS_PTR
+#else
+# undef GETGRNAM_R_HAS_PTR
+#endif
+
+/* Any of the getgrent getgrgid getgrnam using ptr? */
+
+#if (defined(GETGRENT_R_HAS_PTR) || defined(GETGRGID_R_HAS_PTR) || defined(GETGRNAM_R_HAS_PTR))
+# define USE_GRENT_PTR
+#else
+# undef USE_GRENT_PTR
+#endif
+
+/* The getpwent getpwnam getpwuid using ptr? */
+
+#if defined(HAS_GETPWENT_R) && (GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIR)
+# define GETPWENT_R_HAS_PTR
+#else
+# undef GETPWENT_R_HAS_PTR
+#endif
+#if defined(HAS_GETPWNAM_R) && (GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR)
+# define GETPWNAM_R_HAS_PTR
+#else
+# undef GETPWNAM_R_HAS_PTR
+#endif
+#if defined(HAS_GETPWUID_R) && (GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBWR || GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBIR)
+# define GETPWUID_R_HAS_PTR
+#else
+# undef GETPWUID_R_HAS_PTR
+#endif
+
+/* Any of the getpwent getpwnam getpwuid using ptr? */
+
+#if (defined(GETPWENT_R_HAS_PTR) || defined(GETPWNAM_R_HAS_PTR) || defined(GETPWUID_R_HAS_PTR))
+# define USE_PWENT_PTR
+#else
+# undef USE_PWENT_PTR
+#endif
+
+/* The getspent getspnam using ptr? */
+
+#if defined(HAS_GETSPNAM_R) && (GETSPNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR)
+# define GETSPNAM_R_HAS_PTR
+#else
+# undef GETSPNAM_R_HAS_PTR
+#endif
+
+/* Any of the getspent getspnam using ptr? */
+
+#if (defined(GETSPENT_R_HAS_PTR) || defined(GETSPNAM_R_HAS_PTR))
+# define USE_SPENT_PTR
+#else
+# undef USE_SPENT_PTR
+#endif
+
+/* The getgrent getgrgid getgrnam setgrent endgrent using fptr? */
+
+#if defined(HAS_GETGRENT_R) && (GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIH)
+# define GETGRENT_R_HAS_FPTR
+#else
+# undef GETGRENT_R_HAS_FPTR
+#endif
+#if defined(HAS_SETGRENT_R) && (SETGRENT_R_PROTO == REENTRANT_PROTO_I_H || SETGRENT_R_PROTO == REENTRANT_PROTO_V_H)
+# define SETGRENT_R_HAS_FPTR
+#else
+# undef SETGRENT_R_HAS_FPTR
+#endif
+#if defined(HAS_ENDGRENT_R) && (ENDGRENT_R_PROTO == REENTRANT_PROTO_I_H || ENDGRENT_R_PROTO == REENTRANT_PROTO_V_H)
+# define ENDGRENT_R_HAS_FPTR
+#else
+# undef ENDGRENT_R_HAS_FPTR
+#endif
+
+/* Any of the getgrent getgrgid getgrnam setgrent endgrent using fptr? */
+
+#if (defined(GETGRENT_R_HAS_FPTR) || defined(GETGRGID_R_HAS_FPTR) || defined(GETGRNAM_R_HAS_FPTR) || defined(SETGRENT_R_HAS_FPTR) || defined(ENDGRENT_R_HAS_FPTR))
+# define USE_GRENT_FPTR
+#else
+# undef USE_GRENT_FPTR
+#endif
+
+/* The getpwent getpwnam getpwuid setpwent endpwent using fptr? */
+
+#if defined(HAS_GETPWENT_R) && (GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIH)
+# define GETPWENT_R_HAS_FPTR
+#else
+# undef GETPWENT_R_HAS_FPTR
+#endif
+#if defined(HAS_SETPWENT_R) && (SETPWENT_R_PROTO == REENTRANT_PROTO_I_H || SETPWENT_R_PROTO == REENTRANT_PROTO_V_H)
+# define SETPWENT_R_HAS_FPTR
+#else
+# undef SETPWENT_R_HAS_FPTR
+#endif
+#if defined(HAS_ENDPWENT_R) && (ENDPWENT_R_PROTO == REENTRANT_PROTO_I_H || ENDPWENT_R_PROTO == REENTRANT_PROTO_V_H)
+# define ENDPWENT_R_HAS_FPTR
+#else
+# undef ENDPWENT_R_HAS_FPTR
+#endif
+
+/* Any of the getpwent getpwnam getpwuid setpwent endpwent using fptr? */
+
+#if (defined(GETPWENT_R_HAS_FPTR) || defined(GETPWNAM_R_HAS_FPTR) || defined(GETPWUID_R_HAS_FPTR) || defined(SETPWENT_R_HAS_FPTR) || defined(ENDPWENT_R_HAS_FPTR))
+# define USE_PWENT_FPTR
+#else
+# undef USE_PWENT_FPTR
+#endif
+
+/* The getpwent getpwgid getpwnam using buffer? */
+
+#if defined(HAS_GETPWENT_R) && (GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIR || GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBW || GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIH)
+# define GETPWENT_R_HAS_BUFFER
+#else
+# undef GETPWENT_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETPWNAM_R) && (GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR || GETPWNAM_R_PROTO == REENTRANT_PROTO_S_CSBI || GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBI)
+# define GETPWNAM_R_HAS_BUFFER
+#else
+# undef GETPWNAM_R_HAS_BUFFER
+#endif
+
+/* Any of the getpwent getpwgid getpwnam using buffer? */
+
+#if (defined(GETPWENT_R_HAS_BUFFER) || defined(GETPWGID_R_HAS_BUFFER) || defined(GETPWNAM_R_HAS_BUFFER))
+# define USE_PWENT_BUFFER
+#else
+# undef USE_PWENT_BUFFER
+#endif
+
+/* The gethostent gethostbyaddr gethostbyname using ptr? */
+
+#if defined(HAS_GETHOSTENT_R) && (GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE)
+# define GETHOSTENT_R_HAS_PTR
+#else
+# undef GETHOSTENT_R_HAS_PTR
+#endif
+#if defined(HAS_GETHOSTBYADDR_R) && (GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE)
+# define GETHOSTBYADDR_R_HAS_PTR
+#else
+# undef GETHOSTBYADDR_R_HAS_PTR
+#endif
+#if defined(HAS_GETHOSTBYNAME_R) && (GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE)
+# define GETHOSTBYNAME_R_HAS_PTR
+#else
+# undef GETHOSTBYNAME_R_HAS_PTR
+#endif
+
+/* Any of the gethostent gethostbyaddr gethostbyname using ptr? */
+
+#if (defined(GETHOSTENT_R_HAS_PTR) || defined(GETHOSTBYADDR_R_HAS_PTR) || defined(GETHOSTBYNAME_R_HAS_PTR))
+# define USE_HOSTENT_PTR
+#else
+# undef USE_HOSTENT_PTR
+#endif
+
+/* The getnetent getnetbyaddr getnetbyname using ptr? */
+
+#if defined(HAS_GETNETENT_R) && (GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE)
+# define GETNETENT_R_HAS_PTR
+#else
+# undef GETNETENT_R_HAS_PTR
+#endif
+#if defined(HAS_GETNETBYADDR_R) && (GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE)
+# define GETNETBYADDR_R_HAS_PTR
+#else
+# undef GETNETBYADDR_R_HAS_PTR
+#endif
+#if defined(HAS_GETNETBYNAME_R) && (GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE)
+# define GETNETBYNAME_R_HAS_PTR
+#else
+# undef GETNETBYNAME_R_HAS_PTR
+#endif
+
+/* Any of the getnetent getnetbyaddr getnetbyname using ptr? */
+
+#if (defined(GETNETENT_R_HAS_PTR) || defined(GETNETBYADDR_R_HAS_PTR) || defined(GETNETBYNAME_R_HAS_PTR))
+# define USE_NETENT_PTR
+#else
+# undef USE_NETENT_PTR
+#endif
+
+/* The getprotoent getprotobyname getprotobynumber using ptr? */
+
+#if defined(HAS_GETPROTOENT_R) && (GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBWR)
+# define GETPROTOENT_R_HAS_PTR
+#else
+# undef GETPROTOENT_R_HAS_PTR
+#endif
+#if defined(HAS_GETPROTOBYNAME_R) && (GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWR)
+# define GETPROTOBYNAME_R_HAS_PTR
+#else
+# undef GETPROTOBYNAME_R_HAS_PTR
+#endif
+#if defined(HAS_GETPROTOBYNUMBER_R) && (GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISBWR)
+# define GETPROTOBYNUMBER_R_HAS_PTR
+#else
+# undef GETPROTOBYNUMBER_R_HAS_PTR
+#endif
+
+/* Any of the getprotoent getprotobyname getprotobynumber using ptr? */
+
+#if (defined(GETPROTOENT_R_HAS_PTR) || defined(GETPROTOBYNAME_R_HAS_PTR) || defined(GETPROTOBYNUMBER_R_HAS_PTR))
+# define USE_PROTOENT_PTR
+#else
+# undef USE_PROTOENT_PTR
+#endif
+
+/* The getservent getservbyname getservbyport using ptr? */
+
+#if defined(HAS_GETSERVENT_R) && (GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBWR)
+# define GETSERVENT_R_HAS_PTR
+#else
+# undef GETSERVENT_R_HAS_PTR
+#endif
+#if defined(HAS_GETSERVBYNAME_R) && (GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSBWR)
+# define GETSERVBYNAME_R_HAS_PTR
+#else
+# undef GETSERVBYNAME_R_HAS_PTR
+#endif
+#if defined(HAS_GETSERVBYPORT_R) && (GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSBWR)
+# define GETSERVBYPORT_R_HAS_PTR
+#else
+# undef GETSERVBYPORT_R_HAS_PTR
+#endif
+
+/* Any of the getservent getservbyname getservbyport using ptr? */
+
+#if (defined(GETSERVENT_R_HAS_PTR) || defined(GETSERVBYNAME_R_HAS_PTR) || defined(GETSERVBYPORT_R_HAS_PTR))
+# define USE_SERVENT_PTR
+#else
+# undef USE_SERVENT_PTR
+#endif
+
+/* The gethostent gethostbyaddr gethostbyname using buffer? */
+
+#if defined(HAS_GETHOSTENT_R) && (GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBIE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBI)
+# define GETHOSTENT_R_HAS_BUFFER
+#else
+# undef GETHOSTENT_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETHOSTBYADDR_R) && (GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBWIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CIISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE)
+# define GETHOSTBYADDR_R_HAS_BUFFER
+#else
+# undef GETHOSTBYADDR_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETHOSTBYNAME_R) && (GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE || GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBIE)
+# define GETHOSTBYNAME_R_HAS_BUFFER
+#else
+# undef GETHOSTBYNAME_R_HAS_BUFFER
+#endif
+
+/* Any of the gethostent gethostbyaddr gethostbyname using buffer? */
+
+#if (defined(GETHOSTENT_R_HAS_BUFFER) || defined(GETHOSTBYADDR_R_HAS_BUFFER) || defined(GETHOSTBYNAME_R_HAS_BUFFER))
+# define USE_HOSTENT_BUFFER
+#else
+# undef USE_HOSTENT_BUFFER
+#endif
+
+/* The getnetent getnetbyaddr getnetbyname using buffer? */
+
+#if defined(HAS_GETNETENT_R) && (GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBIE || GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBI)
+# define GETNETENT_R_HAS_BUFFER
+#else
+# undef GETNETENT_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETNETBYADDR_R) && (GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_LISBI || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_TISBI || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_LISBI || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE)
+# define GETNETBYADDR_R_HAS_BUFFER
+#else
+# undef GETNETBYADDR_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETNETBYNAME_R) && (GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE || GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBI || GETNETBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI)
+# define GETNETBYNAME_R_HAS_BUFFER
+#else
+# undef GETNETBYNAME_R_HAS_BUFFER
+#endif
+
+/* Any of the getnetent getnetbyaddr getnetbyname using buffer? */
+
+#if (defined(GETNETENT_R_HAS_BUFFER) || defined(GETNETBYADDR_R_HAS_BUFFER) || defined(GETNETBYNAME_R_HAS_BUFFER))
+# define USE_NETENT_BUFFER
+#else
+# undef USE_NETENT_BUFFER
+#endif
+
+/* The getprotoent getprotobyname getprotobynumber using buffer? */
+
+#if defined(HAS_GETPROTOENT_R) && (GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETPROTOENT_R_PROTO == REENTRANT_PROTO_S_SBI)
+# define GETPROTOENT_R_HAS_BUFFER
+#else
+# undef GETPROTOENT_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETPROTOBYNAME_R) && (GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI)
+# define GETPROTOBYNAME_R_HAS_BUFFER
+#else
+# undef GETPROTOBYNAME_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETPROTOBYNUMBER_R) && (GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISBWR || GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_S_ISBI)
+# define GETPROTOBYNUMBER_R_HAS_BUFFER
+#else
+# undef GETPROTOBYNUMBER_R_HAS_BUFFER
+#endif
+
+/* Any of the getprotoent getprotobyname getprotobynumber using buffer? */
+
+#if (defined(GETPROTOENT_R_HAS_BUFFER) || defined(GETPROTOBYNAME_R_HAS_BUFFER) || defined(GETPROTOBYNUMBER_R_HAS_BUFFER))
+# define USE_PROTOENT_BUFFER
+#else
+# undef USE_PROTOENT_BUFFER
+#endif
+
+/* The getservent getservbyname getservbyport using buffer? */
+
+#if defined(HAS_GETSERVENT_R) && (GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETSERVENT_R_PROTO == REENTRANT_PROTO_S_SBI)
+# define GETSERVENT_R_HAS_BUFFER
+#else
+# undef GETSERVENT_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETSERVBYNAME_R) && (GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSBWR || GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_S_CCSBI)
+# define GETSERVBYNAME_R_HAS_BUFFER
+#else
+# undef GETSERVBYNAME_R_HAS_BUFFER
+#endif
+#if defined(HAS_GETSERVBYPORT_R) && (GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSBWR || GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_S_ICSBI)
+# define GETSERVBYPORT_R_HAS_BUFFER
+#else
+# undef GETSERVBYPORT_R_HAS_BUFFER
+#endif
+
+/* Any of the getservent getservbyname getservbyport using buffer? */
+
+#if (defined(GETSERVENT_R_HAS_BUFFER) || defined(GETSERVBYNAME_R_HAS_BUFFER) || defined(GETSERVBYPORT_R_HAS_BUFFER))
+# define USE_SERVENT_BUFFER
+#else
+# undef USE_SERVENT_BUFFER
+#endif
+
+/* The gethostent gethostbyaddr gethostbyname using errno? */
+
+#if defined(HAS_GETHOSTENT_R) && (GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBIE)
+# define GETHOSTENT_R_HAS_ERRNO
+#else
+# undef GETHOSTENT_R_HAS_ERRNO
+#endif
+#if defined(HAS_GETHOSTBYADDR_R) && (GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBWIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CIISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE)
+# define GETHOSTBYADDR_R_HAS_ERRNO
+#else
+# undef GETHOSTBYADDR_R_HAS_ERRNO
+#endif
+#if defined(HAS_GETHOSTBYNAME_R) && (GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE || GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBIE)
+# define GETHOSTBYNAME_R_HAS_ERRNO
+#else
+# undef GETHOSTBYNAME_R_HAS_ERRNO
+#endif
+
+/* Any of the gethostent gethostbyaddr gethostbyname using errno? */
+
+#if (defined(GETHOSTENT_R_HAS_ERRNO) || defined(GETHOSTBYADDR_R_HAS_ERRNO) || defined(GETHOSTBYNAME_R_HAS_ERRNO))
+# define USE_HOSTENT_ERRNO
+#else
+# undef USE_HOSTENT_ERRNO
+#endif
+
+/* The getnetent getnetbyaddr getnetbyname using errno? */
+
+#if defined(HAS_GETNETENT_R) && (GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBIE)
+# define GETNETENT_R_HAS_ERRNO
+#else
+# undef GETNETENT_R_HAS_ERRNO
+#endif
+#if defined(HAS_GETNETBYADDR_R) && (GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE)
+# define GETNETBYADDR_R_HAS_ERRNO
+#else
+# undef GETNETBYADDR_R_HAS_ERRNO
+#endif
+#if defined(HAS_GETNETBYNAME_R) && (GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE)
+# define GETNETBYNAME_R_HAS_ERRNO
+#else
+# undef GETNETBYNAME_R_HAS_ERRNO
+#endif
+
+/* Any of the getnetent getnetbyaddr getnetbyname using errno? */
+
+#if (defined(GETNETENT_R_HAS_ERRNO) || defined(GETNETBYADDR_R_HAS_ERRNO) || defined(GETNETBYNAME_R_HAS_ERRNO))
+# define USE_NETENT_ERRNO
+#else
+# undef USE_NETENT_ERRNO
+#endif
+
+
+typedef struct {
+#ifdef HAS_ASCTIME_R
+ char* _asctime_buffer;
+ size_t _asctime_size;
+#endif /* HAS_ASCTIME_R */
+#ifdef HAS_CRYPT_R
+#if CRYPT_R_PROTO == REENTRANT_PROTO_B_CCD
+ CRYPTD* _crypt_data;
+#else
+ struct crypt_data *_crypt_struct_buffer;
+#endif
+#endif /* HAS_CRYPT_R */
+#ifdef HAS_CTIME_R
+ char* _ctime_buffer;
+ size_t _ctime_size;
+#endif /* HAS_CTIME_R */
+#ifdef HAS_DRAND48_R
+ struct drand48_data _drand48_struct;
+ double _drand48_double;
+#endif /* HAS_DRAND48_R */
+#ifdef HAS_GETGRNAM_R
+ struct group _grent_struct;
+ char* _grent_buffer;
+ size_t _grent_size;
+# ifdef USE_GRENT_PTR
+ struct group* _grent_ptr;
+# endif
+# ifdef USE_GRENT_FPTR
+ FILE* _grent_fptr;
+# endif
+#endif /* HAS_GETGRNAM_R */
+#ifdef HAS_GETHOSTBYNAME_R
+ struct hostent _hostent_struct;
+# if GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD
+ struct hostent_data _hostent_data;
+# else
+ char* _hostent_buffer;
+ size_t _hostent_size;
+# endif
+# ifdef USE_HOSTENT_PTR
+ struct hostent* _hostent_ptr;
+# endif
+# ifdef USE_HOSTENT_ERRNO
+ int _hostent_errno;
+# endif
+#endif /* HAS_GETHOSTBYNAME_R */
+#ifdef HAS_GETLOGIN_R
+ char* _getlogin_buffer;
+ size_t _getlogin_size;
+#endif /* HAS_GETLOGIN_R */
+#ifdef HAS_GETNETBYNAME_R
+ struct netent _netent_struct;
+# if GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD
+ struct netent_data _netent_data;
+# else
+ char* _netent_buffer;
+ size_t _netent_size;
+# endif
+# ifdef USE_NETENT_PTR
+ struct netent* _netent_ptr;
+# endif
+# ifdef USE_NETENT_ERRNO
+ int _netent_errno;
+# endif
+#endif /* HAS_GETNETBYNAME_R */
+#ifdef HAS_GETPROTOBYNAME_R
+ struct protoent _protoent_struct;
+# if GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD
+ struct protoent_data _protoent_data;
+# else
+ char* _protoent_buffer;
+ size_t _protoent_size;
+# endif
+# ifdef USE_PROTOENT_PTR
+ struct protoent* _protoent_ptr;
+# endif
+# ifdef USE_PROTOENT_ERRNO
+ int _protoent_errno;
+# endif
+#endif /* HAS_GETPROTOBYNAME_R */
+#ifdef HAS_GETPWNAM_R
+ struct passwd _pwent_struct;
+ char* _pwent_buffer;
+ size_t _pwent_size;
+# ifdef USE_PWENT_PTR
+ struct passwd* _pwent_ptr;
+# endif
+# ifdef USE_PWENT_FPTR
+ FILE* _pwent_fptr;
+# endif
+#endif /* HAS_GETPWNAM_R */
+#ifdef HAS_GETSERVBYNAME_R
+ struct servent _servent_struct;
+# if GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSD
+ struct servent_data _servent_data;
+# else
+ char* _servent_buffer;
+ size_t _servent_size;
+# endif
+# ifdef USE_SERVENT_PTR
+ struct servent* _servent_ptr;
+# endif
+# ifdef USE_SERVENT_ERRNO
+ int _servent_errno;
+# endif
+#endif /* HAS_GETSERVBYNAME_R */
+#ifdef HAS_GETSPNAM_R
+ struct spwd _spent_struct;
+ char* _spent_buffer;
+ size_t _spent_size;
+# ifdef USE_SPENT_PTR
+ struct spwd* _spent_ptr;
+# endif
+# ifdef USE_SPENT_FPTR
+ FILE* _spent_fptr;
+# endif
+#endif /* HAS_GETSPNAM_R */
+#ifdef HAS_GMTIME_R
+ struct tm _gmtime_struct;
+#endif /* HAS_GMTIME_R */
+#ifdef HAS_LOCALTIME_R
+ struct tm _localtime_struct;
+#endif /* HAS_LOCALTIME_R */
+#ifdef HAS_RANDOM_R
+ struct random_data _random_struct;
+# if RANDOM_R_PROTO == REENTRANT_PROTO_I_iS
+ int _random_retval;
+# endif
+# if RANDOM_R_PROTO == REENTRANT_PROTO_I_lS
+ long _random_retval;
+# endif
+# if RANDOM_R_PROTO == REENTRANT_PROTO_I_St
+ int32_t _random_retval;
+# endif
+#endif /* HAS_RANDOM_R */
+#ifdef HAS_READDIR_R
+ struct dirent* _readdir_struct;
+ size_t _readdir_size;
+# if READDIR_R_PROTO == REENTRANT_PROTO_I_TSR
+ struct dirent* _readdir_ptr;
+# endif
+#endif /* HAS_READDIR_R */
+#ifdef HAS_READDIR64_R
+ struct dirent64* _readdir64_struct;
+ size_t _readdir64_size;
+# if READDIR64_R_PROTO == REENTRANT_PROTO_I_TSR
+ struct dirent64* _readdir64_ptr;
+# endif
+#endif /* HAS_READDIR64_R */
+#ifdef HAS_SETLOCALE_R
+ char* _setlocale_buffer;
+ size_t _setlocale_size;
+#endif /* HAS_SETLOCALE_R */
+#ifdef HAS_SRANDOM_R
+ struct random_data _srandom_struct;
+#endif /* HAS_SRANDOM_R */
+#ifdef HAS_STRERROR_R
+ char* _strerror_buffer;
+ size_t _strerror_size;
+#endif /* HAS_STRERROR_R */
+#ifdef HAS_TTYNAME_R
+ char* _ttyname_buffer;
+ size_t _ttyname_size;
+#endif /* HAS_TTYNAME_R */
+
+ int dummy; /* cannot have empty structs */
+} REENTR;
+
+/* The wrappers. */
+
+#ifdef HAS_ASCTIME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef asctime
+# if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_B_SB
+# define asctime(a) asctime_r(a, PL_reentrant_buffer->_asctime_buffer)
+# endif
+# if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_B_SBI
+# define asctime(a) asctime_r(a, PL_reentrant_buffer->_asctime_buffer, PL_reentrant_buffer->_asctime_size)
+# endif
+# if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_I_SB
+# define asctime(a) (asctime_r(a, PL_reentrant_buffer->_asctime_buffer) == 0 ? PL_reentrant_buffer->_asctime_buffer : 0)
+# endif
+# if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_I_SBI
+# define asctime(a) (asctime_r(a, PL_reentrant_buffer->_asctime_buffer, PL_reentrant_buffer->_asctime_size) == 0 ? PL_reentrant_buffer->_asctime_buffer : 0)
+# endif
+# endif
+#endif /* HAS_ASCTIME_R */
+
+#ifdef HAS_CRYPT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef crypt
+# if !defined(crypt) && CRYPT_R_PROTO == REENTRANT_PROTO_B_CCS
+# define crypt(a, b) crypt_r(a, b, PL_reentrant_buffer->_crypt_struct_buffer)
+# endif
+# if !defined(crypt) && CRYPT_R_PROTO == REENTRANT_PROTO_B_CCD
+# define crypt(a, b) crypt_r(a, b, &PL_reentrant_buffer->_crypt_data)
+# endif
+# endif
+#endif /* HAS_CRYPT_R */
+
+#ifdef HAS_CTERMID_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef ctermid
+# if !defined(ctermid) && CTERMID_R_PROTO == REENTRANT_PROTO_B_B
+# define ctermid(a) ctermid_r(a)
+# endif
+# endif
+#endif /* HAS_CTERMID_R */
+
+#ifdef HAS_CTIME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef ctime
+# if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_B_SB
+# define ctime(a) ctime_r(a, PL_reentrant_buffer->_ctime_buffer)
+# endif
+# if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_B_SBI
+# define ctime(a) ctime_r(a, PL_reentrant_buffer->_ctime_buffer, PL_reentrant_buffer->_ctime_size)
+# endif
+# if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_I_SB
+# define ctime(a) (ctime_r(a, PL_reentrant_buffer->_ctime_buffer) == 0 ? PL_reentrant_buffer->_ctime_buffer : 0)
+# endif
+# if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_I_SBI
+# define ctime(a) (ctime_r(a, PL_reentrant_buffer->_ctime_buffer, PL_reentrant_buffer->_ctime_size) == 0 ? PL_reentrant_buffer->_ctime_buffer : 0)
+# endif
+# endif
+#endif /* HAS_CTIME_R */
+
+#ifdef HAS_DRAND48_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef drand48
+# if !defined(drand48) && DRAND48_R_PROTO == REENTRANT_PROTO_I_ST
+# define drand48() (drand48_r(&PL_reentrant_buffer->_drand48_struct, &PL_reentrant_buffer->_drand48_double) == 0 ? PL_reentrant_buffer->_drand48_double : 0)
+# endif
+# endif
+#endif /* HAS_DRAND48_R */
+
+#ifdef HAS_ENDGRENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef endgrent
+# if !defined(endgrent) && ENDGRENT_R_PROTO == REENTRANT_PROTO_I_H
+# define endgrent() (endgrent_r(&PL_reentrant_buffer->_grent_fptr) == 0 ? 1 : 0)
+# endif
+# if !defined(endgrent) && ENDGRENT_R_PROTO == REENTRANT_PROTO_V_H
+# define endgrent() endgrent_r(&PL_reentrant_buffer->_grent_fptr)
+# endif
+# endif
+#endif /* HAS_ENDGRENT_R */
+
+#ifdef HAS_ENDHOSTENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef endhostent
+# if !defined(endhostent) && ENDHOSTENT_R_PROTO == REENTRANT_PROTO_I_D
+# define endhostent() (endhostent_r(&PL_reentrant_buffer->_hostent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(endhostent) && ENDHOSTENT_R_PROTO == REENTRANT_PROTO_V_D
+# define endhostent() endhostent_r(&PL_reentrant_buffer->_hostent_data)
+# endif
+# endif
+#endif /* HAS_ENDHOSTENT_R */
+
+#ifdef HAS_ENDNETENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef endnetent
+# if !defined(endnetent) && ENDNETENT_R_PROTO == REENTRANT_PROTO_I_D
+# define endnetent() (endnetent_r(&PL_reentrant_buffer->_netent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(endnetent) && ENDNETENT_R_PROTO == REENTRANT_PROTO_V_D
+# define endnetent() endnetent_r(&PL_reentrant_buffer->_netent_data)
+# endif
+# endif
+#endif /* HAS_ENDNETENT_R */
+
+#ifdef HAS_ENDPROTOENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef endprotoent
+# if !defined(endprotoent) && ENDPROTOENT_R_PROTO == REENTRANT_PROTO_I_D
+# define endprotoent() (endprotoent_r(&PL_reentrant_buffer->_protoent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(endprotoent) && ENDPROTOENT_R_PROTO == REENTRANT_PROTO_V_D
+# define endprotoent() endprotoent_r(&PL_reentrant_buffer->_protoent_data)
+# endif
+# endif
+#endif /* HAS_ENDPROTOENT_R */
+
+#ifdef HAS_ENDPWENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef endpwent
+# if !defined(endpwent) && ENDPWENT_R_PROTO == REENTRANT_PROTO_I_H
+# define endpwent() (endpwent_r(&PL_reentrant_buffer->_pwent_fptr) == 0 ? 1 : 0)
+# endif
+# if !defined(endpwent) && ENDPWENT_R_PROTO == REENTRANT_PROTO_V_H
+# define endpwent() endpwent_r(&PL_reentrant_buffer->_pwent_fptr)
+# endif
+# endif
+#endif /* HAS_ENDPWENT_R */
+
+#ifdef HAS_ENDSERVENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef endservent
+# if !defined(endservent) && ENDSERVENT_R_PROTO == REENTRANT_PROTO_I_D
+# define endservent() (endservent_r(&PL_reentrant_buffer->_servent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(endservent) && ENDSERVENT_R_PROTO == REENTRANT_PROTO_V_D
+# define endservent() endservent_r(&PL_reentrant_buffer->_servent_data)
+# endif
+# endif
+#endif /* HAS_ENDSERVENT_R */
+
+#ifdef HAS_GETGRENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getgrent
+# if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBWR
+# define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0))
+# endif
+# if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIR
+# define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0))
+# endif
+# if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBW
+# define getgrent() (getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0))
+# endif
+# if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBI
+# define getgrent() (getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0))
+# endif
+# if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBI
+# define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0))
+# endif
+# if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIH
+# define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_fptr)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0))
+# endif
+# endif
+#endif /* HAS_GETGRENT_R */
+
+#ifdef HAS_GETGRGID_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getgrgid
+# if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBWR
+# define getgrgid(a) ((PL_reentrant_retint = getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0))
+# endif
+# if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBIR
+# define getgrgid(a) ((PL_reentrant_retint = getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0))
+# endif
+# if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBI
+# define getgrgid(a) ((PL_reentrant_retint = getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0))
+# endif
+# if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_S_TSBI
+# define getgrgid(a) (getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETGRGID_R */
+
+#ifdef HAS_GETGRNAM_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getgrnam
+# if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR
+# define getgrnam(a) ((PL_reentrant_retint = getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0))
+# endif
+# if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR
+# define getgrnam(a) ((PL_reentrant_retint = getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0))
+# endif
+# if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CBI
+# define getgrnam(a) (getgrnam_r(a, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? PL_reentrant_buffer->_grent_buffer : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0))
+# endif
+# if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBI
+# define getgrnam(a) ((PL_reentrant_retint = getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0))
+# endif
+# if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CSBI
+# define getgrnam(a) (getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETGRNAM_R */
+
+#ifdef HAS_GETHOSTBYADDR_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef gethostbyaddr
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE
+# define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBWIE
+# define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBIE
+# define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TWISBIE
+# define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CIISBIE
+# define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CSBIE
+# define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? 1 : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TSBIE
+# define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? 1 : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISD
+# define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CIISD
+# define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CII
+# define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c)) == 0 ? 1 : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE
+# define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0))
+# endif
+# endif
+#endif /* HAS_GETHOSTBYADDR_R */
+
+#ifdef HAS_GETHOSTBYNAME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef gethostbyname
+# if !defined(gethostbyname) && GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE
+# define gethostbyname(a) ((PL_reentrant_retint = gethostbyname_r(a, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyname", a) : 0))
+# endif
+# if !defined(gethostbyname) && GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBIE
+# define gethostbyname(a) (gethostbyname_r(a, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyname", a) : 0))
+# endif
+# if !defined(gethostbyname) && GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD
+# define gethostbyname(a) ((PL_reentrant_retint = gethostbyname_r(a, &PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyname", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETHOSTBYNAME_R */
+
+#ifdef HAS_GETHOSTENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef gethostent
+# if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE
+# define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0))
+# endif
+# if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBIE
+# define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0))
+# endif
+# if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBIE
+# define gethostent() (gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0))
+# endif
+# if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBI
+# define gethostent() (gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0))
+# endif
+# if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBI
+# define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0))
+# endif
+# if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SD
+# define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0))
+# endif
+# endif
+#endif /* HAS_GETHOSTENT_R */
+
+#ifdef HAS_GETLOGIN_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getlogin
+# if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_I_BW
+# define getlogin() ((PL_reentrant_retint = getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size)) == 0 ? PL_reentrant_buffer->_getlogin_buffer : ((PL_reentrant_retint == ERANGE) ? (char *) Perl_reentrant_retry("getlogin") : 0))
+# endif
+# if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_I_BI
+# define getlogin() ((PL_reentrant_retint = getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size)) == 0 ? PL_reentrant_buffer->_getlogin_buffer : ((PL_reentrant_retint == ERANGE) ? (char *) Perl_reentrant_retry("getlogin") : 0))
+# endif
+# if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_B_BW
+# define getlogin() getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size)
+# endif
+# if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_B_BI
+# define getlogin() getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size)
+# endif
+# endif
+#endif /* HAS_GETLOGIN_R */
+
+#ifdef HAS_GETNETBYADDR_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getnetbyaddr
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE
+# define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_LISBI
+# define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_TISBI
+# define getnetbyaddr(a, b) (getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_LISBI
+# define getnetbyaddr(a, b) (getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_TISD
+# define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_LISD
+# define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_IISD
+# define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE
+# define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0))
+# endif
+# endif
+#endif /* HAS_GETNETBYADDR_R */
+
+#ifdef HAS_GETNETBYNAME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getnetbyname
+# if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE
+# define getnetbyname(a) ((PL_reentrant_retint = getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0))
+# endif
+# if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBI
+# define getnetbyname(a) ((PL_reentrant_retint = getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0))
+# endif
+# if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI
+# define getnetbyname(a) (getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0))
+# endif
+# if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD
+# define getnetbyname(a) ((PL_reentrant_retint = getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETNETBYNAME_R */
+
+#ifdef HAS_GETNETENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getnetent
+# if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE
+# define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0))
+# endif
+# if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBIE
+# define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_errno)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0))
+# endif
+# if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBIE
+# define getnetent() (getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_errno) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0))
+# endif
+# if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBI
+# define getnetent() (getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0))
+# endif
+# if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBI
+# define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0))
+# endif
+# if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SD
+# define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0))
+# endif
+# endif
+#endif /* HAS_GETNETENT_R */
+
+#ifdef HAS_GETPROTOBYNAME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getprotobyname
+# if !defined(getprotobyname) && GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWR
+# define getprotobyname(a) ((PL_reentrant_retint = getprotobyname_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, &PL_reentrant_buffer->_protoent_ptr)) == 0 ? PL_reentrant_buffer->_protoent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobyname", a) : 0))
+# endif
+# if !defined(getprotobyname) && GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI
+# define getprotobyname(a) (getprotobyname_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size) ? &PL_reentrant_buffer->_protoent_struct : ((errno == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobyname", a) : 0))
+# endif
+# if !defined(getprotobyname) && GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD
+# define getprotobyname(a) (REENTR_MEMZERO(&PL_reentrant_buffer->_protoent_data, sizeof(PL_reentrant_buffer->_protoent_data)),(PL_reentrant_retint = getprotobyname_r(a, &PL_reentrant_buffer->_protoent_struct, &PL_reentrant_buffer->_protoent_data)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobyname", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETPROTOBYNAME_R */
+
+#ifdef HAS_GETPROTOBYNUMBER_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getprotobynumber
+# if !defined(getprotobynumber) && GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISBWR
+# define getprotobynumber(a) ((PL_reentrant_retint = getprotobynumber_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, &PL_reentrant_buffer->_protoent_ptr)) == 0 ? PL_reentrant_buffer->_protoent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobynumber", a) : 0))
+# endif
+# if !defined(getprotobynumber) && GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_S_ISBI
+# define getprotobynumber(a) (getprotobynumber_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size) ? &PL_reentrant_buffer->_protoent_struct : ((errno == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobynumber", a) : 0))
+# endif
+# if !defined(getprotobynumber) && GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISD
+# define getprotobynumber(a) (REENTR_MEMZERO(&PL_reentrant_buffer->_protoent_data, sizeof(PL_reentrant_buffer->_protoent_data)),(PL_reentrant_retint = getprotobynumber_r(a, &PL_reentrant_buffer->_protoent_struct, &PL_reentrant_buffer->_protoent_data)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobynumber", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETPROTOBYNUMBER_R */
+
+#ifdef HAS_GETPROTOENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getprotoent
+# if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBWR
+# define getprotoent() ((PL_reentrant_retint = getprotoent_r(&PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, &PL_reentrant_buffer->_protoent_ptr)) == 0 ? PL_reentrant_buffer->_protoent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0))
+# endif
+# if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBI
+# define getprotoent() ((PL_reentrant_retint = getprotoent_r(&PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0))
+# endif
+# if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_S_SBI
+# define getprotoent() (getprotoent_r(&PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size) ? &PL_reentrant_buffer->_protoent_struct : ((errno == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0))
+# endif
+# if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SD
+# define getprotoent() (REENTR_MEMZERO(&PL_reentrant_buffer->_protoent_data, sizeof(PL_reentrant_buffer->_protoent_data)),(PL_reentrant_retint = getprotoent_r(&PL_reentrant_buffer->_protoent_struct, &PL_reentrant_buffer->_protoent_data)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0))
+# endif
+# endif
+#endif /* HAS_GETPROTOENT_R */
+
+#ifdef HAS_GETPWENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getpwent
+# if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBWR
+# define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0))
+# endif
+# if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIR
+# define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0))
+# endif
+# if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBW
+# define getpwent() (getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0))
+# endif
+# if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBI
+# define getpwent() (getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0))
+# endif
+# if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBI
+# define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0))
+# endif
+# if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIH
+# define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_fptr)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0))
+# endif
+# endif
+#endif /* HAS_GETPWENT_R */
+
+#ifdef HAS_GETPWNAM_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getpwnam
+# if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR
+# define getpwnam(a) ((PL_reentrant_retint = getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0))
+# endif
+# if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR
+# define getpwnam(a) ((PL_reentrant_retint = getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0))
+# endif
+# if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_S_CSBI
+# define getpwnam(a) (getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0))
+# endif
+# if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBI
+# define getpwnam(a) ((PL_reentrant_retint = getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETPWNAM_R */
+
+#ifdef HAS_GETPWUID_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getpwuid
+# if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBWR
+# define getpwuid(a) ((PL_reentrant_retint = getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0))
+# endif
+# if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBIR
+# define getpwuid(a) ((PL_reentrant_retint = getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0))
+# endif
+# if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBI
+# define getpwuid(a) ((PL_reentrant_retint = getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0))
+# endif
+# if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_S_TSBI
+# define getpwuid(a) (getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETPWUID_R */
+
+#ifdef HAS_GETSERVBYNAME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getservbyname
+# if !defined(getservbyname) && GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSBWR
+# define getservbyname(a, b) ((PL_reentrant_retint = getservbyname_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, &PL_reentrant_buffer->_servent_ptr)) == 0 ? PL_reentrant_buffer->_servent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyname", a, b) : 0))
+# endif
+# if !defined(getservbyname) && GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_S_CCSBI
+# define getservbyname(a, b) (getservbyname_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size) ? &PL_reentrant_buffer->_servent_struct : ((errno == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyname", a, b) : 0))
+# endif
+# if !defined(getservbyname) && GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSD
+# define getservbyname(a, b) (REENTR_MEMZERO(&PL_reentrant_buffer->_servent_data, sizeof(PL_reentrant_buffer->_servent_data)),(PL_reentrant_retint = getservbyname_r(a, b, &PL_reentrant_buffer->_servent_struct, &PL_reentrant_buffer->_servent_data)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyname", a, b) : 0))
+# endif
+# endif
+#endif /* HAS_GETSERVBYNAME_R */
+
+#ifdef HAS_GETSERVBYPORT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getservbyport
+# if !defined(getservbyport) && GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSBWR
+# define getservbyport(a, b) ((PL_reentrant_retint = getservbyport_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, &PL_reentrant_buffer->_servent_ptr)) == 0 ? PL_reentrant_buffer->_servent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyport", a, b) : 0))
+# endif
+# if !defined(getservbyport) && GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_S_ICSBI
+# define getservbyport(a, b) (getservbyport_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size) ? &PL_reentrant_buffer->_servent_struct : ((errno == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyport", a, b) : 0))
+# endif
+# if !defined(getservbyport) && GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSD
+# define getservbyport(a, b) (REENTR_MEMZERO(&PL_reentrant_buffer->_servent_data, sizeof(PL_reentrant_buffer->_servent_data)),(PL_reentrant_retint = getservbyport_r(a, b, &PL_reentrant_buffer->_servent_struct, &PL_reentrant_buffer->_servent_data)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyport", a, b) : 0))
+# endif
+# endif
+#endif /* HAS_GETSERVBYPORT_R */
+
+#ifdef HAS_GETSERVENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getservent
+# if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBWR
+# define getservent() ((PL_reentrant_retint = getservent_r(&PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, &PL_reentrant_buffer->_servent_ptr)) == 0 ? PL_reentrant_buffer->_servent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0))
+# endif
+# if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBI
+# define getservent() ((PL_reentrant_retint = getservent_r(&PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0))
+# endif
+# if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_S_SBI
+# define getservent() (getservent_r(&PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size) ? &PL_reentrant_buffer->_servent_struct : ((errno == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0))
+# endif
+# if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SD
+# define getservent() (REENTR_MEMZERO(&PL_reentrant_buffer->_servent_data, sizeof(PL_reentrant_buffer->_servent_data)),(PL_reentrant_retint = getservent_r(&PL_reentrant_buffer->_servent_struct, &PL_reentrant_buffer->_servent_data)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0))
+# endif
+# endif
+#endif /* HAS_GETSERVENT_R */
+
+#ifdef HAS_GETSPNAM_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef getspnam
+# if !defined(getspnam) && GETSPNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR
+# define getspnam(a) ((PL_reentrant_retint = getspnam_r(a, &PL_reentrant_buffer->_spent_struct, PL_reentrant_buffer->_spent_buffer, PL_reentrant_buffer->_spent_size, &PL_reentrant_buffer->_spent_ptr)) == 0 ? PL_reentrant_buffer->_spent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct spwd *) Perl_reentrant_retry("getspnam", a) : 0))
+# endif
+# if !defined(getspnam) && GETSPNAM_R_PROTO == REENTRANT_PROTO_S_CSBI
+# define getspnam(a) (getspnam_r(a, &PL_reentrant_buffer->_spent_struct, PL_reentrant_buffer->_spent_buffer, PL_reentrant_buffer->_spent_size) ? &PL_reentrant_buffer->_spent_struct : ((errno == ERANGE) ? (struct spwd *) Perl_reentrant_retry("getspnam", a) : 0))
+# endif
+# endif
+#endif /* HAS_GETSPNAM_R */
+
+#ifdef HAS_GMTIME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef gmtime
+# if !defined(gmtime) && GMTIME_R_PROTO == REENTRANT_PROTO_S_TS
+# define gmtime(a) (gmtime_r(a, &PL_reentrant_buffer->_gmtime_struct) ? &PL_reentrant_buffer->_gmtime_struct : 0)
+# endif
+# if !defined(gmtime) && GMTIME_R_PROTO == REENTRANT_PROTO_I_TS
+# define gmtime(a) (gmtime_r(a, &PL_reentrant_buffer->_gmtime_struct) == 0 ? &PL_reentrant_buffer->_gmtime_struct : 0)
+# endif
+# endif
+#endif /* HAS_GMTIME_R */
+
+#ifdef HAS_LOCALTIME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef localtime
+# if !defined(localtime) && LOCALTIME_R_PROTO == REENTRANT_PROTO_S_TS
+# define localtime(a) (L_R_TZSET localtime_r(a, &PL_reentrant_buffer->_localtime_struct) ? &PL_reentrant_buffer->_localtime_struct : 0)
+# endif
+# if !defined(localtime) && LOCALTIME_R_PROTO == REENTRANT_PROTO_I_TS
+# define localtime(a) (L_R_TZSET localtime_r(a, &PL_reentrant_buffer->_localtime_struct) == 0 ? &PL_reentrant_buffer->_localtime_struct : 0)
+# endif
+# endif
+#endif /* HAS_LOCALTIME_R */
+
+#ifdef HAS_RANDOM_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef random
+# if !defined(random) && RANDOM_R_PROTO == REENTRANT_PROTO_I_iS
+# define random() (random_r(&PL_reentrant_buffer->_random_retval, &PL_reentrant_buffer->_random_struct) == 0 ? PL_reentrant_buffer->_random_retval : 0)
+# endif
+# if !defined(random) && RANDOM_R_PROTO == REENTRANT_PROTO_I_lS
+# define random() (random_r(&PL_reentrant_buffer->_random_retval, &PL_reentrant_buffer->_random_struct) == 0 ? PL_reentrant_buffer->_random_retval : 0)
+# endif
+# if !defined(random) && RANDOM_R_PROTO == REENTRANT_PROTO_I_St
+# define random() (random_r(&PL_reentrant_buffer->_random_struct, &PL_reentrant_buffer->_random_retval) == 0 ? PL_reentrant_buffer->_random_retval : 0)
+# endif
+# endif
+#endif /* HAS_RANDOM_R */
+
+#ifdef HAS_READDIR_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef readdir
+# if !defined(readdir) && READDIR_R_PROTO == REENTRANT_PROTO_I_TSR
+# define readdir(a) (readdir_r(a, PL_reentrant_buffer->_readdir_struct, &PL_reentrant_buffer->_readdir_ptr) == 0 ? PL_reentrant_buffer->_readdir_ptr : 0)
+# endif
+# if !defined(readdir) && READDIR_R_PROTO == REENTRANT_PROTO_I_TS
+# define readdir(a) (readdir_r(a, PL_reentrant_buffer->_readdir_struct) == 0 ? PL_reentrant_buffer->_readdir_struct : 0)
+# endif
+# endif
+#endif /* HAS_READDIR_R */
+
+#ifdef HAS_READDIR64_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef readdir64
+# if !defined(readdir64) && READDIR64_R_PROTO == REENTRANT_PROTO_I_TSR
+# define readdir64(a) (readdir64_r(a, PL_reentrant_buffer->_readdir64_struct, &PL_reentrant_buffer->_readdir64_ptr) == 0 ? PL_reentrant_buffer->_readdir64_ptr : 0)
+# endif
+# if !defined(readdir64) && READDIR64_R_PROTO == REENTRANT_PROTO_I_TS
+# define readdir64(a) (readdir64_r(a, PL_reentrant_buffer->_readdir64_struct) == 0 ? PL_reentrant_buffer->_readdir64_struct : 0)
+# endif
+# endif
+#endif /* HAS_READDIR64_R */
+
+#ifdef HAS_SETGRENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef setgrent
+# if !defined(setgrent) && SETGRENT_R_PROTO == REENTRANT_PROTO_I_H
+# define setgrent() (setgrent_r(&PL_reentrant_buffer->_grent_fptr) == 0 ? 1 : 0)
+# endif
+# if !defined(setgrent) && SETGRENT_R_PROTO == REENTRANT_PROTO_V_H
+# define setgrent() setgrent_r(&PL_reentrant_buffer->_grent_fptr)
+# endif
+# endif
+#endif /* HAS_SETGRENT_R */
+
+#ifdef HAS_SETHOSTENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef sethostent
+# if !defined(sethostent) && SETHOSTENT_R_PROTO == REENTRANT_PROTO_I_ID
+# define sethostent(a) (sethostent_r(a, &PL_reentrant_buffer->_hostent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(sethostent) && SETHOSTENT_R_PROTO == REENTRANT_PROTO_V_ID
+# define sethostent(a) sethostent_r(a, &PL_reentrant_buffer->_hostent_data)
+# endif
+# endif
+#endif /* HAS_SETHOSTENT_R */
+
+#ifdef HAS_SETLOCALE_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef setlocale
+# if !defined(setlocale) && SETLOCALE_R_PROTO == REENTRANT_PROTO_I_ICBI
+# define setlocale(a, b) (setlocale_r(a, b, PL_reentrant_buffer->_setlocale_buffer, PL_reentrant_buffer->_setlocale_size) == 0 ? PL_reentrant_buffer->_setlocale_buffer : 0)
+# endif
+# endif
+#endif /* HAS_SETLOCALE_R */
+
+#ifdef HAS_SETNETENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef setnetent
+# if !defined(setnetent) && SETNETENT_R_PROTO == REENTRANT_PROTO_I_ID
+# define setnetent(a) (setnetent_r(a, &PL_reentrant_buffer->_netent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(setnetent) && SETNETENT_R_PROTO == REENTRANT_PROTO_V_ID
+# define setnetent(a) setnetent_r(a, &PL_reentrant_buffer->_netent_data)
+# endif
+# endif
+#endif /* HAS_SETNETENT_R */
+
+#ifdef HAS_SETPROTOENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef setprotoent
+# if !defined(setprotoent) && SETPROTOENT_R_PROTO == REENTRANT_PROTO_I_ID
+# define setprotoent(a) (setprotoent_r(a, &PL_reentrant_buffer->_protoent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(setprotoent) && SETPROTOENT_R_PROTO == REENTRANT_PROTO_V_ID
+# define setprotoent(a) setprotoent_r(a, &PL_reentrant_buffer->_protoent_data)
+# endif
+# endif
+#endif /* HAS_SETPROTOENT_R */
+
+#ifdef HAS_SETPWENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef setpwent
+# if !defined(setpwent) && SETPWENT_R_PROTO == REENTRANT_PROTO_I_H
+# define setpwent() (setpwent_r(&PL_reentrant_buffer->_pwent_fptr) == 0 ? 1 : 0)
+# endif
+# if !defined(setpwent) && SETPWENT_R_PROTO == REENTRANT_PROTO_V_H
+# define setpwent() setpwent_r(&PL_reentrant_buffer->_pwent_fptr)
+# endif
+# endif
+#endif /* HAS_SETPWENT_R */
+
+#ifdef HAS_SETSERVENT_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef setservent
+# if !defined(setservent) && SETSERVENT_R_PROTO == REENTRANT_PROTO_I_ID
+# define setservent(a) (setservent_r(a, &PL_reentrant_buffer->_servent_data) == 0 ? 1 : 0)
+# endif
+# if !defined(setservent) && SETSERVENT_R_PROTO == REENTRANT_PROTO_V_ID
+# define setservent(a) setservent_r(a, &PL_reentrant_buffer->_servent_data)
+# endif
+# endif
+#endif /* HAS_SETSERVENT_R */
+
+#ifdef HAS_SRAND48_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef srand48
+# if !defined(srand48) && SRAND48_R_PROTO == REENTRANT_PROTO_I_LS
+# define srand48(a) (srand48_r(a, &PL_reentrant_buffer->_drand48_struct) == 0 ? &PL_reentrant_buffer->_drand48_struct : 0)
+# endif
+# endif
+#endif /* HAS_SRAND48_R */
+
+#ifdef HAS_SRANDOM_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef srandom
+# if !defined(srandom) && SRANDOM_R_PROTO == REENTRANT_PROTO_I_TS
+# define srandom(a) (srandom_r(a, &PL_reentrant_buffer->_srandom_struct) == 0 ? &PL_reentrant_buffer->_srandom_struct : 0)
+# endif
+# endif
+#endif /* HAS_SRANDOM_R */
+
+#ifdef HAS_STRERROR_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef strerror
+# if !defined(strerror) && STRERROR_R_PROTO == REENTRANT_PROTO_I_IBW
+# define strerror(a) (strerror_r(a, PL_reentrant_buffer->_strerror_buffer, PL_reentrant_buffer->_strerror_size) == 0 ? PL_reentrant_buffer->_strerror_buffer : 0)
+# endif
+# if !defined(strerror) && STRERROR_R_PROTO == REENTRANT_PROTO_I_IBI
+# define strerror(a) (strerror_r(a, PL_reentrant_buffer->_strerror_buffer, PL_reentrant_buffer->_strerror_size) == 0 ? PL_reentrant_buffer->_strerror_buffer : 0)
+# endif
+# if !defined(strerror) && STRERROR_R_PROTO == REENTRANT_PROTO_B_IBW
+# define strerror(a) strerror_r(a, PL_reentrant_buffer->_strerror_buffer, PL_reentrant_buffer->_strerror_size)
+# endif
+# endif
+#endif /* HAS_STRERROR_R */
+
+#ifdef HAS_TMPNAM_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef tmpnam
+# if !defined(tmpnam) && TMPNAM_R_PROTO == REENTRANT_PROTO_B_B
+# define tmpnam(a) tmpnam_r(a)
+# endif
+# endif
+#endif /* HAS_TMPNAM_R */
+
+#ifdef HAS_TTYNAME_R
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef ttyname
+# if !defined(ttyname) && TTYNAME_R_PROTO == REENTRANT_PROTO_I_IBW
+# define ttyname(a) (ttyname_r(a, PL_reentrant_buffer->_ttyname_buffer, PL_reentrant_buffer->_ttyname_size) == 0 ? PL_reentrant_buffer->_ttyname_buffer : 0)
+# endif
+# if !defined(ttyname) && TTYNAME_R_PROTO == REENTRANT_PROTO_I_IBI
+# define ttyname(a) (ttyname_r(a, PL_reentrant_buffer->_ttyname_buffer, PL_reentrant_buffer->_ttyname_size) == 0 ? PL_reentrant_buffer->_ttyname_buffer : 0)
+# endif
+# if !defined(ttyname) && TTYNAME_R_PROTO == REENTRANT_PROTO_B_IBI
+# define ttyname(a) ttyname_r(a, PL_reentrant_buffer->_ttyname_buffer, PL_reentrant_buffer->_ttyname_size)
+# endif
+# endif
+#endif /* HAS_TTYNAME_R */
+
+
+
+#endif /* USE_REENTRANT_API */
+
+#endif
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/regcharclass.h b/Master/tlpkg/tlperl.straw/lib/CORE/regcharclass.h
new file mode 100755
index 00000000000..f9a1558d66a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/regcharclass.h
@@ -0,0 +1,454 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * regcharclass.h
+ *
+ * Copyright (C) 2007, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by Porting/regcharclass.pl.
+ *
+ * Any changes made here will be lost!
+ *
+ */
+
+/*
+ LNBREAK: Line Break: \R
+
+ "\x0D\x0A" # CRLF - Network (Windows) line ending
+ 0x0A # LF | LINE FEED
+ 0x0B # VT | VERTICAL TAB
+ 0x0C # FF | FORM FEED
+ 0x0D # CR | CARRIAGE RETURN
+ 0x85 # NEL | NEXT LINE
+ 0x2028 # LINE SEPARATOR
+ 0x2029 # PARAGRAPH SEPARATOR
+*/
+/*** GENERATED CODE ***/
+#define is_LNBREAK(s,is_utf8) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+: ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+: ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
+: ( 0x85 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
+#define is_LNBREAK_safe(s,e,is_utf8) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+ : ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 1) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+ : ( is_utf8 ) ? \
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 0) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( !( is_utf8 ) ) ? \
+ ( 0x85 == ((U8*)s)[0] ) \
+ : 0 ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_LNBREAK_utf8(s) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+: ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+: ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_LNBREAK_utf8_safe(s,e) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
+: ((e)-(s) > 1) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : 0 ) \
+: ((e)-(s) > 0) ? \
+ ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_LNBREAK_latin1(s) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+: ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+: ( 0x85 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
+#define is_LNBREAK_latin1_safe(s,e) \
+( ((e)-(s) > 1) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 0) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )\
+: 0 )
+
+/*
+ HORIZWS: Horizontal Whitespace: \h \H
+
+ 0x09 # HT
+ 0x20 # SPACE
+ 0xa0 # NBSP
+ 0x1680 # OGHAM SPACE MARK
+ 0x180e # MONGOLIAN VOWEL SEPARATOR
+ 0x2000 # EN QUAD
+ 0x2001 # EM QUAD
+ 0x2002 # EN SPACE
+ 0x2003 # EM SPACE
+ 0x2004 # THREE-PER-EM SPACE
+ 0x2005 # FOUR-PER-EM SPACE
+ 0x2006 # SIX-PER-EM SPACE
+ 0x2007 # FIGURE SPACE
+ 0x2008 # PUNCTUATION SPACE
+ 0x2009 # THIN SPACE
+ 0x200A # HAIR SPACE
+ 0x202f # NARROW NO-BREAK SPACE
+ 0x205f # MEDIUM MATHEMATICAL SPACE
+ 0x3000 # IDEOGRAPHIC SPACE
+*/
+/*** GENERATED CODE ***/
+#define is_HORIZWS(s,is_utf8) \
+( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+: ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0xA0 == ((U8*)s)[1] ) ? \
+ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+ : ( 0xE3 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : 0 ) \
+: ( 0xA0 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
+#define is_HORIZWS_safe(s,e,is_utf8) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0xA0 == ((U8*)s)[1] ) ? \
+ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+ : ( 0xE3 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
+ : ( 0xA0 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 1) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( is_utf8 ) ? \
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0xA0 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0xA0 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 0) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( !( is_utf8 ) ) ? \
+ ( 0xA0 == ((U8*)s)[0] ) \
+ : 0 ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_HORIZWS_utf8(s) \
+( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+: ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+: ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0xA0 == ((U8*)s)[1] ) ? \
+ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+: ( 0xE3 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_HORIZWS_utf8_safe(s,e) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0xA0 == ((U8*)s)[1] ) ? \
+ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : 0 ) \
+ : ( 0xE3 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : 0 ) \
+: ((e)-(s) > 1) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : 0 ) \
+: ((e)-(s) > 0) ? \
+ ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_HORIZWS_latin1(s) \
+( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] )
+
+/*** GENERATED CODE ***/
+#define is_HORIZWS_latin1_safe(s,e) \
+( ((e)-(s) > 0) ? \
+ ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_HORIZWS_cp(cp) \
+( 0x09 == cp || ( 0x09 < cp && \
+( 0x20 == cp || ( 0x20 < cp && \
+( 0xA0 == cp || ( 0xA0 < cp && \
+( 0x1680 == cp || ( 0x1680 < cp && \
+( 0x180E == cp || ( 0x180E < cp && \
+( ( 0x2000 <= cp && cp <= 0x200A ) || ( 0x200A < cp && \
+( 0x202F == cp || ( 0x202F < cp && \
+( 0x205F == cp || ( 0x205F < cp && \
+0x3000 == cp ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
+
+/*
+ VERTWS: Vertical Whitespace: \v \V
+
+ 0x0A # LF
+ 0x0B # VT
+ 0x0C # FF
+ 0x0D # CR
+ 0x85 # NEL
+ 0x2028 # LINE SEPARATOR
+ 0x2029 # PARAGRAPH SEPARATOR
+*/
+/*** GENERATED CODE ***/
+#define is_VERTWS(s,is_utf8) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+: ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
+: ( 0x85 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_safe(s,e,is_utf8) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 1) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( is_utf8 ) ? \
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 0) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( !( is_utf8 ) ) ? \
+ ( 0x85 == ((U8*)s)[0] ) \
+ : 0 ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_utf8(s) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+: ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_utf8_safe(s,e) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
+: ((e)-(s) > 1) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : 0 ) \
+: ((e)-(s) > 0) ? \
+ ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_latin1(s) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_latin1_safe(s,e) \
+( ((e)-(s) > 0) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )\
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_cp(cp) \
+( ( 0x0A <= cp && cp <= 0x0D ) || ( 0x0D < cp && \
+( 0x85 == cp || ( 0x85 < cp && \
+( 0x2028 == cp || ( 0x2028 < cp && \
+0x2029 == cp ) ) ) ) ) )
+
+/*
+ TRICKYFOLD: Problematic fold case letters.
+
+ 0x00DF # LATIN1 SMALL LETTER SHARP S
+ 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
+ 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
+*/
+/*** GENERATED CODE ***/
+#define is_TRICKYFOLD(s,is_utf8) \
+( ( is_utf8 ) ? \
+ ( ( 0xC3 == ((U8*)s)[0] ) ? \
+ ( ( 0x9F == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( 0x90 == ((U8*)s)[1] || 0xB0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : 0 ) \
+: ( 0xDF == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
+#define is_TRICKYFOLD_safe(s,e,is_utf8) \
+( ((e)-(s) > 1) ? \
+ ( ( is_utf8 ) ? \
+ ( ( 0xC3 == ((U8*)s)[0] ) ? \
+ ( ( 0x9F == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( 0x90 == ((U8*)s)[1] || 0xB0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : 0 ) \
+ : ( 0xDF == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 0) ? \
+ ( ( !( is_utf8 ) ) ? \
+ ( 0xDF == ((U8*)s)[0] ) \
+ : 0 ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_TRICKYFOLD_cp(cp) \
+( 0xDF == cp || ( 0xDF < cp && \
+( 0x390 == cp || ( 0x390 < cp && \
+0x3B0 == cp ) ) ) )
+
+/*** GENERATED CODE ***/
+#define what_TRICKYFOLD(s,is_utf8) \
+( ( is_utf8 ) ? \
+ ( ( 0xC3 == ((U8*)s)[0] ) ? \
+ ( ( 0x9F == ((U8*)s)[1] ) ? 0xDF : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( 0x90 == ((U8*)s)[1] ) ? 0x390 \
+ : ( 0xB0 == ((U8*)s)[1] ) ? 0x3B0 : 0 ) \
+ : 0 ) \
+: ( 0xDF == ((U8*)s)[0] ) ? 0xDF : 0 )
+
+/*** GENERATED CODE ***/
+#define what_TRICKYFOLD_safe(s,e,is_utf8) \
+( ((e)-(s) > 1) ? \
+ ( ( is_utf8 ) ? \
+ ( ( 0xC3 == ((U8*)s)[0] ) ? \
+ ( ( 0x9F == ((U8*)s)[1] ) ? 0xDF : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( 0x90 == ((U8*)s)[1] ) ? 0x390 \
+ : ( 0xB0 == ((U8*)s)[1] ) ? 0x3B0 : 0 ) \
+ : 0 ) \
+ : ( 0xDF == ((U8*)s)[0] ) ? 0xDF : 0 ) \
+: ((e)-(s) > 0) ? \
+ ( ( ( !( is_utf8 ) ) && ( 0xDF == ((U8*)s)[0] ) ) ? 0xDF : 0 ) \
+: 0 )
+
+/*** GENERATED CODE ***/
+#define what_len_TRICKYFOLD(s,is_utf8,len) \
+( ( is_utf8 ) ? \
+ ( ( 0xC3 == ((U8*)s)[0] ) ? \
+ ( ( 0x9F == ((U8*)s)[1] ) ? len=2, 0xDF : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( 0x90 == ((U8*)s)[1] ) ? len=2, 0x390 \
+ : ( 0xB0 == ((U8*)s)[1] ) ? len=2, 0x3B0 : 0 ) \
+ : 0 ) \
+: ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 )
+
+/*** GENERATED CODE ***/
+#define what_len_TRICKYFOLD_safe(s,e,is_utf8,len) \
+( ((e)-(s) > 1) ? \
+ ( ( is_utf8 ) ? \
+ ( ( 0xC3 == ((U8*)s)[0] ) ? \
+ ( ( 0x9F == ((U8*)s)[1] ) ? len=2, 0xDF : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( 0x90 == ((U8*)s)[1] ) ? len=2, 0x390 \
+ : ( 0xB0 == ((U8*)s)[1] ) ? len=2, 0x3B0 : 0 ) \
+ : 0 ) \
+ : ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 ) \
+: ((e)-(s) > 0) ? \
+ ( ( ( !( is_utf8 ) ) && ( 0xDF == ((U8*)s)[0] ) ) ? len=1, 0xDF : 0 ) \
+: 0 )
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/regcomp.h b/Master/tlpkg/tlperl.straw/lib/CORE/regcomp.h
new file mode 100755
index 00000000000..9bf567701cc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/regcomp.h
@@ -0,0 +1,846 @@
+/* regcomp.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2005, 2006, 2007, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+#include "regcharclass.h"
+
+typedef OP OP_4tree; /* Will be redefined later. */
+
+
+/* Convert branch sequences to more efficient trie ops? */
+#define PERL_ENABLE_TRIE_OPTIMISATION 1
+
+/* Be really agressive about optimising patterns with trie sequences? */
+#define PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION 1
+
+/* Use old style unicode mappings for perl and posix character classes
+ *
+ * NOTE: Enabling this essentially breaks character class matching against unicode
+ * strings, so that POSIX char classes match when they shouldn't, and \d matches
+ * way more than 10 characters, and sometimes a charclass and its complement either
+ * both match or neither match.
+ * NOTE: Disabling this will cause various backwards compatibility issues to rear
+ * their head, and tests to fail. However it will make the charclass behaviour
+ * consistant regardless of internal string type, and make character class inversions
+ * consistant. The tests that fail in the regex engine are basically broken tests.
+ *
+ * Personally I think 5.12 should disable this for sure. Its a bit more debatable for
+ * 5.10, so for now im leaving it enabled.
+ *
+ * -demerphq
+ */
+#define PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS 1
+
+/* Should the optimiser take positive assertions into account? */
+#define PERL_ENABLE_POSITIVE_ASSERTION_STUDY 0
+
+/* Not for production use: */
+#define PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS 0
+
+/* Activate offsets code - set to if 1 to enable */
+#ifdef DEBUGGING
+#define RE_TRACK_PATTERN_OFFSETS
+#endif
+
+/* Unless the next line is uncommented it is illegal to combine lazy
+ matching with possessive matching. Frankly it doesn't make much sense
+ to allow it as X*?+ matches nothing, X+?+ matches a single char only,
+ and X{min,max}?+ matches min times only.
+ */
+/* #define REG_ALLOW_MINMOD_SUSPEND */
+
+/*
+ * The "internal use only" fields in regexp.h are present to pass info from
+ * compile to execute that permits the execute phase to run lots faster on
+ * simple cases. They are:
+ *
+ * regstart sv that must begin a match; NULL if none obvious
+ * reganch is the match anchored (at beginning-of-line only)?
+ * regmust string (pointer into program) that match must include, or NULL
+ * [regmust changed to SV* for bminstr()--law]
+ * regmlen length of regmust string
+ * [regmlen not used currently]
+ *
+ * Regstart and reganch permit very fast decisions on suitable starting points
+ * for a match, cutting down the work a lot. Regmust permits fast rejection
+ * of lines that cannot possibly match. The regmust tests are costly enough
+ * that pregcomp() supplies a regmust only if the r.e. contains something
+ * potentially expensive (at present, the only such thing detected is * or +
+ * at the start of the r.e., which can involve a lot of backup). Regmlen is
+ * supplied because the test in pregexec() needs it and pregcomp() is computing
+ * it anyway.
+ * [regmust is now supplied always. The tests that use regmust have a
+ * heuristic that disables the test if it usually matches.]
+ *
+ * [In fact, we now use regmust in many cases to locate where the search
+ * starts in the string, so if regback is >= 0, the regmust search is never
+ * wasted effort. The regback variable says how many characters back from
+ * where regmust matched is the earliest possible start of the match.
+ * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.]
+ */
+
+/*
+ * Structure for regexp "program". This is essentially a linear encoding
+ * of a nondeterministic finite-state machine (aka syntax charts or
+ * "railroad normal form" in parsing technology). Each node is an opcode
+ * plus a "next" pointer, possibly plus an operand. "Next" pointers of
+ * all nodes except BRANCH implement concatenation; a "next" pointer with
+ * a BRANCH on both ends of it is connecting two alternatives. (Here we
+ * have one of the subtle syntax dependencies: an individual BRANCH (as
+ * opposed to a collection of them) is never concatenated with anything
+ * because of operator precedence.) The operand of some types of node is
+ * a literal string; for others, it is a node leading into a sub-FSM. In
+ * particular, the operand of a BRANCH node is the first node of the branch.
+ * (NB this is *not* a tree structure: the tail of the branch connects
+ * to the thing following the set of BRANCHes.) The opcodes are defined
+ * in regnodes.h which is generated from regcomp.sym by regcomp.pl.
+ */
+
+/*
+ * A node is one char of opcode followed by two chars of "next" pointer.
+ * "Next" pointers are stored as two 8-bit pieces, high order first. The
+ * value is a positive offset from the opcode of the node containing it.
+ * An operand, if any, simply follows the node. (Note that much of the
+ * code generation knows about this implicit relationship.)
+ *
+ * Using two bytes for the "next" pointer is vast overkill for most things,
+ * but allows patterns to get big without disasters.
+ *
+ * [The "next" pointer is always aligned on an even
+ * boundary, and reads the offset directly as a short. Also, there is no
+ * special test to reverse the sign of BACK pointers since the offset is
+ * stored negative.]
+ */
+
+/* This is the stuff that used to live in regexp.h that was truly
+ private to the engine itself. It now lives here. */
+
+
+
+ typedef struct regexp_internal {
+ int name_list_idx; /* Optional data index of an array of paren names */
+ union {
+ U32 *offsets; /* offset annotations 20001228 MJD
+ data about mapping the program to the
+ string -
+ offsets[0] is proglen when this is used
+ */
+ U32 proglen;
+ } u;
+
+ regnode *regstclass; /* Optional startclass as identified or constructed
+ by the optimiser */
+ struct reg_data *data; /* Additional miscellaneous data used by the program.
+ Used to make it easier to clone and free arbitrary
+ data that the regops need. Often the ARG field of
+ a regop is an index into this structure */
+ regnode program[1]; /* Unwarranted chumminess with compiler. */
+} regexp_internal;
+
+#define RXi_SET(x,y) (x)->pprivate = (void*)(y)
+#define RXi_GET(x) ((regexp_internal *)((x)->pprivate))
+#define RXi_GET_DECL(r,ri) regexp_internal *ri = RXi_GET(r)
+/*
+ * Flags stored in regexp->intflags
+ * These are used only internally to the regexp engine
+ *
+ * See regexp.h for flags used externally to the regexp engine
+ */
+#define PREGf_SKIP 0x00000001
+#define PREGf_IMPLICIT 0x00000002 /* Converted .* to ^.* */
+#define PREGf_NAUGHTY 0x00000004 /* how exponential is this pattern? */
+#define PREGf_VERBARG_SEEN 0x00000008
+#define PREGf_CUTGROUP_SEEN 0x00000010
+
+
+/* this is where the old regcomp.h started */
+
+struct regnode_string {
+ U8 str_len;
+ U8 type;
+ U16 next_off;
+ char string[1];
+};
+
+/* Argument bearing node - workhorse,
+ arg1 is often for the data field */
+struct regnode_1 {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+ U32 arg1;
+};
+
+/* Similar to a regnode_1 but with an extra signed argument */
+struct regnode_2L {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+ U32 arg1;
+ I32 arg2;
+};
+
+/* 'Two field' -- Two 16 bit unsigned args */
+struct regnode_2 {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+ U16 arg1;
+ U16 arg2;
+};
+
+
+#define ANYOF_BITMAP_SIZE 32 /* 256 b/(8 b/B) */
+#define ANYOF_CLASSBITMAP_SIZE 4 /* up to 40 (8*5) named classes */
+
+/* also used by trie */
+struct regnode_charclass {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+ U32 arg1;
+ char bitmap[ANYOF_BITMAP_SIZE]; /* only compile-time */
+};
+
+struct regnode_charclass_class { /* has [[:blah:]] classes */
+ U8 flags; /* should have ANYOF_CLASS here */
+ U8 type;
+ U16 next_off;
+ U32 arg1;
+ char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */
+ char classflags[ANYOF_CLASSBITMAP_SIZE]; /* and run-time */
+};
+
+/* XXX fix this description.
+ Impose a limit of REG_INFTY on various pattern matching operations
+ to limit stack growth and to avoid "infinite" recursions.
+*/
+/* The default size for REG_INFTY is I16_MAX, which is the same as
+ SHORT_MAX (see perl.h). Unfortunately I16 isn't necessarily 16 bits
+ (see handy.h). On the Cray C90, sizeof(short)==4 and hence I16_MAX is
+ ((1<<31)-1), while on the Cray T90, sizeof(short)==8 and I16_MAX is
+ ((1<<63)-1). To limit stack growth to reasonable sizes, supply a
+ smaller default.
+ --Andy Dougherty 11 June 1998
+*/
+#if SHORTSIZE > 2
+# ifndef REG_INFTY
+# define REG_INFTY ((1<<15)-1)
+# endif
+#endif
+
+#ifndef REG_INFTY
+# define REG_INFTY I16_MAX
+#endif
+
+#define ARG_VALUE(arg) (arg)
+#define ARG__SET(arg,val) ((arg) = (val))
+
+#undef ARG
+#undef ARG1
+#undef ARG2
+
+#define ARG(p) ARG_VALUE(ARG_LOC(p))
+#define ARG1(p) ARG_VALUE(ARG1_LOC(p))
+#define ARG2(p) ARG_VALUE(ARG2_LOC(p))
+#define ARG2L(p) ARG_VALUE(ARG2L_LOC(p))
+
+#define ARG_SET(p, val) ARG__SET(ARG_LOC(p), (val))
+#define ARG1_SET(p, val) ARG__SET(ARG1_LOC(p), (val))
+#define ARG2_SET(p, val) ARG__SET(ARG2_LOC(p), (val))
+#define ARG2L_SET(p, val) ARG__SET(ARG2L_LOC(p), (val))
+
+#undef NEXT_OFF
+#undef NODE_ALIGN
+
+#define NEXT_OFF(p) ((p)->next_off)
+#define NODE_ALIGN(node)
+#define NODE_ALIGN_FILL(node) ((node)->flags = 0xde) /* deadbeef */
+
+#define SIZE_ALIGN NODE_ALIGN
+
+#undef OP
+#undef OPERAND
+#undef MASK
+#undef STRING
+
+#define OP(p) ((p)->type)
+#define OPERAND(p) (((struct regnode_string *)p)->string)
+#define MASK(p) ((char*)OPERAND(p))
+#define STR_LEN(p) (((struct regnode_string *)p)->str_len)
+#define STRING(p) (((struct regnode_string *)p)->string)
+#define STR_SZ(l) ((l + sizeof(regnode) - 1) / sizeof(regnode))
+#define NODE_SZ_STR(p) (STR_SZ(STR_LEN(p))+1)
+
+#undef NODE_ALIGN
+#undef ARG_LOC
+#undef NEXTOPER
+#undef PREVOPER
+
+#define NODE_ALIGN(node)
+#define ARG_LOC(p) (((struct regnode_1 *)p)->arg1)
+#define ARG1_LOC(p) (((struct regnode_2 *)p)->arg1)
+#define ARG2_LOC(p) (((struct regnode_2 *)p)->arg2)
+#define ARG2L_LOC(p) (((struct regnode_2L *)p)->arg2)
+
+#define NODE_STEP_REGNODE 1 /* sizeof(regnode)/sizeof(regnode) */
+#define EXTRA_STEP_2ARGS EXTRA_SIZE(struct regnode_2)
+
+#define NODE_STEP_B 4
+
+#define NEXTOPER(p) ((p) + NODE_STEP_REGNODE)
+#define PREVOPER(p) ((p) - NODE_STEP_REGNODE)
+
+#define FILL_ADVANCE_NODE(ptr, op) STMT_START { \
+ (ptr)->type = op; (ptr)->next_off = 0; (ptr)++; } STMT_END
+#define FILL_ADVANCE_NODE_ARG(ptr, op, arg) STMT_START { \
+ ARG_SET(ptr, arg); FILL_ADVANCE_NODE(ptr, op); (ptr) += 1; } STMT_END
+
+#define REG_MAGIC 0234
+
+#define SIZE_ONLY (RExC_emit == &PL_regdummy)
+
+/* Flags for node->flags of ANYOF */
+
+#define ANYOF_CLASS 0x08 /* has [[:blah:]] classes */
+#define ANYOF_INVERT 0x04
+#define ANYOF_FOLD 0x02
+#define ANYOF_LOCALE 0x01
+
+/* Used for regstclass only */
+#define ANYOF_EOS 0x10 /* Can match an empty string too */
+
+/* There is a character or a range past 0xff */
+#define ANYOF_UNICODE 0x20
+#define ANYOF_UNICODE_ALL 0x40 /* Can match any char past 0xff */
+
+/* size of node is large (includes class pointer) */
+#define ANYOF_LARGE 0x80
+
+/* Are there any runtime flags on in this node? */
+#define ANYOF_RUNTIME(s) (ANYOF_FLAGS(s) & 0x0f)
+
+#define ANYOF_FLAGS_ALL 0xff
+
+/* Character classes for node->classflags of ANYOF */
+/* Should be synchronized with a table in regprop() */
+/* 2n should pair with 2n+1 */
+
+#define ANYOF_ALNUM 0 /* \w, PL_utf8_alnum, utf8::IsWord, ALNUM */
+#define ANYOF_NALNUM 1
+#define ANYOF_SPACE 2 /* \s */
+#define ANYOF_NSPACE 3
+#define ANYOF_DIGIT 4 /* \d */
+#define ANYOF_NDIGIT 5
+#define ANYOF_ALNUMC 6 /* [[:alnum:]] isalnum(3), utf8::IsAlnum, ALNUMC */
+#define ANYOF_NALNUMC 7
+#define ANYOF_ALPHA 8
+#define ANYOF_NALPHA 9
+#define ANYOF_ASCII 10
+#define ANYOF_NASCII 11
+#define ANYOF_CNTRL 12
+#define ANYOF_NCNTRL 13
+#define ANYOF_GRAPH 14
+#define ANYOF_NGRAPH 15
+#define ANYOF_LOWER 16
+#define ANYOF_NLOWER 17
+#define ANYOF_PRINT 18
+#define ANYOF_NPRINT 19
+#define ANYOF_PUNCT 20
+#define ANYOF_NPUNCT 21
+#define ANYOF_UPPER 22
+#define ANYOF_NUPPER 23
+#define ANYOF_XDIGIT 24
+#define ANYOF_NXDIGIT 25
+#define ANYOF_PSXSPC 26 /* POSIX space: \s plus the vertical tab */
+#define ANYOF_NPSXSPC 27
+#define ANYOF_BLANK 28 /* GNU extension: space and tab: non-vertical space */
+#define ANYOF_NBLANK 29
+
+#define ANYOF_MAX 32
+
+/* pseudo classes, not stored in the class bitmap, but used as flags
+ during compilation of char classes */
+
+#define ANYOF_VERTWS (ANYOF_MAX+1)
+#define ANYOF_NVERTWS (ANYOF_MAX+2)
+#define ANYOF_HORIZWS (ANYOF_MAX+3)
+#define ANYOF_NHORIZWS (ANYOF_MAX+4)
+
+/* Backward source code compatibility. */
+
+#define ANYOF_ALNUML ANYOF_ALNUM
+#define ANYOF_NALNUML ANYOF_NALNUM
+#define ANYOF_SPACEL ANYOF_SPACE
+#define ANYOF_NSPACEL ANYOF_NSPACE
+
+/* Utility macros for the bitmap and classes of ANYOF */
+
+#define ANYOF_SIZE (sizeof(struct regnode_charclass))
+#define ANYOF_CLASS_SIZE (sizeof(struct regnode_charclass_class))
+
+#define ANYOF_FLAGS(p) ((p)->flags)
+
+#define ANYOF_BIT(c) (1 << ((c) & 7))
+
+#define ANYOF_CLASS_BYTE(p, c) (((struct regnode_charclass_class*)(p))->classflags[((c) >> 3) & 3])
+#define ANYOF_CLASS_SET(p, c) (ANYOF_CLASS_BYTE(p, c) |= ANYOF_BIT(c))
+#define ANYOF_CLASS_CLEAR(p, c) (ANYOF_CLASS_BYTE(p, c) &= ~ANYOF_BIT(c))
+#define ANYOF_CLASS_TEST(p, c) (ANYOF_CLASS_BYTE(p, c) & ANYOF_BIT(c))
+
+#define ANYOF_CLASS_ZERO(ret) Zero(((struct regnode_charclass_class*)(ret))->classflags, ANYOF_CLASSBITMAP_SIZE, char)
+#define ANYOF_BITMAP_ZERO(ret) Zero(((struct regnode_charclass*)(ret))->bitmap, ANYOF_BITMAP_SIZE, char)
+
+#define ANYOF_BITMAP(p) (((struct regnode_charclass*)(p))->bitmap)
+#define ANYOF_BITMAP_BYTE(p, c) (ANYOF_BITMAP(p)[(((U8)(c)) >> 3) & 31])
+#define ANYOF_BITMAP_SET(p, c) (ANYOF_BITMAP_BYTE(p, c) |= ANYOF_BIT(c))
+#define ANYOF_BITMAP_CLEAR(p,c) (ANYOF_BITMAP_BYTE(p, c) &= ~ANYOF_BIT(c))
+#define ANYOF_BITMAP_TEST(p, c) (ANYOF_BITMAP_BYTE(p, c) & ANYOF_BIT(c))
+
+#define ANYOF_BITMAP_SETALL(p) \
+ memset (ANYOF_BITMAP(p), 255, ANYOF_BITMAP_SIZE)
+#define ANYOF_BITMAP_CLEARALL(p) \
+ Zero (ANYOF_BITMAP(p), ANYOF_BITMAP_SIZE)
+/* Check that all 256 bits are all set. Used in S_cl_is_anything() */
+#define ANYOF_BITMAP_TESTALLSET(p) \
+ memEQ (ANYOF_BITMAP(p), "\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377", ANYOF_BITMAP_SIZE)
+
+#define ANYOF_SKIP ((ANYOF_SIZE - 1)/sizeof(regnode))
+#define ANYOF_CLASS_SKIP ((ANYOF_CLASS_SIZE - 1)/sizeof(regnode))
+#define ANYOF_CLASS_ADD_SKIP (ANYOF_CLASS_SKIP - ANYOF_SKIP)
+
+
+/*
+ * Utility definitions.
+ */
+#ifndef CHARMASK
+# define UCHARAT(p) ((int)*(const U8*)(p))
+#else
+# define UCHARAT(p) ((int)*(p)&CHARMASK)
+#endif
+
+#define EXTRA_SIZE(guy) ((sizeof(guy)-1)/sizeof(struct regnode))
+
+#define REG_SEEN_ZERO_LEN 0x00000001
+#define REG_SEEN_LOOKBEHIND 0x00000002
+#define REG_SEEN_GPOS 0x00000004
+#define REG_SEEN_EVAL 0x00000008
+#define REG_SEEN_CANY 0x00000010
+#define REG_SEEN_SANY REG_SEEN_CANY /* src bckwrd cmpt */
+#define REG_SEEN_RECURSE 0x00000020
+#define REG_TOP_LEVEL_BRANCHES 0x00000040
+#define REG_SEEN_VERBARG 0x00000080
+#define REG_SEEN_CUTGROUP 0x00000100
+#define REG_SEEN_RUN_ON_COMMENT 0x00000200
+
+START_EXTERN_C
+
+#ifdef PLUGGABLE_RE_EXTENSION
+#include "re_nodes.h"
+#else
+#include "regnodes.h"
+#endif
+
+/* The following have no fixed length. U8 so we can do strchr() on it. */
+#ifndef DOINIT
+EXTCONST U8 PL_varies[];
+#else
+EXTCONST U8 PL_varies[] = {
+ BRANCH, BACK, STAR, PLUS, CURLY, CURLYX, REF, REFF, REFFL,
+ WHILEM, CURLYM, CURLYN, BRANCHJ, IFTHEN, SUSPEND, CLUMP,
+ NREF, NREFF, NREFFL,
+ 0
+};
+#endif
+
+/* The following always have a length of 1. U8 we can do strchr() on it. */
+/* (Note that length 1 means "one character" under UTF8, not "one octet".) */
+#ifndef DOINIT
+EXTCONST U8 PL_simple[];
+#else
+EXTCONST U8 PL_simple[] = {
+ REG_ANY, SANY, CANY,
+ ANYOF,
+ ALNUM, ALNUML,
+ NALNUM, NALNUML,
+ SPACE, SPACEL,
+ NSPACE, NSPACEL,
+ DIGIT, NDIGIT,
+ VERTWS, NVERTWS,
+ HORIZWS, NHORIZWS,
+ 0
+};
+#endif
+
+#ifndef PLUGGABLE_RE_EXTENSION
+#ifndef DOINIT
+EXTCONST regexp_engine PL_core_reg_engine;
+#else /* DOINIT */
+EXTCONST regexp_engine PL_core_reg_engine = {
+ Perl_re_compile,
+ Perl_regexec_flags,
+ Perl_re_intuit_start,
+ Perl_re_intuit_string,
+ Perl_regfree_internal,
+ Perl_reg_numbered_buff_fetch,
+ Perl_reg_numbered_buff_store,
+ Perl_reg_numbered_buff_length,
+ Perl_reg_named_buff,
+ Perl_reg_named_buff_iter,
+ Perl_reg_qr_package,
+#if defined(USE_ITHREADS)
+ Perl_regdupe_internal
+#endif
+};
+#endif /* DOINIT */
+#endif /* PLUGGABLE_RE_EXTENSION */
+
+
+END_EXTERN_C
+
+
+/* .what is a character array with one character for each member of .data
+ * The character describes the function of the corresponding .data item:
+ * f - start-class data for regstclass optimization
+ * n - Root of op tree for (?{EVAL}) item
+ * o - Start op for (?{EVAL}) item
+ * p - Pad for (?{EVAL}) item
+ * s - swash for Unicode-style character class, and the multicharacter
+ * strings resulting from casefolding the single-character entries
+ * in the character class
+ * t - trie struct
+ * u - trie struct's widecharmap (a HV, so can't share, must dup)
+ * also used for revcharmap and words under DEBUGGING
+ * T - aho-trie struct
+ * S - sv for named capture lookup
+ * 20010712 mjd@plover.com
+ * (Remember to update re_dup() and pregfree() if you add any items.)
+ */
+struct reg_data {
+ U32 count;
+ U8 *what;
+ void* data[1];
+};
+
+/* Code in S_to_utf8_substr() and S_to_byte_substr() in regexec.c accesses
+ anchored* and float* via array indexes 0 and 1. */
+#define anchored_substr substrs->data[0].substr
+#define anchored_utf8 substrs->data[0].utf8_substr
+#define anchored_offset substrs->data[0].min_offset
+#define anchored_end_shift substrs->data[0].end_shift
+
+#define float_substr substrs->data[1].substr
+#define float_utf8 substrs->data[1].utf8_substr
+#define float_min_offset substrs->data[1].min_offset
+#define float_max_offset substrs->data[1].max_offset
+#define float_end_shift substrs->data[1].end_shift
+
+#define check_substr substrs->data[2].substr
+#define check_utf8 substrs->data[2].utf8_substr
+#define check_offset_min substrs->data[2].min_offset
+#define check_offset_max substrs->data[2].max_offset
+#define check_end_shift substrs->data[2].end_shift
+
+#define RX_ANCHORED_SUBSTR(rx) ((rx)->anchored_substr)
+#define RX_ANCHORED_UTF8(rx) ((rx)->anchored_utf8)
+#define RX_FLOAT_SUBSTR(rx) ((rx)->float_substr)
+#define RX_FLOAT_UTF8(rx) ((rx)->float_utf8)
+
+/* trie related stuff */
+
+/* a transition record for the state machine. the
+ check field determines which state "owns" the
+ transition. the char the transition is for is
+ determined by offset from the owning states base
+ field. the next field determines which state
+ is to be transitioned to if any.
+*/
+struct _reg_trie_trans {
+ U32 next;
+ U32 check;
+};
+
+/* a transition list element for the list based representation */
+struct _reg_trie_trans_list_elem {
+ U16 forid;
+ U32 newstate;
+};
+typedef struct _reg_trie_trans_list_elem reg_trie_trans_le;
+
+/* a state for compressed nodes. base is an offset
+ into an array of reg_trie_trans array. If wordnum is
+ nonzero the state is accepting. if base is zero then
+ the state has no children (and will be accepting)
+*/
+struct _reg_trie_state {
+ U16 wordnum;
+ union {
+ U32 base;
+ reg_trie_trans_le* list;
+ } trans;
+};
+
+
+
+typedef struct _reg_trie_state reg_trie_state;
+typedef struct _reg_trie_trans reg_trie_trans;
+
+
+/* anything in here that needs to be freed later
+ should be dealt with in pregfree.
+ refcount is first in both this and _reg_ac_data to allow a space
+ optimisation in Perl_regdupe. */
+struct _reg_trie_data {
+ U32 refcount; /* number of times this trie is referenced */
+ U32 lasttrans; /* last valid transition element */
+ U16 *charmap; /* byte to charid lookup array */
+ reg_trie_state *states; /* state data */
+ reg_trie_trans *trans; /* array of transition elements */
+ char *bitmap; /* stclass bitmap */
+ U32 *wordlen; /* array of lengths of words */
+ U16 *jump; /* optional 1 indexed array of offsets before tail
+ for the node following a given word. */
+ U16 *nextword; /* optional 1 indexed array to support linked list
+ of duplicate wordnums */
+ U16 uniquecharcount; /* unique chars in trie (width of trans table) */
+ U32 startstate; /* initial state - used for common prefix optimisation */
+ STRLEN minlen; /* minimum length of words in trie - build/opt only? */
+ STRLEN maxlen; /* maximum length of words in trie - build/opt only? */
+ U32 statecount; /* Build only - number of states in the states array
+ (including the unused zero state) */
+ U32 wordcount; /* Build only */
+#ifdef DEBUGGING
+ STRLEN charcount; /* Build only */
+#endif
+};
+/* There is one (3 under DEBUGGING) pointers that logically belong in this
+ structure, but are held outside as they need duplication on thread cloning,
+ whereas the rest of the structure can be read only:
+ HV *widecharmap; code points > 255 to charid
+#ifdef DEBUGGING
+ AV *words; Array of words contained in trie, for dumping
+ AV *revcharmap; Map of each charid back to its character representation
+#endif
+*/
+
+#define TRIE_WORDS_OFFSET 2
+
+typedef struct _reg_trie_data reg_trie_data;
+
+/* refcount is first in both this and _reg_trie_data to allow a space
+ optimisation in Perl_regdupe. */
+struct _reg_ac_data {
+ U32 refcount;
+ U32 trie;
+ U32 *fail;
+ reg_trie_state *states;
+};
+typedef struct _reg_ac_data reg_ac_data;
+
+/* ANY_BIT doesnt use the structure, so we can borrow it here.
+ This is simpler than refactoring all of it as wed end up with
+ three different sets... */
+
+#define TRIE_BITMAP(p) (((reg_trie_data *)(p))->bitmap)
+#define TRIE_BITMAP_BYTE(p, c) (TRIE_BITMAP(p)[(((U8)(c)) >> 3) & 31])
+#define TRIE_BITMAP_SET(p, c) (TRIE_BITMAP_BYTE(p, c) |= ANYOF_BIT((U8)c))
+#define TRIE_BITMAP_CLEAR(p,c) (TRIE_BITMAP_BYTE(p, c) &= ~ANYOF_BIT((U8)c))
+#define TRIE_BITMAP_TEST(p, c) (TRIE_BITMAP_BYTE(p, c) & ANYOF_BIT((U8)c))
+
+#define IS_ANYOF_TRIE(op) ((op)==TRIEC || (op)==AHOCORASICKC)
+#define IS_TRIE_AC(op) ((op)>=AHOCORASICK)
+
+
+#define BITMAP_BYTE(p, c) (((U8*)p)[(((U8)(c)) >> 3) & 31])
+#define BITMAP_TEST(p, c) (BITMAP_BYTE(p, c) & ANYOF_BIT((U8)c))
+
+/* these defines assume uniquecharcount is the correct variable, and state may be evaluated twice */
+#define TRIE_NODENUM(state) (((state)-1)/(trie->uniquecharcount)+1)
+#define SAFE_TRIE_NODENUM(state) ((state) ? (((state)-1)/(trie->uniquecharcount)+1) : (state))
+#define TRIE_NODEIDX(state) ((state) ? (((state)-1)*(trie->uniquecharcount)+1) : (state))
+
+#ifdef DEBUGGING
+#define TRIE_CHARCOUNT(trie) ((trie)->charcount)
+#else
+#define TRIE_CHARCOUNT(trie) (trie_charcount)
+#endif
+
+#define RE_TRIE_MAXBUF_INIT 65536
+#define RE_TRIE_MAXBUF_NAME "\022E_TRIE_MAXBUF"
+#define RE_DEBUG_FLAGS "\022E_DEBUG_FLAGS"
+
+/*
+
+RE_DEBUG_FLAGS is used to control what debug output is emitted
+its divided into three groups of options, some of which interact.
+The three groups are: Compile, Execute, Extra. There is room for a
+further group, as currently only the low three bytes are used.
+
+ Compile Options:
+
+ PARSE
+ PEEP
+ TRIE
+ PROGRAM
+ OFFSETS
+
+ Execute Options:
+
+ INTUIT
+ MATCH
+ TRIE
+
+ Extra Options
+
+ TRIE
+ OFFSETS
+
+If you modify any of these make sure you make corresponding changes to
+re.pm, especially to the documentation.
+
+*/
+
+
+/* Compile */
+#define RE_DEBUG_COMPILE_MASK 0x0000FF
+#define RE_DEBUG_COMPILE_PARSE 0x000001
+#define RE_DEBUG_COMPILE_OPTIMISE 0x000002
+#define RE_DEBUG_COMPILE_TRIE 0x000004
+#define RE_DEBUG_COMPILE_DUMP 0x000008
+#define RE_DEBUG_COMPILE_FLAGS 0x000010
+
+/* Execute */
+#define RE_DEBUG_EXECUTE_MASK 0x00FF00
+#define RE_DEBUG_EXECUTE_INTUIT 0x000100
+#define RE_DEBUG_EXECUTE_MATCH 0x000200
+#define RE_DEBUG_EXECUTE_TRIE 0x000400
+
+/* Extra */
+#define RE_DEBUG_EXTRA_MASK 0xFF0000
+#define RE_DEBUG_EXTRA_TRIE 0x010000
+#define RE_DEBUG_EXTRA_OFFSETS 0x020000
+#define RE_DEBUG_EXTRA_OFFDEBUG 0x040000
+#define RE_DEBUG_EXTRA_STATE 0x080000
+#define RE_DEBUG_EXTRA_OPTIMISE 0x100000
+#define RE_DEBUG_EXTRA_BUFFERS 0x400000
+/* combined */
+#define RE_DEBUG_EXTRA_STACK 0x280000
+
+#define RE_DEBUG_FLAG(x) (re_debug_flags & x)
+/* Compile */
+#define DEBUG_COMPILE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_COMPILE_MASK) x )
+#define DEBUG_PARSE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_COMPILE_PARSE) x )
+#define DEBUG_OPTIMISE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_COMPILE_OPTIMISE) x )
+#define DEBUG_PARSE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_COMPILE_PARSE) x )
+#define DEBUG_DUMP_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_COMPILE_DUMP) x )
+#define DEBUG_TRIE_COMPILE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_COMPILE_TRIE) x )
+#define DEBUG_FLAGS_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_COMPILE_FLAGS) x )
+/* Execute */
+#define DEBUG_EXECUTE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXECUTE_MASK) x )
+#define DEBUG_INTUIT_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXECUTE_INTUIT) x )
+#define DEBUG_MATCH_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXECUTE_MATCH) x )
+#define DEBUG_TRIE_EXECUTE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXECUTE_TRIE) x )
+
+/* Extra */
+#define DEBUG_EXTRA_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_MASK) x )
+#define DEBUG_OFFSETS_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_OFFSETS) x )
+#define DEBUG_STATE_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_STATE) x )
+#define DEBUG_STACK_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_STACK) x )
+#define DEBUG_BUFFERS_r(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_BUFFERS) x )
+
+#define DEBUG_OPTIMISE_MORE_r(x) DEBUG_r( \
+ if ((RE_DEBUG_EXTRA_OPTIMISE|RE_DEBUG_COMPILE_OPTIMISE) == \
+ (re_debug_flags & (RE_DEBUG_EXTRA_OPTIMISE|RE_DEBUG_COMPILE_OPTIMISE)) ) x )
+#define MJD_OFFSET_DEBUG(x) DEBUG_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_OFFDEBUG) \
+ Perl_warn_nocontext x )
+#define DEBUG_TRIE_COMPILE_MORE_r(x) DEBUG_TRIE_COMPILE_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_TRIE) x )
+#define DEBUG_TRIE_EXECUTE_MORE_r(x) DEBUG_TRIE_EXECUTE_r( \
+ if (re_debug_flags & RE_DEBUG_EXTRA_TRIE) x )
+
+#define DEBUG_TRIE_r(x) DEBUG_r( \
+ if (re_debug_flags & (RE_DEBUG_COMPILE_TRIE \
+ | RE_DEBUG_EXECUTE_TRIE )) x )
+
+/* initialization */
+/* get_sv() can return NULL during global destruction. */
+#define GET_RE_DEBUG_FLAGS DEBUG_r({ \
+ SV * re_debug_flags_sv = NULL; \
+ re_debug_flags_sv = get_sv(RE_DEBUG_FLAGS, 1); \
+ if (re_debug_flags_sv) { \
+ if (!SvIOK(re_debug_flags_sv)) \
+ sv_setuv(re_debug_flags_sv, RE_DEBUG_COMPILE_DUMP | RE_DEBUG_EXECUTE_MASK ); \
+ re_debug_flags=SvIV(re_debug_flags_sv); \
+ }\
+})
+
+#ifdef DEBUGGING
+
+#define GET_RE_DEBUG_FLAGS_DECL IV re_debug_flags = 0; GET_RE_DEBUG_FLAGS;
+
+#define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2) \
+ const char * const rpv = \
+ pv_pretty((dsv), (pv), (l), (m), \
+ PL_colors[(c1)],PL_colors[(c2)], \
+ PERL_PV_ESCAPE_RE |((isuni) ? PERL_PV_ESCAPE_UNI : 0) ); \
+ const int rlen = SvCUR(dsv)
+
+#define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m) \
+ const char * const rpv = \
+ pv_pretty((dsv), (SvPV_nolen_const(sv)), (SvCUR(sv)), (m), \
+ PL_colors[(c1)],PL_colors[(c2)], \
+ PERL_PV_ESCAPE_RE |((isuni) ? PERL_PV_ESCAPE_UNI : 0) )
+
+#define RE_PV_QUOTED_DECL(rpv,isuni,dsv,pv,l,m) \
+ const char * const rpv = \
+ pv_pretty((dsv), (pv), (l), (m), \
+ PL_colors[0], PL_colors[1], \
+ ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | \
+ ((isuni) ? PERL_PV_ESCAPE_UNI : 0)) \
+ )
+
+#define RE_SV_DUMPLEN(ItEm) (SvCUR(ItEm) - (SvTAIL(ItEm)!=0))
+#define RE_SV_TAIL(ItEm) (SvTAIL(ItEm) ? "$" : "")
+
+#else /* if not DEBUGGING */
+
+#define GET_RE_DEBUG_FLAGS_DECL
+#define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2)
+#define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m)
+#define RE_PV_QUOTED_DECL(rpv,isuni,dsv,pv,l,m)
+#define RE_SV_DUMPLEN(ItEm)
+#define RE_SV_TAIL(ItEm)
+
+#endif /* DEBUG RELATED DEFINES */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/regexp.h b/Master/tlpkg/tlperl.straw/lib/CORE/regexp.h
new file mode 100755
index 00000000000..a1417af2a7b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/regexp.h
@@ -0,0 +1,681 @@
+/* regexp.h
+ *
+ * Copyright (C) 1993, 1994, 1996, 1997, 1999, 2000, 2001, 2003,
+ * 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * Definitions etc. for regexp(3) routines.
+ *
+ * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof],
+ * not the System V one.
+ */
+#ifndef PLUGGABLE_RE_EXTENSION
+/* we don't want to include this stuff if we are inside of
+ an external regex engine based on the core one - like re 'debug'*/
+
+struct regnode {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+};
+
+typedef struct regnode regnode;
+
+struct reg_substr_data;
+
+struct reg_data;
+
+struct regexp_engine;
+struct regexp;
+
+struct reg_substr_datum {
+ I32 min_offset;
+ I32 max_offset;
+ SV *substr; /* non-utf8 variant */
+ SV *utf8_substr; /* utf8 variant */
+ I32 end_shift;
+};
+struct reg_substr_data {
+ struct reg_substr_datum data[3]; /* Actual array */
+};
+
+#ifdef PERL_OLD_COPY_ON_WRITE
+#define SV_SAVED_COPY SV *saved_copy; /* If non-NULL, SV which is COW from original */
+#else
+#define SV_SAVED_COPY
+#endif
+
+typedef struct regexp_paren_pair {
+ I32 start;
+ I32 end;
+} regexp_paren_pair;
+
+/*
+ The regexp/REGEXP struct, see L<perlreapi> for further documentation
+ on the individual fields. The struct is ordered so that the most
+ commonly used fields are placed at the start.
+
+ Any patch that adds items to this struct will need to include
+ changes to F<sv.c> (C<Perl_re_dup()>) and F<regcomp.c>
+ (C<pregfree()>). This involves freeing or cloning items in the
+ regexp's data array based on the data item's type.
+*/
+
+typedef struct regexp {
+ /* what engine created this regexp? */
+ const struct regexp_engine* engine;
+ struct regexp* mother_re; /* what re is this a lightweight copy of? */
+
+ /* Information about the match that the perl core uses to manage things */
+ U32 extflags; /* Flags used both externally and internally */
+ I32 minlen; /* mininum possible length of string to match */
+ I32 minlenret; /* mininum possible length of $& */
+ U32 gofs; /* chars left of pos that we search from */
+ struct reg_substr_data *substrs; /* substring data about strings that must appear
+ in the final match, used for optimisations */
+ U32 nparens; /* number of capture buffers */
+
+ /* private engine specific data */
+ U32 intflags; /* Engine Specific Internal flags */
+ void *pprivate; /* Data private to the regex engine which
+ created this object. */
+
+ /* Data about the last/current match. These are modified during matching*/
+ U32 lastparen; /* last open paren matched */
+ U32 lastcloseparen; /* last close paren matched */
+ regexp_paren_pair *swap; /* Swap copy of *offs */
+ regexp_paren_pair *offs; /* Array of offsets for (@-) and (@+) */
+
+ char *subbeg; /* saved or original string
+ so \digit works forever. */
+ SV_SAVED_COPY /* If non-NULL, SV which is COW from original */
+ I32 sublen; /* Length of string pointed by subbeg */
+
+
+ /* Information about the match that isn't often used */
+ I32 prelen; /* length of precomp */
+ const char *precomp; /* pre-compilation regular expression */
+ /* wrapped can't be const char*, as it is returned by sv_2pv_flags */
+ char *wrapped; /* wrapped version of the pattern */
+ I32 wraplen; /* length of wrapped */
+ I32 seen_evals; /* number of eval groups in the pattern - for security checks */
+ HV *paren_names; /* Optional hash of paren names */
+
+ /* Refcount of this regexp */
+ I32 refcnt; /* Refcount of this regexp */
+} regexp;
+
+#define RXp_PAREN_NAMES(rx) ((rx)->paren_names)
+
+/* used for high speed searches */
+typedef struct re_scream_pos_data_s
+{
+ char **scream_olds; /* match pos */
+ I32 *scream_pos; /* Internal iterator of scream. */
+} re_scream_pos_data;
+
+/* regexp_engine structure. This is the dispatch table for regexes.
+ * Any regex engine implementation must be able to build one of these.
+ */
+typedef struct regexp_engine {
+ REGEXP* (*comp) (pTHX_ const SV * const pattern, const U32 flags);
+ I32 (*exec) (pTHX_ REGEXP * const rx, char* stringarg, char* strend,
+ char* strbeg, I32 minend, SV* screamer,
+ void* data, U32 flags);
+ char* (*intuit) (pTHX_ REGEXP * const rx, SV *sv, char *strpos,
+ char *strend, const U32 flags,
+ re_scream_pos_data *data);
+ SV* (*checkstr) (pTHX_ REGEXP * const rx);
+ void (*free) (pTHX_ REGEXP * const rx);
+ void (*numbered_buff_FETCH) (pTHX_ REGEXP * const rx, const I32 paren,
+ SV * const sv);
+ void (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren,
+ SV const * const value);
+ I32 (*numbered_buff_LENGTH) (pTHX_ REGEXP * const rx, const SV * const sv,
+ const I32 paren);
+ SV* (*named_buff) (pTHX_ REGEXP * const rx, SV * const key,
+ SV * const value, const U32 flags);
+ SV* (*named_buff_iter) (pTHX_ REGEXP * const rx, const SV * const lastkey,
+ const U32 flags);
+ SV* (*qr_package)(pTHX_ REGEXP * const rx);
+#ifdef USE_ITHREADS
+ void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
+#endif
+} regexp_engine;
+
+/*
+ These are passed to the numbered capture variable callbacks as the
+ paren name. >= 1 is reserved for actual numbered captures, i.e. $1,
+ $2 etc.
+*/
+#define RX_BUFF_IDX_PREMATCH -2 /* $` / ${^PREMATCH} */
+#define RX_BUFF_IDX_POSTMATCH -1 /* $' / ${^POSTMATCH} */
+#define RX_BUFF_IDX_FULLMATCH 0 /* $& / ${^MATCH} */
+
+/*
+ Flags that are passed to the named_buff and named_buff_iter
+ callbacks above. Those routines are called from universal.c via the
+ Tie::Hash::NamedCapture interface for %+ and %- and the re::
+ functions in the same file.
+*/
+
+/* The Tie::Hash::NamedCapture operation this is part of, if any */
+#define RXapif_FETCH 0x0001
+#define RXapif_STORE 0x0002
+#define RXapif_DELETE 0x0004
+#define RXapif_CLEAR 0x0008
+#define RXapif_EXISTS 0x0010
+#define RXapif_SCALAR 0x0020
+#define RXapif_FIRSTKEY 0x0040
+#define RXapif_NEXTKEY 0x0080
+
+/* Whether %+ or %- is being operated on */
+#define RXapif_ONE 0x0100 /* %+ */
+#define RXapif_ALL 0x0200 /* %- */
+
+/* Whether this is being called from a re:: function */
+#define RXapif_REGNAME 0x0400
+#define RXapif_REGNAMES 0x0800
+#define RXapif_REGNAMES_COUNT 0x1000
+
+/*
+=head1 REGEXP Functions
+
+=for apidoc Am|REGEXP *|SvRX|SV *sv
+
+Convenience macro to get the REGEXP from a SV. This is approximately
+equivalent to the following snippet:
+
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv) &&
+ (tmpsv = (SV*)SvRV(sv)) &&
+ SvTYPE(tmpsv) == SVt_PVMG &&
+ (tmpmg = mg_find(tmpsv, PERL_MAGIC_qr)))
+ {
+ return (REGEXP *)tmpmg->mg_obj;
+ }
+
+NULL will be returned if a REGEXP* is not found.
+
+=for apidoc Am|bool|SvRXOK|SV* sv
+
+Returns a boolean indicating whether the SV contains qr magic
+(PERL_MAGIC_qr).
+
+If you want to do something with the REGEXP* later use SvRX instead
+and check for NULL.
+
+=cut
+*/
+
+#define SvRX(sv) (Perl_get_re_arg(aTHX_ sv))
+#define SvRXOK(sv) (Perl_get_re_arg(aTHX_ sv) ? TRUE : FALSE)
+
+
+/* Flags stored in regexp->extflags
+ * These are used by code external to the regexp engine
+ *
+ * Note that flags starting with RXf_PMf_ have exact equivalents
+ * stored in op_pmflags and which are defined in op.h, they are defined
+ * numerically here only for clarity.
+ *
+ * NOTE: if you modify any RXf flags you should run regen.pl or regcomp.pl
+ * so that regnodes.h is updated with the changes.
+ *
+ */
+
+/* Anchor and GPOS related stuff */
+#define RXf_ANCH_BOL 0x00000001
+#define RXf_ANCH_MBOL 0x00000002
+#define RXf_ANCH_SBOL 0x00000004
+#define RXf_ANCH_GPOS 0x00000008
+#define RXf_GPOS_SEEN 0x00000010
+#define RXf_GPOS_FLOAT 0x00000020
+/* two bits here */
+#define RXf_ANCH (RXf_ANCH_BOL|RXf_ANCH_MBOL|RXf_ANCH_GPOS|RXf_ANCH_SBOL)
+#define RXf_GPOS_CHECK (RXf_GPOS_SEEN|RXf_ANCH_GPOS)
+#define RXf_ANCH_SINGLE (RXf_ANCH_SBOL|RXf_ANCH_GPOS)
+
+/* Flags indicating special patterns */
+#define RXf_SKIPWHITE 0x00000100 /* Pattern is for a split / / */
+#define RXf_START_ONLY 0x00000200 /* Pattern is /^/ */
+#define RXf_WHITE 0x00000400 /* Pattern is /\s+/ */
+#define RXf_NULL 0x40000000 /* Pattern is // */
+
+/* 0x1F800 of extflags is used by (RXf_)PMf_COMPILETIME
+ * If you change these you need to change the equivalent flags in op.h, and
+ * vice versa. */
+#define RXf_PMf_LOCALE 0x00000800 /* use locale */
+#define RXf_PMf_MULTILINE 0x00001000 /* /m */
+#define RXf_PMf_SINGLELINE 0x00002000 /* /s */
+#define RXf_PMf_FOLD 0x00004000 /* /i */
+#define RXf_PMf_EXTENDED 0x00008000 /* /x */
+#define RXf_PMf_KEEPCOPY 0x00010000 /* /p */
+/* these flags are transfered from the PMOP->op_pmflags member during compilation */
+#define RXf_PMf_STD_PMMOD_SHIFT 12
+#define RXf_PMf_STD_PMMOD (RXf_PMf_MULTILINE|RXf_PMf_SINGLELINE|RXf_PMf_FOLD|RXf_PMf_EXTENDED)
+#define RXf_PMf_COMPILETIME (RXf_PMf_MULTILINE|RXf_PMf_SINGLELINE|RXf_PMf_LOCALE|RXf_PMf_FOLD|RXf_PMf_EXTENDED|RXf_PMf_KEEPCOPY)
+
+#define CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl) \
+ case IGNORE_PAT_MOD: *(pmfl) |= RXf_PMf_FOLD; break; \
+ case MULTILINE_PAT_MOD: *(pmfl) |= RXf_PMf_MULTILINE; break; \
+ case SINGLE_PAT_MOD: *(pmfl) |= RXf_PMf_SINGLELINE; break; \
+ case XTENDED_PAT_MOD: *(pmfl) |= RXf_PMf_EXTENDED; break
+
+/* chars and strings used as regex pattern modifiers
+ * Singlular is a 'c'har, plural is a "string"
+ *
+ * NOTE, KEEPCOPY was originally 'k', but was changed to 'p' for preserve
+ * for compatibility reasons with Regexp::Common which highjacked (?k:...)
+ * for its own uses. So 'k' is out as well.
+ */
+#define EXEC_PAT_MOD 'e'
+#define KEEPCOPY_PAT_MOD 'p'
+#define ONCE_PAT_MOD 'o'
+#define GLOBAL_PAT_MOD 'g'
+#define CONTINUE_PAT_MOD 'c'
+#define MULTILINE_PAT_MOD 'm'
+#define SINGLE_PAT_MOD 's'
+#define IGNORE_PAT_MOD 'i'
+#define XTENDED_PAT_MOD 'x'
+
+#define ONCE_PAT_MODS "o"
+#define KEEPCOPY_PAT_MODS "p"
+#define EXEC_PAT_MODS "e"
+#define LOOP_PAT_MODS "gc"
+
+#define STD_PAT_MODS "msix"
+
+#define INT_PAT_MODS STD_PAT_MODS KEEPCOPY_PAT_MODS
+
+#define EXT_PAT_MODS ONCE_PAT_MODS KEEPCOPY_PAT_MODS
+#define QR_PAT_MODS STD_PAT_MODS EXT_PAT_MODS
+#define M_PAT_MODS QR_PAT_MODS LOOP_PAT_MODS
+#define S_PAT_MODS M_PAT_MODS EXEC_PAT_MODS
+
+/*
+ * NOTE: if you modify any RXf flags you should run regen.pl or regcomp.pl
+ * so that regnodes.h is updated with the changes.
+ *
+ */
+
+/* What we have seen */
+#define RXf_LOOKBEHIND_SEEN 0x00020000
+#define RXf_EVAL_SEEN 0x00040000
+#define RXf_CANY_SEEN 0x00080000
+
+/* Special */
+#define RXf_NOSCAN 0x00100000
+#define RXf_CHECK_ALL 0x00200000
+
+/* UTF8 related */
+#define RXf_UTF8 0x00400000
+#define RXf_MATCH_UTF8 0x00800000
+
+/* Intuit related */
+#define RXf_USE_INTUIT_NOML 0x01000000
+#define RXf_USE_INTUIT_ML 0x02000000
+#define RXf_INTUIT_TAIL 0x04000000
+
+/*
+ Set in Perl_pmruntime if op_flags & OPf_SPECIAL, i.e. split. Will
+ be used by regex engines to check whether they should set
+ RXf_SKIPWHITE
+*/
+#define RXf_SPLIT 0x08000000
+
+#define RXf_USE_INTUIT (RXf_USE_INTUIT_NOML|RXf_USE_INTUIT_ML)
+
+/* Copy and tainted info */
+#define RXf_COPY_DONE 0x10000000
+#define RXf_TAINTED_SEEN 0x20000000
+#define RXf_TAINTED 0x80000000 /* this pattern is tainted */
+
+/*
+ * NOTE: if you modify any RXf flags you should run regen.pl or regcomp.pl
+ * so that regnodes.h is updated with the changes.
+ *
+ */
+
+#define RX_HAS_CUTGROUP(prog) ((prog)->intflags & PREGf_CUTGROUP_SEEN)
+#define RXp_MATCH_TAINTED(prog) (RXp_EXTFLAGS(prog) & RXf_TAINTED_SEEN)
+#define RX_MATCH_TAINTED(prog) (RX_EXTFLAGS(prog) & RXf_TAINTED_SEEN)
+#define RX_MATCH_TAINTED_on(prog) (RX_EXTFLAGS(prog) |= RXf_TAINTED_SEEN)
+#define RX_MATCH_TAINTED_off(prog) (RX_EXTFLAGS(prog) &= ~RXf_TAINTED_SEEN)
+#define RX_MATCH_TAINTED_set(prog, t) ((t) \
+ ? RX_MATCH_TAINTED_on(prog) \
+ : RX_MATCH_TAINTED_off(prog))
+
+#define RXp_MATCH_COPIED(prog) (RXp_EXTFLAGS(prog) & RXf_COPY_DONE)
+#define RX_MATCH_COPIED(prog) (RX_EXTFLAGS(prog) & RXf_COPY_DONE)
+#define RXp_MATCH_COPIED_on(prog) (RXp_EXTFLAGS(prog) |= RXf_COPY_DONE)
+#define RX_MATCH_COPIED_on(prog) (RX_EXTFLAGS(prog) |= RXf_COPY_DONE)
+#define RXp_MATCH_COPIED_off(prog) (RXp_EXTFLAGS(prog) &= ~RXf_COPY_DONE)
+#define RX_MATCH_COPIED_off(prog) (RX_EXTFLAGS(prog) &= ~RXf_COPY_DONE)
+#define RX_MATCH_COPIED_set(prog,t) ((t) \
+ ? RX_MATCH_COPIED_on(prog) \
+ : RX_MATCH_COPIED_off(prog))
+
+#define RXp_EXTFLAGS(rx) ((rx)->extflags)
+
+#define RX_PRECOMP(prog) ((prog)->precomp)
+/* *** 5.10.x-specific definition of RX_PRECOMP_const */
+#define RX_PRECOMP_const(prog) ((prog)->precomp)
+#define RX_PRELEN(prog) ((prog)->prelen)
+#define RX_WRAPPED(prog) ((prog)->wrapped)
+#define RX_WRAPLEN(prog) ((prog)->wraplen)
+#define RX_CHECK_SUBSTR(prog) ((prog)->check_substr)
+#define RX_EXTFLAGS(prog) ((prog)->extflags)
+#define RX_REFCNT(prog) ((prog)->refcnt)
+#define RX_ENGINE(prog) ((prog)->engine)
+#define RX_SUBBEG(prog) ((prog)->subbeg)
+#define RX_OFFS(prog) ((prog)->offs)
+#define RX_NPARENS(prog) ((prog)->nparens)
+#define RX_SUBLEN(prog) ((prog)->sublen)
+#define RX_SUBBEG(prog) ((prog)->subbeg)
+#define RX_MINLEN(prog) ((prog)->minlen)
+#define RX_MINLENRET(prog) ((prog)->minlenret)
+#define RX_GOFS(prog) ((prog)->gofs)
+#define RX_LASTPAREN(prog) ((prog)->lastparen)
+#define RX_LASTCLOSEPAREN(prog) ((prog)->lastcloseparen)
+#define RX_SEEN_EVALS(prog) ((prog)->seen_evals)
+
+#endif /* PLUGGABLE_RE_EXTENSION */
+
+/* Stuff that needs to be included in the plugable extension goes below here */
+
+#ifdef PERL_OLD_COPY_ON_WRITE
+#define RX_MATCH_COPY_FREE(rx) \
+ STMT_START {if (rx->saved_copy) { \
+ SV_CHECK_THINKFIRST_COW_DROP(rx->saved_copy); \
+ } \
+ if (RX_MATCH_COPIED(rx)) { \
+ Safefree(RX_SUBBEG(rx)); \
+ RX_MATCH_COPIED_off(rx); \
+ }} STMT_END
+#else
+#define RX_MATCH_COPY_FREE(rx) \
+ STMT_START {if (RX_MATCH_COPIED(rx)) { \
+ Safefree(RX_SUBBEG(rx)); \
+ RX_MATCH_COPIED_off(rx); \
+ }} STMT_END
+#endif
+
+#define RXp_MATCH_UTF8(prog) (RXp_EXTFLAGS(prog) & RXf_MATCH_UTF8)
+#define RX_MATCH_UTF8(prog) (RX_EXTFLAGS(prog) & RXf_MATCH_UTF8)
+#define RX_MATCH_UTF8_on(prog) (RX_EXTFLAGS(prog) |= RXf_MATCH_UTF8)
+#define RX_MATCH_UTF8_off(prog) (RX_EXTFLAGS(prog) &= ~RXf_MATCH_UTF8)
+#define RX_MATCH_UTF8_set(prog, t) ((t) \
+ ? (RX_MATCH_UTF8_on(prog), (PL_reg_match_utf8 = 1)) \
+ : (RX_MATCH_UTF8_off(prog), (PL_reg_match_utf8 = 0)))
+
+/* Whether the pattern stored at RX_WRAPPED is in UTF-8 */
+#define RX_UTF8(prog) (RX_EXTFLAGS(prog) & RXf_UTF8)
+
+#define REXEC_COPY_STR 0x01 /* Need to copy the string. */
+#define REXEC_CHECKED 0x02 /* check_substr already checked. */
+#define REXEC_SCREAM 0x04 /* use scream table. */
+#define REXEC_IGNOREPOS 0x08 /* \G matches at start. */
+#define REXEC_NOT_FIRST 0x10 /* This is another iteration of //g. */
+
+#define ReREFCNT_inc(re) ((void)(re && re->refcnt++), re)
+#define ReREFCNT_dec(re) CALLREGFREE(re)
+
+#define FBMcf_TAIL_DOLLAR 1
+#define FBMcf_TAIL_DOLLARM 2
+#define FBMcf_TAIL_Z 4
+#define FBMcf_TAIL_z 8
+#define FBMcf_TAIL (FBMcf_TAIL_DOLLAR|FBMcf_TAIL_DOLLARM|FBMcf_TAIL_Z|FBMcf_TAIL_z)
+
+#define FBMrf_MULTILINE 1
+
+/* an accepting state/position*/
+struct _reg_trie_accepted {
+ U8 *endpos;
+ U16 wordnum;
+};
+typedef struct _reg_trie_accepted reg_trie_accepted;
+
+/* some basic information about the current match that is created by
+ * Perl_regexec_flags and then passed to regtry(), regmatch() etc */
+
+typedef struct {
+ regexp *prog;
+ char *bol;
+ char *till;
+ SV *sv;
+ char *ganch;
+ char *cutpoint;
+} regmatch_info;
+
+
+/* structures for holding and saving the state maintained by regmatch() */
+
+#ifndef MAX_RECURSE_EVAL_NOCHANGE_DEPTH
+#define MAX_RECURSE_EVAL_NOCHANGE_DEPTH 1000
+#endif
+
+typedef I32 CHECKPOINT;
+
+typedef struct regmatch_state {
+ int resume_state; /* where to jump to on return */
+ char *locinput; /* where to backtrack in string on failure */
+
+ union {
+
+ /* this is a fake union member that matches the first element
+ * of each member that needs to store positive backtrack
+ * information */
+ struct {
+ struct regmatch_state *prev_yes_state;
+ } yes;
+
+ /* branchlike members */
+ /* this is a fake union member that matches the first elements
+ * of each member that needs to behave like a branch */
+ struct {
+ /* this first element must match u.yes */
+ struct regmatch_state *prev_yes_state;
+ U32 lastparen;
+ CHECKPOINT cp;
+
+ } branchlike;
+
+ struct {
+ /* the first elements must match u.branchlike */
+ struct regmatch_state *prev_yes_state;
+ U32 lastparen;
+ CHECKPOINT cp;
+
+ regnode *next_branch; /* next branch node */
+ } branch;
+
+ struct {
+ /* the first elements must match u.branchlike */
+ struct regmatch_state *prev_yes_state;
+ U32 lastparen;
+ CHECKPOINT cp;
+
+ reg_trie_accepted *accept_buff; /* accepting states we have seen */
+ U32 accepted; /* how many accepting states we have seen */
+ U16 *jump; /* positive offsets from me */
+ regnode *B; /* node following the trie */
+ regnode *me; /* Which node am I - needed for jump tries*/
+ } trie;
+
+ /* special types - these members are used to store state for special
+ regops like eval, if/then, lookaround and the markpoint state */
+ struct {
+ /* this first element must match u.yes */
+ struct regmatch_state *prev_yes_state;
+ struct regmatch_state *prev_eval;
+ struct regmatch_state *prev_curlyx;
+ regexp *prev_rex;
+ U32 toggle_reg_flags; /* what bits in PL_reg_flags to
+ flip when transitioning between
+ inner and outer rexen */
+ CHECKPOINT cp; /* remember current savestack indexes */
+ CHECKPOINT lastcp;
+ U32 close_paren; /* which close bracket is our end */
+ regnode *B; /* the node following us */
+ } eval;
+
+ struct {
+ /* this first element must match u.yes */
+ struct regmatch_state *prev_yes_state;
+ I32 wanted;
+ I32 logical; /* saved copy of 'logical' var */
+ regnode *me; /* the IFMATCH/SUSPEND/UNLESSM node */
+ } ifmatch; /* and SUSPEND/UNLESSM */
+
+ struct {
+ /* this first element must match u.yes */
+ struct regmatch_state *prev_yes_state;
+ struct regmatch_state *prev_mark;
+ SV* mark_name;
+ char *mark_loc;
+ } mark;
+
+ struct {
+ int val;
+ } keeper;
+
+ /* quantifiers - these members are used for storing state for
+ for the regops used to implement quantifiers */
+ struct {
+ /* this first element must match u.yes */
+ struct regmatch_state *prev_yes_state;
+ struct regmatch_state *prev_curlyx; /* previous cur_curlyx */
+ regnode *A, *B; /* the nodes corresponding to /A*B/ */
+ CHECKPOINT cp; /* remember current savestack index */
+ bool minmod;
+ int parenfloor;/* how far back to strip paren data */
+ int min; /* the minimal number of A's to match */
+ int max; /* the maximal number of A's to match */
+
+ /* these two are modified by WHILEM */
+ int count; /* how many instances of A we've matched */
+ char *lastloc;/* where previous A matched (0-len detect) */
+ } curlyx;
+
+ struct {
+ /* this first element must match u.yes */
+ struct regmatch_state *prev_yes_state;
+ struct regmatch_state *save_curlyx;
+ CHECKPOINT cp; /* remember current savestack indexes */
+ CHECKPOINT lastcp;
+ char *save_lastloc; /* previous curlyx.lastloc */
+ I32 cache_offset;
+ I32 cache_mask;
+ } whilem;
+
+ struct {
+ /* this first element must match u.yes */
+ struct regmatch_state *prev_yes_state;
+ I32 c1, c2; /* case fold search */
+ CHECKPOINT cp;
+ I32 alen; /* length of first-matched A string */
+ I32 count;
+ bool minmod;
+ regnode *A, *B; /* the nodes corresponding to /A*B/ */
+ regnode *me; /* the curlym node */
+ } curlym;
+
+ struct {
+ U32 paren;
+ CHECKPOINT cp;
+ I32 c1, c2; /* case fold search */
+ char *maxpos; /* highest possible point in string to match */
+ char *oldloc; /* the previous locinput */
+ int count;
+ int min, max; /* {m,n} */
+ regnode *A, *B; /* the nodes corresponding to /A*B/ */
+ } curly; /* and CURLYN/PLUS/STAR */
+
+ } u;
+} regmatch_state;
+
+/* how many regmatch_state structs to allocate as a single slab.
+ * We do it in 4K blocks for efficiency. The "3" is 2 for the next/prev
+ * pointers, plus 1 for any mythical malloc overhead. */
+
+#define PERL_REGMATCH_SLAB_SLOTS \
+ ((4096 - 3 * sizeof (void*)) / sizeof(regmatch_state))
+
+typedef struct regmatch_slab {
+ regmatch_state states[PERL_REGMATCH_SLAB_SLOTS];
+ struct regmatch_slab *prev, *next;
+} regmatch_slab;
+
+#define PL_reg_flags PL_reg_state.re_state_reg_flags
+#define PL_bostr PL_reg_state.re_state_bostr
+#define PL_reginput PL_reg_state.re_state_reginput
+#define PL_regeol PL_reg_state.re_state_regeol
+#define PL_regoffs PL_reg_state.re_state_regoffs
+#define PL_reglastparen PL_reg_state.re_state_reglastparen
+#define PL_reglastcloseparen PL_reg_state.re_state_reglastcloseparen
+#define PL_reg_start_tmp PL_reg_state.re_state_reg_start_tmp
+#define PL_reg_start_tmpl PL_reg_state.re_state_reg_start_tmpl
+#define PL_reg_eval_set PL_reg_state.re_state_reg_eval_set
+#define PL_reg_match_utf8 PL_reg_state.re_state_reg_match_utf8
+#define PL_reg_magic PL_reg_state.re_state_reg_magic
+#define PL_reg_oldpos PL_reg_state.re_state_reg_oldpos
+#define PL_reg_oldcurpm PL_reg_state.re_state_reg_oldcurpm
+#define PL_reg_curpm PL_reg_state.re_state_reg_curpm
+#define PL_reg_oldsaved PL_reg_state.re_state_reg_oldsaved
+#define PL_reg_oldsavedlen PL_reg_state.re_state_reg_oldsavedlen
+#define PL_reg_maxiter PL_reg_state.re_state_reg_maxiter
+#define PL_reg_leftiter PL_reg_state.re_state_reg_leftiter
+#define PL_reg_poscache PL_reg_state.re_state_reg_poscache
+#define PL_reg_poscache_size PL_reg_state.re_state_reg_poscache_size
+#define PL_regsize PL_reg_state.re_state_regsize
+#define PL_reg_starttry PL_reg_state.re_state_reg_starttry
+#define PL_nrs PL_reg_state.re_state_nrs
+
+struct re_save_state {
+ U32 re_state_reg_flags; /* from regexec.c */
+ U32 re_state_reg_start_tmpl; /* from regexec.c */
+ I32 re_state_reg_eval_set; /* from regexec.c */
+ bool re_state_reg_match_utf8; /* from regexec.c */
+ char *re_state_bostr;
+ char *re_state_reginput; /* String-input pointer. */
+ char *re_state_regeol; /* End of input, for $ check. */
+ regexp_paren_pair *re_state_regoffs; /* Pointer to start/end pairs */
+ U32 *re_state_reglastparen; /* Similarly for lastparen. */
+ U32 *re_state_reglastcloseparen; /* Similarly for lastcloseparen. */
+ char **re_state_reg_start_tmp; /* from regexec.c */
+ MAGIC *re_state_reg_magic; /* from regexec.c */
+ PMOP *re_state_reg_oldcurpm; /* from regexec.c */
+ PMOP *re_state_reg_curpm; /* from regexec.c */
+ char *re_state_reg_oldsaved; /* old saved substr during match */
+ STRLEN re_state_reg_oldsavedlen; /* old length of saved substr during match */
+ STRLEN re_state_reg_poscache_size; /* size of pos cache of WHILEM */
+ I32 re_state_reg_oldpos; /* from regexec.c */
+ I32 re_state_reg_maxiter; /* max wait until caching pos */
+ I32 re_state_reg_leftiter; /* wait until caching pos */
+ U32 re_state_regsize; /* from regexec.c */
+ char *re_state_reg_poscache; /* cache of pos of WHILEM */
+ char *re_state_reg_starttry; /* from regexec.c */
+#ifdef PERL_OLD_COPY_ON_WRITE
+ SV *re_state_nrs; /* was placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012). Used to save rx->saved_copy */
+#endif
+};
+
+#define SAVESTACK_ALLOC_FOR_RE_SAVE_STATE \
+ (1 + ((sizeof(struct re_save_state) - 1) / sizeof(*PL_savestack)))
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/regnodes.h b/Master/tlpkg/tlperl.straw/lib/CORE/regnodes.h
new file mode 100755
index 00000000000..1697a12973c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/regnodes.h
@@ -0,0 +1,664 @@
+/* -*- buffer-read-only: t -*-
+ !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by regcomp.pl from regcomp.sym.
+ Any changes made here will be lost!
+*/
+
+/* Regops and State definitions */
+
+#define REGNODE_MAX 90
+#define REGMATCH_STATE_MAX 130
+
+#define END 0 /* 0000 End of program. */
+#define SUCCEED 1 /* 0x01 Return from a subroutine, basically. */
+#define BOL 2 /* 0x02 Match "" at beginning of line. */
+#define MBOL 3 /* 0x03 Same, assuming multiline. */
+#define SBOL 4 /* 0x04 Same, assuming singleline. */
+#define EOS 5 /* 0x05 Match "" at end of string. */
+#define EOL 6 /* 0x06 Match "" at end of line. */
+#define MEOL 7 /* 0x07 Same, assuming multiline. */
+#define SEOL 8 /* 0x08 Same, assuming singleline. */
+#define BOUND 9 /* 0x09 Match "" at any word boundary */
+#define BOUNDL 10 /* 0x0a Match "" at any word boundary */
+#define NBOUND 11 /* 0x0b Match "" at any word non-boundary */
+#define NBOUNDL 12 /* 0x0c Match "" at any word non-boundary */
+#define GPOS 13 /* 0x0d Matches where last m//g left off. */
+#define REG_ANY 14 /* 0x0e Match any one character (except newline). */
+#define SANY 15 /* 0x0f Match any one character. */
+#define CANY 16 /* 0x10 Match any one byte. */
+#define ANYOF 17 /* 0x11 Match character in (or not in) this class. */
+#define ALNUM 18 /* 0x12 Match any alphanumeric character */
+#define ALNUML 19 /* 0x13 Match any alphanumeric char in locale */
+#define NALNUM 20 /* 0x14 Match any non-alphanumeric character */
+#define NALNUML 21 /* 0x15 Match any non-alphanumeric char in locale */
+#define SPACE 22 /* 0x16 Match any whitespace character */
+#define SPACEL 23 /* 0x17 Match any whitespace char in locale */
+#define NSPACE 24 /* 0x18 Match any non-whitespace character */
+#define NSPACEL 25 /* 0x19 Match any non-whitespace char in locale */
+#define DIGIT 26 /* 0x1a Match any numeric character */
+#define DIGITL 27 /* 0x1b Match any numeric character in locale */
+#define NDIGIT 28 /* 0x1c Match any non-numeric character */
+#define NDIGITL 29 /* 0x1d Match any non-numeric character in locale */
+#define CLUMP 30 /* 0x1e Match any combining character sequence */
+#define BRANCH 31 /* 0x1f Match this alternative, or the next... */
+#define BACK 32 /* 0x20 Match "", "next" ptr points backward. */
+#define EXACT 33 /* 0x21 Match this string (preceded by length). */
+#define EXACTF 34 /* 0x22 Match this string, folded (prec. by length). */
+#define EXACTFL 35 /* 0x23 Match this string, folded in locale (w/len). */
+#define NOTHING 36 /* 0x24 Match empty string. */
+#define TAIL 37 /* 0x25 Match empty string. Can jump here from outside. */
+#define STAR 38 /* 0x26 Match this (simple) thing 0 or more times. */
+#define PLUS 39 /* 0x27 Match this (simple) thing 1 or more times. */
+#define CURLY 40 /* 0x28 Match this simple thing {n,m} times. */
+#define CURLYN 41 /* 0x29 Capture next-after-this simple thing */
+#define CURLYM 42 /* 0x2a Capture this medium-complex thing {n,m} times. */
+#define CURLYX 43 /* 0x2b Match this complex thing {n,m} times. */
+#define WHILEM 44 /* 0x2c Do curly processing and see if rest matches. */
+#define OPEN 45 /* 0x2d Mark this point in input as start of */
+#define CLOSE 46 /* 0x2e Analogous to OPEN. */
+#define REF 47 /* 0x2f Match some already matched string */
+#define REFF 48 /* 0x30 Match already matched string, folded */
+#define REFFL 49 /* 0x31 Match already matched string, folded in loc. */
+#define IFMATCH 50 /* 0x32 Succeeds if the following matches. */
+#define UNLESSM 51 /* 0x33 Fails if the following matches. */
+#define SUSPEND 52 /* 0x34 "Independent" sub-RE. */
+#define IFTHEN 53 /* 0x35 Switch, should be preceeded by switcher . */
+#define GROUPP 54 /* 0x36 Whether the group matched. */
+#define LONGJMP 55 /* 0x37 Jump far away. */
+#define BRANCHJ 56 /* 0x38 BRANCH with long offset. */
+#define EVAL 57 /* 0x39 Execute some Perl code. */
+#define MINMOD 58 /* 0x3a Next operator is not greedy. */
+#define LOGICAL 59 /* 0x3b Next opcode should set the flag only. */
+#define RENUM 60 /* 0x3c Group with independently numbered parens. */
+#define TRIE 61 /* 0x3d Match many EXACT(FL?)? at once. flags==type */
+#define TRIEC 62 /* 0x3e Same as TRIE, but with embedded charclass data */
+#define AHOCORASICK 63 /* 0x3f Aho Corasick stclass. flags==type */
+#define AHOCORASICKC 64 /* 0x40 Same as AHOCORASICK, but with embedded charclass data */
+#define GOSUB 65 /* 0x41 recurse to paren arg1 at (signed) ofs arg2 */
+#define GOSTART 66 /* 0x42 recurse to start of pattern */
+#define NREF 67 /* 0x43 Match some already matched string */
+#define NREFF 68 /* 0x44 Match already matched string, folded */
+#define NREFFL 69 /* 0x45 Match already matched string, folded in loc. */
+#define NGROUPP 70 /* 0x46 Whether the group matched. */
+#define INSUBP 71 /* 0x47 Whether we are in a specific recurse. */
+#define DEFINEP 72 /* 0x48 Never execute directly. */
+#define ENDLIKE 73 /* 0x49 Used only for the type field of verbs */
+#define OPFAIL 74 /* 0x4a Same as (?!) */
+#define ACCEPT 75 /* 0x4b Accepts the current matched string. */
+#define VERB 76 /* 0x4c no-sv 1 Used only for the type field of verbs */
+#define PRUNE 77 /* 0x4d Pattern fails at this startpoint if no-backtracking through this */
+#define MARKPOINT 78 /* 0x4e Push the current location for rollback by cut. */
+#define SKIP 79 /* 0x4f On failure skip forward (to the mark) before retrying */
+#define COMMIT 80 /* 0x50 Pattern fails outright if backtracking through this */
+#define CUTGROUP 81 /* 0x51 On failure go to the next alternation in the group */
+#define KEEPS 82 /* 0x52 $& begins here. */
+#define LNBREAK 83 /* 0x53 generic newline pattern */
+#define VERTWS 84 /* 0x54 vertical whitespace (Perl 6) */
+#define NVERTWS 85 /* 0x55 not vertical whitespace (Perl 6) */
+#define HORIZWS 86 /* 0x56 horizontal whitespace (Perl 6) */
+#define NHORIZWS 87 /* 0x57 not horizontal whitespace (Perl 6) */
+#define FOLDCHAR 88 /* 0x58 codepoint with tricky case folding properties. */
+#define OPTIMIZED 89 /* 0x59 Placeholder for dump. */
+#define PSEUDO 90 /* 0x5a Pseudo opcode for internal use. */
+ /* ------------ States ------------- */
+#define TRIE_next (REGNODE_MAX + 1) /* state for TRIE */
+#define TRIE_next_fail (REGNODE_MAX + 2) /* state for TRIE */
+#define EVAL_AB (REGNODE_MAX + 3) /* state for EVAL */
+#define EVAL_AB_fail (REGNODE_MAX + 4) /* state for EVAL */
+#define CURLYX_end (REGNODE_MAX + 5) /* state for CURLYX */
+#define CURLYX_end_fail (REGNODE_MAX + 6) /* state for CURLYX */
+#define WHILEM_A_pre (REGNODE_MAX + 7) /* state for WHILEM */
+#define WHILEM_A_pre_fail (REGNODE_MAX + 8) /* state for WHILEM */
+#define WHILEM_A_min (REGNODE_MAX + 9) /* state for WHILEM */
+#define WHILEM_A_min_fail (REGNODE_MAX + 10) /* state for WHILEM */
+#define WHILEM_A_max (REGNODE_MAX + 11) /* state for WHILEM */
+#define WHILEM_A_max_fail (REGNODE_MAX + 12) /* state for WHILEM */
+#define WHILEM_B_min (REGNODE_MAX + 13) /* state for WHILEM */
+#define WHILEM_B_min_fail (REGNODE_MAX + 14) /* state for WHILEM */
+#define WHILEM_B_max (REGNODE_MAX + 15) /* state for WHILEM */
+#define WHILEM_B_max_fail (REGNODE_MAX + 16) /* state for WHILEM */
+#define BRANCH_next (REGNODE_MAX + 17) /* state for BRANCH */
+#define BRANCH_next_fail (REGNODE_MAX + 18) /* state for BRANCH */
+#define CURLYM_A (REGNODE_MAX + 19) /* state for CURLYM */
+#define CURLYM_A_fail (REGNODE_MAX + 20) /* state for CURLYM */
+#define CURLYM_B (REGNODE_MAX + 21) /* state for CURLYM */
+#define CURLYM_B_fail (REGNODE_MAX + 22) /* state for CURLYM */
+#define IFMATCH_A (REGNODE_MAX + 23) /* state for IFMATCH */
+#define IFMATCH_A_fail (REGNODE_MAX + 24) /* state for IFMATCH */
+#define CURLY_B_min_known (REGNODE_MAX + 25) /* state for CURLY */
+#define CURLY_B_min_known_fail (REGNODE_MAX + 26) /* state for CURLY */
+#define CURLY_B_min (REGNODE_MAX + 27) /* state for CURLY */
+#define CURLY_B_min_fail (REGNODE_MAX + 28) /* state for CURLY */
+#define CURLY_B_max (REGNODE_MAX + 29) /* state for CURLY */
+#define CURLY_B_max_fail (REGNODE_MAX + 30) /* state for CURLY */
+#define COMMIT_next (REGNODE_MAX + 31) /* state for COMMIT */
+#define COMMIT_next_fail (REGNODE_MAX + 32) /* state for COMMIT */
+#define MARKPOINT_next (REGNODE_MAX + 33) /* state for MARKPOINT */
+#define MARKPOINT_next_fail (REGNODE_MAX + 34) /* state for MARKPOINT */
+#define SKIP_next (REGNODE_MAX + 35) /* state for SKIP */
+#define SKIP_next_fail (REGNODE_MAX + 36) /* state for SKIP */
+#define CUTGROUP_next (REGNODE_MAX + 37) /* state for CUTGROUP */
+#define CUTGROUP_next_fail (REGNODE_MAX + 38) /* state for CUTGROUP */
+#define KEEPS_next (REGNODE_MAX + 39) /* state for KEEPS */
+#define KEEPS_next_fail (REGNODE_MAX + 40) /* state for KEEPS */
+
+/* PL_regkind[] What type of regop or state is this. */
+
+#ifndef DOINIT
+EXTCONST U8 PL_regkind[];
+#else
+EXTCONST U8 PL_regkind[] = {
+ END, /* END */
+ END, /* SUCCEED */
+ BOL, /* BOL */
+ BOL, /* MBOL */
+ BOL, /* SBOL */
+ EOL, /* EOS */
+ EOL, /* EOL */
+ EOL, /* MEOL */
+ EOL, /* SEOL */
+ BOUND, /* BOUND */
+ BOUND, /* BOUNDL */
+ NBOUND, /* NBOUND */
+ NBOUND, /* NBOUNDL */
+ GPOS, /* GPOS */
+ REG_ANY, /* REG_ANY */
+ REG_ANY, /* SANY */
+ REG_ANY, /* CANY */
+ ANYOF, /* ANYOF */
+ ALNUM, /* ALNUM */
+ ALNUM, /* ALNUML */
+ NALNUM, /* NALNUM */
+ NALNUM, /* NALNUML */
+ SPACE, /* SPACE */
+ SPACE, /* SPACEL */
+ NSPACE, /* NSPACE */
+ NSPACE, /* NSPACEL */
+ DIGIT, /* DIGIT */
+ DIGIT, /* DIGITL */
+ NDIGIT, /* NDIGIT */
+ NDIGIT, /* NDIGITL */
+ CLUMP, /* CLUMP */
+ BRANCH, /* BRANCH */
+ BACK, /* BACK */
+ EXACT, /* EXACT */
+ EXACT, /* EXACTF */
+ EXACT, /* EXACTFL */
+ NOTHING, /* NOTHING */
+ NOTHING, /* TAIL */
+ STAR, /* STAR */
+ PLUS, /* PLUS */
+ CURLY, /* CURLY */
+ CURLY, /* CURLYN */
+ CURLY, /* CURLYM */
+ CURLY, /* CURLYX */
+ WHILEM, /* WHILEM */
+ OPEN, /* OPEN */
+ CLOSE, /* CLOSE */
+ REF, /* REF */
+ REF, /* REFF */
+ REF, /* REFFL */
+ BRANCHJ, /* IFMATCH */
+ BRANCHJ, /* UNLESSM */
+ BRANCHJ, /* SUSPEND */
+ BRANCHJ, /* IFTHEN */
+ GROUPP, /* GROUPP */
+ LONGJMP, /* LONGJMP */
+ BRANCHJ, /* BRANCHJ */
+ EVAL, /* EVAL */
+ MINMOD, /* MINMOD */
+ LOGICAL, /* LOGICAL */
+ BRANCHJ, /* RENUM */
+ TRIE, /* TRIE */
+ TRIE, /* TRIEC */
+ TRIE, /* AHOCORASICK */
+ TRIE, /* AHOCORASICKC */
+ GOSUB, /* GOSUB */
+ GOSTART, /* GOSTART */
+ REF, /* NREF */
+ REF, /* NREFF */
+ REF, /* NREFFL */
+ NGROUPP, /* NGROUPP */
+ INSUBP, /* INSUBP */
+ DEFINEP, /* DEFINEP */
+ ENDLIKE, /* ENDLIKE */
+ ENDLIKE, /* OPFAIL */
+ ENDLIKE, /* ACCEPT */
+ VERB, /* VERB */
+ VERB, /* PRUNE */
+ VERB, /* MARKPOINT */
+ VERB, /* SKIP */
+ VERB, /* COMMIT */
+ VERB, /* CUTGROUP */
+ KEEPS, /* KEEPS */
+ LNBREAK, /* LNBREAK */
+ VERTWS, /* VERTWS */
+ NVERTWS, /* NVERTWS */
+ HORIZWS, /* HORIZWS */
+ NHORIZWS, /* NHORIZWS */
+ FOLDCHAR, /* FOLDCHAR */
+ NOTHING, /* OPTIMIZED */
+ PSEUDO, /* PSEUDO */
+ /* ------------ States ------------- */
+ TRIE, /* TRIE_next */
+ TRIE, /* TRIE_next_fail */
+ EVAL, /* EVAL_AB */
+ EVAL, /* EVAL_AB_fail */
+ CURLYX, /* CURLYX_end */
+ CURLYX, /* CURLYX_end_fail */
+ WHILEM, /* WHILEM_A_pre */
+ WHILEM, /* WHILEM_A_pre_fail */
+ WHILEM, /* WHILEM_A_min */
+ WHILEM, /* WHILEM_A_min_fail */
+ WHILEM, /* WHILEM_A_max */
+ WHILEM, /* WHILEM_A_max_fail */
+ WHILEM, /* WHILEM_B_min */
+ WHILEM, /* WHILEM_B_min_fail */
+ WHILEM, /* WHILEM_B_max */
+ WHILEM, /* WHILEM_B_max_fail */
+ BRANCH, /* BRANCH_next */
+ BRANCH, /* BRANCH_next_fail */
+ CURLYM, /* CURLYM_A */
+ CURLYM, /* CURLYM_A_fail */
+ CURLYM, /* CURLYM_B */
+ CURLYM, /* CURLYM_B_fail */
+ IFMATCH, /* IFMATCH_A */
+ IFMATCH, /* IFMATCH_A_fail */
+ CURLY, /* CURLY_B_min_known */
+ CURLY, /* CURLY_B_min_known_fail */
+ CURLY, /* CURLY_B_min */
+ CURLY, /* CURLY_B_min_fail */
+ CURLY, /* CURLY_B_max */
+ CURLY, /* CURLY_B_max_fail */
+ COMMIT, /* COMMIT_next */
+ COMMIT, /* COMMIT_next_fail */
+ MARKPOINT, /* MARKPOINT_next */
+ MARKPOINT, /* MARKPOINT_next_fail */
+ SKIP, /* SKIP_next */
+ SKIP, /* SKIP_next_fail */
+ CUTGROUP, /* CUTGROUP_next */
+ CUTGROUP, /* CUTGROUP_next_fail */
+ KEEPS, /* KEEPS_next */
+ KEEPS, /* KEEPS_next_fail */
+};
+#endif
+
+/* regarglen[] - How large is the argument part of the node (in regnodes) */
+
+#ifdef REG_COMP_C
+static const U8 regarglen[] = {
+ 0, /* END */
+ 0, /* SUCCEED */
+ 0, /* BOL */
+ 0, /* MBOL */
+ 0, /* SBOL */
+ 0, /* EOS */
+ 0, /* EOL */
+ 0, /* MEOL */
+ 0, /* SEOL */
+ 0, /* BOUND */
+ 0, /* BOUNDL */
+ 0, /* NBOUND */
+ 0, /* NBOUNDL */
+ 0, /* GPOS */
+ 0, /* REG_ANY */
+ 0, /* SANY */
+ 0, /* CANY */
+ 0, /* ANYOF */
+ 0, /* ALNUM */
+ 0, /* ALNUML */
+ 0, /* NALNUM */
+ 0, /* NALNUML */
+ 0, /* SPACE */
+ 0, /* SPACEL */
+ 0, /* NSPACE */
+ 0, /* NSPACEL */
+ 0, /* DIGIT */
+ 0, /* DIGITL */
+ 0, /* NDIGIT */
+ 0, /* NDIGITL */
+ 0, /* CLUMP */
+ 0, /* BRANCH */
+ 0, /* BACK */
+ 0, /* EXACT */
+ 0, /* EXACTF */
+ 0, /* EXACTFL */
+ 0, /* NOTHING */
+ 0, /* TAIL */
+ 0, /* STAR */
+ 0, /* PLUS */
+ EXTRA_SIZE(struct regnode_2), /* CURLY */
+ EXTRA_SIZE(struct regnode_2), /* CURLYN */
+ EXTRA_SIZE(struct regnode_2), /* CURLYM */
+ EXTRA_SIZE(struct regnode_2), /* CURLYX */
+ 0, /* WHILEM */
+ EXTRA_SIZE(struct regnode_1), /* OPEN */
+ EXTRA_SIZE(struct regnode_1), /* CLOSE */
+ EXTRA_SIZE(struct regnode_1), /* REF */
+ EXTRA_SIZE(struct regnode_1), /* REFF */
+ EXTRA_SIZE(struct regnode_1), /* REFFL */
+ EXTRA_SIZE(struct regnode_1), /* IFMATCH */
+ EXTRA_SIZE(struct regnode_1), /* UNLESSM */
+ EXTRA_SIZE(struct regnode_1), /* SUSPEND */
+ EXTRA_SIZE(struct regnode_1), /* IFTHEN */
+ EXTRA_SIZE(struct regnode_1), /* GROUPP */
+ EXTRA_SIZE(struct regnode_1), /* LONGJMP */
+ EXTRA_SIZE(struct regnode_1), /* BRANCHJ */
+ EXTRA_SIZE(struct regnode_1), /* EVAL */
+ 0, /* MINMOD */
+ 0, /* LOGICAL */
+ EXTRA_SIZE(struct regnode_1), /* RENUM */
+ EXTRA_SIZE(struct regnode_1), /* TRIE */
+ EXTRA_SIZE(struct regnode_charclass), /* TRIEC */
+ EXTRA_SIZE(struct regnode_1), /* AHOCORASICK */
+ EXTRA_SIZE(struct regnode_charclass), /* AHOCORASICKC */
+ EXTRA_SIZE(struct regnode_2L), /* GOSUB */
+ 0, /* GOSTART */
+ EXTRA_SIZE(struct regnode_1), /* NREF */
+ EXTRA_SIZE(struct regnode_1), /* NREFF */
+ EXTRA_SIZE(struct regnode_1), /* NREFFL */
+ EXTRA_SIZE(struct regnode_1), /* NGROUPP */
+ EXTRA_SIZE(struct regnode_1), /* INSUBP */
+ EXTRA_SIZE(struct regnode_1), /* DEFINEP */
+ 0, /* ENDLIKE */
+ 0, /* OPFAIL */
+ EXTRA_SIZE(struct regnode_1), /* ACCEPT */
+ 0, /* VERB */
+ EXTRA_SIZE(struct regnode_1), /* PRUNE */
+ EXTRA_SIZE(struct regnode_1), /* MARKPOINT */
+ EXTRA_SIZE(struct regnode_1), /* SKIP */
+ EXTRA_SIZE(struct regnode_1), /* COMMIT */
+ EXTRA_SIZE(struct regnode_1), /* CUTGROUP */
+ 0, /* KEEPS */
+ 0, /* LNBREAK */
+ 0, /* VERTWS */
+ 0, /* NVERTWS */
+ 0, /* HORIZWS */
+ 0, /* NHORIZWS */
+ EXTRA_SIZE(struct regnode_1), /* FOLDCHAR */
+ 0, /* OPTIMIZED */
+ 0, /* PSEUDO */
+};
+
+/* reg_off_by_arg[] - Which argument holds the offset to the next node */
+
+static const char reg_off_by_arg[] = {
+ 0, /* END */
+ 0, /* SUCCEED */
+ 0, /* BOL */
+ 0, /* MBOL */
+ 0, /* SBOL */
+ 0, /* EOS */
+ 0, /* EOL */
+ 0, /* MEOL */
+ 0, /* SEOL */
+ 0, /* BOUND */
+ 0, /* BOUNDL */
+ 0, /* NBOUND */
+ 0, /* NBOUNDL */
+ 0, /* GPOS */
+ 0, /* REG_ANY */
+ 0, /* SANY */
+ 0, /* CANY */
+ 0, /* ANYOF */
+ 0, /* ALNUM */
+ 0, /* ALNUML */
+ 0, /* NALNUM */
+ 0, /* NALNUML */
+ 0, /* SPACE */
+ 0, /* SPACEL */
+ 0, /* NSPACE */
+ 0, /* NSPACEL */
+ 0, /* DIGIT */
+ 0, /* DIGITL */
+ 0, /* NDIGIT */
+ 0, /* NDIGITL */
+ 0, /* CLUMP */
+ 0, /* BRANCH */
+ 0, /* BACK */
+ 0, /* EXACT */
+ 0, /* EXACTF */
+ 0, /* EXACTFL */
+ 0, /* NOTHING */
+ 0, /* TAIL */
+ 0, /* STAR */
+ 0, /* PLUS */
+ 0, /* CURLY */
+ 0, /* CURLYN */
+ 0, /* CURLYM */
+ 0, /* CURLYX */
+ 0, /* WHILEM */
+ 0, /* OPEN */
+ 0, /* CLOSE */
+ 0, /* REF */
+ 0, /* REFF */
+ 0, /* REFFL */
+ 2, /* IFMATCH */
+ 2, /* UNLESSM */
+ 1, /* SUSPEND */
+ 1, /* IFTHEN */
+ 0, /* GROUPP */
+ 1, /* LONGJMP */
+ 1, /* BRANCHJ */
+ 0, /* EVAL */
+ 0, /* MINMOD */
+ 0, /* LOGICAL */
+ 1, /* RENUM */
+ 0, /* TRIE */
+ 0, /* TRIEC */
+ 0, /* AHOCORASICK */
+ 0, /* AHOCORASICKC */
+ 0, /* GOSUB */
+ 0, /* GOSTART */
+ 0, /* NREF */
+ 0, /* NREFF */
+ 0, /* NREFFL */
+ 0, /* NGROUPP */
+ 0, /* INSUBP */
+ 0, /* DEFINEP */
+ 0, /* ENDLIKE */
+ 0, /* OPFAIL */
+ 0, /* ACCEPT */
+ 0, /* VERB */
+ 0, /* PRUNE */
+ 0, /* MARKPOINT */
+ 0, /* SKIP */
+ 0, /* COMMIT */
+ 0, /* CUTGROUP */
+ 0, /* KEEPS */
+ 0, /* LNBREAK */
+ 0, /* VERTWS */
+ 0, /* NVERTWS */
+ 0, /* HORIZWS */
+ 0, /* NHORIZWS */
+ 0, /* FOLDCHAR */
+ 0, /* OPTIMIZED */
+ 0, /* PSEUDO */
+};
+
+#endif /* REG_COMP_C */
+
+/* reg_name[] - Opcode/state names in string form, for debugging */
+
+#ifndef DOINIT
+EXTCONST char * PL_reg_name[];
+#else
+EXTCONST char * const PL_reg_name[] = {
+ "END", /* 0000 */
+ "SUCCEED", /* 0x01 */
+ "BOL", /* 0x02 */
+ "MBOL", /* 0x03 */
+ "SBOL", /* 0x04 */
+ "EOS", /* 0x05 */
+ "EOL", /* 0x06 */
+ "MEOL", /* 0x07 */
+ "SEOL", /* 0x08 */
+ "BOUND", /* 0x09 */
+ "BOUNDL", /* 0x0a */
+ "NBOUND", /* 0x0b */
+ "NBOUNDL", /* 0x0c */
+ "GPOS", /* 0x0d */
+ "REG_ANY", /* 0x0e */
+ "SANY", /* 0x0f */
+ "CANY", /* 0x10 */
+ "ANYOF", /* 0x11 */
+ "ALNUM", /* 0x12 */
+ "ALNUML", /* 0x13 */
+ "NALNUM", /* 0x14 */
+ "NALNUML", /* 0x15 */
+ "SPACE", /* 0x16 */
+ "SPACEL", /* 0x17 */
+ "NSPACE", /* 0x18 */
+ "NSPACEL", /* 0x19 */
+ "DIGIT", /* 0x1a */
+ "DIGITL", /* 0x1b */
+ "NDIGIT", /* 0x1c */
+ "NDIGITL", /* 0x1d */
+ "CLUMP", /* 0x1e */
+ "BRANCH", /* 0x1f */
+ "BACK", /* 0x20 */
+ "EXACT", /* 0x21 */
+ "EXACTF", /* 0x22 */
+ "EXACTFL", /* 0x23 */
+ "NOTHING", /* 0x24 */
+ "TAIL", /* 0x25 */
+ "STAR", /* 0x26 */
+ "PLUS", /* 0x27 */
+ "CURLY", /* 0x28 */
+ "CURLYN", /* 0x29 */
+ "CURLYM", /* 0x2a */
+ "CURLYX", /* 0x2b */
+ "WHILEM", /* 0x2c */
+ "OPEN", /* 0x2d */
+ "CLOSE", /* 0x2e */
+ "REF", /* 0x2f */
+ "REFF", /* 0x30 */
+ "REFFL", /* 0x31 */
+ "IFMATCH", /* 0x32 */
+ "UNLESSM", /* 0x33 */
+ "SUSPEND", /* 0x34 */
+ "IFTHEN", /* 0x35 */
+ "GROUPP", /* 0x36 */
+ "LONGJMP", /* 0x37 */
+ "BRANCHJ", /* 0x38 */
+ "EVAL", /* 0x39 */
+ "MINMOD", /* 0x3a */
+ "LOGICAL", /* 0x3b */
+ "RENUM", /* 0x3c */
+ "TRIE", /* 0x3d */
+ "TRIEC", /* 0x3e */
+ "AHOCORASICK", /* 0x3f */
+ "AHOCORASICKC", /* 0x40 */
+ "GOSUB", /* 0x41 */
+ "GOSTART", /* 0x42 */
+ "NREF", /* 0x43 */
+ "NREFF", /* 0x44 */
+ "NREFFL", /* 0x45 */
+ "NGROUPP", /* 0x46 */
+ "INSUBP", /* 0x47 */
+ "DEFINEP", /* 0x48 */
+ "ENDLIKE", /* 0x49 */
+ "OPFAIL", /* 0x4a */
+ "ACCEPT", /* 0x4b */
+ "VERB", /* 0x4c */
+ "PRUNE", /* 0x4d */
+ "MARKPOINT", /* 0x4e */
+ "SKIP", /* 0x4f */
+ "COMMIT", /* 0x50 */
+ "CUTGROUP", /* 0x51 */
+ "KEEPS", /* 0x52 */
+ "LNBREAK", /* 0x53 */
+ "VERTWS", /* 0x54 */
+ "NVERTWS", /* 0x55 */
+ "HORIZWS", /* 0x56 */
+ "NHORIZWS", /* 0x57 */
+ "FOLDCHAR", /* 0x58 */
+ "OPTIMIZED", /* 0x59 */
+ "PSEUDO", /* 0x5a */
+ /* ------------ States ------------- */
+ "TRIE_next", /* REGNODE_MAX +0x01 */
+ "TRIE_next_fail", /* REGNODE_MAX +0x02 */
+ "EVAL_AB", /* REGNODE_MAX +0x03 */
+ "EVAL_AB_fail", /* REGNODE_MAX +0x04 */
+ "CURLYX_end", /* REGNODE_MAX +0x05 */
+ "CURLYX_end_fail", /* REGNODE_MAX +0x06 */
+ "WHILEM_A_pre", /* REGNODE_MAX +0x07 */
+ "WHILEM_A_pre_fail", /* REGNODE_MAX +0x08 */
+ "WHILEM_A_min", /* REGNODE_MAX +0x09 */
+ "WHILEM_A_min_fail", /* REGNODE_MAX +0x0a */
+ "WHILEM_A_max", /* REGNODE_MAX +0x0b */
+ "WHILEM_A_max_fail", /* REGNODE_MAX +0x0c */
+ "WHILEM_B_min", /* REGNODE_MAX +0x0d */
+ "WHILEM_B_min_fail", /* REGNODE_MAX +0x0e */
+ "WHILEM_B_max", /* REGNODE_MAX +0x0f */
+ "WHILEM_B_max_fail", /* REGNODE_MAX +0x10 */
+ "BRANCH_next", /* REGNODE_MAX +0x11 */
+ "BRANCH_next_fail", /* REGNODE_MAX +0x12 */
+ "CURLYM_A", /* REGNODE_MAX +0x13 */
+ "CURLYM_A_fail", /* REGNODE_MAX +0x14 */
+ "CURLYM_B", /* REGNODE_MAX +0x15 */
+ "CURLYM_B_fail", /* REGNODE_MAX +0x16 */
+ "IFMATCH_A", /* REGNODE_MAX +0x17 */
+ "IFMATCH_A_fail", /* REGNODE_MAX +0x18 */
+ "CURLY_B_min_known", /* REGNODE_MAX +0x19 */
+ "CURLY_B_min_known_fail", /* REGNODE_MAX +0x1a */
+ "CURLY_B_min", /* REGNODE_MAX +0x1b */
+ "CURLY_B_min_fail", /* REGNODE_MAX +0x1c */
+ "CURLY_B_max", /* REGNODE_MAX +0x1d */
+ "CURLY_B_max_fail", /* REGNODE_MAX +0x1e */
+ "COMMIT_next", /* REGNODE_MAX +0x1f */
+ "COMMIT_next_fail", /* REGNODE_MAX +0x20 */
+ "MARKPOINT_next", /* REGNODE_MAX +0x21 */
+ "MARKPOINT_next_fail", /* REGNODE_MAX +0x22 */
+ "SKIP_next", /* REGNODE_MAX +0x23 */
+ "SKIP_next_fail", /* REGNODE_MAX +0x24 */
+ "CUTGROUP_next", /* REGNODE_MAX +0x25 */
+ "CUTGROUP_next_fail", /* REGNODE_MAX +0x26 */
+ "KEEPS_next", /* REGNODE_MAX +0x27 */
+ "KEEPS_next_fail", /* REGNODE_MAX +0x28 */
+};
+#endif /* DOINIT */
+
+/* PL_reg_extflags_name[] - Opcode/state names in string form, for debugging */
+
+#ifndef DOINIT
+EXTCONST char * PL_reg_extflags_name[];
+#else
+EXTCONST char * const PL_reg_extflags_name[] = {
+ /* Bits in extflags defined: 11111111111111111111111100111111 */
+ "ANCH_BOL", /* 0x00000001 */
+ "ANCH_MBOL", /* 0x00000002 */
+ "ANCH_SBOL", /* 0x00000004 */
+ "ANCH_GPOS", /* 0x00000008 */
+ "GPOS_SEEN", /* 0x00000010 */
+ "GPOS_FLOAT", /* 0x00000020 */
+ "UNUSED_BIT_6", /* 0x00000040 */
+ "UNUSED_BIT_7", /* 0x00000080 */
+ "SKIPWHITE", /* 0x00000100 */
+ "START_ONLY", /* 0x00000200 */
+ "WHITE", /* 0x00000400 */
+ "LOCALE", /* 0x00000800 */
+ "MULTILINE", /* 0x00001000 */
+ "SINGLELINE", /* 0x00002000 */
+ "FOLD", /* 0x00004000 */
+ "EXTENDED", /* 0x00008000 */
+ "KEEPCOPY", /* 0x00010000 */
+ "LOOKBEHIND_SEEN", /* 0x00020000 */
+ "EVAL_SEEN", /* 0x00040000 */
+ "CANY_SEEN", /* 0x00080000 */
+ "NOSCAN", /* 0x00100000 */
+ "CHECK_ALL", /* 0x00200000 */
+ "UTF8", /* 0x00400000 */
+ "MATCH_UTF8", /* 0x00800000 */
+ "USE_INTUIT_NOML", /* 0x01000000 */
+ "USE_INTUIT_ML", /* 0x02000000 */
+ "INTUIT_TAIL", /* 0x04000000 */
+ "SPLIT", /* 0x08000000 */
+ "COPY_DONE", /* 0x10000000 */
+ "TAINTED_SEEN", /* 0x20000000 */
+ "NULL", /* 0x40000000 */
+ "TAINTED", /* 0x80000000 */
+};
+#endif /* DOINIT */
+
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/scope.h b/Master/tlpkg/tlperl.straw/lib/CORE/scope.h
new file mode 100755
index 00000000000..b6976764e7d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/scope.h
@@ -0,0 +1,240 @@
+/* scope.h
+ *
+ * Copyright (C) 1993, 1994, 1996, 1997, 1998, 1999, 2000, 2001,
+ * 2002, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#define SAVEt_ITEM 0
+#define SAVEt_SV 1
+#define SAVEt_AV 2
+#define SAVEt_HV 3
+#define SAVEt_INT 4
+#define SAVEt_LONG 5
+#define SAVEt_I32 6
+#define SAVEt_IV 7
+#define SAVEt_SPTR 8
+#define SAVEt_APTR 9
+#define SAVEt_HPTR 10
+#define SAVEt_PPTR 11
+#define SAVEt_NSTAB 12
+#define SAVEt_SVREF 13
+#define SAVEt_GP 14
+#define SAVEt_FREESV 15
+#define SAVEt_FREEOP 16
+#define SAVEt_FREEPV 17
+#define SAVEt_CLEARSV 18
+#define SAVEt_DELETE 19
+#define SAVEt_DESTRUCTOR 20
+#define SAVEt_REGCONTEXT 21
+#define SAVEt_STACK_POS 22
+#define SAVEt_I16 23
+#define SAVEt_AELEM 24
+#define SAVEt_HELEM 25
+#define SAVEt_OP 26
+#define SAVEt_HINTS 27
+#define SAVEt_ALLOC 28
+#define SAVEt_GENERIC_SVREF 29
+#define SAVEt_DESTRUCTOR_X 30
+#define SAVEt_VPTR 31
+#define SAVEt_I8 32
+#define SAVEt_COMPPAD 33
+#define SAVEt_GENERIC_PVREF 34
+#define SAVEt_PADSV 35
+#define SAVEt_MORTALIZESV 36
+#define SAVEt_SHARED_PVREF 37
+#define SAVEt_BOOL 38
+#define SAVEt_SET_SVFLAGS 39
+#define SAVEt_SAVESWITCHSTACK 40
+#define SAVEt_COP_ARYBASE 41
+#define SAVEt_RE_STATE 42
+#define SAVEt_COMPILE_WARNINGS 43
+#define SAVEt_STACK_CXPOS 44
+#define SAVEt_PARSER 45
+#define SAVEt_PADSV_AND_MORTALIZE 46
+
+#ifndef SCOPE_SAVES_SIGNAL_MASK
+#define SCOPE_SAVES_SIGNAL_MASK 0
+#endif
+
+#define SSCHECK(need) if (PL_savestack_ix + (I32)(need) > PL_savestack_max) savestack_grow()
+#define SSGROW(need) if (PL_savestack_ix + (I32)(need) > PL_savestack_max) savestack_grow_cnt(need)
+#define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
+#define SSPUSHLONG(i) (PL_savestack[PL_savestack_ix++].any_long = (long)(i))
+#define SSPUSHBOOL(p) (PL_savestack[PL_savestack_ix++].any_bool = (p))
+#define SSPUSHIV(i) (PL_savestack[PL_savestack_ix++].any_iv = (IV)(i))
+#define SSPUSHPTR(p) (PL_savestack[PL_savestack_ix++].any_ptr = (void*)(p))
+#define SSPUSHDPTR(p) (PL_savestack[PL_savestack_ix++].any_dptr = (p))
+#define SSPUSHDXPTR(p) (PL_savestack[PL_savestack_ix++].any_dxptr = (p))
+#define SSPOPINT (PL_savestack[--PL_savestack_ix].any_i32)
+#define SSPOPLONG (PL_savestack[--PL_savestack_ix].any_long)
+#define SSPOPBOOL (PL_savestack[--PL_savestack_ix].any_bool)
+#define SSPOPIV (PL_savestack[--PL_savestack_ix].any_iv)
+#define SSPOPPTR (PL_savestack[--PL_savestack_ix].any_ptr)
+#define SSPOPDPTR (PL_savestack[--PL_savestack_ix].any_dptr)
+#define SSPOPDXPTR (PL_savestack[--PL_savestack_ix].any_dxptr)
+
+/*
+=head1 Callback Functions
+
+=for apidoc Ams||SAVETMPS
+Opening bracket for temporaries on a callback. See C<FREETMPS> and
+L<perlcall>.
+
+=for apidoc Ams||FREETMPS
+Closing bracket for temporaries on a callback. See C<SAVETMPS> and
+L<perlcall>.
+
+=for apidoc Ams||ENTER
+Opening bracket on a callback. See C<LEAVE> and L<perlcall>.
+
+=for apidoc Ams||LEAVE
+Closing bracket on a callback. See C<ENTER> and L<perlcall>.
+
+=cut
+*/
+
+#define SAVETMPS save_int((int*)&PL_tmps_floor), PL_tmps_floor = PL_tmps_ix
+#define FREETMPS if (PL_tmps_ix > PL_tmps_floor) free_tmps()
+
+#ifdef DEBUGGING
+#define ENTER \
+ STMT_START { \
+ push_scope(); \
+ DEBUG_SCOPE("ENTER") \
+ } STMT_END
+#define LEAVE \
+ STMT_START { \
+ DEBUG_SCOPE("LEAVE") \
+ pop_scope(); \
+ } STMT_END
+#else
+#define ENTER push_scope()
+#define LEAVE pop_scope()
+#endif
+#define LEAVE_SCOPE(old) if (PL_savestack_ix > old) leave_scope(old)
+
+#define SAVEI8(i) save_I8((I8*)&(i))
+#define SAVEI16(i) save_I16((I16*)&(i))
+#define SAVEI32(i) save_I32((I32*)&(i))
+#define SAVEINT(i) save_int((int*)&(i))
+#define SAVEIV(i) save_iv((IV*)&(i))
+#define SAVELONG(l) save_long((long*)&(l))
+#define SAVEBOOL(b) save_bool((bool*)&(b))
+#define SAVESPTR(s) save_sptr((SV**)&(s))
+#define SAVEPPTR(s) save_pptr((char**)&(s))
+#define SAVEVPTR(s) save_vptr((void*)&(s))
+#define SAVEPADSV(s) save_padsv(s)
+#define SAVEPADSVANDMORTALIZE(s) save_padsv_and_mortalize(s)
+#define SAVEFREESV(s) save_freesv(MUTABLE_SV(s))
+#define SAVEMORTALIZESV(s) save_mortalizesv(MUTABLE_SV(s))
+#define SAVEFREEOP(o) save_freeop((OP*)(o))
+#define SAVEFREEPV(p) save_freepv((char*)(p))
+#define SAVECLEARSV(sv) save_clearsv((SV**)&(sv))
+#define SAVEGENERICSV(s) save_generic_svref((SV**)&(s))
+#define SAVEGENERICPV(s) save_generic_pvref((char**)&(s))
+#define SAVESHAREDPV(s) save_shared_pvref((char**)&(s))
+#define SAVESETSVFLAGS(sv,mask,val) save_set_svflags(sv,mask,val)
+#define SAVEDELETE(h,k,l) \
+ save_delete(MUTABLE_HV(h), (char*)(k), (I32)(l))
+#define SAVEDESTRUCTOR(f,p) \
+ save_destructor((DESTRUCTORFUNC_NOCONTEXT_t)(f), (void*)(p))
+
+#define SAVEDESTRUCTOR_X(f,p) \
+ save_destructor_x((DESTRUCTORFUNC_t)(f), (void*)(p))
+
+#define SAVESTACK_POS() \
+ STMT_START { \
+ SSCHECK(2); \
+ SSPUSHINT(PL_stack_sp - PL_stack_base); \
+ SSPUSHINT(SAVEt_STACK_POS); \
+ } STMT_END
+
+#define SAVEOP() save_op()
+
+#define SAVEHINTS() save_hints()
+
+#define SAVECOMPPAD() save_pushptr(MUTABLE_SV(PL_comppad), SAVEt_COMPPAD)
+
+#define SAVESWITCHSTACK(f,t) \
+ STMT_START { \
+ save_pushptrptr(MUTABLE_SV(f), MUTABLE_SV(t), SAVEt_SAVESWITCHSTACK); \
+ SWITCHSTACK((f),(t)); \
+ PL_curstackinfo->si_stack = (t); \
+ } STMT_END
+
+#define SAVECOPARYBASE(c) save_pushi32ptr(CopARYBASE_get(c), c, SAVEt_COP_ARYBASE);
+
+/* Need to do the cop warnings like this, rather than a "SAVEFREESHAREDPV",
+ because realloc() means that the value can actually change. Possibly
+ could have done savefreesharedpvREF, but this way actually seems cleaner,
+ as it simplifies the code that does the saves, and reduces the load on the
+ save stack. */
+#define SAVECOMPILEWARNINGS() save_pushptr(PL_compiling.cop_warnings, SAVEt_COMPILE_WARNINGS)
+
+#define SAVESTACK_CXPOS() \
+ STMT_START { \
+ SSCHECK(3); \
+ SSPUSHINT(cxstack[cxstack_ix].blk_oldsp); \
+ SSPUSHINT(cxstack_ix); \
+ SSPUSHINT(SAVEt_STACK_CXPOS); \
+ } STMT_END
+
+#define SAVEPARSER(p) save_pushptr((p), SAVEt_PARSER)
+
+#ifdef USE_ITHREADS
+# define SAVECOPSTASH(c) SAVEPPTR(CopSTASHPV(c))
+# define SAVECOPSTASH_FREE(c) SAVESHAREDPV(CopSTASHPV(c))
+# define SAVECOPFILE(c) SAVEPPTR(CopFILE(c))
+# define SAVECOPFILE_FREE(c) SAVESHAREDPV(CopFILE(c))
+# define SAVECOPLABEL(c) SAVEPPTR(CopLABEL(c))
+# define SAVECOPLABEL_FREE(c) SAVESHAREDPV(CopLABEL(c))
+#else
+# define SAVECOPSTASH(c) SAVESPTR(CopSTASH(c))
+# define SAVECOPSTASH_FREE(c) SAVECOPSTASH(c) /* XXX not refcounted */
+# define SAVECOPFILE(c) SAVESPTR(CopFILEGV(c))
+# define SAVECOPFILE_FREE(c) SAVEGENERICSV(CopFILEGV(c))
+# define SAVECOPLABEL(c) SAVEPPTR(CopLABEL(c))
+# define SAVECOPLABEL_FREE(c) SAVEPPTR(CopLABEL(c))
+#endif
+
+#define SAVECOPLINE(c) SAVEI32(CopLINE(c))
+
+/* SSNEW() temporarily allocates a specified number of bytes of data on the
+ * savestack. It returns an integer index into the savestack, because a
+ * pointer would get broken if the savestack is moved on reallocation.
+ * SSNEWa() works like SSNEW(), but also aligns the data to the specified
+ * number of bytes. MEM_ALIGNBYTES is perhaps the most useful. The
+ * alignment will be preserved therough savestack reallocation *only* if
+ * realloc returns data aligned to a size divisible by "align"!
+ *
+ * SSPTR() converts the index returned by SSNEW/SSNEWa() into a pointer.
+ */
+
+#define SSNEW(size) Perl_save_alloc(aTHX_ (size), 0)
+#define SSNEWt(n,t) SSNEW((n)*sizeof(t))
+#define SSNEWa(size,align) Perl_save_alloc(aTHX_ (size), \
+ (I32)(align - ((size_t)((caddr_t)&PL_savestack[PL_savestack_ix]) % align)) % align)
+#define SSNEWat(n,t,align) SSNEWa((n)*sizeof(t), align)
+
+#define SSPTR(off,type) ((type) ((char*)PL_savestack + off))
+#define SSPTRt(off,type) ((type*) ((char*)PL_savestack + off))
+
+#define save_freesv(op) save_pushptr((void *)(op), SAVEt_FREESV)
+#define save_mortalizesv(op) save_pushptr((void *)(op), SAVEt_MORTALIZESV)
+#define save_freeop(op) save_pushptr((void *)(op), SAVEt_FREEOP)
+#define save_freepv(pv) save_pushptr((void *)(pv), SAVEt_FREEPV)
+#define save_op() save_pushptr((void *)(PL_op), SAVEt_OP)
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/sv.h b/Master/tlpkg/tlperl.straw/lib/CORE/sv.h
new file mode 100755
index 00000000000..ccb5be367a2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/sv.h
@@ -0,0 +1,2144 @@
+/* sv.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifdef sv_flags
+#undef sv_flags /* Convex has this in <signal.h> for sigvec() */
+#endif
+
+/*
+=head1 SV Flags
+
+=for apidoc AmU||svtype
+An enum of flags for Perl types. These are found in the file B<sv.h>
+in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
+
+=for apidoc AmU||SVt_PV
+Pointer type flag for scalars. See C<svtype>.
+
+=for apidoc AmU||SVt_IV
+Integer type flag for scalars. See C<svtype>.
+
+=for apidoc AmU||SVt_NV
+Double type flag for scalars. See C<svtype>.
+
+=for apidoc AmU||SVt_PVMG
+Type flag for blessed scalars. See C<svtype>.
+
+=for apidoc AmU||SVt_PVAV
+Type flag for arrays. See C<svtype>.
+
+=for apidoc AmU||SVt_PVHV
+Type flag for hashes. See C<svtype>.
+
+=for apidoc AmU||SVt_PVCV
+Type flag for code refs. See C<svtype>.
+
+=cut
+*/
+
+typedef enum {
+ SVt_NULL, /* 0 */
+ SVt_BIND, /* 1 */
+ SVt_IV, /* 2 */
+ SVt_NV, /* 3 */
+ SVt_RV, /* 4 */
+ SVt_PV, /* 5 */
+ SVt_PVIV, /* 6 */
+ SVt_PVNV, /* 7 */
+ SVt_PVMG, /* 8 */
+ /* PVBM was here, before BIND replaced it. */
+ SVt_PVGV, /* 9 */
+ SVt_PVLV, /* 10 */
+ SVt_PVAV, /* 11 */
+ SVt_PVHV, /* 12 */
+ SVt_PVCV, /* 13 */
+ SVt_PVFM, /* 14 */
+ SVt_PVIO, /* 15 */
+ SVt_LAST /* keep last in enum. used to size arrays */
+} svtype;
+
+#ifndef PERL_CORE
+/* Although Fast Boyer Moore tables are now being stored in PVGVs, for most
+ purposes eternal code wanting to consider PVBM probably needs to think of
+ PVMG instead. */
+# define SVt_PVBM SVt_PVMG
+#endif
+
+/* There is collusion here with sv_clear - sv_clear exits early for SVt_NULL
+ and SVt_IV, so never reaches the clause at the end that uses
+ sv_type_details->body_size to determine whether to call safefree(). Hence
+ body_size can be set no-zero to record the size of PTEs and HEs, without
+ fear of bogus frees. */
+#ifdef PERL_IN_SV_C
+#define PTE_SVSLOT SVt_IV
+#endif
+#if defined(PERL_IN_HV_C) || defined(PERL_IN_XS_APITEST)
+#define HE_SVSLOT SVt_NULL
+#endif
+
+#define PERL_ARENA_ROOTS_SIZE (SVt_LAST)
+
+/* typedefs to eliminate some typing */
+typedef struct he HE;
+typedef struct hek HEK;
+
+/* Using C's structural equivalence to help emulate C++ inheritance here... */
+
+/* start with 2 sv-head building blocks */
+#define _SV_HEAD(ptrtype) \
+ ptrtype sv_any; /* pointer to body */ \
+ U32 sv_refcnt; /* how many references to us */ \
+ U32 sv_flags /* what we are */
+
+#define _SV_HEAD_UNION \
+ union { \
+ IV svu_iv; \
+ UV svu_uv; \
+ SV* svu_rv; /* pointer to another SV */ \
+ char* svu_pv; /* pointer to malloced string */ \
+ SV** svu_array; \
+ HE** svu_hash; \
+ GP* svu_gp; \
+ } sv_u
+
+
+struct STRUCT_SV { /* struct sv { */
+ _SV_HEAD(void*);
+ _SV_HEAD_UNION;
+#ifdef DEBUG_LEAKING_SCALARS
+ PERL_BITFIELD32 sv_debug_optype:9; /* the type of OP that allocated us */
+ PERL_BITFIELD32 sv_debug_inpad:1; /* was allocated in a pad for an OP */
+ PERL_BITFIELD32 sv_debug_cloned:1; /* was cloned for an ithread */
+ PERL_BITFIELD32 sv_debug_line:16; /* the line where we were allocated */
+ U32 sv_debug_serial; /* serial number of sv allocation */
+ char * sv_debug_file; /* the file where we were allocated */
+#endif
+};
+
+struct gv {
+ _SV_HEAD(XPVGV*); /* pointer to xpvgv body */
+ _SV_HEAD_UNION;
+};
+
+struct cv {
+ _SV_HEAD(XPVCV*); /* pointer to xpvcv body */
+ _SV_HEAD_UNION;
+};
+
+struct av {
+ _SV_HEAD(XPVAV*); /* pointer to xpvav body */
+ _SV_HEAD_UNION;
+};
+
+struct hv {
+ _SV_HEAD(XPVHV*); /* pointer to xpvhv body */
+ _SV_HEAD_UNION;
+};
+
+struct io {
+ _SV_HEAD(XPVIO*); /* pointer to xpvio body */
+ _SV_HEAD_UNION;
+};
+
+#undef _SV_HEAD
+#undef _SV_HEAD_UNION /* ensure no pollution */
+
+/*
+=head1 SV Manipulation Functions
+
+=for apidoc Am|U32|SvREFCNT|SV* sv
+Returns the value of the object's reference count.
+
+=for apidoc Am|SV*|SvREFCNT_inc|SV* sv
+Increments the reference count of the given SV.
+
+All of the following SvREFCNT_inc* macros are optimized versions of
+SvREFCNT_inc, and can be replaced with SvREFCNT_inc.
+
+=for apidoc Am|SV*|SvREFCNT_inc_NN|SV* sv
+Same as SvREFCNT_inc, but can only be used if you know I<sv>
+is not NULL. Since we don't have to check the NULLness, it's faster
+and smaller.
+
+=for apidoc Am|void|SvREFCNT_inc_void|SV* sv
+Same as SvREFCNT_inc, but can only be used if you don't need the
+return value. The macro doesn't need to return a meaningful value.
+
+=for apidoc Am|void|SvREFCNT_inc_void_NN|SV* sv
+Same as SvREFCNT_inc, but can only be used if you don't need the return
+value, and you know that I<sv> is not NULL. The macro doesn't need
+to return a meaningful value, or check for NULLness, so it's smaller
+and faster.
+
+=for apidoc Am|SV*|SvREFCNT_inc_simple|SV* sv
+Same as SvREFCNT_inc, but can only be used with expressions without side
+effects. Since we don't have to store a temporary value, it's faster.
+
+=for apidoc Am|SV*|SvREFCNT_inc_simple_NN|SV* sv
+Same as SvREFCNT_inc_simple, but can only be used if you know I<sv>
+is not NULL. Since we don't have to check the NULLness, it's faster
+and smaller.
+
+=for apidoc Am|void|SvREFCNT_inc_simple_void|SV* sv
+Same as SvREFCNT_inc_simple, but can only be used if you don't need the
+return value. The macro doesn't need to return a meaningful value.
+
+=for apidoc Am|void|SvREFCNT_inc_simple_void_NN|SV* sv
+Same as SvREFCNT_inc, but can only be used if you don't need the return
+value, and you know that I<sv> is not NULL. The macro doesn't need
+to return a meaningful value, or check for NULLness, so it's smaller
+and faster.
+
+=for apidoc Am|void|SvREFCNT_dec|SV* sv
+Decrements the reference count of the given SV.
+
+=for apidoc Am|svtype|SvTYPE|SV* sv
+Returns the type of the SV. See C<svtype>.
+
+=for apidoc Am|void|SvUPGRADE|SV* sv|svtype type
+Used to upgrade an SV to a more complex form. Uses C<sv_upgrade> to
+perform the upgrade if necessary. See C<svtype>.
+
+=cut
+*/
+
+#define SvANY(sv) (sv)->sv_any
+#define SvFLAGS(sv) (sv)->sv_flags
+#define SvREFCNT(sv) (sv)->sv_refcnt
+
+#if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
+# define SvREFCNT_inc(sv) \
+ ({ \
+ SV * const _sv = MUTABLE_SV(sv); \
+ if (_sv) \
+ (SvREFCNT(_sv))++; \
+ _sv; \
+ })
+# define SvREFCNT_inc_simple(sv) \
+ ({ \
+ if (sv) \
+ (SvREFCNT(sv))++; \
+ MUTABLE_SV(sv); \
+ })
+# define SvREFCNT_inc_NN(sv) \
+ ({ \
+ SV * const _sv = MUTABLE_SV(sv); \
+ SvREFCNT(_sv)++; \
+ _sv; \
+ })
+# define SvREFCNT_inc_void(sv) \
+ ({ \
+ SV * const _sv = MUTABLE_SV(sv); \
+ if (_sv) \
+ (void)(SvREFCNT(_sv)++); \
+ })
+#else
+# define SvREFCNT_inc(sv) \
+ ((PL_Sv=MUTABLE_SV(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
+# define SvREFCNT_inc_simple(sv) \
+ ((sv) ? (SvREFCNT(sv)++,MUTABLE_SV(sv)) : NULL)
+# define SvREFCNT_inc_NN(sv) \
+ (PL_Sv=MUTABLE_SV(sv),++(SvREFCNT(PL_Sv)),PL_Sv)
+# define SvREFCNT_inc_void(sv) \
+ (void)((PL_Sv=MUTABLE_SV(sv)) ? ++(SvREFCNT(PL_Sv)) : 0)
+#endif
+
+/* These guys don't need the curly blocks */
+#define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
+#define SvREFCNT_inc_simple_NN(sv) (++(SvREFCNT(sv)),MUTABLE_SV(sv))
+#define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT(MUTABLE_SV(sv)))
+#define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT(MUTABLE_SV(sv)))
+
+#if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
+# define SvREFCNT_dec(sv) \
+ ({ \
+ SV * const _sv = MUTABLE_SV(sv); \
+ if (_sv) { \
+ if (SvREFCNT(_sv)) { \
+ if (--(SvREFCNT(_sv)) == 0) \
+ Perl_sv_free2(aTHX_ _sv); \
+ } else { \
+ sv_free(_sv); \
+ } \
+ } \
+ })
+#else
+#define SvREFCNT_dec(sv) sv_free(MUTABLE_SV(sv))
+#endif
+
+#define SVTYPEMASK 0xff
+#define SvTYPE(sv) ((svtype)((sv)->sv_flags & SVTYPEMASK))
+
+/* Sadly there are some parts of the core that have pointers to already-freed
+ SV heads, and rely on being able to tell that they are now free. So mark
+ them all by using a consistent macro. */
+#define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK)
+
+#define SvUPGRADE(sv, mt) (SvTYPE(sv) >= (mt) || (sv_upgrade(sv, mt), 1))
+
+#define SVf_IOK 0x00000100 /* has valid public integer value */
+#define SVf_NOK 0x00000200 /* has valid public numeric value */
+#define SVf_POK 0x00000400 /* has valid public pointer value */
+#define SVf_ROK 0x00000800 /* has a valid reference pointer */
+
+#define SVp_IOK 0x00001000 /* has valid non-public integer value */
+#define SVp_NOK 0x00002000 /* has valid non-public numeric value */
+#define SVp_POK 0x00004000 /* has valid non-public pointer value */
+#define SVp_SCREAM 0x00008000 /* has been studied? */
+#define SVphv_CLONEABLE SVp_SCREAM /* PVHV (stashes) clone its objects */
+#define SVpgv_GP SVp_SCREAM /* GV has a valid GP */
+#define SVprv_PCS_IMPORTED SVp_SCREAM /* RV is a proxy for a constant
+ subroutine in another package. Set the
+ CvIMPORTED_CV_ON() if it needs to be
+ expanded to a real GV */
+
+#define SVs_PADSTALE 0x00010000 /* lexical has gone out of scope */
+#define SVpad_STATE 0x00010000 /* pad name is a "state" var */
+#define SVs_PADTMP 0x00020000 /* in use as tmp */
+#define SVpad_TYPED 0x00020000 /* pad name is a Typed Lexical */
+#define SVs_PADMY 0x00040000 /* in use a "my" variable */
+#define SVpad_OUR 0x00040000 /* pad name is "our" instead of "my" */
+#define SVs_TEMP 0x00080000 /* string is stealable? */
+#define SVs_OBJECT 0x00100000 /* is "blessed" */
+#define SVs_GMG 0x00200000 /* has magical get method */
+#define SVs_SMG 0x00400000 /* has magical set method */
+#define SVs_RMG 0x00800000 /* has random magical methods */
+
+#define SVf_FAKE 0x01000000 /* 0: glob or lexical is just a copy
+ 1: SV head arena wasn't malloc()ed
+ 2: in conjunction with SVf_READONLY
+ marks a shared hash key scalar
+ (SvLEN == 0) or a copy on write
+ string (SvLEN != 0) [SvIsCOW(sv)]
+ 3: For PVCV, whether CvUNIQUE(cv)
+ refers to an eval or once only
+ [CvEVAL(cv), CvSPECIAL(cv)]
+ 4: Whether the regexp pointer is in
+ fact an offset [SvREPADTMP(sv)]
+ 5: On a pad name SV, that slot in the
+ frame AV is a REFCNT'ed reference
+ to a lexical from "outside". */
+#define SVphv_REHASH SVf_FAKE /* 6: On a PVHV, hash values are being
+ recalculated */
+#define SVf_OOK 0x02000000 /* has valid offset value. For a PVHV this
+ means that a hv_aux struct is present
+ after the main array */
+#define SVf_BREAK 0x04000000 /* refcnt is artificially low - used by
+ SVs in final arena cleanup.
+ Set in S_regtry on PL_reg_curpm, so that
+ perl_destruct will skip it. */
+#define SVf_READONLY 0x08000000 /* may not be modified */
+
+
+
+
+#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE)
+
+#define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
+ SVp_IOK|SVp_NOK|SVp_POK|SVpgv_GP)
+
+#define PRIVSHIFT 4 /* (SVp_?OK >> PRIVSHIFT) == SVf_?OK */
+
+#define SVf_AMAGIC 0x10000000 /* has magical overloaded methods */
+
+/* Ensure this value does not clash with the GV_ADD* flags in gv.h: */
+#define SVf_UTF8 0x20000000 /* SvPV is UTF-8 encoded
+ This is also set on RVs whose overloaded
+ stringification is UTF-8. This might
+ only happen as a side effect of SvPV() */
+
+
+/* Some private flags. */
+
+/* PVAV could probably use 0x2000000 without conflict. I assume that PVFM can
+ be UTF-8 encoded, and PVCVs could well have UTF-8 prototypes. PVIOs haven't
+ been restructured, so sometimes get used as string buffers. */
+
+/* PVHV */
+#define SVphv_SHAREKEYS 0x20000000 /* PVHV keys live on shared string table */
+/* PVNV, PVMG, presumably only inside pads */
+#define SVpad_NAME 0x40000000 /* This SV is a name in the PAD, so
+ SVpad_TYPED, SVpad_OUR and SVpad_STATE
+ apply */
+/* PVAV */
+#define SVpav_REAL 0x40000000 /* free old entries */
+/* PVHV */
+#define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */
+/* This is only set true on a PVGV when it's playing "PVBM", but is tested for
+ on any regular scalar (anything <= PVLV) */
+#define SVpbm_VALID 0x40000000
+/* ??? */
+#define SVrepl_EVAL 0x40000000 /* Replacement part of s///e */
+
+/* IV, PVIV, PVNV, PVMG, PVGV and (I assume) PVLV */
+/* Presumably IVs aren't stored in pads */
+#define SVf_IVisUV 0x80000000 /* use XPVUV instead of XPVIV */
+/* PVAV */
+#define SVpav_REIFY 0x80000000 /* can become real */
+/* PVHV */
+#define SVphv_HASKFLAGS 0x80000000 /* keys have flag byte after hash */
+/* PVFM */
+#define SVpfm_COMPILED 0x80000000 /* FORMLINE is compiled */
+/* PVGV when SVpbm_VALID is true */
+#define SVpbm_TAIL 0x80000000
+/* RV upwards. However, SVf_ROK and SVp_IOK are exclusive */
+#define SVprv_WEAKREF 0x80000000 /* Weak reference */
+
+
+struct xpv {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+};
+
+typedef struct {
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+} xpv_allocated;
+
+struct xpviv {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+};
+
+typedef struct {
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+} xpviv_allocated;
+
+#define xiv_iv xiv_u.xivu_iv
+
+struct xpvuv {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xuvu_iv;
+ UV xuvu_uv; /* unsigned value or pv offset */
+ void * xuvu_p1;
+ HEK * xivu_namehek;
+ } xuv_u;
+};
+
+#define xuv_uv xuv_u.xuvu_uv
+
+struct xpvnv {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+};
+
+/* These structure must match the beginning of struct xpvhv in hv.h. */
+struct xpvmg {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+};
+
+struct xpvlv {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek; /* GvNAME */
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+
+ STRLEN xlv_targoff;
+ STRLEN xlv_targlen;
+ SV* xlv_targ;
+ char xlv_type; /* k=keys .=pos x=substr v=vec /=join/re
+ * y=alem/helem/iter t=tie T=tied HE */
+};
+
+/* This structure works in 3 ways - regular scalar, GV with GP, or fast
+ Boyer-Moore. */
+struct xpvgv {
+ union {
+ NV xnv_nv;
+ HV * xgv_stash; /* The stash of this GV */
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* xgv_flags */
+ STRLEN xpv_len; /* 0 */
+ union {
+ IV xivu_iv;
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32; /* is this constant pattern being useful? */
+ HEK * xivu_namehek; /* GvNAME */
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+
+};
+
+/* This structure must match XPVCV in cv.h */
+
+typedef U16 cv_flags_t;
+
+struct xpvfm {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* PVFMs use the pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ union {
+ OP * xcv_start;
+ ANY xcv_xsubany;
+ } xcv_start_u;
+ union {
+ OP * xcv_root;
+ void (*xcv_xsub) (pTHX_ CV*);
+ } xcv_root_u;
+ GV * xcv_gv;
+ char * xcv_file;
+ AV * xcv_padlist;
+ CV * xcv_outside;
+ U32 xcv_outside_seq; /* the COP sequence (at the point of our
+ * compilation) in the lexically enclosing
+ * sub */
+ cv_flags_t xcv_flags;
+ IV xfm_lines;
+};
+
+typedef struct {
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* PVFMs use the pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ union {
+ OP * xcv_start;
+ ANY xcv_xsubany;
+ } xcv_start_u;
+ union {
+ OP * xcv_root;
+ void (*xcv_xsub) (pTHX_ CV*);
+ } xcv_root_u;
+ GV * xcv_gv;
+ char * xcv_file;
+ AV * xcv_padlist;
+ CV * xcv_outside;
+ U32 xcv_outside_seq; /* the COP sequence (at the point of our
+ * compilation) in the lexically enclosing
+ * sub */
+ cv_flags_t xcv_flags;
+ IV xfm_lines;
+} xpvfm_allocated;
+
+struct xpvio {
+ union {
+ NV xnv_nv; /* numeric value, if any */
+ HV * xgv_stash;
+ struct {
+ U32 xlow;
+ U32 xhigh;
+ } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ struct {
+ U32 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_flags;
+ U8 xbm_rare; /* rarest character in string */
+ } xbm_s; /* fields from PVBM */
+ } xnv_u;
+ STRLEN xpv_cur; /* length of svu_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ union {
+ IV xivu_iv; /* integer value or pv offset */
+ UV xivu_uv;
+ void * xivu_p1;
+ I32 xivu_i32;
+ HEK * xivu_namehek;
+ } xiv_u;
+ union {
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ } xmg_u;
+ HV* xmg_stash; /* class package */
+
+ PerlIO * xio_ifp; /* ifp and ofp are normally the same */
+ PerlIO * xio_ofp; /* but sockets need separate streams */
+ /* Cray addresses everything by word boundaries (64 bits) and
+ * code and data pointers cannot be mixed (which is exactly what
+ * Perl_filter_add() tries to do with the dirp), hence the following
+ * union trick (as suggested by Gurusamy Sarathy).
+ * For further information see Geir Johansen's problem report titled
+ [ID 20000612.002] Perl problem on Cray system
+ * The any pointer (known as IoANY()) will also be a good place
+ * to hang any IO disciplines to.
+ */
+ union {
+ DIR * xiou_dirp; /* for opendir, readdir, etc */
+ void * xiou_any; /* for alignment */
+ } xio_dirpu;
+ IV xio_lines; /* $. */
+ IV xio_page; /* $% */
+ IV xio_page_len; /* $= */
+ IV xio_lines_left; /* $- */
+ char * xio_top_name; /* $^ */
+ GV * xio_top_gv; /* $^ */
+ char * xio_fmt_name; /* $~ */
+ GV * xio_fmt_gv; /* $~ */
+ char * xio_bottom_name;/* $^B */
+ GV * xio_bottom_gv; /* $^B */
+ char xio_type;
+ U8 xio_flags;
+};
+#define xio_dirp xio_dirpu.xiou_dirp
+#define xio_any xio_dirpu.xiou_any
+
+#define IOf_ARGV 1 /* this fp iterates over ARGV */
+#define IOf_START 2 /* check for null ARGV and substitute '-' */
+#define IOf_FLUSH 4 /* this fp wants a flush after write op */
+#define IOf_DIDTOP 8 /* just did top of form */
+#define IOf_UNTAINT 16 /* consider this fp (and its data) "safe" */
+#define IOf_NOLINE 32 /* slurped a pseudo-line from empty file */
+#define IOf_FAKE_DIRP 64 /* xio_dirp is fake (source filters kludge) */
+
+/* The following macros define implementation-independent predicates on SVs. */
+
+/*
+=for apidoc Am|U32|SvNIOK|SV* sv
+Returns a U32 value indicating whether the SV contains a number, integer or
+double.
+
+=for apidoc Am|U32|SvNIOKp|SV* sv
+Returns a U32 value indicating whether the SV contains a number, integer or
+double. Checks the B<private> setting. Use C<SvNIOK> instead.
+
+=for apidoc Am|void|SvNIOK_off|SV* sv
+Unsets the NV/IV status of an SV.
+
+=for apidoc Am|U32|SvOK|SV* sv
+Returns a U32 value indicating whether the value is defined. This is
+only meaningful for scalars.
+
+=for apidoc Am|U32|SvIOKp|SV* sv
+Returns a U32 value indicating whether the SV contains an integer. Checks
+the B<private> setting. Use C<SvIOK> instead.
+
+=for apidoc Am|U32|SvNOKp|SV* sv
+Returns a U32 value indicating whether the SV contains a double. Checks the
+B<private> setting. Use C<SvNOK> instead.
+
+=for apidoc Am|U32|SvPOKp|SV* sv
+Returns a U32 value indicating whether the SV contains a character string.
+Checks the B<private> setting. Use C<SvPOK> instead.
+
+=for apidoc Am|U32|SvIOK|SV* sv
+Returns a U32 value indicating whether the SV contains an integer.
+
+=for apidoc Am|void|SvIOK_on|SV* sv
+Tells an SV that it is an integer.
+
+=for apidoc Am|void|SvIOK_off|SV* sv
+Unsets the IV status of an SV.
+
+=for apidoc Am|void|SvIOK_only|SV* sv
+Tells an SV that it is an integer and disables all other OK bits.
+
+=for apidoc Am|void|SvIOK_only_UV|SV* sv
+Tells and SV that it is an unsigned integer and disables all other OK bits.
+
+=for apidoc Am|bool|SvIOK_UV|SV* sv
+Returns a boolean indicating whether the SV contains an unsigned integer.
+
+=for apidoc Am|bool|SvUOK|SV* sv
+Returns a boolean indicating whether the SV contains an unsigned integer.
+
+=for apidoc Am|bool|SvIOK_notUV|SV* sv
+Returns a boolean indicating whether the SV contains a signed integer.
+
+=for apidoc Am|U32|SvNOK|SV* sv
+Returns a U32 value indicating whether the SV contains a double.
+
+=for apidoc Am|void|SvNOK_on|SV* sv
+Tells an SV that it is a double.
+
+=for apidoc Am|void|SvNOK_off|SV* sv
+Unsets the NV status of an SV.
+
+=for apidoc Am|void|SvNOK_only|SV* sv
+Tells an SV that it is a double and disables all other OK bits.
+
+=for apidoc Am|U32|SvPOK|SV* sv
+Returns a U32 value indicating whether the SV contains a character
+string.
+
+=for apidoc Am|void|SvPOK_on|SV* sv
+Tells an SV that it is a string.
+
+=for apidoc Am|void|SvPOK_off|SV* sv
+Unsets the PV status of an SV.
+
+=for apidoc Am|void|SvPOK_only|SV* sv
+Tells an SV that it is a string and disables all other OK bits.
+Will also turn off the UTF-8 status.
+
+=for apidoc Am|bool|SvVOK|SV* sv
+Returns a boolean indicating whether the SV contains a v-string.
+
+=for apidoc Am|U32|SvOOK|SV* sv
+Returns a U32 indicating whether the SvIVX is a valid offset value for
+the SvPVX. This hack is used internally to speed up removal of characters
+from the beginning of a SvPV. When SvOOK is true, then the start of the
+allocated string buffer is really (SvPVX - SvIVX).
+
+=for apidoc Am|U32|SvROK|SV* sv
+Tests if the SV is an RV.
+
+=for apidoc Am|void|SvROK_on|SV* sv
+Tells an SV that it is an RV.
+
+=for apidoc Am|void|SvROK_off|SV* sv
+Unsets the RV status of an SV.
+
+=for apidoc Am|SV*|SvRV|SV* sv
+Dereferences an RV to return the SV.
+
+=for apidoc Am|IV|SvIVX|SV* sv
+Returns the raw value in the SV's IV slot, without checks or conversions.
+Only use when you are sure SvIOK is true. See also C<SvIV()>.
+
+=for apidoc Am|UV|SvUVX|SV* sv
+Returns the raw value in the SV's UV slot, without checks or conversions.
+Only use when you are sure SvIOK is true. See also C<SvUV()>.
+
+=for apidoc Am|NV|SvNVX|SV* sv
+Returns the raw value in the SV's NV slot, without checks or conversions.
+Only use when you are sure SvNOK is true. See also C<SvNV()>.
+
+=for apidoc Am|char*|SvPVX|SV* sv
+Returns a pointer to the physical string in the SV. The SV must contain a
+string.
+
+=for apidoc Am|STRLEN|SvCUR|SV* sv
+Returns the length of the string which is in the SV. See C<SvLEN>.
+
+=for apidoc Am|STRLEN|SvLEN|SV* sv
+Returns the size of the string buffer in the SV, not including any part
+attributable to C<SvOOK>. See C<SvCUR>.
+
+=for apidoc Am|char*|SvEND|SV* sv
+Returns a pointer to the last character in the string which is in the SV.
+See C<SvCUR>. Access the character as *(SvEND(sv)).
+
+=for apidoc Am|HV*|SvSTASH|SV* sv
+Returns the stash of the SV.
+
+=for apidoc Am|void|SvIV_set|SV* sv|IV val
+Set the value of the IV pointer in sv to val. It is possible to perform
+the same function of this macro with an lvalue assignment to C<SvIVX>.
+With future Perls, however, it will be more efficient to use
+C<SvIV_set> instead of the lvalue assignment to C<SvIVX>.
+
+=for apidoc Am|void|SvNV_set|SV* sv|NV val
+Set the value of the NV pointer in sv to val. See C<SvIV_set>.
+
+=for apidoc Am|void|SvPV_set|SV* sv|char* val
+Set the value of the PV pointer in sv to val. See C<SvIV_set>.
+
+=for apidoc Am|void|SvUV_set|SV* sv|UV val
+Set the value of the UV pointer in sv to val. See C<SvIV_set>.
+
+=for apidoc Am|void|SvRV_set|SV* sv|SV* val
+Set the value of the RV pointer in sv to val. See C<SvIV_set>.
+
+=for apidoc Am|void|SvMAGIC_set|SV* sv|MAGIC* val
+Set the value of the MAGIC pointer in sv to val. See C<SvIV_set>.
+
+=for apidoc Am|void|SvSTASH_set|SV* sv|HV* val
+Set the value of the STASH pointer in sv to val. See C<SvIV_set>.
+
+=for apidoc Am|void|SvCUR_set|SV* sv|STRLEN len
+Set the current length of the string which is in the SV. See C<SvCUR>
+and C<SvIV_set>.
+
+=for apidoc Am|void|SvLEN_set|SV* sv|STRLEN len
+Set the actual length of the string which is in the SV. See C<SvIV_set>.
+
+=cut
+*/
+
+#define SvNIOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK))
+#define SvNIOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK))
+#define SvNIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \
+ SVp_IOK|SVp_NOK|SVf_IVisUV))
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+#define assert_not_ROK(sv) ({assert(!SvROK(sv) || !SvRV(sv));}),
+#define assert_not_glob(sv) ({assert(!isGV_with_GP(sv));}),
+#else
+#define assert_not_ROK(sv)
+#define assert_not_glob(sv)
+#endif
+
+#define SvOK(sv) ((SvTYPE(sv) == SVt_BIND) \
+ ? (SvFLAGS(SvRV(sv)) & SVf_OK) \
+ : (SvFLAGS(sv) & SVf_OK))
+#define SvOK_off(sv) (assert_not_ROK(sv) assert_not_glob(sv) \
+ SvFLAGS(sv) &= ~(SVf_OK| \
+ SVf_IVisUV|SVf_UTF8), \
+ SvOOK_off(sv))
+#define SvOK_off_exc_UV(sv) (assert_not_ROK(sv) \
+ SvFLAGS(sv) &= ~(SVf_OK| \
+ SVf_UTF8), \
+ SvOOK_off(sv))
+
+#define SvOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK))
+#define SvIOKp(sv) (SvFLAGS(sv) & SVp_IOK)
+#define SvIOKp_on(sv) (assert_not_glob(sv) SvRELEASE_IVX(sv), \
+ SvFLAGS(sv) |= SVp_IOK)
+#define SvNOKp(sv) (SvFLAGS(sv) & SVp_NOK)
+#define SvNOKp_on(sv) (assert_not_glob(sv) SvFLAGS(sv) |= SVp_NOK)
+#define SvPOKp(sv) (SvFLAGS(sv) & SVp_POK)
+#define SvPOKp_on(sv) (assert_not_ROK(sv) assert_not_glob(sv) \
+ SvFLAGS(sv) |= SVp_POK)
+
+#define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK)
+#define SvIOK_on(sv) (assert_not_glob(sv) SvRELEASE_IVX(sv), \
+ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
+#define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK|SVf_IVisUV))
+#define SvIOK_only(sv) (SvOK_off(sv), \
+ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
+#define SvIOK_only_UV(sv) (assert_not_glob(sv) SvOK_off_exc_UV(sv), \
+ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
+
+#define SvIOK_UV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \
+ == (SVf_IOK|SVf_IVisUV))
+#define SvUOK(sv) SvIOK_UV(sv)
+#define SvIOK_notUV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \
+ == SVf_IOK)
+
+#define SvIsUV(sv) (SvFLAGS(sv) & SVf_IVisUV)
+#define SvIsUV_on(sv) (SvFLAGS(sv) |= SVf_IVisUV)
+#define SvIsUV_off(sv) (SvFLAGS(sv) &= ~SVf_IVisUV)
+
+#define SvNOK(sv) (SvFLAGS(sv) & SVf_NOK)
+#define SvNOK_on(sv) (assert_not_glob(sv) \
+ SvFLAGS(sv) |= (SVf_NOK|SVp_NOK))
+#define SvNOK_off(sv) (SvFLAGS(sv) &= ~(SVf_NOK|SVp_NOK))
+#define SvNOK_only(sv) (SvOK_off(sv), \
+ SvFLAGS(sv) |= (SVf_NOK|SVp_NOK))
+
+/*
+=for apidoc Am|U32|SvUTF8|SV* sv
+Returns a U32 value indicating whether the SV contains UTF-8 encoded data.
+Call this after SvPV() in case any call to string overloading updates the
+internal flag.
+
+=for apidoc Am|void|SvUTF8_on|SV *sv
+Turn on the UTF-8 status of an SV (the data is not changed, just the flag).
+Do not use frivolously.
+
+=for apidoc Am|void|SvUTF8_off|SV *sv
+Unsets the UTF-8 status of an SV.
+
+=for apidoc Am|void|SvPOK_only_UTF8|SV* sv
+Tells an SV that it is a string and disables all other OK bits,
+and leaves the UTF-8 status as it was.
+
+=cut
+ */
+
+/* Ensure the return value of this macro does not clash with the GV_ADD* flags
+in gv.h: */
+#define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8)
+#define SvUTF8_on(sv) (SvFLAGS(sv) |= (SVf_UTF8))
+#define SvUTF8_off(sv) (SvFLAGS(sv) &= ~(SVf_UTF8))
+
+#define SvPOK(sv) (SvFLAGS(sv) & SVf_POK)
+#define SvPOK_on(sv) (assert_not_ROK(sv) assert_not_glob(sv) \
+ SvFLAGS(sv) |= (SVf_POK|SVp_POK))
+#define SvPOK_off(sv) (SvFLAGS(sv) &= ~(SVf_POK|SVp_POK))
+#define SvPOK_only(sv) (assert_not_ROK(sv) assert_not_glob(sv) \
+ SvFLAGS(sv) &= ~(SVf_OK| \
+ SVf_IVisUV|SVf_UTF8), \
+ SvFLAGS(sv) |= (SVf_POK|SVp_POK))
+#define SvPOK_only_UTF8(sv) (assert_not_ROK(sv) assert_not_glob(sv) \
+ SvFLAGS(sv) &= ~(SVf_OK| \
+ SVf_IVisUV), \
+ SvFLAGS(sv) |= (SVf_POK|SVp_POK))
+
+#define SvVOK(sv) (SvMAGICAL(sv) \
+ && mg_find(sv,PERL_MAGIC_vstring))
+/* returns the vstring magic, if any */
+#define SvVSTRING_mg(sv) (SvMAGICAL(sv) \
+ ? mg_find(sv,PERL_MAGIC_vstring) : NULL)
+
+#define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK)
+#define SvOOK_on(sv) ((void)SvIOK_off(sv), SvFLAGS(sv) |= SVf_OOK)
+#define SvOOK_off(sv) ((void)(SvOOK(sv) && sv_backoff(sv)))
+
+#define SvFAKE(sv) (SvFLAGS(sv) & SVf_FAKE)
+#define SvFAKE_on(sv) (SvFLAGS(sv) |= SVf_FAKE)
+#define SvFAKE_off(sv) (SvFLAGS(sv) &= ~SVf_FAKE)
+
+#define SvROK(sv) (SvFLAGS(sv) & SVf_ROK)
+#define SvROK_on(sv) (SvFLAGS(sv) |= SVf_ROK)
+#define SvROK_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK))
+
+#define SvMAGICAL(sv) (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG))
+#define SvMAGICAL_on(sv) (SvFLAGS(sv) |= (SVs_GMG|SVs_SMG|SVs_RMG))
+#define SvMAGICAL_off(sv) (SvFLAGS(sv) &= ~(SVs_GMG|SVs_SMG|SVs_RMG))
+
+#define SvGMAGICAL(sv) (SvFLAGS(sv) & SVs_GMG)
+#define SvGMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_GMG)
+#define SvGMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_GMG)
+
+#define SvSMAGICAL(sv) (SvFLAGS(sv) & SVs_SMG)
+#define SvSMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_SMG)
+#define SvSMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_SMG)
+
+#define SvRMAGICAL(sv) (SvFLAGS(sv) & SVs_RMG)
+#define SvRMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_RMG)
+#define SvRMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_RMG)
+
+#define SvAMAGIC(sv) (SvROK(sv) && (SvFLAGS(SvRV(sv)) & SVf_AMAGIC))
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define SvAMAGIC_on(sv) ({ SV * const kloink = sv; \
+ assert(SvROK(kloink)); \
+ SvFLAGS(SvRV(kloink)) |= SVf_AMAGIC; \
+ })
+# define SvAMAGIC_off(sv) ({ SV * const kloink = sv; \
+ if(SvROK(kloink)) \
+ SvFLAGS(SvRV(kloink)) &= ~SVf_AMAGIC;\
+ })
+#else
+# define SvAMAGIC_on(sv) (SvFLAGS(SvRV(sv)) |= SVf_AMAGIC)
+# define SvAMAGIC_off(sv) \
+ (SvROK(sv) && (SvFLAGS(SvRV(sv)) &= ~SVf_AMAGIC))
+#endif
+
+/*
+=for apidoc Am|U32|SvGAMAGIC|SV* sv
+
+Returns true if the SV has get magic or overloading. If either is true then
+the scalar is active data, and has the potential to return a new value every
+time it is accessed. Hence you must be careful to only read it once per user
+logical operation and work with that returned value. If neither is true then
+the scalar's value cannot change unless written to.
+
+=cut
+*/
+
+#define SvGAMAGIC(sv) (SvGMAGICAL(sv) || SvAMAGIC(sv))
+
+#define Gv_AMG(stash) (PL_amagic_generation && Gv_AMupdate(stash))
+
+#define SvWEAKREF(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_WEAKREF)) \
+ == (SVf_ROK|SVprv_WEAKREF))
+#define SvWEAKREF_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_WEAKREF))
+#define SvWEAKREF_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_WEAKREF))
+
+#define SvPCS_IMPORTED(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_PCS_IMPORTED)) \
+ == (SVf_ROK|SVprv_PCS_IMPORTED))
+#define SvPCS_IMPORTED_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_PCS_IMPORTED))
+#define SvPCS_IMPORTED_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_PCS_IMPORTED))
+
+#define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST)
+
+#define SvPADSTALE(sv) (SvFLAGS(sv) & SVs_PADSTALE)
+#define SvPADSTALE_on(sv) (SvFLAGS(sv) |= SVs_PADSTALE)
+#define SvPADSTALE_off(sv) (SvFLAGS(sv) &= ~SVs_PADSTALE)
+
+#define SvPADTMP(sv) (SvFLAGS(sv) & SVs_PADTMP)
+#define SvPADTMP_on(sv) (SvFLAGS(sv) |= SVs_PADTMP)
+#define SvPADTMP_off(sv) (SvFLAGS(sv) &= ~SVs_PADTMP)
+
+#define SvPADMY(sv) (SvFLAGS(sv) & SVs_PADMY)
+#define SvPADMY_on(sv) (SvFLAGS(sv) |= SVs_PADMY)
+
+#define SvTEMP(sv) (SvFLAGS(sv) & SVs_TEMP)
+#define SvTEMP_on(sv) (SvFLAGS(sv) |= SVs_TEMP)
+#define SvTEMP_off(sv) (SvFLAGS(sv) &= ~SVs_TEMP)
+
+#define SvOBJECT(sv) (SvFLAGS(sv) & SVs_OBJECT)
+#define SvOBJECT_on(sv) (SvFLAGS(sv) |= SVs_OBJECT)
+#define SvOBJECT_off(sv) (SvFLAGS(sv) &= ~SVs_OBJECT)
+
+#define SvREADONLY(sv) (SvFLAGS(sv) & SVf_READONLY)
+#define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
+#define SvREADONLY_off(sv) (SvFLAGS(sv) &= ~SVf_READONLY)
+
+#define SvSCREAM(sv) ((SvFLAGS(sv) & (SVp_SCREAM|SVp_POK)) == (SVp_SCREAM|SVp_POK))
+#define SvSCREAM_on(sv) (SvFLAGS(sv) |= SVp_SCREAM)
+#define SvSCREAM_off(sv) (SvFLAGS(sv) &= ~SVp_SCREAM)
+
+#define SvCOMPILED(sv) (SvFLAGS(sv) & SVpfm_COMPILED)
+#define SvCOMPILED_on(sv) (SvFLAGS(sv) |= SVpfm_COMPILED)
+#define SvCOMPILED_off(sv) (SvFLAGS(sv) &= ~SVpfm_COMPILED)
+
+#define SvEVALED(sv) (SvFLAGS(sv) & SVrepl_EVAL)
+#define SvEVALED_on(sv) (SvFLAGS(sv) |= SVrepl_EVAL)
+#define SvEVALED_off(sv) (SvFLAGS(sv) &= ~SVrepl_EVAL)
+
+#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define SvVALID(sv) ({ const SV *const _svvalid = (const SV*)(sv); \
+ if (SvFLAGS(_svvalid) & SVpbm_VALID) \
+ assert(!isGV_with_GP(_svvalid)); \
+ (SvFLAGS(_svvalid) & SVpbm_VALID); \
+ })
+# define SvVALID_on(sv) ({ SV *const _svvalid = MUTABLE_SV(sv); \
+ assert(!isGV_with_GP(_svvalid)); \
+ (SvFLAGS(_svvalid) |= SVpbm_VALID); \
+ })
+# define SvVALID_off(sv) ({ SV *const _svvalid = MUTABLE_SV(sv); \
+ assert(!isGV_with_GP(_svvalid)); \
+ (SvFLAGS(_svvalid) &= ~SVpbm_VALID); \
+ })
+
+# define SvTAIL(sv) ({ const SV *const _svtail = (const SV *)(sv); \
+ assert(SvTYPE(_svtail) != SVt_PVAV); \
+ assert(SvTYPE(_svtail) != SVt_PVHV); \
+ (SvFLAGS(sv) & (SVpbm_TAIL|SVpbm_VALID)) \
+ == (SVpbm_TAIL|SVpbm_VALID); \
+ })
+#else
+# define SvVALID(sv) (SvFLAGS(sv) & SVpbm_VALID)
+# define SvVALID_on(sv) (SvFLAGS(sv) |= SVpbm_VALID)
+# define SvVALID_off(sv) (SvFLAGS(sv) &= ~SVpbm_VALID)
+# define SvTAIL(sv) ((SvFLAGS(sv) & (SVpbm_TAIL|SVpbm_VALID)) \
+ == (SVpbm_TAIL|SVpbm_VALID))
+
+#endif
+#define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL)
+#define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL)
+
+
+#ifdef USE_ITHREADS
+/* The following uses the FAKE flag to show that a regex pointer is infact
+ its own offset in the regexpad for ithreads */
+#define SvREPADTMP(sv) (SvFLAGS(sv) & SVf_FAKE)
+#define SvREPADTMP_on(sv) (SvFLAGS(sv) |= SVf_FAKE)
+#define SvREPADTMP_off(sv) (SvFLAGS(sv) &= ~SVf_FAKE)
+#endif
+
+#define SvPAD_TYPED(sv) \
+ ((SvFLAGS(sv) & (SVpad_NAME|SVpad_TYPED)) == (SVpad_NAME|SVpad_TYPED))
+
+#define SvPAD_OUR(sv) \
+ ((SvFLAGS(sv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+
+#define SvPAD_STATE(sv) \
+ ((SvFLAGS(sv) & (SVpad_NAME|SVpad_STATE)) == (SVpad_NAME|SVpad_STATE))
+
+#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define SvPAD_TYPED_on(sv) ({ \
+ SV *const _svpad = MUTABLE_SV(sv); \
+ assert(SvTYPE(_svpad) == SVt_PVMG); \
+ (SvFLAGS(_svpad) |= SVpad_NAME|SVpad_TYPED); \
+ })
+#define SvPAD_OUR_on(sv) ({ \
+ SV *const _svpad = MUTABLE_SV(sv); \
+ assert(SvTYPE(_svpad) == SVt_PVMG); \
+ (SvFLAGS(_svpad) |= SVpad_NAME|SVpad_OUR); \
+ })
+#define SvPAD_STATE_on(sv) ({ \
+ SV *const _svpad = MUTABLE_SV(sv); \
+ assert(SvTYPE(_svpad) == SVt_PVNV || SvTYPE(_svpad) == SVt_PVMG); \
+ (SvFLAGS(_svpad) |= SVpad_NAME|SVpad_STATE); \
+ })
+#else
+# define SvPAD_TYPED_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_TYPED)
+# define SvPAD_OUR_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_OUR)
+# define SvPAD_STATE_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_STATE)
+#endif
+
+#define SvOURSTASH(sv) \
+ (SvPAD_OUR(sv) ? ((XPVMG*) SvANY(sv))->xmg_u.xmg_ourstash : NULL)
+#define SvOURSTASH_set(sv, st) \
+ STMT_START { \
+ assert(SvTYPE(sv) == SVt_PVMG); \
+ ((XPVMG*) SvANY(sv))->xmg_u.xmg_ourstash = st; \
+ } STMT_END
+
+#ifdef PERL_DEBUG_COW
+#else
+#endif
+#define SvRVx(sv) SvRV(sv)
+
+#ifdef PERL_DEBUG_COW
+/* Need -0.0 for SvNVX to preserve IEEE FP "negative zero" because
+ +0.0 + -0.0 => +0.0 but -0.0 + -0.0 => -0.0 */
+# define SvIVX(sv) (0 + ((XPVIV*) SvANY(sv))->xiv_iv)
+# define SvUVX(sv) (0 + ((XPVUV*) SvANY(sv))->xuv_uv)
+# define SvNVX(sv) (-0.0 + ((XPVNV*) SvANY(sv))->xnv_u.xnv_nv)
+# define SvRV(sv) (0 + (sv)->sv_u.svu_rv)
+# define SvRV_const(sv) (0 + (sv)->sv_u.svu_rv)
+/* Don't test the core XS code yet. */
+# if defined (PERL_CORE) && PERL_DEBUG_COW > 1
+# define SvPVX(sv) (0 + (assert(!SvREADONLY(sv)), (sv)->sv_u.svu_pv))
+# else
+# define SvPVX(sv) SvPVX_mutable(sv)
+# endif
+# define SvCUR(sv) (0 + ((XPV*) SvANY(sv))->xpv_cur)
+# define SvLEN(sv) (0 + ((XPV*) SvANY(sv))->xpv_len)
+# define SvEND(sv) ((sv)->sv_u.svu_pv + ((XPV*)SvANY(sv))->xpv_cur)
+
+# ifdef DEBUGGING
+# define SvMAGIC(sv) (0 + *(assert(SvTYPE(sv) >= SVt_PVMG), &((XPVMG*) SvANY(sv))->xmg_u.xmg_magic))
+# define SvSTASH(sv) (0 + *(assert(SvTYPE(sv) >= SVt_PVMG), &((XPVMG*) SvANY(sv))->xmg_stash))
+# else
+# define SvMAGIC(sv) (0 + ((XPVMG*) SvANY(sv))->xmg_u.xmg_magic)
+# define SvSTASH(sv) (0 + ((XPVMG*) SvANY(sv))->xmg_stash)
+# endif
+#else
+# define SvLEN(sv) ((XPV*) SvANY(sv))->xpv_len
+# define SvEND(sv) ((sv)->sv_u.svu_pv + ((XPV*)SvANY(sv))->xpv_cur)
+
+# if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+/* These get expanded inside other macros that already use a variable _sv */
+# define SvPVX(sv) \
+ (*({ SV *const _svpvx = MUTABLE_SV(sv); \
+ assert(SvTYPE(_svpvx) >= SVt_PV); \
+ assert(SvTYPE(_svpvx) != SVt_PVAV); \
+ assert(SvTYPE(_svpvx) != SVt_PVHV); \
+ assert(!isGV_with_GP(_svpvx)); \
+ &((_svpvx)->sv_u.svu_pv); \
+ }))
+# define SvCUR(sv) \
+ (*({ const SV *const _svcur = (const SV *)(sv); \
+ assert(SvTYPE(_svcur) >= SVt_PV); \
+ assert(SvTYPE(_svcur) != SVt_PVAV); \
+ assert(SvTYPE(_svcur) != SVt_PVHV); \
+ assert(!isGV_with_GP(_svcur)); \
+ &(((XPV*) MUTABLE_PTR(SvANY(_svcur)))->xpv_cur); \
+ }))
+# define SvIVX(sv) \
+ (*({ const SV *const _svivx = (const SV *)(sv); \
+ assert(SvTYPE(_svivx) == SVt_IV || SvTYPE(_svivx) >= SVt_PVIV); \
+ assert(SvTYPE(_svivx) != SVt_PVAV); \
+ assert(SvTYPE(_svivx) != SVt_PVHV); \
+ assert(SvTYPE(_svivx) != SVt_PVCV); \
+ assert(!isGV_with_GP(_svivx)); \
+ &(((XPVIV*) MUTABLE_PTR(SvANY(_svivx)))->xiv_iv); \
+ }))
+# define SvUVX(sv) \
+ (*({ const SV *const _svuvx = (const SV *)(sv); \
+ assert(SvTYPE(_svuvx) == SVt_IV || SvTYPE(_svuvx) >= SVt_PVIV); \
+ assert(SvTYPE(_svuvx) != SVt_PVAV); \
+ assert(SvTYPE(_svuvx) != SVt_PVHV); \
+ assert(SvTYPE(_svuvx) != SVt_PVCV); \
+ assert(!isGV_with_GP(_svuvx)); \
+ &(((XPVUV*) MUTABLE_PTR(SvANY(_svuvx)))->xuv_uv); \
+ }))
+# define SvNVX(sv) \
+ (*({ const SV *const _svnvx = (const SV *)(sv); \
+ assert(SvTYPE(_svnvx) == SVt_NV || SvTYPE(_svnvx) >= SVt_PVNV); \
+ assert(SvTYPE(_svnvx) != SVt_PVAV); \
+ assert(SvTYPE(_svnvx) != SVt_PVHV); \
+ assert(SvTYPE(_svnvx) != SVt_PVCV); \
+ assert(SvTYPE(_svnvx) != SVt_PVFM); \
+ assert(!isGV_with_GP(_svnvx)); \
+ &(((XPVNV*) MUTABLE_PTR(SvANY(_svnvx)))->xnv_u.xnv_nv); \
+ }))
+# define SvRV(sv) \
+ (*({ SV *const _svrv = MUTABLE_SV(sv); \
+ assert(SvTYPE(_svrv) >= SVt_RV); \
+ assert(SvTYPE(_svrv) != SVt_PVAV); \
+ assert(SvTYPE(_svrv) != SVt_PVHV); \
+ assert(SvTYPE(_svrv) != SVt_PVCV); \
+ assert(SvTYPE(_svrv) != SVt_PVFM); \
+ assert(!isGV_with_GP(_svrv)); \
+ &((_svrv)->sv_u.svu_rv); \
+ }))
+# define SvRV_const(sv) \
+ ({ const SV *const _svrv = (const SV *)(sv); \
+ assert(SvTYPE(_svrv) >= SVt_RV); \
+ assert(SvTYPE(_svrv) != SVt_PVAV); \
+ assert(SvTYPE(_svrv) != SVt_PVHV); \
+ assert(SvTYPE(_svrv) != SVt_PVCV); \
+ assert(SvTYPE(_svrv) != SVt_PVFM); \
+ assert(!isGV_with_GP(_svrv)); \
+ (_svrv)->sv_u.svu_rv; \
+ })
+# define SvMAGIC(sv) \
+ (*({ const SV *const _svmagic = (const SV *)(sv); \
+ assert(SvTYPE(_svmagic) >= SVt_PVMG); \
+ if(SvTYPE(_svmagic) == SVt_PVMG) \
+ assert(!SvPAD_OUR(_svmagic)); \
+ &(((XPVMG*) MUTABLE_PTR(SvANY(_svmagic)))->xmg_u.xmg_magic); \
+ }))
+# define SvSTASH(sv) \
+ (*({ const SV *const _svstash = (const SV *)(sv); \
+ assert(SvTYPE(_svstash) >= SVt_PVMG); \
+ &(((XPVMG*) MUTABLE_PTR(SvANY(_svstash)))->xmg_stash); \
+ }))
+# else
+# define SvPVX(sv) ((sv)->sv_u.svu_pv)
+# define SvCUR(sv) ((XPV*) SvANY(sv))->xpv_cur
+# define SvIVX(sv) ((XPVIV*) SvANY(sv))->xiv_iv
+# define SvUVX(sv) ((XPVUV*) SvANY(sv))->xuv_uv
+# define SvNVX(sv) ((XPVNV*) SvANY(sv))->xnv_u.xnv_nv
+# define SvRV(sv) ((sv)->sv_u.svu_rv)
+# define SvRV_const(sv) (0 + (sv)->sv_u.svu_rv)
+# define SvMAGIC(sv) ((XPVMG*) SvANY(sv))->xmg_u.xmg_magic
+# define SvSTASH(sv) ((XPVMG*) SvANY(sv))->xmg_stash
+# endif
+#endif
+
+#ifndef PERL_POISON
+/* Given that these two are new, there can't be any existing code using them
+ * as LVALUEs */
+# define SvPVX_mutable(sv) (0 + (sv)->sv_u.svu_pv)
+# define SvPVX_const(sv) ((const char*)(0 + (sv)->sv_u.svu_pv))
+#else
+/* Except for the poison code, which uses & to scribble over the pointer after
+ free() is called. */
+# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)
+# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv))
+#endif
+
+#define SvIVXx(sv) SvIVX(sv)
+#define SvUVXx(sv) SvUVX(sv)
+#define SvNVXx(sv) SvNVX(sv)
+#define SvPVXx(sv) SvPVX(sv)
+#define SvLENx(sv) SvLEN(sv)
+#define SvENDx(sv) ((PL_Sv = (sv)), SvEND(PL_Sv))
+
+
+/* Ask a scalar nicely to try to become an IV, if possible.
+ Not guaranteed to stay returning void */
+/* Macro won't actually call sv_2iv if already IOK */
+#define SvIV_please(sv) \
+ STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
+ (void) SvIV(sv); } STMT_END
+#define SvIV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
+ assert(SvTYPE(sv) != SVt_PVAV); \
+ assert(SvTYPE(sv) != SVt_PVHV); \
+ assert(SvTYPE(sv) != SVt_PVCV); \
+ assert(!isGV_with_GP(sv)); \
+ (((XPVIV*) SvANY(sv))->xiv_iv = (val)); } STMT_END
+#define SvNV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) == SVt_NV || SvTYPE(sv) >= SVt_PVNV); \
+ assert(SvTYPE(sv) != SVt_PVAV); assert(SvTYPE(sv) != SVt_PVHV); \
+ assert(SvTYPE(sv) != SVt_PVCV); assert(SvTYPE(sv) != SVt_PVFM); \
+ assert(!isGV_with_GP(sv)); \
+ (((XPVNV*)SvANY(sv))->xnv_u.xnv_nv = (val)); } STMT_END
+#define SvPV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ assert(SvTYPE(sv) != SVt_PVAV); \
+ assert(SvTYPE(sv) != SVt_PVHV); \
+ assert(!isGV_with_GP(sv)); \
+ ((sv)->sv_u.svu_pv = (val)); } STMT_END
+#define SvUV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
+ assert(SvTYPE(sv) != SVt_PVAV); \
+ assert(SvTYPE(sv) != SVt_PVHV); \
+ assert(SvTYPE(sv) != SVt_PVCV); \
+ assert(!isGV_with_GP(sv)); \
+ (((XPVUV*)SvANY(sv))->xuv_uv = (val)); } STMT_END
+#define SvRV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
+ assert(SvTYPE(sv) != SVt_PVAV); \
+ assert(SvTYPE(sv) != SVt_PVHV); \
+ assert(SvTYPE(sv) != SVt_PVCV); \
+ assert(SvTYPE(sv) != SVt_PVFM); \
+ assert(!isGV_with_GP(sv)); \
+ ((sv)->sv_u.svu_rv = (val)); } STMT_END
+#define SvMAGIC_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
+ (((XPVMG*)SvANY(sv))->xmg_u.xmg_magic = (val)); } STMT_END
+#define SvSTASH_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
+ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
+#define SvCUR_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ assert(SvTYPE(sv) != SVt_PVAV); \
+ assert(SvTYPE(sv) != SVt_PVHV); \
+ assert(!isGV_with_GP(sv)); \
+ (((XPV*) SvANY(sv))->xpv_cur = (val)); } STMT_END
+#define SvLEN_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ assert(SvTYPE(sv) != SVt_PVAV); \
+ assert(SvTYPE(sv) != SVt_PVHV); \
+ assert(!isGV_with_GP(sv)); \
+ (((XPV*) SvANY(sv))->xpv_len = (val)); } STMT_END
+#define SvEND_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ SvCUR_set(sv, (val) - SvPVX(sv)); } STMT_END
+
+#define SvPV_renew(sv,n) \
+ STMT_START { SvLEN_set(sv, n); \
+ SvPV_set((sv), (MEM_WRAP_CHECK_(n,char) \
+ (char*)saferealloc((Malloc_t)SvPVX(sv), \
+ (MEM_SIZE)((n))))); \
+ } STMT_END
+
+#define SvPV_shrink_to_cur(sv) STMT_START { \
+ const STRLEN _lEnGtH = SvCUR(sv) + 1; \
+ SvPV_renew(sv, _lEnGtH); \
+ } STMT_END
+
+#define SvPV_free(sv) \
+ STMT_START { \
+ assert(SvTYPE(sv) >= SVt_PV); \
+ if (SvLEN(sv)) { \
+ assert(!SvROK(sv)); \
+ if(SvOOK(sv)) { \
+ SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); \
+ SvFLAGS(sv) &= ~SVf_OOK; \
+ } \
+ Safefree(SvPVX(sv)); \
+ } \
+ } STMT_END
+
+#ifdef PERL_CORE
+/* Code that crops up in three places to take a scalar and ready it to hold
+ a reference */
+# define prepare_SV_for_RV(sv) \
+ STMT_START { \
+ if (SvTYPE(sv) < SVt_RV) \
+ sv_upgrade(sv, SVt_RV); \
+ else if (SvPVX_const(sv)) { \
+ SvPV_free(sv); \
+ SvLEN_set(sv, 0); \
+ SvCUR_set(sv, 0); \
+ } \
+ } STMT_END
+#endif
+
+#define PERL_FBM_TABLE_OFFSET 1 /* Number of bytes between EOS and table */
+
+/* SvPOKp not SvPOK in the assertion because the string can be tainted! eg
+ perl -T -e '/$^X/'
+*/
+#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define BmFLAGS(sv) \
+ (*({ SV *const _bmflags = MUTABLE_SV(sv); \
+ assert(SvTYPE(_bmflags) == SVt_PVGV); \
+ assert(SvVALID(_bmflags)); \
+ &(((XPVGV*) SvANY(_bmflags))->xnv_u.xbm_s.xbm_flags); \
+ }))
+# define BmRARE(sv) \
+ (*({ SV *const _bmrare = MUTABLE_SV(sv); \
+ assert(SvTYPE(_bmrare) == SVt_PVGV); \
+ assert(SvVALID(_bmrare)); \
+ &(((XPVGV*) SvANY(_bmrare))->xnv_u.xbm_s.xbm_rare); \
+ }))
+# define BmUSEFUL(sv) \
+ (*({ SV *const _bmuseful = MUTABLE_SV(sv); \
+ assert(SvTYPE(_bmuseful) == SVt_PVGV); \
+ assert(SvVALID(_bmuseful)); \
+ assert(!SvIOK(_bmuseful)); \
+ &(((XPVGV*) SvANY(_bmuseful))->xiv_u.xivu_i32); \
+ }))
+# define BmPREVIOUS(sv) \
+ (*({ SV *const _bmprevious = MUTABLE_SV(sv); \
+ assert(SvTYPE(_bmprevious) == SVt_PVGV); \
+ assert(SvVALID(_bmprevious)); \
+ &(((XPVGV*) SvANY(_bmprevious))->xnv_u.xbm_s.xbm_previous); \
+ }))
+#else
+# define BmFLAGS(sv) ((XPVGV*) SvANY(sv))->xnv_u.xbm_s.xbm_flags
+# define BmRARE(sv) ((XPVGV*) SvANY(sv))->xnv_u.xbm_s.xbm_rare
+# define BmUSEFUL(sv) ((XPVGV*) SvANY(sv))->xiv_u.xivu_i32
+# define BmPREVIOUS(sv) ((XPVGV*) SvANY(sv))->xnv_u.xbm_s.xbm_previous
+
+#endif
+
+#define FmLINES(sv) ((XPVFM*) SvANY(sv))->xfm_lines
+
+#define LvTYPE(sv) ((XPVLV*) SvANY(sv))->xlv_type
+#define LvTARG(sv) ((XPVLV*) SvANY(sv))->xlv_targ
+#define LvTARGOFF(sv) ((XPVLV*) SvANY(sv))->xlv_targoff
+#define LvTARGLEN(sv) ((XPVLV*) SvANY(sv))->xlv_targlen
+
+#define IoIFP(sv) ((XPVIO*) SvANY(sv))->xio_ifp
+#define IoOFP(sv) ((XPVIO*) SvANY(sv))->xio_ofp
+#define IoDIRP(sv) ((XPVIO*) SvANY(sv))->xio_dirp
+#define IoANY(sv) ((XPVIO*) SvANY(sv))->xio_any
+#define IoLINES(sv) ((XPVIO*) SvANY(sv))->xio_lines
+#define IoPAGE(sv) ((XPVIO*) SvANY(sv))->xio_page
+#define IoPAGE_LEN(sv) ((XPVIO*) SvANY(sv))->xio_page_len
+#define IoLINES_LEFT(sv)((XPVIO*) SvANY(sv))->xio_lines_left
+#define IoTOP_NAME(sv) ((XPVIO*) SvANY(sv))->xio_top_name
+#define IoTOP_GV(sv) ((XPVIO*) SvANY(sv))->xio_top_gv
+#define IoFMT_NAME(sv) ((XPVIO*) SvANY(sv))->xio_fmt_name
+#define IoFMT_GV(sv) ((XPVIO*) SvANY(sv))->xio_fmt_gv
+#define IoBOTTOM_NAME(sv)((XPVIO*) SvANY(sv))->xio_bottom_name
+#define IoBOTTOM_GV(sv) ((XPVIO*) SvANY(sv))->xio_bottom_gv
+#define IoTYPE(sv) ((XPVIO*) SvANY(sv))->xio_type
+#define IoFLAGS(sv) ((XPVIO*) SvANY(sv))->xio_flags
+
+/* IoTYPE(sv) is a single character telling the type of I/O connection. */
+#define IoTYPE_RDONLY '<'
+#define IoTYPE_WRONLY '>'
+#define IoTYPE_RDWR '+'
+#define IoTYPE_APPEND 'a'
+#define IoTYPE_PIPE '|'
+#define IoTYPE_STD '-' /* stdin or stdout */
+#define IoTYPE_SOCKET 's'
+#define IoTYPE_CLOSED ' '
+#define IoTYPE_IMPLICIT 'I' /* stdin or stdout or stderr */
+#define IoTYPE_NUMERIC '#' /* fdopen */
+
+/*
+=for apidoc Am|bool|SvTAINTED|SV* sv
+Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if
+not.
+
+=for apidoc Am|void|SvTAINTED_on|SV* sv
+Marks an SV as tainted if tainting is enabled.
+
+=for apidoc Am|void|SvTAINTED_off|SV* sv
+Untaints an SV. Be I<very> careful with this routine, as it short-circuits
+some of Perl's fundamental security features. XS module authors should not
+use this function unless they fully understand all the implications of
+unconditionally untainting the value. Untainting should be done in the
+standard perl fashion, via a carefully crafted regexp, rather than directly
+untainting variables.
+
+=for apidoc Am|void|SvTAINT|SV* sv
+Taints an SV if tainting is enabled.
+
+=cut
+*/
+
+#define sv_taint(sv) sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0)
+
+#define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
+#define SvTAINTED_on(sv) STMT_START{ if(PL_tainting){sv_taint(sv);} }STMT_END
+#define SvTAINTED_off(sv) STMT_START{ if(PL_tainting){sv_untaint(sv);} }STMT_END
+
+#define SvTAINT(sv) \
+ STMT_START { \
+ if (PL_tainting) { \
+ if (PL_tainted) \
+ SvTAINTED_on(sv); \
+ } \
+ } STMT_END
+
+/*
+=for apidoc Am|char*|SvPV_force|SV* sv|STRLEN len
+Like C<SvPV> but will force the SV into containing just a string
+(C<SvPOK_only>). You want force if you are going to update the C<SvPVX>
+directly.
+
+=for apidoc Am|char*|SvPV_force_nomg|SV* sv|STRLEN len
+Like C<SvPV> but will force the SV into containing just a string
+(C<SvPOK_only>). You want force if you are going to update the C<SvPVX>
+directly. Doesn't process magic.
+
+=for apidoc Am|char*|SvPV|SV* sv|STRLEN len
+Returns a pointer to the string in the SV, or a stringified form of
+the SV if the SV does not contain a string. The SV may cache the
+stringified version becoming C<SvPOK>. Handles 'get' magic. See also
+C<SvPVx> for a version which guarantees to evaluate sv only once.
+
+=for apidoc Am|char*|SvPVx|SV* sv|STRLEN len
+A version of C<SvPV> which guarantees to evaluate C<sv> only once.
+Only use this if C<sv> is an expression with side effects, otherwise use the
+more efficient C<SvPVX>.
+
+=for apidoc Am|char*|SvPV_nomg|SV* sv|STRLEN len
+Like C<SvPV> but doesn't process magic.
+
+=for apidoc Am|char*|SvPV_nolen|SV* sv
+Returns a pointer to the string in the SV, or a stringified form of
+the SV if the SV does not contain a string. The SV may cache the
+stringified form becoming C<SvPOK>. Handles 'get' magic.
+
+=for apidoc Am|IV|SvIV|SV* sv
+Coerces the given SV to an integer and returns it. See C<SvIVx> for a
+version which guarantees to evaluate sv only once.
+
+=for apidoc Am|IV|SvIV_nomg|SV* sv
+Like C<SvIV> but doesn't process magic.
+
+=for apidoc Am|IV|SvIVx|SV* sv
+Coerces the given SV to an integer and returns it. Guarantees to evaluate
+C<sv> only once. Only use this if C<sv> is an expression with side effects,
+otherwise use the more efficient C<SvIV>.
+
+=for apidoc Am|NV|SvNV|SV* sv
+Coerce the given SV to a double and return it. See C<SvNVx> for a version
+which guarantees to evaluate sv only once.
+
+=for apidoc Am|NV|SvNVx|SV* sv
+Coerces the given SV to a double and returns it. Guarantees to evaluate
+C<sv> only once. Only use this if C<sv> is an expression with side effects,
+otherwise use the more efficient C<SvNV>.
+
+=for apidoc Am|UV|SvUV|SV* sv
+Coerces the given SV to an unsigned integer and returns it. See C<SvUVx>
+for a version which guarantees to evaluate sv only once.
+
+=for apidoc Am|UV|SvUV_nomg|SV* sv
+Like C<SvUV> but doesn't process magic.
+
+=for apidoc Am|UV|SvUVx|SV* sv
+Coerces the given SV to an unsigned integer and returns it. Guarantees to
+C<sv> only once. Only use this if C<sv> is an expression with side effects,
+otherwise use the more efficient C<SvUV>.
+
+=for apidoc Am|bool|SvTRUE|SV* sv
+Returns a boolean indicating whether Perl would evaluate the SV as true or
+false. See SvOK() for a defined/undefined test. Does not handle 'get' magic.
+
+=for apidoc Am|char*|SvPVutf8_force|SV* sv|STRLEN len
+Like C<SvPV_force>, but converts sv to utf8 first if necessary.
+
+=for apidoc Am|char*|SvPVutf8|SV* sv|STRLEN len
+Like C<SvPV>, but converts sv to utf8 first if necessary.
+
+=for apidoc Am|char*|SvPVutf8_nolen|SV* sv
+Like C<SvPV_nolen>, but converts sv to utf8 first if necessary.
+
+=for apidoc Am|char*|SvPVbyte_force|SV* sv|STRLEN len
+Like C<SvPV_force>, but converts sv to byte representation first if necessary.
+
+=for apidoc Am|char*|SvPVbyte|SV* sv|STRLEN len
+Like C<SvPV>, but converts sv to byte representation first if necessary.
+
+=for apidoc Am|char*|SvPVbyte_nolen|SV* sv
+Like C<SvPV_nolen>, but converts sv to byte representation first if necessary.
+
+=for apidoc Am|char*|SvPVutf8x_force|SV* sv|STRLEN len
+Like C<SvPV_force>, but converts sv to utf8 first if necessary.
+Guarantees to evaluate sv only once; use the more efficient C<SvPVutf8_force>
+otherwise.
+
+=for apidoc Am|char*|SvPVutf8x|SV* sv|STRLEN len
+Like C<SvPV>, but converts sv to utf8 first if necessary.
+Guarantees to evaluate sv only once; use the more efficient C<SvPVutf8>
+otherwise.
+
+=for apidoc Am|char*|SvPVbytex_force|SV* sv|STRLEN len
+Like C<SvPV_force>, but converts sv to byte representation first if necessary.
+Guarantees to evaluate sv only once; use the more efficient C<SvPVbyte_force>
+otherwise.
+
+=for apidoc Am|char*|SvPVbytex|SV* sv|STRLEN len
+Like C<SvPV>, but converts sv to byte representation first if necessary.
+Guarantees to evaluate sv only once; use the more efficient C<SvPVbyte>
+otherwise.
+
+=for apidoc Am|bool|SvIsCOW|SV* sv
+Returns a boolean indicating whether the SV is Copy-On-Write. (either shared
+hash key scalars, or full Copy On Write scalars if 5.9.0 is configured for
+COW)
+
+=for apidoc Am|bool|SvIsCOW_shared_hash|SV* sv
+Returns a boolean indicating whether the SV is Copy-On-Write shared hash key
+scalar.
+
+=for apidoc Am|void|sv_catpvn_nomg|SV* sv|const char* ptr|STRLEN len
+Like C<sv_catpvn> but doesn't process magic.
+
+=for apidoc Am|void|sv_setsv_nomg|SV* dsv|SV* ssv
+Like C<sv_setsv> but doesn't process magic.
+
+=for apidoc Am|void|sv_catsv_nomg|SV* dsv|SV* ssv
+Like C<sv_catsv> but doesn't process magic.
+
+=for apidoc Amdb|STRLEN|sv_utf8_upgrade_nomg|NN SV *sv
+
+Like sv_utf8_upgrade, but doesn't do magic on C<sv>
+
+=cut
+*/
+
+/* Let us hope that bitmaps for UV and IV are the same */
+#define SvIV(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))
+#define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
+#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
+
+#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
+#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
+
+/* ----*/
+
+#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
+#define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
+#define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
+
+#define SvPV_flags(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
+#define SvPV_flags_const(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
+ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
+#define SvPV_flags_const_nolen(sv, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX_const(sv) : \
+ (const char*) sv_2pv_flags(sv, 0, flags|SV_CONST_RETURN))
+#define SvPV_flags_mutable(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
+ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
+
+#define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
+#define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
+#define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC)
+
+#define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0)
+#define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
+
+#define SvPV_force_flags(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
+#define SvPV_force_flags_nolen(sv, flags) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? SvPVX(sv) : sv_pvn_force_flags(sv, 0, flags))
+#define SvPV_force_flags_mutable(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
+ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
+
+#define SvPV_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC))
+
+#define SvPV_nolen_const(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX_const(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC|SV_CONST_RETURN))
+
+#define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
+#define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0)
+#define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0)
+
+/* ----*/
+
+#define SvPVutf8(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+
+#define SvPVutf8_force(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST)) == (SVf_POK|SVf_UTF8) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
+
+
+#define SvPVutf8_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8)\
+ ? SvPVX(sv) : sv_2pvutf8(sv, 0))
+
+/* ----*/
+
+#define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+
+#define SvPVbyte_force(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
+
+#define SvPVbyte_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK)\
+ ? SvPVX(sv) : sv_2pvbyte(sv, 0))
+
+
+
+/* define FOOx(): idempotent versions of FOO(). If possible, use a local
+ * var to evaluate the arg once; failing that, use a global if possible;
+ * failing that, call a function to do the work
+ */
+
+#define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp)
+#define SvPVutf8x_force(sv, lp) sv_pvutf8n_force(sv, &lp)
+#define SvPVbytex_force(sv, lp) sv_pvbyten_force(sv, &lp)
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+
+# define SvIVx(sv) ({SV *_sv = MUTABLE_SV(sv); SvIV(_sv); })
+# define SvUVx(sv) ({SV *_sv = MUTABLE_SV(sv); SvUV(_sv); })
+# define SvNVx(sv) ({SV *_sv = MUTABLE_SV(sv); SvNV(_sv); })
+# define SvPVx(sv, lp) ({SV *_sv = (sv); SvPV(_sv, lp); })
+# define SvPVx_const(sv, lp) ({SV *_sv = (sv); SvPV_const(_sv, lp); })
+# define SvPVx_nolen(sv) ({SV *_sv = (sv); SvPV_nolen(_sv); })
+# define SvPVx_nolen_const(sv) ({SV *_sv = (sv); SvPV_nolen_const(_sv); })
+# define SvPVutf8x(sv, lp) ({SV *_sv = (sv); SvPVutf8(_sv, lp); })
+# define SvPVbytex(sv, lp) ({SV *_sv = (sv); SvPVbyte(_sv, lp); })
+# define SvPVbytex_nolen(sv) ({SV *_sv = (sv); SvPVbyte_nolen(_sv); })
+# define SvTRUE(sv) ( \
+ !sv \
+ ? 0 \
+ : SvPOK(sv) \
+ ? (({XPV *nxpv = (XPV*)SvANY(sv); \
+ nxpv && \
+ (nxpv->xpv_cur > 1 || \
+ (nxpv->xpv_cur && *(sv)->sv_u.svu_pv != '0')); }) \
+ ? 1 \
+ : 0) \
+ : \
+ SvIOK(sv) \
+ ? SvIVX(sv) != 0 \
+ : SvNOK(sv) \
+ ? SvNVX(sv) != 0.0 \
+ : sv_2bool(sv) )
+# define SvTRUEx(sv) ({SV *_sv = (sv); SvTRUE(_sv); })
+
+#else /* __GNUC__ */
+
+/* These inlined macros use globals, which will require a thread
+ * declaration in user code, so we avoid them under threads */
+
+# define SvIVx(sv) ((PL_Sv = (sv)), SvIV(PL_Sv))
+# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
+# define SvNVx(sv) ((PL_Sv = (sv)), SvNV(PL_Sv))
+# define SvPVx(sv, lp) ((PL_Sv = (sv)), SvPV(PL_Sv, lp))
+# define SvPVx_const(sv, lp) ((PL_Sv = (sv)), SvPV_const(PL_Sv, lp))
+# define SvPVx_nolen(sv) ((PL_Sv = (sv)), SvPV_nolen(PL_Sv))
+# define SvPVx_nolen_const(sv) ((PL_Sv = (sv)), SvPV_nolen_const(PL_Sv))
+# define SvPVutf8x(sv, lp) ((PL_Sv = (sv)), SvPVutf8(PL_Sv, lp))
+# define SvPVbytex(sv, lp) ((PL_Sv = (sv)), SvPVbyte(PL_Sv, lp))
+# define SvPVbytex_nolen(sv) ((PL_Sv = (sv)), SvPVbyte_nolen(PL_Sv))
+# define SvTRUE(sv) ( \
+ !sv \
+ ? 0 \
+ : SvPOK(sv) \
+ ? ((PL_Xpv = (XPV*)SvANY(PL_Sv = (sv))) && \
+ (PL_Xpv->xpv_cur > 1 || \
+ (PL_Xpv->xpv_cur && *PL_Sv->sv_u.svu_pv != '0')) \
+ ? 1 \
+ : 0) \
+ : \
+ SvIOK(sv) \
+ ? SvIVX(sv) != 0 \
+ : SvNOK(sv) \
+ ? SvNVX(sv) != 0.0 \
+ : sv_2bool(sv) )
+# define SvTRUEx(sv) ((PL_Sv = (sv)), SvTRUE(PL_Sv))
+#endif /* __GNU__ */
+
+#define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
+ (SVf_FAKE | SVf_READONLY))
+#define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
+
+#define SvSHARED_HEK_FROM_PV(pvx) \
+ ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
+#define SvSHARED_HASH(sv) (0 + SvSHARED_HEK_FROM_PV(SvPVX_const(sv))->hek_hash)
+
+/* flag values for sv_*_flags functions */
+#define SV_IMMEDIATE_UNREF 1
+#define SV_GMAGIC 2
+#define SV_COW_DROP_PV 4
+#define SV_UTF8_NO_ENCODING 8
+#define SV_NOSTEAL 16
+#define SV_CONST_RETURN 32
+#define SV_MUTABLE_RETURN 64
+#define SV_SMAGIC 128
+#define SV_HAS_TRAILING_NUL 256
+#define SV_COW_SHARED_HASH_KEYS 512
+/* This one is only enabled for PERL_OLD_COPY_ON_WRITE */
+#define SV_COW_OTHER_PVS 1024
+
+/* The core is safe for this COW optimisation. XS code on CPAN may not be.
+ So only default to doing the COW setup if we're in the core.
+ */
+#ifdef PERL_CORE
+# ifndef SV_DO_COW_SVSETSV
+# define SV_DO_COW_SVSETSV SV_COW_SHARED_HASH_KEYS|SV_COW_OTHER_PVS
+# endif
+#endif
+
+#ifndef SV_DO_COW_SVSETSV
+# define SV_DO_COW_SVSETSV 0
+#endif
+
+
+#define sv_unref(sv) sv_unref_flags(sv, 0)
+#define sv_force_normal(sv) sv_force_normal_flags(sv, 0)
+#define sv_usepvn(sv, p, l) sv_usepvn_flags(sv, p, l, 0)
+#define sv_usepvn_mg(sv, p, l) sv_usepvn_flags(sv, p, l, SV_SMAGIC)
+
+/* We are about to replace the SV's current value. So if it's copy on write
+ we need to normalise it. Use the SV_COW_DROP_PV flag hint to say that
+ the value is about to get thrown away, so drop the PV rather than go to
+ the effort of making a read-write copy only for it to get immediately
+ discarded. */
+
+#define SV_CHECK_THINKFIRST_COW_DROP(sv) if (SvTHINKFIRST(sv)) \
+ sv_force_normal_flags(sv, SV_COW_DROP_PV)
+
+#ifdef PERL_OLD_COPY_ON_WRITE
+#define SvRELEASE_IVX(sv) \
+ ((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), SvOOK_off(sv))
+# define SvIsCOW_normal(sv) (SvIsCOW(sv) && SvLEN(sv))
+#else
+# define SvRELEASE_IVX(sv) SvOOK_off(sv)
+#endif /* PERL_OLD_COPY_ON_WRITE */
+
+#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
+ SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
+ SVf_OOK|SVf_BREAK|SVf_READONLY)
+#define CAN_COW_FLAGS (SVp_POK|SVf_POK)
+
+#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \
+ sv_force_normal_flags(sv, 0)
+
+
+/* all these 'functions' are now just macros */
+
+#define sv_pv(sv) SvPV_nolen(sv)
+#define sv_pvutf8(sv) SvPVutf8_nolen(sv)
+#define sv_pvbyte(sv) SvPVbyte_nolen(sv)
+
+#define sv_pvn_force_nomg(sv, lp) sv_pvn_force_flags(sv, lp, 0)
+#define sv_utf8_upgrade_nomg(sv) sv_utf8_upgrade_flags(sv, 0)
+#define sv_catpvn_nomg(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, 0)
+#define sv_setsv(dsv, ssv) \
+ sv_setsv_flags(dsv, ssv, SV_GMAGIC|SV_DO_COW_SVSETSV)
+#define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_DO_COW_SVSETSV)
+#define sv_catsv(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC)
+#define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0)
+#define sv_catsv_mg(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC|SV_SMAGIC)
+#define sv_catpvn(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC)
+#define sv_catpvn_mg(sv, sstr, slen) \
+ sv_catpvn_flags(sv, sstr, slen, SV_GMAGIC|SV_SMAGIC);
+#define sv_2pv(sv, lp) sv_2pv_flags(sv, lp, SV_GMAGIC)
+#define sv_2pv_nolen(sv) sv_2pv(sv, 0)
+#define sv_2pvbyte_nolen(sv) sv_2pvbyte(sv, 0)
+#define sv_2pvutf8_nolen(sv) sv_2pvutf8(sv, 0)
+#define sv_2pv_nomg(sv, lp) sv_2pv_flags(sv, lp, 0)
+#define sv_pvn_force(sv, lp) sv_pvn_force_flags(sv, lp, SV_GMAGIC)
+#define sv_utf8_upgrade(sv) sv_utf8_upgrade_flags(sv, SV_GMAGIC)
+#define sv_2iv(sv) sv_2iv_flags(sv, SV_GMAGIC)
+#define sv_2uv(sv) sv_2uv_flags(sv, SV_GMAGIC)
+#define sv_insert(bigstr, offset, len, little, littlelen) \
+ Perl_sv_insert_flags(aTHX_ (bigstr),(offset), (len), (little), \
+ (littlelen), SV_GMAGIC)
+
+/* Should be named SvCatPVN_utf8_upgrade? */
+#define sv_catpvn_utf8_upgrade(dsv, sstr, slen, nsv) \
+ STMT_START { \
+ if (!(nsv)) \
+ nsv = newSVpvn_flags(sstr, slen, SVs_TEMP); \
+ else \
+ sv_setpvn(nsv, sstr, slen); \
+ SvUTF8_off(nsv); \
+ sv_utf8_upgrade(nsv); \
+ sv_catsv(dsv, nsv); \
+ } STMT_END
+
+/*
+=for apidoc Am|SV*|newRV_inc|SV* sv
+
+Creates an RV wrapper for an SV. The reference count for the original SV is
+incremented.
+
+=cut
+*/
+
+#define newRV_inc(sv) newRV(sv)
+
+/* the following macros update any magic values this sv is associated with */
+
+/*
+=head1 Magical Functions
+
+=for apidoc Am|void|SvGETMAGIC|SV* sv
+Invokes C<mg_get> on an SV if it has 'get' magic. This macro evaluates its
+argument more than once.
+
+=for apidoc Am|void|SvSETMAGIC|SV* sv
+Invokes C<mg_set> on an SV if it has 'set' magic. This macro evaluates its
+argument more than once.
+
+=for apidoc Am|void|SvSetSV|SV* dsb|SV* ssv
+Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments
+more than once.
+
+=for apidoc Am|void|SvSetSV_nosteal|SV* dsv|SV* ssv
+Calls a non-destructive version of C<sv_setsv> if dsv is not the same as
+ssv. May evaluate arguments more than once.
+
+=for apidoc Am|void|SvSetMagicSV|SV* dsb|SV* ssv
+Like C<SvSetSV>, but does any set magic required afterwards.
+
+=for apidoc Am|void|SvSetMagicSV_nosteal|SV* dsv|SV* ssv
+Like C<SvSetSV_nosteal>, but does any set magic required afterwards.
+
+=for apidoc Am|void|SvSHARE|SV* sv
+Arranges for sv to be shared between threads if a suitable module
+has been loaded.
+
+=for apidoc Am|void|SvLOCK|SV* sv
+Arranges for a mutual exclusion lock to be obtained on sv if a suitable module
+has been loaded.
+
+=for apidoc Am|void|SvUNLOCK|SV* sv
+Releases a mutual exclusion lock on sv if a suitable module
+has been loaded.
+
+=head1 SV Manipulation Functions
+
+=for apidoc Am|char *|SvGROW|SV* sv|STRLEN len
+Expands the character buffer in the SV so that it has room for the
+indicated number of bytes (remember to reserve space for an extra trailing
+NUL character). Calls C<sv_grow> to perform the expansion if necessary.
+Returns a pointer to the character buffer.
+
+=cut
+*/
+
+#define SvSHARE(sv) CALL_FPTR(PL_sharehook)(aTHX_ sv)
+#define SvLOCK(sv) CALL_FPTR(PL_lockhook)(aTHX_ sv)
+#define SvUNLOCK(sv) CALL_FPTR(PL_unlockhook)(aTHX_ sv)
+#define SvDESTROYABLE(sv) CALL_FPTR(PL_destroyhook)(aTHX_ sv)
+
+#define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END
+
+#define SvSetSV_and(dst,src,finally) \
+ STMT_START { \
+ if ((dst) != (src)) { \
+ sv_setsv(dst, src); \
+ finally; \
+ } \
+ } STMT_END
+#define SvSetSV_nosteal_and(dst,src,finally) \
+ STMT_START { \
+ if ((dst) != (src)) { \
+ sv_setsv_flags(dst, src, SV_GMAGIC | SV_NOSTEAL | SV_DO_COW_SVSETSV); \
+ finally; \
+ } \
+ } STMT_END
+
+#define SvSetSV(dst,src) \
+ SvSetSV_and(dst,src,/*nothing*/;)
+#define SvSetSV_nosteal(dst,src) \
+ SvSetSV_nosteal_and(dst,src,/*nothing*/;)
+
+#define SvSetMagicSV(dst,src) \
+ SvSetSV_and(dst,src,SvSETMAGIC(dst))
+#define SvSetMagicSV_nosteal(dst,src) \
+ SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst))
+
+
+#if !defined(SKIP_DEBUGGING)
+#define SvPEEK(sv) sv_peek(sv)
+#else
+#define SvPEEK(sv) ""
+#endif
+
+#define SvIMMORTAL(sv) ((sv)==&PL_sv_undef || (sv)==&PL_sv_yes || (sv)==&PL_sv_no || (sv)==&PL_sv_placeholder)
+
+#define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+
+#define isGV(sv) (SvTYPE(sv) == SVt_PVGV)
+/* If I give every macro argument a different name, then there won't be bugs
+ where nested macros get confused. Been there, done that. */
+#define isGV_with_GP(pwadak) \
+ (((SvFLAGS(pwadak) & (SVp_POK|SVpgv_GP)) == SVpgv_GP) \
+ && (SvTYPE(pwadak) == SVt_PVGV || SvTYPE(pwadak) == SVt_PVLV))
+#define isGV_with_GP_on(sv) STMT_START { \
+ assert (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); \
+ assert (!SvPOKp(sv)); \
+ assert (!SvIOKp(sv)); \
+ (SvFLAGS(sv) |= SVpgv_GP); \
+ } STMT_END
+#define isGV_with_GP_off(sv) STMT_START { \
+ assert (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); \
+ assert (!SvPOKp(sv)); \
+ assert (!SvIOKp(sv)); \
+ (SvFLAGS(sv) &= ~SVpgv_GP); \
+ } STMT_END
+
+
+#define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+#define SvGROW_mutable(sv,len) \
+ (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX_mutable(sv))
+#define Sv_Grow sv_grow
+
+#define CLONEf_COPY_STACKS 1
+#define CLONEf_KEEP_PTR_TABLE 2
+#define CLONEf_CLONE_HOST 4
+#define CLONEf_JOIN_IN 8
+
+struct clone_params {
+ AV* stashes;
+ UV flags;
+ PerlInterpreter *proto_perl;
+};
+
+/*
+=for apidoc Am|SV*|newSVpvn_utf8|NULLOK const char* s|STRLEN len|U32 utf8
+
+Creates a new SV and copies a string into it. If utf8 is true, calls
+C<SvUTF8_on> on the new SV. Implemented as a wrapper around C<newSVpvn_flags>.
+
+=cut
+*/
+
+#define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/sys/socket.h b/Master/tlpkg/tlperl.straw/lib/CORE/sys/socket.h
new file mode 100755
index 00000000000..a3c53b0e883
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/sys/socket.h
@@ -0,0 +1,189 @@
+/* sys/socket.h */
+
+/* djl */
+/* Provide UNIX compatibility */
+
+#ifndef _INC_SYS_SOCKET
+#define _INC_SYS_SOCKET
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define WIN32_LEAN_AND_MEAN
+#ifdef __GNUC__
+# define Win32_Winsock
+#endif
+#include <windows.h>
+
+
+/* Too late to include winsock2.h if winsock.h has already been loaded */
+#ifndef _WINSOCKAPI_
+# if defined(UNDER_CE) && UNDER_CE <= 300
+ /* winsock2 only for 4.00+ */
+# include <winsock.h>
+# else
+# include <winsock2.h>
+#endif
+#endif
+
+#include "win32.h"
+
+#define ENOTSOCK WSAENOTSOCK
+
+#ifdef USE_SOCKETS_AS_HANDLES
+
+#ifndef PERL_FD_SETSIZE
+#define PERL_FD_SETSIZE 64
+#endif
+
+#define PERL_BITS_PER_BYTE 8
+#define PERL_NFDBITS (sizeof(Perl_fd_mask)*PERL_BITS_PER_BYTE)
+
+typedef int Perl_fd_mask;
+
+typedef struct Perl_fd_set {
+ Perl_fd_mask bits[(PERL_FD_SETSIZE+PERL_NFDBITS-1)/PERL_NFDBITS];
+} Perl_fd_set;
+
+#define PERL_FD_CLR(n,p) \
+ ((p)->bits[(n)/PERL_NFDBITS] &= ~((unsigned)1 << ((n)%PERL_NFDBITS)))
+
+#define PERL_FD_SET(n,p) \
+ ((p)->bits[(n)/PERL_NFDBITS] |= ((unsigned)1 << ((n)%PERL_NFDBITS)))
+
+#define PERL_FD_ZERO(p) memset((char *)(p),0,sizeof(*(p)))
+
+#define PERL_FD_ISSET(n,p) \
+ ((p)->bits[(n)/PERL_NFDBITS] & ((unsigned)1 << ((n)%PERL_NFDBITS)))
+
+#else /* USE_SOCKETS_AS_HANDLES */
+
+#define Perl_fd_set fd_set
+#define PERL_FD_SET(n,p) FD_SET(n,p)
+#define PERL_FD_CLR(n,p) FD_CLR(n,p)
+#define PERL_FD_ISSET(n,p) FD_ISSET(n,p)
+#define PERL_FD_ZERO(p) FD_ZERO(p)
+
+#endif /* USE_SOCKETS_AS_HANDLES */
+
+SOCKET win32_accept (SOCKET s, struct sockaddr *addr, int *addrlen);
+int win32_bind (SOCKET s, const struct sockaddr *addr, int namelen);
+int win32_closesocket (SOCKET s);
+int win32_connect (SOCKET s, const struct sockaddr *name, int namelen);
+int win32_ioctlsocket (SOCKET s, long cmd, u_long *argp);
+int win32_getpeername (SOCKET s, struct sockaddr *name, int * namelen);
+int win32_getsockname (SOCKET s, struct sockaddr *name, int * namelen);
+int win32_getsockopt (SOCKET s, int level, int optname, char * optval, int *optlen);
+u_long win32_htonl (u_long hostlong);
+u_short win32_htons (u_short hostshort);
+unsigned long win32_inet_addr (const char * cp);
+char * win32_inet_ntoa (struct in_addr in);
+int win32_listen (SOCKET s, int backlog);
+u_long win32_ntohl (u_long netlong);
+u_short win32_ntohs (u_short netshort);
+int win32_recv (SOCKET s, char * buf, int len, int flags);
+int win32_recvfrom (SOCKET s, char * buf, int len, int flags,
+ struct sockaddr *from, int * fromlen);
+int win32_select (int nfds, Perl_fd_set *rfds, Perl_fd_set *wfds, Perl_fd_set *xfds,
+ const struct timeval *timeout);
+int win32_send (SOCKET s, const char * buf, int len, int flags);
+int win32_sendto (SOCKET s, const char * buf, int len, int flags,
+ const struct sockaddr *to, int tolen);
+int win32_setsockopt (SOCKET s, int level, int optname,
+ const char * optval, int optlen);
+SOCKET win32_socket (int af, int type, int protocol);
+int win32_shutdown (SOCKET s, int how);
+
+/* Database function prototypes */
+
+struct hostent * win32_gethostbyaddr(const char * addr, int len, int type);
+struct hostent * win32_gethostbyname(const char * name);
+int win32_gethostname (char * name, int namelen);
+struct servent * win32_getservbyport(int port, const char * proto);
+struct servent * win32_getservbyname(const char * name, const char * proto);
+struct protoent * win32_getprotobynumber(int proto);
+struct protoent * win32_getprotobyname(const char * name);
+struct protoent *win32_getprotoent(void);
+struct servent *win32_getservent(void);
+void win32_sethostent(int stayopen);
+void win32_setnetent(int stayopen);
+struct netent * win32_getnetent(void);
+struct netent * win32_getnetbyname(char *name);
+struct netent * win32_getnetbyaddr(long net, int type);
+void win32_setprotoent(int stayopen);
+void win32_setservent(int stayopen);
+void win32_endhostent(void);
+void win32_endnetent(void);
+void win32_endprotoent(void);
+void win32_endservent(void);
+
+#ifndef WIN32SCK_IS_STDSCK
+
+/* direct to our version */
+
+#define htonl win32_htonl
+#define htons win32_htons
+#define ntohl win32_ntohl
+#define ntohs win32_ntohs
+#define inet_addr win32_inet_addr
+#define inet_ntoa win32_inet_ntoa
+
+#define socket win32_socket
+#define bind win32_bind
+#define listen win32_listen
+#define accept win32_accept
+#define connect win32_connect
+#define send win32_send
+#define sendto win32_sendto
+#define recv win32_recv
+#define recvfrom win32_recvfrom
+#define shutdown win32_shutdown
+#define closesocket win32_closesocket
+#define ioctlsocket win32_ioctlsocket
+#define setsockopt win32_setsockopt
+#define getsockopt win32_getsockopt
+#define getpeername win32_getpeername
+#define getsockname win32_getsockname
+#define gethostname win32_gethostname
+#define gethostbyname win32_gethostbyname
+#define gethostbyaddr win32_gethostbyaddr
+#define getprotobyname win32_getprotobyname
+#define getprotobynumber win32_getprotobynumber
+#define getservbyname win32_getservbyname
+#define getservbyport win32_getservbyport
+#define select win32_select
+#define endhostent win32_endhostent
+#define endnetent win32_endnetent
+#define endprotoent win32_endprotoent
+#define endservent win32_endservent
+#define getnetent win32_getnetent
+#define getnetbyname win32_getnetbyname
+#define getnetbyaddr win32_getnetbyaddr
+#define getprotoent win32_getprotoent
+#define getservent win32_getservent
+#define sethostent win32_sethostent
+#define setnetent win32_setnetent
+#define setprotoent win32_setprotoent
+#define setservent win32_setservent
+
+#ifdef USE_SOCKETS_AS_HANDLES
+#undef fd_set
+#undef FD_SET
+#undef FD_CLR
+#undef FD_ISSET
+#undef FD_ZERO
+#define fd_set Perl_fd_set
+#define FD_SET(n,p) PERL_FD_SET(n,p)
+#define FD_CLR(n,p) PERL_FD_CLR(n,p)
+#define FD_ISSET(n,p) PERL_FD_ISSET(n,p)
+#define FD_ZERO(p) PERL_FD_ZERO(p)
+#endif /* USE_SOCKETS_AS_HANDLES */
+
+#endif /* WIN32SCK_IS_STDSCK */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _INC_SYS_SOCKET */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/thread.h b/Master/tlpkg/tlperl.straw/lib/CORE/thread.h
new file mode 100755
index 00000000000..3a059b5f861
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/thread.h
@@ -0,0 +1,488 @@
+/* thread.h
+ *
+ * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ * by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#if defined(USE_ITHREADS)
+
+#if defined(VMS)
+#include <builtins.h>
+#endif
+
+#ifdef WIN32
+# include <win32thread.h>
+#else
+#ifdef NETWARE
+# include <nw5thread.h>
+#else
+# ifdef OLD_PTHREADS_API /* Here be dragons. */
+# define DETACH(t) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_detach(&(t)->self))) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ Perl_croak_nocontext("panic: DETACH (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } \
+ } STMT_END
+
+# define PERL_GET_CONTEXT Perl_get_context()
+# define PERL_SET_CONTEXT(t) Perl_set_context((void*)t)
+
+# define PTHREAD_GETSPECIFIC_INT
+# ifdef DJGPP
+# define pthread_addr_t any_t
+# define NEED_PTHREAD_INIT
+# define PTHREAD_CREATE_JOINABLE (1)
+# endif
+# ifdef __OPEN_VM
+# define pthread_addr_t void *
+# endif
+# ifdef OEMVS
+# define pthread_addr_t void *
+# define pthread_create(t,a,s,d) pthread_create(t,&(a),s,d)
+# define pthread_keycreate pthread_key_create
+# endif
+# ifdef VMS
+# define pthread_attr_init(a) pthread_attr_create(a)
+# define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_setdetach_np(a,s)
+# define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d)
+# define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d))
+# define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
+# define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
+# endif
+# if defined(__hpux) && defined(__ux_version) && __ux_version <= 1020
+# define pthread_attr_init(a) pthread_attr_create(a)
+ /* XXX pthread_setdetach_np() missing in DCE threads on HP-UX 10.20 */
+# define PTHREAD_ATTR_SETDETACHSTATE(a,s) (0)
+# define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d)
+# define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d))
+# define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
+# define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
+# endif
+# if defined(DJGPP) || defined(__OPEN_VM) || defined(OEMVS)
+# define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,&(s))
+# define YIELD pthread_yield(NULL)
+# endif
+# endif
+# if !defined(__hpux) || !defined(__ux_version) || __ux_version > 1020
+# define pthread_mutexattr_default NULL
+# define pthread_condattr_default NULL
+# endif
+#endif /* NETWARE */
+#endif
+
+#ifndef PTHREAD_CREATE
+/* You are not supposed to pass NULL as the 2nd arg of PTHREAD_CREATE(). */
+# define PTHREAD_CREATE(t,a,s,d) pthread_create(t,&(a),s,d)
+#endif
+
+#ifndef PTHREAD_ATTR_SETDETACHSTATE
+# define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,s)
+#endif
+
+#ifndef PTHREAD_CREATE_JOINABLE
+# ifdef OLD_PTHREAD_CREATE_JOINABLE
+# define PTHREAD_CREATE_JOINABLE OLD_PTHREAD_CREATE_JOINABLE
+# else
+# define PTHREAD_CREATE_JOINABLE 0 /* Panic? No, guess. */
+# endif
+#endif
+
+#ifdef DGUX
+# define THREAD_CREATE_NEEDS_STACK (32*1024)
+#endif
+
+#ifdef __VMS
+ /* Default is 1024 on VAX, 8192 otherwise */
+# ifdef __ia64
+# define THREAD_CREATE_NEEDS_STACK (48*1024)
+# else
+# define THREAD_CREATE_NEEDS_STACK (32*1024)
+# endif
+#endif
+
+#ifdef I_MACH_CTHREADS
+
+/* cthreads interface */
+
+/* #include <mach/cthreads.h> is in perl.h #ifdef I_MACH_CTHREADS */
+
+#define MUTEX_INIT(m) \
+ STMT_START { \
+ *m = mutex_alloc(); \
+ if (*m) { \
+ mutex_init(*m); \
+ } else { \
+ Perl_croak_nocontext("panic: MUTEX_INIT [%s:%d]", \
+ __FILE__, __LINE__); \
+ } \
+ } STMT_END
+
+#define MUTEX_LOCK(m) mutex_lock(*m)
+#define MUTEX_UNLOCK(m) mutex_unlock(*m)
+#define MUTEX_DESTROY(m) \
+ STMT_START { \
+ mutex_free(*m); \
+ *m = 0; \
+ } STMT_END
+
+#define COND_INIT(c) \
+ STMT_START { \
+ *c = condition_alloc(); \
+ if (*c) { \
+ condition_init(*c); \
+ } \
+ else { \
+ Perl_croak_nocontext("panic: COND_INIT [%s:%d]", \
+ __FILE__, __LINE__); \
+ } \
+ } STMT_END
+
+#define COND_SIGNAL(c) condition_signal(*c)
+#define COND_BROADCAST(c) condition_broadcast(*c)
+#define COND_WAIT(c, m) condition_wait(*c, *m)
+#define COND_DESTROY(c) \
+ STMT_START { \
+ condition_free(*c); \
+ *c = 0; \
+ } STMT_END
+
+#define THREAD_CREATE(thr, f) (thr->self = cthread_fork(f, thr), 0)
+#define THREAD_POST_CREATE(thr)
+
+#define THREAD_RET_TYPE any_t
+#define THREAD_RET_CAST(x) ((any_t) x)
+
+#define DETACH(t) cthread_detach(t->self)
+#define JOIN(t, avp) (*(avp) = MUTABLE_AV(cthread_join(t->self)))
+
+#define PERL_SET_CONTEXT(t) cthread_set_data(cthread_self(), t)
+#define PERL_GET_CONTEXT cthread_data(cthread_self())
+
+#define INIT_THREADS cthread_init()
+#define YIELD cthread_yield()
+#define ALLOC_THREAD_KEY NOOP
+#define FREE_THREAD_KEY NOOP
+#define SET_THREAD_SELF(thr) (thr->self = cthread_self())
+
+#endif /* I_MACH_CTHREADS */
+
+#ifndef YIELD
+# ifdef SCHED_YIELD
+# define YIELD SCHED_YIELD
+# else
+# ifdef HAS_SCHED_YIELD
+# define YIELD sched_yield()
+# else
+# ifdef HAS_PTHREAD_YIELD
+ /* pthread_yield(NULL) platforms are expected
+ * to have #defined YIELD for themselves. */
+# define YIELD pthread_yield()
+# endif
+# endif
+# endif
+#endif
+
+#ifdef __hpux
+# define MUTEX_INIT_NEEDS_MUTEX_ZEROED
+#endif
+
+#ifndef MUTEX_INIT
+
+# ifdef MUTEX_INIT_NEEDS_MUTEX_ZEROED
+ /* Temporary workaround, true bug is deeper. --jhi 1999-02-25 */
+# define MUTEX_INIT(m) \
+ STMT_START { \
+ int _eC_; \
+ Zero((m), 1, perl_mutex); \
+ if ((_eC_ = pthread_mutex_init((m), pthread_mutexattr_default))) \
+ Perl_croak_nocontext("panic: MUTEX_INIT (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+# else
+# define MUTEX_INIT(m) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_mutex_init((m), pthread_mutexattr_default))) \
+ Perl_croak_nocontext("panic: MUTEX_INIT (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+# endif
+
+# define MUTEX_LOCK(m) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_mutex_lock((m)))) \
+ Perl_croak_nocontext("panic: MUTEX_LOCK (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+
+# define MUTEX_UNLOCK(m) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_mutex_unlock((m)))) \
+ Perl_croak_nocontext("panic: MUTEX_UNLOCK (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+
+# define MUTEX_DESTROY(m) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_mutex_destroy((m)))) \
+ Perl_croak_nocontext("panic: MUTEX_DESTROY (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+#endif /* MUTEX_INIT */
+
+#ifndef COND_INIT
+# define COND_INIT(c) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_cond_init((c), pthread_condattr_default))) \
+ Perl_croak_nocontext("panic: COND_INIT (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+
+# define COND_SIGNAL(c) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_cond_signal((c)))) \
+ Perl_croak_nocontext("panic: COND_SIGNAL (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+
+# define COND_BROADCAST(c) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_cond_broadcast((c)))) \
+ Perl_croak_nocontext("panic: COND_BROADCAST (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+
+# define COND_WAIT(c, m) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_cond_wait((c), (m)))) \
+ Perl_croak_nocontext("panic: COND_WAIT (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+
+# define COND_DESTROY(c) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_cond_destroy((c)))) \
+ Perl_croak_nocontext("panic: COND_DESTROY (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+#endif /* COND_INIT */
+
+/* DETACH(t) must only be called while holding t->mutex */
+#ifndef DETACH
+# define DETACH(t) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_detach((t)->self))) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ Perl_croak_nocontext("panic: DETACH (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } \
+ } STMT_END
+#endif /* DETACH */
+
+#ifndef JOIN
+# define JOIN(t, avp) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_join((t)->self, (void**)(avp)))) \
+ Perl_croak_nocontext("panic: pthread_join (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+#endif /* JOIN */
+
+/* Use an unchecked fetch of thread-specific data instead of a checked one.
+ * It would fail if the key were bogus, but if the key were bogus then
+ * Really Bad Things would be happening anyway. --dan */
+#if (defined(__ALPHA) && (__VMS_VER >= 70000000)) || \
+ (defined(__alpha) && defined(__osf__) && !defined(__GNUC__)) /* Available only on >= 4.0 */
+# define HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP /* Configure test needed */
+#endif
+
+#ifdef HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP
+# define PTHREAD_GETSPECIFIC(key) pthread_unchecked_getspecific_np(key)
+#else
+# define PTHREAD_GETSPECIFIC(key) pthread_getspecific(key)
+#endif
+
+#ifndef PERL_GET_CONTEXT
+# define PERL_GET_CONTEXT PTHREAD_GETSPECIFIC(PL_thr_key)
+#endif
+
+#ifndef PERL_SET_CONTEXT
+# define PERL_SET_CONTEXT(t) \
+ STMT_START { \
+ int _eC_; \
+ if ((_eC_ = pthread_setspecific(PL_thr_key, (void *)(t)))) \
+ Perl_croak_nocontext("panic: pthread_setspecific (%d) [%s:%d]", \
+ _eC_, __FILE__, __LINE__); \
+ } STMT_END
+#endif /* PERL_SET_CONTEXT */
+
+#ifndef INIT_THREADS
+# ifdef NEED_PTHREAD_INIT
+# define INIT_THREADS pthread_init()
+# endif
+#endif
+
+#ifndef ALLOC_THREAD_KEY
+# define ALLOC_THREAD_KEY \
+ STMT_START { \
+ if (pthread_key_create(&PL_thr_key, 0)) { \
+ write(2, STR_WITH_LEN("panic: pthread_key_create failed\n")); \
+ exit(1); \
+ } \
+ } STMT_END
+#endif
+
+#ifndef FREE_THREAD_KEY
+# define FREE_THREAD_KEY \
+ STMT_START { \
+ pthread_key_delete(PL_thr_key); \
+ } STMT_END
+#endif
+
+#ifndef PTHREAD_ATFORK
+# ifdef HAS_PTHREAD_ATFORK
+# define PTHREAD_ATFORK(prepare,parent,child) \
+ pthread_atfork(prepare,parent,child)
+# else
+# define PTHREAD_ATFORK(prepare,parent,child) \
+ NOOP
+# endif
+#endif
+
+#ifndef THREAD_RET_TYPE
+# define THREAD_RET_TYPE void *
+# define THREAD_RET_CAST(p) ((void *)(p))
+#endif /* THREAD_RET */
+
+# define LOCK_DOLLARZERO_MUTEX MUTEX_LOCK(&PL_dollarzero_mutex)
+# define UNLOCK_DOLLARZERO_MUTEX MUTEX_UNLOCK(&PL_dollarzero_mutex)
+
+#endif /* USE_ITHREADS */
+
+#ifndef MUTEX_LOCK
+# define MUTEX_LOCK(m)
+#endif
+
+#ifndef MUTEX_UNLOCK
+# define MUTEX_UNLOCK(m)
+#endif
+
+#ifndef MUTEX_INIT
+# define MUTEX_INIT(m)
+#endif
+
+#ifndef MUTEX_DESTROY
+# define MUTEX_DESTROY(m)
+#endif
+
+#ifndef COND_INIT
+# define COND_INIT(c)
+#endif
+
+#ifndef COND_SIGNAL
+# define COND_SIGNAL(c)
+#endif
+
+#ifndef COND_BROADCAST
+# define COND_BROADCAST(c)
+#endif
+
+#ifndef COND_WAIT
+# define COND_WAIT(c, m)
+#endif
+
+#ifndef COND_DESTROY
+# define COND_DESTROY(c)
+#endif
+
+#ifndef LOCK_SV_MUTEX
+# define LOCK_SV_MUTEX
+#endif
+
+#ifndef UNLOCK_SV_MUTEX
+# define UNLOCK_SV_MUTEX
+#endif
+
+#ifndef LOCK_STRTAB_MUTEX
+# define LOCK_STRTAB_MUTEX
+#endif
+
+#ifndef UNLOCK_STRTAB_MUTEX
+# define UNLOCK_STRTAB_MUTEX
+#endif
+
+#ifndef LOCK_CRED_MUTEX
+# define LOCK_CRED_MUTEX
+#endif
+
+#ifndef UNLOCK_CRED_MUTEX
+# define UNLOCK_CRED_MUTEX
+#endif
+
+#ifndef LOCK_FDPID_MUTEX
+# define LOCK_FDPID_MUTEX
+#endif
+
+#ifndef UNLOCK_FDPID_MUTEX
+# define UNLOCK_FDPID_MUTEX
+#endif
+
+#ifndef LOCK_SV_LOCK_MUTEX
+# define LOCK_SV_LOCK_MUTEX
+#endif
+
+#ifndef UNLOCK_SV_LOCK_MUTEX
+# define UNLOCK_SV_LOCK_MUTEX
+#endif
+
+#ifndef LOCK_DOLLARZERO_MUTEX
+# define LOCK_DOLLARZERO_MUTEX
+#endif
+
+#ifndef UNLOCK_DOLLARZERO_MUTEX
+# define UNLOCK_DOLLARZERO_MUTEX
+#endif
+
+/* THR, SET_THR, and dTHR are there for compatibility with old versions */
+#ifndef THR
+# define THR PERL_GET_THX
+#endif
+
+#ifndef SET_THR
+# define SET_THR(t) PERL_SET_THX(t)
+#endif
+
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+
+#ifndef INIT_THREADS
+# define INIT_THREADS NOOP
+#endif
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/uconfig.h b/Master/tlpkg/tlperl.straw/lib/CORE/uconfig.h
new file mode 100755
index 00000000000..511a00b8cb1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/uconfig.h
@@ -0,0 +1,4595 @@
+/*
+ * This file was produced by running the config_h.SH script, which
+ * gets its values from uconfig.sh, which is generally produced by
+ * running Configure.
+ *
+ * Feel free to modify any of this as the need arises. Note, however,
+ * that running config_h.SH again will wipe out any changes you've made.
+ * For a more permanent change edit uconfig.sh and rerun config_h.SH.
+ *
+ * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $
+ */
+
+/*
+ * Package name : perl5
+ * Source directory : .
+ * Configuration time: Thu Jan 1 00:00:00 GMT 1970
+ * Configured by : root@localhost
+ * Target system : unknown
+ */
+
+#ifndef _config_h_
+#define _config_h_
+
+/* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "" /**/
+
+/* HAS_ALARM:
+ * This symbol, if defined, indicates that the alarm routine is
+ * available.
+ */
+/*#define HAS_ALARM / **/
+
+/* HAS_BCMP:
+ * This symbol is defined if the bcmp() routine is available to
+ * compare blocks of memory.
+ */
+/*#define HAS_BCMP / **/
+
+/* HAS_BCOPY:
+ * This symbol is defined if the bcopy() routine is available to
+ * copy blocks of memory.
+ */
+/*#define HAS_BCOPY / **/
+
+/* HAS_BZERO:
+ * This symbol is defined if the bzero() routine is available to
+ * set a memory block to 0.
+ */
+/*#define HAS_BZERO / **/
+
+/* HAS_CHOWN:
+ * This symbol, if defined, indicates that the chown routine is
+ * available.
+ */
+/*#define HAS_CHOWN / **/
+
+/* HAS_CHROOT:
+ * This symbol, if defined, indicates that the chroot routine is
+ * available.
+ */
+/*#define HAS_CHROOT / **/
+
+/* HAS_CHSIZE:
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+/*#define HAS_CHSIZE / **/
+
+/* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+/*#define HAS_CRYPT / **/
+
+/* HAS_CTERMID:
+ * This symbol, if defined, indicates that the ctermid routine is
+ * available to generate filename for terminal.
+ */
+/*#define HAS_CTERMID / **/
+
+/* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+/*#define HAS_CUSERID / **/
+
+/* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+/*#define HAS_DBL_DIG / * */
+
+/* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+/*#define HAS_DIFFTIME / **/
+
+/* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+/*#define HAS_DLERROR / **/
+
+/* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
+/*#define DOSUID / **/
+
+/* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+/*#define HAS_DUP2 / **/
+
+/* HAS_FCHMOD:
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+/*#define HAS_FCHMOD / **/
+
+/* HAS_FCHOWN:
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+/*#define HAS_FCHOWN / **/
+
+/* HAS_FCNTL:
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+/*#define HAS_FCNTL / **/
+
+/* HAS_FGETPOS:
+ * This symbol, if defined, indicates that the fgetpos routine is
+ * available to get the file position indicator, similar to ftell().
+ */
+/*#define HAS_FGETPOS / **/
+
+/* HAS_FLOCK:
+ * This symbol, if defined, indicates that the flock routine is
+ * available to do file locking.
+ */
+/*#define HAS_FLOCK / **/
+
+/* HAS_FORK:
+ * This symbol, if defined, indicates that the fork routine is
+ * available.
+ */
+#define HAS_FORK /**/
+
+/* HAS_FSETPOS:
+ * This symbol, if defined, indicates that the fsetpos routine is
+ * available to set the file position indicator, similar to fseek().
+ */
+/*#define HAS_FSETPOS / **/
+
+/* HAS_GETTIMEOFDAY:
+ * This symbol, if defined, indicates that the gettimeofday() system
+ * call is available for a sub-second accuracy clock. Usually, the file
+ * <sys/resource.h> needs to be included (see I_SYS_RESOURCE).
+ * The type "Timeval" should be used to refer to "struct timeval".
+ */
+/*#define HAS_GETTIMEOFDAY / **/
+#ifdef HAS_GETTIMEOFDAY
+#define Timeval struct timeval /* Structure used by gettimeofday() */
+#endif
+
+/* HAS_GETGROUPS:
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+/*#define HAS_GETGROUPS / **/
+
+/* HAS_GETLOGIN:
+ * This symbol, if defined, indicates that the getlogin routine is
+ * available to get the login name.
+ */
+/*#define HAS_GETLOGIN / **/
+
+/* HAS_GETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the getpgid(pid) function is available to get the
+ * process group id.
+ */
+/*#define HAS_GETPGID / **/
+
+/* HAS_GETPGRP2:
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+/*#define HAS_GETPGRP2 / **/
+
+/* HAS_GETPPID:
+ * This symbol, if defined, indicates that the getppid routine is
+ * available to get the parent process ID.
+ */
+/*#define HAS_GETPPID / **/
+
+/* HAS_GETPRIORITY:
+ * This symbol, if defined, indicates that the getpriority routine is
+ * available to get a process's priority.
+ */
+/*#define HAS_GETPRIORITY / **/
+
+/* HAS_INET_ATON:
+ * This symbol, if defined, indicates to the C program that the
+ * inet_aton() function is available to parse IP address "dotted-quad"
+ * strings.
+ */
+/*#define HAS_INET_ATON / **/
+
+/* HAS_KILLPG:
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+/*#define HAS_KILLPG / **/
+
+/* HAS_LINK:
+ * This symbol, if defined, indicates that the link routine is
+ * available to create hard links.
+ */
+/*#define HAS_LINK / **/
+
+/* HAS_LOCALECONV:
+ * This symbol, if defined, indicates that the localeconv routine is
+ * available for numeric and monetary formatting conventions.
+ */
+/*#define HAS_LOCALECONV / **/
+
+/* HAS_LOCKF:
+ * This symbol, if defined, indicates that the lockf routine is
+ * available to do file locking.
+ */
+/*#define HAS_LOCKF / **/
+
+/* HAS_LSTAT:
+ * This symbol, if defined, indicates that the lstat routine is
+ * available to do file stats on symbolic links.
+ */
+/*#define HAS_LSTAT / **/
+
+/* HAS_MBLEN:
+ * This symbol, if defined, indicates that the mblen routine is available
+ * to find the number of bytes in a multibye character.
+ */
+/*#define HAS_MBLEN / **/
+
+/* HAS_MBSTOWCS:
+ * This symbol, if defined, indicates that the mbstowcs routine is
+ * available to covert a multibyte string into a wide character string.
+ */
+/*#define HAS_MBSTOWCS / **/
+
+/* HAS_MBTOWC:
+ * This symbol, if defined, indicates that the mbtowc routine is available
+ * to covert a multibyte to a wide character.
+ */
+/*#define HAS_MBTOWC / **/
+
+/* HAS_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory.
+ */
+#define HAS_MEMCMP /**/
+
+/* HAS_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory.
+ */
+#define HAS_MEMCPY /**/
+
+/* HAS_MEMMOVE:
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to copy potentially overlapping blocks of memory. This should be used
+ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your
+ * own version.
+ */
+/*#define HAS_MEMMOVE / **/
+
+/* HAS_MEMSET:
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set blocks of memory.
+ */
+/*#define HAS_MEMSET / **/
+
+/* HAS_MKDIR:
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+/*#define HAS_MKDIR / **/
+
+/* HAS_MKFIFO:
+ * This symbol, if defined, indicates that the mkfifo routine is
+ * available to create FIFOs. Otherwise, mknod should be able to
+ * do it for you. However, if mkfifo is there, mknod might require
+ * super-user privileges which mkfifo will not.
+ */
+/*#define HAS_MKFIFO / **/
+
+/* HAS_MKTIME:
+ * This symbol, if defined, indicates that the mktime routine is
+ * available.
+ */
+/*#define HAS_MKTIME / **/
+
+/* HAS_MSYNC:
+ * This symbol, if defined, indicates that the msync system call is
+ * available to synchronize a mapped file.
+ */
+/*#define HAS_MSYNC / **/
+
+/* HAS_MUNMAP:
+ * This symbol, if defined, indicates that the munmap system call is
+ * available to unmap a region, usually mapped by mmap().
+ */
+/*#define HAS_MUNMAP / **/
+
+/* HAS_NICE:
+ * This symbol, if defined, indicates that the nice routine is
+ * available.
+ */
+/*#define HAS_NICE / **/
+
+/* HAS_PATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given filename.
+ */
+/* HAS_FPATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given open file descriptor.
+ */
+/*#define HAS_PATHCONF / **/
+/*#define HAS_FPATHCONF / **/
+
+/* HAS_PAUSE:
+ * This symbol, if defined, indicates that the pause routine is
+ * available to suspend a process until a signal is received.
+ */
+/*#define HAS_PAUSE / **/
+
+/* HAS_PIPE:
+ * This symbol, if defined, indicates that the pipe routine is
+ * available to create an inter-process channel.
+ */
+/*#define HAS_PIPE / **/
+
+/* HAS_POLL:
+ * This symbol, if defined, indicates that the poll routine is
+ * available to poll active file descriptors. Please check I_POLL and
+ * I_SYS_POLL to know which header should be included as well.
+ */
+/*#define HAS_POLL / **/
+
+/* HAS_READDIR:
+ * This symbol, if defined, indicates that the readdir routine is
+ * available to read directory entries. You may have to include
+ * <dirent.h>. See I_DIRENT.
+ */
+#define HAS_READDIR /**/
+
+/* HAS_SEEKDIR:
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+/*#define HAS_SEEKDIR / **/
+
+/* HAS_TELLDIR:
+ * This symbol, if defined, indicates that the telldir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+/*#define HAS_TELLDIR / **/
+
+/* HAS_REWINDDIR:
+ * This symbol, if defined, indicates that the rewinddir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+/*#define HAS_REWINDDIR / **/
+
+/* HAS_READLINK:
+ * This symbol, if defined, indicates that the readlink routine is
+ * available to read the value of a symbolic link.
+ */
+/*#define HAS_READLINK / **/
+
+/* HAS_RENAME:
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+#define HAS_RENAME /**/
+
+/* HAS_RMDIR:
+ * This symbol, if defined, indicates that the rmdir routine is
+ * available to remove directories. Otherwise you should fork off a
+ * new process to exec /bin/rmdir.
+ */
+/*#define HAS_RMDIR / **/
+
+/* HAS_SELECT:
+ * This symbol, if defined, indicates that the select routine is
+ * available to select active file descriptors. If the timeout field
+ * is used, <sys/time.h> may need to be included.
+ */
+/*#define HAS_SELECT / **/
+
+/* HAS_SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+/*#define HAS_SETEGID / **/
+
+/* HAS_SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+/*#define HAS_SETEUID / **/
+
+/* HAS_SETGROUPS:
+ * This symbol, if defined, indicates that the setgroups() routine is
+ * available to set the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+/*#define HAS_SETGROUPS / **/
+
+/* HAS_SETLINEBUF:
+ * This symbol, if defined, indicates that the setlinebuf routine is
+ * available to change stderr or stdout from block-buffered or unbuffered
+ * to a line-buffered mode.
+ */
+/*#define HAS_SETLINEBUF / **/
+
+/* HAS_SETLOCALE:
+ * This symbol, if defined, indicates that the setlocale routine is
+ * available to handle locale-specific ctype implementations.
+ */
+/*#define HAS_SETLOCALE / **/
+
+/* HAS_SETPGID:
+ * This symbol, if defined, indicates that the setpgid(pid, gpid)
+ * routine is available to set process group ID.
+ */
+/*#define HAS_SETPGID / **/
+
+/* HAS_SETPGRP2:
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+/*#define HAS_SETPGRP2 / **/
+
+/* HAS_SETPRIORITY:
+ * This symbol, if defined, indicates that the setpriority routine is
+ * available to set a process's priority.
+ */
+/*#define HAS_SETPRIORITY / **/
+
+/* HAS_SETREGID:
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current
+ * process.
+ */
+/* HAS_SETRESGID:
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * process.
+ */
+/*#define HAS_SETREGID / **/
+/*#define HAS_SETRESGID / **/
+
+/* HAS_SETREUID:
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current
+ * process.
+ */
+/* HAS_SETRESUID:
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * process.
+ */
+/*#define HAS_SETREUID / **/
+/*#define HAS_SETRESUID / **/
+
+/* HAS_SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+/*#define HAS_SETRGID / **/
+
+/* HAS_SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+/*#define HAS_SETRUID / **/
+
+/* HAS_SETSID:
+ * This symbol, if defined, indicates that the setsid routine is
+ * available to set the process group ID.
+ */
+/*#define HAS_SETSID / **/
+
+/* HAS_STRCHR:
+ * This symbol is defined to indicate that the strchr()/strrchr()
+ * functions are available for string searching. If not, try the
+ * index()/rindex() pair.
+ */
+/* HAS_INDEX:
+ * This symbol is defined to indicate that the index()/rindex()
+ * functions are available for string searching.
+ */
+/*#define HAS_STRCHR / **/
+/*#define HAS_INDEX / **/
+
+/* HAS_STRCOLL:
+ * This symbol, if defined, indicates that the strcoll routine is
+ * available to compare strings using collating information.
+ */
+/*#define HAS_STRCOLL / **/
+
+/* HAS_STRTOD:
+ * This symbol, if defined, indicates that the strtod routine is
+ * available to provide better numeric string conversion than atof().
+ */
+/*#define HAS_STRTOD / **/
+
+/* HAS_STRTOL:
+ * This symbol, if defined, indicates that the strtol routine is available
+ * to provide better numeric string conversion than atoi() and friends.
+ */
+/*#define HAS_STRTOL / **/
+
+/* HAS_STRXFRM:
+ * This symbol, if defined, indicates that the strxfrm() routine is
+ * available to transform strings.
+ */
+/*#define HAS_STRXFRM / **/
+
+/* HAS_SYMLINK:
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+/*#define HAS_SYMLINK / **/
+
+/* HAS_SYSCALL:
+ * This symbol, if defined, indicates that the syscall routine is
+ * available to call arbitrary system calls. If undefined, that's tough.
+ */
+/*#define HAS_SYSCALL / **/
+
+/* HAS_SYSCONF:
+ * This symbol, if defined, indicates that sysconf() is available
+ * to determine system related limits and options.
+ */
+/*#define HAS_SYSCONF / **/
+
+/* HAS_SYSTEM:
+ * This symbol, if defined, indicates that the system routine is
+ * available to issue a shell command.
+ */
+/*#define HAS_SYSTEM / **/
+
+/* HAS_TCGETPGRP:
+ * This symbol, if defined, indicates that the tcgetpgrp routine is
+ * available to get foreground process group ID.
+ */
+/*#define HAS_TCGETPGRP / **/
+
+/* HAS_TCSETPGRP:
+ * This symbol, if defined, indicates that the tcsetpgrp routine is
+ * available to set foreground process group ID.
+ */
+/*#define HAS_TCSETPGRP / **/
+
+/* HAS_TRUNCATE:
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+/*#define HAS_TRUNCATE / **/
+
+/* HAS_TZNAME:
+ * This symbol, if defined, indicates that the tzname[] array is
+ * available to access timezone names.
+ */
+/*#define HAS_TZNAME / **/
+
+/* HAS_UMASK:
+ * This symbol, if defined, indicates that the umask routine is
+ * available to set and get the value of the file creation mask.
+ */
+/*#define HAS_UMASK / **/
+
+/* HAS_USLEEP:
+ * This symbol, if defined, indicates that the usleep routine is
+ * available to let the process sleep on a sub-second accuracy.
+ */
+/*#define HAS_USLEEP / **/
+
+/* HAS_WAIT4:
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+/*#define HAS_WAIT4 / **/
+
+/* HAS_WAITPID:
+ * This symbol, if defined, indicates that the waitpid routine is
+ * available to wait for child process.
+ */
+/*#define HAS_WAITPID / **/
+
+/* HAS_WCSTOMBS:
+ * This symbol, if defined, indicates that the wcstombs routine is
+ * available to convert wide character strings to multibyte strings.
+ */
+/*#define HAS_WCSTOMBS / **/
+
+/* HAS_WCTOMB:
+ * This symbol, if defined, indicates that the wctomb routine is available
+ * to covert a wide character to a multibyte.
+ */
+/*#define HAS_WCTOMB / **/
+
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * getgroups() and setgroups(). Usually, this is the same as
+ * gidtype (gid_t) , but sometimes it isn't.
+ * It can be int, ushort, gid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
+ * typedef'ed information. This is only required if you have
+ * getgroups() or setgroups()..
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t int /* Type for 2nd arg to [sg]etgroups() */
+#endif
+
+/* I_ARPA_INET:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <arpa/inet.h> to get inet_addr and friends declarations.
+ */
+/*#define I_ARPA_INET / **/
+
+/* I_DBM:
+ * This symbol, if defined, indicates that <dbm.h> exists and should
+ * be included.
+ */
+/* I_RPCSVC_DBM:
+ * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
+ * should be included.
+ */
+/*#define I_DBM / **/
+/*#define I_RPCSVC_DBM / **/
+
+/* I_DLFCN:
+ * This symbol, if defined, indicates that <dlfcn.h> exists and should
+ * be included.
+ */
+/*#define I_DLFCN / **/
+
+/* I_FCNTL:
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+/*#define I_FCNTL / **/
+
+/* I_FLOAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <float.h> to get definition of symbols like DBL_MAX or
+ * DBL_MIN, i.e. machine dependent floating point values.
+ */
+/*#define I_FLOAT / **/
+
+/* I_GDBM:
+ * This symbol, if defined, indicates that <gdbm.h> exists and should
+ * be included.
+ */
+/*#define I_GDBM / **/
+
+/* I_LIMITS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <limits.h> to get definition of symbols like WORD_BIT or
+ * LONG_MAX, i.e. machine dependant limitations.
+ */
+/*#define I_LIMITS / **/
+
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+/*#define I_LOCALE / **/
+
+/* I_MATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <math.h>.
+ */
+#define I_MATH /**/
+
+/* I_MEMORY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <memory.h>.
+ */
+/*#define I_MEMORY / **/
+
+/* I_NETINET_IN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/in.h>. Otherwise, you may try <sys/in.h>.
+ */
+/*#define I_NETINET_IN / **/
+
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+/*#define I_SFIO / **/
+
+/* I_STDDEF:
+ * This symbol, if defined, indicates that <stddef.h> exists and should
+ * be included.
+ */
+/*#define I_STDDEF / **/
+
+/* I_STDLIB:
+ * This symbol, if defined, indicates that <stdlib.h> exists and should
+ * be included.
+ */
+#define I_STDLIB /**/
+
+/* I_STRING:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <string.h> (USG systems) instead of <strings.h> (BSD systems).
+ */
+#define I_STRING /**/
+
+/* I_SYS_DIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/dir.h>.
+ */
+/*#define I_SYS_DIR / **/
+
+/* I_SYS_FILE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/file.h> to get definition of R_OK and friends.
+ */
+/*#define I_SYS_FILE / **/
+
+/* I_SYS_IOCTL:
+ * This symbol, if defined, indicates that <sys/ioctl.h> exists and should
+ * be included. Otherwise, include <sgtty.h> or <termio.h>.
+ */
+/* I_SYS_SOCKIO:
+ * This symbol, if defined, indicates the <sys/sockio.h> should be included
+ * to get socket ioctl options, like SIOCATMARK.
+ */
+/*#define I_SYS_IOCTL / **/
+/*#define I_SYS_SOCKIO / **/
+
+/* I_SYS_NDIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/ndir.h>.
+ */
+/*#define I_SYS_NDIR / **/
+
+/* I_SYS_PARAM:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/param.h>.
+ */
+/*#define I_SYS_PARAM / **/
+
+/* I_SYS_POLL:
+ * This symbol, if defined, indicates that the program may include
+ * <sys/poll.h>. When I_POLL is also defined, it's probably safest
+ * to only include <poll.h>.
+ */
+/*#define I_SYS_POLL / **/
+
+/* I_SYS_RESOURCE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/resource.h>.
+ */
+/*#define I_SYS_RESOURCE / **/
+
+/* I_SYS_SELECT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/select.h> in order to get definition of struct timeval.
+ */
+/*#define I_SYS_SELECT / **/
+
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+/* I_SYS_TIMES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/times.h>.
+ */
+/*#define I_SYS_TIMES / **/
+
+/* I_SYS_TYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/types.h>.
+ */
+/*#define I_SYS_TYPES / **/
+
+/* I_SYS_UN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/un.h> to get UNIX domain socket definitions.
+ */
+/*#define I_SYS_UN / **/
+
+/* I_SYS_WAIT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/wait.h>.
+ */
+/*#define I_SYS_WAIT / **/
+
+/* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+/* I_TERMIOS:
+ * This symbol, if defined, indicates that the program should include
+ * the POSIX termios.h rather than sgtty.h or termio.h.
+ * There are also differences in the ioctl() calls that depend on the
+ * value of this symbol.
+ */
+/* I_SGTTY:
+ * This symbol, if defined, indicates that the program should include
+ * <sgtty.h> rather than <termio.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+/*#define I_TERMIO / **/
+/*#define I_TERMIOS / **/
+/*#define I_SGTTY / **/
+
+/* I_UNISTD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <unistd.h>.
+ */
+/*#define I_UNISTD / **/
+
+/* I_UTIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <utime.h>.
+ */
+/*#define I_UTIME / **/
+
+/* I_VALUES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <values.h> to get definition of symbols like MINFLOAT or
+ * MAXLONG, i.e. machine dependant limitations. Probably, you
+ * should use <limits.h> instead, if it is available.
+ */
+/*#define I_VALUES / **/
+
+/* I_VFORK:
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+/*#define I_VFORK / **/
+
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+#define LONGSIZE 4 /**/
+#define SHORTSIZE 2 /**/
+
+/* MULTIARCH:
+ * This symbol, if defined, signifies that the build
+ * process will produce some binary files that are going to be
+ * used in a cross-platform environment. This is the case for
+ * example with the NeXT "fat" binaries that contain executables
+ * for several CPUs.
+ */
+/*#define MULTIARCH / **/
+
+/* HAS_QUAD:
+ * This symbol, if defined, tells that there's a 64-bit integer type,
+ * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one
+ * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T.
+ */
+/*#define HAS_QUAD / **/
+#ifdef HAS_QUAD
+# define Quad_t int64_t /**/
+# define Uquad_t uint64_t /**/
+# define QUADKIND 4 /**/
+# define QUAD_IS_INT 1
+# define QUAD_IS_LONG 2
+# define QUAD_IS_LONG_LONG 3
+# define QUAD_IS_INT64_T 4
+#endif
+
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+/* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+#define OSNAME "unknown" /**/
+#define OSVERS "unknown" /**/
+
+/* ARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user wants to put architecture-dependent public
+ * library files for perl5. It is most often a local directory
+ * such as /usr/local/lib. Programs using this variable must be
+ * prepared to deal with filename expansion. If ARCHLIB is the
+ * same as PRIVLIB, it is not defined, since presumably the
+ * program already searches PRIVLIB.
+ */
+/* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/*#define ARCHLIB "/usr/local/lib/perl5/5.11/unknown" / **/
+/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.11/unknown" / **/
+
+/* ARCHNAME:
+ * This symbol holds a string representing the architecture name.
+ * It may be used to construct an architecture-dependant pathname
+ * where library files may be held under a private library, for
+ * instance.
+ */
+#define ARCHNAME "unknown" /**/
+
+/* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+/* BIN_EXP:
+ * This symbol is the filename expanded version of the BIN symbol, for
+ * programs that do not want to deal with that at run-time.
+ */
+/* PERL_RELOCATABLE_INC:
+ * This symbol, if defined, indicates that we'd like to relocate entries
+ * in @INC at run time based on the location of the perl binary.
+ */
+#define BIN "/usr/local/bin" /**/
+#define BIN_EXP "/usr/local/bin" /**/
+#define PERL_RELOCATABLE_INC "undef" /**/
+
+/* CAT2:
+ * This macro concatenates 2 tokens together.
+ */
+/* STRINGIFY:
+ * This macro surrounds its token with double quotes.
+ */
+#if 42 == 1
+#define CAT2(a,b) a/**/b
+#define STRINGIFY(a) "a"
+#endif
+#if 42 == 42
+#define PeRl_CaTiFy(a, b) a ## b
+#define PeRl_StGiFy(a) #a
+#define CAT2(a,b) PeRl_CaTiFy(a,b)
+#define StGiFy(a) PeRl_StGiFy(a)
+#define STRINGIFY(a) PeRl_StGiFy(a)
+#endif
+#if 42 != 1 && 42 != 42
+#include "Bletch: How does this C preprocessor concatenate tokens?"
+#endif
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+/* CPPRUN:
+ * This symbol contains the string which will invoke a C preprocessor on
+ * the standard input and produce to standard output. It needs to end
+ * with CPPLAST, after all other preprocessor flags have been specified.
+ * The main difference with CPPSTDIN is that this program will never be a
+ * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is
+ * available directly to the user. Note that it may well be different from
+ * the preprocessor used to compile the C program.
+ */
+/* CPPLAST:
+ * This symbol is intended to be used along with CPPRUN in the same manner
+ * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
+ */
+#define CPPSTDIN "cc -E"
+#define CPPMINUS "-"
+#define CPPRUN "cc -E"
+#define CPPLAST "-"
+
+/* HAS_ACCESS:
+ * This manifest constant lets the C program know that the access()
+ * system call is available to check for accessibility using real UID/GID.
+ * (always present on UNIX.)
+ */
+/*#define HAS_ACCESS / **/
+
+/* HAS_ACCESSX:
+ * This symbol, if defined, indicates that the accessx routine is
+ * available to do extended access checks.
+ */
+/*#define HAS_ACCESSX / **/
+
+/* HAS_ASCTIME_R:
+ * This symbol, if defined, indicates that the asctime_r routine
+ * is available to asctime re-entrantly.
+ */
+/* ASCTIME_R_PROTO:
+ * This symbol encodes the prototype of asctime_r.
+ * It is zero if d_asctime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r
+ * is defined.
+ */
+/*#define HAS_ASCTIME_R / **/
+#define ASCTIME_R_PROTO 0 /**/
+
+/* HASATTRIBUTE_FORMAT:
+ * Can we handle GCC attribute for checking printf-style formats
+ */
+/* PRINTF_FORMAT_NULL_OK:
+ * Allows __printf__ format to be null when checking printf-style
+ */
+/* HASATTRIBUTE_MALLOC:
+ * Can we handle GCC attribute for malloc-style functions.
+ */
+/* HASATTRIBUTE_NONNULL:
+ * Can we handle GCC attribute for nonnull function parms.
+ */
+/* HASATTRIBUTE_NORETURN:
+ * Can we handle GCC attribute for functions that do not return
+ */
+/* HASATTRIBUTE_PURE:
+ * Can we handle GCC attribute for pure functions
+ */
+/* HASATTRIBUTE_UNUSED:
+ * Can we handle GCC attribute for unused variables and arguments
+ */
+/* HASATTRIBUTE_DEPRECATED:
+ * Can we handle GCC attribute for marking deprecated APIs
+ */
+/* HASATTRIBUTE_WARN_UNUSED_RESULT:
+ * Can we handle GCC attribute for warning on unused results
+ */
+/*#define HASATTRIBUTE_DEPRECATED / **/
+/*#define HASATTRIBUTE_FORMAT / **/
+/*#define PRINTF_FORMAT_NULL_OK / **/
+/*#define HASATTRIBUTE_NORETURN / **/
+/*#define HASATTRIBUTE_MALLOC / **/
+/*#define HASATTRIBUTE_NONNULL / **/
+/*#define HASATTRIBUTE_PURE / **/
+/*#define HASATTRIBUTE_UNUSED / **/
+/*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/
+
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+/*#define HASCONST / **/
+#ifndef HASCONST
+#define const
+#endif
+
+/* HAS_CRYPT_R:
+ * This symbol, if defined, indicates that the crypt_r routine
+ * is available to crypt re-entrantly.
+ */
+/* CRYPT_R_PROTO:
+ * This symbol encodes the prototype of crypt_r.
+ * It is zero if d_crypt_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r
+ * is defined.
+ */
+/*#define HAS_CRYPT_R / **/
+#define CRYPT_R_PROTO 0 /**/
+
+/* HAS_CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ */
+/* CSH:
+ * This symbol, if defined, contains the full pathname of csh.
+ */
+/*#define HAS_CSH / **/
+#ifdef HAS_CSH
+#define CSH "" /**/
+#endif
+
+/* HAS_CTERMID_R:
+ * This symbol, if defined, indicates that the ctermid_r routine
+ * is available to ctermid re-entrantly.
+ */
+/* CTERMID_R_PROTO:
+ * This symbol encodes the prototype of ctermid_r.
+ * It is zero if d_ctermid_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r
+ * is defined.
+ */
+/*#define HAS_CTERMID_R / **/
+#define CTERMID_R_PROTO 0 /**/
+
+/* HAS_CTIME_R:
+ * This symbol, if defined, indicates that the ctime_r routine
+ * is available to ctime re-entrantly.
+ */
+/* CTIME_R_PROTO:
+ * This symbol encodes the prototype of ctime_r.
+ * It is zero if d_ctime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r
+ * is defined.
+ */
+/*#define HAS_CTIME_R / **/
+#define CTIME_R_PROTO 0 /**/
+
+/* HAS_DRAND48_R:
+ * This symbol, if defined, indicates that the drand48_r routine
+ * is available to drand48 re-entrantly.
+ */
+/* DRAND48_R_PROTO:
+ * This symbol encodes the prototype of drand48_r.
+ * It is zero if d_drand48_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r
+ * is defined.
+ */
+/*#define HAS_DRAND48_R / **/
+#define DRAND48_R_PROTO 0 /**/
+
+/* HAS_DRAND48_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the drand48() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern double drand48(void);
+ */
+/*#define HAS_DRAND48_PROTO / **/
+
+/* HAS_EACCESS:
+ * This symbol, if defined, indicates that the eaccess routine is
+ * available to do extended access checks.
+ */
+/*#define HAS_EACCESS / **/
+
+/* HAS_ENDGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the group database.
+ */
+/*#define HAS_ENDGRENT / **/
+
+/* HAS_ENDGRENT_R:
+ * This symbol, if defined, indicates that the endgrent_r routine
+ * is available to endgrent re-entrantly.
+ */
+/* ENDGRENT_R_PROTO:
+ * This symbol encodes the prototype of endgrent_r.
+ * It is zero if d_endgrent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r
+ * is defined.
+ */
+/*#define HAS_ENDGRENT_R / **/
+#define ENDGRENT_R_PROTO 0 /**/
+
+/* HAS_ENDHOSTENT:
+ * This symbol, if defined, indicates that the endhostent() routine is
+ * available to close whatever was being used for host queries.
+ */
+/*#define HAS_ENDHOSTENT / **/
+
+/* HAS_ENDHOSTENT_R:
+ * This symbol, if defined, indicates that the endhostent_r routine
+ * is available to endhostent re-entrantly.
+ */
+/* ENDHOSTENT_R_PROTO:
+ * This symbol encodes the prototype of endhostent_r.
+ * It is zero if d_endhostent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r
+ * is defined.
+ */
+/*#define HAS_ENDHOSTENT_R / **/
+#define ENDHOSTENT_R_PROTO 0 /**/
+
+/* HAS_ENDNETENT:
+ * This symbol, if defined, indicates that the endnetent() routine is
+ * available to close whatever was being used for network queries.
+ */
+/*#define HAS_ENDNETENT / **/
+
+/* HAS_ENDNETENT_R:
+ * This symbol, if defined, indicates that the endnetent_r routine
+ * is available to endnetent re-entrantly.
+ */
+/* ENDNETENT_R_PROTO:
+ * This symbol encodes the prototype of endnetent_r.
+ * It is zero if d_endnetent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r
+ * is defined.
+ */
+/*#define HAS_ENDNETENT_R / **/
+#define ENDNETENT_R_PROTO 0 /**/
+
+/* HAS_ENDPROTOENT:
+ * This symbol, if defined, indicates that the endprotoent() routine is
+ * available to close whatever was being used for protocol queries.
+ */
+/*#define HAS_ENDPROTOENT / **/
+
+/* HAS_ENDPROTOENT_R:
+ * This symbol, if defined, indicates that the endprotoent_r routine
+ * is available to endprotoent re-entrantly.
+ */
+/* ENDPROTOENT_R_PROTO:
+ * This symbol encodes the prototype of endprotoent_r.
+ * It is zero if d_endprotoent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r
+ * is defined.
+ */
+/*#define HAS_ENDPROTOENT_R / **/
+#define ENDPROTOENT_R_PROTO 0 /**/
+
+/* HAS_ENDPWENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the passwd database.
+ */
+/*#define HAS_ENDPWENT / **/
+
+/* HAS_ENDPWENT_R:
+ * This symbol, if defined, indicates that the endpwent_r routine
+ * is available to endpwent re-entrantly.
+ */
+/* ENDPWENT_R_PROTO:
+ * This symbol encodes the prototype of endpwent_r.
+ * It is zero if d_endpwent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r
+ * is defined.
+ */
+/*#define HAS_ENDPWENT_R / **/
+#define ENDPWENT_R_PROTO 0 /**/
+
+/* HAS_ENDSERVENT:
+ * This symbol, if defined, indicates that the endservent() routine is
+ * available to close whatever was being used for service queries.
+ */
+/*#define HAS_ENDSERVENT / **/
+
+/* HAS_ENDSERVENT_R:
+ * This symbol, if defined, indicates that the endservent_r routine
+ * is available to endservent re-entrantly.
+ */
+/* ENDSERVENT_R_PROTO:
+ * This symbol encodes the prototype of endservent_r.
+ * It is zero if d_endservent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r
+ * is defined.
+ */
+/*#define HAS_ENDSERVENT_R / **/
+#define ENDSERVENT_R_PROTO 0 /**/
+
+/* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+/*#define FLEXFILENAMES / **/
+
+/* HAS_GETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for sequential access of the group database.
+ */
+/*#define HAS_GETGRENT / **/
+
+/* HAS_GETGRENT_R:
+ * This symbol, if defined, indicates that the getgrent_r routine
+ * is available to getgrent re-entrantly.
+ */
+/* GETGRENT_R_PROTO:
+ * This symbol encodes the prototype of getgrent_r.
+ * It is zero if d_getgrent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r
+ * is defined.
+ */
+/*#define HAS_GETGRENT_R / **/
+#define GETGRENT_R_PROTO 0 /**/
+
+/* HAS_GETGRGID_R:
+ * This symbol, if defined, indicates that the getgrgid_r routine
+ * is available to getgrgid re-entrantly.
+ */
+/* GETGRGID_R_PROTO:
+ * This symbol encodes the prototype of getgrgid_r.
+ * It is zero if d_getgrgid_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r
+ * is defined.
+ */
+/*#define HAS_GETGRGID_R / **/
+#define GETGRGID_R_PROTO 0 /**/
+
+/* HAS_GETGRNAM_R:
+ * This symbol, if defined, indicates that the getgrnam_r routine
+ * is available to getgrnam re-entrantly.
+ */
+/* GETGRNAM_R_PROTO:
+ * This symbol encodes the prototype of getgrnam_r.
+ * It is zero if d_getgrnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r
+ * is defined.
+ */
+/*#define HAS_GETGRNAM_R / **/
+#define GETGRNAM_R_PROTO 0 /**/
+
+/* HAS_GETHOSTBYADDR:
+ * This symbol, if defined, indicates that the gethostbyaddr() routine is
+ * available to look up hosts by their IP addresses.
+ */
+/*#define HAS_GETHOSTBYADDR / **/
+
+/* HAS_GETHOSTBYNAME:
+ * This symbol, if defined, indicates that the gethostbyname() routine is
+ * available to look up host names in some data base or other.
+ */
+/*#define HAS_GETHOSTBYNAME / **/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to look up host names in some data base or another.
+ */
+/*#define HAS_GETHOSTENT / **/
+
+/* HAS_GETHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * gethostname() routine to derive the host name. See also HAS_UNAME
+ * and PHOSTNAME.
+ */
+/* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+/* PHOSTNAME:
+ * This symbol, if defined, indicates the command to feed to the
+ * popen() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and HAS_UNAME. Note that the command uses a fully qualified path,
+ * so that it is safe even if used by a process with super-user
+ * privileges.
+ */
+/* HAS_PHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * contents of PHOSTNAME as a command to feed to the popen() routine
+ * to derive the host name.
+ */
+/*#define HAS_GETHOSTNAME / **/
+/*#define HAS_UNAME / **/
+/*#define HAS_PHOSTNAME / **/
+#ifdef HAS_PHOSTNAME
+#define PHOSTNAME "/bin/hostname" /* How to get the host name */
+#endif
+
+/* HAS_GETHOSTBYADDR_R:
+ * This symbol, if defined, indicates that the gethostbyaddr_r routine
+ * is available to gethostbyaddr re-entrantly.
+ */
+/* GETHOSTBYADDR_R_PROTO:
+ * This symbol encodes the prototype of gethostbyaddr_r.
+ * It is zero if d_gethostbyaddr_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r
+ * is defined.
+ */
+/*#define HAS_GETHOSTBYADDR_R / **/
+#define GETHOSTBYADDR_R_PROTO 0 /**/
+
+/* HAS_GETHOSTBYNAME_R:
+ * This symbol, if defined, indicates that the gethostbyname_r routine
+ * is available to gethostbyname re-entrantly.
+ */
+/* GETHOSTBYNAME_R_PROTO:
+ * This symbol encodes the prototype of gethostbyname_r.
+ * It is zero if d_gethostbyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r
+ * is defined.
+ */
+/*#define HAS_GETHOSTBYNAME_R / **/
+#define GETHOSTBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETHOSTENT_R:
+ * This symbol, if defined, indicates that the gethostent_r routine
+ * is available to gethostent re-entrantly.
+ */
+/* GETHOSTENT_R_PROTO:
+ * This symbol encodes the prototype of gethostent_r.
+ * It is zero if d_gethostent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r
+ * is defined.
+ */
+/*#define HAS_GETHOSTENT_R / **/
+#define GETHOSTENT_R_PROTO 0 /**/
+
+/* HAS_GETHOST_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for gethostent(), gethostbyname(), and
+ * gethostbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETHOST_PROTOS / **/
+
+/* HAS_GETLOGIN_R:
+ * This symbol, if defined, indicates that the getlogin_r routine
+ * is available to getlogin re-entrantly.
+ */
+/* GETLOGIN_R_PROTO:
+ * This symbol encodes the prototype of getlogin_r.
+ * It is zero if d_getlogin_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r
+ * is defined.
+ */
+/*#define HAS_GETLOGIN_R / **/
+#define GETLOGIN_R_PROTO 0 /**/
+
+/* HAS_GETNETBYADDR:
+ * This symbol, if defined, indicates that the getnetbyaddr() routine is
+ * available to look up networks by their IP addresses.
+ */
+/*#define HAS_GETNETBYADDR / **/
+
+/* HAS_GETNETBYNAME:
+ * This symbol, if defined, indicates that the getnetbyname() routine is
+ * available to look up networks by their names.
+ */
+/*#define HAS_GETNETBYNAME / **/
+
+/* HAS_GETNETENT:
+ * This symbol, if defined, indicates that the getnetent() routine is
+ * available to look up network names in some data base or another.
+ */
+/*#define HAS_GETNETENT / **/
+
+/* HAS_GETNETBYADDR_R:
+ * This symbol, if defined, indicates that the getnetbyaddr_r routine
+ * is available to getnetbyaddr re-entrantly.
+ */
+/* GETNETBYADDR_R_PROTO:
+ * This symbol encodes the prototype of getnetbyaddr_r.
+ * It is zero if d_getnetbyaddr_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r
+ * is defined.
+ */
+/*#define HAS_GETNETBYADDR_R / **/
+#define GETNETBYADDR_R_PROTO 0 /**/
+
+/* HAS_GETNETBYNAME_R:
+ * This symbol, if defined, indicates that the getnetbyname_r routine
+ * is available to getnetbyname re-entrantly.
+ */
+/* GETNETBYNAME_R_PROTO:
+ * This symbol encodes the prototype of getnetbyname_r.
+ * It is zero if d_getnetbyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r
+ * is defined.
+ */
+/*#define HAS_GETNETBYNAME_R / **/
+#define GETNETBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETNETENT_R:
+ * This symbol, if defined, indicates that the getnetent_r routine
+ * is available to getnetent re-entrantly.
+ */
+/* GETNETENT_R_PROTO:
+ * This symbol encodes the prototype of getnetent_r.
+ * It is zero if d_getnetent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r
+ * is defined.
+ */
+/*#define HAS_GETNETENT_R / **/
+#define GETNETENT_R_PROTO 0 /**/
+
+/* HAS_GETNET_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getnetent(), getnetbyname(), and
+ * getnetbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETNET_PROTOS / **/
+
+/* HAS_GETPROTOENT:
+ * This symbol, if defined, indicates that the getprotoent() routine is
+ * available to look up protocols in some data base or another.
+ */
+/*#define HAS_GETPROTOENT / **/
+
+/* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+/*#define HAS_GETPGRP / **/
+/*#define USE_BSD_GETPGRP / **/
+
+/* HAS_GETPROTOBYNAME:
+ * This symbol, if defined, indicates that the getprotobyname()
+ * routine is available to look up protocols by their name.
+ */
+/* HAS_GETPROTOBYNUMBER:
+ * This symbol, if defined, indicates that the getprotobynumber()
+ * routine is available to look up protocols by their number.
+ */
+/*#define HAS_GETPROTOBYNAME / **/
+/*#define HAS_GETPROTOBYNUMBER / **/
+
+/* HAS_GETPROTOBYNAME_R:
+ * This symbol, if defined, indicates that the getprotobyname_r routine
+ * is available to getprotobyname re-entrantly.
+ */
+/* GETPROTOBYNAME_R_PROTO:
+ * This symbol encodes the prototype of getprotobyname_r.
+ * It is zero if d_getprotobyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r
+ * is defined.
+ */
+/*#define HAS_GETPROTOBYNAME_R / **/
+#define GETPROTOBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETPROTOBYNUMBER_R:
+ * This symbol, if defined, indicates that the getprotobynumber_r routine
+ * is available to getprotobynumber re-entrantly.
+ */
+/* GETPROTOBYNUMBER_R_PROTO:
+ * This symbol encodes the prototype of getprotobynumber_r.
+ * It is zero if d_getprotobynumber_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r
+ * is defined.
+ */
+/*#define HAS_GETPROTOBYNUMBER_R / **/
+#define GETPROTOBYNUMBER_R_PROTO 0 /**/
+
+/* HAS_GETPROTOENT_R:
+ * This symbol, if defined, indicates that the getprotoent_r routine
+ * is available to getprotoent re-entrantly.
+ */
+/* GETPROTOENT_R_PROTO:
+ * This symbol encodes the prototype of getprotoent_r.
+ * It is zero if d_getprotoent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r
+ * is defined.
+ */
+/*#define HAS_GETPROTOENT_R / **/
+#define GETPROTOENT_R_PROTO 0 /**/
+
+/* HAS_GETPROTO_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getprotoent(), getprotobyname(), and
+ * getprotobyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETPROTO_PROTOS / **/
+
+/* HAS_GETPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for sequential access of the passwd database.
+ * If this is not available, the older getpw() function may be available.
+ */
+/*#define HAS_GETPWENT / **/
+
+/* HAS_GETPWENT_R:
+ * This symbol, if defined, indicates that the getpwent_r routine
+ * is available to getpwent re-entrantly.
+ */
+/* GETPWENT_R_PROTO:
+ * This symbol encodes the prototype of getpwent_r.
+ * It is zero if d_getpwent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r
+ * is defined.
+ */
+/*#define HAS_GETPWENT_R / **/
+#define GETPWENT_R_PROTO 0 /**/
+
+/* HAS_GETPWNAM_R:
+ * This symbol, if defined, indicates that the getpwnam_r routine
+ * is available to getpwnam re-entrantly.
+ */
+/* GETPWNAM_R_PROTO:
+ * This symbol encodes the prototype of getpwnam_r.
+ * It is zero if d_getpwnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r
+ * is defined.
+ */
+/*#define HAS_GETPWNAM_R / **/
+#define GETPWNAM_R_PROTO 0 /**/
+
+/* HAS_GETPWUID_R:
+ * This symbol, if defined, indicates that the getpwuid_r routine
+ * is available to getpwuid re-entrantly.
+ */
+/* GETPWUID_R_PROTO:
+ * This symbol encodes the prototype of getpwuid_r.
+ * It is zero if d_getpwuid_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r
+ * is defined.
+ */
+/*#define HAS_GETPWUID_R / **/
+#define GETPWUID_R_PROTO 0 /**/
+
+/* HAS_GETSERVENT:
+ * This symbol, if defined, indicates that the getservent() routine is
+ * available to look up network services in some data base or another.
+ */
+/*#define HAS_GETSERVENT / **/
+
+/* HAS_GETSERVBYNAME_R:
+ * This symbol, if defined, indicates that the getservbyname_r routine
+ * is available to getservbyname re-entrantly.
+ */
+/* GETSERVBYNAME_R_PROTO:
+ * This symbol encodes the prototype of getservbyname_r.
+ * It is zero if d_getservbyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r
+ * is defined.
+ */
+/*#define HAS_GETSERVBYNAME_R / **/
+#define GETSERVBYNAME_R_PROTO 0 /**/
+
+/* HAS_GETSERVBYPORT_R:
+ * This symbol, if defined, indicates that the getservbyport_r routine
+ * is available to getservbyport re-entrantly.
+ */
+/* GETSERVBYPORT_R_PROTO:
+ * This symbol encodes the prototype of getservbyport_r.
+ * It is zero if d_getservbyport_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r
+ * is defined.
+ */
+/*#define HAS_GETSERVBYPORT_R / **/
+#define GETSERVBYPORT_R_PROTO 0 /**/
+
+/* HAS_GETSERVENT_R:
+ * This symbol, if defined, indicates that the getservent_r routine
+ * is available to getservent re-entrantly.
+ */
+/* GETSERVENT_R_PROTO:
+ * This symbol encodes the prototype of getservent_r.
+ * It is zero if d_getservent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r
+ * is defined.
+ */
+/*#define HAS_GETSERVENT_R / **/
+#define GETSERVENT_R_PROTO 0 /**/
+
+/* HAS_GETSERV_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getservent(), getservbyname(), and
+ * getservbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETSERV_PROTOS / **/
+
+/* HAS_GETSPNAM_R:
+ * This symbol, if defined, indicates that the getspnam_r routine
+ * is available to getspnam re-entrantly.
+ */
+/* GETSPNAM_R_PROTO:
+ * This symbol encodes the prototype of getspnam_r.
+ * It is zero if d_getspnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r
+ * is defined.
+ */
+/*#define HAS_GETSPNAM_R / **/
+#define GETSPNAM_R_PROTO 0 /**/
+
+/* HAS_GETSERVBYNAME:
+ * This symbol, if defined, indicates that the getservbyname()
+ * routine is available to look up services by their name.
+ */
+/* HAS_GETSERVBYPORT:
+ * This symbol, if defined, indicates that the getservbyport()
+ * routine is available to look up services by their port.
+ */
+/*#define HAS_GETSERVBYNAME / **/
+/*#define HAS_GETSERVBYPORT / **/
+
+/* HAS_GMTIME_R:
+ * This symbol, if defined, indicates that the gmtime_r routine
+ * is available to gmtime re-entrantly.
+ */
+/* GMTIME_R_PROTO:
+ * This symbol encodes the prototype of gmtime_r.
+ * It is zero if d_gmtime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r
+ * is defined.
+ */
+/*#define HAS_GMTIME_R / **/
+#define GMTIME_R_PROTO 0 /**/
+
+/* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+/*#define HAS_HTONL / **/
+/*#define HAS_HTONS / **/
+/*#define HAS_NTOHL / **/
+/*#define HAS_NTOHS / **/
+
+/* HAS_LOCALTIME_R:
+ * This symbol, if defined, indicates that the localtime_r routine
+ * is available to localtime re-entrantly.
+ */
+/* LOCALTIME_R_NEEDS_TZSET:
+ * Many libc's localtime_r implementations do not call tzset,
+ * making them differ from localtime(), and making timezone
+ * changes using $ENV{TZ} without explicitly calling tzset
+ * impossible. This symbol makes us call tzset before localtime_r
+ */
+/*#define LOCALTIME_R_NEEDS_TZSET / **/
+#ifdef LOCALTIME_R_NEEDS_TZSET
+#define L_R_TZSET tzset(),
+#else
+#define L_R_TZSET
+#endif
+
+/* LOCALTIME_R_PROTO:
+ * This symbol encodes the prototype of localtime_r.
+ * It is zero if d_localtime_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r
+ * is defined.
+ */
+/*#define HAS_LOCALTIME_R / **/
+#define LOCALTIME_R_PROTO 0 /**/
+
+/* HAS_LONG_DOUBLE:
+ * This symbol will be defined if the C compiler supports long
+ * doubles.
+ */
+/* LONG_DOUBLESIZE:
+ * This symbol contains the size of a long double, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long doubles.
+ */
+/*#define HAS_LONG_DOUBLE / **/
+#ifdef HAS_LONG_DOUBLE
+#define LONG_DOUBLESIZE 8 /**/
+#endif
+
+/* HAS_LONG_LONG:
+ * This symbol will be defined if the C compiler supports long long.
+ */
+/* LONGLONGSIZE:
+ * This symbol contains the size of a long long, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long long.
+ */
+/*#define HAS_LONG_LONG / **/
+#ifdef HAS_LONG_LONG
+#define LONGLONGSIZE 8 /**/
+#endif
+
+/* HAS_LSEEK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the lseek() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern off_t lseek(int, off_t, int);
+ */
+/*#define HAS_LSEEK_PROTO / **/
+
+/* HAS_MEMCHR:
+ * This symbol, if defined, indicates that the memchr routine is available
+ * to locate characters within a C string.
+ */
+#define HAS_MEMCHR /**/
+
+/* HAS_MKSTEMP:
+ * This symbol, if defined, indicates that the mkstemp routine is
+ * available to exclusively create and open a uniquely named
+ * temporary file.
+ */
+/*#define HAS_MKSTEMP / **/
+
+/* HAS_MMAP:
+ * This symbol, if defined, indicates that the mmap system call is
+ * available to map a file into memory.
+ */
+/* Mmap_t:
+ * This symbol holds the return type of the mmap() system call
+ * (and simultaneously the type of the first argument).
+ * Usually set to 'void *' or 'caddr_t'.
+ */
+/*#define HAS_MMAP / **/
+#define Mmap_t void * /**/
+
+/* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+/*#define HAS_MSG / **/
+
+/* OLD_PTHREAD_CREATE_JOINABLE:
+ * This symbol, if defined, indicates how to create pthread
+ * in joinable (aka undetached) state. NOTE: not defined
+ * if pthread.h already has defined PTHREAD_CREATE_JOINABLE
+ * (the new version of the constant).
+ * If defined, known values are PTHREAD_CREATE_UNDETACHED
+ * and __UNDETACHED.
+ */
+/*#define OLD_PTHREAD_CREATE_JOINABLE / **/
+
+/* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available to setup fork handlers.
+ */
+/*#define HAS_PTHREAD_ATFORK / **/
+
+/* HAS_PTHREAD_YIELD:
+ * This symbol, if defined, indicates that the pthread_yield
+ * routine is available to yield the execution of the current
+ * thread. sched_yield is preferable to pthread_yield.
+ */
+/* SCHED_YIELD:
+ * This symbol defines the way to yield the execution of
+ * the current thread. Known ways are sched_yield,
+ * pthread_yield, and pthread_yield with NULL.
+ */
+/* HAS_SCHED_YIELD:
+ * This symbol, if defined, indicates that the sched_yield
+ * routine is available to yield the execution of the current
+ * thread. sched_yield is preferable to pthread_yield.
+ */
+/*#define HAS_PTHREAD_YIELD / **/
+#define SCHED_YIELD sched_yield() /**/
+/*#define HAS_SCHED_YIELD / **/
+
+/* HAS_RANDOM_R:
+ * This symbol, if defined, indicates that the random_r routine
+ * is available to random re-entrantly.
+ */
+/* RANDOM_R_PROTO:
+ * This symbol encodes the prototype of random_r.
+ * It is zero if d_random_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r
+ * is defined.
+ */
+/*#define HAS_RANDOM_R / **/
+#define RANDOM_R_PROTO 0 /**/
+
+/* HAS_READDIR64_R:
+ * This symbol, if defined, indicates that the readdir64_r routine
+ * is available to readdir64 re-entrantly.
+ */
+/* READDIR64_R_PROTO:
+ * This symbol encodes the prototype of readdir64_r.
+ * It is zero if d_readdir64_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r
+ * is defined.
+ */
+/*#define HAS_READDIR64_R / **/
+#define READDIR64_R_PROTO 0 /**/
+
+/* HAS_READDIR_R:
+ * This symbol, if defined, indicates that the readdir_r routine
+ * is available to readdir re-entrantly.
+ */
+/* READDIR_R_PROTO:
+ * This symbol encodes the prototype of readdir_r.
+ * It is zero if d_readdir_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r
+ * is defined.
+ */
+/*#define HAS_READDIR_R / **/
+#define READDIR_R_PROTO 0 /**/
+
+/* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+/*#define HAS_SEM / **/
+
+/* HAS_SETGRENT:
+ * This symbol, if defined, indicates that the setgrent routine is
+ * available for initializing sequential access of the group database.
+ */
+/*#define HAS_SETGRENT / **/
+
+/* HAS_SETGRENT_R:
+ * This symbol, if defined, indicates that the setgrent_r routine
+ * is available to setgrent re-entrantly.
+ */
+/* SETGRENT_R_PROTO:
+ * This symbol encodes the prototype of setgrent_r.
+ * It is zero if d_setgrent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r
+ * is defined.
+ */
+/*#define HAS_SETGRENT_R / **/
+#define SETGRENT_R_PROTO 0 /**/
+
+/* HAS_SETHOSTENT:
+ * This symbol, if defined, indicates that the sethostent() routine is
+ * available.
+ */
+/*#define HAS_SETHOSTENT / **/
+
+/* HAS_SETHOSTENT_R:
+ * This symbol, if defined, indicates that the sethostent_r routine
+ * is available to sethostent re-entrantly.
+ */
+/* SETHOSTENT_R_PROTO:
+ * This symbol encodes the prototype of sethostent_r.
+ * It is zero if d_sethostent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r
+ * is defined.
+ */
+/*#define HAS_SETHOSTENT_R / **/
+#define SETHOSTENT_R_PROTO 0 /**/
+
+/* HAS_SETLOCALE_R:
+ * This symbol, if defined, indicates that the setlocale_r routine
+ * is available to setlocale re-entrantly.
+ */
+/* SETLOCALE_R_PROTO:
+ * This symbol encodes the prototype of setlocale_r.
+ * It is zero if d_setlocale_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r
+ * is defined.
+ */
+/*#define HAS_SETLOCALE_R / **/
+#define SETLOCALE_R_PROTO 0 /**/
+
+/* HAS_SETNETENT:
+ * This symbol, if defined, indicates that the setnetent() routine is
+ * available.
+ */
+/*#define HAS_SETNETENT / **/
+
+/* HAS_SETNETENT_R:
+ * This symbol, if defined, indicates that the setnetent_r routine
+ * is available to setnetent re-entrantly.
+ */
+/* SETNETENT_R_PROTO:
+ * This symbol encodes the prototype of setnetent_r.
+ * It is zero if d_setnetent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r
+ * is defined.
+ */
+/*#define HAS_SETNETENT_R / **/
+#define SETNETENT_R_PROTO 0 /**/
+
+/* HAS_SETPROTOENT:
+ * This symbol, if defined, indicates that the setprotoent() routine is
+ * available.
+ */
+/*#define HAS_SETPROTOENT / **/
+
+/* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+/*#define HAS_SETPGRP / **/
+/*#define USE_BSD_SETPGRP / **/
+
+/* HAS_SETPROTOENT_R:
+ * This symbol, if defined, indicates that the setprotoent_r routine
+ * is available to setprotoent re-entrantly.
+ */
+/* SETPROTOENT_R_PROTO:
+ * This symbol encodes the prototype of setprotoent_r.
+ * It is zero if d_setprotoent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r
+ * is defined.
+ */
+/*#define HAS_SETPROTOENT_R / **/
+#define SETPROTOENT_R_PROTO 0 /**/
+
+/* HAS_SETPWENT:
+ * This symbol, if defined, indicates that the setpwent routine is
+ * available for initializing sequential access of the passwd database.
+ */
+/*#define HAS_SETPWENT / **/
+
+/* HAS_SETPWENT_R:
+ * This symbol, if defined, indicates that the setpwent_r routine
+ * is available to setpwent re-entrantly.
+ */
+/* SETPWENT_R_PROTO:
+ * This symbol encodes the prototype of setpwent_r.
+ * It is zero if d_setpwent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r
+ * is defined.
+ */
+/*#define HAS_SETPWENT_R / **/
+#define SETPWENT_R_PROTO 0 /**/
+
+/* HAS_SETSERVENT:
+ * This symbol, if defined, indicates that the setservent() routine is
+ * available.
+ */
+/*#define HAS_SETSERVENT / **/
+
+/* HAS_SETSERVENT_R:
+ * This symbol, if defined, indicates that the setservent_r routine
+ * is available to setservent re-entrantly.
+ */
+/* SETSERVENT_R_PROTO:
+ * This symbol encodes the prototype of setservent_r.
+ * It is zero if d_setservent_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r
+ * is defined.
+ */
+/*#define HAS_SETSERVENT_R / **/
+#define SETSERVENT_R_PROTO 0 /**/
+
+/* HAS_SETVBUF:
+ * This symbol, if defined, indicates that the setvbuf routine is
+ * available to change buffering on an open stdio stream.
+ * to a line-buffered mode.
+ */
+/*#define HAS_SETVBUF / **/
+
+/* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+/*#define HAS_SHM / **/
+
+/* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+/* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+#define Shmat_t void * /**/
+/*#define HAS_SHMAT_PROTOTYPE / **/
+
+/* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+/* HAS_MSG_CTRUNC:
+ * This symbol, if defined, indicates that the MSG_CTRUNC is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_DONTROUTE:
+ * This symbol, if defined, indicates that the MSG_DONTROUTE is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_OOB:
+ * This symbol, if defined, indicates that the MSG_OOB is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PEEK:
+ * This symbol, if defined, indicates that the MSG_PEEK is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PROXY:
+ * This symbol, if defined, indicates that the MSG_PROXY is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_SCM_RIGHTS:
+ * This symbol, if defined, indicates that the SCM_RIGHTS is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/*#define HAS_SOCKET / **/
+/*#define HAS_SOCKETPAIR / **/
+/*#define HAS_MSG_CTRUNC / **/
+/*#define HAS_MSG_DONTROUTE / **/
+/*#define HAS_MSG_OOB / **/
+/*#define HAS_MSG_PEEK / **/
+/*#define HAS_MSG_PROXY / **/
+/*#define HAS_SCM_RIGHTS / **/
+
+/* HAS_SRAND48_R:
+ * This symbol, if defined, indicates that the srand48_r routine
+ * is available to srand48 re-entrantly.
+ */
+/* SRAND48_R_PROTO:
+ * This symbol encodes the prototype of srand48_r.
+ * It is zero if d_srand48_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r
+ * is defined.
+ */
+/*#define HAS_SRAND48_R / **/
+#define SRAND48_R_PROTO 0 /**/
+
+/* HAS_SRANDOM_R:
+ * This symbol, if defined, indicates that the srandom_r routine
+ * is available to srandom re-entrantly.
+ */
+/* SRANDOM_R_PROTO:
+ * This symbol encodes the prototype of srandom_r.
+ * It is zero if d_srandom_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r
+ * is defined.
+ */
+/*#define HAS_SRANDOM_R / **/
+#define SRANDOM_R_PROTO 0 /**/
+
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#ifndef USE_STAT_BLOCKS
+/*#define USE_STAT_BLOCKS / **/
+#endif
+
+/* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+/*#define USE_STRUCT_COPY / **/
+
+/* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+/* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+/* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+/*#define HAS_STRERROR / **/
+/*#define HAS_SYS_ERRLIST / **/
+#define Strerror(e) strerror(e)
+
+/* HAS_STRERROR_R:
+ * This symbol, if defined, indicates that the strerror_r routine
+ * is available to strerror re-entrantly.
+ */
+/* STRERROR_R_PROTO:
+ * This symbol encodes the prototype of strerror_r.
+ * It is zero if d_strerror_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r
+ * is defined.
+ */
+/*#define HAS_STRERROR_R / **/
+#define STRERROR_R_PROTO 0 /**/
+
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+#define HAS_STRTOUL /**/
+
+/* HAS_TIME:
+ * This symbol, if defined, indicates that the time() routine exists.
+ */
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define HAS_TIME /**/
+#define Time_t time_t /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+/*#define HAS_TIMES / **/
+
+/* HAS_TMPNAM_R:
+ * This symbol, if defined, indicates that the tmpnam_r routine
+ * is available to tmpnam re-entrantly.
+ */
+/* TMPNAM_R_PROTO:
+ * This symbol encodes the prototype of tmpnam_r.
+ * It is zero if d_tmpnam_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r
+ * is defined.
+ */
+/*#define HAS_TMPNAM_R / **/
+#define TMPNAM_R_PROTO 0 /**/
+
+/* HAS_TTYNAME_R:
+ * This symbol, if defined, indicates that the ttyname_r routine
+ * is available to ttyname re-entrantly.
+ */
+/* TTYNAME_R_PROTO:
+ * This symbol encodes the prototype of ttyname_r.
+ * It is zero if d_ttyname_r is undef, and one of the
+ * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r
+ * is defined.
+ */
+/*#define HAS_TTYNAME_R / **/
+#define TTYNAME_R_PROTO 0 /**/
+
+/* HAS_UNION_SEMUN:
+ * This symbol, if defined, indicates that the union semun is
+ * defined by including <sys/sem.h>. If not, the user code
+ * probably needs to define it as:
+ * union semun {
+ * int val;
+ * struct semid_ds *buf;
+ * unsigned short *array;
+ * }
+ */
+/* USE_SEMCTL_SEMUN:
+ * This symbol, if defined, indicates that union semun is
+ * used for semctl IPC_STAT.
+ */
+/* USE_SEMCTL_SEMID_DS:
+ * This symbol, if defined, indicates that struct semid_ds * is
+ * used for semctl IPC_STAT.
+ */
+/*#define HAS_UNION_SEMUN / **/
+/*#define USE_SEMCTL_SEMUN / **/
+/*#define USE_SEMCTL_SEMID_DS / **/
+
+/* HAS_VFORK:
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+/*#define HAS_VFORK / **/
+
+/* HAS_PSEUDOFORK:
+ * This symbol, if defined, indicates that an emulation of the
+ * fork routine is available.
+ */
+/*#define HAS_PSEUDOFORK / **/
+
+/* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+#define Signal_t int /* Signal handler's return type */
+
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+/*#define HASVOLATILE / **/
+#ifndef HASVOLATILE
+#define volatile
+#endif
+
+/* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Fpos_t int /* File position type */
+
+/* Gid_t_f:
+ * This symbol defines the format string used for printing a Gid_t.
+ */
+#define Gid_t_f "lu" /**/
+
+/* Gid_t_sign:
+ * This symbol holds the signedess of a Gid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Gid_t_sign 1 /* GID sign */
+
+/* Gid_t_size:
+ * This symbol holds the size of a Gid_t in bytes.
+ */
+#define Gid_t_size 4 /* GID size */
+
+/* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * gid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+#define Gid_t int /* Type for getgid(), etc... */
+
+/* I_DIRENT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <dirent.h>. Using this symbol also triggers the definition
+ * of the Direntry_t define which ends up being 'struct dirent' or
+ * 'struct direct' depending on the availability of <dirent.h>.
+ */
+/* DIRNAMLEN:
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+/* Direntry_t:
+ * This symbol is set to 'struct direct' or 'struct dirent' depending on
+ * whether dirent is available or not. You should use this pseudo type to
+ * portably declare your directory entries.
+ */
+#define I_DIRENT /**/
+/*#define DIRNAMLEN / **/
+#define Direntry_t struct dirent
+
+/* I_GRP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <grp.h>.
+ */
+/* GRPASSWD:
+ * This symbol, if defined, indicates to the C program that struct group
+ * in <grp.h> contains gr_passwd.
+ */
+/*#define I_GRP / **/
+/*#define GRPASSWD / **/
+
+/* I_MACH_CTHREADS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <mach/cthreads.h>.
+ */
+/*#define I_MACH_CTHREADS / **/
+
+/* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+/* I_GDBMNDBM:
+ * This symbol, if defined, indicates that <gdbm/ndbm.h> exists and should
+ * be included. This was the location of the ndbm.h compatibility file
+ * in RedHat 7.1.
+ */
+/* I_GDBM_NDBM:
+ * This symbol, if defined, indicates that <gdbm-ndbm.h> exists and should
+ * be included. This is the location of the ndbm.h compatibility file
+ * in Debian 4.0.
+ */
+/* NDBM_H_USES_PROTOTYPES:
+ * This symbol, if defined, indicates that <ndbm.h> uses real ANSI C
+ * prototypes instead of K&R style function declarations without any
+ * parameter information. While ANSI C prototypes are supported in C++,
+ * K&R style function declarations will yield errors.
+ */
+/* GDBMNDBM_H_USES_PROTOTYPES:
+ * This symbol, if defined, indicates that <gdbm/ndbm.h> uses real ANSI C
+ * prototypes instead of K&R style function declarations without any
+ * parameter information. While ANSI C prototypes are supported in C++,
+ * K&R style function declarations will yield errors.
+ */
+/* GDBM_NDBM_H_USES_PROTOTYPES:
+ * This symbol, if defined, indicates that <gdbm-ndbm.h> uses real ANSI C
+ * prototypes instead of K&R style function declarations without any
+ * parameter information. While ANSI C prototypes are supported in C++,
+ * K&R style function declarations will yield errors.
+ */
+/*#define I_NDBM / **/
+/*#define I_GDBMNDBM / **/
+/*#define I_GDBM_NDBM / **/
+/*#define NDBM_H_USES_PROTOTYPES / **/
+/*#define GDBMNDBM_H_USES_PROTOTYPES / **/
+/*#define GDBM_NDBM_H_USES_PROTOTYPES / **/
+
+/* I_NETDB:
+ * This symbol, if defined, indicates that <netdb.h> exists and
+ * should be included.
+ */
+/*#define I_NETDB / **/
+
+/* I_NET_ERRNO:
+ * This symbol, if defined, indicates that <net/errno.h> exists and
+ * should be included.
+ */
+/*#define I_NET_ERRNO / **/
+
+/* I_PTHREAD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pthread.h>.
+ */
+/*#define I_PTHREAD / **/
+
+/* I_PWD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pwd.h>.
+ */
+/* PWQUOTA:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+/* PWAGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+/* PWCHANGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+/* PWCLASS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+/* PWEXPIRE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+/* PWCOMMENT:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+/* PWGECOS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_gecos.
+ */
+/* PWPASSWD:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_passwd.
+ */
+/*#define I_PWD / **/
+/*#define PWQUOTA / **/
+/*#define PWAGE / **/
+/*#define PWCHANGE / **/
+/*#define PWCLASS / **/
+/*#define PWEXPIRE / **/
+/*#define PWCOMMENT / **/
+/*#define PWGECOS / **/
+/*#define PWPASSWD / **/
+
+/* I_SYS_ACCESS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/access.h>.
+ */
+/*#define I_SYS_ACCESS / **/
+
+/* I_SYS_SECURITY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/security.h>.
+ */
+/*#define I_SYS_SECURITY / **/
+
+/* I_SYSUIO:
+ * This symbol, if defined, indicates that <sys/uio.h> exists and
+ * should be included.
+ */
+/*#define I_SYSUIO / **/
+
+/* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+/* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+#define I_STDARG /**/
+/*#define I_VARARGS / **/
+
+/* PERL_INC_VERSION_LIST:
+ * This variable specifies the list of subdirectories in over
+ * which perl.c:incpush() and lib/lib.pm will automatically
+ * search when adding directories to @INC, in a format suitable
+ * for a C initialization string. See the inc_version_list entry
+ * in Porting/Glossary for more details.
+ */
+/*#define PERL_INC_VERSION_LIST NULL / **/
+
+/* INSTALL_USR_BIN_PERL:
+ * This symbol, if defined, indicates that Perl is to be installed
+ * also as /usr/bin/perl.
+ */
+/*#define INSTALL_USR_BIN_PERL / **/
+
+/* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+/* LSEEKSIZE:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+/* Off_t_size:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+#define Off_t int /* <offset> type */
+#define LSEEKSIZE 4 /* <offset> size */
+#define Off_t_size 4 /* <offset> size */
+
+/* Free_t:
+ * This variable contains the return type of free(). It is usually
+ * void, but occasionally int.
+ */
+/* Malloc_t:
+ * This symbol is the type of pointer returned by malloc and realloc.
+ */
+#define Malloc_t void * /**/
+#define Free_t void /**/
+
+/* PERL_MALLOC_WRAP:
+ * This symbol, if defined, indicates that we'd like malloc wrap checks.
+ */
+/*#define PERL_MALLOC_WRAP / **/
+
+/* MYMALLOC:
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+/*#define MYMALLOC / **/
+
+/* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+#define Mode_t int /* file mode parameter for system calls */
+
+/* Netdb_host_t:
+ * This symbol holds the type used for the 1st argument
+ * to gethostbyaddr().
+ */
+/* Netdb_hlen_t:
+ * This symbol holds the type used for the 2nd argument
+ * to gethostbyaddr().
+ */
+/* Netdb_name_t:
+ * This symbol holds the type used for the argument to
+ * gethostbyname().
+ */
+/* Netdb_net_t:
+ * This symbol holds the type used for the 1st argument to
+ * getnetbyaddr().
+ */
+#define Netdb_host_t const char * /**/
+#define Netdb_hlen_t int /**/
+#define Netdb_name_t const char * /**/
+#define Netdb_net_t unsigned long /**/
+
+/* PERL_OTHERLIBDIRS:
+ * 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 @INC.
+ * Perl will automatically search below each path for version-
+ * and architecture-specific directories. See PERL_INC_VERSION_LIST
+ * for more details.
+ */
+/*#define PERL_OTHERLIBDIRS " " / **/
+
+/* Pid_t:
+ * This symbol holds the type used to declare process ids in the kernel.
+ * It can be int, uint, pid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Pid_t int /* PID type */
+
+/* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+/* PRIVLIB_EXP:
+ * This symbol contains the ~name expanded version of PRIVLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define PRIVLIB "/usr/local/lib/perl5/5.11" /**/
+#define PRIVLIB_EXP "/usr/local/lib/perl5/5.11" /**/
+
+/* CAN_PROTOTYPE:
+ * If defined, this macro indicates that the C compiler can handle
+ * function prototypes.
+ */
+/* _:
+ * This macro is used to declare function parameters for folks who want
+ * to make declarations with prototypes using a different style than
+ * the above macros. Use double parentheses. For example:
+ *
+ * int main _((int argc, char *argv[]));
+ */
+/*#define CAN_PROTOTYPE / **/
+#ifdef CAN_PROTOTYPE
+#define _(args) args
+#else
+#define _(args) ()
+#endif
+
+/* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+#define Select_fd_set_t int /**/
+
+/* SH_PATH:
+ * This symbol contains the full pathname to the shell used on this
+ * on this system to execute Bourne shell scripts. Usually, this will be
+ * /bin/sh, though it's possible that some systems will have /bin/ksh,
+ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ * D:/bin/sh.exe.
+ */
+#define SH_PATH "/bin/sh" /**/
+
+/* SIG_NAME:
+ * This symbol contains a list of signal names in order of
+ * signal number. This is intended
+ * to be used as a static array initialization, like this:
+ * char *sig_name[] = { SIG_NAME };
+ * The signals in the list are separated with commas, and each signal
+ * is surrounded by double quotes. There is no leading SIG in the signal
+ * name, i.e. SIGQUIT is known as "QUIT".
+ * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn,
+ * etc., where nn is the actual signal number (e.g. NUM37).
+ * The signal number for sig_name[i] is stored in sig_num[i].
+ * The last element is 0 to terminate the list with a NULL. This
+ * corresponds to the 0 at the end of the sig_name_init list.
+ * Note that this variable is initialized from the sig_name_init,
+ * not from sig_name (which is unused).
+ */
+/* SIG_NUM:
+ * This symbol contains a list of signal numbers, in the same order as the
+ * SIG_NAME list. It is suitable for static array initialization, as in:
+ * int sig_num[] = { SIG_NUM };
+ * The signals in the list are separated with commas, and the indices
+ * within that list and the SIG_NAME list match, so it's easy to compute
+ * the signal name from a number or vice versa at the price of a small
+ * dynamic linear lookup.
+ * Duplicates are allowed, but are moved to the end of the list.
+ * The signal number corresponding to sig_name[i] is sig_number[i].
+ * if (i < NSIG) then sig_number[i] == i.
+ * The last element is 0, corresponding to the 0 at the end of
+ * the sig_name_init list.
+ * Note that this variable is initialized from the sig_num_init,
+ * not from sig_num (which is unused).
+ */
+/* SIG_SIZE:
+ * This variable contains the number of elements of the SIG_NAME
+ * and SIG_NUM arrays, excluding the final NULL entry.
+ */
+#define SIG_NAME 0 /**/
+#define SIG_NUM 0 /**/
+#define SIG_SIZE 1 /**/
+
+/* SITEARCH:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * 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 Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITEARCH_EXP:
+ * This symbol contains the ~name expanded version of SITEARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/*#define SITEARCH "/usr/local/lib/perl5/5.11/unknown" / **/
+/*#define SITEARCH_EXP "/usr/local/lib/perl5/5.11/unknown" / **/
+
+/* SITELIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * 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 Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* SITELIB_STEM:
+ * This define is SITELIB_EXP with any trailing version-specific component
+ * removed. The elements in inc_version_list (inc_version_list.U) can
+ * be tacked onto this variable to generate a list of directories to search.
+ */
+#define SITELIB "/usr/local/lib/perl5/5.11" /**/
+#define SITELIB_EXP "/usr/local/lib/perl5/5.11" /**/
+#define SITELIB_STEM "/usr/local/lib/perl5" /**/
+
+/* Size_t_size:
+ * This symbol holds the size of a Size_t in bytes.
+ */
+#define Size_t_size 4 /* */
+
+/* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Size_t size_t /* length paramater for string functions */
+
+/* Sock_size_t:
+ * This symbol holds the type used for the size argument of
+ * various socket calls (just the base type, not the pointer-to).
+ */
+#define Sock_size_t int /**/
+
+/* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR char /**/
+
+/* Uid_t_f:
+ * This symbol defines the format string used for printing a Uid_t.
+ */
+#define Uid_t_f "lu" /**/
+
+/* Uid_t_sign:
+ * This symbol holds the signedess of a Uid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Uid_t_sign 1 /* UID sign */
+
+/* Uid_t_size:
+ * This symbol holds the size of a Uid_t in bytes.
+ */
+#define Uid_t_size 4 /* UID size */
+
+/* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Uid_t int /* UID type */
+
+/* USE_ITHREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the interpreter-based threading implementation.
+ */
+/* USE_5005THREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the 5.005-based threading implementation.
+ * Only valid up to 5.8.x.
+ */
+/* OLD_PTHREADS_API:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use the old draft POSIX threads API.
+ */
+/* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
+/*#define USE_5005THREADS / **/
+/*#define USE_ITHREADS / **/
+#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
+#define USE_THREADS /* until src is revised*/
+#endif
+/*#define OLD_PTHREADS_API / **/
+/*#define USE_REENTRANT_API / **/
+
+/* PERL_VENDORARCH:
+ * If defined, this symbol contains the name of a private library.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world.
+ * It may have a ~ 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 Makefile.PL INSTALLDIRS=vendor
+ * or equivalent. See INSTALL for details.
+ */
+/* PERL_VENDORARCH_EXP:
+ * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/*#define PERL_VENDORARCH "" / **/
+/*#define PERL_VENDORARCH_EXP "" / **/
+
+/* PERL_VENDORLIB_EXP:
+ * This symbol contains the ~name expanded version of VENDORLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* PERL_VENDORLIB_STEM:
+ * This define is PERL_VENDORLIB_EXP with any trailing version-specific component
+ * removed. The elements in inc_version_list (inc_version_list.U) can
+ * be tacked onto this variable to generate a list of directories to search.
+ */
+/*#define PERL_VENDORLIB_EXP "" / **/
+/*#define PERL_VENDORLIB_STEM "" / **/
+
+/* VOIDFLAGS:
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ * 8 = suports declaration of generic void pointers
+ *
+ * The package designer should define VOIDUSED to indicate the requirements
+ * of the package. This can be done either by #defining VOIDUSED before
+ * including config.h, or by defining defvoidused in Myinit.U. If the
+ * latter approach is taken, only those flags will be tested. If the
+ * level of void support necessary is not present, defines void to int.
+ */
+#ifndef VOIDUSED
+#define VOIDUSED 1
+#endif
+#define VOIDFLAGS 1
+#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define void int /* is void to be avoided? */
+#define M_VOID /* Xenix strikes again */
+#endif
+
+/* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+/* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+#ifndef USE_CROSS_COMPILE
+/*#define USE_CROSS_COMPILE / **/
+#define PERL_TARGETARCH "" /**/
+#endif
+
+/* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double, or a long double when applicable. Usual values are 2,
+ * 4 and 8. The default is eight, for safety.
+ */
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# define MEM_ALIGNBYTES 8
+#else
+#define MEM_ALIGNBYTES 4
+#endif
+
+/* BYTEORDER:
+ * This symbol holds the hexadecimal constant defined in byteorder,
+ * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc...
+ * If the compiler supports cross-compiling or multiple-architecture
+ * binaries (eg. on NeXT systems), use compiler-defined macros to
+ * determine the byte order.
+ * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
+ * Binaries (MAB) on either big endian or little endian machines.
+ * The endian-ness is available at compile-time. This only matters
+ * for perl, where the config.h can be generated and installed on
+ * one system, and used by a different architecture to build an
+ * extension. Older versions of NeXT that might not have
+ * defined either *_ENDIAN__ were all on Motorola 680x0 series,
+ * so the default case (for NeXT) is big endian to catch them.
+ * This might matter for NeXT 3.0.
+ */
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+# ifdef __LITTLE_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x1234
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x12345678
+# endif
+# endif
+# else
+# ifdef __BIG_ENDIAN__
+# if LONGSIZE == 4
+# define BYTEORDER 0x4321
+# else
+# if LONGSIZE == 8
+# define BYTEORDER 0x87654321
+# endif
+# endif
+# endif
+# endif
+# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
+# define BYTEORDER 0x4321
+# endif
+#else
+#define BYTEORDER 0x1234 /* large digits for MSB */
+#endif /* NeXT */
+
+/* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+/*#define CASTI32 / **/
+
+/* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+/* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+/*#define CASTNEGFLOAT / **/
+#define CASTFLAGS 0 /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+/*#define VOID_CLOSEDIR / **/
+
+/* HAS_FD_SET:
+ * This symbol, when defined, indicates presence of the fd_set typedef
+ * in <sys/types.h>
+ */
+/*#define HAS_FD_SET / **/
+
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * The usual values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
+/* HAS_GETPAGESIZE:
+ * This symbol, if defined, indicates that the getpagesize system call
+ * is available to get system page size, which is the granularity of
+ * many memory management calls.
+ */
+/*#define HAS_GETPAGESIZE / **/
+
+/* HAS_GNULIBC:
+ * This symbol, if defined, indicates to the C program that
+ * the GNU C library is being used. A better check is to use
+ * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc.
+ */
+/*#define HAS_GNULIBC / **/
+#if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
+# define _GNU_SOURCE
+#endif
+
+/* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+/*#define HAS_ISASCII / **/
+
+/* HAS_LCHOWN:
+ * This symbol, if defined, indicates that the lchown routine is
+ * available to operate on a symbolic link (instead of following the
+ * link).
+ */
+/*#define HAS_LCHOWN / **/
+
+/* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+/*#define HAS_OPEN3 / **/
+
+/* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Normally, you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+/*#define HAS_SAFE_BCOPY / **/
+
+/* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. If you need to
+ * copy overlapping memory blocks, you should check HAS_MEMMOVE and
+ * use memmove() instead, if available.
+ */
+/*#define HAS_SAFE_MEMCPY / **/
+
+/* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * and can be used to compare relative magnitudes of chars with their high
+ * bits set. If it is not defined, roll your own version.
+ */
+/*#define HAS_SANE_MEMCMP / **/
+
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+/*#define HAS_SIGACTION / **/
+
+/* HAS_SIGSETJMP:
+ * This variable indicates to the C program that the sigsetjmp()
+ * routine is available to save the calling process's registers
+ * and stack environment for later use by siglongjmp(), and
+ * to optionally save the process's signal mask. See
+ * Sigjmp_buf, Sigsetjmp, and Siglongjmp.
+ */
+/* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+/* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/*#define HAS_SIGSETJMP / **/
+#ifdef HAS_SIGSETJMP
+#define Sigjmp_buf sigjmp_buf
+#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
+#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
+#else
+#define Sigjmp_buf jmp_buf
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
+#endif
+
+/* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+/* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+/* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+/* STDIO_PTR_LVAL_SETS_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n has the side effect of decreasing the
+ * value of File_cnt(fp) by n.
+ */
+/* STDIO_PTR_LVAL_NOCHANGE_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n leaves File_cnt(fp) unchanged.
+ */
+/*#define USE_STDIO_PTR / **/
+#ifdef USE_STDIO_PTR
+#define FILE_ptr(fp) ((fp)->_IO_read_ptr)
+/*#define STDIO_PTR_LVALUE / **/
+#define FILE_cnt(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr)
+/*#define STDIO_CNT_LVALUE / **/
+/*#define STDIO_PTR_LVAL_SETS_CNT / **/
+/*#define STDIO_PTR_LVAL_NOCHANGE_CNT / **/
+#endif
+
+/* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+/* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+/* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+/*#define USE_STDIO_BASE / **/
+#ifdef USE_STDIO_BASE
+#define FILE_base(fp) ((fp)->_IO_read_base)
+#define FILE_bufsiz(fp) ((fp)->_IO_read_end - (fp)->_IO_read_base)
+#endif
+
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+/*#define USE_CHAR_VSPRINTF / **/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE 8 /**/
+
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+/* HAS_TM_TM_ZONE:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_zone field.
+ */
+/* HAS_TM_TM_GMTOFF:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_gmtoff field.
+ */
+#define I_TIME /**/
+/*#define I_SYS_TIME / **/
+/*#define I_SYS_TIME_KERNEL / **/
+/*#define HAS_TM_TM_ZONE / **/
+/*#define HAS_TM_TM_GMTOFF / **/
+
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#undef EOF_NONBLOCK
+
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE 4 /**/
+
+/* Drand01:
+ * This macro is to be used to generate uniformly distributed
+ * random numbers over the range [0., 1.[. You may have to supply
+ * an 'extern double drand48();' in your program since SunOS 4.1.3
+ * doesn't provide you with anything relevant in its headers.
+ * See HAS_DRAND48_PROTO.
+ */
+/* Rand_seed_t:
+ * This symbol defines the type of the argument of the
+ * random seed function.
+ */
+/* seedDrand01:
+ * This symbol defines the macro to be used in seeding the
+ * random number generator (see Drand01).
+ */
+/* RANDBITS:
+ * This symbol indicates how many bits are produced by the
+ * function used to generate normalized random numbers.
+ * Values include 15, 16, 31, and 48.
+ */
+#define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) /**/
+#define Rand_seed_t int /**/
+#define seedDrand01(x) srand((Rand_seed_t)x) /**/
+#define RANDBITS 48 /**/
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t int /* signed count of bytes */
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+/*#define EBCDIC / **/
+
+/* PERL_USE_DEVEL:
+ * This symbol, if defined, indicates that Perl was configured with
+ * -Dusedevel, to enable development features. This should not be
+ * done for production builds.
+ */
+/*#define PERL_USE_DEVEL / **/
+
+/* HAS_ATOLF:
+ * This symbol, if defined, indicates that the atolf routine is
+ * available to convert strings into long doubles.
+ */
+/*#define HAS_ATOLF / **/
+
+/* HAS_ATOLL:
+ * This symbol, if defined, indicates that the atoll routine is
+ * available to convert strings into long longs.
+ */
+/*#define HAS_ATOLL / **/
+
+/* HAS__FWALK:
+ * This symbol, if defined, indicates that the _fwalk system call is
+ * available to apply a function to all the file handles.
+ */
+/*#define HAS__FWALK / **/
+
+/* HAS_AINTL:
+ * This symbol, if defined, indicates that the aintl routine is
+ * available. If copysignl is also present we can emulate modfl.
+ */
+/*#define HAS_AINTL / **/
+
+/* HAS_BUILTIN_CHOOSE_EXPR:
+ * Can we handle GCC builtin for compile-time ternary-like expressions
+ */
+/* HAS_BUILTIN_EXPECT:
+ * Can we handle GCC builtin for telling that certain values are more
+ * likely
+ */
+/*#define HAS_BUILTIN_EXPECT / **/
+/*#define HAS_BUILTIN_CHOOSE_EXPR / **/
+
+/* HAS_C99_VARIADIC_MACROS:
+ * If defined, the compiler supports C99 variadic macros.
+ */
+/*#define HAS_C99_VARIADIC_MACROS / **/
+
+/* HAS_CLASS:
+ * This symbol, if defined, indicates that the class routine is
+ * available to classify doubles. Available for example in AIX.
+ * The returned values are defined in <float.h> and are:
+ *
+ * FP_PLUS_NORM Positive normalized, nonzero
+ * FP_MINUS_NORM Negative normalized, nonzero
+ * FP_PLUS_DENORM Positive denormalized, nonzero
+ * FP_MINUS_DENORM Negative denormalized, nonzero
+ * FP_PLUS_ZERO +0.0
+ * FP_MINUS_ZERO -0.0
+ * FP_PLUS_INF +INF
+ * FP_MINUS_INF -INF
+ * FP_NANS Signaling Not a Number (NaNS)
+ * FP_NANQ Quiet Not a Number (NaNQ)
+ */
+/*#define HAS_CLASS / **/
+
+/* HAS_CLEARENV:
+ * This symbol, if defined, indicates that the clearenv () routine is
+ * available for use.
+ */
+/*#define HAS_CLEARENV / **/
+
+/* HAS_STRUCT_CMSGHDR:
+ * This symbol, if defined, indicates that the struct cmsghdr
+ * is supported.
+ */
+/*#define HAS_STRUCT_CMSGHDR / **/
+
+/* HAS_COPYSIGNL:
+ * This symbol, if defined, indicates that the copysignl routine is
+ * available. If aintl is also present we can emulate modfl.
+ */
+/*#define HAS_COPYSIGNL / **/
+
+/* USE_CPLUSPLUS:
+ * This symbol, if defined, indicates that a C++ compiler was
+ * used to compiled Perl and will be used to compile extensions.
+ */
+/*#define USE_CPLUSPLUS / **/
+
+/* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+/*#define HAS_DBMINIT_PROTO / **/
+
+/* HAS_DIR_DD_FD:
+ * This symbol, if defined, indicates that the the DIR* dirstream
+ * structure contains a member variable named dd_fd.
+ */
+/*#define HAS_DIR_DD_FD / **/
+
+/* HAS_DIRFD:
+ * This manifest constant lets the C program know that dirfd
+ * is available.
+ */
+/*#define HAS_DIRFD / **/
+
+/* DLSYM_NEEDS_UNDERSCORE:
+ * This symbol, if defined, indicates that we need to prepend an
+ * underscore to the symbol name before calling dlsym(). This only
+ * makes sense if you *have* dlsym, which we will presume is the
+ * case if you're using dl_dlopen.xs.
+ */
+/*#define DLSYM_NEEDS_UNDERSCORE / **/
+
+/* HAS_FAST_STDIO:
+ * This symbol, if defined, indicates that the "fast stdio"
+ * is available to manipulate the stdio buffers directly.
+ */
+/*#define HAS_FAST_STDIO / **/
+
+/* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+/*#define HAS_FCHDIR / **/
+
+/* FCNTL_CAN_LOCK:
+ * This symbol, if defined, indicates that fcntl() can be used
+ * for file locking. Normally on Unix systems this is defined.
+ * It may be undefined on VMS.
+ */
+/*#define FCNTL_CAN_LOCK / **/
+
+/* HAS_FINITE:
+ * This symbol, if defined, indicates that the finite routine is
+ * available to check whether a double is finite (non-infinity non-NaN).
+ */
+/*#define HAS_FINITE / **/
+
+/* HAS_FINITEL:
+ * This symbol, if defined, indicates that the finitel routine is
+ * available to check whether a long double is finite
+ * (non-infinity non-NaN).
+ */
+/*#define HAS_FINITEL / **/
+
+/* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+/*#define HAS_FLOCK_PROTO / **/
+
+/* HAS_FP_CLASS:
+ * This symbol, if defined, indicates that the fp_class routine is
+ * available to classify doubles. Available for example in Digital UNIX.
+ * The returned values are defined in <math.h> and are:
+ *
+ * FP_SNAN Signaling NaN (Not-a-Number)
+ * FP_QNAN Quiet NaN (Not-a-Number)
+ * FP_POS_INF +infinity
+ * FP_NEG_INF -infinity
+ * FP_POS_NORM Positive normalized
+ * FP_NEG_NORM Negative normalized
+ * FP_POS_DENORM Positive denormalized
+ * FP_NEG_DENORM Negative denormalized
+ * FP_POS_ZERO +0.0 (positive zero)
+ * FP_NEG_ZERO -0.0 (negative zero)
+ */
+/*#define HAS_FP_CLASS / **/
+
+/* HAS_FPCLASS:
+ * This symbol, if defined, indicates that the fpclass routine is
+ * available to classify doubles. Available for example in Solaris/SVR4.
+ * The returned values are defined in <ieeefp.h> and are:
+ *
+ * FP_SNAN signaling NaN
+ * FP_QNAN quiet NaN
+ * FP_NINF negative infinity
+ * FP_PINF positive infinity
+ * FP_NDENORM negative denormalized non-zero
+ * FP_PDENORM positive denormalized non-zero
+ * FP_NZERO negative zero
+ * FP_PZERO positive zero
+ * FP_NNORM negative normalized non-zero
+ * FP_PNORM positive normalized non-zero
+ */
+/*#define HAS_FPCLASS / **/
+
+/* HAS_FPCLASSIFY:
+ * This symbol, if defined, indicates that the fpclassify routine is
+ * available to classify doubles. Available for example in HP-UX.
+ * The returned values are defined in <math.h> and are
+ *
+ * FP_NORMAL Normalized
+ * FP_ZERO Zero
+ * FP_INFINITE Infinity
+ * FP_SUBNORMAL Denormalized
+ * FP_NAN NaN
+ *
+ */
+/*#define HAS_FPCLASSIFY / **/
+
+/* HAS_FPCLASSL:
+ * This symbol, if defined, indicates that the fpclassl routine is
+ * available to classify long doubles. Available for example in IRIX.
+ * The returned values are defined in <ieeefp.h> and are:
+ *
+ * FP_SNAN signaling NaN
+ * FP_QNAN quiet NaN
+ * FP_NINF negative infinity
+ * FP_PINF positive infinity
+ * FP_NDENORM negative denormalized non-zero
+ * FP_PDENORM positive denormalized non-zero
+ * FP_NZERO negative zero
+ * FP_PZERO positive zero
+ * FP_NNORM negative normalized non-zero
+ * FP_PNORM positive normalized non-zero
+ */
+/*#define HAS_FPCLASSL / **/
+
+/* HAS_FPOS64_T:
+ * This symbol will be defined if the C compiler supports fpos64_t.
+ */
+/*#define HAS_FPOS64_T / **/
+
+/* HAS_FREXPL:
+ * This symbol, if defined, indicates that the frexpl routine is
+ * available to break a long double floating-point number into
+ * a normalized fraction and an integral power of 2.
+ */
+/*#define HAS_FREXPL / **/
+
+/* HAS_STRUCT_FS_DATA:
+ * This symbol, if defined, indicates that the struct fs_data
+ * to do statfs() is supported.
+ */
+/*#define HAS_STRUCT_FS_DATA / **/
+
+/* HAS_FSEEKO:
+ * This symbol, if defined, indicates that the fseeko routine is
+ * available to fseek beyond 32 bits (useful for ILP32 hosts).
+ */
+/*#define HAS_FSEEKO / **/
+
+/* HAS_FSTATFS:
+ * This symbol, if defined, indicates that the fstatfs routine is
+ * available to stat filesystems by file descriptors.
+ */
+/*#define HAS_FSTATFS / **/
+
+/* HAS_FSYNC:
+ * This symbol, if defined, indicates that the fsync routine is
+ * available to write a file's modified data and attributes to
+ * permanent storage.
+ */
+/*#define HAS_FSYNC / **/
+
+/* HAS_FTELLO:
+ * This symbol, if defined, indicates that the ftello routine is
+ * available to ftell beyond 32 bits (useful for ILP32 hosts).
+ */
+/*#define HAS_FTELLO / **/
+
+/* HAS_FUTIMES:
+ * This symbol, if defined, indicates that the futimes routine is
+ * available to change file descriptor time stamps with struct timevals.
+ */
+/*#define HAS_FUTIMES / **/
+
+/* HAS_GETCWD:
+ * This symbol, if defined, indicates that the getcwd routine is
+ * available to get the current working directory.
+ */
+/*#define HAS_GETCWD / **/
+
+/* HAS_GETESPWNAM:
+ * This symbol, if defined, indicates that the getespwnam system call is
+ * available to retrieve enchanced (shadow) password entries by name.
+ */
+/*#define HAS_GETESPWNAM / **/
+
+/* HAS_GETFSSTAT:
+ * This symbol, if defined, indicates that the getfsstat routine is
+ * available to stat filesystems in bulk.
+ */
+/*#define HAS_GETFSSTAT / **/
+
+/* HAS_GETITIMER:
+ * This symbol, if defined, indicates that the getitimer routine is
+ * available to return interval timers.
+ */
+/*#define HAS_GETITIMER / **/
+
+/* HAS_GETMNT:
+ * This symbol, if defined, indicates that the getmnt routine is
+ * available to get filesystem mount info by filename.
+ */
+/*#define HAS_GETMNT / **/
+
+/* HAS_GETMNTENT:
+ * This symbol, if defined, indicates that the getmntent routine is
+ * available to iterate through mounted file systems to get their info.
+ */
+/*#define HAS_GETMNTENT / **/
+
+/* HAS_GETPRPWNAM:
+ * This symbol, if defined, indicates that the getprpwnam system call is
+ * available to retrieve protected (shadow) password entries by name.
+ */
+/*#define HAS_GETPRPWNAM / **/
+
+/* HAS_GETSPNAM:
+ * This symbol, if defined, indicates that the getspnam system call is
+ * available to retrieve SysV shadow password entries by name.
+ */
+/*#define HAS_GETSPNAM / **/
+
+/* HAS_HASMNTOPT:
+ * This symbol, if defined, indicates that the hasmntopt routine is
+ * available to query the mount options of file systems.
+ */
+/*#define HAS_HASMNTOPT / **/
+
+/* HAS_ILOGBL:
+ * This symbol, if defined, indicates that the ilogbl routine is
+ * available. If scalbnl is also present we can emulate frexpl.
+ */
+/*#define HAS_ILOGBL / **/
+
+/* HAS_INT64_T:
+ * This symbol will defined if the C compiler supports int64_t.
+ * Usually the <inttypes.h> needs to be included, but sometimes
+ * <sys/types.h> is enough.
+ */
+/*#define HAS_INT64_T / **/
+
+/* HAS_ISFINITE:
+ * This symbol, if defined, indicates that the isfinite routine is
+ * available to check whether a double is finite (non-infinity non-NaN).
+ */
+/*#define HAS_ISFINITE / **/
+
+/* HAS_ISINF:
+ * This symbol, if defined, indicates that the isinf routine is
+ * available to check whether a double is an infinity.
+ */
+/*#define HAS_ISINF / **/
+
+/* HAS_ISNAN:
+ * This symbol, if defined, indicates that the isnan routine is
+ * available to check whether a double is a NaN.
+ */
+/*#define HAS_ISNAN / **/
+
+/* HAS_ISNANL:
+ * This symbol, if defined, indicates that the isnanl routine is
+ * available to check whether a long double is a NaN.
+ */
+/*#define HAS_ISNANL / **/
+
+/* HAS_LDBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol LDBL_DIG, which is the number
+ * of significant digits in a long double precision number. Unlike
+ * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined.
+ */
+/*#define HAS_LDBL_DIG / * */
+
+/* LIBM_LIB_VERSION:
+ * This symbol, if defined, indicates that libm exports _LIB_VERSION
+ * and that math.h defines the enum to manipulate it.
+ */
+/*#define LIBM_LIB_VERSION / **/
+
+/* HAS_MADVISE:
+ * This symbol, if defined, indicates that the madvise system call is
+ * available to map a file into memory.
+ */
+/*#define HAS_MADVISE / **/
+
+/* HAS_MALLOC_SIZE:
+ * This symbol, if defined, indicates that the malloc_size
+ * routine is available for use.
+ */
+/*#define HAS_MALLOC_SIZE / **/
+
+/* HAS_MALLOC_GOOD_SIZE:
+ * This symbol, if defined, indicates that the malloc_good_size
+ * routine is available for use.
+ */
+/*#define HAS_MALLOC_GOOD_SIZE / **/
+
+/* HAS_MKDTEMP:
+ * This symbol, if defined, indicates that the mkdtemp routine is
+ * available to exclusively create a uniquely named temporary directory.
+ */
+/*#define HAS_MKDTEMP / **/
+
+/* HAS_MKSTEMPS:
+ * This symbol, if defined, indicates that the mkstemps routine is
+ * available to excluslvely create and open a uniquely named
+ * (with a suffix) temporary file.
+ */
+/*#define HAS_MKSTEMPS / **/
+
+/* HAS_MODFL:
+ * This symbol, if defined, indicates that the modfl routine is
+ * available to split a long double x into a fractional part f and
+ * an integer part i such that |f| < 1.0 and (f + i) = x.
+ */
+/* HAS_MODFL_PROTO:
+ * 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.
+ */
+/* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine 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.
+ */
+/*#define HAS_MODFL / **/
+/*#define HAS_MODFL_PROTO / **/
+/*#define HAS_MODFL_POW32_BUG / **/
+
+/* HAS_MPROTECT:
+ * This symbol, if defined, indicates that the mprotect system call is
+ * available to modify the access protection of a memory mapped file.
+ */
+/*#define HAS_MPROTECT / **/
+
+/* HAS_STRUCT_MSGHDR:
+ * This symbol, if defined, indicates that the struct msghdr
+ * is supported.
+ */
+/*#define HAS_STRUCT_MSGHDR / **/
+
+/* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+/*#define HAS_NL_LANGINFO / **/
+
+/* HAS_OFF64_T:
+ * This symbol will be defined if the C compiler supports off64_t.
+ */
+/*#define HAS_OFF64_T / **/
+
+/* HAS_PROCSELFEXE:
+ * This symbol is defined if PROCSELFEXE_PATH is a symlink
+ * to the absolute pathname of the executing program.
+ */
+/* PROCSELFEXE_PATH:
+ * If HAS_PROCSELFEXE is defined this symbol is the filename
+ * of the symbolic link pointing to the absolute pathname of
+ * the executing program.
+ */
+/*#define HAS_PROCSELFEXE / **/
+#if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH)
+#define PROCSELFEXE_PATH /**/
+#endif
+
+/* HAS_PTHREAD_ATTR_SETSCOPE:
+ * This symbol, if defined, indicates that the pthread_attr_setscope
+ * system call is available to set the contention scope attribute of
+ * a thread attribute object.
+ */
+/*#define HAS_PTHREAD_ATTR_SETSCOPE / **/
+
+/* HAS_READV:
+ * This symbol, if defined, indicates that the readv routine is
+ * available to do gather reads. You will also need <sys/uio.h>
+ * and there I_SYSUIO.
+ */
+/*#define HAS_READV / **/
+
+/* HAS_RECVMSG:
+ * This symbol, if defined, indicates that the recvmsg routine is
+ * available to send structured socket messages.
+ */
+/*#define HAS_RECVMSG / **/
+
+/* HAS_SBRK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sbrk() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern void* sbrk(int);
+ * extern void* sbrk(size_t);
+ */
+/*#define HAS_SBRK_PROTO / **/
+
+/* HAS_SCALBNL:
+ * This symbol, if defined, indicates that the scalbnl routine is
+ * available. If ilogbl is also present we can emulate frexpl.
+ */
+/*#define HAS_SCALBNL / **/
+
+/* HAS_SENDMSG:
+ * This symbol, if defined, indicates that the sendmsg routine is
+ * available to send structured socket messages.
+ */
+/*#define HAS_SENDMSG / **/
+
+/* HAS_SETITIMER:
+ * This symbol, if defined, indicates that the setitimer routine is
+ * available to set interval timers.
+ */
+/*#define HAS_SETITIMER / **/
+
+/* HAS_SETPROCTITLE:
+ * This symbol, if defined, indicates that the setproctitle routine is
+ * available to set process title.
+ */
+/*#define HAS_SETPROCTITLE / **/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+/*#define USE_SFIO / **/
+
+/* HAS_SIGNBIT:
+ * This symbol, if defined, indicates that the signbit routine is
+ * available to check if the given number has the sign bit set.
+ * This should include correct testing of -0.0. This will only be set
+ * if the signbit() routine is safe to use with the NV type used internally
+ * in perl. Users should call Perl_signbit(), which will be #defined to
+ * the system's signbit() function or macro if this symbol is defined.
+ */
+/*#define HAS_SIGNBIT / **/
+
+/* HAS_SIGPROCMASK:
+ * This symbol, if defined, indicates that the sigprocmask
+ * system call is available to examine or change the signal mask
+ * of the calling process.
+ */
+/*#define HAS_SIGPROCMASK / **/
+
+/* USE_SITECUSTOMIZE:
+ * This symbol, if defined, indicates that sitecustomize should
+ * be used.
+ */
+#ifndef USE_SITECUSTOMIZE
+/*#define USE_SITECUSTOMIZE / **/
+#endif
+
+/* HAS_SNPRINTF:
+ * This symbol, if defined, indicates that the snprintf () library
+ * function is available for use.
+ */
+/* HAS_VSNPRINTF:
+ * This symbol, if defined, indicates that the vsnprintf () library
+ * function is available for use.
+ */
+/*#define HAS_SNPRINTF / **/
+/*#define HAS_VSNPRINTF / **/
+
+/* HAS_SOCKATMARK:
+ * This symbol, if defined, indicates that the sockatmark routine is
+ * available to test whether a socket is at the out-of-band mark.
+ */
+/*#define HAS_SOCKATMARK / **/
+
+/* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark(int);
+ */
+/*#define HAS_SOCKATMARK_PROTO / **/
+
+/* HAS_SOCKS5_INIT:
+ * This symbol, if defined, indicates that the socks5_init routine is
+ * available to initialize SOCKS 5.
+ */
+/*#define HAS_SOCKS5_INIT / **/
+
+/* SPRINTF_RETURNS_STRLEN:
+ * This variable defines whether sprintf returns the length of the string
+ * (as per the ANSI spec). Some C libraries retain compatibility with
+ * pre-ANSI C and return a pointer to the passed in buffer; for these
+ * this variable will be undef.
+ */
+/*#define SPRINTF_RETURNS_STRLEN / **/
+
+/* HAS_SQRTL:
+ * This symbol, if defined, indicates that the sqrtl routine is
+ * available to do long double square roots.
+ */
+/*#define HAS_SQRTL / **/
+
+/* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+/*#define HAS_SETRESGID_PROTO / **/
+
+/* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+/*#define HAS_SETRESUID_PROTO / **/
+
+/* HAS_STRUCT_STATFS_F_FLAGS:
+ * This symbol, if defined, indicates that the struct statfs
+ * does have the f_flags member containing the mount flags of
+ * the filesystem containing the file.
+ * This kind of struct statfs is coming from <sys/mount.h> (BSD 4.3),
+ * not from <sys/statfs.h> (SYSV). Older BSDs (like Ultrix) do not
+ * have statfs() and struct statfs, they have ustat() and getmnt()
+ * with struct ustat and struct fs_data.
+ */
+/*#define HAS_STRUCT_STATFS_F_FLAGS / **/
+
+/* HAS_STRUCT_STATFS:
+ * This symbol, if defined, indicates that the struct statfs
+ * to do statfs() is supported.
+ */
+/*#define HAS_STRUCT_STATFS / **/
+
+/* HAS_FSTATVFS:
+ * This symbol, if defined, indicates that the fstatvfs routine is
+ * available to stat filesystems by file descriptors.
+ */
+/*#define HAS_FSTATVFS / **/
+
+/* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+/*#define HAS_STRFTIME / **/
+
+/* HAS_STRLCAT:
+ * This symbol, if defined, indicates that the strlcat () routine is
+ * available to do string concatenation.
+ */
+/*#define HAS_STRLCAT / **/
+
+/* HAS_STRLCPY:
+ * This symbol, if defined, indicates that the strlcpy () routine is
+ * available to do string copying.
+ */
+/*#define HAS_STRLCPY / **/
+
+/* HAS_STRTOLD:
+ * This symbol, if defined, indicates that the strtold routine is
+ * available to convert strings to long doubles.
+ */
+/*#define HAS_STRTOLD / **/
+
+/* HAS_STRTOLL:
+ * This symbol, if defined, indicates that the strtoll routine is
+ * available to convert strings to long longs.
+ */
+/*#define HAS_STRTOLL / **/
+
+/* HAS_STRTOQ:
+ * This symbol, if defined, indicates that the strtoq routine is
+ * available to convert strings to long longs (quads).
+ */
+/*#define HAS_STRTOQ / **/
+
+/* HAS_STRTOULL:
+ * This symbol, if defined, indicates that the strtoull routine is
+ * available to convert strings to unsigned long longs.
+ */
+/*#define HAS_STRTOULL / **/
+
+/* HAS_STRTOUQ:
+ * This symbol, if defined, indicates that the strtouq routine is
+ * available to convert strings to unsigned long longs (quads).
+ */
+/*#define HAS_STRTOUQ / **/
+
+/* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+/*#define HAS_SYSCALL_PROTO / **/
+
+/* HAS_TELLDIR_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the telldir() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern long telldir(DIR*);
+ */
+/*#define HAS_TELLDIR_PROTO / **/
+
+/* HAS_CTIME64:
+ * This symbol, if defined, indicates that the ctime64 () routine is
+ * available to do the 64bit variant of ctime ()
+ */
+/* HAS_LOCALTIME64:
+ * This symbol, if defined, indicates that the localtime64 () routine is
+ * available to do the 64bit variant of localtime ()
+ */
+/* HAS_GMTIME64:
+ * This symbol, if defined, indicates that the gmtime64 () routine is
+ * available to do the 64bit variant of gmtime ()
+ */
+/* HAS_MKTIME64:
+ * This symbol, if defined, indicates that the mktime64 () routine is
+ * available to do the 64bit variant of mktime ()
+ */
+/* HAS_DIFFTIME64:
+ * This symbol, if defined, indicates that the difftime64 () routine is
+ * available to do the 64bit variant of difftime ()
+ */
+/* HAS_ASCTIME64:
+ * This symbol, if defined, indicates that the asctime64 () routine is
+ * available to do the 64bit variant of asctime ()
+ */
+/*#define HAS_CTIME64 / **/
+/*#define HAS_LOCALTIME64 / **/
+/*#define HAS_GMTIME64 / **/
+/*#define HAS_MKTIME64 / **/
+/*#define HAS_DIFFTIME64 / **/
+/*#define HAS_ASCTIME64 / **/
+
+/* HAS_TIMEGM:
+ * This symbol, if defined, indicates that the timegm routine is
+ * available to do the opposite of gmtime ()
+ */
+/*#define HAS_TIMEGM / **/
+
+/* U32_ALIGNMENT_REQUIRED:
+ * This symbol, if defined, indicates that you must access
+ * character data through U32-aligned pointers.
+ */
+#ifndef U32_ALIGNMENT_REQUIRED
+#define U32_ALIGNMENT_REQUIRED /**/
+#endif
+
+/* HAS_UALARM:
+ * This symbol, if defined, indicates that the ualarm routine is
+ * available to do alarms with microsecond granularity.
+ */
+/*#define HAS_UALARM / **/
+
+/* HAS_UNORDERED:
+ * This symbol, if defined, indicates that the unordered routine is
+ * available to check whether two doubles are unordered
+ * (effectively: whether either of them is NaN)
+ */
+/*#define HAS_UNORDERED / **/
+
+/* HAS_UNSETENV:
+ * This symbol, if defined, indicates that the unsetenv () routine is
+ * available for use.
+ */
+/*#define HAS_UNSETENV / **/
+
+/* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+/*#define HAS_USLEEP_PROTO / **/
+
+/* HAS_USTAT:
+ * This symbol, if defined, indicates that the ustat system call is
+ * available to query file system statistics by dev_t.
+ */
+/*#define HAS_USTAT / **/
+
+/* HAS_WRITEV:
+ * This symbol, if defined, indicates that the writev routine is
+ * available to do scatter writes.
+ */
+/*#define HAS_WRITEV / **/
+
+/* USE_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+/*#define USE_DYNAMIC_LOADING / **/
+
+/* FFLUSH_NULL:
+ * This symbol, if defined, tells that fflush(NULL) does flush
+ * all pending stdio output.
+ */
+/* FFLUSH_ALL:
+ * 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.
+ */
+/*#define FFLUSH_NULL / **/
+/*#define FFLUSH_ALL / **/
+
+/* I_ASSERT:
+ * This symbol, if defined, indicates that <assert.h> exists and
+ * could be included by the C program to get the assert() macro.
+ */
+#define I_ASSERT /**/
+
+/* I_CRYPT:
+ * This symbol, if defined, indicates that <crypt.h> exists and
+ * should be included.
+ */
+/*#define I_CRYPT / **/
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+/* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+/* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+/* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+#define DB_Hash_t u_int32_t /**/
+#define DB_Prefix_t size_t /**/
+#define DB_VERSION_MAJOR_CFG 0 /**/
+#define DB_VERSION_MINOR_CFG 0 /**/
+#define DB_VERSION_PATCH_CFG 0 /**/
+
+/* I_FP:
+ * This symbol, if defined, indicates that <fp.h> exists and
+ * should be included.
+ */
+/*#define I_FP / **/
+
+/* I_FP_CLASS:
+ * This symbol, if defined, indicates that <fp_class.h> exists and
+ * should be included.
+ */
+/*#define I_FP_CLASS / **/
+
+/* I_IEEEFP:
+ * This symbol, if defined, indicates that <ieeefp.h> exists and
+ * should be included.
+ */
+/*#define I_IEEEFP / **/
+
+/* I_INTTYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <inttypes.h>.
+ */
+/*#define I_INTTYPES / **/
+
+/* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+/*#define I_LANGINFO / **/
+
+/* I_LIBUTIL:
+ * This symbol, if defined, indicates that <libutil.h> exists and
+ * should be included.
+ */
+/*#define I_LIBUTIL / **/
+
+/* I_MALLOCMALLOC:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <malloc/malloc.h>.
+ */
+/*#define I_MALLOCMALLOC / **/
+
+/* I_MNTENT:
+ * This symbol, if defined, indicates that <mntent.h> exists and
+ * should be included.
+ */
+/*#define I_MNTENT / **/
+
+/* I_NETINET_TCP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/tcp.h>.
+ */
+/*#define I_NETINET_TCP / **/
+
+/* I_POLL:
+ * This symbol, if defined, indicates that <poll.h> exists and
+ * should be included. (see also HAS_POLL)
+ */
+/*#define I_POLL / **/
+
+/* I_PROT:
+ * This symbol, if defined, indicates that <prot.h> exists and
+ * should be included.
+ */
+/*#define I_PROT / **/
+
+/* I_SHADOW:
+ * This symbol, if defined, indicates that <shadow.h> exists and
+ * should be included.
+ */
+/*#define I_SHADOW / **/
+
+/* I_SOCKS:
+ * This symbol, if defined, indicates that <socks.h> exists and
+ * should be included.
+ */
+/*#define I_SOCKS / **/
+
+/* I_SUNMATH:
+ * This symbol, if defined, indicates that <sunmath.h> exists and
+ * should be included.
+ */
+/*#define I_SUNMATH / **/
+
+/* I_SYSLOG:
+ * This symbol, if defined, indicates that <syslog.h> exists and
+ * should be included.
+ */
+/*#define I_SYSLOG / **/
+
+/* I_SYSMODE:
+ * This symbol, if defined, indicates that <sys/mode.h> exists and
+ * should be included.
+ */
+/*#define I_SYSMODE / **/
+
+/* I_SYS_MOUNT:
+ * This symbol, if defined, indicates that <sys/mount.h> exists and
+ * should be included.
+ */
+/*#define I_SYS_MOUNT / **/
+
+/* I_SYS_STATFS:
+ * This symbol, if defined, indicates that <sys/statfs.h> exists.
+ */
+/*#define I_SYS_STATFS / **/
+
+/* I_SYS_STATVFS:
+ * This symbol, if defined, indicates that <sys/statvfs.h> exists and
+ * should be included.
+ */
+/*#define I_SYS_STATVFS / **/
+
+/* I_SYSUTSNAME:
+ * This symbol, if defined, indicates that <sys/utsname.h> exists and
+ * should be included.
+ */
+/*#define I_SYSUTSNAME / **/
+
+/* I_SYS_VFS:
+ * This symbol, if defined, indicates that <sys/vfs.h> exists and
+ * should be included.
+ */
+/*#define I_SYS_VFS / **/
+
+/* I_USTAT:
+ * This symbol, if defined, indicates that <ustat.h> exists and
+ * should be included.
+ */
+/*#define I_USTAT / **/
+
+/* PERL_PRIfldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'f') for output.
+ */
+/* PERL_PRIgldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'g') for output.
+ */
+/* PERL_PRIeldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'e') for output.
+ */
+/* PERL_SCNfldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'f') for input.
+ */
+/*#define PERL_PRIfldbl "llf" / **/
+/*#define PERL_PRIgldbl "llg" / **/
+/*#define PERL_PRIeldbl "lle" / **/
+/*#define PERL_SCNfldbl "llf" / **/
+
+/* PERL_MAD:
+ * This symbol, if defined, indicates that the Misc Attribution
+ * Declaration code should be conditionally compiled.
+ */
+/*#define PERL_MAD / **/
+
+/* NEED_VA_COPY:
+ * 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, handy.h defines a platform-
+ * independent macro, Perl_va_copy(src, dst), to do the job.
+ */
+/*#define NEED_VA_COPY / **/
+
+/* IVTYPE:
+ * This symbol defines the C type used for Perl's IV.
+ */
+/* UVTYPE:
+ * This symbol defines the C type used for Perl's UV.
+ */
+/* I8TYPE:
+ * This symbol defines the C type used for Perl's I8.
+ */
+/* U8TYPE:
+ * This symbol defines the C type used for Perl's U8.
+ */
+/* I16TYPE:
+ * This symbol defines the C type used for Perl's I16.
+ */
+/* U16TYPE:
+ * This symbol defines the C type used for Perl's U16.
+ */
+/* I32TYPE:
+ * This symbol defines the C type used for Perl's I32.
+ */
+/* U32TYPE:
+ * This symbol defines the C type used for Perl's U32.
+ */
+/* I64TYPE:
+ * This symbol defines the C type used for Perl's I64.
+ */
+/* U64TYPE:
+ * This symbol defines the C type used for Perl's U64.
+ */
+/* NVTYPE:
+ * This symbol defines the C type used for Perl's NV.
+ */
+/* IVSIZE:
+ * This symbol contains the sizeof(IV).
+ */
+/* UVSIZE:
+ * This symbol contains the sizeof(UV).
+ */
+/* I8SIZE:
+ * This symbol contains the sizeof(I8).
+ */
+/* U8SIZE:
+ * This symbol contains the sizeof(U8).
+ */
+/* I16SIZE:
+ * This symbol contains the sizeof(I16).
+ */
+/* U16SIZE:
+ * This symbol contains the sizeof(U16).
+ */
+/* I32SIZE:
+ * This symbol contains the sizeof(I32).
+ */
+/* U32SIZE:
+ * This symbol contains the sizeof(U32).
+ */
+/* I64SIZE:
+ * This symbol contains the sizeof(I64).
+ */
+/* U64SIZE:
+ * This symbol contains the sizeof(U64).
+ */
+/* NVSIZE:
+ * This symbol contains the sizeof(NV).
+ */
+/* NV_PRESERVES_UV:
+ * This symbol, if defined, indicates that a variable of type NVTYPE
+ * can preserve all the bits of a variable of type UVTYPE.
+ */
+/* NV_PRESERVES_UV_BITS:
+ * This symbol contains the number of bits a variable of type NVTYPE
+ * can preserve of a variable of type UVTYPE.
+ */
+/* NV_OVERFLOWS_INTEGERS_AT:
+ * This symbol gives the largest integer value that NVs can hold. This
+ * value + 1.0 cannot be stored accurately. It is expressed as constant
+ * floating point expression to reduce the chance of decimale/binary
+ * conversion issues. If it can not be determined, the value 0 is given.
+ */
+/* NV_ZERO_IS_ALLBITS_ZERO:
+ * This symbol, if defined, indicates that a variable of type NVTYPE
+ * stores 0.0 in memory as all bits zero.
+ */
+#define IVTYPE long /**/
+#define UVTYPE unsigned long /**/
+#define I8TYPE char /**/
+#define U8TYPE unsigned char /**/
+#define I16TYPE short /**/
+#define U16TYPE unsigned short /**/
+#define I32TYPE long /**/
+#define U32TYPE unsigned long /**/
+#ifdef HAS_QUAD
+#define I64TYPE int64_t /**/
+#define U64TYPE uint64_t /**/
+#endif
+#define NVTYPE double /**/
+#define IVSIZE 4 /**/
+#define UVSIZE 4 /**/
+#define I8SIZE 1 /**/
+#define U8SIZE 1 /**/
+#define I16SIZE 2 /**/
+#define U16SIZE 2 /**/
+#define I32SIZE 4 /**/
+#define U32SIZE 4 /**/
+#ifdef HAS_QUAD
+#define I64SIZE 8 /**/
+#define U64SIZE 8 /**/
+#endif
+#define NVSIZE 8 /**/
+#undef NV_PRESERVES_UV
+#define NV_PRESERVES_UV_BITS 0
+#define 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
+#undef NV_ZERO_IS_ALLBITS_ZERO
+#if UVSIZE == 8
+# ifdef BYTEORDER
+# if BYTEORDER == 0x1234
+# undef BYTEORDER
+# define BYTEORDER 0x12345678
+# else
+# if BYTEORDER == 0x4321
+# undef BYTEORDER
+# define BYTEORDER 0x87654321
+# endif
+# endif
+# endif
+#endif
+
+/* IVdf:
+ * This symbol defines the format string used for printing a Perl IV
+ * as a signed decimal integer.
+ */
+/* UVuf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned decimal integer.
+ */
+/* UVof:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned octal integer.
+ */
+/* UVxf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned hexadecimal integer in lowercase abcdef.
+ */
+/* UVXf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned hexadecimal integer in uppercase ABCDEF.
+ */
+/* NVef:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %e-ish floating point format.
+ */
+/* NVff:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %f-ish floating point format.
+ */
+/* NVgf:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %g-ish floating point format.
+ */
+#define IVdf "ld" /**/
+#define UVuf "lu" /**/
+#define UVof "lo" /**/
+#define UVxf "lx" /**/
+#define UVXf "lX" /**/
+#define NVef "e" /**/
+#define NVff "f" /**/
+#define NVgf "g" /**/
+
+/* SELECT_MIN_BITS:
+ * This symbol 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(n/32), especially many little-endians do
+ * the latter. This is only useful if you have select(), naturally.
+ */
+#define SELECT_MIN_BITS 32 /**/
+
+/* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+#define STARTPERL "#!perl" /**/
+
+/* HAS_STDIO_STREAM_ARRAY:
+ * This symbol, if defined, tells that there is an array
+ * holding the stdio streams.
+ */
+/* STDIO_STREAM_ARRAY:
+ * This symbol tells the name of the array holding the stdio streams.
+ * Usual values include _iob, __iob, and __sF.
+ */
+/*#define HAS_STDIO_STREAM_ARRAY / **/
+#ifdef HAS_STDIO_STREAM_ARRAY
+#define STDIO_STREAM_ARRAY
+#endif
+
+/* GMTIME_MAX:
+ * This symbol contains the maximum value for the time_t offset that
+ * the system function gmtime () accepts, and defaults to 0
+ */
+/* GMTIME_MIN:
+ * This symbol contains the minimum value for the time_t offset that
+ * the system function gmtime () accepts, and defaults to 0
+ */
+/* LOCALTIME_MAX:
+ * This symbol contains the maximum value for the time_t offset that
+ * the system function localtime () accepts, and defaults to 0
+ */
+/* LOCALTIME_MIN:
+ * This symbol contains the minimum value for the time_t offset that
+ * the system function localtime () accepts, and defaults to 0
+ */
+#define GMTIME_MAX 2147483647 /**/
+#define GMTIME_MIN 0 /**/
+#define LOCALTIME_MAX 2147483647 /**/
+#define LOCALTIME_MIN 0 /**/
+
+/* USE_64_BIT_INT:
+ * This symbol, if defined, indicates that 64-bit integers should
+ * be used when available. If not defined, the native integers
+ * will be employed (be they 32 or 64 bits). The minimal possible
+ * 64-bitness is used, 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.
+ */
+/* USE_64_BIT_ALL:
+ * This symbol, if defined, indicates that 64-bit integers should
+ * be used when available. If not defined, the native integers
+ * will be used (be they 32 or 64 bits). 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 CPU at all or
+ * you may need at least to reboot your OS to 64-bit mode.
+ */
+#ifndef USE_64_BIT_INT
+/*#define USE_64_BIT_INT / **/
+#endif
+#ifndef USE_64_BIT_ALL
+/*#define USE_64_BIT_ALL / **/
+#endif
+
+/* USE_DTRACE:
+ * This symbol, if defined, indicates that Perl should
+ * be built with support for DTrace.
+ */
+/*#define USE_DTRACE / **/
+
+/* USE_FAST_STDIO:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use 'fast stdio'.
+ * Defaults to define in Perls 5.8 and earlier, to undef later.
+ */
+#ifndef USE_FAST_STDIO
+/*#define USE_FAST_STDIO / **/
+#endif
+
+/* USE_LARGE_FILES:
+ * This symbol, if defined, indicates that large file support
+ * should be used when available.
+ */
+#ifndef USE_LARGE_FILES
+/*#define USE_LARGE_FILES / **/
+#endif
+
+/* USE_LONG_DOUBLE:
+ * This symbol, if defined, indicates that long doubles should
+ * be used when available.
+ */
+#ifndef USE_LONG_DOUBLE
+/*#define USE_LONG_DOUBLE / **/
+#endif
+
+/* USE_MORE_BITS:
+ * This symbol, if defined, indicates that 64-bit interfaces and
+ * long doubles should be used when available.
+ */
+#ifndef USE_MORE_BITS
+/*#define USE_MORE_BITS / **/
+#endif
+
+/* MULTIPLICITY:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use multiplicity.
+ */
+#ifndef MULTIPLICITY
+/*#define MULTIPLICITY / **/
+#endif
+
+/* USE_PERLIO:
+ * This symbol, if defined, indicates that the PerlIO abstraction should
+ * be used throughout. If not defined, stdio should be
+ * used in a fully backward compatible manner.
+ */
+#ifndef USE_PERLIO
+/*#define USE_PERLIO / **/
+#endif
+
+/* USE_SOCKS:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use socks.
+ */
+#ifndef USE_SOCKS
+/*#define USE_SOCKS / **/
+#endif
+
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/unixish.h b/Master/tlpkg/tlperl.straw/lib/CORE/unixish.h
new file mode 100755
index 00000000000..6ad95c2dc8c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/unixish.h
@@ -0,0 +1,156 @@
+/* unixish.h
+ *
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002,
+ * 2003, 2006, 2007, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * The following symbols are defined if your operating system supports
+ * functions by that name. All Unixes I know of support them, thus they
+ * are not checked by the configuration script, but are directly defined
+ * here.
+ */
+
+#ifndef PERL_MICRO
+
+/* HAS_IOCTL:
+ * This symbol, if defined, indicates that the ioctl() routine is
+ * available to set I/O characteristics
+ */
+#define HAS_IOCTL /**/
+
+/* HAS_UTIME:
+ * This symbol, if defined, indicates that the routine utime() is
+ * available to update the access and modification times of files.
+ */
+#define HAS_UTIME /**/
+
+/* HAS_GROUP
+ * This symbol, if defined, indicates that the getgrnam() and
+ * getgrgid() routines are available to get group entries.
+ * The getgrent() has a separate definition, HAS_GETGRENT.
+ */
+#define HAS_GROUP /**/
+
+/* HAS_PASSWD
+ * This symbol, if defined, indicates that the getpwnam() and
+ * getpwuid() routines are available to get password entries.
+ * The getpwent() has a separate definition, HAS_GETPWENT.
+ */
+#define HAS_PASSWD /**/
+
+#define HAS_KILL
+#define HAS_WAIT
+
+#endif /* !PERL_MICRO */
+
+/* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+#undef USEMYBINMODE
+
+/* Stat_t:
+ * This symbol holds the type used to declare buffers for information
+ * returned by stat(). It's usually just struct stat. It may be necessary
+ * to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ * information.
+ */
+#define Stat_t struct stat
+
+/* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+#define USE_STAT_RDEV /**/
+
+/* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+#undef ACME_MESS /**/
+
+/* UNLINK_ALL_VERSIONS:
+ * This symbol, if defined, indicates that the program should arrange
+ * to remove all versions of a file if unlink() is called. This is
+ * probably only relevant for VMS.
+ */
+/* #define UNLINK_ALL_VERSIONS / **/
+
+/* VMS:
+ * This symbol, if defined, indicates that the program is running under
+ * VMS. It is currently automatically set by cpps running under VMS,
+ * and is included here for completeness only.
+ */
+/* #define VMS / **/
+
+/* ALTERNATE_SHEBANG:
+ * This symbol, if defined, contains a "magic" string which may be used
+ * as the first line of a Perl program designed to be executed directly
+ * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG
+ * begins with a character other then #, then Perl will only treat
+ * it as a command line if it finds the string "perl" in the first
+ * word; otherwise it's treated as the first line of code in the script.
+ * (IOW, Perl won't hand off to another interpreter via an alternate
+ * shebang sequence that might be legal Perl code.)
+ */
+/* #define ALTERNATE_SHEBANG "#!" / **/
+
+# include <signal.h>
+
+#ifndef SIGABRT
+# define SIGABRT SIGILL
+#endif
+#ifndef SIGILL
+# define SIGILL 6 /* blech */
+#endif
+#define ABORT() kill(PerlProc_getpid(),SIGABRT);
+
+/*
+ * fwrite1() should be a routine with the same calling sequence as fwrite(),
+ * but which outputs all of the bytes requested as a single stream (unlike
+ * fwrite() itself, which on some systems outputs several distinct records
+ * if the number_of_items parameter is >1).
+ */
+#define fwrite1 fwrite
+
+#define Stat(fname,bufptr) stat((fname),(bufptr))
+#define Fstat(fd,bufptr) fstat((fd),(bufptr))
+#define Fflush(fp) fflush(fp)
+#define Mkdir(path,mode) mkdir((path),(mode))
+
+#ifndef PERL_SYS_INIT_BODY
+# define PERL_SYS_INIT_BODY(c,v) \
+ MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; MALLOC_INIT
+#endif
+
+#ifndef PERL_SYS_TERM_BODY
+# define PERL_SYS_TERM_BODY() \
+ HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM;
+
+#endif
+
+#define BIT_BUCKET "/dev/null"
+
+#define dXSUB_SYS
+
+#ifndef NO_ENVIRON_ARRAY
+#define USE_ENVIRON_ARRAY
+#endif
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/utf8.h b/Master/tlpkg/tlperl.straw/lib/CORE/utf8.h
new file mode 100755
index 00000000000..3560329166e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/utf8.h
@@ -0,0 +1,352 @@
+/* utf8.h
+ *
+ * Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2009 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/* Use UTF-8 as the default script encoding?
+ * Turning this on will break scripts having non-UTF-8 binary
+ * data (such as Latin-1) in string literals. */
+#ifdef USE_UTF8_SCRIPTS
+# define USE_UTF8_IN_NAMES (!IN_BYTES)
+#else
+# define USE_UTF8_IN_NAMES (PL_hints & HINT_UTF8)
+#endif
+
+/* Source backward compatibility. */
+#define uvuni_to_utf8(d, uv) uvuni_to_utf8_flags(d, uv, 0)
+#define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
+
+#ifdef EBCDIC
+/* The equivalent of these macros but implementing UTF-EBCDIC
+ are in the following header file:
+ */
+
+#include "utfebcdic.h"
+
+#else
+START_EXTERN_C
+
+#ifdef DOINIT
+EXTCONST unsigned char PL_utf8skip[] = {
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus */
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus */
+2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /* scripts */
+3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,6,6, /* cjk etc. */
+7,13, /* Perl extended (not UTF-8). Up to 72bit allowed (64-bit + reserved). */
+};
+#else
+EXTCONST unsigned char PL_utf8skip[];
+#endif
+
+END_EXTERN_C
+#define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)]
+
+/* Native character to iso-8859-1 */
+#define NATIVE_TO_ASCII(ch) (ch)
+#define ASCII_TO_NATIVE(ch) (ch)
+/* Transform after encoding */
+#define NATIVE_TO_UTF(ch) (ch)
+#define UTF_TO_NATIVE(ch) (ch)
+/* Transforms in wide UV chars */
+#define UNI_TO_NATIVE(ch) (ch)
+#define NATIVE_TO_UNI(ch) (ch)
+/* Transforms in invariant space */
+#define NATIVE_TO_NEED(enc,ch) (ch)
+#define ASCII_TO_NEED(enc,ch) (ch)
+
+/* As there are no translations avoid the function wrapper */
+#define utf8n_to_uvchr utf8n_to_uvuni
+#define uvchr_to_utf8 uvuni_to_utf8
+
+/*
+
+ The following table is from Unicode 3.2.
+
+ Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte
+
+ U+0000..U+007F 00..7F
+ U+0080..U+07FF C2..DF 80..BF
+ U+0800..U+0FFF E0 A0..BF 80..BF
+ U+1000..U+CFFF E1..EC 80..BF 80..BF
+ U+D000..U+D7FF ED 80..9F 80..BF
+ U+D800..U+DFFF ******* ill-formed *******
+ U+E000..U+FFFF EE..EF 80..BF 80..BF
+ U+10000..U+3FFFF F0 90..BF 80..BF 80..BF
+ U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF
+ U+100000..U+10FFFF F4 80..8F 80..BF 80..BF
+
+Note the A0..BF in U+0800..U+0FFF, the 80..9F in U+D000...U+D7FF,
+the 90..BF in U+10000..U+3FFFF, and the 80...8F in U+100000..U+10FFFF.
+The "gaps" are caused by legal UTF-8 avoiding non-shortest encodings:
+it is technically possible to UTF-8-encode a single code point in different
+ways, but that is explicitly forbidden, and the shortest possible encoding
+should always be used (and that is what Perl does).
+
+ */
+
+/*
+ Another way to look at it, as bits:
+
+ Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte
+
+ 0aaaaaaa 0aaaaaaa
+ 00000bbbbbaaaaaa 110bbbbb 10aaaaaa
+ ccccbbbbbbaaaaaa 1110cccc 10bbbbbb 10aaaaaa
+ 00000dddccccccbbbbbbaaaaaa 11110ddd 10cccccc 10bbbbbb 10aaaaaa
+
+As you can see, the continuation bytes all begin with C<10>, and the
+leading bits of the start byte tell how many bytes the are in the
+encoded character.
+
+*/
+
+
+#define UNI_IS_INVARIANT(c) (((UV)c) < 0x80)
+#define UTF8_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_UTF(c))
+#define NATIVE_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_ASCII(c))
+#define UTF8_IS_START(c) (((U8)c) >= 0xc0 && (((U8)c) <= 0xfd))
+#define UTF8_IS_CONTINUATION(c) (((U8)c) >= 0x80 && (((U8)c) <= 0xbf))
+#define UTF8_IS_CONTINUED(c) (((U8)c) & 0x80)
+#define UTF8_IS_DOWNGRADEABLE_START(c) (((U8)c & 0xfc) == 0xc0)
+
+#define UTF_START_MARK(len) ((len > 7) ? 0xFF : (0xFE << (7-len)))
+#define UTF_START_MASK(len) ((len >= 7) ? 0x00 : (0x1F >> (len-2)))
+
+#define UTF_CONTINUATION_MARK 0x80
+#define UTF_ACCUMULATION_SHIFT 6
+#define UTF_CONTINUATION_MASK ((U8)0x3f)
+#define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT) | (((U8)new) & UTF_CONTINUATION_MASK))
+
+#define UTF8_EIGHT_BIT_HI(c) ((((U8)(c))>>UTF_ACCUMULATION_SHIFT)|UTF_START_MARK(2))
+#define UTF8_EIGHT_BIT_LO(c) (((((U8)(c)))&UTF_CONTINUATION_MASK)|UTF_CONTINUATION_MARK)
+
+#ifdef HAS_QUAD
+#define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \
+ (uv) < 0x800 ? 2 : \
+ (uv) < 0x10000 ? 3 : \
+ (uv) < 0x200000 ? 4 : \
+ (uv) < 0x4000000 ? 5 : \
+ (uv) < 0x80000000 ? 6 : \
+ (uv) < UTF8_QUAD_MAX ? 7 : 13 )
+#else
+/* No, I'm not even going to *TRY* putting #ifdef inside a #define */
+#define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \
+ (uv) < 0x800 ? 2 : \
+ (uv) < 0x10000 ? 3 : \
+ (uv) < 0x200000 ? 4 : \
+ (uv) < 0x4000000 ? 5 : \
+ (uv) < 0x80000000 ? 6 : 7 )
+#endif
+
+/*
+ * Note: we try to be careful never to call the isXXX_utf8() functions
+ * unless we're pretty sure we've seen the beginning of a UTF-8 character
+ * (that is, the two high bits are set). Otherwise we risk loading in the
+ * heavy-duty swash_init and swash_fetch routines unnecessarily.
+ */
+#define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || (*((const U8*)p) < 0xc0))) \
+ ? isIDFIRST(*(p)) \
+ : isIDFIRST_utf8((const U8*)p))
+#define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || (*((const U8*)p) < 0xc0))) \
+ ? isALNUM(*(p)) \
+ : isALNUM_utf8((const U8*)p))
+
+
+#endif /* EBCDIC vs ASCII */
+
+/* Rest of these are attributes of Unicode and perl's internals rather than the encoding */
+
+#define isIDFIRST_lazy(p) isIDFIRST_lazy_if(p,1)
+#define isALNUM_lazy(p) isALNUM_lazy_if(p,1)
+
+#define UTF8_MAXBYTES 13
+/* How wide can a single UTF-8 encoded character become in bytes.
+ * NOTE: Strictly speaking Perl's UTF-8 should not be called UTF-8
+ * since UTF-8 is an encoding of Unicode and given Unicode's current
+ * upper limit only four bytes is possible. Perl thinks of UTF-8
+ * as a way to encode non-negative integers in a binary format. */
+#define UTF8_MAXLEN UTF8_MAXBYTES
+
+#define UTF8_MAXLEN_UCLC 3 /* Obsolete, do not use. */
+#define UTF8_MAXLEN_UCLC_MULT 39 /* Obsolete, do not use. */
+#define UTF8_MAXLEN_FOLD 3 /* Obsolete, do not use. */
+#define UTF8_MAXLEN_FOLD_MULT 39 /* Obsolete, do not use. */
+
+/* The maximum number of UTF-8 bytes a single Unicode character can
+ * uppercase/lowercase/fold into; this number depends on the Unicode
+ * version. An example of maximal expansion is the U+03B0 which
+ * uppercases to U+03C5 U+0308 U+0301. The Unicode databases that
+ * tell these things are UnicodeDatabase.txt, CaseFolding.txt, and
+ * SpecialCasing.txt. */
+#define UTF8_MAXBYTES_CASE 6
+
+#define IN_BYTES (CopHINTS_get(PL_curcop) & HINT_BYTES)
+#define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTES)
+
+#define UTF8_ALLOW_EMPTY 0x0001
+#define UTF8_ALLOW_CONTINUATION 0x0002
+#define UTF8_ALLOW_NON_CONTINUATION 0x0004
+#define UTF8_ALLOW_FE_FF 0x0008 /* Allow above 0x7fffFFFF */
+#define UTF8_ALLOW_SHORT 0x0010
+#define UTF8_ALLOW_SURROGATE 0x0020
+#define UTF8_ALLOW_FFFF 0x0040 /* Allow UNICODE_ILLEGAL */
+#define UTF8_ALLOW_LONG 0x0080
+#define UTF8_ALLOW_ANYUV (UTF8_ALLOW_EMPTY|UTF8_ALLOW_FE_FF|\
+ UTF8_ALLOW_SURROGATE|UTF8_ALLOW_FFFF)
+#define UTF8_ALLOW_ANY 0x00FF
+#define UTF8_CHECK_ONLY 0x0200
+#define UTF8_ALLOW_DEFAULT (ckWARN(WARN_UTF8) ? 0 : \
+ UTF8_ALLOW_ANYUV)
+
+#define UNICODE_SURROGATE_FIRST 0xD800
+#define UNICODE_SURROGATE_LAST 0xDFFF
+#define UNICODE_REPLACEMENT 0xFFFD
+#define UNICODE_BYTE_ORDER_MARK 0xFEFF
+#define UNICODE_ILLEGAL 0xFFFF
+
+/* Though our UTF-8 encoding can go beyond this,
+ * let's be conservative and do as Unicode 3.2 says. */
+#define PERL_UNICODE_MAX 0x10FFFF
+
+#define UNICODE_ALLOW_SURROGATE 0x0001 /* Allow UTF-16 surrogates (EVIL) */
+#define UNICODE_ALLOW_FDD0 0x0002 /* Allow the U+FDD0...U+FDEF */
+#define UNICODE_ALLOW_FFFF 0x0004 /* Allow U+FFF[EF], U+1FFF[EF], ... */
+#define UNICODE_ALLOW_SUPER 0x0008 /* Allow past 0x10FFFF */
+#define UNICODE_ALLOW_ANY 0x000F
+
+#define UNICODE_IS_SURROGATE(c) ((c) >= UNICODE_SURROGATE_FIRST && \
+ (c) <= UNICODE_SURROGATE_LAST)
+#define UNICODE_IS_REPLACEMENT(c) ((c) == UNICODE_REPLACEMENT)
+#define UNICODE_IS_BYTE_ORDER_MARK(c) ((c) == UNICODE_BYTE_ORDER_MARK)
+#define UNICODE_IS_ILLEGAL(c) ((c) == UNICODE_ILLEGAL)
+
+#ifdef HAS_QUAD
+# define UTF8_QUAD_MAX UINT64_C(0x1000000000)
+#endif
+
+#define UTF8_IS_ASCII(c) UTF8_IS_INVARIANT(c)
+
+#define UNICODE_LATIN_SMALL_LETTER_SHARP_S 0x00DF
+#define UNICODE_GREEK_CAPITAL_LETTER_SIGMA 0x03A3
+#define UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA 0x03C2
+#define UNICODE_GREEK_SMALL_LETTER_SIGMA 0x03C3
+
+#define EBCDIC_LATIN_SMALL_LETTER_SHARP_S 0x0059
+
+#define UNI_DISPLAY_ISPRINT 0x0001
+#define UNI_DISPLAY_BACKSLASH 0x0002
+#define UNI_DISPLAY_QQ (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH)
+#define UNI_DISPLAY_REGEX (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH)
+
+#ifdef EBCDIC
+# define ANYOF_FOLD_SHARP_S(node, input, end) \
+ (ANYOF_BITMAP_TEST(node, EBCDIC_LATIN_SMALL_LETTER_SHARP_S) && \
+ (ANYOF_FLAGS(node) & ANYOF_UNICODE) && \
+ (ANYOF_FLAGS(node) & ANYOF_FOLD) && \
+ ((end) > (input) + 1) && \
+ toLOWER((input)[0]) == 's' && \
+ toLOWER((input)[1]) == 's')
+#else
+# define ANYOF_FOLD_SHARP_S(node, input, end) \
+ (ANYOF_BITMAP_TEST(node, UNICODE_LATIN_SMALL_LETTER_SHARP_S) && \
+ (ANYOF_FLAGS(node) & ANYOF_UNICODE) && \
+ (ANYOF_FLAGS(node) & ANYOF_FOLD) && \
+ ((end) > (input) + 1) && \
+ toLOWER((input)[0]) == 's' && \
+ toLOWER((input)[1]) == 's')
+#endif
+#define SHARP_S_SKIP 2
+
+#ifdef EBCDIC
+/* IS_UTF8_CHAR() is not ported to EBCDIC */
+#else
+#define IS_UTF8_CHAR_1(p) \
+ ((p)[0] <= 0x7F)
+#define IS_UTF8_CHAR_2(p) \
+ ((p)[0] >= 0xC2 && (p)[0] <= 0xDF && \
+ (p)[1] >= 0x80 && (p)[1] <= 0xBF)
+#define IS_UTF8_CHAR_3a(p) \
+ ((p)[0] == 0xE0 && \
+ (p)[1] >= 0xA0 && (p)[1] <= 0xBF && \
+ (p)[2] >= 0x80 && (p)[2] <= 0xBF)
+#define IS_UTF8_CHAR_3b(p) \
+ ((p)[0] >= 0xE1 && (p)[0] <= 0xEC && \
+ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
+ (p)[2] >= 0x80 && (p)[2] <= 0xBF)
+#define IS_UTF8_CHAR_3c(p) \
+ ((p)[0] == 0xED && \
+ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
+ (p)[2] >= 0x80 && (p)[2] <= 0xBF)
+/* In IS_UTF8_CHAR_3c(p) one could use
+ * (p)[1] >= 0x80 && (p)[1] <= 0x9F
+ * if one wanted to exclude surrogates. */
+#define IS_UTF8_CHAR_3d(p) \
+ ((p)[0] >= 0xEE && (p)[0] <= 0xEF && \
+ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
+ (p)[2] >= 0x80 && (p)[2] <= 0xBF)
+#define IS_UTF8_CHAR_4a(p) \
+ ((p)[0] == 0xF0 && \
+ (p)[1] >= 0x90 && (p)[1] <= 0xBF && \
+ (p)[2] >= 0x80 && (p)[2] <= 0xBF && \
+ (p)[3] >= 0x80 && (p)[3] <= 0xBF)
+#define IS_UTF8_CHAR_4b(p) \
+ ((p)[0] >= 0xF1 && (p)[0] <= 0xF3 && \
+ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
+ (p)[2] >= 0x80 && (p)[2] <= 0xBF && \
+ (p)[3] >= 0x80 && (p)[3] <= 0xBF)
+/* In IS_UTF8_CHAR_4c(p) one could use
+ * (p)[0] == 0xF4
+ * if one wanted to stop at the Unicode limit U+10FFFF.
+ * The 0xF7 allows us to go to 0x1fffff (0x200000 would
+ * require five bytes). Not doing any further code points
+ * since that is not needed (and that would not be strict
+ * UTF-8, anyway). The "slow path" in Perl_is_utf8_char()
+ * will take care of the "extended UTF-8". */
+#define IS_UTF8_CHAR_4c(p) \
+ ((p)[0] == 0xF4 && (p)[0] <= 0xF7 && \
+ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
+ (p)[2] >= 0x80 && (p)[2] <= 0xBF && \
+ (p)[3] >= 0x80 && (p)[3] <= 0xBF)
+
+#define IS_UTF8_CHAR_3(p) \
+ (IS_UTF8_CHAR_3a(p) || \
+ IS_UTF8_CHAR_3b(p) || \
+ IS_UTF8_CHAR_3c(p) || \
+ IS_UTF8_CHAR_3d(p))
+#define IS_UTF8_CHAR_4(p) \
+ (IS_UTF8_CHAR_4a(p) || \
+ IS_UTF8_CHAR_4b(p) || \
+ IS_UTF8_CHAR_4c(p))
+
+/* IS_UTF8_CHAR(p) is strictly speaking wrong (not UTF-8) because it
+ * (1) allows UTF-8 encoded UTF-16 surrogates
+ * (2) it allows code points past U+10FFFF.
+ * The Perl_is_utf8_char() full "slow" code will handle the Perl
+ * "extended UTF-8". */
+#define IS_UTF8_CHAR(p, n) \
+ ((n) == 1 ? IS_UTF8_CHAR_1(p) : \
+ (n) == 2 ? IS_UTF8_CHAR_2(p) : \
+ (n) == 3 ? IS_UTF8_CHAR_3(p) : \
+ (n) == 4 ? IS_UTF8_CHAR_4(p) : 0)
+
+#define IS_UTF8_CHAR_FAST(n) ((n) <= 4)
+
+#endif /* IS_UTF8_CHAR() for UTF-8 */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/utfebcdic.h b/Master/tlpkg/tlperl.straw/lib/CORE/utfebcdic.h
new file mode 100755
index 00000000000..be9a19307a9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/utfebcdic.h
@@ -0,0 +1,494 @@
+/* utfebcdic.h
+ *
+ * Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2009 by Larry Wall,
+ * Nick Ing-Simmons, 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.
+ *
+ * Macros to implement UTF-EBCDIC as perl's internal encoding
+ * Taken from version 7.1 of Unicode Techical Report #16:
+ * http://www.unicode.org/unicode/reports/tr16
+ *
+ * To summarize, the way it works is:
+ * To convert an EBCDIC character to UTF-EBCDIC:
+ * 1) convert to Unicode. The table in this file that does this is for
+ * EBCDIC bytes is PL_e2a (with inverse PLa2e). The 'a' stands for
+ * ASCIIish, meaning latin1.
+ * 2) convert that to a utf8-like string called I8 with variant characters
+ * occupying multiple bytes. This step is similar to the utf8-creating
+ * step from Unicode, but the details are different. There is a chart
+ * about the bit patterns in a comment later in this file. But
+ * essentially here are the differences:
+ * UTF8 I8
+ * invariant byte starts with 0 starts with 0 or 100
+ * continuation byte starts with 10 starts with 101
+ * start byte same in both: if the code point requires N bytes,
+ * then the leading N bits are 1, followed by a 0. (No
+ * trailing 0 for the very largest possible allocation
+ * in I8, far beyond the current Unicode standard's
+ * max, as shown in the comment later in this file.)
+ * 3) Use the table published in tr16 to convert each byte from step 2 into
+ * final UTF-EBCDIC. The table in this file is PL_utf2e, and its invverse
+ * is PL_e2utf. They are constructed so that all EBCDIC invariants remain
+ * invariant, but no others do. For example, the ordinal value of 'A' is
+ * 193 in EBCDIC, and also is 193 in UTF-EBCDIC. Step 1) converts it to
+ * 65, Step 2 leaves it at 65, and Step 3 converts it back to 193. As an
+ * example of how a variant character works, take LATIN SMALL LETTER Y
+ * WITH DIAERESIS, which is typicially 0xDF in EBCDIC. Step 1 converts it
+ * to the Unicode value, 0xFF. Step 2 converts that to two bytes =
+ * 11000111 10111111 = C7 BF, and Step 3 converts those to 0x8B 0x73. The
+ * table is constructed so that the first bytes of a variant will always
+ * have its upper bit set (at least in the encodings that Perl recognizes,
+ * and probably all).
+ *
+ * If you're starting from Unicode, skip step 1. For UTF-EBCDIC to straight
+ * EBCDIC, reverse the steps.
+ *
+ * The EBCDIC invariants have been chosen to be those characters whose Unicode
+ * equivalents have ordinal numbers less than 160, that is the same characters
+ * that are expressible in ASCII, plus the C1 controls. So there are 160
+ * invariants instead of the 128 in UTF-8. (My guess is that this is because
+ * the C1 control NEL (and maybe others) is important in IBM.)
+ *
+ * The purpose of Step 3 is to make the encoding be invariant for the chosen
+ * characters. This messes up the convenient patterns found in step 2, so
+ * generally, one has to undo step 3 into a temporary to use them. However,
+ * a "shadow", or parallel table, PL_utf8skip, has been constructed so that for
+ * each byte, it says how long the sequence is if that byte were to begin it
+ *
+ * There are actually 3 slightly different UTF-EBCDIC encodings in this file,
+ * one for each of the code pages recognized by Perl. That means that there
+ * are actually three different sets of tables, one for each code page. (If
+ * Perl is compiled on platforms using other EBCDIC code pages, it may not
+ * compile, or silently mistake it for one of the three.)
+ *
+ * EBCDIC characters above 0xFF are the same as Unicode in Perl's
+ * implementation of all 3 encodings, so for those Step 1 is trivial.
+ *
+ * (Note that the entries for invariant characters are necessarily the same in
+ * PL_e2a and PLe2f, and the same for their inverses.)
+ *
+ * UTF-EBCDIC strings are the same length or longer than UTF-8 representations
+ * of the same string. The maximum code point representable as 2 bytes in
+ * UTF-EBCDIC is 0x3FFF, instead of 0x7FFF in UTF-8.
+ */
+
+START_EXTERN_C
+
+#ifdef DOINIT
+/* Indexed by encoded byte this table gives the length of the sequence.
+ Adapted from the shadow flags table in tr16.
+ The entries marked 9 in tr6 are continuation bytes and are marked
+ as length 1 here so that we can recover.
+*/
+#if '^' == 95 /* if defined(__MVS__) || defined(??) (VM/ESA?) 1047 */
+EXTCONST unsigned char PL_utf8skip[] = {
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,2,2,2,2,2,1,1,1,1,1,1,1,
+2,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,
+2,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,
+2,1,1,1,1,1,1,1,1,1,2,2,2,1,2,2,
+2,2,2,2,2,2,2,3,3,3,3,3,3,1,3,3,
+1,1,1,1,1,1,1,1,1,1,3,3,3,3,3,3,
+1,1,1,1,1,1,1,1,1,1,3,3,4,4,4,4,
+1,4,1,1,1,1,1,1,1,1,4,4,4,5,5,5,
+1,1,1,1,1,1,1,1,1,1,5,6,6,7,7,1
+};
+#endif
+
+#if '^' == 106 /* if defined(_OSD_POSIX) POSIX-BC */
+unsigned char PL_utf8skip[] = {
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,2,2,2,2,2,3,1,1,1,1,1,1,
+2,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,
+2,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,
+2,3,1,1,1,1,1,1,1,1,2,2,2,3,2,2,
+1,2,2,2,2,2,2,3,3,3,2,1,1,1,3,3,
+4,1,1,1,1,1,1,1,1,1,3,3,3,3,3,3,
+1,1,1,1,1,1,1,1,1,1,3,3,4,6,4,4,
+7,4,1,1,1,1,1,1,1,1,4,4,4,5,5,5,
+1,1,1,1,1,1,1,1,1,1,5,1,6,1,7,1
+};
+#endif
+
+#if '^' == 176 /* if defined(??) (OS/400?) 037 */
+unsigned char PL_utf8skip[] = {
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,
+1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+1,1,1,1,2,2,2,2,2,1,1,1,1,1,1,1,
+2,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,
+2,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,
+2,1,1,1,1,1,1,1,1,1,2,2,2,3,2,2,
+1,2,2,2,2,2,2,3,3,3,1,1,3,3,3,3,
+1,1,1,1,1,1,1,1,1,1,3,3,3,3,3,3,
+1,1,1,1,1,1,1,1,1,1,3,3,4,4,4,4,
+1,4,1,1,1,1,1,1,1,1,4,4,4,5,5,5,
+1,1,1,1,1,1,1,1,1,1,5,6,6,7,7,1
+};
+#endif
+
+/* Transform tables from tr16 applied after encoding to render encoding EBCDIC
+ * like, meaning that all the invariants are actually invariant, eg, that 'A'
+ * remains 'A' */
+
+#if '^' == 95 /* if defined(__MVS__) || defined(??) (VM/ESA?) 1047 */
+EXTCONST unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (IBM-1047) */
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
+ 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
+ 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
+ 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,
+ 0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0xC0, 0x4F, 0xD0, 0xA1, 0x07,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x06, 0x17, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x09, 0x0A, 0x1B,
+ 0x30, 0x31, 0x1A, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3A, 0x3B, 0x04, 0x14, 0x3E, 0xFF,
+ 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56,
+ 0x57, 0x58, 0x59, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x70, 0x71, 0x72, 0x73,
+ 0x74, 0x75, 0x76, 0x77, 0x78, 0x80, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F, 0x90, 0x9A, 0x9B, 0x9C,
+ 0x9D, 0x9E, 0x9F, 0xA0, 0xAA, 0xAB, 0xAC, 0xAE, 0xAF, 0xB0, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6,
+ 0xB7, 0xB8, 0xB9, 0xBA, 0xBB, 0xBC, 0xBE, 0xBF, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF, 0xDA, 0xDB,
+ 0xDC, 0xDD, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE
+};
+
+EXTCONST unsigned char PL_e2utf[] = { /* EBCDIC (IBM-1047) to UTF-8-mod */
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, 0xB0, 0xB1, 0xB2, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,
+ 0x2D, 0x2F, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xBB, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xBC, 0xBD, 0xBE, 0xBF, 0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xC5, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xCB,
+ 0xCC, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xCD, 0xCE, 0xCF, 0xD0, 0xD1, 0xD2,
+ 0xD3, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xD4, 0xD5, 0xD6, 0x5B, 0xD7, 0xD8,
+ 0xD9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF, 0xE0, 0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0x5D, 0xE6, 0xE7,
+ 0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED,
+ 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xEE, 0xEF, 0xF0, 0xF1, 0xF2, 0xF3,
+ 0x5C, 0xF4, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF, 0x9F
+};
+#endif /* 1047 */
+
+#if '^' == 106 /* if defined(_OSD_POSIX) POSIX-BC */
+unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (POSIX-BC) */
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
+ 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
+ 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
+ 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xBB, 0xBC, 0xBD, 0x6A, 0x6D,
+ 0x4A, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0xFB, 0x4F, 0xFD, 0xFF, 0x07,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x06, 0x17, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x09, 0x0A, 0x1B,
+ 0x30, 0x31, 0x1A, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3A, 0x3B, 0x04, 0x14, 0x3E, 0x5F,
+ 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xB0, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56,
+ 0x57, 0x58, 0x59, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xD0, 0x70, 0x71, 0x72, 0x73,
+ 0x74, 0x75, 0x76, 0x77, 0x78, 0x80, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F, 0x90, 0x9A, 0x9B, 0x9C,
+ 0x9D, 0x9E, 0x9F, 0xA0, 0xAA, 0xAB, 0xAC, 0xAE, 0xAF, 0xBA, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6,
+ 0xB7, 0xB8, 0xB9, 0xAD, 0x79, 0xA1, 0xBE, 0xBF, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF, 0xDA, 0xDB,
+ 0xDC, 0xC0, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xDD, 0xFC, 0xE0, 0xFE
+};
+
+unsigned char PL_e2utf[] = { /* EBCDIC (POSIX-BC) to UTF-8-mod */
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0x60, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, 0xB0, 0xB1, 0xB2, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x9F,
+ 0x2D, 0x2F, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0x5E, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xBC, 0xBD, 0xBE, 0xBF, 0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0xE4, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xC5, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xCB,
+ 0xCC, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xCD, 0xCE, 0xCF, 0xD0, 0xD1, 0xD2,
+ 0xD3, 0xE5, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xD4, 0xD5, 0xD6, 0xE3, 0xD7, 0xD8,
+ 0xA9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF, 0xE0, 0xE1, 0xE2, 0xD9, 0x5B, 0x5C, 0x5D, 0xE6, 0xE7,
+ 0xF1, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED,
+ 0xBB, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xEE, 0xEF, 0xF0, 0xFC, 0xF2, 0xF3,
+ 0xFE, 0xF4, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xFB, 0x7B, 0xFD, 0x7D, 0xFF, 0x7E
+};
+#endif /* POSIX-BC */
+
+#if '^' == 176 /* if defined(??) (OS/400?) 037 */
+unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (IBM-037) */
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
+ 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
+ 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
+ 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xBA, 0xE0, 0xBB, 0xB0, 0x6D,
+ 0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0xC0, 0x4F, 0xD0, 0xA1, 0x07,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x15, 0x06, 0x17, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x09, 0x0A, 0x1B,
+ 0x30, 0x31, 0x1A, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3A, 0x3B, 0x04, 0x14, 0x3E, 0xFF,
+ 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56,
+ 0x57, 0x58, 0x59, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x70, 0x71, 0x72, 0x73,
+ 0x74, 0x75, 0x76, 0x77, 0x78, 0x80, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F, 0x90, 0x9A, 0x9B, 0x9C,
+ 0x9D, 0x9E, 0x9F, 0xA0, 0xAA, 0xAB, 0xAC, 0xAE, 0xAF, 0x5F, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6,
+ 0xB7, 0xB8, 0xB9, 0xAD, 0xBD, 0xBC, 0xBE, 0xBF, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF, 0xDA, 0xDB,
+ 0xDC, 0xDD, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE
+};
+
+unsigned char PL_e2utf[] = { /* EBCDIC (IBM-037) to UTF-8-mod */
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x0A, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, 0xB0, 0xB1, 0xB2, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0xD9,
+ 0x2D, 0x2F, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xBB, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xBC, 0xBD, 0xBE, 0xBF, 0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xC5, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xCB,
+ 0xCC, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xCD, 0xCE, 0xCF, 0xD0, 0xD1, 0xD2,
+ 0xD3, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xD4, 0xD5, 0xD6, 0xE3, 0xD7, 0xD8,
+ 0x5E, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF, 0xE0, 0xE1, 0xE2, 0x5B, 0x5D, 0xE5, 0xE4, 0xE6, 0xE7,
+ 0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED,
+ 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xEE, 0xEF, 0xF0, 0xF1, 0xF2, 0xF3,
+ 0x5C, 0xF4, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF, 0x9F
+};
+#endif /* 037 */
+
+/* These tables moved from perl.h and converted to hex.
+ They map platfrom code page from/to bottom 256 codes of Unicode (i.e. iso-8859-1).
+*/
+
+#if '^' == 95 /* if defined(__MVS__) || defined(??) (VM/ESA?) 1047 */
+EXTCONST unsigned char PL_a2e[] = { /* ASCII (iso-8859-1) to EBCDIC (IBM-1047) */
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
+ 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
+ 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
+ 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,
+ 0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0xC0, 0x4F, 0xD0, 0xA1, 0x07,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x06, 0x17, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x09, 0x0A, 0x1B,
+ 0x30, 0x31, 0x1A, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3A, 0x3B, 0x04, 0x14, 0x3E, 0xFF,
+ 0x41, 0xAA, 0x4A, 0xB1, 0x9F, 0xB2, 0x6A, 0xB5, 0xBB, 0xB4, 0x9A, 0x8A, 0xB0, 0xCA, 0xAF, 0xBC,
+ 0x90, 0x8F, 0xEA, 0xFA, 0xBE, 0xA0, 0xB6, 0xB3, 0x9D, 0xDA, 0x9B, 0x8B, 0xB7, 0xB8, 0xB9, 0xAB,
+ 0x64, 0x65, 0x62, 0x66, 0x63, 0x67, 0x9E, 0x68, 0x74, 0x71, 0x72, 0x73, 0x78, 0x75, 0x76, 0x77,
+ 0xAC, 0x69, 0xED, 0xEE, 0xEB, 0xEF, 0xEC, 0xBF, 0x80, 0xFD, 0xFE, 0xFB, 0xFC, 0xBA, 0xAE, 0x59,
+ 0x44, 0x45, 0x42, 0x46, 0x43, 0x47, 0x9C, 0x48, 0x54, 0x51, 0x52, 0x53, 0x58, 0x55, 0x56, 0x57,
+ 0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xDD, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF
+};
+
+EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (IBM-1047) to ASCII (iso-8859-1) */
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xE2, 0xE4, 0xE0, 0xE1, 0xE3, 0xE5, 0xE7, 0xF1, 0xA2, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xE9, 0xEA, 0xEB, 0xE8, 0xED, 0xEE, 0xEF, 0xEC, 0xDF, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,
+ 0x2D, 0x2F, 0xC2, 0xC4, 0xC0, 0xC1, 0xC3, 0xC5, 0xC7, 0xD1, 0xA6, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xF8, 0xC9, 0xCA, 0xCB, 0xC8, 0xCD, 0xCE, 0xCF, 0xCC, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xD8, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xAB, 0xBB, 0xF0, 0xFD, 0xFE, 0xB1,
+ 0xB0, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xAA, 0xBA, 0xE6, 0xB8, 0xC6, 0xA4,
+ 0xB5, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xA1, 0xBF, 0xD0, 0x5B, 0xDE, 0xAE,
+ 0xAC, 0xA3, 0xA5, 0xB7, 0xA9, 0xA7, 0xB6, 0xBC, 0xBD, 0xBE, 0xDD, 0xA8, 0xAF, 0x5D, 0xB4, 0xD7,
+ 0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xAD, 0xF4, 0xF6, 0xF2, 0xF3, 0xF5,
+ 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xB9, 0xFB, 0xFC, 0xF9, 0xFA, 0xFF,
+ 0x5C, 0xF7, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xB2, 0xD4, 0xD6, 0xD2, 0xD3, 0xD5,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xB3, 0xDB, 0xDC, 0xD9, 0xDA, 0x9F
+};
+#endif /* 1047 */
+
+#if '^' == 106 /* if defined(_OSD_POSIX) POSIX-BC */
+EXTCONST unsigned char PL_a2e[] = { /* ASCII (ISO8859-1) to EBCDIC (POSIX-BC) */
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
+ 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
+ 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
+ 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xBB, 0xBC, 0xBD, 0x6A, 0x6D,
+ 0x4A, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0xFB, 0x4F, 0xFD, 0xFF, 0x07,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x06, 0x17, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x09, 0x0A, 0x1B,
+ 0x30, 0x31, 0x1A, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3A, 0x3B, 0x04, 0x14, 0x3E, 0x5F,
+ 0x41, 0xAA, 0xB0, 0xB1, 0x9F, 0xB2, 0xD0, 0xB5, 0x79, 0xB4, 0x9A, 0x8A, 0xBA, 0xCA, 0xAF, 0xA1,
+ 0x90, 0x8F, 0xEA, 0xFA, 0xBE, 0xA0, 0xB6, 0xB3, 0x9D, 0xDA, 0x9B, 0x8B, 0xB7, 0xB8, 0xB9, 0xAB,
+ 0x64, 0x65, 0x62, 0x66, 0x63, 0x67, 0x9E, 0x68, 0x74, 0x71, 0x72, 0x73, 0x78, 0x75, 0x76, 0x77,
+ 0xAC, 0x69, 0xED, 0xEE, 0xEB, 0xEF, 0xEC, 0xBF, 0x80, 0xE0, 0xFE, 0xDD, 0xFC, 0xAD, 0xAE, 0x59,
+ 0x44, 0x45, 0x42, 0x46, 0x43, 0x47, 0x9C, 0x48, 0x54, 0x51, 0x52, 0x53, 0x58, 0x55, 0x56, 0x57,
+ 0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xC0, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF
+};
+
+EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (POSIX-BC) to ASCII (ISO8859-1) */
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xE2, 0xE4, 0xE0, 0xE1, 0xE3, 0xE5, 0xE7, 0xF1, 0x60, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xE9, 0xEA, 0xEB, 0xE8, 0xED, 0xEE, 0xEF, 0xEC, 0xDF, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x9F,
+ 0x2D, 0x2F, 0xC2, 0xC4, 0xC0, 0xC1, 0xC3, 0xC5, 0xC7, 0xD1, 0x5E, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xF8, 0xC9, 0xCA, 0xCB, 0xC8, 0xCD, 0xCE, 0xCF, 0xCC, 0xA8, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xD8, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xAB, 0xBB, 0xF0, 0xFD, 0xFE, 0xB1,
+ 0xB0, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xAA, 0xBA, 0xE6, 0xB8, 0xC6, 0xA4,
+ 0xB5, 0xAF, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xA1, 0xBF, 0xD0, 0xDD, 0xDE, 0xAE,
+ 0xA2, 0xA3, 0xA5, 0xB7, 0xA9, 0xA7, 0xB6, 0xBC, 0xBD, 0xBE, 0xAC, 0x5B, 0x5C, 0x5D, 0xB4, 0xD7,
+ 0xF9, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xAD, 0xF4, 0xF6, 0xF2, 0xF3, 0xF5,
+ 0xA6, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xB9, 0xFB, 0xFC, 0xDB, 0xFA, 0xFF,
+ 0xD9, 0xF7, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xB2, 0xD4, 0xD6, 0xD2, 0xD3, 0xD5,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xB3, 0x7B, 0xDC, 0x7D, 0xDA, 0x7E
+};
+#endif /* POSIX-BC */
+
+#if '^' == 176 /* if defined(??) (OS/400?) 037 */
+EXTCONST unsigned char PL_a2e[] = { /* ASCII (ISO8859-1) to EBCDIC (IBM-037) */
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
+ 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
+ 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
+ 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xBA, 0xE0, 0xBB, 0xB0, 0x6D,
+ 0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0xC0, 0x4F, 0xD0, 0xA1, 0x07,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x15, 0x06, 0x17, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x09, 0x0A, 0x1B,
+ 0x30, 0x31, 0x1A, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3A, 0x3B, 0x04, 0x14, 0x3E, 0xFF,
+ 0x41, 0xAA, 0x4A, 0xB1, 0x9F, 0xB2, 0x6A, 0xB5, 0xBD, 0xB4, 0x9A, 0x8A, 0x5F, 0xCA, 0xAF, 0xBC,
+ 0x90, 0x8F, 0xEA, 0xFA, 0xBE, 0xA0, 0xB6, 0xB3, 0x9D, 0xDA, 0x9B, 0x8B, 0xB7, 0xB8, 0xB9, 0xAB,
+ 0x64, 0x65, 0x62, 0x66, 0x63, 0x67, 0x9E, 0x68, 0x74, 0x71, 0x72, 0x73, 0x78, 0x75, 0x76, 0x77,
+ 0xAC, 0x69, 0xED, 0xEE, 0xEB, 0xEF, 0xEC, 0xBF, 0x80, 0xFD, 0xFE, 0xFB, 0xFC, 0xAD, 0xAE, 0x59,
+ 0x44, 0x45, 0x42, 0x46, 0x43, 0x47, 0x9C, 0x48, 0x54, 0x51, 0x52, 0x53, 0x58, 0x55, 0x56, 0x57,
+ 0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xDD, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF
+};
+
+EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (IBM-037) to ASCII (ISO8859-1) */
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x0A, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xE2, 0xE4, 0xE0, 0xE1, 0xE3, 0xE5, 0xE7, 0xF1, 0xA2, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xE9, 0xEA, 0xEB, 0xE8, 0xED, 0xEE, 0xEF, 0xEC, 0xDF, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0xAC,
+ 0x2D, 0x2F, 0xC2, 0xC4, 0xC0, 0xC1, 0xC3, 0xC5, 0xC7, 0xD1, 0xA6, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xF8, 0xC9, 0xCA, 0xCB, 0xC8, 0xCD, 0xCE, 0xCF, 0xCC, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xD8, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xAB, 0xBB, 0xF0, 0xFD, 0xFE, 0xB1,
+ 0xB0, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xAA, 0xBA, 0xE6, 0xB8, 0xC6, 0xA4,
+ 0xB5, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xA1, 0xBF, 0xD0, 0xDD, 0xDE, 0xAE,
+ 0x5E, 0xA3, 0xA5, 0xB7, 0xA9, 0xA7, 0xB6, 0xBC, 0xBD, 0xBE, 0x5B, 0x5D, 0xAF, 0xA8, 0xB4, 0xD7,
+ 0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xAD, 0xF4, 0xF6, 0xF2, 0xF3, 0xF5,
+ 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xB9, 0xFB, 0xFC, 0xF9, 0xFA, 0xFF,
+ 0x5C, 0xF7, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xB2, 0xD4, 0xD6, 0xD2, 0xD3, 0xD5,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xB3, 0xDB, 0xDC, 0xD9, 0xDA, 0x9F
+};
+#endif /* 037 */
+
+#else
+EXTCONST unsigned char PL_utf8skip[];
+EXTCONST unsigned char PL_e2utf[];
+EXTCONST unsigned char PL_utf2e[];
+EXTCONST unsigned char PL_e2a[];
+EXTCONST unsigned char PL_a2e[];
+#endif
+
+END_EXTERN_C
+
+#define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)]
+
+/* EBCDIC-happy ways of converting native code to UTF-8 */
+
+/* Native to iso-8859-1 */
+#define NATIVE_TO_ASCII(ch) PL_e2a[(U8)(ch)]
+#define ASCII_TO_NATIVE(ch) PL_a2e[(U8)(ch)]
+/* Transform after encoding */
+#define NATIVE_TO_UTF(ch) PL_e2utf[(U8)(ch)]
+#define UTF_TO_NATIVE(ch) PL_utf2e[(U8)(ch)]
+/* Transform in wide UV char space */
+#define NATIVE_TO_UNI(ch) (((ch) > 255) ? (ch) : NATIVE_TO_ASCII(ch))
+#define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
+/* Transform in invariant..byte space */
+#define NATIVE_TO_NEED(enc,ch) ((enc) ? UTF_TO_NATIVE(NATIVE_TO_ASCII(ch)) : (ch))
+#define ASCII_TO_NEED(enc,ch) ((enc) ? UTF_TO_NATIVE(ch) : ASCII_TO_NATIVE(ch))
+
+/*
+ * Note: we should try and be careful never to call the isXXX_utf8() functions
+ * unless we're pretty sure we've seen the beginning of a UTF-EBCDIC character
+ * Otherwise we risk loading in the heavy-duty swash_init and swash_fetch
+ * routines unnecessarily.
+ */
+
+#define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || UTF8_IS_INVARIANT(*p))) \
+ ? isIDFIRST(*(p)) \
+ : isIDFIRST_utf8((const U8*)p))
+#define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || UTF8_IS_INVARIANT(*p))) \
+ ? isALNUM(*(p)) \
+ : isALNUM_utf8((const U8*)p))
+
+/*
+ The following table is adapted from tr16, it shows UTF-8-mod encoding of Unicode code points.
+
+ Unicode Bit pattern 1st Byte 2nd Byte 3rd Byte 4th Byte 5th Byte 6th Byte 7th byte
+ U+0000..U+007F 000000000xxxxxxx 0xxxxxxx
+ U+0080..U+009F 00000000100xxxxx 100xxxxx
+ U+00A0..U+00FF 00000000yyyxxxxx 11000yyy 101xxxxx
+
+ U+00A0..U+03FF 000000yyyyyxxxxx 110yyyyy 101xxxxx
+ U+0400..U+3FFF 00zzzzyyyyyxxxxx 1110zzzz 101yyyyy 101xxxxx
+ U+4000..U+3FFFF 0wwwzzzzzyyyyyxxxxx 11110www 101zzzzz 101yyyyy 101xxxxx
+ U+40000..U+3FFFFF 0vvwwwwwzzzzzyyyyyxxxxx 111110vv 101wwwww 101zzzzz 101yyyyy 101xxxxx
+ U+400000..U+3FFFFFF 0uvvvvvwwwwwzzzzzyyyyyxxxxx 1111110u 101vvvvv 101wwwww 101zzzzz 101yyyyy 101xxxxx
+ U+4000000..U+7FFFFFFF 0tuuuuuvvvvvwwwwwzzzzzyyyyyxxxxx 1111111t 101uuuuu 101vvvvv 101wwwww 101zzzzz 101yyyyy 101xxxxx
+
+ Note: The UTF-8-Mod transformation is valid for UCS-4 values X'0' to
+ X'7FFFFFFF' (the full extent of ISO/IEC 10646 coding space).
+
+ */
+
+#define UNISKIP(uv) ( (uv) < 0xA0 ? 1 : \
+ (uv) < 0x400 ? 2 : \
+ (uv) < 0x4000 ? 3 : \
+ (uv) < 0x40000 ? 4 : \
+ (uv) < 0x400000 ? 5 : \
+ (uv) < 0x4000000 ? 6 : 7 )
+
+
+#define UNI_IS_INVARIANT(c) ((c) < 0xA0)
+/* UTF-EBCDIC sematic macros - transform back into UTF-8-Mod and then compare */
+#define NATIVE_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_ASCII(c))
+#define UTF8_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_UTF(c))
+#define UTF8_IS_START(c) (NATIVE_TO_UTF(c) >= 0xA0 && (NATIVE_TO_UTF(c) & 0xE0) != 0xA0)
+#define UTF8_IS_CONTINUATION(c) ((NATIVE_TO_UTF(c) & 0xE0) == 0xA0)
+#define UTF8_IS_CONTINUED(c) (NATIVE_TO_UTF(c) >= 0xA0)
+#define UTF8_IS_DOWNGRADEABLE_START(c) (NATIVE_TO_UTF(c) >= 0xA0 && (NATIVE_TO_UTF(c) & 0xF8) == 0xC0)
+
+#define UTF_START_MARK(len) ((len > 7) ? 0xFF : ((U8)(0xFE << (7-len))))
+#define UTF_START_MASK(len) ((len >= 6) ? 0x01 : (0x1F >> (len-2)))
+#define UTF_CONTINUATION_MARK 0xA0
+#define UTF_CONTINUATION_MASK ((U8)0x1f)
+#define UTF_ACCUMULATION_SHIFT 5
+
+#define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT)|(NATIVE_TO_UTF(new) & UTF_CONTINUATION_MASK))
+
+/* UTF-EBCDIC encode a downgradeable value */
+#define UTF8_EIGHT_BIT_HI(c) UTF_TO_NATIVE((((U8)(c))>>UTF_ACCUMULATION_SHIFT)|UTF_START_MARK(2))
+#define UTF8_EIGHT_BIT_LO(c) UTF_TO_NATIVE(((((U8)(c)))&UTF_CONTINUATION_MASK)|UTF_CONTINUATION_MARK)
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/util.h b/Master/tlpkg/tlperl.straw/lib/CORE/util.h
new file mode 100755
index 00000000000..db91c18ee8d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/util.h
@@ -0,0 +1,53 @@
+/* util.h
+ *
+ * Copyright (C) 1991, 1992, 1993, 1999, 2001, 2002, 2003, 2004, 2005,
+ * 2007, by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifdef VMS
+# define PERL_FILE_IS_ABSOLUTE(f) \
+ (*(f) == '/' \
+ || (strchr(f,':') \
+ || ((*(f) == '[' || *(f) == '<') \
+ && (isALNUM((f)[1]) || strchr("$-_]>",(f)[1])))))
+
+#else /* !VMS */
+# if defined(WIN32) || defined(__CYGWIN__)
+# define PERL_FILE_IS_ABSOLUTE(f) \
+ (*(f) == '/' || *(f) == '\\' /* UNC/rooted path */ \
+ || ((f)[0] && (f)[1] == ':')) /* drive name */
+# else /* !WIN32 */
+# ifdef NETWARE
+# define PERL_FILE_IS_ABSOLUTE(f) \
+ (((f)[0] && (f)[1] == ':') /* drive name */ \
+ || ((f)[0] == '\\' && (f)[1] == '\\') /* UNC path */ \
+ || ((f)[3] == ':')) /* volume name, currently only sys */
+# else /* !NETWARE */
+# if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
+# define PERL_FILE_IS_ABSOLUTE(f) \
+ (*(f) == '/' \
+ || ((f)[0] && (f)[1] == ':')) /* drive name */
+# else /* NEITHER DOSISH NOR EPOCISH NOR SYMBIANISH */
+# ifdef MACOS_TRADITIONAL
+# define PERL_FILE_IS_ABSOLUTE(f) (strchr(f, ':') && *(f) != ':')
+# else /* !MACOS_TRADITIONAL */
+# define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/')
+# endif /* MACOS_TRADITIONAL */
+# endif /* DOSISH */
+# endif /* NETWARE */
+# endif /* WIN32 */
+#endif /* VMS */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/uudmap.h b/Master/tlpkg/tlperl.straw/lib/CORE/uudmap.h
new file mode 100755
index 00000000000..41341665dd2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/uudmap.h
@@ -0,0 +1,18 @@
+{
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/vdir.h b/Master/tlpkg/tlperl.straw/lib/CORE/vdir.h
new file mode 100755
index 00000000000..db7ec8417fe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/vdir.h
@@ -0,0 +1,726 @@
+/* vdir.h
+ *
+ * (c) 1999 Microsoft Corporation. All rights reserved.
+ * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+
+#ifndef ___VDir_H___
+#define ___VDir_H___
+
+/*
+ * Allow one slot for each possible drive letter
+ * and one additional slot for a UNC name
+ */
+const int driveCount = ('Z'-'A')+1+1;
+
+class VDir
+{
+public:
+ VDir(int bManageDir = 1);
+ ~VDir() {};
+
+ void Init(VDir* pDir, VMem *pMem);
+ void SetDefaultA(char const *pDefault);
+ void SetDefaultW(WCHAR const *pDefault);
+ char* MapPathA(const char *pInName);
+ WCHAR* MapPathW(const WCHAR *pInName);
+ int SetCurrentDirectoryA(char *lpBuffer);
+ int SetCurrentDirectoryW(WCHAR *lpBuffer);
+ inline int GetDefault(void) { return nDefault; };
+
+ inline char* GetCurrentDirectoryA(int dwBufSize, char *lpBuffer)
+ {
+ char* ptr = dirTableA[nDefault];
+ while (--dwBufSize)
+ {
+ if ((*lpBuffer++ = *ptr++) == '\0')
+ break;
+ }
+ *lpBuffer = '\0';
+ return /* unused */ NULL;
+ };
+ inline WCHAR* GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer)
+ {
+ WCHAR* ptr = dirTableW[nDefault];
+ while (--dwBufSize)
+ {
+ if ((*lpBuffer++ = *ptr++) == '\0')
+ break;
+ }
+ *lpBuffer = '\0';
+ return /* unused */ NULL;
+ };
+
+ DWORD CalculateEnvironmentSpace(void);
+ LPSTR BuildEnvironmentSpace(LPSTR lpStr);
+
+protected:
+ int SetDirA(char const *pPath, int index);
+ int SetDirW(WCHAR const *pPath, int index);
+ void FromEnvA(char *pEnv, int index);
+ void FromEnvW(WCHAR *pEnv, int index);
+
+ inline const char *GetDefaultDirA(void)
+ {
+ return dirTableA[nDefault];
+ };
+ inline void SetDefaultDirA(char const *pPath, int index)
+ {
+ SetDirA(pPath, index);
+ nDefault = index;
+ };
+ inline const WCHAR *GetDefaultDirW(void)
+ {
+ return dirTableW[nDefault];
+ };
+ inline void SetDefaultDirW(WCHAR const *pPath, int index)
+ {
+ SetDirW(pPath, index);
+ nDefault = index;
+ };
+ inline const char *GetDirA(int index)
+ {
+ char *ptr = dirTableA[index];
+ if (!ptr) {
+ /* simulate the existance of this drive */
+ ptr = szLocalBufferA;
+ ptr[0] = 'A' + index;
+ ptr[1] = ':';
+ ptr[2] = '\\';
+ ptr[3] = 0;
+ }
+ return ptr;
+ };
+ inline const WCHAR *GetDirW(int index)
+ {
+ WCHAR *ptr = dirTableW[index];
+ if (!ptr) {
+ /* simulate the existance of this drive */
+ ptr = szLocalBufferW;
+ ptr[0] = 'A' + index;
+ ptr[1] = ':';
+ ptr[2] = '\\';
+ ptr[3] = 0;
+ }
+ return ptr;
+ };
+
+ inline int DriveIndex(char chr)
+ {
+ if (chr == '\\' || chr == '/')
+ return ('Z'-'A')+1;
+ return (chr | 0x20)-'a';
+ };
+
+ VMem *pMem;
+ int nDefault, bManageDirectory;
+ char *dirTableA[driveCount];
+ char szLocalBufferA[MAX_PATH+1];
+ WCHAR *dirTableW[driveCount];
+ WCHAR szLocalBufferW[MAX_PATH+1];
+};
+
+
+VDir::VDir(int bManageDir /* = 1 */)
+{
+ nDefault = 0;
+ bManageDirectory = bManageDir;
+ memset(dirTableA, 0, sizeof(dirTableA));
+ memset(dirTableW, 0, sizeof(dirTableW));
+}
+
+void VDir::Init(VDir* pDir, VMem *p)
+{
+ int index;
+
+ pMem = p;
+ if (pDir) {
+ for (index = 0; index < driveCount; ++index) {
+ SetDirW(pDir->GetDirW(index), index);
+ }
+ nDefault = pDir->GetDefault();
+ }
+ else {
+ int bSave = bManageDirectory;
+ DWORD driveBits = GetLogicalDrives();
+ OSVERSIONINFO osver;
+
+ memset(&osver, 0, sizeof(osver));
+ osver.dwOSVersionInfoSize = sizeof(osver);
+ GetVersionEx(&osver);
+
+ bManageDirectory = 0;
+ if (osver.dwMajorVersion < 5) {
+ char szBuffer[MAX_PATH*driveCount];
+ if (GetLogicalDriveStringsA(sizeof(szBuffer), szBuffer)) {
+ char* pEnv = (char*)GetEnvironmentStringsA();
+ char* ptr = szBuffer;
+ for (index = 0; index < driveCount; ++index) {
+ if (driveBits & (1<<index)) {
+ ptr += SetDirA(ptr, index) + 1;
+ FromEnvA(pEnv, index);
+ }
+ }
+ FreeEnvironmentStringsA(pEnv);
+ }
+ SetDefaultA(".");
+ }
+ else { /* Windows 2000 or later */
+ WCHAR szBuffer[MAX_PATH*driveCount];
+ if (GetLogicalDriveStringsW(sizeof(szBuffer), szBuffer)) {
+ WCHAR* pEnv = GetEnvironmentStringsW();
+ WCHAR* ptr = szBuffer;
+ for (index = 0; index < driveCount; ++index) {
+ if (driveBits & (1<<index)) {
+ ptr += SetDirW(ptr, index) + 1;
+ FromEnvW(pEnv, index);
+ }
+ }
+ FreeEnvironmentStringsW(pEnv);
+ }
+ SetDefaultW(L".");
+ }
+ bManageDirectory = bSave;
+ }
+}
+
+int VDir::SetDirA(char const *pPath, int index)
+{
+ char chr, *ptr;
+ int length = 0;
+ WCHAR wBuffer[MAX_PATH+1];
+ if (index < driveCount && pPath != NULL) {
+ length = strlen(pPath);
+ pMem->Free(dirTableA[index]);
+ ptr = dirTableA[index] = (char*)pMem->Malloc(length+2);
+ if (ptr != NULL) {
+ strcpy(ptr, pPath);
+ ptr += length-1;
+ chr = *ptr++;
+ if (chr != '\\' && chr != '/') {
+ *ptr++ = '\\';
+ *ptr = '\0';
+ }
+ MultiByteToWideChar(CP_ACP, 0, dirTableA[index], -1,
+ wBuffer, (sizeof(wBuffer)/sizeof(WCHAR)));
+ length = wcslen(wBuffer);
+ pMem->Free(dirTableW[index]);
+ dirTableW[index] = (WCHAR*)pMem->Malloc((length+1)*2);
+ if (dirTableW[index] != NULL) {
+ wcscpy(dirTableW[index], wBuffer);
+ }
+ }
+ }
+
+ if(bManageDirectory)
+ ::SetCurrentDirectoryA(pPath);
+
+ return length;
+}
+
+void VDir::FromEnvA(char *pEnv, int index)
+{ /* gets the directory for index from the environment variable. */
+ while (*pEnv != '\0') {
+ if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index)) {
+ SetDirA(&pEnv[4], index);
+ break;
+ }
+ else
+ pEnv += strlen(pEnv)+1;
+ }
+}
+
+void VDir::FromEnvW(WCHAR *pEnv, int index)
+{ /* gets the directory for index from the environment variable. */
+ while (*pEnv != '\0') {
+ if ((pEnv[0] == '=') && (DriveIndex((char)pEnv[1]) == index)) {
+ SetDirW(&pEnv[4], index);
+ break;
+ }
+ else
+ pEnv += wcslen(pEnv)+1;
+ }
+}
+
+void VDir::SetDefaultA(char const *pDefault)
+{
+ char szBuffer[MAX_PATH+1];
+ char *pPtr;
+
+ if (GetFullPathNameA(pDefault, sizeof(szBuffer), szBuffer, &pPtr)) {
+ if (*pDefault != '.' && pPtr != NULL)
+ *pPtr = '\0';
+
+ SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0]));
+ }
+}
+
+int VDir::SetDirW(WCHAR const *pPath, int index)
+{
+ WCHAR chr, *ptr;
+ int length = 0;
+ if (index < driveCount && pPath != NULL) {
+ length = wcslen(pPath);
+ pMem->Free(dirTableW[index]);
+ ptr = dirTableW[index] = (WCHAR*)pMem->Malloc((length+2)*2);
+ if (ptr != NULL) {
+ char *ansi;
+ wcscpy(ptr, pPath);
+ ptr += length-1;
+ chr = *ptr++;
+ if (chr != '\\' && chr != '/') {
+ *ptr++ = '\\';
+ *ptr = '\0';
+ }
+ ansi = win32_ansipath(dirTableW[index]);
+ length = strlen(ansi);
+ pMem->Free(dirTableA[index]);
+ dirTableA[index] = (char*)pMem->Malloc(length+1);
+ if (dirTableA[index] != NULL) {
+ strcpy(dirTableA[index], ansi);
+ }
+ win32_free(ansi);
+ }
+ }
+
+ if(bManageDirectory)
+ ::SetCurrentDirectoryW(pPath);
+
+ return length;
+}
+
+void VDir::SetDefaultW(WCHAR const *pDefault)
+{
+ WCHAR szBuffer[MAX_PATH+1];
+ WCHAR *pPtr;
+
+ if (GetFullPathNameW(pDefault, (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr)) {
+ if (*pDefault != '.' && pPtr != NULL)
+ *pPtr = '\0';
+
+ SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0]));
+ }
+}
+
+inline BOOL IsPathSep(char ch)
+{
+ return (ch == '\\' || ch == '/');
+}
+
+inline void DoGetFullPathNameA(char* lpBuffer, DWORD dwSize, char* Dest)
+{
+ char *pPtr;
+
+ /*
+ * On WinNT GetFullPathName does not fail, (or at least always
+ * succeeds when the drive is valid) WinNT does set *Dest to NULL
+ * On Win98 GetFullPathName will set last error if it fails, but
+ * does not touch *Dest
+ */
+ *Dest = '\0';
+ GetFullPathNameA(lpBuffer, dwSize, Dest, &pPtr);
+}
+
+inline bool IsSpecialFileName(const char* pName)
+{
+ /* specical file names are devices that the system can open
+ * these include AUX, CON, NUL, PRN, COMx, LPTx, CLOCK$, CONIN$, CONOUT$
+ * (x is a single digit, and names are case-insensitive)
+ */
+ char ch = (pName[0] & ~0x20);
+ switch (ch)
+ {
+ case 'A': /* AUX */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && !pName[3])
+ return true;
+ break;
+ case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */
+ ch = (pName[1] & ~0x20);
+ switch (ch)
+ {
+ case 'L': /* CLOCK$ */
+ if (((pName[2] & ~0x20) == 'O')
+ && ((pName[3] & ~0x20) == 'C')
+ && ((pName[4] & ~0x20) == 'K')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ break;
+ case 'O': /* COMx, CON, CONIN$ CONOUT$ */
+ if ((pName[2] & ~0x20) == 'M') {
+ if ((pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ }
+ else if ((pName[2] & ~0x20) == 'N') {
+ if (!pName[3])
+ return true;
+ else if ((pName[3] & ~0x20) == 'I') {
+ if (((pName[4] & ~0x20) == 'N')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ }
+ else if ((pName[3] & ~0x20) == 'O') {
+ if (((pName[4] & ~0x20) == 'U')
+ && ((pName[5] & ~0x20) == 'T')
+ && (pName[6] == '$')
+ && !pName[7])
+ return true;
+ }
+ }
+ break;
+ }
+ break;
+ case 'L': /* LPTx */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && (pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ break;
+ case 'N': /* NUL */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'L')
+ && !pName[3])
+ return true;
+ break;
+ case 'P': /* PRN */
+ if (((pName[1] & ~0x20) == 'R')
+ && ((pName[2] & ~0x20) == 'N')
+ && !pName[3])
+ return true;
+ break;
+ }
+ return false;
+}
+
+char *VDir::MapPathA(const char *pInName)
+{ /*
+ * possiblities -- relative path or absolute path with or without drive letter
+ * OR UNC name
+ */
+ char szBuffer[(MAX_PATH+1)*2];
+ char szlBuf[MAX_PATH+1];
+ int length = strlen(pInName);
+
+ if (!length)
+ return (char*)pInName;
+
+ if (length > MAX_PATH) {
+ strncpy(szlBuf, pInName, MAX_PATH);
+ if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) {
+ /* absolute path - reduce length by 2 for drive specifier */
+ szlBuf[MAX_PATH-2] = '\0';
+ }
+ else
+ szlBuf[MAX_PATH] = '\0';
+ pInName = szlBuf;
+ }
+ /* strlen(pInName) is now <= MAX_PATH */
+
+ if (pInName[1] == ':') {
+ /* has drive letter */
+ if (IsPathSep(pInName[2])) {
+ /* absolute with drive letter */
+ DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ else {
+ /* relative path with drive letter */
+ strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+ strcat(szBuffer, &pInName[2]);
+ if(strlen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ }
+ else {
+ /* no drive letter */
+ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ /* UNC name */
+ DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ else {
+ strcpy(szBuffer, GetDefaultDirA());
+ if (IsPathSep(pInName[0])) {
+ /* absolute path */
+ strcpy(&szBuffer[2], pInName);
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ else {
+ /* relative path */
+ if (IsSpecialFileName(pInName)) {
+ return (char*)pInName;
+ }
+ else {
+ strcat(szBuffer, pInName);
+ if (strlen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ }
+ }
+ }
+
+ return szLocalBufferA;
+}
+
+int VDir::SetCurrentDirectoryA(char *lpBuffer)
+{
+ char *pPtr;
+ int length, nRet = -1;
+
+ pPtr = MapPathA(lpBuffer);
+ length = strlen(pPtr);
+ if(length > 3 && IsPathSep(pPtr[length-1])) {
+ /* don't remove the trailing slash from 'x:\' */
+ pPtr[length-1] = '\0';
+ }
+
+ DWORD r = GetFileAttributesA(pPtr);
+ if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY))
+ {
+ char szBuffer[(MAX_PATH+1)*2];
+ DoGetFullPathNameA(pPtr, sizeof(szBuffer), szBuffer);
+ SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0]));
+ nRet = 0;
+ }
+
+ return nRet;
+}
+
+DWORD VDir::CalculateEnvironmentSpace(void)
+{ /* the current directory environment strings are stored as '=D:=d:\path' */
+ int index;
+ DWORD dwSize = 0;
+ for (index = 0; index < driveCount; ++index) {
+ if (dirTableA[index] != NULL) {
+ dwSize += strlen(dirTableA[index]) + 5; /* add 1 for trailing NULL and 4 for '=D:=' */
+ }
+ }
+ return dwSize;
+}
+
+LPSTR VDir::BuildEnvironmentSpace(LPSTR lpStr)
+{ /* store the current directory environment strings as '=D:=d:\path' */
+ int index, length;
+ LPSTR lpDirStr;
+ for (index = 0; index < driveCount; ++index) {
+ lpDirStr = dirTableA[index];
+ if (lpDirStr != NULL) {
+ lpStr[0] = '=';
+ lpStr[1] = lpDirStr[0];
+ lpStr[2] = '\0';
+ CharUpper(&lpStr[1]);
+ lpStr[2] = ':';
+ lpStr[3] = '=';
+ strcpy(&lpStr[4], lpDirStr);
+ length = strlen(lpDirStr);
+ lpStr += length + 5; /* add 1 for trailing NULL and 4 for '=D:=' */
+ if (length > 3 && IsPathSep(lpStr[-2])) {
+ lpStr[-2] = '\0'; /* remove the trailing path separator */
+ --lpStr;
+ }
+ }
+ }
+ return lpStr;
+}
+
+inline BOOL IsPathSep(WCHAR ch)
+{
+ return (ch == '\\' || ch == '/');
+}
+
+inline void DoGetFullPathNameW(WCHAR* lpBuffer, DWORD dwSize, WCHAR* Dest)
+{
+ WCHAR *pPtr;
+
+ /*
+ * On WinNT GetFullPathName does not fail, (or at least always
+ * succeeds when the drive is valid) WinNT does set *Dest to NULL
+ * On Win98 GetFullPathName will set last error if it fails, but
+ * does not touch *Dest
+ */
+ *Dest = '\0';
+ GetFullPathNameW(lpBuffer, dwSize, Dest, &pPtr);
+}
+
+inline bool IsSpecialFileName(const WCHAR* pName)
+{
+ /* specical file names are devices that the system can open
+ * these include AUX, CON, NUL, PRN, COMx, LPTx, CLOCK$, CONIN$, CONOUT$
+ * (x is a single digit, and names are case-insensitive)
+ */
+ WCHAR ch = (pName[0] & ~0x20);
+ switch (ch)
+ {
+ case 'A': /* AUX */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && !pName[3])
+ return true;
+ break;
+ case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */
+ ch = (pName[1] & ~0x20);
+ switch (ch)
+ {
+ case 'L': /* CLOCK$ */
+ if (((pName[2] & ~0x20) == 'O')
+ && ((pName[3] & ~0x20) == 'C')
+ && ((pName[4] & ~0x20) == 'K')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ break;
+ case 'O': /* COMx, CON, CONIN$ CONOUT$ */
+ if ((pName[2] & ~0x20) == 'M') {
+ if ((pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ }
+ else if ((pName[2] & ~0x20) == 'N') {
+ if (!pName[3])
+ return true;
+ else if ((pName[3] & ~0x20) == 'I') {
+ if (((pName[4] & ~0x20) == 'N')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ }
+ else if ((pName[3] & ~0x20) == 'O') {
+ if (((pName[4] & ~0x20) == 'U')
+ && ((pName[5] & ~0x20) == 'T')
+ && (pName[6] == '$')
+ && !pName[7])
+ return true;
+ }
+ }
+ break;
+ }
+ break;
+ case 'L': /* LPTx */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && (pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ break;
+ case 'N': /* NUL */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'L')
+ && !pName[3])
+ return true;
+ break;
+ case 'P': /* PRN */
+ if (((pName[1] & ~0x20) == 'R')
+ && ((pName[2] & ~0x20) == 'N')
+ && !pName[3])
+ return true;
+ break;
+ }
+ return false;
+}
+
+WCHAR* VDir::MapPathW(const WCHAR *pInName)
+{ /*
+ * possiblities -- relative path or absolute path with or without drive letter
+ * OR UNC name
+ */
+ WCHAR szBuffer[(MAX_PATH+1)*2];
+ WCHAR szlBuf[MAX_PATH+1];
+ int length = wcslen(pInName);
+
+ if (!length)
+ return (WCHAR*)pInName;
+
+ if (length > MAX_PATH) {
+ wcsncpy(szlBuf, pInName, MAX_PATH);
+ if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) {
+ /* absolute path - reduce length by 2 for drive specifier */
+ szlBuf[MAX_PATH-2] = '\0';
+ }
+ else
+ szlBuf[MAX_PATH] = '\0';
+ pInName = szlBuf;
+ }
+ /* strlen(pInName) is now <= MAX_PATH */
+
+ if (pInName[1] == ':') {
+ /* has drive letter */
+ if (IsPathSep(pInName[2])) {
+ /* absolute with drive letter */
+ DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ else {
+ /* relative path with drive letter */
+ wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+ wcscat(szBuffer, &pInName[2]);
+ if(wcslen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ }
+ else {
+ /* no drive letter */
+ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ /* UNC name */
+ DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ else {
+ wcscpy(szBuffer, GetDefaultDirW());
+ if (IsPathSep(pInName[0])) {
+ /* absolute path */
+ wcscpy(&szBuffer[2], pInName);
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ else {
+ /* relative path */
+ if (IsSpecialFileName(pInName)) {
+ return (WCHAR*)pInName;
+ }
+ else {
+ wcscat(szBuffer, pInName);
+ if (wcslen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ }
+ }
+ }
+ return szLocalBufferW;
+}
+
+int VDir::SetCurrentDirectoryW(WCHAR *lpBuffer)
+{
+ WCHAR *pPtr;
+ int length, nRet = -1;
+
+ pPtr = MapPathW(lpBuffer);
+ length = wcslen(pPtr);
+ if(length > 3 && IsPathSep(pPtr[length-1])) {
+ /* don't remove the trailing slash from 'x:\' */
+ pPtr[length-1] = '\0';
+ }
+
+ DWORD r = GetFileAttributesW(pPtr);
+ if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY))
+ {
+ WCHAR wBuffer[(MAX_PATH+1)*2];
+ DoGetFullPathNameW(pPtr, (sizeof(wBuffer)/sizeof(WCHAR)), wBuffer);
+ SetDefaultDirW(wBuffer, DriveIndex((char)wBuffer[0]));
+ nRet = 0;
+ }
+
+ return nRet;
+}
+
+#endif /* ___VDir_H___ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/vmem.h b/Master/tlpkg/tlperl.straw/lib/CORE/vmem.h
new file mode 100755
index 00000000000..460f55793a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/vmem.h
@@ -0,0 +1,1259 @@
+/* vmem.h
+ *
+ * (c) 1999 Microsoft Corporation. All rights reserved.
+ * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * Options:
+ *
+ * Defining _USE_MSVCRT_MEM_ALLOC will cause all memory allocations
+ * to be forwarded to MSVCRT.DLL. Defining _USE_LINKED_LIST as well will
+ * track all allocations in a doubly linked list, so that the host can
+ * free all memory allocated when it goes away.
+ * If _USE_MSVCRT_MEM_ALLOC is not defined then Knuth's boundary tag algorithm
+ * is used; defining _USE_BUDDY_BLOCKS will use Knuth's algorithm R
+ * (Buddy system reservation)
+ *
+ */
+
+#ifndef ___VMEM_H_INC___
+#define ___VMEM_H_INC___
+
+#ifndef UNDER_CE
+#define _USE_MSVCRT_MEM_ALLOC
+#endif
+#define _USE_LINKED_LIST
+
+// #define _USE_BUDDY_BLOCKS
+
+// #define _DEBUG_MEM
+#ifdef _DEBUG_MEM
+#define ASSERT(f) if(!(f)) DebugBreak();
+
+inline void MEMODS(char *str)
+{
+ OutputDebugString(str);
+ OutputDebugString("\n");
+}
+
+inline void MEMODSlx(char *str, long x)
+{
+ char szBuffer[512];
+ sprintf(szBuffer, "%s %lx\n", str, x);
+ OutputDebugString(szBuffer);
+}
+
+#define WALKHEAP() WalkHeap(0)
+#define WALKHEAPTRACE() WalkHeap(1)
+
+#else
+
+#define ASSERT(f)
+#define MEMODS(x)
+#define MEMODSlx(x, y)
+#define WALKHEAP()
+#define WALKHEAPTRACE()
+
+#endif
+
+#ifdef _USE_MSVCRT_MEM_ALLOC
+
+#ifndef _USE_LINKED_LIST
+// #define _USE_LINKED_LIST
+#endif
+
+/*
+ * Pass all memory requests throught to msvcrt.dll
+ * optionaly track by using a doubly linked header
+ */
+
+typedef void (*LPFREE)(void *block);
+typedef void* (*LPMALLOC)(size_t size);
+typedef void* (*LPREALLOC)(void *block, size_t size);
+#ifdef _USE_LINKED_LIST
+class VMem;
+typedef struct _MemoryBlockHeader* PMEMORY_BLOCK_HEADER;
+typedef struct _MemoryBlockHeader {
+ PMEMORY_BLOCK_HEADER pNext;
+ PMEMORY_BLOCK_HEADER pPrev;
+ VMem *owner;
+} MEMORY_BLOCK_HEADER, *PMEMORY_BLOCK_HEADER;
+#endif
+
+class VMem
+{
+public:
+ VMem();
+ ~VMem();
+ virtual void* Malloc(size_t size);
+ virtual void* Realloc(void* pMem, size_t size);
+ virtual void Free(void* pMem);
+ virtual void GetLock(void);
+ virtual void FreeLock(void);
+ virtual int IsLocked(void);
+ virtual long Release(void);
+ virtual long AddRef(void);
+
+ inline BOOL CreateOk(void)
+ {
+ return TRUE;
+ };
+
+protected:
+#ifdef _USE_LINKED_LIST
+ void LinkBlock(PMEMORY_BLOCK_HEADER ptr)
+ {
+ PMEMORY_BLOCK_HEADER next = m_Dummy.pNext;
+ m_Dummy.pNext = ptr;
+ ptr->pPrev = &m_Dummy;
+ ptr->pNext = next;
+ ptr->owner = this;
+ next->pPrev = ptr;
+ }
+ void UnlinkBlock(PMEMORY_BLOCK_HEADER ptr)
+ {
+ PMEMORY_BLOCK_HEADER next = ptr->pNext;
+ PMEMORY_BLOCK_HEADER prev = ptr->pPrev;
+ prev->pNext = next;
+ next->pPrev = prev;
+ }
+
+ MEMORY_BLOCK_HEADER m_Dummy;
+#endif
+
+ long m_lRefCount; // number of current users
+ CRITICAL_SECTION m_cs; // access lock
+ HINSTANCE m_hLib;
+ LPFREE m_pfree;
+ LPMALLOC m_pmalloc;
+ LPREALLOC m_prealloc;
+};
+
+VMem::VMem()
+{
+ m_lRefCount = 1;
+ InitializeCriticalSection(&m_cs);
+#ifdef _USE_LINKED_LIST
+ m_Dummy.pNext = m_Dummy.pPrev = &m_Dummy;
+ m_Dummy.owner = this;
+#endif
+ m_hLib = LoadLibrary("msvcrt.dll");
+ if (m_hLib) {
+ m_pfree = (LPFREE)GetProcAddress(m_hLib, "free");
+ m_pmalloc = (LPMALLOC)GetProcAddress(m_hLib, "malloc");
+ m_prealloc = (LPREALLOC)GetProcAddress(m_hLib, "realloc");
+ }
+}
+
+VMem::~VMem(void)
+{
+#ifdef _USE_LINKED_LIST
+ while (m_Dummy.pNext != &m_Dummy) {
+ Free(m_Dummy.pNext+1);
+ }
+#endif
+ if (m_hLib)
+ FreeLibrary(m_hLib);
+ DeleteCriticalSection(&m_cs);
+}
+
+void* VMem::Malloc(size_t size)
+{
+#ifdef _USE_LINKED_LIST
+ GetLock();
+ PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)m_pmalloc(size+sizeof(MEMORY_BLOCK_HEADER));
+ if (!ptr) {
+ FreeLock();
+ return NULL;
+ }
+ LinkBlock(ptr);
+ FreeLock();
+ return (ptr+1);
+#else
+ return m_pmalloc(size);
+#endif
+}
+
+void* VMem::Realloc(void* pMem, size_t size)
+{
+#ifdef _USE_LINKED_LIST
+ if (!pMem)
+ return Malloc(size);
+
+ if (!size) {
+ Free(pMem);
+ return NULL;
+ }
+
+ GetLock();
+ PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER));
+ UnlinkBlock(ptr);
+ ptr = (PMEMORY_BLOCK_HEADER)m_prealloc(ptr, size+sizeof(MEMORY_BLOCK_HEADER));
+ if (!ptr) {
+ FreeLock();
+ return NULL;
+ }
+ LinkBlock(ptr);
+ FreeLock();
+
+ return (ptr+1);
+#else
+ return m_prealloc(pMem, size);
+#endif
+}
+
+void VMem::Free(void* pMem)
+{
+#ifdef _USE_LINKED_LIST
+ if (pMem) {
+ PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER));
+ if (ptr->owner != this) {
+ if (ptr->owner) {
+#if 1
+ dTHX;
+ int *nowhere = NULL;
+ Perl_warn(aTHX_ "Free to wrong pool %p not %p",this,ptr->owner);
+ *nowhere = 0; /* this segfault is deliberate,
+ so you can see the stack trace */
+#else
+ ptr->owner->Free(pMem);
+#endif
+ }
+ return;
+ }
+ GetLock();
+ UnlinkBlock(ptr);
+ ptr->owner = NULL;
+ m_pfree(ptr);
+ FreeLock();
+ }
+#else
+ m_pfree(pMem);
+#endif
+}
+
+void VMem::GetLock(void)
+{
+ EnterCriticalSection(&m_cs);
+}
+
+void VMem::FreeLock(void)
+{
+ LeaveCriticalSection(&m_cs);
+}
+
+int VMem::IsLocked(void)
+{
+#if 0
+ /* XXX TryEnterCriticalSection() is not available in some versions
+ * of Windows 95. Since this code is not used anywhere yet, we
+ * skirt the issue for now. */
+ BOOL bAccessed = TryEnterCriticalSection(&m_cs);
+ if(bAccessed) {
+ LeaveCriticalSection(&m_cs);
+ }
+ return !bAccessed;
+#else
+ ASSERT(0); /* alarm bells for when somebody calls this */
+ return 0;
+#endif
+}
+
+long VMem::Release(void)
+{
+ long lCount = InterlockedDecrement(&m_lRefCount);
+ if(!lCount)
+ delete this;
+ return lCount;
+}
+
+long VMem::AddRef(void)
+{
+ long lCount = InterlockedIncrement(&m_lRefCount);
+ return lCount;
+}
+
+#else /* _USE_MSVCRT_MEM_ALLOC */
+
+/*
+ * Knuth's boundary tag algorithm Vol #1, Page 440.
+ *
+ * Each block in the heap has tag words before and after it,
+ * TAG
+ * block
+ * TAG
+ * The size is stored in these tags as a long word, and includes the 8 bytes
+ * of overhead that the boundary tags consume. Blocks are allocated on long
+ * word boundaries, so the size is always multiples of long words. When the
+ * block is allocated, bit 0, (the tag bit), of the size is set to 1. When
+ * a block is freed, it is merged with adjacent free blocks, and the tag bit
+ * is set to 0.
+ *
+ * A linked list is used to manage the free list. The first two long words of
+ * the block contain double links. These links are only valid when the block
+ * is freed, therefore space needs to be reserved for them. Thus, the minimum
+ * block size (not counting the tags) is 8 bytes.
+ *
+ * Since memory allocation may occur on a single threaded, explict locks are not
+ * provided.
+ *
+ */
+
+const long lAllocStart = 0x00020000; /* start at 128K */
+const long minBlockSize = sizeof(void*)*2;
+const long sizeofTag = sizeof(long);
+const long blockOverhead = sizeofTag*2;
+const long minAllocSize = minBlockSize+blockOverhead;
+#ifdef _USE_BUDDY_BLOCKS
+const long lSmallBlockSize = 1024;
+const size_t nListEntries = ((lSmallBlockSize-minAllocSize)/sizeof(long));
+
+inline size_t CalcEntry(size_t size)
+{
+ ASSERT((size&(sizeof(long)-1)) == 0);
+ return ((size - minAllocSize) / sizeof(long));
+}
+#endif
+
+typedef BYTE* PBLOCK; /* pointer to a memory block */
+
+/*
+ * Macros for accessing hidden fields in a memory block:
+ *
+ * SIZE size of this block (tag bit 0 is 1 if block is allocated)
+ * PSIZE size of previous physical block
+ */
+
+#define SIZE(block) (*(ULONG*)(((PBLOCK)(block))-sizeofTag))
+#define PSIZE(block) (*(ULONG*)(((PBLOCK)(block))-(blockOverhead)))
+inline void SetTags(PBLOCK block, long size)
+{
+ SIZE(block) = size;
+ PSIZE(block+(size&~1)) = size;
+}
+
+/*
+ * Free list pointers
+ * PREV pointer to previous block
+ * NEXT pointer to next block
+ */
+
+#define PREV(block) (*(PBLOCK*)(block))
+#define NEXT(block) (*(PBLOCK*)((block)+sizeof(PBLOCK)))
+inline void SetLink(PBLOCK block, PBLOCK prev, PBLOCK next)
+{
+ PREV(block) = prev;
+ NEXT(block) = next;
+}
+inline void Unlink(PBLOCK p)
+{
+ PBLOCK next = NEXT(p);
+ PBLOCK prev = PREV(p);
+ NEXT(prev) = next;
+ PREV(next) = prev;
+}
+#ifndef _USE_BUDDY_BLOCKS
+inline void AddToFreeList(PBLOCK block, PBLOCK pInList)
+{
+ PBLOCK next = NEXT(pInList);
+ NEXT(pInList) = block;
+ SetLink(block, pInList, next);
+ PREV(next) = block;
+}
+#endif
+
+/* Macro for rounding up to the next sizeof(long) */
+#define ROUND_UP(n) (((ULONG)(n)+sizeof(long)-1)&~(sizeof(long)-1))
+#define ROUND_UP64K(n) (((ULONG)(n)+0x10000-1)&~(0x10000-1))
+#define ROUND_DOWN(n) ((ULONG)(n)&~(sizeof(long)-1))
+
+/*
+ * HeapRec - a list of all non-contiguous heap areas
+ *
+ * Each record in this array contains information about a non-contiguous heap area.
+ */
+
+const int maxHeaps = 32; /* 64 was overkill */
+const long lAllocMax = 0x80000000; /* max size of allocation */
+
+#ifdef _USE_BUDDY_BLOCKS
+typedef struct _FreeListEntry
+{
+ BYTE Dummy[minAllocSize]; // dummy free block
+} FREE_LIST_ENTRY, *PFREE_LIST_ENTRY;
+#endif
+
+#ifndef _USE_BUDDY_BLOCKS
+#define USE_BIGBLOCK_ALLOC
+#endif
+/*
+ * performance tuning
+ * Use VirtualAlloc() for blocks bigger than nMaxHeapAllocSize since
+ * Windows 95/98/Me have heap managers that are designed for memory
+ * blocks smaller than four megabytes.
+ */
+
+#ifdef USE_BIGBLOCK_ALLOC
+const int nMaxHeapAllocSize = (1024*512); /* don't allocate anything larger than this from the heap */
+#endif
+
+typedef struct _HeapRec
+{
+ PBLOCK base; /* base of heap area */
+ ULONG len; /* size of heap area */
+#ifdef USE_BIGBLOCK_ALLOC
+ BOOL bBigBlock; /* was allocate using VirtualAlloc */
+#endif
+} HeapRec;
+
+class VMem
+{
+public:
+ VMem();
+ ~VMem();
+ virtual void* Malloc(size_t size);
+ virtual void* Realloc(void* pMem, size_t size);
+ virtual void Free(void* pMem);
+ virtual void GetLock(void);
+ virtual void FreeLock(void);
+ virtual int IsLocked(void);
+ virtual long Release(void);
+ virtual long AddRef(void);
+
+ inline BOOL CreateOk(void)
+ {
+#ifdef _USE_BUDDY_BLOCKS
+ return TRUE;
+#else
+ return m_hHeap != NULL;
+#endif
+ };
+
+ void ReInit(void);
+
+protected:
+ void Init(void);
+ int Getmem(size_t size);
+
+ int HeapAdd(void* ptr, size_t size
+#ifdef USE_BIGBLOCK_ALLOC
+ , BOOL bBigBlock
+#endif
+ );
+
+ void* Expand(void* block, size_t size);
+
+#ifdef _USE_BUDDY_BLOCKS
+ inline PBLOCK GetFreeListLink(int index)
+ {
+ if (index >= nListEntries)
+ index = nListEntries-1;
+ return &m_FreeList[index].Dummy[sizeofTag];
+ }
+ inline PBLOCK GetOverSizeFreeList(void)
+ {
+ return &m_FreeList[nListEntries-1].Dummy[sizeofTag];
+ }
+ inline PBLOCK GetEOLFreeList(void)
+ {
+ return &m_FreeList[nListEntries].Dummy[sizeofTag];
+ }
+
+ void AddToFreeList(PBLOCK block, size_t size)
+ {
+ PBLOCK pFreeList = GetFreeListLink(CalcEntry(size));
+ PBLOCK next = NEXT(pFreeList);
+ NEXT(pFreeList) = block;
+ SetLink(block, pFreeList, next);
+ PREV(next) = block;
+ }
+#endif
+ inline size_t CalcAllocSize(size_t size)
+ {
+ /*
+ * Adjust the real size of the block to be a multiple of sizeof(long), and add
+ * the overhead for the boundary tags. Disallow negative or zero sizes.
+ */
+ return (size < minBlockSize) ? minAllocSize : (size_t)ROUND_UP(size) + blockOverhead;
+ }
+
+#ifdef _USE_BUDDY_BLOCKS
+ FREE_LIST_ENTRY m_FreeList[nListEntries+1]; // free list with dummy end of list entry as well
+#else
+ HANDLE m_hHeap; // memory heap for this script
+ char m_FreeDummy[minAllocSize]; // dummy free block
+ PBLOCK m_pFreeList; // pointer to first block on free list
+#endif
+ PBLOCK m_pRover; // roving pointer into the free list
+ HeapRec m_heaps[maxHeaps]; // list of all non-contiguous heap areas
+ int m_nHeaps; // no. of heaps in m_heaps
+ long m_lAllocSize; // current alloc size
+ long m_lRefCount; // number of current users
+ CRITICAL_SECTION m_cs; // access lock
+
+#ifdef _DEBUG_MEM
+ void WalkHeap(int complete);
+ void MemoryUsageMessage(char *str, long x, long y, int c);
+ FILE* m_pLog;
+#endif
+};
+
+VMem::VMem()
+{
+ m_lRefCount = 1;
+#ifndef _USE_BUDDY_BLOCKS
+ BOOL bRet = (NULL != (m_hHeap = HeapCreate(HEAP_NO_SERIALIZE,
+ lAllocStart, /* initial size of heap */
+ 0))); /* no upper limit on size of heap */
+ ASSERT(bRet);
+#endif
+
+ InitializeCriticalSection(&m_cs);
+#ifdef _DEBUG_MEM
+ m_pLog = 0;
+#endif
+
+ Init();
+}
+
+VMem::~VMem(void)
+{
+#ifndef _USE_BUDDY_BLOCKS
+ ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, NULL));
+#endif
+ WALKHEAPTRACE();
+
+ DeleteCriticalSection(&m_cs);
+#ifdef _USE_BUDDY_BLOCKS
+ for(int index = 0; index < m_nHeaps; ++index) {
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+ }
+#else /* !_USE_BUDDY_BLOCKS */
+#ifdef USE_BIGBLOCK_ALLOC
+ for(int index = 0; index < m_nHeaps; ++index) {
+ if (m_heaps[index].bBigBlock) {
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+ }
+ }
+#endif
+ BOOL bRet = HeapDestroy(m_hHeap);
+ ASSERT(bRet);
+#endif /* _USE_BUDDY_BLOCKS */
+}
+
+void VMem::ReInit(void)
+{
+ for(int index = 0; index < m_nHeaps; ++index) {
+#ifdef _USE_BUDDY_BLOCKS
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+#else
+#ifdef USE_BIGBLOCK_ALLOC
+ if (m_heaps[index].bBigBlock) {
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+ }
+ else
+#endif
+ HeapFree(m_hHeap, HEAP_NO_SERIALIZE, m_heaps[index].base);
+#endif /* _USE_BUDDY_BLOCKS */
+ }
+
+ Init();
+}
+
+void VMem::Init(void)
+{
+#ifdef _USE_BUDDY_BLOCKS
+ PBLOCK pFreeList;
+ /*
+ * Initialize the free list by placing a dummy zero-length block on it.
+ * Set the end of list marker.
+ * Set the number of non-contiguous heaps to zero.
+ * Set the next allocation size.
+ */
+ for (int index = 0; index < nListEntries; ++index) {
+ pFreeList = GetFreeListLink(index);
+ SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0;
+ PREV(pFreeList) = NEXT(pFreeList) = pFreeList;
+ }
+ pFreeList = GetEOLFreeList();
+ SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0;
+ PREV(pFreeList) = NEXT(pFreeList) = NULL;
+ m_pRover = GetOverSizeFreeList();
+#else
+ /*
+ * Initialize the free list by placing a dummy zero-length block on it.
+ * Set the number of non-contiguous heaps to zero.
+ */
+ m_pFreeList = m_pRover = (PBLOCK)(&m_FreeDummy[sizeofTag]);
+ PSIZE(m_pFreeList+minAllocSize) = SIZE(m_pFreeList) = 0;
+ PREV(m_pFreeList) = NEXT(m_pFreeList) = m_pFreeList;
+#endif
+
+ m_nHeaps = 0;
+ m_lAllocSize = lAllocStart;
+}
+
+void* VMem::Malloc(size_t size)
+{
+ WALKHEAP();
+
+ PBLOCK ptr;
+ size_t lsize, rem;
+ /*
+ * Disallow negative or zero sizes.
+ */
+ size_t realsize = CalcAllocSize(size);
+ if((int)realsize < minAllocSize || size == 0)
+ return NULL;
+
+#ifdef _USE_BUDDY_BLOCKS
+ /*
+ * Check the free list of small blocks if this is free use it
+ * Otherwise check the rover if it has no blocks then
+ * Scan the free list entries use the first free block
+ * split the block if needed, stop at end of list marker
+ */
+ {
+ int index = CalcEntry(realsize);
+ if (index < nListEntries-1) {
+ ptr = GetFreeListLink(index);
+ lsize = SIZE(ptr);
+ if (lsize >= realsize) {
+ rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ SetTags(ptr, lsize | 1);
+ return ptr;
+ }
+ ptr = m_pRover;
+ lsize = SIZE(ptr);
+ if (lsize >= realsize) {
+ rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ SetTags(ptr, lsize | 1);
+ return ptr;
+ }
+ ptr = GetFreeListLink(index+1);
+ while (NEXT(ptr)) {
+ lsize = SIZE(ptr);
+ if (lsize >= realsize) {
+ size_t rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ SetTags(ptr, lsize | 1);
+ return ptr;
+ }
+ ptr += sizeof(FREE_LIST_ENTRY);
+ }
+ }
+ }
+#endif
+
+ /*
+ * Start searching the free list at the rover. If we arrive back at rover without
+ * finding anything, allocate some memory from the heap and try again.
+ */
+ ptr = m_pRover; /* start searching at rover */
+ int loops = 2; /* allow two times through the loop */
+ for(;;) {
+ lsize = SIZE(ptr);
+ ASSERT((lsize&1)==0);
+ /* is block big enough? */
+ if(lsize >= realsize) {
+ /* if the remainder is too small, don't bother splitting the block. */
+ rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ if(m_pRover == ptr)
+ m_pRover = NEXT(ptr);
+
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, lsize | 1);
+ return ((void *)ptr);
+ }
+
+ /*
+ * This block was unsuitable. If we've gone through this list once already without
+ * finding anything, allocate some new memory from the heap and try again.
+ */
+ ptr = NEXT(ptr);
+ if(ptr == m_pRover) {
+ if(!(loops-- && Getmem(realsize))) {
+ return NULL;
+ }
+ ptr = m_pRover;
+ }
+ }
+}
+
+void* VMem::Realloc(void* block, size_t size)
+{
+ WALKHEAP();
+
+ /* if size is zero, free the block. */
+ if(size == 0) {
+ Free(block);
+ return (NULL);
+ }
+
+ /* if block pointer is NULL, do a Malloc(). */
+ if(block == NULL)
+ return Malloc(size);
+
+ /*
+ * Grow or shrink the block in place.
+ * if the block grows then the next block will be used if free
+ */
+ if(Expand(block, size) != NULL)
+ return block;
+
+ size_t realsize = CalcAllocSize(size);
+ if((int)realsize < minAllocSize)
+ return NULL;
+
+ /*
+ * see if the previous block is free, and is it big enough to cover the new size
+ * if merged with the current block.
+ */
+ PBLOCK ptr = (PBLOCK)block;
+ size_t cursize = SIZE(ptr) & ~1;
+ size_t psize = PSIZE(ptr);
+ if((psize&1) == 0 && (psize + cursize) >= realsize) {
+ PBLOCK prev = ptr - psize;
+ if(m_pRover == prev)
+ m_pRover = NEXT(prev);
+
+ /* Unlink the next block from the free list. */
+ Unlink(prev);
+
+ /* Copy contents of old block to new location, make it the current block. */
+ memmove(prev, ptr, cursize);
+ cursize += psize; /* combine sizes */
+ ptr = prev;
+
+ size_t rem = cursize - realsize;
+ if(rem >= minAllocSize) {
+ /*
+ * The remainder is big enough to be a new block. Set boundary
+ * tags for the resized block and the new block.
+ */
+ prev = ptr + realsize;
+ /*
+ * add the new block to the free list.
+ * next block cannot be free
+ */
+ SetTags(prev, rem);
+#ifdef _USE_BUDDY_BLOCKS
+ AddToFreeList(prev, rem);
+#else
+ AddToFreeList(prev, m_pFreeList);
+#endif
+ cursize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, cursize | 1);
+ return ((void *)ptr);
+ }
+
+ /* Allocate a new block, copy the old to the new, and free the old. */
+ if((ptr = (PBLOCK)Malloc(size)) != NULL) {
+ memmove(ptr, block, cursize-blockOverhead);
+ Free(block);
+ }
+ return ((void *)ptr);
+}
+
+void VMem::Free(void* p)
+{
+ WALKHEAP();
+
+ /* Ignore null pointer. */
+ if(p == NULL)
+ return;
+
+ PBLOCK ptr = (PBLOCK)p;
+
+ /* Check for attempt to free a block that's already free. */
+ size_t size = SIZE(ptr);
+ if((size&1) == 0) {
+ MEMODSlx("Attempt to free previously freed block", (long)p);
+ return;
+ }
+ size &= ~1; /* remove allocated tag */
+
+ /* if previous block is free, add this block to it. */
+#ifndef _USE_BUDDY_BLOCKS
+ int linked = FALSE;
+#endif
+ size_t psize = PSIZE(ptr);
+ if((psize&1) == 0) {
+ ptr -= psize; /* point to previous block */
+ size += psize; /* merge the sizes of the two blocks */
+#ifdef _USE_BUDDY_BLOCKS
+ Unlink(ptr);
+#else
+ linked = TRUE; /* it's already on the free list */
+#endif
+ }
+
+ /* if the next physical block is free, merge it with this block. */
+ PBLOCK next = ptr + size; /* point to next physical block */
+ size_t nsize = SIZE(next);
+ if((nsize&1) == 0) {
+ /* block is free move rover if needed */
+ if(m_pRover == next)
+ m_pRover = NEXT(next);
+
+ /* unlink the next block from the free list. */
+ Unlink(next);
+
+ /* merge the sizes of this block and the next block. */
+ size += nsize;
+ }
+
+ /* Set the boundary tags for the block; */
+ SetTags(ptr, size);
+
+ /* Link the block to the head of the free list. */
+#ifdef _USE_BUDDY_BLOCKS
+ AddToFreeList(ptr, size);
+#else
+ if(!linked) {
+ AddToFreeList(ptr, m_pFreeList);
+ }
+#endif
+}
+
+void VMem::GetLock(void)
+{
+ EnterCriticalSection(&m_cs);
+}
+
+void VMem::FreeLock(void)
+{
+ LeaveCriticalSection(&m_cs);
+}
+
+int VMem::IsLocked(void)
+{
+#if 0
+ /* XXX TryEnterCriticalSection() is not available in some versions
+ * of Windows 95. Since this code is not used anywhere yet, we
+ * skirt the issue for now. */
+ BOOL bAccessed = TryEnterCriticalSection(&m_cs);
+ if(bAccessed) {
+ LeaveCriticalSection(&m_cs);
+ }
+ return !bAccessed;
+#else
+ ASSERT(0); /* alarm bells for when somebody calls this */
+ return 0;
+#endif
+}
+
+
+long VMem::Release(void)
+{
+ long lCount = InterlockedDecrement(&m_lRefCount);
+ if(!lCount)
+ delete this;
+ return lCount;
+}
+
+long VMem::AddRef(void)
+{
+ long lCount = InterlockedIncrement(&m_lRefCount);
+ return lCount;
+}
+
+
+int VMem::Getmem(size_t requestSize)
+{ /* returns -1 is successful 0 if not */
+#ifdef USE_BIGBLOCK_ALLOC
+ BOOL bBigBlock;
+#endif
+ void *ptr;
+
+ /* Round up size to next multiple of 64K. */
+ size_t size = (size_t)ROUND_UP64K(requestSize);
+
+ /*
+ * if the size requested is smaller than our current allocation size
+ * adjust up
+ */
+ if(size < (unsigned long)m_lAllocSize)
+ size = m_lAllocSize;
+
+ /* Update the size to allocate on the next request */
+ if(m_lAllocSize != lAllocMax)
+ m_lAllocSize <<= 2;
+
+#ifndef _USE_BUDDY_BLOCKS
+ if(m_nHeaps != 0
+#ifdef USE_BIGBLOCK_ALLOC
+ && !m_heaps[m_nHeaps-1].bBigBlock
+#endif
+ ) {
+ /* Expand the last allocated heap */
+ ptr = HeapReAlloc(m_hHeap, HEAP_REALLOC_IN_PLACE_ONLY|HEAP_NO_SERIALIZE,
+ m_heaps[m_nHeaps-1].base,
+ m_heaps[m_nHeaps-1].len + size);
+ if(ptr != 0) {
+ HeapAdd(((char*)ptr) + m_heaps[m_nHeaps-1].len, size
+#ifdef USE_BIGBLOCK_ALLOC
+ , FALSE
+#endif
+ );
+ return -1;
+ }
+ }
+#endif /* _USE_BUDDY_BLOCKS */
+
+ /*
+ * if we didn't expand a block to cover the requested size
+ * allocate a new Heap
+ * the size of this block must include the additional dummy tags at either end
+ * the above ROUND_UP64K may not have added any memory to include this.
+ */
+ if(size == requestSize)
+ size = (size_t)ROUND_UP64K(requestSize+(blockOverhead));
+
+Restart:
+#ifdef _USE_BUDDY_BLOCKS
+ ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE);
+#else
+#ifdef USE_BIGBLOCK_ALLOC
+ bBigBlock = FALSE;
+ if (size >= nMaxHeapAllocSize) {
+ bBigBlock = TRUE;
+ ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE);
+ }
+ else
+#endif
+ ptr = HeapAlloc(m_hHeap, HEAP_NO_SERIALIZE, size);
+#endif /* _USE_BUDDY_BLOCKS */
+
+ if (!ptr) {
+ /* try to allocate a smaller chunk */
+ size >>= 1;
+ if(size > requestSize)
+ goto Restart;
+ }
+
+ if(ptr == 0) {
+ MEMODSlx("HeapAlloc failed on size!!!", size);
+ return 0;
+ }
+
+#ifdef _USE_BUDDY_BLOCKS
+ if (HeapAdd(ptr, size)) {
+ VirtualFree(ptr, 0, MEM_RELEASE);
+ return 0;
+ }
+#else
+#ifdef USE_BIGBLOCK_ALLOC
+ if (HeapAdd(ptr, size, bBigBlock)) {
+ if (bBigBlock) {
+ VirtualFree(ptr, 0, MEM_RELEASE);
+ }
+ }
+#else
+ HeapAdd(ptr, size);
+#endif
+#endif /* _USE_BUDDY_BLOCKS */
+ return -1;
+}
+
+int VMem::HeapAdd(void* p, size_t size
+#ifdef USE_BIGBLOCK_ALLOC
+ , BOOL bBigBlock
+#endif
+ )
+{ /* if the block can be succesfully added to the heap, returns 0; otherwise -1. */
+ int index;
+
+ /* Check size, then round size down to next long word boundary. */
+ if(size < minAllocSize)
+ return -1;
+
+ size = (size_t)ROUND_DOWN(size);
+ PBLOCK ptr = (PBLOCK)p;
+
+#ifdef USE_BIGBLOCK_ALLOC
+ if (!bBigBlock) {
+#endif
+ /*
+ * Search for another heap area that's contiguous with the bottom of this new area.
+ * (It should be extremely unusual to find one that's contiguous with the top).
+ */
+ for(index = 0; index < m_nHeaps; ++index) {
+ if(ptr == m_heaps[index].base + (int)m_heaps[index].len) {
+ /*
+ * The new block is contiguous with a previously allocated heap area. Add its
+ * length to that of the previous heap. Merge it with the dummy end-of-heap
+ * area marker of the previous heap.
+ */
+ m_heaps[index].len += size;
+ break;
+ }
+ }
+#ifdef USE_BIGBLOCK_ALLOC
+ }
+ else {
+ index = m_nHeaps;
+ }
+#endif
+
+ if(index == m_nHeaps) {
+ /* The new block is not contiguous, or is BigBlock. Add it to the heap list. */
+ if(m_nHeaps == maxHeaps) {
+ return -1; /* too many non-contiguous heaps */
+ }
+ m_heaps[m_nHeaps].base = ptr;
+ m_heaps[m_nHeaps].len = size;
+#ifdef USE_BIGBLOCK_ALLOC
+ m_heaps[m_nHeaps].bBigBlock = bBigBlock;
+#endif
+ m_nHeaps++;
+
+ /*
+ * Reserve the first LONG in the block for the ending boundary tag of a dummy
+ * block at the start of the heap area.
+ */
+ size -= blockOverhead;
+ ptr += blockOverhead;
+ PSIZE(ptr) = 1; /* mark the dummy previous block as allocated */
+ }
+
+ /*
+ * Convert the heap to one large block. Set up its boundary tags, and those of
+ * marker block after it. The marker block before the heap will already have
+ * been set up if this heap is not contiguous with the end of another heap.
+ */
+ SetTags(ptr, size | 1);
+ PBLOCK next = ptr + size; /* point to dummy end block */
+ SIZE(next) = 1; /* mark the dummy end block as allocated */
+
+ /*
+ * Link the block to the start of the free list by calling free().
+ * This will merge the block with any adjacent free blocks.
+ */
+ Free(ptr);
+ return 0;
+}
+
+
+void* VMem::Expand(void* block, size_t size)
+{
+ /*
+ * Disallow negative or zero sizes.
+ */
+ size_t realsize = CalcAllocSize(size);
+ if((int)realsize < minAllocSize || size == 0)
+ return NULL;
+
+ PBLOCK ptr = (PBLOCK)block;
+
+ /* if the current size is the same as requested, do nothing. */
+ size_t cursize = SIZE(ptr) & ~1;
+ if(cursize == realsize) {
+ return block;
+ }
+
+ /* if the block is being shrunk, convert the remainder of the block into a new free block. */
+ if(realsize <= cursize) {
+ size_t nextsize = cursize - realsize; /* size of new remainder block */
+ if(nextsize >= minAllocSize) {
+ /*
+ * Split the block
+ * Set boundary tags for the resized block and the new block.
+ */
+ SetTags(ptr, realsize | 1);
+ ptr += realsize;
+
+ /*
+ * add the new block to the free list.
+ * call Free to merge this block with next block if free
+ */
+ SetTags(ptr, nextsize | 1);
+ Free(ptr);
+ }
+
+ return block;
+ }
+
+ PBLOCK next = ptr + cursize;
+ size_t nextsize = SIZE(next);
+
+ /* Check the next block for consistency.*/
+ if((nextsize&1) == 0 && (nextsize + cursize) >= realsize) {
+ /*
+ * The next block is free and big enough. Add the part that's needed
+ * to our block, and split the remainder off into a new block.
+ */
+ if(m_pRover == next)
+ m_pRover = NEXT(next);
+
+ /* Unlink the next block from the free list. */
+ Unlink(next);
+ cursize += nextsize; /* combine sizes */
+
+ size_t rem = cursize - realsize; /* size of remainder */
+ if(rem >= minAllocSize) {
+ /*
+ * The remainder is big enough to be a new block.
+ * Set boundary tags for the resized block and the new block.
+ */
+ next = ptr + realsize;
+ /*
+ * add the new block to the free list.
+ * next block cannot be free
+ */
+ SetTags(next, rem);
+#ifdef _USE_BUDDY_BLOCKS
+ AddToFreeList(next, rem);
+#else
+ AddToFreeList(next, m_pFreeList);
+#endif
+ cursize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, cursize | 1);
+ return ((void *)ptr);
+ }
+ return NULL;
+}
+
+#ifdef _DEBUG_MEM
+#define LOG_FILENAME ".\\MemLog.txt"
+
+void VMem::MemoryUsageMessage(char *str, long x, long y, int c)
+{
+ char szBuffer[512];
+ if(str) {
+ if(!m_pLog)
+ m_pLog = fopen(LOG_FILENAME, "w");
+ sprintf(szBuffer, str, x, y, c);
+ fputs(szBuffer, m_pLog);
+ }
+ else {
+ if(m_pLog) {
+ fflush(m_pLog);
+ fclose(m_pLog);
+ m_pLog = 0;
+ }
+ }
+}
+
+void VMem::WalkHeap(int complete)
+{
+ if(complete) {
+ MemoryUsageMessage(NULL, 0, 0, 0);
+ size_t total = 0;
+ for(int i = 0; i < m_nHeaps; ++i) {
+ total += m_heaps[i].len;
+ }
+ MemoryUsageMessage("VMem heaps used %d. Total memory %08x\n", m_nHeaps, total, 0);
+
+ /* Walk all the heaps - verify structures */
+ for(int index = 0; index < m_nHeaps; ++index) {
+ PBLOCK ptr = m_heaps[index].base;
+ size_t size = m_heaps[index].len;
+#ifndef _USE_BUDDY_BLOCKS
+#ifdef USE_BIGBLOCK_ALLOC
+ if (!m_heaps[m_nHeaps].bBigBlock)
+#endif
+ ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, ptr));
+#endif
+
+ /* set over reserved header block */
+ size -= blockOverhead;
+ ptr += blockOverhead;
+ PBLOCK pLast = ptr + size;
+ ASSERT(PSIZE(ptr) == 1); /* dummy previous block is allocated */
+ ASSERT(SIZE(pLast) == 1); /* dummy next block is allocated */
+ while(ptr < pLast) {
+ ASSERT(ptr > m_heaps[index].base);
+ size_t cursize = SIZE(ptr) & ~1;
+ ASSERT((PSIZE(ptr+cursize) & ~1) == cursize);
+ MemoryUsageMessage("Memory Block %08x: Size %08x %c\n", (long)ptr, cursize, (SIZE(ptr)&1) ? 'x' : ' ');
+ if(!(SIZE(ptr)&1)) {
+ /* this block is on the free list */
+ PBLOCK tmp = NEXT(ptr);
+ while(tmp != ptr) {
+ ASSERT((SIZE(tmp)&1)==0);
+ if(tmp == m_pFreeList)
+ break;
+ ASSERT(NEXT(tmp));
+ tmp = NEXT(tmp);
+ }
+ if(tmp == ptr) {
+ MemoryUsageMessage("Memory Block %08x: Size %08x free but not in free list\n", (long)ptr, cursize, 0);
+ }
+ }
+ ptr += cursize;
+ }
+ }
+ MemoryUsageMessage(NULL, 0, 0, 0);
+ }
+}
+#endif /* _DEBUG_MEM */
+
+#endif /* _USE_MSVCRT_MEM_ALLOC */
+
+#endif /* ___VMEM_H_INC___ */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/warnings.h b/Master/tlpkg/tlperl.straw/lib/CORE/warnings.h
new file mode 100755
index 00000000000..66a9a0a65df
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/warnings.h
@@ -0,0 +1,123 @@
+/* -*- buffer-read-only: t -*-
+ !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warnings.pl
+ Any changes made here will be lost!
+*/
+
+
+#define Off(x) ((x) / 8)
+#define Bit(x) (1 << ((x) % 8))
+#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
+
+
+#define G_WARN_OFF 0 /* $^W == 0 */
+#define G_WARN_ON 1 /* -w flag and $^W != 0 */
+#define G_WARN_ALL_ON 2 /* -W flag */
+#define G_WARN_ALL_OFF 4 /* -X flag */
+#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
+#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
+
+#define pWARN_STD NULL
+#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
+#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
+
+#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
+ (x) == pWARN_NONE)
+
+/* if PL_warnhook is set to this value, then warnings die */
+#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
+
+/* Warnings Categories added in Perl 5.008 */
+
+#define WARN_ALL 0
+#define WARN_CLOSURE 1
+#define WARN_DEPRECATED 2
+#define WARN_EXITING 3
+#define WARN_GLOB 4
+#define WARN_IO 5
+#define WARN_CLOSED 6
+#define WARN_EXEC 7
+#define WARN_LAYER 8
+#define WARN_NEWLINE 9
+#define WARN_PIPE 10
+#define WARN_UNOPENED 11
+#define WARN_MISC 12
+#define WARN_NUMERIC 13
+#define WARN_ONCE 14
+#define WARN_OVERFLOW 15
+#define WARN_PACK 16
+#define WARN_PORTABLE 17
+#define WARN_RECURSION 18
+#define WARN_REDEFINE 19
+#define WARN_REGEXP 20
+#define WARN_SEVERE 21
+#define WARN_DEBUGGING 22
+#define WARN_INPLACE 23
+#define WARN_INTERNAL 24
+#define WARN_MALLOC 25
+#define WARN_SIGNAL 26
+#define WARN_SUBSTR 27
+#define WARN_SYNTAX 28
+#define WARN_AMBIGUOUS 29
+#define WARN_BAREWORD 30
+#define WARN_DIGIT 31
+#define WARN_PARENTHESIS 32
+#define WARN_PRECEDENCE 33
+#define WARN_PRINTF 34
+#define WARN_PROTOTYPE 35
+#define WARN_QW 36
+#define WARN_RESERVED 37
+#define WARN_SEMICOLON 38
+#define WARN_TAINT 39
+#define WARN_THREADS 40
+#define WARN_UNINITIALIZED 41
+#define WARN_UNPACK 42
+#define WARN_UNTIE 43
+#define WARN_UTF8 44
+#define WARN_VOID 45
+
+#define WARNsize 12
+#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125"
+#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0"
+
+#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
+#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
+#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p) \
+ (specialWARN(p) ? (STRLEN*)(p) \
+ : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
+ char))
+
+#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
+#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
+#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
+#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
+
+#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
+#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
+#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
+#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
+
+#define packWARN(a) (a )
+#define packWARN2(a,b) ((a) | ((b)<<8) )
+#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
+#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
+
+#define unpackWARN1(x) ((x) & 0xFF)
+#define unpackWARN2(x) (((x) >>8) & 0xFF)
+#define unpackWARN3(x) (((x) >>16) & 0xFF)
+#define unpackWARN4(x) (((x) >>24) & 0xFF)
+
+#define ckDEAD(x) \
+ ( ! specialWARN(PL_curcop->cop_warnings) && \
+ ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
+ isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
+ isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
+ isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
+ isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
+
+/* end of file warnings.h */
+/* ex: set ro: */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/win32.h b/Master/tlpkg/tlperl.straw/lib/CORE/win32.h
new file mode 100755
index 00000000000..224c6575078
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/win32.h
@@ -0,0 +1,588 @@
+/* WIN32.H
+ *
+ * (c) 1995 Microsoft Corporation. All rights reserved.
+ * Developed by hip communications inc., http://info.hip.com/info/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+#ifndef _INC_WIN32_PERL5
+#define _INC_WIN32_PERL5
+
+#ifndef _WIN32_WINNT
+# define _WIN32_WINNT 0x0400 /* needed for TryEnterCriticalSection() etc. */
+#endif
+
+#if defined(PERL_IMPLICIT_SYS)
+# define DYNAMIC_ENV_FETCH
+# define HAS_GETENV_LEN
+# define prime_env_iter()
+# define WIN32IO_IS_STDIO /* don't pull in custom stdio layer */
+# define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */
+# ifdef PERL_GLOBAL_STRUCT
+# error PERL_GLOBAL_STRUCT cannot be defined with PERL_IMPLICIT_SYS
+# endif
+# define win32_get_privlib PerlEnv_lib_path
+# define win32_get_sitelib PerlEnv_sitelib_path
+# define win32_get_vendorlib PerlEnv_vendorlib_path
+#endif
+
+#ifdef __GNUC__
+# ifndef __int64 /* some versions seem to #define it already */
+# define __int64 long long
+# endif
+# define Win32_Winsock
+#ifdef __cplusplus
+/* Mingw32 gcc -xc++ objects to __attribute((unused)) at least */
+#undef PERL_UNUSED_DECL
+#define PERL_UNUSED_DECL
+#endif
+#endif
+
+
+/* Define DllExport akin to perl's EXT,
+ * If we are in the DLL or mimicing the DLL for Win95 work round
+ * then Export the symbol,
+ * otherwise import it.
+ */
+
+/* now even GCC supports __declspec() */
+
+#if defined(PERLDLL) || defined(WIN95FIX)
+#define DllExport
+/*#define DllExport __declspec(dllexport)*/ /* noises with VC5+sp3 */
+#else
+#define DllExport __declspec(dllimport)
+#endif
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+#ifdef WIN32_LEAN_AND_MEAN /* C file is NOT a Perl5 original. */
+#define CONTEXT PERL_CONTEXT /* Avoid conflict of CONTEXT defs. */
+#endif /*WIN32_LEAN_AND_MEAN */
+
+#ifndef TLS_OUT_OF_INDEXES
+#define TLS_OUT_OF_INDEXES (DWORD)0xFFFFFFFF
+#endif
+
+#include <dirent.h>
+#include <io.h>
+#include <process.h>
+#include <stdio.h>
+#include <direct.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <fcntl.h>
+#ifndef EXT
+#include "EXTERN.h"
+#endif
+
+struct tms {
+ long tms_utime;
+ long tms_stime;
+ long tms_cutime;
+ long tms_cstime;
+};
+
+#ifndef SYS_NMLN
+#define SYS_NMLN 257
+#endif
+
+struct utsname {
+ char sysname[SYS_NMLN];
+ char nodename[SYS_NMLN];
+ char release[SYS_NMLN];
+ char version[SYS_NMLN];
+ char machine[SYS_NMLN];
+};
+
+#ifndef START_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C
+#endif
+#endif
+
+#define STANDARD_C 1
+#define DOSISH 1 /* no escaping our roots */
+#define OP_BINARY O_BINARY /* mistake in in pp_sys.c? */
+
+/* Define USE_SOCKETS_AS_HANDLES to enable emulation of windows sockets as
+ * real filehandles. XXX Should always be defined (the other version is untested) */
+#define USE_SOCKETS_AS_HANDLES
+
+/* read() and write() aren't transparent for socket handles */
+#define PERL_SOCK_SYSREAD_IS_RECV
+#define PERL_SOCK_SYSWRITE_IS_SEND
+
+#define PERL_NO_FORCE_LINK /* no need for PL_force_link_funcs */
+
+/* Define USE_FIXED_OSFHANDLE to fix MSVCRT's _open_osfhandle() on W95.
+ It now uses some black magic to work seamlessly with the DLL CRT and
+ works with MSVC++ 4.0+ or GCC/Mingw32
+ -- BKS 1-24-2000
+ Only use this fix for VC++ 6.x or earlier (and for GCC, which we assume
+ uses MSVCRT.DLL). Later versions use MSVCR70.dll, MSVCR71.dll, etc, which
+ do not require the fix. */
+#if (defined(_M_IX86) && _MSC_VER >= 1000 && _MSC_VER <= 1200) || defined(__MINGW32__)
+#define USE_FIXED_OSFHANDLE
+#endif
+
+/* Define PERL_WIN32_SOCK_DLOAD to have Perl dynamically load the winsock
+ DLL when needed. Don't use if your compiler supports delayloading (ie, VC++ 6.0)
+ -- BKS 5-29-2000 */
+#if !(defined(_M_IX86) && _MSC_VER >= 1200)
+#define PERL_WIN32_SOCK_DLOAD
+#endif
+#define ENV_IS_CASELESS
+
+#define PIPESOCK_MODE "b" /* pipes, sockets default to binmode */
+
+#ifndef VER_PLATFORM_WIN32_WINDOWS /* VC-2.0 headers don't have this */
+#define VER_PLATFORM_WIN32_WINDOWS 1
+#endif
+
+#ifndef FILE_SHARE_DELETE /* VC-4.0 headers don't have this */
+#define FILE_SHARE_DELETE 0x00000004
+#endif
+
+/* access() mode bits */
+#ifndef R_OK
+# define R_OK 4
+# define W_OK 2
+# define X_OK 1
+# define F_OK 0
+#endif
+
+/* for waitpid() */
+#ifndef WNOHANG
+# define WNOHANG 1
+#endif
+
+#define PERL_GET_CONTEXT_DEFINED
+
+/* Compiler-specific stuff. */
+
+#ifdef __BORLANDC__ /* Borland C++ */
+
+#if (__BORLANDC__ <= 0x520)
+#define _access access
+#define _chdir chdir
+#endif
+
+#define _getpid getpid
+#define wcsicmp _wcsicmp
+#include <sys/types.h>
+
+#ifndef DllMain
+#define DllMain DllEntryPoint
+#endif
+
+#pragma warn -8004 /* "'foo' is assigned a value that is never used" */
+#pragma warn -8008 /* "condition is always true/false" */
+#pragma warn -8012 /* "comparing signed and unsigned values" */
+#pragma warn -8027 /* "functions containing %s are not expanded inline" */
+#pragma warn -8057 /* "parameter 'foo' is never used" */
+#pragma warn -8060 /* "possibly incorrect assignment" */
+#pragma warn -8066 /* "unreachable code" */
+#pragma warn -8071 /* "conversion may lose significant digits" */
+#pragma warn -8080 /* "'foo' is declared but never used" */
+
+/* Borland C thinks that a pointer to a member variable is 12 bytes in size. */
+#define PERL_MEMBER_PTR_SIZE 12
+
+#define isnan _isnan
+
+#endif
+
+#ifdef _MSC_VER /* Microsoft Visual C++ */
+
+#ifndef UNDER_CE
+typedef long uid_t;
+typedef long gid_t;
+typedef unsigned short mode_t;
+#endif
+
+#pragma warning(disable: 4102) /* "unreferenced label" */
+
+/* Visual C thinks that a pointer to a member variable is 16 bytes in size. */
+#define PERL_MEMBER_PTR_SIZE 16
+
+#define isnan _isnan
+#define snprintf _snprintf
+#define vsnprintf _vsnprintf
+
+#if _MSC_VER < 1300
+/* VC6 has broken NaN semantics: NaN == NaN returns true instead of false */
+#define NAN_COMPARE_BROKEN 1
+#endif
+
+#endif /* _MSC_VER */
+
+#ifdef __MINGW32__ /* Minimal Gnu-Win32 */
+
+typedef long uid_t;
+typedef long gid_t;
+#ifndef _environ
+#define _environ environ
+#endif
+#define flushall _flushall
+#define fcloseall _fcloseall
+#define isnan _isnan /* ...same libraries as MSVC */
+
+#ifndef _O_NOINHERIT
+# define _O_NOINHERIT 0x0080
+# ifndef _NO_OLDNAMES
+# define O_NOINHERIT _O_NOINHERIT
+# endif
+#endif
+
+/* <stdint.h>, pulled in by <io.h> as of mingw-runtime-3.3, typedef's
+ * (u)intptr_t but doesn't set the _(U)INTPTR_T_DEFINED defines */
+#ifdef _STDINT_H
+# ifndef _INTPTR_T_DEFINED
+# define _INTPTR_T_DEFINED
+# endif
+# ifndef _UINTPTR_T_DEFINED
+# define _UINTPTR_T_DEFINED
+# endif
+#endif
+
+#endif /* __MINGW32__ */
+
+/* both GCC/Mingw32 and MSVC++ 4.0 are missing this, so we put it here */
+#ifndef CP_UTF8
+# define CP_UTF8 65001
+#endif
+
+/* compatibility stuff for other compilers goes here */
+
+#ifndef _INTPTR_T_DEFINED
+typedef int intptr_t;
+# define _INTPTR_T_DEFINED
+#endif
+
+#ifndef _UINTPTR_T_DEFINED
+typedef unsigned int uintptr_t;
+# define _UINTPTR_T_DEFINED
+#endif
+
+START_EXTERN_C
+
+/* For UNIX compatibility. */
+
+extern uid_t getuid(void);
+extern gid_t getgid(void);
+extern uid_t geteuid(void);
+extern gid_t getegid(void);
+extern int setuid(uid_t uid);
+extern int setgid(gid_t gid);
+extern int kill(int pid, int sig);
+extern int killpg(int pid, int sig);
+#ifndef USE_PERL_SBRK
+extern void *sbrk(ptrdiff_t need);
+# define HAS_SBRK_PROTO
+#endif
+extern char * getlogin(void);
+extern int chown(const char *p, uid_t o, gid_t g);
+extern int mkstemp(const char *path);
+
+#undef Stat
+#define Stat win32_stat
+
+#undef init_os_extras
+#define init_os_extras Perl_init_os_extras
+
+DllExport void Perl_win32_init(int *argcp, char ***argvp);
+DllExport void Perl_win32_term(void);
+DllExport void Perl_init_os_extras(void);
+DllExport void win32_str_os_error(void *sv, DWORD err);
+DllExport int RunPerl(int argc, char **argv, char **env);
+
+typedef struct {
+ HANDLE childStdIn;
+ HANDLE childStdOut;
+ HANDLE childStdErr;
+ /*
+ * the following correspond to the fields of the same name
+ * in the STARTUPINFO structure. Embedders can use these to
+ * control the spawning process' look.
+ * Example - to hide the window of the spawned process:
+ * dwFlags = STARTF_USESHOWWINDOW;
+ * wShowWindow = SW_HIDE;
+ */
+ DWORD dwFlags;
+ DWORD dwX;
+ DWORD dwY;
+ DWORD dwXSize;
+ DWORD dwYSize;
+ DWORD dwXCountChars;
+ DWORD dwYCountChars;
+ DWORD dwFillAttribute;
+ WORD wShowWindow;
+} child_IO_table;
+
+DllExport void win32_get_child_IO(child_IO_table* ptr);
+DllExport HWND win32_create_message_window(void);
+
+#ifndef USE_SOCKETS_AS_HANDLES
+extern FILE * my_fdopen(int, char *);
+#endif
+extern int my_fclose(FILE *);
+extern int my_fstat(int fd, Stat_t *sbufptr);
+extern char * win32_get_privlib(const char *pl);
+extern char * win32_get_sitelib(const char *pl);
+extern char * win32_get_vendorlib(const char *pl);
+extern int IsWin95(void);
+extern int IsWinNT(void);
+
+#ifdef PERL_IMPLICIT_SYS
+extern void win32_delete_internal_host(void *h);
+#endif
+
+extern char * staticlinkmodules[];
+
+END_EXTERN_C
+
+typedef char * caddr_t; /* In malloc.c (core address). */
+
+/*
+ * handle socket stuff, assuming socket is always available
+ */
+#include <sys/socket.h>
+#include <netdb.h>
+
+#ifdef MYMALLOC
+#define EMBEDMYMALLOC /**/
+/* #define USE_PERL_SBRK /**/
+/* #define PERL_SBRK_VIA_MALLOC /**/
+#endif
+
+#ifdef PERL_TEXTMODE_SCRIPTS
+# define PERL_SCRIPT_MODE "r"
+#else
+# define PERL_SCRIPT_MODE "rb"
+#endif
+
+/*
+ * Now Win32 specific per-thread data stuff
+ */
+
+/* Leave the first couple ids after WM_USER unused because they
+ * might be used by an embedding application, and on Windows
+ * version before 2000 we might end up eating those messages
+ * if they were not meant for us.
+ */
+#define WM_USER_MIN (WM_USER+30)
+#define WM_USER_MESSAGE (WM_USER_MIN)
+#define WM_USER_KILL (WM_USER_MIN+1)
+#define WM_USER_MAX (WM_USER_MIN+1)
+
+struct thread_intern {
+ /* XXX can probably use one buffer instead of several */
+ char Wstrerror_buffer[512];
+ struct servent Wservent;
+ char Wgetlogin_buffer[128];
+# ifdef USE_SOCKETS_AS_HANDLES
+ int Winit_socktype;
+# endif
+# ifdef HAVE_DES_FCRYPT
+ char Wcrypt_buffer[30];
+# endif
+# ifdef USE_RTL_THREAD_API
+ void * retv; /* slot for thread return value */
+# endif
+ BOOL Wuse_showwindow;
+ WORD Wshowwindow;
+};
+
+#define HAVE_INTERP_INTERN
+typedef struct {
+ long num;
+ DWORD pids[MAXIMUM_WAIT_OBJECTS];
+ HANDLE handles[MAXIMUM_WAIT_OBJECTS];
+} child_tab;
+
+#ifdef USE_ITHREADS
+typedef struct {
+ long num;
+ DWORD pids[MAXIMUM_WAIT_OBJECTS];
+ HANDLE handles[MAXIMUM_WAIT_OBJECTS];
+ HWND message_hwnds[MAXIMUM_WAIT_OBJECTS];
+} pseudo_child_tab;
+#endif
+
+#ifndef Sighandler_t
+typedef Signal_t (*Sighandler_t) (int);
+#define Sighandler_t Sighandler_t
+#endif
+
+struct interp_intern {
+ char * perlshell_tokens;
+ char ** perlshell_vec;
+ long perlshell_items;
+ struct av * fdpid;
+ child_tab * children;
+#ifdef USE_ITHREADS
+ DWORD pseudo_id;
+ pseudo_child_tab * pseudo_children;
+#endif
+ void * internal_host;
+ struct thread_intern thr_intern;
+ HWND message_hwnd;
+ UINT timerid;
+ unsigned poll_count;
+ Sighandler_t sigtable[SIG_SIZE];
+};
+
+DllExport int win32_async_check(pTHX);
+
+#define WIN32_POLL_INTERVAL 32768
+#define PERL_ASYNC_CHECK() if (w32_do_async || PL_sig_pending) win32_async_check(aTHX)
+
+#define w32_perlshell_tokens (PL_sys_intern.perlshell_tokens)
+#define w32_perlshell_vec (PL_sys_intern.perlshell_vec)
+#define w32_perlshell_items (PL_sys_intern.perlshell_items)
+#define w32_fdpid (PL_sys_intern.fdpid)
+#define w32_children (PL_sys_intern.children)
+#define w32_num_children (w32_children->num)
+#define w32_child_pids (w32_children->pids)
+#define w32_child_handles (w32_children->handles)
+#define w32_pseudo_id (PL_sys_intern.pseudo_id)
+#define w32_pseudo_children (PL_sys_intern.pseudo_children)
+#define w32_num_pseudo_children (w32_pseudo_children->num)
+#define w32_pseudo_child_pids (w32_pseudo_children->pids)
+#define w32_pseudo_child_handles (w32_pseudo_children->handles)
+#define w32_pseudo_child_message_hwnds (w32_pseudo_children->message_hwnds)
+#define w32_internal_host (PL_sys_intern.internal_host)
+#define w32_timerid (PL_sys_intern.timerid)
+#define w32_message_hwnd (PL_sys_intern.message_hwnd)
+#define w32_sighandler (PL_sys_intern.sigtable)
+#define w32_poll_count (PL_sys_intern.poll_count)
+#define w32_do_async (w32_poll_count++ > WIN32_POLL_INTERVAL)
+#define w32_strerror_buffer (PL_sys_intern.thr_intern.Wstrerror_buffer)
+#define w32_getlogin_buffer (PL_sys_intern.thr_intern.Wgetlogin_buffer)
+#define w32_crypt_buffer (PL_sys_intern.thr_intern.Wcrypt_buffer)
+#define w32_servent (PL_sys_intern.thr_intern.Wservent)
+#define w32_init_socktype (PL_sys_intern.thr_intern.Winit_socktype)
+#define w32_use_showwindow (PL_sys_intern.thr_intern.Wuse_showwindow)
+#define w32_showwindow (PL_sys_intern.thr_intern.Wshowwindow)
+
+#ifdef USE_ITHREADS
+# define PERL_WAIT_FOR_CHILDREN \
+ STMT_START { \
+ if (w32_pseudo_children && w32_num_pseudo_children) { \
+ long children = w32_num_pseudo_children; \
+ WaitForMultipleObjects(children, \
+ w32_pseudo_child_handles, \
+ TRUE, INFINITE); \
+ while (children) \
+ CloseHandle(w32_pseudo_child_handles[--children]); \
+ } \
+ } STMT_END
+#endif
+
+#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX)
+#ifdef PERL_CORE
+
+/* C doesn't like repeat struct definitions */
+#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION>=3)
+#undef _CRTIMP
+#endif
+#ifndef _CRTIMP
+#define _CRTIMP __declspec(dllimport)
+#endif
+
+/*
+ * Control structure for lowio file handles
+ */
+typedef struct {
+ intptr_t osfhnd;/* underlying OS file HANDLE */
+ char osfile; /* attributes of file (e.g., open in text mode?) */
+ char pipech; /* one char buffer for handles opened on pipes */
+ int lockinitflag;
+ CRITICAL_SECTION lock;
+} ioinfo;
+
+
+/*
+ * Array of arrays of control structures for lowio files.
+ */
+EXTERN_C _CRTIMP ioinfo* __pioinfo[];
+
+/*
+ * Definition of IOINFO_L2E, the log base 2 of the number of elements in each
+ * array of ioinfo structs.
+ */
+#define IOINFO_L2E 5
+
+/*
+ * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array
+ */
+#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
+
+/*
+ * Access macros for getting at an ioinfo struct and its fields from a
+ * file handle
+ */
+#define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1)))
+#define _osfhnd(i) (_pioinfo(i)->osfhnd)
+#define _osfile(i) (_pioinfo(i)->osfile)
+#define _pipech(i) (_pioinfo(i)->pipech)
+
+/* since we are not doing a dup2(), this works fine */
+#define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = (intptr_t)osfh)
+#endif
+#endif
+
+/* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */
+#if defined(PERL_EXT_IO) || defined(PERL_EXT_POSIX)
+#undef PERLIO_NOT_STDIO
+#endif
+#define PERLIO_NOT_STDIO 0
+
+#include "perlio.h"
+
+/*
+ * This provides a layer of functions and macros to ensure extensions will
+ * get to use the same RTL functions as the core.
+ */
+#include "win32iop.h"
+
+#define EXEC_ARGV_CAST(x) ((const char *const *) x)
+
+#if !defined(ECONNABORTED) && defined(WSAECONNABORTED)
+#define ECONNABORTED WSAECONNABORTED
+#endif
+#if !defined(ECONNRESET) && defined(WSAECONNRESET)
+#define ECONNRESET WSAECONNRESET
+#endif
+#if !defined(EAFNOSUPPORT) && defined(WSAEAFNOSUPPORT)
+#define EAFNOSUPPORT WSAEAFNOSUPPORT
+#endif
+/* Why not needed for ECONNREFUSED? --abe */
+
+DllExport void *win32_signal_context(void);
+#define PERL_GET_SIG_CONTEXT win32_signal_context()
+
+#ifdef UNDER_CE
+#define Win_GetModuleHandle XCEGetModuleHandleA
+#define Win_GetProcAddress XCEGetProcAddressA
+#define Win_GetModuleFileName XCEGetModuleFileNameA
+#define Win_CreateSemaphore CreateSemaphoreW
+#else
+#define Win_GetModuleHandle GetModuleHandle
+#define Win_GetProcAddress GetProcAddress
+#define Win_GetModuleFileName GetModuleFileName
+#define Win_CreateSemaphore CreateSemaphore
+#endif
+
+#endif /* _INC_WIN32_PERL5 */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/win32iop-o.h b/Master/tlpkg/tlperl.straw/lib/CORE/win32iop-o.h
new file mode 100755
index 00000000000..57b073ba874
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/win32iop-o.h
@@ -0,0 +1,340 @@
+/* Time-stamp: <01/08/01 21:00:16 keuchel@w2k> */
+
+#ifndef WIN32IOP_H
+#define WIN32IOP_H
+
+#ifndef START_EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C
+#endif
+#endif
+
+#ifndef UNDER_CE
+#if defined(_MSC_VER) || defined(__MINGW32__)
+# include <sys/utime.h>
+#else
+# include <utime.h>
+#endif
+#endif
+
+/*
+ * defines for flock emulation
+ */
+#define LOCK_SH 1
+#define LOCK_EX 2
+#define LOCK_NB 4
+#define LOCK_UN 8
+
+/*
+ * Make this as close to original stdio as possible.
+ */
+
+/*
+ * function prototypes for our own win32io layer
+ */
+START_EXTERN_C
+
+DllExport int * win32_errno(void);
+DllExport char *** win32_environ(void);
+DllExport FILE* win32_stdin(void);
+DllExport FILE* win32_stdout(void);
+DllExport FILE* win32_stderr(void);
+DllExport int win32_ferror(FILE *fp);
+DllExport int win32_feof(FILE *fp);
+DllExport char* win32_strerror(int e);
+
+DllExport int win32_fprintf(FILE *pf, const char *format, ...);
+DllExport int win32_printf(const char *format, ...);
+DllExport int win32_vfprintf(FILE *pf, const char *format, va_list arg);
+DllExport int win32_vprintf(const char *format, va_list arg);
+DllExport size_t win32_fread(void *buf, size_t size, size_t count, FILE *pf);
+DllExport size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf);
+DllExport FILE* win32_fopen(const char *path, const char *mode);
+DllExport FILE* win32_fdopen(int fh, const char *mode);
+DllExport FILE* win32_freopen(const char *path, const char *mode, FILE *pf);
+DllExport int win32_fclose(FILE *pf);
+DllExport int win32_fputs(const char *s,FILE *pf);
+DllExport int win32_fputc(int c,FILE *pf);
+DllExport int win32_ungetc(int c,FILE *pf);
+DllExport int win32_getc(FILE *pf);
+DllExport int win32_fileno(FILE *pf);
+DllExport void win32_clearerr(FILE *pf);
+DllExport int win32_fflush(FILE *pf);
+DllExport long win32_ftell(FILE *pf);
+DllExport int win32_fseek(FILE *pf,long offset,int origin);
+DllExport int win32_fgetpos(FILE *pf,fpos_t *p);
+DllExport int win32_fsetpos(FILE *pf,const fpos_t *p);
+DllExport void win32_rewind(FILE *pf);
+DllExport FILE* win32_tmpfile(void);
+DllExport int win32_tmpfd(void);
+DllExport void win32_abort(void);
+DllExport int win32_fstat(int fd,struct stat *sbufptr);
+DllExport int win32_stat(const char *name,struct stat *sbufptr);
+DllExport int win32_pipe( int *phandles, unsigned int psize, int textmode );
+DllExport PerlIO* win32_popen( const char *command, const char *mode );
+DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args);
+DllExport int win32_pclose( FILE *pf);
+DllExport int win32_rename( const char *oname, const char *newname);
+DllExport int win32_setmode( int fd, int mode);
+DllExport int win32_chsize(int fd, Off_t size);
+DllExport long win32_lseek( int fd, long offset, int origin);
+DllExport long win32_tell( int fd);
+DllExport int win32_dup( int fd);
+DllExport int win32_dup2(int h1, int h2);
+DllExport int win32_open(const char *path, int oflag,...);
+DllExport int win32_close(int fd);
+DllExport int win32_eof(int fd);
+DllExport int win32_read(int fd, void *buf, unsigned int cnt);
+DllExport int win32_write(int fd, const void *buf, unsigned int cnt);
+DllExport int win32_spawnvp(int mode, const char *cmdname,
+ const char *const *argv);
+DllExport int win32_mkdir(const char *dir, int mode);
+DllExport int win32_rmdir(const char *dir);
+DllExport int win32_chdir(const char *dir);
+DllExport int win32_flock(int fd, int oper);
+DllExport int win32_execv(const char *cmdname, const char *const *argv);
+DllExport int win32_execvp(const char *cmdname, const char *const *argv);
+DllExport void win32_perror(const char *str);
+DllExport void win32_setbuf(FILE *pf, char *buf);
+DllExport int win32_setvbuf(FILE *pf, char *buf, int type, size_t size);
+DllExport int win32_flushall(void);
+DllExport int win32_fcloseall(void);
+DllExport char* win32_fgets(char *s, int n, FILE *pf);
+DllExport char* win32_gets(char *s);
+DllExport int win32_fgetc(FILE *pf);
+DllExport int win32_putc(int c, FILE *pf);
+DllExport int win32_puts(const char *s);
+DllExport int win32_getchar(void);
+DllExport int win32_putchar(int c);
+DllExport void* win32_malloc(size_t size);
+DllExport void* win32_calloc(size_t numitems, size_t size);
+DllExport void* win32_realloc(void *block, size_t size);
+DllExport void win32_free(void *block);
+
+DllExport int win32_open_osfhandle(long handle, int flags);
+DllExport long win32_get_osfhandle(int fd);
+
+DllExport DIR* win32_opendir(char *filename);
+DllExport struct direct* win32_readdir(DIR *dirp);
+DllExport long win32_telldir(DIR *dirp);
+DllExport void win32_seekdir(DIR *dirp, long loc);
+DllExport void win32_rewinddir(DIR *dirp);
+DllExport int win32_closedir(DIR *dirp);
+
+DllExport char* win32_getenv(const char *name);
+DllExport int win32_putenv(const char *name);
+
+DllExport unsigned win32_sleep(unsigned int);
+DllExport int win32_times(struct tms *timebuf);
+DllExport unsigned win32_alarm(unsigned int sec);
+DllExport int win32_stat(const char *path, struct stat *buf);
+DllExport char* win32_longpath(char *path);
+DllExport int win32_ioctl(int i, unsigned int u, char *data);
+DllExport int win32_link(const char *oldname, const char *newname);
+DllExport int win32_gettimeofday(struct timeval *tp, void *not_used);
+DllExport int win32_unlink(const char *f);
+DllExport int win32_utime(const char *f, struct utimbuf *t);
+DllExport int win32_uname(struct utsname *n);
+DllExport int win32_wait(int *status);
+DllExport int win32_waitpid(int pid, int *status, int flags);
+DllExport int win32_kill(int pid, int sig);
+DllExport unsigned long win32_os_id(void);
+DllExport void* win32_dynaload(const char*filename);
+DllExport int win32_access(const char *path, int mode);
+DllExport int win32_chmod(const char *path, int mode);
+DllExport int win32_getpid(void);
+DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode);
+
+DllExport char * win32_crypt(const char *txt, const char *salt);
+
+END_EXTERN_C
+
+/*
+ * the following six(6) is #define in stdio.h
+ */
+#ifndef WIN32IO_IS_STDIO
+#undef errno
+#undef environ
+#undef stderr
+#undef stdin
+#undef stdout
+#undef ferror
+#undef feof
+#undef fclose
+#undef pipe
+#undef pause
+#undef sleep
+#undef times
+#undef alarm
+#undef ioctl
+#undef unlink
+#undef utime
+#undef uname
+#undef wait
+
+#ifdef __BORLANDC__
+#undef ungetc
+#undef getc
+#undef putc
+#undef getchar
+#undef putchar
+#undef fileno
+#endif
+
+#define stderr win32_stderr()
+#define stdout win32_stdout()
+#define stdin win32_stdin()
+#define feof(f) win32_feof(f)
+#define ferror(f) win32_ferror(f)
+#define errno (*win32_errno())
+#define environ (*win32_environ())
+#define strerror win32_strerror
+
+/*
+ * redirect to our own version
+ */
+#undef fprintf
+#define fprintf win32_fprintf
+#undef vfprintf
+#define vfprintf win32_vfprintf
+#undef printf
+#define printf win32_printf
+#undef vprintf
+#define vprintf win32_vprintf
+#undef fread
+#define fread(buf,size,count,f) win32_fread(buf,size,count,f)
+#undef fwrite
+#define fwrite(buf,size,count,f) win32_fwrite(buf,size,count,f)
+#undef fopen
+#define fopen win32_fopen
+#undef fdopen
+#define fdopen win32_fdopen
+#undef freopen
+#define freopen win32_freopen
+#define fclose(f) win32_fclose(f)
+#undef fputs
+#define fputs(s,f) win32_fputs(s,f)
+#undef fputc
+#define fputc(c,f) win32_fputc(c,f)
+#undef ungetc
+#define ungetc(c,f) win32_ungetc(c,f)
+#undef getc
+#define getc(f) win32_getc(f)
+#undef fileno
+#define fileno(f) win32_fileno(f)
+#undef clearerr
+#define clearerr(f) win32_clearerr(f)
+#undef fflush
+#define fflush(f) win32_fflush(f)
+#undef ftell
+#define ftell(f) win32_ftell(f)
+#undef fseek
+#define fseek(f,o,w) win32_fseek(f,o,w)
+#undef fgetpos
+#define fgetpos(f,p) win32_fgetpos(f,p)
+#undef fsetpos
+#define fsetpos(f,p) win32_fsetpos(f,p)
+#undef rewind
+#define rewind(f) win32_rewind(f)
+#define tmpfile() win32_tmpfile()
+#define abort() win32_abort()
+#define fstat(fd,bufptr) win32_fstat(fd,bufptr)
+#define stat(pth,bufptr) win32_stat(pth,bufptr)
+#define longpath(pth) win32_longpath(pth)
+#define rename(old,new) win32_rename(old,new)
+#define setmode(fd,mode) win32_setmode(fd,mode)
+#define lseek(fd,offset,orig) win32_lseek(fd,offset,orig)
+#define tell(fd) win32_tell(fd)
+#define dup(fd) win32_dup(fd)
+#define dup2(fd1,fd2) win32_dup2(fd1,fd2)
+#define open win32_open
+#define close(fd) win32_close(fd)
+#define eof(fd) win32_eof(fd)
+#define read(fd,b,s) win32_read(fd,b,s)
+#define write(fd,b,s) win32_write(fd,b,s)
+#define _open_osfhandle win32_open_osfhandle
+#define _get_osfhandle win32_get_osfhandle
+#define spawnvp win32_spawnvp
+#define mkdir win32_mkdir
+#define rmdir win32_rmdir
+#define chdir win32_chdir
+#define flock(fd,o) win32_flock(fd,o)
+#define execv win32_execv
+#define execvp win32_execvp
+#define perror win32_perror
+#define setbuf win32_setbuf
+#undef setvbuf
+#define setvbuf win32_setvbuf
+#undef flushall
+#define flushall win32_flushall
+#undef fcloseall
+#define fcloseall win32_fcloseall
+#undef fgets
+#define fgets win32_fgets
+#undef gets
+#define gets win32_gets
+#undef fgetc
+#define fgetc win32_fgetc
+#undef putc
+#define putc win32_putc
+#undef puts
+#define puts win32_puts
+#undef getchar
+#define getchar win32_getchar
+#undef putchar
+#define putchar win32_putchar
+#define access(p,m) win32_access(p,m)
+#define chmod(p,m) win32_chmod(p,m)
+
+
+#if !defined(MYMALLOC) || !defined(PERL_CORE)
+#undef malloc
+#undef calloc
+#undef realloc
+#undef free
+#define malloc win32_malloc
+#define calloc win32_calloc
+#define realloc win32_realloc
+#define free win32_free
+#endif
+
+#define pipe(fd) win32_pipe((fd), 512, O_BINARY)
+#define pause() win32_sleep((32767L << 16) + 32767)
+#define sleep win32_sleep
+#define times win32_times
+#define alarm win32_alarm
+#define ioctl win32_ioctl
+#define link win32_link
+#define unlink win32_unlink
+#define utime win32_utime
+#define uname win32_uname
+#define wait win32_wait
+#define waitpid win32_waitpid
+#define kill win32_kill
+
+#define opendir win32_opendir
+#define readdir win32_readdir
+#define telldir win32_telldir
+#define seekdir win32_seekdir
+#define rewinddir win32_rewinddir
+#define closedir win32_closedir
+#define os_id win32_os_id
+#define getpid win32_getpid
+
+#undef crypt
+#define crypt(t,s) win32_crypt(t,s)
+
+#undef getenv
+#define getenv win32_getenv
+#undef putenv
+#define putenv win32_putenv
+
+#endif /* WIN32IO_IS_STDIO */
+#endif /* WIN32IOP_H */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/win32iop.h b/Master/tlpkg/tlperl.straw/lib/CORE/win32iop.h
new file mode 100755
index 00000000000..b03e9a753cd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/win32iop.h
@@ -0,0 +1,340 @@
+#ifndef WIN32IOP_H
+#define WIN32IOP_H
+
+#ifndef START_EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C
+#endif
+#endif
+
+#if defined(_MSC_VER) || defined(__MINGW32__)
+# include <sys/utime.h>
+#else
+# include <utime.h>
+#endif
+
+/*
+ * defines for flock emulation
+ */
+#define LOCK_SH 1
+#define LOCK_EX 2
+#define LOCK_NB 4
+#define LOCK_UN 8
+
+/*
+ * Make this as close to original stdio as possible.
+ */
+
+/*
+ * function prototypes for our own win32io layer
+ */
+START_EXTERN_C
+
+DllExport int * win32_errno(void);
+DllExport char *** win32_environ(void);
+DllExport FILE* win32_stdin(void);
+DllExport FILE* win32_stdout(void);
+DllExport FILE* win32_stderr(void);
+DllExport int win32_ferror(FILE *fp);
+DllExport int win32_feof(FILE *fp);
+DllExport char* win32_strerror(int e);
+
+DllExport int win32_fprintf(FILE *pf, const char *format, ...);
+DllExport int win32_printf(const char *format, ...);
+DllExport int win32_vfprintf(FILE *pf, const char *format, va_list arg);
+DllExport int win32_vprintf(const char *format, va_list arg);
+DllExport size_t win32_fread(void *buf, size_t size, size_t count, FILE *pf);
+DllExport size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf);
+DllExport FILE* win32_fopen(const char *path, const char *mode);
+DllExport FILE* win32_fdopen(int fh, const char *mode);
+DllExport FILE* win32_freopen(const char *path, const char *mode, FILE *pf);
+DllExport int win32_fclose(FILE *pf);
+DllExport int win32_fputs(const char *s,FILE *pf);
+DllExport int win32_fputc(int c,FILE *pf);
+DllExport int win32_ungetc(int c,FILE *pf);
+DllExport int win32_getc(FILE *pf);
+DllExport int win32_fileno(FILE *pf);
+DllExport void win32_clearerr(FILE *pf);
+DllExport int win32_fflush(FILE *pf);
+DllExport Off_t win32_ftell(FILE *pf);
+DllExport int win32_fseek(FILE *pf,Off_t offset,int origin);
+DllExport int win32_fgetpos(FILE *pf,fpos_t *p);
+DllExport int win32_fsetpos(FILE *pf,const fpos_t *p);
+DllExport void win32_rewind(FILE *pf);
+DllExport int win32_tmpfd(void);
+DllExport FILE* win32_tmpfile(void);
+DllExport void win32_abort(void);
+DllExport int win32_fstat(int fd,Stat_t *sbufptr);
+DllExport int win32_stat(const char *name,Stat_t *sbufptr);
+DllExport int win32_pipe( int *phandles, unsigned int psize, int textmode );
+DllExport PerlIO* win32_popen( const char *command, const char *mode );
+DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args);
+DllExport int win32_pclose( PerlIO *pf);
+DllExport int win32_rename( const char *oname, const char *newname);
+DllExport int win32_setmode( int fd, int mode);
+DllExport int win32_chsize(int fd, Off_t size);
+DllExport Off_t win32_lseek( int fd, Off_t offset, int origin);
+DllExport Off_t win32_tell( int fd);
+DllExport int win32_dup( int fd);
+DllExport int win32_dup2(int h1, int h2);
+DllExport int win32_open(const char *path, int oflag,...);
+DllExport int win32_close(int fd);
+DllExport int win32_eof(int fd);
+DllExport int win32_read(int fd, void *buf, unsigned int cnt);
+DllExport int win32_write(int fd, const void *buf, unsigned int cnt);
+DllExport int win32_spawnvp(int mode, const char *cmdname,
+ const char *const *argv);
+DllExport int win32_mkdir(const char *dir, int mode);
+DllExport int win32_rmdir(const char *dir);
+DllExport int win32_chdir(const char *dir);
+DllExport int win32_flock(int fd, int oper);
+DllExport int win32_execv(const char *cmdname, const char *const *argv);
+DllExport int win32_execvp(const char *cmdname, const char *const *argv);
+DllExport void win32_perror(const char *str);
+DllExport void win32_setbuf(FILE *pf, char *buf);
+DllExport int win32_setvbuf(FILE *pf, char *buf, int type, size_t size);
+DllExport int win32_flushall(void);
+DllExport int win32_fcloseall(void);
+DllExport char* win32_fgets(char *s, int n, FILE *pf);
+DllExport char* win32_gets(char *s);
+DllExport int win32_fgetc(FILE *pf);
+DllExport int win32_putc(int c, FILE *pf);
+DllExport int win32_puts(const char *s);
+DllExport int win32_getchar(void);
+DllExport int win32_putchar(int c);
+DllExport void* win32_malloc(size_t size);
+DllExport void* win32_calloc(size_t numitems, size_t size);
+DllExport void* win32_realloc(void *block, size_t size);
+DllExport void win32_free(void *block);
+
+DllExport int win32_open_osfhandle(intptr_t handle, int flags);
+DllExport intptr_t win32_get_osfhandle(int fd);
+DllExport FILE* win32_fdupopen(FILE *pf);
+
+DllExport DIR* win32_opendir(const char *filename);
+DllExport struct direct* win32_readdir(DIR *dirp);
+DllExport long win32_telldir(DIR *dirp);
+DllExport void win32_seekdir(DIR *dirp, long loc);
+DllExport void win32_rewinddir(DIR *dirp);
+DllExport int win32_closedir(DIR *dirp);
+
+DllExport char* win32_getenv(const char *name);
+DllExport int win32_putenv(const char *name);
+
+DllExport unsigned win32_sleep(unsigned int);
+DllExport int win32_times(struct tms *timebuf);
+DllExport unsigned win32_alarm(unsigned int sec);
+DllExport int win32_stat(const char *path, Stat_t *buf);
+DllExport char* win32_longpath(char *path);
+DllExport char* win32_ansipath(const WCHAR *path);
+DllExport int win32_ioctl(int i, unsigned int u, char *data);
+DllExport int win32_link(const char *oldname, const char *newname);
+DllExport int win32_unlink(const char *f);
+DllExport int win32_utime(const char *f, struct utimbuf *t);
+DllExport int win32_gettimeofday(struct timeval *tp, void *not_used);
+DllExport int win32_uname(struct utsname *n);
+DllExport int win32_wait(int *status);
+DllExport int win32_waitpid(int pid, int *status, int flags);
+DllExport int win32_kill(int pid, int sig);
+DllExport unsigned long win32_os_id(void);
+DllExport void* win32_dynaload(const char*filename);
+DllExport int win32_access(const char *path, int mode);
+DllExport int win32_chmod(const char *path, int mode);
+DllExport int win32_getpid(void);
+
+DllExport char * win32_crypt(const char *txt, const char *salt);
+
+DllExport void * win32_get_childenv(void);
+DllExport void win32_free_childenv(void* d);
+DllExport void win32_clearenv(void);
+DllExport char * win32_get_childdir(void);
+DllExport void win32_free_childdir(char* d);
+DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode);
+
+
+END_EXTERN_C
+
+#undef alarm
+#define alarm win32_alarm
+
+/*
+ * the following six(6) is #define in stdio.h
+ */
+#ifndef WIN32IO_IS_STDIO
+#undef errno
+#undef environ
+#undef stderr
+#undef stdin
+#undef stdout
+#undef ferror
+#undef feof
+#undef fclose
+#undef pipe
+#undef pause
+#undef sleep
+#undef times
+#undef ioctl
+#undef unlink
+#undef utime
+#undef gettimeofday
+#undef uname
+#undef wait
+
+#ifdef __BORLANDC__
+#undef ungetc
+#undef getc
+#undef putc
+#undef getchar
+#undef putchar
+#endif
+
+#if defined(__MINGW32__) || defined(__BORLANDC__)
+#undef fileno
+#endif
+
+#define stderr win32_stderr()
+#define stdout win32_stdout()
+#define stdin win32_stdin()
+#define feof(f) win32_feof(f)
+#define ferror(f) win32_ferror(f)
+#define errno (*win32_errno())
+#define environ (*win32_environ())
+#define strerror win32_strerror
+
+/*
+ * redirect to our own version
+ */
+#undef fprintf
+#define fprintf win32_fprintf
+#define vfprintf win32_vfprintf
+#define printf win32_printf
+#define vprintf win32_vprintf
+#define fread(buf,size,count,f) win32_fread(buf,size,count,f)
+#define fwrite(buf,size,count,f) win32_fwrite(buf,size,count,f)
+#define fopen win32_fopen
+#undef fdopen
+#define fdopen win32_fdopen
+#define freopen win32_freopen
+#define fclose(f) win32_fclose(f)
+#define fputs(s,f) win32_fputs(s,f)
+#define fputc(c,f) win32_fputc(c,f)
+#define ungetc(c,f) win32_ungetc(c,f)
+#undef getc
+#define getc(f) win32_getc(f)
+#define fileno(f) win32_fileno(f)
+#define clearerr(f) win32_clearerr(f)
+#define fflush(f) win32_fflush(f)
+#define ftell(f) win32_ftell(f)
+#define fseek(f,o,w) win32_fseek(f,o,w)
+#define fgetpos(f,p) win32_fgetpos(f,p)
+#define fsetpos(f,p) win32_fsetpos(f,p)
+#define rewind(f) win32_rewind(f)
+#define tmpfile() win32_tmpfile()
+#define abort() win32_abort()
+#define fstat(fd,bufptr) win32_fstat(fd,bufptr)
+#define stat(pth,bufptr) win32_stat(pth,bufptr)
+#define longpath(pth) win32_longpath(pth)
+#define ansipath(pth) win32_ansipath(pth)
+#define rename(old,new) win32_rename(old,new)
+#define setmode(fd,mode) win32_setmode(fd,mode)
+#define chsize(fd,sz) win32_chsize(fd,sz)
+#define lseek(fd,offset,orig) win32_lseek(fd,offset,orig)
+#define tell(fd) win32_tell(fd)
+#define dup(fd) win32_dup(fd)
+#define dup2(fd1,fd2) win32_dup2(fd1,fd2)
+#define open win32_open
+#define close(fd) win32_close(fd)
+#define eof(fd) win32_eof(fd)
+#define read(fd,b,s) win32_read(fd,b,s)
+#define write(fd,b,s) win32_write(fd,b,s)
+#define _open_osfhandle win32_open_osfhandle
+#define _get_osfhandle win32_get_osfhandle
+#define spawnvp win32_spawnvp
+#define mkdir win32_mkdir
+#define rmdir win32_rmdir
+#define chdir win32_chdir
+#define flock(fd,o) win32_flock(fd,o)
+#define execv win32_execv
+#define execvp win32_execvp
+#define perror win32_perror
+#define setbuf win32_setbuf
+#define setvbuf win32_setvbuf
+#undef flushall
+#define flushall win32_flushall
+#undef fcloseall
+#define fcloseall win32_fcloseall
+#define fgets win32_fgets
+#define gets win32_gets
+#define fgetc win32_fgetc
+#undef putc
+#define putc win32_putc
+#define puts win32_puts
+#undef getchar
+#define getchar win32_getchar
+#undef putchar
+#define putchar win32_putchar
+#define access(p,m) win32_access(p,m)
+#define chmod(p,m) win32_chmod(p,m)
+
+
+#if !defined(MYMALLOC) || !defined(PERL_CORE)
+#undef malloc
+#undef calloc
+#undef realloc
+#undef free
+#define malloc win32_malloc
+#define calloc win32_calloc
+#define realloc win32_realloc
+#define free win32_free
+#endif
+
+#define pipe(fd) win32_pipe((fd), 512, O_BINARY)
+#define pause() win32_sleep((32767L << 16) + 32767)
+#define sleep win32_sleep
+#define times win32_times
+#define ioctl win32_ioctl
+#define link win32_link
+#define unlink win32_unlink
+#define utime win32_utime
+#define gettimeofday win32_gettimeofday
+#define uname win32_uname
+#define wait win32_wait
+#define waitpid win32_waitpid
+#define kill win32_kill
+
+#define opendir win32_opendir
+#define readdir win32_readdir
+#define telldir win32_telldir
+#define seekdir win32_seekdir
+#define rewinddir win32_rewinddir
+#define closedir win32_closedir
+#define os_id win32_os_id
+#define getpid win32_getpid
+
+#undef crypt
+#define crypt(t,s) win32_crypt(t,s)
+
+#undef get_childenv
+#undef free_childenv
+#undef clearenv
+#undef get_childdir
+#undef free_childdir
+#define get_childenv() win32_get_childenv()
+#define free_childenv(d) win32_free_childenv(d)
+#define clearenv() win32_clearenv()
+#define get_childdir() win32_get_childdir()
+#define free_childdir(d) win32_free_childdir(d)
+
+#undef getenv
+#define getenv win32_getenv
+#undef putenv
+#define putenv win32_putenv
+
+#endif /* WIN32IO_IS_STDIO */
+#endif /* WIN32IOP_H */
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/win32thread.h b/Master/tlpkg/tlperl.straw/lib/CORE/win32thread.h
new file mode 100755
index 00000000000..c6f93097ffa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/win32thread.h
@@ -0,0 +1,197 @@
+#ifndef _WIN32THREAD_H
+#define _WIN32THREAD_H
+
+#include "win32.h"
+
+typedef struct win32_cond { LONG waiters; HANDLE sem; } perl_cond;
+typedef DWORD perl_key;
+typedef HANDLE perl_os_thread;
+
+#ifndef DONT_USE_CRITICAL_SECTION
+
+/* Critical Sections used instead of mutexes: lightweight,
+ * but can't be communicated to child processes, and can't get
+ * HANDLE to it for use elsewhere.
+ */
+typedef CRITICAL_SECTION perl_mutex;
+#define MUTEX_INIT(m) InitializeCriticalSection(m)
+#define MUTEX_LOCK(m) EnterCriticalSection(m)
+#define MUTEX_UNLOCK(m) LeaveCriticalSection(m)
+#define MUTEX_DESTROY(m) DeleteCriticalSection(m)
+
+#else
+
+typedef HANDLE perl_mutex;
+# define MUTEX_INIT(m) \
+ STMT_START { \
+ if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL) \
+ Perl_croak_nocontext("panic: MUTEX_INIT"); \
+ } STMT_END
+
+# define MUTEX_LOCK(m) \
+ STMT_START { \
+ if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \
+ Perl_croak_nocontext("panic: MUTEX_LOCK"); \
+ } STMT_END
+
+# define MUTEX_UNLOCK(m) \
+ STMT_START { \
+ if (ReleaseMutex(*(m)) == 0) \
+ Perl_croak_nocontext("panic: MUTEX_UNLOCK"); \
+ } STMT_END
+
+# define MUTEX_DESTROY(m) \
+ STMT_START { \
+ if (CloseHandle(*(m)) == 0) \
+ Perl_croak_nocontext("panic: MUTEX_DESTROY"); \
+ } STMT_END
+
+#endif
+
+/* These macros assume that the mutex associated with the condition
+ * will always be held before COND_{SIGNAL,BROADCAST,WAIT,DESTROY},
+ * so there's no separate mutex protecting access to (c)->waiters
+ */
+#define COND_INIT(c) \
+ STMT_START { \
+ (c)->waiters = 0; \
+ (c)->sem = Win_CreateSemaphore(NULL,0,LONG_MAX,NULL); \
+ if ((c)->sem == NULL) \
+ Perl_croak_nocontext("panic: COND_INIT (%ld)",GetLastError()); \
+ } STMT_END
+
+#define COND_SIGNAL(c) \
+ STMT_START { \
+ if ((c)->waiters > 0 && \
+ ReleaseSemaphore((c)->sem,1,NULL) == 0) \
+ Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",GetLastError()); \
+ } STMT_END
+
+#define COND_BROADCAST(c) \
+ STMT_START { \
+ if ((c)->waiters > 0 && \
+ ReleaseSemaphore((c)->sem,(c)->waiters,NULL) == 0) \
+ Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\
+ } STMT_END
+
+#define COND_WAIT(c, m) \
+ STMT_START { \
+ (c)->waiters++; \
+ MUTEX_UNLOCK(m); \
+ /* Note that there's no race here, since a \
+ * COND_BROADCAST() on another thread will have seen the\
+ * right number of waiters (i.e. including this one) */ \
+ if (WaitForSingleObject((c)->sem,INFINITE)==WAIT_FAILED)\
+ Perl_croak_nocontext("panic: COND_WAIT (%ld)",GetLastError()); \
+ /* XXX there may be an inconsequential race here */ \
+ MUTEX_LOCK(m); \
+ (c)->waiters--; \
+ } STMT_END
+
+#define COND_DESTROY(c) \
+ STMT_START { \
+ (c)->waiters = 0; \
+ if (CloseHandle((c)->sem) == 0) \
+ Perl_croak_nocontext("panic: COND_DESTROY (%ld)",GetLastError()); \
+ } STMT_END
+
+#define DETACH(t) \
+ STMT_START { \
+ if (CloseHandle((t)->self) == 0) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ Perl_croak_nocontext("panic: DETACH"); \
+ } \
+ } STMT_END
+
+
+#define THREAD_CREATE(t, f) Perl_thread_create(t, f)
+#define THREAD_POST_CREATE(t) NOOP
+
+/* XXX Docs mention that the RTL versions of thread creation routines
+ * should be used, but that advice only seems applicable when the RTL
+ * is not in a DLL. RTL DLLs in both Borland and VC seem to do all of
+ * the init/deinit required upon DLL_THREAD_ATTACH/DETACH. So we seem
+ * to be completely safe using straight Win32 API calls, rather than
+ * the much braindamaged RTL calls.
+ *
+ * _beginthread() in the RTLs call CloseHandle() just after the thread
+ * function returns, which means: 1) we have a race on our hands
+ * 2) it is impossible to implement join() semantics.
+ *
+ * IOW, do *NOT* turn on USE_RTL_THREAD_API! It is here
+ * for experimental purposes only. GSAR 98-01-02
+ */
+#ifdef USE_RTL_THREAD_API
+# include <process.h>
+# if defined(__BORLANDC__)
+ /* Borland RTL doesn't allow a return value from thread function! */
+# define THREAD_RET_TYPE void _USERENTRY
+# define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p)))
+# elif defined (_MSC_VER)
+# define THREAD_RET_TYPE unsigned __stdcall
+# define THREAD_RET_CAST(p) ((unsigned)(p))
+# else
+ /* CRTDLL.DLL doesn't allow a return value from thread function! */
+# define THREAD_RET_TYPE void __cdecl
+# define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p)))
+# endif
+#else /* !USE_RTL_THREAD_API */
+# define THREAD_RET_TYPE DWORD WINAPI
+# define THREAD_RET_CAST(p) ((DWORD)(p))
+#endif /* !USE_RTL_THREAD_API */
+
+typedef THREAD_RET_TYPE thread_func_t(void *);
+
+
+START_EXTERN_C
+
+#if defined(PERLDLL) && defined(USE_DECLSPEC_THREAD) && (!defined(__BORLANDC__) || defined(_DLL))
+extern __declspec(thread) void *PL_current_context;
+#define PERL_SET_CONTEXT(t) (PL_current_context = t)
+#define PERL_GET_CONTEXT PL_current_context
+#else
+#define PERL_GET_CONTEXT Perl_get_context()
+#define PERL_SET_CONTEXT(t) Perl_set_context(t)
+#endif
+
+END_EXTERN_C
+
+#define INIT_THREADS NOOP
+#define ALLOC_THREAD_KEY \
+ STMT_START { \
+ if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) { \
+ PerlIO_printf(PerlIO_stderr(),"panic: TlsAlloc"); \
+ exit(1); \
+ } \
+ } STMT_END
+
+#define FREE_THREAD_KEY \
+ STMT_START { \
+ TlsFree(PL_thr_key); \
+ } STMT_END
+
+#define PTHREAD_ATFORK(prepare,parent,child) NOOP
+
+#if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER)
+#define JOIN(t, avp) \
+ STMT_START { \
+ if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
+ || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \
+ || (CloseHandle((t)->self) == 0)) \
+ Perl_croak_nocontext("panic: JOIN"); \
+ *avp = (AV *)((t)->i.retv); \
+ } STMT_END
+#else /* !USE_RTL_THREAD_API || _MSC_VER */
+#define JOIN(t, avp) \
+ STMT_START { \
+ if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
+ || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \
+ || (CloseHandle((t)->self) == 0)) \
+ Perl_croak_nocontext("panic: JOIN"); \
+ } STMT_END
+#endif /* !USE_RTL_THREAD_API || _MSC_VER */
+
+#define YIELD Sleep(0)
+
+#endif /* _WIN32THREAD_H */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CORE/wince.h b/Master/tlpkg/tlperl.straw/lib/CORE/wince.h
new file mode 100755
index 00000000000..2a97668bb15
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CORE/wince.h
@@ -0,0 +1,146 @@
+/* wince.h */
+
+/* Time-stamp: <01/08/01 20:48:08 keuchel@w2k> */
+
+/* This file includes extracts from the celib-headers, because */
+/* the celib-headers produces macro conflicts with defines in */
+/* win32iop.h etc */
+
+#ifndef WINCE_H
+#define WINCE_H 1
+
+#include "celib_defs.h"
+
+/* include local copies of celib headers... */
+#include "errno.h"
+#include "sys/stat.h"
+#include "time.h"
+#include "cectype.h"
+
+#ifndef START_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C
+#endif
+#endif
+
+START_EXTERN_C
+
+#ifndef _IOFBF
+#define _IOFBF 0x0000
+#endif
+#ifndef _IOLBF
+#define _IOLBF 0x0040
+#endif
+#ifndef _IONBF
+#define _IONBF 0x0004
+#endif
+
+#if UNDER_CE <= 200
+XCE_EXPORT double xceatof(const char *);
+XCE_EXPORT int xcetoupper(int c);
+XCE_EXPORT int xcetolower(int c);
+#define atof xceatof
+#define toupper xcetoupper
+#define tolower xcetolower
+#else
+XCE_EXPORT double atof(const char *);
+#endif
+
+XCE_EXPORT void XCEShowMessageA(const char *fmt, ...);
+
+#define time xcetime
+#define gmtime xcegmtime
+#define localtime xcelocaltime
+#define asctime xceasctime
+/* #define utime xceutime */
+#define futime xcefutime
+#define ftime xceftime
+#define ctime xcectime
+#define gettimeofday xcegettimeofday
+#define GetSystemTimeAsFileTime XCEGetSystemTimeAsFileTime
+
+#define setuid xcesetuid
+#define getuid xcegetuid
+#define geteuid xcegeteuid
+#define seteuid xceseteuid
+
+#define setgid xcesetgid
+#define getgid xcegetgid
+#define getegid xcegetegid
+#define setegid xcesetegid
+
+XCE_EXPORT int xcechown(const char *filename, int owner, int group);
+#define chown xcechown
+
+XCE_EXPORT char *xcestrrchr(const char * string, int ch);
+#define strrchr xcestrrchr
+
+XCE_EXPORT void (*xcesignal(int, void (*)(int)))(int);
+XCE_EXPORT int xceraise(int);
+#define signal xcesignal
+#define raise xceraise
+
+XCE_EXPORT int xcecreat(const char *filename, int pmode);
+XCE_EXPORT int xceopen(const char *fname, int mode, ...);
+XCE_EXPORT int xceread(int fd, void *buf, int size);
+XCE_EXPORT int xcewrite(int fd, void *buf, int size);
+XCE_EXPORT int xceclose(int fd);
+XCE_EXPORT off_t xcelseek(int fd, int off, int whence);
+
+XCE_EXPORT char *xcestrupr(char *string);
+XCE_EXPORT char *xcestrlwr(char *string);
+#define strupr xcestrupr
+#define strlwr xcestrlwr
+
+XCE_EXPORT double xcestrtod(const char *s, char **errorptr);
+XCE_EXPORT long xcestrtol(const char *s, char **errorptr, int base);
+XCE_EXPORT unsigned long xcestrtoul(const char *s, char **errorptr, int base);
+#define strtod xcestrtod
+#define strtol xcestrtol
+#define strtoul xcestrtoul
+
+XCE_EXPORT int xcestrnicmp(const char *first, const char *last, size_t count);
+#define strnicmp xcestrnicmp
+
+XCE_EXPORT int xceumask(int mask);
+#define umask xceumask
+
+XCE_EXPORT int xceisatty(int fd);
+#define isatty xceisatty
+
+XCE_EXPORT int xcechsize(int fd, unsigned long size);
+#define chsize xcechsize
+
+XCE_EXPORT char *xcegetlogin();
+#define getlogin xcegetlogin
+
+XCE_EXPORT DWORD XCEAPI XCEGetModuleFileNameA(HMODULE hModule, LPTSTR lpName, DWORD nSize);
+XCE_EXPORT HMODULE XCEAPI XCEGetModuleHandleA(const char *lpName);
+XCE_EXPORT FARPROC XCEAPI XCEGetProcAddressA(HMODULE hMod, const char *name);
+
+/* //////////////////////////////////////////////////////////////////// */
+
+#define getgid xcegetgid
+#define getegid xcegetegid
+#define geteuid xcegeteuid
+#define setgid xcesetgid
+
+#define strupr xcestrupr
+#define time xcetime
+
+XCE_EXPORT BOOL XCEFreeEnvironmentStrings(LPCSTR buf);
+#define GetEnvironmentStrings XCEGetEnvironmentStrings
+#define FreeEnvironmentStrings XCEFreeEnvironmentStrings
+
+void wce_hitreturn();
+
+END_EXTERN_C
+
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/API/HOWTO.pod b/Master/tlpkg/tlperl.straw/lib/CPAN/API/HOWTO.pod
new file mode 100755
index 00000000000..e65a4bc9313
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/API/HOWTO.pod
@@ -0,0 +1,44 @@
+=head1 NAME
+
+CPAN::API::HOWTO - a recipe book for programming with CPAN.pm
+
+=head1 RECIPES
+
+All of these recipes assume that you have put "use CPAN" at the top of
+your program.
+
+=head2 What distribution contains a particular module?
+
+ my $distribution = CPAN::Shell->expand(
+ "Module", "Data::UUID"
+ )->distribution()->pretty_id();
+
+This returns a string of the form "AUTHORID/TARBALL". If you want the
+full path and filename to this distribution on a CPAN mirror, then it is
+C<.../authors/id/A/AU/AUTHORID/TARBALL>.
+
+=head2 What modules does a particular distribution contain?
+
+ CPAN::Index->reload();
+ my @modules = CPAN::Shell->expand(
+ "Distribution", "JHI/Graph-0.83.tar.gz"
+ )->containsmods();
+
+You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL.
+
+=head1 SEE ALSO
+
+the main CPAN.pm documentation
+
+=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 AUTHOR
+
+David Cantrell
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Admin.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Admin.pm
new file mode 100755
index 00000000000..de8d7001840
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Admin.pm
@@ -0,0 +1,230 @@
+package CPAN::Admin;
+use base CPAN;
+use CPAN; # old base.pm did not load CPAN on previous line
+use strict;
+use vars qw(@EXPORT $VERSION);
+use constant PAUSE_IP => "pause.perl.org";
+
+@EXPORT = qw(shell);
+$VERSION = "5.5";
+push @CPAN::Complete::COMMANDS, qw(register modsearch);
+$CPAN::Shell::COLOR_REGISTERED = 1;
+
+sub shell {
+ CPAN::shell($_[0]||"admin's cpan> ",$_[1]);
+}
+
+sub CPAN::Shell::register {
+ my($self,$mod,@rest) = @_;
+ unless ($mod) {
+ print "register called without argument\n";
+ return;
+ }
+ if ($CPAN::META->has_inst("URI::Escape")) {
+ require URI::Escape;
+ } else {
+ print "register requires URI::Escape installed, otherwise it cannot work\n";
+ return;
+ }
+ print "Got request for mod[$mod]\n";
+ if (@rest) {
+ my $modline = join " ", $mod, @rest;
+ print "Sending to PAUSE [$modline]\n";
+ my $emodline = URI::Escape::uri_escape($modline, '^\w ');
+ $emodline =~ s/ /+/g;
+ my $url =
+ sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
+ "%s;SUBMIT_pause99_add_mod_hint=hint",
+ PAUSE_IP,
+ $emodline,
+ );
+ print "url[$url]\n\n";
+ print ">>>>Trying to open a netscape window<<<<\n";
+ sleep 1;
+ system("netscape","-remote","openURL($url)");
+ return;
+ }
+ my $m = CPAN::Shell->expand("Module",$mod);
+ unless (ref $m) {
+ print "Could not determine the object for $mod\n";
+ return;
+ }
+ my $id = $m->id;
+ print "Found module id[$id] in database\n";
+
+ if (exists $m->{RO} && $m->{RO}{chapterid}) {
+ print "$id is already registered\n";
+ return;
+ }
+
+ my(@namespace) = split /::/, $id;
+ my $rootns = $namespace[0];
+
+ # Tk, XML and Apache need special treatment
+ if ($rootns=~/^(Bundle)\b/) {
+ print "Bundles are not yet ready for registering\n";
+ return;
+ }
+
+ # make a good suggestion for the chapter
+ my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/");
+ print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n";
+ my(%seench);
+ for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) {
+ next unless $ch;
+ $seench{$ch}=undef;
+ }
+ my(@seench) = sort grep {length($_)} keys %seench;
+ my $reco_ch = "";
+ if (@seench>1) {
+ print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n";
+ $reco_ch = $seench[0];
+ print "Picking $reco_ch\n";
+ } elsif (@seench==1) {
+ print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n";
+ $reco_ch = $seench[0];
+ } else {
+ print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n";
+ }
+
+ # Look closer at the dist
+ my $d = CPAN::Shell->expand("Distribution", $m->cpan_file);
+ printf "Module comes with dist[%s]\n", $d->id;
+ for my $contm ($d->containsmods) {
+ if ($CPAN::META->exists("CPAN::Module",$contm)) {
+ my $contm_obj = CPAN::Shell->expand("Module",$contm) or next;
+ my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description};
+ printf(" in same dist: %s%s\n",
+ $contm,
+ $is_reg ? " already in modulelist" : "",
+ );
+ }
+ }
+
+ # get it so that m is better and we can inspect for XS
+ CPAN::Shell->get($id);
+ CPAN::Shell->m($id);
+ CPAN::Shell->d($d->id);
+
+ my $has_xs = 0;
+ {
+ my($mani,@mani);
+ local $/ = "\n";
+ open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>;
+ my @xs = grep /\.xs\b/, @mani;
+ if (@xs) {
+ print "Found XS files: @xs";
+ $has_xs=1;
+ }
+ }
+ my $emodid = URI::Escape::uri_escape($id, '\W');
+ my $ech = $reco_ch;
+ $ech =~ s/ /+/g;
+ my $description = $m->{MANPAGE} || "";
+ $description =~ s/[A-Z]<//; # POD markup (and maybe more)
+ $description =~ s/^\s+//; # leading spaces
+ $description =~ s/>//; # POD
+ $description =~ s/^\Q$id\E//; # usually this line starts with the modid
+ $description =~ s/^[ \-]+//; # leading spaces and dashes
+ substr($description,44) = "" if length($description)>44;
+ $description = ucfirst($description);
+ my $edescription = URI::Escape::uri_escape($description, '^\w ');
+ $edescription =~ s/ /+/g;
+ my $url =
+ sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
+ "%s;pause99_add_mod_chapterid=%s;pause99_add_mod_statd=%s;".
+ "pause99_add_mod_stats=%s;pause99_add_mod_statl=%s;".
+ "pause99_add_mod_stati=%s;pause99_add_mod_description=%s;".
+ "pause99_add_mod_userid=%s;SUBMIT_pause99_add_mod_preview=preview",
+ PAUSE_IP,
+ $emodid,
+ $ech,
+ "R",
+ "d",
+ $has_xs ? "c" : "p",
+ "O",
+ $edescription,
+ $m->{RO}{CPAN_USERID},
+ );
+ print "$url\n\n";
+ print ">>>>Trying to open a netscape window<<<<\n";
+ system("netscape","-remote","openURL($url)");
+}
+
+sub CPAN::Shell::modsearch {
+ my($self,@line) = @_;
+ unless (@line) {
+ print "modsearch called without argument\n";
+ return;
+ }
+ my $request = join " ", @line;
+ print "Got request[$request]\n";
+ my $erequest = URI::Escape::uri_escape($request, '^\w ');
+ $erequest =~ s/ /+/g;
+ my $url =
+ sprintf("http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?query=%s".
+ "&errors=0&case=on&maxfiles=100&maxlines=30",
+ $erequest,
+ );
+ print "$url\n\n";
+ print ">>>>Trying to open a netscape window<<<<\n";
+ system("netscape","-remote","openURL('$url')");
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ CPAN::Admin - A CPAN Shell for CPAN admins
+
+=head1 SYNOPSIS
+
+ perl -MCPAN::Admin -e shell
+
+=head1 STATUS
+
+Note: this module is currently not maintained. If you need it and fix
+it for your needs, please submit patches.
+
+=head1 DESCRIPTION
+
+CPAN::Admin is a subclass of CPAN that adds the commands C<register>
+and C<modsearch> to the CPAN shell.
+
+C<register> calls C<get> on the named module, assembles a couple of
+informations (description, language), and calls Netscape with the
+-remote argument so that a form is filled with all the assembled
+informations and the registration can be performed with a single
+click. If the command line has more than one argument, register does
+not run a C<get>, instead it interprets the rest of the line as DSLI
+status, description, and userid and sends them to netscape such that
+the form is again mostly filled and can be edited or confirmed with a
+single click. CPAN::Admin never performs the submission click for you,
+it is only intended to fill in the form on PAUSE and leave the
+confirmation to you.
+
+C<modsearch> simply passes the arguments to the search engine for the
+modules@perl.org mailing list at http://www.xray.mpe.mpg.de where all
+registration requests are stored. It does so in the same way as
+register, namely with the C<netscape -remote> command.
+
+An experimental feature has also been added, namely to color already
+registered modules in listings. If you have Term::ANSIColor installed,
+the u, r, and m commands will show already registered modules in
+green.
+
+=head1 PREREQISITES
+
+URI::Escape, netscape browser available in the path, netscape must
+understand the -remote switch (as far as I know, this is only
+available on UNIX); coloring of registered modules is only available
+if Term::ANSIColor is installed.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Author.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Author.pm
new file mode 100755
index 00000000000..e9e9226be5d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Author.pm
@@ -0,0 +1,236 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Author;
+use strict;
+
+use CPAN::InfoObj;
+@CPAN::Author::ISA = qw(CPAN::InfoObj);
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+package CPAN::Author;
+use strict;
+
+#-> sub CPAN::Author::force
+sub force {
+ my $self = shift;
+ $self->{force}++;
+}
+
+#-> sub CPAN::Author::force
+sub unforce {
+ my $self = shift;
+ delete $self->{force};
+}
+
+#-> sub CPAN::Author::id
+sub id {
+ my $self = shift;
+ my $id = $self->{ID};
+ $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
+ $id;
+}
+
+#-> sub CPAN::Author::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
+ $class,
+ $self->{ID},
+ $self->fullname,
+ $self->email);
+ join "", @m;
+}
+
+#-> sub CPAN::Author::fullname ;
+sub fullname {
+ shift->ro->{FULLNAME};
+}
+*name = \&fullname;
+
+#-> sub CPAN::Author::email ;
+sub email { shift->ro->{EMAIL}; }
+
+#-> sub CPAN::Author::ls ;
+sub ls {
+ my $self = shift;
+ my $glob = shift || "";
+ my $silent = shift || 0;
+ my $id = $self->id;
+
+ # adapted from CPAN::Distribution::verifyCHECKSUM ;
+ my(@csf); # chksumfile
+ @csf = $self->id =~ /(.)(.)(.*)/;
+ $csf[1] = join "", @csf[0,1];
+ $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
+ my(@dl);
+ @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
+ unless (grep {$_->[2] eq $csf[1]} @dl) {
+ $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
+ return;
+ }
+ @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
+ unless (grep {$_->[2] eq $csf[2]} @dl) {
+ $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
+ return;
+ }
+ @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
+ if ($glob) {
+ if ($CPAN::META->has_inst("Text::Glob")) {
+ $glob =~ s|/$|/*|;
+ my $rglob = Text::Glob::glob_to_regex($glob);
+ CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
+ my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl;
+ if (1==@tmpdl && $tmpdl[0][0]==0) {
+ $rglob = Text::Glob::glob_to_regex("$glob/*");
+ @dl = grep { $_->[2] =~ /$rglob/ } @dl;
+ } else {
+ @dl = @tmpdl;
+ }
+ CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
+ } else {
+ $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
+ }
+ }
+ unless ($silent >= 2) {
+ $CPAN::Frontend->myprint
+ (
+ join "",
+ map {
+ sprintf
+ (
+ "%8d %10s %s/%s%s\n",
+ $_->[0],
+ $_->[1],
+ $id,
+ $_->[2],
+ 0==$_->[0]?"/":"",
+ )
+ } sort { $a->[2] cmp $b->[2] } @dl
+ );
+ }
+ @dl;
+}
+
+# returns an array of arrays, the latter contain (size,mtime,filename)
+#-> sub CPAN::Author::dir_listing ;
+sub dir_listing {
+ my $self = shift;
+ my $chksumfile = shift;
+ my $recursive = shift;
+ my $may_ftp = shift;
+
+ my $lc_want =
+ File::Spec->catfile($CPAN::Config->{keep_source_where},
+ "authors", "id", @$chksumfile);
+
+ my $fh;
+
+ CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG;
+ # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
+ # hazard. (Without GPG installed they are not that much better,
+ # though.)
+ $fh = FileHandle->new;
+ if (open($fh, $lc_want)) {
+ my $line = <$fh>; close $fh;
+ unlink($lc_want) unless $line =~ /PGP/;
+ }
+
+ local($") = "/";
+ # connect "force" argument with "index_expire".
+ my $force = $self->{force};
+ if (my @stat = stat $lc_want) {
+ $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
+ }
+ my $lc_file;
+ if ($may_ftp) {
+ $lc_file = eval {
+ CPAN::FTP->localize
+ (
+ "authors/id/@$chksumfile",
+ $lc_want,
+ $force,
+ );
+ };
+ unless ($lc_file) {
+ $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
+ $chksumfile->[-1] .= ".gz";
+ $lc_file = eval {
+ CPAN::FTP->localize
+ ("authors/id/@$chksumfile",
+ "$lc_want.gz",
+ 1,
+ );
+ };
+ if ($lc_file) {
+ $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
+ eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
+ } else {
+ return;
+ }
+ }
+ } else {
+ $lc_file = $lc_want;
+ # we *could* second-guess and if the user has a file: URL,
+ # then we could look there. But on the other hand, if they do
+ # have a file: URL, wy did they choose to set
+ # $CPAN::Config->{show_upload_date} to false?
+ }
+
+ # adapted from CPAN::Distribution::CHECKSUM_check_file ;
+ $fh = FileHandle->new;
+ my($cksum);
+ if (open $fh, $lc_file) {
+ local($/);
+ my $eval = <$fh>;
+ $eval =~ s/\015?\012/\n/g;
+ close $fh;
+ my($compmt) = Safe->new();
+ $cksum = $compmt->reval($eval);
+ if ($@) {
+ rename $lc_file, "$lc_file.bad";
+ Carp::confess($@) if $@;
+ }
+ } elsif ($may_ftp) {
+ Carp::carp ("Could not open '$lc_file' for reading.");
+ } else {
+ # Maybe should warn: "You may want to set show_upload_date to a true value"
+ return;
+ }
+ my(@result,$f);
+ for $f (sort keys %$cksum) {
+ if (exists $cksum->{$f}{isdir}) {
+ if ($recursive) {
+ my(@dir) = @$chksumfile;
+ pop @dir;
+ push @dir, $f, "CHECKSUMS";
+ push @result, [ 0, "-", $f ];
+ push @result, map {
+ [$_->[0], $_->[1], "$f/$_->[2]"]
+ } $self->dir_listing(\@dir,1,$may_ftp);
+ } else {
+ push @result, [ 0, "-", $f ];
+ }
+ } else {
+ push @result, [
+ ($cksum->{$f}{"size"}||0),
+ $cksum->{$f}{"mtime"}||"---",
+ $f
+ ];
+ }
+ }
+ @result;
+}
+
+#-> sub CPAN::Author::reports
+sub reports {
+ $CPAN::Frontend->mywarn("reports on authors not implemented.
+Please file a bugreport if you need this.\n");
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Bundle.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Bundle.pm
new file mode 100755
index 00000000000..e7360f80485
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Bundle.pm
@@ -0,0 +1,287 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Bundle;
+use strict;
+use CPAN::Module;
+@CPAN::Bundle::ISA = qw(CPAN::Module);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+sub look {
+ my $self = shift;
+ $CPAN::Frontend->myprint($self->as_string);
+}
+
+#-> CPAN::Bundle::undelay
+sub undelay {
+ my $self = shift;
+ delete $self->{later};
+ for my $c ( $self->contains ) {
+ my $obj = CPAN::Shell->expandany($c) or next;
+ $obj->undelay;
+ }
+}
+
+# mark as dirty/clean
+#-> sub CPAN::Bundle::color_cmd_tmps ;
+sub color_cmd_tmps {
+ my($self) = shift;
+ my($depth) = shift || 0;
+ my($color) = shift || 0;
+ my($ancestors) = shift || [];
+ # a module needs to recurse to its cpan_file, a distribution needs
+ # to recurse into its prereq_pms, a bundle needs to recurse into its modules
+
+ return if exists $self->{incommandcolor}
+ && $color==1
+ && $self->{incommandcolor}==$color;
+ if ($depth>=$CPAN::MAX_RECURSION) {
+ die(CPAN::Exception::RecursiveDependency->new($ancestors));
+ }
+ # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+
+ for my $c ( $self->contains ) {
+ my $obj = CPAN::Shell->expandany($c) or next;
+ CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
+ $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
+ }
+ # never reached code?
+ #if ($color==0) {
+ #delete $self->{badtestcnt};
+ #}
+ $self->{incommandcolor} = $color;
+}
+
+#-> sub CPAN::Bundle::as_string ;
+sub as_string {
+ my($self) = @_;
+ $self->contains;
+ # following line must be "=", not "||=" because we have a moving target
+ $self->{INST_VERSION} = $self->inst_version;
+ return $self->SUPER::as_string;
+}
+
+#-> sub CPAN::Bundle::contains ;
+sub contains {
+ my($self) = @_;
+ my($inst_file) = $self->inst_file || "";
+ my($id) = $self->id;
+ $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
+ if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
+ undef $inst_file;
+ }
+ unless ($inst_file) {
+ # Try to get at it in the cpan directory
+ $self->debug("no inst_file") if $CPAN::DEBUG;
+ my $cpan_file;
+ $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
+ $cpan_file = $self->cpan_file;
+ if ($cpan_file eq "N/A") {
+ $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
+ Maybe stale symlink? Maybe removed during session? Giving up.\n");
+ }
+ my $dist = $CPAN::META->instance('CPAN::Distribution',
+ $self->cpan_file);
+ $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
+ $dist->get;
+ $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
+ my($todir) = $CPAN::Config->{'cpan_home'};
+ my(@me,$from,$to,$me);
+ @me = split /::/, $self->id;
+ $me[-1] .= ".pm";
+ $me = File::Spec->catfile(@me);
+ $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
+ $to = File::Spec->catfile($todir,$me);
+ File::Path::mkpath(File::Basename::dirname($to));
+ File::Copy::copy($from, $to)
+ or Carp::confess("Couldn't copy $from to $to: $!");
+ $inst_file = $to;
+ }
+ my @result;
+ my $fh = FileHandle->new;
+ local $/ = "\n";
+ open($fh,$inst_file) or die "Could not open '$inst_file': $!";
+ my $in_cont = 0;
+ $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
+ while (<$fh>) {
+ $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
+ m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
+ next unless $in_cont;
+ next if /^=/;
+ s/\#.*//;
+ next if /^\s+$/;
+ chomp;
+ push @result, (split " ", $_, 2)[0];
+ }
+ close $fh;
+ delete $self->{STATUS};
+ $self->{CONTAINS} = \@result;
+ $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
+ unless (@result) {
+ $CPAN::Frontend->mywarn(qq{
+The bundle file "$inst_file" may be a broken
+bundlefile. It seems not to contain any bundle definition.
+Please check the file and if it is bogus, please delete it.
+Sorry for the inconvenience.
+});
+ }
+ @result;
+}
+
+#-> sub CPAN::Bundle::find_bundle_file
+# $where is in local format, $what is in unix format
+sub find_bundle_file {
+ my($self,$where,$what) = @_;
+ $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
+### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
+### my $bu = File::Spec->catfile($where,$what);
+### return $bu if -f $bu;
+ my $manifest = File::Spec->catfile($where,"MANIFEST");
+ unless (-f $manifest) {
+ require ExtUtils::Manifest;
+ my $cwd = CPAN::anycwd();
+ $self->safe_chdir($where);
+ ExtUtils::Manifest::mkmanifest();
+ $self->safe_chdir($cwd);
+ }
+ my $fh = FileHandle->new($manifest)
+ or Carp::croak("Couldn't open $manifest: $!");
+ local($/) = "\n";
+ my $bundle_filename = $what;
+ $bundle_filename =~ s|Bundle.*/||;
+ my $bundle_unixpath;
+ while (<$fh>) {
+ next if /^\s*\#/;
+ my($file) = /(\S+)/;
+ if ($file =~ m|\Q$what\E$|) {
+ $bundle_unixpath = $file;
+ # return File::Spec->catfile($where,$bundle_unixpath); # bad
+ last;
+ }
+ # retry if she managed to have no Bundle directory
+ $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
+ }
+ return File::Spec->catfile($where, split /\//, $bundle_unixpath)
+ if $bundle_unixpath;
+ Carp::croak("Couldn't find a Bundle file in $where");
+}
+
+# needs to work quite differently from Module::inst_file because of
+# cpan_home/Bundle/ directory and the possibility that we have
+# shadowing effect. As it makes no sense to take the first in @INC for
+# Bundles, we parse them all for $VERSION and take the newest.
+
+#-> sub CPAN::Bundle::inst_file ;
+sub inst_file {
+ my($self) = @_;
+ my($inst_file);
+ my(@me);
+ @me = split /::/, $self->id;
+ $me[-1] .= ".pm";
+ my($incdir,$bestv);
+ foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
+ my $parsefile = File::Spec->catfile($incdir, @me);
+ CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
+ next unless -f $parsefile;
+ my $have = eval { MM->parse_version($parsefile); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
+ }
+ if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
+ $self->{INST_FILE} = $parsefile;
+ $self->{INST_VERSION} = $bestv = $have;
+ }
+ }
+ $self->{INST_FILE};
+}
+
+#-> sub CPAN::Bundle::inst_version ;
+sub inst_version {
+ my($self) = @_;
+ $self->inst_file; # finds INST_VERSION as side effect
+ $self->{INST_VERSION};
+}
+
+#-> sub CPAN::Bundle::rematein ;
+sub rematein {
+ my($self,$meth) = @_;
+ $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
+ my($id) = $self->id;
+ Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" )
+ unless $self->inst_file || $self->cpan_file;
+ my($s,%fail);
+ for $s ($self->contains) {
+ my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
+ $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
+ if ($type eq 'CPAN::Distribution') {
+ $CPAN::Frontend->mywarn(qq{
+The Bundle }.$self->id.qq{ contains
+explicitly a file '$s'.
+Going to $meth that.
+});
+ $CPAN::Frontend->mysleep(5);
+ }
+ # possibly noisy action:
+ $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
+ my $obj = $CPAN::META->instance($type,$s);
+ $obj->{reqtype} = $self->{reqtype};
+ $obj->$meth();
+ }
+}
+
+# If a bundle contains another that contains an xs_file we have here,
+# we just don't bother I suppose
+#-> sub CPAN::Bundle::xs_file
+sub xs_file {
+ return 0;
+}
+
+#-> sub CPAN::Bundle::force ;
+sub fforce { shift->rematein('fforce',@_); }
+#-> sub CPAN::Bundle::force ;
+sub force { shift->rematein('force',@_); }
+#-> sub CPAN::Bundle::notest ;
+sub notest { shift->rematein('notest',@_); }
+#-> sub CPAN::Bundle::get ;
+sub get { shift->rematein('get',@_); }
+#-> sub CPAN::Bundle::make ;
+sub make { shift->rematein('make',@_); }
+#-> sub CPAN::Bundle::test ;
+sub test {
+ my $self = shift;
+ # $self->{badtestcnt} ||= 0;
+ $self->rematein('test',@_);
+}
+#-> sub CPAN::Bundle::install ;
+sub install {
+ my $self = shift;
+ $self->rematein('install',@_);
+}
+#-> sub CPAN::Bundle::clean ;
+sub clean { shift->rematein('clean',@_); }
+
+#-> sub CPAN::Bundle::uptodate ;
+sub uptodate {
+ my($self) = @_;
+ return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
+ my $c;
+ foreach $c ($self->contains) {
+ my $obj = CPAN::Shell->expandany($c);
+ return 0 unless $obj->uptodate;
+ }
+ return 1;
+}
+
+#-> sub CPAN::Bundle::readme ;
+sub readme {
+ my($self) = @_;
+ my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
+No File found for bundle } . $self->id . qq{\n}), return;
+ $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
+ $CPAN::META->instance('CPAN::Distribution',$file)->readme;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/CacheMgr.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/CacheMgr.pm
new file mode 100755
index 00000000000..827baeaefdb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/CacheMgr.pm
@@ -0,0 +1,246 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::CacheMgr;
+use strict;
+use CPAN::InfoObj;
+@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
+use Cwd qw(chdir);
+use File::Find;
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+package CPAN::CacheMgr;
+use strict;
+
+#-> sub CPAN::CacheMgr::as_string ;
+sub as_string {
+ eval { require Data::Dumper };
+ if ($@) {
+ return shift->SUPER::as_string;
+ } else {
+ return Data::Dumper::Dumper(shift);
+ }
+}
+
+#-> sub CPAN::CacheMgr::cachesize ;
+sub cachesize {
+ shift->{DU};
+}
+
+#-> sub CPAN::CacheMgr::tidyup ;
+sub tidyup {
+ my($self) = @_;
+ return unless $CPAN::META->{LOCK};
+ return unless -d $self->{ID};
+ my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
+ for my $current (0..$#toremove) {
+ my $toremove = $toremove[$current];
+ $CPAN::Frontend->myprint(sprintf(
+ "DEL(%d/%d): %s \n",
+ $current+1,
+ scalar @toremove,
+ $toremove,
+ )
+ );
+ return if $CPAN::Signal;
+ $self->_clean_cache($toremove);
+ return if $CPAN::Signal;
+ }
+}
+
+#-> sub CPAN::CacheMgr::dir ;
+sub dir {
+ shift->{ID};
+}
+
+#-> sub CPAN::CacheMgr::entries ;
+sub entries {
+ my($self,$dir) = @_;
+ return unless defined $dir;
+ $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
+ $dir ||= $self->{ID};
+ my($cwd) = CPAN::anycwd();
+ chdir $dir or Carp::croak("Can't chdir to $dir: $!");
+ my $dh = DirHandle->new(File::Spec->curdir)
+ or Carp::croak("Couldn't opendir $dir: $!");
+ my(@entries);
+ for ($dh->read) {
+ next if $_ eq "." || $_ eq "..";
+ if (-f $_) {
+ push @entries, File::Spec->catfile($dir,$_);
+ } elsif (-d _) {
+ push @entries, File::Spec->catdir($dir,$_);
+ } else {
+ $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
+ }
+ }
+ chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
+ sort { -M $a <=> -M $b} @entries;
+}
+
+#-> sub CPAN::CacheMgr::disk_usage ;
+sub disk_usage {
+ my($self,$dir,$fast) = @_;
+ return if exists $self->{SIZE}{$dir};
+ return if $CPAN::Signal;
+ my($Du) = 0;
+ if (-e $dir) {
+ if (-d $dir) {
+ unless (-x $dir) {
+ unless (chmod 0755, $dir) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
+ "permission to change the permission; cannot ".
+ "estimate disk usage of '$dir'\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } elsif (-f $dir) {
+ # nothing to say, no matter what the permissions
+ }
+ } else {
+ $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
+ return;
+ }
+ if ($fast) {
+ $Du = 0; # placeholder
+ } else {
+ find(
+ sub {
+ $File::Find::prune++ if $CPAN::Signal;
+ return if -l $_;
+ if ($^O eq 'MacOS') {
+ require Mac::Files;
+ my $cat = Mac::Files::FSpGetCatInfo($_);
+ $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
+ } else {
+ if (-d _) {
+ unless (-x _) {
+ unless (chmod 0755, $_) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
+ "the permission to change the permission; ".
+ "can only partially estimate disk usage ".
+ "of '$_'\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } else {
+ $Du += (-s _);
+ }
+ }
+ },
+ $dir
+ );
+ }
+ return if $CPAN::Signal;
+ $self->{SIZE}{$dir} = $Du/1024/1024;
+ unshift @{$self->{FIFO}}, $dir;
+ $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
+ $self->{DU} += $Du/1024/1024;
+ $self->{DU};
+}
+
+#-> sub CPAN::CacheMgr::_clean_cache ;
+sub _clean_cache {
+ my($self,$dir) = @_;
+ return unless -e $dir;
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
+ $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
+ "will not remove\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
+ if $CPAN::DEBUG;
+ File::Path::rmtree($dir);
+ my $id_deleted = 0;
+ if ($dir !~ /\.yml$/ && -f "$dir.yml") {
+ my $yaml_module = CPAN::_yaml_module();
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
+ unlink "$dir.yml" or
+ $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
+ return;
+ } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
+ $CPAN::META->delete("CPAN::Distribution", $id);
+
+ # XXX we should restore the state NOW, otherise this
+ # distro does not exist until we read an index. BUG ALERT(?)
+
+ # $CPAN::Frontend->mywarn (" +++\n");
+ $id_deleted++;
+ }
+ }
+ unlink "$dir.yml"; # may fail
+ unless ($id_deleted) {
+ CPAN->debug("no distro found associated with '$dir'");
+ }
+ }
+ $self->{DU} -= $self->{SIZE}{$dir};
+ delete $self->{SIZE}{$dir};
+}
+
+#-> sub CPAN::CacheMgr::new ;
+sub new {
+ my $class = shift;
+ my $time = time;
+ my($debug,$t2);
+ $debug = "";
+ my $self = {
+ ID => $CPAN::Config->{build_dir},
+ MAX => $CPAN::Config->{'build_cache'},
+ SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
+ DU => 0
+ };
+ File::Path::mkpath($self->{ID});
+ my $dh = DirHandle->new($self->{ID});
+ bless $self, $class;
+ $self->scan_cache;
+ $t2 = time;
+ $debug .= "timing of CacheMgr->new: ".($t2 - $time);
+ $time = $t2;
+ CPAN->debug($debug) if $CPAN::DEBUG;
+ $self;
+}
+
+#-> sub CPAN::CacheMgr::scan_cache ;
+sub scan_cache {
+ my $self = shift;
+ return if $self->{SCAN} eq 'never';
+ $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
+ unless $self->{SCAN} eq 'atstart';
+ return unless $CPAN::META->{LOCK};
+ $CPAN::Frontend->myprint(
+ sprintf("Scanning cache %s for sizes\n",
+ $self->{ID}));
+ my $e;
+ my @entries = $self->entries($self->{ID});
+ my $i = 0;
+ my $painted = 0;
+ for $e (@entries) {
+ my $symbol = ".";
+ if ($self->{DU} > $self->{MAX}) {
+ $symbol = "-";
+ $self->disk_usage($e,1);
+ } else {
+ $self->disk_usage($e);
+ }
+ $i++;
+ while (($painted/76) < ($i/@entries)) {
+ $CPAN::Frontend->myprint($symbol);
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+ $self->tidyup;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Checksums.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Checksums.pm
new file mode 100755
index 00000000000..9f8e779cd2a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Checksums.pm
@@ -0,0 +1,432 @@
+package CPAN::Checksums;
+
+use strict;
+use vars qw(
+ $CAUTION
+ $DIRNAME
+ $IGNORE_MATCH
+ $MIN_MTIME_CHECKSUMS
+ $SIGNING_KEY
+ $SIGNING_PROGRAM
+ $TRY_SHORTNAME
+ $VERSION
+ @EXPORT_OK
+ @ISA
+ );
+
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(updatedir);
+$VERSION = "2.05";
+$VERSION =~ s/_//;
+$CAUTION ||= 0;
+$TRY_SHORTNAME ||= 0;
+$SIGNING_PROGRAM ||= 'gpg --clearsign --default-key ';
+$SIGNING_KEY ||= '';
+$MIN_MTIME_CHECKSUMS ||= 0;
+$IGNORE_MATCH = qr{(?i-xsm:readme$)};
+
+use DirHandle ();
+use IO::File ();
+use Digest::MD5 ();
+use Compress::Bzip2();
+use Compress::Zlib ();
+use File::Spec ();
+use File::Temp;
+use Data::Dumper ();
+use Data::Compare ();
+use Digest::SHA ();
+
+sub _dir_to_dref {
+ my($dirname,$old_dref) = @_;
+ my($dref) = {};
+ my($dh)= DirHandle->new;
+ my($fh) = new IO::File;
+ $dh->open($dirname) or die "Couldn't opendir $dirname\: $!";
+ my(%shortnameseen);
+ DIRENT: for my $de ($dh->read) {
+ next if $de =~ /^\./;
+ next if substr($de,0,9) eq "CHECKSUMS";
+ next if $IGNORE_MATCH && $de =~ $IGNORE_MATCH;
+
+ my $abs = File::Spec->catfile($dirname,$de);
+
+ #
+ # SHORTNAME offers an 8.3 name, probably not needed but it was
+ # always there,,,
+ #
+ if ($TRY_SHORTNAME) {
+ my $shortname = lc $de;
+ $shortname =~ s/\.tar[._-]gz$/\.tgz/;
+ my $suffix;
+ ($suffix = $shortname) =~ s/.*\.//;
+ substr($suffix,3) = "" if length($suffix) > 3;
+ my @p;
+ if ($shortname =~ /\-/) {
+ @p = $shortname =~ /(.{1,16})-.*?([\d\.]{2,8})/;
+ } else {
+ @p = $shortname =~ /(.{1,8}).*?([\d\.]{2,8})/;
+ }
+ $p[0] ||= lc $de;
+ $p[0] =~ s/[^a-z0-9]//g;
+ $p[1] ||= 0;
+ $p[1] =~ s/\D//g;
+ my $counter = 7;
+ while (length($p[0]) + length($p[1]) > 8) {
+ substr($p[0], $counter) = "" if length($p[0]) > $counter;
+ substr($p[1], $counter) = "" if length($p[1]) > $counter--;
+ }
+ my $dot = $suffix ? "." : "";
+ $shortname = "$p[0]$p[1]$dot$suffix";
+ while (exists $shortnameseen{$shortname}) {
+ my($modi) = $shortname =~ /([a-z\d]+)/;
+ $modi++;
+ $shortname = "$modi$dot$suffix";
+ if (++$counter > 1000){ # avoid endless loops and accept the buggy choice
+ warn "Warning: long loop on shortname[$shortname]de[$de]";
+ last;
+ }
+ }
+ $dref->{$de}->{shortname} = $shortname;
+ $shortnameseen{$shortname} = undef; # for exists check good enough
+ }
+
+ #
+ # STAT facts
+ #
+ if (-l File::Spec->catdir($dirname,$de)){
+ # Symlinks are a mess on a replicated, database driven system,
+ # but as they are not forbidden, we cannot ignore them. We do
+ # have a directory with nothing but a symlink in it. When we
+ # ignored the symlink, we did not write a CHECKSUMS file and
+ # CPAN.pm issued lots of warnings:-(
+ $dref->{$de}{issymlink} = 1;
+ }
+ if (-d File::Spec->catdir($dirname,$de)){
+ $dref->{$de}{isdir} = 1;
+ } else {
+ my @stat = stat $abs or next DIRENT;
+ $dref->{$de}{size} = $stat[7];
+ my(@gmtime) = gmtime $stat[9];
+ $gmtime[4]++;
+ $gmtime[5]+=1900;
+ $dref->{$de}{mtime} = sprintf "%04d-%02d-%02d", @gmtime[5,4,3];
+ _add_digests($de,$dref,"Digest::SHA",[256],"sha256",$abs,$old_dref);
+ my $can_reuse_old_md5 = 1;
+ COMPARE: for my $param (qw(size mtime sha256)) {
+ if (!exists $old_dref->{$de}{$param} ||
+ $dref->{$de}{$param} ne $old_dref->{$de}{$param}) {
+ $can_reuse_old_md5 = 0;
+ last COMPARE;
+ }
+ }
+ if ( $can_reuse_old_md5 ) {
+ for my $param (qw(md5 md5-ungz md5-unbz2)) {
+ next unless exists $old_dref->{$de}{$param};
+ $dref->{$de}{$param} = $old_dref->{$de}{$param};
+ }
+ } else {
+ _add_digests($de,$dref,"Digest::MD5",[],"md5",$abs,$old_dref);
+ }
+
+ } # ! -d
+ }
+ $dh->close;
+ $dref;
+}
+
+sub _read_old_ddump {
+ my($ckfn) = @_;
+ my $is_signed = 0;
+ my($fh) = new IO::File;
+ my $old_ddump = "";
+ if ($fh->open($ckfn)) {
+ local $/ = "\n";
+ while (<$fh>) {
+ next if /^\#/;
+ $is_signed = 1 if /SIGNED MESSAGE/;
+ $old_ddump .= $_;
+ }
+ close $fh;
+ }
+ return($old_ddump,$is_signed);
+}
+
+sub updatedir ($) {
+ my($dirname) = @_;
+ my $ckfn = File::Spec->catfile($dirname, "CHECKSUMS"); # checksum-file-name
+ my($old_ddump,$is_signed) = _read_old_ddump($ckfn);
+ my($old_dref) = makehashref($old_ddump);
+ my $dref = _dir_to_dref($dirname,$old_dref);
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Quotekeys = 1;
+ local $Data::Dumper::Sortkeys = 1;
+ my $ddump = Data::Dumper->new([$dref],["cksum"])->Dump;
+ my @ckfnstat = stat $ckfn;
+ if ($old_ddump) {
+ local $DIRNAME = $dirname;
+ if ( !!$SIGNING_KEY == !!$is_signed ) { # either both or neither
+ if (!$MIN_MTIME_CHECKSUMS || $ckfnstat[9] > $MIN_MTIME_CHECKSUMS ) {
+ # recent enough
+ return 1 if $old_ddump eq $ddump;
+ return 1 if ckcmp($old_dref,$dref);
+ }
+ }
+ if ($CAUTION) {
+ my $report = investigate($old_dref,$dref);
+ warn $report if $report;
+ }
+ }
+ my $ft = File::Temp->new(
+ DIR => $dirname,
+ TEMPLATE => "CHECKSUMS.XXXX",
+ CLEANUP => 0,
+ ) or die;
+ my $tckfn = $ft->filename;
+ close $ft;
+ my($fh) = new IO::File;
+ open $fh, ">$tckfn\0" or die "Couldn't open >$tckfn\: $!";
+
+ local $\;
+ if ($SIGNING_KEY) {
+ print $fh "0&&<<''; # this PGP-signed message is also valid perl\n";
+ close $fh;
+ open $fh, "| $SIGNING_PROGRAM $SIGNING_KEY >> $tckfn"
+ or die "Could not call gpg: $!";
+ $ddump .= "__END__\n";
+ }
+
+ my $message = sprintf "# CHECKSUMS file written on %s GMT by CPAN::Checksums (v%s)\n%s",
+ scalar gmtime, $VERSION, $ddump;
+ print $fh $message;
+ my $success = close $fh;
+ if ($SIGNING_KEY && !$success) {
+ warn "Couldn't run '$SIGNING_PROGRAM $SIGNING_KEY'!
+Writing to $tckfn directly";
+ open $fh, ">$tckfn\0" or die "Couldn't open >$tckfn\: $!";
+ print $fh $message;
+ close $fh or warn "Couldn't close $tckfn: $!";
+ }
+ chmod 0644, $ckfn or die "Couldn't chmod to 0644 for $ckfn\: $!" if -f $ckfn;
+ rename $tckfn, $ckfn or die "Could not rename: $!";
+ chmod 0444, $ckfn or die "Couldn't chmod to 0444 for $ckfn\: $!";
+ return 2;
+}
+
+sub _add_digests ($$$$$$$) {
+ my($de,$dref,$module,$constructor_args,$keyname,$abs,$old_dref) = @_;
+ my($fh) = new IO::File;
+ my $dig = $module->new(@$constructor_args);
+ $fh->open("$abs\0") or die "Couldn't open $abs: $!";
+ binmode($fh); # make sure it's called as a function, solaris with
+ # perl 5.8.4 complained about missing method in
+ # IO::File
+ $dig->addfile($fh);
+ $fh->close;
+ my $digest = $dig->hexdigest;
+ $dref->{$de}{$keyname} = $digest;
+ $dig = $module->new(@$constructor_args);
+ if ($de =~ /\.gz$/) {
+ my($buffer, $zip);
+ if (exists $old_dref->{$de}{$keyname} &&
+ $dref->{$de}{$keyname} eq $old_dref->{$de}{$keyname} &&
+ exists $old_dref->{$de}{"$keyname-ungz"}
+ ) {
+ $dref->{$de}{"$keyname-ungz"} = $old_dref->{$de}{"$keyname-ungz"};
+ return;
+ }
+ if ($zip = Compress::Zlib::gzopen($abs, "rb")) {
+ $dig->add($buffer)
+ while $zip->gzread($buffer) > 0;
+ $dref->{$de}{"$keyname-ungz"} = $dig->hexdigest;
+ $zip->gzclose;
+ }
+ } elsif ($de =~ /\.bz2$/) {
+ my($buffer, $zip);
+ if (exists $old_dref->{$de}{$keyname} &&
+ $dref->{$de}{$keyname} eq $old_dref->{$de}{$keyname} &&
+ exists $old_dref->{$de}{"$keyname-unbz2"}
+ ) {
+ $dref->{$de}{"$keyname-unbz2"} = $old_dref->{$de}{"$keyname-unbz2"};
+ return;
+ }
+ if ($zip = Compress::Bzip2::bzopen($abs, "rb")) {
+ $dig->add($buffer)
+ while $zip->bzread($buffer) > 0;
+ $dref->{$de}{"$keyname-unbz2"} = $dig->hexdigest;
+ $zip->bzclose;
+ }
+ }
+}
+
+sub ckcmp ($$) {
+ my($old,$new) = @_;
+ for ($old,$new) {
+ $_ = makehashref($_);
+ }
+ Data::Compare::Compare($old,$new);
+}
+
+# see if a file changed but the name not
+sub investigate ($$) {
+ my($old,$new) = @_;
+ for ($old,$new) {
+ $_ = makehashref($_);
+ }
+ my $complain = "";
+ for my $dist (sort keys %$new) {
+ if (exists $old->{$dist}) {
+ my $headersaid;
+ for my $diff (qw/md5 sha256 size md5-ungz sha256-ungz mtime/) {
+ next unless exists $old->{$dist}{$diff} &&
+ exists $new->{$dist}{$diff};
+ next if $old->{$dist}{$diff} eq $new->{$dist}{$diff};
+ $complain .=
+ scalar gmtime().
+ " GMT:\ndiffering old/new version of same file $dist:\n"
+ unless $headersaid++;
+ $complain .=
+ qq{\t$diff "$old->{$dist}{$diff}" -> "$new->{$dist}{$diff}"\n}; #};
+ }
+ }
+ }
+ $complain;
+}
+
+sub makehashref ($) {
+ local($_) = shift;
+ unless (ref $_ eq "HASH") {
+ require Safe;
+ my($comp) = Safe->new("CPAN::Checksums::reval");
+ my $cksum; # used by Data::Dumper
+ $_ = $comp->reval($_) || {};
+ die "CPAN::Checksums: Caught error[$@] while checking $DIRNAME" if $@;
+ }
+ $_;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Checksums - Write a C<CHECKSUMS> file for a directory as on CPAN
+
+=head1 SYNOPSIS
+
+ use CPAN::Checksums qw(updatedir);
+ my $success = updatedir($directory);
+
+=head1 INCOMPATIBILITY ALERT
+
+Since version 1.0 the generation of the attribute C<shortname> is
+turned off by default. It was too slow and was not used as far as I
+know, and above all, it could fail on large directories. The shortname
+feature can still be turned on by setting the global variable
+$TRY_SHORTNAME to a true value.
+
+=head1 DESCRIPTION
+
+=over 2
+
+=item $success = updatedir($dir)
+
+C<updatedir()> takes a directory name as argument and writes a typical
+C<CHECKSUMS> file in that directory as used on CPAN unless a previously
+written C<CHECKSUMS> file is there that is still valid. Returns 2 if a
+new C<CHECKSUMS> file has been written, 1 if a valid C<CHECKSUMS> file is
+already there, otherwise dies.
+
+Note: since version 2.0 updatedir on empty directories behaves just
+the same. In older versions it silently did nothing.
+
+=back
+
+=head2 Global Variables in package CPAN::Checksums
+
+=over
+
+=item $IGNORE_MATCH
+
+If the global variable $IGNORE_MATCH is set, then all files matching
+this expression will be completely ignored and will not be included in
+the CPAN C<CHECKSUMS> files. Per default this variable is set to
+
+ qr{(?i-xsm:readme$)}
+
+=item $CAUTION
+
+Setting the global variable $CAUTION causes updatedir() to report
+changes of files in the attributes C<size>, C<mtime>, C<md5>, or
+C<md5-ungz> to STDERR.
+
+=item $TRY_SHORTNAME
+
+By setting the global variable $TRY_SHORTNAME to a true value, you can
+tell updatedir() to include an attribute C<shortname> in the resulting
+hash that is 8.3-compatible. Please note, that updatedir() in this
+case may be slow and may even fail on large directories, because it
+will always only try 1000 iterations to find a name that is not yet
+taken and then give up.
+
+=item $SIGNING_KEY
+
+Setting the global variable $SIGNING_KEY makes the generated C<CHECKSUMS>
+file to be clear-signed by the command specified in $SIGNING_PROGRAM
+(defaults to C<gpg --clearsign --default-key >), passing the signing
+key as an extra argument. The resulting C<CHECKSUMS> file should look like:
+
+ 0&&<<''; # this PGP-signed message is also valid perl
+ -----BEGIN PGP SIGNED MESSAGE-----
+ Hash: SHA1
+
+ # CHECKSUMS file written on ... by CPAN::Checksums (v...)
+ $cksum = {
+ ...
+ };
+
+ __END__
+ -----BEGIN PGP SIGNATURE-----
+ ...
+ -----END PGP SIGNATURE-----
+
+note that the actual data remains intact, but two extra lines are
+added to make it legal for both OpenPGP and perl syntax.
+
+=item $MIN_MTIME_CHECKSUMS
+
+If the global variable $MIN_MTIME_CHECKSUMS is set, then updatedir
+will renew signatures on checksum files that have an older mtime than
+the given value.
+
+=back
+
+=head1 PREREQUISITES
+
+DirHandle, IO::File, Digest::MD5, Digest::SHA, Compress::Bzip2,
+Compress::Zlib, File::Spec, Data::Dumper, Data::Compare, File::Temp
+
+=head1 BUGS
+
+If updatedir is interrupted, it may leave a temporary file lying
+around. These files have the File::Temp template C<CHECKSUMS.XXXX> and
+should be harvested by a cronjob.
+
+=head1 AUTHOR
+
+Andreas Koenig, andreas.koenig@anima.de; GnuPG support by Autrijus Tang
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2002-2008 Andreas Koenig, Audrey Tang, Steve Peters.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Complete.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Complete.pm
new file mode 100755
index 00000000000..e1fe896d4a5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Complete.pm
@@ -0,0 +1,175 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Complete;
+use strict;
+@CPAN::Complete::ISA = qw(CPAN::Debug);
+# Q: where is the "How do I add a new command" HOWTO?
+# A: svn diff -r 1048:1049 where andk added the report command
+@CPAN::Complete::COMMANDS = sort qw(
+ ? ! a b d h i m o q r u
+ autobundle
+ bye
+ clean
+ cvs_import
+ dump
+ exit
+ failed
+ force
+ fforce
+ hosts
+ install
+ install_tested
+ is_tested
+ look
+ ls
+ make
+ mkmyconfig
+ notest
+ perldoc
+ quit
+ readme
+ recent
+ recompile
+ reload
+ report
+ reports
+ scripts
+ smoke
+ test
+ upgrade
+);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+package CPAN::Complete;
+use strict;
+
+sub gnu_cpl {
+ my($text, $line, $start, $end) = @_;
+ my(@perlret) = cpl($text, $line, $start);
+ # find longest common match. Can anybody show me how to peruse
+ # T::R::Gnu to have this done automatically? Seems expensive.
+ return () unless @perlret;
+ my($newtext) = $text;
+ for (my $i = length($text)+1;;$i++) {
+ last unless length($perlret[0]) && length($perlret[0]) >= $i;
+ my $try = substr($perlret[0],0,$i);
+ my @tries = grep {substr($_,0,$i) eq $try} @perlret;
+ # warn "try[$try]tries[@tries]";
+ if (@tries == @perlret) {
+ $newtext = $try;
+ } else {
+ last;
+ }
+ }
+ ($newtext,@perlret);
+}
+
+#-> sub CPAN::Complete::cpl ;
+sub cpl {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ $line ||= "";
+ $pos ||= 0;
+ CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ $line =~ s/^\s*//;
+ if ($line =~ s/^((?:notest|f?force)\s*)//) {
+ $pos -= length($1);
+ }
+ my @return;
+ if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
+ @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
+ } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
+ @return = ();
+ } elsif ($line =~ /^a\s/) {
+ @return = cplx('CPAN::Author',uc($word));
+ } elsif ($line =~ /^ls\s/) {
+ my($author,$rest) = $word =~ m|([^/]+)/?(.*)|;
+ @return = $rest ? () : map {"$_/"} cplx('CPAN::Author',uc($author||""));
+ if (0 && 1==@return) { # XXX too slow and even wrong when there is a * already
+ @return = grep /^\Q$word\E/, map {"$author/$_->[2]"} CPAN::Shell->expand("Author",$author)->ls("$rest*","2");
+ }
+ } elsif ($line =~ /^b\s/) {
+ CPAN::Shell->local_bundles;
+ @return = cplx('CPAN::Bundle',$word);
+ } elsif ($line =~ /^d\s/) {
+ @return = cplx('CPAN::Distribution',$word);
+ } elsif ($line =~ m/^(
+ [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
+ )\s/x ) {
+ if ($word =~ /^Bundle::/) {
+ CPAN::Shell->local_bundles;
+ }
+ @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
+ } elsif ($line =~ /^i\s/) {
+ @return = cpl_any($word);
+ } elsif ($line =~ /^reload\s/) {
+ @return = cpl_reload($word,$line,$pos);
+ } elsif ($line =~ /^o\s/) {
+ @return = cpl_option($word,$line,$pos);
+ } elsif ($line =~ m/^\S+\s/ ) {
+ # fallback for future commands and what we have forgotten above
+ @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
+ } else {
+ @return = ();
+ }
+ return @return;
+}
+
+#-> sub CPAN::Complete::cplx ;
+sub cplx {
+ my($class, $word) = @_;
+ if (CPAN::_sqlite_running()) {
+ $CPAN::SQLite->search($class, "^\Q$word\E");
+ }
+ my $method = "id";
+ $method = "pretty_id" if $class eq "CPAN::Distribution";
+ sort grep /^\Q$word\E/, map { $_->$method() } $CPAN::META->all_objects($class);
+}
+
+#-> sub CPAN::Complete::cpl_any ;
+sub cpl_any {
+ my($word) = shift;
+ return (
+ cplx('CPAN::Author',$word),
+ cplx('CPAN::Bundle',$word),
+ cplx('CPAN::Distribution',$word),
+ cplx('CPAN::Module',$word),
+ );
+}
+
+#-> sub CPAN::Complete::cpl_reload ;
+sub cpl_reload {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@words) = split " ", $line;
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@ok) = qw(cpan index);
+ return @ok if @words == 1;
+ return grep /^\Q$word\E/, @ok if @words == 2 && $word;
+}
+
+#-> sub CPAN::Complete::cpl_option ;
+sub cpl_option {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@words) = split " ", $line;
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@ok) = qw(conf debug);
+ return @ok if @words == 1;
+ return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
+ if (0) {
+ } elsif ($words[1] eq 'index') {
+ return ();
+ } elsif ($words[1] eq 'conf') {
+ return CPAN::HandleConfig::cpl(@_);
+ } elsif ($words[1] eq 'debug') {
+ return sort grep /^\Q$word\E/i,
+ sort keys %CPAN::DEBUG, 'all';
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Config.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Config.pm
new file mode 100755
index 00000000000..6fbca32afc8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Config.pm
@@ -0,0 +1,87 @@
+
+# This is CPAN.pm's systemwide configuration file. This file provides
+# defaults for users, and the values can be changed in a per-user
+# configuration file. The user-config file is being looked for as
+# ~/.cpan/CPAN/MyConfig.pm.
+
+my @urllist = (
+ q[http://cpan.strawberryperl.com/],
+);
+if ( -d 'C:\\strawberry\\minicpan' ) {
+ # If we are on fake Hotel/Airport wireless,
+ # prefer the minicpan to the poisoned wireless.
+ eval { require LWP::Online; };
+ unless ( $@ ) {
+ if ( LWP::Online::online() ) {
+ push @urllist, q[file:///C:/strawberry/minicpan/];
+ } else {
+ unshift @urllist, q[file:///C:/strawberry/minicpan/];
+ }
+ }
+}
+
+$CPAN::Config = {
+ applypatch => q[],
+ auto_commit => q[1],
+ build_cache => q[10],
+ build_dir => qq[C:\\strawberry\\cpan\\build],
+ build_dir_reuse => q[0],
+ build_requires_install_policy => q[yes],
+ bzip2 => q[],
+ cache_metadata => q[0],
+ check_sigs => q[0],
+ colorize_output => q[0],
+ colorize_print => q[bold blue on_white],
+ colorize_warn => q[bold red on_white],
+ commandnumber_in_prompt => q[0],
+ cpan_home => q[C:\\strawberry\\cpan],
+ curl => q[],
+ ftp => q[C:\\WINDOWS\\system32\\ftp.EXE],
+ ftp_passive => q[1],
+ ftp_proxy => q[],
+ getcwd => q[cwd],
+ gpg => q[],
+ gzip => q[ ], #will use perl module if it is ' '
+ histfile => q[C:\\strawberry\\cpan\\histfile],
+ histsize => q[100],
+ http_proxy => q[],
+ inactivity_timeout => q[0],
+ index_expire => q[1],
+ inhibit_startup_message => q[0],
+ keep_source_where => q[C:\\strawberry\\cpan\\sources],
+ load_module_verbosity => q[none],
+ lynx => q[],
+ make => q[C:\\strawberry\\c\\bin\\dmake.EXE],
+ make_arg => q[],
+ make_install_arg => q[UNINST=1],
+ makepl_arg => q[],
+ mbuild_arg => q[],
+ mbuild_install_arg => q[--uninst 1],
+ mbuildpl_arg => q[],
+ ncftp => q[],
+ ncftpget => q[],
+ no_proxy => q[],
+ pager => q[C:\\WINDOWS\\system32\\more.COM],
+ patch => q[C:\\strawberry\\c\\bin\\patch.exe],
+ prefer_installer => q[MB],
+ prefs_dir => q[C:\\strawberry\\cpan\\prefs],
+ prerequisites_policy => q[follow],
+ scan_cache => q[atstart],
+ shell => q[C:\\WINDOWS\\system32\\cmd.exe],
+ show_unparsable_versions => q[0],
+ show_upload_date => q[1],
+ show_zero_versions => q[0],
+ tar => q[ ], #will use perl module if it is ' '
+ tar_verbosity => q[none],
+ term_is_latin => q[0],
+ term_ornaments => q[0],
+ test_report => q[0],
+ unzip => q[],
+ urllist => \@urllist,
+ use_sqlite => q[1],
+ wget => q[],
+ yaml_load_code => q[0],
+ yaml_module => q[YAML],
+};
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Debug.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Debug.pm
new file mode 100755
index 00000000000..926b0d79b41
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Debug.pm
@@ -0,0 +1,79 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+package CPAN::Debug;
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "5.5";
+# module is internal to CPAN.pm
+
+%CPAN::DEBUG = qw[
+ CPAN 1
+ Index 2
+ InfoObj 4
+ Author 8
+ Distribution 16
+ Bundle 32
+ Module 64
+ CacheMgr 128
+ Complete 256
+ FTP 512
+ Shell 1024
+ Eval 2048
+ HandleConfig 4096
+ Tarzip 8192
+ Version 16384
+ Queue 32768
+ FirstTime 65536
+];
+
+$CPAN::DEBUG ||= 0;
+
+#-> sub CPAN::Debug::debug ;
+sub debug {
+ my($self,$arg) = @_;
+
+ my @caller;
+ my $i = 0;
+ while () {
+ my(@c) = (caller($i))[0 .. ($i ? 3 : 2)];
+ last unless defined $c[0];
+ push @caller, \@c;
+ for (0,3) {
+ last if $_ > $#c;
+ $c[$_] =~ s/.*:://;
+ }
+ for (1) {
+ $c[$_] =~ s|.*/||;
+ }
+ last if ++$i>=3;
+ }
+ pop @caller;
+ if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) {
+ if ($arg and ref $arg) {
+ eval { require Data::Dumper };
+ if ($@) {
+ $CPAN::Frontend->myprint($arg->as_string);
+ } else {
+ $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
+ }
+ } else {
+ my $outer = "";
+ local $" = ",";
+ if (@caller>1) {
+ $outer = ",[@{$caller[1]}]";
+ }
+ $CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/DeferredCode.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/DeferredCode.pm
new file mode 100755
index 00000000000..0db37a64853
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/DeferredCode.pm
@@ -0,0 +1,16 @@
+package CPAN::DeferredCode;
+
+use strict;
+use vars qw/$VERSION/;
+
+use overload fallback => 1, map { ($_ => 'run') } qw/
+ bool "" 0+
+/;
+
+$VERSION = "5.50";
+
+sub run {
+ $_[0]->();
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/DistnameInfo.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/DistnameInfo.pm
new file mode 100755
index 00000000000..808cf2ba40d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/DistnameInfo.pm
@@ -0,0 +1,194 @@
+
+package CPAN::DistnameInfo;
+
+$VERSION = "0.09";
+use strict;
+
+sub distname_info {
+ my $file = shift or return;
+
+ my ($dist, $version) = $file =~ /^
+ ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
+ (?:
+ [A-Za-z](?=[^A-Za-z]|$)
+ |
+ \d(?=-)
+ )(?<![._-][vV])
+ )+)(.*)
+ $/xs or return ($file,undef,undef);
+
+ if ($dist =~ /-undef\z/ and ! length $version) {
+ $dist =~ s/-undef\z//;
+ }
+
+ if ($version =~ /^(-[Vv].*)-(\d.*)/) {
+
+ # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
+ # where the V3_1_1 is part of the distname
+ $dist .= $1;
+ $version = $2;
+ }
+
+ # Normalize the Dist.pm-1.23 convention which CGI.pm and
+ # a few others use.
+ $dist =~ s{\.pm$}{};
+
+ $version = $1
+ if !length $version and $dist =~ s/-(\d+\w)$//;
+
+ $version = $1 . $version
+ if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
+
+ if ($version =~ /\d\.\d/) {
+ $version =~ s/^[-_.]+//;
+ }
+ else {
+ $version =~ s/^[-_]+//;
+ }
+
+ my $dev;
+ if (length $version) {
+ if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
+ $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
+ }
+ elsif ($version =~ /\d\D\d+_\d/) {
+ $dev = 1;
+ }
+ }
+ else {
+ $version = undef;
+ }
+
+ ($dist, $version, $dev);
+}
+
+sub new {
+ my $class = shift;
+ my $distfile = shift;
+
+ $distfile =~ s,//+,/,g;
+
+ my %info = ( pathname => $distfile );
+
+ ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
+ and $info{cpanid} = $6;
+
+ if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
+ $info{distvname} = $1;
+ $info{extension} = $2;
+ }
+
+ @info{qw(dist version beta)} = distname_info($info{distvname});
+ $info{maturity} = delete $info{beta} ? 'developer' : 'released';
+
+ return bless \%info, $class;
+}
+
+sub dist { shift->{dist} }
+sub version { shift->{version} }
+sub maturity { shift->{maturity} }
+sub filename { shift->{filename} }
+sub cpanid { shift->{cpanid} }
+sub distvname { shift->{distvname} }
+sub extension { shift->{extension} }
+sub pathname { shift->{pathname} }
+
+sub properties { %{ $_[0] } }
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::DistnameInfo - Extract distribution name and version from a distribution filename
+
+=head1 SYNOPSIS
+
+ my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz";
+
+ my $d = CPAN::DistnameInfo->new($pathname);
+
+ my $dist = $d->dist; # "CPAN-DistnameInfo"
+ my $version = $d->version; # "0.02"
+ my $maturity = $d->maturity; # "released"
+ my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
+ my $cpanid = $d->cpanid; # "GBARR"
+ my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
+ my $extension = $d->extension; # "tar.gz"
+ my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..."
+
+ my %prop = $d->properties;
+
+=head1 DESCRIPTION
+
+Many online services that are centered around CPAN attempt to
+associate multiple uploads by extracting a distribution name from
+the filename of the upload. For most distributions this is easy as
+they have used ExtUtils::MakeMaker or Module::Build to create the
+distribution, which results in a uniform name. But sadly not all
+uploads are created in this way.
+
+C<CPAN::DistnameInfo> uses heuristics that have been learnt by
+L<http://search.cpan.org/> to extract the distribution name and
+version from filenames and also report if the version is to be
+treated as a developer release
+
+The constructor takes a single pathname, returning an object with the following methods
+
+=over
+
+=item cpanid
+
+If the path given looked like a CPAN authors directory path, then this will be the
+the CPAN id of the author.
+
+=item dist
+
+The name of the distribution
+
+=item distvname
+
+The file name with any suffix and leading directory names removed
+
+=item filename
+
+If the path given looked like a CPAN authors directory path, then this will be the
+path to the file relative to the detected CPAN author directory. Otherwise it is the path
+that was passed in.
+
+=item maturity
+
+The maturity of the distribution. This will be either C<released> or C<developer>
+
+=item extension
+
+The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz')
+
+=item pathname
+
+The pathname that was passed to the constructor when creating the object.
+
+=item properties
+
+This will return a list of key-value pairs, suitable for assigning to a hash,
+for the known properties.
+
+=item version
+
+The extracted version
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Graham Barr. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm
new file mode 100755
index 00000000000..22d3f0640b3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm
@@ -0,0 +1,3879 @@
+package CPAN::Distribution;
+use strict;
+use Cwd qw(chdir);
+use CPAN::Distroprefs;
+use CPAN::InfoObj;
+@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
+use vars qw($VERSION);
+$VERSION = "1.94";
+
+# Accessors
+sub cpan_comment {
+ my $self = shift;
+ my $ro = $self->ro or return;
+ $ro->{CPAN_COMMENT}
+}
+
+#-> CPAN::Distribution::undelay
+sub undelay {
+ my $self = shift;
+ for my $delayer (
+ "configure_requires_later",
+ "configure_requires_later_for",
+ "later",
+ "later_for",
+ ) {
+ delete $self->{$delayer};
+ }
+}
+
+#-> CPAN::Distribution::is_dot_dist
+sub is_dot_dist {
+ my($self) = @_;
+ return substr($self->id,-1,1) eq ".";
+}
+
+# add the A/AN/ stuff
+#-> CPAN::Distribution::normalize
+sub normalize {
+ my($self,$s) = @_;
+ $s = $self->id unless defined $s;
+ if (substr($s,-1,1) eq ".") {
+ # using a global because we are sometimes called as static method
+ if (!$CPAN::META->{LOCK}
+ && !$CPAN::Have_warned->{"$s is unlocked"}++
+ ) {
+ $CPAN::Frontend->mywarn("You are visiting the local directory
+ '$s'
+ without lock, take care that concurrent processes do not do likewise.\n");
+ $CPAN::Frontend->mysleep(1);
+ }
+ if ($s eq ".") {
+ $s = "$CPAN::iCwd/.";
+ } elsif (File::Spec->file_name_is_absolute($s)) {
+ } elsif (File::Spec->can("rel2abs")) {
+ $s = File::Spec->rel2abs($s);
+ } else {
+ $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
+ }
+ CPAN->debug("s[$s]") if $CPAN::DEBUG;
+ unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
+ for ($CPAN::META->instance("CPAN::Distribution", $s)) {
+ $_->{build_dir} = $s;
+ $_->{archived} = "local_directory";
+ $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
+ }
+ }
+ } elsif (
+ $s =~ tr|/|| == 1
+ or
+ $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
+ ) {
+ return $s if $s =~ m:^N/A|^Contact Author: ;
+ $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
+ CPAN->debug("s[$s]") if $CPAN::DEBUG;
+ }
+ $s;
+}
+
+#-> sub CPAN::Distribution::author ;
+sub author {
+ my($self) = @_;
+ my($authorid);
+ if (substr($self->id,-1,1) eq ".") {
+ $authorid = "LOCAL";
+ } else {
+ ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
+ }
+ CPAN::Shell->expand("Author",$authorid);
+}
+
+# tries to get the yaml from CPAN instead of the distro itself:
+# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
+sub fast_yaml {
+ my($self) = @_;
+ my $meta = $self->pretty_id;
+ $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
+ my(@ls) = CPAN::Shell->globls($meta);
+ my $norm = $self->normalize($meta);
+
+ my($local_file);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$norm)
+ );
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ unless ($local_file =
+ CPAN::FTP->localize("authors/id/$norm",
+ $local_wanted)) {
+ $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
+ }
+ my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
+}
+
+#-> sub CPAN::Distribution::cpan_userid
+sub cpan_userid {
+ my $self = shift;
+ if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
+ return $1;
+ }
+ return $self->SUPER::cpan_userid;
+}
+
+#-> sub CPAN::Distribution::pretty_id
+sub pretty_id {
+ my $self = shift;
+ my $id = $self->id;
+ return $id unless $id =~ m|^./../|;
+ substr($id,5);
+}
+
+#-> sub CPAN::Distribution::base_id
+sub base_id {
+ my $self = shift;
+ my $id = $self->pretty_id();
+ my $base_id = File::Basename::basename($id);
+ $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
+ return $base_id;
+}
+
+#-> sub CPAN::Distribution::tested_ok_but_not_installed
+sub tested_ok_but_not_installed {
+ my $self = shift;
+ return (
+ $self->{make_test}
+ && $self->{build_dir}
+ && (UNIVERSAL::can($self->{make_test},"failed") ?
+ ! $self->{make_test}->failed :
+ $self->{make_test} =~ /^YES/
+ )
+ && (
+ !$self->{install}
+ ||
+ $self->{install}->failed
+ )
+ );
+}
+
+
+# mark as dirty/clean for the sake of recursion detection. $color=1
+# means "in use", $color=0 means "not in use anymore". $color=2 means
+# we have determined prereqs now and thus insist on passing this
+# through (at least) once again.
+
+#-> sub CPAN::Distribution::color_cmd_tmps ;
+sub color_cmd_tmps {
+ my($self) = shift;
+ my($depth) = shift || 0;
+ my($color) = shift || 0;
+ my($ancestors) = shift || [];
+ # a distribution needs to recurse into its prereq_pms
+
+ return if exists $self->{incommandcolor}
+ && $color==1
+ && $self->{incommandcolor}==$color;
+ if ($depth>=$CPAN::MAX_RECURSION) {
+ die(CPAN::Exception::RecursiveDependency->new($ancestors));
+ }
+ # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+ my $prereq_pm = $self->prereq_pm;
+ if (defined $prereq_pm) {
+ PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
+ keys %{$prereq_pm->{build_requires}||{}}) {
+ next PREREQ if $pre eq "perl";
+ my $premo;
+ unless ($premo = CPAN::Shell->expand("Module",$pre)) {
+ $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
+ $CPAN::Frontend->mysleep(2);
+ next PREREQ;
+ }
+ $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
+ }
+ }
+ if ($color==0) {
+ delete $self->{sponsored_mods};
+
+ # as we are at the end of a command, we'll give up this
+ # reminder of a broken test. Other commands may test this guy
+ # again. Maybe 'badtestcnt' should be renamed to
+ # 'make_test_failed_within_command'?
+ delete $self->{badtestcnt};
+ }
+ $self->{incommandcolor} = $color;
+}
+
+#-> sub CPAN::Distribution::as_string ;
+sub as_string {
+ my $self = shift;
+ $self->containsmods;
+ $self->upload_date;
+ $self->SUPER::as_string(@_);
+}
+
+#-> sub CPAN::Distribution::containsmods ;
+sub containsmods {
+ my $self = shift;
+ return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
+ my $dist_id = $self->{ID};
+ for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
+ my $mod_file = $mod->cpan_file or next;
+ my $mod_id = $mod->{ID} or next;
+ # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
+ # sleep 1;
+ if ($CPAN::Signal) {
+ delete $self->{CONTAINSMODS};
+ return;
+ }
+ $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
+ }
+ keys %{$self->{CONTAINSMODS}||={}};
+}
+
+#-> sub CPAN::Distribution::upload_date ;
+sub upload_date {
+ my $self = shift;
+ return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
+ my(@local_wanted) = split(/\//,$self->id);
+ my $filename = pop @local_wanted;
+ push @local_wanted, "CHECKSUMS";
+ my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
+ return unless $author;
+ my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
+ return unless @dl;
+ my($dirent) = grep { $_->[2] eq $filename } @dl;
+ # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
+ return unless $dirent->[1];
+ return $self->{UPLOAD_DATE} = $dirent->[1];
+}
+
+#-> sub CPAN::Distribution::uptodate ;
+sub uptodate {
+ my($self) = @_;
+ my $c;
+ foreach $c ($self->containsmods) {
+ my $obj = CPAN::Shell->expandany($c);
+ unless ($obj->uptodate) {
+ my $id = $self->pretty_id;
+ $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
+ return 0;
+ }
+ }
+ return 1;
+}
+
+#-> sub CPAN::Distribution::called_for ;
+sub called_for {
+ my($self,$id) = @_;
+ $self->{CALLED_FOR} = $id if defined $id;
+ return $self->{CALLED_FOR};
+}
+
+#-> sub CPAN::Distribution::get ;
+sub get {
+ my($self) = @_;
+ $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
+ if (my $goto = $self->prefs->{goto}) {
+ $CPAN::Frontend->mywarn
+ (sprintf(
+ "delegating to '%s' as specified in prefs file '%s' doc %d\n",
+ $goto,
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ ));
+ return $self->goto($goto);
+ }
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ EXCUSE: {
+ my @e;
+ my $goodbye_message;
+ $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
+ if ($self->prefs->{disabled} && ! $self->{force_update}) {
+ my $why = sprintf(
+ "Disabled via prefs file '%s' doc %d",
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ );
+ push @e, $why;
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
+ $goodbye_message = "[disabled] -- NA $why";
+ # note: not intended to be persistent but at least visible
+ # during this session
+ } else {
+ if (exists $self->{build_dir} && -d $self->{build_dir}
+ && ($self->{modulebuild}||$self->{writemakefile})
+ ) {
+ # this deserves print, not warn:
+ $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
+ "$self->{build_dir}\n"
+ );
+ return 1;
+ }
+
+ # although we talk about 'force' we shall not test on
+ # force directly. New model of force tries to refrain from
+ # direct checking of force.
+ exists $self->{unwrapped} and (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )
+ and push @e, "Unwrapping had some problem, won't try again without force";
+ }
+ if (@e) {
+ $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
+ if ($goodbye_message) {
+ $self->goodbye($goodbye_message);
+ }
+ return;
+ }
+ }
+ my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
+
+ my($local_file);
+ unless ($self->{build_dir} && -d $self->{build_dir}) {
+ $self->get_file_onto_local_disk;
+ return if $CPAN::Signal;
+ $self->check_integrity;
+ return if $CPAN::Signal;
+ (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
+ if (exists $self->{writemakefile} && ref $self->{writemakefile}
+ && $self->{writemakefile}->can("failed") &&
+ $self->{writemakefile}->failed) {
+ return;
+ }
+ $packagedir ||= $self->{build_dir};
+ $self->{build_dir} = $packagedir;
+ }
+
+ if ($CPAN::Signal) {
+ $self->safe_chdir($sub_wd);
+ return;
+ }
+ return $self->choose_MM_or_MB($local_file);
+}
+
+#-> CPAN::Distribution::get_file_onto_local_disk
+sub get_file_onto_local_disk {
+ my($self) = @_;
+
+ return if $self->is_dot_dist;
+ my($local_file);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$self->id)
+ );
+
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ unless ($local_file =
+ CPAN::FTP->localize("authors/id/$self->{ID}",
+ $local_wanted)) {
+ my $note = "";
+ if ($CPAN::Index::DATE_OF_02) {
+ $note = "Note: Current database in memory was generated ".
+ "on $CPAN::Index::DATE_OF_02\n";
+ }
+ $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
+ }
+
+ $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
+ $self->{localfile} = $local_file;
+}
+
+
+#-> CPAN::Distribution::check_integrity
+sub check_integrity {
+ my($self) = @_;
+
+ return if $self->is_dot_dist;
+ if ($CPAN::META->has_inst("Digest::SHA")) {
+ $self->debug("Digest::SHA is installed, verifying");
+ $self->verifyCHECKSUM;
+ } else {
+ $self->debug("Digest::SHA is NOT installed");
+ }
+}
+
+#-> CPAN::Distribution::run_preps_on_packagedir
+sub run_preps_on_packagedir {
+ my($self) = @_;
+ return if $self->is_dot_dist;
+
+ $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
+ my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
+ $self->safe_chdir($builddir);
+ $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
+ File::Path::rmtree("tmp-$$");
+ unless (mkdir "tmp-$$", 0755) {
+ $CPAN::Frontend->unrecoverable_error(<<EOF);
+Couldn't mkdir '$builddir/tmp-$$': $!
+
+Cannot continue: Please find the reason why I cannot make the
+directory
+$builddir/tmp-$$
+and fix the problem, then retry.
+
+EOF
+ }
+ if ($CPAN::Signal) {
+ return;
+ }
+ $self->safe_chdir("tmp-$$");
+
+ #
+ # Unpack the goods
+ #
+ my $local_file = $self->{localfile};
+ my $ct = eval{CPAN::Tarzip->new($local_file)};
+ unless ($ct) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO");
+ delete $self->{build_dir};
+ return;
+ }
+ if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
+ $self->{was_uncompressed}++ unless eval{$ct->gtest()};
+ $self->untar_me($ct);
+ } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
+ $self->unzip_me($ct);
+ } else {
+ $self->{was_uncompressed}++ unless $ct->gtest();
+ $local_file = $self->handle_singlefile($local_file);
+ }
+
+ # we are still in the tmp directory!
+ # Let's check if the package has its own directory.
+ my $dh = DirHandle->new(File::Spec->curdir)
+ or Carp::croak("Couldn't opendir .: $!");
+ my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
+ if (grep { $_ eq "pax_global_header" } @readdir) {
+ $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
+from the tarball '$local_file'.
+This is almost certainly an error. Please upgrade your tar.
+I'll ignore this file for now.
+See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
+ $CPAN::Frontend->mysleep(5);
+ @readdir = grep { $_ ne "pax_global_header" } @readdir;
+ }
+ $dh->close;
+ my ($packagedir);
+ # XXX here we want in each branch File::Temp to protect all build_dir directories
+ if (CPAN->has_usable("File::Temp")) {
+ my $tdir_base;
+ my $from_dir;
+ my @dirents;
+ if (@readdir == 1 && -d $readdir[0]) {
+ $tdir_base = $readdir[0];
+ $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
+ my $dh2;
+ unless ($dh2 = DirHandle->new($from_dir)) {
+ my($mode) = (stat $from_dir)[2];
+ my $why = sprintf
+ (
+ "Couldn't opendir '%s', mode '%o': %s",
+ $from_dir,
+ $mode,
+ $!,
+ );
+ $CPAN::Frontend->mywarn("$why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
+ return;
+ }
+ @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
+ } else {
+ my $userid = $self->cpan_userid;
+ CPAN->debug("userid[$userid]");
+ if (!$userid or $userid eq "N/A") {
+ $userid = "anon";
+ }
+ $tdir_base = $userid;
+ $from_dir = File::Spec->curdir;
+ @dirents = @readdir;
+ }
+ $packagedir = File::Temp::tempdir(
+ "$tdir_base-XXXXXX",
+ DIR => $builddir,
+ CLEANUP => 0,
+ );
+ chmod 0777 &~ umask, $packagedir; # may fail
+ my $f;
+ for $f (@dirents) { # is already without "." and ".."
+ my $from = File::Spec->catdir($from_dir,$f);
+ my $to = File::Spec->catdir($packagedir,$f);
+ unless (File::Copy::move($from,$to)) {
+ my $err = $!;
+ $from = File::Spec->rel2abs($from);
+ Carp::confess("Couldn't move $from to $to: $err");
+ }
+ }
+ } else { # older code below, still better than nothing when there is no File::Temp
+ my($distdir);
+ if (@readdir == 1 && -d $readdir[0]) {
+ $distdir = $readdir[0];
+ $packagedir = File::Spec->catdir($builddir,$distdir);
+ $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
+ if $CPAN::DEBUG;
+ -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
+ "$packagedir\n");
+ File::Path::rmtree($packagedir);
+ unless (File::Copy::move($distdir,$packagedir)) {
+ $CPAN::Frontend->unrecoverable_error(<<EOF);
+Couldn't move '$distdir' to '$packagedir': $!
+
+Cannot continue: Please find the reason why I cannot move
+$builddir/tmp-$$/$distdir
+to
+$packagedir
+and fix the problem, then retry
+
+EOF
+ }
+ $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
+ $distdir,
+ $packagedir,
+ -e $packagedir,
+ -d $packagedir,
+ )) if $CPAN::DEBUG;
+ } else {
+ my $userid = $self->cpan_userid;
+ CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
+ if (!$userid or $userid eq "N/A") {
+ $userid = "anon";
+ }
+ my $pragmatic_dir = $userid . '000';
+ $pragmatic_dir =~ s/\W_//g;
+ $pragmatic_dir++ while -d "../$pragmatic_dir";
+ $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
+ $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
+ File::Path::mkpath($packagedir);
+ my($f);
+ for $f (@readdir) { # is already without "." and ".."
+ my $to = File::Spec->catdir($packagedir,$f);
+ File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
+ }
+ }
+ }
+ $self->{build_dir} = $packagedir;
+ $self->safe_chdir($builddir);
+ File::Path::rmtree("tmp-$$");
+
+ $self->safe_chdir($packagedir);
+ $self->_signature_business();
+ $self->safe_chdir($builddir);
+
+ return($packagedir,$local_file);
+}
+
+#-> sub CPAN::Distribution::parse_meta_yml ;
+sub parse_meta_yml {
+ my($self) = @_;
+ my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
+ my $yaml = File::Spec->catfile($build_dir,"META.yml");
+ $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
+ return unless -f $yaml;
+ my $early_yaml;
+ eval {
+ require Parse::CPAN::Meta;
+ $early_yaml = Parse::CPAN::Meta::LoadFile($yaml)->[0];
+ };
+ unless ($early_yaml) {
+ eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
+ }
+ unless ($early_yaml) {
+ return;
+ }
+ return $early_yaml;
+}
+
+#-> sub CPAN::Distribution::satisfy_requires ;
+sub satisfy_requires {
+ my ($self) = @_;
+ if (my @prereq = $self->unsat_prereq("later")) {
+ if ($prereq[0][0] eq "perl") {
+ my $need = "requires perl '$prereq[0][1]'";
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
+ $self->{make} = CPAN::Distrostatus->new("NO $need");
+ $self->store_persistent_state;
+ die "[prereq] -- NOT OK\n";
+ } else {
+ my $follow = eval { $self->follow_prereqs("later",@prereq); };
+ if (0) {
+ } elsif ($follow) {
+ # signal success to the queuerunner
+ return 1;
+ } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ die "[depend] -- NOT OK\n";
+ }
+ }
+ }
+}
+
+#-> sub CPAN::Distribution::satisfy_configure_requires ;
+sub satisfy_configure_requires {
+ my($self) = @_;
+ my $enable_configure_requires = 1;
+ if (!$enable_configure_requires) {
+ return 1;
+ # if we return 1 here, everything is as before we introduced
+ # configure_requires that means, things with
+ # configure_requires simply fail, all others succeed
+ }
+ my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
+ if ($self->{configure_requires_later}) {
+ for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
+ if ($self->{configure_requires_later_for}{$k}>1) {
+ # we must not come here a second time
+ $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
+ require YAML::Syck;
+ $CPAN::Frontend->mydie
+ (
+ YAML::Syck::Dump
+ ({self=>$self, prereq=>\@prereq})
+ );
+ }
+ }
+ }
+ if ($prereq[0][0] eq "perl") {
+ my $need = "requires perl '$prereq[0][1]'";
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
+ $self->{make} = CPAN::Distrostatus->new("NO $need");
+ $self->store_persistent_state;
+ return $self->goodbye("[prereq] -- NOT OK");
+ } else {
+ my $follow = eval {
+ $self->follow_prereqs("configure_requires_later", @prereq);
+ };
+ if (0) {
+ } elsif ($follow) {
+ return;
+ } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ return $self->goodbye("[depend] -- NOT OK");
+ }
+ else {
+ return $self->goodbye("[configure_requires] -- NOT OK");
+ }
+ }
+ die "never reached";
+}
+
+#-> sub CPAN::Distribution::choose_MM_or_MB ;
+sub choose_MM_or_MB {
+ my($self,$local_file) = @_;
+ $self->satisfy_configure_requires() or return;
+ my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
+ my($mpl_exists) = -f $mpl;
+ unless ($mpl_exists) {
+ # NFS has been reported to have racing problems after the
+ # renaming of a directory in some environments.
+ # This trick helps.
+ $CPAN::Frontend->mysleep(1);
+ my $mpldh = DirHandle->new($self->{build_dir})
+ or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
+ $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
+ $mpldh->close;
+ }
+ my $prefer_installer = "eumm"; # eumm|mb
+ if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
+ if ($mpl_exists) { # they *can* choose
+ if ($CPAN::META->has_inst("Module::Build")) {
+ $prefer_installer = CPAN::HandleConfig->prefs_lookup(
+ $self, q{prefer_installer}
+ );
+ # M::B <= 0.35 left a DATA handle open that
+ # causes problems upgrading M::B on Windows
+ close *Module::Build::Version::DATA
+ if fileno *Module::Build::Version::DATA;
+ }
+ } else {
+ $prefer_installer = "mb";
+ }
+ }
+ return unless $self->patch;
+ if (lc($prefer_installer) eq "rand") {
+ $prefer_installer = rand()<.5 ? "eumm" : "mb";
+ }
+ if (lc($prefer_installer) eq "mb") {
+ $self->{modulebuild} = 1;
+ } elsif ($self->{archived} eq "patch") {
+ # not an edge case, nothing to install for sure
+ my $why = "A patch file cannot be installed";
+ $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
+ } elsif (! $mpl_exists) {
+ $self->_edge_cases($mpl,$local_file);
+ }
+ if ($self->{build_dir}
+ &&
+ $CPAN::Config->{build_dir_reuse}
+ ) {
+ $self->store_persistent_state;
+ }
+ return $self;
+}
+
+#-> CPAN::Distribution::store_persistent_state
+sub store_persistent_state {
+ my($self) = @_;
+ my $dir = $self->{build_dir};
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
+ $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
+ "will not store persistent state\n");
+ return;
+ }
+ my $file = sprintf "%s.yml", $dir;
+ my $yaml_module = CPAN::_yaml_module();
+ if ($CPAN::META->has_inst($yaml_module)) {
+ CPAN->_yaml_dumpfile(
+ $file,
+ {
+ time => time,
+ perl => CPAN::_perl_fingerprint(),
+ distribution => $self,
+ }
+ );
+ } else {
+ $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
+ "will not store persistent state\n");
+ }
+}
+
+#-> CPAN::Distribution::try_download
+sub try_download {
+ my($self,$patch) = @_;
+ my $norm = $self->normalize($patch);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$norm),
+ );
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ return CPAN::FTP->localize("authors/id/$norm",
+ $local_wanted);
+}
+
+{
+ my $stdpatchargs = "";
+ #-> CPAN::Distribution::patch
+ sub patch {
+ my($self) = @_;
+ $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
+ my $patches = $self->prefs->{patches};
+ $patches ||= "";
+ $self->debug("patches[$patches]") if $CPAN::DEBUG;
+ if ($patches) {
+ return unless @$patches;
+ $self->safe_chdir($self->{build_dir});
+ CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
+ my $patchbin = $CPAN::Config->{patch};
+ unless ($patchbin && length $patchbin) {
+ $CPAN::Frontend->mydie("No external patch command configured\n\n".
+ "Please run 'o conf init /patch/'\n\n");
+ }
+ unless (MM->maybe_command($patchbin)) {
+ $CPAN::Frontend->mydie("No external patch command available\n\n".
+ "Please run 'o conf init /patch/'\n\n");
+ }
+ $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
+ local $ENV{PATCH_GET} = 0; # formerly known as -g0
+ unless ($stdpatchargs) {
+ my $system = "$patchbin --version |";
+ local *FH;
+ open FH, $system or die "Could not fork '$system': $!";
+ local $/ = "\n";
+ my $pversion;
+ PARSEVERSION: while (<FH>) {
+ if (/^patch\s+([\d\.]+)/) {
+ $pversion = $1;
+ last PARSEVERSION;
+ }
+ }
+ if ($pversion) {
+ $stdpatchargs = "-N --fuzz=3";
+ } else {
+ $stdpatchargs = "-N";
+ }
+ }
+ my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
+ $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
+ my $patches_dir = $CPAN::Config->{patches_dir};
+ for my $patch (@$patches) {
+ if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
+ my $f = File::Spec->catfile($patches_dir, $patch);
+ $patch = $f if -f $f;
+ }
+ unless (-f $patch) {
+ CPAN->debug("not on disk: patch[$patch]") if $CPAN::DEBUG;
+ if (my $trydl = $self->try_download($patch)) {
+ $patch = $trydl;
+ } else {
+ my $fail = "Could not find patch '$patch'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ }
+ $CPAN::Frontend->myprint(" $patch\n");
+ my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
+
+ my $pcommand;
+ my $ppp = $self->_patch_p_parameter($readfh);
+ if ($ppp eq "applypatch") {
+ $pcommand = "$CPAN::Config->{applypatch} -verbose";
+ } else {
+ my $thispatchargs = join " ", $stdpatchargs, $ppp;
+ $pcommand = "$patchbin $thispatchargs";
+ }
+
+ $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
+ my $writefh = FileHandle->new;
+ $CPAN::Frontend->myprint(" $pcommand\n");
+ unless (open $writefh, "|$pcommand") {
+ my $fail = "Could not fork '$pcommand'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ binmode($writefh);
+ while (my $x = $readfh->READLINE) {
+ print $writefh $x;
+ }
+ unless (close $writefh) {
+ my $fail = "Could not apply patch '$patch'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ }
+ $self->{patched}++;
+ }
+ return 1;
+ }
+}
+
+sub _patch_p_parameter {
+ my($self,$fh) = @_;
+ my $cnt_files = 0;
+ my $cnt_p0files = 0;
+ local($_);
+ while ($_ = $fh->READLINE) {
+ if (
+ $CPAN::Config->{applypatch}
+ &&
+ /\#\#\#\# ApplyPatch data follows \#\#\#\#/
+ ) {
+ return "applypatch"
+ }
+ next unless /^[\*\+]{3}\s(\S+)/;
+ my $file = $1;
+ $cnt_files++;
+ $cnt_p0files++ if -f $file;
+ CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
+ if $CPAN::DEBUG;
+ }
+ return "-p1" unless $cnt_files;
+ return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
+}
+
+#-> sub CPAN::Distribution::_edge_cases
+# with "configure" or "Makefile" or single file scripts
+sub _edge_cases {
+ my($self,$mpl,$local_file) = @_;
+ $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
+ $mpl,
+ CPAN::anycwd(),
+ )) if $CPAN::DEBUG;
+ my $build_dir = $self->{build_dir};
+ my($configure) = File::Spec->catfile($build_dir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{configure} = $configure;
+ } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
+ $CPAN::Frontend->mywarn(qq{
+Package comes with a Makefile and without a Makefile.PL.
+We\'ll try to build it with that Makefile then.
+});
+ $self->{writemakefile} = CPAN::Distrostatus->new("YES");
+ $CPAN::Frontend->mysleep(2);
+ } else {
+ my $cf = $self->called_for || "unknown";
+ if ($cf =~ m|/|) {
+ $cf =~ s|.*/||;
+ $cf =~ s|\W.*||;
+ }
+ $cf =~ s|[/\\:]||g; # risk of filesystem damage
+ $cf = "unknown" unless length($cf);
+ if (my $crud = $self->_contains_crud($build_dir)) {
+ my $why = qq{Package contains $crud; not recognized as a perl package, giving up};
+ $CPAN::Frontend->mywarn("$why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
+ return;
+ }
+ $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
+ (The test -f "$mpl" returned false.)
+ Writing one on our own (setting NAME to $cf)\a\n});
+ $self->{had_no_makefile_pl}++;
+ $CPAN::Frontend->mysleep(3);
+
+ # Writing our own Makefile.PL
+
+ my $exefile_stanza = "";
+ if ($self->{archived} eq "maybe_pl") {
+ $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
+ }
+
+ my $fh = FileHandle->new;
+ $fh->open(">$mpl")
+ or Carp::croak("Could not open >$mpl: $!");
+ $fh->print(
+ qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
+# because there was no Makefile.PL supplied.
+# Autogenerated on: }.scalar localtime().qq{
+
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => q[$cf],$exefile_stanza
+ );
+});
+ $fh->close;
+ }
+}
+
+#-> CPAN;:Distribution::_contains_crud
+sub _contains_crud {
+ my($self,$dir) = @_;
+ my(@dirs, $dh, @files);
+ opendir $dh, $dir or return;
+ my $dirent;
+ for $dirent (readdir $dh) {
+ next if $dirent =~ /^\.\.?$/;
+ my $path = File::Spec->catdir($dir,$dirent);
+ if (-d $path) {
+ push @dirs, $dirent;
+ } elsif (-f $path) {
+ push @files, $dirent;
+ }
+ }
+ if (@dirs && @files) {
+ return "both files[@files] and directories[@dirs]";
+ } elsif (@files > 2) {
+ return "several files[@files] but no Makefile.PL or Build.PL";
+ }
+ return;
+}
+
+#-> CPAN;:Distribution::_exefile_stanza
+sub _exefile_stanza {
+ my($self,$build_dir,$local_file) = @_;
+
+ my $fh = FileHandle->new;
+ my $script_file = File::Spec->catfile($build_dir,$local_file);
+ $fh->open($script_file)
+ or Carp::croak("Could not open script '$script_file': $!");
+ local $/ = "\n";
+ # name parsen und prereq
+ my($state) = "poddir";
+ my($name, $prereq) = ("", "");
+ while (<$fh>) {
+ if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
+ if ($1 eq 'NAME') {
+ $state = "name";
+ } elsif ($1 eq 'PREREQUISITES') {
+ $state = "prereq";
+ }
+ } elsif ($state =~ m{^(name|prereq)$}) {
+ if (/^=/) {
+ $state = "poddir";
+ } elsif (/^\s*$/) {
+ # nop
+ } elsif ($state eq "name") {
+ if ($name eq "") {
+ ($name) = /^(\S+)/;
+ $state = "poddir";
+ }
+ } elsif ($state eq "prereq") {
+ $prereq .= $_;
+ }
+ } elsif (/^=cut\b/) {
+ last;
+ }
+ }
+ $fh->close;
+
+ for ($name) {
+ s{.*<}{}; # strip X<...>
+ s{>.*}{};
+ }
+ chomp $prereq;
+ $prereq = join " ", split /\s+/, $prereq;
+ my($PREREQ_PM) = join("\n", map {
+ s{.*<}{}; # strip X<...>
+ s{>.*}{};
+ if (/[\s\'\"]/) { # prose?
+ } else {
+ s/[^\w:]$//; # period?
+ " "x28 . "'$_' => 0,";
+ }
+ } split /\s*,\s*/, $prereq);
+
+ if ($name) {
+ my $to_file = File::Spec->catfile($build_dir, $name);
+ rename $script_file, $to_file
+ or die "Can't rename $script_file to $to_file: $!";
+ }
+
+ return "
+ EXE_FILES => ['$name'],
+ PREREQ_PM => {
+$PREREQ_PM
+ },
+";
+}
+
+#-> CPAN::Distribution::_signature_business
+sub _signature_business {
+ my($self) = @_;
+ my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
+ q{check_sigs});
+ if ($check_sigs) {
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ if (-f "SIGNATURE") {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
+ my $rv = Module::Signature::verify();
+ if ($rv != Module::Signature::SIGNATURE_OK() and
+ $rv != Module::Signature::SIGNATURE_MISSING()) {
+ $CPAN::Frontend->mywarn(
+ qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}
+ );
+
+ my $wrap =
+ sprintf(qq{I'd recommend removing %s. Some error occurred }.
+ qq{while checking its signature, so it could }.
+ qq{be invalid. Maybe you have configured }.
+ qq{your 'urllist' with a bad URL. Please check this }.
+ qq{array with 'o conf urllist' and retry. Or }.
+ qq{examine the distribution in a subshell. Try
+ look %s
+and run
+ cpansign -v
+},
+ $self->{localfile},
+ $self->pretty_id,
+ );
+ $self->{signature_verify} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
+ $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
+ } else {
+ $self->{signature_verify} = CPAN::Distrostatus->new("YES");
+ $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
+ }
+ } else {
+ $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
+ }
+ } else {
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
+ }
+ }
+}
+
+#-> CPAN::Distribution::untar_me ;
+sub untar_me {
+ my($self,$ct) = @_;
+ $self->{archived} = "tar";
+ my $result = eval { $ct->untar() };
+ if ($result) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
+ }
+}
+
+# CPAN::Distribution::unzip_me ;
+sub unzip_me {
+ my($self,$ct) = @_;
+ $self->{archived} = "zip";
+ if ($ct->unzip()) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
+ }
+ return;
+}
+
+sub handle_singlefile {
+ my($self,$local_file) = @_;
+
+ if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
+ $self->{archived} = "pm";
+ } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
+ $self->{archived} = "patch";
+ } else {
+ $self->{archived} = "maybe_pl";
+ }
+
+ my $to = File::Basename::basename($local_file);
+ if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
+ if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
+ }
+ } else {
+ if (File::Copy::cp($local_file,".")) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
+ }
+ }
+ return $to;
+}
+
+#-> sub CPAN::Distribution::new ;
+sub new {
+ my($class,%att) = @_;
+
+ # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
+
+ my $this = { %att };
+ return bless $this, $class;
+}
+
+#-> sub CPAN::Distribution::look ;
+sub look {
+ my($self) = @_;
+
+ if ($^O eq 'MacOS') {
+ $self->Mac::BuildTools::look;
+ return;
+ }
+
+ if ( $CPAN::Config->{'shell'} ) {
+ $CPAN::Frontend->myprint(qq{
+Trying to open a subshell in the build directory...
+});
+ } else {
+ $CPAN::Frontend->myprint(qq{
+Your configuration does not define a value for subshells.
+Please define it with "o conf shell <your shell>"
+});
+ return;
+ }
+ my $dist = $self->id;
+ my $dir;
+ unless ($dir = $self->dir) {
+ $self->get;
+ }
+ unless ($dir ||= $self->dir) {
+ $CPAN::Frontend->mywarn(qq{
+Could not determine which directory to use for looking at $dist.
+});
+ return;
+ }
+ my $pwd = CPAN::anycwd();
+ $self->safe_chdir($dir);
+ $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
+ {
+ local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
+ $ENV{CPAN_SHELL_LEVEL} += 1;
+ my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ unless (system($shell) == 0) {
+ my $code = $? >> 8;
+ $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+ }
+ }
+ $self->safe_chdir($pwd);
+}
+
+# CPAN::Distribution::cvs_import ;
+sub cvs_import {
+ my($self) = @_;
+ $self->get;
+ my $dir = $self->dir;
+
+ my $package = $self->called_for;
+ my $module = $CPAN::META->instance('CPAN::Module', $package);
+ my $version = $module->cpan_version;
+
+ my $userid = $self->cpan_userid;
+
+ my $cvs_dir = (split /\//, $dir)[-1];
+ $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
+ my $cvs_root =
+ $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
+ my $cvs_site_perl =
+ $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
+ if ($cvs_site_perl) {
+ $cvs_dir = "$cvs_site_perl/$cvs_dir";
+ }
+ my $cvs_log = qq{"imported $package $version sources"};
+ $version =~ s/\./_/g;
+ # XXX cvs: undocumented and unclear how it was meant to work
+ my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
+ "$cvs_dir", $userid, "v$version");
+
+ my $pwd = CPAN::anycwd();
+ chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
+
+ $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
+
+ $CPAN::Frontend->myprint(qq{@cmd\n});
+ system(@cmd) == 0 or
+ # XXX cvs
+ $CPAN::Frontend->mydie("cvs import failed");
+ chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
+}
+
+#-> sub CPAN::Distribution::readme ;
+sub readme {
+ my($self) = @_;
+ my($dist) = $self->id;
+ my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
+ $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
+ my($local_file);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,"$sans.readme"),
+ );
+ my $readme = "authors/id/$sans.readme";
+ $self->debug("Doing localize for '$readme'") if $CPAN::DEBUG;
+ $local_file = CPAN::FTP->localize($readme,
+ $local_wanted)
+ or $CPAN::Frontend->mydie(qq{No $sans.readme found});
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::launch_file($local_file);
+ return;
+ }
+
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ my $pager = $CPAN::Config->{'pager'} || "cat";
+ $fh_pager->open("|$pager")
+ or die "Could not open pager $pager\: $!";
+ my $fh_readme = FileHandle->new;
+ $fh_readme->open($local_file)
+ or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
+ $CPAN::Frontend->myprint(qq{
+Displaying file
+ $local_file
+with pager "$pager"
+});
+ $fh_pager->print(<$fh_readme>);
+ $fh_pager->close;
+}
+
+#-> sub CPAN::Distribution::verifyCHECKSUM ;
+sub verifyCHECKSUM {
+ my($self) = @_;
+ EXCUSE: {
+ my @e;
+ $self->{CHECKSUM_STATUS} ||= "";
+ $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ my($lc_want,$lc_file,@local,$basename);
+ @local = split(/\//,$self->id);
+ pop @local;
+ push @local, "CHECKSUMS";
+ $lc_want =
+ File::Spec->catfile($CPAN::Config->{keep_source_where},
+ "authors", "id", @local);
+ local($") = "/";
+ if (my $size = -s $lc_want) {
+ $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
+ if ($self->CHECKSUM_check_file($lc_want,1)) {
+ return $self->{CHECKSUM_STATUS} = "OK";
+ }
+ }
+ $lc_file = CPAN::FTP->localize("authors/id/@local",
+ $lc_want,1);
+ unless ($lc_file) {
+ $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
+ $local[-1] .= ".gz";
+ $lc_file = CPAN::FTP->localize("authors/id/@local",
+ "$lc_want.gz",1);
+ if ($lc_file) {
+ $lc_file =~ s/\.gz(?!\n)\Z//;
+ eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
+ } else {
+ return;
+ }
+ }
+ if ($self->CHECKSUM_check_file($lc_file)) {
+ return $self->{CHECKSUM_STATUS} = "OK";
+ }
+}
+
+#-> sub CPAN::Distribution::SIG_check_file ;
+sub SIG_check_file {
+ my($self,$chk_file) = @_;
+ my $rv = eval { Module::Signature::_verify($chk_file) };
+
+ if ($rv == Module::Signature::SIGNATURE_OK()) {
+ $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
+ return $self->{SIG_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid
+ )->as_string);
+
+ my $wrap = qq{I\'d recommend removing $chk_file. Its signature
+is invalid. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry.};
+
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+ }
+}
+
+#-> sub CPAN::Distribution::CHECKSUM_check_file ;
+
+# sloppy is 1 when we have an old checksums file that maybe is good
+# enough
+
+sub CHECKSUM_check_file {
+ my($self,$chk_file,$sloppy) = @_;
+ my($cksum,$file,$basename);
+
+ $sloppy ||= 0;
+ $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
+ my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
+ q{check_sigs});
+ if ($check_sigs) {
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
+ $self->SIG_check_file($chk_file);
+ } else {
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
+ }
+ }
+
+ $file = $self->{localfile};
+ $basename = File::Basename::basename($file);
+ my $fh = FileHandle->new;
+ if (open $fh, $chk_file) {
+ local($/);
+ my $eval = <$fh>;
+ $eval =~ s/\015?\012/\n/g;
+ close $fh;
+ my($compmt) = Safe->new();
+ $cksum = $compmt->reval($eval);
+ if ($@) {
+ rename $chk_file, "$chk_file.bad";
+ Carp::confess($@) if $@;
+ }
+ } else {
+ Carp::carp "Could not open $chk_file for reading";
+ }
+
+ if (! ref $cksum or ref $cksum ne "HASH") {
+ $CPAN::Frontend->mywarn(qq{
+Warning: checksum file '$chk_file' broken.
+
+When trying to read that file I expected to get a hash reference
+for further processing, but got garbage instead.
+});
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
+ $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
+ $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
+ return;
+ } elsif (exists $cksum->{$basename}{sha256}) {
+ $self->debug("Found checksum for $basename:" .
+ "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
+
+ open($fh, $file);
+ binmode $fh;
+ my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
+ $fh->close;
+ $fh = CPAN::Tarzip->TIEHANDLE($file);
+
+ unless ($eq) {
+ my $dg = Digest::SHA->new(256);
+ my($data,$ref);
+ $ref = \$data;
+ while ($fh->READ($ref, 4096) > 0) {
+ $dg->add($data);
+ }
+ my $hexdigest = $dg->hexdigest;
+ $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
+ }
+
+ if ($eq) {
+ $CPAN::Frontend->myprint("Checksum for $file ok\n");
+ return $self->{CHECKSUM_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid
+ )->as_string);
+
+ my $wrap = qq{I\'d recommend removing $file. Its
+checksum is incorrect. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry.};
+
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+
+ # former versions just returned here but this seems a
+ # serious threat that deserves a die
+
+ # $CPAN::Frontend->myprint("\n\n");
+ # sleep 3;
+ # return;
+ }
+ # close $fh if fileno($fh);
+ } else {
+ return if $sloppy;
+ unless ($self->{CHECKSUM_STATUS}) {
+ $CPAN::Frontend->mywarn(qq{
+Warning: No checksum for $basename in $chk_file.
+
+The cause for this may be that the file is very new and the checksum
+has not yet been calculated, but it may also be that something is
+going awry right now.
+});
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
+ $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
+ }
+ $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
+ return;
+ }
+}
+
+#-> sub CPAN::Distribution::eq_CHECKSUM ;
+sub eq_CHECKSUM {
+ my($self,$fh,$expect) = @_;
+ if ($CPAN::META->has_inst("Digest::SHA")) {
+ my $dg = Digest::SHA->new(256);
+ my($data);
+ while (read($fh, $data, 4096)) {
+ $dg->add($data);
+ }
+ my $hexdigest = $dg->hexdigest;
+ # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
+ return $hexdigest eq $expect;
+ }
+ return 1;
+}
+
+#-> sub CPAN::Distribution::force ;
+
+# Both CPAN::Modules and CPAN::Distributions know if "force" is in
+# effect by autoinspection, not by inspecting a global variable. One
+# of the reason why this was chosen to work that way was the treatment
+# of dependencies. They should not automatically inherit the force
+# status. But this has the downside that ^C and die() will return to
+# the prompt but will not be able to reset the force_update
+# attributes. We try to correct for it currently in the read_metadata
+# routine, and immediately before we check for a Signal. I hope this
+# works out in one of v1.57_53ff
+
+# "Force get forgets previous error conditions"
+
+#-> sub CPAN::Distribution::fforce ;
+sub fforce {
+ my($self, $method) = @_;
+ $self->force($method,1);
+}
+
+#-> sub CPAN::Distribution::force ;
+sub force {
+ my($self, $method,$fforce) = @_;
+ my %phase_map = (
+ get => [
+ "unwrapped",
+ "build_dir",
+ "archived",
+ "localfile",
+ "CHECKSUM_STATUS",
+ "signature_verify",
+ "prefs",
+ "prefs_file",
+ "prefs_file_doc",
+ ],
+ make => [
+ "writemakefile",
+ "make",
+ "modulebuild",
+ "prereq_pm",
+ "prereq_pm_detected",
+ ],
+ test => [
+ "badtestcnt",
+ "make_test",
+ ],
+ install => [
+ "install",
+ ],
+ unknown => [
+ "reqtype",
+ "yaml_content",
+ ],
+ );
+ my $methodmatch = 0;
+ my $ldebug = 0;
+ PHASE: for my $phase (qw(unknown get make test install)) { # order matters
+ $methodmatch = 1 if $fforce || $phase eq $method;
+ next unless $methodmatch;
+ ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
+ if ($phase eq "get") {
+ if (substr($self->id,-1,1) eq "."
+ && $att =~ /(unwrapped|build_dir|archived)/ ) {
+ # cannot be undone for local distros
+ next ATTRIBUTE;
+ }
+ if ($att eq "build_dir"
+ && $self->{build_dir}
+ && $CPAN::META->{is_tested}
+ ) {
+ delete $CPAN::META->{is_tested}{$self->{build_dir}};
+ }
+ } elsif ($phase eq "test") {
+ if ($att eq "make_test"
+ && $self->{make_test}
+ && $self->{make_test}{COMMANDID}
+ && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
+ ) {
+ # endless loop too likely
+ next ATTRIBUTE;
+ }
+ }
+ delete $self->{$att};
+ if ($ldebug || $CPAN::DEBUG) {
+ # local $CPAN::DEBUG = 16; # Distribution
+ CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
+ }
+ }
+ }
+ if ($method && $method =~ /make|test|install/) {
+ $self->{force_update} = 1; # name should probably have been force_install
+ }
+}
+
+#-> sub CPAN::Distribution::notest ;
+sub notest {
+ my($self, $method) = @_;
+ # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
+ $self->{"notest"}++; # name should probably have been force_install
+}
+
+#-> sub CPAN::Distribution::unnotest ;
+sub unnotest {
+ my($self) = @_;
+ # warn "XDEBUG: deleting notest";
+ delete $self->{notest};
+}
+
+#-> sub CPAN::Distribution::unforce ;
+sub unforce {
+ my($self) = @_;
+ delete $self->{force_update};
+}
+
+#-> sub CPAN::Distribution::isa_perl ;
+sub isa_perl {
+ my($self) = @_;
+ my $file = File::Basename::basename($self->id);
+ if ($file =~ m{ ^ perl
+ -?
+ (5)
+ ([._-])
+ (
+ \d{3}(_[0-4][0-9])?
+ |
+ \d+\.\d+
+ )
+ \.tar[._-](?:gz|bz2)
+ (?!\n)\Z
+ }xs) {
+ return "$1.$3";
+ } elsif ($self->cpan_comment
+ &&
+ $self->cpan_comment =~ /isa_perl\(.+?\)/) {
+ return $1;
+ }
+}
+
+
+#-> sub CPAN::Distribution::perl ;
+sub perl {
+ my ($self) = @_;
+ if (! $self) {
+ use Carp qw(carp);
+ carp __PACKAGE__ . "::perl was called without parameters.";
+ }
+ return CPAN::HandleConfig->safe_quote($CPAN::Perl);
+}
+
+
+#-> sub CPAN::Distribution::make ;
+sub make {
+ my($self) = @_;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ # Emergency brake if they said install Pippi and get newest perl
+ if ($self->isa_perl) {
+ if (
+ $self->called_for ne $self->id &&
+ ! $self->{force_update}
+ ) {
+ # if we die here, we break bundles
+ $CPAN::Frontend
+ ->mywarn(sprintf(
+ qq{The most recent version "%s" of the module "%s"
+is part of the perl-%s distribution. To install that, you need to run
+ force install %s --or--
+ install %s
+},
+ $CPAN::META->instance(
+ 'CPAN::Module',
+ $self->called_for
+ )->cpan_version,
+ $self->called_for,
+ $self->isa_perl,
+ $self->called_for,
+ $self->id,
+ ));
+ $self->{make} = CPAN::Distrostatus->new("NO isa perl");
+ $CPAN::Frontend->mysleep(1);
+ return;
+ }
+ }
+ $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
+ $self->get;
+ return if $self->prefs->{disabled} && ! $self->{force_update};
+ if ($self->{configure_requires_later}) {
+ return;
+ }
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+
+ my $builddir;
+ EXCUSE: {
+ my @e;
+ if (!$self->{archived} || $self->{archived} eq "NO") {
+ push @e, "Is neither a tar nor a zip archive.";
+ }
+
+ if (!$self->{unwrapped}
+ || (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )) {
+ push @e, "Had problems unarchiving. Please build manually";
+ }
+
+ unless ($self->{force_update}) {
+ exists $self->{signature_verify} and
+ (
+ UNIVERSAL::can($self->{signature_verify},"failed") ?
+ $self->{signature_verify}->failed :
+ $self->{signature_verify} =~ /^NO/
+ )
+ and push @e, "Did not pass the signature test.";
+ }
+
+ if (exists $self->{writemakefile} &&
+ (
+ UNIVERSAL::can($self->{writemakefile},"failed") ?
+ $self->{writemakefile}->failed :
+ $self->{writemakefile} =~ /^NO/
+ )) {
+ # XXX maybe a retry would be in order?
+ my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
+ $self->{writemakefile}->text :
+ $self->{writemakefile};
+ $err =~ s/^NO\s*(--\s+)?//;
+ $err ||= "Had some problem writing Makefile";
+ $err .= ", won't make";
+ push @e, $err;
+ }
+
+ if (defined $self->{make}) {
+ if (UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/) {
+ if ($self->{force_update}) {
+ # Trying an already failed 'make' (unless somebody else blocks)
+ } else {
+ # introduced for turning recursion detection into a distrostatus
+ my $error = length $self->{make}>3
+ ? substr($self->{make},3) : "Unknown error";
+ $CPAN::Frontend->mywarn("Could not make: $error\n");
+ $self->store_persistent_state;
+ return;
+ }
+ } else {
+ push @e, "Has already been made";
+ my $wait_for_prereqs = eval { $self->satisfy_requires };
+ return 1 if $wait_for_prereqs; # tells queuerunner to continue
+ return $self->goodbye($@) if $@; # tells queuerunner to stop
+ }
+ }
+
+ my $later = $self->{later} || $self->{configure_requires_later};
+ if ($later) { # see also undelay
+ if ($later) {
+ push @e, $later;
+ }
+ }
+
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+ unless (chdir $builddir) {
+ push @e, "Couldn't chdir to '$builddir': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
+ }
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+ $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
+ $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make($self);
+ return;
+ }
+
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next unless defined $v;
+ $env{$k} = $v;
+ }
+ local %ENV = %env;
+ my $system;
+ my $pl_commandline;
+ if ($self->prefs->{pl}) {
+ $pl_commandline = $self->prefs->{pl}{commandline};
+ }
+ if ($pl_commandline) {
+ $system = $pl_commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{'configure'}) {
+ $system = $self->{'configure'};
+ } elsif ($self->{modulebuild}) {
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
+ $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
+ } else {
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
+ my $switch = "";
+# This needs a handler that can be turned on or off:
+# $switch = "-MExtUtils::MakeMaker ".
+# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
+# if $] > 5.00310;
+ my $makepl_arg = $self->_make_phase_arg("pl");
+ $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
+ "Makefile.PL");
+ $system = sprintf("%s%s Makefile.PL%s",
+ $perl,
+ $switch ? " $switch" : "",
+ $makepl_arg ? " $makepl_arg" : "",
+ );
+ }
+ my $pl_env;
+ if ($self->prefs->{pl}) {
+ $pl_env = $self->prefs->{pl}{env};
+ }
+ if ($pl_env) {
+ for my $e (keys %$pl_env) {
+ $ENV{$e} = $pl_env->{$e};
+ }
+ }
+ if (exists $self->{writemakefile}) {
+ } else {
+ local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
+ my($ret,$pid,$output);
+ $@ = "";
+ my $go_via_alarm;
+ if ($CPAN::Config->{inactivity_timeout}) {
+ require Config;
+ if ($Config::Config{d_alarm}
+ &&
+ $Config::Config{d_alarm} eq "define"
+ ) {
+ $go_via_alarm++
+ } else {
+ $CPAN::Frontend->mywarn("Warning: you have configured the config ".
+ "variable 'inactivity_timeout' to ".
+ "'$CPAN::Config->{inactivity_timeout}'. But ".
+ "on this machine the system call 'alarm' ".
+ "isn't available. This means that we cannot ".
+ "provide the feature of intercepting long ".
+ "waiting code and will turn this feature off.\n"
+ );
+ $CPAN::Config->{inactivity_timeout} = 0;
+ }
+ }
+ if ($go_via_alarm) {
+ if ( $self->_should_report('pl') ) {
+ ($output, $ret) = CPAN::Reporter::record_command(
+ $system,
+ $CPAN::Config->{inactivity_timeout},
+ );
+ CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
+ }
+ else {
+ eval {
+ alarm $CPAN::Config->{inactivity_timeout};
+ local $SIG{CHLD}; # = sub { wait };
+ if (defined($pid = fork)) {
+ if ($pid) { #parent
+ # wait;
+ waitpid $pid, 0;
+ } else { #child
+ # note, this exec isn't necessary if
+ # inactivity_timeout is 0. On the Mac I'd
+ # suggest, we set it always to 0.
+ exec $system;
+ }
+ } else {
+ $CPAN::Frontend->myprint("Cannot fork: $!");
+ return;
+ }
+ };
+ alarm 0;
+ if ($@) {
+ kill 9, $pid;
+ waitpid $pid, 0;
+ my $err = "$@";
+ $CPAN::Frontend->myprint($err);
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
+ $@ = "";
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- TIMED OUT");
+ }
+ }
+ } else {
+ if (my $expect_model = $self->_prefs_with_expect("pl")) {
+ # XXX probably want to check _should_report here and warn
+ # about not being able to use CPAN::Reporter with expect
+ $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
+ if (! defined $ret
+ && $self->{writemakefile}
+ && $self->{writemakefile}->failed) {
+ # timeout
+ return;
+ }
+ }
+ elsif ( $self->_should_report('pl') ) {
+ ($output, $ret) = CPAN::Reporter::record_command($system);
+ CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
+ }
+ else {
+ $ret = system($system);
+ }
+ if ($ret != 0) {
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new("NO '$system' returned status $ret");
+ $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- NOT OK");
+ }
+ }
+ if (-f "Makefile" || -f "Build") {
+ $self->{writemakefile} = CPAN::Distrostatus->new("YES");
+ delete $self->{make_clean}; # if cleaned before, enable next
+ } else {
+ my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
+ my $why = "No '$makefile' created";
+ $CPAN::Frontend->mywarn($why);
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new(qq{NO -- $why\n});
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- NOT OK");
+ }
+ }
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+ my $wait_for_prereqs = eval { $self->satisfy_requires };
+ return 1 if $wait_for_prereqs; # tells queuerunner to continue
+ return $self->goodbye($@) if $@; # tells queuerunner to stop
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+ my $make_commandline;
+ if ($self->prefs->{make}) {
+ $make_commandline = $self->prefs->{make}{commandline};
+ }
+ if ($make_commandline) {
+ $system = $make_commandline;
+ $ENV{PERL} = CPAN::find_perl();
+ } else {
+ if ($self->{modulebuild}) {
+ unless (-f "Build") {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
+ " in cwd[$cwd]. Danger, Will Robinson!\n");
+ $CPAN::Frontend->mysleep(5);
+ }
+ $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
+ } else {
+ $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
+ }
+ $system =~ s/\s+$//;
+ my $make_arg = $self->_make_phase_arg("make");
+ $system = sprintf("%s%s",
+ $system,
+ $make_arg ? " $make_arg" : "",
+ );
+ }
+ my $make_env;
+ if ($self->prefs->{make}) {
+ $make_env = $self->prefs->{make}{env};
+ }
+ if ($make_env) { # overriding the local ENV of PL, not the outer
+ # ENV, but unlikely to be a risk
+ for my $e (keys %$make_env) {
+ $ENV{$e} = $make_env->{$e};
+ }
+ }
+ my $expect_model = $self->_prefs_with_expect("make");
+ my $want_expect = 0;
+ if ( $expect_model && @{$expect_model->{talk}} ) {
+ my $can_expect = $CPAN::META->has_inst("Expect");
+ if ($can_expect) {
+ $want_expect = 1;
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
+ "system()\n");
+ }
+ }
+ my $system_ok;
+ if ($want_expect) {
+ # XXX probably want to check _should_report here and
+ # warn about not being able to use CPAN::Reporter with expect
+ $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
+ }
+ elsif ( $self->_should_report('make') ) {
+ my ($output, $ret) = CPAN::Reporter::record_command($system);
+ CPAN::Reporter::grade_make( $self, $system, $output, $ret );
+ $system_ok = ! $ret;
+ }
+ else {
+ $system_ok = system($system) == 0;
+ }
+ $self->introduce_myself;
+ if ( $system_ok ) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{make} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
+ $self->{make} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ }
+ $self->store_persistent_state;
+}
+
+# CPAN::Distribution::goodbye ;
+sub goodbye {
+ my($self,$goodbye) = @_;
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn(" $id\n $goodbye\n");
+ return;
+}
+
+# CPAN::Distribution::_run_via_expect ;
+sub _run_via_expect {
+ my($self,$system,$phase,$expect_model) = @_;
+ CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
+ if ($CPAN::META->has_inst("Expect")) {
+ my $expo = Expect->new; # expo Expect object;
+ $expo->spawn($system);
+ $expect_model->{mode} ||= "deterministic";
+ if ($expect_model->{mode} eq "deterministic") {
+ return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
+ } elsif ($expect_model->{mode} eq "anyorder") {
+ return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
+ } else {
+ die "Panic: Illegal expect mode: $expect_model->{mode}";
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
+ return system($system);
+ }
+}
+
+sub _run_via_expect_anyorder {
+ my($self,$expo,$phase,$expect_model) = @_;
+ my $timeout = $expect_model->{timeout} || 5;
+ my $reuse = $expect_model->{reuse};
+ my @expectacopy = @{$expect_model->{talk}}; # we trash it!
+ my $but = "";
+ my $timeout_start = time;
+ EXPECT: while () {
+ my($eof,$ran_into_timeout);
+ # XXX not up to the full power of expect. one could certainly
+ # wrap all of the talk pairs into a single expect call and on
+ # success tweak it and step ahead to the next question. The
+ # current implementation unnecessarily limits itself to a
+ # single match.
+ my @match = $expo->expect(1,
+ [ eof => sub {
+ $eof++;
+ } ],
+ [ timeout => sub {
+ $ran_into_timeout++;
+ } ],
+ -re => eval"qr{.}",
+ );
+ if ($match[2]) {
+ $but .= $match[2];
+ }
+ $but .= $expo->clear_accum;
+ if ($eof) {
+ $expo->soft_close;
+ return $expo->exitstatus();
+ } elsif ($ran_into_timeout) {
+ # warn "DEBUG: they are asking a question, but[$but]";
+ for (my $i = 0; $i <= $#expectacopy; $i+=2) {
+ my($next,$send) = @expectacopy[$i,$i+1];
+ my $regex = eval "qr{$next}";
+ # warn "DEBUG: will compare with regex[$regex].";
+ if ($but =~ /$regex/) {
+ # warn "DEBUG: will send send[$send]";
+ $expo->send($send);
+ # never allow reusing an QA pair unless they told us
+ splice @expectacopy, $i, 2 unless $reuse;
+ $but =~ s/(?s:^.*?)$regex//;
+ $timeout_start = time;
+ next EXPECT;
+ }
+ }
+ my $have_waited = time - $timeout_start;
+ if ($have_waited < $timeout) {
+ # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
+ next EXPECT;
+ }
+ my $why = "could not answer a question during the dialog";
+ $CPAN::Frontend->mywarn("Failing: $why\n");
+ $self->{$phase} =
+ CPAN::Distrostatus->new("NO $why");
+ return 0;
+ }
+ }
+}
+
+sub _run_via_expect_deterministic {
+ my($self,$expo,$phase,$expect_model) = @_;
+ my $ran_into_timeout;
+ my $ran_into_eof;
+ my $timeout = $expect_model->{timeout} || 15; # currently unsettable
+ my $expecta = $expect_model->{talk};
+ EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
+ my($re,$send) = @$expecta[$i,$i+1];
+ CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
+ my $regex = eval "qr{$re}";
+ $expo->expect($timeout,
+ [ eof => sub {
+ my $but = $expo->clear_accum;
+ $CPAN::Frontend->mywarn("EOF (maybe harmless)
+expected[$regex]\nbut[$but]\n\n");
+ $ran_into_eof++;
+ } ],
+ [ timeout => sub {
+ my $but = $expo->clear_accum;
+ $CPAN::Frontend->mywarn("TIMEOUT
+expected[$regex]\nbut[$but]\n\n");
+ $ran_into_timeout++;
+ } ],
+ -re => $regex);
+ if ($ran_into_timeout) {
+ # note that the caller expects 0 for success
+ $self->{$phase} =
+ CPAN::Distrostatus->new("NO timeout during expect dialog");
+ return 0;
+ } elsif ($ran_into_eof) {
+ last EXPECT;
+ }
+ $expo->send($send);
+ }
+ $expo->soft_close;
+ return $expo->exitstatus();
+}
+
+#-> CPAN::Distribution::_validate_distropref
+sub _validate_distropref {
+ my($self,@args) = @_;
+ if (
+ $CPAN::META->has_inst("CPAN::Kwalify")
+ &&
+ $CPAN::META->has_inst("Kwalify")
+ ) {
+ eval {CPAN::Kwalify::_validate("distroprefs",@args);};
+ if ($@) {
+ $CPAN::Frontend->mywarn($@);
+ }
+ } else {
+ CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
+ }
+}
+
+#-> CPAN::Distribution::_find_prefs
+sub _find_prefs {
+ my($self) = @_;
+ my $distroid = $self->pretty_id;
+ #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
+ my $prefs_dir = $CPAN::Config->{prefs_dir};
+ return if $prefs_dir =~ /^\s*$/;
+ eval { File::Path::mkpath($prefs_dir); };
+ if ($@) {
+ $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
+ }
+ my $yaml_module = CPAN::_yaml_module();
+ my $ext_map = {};
+ my @extensions;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ $ext_map->{yml} = 'CPAN';
+ } else {
+ my @fallbacks;
+ if ($CPAN::META->has_inst("Data::Dumper")) {
+ push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
+ }
+ if ($CPAN::META->has_inst("Storable")) {
+ push @fallbacks, $ext_map->{st} = 'Storable';
+ }
+ if (@fallbacks) {
+ local $" = " and ";
+ unless ($self->{have_complained_about_missing_yaml}++) {
+ $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
+ "to @fallbacks to read prefs '$prefs_dir'\n");
+ }
+ } else {
+ unless ($self->{have_complained_about_missing_yaml}++) {
+ $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
+ "read prefs '$prefs_dir'\n");
+ }
+ }
+ }
+ my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
+ DIRENT: while (my $result = $finder->next) {
+ if ($result->is_warning) {
+ $CPAN::Frontend->mywarn($result->as_string);
+ $CPAN::Frontend->mysleep(1);
+ next DIRENT;
+ } elsif ($result->is_fatal) {
+ $CPAN::Frontend->mydie($result->as_string);
+ }
+
+ my @prefs = @{ $result->prefs };
+
+ ELEMENT: for my $y (0..$#prefs) {
+ my $pref = $prefs[$y];
+ $self->_validate_distropref($pref->data, $result->abs, $y);
+
+ # I don't know why we silently skip when there's no match, but
+ # complain if there's an empty match hashref, and there's no
+ # comment explaining why -- hdp, 2008-03-18
+ unless ($pref->has_any_match) {
+ next ELEMENT;
+ }
+
+ unless ($pref->has_valid_subkeys) {
+ $CPAN::Frontend->mydie(sprintf
+ "Nonconforming .%s file '%s': " .
+ "missing match/* subattribute. " .
+ "Please remove, cannot continue.",
+ $result->ext, $result->abs,
+ );
+ }
+
+ my $arg = {
+ env => \%ENV,
+ distribution => $distroid,
+ perl => \&CPAN::find_perl,
+ perlconfig => \%Config::Config,
+ module => sub { [ $self->containsmods ] },
+ };
+
+ if ($pref->matches($arg)) {
+ return {
+ prefs => $pref->data,
+ prefs_file => $result->abs,
+ prefs_file_doc => $y,
+ };
+ }
+
+ }
+ }
+ return;
+}
+
+# CPAN::Distribution::prefs
+sub prefs {
+ my($self) = @_;
+ if (exists $self->{negative_prefs_cache}
+ &&
+ $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
+ ) {
+ delete $self->{negative_prefs_cache};
+ delete $self->{prefs};
+ }
+ if (exists $self->{prefs}) {
+ return $self->{prefs}; # XXX comment out during debugging
+ }
+ if ($CPAN::Config->{prefs_dir}) {
+ CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
+ my $prefs = $self->_find_prefs();
+ $prefs ||= ""; # avoid warning next line
+ CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
+ if ($prefs) {
+ for my $x (qw(prefs prefs_file prefs_file_doc)) {
+ $self->{$x} = $prefs->{$x};
+ }
+ my $bs = sprintf(
+ "%s[%s]",
+ File::Basename::basename($self->{prefs_file}),
+ $self->{prefs_file_doc},
+ );
+ my $filler1 = "_" x 22;
+ my $filler2 = int(66 - length($bs))/2;
+ $filler2 = 0 if $filler2 < 0;
+ $filler2 = " " x $filler2;
+ $CPAN::Frontend->myprint("
+$filler1 D i s t r o P r e f s $filler1
+$filler2 $bs $filler2
+");
+ $CPAN::Frontend->mysleep(1);
+ return $self->{prefs};
+ }
+ }
+ $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
+ return $self->{prefs} = +{};
+}
+
+# CPAN::Distribution::_make_phase_arg
+sub _make_phase_arg {
+ my($self, $phase) = @_;
+ my $_make_phase_arg;
+ my $prefs = $self->prefs;
+ if (
+ $prefs
+ && exists $prefs->{$phase}
+ && exists $prefs->{$phase}{args}
+ && $prefs->{$phase}{args}
+ ) {
+ $_make_phase_arg = join(" ",
+ map {CPAN::HandleConfig
+ ->safe_quote($_)} @{$prefs->{$phase}{args}},
+ );
+ }
+
+# cpan[2]> o conf make[TAB]
+# make make_install_make_command
+# make_arg makepl_arg
+# make_install_arg
+# cpan[2]> o conf mbuild[TAB]
+# mbuild_arg mbuild_install_build_command
+# mbuild_install_arg mbuildpl_arg
+
+ my $mantra; # must switch make/mbuild here
+ if ($self->{modulebuild}) {
+ $mantra = "mbuild";
+ } else {
+ $mantra = "make";
+ }
+ my %map = (
+ pl => "pl_arg",
+ make => "_arg",
+ test => "_test_arg", # does not really exist but maybe
+ # will some day and now protects
+ # us from unini warnings
+ install => "_install_arg",
+ );
+ my $phase_underscore_meshup = $map{$phase};
+ my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
+
+ $_make_phase_arg ||= $CPAN::Config->{$what};
+ return $_make_phase_arg;
+}
+
+# CPAN::Distribution::_make_command
+sub _make_command {
+ my ($self) = @_;
+ if ($self) {
+ return
+ CPAN::HandleConfig
+ ->safe_quote(
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make})
+ || $Config::Config{make}
+ || 'make'
+ );
+ } else {
+ # Old style call, without object. Deprecated
+ Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
+ return
+ safe_quote(undef,
+ CPAN::HandleConfig->prefs_lookup($self,q{make})
+ || $CPAN::Config->{make}
+ || $Config::Config{make}
+ || 'make');
+ }
+}
+
+#-> sub CPAN::Distribution::follow_prereqs ;
+sub follow_prereqs {
+ my($self) = shift;
+ my($slot) = shift;
+ my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
+ return unless @prereq_tuples;
+ my(@good_prereq_tuples);
+ for my $p (@prereq_tuples) {
+ # XXX watch out for foul ones
+ push @good_prereq_tuples, $p;
+ }
+ my $pretty_id = $self->pretty_id;
+ my %map = (
+ b => "build_requires",
+ r => "requires",
+ c => "commandline",
+ );
+ my($filler1,$filler2,$filler3,$filler4);
+ my $unsat = "Unsatisfied dependencies detected during";
+ my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
+ {
+ my $r = int(($w - length($unsat))/2);
+ my $l = $w - length($unsat) - $r;
+ $filler1 = "-"x4 . " "x$l;
+ $filler2 = " "x$r . "-"x4 . "\n";
+ }
+ {
+ my $r = int(($w - length($pretty_id))/2);
+ my $l = $w - length($pretty_id) - $r;
+ $filler3 = "-"x4 . " "x$l;
+ $filler4 = " "x$r . "-"x4 . "\n";
+ }
+ $CPAN::Frontend->
+ myprint("$filler1 $unsat $filler2".
+ "$filler3 $pretty_id $filler4".
+ join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
+ );
+ my $follow = 0;
+ if ($CPAN::Config->{prerequisites_policy} eq "follow") {
+ $follow = 1;
+ } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
+ my $answer = CPAN::Shell::colorable_makemaker_prompt(
+"Shall I follow them and prepend them to the queue
+of modules we are processing right now?", "yes");
+ $follow = $answer =~ /^\s*y/i;
+ } else {
+ my @prereq = map { $_=>[0] } @good_prereq_tuples;
+ local($") = ", ";
+ $CPAN::Frontend->
+ myprint(" Ignoring dependencies on modules @prereq\n");
+ }
+ if ($follow) {
+ my $id = $self->id;
+ # color them as dirty
+ for my $gp (@good_prereq_tuples) {
+ # warn "calling color_cmd_tmps(0,1)";
+ my $p = $gp->[0];
+ my $any = CPAN::Shell->expandany($p);
+ $self->{$slot . "_for"}{$any->id}++;
+ if ($any) {
+ $any->color_cmd_tmps(0,2);
+ } else {
+ $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
+ $CPAN::Frontend->mysleep(2);
+ }
+ }
+ # queue them and re-queue yourself
+ CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
+ map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
+ $self->{$slot} = "Delayed until after prerequisites";
+ return 1; # signal success to the queuerunner
+ }
+ return;
+}
+
+sub _feature_depends {
+ my($self) = @_;
+ my $meta_yml = $self->parse_meta_yml();
+ my $optf = $meta_yml->{optional_features} or return;
+ if (!ref $optf or ref $optf ne "HASH"){
+ $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
+ $optf = {};
+ }
+ my $wantf = $self->prefs->{features} or return;
+ if (!ref $wantf or ref $wantf ne "ARRAY"){
+ $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
+ $wantf = [];
+ }
+ my $dep = +{};
+ for my $wf (@$wantf) {
+ if (my $f = $optf->{$wf}) {
+ $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
+ "is accompanied by this description:\n".
+ $f->{description}.
+ "\n\n"
+ );
+ # configure_requires currently not in the spec, unlikely to be useful anyway
+ for my $reqtype (qw(configure_requires build_requires requires)) {
+ my $reqhash = $f->{$reqtype} or next;
+ while (my($k,$v) = each %$reqhash) {
+ $dep->{$reqtype}{$k} = $v;
+ }
+ }
+ } else {
+ $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
+ "found in the META.yml file".
+ "\n\n"
+ );
+ }
+ }
+ $dep;
+}
+
+#-> sub CPAN::Distribution::unsat_prereq ;
+# return ([Foo,"r"],[Bar,"b"]) for normal modules
+# return ([perl=>5.008]) if we need a newer perl than we are running under
+# (sorry for the inconsistency, it was an accident)
+sub unsat_prereq {
+ my($self,$slot) = @_;
+ my(%merged,$prereq_pm);
+ my $prefs_depends = $self->prefs->{depends}||{};
+ my $feature_depends = $self->_feature_depends();
+ if ($slot eq "configure_requires_later") {
+ my $meta_yml = $self->parse_meta_yml();
+ if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
+ $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
+ $meta_yml = +{};
+ }
+ %merged = (
+ %{$meta_yml->{configure_requires}||{}},
+ %{$prefs_depends->{configure_requires}||{}},
+ %{$feature_depends->{configure_requires}||{}},
+ );
+ $prereq_pm = {}; # configure_requires defined as "b"
+ } elsif ($slot eq "later") {
+ my $prereq_pm_0 = $self->prereq_pm || {};
+ for my $reqtype (qw(requires build_requires)) {
+ $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
+ for my $dep ($prefs_depends,$feature_depends) {
+ for my $k (keys %{$dep->{$reqtype}||{}}) {
+ $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
+ }
+ }
+ }
+ %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
+ } else {
+ die "Panic: illegal slot '$slot'";
+ }
+ my(@need);
+ my @merged = %merged;
+ CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
+ NEED: while (my($need_module, $need_version) = each %merged) {
+ my($available_version,$inst_file,$available_file,$nmo);
+ if ($need_module eq "perl") {
+ $available_version = $];
+ $available_file = CPAN::find_perl();
+ } else {
+ if (CPAN::_sqlite_running()) {
+ CPAN::Index->reload;
+ $CPAN::SQLite->search("CPAN::Module",$need_module);
+ }
+ $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
+ next if $nmo->uptodate;
+ $inst_file = $nmo->inst_file || '';
+ $available_file = $nmo->available_file || '';
+
+ # if they have not specified a version, we accept any installed one
+ if ( $available_file
+ and ( # a few quick shortcurcuits
+ not defined $need_version
+ or $need_version eq '0' # "==" would trigger warning when not numeric
+ or $need_version eq "undef"
+ )) {
+ next NEED;
+ }
+
+ $available_version = $nmo->available_version;
+ }
+
+ # We only want to install prereqs if either they're not installed
+ # or if the installed version is too old. We cannot omit this
+ # check, because if 'force' is in effect, nobody else will check.
+ # But we don't want to accept a deprecated module installed as part
+ # of the Perl core, so we continue if the available file is the installed
+ # one and is deprecated
+
+ if ( $available_file ) {
+ if ( $inst_file && $available_file eq $inst_file && $nmo->inst_deprecated ) {
+ # continue installing as a prereq
+ }
+ else {
+ next NEED if $self->_fulfills_all_version_rqs(
+ $need_module,$available_file,$available_version,$need_version
+ );
+ }
+ }
+
+ if ($need_module eq "perl") {
+ return ["perl", $need_version];
+ }
+ $self->{sponsored_mods}{$need_module} ||= 0;
+ CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
+ if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
+ # We have already sponsored it and for some reason it's still
+ # not available. So we do ... what??
+
+ # if we push it again, we have a potential infinite loop
+
+ # The following "next" was a very problematic construct.
+ # It helped a lot but broke some day and had to be
+ # replaced.
+
+ # We must be able to deal with modules that come again and
+ # again as a prereq and have themselves prereqs and the
+ # queue becomes long but finally we would find the correct
+ # order. The RecursiveDependency check should trigger a
+ # die when it's becoming too weird. Unfortunately removing
+ # this next breaks many other things.
+
+ # The bug that brought this up is described in Todo under
+ # "5.8.9 cannot install Compress::Zlib"
+
+ # next; # this is the next that had to go away
+
+ # The following "next NEED" are fine and the error message
+ # explains well what is going on. For example when the DBI
+ # fails and consequently DBD::SQLite fails and now we are
+ # processing CPAN::SQLite. Then we must have a "next" for
+ # DBD::SQLite. How can we get it and how can we identify
+ # all other cases we must identify?
+
+ my $do = $nmo->distribution;
+ next NEED unless $do; # not on CPAN
+ if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$self->{ID}' seems ".
+ "not available according to the indices\n"
+ );
+ next NEED;
+ }
+ NOSAYER: for my $nosayer (
+ "unwrapped",
+ "writemakefile",
+ "signature_verify",
+ "make",
+ "make_test",
+ "install",
+ "make_clean",
+ ) {
+ if ($do->{$nosayer}) {
+ my $selfid = $self->pretty_id;
+ my $did = $do->pretty_id;
+ if (UNIVERSAL::can($do->{$nosayer},"failed") ?
+ $do->{$nosayer}->failed :
+ $do->{$nosayer} =~ /^NO/) {
+ if ($nosayer eq "make_test"
+ &&
+ $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
+ ) {
+ next NOSAYER;
+ }
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$selfid' failed when ".
+ "processing '$did' with ".
+ "'$nosayer => $do->{$nosayer}'. Continuing, ".
+ "but chances to succeed are limited.\n"
+ );
+ $CPAN::Frontend->mysleep($sponsoring/10);
+ next NEED;
+ } else { # the other guy succeeded
+ if ($nosayer =~ /^(install|make_test)$/) {
+ # we had this with
+ # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
+ # in 2007-03 for 'make install'
+ # and 2008-04: #30464 (for 'make test')
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$selfid' already built ".
+ "but the result looks suspicious. ".
+ "Skipping another build attempt, ".
+ "to prevent looping endlessly.\n"
+ );
+ next NEED;
+ }
+ }
+ }
+ }
+ }
+ my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
+ push @need, [$need_module,$needed_as];
+ }
+ my @unfolded = map { "[".join(",",@$_)."]" } @need;
+ CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
+ @need;
+}
+
+sub _fulfills_all_version_rqs {
+ my($self,$need_module,$available_file,$available_version,$need_version) = @_;
+ my(@all_requirements) = split /\s*,\s*/, $need_version;
+ local($^W) = 0;
+ my $ok = 0;
+ RQ: for my $rq (@all_requirements) {
+ if ($rq =~ s|>=\s*||) {
+ } elsif ($rq =~ s|>\s*||) {
+ # 2005-12: one user
+ if (CPAN::Version->vgt($available_version,$rq)) {
+ $ok++;
+ }
+ next RQ;
+ } elsif ($rq =~ s|!=\s*||) {
+ # 2005-12: no user
+ if (CPAN::Version->vcmp($available_version,$rq)) {
+ $ok++;
+ next RQ;
+ } else {
+ $ok=0;
+ last RQ;
+ }
+ } elsif ($rq =~ m|<=?\s*|) {
+ # 2005-12: no user
+ $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
+ $ok++;
+ next RQ;
+ } elsif ($rq =~ s|==\s*||) {
+ # 2009-07: ELLIOTJS/Perl-Critic-1.099_002.tar.gz
+ if (CPAN::Version->vcmp($available_version,$rq)) {
+ $ok=0;
+ last RQ;
+ } else {
+ $ok++;
+ next RQ;
+ }
+ }
+ if (! CPAN::Version->vgt($rq, $available_version)) {
+ $ok++;
+ }
+ CPAN->debug(sprintf("need_module[%s]available_file[%s]".
+ "available_version[%s]rq[%s]ok[%d]",
+ $need_module,
+ $available_file,
+ $available_version,
+ CPAN::Version->readable($rq),
+ $ok,
+ )) if $CPAN::DEBUG;
+ }
+ my $ret = $ok == @all_requirements;
+ CPAN->debug(sprintf("need_module[%s]ok[%s]all_requirements[%d]",$need_module, $ok, scalar @all_requirements)) if $CPAN::DEBUG;
+ return $ret;
+}
+
+#-> sub CPAN::Distribution::read_yaml ;
+sub read_yaml {
+ my($self) = @_;
+ return $self->{yaml_content} if exists $self->{yaml_content};
+ my $build_dir;
+ unless ($build_dir = $self->{build_dir}) {
+ # maybe permission on build_dir was missing
+ $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
+ return;
+ }
+ # if MYMETA.yml exists, that takes precedence over META.yml
+ my $meta = File::Spec->catfile($build_dir,"META.yml");
+ my $mymeta = File::Spec->catfile($build_dir,"MYMETA.yml");
+ my $yaml = -f $mymeta ? $mymeta : $meta;
+ $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
+ return unless -f $yaml;
+ eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Could not read ".
+ "'$yaml'. Falling back to other ".
+ "methods to determine prerequisites\n");
+ return $self->{yaml_content} = undef; # if we die, then we
+ # cannot read YAML's own
+ # META.yml
+ }
+ # not "authoritative"
+ for ($self->{yaml_content}) {
+ if (defined $_ && (! ref $_ || ref $_ ne "HASH")) {
+ $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
+ $self->{yaml_content} = +{};
+ }
+ }
+ # MYMETA.yml is not dynamic by definition
+ if ( $yaml ne $mymeta &&
+ ( not exists $self->{yaml_content}{dynamic_config}
+ or $self->{yaml_content}{dynamic_config}
+ )
+ ) {
+ $self->{yaml_content} = undef;
+ }
+ $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
+ if $CPAN::DEBUG;
+ return $self->{yaml_content};
+}
+
+#-> sub CPAN::Distribution::prereq_pm ;
+sub prereq_pm {
+ my($self) = @_;
+ $self->{prereq_pm_detected} ||= 0;
+ CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
+ return $self->{prereq_pm} if $self->{prereq_pm_detected};
+ return unless $self->{writemakefile} # no need to have succeeded
+ # but we must have run it
+ || $self->{modulebuild};
+ unless ($self->{build_dir}) {
+ return;
+ }
+ CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
+ $self->{writemakefile}||"",
+ $self->{modulebuild}||"",
+ ) if $CPAN::DEBUG;
+ my($req,$breq);
+ if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
+ $req = $yaml->{requires} || {};
+ $breq = $yaml->{build_requires} || {};
+ undef $req unless ref $req eq "HASH" && %$req;
+ if ($req) {
+ if ($yaml->{generated_by} &&
+ $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
+ my $eummv = do { local $^W = 0; $1+0; };
+ if ($eummv < 6.2501) {
+ # thanks to Slaven for digging that out: MM before
+ # that could be wrong because it could reflect a
+ # previous release
+ undef $req;
+ }
+ }
+ my $areq;
+ my $do_replace;
+ while (my($k,$v) = each %{$req||{}}) {
+ if ($v =~ /\d/) {
+ $areq->{$k} = $v;
+ } elsif ($k =~ /[A-Za-z]/ &&
+ $v =~ /[A-Za-z]/ &&
+ $CPAN::META->exists("CPAN::Module",$v)
+ ) {
+ $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
+ "requires hash: $k => $v; I'll take both ".
+ "key and value as a module name\n");
+ $CPAN::Frontend->mysleep(1);
+ $areq->{$k} = 0;
+ $areq->{$v} = 0;
+ $do_replace++;
+ }
+ }
+ $req = $areq if $do_replace;
+ }
+ }
+ unless ($req || $breq) {
+ my $build_dir;
+ unless ( $build_dir = $self->{build_dir} ) {
+ return;
+ }
+ my $makefile = File::Spec->catfile($build_dir,"Makefile");
+ my $fh;
+ if (-f $makefile
+ and
+ $fh = FileHandle->new("<$makefile\0")) {
+ CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
+ local($/) = "\n";
+ while (<$fh>) {
+ last if /MakeMaker post_initialize section/;
+ my($p) = m{^[\#]
+ \s+PREREQ_PM\s+=>\s+(.+)
+ }x;
+ next unless $p;
+ # warn "Found prereq expr[$p]";
+
+ # Regexp modified by A.Speer to remember actual version of file
+ # PREREQ_PM hash key wants, then add to
+ while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
+ my($m,$n) = ($1,$2);
+ # When a prereq is mentioned twice: let the bigger
+ # win; usual culprit is that they declared
+ # build_requires separately from requires; see
+ # rt.cpan.org #47774
+ my($prevn);
+ if ( defined $req->{$m} ) {
+ $prevn = $req->{$m};
+ }
+ if ($n =~ /^q\[(.*?)\]$/) {
+ $n = $1;
+ }
+ if (!$prevn || CPAN::Version->vlt($prevn, $n)){
+ $req->{$m} = $n;
+ }
+ }
+ last;
+ }
+ }
+ }
+ unless ($req || $breq) {
+ my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
+ my $buildfile = File::Spec->catfile($build_dir,"Build");
+ if (-f $buildfile) {
+ CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
+ my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
+ if (-f $build_prereqs) {
+ CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
+ my $content = do { local *FH;
+ open FH, $build_prereqs
+ or $CPAN::Frontend->mydie("Could not open ".
+ "'$build_prereqs': $!");
+ local $/;
+ <FH>;
+ };
+ my $bphash = eval $content;
+ if ($@) {
+ } else {
+ $req = $bphash->{requires} || +{};
+ $breq = $bphash->{build_requires} || +{};
+ }
+ }
+ }
+ }
+ if (-f "Build.PL"
+ && ! -f "Makefile.PL"
+ && ! exists $req->{"Module::Build"}
+ && ! $CPAN::META->has_inst("Module::Build")) {
+ $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
+ "undeclared prerequisite.\n".
+ " Adding it now as such.\n"
+ );
+ $CPAN::Frontend->mysleep(5);
+ $req->{"Module::Build"} = 0;
+ delete $self->{writemakefile};
+ }
+ if ($req || $breq) {
+ $self->{prereq_pm_detected}++;
+ return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
+ }
+}
+
+#-> sub CPAN::Distribution::test ;
+sub test {
+ my($self) = @_;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+ $self->make;
+ return if $self->prefs->{disabled} && ! $self->{force_update};
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+ # warn "XDEBUG: checking for notest: $self->{notest} $self";
+ if ($self->{notest}) {
+ $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
+ return 1;
+ }
+
+ my $make = $self->{modulebuild} ? "Build" : "make";
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ $CPAN::Frontend->myprint("Running $make test\n");
+
+ EXCUSE: {
+ my @e;
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
+ push @e,
+ "Make had some problems, won't test";
+ }
+
+ exists $self->{make} and
+ (
+ UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/
+ ) and push @e, "Can't test without successful make";
+ $self->{badtestcnt} ||= 0;
+ if ($self->{badtestcnt} > 0) {
+ require Data::Dumper;
+ CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
+ push @e, "Won't repeat unsuccessful test during this command";
+ }
+
+ push @e, $self->{later} if $self->{later};
+ push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
+
+ if (exists $self->{build_dir}) {
+ if (exists $self->{make_test}) {
+ if (
+ UNIVERSAL::can($self->{make_test},"failed") ?
+ $self->{make_test}->failed :
+ $self->{make_test} =~ /^NO/
+ ) {
+ if (
+ UNIVERSAL::can($self->{make_test},"commandid")
+ &&
+ $self->{make_test}->commandid == $CPAN::CurrentCommandId
+ ) {
+ push @e, "Has already been tested within this command";
+ }
+ } else {
+ push @e, "Has already been tested successfully";
+ # if global "is_tested" has been cleared, we need to mark this to
+ # be added to PERL5LIB if not already installed
+ if ($self->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ }
+ }
+ }
+ } elsif (!@e) {
+ push @e, "Has no own directory";
+ }
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ unless (chdir $self->{build_dir}) {
+ push @e, "Couldn't chdir to '$self->{build_dir}': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
+ }
+ $self->debug("Changed directory to $self->{build_dir}")
+ if $CPAN::DEBUG;
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make_test($self);
+ return;
+ }
+
+ if ($self->{modulebuild}) {
+ my $thm = CPAN::Shell->expand("Module","Test::Harness");
+ my $v = $thm->inst_version;
+ if (CPAN::Version->vlt($v,2.62)) {
+ # XXX Eric Wilhelm reported this as a bug: klapperl:
+ # Test::Harness 3.0 self-tests, so that should be 'unless
+ # installing Test::Harness'
+ unless ($self->id eq $thm->distribution->id) {
+ $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
+ '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
+ $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
+ return;
+ }
+ }
+ }
+
+ if ( ! $self->{force_update} ) {
+ # bypass actual tests if "trust_test_report_history" and have a report
+ my $have_tested_fcn;
+ if ( $CPAN::Config->{trust_test_report_history}
+ && $CPAN::META->has_inst("CPAN::Reporter::History")
+ && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
+ if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
+ # Do nothing if grade was DISCARD
+ if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
+ # if global "is_tested" has been cleared, we need to mark this to
+ # be added to PERL5LIB if not already installed
+ if ($self->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ }
+ $CPAN::Frontend->myprint("Found prior test report -- OK\n");
+ return;
+ }
+ elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
+ $self->{badtestcnt}++;
+ $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
+ return;
+ }
+ }
+ }
+ }
+
+ my $system;
+ my $prefs_test = $self->prefs->{test};
+ if (my $commandline
+ = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
+ $system = $commandline;
+ $ENV{PERL} = CPAN::find_perl();
+ } elsif ($self->{modulebuild}) {
+ $system = sprintf "%s test", $self->_build_command();
+ unless (-e "Build") {
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
+ }
+ } else {
+ $system = join " ", $self->_make_command(), "test";
+ }
+ my $make_test_arg = $self->_make_phase_arg("test");
+ $system = sprintf("%s%s",
+ $system,
+ $make_test_arg ? " $make_test_arg" : "",
+ );
+ my($tests_ok);
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next unless defined $v;
+ $env{$k} = $v;
+ }
+ local %ENV = %env;
+ my $test_env;
+ if ($self->prefs->{test}) {
+ $test_env = $self->prefs->{test}{env};
+ }
+ if ($test_env) {
+ for my $e (keys %$test_env) {
+ $ENV{$e} = $test_env->{$e};
+ }
+ }
+ my $expect_model = $self->_prefs_with_expect("test");
+ my $want_expect = 0;
+ if ( $expect_model && @{$expect_model->{talk}} ) {
+ my $can_expect = $CPAN::META->has_inst("Expect");
+ if ($can_expect) {
+ $want_expect = 1;
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
+ "testing without\n");
+ }
+ }
+ if ($want_expect) {
+ if ($self->_should_report('test')) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
+ "not supported when distroprefs specify ".
+ "an interactive test\n");
+ }
+ $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
+ } elsif ( $self->_should_report('test') ) {
+ $tests_ok = CPAN::Reporter::test($self, $system);
+ } else {
+ $tests_ok = system($system) == 0;
+ }
+ $self->introduce_myself;
+ if ( $tests_ok ) {
+ {
+ my @prereq;
+
+ # local $CPAN::DEBUG = 16; # Distribution
+ for my $m (keys %{$self->{sponsored_mods}}) {
+ next unless $self->{sponsored_mods}{$m} > 0;
+ my $m_obj = CPAN::Shell->expand("Module",$m) or next;
+ # XXX we need available_version which reflects
+ # $ENV{PERL5LIB} so that already tested but not yet
+ # installed modules are counted.
+ my $available_version = $m_obj->available_version;
+ my $available_file = $m_obj->available_file;
+ if ($available_version &&
+ !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
+ ) {
+ CPAN->debug("m[$m] good enough available_version[$available_version]")
+ if $CPAN::DEBUG;
+ } elsif ($available_file
+ && (
+ !$self->{prereq_pm}{$m}
+ ||
+ $self->{prereq_pm}{$m} == 0
+ )
+ ) {
+ # lex Class::Accessor::Chained::Fast which has no $VERSION
+ CPAN->debug("m[$m] have available_file[$available_file]")
+ if $CPAN::DEBUG;
+ } else {
+ push @prereq, $m;
+ }
+ }
+ if (@prereq) {
+ my $cnt = @prereq;
+ my $which = join ",", @prereq;
+ my $but = $cnt == 1 ? "one dependency not OK ($which)" :
+ "$cnt dependencies missing ($which)";
+ $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO $but");
+ $self->store_persistent_state;
+ return $self->goodbye("[dependencies] -- NA");
+ }
+ }
+
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ # probably impossible to need the next line because badtestcnt
+ # has a lifespan of one command
+ delete $self->{badtestcnt};
+ } else {
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
+ $self->{badtestcnt}++;
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ CPAN::Shell->optprint
+ ("hint",
+ sprintf
+ ("//hint// to see the cpan-testers results for installing this module, try:
+ reports %s\n",
+ $self->pretty_id));
+ }
+ $self->store_persistent_state;
+}
+
+sub _prefs_with_expect {
+ my($self,$where) = @_;
+ return unless my $prefs = $self->prefs;
+ return unless my $where_prefs = $prefs->{$where};
+ if ($where_prefs->{expect}) {
+ return {
+ mode => "deterministic",
+ timeout => 15,
+ talk => $where_prefs->{expect},
+ };
+ } elsif ($where_prefs->{"eexpect"}) {
+ return $where_prefs->{"eexpect"};
+ }
+ return;
+}
+
+#-> sub CPAN::Distribution::clean ;
+sub clean {
+ my($self) = @_;
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make clean\n");
+ unless (exists $self->{archived}) {
+ $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
+ "/untarred, nothing done\n");
+ return 1;
+ }
+ unless (exists $self->{build_dir}) {
+ $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
+ return 1;
+ }
+ if (exists $self->{writemakefile}
+ and $self->{writemakefile}->failed
+ ) {
+ $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
+ return 1;
+ }
+ EXCUSE: {
+ my @e;
+ exists $self->{make_clean} and $self->{make_clean} eq "YES" and
+ push @e, "make clean already called once";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ chdir $self->{build_dir} or
+ Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
+ $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make_clean($self);
+ return;
+ }
+
+ my $system;
+ if ($self->{modulebuild}) {
+ unless (-f "Build") {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
+ " in cwd[$cwd]. Danger, Will Robinson!");
+ $CPAN::Frontend->mysleep(5);
+ }
+ $system = sprintf "%s clean", $self->_build_command();
+ } else {
+ $system = join " ", $self->_make_command(), "clean";
+ }
+ my $system_ok = system($system) == 0;
+ $self->introduce_myself;
+ if ( $system_ok ) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+
+ # $self->force;
+
+ # Jost Krieger pointed out that this "force" was wrong because
+ # it has the effect that the next "install" on this distribution
+ # will untar everything again. Instead we should bring the
+ # object's state back to where it is after untarring.
+
+ for my $k (qw(
+ force_update
+ install
+ writemakefile
+ make
+ make_test
+ )) {
+ delete $self->{$k};
+ }
+ $self->{make_clean} = CPAN::Distrostatus->new("YES");
+
+ } else {
+ # Hmmm, what to do if make clean failed?
+
+ $self->{make_clean} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
+
+ # 2006-02-27: seems silly to me to force a make now
+ # $self->force("make"); # so that this directory won't be used again
+
+ }
+ $self->store_persistent_state;
+}
+
+#-> sub CPAN::Distribution::goto ;
+sub goto {
+ my($self,$goto) = @_;
+ $goto = $self->normalize($goto);
+ my $why = sprintf(
+ "Goto '$goto' via prefs file '%s' doc %d",
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ );
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
+ # 2007-07-16 akoenig : Better than NA would be if we could inherit
+ # the status of the $goto distro but given the exceptional nature
+ # of 'goto' I feel reluctant to implement it
+ my $goodbye_message = "[goto] -- NA $why";
+ $self->goodbye($goodbye_message);
+
+ # inject into the queue
+
+ CPAN::Queue->delete($self->id);
+ CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
+
+ # and run where we left off
+
+ my($method) = (caller(1))[3];
+ CPAN->instance("CPAN::Distribution",$goto)->$method();
+ CPAN::Queue->delete_first($goto);
+}
+
+#-> sub CPAN::Distribution::install ;
+sub install {
+ my($self) = @_;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+ unless ($self->{badtestcnt}) {
+ $self->test;
+ }
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make install\n");
+ EXCUSE: {
+ my @e;
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
+ push @e,
+ "Make had some problems, won't install";
+ }
+
+ exists $self->{make} and
+ (
+ UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/
+ ) and
+ push @e, "Make had returned bad status, install seems impossible";
+
+ if (exists $self->{build_dir}) {
+ } elsif (!@e) {
+ push @e, "Has no own directory";
+ }
+
+ if (exists $self->{make_test} and
+ (
+ UNIVERSAL::can($self->{make_test},"failed") ?
+ $self->{make_test}->failed :
+ $self->{make_test} =~ /^NO/
+ )) {
+ if ($self->{force_update}) {
+ $self->{make_test}->text("FAILED but failure ignored because ".
+ "'force' in effect");
+ } else {
+ push @e, "make test had returned bad status, ".
+ "won't install without force"
+ }
+ }
+ if (exists $self->{install}) {
+ if (UNIVERSAL::can($self->{install},"text") ?
+ $self->{install}->text eq "YES" :
+ $self->{install} =~ /^YES/
+ ) {
+ $CPAN::Frontend->myprint(" Already done\n");
+ $CPAN::META->is_installed($self->{build_dir});
+ return 1;
+ } else {
+ # comment in Todo on 2006-02-11; maybe retry?
+ push @e, "Already tried without success";
+ }
+ }
+
+ push @e, $self->{later} if $self->{later};
+ push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
+
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ unless (chdir $self->{build_dir}) {
+ push @e, "Couldn't chdir to '$self->{build_dir}': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
+ }
+ $self->debug("Changed directory to $self->{build_dir}")
+ if $CPAN::DEBUG;
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make_install($self);
+ return;
+ }
+
+ my $system;
+ if (my $commandline = $self->prefs->{install}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = CPAN::find_perl();
+ } elsif ($self->{modulebuild}) {
+ my($mbuild_install_build_command) =
+ exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
+ $CPAN::Config->{mbuild_install_build_command} ?
+ $CPAN::Config->{mbuild_install_build_command} :
+ $self->_build_command();
+ $system = sprintf("%s install %s",
+ $mbuild_install_build_command,
+ $CPAN::Config->{mbuild_install_arg},
+ );
+ } else {
+ my($make_install_make_command) =
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make_install_make_command})
+ || $self->_make_command();
+ $system = sprintf("%s install %s",
+ $make_install_make_command,
+ $CPAN::Config->{make_install_arg},
+ );
+ }
+
+ my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
+ my $brip = CPAN::HandleConfig->prefs_lookup($self,
+ q{build_requires_install_policy});
+ $brip ||="ask/yes";
+ my $id = $self->id;
+ my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
+ my $want_install = "yes";
+ if ($reqtype eq "b") {
+ if ($brip eq "no") {
+ $want_install = "no";
+ } elsif ($brip =~ m|^ask/(.+)|) {
+ my $default = $1;
+ $default = "yes" unless $default =~ /^(y|n)/i;
+ $want_install =
+ CPAN::Shell::colorable_makemaker_prompt
+ ("$id is just needed temporarily during building or testing. ".
+ "Do you want to install it permanently?",
+ $default);
+ }
+ }
+ unless ($want_install =~ /^y/i) {
+ my $is_only = "is only 'build_requires'";
+ $CPAN::Frontend->mywarn("Not installing because $is_only\n");
+ $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
+ delete $self->{force_update};
+ return;
+ }
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ $CPAN::META->set_perl5lib;
+ my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
+("Can't execute $system: $!");
+ my($makeout) = "";
+ while (<$pipe>) {
+ print $_; # intentionally NOT use Frontend->myprint because it
+ # looks irritating when we markup in color what we
+ # just pass through from an external program
+ $makeout .= $_;
+ }
+ $pipe->close;
+ my $close_ok = $? == 0;
+ $self->introduce_myself;
+ if ( $close_ok ) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $CPAN::META->is_installed($self->{build_dir});
+ $self->{install} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{install} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ my $mimc =
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make_install_make_command});
+ if (
+ $makeout =~ /permission/s
+ && $> > 0
+ && (
+ ! $mimc
+ || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
+ q{make}))
+ )
+ ) {
+ $CPAN::Frontend->myprint(
+ qq{----\n}.
+ qq{ You may have to su }.
+ qq{to root to install the package\n}.
+ qq{ (Or you may want to run something like\n}.
+ qq{ o conf make_install_make_command 'sudo make'\n}.
+ qq{ to raise your permissions.}
+ );
+ }
+ }
+ delete $self->{force_update};
+ $self->store_persistent_state;
+}
+
+sub introduce_myself {
+ my($self) = @_;
+ $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
+}
+
+#-> sub CPAN::Distribution::dir ;
+sub dir {
+ shift->{build_dir};
+}
+
+#-> sub CPAN::Distribution::perldoc ;
+sub perldoc {
+ my($self) = @_;
+
+ my($dist) = $self->id;
+ my $package = $self->called_for;
+
+ if ($CPAN::META->has_inst("Pod::Perldocs")) {
+ my($perl) = $self->perl
+ or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
+ my @args = ($perl, q{-MPod::Perldocs}, q{-e},
+ q{Pod::Perldocs->run()}, $package);
+ my($wstatus);
+ unless ( ($wstatus = system(@args)) == 0 ) {
+ my $estatus = $wstatus >> 8;
+ $CPAN::Frontend->myprint(qq{
+ Function system("@args")
+ returned status $estatus (wstat $wstatus)
+ });
+ }
+ }
+ else {
+ $self->_display_url( $CPAN::Defaultdocs . $package );
+ }
+}
+
+#-> sub CPAN::Distribution::_check_binary ;
+sub _check_binary {
+ my ($dist,$shell,$binary) = @_;
+ my ($pid,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
+ if $CPAN::DEBUG;
+
+ if ($CPAN::META->has_inst("File::Which")) {
+ return File::Which::which($binary);
+ } else {
+ local *README;
+ $pid = open README, "which $binary|"
+ or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
+ return unless $pid;
+ while (<README>) {
+ $out .= $_;
+ }
+ close README
+ or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
+ and return;
+ }
+
+ $CPAN::Frontend->myprint(qq{ + $out \n})
+ if $CPAN::DEBUG && $out;
+
+ return $out;
+}
+
+#-> sub CPAN::Distribution::_display_url ;
+sub _display_url {
+ my($self,$url) = @_;
+ my($res,$saved_file,$pid,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
+ if $CPAN::DEBUG;
+
+ # should we define it in the config instead?
+ my $html_converter = "html2text.pl";
+
+ my $web_browser = $CPAN::Config->{'lynx'} || undef;
+ my $web_browser_out = $web_browser
+ ? CPAN::Distribution->_check_binary($self,$web_browser)
+ : undef;
+
+ if ($web_browser_out) {
+ # web browser found, run the action
+ my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
+ $CPAN::Frontend->myprint(qq{system[$browser $url]})
+ if $CPAN::DEBUG;
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with browser $browser
+});
+ $CPAN::Frontend->mysleep(1);
+ system("$browser $url");
+ if ($saved_file) { 1 while unlink($saved_file) }
+ } else {
+ # web browser not found, let's try text only
+ my $html_converter_out =
+ CPAN::Distribution->_check_binary($self,$html_converter);
+ $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
+
+ if ($html_converter_out ) {
+ # html2text found, run it
+ $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
+ $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
+ unless defined($saved_file);
+
+ local *README;
+ $pid = open README, "$html_converter $saved_file |"
+ or $CPAN::Frontend->mydie(qq{
+Could not fork '$html_converter $saved_file': $!});
+ my($fh,$filename);
+ if ($CPAN::META->has_usable("File::Temp")) {
+ $fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => 'cpan_htmlconvert_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ $filename = $fh->filename;
+ } else {
+ $filename = "cpan_htmlconvert_$$.txt";
+ $fh = FileHandle->new();
+ open $fh, ">$filename" or die;
+ }
+ while (<README>) {
+ $fh->print($_);
+ }
+ close README or
+ $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
+ my $tmpin = $fh->filename;
+ $CPAN::Frontend->myprint(sprintf(qq{
+Run '%s %s' and
+saved output to %s\n},
+ $html_converter,
+ $saved_file,
+ $tmpin,
+ )) if $CPAN::DEBUG;
+ close $fh;
+ local *FH;
+ open FH, $tmpin
+ or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ my $pager = $CPAN::Config->{'pager'} || "cat";
+ $fh_pager->open("|$pager")
+ or $CPAN::Frontend->mydie(qq{
+Could not open pager '$pager': $!});
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with pager "$pager"
+});
+ $CPAN::Frontend->mysleep(1);
+ $fh_pager->print(<FH>);
+ $fh_pager->close;
+ } else {
+ # coldn't find the web browser or html converter
+ $CPAN::Frontend->myprint(qq{
+You need to install lynx or $html_converter to use this feature.});
+ }
+ }
+}
+
+#-> sub CPAN::Distribution::_getsave_url ;
+sub _getsave_url {
+ my($dist, $shell, $url) = @_;
+
+ $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
+ if $CPAN::DEBUG;
+
+ my($fh,$filename);
+ if ($CPAN::META->has_usable("File::Temp")) {
+ $fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => "cpan_getsave_url_XXXX",
+ suffix => ".html",
+ unlink => 0,
+ );
+ $filename = $fh->filename;
+ } else {
+ $fh = FileHandle->new;
+ $filename = "cpan_getsave_url_$$.html";
+ }
+ my $tmpin = $filename;
+ if ($CPAN::META->has_usable('LWP')) {
+ $CPAN::Frontend->myprint("Fetching with LWP:
+ $url
+");
+ my $Ua;
+ CPAN::LWP::UserAgent->config;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
+ return;
+ } else {
+ my($var);
+ $Ua->proxy('http', $var)
+ if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
+ $Ua->no_proxy($var)
+ if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
+ }
+
+ my $req = HTTP::Request->new(GET => $url);
+ $req->header('Accept' => 'text/html');
+ my $res = $Ua->request($req);
+ if ($res->is_success) {
+ $CPAN::Frontend->myprint(" + request successful.\n")
+ if $CPAN::DEBUG;
+ print $fh $res->content;
+ close $fh;
+ $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
+ if $CPAN::DEBUG;
+ return $tmpin;
+ } else {
+ $CPAN::Frontend->myprint(sprintf(
+ "LWP failed with code[%s], message[%s]\n",
+ $res->code,
+ $res->message,
+ ));
+ return;
+ }
+ } else {
+ $CPAN::Frontend->mywarn(" LWP not available\n");
+ return;
+ }
+}
+
+#-> sub CPAN::Distribution::_build_command
+sub _build_command {
+ my($self) = @_;
+ if ($^O eq "MSWin32") { # special code needed at least up to
+ # Module::Build 0.2611 and 0.2706; a fix
+ # in M:B has been promised 2006-01-30
+ my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
+ return "$perl ./Build";
+ }
+ return "./Build";
+}
+
+#-> sub CPAN::Distribution::_should_report
+sub _should_report {
+ my($self, $phase) = @_;
+ die "_should_report() requires a 'phase' argument"
+ if ! defined $phase;
+
+ # configured
+ my $test_report = CPAN::HandleConfig->prefs_lookup($self,
+ q{test_report});
+ return unless $test_report;
+
+ # don't repeat if we cached a result
+ return $self->{should_report}
+ if exists $self->{should_report};
+
+ # don't report if we generated a Makefile.PL
+ if ( $self->{had_no_makefile_pl} ) {
+ $CPAN::Frontend->mywarn(
+ "Will not send CPAN Testers report with generated Makefile.PL.\n"
+ );
+ return $self->{should_report} = 0;
+ }
+
+ # available
+ if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
+ $CPAN::Frontend->mywarn(
+ "CPAN::Reporter not installed. No reports will be sent.\n"
+ );
+ return $self->{should_report} = 0;
+ }
+
+ # capable
+ my $crv = CPAN::Reporter->VERSION;
+ if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
+ # don't cache $self->{should_report} -- need to check each phase
+ if ( $phase eq 'test' ) {
+ return 1;
+ }
+ else {
+ $CPAN::Frontend->mywarn(
+ "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
+ "you only have version $crv\. Only 'test' phase reports will be sent.\n"
+ );
+ return;
+ }
+ }
+
+ # appropriate
+ if ($self->is_dot_dist) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "for local directories\n");
+ return $self->{should_report} = 0;
+ }
+ if ($self->prefs->{patches}
+ &&
+ @{$self->prefs->{patches}}
+ &&
+ $self->{patched}
+ ) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "when the source has been patched\n");
+ return $self->{should_report} = 0;
+ }
+
+ # proceed and cache success
+ return $self->{should_report} = 1;
+}
+
+#-> sub CPAN::Distribution::reports
+sub reports {
+ my($self) = @_;
+ my $pathname = $self->id;
+ $CPAN::Frontend->myprint("Distribution: $pathname\n");
+
+ unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
+ $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
+ }
+ unless ($CPAN::META->has_usable("LWP")) {
+ $CPAN::Frontend->mydie("LWP not installed; cannot continue");
+ }
+ unless ($CPAN::META->has_usable("File::Temp")) {
+ $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
+ }
+
+ my $d = CPAN::DistnameInfo->new($pathname);
+
+ my $dist = $d->dist; # "CPAN-DistnameInfo"
+ my $version = $d->version; # "0.02"
+ my $maturity = $d->maturity; # "released"
+ my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
+ my $cpanid = $d->cpanid; # "GBARR"
+ my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
+
+ my $url = sprintf "http://www.cpantesters.org/show/%s.yaml", $dist;
+
+ CPAN::LWP::UserAgent->config;
+ my $Ua;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ $CPAN::Frontend->myprint("Fetching '$url'...");
+ my $resp = $Ua->get($url);
+ unless ($resp->is_success) {
+ $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
+ }
+ $CPAN::Frontend->myprint("DONE\n\n");
+ my $yaml = $resp->content;
+ # was fuer ein Umweg!
+ my $fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => 'cpan_reports_XXXX',
+ suffix => '.yaml',
+ unlink => 0,
+ );
+ my $tfilename = $fh->filename;
+ print $fh $yaml;
+ close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
+ my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
+ unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
+ my %other_versions;
+ my $this_version_seen;
+ for my $rep (@$unserialized) {
+ my $rversion = $rep->{version};
+ if ($rversion eq $version) {
+ unless ($this_version_seen++) {
+ $CPAN::Frontend->myprint ("$rep->{version}:\n");
+ }
+ my $arch = $rep->{archname} || $rep->{platform} || '????';
+ my $grade = $rep->{action} || $rep->{status} || '????';
+ my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????';
+ $CPAN::Frontend->myprint
+ (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
+ $arch eq $Config::Config{archname}?"*":"",
+ $grade eq "PASS"?"+":$grade eq"FAIL"?"-":"",
+ $grade,
+ $rep->{perl},
+ $ostext,
+ $rep->{osvers},
+ $arch,
+ ));
+ } else {
+ $other_versions{$rep->{version}}++;
+ }
+ }
+ unless ($this_version_seen) {
+ $CPAN::Frontend->myprint("No reports found for version '$version'
+Reports for other versions:\n");
+ for my $v (sort keys %other_versions) {
+ $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
+ }
+ }
+ $url =~ s/\.yaml/.html/;
+ $CPAN::Frontend->myprint("See $url for details\n");
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Distroprefs.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Distroprefs.pm
new file mode 100755
index 00000000000..e1be9cdf749
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Distroprefs.pm
@@ -0,0 +1,451 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+
+use strict;
+package CPAN::Distroprefs;
+
+use vars qw($VERSION);
+$VERSION = '6';
+
+package CPAN::Distroprefs::Result;
+
+use File::Spec;
+
+sub new { bless $_[1] || {} => $_[0] }
+
+sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
+
+sub __cloner {
+ my ($class, $name, $newclass) = @_;
+ $newclass = 'CPAN::Distroprefs::Result::' . $newclass;
+ no strict 'refs';
+ *{$class . '::' . $name} = sub {
+ $newclass->new({
+ %{ $_[0] },
+ %{ $_[1] },
+ });
+ };
+}
+BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
+BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
+BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
+
+sub __accessor {
+ my ($class, $key) = @_;
+ no strict 'refs';
+ *{$class . '::' . $key} = sub { $_[0]->{$key} };
+}
+BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
+
+sub is_warning { 0 }
+sub is_fatal { 0 }
+sub is_success { 0 }
+
+package CPAN::Distroprefs::Result::Error;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
+BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
+
+sub as_string {
+ my ($self) = @_;
+ if ($self->msg) {
+ return sprintf $self->fmt_reason, $self->file, $self->msg;
+ } else {
+ return sprintf $self->fmt_unknown, $self->file;
+ }
+}
+
+package CPAN::Distroprefs::Result::Warning;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
+sub is_warning { 1 }
+sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
+sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
+
+package CPAN::Distroprefs::Result::Fatal;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
+sub is_fatal { 1 }
+sub fmt_reason { "Error reading distroprefs file %s: %s" }
+sub fmt_unknown { "Unknown error reading distroprefs file %s." }
+
+package CPAN::Distroprefs::Result::Success;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
+BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
+sub is_success { 1 }
+
+package CPAN::Distroprefs::Iterator;
+
+sub new { bless $_[1] => $_[0] }
+
+sub next { $_[0]->() }
+
+package CPAN::Distroprefs;
+
+use Carp ();
+use DirHandle;
+
+sub _load_method {
+ my ($self, $loader, $result) = @_;
+ return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
+ return '_load_' . $result->ext;
+}
+
+sub _load_yaml {
+ my ($self, $loader, $result) = @_;
+ my $data = eval {
+ $loader eq 'CPAN'
+ ? $loader->_yaml_loadfile($result->abs)
+ : [ $loader->can('LoadFile')->($result->abs) ]
+ };
+ if (my $err = $@) {
+ die $result->as_warning({
+ msg => $err,
+ });
+ } elsif (!$data) {
+ die $result->as_warning;
+ } else {
+ return @$data;
+ }
+}
+
+sub _load_dd {
+ my ($self, $loader, $result) = @_;
+ my @data;
+ {
+ package CPAN::Eval;
+ # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
+ # not sure why we wouldn't just skip the file as we do for all other
+ # errors. -- hdp
+ my $abs = $result->abs;
+ open FH, "<$abs" or die $result->as_fatal(msg => "$!");
+ local $/;
+ my $eval = <FH>;
+ close FH;
+ no strict;
+ eval $eval;
+ if (my $err = $@) {
+ die $result->as_warning({ msg => $err });
+ }
+ my $i = 1;
+ while (${"VAR$i"}) {
+ push @data, ${"VAR$i"};
+ $i++;
+ }
+ }
+ return @data;
+}
+
+sub _load_st {
+ my ($self, $loader, $result) = @_;
+ # eval because Storable is never forward compatible
+ my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
+ if (my $err = $@) {
+ die $result->as_warning({ msg => $err });
+ }
+ return @data;
+}
+
+sub find {
+ my ($self, $dir, $ext_map) = @_;
+
+ my $dh = DirHandle->new($dir) or Carp::croak("Couldn't open '$dir': $!");
+ my @files = sort $dh->read;
+
+ # label the block so that we can use redo in the middle
+ return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
+ return unless %$ext_map;
+
+ local $_ = shift @files;
+ return unless defined;
+ redo if $_ eq '.' || $_ eq '..';
+
+ my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
+ my ($ext) = /\.($possible_ext)$/ or redo;
+ my $loader = $ext_map->{$ext};
+
+ my $result = CPAN::Distroprefs::Result->new({
+ file => $_, ext => $ext, dir => $dir
+ });
+ # copied from CPAN.pm; is this ever actually possible?
+ redo unless -f $result->abs;
+
+ my $load_method = $self->_load_method($loader, $result);
+ my @prefs = eval { $self->$load_method($loader, $result) };
+ if (my $err = $@) {
+ if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
+ return $err;
+ }
+ # rethrow any exceptions that we did not generate
+ die $err;
+ } elsif (!@prefs) {
+ # the loader should have handled this, but just in case:
+ return $result->as_warning;
+ }
+ return $result->as_success({
+ prefs => [
+ map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
+ ],
+ });
+ } });
+}
+
+package CPAN::Distroprefs::Pref;
+
+use Carp ();
+
+sub new { bless $_[1] => $_[0] }
+
+sub data { shift->{data} }
+
+sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
+
+sub has_match {
+ my $match = $_[0]->data->{match} || return 0;
+ exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
+}
+
+sub has_valid_subkeys {
+ grep { exists $_[0]->data->{match}{$_} }
+ map { $_, "not_$_" }
+ $_[0]->match_attributes
+}
+
+sub _pattern {
+ my $re = shift;
+ my $p = eval sprintf 'qr{%s}', $re;
+ if ($@) {
+ $@ =~ s/\n$//;
+ die "Error in Distroprefs pattern qr{$re}\n$@";
+ }
+ return $p;
+}
+
+sub _match_scalar {
+ my ($match, $data) = @_;
+ my $qr = _pattern($match);
+ return $data =~ /$qr/;
+}
+
+sub _match_hash {
+ my ($match, $data) = @_;
+ for my $mkey (keys %$match) {
+ (my $dkey = $mkey) =~ s/^not_//;
+ my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
+ if (_match_scalar($match->{$mkey}, $val)) {
+ return 0 if $mkey =~ /^not_/;
+ }
+ else {
+ return 0 if $mkey !~ /^not_/;
+ }
+ }
+ return 1;
+}
+
+sub _match {
+ my ($self, $key, $data, $matcher) = @_;
+ my $m = $self->data->{match};
+ if (exists $m->{$key}) {
+ return 0 unless $matcher->($m->{$key}, $data);
+ }
+ if (exists $m->{"not_$key"}) {
+ return 0 if $matcher->($m->{"not_$key"}, $data);
+ }
+ return 1;
+}
+
+sub _scalar_match {
+ my ($self, $key, $data) = @_;
+ return $self->_match($key, $data, \&_match_scalar);
+}
+
+sub _hash_match {
+ my ($self, $key, $data) = @_;
+ return $self->_match($key, $data, \&_match_hash);
+}
+
+# do not take the order of C<keys %$match> because "module" is by far the
+# slowest
+sub match_attributes { qw(env distribution perl perlconfig module) }
+
+sub match_module {
+ my ($self, $modules) = @_;
+ return $self->_match("module", $modules, sub {
+ my($match, $data) = @_;
+ my $qr = _pattern($match);
+ for my $module (@$data) {
+ return 1 if $module =~ /$qr/;
+ }
+ return 0;
+ });
+}
+
+sub match_distribution { shift->_scalar_match(distribution => @_) }
+sub match_perl { shift->_scalar_match(perl => @_) }
+
+sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
+sub match_env { shift->_hash_match(env => @_) }
+
+sub matches {
+ my ($self, $arg) = @_;
+
+ my $default_match = 0;
+ for my $key (grep { $self->has_match($_) } $self->match_attributes) {
+ unless (exists $arg->{$key}) {
+ Carp::croak "Can't match pref: missing argument key $key";
+ }
+ $default_match = 1;
+ my $val = $arg->{$key};
+ # make it possible to avoid computing things until we have to
+ if (ref($val) eq 'CODE') { $val = $val->() }
+ my $meth = "match_$key";
+ return 0 unless $self->$meth($val);
+ }
+
+ return $default_match;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Distroprefs -- read and match distroprefs
+
+=head1 SYNOPSIS
+
+ use CPAN::Distroprefs;
+
+ my %info = (... distribution/environment info ...);
+
+ my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
+
+ while (my $result = $finder->next) {
+
+ die $result->as_string if $result->is_fatal;
+
+ warn($result->as_string), next if $result->is_warning;
+
+ for my $pref (@{ $result->prefs }) {
+ if ($pref->matches(\%info)) {
+ return $pref;
+ }
+ }
+ }
+
+
+=head1 DESCRIPTION
+
+This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
+
+=head1 INTERFACE
+
+ my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
+
+ while (my $result = $finder->next) { ... }
+
+Build an iterator which finds distroprefs files in the given directory.
+
+C<%ext_map> is a hashref whose keys are file extensions and whose values are
+modules used to load matching files:
+
+ {
+ 'yml' => 'YAML::Syck',
+ 'dd' => 'Data::Dumper',
+ ...
+ }
+
+Each time C<< $finder->next >> is called, the iterator returns one of two
+possible values:
+
+=over
+
+=item * a CPAN::Distroprefs::Result object
+
+=item * C<undef>, indicating that no prefs files remain to be found
+
+=back
+
+=head1 RESULTS
+
+L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
+indicate success or failure when reading a prefs file.
+
+=head2 Common
+
+All results share some common attributes:
+
+=head3 type
+
+C<success>, C<warning>, or C<fatal>
+
+=head3 file
+
+the file from which these prefs were read, or to which this error refers (relative filename)
+
+=head3 ext
+
+the file's extension, which determines how to load it
+
+=head3 dir
+
+the directory the file was read from
+
+=head3 abs
+
+the absolute path to the file
+
+=head2 Errors
+
+Error results (warning and fatal) contain:
+
+=head3 msg
+
+the error message (usually either C<$!> or a YAML error)
+
+=head2 Successes
+
+Success results contain:
+
+=head3 prefs
+
+an arrayref of CPAN::Distroprefs::Pref objects
+
+=head1 PREFS
+
+CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
+They are constructed automatically as part of C<success> results from C<find()>.
+
+=head3 data
+
+the pref information as a hashref, suitable for e.g. passing to Kwalify
+
+=head3 match_attributes
+
+returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
+
+currently: C<env perl perlconfig distribution module>
+
+=head3 has_any_match
+
+true if this pref has a 'match' attribute at all
+
+=head3 has_valid_subkeys
+
+true if this pref has a 'match' attribute and at least one valid match attribute
+
+=head3 matches
+
+ if ($pref->matches(\%arg)) { ... }
+
+true if this pref matches the passed-in hashref, which must have a value for
+each of the C<match_attributes> (above)
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Distrostatus.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Distrostatus.pm
new file mode 100755
index 00000000000..0cc6cc9a793
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Distrostatus.pm
@@ -0,0 +1,45 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Distrostatus;
+use overload '""' => "as_string",
+ fallback => 1;
+use vars qw($something_has_failed_at);
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$arg) = @_;
+ my $failed = substr($arg,0,2) eq "NO";
+ if ($failed) {
+ $something_has_failed_at = $CPAN::CurrentCommandId;
+ }
+ bless {
+ TEXT => $arg,
+ FAILED => $failed,
+ COMMANDID => $CPAN::CurrentCommandId,
+ TIME => time,
+ }, $class;
+}
+sub something_has_just_failed () {
+ defined $something_has_failed_at &&
+ $something_has_failed_at == $CPAN::CurrentCommandId;
+}
+sub commandid { shift->{COMMANDID} }
+sub failed { shift->{FAILED} }
+sub text {
+ my($self,$set) = @_;
+ if (defined $set) {
+ $self->{TEXT} = $set;
+ }
+ $self->{TEXT};
+}
+sub as_string {
+ my($self) = @_;
+ $self->text;
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/RecursiveDependency.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/RecursiveDependency.pm
new file mode 100755
index 00000000000..b928ad74e31
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/RecursiveDependency.pm
@@ -0,0 +1,85 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::RecursiveDependency;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+# a module sees its distribution (no version)
+# a distribution sees its prereqs (which are module names) (usually with versions)
+# a bundle sees its module names and/or its distributions (no version)
+
+sub new {
+ my($class) = shift;
+ my($deps_arg) = shift;
+ my (@deps,%seen,$loop_starts_with);
+ DCHAIN: for my $dep (@$deps_arg) {
+ push @deps, {name => $dep, display_as => $dep};
+ if ($seen{$dep}++) {
+ $loop_starts_with = $dep;
+ last DCHAIN;
+ }
+ }
+ my $in_loop = 0;
+ for my $i (0..$#deps) {
+ my $x = $deps[$i]{name};
+ $in_loop ||= $loop_starts_with && $x eq $loop_starts_with;
+ my $xo = CPAN::Shell->expandany($x) or next;
+ if ($xo->isa("CPAN::Module")) {
+ my $have = $xo->inst_version || "N/A";
+ my($want,$d,$want_type);
+ if ($i>0 and $d = $deps[$i-1]{name}) {
+ my $do = CPAN::Shell->expandany($d);
+ $want = $do->{prereq_pm}{requires}{$x};
+ if (defined $want) {
+ $want_type = "requires: ";
+ } else {
+ $want = $do->{prereq_pm}{build_requires}{$x};
+ if (defined $want) {
+ $want_type = "build_requires: ";
+ } else {
+ $want_type = "unknown status";
+ $want = "???";
+ }
+ }
+ } else {
+ $want = $xo->cpan_version;
+ $want_type = "want: ";
+ }
+ $deps[$i]{have} = $have;
+ $deps[$i]{want_type} = $want_type;
+ $deps[$i]{want} = $want;
+ $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
+ } elsif ($xo->isa("CPAN::Distribution")) {
+ $deps[$i]{display_as} = $xo->pretty_id;
+ if ($in_loop) {
+ $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
+ } else {
+ $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
+ }
+ $xo->store_persistent_state; # otherwise I will not reach
+ # all involved parties for
+ # the next session
+ }
+ }
+ bless { deps => \@deps, loop_starts_with => $loop_starts_with }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ my $deps = $self->{deps};
+ my $loop_starts_with = $self->{loop_starts_with};
+ unless ($loop_starts_with) {
+ return "--not a recursive/circular dependency--";
+ }
+ my $ret = "\nRecursive dependency detected:\n ";
+ $ret .= join("\n => ", map {$_->{display_as}} @$deps);
+ $ret .= ".\nCannot resolve.\n";
+ $ret;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/blocked_urllist.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/blocked_urllist.pm
new file mode 100755
index 00000000000..102c194e612
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/blocked_urllist.pm
@@ -0,0 +1,46 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::blocked_urllist;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "1.0";
+
+
+sub new {
+ my($class) = @_;
+ bless {}, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($CPAN::Config->{connect_to_internet_ok}) {
+ return qq{
+
+You have not configured a urllist for CPAN mirrors. Configure it with
+
+ o conf init urllist
+
+};
+ } else {
+ return qq{
+
+You have not configured a urllist and do not allow connections to the
+internet to get a list of mirrors. If you wish to get a list of CPAN
+mirrors to pick from, use this command
+
+ o conf init connect_to_internet_ok urllist
+
+If you do not wish to get a list of mirrors and would prefer to set
+your urllist manually, use just this command instead
+
+ o conf init urllist
+
+};
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/yaml_not_installed.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/yaml_not_installed.pm
new file mode 100755
index 00000000000..e1259e5397d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Exception/yaml_not_installed.pm
@@ -0,0 +1,73 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::yaml_not_installed;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$module,$file,$during) = @_;
+ bless { module => $module, file => $file, during => $during }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
+}
+
+package CPAN::Exception::yaml_process_error;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$module,$file,$during,$error) = @_;
+ # my $at = Carp::longmess(""); # XXX find something more beautiful
+ bless { module => $module,
+ file => $file,
+ during => $during,
+ error => $error,
+ # at => $at,
+ }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($self->{during}) {
+ if ($self->{file}) {
+ if ($self->{module}) {
+ if ($self->{error}) {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' the following error was encountered:\n".
+ " $self->{error}\n";
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' some YAML file\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: unknown error encountered\n";
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/FTP.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/FTP.pm
new file mode 100755
index 00000000000..268ca284678
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/FTP.pm
@@ -0,0 +1,1074 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::FTP;
+use strict;
+
+use Fcntl qw(:flock);
+use File::Basename qw(dirname);
+use File::Path qw(mkpath);
+use CPAN::FTP::netrc;
+use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
+
+@CPAN::FTP::ISA = qw(CPAN::Debug);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5004";
+
+#-> sub CPAN::FTP::ftp_statistics
+# if they want to rewrite, they need to pass in a filehandle
+sub _ftp_statistics {
+ my($self,$fh) = @_;
+ my $locktype = $fh ? LOCK_EX : LOCK_SH;
+ $fh ||= FileHandle->new;
+ my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
+ mkpath dirname $file;
+ open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
+ my $sleep = 1;
+ my $waitstart;
+ while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
+ $waitstart ||= localtime();
+ if ($sleep>3) {
+ $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
+ }
+ $CPAN::Frontend->mysleep($sleep);
+ if ($sleep <= 3) {
+ $sleep+=0.33;
+ } elsif ($sleep <=6) {
+ $sleep+=0.11;
+ }
+ }
+ my $stats = eval { CPAN->_yaml_loadfile($file); };
+ if ($@) {
+ if (ref $@) {
+ if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
+ $CPAN::Frontend->myprint("Warning (usually harmless): $@\n");
+ return;
+ } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
+ $CPAN::Frontend->mydie($@);
+ }
+ } else {
+ $CPAN::Frontend->mydie($@);
+ }
+ }
+ return $stats->[0];
+}
+
+#-> sub CPAN::FTP::_mytime
+sub _mytime () {
+ if (CPAN->has_inst("Time::HiRes")) {
+ return Time::HiRes::time();
+ } else {
+ return time;
+ }
+}
+
+#-> sub CPAN::FTP::_new_stats
+sub _new_stats {
+ my($self,$file) = @_;
+ my $ret = {
+ file => $file,
+ attempts => [],
+ start => _mytime,
+ };
+ $ret;
+}
+
+#-> sub CPAN::FTP::_add_to_statistics
+sub _add_to_statistics {
+ my($self,$stats) = @_;
+ my $yaml_module = CPAN::_yaml_module();
+ $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ $stats->{thesiteurl} = $ThesiteURL;
+ $stats->{end} = CPAN::FTP::_mytime();
+ my $fh = FileHandle->new;
+ my $time = time;
+ my $sdebug = 0;
+ my @debug;
+ @debug = $time if $sdebug;
+ my $fullstats = $self->_ftp_statistics($fh);
+ close $fh;
+ $fullstats->{history} ||= [];
+ push @debug, scalar @{$fullstats->{history}} if $sdebug;
+ push @debug, time if $sdebug;
+ push @{$fullstats->{history}}, $stats;
+ # YAML.pm 0.62 is unacceptably slow with 999;
+ # YAML::Syck 0.82 has no noticable performance problem with 999;
+ my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
+ my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
+ while (
+ @{$fullstats->{history}} > $ftpstats_size
+ || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
+ ) {
+ shift @{$fullstats->{history}}
+ }
+ push @debug, scalar @{$fullstats->{history}} if $sdebug;
+ push @debug, time if $sdebug;
+ push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
+ # need no eval because if this fails, it is serious
+ my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
+ CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
+ if ( $sdebug ) {
+ local $CPAN::DEBUG = 512; # FTP
+ push @debug, time;
+ CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
+ "after[%d]at[%d]oldest[%s]dumped backat[%d]",
+ @debug,
+ ));
+ }
+ # Win32 cannot rename a file to an existing filename
+ unlink($sfile) if ($^O eq 'MSWin32' or $^O eq 'os2');
+ _copy_stat($sfile, "$sfile.$$") if -e $sfile;
+ rename "$sfile.$$", $sfile
+ or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
+ }
+}
+
+# Copy some stat information (owner, group, mode and) from one file to
+# another.
+# This is a utility function which might be moved to a utility repository.
+#-> sub CPAN::FTP::_copy_stat
+sub _copy_stat {
+ my($src, $dest) = @_;
+ my @stat = stat($src);
+ if (!@stat) {
+ $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
+ return;
+ }
+
+ eval {
+ chmod $stat[2], $dest
+ or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
+ };
+ warn $@ if $@;
+ eval {
+ chown $stat[4], $stat[5], $dest
+ or do {
+ my $save_err = $!; # otherwise it's lost in the get... calls
+ $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
+ (getpwuid($stat[4]))[0] . "/" .
+ (getgrgid($stat[5]))[0] . ": $save_err\n"
+ );
+ };
+ };
+ warn $@ if $@;
+}
+
+# if file is CHECKSUMS, suggest the place where we got the file to be
+# checked from, maybe only for young files?
+#-> sub CPAN::FTP::_recommend_url_for
+sub _recommend_url_for {
+ my($self, $file, $urllist) = @_;
+ if ($file =~ s|/CHECKSUMS(.gz)?$||) {
+ my $fullstats = $self->_ftp_statistics();
+ my $history = $fullstats->{history} || [];
+ while (my $last = pop @$history) {
+ last if $last->{end} - time > 3600; # only young results are interesting
+ next unless $last->{file}; # dirname of nothing dies!
+ next unless $file eq dirname($last->{file});
+ return $last->{thesiteurl};
+ }
+ }
+ if ($CPAN::Config->{randomize_urllist}
+ &&
+ rand(1) < $CPAN::Config->{randomize_urllist}
+ ) {
+ $urllist->[int rand scalar @$urllist];
+ } else {
+ return ();
+ }
+}
+
+#-> sub CPAN::FTP::_get_urllist
+sub _get_urllist {
+ my($self, $with_defaults) = @_;
+ $with_defaults ||= 0;
+ CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;
+
+ $CPAN::Config->{urllist} ||= [];
+ unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
+ $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
+ $CPAN::Config->{urllist} = [];
+ }
+ my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
+ push @urllist, @CPAN::Defaultsites if $with_defaults;
+ for my $u (@urllist) {
+ CPAN->debug("u[$u]") if $CPAN::DEBUG;
+ if (UNIVERSAL::can($u,"text")) {
+ $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
+ } else {
+ $u .= "/" unless substr($u,-1) eq "/";
+ $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
+ }
+ }
+ \@urllist;
+}
+
+#-> sub CPAN::FTP::ftp_get ;
+sub ftp_get {
+ my($class,$host,$dir,$file,$target) = @_;
+ $class->debug(
+ qq[Going to fetch file [$file] from dir [$dir]
+ on host [$host] as local [$target]\n]
+ ) if $CPAN::DEBUG;
+ my $ftp = Net::FTP->new($host);
+ unless ($ftp) {
+ $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
+ return;
+ }
+ return 0 unless defined $ftp;
+ $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
+ $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
+ unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg\n");
+ return;
+ }
+ unless ( $ftp->cwd($dir) ) {
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg\n");
+ return;
+ }
+ $ftp->binary;
+ $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
+ unless ( $ftp->get($file,$target) ) {
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg\n");
+ return;
+ }
+ $ftp->quit; # it's ok if this fails
+ return 1;
+}
+
+# If more accuracy is wanted/needed, Chris Leach sent me this patch...
+
+ # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
+ # > --- /tmp/cp Wed Sep 24 13:26:40 1997
+ # > ***************
+ # > *** 1562,1567 ****
+ # > --- 1562,1580 ----
+ # > return 1 if substr($url,0,4) eq "file";
+ # > return 1 unless $url =~ m|://([^/]+)|;
+ # > my $host = $1;
+ # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ # > + if ($proxy) {
+ # > + $proxy =~ m|://([^/:]+)|;
+ # > + $proxy = $1;
+ # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
+ # > + if ($noproxy) {
+ # > + if ($host !~ /$noproxy$/) {
+ # > + $host = $proxy;
+ # > + }
+ # > + } else {
+ # > + $host = $proxy;
+ # > + }
+ # > + }
+ # > require Net::Ping;
+ # > return 1 unless $Net::Ping::VERSION >= 2;
+ # > my $p;
+
+
+#-> sub CPAN::FTP::localize ;
+sub localize {
+ my($self,$file,$aslocal,$force,$with_defaults) = @_;
+ $force ||= 0;
+ Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" )
+ unless defined $aslocal;
+ if ($CPAN::DEBUG){
+ require Carp;
+ my $longmess = Carp::longmess();
+ $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
+ }
+ if ($^O eq 'MacOS') {
+ # Comment by AK on 2000-09-03: Uniq short filenames would be
+ # available in CHECKSUMS file
+ my($name, $path) = File::Basename::fileparse($aslocal, '');
+ if (length($name) > 31) {
+ $name =~ s/(
+ \.(
+ readme(\.(gz|Z))? |
+ (tar\.)?(gz|Z) |
+ tgz |
+ zip |
+ pm\.(gz|Z)
+ )
+ )$//x;
+ my $suf = $1;
+ my $size = 31 - length($suf);
+ while (length($name) > $size) {
+ chop $name;
+ }
+ $name .= $suf;
+ $aslocal = File::Spec->catfile($path, $name);
+ }
+ }
+
+ if (-f $aslocal && -r _ && !($force & 1)) {
+ my $size;
+ if ($size = -s $aslocal) {
+ $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
+ return $aslocal;
+ } else {
+ # empty file from a previous unsuccessful attempt to download it
+ unlink $aslocal or
+ $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
+ "could not remove.");
+ }
+ }
+ my($maybe_restore) = 0;
+ if (-f $aslocal) {
+ rename $aslocal, "$aslocal.bak$$";
+ $maybe_restore++;
+ }
+
+ my($aslocal_dir) = dirname($aslocal);
+ # Inheritance is not easier to manage than a few if/else branches
+ if ($CPAN::META->has_usable('LWP::UserAgent')) {
+ unless ($Ua) {
+ CPAN::LWP::UserAgent->config;
+ eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
+ if ($@) {
+ $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
+ if $CPAN::DEBUG;
+ } else {
+ my($var);
+ $Ua->proxy('ftp', $var)
+ if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
+ $Ua->proxy('http', $var)
+ if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
+ $Ua->no_proxy($var)
+ if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
+ }
+ }
+ }
+ for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
+ $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
+ }
+
+ # Try the list of urls for each single object. We keep a record
+ # where we did get a file from
+ my(@reordered,$last);
+ my $ccurllist = $self->_get_urllist($with_defaults);
+ $last = $#$ccurllist;
+ if ($force & 2) { # local cpans probably out of date, don't reorder
+ @reordered = (0..$last);
+ } else {
+ @reordered =
+ sort {
+ (substr($ccurllist->[$b],0,4) eq "file")
+ <=>
+ (substr($ccurllist->[$a],0,4) eq "file")
+ or
+ defined($ThesiteURL)
+ and
+ ($ccurllist->[$b] eq $ThesiteURL)
+ <=>
+ ($ccurllist->[$a] eq $ThesiteURL)
+ } 0..$last;
+ }
+ my(@levels);
+ $Themethod ||= "";
+ $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
+ my @all_levels = (
+ ["dleasy", "file"],
+ ["dleasy"],
+ ["dlhard"],
+ ["dlhardest"],
+ ["dleasy", "http","defaultsites"],
+ ["dlhard", "http","defaultsites"],
+ ["dleasy", "ftp", "defaultsites"],
+ ["dlhard", "ftp", "defaultsites"],
+ ["dlhardest","", "defaultsites"],
+ );
+ if ($Themethod) {
+ @levels = grep {$_->[0] eq $Themethod} @all_levels;
+ push @levels, grep {$_->[0] ne $Themethod} @all_levels;
+ } else {
+ @levels = @all_levels;
+ }
+ @levels = qw/dleasy/ if $^O eq 'MacOS';
+ my($levelno);
+ local $ENV{FTP_PASSIVE} =
+ exists $CPAN::Config->{ftp_passive} ?
+ $CPAN::Config->{ftp_passive} : 1;
+ my $ret;
+ my $stats = $self->_new_stats($file);
+ for ($CPAN::Config->{connect_to_internet_ok}) {
+ $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
+ }
+ LEVEL: for $levelno (0..$#levels) {
+ my $level_tuple = $levels[$levelno];
+ my($level,$scheme,$sitetag) = @$level_tuple;
+ $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
+ my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist;
+ my @urllist;
+ if ($defaultsites) {
+ unless (defined $connect_to_internet_ok) {
+ $CPAN::Frontend->myprint(sprintf qq{
+I would like to connect to one of the following sites to get '%s':
+
+%s
+},
+ $file,
+ join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
+ );
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
+ if ($answer =~ /^y/i) {
+ $connect_to_internet_ok = 1;
+ } else {
+ $connect_to_internet_ok = 0;
+ }
+ }
+ if ($connect_to_internet_ok) {
+ @urllist = @CPAN::Defaultsites;
+ } else {
+ my $sleep = 2;
+ # the tricky thing about dying here is that everybody
+ # believes that calls to exists() or all_objects() are
+ # safe.
+ require CPAN::Exception::blocked_urllist;
+ die CPAN::Exception::blocked_urllist->new;
+ }
+ } else { # ! $defaultsites
+ my @host_seq = $level =~ /dleasy/ ?
+ @reordered : 0..$last; # reordered has file and $Thesiteurl first
+ @urllist = map { $ccurllist->[$_] } @host_seq;
+ }
+ $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
+ my $aslocal_tempfile = $aslocal . ".tmp" . $$;
+ if (my $recommend = $self->_recommend_url_for($file,\@urllist)) {
+ @urllist = grep { $_ ne $recommend } @urllist;
+ unshift @urllist, $recommend;
+ }
+ $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
+ $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
+ if ($ret) {
+ CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
+ if ($ret eq $aslocal_tempfile) {
+ # if we got it exactly as we asked for, only then we
+ # want to rename
+ rename $aslocal_tempfile, $aslocal
+ or $CPAN::Frontend->mydie("Error while trying to rename ".
+ "'$ret' to '$aslocal': $!");
+ $ret = $aslocal;
+ }
+ elsif (-f $ret && $scheme eq 'file' ) {
+ # it's a local file, so there's nothing left to do, we
+ # let them read from where it is
+ }
+ $Themethod = $level;
+ my $now = time;
+ # utime $now, $now, $aslocal; # too bad, if we do that, we
+ # might alter a local mirror
+ $self->debug("level[$level]") if $CPAN::DEBUG;
+ last LEVEL;
+ } else {
+ unlink $aslocal_tempfile;
+ last if $CPAN::Signal; # need to cleanup
+ }
+ }
+ if ($ret) {
+ $stats->{filesize} = -s $ret;
+ }
+ $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
+ $self->_add_to_statistics($stats);
+ $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
+ if ($ret) {
+ unlink "$aslocal.bak$$";
+ return $ret;
+ }
+ unless ($CPAN::Signal) {
+ my(@mess);
+ local $" = " ";
+ if (@{$CPAN::Config->{urllist}}) {
+ push @mess,
+ qq{Please check, if the URLs I found in your configuration file \(}.
+ join(", ", @{$CPAN::Config->{urllist}}).
+ qq{\) are valid.};
+ } else {
+ push @mess, qq{Your urllist is empty!};
+ }
+ push @mess, qq{The urllist can be edited.},
+ qq{E.g. with 'o conf urllist push ftp://myurl/'};
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
+ $CPAN::Frontend->mydie("Could not fetch $file\n");
+ }
+ if ($maybe_restore) {
+ rename "$aslocal.bak$$", $aslocal;
+ $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
+ $self->ls($aslocal) . "\n");
+ return $aslocal;
+ }
+ return;
+}
+
+sub mymkpath {
+ my($self, $aslocal_dir) = @_;
+ mkpath($aslocal_dir);
+ $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
+ qq{directory "$aslocal_dir".
+ I\'ll continue, but if you encounter problems, they may be due
+ to insufficient permissions.\n}) unless -w $aslocal_dir;
+}
+
+sub hostdlxxx {
+ my $self = shift;
+ my $level = shift;
+ my $scheme = shift;
+ my $h = shift;
+ $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
+ my $method = "host$level";
+ $self->$method($h, @_);
+}
+
+sub _set_attempt {
+ my($self,$stats,$method,$url) = @_;
+ push @{$stats->{attempts}}, {
+ method => $method,
+ start => _mytime,
+ url => $url,
+ };
+}
+
+# package CPAN::FTP;
+sub hostdleasy { #called from hostdlxxx
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
+ my($ro_url);
+ HOSTEASY: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"dleasy",$ro_url);
+ my $url .= "$ro_url$file";
+ $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
+ if ($url =~ /^file:/) {
+ my $l;
+ if ($CPAN::META->has_inst('URI::URL')) {
+ my $u = URI::URL->new($url);
+ $l = $u->file;
+ } else { # works only on Unix, is poorly constructed, but
+ # hopefully better than nothing.
+ # RFC 1738 says fileurl BNF is
+ # fileurl = "file://" [ host | "localhost" ] "/" fpath
+ # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
+ # the code
+ ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
+ $l =~ s|^file:||; # assume they
+ # meant
+ # file://localhost
+ $l =~ s|^/||s
+ if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
+ }
+ $self->debug("local file[$l]") if $CPAN::DEBUG;
+ if ( -f $l && -r _) {
+ $ThesiteURL = $ro_url;
+ return $l;
+ }
+ # If request is for a compressed file and we can find the
+ # uncompressed file also, return the path of the uncompressed file
+ # otherwise, decompress it and return the resulting path
+ if ($l =~ /(.+)\.gz$/) {
+ my $ungz = $1;
+ if ( -f $ungz && -r _) {
+ $ThesiteURL = $ro_url;
+ return $ungz;
+ }
+ else {
+ eval { CPAN::Tarzip->new($l)->gunzip($aslocal) };
+ if ( -f $aslocal) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ else {
+ $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
+ if $@;
+ return;
+ }
+ }
+ }
+ # Otherwise, return the local file path if it exists
+ elsif ( -f $l && -r _) {
+ $ThesiteURL = $ro_url;
+ return $l;
+ }
+ # If we can't find it, but there is a compressed version
+ # of it, then decompress it
+ elsif (-f "$l.gz") {
+ $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
+ eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
+ if ( -f $aslocal) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ else {
+ $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
+ if $@;
+ return;
+ }
+ }
+ $CPAN::Frontend->mywarn("Could not find '$l'\n");
+ }
+ $self->debug("it was not a file URL") if $CPAN::DEBUG;
+ if ($CPAN::META->has_usable('LWP')) {
+ $CPAN::Frontend->myprint("Fetching with LWP:\n$url\n");
+ unless ($Ua) {
+ CPAN::LWP::UserAgent->config;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ }
+ my $res = $Ua->mirror($url, $aslocal);
+ if ($res->is_success) {
+ $ThesiteURL = $ro_url;
+ my $now = time;
+ utime $now, $now, $aslocal; # download time is more
+ # important than upload
+ # time
+ return $aslocal;
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
+ my $gzurl = "$url.gz";
+ $CPAN::Frontend->myprint("Fetching with LWP:\n$gzurl\n");
+ $res = $Ua->mirror($gzurl, "$aslocal.gz");
+ if ($res->is_success) {
+ if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ }
+ } else {
+ $CPAN::Frontend->myprint(sprintf(
+ "LWP failed with code[%s] message[%s]\n",
+ $res->code,
+ $res->message,
+ ));
+ # Alan Burlison informed me that in firewall environments
+ # Net::FTP can still succeed where LWP fails. So we do not
+ # skip Net::FTP anymore when LWP is available.
+ }
+ } else {
+ $CPAN::Frontend->mywarn(" LWP not available\n");
+ }
+ return if $CPAN::Signal;
+ if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # that's the nice and easy way thanks to Graham
+ $self->debug("recognized ftp") if $CPAN::DEBUG;
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ if ($CPAN::META->has_usable('Net::FTP')) {
+ $dir =~ s|/+|/|g;
+ $CPAN::Frontend->myprint("Fetching with Net::FTP:\n$url\n");
+ $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
+ "aslocal[$aslocal]") if $CPAN::DEBUG;
+ if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ if ($aslocal !~ /\.gz(?!\n)\Z/) {
+ my $gz = "$aslocal.gz";
+ $CPAN::Frontend->myprint("Fetching with Net::FTP\n$url.gz\n");
+ if (CPAN::FTP->ftp_get($host,
+ $dir,
+ "$getfile.gz",
+ $gz) &&
+ eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
+ ) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ }
+ # next HOSTEASY;
+ } else {
+ CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
+ }
+ }
+ if (
+ UNIVERSAL::can($ro_url,"text")
+ and
+ $ro_url->{FROM} eq "USER"
+ ) {
+ ##address #17973: default URLs should not try to override
+ ##user-defined URLs just because LWP is not available
+ my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
+ return $ret if $ret;
+ }
+ return if $CPAN::Signal;
+ }
+}
+
+# package CPAN::FTP;
+sub hostdlhard {
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
+
+ # Came back if Net::FTP couldn't establish connection (or
+ # failed otherwise) Maybe they are behind a firewall, but they
+ # gave us a socksified (or other) ftp program...
+
+ my($ro_url);
+ my($devnull) = $CPAN::Config->{devnull} || "";
+ # < /dev/null ";
+ my($aslocal_dir) = dirname($aslocal);
+ mkpath($aslocal_dir);
+ my $some_dl_success = 0;
+ my $any_attempt = 0;
+ HOSTHARD: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"dlhard",$ro_url);
+ my $url = "$ro_url$file";
+ my($proto,$host,$dir,$getfile);
+
+ # Courtesy Mark Conty mark_conty@cargill.com change from
+ # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # to
+ if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
+ # proto not yet used
+ ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
+ } else {
+ next HOSTHARD; # who said, we could ftp anything except ftp?
+ }
+ next HOSTHARD if $proto eq "file"; # file URLs would have had
+ # success above. Likely a bogus URL
+
+ # making at least one attempt against a host
+ $any_attempt++;
+
+ $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
+
+ # Try the most capable first and leave ncftp* for last as it only
+ # does FTP.
+ my $proxy_vars = $self->_proxy_vars($ro_url);
+ DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
+ my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
+ next DLPRG unless defined $funkyftp;
+ next DLPRG if $funkyftp =~ /^\s*$/;
+
+ my($src_switch) = "";
+ my($chdir) = "";
+ my($stdout_redir) = " > \"$aslocal\"";
+ if ($f eq "lynx") {
+ $src_switch = " -source";
+ } elsif ($f eq "ncftp") {
+ next DLPRG unless $url =~ m{\Aftp://};
+ $src_switch = " -c";
+ } elsif ($f eq "wget") {
+ $src_switch = " -O \"$aslocal\"";
+ $stdout_redir = "";
+ } elsif ($f eq 'curl') {
+ $src_switch = ' -L -f -s -S --netrc-optional';
+ if ($proxy_vars->{http_proxy}) {
+ $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
+ }
+ } elsif ($f eq "ncftpget") {
+ next DLPRG unless $url =~ m{\Aftp://};
+ $chdir = "cd $aslocal_dir && ";
+ $stdout_redir = "";
+ }
+ $CPAN::Frontend->myprint(
+ qq[
+Trying with
+ $funkyftp$src_switch
+to get
+ $url
+]);
+ my($system) =
+ "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
+ $self->debug("system[$system]") if $CPAN::DEBUG;
+ my($wstatus) = system($system);
+ if ($f eq "lynx") {
+ # lynx returns 0 when it fails somewhere
+ if (-s $aslocal) {
+ my $content = do { local *FH;
+ open FH, $aslocal or die;
+ local $/;
+ <FH> };
+ if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
+ $CPAN::Frontend->mywarn(qq{
+No success, the file that lynx has downloaded looks like an error message:
+$content
+});
+ $CPAN::Frontend->mysleep(1);
+ next DLPRG;
+ }
+ $some_dl_success++;
+ } else {
+ $CPAN::Frontend->myprint(qq{
+No success, the file that lynx has downloaded is an empty file.
+});
+ next DLPRG;
+ }
+ }
+ if ($wstatus == 0) {
+ if (-s $aslocal) {
+ # Looks good
+ $some_dl_success++;
+ }
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ my $estatus = $wstatus >> 8;
+ my $size = -f $aslocal ?
+ ", left\n$aslocal with size ".-s _ :
+ "\nWarning: expected file [$aslocal] doesn't exist";
+ $CPAN::Frontend->myprint(qq{
+ Function system("$system")
+ returned status $estatus (wstat $wstatus)$size
+ });
+ }
+ return if $CPAN::Signal;
+ } # download/transfer programs (DLPRG)
+ } # host
+ return unless $any_attempt;
+ if ($some_dl_success) {
+ $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n");
+ } else {
+ $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n");
+ }
+ return;
+}
+
+#-> CPAN::FTP::_proxy_vars
+sub _proxy_vars {
+ my($self,$url) = @_;
+ my $ret = +{};
+ my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ if ($http_proxy) {
+ my($host) = $url =~ m|://([^/:]+)|;
+ my $want_proxy = 1;
+ my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
+ my @noproxy = split /\s*,\s*/, $noproxy;
+ if ($host) {
+ DOMAIN: for my $domain (@noproxy) {
+ if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
+ $want_proxy = 0;
+ last DOMAIN;
+ }
+ }
+ } else {
+ $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n");
+ }
+ if ($want_proxy) {
+ my($user, $pass) =
+ &CPAN::LWP::UserAgent::get_proxy_credentials();
+ $ret = {
+ proxy_user => $user,
+ proxy_pass => $pass,
+ http_proxy => $http_proxy
+ };
+ }
+ }
+ return $ret;
+}
+
+# package CPAN::FTP;
+sub hostdlhardest {
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
+
+ return unless @$host_seq;
+ my($ro_url);
+ my($aslocal_dir) = dirname($aslocal);
+ mkpath($aslocal_dir);
+ my $ftpbin = $CPAN::Config->{ftp};
+ unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
+ $CPAN::Frontend->myprint("No external ftp command available\n\n");
+ return;
+ }
+ $CPAN::Frontend->mywarn(qq{
+As a last resort we now switch to the external ftp command '$ftpbin'
+to get '$aslocal'.
+
+Doing so often leads to problems that are hard to diagnose.
+
+If you're the victim of such problems, please consider unsetting the
+ftp config variable with
+
+ o conf ftp ""
+ o conf commit
+
+});
+ $CPAN::Frontend->mysleep(2);
+ HOSTHARDEST: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"dlhardest",$ro_url);
+ my $url = "$ro_url$file";
+ $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
+ unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ next;
+ }
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ my $timestamp = 0;
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
+ $ctime,$blksize,$blocks) = stat($aslocal);
+ $timestamp = $mtime ||= 0;
+ my($netrc) = CPAN::FTP::netrc->new;
+ my($netrcfile) = $netrc->netrc;
+ my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
+ my $targetfile = File::Basename::basename($aslocal);
+ my(@dialog);
+ push(
+ @dialog,
+ "lcd $aslocal_dir",
+ "cd /",
+ map("cd $_", split /\//, $dir), # RFC 1738
+ "bin",
+ "passive",
+ "get $getfile $targetfile",
+ "quit"
+ );
+ if (! $netrcfile) {
+ CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
+ } elsif ($netrc->hasdefault || $netrc->contains($host)) {
+ CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
+ $netrc->hasdefault,
+ $netrc->contains($host))) if $CPAN::DEBUG;
+ if ($netrc->protected) {
+ my $dialog = join "", map { " $_\n" } @dialog;
+ my $netrc_explain;
+ if ($netrc->contains($host)) {
+ $netrc_explain = "Relying that your .netrc entry for '$host' ".
+ "manages the login";
+ } else {
+ $netrc_explain = "Relying that your default .netrc entry ".
+ "manages the login";
+ }
+ $CPAN::Frontend->myprint(qq{
+ Trying with external ftp to get
+ '$url'
+ $netrc_explain
+ Going to send the dialog
+$dialog
+}
+ );
+ $self->talk_ftp("$ftpbin$verbose $host",
+ @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Hmm... Still failed!\n");
+ }
+ return if $CPAN::Signal;
+ } else {
+ $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
+ qq{correctly protected.\n});
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
+ nor does it have a default entry\n");
+ }
+
+ # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
+ # then and login manually to host, using e-mail as
+ # password.
+ $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
+ unshift(
+ @dialog,
+ "open $host",
+ "user anonymous $Config::Config{'cf_email'}"
+ );
+ my $dialog = join "", map { " $_\n" } @dialog;
+ $CPAN::Frontend->myprint(qq{
+ Trying with external ftp to get
+ $url
+ Going to send the dialog
+$dialog
+}
+ );
+ $self->talk_ftp("$ftpbin$verbose -n", @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
+ }
+ return if $CPAN::Signal;
+ $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
+ $CPAN::Frontend->mysleep(2);
+ } # host
+}
+
+# package CPAN::FTP;
+sub talk_ftp {
+ my($self,$command,@dialog) = @_;
+ my $fh = FileHandle->new;
+ $fh->open("|$command") or die "Couldn't open ftp: $!";
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close; # Wait for process to complete
+ my $wstatus = $?;
+ my $estatus = $wstatus >> 8;
+ $CPAN::Frontend->myprint(qq{
+Subprocess "|$command"
+ returned status $estatus (wstat $wstatus)
+}) if $wstatus;
+}
+
+# find2perl needs modularization, too, all the following is stolen
+# from there
+# CPAN::FTP::ls
+sub ls {
+ my($self,$name) = @_;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
+ $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
+
+ my($perms,%user,%group);
+ my $pname = $name;
+
+ if ($blocks) {
+ $blocks = int(($blocks + 1) / 2);
+ }
+ else {
+ $blocks = int(($sizemm + 1023) / 1024);
+ }
+
+ if (-f _) { $perms = '-'; }
+ elsif (-d _) { $perms = 'd'; }
+ elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
+ elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
+ elsif (-p _) { $perms = 'p'; }
+ elsif (-S _) { $perms = 's'; }
+ else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
+
+ my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
+ my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+ my $tmpmode = $mode;
+ my $tmp = $rwx[$tmpmode & 7];
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
+ substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
+ substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
+ $perms .= $tmp;
+
+ my $user = $user{$uid} || $uid; # too lazy to implement lookup
+ my $group = $group{$gid} || $gid;
+
+ my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
+ my($timeyear);
+ my($moname) = $moname[$mon];
+ if (-M _ > 365.25 / 2) {
+ $timeyear = $year + 1900;
+ }
+ else {
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
+ }
+
+ sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $sizemm,
+ $moname,
+ $mday,
+ $timeyear,
+ $pname;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/FTP/netrc.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/FTP/netrc.pm
new file mode 100755
index 00000000000..c05405e7ef6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/FTP/netrc.pm
@@ -0,0 +1,63 @@
+package CPAN::FTP::netrc;
+use strict;
+
+$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.00";
+
+# package CPAN::FTP::netrc;
+sub new {
+ my($class) = @_;
+ my $home = CPAN::HandleConfig::home();
+ my $file = File::Spec->catfile($home,".netrc");
+
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat($file);
+ $mode ||= 0;
+ my $protected = 0;
+
+ my($fh,@machines,$hasdefault);
+ $hasdefault = 0;
+ $fh = FileHandle->new or die "Could not create a filehandle";
+
+ if($fh->open($file)) {
+ $protected = ($mode & 077) == 0;
+ local($/) = "";
+ NETRC: while (<$fh>) {
+ my(@tokens) = split " ", $_;
+ TOKEN: while (@tokens) {
+ my($t) = shift @tokens;
+ if ($t eq "default") {
+ $hasdefault++;
+ last NETRC;
+ }
+ last TOKEN if $t eq "macdef";
+ if ($t eq "machine") {
+ push @machines, shift @tokens;
+ }
+ }
+ }
+ } else {
+ $file = $hasdefault = $protected = "";
+ }
+
+ bless {
+ 'mach' => [@machines],
+ 'netrc' => $file,
+ 'hasdefault' => $hasdefault,
+ 'protected' => $protected,
+ }, $class;
+}
+
+# CPAN::FTP::netrc::hasdefault;
+sub hasdefault { shift->{'hasdefault'} }
+sub netrc { shift->{'netrc'} }
+sub protected { shift->{'protected'} }
+sub contains {
+ my($self,$mach) = @_;
+ for ( @{$self->{'mach'}} ) {
+ return 1 if $_ eq $mach;
+ }
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/FirstTime.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/FirstTime.pm
new file mode 100755
index 00000000000..d1db0cdaf26
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/FirstTime.pm
@@ -0,0 +1,1797 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+package CPAN::FirstTime;
+use strict;
+
+use ExtUtils::MakeMaker ();
+use FileHandle ();
+use File::Basename ();
+use File::Path ();
+use File::Spec ();
+use CPAN::Mirrors ();
+use vars qw($VERSION $silent);
+$VERSION = "5.53";
+
+=head1 NAME
+
+CPAN::FirstTime - Utility for CPAN::Config file Initialization
+
+=head1 SYNOPSIS
+
+CPAN::FirstTime::init()
+
+=head1 DESCRIPTION
+
+The init routine asks a few questions and writes a CPAN/Config.pm or
+CPAN/MyConfig.pm file (depending on what it is currently using).
+
+In the following all questions and explanations regarding config
+variables are collected.
+
+=cut
+
+# down until the next =back the manpage must be parsed by the program
+# because the text is used in the init dialogues.
+
+my @podpara = split /\n\n/, <<'=back';
+
+=over 2
+
+=item auto_commit
+
+Normally CPAN.pm keeps config variables in memory and changes need to
+be saved in a separate 'o conf commit' command to make them permanent
+between sessions. If you set the 'auto_commit' option to true, changes
+to a config variable are always automatically committed to disk.
+
+Always commit changes to config variables to disk?
+
+=item build_cache
+
+CPAN.pm can limit the size of the disk area for keeping the build
+directories with all the intermediate files.
+
+Cache size for build directory (in MB)?
+
+=item build_dir
+
+Directory where the build process takes place?
+
+=item build_dir_reuse
+
+Until version 1.88 CPAN.pm never trusted the contents of the build_dir
+directory between sessions. Since 1.88_58 CPAN.pm has a YAML-based
+mechanism that makes it possible to share the contents of the
+build_dir/ directory between different sessions with the same version
+of perl. People who prefer to test things several days before
+installing will like this feature because it safes a lot of time.
+
+If you say yes to the following question, CPAN will try to store
+enough information about the build process so that it can pick up in
+future sessions at the same state of affairs as it left a previous
+session.
+
+Store and re-use state information about distributions between
+CPAN.pm sessions?
+
+=item build_requires_install_policy
+
+When a module declares another one as a 'build_requires' prerequisite
+this means that the other module is only needed for building or
+testing the module but need not be installed permanently. In this case
+you may wish to install that other module nonetheless or just keep it
+in the 'build_dir' directory to have it available only temporarily.
+Installing saves time on future installations but makes the perl
+installation bigger.
+
+You can choose if you want to always install (yes), never install (no)
+or be always asked. In the latter case you can set the default answer
+for the question to yes (ask/yes) or no (ask/no).
+
+Policy on installing 'build_requires' modules (yes, no, ask/yes,
+ask/no)?
+
+=item cache_metadata
+
+To considerably speed up the initial CPAN shell startup, it is
+possible to use Storable to create a cache of metadata. If Storable is
+not available, the normal index mechanism will be used.
+
+Note: this mechanism is not used when use_sqlite is on and SQLLite is
+running.
+
+Cache metadata (yes/no)?
+
+=item check_sigs
+
+CPAN packages can be digitally signed by authors and thus verified
+with the security provided by strong cryptography. The exact mechanism
+is defined in the Module::Signature module. While this is generally
+considered a good thing, it is not always convenient to the end user
+to install modules that are signed incorrectly or where the key of the
+author is not available or where some prerequisite for
+Module::Signature has a bug and so on.
+
+With the check_sigs parameter you can turn signature checking on and
+off. The default is off for now because the whole tool chain for the
+functionality is not yet considered mature by some. The author of
+CPAN.pm would recommend setting it to true most of the time and
+turning it off only if it turns out to be annoying.
+
+Note that if you do not have Module::Signature installed, no signature
+checks will be performed at all.
+
+Always try to check and verify signatures if a SIGNATURE file is in
+the package and Module::Signature is installed (yes/no)?
+
+=item colorize_output
+
+When you have Term::ANSIColor installed, you can turn on colorized
+output to have some visual differences between normal CPAN.pm output,
+warnings, debugging output, and the output of the modules being
+installed. Set your favorite colors after some experimenting with the
+Term::ANSIColor module.
+
+Do you want to turn on colored output?
+
+=item colorize_print
+
+Color for normal output?
+
+=item colorize_warn
+
+Color for warnings?
+
+=item colorize_debug
+
+Color for debugging messages?
+
+=item commandnumber_in_prompt
+
+The prompt of the cpan shell can contain the current command number
+for easier tracking of the session or be a plain string.
+
+Do you want the command number in the prompt (yes/no)?
+
+=item connect_to_internet_ok
+
+If you have never defined your own C<urllist> in your configuration
+then C<CPAN.pm> will be hesitant to use the built in default sites for
+downloading. It will ask you once per session if a connection to the
+internet is OK and only if you say yes, it will try to connect. But to
+avoid this question, you can choose your favorite download sites once
+and get away with it. Or, if you have no favorite download sites
+answer yes to the following question.
+
+If no urllist has been chosen yet, would you prefer CPAN.pm to connect
+to the built-in default sites without asking? (yes/no)?
+
+=item ftp_passive
+
+Shall we always set the FTP_PASSIVE environment variable when dealing
+with ftp download (yes/no)?
+
+=item ftpstats_period
+
+Statistics about downloads are truncated by size and period
+simultaneously.
+
+How many days shall we keep statistics about downloads?
+
+=item ftpstats_size
+
+Statistics about downloads are truncated by size and period
+simultaneously.
+
+How many items shall we keep in the statistics about downloads?
+
+=item getcwd
+
+CPAN.pm changes the current working directory often and needs to
+determine its own current working directory. Per default it uses
+Cwd::cwd but if this doesn't work on your system for some reason,
+alternatives can be configured according to the following table:
+
+ cwd Cwd::cwd
+ getcwd Cwd::getcwd
+ fastcwd Cwd::fastcwd
+ backtickcwd external command cwd
+
+Preferred method for determining the current working directory?
+
+=item halt_on_failure
+
+Normaly, CPAN.pm continues processing the full list of targets and
+dependencies, even if one of them fails. However, you can specify
+that CPAN should halt after the first failure.
+
+Do you want to halt on failure (yes/no)?
+
+=item histfile
+
+If you have one of the readline packages (Term::ReadLine::Perl,
+Term::ReadLine::Gnu, possibly others) installed, the interactive CPAN
+shell will have history support. The next two questions deal with the
+filename of the history file and with its size. If you do not want to
+set this variable, please hit SPACE RETURN to the following question.
+
+File to save your history?
+
+=item histsize
+
+Number of lines to save?
+
+=item inactivity_timeout
+
+Sometimes you may wish to leave the processes run by CPAN alone
+without caring about them. Because the Makefile.PL or the Build.PL
+sometimes contains question you're expected to answer, you can set a
+timer that will kill a 'perl Makefile.PL' process after the specified
+time in seconds.
+
+If you set this value to 0, these processes will wait forever. This is
+the default and recommended setting.
+
+Timeout for inactivity during {Makefile,Build}.PL?
+
+=item index_expire
+
+The CPAN indexes are usually rebuilt once or twice per hour, but the
+typical CPAN mirror mirrors only once or twice per day. Depending on
+the quality of your mirror and your desire to be on the bleeding edge,
+you may want to set the following value to more or less than one day
+(which is the default). It determines after how many days CPAN.pm
+downloads new indexes.
+
+Let the index expire after how many days?
+
+=item inhibit_startup_message
+
+When the CPAN shell is started it normally displays a greeting message
+that contains the running version and the status of readline support.
+
+Do you want to turn this message off?
+
+=item keep_source_where
+
+Unless you are accessing the CPAN on your filesystem via a file: URL,
+CPAN.pm needs to keep the source files it downloads somewhere. Please
+supply a directory where the downloaded files are to be kept.
+
+Download target directory?
+
+=item load_module_verbosity
+
+When CPAN.pm loads a module it needs for some optional feature, it
+usually reports about module name and version. Choose 'v' to get this
+message, 'none' to suppress it.
+
+Verbosity level for loading modules (none or v)?
+
+=item makepl_arg
+
+Every Makefile.PL is run by perl in a separate process. Likewise we
+run 'make' and 'make install' in separate processes. If you have
+any parameters (e.g. PREFIX, UNINST or the like) you want to
+pass to the calls, please specify them here.
+
+If you don't understand this question, just press ENTER.
+
+Typical frequently used settings:
+
+ PREFIX=~/perl # non-root users (please see manual for more hints)
+
+Parameters for the 'perl Makefile.PL' command?
+
+=item make_arg
+
+Parameters for the 'make' command? Typical frequently used setting:
+
+ -j3 # dual processor system (on GNU make)
+
+Your choice:
+
+=item make_install_arg
+
+Parameters for the 'make install' command?
+Typical frequently used setting:
+
+ UNINST=1 # to always uninstall potentially conflicting files
+
+Your choice:
+
+=item make_install_make_command
+
+Do you want to use a different make command for 'make install'?
+Cautious people will probably prefer:
+
+ su root -c make
+ or
+ sudo make
+ or
+ /path1/to/sudo -u admin_account /path2/to/make
+
+or some such. Your choice:
+
+=item mbuildpl_arg
+
+A Build.PL is run by perl in a separate process. Likewise we run
+'./Build' and './Build install' in separate processes. If you have any
+parameters you want to pass to the calls, please specify them here.
+
+Typical frequently used settings:
+
+ --install_base /home/xxx # different installation directory
+
+Parameters for the 'perl Build.PL' command?
+
+=item mbuild_arg
+
+Parameters for the './Build' command? Setting might be:
+
+ --extra_linker_flags -L/usr/foo/lib # non-standard library location
+
+Your choice:
+
+=item mbuild_install_arg
+
+Parameters for the './Build install' command? Typical frequently used
+setting:
+
+ --uninst 1 # uninstall conflicting files
+
+Your choice:
+
+=item mbuild_install_build_command
+
+Do you want to use a different command for './Build install'? Sudo
+users will probably prefer:
+
+ su root -c ./Build
+ or
+ sudo ./Build
+ or
+ /path1/to/sudo -u admin_account ./Build
+
+or some such. Your choice:
+
+=item pager
+
+What is your favorite pager program?
+
+=item prefer_installer
+
+When you have Module::Build installed and a module comes with both a
+Makefile.PL and a Build.PL, which shall have precedence?
+
+The main two standard installer modules are the old and well
+established ExtUtils::MakeMaker (for short: EUMM) which uses the
+Makefile.PL. And the next generation installer Module::Build (MB)
+which works with the Build.PL (and often comes with a Makefile.PL
+too). If a module comes only with one of the two we will use that one
+but if both are supplied then a decision must be made between EUMM and
+MB. See also http://rt.cpan.org/Ticket/Display.html?id=29235 for a
+discussion about the right default.
+
+Or, as a third option you can choose RAND which will make a random
+decision (something regular CPAN testers will enjoy).
+
+In case you can choose between running a Makefile.PL or a Build.PL,
+which installer would you prefer (EUMM or MB or RAND)?
+
+=item prefs_dir
+
+CPAN.pm can store customized build environments based on regular
+expressions for distribution names. These are YAML files where the
+default options for CPAN.pm and the environment can be overridden and
+dialog sequences can be stored that can later be executed by an
+Expect.pm object. The CPAN.pm distribution comes with some prefab YAML
+files that cover sample distributions that can be used as blueprints
+to store one own prefs. Please check out the distroprefs/ directory of
+the CPAN.pm distribution to get a quick start into the prefs system.
+
+Directory where to store default options/environment/dialogs for
+building modules that need some customization?
+
+=item prerequisites_policy
+
+The CPAN module can detect when a module which you are trying to build
+depends on prerequisites. If this happens, it can build the
+prerequisites for you automatically ('follow'), ask you for
+confirmation ('ask'), or just ignore them ('ignore'). Please set your
+policy to one of the three values.
+
+Policy on building prerequisites (follow, ask or ignore)?
+
+=item randomize_urllist
+
+CPAN.pm can introduce some randomness when using hosts for download
+that are configured in the urllist parameter. Enter a numeric value
+between 0 and 1 to indicate how often you want to let CPAN.pm try a
+random host from the urllist. A value of one specifies to always use a
+random host as the first try. A value of zero means no randomness at
+all. Anything in between specifies how often, on average, a random
+host should be tried first.
+
+Randomize parameter
+
+=item scan_cache
+
+By default, each time the CPAN module is started, cache scanning is
+performed to keep the cache size in sync. To prevent this, answer
+'never'.
+
+Perform cache scanning (atstart or never)?
+
+=item shell
+
+What is your favorite shell?
+
+=item show_unparsable_versions
+
+During the 'r' command CPAN.pm finds modules without version number.
+When the command finishes, it prints a report about this. If you
+want this report to be very verbose, say yes to the following
+variable.
+
+Show all individual modules that have no $VERSION?
+
+=item show_upload_date
+
+The 'd' and the 'm' command normally only show you information they
+have in their in-memory database and thus will never connect to the
+internet. If you set the 'show_upload_date' variable to true, 'm' and
+'d' will additionally show you the upload date of the module or
+distribution. Per default this feature is off because it may require a
+net connection to get at the upload date.
+
+Always try to show upload date with 'd' and 'm' command (yes/no)?
+
+=item show_zero_versions
+
+During the 'r' command CPAN.pm finds modules with a version number of
+zero. When the command finishes, it prints a report about this. If you
+want this report to be very verbose, say yes to the following
+variable.
+
+Show all individual modules that have a $VERSION of zero?
+
+=item tar_verbosity
+
+When CPAN.pm uses the tar command, which switch for the verbosity
+shall be used? Choose 'none' for quiet operation, 'v' for file
+name listing, 'vv' for full listing.
+
+Tar command verbosity level (none or v or vv)?
+
+=item term_is_latin
+
+The next option deals with the charset (aka character set) your
+terminal supports. In general, CPAN is English speaking territory, so
+the charset does not matter much but some CPAN have names that are
+outside the ASCII range. If your terminal supports UTF-8, you should
+say no to the next question. If it expects ISO-8859-1 (also known as
+LATIN1) then you should say yes. If it supports neither, your answer
+does not matter because you will not be able to read the names of some
+authors anyway. If you answer no, names will be output in UTF-8.
+
+Your terminal expects ISO-8859-1 (yes/no)?
+
+=item term_ornaments
+
+When using Term::ReadLine, you can turn ornaments on so that your
+input stands out against the output from CPAN.pm.
+
+Do you want to turn ornaments on?
+
+=item test_report
+
+The goal of the CPAN Testers project (http://testers.cpan.org/) is to
+test as many CPAN packages as possible on as many platforms as
+possible. This provides valuable feedback to module authors and
+potential users to identify bugs or platform compatibility issues and
+improves the overall quality and value of CPAN.
+
+One way you can contribute is to send test results for each module
+that you install. If you install the CPAN::Reporter module, you have
+the option to automatically generate and email test reports to CPAN
+Testers whenever you run tests on a CPAN package.
+
+See the CPAN::Reporter documentation for additional details and
+configuration settings. If your firewall blocks outgoing email,
+you will need to configure CPAN::Reporter before sending reports.
+
+Email test reports if CPAN::Reporter is installed (yes/no)?
+
+=item perl5lib_verbosity
+
+When CPAN.pm extends @INC via PERL5LIB, it prints a list of
+directories added (or a summary of how many directories are
+added). Choose 'v' to get this message, 'none' to suppress it.
+
+Verbosity level for PERL5LIB changes (none or v)?
+
+=item trust_test_report_history
+
+When a distribution has already been tested by CPAN::Reporter on
+this machine, CPAN can skip the test phase and just rely on the
+test report history instead.
+
+Note that this will not apply to distributions that failed tests
+because of missing dependencies. Also, tests can be run
+regardless of the history using "force".
+
+Do you want to rely on the test report history (yes/no)?
+
+=item use_sqlite
+
+CPAN::SQLite is a layer between the index files that are downloaded
+from the CPAN and CPAN.pm that speeds up metadata queries and reduces
+memory consumption of CPAN.pm considerably.
+
+Use CPAN::SQLite if available? (yes/no)?
+
+=item version_timeout
+
+This timeout prevents CPAN from hanging when trying to parse a
+pathologically coded $VERSION from a module.
+
+The default is 15 seconds. If you set this value to 0, no timeout
+will occur, but this is not recommended.
+
+Timeout for parsing module versions?
+
+=item yaml_load_code
+
+Both YAML.pm and YAML::Syck are capable of deserialising code. As this
+requires a string eval, which might be a security risk, you can use
+this option to enable or disable the deserialisation of code via
+CPAN::DeferredCode. (Note: This does not work under perl 5.6)
+
+Do you want to enable code deserialisation (yes/no)?
+
+=item yaml_module
+
+At the time of this writing (2009-03) there are three YAML
+implementations working: YAML, YAML::Syck, and YAML::XS. The latter
+two are faster but need a C compiler installed on your system. There
+may be more alternative YAML conforming modules. When I tried two
+other players, YAML::Tiny and YAML::Perl, they seemed not powerful
+enough to work with CPAN.pm. This may have changed in the meantime.
+
+Which YAML implementation would you prefer?
+
+=back
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+use vars qw( %prompts );
+
+{
+
+ my @prompts = (
+
+manual_config => qq[
+CPAN is the world-wide archive of perl resources. It consists of about
+300 sites that all replicate the same contents around the globe. Many
+countries have at least one CPAN site already. The resources found on
+CPAN are easily accessible with the CPAN.pm module. If you want to use
+CPAN.pm, lots of things have to be configured. Fortunately, most of
+them can be determined automatically. If you prefer the automatic
+configuration, answer 'yes' below.
+
+If you prefer to enter a dialog instead, you can answer 'no' to this
+question and I'll let you configure in small steps one thing after the
+other. (Note: you can revisit this dialog anytime later by typing 'o
+conf init' at the cpan prompt.)
+
+],
+
+auto_pick => qq{
+Would you like me to automatically choose the best CPAN mirror
+sites for you? (This means connecting to the Internet and could
+take a couple minutes)},
+
+config_intro => qq{
+
+The following questions are intended to help you with the
+configuration. The CPAN module needs a directory of its own to cache
+important index files and maybe keep a temporary mirror of CPAN files.
+This may be a site-wide or a personal directory.
+
+},
+
+# cpan_home => qq{ },
+
+cpan_home_where => qq{
+
+First of all, I'd like to create this directory. Where?
+
+},
+
+external_progs => qq{
+
+The CPAN module will need a few external programs to work properly.
+Please correct me, if I guess the wrong path for a program. Don't
+panic if you do not have some of them, just press ENTER for those. To
+disable the use of a program, you can type a space followed by ENTER.
+
+},
+
+proxy_intro => qq{
+
+If you're accessing the net via proxies, you can specify them in the
+CPAN configuration or via environment variables. The variable in
+the \$CPAN::Config takes precedence.
+
+},
+
+proxy_user => qq{
+
+If your proxy is an authenticating proxy, you can store your username
+permanently. If you do not want that, just press RETURN. You will then
+be asked for your username in every future session.
+
+},
+
+proxy_pass => qq{
+
+Your password for the authenticating proxy can also be stored
+permanently on disk. If this violates your security policy, just press
+RETURN. You will then be asked for the password in every future
+session.
+
+},
+
+urls_intro => qq{
+Now you need to choose your CPAN mirror sites. You can let me
+pick mirrors for you, you can select them from a list or you
+can enter them by hand.
+},
+
+urls_picker_intro => qq{First, pick a nearby continent and country by typing in the number(s)
+in front of the item(s) you want to select. You can pick several of
+each, separated by spaces. Then, you will be presented with a list of
+URLs of CPAN mirrors in the countries you selected, along with
+previously selected URLs. Select some of those URLs, or just keep the
+old list. Finally, you will be prompted for any extra URLs -- file:,
+ftp:, or http: -- that host a CPAN mirror.
+
+You should select more than one (just in case the first isn't available).
+
+},
+
+password_warn => qq{
+
+Warning: Term::ReadKey seems not to be available, your password will
+be echoed to the terminal!
+
+},
+
+ );
+
+ die "Coding error in \@prompts declaration. Odd number of elements, above"
+ if (@prompts % 2);
+
+ %prompts = @prompts;
+
+ if (scalar(keys %prompts) != scalar(@prompts)/2) {
+ my %already;
+ for my $item (0..$#prompts) {
+ next if $item % 2;
+ die "$prompts[$item] is duplicated\n" if $already{$prompts[$item]}++;
+ }
+ }
+
+ shift @podpara;
+ while (@podpara) {
+ warn "Alert: cannot parse my own manpage for init dialog" unless $podpara[0] =~ s/^=item\s+//;
+ my $name = shift @podpara;
+ my @para;
+ while (@podpara && $podpara[0] !~ /^=item/) {
+ push @para, shift @podpara;
+ }
+ $prompts{$name} = pop @para;
+ if (@para) {
+ $prompts{$name . "_intro"} = join "", map { "$_\n\n" } @para;
+ }
+ }
+
+}
+
+sub init {
+ my($configpm, %args) = @_;
+ use Config;
+ # extra args after 'o conf init'
+ my $matcher = $args{args} && @{$args{args}} ? $args{args}[0] : '';
+ if ($matcher =~ /^\/(.*)\/$/) {
+ # case /regex/ => take the first, ignore the rest
+ $matcher = $1;
+ shift @{$args{args}};
+ if (@{$args{args}}) {
+ local $" = " ";
+ $CPAN::Frontend->mywarn("Ignoring excessive arguments '@{$args{args}}'");
+ $CPAN::Frontend->mysleep(2);
+ }
+ } elsif (0 == length $matcher) {
+ } elsif (0 && $matcher eq "~") { # extremely buggy, but a nice idea
+ my @unconfigured = grep { not exists $CPAN::Config->{$_}
+ or not defined $CPAN::Config->{$_}
+ or not length $CPAN::Config->{$_}
+ } keys %$CPAN::Config;
+ $matcher = "\\b(".join("|", @unconfigured).")\\b";
+ $CPAN::Frontend->mywarn("matcher[$matcher]");
+ } else {
+ # case WORD... => all arguments must be valid
+ for my $arg (@{$args{args}}) {
+ unless (exists $CPAN::HandleConfig::keys{$arg}) {
+ $CPAN::Frontend->mywarn("'$arg' is not a valid configuration variable\n");
+ return;
+ }
+ }
+ $matcher = "\\b(".join("|",@{$args{args}}).")\\b";
+ }
+ CPAN->debug("matcher[$matcher]") if $CPAN::DEBUG;
+
+ unless ($CPAN::VERSION) {
+ require CPAN::Nox;
+ }
+ require CPAN::HandleConfig;
+ CPAN::HandleConfig::require_myconfig_or_config();
+ $CPAN::Config ||= {};
+ local($/) = "\n";
+ local($\) = "";
+ local($|) = 1;
+
+ my($ans,$default); # why so half global?
+
+ #
+ #= Files, directories
+ #
+
+ unless ($matcher) {
+ $CPAN::Frontend->myprint($prompts{manual_config});
+ }
+
+ my $manual_conf;
+
+ local *_real_prompt;
+ if ( $args{autoconfig} ) {
+ $manual_conf = "no";
+ } elsif ($matcher) {
+ $manual_conf = "yes";
+ } else {
+ my $_conf = prompt("Would you like me to configure as much as possible ".
+ "automatically?", "yes");
+ $manual_conf = ($_conf and $_conf =~ /^y/i) ? "no" : "yes";
+ }
+ CPAN->debug("manual_conf[$manual_conf]") if $CPAN::DEBUG;
+ my $fastread;
+ {
+ if ($manual_conf =~ /^y/i) {
+ $fastread = 0;
+ } else {
+ $fastread = 1;
+ $silent = 1;
+ $CPAN::Config->{urllist} ||= [];
+ $CPAN::Config->{connect_to_internet_ok} ||= 1;
+
+ local $^W = 0;
+ # prototype should match that of &MakeMaker::prompt
+ my $current_second = time;
+ my $current_second_count = 0;
+ my $i_am_mad = 0;
+ # silent prompting -- just quietly use default
+ *_real_prompt = sub { return $_[1] };
+ }
+ }
+
+ if (!$matcher or q{
+ build_dir
+ build_dir_reuse
+ cpan_home
+ keep_source_where
+ prefs_dir
+ } =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{config_intro}) unless $silent;
+
+ init_cpan_home($matcher);
+
+ my_dflt_prompt("keep_source_where",
+ File::Spec->catdir($CPAN::Config->{cpan_home},"sources"),
+ $matcher,
+ );
+ my_dflt_prompt("build_dir",
+ File::Spec->catdir($CPAN::Config->{cpan_home},"build"),
+ $matcher
+ );
+ my_yn_prompt(build_dir_reuse => 0, $matcher);
+ my_dflt_prompt("prefs_dir",
+ File::Spec->catdir($CPAN::Config->{cpan_home},"prefs"),
+ $matcher
+ );
+ }
+
+ #
+ #= Config: auto_commit
+ #
+
+ my_yn_prompt(auto_commit => 0, $matcher);
+
+ #
+ #= Cache size, Index expire
+ #
+ my_dflt_prompt(build_cache => 100, $matcher);
+
+ my_dflt_prompt(index_expire => 1, $matcher);
+ my_prompt_loop(scan_cache => 'atstart', $matcher, 'atstart|never');
+
+ #
+ #= cache_metadata
+ #
+
+ my_yn_prompt(cache_metadata => 1, $matcher);
+ my_yn_prompt(use_sqlite => 0, $matcher);
+
+ #
+ #= Do we follow PREREQ_PM?
+ #
+
+ my_prompt_loop(prerequisites_policy => 'ask', $matcher,
+ 'follow|ask|ignore');
+ my_prompt_loop(build_requires_install_policy => 'ask/yes', $matcher,
+ 'yes|no|ask/yes|ask/no');
+
+ #
+ #= Module::Signature
+ #
+ my_yn_prompt(check_sigs => 0, $matcher);
+
+ #
+ #= CPAN::Reporter
+ #
+ if (!$matcher or 'test_report' =~ /$matcher/) {
+ my_yn_prompt(test_report => 0, $matcher);
+ if (
+ $CPAN::Config->{test_report} &&
+ $CPAN::META->has_inst("CPAN::Reporter") &&
+ CPAN::Reporter->can('configure')
+ ) {
+ local *_real_prompt;
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ my $_conf = prompt("Would you like me configure CPAN::Reporter now?", $silent ? "no" : "yes");
+ if ($_conf =~ /^y/i) {
+ $CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n");
+ CPAN::Reporter::configure();
+ $CPAN::Frontend->myprint("\nReturning to CPAN configuration.\n");
+ }
+ }
+ }
+
+ my_yn_prompt(trust_test_report_history => 0, $matcher);
+
+ #
+ #= YAML vs. YAML::Syck
+ #
+ if (!$matcher or "yaml_module" =~ /$matcher/) {
+ my_dflt_prompt(yaml_module => "YAML", $matcher);
+ my $old_v = $CPAN::Config->{load_module_verbosity};
+ $CPAN::Config->{load_module_verbosity} = q[none];
+ unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module})) {
+ $CPAN::Frontend->mywarn
+ ("Warning (maybe harmless): '$CPAN::Config->{yaml_module}' not installed.\n");
+ $CPAN::Frontend->mysleep(3);
+ }
+ $CPAN::Config->{load_module_verbosity} = $old_v;
+ }
+
+ #
+ #= YAML code deserialisation
+ #
+ my_yn_prompt(yaml_load_code => 0, $matcher);
+
+ #
+ #= External programs
+ #
+ my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
+ _init_external_progs($matcher,\@path);
+
+ {
+ my $path = $CPAN::Config->{'pager'} ||
+ $ENV{PAGER} || find_exe("less",\@path) ||
+ find_exe("more",\@path) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 )
+ || "more";
+ my_dflt_prompt(pager => $path, $matcher);
+ }
+
+ {
+ my $path = $CPAN::Config->{'shell'};
+ if ($path && File::Spec->file_name_is_absolute($path)) {
+ $CPAN::Frontend->mywarn("Warning: configured $path does not exist\n")
+ unless -e $path;
+ $path = "";
+ }
+ $path ||= $ENV{SHELL};
+ $path ||= $ENV{COMSPEC} if $^O eq "MSWin32";
+ if ($^O eq 'MacOS') {
+ $CPAN::Config->{'shell'} = 'not_here';
+ } else {
+ $path ||= 'sh', $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only
+ my_dflt_prompt(shell => $path, $matcher);
+ }
+ }
+
+ #
+ # verbosity
+ #
+
+ my_prompt_loop(tar_verbosity => 'v', $matcher,
+ 'none|v|vv');
+ my_prompt_loop(load_module_verbosity => 'none', $matcher,
+ 'none|v');
+ my_prompt_loop(perl5lib_verbosity => 'v', $matcher,
+ 'none|v');
+ my_yn_prompt(inhibit_startup_message => 0, $matcher);
+
+ #
+ #= Installer, arguments to make etc.
+ #
+
+ my_prompt_loop(prefer_installer => 'MB', $matcher, 'MB|EUMM|RAND');
+
+ if (!$matcher or 'makepl_arg make_arg' =~ /$matcher/) {
+ my_dflt_prompt(makepl_arg => "", $matcher);
+ my_dflt_prompt(make_arg => "", $matcher);
+ if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) {
+ $CPAN::Frontend->mywarn(
+ "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
+ "that specify their own LIBS or INC options in Makefile.PL.\n"
+ );
+ }
+
+ }
+
+ require CPAN::HandleConfig;
+ if (exists $CPAN::HandleConfig::keys{make_install_make_command}) {
+ # as long as Windows needs $self->_build_command, we cannot
+ # support sudo on windows :-)
+ my_dflt_prompt(make_install_make_command => $CPAN::Config->{make} || "",
+ $matcher);
+ }
+
+ my_dflt_prompt(make_install_arg => $CPAN::Config->{make_arg} || "",
+ $matcher);
+
+ my_dflt_prompt(mbuildpl_arg => "", $matcher);
+ my_dflt_prompt(mbuild_arg => "", $matcher);
+
+ if (exists $CPAN::HandleConfig::keys{mbuild_install_build_command}
+ and $^O ne "MSWin32") {
+ # as long as Windows needs $self->_build_command, we cannot
+ # support sudo on windows :-)
+ my_dflt_prompt(mbuild_install_build_command => "./Build", $matcher);
+ }
+
+ my_dflt_prompt(mbuild_install_arg => "", $matcher);
+
+ #
+ #= Alarm period
+ #
+
+ my_dflt_prompt(inactivity_timeout => 0, $matcher);
+ my_dflt_prompt(version_timeout => 15, $matcher);
+
+ #
+ #== halt_on_failure
+ #
+ my_yn_prompt(halt_on_failure => 0, $matcher);
+
+ #
+ #= Proxies
+ #
+
+ my @proxy_vars = qw/ftp_proxy http_proxy no_proxy/;
+ my @proxy_user_vars = qw/proxy_user proxy_pass/;
+ if (!$matcher or "@proxy_vars @proxy_user_vars" =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{proxy_intro}) unless $silent;
+
+ for (@proxy_vars) {
+ $prompts{$_} = "Your $_?";
+ my_dflt_prompt($_ => $ENV{$_}||"", $matcher);
+ }
+
+ if ($CPAN::Config->{ftp_proxy} ||
+ $CPAN::Config->{http_proxy}) {
+
+ $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER || "";
+
+ $CPAN::Frontend->myprint($prompts{proxy_user}) unless $silent;
+
+ if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) {
+ $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $silent;
+
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("noecho");
+ } else {
+ $CPAN::Frontend->myprint($prompts{password_warn}) unless $silent;
+ }
+ $CPAN::Config->{proxy_pass} = prompt_no_strip("Your proxy password?");
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("restore");
+ }
+ $CPAN::Frontend->myprint("\n\n") unless $silent;
+ }
+ }
+ }
+
+ #
+ #= how FTP works
+ #
+
+ my_yn_prompt(ftp_passive => 1, $matcher);
+
+ #
+ #= how cwd works
+ #
+
+ my_prompt_loop(getcwd => 'cwd', $matcher,
+ 'cwd|getcwd|fastcwd|backtickcwd');
+
+ #
+ #= the CPAN shell itself (prompt, color)
+ #
+
+ my_yn_prompt(commandnumber_in_prompt => 1, $matcher);
+ my_yn_prompt(term_ornaments => 1, $matcher);
+ if ("colorize_output colorize_print colorize_warn colorize_debug" =~ $matcher) {
+ my_yn_prompt(colorize_output => 0, $matcher);
+ if ($CPAN::Config->{colorize_output}) {
+ if ($CPAN::META->has_inst("Term::ANSIColor")) {
+ my $T="gYw";
+ $CPAN::Frontend->myprint( " on_ on_y ".
+ " on_ma on_\n") unless $silent;
+ $CPAN::Frontend->myprint( " on_black on_red green ellow ".
+ "on_blue genta on_cyan white\n") unless $silent;
+
+ for my $FG ("", "bold",
+ map {$_,"bold $_"} "black","red","green",
+ "yellow","blue",
+ "magenta",
+ "cyan","white") {
+ $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $silent;
+ for my $BG ("",map {"on_$_"} qw(black red green yellow
+ blue magenta cyan white)) {
+ $CPAN::Frontend->myprint( $FG||$BG ?
+ Term::ANSIColor::colored(" $T ","$FG $BG") : " $T ") unless $silent;
+ }
+ $CPAN::Frontend->myprint( "\n" ) unless $silent;
+ }
+ $CPAN::Frontend->myprint( "\n" ) unless $silent;
+ }
+ for my $tuple (
+ ["colorize_print", "bold blue on_white"],
+ ["colorize_warn", "bold red on_white"],
+ ["colorize_debug", "black on_cyan"],
+ ) {
+ my_dflt_prompt($tuple->[0] => $tuple->[1], $matcher);
+ if ($CPAN::META->has_inst("Term::ANSIColor")) {
+ eval { Term::ANSIColor::color($CPAN::Config->{$tuple->[0]})};
+ if ($@) {
+ $CPAN::Config->{$tuple->[0]} = $tuple->[1];
+ $CPAN::Frontend->mywarn($@."setting to default '$tuple->[1]'\n");
+ }
+ }
+ }
+ }
+ }
+
+ #
+ #== term_is_latin
+ #
+
+ my_yn_prompt(term_is_latin => 1, $matcher);
+
+ #
+ #== save history in file 'histfile'
+ #
+
+ if (!$matcher or 'histfile histsize' =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{histfile_intro}) unless $silent;
+ defined($default = $CPAN::Config->{histfile}) or
+ $default = File::Spec->catfile($CPAN::Config->{cpan_home},"histfile");
+ my_dflt_prompt(histfile => $default, $matcher);
+
+ if ($CPAN::Config->{histfile}) {
+ defined($default = $CPAN::Config->{histsize}) or $default = 100;
+ my_dflt_prompt(histsize => $default, $matcher);
+ }
+ }
+
+ #
+ #== do an ls on the m or the d command
+ #
+ my_yn_prompt(show_upload_date => 0, $matcher);
+
+ #
+ #== verbosity at the end of the r command
+ #
+ if (!$matcher
+ or 'show_unparsable_versions' =~ /$matcher/
+ or 'show_zero_versions' =~ /$matcher/
+ ) {
+ $CPAN::Frontend->myprint($prompts{show_unparsable_or_zero_versions_intro});
+ my_yn_prompt(show_unparsable_versions => 0, $matcher);
+ my_yn_prompt(show_zero_versions => 0, $matcher);
+ }
+
+ #
+ #= MIRRORED.BY and conf_sites()
+ #
+
+ # remember, this is only triggered if no urllist is given, so 0 is
+ # fair and protects the default site from being overloaded and
+ # gives the user more chances to select his own urllist.
+ my_yn_prompt("connect_to_internet_ok" => $fastread ? 1 : 0, $matcher);
+ $CPAN::Config->{urllist} ||= [];
+ if ($matcher) {
+ if ("urllist" =~ $matcher) {
+ $CPAN::Frontend->myprint($prompts{urls_intro});
+
+ # conf_sites would go into endless loop with the smash prompt
+ local *_real_prompt;
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ my $_conf = prompt($prompts{auto_pick}, "yes");
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites( auto_pick => 1 ) or bring_your_own();
+ }
+ else {
+ my $_conf = prompt(
+ "Would you like to pick from the CPAN mirror list?", "yes"
+ );
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites();
+ }
+ bring_your_own();
+ }
+ _print_urllist();
+ }
+ if ("randomize_urllist" =~ $matcher) {
+ my_dflt_prompt(randomize_urllist => 0, $matcher);
+ }
+ if ("ftpstats_size" =~ $matcher) {
+ my_dflt_prompt(ftpstats_size => 99, $matcher);
+ }
+ if ("ftpstats_period" =~ $matcher) {
+ my_dflt_prompt(ftpstats_period => 14, $matcher);
+ }
+ } elsif ($fastread) {
+ $silent = 0;
+ local *_real_prompt;
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ if ( @{ $CPAN::Config->{urllist} } ) {
+ $CPAN::Frontend->myprint(
+ "\nYour 'urllist' is already configured. Type 'o conf init urllist' to change it.\n"
+ );
+ }
+ else {
+ $CPAN::Frontend->myprint(
+ "Autoconfigured everything but 'urllist'.\n"
+ );
+
+ $CPAN::Frontend->myprint($prompts{urls_intro});
+
+ my $_conf = prompt($prompts{auto_pick}, "yes");
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites( auto_pick => 1 ) or bring_your_own();
+ }
+ else {
+ my $_conf = prompt(
+ "Would you like to pick from the CPAN mirror list?", "yes"
+ );
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites();
+ }
+ bring_your_own();
+ }
+ _print_urllist();
+ }
+ $CPAN::Frontend->myprint(
+ "\nAutoconfiguration complete.\n"
+ );
+ }
+
+ $silent = 0; # reset
+
+ $CPAN::Frontend->myprint("\n");
+ if ($matcher && !$CPAN::Config->{auto_commit}) {
+ $CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ".
+ "make the config permanent!\n");
+ } else {
+ CPAN::HandleConfig->commit($configpm);
+ }
+}
+
+sub _init_external_progs {
+ my($matcher,$PATH) = @_;
+ my @external_progs = qw/bzip2 gzip tar unzip
+
+ make
+
+ curl lynx wget ncftpget ncftp ftp
+
+ gpg
+
+ patch applypatch
+ /;
+ if (!$matcher or "@external_progs" =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{external_progs}) unless $silent;
+
+ my $old_warn = $^W;
+ local $^W if $^O eq 'MacOS';
+ local $^W = $old_warn;
+ my $progname;
+ for $progname (@external_progs) {
+ next if $matcher && $progname !~ /$matcher/;
+ if ($^O eq 'MacOS') {
+ $CPAN::Config->{$progname} = 'not_here';
+ next;
+ }
+
+ my $progcall = $progname;
+ unless ($matcher) {
+ # we really don't need ncftp if we have ncftpget, but
+ # if they chose this dialog via matcher, they shall have it
+ next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " ";
+ }
+ my $path = $CPAN::Config->{$progname}
+ || $Config::Config{$progname}
+ || "";
+ if (File::Spec->file_name_is_absolute($path)) {
+ # testing existence is not good enough, some have these exe
+ # extensions
+
+ # warn "Warning: configured $path does not exist\n" unless -e $path;
+ # $path = "";
+ } elsif ($path =~ /^\s+$/) {
+ # preserve disabled programs
+ } else {
+ $path = '';
+ }
+ unless ($path) {
+ # e.g. make -> nmake
+ $progcall = $Config::Config{$progname} if $Config::Config{$progname};
+ }
+
+ $path ||= find_exe($progcall,$PATH);
+ unless ($path) { # not -e $path, because find_exe already checked that
+ local $"=";";
+ $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n") unless $silent;
+ if ($progname eq "make") {
+ $CPAN::Frontend->mywarn("ALERT: 'make' is an essential tool for ".
+ "building perl Modules. Please make sure you ".
+ "have 'make' (or some equivalent) ".
+ "working.\n"
+ );
+ if ($^O eq "MSWin32") {
+ $CPAN::Frontend->mywarn("
+Windows users may want to follow this procedure when back in the CPAN shell:
+
+ look YVES/scripts/alien_nmake.pl
+ perl alien_nmake.pl
+
+This will install nmake on your system which can be used as a 'make'
+substitute. You can then revisit this dialog with
+
+ o conf init make
+
+");
+ }
+ }
+ }
+ $prompts{$progname} = "Where is your $progname program?";
+ my_dflt_prompt($progname,$path,$matcher);
+ }
+ }
+}
+
+sub init_cpan_home {
+ my($matcher) = @_;
+ if (!$matcher or 'cpan_home' =~ /$matcher/) {
+ my $cpan_home = $CPAN::Config->{cpan_home}
+ || File::Spec->catdir(CPAN::HandleConfig::home(), ".cpan");
+
+ if (-d $cpan_home) {
+ $CPAN::Frontend->myprint(qq{
+
+I see you already have a directory
+ $cpan_home
+Shall we use it as the general CPAN build and cache directory?
+
+}) unless $silent;
+ } else {
+ # no cpan-home, must prompt and get one
+ $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $silent;
+ }
+
+ my $default = $cpan_home;
+ my $loop = 0;
+ my($last_ans,$ans);
+ $CPAN::Frontend->myprint(" <cpan_home>\n") unless $silent;
+ PROMPT: while ($ans = prompt("CPAN build and cache directory?",$default)) {
+ if (File::Spec->file_name_is_absolute($ans)) {
+ my @cpan_home = split /[\/\\]/, $ans;
+ DIR: for my $dir (@cpan_home) {
+ if ($dir =~ /^~/ and (!$last_ans or $ans ne $last_ans)) {
+ $CPAN::Frontend
+ ->mywarn("Warning: a tilde in the path will be ".
+ "taken as a literal tilde. Please ".
+ "confirm again if you want to keep it\n");
+ $last_ans = $default = $ans;
+ next PROMPT;
+ }
+ }
+ } else {
+ require Cwd;
+ my $cwd = Cwd::cwd();
+ my $absans = File::Spec->catdir($cwd,$ans);
+ $CPAN::Frontend->mywarn("The path '$ans' is not an ".
+ "absolute path. Please specify ".
+ "an absolute path\n");
+ $default = $absans;
+ next PROMPT;
+ }
+ eval { File::Path::mkpath($ans); }; # dies if it can't
+ if ($@) {
+ $CPAN::Frontend->mywarn("Couldn't create directory $ans.\n".
+ "Please retry.\n");
+ next PROMPT;
+ }
+ if (-d $ans && -w _) {
+ last PROMPT;
+ } else {
+ $CPAN::Frontend->mywarn("Couldn't find directory $ans\n".
+ "or directory is not writable. Please retry.\n");
+ if (++$loop > 5) {
+ $CPAN::Frontend->mydie("Giving up");
+ }
+ }
+ }
+ $CPAN::Config->{cpan_home} = $ans;
+ }
+}
+
+sub my_dflt_prompt {
+ my ($item, $dflt, $m) = @_;
+ my $default = $CPAN::Config->{$item} || $dflt;
+
+ if (!$silent && (!$m || $item =~ /$m/)) {
+ if (my $intro = $prompts{$item . "_intro"}) {
+ $CPAN::Frontend->myprint($intro);
+ }
+ $CPAN::Frontend->myprint(" <$item>\n");
+ $CPAN::Config->{$item} = prompt($prompts{$item}, $default);
+ } else {
+ $CPAN::Config->{$item} = $default;
+ }
+}
+
+sub my_yn_prompt {
+ my ($item, $dflt, $m) = @_;
+ my $default;
+ defined($default = $CPAN::Config->{$item}) or $default = $dflt;
+
+ # $DB::single = 1;
+ if (!$silent && (!$m || $item =~ /$m/)) {
+ if (my $intro = $prompts{$item . "_intro"}) {
+ $CPAN::Frontend->myprint($intro);
+ }
+ $CPAN::Frontend->myprint(" <$item>\n");
+ my $ans = prompt($prompts{$item}, $default ? 'yes' : 'no');
+ $CPAN::Config->{$item} = ($ans =~ /^[y1]/i ? 1 : 0);
+ } else {
+ $CPAN::Config->{$item} = $default;
+ }
+}
+
+sub my_prompt_loop {
+ my ($item, $dflt, $m, $ok) = @_;
+ my $default = $CPAN::Config->{$item} || $dflt;
+ my $ans;
+
+ if (!$silent && (!$m || $item =~ /$m/)) {
+ $CPAN::Frontend->myprint($prompts{$item . "_intro"});
+ $CPAN::Frontend->myprint(" <$item>\n");
+ do { $ans = prompt($prompts{$item}, $default);
+ } until $ans =~ /$ok/;
+ $CPAN::Config->{$item} = $ans;
+ } else {
+ $CPAN::Config->{$item} = $default;
+ }
+}
+
+
+# Here's the logic about the MIRRORED.BY file. There are a number of scenarios:
+# (1) We have a cached MIRRORED.BY file
+# (1a) We're auto-picking
+# - Refresh it automatically if it's old
+# (1b) Otherwise, ask if using cached is ok. If old, default to no.
+# - If cached is not ok, get it from the Internet. If it succeeds we use
+# the new file. Otherwise, we use the old file.
+# (2) We don't have a copy at all
+# (2a) If we are allowed to connect, we try to get a new copy. If it succeeds,
+# we use it, otherwise, we warn about failure
+# (2b) If we aren't allowed to connect,
+
+sub conf_sites {
+ my %args = @_;
+ # auto pick implies using the internet
+ $CPAN::Config->{connect_to_internet_ok} = 1 if $args{auto_pick};
+
+ my $m = 'MIRRORED.BY';
+ my $mby = File::Spec->catfile($CPAN::Config->{keep_source_where},$m);
+ File::Path::mkpath(File::Basename::dirname($mby));
+ # Why are we using MIRRORED.BY from the current directory?
+ # Is this for testing? -- dagolden, 2009-11-05
+ if (-f $mby && -f $m && -M $m < -M $mby) {
+ require File::Copy;
+ File::Copy::copy($m,$mby) or die "Could not update $mby: $!";
+ }
+ local $^T = time;
+ # if we have a cached copy is not older than 60 days, we either
+ # use it or refresh it or fall back to it if the refresh failed.
+ if ($mby && -f $mby && -s _ > 0 ) {
+ my $very_old = (-M $mby > 60);
+ my $mtime = localtime((stat _)[9]);
+ # if auto_pick, refresh anything old automatically
+ if ( $args{auto_pick} ) {
+ if ( $very_old ) {
+ $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n});
+ eval { CPAN::FTP->localize($m,$mby,3,1) }
+ or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n});
+ $CPAN::Frontend->myprint("\n");
+ }
+ }
+ else {
+ my $prompt = qq{Found a cached mirror list as of $mtime
+
+If you'd like to just use the cached copy, answer 'yes', below.
+If you'd like an updated copy of the mirror list, answer 'no' and
+I'll get a fresh one from the Internet.
+
+Shall I use the cached mirror list?};
+ my $ans = prompt($prompt, $very_old ? "no" : "yes");
+ if ($ans =~ /^n/i) {
+ $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n});
+ # you asked for it from the Internet
+ $CPAN::Config->{connect_to_internet_ok} = 1;
+ eval { CPAN::FTP->localize($m,$mby,3,1) }
+ or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n});
+ $CPAN::Frontend->myprint("\n");
+ }
+ }
+ }
+ # else there is no cached copy and we must fetch or fail
+ else {
+ # If they haven't agree to connect to the internet, ask again
+ if ( ! $CPAN::Config->{connect_to_internet_ok} ) {
+ my $prompt = q{You are missing a copy of the CPAN mirror list.
+
+May I connect to the Internet to get it?};
+ my $ans = prompt($prompt, "yes");
+ if ($ans =~ /^y/i) {
+ $CPAN::Config->{connect_to_internet_ok} = 1;
+ }
+ }
+
+ # Now get it from the Internet or complain
+ if ( $CPAN::Config->{connect_to_internet_ok} ) {
+ $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
+ eval { CPAN::FTP->localize($m,$mby,3,1) }
+ or $CPAN::Frontend->mywarn(<<'HERE');
+We failed to get a copy of the mirror list from the Internet.
+You will need to provide CPAN mirror URLs yourself.
+HERE
+ $CPAN::Frontend->myprint("\n");
+ }
+ else {
+ $CPAN::Frontend->mywarn(<<'HERE');
+You will need to provide CPAN mirror URLs yourself or set
+'o conf connect_to_internet_ok 1' and try again.
+HERE
+ }
+ }
+
+ # if we finally have a good local MIRRORED.BY, get on with picking
+ if (-f $mby && -s _ > 0){
+ $CPAN::Config->{urllist} =
+ $args{auto_pick} ? auto_mirrored_by($mby) : choose_mirrored_by($mby);
+ return 1;
+ }
+
+ return;
+}
+
+sub find_exe {
+ my($exe,$path) = @_;
+ my($dir);
+ #warn "in find_exe exe[$exe] path[@$path]";
+ for $dir (@$path) {
+ my $abs = File::Spec->catfile($dir,$exe);
+ if (($abs = MM->maybe_command($abs))) {
+ return $abs;
+ }
+ }
+}
+
+sub picklist {
+ my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_;
+ CPAN->debug("picklist('$items','$prompt','$default','$require_nonempty',".
+ "'$empty_warning')") if $CPAN::DEBUG;
+ $default ||= '';
+
+ my $pos = 0;
+
+ my @nums;
+ SELECTION: while (1) {
+
+ # display, at most, 15 items at a time
+ my $limit = $#{ $items } - $pos;
+ $limit = 15 if $limit > 15;
+
+ # show the next $limit items, get the new position
+ $pos = display_some($items, $limit, $pos, $default);
+ $pos = 0 if $pos >= @$items;
+
+ my $num = prompt($prompt,$default);
+
+ @nums = split (' ', $num);
+ {
+ my %seen;
+ @nums = grep { !$seen{$_}++ } @nums;
+ }
+ my $i = scalar @$items;
+ unrangify(\@nums);
+ if (0 == @nums) {
+ # cannot allow nothing because nothing means paging!
+ # return;
+ } elsif (grep (/\D/ || $_ < 1 || $_ > $i, @nums)) {
+ $CPAN::Frontend->mywarn("invalid items entered, try again\n");
+ if ("@nums" =~ /\D/) {
+ $CPAN::Frontend->mywarn("(we are expecting only numbers between 1 and $i)\n");
+ }
+ next SELECTION;
+ }
+ if ($require_nonempty && !@nums) {
+ $CPAN::Frontend->mywarn("$empty_warning\n");
+ }
+
+ # a blank line continues...
+ unless (@nums){
+ $CPAN::Frontend->mysleep(0.1); # prevent hot spinning process on the next bug
+ next SELECTION;
+ }
+ last;
+ }
+ for (@nums) { $_-- }
+ @{$items}[@nums];
+}
+
+sub unrangify ($) {
+ my($nums) = $_[0];
+ my @nums2 = ();
+ while (@{$nums||[]}) {
+ my $n = shift @$nums;
+ if ($n =~ /^(\d+)-(\d+)$/) {
+ my @range = $1 .. $2;
+ # warn "range[@range]";
+ push @nums2, @range;
+ } else {
+ push @nums2, $n;
+ }
+ }
+ push @$nums, @nums2;
+}
+
+sub display_some {
+ my ($items, $limit, $pos, $default) = @_;
+ $pos ||= 0;
+
+ my @displayable = @$items[$pos .. ($pos + $limit)];
+ for my $item (@displayable) {
+ $CPAN::Frontend->myprint(sprintf "(%d) %s\n", ++$pos, $item);
+ }
+ my $hit_what = $default ? "SPACE RETURN" : "RETURN";
+ $CPAN::Frontend->myprint(sprintf("%d more items, hit %s to show them\n",
+ (@$items - $pos),
+ $hit_what,
+ ))
+ if $pos < @$items;
+ return $pos;
+}
+
+sub auto_mirrored_by {
+ my $local = shift or return;
+ local $|=1;
+ $CPAN::Frontend->myprint("Searching for the best CPAN mirrors (please be patient) ...");
+ my $mirrors = CPAN::Mirrors->new($local);
+ my $cnt = 0;
+ my @best = $mirrors->best_mirrors(
+ how_many => 5,
+ callback => sub { $CPAN::Frontend->myprint(".") },
+ );
+ my $urllist = [ map { $_->ftp } @best ];
+ push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}};
+ $CPAN::Frontend->myprint(" done!\n\n");
+ return $urllist;
+}
+
+sub choose_mirrored_by {
+ my $local = shift or return;
+ my ($default);
+ my $mirrors = CPAN::Mirrors->new($local);
+ my @previous_urls = @{$CPAN::Config->{urllist}};
+
+ $CPAN::Frontend->myprint($prompts{urls_picker_intro});
+
+ my (@cont, $cont, %cont, @countries, @urls, %seen);
+ my $no_previous_warn =
+ "Sorry! since you don't have any existing picks, you must make a\n" .
+ "geographic selection.";
+ my $offer_cont = [sort $mirrors->continents];
+ if (@previous_urls) {
+ push @$offer_cont, "(edit previous picks)";
+ $default = @$offer_cont;
+ } else {
+ # cannot allow nothing because nothing means paging!
+ # push @$offer_cont, "(none of the above)";
+ }
+ @cont = picklist($offer_cont,
+ "Select your continent (or several nearby continents)",
+ $default,
+ ! @previous_urls,
+ $no_previous_warn);
+ # cannot allow nothing because nothing means paging!
+ # return unless @cont;
+
+ foreach $cont (@cont) {
+ my @c = sort $mirrors->countries($cont);
+ @cont{@c} = map ($cont, 0..$#c);
+ @c = map ("$_ ($cont)", @c) if @cont > 1;
+ push (@countries, @c);
+ }
+ if (@previous_urls && @countries) {
+ push @countries, "(edit previous picks)";
+ $default = @countries;
+ }
+
+ if (@countries) {
+ @countries = picklist (\@countries,
+ "Select your country (or several nearby countries)",
+ $default,
+ ! @previous_urls,
+ $no_previous_warn);
+ %seen = map (($_ => 1), @previous_urls);
+ # hmmm, should take list of defaults from CPAN::Config->{'urllist'}...
+ foreach my $country (@countries) {
+ next if $country =~ /edit previous picks/;
+ (my $bare_country = $country) =~ s/ \(.*\)//;
+ my @u;
+ for my $m ( $mirrors->mirrors($bare_country) ) {
+ push @u, $m->ftp if $m->ftp;
+ push @u, $m->http if $m->http;
+ }
+ @u = grep (! $seen{$_}, @u);
+ @u = map ("$_ ($bare_country)", @u)
+ if @countries > 1;
+ push (@urls, sort @u);
+ }
+ }
+ push (@urls, map ("$_ (previous pick)", @previous_urls));
+ my $prompt = "Select as many URLs as you like (by number),
+put them on one line, separated by blanks, hyphenated ranges allowed
+ e.g. '1 4 5' or '7 1-4 8'";
+ if (@previous_urls) {
+ $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) ..
+ (scalar @urls));
+ $prompt .= "\n(or just hit RETURN to keep your previous picks)";
+ }
+
+ @urls = picklist (\@urls, $prompt, $default);
+ foreach (@urls) { s/ \(.*\)//; }
+ return [ @urls ];
+}
+
+sub bring_your_own {
+ my $urllist = [ @{$CPAN::Config->{urllist}} ];
+ my %seen = map (($_ => 1), @$urllist);
+ my($ans,@urls);
+ my $eacnt = 0; # empty answers
+ $CPAN::Frontend->myprint(<<'HERE');
+
+Now you can enter your own CPAN URLs by hand. A local CPAN mirror can be
+listed using a 'file:' URL like 'file:///path/to/cpan/'
+
+HERE
+ do {
+ my $prompt = "Enter another URL or RETURN to quit:";
+ unless (%seen) {
+ $prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from.
+
+Please enter your CPAN site:};
+ }
+ $ans = prompt ($prompt, "");
+
+ if ($ans) {
+ $ans =~ s|/?\z|/|; # has to end with one slash
+ # XXX This manipulation is odd. Shouldn't we check that $ans is
+ # a directory before converting to file:///? And we need /// below,
+ # too, don't we? -- dagolden, 2009-11-05
+ $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file:
+ if ($ans =~ /^\w+:\/./) {
+ push @urls, $ans unless $seen{$ans}++;
+ } else {
+ $CPAN::Frontend->
+ myprint(sprintf(qq{"%s" doesn\'t look like an URL at first sight.
+I\'ll ignore it for now.
+You can add it to your %s
+later if you\'re sure it\'s right.\n},
+ $ans,
+ $INC{'CPAN/MyConfig.pm'}
+ || $INC{'CPAN/Config.pm'}
+ || "configuration file",
+ ));
+ }
+ } else {
+ if (++$eacnt >= 5) {
+ $CPAN::Frontend->
+ mywarn("Giving up.\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } while $ans || !%seen;
+
+ @$urllist = CPAN::_uniq(@$urllist, @urls);
+ $CPAN::Config->{urllist} = $urllist;
+}
+
+sub _print_urllist {
+ $CPAN::Frontend->myprint("New urllist\n");
+ for ( @{$CPAN::Config->{urllist} || []} ) {
+ $CPAN::Frontend->myprint(" $_\n")
+ };
+}
+
+sub _strip_spaces {
+ $_[0] =~ s/^\s+//; # no leading spaces
+ $_[0] =~ s/\s+\z//; # no trailing spaces
+}
+
+sub prompt ($;$) {
+ unless (defined &_real_prompt) {
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ }
+ my $ans = _real_prompt(@_);
+
+ _strip_spaces($ans);
+ $CPAN::Frontend->myprint("\n");
+
+ return $ans;
+}
+
+
+sub prompt_no_strip ($;$) {
+ return _real_prompt(@_);
+}
+
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/HandleConfig.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/HandleConfig.pm
new file mode 100755
index 00000000000..6a134bd755e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/HandleConfig.pm
@@ -0,0 +1,735 @@
+package CPAN::HandleConfig;
+use strict;
+use vars qw(%can %keys $loading $VERSION);
+
+$VERSION = "5.5";
+
+%can = (
+ commit => "Commit changes to disk",
+ defaults => "Reload defaults from disk",
+ help => "Short help about 'o conf' usage",
+ init => "Interactive setting of all options",
+);
+
+# Q: where is the "How do I add a new config option" HOWTO?
+# A1: svn diff -r 757:758 # where dagolden added test_report
+# A2: svn diff -r 985:986 # where andk added yaml_module
+# A3: 1. add new config option to %keys below
+# 2. add a Pod description in CPAN::FirstTime; it should include a
+# prompt line; see others for examples
+# 3. add a "matcher" section in CPAN::FirstTime::init that includes
+# a prompt function; see others for examples
+# 4. add config option to documentation section in CPAN.pm
+
+%keys = map { $_ => undef }
+ (
+ "applypatch",
+ "auto_commit",
+ "build_cache",
+ "build_dir",
+ "build_dir_reuse",
+ "build_requires_install_policy",
+ "bzip2",
+ "cache_metadata",
+ "check_sigs",
+ "colorize_debug",
+ "colorize_output",
+ "colorize_print",
+ "colorize_warn",
+ "commandnumber_in_prompt",
+ "commands_quote",
+ "connect_to_internet_ok",
+ "cpan_home",
+ "curl",
+ "dontload_hash", # deprecated after 1.83_68 (rev. 581)
+ "dontload_list",
+ "ftp",
+ "ftp_passive",
+ "ftp_proxy",
+ "ftpstats_size",
+ "ftpstats_period",
+ "getcwd",
+ "gpg",
+ "gzip",
+ "halt_on_failure",
+ "histfile",
+ "histsize",
+ "http_proxy",
+ "inactivity_timeout",
+ "index_expire",
+ "inhibit_startup_message",
+ "keep_source_where",
+ "load_module_verbosity",
+ "lynx",
+ "make",
+ "make_arg",
+ "make_install_arg",
+ "make_install_make_command",
+ "makepl_arg",
+ "mbuild_arg",
+ "mbuild_install_arg",
+ "mbuild_install_build_command",
+ "mbuildpl_arg",
+ "ncftp",
+ "ncftpget",
+ "no_proxy",
+ "pager",
+ "password",
+ "patch",
+ "patches_dir",
+ "perl5lib_verbosity",
+ "prefer_installer",
+ "prefs_dir",
+ "prerequisites_policy",
+ "proxy_pass",
+ "proxy_user",
+ "randomize_urllist",
+ "scan_cache",
+ "shell",
+ "show_unparsable_versions",
+ "show_upload_date",
+ "show_zero_versions",
+ "tar",
+ "tar_verbosity",
+ "term_is_latin",
+ "term_ornaments",
+ "test_report",
+ "trust_test_report_history",
+ "unzip",
+ "urllist",
+ "use_sqlite",
+ "username",
+ "version_timeout",
+ "wait_list",
+ "wget",
+ "yaml_load_code",
+ "yaml_module",
+ );
+
+my %prefssupport = map { $_ => 1 }
+ (
+ "build_requires_install_policy",
+ "check_sigs",
+ "make",
+ "make_install_make_command",
+ "prefer_installer",
+ "test_report",
+ );
+
+# returns true on successful action
+sub edit {
+ my($self,@args) = @_;
+ return unless @args;
+ CPAN->debug("self[$self]args[".join(" | ",@args)."]");
+ my($o,$str,$func,$args,$key_exists);
+ $o = shift @args;
+ if($can{$o}) {
+ my $success = $self->$o(args => \@args); # o conf init => sub init => sub load
+ unless ($success) {
+ die "Panic: could not configure CPAN.pm for args [@args]. Giving up.";
+ }
+ } else {
+ CPAN->debug("o[$o]") if $CPAN::DEBUG;
+ unless (exists $keys{$o}) {
+ $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
+ }
+ my $changed;
+
+
+ # one day I used randomize_urllist for a boolean, so we must
+ # list them explicitly --ak
+ if (0) {
+ } elsif ($o =~ /^(wait_list|urllist|dontload_list)$/) {
+
+ #
+ # ARRAYS
+ #
+
+ $func = shift @args;
+ $func ||= "";
+ CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG;
+ # Let's avoid eval, it's easier to comprehend without.
+ if ($func eq "push") {
+ push @{$CPAN::Config->{$o}}, @args;
+ $changed = 1;
+ } elsif ($func eq "pop") {
+ pop @{$CPAN::Config->{$o}};
+ $changed = 1;
+ } elsif ($func eq "shift") {
+ shift @{$CPAN::Config->{$o}};
+ $changed = 1;
+ } elsif ($func eq "unshift") {
+ unshift @{$CPAN::Config->{$o}}, @args;
+ $changed = 1;
+ } elsif ($func eq "splice") {
+ my $offset = shift @args || 0;
+ my $length = shift @args || 0;
+ splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn
+ $changed = 1;
+ } elsif ($func) {
+ $CPAN::Config->{$o} = [$func, @args];
+ $changed = 1;
+ } else {
+ $self->prettyprint($o);
+ }
+ if ($changed) {
+ if ($o eq "urllist") {
+ # reset the cached values
+ undef $CPAN::FTP::Thesite;
+ undef $CPAN::FTP::Themethod;
+ $CPAN::Index::LAST_TIME = 0;
+ } elsif ($o eq "dontload_list") {
+ # empty it, it will be built up again
+ $CPAN::META->{dontload_hash} = {};
+ }
+ }
+ } elsif ($o =~ /_hash$/) {
+
+ #
+ # HASHES
+ #
+
+ if (@args==1 && $args[0] eq "") {
+ @args = ();
+ } elsif (@args % 2) {
+ push @args, "";
+ }
+ $CPAN::Config->{$o} = { @args };
+ $changed = 1;
+ } else {
+
+ #
+ # SCALARS
+ #
+
+ if (defined $args[0]) {
+ $CPAN::CONFIG_DIRTY = 1;
+ $CPAN::Config->{$o} = $args[0];
+ $changed = 1;
+ }
+ $self->prettyprint($o)
+ if exists $keys{$o} or defined $CPAN::Config->{$o};
+ }
+ if ($changed) {
+ if ($CPAN::Config->{auto_commit}) {
+ $self->commit;
+ } else {
+ $CPAN::CONFIG_DIRTY = 1;
+ $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
+ "make the config permanent!\n\n");
+ }
+ }
+ }
+}
+
+sub prettyprint {
+ my($self,$k) = @_;
+ my $v = $CPAN::Config->{$k};
+ if (ref $v) {
+ my(@report);
+ if (ref $v eq "ARRAY") {
+ @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v;
+ } else {
+ @report = map
+ {
+ sprintf "\t%-18s => %s\n",
+ "[$_]",
+ defined $v->{$_} ? "[$v->{$_}]" : "undef"
+ } keys %$v;
+ }
+ $CPAN::Frontend->myprint(
+ join(
+ "",
+ sprintf(
+ " %-18s\n",
+ $k
+ ),
+ @report
+ )
+ );
+ } elsif (defined $v) {
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
+ } else {
+ $CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k);
+ }
+}
+
+sub commit {
+ my($self,@args) = @_;
+ CPAN->debug("args[@args]") if $CPAN::DEBUG;
+ if ($CPAN::RUN_DEGRADED) {
+ $CPAN::Frontend->mydie(
+ "'o conf commit' disabled in ".
+ "degraded mode. Maybe try\n".
+ " !undef \$CPAN::RUN_DEGRADED\n"
+ );
+ }
+ my $configpm;
+ if (@args) {
+ if ($args[0] eq "args") {
+ # we have not signed that contract
+ } else {
+ $configpm = $args[0];
+ }
+ }
+ unless (defined $configpm) {
+ $configpm ||= $INC{"CPAN/MyConfig.pm"};
+ $configpm ||= $INC{"CPAN/Config.pm"};
+ $configpm || Carp::confess(q{
+CPAN::Config::commit called without an argument.
+Please specify a filename where to save the configuration or try
+"o conf init" to have an interactive course through configing.
+});
+ }
+ my($mode);
+ if (-f $configpm) {
+ $mode = (stat $configpm)[2];
+ if ($mode && ! -w _) {
+ Carp::confess("$configpm is not writable");
+ }
+ }
+
+ my $msg;
+ my $home = home();
+ $msg = <<EOF unless $configpm =~ /MyConfig/;
+
+# This is CPAN.pm's systemwide configuration file. This file provides
+# defaults for users, and the values can be changed in a per-user
+# configuration file. The user-config file is being looked for as
+# $home/.cpan/CPAN/MyConfig.pm.
+
+EOF
+ $msg ||= "\n";
+ my($fh) = FileHandle->new;
+ rename $configpm, "$configpm~" if -f $configpm;
+ open $fh, ">$configpm" or
+ $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
+ $fh->print(qq[$msg\$CPAN::Config = \{\n]);
+ foreach (sort keys %$CPAN::Config) {
+ unless (exists $keys{$_}) {
+ # do not drop them: forward compatibility!
+ $CPAN::Frontend->mywarn("Unknown config variable '$_'\n");
+ next;
+ }
+ $fh->print(
+ " '$_' => ",
+ $self->neatvalue($CPAN::Config->{$_}),
+ ",\n"
+ );
+ }
+
+ $fh->print("};\n1;\n__END__\n");
+ close $fh;
+
+ #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ #chmod $mode, $configpm;
+###why was that so? $self->defaults;
+ $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
+ $CPAN::CONFIG_DIRTY = 0;
+ 1;
+}
+
+# stolen from MakeMaker; not taking the original because it is buggy;
+# bugreport will have to say: keys of hashes remain unquoted and can
+# produce syntax errors
+sub neatvalue {
+ my($self, $v) = @_;
+ return "undef" unless defined $v;
+ my($t) = ref $v;
+ unless ($t) {
+ $v =~ s/\\/\\\\/g;
+ return "q[$v]";
+ }
+ if ($t eq 'ARRAY') {
+ my(@m, @neat);
+ push @m, "[";
+ foreach my $elem (@$v) {
+ push @neat, "q[$elem]";
+ }
+ push @m, join ", ", @neat;
+ push @m, "]";
+ return join "", @m;
+ }
+ return "$v" unless $t eq 'HASH';
+ my(@m, $key, $val);
+ while (($key,$val) = each %$v) {
+ last unless defined $key; # cautious programming in case (undef,undef) is true
+ push(@m,"q[$key]=>".$self->neatvalue($val)) ;
+ }
+ return "{ ".join(', ',@m)." }";
+}
+
+sub defaults {
+ my($self) = @_;
+ if ($CPAN::RUN_DEGRADED) {
+ $CPAN::Frontend->mydie(
+ "'o conf defaults' disabled in ".
+ "degraded mode. Maybe try\n".
+ " !undef \$CPAN::RUN_DEGRADED\n"
+ );
+ }
+ my $done;
+ for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
+ if ($INC{$config}) {
+ CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG;
+ CPAN::Shell->_reload_this($config,{reloforce => 1});
+ $CPAN::Frontend->myprint("'$INC{$config}' reread\n");
+ last;
+ }
+ }
+ $CPAN::CONFIG_DIRTY = 0;
+ 1;
+}
+
+=head2 C<< CLASS->safe_quote ITEM >>
+
+Quotes an item to become safe against spaces
+in shell interpolation. An item is enclosed
+in double quotes if:
+
+ - the item contains spaces in the middle
+ - the item does not start with a quote
+
+This happens to avoid shell interpolation
+problems when whitespace is present in
+directory names.
+
+This method uses C<commands_quote> to determine
+the correct quote. If C<commands_quote> is
+a space, no quoting will take place.
+
+
+if it starts and ends with the same quote character: leave it as it is
+
+if it contains no whitespace: leave it as it is
+
+if it contains whitespace, then
+
+if it contains quotes: better leave it as it is
+
+else: quote it with the correct quote type for the box we're on
+
+=cut
+
+{
+ # Instead of patching the guess, set commands_quote
+ # to the right value
+ my ($quotes,$use_quote)
+ = $^O eq 'MSWin32'
+ ? ('"', '"')
+ : (q{"'}, "'")
+ ;
+
+ sub safe_quote {
+ my ($self, $command) = @_;
+ # Set up quote/default quote
+ my $quote = $CPAN::Config->{commands_quote} || $quotes;
+
+ if ($quote ne ' '
+ and defined($command )
+ and $command =~ /\s/
+ and $command !~ /[$quote]/) {
+ return qq<$use_quote$command$use_quote>
+ }
+ return $command;
+ }
+}
+
+sub init {
+ my($self,@args) = @_;
+ CPAN->debug("self[$self]args[".join(",",@args)."]");
+ $self->load(doit => 1, @args);
+ 1;
+}
+
+# This is a piece of repeated code that is abstracted here for
+# maintainability. RMB
+#
+sub _configpmtest {
+ my($configpmdir, $configpmtest) = @_;
+ if (-w $configpmtest) {
+ return $configpmtest;
+ } elsif (-w $configpmdir) {
+ #_#_# following code dumped core on me with 5.003_11, a.k.
+ my $configpm_bak = "$configpmtest.bak";
+ unlink $configpm_bak if -f $configpm_bak;
+ if( -f $configpmtest ) {
+ if( rename $configpmtest, $configpm_bak ) {
+ $CPAN::Frontend->mywarn(<<END);
+Old configuration file $configpmtest
+ moved to $configpm_bak
+END
+ }
+ }
+ my $fh = FileHandle->new;
+ if ($fh->open(">$configpmtest")) {
+ $fh->print("1;\n");
+ return $configpmtest;
+ } else {
+ # Should never happen
+ Carp::confess("Cannot open >$configpmtest");
+ }
+ } else { return }
+}
+
+sub require_myconfig_or_config () {
+ return if $INC{"CPAN/MyConfig.pm"};
+ local @INC = @INC;
+ my $home = home();
+ unshift @INC, File::Spec->catdir($home,'.cpan');
+ eval { require CPAN::MyConfig };
+ my $err_myconfig = $@;
+ if ($err_myconfig and $err_myconfig !~ m#locate CPAN/MyConfig\.pm#) {
+ die "Error while requiring CPAN::MyConfig:\n$err_myconfig";
+ }
+ unless ($INC{"CPAN/MyConfig.pm"}) { # this guy has settled his needs already
+ eval {require CPAN::Config;}; # not everybody has one
+ my $err_config = $@;
+ if ($err_config and $err_config !~ m#locate CPAN/Config\.pm#) {
+ die "Error while requiring CPAN::Config:\n$err_config";
+ }
+ }
+}
+
+sub home () {
+ my $home;
+ # Suppress load messages until we load the config and know whether
+ # load messages are desired. Otherwise, it's unexpected and odd
+ # why one load message pops up even when verbosity is turned off.
+ # This means File::HomeDir load messages are never seen, but I
+ # think that's probably OK -- DAGOLDEN
+
+ # 5.6.2 seemed to segfault localizing a value in a hashref
+ # so do it manually instead
+ my $old_v = $CPAN::Config->{load_module_verbosity};
+ $CPAN::Config->{load_module_verbosity} = q[none];
+ if ($CPAN::META->has_usable("File::HomeDir")) {
+ if ($^O eq 'darwin') {
+ $home = File::HomeDir->my_home; # my_data is ~/Library/Application Support on darwin,
+ # which causes issues in the toolchain.
+ }
+ else {
+ $home = File::HomeDir->my_data || File::HomeDir->my_home;
+ }
+ }
+ unless (defined $home) {
+ $home = $ENV{HOME};
+ }
+ $CPAN::Config->{load_module_verbosity} = $old_v;
+ $home;
+}
+
+sub load {
+ my($self, %args) = @_;
+ $CPAN::Be_Silent++ if $args{be_silent};
+ my $doit;
+ $doit = delete $args{doit};
+
+ use Carp;
+ require_myconfig_or_config;
+ my @miss = $self->missing_config_data;
+ CPAN->debug("doit[$doit]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
+ return unless $doit || @miss;
+ return if $loading;
+ local $loading = ($loading||0) + 1;
+
+ require CPAN::FirstTime;
+ my($redo,$configpm,$fh);
+ if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
+ $configpm = $INC{"CPAN/Config.pm"};
+ $redo++;
+ } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
+ $configpm = $INC{"CPAN/MyConfig.pm"};
+ $redo++;
+ } else {
+ my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
+ my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
+ my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
+ my $inc_key;
+ if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
+ $configpm = _configpmtest($configpmdir,$configpmtest);
+ $inc_key = "CPAN/Config.pm";
+ }
+ unless ($configpm) {
+ $configpmdir = File::Spec->catdir(home,".cpan","CPAN");
+ File::Path::mkpath($configpmdir);
+ $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
+ $configpm = _configpmtest($configpmdir,$configpmtest);
+ $inc_key = "CPAN/MyConfig.pm";
+ }
+ if ($configpm) {
+ $INC{$inc_key} = $configpm;
+ } else {
+ my $text = qq{WARNING: CPAN.pm is unable to } .
+ qq{create a configuration file.};
+ output($text, 'confess');
+ }
+
+ }
+ local($") = ", ";
+ if ($redo && !$doit) {
+ $CPAN::Frontend->myprint(<<END);
+Sorry, we have to rerun the configuration dialog for CPAN.pm due to
+some missing parameters... Will write to
+ <<$configpm>>
+
+END
+ $args{args} = \@miss;
+ }
+ my $initialized = CPAN::FirstTime::init($configpm, %args);
+ return $initialized;
+}
+
+
+# returns mandatory but missing entries in the Config
+sub missing_config_data {
+ my(@miss);
+ for (
+ "auto_commit",
+ "build_cache",
+ "build_dir",
+ "cache_metadata",
+ "cpan_home",
+ "ftp_proxy",
+ #"gzip",
+ "http_proxy",
+ "index_expire",
+ #"inhibit_startup_message",
+ "keep_source_where",
+ #"make",
+ "make_arg",
+ "make_install_arg",
+ "makepl_arg",
+ "mbuild_arg",
+ "mbuild_install_arg",
+ ($^O eq "MSWin32" ? "" : "mbuild_install_build_command"),
+ "mbuildpl_arg",
+ "no_proxy",
+ #"pager",
+ "prerequisites_policy",
+ "scan_cache",
+ #"tar",
+ #"unzip",
+ "urllist",
+ ) {
+ next unless exists $keys{$_};
+ push @miss, $_ unless defined $CPAN::Config->{$_};
+ }
+ return @miss;
+}
+
+sub help {
+ $CPAN::Frontend->myprint(q[
+Known options:
+ commit commit session changes to disk
+ defaults reload default config values from disk
+ help this help
+ init enter a dialog to set all or a set of parameters
+
+Edit key values as in the following (the "o" is a literal letter o):
+ o conf build_cache 15
+ o conf build_dir "/foo/bar"
+ o conf urllist shift
+ o conf urllist unshift ftp://ftp.foo.bar/
+ o conf inhibit_startup_message 1
+
+]);
+ undef; #don't reprint CPAN::Config
+}
+
+sub cpl {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@words) = split " ", substr($line,0,$pos+1);
+ if (
+ defined($words[2])
+ and
+ $words[2] =~ /list$/
+ and
+ (
+ @words == 3
+ ||
+ @words == 4 && length($word)
+ )
+ ) {
+ return grep /^\Q$word\E/, qw(splice shift unshift pop push);
+ } elsif (defined($words[2])
+ and
+ $words[2] eq "init"
+ and
+ (
+ @words == 3
+ ||
+ @words >= 4 && length($word)
+ )) {
+ return sort grep /^\Q$word\E/, keys %keys;
+ } elsif (@words >= 4) {
+ return ();
+ }
+ my %seen;
+ my(@o_conf) = sort grep { !$seen{$_}++ }
+ keys %can,
+ keys %$CPAN::Config,
+ keys %keys;
+ return grep /^\Q$word\E/, @o_conf;
+}
+
+sub prefs_lookup {
+ my($self,$distro,$what) = @_;
+
+ if ($prefssupport{$what}) {
+ return $CPAN::Config->{$what} unless
+ $distro
+ and $distro->prefs
+ and $distro->prefs->{cpanconfig}
+ and defined $distro->prefs->{cpanconfig}{$what};
+ return $distro->prefs->{cpanconfig}{$what};
+ } else {
+ $CPAN::Frontend->mywarn("Warning: $what not yet officially ".
+ "supported for distroprefs, doing a normal lookup");
+ return $CPAN::Config->{$what};
+ }
+}
+
+
+{
+ package
+ CPAN::Config; ####::###### #hide from indexer
+ # note: J. Nick Koston wrote me that they are using
+ # CPAN::Config->commit although undocumented. I suggested
+ # CPAN::Shell->o("conf","commit") even when ugly it is at least
+ # documented
+
+ # that's why I added the CPAN::Config class with autoload and
+ # deprecated warning
+
+ use strict;
+ use vars qw($AUTOLOAD $VERSION);
+ $VERSION = "5.5";
+
+ # formerly CPAN::HandleConfig was known as CPAN::Config
+ sub AUTOLOAD { ## no critic
+ my $class = shift; # e.g. in dh-make-perl: CPAN::Config
+ my($l) = $AUTOLOAD;
+ $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n");
+ $l =~ s/.*:://;
+ CPAN::HandleConfig->$l(@_);
+ }
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End:
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Index.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Index.pm
new file mode 100755
index 00000000000..9df757de706
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Index.pm
@@ -0,0 +1,619 @@
+package CPAN::Index;
+use strict;
+use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
+$VERSION = "1.94";
+@CPAN::Index::ISA = qw(CPAN::Debug);
+$LAST_TIME ||= 0;
+$DATE_OF_03 ||= 0;
+# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
+sub PROTOCOL { 2.0 }
+
+#-> sub CPAN::Index::force_reload ;
+sub force_reload {
+ my($class) = @_;
+ $CPAN::Index::LAST_TIME = 0;
+ $class->reload(1);
+}
+
+my @indexbundle =
+ (
+ {
+ reader => "rd_authindex",
+ dir => "authors",
+ remotefile => '01mailrc.txt.gz',
+ shortlocalfile => '01mailrc.gz',
+ },
+ {
+ reader => "rd_modpacks",
+ dir => "modules",
+ remotefile => '02packages.details.txt.gz',
+ shortlocalfile => '02packag.gz',
+ },
+ {
+ reader => "rd_modlist",
+ dir => "modules",
+ remotefile => '03modlist.data.gz',
+ shortlocalfile => '03mlist.gz',
+ },
+ );
+
+#-> sub CPAN::Index::reload ;
+sub reload {
+ my($self,$force) = @_;
+ my $time = time;
+
+ # XXX check if a newer one is available. (We currently read it
+ # from time to time)
+ for ($CPAN::Config->{index_expire}) {
+ $_ = 0.001 unless $_ && $_ > 0.001;
+ }
+ unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
+ # debug here when CPAN doesn't seem to read the Metadata
+ require Carp;
+ Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
+ }
+ unless ($CPAN::META->{PROTOCOL}) {
+ $self->read_metadata_cache;
+ $CPAN::META->{PROTOCOL} ||= "1.0";
+ }
+ if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
+ # warn "Setting last_time to 0";
+ $LAST_TIME = 0; # No warning necessary
+ }
+ if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
+ and ! $force) {
+ # called too often
+ # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
+ } elsif (0) {
+ # IFF we are developing, it helps to wipe out the memory
+ # between reloads, otherwise it is not what a user expects.
+ undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
+ $CPAN::META = CPAN->new;
+ } else {
+ my($debug,$t2);
+ local $LAST_TIME = $time;
+ local $CPAN::META->{PROTOCOL} = PROTOCOL;
+
+ my $needshort = $^O eq "dos";
+
+ INX: for my $indexbundle (@indexbundle) {
+ my $reader = $indexbundle->{reader};
+ my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile};
+ my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile);
+ my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile};
+ my $localized = $self->reload_x($remote, $localpath, $force);
+ $self->$reader($localized); # may die but we let the shell catch it
+ if ($CPAN::DEBUG){
+ $t2 = time;
+ $debug = "timing reading 01[".($t2 - $time)."]";
+ $time = $t2;
+ }
+ return if $CPAN::Signal; # this is sometimes lengthy
+ }
+ $self->write_metadata_cache;
+ if ($CPAN::DEBUG){
+ $t2 = time;
+ $debug .= "03[".($t2 - $time)."]";
+ $time = $t2;
+ }
+ CPAN->debug($debug) if $CPAN::DEBUG;
+ }
+ if ($CPAN::Config->{build_dir_reuse}) {
+ $self->reanimate_build_dir;
+ }
+ if (CPAN::_sqlite_running()) {
+ $CPAN::SQLite->reload(time => $time, force => $force)
+ if not $LAST_TIME;
+ }
+ $LAST_TIME = $time;
+ $CPAN::META->{PROTOCOL} = PROTOCOL;
+}
+
+#-> sub CPAN::Index::reanimate_build_dir ;
+sub reanimate_build_dir {
+ my($self) = @_;
+ unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
+ return;
+ }
+ return if $HAVE_REANIMATED++;
+ my $d = $CPAN::Config->{build_dir};
+ my $dh = DirHandle->new;
+ opendir $dh, $d or return; # does not exist
+ my $dirent;
+ my $i = 0;
+ my $painted = 0;
+ my $restored = 0;
+ my @candidates = map { $_->[0] }
+ sort { $b->[1] <=> $a->[1] }
+ map { [ $_, -M File::Spec->catfile($d,$_) ] }
+ grep {/\.yml$/} readdir $dh;
+ unless (@candidates) {
+ $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
+ return;
+ }
+ $CPAN::Frontend->myprint
+ (sprintf("Going to read %d yaml file%s from %s/\n",
+ scalar @candidates,
+ @candidates==1 ? "" : "s",
+ $CPAN::Config->{build_dir}
+ ));
+ my $start = CPAN::FTP::_mytime();
+ DISTRO: for $i (0..$#candidates) {
+ my $dirent = $candidates[$i];
+ my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
+ if ($@) {
+ warn "Error while parsing file '$dirent'; error: '$@'";
+ next DISTRO;
+ }
+ my $c = $y->[0];
+ if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
+ my $key = $c->{distribution}{ID};
+ for my $k (keys %{$c->{distribution}}) {
+ if ($c->{distribution}{$k}
+ && ref $c->{distribution}{$k}
+ && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
+ $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
+ }
+ }
+
+ #we tried to restore only if element already
+ #exists; but then we do not work with metadata
+ #turned off.
+ my $do
+ = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
+ = $c->{distribution};
+ for my $skipper (qw(
+ badtestcnt
+ configure_requires_later
+ configure_requires_later_for
+ force_update
+ later
+ later_for
+ notest
+ should_report
+ sponsored_mods
+ prefs
+ negative_prefs_cache
+ )) {
+ delete $do->{$skipper};
+ }
+ if ($do->can("tested_ok_but_not_installed")) {
+ if ($do->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
+ } else {
+ next DISTRO;
+ }
+ }
+ $restored++;
+ }
+ $i++;
+ while (($painted/76) < ($i/@candidates)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ }
+ my $took = CPAN::FTP::_mytime() - $start;
+ $CPAN::Frontend->myprint(sprintf(
+ "DONE\nRestored the state of %s (in %.4f secs)\n",
+ $restored || "none",
+ $took,
+ ));
+}
+
+
+#-> sub CPAN::Index::reload_x ;
+sub reload_x {
+ my($cl,$wanted,$localname,$force) = @_;
+ $force |= 2; # means we're dealing with an index here
+ CPAN::HandleConfig->load; # we should guarantee loading wherever
+ # we rely on Config XXX
+ $localname ||= $wanted;
+ my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
+ $localname);
+ if (
+ -f $abs_wanted &&
+ -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
+ !($force & 1)
+ ) {
+ my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
+ $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
+ qq{day$s. I\'ll use that.});
+ return $abs_wanted;
+ } else {
+ $force |= 1; # means we're quite serious about it.
+ }
+ return CPAN::FTP->localize($wanted,$abs_wanted,$force);
+}
+
+#-> sub CPAN::Index::rd_authindex ;
+sub rd_authindex {
+ my($cl, $index_target) = @_;
+ return unless defined $index_target;
+ return if CPAN::_sqlite_running();
+ my @lines;
+ $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ local(*FH);
+ tie *FH, 'CPAN::Tarzip', $index_target;
+ local($/) = "\n";
+ local($_);
+ push @lines, split /\012/ while <FH>;
+ my $i = 0;
+ my $painted = 0;
+ foreach (@lines) {
+ my($userid,$fullname,$email) =
+ m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
+ $fullname ||= $email;
+ if ($userid && $fullname && $email) {
+ my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
+ $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
+ } else {
+ CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
+ }
+ $i++;
+ while (($painted/76) < ($i/@lines)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+}
+
+sub userid {
+ my($self,$dist) = @_;
+ $dist = $self->{'id'} unless defined $dist;
+ my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
+ $ret;
+}
+
+#-> sub CPAN::Index::rd_modpacks ;
+sub rd_modpacks {
+ my($self, $index_target) = @_;
+ return unless defined $index_target;
+ return if CPAN::_sqlite_running();
+ $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
+ local $_;
+ CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
+ my $slurp = "";
+ my $chunk;
+ while (my $bytes = $fh->READ(\$chunk,8192)) {
+ $slurp.=$chunk;
+ }
+ my @lines = split /\012/, $slurp;
+ CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
+ undef $fh;
+ # read header
+ my($line_count,$last_updated);
+ while (@lines) {
+ my $shift = shift(@lines);
+ last if $shift =~ /^\s*$/;
+ $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
+ $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
+ }
+ CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
+ if (not defined $line_count) {
+
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
+Please check the validity of the index file by comparing it to more
+than one CPAN mirror. I'll continue but problems seem likely to
+happen.\a
+});
+
+ $CPAN::Frontend->mysleep(5);
+ } elsif ($line_count != scalar @lines) {
+
+ $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
+contains a Line-Count header of %d but I see %d lines there. Please
+check the validity of the index file by comparing it to more than one
+CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
+$index_target, $line_count, scalar(@lines));
+
+ }
+ if (not defined $last_updated) {
+
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
+Please check the validity of the index file by comparing it to more
+than one CPAN mirror. I'll continue but problems seem likely to
+happen.\a
+});
+
+ $CPAN::Frontend->mysleep(5);
+ } else {
+
+ $CPAN::Frontend
+ ->myprint(sprintf qq{ Database was generated on %s\n},
+ $last_updated);
+ $DATE_OF_02 = $last_updated;
+
+ my $age = time;
+ if ($CPAN::META->has_inst('HTTP::Date')) {
+ require HTTP::Date;
+ $age -= HTTP::Date::str2time($last_updated);
+ } else {
+ $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
+ require Time::Local;
+ my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
+ $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
+ $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
+ }
+ $age /= 3600*24;
+ if ($age > 30) {
+
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: This index file is %d days old.
+ Please check the host you chose as your CPAN mirror for staleness.
+ I'll continue but problems seem likely to happen.\a\n},
+ $age);
+
+ } elsif ($age < -1) {
+
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: Your system date is %d days behind this index file!
+ System time: %s
+ Timestamp index file: %s
+ Please fix your system time, problems with the make command expected.\n},
+ -$age,
+ scalar gmtime,
+ $DATE_OF_02,
+ );
+
+ }
+ }
+
+
+ # A necessity since we have metadata_cache: delete what isn't
+ # there anymore
+ my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
+ CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
+ my(%exists);
+ my $i = 0;
+ my $painted = 0;
+ foreach (@lines) {
+ # before 1.56 we split into 3 and discarded the rest. From
+ # 1.57 we assign remaining text to $comment thus allowing to
+ # influence isa_perl
+ my($mod,$version,$dist,$comment) = split " ", $_, 4;
+ unless ($mod && defined $version && $dist) {
+ $CPAN::Frontend->mywarn("Could not split line[$_]\n");
+ next;
+ }
+ my($bundle,$id,$userid);
+
+ if ($mod eq 'CPAN' &&
+ ! (
+ CPAN::Queue->exists('Bundle::CPAN') ||
+ CPAN::Queue->exists('CPAN')
+ )
+ ) {
+ local($^W)= 0;
+ if ($version > $CPAN::VERSION) {
+ $CPAN::Frontend->mywarn(qq{
+ New CPAN.pm version (v$version) available.
+ [Currently running version is v$CPAN::VERSION]
+ You might want to try
+ install CPAN
+ reload cpan
+ to both upgrade CPAN.pm and run the new version without leaving
+ the current session.
+
+}); #});
+ $CPAN::Frontend->mysleep(2);
+ $CPAN::Frontend->myprint(qq{\n});
+ }
+ last if $CPAN::Signal;
+ } elsif ($mod =~ /^Bundle::(.*)/) {
+ $bundle = $1;
+ }
+
+ if ($bundle) {
+ $id = $CPAN::META->instance('CPAN::Bundle',$mod);
+ # Let's make it a module too, because bundles have so much
+ # in common with modules.
+
+ # Changed in 1.57_63: seems like memory bloat now without
+ # any value, so commented out
+
+ # $CPAN::META->instance('CPAN::Module',$mod);
+
+ } else {
+
+ # instantiate a module object
+ $id = $CPAN::META->instance('CPAN::Module',$mod);
+
+ }
+
+ # Although CPAN prohibits same name with different version the
+ # indexer may have changed the version for the same distro
+ # since the last time ("Force Reindexing" feature)
+ if ($id->cpan_file ne $dist
+ ||
+ $id->cpan_version ne $version
+ ) {
+ $userid = $id->userid || $self->userid($dist);
+ $id->set(
+ 'CPAN_USERID' => $userid,
+ 'CPAN_VERSION' => $version,
+ 'CPAN_FILE' => $dist,
+ );
+ }
+
+ # instantiate a distribution object
+ if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
+ # we do not need CONTAINSMODS unless we do something with
+ # this dist, so we better produce it on demand.
+
+ ## my $obj = $CPAN::META->instance(
+ ## 'CPAN::Distribution' => $dist
+ ## );
+ ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
+ } else {
+ $CPAN::META->instance(
+ 'CPAN::Distribution' => $dist
+ )->set(
+ 'CPAN_USERID' => $userid,
+ 'CPAN_COMMENT' => $comment,
+ );
+ }
+ if ($secondtime) {
+ for my $name ($mod,$dist) {
+ # $self->debug("exists name[$name]") if $CPAN::DEBUG;
+ $exists{$name} = undef;
+ }
+ }
+ $i++;
+ while (($painted/76) < ($i/@lines)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+ if ($secondtime) {
+ for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
+ for my $o ($CPAN::META->all_objects($class)) {
+ next if exists $exists{$o->{ID}};
+ $CPAN::META->delete($class,$o->{ID});
+ # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
+ # if $CPAN::DEBUG;
+ }
+ }
+ }
+}
+
+#-> sub CPAN::Index::rd_modlist ;
+sub rd_modlist {
+ my($cl,$index_target) = @_;
+ return unless defined $index_target;
+ return if CPAN::_sqlite_running();
+ $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
+ local $_;
+ my $slurp = "";
+ my $chunk;
+ while (my $bytes = $fh->READ(\$chunk,8192)) {
+ $slurp.=$chunk;
+ }
+ my @eval2 = split /\012/, $slurp;
+
+ while (@eval2) {
+ my $shift = shift(@eval2);
+ if ($shift =~ /^Date:\s+(.*)/) {
+ if ($DATE_OF_03 eq $1) {
+ $CPAN::Frontend->myprint("Unchanged.\n");
+ return;
+ }
+ ($DATE_OF_03) = $1;
+ }
+ last if $shift =~ /^\s*$/;
+ }
+ push @eval2, q{CPAN::Modulelist->data;};
+ local($^W) = 0;
+ my($compmt) = Safe->new("CPAN::Safe1");
+ my($eval2) = join("\n", @eval2);
+ CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
+ my $ret = $compmt->reval($eval2);
+ Carp::confess($@) if $@;
+ return if $CPAN::Signal;
+ my $i = 0;
+ my $until = keys(%$ret);
+ my $painted = 0;
+ CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
+ for (keys %$ret) {
+ my $obj = $CPAN::META->instance("CPAN::Module",$_);
+ delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
+ $obj->set(%{$ret->{$_}});
+ $i++;
+ while (($painted/76) < ($i/$until)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+}
+
+#-> sub CPAN::Index::write_metadata_cache ;
+sub write_metadata_cache {
+ my($self) = @_;
+ return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running();
+ return unless $CPAN::META->has_usable("Storable");
+ my $cache;
+ foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
+ CPAN::Distribution)) {
+ $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
+ }
+ my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
+ $cache->{last_time} = $LAST_TIME;
+ $cache->{DATE_OF_02} = $DATE_OF_02;
+ $cache->{PROTOCOL} = PROTOCOL;
+ $CPAN::Frontend->myprint("Going to write $metadata_file\n");
+ eval { Storable::nstore($cache, $metadata_file) };
+ $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
+}
+
+#-> sub CPAN::Index::read_metadata_cache ;
+sub read_metadata_cache {
+ my($self) = @_;
+ return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running();
+ return unless $CPAN::META->has_usable("Storable");
+ my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
+ return unless -r $metadata_file and -f $metadata_file;
+ $CPAN::Frontend->myprint("Going to read '$metadata_file'\n");
+ my $cache;
+ eval { $cache = Storable::retrieve($metadata_file) };
+ $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
+ if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
+ $LAST_TIME = 0;
+ return;
+ }
+ if (exists $cache->{PROTOCOL}) {
+ if (PROTOCOL > $cache->{PROTOCOL}) {
+ $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
+ "with protocol v%s, requiring v%s\n",
+ $cache->{PROTOCOL},
+ PROTOCOL)
+ );
+ return;
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
+ "with protocol v1.0\n");
+ return;
+ }
+ my $clcnt = 0;
+ my $idcnt = 0;
+ while(my($class,$v) = each %$cache) {
+ next unless $class =~ /^CPAN::/;
+ $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
+ while (my($id,$ro) = each %$v) {
+ $CPAN::META->{readwrite}{$class}{$id} ||=
+ $class->new(ID=>$id, RO=>$ro);
+ $idcnt++;
+ }
+ $clcnt++;
+ }
+ unless ($clcnt) { # sanity check
+ $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
+ return;
+ }
+ if ($idcnt < 1000) {
+ $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
+ "in $metadata_file\n");
+ return;
+ }
+ $CPAN::META->{PROTOCOL} ||=
+ $cache->{PROTOCOL}; # reading does not up or downgrade, but it
+ # does initialize to some protocol
+ $LAST_TIME = $cache->{last_time};
+ $DATE_OF_02 = $cache->{DATE_OF_02};
+ $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
+ if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
+ return;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/InfoObj.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/InfoObj.pm
new file mode 100755
index 00000000000..9198316c69f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/InfoObj.pm
@@ -0,0 +1,224 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::InfoObj;
+use strict;
+
+use CPAN::Debug;
+@CPAN::InfoObj::ISA = qw(CPAN::Debug);
+
+use Cwd qw(chdir);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+sub ro {
+ my $self = shift;
+ exists $self->{RO} and return $self->{RO};
+}
+
+#-> sub CPAN::InfoObj::cpan_userid
+sub cpan_userid {
+ my $self = shift;
+ my $ro = $self->ro;
+ if ($ro) {
+ return $ro->{CPAN_USERID} || "N/A";
+ } else {
+ $self->debug("ID[$self->{ID}]");
+ # N/A for bundles found locally
+ return "N/A";
+ }
+}
+
+sub id { shift->{ID}; }
+
+#-> sub CPAN::InfoObj::new ;
+sub new {
+ my $this = bless {}, shift;
+ %$this = @_;
+ $this
+}
+
+# The set method may only be used by code that reads index data or
+# otherwise "objective" data from the outside world. All session
+# related material may do anything else with instance variables but
+# must not touch the hash under the RO attribute. The reason is that
+# the RO hash gets written to Metadata file and is thus persistent.
+
+#-> sub CPAN::InfoObj::safe_chdir ;
+sub safe_chdir {
+ my($self,$todir) = @_;
+ # we die if we cannot chdir and we are debuggable
+ Carp::confess("safe_chdir called without todir argument")
+ unless defined $todir and length $todir;
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ if (-e $todir) {
+ unless (-x $todir) {
+ unless (chmod 0755, $todir) {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
+ "permission to change the permission; cannot ".
+ "chdir to '$todir'\n");
+ $CPAN::Frontend->mysleep(5);
+ $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
+ qq{to todir[$todir]: $!});
+ }
+ }
+ } else {
+ $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
+ }
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
+ qq{to todir[$todir] (a chmod has been issued): $!});
+ }
+ }
+}
+
+#-> sub CPAN::InfoObj::set ;
+sub set {
+ my($self,%att) = @_;
+ my $class = ref $self;
+
+ # This must be ||=, not ||, because only if we write an empty
+ # reference, only then the set method will write into the readonly
+ # area. But for Distributions that spring into existence, maybe
+ # because of a typo, we do not like it that they are written into
+ # the readonly area and made permanent (at least for a while) and
+ # that is why we do not "allow" other places to call ->set.
+ unless ($self->id) {
+ CPAN->debug("Bug? Empty ID, rejecting");
+ return;
+ }
+ my $ro = $self->{RO} =
+ $CPAN::META->{readonly}{$class}{$self->id} ||= {};
+
+ while (my($k,$v) = each %att) {
+ $ro->{$k} = $v;
+ }
+}
+
+#-> sub CPAN::InfoObj::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
+ push @m, sprintf "%-15s %s\n", $class, $id;
+ join "", @m;
+}
+
+#-> sub CPAN::InfoObj::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, $class, " id = $self->{ID}\n";
+ my $ro;
+ unless ($ro = $self->ro) {
+ if (substr($self->{ID},-1,1) eq ".") { # directory
+ $ro = +{};
+ } else {
+ $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ for (sort keys %$ro) {
+ # next if m/^(ID|RO)$/;
+ my $extra = "";
+ if ($_ eq "CPAN_USERID") {
+ $extra .= " (";
+ $extra .= $self->fullname;
+ my $email; # old perls!
+ if ($email = $CPAN::META->instance("CPAN::Author",
+ $self->cpan_userid
+ )->email) {
+ $extra .= " <$email>";
+ } else {
+ $extra .= " <no email>";
+ }
+ $extra .= ")";
+ } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
+ push @m, sprintf " %-12s %s\n", $_, $self->fullname;
+ next;
+ }
+ next unless defined $ro->{$_};
+ push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
+ }
+ KEY: for (sort keys %$self) {
+ next if m/^(ID|RO)$/;
+ unless (defined $self->{$_}) {
+ delete $self->{$_};
+ next KEY;
+ }
+ if (ref($self->{$_}) eq "ARRAY") {
+ push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
+ } elsif (ref($self->{$_}) eq "HASH") {
+ my $value;
+ if (/^CONTAINSMODS$/) {
+ $value = join(" ",sort keys %{$self->{$_}});
+ } elsif (/^prereq_pm$/) {
+ my @value;
+ my $v = $self->{$_};
+ for my $x (sort keys %$v) {
+ my @svalue;
+ for my $y (sort keys %{$v->{$x}}) {
+ push @svalue, "$y=>$v->{$x}{$y}";
+ }
+ push @value, "$x\:" . join ",", @svalue if @svalue;
+ }
+ $value = join ";", @value;
+ } else {
+ $value = $self->{$_};
+ }
+ push @m, sprintf(
+ " %-12s %s\n",
+ $_,
+ $value,
+ );
+ } else {
+ push @m, sprintf " %-12s %s\n", $_, $self->{$_};
+ }
+ }
+ join "", @m, "\n";
+}
+
+#-> sub CPAN::InfoObj::fullname ;
+sub fullname {
+ my($self) = @_;
+ $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
+}
+
+#-> sub CPAN::InfoObj::dump ;
+sub dump {
+ my($self, $what) = @_;
+ unless ($CPAN::META->has_inst("Data::Dumper")) {
+ $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
+ }
+ local $Data::Dumper::Sortkeys;
+ $Data::Dumper::Sortkeys = 1;
+ my $out = Data::Dumper::Dumper($what ? eval $what : $self);
+ if (length $out > 100000) {
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ my $pager = $CPAN::Config->{'pager'} || "cat";
+ $fh_pager->open("|$pager")
+ or die "Could not open pager $pager\: $!";
+ $fh_pager->print($out);
+ close $fh_pager;
+ } else {
+ $CPAN::Frontend->myprint($out);
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Inject.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Inject.pm
new file mode 100755
index 00000000000..af3dcd8c310
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Inject.pm
@@ -0,0 +1,514 @@
+package CPAN::Inject;
+
+=pod
+
+=head1 NAME
+
+CPAN::Inject - Base class for injecting distributions into CPAN sources
+
+=head1 SYNOPSIS
+
+ # Create the injector
+ my $cpan = CPAN::Inject->new(
+ sources => '/root/.cpan/sources', # Required field
+ author => 'LOCAL', # The default
+ );
+
+ # Add a file to the user
+ $cpan->add( file => 'some/random/Perl-Tarball-1.02.tar.gz' );
+
+ # What would have have to use when installing
+ # $path = 'LOCAL/Perl-Tarball-1.02.tar.gz';
+ my $path = $cpan->install_path( 'some/random/Perl-Tarball-1.02.tar.gz' );
+
+=head1 DESCRIPTION
+
+Following the release of L<CPAN::Mini>, the L<CPAN::Mini::Inject> module
+was created to add additional distributions into a minicpan mirror.
+
+While it was created for use with a minicpan mirror, similar
+functionality can be reused in other situations.
+
+B<CPAN::Inject> replicates the basics of this functionality.
+
+Specifically, it takes an arbitrary tarball and adds it to the CPAN
+sources directory for a particular author, and then add the new file
+to the F<CHECKSUMS> file.
+
+It does not reimplement the logic to add files to the indexes.
+
+The initial use this module was created for was to inject tarballs into
+the CPAN sources directory for the reserved LOCAL user, so that the can be
+installed via the CPAN shell, with automated recursion to CPAN dependencies.
+
+But although the number of functions is limited (current only C<add> exists,
+with the others to be added as needed) the implementation is very generic
+and sub-classable, so that it can be reused in other situations.
+
+=head1 METHODS
+
+=cut
+
+use 5.005;
+use strict;
+use Params::Util '_STRING';
+use File::stat ();
+use File::chmod ();
+use File::Spec ();
+use File::Path ();
+use File::Copy ();
+use File::Basename ();
+use CPAN::Checksums ();
+
+use vars qw{$VERSION $CHECK_OWNER};
+
+BEGIN {
+ $VERSION = '0.11';
+
+ # Attempt to determine whether or not we are capable
+ # of finding the owner of a directory.
+ # Unless someone set it to a hard-coded value before we
+ # started to load this module.
+ unless ( defined $CHECK_OWNER ) {
+ # Take a directory we know should exist...
+ my $root = File::Spec->rootdir();
+ unless ( -d $root ) {
+ die "Cannot determine if CPAN::Inject can operate on this platform";
+ }
+
+ # ... find the owner for it...
+ my $owner = File::stat::stat($root)->uid;
+
+ # ... and if it works, check again in the future.
+ # Unless someone set it already, in which case
+ $CHECK_OWNER = defined $owner ? 1 : '';
+ }
+
+ # And boolify the value, just to be a little safer
+ $CHECK_OWNER = !! $CHECK_OWNER;
+}
+
+
+
+
+
+#####################################################################
+# Constructor and Accessors
+
+=pod
+
+=head2 new
+
+ # Create the injector for the default LOCAL author
+ $cpan = CPAN::Inject->new(
+ sources => '/root/.cpan/sources',
+ );
+
+ # Create the injector for a specific author
+ $cpan = CPAN::Inject->new(
+ sources => '/root/.cpan/sources',
+ author => 'ADAMK',
+ );
+
+The C<new> constructor takes a set of named params and create a cpan
+injection object.
+
+* B<sources> - The compulsory C<sources> param should be the path to a
+directory that is the root of a mirror (or a partial mirror such as a
+L<CPAN::Cache> or a L<CPAN::Mini>).
+
+To retain the permissions and ownership integrity of the sources tree,
+you must be the owner of the C<sources> directory in order to inject the
+distribution tarballs.
+
+* B<author> - The optional C<author> param should be the CPAN id of an
+author. By default, the reserved local CPAN id "LOCAL" will be used.
+
+The author provided will be used as a default in all further actions.
+
+Returns a C<CPAN::Inject> object, or throws an exception on error.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {@_}, $class;
+
+ # Check where we are going to write to
+ my $sources = $self->sources;
+ unless ( _STRING($sources) ) {
+ Carp::croak("Did not probide a sources param, or not a string");
+ }
+ unless ( -d $sources ) {
+ # The sources directory may actually exist, but we cannot
+ # see it because we do not have execute permissions to the
+ # parent directory tree.
+ # For example, if it is at /root/.cpan/source and we do not
+ # have -x permissions to /root
+ my ($v, $d) = File::Spec->splitpath( $sources, 'nofile' );
+ my @dirs = File::Spec->splitdir( $d );
+
+ # Ignore the last directory, since that is what we -d tested
+ pop @dirs;
+
+ # Check for the existance and rx status of each parent
+ foreach my $i ( 0 .. $#dirs ) {
+ my $parent = File::Spec->catpath(
+ $v,
+ File::Spec->catdir( @dirs[0..$i] ),
+ '', # No file (returns just the dir)
+ );
+ unless ( -d $parent ) {
+ Carp::croak("The directory '$sources' does not exist");
+ }
+ unless ( -r $parent and -x $parent ) {
+ # Assume that it does exist, but that we can't see it
+ Carp::croak("The sources directory is not owned by the current user");
+ }
+ }
+ Carp::croak("The directory '$sources' does not exist");
+ }
+ unless ( $< == File::stat::stat($sources)->uid ) {
+ Carp::croak("The sources directory is not owned by the current user");
+ }
+
+ # Check for a default author name
+ $self->{author} = 'LOCAL' unless $self->author;
+ unless ( _AUTHOR( $self->author ) ) {
+ Carp::croak( "The author name '"
+ . $self->author
+ . "' is not a valid author string"
+ );
+ }
+
+ $self;
+}
+
+=pod
+
+=head2 from_cpan_config
+
+The C<from_cpan_config> constructor loads the CPAN.pm configuration file, and
+uses the data contained within to specific the sources path for the
+object.
+
+This constructor is otherwise the same.
+
+Returns a B<CPAN::Inject> object on success, or throws an exception on
+error.
+
+=cut
+
+sub from_cpan_config {
+ my $class = shift;
+
+ # Load the CPAN module
+ require CPAN;
+
+ # Support for different mechanisms depending on the version
+ # of CPAN that is in use.
+ if ( defined $CPAN::HandleConfig::VERSION ) {
+ CPAN::HandleConfig->load;
+ } else {
+ CPAN::Config->load;
+ }
+
+ # Get the sources directory
+ my $sources = undef;
+ if ( defined $CPAN::Config->{keep_source_where} ) {
+ $sources = $CPAN::Config->{keep_source_where};
+ } elsif ( defined $CPAN::Config->{cpan_home} ) {
+ $sources = File::Spec->catdir( $CPAN::Config->{cpan_home}, 'sources' );
+ } else {
+ Carp::croak("Failed to find sources directory in CPAN::Config");
+ }
+
+ # Hand off to the main constructor
+ return $class->new(
+ sources => $sources,
+ @_,
+ );
+}
+
+=pod
+
+=head2 sources
+
+The C<sources> accessor returns the path to the root of the directory tree.
+
+=cut
+
+sub sources {
+ $_[0]->{sources};
+}
+
+=pod
+
+=head2 author
+
+The C<author> accessor returns the CPAN id for the default author which
+will be "LOCAL" if you did not provide an alternative param to the the
+C<new> constructor.
+
+=cut
+
+sub author {
+ $_[0]->{author};
+}
+
+
+
+
+
+#####################################################################
+# Main methods
+
+=pod
+
+=head2 add
+
+ # Add a file to the constructor/default author
+ $cpan->add( file => 'any/arbitrary/Perl-Tarball-1.01.tar.gz' );
+
+The C<add> method takes a Perl distribution tarball from an arbitrary
+path, and adds it to the sources path.
+
+The specific location the tarball is copied to will be in the root
+directory for the author provided to the constructor.
+
+Returns the install_path value as a convenience, or throws an exception
+on error.
+
+=cut
+
+sub add {
+ my $self = shift;
+ my %params = @_;
+
+ # Check the file source path
+ my $from_file = $params{file};
+ unless ( $from_file and -f $from_file and -r $from_file ) {
+ Carp::croak("Did not provide a file name, or does not exist");
+ }
+
+ # Get the file name
+ my $name = File::Basename::fileparse($from_file)
+ or die "Failed to get filename";
+
+ # Find the location to copy it to
+ my $to_file = $self->file_path($name);
+ my $to_dir = File::Basename::dirname($to_file);
+
+ # Make the path for the file
+ eval { File::Path::mkpath($to_dir) };
+ if ( my $e = $@ ) {
+ Carp::croak("Failed to create $to_dir: $e");
+ }
+
+ # Copy the file to the directory, and ensure writable
+ File::Copy::copy( $from_file => $to_file )
+ or Carp::croak("Failed to copy $from_file to $to_file");
+ chmod( 0644, $to_file )
+ or Carp::croak("Failed to correct permissions for $to_file");
+
+ # Update the checksums file, and ensure writable
+ eval { CPAN::Checksums::updatedir($to_dir); };
+ if ( my $e = $@ ) {
+ Carp::croak("Failed to update CHECKSUMS after insertion: $e");
+ }
+ chmod( 0644, File::Spec->catfile( $to_dir, 'CHECKSUMS' ) )
+ or Carp::croak("Failed to correct permissions for CHECKSUMS");
+
+ # Return the install_path as a convenience
+ $self->install_path($name);
+}
+
+=pod
+
+=head2 remove
+
+ # Remove a distribution from the repository
+ $cpan->remove( dist => 'LOCAL/Perl-Tarball-1.01.tar.gz' );
+
+The C<remove> method takes a distribution path and removes it from the
+sources path. The file is also removed.
+
+Does not return anything useful and throws an exception on error.
+
+=cut
+
+sub remove {
+ my $self = shift;
+ my %params = @_;
+
+ # Get the file name
+ my $name = File::Basename::fileparse($params{dist})
+ or die "Failed to get filename";
+
+ my $file_path = $self->file_path($name);
+
+ # Remove the file from CPAN.
+ unlink $file_path while -e $file_path;
+
+ # Update the checksums file
+ my $to_file = $self->file_path($name);
+ my $to_dir = File::Basename::dirname($to_file);
+ eval { CPAN::Checksums::updatedir($to_dir); };
+ if ( my $e = $@ ) {
+ Carp::croak("Failed to update CHECKSUMS after removal: $e");
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 author_subpath
+
+ # $path = 'authors/id/L/LO/LOCAL'
+ $path = $cpan->author_subpath;
+
+The C<author_subpath> method takes a CPAN author id (or uses the CPAN
+author id originally provided to the constructor) and returns the
+relative subpath for the AUTHOR within the sources tree.
+
+Returns the subpath as a string.
+
+=cut
+
+sub author_subpath {
+ my $author = $_[0]->author;
+ File::Spec->catdir(
+ 'authors', 'id',
+ substr( $author, 0, 1 ),
+ substr( $author, 0, 2 ), $author,
+ );
+}
+
+=pod
+
+=head2 author_path
+
+ # $path = '/root/.cpan/sources/authors/id/L/LO/LOCAL'
+ $path = $cpan->author_subpath;
+
+The C<author_path> method finds the full path for the root directory for
+the named author.
+
+Returns the path as a string.
+
+=cut
+
+sub author_path {
+ File::Spec->catdir( $_[0]->sources, $_[0]->author_subpath, );
+}
+
+=pod
+
+=head2 file_path
+
+ # $path = '/root/.cpan/sources/authors/id/L/LO/LOCAL/Perl-Tarball-1.02.tar.gz'
+ $path = $cpan->file_path( 'Perl-Tarball-1.02.tar.gz' );
+ $path = $cpan->file_path( '/some/random/place/Perl-Tarball-1.02.tar.gz' );
+
+The C<file_path> method takes the name of a tarball (either just the name
+or a full path) and calculates the location that the file will end up at.
+
+When files are copied into the sources directory, they are always copied
+to the top level of the author root.
+
+Returns the path as a string.
+
+=cut
+
+sub file_path {
+ File::Spec->catfile( $_[0]->sources, $_[0]->author_subpath, $_[1], );
+}
+
+=pod
+
+=head2 install_path
+
+ # $path = 'LOCAL/Perl-Tarball-1.01.tar.gz';
+ $path = $cpan->install_path( 'Perl-Tarball-1.01.tar.gz' );
+ $path = $cpan->install_path( '/some/random/place/Perl-Tarball-1.02.tar.gz' );
+
+The C<install_path> method returns the path for the distribution as the
+CPAN shell understands it.
+
+Using this path, the CPAN shell can expand it to locate the
+distribution, and then can install it.
+
+Returns the path as a string.
+
+=cut
+
+sub install_path {
+ my $self = shift;
+ my $file = File::Basename::fileparse(shift)
+ or Carp::croak("Failed to get filename");
+ join( '/', $self->author, $file );
+}
+
+
+
+
+
+#####################################################################
+# Support Functions
+
+sub _AUTHOR {
+ ( _STRING( $_[0] ) and $_[0] =~ /^[A-Z]{3,}$/ ) ? $_[0] : undef;
+}
+
+1;
+
+=pod
+
+=head1 SUPPORT
+
+This module is stored in an Open Repository at the following address.
+
+L<http://svn.ali.as/cpan/trunk/CPAN-Inject>
+
+Write access to the repository is made available automatically to any
+published CPAN author, and to most other volunteers on request.
+
+If you are able to submit your bug report in the form of new (failing)
+unit tests, or can apply your fix directly instead of submitting a patch,
+you are B<strongly> encouraged to do so as the author currently maintains
+over 100 modules and it can take some time to deal with non-Critcal bug
+reports or patches.
+
+This will guarentee that your issue will be addressed in the next
+release of the module.
+
+If you cannot provide a direct test or fix, or don't have time to do so,
+then regular bug reports are still accepted and appreciated via the CPAN
+bug tracker.
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPAN-Inject>
+
+For other issues, for commercial enhancement or support, or to have your
+write access enabled for the repository, contact the author at the email
+address above.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<CPAN::Mini::Inject>
+
+=head1 COPYRIGHT
+
+Copyright 2006 - 2007 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify.pm
new file mode 100755
index 00000000000..3cade90b91a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify.pm
@@ -0,0 +1,136 @@
+=head1 NAME
+
+CPAN::Kwalify - Interface between CPAN.pm and Kwalify.pm
+
+=head1 SYNOPSIS
+
+ use CPAN::Kwalify;
+ validate($schema_name, $data, $file, $doc);
+
+=head1 DESCRIPTION
+
+=over
+
+=item _validate($schema_name, $data, $file, $doc)
+
+$schema_name is the name of a supported schema. Currently only
+C<distroprefs> is supported. $data is the data to be validated. $file
+is the absolute path to the file the data are coming from. $doc is the
+index of the document within $doc that is to be validated. The last
+two arguments are only there for better error reporting.
+
+Relies on being called from within CPAN.pm.
+
+Dies if something fails. Does not return anything useful.
+
+=item yaml($schema_name)
+
+Returns the YAML text of that schema. Dies if something fails.
+
+=back
+
+=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>
+
+
+
+=cut
+
+
+use strict;
+
+package CPAN::Kwalify;
+use vars qw($VERSION $VAR1);
+$VERSION = "5.50";
+
+use File::Spec ();
+
+my %vcache = ();
+
+my $schema_loaded = {};
+
+sub _validate {
+ my($schema_name,$data,$abs,$y) = @_;
+ my $yaml_module = CPAN->_yaml_module;
+ if (
+ $CPAN::META->has_inst($yaml_module)
+ &&
+ $CPAN::META->has_inst("Kwalify")
+ ) {
+ my $load = UNIVERSAL::can($yaml_module,"Load");
+ unless ($schema_loaded->{$schema_name}) {
+ eval {
+ my $schema_yaml = yaml($schema_name);
+ $schema_loaded->{$schema_name} = $load->($schema_yaml);
+ };
+ if ($@) {
+ # we know that YAML.pm 0.62 cannot parse the schema,
+ # so we try a fallback
+ my $content = do {
+ my $path = __FILE__;
+ $path =~ s/\.pm$//;
+ $path = File::Spec->catfile($path, "$schema_name.dd");
+ local *FH;
+ open FH, $path or die "Could not open '$path': $!";
+ local $/;
+ <FH>;
+ };
+ $VAR1 = undef;
+ eval $content;
+ if (my $err = $@) {
+ die "parsing of '$schema_name.dd' failed: $err";
+ }
+ $schema_loaded->{$schema_name} = $VAR1;
+ }
+ }
+ }
+ if (my $schema = $schema_loaded->{$schema_name}) {
+ my $mtime = (stat $abs)[9];
+ for my $k (keys %{$vcache{$abs}}) {
+ delete $vcache{$abs}{$k} unless $k eq $mtime;
+ }
+ return if $vcache{$abs}{$mtime}{$y}++;
+ eval { Kwalify::validate($schema, $data) };
+ if (my $err = $@) {
+ my $info = {}; yaml($schema_name, info => $info);
+ die "validation of distropref '$abs'[$y] against schema '$info->{path}' failed: $err";
+ }
+ }
+}
+
+sub _clear_cache {
+ %vcache = ();
+}
+
+sub yaml {
+ my($schema_name, %opt) = @_;
+ my $content = do {
+ my $path = __FILE__;
+ $path =~ s/\.pm$//;
+ $path = File::Spec->catfile($path, "$schema_name.yml");
+ if ($opt{info}) {
+ $opt{info}{path} = $path;
+ }
+ local *FH;
+ open FH, $path or die "Could not open '$path': $!";
+ local $/;
+ <FH>;
+ };
+ return $content;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End:
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.dd b/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.dd
new file mode 100755
index 00000000000..fd046271b87
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.dd
@@ -0,0 +1,150 @@
+$VAR1 = {
+ "mapping" => {
+ "comment" => {
+ "type" => "text"
+ },
+ "cpanconfig" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "depends" => {
+ "mapping" => {
+ "build_requires" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "configure_requires" => {},
+ "requires" => {}
+ },
+ "type" => "map"
+ },
+ "disabled" => {
+ "enum" => [
+ 0,
+ 1
+ ],
+ "type" => "int"
+ },
+ "features" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "goto" => {
+ "type" => "text"
+ },
+ "install" => {
+ "mapping" => {
+ "args" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "commandline" => {
+ "type" => "text"
+ },
+ "eexpect" => {
+ "mapping" => {
+ "mode" => {
+ "enum" => [
+ "deterministic",
+ "anyorder"
+ ],
+ "type" => "text"
+ },
+ "reuse" => {
+ "type" => "int"
+ },
+ "talk" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "timeout" => {
+ "type" => "number"
+ }
+ },
+ "type" => "map"
+ },
+ "env" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "expect" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ }
+ },
+ "type" => "map"
+ },
+ "make" => {},
+ "match" => {
+ "mapping" => {
+ "distribution" => {
+ "type" => "text"
+ },
+ "env" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "module" => {
+ "type" => "text"
+ },
+ "perl" => {
+ "type" => "text"
+ },
+ "perlconfig" => {}
+ },
+ "type" => "map"
+ },
+ "patches" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "pl" => {},
+ "reminder" => {
+ "type" => "text"
+ },
+ "test" => {}
+ },
+ "type" => "map"
+};
+$VAR1->{"mapping"}{"depends"}{"mapping"}{"configure_requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
+$VAR1->{"mapping"}{"depends"}{"mapping"}{"requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
+$VAR1->{"mapping"}{"make"} = $VAR1->{"mapping"}{"install"};
+$VAR1->{"mapping"}{"match"}{"mapping"}{"perlconfig"} = $VAR1->{"mapping"}{"match"}{"mapping"}{"env"};
+$VAR1->{"mapping"}{"pl"} = $VAR1->{"mapping"}{"install"};
+$VAR1->{"mapping"}{"test"} = $VAR1->{"mapping"}{"install"};
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.yml b/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.yml
new file mode 100755
index 00000000000..431f1742767
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Kwalify/distroprefs.yml
@@ -0,0 +1,92 @@
+---
+type: map
+mapping:
+ comment:
+ type: text
+ depends:
+ type: map
+ mapping:
+ configure_requires:
+ &requires_common
+ type: map
+ mapping:
+ =:
+ type: text
+ build_requires: *requires_common
+ requires: *requires_common
+ match:
+ type: map
+ mapping:
+ distribution:
+ type: text
+ module:
+ type: text
+ perl:
+ type: text
+ perlconfig:
+ &matchhash_common
+ type: map
+ mapping:
+ =:
+ type: text
+ env: *matchhash_common
+ install:
+ &args_env_expect
+ type: map
+ mapping:
+ args:
+ type: seq
+ sequence:
+ - type: text
+ commandline:
+ type: text
+ env:
+ type: map
+ mapping:
+ =:
+ type: text
+ expect:
+ type: seq
+ sequence:
+ - type: text
+ eexpect:
+ type: map
+ mapping:
+ mode:
+ type: text
+ enum:
+ - deterministic
+ - anyorder
+ timeout:
+ type: number
+ reuse:
+ type: int
+ talk:
+ type: seq
+ sequence:
+ - type: text
+ make: *args_env_expect
+ pl: *args_env_expect
+ test: *args_env_expect
+ patches:
+ type: seq
+ sequence:
+ - type: text
+ disabled:
+ type: int
+ enum:
+ - 0
+ - 1
+ goto:
+ type: text
+ cpanconfig:
+ type: map
+ mapping:
+ =:
+ type: text
+ features:
+ type: seq
+ sequence:
+ - type: text
+ reminder:
+ type: text
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/LWP/UserAgent.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/LWP/UserAgent.pm
new file mode 100755
index 00000000000..7bb86f9a15d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/LWP/UserAgent.pm
@@ -0,0 +1,135 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::LWP::UserAgent;
+use strict;
+use vars qw(@ISA $USER $PASSWD $SETUPDONE);
+# we delay requiring LWP::UserAgent and setting up inheritance until we need it
+
+$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.94";
+
+sub config {
+ return if $SETUPDONE;
+ if ($CPAN::META->has_usable('LWP::UserAgent')) {
+ require LWP::UserAgent;
+ @ISA = qw(Exporter LWP::UserAgent); ## no critic
+ $SETUPDONE++;
+ } else {
+ $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
+ }
+}
+
+sub get_basic_credentials {
+ my($self, $realm, $uri, $proxy) = @_;
+ if ($USER && $PASSWD) {
+ return ($USER, $PASSWD);
+ }
+ if ( $proxy ) {
+ ($USER,$PASSWD) = $self->get_proxy_credentials();
+ } else {
+ ($USER,$PASSWD) = $self->get_non_proxy_credentials();
+ }
+ return($USER,$PASSWD);
+}
+
+sub get_proxy_credentials {
+ my $self = shift;
+ my ($user, $password);
+ if ( defined $CPAN::Config->{proxy_user} ) {
+ $user = $CPAN::Config->{proxy_user};
+ $password = $CPAN::Config->{proxy_pass} || "";
+ return ($user, $password);
+ }
+ my $username_prompt = "\nProxy authentication needed!
+ (Note: to permanently configure username and password run
+ o conf proxy_user your_username
+ o conf proxy_pass your_password
+ )\nUsername:";
+ ($user, $password) =
+ _get_username_and_password_from_user($username_prompt);
+ return ($user,$password);
+}
+
+sub get_non_proxy_credentials {
+ my $self = shift;
+ my ($user,$password);
+ if ( defined $CPAN::Config->{username} ) {
+ $user = $CPAN::Config->{username};
+ $password = $CPAN::Config->{password} || "";
+ return ($user, $password);
+ }
+ my $username_prompt = "\nAuthentication needed!
+ (Note: to permanently configure username and password run
+ o conf username your_username
+ o conf password your_password
+ )\nUsername:";
+
+ ($user, $password) =
+ _get_username_and_password_from_user($username_prompt);
+ return ($user,$password);
+}
+
+sub _get_username_and_password_from_user {
+ my $username_message = shift;
+ my ($username,$password);
+
+ ExtUtils::MakeMaker->import(qw(prompt));
+ $username = prompt($username_message);
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("noecho");
+ }
+ else {
+ $CPAN::Frontend->mywarn(
+ "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
+ );
+ }
+ $password = prompt("Password:");
+
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("restore");
+ }
+ $CPAN::Frontend->myprint("\n\n");
+ return ($username,$password);
+}
+
+# mirror(): Its purpose is to deal with proxy authentication. When we
+# call SUPER::mirror, we relly call the mirror method in
+# LWP::UserAgent. LWP::UserAgent will then call
+# $self->get_basic_credentials or some equivalent and this will be
+# $self->dispatched to our own get_basic_credentials method.
+
+# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
+
+# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
+# although we have gone through our get_basic_credentials, the proxy
+# server refuses to connect. This could be a case where the username or
+# password has changed in the meantime, so I'm trying once again without
+# $USER and $PASSWD to give the get_basic_credentials routine another
+# chance to set $USER and $PASSWD.
+
+# mirror(): Its purpose is to deal with proxy authentication. When we
+# call SUPER::mirror, we relly call the mirror method in
+# LWP::UserAgent. LWP::UserAgent will then call
+# $self->get_basic_credentials or some equivalent and this will be
+# $self->dispatched to our own get_basic_credentials method.
+
+# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
+
+# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
+# although we have gone through our get_basic_credentials, the proxy
+# server refuses to connect. This could be a case where the username or
+# password has changed in the meantime, so I'm trying once again without
+# $USER and $PASSWD to give the get_basic_credentials routine another
+# chance to set $USER and $PASSWD.
+
+sub mirror {
+ my($self,$url,$aslocal) = @_;
+ my $result = $self->SUPER::mirror($url,$aslocal);
+ if ($result->code == 407) {
+ undef $USER;
+ undef $PASSWD;
+ $result = $self->SUPER::mirror($url,$aslocal);
+ }
+ $result;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Mirrors.pm
new file mode 100755
index 00000000000..1a3402e8de5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Mirrors.pm
@@ -0,0 +1,260 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Mirrors;
+use strict;
+use vars qw($VERSION $urllist $silent);
+$VERSION = "1.77";
+
+use Carp;
+use FileHandle;
+use Fcntl ":flock";
+
+sub new {
+ my ($class, $file) = @_;
+ my $self = bless {
+ mirrors => [],
+ geography => {},
+ }, $class;
+
+ my $handle = FileHandle->new;
+ $handle->open($file)
+ or croak "Couldn't open $file: $!";
+ flock $handle, LOCK_SH;
+ $self->_parse($file,$handle);
+ flock $handle, LOCK_UN;
+ $handle->close;
+
+ # populate continents & countries
+
+ return $self
+}
+
+sub continents {
+ my ($self) = @_;
+ return keys %{$self->{geography}};
+}
+
+sub countries {
+ my ($self, @continents) = @_;
+ @continents = $self->continents unless @continents;
+ my @countries;
+ for my $c (@continents) {
+ push @countries, keys %{ $self->{geography}{$c} };
+ }
+ return @countries;
+}
+
+sub mirrors {
+ my ($self, @countries) = @_;
+ return @{$self->{mirrors}} unless @countries;
+ my %wanted = map { $_ => 1 } @countries;
+ my @found;
+ for my $m (@{$self->{mirrors}}) {
+ push @found, $m if exists $wanted{$m->country};
+ }
+ return @found;
+}
+
+sub best_mirrors {
+ my ($self, %args) = @_;
+ my $how_many = $args{how_many} || 1;
+ my $callback = $args{callback};
+ my $verbose = $args{verbose};
+ my $conts = $args{continents} || [];
+ $conts = [$conts] unless ref $conts;
+
+ my $seen = {};
+
+ if ( ! @$conts ) {
+ print "Searching for the best continent ...\n" if $verbose;
+ my @best = $self->_find_best_continent($seen, $verbose, $callback);
+
+ # how many continents to find enough mirrors? We should scan
+ # more than we need -- arbitrarily, we'll say x2
+ my $count = 0;
+ for my $c ( @best ) {
+ push @$conts, $c;
+ $count += $self->mirrors( $self->countries($c) );
+ last if $count >= 2 * $how_many;
+ }
+ }
+
+ print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
+
+ my @timings;
+ for my $m ($self->mirrors($self->countries(@$conts))) {
+ next unless $m->ftp;
+ my $hostname = $m->hostname;
+ if ( $seen->{$hostname} ) {
+ push @timings, $seen->{$hostname}
+ if defined $seen->{$hostname}[1];
+ }
+ else {
+ my $ping = $m->ping;
+ next unless defined $ping;
+ push @timings, [$m, $ping];
+ $callback->($m,$ping) if $callback;
+ }
+ }
+ return unless @timings;
+ $how_many = @timings if $how_many > @timings;
+ my @best =
+ map { $_->[0] }
+ sort { $a->[1] <=> $b->[1] } @timings;
+
+ return wantarray ? @best[0 .. $how_many-1] : $best[0];
+}
+
+sub _find_best_continent {
+ my ($self, $seen, $verbose, $callback) = @_;
+
+ my %median;
+ CONT: for my $c ( $self->continents ) {
+ my @mirrors = $self->mirrors( $self->countries($c) );
+ next CONT unless @mirrors;
+ my $sample = 9;
+ my $n = (@mirrors < $sample) ? @mirrors : $sample;
+ my @tests;
+ RANDOM: while ( @mirrors && @tests < $n ) {
+ my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
+ my $ping = $m->ping;
+ $callback->($m,$ping) if $callback;
+ # record undef so we don't try again
+ $seen->{$m->hostname} = [$m, $ping];
+ next RANDOM unless defined $ping;
+ push @tests, $ping;
+ }
+ next CONT unless @tests;
+ @tests = sort { $a <=> $b } @tests;
+ if ( @tests == 1 ) {
+ $median{$c} = $tests[0];
+ }
+ elsif ( @tests % 2 ) {
+ $median{$c} = $tests[ int(@tests / 2) ];
+ }
+ else {
+ my $mid_high = int(@tests/2);
+ $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2;
+ }
+ }
+
+ my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
+
+ if ( $verbose ) {
+ print "Median result by continent:\n";
+ for my $c ( @best_cont ) {
+ printf( " %d ms %s\n", int($median{$c}*1000+.5), $c );
+ }
+ }
+
+ return wantarray ? @best_cont : $best_cont[0];
+}
+
+# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
+sub _parse {
+ my ($self, $file, $handle) = @_;
+ my $output = $self->{mirrors};
+ my $geo = $self->{geography};
+
+ local $/ = "\012";
+ my $line = 0;
+ my $mirror = undef;
+ while ( 1 ) {
+ # Next line
+ my $string = <$handle>;
+ last if ! defined $string;
+ $line = $line + 1;
+
+ # Remove the useless lines
+ chomp( $string );
+ next if $string =~ /^\s*$/;
+ next if $string =~ /^\s*#/;
+
+ # Hostname or property?
+ if ( $string =~ /^\s/ ) {
+ # Property
+ unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
+ croak("Invalid property on line $line");
+ }
+ my ($prop, $value) = ($1,$2);
+ $mirror ||= {};
+ if ( $prop eq 'dst_location' ) {
+ my (@location,$continent,$country);
+ @location = (split /\s*,\s*/, $value)
+ and ($continent, $country) = @location[-1,-2];
+ $continent =~ s/\s\(.*//;
+ $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
+ $geo->{$continent}{$country} = 1 if $continent && $country;
+ $mirror->{continent} = $continent || "unknown";
+ $mirror->{country} = $country || "unknown";
+ }
+ elsif ( $prop eq 'dst_http' ) {
+ $mirror->{http} = $value;
+ }
+ elsif ( $prop eq 'dst_ftp' ) {
+ $mirror->{ftp} = $value;
+ }
+ elsif ( $prop eq 'dst_rsync' ) {
+ $mirror->{rsync} = $value;
+ }
+ else {
+ $prop =~ s/^dst_//;
+ $mirror->{$prop} = $value;
+ }
+ } else {
+ # Hostname
+ unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
+ croak("Invalid host name on line $line");
+ }
+ my $current = $mirror;
+ $mirror = { hostname => "$1" };
+ if ( $current ) {
+ push @$output, CPAN::Mirrored::By->new($current);
+ }
+ }
+ }
+ if ( $mirror ) {
+ push @$output, CPAN::Mirrored::By->new($mirror);
+ }
+
+ return;
+}
+
+#--------------------------------------------------------------------------#
+
+package CPAN::Mirrored::By;
+use strict;
+use Net::Ping ();
+
+sub new {
+ my($self,$arg) = @_;
+ $arg ||= {};
+ bless $arg, $self;
+}
+sub hostname { shift->{hostname} }
+sub continent { shift->{continent} }
+sub country { shift->{country} }
+sub http { shift->{http} || '' }
+sub ftp { shift->{ftp} || '' }
+sub rsync { shift->{rsync} || '' }
+
+sub url {
+ my $self = shift;
+ return $self->{ftp} || $self->{http};
+}
+
+sub ping {
+ my $self = shift;
+ my $ping = Net::Ping->new("tcp",1);
+ my ($proto) = $self->url =~ m{^([^:]+)};
+ my $port = $proto eq 'http' ? 80 : 21;
+ return unless $port;
+ $ping->port_number($port);
+ $ping->hires(1);
+ my ($alive,$rtt) = $ping->ping($self->hostname);
+ return $alive ? $rtt : undef;
+}
+
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Module.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Module.pm
new file mode 100755
index 00000000000..43c42bf1049
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Module.pm
@@ -0,0 +1,688 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Module;
+use strict;
+@CPAN::Module::ISA = qw(CPAN::InfoObj);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+BEGIN {
+ # alarm() is not implemented in perl 5.6.x and earlier under Windows
+ *ALARM_IMPLEMENTED = sub () { $] >= 5.007 || $^O !~ /MSWin/ };
+}
+
+# Accessors
+#-> sub CPAN::Module::userid
+sub userid {
+ my $self = shift;
+ my $ro = $self->ro;
+ return unless $ro;
+ return $ro->{userid} || $ro->{CPAN_USERID};
+}
+#-> sub CPAN::Module::description
+sub description {
+ my $self = shift;
+ my $ro = $self->ro or return "";
+ $ro->{description}
+}
+
+#-> sub CPAN::Module::distribution
+sub distribution {
+ my($self) = @_;
+ CPAN::Shell->expand("Distribution",$self->cpan_file);
+}
+
+#-> sub CPAN::Module::_is_representative_module
+sub _is_representative_module {
+ my($self) = @_;
+ return $self->{_is_representative_module} if defined $self->{_is_representative_module};
+ my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
+ $pm =~ s|.+/||;
+ $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
+ $pm =~ s|-\d+\.\d+.+$||;
+ $pm =~ s|-[\d\.]+$||;
+ $pm =~ s/-/::/g;
+ $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
+ # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
+ $self->{_is_representative_module};
+}
+
+#-> sub CPAN::Module::undelay
+sub undelay {
+ my $self = shift;
+ delete $self->{later};
+ if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
+ $dist->undelay;
+ }
+}
+
+# mark as dirty/clean
+#-> sub CPAN::Module::color_cmd_tmps ;
+sub color_cmd_tmps {
+ my($self) = shift;
+ my($depth) = shift || 0;
+ my($color) = shift || 0;
+ my($ancestors) = shift || [];
+ # a module needs to recurse to its cpan_file
+
+ return if exists $self->{incommandcolor}
+ && $color==1
+ && $self->{incommandcolor}==$color;
+ return if $color==0 && !$self->{incommandcolor};
+ if ($color>=1) {
+ if ( $self->uptodate ) {
+ $self->{incommandcolor} = $color;
+ return;
+ } elsif (my $have_version = $self->available_version) {
+ # maybe what we have is good enough
+ if (@$ancestors) {
+ my $who_asked_for_me = $ancestors->[-1];
+ my $obj = CPAN::Shell->expandany($who_asked_for_me);
+ if (0) {
+ } elsif ($obj->isa("CPAN::Bundle")) {
+ # bundles cannot specify a minimum version
+ return;
+ } elsif ($obj->isa("CPAN::Distribution")) {
+ if (my $prereq_pm = $obj->prereq_pm) {
+ for my $k (keys %$prereq_pm) {
+ if (my $want_version = $prereq_pm->{$k}{$self->id}) {
+ if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
+ $self->{incommandcolor} = $color;
+ return;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ $self->{incommandcolor} = $color; # set me before recursion,
+ # so we can break it
+ }
+ if ($depth>=$CPAN::MAX_RECURSION) {
+ die(CPAN::Exception::RecursiveDependency->new($ancestors));
+ }
+ # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+
+ if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
+ $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
+ }
+ # unreached code?
+ # if ($color==0) {
+ # delete $self->{badtestcnt};
+ # }
+ $self->{incommandcolor} = $color;
+}
+
+#-> sub CPAN::Module::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ my $color_on = "";
+ my $color_off = "";
+ if (
+ $CPAN::Shell::COLOR_REGISTERED
+ &&
+ $CPAN::META->has_inst("Term::ANSIColor")
+ &&
+ $self->description
+ ) {
+ $color_on = Term::ANSIColor::color("green");
+ $color_off = Term::ANSIColor::color("reset");
+ }
+ my $uptodateness = " ";
+ unless ($class eq "Bundle") {
+ my $u = $self->uptodate;
+ $uptodateness = $u ? "=" : "<" if defined $u;
+ };
+ my $id = do {
+ my $d = $self->distribution;
+ $d ? $d -> pretty_id : $self->cpan_userid;
+ };
+ push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
+ $class,
+ $uptodateness,
+ $color_on,
+ $self->id,
+ $color_off,
+ $id,
+ );
+ join "", @m;
+}
+
+#-> sub CPAN::Module::dslip_status
+sub dslip_status {
+ my($self) = @_;
+ my($stat);
+ # development status
+ @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
+ pre-alpha alpha beta released
+ mature standard,;
+ # support level
+ @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
+ developer comp.lang.perl.*
+ none abandoned,;
+ # language
+ @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
+ # interface
+ @{$stat->{I}}{qw,f r O p h n,} = qw,functions
+ references+ties
+ object-oriented pragma
+ hybrid none,;
+ # public licence
+ @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
+ GPL LGPL
+ BSD Artistic Artistic_2
+ open-source
+ distribution_allowed
+ restricted_distribution
+ no_licence,;
+ for my $x (qw(d s l i p)) {
+ $stat->{$x}{' '} = 'unknown';
+ $stat->{$x}{'?'} = 'unknown';
+ }
+ my $ro = $self->ro;
+ return +{} unless $ro && $ro->{statd};
+ return {
+ D => $ro->{statd},
+ S => $ro->{stats},
+ L => $ro->{statl},
+ I => $ro->{stati},
+ P => $ro->{statp},
+ DV => $stat->{D}{$ro->{statd}},
+ SV => $stat->{S}{$ro->{stats}},
+ LV => $stat->{L}{$ro->{statl}},
+ IV => $stat->{I}{$ro->{stati}},
+ PV => $stat->{P}{$ro->{statp}},
+ };
+}
+
+#-> sub CPAN::Module::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ local($^W) = 0;
+ push @m, $class, " id = $self->{ID}\n";
+ my $sprintf = " %-12s %s\n";
+ push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
+ if $self->description;
+ my $sprintf2 = " %-12s %s (%s)\n";
+ my($userid);
+ $userid = $self->userid;
+ if ( $userid ) {
+ my $author;
+ if ($author = CPAN::Shell->expand('Author',$userid)) {
+ my $email = "";
+ my $m; # old perls
+ if ($m = $author->email) {
+ $email = " <$m>";
+ }
+ push @m, sprintf(
+ $sprintf2,
+ 'CPAN_USERID',
+ $userid,
+ $author->fullname . $email
+ );
+ }
+ }
+ push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
+ if $self->cpan_version;
+ if (my $cpan_file = $self->cpan_file) {
+ push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
+ if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
+ my $upload_date = $dist->upload_date;
+ if ($upload_date) {
+ push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
+ }
+ }
+ }
+ my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
+ my $dslip = $self->dslip_status;
+ push @m, sprintf(
+ $sprintf3,
+ 'DSLIP_STATUS',
+ @{$dslip}{qw(D S L I P DV SV LV IV PV)},
+ ) if $dslip->{D};
+ my $local_file = $self->inst_file;
+ unless ($self->{MANPAGE}) {
+ my $manpage;
+ if ($local_file) {
+ $manpage = $self->manpage_headline($local_file);
+ } else {
+ # If we have already untarred it, we should look there
+ my $dist = $CPAN::META->instance('CPAN::Distribution',
+ $self->cpan_file);
+ # warn "dist[$dist]";
+ # mff=manifest file; mfh=manifest handle
+ my($mff,$mfh);
+ if (
+ $dist->{build_dir}
+ and
+ (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
+ and
+ $mfh = FileHandle->new($mff)
+ ) {
+ CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
+ my $lfre = $self->id; # local file RE
+ $lfre =~ s/::/./g;
+ $lfre .= "\\.pm\$";
+ my($lfl); # local file file
+ local $/ = "\n";
+ my(@mflines) = <$mfh>;
+ for (@mflines) {
+ s/^\s+//;
+ s/\s.*//s;
+ }
+ while (length($lfre)>5 and !$lfl) {
+ ($lfl) = grep /$lfre/, @mflines;
+ CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
+ $lfre =~ s/.+?\.//;
+ }
+ $lfl =~ s/\s.*//; # remove comments
+ $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
+ my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
+ # warn "lfl_abs[$lfl_abs]";
+ if (-f $lfl_abs) {
+ $manpage = $self->manpage_headline($lfl_abs);
+ }
+ }
+ }
+ $self->{MANPAGE} = $manpage if $manpage;
+ }
+ my($item);
+ for $item (qw/MANPAGE/) {
+ push @m, sprintf($sprintf, $item, $self->{$item})
+ if exists $self->{$item};
+ }
+ for $item (qw/CONTAINS/) {
+ push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
+ if exists $self->{$item} && @{$self->{$item}};
+ }
+ push @m, sprintf($sprintf, 'INST_FILE',
+ $local_file || "(not installed)");
+ push @m, sprintf($sprintf, 'INST_VERSION',
+ $self->inst_version) if $local_file;
+ if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
+ my $available_file = $self->available_file;
+ if ($available_file && $available_file ne $local_file) {
+ push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
+ push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
+ }
+ }
+ join "", @m, "\n";
+}
+
+#-> sub CPAN::Module::manpage_headline
+sub manpage_headline {
+ my($self,$local_file) = @_;
+ my(@local_file) = $local_file;
+ $local_file =~ s/\.pm(?!\n)\Z/.pod/;
+ push @local_file, $local_file;
+ my(@result,$locf);
+ for $locf (@local_file) {
+ next unless -f $locf;
+ my $fh = FileHandle->new($locf)
+ or $Carp::Frontend->mydie("Couldn't open $locf: $!");
+ my $inpod = 0;
+ local $/ = "\n";
+ while (<$fh>) {
+ $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
+ m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
+ next unless $inpod;
+ next if /^=/;
+ next if /^\s+$/;
+ chomp;
+ push @result, $_;
+ }
+ close $fh;
+ last if @result;
+ }
+ for (@result) {
+ s/^\s+//;
+ s/\s+$//;
+ }
+ join " ", @result;
+}
+
+#-> sub CPAN::Module::cpan_file ;
+# Note: also inherited by CPAN::Bundle
+sub cpan_file {
+ my $self = shift;
+ # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
+ unless ($self->ro) {
+ CPAN::Index->reload;
+ }
+ my $ro = $self->ro;
+ if ($ro && defined $ro->{CPAN_FILE}) {
+ return $ro->{CPAN_FILE};
+ } else {
+ my $userid = $self->userid;
+ if ( $userid ) {
+ if ($CPAN::META->exists("CPAN::Author",$userid)) {
+ my $author = $CPAN::META->instance("CPAN::Author",
+ $userid);
+ my $fullname = $author->fullname;
+ my $email = $author->email;
+ unless (defined $fullname && defined $email) {
+ return sprintf("Contact Author %s",
+ $userid,
+ );
+ }
+ return "Contact Author $fullname <$email>";
+ } else {
+ return "Contact Author $userid (Email address not available)";
+ }
+ } else {
+ return "N/A";
+ }
+ }
+}
+
+#-> sub CPAN::Module::cpan_version ;
+sub cpan_version {
+ my $self = shift;
+
+ my $ro = $self->ro;
+ unless ($ro) {
+ # Can happen with modules that are not on CPAN
+ $ro = {};
+ }
+ $ro->{CPAN_VERSION} = 'undef'
+ unless defined $ro->{CPAN_VERSION};
+ $ro->{CPAN_VERSION};
+}
+
+#-> sub CPAN::Module::force ;
+sub force {
+ my($self) = @_;
+ $self->{force_update} = 1;
+}
+
+#-> sub CPAN::Module::fforce ;
+sub fforce {
+ my($self) = @_;
+ $self->{force_update} = 2;
+}
+
+#-> sub CPAN::Module::notest ;
+sub notest {
+ my($self) = @_;
+ # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
+ $self->{notest}++;
+}
+
+#-> sub CPAN::Module::rematein ;
+sub rematein {
+ my($self,$meth) = @_;
+ $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
+ $meth,
+ $self->id));
+ my $cpan_file = $self->cpan_file;
+ if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
+ $CPAN::Frontend->mywarn(sprintf qq{
+ The module %s isn\'t available on CPAN.
+
+ Either the module has not yet been uploaded to CPAN, or it is
+ temporary unavailable. Please contact the author to find out
+ more about the status. Try 'i %s'.
+},
+ $self->id,
+ $self->id,
+ );
+ return;
+ }
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->called_for($self->id);
+ if (exists $self->{force_update}) {
+ if ($self->{force_update} == 2) {
+ $pack->fforce($meth);
+ } else {
+ $pack->force($meth);
+ }
+ }
+ $pack->notest($meth) if exists $self->{notest} && $self->{notest};
+
+ $pack->{reqtype} ||= "";
+ CPAN->debug("dist-reqtype[$pack->{reqtype}]".
+ "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
+ if ($pack->{reqtype}) {
+ if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
+ $pack->{reqtype} = $self->{reqtype};
+ if (
+ exists $pack->{install}
+ &&
+ (
+ UNIVERSAL::can($pack->{install},"failed") ?
+ $pack->{install}->failed :
+ $pack->{install} =~ /^NO/
+ )
+ ) {
+ delete $pack->{install};
+ $CPAN::Frontend->mywarn
+ ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
+ }
+ }
+ } else {
+ $pack->{reqtype} = $self->{reqtype};
+ }
+
+ my $success = eval {
+ $pack->$meth();
+ };
+ my $err = $@;
+ $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
+ $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
+ delete $self->{force_update};
+ delete $self->{notest};
+ if ($err) {
+ die $err;
+ }
+ return $success;
+}
+
+#-> sub CPAN::Module::perldoc ;
+sub perldoc { shift->rematein('perldoc') }
+#-> sub CPAN::Module::readme ;
+sub readme { shift->rematein('readme') }
+#-> sub CPAN::Module::look ;
+sub look { shift->rematein('look') }
+#-> sub CPAN::Module::cvs_import ;
+sub cvs_import { shift->rematein('cvs_import') }
+#-> sub CPAN::Module::get ;
+sub get { shift->rematein('get',@_) }
+#-> sub CPAN::Module::make ;
+sub make { shift->rematein('make') }
+#-> sub CPAN::Module::test ;
+sub test {
+ my $self = shift;
+ # $self->{badtestcnt} ||= 0;
+ $self->rematein('test',@_);
+}
+
+#-> sub CPAN::Module::deprecated_in_core ;
+sub deprecated_in_core {
+ my ($self) = @_;
+ return unless $CPAN::META->has_inst('Module::CoreList') && Module::CoreList->can('is_deprecated');
+ return Module::CoreList::is_deprecated($self->{ID});
+}
+
+#-> sub CPAN::Module::inst_deprecated;
+# Indicates whether the *installed* version of the module is a deprecated *and*
+# installed as part of the Perl core library path
+sub inst_deprecated {
+ my ($self) = @_;
+ my $inst_file = $self->inst_file or return;
+ return $self->deprecated_in_core && $self->_in_priv_or_arch($inst_file);
+}
+
+#-> sub CPAN::Module::uptodate ;
+sub uptodate {
+ my ($self) = @_;
+ local ($_);
+ my $inst = $self->inst_version or return 0;
+ my $cpan = $self->cpan_version;
+ return 0 if CPAN::Version->vgt($cpan,$inst) || $self->inst_deprecated;
+ CPAN->debug
+ (join
+ ("",
+ "returning uptodate. ",
+ "cpan[$cpan]inst[$inst]",
+ )) if $CPAN::DEBUG;
+ return 1;
+}
+
+# returns true if installed in privlib or archlib
+sub _in_priv_or_arch {
+ my($self,$inst_file) = @_;
+ for my $confdirname (qw(archlibexp privlibexp)) {
+ my $confdir = $Config::Config{$confdirname};
+ if ($confdir eq substr($inst_file,0,length($confdir))) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+#-> sub CPAN::Module::install ;
+sub install {
+ my($self) = @_;
+ my($doit) = 0;
+ if ($self->uptodate
+ &&
+ not exists $self->{force_update}
+ ) {
+ $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
+ $self->id,
+ $self->inst_version,
+ ));
+ } else {
+ $doit = 1;
+ }
+ my $ro = $self->ro;
+ if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
+ $CPAN::Frontend->mywarn(qq{
+\n\n\n ***WARNING***
+ The module $self->{ID} has no active maintainer (CPAN support level flag 'abandoned').\n\n\n
+});
+ $CPAN::Frontend->mysleep(5);
+ }
+ return $doit ? $self->rematein('install') : 1;
+}
+#-> sub CPAN::Module::clean ;
+sub clean { shift->rematein('clean') }
+
+#-> sub CPAN::Module::inst_file ;
+sub inst_file {
+ my($self) = @_;
+ $self->_file_in_path([@INC]);
+}
+
+#-> sub CPAN::Module::available_file ;
+sub available_file {
+ my($self) = @_;
+ my $sep = $Config::Config{path_sep};
+ my $perllib = $ENV{PERL5LIB};
+ $perllib = $ENV{PERLLIB} unless defined $perllib;
+ my @perllib = split(/$sep/,$perllib) if defined $perllib;
+ my @cpan_perl5inc;
+ if ($CPAN::Perl5lib_tempfile) {
+ my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
+ @cpan_perl5inc = @{$yaml->[0]{inc} || []};
+ }
+ $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
+}
+
+#-> sub CPAN::Module::file_in_path ;
+sub _file_in_path {
+ my($self,$path) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ $packpath[-1] .= ".pm";
+ if (@packpath == 1 && $packpath[0] eq "readline.pm") {
+ unshift @packpath, "Term", "ReadLine"; # historical reasons
+ }
+ foreach $dir (@$path) {
+ my $pmfile = File::Spec->catfile($dir,@packpath);
+ if (-f $pmfile) {
+ return $pmfile;
+ }
+ }
+ return;
+}
+
+#-> sub CPAN::Module::xs_file ;
+sub xs_file {
+ my($self) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ push @packpath, $packpath[-1];
+ $packpath[-1] .= "." . $Config::Config{'dlext'};
+ foreach $dir (@INC) {
+ my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
+ if (-f $xsfile) {
+ return $xsfile;
+ }
+ }
+ return;
+}
+
+#-> sub CPAN::Module::inst_version ;
+sub inst_version {
+ my($self) = @_;
+ my $parsefile = $self->inst_file or return;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
+
+#-> sub CPAN::Module::inst_version ;
+sub available_version {
+ my($self) = @_;
+ my $parsefile = $self->available_file or return;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
+
+#-> sub CPAN::Module::parse_version ;
+sub parse_version {
+ my($self,$parsefile) = @_;
+ if (ALARM_IMPLEMENTED) {
+ my $timeout = (exists($CPAN::Config{'version_timeout'}))
+ ? $CPAN::Config{'version_timeout'}
+ : 15;
+ alarm($timeout);
+ }
+ my $have = eval {
+ local $SIG{ALRM} = sub { die "alarm\n" };
+ MM->parse_version($parsefile);
+ };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
+ }
+ alarm(0) if ALARM_IMPLEMENTED;
+ my $leastsanity = eval { defined $have && length $have; };
+ $have = "undef" unless $leastsanity;
+ $have =~ s/^ //; # since the %vd hack these two lines here are needed
+ $have =~ s/ $//; # trailing whitespace happens all the time
+
+ $have = CPAN::Version->readable($have);
+
+ $have =~ s/\s*//g; # stringify to float around floating point issues
+ $have; # no stringify needed, \s* above matches always
+}
+
+#-> sub CPAN::Module::reports
+sub reports {
+ my($self) = @_;
+ $self->distribution->reports;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Nox.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Nox.pm
new file mode 100755
index 00000000000..5fe5a25ae6e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Nox.pm
@@ -0,0 +1,51 @@
+package CPAN::Nox;
+use strict;
+use vars qw($VERSION @EXPORT);
+
+BEGIN{
+ $CPAN::Suppress_readline=1 unless defined $CPAN::term;
+}
+
+use base 'Exporter';
+use CPAN;
+
+$VERSION = "5.50";
+$CPAN::META->has_inst('Digest::MD5','no');
+$CPAN::META->has_inst('LWP','no');
+$CPAN::META->has_inst('Compress::Zlib','no');
+@EXPORT = @CPAN::EXPORT;
+
+*AUTOLOAD = \&CPAN::AUTOLOAD;
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Nox - Wrapper around CPAN.pm without using any XS module
+
+=head1 SYNOPSIS
+
+Interactive mode:
+
+ perl -MCPAN::Nox -e shell;
+
+=head1 DESCRIPTION
+
+This package has the same functionality as CPAN.pm, but tries to
+prevent the usage of compiled extensions during its own
+execution. Its primary purpose is a rescue in case you upgraded perl
+and broke binary compatibility somehow.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPAN>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Prompt.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Prompt.pm
new file mode 100755
index 00000000000..7a4e2d81e13
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Prompt.pm
@@ -0,0 +1,29 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Prompt;
+use overload '""' => "as_string";
+use vars qw($prompt);
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+$prompt = "cpan> ";
+$CPAN::CurrentCommandId ||= 0;
+sub new {
+ bless {}, shift;
+}
+sub as_string {
+ my $word = "cpan";
+ unless ($CPAN::META->{LOCK}) {
+ $word = "nolock_cpan";
+ }
+ if ($CPAN::Config->{commandnumber_in_prompt}) {
+ sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
+ } else {
+ "$word> ";
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Queue.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Queue.pm
new file mode 100755
index 00000000000..b60f57c1cfe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Queue.pm
@@ -0,0 +1,198 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+use strict;
+package CPAN::Queue::Item;
+
+# CPAN::Queue::Item::new ;
+sub new {
+ my($class,@attr) = @_;
+ my $self = bless { @attr }, $class;
+ return $self;
+}
+
+sub as_string {
+ my($self) = @_;
+ $self->{qmod};
+}
+
+# r => requires, b => build_requires, c => commandline
+sub reqtype {
+ my($self) = @_;
+ $self->{reqtype};
+}
+
+package CPAN::Queue;
+
+# One use of the queue is to determine if we should or shouldn't
+# announce the availability of a new CPAN module
+
+# Now we try to use it for dependency tracking. For that to happen
+# we need to draw a dependency tree and do the leaves first. This can
+# easily be reached by running CPAN.pm recursively, but we don't want
+# to waste memory and run into deep recursion. So what we can do is
+# this:
+
+# CPAN::Queue is the package where the queue is maintained. Dependencies
+# often have high priority and must be brought to the head of the queue,
+# possibly by jumping the queue if they are already there. My first code
+# attempt tried to be extremely correct. Whenever a module needed
+# immediate treatment, I either unshifted it to the front of the queue,
+# or, if it was already in the queue, I spliced and let it bypass the
+# others. This became a too correct model that made it impossible to put
+# an item more than once into the queue. Why would you need that? Well,
+# you need temporary duplicates as the manager of the queue is a loop
+# that
+#
+# (1) looks at the first item in the queue without shifting it off
+#
+# (2) cares for the item
+#
+# (3) removes the item from the queue, *even if its agenda failed and
+# even if the item isn't the first in the queue anymore* (that way
+# protecting against never ending queues)
+#
+# So if an item has prerequisites, the installation fails now, but we
+# want to retry later. That's easy if we have it twice in the queue.
+#
+# I also expect insane dependency situations where an item gets more
+# than two lives in the queue. Simplest example is triggered by 'install
+# Foo Foo Foo'. People make this kind of mistakes and I don't want to
+# get in the way. I wanted the queue manager to be a dumb servant, not
+# one that knows everything.
+#
+# Who would I tell in this model that the user wants to be asked before
+# processing? I can't attach that information to the module object,
+# because not modules are installed but distributions. So I'd have to
+# tell the distribution object that it should ask the user before
+# processing. Where would the question be triggered then? Most probably
+# in CPAN::Distribution::rematein.
+
+use vars qw{ @All $VERSION };
+$VERSION = "5.5";
+
+# CPAN::Queue::queue_item ;
+sub queue_item {
+ my($class,@attr) = @_;
+ my $item = "$class\::Item"->new(@attr);
+ $class->qpush($item);
+ return 1;
+}
+
+# CPAN::Queue::qpush ;
+sub qpush {
+ my($class,$obj) = @_;
+ push @All, $obj;
+ CPAN->debug(sprintf("in new All[%s]",
+ join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All),
+ )) if $CPAN::DEBUG;
+}
+
+# CPAN::Queue::first ;
+sub first {
+ my $obj = $All[0];
+ $obj;
+}
+
+# CPAN::Queue::delete_first ;
+sub delete_first {
+ my($class,$what) = @_;
+ my $i;
+ for my $i (0..$#All) {
+ if ( $All[$i]->{qmod} eq $what ) {
+ splice @All, $i, 1;
+ return;
+ }
+ }
+}
+
+# CPAN::Queue::jumpqueue ;
+sub jumpqueue {
+ my $class = shift;
+ my @what = @_;
+ CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
+ join("",
+ map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All, @what
+ ))) if $CPAN::DEBUG;
+ unless (defined $what[0]{reqtype}) {
+ # apparently it was not the Shell that sent us this enquiry,
+ # treat it as commandline
+ $what[0]{reqtype} = "c";
+ }
+ my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
+ WHAT: for my $what_tuple (@what) {
+ my($what,$reqtype) = @$what_tuple{qw(qmod reqtype)};
+ if ($reqtype eq "r"
+ &&
+ $inherit_reqtype eq "b"
+ ) {
+ $reqtype = "b";
+ }
+ my $jumped = 0;
+ for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
+ # CPAN->debug("i[$i]this[$All[$i]{qmod}]what[$what]") if $CPAN::DEBUG;
+ if ($All[$i]{qmod} eq $what) {
+ $jumped++;
+ if ($jumped >= 50) {
+ die "PANIC: object[$what] 50 instances on the queue, looks like ".
+ "some recursiveness has hit";
+ } elsif ($jumped > 25) { # one's OK if e.g. just processing
+ # now; more are OK if user typed
+ # it several times
+ my $sleep = sprintf "%.1f", $jumped/10;
+ $CPAN::Frontend->mywarn(
+qq{Warning: Object [$what] queued $jumped times, sleeping $sleep secs!\n}
+ );
+ $CPAN::Frontend->mysleep($sleep);
+ # next WHAT;
+ }
+ }
+ }
+ my $obj = "$class\::Item"->new(
+ qmod => $what,
+ reqtype => $reqtype
+ );
+ unshift @All, $obj;
+ }
+ CPAN->debug(sprintf("after jumpqueue All[%s]",
+ join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
+ )) if $CPAN::DEBUG;
+}
+
+# CPAN::Queue::exists ;
+sub exists {
+ my($self,$what) = @_;
+ my @all = map { $_->{qmod} } @All;
+ my $exists = grep { $_->{qmod} eq $what } @All;
+ # warn "in exists what[$what] all[@all] exists[$exists]";
+ $exists;
+}
+
+# CPAN::Queue::delete ;
+sub delete {
+ my($self,$mod) = @_;
+ @All = grep { $_->{qmod} ne $mod } @All;
+ CPAN->debug(sprintf("after delete mod[%s] All[%s]",
+ $mod,
+ join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
+ )) if $CPAN::DEBUG;
+}
+
+# CPAN::Queue::nullify_queue ;
+sub nullify_queue {
+ @All = ();
+}
+
+# CPAN::Queue::size ;
+sub size {
+ return scalar @All;
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite.pm
new file mode 100755
index 00000000000..01fd4139af7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite.pm
@@ -0,0 +1,323 @@
+package CPAN::SQLite;
+use strict;
+use warnings;
+use File::HomeDir;
+require File::Spec;
+use Cwd;
+require CPAN::SQLite::META;
+
+our $VERSION = '0.199';
+
+# an array ref of distributions to ignore indexing
+my $ignore = [qw(SpreadSheet-WriteExcel-WebPivot)];
+our $db_name = 'cpandb.sql';
+
+use constant WIN32 => $^O eq 'MSWin32';
+
+sub new {
+ my ($class, %args) = @_;
+ my ($CPAN, $update_indices);
+ my $db_dir = $args{db_dir};
+ my $urllist = [];
+ my $keep_source_where;
+ # for testing undr Darwin, must load CPAN::MyConfig contained
+ # in PERL5LIB, as File::HomeDir doesn't use this
+ if ($ENV{CPAN_SQLITE_TESTING}) {
+ eval {require CPAN::MyConfig;};
+ }
+ eval {require CPAN; CPAN::HandleConfig->load;};
+ if ( not $@ and not defined $args{CPAN} ) {
+ $CPAN = $CPAN::Config->{cpan_home};
+ $db_dir = $CPAN;
+ $keep_source_where = $CPAN::Config->{keep_source_where};
+ $urllist = $CPAN::Config->{urllist};
+ die qq{The '$CPAN' directory doesn't exist} unless -d $CPAN;
+ $update_indices = 0;
+ }
+ else {
+ $CPAN = $args{CPAN} || '';
+ die qq{Please specify the CPAN location} unless defined $CPAN;
+ die qq{The '$CPAN' directory doesn't exist} unless (-d $CPAN);
+ $update_indices = (-f File::Spec->catfile($CPAN, 'MIRRORING.FROM')) ?
+ 0 : 1;
+ }
+ push @$urllist, q{http://www.cpan.org/};
+ $db_dir ||= cwd;
+ my $self = {%args, CPAN => $CPAN, update_indices => $update_indices,
+ db_name => $db_name, urllist => $urllist,
+ keep_source_where => $keep_source_where, db_dir => $db_dir};
+ bless $self, $class;
+}
+
+sub index {
+ my ($self, %args) = @_;
+ require CPAN::SQLite::Index;
+ my %wanted = map {$_ => $self->{$_}}
+ qw(CPAN ignore update_indices db_name db_dir
+ keep_source_where setup reindex urllist);
+ my $log_dir = $self->{CPAN} || $self->{db_dir};
+ die qq{Please create the directory '$log_dir' first} unless -d $log_dir;
+ my $index = CPAN::SQLite::Index->new(%wanted, %args, log_dir => $log_dir);
+ $index->index() or do {
+ warn qq{Indexing failed!};
+ return;
+ };
+ return 1;
+}
+
+sub query {
+ my ($self, %args) = @_;
+ my $cwd = $self->{cwd};
+ require CPAN::SQLite::Search;
+ my %wanted = map {$_ => $self->{$_}}
+ qw(max_results CPAN db_name db_dir meta_obj);
+ my $query = CPAN::SQLite::Search->new(%wanted, %args);
+ %wanted = map {$_ => $self->{$_}} qw(mode query id name);
+ $query->query(%wanted, %args) or do {
+ warn qq{Query failed!};
+ return;
+ };
+ my $results = $query->{results};
+ return unless defined $results;
+ $self->{results} = $query->{results};
+ return 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite - maintain and search a minimal CPAN database
+
+=head1 SYNOPSIS
+
+ my $obj = CPAN::SQLite->new(CPAN => '/path/to/CPAN');
+ $obj->index(setup => 1);
+
+ $obj->query(mode => 'dist', name => 'CPAN');
+ my $results = $obj->{results};
+
+=head1 DESCRIPTION
+
+This package is used for setting up, maintaining, and
+searching a CPAN database consisting of the information
+stored in the three main CPAN indices:
+F<$CPAN/modules/03modlist.data.gz>,
+F<$CPAN/modules/02packages.details.txt.gz>, and
+F<$CPAN/authors/01mailrc.txt.gz>. It should be
+considered at an alpha stage of development.
+
+One begins by creating the object as
+
+ my $obj = CPAN::SQLite->new(%args);
+
+which accepts the following arguments:
+
+=over 3
+
+=item * C<CPAN =E<gt> '/path/to/CPAN'>
+
+This specifies the path to where the index files are
+to be stored. This could be a local CPAN mirror,
+defined here by the presence of a F<MIRRORED.BY> file beneath
+this directory, or a local directory in which to store
+these files from a remote CPAN mirror. In the latter case,
+the index files are fetched from a remote CPAN mirror,
+using the same list that C<CPAN.pm> uses, if this is
+configured, and are updated if they are more than one
+day old.
+
+If the C<CPAN> option is not given, it will default
+to C<cpan_home> of L<CPAN>, if this is configured,
+with the index files found under C<keep_source_where>.
+A fatal error results if such a directory isn't found.
+Updates to these index files are assumed here to be
+handled by C<CPAN.pm>.
+
+=item * C<db_dir =E<gt> '/path/to/db/dir'>
+
+This specifies the path to where the database file is
+found. If not given, it defaults to the
+C<cpan_home> directory of C<CPAN.pm>, if present, or to
+the directory in which the script was invoked. The name
+of the database file is C<cpandb.sql>.
+
+=back
+
+There are two main methods available.
+
+=head2 C<$obj-E<gt>index(%args);>
+
+This is used to set up and maintain the database. The
+following arguments are accepted:
+
+=over 3
+
+=item * setup =E<gt> 1
+
+This specifies that the database is to be created and
+populated from the CPAN indices; any exisiting database
+will be overwritten. Not specifying this option will
+assume that an existing database is to be updated.
+
+=item * reindex =E<gt> 'dist_name'
+
+This specifies that the CPAN distribution C<dist_name>
+is to be reindexed.
+
+=back
+
+=head2 C<$obj-E<gt>query(%args);>
+
+This is used for querying the database by distribution
+name, module name, or CPAN author name. There are
+two arguments needed to specify such queries.
+
+=over 3
+
+=item * C<mode =E<gt> some_value>
+
+This specifies what type of query to perform,
+with C<mode> being one of C<dist>, C<module>,
+or C<author>, for searching through, respectively,
+CPAN distribution names, module names, or author names and
+CPAN ids.
+
+=item * C<type =E<gt> query_term>
+
+This specifies the query term for the search, with
+C<type> being one of C<name>, to search for an
+exact match, or C<search>, for searching for partial
+matches. Perl regular expressions are supported in
+the C<query_term> for the C<search> option.
+
+=back
+
+As well, an option of C<max_results =E<gt> some_number> will
+limit the number of results returned; if not specified,
+this defaults to 200.
+
+=head1 CPAN.pm support
+
+As of CPAN.pm version 1.88_65, there is experimental support
+within CPAN.pm for using CPAN::SQLite to obtain
+information on packages, modules, and authors. One goal
+of this is to reduce the memory footprint of the CPAN.pm
+shell, as this information is no longer all preloaded into
+memory. This can be enabled through
+
+ perl -MCPAN -e shell
+ cpan> o conf use_sqlite 1
+
+Use
+
+ cpan> o conf commit
+
+to save this setting for future sessions.
+
+Using CPAN::SQLite, what happens is that a request for information
+through CPAN.pm, such as
+
+ cpan> a ANDK
+
+will cause a query to the SQLite database to be made.
+If successful, this will place the relevant data for this
+request into the data structure CPAN.pm uses to store and
+retrieve such information. Thus, at any given time, the
+only information CPAN.pm stores in memory is that for
+packages, modules, and authors for which previous queries
+have been made. There are certain requests, such as
+
+ cpan> r
+
+to make a list of recommended packages for which upgrades
+on CPAN are available, which will result in loading
+information on all available packages into memory; if such
+a query is made, the subsequent memory footprint of CPAN.pm
+with and without CPAN::SQLite will be essentially the same.
+
+The database itself, called F<cpandb.sql>, will be stored
+in the location specified by C<$CPAN::Config-E<gt>{cpan_home}>.
+When first started, this database will be created, and afterwards,
+it will be updated if the database is older than one day since
+the last update. A log file of the creation or update process, called
+F<cpan_search_log.dddddddddd>, will be created in the same
+directory as the database file.
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Index>, for setting up and maintaining
+the database, and L<CPAN::SQLite::Search> for an
+interface to querying the database. Some details
+of the interaction with L<CPAN> is available from
+L<CPAN::SQLite::META>. See also the L<cpandb> script for a
+command-line interface to the
+indexing and querying of the database.
+
+Development takes place on the CPAN-Search-Lite project
+at L<http://cpan-search.svn.sourceforge.net/viewvc/cpan-search/CPAN-SQLite/>.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CPAN::SQLite
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CPAN-SQLite>
+
+=item * CPAN::Forum: Discussion forum
+
+L<http:///www.cpanforum.com/dist/CPAN-SQLite>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CPAN-SQLite>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CPAN-SQLite>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CPAN-SQLite>
+
+=back
+
+=head1 BUGS
+
+At this time, CPAN::SQLite keeps information contained only
+in the latest version of a CPAN distribution. This means that
+modules that are provided only in older versions of a CPAN
+distribution will not be present in the database; for example,
+at this time, the latest version of the I<libwww-perl> distribution
+on CPAN is 5.805, but there are modules such as I<URI::URL::finger>
+contained in version 5.10 of libwww-perl that are not present in 5.805.
+This behaviour differs from that of L<CPAN> without CPAN::SQLite.
+This may change in the future.
+
+Please report bugs and feature requests via
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CPAN-SQLite>.
+
+=head1 ENVIRONMENT VARIABLES
+
+Information messages from the indexing procedures are printed
+out to STDOUT if the environment variable CPAN_SQLITE_DEBUG
+is set. This is automatically set within L<CPAN::SQLite::Index>.
+If CPAN_SQLITE_NO_LOG_FILES is set, no log files will be created
+during the indexing procedures.
+
+=head1 COPYRIGHT
+
+This software is copyright 2006,2008 by Randy Kobes
+E<lt>r.kobes@uwinnipeg.caE<gt>. Use and
+redistribution are under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI.pm
new file mode 100755
index 00000000000..52318924531
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI.pm
@@ -0,0 +1,169 @@
+package CPAN::SQLite::DBI;
+use strict;
+use warnings;
+require File::Spec;
+use DBI;
+our $VERSION = '0.199';
+
+use base qw(Exporter);
+our ($dbh, $tables, @EXPORT_OK);
+@EXPORT_OK = qw($dbh $tables);
+
+sub rlike {
+ my ($x, $y) = @_;
+ return ($x =~ /$y/i) ? 1 : 0;
+}
+
+$tables = {
+ mods => {
+ primary => {mod_id => q{INTEGER NOT NULL PRIMARY KEY}},
+ other => {
+ mod_name => q{VARCHAR(100) NOT NULL},
+ dist_id => q{INTEGER NOT NULL},
+ mod_abs => q{TEXT},
+ mod_vers => q{VARCHAR(10)},
+ dslip => q{VARCHAR(5)},
+ chapterid => q{INTEGER},
+ },
+ key => [qw/dist_id mod_name/],
+ name => 'mod_name',
+ id => 'mod_id',
+ has_a => {dists => 'dist_id'},
+ },
+ dists => {
+ primary => {dist_id => q{INTEGER NOT NULL PRIMARY KEY}},
+ other => {
+ dist_name => q{VARCHAR(90) NOT NULL},
+ auth_id => q{INTEGER NOT NULL},
+ dist_file => q{VARCHAR(110) NOT NULL},
+ dist_vers => q{VARCHAR(20)},
+ dist_abs => q{TEXT},
+ dist_dslip => q{VARCHAR(5)},
+ },
+ key => [qw/auth_id dist_name/],
+ name => 'dist_name',
+ id => 'dist_id',
+ has_a => {auths => 'auth_id'},
+ has_many => {mods => 'dist_id',
+ chaps => 'dist_id',
+ },
+ },
+ auths => {
+ primary => {auth_id => q{INTEGER NOT NULL PRIMARY KEY}},
+ other => {
+ cpanid => q{VARCHAR(20) NOT NULL},
+ fullname => q{VARCHAR(40) NOT NULL},
+ email => q{TEXT},
+ },
+ key => [qw/cpanid/],
+ has_many => {dists => 'dist_id'},
+ name => 'cpanid',
+ id => 'auth_id',
+ },
+ chaps => {
+ primary => {chap_id => q{INTEGER NOT NULL PRIMARY KEY}},
+ other => {
+ dist_id => q{INTEGER NOT NULL},
+ chapterid => q{INTEGER},
+ subchapter => q{TEXT},
+ },
+ key => [qw/dist_id/],
+ id => 'chap_id',
+ name => 'chapterid',
+ has_a => {dists => 'dist_id'},
+ },
+ };
+
+sub new {
+ my ($class, %args) = @_;
+ my $db_dir = $args{db_dir} || $args{CPAN};
+ my $db = File::Spec->catfile($db_dir, $args{db_name});
+ $dbh ||= DBI->connect("DBI:SQLite:$db", '', '',
+ {RaiseError => 1, AutoCommit => 0})
+ or die "Cannot connect to $db";
+ $dbh->{AutoCommit} = 0;
+ $dbh->func('RLIKE', 2, \&rlike, 'create_function');
+
+ my $objs;
+ foreach my $table (keys %$tables) {
+ my $cl = $class . '::' . $table;
+ $objs->{$table} = $cl->make(table => $table);
+ }
+
+ for my $table (keys %$tables) {
+ foreach my $type (qw(primary other)) {
+ foreach my $column (keys %{$tables->{$table}->{$type}}) {
+ push @{$tables->{$table}->{columns}}, $column;
+ }
+ }
+ }
+
+ bless {objs => $objs}, $class;
+}
+
+sub make {
+ my ($class, %args) = @_;
+ my $table = $args{table};
+ die qq{No table exists corresponding to '$class'} unless $table;
+ my $info = $tables->{$table};
+ die qq{No information available for table '$table'} unless $info;
+ my $self = {table => $table,
+ columns => $info->{columns},
+ id => $info->{id},
+ name => $info->{name},
+ };
+ foreach (qw(name has_a has_many)) {
+ next unless defined $info->{$_};
+ $self->{$_} = $info->{$_};
+ }
+ bless $self, $class;
+}
+
+sub db_error {
+ my ($obj, $sth) = @_;
+ return unless $dbh;
+ if ($sth) {
+ $sth->finish;
+ undef $sth;
+ }
+ $obj->{error_msg} = q{Database error: } . $dbh->errstr;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::DBI - DBI information for the CPAN::SQLite database
+
+=head1 DESCRIPTION
+
+This module is used by L<CPAN::SQLite::Index> and
+L<CPAN::SQLite::Search> to set up some basic database
+information. It exports two variables:
+
+=over 3
+
+=item C<$tables>
+
+This is a hash reference whose keys are the table names, with
+corresponding values being hash references whose keys are the
+columns of the table and values being the associated data types.
+
+=item C<$dbh>
+
+This is a L<DBI> database handle used to connect to the
+database.
+
+=back
+
+The main method of this module is C<make>, which is used
+to make the tables of the database.
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Index> and L<CPAN::SQLite::Search>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Index.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Index.pm
new file mode 100755
index 00000000000..19fb93b29bf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Index.pm
@@ -0,0 +1,237 @@
+package CPAN::SQLite::DBI::Index;
+use CPAN::SQLite::DBI qw($dbh);
+use base qw(CPAN::SQLite::DBI);
+
+use strict;
+use warnings;
+our $VERSION = '0.199';
+
+package CPAN::SQLite::DBI::Index::chaps;
+use base qw(CPAN::SQLite::DBI::Index);
+use CPAN::SQLite::DBI qw($dbh);
+
+package CPAN::SQLite::DBI::Index::mods;
+use base qw(CPAN::SQLite::DBI::Index);
+use CPAN::SQLite::DBI qw($dbh);
+
+package CPAN::SQLite::DBI::Index::dists;
+use base qw(CPAN::SQLite::DBI::Index);
+use CPAN::SQLite::DBI qw($dbh);
+
+sub fetch_ids {
+ my $self = shift;
+ my $sql = sprintf(qq{SELECT %s,%s,%s FROM %s},
+ $self->{id}, $self->{name}, 'dist_vers',
+ $self->{table});
+ my $sth = $dbh->prepare($sql) or do {
+ $self->db_error();
+ return;
+ };
+ $sth->execute() or do {
+ $self->db_error($sth);
+ return;
+ };
+ my ($ids, $versions);
+ while (my ($id, $key, $vers) = $sth->fetchrow_array()) {
+ $ids->{$key} = $id;
+ $versions->{$key} = $vers;
+ }
+ $sth->finish;
+ undef $sth;
+ return ($ids, $versions);
+}
+
+package CPAN::SQLite::DBI::Index::auths;
+use base qw(CPAN::SQLite::DBI::Index);
+use CPAN::SQLite::DBI qw($dbh);
+
+package CPAN::SQLite::DBI::Index;
+use CPAN::SQLite::DBI qw($tables);
+use CPAN::SQLite::DBI qw($dbh);
+
+sub fetch_ids {
+ my $self = shift;
+ my $sql = sprintf(qq{SELECT %s,%s from %s},
+ $self->{id}, $self->{name}, $self->{table});
+ my $sth = $dbh->prepare($sql) or do {
+ $self->db_error();
+ return;
+ };
+ $sth->execute() or do {
+ $self->db_error($sth);
+ return;
+ };
+ my $ids;
+ while (my ($id, $key) = $sth->fetchrow_array()) {
+ $ids->{$key} = $id;
+ }
+ $sth->finish;
+ undef $sth;
+ return $ids;
+}
+
+sub schema {
+ my ($self, $data) = @_;
+ my $schema = '';
+ foreach my $type (qw(primary other)) {
+ foreach my $column (keys %{$data->{$type}}) {
+ $schema .= $column . ' ' . $data->{$type}->{$column} . ", ";
+ }
+ }
+ $schema =~ s{, $}{};
+ return $schema;
+}
+
+sub create_index {
+ my ($self, $data) = @_;
+ my $sql = '';
+ my $key = $data->{key};
+ my $table = $self->{table};
+ return 1 unless (defined $key and ref($key) eq 'ARRAY');
+ foreach my $index(@$key) {
+ my $id_name = 'ix_' . $table . '_' . $index;
+ $id_name =~ s/\(\s*\d+\s*\)//;
+ my $sql = 'CREATE INDEX ' . $id_name . ' ON ' .
+ $table . '( ' . $index . ' )';
+ my $sth = $dbh->prepare($sql);
+ $sth->execute() or do {
+ $self->db_error($sth);
+ return;
+ };
+ $sth->finish;
+ undef $sth;
+ }
+ return 1;
+}
+
+sub drop_table {
+ my $self = shift;
+ my $table = $self->{table};
+ my $sql = qq{SELECT name FROM sqlite_master } .
+ qq{ WHERE type='table' AND name=?};
+ my $sth = $dbh->prepare($sql);
+ $sth->execute($table);
+ if (defined $sth->fetchrow_array) {
+ $dbh->do(qq{drop table $table}) or do {
+ $self->db_error($sth);
+ return;
+ };
+ }
+ $sth->finish;
+ undef $sth;
+ return 1;
+}
+
+sub create_table {
+ my ($self, $schema) = @_;
+ return unless $schema;
+ my $sql = sprintf(qq{CREATE TABLE %s (%s)}, $self->{table}, $schema);
+ my $sth = $dbh->prepare($sql);
+ $sth->execute() or do {
+ $self->db_error($sth);
+ return;
+ };
+ $sth->finish;
+ undef $sth;
+ return 1;
+}
+
+sub create_tables {
+ my ($self, %args) = @_;
+ return unless $args{setup};
+ my $objs = $self->{objs};
+ foreach my $table(keys %$objs) {
+ next unless my $schema = $self->schema($tables->{$table});
+ my $obj = $objs->{$table};
+ $obj->drop_table or return;
+ $obj->create_table($schema) or return;
+ $obj->create_index($tables->{$table}) or return;
+ }
+ return 1;
+}
+
+sub sth_insert {
+ my ($self, $fields) = @_;
+ my $flds = join ',', @$fields;
+ my $vals = join ',', map '?', @$fields;
+ my $sql = sprintf(qq{INSERT INTO %s (%s) VALUES (%s)},
+ $self->{table}, $flds, $vals);
+
+ my $sth = $dbh->prepare($sql) or do {
+ $self->db_error();
+ return;
+ };
+ return $sth;
+}
+
+sub sth_update {
+ my ($self, $fields, $id, $rep_id) = @_;
+ my $set = join ',', map "$_=?", @$fields;
+ my $sql = sprintf(qq{UPDATE %s SET %s WHERE %s = %s},
+ $self->{table}, $set, $self->{id}, $id);
+ $sql .= qq { AND rep_id = $rep_id } if ($rep_id);
+ my $sth = $dbh->prepare($sql) or do {
+ $self->db_error();
+ return;
+ };
+ return $sth;
+}
+
+sub sth_delete {
+ my ($self, $table_id, $rep_id) = @_;
+ my $sql = sprintf(qq{DELETE FROM %s where %s = ?},
+ $self->{table}, $table_id);
+ $sql .= qq { AND rep_id = $rep_id } if ($rep_id);
+ my $sth = $dbh->prepare($sql) or do {
+ $self->db_error();
+ return;
+ };
+ return $sth;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::DBI::Index - DBI information for indexing the CPAN::SQLite database
+
+=head1 DESCRIPTION
+
+This module provides various methods for L<CPAN::SQLite::Index> in
+indexing and populating the database from the index files.
+
+=over
+
+=item C<create_tables>
+
+This creates the database tables.
+
+=item C<drop_table>
+
+This drops a table.
+
+=item C<sth_insert>
+
+This returns an C<$sth> statement handle for inserting
+values into a table.
+
+=item C<sth_update>
+
+This returns an C<$sth> statement handle for updating
+values into a table.
+
+=item C<sth_delete>
+
+This returns an C<$sth> statement handle for deleting
+values from a table.
+
+=back
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Index>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Search.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Search.pm
new file mode 100755
index 00000000000..32b4dcae4c9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/DBI/Search.pm
@@ -0,0 +1,283 @@
+package CPAN::SQLite::DBI::Search;
+use base qw(CPAN::SQLite::DBI);
+use CPAN::SQLite::DBI qw($tables $dbh);
+use CPAN::SQLite::Util qw($full_id);
+
+our $VERSION = '0.199';
+
+use strict;
+use warnings;
+
+package CPAN::SQLite::DBI::Search::chaps;
+use base qw(CPAN::SQLite::DBI::Search);
+use CPAN::SQLite::DBI qw($dbh);
+
+package CPAN::SQLite::DBI::Search::mods;
+use base qw(CPAN::SQLite::DBI::Search);
+use CPAN::SQLite::DBI qw($dbh);
+
+package CPAN::SQLite::DBI::Search::dists;
+use base qw(CPAN::SQLite::DBI::Search);
+use CPAN::SQLite::DBI qw($dbh);
+
+package CPAN::SQLite::DBI::Search::auths;
+use base qw(CPAN::SQLite::DBI::Search);
+use CPAN::SQLite::DBI qw($dbh);
+
+package CPAN::SQLite::DBI::Search;
+use base qw(CPAN::SQLite::DBI);
+use CPAN::SQLite::DBI qw($tables $dbh);
+use CPAN::SQLite::Util qw($full_id expand_dslip download %chaps);
+
+sub fetch {
+ my ($self, %args) = @_;
+ my $fields = $args{fields};
+ my $search = $args{search};
+ my @fields = ref($fields) eq 'ARRAY' ?
+ @{$fields} : ($fields);
+ my $sql = $self->sql_statement(%args) or do {
+ $self->{error} = 'Error constructing sql statement: ' .
+ $self->{error};
+ return;
+ };
+ my $sth = $dbh->prepare($sql) or do {
+ $self->db_error();
+ return;
+ };
+ $sth->execute() or do {
+ $self->db_error($sth);
+ return;
+ };
+
+ if (not $search->{wantarray}) {
+ my (%results, %meta_results, $results);
+ @results{@fields} = $sth->fetchrow_array;
+ $results = ($sth->rows == 0) ? undef : \%results;
+ $sth->finish;
+ undef $sth;
+ $self->extra_info($results) if $results;
+ return $results;
+ }
+ else {
+ my (%hash, $results);
+ while ( @hash{@fields} = $sth->fetchrow_array) {
+ my %tmp = %hash;
+ $self->extra_info(\%tmp);
+ push @{$results}, \%tmp;
+ }
+ $results = undef if ($sth->rows == 0);
+ $sth->finish;
+ undef $sth;
+ return $results;
+ }
+}
+
+sub fetch_and_set {
+ my ($self, %args) = @_;
+ my $fields = $args{fields};
+ my $search = $args{search};
+ my $meta_obj = $args{meta_obj};
+ die "Please supply a CPAN::SQLite::Meta::* object"
+ unless ($meta_obj and ref($meta_obj) =~ /^CPAN::SQLite::META/);
+ my @fields = ref($fields) eq 'ARRAY' ?
+ @{$fields} : ($fields);
+ my $sql = $self->sql_statement(%args) or do {
+ $self->{error} = 'Error constructing sql statement: ' .
+ $self->{error};
+ return;
+ };
+ my $sth = $dbh->prepare($sql) or do {
+ $self->db_error();
+ return;
+ };
+ $sth->execute() or do {
+ $self->db_error($sth);
+ return;
+ };
+
+ my $want_ids = $args{want_ids};
+ my $set_list = $args{set_list};
+ my $download = $args{download};
+ if (not $search->{wantarray}) {
+ my (%results, %meta_results, $results);
+ @results{@fields} = $sth->fetchrow_array;
+ $results = ($sth->rows == 0) ? undef : \%results;
+ $sth->finish;
+ undef $sth;
+ return unless $results;
+ $self->extra_info($results);
+ $meta_obj->set_data($results);
+ if ($want_ids) {
+ $meta_results{dist_id} = $results{dist_id};
+ $meta_results{download} = download($results{cpanid},
+ $results{dist_file});
+ return \%meta_results;
+ }
+ else {
+ return 1;
+ }
+ }
+ else {
+ my (%hash, $meta_results);
+ while ( @hash{@fields} = $sth->fetchrow_array) {
+ my %tmp = %hash;
+ if ($set_list) {
+ push @{$meta_results}, \%tmp;
+ }
+ else {
+ $self->extra_info(\%tmp);
+ $meta_obj->set_data(\%tmp);
+ if ($want_ids) {
+ my $download = download($tmp{cpanid}, $tmp{dist_file});
+ push @{$meta_results}, {dist_id => $tmp{dist_id},
+ download => $download};
+
+ }
+ }
+ }
+ $meta_results = undef if ($sth->rows == 0);
+ $sth->finish;
+ undef $sth;
+ return unless $meta_results;
+ $meta_obj->set_list_data($meta_results, $download) if $set_list;
+ return $want_ids ? $meta_results : 1;
+ }
+}
+
+sub extra_info {
+ my ($self, $results) = @_;
+ if ($results->{cpanid} and $results->{dist_file}) {
+ $results->{download} = download($results->{cpanid}, $results->{dist_file});
+ }
+ my $what;
+ if ( ($what = $results->{dslip}) or ($what = $results->{dist_dslip}) ) {
+ $results->{dslip_info} = expand_dslip($what);
+ }
+ if (my $chapterid = $results->{chapterid}) {
+ $chapterid += 0;
+ $results->{chapter_desc} = $chaps{$chapterid};
+ }
+}
+
+sub sql_statement {
+ my ($self, %args) = @_;
+
+ my $search = $args{search};
+ my $distinct = $search->{distinct} ? 'DISTINCT' : '';
+ my $table = $args{table};
+ my @tables = ($table);
+
+ my $fields = $args{fields};
+ my @fields = ref($fields) eq 'ARRAY' ?
+ @{$fields} : ($fields);
+ for (@fields) {
+ $_ = $full_id->{$_} if $full_id->{$_};
+ }
+
+ my $sql = qq{SELECT $distinct } . join(',', @fields);
+ my $where = '';
+ my $type = $search->{type};
+ QUERY: {
+ ($type eq 'query' ) and do {
+ my $value = $search->{value};
+ last QUERY if ($value eq '^');
+ my $name = $search->{name};
+ my $text = $search->{text};
+ my $use_like = ($value =~ /^\^?[A-Za-z0-9_\\\:\-]+$/) ? 1 : 0;
+ my $prepend = '%';
+ if ($use_like and $value =~ /^\^/) {
+ $prepend = '';
+ $value =~ s/^\^//;
+ $value =~ s{\\}{}g;
+ }
+ $where = $use_like ?
+ qq{$name LIKE '$prepend$value%'} :
+ qq{RLIKE($name, '$value')};
+ if ($name eq 'cpanid') {
+ $where .= $use_like ?
+ qq{ OR $text LIKE '$prepend$value%'} :
+ qq{ OR RLIKE($text, '$value')};
+ }
+ last QUERY;
+ };
+ ($type eq 'id') and do {
+ $where = qq{ $search->{id} = $search->{value} };
+ last QUERY;
+ };
+ ($type eq 'name') and do {
+ $where = qq{ $search->{name} = '$search->{value}' };
+ last QUERY;
+ };
+ warn qq{Unknown query type};
+ return;
+ }
+ my $join;
+
+ $sql .= ' FROM ' . $table;
+ my $left_join = $args{join} || $args{left_join};
+ if ($left_join) {
+ if (ref($left_join) eq 'HASH') {
+ foreach my $key(keys %$left_join) {
+ my $id = $left_join->{$key};
+ $sql .= " LEFT JOIN $key ON $table.$id=$key.$id ";
+ }
+ }
+ }
+
+ if ($where) {
+ $sql .= ' WHERE ( ' . $where . ' )';
+ $sql .= ' AND (' . $join . ')' if $join;
+ }
+ else {
+ $sql .= ' WHERE (' . $join . ')' if $join;
+ }
+
+ my $order_by = '';
+ if (my $user_order_by = $args{order_by}) {
+ $order_by = $order_by ? "$order_by,$user_order_by" : $user_order_by;
+ }
+ if ($order_by and $where) {
+ $sql .= qq{ ORDER BY $order_by };
+ }
+
+ if (my $limit = $args{limit}) {
+ my ($min, $max) = ref($limit) eq 'HASH' ?
+ ( $limit->{min} || 0, $limit->{max} ) :
+ (0, $limit );
+ $sql .= qq{ LIMIT $min,$max };
+ }
+ return $sql;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::DBI::Search - DBI information for searching the CPAN::SQLite database
+
+=head1 DESCRIPTION
+
+This module provides methods for L<CPAN::SQLite::Search> for searching
+the C<CPAN::SQLite> database. There are two main methods.
+
+=over
+
+=item C<fetch>
+
+This takes information from C<CPAN::SQLite::Search> and sets up
+a query on the database, returning the results found.
+
+=item C<sql_statement>
+
+This is used by the C<fetch> method to construct the appropriate
+SQL statement.
+
+=back
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Search>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Index.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Index.pm
new file mode 100755
index 00000000000..31923ff2beb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Index.pm
@@ -0,0 +1,264 @@
+package CPAN::SQLite::Index;
+use strict;
+use warnings;
+use CPAN::SQLite::Info;
+use CPAN::SQLite::State;
+use CPAN::SQLite::Populate;
+use CPAN::SQLite::DBI qw($tables);
+use File::Spec::Functions qw(catfile);
+use File::Basename;
+use File::Path;
+use LWP::Simple qw(getstore is_success);
+
+our $VERSION = '0.199';
+unless ($ENV{CPAN_SQLITE_NO_LOG_FILES}) {
+ $ENV{CPAN_SQLITE_DEBUG} = 1;
+}
+
+our ($oldout);
+my $log_file = 'cpan_sqlite_log.' . time;
+
+sub new {
+ my ($class, %args) = @_;
+ if ($args{setup} and $args{reindex}) {
+ die "Reindexing must be done on an exisiting database";
+ }
+
+ my $self = {index => undef, state => undef, %args};
+ bless $self, $class;
+}
+
+sub index {
+ my ($self, %args) = @_;
+ my $setup = $self->{setup};
+
+ if ($setup) {
+ my $db_name = catfile($self->{db_dir}, $self->{db_name});
+ if (-f $db_name) {
+ warn qq{Removing existing $db_name\n};
+ unlink $db_name or warn qq{Cannot unlink $db_name: $!};
+ }
+ }
+ my $log = catfile($self->{log_dir}, $log_file);
+ unless ($ENV{CPAN_SQLITE_NO_LOG_FILES}) {
+ $oldout = error_fh($log);
+ }
+
+ if ($self->{update_indices}) {
+ warn qq{Fetching index files ...\n};
+ $self->fetch_cpan_indices() or do {
+ warn qq{fetch_cpan_indices() failed};
+ return;
+ }
+ }
+
+ warn qq{Gathering information from index files ...\n};
+ $self->fetch_info or do {
+ warn qq{fetch_info() failed!};
+ return;
+ };
+ unless ($setup) {
+ warn qq{Obtaining current state of database ...\n};
+ $self->state or do {
+ warn qq{state() failed!};
+ return;
+ };
+ }
+ warn qq{Populating database tables ...\n};
+ $self->populate or do {
+ warn qq{populate() failed!};
+ return;
+ };
+ return 1;
+}
+
+sub fetch_cpan_indices {
+ my ($self, %args) = @_;
+ my $CPAN = $self->{CPAN};
+ my $indices = {'01mailrc.txt.gz' => 'authors',
+ '02packages.details.txt.gz' => 'modules',
+ '03modlist.data.gz' => 'modules',
+ };
+ foreach my $index (keys %$indices) {
+ my $file = catfile($CPAN, $indices->{$index}, $index);
+ next if (-e $file and -M $file < 1);
+ my $dir = dirname($file);
+ unless (-d $dir) {
+ mkpath($dir, 1, 0755) or die "Cannot mkpath $dir: $!";
+ }
+ my @urllist = @{$self->{urllist}};
+ foreach my $cpan(@urllist) {
+ my $from = join '/', ($cpan, $indices->{$index}, $index);
+ last if is_success(getstore($from, $file));
+ }
+ unless (-f $file) {
+ warn qq{Cannot retrieve '$file'};
+ return;
+ }
+ }
+ return 1;
+}
+
+sub fetch_info {
+ my $self = shift;
+ my %wanted = map {$_ => $self->{$_}} qw(CPAN ignore keep_source_where);
+ my $info = CPAN::SQLite::Info->new(%wanted);
+ $info->fetch_info() or return;
+ my @tables = qw(dists mods auths);
+ my $index;
+ foreach my $table(@tables) {
+ my $class = __PACKAGE__ . '::' . $table;
+ my $this = {info => $info->{$table}};
+ $index->{$table} = bless $this, $class;
+ }
+ $self->{index} = $index;
+ return 1;
+}
+
+sub state {
+ my $self = shift;
+
+ my %wanted = map {$_ => $self->{$_}}
+ qw(db_name index setup reindex db_dir);
+ my $state = CPAN::SQLite::State->new(%wanted);
+ $state->state() or return;
+ $self->{state} = $state;
+ return 1;
+}
+
+sub populate {
+ my $self = shift;
+ my %wanted = map {$_ => $self->{$_}}
+ qw(db_name index setup state db_dir);
+ my $db = CPAN::SQLite::Populate->new(%wanted);
+ $db->populate() or return;
+ return 1;
+}
+
+sub error_fh {
+ my $file = shift;
+ open(my $tmp, '>', $file) or die "Cannot open $file: $!";
+ close $tmp;
+ open(my $oldout, '>&STDOUT');
+ open(STDOUT, '>', $file) or die "Cannot tie STDOUT to $file: $!";
+ select STDOUT; $| = 1;
+ return $oldout;
+}
+
+sub DESTROY {
+ unless ($ENV{CPAN_SQLITE_NO_LOG_FILES}) {
+ close STDOUT;
+ open(STDOUT, ">&$oldout");
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::Index - set up or update database tables.
+
+=head1 SYNOPSIS
+
+ my $index = CPAN::SQLite::Index->new(setup => 1);
+ $index->index();
+
+=head1 DESCRIPTION
+
+This is the main module used to set up or update the
+database tables used to store information from the
+CPAN and ppm indices. The creation of the object
+
+ my $index = CPAN::SQLite::Index->new(%args);
+
+accepts two possible arguments:
+
+=over 3
+
+=item * setup =E<gt> 1
+
+This (optional) argument specifies that the database is being set up.
+Any existing tables will be dropped.
+
+=item * reindex =E<gt> value
+
+This (optional) argument specifies distribution names that
+one would like to reindex in an existing database. These may
+be specified as either a scalar, for a single distribution,
+or as an array reference for a list of distributions.
+
+=back
+
+=head1 DETAILS
+
+Calling
+
+ $index->index();
+
+will start the indexing procedure. Various messages
+detailing the progress will written to I<STDOUT>,
+which by default will be captured into a file
+F<cpan_sqlite_log.dddddddddd>, where the extension
+is the C<time> that the method was invoked. Error messages
+are not captured, and will appear in I<STDERR>.
+
+The steps of the indexing procedure are as follows.
+
+=over 3
+
+=item * fetch index data
+
+The necessary CPAN index files
+F<$CPAN/authors/01mailrc.txt.gz>,
+F<$CPAN/modules/02packages.details.txt.gz>, and
+F<$CPAN/modules/03modlist.data.gz> will be fetched
+from the CPAN mirror specified by the C<$cpan> variable
+at the beginning of L<CPAN::SQLite::Index>. If you are
+using this option, it is recommended to use the
+same CPAN mirror with subsequent updates, to ensure consistency
+of the database. As well, the information on the locations
+of the CPAN mirrors used for Template-Toolkit and GeoIP
+is written.
+
+=item * get index information
+
+Information from the CPAN indices is extracted through
+L<CPAN::SQLite::Info>.
+
+=item * get state information
+
+Unless the C<setup> argument within the C<new>
+method of L<CPAN::SQLite::Index> is specified,
+this will get information on the state of the database
+through L<CPAN::SQLite::State>.
+A comparision is then made between this information
+and that gathered from the CPAN indices, and if there's
+a discrepency in some items, those items are marked
+for either insertion, updating, or deletion, as appropriate.
+
+=item * populate the database
+
+At this stage the gathered information is used to populate
+the database, through L<CPAN::SQLite::Populate>,
+either inserting new items, updating
+existing ones, or deleting obsolete items.
+
+=back
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Info>, L<CPAN::SQLite::State>,
+L<CPAN::SQLite::Populate>,
+and L<CPAN::SQLite::Util>.
+Development takes place on the CPAN-SQLite project
+at L<http://sourceforge.net/projects/cpan-search/>.
+
+=head1 COPYRIGHT
+
+This software is copyright 2006 by Randy Kobes
+E<lt>r.kobes@uwinnipeg.caE<gt>. Use and
+redistribution are under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Info.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Info.pm
new file mode 100755
index 00000000000..09ec1896bb5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Info.pm
@@ -0,0 +1,338 @@
+package CPAN::SQLite::Info;
+use strict;
+use warnings;
+use CPAN::DistnameInfo;
+use File::Spec::Functions qw(catfile);
+use Compress::Zlib;
+use File::Basename;
+use Safe;
+use CPAN::SQLite::Util qw(vcmp print_debug);
+
+our $VERSION = '0.199';
+
+my $ext = qr/\.(tar\.gz|tar\.Z|tgz|zip)$/;
+
+sub new {
+ my ($class, %args) = @_;
+ my $self = {dists => {}, auths => {}, mods => {}, %args};
+ bless $self, $class;
+}
+
+sub fetch_info {
+ my $self = shift;
+ $self->mailrc() or return;
+ $self->dists_and_mods() or return;
+ return 1;
+}
+
+sub dists_and_mods {
+ my $self = shift;
+ my $modlist = $self->modlist();
+ my ($packages, $cpan_files) = $self->packages();
+
+ my ($dists, $mods);
+ my $ignore = $self->{ignore};
+ my $pat;
+ if ($ignore and ref($ignore) eq 'ARRAY') {
+ $pat = join '|', @$ignore;
+ }
+ foreach my $cpan_file (keys %$cpan_files) {
+ if ($pat and ($cpan_file =~ /^($pat)/)) {
+ delete $cpan_files->{$cpan_file};
+ print_debug("Ignoring $cpan_file\n");
+ next;
+ }
+ my $d = CPAN::DistnameInfo->new($cpan_file);
+ next unless ($d->maturity eq 'released');
+ my $dist_name = $d->dist;
+ my $dist_vers = $d->version;
+ my $cpanid = $d->cpanid;
+ my $dist_file = $d->filename;
+ unless ($dist_name and $dist_vers and $cpanid) {
+ print_debug("No dist_name/version/cpanid for $cpan_file: skipping\n");
+ delete $cpan_files->{$cpan_file};
+ next;
+ }
+ # ignore specified dists
+ if ($pat and ($dist_name =~ /^($pat)$/)) {
+ delete $cpan_files->{$cpan_file};
+ print_debug("Ignoring $dist_name\n");
+ next;
+ }
+ if (not $dists->{$dist_name} or
+ vcmp($dist_vers, $dists->{$dist_name}->{dist_vers}) > 0) {
+ $dists->{$dist_name}->{dist_vers} = $dist_vers;
+ $dists->{$dist_name}->{dist_file} = $dist_file;
+ $dists->{$dist_name}->{cpanid} = $cpanid;
+ }
+ }
+
+ my $wanted;
+ foreach my $dist_name (keys %$dists) {
+ $wanted->{basename($dists->{$dist_name}->{dist_file})} = $dist_name;
+ }
+ foreach my $mod_name (keys %$packages) {
+ my $file = basename($packages->{$mod_name}->{dist_file});
+ my $dist_name = $wanted->{$file};
+ unless ($dist_name and $dists->{$dist_name}) {
+ delete $packages->{$mod_name};
+ next;
+ }
+ $mods->{$mod_name}->{dist_name} = $dist_name;
+ $dists->{$dist_name}->{modules}->{$mod_name}++;
+ $mods->{$mod_name}->{mod_vers} = $packages->{$mod_name}->{mod_vers};
+ if (my $info = $modlist->{$mod_name}) {
+ if (my $mod_abs = $info->{description}) {
+ $mods->{$mod_name}->{mod_abs} = $mod_abs;
+ (my $trial_dist = $mod_name) =~ s!::!-!g;
+ if ($trial_dist eq $dist_name) {
+ $dists->{$dist_name}->{dist_abs} = $mod_abs;
+ }
+ }
+ if (my $chapterid = $info->{chapterid} + 0) {
+ $mods->{$mod_name}->{chapterid} = $chapterid;
+ (my $sub_chapter = $mod_name) =~ s!^([^:]+).*!$1!;
+ $dists->{$dist_name}->{chapterid}->{$chapterid}->{$sub_chapter}++;
+ }
+ my %dslip = ();
+ for (qw(statd stats statl stati statp) ) {
+ next unless defined $info->{$_};
+ $dslip{$_} = $info->{$_};
+ }
+ if (%dslip) {
+ my $value = '';
+ foreach (qw(d s l i p)) {
+ my $key = 'stat' . $_;
+ $value .= (defined $dslip{$key} ?
+ $dslip{$key} : '?');
+ }
+ $mods->{$mod_name}->{dslip} = $value;
+ (my $trial_dist = $mod_name) =~ s!::!-!g;
+ if ($trial_dist eq $dist_name) {
+ $dists->{$dist_name}->{dslip} = $value;
+ }
+ }
+ }
+ }
+ $self->{dists} = $dists;
+ $self->{mods} = $mods;
+}
+
+sub modlist {
+ my $self = shift;
+ my $index = 'modules/03modlist.data.gz';
+ my $mod = $self->{keep_source_where} ?
+ CPAN::FTP->localize($index,
+ catfile($self->{keep_source_where}, $index) ) :
+ catfile($self->{CPAN}, $index);
+ return unless check_file('modules/03modlist.data.gz', $mod);
+ print_debug("Reading information from $mod\n");
+ my $lines = zcat($mod);
+ while (@$lines) {
+ my $shift = shift(@$lines);
+ last if $shift =~ /^\s*$/;
+ }
+ push @$lines, q{CPAN::Modulelist->data;};
+ my($comp) = Safe->new("CPAN::Safe1");
+ my($eval) = join("\n", @$lines);
+ my $ret = $comp->reval($eval);
+ die "Cannot eval $mod: $@" if $@;
+ return $ret;
+}
+
+sub packages {
+ my $self = shift;
+ my $index = 'modules/02packages.details.txt.gz';
+ my $packages = $self->{keep_source_where} ?
+ CPAN::FTP->localize($index,
+ catfile($self->{keep_source_where}, $index) ) :
+ catfile($self->{CPAN}, $index);
+ return unless check_file('modules/02packages.details.txt.gz', $packages);
+ print_debug("Reading information from $packages\n");
+ my $lines = zcat($packages);
+ while (@$lines) {
+ my $shift = shift(@$lines);
+ last if $shift =~ /^\s*$/;
+ }
+ my ($mods, $cpan_files);
+ foreach (@$lines) {
+ my ($mod_name,$mod_vers,$dist_file,$comment) = split " ", $_, 4;
+ $mod_vers = undef if $mod_vers eq 'undef';
+ $mods->{$mod_name} = {mod_vers => $mod_vers, dist_file => $dist_file};
+ $cpan_files->{$dist_file}++;
+ }
+ return ($mods, $cpan_files);
+}
+
+sub mailrc {
+ my $self = shift;
+ my $index = 'authors/01mailrc.txt.gz';
+ my $mailrc = $self->{keep_source_where} ?
+ CPAN::FTP->localize($index,
+ catfile($self->{keep_source_where}, $index) ) :
+ catfile($self->{CPAN}, $index);
+ return unless check_file('authors/01mailrc.txt.gz', $mailrc);
+ print_debug("Reading information from $mailrc\n");
+ my $lines = zcat($mailrc);
+ my $auths;
+ foreach (@$lines) {
+ #my($cpanid,$fullname,$email) =
+ #m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
+ my ($cpanid, $authinfo) = m/alias\s+(\S+)\s+\"([^\"]+)\"/;
+ next unless $cpanid;
+ my ($fullname, $email);
+ if ($authinfo =~ m/([^<]+)\<(.*)\>/) {
+ $fullname = $1;
+ $email = $2;
+ }
+ else {
+ $fullname = '';
+ $email = lc($cpanid) . '@cpan.org';
+ }
+ $auths->{$cpanid} = {fullname => trim($fullname),
+ email => trim($email)};
+ }
+ $self->{auths} = $auths;
+}
+
+sub check_file {
+ my ($index, $file) = @_;
+ unless ($file) {
+ warn qq{index file '$index' not defined};
+ return;
+ }
+ unless (-f $file) {
+ warn qq{index file '$file' not found};
+ return;
+ }
+ return 1;
+}
+
+sub zcat {
+ my $file = shift;
+ my ($buffer, $lines);
+ my $gz = gzopen($file, 'rb')
+ or die "Cannot open $file: $gzerrno";
+ while ($gz->gzreadline($buffer) > 0) {
+ push @$lines, $buffer;
+ }
+ die "Error reading from $file: $gzerrno" . ($gzerrno+0)
+ if $gzerrno != Z_STREAM_END;
+ $gz->gzclose();
+ return $lines;
+}
+
+sub trim {
+ my $string = shift;
+ return '' unless $string;
+ $string =~ s/^\s+//;
+ $string =~ s/\s+$//;
+ $string =~ s/\s+/ /g;
+ return $string;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::Info - extract information from CPAN indices
+
+=head1 DESCRIPTION
+
+This module extracts information from the CPAN indices
+F<$CPAN/modules/03modlist.data.gz>,
+F<$CPAN/modules/02packages.details.txt.gz>, and
+F<$CPAN/authors/01mailrc.txt.gz>.
+
+A C<CPAN::SQLite::Info> object is created with
+
+ my $info = CPAN::SQLite::Info->new(CPAN => $cpan);
+
+where C<$cpan> specifies the top-level CPAN directory
+underneath which the index files are found. Calling
+
+ $info->fetch_info();
+
+will result in the object being populated with 3 hash references:
+
+=over 3
+
+=item * C<$info-E<gt>{dists}>
+
+This contains information on distributions. Keys of this hash
+reference are the distribution names, with the associated value being a
+hash reference with keys of
+
+=over 3
+
+=item C<dist_vers> - the version of the CPAN file
+
+=item C<dist_file> - the CPAN filename
+
+=item C<cpanid> - the CPAN author id
+
+=item C<dist_abs> - a description, if available
+
+=item C<modules> - specifies the modules present in the distribution:
+
+ for my $module (keys %{$info->{$distname}->{modules}}) {
+ print "Module: $module\n";
+ }
+
+=item C<chapterid> - specifies the chapterid and the subchapter
+for the distribution:
+
+ for my $id (keys %{$info->{$distname}->{chapterid}}) {
+ print "For chapterid $id\n";
+ for my $sc (keys %{$info->{$distname}->{chapterid}->{$id}}) {
+ print " Subchapter: $sc\n";
+ }
+ }
+
+=back
+
+=item * C<$info-E<gt>{mods}>
+
+This contains information on modules. Keys of this hash
+reference are the module names, with the associated values being a
+hash reference with keys of
+
+=over 3
+
+=item C<dist_name> - the distribution name containing the module
+
+=item C<mod_vers> - the version
+
+=item C<mod_abs> - a description, if available
+
+=item C<chapterid> - the chapter id of the module, if present
+
+=item C<dslip> - a 5 character string specifying the dslip
+(development, support, language, interface, public licence) information.
+
+=back
+
+=item * C<$info-E<gt>{auths}>
+
+This contains information on CPAN authors. Keys of this hash
+reference are the CPAN ids, with the associated value being a
+hash reference with keys of
+
+=over 3
+
+=item C<fullname> - the author's full name
+
+=item C<email> - the author's email address
+
+=back
+
+=back
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Index>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/META.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/META.pm
new file mode 100755
index 00000000000..b1309eaf1d8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/META.pm
@@ -0,0 +1,480 @@
+package CPAN::SQLite::META;
+require CPAN::SQLite;
+use strict;
+use warnings;
+use base qw(Exporter);
+our @EXPORT_OK;
+@EXPORT_OK = qw(setup update);
+our $global_id;
+our $VERSION = '0.199';
+
+sub new {
+ my ($class, $cpan_meta) = @_;
+ my $cpan_sqlite = CPAN::SQLite->new();
+ bless {cpan_meta => $cpan_meta, cpan_sqlite => $cpan_sqlite}, $class;
+}
+
+sub set {
+ my ($self, $class, $id) = @_;
+ my $sqlite_obj = $self->make_obj(class => $class, id => $id);
+ return $sqlite_obj->set_one();
+}
+
+sub search {
+ my ($self, $class, $regex) = @_;
+ my $sqlite_obj = $self->make_obj(class => $class, regex => $regex);
+ $sqlite_obj->set_many();
+}
+
+sub make_obj {
+ my ($self, %args) = @_;
+ my $class = $args{class};
+ die qq{Must supply a CPAN::* class string}
+ unless ($class and $class =~ /^CPAN::/);
+ (my $type = $class) =~ s/^CPAN//;
+ my $package = __PACKAGE__ . $type;
+ bless {cpan_meta => $self->{cpan_meta},
+ cpan_sqlite => $self->{cpan_sqlite},
+ class => $class,
+ id => $args{id}, regex => $args{regex},
+ }, $package;
+}
+
+package CPAN::SQLite::META::Author;
+use base qw(CPAN::SQLite::META);
+use CPAN::SQLite::Util qw(has_hash_data);
+
+sub set_one {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $id = $self->{id};
+ my $class = $self->{class};
+ $cpan_sqlite->{results} = {};
+ $cpan_sqlite->query(mode => 'author', name => $id, meta_obj => $self);
+ my $cpan_meta = $self->{cpan_meta};
+ $cpan_meta->{readonly}{$class}{$id};
+}
+
+sub set_many {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $regex = $self->{regex};
+ $cpan_sqlite->{results} = [];
+ $cpan_sqlite->query(mode => 'author', query => $regex, meta_obj => $self);
+}
+
+sub set_data {
+ my ($self, $results) = @_;
+ $self->set_author($results->{cpanid}, $results);
+}
+
+package CPAN::SQLite::META::Distribution;
+use base qw(CPAN::SQLite::META);
+use CPAN::SQLite::Util qw(has_hash_data download);
+use CPAN::DistnameInfo;
+my $ext = qr{\.(tar\.gz|tar\.Z|tgz|zip)$};
+
+sub set_one {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $id = $self->{id};
+ my ($dist_name, $dist_id);
+ if ($id =~ /$ext/) {
+ ($dist_name, $dist_id) = $self->extract_distinfo($id);
+ }
+ return unless ($dist_name and $dist_id);
+ my $class = $self->{class};
+ $cpan_sqlite->{results} = {};
+ $cpan_sqlite->query(mode => 'dist', name => $dist_name, meta_obj => $self);
+ my $cpan_meta = $self->{cpan_meta};
+ $cpan_meta->{readonly}{$class}{$dist_id};
+}
+
+sub set_many {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $regex = $self->{regex};
+ $cpan_sqlite->{results} = [];
+ $cpan_sqlite->query(mode => 'dist', query => $regex, meta_obj => $self);
+}
+
+sub set_data {
+ my ($self, $results) = @_;
+ $global_id = $results->{download};
+ $self->set_dist($results->{download}, $results);
+}
+
+sub set_list_data {
+ my ($self, $results, $download) = @_;
+ $global_id = $download;
+ $self->set_containsmods($results);
+ $global_id = undef;
+}
+
+package CPAN::SQLite::META::Module;
+use base qw(CPAN::SQLite::META);
+use CPAN::SQLite::Util qw(has_hash_data);
+
+sub set_one {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $id = $self->{id};
+ return if ($id =~ /^Bundle::/);
+ my $class = $self->{class};
+ $cpan_sqlite->{results} = {};
+ $cpan_sqlite->query(mode => 'module', name => $id, meta_obj => $self);
+ my $cpan_meta = $self->{cpan_meta};
+ $cpan_meta->{readonly}{$class}{$id};
+}
+
+sub set_many {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $regex = $self->{regex};
+ $cpan_sqlite->{results} = [];
+ $cpan_sqlite->query(mode => 'module', query => $regex, meta_obj => $self);
+}
+
+sub set_data {
+ my ($self, $results) = @_;
+ $self->set_module($results->{mod_name}, $results);
+ $global_id = $results->{download};
+ $self->set_dist($results->{download}, $results);
+}
+
+sub set_list_data {
+ my ($self, $results, $download) = @_;
+ $global_id = $download;
+ $self->set_containsmods($results);
+ $global_id = undef;
+}
+
+package CPAN::SQLite::META::Bundle;
+use base qw(CPAN::SQLite::META);
+use CPAN::SQLite::Util qw(has_hash_data);
+
+sub set_one {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $id = $self->{id};
+ unless ($id =~ /^Bundle::/) {
+ $id = 'Bundle::' . $id;
+ }
+ my $class = $self->{class};
+ $cpan_sqlite->{results} = {};
+ $cpan_sqlite->query(mode => 'module', name => $id, meta_obj => $self);
+ my $cpan_meta = $self->{cpan_meta};
+ $cpan_meta->{readonly}{$class}{$id};
+}
+
+sub set_many {
+ my $self = shift;
+ my $cpan_sqlite = $self->{cpan_sqlite};
+ my $regex = $self->{regex};
+ unless ($regex =~ /(^Bundle::|[\^\$\*\+\?\|])/i) {
+ $regex = '^Bundle::' . $regex;
+ }
+ $regex = '^Bundle::' if $regex eq '^';
+ $cpan_sqlite->{results} = [];
+ $cpan_sqlite->query(mode => 'module', query => $regex, meta_obj => $self);
+}
+
+sub set_data {
+ my ($self, $results) = @_;
+ $self->set_bundle($results->{mod_name}, $results);
+ $global_id = $results->{download};
+ $self->set_dist($results->{download}, $results);
+}
+
+sub set_list_data {
+ my ($self, $results, $download) = @_;
+ $global_id = $download;
+ $self->set_containsmods($results);
+ $global_id = undef;
+}
+
+package CPAN::SQLite::META;
+use CPAN::SQLite::Util qw(download);
+
+my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+my @days = qw(Sun Mon Tue Wed Thu Fri Sat);
+
+sub set_author {
+ my ($self, $id, $results) = @_;
+ my $class = 'CPAN::Author';
+ my $cpan_meta = $self->{cpan_meta};
+ $cpan_meta->instance(
+ $class => $id
+ )->set(
+ 'FULLNAME' => $results->{fullname},
+ 'EMAIL' => $results->{email},
+ );
+}
+
+sub set_module {
+ my ($self, $id, $results) = @_;
+ my $class = 'CPAN::Module';
+ my $cpan_meta = $self->{cpan_meta};
+ my %dslip;
+ if (my $dslip = $results->{dslip}) {
+ my @values = split '', $dslip;
+ for (qw(d s l i p)) {
+ $dslip{'stat' . $_} = shift @values;
+ }
+ }
+ my $d = $cpan_meta->instance(
+ $class => $id
+ );
+ $d->set(
+ 'description' => $results->{mod_abs},
+ 'userid' => $results->{cpanid},
+ 'CPAN_VERSION' => $results->{mod_vers},
+ 'CPAN_FILE' => $results->{download},
+ 'CPAN_USERID' => $results->{cpanid},
+ 'chapterid' => $results->{chapterid},
+ %dslip,
+ );
+}
+
+sub set_bundle {
+ my ($self, $id, $results) = @_;
+ my $class = 'CPAN::Bundle';
+ my $cpan_meta = $self->{cpan_meta};
+ my %dslip;
+ if (my $dslip = $results->{dslip}) {
+ my @values = split '', $dslip;
+ for (qw(d s l i p)) {
+ $dslip{'stat' . $_} = shift @values;
+ }
+ }
+ my $d = $cpan_meta->instance(
+ $class => $id
+ );
+ $d->set(
+ 'description' => $results->{mod_abs},
+ 'userid' => $results->{cpanid},
+ 'CPAN_VERSION' => $results->{mod_vers},
+ 'CPAN_FILE' => $results->{download},
+ 'CPAN_USERID' => $results->{cpanid},
+ 'chapterid' => $results->{chapterid},
+ %dslip,
+ );
+}
+
+sub set_dist {
+ my ($self, $id, $results) = @_;
+ my $class = 'CPAN::Distribution';
+ my $cpan_meta = $self->{cpan_meta};
+ my $d = $cpan_meta->instance(
+ $class => $id
+ );
+ $d->set(
+ 'DESCRIPTION' => $results->{dist_abs},
+ 'CPAN_USERID' => $results->{cpanid},
+ 'CPAN_VERSION' => $results->{dist_vers},
+ );
+}
+
+sub set_containsmods {
+ my ($self, $mods) = @_;
+ my $class = 'CPAN::Distribution';
+ my $cpan_meta = $self->{cpan_meta};
+ my %containsmods;
+ if ($mods and (ref($mods) eq 'ARRAY')) {
+ %containsmods = map {$_->{mod_name} => 1} @$mods;
+ }
+ my $d = $cpan_meta->instance(
+ $class => $global_id
+ );
+ $d->{CONTAINSMODS} = \%containsmods;
+}
+
+sub reload {
+ my($self, %args) = @_;
+ my $time = $args{'time'} || time;
+ my $force = $args{force};
+ my $db_name = $CPAN::SQLite::db_name;
+ my $db = File::Spec->catfile($CPAN::Config->{cpan_home}, $db_name);
+ my $journal_file = $db . '-journal';
+ if (-e $journal_file) {
+ warn qq{Database locked - cannot update.};
+ return;
+ }
+ my @args = ($^X, '-MCPAN::SQLite::META=setup,update', '-e');
+ if (-e $db && -s _) {
+ my $mtime_db = (stat(_))[9];
+ my $time_string = gmtime_string($mtime_db);
+ warn "Database was generated on $time_string\n";
+ unless ($force) {
+ return if (($time - $mtime_db) < $CPAN::Config->{index_expire}*86400);
+ }
+ warn "Updating database file ...\n";
+ push @args, q{update};
+ }
+ else {
+ unlink($db) if -e _;
+ warn "Creating database file ...\n";
+ push @args, q{setup};
+ }
+ if ($CPAN::SQLite::DBI::dbh) {
+ $CPAN::SQLite::DBI::dbh->disconnect();
+ $CPAN::SQLite::DBI::dbh = undef;
+ }
+ system(@args) == 0 or die qq{system @args failed: $?};
+ warn "Done!\n";
+}
+
+sub setup {
+ my $obj = CPAN::SQLite->new(setup => 1);
+ $obj->index() or die qq{CPAN::SQLite setup failed};
+}
+
+sub update {
+ my $obj = CPAN::SQLite->new();
+ $obj->index() or die qq{CPAN::SQLite update failed};
+}
+
+sub gmtime_string {
+ my $time = shift;
+ return unless $time;
+ my @a = gmtime($time);
+ my $string = sprintf("%s, %02d %s %d %02d:%02d:%02d GMT",
+ $days[$a[6]], $a[3], $months[$a[4]],
+ $a[5] + 1900, $a[2], $a[1], $a[0]);
+ return $string;
+}
+
+sub extract_distinfo {
+ my ($self, $pathname) = @_;
+ unless ($pathname =~ m{^\w/\w\w/}) {
+ $pathname =~ s{^(\w)(\w)(.*)}{$1/$1$2/$1$2$3};
+ }
+ my $d = CPAN::DistnameInfo->new($pathname);
+ my $dist = $d->dist;
+ my $download = download($d->cpanid, $d->filename);
+ return ($dist and $download) ? ($dist, $download) : undef;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::META - helper module for CPAN.pm integration
+
+=head1 DESCRIPTION
+
+This module has no direct public interface, but is intended
+as a helper module for use of CPAN::SQLite within the CPAN.pm
+module. A new object is created as
+
+ my $obj = CPAN::SQLite::META->new($CPAN::META);
+
+where C<$CPAN::META> comes from CPAN.pm. There are then
+two main methods available.
+
+=over 4
+
+=item C<set>
+
+This is used as
+
+ $obj->set($class, $id);
+
+where C<$class> is one of C<CPAN::Author>, C<CPAN::Module>, or
+C<CPAN::Distribution>, and C<$id> is the id CPAN.pm uses to
+identify the class. The method searches the C<CPAN::SQLite>
+database by name using the appropriate C<author>, C<dist>,
+or C<module> mode, and if a result is found, calls
+
+ $CPAN::META->instance(
+ $class => $id
+ )->set(
+ %attributes
+ );
+
+to register an instance of this class within C<CPAN.pm>.
+
+=item C<ssearch>
+
+This is used as
+
+ $obj->search($class, $id);
+
+where C<$class> is one of C<CPAN::Author>, C<CPAN::Module>, or
+C<CPAN::Distribution>, and C<$id> is the id CPAN.pm uses to
+identify the class. The method searches the C<CPAN::SQLite>
+database by C<query> using the appropriate C<author>, C<dist>,
+or C<module> mode, and if results are found, calls
+
+ $CPAN::META->instance(
+ $class => $id
+ )->set(
+ %attributes
+ );
+
+for each match to register an instance of this class
+within C<CPAN.pm>.
+
+=back
+
+The attributes set within C<$CPAN::META->instance> depend
+on the particular class.
+
+=over
+
+=item author
+
+The attributes are
+
+ 'FULLNAME' => $results->{fullname},
+ 'EMAIL' => $results->{email},
+
+where C<$results> are the results returned from C<CPAN::SQLite>.
+
+=item module
+
+The attributes are
+
+ 'description' => $results->{mod_abs},
+ 'userid' => $results->{cpanid},
+ 'CPAN_VERSION' => $results->{mod_vers},
+ 'CPAN_FILE' => $results->{download},
+ 'CPAN_USERID' => $results->{cpanid},
+ 'chapterid' => $results->{chapterid},
+ %dslip,
+
+where C<$results> are the results returned from C<CPAN::SQLite>.
+Here, C<%dslip> is a hash containing keys C<statd>, C<stats>,
+C<statl>, C<stati>, and C<statp>, with corresponding values
+being the registered dslip entries for the module, if present.
+
+=item dist
+
+The attributes are
+
+ 'DESCRIPTION' => $results->{dist_abs},
+ 'CPAN_USERID' => $results->{cpanid},
+ 'CPAN_VERSION' => $results->{dist_vers},
+
+As well, a C<CONTAINSMODS> key to C<$CPAN::META> is added, this
+being a hash reference whose keys are the modules contained
+within the distribution.
+
+=back
+
+There is also a method available C<reload>, which rebuilds
+the database. It can be used as
+
+ $obj->reload(force => 1, time => $time);
+
+The C<time> option (which, if not passed in, will default to the
+current time) will be used to compare the current time to
+the mtime of the database file; if they differ by more than
+one day, the database will be rebuilt. The <force> option, if
+given, will force a rebuilding of the database regardless
+of the time difference.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Populate.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Populate.pm
new file mode 100755
index 00000000000..ec03f9bdecf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Populate.pm
@@ -0,0 +1,958 @@
+package CPAN::SQLite::Populate;
+use strict;
+use warnings;
+no warnings qw(redefine);
+use CPAN::SQLite::Util qw($table_id has_hash_data print_debug);
+use CPAN::SQLite::DBI::Index;
+use CPAN::SQLite::DBI qw($dbh);
+use File::Find;
+use File::Basename;
+use File::Spec::Functions;
+use File::Path;
+
+our $dbh = $CPAN::SQLite::DBI::dbh;
+my ($setup);
+our $VERSION = '0.199';
+
+my %tbl2obj;
+$tbl2obj{$_} = __PACKAGE__ . '::' . $_
+ for (qw(dists mods auths chaps));
+my %obj2tbl = reverse %tbl2obj;
+
+sub new {
+ my ($class, %args) = @_;
+
+ $setup = $args{setup};
+
+ my $index = $args{index};
+ my @tables = qw(dists mods auths);
+ foreach my $table (@tables) {
+ my $obj = $index->{$table};
+ die "Please supply a CPAN::SQLite::Index::$table object"
+ unless ($obj and ref($obj) eq "CPAN::SQLite::Index::$table");
+ }
+ my $state = $args{state};
+ unless ($setup) {
+ die "Please supply a CPAN::SQLite::State object"
+ unless ($state and ref($state) eq 'CPAN::SQLite::State');
+ }
+ my $cdbi = CPAN::SQLite::DBI::Index->new(%args);
+
+ my $self = {index => $index,
+ state => $state,
+ obj => {},
+ cdbi => $cdbi,
+ db_name => $args{db_name},
+ };
+ bless $self, $class;
+}
+
+sub populate {
+ my $self = shift;
+
+ if ($setup) {
+ unless ($self->{cdbi}->create_tables(setup => $setup)) {
+ warn "Creating tables failed";
+ return;
+ }
+ }
+ unless ($self->create_objs()) {
+ warn "Cannot create objects";
+ return;
+ }
+ unless ($self->populate_tables()) {
+ warn "Populating tables failed";
+ return;
+ }
+ return 1;
+}
+
+sub create_objs {
+ my $self = shift;
+ my @tables = qw(dists auths mods chaps);
+
+ foreach my $table (@tables) {
+ my $obj;
+ my $pack = $tbl2obj{$table};
+ my $index = $self->{index}->{$table};
+ if ($index and ref($index) eq "CPAN::SQLite::Index::$table") {
+ my $info = $index->{info};
+ return unless has_hash_data($info);
+ $obj = $pack->new(info => $info,
+ cdbi => $self->{cdbi}->{objs}->{$table});
+ }
+ else {
+ $obj = $pack->new(cdbi => $self->{cdbi}->{objs}->{$table});
+ }
+ $self->{obj}->{$table} = $obj;
+ }
+ foreach my $table (@tables) {
+ my $obj = $self->{obj}->{$table};
+ foreach (@tables) {
+ next if ref($obj) eq $tbl2obj{$_};
+ $obj->{obj}->{$_} = $self->{obj}->{$_};
+ }
+ }
+
+ unless ($setup) {
+ my $state = $self->{state};
+ my @tables = qw(auths dists mods);
+ my @data = qw(ids insert update delete);
+
+ foreach my $table (@tables) {
+ my $state_obj = $state->{obj}->{$table};
+ my $pop_obj = $self->{obj}->{$table};
+ $pop_obj->{$_} = $state_obj->{$_} for (@data);
+ }
+ }
+ return 1;
+}
+
+sub populate_tables {
+ my $self = shift;
+ my @methods = $setup ? qw(insert) : qw(insert update delete);
+ my @tables = qw(auths dists mods chaps);
+ for my $method (@methods) {
+ for my $table (@tables) {
+ my $obj = $self->{obj}->{$table};
+ unless ($obj->$method()) {
+ if (my $error = $obj->{error_msg}) {
+ print_debug("Fatal error from ", ref($obj), ": ", $error, $/);
+ return;
+ }
+ else {
+ my $info = $obj->{info_msg};
+ print_debug("Info from ", ref($obj), ": ", $info, $/);
+ }
+ }
+ }
+ }
+ return 1;
+}
+
+package CPAN::SQLite::Populate::auths;
+use base qw(CPAN::SQLite::Populate);
+use CPAN::SQLite::Util qw(has_hash_data print_debug);
+
+sub new {
+ my ($class, %args) = @_;
+ my $info = $args{info};
+ die "No author info available" unless has_hash_data($info);
+ my $cdbi = $args{cdbi};
+ die "No dbi object available"
+ unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::auths');
+ my $self = {
+ info => $info,
+ insert => {},
+ update => {},
+ delete => {},
+ ids => {},
+ obj => {},
+ cdbi => $cdbi,
+ error_msg => '',
+ info_msg => '',
+ };
+ bless $self, $class;
+}
+
+sub insert {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ my $info = $self->{info};
+ my $cdbi = $self->{cdbi};
+ my $data = $setup ? $info : $self->{insert};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No author data to insert};
+ return;
+ }
+ my $auth_ids = $self->{ids};
+ my @fields = qw(cpanid email fullname);
+ my $sth = $cdbi->sth_insert(\@fields) or do {
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ foreach my $cpanid (keys %$data) {
+ my $values = $info->{$cpanid};
+ next unless ($values and $cpanid);
+ print_debug("Inserting author $cpanid\n");
+ $sth->execute($cpanid, $values->{email}, $values->{fullname})
+ or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ $auth_ids->{$cpanid} =
+ $dbh->func('last_insert_rowid') or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ $sth->finish();
+ undef $sth;
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub update {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ my $data = $self->{update};
+ my $cdbi = $self->{cdbi};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No author data to update};
+ return;
+ }
+
+ my $info = $self->{info};
+ my @fields = qw(cpanid email fullname);
+ foreach my $cpanid (keys %$data) {
+ print_debug("Updating author $cpanid\n");
+ next unless $data->{$cpanid};
+ my $sth = $cdbi->sth_update(\@fields, $data->{$cpanid});
+ my $values = $info->{$cpanid};
+ next unless ($cpanid and $values);
+ $sth->execute($cpanid, $values->{email}, $values->{fullname})
+ or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ $sth->finish();
+ undef $sth;
+ }
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub delete {
+ my $self = shift;
+ $self->{info_msg} = q{No author data to delete};
+ return;
+}
+
+package CPAN::SQLite::Populate::dists;
+use base qw(CPAN::SQLite::Populate);
+use CPAN::SQLite::Util qw(has_hash_data print_debug);
+
+sub new {
+ my ($class, %args) = @_;
+ my $info = $args{info};
+ die "No dist info available" unless has_hash_data($info);
+ my $cdbi = $args{cdbi};
+ die "No dbi object available"
+ unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::dists');
+ my $self = {
+ info => $info,
+ insert => {},
+ update => {},
+ delete => {},
+ ids => {},
+ obj => {},
+ cdbi => $cdbi,
+ error_msg => '',
+ info_msg => '',
+ };
+ bless $self, $class;
+}
+
+sub insert {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ return unless my $auth_obj = $self->{obj}->{auths};
+ my $cdbi = $self->{cdbi};
+ my $auth_ids = $auth_obj->{ids};
+ my $dists = $self->{info};
+ my $data = $setup ? $dists : $self->{insert};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No dist data to insert};
+ return;
+ }
+ unless ($dists and $auth_ids) {
+ $self->{error_msg}->{index} = q{No dist index data available};
+ return;
+ }
+
+ my $dist_ids = $self->{ids};
+ my @fields = qw(auth_id dist_name dist_file dist_vers dist_abs dist_dslip);
+ my $sth = $cdbi->sth_insert(\@fields) or do {
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ foreach my $distname (keys %$data) {
+ my $values = $dists->{$distname};
+ my $cpanid = $values->{cpanid};
+ next unless ($values and $cpanid and $auth_ids->{$cpanid});
+ print_debug("Inserting $distname of $cpanid\n");
+ $sth->execute($auth_ids->{$values->{cpanid}}, $distname,
+ $values->{dist_file}, $values->{dist_vers},
+ $values->{dist_abs}, $values->{dslip}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ $dist_ids->{$distname} = $dbh->func('last_insert_rowid') or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ $sth->finish();
+ undef $sth;
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub update {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ my $cdbi = $self->{cdbi};
+ my $data = $self->{update};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No dist data to update};
+ return;
+ }
+ return unless my $auth_obj = $self->{obj}->{auths};
+ my $auth_ids = $auth_obj->{ids};
+ my $dists = $self->{info};
+ unless ($dists and $auth_ids) {
+ $self->{error_msg} = q{No dist index data available};
+ return;
+ }
+
+ my @fields = qw(auth_id dist_name dist_file dist_vers dist_abs dist_dslip);
+ foreach my $distname (keys %$data) {
+ next unless $data->{$distname};
+ my $sth = $cdbi->sth_update(\@fields, $data->{$distname});
+ my $values = $dists->{$distname};
+ my $cpanid = $values->{cpanid};
+ next unless ($values and $cpanid and $auth_ids->{$cpanid});
+ print_debug("Updating $distname of $cpanid\n");
+ $sth->execute($auth_ids->{$values->{cpanid}}, $distname,
+ $values->{dist_file}, $values->{dist_vers},
+ $values->{dist_abs}, $values->{dslip}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ $sth->finish();
+ undef $sth;
+ }
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub delete {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ my $cdbi = $self->{cdbi};
+ my $data = $self->{delete};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No dist data to delete};
+ return;
+ }
+
+ my $sth = $cdbi->sth_delete('dist_id');
+ foreach my $distname(keys %$data) {
+ print_debug("Deleting $distname\n");
+ $sth->execute($data->{$distname}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ $sth->finish();
+ undef $sth;
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+package CPAN::SQLite::Populate::mods;
+use base qw(CPAN::SQLite::Populate);
+use CPAN::SQLite::Util qw(has_hash_data print_debug);
+
+sub new {
+ my ($class, %args) = @_;
+ my $info = $args{info};
+ die "No module info available" unless has_hash_data($info);
+ my $cdbi = $args{cdbi};
+ die "No dbi object available"
+ unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::mods');
+ my $self = {
+ info => $info,
+ insert => {},
+ update => {},
+ delete => {},
+ ids => {},
+ obj => {},
+ cdbi => $cdbi,
+ error_msg => '',
+ info_msg => '',
+ };
+ bless $self, $class;
+}
+
+sub insert {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $cdbi = $self->{cdbi};
+ my $dist_ids = $dist_obj->{ids};
+ my $mods = $self->{info};
+ my $data = $setup ? $mods : $self->{insert};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No module data to insert};
+ return;
+ }
+ unless ($mods and $dist_ids) {
+ $self->{error_msg} = q{No module index data available};
+ return;
+ }
+
+ my $mod_ids = $self->{ids};
+ my @fields = qw(dist_id mod_name mod_abs
+ mod_vers dslip chapterid);
+
+ my $sth = $cdbi->sth_insert(\@fields) or do {
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ foreach my $modname(keys %$data) {
+ my $values = $mods->{$modname};
+ next unless ($values and $dist_ids->{$values->{dist_name}});
+ $sth->execute($dist_ids->{$values->{dist_name}}, $modname,
+ $values->{mod_abs}, $values->{mod_vers},
+ $values->{dslip}, $values->{chapterid})
+ or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ $mod_ids->{$modname} = $dbh->func('last_insert_rowid') or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ $sth->finish();
+ undef $sth;
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub update {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ my $cdbi = $self->{cdbi};
+ my $data = $self->{update};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No module data to update};
+ return;
+ }
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $dist_ids = $dist_obj->{ids};
+ my $mods = $self->{info};
+ unless ($dist_ids and $mods) {
+ $self->{error_msg} = q{No module index data available};
+ return;
+ }
+
+ my @fields = qw(dist_id mod_name mod_abs
+ mod_vers dslip chapterid);
+
+ foreach my $modname (keys %$data) {
+ next unless $data->{$modname};
+ print_debug("Updating $modname\n");
+ my $sth = $cdbi->sth_update(\@fields, $data->{$modname});
+ my $values = $mods->{$modname};
+ next unless ($values and $dist_ids->{$values->{dist_name}});
+ $sth->execute($dist_ids->{$values->{dist_name}}, $modname,
+ $values->{mod_abs}, $values->{mod_vers},
+ $values->{dslip}, $values->{chapterid})
+ or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ $sth->finish();
+ undef $sth;
+ }
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub delete {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $cdbi = $self->{cdbi};
+ my $data = $dist_obj->{delete};
+ if (has_hash_data($data)) {
+ my $sth = $cdbi->sth_delete('dist_id');
+ foreach my $distname(keys %$data) {
+ $sth->execute($data->{$distname}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ $sth->finish();
+ undef $sth;
+ }
+
+ $data = $self->{delete};
+ if (has_hash_data($data)) {
+ my $sth = $cdbi->sth_delete('mod_id');
+ foreach my $modname(keys %$data) {
+ $sth->execute($data->{$modname}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ print_debug("Deleting $modname\n");
+ }
+ $sth->finish;
+ undef $sth;
+ }
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+package CPAN::SQLite::Populate::chaps;
+use base qw(CPAN::SQLite::Populate);
+use CPAN::SQLite::Util qw(has_hash_data print_debug);
+
+sub new {
+ my ($class, %args) = @_;
+ my $cdbi = $args{cdbi};
+ die "No dbi object available"
+ unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::chaps');
+ my $self = {
+ obj => {},
+ cdbi => $cdbi,
+ error_msg => '',
+ info_msg => '',
+ };
+ bless $self, $class;
+}
+
+sub insert {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $cdbi = $self->{cdbi};
+ my $dist_insert = $dist_obj->{insert};
+ my $dists = $dist_obj->{info};
+ my $dist_ids = $dist_obj->{ids};
+ my $data = $setup ? $dists : $dist_insert;
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No chap data to insert};
+ return;
+ }
+ unless ($dists and $dist_ids) {
+ $self->{error_msg} = q{No chap index data available};
+ return;
+ }
+
+ my @fields = qw(chapterid dist_id subchapter);
+ my $sth = $cdbi->sth_insert(\@fields) or do {
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ foreach my $dist (keys %$data) {
+ my $values = $dists->{$dist};
+ next unless defined $values->{chapterid};
+ foreach my $chap_id(keys %{$values->{chapterid}}) {
+ foreach my $sub_chap(keys %{$values->{chapterid}->{$chap_id}}) {
+ next unless $dist_ids->{$dist};
+ $sth->execute($chap_id, $dist_ids->{$dist}, $sub_chap)
+ or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ }
+ }
+ $sth->finish();
+ undef $sth;
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub update {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ my $cdbi = $self->{cdbi};
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $dists = $dist_obj->{info};
+ my $dist_ids = $dist_obj->{ids};
+ my $data = $dist_obj->{update};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No chap data to update};
+ return;
+ }
+ unless ($dist_ids and $dists) {
+ $self->{error_msg} = q{No chap index data available};
+ return;
+ }
+
+ my $sth = $cdbi->sth_delete('dist_id');
+ foreach my $distname(keys %$data) {
+ next unless $data->{$distname};
+ $sth->execute($data->{$distname}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ $sth->finish();
+ undef $sth;
+
+ my @fields = qw(chapterid dist_id subchapter);
+ $sth = $cdbi->sth_insert(\@fields);
+ foreach my $dist (keys %$data) {
+ my $values = $dists->{$dist};
+ next unless defined $values->{chapterid};
+ foreach my $chap_id(keys %{$values->{chapterid}}) {
+ foreach my $sub_chap(keys %{$values->{chapterid}->{$chap_id}}) {
+ next unless $dist_ids->{$dist};
+ $sth->execute($chap_id, $dist_ids->{$dist}, $sub_chap)
+ or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ }
+ }
+ $sth->finish();
+ undef $sth;
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub delete {
+ my $self = shift;
+ unless ($dbh) {
+ $self->{error_msg} = q{No db handle available};
+ return;
+ }
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $cdbi = $self->{cdbi};
+ my $data = $dist_obj->{delete};
+ unless (has_hash_data($data)) {
+ $self->{info_msg} = q{No chap data to delete};
+ return;
+ }
+
+ my $sth = $cdbi->sth_delete('dist_id');
+ foreach my $distname(keys %$data) {
+ $sth->execute($data->{$distname}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ }
+ $sth->finish();
+ undef $sth;
+ $dbh->commit() or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+package CPAN::SQLite::Populate;
+
+sub db_error {
+ my ($obj, $sth) = @_;
+ return unless $dbh;
+ if ($sth) {
+ $sth->finish;
+ undef $sth;
+ }
+ $obj->{error_msg} = q{Database error: } . $dbh->errstr;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::Populate - create and populate database tables
+
+=head1 DESCRIPTION
+
+This module is responsible for creating the tables
+(if C<setup> is passed as an option) and then for
+inserting, updating, or deleting (as appropriate) the
+relevant information from the indices of
+I<CPAN::SQLite::Info> and the
+state information from I<CPAN::SQLite::State>. It does
+this through the C<insert>, C<update>, and C<delete>
+methods associated with each table.
+
+Note that the tables are created with the C<setup> argument
+passed into the C<new> method when creating the
+C<CPAN::SQLite::Index> object; existing tables will be
+dropped.
+
+=head1 TABLES
+
+The tables used are described below - the data types correspond
+to mysql tables, with the corresponding adjustments made if
+the SQLite database is used.
+
+=head2 mods
+
+This table contains module information, and is created as
+
+ mod_id INTEGER NOT NULL PRIMARY KEY
+ mod_name VARCHAR(100) NOT NULL
+ dist_id INTEGER NOT NULL
+ mod_abs TEXT
+ mod_vers VARCHAR(10)
+ dslip VARCHAR(5)
+ chapterid INTEGER
+
+=over 3
+
+=item * mod_id
+
+This is the primary (unique) key of the table.
+
+=item * dist_id
+
+This key corresponds to the id of the associated distribution
+in the C<dists> table.
+
+=item * mod_name
+
+This is the module's name.
+
+=item * mod_abs
+
+This is a description, if available, of the module.
+
+=item * mod_vers
+
+This value, if present, gives the version of the module.
+
+=item * dslip
+
+This is a 5 character string expressing the dslip
+(development, support, language, interface, public
+license) information.
+
+=item * chapterid
+
+This number corresponds to the chapter id of the module,
+if present.
+
+=back
+
+=head2 dists
+
+This table contains distribution information, and is created as
+
+ dist_id INTEGER NOT NULL PRIMARY KEY
+ dist_name VARCHAR(90) NOT NULL
+ auth_id INTEGER NOT NULL
+ dist_file VARCHAR(110) NOT NULL
+ dist_vers VARCHAR(20)
+ dist_abs TEXT
+ dist_dslip VARCHAR(5)
+
+=over 3
+
+=item * dist_id
+
+This is the primary (unique) key of the table.
+
+=item * auth_id
+
+This corresponds to the CPAN author id of the distribution
+in the C<auths> table.
+
+=item * dist_name
+
+This corresponds to the distribution name (eg, for
+F<My-Distname-0.22.tar.gz>, C<dist_name> will be C<My-Distname>).
+
+=item * dist_file
+
+This corresponds to the CPAN file name.
+
+=item * dist_vers
+
+This is the version of the CPAN file (eg, for
+F<My-Distname-0.22.tar.gz>, C<dist_vers> will be C<0.22>).
+
+=item * dist_abs
+
+This is a description of the distribtion. If not directly
+supplied, the description for, eg, C<Foo::Bar>, if present, will
+be used for the C<Foo-Bar> distribution.
+
+=item * dist_dslip
+
+This is a 5 character string expressing the dslip
+(development, support, language, interface, public
+license) information. Normally this comes from the
+module name; this value for the distribution name
+comes in simple cases where the module name
+matches the distribution name by a substitution of
+C<::> by C<->.
+
+=back
+
+=head2 auths
+
+This table contains CPAN author information, and is created as
+
+ auth_id INTEGER NOT NULL PRIMARY KEY
+ cpanid VARCHAR(20) NOT NULL
+ fullname VARCHAR(40) NOT NULL
+ email TEXT
+
+=over 3
+
+=item * auth_id
+
+This is the primary (unique) key of the table.
+
+=item * cpanid
+
+This gives the CPAN author id.
+
+=item * fullname
+
+This is the full name of the author.
+
+=item * email
+
+This is the supplied email address of the author.
+
+=back
+
+=head2 chaps
+
+This table contains chapter information associated with
+distributions. PAUSE allows one, when registering modules,
+to associate a chapter id with each module (see the C<mods>
+table). This information is used here to associate chapters
+(and subchapters) with distributions in the following manner.
+Suppose a distribution C<Quantum-Theory> contains a module
+C<Beta::Decay> with chapter id C<55>, and
+another module C<Laser> with chapter id C<87>. The
+C<Quantum-Theory> distribution will then have two
+entries in this table - C<chapterid> of I<55> and
+C<subchapter> of I<Beta>, and C<chapterid> of I<87> and
+C<subchapter> of I<Laser>.
+
+The table is created as follows.
+
+ chap_id INTEGER NOT NULL PRIMARY KEY
+ chapterid INTEGER
+ dist_id INTEGER NOT NULL
+ subchapter TEXT
+
+=over 3
+
+=item * chap_id
+
+This is the primary (unique) key of the table.
+
+=item * chapterid
+
+This number corresponds to the chapter id.
+
+=item * dist_id
+
+This is the id corresponding to the distribution in the
+C<dists> table.
+
+=item * subchapter
+
+This is the subchapter.
+
+=back
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Index>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Search.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Search.pm
new file mode 100755
index 00000000000..c09b549c606
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Search.pm
@@ -0,0 +1,520 @@
+package CPAN::SQLite::Search;
+use strict;
+use warnings;
+no warnings qw(redefine);
+use utf8;
+use CPAN::SQLite::Util qw($mode_info);
+use CPAN::SQLite::DBI::Search;
+
+our $max_results = 0;
+our $VERSION = '0.199';
+my $cdbi_query;
+
+my %mode2obj;
+$mode2obj{$_} = __PACKAGE__ . '::' . $_
+ for (qw(dist author module));
+
+sub new {
+ my ($class, %args) = @_;
+ $cdbi_query = CPAN::SQLite::DBI::Search->new(%args);
+ $max_results = $args{max_results} if $args{max_results};
+ my $self = {results => undef, error => '', %args};
+ bless $self, $class;
+}
+
+sub query {
+ my ($self, %args) = @_;
+ my $mode = $args{mode} || 'module';
+ unless ($mode) {
+ $self->{error} = q{Please specify a 'mode' argument};
+ return;
+ }
+ my $info = $mode_info->{$mode};
+ my $table = $info->{table};
+ unless ($table) {
+ $self->{error} = qq{No table exists for '$mode'};
+ return;
+ }
+ my $cdbi = $cdbi_query->{objs}->{$table};
+ my $class = 'CPAN::SQLite::DBI::Search::' . $table;
+ unless ($cdbi and ref($cdbi) eq $class) {
+ $self->{error} = qq{No cdbi object exists for '$table'};
+ return;
+ }
+ my $obj;
+ eval {$obj = $mode2obj{$mode}->make(table => $table, cdbi => $cdbi);};
+ if ($@) {
+ $self->{error} = qq{Mode '$mode' is not known};
+ return;
+ }
+ my $value;
+ my $search = {name => $info->{name},
+ text => $info->{text},
+ id => $info->{id},
+ };
+ TYPE: {
+ ($value = $args{query}) and do {
+ $search->{value} = $value;
+ $search->{type} = 'query';
+ $search->{wantarray} = 1;
+ last TYPE;
+ };
+ ($value = $args{id}) and do {
+ $search->{value} = $value;
+ $search->{type} = 'id';
+ $search->{distinct} = 1;
+ last TYPE;
+ };
+ ($value = $args{name}) and do {
+ $search->{value} = $value;
+ $search->{type} = 'name';
+ $search->{distinct} = 1;
+ last TYPE;
+ };
+ $self->{error} = q{Cannot determine the type of search};
+ return;
+ }
+
+ $obj->search(search => $search, meta_obj => $self->{meta_obj});
+ $self->{results} = $obj->{results};
+ if (my $error = $obj->{error}) {
+ $self->{error} = $error;
+ return;
+ }
+ return 1;
+}
+
+sub make {
+ my ($class, %args) = @_;
+ for (qw(table cdbi)) {
+ die qq{Must supply an '$_' arg} unless defined $args{$_};
+ }
+ my $self = {results => undef, error => '',
+ table => $args{table}, cdbi => $args{cdbi}};
+ bless $self, $class;
+}
+
+package CPAN::SQLite::Search::author;
+use base qw(CPAN::SQLite::Search);
+
+sub search {
+ my ($self, %args) = @_;
+ return unless $args{search};
+ my $cdbi = $self->{cdbi};
+ my $meta_obj = $args{meta_obj};
+ $args{fields} = [ qw(auth_id cpanid fullname email) ];
+ $args{table} = 'auths';
+ if ($max_results) {
+ $args{limit} = $max_results;
+ }
+ $args{order_by} = 'cpanid';
+ my $results;
+ return unless $results = ($meta_obj ?
+ $cdbi->fetch_and_set(%args) :
+ $cdbi->fetch(%args));
+ unless ($meta_obj) {
+ $self->{results} =
+ (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
+ $results->[0] : $results;
+ }
+ return 1 if $meta_obj;
+
+# The following will get all the dists associated with the cpanid
+ $args{join} = undef;
+ $args{table} = 'dists';
+ $args{fields} = [ qw(dist_file dist_abs) ];
+ $args{order_by} = 'dist_file';
+ my @items = (ref($results) eq 'ARRAY') ? @$results : ($results);
+ foreach my $item (@items) {
+ my $search = {id => 'auth_id',
+ value => $item->{auth_id},
+ type => 'id',
+ wantarray => 1,
+ };
+ my $dists;
+ next unless ($dists = $cdbi->fetch(%args, search => $search));
+ $item->{dists} = (ref($dists) eq 'ARRAY') ? $dists : [$dists];
+ }
+ $self->{results} =
+ (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
+ $results->[0] : $results;
+ return 1;
+}
+
+package CPAN::SQLite::Search::module;
+use base qw(CPAN::SQLite::Search);
+
+sub search {
+ my ($self, %args) = @_;
+ return unless $args{search};
+ my $cdbi = $self->{cdbi};
+ my $meta_obj = $args{meta_obj};
+
+ $args{fields} = [ qw(mod_id mod_name mod_abs mod_vers chapterid
+ dslip dist_id dist_name dist_file dist_vers dist_abs
+ auth_id cpanid fullname email) ];
+ $args{table} = 'dists';
+ $args{join} = { mods => 'dist_id',
+ auths => 'auth_id',
+ };
+ $args{order_by} = 'mod_name';
+ if ($max_results) {
+ $args{limit} = $max_results;
+ }
+ my $results;
+ return unless $results = ($meta_obj ?
+ $cdbi->fetch_and_set(%args, want_ids => 1) :
+ $cdbi->fetch(%args));
+# if running under CPAN.pm, need to build a list of modules
+# contained in the distribution
+ if ($meta_obj) {
+ my %seen;
+ $args{join} = undef;
+ $args{table} = 'mods';
+ my @items = (ref($results) eq 'ARRAY') ? @$results : ($results);
+ foreach my $item(@items) {
+ my $dist_id = $item->{dist_id};
+ next if $seen{$dist_id};
+ $args{fields} = [ qw(mod_name mod_abs) ];
+ $args{order_by} = 'mod_name';
+ $args{join} = undef;
+ my $search = {id => 'dist_id',
+ value => $item->{dist_id},
+ type => 'id',
+ wantarray => 1,
+ };
+ $seen{$dist_id}++;
+ my $mods;
+ next unless $mods = $cdbi->fetch_and_set(%args,
+ search => $search,
+ set_list => 1,
+ download => $item->{download});
+ }
+ }
+ unless ($meta_obj) {
+ $self->{results} =
+ (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
+ $results->[0] : $results;
+ }
+ return 1;
+}
+
+package CPAN::SQLite::Search::dist;
+use base qw(CPAN::SQLite::Search);
+
+sub search {
+ my ($self, %args) = @_;
+ return unless $args{search};
+ my $cdbi = $self->{cdbi};
+ my $meta_obj = $args{meta_obj};
+
+ $args{fields} = [ qw(dist_id dist_name dist_abs dist_vers dist_dslip
+ dist_file auth_id cpanid fullname email) ];
+ $args{table} = 'dists';
+ $args{join} = {auths => 'auth_id'};
+ $args{order_by} = 'dist_name';
+ if ($max_results) {
+ $args{limit} = $max_results;
+ }
+ my $results;
+ return unless $results = ($meta_obj ?
+ $cdbi->fetch_and_set(%args, want_ids => 1) :
+ $cdbi->fetch(%args));
+
+ $args{join} = undef;
+ $args{table} = 'mods';
+ $args{fields} = [ qw(mod_name mod_abs) ];
+ $args{order_by} = 'mod_name';
+ my @items = (ref($results) eq 'ARRAY') ? @$results : ($results);
+ foreach my $item(@items) {
+ my $search = {id => 'dist_id',
+ value => $item->{dist_id},
+ type => 'id',
+ wantarray => 1,
+ };
+ my $mods;
+ next unless $mods = ($meta_obj ?
+ $cdbi->fetch_and_set(%args,
+ search => $search,
+ set_list => 1,
+ download => $item->{download}) :
+ $cdbi->fetch(%args,
+ search => $search) );
+ next if $meta_obj;
+ $item->{mods} = (ref($mods) eq 'ARRAY') ? $mods : [$mods];
+ }
+ unless ($meta_obj) {
+ $self->{results} =
+ (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
+ $results->[0] : $results;
+ }
+ return 1;
+}
+
+package CPAN::SQLite::Search;
+
+sub mod_subchapter {
+ my ($self, $mod_name) = @_;
+ (my $sc = $mod_name) =~ s{^([^:]+).*}{$1};
+ return $sc;
+}
+
+sub dist_subchapter {
+ my ($self, $dist_name) = @_;
+ (my $sc = $dist_name) =~ s{^([^-]+).*}{$1};
+ return $sc;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::Search - perform queries on the database
+
+=head1 SYNOPSIS
+
+ my $max_results = 200;
+ my $query = CPAN::SQLite::Search->new(db_dir => $db_dir,
+ db_name => $db_name,
+ max_results => $max_results);
+ $query->query(mode => 'module', name => 'Net::FTP');
+ my $results = $query->{results};
+
+=head1 CONSTRUCTING THE QUERY
+
+This module queries the database via various types of queries
+and returns the results for subsequent display. The
+C<CPAN::SQLite::Search> object is created via the C<new> method as
+
+ my $query = CPAN::SQLite::Search->new(db_dir => $db_dir,
+ db_name => $db_name,
+ max_results => $max_results);
+
+which takes as arguments
+
+=over 3
+
+=item * db_dir =E<gt> $db_dir
+
+This is the directory where the database file is stored. This is
+optional if the C<CPAN> option is given.
+
+=item * CPAN =E<gt> $CPAN
+
+This option specifies the C<cpan_home> directory of an
+already configured CPAN.pm, which is where the database
+file will be stored if C<db_dir> is not given.
+
+=item * max_results =E<gt> $max_results
+
+This is the maximum value used to limit the number of results
+returned under a user query. If not specified, a value contained
+within C<CPAN::SQLite::Search> will be used.
+
+=back
+
+A basic query then is constructed as
+
+ $query->query(mode => $mode, $type => $value);
+
+with the results available as
+
+ my $results = $query->{results}
+
+There are three basic modes:
+
+=over 3
+
+=item * module
+
+This is for information on modules.
+
+=item * dist
+
+This is for information on distributions.
+
+=item * author
+
+This is for information on CPAN authors or cpanids.
+
+=back
+
+=head2 C<module>, C<dist>, and C<author> modes
+
+For a mode of C<module>, C<dist>, and C<author>, there are
+four basic options to be used for the C<$type =E<gt> $value> option:
+
+=over 3
+
+=item * query =E<gt> $query_term
+
+This will search through module names,
+distribution names, or CPAN author names and ids
+(for C<module>, C<dist>, and C<author> modes
+respectively). The results are case insensitive,
+and Perl regular expressions for the C<$query_term>
+are recognized.
+
+=item * name =E<gt> $name
+
+This will report exact matches (in a case sensitive manner)
+for the module name, distribution name, or CPAN author id,
+for C<module>, C<dist>, and C<author> modes
+respectively.
+
+=item * id =E<gt> $id
+
+This will look up information on the primary key according
+to the mode specified. This is more for internal use,
+to help speed up queries; using this "publically" is
+probably not a good idea, as the ids may change over the
+course of time.
+
+=back
+
+=head1 RESULTS
+
+After making the query, the results can be accessed through
+
+ my $results = $query->{results};
+
+No results either can mean no matches were found, or
+else an error in making the query resulted (in which case,
+a brief error message is contained in C<$query-E<gt>{error}>).
+Assuming there are results, what is returned depends on
+the mode and on the type of query. See L<CPAN::SQLite::Populate>
+for a description of the fields in the various tables
+listed below - these fields are used as the keys of the
+hash references that arise.
+
+=head2 C<author> mode
+
+=over 3
+
+=item * C<name> or C<id> query
+
+This returns the C<auth_id>, C<cpanid>, C<email>, and C<fullname>
+of the C<auths> table. As well, an array reference
+C<$results-E<gt>{dists}> is returned representing
+all distributions associated with that C<cpanid> - each
+member of the array reference is a hash reference
+describing the C<dist_id>, C<dist_name>,
+C<dist_abs>, C<dist_vers>, and C<dist_file> fields in the
+C<dists> table. An additional entry, C<download>, is
+supplied, which can be used as C<$CPAN/authors/id/$download>
+to specify the url of the distribution.
+
+=item * C<query> query
+
+If this results in more than one match, an array reference
+is returned, each member of which is a hash reference containg
+the C<auth_id>, C<cpanid>, and C<fullname> fields. If there
+is only one result found, a C<name> query based on the
+matched C<cpanid> is performed.
+
+=back
+
+=head2 C<module> mode
+
+=over 3
+
+=item * C<name> or C<id> query
+
+This returns the C<mod_id>, C<mod_name>, C<mod_abs>, C<mod_vers>,
+C<dslip>, C<chapterid>, C<dist_id>, C<dist_name>, C<dist_file>,
+C<auth_id>, C<cpanid>, C<fullname>, and C<email>
+of the C<auths>, C<mods>, and C<dists> tables.
+As well, the following entries may be present.
+
+=over 3
+
+=item * C<download>
+
+This can be used as C<$CPAN/authors/id/$download>
+to specify the url of the distribution.
+
+=item * C<dslip_info>
+
+If C<dslip> is available, an array reference C<dslip_info> is supplied,
+each entry being a hash reference. The hash reference contains
+two keys - C<desc>, whose value is a general description of the
+what the dslip entry represents, and C<what>, whose value is
+a description of the entry itself.
+
+=back
+
+=item * C<query> query
+
+If this results in more than one match, an array reference
+is returned, each member of which is a hash reference containing
+the C<mod_id>, C<mod_name>, C<mod_abs>, C<mod_abs>, C<dist_vers>, C<dist_abs>,
+C<auth_id>, C<cpanid>, C<dist_id>, C<dist_name>, and C<dist_file>.
+As well, a C<download> field which
+can be used as C<$CPAN/authors/id/$download>
+to specify the url of the distribution is provided. If there
+is only one result found, a C<name> query based on the
+matched C<mod_name> is performed.
+
+=back
+
+=head2 C<dist> mode
+
+=over 3
+
+=item * C<name> or C<id> query
+
+This returns the C<dist_id>, C<dist_name>, C<dist_abs>, C<dist_vers>,
+C<dist_file>, C<size>, C<birth>, C<auth_id>, C<cpanid>, and C<fullname>
+of the C<auths>, C<mods>, and C<dists> tables.
+As well, the following entries may be present.
+
+=over 3
+
+=item * C<download>
+
+This can be used as C<$CPAN/authors/id/$download>
+to specify the url of the distribution.
+
+=item * C<mods>
+
+This is an array reference containing information on the
+modules present. Each entry is a hash reference containing the
+C<mod_id>, C<mod_name>, C<mod_abs>, C<mod_vers>, and C<dslip>
+fields for the module.
+
+=item * C<dslip> and C<dslip_info>
+
+If the module name and distribution name are related by
+C<s/::/->, the C<dslip> and C<dslip_info> entries for
+that module are returned.
+
+=back
+
+=item * C<query> query
+
+If this results in more than one match, an array reference
+is returned, each member of which is a hash reference containing
+the C<dist_id>, C<dist_name>, C<dist_abs>, C<dist_file>,
+and C<cpanid> fields. As well, a C<download> field which
+can be used as C<$CPAN/authors/id/$download>
+to specify the url of the distribution is provided. If there
+is only one result found, a C<name> query based on the
+matched C<dist_name> is performed.
+
+=back
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite::Populate>.
+
+=head1 COPYRIGHT
+
+This software is copyright 2006 by Randy Kobes
+E<lt>r.kobes@uwinnipeg.caE<gt>. Use and
+redistribution are under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/State.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/State.pm
new file mode 100755
index 00000000000..95ed50263eb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/State.pm
@@ -0,0 +1,410 @@
+package CPAN::SQLite::State;
+use strict;
+use warnings;
+no warnings qw(redefine);
+use CPAN::SQLite::DBI qw($dbh);
+use CPAN::SQLite::DBI::Index;
+use CPAN::SQLite::Util qw(has_hash_data print_debug);
+our $VERSION = '0.199';
+
+my %tbl2obj;
+$tbl2obj{$_} = __PACKAGE__ . '::' . $_ for (qw(dists mods auths));
+my %obj2tbl = reverse %tbl2obj;
+
+our $dbh = $CPAN::SQLite::DBI::dbh;
+
+sub new {
+ my ($class, %args) = @_;
+
+ if ($args{setup}) {
+ die "No state information available under setup";
+ }
+
+ my $index = $args{index};
+ my @tables = qw(dists mods auths);
+ foreach my $table (@tables) {
+ my $obj = $index->{$table};
+ die "Please supply a CPAN::SQLite::Index::$table object"
+ unless ($obj and ref($obj) eq "CPAN::SQLite::Index::$table");
+ }
+ my $cdbi = CPAN::SQLite::DBI::Index->new(%args);
+
+ my $self = {index => $index,
+ obj => {},
+ cdbi => $cdbi,
+ reindex => $args{reindex},
+ };
+ bless $self, $class;
+}
+
+sub state {
+ my $self = shift;
+ unless ($self->create_objs()) {
+ print_debug("Cannot create objects");
+ return;
+ }
+ unless ($self->state_info()) {
+ print_debug("Getting state information failed");
+ return;
+ };
+ return 1;
+}
+
+sub create_objs {
+ my $self = shift;
+ my @tables = qw(dists auths mods);
+
+ foreach my $table (@tables) {
+ my $obj;
+ my $pack = $tbl2obj{$table};
+ my $index = $self->{index}->{$table};
+ if ($index and ref($index) eq "CPAN::SQLite::Index::$table") {
+ my $info = $index->{info};
+ return unless has_hash_data($info);
+ $obj = $pack->new(info => $info,
+ cdbi => $self->{cdbi}->{objs}->{$table});
+ }
+ else {
+ $obj = $pack->new();
+ }
+ $self->{obj}->{$table} = $obj;
+ }
+
+ foreach my $table (@tables) {
+ my $obj = $self->{obj}->{$table};
+ foreach (@tables) {
+ next if ref($obj) eq $tbl2obj{$_};
+ $obj->{obj}->{$_} = $self->{obj}->{$_};
+ }
+ }
+ return 1;
+}
+
+sub state_info {
+ my $self = shift;
+ my @methods = qw(ids state);
+ my @tables = qw(dists auths mods);
+
+ for my $method (@methods) {
+ for my $table (@tables) {
+ my $obj = $self->{obj}->{$table};
+ unless ($obj->$method()) {
+ if (my $error = $obj->{error_msg}) {
+ print_debug("Fatal error from ", ref($obj), ": ", $error, $/);
+ return;
+ }
+ else {
+ my $info = $obj->{info_msg};
+ print_debug("Info from ", ref($obj), ": ", $info, $/);
+ }
+ }
+ }
+ }
+ return 1;
+}
+
+package CPAN::SQLite::State::auths;
+use base qw(CPAN::SQLite::State);
+use CPAN::SQLite::Util qw(has_hash_data print_debug);
+
+sub new {
+ my ($class, %args) = @_;
+ my $info = $args{info};
+ die "No author info available" unless has_hash_data($info);
+ my $cdbi = $args{cdbi};
+ die "No dbi object available"
+ unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::auths');
+ my $self = {
+ info => $info,
+ insert => {},
+ update => {},
+ delete => {},
+ ids => {},
+ obj => {},
+ cdbi => $cdbi,
+ error_msg => '',
+ info_msg => '',
+ };
+ bless $self, $class;
+}
+
+sub ids {
+ my $self = shift;
+ my $cdbi = $self->{cdbi};
+ $self->{ids} = $cdbi->fetch_ids() or do {
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub state {
+ my $self = shift;
+ my $auth_ids = $self->{ids};
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $dist_update = $dist_obj->{update};
+ my $dist_insert = $dist_obj->{insert};
+ my $dists = $dist_obj->{info};
+ my ($update, $insert);
+ if (has_hash_data($dist_insert)) {
+ foreach my $distname (keys %{$dist_insert}) {
+ my $cpanid = $dists->{$distname}->{cpanid};
+ if (my $auth_id = $auth_ids->{$cpanid}) {
+ $update->{$cpanid} = $auth_id;
+ }
+ else {
+ $insert->{$cpanid}++;
+ }
+ }
+ }
+ if (has_hash_data($dist_update)) {
+ foreach my $distname (keys %{$dist_update}) {
+ my $cpanid = $dists->{$distname}->{cpanid};
+ if (my $auth_id = $auth_ids->{$cpanid}) {
+ $update->{$cpanid} = $auth_id;
+ }
+ else {
+ $insert->{$cpanid}++;
+ }
+ }
+ }
+ $self->{update} = $update;
+ $self->{insert} = $insert;
+ return 1;
+}
+
+package CPAN::SQLite::State::dists;
+use base qw(CPAN::SQLite::State);
+use CPAN::SQLite::Util qw(vcmp has_hash_data print_debug);
+
+sub new {
+ my ($class, %args) = @_;
+ my $info = $args{info};
+ die "No dist info available" unless has_hash_data($info);
+ my $cdbi = $args{cdbi};
+ die "No dbi object available"
+ unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::dists');
+ my $self = {
+ info => $info,
+ insert => {},
+ update => {},
+ delete => {},
+ ids => {},
+ versions => {},
+ obj => {},
+ cdbi => $cdbi,
+ error_msg => '',
+ info_msg => '',
+ reindex => undef,
+ };
+ bless $self, $class;
+}
+
+sub ids {
+ my $self = shift;
+ my $cdbi = $self->{cdbi};
+ ($self->{ids}, $self->{versions}) = $cdbi->fetch_ids() or do {
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub state {
+ my $self = shift;
+ my $dist_versions = $self->{versions};
+ my $dists = $self->{info};
+ my $dist_ids = $self->{ids};
+ my ($insert, $update, $delete);
+
+ my $reindex = $self->{reindex};
+ if (defined $reindex) {
+ my @dists = ref($reindex) eq 'ARRAY' ? @$reindex : ($reindex);
+ foreach my $distname(@dists) {
+ my $id = $dist_ids->{$distname};
+ if (not defined $id) {
+ print_debug(qq{"$distname" does not have an id: reindexing ignored\n});
+ next;
+ }
+ $update->{$distname} = $id;
+ }
+ $self->{update} = $update;
+ return 1;
+ }
+
+ foreach my $distname (keys %$dists) {
+ if (not defined $dist_versions->{$distname}) {
+ $insert->{$distname}++;
+ }
+ elsif (vcmp($dists->{$distname}->{dist_vers},
+ $dist_versions->{$distname}) > 0) {
+ $update->{$distname} = $dist_ids->{$distname};
+ }
+ }
+ $self->{update} = $update;
+ $self->{insert} = $insert;
+ foreach my $distname(keys %$dist_versions) {
+ next if $dists->{$distname};
+ $delete->{$distname} = $dist_ids->{$distname};
+ print_debug("Will delete $distname\n");
+ }
+ $self->{delete} = $delete;
+ return 1;
+}
+
+package CPAN::SQLite::State::mods;
+use base qw(CPAN::SQLite::State);
+use CPAN::SQLite::Util qw(has_hash_data print_debug);
+
+sub new {
+ my ($class, %args) = @_;
+ my $info = $args{info};
+ die "No module info available" unless has_hash_data($info);
+ my $cdbi = $args{cdbi};
+ die "No dbi object available"
+ unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::mods');
+ my $self = {
+ info => $info,
+ insert => {},
+ update => {},
+ delete => {},
+ ids => {},
+ obj => {},
+ cdbi => $cdbi,
+ error_msg => '',
+ info_msg => '',
+ };
+ bless $self, $class;
+}
+
+sub ids {
+ my $self = shift;
+ my $cdbi = $self->{cdbi};
+ $self->{ids} = $cdbi->fetch_ids() or do {
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ return 1;
+}
+
+sub state {
+ my $self = shift;
+ my $mods = $self->{info};
+ my $mod_ids = $self->{ids};
+ return unless my $dist_obj = $self->{obj}->{dists};
+ my $dists = $dist_obj->{info};
+ my $dist_update = $dist_obj->{update};
+ my $dist_insert = $dist_obj->{insert};
+ my ($update, $insert, $delete);
+ my $cdbi = $self->{cdbi};
+ if (has_hash_data($dist_insert)) {
+ foreach my $distname (keys %{$dist_insert}) {
+ foreach my $module(keys %{$dists->{$distname}->{modules}}) {
+ $insert->{$module}++;
+ }
+ }
+ }
+ if (has_hash_data($dist_update)) {
+ foreach my $distname (keys %{$dist_update}) {
+ foreach my $module(keys %{$dists->{$distname}->{modules}}) {
+ my $mod_id = $mod_ids->{$module};
+ if ($mod_id) {
+ $update->{$module} = $mod_id;
+ }
+ else {
+ $insert->{$module}++;
+ }
+ }
+ }
+ }
+
+ if (has_hash_data($dist_update)) {
+ my $sql = q{SELECT mod_id,mod_name from mods,dists WHERE dists.dist_id = mods.dist_id and dists.dist_id = ?};
+ my $sth = $dbh->prepare($sql) or do {
+ $cdbi->db_error();
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ my $dist_ids = $dist_obj->{ids};
+ foreach my $distname (keys %{$dist_update}) {
+ my %mods = ();
+ %mods = map {$_ => 1} keys %{$dists->{$distname}->{modules}};
+ $sth->execute($dist_ids->{$distname}) or do {
+ $cdbi->db_error($sth);
+ $self->{error_msg} = $cdbi->{error_msg};
+ return;
+ };
+ while (my($mod_id, $mod_name) = $sth->fetchrow_array) {
+ next if $mods{$mod_name};
+ $delete->{$mod_name} = $mod_id;
+ }
+ }
+ $sth->finish;
+ undef $sth;
+ }
+
+ $self->{update} = $update;
+ $self->{insert} = $insert;
+ $self->{delete} = $delete;
+ return 1;
+}
+
+
+package CPAN::SQLite::State;
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::State - get state information on the database
+
+=head1 DESCRIPTION
+
+This module gets information on the current state of the
+database and compares it to that obtained from the CPAN
+index files from I<CPAN::SQLite::Info> and from the
+repositories from I<CPAN::SQLite::PPM>. For each of the
+four tables I<dists>, I<mods>, I<auths>, and I<ppms>,
+two methods are used to get this information:
+
+=over 3
+
+=item * C<ids>
+
+This method gets the ids of the relevant names, and
+versions, if applicable, in the table.
+
+=item * C<state>
+
+This method compares the information in the tables
+obtained from the C<ids> method to that from the
+CPAN indices and ppm repositories. One of three actions
+is then decided, which is subsequently acted upon in
+I<CPAN::SQLite::Populate>.
+
+=over 3
+
+=item * C<insert>
+
+If the information in the indices is not in the
+database, this information is marked for insertion.
+
+=item * C<update>
+
+If the information in the database is older than that
+form the indices (generally, this means an older version),
+the information is marked for updating.
+
+=item * C<delete>
+
+If the information in the database is no longer present
+in the indices, the information is marked for deletion.
+
+=back
+
+=back
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Util.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Util.pm
new file mode 100755
index 00000000000..7f3ffcf8117
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/SQLite/Util.pm
@@ -0,0 +1,367 @@
+package CPAN::SQLite::Util;
+use strict;
+use warnings;
+our $VERSION = '0.199';
+
+use base qw(Exporter);
+our (@EXPORT_OK, %chaps, %modes,
+ $table_id, $query_info, $mode_info, $full_id, $dslip);
+@EXPORT_OK = qw(%chaps $repositories %modes
+ vcmp $table_id $query_info $mode_info $full_id
+ has_hash_data has_array_data $dslip
+ expand_dslip download chap_desc print_debug);
+
+make_ids();
+
+$mode_info = {
+ module => {id => 'mod_id',
+ table => 'mods',
+ name => 'mod_name',
+ text => 'mod_abs',
+ },
+ dist => {id => 'dist_id',
+ table => 'dists',
+ name => 'dist_name',
+ text => 'dist_abs',
+ },
+ author => {id => 'auth_id',
+ table => 'auths',
+ name => 'cpanid',
+ text => 'fullname',
+ },
+ chapter => {id => 'chapterid',
+ table => 'chaps',
+ name => 'subchapter',
+ text => 'subchapter',
+ },
+ };
+
+%modes = map {$_ => 1} keys %$mode_info;
+
+$query_info = { module => {mode => 'module', type => 'name'},
+ mod_id => {mode => 'module', type => 'id'},
+ dist => {mode => 'dist', type => 'name'},
+ dist_id => {mode => 'dist', type => 'id'},
+ cpanid => {mode => 'author', type => 'name'},
+ author => {mode => 'author', type => 'name'},
+ auth_id => {mode => 'author', type => 'id'},
+ };
+
+%chaps = (
+ 2 => 'Perl Core Modules',
+ 3 => 'Development Support',
+ 4 => 'Operating System Interfaces',
+ 5 => 'Networking Devices IPC',
+ 6 => 'Data Type Utilities',
+ 7 => 'Database Interfaces',
+ 8 => 'User Interfaces',
+ 9 => 'Language Interfaces',
+ 10 => 'File Names Systems Locking',
+ 11 => 'String Lang Text Proc',
+ 12 => 'Opt Arg Param Proc',
+ 13 => 'Internationalization Locale',
+ 14 => 'Security and Encryption',
+ 15 => 'World Wide Web HTML HTTP CGI',
+ 16 => 'Server and Daemon Utilities',
+ 17 => 'Archiving and Compression',
+ 18 => 'Images Pixmaps Bitmaps',
+ 19 => 'Mail and Usenet News',
+ 20 => 'Control Flow Utilities',
+ 21 => 'File Handle Input Output',
+ 22 => 'Microsoft Windows Modules',
+ 23 => 'Miscellaneous Modules',
+ 24 => 'Commercial Software Interfaces',
+ 26 => 'Documentation',
+ 27 => 'Pragma',
+ 28 => 'Perl6',
+ 99 => 'Not In Modulelist',
+ );
+
+$dslip = {
+ d => {
+ M => q{Mature (no rigorous definition)},
+ R => q{Released},
+ S => q{Standard, supplied with Perl 5},
+ a => q{Alpha testing},
+ b => q{Beta testing},
+ c => q{Under construction but pre-alpha (not yet released)},
+ desc => q{Development Stage (Note: *NO IMPLIED TIMESCALES*)},
+ i => q{Idea, listed to gain consensus or as a placeholder},
+ },
+ s => {
+ a => q{Abandoned, the module has been abandoned by its author},
+ d => q{Developer},
+ desc => q{Support Level},
+ m => q{Mailing-list},
+ n => q{None known, try comp.lang.perl.modules},
+ u => q{Usenet newsgroup comp.lang.perl.modules},
+ },
+ l => {
+ '+' => q{C++ and perl, a C++ compiler will be needed},
+ c => q{C and perl, a C compiler will be needed},
+ desc => q{Language Used},
+ h => q{Hybrid, written in perl with optional C code, no compiler needed},
+ o => q{perl and another language other than C or C++},
+ p => q{Perl-only, no compiler needed, should be platform independent},
+ },
+ i => {
+ O => q{Object oriented using blessed references and/or inheritance},
+ desc => q{Interface Style},
+ f => q{plain Functions, no references used},
+ h => q{hybrid, object and function interfaces available},
+ n => q{no interface at all (huh?)},
+ r => q{some use of unblessed References or ties},
+ },
+ p => {
+ a => q{Artistic license alone},
+ b => q{BSD: The BSD License},
+ desc => q{Public License},
+ g => q{GPL: GNU General Public License},
+ l => q{LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")},
+ o => q{other (but distribution allowed without restrictions)},
+ p => q{Standard-Perl: user may choose between GPL and Artistic},
+ },
+};
+
+
+sub make_ids {
+ my @tables = qw(mods dists auths);
+ foreach my $table (@tables) {
+ (my $id = $table) =~ s!(\w+)s$!$1_id!;
+ $table_id->{$table} = $id;
+ $full_id->{$id} = $table . '.' . $id;
+ }
+# $full_id->{chapterid} = 'chaps.chapterid';
+}
+
+#my $num_re = qr{^0*\.\d+$};
+#sub vcmp {
+# my ($v1, $v2) = @_;
+# return unless (defined $v1 and defined $v2);
+# if ($v1 =~ /$num_re/ and $v2 =~ /$num_re/) {
+# return $v1 <=> $v2;
+# }
+# return Sort::Versions::versioncmp($v1, $v2);
+#}
+
+sub has_hash_data {
+ my $data = shift;
+ return unless (defined $data and ref($data) eq 'HASH');
+ return (scalar keys %$data > 0) ? 1 : 0;
+}
+
+sub has_array_data {
+ my $data = shift;
+ return unless (defined $data and ref($data) eq 'ARRAY');
+ return (scalar @$data > 0) ? 1 : 0;
+}
+
+sub expand_dslip {
+ my ($string) = @_;
+ my $entries = [];
+ my @info = split '', $string;
+ my @given = qw(d s l i p);
+ for (0 .. 4) {
+ my $entry;
+ my $given = $given[$_];
+ my $info = $info[$_];
+ $entry->{desc} = $dslip->{$given}->{desc};
+ $entry->{what} = (not $info or $info eq '?') ?
+ 'not specified' : $dslip->{$given}->{$info};
+ push @$entries, $entry;
+ }
+ return $entries;
+}
+
+sub download {
+ my ($cpanid, $dist_file) = @_;
+ return unless ($cpanid and $dist_file);
+ (my $fullid = $cpanid) =~ s!^(\w)(\w)(.*)!$1/$1$2/$1$2$3!;
+ my $download = $fullid . '/' . $dist_file;
+ return $download;
+}
+
+sub chap_desc {
+ my ($id) = @_;
+ return $chaps{$id};
+}
+
+sub print_debug {
+ return unless $ENV{CPAN_SQLITE_DEBUG};
+ print @_;
+}
+
+sub vcmp {
+ my ($v1, $v2) = @_;
+ return CPAN::SQLite::Version->vcmp($v1, $v2);
+}
+
+
+# This is borrowed essentially verbatim from CPAN::Version
+# It's included here so as to not demand a CPAN.pm upgrade
+
+package CPAN::SQLite::Version;
+
+use strict;
+our $VERSION = 0.1;
+no warnings;
+
+# CPAN::Version::vcmp courtesy Jost Krieger
+sub vcmp {
+ my ($self, $l, $r) = @_;
+
+ return 0 if $l eq $r; # short circuit for quicker success
+
+ for ($l, $r) {
+ next unless tr/.// > 1;
+ s/^v?/v/;
+ 1 while s/\.0+(\d)/.$1/;
+ }
+ if ($l =~ /^v/ <=> $r =~ /^v/) {
+ for ($l, $r) {
+ next if /^v/;
+ $_ = $self->float2vv($_);
+ }
+ }
+
+ return (
+ ($l ne "undef") <=> ($r ne "undef") ||
+ (
+ $] >= 5.006 &&
+ $l =~ /^v/ &&
+ $r =~ /^v/ &&
+ $self->vstring($l) cmp $self->vstring($r)
+ ) ||
+ $l <=> $r ||
+ $l cmp $r
+ );
+}
+
+sub vgt {
+ my ($self, $l, $r) = @_;
+ $self->vcmp($l, $r) > 0;
+}
+
+sub vlt {
+ my ($self, $l, $r) = @_;
+ 0 + ($self->vcmp($l, $r) < 0);
+}
+
+sub vstring {
+ my ($self, $n) = @_;
+ $n =~ s/^v//
+ or die "CPAN::Search::Lite::Version::vstring() called with invalid arg [$n]";
+ {
+ no warnings;
+ pack "U*", split /\./, $n;
+ }
+}
+
+# vv => visible vstring
+sub float2vv {
+ my ($self, $n) = @_;
+ my ($rev) = int($n);
+ $rev ||= 0;
+ my ($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
+ # architecture influence
+ $mantissa ||= 0;
+ $mantissa .= "0" while length($mantissa)%3;
+ my $ret = "v" . $rev;
+ while ($mantissa) {
+ $mantissa =~ s/(\d{1,3})// or
+ die "Panic: length>0 but not a digit? mantissa[$mantissa]";
+ $ret .= ".".int($1);
+ }
+ # warn "n[$n]ret[$ret]";
+ $ret;
+}
+
+sub readable {
+ my($self,$n) = @_;
+ $n =~ /^([\w\-\+\.]+)/;
+
+ return $1 if defined $1 && length($1)>0;
+ # if the first user reaches version v43, he will be treated as "+".
+ # We'll have to decide about a new rule here then, depending on what
+ # will be the prevailing versioning behavior then.
+
+ if ($] < 5.006) { # or whenever v-strings were introduced
+ # we get them wrong anyway, whatever we do, because 5.005 will
+ # have already interpreted 0.2.4 to be "0.24". So even if he
+ # indexer sends us something like "v0.2.4" we compare wrongly.
+
+ # And if they say v1.2, then the old perl takes it as "v12"
+
+ warn("Suspicious version string seen [$n]\n");
+ return $n;
+ }
+ my $better = sprintf "v%vd", $n;
+ return $better;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::SQLite::Util - export some common data structures used by CPAN::SQLite::*
+
+=head1 DESCRIPTION
+
+This module exports some common data structures used by other
+I<CPAN::Search::Lite::*> modules. At present these are
+
+=over 3
+
+=item * C<%chaps>
+
+This is hash whose keys are the CPAN chapter ids with associated
+values being the corresponding chapter descriptions.
+
+=item * C<$dslip>
+
+This contains a description of the meaning of the
+various C<dslip> codes.
+
+=item * C<$table_id>
+
+This is a hash reference whose keys are the tables used
+and whose values are the associated primary keys.
+
+=item * C<$full_id>
+
+This is a hash reference whose keys are the primary keys
+of the tables and whose values are the associated fully qualified
+primary keys (ie, with the table name prepended).
+
+=item * C<$mode_info>
+
+This is a hash reference whose keys are the allowed
+modes of I<CPAN::Search::Lite::Query> and whose associated values
+are hash references with keys C<id>, C<name>, and C<text> describing
+what columns to use for that key.
+
+=item * C<$query_info>
+
+This is a hash reference whose purpose is to provide
+shortcuts to making queries using I<CPAN::Search::Lite::Query>. The
+keys of this reference is the shortcut name, and the associated
+value is a hash reference specifying the required I<mode> and
+I<type> keys.
+
+=item * C<vcmp>
+
+This routine, used as
+
+ if (vcmp($v1, $v2) > 0) {
+ print "$v1 is higher than $v2\n";
+ }
+
+is used to compare two versions, and returns 1/0/-1 if
+the first argument is considered higher/equal/lower than
+the second. It uses C<Sort::Versions>.
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Shell.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Shell.pm
new file mode 100755
index 00000000000..8fb5628b112
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Shell.pm
@@ -0,0 +1,1974 @@
+package CPAN::Shell;
+use strict;
+
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+
+use vars qw(
+ $ADVANCED_QUERY
+ $AUTOLOAD
+ $COLOR_REGISTERED
+ $Help
+ $autoload_recursion
+ $reload
+ @ISA
+ @relo
+ $VERSION
+ );
+@relo = (
+ "CPAN.pm",
+ "CPAN/Author.pm",
+ "CPAN/CacheMgr.pm",
+ "CPAN/Complete.pm",
+ "CPAN/Debug.pm",
+ "CPAN/DeferredCode.pm",
+ "CPAN/Distribution.pm",
+ "CPAN/Distroprefs.pm",
+ "CPAN/Distrostatus.pm",
+ "CPAN/Exception/RecursiveDependency.pm",
+ "CPAN/Exception/yaml_not_installed.pm",
+ "CPAN/FirstTime.pm",
+ "CPAN/FTP.pm",
+ "CPAN/FTP/netrc.pm",
+ "CPAN/HandleConfig.pm",
+ "CPAN/Index.pm",
+ "CPAN/InfoObj.pm",
+ "CPAN/Kwalify.pm",
+ "CPAN/LWP/UserAgent.pm",
+ "CPAN/Module.pm",
+ "CPAN/Prompt.pm",
+ "CPAN/Queue.pm",
+ "CPAN/Reporter/Config.pm",
+ "CPAN/Reporter/History.pm",
+ "CPAN/Reporter/PrereqCheck.pm",
+ "CPAN/Reporter.pm",
+ "CPAN/Shell.pm",
+ "CPAN/SQLite.pm",
+ "CPAN/Tarzip.pm",
+ "CPAN/Version.pm",
+ );
+$VERSION = "5.5";
+# record the initial timestamp for reload.
+$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
+@CPAN::Shell::ISA = qw(CPAN::Debug);
+use Cwd qw(chdir);
+use Carp ();
+$COLOR_REGISTERED ||= 0;
+$Help = {
+ '?' => \"help",
+ '!' => "eval the rest of the line as perl",
+ a => "whois author",
+ autobundle => "write inventory into a bundle file",
+ b => "info about bundle",
+ bye => \"quit",
+ clean => "clean up a distribution's build directory",
+ # cvs_import
+ d => "info about a distribution",
+ # dump
+ exit => \"quit",
+ failed => "list all failed actions within current session",
+ fforce => "redo a command from scratch",
+ force => "redo a command",
+ get => "download a distribution",
+ h => \"help",
+ help => "overview over commands; 'help ...' explains specific commands",
+ hosts => "statistics about recently used hosts",
+ i => "info about authors/bundles/distributions/modules",
+ install => "install a distribution",
+ install_tested => "install all distributions tested OK",
+ is_tested => "list all distributions tested OK",
+ look => "open a subshell in a distribution's directory",
+ ls => "list distributions matching a fileglob",
+ m => "info about a module",
+ make => "make/build a distribution",
+ mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
+ notest => "run a (usually install) command but leave out the test phase",
+ o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
+ perldoc => "try to get a manpage for a module",
+ q => \"quit",
+ quit => "leave the cpan shell",
+ r => "review upgradable modules",
+ readme => "display the README of a distro with a pager",
+ recent => "show recent uploads to the CPAN",
+ # recompile
+ reload => "'reload cpan' or 'reload index'",
+ report => "test a distribution and send a test report to cpantesters",
+ reports => "info about reported tests from cpantesters",
+ # scripts
+ # smoke
+ test => "test a distribution",
+ u => "display uninstalled modules",
+ upgrade => "combine 'r' command with immediate installation",
+ };
+{
+ $autoload_recursion ||= 0;
+
+ #-> sub CPAN::Shell::AUTOLOAD ;
+ sub AUTOLOAD { ## no critic
+ $autoload_recursion++;
+ my($l) = $AUTOLOAD;
+ my $class = shift(@_);
+ # warn "autoload[$l] class[$class]";
+ $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;
+ }
+ if ($l =~ /^w/) {
+ # XXX needs to be reconsidered
+ if ($CPAN::META->has_inst('CPAN::WAIT')) {
+ CPAN::WAIT->$l(@_);
+ } else {
+ $CPAN::Frontend->mywarn(qq{
+Commands starting with "w" require CPAN::WAIT to be installed.
+Please consider installing CPAN::WAIT to use the fulltext index.
+For this you just need to type
+ install CPAN::WAIT
+});
+ }
+ } else {
+ $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
+ qq{Type ? for help.
+});
+ }
+ $autoload_recursion--;
+ }
+}
+
+
+#-> sub CPAN::Shell::h ;
+sub h {
+ my($class,$about) = @_;
+ if (defined $about) {
+ my $help;
+ if (exists $Help->{$about}) {
+ if (ref $Help->{$about}) { # aliases
+ $about = ${$Help->{$about}};
+ }
+ $help = $Help->{$about};
+ } else {
+ $help = "No help available";
+ }
+ $CPAN::Frontend->myprint("$about\: $help\n");
+ } else {
+ my $filler = " " x (80 - 28 - length($CPAN::VERSION));
+ $CPAN::Frontend->myprint(qq{
+Display Information $filler (ver $CPAN::VERSION)
+ command argument description
+ a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
+ i WORD or /REGEXP/ about any of the above
+ ls AUTHOR or GLOB about files in the author's directory
+ (with WORD being a module, bundle or author name or a distribution
+ name of the form AUTHOR/DISTRIBUTION)
+
+Download, Test, Make, Install...
+ get download clean make clean
+ make make (implies get) look open subshell in dist directory
+ test make test (implies make) readme display these README files
+ install make install (implies test) perldoc display POD documentation
+
+Upgrade
+ r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
+ upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
+
+Pragmas
+ force CMD try hard to do command fforce CMD try harder
+ notest CMD skip testing
+
+Other
+ h,? display this menu ! perl-code eval a perl command
+ o conf [opt] set and query options q quit the cpan shell
+ reload cpan load CPAN.pm again reload index load newer indices
+ autobundle Snapshot recent latest CPAN uploads});
+}
+}
+
+*help = \&h;
+
+#-> sub CPAN::Shell::a ;
+sub a {
+ my($self,@arg) = @_;
+ # authors are always UPPERCASE
+ for (@arg) {
+ $_ = uc $_ unless /=/;
+ }
+ $CPAN::Frontend->myprint($self->format_result('Author',@arg));
+}
+
+#-> sub CPAN::Shell::globls ;
+sub globls {
+ my($self,$s,$pragmas) = @_;
+ # ls is really very different, but we had it once as an ordinary
+ # command in the Shell (upto rev. 321) and we could not handle
+ # force well then
+ my(@accept,@preexpand);
+ if ($s =~ /[\*\?\/]/) {
+ if ($CPAN::META->has_inst("Text::Glob")) {
+ if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
+ my $rau = Text::Glob::glob_to_regex(uc $au);
+ CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
+ if $CPAN::DEBUG;
+ push @preexpand, map { $_->id . "/" . $pathglob }
+ CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
+ } else {
+ my $rau = Text::Glob::glob_to_regex(uc $s);
+ push @preexpand, map { $_->id }
+ CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ "/$rau/");
+ }
+ } else {
+ $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
+ }
+ } else {
+ push @preexpand, uc $s;
+ }
+ for (@preexpand) {
+ unless (/^[A-Z0-9\-]+(\/|$)/i) {
+ $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
+ next;
+ }
+ push @accept, $_;
+ }
+ my $silent = @accept>1;
+ my $last_alpha = "";
+ my @results;
+ for my $a (@accept) {
+ my($author,$pathglob);
+ if ($a =~ m|(.*?)/(.*)|) {
+ my $a2 = $1;
+ $pathglob = $2;
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a2)
+ or $CPAN::Frontend->mydie("No author found for $a2\n");
+ } else {
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a)
+ or $CPAN::Frontend->mydie("No author found for $a\n");
+ }
+ if ($silent) {
+ my $alpha = substr $author->id, 0, 1;
+ my $ad;
+ if ($alpha eq $last_alpha) {
+ $ad = "";
+ } else {
+ $ad = "[$alpha]";
+ $last_alpha = $alpha;
+ }
+ $CPAN::Frontend->myprint($ad);
+ }
+ for my $pragma (@$pragmas) {
+ if ($author->can($pragma)) {
+ $author->$pragma();
+ }
+ }
+ CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG;
+ push @results, $author->ls($pathglob,$silent); # silent if
+ # more than one
+ # author
+ for my $pragma (@$pragmas) {
+ my $unpragma = "un$pragma";
+ if ($author->can($unpragma)) {
+ $author->$unpragma();
+ }
+ }
+ }
+ @results;
+}
+
+#-> sub CPAN::Shell::local_bundles ;
+sub local_bundles {
+ my($self,@which) = @_;
+ my($incdir,$bdir,$dh);
+ foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
+ my @bbase = "Bundle";
+ while (my $bbase = shift @bbase) {
+ $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
+ CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
+ if ($dh = DirHandle->new($bdir)) { # may fail
+ my($entry);
+ for $entry ($dh->read) {
+ next if $entry =~ /^\./;
+ next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
+ if (-d File::Spec->catdir($bdir,$entry)) {
+ push @bbase, "$bbase\::$entry";
+ } else {
+ next unless $entry =~ s/\.pm(?!\n)\Z//;
+ $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
+ }
+ }
+ }
+ }
+ }
+}
+
+#-> sub CPAN::Shell::b ;
+sub b {
+ my($self,@which) = @_;
+ CPAN->debug("which[@which]") if $CPAN::DEBUG;
+ $self->local_bundles;
+ $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
+}
+
+#-> sub CPAN::Shell::d ;
+sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
+
+#-> sub CPAN::Shell::m ;
+sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
+ my $self = shift;
+ my @m = @_;
+ for (@m) {
+ if (m|(?:\w+/)*\w+\.pm$|) { # same regexp in expandany
+ s/.pm$//;
+ s|/|::|g;
+ }
+ }
+ $CPAN::Frontend->myprint($self->format_result('Module',@m));
+}
+
+#-> sub CPAN::Shell::i ;
+sub i {
+ my($self) = shift;
+ my(@args) = @_;
+ @args = '/./' unless @args;
+ my(@result);
+ for my $type (qw/Bundle Distribution Module/) {
+ push @result, $self->expand($type,@args);
+ }
+ # Authors are always uppercase.
+ push @result, $self->expand("Author", map { uc $_ } @args);
+
+ my $result = @result == 1 ?
+ $result[0]->as_string :
+ @result == 0 ?
+ "No objects found of any type for argument @args\n" :
+ join("",
+ (map {$_->as_glimpse} @result),
+ scalar @result, " items found\n",
+ );
+ $CPAN::Frontend->myprint($result);
+}
+
+#-> sub CPAN::Shell::o ;
+
+# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
+# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
+# probably have been called 'set' and 'o debug' maybe 'set debug' or
+# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
+sub o {
+ my($self,$o_type,@o_what) = @_;
+ $o_type ||= "";
+ CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
+ if ($o_type eq 'conf') {
+ my($cfilter);
+ ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
+ if (!@o_what or $cfilter) { # print all things, "o conf"
+ $cfilter ||= "";
+ my $qrfilter = eval 'qr/$cfilter/';
+ my($k,$v);
+ $CPAN::Frontend->myprint("\$CPAN::Config options from ");
+ my @from;
+ if (exists $INC{'CPAN/Config.pm'}) {
+ push @from, $INC{'CPAN/Config.pm'};
+ }
+ if (exists $INC{'CPAN/MyConfig.pm'}) {
+ push @from, $INC{'CPAN/MyConfig.pm'};
+ }
+ $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
+ $CPAN::Frontend->myprint(":\n");
+ for $k (sort keys %CPAN::HandleConfig::can) {
+ next unless $k =~ /$qrfilter/;
+ $v = $CPAN::HandleConfig::can{$k};
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
+ }
+ $CPAN::Frontend->myprint("\n");
+ for $k (sort keys %CPAN::HandleConfig::keys) {
+ next unless $k =~ /$qrfilter/;
+ CPAN::HandleConfig->prettyprint($k);
+ }
+ $CPAN::Frontend->myprint("\n");
+ } else {
+ if (CPAN::HandleConfig->edit(@o_what)) {
+ } else {
+ $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
+ qq{items\n\n});
+ }
+ }
+ } elsif ($o_type eq 'debug') {
+ my(%valid);
+ @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
+ if (@o_what) {
+ while (@o_what) {
+ my($what) = shift @o_what;
+ if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
+ $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
+ next;
+ }
+ if ( exists $CPAN::DEBUG{$what} ) {
+ $CPAN::DEBUG |= $CPAN::DEBUG{$what};
+ } elsif ($what =~ /^\d/) {
+ $CPAN::DEBUG = $what;
+ } elsif (lc $what eq 'all') {
+ my($max) = 0;
+ for (values %CPAN::DEBUG) {
+ $max += $_;
+ }
+ $CPAN::DEBUG = $max;
+ } else {
+ my($known) = 0;
+ for (keys %CPAN::DEBUG) {
+ next unless lc($_) eq lc($what);
+ $CPAN::DEBUG |= $CPAN::DEBUG{$_};
+ $known = 1;
+ }
+ $CPAN::Frontend->myprint("unknown argument [$what]\n")
+ unless $known;
+ }
+ }
+ } else {
+ my $raw = "Valid options for debug are ".
+ join(", ",sort(keys %CPAN::DEBUG), 'all').
+ qq{ or a number. Completion works on the options. }.
+ qq{Case is ignored.};
+ require Text::Wrap;
+ $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
+ $CPAN::Frontend->myprint("\n\n");
+ }
+ if ($CPAN::DEBUG) {
+ $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
+ my($k,$v);
+ for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
+ $v = $CPAN::DEBUG{$k};
+ $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
+ if $v & $CPAN::DEBUG;
+ }
+ } else {
+ $CPAN::Frontend->myprint("Debugging turned off completely.\n");
+ }
+ } else {
+ $CPAN::Frontend->myprint(qq{
+Known options:
+ conf set or get configuration variables
+ debug set or get debugging options
+});
+ }
+}
+
+# CPAN::Shell::paintdots_onreload
+sub paintdots_onreload {
+ my($ref) = shift;
+ sub {
+ if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
+ my($subr) = $1;
+ ++$$ref;
+ local($|) = 1;
+ # $CPAN::Frontend->myprint(".($subr)");
+ $CPAN::Frontend->myprint(".");
+ if ($subr =~ /\bshell\b/i) {
+ # warn "debug[$_[0]]";
+
+ # It would be nice if we could detect that a
+ # subroutine has actually changed, but for now we
+ # practically always set the GOTOSHELL global
+
+ $CPAN::GOTOSHELL=1;
+ }
+ return;
+ }
+ warn @_;
+ };
+}
+
+#-> sub CPAN::Shell::hosts ;
+sub hosts {
+ my($self) = @_;
+ my $fullstats = CPAN::FTP->_ftp_statistics();
+ my $history = $fullstats->{history} || [];
+ my %S; # statistics
+ while (my $last = pop @$history) {
+ my $attempts = $last->{attempts} or next;
+ my $start;
+ if (@$attempts) {
+ $start = $attempts->[-1]{start};
+ if ($#$attempts > 0) {
+ for my $i (0..$#$attempts-1) {
+ my $url = $attempts->[$i]{url} or next;
+ $S{no}{$url}++;
+ }
+ }
+ } else {
+ $start = $last->{start};
+ }
+ next unless $last->{thesiteurl}; # C-C? bad filenames?
+ $S{start} = $start;
+ $S{end} ||= $last->{end};
+ my $dltime = $last->{end} - $start;
+ my $dlsize = $last->{filesize} || 0;
+ my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
+ my $s = $S{ok}{$url} ||= {};
+ $s->{n}++;
+ $s->{dlsize} ||= 0;
+ $s->{dlsize} += $dlsize/1024;
+ $s->{dltime} ||= 0;
+ $s->{dltime} += $dltime;
+ }
+ my $res;
+ for my $url (keys %{$S{ok}}) {
+ next if $S{ok}{$url}{dltime} == 0; # div by zero
+ push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
+ $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
+ $url,
+ ];
+ }
+ for my $url (keys %{$S{no}}) {
+ push @{$res->{no}}, [$S{no}{$url},
+ $url,
+ ];
+ }
+ my $R = ""; # report
+ if ($S{start} && $S{end}) {
+ $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
+ $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
+ }
+ if ($res->{ok} && @{$res->{ok}}) {
+ $R .= sprintf "\nSuccessful downloads:
+ N kB secs kB/s url\n";
+ my $i = 20;
+ for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
+ $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
+ last if --$i<=0;
+ }
+ }
+ if ($res->{no} && @{$res->{no}}) {
+ $R .= sprintf "\nUnsuccessful downloads:\n";
+ my $i = 20;
+ for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
+ $R .= sprintf "%4d %s\n", @$_;
+ last if --$i<=0;
+ }
+ }
+ $CPAN::Frontend->myprint($R);
+}
+
+# here is where 'reload cpan' is done
+#-> sub CPAN::Shell::reload ;
+sub reload {
+ my($self,$command,@arg) = @_;
+ $command ||= "";
+ $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
+ if ($command =~ /^cpan$/i) {
+ my $redef = 0;
+ chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
+ my $failed;
+ MFILE: for my $f (@relo) {
+ next unless exists $INC{$f};
+ my $p = $f;
+ $p =~ s/\.pm$//;
+ $p =~ s|/|::|g;
+ $CPAN::Frontend->myprint("($p");
+ local($SIG{__WARN__}) = paintdots_onreload(\$redef);
+ $self->_reload_this($f) or $failed++;
+ my $v = eval "$p\::->VERSION";
+ $CPAN::Frontend->myprint("v$v)");
+ }
+ $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ if ($failed) {
+ my $errors = $failed == 1 ? "error" : "errors";
+ $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
+ "this session.\n");
+ }
+ } elsif ($command =~ /^index$/i) {
+ CPAN::Index->force_reload;
+ } else {
+ $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
+index re-reads the index files\n});
+ }
+}
+
+# reload means only load again what we have loaded before
+#-> sub CPAN::Shell::_reload_this ;
+sub _reload_this {
+ my($self,$f,$args) = @_;
+ CPAN->debug("f[$f]") if $CPAN::DEBUG;
+ return 1 unless $INC{$f}; # we never loaded this, so we do not
+ # reload but say OK
+ my $pwd = CPAN::anycwd();
+ CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
+ my($file);
+ for my $inc (@INC) {
+ $file = File::Spec->catfile($inc,split /\//, $f);
+ last if -f $file;
+ $file = "";
+ }
+ CPAN->debug("file[$file]") if $CPAN::DEBUG;
+ my @inc = @INC;
+ unless ($file && -f $file) {
+ # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
+ $file = $INC{$f};
+ unless (CPAN->has_inst("File::Basename")) {
+ @inc = File::Basename::dirname($file);
+ } else {
+ # do we ever need this?
+ @inc = substr($file,0,-length($f)-1); # bring in back to me!
+ }
+ }
+ CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
+ unless (-f $file) {
+ $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
+ return;
+ }
+ my $mtime = (stat $file)[9];
+ $reload->{$f} ||= -1;
+ my $must_reload = $mtime != $reload->{$f};
+ $args ||= {};
+ $must_reload ||= $args->{reloforce}; # o conf defaults needs this
+ if ($must_reload) {
+ my $fh = FileHandle->new($file) or
+ $CPAN::Frontend->mydie("Could not open $file: $!");
+ local($/);
+ local $^W = 1;
+ my $content = <$fh>;
+ CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
+ if $CPAN::DEBUG;
+ delete $INC{$f};
+ local @INC = @inc;
+ eval "require '$f'";
+ if ($@) {
+ warn $@;
+ return;
+ }
+ $reload->{$f} = $mtime;
+ } else {
+ $CPAN::Frontend->myprint("__unchanged__");
+ }
+ return 1;
+}
+
+#-> sub CPAN::Shell::mkmyconfig ;
+sub mkmyconfig {
+ my($self, $cpanpm, %args) = @_;
+ require CPAN::FirstTime;
+ my $home = CPAN::HandleConfig::home();
+ $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
+ File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
+ File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
+ CPAN::HandleConfig::require_myconfig_or_config();
+ $CPAN::Config ||= {};
+ $CPAN::Config = {
+ %$CPAN::Config,
+ build_dir => undef,
+ cpan_home => undef,
+ keep_source_where => undef,
+ histfile => undef,
+ };
+ CPAN::FirstTime::init($cpanpm, %args);
+}
+
+#-> sub CPAN::Shell::_binary_extensions ;
+sub _binary_extensions {
+ my($self) = shift @_;
+ my(@result,$module,%seen,%need,$headerdone);
+ for $module ($self->expand('Module','/./')) {
+ my $file = $module->cpan_file;
+ next if $file eq "N/A";
+ next if $file =~ /^Contact Author/;
+ my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
+ next if $dist->isa_perl;
+ next unless $module->xs_file;
+ local($|) = 1;
+ $CPAN::Frontend->myprint(".");
+ push @result, $module;
+ }
+# print join " | ", @result;
+ $CPAN::Frontend->myprint("\n");
+ return @result;
+}
+
+#-> sub CPAN::Shell::recompile ;
+sub recompile {
+ my($self) = shift @_;
+ my($module,@module,$cpan_file,%dist);
+ @module = $self->_binary_extensions();
+ for $module (@module) { # we force now and compile later, so we
+ # don't do it twice
+ $cpan_file = $module->cpan_file;
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->force;
+ $dist{$cpan_file}++;
+ }
+ for $cpan_file (sort keys %dist) {
+ $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->install;
+ $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
+ # stop a package from recompiling,
+ # e.g. IO-1.12 when we have perl5.003_10
+ }
+}
+
+#-> sub CPAN::Shell::scripts ;
+sub scripts {
+ my($self, $arg) = @_;
+ $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
+
+ for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
+ unless ($CPAN::META->has_inst($req)) {
+ $CPAN::Frontend->mywarn(" $req not available\n");
+ }
+ }
+ my $p = HTML::LinkExtor->new();
+ my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
+ unless (-f $indexfile) {
+ $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
+ }
+ $p->parse_file($indexfile);
+ my @hrefs;
+ my $qrarg;
+ if ($arg =~ s|^/(.+)/$|$1|) {
+ $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
+ }
+ for my $l ($p->links) {
+ my $tag = shift @$l;
+ next unless $tag eq "a";
+ my %att = @$l;
+ my $href = $att{href};
+ next unless $href =~ s|^\.\./authors/id/./../||;
+ if ($arg) {
+ if ($qrarg) {
+ if ($href =~ $qrarg) {
+ push @hrefs, $href;
+ }
+ } else {
+ if ($href =~ /\Q$arg\E/) {
+ push @hrefs, $href;
+ }
+ }
+ } else {
+ push @hrefs, $href;
+ }
+ }
+ # now filter for the latest version if there is more than one of a name
+ my %stems;
+ for (sort @hrefs) {
+ my $href = $_;
+ s/-v?\d.*//;
+ my $stem = $_;
+ $stems{$stem} ||= [];
+ push @{$stems{$stem}}, $href;
+ }
+ for (sort keys %stems) {
+ my $highest;
+ if (@{$stems{$_}} > 1) {
+ $highest = List::Util::reduce {
+ Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
+ } @{$stems{$_}};
+ } else {
+ $highest = $stems{$_}[0];
+ }
+ $CPAN::Frontend->myprint("$highest\n");
+ }
+}
+
+#-> sub CPAN::Shell::report ;
+sub report {
+ my($self,@args) = @_;
+ unless ($CPAN::META->has_inst("CPAN::Reporter")) {
+ $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
+ }
+ local $CPAN::Config->{test_report} = 1;
+ $self->force("test",@args); # force is there so that the test be
+ # re-run (as documented)
+}
+
+# compare with is_tested
+#-> sub CPAN::Shell::install_tested
+sub install_tested {
+ my($self,@some) = @_;
+ $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
+ return if @some;
+ CPAN::Index->reload;
+
+ for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
+ my $yaml = "$b.yml";
+ unless (-f $yaml) {
+ $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
+ next;
+ }
+ my $yaml_content = CPAN->_yaml_loadfile($yaml);
+ my $id = $yaml_content->[0]{distribution}{ID};
+ unless ($id) {
+ $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
+ next;
+ }
+ my $do = CPAN::Shell->expandany($id);
+ unless ($do) {
+ $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
+ next;
+ }
+ unless ($do->{build_dir}) {
+ $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
+ next;
+ }
+ unless ($do->{build_dir} eq $b) {
+ $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
+ next;
+ }
+ push @some, $do;
+ }
+
+ $CPAN::Frontend->mywarn("No tested distributions found.\n"),
+ return unless @some;
+
+ @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
+ $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
+ return unless @some;
+
+ # @some = grep { not $_->uptodate } @some;
+ # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
+ # return unless @some;
+
+ CPAN->debug("some[@some]");
+ for my $d (@some) {
+ my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
+ $CPAN::Frontend->myprint("install_tested: Running for $id\n");
+ $CPAN::Frontend->mysleep(1);
+ $self->install($d);
+ }
+}
+
+#-> sub CPAN::Shell::upgrade ;
+sub upgrade {
+ my($self,@args) = @_;
+ $self->install($self->r(@args));
+}
+
+#-> sub CPAN::Shell::_u_r_common ;
+sub _u_r_common {
+ my($self) = shift @_;
+ my($what) = shift @_;
+ CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
+ Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
+ $what && $what =~ /^[aru]$/;
+ my(@args) = @_;
+ @args = '/./' unless @args;
+ my(@result,$module,%seen,%need,$headerdone,
+ $version_undefs,$version_zeroes,
+ @version_undefs,@version_zeroes);
+ $version_undefs = $version_zeroes = 0;
+ my $sprintf = "%s%-25s%s %9s %9s %s\n";
+ my @expand = $self->expand('Module',@args);
+ if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
+ # for metadata cache
+ my $expand = scalar @expand;
+ $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
+ }
+ my @sexpand;
+ if ($] < 5.008) {
+ # hard to believe that the more complex sorting can lead to
+ # stack curruptions on older perl
+ @sexpand = sort {$a->id cmp $b->id} @expand;
+ } else {
+ @sexpand = map {
+ $_->[1]
+ } sort {
+ $b->[0] <=> $a->[0]
+ ||
+ $a->[1]{ID} cmp $b->[1]{ID},
+ } map {
+ [$_->_is_representative_module,
+ $_
+ ]
+ } @expand;
+ }
+ if ($CPAN::DEBUG) {
+ $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
+ sleep 1;
+ }
+ MODULE: for $module (@sexpand) {
+ my $file = $module->cpan_file;
+ next MODULE unless defined $file; # ??
+ $file =~ s!^./../!!;
+ my($latest) = $module->cpan_version;
+ my($inst_file) = $module->inst_file;
+ CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
+ my($have);
+ return if $CPAN::Signal;
+ my($next_MODULE);
+ eval { # version.pm involved!
+ if ($inst_file) {
+ if ($what eq "a") {
+ $have = $module->inst_version;
+ } elsif ($what eq "r") {
+ $have = $module->inst_version;
+ local($^W) = 0;
+ if ($have eq "undef") {
+ $version_undefs++;
+ push @version_undefs, $module->as_glimpse;
+ } elsif (CPAN::Version->vcmp($have,0)==0) {
+ $version_zeroes++;
+ push @version_zeroes, $module->as_glimpse;
+ }
+ ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
+ # to be pedantic we should probably say:
+ # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
+ # to catch the case where CPAN has a version 0 and we have a version undef
+ } elsif ($what eq "u") {
+ ++$next_MODULE;
+ }
+ } else {
+ if ($what eq "a") {
+ ++$next_MODULE;
+ } elsif ($what eq "r") {
+ ++$next_MODULE;
+ } elsif ($what eq "u") {
+ $have = "-";
+ }
+ }
+ };
+ next MODULE if $next_MODULE;
+ if ($@) {
+ $CPAN::Frontend->mywarn
+ (sprintf("Error while comparing cpan/installed versions of '%s':
+INST_FILE: %s
+INST_VERSION: %s %s
+CPAN_VERSION: %s %s
+",
+ $module->id,
+ $inst_file || "",
+ (defined $have ? $have : "[UNDEFINED]"),
+ (ref $have ? ref $have : ""),
+ $latest,
+ (ref $latest ? ref $latest : ""),
+ ));
+ next MODULE;
+ }
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $seen{$file} ||= 0;
+ if ($what eq "a") {
+ push @result, sprintf "%s %s\n", $module->id, $have;
+ } elsif ($what eq "r") {
+ push @result, $module->id;
+ next MODULE if $seen{$file}++;
+ } elsif ($what eq "u") {
+ push @result, $module->id;
+ next MODULE if $seen{$file}++;
+ next MODULE if $file =~ /^Contact/;
+ }
+ unless ($headerdone++) {
+ $CPAN::Frontend->myprint("\n");
+ $CPAN::Frontend->myprint(sprintf(
+ $sprintf,
+ "",
+ "Package namespace",
+ "",
+ "installed",
+ "latest",
+ "in CPAN file"
+ ));
+ }
+ my $color_on = "";
+ my $color_off = "";
+ if (
+ $COLOR_REGISTERED
+ &&
+ $CPAN::META->has_inst("Term::ANSIColor")
+ &&
+ $module->description
+ ) {
+ $color_on = Term::ANSIColor::color("green");
+ $color_off = Term::ANSIColor::color("reset");
+ }
+ $CPAN::Frontend->myprint(sprintf $sprintf,
+ $color_on,
+ $module->id,
+ $color_off,
+ $have,
+ $latest,
+ $file);
+ $need{$module->id}++;
+ }
+ unless (%need) {
+ if ($what eq "u") {
+ $CPAN::Frontend->myprint("No modules found for @args\n");
+ } elsif ($what eq "r") {
+ $CPAN::Frontend->myprint("All modules are up to date for @args\n");
+ }
+ }
+ if ($what eq "r") {
+ if ($version_zeroes) {
+ my $s_has = $version_zeroes > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
+ qq{a version number of 0\n});
+ if ($CPAN::Config->{show_zero_versions}) {
+ local $" = "\t";
+ $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
+ qq{to hide them)\n});
+ } else {
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
+ qq{to show them)\n});
+ }
+ }
+ if ($version_undefs) {
+ my $s_has = $version_undefs > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
+ qq{parsable version number\n});
+ if ($CPAN::Config->{show_unparsable_versions}) {
+ local $" = "\t";
+ $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
+ qq{to hide them)\n});
+ } else {
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
+ qq{to show them)\n});
+ }
+ }
+ }
+ @result;
+}
+
+#-> sub CPAN::Shell::r ;
+sub r {
+ shift->_u_r_common("r",@_);
+}
+
+#-> sub CPAN::Shell::u ;
+sub u {
+ shift->_u_r_common("u",@_);
+}
+
+#-> sub CPAN::Shell::failed ;
+sub failed {
+ my($self,$only_id,$silent) = @_;
+ my @failed;
+ DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
+ my $failed = "";
+ NAY: for my $nosayer ( # order matters!
+ "unwrapped",
+ "writemakefile",
+ "signature_verify",
+ "make",
+ "make_test",
+ "install",
+ "make_clean",
+ ) {
+ next unless exists $d->{$nosayer};
+ next unless defined $d->{$nosayer};
+ next unless (
+ UNIVERSAL::can($d->{$nosayer},"failed") ?
+ $d->{$nosayer}->failed :
+ $d->{$nosayer} =~ /^NO/
+ );
+ next NAY if $only_id && $only_id != (
+ UNIVERSAL::can($d->{$nosayer},"commandid")
+ ?
+ $d->{$nosayer}->commandid
+ :
+ $CPAN::CurrentCommandId
+ );
+ $failed = $nosayer;
+ last;
+ }
+ next DIST unless $failed;
+ my $id = $d->id;
+ $id =~ s|^./../||;
+ #$print .= sprintf(
+ # " %-45s: %s %s\n",
+ push @failed,
+ (
+ UNIVERSAL::can($d->{$failed},"failed") ?
+ [
+ $d->{$failed}->commandid,
+ $id,
+ $failed,
+ $d->{$failed}->text,
+ $d->{$failed}{TIME}||0,
+ ] :
+ [
+ 1,
+ $id,
+ $failed,
+ $d->{$failed},
+ 0,
+ ]
+ );
+ }
+ my $scope;
+ if ($only_id) {
+ $scope = "this command";
+ } elsif ($CPAN::Index::HAVE_REANIMATED) {
+ $scope = "this or a previous session";
+ # it might be nice to have a section for previous session and
+ # a second for this
+ } else {
+ $scope = "this session";
+ }
+ if (@failed) {
+ my $print;
+ my $debug = 0;
+ if ($debug) {
+ $print = join "",
+ map { sprintf "%5d %-45s: %s %s\n", @$_ }
+ sort { $a->[0] <=> $b->[0] } @failed;
+ } else {
+ $print = join "",
+ map { sprintf " %-45s: %s %s\n", @$_[1..3] }
+ sort {
+ $a->[0] <=> $b->[0]
+ ||
+ $a->[4] <=> $b->[4]
+ } @failed;
+ }
+ $CPAN::Frontend->myprint("Failed during $scope:\n$print");
+ } elsif (!$only_id || !$silent) {
+ $CPAN::Frontend->myprint("Nothing failed in $scope\n");
+ }
+}
+
+# XXX intentionally undocumented because completely bogus, unportable,
+# useless, etc.
+
+#-> sub CPAN::Shell::status ;
+sub status {
+ my($self) = @_;
+ require Devel::Size;
+ my $ps = FileHandle->new;
+ open $ps, "/proc/$$/status";
+ my $vm = 0;
+ while (<$ps>) {
+ next unless /VmSize:\s+(\d+)/;
+ $vm = $1;
+ last;
+ }
+ $CPAN::Frontend->mywarn(sprintf(
+ "%-27s %6d\n%-27s %6d\n",
+ "vm",
+ $vm,
+ "CPAN::META",
+ Devel::Size::total_size($CPAN::META)/1024,
+ ));
+ for my $k (sort keys %$CPAN::META) {
+ next unless substr($k,0,4) eq "read";
+ warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
+ for my $k2 (sort keys %{$CPAN::META->{$k}}) {
+ warn sprintf " %-25s %6d (keys: %6d)\n",
+ $k2,
+ Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
+ scalar keys %{$CPAN::META->{$k}{$k2}};
+ }
+ }
+}
+
+# compare with install_tested
+#-> sub CPAN::Shell::is_tested
+sub is_tested {
+ my($self) = @_;
+ CPAN::Index->reload;
+ for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
+ my $time;
+ if ($CPAN::META->{is_tested}{$b}) {
+ $time = scalar(localtime $CPAN::META->{is_tested}{$b});
+ } else {
+ $time = scalar localtime;
+ $time =~ s/\S/?/g;
+ }
+ $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
+ }
+}
+
+#-> sub CPAN::Shell::autobundle ;
+sub autobundle {
+ my($self) = shift;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ my(@bundle) = $self->_u_r_common("a",@_);
+ my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ File::Path::mkpath($todir);
+ unless (-d $todir) {
+ $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
+ return;
+ }
+ my($y,$m,$d) = (localtime)[5,4,3];
+ $y+=1900;
+ $m++;
+ my($c) = 0;
+ my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
+ my($to) = File::Spec->catfile($todir,"$me.pm");
+ while (-f $to) {
+ $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
+ $to = File::Spec->catfile($todir,"$me.pm");
+ }
+ my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
+ $fh->print(
+ "package Bundle::$me;\n\n",
+ "\$","VERSION = '0.01';\n\n", # hide from perl-reversion
+ "1;\n\n",
+ "__END__\n\n",
+ "=head1 NAME\n\n",
+ "Bundle::$me - Snapshot of installation on ",
+ $Config::Config{'myhostname'},
+ " on ",
+ scalar(localtime),
+ "\n\n=head1 SYNOPSIS\n\n",
+ "perl -MCPAN -e 'install Bundle::$me'\n\n",
+ "=head1 CONTENTS\n\n",
+ join("\n", @bundle),
+ "\n\n=head1 CONFIGURATION\n\n",
+ Config->myconfig,
+ "\n\n=head1 AUTHOR\n\n",
+ "This Bundle has been generated automatically ",
+ "by the autobundle routine in CPAN.pm.\n",
+ );
+ $fh->close;
+ $CPAN::Frontend->myprint("\nWrote bundle file
+ $to\n\n");
+}
+
+#-> sub CPAN::Shell::expandany ;
+sub expandany {
+ my($self,$s) = @_;
+ CPAN->debug("s[$s]") if $CPAN::DEBUG;
+ my $module_as_path = "";
+ if ($s =~ m|(?:\w+/)*\w+\.pm$|) { # same regexp in sub m
+ $module_as_path = $s;
+ $module_as_path =~ s/.pm$//;
+ $module_as_path =~ s|/|::|g;
+ }
+ if ($module_as_path) {
+ if ($module_as_path =~ m|^Bundle::|) {
+ $self->local_bundles;
+ return $self->expand('Bundle',$module_as_path);
+ } else {
+ return $self->expand('Module',$module_as_path)
+ if $CPAN::META->exists('CPAN::Module',$module_as_path);
+ }
+ } elsif ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
+ $s = CPAN::Distribution->normalize($s);
+ return $CPAN::META->instance('CPAN::Distribution',$s);
+ # Distributions spring into existence, not expand
+ } elsif ($s =~ m|^Bundle::|) {
+ $self->local_bundles; # scanning so late for bundles seems
+ # both attractive and crumpy: always
+ # current state but easy to forget
+ # somewhere
+ return $self->expand('Bundle',$s);
+ } else {
+ return $self->expand('Module',$s)
+ if $CPAN::META->exists('CPAN::Module',$s);
+ }
+ return;
+}
+
+#-> sub CPAN::Shell::expand ;
+sub expand {
+ my $self = shift;
+ my($type,@args) = @_;
+ CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
+ my $class = "CPAN::$type";
+ my $methods = ['id'];
+ for my $meth (qw(name)) {
+ next unless $class->can($meth);
+ push @$methods, $meth;
+ }
+ $self->expand_by_method($class,$methods,@args);
+}
+
+#-> sub CPAN::Shell::expand_by_method ;
+sub expand_by_method {
+ my $self = shift;
+ my($class,$methods,@args) = @_;
+ my($arg,@m);
+ for $arg (@args) {
+ my($regex,$command);
+ if ($arg =~ m|^/(.*)/$|) {
+ $regex = $1;
+# FIXME: there seem to be some ='s in the author data, which trigger
+# a failure here. This needs to be contemplated.
+# } elsif ($arg =~ m/=/) {
+# $command = 1;
+ }
+ my $obj;
+ CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
+ $class,
+ defined $regex ? $regex : "UNDEFINED",
+ defined $command ? $command : "UNDEFINED",
+ ) if $CPAN::DEBUG;
+ if (defined $regex) {
+ if (CPAN::_sqlite_running()) {
+ CPAN::Index->reload;
+ $CPAN::SQLite->search($class, $regex);
+ }
+ for $obj (
+ $CPAN::META->all_objects($class)
+ ) {
+ unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
+ # BUG, we got an empty object somewhere
+ require Data::Dumper;
+ CPAN->debug(sprintf(
+ "Bug in CPAN: Empty id on obj[%s][%s]",
+ $obj,
+ Data::Dumper::Dumper($obj)
+ )) if $CPAN::DEBUG;
+ next;
+ }
+ for my $method (@$methods) {
+ my $match = eval {$obj->$method() =~ /$regex/i};
+ if ($@) {
+ my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
+ $err ||= $@; # if we were too restrictive above
+ $CPAN::Frontend->mydie("$err\n");
+ } elsif ($match) {
+ push @m, $obj;
+ last;
+ }
+ }
+ }
+ } elsif ($command) {
+ die "equal sign in command disabled (immature interface), ".
+ "you can set
+ ! \$CPAN::Shell::ADVANCED_QUERY=1
+to enable it. But please note, this is HIGHLY EXPERIMENTAL code
+that may go away anytime.\n"
+ unless $ADVANCED_QUERY;
+ my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
+ my($matchcrit) = $criterion =~ m/^~(.+)/;
+ for my $self (
+ sort
+ {$a->id cmp $b->id}
+ $CPAN::META->all_objects($class)
+ ) {
+ my $lhs = $self->$method() or next; # () for 5.00503
+ if ($matchcrit) {
+ push @m, $self if $lhs =~ m/$matchcrit/;
+ } else {
+ push @m, $self if $lhs eq $criterion;
+ }
+ }
+ } else {
+ my($xarg) = $arg;
+ if ( $class eq 'CPAN::Bundle' ) {
+ $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
+ } elsif ($class eq "CPAN::Distribution") {
+ $xarg = CPAN::Distribution->normalize($arg);
+ } else {
+ $xarg =~ s/:+/::/g;
+ }
+ if ($CPAN::META->exists($class,$xarg)) {
+ $obj = $CPAN::META->instance($class,$xarg);
+ } elsif ($CPAN::META->exists($class,$arg)) {
+ $obj = $CPAN::META->instance($class,$arg);
+ } else {
+ next;
+ }
+ push @m, $obj;
+ }
+ }
+ @m = sort {$a->id cmp $b->id} @m;
+ if ( $CPAN::DEBUG ) {
+ my $wantarray = wantarray;
+ my $join_m = join ",", map {$_->id} @m;
+ # $self->debug("wantarray[$wantarray]join_m[$join_m]");
+ my $count = scalar @m;
+ $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
+ }
+ return wantarray ? @m : $m[0];
+}
+
+#-> sub CPAN::Shell::format_result ;
+sub format_result {
+ my($self) = shift;
+ my($type,@args) = @_;
+ @args = '/./' unless @args;
+ my(@result) = $self->expand($type,@args);
+ my $result = @result == 1 ?
+ $result[0]->as_string :
+ @result == 0 ?
+ "No objects of type $type found for argument @args\n" :
+ join("",
+ (map {$_->as_glimpse} @result),
+ scalar @result, " items found\n",
+ );
+ $result;
+}
+
+#-> sub CPAN::Shell::report_fh ;
+{
+ my $installation_report_fh;
+ my $previously_noticed = 0;
+
+ sub report_fh {
+ return $installation_report_fh if $installation_report_fh;
+ if ($CPAN::META->has_usable("File::Temp")) {
+ $installation_report_fh
+ = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => 'cpan_install_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ }
+ unless ( $installation_report_fh ) {
+ warn("Couldn't open installation report file; " .
+ "no report file will be generated."
+ ) unless $previously_noticed++;
+ }
+ }
+}
+
+
+# The only reason for this method is currently to have a reliable
+# debugging utility that reveals which output is going through which
+# channel. No, I don't like the colors ;-)
+
+# to turn colordebugging on, write
+# cpan> o conf colorize_output 1
+
+#-> sub CPAN::Shell::colorize_output ;
+{
+ my $print_ornamented_have_warned = 0;
+ sub colorize_output {
+ my $colorize_output = $CPAN::Config->{colorize_output};
+ if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
+ unless ($print_ornamented_have_warned++) {
+ # no myprint/mywarn within myprint/mywarn!
+ warn "Colorize_output is set to true but Term::ANSIColor is not
+installed. To activate colorized output, please install Term::ANSIColor.\n\n";
+ }
+ $colorize_output = 0;
+ }
+ return $colorize_output;
+ }
+}
+
+
+#-> sub CPAN::Shell::print_ornamented ;
+sub print_ornamented {
+ my($self,$what,$ornament) = @_;
+ return unless defined $what;
+
+ local $| = 1; # Flush immediately
+ if ( $CPAN::Be_Silent ) {
+ print {report_fh()} $what;
+ return;
+ }
+ my $swhat = "$what"; # stringify if it is an object
+ if ($CPAN::Config->{term_is_latin}) {
+ # note: deprecated, need to switch to $LANG and $LC_*
+ # courtesy jhi:
+ $swhat
+ =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
+ }
+ if ($self->colorize_output) {
+ if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
+ # if you want to have this configurable, please file a bugreport
+ $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
+ }
+ my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
+ if ($@) {
+ print "Term::ANSIColor rejects color[$ornament]: $@\n
+Please choose a different color (Hint: try 'o conf init /color/')\n";
+ }
+ # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
+ # $trailer construct. We want the newline be the last thing if
+ # there is a newline at the end ensuring that the next line is
+ # empty for other players
+ my $trailer = "";
+ $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
+ print $color_on,
+ $swhat,
+ Term::ANSIColor::color("reset"),
+ $trailer;
+ } else {
+ print $swhat;
+ }
+}
+
+#-> sub CPAN::Shell::myprint ;
+
+# where is myprint/mywarn/Frontend/etc. documented? Where to use what?
+# I think, we send everything to STDOUT and use print for normal/good
+# news and warn for news that need more attention. Yes, this is our
+# working contract for now.
+sub myprint {
+ my($self,$what) = @_;
+ $self->print_ornamented($what,
+ $CPAN::Config->{colorize_print}||'bold blue on_white',
+ );
+}
+
+sub optprint {
+ my($self,$category,$what) = @_;
+ my $vname = $category . "_verbosity";
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ if (!$CPAN::Config->{$vname}
+ || $CPAN::Config->{$vname} =~ /^v/
+ ) {
+ $CPAN::Frontend->myprint($what);
+ }
+}
+
+#-> sub CPAN::Shell::myexit ;
+sub myexit {
+ my($self,$what) = @_;
+ $self->myprint($what);
+ exit;
+}
+
+#-> sub CPAN::Shell::mywarn ;
+sub mywarn {
+ my($self,$what) = @_;
+ $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
+}
+
+# only to be used for shell commands
+#-> sub CPAN::Shell::mydie ;
+sub mydie {
+ my($self,$what) = @_;
+ $self->mywarn($what);
+
+ # If it is the shell, we want the following die to be silent,
+ # but if it is not the shell, we would need a 'die $what'. We need
+ # to take care that only shell commands use mydie. Is this
+ # possible?
+
+ die "\n";
+}
+
+# sub CPAN::Shell::colorable_makemaker_prompt ;
+sub colorable_makemaker_prompt {
+ my($foo,$bar) = @_;
+ if (CPAN::Shell->colorize_output) {
+ my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
+ my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
+ print $color_on;
+ }
+ my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
+ if (CPAN::Shell->colorize_output) {
+ print Term::ANSIColor::color('reset');
+ }
+ return $ans;
+}
+
+# use this only for unrecoverable errors!
+#-> sub CPAN::Shell::unrecoverable_error ;
+sub unrecoverable_error {
+ my($self,$what) = @_;
+ my @lines = split /\n/, $what;
+ my $longest = 0;
+ for my $l (@lines) {
+ $longest = length $l if length $l > $longest;
+ }
+ $longest = 62 if $longest > 62;
+ for my $l (@lines) {
+ if ($l =~ /^\s*$/) {
+ $l = "\n";
+ next;
+ }
+ $l = "==> $l";
+ if (length $l < 66) {
+ $l = pack "A66 A*", $l, "<==";
+ }
+ $l .= "\n";
+ }
+ unshift @lines, "\n";
+ $self->mydie(join "", @lines);
+}
+
+#-> sub CPAN::Shell::mysleep ;
+sub mysleep {
+ my($self, $sleep) = @_;
+ if (CPAN->has_inst("Time::HiRes")) {
+ Time::HiRes::sleep($sleep);
+ } else {
+ sleep($sleep < 1 ? 1 : int($sleep + 0.5));
+ }
+}
+
+#-> sub CPAN::Shell::setup_output ;
+sub setup_output {
+ return if -t STDOUT;
+ my $odef = select STDERR;
+ $| = 1;
+ select STDOUT;
+ $| = 1;
+ select $odef;
+}
+
+#-> sub CPAN::Shell::rematein ;
+# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
+sub rematein {
+ my $self = shift;
+ # this variable was global and disturbed programmers, so localize:
+ local $CPAN::Distrostatus::something_has_failed_at;
+ my($meth,@some) = @_;
+ my @pragma;
+ while($meth =~ /^(ff?orce|notest)$/) {
+ push @pragma, $meth;
+ $meth = shift @some or
+ $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
+ "cannot continue");
+ }
+ setup_output();
+ CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
+
+ # Here is the place to set "test_count" on all involved parties to
+ # 0. We then can pass this counter on to the involved
+ # distributions and those can refuse to test if test_count > X. In
+ # the first stab at it we could use a 1 for "X".
+
+ # But when do I reset the distributions to start with 0 again?
+ # Jost suggested to have a random or cycling interaction ID that
+ # we pass through. But the ID is something that is just left lying
+ # around in addition to the counter, so I'd prefer to set the
+ # counter to 0 now, and repeat at the end of the loop. But what
+ # about dependencies? They appear later and are not reset, they
+ # enter the queue but not its copy. How do they get a sensible
+ # test_count?
+
+ # With configure_requires, "get" is vulnerable in recursion.
+
+ my $needs_recursion_protection = "get|make|test|install";
+
+ # construct the queue
+ my($s,@s,@qcopy);
+ STHING: foreach $s (@some) {
+ my $obj;
+ if (ref $s) {
+ CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
+ $obj = $s;
+ } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
+ } elsif ($s =~ m|^/|) { # looks like a regexp
+ if (substr($s,-1,1) eq ".") {
+ $obj = CPAN::Shell->expandany($s);
+ } else {
+ my @obj;
+ CLASS: for my $class (qw(Distribution Bundle Module)) {
+ if (@obj = $self->expand($class,$s)) {
+ last CLASS;
+ }
+ }
+ if (@obj) {
+ if (1==@obj) {
+ $obj = $obj[0];
+ } else {
+ $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
+ "only supported when unambiguous.\nRejecting argument '$s'\n");
+ $CPAN::Frontend->mysleep(2);
+ next STHING;
+ }
+ }
+ }
+ } elsif ($meth eq "ls") {
+ $self->globls($s,\@pragma);
+ next STHING;
+ } else {
+ CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
+ $obj = CPAN::Shell->expandany($s);
+ }
+ if (0) {
+ } elsif (ref $obj) {
+ if ($meth =~ /^($needs_recursion_protection)$/) {
+ # it would be silly to check for recursion for look or dump
+ # (we are in CPAN::Shell::rematein)
+ CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
+ eval { $obj->color_cmd_tmps(0,1); };
+ if ($@) {
+ if (ref $@
+ and $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ } else {
+ if (0) {
+ require Carp;
+ Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
+ }
+ die;
+ }
+ }
+ }
+ CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
+ push @qcopy, $obj;
+ } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
+ $obj = $CPAN::META->instance('CPAN::Author',uc($s));
+ if ($meth =~ /^(dump|ls|reports)$/) {
+ $obj->$meth();
+ } else {
+ $CPAN::Frontend->mywarn(
+ join "",
+ "Don't be silly, you can't $meth ",
+ $obj->fullname,
+ " ;-)\n"
+ );
+ $CPAN::Frontend->mysleep(2);
+ }
+ } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
+ CPAN::InfoObj->dump($s);
+ } else {
+ $CPAN::Frontend
+ ->mywarn(qq{Warning: Cannot $meth $s, }.
+ qq{don't know what it is.
+Try the command
+
+ i /$s/
+
+to find objects with matching identifiers.
+});
+ $CPAN::Frontend->mysleep(2);
+ }
+ }
+
+ # queuerunner (please be warned: when I started to change the
+ # queue to hold objects instead of names, I made one or two
+ # mistakes and never found which. I reverted back instead)
+ QITEM: while (my $q = CPAN::Queue->first) {
+ my $obj;
+ my $s = $q->as_string;
+ my $reqtype = $q->reqtype || "";
+ $obj = CPAN::Shell->expandany($s);
+ unless ($obj) {
+ # don't know how this can happen, maybe we should panic,
+ # but maybe we get a solution from the first user who hits
+ # this unfortunate exception?
+ $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
+ "to an object. Skipping.\n");
+ $CPAN::Frontend->mysleep(5);
+ CPAN::Queue->delete_first($s);
+ next QITEM;
+ }
+ $obj->{reqtype} ||= "";
+ {
+ # force debugging because CPAN::SQLite somehow delivers us
+ # an empty object;
+
+ # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
+
+ CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
+ "q-reqtype[$reqtype]") if $CPAN::DEBUG;
+ }
+ if ($obj->{reqtype}) {
+ if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
+ $obj->{reqtype} = $reqtype;
+ if (
+ exists $obj->{install}
+ &&
+ (
+ UNIVERSAL::can($obj->{install},"failed") ?
+ $obj->{install}->failed :
+ $obj->{install} =~ /^NO/
+ )
+ ) {
+ delete $obj->{install};
+ $CPAN::Frontend->mywarn
+ ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
+ }
+ }
+ } else {
+ $obj->{reqtype} = $reqtype;
+ }
+
+ for my $pragma (@pragma) {
+ if ($pragma
+ &&
+ $obj->can($pragma)) {
+ $obj->$pragma($meth);
+ }
+ }
+ if (UNIVERSAL::can($obj, 'called_for')) {
+ $obj->called_for($s);
+ }
+ CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
+ qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
+
+ push @qcopy, $obj;
+ if ($meth =~ /^(report)$/) { # they came here with a pragma?
+ $self->$meth($obj);
+ } elsif (! UNIVERSAL::can($obj,$meth)) {
+ # Must never happen
+ my $serialized = "";
+ if (0) {
+ } elsif ($CPAN::META->has_inst("YAML::Syck")) {
+ $serialized = YAML::Syck::Dump($obj);
+ } elsif ($CPAN::META->has_inst("YAML")) {
+ $serialized = YAML::Dump($obj);
+ } elsif ($CPAN::META->has_inst("Data::Dumper")) {
+ $serialized = Data::Dumper::Dumper($obj);
+ } else {
+ require overload;
+ $serialized = overload::StrVal($obj);
+ }
+ CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
+ $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
+ } elsif ($obj->$meth()) {
+ CPAN::Queue->delete($s);
+ CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
+ } else {
+ CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
+ }
+
+ $obj->undelay;
+ for my $pragma (@pragma) {
+ my $unpragma = "un$pragma";
+ if ($obj->can($unpragma)) {
+ $obj->$unpragma();
+ }
+ }
+ if ($CPAN::Config->{halt_on_failure}
+ &&
+ CPAN::Distrostatus::something_has_just_failed()
+ ) {
+ $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
+ CPAN::Queue->nullify_queue;
+ last QITEM;
+ }
+ CPAN::Queue->delete_first($s);
+ }
+ if ($meth =~ /^($needs_recursion_protection)$/) {
+ for my $obj (@qcopy) {
+ $obj->color_cmd_tmps(0,0);
+ }
+ }
+}
+
+#-> sub CPAN::Shell::recent ;
+sub recent {
+ my($self) = @_;
+ if ($CPAN::META->has_inst("XML::LibXML")) {
+ my $url = $CPAN::Defaultrecent;
+ $CPAN::Frontend->myprint("Going to fetch '$url'\n");
+ unless ($CPAN::META->has_usable("LWP")) {
+ $CPAN::Frontend->mydie("LWP not installed; cannot continue");
+ }
+ CPAN::LWP::UserAgent->config;
+ my $Ua;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ my $resp = $Ua->get($url);
+ unless ($resp->is_success) {
+ $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
+ }
+ $CPAN::Frontend->myprint("DONE\n\n");
+ my $xml = XML::LibXML->new->parse_string($resp->content);
+ if (0) {
+ my $s = $xml->serialize(2);
+ $s =~ s/\n\s*\n/\n/g;
+ $CPAN::Frontend->myprint($s);
+ return;
+ }
+ my @distros;
+ if ($url =~ /winnipeg/) {
+ my $pubdate = $xml->findvalue("/rss/channel/pubDate");
+ $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
+ for my $eitem ($xml->findnodes("/rss/channel/item")) {
+ my $distro = $eitem->findvalue("enclosure/\@url");
+ $distro =~ s|.*?/authors/id/./../||;
+ my $size = $eitem->findvalue("enclosure/\@length");
+ my $desc = $eitem->findvalue("description");
+ $desc =~ s/.+? - //;
+ $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
+ push @distros, $distro;
+ }
+ } elsif ($url =~ /search.*uploads.rdf/) {
+ # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ # xmlns="http://purl.org/rss/1.0/"
+ # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
+ # xmlns:dc="http://purl.org/dc/elements/1.1/"
+ # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
+ # xmlns:admin="http://webns.net/mvcb/"
+
+
+ my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
+ $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
+ my $finish_eitem = 0;
+ local $SIG{INT} = sub { $finish_eitem = 1 };
+ EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
+ my $distro = $eitem->findvalue("\@rdf:about");
+ $distro =~ s|.*~||; # remove up to the tilde before the name
+ $distro =~ s|/$||; # remove trailing slash
+ $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
+ my $author = uc $1 or die "distro[$distro] without author, cannot continue";
+ my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
+ my $i = 0;
+ SUBDIRTEST: while () {
+ last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
+ if (my @ret = $self->globls("$distro*")) {
+ @ret = grep {$_->[2] !~ /meta/} @ret;
+ @ret = grep {length $_->[2]} @ret;
+ if (@ret) {
+ $distro = "$author/$ret[0][2]";
+ last SUBDIRTEST;
+ }
+ }
+ $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
+ }
+
+ next EITEM if $distro =~ m|\*|; # did not find the thing
+ $CPAN::Frontend->myprint("____$desc\n");
+ push @distros, $distro;
+ last EITEM if $finish_eitem;
+ }
+ }
+ return \@distros;
+ } else {
+ # deprecated old version
+ $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
+ }
+}
+
+#-> sub CPAN::Shell::smoke ;
+sub smoke {
+ my($self) = @_;
+ my $distros = $self->recent;
+ DISTRO: for my $distro (@$distros) {
+ next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
+ $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
+ {
+ my $skip = 0;
+ local $SIG{INT} = sub { $skip = 1 };
+ for (0..9) {
+ $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
+ sleep 1;
+ if ($skip) {
+ $CPAN::Frontend->myprint(" skipped\n");
+ next DISTRO;
+ }
+ }
+ }
+ $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
+ $self->test($distro);
+ }
+}
+
+{
+ # set up the dispatching methods
+ no strict "refs";
+ for my $command (qw(
+ clean
+ cvs_import
+ dump
+ force
+ fforce
+ get
+ install
+ look
+ ls
+ make
+ notest
+ perldoc
+ readme
+ reports
+ test
+ )) {
+ *$command = sub { shift->rematein($command, @_); };
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Tarzip.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Tarzip.pm
new file mode 100755
index 00000000000..b97bd200164
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Tarzip.pm
@@ -0,0 +1,442 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+package CPAN::Tarzip;
+use strict;
+use vars qw($VERSION @ISA $BUGHUNTING);
+use CPAN::Debug;
+use File::Basename qw(basename);
+$VERSION = "5.501";
+# module is internal to CPAN.pm
+
+@ISA = qw(CPAN::Debug); ## no critic
+$BUGHUNTING ||= 0; # released code must have turned off
+
+# it's ok if file doesn't exist, it just matters if it is .gz or .bz2
+sub new {
+ my($class,$file) = @_;
+ $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
+ my $me = { FILE => $file };
+ if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
+ $me->{ISCOMPRESSED} = 1;
+ } else {
+ $me->{ISCOMPRESSED} = 0;
+ }
+ if (0) {
+ } elsif ($file =~ /\.(?:bz2|tbz)$/i) {
+ unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
+ my $bzip2 = _my_which("bzip2");
+ if ($bzip2) {
+ $me->{UNGZIPPRG} = $bzip2;
+ } else {
+ $CPAN::Frontend->mydie(qq{
+CPAN.pm needs the external program bzip2 in order to handle '$file'.
+Please install it now and run 'o conf init' to register it as external
+program.
+});
+ }
+ }
+ } else {
+ $me->{UNGZIPPRG} = _my_which("gzip");
+ }
+ $me->{TARPRG} = _my_which("tar") || _my_which("gtar");
+ bless $me, $class;
+}
+
+sub _my_which {
+ my($what) = @_;
+ if ($CPAN::Config->{$what}) {
+ return $CPAN::Config->{$what};
+ }
+ if ($CPAN::META->has_inst("File::Which")) {
+ return File::Which::which($what);
+ }
+ my @cand = MM->maybe_command($what);
+ return $cand[0] if @cand;
+ require File::Spec;
+ my $component;
+ PATH_COMPONENT: foreach $component (File::Spec->path()) {
+ next unless defined($component) && $component;
+ my($abs) = File::Spec->catfile($component,$what);
+ if (MM->maybe_command($abs)) {
+ return $abs;
+ }
+ }
+ return;
+}
+
+sub gzip {
+ my($self,$read) = @_;
+ my $write = $self->{FILE};
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my($buffer,$fhw);
+ $fhw = FileHandle->new($read)
+ or $CPAN::Frontend->mydie("Could not open $read: $!");
+ my $cwd = `pwd`;
+ my $gz = Compress::Zlib::gzopen($write, "wb")
+ or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
+ $gz->gzwrite($buffer)
+ while read($fhw,$buffer,4096) > 0 ;
+ $gz->gzclose() ;
+ $fhw->close;
+ return 1;
+ } else {
+ my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ system(qq{$command -c "$read" > "$write"})==0;
+ }
+}
+
+
+sub gunzip {
+ my($self,$write) = @_;
+ my $read = $self->{FILE};
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my($buffer,$fhw);
+ $fhw = FileHandle->new(">$write")
+ or $CPAN::Frontend->mydie("Could not open >$write: $!");
+ my $gz = Compress::Zlib::gzopen($read, "rb")
+ or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
+ $fhw->print($buffer)
+ while $gz->gzread($buffer) > 0 ;
+ $CPAN::Frontend->mydie("Error reading from $read: $!\n")
+ if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
+ $gz->gzclose() ;
+ $fhw->close;
+ return 1;
+ } else {
+ my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ system(qq{$command -dc "$read" > "$write"})==0;
+ }
+}
+
+
+sub gtest {
+ my($self) = @_;
+ return $self->{GTEST} if exists $self->{GTEST};
+ defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
+ my $read = $self->{FILE};
+ my $success;
+ if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
+ my($buffer,$len);
+ $len = 0;
+ my $gz = Compress::Bzip2::bzopen($read, "rb")
+ or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
+ $read,
+ $Compress::Bzip2::bzerrno));
+ while ($gz->bzread($buffer) > 0 ) {
+ $len += length($buffer);
+ $buffer = "";
+ }
+ my $err = $gz->bzerror;
+ $success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END();
+ if ($len == -s $read) {
+ $success = 0;
+ CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
+ }
+ $gz->gzclose();
+ CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
+ } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) {
+ # After I had reread the documentation in zlib.h, I discovered that
+ # uncompressed files do not lead to an gzerror (anymore?).
+ my($buffer,$len);
+ $len = 0;
+ my $gz = Compress::Zlib::gzopen($read, "rb")
+ or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
+ $read,
+ $Compress::Zlib::gzerrno));
+ while ($gz->gzread($buffer) > 0 ) {
+ $len += length($buffer);
+ $buffer = "";
+ }
+ my $err = $gz->gzerror;
+ $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
+ if ($len == -s $read) {
+ $success = 0;
+ CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
+ }
+ $gz->gzclose();
+ CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
+ } elsif (!$self->{ISCOMPRESSED}) {
+ $success = 0;
+ } else {
+ my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ $success = 0==system(qq{$command -qdt "$read"});
+ }
+ return $self->{GTEST} = $success;
+}
+
+
+sub TIEHANDLE {
+ my($class,$file) = @_;
+ my $ret;
+ $class->debug("file[$file]");
+ my $self = $class->new($file);
+ if (0) {
+ } elsif (!$self->gtest) {
+ my $fh = FileHandle->new($file)
+ or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
+ binmode $fh;
+ $self->{FH} = $fh;
+ $class->debug("via uncompressed FH");
+ } elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
+ my $gz = Compress::Bzip2::bzopen($file,"rb") or
+ $CPAN::Frontend->mydie("Could not bzopen $file");
+ $self->{GZ} = $gz;
+ $class->debug("via Compress::Bzip2");
+ } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) {
+ my $gz = Compress::Zlib::gzopen($file,"rb") or
+ $CPAN::Frontend->mydie("Could not gzopen $file");
+ $self->{GZ} = $gz;
+ $class->debug("via Compress::Zlib");
+ } else {
+ my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ my $pipe = "$gzip -dc $file |";
+ my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
+ binmode $fh;
+ $self->{FH} = $fh;
+ $class->debug("via external $gzip");
+ }
+ $self;
+}
+
+
+sub READLINE {
+ my($self) = @_;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ my($line,$bytesread);
+ $bytesread = $gz->gzreadline($line);
+ return undef if $bytesread <= 0;
+ return $line;
+ } else {
+ my $fh = $self->{FH};
+ return scalar <$fh>;
+ }
+}
+
+
+sub READ {
+ my($self,$ref,$length,$offset) = @_;
+ $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
+ return $byteread;
+ } else {
+ my $fh = $self->{FH};
+ return read($fh,$$ref,$length);
+ }
+}
+
+
+sub DESTROY {
+ my($self) = @_;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ $gz->gzclose() if defined $gz; # hard to say if it is allowed
+ # to be undef ever. AK, 2000-09
+ } else {
+ my $fh = $self->{FH};
+ $fh->close if defined $fh;
+ }
+ undef $self;
+}
+
+sub untar {
+ my($self) = @_;
+ my $file = $self->{FILE};
+ my($prefer) = 0;
+
+ my $exttar = $self->{TARPRG} || "";
+ $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
+ my $extgzip = $self->{UNGZIPPRG} || "";
+ $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
+
+ if (0) { # makes changing order easier
+ } elsif ($BUGHUNTING) {
+ $prefer=2;
+ } elsif ($exttar && $extgzip && $file =~ /\.(?:bz2|tbz)$/i) {
+ # until Archive::Tar handles bzip2
+ $prefer = 1;
+ } elsif (
+ $CPAN::META->has_usable("Archive::Tar")
+ &&
+ $CPAN::META->has_inst("Compress::Zlib") ) {
+ $prefer = 2;
+ } elsif ($exttar && $extgzip) {
+ # no modules and not bz2
+ $prefer = 1;
+ # but solaris binary tar is a problem
+ if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
+ $CPAN::Frontend->mywarn(<< 'END_WARN');
+
+WARNING: Many CPAN distributions were archived with GNU tar and some of
+them may be incompatible with Solaris tar. We respectfully suggest you
+configure CPAN to use a GNU tar instead ("o conf init tar") or install
+a recent Archive::Tar instead;
+
+END_WARN
+ }
+ } else {
+ my $foundtar = $exttar ? "'$exttar'" : "nothing";
+ my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
+ my $foundAT;
+ if ($CPAN::META->has_usable("Archive::Tar")) {
+ $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
+ } else {
+ $foundAT = "nothing";
+ }
+ my $foundCZ;
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
+ } elsif ($foundAT) {
+ $foundCZ = "nothing";
+ } else {
+ $foundCZ = "also nothing";
+ }
+ $CPAN::Frontend->mydie(qq{
+
+CPAN.pm needs either the external programs tar and gzip -or- both
+modules Archive::Tar and Compress::Zlib installed.
+
+For tar I found $foundtar, for gzip $foundzip.
+
+For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
+
+Can't continue cutting file '$file'.
+});
+ }
+ my $tar_verb = "v";
+ if (defined $CPAN::Config->{tar_verbosity}) {
+ $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
+ $CPAN::Config->{tar_verbosity};
+ }
+ if ($prefer==1) { # 1 => external gzip+tar
+ my($system);
+ my $is_compressed = $self->gtest();
+ my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
+ if ($is_compressed) {
+ my $command = CPAN::HandleConfig->safe_quote($extgzip);
+ $system = qq{$command -dc }.
+ qq{< "$file" | $tarcommand x${tar_verb}f -};
+ } else {
+ $system = qq{$tarcommand x${tar_verb}f "$file"};
+ }
+ if (system($system) != 0) {
+ # people find the most curious tar binaries that cannot handle
+ # pipes
+ if ($is_compressed) {
+ (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
+ $ungzf = basename $ungzf;
+ my $ct = CPAN::Tarzip->new($file);
+ if ($ct->gunzip($ungzf)) {
+ $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
+ } else {
+ $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
+ }
+ $file = $ungzf;
+ }
+ $system = qq{$tarcommand x${tar_verb}f "$file"};
+ $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
+ if (system($system)==0) {
+ $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
+ } else {
+ $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
+ }
+ return 1;
+ } else {
+ return 1;
+ }
+ } elsif ($prefer==2) { # 2 => modules
+ unless ($CPAN::META->has_usable("Archive::Tar")) {
+ $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
+ }
+ # Make sure AT does not use uid/gid/permissions in the archive
+ # This leaves it to the user's umask instead
+ local $Archive::Tar::CHMOD = 1;
+ local $Archive::Tar::SAME_PERMISSIONS = 0;
+ # Make sure AT leaves current user as owner
+ local $Archive::Tar::CHOWN = 0;
+ my $tar = Archive::Tar->new($file,1);
+ my $af; # archive file
+ my @af;
+ if ($BUGHUNTING) {
+ # RCS 1.337 had this code, it turned out unacceptable slow but
+ # it revealed a bug in Archive::Tar. Code is only here to hunt
+ # the bug again. It should never be enabled in published code.
+ # GDGraph3d-0.53 was an interesting case according to Larry
+ # Virden.
+ warn(">>>Bughunting code enabled<<< " x 20);
+ for $af ($tar->list_files) {
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains ".
+ "illegal member [$af]");
+ }
+ $CPAN::Frontend->myprint("$af\n");
+ $tar->extract($af); # slow but effective for finding the bug
+ return if $CPAN::Signal;
+ }
+ } else {
+ for $af ($tar->list_files) {
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains ".
+ "illegal member [$af]");
+ }
+ if ($tar_verb eq "v" || $tar_verb eq "vv") {
+ $CPAN::Frontend->myprint("$af\n");
+ }
+ push @af, $af;
+ return if $CPAN::Signal;
+ }
+ $tar->extract(@af) or
+ $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
+ }
+
+ Mac::BuildTools::convert_files([$tar->list_files], 1)
+ if ($^O eq 'MacOS');
+
+ return 1;
+ }
+}
+
+sub unzip {
+ my($self) = @_;
+ my $file = $self->{FILE};
+ if ($CPAN::META->has_inst("Archive::Zip")) {
+ # blueprint of the code from Archive::Zip::Tree::extractTree();
+ my $zip = Archive::Zip->new();
+ my $status;
+ $status = $zip->read($file);
+ $CPAN::Frontend->mydie("Read of file[$file] failed\n")
+ if $status != Archive::Zip::AZ_OK();
+ $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
+ my @members = $zip->members();
+ for my $member ( @members ) {
+ my $af = $member->fileName();
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains ".
+ "illegal member [$af]");
+ }
+ $status = $member->extractToFileNamed( $af );
+ $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
+ $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
+ $status != Archive::Zip::AZ_OK();
+ return if $CPAN::Signal;
+ }
+ return 1;
+ } else {
+ my $unzip = $CPAN::Config->{unzip} or
+ $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
+ my @system = ($unzip, $file);
+ return system(@system) == 0;
+ }
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/URL.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/URL.pm
new file mode 100755
index 00000000000..52b42eec88e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/URL.pm
@@ -0,0 +1,31 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::URL;
+use overload '""' => "as_string", fallback => 1;
+# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
+# planned are things like age or quality
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+sub new {
+ my($class,%args) = @_;
+ bless {
+ %args
+ }, $class;
+}
+sub as_string {
+ my($self) = @_;
+ $self->text;
+}
+sub text {
+ my($self,$set) = @_;
+ if (defined $set) {
+ $self->{TEXT} = $set;
+ }
+ $self->{TEXT};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Version.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Version.pm
new file mode 100755
index 00000000000..da876aac2d7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Version.pm
@@ -0,0 +1,173 @@
+package CPAN::Version;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "5.5";
+
+# CPAN::Version::vcmp courtesy Jost Krieger
+sub vcmp {
+ my($self,$l,$r) = @_;
+ local($^W) = 0;
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+
+ return 0 if $l eq $r; # short circuit for quicker success
+
+ for ($l,$r) {
+ s/_//g;
+ }
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+ for ($l,$r) {
+ next unless tr/.// > 1 || /^v/;
+ s/^v?/v/;
+ 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
+ }
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+ if ($l=~/^v/ <=> $r=~/^v/) {
+ for ($l,$r) {
+ next if /^v/;
+ $_ = $self->float2vv($_);
+ }
+ }
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+ my $lvstring = "v0";
+ my $rvstring = "v0";
+ if ($] >= 5.006
+ && $l =~ /^v/
+ && $r =~ /^v/) {
+ $lvstring = $self->vstring($l);
+ $rvstring = $self->vstring($r);
+ CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG;
+ }
+
+ return (
+ ($l ne "undef") <=> ($r ne "undef")
+ ||
+ $lvstring cmp $rvstring
+ ||
+ $l <=> $r
+ ||
+ $l cmp $r
+ );
+}
+
+sub vgt {
+ my($self,$l,$r) = @_;
+ $self->vcmp($l,$r) > 0;
+}
+
+sub vlt {
+ my($self,$l,$r) = @_;
+ 0 + ($self->vcmp($l,$r) < 0);
+}
+
+sub vge {
+ my($self,$l,$r) = @_;
+ $self->vcmp($l,$r) >= 0;
+}
+
+sub vle {
+ my($self,$l,$r) = @_;
+ 0 + ($self->vcmp($l,$r) <= 0);
+}
+
+sub vstring {
+ my($self,$n) = @_;
+ $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
+ pack "U*", split /\./, $n;
+}
+
+# vv => visible vstring
+sub float2vv {
+ my($self,$n) = @_;
+ my($rev) = int($n);
+ $rev ||= 0;
+ my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
+ # architecture influence
+ $mantissa ||= 0;
+ $mantissa .= "0" while length($mantissa)%3;
+ my $ret = "v" . $rev;
+ while ($mantissa) {
+ $mantissa =~ s/(\d{1,3})// or
+ die "Panic: length>0 but not a digit? mantissa[$mantissa]";
+ $ret .= ".".int($1);
+ }
+ # warn "n[$n]ret[$ret]";
+ $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
+ $ret;
+}
+
+sub readable {
+ my($self,$n) = @_;
+ $n =~ /^([\w\-\+\.]+)/;
+
+ return $1 if defined $1 && length($1)>0;
+ # if the first user reaches version v43, he will be treated as "+".
+ # We'll have to decide about a new rule here then, depending on what
+ # will be the prevailing versioning behavior then.
+
+ if ($] < 5.006) { # or whenever v-strings were introduced
+ # we get them wrong anyway, whatever we do, because 5.005 will
+ # have already interpreted 0.2.4 to be "0.24". So even if he
+ # indexer sends us something like "v0.2.4" we compare wrongly.
+
+ # And if they say v1.2, then the old perl takes it as "v12"
+
+ if (defined $CPAN::Frontend) {
+ $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
+ } else {
+ warn("Suspicious version string seen [$n]\n");
+ }
+ return $n;
+ }
+ my $better = sprintf "v%vd", $n;
+ CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
+ return $better;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Version - utility functions to compare CPAN versions
+
+=head1 SYNOPSIS
+
+ use CPAN::Version;
+
+ CPAN::Version->vgt("1.1","1.1.1"); # 1 bc. 1.1 > 1.001001
+
+ CPAN::Version->vlt("1.1","1.1"); # 0 bc. 1.1 not < 1.1
+
+ CPAN::Version->vcmp("1.1","1.1.1"); # 1 bc. first is larger
+
+ CPAN::Version->vcmp("1.1.1","1.1"); # -1 bc. first is smaller
+
+ CPAN::Version->readable(v1.2.3); # "v1.2.3"
+
+ CPAN::Version->vstring("v1.2.3"); # v1.2.3
+
+ CPAN::Version->float2vv(1.002003); # "v1.2.3"
+
+=head1 DESCRIPTION
+
+This module mediates between some version that perl sees in a package
+and the version that is published by the CPAN indexer.
+
+It's only written as a helper module for both CPAN.pm and CPANPLUS.pm.
+
+As it stands it predates version.pm but has the same goal: make
+version strings visible and comparable.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End:
diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS.pm
new file mode 100755
index 00000000000..b4a7e8fe5d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.9001"; #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.straw/lib/Carp.pm b/Master/tlpkg/tlperl.straw/lib/Carp.pm
new file mode 100755
index 00000000000..c06f949cc7e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Carp.pm
@@ -0,0 +1,237 @@
+package Carp;
+
+our $VERSION = '1.11';
+# this file is an utra-lightweight stub. The first time a function is
+# called, Carp::Heavy is loaded, and the real short/longmessmess_jmp
+# subs are installed
+
+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
+
+# 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'; @_ }
+
+# fixed hooks for stashes to point to
+sub longmess { goto &longmess_jmp }
+sub shortmess { goto &shortmess_jmp }
+# these two are replaced when Carp::Heavy is loaded
+sub longmess_jmp {
+ local($@, $!);
+ eval { require Carp::Heavy };
+ return $@ if $@;
+ goto &longmess_real;
+}
+sub shortmess_jmp {
+ local($@, $!);
+ eval { require Carp::Heavy };
+ return $@ if $@;
+ goto &shortmess_real;
+}
+
+sub croak { die shortmess @_ }
+sub confess { die longmess @_ }
+sub carp { warn shortmess @_ }
+sub cluck { warn longmess @_ }
+
+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<cluck> 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::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.straw/lib/Class/ErrorHandler.pm b/Master/tlpkg/tlperl.straw/lib/Class/ErrorHandler.pm
new file mode 100755
index 00000000000..20c82eb65c0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Class/ErrorHandler.pm
@@ -0,0 +1,100 @@
+# $Id: ErrorHandler.pm,v 1.1.1.1 2004/08/15 14:55:43 btrott Exp $
+
+package Class::ErrorHandler;
+use strict;
+
+use vars qw( $VERSION $ERROR );
+$VERSION = '0.01';
+
+sub error {
+ my $msg = $_[1] || '';
+ if (ref($_[0])) {
+ $_[0]->{_errstr} = $msg;
+ } else {
+ $ERROR = $msg;
+ }
+ return;
+}
+
+sub errstr {
+ ref($_[0]) ? $_[0]->{_errstr} : $ERROR
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Class::ErrorHandler - Base class for error handling
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw( Class::ErrorHandler );
+
+ sub class_method {
+ my $class = shift;
+ ...
+ return $class->error("Help!")
+ unless $continue;
+ }
+
+ sub object_method {
+ my $obj = shift;
+ ...
+ return $obj->error("I am no more")
+ unless $continue;
+ }
+
+ package main;
+ use Foo;
+
+ Foo->class_method or die Foo->errstr;
+
+ my $foo = Foo->new;
+ $foo->object_method or die $foo->errstr;
+
+=head1 DESCRIPTION
+
+I<Class::ErrorHandler> provides an error-handling mechanism that's generic
+enough to be used as the base class for a variety of OO classes. Subclasses
+inherit its two error-handling methods, I<error> and I<errstr>, to
+communicate error messages back to the calling program.
+
+On failure (for whatever reason), a subclass should call I<error> and return
+to the caller; I<error> itself sets the error message internally, then
+returns C<undef>. This has the effect of the method that failed returning
+C<undef> to the caller. The caller should check for errors by checking for a
+return value of C<undef>, and calling I<errstr> to get the value of the
+error message on an error.
+
+As demonstrated in the L<SYNOPSIS>, I<error> and I<errstr> work as both class
+methods and object methods.
+
+=head1 USAGE
+
+=head2 Class->error($message)
+
+=head2 $object->error($message)
+
+Sets the error message for either the class I<Class> or the object
+I<$object> to the message I<$message>. Returns C<undef>.
+
+=head2 Class->errstr
+
+=head2 $object->errstr
+
+Accesses the last error message set in the class I<Class> or the
+object I<$object>, respectively, and returns that error message.
+
+=head1 LICENSE
+
+I<Class::ErrorHandler> is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR & COPYRIGHT
+
+Except where otherwise noted, I<Class::ErrorHandler> is Copyright 2004
+Benjamin Trott, cpan@stupidfool.org. All rights reserved.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Class/ISA.pm b/Master/tlpkg/tlperl.straw/lib/Class/ISA.pm
new file mode 100755
index 00000000000..83f47acf6d7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Class/ISA.pm
@@ -0,0 +1,218 @@
+package Class::ISA;
+require 5;
+use strict;
+use vars qw($Debug $VERSION);
+$VERSION = '0.36';
+$Debug = 0 unless defined $Debug;
+
+use if $] >= 5.011, 'deprecate';
+
+###########################################################################
+
+sub self_and_super_versions {
+ no strict 'refs';
+ map {
+ $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef)
+ } self_and_super_path($_[0])
+}
+
+# Also consider magic like:
+# no strict 'refs';
+# my %class2SomeHashr =
+# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () }
+# Class::ISA::self_and_super_path($class);
+# to get a hash of refs to all the defined (and non-empty) hashes in
+# $class and its superclasses.
+#
+# Or even consider this incantation for doing something like hash-data
+# inheritance:
+# no strict 'refs';
+# %union_hash =
+# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () }
+# reverse(Class::ISA::self_and_super_path($class));
+# Consider that reverse() is necessary because with
+# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist');
+# $foo{'a'} is 'foist', not 'wun'.
+
+###########################################################################
+sub super_path {
+ my @ret = &self_and_super_path(@_);
+ shift @ret if @ret;
+ return @ret;
+}
+
+#--------------------------------------------------------------------------
+sub self_and_super_path {
+ # Assumption: searching is depth-first.
+ # Assumption: '' (empty string) can't be a class package name.
+ # Note: 'UNIVERSAL' is not given any special treatment.
+ return () unless @_;
+
+ my @out = ();
+
+ my @in_stack = ($_[0]);
+ my %seen = ($_[0] => 1);
+
+ my $current;
+ while(@in_stack) {
+ next unless defined($current = shift @in_stack) && length($current);
+ print "At $current\n" if $Debug;
+ push @out, $current;
+ no strict 'refs';
+ unshift @in_stack,
+ map
+ { my $c = $_; # copy, to avoid being destructive
+ substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
+ # Canonize the :: -> main::, ::foo -> main::foo thing.
+ # Should I ever canonize the Foo'Bar = Foo::Bar thing?
+ $seen{$c}++ ? () : $c;
+ }
+ @{"$current\::ISA"}
+ ;
+ # I.e., if this class has any parents (at least, ones I've never seen
+ # before), push them, in order, onto the stack of classes I need to
+ # explore.
+ }
+
+ return @out;
+}
+#--------------------------------------------------------------------------
+1;
+
+__END__
+
+=head1 NAME
+
+Class::ISA - report the search path for a class's ISA tree
+
+=head1 SYNOPSIS
+
+ # Suppose you go: use Food::Fishstick, and that uses and
+ # inherits from other things, which in turn use and inherit
+ # from other things. And suppose, for sake of brevity of
+ # example, that their ISA tree is the same as:
+
+ @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
+ @Food::Fish::ISA = qw(Food);
+ @Food::ISA = qw(Matter);
+ @Life::Fungus::ISA = qw(Life);
+ @Chemicals::ISA = qw(Matter);
+ @Life::ISA = qw(Matter);
+ @Matter::ISA = qw();
+
+ use Class::ISA;
+ print "Food::Fishstick path is:\n ",
+ join(", ", Class::ISA::super_path('Food::Fishstick')),
+ "\n";
+
+That prints:
+
+ Food::Fishstick path is:
+ Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals
+
+=head1 DESCRIPTION
+
+Suppose you have a class (like Food::Fish::Fishstick) that is derived,
+via its @ISA, from one or more superclasses (as Food::Fish::Fishstick
+is from Food::Fish, Life::Fungus, and Chemicals), and some of those
+superclasses may themselves each be derived, via its @ISA, from one or
+more superclasses (as above).
+
+When, then, you call a method in that class ($fishstick->calories),
+Perl first searches there for that method, but if it's not there, it
+goes searching in its superclasses, and so on, in a depth-first (or
+maybe "height-first" is the word) search. In the above example, it'd
+first look in Food::Fish, then Food, then Matter, then Life::Fungus,
+then Life, then Chemicals.
+
+This library, Class::ISA, provides functions that return that list --
+the list (in order) of names of classes Perl would search to find a
+method, with no duplicates.
+
+=head1 FUNCTIONS
+
+=over
+
+=item the function Class::ISA::super_path($CLASS)
+
+This returns the ordered list of names of classes that Perl would
+search thru in order to find a method, with no duplicates in the list.
+$CLASS is not included in the list. UNIVERSAL is not included -- if
+you need to consider it, add it to the end.
+
+
+=item the function Class::ISA::self_and_super_path($CLASS)
+
+Just like C<super_path>, except that $CLASS is included as the first
+element.
+
+=item the function Class::ISA::self_and_super_versions($CLASS)
+
+This returns a hash whose keys are $CLASS and its
+(super-)superclasses, and whose values are the contents of each
+class's $VERSION (or undef, for classes with no $VERSION).
+
+The code for self_and_super_versions is meant to serve as an example
+for precisely the kind of tasks I anticipate that self_and_super_path
+and super_path will be used for. You are strongly advised to read the
+source for self_and_super_versions, and the comments there.
+
+=back
+
+=head1 CAUTIONARY NOTES
+
+* Class::ISA doesn't export anything. You have to address the
+functions with a "Class::ISA::" on the front.
+
+* Contrary to its name, Class::ISA isn't a class; it's just a package.
+Strange, isn't it?
+
+* Say you have a loop in the ISA tree of the class you're calling one
+of the Class::ISA functions on: say that Food inherits from Matter,
+but Matter inherits from Food (for sake of argument). If Perl, while
+searching for a method, actually discovers this cyclicity, it will
+throw a fatal error. The functions in Class::ISA effectively ignore
+this cyclicity; the Class::ISA algorithm is "never go down the same
+path twice", and cyclicities are just a special case of that.
+
+* The Class::ISA functions just look at @ISAs. But theoretically, I
+suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and
+do whatever they please. That would be bad behavior, tho; and I try
+not to think about that.
+
+* If Perl can't find a method anywhere in the ISA tree, it then looks
+in the magical class UNIVERSAL. This is rarely relevant to the tasks
+that I expect Class::ISA functions to be put to, but if it matters to
+you, then instead of this:
+
+ @supers = Class::Tree::super_path($class);
+
+do this:
+
+ @supers = (Class::Tree::super_path($class), 'UNIVERSAL');
+
+And don't say no-one ever told ya!
+
+* When you call them, the Class::ISA functions look at @ISAs anew --
+that is, there is no memoization, and so if ISAs change during
+runtime, you get the current ISA tree's path, not anything memoized.
+However, changing ISAs at runtime is probably a sign that you're out
+of your mind!
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 1999-2009 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=head1 MAINTAINER
+
+Maintained by Steffen Mueller C<smueller@cpan.org>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Class/Loader.pm b/Master/tlpkg/tlperl.straw/lib/Class/Loader.pm
new file mode 100755
index 00000000000..ccb7251dab9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Class/Loader.pm
@@ -0,0 +1,221 @@
+#!/usr/bin/perl -sw
+##
+## Class::Loader
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: Loader.pm,v 2.2 2001/07/18 20:21:39 vipul Exp $
+
+package Class::Loader;
+use Data::Dumper;
+use vars qw($VERSION);
+
+($VERSION) = '$Revision: 2.03 $' =~ /\s(\d+\.\d+)\s/;
+my %MAPS = ();
+
+sub new {
+ return bless {}, shift;
+}
+
+
+sub _load {
+
+ my ($self, $field, @source) = @_;
+ if ((scalar @source) % 2) {
+ unshift @source, $field;
+ $field = ""
+ }
+
+ local ($name, $module, $constructor, $args);
+ my %source = @source;
+ my $class = ref $self || $self;
+ my $object;
+
+ for (keys %source) { ${lc($_)} = $source{$_} }
+
+ if ($name) {
+ my $classmap = $self->_retrmap ($class) || return;
+ my $map = $$classmap{$name} || return;
+ for (keys %$map) { ${lc($_)} = $$map{$_} };
+ }
+
+ if ($module) {
+ unless (eval "require $module") {
+ if ($source{CPAN}) {
+ require CPAN; CPAN->import;
+ my $obj = CPAN::Shell->expand ('Module', $module);
+ return unless $obj;
+ $obj->install;
+ eval "require $module" || return;
+ } else { return }
+ }
+ $constructor ||= 'new';
+ if ($args) {
+ my $topass = __prepare_args ($args);
+ $object = eval "$module->$constructor($topass)" or return;
+ undef $topass; undef $args;
+ } else { $object = eval "$module->$constructor" or return }
+ } else { return }
+
+ return $field ? $$self{$field} = $object : $object
+
+}
+
+
+sub _storemap {
+ my ($self, %map) = @_;
+ my $class = ref $self;
+ for (keys %map) { $MAPS{$class}{$_} = $map{$_} }
+}
+
+
+sub _retrmap {
+ my ($self) = @_;
+ my $class = ref $self;
+ return $MAPS{$class} if $MAPS{$class};
+ return;
+}
+
+
+sub __prepare_args {
+
+ my $topass = Dumper shift;
+ $topass =~ s/\$VAR1 = \[//;
+ $topass =~ s/];\s*//g;
+ $topass =~ m/(.*)/s;
+ $topass = $1;
+ return $topass;
+
+}
+
+1;
+
+=head1 NAME
+
+Class::Loader - Load modules and create objects on demand.
+
+=head1 VERSION
+
+ $Revision: 2.2 $
+ $Date: 2001/07/18 20:21:39 $
+
+=head1 SYNOPSIS
+
+ package Web::Server;
+ use Class::Loader;
+ @ISA = qw(Class::Loader);
+
+ $self->_load( 'Content_Handler', {
+ Module => "Filter::URL",
+ Constructor => "new",
+ Args => [ ],
+ }
+ );
+
+
+=head1 DESCRIPTION
+
+Certain applications like to defer the decision to use a particular module
+till runtime. This is possible in perl, and is a useful trick in
+situations where the type of data is not known at compile time and the
+application doesn't wish to pre-compile modules to handle all types of
+data it can work with. Loading modules at runtime can also provide
+flexible interfaces for perl modules. Modules can let the programmer
+decide what modules will be used by it instead of hard-coding their names.
+
+Class::Loader is an inheritable class that provides a method, _load(),
+to load a module from disk and construct an object by calling its
+constructor. It also provides a way to map modules names and
+associated metadata with symbolic names that can be used in place of
+module names at _load().
+
+=head1 METHODS
+
+=over 4
+
+=item B<new()>
+
+A basic constructor. You can use this to create an object of
+Class::Loader, in case you don't want to inherit Class::Loader.
+
+=item B<_load()>
+
+_load() loads a module and calls its constructor. It returns the newly
+constructed object on success or a non-true value on failure. The first
+argument can be the name of the key in which the returned object is
+stored. This argument is optional. The second (or the first) argument is a
+hash which can take the following keys:
+
+=over 4
+
+=item B<Module>
+
+This is name of the class to load. (It is not the module's filename.)
+
+=item B<Name>
+
+Symbolic name of the module defined with _storemap(). Either one of Module
+or Name keys must be present in a call to _load().
+
+=item B<Constructor>
+
+Name of the Module constructor. Defaults to "new".
+
+=item B<Args>
+
+A reference to the list of arguments for the constructor. _load() calls
+the constructor with this list. If no Args are present, _load() will call
+the constructor without any arguments.
+
+=item B<CPAN>
+
+If the Module is not installed on the local system, _load() can fetch &
+install it from CPAN provided the CPAN key is present. This functionality
+assumes availability of a pre-configured CPAN shell.
+
+=back
+
+=item B<_storemap()>
+
+Class::Loader maintains a class table that maps symbolic names to
+parameters accepted by _load(). It takes a hash as argument whose keys are
+symbolic names and value are hash references that contain a set of _load()
+arguments. Here's an example:
+
+ $self->_storemap ( "URL" => { Module => "Filter::URL",
+ Constructor => "foo",
+ Args => [qw(bar baz)],
+ }
+ );
+
+ # time passes...
+
+ $self->{handler} = $self->_load ( Name => 'URL' );
+
+=item B<_retrmap()>
+
+_retrmap() returns the entire map stored with Class::Loader. Class::Loader
+maintains separate maps for different classes, and _retrmap() returns the
+map valid in the caller class.
+
+=back
+
+=head1 SEE ALSO
+
+AnyLoader(3)
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
+
+=head1 LICENSE
+
+Copyright (c) 2001, Vipul Ved Prakash. All rights reserved. This code 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.straw/lib/Class/LoaderTest.pm b/Master/tlpkg/tlperl.straw/lib/Class/LoaderTest.pm
new file mode 100755
index 00000000000..0bebe321587
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Class/LoaderTest.pm
@@ -0,0 +1,41 @@
+#!/usr/bin/perl -sw
+##
+##
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: LoaderTest.pm,v 1.2 2001/05/01 00:09:12 vipul Exp $
+
+package Class::LoaderTest;
+use Data::Dumper;
+
+sub new {
+
+ my $self = { Method => 'new' };
+ return bless $self, shift;
+
+}
+
+
+sub foo {
+
+ my ($class, $embed) = @_;
+ $embed ||= 'foo';
+ my $self = { Method => $embed };
+ return bless $self, shift;
+
+}
+
+sub blah {
+
+ my ($class, %params) = @_;
+ my $self = { %params };
+ return bless $self, $class;
+
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Class/Struct.pm b/Master/tlpkg/tlperl.straw/lib/Class/Struct.pm
new file mode 100755
index 00000000000..7a9af54faf8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Class/Struct.pm
@@ -0,0 +1,636 @@
+package Class::Struct;
+
+## See POD after __END__
+
+use 5.006_001;
+
+use strict;
+use warnings::register;
+our(@ISA, @EXPORT, $VERSION);
+
+use Carp;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(struct);
+
+$VERSION = '0.63';
+
+## Tested on 5.002 and 5.003 without class membership tests:
+my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
+
+my $print = 0;
+sub printem {
+ if (@_) { $print = shift }
+ else { $print++ }
+}
+
+{
+ package Class::Struct::Tie_ISA;
+
+ sub TIEARRAY {
+ my $class = shift;
+ return bless [], $class;
+ }
+
+ sub STORE {
+ my ($self, $index, $value) = @_;
+ Class::Struct::_subclass_error();
+ }
+
+ sub FETCH {
+ my ($self, $index) = @_;
+ $self->[$index];
+ }
+
+ sub FETCHSIZE {
+ my $self = shift;
+ return scalar(@$self);
+ }
+
+ sub DESTROY { }
+}
+
+sub import {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ $self->export_to_level( 1, $self, @EXPORT );
+ } elsif ( @_ == 1 ) {
+ # This is admittedly a little bit silly:
+ # do we ever export anything else than 'struct'...?
+ $self->export_to_level( 1, $self, @_ );
+ } else {
+ goto &struct;
+ }
+}
+
+sub struct {
+
+ # Determine parameter list structure, one of:
+ # struct( class => [ element-list ])
+ # struct( class => { element-list })
+ # struct( element-list )
+ # Latter form assumes current package name as struct name.
+
+ my ($class, @decls);
+ my $base_type = ref $_[1];
+ if ( $base_type eq 'HASH' ) {
+ $class = shift;
+ @decls = %{shift()};
+ _usage_error() if @_;
+ }
+ elsif ( $base_type eq 'ARRAY' ) {
+ $class = shift;
+ @decls = @{shift()};
+ _usage_error() if @_;
+ }
+ else {
+ $base_type = 'ARRAY';
+ $class = (caller())[0];
+ @decls = @_;
+ }
+
+ _usage_error() if @decls % 2 == 1;
+
+ # Ensure we are not, and will not be, a subclass.
+
+ my $isa = do {
+ no strict 'refs';
+ \@{$class . '::ISA'};
+ };
+ _subclass_error() if @$isa;
+ tie @$isa, 'Class::Struct::Tie_ISA';
+
+ # Create constructor.
+
+ croak "function 'new' already defined in package $class"
+ if do { no strict 'refs'; defined &{$class . "::new"} };
+
+ my @methods = ();
+ my %refs = ();
+ my %arrays = ();
+ my %hashes = ();
+ my %classes = ();
+ my $got_class = 0;
+ my $out = '';
+
+ $out = "{\n package $class;\n use Carp;\n sub new {\n";
+ $out .= " my (\$class, \%init) = \@_;\n";
+ $out .= " \$class = __PACKAGE__ unless \@_;\n";
+
+ my $cnt = 0;
+ my $idx = 0;
+ my( $cmt, $name, $type, $elem );
+
+ if( $base_type eq 'HASH' ){
+ $out .= " my(\$r) = {};\n";
+ $cmt = '';
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $out .= " my(\$r) = [];\n";
+ }
+ while( $idx < @decls ){
+ $name = $decls[$idx];
+ $type = $decls[$idx+1];
+ push( @methods, $name );
+ if( $base_type eq 'HASH' ){
+ $elem = "{'${class}::$name'}";
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ $cmt = " # $name";
+ }
+ if( $type =~ /^\*(.)/ ){
+ $refs{$name}++;
+ $type = $1;
+ }
+ my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
+ if( $type eq '@' ){
+ $out .= " croak 'Initializer for $name must be array reference'\n";
+ $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
+ $out .= " \$r->$elem = $init [];$cmt\n";
+ $arrays{$name}++;
+ }
+ elsif( $type eq '%' ){
+ $out .= " croak 'Initializer for $name must be hash reference'\n";
+ $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
+ $out .= " \$r->$elem = $init {};$cmt\n";
+ $hashes{$name}++;
+ }
+ elsif ( $type eq '$') {
+ $out .= " \$r->$elem = $init undef;$cmt\n";
+ }
+ elsif( $type =~ /^\w+(?:::\w+)*$/ ){
+ $out .= " if (defined(\$init{'$name'})) {\n";
+ $out .= " if (ref \$init{'$name'} eq 'HASH')\n";
+ $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n";
+ $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
+ $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n";
+ $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
+ $out .= " }\n";
+ $classes{$name} = $type;
+ $got_class = 1;
+ }
+ else{
+ croak "'$type' is not a valid struct element type";
+ }
+ $idx += 2;
+ }
+ $out .= " bless \$r, \$class;\n }\n";
+
+ # Create accessor methods.
+
+ my( $pre, $pst, $sel );
+ $cnt = 0;
+ foreach $name (@methods){
+ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
+ warnings::warnif("function '$name' already defined, overrides struct accessor method");
+ }
+ else {
+ $pre = $pst = $cmt = $sel = '';
+ if( defined $refs{$name} ){
+ $pre = "\\(";
+ $pst = ")";
+ $cmt = " # returns ref";
+ }
+ $out .= " sub $name {$cmt\n my \$r = shift;\n";
+ if( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ }
+ elsif( $base_type eq 'HASH' ){
+ $elem = "{'${class}::$name'}";
+ }
+ if( defined $arrays{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
+ $sel = "->[\$i]";
+ }
+ elsif( defined $hashes{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
+ $sel = "->{\$i}";
+ }
+ elsif( defined $classes{$name} ){
+ if ( $CHECK_CLASS_MEMBERSHIP ) {
+ $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
+ }
+ }
+ $out .= " croak 'Too many args to $name' if \@_ > 1;\n";
+ $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
+ $out .= " }\n";
+ }
+ }
+ $out .= "}\n1;\n";
+
+ print $out if $print;
+ my $result = eval $out;
+ carp $@ if $@;
+}
+
+sub _usage_error {
+ confess "struct usage error";
+}
+
+sub _subclass_error {
+ croak 'struct class cannot be a subclass (@ISA not allowed)';
+}
+
+1; # for require
+
+
+__END__
+
+=head1 NAME
+
+Class::Struct - declare struct-like datatypes as Perl classes
+
+=head1 SYNOPSIS
+
+ use Class::Struct;
+ # declare struct, based on array:
+ struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
+ # declare struct, based on hash:
+ struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
+
+ package CLASS_NAME;
+ use Class::Struct;
+ # declare struct, based on array, implicit class name:
+ struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
+
+ # Declare struct at compile time
+ use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ];
+ use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... };
+
+ # declare struct at compile time, based on array, implicit class name:
+ package CLASS_NAME;
+ use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ;
+
+ package Myobj;
+ use Class::Struct;
+ # declare struct with four types of elements:
+ struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
+
+ $obj = new Myobj; # constructor
+
+ # scalar type accessor:
+ $element_value = $obj->s; # element value
+ $obj->s('new value'); # assign to element
+
+ # array type accessor:
+ $ary_ref = $obj->a; # reference to whole array
+ $ary_element_value = $obj->a(2); # array element value
+ $obj->a(2, 'new value'); # assign to array element
+
+ # hash type accessor:
+ $hash_ref = $obj->h; # reference to whole hash
+ $hash_element_value = $obj->h('x'); # hash element value
+ $obj->h('x', 'new value'); # assign to hash element
+
+ # class type accessor:
+ $element_value = $obj->c; # object reference
+ $obj->c->method(...); # call method of object
+ $obj->c(new My_Other_Class); # assign a new object
+
+=head1 DESCRIPTION
+
+C<Class::Struct> exports a single function, C<struct>.
+Given a list of element names and types, and optionally
+a class name, C<struct> creates a Perl 5 class that implements
+a "struct-like" data structure.
+
+The new class is given a constructor method, C<new>, for creating
+struct objects.
+
+Each element in the struct data has an accessor method, which is
+used to assign to the element and to fetch its value. The
+default accessor can be overridden by declaring a C<sub> of the
+same name in the package. (See Example 2.)
+
+Each element's type can be scalar, array, hash, or class.
+
+=head2 The C<struct()> function
+
+The C<struct> function has three forms of parameter-list.
+
+ struct( CLASS_NAME => [ ELEMENT_LIST ]);
+ struct( CLASS_NAME => { ELEMENT_LIST });
+ struct( ELEMENT_LIST );
+
+The first and second forms explicitly identify the name of the
+class being created. The third form assumes the current package
+name as the class name.
+
+An object of a class created by the first and third forms is
+based on an array, whereas an object of a class created by the
+second form is based on a hash. The array-based forms will be
+somewhat faster and smaller; the hash-based forms are more
+flexible.
+
+The class created by C<struct> must not be a subclass of another
+class other than C<UNIVERSAL>.
+
+It can, however, be used as a superclass for other classes. To facilitate
+this, the generated constructor method uses a two-argument blessing.
+Furthermore, if the class is hash-based, the key of each element is
+prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
+
+A function named C<new> must not be explicitly defined in a class
+created by C<struct>.
+
+The I<ELEMENT_LIST> has the form
+
+ NAME => TYPE, ...
+
+Each name-type pair declares one element of the struct. Each
+element name will be defined as an accessor method unless a
+method by that name is explicitly defined; in the latter case, a
+warning is issued if the warning flag (B<-w>) is set.
+
+=head2 Class Creation at Compile Time
+
+C<Class::Struct> can create your class at compile time. The main reason
+for doing this is obvious, so your class acts like every other class in
+Perl. Creating your class at compile time will make the order of events
+similar to using any other class ( or Perl module ).
+
+There is no significant speed gain between compile time and run time
+class creation, there is just a new, more standard order of events.
+
+=head2 Element Types and Accessor Methods
+
+The four element types -- scalar, array, hash, and class -- are
+represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
+optionally preceded by a C<'*'>.
+
+The accessor method provided by C<struct> for an element depends
+on the declared type of the element.
+
+=over 4
+
+=item Scalar (C<'$'> or C<'*$'>)
+
+The element is a scalar, and by default is initialized to C<undef>
+(but see L<Initializing with new>).
+
+The accessor's argument, if any, is assigned to the element.
+
+If the element type is C<'$'>, the value of the element (after
+assignment) is returned. If the element type is C<'*$'>, a reference
+to the element is returned.
+
+=item Array (C<'@'> or C<'*@'>)
+
+The element is an array, initialized by default to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole array (whether or not the element was
+specified as C<'@'> or C<'*@'>).
+
+With one or two arguments, the first argument is an index
+specifying one element of the array; the second argument, if
+present, is assigned to the array element. If the element type
+is C<'@'>, the accessor returns the array element value. If the
+element type is C<'*@'>, a reference to the array element is
+returned.
+
+As a special case, when the accessor is called with an array reference
+as the sole argument, this causes an assignment of the whole array element.
+The object reference is returned.
+
+=item Hash (C<'%'> or C<'*%'>)
+
+The element is a hash, initialized by default to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole hash (whether or not the element was
+specified as C<'%'> or C<'*%'>).
+
+With one or two arguments, the first argument is a key specifying
+one element of the hash; the second argument, if present, is
+assigned to the hash element. If the element type is C<'%'>, the
+accessor returns the hash element value. If the element type is
+C<'*%'>, a reference to the hash element is returned.
+
+As a special case, when the accessor is called with a hash reference
+as the sole argument, this causes an assignment of the whole hash element.
+The object reference is returned.
+
+=item Class (C<'Class_Name'> or C<'*Class_Name'>)
+
+The element's value must be a reference blessed to the named
+class or to one of its subclasses. The element is not initialized
+by default.
+
+The accessor's argument, if any, is assigned to the element. The
+accessor will C<croak> if this is not an appropriate object
+reference.
+
+If the element type does not start with a C<'*'>, the accessor
+returns the element value (after assignment). If the element type
+starts with a C<'*'>, a reference to the element itself is returned.
+
+=back
+
+=head2 Initializing with C<new>
+
+C<struct> always creates a constructor called C<new>. That constructor
+may take a list of initializers for the various elements of the new
+struct.
+
+Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>.
+The initializer value for a scalar element is just a scalar value. The
+initializer for an array element is an array reference. The initializer
+for a hash is a hash reference.
+
+The initializer for a class element is an object of the corresponding class,
+or of one of it's subclasses, or a reference to a hash containing named
+arguments to be passed to the element's constructor.
+
+See Example 3 below for an example of initialization.
+
+=head1 EXAMPLES
+
+=over 4
+
+=item Example 1
+
+Giving a struct element a class type that is also a struct is how
+structs are nested. Here, C<Timeval> represents a time (seconds and
+microseconds), and C<Rusage> has two elements, each of which is of
+type C<Timeval>.
+
+ use Class::Struct;
+
+ struct( Rusage => {
+ ru_utime => 'Timeval', # user time used
+ ru_stime => 'Timeval', # system time used
+ });
+
+ struct( Timeval => [
+ tv_secs => '$', # seconds
+ tv_usecs => '$', # microseconds
+ ]);
+
+ # create an object:
+ my $t = Rusage->new(ru_utime=>Timeval->new(), ru_stime=>Timeval->new());
+
+ # $t->ru_utime and $t->ru_stime are objects of type Timeval.
+ # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec.
+ $t->ru_utime->tv_secs(100);
+ $t->ru_utime->tv_usecs(0);
+ $t->ru_stime->tv_secs(5);
+ $t->ru_stime->tv_usecs(0);
+
+=item Example 2
+
+An accessor function can be redefined in order to provide
+additional checking of values, etc. Here, we want the C<count>
+element always to be nonnegative, so we redefine the C<count>
+accessor accordingly.
+
+ package MyObj;
+ use Class::Struct;
+
+ # declare the struct
+ struct ( 'MyObj', { count => '$', stuff => '%' } );
+
+ # override the default accessor method for 'count'
+ sub count {
+ my $self = shift;
+ if ( @_ ) {
+ die 'count must be nonnegative' if $_[0] < 0;
+ $self->{'MyObj::count'} = shift;
+ warn "Too many args to count" if @_;
+ }
+ return $self->{'MyObj::count'};
+ }
+
+ package main;
+ $x = new MyObj;
+ print "\$x->count(5) = ", $x->count(5), "\n";
+ # prints '$x->count(5) = 5'
+
+ print "\$x->count = ", $x->count, "\n";
+ # prints '$x->count = 5'
+
+ print "\$x->count(-5) = ", $x->count(-5), "\n";
+ # dies due to negative argument!
+
+=item Example 3
+
+The constructor of a generated class can be passed a list
+of I<element>=>I<value> pairs, with which to initialize the struct.
+If no initializer is specified for a particular element, its default
+initialization is performed instead. Initializers for non-existent
+elements are silently ignored.
+
+Note that the initializer for a nested class may be specified as
+an object of that class, or as a reference to a hash of initializers
+that are passed on to the nested struct's constructor.
+
+ use Class::Struct;
+
+ struct Breed =>
+ {
+ name => '$',
+ cross => '$',
+ };
+
+ struct Cat =>
+ [
+ name => '$',
+ kittens => '@',
+ markings => '%',
+ breed => 'Breed',
+ ];
+
+
+ my $cat = Cat->new( name => 'Socks',
+ kittens => ['Monica', 'Kenneth'],
+ markings => { socks=>1, blaze=>"white" },
+ breed => Breed->new(name=>'short-hair', cross=>1),
+ or: breed => {name=>'short-hair', cross=>1},
+ );
+
+ print "Once a cat called ", $cat->name, "\n";
+ print "(which was a ", $cat->breed->name, ")\n";
+ print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";
+
+=back
+
+=head1 Author and Modification History
+
+Modified by Damian Conway, 2001-09-10, v0.62.
+
+ Modified implicit construction of nested objects.
+ Now will also take an object ref instead of requiring a hash ref.
+ Also default initializes nested object attributes to undef, rather
+ than calling object constructor without args
+ Original over-helpfulness was fraught with problems:
+ * the class's constructor might not be called 'new'
+ * the class might not have a hash-like-arguments constructor
+ * the class might not have a no-argument constructor
+ * "recursive" data structures didn't work well:
+ package Person;
+ struct { mother => 'Person', father => 'Person'};
+
+
+Modified by Casey West, 2000-11-08, v0.59.
+
+ Added the ability for compile time class creation.
+
+Modified by Damian Conway, 1999-03-05, v0.58.
+
+ Added handling of hash-like arg list to class ctor.
+
+ Changed to two-argument blessing in ctor to support
+ derivation from created classes.
+
+ Added classname prefixes to keys in hash-based classes
+ (refer to "Perl Cookbook", Recipe 13.12 for rationale).
+
+ Corrected behaviour of accessors for '*@' and '*%' struct
+ elements. Package now implements documented behaviour when
+ returning a reference to an entire hash or array element.
+ Previously these were returned as a reference to a reference
+ to the element.
+
+Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
+
+ members() function removed.
+ Documentation corrected and extended.
+ Use of struct() in a subclass prohibited.
+ User definition of accessor allowed.
+ Treatment of '*' in element types corrected.
+ Treatment of classes as element types corrected.
+ Class name to struct() made optional.
+ Diagnostic checks added.
+
+Originally C<Class::Template> by Dean Roehrich.
+
+ # Template.pm --- struct/member template builder
+ # 12mar95
+ # Dean Roehrich
+ #
+ # changes/bugs fixed since 28nov94 version:
+ # - podified
+ # changes/bugs fixed since 21nov94 version:
+ # - Fixed examples.
+ # changes/bugs fixed since 02sep94 version:
+ # - Moved to Class::Template.
+ # changes/bugs fixed since 20feb94 version:
+ # - Updated to be a more proper module.
+ # - Added "use strict".
+ # - Bug in build_methods, was using @var when @$var needed.
+ # - Now using my() rather than local().
+ #
+ # Uses perl5 classes to create nested data types.
+ # This is offered as one implementation of Tom Christiansen's "structs.pl"
+ # idea.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Config.pm b/Master/tlpkg/tlperl.straw/lib/Config.pm
new file mode 100755
index 00000000000..1759bffb8f5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Config.pm
@@ -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.10.1) doesn't match executable version ($])"
+ unless $^V;
+
+$^V eq 5.10.1
+ or die "Perl lib version (5.10.1) 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:\\strawberry\\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 => 'C:\\strawberry\\c\\lib',
+ osname => 'MSWin32',
+ osvers => '5.1',
+ path_sep => ';',
+ privlibexp => 'C:\\strawberry\\perl\\lib',
+ scriptdir => 'C:\\strawberry\\perl\\bin',
+ sitearchexp => 'C:\\strawberry\\perl\\site\\lib',
+ sitelibexp => 'C:\\strawberry\\perl\\site\\lib',
+ useithreads => 'define',
+ usevendorprefix => 'define',
+ version => '5.10.1',
+};
diff --git a/Master/tlpkg/tlperl.straw/lib/Config.pod b/Master/tlpkg/tlperl.straw/lib/Config.pod
new file mode 100755
index 00000000000..cdafa7e133d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Config.pod
@@ -0,0 +1,8824 @@
+=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<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<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<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<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.straw/lib/Config_heavy.pl b/Master/tlpkg/tlperl.straw/lib/Config_heavy.pl
new file mode 100755
index 00000000000..f8661df17f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Config_heavy.pl
@@ -0,0 +1,1274 @@
+# 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
+### Configured by: win32-vanilla@perl.org
+### 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='10'
+PERL_API_REVISION='5'
+PERL_API_SUBVERSION='0'
+PERL_API_VERSION='10'
+PERL_CONFIG_SH='true'
+PERL_PATCHLEVEL=''
+PERL_REVISION='5'
+PERL_SUBVERSION='1'
+PERL_VERSION='10'
+RCSfile='$RCSfile'
+Revision='$Revision'
+SUBVERSION='1'
+Source=''
+State=''
+_a='.a'
+_exe='.exe'
+_o='.o'
+afs='false'
+afsroot='/afs'
+alignbytes='8'
+ansi2knr=''
+aphostname=''
+api_revision='5'
+api_subversion='0'
+api_version='10'
+api_versionstring='5.10.0'
+ar='ar'
+archlib='C:\strawberry\perl\lib'
+archlibexp='C:\strawberry\perl\lib'
+archname64=''
+archname='MSWin32-x86-multi-thread'
+archobjs=''
+asctime_r_proto='0'
+awk='awk'
+baserev='5'
+bash=''
+bin='C:\strawberry\perl\bin'
+binexp='C:\strawberry\perl\bin'
+bison=''
+byacc='byacc'
+byteorder='1234'
+c=''
+castflags='0'
+cat='type'
+cc='gcc'
+cccdlflags=' '
+ccdlflags=' '
+ccflags=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DUSE_SITECUSTOMIZE -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -fno-strict-aliasing -DPERL_MSVCRT_READFIX'
+ccflags_uselargefiles=''
+ccname='gcc'
+ccsymbols=''
+ccversion=''
+cf_by='1'
+cf_email='win32-vanilla@perl.org'
+cf_time='Wed Jan 27 23:29:27 2010'
+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='define'
+d_vendorbin='define'
+d_vendorlib='define'
+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 GDBM_File Hash/Util Hash/Util/FieldHash IO 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/Typemap attrs 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='Attribute/Handlers B Compress/Raw/Bzip2 Compress/Raw/Zlib Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Digest/SHA Encode Errno Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util Hash/Util/FieldHash IO IO/Compress List/Util MIME/Base64 Math/BigInt/FastCalc Module/Pluggable Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Safe Socket Storable Sys/Hostname Test/Harness Text/Soundex Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/Typemap attrs mro 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='3.4.5'
+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='define'
+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='C:\strawberry\c\include'
+inews=''
+initialinstalllocation=''
+installarchlib='C:\strawberry\perl\lib'
+installbin='C:\strawberry\perl\bin'
+installhtml1dir=''
+installhtml3dir=''
+installhtmldir=''
+installhtmlhelpdir=''
+installman1dir=''
+installman3dir=''
+installprefix='C:\strawberry\perl'
+installprefixexp='C:\strawberry\perl'
+installprivlib='C:\strawberry\perl\lib'
+installscript='C:\strawberry\perl\bin'
+installsitearch='C:\strawberry\perl\site\lib'
+installsitebin='C:\strawberry\perl\bin'
+installsitehtml1dir=''
+installsitehtml3dir=''
+installsitelib='C:\strawberry\perl\site\lib'
+installsiteman1dir=''
+installsiteman3dir=''
+installsitescript=''
+installstyle='lib'
+installusrbinperl='undef'
+installvendorarch='C:\strawberry\perl\vendor\lib'
+installvendorbin='C:\strawberry\perl\bin'
+installvendorhtml1dir=''
+installvendorhtml3dir=''
+installvendorlib='C:\strawberry\perl\vendor\lib'
+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 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 Win32 Win32API/File Win32CORE XS/APItest XS/Typemap attrs mro re threads threads/shared'
+ksh=''
+ld='g++'
+lddlflags='-mdll -s -L"C:\strawberry\perl\lib\CORE" -L"C:\strawberry\c\lib"'
+ldflags='-s -L"C:\strawberry\perl\lib\CORE" -L"C:\strawberry\c\lib"'
+ldflags_uselargefiles=''
+ldlibpthname=''
+less='less'
+lib_ext='.a'
+libc=''
+libperl='libperl510.a'
+libpth='C:\strawberry\c\lib'
+libs=' -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32'
+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=''
+man1direxp=''
+man1ext='1'
+man3dir=''
+man3direxp=''
+man3ext='3'
+mips_type=''
+mistrustnm=''
+mkdir='mkdir'
+mmaptype='void *'
+modetype='mode_t'
+more='more /e'
+multiarch='undef'
+mv=''
+myarchname='MSWin32'
+mydomain=''
+myhostname=''
+myuname='Win32 strawberryperl 5.10.1.1 #1 1264655466 i386'
+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='Attribute/Handlers Errno IO/Compress List/Util Module/Pluggable Safe Test/Harness'
+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='10'
+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'
+perlpath='C:\strawberry\perl\bin\perl.exe'
+pg=''
+phostname='hostname'
+pidtype='int'
+plibpth=''
+pmake=''
+pr=''
+prefix='C:\strawberry\perl'
+prefixexp='C:\strawberry\perl'
+privlib='C:\strawberry\perl\lib'
+privlibexp='C:\strawberry\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:\strawberry\perl\bin'
+scriptdirexp='C:\strawberry\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:\strawberry\perl\site\lib'
+sitearchexp='C:\strawberry\perl\site\lib'
+sitebin='C:\strawberry\perl\site\bin'
+sitebinexp='C:\strawberry\perl\site\bin'
+sitehtml1dir=''
+sitehtml1direxp=''
+sitehtml3dir=''
+sitehtml3direxp=''
+sitelib='C:\strawberry\perl\site\lib'
+sitelib_stem=''
+sitelibexp='C:\strawberry\perl\site\lib'
+siteman1dir=''
+siteman1direxp=''
+siteman3dir=''
+siteman3direxp=''
+siteprefix='C:\strawberry\perl\site'
+siteprefixexp='C:\strawberry\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=''
+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='define'
+usesocks='undef'
+usethreads='define'
+usevendorprefix='define'
+usevfork='false'
+usrinc='C:\strawberry\c\include'
+uuname=''
+uvXUformat='"lX"'
+uvoformat='"lo"'
+uvsize='4'
+uvtype='unsigned long'
+uvuformat='"lu"'
+uvxformat='"lx"'
+vendorarch='C:\strawberry\perl\vendor\lib'
+vendorarchexp='C:\strawberry\perl\vendor\lib'
+vendorbin='C:\strawberry\perl\vendor\bin'
+vendorbinexp='C:\strawberry\perl\vendor\bin'
+vendorhtml1dir=''
+vendorhtml1direxp=''
+vendorhtml3dir=''
+vendorhtml3direxp=''
+vendorlib='C:\strawberry\perl\vendor\lib'
+vendorlib_stem=''
+vendorlibexp='C:\strawberry\perl\vendor\lib'
+vendorman1dir=''
+vendorman1direxp=''
+vendorman3dir=''
+vendorman3direxp=''
+vendorprefix='C:\strawberry\perl\vendor'
+vendorprefixexp='C:\strawberry\perl\vendor'
+vendorscript=''
+vendorscriptexp=''
+version='5.10.1'
+version_patchlevel_string='version 10 subversion 1'
+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 -DUSE_SITECUSTOMIZE -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -fno-strict-aliasing -DPERL_MSVCRT_READFIX'
+ldflags_nolargefiles='-s -L"C:\strawberry\perl\lib\CORE" -L"C:\strawberry\c\lib"'
+libs_nolargefiles='-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32'
+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.straw/lib/Convert/ASCII/Armor.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm
new file mode 100755
index 00000000000..8e78bff3238
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm
@@ -0,0 +1,37 @@
+#!/usr/bin/perl -sw
+##
+##
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: Armor.pm,v 1.1 2001/03/19 23:15:09 vipul Exp $
+
+package Convert::ASCII::Armor;
+use lib "../../../lib";
+use Convert::ASCII::Armour;
+use vars qw(@ISA);
+@ISA = qw(Convert::ASCII::Armour);
+
+1;
+
+=head1 NAME
+
+Convert::ASCII::Armor - Convert binary octets into ASCII armoured messages.
+
+=head1 SYNOPSIS
+
+See SYNOPSIS in Convert::ASCII::Armour.
+
+=head1 DESCRIPTION
+
+Empty subclass of Convert::ASCII::Armour for American English speakers.
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm
new file mode 100755
index 00000000000..b941ec11783
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm
@@ -0,0 +1,247 @@
+#!/usr/bin/perl -sw
+##
+## Convert::ASCII::Armour
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: Armour.pm,v 1.4 2001/03/19 23:15:09 vipul Exp $
+
+package Convert::ASCII::Armour;
+use strict;
+use Digest::MD5 qw(md5);
+use MIME::Base64;
+use Compress::Zlib qw(compress uncompress);
+use vars qw($VERSION);
+
+($VERSION) = '$Revision: 1.4 $' =~ /\s(\d+\.\d+)\s/;
+
+
+sub new {
+ return bless {}, shift;
+}
+
+
+sub error {
+ my ($self, $errstr) = @_;
+ $$self{errstr} = "$errstr\n";
+ return;
+}
+
+
+sub errstr {
+ my $self = shift;
+ return $$self{errstr};
+}
+
+
+sub armour {
+
+ my ($self, %params) = @_;
+
+ my $compress = $params{Compress} ? "COMPRESSED " : "";
+ return undef unless $params{Content};
+ $params{Object} = "UNKNOWN $compress DATA" unless $params{Object};
+
+ my $head = "-"x5 . "BEGIN $compress$params{Object}" . "-"x5;
+ my $tail = "-"x5 . "END $compress$params{Object}" . "-"x5;
+
+ my $content = $self->encode_content (%{$params{Content}});
+ $content = compress($content) if $compress;
+ my $checksum = encode_base64 (md5 ($content));
+ my $econtent = encode_base64 ($content);
+
+ my $eheaders = "";
+ for my $key (keys %{$params{Headers}}) {
+ $eheaders .= "$key: $params{Headers}->{$key}\n";
+ }
+
+ my $message = "$head\n$eheaders\n$econtent=$checksum$tail\n";
+ return $message;
+
+}
+
+
+sub unarmour {
+ my ($self, $message) = @_;
+
+ my ($head, $object, $headers, $content, $tail) = $message =~
+ m:(-----BEGIN ([^\n\-]+)-----)\n(.*?\n\n)?(.+)(-----END .*?-----)$:s
+ or return $self->error ("Breached Armour.");
+
+ my ($compress, $obj) = $object =~ /^(COMPRESSED )(.*)$/;
+ $object = $obj if $obj;
+ $content =~ s:=([^\n]+)$::s or return $self->error ("Breached Armour.");
+ my $checksum = $1; $content = decode_base64 ($content);
+ my $ncheck = encode_base64 (md5 ($content)); $ncheck =~ s/\n//;
+ return $self->error ("Checksum Failed.") unless $ncheck eq $checksum;
+ $content = uncompress ($content) if $compress;
+ my $dcontent = $self->decode_content ($content) || return;
+
+ my $dheaders;
+ if ($headers) {
+ my @pairs = split /\n/, $headers;
+ for (@pairs) {
+ my ($key, $value) = split /: /, $_, 2;
+ $$dheaders{$key} = $value if $key;
+ }
+ }
+
+ my %return = ( Content => $dcontent,
+ Object => $object,
+ Headers => $dheaders );
+
+ return \%return;
+
+}
+
+
+sub encode_content {
+ my ($self, %data) = @_;
+ my $encoded = "";
+
+ for my $key (keys %data) {
+ $encoded .= length ($key) . chr(0) . length ($data{$key}) .
+ chr(0) . "$key$data{$key}";
+ }
+
+ return $encoded;
+}
+
+
+sub decode_content {
+ my ($self, $content) = @_;
+ my %data;
+
+ while ($content) {
+ $content =~ s/^(\d+)\x00(\d+)\x00// ||
+ return $self->error ("Inconsistent content.");
+ my $keylen = $1; my $valuelen = $2;
+ my $key = substr $content, 0, $keylen;
+ my $value = substr $content, $keylen, $valuelen;
+ substr ($content, 0, $keylen + $valuelen) = "";
+ $data{$key} = $value;
+ }
+
+ return \%data;
+}
+
+
+sub armor { armour (@_) }
+sub unarmor { unarmour (@_) }
+
+
+1;
+
+
+=head1 NAME
+
+Convert::ASCII::Armour - Convert binary octets into ASCII armoured messages.
+
+=head1 SYNOPSIS
+
+ my $converter = new Convert::ASCII::Armour;
+
+ my $message = $converter->armour(
+ Object => "FOO RECORD",
+ Headers => {
+ Table => "FooBar",
+ Version => "1.23",
+ },
+ Content => {
+ Key => "0x8738FA7382",
+ Name => "Zoya Hall",
+ Pic => "....", # gif
+ },
+ Compress => 1,
+ );
+
+ print $message;
+
+
+ -----BEGIN COMPRESSED FOO RECORD-----
+ Version: 1.23
+ Table: FooBar
+
+ eJwzZzA0Z/BNLS5OTE8NycgsVgCiRIVciIAJg6EJg0tiSaqhsYJvYlFy...
+ XnpOZl5qYlJySmpaekZmVnZObl5+QWFRcUlpWXlFZRWXAk7g6OTs4urm...
+ Fh4VGaWAR5ehkbGJqZm5hSUeNXWKDsoGcWpaGpq68bba0dWxtTVmDOYM...
+ NzuZ
+ =MxpZvjkrv5XyhkVCuXmsBQ==
+ -----END COMPRESSED FOO RECORD-----
+
+
+ my $decoded = $converter->unarmour( $message )
+ || die $converter->errstr();
+
+
+=head1 DESCRIPTION
+
+This module converts hashes of binary octets into ASCII messages suitable
+for transfer over 6-bit clean transport channels. The encoded ASCII
+resembles PGP's armoured messages, but are in no way compatible with PGP.
+
+=head1 METHODS
+
+=head2 B<new()>
+
+Constructor.
+
+=head2 B<armour()>
+
+Converts a hash of binary octets into an ASCII encoded message. The
+encoded message has 4 parts: head and tail strings that act as identifiers
+and delimiters, a cluster of headers at top of the message, Base64 encoded
+message body and a Base64 encoded MD5 digest of the message body. armour()
+takes a hash as argument with following keys:
+
+=over 4
+
+=item B<Object>
+
+An identification string embedded in head and tail strings.
+
+=item B<Content>
+
+Content is a hashref that contains the binary octets to be encoded. This
+hash is serialized, compressed (if specified) and encoded into ASCII with
+MIME::Base64. The result is the body of the encoded message.
+
+=item B<Headers>
+
+Headers is a hashref that contains ASCII headers that are placed at top of
+the encoded message. Headers are encoded as RFC822 headers.
+
+=item B<Compress>
+
+A boolean parameter that forces armour() to compress the message body.
+
+=back
+
+=head2 B<unarmour()>
+
+Decodes an armoured ASCII message into the hash provided as argument
+to armour(). The hash contains Content, Object, and Headers.
+unarmour() performs several consistency checks and returns a non-true
+value on failure.
+
+=head2 B<errstr()>
+
+Returns the error message set by unarmour() on failure.
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
+
+=head1 LICENSE
+
+Copyright (c) 2001, Vipul Ved Prakash. All rights reserved. This code is
+free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+=head1 SEE ALSO
+
+MIME::Base64(3), Compress::Zlib(3), Digest::MD5(3)
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pm
new file mode 100755
index 00000000000..71a599dbd1b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pm
@@ -0,0 +1,444 @@
+# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Convert::ASN1;
+
+# $Id: ASN1.pm,v 1.29 2003/10/08 14:29:17 gbarr Exp $
+
+use 5.004;
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
+use Exporter;
+
+use constant CHECK_UTF8 => $] > 5.007;
+
+BEGIN {
+ local $SIG{__DIE__};
+ eval { require bytes and 'bytes'->import };
+
+ if (CHECK_UTF8) {
+ require Encode;
+ require utf8;
+ }
+
+ @ISA = qw(Exporter);
+ $VERSION = "0.22";
+
+ %EXPORT_TAGS = (
+ io => [qw(asn_recv asn_send asn_read asn_write asn_get asn_ready)],
+
+ debug => [qw(asn_dump asn_hexdump)],
+
+ const => [qw(ASN_BOOLEAN ASN_INTEGER ASN_BIT_STR ASN_OCTET_STR
+ ASN_NULL ASN_OBJECT_ID ASN_REAL ASN_ENUMERATED
+ ASN_SEQUENCE ASN_SET ASN_PRINT_STR ASN_IA5_STR
+ ASN_UTC_TIME ASN_GENERAL_TIME ASN_RELATIVE_OID
+ ASN_UNIVERSAL ASN_APPLICATION ASN_CONTEXT ASN_PRIVATE
+ ASN_PRIMITIVE ASN_CONSTRUCTOR ASN_LONG_LEN ASN_EXTENSION_ID ASN_BIT)],
+
+ tag => [qw(asn_tag asn_decode_tag2 asn_decode_tag asn_encode_tag asn_decode_length asn_encode_length)]
+ );
+
+ @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+ $EXPORT_TAGS{all} = \@EXPORT_OK;
+
+ @opParts = qw(
+ cTAG cTYPE cVAR cLOOP cOPT cCHILD cDEFINE
+ );
+
+ @opName = qw(
+ opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
+ opSEQUENCE opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID opBCD
+ );
+
+ foreach my $l (\@opParts, \@opName) {
+ my $i = 0;
+ foreach my $name (@$l) {
+ my $j = $i++;
+ no strict 'refs';
+ *{__PACKAGE__ . '::' . $name} = sub () { $j }
+ }
+ }
+}
+
+sub _internal_syms {
+ my $pkg = caller;
+ no strict 'refs';
+ for my $sub (@opParts,@opName,'dump_op') {
+ *{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub};
+ }
+}
+
+sub ASN_BOOLEAN () { 0x01 }
+sub ASN_INTEGER () { 0x02 }
+sub ASN_BIT_STR () { 0x03 }
+sub ASN_OCTET_STR () { 0x04 }
+sub ASN_NULL () { 0x05 }
+sub ASN_OBJECT_ID () { 0x06 }
+sub ASN_REAL () { 0x09 }
+sub ASN_ENUMERATED () { 0x0A }
+sub ASN_RELATIVE_OID () { 0x0D }
+sub ASN_SEQUENCE () { 0x10 }
+sub ASN_SET () { 0x11 }
+sub ASN_PRINT_STR () { 0x13 }
+sub ASN_IA5_STR () { 0x16 }
+sub ASN_UTC_TIME () { 0x17 }
+sub ASN_GENERAL_TIME () { 0x18 }
+
+sub ASN_UNIVERSAL () { 0x00 }
+sub ASN_APPLICATION () { 0x40 }
+sub ASN_CONTEXT () { 0x80 }
+sub ASN_PRIVATE () { 0xC0 }
+
+sub ASN_PRIMITIVE () { 0x00 }
+sub ASN_CONSTRUCTOR () { 0x20 }
+
+sub ASN_LONG_LEN () { 0x80 }
+sub ASN_EXTENSION_ID () { 0x1F }
+sub ASN_BIT () { 0x80 }
+
+
+sub new {
+ my $pkg = shift;
+ my $self = bless {}, $pkg;
+
+ $self->configure(@_);
+ $self;
+}
+
+
+sub configure {
+ my $self = shift;
+ my %opt = @_;
+
+ $self->{options}{encoding} = uc($opt{encoding} || 'BER');
+
+ unless ($self->{options}{encoding} =~ /^[BD]ER$/) {
+ require Carp;
+ Carp::croak("Unsupported encoding format '$opt{encoding}'");
+ }
+
+ for my $type (qw(encode decode)) {
+ if (exists $opt{$type}) {
+ while(my($what,$value) = each %{$opt{$type}}) {
+ $self->{options}{"${type}_${what}"} = $value;
+ }
+ }
+ }
+}
+
+
+
+sub find {
+ my $self = shift;
+ my $what = shift;
+ return unless exists $self->{tree}{$what};
+ my %new = %$self;
+ $new{script} = $new{tree}->{$what};
+ bless \%new, ref($self);
+}
+
+
+sub prepare {
+ my $self = shift;
+ my $asn = shift;
+
+ $self = $self->new unless ref($self);
+ my $tree;
+ if( ref($asn) eq 'GLOB' ){
+ local $/ = undef;
+ my $txt = <$asn>;
+ $tree = Convert::ASN1::parser::parse($txt);
+ } else {
+ $tree = Convert::ASN1::parser::parse($asn);
+ }
+
+ unless ($tree) {
+ $self->{error} = $@;
+ return;
+ ### If $self has been set to a new object, not returning
+ ### this object here will destroy the object, so the caller
+ ### won't be able to get at the error.
+ }
+
+ $self->{tree} = _pack_struct($tree);
+ $self->{script} = (values %$tree)[0];
+ $self;
+}
+
+sub prepare_file {
+ my $self = shift;
+ my $asnp = shift;
+
+ local *ASN;
+ open( ASN, $asnp )
+ or do{ $self->{error} = $@; return; };
+ my $ret = $self->prepare( \*ASN );
+ close( ASN );
+ $ret;
+}
+
+sub registeroid {
+ my $self = shift;
+ my $oid = shift;
+ my $handler = shift;
+
+ $self->{options}{oidtable}{$oid}=$handler;
+ $self->{oidtable}{$oid}=$handler;
+}
+
+sub registertype {
+ my $self = shift;
+ my $def = shift;
+ my $type = shift;
+ my $handler = shift;
+
+ $self->{options}{handlers}{$def}{$type}=$handler;
+}
+
+# In XS the will convert the tree between perl and C structs
+
+sub _pack_struct { $_[0] }
+sub _unpack_struct { $_[0] }
+
+##
+## Encoding
+##
+
+sub encode {
+ my $self = shift;
+ my $stash = @_ == 1 ? shift : { @_ };
+ my $buf = '';
+ local $SIG{__DIE__};
+ eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) }
+ or do { $self->{error} = $@; undef }
+}
+
+
+
+# Encode tag value for encoding.
+# We assume that the tag has been correctly generated with asn_tag()
+
+sub asn_encode_tag {
+ $_[0] >> 8
+ ? $_[0] & 0x8000
+ ? $_[0] & 0x800000
+ ? pack("V",$_[0])
+ : substr(pack("V",$_[0]),0,3)
+ : pack("v", $_[0])
+ : chr($_[0]);
+}
+
+
+# Encode a length. If < 0x80 then encode as a byte. Otherwise encode
+# 0x80 | num_bytes followed by the bytes for the number. top end
+# bytes of all zeros are not encoded
+
+sub asn_encode_length {
+
+ if($_[0] >> 7) {
+ my $lenlen = &num_length;
+
+ return pack("Ca*", $lenlen | 0x80, substr(pack("N",$_[0]), -$lenlen));
+ }
+
+ return pack("C", $_[0]);
+}
+
+
+##
+## Decoding
+##
+
+sub decode {
+ my $self = shift;
+
+ local $SIG{__DIE__};
+ my $ret = eval {
+ my (%stash, $result);
+ my $script = $self->{script};
+ my $stash = (1 == @$script && !$self->{script}[0][cVAR]) ? \$result : ($result=\%stash);
+
+ _decode(
+ $self->{options},
+ $script,
+ $stash,
+ 0,
+ length $_[0],
+ undef,
+ {},
+ $_[0]);
+
+ $result;
+ };
+ if ($@) {
+ $self->{'error'} = $@;
+ return undef;
+ }
+ $ret;
+}
+
+
+sub asn_decode_length {
+ return unless length $_[0];
+
+ my $len = ord substr($_[0],0,1);
+
+ if($len & 0x80) {
+ $len &= 0x7f or return (1,-1);
+
+ return if $len >= length $_[0];
+
+ return (1+$len, unpack("N", "\0" x (4 - $len) . substr($_[0],1,$len)));
+ }
+ return (1, $len);
+}
+
+
+sub asn_decode_tag {
+ return unless length $_[0];
+
+ my $tag = ord $_[0];
+ my $n = 1;
+
+ if(($tag & 0x1f) == 0x1f) {
+ my $b;
+ do {
+ return if $n >= length $_[0];
+ $b = ord substr($_[0],$n,1);
+ $tag |= $b << (8 * $n++);
+ } while($b & 0x80);
+ }
+ ($n, $tag);
+}
+
+
+sub asn_decode_tag2 {
+ return unless length $_[0];
+
+ my $tag = ord $_[0];
+ my $num = $tag & 0x1f;
+ my $len = 1;
+
+ if($num == 0x1f) {
+ $num = 0;
+ my $b;
+ do {
+ return if $len >= length $_[0];
+ $b = ord substr($_[0],$len++,1);
+ $num = ($num << 7) + ($b & 0x7f);
+ } while($b & 0x80);
+ }
+ ($len, $tag, $num);
+}
+
+
+##
+## Utilities
+##
+
+# How many bytes are needed to encode a number
+
+sub num_length {
+ $_[0] >> 8
+ ? $_[0] >> 16
+ ? $_[0] >> 24
+ ? 4
+ : 3
+ : 2
+ : 1
+}
+
+# Convert from a bigint to an octet string
+
+sub i2osp {
+ my($num, $biclass) = @_;
+ eval "use $biclass";
+ $num = $biclass->new($num);
+ my $neg = $num < 0
+ and $num = abs($num+1);
+ my $base = $biclass->new(256);
+ my $result = '';
+ while($num != 0) {
+ my $r = $num % $base;
+ $num = ($num-$r) / $base;
+ $result .= chr($r);
+ }
+ $result ^= chr(255) x length($result) if $neg;
+ return scalar reverse $result;
+}
+
+# Convert from an octet string to a bigint
+
+sub os2ip {
+ my($os, $biclass) = @_;
+ eval "require $biclass";
+ my $base = $biclass->new(256);
+ my $result = $biclass->new(0);
+ my $neg = ord($os) >= 0x80
+ and $os ^= chr(255) x length($os);
+ for (unpack("C*",$os)) {
+ $result = ($result * $base) + $_;
+ }
+ return $neg ? ($result + 1) * -1 : $result;
+}
+
+# Given a class and a tag, calculate an integer which when encoded
+# will become the tag. This means that the class bits are always
+# in the bottom byte, so are the tag bits if tag < 30. Otherwise
+# the tag is in the upper 3 bytes. The upper bytes are encoded
+# with bit8 representing that there is another byte. This
+# means the max tag we can do is 0x1fffff
+
+sub asn_tag {
+ my($class,$value) = @_;
+
+ die sprintf "Bad tag class 0x%x",$class
+ if $class & ~0xe0;
+
+ unless ($value & ~0x1f or $value == 0x1f) {
+ return (($class & 0xe0) | $value);
+ }
+
+ die sprintf "Tag value 0x%08x too big\n",$value
+ if $value & 0xffe00000;
+
+ $class = ($class | 0x1f) & 0xff;
+
+ my @t = ($value & 0x7f);
+ unshift @t, (0x80 | ($value & 0x7f)) while $value >>= 7;
+ unpack("V",pack("C4",$class,@t,0,0));
+}
+
+
+BEGIN {
+ # When we have XS &_encode will be defined by the XS code
+ # so will all the subs in these required packages
+ unless (defined &_encode) {
+ require Convert::ASN1::_decode;
+ require Convert::ASN1::_encode;
+ require Convert::ASN1::IO;
+ }
+
+ require Convert::ASN1::parser;
+}
+
+sub AUTOLOAD {
+ require Convert::ASN1::Debug if $AUTOLOAD =~ /dump/;
+ goto &{$AUTOLOAD} if defined &{$AUTOLOAD};
+ require Carp;
+ my $pkg = ref($_[0]) || ($_[0] =~ /^[\w\d]+(?:::[\w\d]+)*$/)[0];
+ if ($pkg and UNIVERSAL::isa($pkg, __PACKAGE__)) { # guess it was a method call
+ $AUTOLOAD =~ s/.*:://;
+ Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$AUTOLOAD,$pkg);
+ }
+ else {
+ Carp::croak(sprintf q{Undefined subroutine &%s called}, $AUTOLOAD);
+ }
+}
+
+sub DESTROY {}
+
+sub error { $_[0]->{error} }
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pod b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pod
new file mode 100755
index 00000000000..b31395b334e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pod
@@ -0,0 +1,480 @@
+=head1 NAME
+
+Convert::ASN1 - ASN.1 Encode/Decode library
+
+=head1 SYNOPSYS
+
+ use Convert::ASN1;
+
+ $asn = Convert::ASN1->new;
+ $asn->prepare(q<
+
+ [APPLICATION 7] SEQUENCE {
+ int INTEGER,
+ str OCTET STRING
+ }
+
+ >);
+
+ $pdu = $asn->encode( int => 7, str => "string");
+
+ $out = $asn->decode($pdu);
+ print $out->{int}," ",$out->{str},"\n";
+
+ use Convert::ASN1 qw(:io);
+
+ $peer = asn_recv($sock,$buffer,0);
+ $nbytes = asn_read($fh, $buffer);
+ $nbytes = asn_send($sock, $buffer, $peer);
+ $nbytes = asn_send($sock, $buffer);
+ $nbytes = asn_write($fh, $buffer);
+ $buffer = asn_get($fh);
+ $yes = asn_ready($fh)
+
+=head1 DESCRIPTION
+
+Convert::ASN1 encodes and decodes ASN.1 data structures using BER/DER
+rules.
+
+=head1 METHODS
+
+=head2 new ( [OPTIONS] )
+
+Contructor, creates a new object.
+
+If given, B<OPTIONS> are the same ones as for L</"configure ( OPTIONS )"> below.
+
+=head2 error ()
+
+Returns the last error.
+
+=head2 configure ( OPTIONS )
+
+Configure options to control how Convert::ASN1 will perform various tasks.
+Options are passed as name-value pairs.
+
+=over 4
+
+=item encode
+
+Reference to a hash which contains various encode options.
+
+=item decode
+
+Reference to a hash which contains various decode options.
+
+=item encoding
+
+One of 'BER' or 'DER'. The default is 'BER'
+
+=back
+
+Encode options
+
+=over 4
+
+=item real
+
+Which encoding to use for real's. One of 'binary', 'nr1', 'nr2', 'nr3'
+
+=item time
+
+This controls how UTCTime and GeneralizedTime elements are encoded. The default
+is C<withzone>.
+
+=over 4
+
+=item utctime
+
+The value passed will be encoded without a zone, ie a UTC value.
+
+=item withzone
+
+The value will be encoded with a zone. By default it will be encoded
+using the local time offset. The offset may be set using the C<timezone>
+configure option.
+
+=item raw
+
+The value passed should already be in the correct format and will be copied
+into the PDU as-is.
+
+=back
+
+=item timezone
+
+By default UTCTime and GeneralizedTime will be encoded using the local
+time offset from UTC. This will over-ride that. It is an offset from UTC
+in seconds. This option can be overriden by passing a reference to a
+list of two values as the time value. The list should contain the time
+value and the offset from UTC in seconds.
+
+=item bigint
+
+If during encoding an value greater than 32 bits is discovered and
+is not already a big integer object, then the value will first be
+converted into a big integer object. This option controls the big
+integer class into which the objects will be blessed. The default
+is to use Math::BigInt
+
+=back
+
+Decode options
+
+=over 4
+
+=item time
+
+This controls how a UTCTime or a GeneralizedTime element will be decoded. The default
+is C<utctime>.
+
+=over 4
+
+=item utctime
+
+The value returned will be a time value as returned by the C<time> function.
+
+=item withzone
+
+The value returned will be a reference to an array of two values. The first is the
+same as with C<utctime>, the second is the timezone offset, in seconds, that was
+used in the encoding.
+
+=item raw
+
+The value returned will be the raw encoding as extracted from the PDU.
+
+=back
+
+=item bigint
+
+If during decoding any big integers are discovered (integers greater
+than 32 bits), they will be decoded into big integer objects. This option
+controls the big integer class into which the objects will be blessed.
+The default is to use Math::BigInt.
+
+=item null
+
+The value to decode ASN.1 NULL types into.
+If not set, it defaults to C<1>.
+
+=back
+
+=head2 prepare ( ASN )
+
+Compile the given ASN.1 descripton which can be passed as a string
+or as a filehandle. The syntax used is very close to ASN.1, but has
+a few differences. If the ASN decribes only one macro then encode/decode can be
+called on this object. If ASN describes more than one ASN.1 macro then C<find>
+must be called. The method returns undef on error.
+
+=head2 prepare_file ( ASNPATH )
+
+Compile the ASN.1 description to be read from the specified pathname.
+
+=head2 find ( MACRO )
+
+Find a macro from a prepared ASN.1 description. Returns an object which can
+be used for encode/decode.
+
+=head2 encode ( VARIABLES )
+
+Encode a PDU. Top-level variable are passed as name-value pairs, or as a reference
+to a hash containing them. Returns the encoded PDU, or undef on error.
+
+=head2 decode ( PDU )
+
+Decode the PDU, returns a reference to a hash containg the values for the PDU. Returns
+undef if there was an error.
+
+=head2 registeroid ( OID, HANDLER )
+
+Register a handler for all ASN.1 elements
+that are C<DEFINED BY> the given OID.
+
+B<HANDLER> must be a Convert::ASN1 object, e.g. as returned by L</"find ( MACRO )">.
+
+=head2 registertype ( NAME, OID, HANDLER )
+
+Register a handler for all ASN.1 elements named C<NAME>,
+that are C<DEFINED BY> the given OID.
+
+B<HANDLER> must be a Convert::ASN1 object, e.g. as returned by L</"find ( MACRO )">.
+
+=head1 EXPORTS
+
+As well as providing an object interface for encoding/decoding PDUs Convert::ASN1
+also provides the following functions.
+
+=head2 IO Functions
+
+=over 4
+
+=item asn_recv ( SOCK, BUFFER, FLAGS )
+
+Will read a single element from the socket SOCK into BUFFER. FLAGS may
+be MSG_PEEK as exported by C<Socket>. Returns the address of the sender,
+or undef if there was an error. Some systems do not support the return
+of the peer address when the socket is a connected socket, in these
+cases the empty string will be returned. This is the same behaviour
+as the C<recv> function in perl itself.
+
+It is recommended that if the socket is of type SOCK_DGRAM then C<recv>
+be called directly instead of calling C<asn_recv>.
+
+=item asn_read ( FH, BUFFER, OFFSET )
+
+=item asn_read ( FH, BUFFER )
+
+Will read a single element from the filehandle FH into BUFFER. Returns the
+number of bytes read if a complete element was read, -1 if an incomplete
+element was read or undef if there was an error. If OFFSET is specified
+then it is assumed that BUFFER already contains an incomplete element
+and new data will be appended starting at OFFSET.
+
+If FH is a socket the asn_recv is used to read the element, so the same
+restiction applies if FH is a socket of type SOCK_DGRAM.
+
+=item asn_send ( SOCK, BUFFER, FLAGS, TO )
+
+=item asn_send ( SOCK, BUFFER, FLAGS )
+
+Identical to calling C<send>, see L<perlfunc>
+
+=item asn_write ( FH, BUFFER )
+
+Identical to calling C<syswrite> with 2 arguments, see L<perlfunc>
+
+=item asn_get ( FH )
+
+C<asn_get> provides buffered IO. Because it needs a buffer FH must be a GLOB
+or a reference to a GLOB. C<asn_get> will use two entries in the hash element
+of the GLOB to use as its buffer:
+
+ asn_buffer - input buffer
+ asn_need - number of bytes needed for the next element, if known
+
+Returns an element or undef if there was an error.
+
+=item asn_ready ( FH )
+
+C<asn_ready> works with C<asn_get>. It will return true if C<asn_get> has already
+read enough data into the buffer to return a complete element.
+
+=back
+
+=head2 Encode/Decode Functions
+
+=over 4
+
+=item asn_tag ( CLASS, VALUE )
+
+Given B<CLASS> and a B<VALUE>, calculate an integer which when encoded
+will become the tag.
+
+=item asn_decode_tag ( TAG )
+
+Decode the given ASN.1 encoded C<TAG>.
+
+=item asn_encode_tag ( TAG )
+
+Encode B<TAG> value for encoding.
+We assume that the tag has been correctly generated with L</"asn_tag ( CLASS, VALUE )">.
+
+=item asn_decode_length ( LEN )
+
+Decode the given ASN.1 decoded C<LEN>.
+
+=item asn_encode_length ( LEN )
+
+Encode the given C<LEN> to its ASN.1 encoding.
+
+=back
+
+=head2 Constants
+
+=over 4
+
+=item ASN_BIT_STR
+
+=item ASN_BOOLEAN
+
+=item ASN_ENUMERATED
+
+=item ASN_GENERAL_TIME
+
+=item ASN_IA5_STR
+
+=item ASN_INTEGER
+
+=item ASN_NULL
+
+=item ASN_OBJECT_ID
+
+=item ASN_OCTET_STR
+
+=item ASN_PRINT_STR
+
+=item ASN_REAL
+
+=item ASN_SEQUENCE
+
+=item ASN_SET
+
+=item ASN_UTC_TIME
+
+=item ASN_APPLICATION
+
+=item ASN_CONTEXT
+
+=item ASN_PRIVATE
+
+=item ASN_UNIVERSAL
+
+=item ASN_PRIMITIVE
+
+=item ASN_CONSTRUCTOR
+
+=item ASN_LONG_LEN
+
+=item ASN_EXTENSION_ID
+
+=item ASN_BIT
+
+=back
+
+=head2 Debug Functions
+
+=over 4
+
+=item asn_dump ( [FH,] BUFFER )
+
+Try to decode the given buffer as ASN.1 structure and dump it to the
+given file handle, or C<STDERR> if the handle is not given.
+
+=item asn_hexdump ( FH, BUFFER )
+
+=back
+
+=head1 EXPORT TAGS
+
+=over 4
+
+=item :all
+
+All exported functions
+
+=item :const
+
+ASN_BOOLEAN, ASN_INTEGER, ASN_BIT_STR, ASN_OCTET_STR,
+ASN_NULL, ASN_OBJECT_ID, ASN_REAL, ASN_ENUMERATED,
+ASN_SEQUENCE, ASN_SET, ASN_PRINT_STR, ASN_IA5_STR,
+ASN_UTC_TIME, ASN_GENERAL_TIME,
+ASN_UNIVERSAL, ASN_APPLICATION, ASN_CONTEXT, ASN_PRIVATE,
+ASN_PRIMITIVE, ASN_CONSTRUCTOR, ASN_LONG_LEN, ASN_EXTENSION_ID, ASN_BIT
+
+=item :debug
+
+asn_dump, asn_hexdump
+
+=item :io
+
+asn_recv, asn_send, asn_read, asn_write, asn_get, asn_ready
+
+=item :tag
+
+asn_tag, asn_decode_tag, asn_encode_tag, asn_decode_length, asn_encode_length
+
+=back
+
+=head1 MAPPING ASN.1 TO PERL
+
+Every element in the ASN.1 definition has a name, in perl a hash is used
+with these names as an index and the element value as the hash value.
+
+ # ASN.1
+ int INTEGER,
+ str OCTET STRING
+
+ # Perl
+ { int => 5, str => "text" }
+
+
+In the case of a SEQUENCE, SET or CHOICE then the value in the namespace will
+be a hash reference which will be the namespce for the elements with
+that element.
+
+ # ASN.1
+ int INTEGER,
+ seq SEQUENCE {
+ str OCTET STRING,
+ bool BOOLEAN
+ }
+
+ # Perl
+ { int => 5, seq => { str => "text", bool => 1}}
+
+If the element is a SEQUENCE OF, or SET OF, then the value in the namespace
+will be an array reference. The elements in the array will be of
+the type expected by the type following the OF. For example
+with "SEQUENCE OF STRING" the array would contain strings. With
+"SEQUENCE OF SEQUENCE { ... }" the array will contain hash references
+which will be used as namespaces
+
+ # ASN.1
+ int INTEGER,
+ str SEQUENCE OF OCTET STRING
+
+ # Perl
+ { int => 5, str => [ "text1", "text2"]}
+
+ # ASN.1
+ int INTEGER,
+ str SEQUENCE OF SEQUENCE {
+ type OCTET STRING,
+ value INTEGER
+ }
+
+ # Perl
+ { int => 5, str => [
+ { type => "abc", value => 4 },
+ { type => "def", value => -1 },
+ ]}
+
+=head2 Exceptions
+
+There are some exceptions where Convert::ASN1 does not require an element to be named.
+These are SEQUENCE {...}, SET {...} and CHOICE. In each case if the element is not
+given a name then the elements inside the {...} will share the same namespace as
+the elements outside of the {...}.
+
+=head1 TODO
+
+=over 4
+
+=item *
+
+XS implementation.
+
+=item *
+
+More documentation.
+
+=item *
+
+More tests.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>, Report bugs via <bug-Convert-ASN1@rt.cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm
new file mode 100755
index 00000000000..b9af2568a71
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm
@@ -0,0 +1,226 @@
+# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Convert::ASN1;
+
+##
+## just for debug :-)
+##
+
+sub _hexdump {
+ my($fmt,$pos) = @_[1,2]; # Don't copy buffer
+
+ $pos ||= 0;
+
+ my $offset = 0;
+ my $cnt = 1 << 4;
+ my $len = length($_[0]);
+ my $linefmt = ("%02X " x $cnt) . "%s\n";
+
+ print "\n";
+
+ while ($offset < $len) {
+ my $data = substr($_[0],$offset,$cnt);
+ my @y = unpack("C*",$data);
+
+ printf $fmt,$pos if $fmt;
+
+ # On the last time through replace '%02X ' with '__ ' for the
+ # missing values
+ substr($linefmt, 5*@y,5*($cnt-@y)) = "__ " x ($cnt - @y)
+ if @y != $cnt;
+
+ # Change non-printable chars to '.'
+ $data =~ s/[\x00-\x1f\x7f-\xff]/./sg;
+ printf $linefmt, @y,$data;
+
+ $offset += $cnt;
+ $pos += $cnt;
+ }
+}
+
+my %type = (
+ split(/[\t\n]\s*/,
+ q(10 SEQUENCE
+ 01 BOOLEAN
+ 0A ENUM
+ 0D RELATIVE-OID
+ 11 SET
+ 02 INTEGER
+ 03 BIT STRING
+ C0 [PRIVATE %d]
+ 04 STRING
+ 40 [APPLICATION %d]
+ 05 NULL
+ 06 OBJECT ID
+ 80 [CONTEXT %d]
+ )
+ )
+);
+
+BEGIN { undef &asn_dump }
+sub asn_dump {
+ my $fh = @_>1 ? shift : \*STDERR;
+
+ my $ofh = select($fh);
+
+ my $pos = 0;
+ my $indent = "";
+ my @seqend = ();
+ my $length = length($_[0]);
+ my $fmt = $length > 0xffff ? "%08X" : "%04X";
+
+ while(1) {
+ while (@seqend && $pos >= $seqend[0]) {
+ $indent = substr($indent,2);
+ warn "Bad sequence length " unless $pos == shift @seqend;
+ printf "$fmt : %s}\n",$pos,$indent;
+ }
+ last unless $pos < $length;
+
+ my $start = $pos;
+ my($tb,$tag,$tnum) = asn_decode_tag2(substr($_[0],$pos,10));
+ $pos += $tb;
+ my($lb,$len) = asn_decode_length(substr($_[0],$pos,10));
+ $pos += $lb;
+
+ if($tag == 0 && $len == 0) {
+ $seqend[0] = $pos;
+ redo;
+ }
+ printf $fmt. " %4d: %s",$start,$len,$indent;
+
+ my $label = $type{sprintf("%02X",$tag & ~0x20)}
+ || $type{sprintf("%02X",$tag & 0xC0)}
+ || "[UNIVERSAL %d]";
+ printf $label, $tnum;
+
+ if ($tag & ASN_CONSTRUCTOR) {
+ print " {\n";
+ if($len < 0) {
+ unshift(@seqend, length $_[0]);
+ }
+ else {
+ unshift(@seqend, $pos + $len);
+ }
+ $indent .= " ";
+ next;
+ }
+
+ my $tmp;
+
+ for ($label) { # switch
+ /^(INTEGER|ENUM)/ && do {
+ Convert::ASN1::_dec_integer({},[],{},$tmp,$_[0],$pos,$len);
+ printf " = %d\n",$tmp;
+ last;
+ };
+
+ /^BOOLEAN/ && do {
+ Convert::ASN1::_dec_boolean({},[],{},$tmp,$_[0],$pos,$len);
+ printf " = %s\n",$tmp ? 'TRUE' : 'FALSE';
+ last;
+ };
+
+ /^(?:(OBJECT ID)|(RELATIVE-OID))/ && do {
+ my @op; $op[cTYPE] = $1 ? opOBJID : opROID;
+ Convert::ASN1::_dec_object_id({},\@op,{},$tmp,$_[0],$pos,$len);
+ printf " = %s\n",$tmp;
+ last;
+ };
+
+ /^NULL/ && do {
+ print "\n";
+ last;
+ };
+
+ /^STRING/ && do {
+ Convert::ASN1::_dec_string({},[],{},$tmp,$_[0],$pos,$len);
+ if ($tmp =~ /[\x00-\x1f\x7f-\xff]/s) {
+ _hexdump($tmp,$fmt . " : ".$indent, $pos);
+ }
+ else {
+ printf " = '%s'\n",$tmp;
+ }
+ last;
+ };
+
+# /^BIT STRING/ && do {
+# Convert::BER::BIT_STRING->unpack($ber,\$tmp);
+# print " = ",$tmp,"\n";
+# last;
+# };
+
+ # default -- dump hex data
+ _hexdump(substr($_[0],$pos,$len),$fmt . " : ".$indent, $pos);
+ }
+ $pos += $len;
+ }
+
+ select($ofh);
+}
+
+BEGIN { undef &asn_hexdump }
+sub asn_hexdump {
+ my $fh = @_>1 ? shift : \*STDERR;
+ my $ofh = select($fh);
+
+ _hexdump($_[0]);
+ print "\n";
+ select($ofh);
+}
+
+BEGIN { undef &dump }
+sub dump {
+ my $self = shift;
+
+ for (@{$self->{script}}) {
+ dump_op($_,"",{},1);
+ }
+}
+
+BEGIN { undef &dump_all }
+sub dump_all {
+ my $self = shift;
+
+ while(my($k,$v) = each %{$self->{tree}}) {
+ print STDERR "$k:\n";
+ for (@$v) {
+ dump_op($_,"",{},1);
+ }
+ }
+}
+
+
+BEGIN { undef &dump_op }
+sub dump_op {
+ my($op,$indent,$done,$line) = @_;
+ $indent ||= "";
+ printf STDERR "%3d: ",$line;
+ if ($done->{$op}) {
+ print STDERR " $indent=",$done->{$op},"\n";
+ return ++$line;
+ }
+ $done->{$op} = $line++;
+ print STDERR $indent,"[ '",unpack("H*",$op->[cTAG]),"', ";
+ print STDERR $op->[cTYPE] =~ /\D/ ? $op->[cTYPE] : $opName[$op->[cTYPE]];
+ print STDERR ", ",defined($op->[cVAR]) ? $op->[cVAR] : "_";
+ print STDERR ", ",defined($op->[cLOOP]) ? $op->[cLOOP] : "_";
+ print STDERR ", ",defined($op->[cOPT]) ? $op->[cOPT] : "_";
+ print STDERR "]";
+ if ($op->[cCHILD]) {
+ print STDERR " ",scalar @{$op->[cCHILD]},"\n";
+ for (@{$op->[cCHILD]}) {
+ $line = dump_op($_,$indent . " ",$done,$line);
+ }
+ }
+ else {
+ print STDERR "\n";
+ }
+ print STDERR "\n" unless length $indent;
+ $line;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/IO.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/IO.pm
new file mode 100755
index 00000000000..e3dac3ee850
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/IO.pm
@@ -0,0 +1,261 @@
+# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Convert::ASN1;
+
+use strict;
+use Socket;
+
+BEGIN {
+ local $SIG{__DIE__};
+ eval { require bytes } and 'bytes'->import
+}
+
+sub asn_recv { # $socket, $buffer, $flags
+
+ my $peer;
+ my $buf;
+ my $n = 128;
+ my $pos = 0;
+ my $depth = 0;
+ my $len = 0;
+ my($tmp,$tb,$lb);
+
+ MORE:
+ for(
+ $peer = recv($_[0],$buf,$n,MSG_PEEK);
+ defined $peer;
+ $peer = recv($_[0],$buf,$n<<=1,MSG_PEEK)
+ ) {
+
+ if ($depth) { # Are we searching of "\0\0"
+
+ unless (2+$pos <= length $buf) {
+ next MORE if $n == length $buf;
+ last MORE;
+ }
+
+ if(substr($buf,$pos,2) eq "\0\0") {
+ unless (--$depth) {
+ $len = $pos + 2;
+ last MORE;
+ }
+ }
+ }
+
+ # If we can decode a tag and length we can detemine the length
+ ($tb,$tmp) = asn_decode_tag(substr($buf,$pos));
+ unless ($tb || $pos+$tb < length $buf) {
+ next MORE if $n == length $buf;
+ last MORE;
+ }
+
+ if (ord(substr($buf,$pos+$tb,1)) == 0x80) {
+ # indefinite length, grrr!
+ $depth++;
+ $pos += $tb + 1;
+ redo MORE;
+ }
+
+ ($lb,$len) = asn_decode_length(substr($buf,$pos+$tb));
+
+ if ($lb) {
+ if ($depth) {
+ $pos += $tb + $lb + $len;
+ redo MORE;
+ }
+ else {
+ $len += $tb + $lb + $pos;
+ last MORE;
+ }
+ }
+ }
+
+ if (defined $peer) {
+ if ($len > length $buf) {
+ # Check we can read the whole element
+ goto error
+ unless defined($peer = recv($_[0],$buf,$len,MSG_PEEK));
+
+ if ($len > length $buf) {
+ # Cannot get whole element
+ $_[1]='';
+ return $peer;
+ }
+ }
+ elsif ($len == 0) {
+ $_[1] = '';
+ return $peer;
+ }
+
+ if ($_[2] & MSG_PEEK) {
+ $_[1] = substr($buf,0,$len);
+ }
+ elsif (!defined($peer = recv($_[0],$_[1],$len,0))) {
+ goto error;
+ }
+
+ return $peer;
+ }
+
+error:
+ $_[1] = undef;
+}
+
+sub asn_read { # $fh, $buffer, $offset
+
+ # We need to read one packet, and exactly only one packet.
+ # So we have to read the first few bytes one at a time, until
+ # we have enough to decode a tag and a length. We then know
+ # how many more bytes to read
+
+ if ($_[2]) {
+ if ($_[2] > length $_[1]) {
+ require Carp;
+ Carp::carp("Offset beyond end of buffer");
+ return;
+ }
+ substr($_[1],$_[2]) = '';
+ }
+ else {
+ $_[1] = '';
+ }
+
+ my $pos = 0;
+ my $need = 0;
+ my $depth = 0;
+ my $ch;
+ my $n;
+ my $e;
+
+
+ while(1) {
+ $need = ($pos + ($depth * 2)) || 2;
+
+ while(($n = $need - length $_[1]) > 0) {
+ $e = sysread($_[0],$_[1],$n,length $_[1]) or
+ goto READ_ERR;
+ }
+
+ my $tch = ord(substr($_[1],$pos++,1));
+ # Tag may be multi-byte
+ if(($tch & 0x1f) == 0x1f) {
+ my $ch;
+ do {
+ $need++;
+ while(($n = $need - length $_[1]) > 0) {
+ $e = sysread($_[0],$_[1],$n,length $_[1]) or
+ goto READ_ERR;
+ }
+ $ch = ord(substr($_[1],$pos++,1));
+ } while($ch & 0x80);
+ }
+
+ $need = $pos + 1;
+
+ while(($n = $need - length $_[1]) > 0) {
+ $e = sysread($_[0],$_[1],$n,length $_[1]) or
+ goto READ_ERR;
+ }
+
+ my $len = ord(substr($_[1],$pos++,1));
+
+ if($len & 0x80) {
+ unless ($len &= 0x7f) {
+ $depth++;
+ next;
+ }
+ $need = $pos + $len;
+
+ while(($n = $need - length $_[1]) > 0) {
+ $e = sysread($_[0],$_[1],$n,length $_[1]) or
+ goto READ_ERR;
+ }
+
+ $pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[1],$pos,$len));
+ }
+ elsif (!$len && !$tch) {
+ die "Bad ASN PDU" unless $depth;
+ unless (--$depth) {
+ last;
+ }
+ }
+ else {
+ $pos += $len;
+ }
+
+ last unless $depth;
+ }
+
+ while(($n = $pos - length $_[1]) > 0) {
+ $e = sysread($_[0],$_[1],$n,length $_[1]) or
+ goto READ_ERR;
+ }
+
+ return length $_[1];
+
+READ_ERR:
+ $@ = defined($e) ? "Unexpected EOF" : "I/O Error $!"; # . CORE::unpack("H*",$_[1]);
+ return undef;
+}
+
+sub asn_send { # $sock, $buffer, $flags, $to
+
+ @_ == 4
+ ? send($_[0],$_[1],$_[2],$_[3])
+ : send($_[0],$_[1],$_[2]);
+}
+
+sub asn_write { # $sock, $buffer
+
+ syswrite($_[0],$_[1], length $_[1]);
+}
+
+sub asn_get { # $fh
+
+ my $fh = ref($_[0]) ? $_[0] : \($_[0]);
+ my $href = \%{*$fh};
+
+ $href->{'asn_buffer'} = '' unless exists $href->{'asn_buffer'};
+
+ my $need = delete $href->{'asn_need'} || 0;
+ while(1) {
+ next if $need;
+ my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or next;
+ my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or next;
+ $need = $tb + $lb + $len;
+ }
+ continue {
+ if ($need && $need <= length $href->{'asn_buffer'}) {
+ my $ret = substr($href->{'asn_buffer'},0,$need);
+ substr($href->{'asn_buffer'},0,$need) = '';
+ return $ret;
+ }
+
+ my $get = $need > 1024 ? $need : 1024;
+
+ sysread($_[0], $href->{'asn_buffer'}, $get, length $href->{'asn_buffer'})
+ or return undef;
+ }
+}
+
+sub asn_ready { # $fh
+
+ my $fh = ref($_[0]) ? $_[0] : \($_[0]);
+ my $href = \%{*$fh};
+
+ return 0 unless exists $href->{'asn_buffer'};
+
+ return $href->{'asn_need'} <= length $href->{'asn_buffer'}
+ if exists $href->{'asn_need'};
+
+ my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or return 0;
+ my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or return 0;
+
+ $href->{'asn_need'} = $tb + $lb + $len;
+
+ $href->{'asn_need'} <= length $href->{'asn_buffer'};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_decode.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_decode.pm
new file mode 100755
index 00000000000..944dd00e84d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_decode.pm
@@ -0,0 +1,675 @@
+# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Convert::ASN1;
+
+BEGIN {
+ local $SIG{__DIE__};
+ eval { require bytes and 'bytes'->import };
+}
+
+# These are the subs that do the decode, they are called with
+# 0 1 2 3 4
+# $optn, $op, $stash, $var, $buf
+# The order must be the same as the op definitions above
+
+my @decode = (
+ sub { die "internal error\n" },
+ \&_dec_boolean,
+ \&_dec_integer,
+ \&_dec_bitstring,
+ \&_dec_string,
+ \&_dec_null,
+ \&_dec_object_id,
+ \&_dec_real,
+ \&_dec_sequence,
+ \&_dec_set,
+ \&_dec_time,
+ \&_dec_time,
+ \&_dec_utf8,
+ undef, # ANY
+ undef, # CHOICE
+ \&_dec_object_id,
+ \&_dec_bcd,
+);
+
+my @ctr;
+@ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);
+
+
+sub _decode {
+ my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_;
+ my $idx = 0;
+
+ # we try not to copy the input buffer at any time
+ foreach my $buf ($_[-1]) {
+ OP:
+ foreach my $op (@{$ops}) {
+ my $var = $op->[cVAR];
+
+ if (length $op->[cTAG]) {
+
+ TAGLOOP: {
+ my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
+ or do {
+ next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
+ die "decode error";
+ };
+
+ if ($tag eq $op->[cTAG]) {
+
+ &{$decode[$op->[cTYPE]]}(
+ $optn,
+ $op,
+ $stash,
+ # We send 1 if there is not var as if there is the decode
+ # should be getting undef. So if it does not get undef
+ # it knows it has no variable
+ ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : 1),
+ $buf,$npos,$len, $larr
+ );
+
+ $pos = $npos+$len+$indef;
+
+ redo TAGLOOP if $seqof && $pos < $end;
+ next OP;
+ }
+
+ if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR))
+ and my $ctr = $ctr[$op->[cTYPE]])
+ {
+ _decode(
+ $optn,
+ [$op],
+ undef,
+ $npos,
+ $npos+$len,
+ (\my @ctrlist),
+ $larr,
+ $buf,
+ );
+
+ ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : undef)
+ = &{$ctr}(@ctrlist);
+ $pos = $npos+$len+$indef;
+
+ redo TAGLOOP if $seqof && $pos < $end;
+ next OP;
+
+ }
+
+ if ($seqof || defined $op->[cOPT]) {
+ next OP;
+ }
+
+ die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]), " ",$pos," ",$op->[cTYPE]," ",$op->[cVAR]||'';
+ }
+ }
+ else { # opTag length is zero, so it must be an ANY or CHOICE
+
+ if ($op->[cTYPE] == opANY) {
+
+ ANYLOOP: {
+
+ my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
+ or do {
+ next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
+ die "decode error";
+ };
+
+ $len += $npos-$pos;
+
+ if ($op->[cDEFINE]) {
+ $handler = $optn->{oidtable} && $optn->{oidtable}{$stash->{$op->[cDEFINE]}};
+ $handler ||= $optn->{handlers}{$op->[cVAR]}{$stash->{$op->[cDEFINE]}};
+ }
+
+ ($seqof ? $seqof->[$idx++] : ref($stash) eq 'SCALAR' ? $$stash : $stash->{$var})
+ = $handler ? $handler->decode(substr($buf,$pos,$len)) : substr($buf,$pos,$len);
+
+ $pos += $len + $indef;
+
+ redo ANYLOOP if $seqof && $pos < $end;
+ }
+ }
+ else {
+
+ CHOICELOOP: {
+ my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
+ or do {
+ next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
+ die "decode error";
+ };
+ foreach my $cop (@{$op->[cCHILD]}) {
+
+ if ($tag eq $cop->[cTAG]) {
+
+ my $nstash = $seqof
+ ? ($seqof->[$idx++]={})
+ : defined($var)
+ ? ($stash->{$var}={})
+ : ref($stash) eq 'SCALAR'
+ ? ($$stash={}) : $stash;
+
+ &{$decode[$cop->[cTYPE]]}(
+ $optn,
+ $cop,
+ $nstash,
+ ($cop->[cVAR] ? $nstash->{$cop->[cVAR]} : undef),
+ $buf,$npos,$len,$larr,
+ );
+
+ $pos = $npos+$len+$indef;
+
+ redo CHOICELOOP if $seqof && $pos < $end;
+ next OP;
+ }
+
+ unless (length $cop->[cTAG]) {
+ eval {
+ _decode(
+ $optn,
+ [$cop],
+ (\my %tmp_stash),
+ $pos,
+ $npos+$len+$indef,
+ undef,
+ $larr,
+ $buf,
+ );
+
+ my $nstash = $seqof
+ ? ($seqof->[$idx++]={})
+ : defined($var)
+ ? ($stash->{$var}={})
+ : ref($stash) eq 'SCALAR'
+ ? ($$stash={}) : $stash;
+
+ @{$nstash}{keys %tmp_stash} = values %tmp_stash;
+
+ } or next;
+
+ $pos = $npos+$len+$indef;
+
+ redo CHOICELOOP if $seqof && $pos < $end;
+ next OP;
+ }
+
+ if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR))
+ and my $ctr = $ctr[$cop->[cTYPE]])
+ {
+ my $nstash = $seqof
+ ? ($seqof->[$idx++]={})
+ : defined($var)
+ ? ($stash->{$var}={})
+ : ref($stash) eq 'SCALAR'
+ ? ($$stash={}) : $stash;
+
+ _decode(
+ $optn,
+ [$cop],
+ undef,
+ $npos,
+ $npos+$len,
+ (\my @ctrlist),
+ $larr,
+ $buf,
+ );
+
+ $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
+ $pos = $npos+$len+$indef;
+
+ redo CHOICELOOP if $seqof && $pos < $end;
+ next OP;
+ }
+ }
+ }
+ die "decode error" unless $op->[cOPT];
+ }
+ }
+ }
+ }
+ die "decode error $pos $end" unless $pos == $end;
+}
+
+
+sub _dec_boolean {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ $_[3] = ord(substr($_[4],$_[5],1)) ? 1 : 0;
+ 1;
+}
+
+
+sub _dec_integer {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ my $buf = substr($_[4],$_[5],$_[6]);
+ my $tmp = ord($buf) & 0x80 ? chr(255) : chr(0);
+ if ($_[6] > 4) {
+ $_[3] = os2ip($tmp x (4-$_[6]) . $buf, $_[0]->{decode_bigint} || 'Math::BigInt');
+ } else {
+ # N unpacks an unsigned value
+ $_[3] = unpack("l",pack("l",unpack("N", $tmp x (4-$_[6]) . $buf)));
+ }
+ 1;
+}
+
+
+sub _dec_bitstring {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ $_[3] = [ substr($_[4],$_[5]+1,$_[6]-1), ($_[6]-1)*8-ord(substr($_[4],$_[5],1)) ];
+ 1;
+}
+
+
+sub _dec_string {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ $_[3] = substr($_[4],$_[5],$_[6]);
+ 1;
+}
+
+
+sub _dec_null {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ $_[3] = exists($_[0]->{decode_null}) ? $_[0]->{decode_null} : 1;
+ 1;
+}
+
+
+sub _dec_object_id {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ my @data = unpack("w*",substr($_[4],$_[5],$_[6]));
+ if ($_[1]->[cTYPE] == opOBJID and @data > 1) {
+ if ($data[0] < 40) {
+ splice(@data, 0, 1, 0, $data[0]);
+ }
+ elsif ($data[0] < 80) {
+ splice(@data, 0, 1, 1, $data[0] - 40);
+ }
+ else {
+ splice(@data, 0, 1, 2, $data[0] - 80);
+ }
+ }
+ $_[3] = join(".", @data);
+ 1;
+}
+
+
+my @_dec_real_base = (2,8,16);
+
+sub _dec_real {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ $_[3] = 0.0, return unless $_[6];
+
+ my $first = ord(substr($_[4],$_[5],1));
+ if ($first & 0x80) {
+ # A real number
+
+ require POSIX;
+
+ my $exp;
+ my $expLen = $first & 0x3;
+ my $estart = $_[5]+1;
+
+ if($expLen == 3) {
+ $estart++;
+ $expLen = ord(substr($_[4],$_[5]+1,1));
+ }
+ else {
+ $expLen++;
+ }
+ _dec_integer(undef, undef, undef, $exp, $_[4],$estart,$expLen);
+
+ my $mant = 0.0;
+ for (reverse unpack("C*",substr($_[4],$estart+$expLen,$_[6]-1-$expLen))) {
+ $exp +=8, $mant = (($mant+$_) / 256) ;
+ }
+
+ $mant *= 1 << (($first >> 2) & 0x3);
+ $mant = - $mant if $first & 0x40;
+
+ $_[3] = $mant * POSIX::pow($_dec_real_base[($first >> 4) & 0x3], $exp);
+ return;
+ }
+ elsif($first & 0x40) {
+ $_[3] = POSIX::HUGE_VAL(),return if $first == 0x40;
+ $_[3] = - POSIX::HUGE_VAL(),return if $first == 0x41;
+ }
+ elsif(substr($_[4],$_[5],$_[6]) =~ /^.([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)$/s) {
+ $_[3] = eval "$1$2";
+ return;
+ }
+
+ die "REAL decode error\n";
+}
+
+
+sub _dec_sequence {
+# 0 1 2 3 4 5 6 7
+# $optn, $op, $stash, $var, $buf, $pos, $len, $larr
+
+ if (defined( my $ch = $_[1]->[cCHILD])) {
+ _decode(
+ $_[0], #optn
+ $ch, #ops
+ (defined($_[3]) || $_[1]->[cLOOP]) ? $_[2] : ($_[3]= {}), #stash
+ $_[5], #pos
+ $_[5]+$_[6], #end
+ $_[1]->[cLOOP] && ($_[3]=[]), #loop
+ $_[7],
+ $_[4], #buf
+ );
+ }
+ else {
+ $_[3] = substr($_[4],$_[5],$_[6]);
+ }
+ 1;
+}
+
+
+sub _dec_set {
+# 0 1 2 3 4 5 6 7
+# $optn, $op, $stash, $var, $buf, $pos, $len, $larr
+
+ # decode SET OF the same as SEQUENCE OF
+ my $ch = $_[1]->[cCHILD];
+ goto &_dec_sequence if $_[1]->[cLOOP] or !defined($ch);
+
+ my ($optn, $pos, $larr) = @_[0,5,7];
+ my $stash = defined($_[3]) ? $_[2] : ($_[3]={});
+ my $end = $pos + $_[6];
+ my @done;
+
+ while ($pos < $end) {
+ my($tag,$len,$npos,$indef) = _decode_tl($_[4],$pos,$end,$larr)
+ or die "decode error";
+
+ my ($idx, $any, $done) = (-1);
+
+SET_OP:
+ foreach my $op (@$ch) {
+ $idx++;
+ if (length($op->[cTAG])) {
+ if ($tag eq $op->[cTAG]) {
+ my $var = $op->[cVAR];
+ &{$decode[$op->[cTYPE]]}(
+ $optn,
+ $op,
+ $stash,
+ # We send 1 if there is not var as if there is the decode
+ # should be getting undef. So if it does not get undef
+ # it knows it has no variable
+ (defined($var) ? $stash->{$var} : 1),
+ $_[4],$npos,$len,$larr,
+ );
+ $done = $idx;
+ last SET_OP;
+ }
+ if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR))
+ and my $ctr = $ctr[$op->[cTYPE]])
+ {
+ _decode(
+ $optn,
+ [$op],
+ undef,
+ $npos,
+ $npos+$len,
+ (\my @ctrlist),
+ $larr,
+ $_[4],
+ );
+
+ $stash->{$op->[cVAR]} = &{$ctr}(@ctrlist)
+ if defined $op->[cVAR];
+ $done = $idx;
+ last SET_OP;
+ }
+ next SET_OP;
+ }
+ elsif ($op->[cTYPE] == opANY) {
+ $any = $idx;
+ }
+ elsif ($op->[cTYPE] == opCHOICE) {
+ foreach my $cop (@{$op->[cCHILD]}) {
+ if ($tag eq $cop->[cTAG]) {
+ my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
+
+ &{$decode[$cop->[cTYPE]]}(
+ $optn,
+ $cop,
+ $nstash,
+ $nstash->{$cop->[cVAR]},
+ $_[4],$npos,$len,$larr,
+ );
+ $done = $idx;
+ last SET_OP;
+ }
+ if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR))
+ and my $ctr = $ctr[$cop->[cTYPE]])
+ {
+ my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
+
+ _decode(
+ $optn,
+ [$cop],
+ undef,
+ $npos,
+ $npos+$len,
+ (\my @ctrlist),
+ $larr,
+ $_[4],
+ );
+
+ $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
+ $done = $idx;
+ last SET_OP;
+ }
+ }
+ }
+ else {
+ die "internal error";
+ }
+ }
+
+ if (!defined($done) and defined($any)) {
+ my $var = $ch->[$any][cVAR];
+ $stash->{$var} = substr($_[4],$pos,$len+$npos-$pos) if defined $var;
+ $done = $any;
+ }
+
+ die "decode error" if !defined($done) or $done[$done]++;
+
+ $pos = $npos + $len + $indef;
+ }
+
+ die "decode error" unless $end == $pos;
+
+ foreach my $idx (0..$#{$ch}) {
+ die "decode error" unless $done[$idx] or $ch->[$idx][cOPT];
+ }
+
+ 1;
+}
+
+
+my %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2);
+
+sub _dec_time {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ my $mode = $_dec_time_opt{$_[0]->{'decode_time'} || ''} || 0;
+
+ if ($mode == 2 or $_[6] == 0) {
+ $_[3] = substr($_[4],$_[5],$_[6]);
+ return;
+ }
+
+ my @bits = (substr($_[4],$_[5],$_[6])
+ =~ /^((?:\d\d)?\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)((?:\.\d{1,3})?)(([-+])(\d\d)(\d\d)|Z)/)
+ or die "bad time format";
+
+ if ($bits[0] < 100) {
+ $bits[0] += 100 if $bits[0] < 50;
+ }
+ else {
+ $bits[0] -= 1900;
+ }
+ $bits[1] -= 1;
+ require Time::Local;
+ my $time = Time::Local::timegm(@bits[5,4,3,2,1,0]);
+ $time += $bits[6] if length $bits[6];
+ my $offset = 0;
+ if ($bits[7] ne 'Z') {
+ $offset = $bits[9] * 3600 + $bits[10] * 60;
+ $offset = -$offset if $bits[8] eq '-';
+ $time -= $offset;
+ }
+ $_[3] = $mode ? [$time,$offset] : $time;
+}
+
+
+sub _dec_utf8 {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ BEGIN {
+ unless (CHECK_UTF8) {
+ local $SIG{__DIE__};
+ eval { require bytes } and 'bytes'->unimport;
+ eval { require utf8 } and 'utf8'->import;
+ }
+ }
+
+ if (CHECK_UTF8) {
+ $_[3] = Encode::decode('utf8', substr($_[4],$_[5],$_[6]));
+ }
+ else {
+ $_[3] = (substr($_[4],$_[5],$_[6]) =~ /(.*)/s)[0];
+ }
+
+ 1;
+}
+
+
+sub _decode_tl {
+ my($pos,$end,$larr) = @_[1,2,3];
+
+ my $indef = 0;
+
+ my $tag = substr($_[0], $pos++, 1);
+
+ if((ord($tag) & 0x1f) == 0x1f) {
+ my $b;
+ my $n=1;
+ do {
+ $tag .= substr($_[0],$pos++,1);
+ $b = ord substr($tag,-1);
+ } while($b & 0x80);
+ }
+ return if $pos >= $end;
+
+ my $len = ord substr($_[0],$pos++,1);
+
+ if($len & 0x80) {
+ $len &= 0x7f;
+
+ if ($len) {
+ return if $pos+$len > $end ;
+
+ ($len,$pos) = (unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len)), $pos+$len);
+ }
+ else {
+ unless (exists $larr->{$pos}) {
+ _scan_indef($_[0],$pos,$end,$larr) or return;
+ }
+ $indef = 2;
+ $len = $larr->{$pos};
+ }
+ }
+
+ return if $pos+$len+$indef > $end;
+
+ # return the tag, the length of the data, the position of the data
+ # and the number of extra bytes for indefinate encoding
+
+ ($tag, $len, $pos, $indef);
+}
+
+sub _scan_indef {
+ my($pos,$end,$larr) = @_[1,2,3];
+ my @depth = ( $pos );
+
+ while(@depth) {
+ return if $pos+2 > $end;
+
+ if (substr($_[0],$pos,2) eq "\0\0") {
+ my $end = $pos;
+ my $stref = shift @depth;
+ # replace pos with length = end - pos
+ $larr->{$stref} = $end - $stref;
+ $pos += 2;
+ next;
+ }
+
+ my $tag = substr($_[0], $pos++, 1);
+
+ if((ord($tag) & 0x1f) == 0x1f) {
+ my $b;
+ do {
+ $tag .= substr($_[0],$pos++,1);
+ $b = ord substr($tag,-1);
+ } while($b & 0x80);
+ }
+ return if $pos >= $end;
+
+ my $len = ord substr($_[0],$pos++,1);
+
+ if($len & 0x80) {
+ if ($len &= 0x7f) {
+ return if $pos+$len > $end ;
+
+ $pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len));
+ }
+ else {
+ # reserve another list element
+ unshift @depth, $pos;
+ }
+ }
+ else {
+ $pos += $len;
+ }
+ }
+
+ 1;
+}
+
+sub _ctr_string { join '', @_ }
+
+sub _ctr_bitstring {
+ [ join('', map { $_->[0] } @_), $_[-1]->[1] ]
+}
+
+sub _dec_bcd {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $pos, $len
+
+ ($_[3] = unpack("H*", substr($_[4],$_[5],$_[6]))) =~ s/[fF]$//;
+ 1;
+}
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_encode.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_encode.pm
new file mode 100755
index 00000000000..7aba3cd1b16
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_encode.pm
@@ -0,0 +1,406 @@
+# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Convert::ASN1;
+
+BEGIN {
+ unless (CHECK_UTF8) {
+ local $SIG{__DIE__};
+ eval { require bytes } and 'bytes'->import
+ }
+}
+
+# These are the subs which do the encoding, they are called with
+# 0 1 2 3 4 5
+# $opt, $op, $stash, $var, $buf, $loop
+# The order in the array must match the op definitions above
+
+my @encode = (
+ sub { die "internal error\n" },
+ \&_enc_boolean,
+ \&_enc_integer,
+ \&_enc_bitstring,
+ \&_enc_string,
+ \&_enc_null,
+ \&_enc_object_id,
+ \&_enc_real,
+ \&_enc_sequence,
+ \&_enc_sequence, # SET is the same encoding as sequence
+ \&_enc_time,
+ \&_enc_time,
+ \&_enc_utf8,
+ \&_enc_any,
+ \&_enc_choice,
+ \&_enc_object_id,
+ \&_enc_bcd,
+);
+
+
+sub _encode {
+ my ($optn, $ops, $stash, $path) = @_;
+ my $var;
+
+ foreach my $op (@{$ops}) {
+ if (defined(my $opt = $op->[cOPT])) {
+ next unless defined $stash->{$opt};
+ }
+ if (defined($var = $op->[cVAR])) {
+ push @$path, $var;
+ require Carp, Carp::croak(join(".", @$path)," is undefined") unless defined $stash->{$var};
+ }
+ $_[4] .= $op->[cTAG];
+
+ &{$encode[$op->[cTYPE]]}(
+ $optn,
+ $op,
+ (UNIVERSAL::isa($stash, 'HASH')
+ ? ($stash, defined($var) ? $stash->{$var} : undef)
+ : ({}, $stash)),
+ $_[4],
+ $op->[cLOOP],
+ $path,
+ );
+
+ pop @$path if defined $var;
+ }
+
+ $_[4];
+}
+
+
+sub _enc_boolean {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ $_[4] .= pack("CC",1, $_[3] ? 0xff : 0);
+}
+
+
+sub _enc_integer {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+ if (abs($_[3]) >= 2**31) {
+ my $os = i2osp($_[3], ref($_[3]) || $_[0]->{encode_bigint} || 'Math::BigInt');
+ my $len = length $os;
+ my $msb = (vec($os, 0, 8) & 0x80) ? 0 : 255;
+ $len++, $os = chr($msb) . $os if $msb xor $_[3] > 0;
+ $_[4] .= asn_encode_length($len);
+ $_[4] .= $os;
+ }
+ else {
+ my $val = int($_[3]);
+ my $neg = ($val < 0);
+ my $len = num_length($neg ? ~$val : $val);
+ my $msb = $val & (0x80 << (($len - 1) * 8));
+
+ $len++ if $neg ? !$msb : $msb;
+
+ $_[4] .= asn_encode_length($len);
+ $_[4] .= substr(pack("N",$val), -$len);
+ }
+}
+
+
+sub _enc_bitstring {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+ my $vref = ref($_[3]) ? \($_[3]->[0]) : \$_[3];
+
+ if (CHECK_UTF8 and Encode::is_utf8($$vref)) {
+ utf8::encode(my $tmp = $$vref);
+ $vref = \$tmp;
+ }
+
+ if (ref($_[3])) {
+ my $less = (8 - ($_[3]->[1] & 7)) & 7;
+ my $len = ($_[3]->[1] + 7) >> 3;
+ $_[4] .= asn_encode_length(1+$len);
+ $_[4] .= chr($less);
+ $_[4] .= substr($$vref, 0, $len);
+ if ($less && $len) {
+ substr($_[4],-1) &= chr((0xff << $less) & 0xff);
+ }
+ }
+ else {
+ $_[4] .= asn_encode_length(1+length $$vref);
+ $_[4] .= chr(0);
+ $_[4] .= $$vref;
+ }
+}
+
+
+sub _enc_string {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ if (CHECK_UTF8 and Encode::is_utf8($_[3])) {
+ utf8::encode(my $tmp = $_[3]);
+ $_[4] .= asn_encode_length(length $tmp);
+ $_[4] .= $tmp;
+ }
+ else {
+ $_[4] .= asn_encode_length(length $_[3]);
+ $_[4] .= $_[3];
+ }
+}
+
+
+sub _enc_null {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ $_[4] .= chr(0);
+}
+
+
+sub _enc_object_id {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ my @data = ($_[3] =~ /(\d+)/g);
+
+ if ($_[1]->[cTYPE] == opOBJID) {
+ if(@data < 2) {
+ @data = (0);
+ }
+ else {
+ my $first = $data[1] + ($data[0] * 40);
+ splice(@data,0,2,$first);
+ }
+ }
+
+ my $l = length $_[4];
+ $_[4] .= pack("cw*", 0, @data);
+ substr($_[4],$l,1) = asn_encode_length(length($_[4]) - $l - 1);
+}
+
+
+sub _enc_real {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ # Zero
+ unless ($_[3]) {
+ $_[4] .= chr(0);
+ return;
+ }
+
+ require POSIX;
+
+ # +oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
+ if ($_[3] >= POSIX::HUGE_VAL()) {
+ $_[4] .= pack("C*",0x01,0x40);
+ return;
+ }
+
+ # -oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
+ if ($_[3] <= - POSIX::HUGE_VAL()) {
+ $_[4] .= pack("C*",0x01,0x41);
+ return;
+ }
+
+ if (exists $_[0]->{'encode_real'} && $_[0]->{'encode_real'} ne 'binary') {
+ my $tmp = sprintf("%g",$_[3]);
+ $_[4] .= asn_encode_length(1+length $tmp);
+ $_[4] .= chr(1); # NR1?
+ $_[4] .= $tmp;
+ return;
+ }
+
+ # We have a real number.
+ my $first = 0x80;
+ my($mantissa, $exponent) = POSIX::frexp($_[3]);
+
+ if ($mantissa < 0.0) {
+ $mantissa = -$mantissa;
+ $first |= 0x40;
+ }
+ my($eMant,$eExp);
+
+ while($mantissa > 0.0) {
+ ($mantissa, my $int) = POSIX::modf($mantissa * (1<<8));
+ $eMant .= chr($int);
+ }
+ $exponent -= 8 * length $eMant;
+
+ _enc_integer(undef, undef, undef, $exponent, $eExp);
+
+ # $eExp will br prefixed by a length byte
+
+ if (5 > length $eExp) {
+ $eExp =~ s/\A.//s;
+ $first |= length($eExp)-1;
+ }
+ else {
+ $first |= 0x3;
+ }
+
+ $_[4] .= asn_encode_length(1 + length($eMant) + length($eExp));
+ $_[4] .= chr($first);
+ $_[4] .= $eExp;
+ $_[4] .= $eMant;
+}
+
+
+sub _enc_sequence {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ if (my $ops = $_[1]->[cCHILD]) {
+ my $l = length $_[4];
+ $_[4] .= "\0\0"; # guess
+ if (defined $_[5]) {
+ my $op = $ops->[0]; # there should only be one
+ my $enc = $encode[$op->[cTYPE]];
+ my $tag = $op->[cTAG];
+ my $loop = $op->[cLOOP];
+
+ push @{$_[6]}, -1;
+
+ foreach my $var (@{$_[3]}) {
+ $_[6]->[-1]++;
+ $_[4] .= $tag;
+
+ &{$enc}(
+ $_[0], # $optn
+ $op, # $op
+ $_[2], # $stash
+ $var, # $var
+ $_[4], # $buf
+ $loop, # $loop
+ $_[6], # $path
+ );
+ }
+ pop @{$_[6]};
+ }
+ else {
+ _encode($_[0],$_[1]->[cCHILD], defined($_[3]) ? $_[3] : $_[2], $_[6], $_[4]);
+ }
+ substr($_[4],$l,2) = asn_encode_length(length($_[4]) - $l - 2);
+ }
+ else {
+ $_[4] .= asn_encode_length(length $_[3]);
+ $_[4] .= $_[3];
+ }
+}
+
+
+my %_enc_time_opt = ( utctime => 1, withzone => 0, raw => 2);
+
+sub _enc_time {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ my $mode = $_enc_time_opt{$_[0]->{'encode_time'} || ''} || 0;
+
+ if ($mode == 2) {
+ $_[4] .= asn_encode_length(length $_[3]);
+ $_[4] .= $_[3];
+ return;
+ }
+
+ my @time;
+ my $offset;
+ my $isgen = $_[1]->[cTYPE] == opGTIME;
+
+ if (ref($_[3])) {
+ $offset = int($_[3]->[1] / 60);
+ $time = $_[3]->[0] + $_[3]->[1];
+ }
+ elsif ($mode == 0) {
+ if (exists $_[0]->{'encode_timezone'}) {
+ $offset = int($_[0]->{'encode_timezone'} / 60);
+ $time = $_[3] + $_[0]->{'encode_timezone'};
+ }
+ else {
+ @time = localtime($_[3]);
+ my @g = gmtime($_[3]);
+
+ $offset = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60;
+ $time = $_[3] + $offset*60;
+ }
+ }
+ else {
+ $time = $_[3];
+ }
+ @time = gmtime($time);
+ $time[4] += 1;
+ $time[5] = $isgen ? ($time[5] + 1900) : ($time[5] % 100);
+
+ my $tmp = sprintf("%02d"x6, @time[5,4,3,2,1,0]);
+ if ($isgen) {
+ my $sp = sprintf("%.03f",$time);
+ $tmp .= substr($sp,-4) unless $sp =~ /\.000$/;
+ }
+ $tmp .= $offset ? sprintf("%+03d%02d",$offset / 60, abs($offset % 60)) : 'Z';
+ $_[4] .= asn_encode_length(length $tmp);
+ $_[4] .= $tmp;
+}
+
+
+sub _enc_utf8 {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ if (CHECK_UTF8) {
+ my $tmp = $_[3];
+ utf8::upgrade($tmp) unless Encode::is_utf8($tmp);
+ utf8::encode($tmp);
+ $_[4] .= asn_encode_length(length $tmp);
+ $_[4] .= $tmp;
+ }
+ else {
+ $_[4] .= asn_encode_length(length $_[3]);
+ $_[4] .= $_[3];
+ }
+}
+
+
+sub _enc_any {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ my $handler;
+ if ($_[1]->[cDEFINE] && $_[2]->{$_[1]->[cDEFINE]}) {
+ $handler=$_[0]->{oidtable}{$_[2]->{$_[1]->[cDEFINE]}};
+ $handler=$_[0]->{handlers}{$_[1]->[cVAR]}{$_[2]->{$_[1]->[cDEFINE]}} unless $handler;
+ }
+ if ($handler) {
+ $_[4] .= $handler->encode($_[3]);
+ } else {
+ $_[4] .= $_[3];
+ }
+}
+
+
+sub _enc_choice {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+
+ my $stash = defined($_[3]) ? $_[3] : $_[2];
+ for my $op (@{$_[1]->[cCHILD]}) {
+ my $var = defined $op->[cVAR] ? $op->[cVAR] : $op->[cCHILD]->[0]->[cVAR];
+
+ if (exists $stash->{$var}) {
+ push @{$_[6]}, $var;
+ _encode($_[0],[$op], $stash, $_[6], $_[4]);
+ pop @{$_[6]};
+ return;
+ }
+ }
+ require Carp;
+ Carp::croak("No value found for CHOICE " . join(".", @{$_[6]}));
+}
+
+
+sub _enc_bcd {
+# 0 1 2 3 4 5 6
+# $optn, $op, $stash, $var, $buf, $loop, $path
+ my $str = ("$_[3]" =~ /^(\d+)/) ? $1 : "";
+ $str .= "F" if length($str) & 1;
+ $_[4] .= asn_encode_length(length($str) / 2);
+ $_[4] .= pack("H*", $str);
+}
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/parser.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/parser.pm
new file mode 100755
index 00000000000..36d07c53004
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/parser.pm
@@ -0,0 +1,916 @@
+#$yysccsid = "@(#)yaccpar 1.8 (Berkeley) 01/20/91 (Perl 2.0 12/31/92)";
+# 23 "parser.y"
+;# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+;# This program is free software; you can redistribute it and/or
+;# modify it under the same terms as Perl itself.
+
+package Convert::ASN1::parser;
+
+use strict;
+use Convert::ASN1 qw(:all);
+use vars qw(
+ $asn $yychar $yyerrflag $yynerrs $yyn @yyss
+ $yyssp $yystate @yyvs $yyvsp $yylval $yys $yym $yyval
+);
+
+BEGIN { Convert::ASN1->_internal_syms }
+
+my $yydebug=0;
+my %yystate;
+
+my %base_type = (
+ BOOLEAN => [ asn_encode_tag(ASN_BOOLEAN), opBOOLEAN ],
+ INTEGER => [ asn_encode_tag(ASN_INTEGER), opINTEGER ],
+ BIT_STRING => [ asn_encode_tag(ASN_BIT_STR), opBITSTR ],
+ OCTET_STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ],
+ STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ],
+ NULL => [ asn_encode_tag(ASN_NULL), opNULL ],
+ OBJECT_IDENTIFIER => [ asn_encode_tag(ASN_OBJECT_ID), opOBJID ],
+ REAL => [ asn_encode_tag(ASN_REAL), opREAL ],
+ ENUMERATED => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ],
+ ENUM => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ],
+ 'RELATIVE-OID' => [ asn_encode_tag(ASN_RELATIVE_OID), opROID ],
+
+ SEQUENCE => [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opSEQUENCE ],
+ SET => [ asn_encode_tag(ASN_SET | ASN_CONSTRUCTOR), opSET ],
+
+ ObjectDescriptor => [ asn_encode_tag(ASN_UNIVERSAL | 7), opSTRING ],
+ UTF8String => [ asn_encode_tag(ASN_UNIVERSAL | 12), opUTF8 ],
+ NumericString => [ asn_encode_tag(ASN_UNIVERSAL | 18), opSTRING ],
+ PrintableString => [ asn_encode_tag(ASN_UNIVERSAL | 19), opSTRING ],
+ TeletexString => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],
+ T61String => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],
+ VideotexString => [ asn_encode_tag(ASN_UNIVERSAL | 21), opSTRING ],
+ IA5String => [ asn_encode_tag(ASN_UNIVERSAL | 22), opSTRING ],
+ UTCTime => [ asn_encode_tag(ASN_UNIVERSAL | 23), opUTIME ],
+ GeneralizedTime => [ asn_encode_tag(ASN_UNIVERSAL | 24), opGTIME ],
+ GraphicString => [ asn_encode_tag(ASN_UNIVERSAL | 25), opSTRING ],
+ VisibleString => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],
+ ISO646String => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],
+ GeneralString => [ asn_encode_tag(ASN_UNIVERSAL | 27), opSTRING ],
+ CharacterString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],
+ UniversalString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],
+ BMPString => [ asn_encode_tag(ASN_UNIVERSAL | 30), opSTRING ],
+ BCDString => [ asn_encode_tag(ASN_OCTET_STR), opBCD ],
+
+ CHOICE => [ '', opCHOICE ],
+ ANY => [ '', opANY ],
+);
+
+;# Given an OP, wrap it in a SEQUENCE
+
+sub explicit {
+ my $op = shift;
+ my @seq = @$op;
+
+ @seq[cTYPE,cCHILD,cVAR,cLOOP] = ('SEQUENCE',[$op],undef,undef);
+ @{$op}[cTAG,cOPT] = ();
+
+ \@seq;
+}
+
+sub constWORD () { 1 }
+sub constCLASS () { 2 }
+sub constSEQUENCE () { 3 }
+sub constSET () { 4 }
+sub constCHOICE () { 5 }
+sub constOF () { 6 }
+sub constIMPLICIT () { 7 }
+sub constEXPLICIT () { 8 }
+sub constOPTIONAL () { 9 }
+sub constLBRACE () { 10 }
+sub constRBRACE () { 11 }
+sub constCOMMA () { 12 }
+sub constANY () { 13 }
+sub constASSIGN () { 14 }
+sub constNUMBER () { 15 }
+sub constENUM () { 16 }
+sub constCOMPONENTS () { 17 }
+sub constPOSTRBRACE () { 18 }
+sub constDEFINED () { 19 }
+sub constBY () { 20 }
+sub constYYERRCODE () { 256 }
+my @yylhs = ( -1,
+ 0, 0, 2, 2, 3, 3, 6, 6, 6, 6,
+ 8, 13, 13, 12, 14, 14, 14, 9, 9, 9,
+ 10, 18, 18, 18, 18, 18, 19, 19, 11, 16,
+ 16, 20, 20, 20, 21, 1, 1, 1, 22, 22,
+ 22, 24, 24, 24, 24, 23, 23, 23, 15, 15,
+ 4, 4, 5, 5, 5, 17, 17, 25, 7, 7,
+);
+my @yylen = ( 2,
+ 1, 1, 3, 4, 4, 1, 1, 1, 1, 1,
+ 3, 1, 1, 6, 1, 1, 1, 4, 4, 4,
+ 4, 1, 1, 1, 2, 1, 0, 3, 1, 1,
+ 2, 1, 3, 3, 4, 0, 1, 2, 1, 3,
+ 3, 2, 1, 1, 1, 4, 1, 3, 0, 1,
+ 0, 1, 0, 1, 1, 1, 3, 2, 0, 1,
+);
+my @yydefred = ( 0,
+ 0, 52, 0, 0, 1, 0, 0, 47, 0, 39,
+ 0, 0, 0, 0, 55, 54, 0, 0, 0, 3,
+ 0, 6, 0, 11, 0, 0, 0, 0, 48, 0,
+ 40, 41, 0, 22, 0, 0, 0, 0, 45, 43,
+ 0, 44, 0, 29, 46, 4, 0, 0, 0, 0,
+ 7, 8, 9, 10, 0, 25, 0, 50, 42, 0,
+ 0, 0, 0, 0, 0, 32, 60, 5, 0, 0,
+ 0, 56, 0, 18, 19, 0, 20, 0, 0, 28,
+ 58, 21, 0, 0, 0, 34, 33, 57, 0, 0,
+ 17, 15, 16, 0, 35, 14,
+);
+my @yydgoto = ( 4,
+ 5, 6, 20, 7, 17, 50, 68, 8, 51, 52,
+ 53, 54, 43, 94, 59, 64, 71, 44, 56, 65,
+ 66, 9, 10, 45, 72,
+);
+my @yysindex = ( 7,
+ 9, 0, 12, 0, 0, 19, 51, 0, 34, 0,
+ 75, 51, 31, -1, 0, 0, 90, 55, 55, 0,
+ 51, 0, 114, 0, 75, 26, 53, 61, 0, 77,
+ 0, 0, 114, 0, 26, 53, 64, 76, 0, 0,
+ 89, 0, 96, 0, 0, 0, 55, 55, 111, 103,
+ 0, 0, 0, 0, 94, 0, 130, 0, 0, 77,
+ 122, 128, 77, 141, 78, 0, 0, 0, 155, 147,
+ 33, 0, 51, 0, 0, 51, 0, 111, 111, 0,
+ 0, 0, 130, 119, 114, 0, 0, 0, 26, 53,
+ 0, 0, 0, 89, 0, 0,
+);
+my @yyrindex = ( 150,
+ 100, 0, 0, 0, 0, 166, 106, 0, 39, 0,
+ 100, 133, 0, 0, 0, 0, 0, 165, 140, 0,
+ 133, 0, 0, 0, 100, 0, 0, 0, 0, 100,
+ 0, 0, 0, 0, 16, 29, 42, 69, 0, 0,
+ 37, 0, 0, 0, 0, 0, 156, 156, 0, 125,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 100,
+ 0, 0, 100, 0, 154, 0, 0, 0, 0, 0,
+ 0, 0, 133, 0, 0, 133, 0, 0, 160, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 73, 88,
+ 0, 0, 0, 3, 0, 0,
+);
+my @yygindex = ( 0,
+ 28, 0, 149, 1, -11, 91, 0, 8, -17, -18,
+ -16, 152, 0, 0, 83, 0, 0, 0, 0, 0,
+ 50, 0, 123, 0, 95,
+);
+sub constYYTABLESIZE () { 178 }
+my @yytable = ( 29,
+ 23, 12, 49, 49, 40, 39, 41, 1, 2, 33,
+ 2, 21, 25, 49, 49, 23, 23, 13, 22, 14,
+ 49, 12, 11, 3, 23, 21, 23, 23, 24, 24,
+ 12, 24, 22, 23, 13, 47, 49, 24, 37, 24,
+ 24, 27, 27, 82, 83, 18, 24, 49, 49, 37,
+ 27, 19, 27, 27, 49, 30, 2, 15, 16, 27,
+ 73, 84, 48, 76, 85, 92, 91, 93, 26, 26,
+ 49, 3, 23, 23, 61, 62, 2, 26, 2, 26,
+ 26, 23, 55, 23, 23, 57, 26, 24, 24, 78,
+ 23, 3, 26, 27, 28, 79, 24, 58, 24, 24,
+ 51, 60, 51, 51, 51, 24, 51, 51, 53, 53,
+ 53, 63, 51, 69, 34, 51, 35, 36, 28, 34,
+ 67, 89, 90, 28, 59, 59, 37, 86, 87, 38,
+ 70, 37, 74, 53, 38, 53, 53, 53, 75, 38,
+ 31, 32, 51, 51, 51, 53, 51, 51, 53, 36,
+ 38, 77, 51, 51, 51, 80, 51, 51, 51, 51,
+ 51, 81, 51, 51, 30, 2, 36, 51, 51, 51,
+ 31, 51, 51, 46, 42, 95, 96, 88,
+);
+my @yycheck = ( 17,
+ 12, 1, 0, 1, 23, 23, 23, 1, 2, 21,
+ 2, 11, 14, 11, 12, 0, 1, 6, 11, 1,
+ 18, 6, 14, 17, 9, 25, 11, 12, 0, 1,
+ 30, 1, 25, 18, 6, 10, 0, 9, 0, 11,
+ 12, 0, 1, 11, 12, 12, 18, 11, 12, 11,
+ 9, 18, 11, 12, 18, 1, 2, 7, 8, 18,
+ 60, 73, 10, 63, 76, 84, 84, 84, 0, 1,
+ 10, 17, 0, 1, 47, 48, 2, 9, 2, 11,
+ 12, 9, 19, 11, 12, 10, 18, 0, 1, 12,
+ 18, 17, 3, 4, 5, 18, 9, 9, 11, 12,
+ 1, 6, 3, 4, 5, 18, 7, 8, 3, 4,
+ 5, 1, 13, 20, 1, 16, 3, 4, 5, 1,
+ 18, 3, 4, 5, 0, 1, 13, 78, 79, 16,
+ 1, 13, 11, 1, 16, 3, 4, 5, 11, 0,
+ 18, 19, 3, 4, 5, 13, 7, 8, 16, 0,
+ 11, 11, 3, 4, 5, 1, 7, 8, 3, 4,
+ 5, 15, 7, 8, 11, 0, 11, 3, 4, 5,
+ 11, 7, 8, 25, 23, 85, 94, 83,
+);
+sub constYYFINAL () { 4 }
+
+
+
+sub constYYMAXTOKEN () { 20 }
+sub yyclearin { $yychar = -1; }
+sub yyerrok { $yyerrflag = 0; }
+sub YYERROR { ++$yynerrs; &yy_err_recover; }
+sub yy_err_recover
+{
+ if ($yyerrflag < 3)
+ {
+ $yyerrflag = 3;
+ while (1)
+ {
+ if (($yyn = $yysindex[$yyss[$yyssp]]) &&
+ ($yyn += constYYERRCODE()) >= 0 &&
+ $yyn <= $#yycheck && $yycheck[$yyn] == constYYERRCODE())
+ {
+
+
+
+
+ $yyss[++$yyssp] = $yystate = $yytable[$yyn];
+ $yyvs[++$yyvsp] = $yylval;
+ next yyloop;
+ }
+ else
+ {
+
+
+
+
+ return(1) if $yyssp <= 0;
+ --$yyssp;
+ --$yyvsp;
+ }
+ }
+ }
+ else
+ {
+ return (1) if $yychar == 0;
+ $yychar = -1;
+ next yyloop;
+ }
+0;
+} # yy_err_recover
+
+sub yyparse
+{
+
+ if ($yys = $ENV{'YYDEBUG'})
+ {
+ $yydebug = int($1) if $yys =~ /^(\d)/;
+ }
+
+
+ $yynerrs = 0;
+ $yyerrflag = 0;
+ $yychar = (-1);
+
+ $yyssp = 0;
+ $yyvsp = 0;
+ $yyss[$yyssp] = $yystate = 0;
+
+yyloop: while(1)
+ {
+ yyreduce: {
+ last yyreduce if ($yyn = $yydefred[$yystate]);
+ if ($yychar < 0)
+ {
+ if (($yychar = &yylex) < 0) { $yychar = 0; }
+ }
+ if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 &&
+ $yyn <= $#yycheck && $yycheck[$yyn] == $yychar)
+ {
+
+
+
+
+ $yyss[++$yyssp] = $yystate = $yytable[$yyn];
+ $yyvs[++$yyvsp] = $yylval;
+ $yychar = (-1);
+ --$yyerrflag if $yyerrflag > 0;
+ next yyloop;
+ }
+ if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 &&
+ $yyn <= $#yycheck && $yycheck[$yyn] == $yychar)
+ {
+ $yyn = $yytable[$yyn];
+ last yyreduce;
+ }
+ if (! $yyerrflag) {
+ &yyerror('syntax error');
+ ++$yynerrs;
+ }
+ return undef if &yy_err_recover;
+ } # yyreduce
+
+
+
+
+ $yym = $yylen[$yyn];
+ $yyval = $yyvs[$yyvsp+1-$yym];
+ switch:
+ {
+my $label = "State$yyn";
+goto $label if exists $yystate{$label};
+last switch;
+State1: {
+# 96 "parser.y"
+{ $yyval = { '' => $yyvs[$yyvsp-0] };
+last switch;
+} }
+State3: {
+# 101 "parser.y"
+{
+ $yyval = { $yyvs[$yyvsp-2], [$yyvs[$yyvsp-0]] };
+
+last switch;
+} }
+State4: {
+# 105 "parser.y"
+{
+ $yyval=$yyvs[$yyvsp-3];
+ $yyval->{$yyvs[$yyvsp-2]} = [$yyvs[$yyvsp-0]];
+
+last switch;
+} }
+State5: {
+# 112 "parser.y"
+{
+ $yyvs[$yyvsp-1]->[cTAG] = $yyvs[$yyvsp-3];
+ $yyval = $yyvs[$yyvsp-2] ? explicit($yyvs[$yyvsp-1]) : $yyvs[$yyvsp-1];
+
+last switch;
+} }
+State11: {
+# 126 "parser.y"
+{
+ @{$yyval = []}[cTYPE,cCHILD] = ('COMPONENTS', $yyvs[$yyvsp-0]);
+
+last switch;
+} }
+State14: {
+# 136 "parser.y"
+{
+ $yyvs[$yyvsp-1]->[cTAG] = $yyvs[$yyvsp-3];
+ @{$yyval = []}[cTYPE,cCHILD,cLOOP,cOPT] = ($yyvs[$yyvsp-5], [$yyvs[$yyvsp-1]], 1, $yyvs[$yyvsp-0]);
+ $yyval = explicit($yyval) if $yyvs[$yyvsp-2];
+
+last switch;
+} }
+State18: {
+# 149 "parser.y"
+{
+ @{$yyval = []}[cTYPE,cCHILD] = ('SEQUENCE', $yyvs[$yyvsp-1]);
+
+last switch;
+} }
+State19: {
+# 153 "parser.y"
+{
+ @{$yyval = []}[cTYPE,cCHILD] = ('SET', $yyvs[$yyvsp-1]);
+
+last switch;
+} }
+State20: {
+# 157 "parser.y"
+{
+ @{$yyval = []}[cTYPE,cCHILD] = ('CHOICE', $yyvs[$yyvsp-1]);
+
+last switch;
+} }
+State21: {
+# 163 "parser.y"
+{
+ @{$yyval = []}[cTYPE] = ('ENUM');
+
+last switch;
+} }
+State22: {
+# 168 "parser.y"
+{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0];
+last switch;
+} }
+State23: {
+# 169 "parser.y"
+{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0];
+last switch;
+} }
+State24: {
+# 170 "parser.y"
+{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0];
+last switch;
+} }
+State25: {
+# 172 "parser.y"
+{
+ @{$yyval = []}[cTYPE,cCHILD,cDEFINE] = ('ANY',undef,$yyvs[$yyvsp-0]);
+
+last switch;
+} }
+State26: {
+# 175 "parser.y"
+{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0];
+last switch;
+} }
+State27: {
+# 178 "parser.y"
+{ $yyval=undef;
+last switch;
+} }
+State28: {
+# 179 "parser.y"
+{ $yyval=$yyvs[$yyvsp-0];
+last switch;
+} }
+State30: {
+# 185 "parser.y"
+{ $yyval = $yyvs[$yyvsp-0];
+last switch;
+} }
+State31: {
+# 186 "parser.y"
+{ $yyval = $yyvs[$yyvsp-1];
+last switch;
+} }
+State32: {
+# 190 "parser.y"
+{
+ $yyval = [ $yyvs[$yyvsp-0] ];
+
+last switch;
+} }
+State33: {
+# 194 "parser.y"
+{
+ push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
+
+last switch;
+} }
+State34: {
+# 198 "parser.y"
+{
+ push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
+
+last switch;
+} }
+State35: {
+# 204 "parser.y"
+{
+ @{$yyval=$yyvs[$yyvsp-0]}[cVAR,cTAG] = ($yyvs[$yyvsp-3],$yyvs[$yyvsp-2]);
+ $yyval = explicit($yyval) if $yyvs[$yyvsp-1];
+
+last switch;
+} }
+State36: {
+# 211 "parser.y"
+{ $yyval = [];
+last switch;
+} }
+State37: {
+# 212 "parser.y"
+{ $yyval = $yyvs[$yyvsp-0];
+last switch;
+} }
+State38: {
+# 213 "parser.y"
+{ $yyval = $yyvs[$yyvsp-1];
+last switch;
+} }
+State39: {
+# 217 "parser.y"
+{
+ $yyval = [ $yyvs[$yyvsp-0] ];
+
+last switch;
+} }
+State40: {
+# 221 "parser.y"
+{
+ push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
+
+last switch;
+} }
+State41: {
+# 225 "parser.y"
+{
+ push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
+
+last switch;
+} }
+State42: {
+# 231 "parser.y"
+{
+ @{$yyval=$yyvs[$yyvsp-1]}[cOPT] = ($yyvs[$yyvsp-0]);
+
+last switch;
+} }
+State46: {
+# 240 "parser.y"
+{
+ @{$yyval=$yyvs[$yyvsp-0]}[cVAR,cTAG] = ($yyvs[$yyvsp-3],$yyvs[$yyvsp-2]);
+ $yyval->[cOPT] = $yyvs[$yyvsp-3] if $yyval->[cOPT];
+ $yyval = explicit($yyval) if $yyvs[$yyvsp-1];
+
+last switch;
+} }
+State48: {
+# 247 "parser.y"
+{
+ @{$yyval=$yyvs[$yyvsp-0]}[cTAG] = ($yyvs[$yyvsp-2]);
+ $yyval = explicit($yyval) if $yyvs[$yyvsp-1];
+
+last switch;
+} }
+State49: {
+# 253 "parser.y"
+{ $yyval = undef;
+last switch;
+} }
+State50: {
+# 254 "parser.y"
+{ $yyval = 1;
+last switch;
+} }
+State51: {
+# 258 "parser.y"
+{ $yyval = undef;
+last switch;
+} }
+State53: {
+# 262 "parser.y"
+{ $yyval = undef;
+last switch;
+} }
+State54: {
+# 263 "parser.y"
+{ $yyval = 1;
+last switch;
+} }
+State55: {
+# 264 "parser.y"
+{ $yyval = 0;
+last switch;
+} }
+State56: {
+# 267 "parser.y"
+{
+last switch;
+} }
+State57: {
+# 268 "parser.y"
+{
+last switch;
+} }
+State58: {
+# 271 "parser.y"
+{
+last switch;
+} }
+State59: {
+# 274 "parser.y"
+{
+last switch;
+} }
+State60: {
+# 275 "parser.y"
+{
+last switch;
+} }
+ } # switch
+ $yyssp -= $yym;
+ $yystate = $yyss[$yyssp];
+ $yyvsp -= $yym;
+ $yym = $yylhs[$yyn];
+ if ($yystate == 0 && $yym == 0)
+ {
+
+
+
+
+ $yystate = constYYFINAL();
+ $yyss[++$yyssp] = constYYFINAL();
+ $yyvs[++$yyvsp] = $yyval;
+ if ($yychar < 0)
+ {
+ if (($yychar = &yylex) < 0) { $yychar = 0; }
+ }
+ return $yyvs[$yyvsp] if $yychar == 0;
+ next yyloop;
+ }
+ if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 &&
+ $yyn <= $#yycheck && $yycheck[$yyn] == $yystate)
+ {
+ $yystate = $yytable[$yyn];
+ } else {
+ $yystate = $yydgoto[$yym];
+ }
+
+
+
+
+ $yyss[++$yyssp] = $yystate;
+ $yyvs[++$yyvsp] = $yyval;
+ } # yyloop
+} # yyparse
+# 279 "parser.y"
+
+my %reserved = (
+ 'OPTIONAL' => constOPTIONAL(),
+ 'CHOICE' => constCHOICE(),
+ 'OF' => constOF(),
+ 'IMPLICIT' => constIMPLICIT(),
+ 'EXPLICIT' => constEXPLICIT(),
+ 'SEQUENCE' => constSEQUENCE(),
+ 'SET' => constSET(),
+ 'ANY' => constANY(),
+ 'ENUM' => constENUM(),
+ 'ENUMERATED' => constENUM(),
+ 'COMPONENTS' => constCOMPONENTS(),
+ '{' => constLBRACE(),
+ '}' => constRBRACE(),
+ ',' => constCOMMA(),
+ '::=' => constASSIGN(),
+ 'DEFINED' => constDEFINED(),
+ 'BY' => constBY()
+);
+
+my $reserved = join("|", reverse sort grep { /\w/ } keys %reserved);
+
+my %tag_class = (
+ APPLICATION => ASN_APPLICATION,
+ UNIVERSAL => ASN_UNIVERSAL,
+ PRIVATE => ASN_PRIVATE,
+ CONTEXT => ASN_CONTEXT,
+ '' => ASN_CONTEXT # if not specified, its CONTEXT
+);
+
+;##
+;## This is NOT thread safe !!!!!!
+;##
+
+my $pos;
+my $last_pos;
+my @stacked;
+
+sub parse {
+ local(*asn) = \($_[0]);
+ ($pos,$last_pos,@stacked) = ();
+
+ eval {
+ local $SIG{__DIE__};
+ compile(verify(yyparse()));
+ }
+}
+
+sub compile_one {
+ my $tree = shift;
+ my $ops = shift;
+ my $name = shift;
+ foreach my $op (@$ops) {
+ next unless ref($op) eq 'ARRAY';
+ bless $op;
+ my $type = $op->[cTYPE];
+ if (exists $base_type{$type}) {
+ $op->[cTYPE] = $base_type{$type}->[1];
+ $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $base_type{$type}->[0];
+ }
+ else {
+ die "Unknown type '$type'\n" unless exists $tree->{$type};
+ my $ref = compile_one(
+ $tree,
+ $tree->{$type},
+ defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name
+ );
+ if (defined($op->[cTAG]) && $ref->[0][cTYPE] == opCHOICE) {
+ @{$op}[cTYPE,cCHILD] = (opSEQUENCE,$ref);
+ }
+ else {
+ @{$op}[cTYPE,cCHILD,cLOOP] = @{$ref->[0]}[cTYPE,cCHILD,cLOOP];
+ }
+ $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $ref->[0][cTAG];
+ }
+ $op->[cTAG] |= chr(ASN_CONSTRUCTOR)
+ if length $op->[cTAG] && ($op->[cTYPE] == opSET || $op->[cTYPE] == opSEQUENCE);
+
+ if ($op->[cCHILD]) {
+ ;# If we have children we are one of
+ ;# opSET opSEQUENCE opCHOICE
+
+ compile_one($tree, $op->[cCHILD], defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name);
+
+ ;# If a CHOICE is given a tag, then it must be EXPLICIT
+ if ($op->[cTYPE] == opCHOICE && defined($op->[cTAG]) && length($op->[cTAG])) {
+ $op = bless explicit($op);
+ $op->[cTYPE] = opSEQUENCE;
+ }
+
+ if ( @{$op->[cCHILD]} > 1) {
+ ;#if ($op->[cTYPE] != opSEQUENCE) {
+ ;# Here we need to flatten CHOICEs and check that SET and CHOICE
+ ;# do not contain duplicate tags
+ ;#}
+ if ($op->[cTYPE] == opSET) {
+ ;# In case we do CER encoding we order the SET elements by thier tags
+ my @tags = map {
+ length($_->[cTAG])
+ ? $_->[cTAG]
+ : $_->[cTYPE] == opCHOICE
+ ? (sort map { $_->[cTAG] } $_->[cCHILD])[0]
+ : ''
+ } @{$op->[cCHILD]};
+ @{$op->[cCHILD]} = @{$op->[cCHILD]}[sort { $tags[$a] cmp $tags[$b] } 0..$#tags];
+ }
+ }
+ else {
+ ;# A SET of one element can be treated the same as a SEQUENCE
+ $op->[cTYPE] = opSEQUENCE if $op->[cTYPE] == opSET;
+ }
+ }
+ }
+ $ops;
+}
+
+sub compile {
+ my $tree = shift;
+
+ ;# The tree should be valid enough to be able to
+ ;# - resolve references
+ ;# - encode tags
+ ;# - verify CHOICEs do not contain duplicate tags
+
+ ;# once references have been resolved, and also due to
+ ;# flattening of COMPONENTS, it is possible for an op
+ ;# to appear in multiple places. So once an op is
+ ;# compiled we bless it. This ensure we dont try to
+ ;# compile it again.
+
+ while(my($k,$v) = each %$tree) {
+ compile_one($tree,$v,$k);
+ }
+
+ $tree;
+}
+
+sub verify {
+ my $tree = shift or return;
+ my $err = "";
+
+ ;# Well it parsed correctly, now we
+ ;# - check references exist
+ ;# - flatten COMPONENTS OF (checking for loops)
+ ;# - check for duplicate var names
+
+ while(my($name,$ops) = each %$tree) {
+ my $stash = {};
+ my @scope = ();
+ my $path = "";
+ my $idx = 0;
+
+ while($ops) {
+ if ($idx < @$ops) {
+ my $op = $ops->[$idx++];
+ my $var;
+ if (defined ($var = $op->[cVAR])) {
+
+ $err .= "$name: $path.$var used multiple times\n"
+ if $stash->{$var}++;
+
+ }
+ if (defined $op->[cCHILD]) {
+ if (ref $op->[cCHILD]) {
+ push @scope, [$stash, $path, $ops, $idx];
+ if (defined $var) {
+ $stash = {};
+ $path .= "." . $var;
+ }
+ $idx = 0;
+ $ops = $op->[cCHILD];
+ }
+ elsif ($op->[cTYPE] eq 'COMPONENTS') {
+ splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD]));
+ }
+ else {
+ die "Internal error\n";
+ }
+ }
+ }
+ else {
+ my $s = pop @scope
+ or last;
+ ($stash,$path,$ops,$idx) = @$s;
+ }
+ }
+ }
+ die $err if length $err;
+ $tree;
+}
+
+sub expand_ops {
+ my $tree = shift;
+ my $want = shift;
+ my $seen = shift || { };
+
+ die "COMPONENTS OF loop $want\n" if $seen->{$want}++;
+ die "Undefined macro $want\n" unless exists $tree->{$want};
+ my $ops = $tree->{$want};
+ die "Bad macro for COMPUNENTS OF '$want'\n"
+ unless @$ops == 1
+ && ($ops->[0][cTYPE] eq 'SEQUENCE' || $ops->[0][cTYPE] eq 'SET')
+ && ref $ops->[0][cCHILD];
+ $ops = $ops->[0][cCHILD];
+ for(my $idx = 0 ; $idx < @$ops ; ) {
+ my $op = $ops->[$idx++];
+ if ($op->[cTYPE] eq 'COMPONENTS') {
+ splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD], $seen));
+ }
+ }
+
+ @$ops;
+}
+
+sub _yylex {
+ my $ret = &_yylex;
+ warn $ret;
+ $ret;
+}
+
+sub yylex {
+ return shift @stacked if @stacked;
+
+ while ($asn =~ /\G(?:
+ (\s+|--[^\n]*)
+ |
+ ([,{}]|::=)
+ |
+ ($reserved)\b
+ |
+ (
+ (?:OCTET|BIT)\s+STRING
+ |
+ OBJECT\s+IDENTIFIER
+ |
+ RELATIVE-OID
+ )\b
+ |
+ (\w+(?:-\w+)*)
+ |
+ \[\s*
+ (
+ (?:(?:APPLICATION|PRIVATE|UNIVERSAL|CONTEXT)\s+)?
+ \d+
+ )
+ \s*\]
+ |
+ \((\d+)\)
+ )/sxgo
+ ) {
+
+ ($last_pos,$pos) = ($pos,pos($asn));
+
+ next if defined $1; # comment or whitespace
+
+ if (defined $2 or defined $3) {
+ # A comma is not required after a '}' so to aid the
+ # parser we insert a fake token after any '}'
+ push @stacked, constPOSTRBRACE() if defined $2 and $+ eq '}';
+
+ return $reserved{$yylval = $+};
+ }
+
+ if (defined $4) {
+ ($yylval = $+) =~ s/\s+/_/g;
+ return constWORD();
+ }
+
+ if (defined $5) {
+ $yylval = $+;
+ return constWORD();
+ }
+
+ if (defined $6) {
+ my($class,$num) = ($+ =~ /^([A-Z]*)\s*(\d+)$/);
+ $yylval = asn_tag($tag_class{$class}, $num);
+ return constCLASS();
+ }
+
+ if (defined $7) {
+ $yylval = $+;
+ return constNUMBER();
+ }
+
+ die "Internal error\n";
+
+ }
+
+ die "Parse error before ",substr($asn,$pos,40),"\n"
+ unless $pos == length($asn);
+
+ 0
+}
+
+sub yyerror {
+ die @_," ",substr($asn,$last_pos,40),"\n";
+}
+
+1;
+
+%yystate = ('State51','','State34','','State11','','State33','','State24',
+'','State40','','State31','','State37','','State23','','State22','',
+'State21','','State57','','State39','','State56','','State20','','State25',
+'','State38','','State14','','State19','','State46','','State5','',
+'State53','','State26','','State27','','State50','','State36','','State4',
+'','State3','','State32','','State49','','State30','','State35','',
+'State48','','State55','','State42','','State28','','State58','','State41',
+'','State18','','State59','','State1','','State54','','State60',
+'');
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/PEM.pm b/Master/tlpkg/tlperl.straw/lib/Convert/PEM.pm
new file mode 100755
index 00000000000..f6668bf3d87
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/PEM.pm
@@ -0,0 +1,472 @@
+# $Id: PEM.pm 1829 2005-05-25 21:51:40Z btrott $
+
+package Convert::PEM;
+use strict;
+use base qw( Class::ErrorHandler );
+
+use MIME::Base64;
+use Digest::MD5 qw( md5 );
+use Convert::ASN1;
+use Carp qw( croak );
+use Convert::PEM::CBC;
+
+use vars qw( $VERSION );
+$VERSION = '0.07';
+
+sub new {
+ my $class = shift;
+ my $pem = bless { }, $class;
+ $pem->init(@_);
+}
+
+sub init {
+ my $pem = shift;
+ my %param = @_;
+ unless (exists $param{ASN} && exists $param{Name}) {
+ return (ref $pem)->error("init: Name and ASN are required");
+ }
+ else {
+ $pem->{ASN} = $param{ASN};
+ $pem->{Name} = $param{Name};
+ }
+ $pem->{Macro} = $param{Macro};
+ my $asn = $pem->{_asn} = Convert::ASN1->new;
+ $asn->prepare( $pem->{ASN} ) or
+ return (ref $pem)->error("ASN prepare failed: $asn->{error}");
+ $pem;
+}
+
+sub asn { $_[0]->{_asn} }
+sub ASN { $_[0]->{ASN} }
+sub name { $_[0]->{Name} }
+
+sub read {
+ my $pem = shift;
+ my %param = @_;
+
+ my $blob;
+ local *FH;
+ my $fname = delete $param{Filename};
+ open FH, $fname or
+ return $pem->error("Can't open $fname: $!");
+ $blob = do { local $/; <FH> };
+ close FH;
+
+ $param{Content} = $blob;
+ $pem->decode(%param);
+}
+
+sub write {
+ my $pem = shift;
+ my %param = @_;
+
+ my $fname = delete $param{Filename} or
+ return $pem->error("write: Filename is required");
+ my $blob = $pem->encode(%param);
+
+ local *FH;
+ open FH, ">$fname" or
+ return $pem->error("Can't open $fname: $!");
+ print FH $blob;
+ close FH;
+ $blob;
+}
+
+sub decode {
+ my $pem = shift;
+ my %param = @_;
+ my $blob = $param{Content} or
+ return $pem->error("'Content' is required");
+ chomp $blob;
+
+ my $dec = $pem->explode($blob) or return;
+ my $name = $param{Name} || $pem->name;
+ return $pem->error("Object $dec->{Object} does not match " . $name)
+ unless $dec->{Object} eq $name;
+
+ my $head = $dec->{Headers};
+ my $buf = $dec->{Content};
+ my %headers = map { $_->[0] => $_->[1] } @$head;
+ if (%headers && $headers{'Proc-Type'} eq '4,ENCRYPTED') {
+ $buf = $pem->decrypt( Ciphertext => $buf,
+ Info => $headers{'DEK-Info'},
+ Password => $param{Password} )
+ or return;
+ }
+
+ my $asn = $pem->asn;
+ if (my $macro = ($param{Macro} || $pem->{Macro})) {
+ $asn = $asn->find($macro) or
+ return $pem->error("Can't find Macro $macro");
+ }
+ my $obj = $asn->decode($buf) or
+ return $pem->error("ASN decode failed: $asn->{error}");
+
+ $obj;
+}
+
+sub encode {
+ my $pem = shift;
+ my %param = @_;
+
+ my $asn = $pem->asn;
+ if (my $macro = ($param{Macro} || $pem->{Macro})) {
+ $asn = $asn->find($macro) or
+ return $pem->error("Can't find Macro $macro");
+ }
+ my $buf = $asn->encode( $param{Content} ) or
+ return $pem->error("ASN encode failed: $asn->{error}");
+
+ my(@headers);
+ if ($param{Password}) {
+ my($info);
+ ($buf, $info) = $pem->encrypt( Plaintext => $buf,
+ Password => $param{Password} )
+ or return;
+ push @headers, [ 'Proc-Type' => '4,ENCRYPTED' ];
+ push @headers, [ 'DEK-Info' => $info ];
+ }
+
+ $pem->implode( Object => $param{Name} || $pem->name,
+ Headers => \@headers,
+ Content => $buf );
+}
+
+sub explode {
+ my $pem = shift;
+ my($message) = @_;
+ my($head, $object, $headers, $content, $tail) = $message =~
+ m:(-----BEGIN ([^\n\-]+)-----)\n(.*?\n\n)?(.+)(-----END .*?-----)$:s;
+ my $buf = decode_base64($content);
+
+ my @headers;
+ if ($headers) {
+ for my $h ( split /\n/, $headers ) {
+ my($k, $v) = split /:\s*/, $h, 2;
+ push @headers, [ $k => $v ] if $k;
+ }
+ }
+
+ { Content => $buf,
+ Object => $object,
+ Headers => \@headers }
+}
+
+sub implode {
+ my $pem = shift;
+ my %param = @_;
+ my $head = "-----BEGIN $param{Object}-----";
+ my $tail = "-----END $param{Object}-----";
+ my $content = encode_base64( $param{Content}, '' );
+ $content =~ s!(.{1,64})!$1\n!g;
+ my $headers = join '',
+ map { "$_->[0]: $_->[1]\n" }
+ @{ $param{Headers} };
+ $headers .= "\n" if $headers;
+ "$head\n$headers$content$tail\n";
+}
+
+use vars qw( %CTYPES );
+%CTYPES = ('DES-EDE3-CBC' => 'Crypt::DES_EDE3');
+
+sub decrypt {
+ my $pem = shift;
+ my %param = @_;
+ my $passphrase = $param{Password} || "";
+ my($ctype, $iv) = split /,/, $param{Info};
+ my $cmod = $CTYPES{$ctype} or
+ return $pem->error("Unrecognized cipher: '$ctype'");
+ $iv = pack "H*", $iv;
+ my $cbc = Convert::PEM::CBC->new(
+ Passphrase => $passphrase,
+ Cipher => $cmod,
+ IV => $iv );
+ my $buf = $cbc->decrypt($param{Ciphertext}) or
+ return $pem->error("Decryption failed: " . $cbc->errstr);
+ $buf;
+}
+
+sub encrypt {
+ my $pem = shift;
+ my %param = @_;
+ $param{Password} or return $param{Plaintext};
+ my $ctype = $param{Cipher} || 'DES-EDE3-CBC';
+ my $cmod = $CTYPES{$ctype} or
+ return $pem->error("Unrecognized cipher: '$ctype'");
+ my $cbc = Convert::PEM::CBC->new(
+ Passphrase => $param{Password},
+ Cipher => $cmod );
+ my $iv = uc join '', unpack "H*", $cbc->iv;
+ my $buf = $cbc->encrypt($param{Plaintext}) or
+ return $pem->error("Encryption failed: " . $cbc->errstr);
+ ($buf, "$ctype,$iv");
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Convert::PEM - Read/write encrypted ASN.1 PEM files
+
+=head1 SYNOPSIS
+
+ use Convert::PEM;
+ my $pem = Convert::PEM->new(
+ Name => "DSA PRIVATE KEY",
+ ASN => qq(
+ DSAPrivateKey SEQUENCE {
+ version INTEGER,
+ p INTEGER,
+ q INTEGER,
+ g INTEGER,
+ pub_key INTEGER,
+ priv_key INTEGER
+ }
+ ));
+
+ my $pkey = $pem->read(
+ Filename => $keyfile,
+ Password => $pwd
+ );
+
+ $pem->write(
+ Content => $pkey,
+ Password => $pwd,
+ Filename => $keyfile
+ );
+
+=head1 DESCRIPTION
+
+I<Convert::PEM> reads and writes PEM files containing ASN.1-encoded
+objects. The files can optionally be encrypted using a symmetric
+cipher algorithm, such as 3DES. An unencrypted PEM file might look
+something like this:
+
+ -----BEGIN DH PARAMETERS-----
+ MB4CGQDUoLoCULb9LsYm5+/WN992xxbiLQlEuIsCAQM=
+ -----END DH PARAMETERS-----
+
+The string beginning C<MB4C...> is the Base64-encoded, ASN.1-encoded
+"object."
+
+An encrypted file would have headers describing the type of
+encryption used, and the initialization vector:
+
+ -----BEGIN DH PARAMETERS-----
+ Proc-Type: 4,ENCRYPTED
+ DEK-Info: DES-EDE3-CBC,C814158661DC1449
+
+ AFAZFbnQNrGjZJ/ZemdVSoZa3HWujxZuvBHzHNoesxeyqqidFvnydA==
+ -----END DH PARAMETERS-----
+
+The two headers (C<Proc-Type> and C<DEK-Info>) indicate information
+about the type of encryption used, and the string starting with
+C<AFAZ...> is the Base64-encoded, encrypted, ASN.1-encoded
+contents of this "object."
+
+The initialization vector (C<C814158661DC1449>) is chosen randomly.
+
+=head1 USAGE
+
+=head2 $pem = Convert::PEM->new( %arg )
+
+Constructs a new I<Convert::PEM> object designed to read/write an
+object of a specific type (given in I<%arg>, see below). Returns the
+new object on success, C<undef> on failure (see I<ERROR HANDLING> for
+details).
+
+I<%arg> can contain:
+
+=over 4
+
+=item * Name
+
+The name of the object; when decoding a PEM-encoded stream, the name
+in the encoding will be checked against the value of I<Name>.
+Similarly, when encoding an object, the value of I<Name> will be used
+as the name of the object in the PEM-encoded content. For example, given
+the string C<FOO BAR>, the output from I<encode> will start with a
+header like:
+
+ -----BEGIN FOO BAR-----
+
+I<Name> is a required argument.
+
+=item * ASN
+
+An ASN.1 description of the content to be either encoded or decoded.
+
+I<ASN> is a required argument.
+
+=item * Macro
+
+If your ASN.1 description (in the I<ASN> parameter) includes more than
+one ASN.1 macro definition, you will want to use the I<Macro> parameter
+to specify which definition to use when encoding/decoding objects.
+For example, if your ASN.1 description looks like this:
+
+ Foo ::= SEQUENCE {
+ x INTEGER,
+ bar Bar
+ }
+
+ Bar ::= INTEGER
+
+If you want to encode/decode a C<Foo> object, you will need to tell
+I<Convert::PEM> to use the C<Foo> macro definition by using the I<Macro>
+parameter and setting the value to C<Foo>.
+
+I<Macro> is an optional argument.
+
+=back
+
+=head2 $obj = $pem->decode(%args)
+
+Decodes, and, optionally, decrypts a PEM file, returning the
+object as decoded by I<Convert::ASN1>. The difference between this
+method and I<read> is that I<read> reads the contents of a PEM file
+on disk; this method expects you to pass the PEM contents as an
+argument.
+
+If an error occurs while reading the file or decrypting/decoding
+the contents, the function returns I<undef>, and you should check
+the error message using the I<errstr> method (below).
+
+I<%args> can contain:
+
+=over 4
+
+=item * Content
+
+The PEM contents.
+
+=item * Password
+
+The password with which the file contents were encrypted.
+
+If the file is encrypted, this is a mandatory argument (well, it's
+not strictly mandatory, but decryption isn't going to work without
+it). Otherwise it's not necessary.
+
+=back
+
+=head2 $blob = $pem->encode(%args)
+
+Constructs the contents for the PEM file from an object: ASN.1-encodes
+the object, optionally encrypts those contents.
+
+Returns I<undef> on failure (encryption failure, file-writing failure,
+etc.); in this case you should check the error message using the
+I<errstr> method (below). On success returns the constructed PEM string.
+
+I<%args> can contain:
+
+=over 4
+
+=item * Content
+
+A hash reference that will be passed to I<Convert::ASN1::encode>,
+and which should correspond to the ASN.1 description you gave to the
+I<new> method. The hash reference should have the exact same format
+as that returned from the I<read> method.
+
+This argument is mandatory.
+
+=item * Password
+
+A password used to encrypt the contents of the PEM file. This is an
+optional argument; if not provided the contents will be unencrypted.
+
+=back
+
+=head2 $obj = $pem->read(%args)
+
+Reads, decodes, and, optionally, decrypts a PEM file, returning
+the object as decoded by I<Convert::ASN1>. This is implemented
+as a wrapper around I<decode>, with the bonus of reading the PEM
+file from disk for you.
+
+If an error occurs while reading the file or decrypting/decoding
+the contents, the function returns I<undef>, and you should check
+the error message using the I<errstr> method (below).
+
+In addition to the arguments that can be passed to the I<decode>
+method (minus the I<Content> method), I<%args> can contain:
+
+=over 4
+
+=item * Filename
+
+The location of the PEM file that you wish to read.
+
+=back
+
+=head2 $pem->write(%args)
+
+Constructs the contents for the PEM file from an object: ASN.1-encodes
+the object, optionally encrypts those contents; then writes the file
+to disk. This is implemented as a wrapper around I<encode>, with the
+bonus of writing the file to disk for you.
+
+Returns I<undef> on failure (encryption failure, file-writing failure,
+etc.); in this case you should check the error message using the
+I<errstr> method (below). On success returns the constructed PEM string.
+
+In addition to the arguments for I<encode>, I<%args> can contain:
+
+=over 4
+
+=item * Filename
+
+The location on disk where you'd like the PEM file written.
+
+=back
+
+=head2 $pem->errstr
+
+Returns the value of the last error that occurred. This should only
+be considered meaningful when you've received I<undef> from one of
+the functions above; in all other cases its relevance is undefined.
+
+=head2 $pem->asn
+
+Returns the I<Convert::ASN1> object used internally to decode and
+encode ASN.1 representations. This is useful when you wish to
+interact directly with that object; for example, if you need to
+call I<configure> on that object to set the type of big-integer
+class to be used when decoding/encoding big integers:
+
+ $pem->asn->configure( decode => { bigint => 'Math::Pari' },
+ encode => { bigint => 'Math::Pari' } );
+
+=head1 ERROR HANDLING
+
+If an error occurs in any of the above methods, the method will return
+C<undef>. You should then call the method I<errstr> to determine the
+source of the error:
+
+ $pem->errstr
+
+In the case that you do not yet have a I<Convert::PEM> object (that is,
+if an error occurs while creating a I<Convert::PEM> object), the error
+can be obtained as a class method:
+
+ Convert::PEM->errstr
+
+For example, if you try to decode an encrypted object, and you do not
+give a passphrase to decrypt the object:
+
+ my $obj = $pem->read( Filename => "encrypted.pem" )
+ or die "Decryption failed: ", $pem->errstr;
+
+=head1 AUTHOR & COPYRIGHTS
+
+Benjamin Trott, ben@rhumba.pair.com
+
+Except where otherwise noted, Convert::PEM is Copyright 2001
+Benjamin Trott. All rights reserved. Convert::PEM is free
+software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm b/Master/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm
new file mode 100755
index 00000000000..971a272151a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm
@@ -0,0 +1,227 @@
+# $Id: CBC.pm 1829 2005-05-25 21:51:40Z btrott $
+
+package Convert::PEM::CBC;
+use strict;
+
+use Carp qw( croak );
+use Digest::MD5 qw( md5 );
+use base qw( Class::ErrorHandler );
+
+sub new {
+ my $class = shift;
+ my $cbc = bless { }, $class;
+ $cbc->init(@_);
+}
+
+sub init {
+ my $cbc = shift;
+ my %param = @_;
+ $cbc->{iv} = exists $param{IV} ? $param{IV} :
+ pack("C*", map { rand 255 } 1..8);
+ croak "init: Cipher is required"
+ unless my $cipher = $param{Cipher};
+ if (ref($cipher)) {
+ $cbc->{cipher} = $cipher;
+ }
+ else {
+ eval "use $cipher;";
+ croak "Loading '$cipher' failed: $@" if $@;
+ my $key = $param{Key};
+ if (!$key && exists $param{Passphrase}) {
+ $key = bytes_to_key($param{Passphrase}, $cbc->{iv},
+ \&md5, $cipher->keysize);
+ }
+ croak "init: either Key or Passphrase required"
+ unless $key;
+ $cbc->{cipher} = $cipher->new($key);
+ }
+ $cbc;
+}
+
+sub iv { $_[0]->{iv} }
+
+sub encrypt {
+ my $cbc = shift;
+ my($text) = @_;
+ my $cipher = $cbc->{cipher};
+ my $bs = $cipher->blocksize;
+ my @blocks = $text =~ /(.{1,$bs})/ogs;
+ my $last = pop @blocks if length($blocks[-1]) < $bs;
+ my $iv = $cbc->{iv};
+ my $buf = '';
+ for my $block (@blocks) {
+ $buf .= $iv = $cipher->encrypt($iv ^ $block);
+ }
+ $last = pack("C*", ($bs) x $bs) unless $last && length $last;
+ if (length $last) {
+ $last .= pack("C*", ($bs-length($last)) x ($bs-length($last)))
+ if length($last) < $bs;
+ $buf .= $iv = $cipher->encrypt($iv ^ $last);
+ }
+ $cbc->{iv} = $iv;
+ $buf;
+}
+
+sub decrypt {
+ my $cbc = shift;
+ my($text) = @_;
+ my $cipher = $cbc->{cipher};
+ my $bs = $cipher->blocksize;
+ my @blocks = $text =~ /(.{1,$bs})/ogs;
+ my $last = length($blocks[-1]) < $bs ?
+ join '', splice(@blocks, -2) : pop @blocks;
+ my $iv = $cbc->{iv};
+ my $buf = '';
+ for my $block (@blocks) {
+ $buf .= $iv ^ $cipher->decrypt($block);
+ $iv = $block;
+ }
+ $last = pack "a$bs", $last;
+ if (length($last)) {
+ my $tmp = $iv ^ $cipher->decrypt($last);
+ $iv = $last;
+ $last = $tmp;
+ my $cut = ord substr $last, -1;
+ return $cbc->error("Bad key/passphrase")
+ if $cut > $bs;
+ substr($last, -$cut) = '';
+ $buf .= $last;
+ }
+ $cbc->{iv} = $iv;
+ $buf;
+}
+
+sub bytes_to_key {
+ my($key, $salt, $md, $ks) = @_;
+ my $ckey = $md->($key, $salt);
+ while (length($ckey) < $ks) {
+ $ckey .= $md->($ckey, $key, $salt);
+ }
+ substr $ckey, 0, $ks;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Convert::PEM::CBC - Cipher Block Chaining Mode implementation
+
+=head1 SYNOPSIS
+
+ use Convert::PEM::CBC;
+ my $cbc = Convert::PEM::CBC->new(
+ Cipher => 'Crypt::DES_EDE3',
+ Passphrase => 'foo'
+ );
+
+ $cbc->encrypt($plaintext);
+
+=head1 DESCRIPTION
+
+I<Convert::PEM::CBC> implements the CBC (Cipher Block Chaining)
+mode for encryption/decryption ciphers; the CBC is designed for
+compatability with OpenSSL and may not be compatible with other
+implementations (such as SSH).
+
+=head1 USAGE
+
+=head2 $cbc = Convert::PEM::CBC->new(%args)
+
+Creates a new I<Convert::PEM::CBC> object and initializes it.
+Returns the new object.
+
+I<%args> can contain:
+
+=over 4
+
+=item * Cipher
+
+Either the name of an encryption cipher class (eg. I<Crypt::DES>),
+or an object already blessed into such a class. The class must
+support the I<keysize>, I<blocksize>, I<encrypt>, and I<decrypt>
+methods. If the value is a blessed object, it is assumed that the
+object has already been initialized with a key.
+
+This argument is mandatory.
+
+=item * Passphrase
+
+A passphrase to encrypt/decrypt the content. This is different in
+implementation from a key (I<Key>), because it is assumed that a
+passphrase comes directly from a user, and must be munged into the
+correct form for a key. This "munging" is done by repeatedly
+computing an MD5 hash of the passphrase, the IV, and the existing
+hash, until the generated key is longer than the keysize for the
+cipher (I<Cipher>).
+
+Because of this "munging", this argument can be any length (even
+an empty string).
+
+If you give the I<Cipher> argument an object, this argument is
+ignored. If the I<Cipher> argument is a cipher class, either this
+argument or I<Key> must be provided.
+
+=item * Key
+
+A raw key, to be passed directly to the new cipher object. Because
+this is passed directly to the cipher itself, the length of the
+key must be equal to or greater than the keysize for the I<Cipher>.
+
+As with the I<Passphrase> argument, if you give the I<Cipher>
+argument an already-constructed cipher object, this argument is
+ignored. If the I<Cipher> argument is a cipher class, either this
+argument or I<Passphrase> must be provided.
+
+=item * IV
+
+The initialization vector for CBC mode.
+
+This argument is optional; if not provided, a random IV will be
+generated. Obviously, if you're decrypting data, you should provide
+this argument, because your IV should match the IV used to encrypt
+the data.
+
+=back
+
+=head2 $cbc->encrypt($plaintext)
+
+Encrypts the plaintext I<$plaintext> using the underlying cipher
+implementation in CBC mode, and returns the ciphertext.
+
+If any errors occur, returns I<undef>, and you should check the
+I<errstr> method to find out what went wrong.
+
+=head2 $cbc->decrypt($ciphertext)
+
+Decrypts the ciphertext I<$ciphertext> using the underlying
+cipher implementation in CBC mode, and returns the plaintext.
+
+If any errors occur, returns I<undef>, and you should check the
+I<errstr> method to find out what went wrong.
+
+=head2 $cbc->iv
+
+Returns the current initialization vector. One use for this might be
+to grab the initial value of the IV if it's created randomly (ie.
+you haven't provided an I<IV> argument to I<new>):
+
+ my $cbc = Convert::PEM::CBC->new( Cipher => $cipher );
+ my $iv = $cbc->iv; ## Generated randomly in 'new'.
+
+I<Convert::PEM> uses this to write the IV to the PEM file when
+encrypting, so that it can be known when trying to decrypt the
+file.
+
+=head2 $cbc->errstr
+
+Returns the value of the last error that occurred. This should only
+be considered meaningful when you've received I<undef> from one of
+the functions above; in all other cases its relevance is undefined.
+
+=head1 AUTHOR & COPYRIGHTS
+
+Please see the Convert::PEM manpage for author, copyright, and
+license information.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Crypt/CAST5_PP/Tables.pm b/Master/tlpkg/tlperl.straw/lib/Crypt/CAST5_PP/Tables.pm
new file mode 100755
index 00000000000..0713957a658
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Crypt/CAST5_PP/Tables.pm
@@ -0,0 +1,375 @@
+# Crypt::CAST5_PP::Tables
+# S-box tables for CAST5 encryption
+
+use strict;
+use integer;
+
+@Crypt::CAST5_PP::s1 = (
+0x30fb40d4, 0x9fa0ff0b, 0x6beccd2f, 0x3f258c7a, 0x1e213f2f, 0x9c004dd3,
+0x6003e540, 0xcf9fc949, 0xbfd4af27, 0x88bbbdb5, 0xe2034090, 0x98d09675,
+0x6e63a0e0, 0x15c361d2, 0xc2e7661d, 0x22d4ff8e, 0x28683b6f, 0xc07fd059,
+0xff2379c8, 0x775f50e2, 0x43c340d3, 0xdf2f8656, 0x887ca41a, 0xa2d2bd2d,
+0xa1c9e0d6, 0x346c4819, 0x61b76d87, 0x22540f2f, 0x2abe32e1, 0xaa54166b,
+0x22568e3a, 0xa2d341d0, 0x66db40c8, 0xa784392f, 0x004dff2f, 0x2db9d2de,
+0x97943fac, 0x4a97c1d8, 0x527644b7, 0xb5f437a7, 0xb82cbaef, 0xd751d159,
+0x6ff7f0ed, 0x5a097a1f, 0x827b68d0, 0x90ecf52e, 0x22b0c054, 0xbc8e5935,
+0x4b6d2f7f, 0x50bb64a2, 0xd2664910, 0xbee5812d, 0xb7332290, 0xe93b159f,
+0xb48ee411, 0x4bff345d, 0xfd45c240, 0xad31973f, 0xc4f6d02e, 0x55fc8165,
+0xd5b1caad, 0xa1ac2dae, 0xa2d4b76d, 0xc19b0c50, 0x882240f2, 0x0c6e4f38,
+0xa4e4bfd7, 0x4f5ba272, 0x564c1d2f, 0xc59c5319, 0xb949e354, 0xb04669fe,
+0xb1b6ab8a, 0xc71358dd, 0x6385c545, 0x110f935d, 0x57538ad5, 0x6a390493,
+0xe63d37e0, 0x2a54f6b3, 0x3a787d5f, 0x6276a0b5, 0x19a6fcdf, 0x7a42206a,
+0x29f9d4d5, 0xf61b1891, 0xbb72275e, 0xaa508167, 0x38901091, 0xc6b505eb,
+0x84c7cb8c, 0x2ad75a0f, 0x874a1427, 0xa2d1936b, 0x2ad286af, 0xaa56d291,
+0xd7894360, 0x425c750d, 0x93b39e26, 0x187184c9, 0x6c00b32d, 0x73e2bb14,
+0xa0bebc3c, 0x54623779, 0x64459eab, 0x3f328b82, 0x7718cf82, 0x59a2cea6,
+0x04ee002e, 0x89fe78e6, 0x3fab0950, 0x325ff6c2, 0x81383f05, 0x6963c5c8,
+0x76cb5ad6, 0xd49974c9, 0xca180dcf, 0x380782d5, 0xc7fa5cf6, 0x8ac31511,
+0x35e79e13, 0x47da91d0, 0xf40f9086, 0xa7e2419e, 0x31366241, 0x051ef495,
+0xaa573b04, 0x4a805d8d, 0x548300d0, 0x00322a3c, 0xbf64cddf, 0xba57a68e,
+0x75c6372b, 0x50afd341, 0xa7c13275, 0x915a0bf5, 0x6b54bfab, 0x2b0b1426,
+0xab4cc9d7, 0x449ccd82, 0xf7fbf265, 0xab85c5f3, 0x1b55db94, 0xaad4e324,
+0xcfa4bd3f, 0x2deaa3e2, 0x9e204d02, 0xc8bd25ac, 0xeadf55b3, 0xd5bd9e98,
+0xe31231b2, 0x2ad5ad6c, 0x954329de, 0xadbe4528, 0xd8710f69, 0xaa51c90f,
+0xaa786bf6, 0x22513f1e, 0xaa51a79b, 0x2ad344cc, 0x7b5a41f0, 0xd37cfbad,
+0x1b069505, 0x41ece491, 0xb4c332e6, 0x032268d4, 0xc9600acc, 0xce387e6d,
+0xbf6bb16c, 0x6a70fb78, 0x0d03d9c9, 0xd4df39de, 0xe01063da, 0x4736f464,
+0x5ad328d8, 0xb347cc96, 0x75bb0fc3, 0x98511bfb, 0x4ffbcc35, 0xb58bcf6a,
+0xe11f0abc, 0xbfc5fe4a, 0xa70aec10, 0xac39570a, 0x3f04442f, 0x6188b153,
+0xe0397a2e, 0x5727cb79, 0x9ceb418f, 0x1cacd68d, 0x2ad37c96, 0x0175cb9d,
+0xc69dff09, 0xc75b65f0, 0xd9db40d8, 0xec0e7779, 0x4744ead4, 0xb11c3274,
+0xdd24cb9e, 0x7e1c54bd, 0xf01144f9, 0xd2240eb1, 0x9675b3fd, 0xa3ac3755,
+0xd47c27af, 0x51c85f4d, 0x56907596, 0xa5bb15e6, 0x580304f0, 0xca042cf1,
+0x011a37ea, 0x8dbfaadb, 0x35ba3e4a, 0x3526ffa0, 0xc37b4d09, 0xbc306ed9,
+0x98a52666, 0x5648f725, 0xff5e569d, 0x0ced63d0, 0x7c63b2cf, 0x700b45e1,
+0xd5ea50f1, 0x85a92872, 0xaf1fbda7, 0xd4234870, 0xa7870bf3, 0x2d3b4d79,
+0x42e04198, 0x0cd0ede7, 0x26470db8, 0xf881814c, 0x474d6ad7, 0x7c0c5e5c,
+0xd1231959, 0x381b7298, 0xf5d2f4db, 0xab838653, 0x6e2f1e23, 0x83719c9e,
+0xbd91e046, 0x9a56456e, 0xdc39200c, 0x20c8c571, 0x962bda1c, 0xe1e696ff,
+0xb141ab08, 0x7cca89b9, 0x1a69e783, 0x02cc4843, 0xa2f7c579, 0x429ef47d,
+0x427b169c, 0x5ac9f049, 0xdd8f0f00, 0x5c8165bf,
+);
+
+@Crypt::CAST5_PP::s2 = (
+0x1f201094, 0xef0ba75b, 0x69e3cf7e, 0x393f4380, 0xfe61cf7a, 0xeec5207a,
+0x55889c94, 0x72fc0651, 0xada7ef79, 0x4e1d7235, 0xd55a63ce, 0xde0436ba,
+0x99c430ef, 0x5f0c0794, 0x18dcdb7d, 0xa1d6eff3, 0xa0b52f7b, 0x59e83605,
+0xee15b094, 0xe9ffd909, 0xdc440086, 0xef944459, 0xba83ccb3, 0xe0c3cdfb,
+0xd1da4181, 0x3b092ab1, 0xf997f1c1, 0xa5e6cf7b, 0x01420ddb, 0xe4e7ef5b,
+0x25a1ff41, 0xe180f806, 0x1fc41080, 0x179bee7a, 0xd37ac6a9, 0xfe5830a4,
+0x98de8b7f, 0x77e83f4e, 0x79929269, 0x24fa9f7b, 0xe113c85b, 0xacc40083,
+0xd7503525, 0xf7ea615f, 0x62143154, 0x0d554b63, 0x5d681121, 0xc866c359,
+0x3d63cf73, 0xcee234c0, 0xd4d87e87, 0x5c672b21, 0x071f6181, 0x39f7627f,
+0x361e3084, 0xe4eb573b, 0x602f64a4, 0xd63acd9c, 0x1bbc4635, 0x9e81032d,
+0x2701f50c, 0x99847ab4, 0xa0e3df79, 0xba6cf38c, 0x10843094, 0x2537a95e,
+0xf46f6ffe, 0xa1ff3b1f, 0x208cfb6a, 0x8f458c74, 0xd9e0a227, 0x4ec73a34,
+0xfc884f69, 0x3e4de8df, 0xef0e0088, 0x3559648d, 0x8a45388c, 0x1d804366,
+0x721d9bfd, 0xa58684bb, 0xe8256333, 0x844e8212, 0x128d8098, 0xfed33fb4,
+0xce280ae1, 0x27e19ba5, 0xd5a6c252, 0xe49754bd, 0xc5d655dd, 0xeb667064,
+0x77840b4d, 0xa1b6a801, 0x84db26a9, 0xe0b56714, 0x21f043b7, 0xe5d05860,
+0x54f03084, 0x066ff472, 0xa31aa153, 0xdadc4755, 0xb5625dbf, 0x68561be6,
+0x83ca6b94, 0x2d6ed23b, 0xeccf01db, 0xa6d3d0ba, 0xb6803d5c, 0xaf77a709,
+0x33b4a34c, 0x397bc8d6, 0x5ee22b95, 0x5f0e5304, 0x81ed6f61, 0x20e74364,
+0xb45e1378, 0xde18639b, 0x881ca122, 0xb96726d1, 0x8049a7e8, 0x22b7da7b,
+0x5e552d25, 0x5272d237, 0x79d2951c, 0xc60d894c, 0x488cb402, 0x1ba4fe5b,
+0xa4b09f6b, 0x1ca815cf, 0xa20c3005, 0x8871df63, 0xb9de2fcb, 0x0cc6c9e9,
+0x0beeff53, 0xe3214517, 0xb4542835, 0x9f63293c, 0xee41e729, 0x6e1d2d7c,
+0x50045286, 0x1e6685f3, 0xf33401c6, 0x30a22c95, 0x31a70850, 0x60930f13,
+0x73f98417, 0xa1269859, 0xec645c44, 0x52c877a9, 0xcdff33a6, 0xa02b1741,
+0x7cbad9a2, 0x2180036f, 0x50d99c08, 0xcb3f4861, 0xc26bd765, 0x64a3f6ab,
+0x80342676, 0x25a75e7b, 0xe4e6d1fc, 0x20c710e6, 0xcdf0b680, 0x17844d3b,
+0x31eef84d, 0x7e0824e4, 0x2ccb49eb, 0x846a3bae, 0x8ff77888, 0xee5d60f6,
+0x7af75673, 0x2fdd5cdb, 0xa11631c1, 0x30f66f43, 0xb3faec54, 0x157fd7fa,
+0xef8579cc, 0xd152de58, 0xdb2ffd5e, 0x8f32ce19, 0x306af97a, 0x02f03ef8,
+0x99319ad5, 0xc242fa0f, 0xa7e3ebb0, 0xc68e4906, 0xb8da230c, 0x80823028,
+0xdcdef3c8, 0xd35fb171, 0x088a1bc8, 0xbec0c560, 0x61a3c9e8, 0xbca8f54d,
+0xc72feffa, 0x22822e99, 0x82c570b4, 0xd8d94e89, 0x8b1c34bc, 0x301e16e6,
+0x273be979, 0xb0ffeaa6, 0x61d9b8c6, 0x00b24869, 0xb7ffce3f, 0x08dc283b,
+0x43daf65a, 0xf7e19798, 0x7619b72f, 0x8f1c9ba4, 0xdc8637a0, 0x16a7d3b1,
+0x9fc393b7, 0xa7136eeb, 0xc6bcc63e, 0x1a513742, 0xef6828bc, 0x520365d6,
+0x2d6a77ab, 0x3527ed4b, 0x821fd216, 0x095c6e2e, 0xdb92f2fb, 0x5eea29cb,
+0x145892f5, 0x91584f7f, 0x5483697b, 0x2667a8cc, 0x85196048, 0x8c4bacea,
+0x833860d4, 0x0d23e0f9, 0x6c387e8a, 0x0ae6d249, 0xb284600c, 0xd835731d,
+0xdcb1c647, 0xac4c56ea, 0x3ebd81b3, 0x230eabb0, 0x6438bc87, 0xf0b5b1fa,
+0x8f5ea2b3, 0xfc184642, 0x0a036b7a, 0x4fb089bd, 0x649da589, 0xa345415e,
+0x5c038323, 0x3e5d3bb9, 0x43d79572, 0x7e6dd07c, 0x06dfdf1e, 0x6c6cc4ef,
+0x7160a539, 0x73bfbe70, 0x83877605, 0x4523ecf1,
+);
+
+@Crypt::CAST5_PP::s3 = (
+0x8defc240, 0x25fa5d9f, 0xeb903dbf, 0xe810c907, 0x47607fff, 0x369fe44b,
+0x8c1fc644, 0xaececa90, 0xbeb1f9bf, 0xeefbcaea, 0xe8cf1950, 0x51df07ae,
+0x920e8806, 0xf0ad0548, 0xe13c8d83, 0x927010d5, 0x11107d9f, 0x07647db9,
+0xb2e3e4d4, 0x3d4f285e, 0xb9afa820, 0xfade82e0, 0xa067268b, 0x8272792e,
+0x553fb2c0, 0x489ae22b, 0xd4ef9794, 0x125e3fbc, 0x21fffcee, 0x825b1bfd,
+0x9255c5ed, 0x1257a240, 0x4e1a8302, 0xbae07fff, 0x528246e7, 0x8e57140e,
+0x3373f7bf, 0x8c9f8188, 0xa6fc4ee8, 0xc982b5a5, 0xa8c01db7, 0x579fc264,
+0x67094f31, 0xf2bd3f5f, 0x40fff7c1, 0x1fb78dfc, 0x8e6bd2c1, 0x437be59b,
+0x99b03dbf, 0xb5dbc64b, 0x638dc0e6, 0x55819d99, 0xa197c81c, 0x4a012d6e,
+0xc5884a28, 0xccc36f71, 0xb843c213, 0x6c0743f1, 0x8309893c, 0x0feddd5f,
+0x2f7fe850, 0xd7c07f7e, 0x02507fbf, 0x5afb9a04, 0xa747d2d0, 0x1651192e,
+0xaf70bf3e, 0x58c31380, 0x5f98302e, 0x727cc3c4, 0x0a0fb402, 0x0f7fef82,
+0x8c96fdad, 0x5d2c2aae, 0x8ee99a49, 0x50da88b8, 0x8427f4a0, 0x1eac5790,
+0x796fb449, 0x8252dc15, 0xefbd7d9b, 0xa672597d, 0xada840d8, 0x45f54504,
+0xfa5d7403, 0xe83ec305, 0x4f91751a, 0x925669c2, 0x23efe941, 0xa903f12e,
+0x60270df2, 0x0276e4b6, 0x94fd6574, 0x927985b2, 0x8276dbcb, 0x02778176,
+0xf8af918d, 0x4e48f79e, 0x8f616ddf, 0xe29d840e, 0x842f7d83, 0x340ce5c8,
+0x96bbb682, 0x93b4b148, 0xef303cab, 0x984faf28, 0x779faf9b, 0x92dc560d,
+0x224d1e20, 0x8437aa88, 0x7d29dc96, 0x2756d3dc, 0x8b907cee, 0xb51fd240,
+0xe7c07ce3, 0xe566b4a1, 0xc3e9615e, 0x3cf8209d, 0x6094d1e3, 0xcd9ca341,
+0x5c76460e, 0x00ea983b, 0xd4d67881, 0xfd47572c, 0xf76cedd9, 0xbda8229c,
+0x127dadaa, 0x438a074e, 0x1f97c090, 0x081bdb8a, 0x93a07ebe, 0xb938ca15,
+0x97b03cff, 0x3dc2c0f8, 0x8d1ab2ec, 0x64380e51, 0x68cc7bfb, 0xd90f2788,
+0x12490181, 0x5de5ffd4, 0xdd7ef86a, 0x76a2e214, 0xb9a40368, 0x925d958f,
+0x4b39fffa, 0xba39aee9, 0xa4ffd30b, 0xfaf7933b, 0x6d498623, 0x193cbcfa,
+0x27627545, 0x825cf47a, 0x61bd8ba0, 0xd11e42d1, 0xcead04f4, 0x127ea392,
+0x10428db7, 0x8272a972, 0x9270c4a8, 0x127de50b, 0x285ba1c8, 0x3c62f44f,
+0x35c0eaa5, 0xe805d231, 0x428929fb, 0xb4fcdf82, 0x4fb66a53, 0x0e7dc15b,
+0x1f081fab, 0x108618ae, 0xfcfd086d, 0xf9ff2889, 0x694bcc11, 0x236a5cae,
+0x12deca4d, 0x2c3f8cc5, 0xd2d02dfe, 0xf8ef5896, 0xe4cf52da, 0x95155b67,
+0x494a488c, 0xb9b6a80c, 0x5c8f82bc, 0x89d36b45, 0x3a609437, 0xec00c9a9,
+0x44715253, 0x0a874b49, 0xd773bc40, 0x7c34671c, 0x02717ef6, 0x4feb5536,
+0xa2d02fff, 0xd2bf60c4, 0xd43f03c0, 0x50b4ef6d, 0x07478cd1, 0x006e1888,
+0xa2e53f55, 0xb9e6d4bc, 0xa2048016, 0x97573833, 0xd7207d67, 0xde0f8f3d,
+0x72f87b33, 0xabcc4f33, 0x7688c55d, 0x7b00a6b0, 0x947b0001, 0x570075d2,
+0xf9bb88f8, 0x8942019e, 0x4264a5ff, 0x856302e0, 0x72dbd92b, 0xee971b69,
+0x6ea22fde, 0x5f08ae2b, 0xaf7a616d, 0xe5c98767, 0xcf1febd2, 0x61efc8c2,
+0xf1ac2571, 0xcc8239c2, 0x67214cb8, 0xb1e583d1, 0xb7dc3e62, 0x7f10bdce,
+0xf90a5c38, 0x0ff0443d, 0x606e6dc6, 0x60543a49, 0x5727c148, 0x2be98a1d,
+0x8ab41738, 0x20e1be24, 0xaf96da0f, 0x68458425, 0x99833be5, 0x600d457d,
+0x282f9350, 0x8334b362, 0xd91d1120, 0x2b6d8da0, 0x642b1e31, 0x9c305a00,
+0x52bce688, 0x1b03588a, 0xf7baefd5, 0x4142ed9c, 0xa4315c11, 0x83323ec5,
+0xdfef4636, 0xa133c501, 0xe9d3531c, 0xee353783,
+);
+
+@Crypt::CAST5_PP::s4 = (
+0x9db30420, 0x1fb6e9de, 0xa7be7bef, 0xd273a298, 0x4a4f7bdb, 0x64ad8c57,
+0x85510443, 0xfa020ed1, 0x7e287aff, 0xe60fb663, 0x095f35a1, 0x79ebf120,
+0xfd059d43, 0x6497b7b1, 0xf3641f63, 0x241e4adf, 0x28147f5f, 0x4fa2b8cd,
+0xc9430040, 0x0cc32220, 0xfdd30b30, 0xc0a5374f, 0x1d2d00d9, 0x24147b15,
+0xee4d111a, 0x0fca5167, 0x71ff904c, 0x2d195ffe, 0x1a05645f, 0x0c13fefe,
+0x081b08ca, 0x05170121, 0x80530100, 0xe83e5efe, 0xac9af4f8, 0x7fe72701,
+0xd2b8ee5f, 0x06df4261, 0xbb9e9b8a, 0x7293ea25, 0xce84ffdf, 0xf5718801,
+0x3dd64b04, 0xa26f263b, 0x7ed48400, 0x547eebe6, 0x446d4ca0, 0x6cf3d6f5,
+0x2649abdf, 0xaea0c7f5, 0x36338cc1, 0x503f7e93, 0xd3772061, 0x11b638e1,
+0x72500e03, 0xf80eb2bb, 0xabe0502e, 0xec8d77de, 0x57971e81, 0xe14f6746,
+0xc9335400, 0x6920318f, 0x081dbb99, 0xffc304a5, 0x4d351805, 0x7f3d5ce3,
+0xa6c866c6, 0x5d5bcca9, 0xdaec6fea, 0x9f926f91, 0x9f46222f, 0x3991467d,
+0xa5bf6d8e, 0x1143c44f, 0x43958302, 0xd0214eeb, 0x022083b8, 0x3fb6180c,
+0x18f8931e, 0x281658e6, 0x26486e3e, 0x8bd78a70, 0x7477e4c1, 0xb506e07c,
+0xf32d0a25, 0x79098b02, 0xe4eabb81, 0x28123b23, 0x69dead38, 0x1574ca16,
+0xdf871b62, 0x211c40b7, 0xa51a9ef9, 0x0014377b, 0x041e8ac8, 0x09114003,
+0xbd59e4d2, 0xe3d156d5, 0x4fe876d5, 0x2f91a340, 0x557be8de, 0x00eae4a7,
+0x0ce5c2ec, 0x4db4bba6, 0xe756bdff, 0xdd3369ac, 0xec17b035, 0x06572327,
+0x99afc8b0, 0x56c8c391, 0x6b65811c, 0x5e146119, 0x6e85cb75, 0xbe07c002,
+0xc2325577, 0x893ff4ec, 0x5bbfc92d, 0xd0ec3b25, 0xb7801ab7, 0x8d6d3b24,
+0x20c763ef, 0xc366a5fc, 0x9c382880, 0x0ace3205, 0xaac9548a, 0xeca1d7c7,
+0x041afa32, 0x1d16625a, 0x6701902c, 0x9b757a54, 0x31d477f7, 0x9126b031,
+0x36cc6fdb, 0xc70b8b46, 0xd9e66a48, 0x56e55a79, 0x026a4ceb, 0x52437eff,
+0x2f8f76b4, 0x0df980a5, 0x8674cde3, 0xedda04eb, 0x17a9be04, 0x2c18f4df,
+0xb7747f9d, 0xab2af7b4, 0xefc34d20, 0x2e096b7c, 0x1741a254, 0xe5b6a035,
+0x213d42f6, 0x2c1c7c26, 0x61c2f50f, 0x6552daf9, 0xd2c231f8, 0x25130f69,
+0xd8167fa2, 0x0418f2c8, 0x001a96a6, 0x0d1526ab, 0x63315c21, 0x5e0a72ec,
+0x49bafefd, 0x187908d9, 0x8d0dbd86, 0x311170a7, 0x3e9b640c, 0xcc3e10d7,
+0xd5cad3b6, 0x0caec388, 0xf73001e1, 0x6c728aff, 0x71eae2a1, 0x1f9af36e,
+0xcfcbd12f, 0xc1de8417, 0xac07be6b, 0xcb44a1d8, 0x8b9b0f56, 0x013988c3,
+0xb1c52fca, 0xb4be31cd, 0xd8782806, 0x12a3a4e2, 0x6f7de532, 0x58fd7eb6,
+0xd01ee900, 0x24adffc2, 0xf4990fc5, 0x9711aac5, 0x001d7b95, 0x82e5e7d2,
+0x109873f6, 0x00613096, 0xc32d9521, 0xada121ff, 0x29908415, 0x7fbb977f,
+0xaf9eb3db, 0x29c9ed2a, 0x5ce2a465, 0xa730f32c, 0xd0aa3fe8, 0x8a5cc091,
+0xd49e2ce7, 0x0ce454a9, 0xd60acd86, 0x015f1919, 0x77079103, 0xdea03af6,
+0x78a8565e, 0xdee356df, 0x21f05cbe, 0x8b75e387, 0xb3c50651, 0xb8a5c3ef,
+0xd8eeb6d2, 0xe523be77, 0xc2154529, 0x2f69efdf, 0xafe67afb, 0xf470c4b2,
+0xf3e0eb5b, 0xd6cc9876, 0x39e4460c, 0x1fda8538, 0x1987832f, 0xca007367,
+0xa99144f8, 0x296b299e, 0x492fc295, 0x9266beab, 0xb5676e69, 0x9bd3ddda,
+0xdf7e052f, 0xdb25701c, 0x1b5e51ee, 0xf65324e6, 0x6afce36c, 0x0316cc04,
+0x8644213e, 0xb7dc59d0, 0x7965291f, 0xccd6fd43, 0x41823979, 0x932bcdf6,
+0xb657c34d, 0x4edfd282, 0x7ae5290c, 0x3cb9536b, 0x851e20fe, 0x9833557e,
+0x13ecf0b0, 0xd3ffb372, 0x3f85c5c1, 0x0aef7ed2,
+);
+
+@Crypt::CAST5_PP::s5 = (
+0x7ec90c04, 0x2c6e74b9, 0x9b0e66df, 0xa6337911, 0xb86a7fff, 0x1dd358f5,
+0x44dd9d44, 0x1731167f, 0x08fbf1fa, 0xe7f511cc, 0xd2051b00, 0x735aba00,
+0x2ab722d8, 0x386381cb, 0xacf6243a, 0x69befd7a, 0xe6a2e77f, 0xf0c720cd,
+0xc4494816, 0xccf5c180, 0x38851640, 0x15b0a848, 0xe68b18cb, 0x4caadeff,
+0x5f480a01, 0x0412b2aa, 0x259814fc, 0x41d0efe2, 0x4e40b48d, 0x248eb6fb,
+0x8dba1cfe, 0x41a99b02, 0x1a550a04, 0xba8f65cb, 0x7251f4e7, 0x95a51725,
+0xc106ecd7, 0x97a5980a, 0xc539b9aa, 0x4d79fe6a, 0xf2f3f763, 0x68af8040,
+0xed0c9e56, 0x11b4958b, 0xe1eb5a88, 0x8709e6b0, 0xd7e07156, 0x4e29fea7,
+0x6366e52d, 0x02d1c000, 0xc4ac8e05, 0x9377f571, 0x0c05372a, 0x578535f2,
+0x2261be02, 0xd642a0c9, 0xdf13a280, 0x74b55bd2, 0x682199c0, 0xd421e5ec,
+0x53fb3ce8, 0xc8adedb3, 0x28a87fc9, 0x3d959981, 0x5c1ff900, 0xfe38d399,
+0x0c4eff0b, 0x062407ea, 0xaa2f4fb1, 0x4fb96976, 0x90c79505, 0xb0a8a774,
+0xef55a1ff, 0xe59ca2c2, 0xa6b62d27, 0xe66a4263, 0xdf65001f, 0x0ec50966,
+0xdfdd55bc, 0x29de0655, 0x911e739a, 0x17af8975, 0x32c7911c, 0x89f89468,
+0x0d01e980, 0x524755f4, 0x03b63cc9, 0x0cc844b2, 0xbcf3f0aa, 0x87ac36e9,
+0xe53a7426, 0x01b3d82b, 0x1a9e7449, 0x64ee2d7e, 0xcddbb1da, 0x01c94910,
+0xb868bf80, 0x0d26f3fd, 0x9342ede7, 0x04a5c284, 0x636737b6, 0x50f5b616,
+0xf24766e3, 0x8eca36c1, 0x136e05db, 0xfef18391, 0xfb887a37, 0xd6e7f7d4,
+0xc7fb7dc9, 0x3063fcdf, 0xb6f589de, 0xec2941da, 0x26e46695, 0xb7566419,
+0xf654efc5, 0xd08d58b7, 0x48925401, 0xc1bacb7f, 0xe5ff550f, 0xb6083049,
+0x5bb5d0e8, 0x87d72e5a, 0xab6a6ee1, 0x223a66ce, 0xc62bf3cd, 0x9e0885f9,
+0x68cb3e47, 0x086c010f, 0xa21de820, 0xd18b69de, 0xf3f65777, 0xfa02c3f6,
+0x407edac3, 0xcbb3d550, 0x1793084d, 0xb0d70eba, 0x0ab378d5, 0xd951fb0c,
+0xded7da56, 0x4124bbe4, 0x94ca0b56, 0x0f5755d1, 0xe0e1e56e, 0x6184b5be,
+0x580a249f, 0x94f74bc0, 0xe327888e, 0x9f7b5561, 0xc3dc0280, 0x05687715,
+0x646c6bd7, 0x44904db3, 0x66b4f0a3, 0xc0f1648a, 0x697ed5af, 0x49e92ff6,
+0x309e374f, 0x2cb6356a, 0x85808573, 0x4991f840, 0x76f0ae02, 0x083be84d,
+0x28421c9a, 0x44489406, 0x736e4cb8, 0xc1092910, 0x8bc95fc6, 0x7d869cf4,
+0x134f616f, 0x2e77118d, 0xb31b2be1, 0xaa90b472, 0x3ca5d717, 0x7d161bba,
+0x9cad9010, 0xaf462ba2, 0x9fe459d2, 0x45d34559, 0xd9f2da13, 0xdbc65487,
+0xf3e4f94e, 0x176d486f, 0x097c13ea, 0x631da5c7, 0x445f7382, 0x175683f4,
+0xcdc66a97, 0x70be0288, 0xb3cdcf72, 0x6e5dd2f3, 0x20936079, 0x459b80a5,
+0xbe60e2db, 0xa9c23101, 0xeba5315c, 0x224e42f2, 0x1c5c1572, 0xf6721b2c,
+0x1ad2fff3, 0x8c25404e, 0x324ed72f, 0x4067b7fd, 0x0523138e, 0x5ca3bc78,
+0xdc0fd66e, 0x75922283, 0x784d6b17, 0x58ebb16e, 0x44094f85, 0x3f481d87,
+0xfcfeae7b, 0x77b5ff76, 0x8c2302bf, 0xaaf47556, 0x5f46b02a, 0x2b092801,
+0x3d38f5f7, 0x0ca81f36, 0x52af4a8a, 0x66d5e7c0, 0xdf3b0874, 0x95055110,
+0x1b5ad7a8, 0xf61ed5ad, 0x6cf6e479, 0x20758184, 0xd0cefa65, 0x88f7be58,
+0x4a046826, 0x0ff6f8f3, 0xa09c7f70, 0x5346aba0, 0x5ce96c28, 0xe176eda3,
+0x6bac307f, 0x376829d2, 0x85360fa9, 0x17e3fe2a, 0x24b79767, 0xf5a96b20,
+0xd6cd2595, 0x68ff1ebf, 0x7555442c, 0xf19f06be, 0xf9e0659a, 0xeeb9491d,
+0x34010718, 0xbb30cab8, 0xe822fe15, 0x88570983, 0x750e6249, 0xda627e55,
+0x5e76ffa8, 0xb1534546, 0x6d47de08, 0xefe9e7d4,
+);
+
+@Crypt::CAST5_PP::s6 = (
+0xf6fa8f9d, 0x2cac6ce1, 0x4ca34867, 0xe2337f7c, 0x95db08e7, 0x016843b4,
+0xeced5cbc, 0x325553ac, 0xbf9f0960, 0xdfa1e2ed, 0x83f0579d, 0x63ed86b9,
+0x1ab6a6b8, 0xde5ebe39, 0xf38ff732, 0x8989b138, 0x33f14961, 0xc01937bd,
+0xf506c6da, 0xe4625e7e, 0xa308ea99, 0x4e23e33c, 0x79cbd7cc, 0x48a14367,
+0xa3149619, 0xfec94bd5, 0xa114174a, 0xeaa01866, 0xa084db2d, 0x09a8486f,
+0xa888614a, 0x2900af98, 0x01665991, 0xe1992863, 0xc8f30c60, 0x2e78ef3c,
+0xd0d51932, 0xcf0fec14, 0xf7ca07d2, 0xd0a82072, 0xfd41197e, 0x9305a6b0,
+0xe86be3da, 0x74bed3cd, 0x372da53c, 0x4c7f4448, 0xdab5d440, 0x6dba0ec3,
+0x083919a7, 0x9fbaeed9, 0x49dbcfb0, 0x4e670c53, 0x5c3d9c01, 0x64bdb941,
+0x2c0e636a, 0xba7dd9cd, 0xea6f7388, 0xe70bc762, 0x35f29adb, 0x5c4cdd8d,
+0xf0d48d8c, 0xb88153e2, 0x08a19866, 0x1ae2eac8, 0x284caf89, 0xaa928223,
+0x9334be53, 0x3b3a21bf, 0x16434be3, 0x9aea3906, 0xefe8c36e, 0xf890cdd9,
+0x80226dae, 0xc340a4a3, 0xdf7e9c09, 0xa694a807, 0x5b7c5ecc, 0x221db3a6,
+0x9a69a02f, 0x68818a54, 0xceb2296f, 0x53c0843a, 0xfe893655, 0x25bfe68a,
+0xb4628abc, 0xcf222ebf, 0x25ac6f48, 0xa9a99387, 0x53bddb65, 0xe76ffbe7,
+0xe967fd78, 0x0ba93563, 0x8e342bc1, 0xe8a11be9, 0x4980740d, 0xc8087dfc,
+0x8de4bf99, 0xa11101a0, 0x7fd37975, 0xda5a26c0, 0xe81f994f, 0x9528cd89,
+0xfd339fed, 0xb87834bf, 0x5f04456d, 0x22258698, 0xc9c4c83b, 0x2dc156be,
+0x4f628daa, 0x57f55ec5, 0xe2220abe, 0xd2916ebf, 0x4ec75b95, 0x24f2c3c0,
+0x42d15d99, 0xcd0d7fa0, 0x7b6e27ff, 0xa8dc8af0, 0x7345c106, 0xf41e232f,
+0x35162386, 0xe6ea8926, 0x3333b094, 0x157ec6f2, 0x372b74af, 0x692573e4,
+0xe9a9d848, 0xf3160289, 0x3a62ef1d, 0xa787e238, 0xf3a5f676, 0x74364853,
+0x20951063, 0x4576698d, 0xb6fad407, 0x592af950, 0x36f73523, 0x4cfb6e87,
+0x7da4cec0, 0x6c152daa, 0xcb0396a8, 0xc50dfe5d, 0xfcd707ab, 0x0921c42f,
+0x89dff0bb, 0x5fe2be78, 0x448f4f33, 0x754613c9, 0x2b05d08d, 0x48b9d585,
+0xdc049441, 0xc8098f9b, 0x7dede786, 0xc39a3373, 0x42410005, 0x6a091751,
+0x0ef3c8a6, 0x890072d6, 0x28207682, 0xa9a9f7be, 0xbf32679d, 0xd45b5b75,
+0xb353fd00, 0xcbb0e358, 0x830f220a, 0x1f8fb214, 0xd372cf08, 0xcc3c4a13,
+0x8cf63166, 0x061c87be, 0x88c98f88, 0x6062e397, 0x47cf8e7a, 0xb6c85283,
+0x3cc2acfb, 0x3fc06976, 0x4e8f0252, 0x64d8314d, 0xda3870e3, 0x1e665459,
+0xc10908f0, 0x513021a5, 0x6c5b68b7, 0x822f8aa0, 0x3007cd3e, 0x74719eef,
+0xdc872681, 0x073340d4, 0x7e432fd9, 0x0c5ec241, 0x8809286c, 0xf592d891,
+0x08a930f6, 0x957ef305, 0xb7fbffbd, 0xc266e96f, 0x6fe4ac98, 0xb173ecc0,
+0xbc60b42a, 0x953498da, 0xfba1ae12, 0x2d4bd736, 0x0f25faab, 0xa4f3fceb,
+0xe2969123, 0x257f0c3d, 0x9348af49, 0x361400bc, 0xe8816f4a, 0x3814f200,
+0xa3f94043, 0x9c7a54c2, 0xbc704f57, 0xda41e7f9, 0xc25ad33a, 0x54f4a084,
+0xb17f5505, 0x59357cbe, 0xedbd15c8, 0x7f97c5ab, 0xba5ac7b5, 0xb6f6deaf,
+0x3a479c3a, 0x5302da25, 0x653d7e6a, 0x54268d49, 0x51a477ea, 0x5017d55b,
+0xd7d25d88, 0x44136c76, 0x0404a8c8, 0xb8e5a121, 0xb81a928a, 0x60ed5869,
+0x97c55b96, 0xeaec991b, 0x29935913, 0x01fdb7f1, 0x088e8dfa, 0x9ab6f6f5,
+0x3b4cbf9f, 0x4a5de3ab, 0xe6051d35, 0xa0e1d855, 0xd36b4cf1, 0xf544edeb,
+0xb0e93524, 0xbebb8fbd, 0xa2d762cf, 0x49c92f54, 0x38b5f331, 0x7128a454,
+0x48392905, 0xa65b1db8, 0x851c97bd, 0xd675cf2f,
+);
+
+@Crypt::CAST5_PP::s7 = (
+0x85e04019, 0x332bf567, 0x662dbfff, 0xcfc65693, 0x2a8d7f6f, 0xab9bc912,
+0xde6008a1, 0x2028da1f, 0x0227bce7, 0x4d642916, 0x18fac300, 0x50f18b82,
+0x2cb2cb11, 0xb232e75c, 0x4b3695f2, 0xb28707de, 0xa05fbcf6, 0xcd4181e9,
+0xe150210c, 0xe24ef1bd, 0xb168c381, 0xfde4e789, 0x5c79b0d8, 0x1e8bfd43,
+0x4d495001, 0x38be4341, 0x913cee1d, 0x92a79c3f, 0x089766be, 0xbaeeadf4,
+0x1286becf, 0xb6eacb19, 0x2660c200, 0x7565bde4, 0x64241f7a, 0x8248dca9,
+0xc3b3ad66, 0x28136086, 0x0bd8dfa8, 0x356d1cf2, 0x107789be, 0xb3b2e9ce,
+0x0502aa8f, 0x0bc0351e, 0x166bf52a, 0xeb12ff82, 0xe3486911, 0xd34d7516,
+0x4e7b3aff, 0x5f43671b, 0x9cf6e037, 0x4981ac83, 0x334266ce, 0x8c9341b7,
+0xd0d854c0, 0xcb3a6c88, 0x47bc2829, 0x4725ba37, 0xa66ad22b, 0x7ad61f1e,
+0x0c5cbafa, 0x4437f107, 0xb6e79962, 0x42d2d816, 0x0a961288, 0xe1a5c06e,
+0x13749e67, 0x72fc081a, 0xb1d139f7, 0xf9583745, 0xcf19df58, 0xbec3f756,
+0xc06eba30, 0x07211b24, 0x45c28829, 0xc95e317f, 0xbc8ec511, 0x38bc46e9,
+0xc6e6fa14, 0xbae8584a, 0xad4ebc46, 0x468f508b, 0x7829435f, 0xf124183b,
+0x821dba9f, 0xaff60ff4, 0xea2c4e6d, 0x16e39264, 0x92544a8b, 0x009b4fc3,
+0xaba68ced, 0x9ac96f78, 0x06a5b79a, 0xb2856e6e, 0x1aec3ca9, 0xbe838688,
+0x0e0804e9, 0x55f1be56, 0xe7e5363b, 0xb3a1f25d, 0xf7debb85, 0x61fe033c,
+0x16746233, 0x3c034c28, 0xda6d0c74, 0x79aac56c, 0x3ce4e1ad, 0x51f0c802,
+0x98f8f35a, 0x1626a49f, 0xeed82b29, 0x1d382fe3, 0x0c4fb99a, 0xbb325778,
+0x3ec6d97b, 0x6e77a6a9, 0xcb658b5c, 0xd45230c7, 0x2bd1408b, 0x60c03eb7,
+0xb9068d78, 0xa33754f4, 0xf430c87d, 0xc8a71302, 0xb96d8c32, 0xebd4e7be,
+0xbe8b9d2d, 0x7979fb06, 0xe7225308, 0x8b75cf77, 0x11ef8da4, 0xe083c858,
+0x8d6b786f, 0x5a6317a6, 0xfa5cf7a0, 0x5dda0033, 0xf28ebfb0, 0xf5b9c310,
+0xa0eac280, 0x08b9767a, 0xa3d9d2b0, 0x79d34217, 0x021a718d, 0x9ac6336a,
+0x2711fd60, 0x438050e3, 0x069908a8, 0x3d7fedc4, 0x826d2bef, 0x4eeb8476,
+0x488dcf25, 0x36c9d566, 0x28e74e41, 0xc2610aca, 0x3d49a9cf, 0xbae3b9df,
+0xb65f8de6, 0x92aeaf64, 0x3ac7d5e6, 0x9ea80509, 0xf22b017d, 0xa4173f70,
+0xdd1e16c3, 0x15e0d7f9, 0x50b1b887, 0x2b9f4fd5, 0x625aba82, 0x6a017962,
+0x2ec01b9c, 0x15488aa9, 0xd716e740, 0x40055a2c, 0x93d29a22, 0xe32dbf9a,
+0x058745b9, 0x3453dc1e, 0xd699296e, 0x496cff6f, 0x1c9f4986, 0xdfe2ed07,
+0xb87242d1, 0x19de7eae, 0x053e561a, 0x15ad6f8c, 0x66626c1c, 0x7154c24c,
+0xea082b2a, 0x93eb2939, 0x17dcb0f0, 0x58d4f2ae, 0x9ea294fb, 0x52cf564c,
+0x9883fe66, 0x2ec40581, 0x763953c3, 0x01d6692e, 0xd3a0c108, 0xa1e7160e,
+0xe4f2dfa6, 0x693ed285, 0x74904698, 0x4c2b0edd, 0x4f757656, 0x5d393378,
+0xa132234f, 0x3d321c5d, 0xc3f5e194, 0x4b269301, 0xc79f022f, 0x3c997e7e,
+0x5e4f9504, 0x3ffafbbd, 0x76f7ad0e, 0x296693f4, 0x3d1fce6f, 0xc61e45be,
+0xd3b5ab34, 0xf72bf9b7, 0x1b0434c0, 0x4e72b567, 0x5592a33d, 0xb5229301,
+0xcfd2a87f, 0x60aeb767, 0x1814386b, 0x30bcc33d, 0x38a0c07d, 0xfd1606f2,
+0xc363519b, 0x589dd390, 0x5479f8e6, 0x1cb8d647, 0x97fd61a9, 0xea7759f4,
+0x2d57539d, 0x569a58cf, 0xe84e63ad, 0x462e1b78, 0x6580f87e, 0xf3817914,
+0x91da55f4, 0x40a230f3, 0xd1988f35, 0xb6e318d2, 0x3ffa50bc, 0x3d40f021,
+0xc3c0bdae, 0x4958c24c, 0x518f36b2, 0x84b1d370, 0x0fedce83, 0x878ddada,
+0xf2a279c7, 0x94e01be8, 0x90716f4b, 0x954b8aa3,
+);
+
+@Crypt::CAST5_PP::s8 = (
+0xe216300d, 0xbbddfffc, 0xa7ebdabd, 0x35648095, 0x7789f8b7, 0xe6c1121b,
+0x0e241600, 0x052ce8b5, 0x11a9cfb0, 0xe5952f11, 0xece7990a, 0x9386d174,
+0x2a42931c, 0x76e38111, 0xb12def3a, 0x37ddddfc, 0xde9adeb1, 0x0a0cc32c,
+0xbe197029, 0x84a00940, 0xbb243a0f, 0xb4d137cf, 0xb44e79f0, 0x049eedfd,
+0x0b15a15d, 0x480d3168, 0x8bbbde5a, 0x669ded42, 0xc7ece831, 0x3f8f95e7,
+0x72df191b, 0x7580330d, 0x94074251, 0x5c7dcdfa, 0xabbe6d63, 0xaa402164,
+0xb301d40a, 0x02e7d1ca, 0x53571dae, 0x7a3182a2, 0x12a8ddec, 0xfdaa335d,
+0x176f43e8, 0x71fb46d4, 0x38129022, 0xce949ad4, 0xb84769ad, 0x965bd862,
+0x82f3d055, 0x66fb9767, 0x15b80b4e, 0x1d5b47a0, 0x4cfde06f, 0xc28ec4b8,
+0x57e8726e, 0x647a78fc, 0x99865d44, 0x608bd593, 0x6c200e03, 0x39dc5ff6,
+0x5d0b00a3, 0xae63aff2, 0x7e8bd632, 0x70108c0c, 0xbbd35049, 0x2998df04,
+0x980cf42a, 0x9b6df491, 0x9e7edd53, 0x06918548, 0x58cb7e07, 0x3b74ef2e,
+0x522fffb1, 0xd24708cc, 0x1c7e27cd, 0xa4eb215b, 0x3cf1d2e2, 0x19b47a38,
+0x424f7618, 0x35856039, 0x9d17dee7, 0x27eb35e6, 0xc9aff67b, 0x36baf5b8,
+0x09c467cd, 0xc18910b1, 0xe11dbf7b, 0x06cd1af8, 0x7170c608, 0x2d5e3354,
+0xd4de495a, 0x64c6d006, 0xbcc0c62c, 0x3dd00db3, 0x708f8f34, 0x77d51b42,
+0x264f620f, 0x24b8d2bf, 0x15c1b79e, 0x46a52564, 0xf8d7e54e, 0x3e378160,
+0x7895cda5, 0x859c15a5, 0xe6459788, 0xc37bc75f, 0xdb07ba0c, 0x0676a3ab,
+0x7f229b1e, 0x31842e7b, 0x24259fd7, 0xf8bef472, 0x835ffcb8, 0x6df4c1f2,
+0x96f5b195, 0xfd0af0fc, 0xb0fe134c, 0xe2506d3d, 0x4f9b12ea, 0xf215f225,
+0xa223736f, 0x9fb4c428, 0x25d04979, 0x34c713f8, 0xc4618187, 0xea7a6e98,
+0x7cd16efc, 0x1436876c, 0xf1544107, 0xbedeee14, 0x56e9af27, 0xa04aa441,
+0x3cf7c899, 0x92ecbae6, 0xdd67016d, 0x151682eb, 0xa842eedf, 0xfdba60b4,
+0xf1907b75, 0x20e3030f, 0x24d8c29e, 0xe139673b, 0xefa63fb8, 0x71873054,
+0xb6f2cf3b, 0x9f326442, 0xcb15a4cc, 0xb01a4504, 0xf1e47d8d, 0x844a1be5,
+0xbae7dfdc, 0x42cbda70, 0xcd7dae0a, 0x57e85b7a, 0xd53f5af6, 0x20cf4d8c,
+0xcea4d428, 0x79d130a4, 0x3486ebfb, 0x33d3cddc, 0x77853b53, 0x37effcb5,
+0xc5068778, 0xe580b3e6, 0x4e68b8f4, 0xc5c8b37e, 0x0d809ea2, 0x398feb7c,
+0x132a4f94, 0x43b7950e, 0x2fee7d1c, 0x223613bd, 0xdd06caa2, 0x37df932b,
+0xc4248289, 0xacf3ebc3, 0x5715f6b7, 0xef3478dd, 0xf267616f, 0xc148cbe4,
+0x9052815e, 0x5e410fab, 0xb48a2465, 0x2eda7fa4, 0xe87b40e4, 0xe98ea084,
+0x5889e9e1, 0xefd390fc, 0xdd07d35b, 0xdb485694, 0x38d7e5b2, 0x57720101,
+0x730edebc, 0x5b643113, 0x94917e4f, 0x503c2fba, 0x646f1282, 0x7523d24a,
+0xe0779695, 0xf9c17a8f, 0x7a5b2121, 0xd187b896, 0x29263a4d, 0xba510cdf,
+0x81f47c9f, 0xad1163ed, 0xea7b5965, 0x1a00726e, 0x11403092, 0x00da6d77,
+0x4a0cdd61, 0xad1f4603, 0x605bdfb0, 0x9eedc364, 0x22ebe6a8, 0xcee7d28a,
+0xa0e736a0, 0x5564a6b9, 0x10853209, 0xc7eb8f37, 0x2de705ca, 0x8951570f,
+0xdf09822b, 0xbd691a6c, 0xaa12e4f2, 0x87451c0f, 0xe0f6a27a, 0x3ada4819,
+0x4cf1764f, 0x0d771c2b, 0x67cdb156, 0x350d8384, 0x5938fa0f, 0x42399ef3,
+0x36997b07, 0x0e84093d, 0x4aa93e61, 0x8360d87b, 0x1fa98b0c, 0x1149382c,
+0xe97625a5, 0x0614d1b7, 0x0e25244b, 0x0c768347, 0x589e8d82, 0x0d2059d1,
+0xa466bb1e, 0xf8da0a82, 0x04f19130, 0xba6e4ec0, 0x99265164, 0x1ee7230d,
+0x50b2ad80, 0xeaee6801, 0x8db2a283, 0xea8bf59e,
+);
+
+1 # end Tables.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/Crypt/DES_EDE3.pm b/Master/tlpkg/tlperl.straw/lib/Crypt/DES_EDE3.pm
new file mode 100755
index 00000000000..5bb52e97955
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Crypt/DES_EDE3.pm
@@ -0,0 +1,118 @@
+# $Id: DES_EDE3.pm,v 1.2 2001/09/15 03:41:09 btrott Exp $
+
+package Crypt::DES_EDE3;
+use strict;
+
+use Crypt::DES;
+use vars qw( $VERSION );
+$VERSION = '0.01';
+
+sub new {
+ my $class = shift;
+ my $ede3 = bless {}, $class;
+ $ede3->init(@_);
+}
+
+sub keysize { 24 }
+sub blocksize { 8 }
+
+sub init {
+ my $ede3 = shift;
+ my($key) = @_;
+ for my $i (1..3) {
+ $ede3->{"des$i"} = Crypt::DES->new(substr $key, 8*($i-1), 8);
+ }
+ $ede3;
+}
+
+sub encrypt {
+ my($ede3, $block) = @_;
+ $ede3->{des3}->encrypt(
+ $ede3->{des2}->decrypt(
+ $ede3->{des1}->encrypt($block)
+ )
+ );
+}
+
+sub decrypt {
+ my($ede3, $block) = @_;
+ $ede3->{des1}->decrypt(
+ $ede3->{des2}->encrypt(
+ $ede3->{des3}->decrypt($block)
+ )
+ );
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Crypt::DES_EDE3 - Triple-DES EDE encryption/decryption
+
+=head1 SYNOPSIS
+
+ use Crypt::DES_EDE3;
+ my $ede3 = Crypt::DES_EDE3->new($key);
+ $ede3->encrypt($block);
+
+=head1 DESCRIPTION
+
+I<Crypt::DES_EDE3> implements DES-EDE3 encryption. This is triple-DES
+encryption where an encrypt operation is encrypt-decrypt-encrypt, and
+decrypt is decrypt-encrypt-decrypt. This implementation uses I<Crypt::DES>
+to do its dirty DES work, and simply provides a wrapper around that
+module: setting up the individual DES ciphers, initializing the keys,
+and performing the encryption/decryption steps.
+
+DES-EDE3 encryption requires a key size of 24 bytes.
+
+You're probably best off not using this module directly, as the I<encrypt>
+and I<decrypt> methods expect 8-octet blocks. You might want to use the
+module in conjunction with I<Crypt::CBC>, for example. This would be
+DES-EDE3-CBC, or triple-DES in outer CBC mode.
+
+=head1 USAGE
+
+=head2 $ede3 = Crypt::DES_EDE3->new($key)
+
+Creates a new I<Crypt::DES_EDE3> object (really, a collection of three DES
+ciphers), and initializes each cipher with part of I<$key>, which should be
+at least 24 bytes. If it's longer than 24 bytes, the extra bytes will be
+ignored.
+
+Returns the new object.
+
+=head2 $ede3->encrypt($block)
+
+Encrypts an 8-byte block of data I<$block> using the three DES ciphers in
+an encrypt-decrypt-encrypt operation.
+
+Returns the encrypted block.
+
+=head2 $ede3->decrypt($block)
+
+Decrypts an 8-byte block of data I<$block> using the three DES ciphers in
+a decrypt-encrypt-decrypt operation.
+
+Returns the decrypted block.
+
+=head2 $ede3->blocksize
+
+Returns the block size (8).
+
+=head2 $ede3->keysize
+
+Returns the key size (24).
+
+=head1 LICENSE
+
+Crypt::DES_EDE3 is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR & COPYRIGHTS
+
+Crypt::DES_EDE3 is Copyright 2001 Benjamin Trott, ben@rhumba.pair.com. All
+rights reserved.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Cwd.pm b/Master/tlpkg/tlperl.straw/lib/Cwd.pm
new file mode 100755
index 00000000000..a5e2cda932b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/DB.pm b/Master/tlpkg/tlperl.straw/lib/DB.pm
new file mode 100755
index 00000000000..efb903557a7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/DBI/Changes.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Changes.pm
new file mode 100755
index 00000000000..4b3693a78fc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Changes.pm
@@ -0,0 +1,2024 @@
+=head1 NAME
+
+DBI::Changes - List of significant changes to the DBI
+
+(As of $Date: 2009-06-08 11:07:26 +0100 (Mon, 08 Jun 2009) $ $Revision: 12816 $)
+
+=cut
+
+=head2 Changes in DBI 1.609 (svn r12816) 8th June 2009
+
+ Fixes to DBD::File (H.Merijn Brand)
+ added f_schema attribute
+ table names case sensitive when quoted, insensitive when unquoted
+ workaround a bug in SQL::Statement (temporary fix) related
+ to the "You passed x parameters where y required" error
+
+ Added ImplementorClass and Name info to the "Issuing rollback() due to
+ DESTROY without explicit disconnect" warning to identify the handle.
+ Applies to compiled drivers when they are recompiled.
+ Added DBI->visit_handles($coderef) method.
+ Added $h->visit_child_handles($coderef) method.
+ Added docs for column_info()'s COLUMN_DEF value.
+ Clarified docs on stickyness of data type via bind_param().
+ Clarified docs on stickyness of data type via bind_col().
+
+=head2 Changes in DBI 1.608 (svn r12742) 5th May 2009
+
+ Fixes to DBD::File (H.Merijn Brand)
+ bind_param () now honors the attribute argument
+ added f_ext attribute
+ File::Spec is always required. (CORE since 5.00405)
+ Fail and set errstr on parameter count mismatch in execute ()
+ Fixed two small memory leaks when running in mod_perl
+ one in DBI->connect and one in DBI::Gofer::Execute.
+ Both due to "local $ENV{...};" leaking memory.
+ Fixed DBD_ATTRIB_DELETE macro for driver authors
+ and updated DBI::DBD docs thanks to Martin J. Evans.
+ Fixed 64bit issues in trace messages thanks to Charles Jardine.
+ Fixed FETCH_many() method to work with drivers that incorrectly return
+ an empty list from $h->FETCH. Affected gofer.
+
+ Added 'sqlite_' as registered prefix for DBD::SQLite.
+ Corrected many typos in DBI docs thanks to Martin J. Evans.
+ Improved DBI::DBD docs thanks to H.Merijn Brand.
+
+=head2 Changes in DBI 1.607 (svn r11571) 22nd July 2008
+
+ NOTE: Perl 5.8.1 is now the minimum supported version.
+ If you need support for earlier versions send me a patch.
+
+ Fixed missing import of carp in DBI::Gofer::Execute.
+
+ Added note to docs about effect of execute(@empty_array).
+ Clarified docs for ReadOnly thanks to Martin Evans.
+
+=head2 Changes in DBI 1.605 (svn r11434) 16th June 2008
+
+ Fixed broken DBIS macro with threads on big-endian machines
+ with 64bit ints but 32bit pointers. Ticket #32309.
+ Fixed the selectall_arrayref, selectrow_arrayref, and selectrow_array
+ methods that get embedded into compiled drivers to use the
+ inner sth handle when passed a $sth instead of an sql string.
+ Drivers will need to be recompiled to pick up this change.
+ Fixed leak in neat() for some kinds of values thanks to Rudolf Lippan.
+ Fixed DBI::PurePerl neat() to behave more like XS neat().
+
+ Increased default $DBI::neat_maxlen from 400 to 1000.
+ Increased timeout on tests to accomodate very slow systems.
+ Changed behaviour of trace levels 1..4 to show less information
+ at lower levels.
+ Changed the format of the key used for $h->{CachedKids}
+ (which is undocumented so you shouldn't depend on it anyway)
+ Changed gofer error handling to avoid duplicate error text in errstr.
+ Clarified docs re ":N" style placeholders.
+ Improved gofer retry-on-error logic and refactored to aid subclassing.
+ Improved gofer trace output in assorted ways.
+
+ Removed the beeps "\a" from Makefile.PL warnings.
+ Removed check for PlRPC-modules from Makefile.PL
+
+ Added sorting of ParamValues reported by ShowErrorStatement
+ thanks to to Rudolf Lippan.
+ Added cache miss trace message to DBD::Gofer transport class.
+ Added $drh->dbixs_revision method.
+ Added explicit LICENSE specification (perl) to META.yaml
+
+=head2 Changes in DBI 1.604 (svn rev 10994) 24th March 2008
+
+ Fixed fetchall_arrayref with $max_rows argument broken in 1.603,
+ thanks to Greg Sabino Mullane.
+ Fixed a few harmless compiler warnings on cygwin.
+
+=head2 Changes in DBI 1.603
+
+ Fixed pure-perl fetchall_arrayref with $max_rows argument
+ to not error when fetching after all rows already fetched.
+ (Was fixed for compiled drivers back in DBI 1.31.)
+ Thanks to Mark Overmeer.
+ Fixed C sprintf formats and casts, fixing compiler warnings.
+
+ Changed dbi_profile() to accept a hash of profiles and apply to all.
+ Changed gofer stream transport to improve error reporting.
+ Changed gofer test timeout to avoid spurious failures on slow systems.
+
+ Added options to t/85gofer.t so it's more useful for manual testing.
+
+=head2 Changes in DBI 1.602 (svn rev 10706) 8th February 2008
+
+ Fixed potential coredump if stack reallocated while calling back
+ into perl from XS code. Thanks to John Gardiner Myers.
+ Fixed DBI::Util::CacheMemory->new to not clear the cache.
+ Fixed avg in DBI::Profile as_text() thanks to Abe Ingersoll.
+ Fixed DBD::DBM bug in push_names thanks to J M Davitt.
+ Fixed take_imp_data for some platforms thanks to Jeffrey Klein.
+ Fixed docs tie'ing CacheKids (ie LRU cache) thanks to Peter John Edwards.
+
+ Expanded DBI::DBD docs for driver authors thanks to Martin Evans.
+ Enhanced t/80proxy.t test script.
+ Enhanced t/85gofer.t test script thanks to Stig.
+ Enhanced t/10examp.t test script thanks to David Cantrell.
+ Documented $DBI::stderr as the default value of err for internal errors.
+
+ Gofer changes:
+ track_recent now also keeps track of N most recent errors.
+ The connect method is now also counted in stats.
+
+=head2 Changes in DBI 1.601 (svn rev 10103), 21st October 2007
+
+ Fixed t/05thrclone.t to work with Test::More >= 0.71
+ thanks to Jerry D. Hedden and Michael G Schwern.
+ Fixed DBI for VMS thanks to Peter (Stig) Edwards.
+
+ Added client-side caching to DBD::Gofer. Can use any cache with
+ get($k)/set($k,$v) methods, including all the Cache and Cache::Cache
+ distribution modules plus Cache::Memcached, Cache::FastMmap etc.
+ Works for all transports. Overridable per handle.
+
+ Added DBI::Util::CacheMemory for use with DBD::Gofer caching.
+ It's a very fast and small strict subset of Cache::Memory.
+
+=head2 Changes in DBI 1.59 (svn rev 9874), 23rd August 2007
+
+ Fixed DBI::ProfileData to unescape headers lines read from data file.
+ Fixed DBI::ProfileData to not clobber $_, thanks to Alexey Tourbin.
+ Fixed DBI::SQL::Nano to not clobber $_, thanks to Alexey Tourbin.
+ Fixed DBI::PurePerl to return undef for ChildHandles if weaken not available.
+ Fixed DBD::Proxy disconnect error thanks to Philip Dye.
+ Fixed DBD::Gofer::Transport::Base bug (typo) in timeout code.
+ Fixed DBD::Proxy rows method thanks to Philip Dye.
+ Fixed dbiprof compile errors, thanks to Alexey Tourbin.
+ Fixed t/03handle.t to skip some tests if ChildHandles not available.
+
+ Added check_response_sub to DBI::Gofer::Execute
+
+=head2 Changes in DBI 1.58 (svn rev 9678), 25th June 2007
+
+ Fixed code triggering fatal error in bleadperl, thanks to Steve Hay.
+ Fixed compiler warning thanks to Jerry D. Hedden.
+ Fixed t/40profile.t to use int(dbi_time()) for systems like Cygwin where
+ time() seems to be rounded not truncated from the high resolution time.
+ Removed dump_results() test from t/80proxy.t.
+
+=head2 Changes in DBI 1.57 (svn rev 9639), 13th June 2007
+
+ Note: this release includes a change to the DBI::hash() function which will
+ now produce different values than before *if* your perl was built with 64-bit
+ 'int' type (i.e. "perl -V:intsize" says intsize='8'). It's relatively rare
+ for perl to be configured that way, even on 64-bit systems.
+
+ Fixed XS versions of select*_*() methods to call execute()
+ fetch() etc., with inner handle instead of outer.
+ Fixed execute_for_fetch() to not cache errstr values
+ thanks to Bart Degryse.
+ Fixed unused var compiler warning thanks to JDHEDDEN.
+ Fixed t/86gofer_fail tests to be less likely to fail falsely.
+
+ Changed DBI::hash to return 'I32' type instead of 'int' so results are
+ portable/consistent regardless of size of the int type.
+ Corrected timeout example in docs thanks to Egmont Koblinger.
+ Changed t/01basic.t to warn instead of failing when it detects
+ a problem with Math::BigInt (some recent versions had problems).
+
+ Added support for !Time and !Time~N to DBI::Profile Path. See docs.
+ Added extra trace info to connect_cached thanks to Walery Studennikov.
+ Added non-random (deterministic) mode to DBI_GOFER_RANDOM mechanism.
+ Added DBIXS_REVISION macro that drivers can use.
+ Added more docs for private_attribute_info() method.
+
+ DBI::Profile changes:
+ dbi_profile() now returns ref to relevant leaf node.
+ Don't profile DESTROY during global destruction.
+ Added as_node_path_list() and as_text() methods.
+ DBI::ProfileDumper changes:
+ Don't write file if there's no profile data.
+ Uses full natural precision when saving data (was using %.6f)
+ Optimized flush_to_disk().
+ Locks the data file while writing.
+ Enabled filename to be a code ref for dynamic names.
+ DBI::ProfileDumper::Apache changes:
+ Added Quiet=>1 to avoid write to STDERR in flush_to_disk().
+ Added Dir=>... to specify a writable destination directory.
+ Enabled DBI_PROFILE_APACHE_LOG_DIR for mod_perl 1 as well as 2.
+ Added parent pid to default data file name.
+ DBI::ProfileData changes:
+ Added DeleteFiles option to rename & delete files once read.
+ Locks the data files while reading.
+ Added ability to sort by Path elements.
+ dbiprof changes:
+ Added --dumpnodes and --delete options.
+ Added/updated docs for both DBI::ProfileDumper && ::Apache.
+
+=head2 Changes in DBI 1.56 (svn rev 9660), 18th June 2007
+
+ Fixed printf arg warnings thanks to JDHEDDEN.
+ Fixed returning driver-private sth attributes via gofer.
+
+ Changed pod docs docs to use =head3 instead of =item
+ so now in html you get links to individual methods etc.
+ Changed default gofer retry_limit from 2 to 0.
+ Changed tests to workaround Math::BigInt broken versions.
+ Changed dbi_profile_merge() to dbi_profile_merge_nodes()
+ old name still works as an alias for the new one.
+ Removed old DBI internal sanity check that's no longer valid
+ causing "panic: DESTROY (dbih_clearcom)" when tracing enabled
+
+ Added DBI_GOFER_RANDOM env var that can be use to trigger random
+ failures and delays when executing gofer requests. Designed to help
+ test automatic retry on failures and timeout handling.
+ Added lots more docs to all the DBD::Gofer and DBI::Gofer classes.
+
+=head2 Changes in DBI 1.55 (svn rev 9504), 4th May 2007
+
+ Fixed set_err() so HandleSetErr hook is executed reliably, if set.
+ Fixed accuracy of profiling when perl configured to use long doubles.
+ Fixed 42prof_data.t on fast systems with poor timers thanks to Malcolm Nooning.
+ Fixed potential corruption in selectall_arrayref and selectrow_arrayref
+ for compiled drivers, thanks to Rob Davies.
+ Rebuild your compiled drivers after installing DBI.
+
+ Changed some handle creation code from perl to C code,
+ to reduce handle creation cost by ~20%.
+ Changed internal implementation of the CachedKids attribute
+ so it's a normal handle attribute (and initially undef).
+ Changed connect_cached and prepare_cached to avoid a FETCH method call,
+ and thereby reduced cost by ~5% and ~30% respectively.
+ Changed _set_fbav to not croak when given a wrongly sized array,
+ it now warns and adjusts the row buffer to match.
+ Changed some internals to improve performance with threaded perls.
+ Changed DBD::NullP to be slightly more useful for testing.
+ Changed File::Spec prerequisite to not require a minimum version.
+ Changed tests to work with other DBMs thanks to ZMAN.
+ Changed ex/perl_dbi_nulls_test.pl to be more descriptive.
+
+ Added more functionality to the (undocumented) Callback mechanism.
+ Callbacks can now elect to provide a value to be returned, in which case
+ the method won't be called. A callback for "*" is applied to all methods
+ that don't have their own callback.
+ Added $h->{ReadOnly} attribute.
+ Added support for DBI Profile Path to contain refs to scalars
+ which will be de-ref'd for each profile sample.
+ Added dbilogstrip utility to edit DBI logs for diff'ing (gets installed)
+ Added details for SQLite 3.3 to NULL handling docs thanks to Alex Teslik.
+ Added take_imp_data() to DBI::PurePerl.
+
+ Gofer related changes:
+ Fixed gofer pipeone & stream transports to avoid risk of hanging.
+ Improved error handling and tracing significantly.
+ Added way to generate random 1-in-N failures for methods.
+ Added automatic retry-on-error mechanism to gofer transport base class.
+ Added tests to show automatic retry mechanism works a treat!
+ Added go_retry_hook callback hook so apps can fine-tune retry behaviour.
+ Added header to request and response packets for sanity checking
+ and to enable version skew between client and server.
+ Added forced_single_resultset, max_cached_sth_per_dbh and max_cached_dbh_per_drh
+ to gofer executor config.
+ Driver-private methods installed with install_method are now proxied.
+ No longer does a round-trip to the server for methods it knows
+ have not been overridden by the remote driver.
+ Most significant aspects of gofer behaviour are controlled by policy mechanism.
+ Added policy-controlled caching of results for some methods, such as schema metadata.
+ The connect_cached and prepare_cached methods cache on client and server.
+ The bind_param_array and execute_array methods are now supported.
+ Worked around a DBD::Sybase bind_param bug (which is fixed in DBD::Sybase 1.07)
+ Added goferperf.pl utility (doesn't get installed).
+ Many other assorted Gofer related bug fixes, enhancements and docs.
+ The http and mod_perl transports have been remove to their own distribution.
+ Client and server will need upgrading together for this release.
+
+=head2 Changes in DBI 1.54 (svn rev 9157), 23rd February 2007
+
+ NOTE: This release includes the 'next big thing': DBD::Gofer.
+ Take a look!
+
+ WARNING: This version has some subtle changes in DBI internals.
+ It's possible, though doubtful, that some may affect your code.
+ I recommend some extra testing before using this release.
+ Or perhaps I'm just being over cautious...
+
+ Fixed type_info when called for multiple dbh thanks to Cosimo Streppone.
+ Fixed compile warnings in bleadperl on freebsd-6.1-release
+ and solaris 10g thanks to Philip M. Gollucci.
+ Fixed to compile for perl built with -DNO_MATHOMS thanks to Jerry D. Hedden.
+ Fixed to work for bleadperl (r29544) thanks to Nicholas Clark.
+ Users of Perl >= 5.9.5 will require DBI >= 1.54.
+ Fixed rare error when profiling access to $DBI::err etc tied variables.
+ Fixed DBI::ProfileDumper to not be affected by changes to $/ and $,
+ thanks to Michael Schwern.
+
+ Changed t/40profile.t to skip tests for perl < 5.8.0.
+ Changed setting trace file to no longer write "Trace file set" to new file.
+ Changed 'handle cleared whilst still active' warning for dbh
+ to only be given for dbh that have active sth or are not AutoCommit.
+ Changed take_imp_data to call finish on all Active child sth.
+ Changed DBI::PurePerl trace() method to be more consistent.
+ Changed set_err method to effectively not append to errstr if the new errstr
+ is the same as the current one.
+ Changed handle factory methods, like connect, prepare, and table_info,
+ to copy any error/warn/info state of the handle being returned
+ up into the handle the method was called on.
+ Changed row buffer handling to not alter NUM_OF_FIELDS if it's
+ inconsistent with number of elements in row buffer array.
+ Updated DBI::DBD docs re handling multiple result sets.
+ Updated DBI::DBD docs for driver authors thanks to Ammon Riley
+ and Dean Arnold.
+ Updated column_info docs to note that if a table doesn't exist
+ you get an sth for an empty result set and not an error.
+
+ Added new DBD::Gofer 'stateless proxy' driver and framework,
+ and the DBI test suite is now also executed via DBD::Gofer,
+ and DBD::Gofer+DBI::PurePerl, in addition to DBI::PurePerl.
+ Added ability for trace() to support filehandle argument,
+ including tracing into a string, thanks to Dean Arnold.
+ Added ability for drivers to implement func() method
+ so proxy drivers can proxy the func method itself.
+ Added SQL_BIGINT type code (resolved to the ODBC/JDBC value (-5))
+ Added $h->private_attribute_info method.
+
+=head2 Changes in DBI 1.53 (svn rev 7995), 31st October 2006
+
+ Fixed checks for weaken to work with early 5.8.x versions
+ Fixed DBD::Proxy handling of some methods, including commit and rollback.
+ Fixed t/40profile.t to be more insensitive to long double precision.
+ Fixed t/40profile.t to be insensitive to small negative shifts in time
+ thanks to Jamie McCarthy.
+ Fixed t/40profile.t to skip tests for perl < 5.8.0.
+ Fixed to work with current 'bleadperl' (~5.9.5) thanks to Steve Peters.
+ Users of Perl >= 5.9.5 will require DBI >= 1.53.
+ Fixed to be more robust against drivers not handling multiple result
+ sets properly, thanks to Gisle Aas.
+
+ Added array context support to execute_array and execute_for_fetch
+ methods which returns executed tuples and rows affected.
+ Added Tie::Cache::LRU example to docs thanks to Brandon Black.
+
+=head2 Changes in DBI 1.52 (svn rev 6840), 30th July 2006
+
+ Fixed memory leak (per handle) thanks to Nicholas Clark and Ephraim Dan.
+ Fixed memory leak (16 bytes per sth) thanks to Doru Theodor Petrescu.
+ Fixed execute_for_fetch/execute_array to RaiseError thanks to Martin J. Evans.
+ Fixed for perl 5.9.4. Users of Perl >= 5.9.4 will require DBI >= 1.52.
+
+ Updated DBD::File to 0.35 to match the latest release on CPAN.
+
+ Added $dbh->statistics_info specification thanks to Brandon Black.
+
+ Many changes and additions to profiling:
+ Profile Path can now uses sane strings instead of obscure numbers,
+ can refer to attributes, assorted magical values, and even code refs!
+ Parsing of non-numeric DBI_PROFILE env var values has changed.
+ Changed DBI::Profile docs extensively - many new features.
+ See DBI::Profile docs for more information.
+
+=head2 Changes in DBI 1.51 (svn rev 6475), 6th June 2006
+
+ Fixed $dbh->clone method 'signature' thanks to Jeffrey Klein.
+ Fixed default ping() method to return false if !$dbh->{Active}.
+ Fixed t/40profile.t to be insensitive to long double precision.
+ Fixed for perl 5.8.0's more limited weaken() function.
+ Fixed DBD::Proxy to not alter $@ in disconnect or AUTOLOADd methods.
+ Fixed bind_columns() to use return set_err(...) instead of die()
+ to report incorrect number of parameters, thanks to Ben Thul.
+ Fixed bind_col() to ignore undef as bind location, thanks to David Wheeler.
+ Fixed for perl 5.9.x for non-threaded builds thanks to Nicholas Clark.
+ Users of Perl >= 5.9.x will require DBI >= 1.51.
+ Fixed fetching of rows as hash refs to preserve utf8 on field names
+ from $sth->{NAME} thanks to Alexey Gaidukov.
+ Fixed build on Win32 (dbd_postamble) thanks to David Golden.
+
+ Improved performance for thread-enabled perls thanks to Gisle Aas.
+ Drivers can now use PERL_NO_GET_CONTEXT thanks to Gisle Aas.
+ Driver authors please read the notes in the DBI::DBD docs.
+ Changed DBI::Profile format to always include a percentage,
+ if not exiting then uses time between the first and last DBI call.
+ Changed DBI::ProfileData to be more forgiving of systems with
+ unstable clocks (where time may go backwards occasionally).
+ Clarified the 'Subclassing the DBI' docs.
+ Assorted minor changes to docs from comments on annocpan.org.
+ Changed Makefile.PL to avoid incompatible options for old gcc.
+
+ Added 'fetch array of hash refs' example to selectall_arrayref
+ docs thanks to Tom Schindl.
+ Added docs for $sth->{ParamArrays} thanks to Martin J. Evans.
+ Added reference to $DBI::neat_maxlen in TRACING section of docs.
+ Added ability for DBI::Profile Path to include attributes
+ and a summary of where the code was called from.
+
+=head2 Changes in DBI 1.50 (svn rev 2307), 13 December 2005
+
+ Fixed Makefile.PL options for gcc bug introduced in 1.49.
+ Fixed handle magic order to keep DBD::Oracle happy.
+ Fixed selectrow_array to return empty list on error.
+
+ Changed dbi_profile_merge() to be able to recurse and merge
+ sub-trees of profile data.
+
+ Added documentation for dbi_profile_merge(), including how to
+ measure the time spent inside the DBI for an http request.
+
+=head2 Changes in DBI 1.49 (svn rev 2287), 29th November 2005
+
+ Fixed assorted attribute handling bugs in DBD::Proxy.
+ Fixed croak() in DBD::NullP thanks to Sergey Skvortsov.
+ Fixed handling of take_imp_data() and dbi_imp_data attribute.
+ Fixed bugs in DBD::DBM thanks to Jeff Zucker.
+ Fixed bug in DBI::ProfileDumper thanks to Sam Tregar.
+ Fixed ping in DBD::Proxy thanks to George Campbell.
+ Fixed dangling ref in $sth after parent $dbh destroyed
+ with thanks to il@rol.ru for the bug report #13151
+ Fixed prerequisites to include Storable thanks to Michael Schwern.
+ Fixed take_imp_data to be more practical.
+
+ Change to require perl 5.6.1 (as advertised in 2003) not 5.6.0.
+ Changed internals to be more strictly coded thanks to Andy Lester.
+ Changed warning about multiple copies of Driver.xst found in @INC
+ to ignore duplicated directories thanks to Ed Avis.
+ Changed Driver.xst to enable drivers to define an dbd_st_prepare_sv
+ function where the statement parameter is an SV. That enables
+ compiled drivers to support SQL strings that are UTF-8.
+ Changed "use DBI" to only set $DBI::connect_via if not already set.
+ Changed docs to clarify pre-method clearing of err values.
+
+ Added ability for DBI::ProfileData to edit profile path on loading.
+ This enables aggregation of different SQL statements into the same
+ profile node - very handy when not using placeholders or when working
+ multiple separate tables for the same thing (ie logtable_2005_11_28)
+ Added $sth->{ParamTypes} specification thanks to Dean Arnold.
+ Added $h->{Callbacks} attribute to enable code hooks to be invoked
+ when certain methods are called. For example:
+ $dbh->{Callbacks}->{prepare} = sub { ... };
+ With thanks to David Wheeler for the kick start.
+ Added $h->{ChildHandles} (using weakrefs) thanks to Sam Tregar
+ I've recoded it in C so there's no significant performance impact.
+ Added $h->{Type} docs (returns 'dr', 'db', or 'st')
+ Adding trace message in DESTROY if InactiveDestroy enabled.
+ Added %drhs = DBI->installed_drivers();
+
+ Ported DBI::ProfileDumper::Apache to mod_perl2 RC5+
+ thanks to Philip M. Golluci
+
+=head2 Changes in DBI 1.48 (svn rev 928), 14th March 2005
+
+ Fixed DBI::DBD::Metadata generation of type_info_all thanks to Steffen Goeldner
+ (driver authors who have used it should rerun it).
+
+ Updated docs for NULL Value placeholders thanks to Brian Campbell.
+
+ Added multi-keyfield nested hash fetching to fetchall_hashref()
+ thanks to Zhuang (John) Li for polishing up my draft.
+ Added registered driver prefixes: amzn_ for DBD::Amazon and yaswi_ for DBD::Yaswi.
+
+
+=head2 Changes in DBI 1.47 (svn rev 854), 2nd February 2005
+
+ Fixed DBI::ProxyServer to not create pid files by default.
+ References: Ubuntu Security Notice USN-70-1, CAN-2005-0077
+ Thanks to Javier Fernández-Sanguino Peña from the
+ Debian Security Audit Project, and Jonathan Leffler.
+ Fixed some tests to work with older Test::More versions.
+ Fixed setting $DBI::err/errstr in DBI::PurePerl.
+ Fixed potential undef warning from connect_cached().
+ Fixed $DBI::lasth handling for DESTROY so lasth points to
+ parent even if DESTROY called other methods.
+ Fixed DBD::Proxy method calls to not alter $@.
+ Fixed DBD::File problem with encoding pragma thanks to Erik Rijkers.
+
+ Changed error handling so undef errstr doesn't cause warning.
+ Changed DBI::DBD docs to use =head3/=head4 pod thanks to
+ Jonathan Leffler. This may generate warnings for perl 5.6.
+ Changed DBI::PurePerl to set autoflush on trace filehandle.
+ Changed DBD::Proxy to treat Username as a local attribute
+ so recent DBI version can be used with old DBI::ProxyServer.
+ Changed driver handle caching in DBD::File.
+ Added $GetInfoType{SQL_DATABASE_NAME} thanks to Steffen Goeldner.
+
+ Updated docs to recommend some common DSN string attributes.
+ Updated connect_cached() docs with issues and suggestions.
+ Updated docs for NULL Value placeholders thanks to Brian Campbell.
+ Updated docs for primary_key_info and primary_keys.
+ Updated docs to clarify that the default fetchrow_hashref behaviour,
+ of returning a ref to a new hash for each row, will not change.
+ Updated err/errstr/state docs for DBD authors thanks to Steffen Goeldner.
+ Updated handle/attribute docs for DBD authors thanks to Steffen Goeldner.
+ Corrected and updated LongReadLen docs thanks to Bart Lateur.
+ Added DBD::JDBC as a registered driver.
+
+=head2 Changes in DBI 1.46 (svn rev 584), 16th November 2004
+
+ Fixed parsing bugs in DBI::SQL::Nano thanks to Jeff Zucker.
+ Fixed a couple of bad links in docs thanks to Graham Barr.
+ Fixed test.pl Win32 undef warning thanks to H.Merijn Brand & David Repko.
+ Fixed minor issues in DBI::DBD::Metadata thanks to Steffen Goeldner.
+ Fixed DBI::PurePerl neat() to use double quotes for utf8.
+
+ Changed execute_array() definition, and default implementation,
+ to not consider scalar values for execute tuple count. See docs.
+ Changed DBD::File to enable ShowErrorStatement by default,
+ which affects DBD::File subclasses such as DBD::CSV and DBD::DBM.
+ Changed use DBI qw(:utils) tag to include $neat_maxlen.
+ Updated Roadmap and ToDo.
+
+ Added data_string_diff() data_string_desc() and data_diff()
+ utility functions to help diagnose Unicode issues.
+ All can be imported via the use DBI qw(:utils) tag.
+
+=head2 Changes in DBI 1.45 (svn rev 480), 6th October 2004
+
+ Fixed DBI::DBD code for drivers broken in 1.44.
+ Fixed "Free to wrong pool"/"Attempt to free unreferenced scalar" in FETCH.
+
+=head2 Changes in DBI 1.44 (svn rev 478), 5th October 2004
+
+ Fixed build issues on VMS thanks to Jakob Snoer.
+ Fixed DBD::File finish() method to return 1 thanks to Jan Dubois.
+ Fixed rare core dump during global destruction thanks to Mark Jason Dominus.
+ Fixed risk of utf8 flag persisting from one row to the next.
+
+ Changed bind_param_array() so it doesn't require all bind arrays
+ to have the same number of elements.
+ Changed bind_param_array() to error if placeholder number <= 0.
+ Changed execute_array() definition, and default implementation,
+ to effectively NULL-pad shorter bind arrays.
+ Changed execute_array() to return "0E0" for 0 as per the docs.
+ Changed execute_for_fetch() definition, and default implementation,
+ to return "0E0" for 0 like execute() and execute_array().
+ Changed Test::More prerequisite to Test::Simple (which is also the name
+ of the distribution both are packaged in) to work around ppm behaviour.
+
+ Corrected docs to say that get/set of unknown attribute generates
+ a warning and is no longer fatal. Thanks to Vadim.
+ Corrected fetchall_arrayref() docs example thanks to Drew Broadley.
+
+ Added $h1->swap_inner_handle($h2) sponsored by BizRate.com
+
+
+=head2 Changes in DBI 1.43 (svn rev 377), 2nd July 2004
+
+ Fixed connect() and connect_cached() RaiseError/PrintError
+ which would sometimes show "(no error string)" as the error.
+ Fixed compiler warning thanks to Paul Marquess.
+ Fixed "trace level set to" trace message thanks to H.Merijn Brand.
+ Fixed DBD::DBM $dbh->{dbm_tables}->{...} to be keyed by the
+ table name not the file name thanks to Jeff Zucker.
+ Fixed last_insert_id(...) thanks to Rudy Lippan.
+ Fixed propagation of scalar/list context into proxied methods.
+ Fixed DBI::Profile::DESTROY to not alter $@.
+ Fixed DBI::ProfileDumper new() docs thanks to Michael Schwern.
+ Fixed _load_class to propagate $@ thanks to Drew Taylor.
+ Fixed compile warnings on Win32 thanks to Robert Baron.
+ Fixed problem building with recent versions of MakeMaker.
+ Fixed DBD::Sponge not to generate warning with threads.
+ Fixed DBI_AUTOPROXY to work more than once thanks to Steven Hirsch.
+
+ Changed TraceLevel 1 to not show recursive/nested calls.
+ Changed getting or setting an invalid attribute to no longer be
+ a fatal error but generate a warning instead.
+ Changed selectall_arrayref() to call finish() if
+ $attr->{MaxRows} is defined.
+ Changed all tests to use Test::More and enhanced the tests thanks
+ to Stevan Little and Andy Lester. See http://qa.perl.org/phalanx/
+ Changed Test::More minimum prerequisite version to 0.40 (2001).
+ Changed DBI::Profile header to include the date and time.
+
+ Added DBI->parse_dsn($dsn) method.
+ Added warning if build directory path contains white space.
+ Added docs for parse_trace_flags() and parse_trace_flag().
+ Removed "may change" warnings from the docs for table_info(),
+ primary_key_info(), and foreign_key_info() methods.
+
+=head2 Changes in DBI 1.42 (svn rev 222), 12th March 2004
+
+ Fixed $sth->{NUM_OF_FIELDS} of non-executed statement handle
+ to be undef as per the docs (it was 0).
+ Fixed t/41prof_dump.t to work with perl5.9.1.
+ Fixed DBD_ATTRIB_DELETE macro thanks to Marco Paskamp.
+ Fixed DBI::PurePerl looks_like_number() and $DBI::rows.
+ Fixed ref($h)->can("foo") to not croak.
+
+ Changed attributes (NAME, TYPE etc) of non-executed statement
+ handle to be undef instead of triggering an error.
+ Changed ShowErrorStatement to apply to more $dbh methods.
+ Changed DBI_TRACE env var so just does this at load time:
+ DBI->trace(split '=', $ENV{DBI_TRACE}, 2);
+ Improved "invalid number of parameters" error message.
+ Added DBI::common as base class for DBI::db, DBD::st etc.
+ Moved methods common to all handles into DBI::common.
+
+ Major tracing enhancement:
+
+ Added $h->parse_trace_flags("foo|SQL|7") to map a group of
+ trace flags into the corresponding trace flag bits.
+ Added automatic calling of parse_trace_flags() if
+ setting the trace level to a non-numeric value:
+ $h->{TraceLevel}="foo|SQL|7"; $h->trace("foo|SQL|7");
+ DBI->connect("dbi:Driver(TraceLevel=SQL|foo):...", ...);
+ Currently no trace flags have been defined.
+ Added to, and reworked, the trace documentation.
+ Added dbivport.h for driver authors to use.
+
+ Major driver additions that Jeff Zucker and I have been working on:
+
+ Added DBI::SQL::Nano a 'smaller than micro' SQL parser
+ with an SQL::Statement compatible API. If SQL::Statement
+ is installed then DBI::SQL::Nano becomes an empty subclass
+ of SQL::Statement, unless the DBI_SQL_NANO env var is true.
+ Added DBD::File, modified to use DBI::SQL::Nano.
+ Added DBD::DBM, an SQL interface to DBM files using DBD::File.
+
+ Documentation changes:
+
+ Corrected typos in docs thanks to Steffen Goeldner.
+ Corrected execute_for_fetch example thanks to Dean Arnold.
+
+=head2 Changes in DBI 1.41 (svn rev 130), 22nd February 2004
+
+ Fixed execute_for_array() so tuple_status parameter is optional
+ as per docs, thanks to Ed Avis.
+ Fixed execute_for_array() docs to say that it returns undef if
+ any of the execute() calls fail.
+ Fixed take_imp_data() test on m68k reported by Christian Hammers.
+ Fixed write_typeinfo_pm inconsistencies in DBI::DBD::Metadata
+ thanks to Andy Hassall.
+ Fixed $h->{TraceLevel} to not return DBI->trace trace level
+ which it used to if DBI->trace trace level was higher.
+
+ Changed set_err() to append to errstr, with a leading "\n" if it's
+ not empty, so that multiple error/warning messages are recorded.
+ Changed trace to limit elements dumped when an array reference is
+ returned from a method to the max(40, $DBI::neat_maxlen/10)
+ so that fetchall_arrayref(), for example, doesn't flood the trace.
+ Changed trace level to be a four bit integer (levels 0 thru 15)
+ and a set of topic flags (no topics have been assigned yet).
+ Changed column_info() to check argument count.
+ Extended bind_param() TYPE attribute specification to imply
+ standard formating of value, eg SQL_DATE implies 'YYYY-MM-DD'.
+
+ Added way for drivers to indicate 'success with info' or 'warning'
+ by setting err to "0" for warning and "" for information.
+ Both values are false and so don't trigger RaiseError etc.
+ Thanks to Steffen Goeldner for the original idea.
+ Added $h->{HandleSetErr} = sub { ... } to be called at the
+ point that an error, warn, or info state is recorded.
+ The code can alter the err, errstr, and state values
+ (e.g., to promote an error to a warning, or the reverse).
+ Added $h->{PrintWarn} attribute to enable printing of warnings
+ recorded by the driver. Defaults to same value as $^W (perl -w).
+ Added $h->{ErrCount} attribute, incremented whenever an error is
+ recorded by the driver via set_err().
+ Added $h->{Executed} attribute, set if do()/execute() called.
+ Added \%attr parameter to foreign_key_info() method.
+ Added ref count of inner handle to "DESTROY ignored for outer" msg.
+ Added Win32 build config checks to DBI::DBD thanks to Andy Hassall.
+ Added bind_col to Driver.xst so drivers can define their own.
+ Added TYPE attribute to bind_col and specified the expected
+ driver behaviour.
+
+ Major update to signal handling docs thanks to Lincoln Baxter.
+ Corrected dbiproxy usage doc thanks to Christian Hammers.
+ Corrected type_info_all index hash docs thanks to Steffen Goeldner.
+ Corrected type_info COLUMN_SIZE to chars not bytes thanks to Dean Arnold.
+ Corrected get_info() docs to include details of DBI::Const::GetInfoType.
+ Clarified that $sth->{PRECISION} is OCTET_LENGTH for char types.
+
+=head2 Changes in DBI 1.40, 7th January 2004
+
+ Fixed handling of CachedKids when DESTROYing threaded handles.
+ Fixed sql_user_name() in DBI::DBD::Metadata (used by write_getinfo_pm)
+ to use $dbh->{Username}. Driver authors please update your code.
+
+ Changed connect_cached() when running under Apache::DBI
+ to route calls to Apache::DBI::connect().
+
+ Added CLONE() to DBD::Sponge and DBD::ExampleP.
+ Added warning when starting a new thread about any loaded driver
+ which does not have a CLONE() function.
+ Added new prepare_cache($sql, \%attr, 3) option to manage Active handles.
+ Added SCALE and NULLABLE support to DBD::Sponge.
+ Added missing execute() in fetchall_hashref docs thanks to Iain Truskett.
+ Added a CONTRIBUTING section to the docs with notes on creating patches.
+
+=head2 Changes in DBI 1.39, 27th November 2003
+
+ Fixed STORE to not clear error during nested DBI call, again/better,
+ thanks to Tony Bowden for the report and helpful test case.
+ Fixed DBI dispatch to not try to use AUTOLOAD for driver methods unless
+ the method has been declared (as methods should be when using AUTOLOAD).
+ This fixes a problem when the Attribute::Handlers module is loaded.
+ Fixed cwd check code to use $Config{path_sep} thanks to Steve Hay.
+ Fixed unqualified croak() calls thanks to Steffen Goeldner.
+ Fixed DBD::ExampleP TYPE and PRECISION attributes thanks to Tom Lowery.
+ Fixed tracing of methods that only get traced at high trace levels.
+
+ The level 1 trace no longer includes nested method calls so it generally
+ just shows the methods the application explicitly calls.
+ Added line to trace log (level>=4) when err/errstr is cleared.
+ Updated docs for InactiveDestroy and point out where and when the
+ trace includes the process id.
+ Update DBI::DBD docs thanks to Steffen Goeldner.
+ Removed docs saying that the DBI->data_sources method could be
+ passed a $dbh. The $dbh->data_sources method should be used instead.
+ Added link to 'DBI recipes' thanks to Giuseppe Maxia:
+ http://gmax.oltrelinux.com/dbirecipes.html (note that this
+ is not an endorsement that the recipies are 'optimal')
+
+ Note: There is a bug in perl 5.8.2 when configured with threads
+ and debugging enabled (bug #24463) which causes a DBI test to fail.
+
+=head2 Changes in DBI 1.38, 21th August 2003
+
+ NOTE: The DBI now requires perl version 5.6.0 or later.
+ (As per notice in DBI 1.33 released 27th February 2003)
+
+ Fixed spurious t/03handles failure on 64bit perls reported by H.Merijn Brand.
+ Fixed spurious t/15array failure on some perl versions thanks to Ed Avis.
+ Fixed build using dmake on windows thanks to Steffen Goeldner.
+ Fixed build on using some shells thanks to Gurusamy Sarathy.
+ Fixed ParamValues to only be appended to ShowErrorStatement if not empty.
+ Fixed $dbh->{Statement} not being writable by drivers in some cases.
+ Fixed occasional undef warnings on connect failures thanks to Ed Avis.
+ Fixed small memory leak when using $sth->{NAME..._hash}.
+ Fixed 64bit warnings thanks to Marian Jancar.
+ Fixed DBD::Proxy::db::DESTROY to not alter $@ thanks to Keith Chapman.
+ Fixed Makefile.PL status from WriteMakefile() thanks to Leon Brocard.
+
+ Changed "Can't set ...->{Foo}: unrecognised attribute" from an error to a
+ warning when running with DBI::ProxyServer to simplify upgrades.
+ Changed execute_array() to no longer require ArrayTupleStatus attribute.
+ Changed DBI->available_drivers to not hide DBD::Sponge.
+ Updated/moved placeholder docs to a better place thanks to Johan Vromans.
+ Changed dbd_db_do4 api in Driver.xst to match dbd_st_execute (return int,
+ not bool), relevant only to driver authors.
+ Changed neat(), and thus trace(), so strings marked as utf8 are presented
+ in double quotes instead of single quotes and are not sanitized.
+
+ Added $dbh->data_sources method.
+ Added $dbh->last_insert_id method.
+ Added $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status) method.
+ Added DBI->installed_versions thanks to Jeff Zucker.
+ Added $DBI::Profile::ON_DESTROY_DUMP variable.
+ Added docs for DBD::Sponge thanks to Mark Stosberg.
+
+=head2 Changes in DBI 1.37, 15th May 2003
+
+ Fixed "Can't get dbh->{Statement}: unrecognised attribute" error in test
+ caused by change to perl internals in 5.8.0
+ Fixed to build with latest development perl (5.8.1@19525).
+ Fixed C code to use all ANSI declarations thanks to Steven Lembark.
+
+=head2 Changes in DBI 1.36, 11th May 2003
+
+ Fixed DBI->connect to carp instead of croak on 'old-style' usage.
+ Fixed connect(,,, { RootClass => $foo }) to not croak if module not found.
+ Fixed code generated by DBI::DBD::Metadata thanks to DARREN@cpan.org (#2270)
+ Fixed DBI::PurePerl to not reset $@ during method dispatch.
+ Fixed VMS build thanks to Michael Schwern.
+ Fixed Proxy disconnect thanks to Steven Hirsch.
+ Fixed error in DBI::DBD docs thanks to Andy Hassall.
+
+ Changed t/40profile.t to not require Time::HiRes.
+ Changed DBI::ProxyServer to load DBI only on first request, which
+ helps threaded server mode, thanks to Bob Showalter.
+ Changed execute_array() return value from row count to executed
+ tuple count, and now the ArrayTupleStatus attribute is mandatory.
+ NOTE: That is an API definition change that may affect your code.
+ Changed CompatMode attribute to also disable attribute 'quick FETCH'.
+ Changed attribute FETCH to be slightly faster thanks to Stas Bekman.
+
+ Added workaround for perl bug #17575 tied hash nested FETCH
+ thanks to Silvio Wanka.
+ Added Username and Password attributes to connect(..., \%attr) and so
+ also embedded in DSN like "dbi:Driver(Username=user,Password=pass):..."
+ Username and Password can't contain ")", ",", or "=" characters.
+ The predence is DSN first, then \%attr, then $user & $pass parameters,
+ and finally the DBI_USER & DBI_PASS environment variables.
+ The Username attribute is stored in the $dbh but the Password is not.
+ Added ProxyServer HOWTO configure restrictions docs thanks to Jochen Wiedmann.
+ Added MaxRows attribute to selectcol_arrayref prompted by Wojciech Pietron.
+ Added dump_handle as a method not just a DBI:: utility function.
+ Added on-demand by-row data feed into execute_array() using code ref,
+ or statement handle. For example, to insert from a select:
+ $insert_sth->execute_array( { ArrayTupleFetch => $select_sth, ... } )
+ Added warning to trace log when $h->{foo}=... is ignored due to
+ invalid prefix (e.g., not 'private_').
+
+=head2 Changes in DBI 1.35, 7th March 2003
+
+ Fixed memory leak in fetchrow_hashref introduced in DBI 1.33.
+ Fixed various DBD::Proxy errors introduced in DBI 1.33.
+ Fixed to ANSI C in dbd_dr_data_sources thanks to Jonathan Leffler.
+ Fixed $h->can($method_name) to return correct code ref.
+ Removed DBI::Format from distribution as it's now part of the
+ separate DBI::Shell distribution by Tom Lowery.
+ Updated DBI::DBD docs with a note about the CLONE method.
+ Updated DBI::DBD docs thanks to Jonathan Leffler.
+ Updated DBI::DBD::Metadata for perl 5.5.3 thanks to Jonathan Leffler.
+ Added note to install_method docs about setup_driver() method.
+
+=head2 Changes in DBI 1.34, 28th February 2003
+
+ Fixed DBI::DBD docs to refer to DBI::DBD::Metadata thanks to Jonathan Leffler.
+ Fixed dbi_time() compile using BorlandC on Windows thanks to Steffen Goeldner.
+ Fixed profile tests to do enough work to measure on Windows.
+ Fixed disconnect_all() to not be required by drivers.
+
+ Added $okay = $h->can($method_name) to check if a method exists.
+ Added DBD::*::*->install_method($method_name, \%attr) so driver private
+ methods can be 'installed' into the DBI dispatcher and no longer
+ need to be called using $h->func(..., $method_name).
+
+ Enhanced $dbh->clone() and documentation.
+ Enhanced docs to note that dbi_time(), and thus profiling, is limited
+ to only millisecond (seconds/1000) resolution on Windows.
+ Removed old DBI::Shell from distribution and added Tom Lowery's improved
+ version to the Bundle::DBI file.
+ Updated minimum version numbers for modules in Bundle::DBI.
+
+=head2 Changes in DBI 1.33, 27th February 2003
+
+ NOTE: Future versions of the DBI *will not* support perl 5.6.0 or earlier.
+ : Perl 5.6.1 will be the minimum supported version.
+
+ NOTE: The "old-style" connect: DBI->connect($database, $user, $pass, $driver);
+ : has been deprecated for several years and will now generate a warning.
+ : It will be removed in a later release. Please change any old connect() calls.
+
+ Added $dbh2 = $dbh1->clone to make a new connection to the database
+ that is identical to the original one. clone() can be called even after
+ the original handle has been disconnected. See the docs for more details.
+
+ Fixed merging of profile data to not sum DBIprof_FIRST_TIME values.
+ Fixed unescaping of newlines in DBI::ProfileData thanks to Sam Tregar.
+ Fixed Taint bug with fetchrow_hashref with help from Bradley Baetz.
+ Fixed $dbh->{Active} for DBD::Proxy, reported by Bob Showalter.
+ Fixed STORE to not clear error during nested DBI call,
+ thanks to Tony Bowden for the report and helpful test case.
+ Fixed DBI::PurePerl error clearing behaviour.
+ Fixed dbi_time() and thus DBI::Profile on Windows thanks to Smejkal Petr.
+ Fixed problem that meant ShowErrorStatement could show wrong statement,
+ thanks to Ron Savage for the report and test case.
+ Changed Apache::DBI hook to check for $ENV{MOD_PERL} instead of
+ $ENV{GATEWAY_INTERFACE} thanks to Ask Bjoern Hansen.
+ No longer tries to dup trace logfp when an interpreter is being cloned.
+ Database handles no longer inherit shared $h->err/errstr/state storage
+ from their drivers, so each $dbh has it's own $h->err etc. values
+ and is no longer affected by calls made on other dbh's.
+ Now when a dbh is destroyed it's err/errstr/state values are copied
+ up to the driver so checking $DBI::errstr still works as expected.
+
+ Build / portability fixes:
+ Fixed t/40profile.t to not use Time::HiRes.
+ Fixed t/06attrs.t to not be locale sensitive, reported by Christian Hammers.
+ Fixed sgi compiler warnings, reported by Paul Blake.
+ Fixed build using make -j4, reported by Jonathan Leffler.
+ Fixed build and tests under VMS thanks to Craig A. Berry.
+
+ Documentation changes:
+ Documented $high_resolution_time = dbi_time() function.
+ Documented that bind_col() can take an atribute hash.
+ Clarified documentation for ParamValues attribute hash keys.
+ Many good DBI documentation tweaks from Jonathan Leffler,
+ including a major update to the DBI::DBD driver author guide.
+ Clarified that execute() should itself call finish() if it's
+ called on a statement handle that's still active.
+ Clarified $sth->{ParamValues}. Driver authors please note.
+ Removed "NEW" markers on some methods and attributes and
+ added text to each giving the DBI version it was added in,
+ if it was added after DBI 1.21 (Feb 2002).
+
+ Changes of note for authors of all drivers:
+ Added SQL_DATA_TYPE, SQL_DATETIME_SUB, NUM_PREC_RADIX, and
+ INTERVAL_PRECISION fields to docs for type_info_all. There were
+ already in type_info(), but type_info_all() didn't specify the
+ index values. Please check and update your type_info_all() code.
+ Added DBI::DBD::Metadata module that auto-generates your drivers
+ get_info and type_info_all data and code, thanks mainly to
+ Jonathan Leffler and Steffen Goeldner. If you've not implemented
+ get_info and type_info_all methods and your database has an ODBC
+ driver available then this will do all the hard work for you!
+ Drivers should no longer pass Err, Errstr, or State to _new_drh
+ or _new_dbh functions.
+ Please check that you support the slightly modified behaviour of
+ $sth->{ParamValues}, e.g., always return hash with keys if possible.
+
+ Changes of note for authors of compiled drivers:
+ Added dbd_db_login6 & dbd_st_finish3 prototypes thanks to Jonathan Leffler.
+ All dbd_*_*() functions implemented by drivers must have a
+ corresponding #define dbd_*_* <driver_prefix>_*_* otherwise
+ the driver may not work with a future release of the DBI.
+
+ Changes of note for authors of drivers which use Driver.xst:
+ Some new method hooks have been added are are enabled by
+ defining corresponding macros:
+ $drh->data_sources() - dbd_dr_data_sources
+ $dbh->do() - dbd_db_do4
+ The following methods won't be compiled into the driver unless
+ the corresponding macro has been #defined:
+ $drh->disconnect_all() - dbd_discon_all
+
+
+=head2 Changes in DBI 1.32, 1st December 2002
+
+ Fixed to work with 5.005_03 thanks to Tatsuhiko Miyagawa (I've not tested it).
+ Reenabled taint tests (accidentally left disabled) spotted by Bradley Baetz.
+ Improved docs for FetchHashKeyName attribute thanks to Ian Barwick.
+ Fixed core dump if fetchrow_hashref given bad argument (name of attribute
+ with a value that wasn't an array reference), spotted by Ian Barwick.
+ Fixed some compiler warnings thanks to David Wheeler.
+ Updated Steven Hirsch's enhanced proxy work (seems I left out a bit).
+ Made t/40profile.t tests more reliable, reported by Randy, who is part of
+ the excellent CPAN testers team: http://testers.cpan.org/
+ (Please visit, see the valuable work they do and, ideally, join in!)
+
+=head2 Changes in DBI 1.31, 29th November 2002
+
+ The fetchall_arrayref method, when called with a $maxrows parameter,
+ no longer gives an error if called again after all rows have been
+ fetched. This simplifies application logic when fetching in batches.
+ Also added batch-fetch while() loop example to the docs.
+ The proxy now supports non-lazy (synchronous) prepare, positioned
+ updates (for selects containing 'for update'), PlRPC config set
+ via attributes, and accurate propagation of errors, all thanks
+ to Steven Hirsch (plus a minor fix from Sean McMurray and doc
+ tweaks from Michael A Chase).
+ The DBI_AUTOPROXY env var can now hold the full dsn of the proxy driver
+ plus attributes, like "dbi:Proxy(proxy_foo=>1):host=...".
+ Added TaintIn & TaintOut attributes to give finer control over
+ tainting thanks to Bradley Baetz.
+ The RootClass attribute no longer ignores failure to load a module,
+ but also doesn't try to load a module if the class already exists,
+ with thanks to James FitzGibbon.
+ HandleError attribute works for connect failures thanks to David Wheeler.
+ The connect() RaiseError/PrintError message now includes the username.
+ Changed "last handle unknown or destroyed" warning to be a trace message.
+ Removed undocumented $h->event() method.
+ Further enhancements to DBD::PurePerl accuracy.
+ The CursorName attribute now defaults to undef and not an error.
+
+ DBI::Profile changes:
+ New DBI::ProfileDumper, DBI::ProfileDumper::Apache, and
+ DBI::ProfileData modules (to manage the storage and processing
+ of profile data), plus dbiprof program for analyzing profile
+ data - with many thanks to Sam Tregar.
+ Added $DBI::err (etc) tied variable lookup time to profile.
+ Added time for DESTROY method into parent handles profile (used to be ignored).
+
+ Documentation changes:
+ Documented $dbh = $sth->{Database} attribute.
+ Documented $dbh->connected(...) post-connection call when subclassing.
+ Updated some minor doc issues thanks to H.Merijn Brand.
+ Updated Makefile.PL example in DBI::DBD thanks to KAWAI,Takanori.
+ Fixed execute_array() example thanks to Peter van Hardenberg.
+
+ Changes for driver authors, not required but strongly recommended:
+ Change DBIS to DBIc_DBISTATE(imp_xxh) [or imp_dbh, imp_sth etc]
+ Change DBILOGFP to DBIc_LOGPIO(imp_xxh) [or imp_dbh, imp_sth etc]
+ Any function from which all instances of DBIS and DBILOGFP are
+ removed can also have dPERLINTERP removed (a good thing).
+ All use of the DBIh_EVENT* macros should be removed.
+ Major update to DBI::DBD docs thanks largely to Jonathan Leffler.
+ Add these key values: 'Err' => \my $err, 'Errstr' => \my $errstr,
+ to the hash passed to DBI::_new_dbh() in your driver source code.
+ That will make each $dbh have it's own $h->err and $h->errstr
+ values separate from other $dbh belonging to the same driver.
+ If you have a ::db or ::st DESTROY methods that do nothing
+ you can now remove them - which speeds up handle destruction.
+
+
+=head2 Changes in DBI 1.30, 18th July 2002
+
+ Fixed problems with selectrow_array, selectrow_arrayref, and
+ selectall_arrayref introduced in DBI 1.29.
+ Fixed FETCHing a handle attribute to not clear $DBI::err etc (broken in 1.29).
+ Fixed core dump at trace level 9 or above.
+ Fixed compilation with perl 5.6.1 + ithreads (i.e. Windows).
+ Changed definition of behaviour of selectrow_array when called in a scalar
+ context to match fetchrow_array.
+ Corrected selectrow_arrayref docs which showed selectrow_array thanks to Paul DuBois.
+
+=head2 Changes in DBI 1.29, 15th July 2002
+
+ NOTE: This release changes the specified behaviour for the
+ : fetchrow_array method when called in a scalar context:
+ : The DBI spec used to say that it would return the FIRST field.
+ : Which field it returns (i.e., the first or the last) is now undefined.
+ : This does not affect statements that only select one column, which is
+ : usually the case when fetchrow_array is called in a scalar context.
+ : FYI, this change was triggered by discovering that the fetchrow_array
+ : implementation in Driver.xst (used by most compiled drivers)
+ : didn't match the DBI specification. Rather than change the code
+ : to match, and risk breaking existing applications, I've changed the
+ : specification (that part was always of dubious value anyway).
+
+ NOTE: Future versions of the DBI may not support for perl 5.5 much longer.
+ : If you are still using perl 5.005_03 you should be making plans to
+ : upgrade to at least perl 5.6.1, or 5.8.0. Perl 5.8.0 is due to be
+ : released in the next week or so. (Although it's a "point 0" release,
+ : it is the most throughly tested release ever.)
+
+ Added XS/C implementations of selectrow_array, selectrow_arrayref, and
+ selectall_arrayref to Driver.xst. See DBI 1.26 Changes for more info.
+ Removed support for the old (fatally flawed) "5005" threading model.
+ Added support for new perl 5.8 iThreads thanks to Gerald Richter.
+ (Threading support and safety should still be regarded as beta
+ quality until further notice. But it's much better than it was.)
+ Updated the "Threads and Thread Safety" section of the docs.
+ The trace output can be sent to STDOUT instead of STDERR by using
+ "STDOUT" as the name of the file, i.e., $h->trace(..., "STDOUT")
+ Added pointer to perlreftut, perldsc, perllol, and perlboot manuals
+ into the intro section of the docs, suggested by Brian McCain.
+ Fixed DBI::Const::GetInfo::* pod docs thanks to Zack Weinberg.
+ Some changes to how $dbh method calls are treated by DBI::Profile:
+ Meta-data methods now clear $dbh->{Statement} on entry.
+ Some $dbh methods are now profiled as if $dbh->{Statement} was empty
+ (because thet're unlikely to actually relate to its contents).
+ Updated dbiport.h to ppport.h from perl 5.8.0.
+ Tested with perl 5.5.3 (vanilla, Solaris), 5.6.1 (vanilla, Solaris), and
+ perl 5.8.0 (RC3@17527 with iThreads & Multiplicity on Solaris and FreeBSD).
+
+=head2 Changes in DBI 1.28, 14th June 2002
+
+ Added $sth->{ParamValues} to return a hash of the most recent
+ values bound to placeholders via bind_param() or execute().
+ Individual drivers need to be updated to support it.
+ Enhanced ShowErrorStatement to include ParamValues if available:
+ "DBD::foo::st execute failed: errstr [for statement ``...'' with params: 1='foo']"
+ Further enhancements to DBD::PurePerl accuracy.
+
+=head2 Changes in DBI 1.27, 13th June 2002
+
+ Fixed missing column in C implementation of fetchall_arrayref()
+ thanks to Philip Molter for the prompt reporting of the problem.
+
+=head2 Changes in DBI 1.26, 13th June 2002
+
+ Fixed t/40profile.t to work on Windows thanks to Smejkal Petr.
+ Fixed $h->{Profile} to return undef, not error, if not set.
+ Fixed DBI->available_drivers in scalar context thanks to Michael Schwern.
+
+ Added C implementations of selectrow_arrayref() and fetchall_arrayref()
+ in Driver.xst. All compiled drivers using Driver.xst will now be
+ faster making those calls. Most noticable with fetchall_arrayref for
+ many rows or selectrow_arrayref with a fast query. For example, using
+ DBD::mysql a selectrow_arrayref for a single row using a primary key
+ is ~20% faster, and fetchall_arrayref for 20000 rows is twice as fast!
+ Drivers just need to be recompiled and reinstalled to enable it.
+ The fetchall_arrayref speed up only applies if $slice parameter is not used.
+ Added $max_rows parameter to fetchall_arrayref() to optionally limit
+ the number of rows returned. Can now fetch batches of rows.
+ Added MaxRows attribute to selectall_arrayref()
+ which then passes it to fetchall_arrayref().
+ Changed selectrow_array to make use of selectrow_arrayref.
+ Trace level 1 now shows first two parameters of all methods
+ (used to only for that for some, like prepare,execute,do etc)
+ Trace indicator for recursive calls (first char on trace lines)
+ now starts at 1 not 2.
+
+ Documented that $h->func() does not trigger RaiseError etc
+ so applications must explicitly check for errors.
+ DBI::Profile with DBI_PROFILE now shows percentage time inside DBI.
+ HandleError docs updated to show that handler can edit error message.
+ HandleError subroutine interface is now regarded as stable.
+
+=head2 Changes in DBI 1.25, 5th June 2002
+
+ Fixed build problem on Windows and some compiler warnings.
+ Fixed $dbh->{Driver} and $sth->{Statement} for driver internals
+ These are 'inner' handles as per behaviour prior to DBI 1.16.
+ Further minor improvements to DBI::PurePerl accuracy.
+
+=head2 Changes in DBI 1.24, 4th June 2002
+
+ Fixed reference loop causing a handle/memory leak
+ that was introduced in DBI 1.16.
+ Fixed DBI::Format to work with 'filehandles' from IO::Scalar
+ and similar modules thanks to report by Jeff Boes.
+ Fixed $h->func for DBI::PurePerl thanks to Jeff Zucker.
+ Fixed $dbh->{Name} for DBI::PurePerl thanks to Dean Arnold.
+
+ Added DBI method call profiling and benchmarking.
+ This is a major new addition to the DBI.
+ See $h->{Profile} attribute and DBI::Profile module.
+ For a quick trial, set the DBI_PROFILE environment variable and
+ run your favourite DBI script. Try it with DBI_PROFILE set to 1,
+ then try 2, 4, 8, 10, and -10. Have fun!
+
+ Added execute_array() and bind_param_array() documentation
+ with thanks to Dean Arnold.
+ Added notes about the DBI having not yet been tested with iThreads
+ (testing and patches for SvLOCK etc welcome).
+ Removed undocumented Handlers attribute (replaced by HandleError).
+ Tested with 5.5.3 and 5.8.0 RC1.
+
+=head2 Changes in DBI 1.23, 25th May 2002
+
+ Greatly improved DBI::PurePerl in performance and accuracy.
+ Added more detail to DBI::PurePerl docs about what's not supported.
+ Fixed undef warnings from t/15array.t and DBD::Sponge.
+
+=head2 Changes in DBI 1.22, 22nd May 2002
+
+ Added execute_array() and bind_param_array() with special thanks
+ to Dean Arnold. Not yet documented. See t/15array.t for examples.
+ All drivers now automatically support these methods.
+ Added DBI::PurePerl, a transparent DBI emulation for pure-perl drivers
+ with special thanks to Jeff Zucker. Perldoc DBI::PurePerl for details.
+ Added DBI::Const::GetInfo* modules thanks to Steffen Goeldner.
+ Added write_getinfo_pm utility to DBI::DBD thanks to Steffen Goeldner.
+ Added $allow_active==2 mode for prepare_cached() thanks to Stephen Clouse.
+
+ Updated DBI::Format to Revision 11.4 thanks to Tom Lowery.
+ Use File::Spec in Makefile.PL (helps VMS etc) thanks to Craig Berry.
+ Extend $h->{Warn} to commit/rollback ineffective warning thanks to Jeff Baker.
+ Extended t/preparse.t and removed "use Devel::Peek" thanks to Scott Hildreth.
+ Only copy Changes to blib/lib/Changes.pm once thanks to Jonathan Leffler.
+ Updated internals for modern perls thanks to Jonathan Leffler and Jeff Urlwin.
+ Tested with perl 5.7.3 (just using default perl config).
+
+ Documentation changes:
+
+ Added 'Catalog Methods' section to docs thanks to Steffen Goeldner.
+ Updated README thanks to Michael Schwern.
+ Clarified that driver may choose not to start new transaction until
+ next use of $dbh after commit/rollback.
+ Clarified docs for finish method.
+ Clarified potentials problems with prepare_cached() thanks to Stephen Clouse.
+
+
+=head2 Changes in DBI 1.21, 7th February 2002
+
+ The minimum supported perl version is now 5.005_03.
+
+ Fixed DBD::Proxy support for AutoCommit thanks to Jochen Wiedmann.
+ Fixed DBI::ProxyServer bind_param(_inout) handing thanks to Oleg Mechtcheriakov.
+ Fixed DBI::ProxyServer fetch loop thanks to nobull@mail.com.
+ Fixed install_driver do-the-right-thing with $@ on error. It, and connect(),
+ will leave $@ empty on success and holding the error message on error.
+ Thanks to Jay Lawrence, Gavin Sherlock and others for the bug report.
+ Fixed fetchrow_hashref to assign columns to the hash left-to-right
+ so later fields with the same name overwrite earlier ones
+ as per DBI < 1.15, thanks to Kay Roepke.
+
+ Changed tables() to use quote_indentifier() if the driver returns a
+ true value for $dbh->get_info(29) # SQL_IDENTIFIER_QUOTE_CHAR
+ Changed ping() so it no longer triggers RaiseError/PrintError.
+ Changed connect() to not call $class->install_driver unless needed.
+ Changed DESTROY to catch fatal exceptions and append to $@.
+
+ Added ISO SQL/CLI & ODBCv3 data type definitions thanks to Steffen Goeldner.
+ Removed the definition of SQL_BIGINT data type constant as the value is
+ inconsistent between standards (ODBC=-5, SQL/CLI=25).
+ Added $dbh->column_info(...) thanks to Steffen Goeldner.
+ Added $dbh->foreign_key_info(...) thanks to Steffen Goeldner.
+ Added $dbh->quote_identifier(...) insipred by Simon Oliver.
+ Added $dbh->set_err(...) for DBD authors and DBI subclasses
+ (actually been there for a while, now expanded and documented).
+ Added $h->{HandleError} = sub { ... } addition and/or alternative
+ to RaiseError/PrintError. See the docs for more info.
+ Added $h->{TraceLevel} = N attribute to set/get trace level of handle
+ thus can set trace level via an (eg externally specified) DSN
+ using the embedded attribute syntax:
+ $dsn = 'dbi:DB2(PrintError=1,TraceLevel=2):dbname';
+ Plus, you can also now do: local($h->{TraceLevel}) = N;
+ (but that leaks a little memory in some versions of perl).
+ Added some call tree information to trace output if trace level >= 3
+ With thanks to Graham Barr for the stack walking code.
+ Added experimental undocumented $dbh->preparse(), see t/preparse.t
+ With thanks to Scott T. Hildreth for much of the work.
+ Added Fowler/Noll/Vo hash type as an option to DBI::hash().
+
+ Documentation changes:
+
+ Added DBI::Changes so now you can "perldoc DBI::Changes", yeah!
+ Added selectrow_arrayref & selectrow_hashref docs thanks to Doug Wilson.
+ Added 'Standards Reference Information' section to docs to gather
+ together all references to relevant on-line standards.
+ Added link to poop.sourceforge.net into the docs thanks to Dave Rolsky.
+ Added link to hyperlinked BNF for SQL92 thanks to Jeff Zucker.
+ Added 'Subclassing the DBI' docs thanks to Stephen Clouse, and
+ then changed some of them to reflect the new approach to subclassing.
+ Added stronger wording to description of $h->{private_*} attributes.
+ Added docs for DBI::hash.
+
+ Driver API changes:
+
+ Now a COPY of the DBI->connect() attributes is passed to the driver
+ connect() method, so it can process and delete any elements it wants.
+ Deleting elements reduces/avoids the explicit
+ $dbh->{$_} = $attr->{$_} foreach keys %$attr;
+ that DBI->connect does after the driver connect() method returns.
+
+
+=head2 Changes in DBI 1.20, 24th August 2001
+
+ WARNING: This release contains two changes that may affect your code.
+ : Any code using selectall_hashref(), which was added in March 2001, WILL
+ : need to be changed. Any code using fetchall_arrayref() with a non-empty
+ : hash slice parameter may, in a few rare cases, need to be changed.
+ : See the change list below for more information about the changes.
+ : See the DBI documentation for a description of current behaviour.
+
+ Fixed memory leak thanks to Toni Andjelkovic.
+ Changed fetchall_arrayref({ foo=>1, ...}) specification again (sorry):
+ The key names of the returned hashes is identical to the letter case of
+ the names in the parameter hash, regardless of the L</FetchHashKeyName>
+ attribute. The letter case is ignored for matching.
+ Changed fetchall_arrayref([...]) array slice syntax specification to
+ clarify that the numbers in the array slice are perl index numbers
+ (which start at 0) and not column numbers (which start at 1).
+ Added { Columns=>... } and { Slice =>... } attributes to selectall_arrayref()
+ which is passed to fetchall_arrayref() so it can fetch hashes now.
+ Added a { Columns => [...] } attribute to selectcol_arrayref() so that
+ the list it returns can be built from more than one column per row.
+ Why? Consider my %hash = @{$dbh->selectcol_arrayref($sql,{ Columns=>[1,2]})}
+ to return id-value pairs which can be used directly to build a hash.
+ Added $hash_ref = $sth->fetchall_hashref( $key_field )
+ which returns a ref to a hash with, typically, one element per row.
+ $key_field is the name of the field to get the key for each row from.
+ The value of the hash for each row is a hash returned by fetchrow_hashref.
+ Changed selectall_hashref to return a hash ref (from fetchall_hashref)
+ and not an array of hashes as it has since DBI 1.15 (end March 2001).
+ WARNING: THIS CHANGE WILL BREAK ANY CODE USING selectall_hashref()!
+ Sorry, but I think this is an important regularization of the API.
+ To get previous selectall_hashref() behaviour (an array of hash refs)
+ change $ary_ref = $dbh->selectall_hashref( $statement, undef, @bind);
+ to $ary_ref = $dbh->selectall_arrayref($statement, { Columns=>{} }, @bind);
+ Added NAME_lc_hash, NAME_uc_hash, NAME_hash statement handle attributes.
+ which return a ref to a hash of field_name => field_index (0..n-1) pairs.
+ Fixed select_hash() example thanks to Doug Wilson.
+ Removed (unbundled) DBD::ADO and DBD::Multiplex from the DBI distribution.
+ The latest versions of those modules are available from CPAN sites.
+ Added $dbh->begin_work. This method causes AutoCommit to be turned
+ off just until the next commit() or rollback().
+ Driver authors: if the DBIcf_BegunWork flag is set when your commit or
+ rollback method is called then please turn AutoCommit on and clear the
+ DBIcf_BegunWork flag. If you don't then the DBI will but it'll be much
+ less efficient and won't handle error conditions very cleanly.
+ Retested on perl 5.4.4, but the DBI won't support 5.4.x much longer.
+ Added text to SUPPORT section of the docs:
+ For direct DBI and DBD::Oracle support, enhancement, and related work
+ I am available for consultancy on standard commercial terms.
+ Added text to ACKNOWLEDGEMENTS section of the docs:
+ Much of the DBI and DBD::Oracle was developed while I was Technical
+ Director (CTO) of the Paul Ingram Group (www.ig.co.uk). So I'd
+ especially like to thank Paul for his generosity and vision in
+ supporting this work for many years.
+
+=head2 Changes in DBI 1.19, 20th July 2001
+
+ Made fetchall_arrayref({ foo=>1, ...}) be more strict to the specification
+ in relation to wanting hash slice keys to be lowercase names.
+ WARNING: If you've used fetchall_arrayref({...}) with a hash slice
+ that contains keys with uppercase letters then your code will break.
+ (As far as I recall the spec has always said don't do that.)
+ Fixed $sth->execute() to update $dbh->{Statement} to $sth->{Statement}.
+ Added row number to trace output for fetch method calls.
+ Trace level 1 no longer shows fetches with row>1 (to reduce output volume).
+ Added $h->{FetchHashKeyName} = 'NAME_lc' or 'NAME_uc' to alter
+ behaviour of fetchrow_hashref() method. See docs.
+ Added type_info quote caching to quote() method thanks to Dean Kopesky.
+ Makes using quote() with second data type param much much faster.
+ Added type_into_all() caching to type_info(), spotted by Dean Kopesky.
+ Added new API definition for table_info() and tables(),
+ driver authors please note!
+ Added primary_key_info() to DBI API thanks to Steffen Goeldner.
+ Added primary_key() to DBI API as simpler interface to primary_key_info().
+ Indent and other fixes for DBI::DBD doc thanks to H.Merijn Brand.
+ Added prepare_cached() insert_hash() example thanks to Doug Wilson.
+ Removed false docs for fetchall_hashref(), use fetchall_arrayref({}).
+
+=head2 Changes in DBI 1.18, 4th June 2001
+
+ Fixed that altering ShowErrorStatement also altered AutoCommit!
+ Thanks to Jeff Boes for spotting that clanger.
+ Fixed DBD::Proxy to handle commit() and rollback(). Long overdue, sorry.
+ Fixed incompatibility with perl 5.004 (but no one's using that right? :)
+ Fixed connect_cached and prepare_cached to not be affected by the order
+ of elements in the attribute hash. Spotted by Mitch Helle-Morrissey.
+ Fixed version number of DBI::Shell
+ reported by Stuhlpfarrer Gerhard and others.
+ Defined and documented table_info() attribute semantics (ODBC compatible)
+ thanks to Olga Voronova, who also implemented then in DBD::Oracle.
+ Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee.
+
+=head2 Changes in DBI 1.16, 30th May 2001
+
+ Reimplemented fetchrow_hashref in C, now fetches about 25% faster!
+ Changed behaviour if both PrintError and RaiseError are enabled
+ to simply do both (in that order, obviously :)
+ Slight reduction in DBI handle creation overhead.
+ Fixed $dbh->{Driver} & $sth->{Database} to return 'outer' handles.
+ Fixed execute param count check to honour RaiseError spotted by Belinda Giardie.
+ Fixed build for perl5.6.1 with PERLIO thanks to H.Merijn Brand.
+ Fixed client sql restrictions in ProxyServer.pm thanks to Jochen Wiedmann.
+ Fixed batch mode command parsing in Shell thanks to Christian Lemburg.
+ Fixed typo in selectcol_arrayref docs thanks to Jonathan Leffler.
+ Fixed selectrow_hashref to be available to callers thanks to T.J.Mather.
+ Fixed core dump if statement handle didn't define Statement attribute.
+ Added bind_param_inout docs to DBI::DBD thanks to Jonathan Leffler.
+ Added note to data_sources() method docs that some drivers may
+ require a connected database handle to be supplied as an attribute.
+ Trace of install_driver method now shows path of driver file loaded.
+ Changed many '||' to 'or' in the docs thanks to H.Merijn Brand.
+ Updated DBD::ADO again (improvements in error handling) from Tom Lowery.
+ Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee.
+ Updated email and web addresses in DBI::FAQ thanks to Michael A Chase.
+
+=head2 Changes in DBI 1.15, 28th March 2001
+
+ Added selectrow_arrayref
+ Added selectrow_hashref
+ Added selectall_hashref thanks to Leon Brocard.
+ Added DBI->connect(..., { dbi_connect_method => 'method' })
+ Added $dbh->{Statement} aliased to most recent child $sth->{Statement}.
+ Added $h->{ShowErrorStatement}=1 to cause the appending of the
+ relevant Statement text to the RaiseError/PrintError text.
+ Modified type_info to always return hash keys in uppercase and
+ to not require uppercase 'DATA_TYPE' key from type_info_all.
+ Thanks to Jennifer Tong and Rob Douglas.
+ Added \%attr param to tables() and table_info() methods.
+ Trace method uses warn() if it can't open the new file.
+ Trace shows source line and filename during global destruction.
+ Updated packages:
+ Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee.
+ Updated DBD::ADO to much improved version 0.4 from Tom Lowery.
+ Updated DBD::Sponge to include $sth->{PRECISION} thanks to Tom Lowery.
+ Changed DBD::ExampleP to use lstat() instead of stat().
+ Documentation:
+ Documented $DBI::lasth (which has been there since day 1).
+ Documented SQL_* names.
+ Clarified and extended docs for $h->state thanks to Masaaki Hirose.
+ Clarified fetchall_arrayref({}) docs (thanks to, er, someone!).
+ Clarified type_info_all re lettercase and index values.
+ Updated DBI::FAQ to 0.38 thanks to Alligator Descartes.
+ Added cute bind_columns example thanks to H.Merijn Brand.
+ Extended docs on \%attr arg to data_sources method.
+ Makefile.PL
+ Removed obscure potential 'rm -rf /' (thanks to Ulrich Pfeifer).
+ Removed use of glob and find (thanks to Michael A. Chase).
+ Proxy:
+ Removed debug messages from DBD::Proxy AUTOLOAD thanks to Brian McCauley.
+ Added fix for problem using table_info thanks to Tom Lowery.
+ Added better determination of where to put the pid file, and...
+ Added KNOWN ISSUES section to DBD::Proxy docs thanks to Jochen Wiedmann.
+ Shell:
+ Updated DBI::Format to include DBI::Format::String thanks to Tom Lowery.
+ Added describe command thanks to Tom Lowery.
+ Added columnseparator option thanks to Tom Lowery (I think).
+ Added 'raw' format thanks to, er, someone, maybe Tom again.
+ Known issues:
+ Perl 5.005 and 5.006 both leak memory doing local($handle->{Foo}).
+ Perl 5.004 doesn't. The leak is not a DBI or driver bug.
+
+=head2 Changes in DBI 1.14, 14th June 2000
+
+ NOTE: This version is the one the DBI book is based on.
+ NOTE: This version requires at least Perl 5.004.
+ Perl 5.6 ithreads changes with thanks to Doug MacEachern.
+ Changed trace output to use PerlIO thanks to Paul Moore.
+ Fixed bug in RaiseError/PrintError handling.
+ (% chars in the error string could cause a core dump.)
+ Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt.
+ Major documentation polishing thanks to Linda Mui at O'Reilly.
+ Password parameter now shown as **** in trace output.
+ Added two fields to type_info and type_info_all.
+ Added $dsn to PrintError/RaiseError message from DBI->connect().
+ Changed prepare_cached() croak to carp if sth still Active.
+ Added prepare_cached() example to the docs.
+ Added further DBD::ADO enhancements from Thomas Lowery.
+
+=head2 Changes in DBI 1.13, 11th July 1999
+
+ Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt.
+ Fixed problems with DBD::ExampleP long_list test mode.
+ Added SQL_WCHAR SQL_WVARCHAR SQL_WLONGVARCHAR and SQL_BIT
+ to list of known and exportable SQL types.
+ Improved data fetch performance of DBD::ADO.
+ Added GetTypeInfo to DBD::ADO thanks to Thomas Lowery.
+ Actually documented connect_cached thanks to Michael Schwern.
+ Fixed user/key/cipher bug in ProxyServer thanks to Joshua Pincus.
+
+=head2 Changes in DBI 1.12, 29th June 1999
+
+ Fixed significant DBD::ADO bug (fetch skipped first row).
+ Fixed ProxyServer bug handling non-select statements.
+ Fixed VMS problem with t/examp.t thanks to Craig Berry.
+ Trace only shows calls to trace_msg and _set_fbav at high levels.
+ Modified t/examp.t to workaround Cygwin buffering bug.
+
+=head2 Changes in DBI 1.11, 17th June 1999
+
+ Fixed bind_columns argument checking to allow a single arg.
+ Fixed problems with internal default_user method.
+ Fixed broken DBD::ADO.
+ Made default $DBI::rows more robust for some obscure cases.
+
+=head2 Changes in DBI 1.10, 14th June 1999
+
+ Fixed trace_msg.al error when using Apache.
+ Fixed dbd_st_finish enhancement in Driver.xst (internals).
+ Enable drivers to define default username and password
+ and temporarily disabled warning added in 1.09.
+ Thread safety optimised for single thread case.
+
+=head2 Changes in DBI 1.09, 9th June 1999
+
+ Added optional minimum trace level parameter to trace_msg().
+ Added warning in Makefile.PL that DBI will require 5.004 soon.
+ Added $dbh->selectcol_arrayref($statement) method.
+ Fixed fetchall_arrayref hash-slice mode undef NAME problem.
+ Fixed problem with tainted parameter checking and t/examp.t.
+ Fixed problem with thread safety code, including 64 bit machines.
+ Thread safety now enabled by default for threaded perls.
+ Enhanced code for MULTIPLICITY/PERL_OBJECT from ActiveState.
+ Enhanced prepare_cached() method.
+ Minor changes to trace levels (less internal info at level 2).
+ Trace log now shows "!! ERROR..." before the "<- method" line.
+ DBI->connect() now warn's if user / password is undefined and
+ DBI_USER / DBI_PASS environment variables are not defined.
+ The t/proxy.t test now ignores any /etc/dbiproxy.conf file.
+ Added portability fixes for MacOS from Chris Nandor.
+ Updated mailing list address from fugue.com to isc.org.
+
+=head2 Changes in DBI 1.08, 12th May 1999
+
+ Much improved DBD::ADO driver thanks to Phlip Plumlee and others.
+ Connect now allows you to specify attribute settings within the DSN
+ E.g., "dbi:Driver(RaiseError=>1,Taint=>1,AutoCommit=>0):dbname"
+ The $h->{Taint} attribute now also enables taint checking of
+ arguments to almost all DBI methods.
+ Improved trace output in various ways.
+ Fixed bug where $sth->{NAME_xx} was undef in some situations.
+ Fixed code for MULTIPLICITY/PERL_OBJECT thanks to Alex Smishlajev.
+ Fixed and documented DBI->connect_cached.
+ Workaround for Cygwin32 build problem with help from Jong-Pork Park.
+ bind_columns no longer needs undef or hash ref as first parameter.
+
+=head2 Changes in DBI 1.07, 6th May 1999
+
+ Trace output now shows contents of array refs returned by DBI.
+ Changed names of some result columns from type_info, type_info_all,
+ tables and table_info to match ODBC 3.5 / ISO/IEC standards.
+ Many fixes for DBD::Proxy and ProxyServer.
+ Fixed error reporting in install_driver.
+ Major enhancement to DBI::W32ODBC from Patrick Hollins.
+ Added $h->{Taint} to taint fetched data if tainting (perl -T).
+ Added code for MULTIPLICITY/PERL_OBJECT contributed by ActiveState.
+ Added $sth->more_results (undocumented for now).
+
+=head2 Changes in DBI 1.06, 6th January 1999
+
+ Fixed Win32 Makefile.PL problem in 1.04 and 1.05.
+ Significant DBD::Proxy enhancements and fixes
+ including support for bind_param_inout (Jochen and I)
+ Added experimental DBI->connect_cached method.
+ Added $sth->{NAME_uc} and $sth->{NAME_lc} attributes.
+ Enhanced fetchrow_hashref to take an attribute name arg.
+
+=head2 Changes in DBI 1.05, 4th January 1999
+
+ Improved DBD::ADO connect (thanks to Phlip Plumlee).
+ Improved thread safety (thanks to Jochen Wiedmann).
+ [Quick release prompted by truncation of copies on CPAN]
+
+=head2 Changes in DBI 1.04, 3rd January 1999
+
+ Fixed error in Driver.xst. DBI build now tests Driver.xst.
+ Removed unused variable compiler warnings in Driver.xst.
+ DBI::DBD module now tested during DBI build.
+ Further clarification in the DBI::DBD driver writers manual.
+ Added optional name parameter to $sth->fetchrow_hashref.
+
+=head2 Changes in DBI 1.03, 1st January 1999
+
+ Now builds with Perl>=5.005_54 (PERL_POLLUTE in DBIXS.h)
+ DBI trace trims path from "at yourfile.pl line nnn".
+ Trace level 1 now shows statement passed to prepare.
+ Assorted improvements to the DBI manual.
+ Assorted improvements to the DBI::DBD driver writers manual.
+ Fixed $dbh->quote prototype to include optional $data_type.
+ Fixed $dbh->prepare_cached problems.
+ $dbh->selectrow_array behaves better in scalar context.
+ Added a (very) experimental DBD::ADO driver for Win32 ADO.
+ Added experimental thread support (perl Makefile.PL -thread).
+ Updated the DBI::FAQ - thanks to Alligator Descartes.
+ The following changes were implemented and/or packaged
+ by Jochen Wiedmann - thanks Jochen:
+ Added a Bundle for CPAN installation of DBI, the DBI proxy
+ server and prerequisites (lib/Bundle/DBI.pm).
+ DBI->available_drivers uses File::Spec, if available.
+ This makes it work on MacOS. (DBI.pm)
+ Modified type_info to work with read-only values returned
+ by type_info_all. (DBI.pm)
+ Added handling of magic values in $sth->execute,
+ $sth->bind_param and other methods (Driver.xst)
+ Added Perl's CORE directory to the linkers path on Win32,
+ required by recent versions of ActiveState Perl.
+ Fixed DBD::Sponge to work with empty result sets.
+ Complete rewrite of DBI::ProxyServer and DBD::Proxy.
+
+=head2 Changes in DBI 1.02, 2nd September 1998
+
+ Fixed DBI::Shell including @ARGV and /current.
+ Added basic DBI::Shell test.
+ Renamed DBI::Shell /display to /format.
+
+=head2 Changes in DBI 1.01, 2nd September 1998
+
+ Many enhancements to Shell (with many contributions from
+ Jochen Wiedmann, Tom Lowery and Adam Marks).
+ Assorted fixes to DBD::Proxy and DBI::ProxyServer.
+ Tidied up trace messages - trace(2) much cleaner now.
+ Added $dbh->{RowCacheSize} and $sth->{RowsInCache}.
+ Added experimental DBI::Format (mainly for DBI::Shell).
+ Fixed fetchall_arrayref($slice_hash).
+ DBI->connect now honours PrintError=1 if connect fails.
+ Assorted clarifications to the docs.
+
+=head2 Changes in DBI 1.00, 14th August 1998
+
+ The DBI is no longer 'alpha' software!
+ Added $dbh->tables and $dbh->table_info.
+ Documented \%attr arg to data_sources method.
+ Added $sth->{TYPE}, $sth->{PRECISION} and $sth->{SCALE}.
+ Added $sth->{Statement}.
+ DBI::Shell now uses neat_list to print results
+ It also escapes "'" chars and converts newlines to spaces.
+
+=head2 Changes in DBI 0.95, 10th August 1998
+
+ WARNING: THIS IS AN EXPERIMENTAL RELEASE!
+
+ Fixed 0.94 slip so it will build on pre-5.005 again.
+ Added DBI_AUTOPROXY environment variable.
+ Array ref returned from fetch/fetchrow_arrayref now readonly.
+ Improved connect error reporting by DBD::Proxy.
+ All trace/debug messages from DBI now go to trace file.
+
+=head2 Changes in DBI 0.94, 9th August 1998
+
+ WARNING: THIS IS AN EXPERIMENTAL RELEASE!
+
+ Added DBD::Shell and dbish interactive DBI shell. Try it!
+ Any database attribs can be set via DBI->connect(,,, \%attr).
+ Added _get_fbav and _set_fbav methods for Perl driver developers
+ (see ExampleP driver for perl usage). Drivers which don't use
+ one of these methods (either via XS or Perl) are not compliant.
+ DBI trace now shows adds " at yourfile.pl line nnn"!
+ PrintError and RaiseError now prepend driver and method name.
+ The available_drivers method no longer returns NullP or Sponge.
+ Added $dbh->{Name}.
+ Added $dbh->quote($value, $data_type).
+ Added more hints to install_driver failure message.
+ Added DBD::Proxy and DBI::ProxyServer (from Jochen Wiedmann).
+ Added $DBI::neat_maxlen to control truncation of trace output.
+ Added $dbh->selectall_arrayref and $dbh->selectrow_array methods.
+ Added $dbh->tables.
+ Added $dbh->type_info and $dbh->type_info_all.
+ Added $h->trace_msg($msg) to write to trace log.
+ Added @bool = DBI::looks_like_number(@ary).
+ Many assorted improvements to the DBI docs.
+
+=head2 Changes in DBI 0.93, 13th February 1998
+
+ Fixed DBI::DBD::dbd_postamble bug causing 'Driver.xsi not found' errors.
+ Changes to handling of 'magic' values in neatsvpv (used by trace).
+ execute (in Driver.xst) stops binding after first bind error.
+ This release requires drivers to be rebuilt.
+
+=head2 Changes in DBI 0.92, 3rd February 1998
+
+ Fixed per-handle memory leak (with many thanks to Irving Reid).
+ Added $dbh->prepare_cached() caching variant of $dbh->prepare.
+ Added some attributes:
+ $h->{Active} is the handle 'Active' (vague concept) (boolean)
+ $h->{Kids} e.g. number of sth's associated with a dbh
+ $h->{ActiveKids} number of the above which are 'Active'
+ $dbh->{CachedKids} ref to prepare_cached sth cache
+ Added support for general-purpose 'private_' attributes.
+ Added experimental support for subclassing the DBI: see t/subclass.t
+ Added SQL_ALL_TYPES to exported :sql_types.
+ Added dbd_dbi_dir() and dbd_dbi_arch_dir() to DBI::DBD module so that
+ DBD Makefile.PLs can work with the DBI installed in non-standard locations.
+ Fixed 'Undefined value' warning and &sv_no output from neatsvpv/trace.
+ Fixed small 'once per interpreter' leak.
+ Assorted minor documentation fixes.
+
+=head2 Changes in DBI 0.91, 10th December 1997
+
+ NOTE: This fix may break some existing scripts:
+ DBI->connect("dbi:...",$user,$pass) was not setting AutoCommit and PrintError!
+ DBI->connect(..., { ... }) no longer sets AutoCommit or PrintError twice.
+ DBI->connect(..., { RaiseError=>1 }) now croaks if connect fails.
+ Fixed $fh parameter of $sth->dump_results;
+ Added default statement DESTROY method which carps.
+ Added default driver DESTROY method to silence AUTOLOAD/__DIE__/CGI::Carp
+ Added more SQL_* types to %EXPORT_TAGS and @EXPORT_OK.
+ Assorted documentation updates (mainly clarifications).
+ Added workaround for perl's 'sticky lvalue' bug.
+ Added better warning for bind_col(umns) where fields==0.
+ Fixed to build okay with 5.004_54 with or without USE_THREADS.
+ Note that the DBI has not been tested for thread safety yet.
+
+=head2 Changes in DBI 0.90, 6th September 1997
+
+ Can once again be built with Perl 5.003.
+ The DBI class can be subclassed more easily now.
+ InactiveDestroy fixed for drivers using the *.xst template.
+ Slightly faster handle creation.
+ Changed prototype for dbd_*_*_attrib() to add extra param.
+ Note: 0.90, 0.89 and possibly some other recent versions have
+ a small memory leak. This will be fixed in the next release.
+
+=head2 Changes in DBI 0.89, 25th July 1997
+
+ Minor fix to neatsvpv (mainly used for debug trace) to workaround
+ bug in perl where SvPV removes IOK flag from an SV.
+ Minor updates to the docs.
+
+=head2 Changes in DBI 0.88, 22nd July 1997
+
+ Fixed build for perl5.003 and Win32 with Borland.
+ Fixed documentation formatting.
+ Fixed DBI_DSN ignored for old-style connect (with explicit driver).
+ Fixed AutoCommit in DBD::ExampleP
+ Fixed $h->trace.
+ The DBI can now export SQL type values: use DBI ':sql_types';
+ Modified Driver.xst and renamed DBDI.h to dbd_xsh.h
+
+=head2 Changes in DBI 0.87, 18th July 1997
+
+ Fixed minor type clashes.
+ Added more docs about placeholders and bind values.
+
+=head2 Changes in DBI 0.86, 16th July 1997
+
+ Fixed failed connect causing 'unblessed ref' and other errors.
+ Drivers must handle AutoCommit FETCH and STORE else DBI croaks.
+ Added $h->{LongReadLen} and $h->{LongTruncOk} attributes for BLOBS.
+ Added DBI_USER and DBI_PASS env vars. See connect docs for usage.
+ Added DBI->trace() to set global trace level (like per-handle $h->trace).
+ PERL_DBI_DEBUG env var renamed DBI_DEBUG (old name still works for now).
+ Updated docs, including commit, rollback, AutoCommit and Transactions sections.
+ Added bind_param method and execute(@bind_values) to docs.
+ Fixed fetchall_arrayref.
+
+ Since the DBIS structure has change the internal version numbers have also
+ changed (DBIXS_VERSION == 9 and DBISTATE_VERSION == 9) so drivers will have
+ to be recompiled. The test is also now more sensitive and the version
+ mismatch error message now more clear about what to do. Old drivers are
+ likely to core dump (this time) until recompiled for this DBI. In future
+ DBI/DBD version mismatch will always produce a clear error message.
+
+ Note that this DBI release contains and documents many new features
+ that won't appear in drivers for some time. Driver writers might like
+ to read perldoc DBI::DBD and comment on or apply the information given.
+
+=head2 Changes in DBI 0.85, 25th June 1997
+
+ NOTE: New-style connect now defaults to AutoCommit mode unless
+ { AutoCommit => 0 } specified in connect attributes. See the docs.
+ AutoCommit attribute now defined and tracked by DBI core.
+ Drivers should use/honour this and not implement their own.
+ Added pod doc changes from Andreas and Jonathan.
+ New DBI_DSN env var default for connect method. See docs.
+ Documented the func method.
+ Fixed "Usage: DBD::_::common::DESTROY" error.
+ Fixed bug which set some attributes true when there value was fetched.
+ Added new internal DBIc_set() macro for drivers to use.
+
+=head2 Changes in DBI 0.84, 20th June 1997
+
+ Added $h->{PrintError} attribute which, if set true, causes all errors to
+ trigger a warn().
+ New-style DBI->connect call now automatically sets PrintError=1 unless
+ { PrintError => 0 } specified in the connect attributes. See the docs.
+ The old-style connect with a separate driver parameter is deprecated.
+ Fixed fetchrow_hashref.
+ Renamed $h->debug to $h->trace() and added a trace filename arg.
+ Assorted other minor tidy-ups.
+
+=head2 Changes in DBI 0.83, 11th June 1997
+
+ Added driver specification syntax to DBI->connect data_source
+ parameter: DBI->connect('dbi:driver:...', $user, $passwd);
+ The DBI->data_sources method should return data_source
+ names with the appropriate 'dbi:driver:' prefix.
+ DBI->connect will warn if \%attr is true but not a hash ref.
+ Added the new fetchrow methods:
+ @row_ary = $sth->fetchrow_array;
+ $ary_ref = $sth->fetchrow_arrayref;
+ $hash_ref = $sth->fetchrow_hashref;
+ The old fetch and fetchrow methods still work.
+ Driver implementors should implement the new names for
+ fetchrow_array and fetchrow_arrayref ASAP (use the xs ALIAS:
+ directive to define aliases for fetch and fetchrow).
+ Fixed occasional problems with t/examp.t test.
+ Added automatic errstr reporting to the debug trace output.
+ Added the DBI FAQ from Alligator Descartes in module form for
+ easy reading via "perldoc DBI::FAQ". Needs reformatting.
+ Unknown driver specific attribute names no longer croak.
+ Fixed problem with internal neatsvpv macro.
+
+=head2 Changes in DBI 0.82, 23rd May 1997
+
+ Added $h->{RaiseError} attribute which, if set true, causes all errors to
+ trigger a die(). This makes it much easier to implement robust applications
+ in terms of higher level eval { ... } blocks and rollbacks.
+ Added DBI->data_sources($driver) method for implementation by drivers.
+ The quote method now returns the string NULL (without quotes) for undef.
+ Added VMS support thanks to Dan Sugalski.
+ Added a 'quick start guide' to the README.
+ Added neatsvpv function pointer to DBIS structure to make it available for
+ use by drivers. A macro defines neatsvpv(sv,len) as (DBIS->neatsvpv(sv,len)).
+ Old XS macro SV_YES_NO changes to standard boolSV.
+ Since the DBIS structure has change the internal version numbers have also
+ changed (DBIXS_VERSION == 8 and DBISTATE_VERSION == 8) so drivers will have
+ to be recompiled.
+
+=head2 Changes in DBI 0.81, 7th May 1997
+
+ Minor fix to let DBI build using less modern perls.
+ Fixed a suprious typo warning.
+
+=head2 Changes in DBI 0.80, 6th May 1997
+
+ Builds with no changes on NT using perl5.003_99 (with thanks to Jeffrey Urlwin).
+ Automatically supports Apache::DBI (with thanks to Edmund Mergl).
+ DBI scripts no longer need to be modified to make use of Apache::DBI.
+ Added a ping method and an experimental connect_test_perf method.
+ Added a fetchhash and fetch_all methods.
+ The func method no longer pre-clears err and errstr.
+ Added ChopBlanks attribute (currently defaults to off, that may change).
+ Support for the attribute needs to be implemented by individual drivers.
+ Reworked tests into standard t/*.t form.
+ Added more pod text. Fixed assorted bugs.
+
+
+=head2 Changes in DBI 0.79, 7th Apr 1997
+
+ Minor release. Tidied up pod text and added some more descriptions
+ (especially disconnect). Minor changes to DBI.xs to remove compiler
+ warnings.
+
+=head2 Changes in DBI 0.78, 28th Mar 1997
+
+ Greatly extended the pod documentation in DBI.pm, including the under
+ used bind_columns method. Use 'perldoc DBI' to read after installing.
+ Fixed $h->err. Fetching an attribute value no longer resets err.
+ Added $h->{InactiveDestroy}, see documentation for details.
+ Improved debugging of cached ('quick') attribute fetches.
+ errstr will return err code value if there is no string value.
+ Added DBI/W32ODBC to the distribution. This is a pure-perl experimental
+ DBI emulation layer for Win32::ODBC. Note that it's unsupported, your
+ mileage will vary, and bug reports without fixes will probably be ignored.
+
+=head2 Changes in DBI 0.77, 21st Feb 1997
+
+ Removed erroneous $h->errstate and $h->errmsg methods from DBI.pm.
+ Added $h->err, $h->errstr and $h->state default methods in DBI.xs.
+ Updated informal DBI API notes in DBI.pm. Updated README slightly.
+ DBIXS.h now correctly installed into INST_ARCHAUTODIR.
+ (DBD authors will need to edit their Makefile.PL's to use
+ -I$(INSTALLSITEARCH)/auto/DBI -I$(INSTALLSITEARCH)/DBI)
+
+
+=head2 Changes in DBI 0.76, 3rd Feb 1997
+
+ Fixed a compiler type warnings (pedantic IRIX again).
+
+=head2 Changes in DBI 0.75, 27th Jan 1997
+
+ Fix problem introduced by a change in Perl5.003_XX.
+ Updated README and DBI.pm docs.
+
+=head2 Changes in DBI 0.74, 14th Jan 1997
+
+ Dispatch now sets dbi_debug to the level of the current handle
+ (this makes tracing/debugging individual handles much easier).
+ The '>> DISPATCH' log line now only logged at debug >= 3 (was 2).
+ The $csr->NUM_OF_FIELDS attribute can be set if not >0 already.
+ You can log to a file using the env var PERL_DBI_DEBUG=/tmp/dbi.log.
+ Added a type cast needed by IRIX.
+ No longer sets perl_destruct_level unless debug set >= 4.
+ Make compatible with PerlIO and sfio.
+
+=head2 Changes in DBI 0.73, 10th Oct 1996
+
+ Fixed some compiler type warnings (IRIX).
+ Fixed DBI->internal->{DebugLog} = $filename.
+ Made debug log file unbuffered.
+ Added experimental bind_param_inout method to interface.
+ Usage: $dbh->bind_param_inout($param, \$value, $maxlen [, \%attribs ])
+ (only currently used by DBD::Oracle at this time.)
+
+=head2 Changes in DBI 0.72, 23 Sep 1996
+
+ Using an undefined value as a handle now gives a better
+ error message (mainly useful for emulators like Oraperl).
+ $dbh->do($sql, @params) now works for binding placeholders.
+
+=head2 Changes in DBI 0.71, 10 July 1996
+
+ Removed spurious abort() from invalid handle check.
+ Added quote method to DBI interface and added test.
+
+=head2 Changes in DBI 0.70, 16 June 1996
+
+ Added extra invalid handle check (dbih_getcom)
+ Fixed broken $dbh->quote method.
+ Added check for old GCC in Makefile.PL
+
+=head2 Changes in DBI 0.69
+
+ Fixed small memory leak.
+ Clarified the behaviour of DBI->connect.
+ $dbh->do now returns '0E0' instead of 'OK'.
+ Fixed "Can't read $DBI::errstr, lost last handle" problem.
+
+
+=head2 Changes in DBI 0.68, 2 Mar 1996
+
+ Changes to suit perl5.002 and site_lib directories.
+ Detects old versions ahead of new in @INC.
+
+
+=head2 Changes in DBI 0.67, 15 Feb 1996
+
+ Trivial change to test suite to fix a problem shown up by the
+ Perl5.002gamma release Test::Harness.
+
+
+=head2 Changes in DBI 0.66, 29 Jan 1996
+
+ Minor changes to bring the DBI into line with 5.002 mechanisms,
+ specifically the xs/pm VERSION checking mechanism.
+ No functionality changes. One no-last-handle bug fix (rare problem).
+ Requires 5.002 (beta2 or later).
+
+
+=head2 Changes in DBI 0.65, 23 Oct 1995
+
+ Added $DBI::state to hold SQL CLI / ODBC SQLSTATE value.
+ SQLSTATE "00000" (success) is returned as "" (false), all else is true.
+ If a driver does not explicitly initialise it (via $h->{State} or
+ DBIc_STATE(imp_xxh) then $DBI::state will automatically return "" if
+ $DBI::err is false otherwise "S1000" (general error).
+ As always, this is a new feature and liable to change.
+
+ The is *no longer* a default error handler!
+ You can add your own using push(@{$h->{Handlers}}, sub { ... })
+ but be aware that this interface may change (or go away).
+
+ The DBI now automatically clears $DBI::err, errstr and state before
+ calling most DBI methods. Previously error conditions would persist.
+ Added DBIh_CLEAR_ERROR(imp_xxh) macro.
+
+ DBI now EXPORT_OK's some utility functions, neat($value),
+ neat_list(@values) and dump_results($sth).
+
+ Slightly enhanced t/min.t minimal test script in an effort to help
+ narrow down the few stray core dumps that some porters still report.
+
+ Renamed readblob to blob_read (old name still works but warns).
+ Added default blob_copy_to_file method.
+
+ Added $sth = $dbh->tables method. This returns an $sth for a query
+ which has these columns: TABLE_CATALOGUE, TABLE_OWNER, TABLE_NAME,
+ TABLE_TYPE, REMARKS in that order. The TABLE_CATALOGUE column
+ should be ignored for now.
+
+
+=head2 Changes in DBI 0.64, 23 Oct 1995
+
+ Fixed 'disconnect invalidates 1 associated cursor(s)' problem.
+ Drivers using DBIc_ACTIVE_on/off() macros should not need any changes
+ other than to test for DBIc_ACTIVE_KIDS() instead of DBIc_KIDS().
+ Fixed possible core dump in dbih_clearcom during global destruction.
+
+
+=head2 Changes in DBI 0.63, 1 Sep 1995
+
+ Minor update. Fixed uninitialised memory bug in method
+ attribute handling and streamlined processing and debugging.
+ Revised usage definitions for bind_* methods and readblob.
+
+
+=head2 Changes in DBI 0.62, 26 Aug 1995
+
+ Added method redirection method $h->func(..., $method_name).
+ This is now the official way to call private driver methods
+ that are not part of the DBI standard. E.g.:
+ @ary = $sth->func('ora_types');
+ It can also be used to call existing methods. Has very low cost.
+
+ $sth->bind_col columns now start from 1 (not 0) to match SQL.
+ $sth->bind_columns now takes a leading attribute parameter (or undef),
+ e.g., $sth->bind_columns($attribs, \$col1 [, \$col2 , ...]);
+
+ Added handy DBD_ATTRIBS_CHECK macro to vet attribs in XS.
+ Added handy DBD_ATTRIB_GET_SVP, DBD_ATTRIB_GET_BOOL and
+ DBD_ATTRIB_GET_IV macros for handling attributes.
+
+ Fixed STORE for NUM_OF_FIELDS and NUM_OF_PARAMS.
+ Added FETCH for NUM_OF_FIELDS and NUM_OF_PARAMS.
+
+ Dispatch no longer bothers to call _untie().
+ Faster startup via install_method/_add_dispatch changes.
+
+
+=head2 Changes in DBI 0.61, 22 Aug 1995
+
+ Added $sth->bind_col($column, \$var [, \%attribs ]);
+
+ This method enables perl variable to be directly and automatically
+ updated when a row is fetched. It requires no driver support
+ (if the driver has been written to use DBIS->get_fbav).
+ Currently \%attribs is unused.
+
+ Added $sth->bind_columns(\$var [, \$var , ...]);
+
+ This method is a short-cut for bind_col which binds all the
+ columns of a query in one go (with no attributes). It also
+ requires no driver support.
+
+ Added $sth->bind_param($parameter, $var [, \%attribs ]);
+
+ This method enables attributes to be specified when values are
+ bound to placeholders. It also enables binding to occur away
+ from the execute method to improve execute efficiency.
+ The DBI does not provide a default implementation of this.
+ See the DBD::Oracle module for a detailed example.
+
+ The DBI now provides default implementations of both fetch and
+ fetchrow. Each is written in terms of the other. A driver is
+ expected to implement at least one of them.
+
+ More macro and assorted structure changes in DBDXS.h. Sorry!
+ The old dbihcom definitions have gone. All fields have macros.
+ The imp_xxh_t type is now used within the DBI as well as drivers.
+ Drivers must set DBIc_NUM_FIELDS(imp_sth) and DBIc_NUM_PARAMS(imp_sth).
+
+ test.pl includes a trivial test of bind_param and bind_columns.
+
+
+=head2 Changes in DBI 0.60, 17 Aug 1995
+
+ This release has significant code changes but much less
+ dramatic than the previous release. The new implementors data
+ handling mechanism has matured significantly (don't be put off
+ by all the struct typedefs in DBIXS.h, there's just to make it
+ easier for drivers while keeping things type-safe).
+
+ The DBI now includes two new methods:
+
+ do $dbh->do($statement)
+
+ This method prepares, executes and finishes a statement. It is
+ designed to be used for executing one-off non-select statements
+ where there is no benefit in reusing a prepared statement handle.
+
+ fetch $array_ref = $sth->fetch;
+
+ This method is the new 'lowest-level' row fetching method. The
+ previous @row = $sth->fetchrow method now defaults to calling
+ the fetch method and expanding the returned array reference.
+
+ The DBI now provides fallback attribute FETCH and STORE functions
+ which drivers should call if they don't recognise an attribute.
+
+ THIS RELEASE IS A GOOD STARTING POINT FOR DRIVER DEVELOPERS!
+ Study DBIXS.h from the DBI and Oracle.xs etc from DBD::Oracle.
+ There will be further changes in the interface but nothing
+ as dramatic as these last two releases! (I hope :-)
+
+
+=head2 Changes in DBI 0.59 15 Aug 1995
+
+ NOTE: THIS IS AN UNSTABLE RELEASE!
+
+ Major reworking of internal data management!
+ Performance improvements and memory leaks fixed.
+ Added a new NullP (empty) driver and a -m flag
+ to test.pl to help check for memory leaks.
+ Study DBD::Oracle version 0.21 for more details.
+ (Comparing parts of v0.21 with v0.20 may be useful.)
+
+
+=head2 Changes in DBI 0.58 21 June 1995
+
+ Added DBI->internal->{DebugLog} = $filename;
+ Reworked internal logging.
+ Added $VERSION.
+ Made disconnect_all a compulsary method for drivers.
+
+
+=head1 ANCIENT HISTORY
+
+12th Oct 1994: First public release of the DBI module.
+ (for Perl 5.000-beta-3h)
+
+19th Sep 1994: DBperl project renamed to DBI.
+
+29th Sep 1992: DBperl project started.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ANSI.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ANSI.pm
new file mode 100755
index 00000000000..428ce37188b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ANSI.pm
@@ -0,0 +1,236 @@
+# $Id: ANSI.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# Copyright (c) 2002 Tim Bunce Ireland
+#
+# Constant data describing ANSI CLI info types and return values for the
+# SQLGetInfo() method of ODBC.
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+package DBI::Const::GetInfo::ANSI;
+
+=head1 NAME
+
+DBI::Const::GetInfo::ANSI - ISO/IEC SQL/CLI Constants for GetInfo
+
+=head1 SYNOPSIS
+
+ The API for this module is private and subject to change.
+
+=head1 DESCRIPTION
+
+Information requested by GetInfo().
+
+See: A.1 C header file SQLCLI.H, Page 316, 317.
+
+The API for this module is private and subject to change.
+
+=head1 REFERENCES
+
+ ISO/IEC FCD 9075-3:200x Information technology - Database Languages -
+ SQL - Part 3: Call-Level Interface (SQL/CLI)
+
+ SC32 N00744 = WG3:VIE-005 = H2-2002-007
+
+ Date: 2002-01-15
+
+=cut
+
+my
+$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+
+%InfoTypes =
+(
+ SQL_ALTER_TABLE => 86
+, SQL_CATALOG_NAME => 10003
+, SQL_COLLATING_SEQUENCE => 10004
+, SQL_CURSOR_COMMIT_BEHAVIOR => 23
+, SQL_CURSOR_SENSITIVITY => 10001
+, SQL_DATA_SOURCE_NAME => 2
+, SQL_DATA_SOURCE_READ_ONLY => 25
+, SQL_DBMS_NAME => 17
+, SQL_DBMS_VERSION => 18
+, SQL_DEFAULT_TRANSACTION_ISOLATION => 26
+, SQL_DESCRIBE_PARAMETER => 10002
+, SQL_FETCH_DIRECTION => 8
+, SQL_GETDATA_EXTENSIONS => 81
+, SQL_IDENTIFIER_CASE => 28
+, SQL_INTEGRITY => 73
+, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34
+, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97
+, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99
+, SQL_MAXIMUM_COLUMNS_IN_SELECT => 100
+, SQL_MAXIMUM_COLUMNS_IN_TABLE => 101
+, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30
+, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1
+, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31
+, SQL_MAXIMUM_DRIVER_CONNECTIONS => 0
+, SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005
+, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32
+, SQL_MAXIMUM_STMT_OCTETS => 20000
+, SQL_MAXIMUM_STMT_OCTETS_DATA => 20001
+, SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 20002
+, SQL_MAXIMUM_TABLES_IN_SELECT => 106
+, SQL_MAXIMUM_TABLE_NAME_LENGTH => 35
+, SQL_MAXIMUM_USER_NAME_LENGTH => 107
+, SQL_NULL_COLLATION => 85
+, SQL_ORDER_BY_COLUMNS_IN_SELECT => 90
+, SQL_OUTER_JOIN_CAPABILITIES => 115
+, SQL_SCROLL_CONCURRENCY => 43
+, SQL_SEARCH_PATTERN_ESCAPE => 14
+, SQL_SERVER_NAME => 13
+, SQL_SPECIAL_CHARACTERS => 94
+, SQL_TRANSACTION_CAPABLE => 46
+, SQL_TRANSACTION_ISOLATION_OPTION => 72
+, SQL_USER_NAME => 47
+);
+
+=head2 %ReturnTypes
+
+See: Codes and data types for implementation information (Table 28), Page 85, 86.
+
+Mapped to ODBC datatype names.
+
+=cut
+
+%ReturnTypes = # maxlen
+(
+ SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # INTEGER
+, SQL_CATALOG_NAME => 'SQLCHAR' # CHARACTER (1)
+, SQL_COLLATING_SEQUENCE => 'SQLCHAR' # CHARACTER (254)
+, SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # SMALLINT
+, SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # INTEGER
+, SQL_DATA_SOURCE_NAME => 'SQLCHAR' # CHARACTER (128)
+, SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # CHARACTER (1)
+, SQL_DBMS_NAME => 'SQLCHAR' # CHARACTER (254)
+, SQL_DBMS_VERSION => 'SQLCHAR' # CHARACTER (254)
+, SQL_DEFAULT_TRANSACTION_ISOLATION => 'SQLUINTEGER' # INTEGER
+, SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # CHARACTER (1)
+, SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # INTEGER
+, SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # INTEGER
+, SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # SMALLINT
+, SQL_INTEGRITY => 'SQLCHAR' # CHARACTER (1)
+, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_STMT_OCTETS => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_STMT_OCTETS_DATA => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_TABLE_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT
+, SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT
+, SQL_NULL_COLLATION => 'SQLUSMALLINT' # SMALLINT
+, SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # CHARACTER (1)
+, SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # INTEGER
+, SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # INTEGER
+, SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # CHARACTER (1)
+, SQL_SERVER_NAME => 'SQLCHAR' # CHARACTER (128)
+, SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # CHARACTER (254)
+, SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # SMALLINT
+, SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # INTEGER
+, SQL_USER_NAME => 'SQLCHAR' # CHARACTER (128)
+);
+
+=head2 %ReturnValues
+
+See: A.1 C header file SQLCLI.H, Page 317, 318.
+
+=cut
+
+$ReturnValues{SQL_ALTER_TABLE} =
+{
+ SQL_AT_ADD_COLUMN => 0x00000001
+, SQL_AT_DROP_COLUMN => 0x00000002
+, SQL_AT_ALTER_COLUMN => 0x00000004
+, SQL_AT_ADD_CONSTRAINT => 0x00000008
+, SQL_AT_DROP_CONSTRAINT => 0x00000010
+};
+$ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} =
+{
+ SQL_CB_DELETE => 0
+, SQL_CB_CLOSE => 1
+, SQL_CB_PRESERVE => 2
+};
+$ReturnValues{SQL_FETCH_DIRECTION} =
+{
+ SQL_FD_FETCH_NEXT => 0x00000001
+, SQL_FD_FETCH_FIRST => 0x00000002
+, SQL_FD_FETCH_LAST => 0x00000004
+, SQL_FD_FETCH_PRIOR => 0x00000008
+, SQL_FD_FETCH_ABSOLUTE => 0x00000010
+, SQL_FD_FETCH_RELATIVE => 0x00000020
+};
+$ReturnValues{SQL_GETDATA_EXTENSIONS} =
+{
+ SQL_GD_ANY_COLUMN => 0x00000001
+, SQL_GD_ANY_ORDER => 0x00000002
+};
+$ReturnValues{SQL_IDENTIFIER_CASE} =
+{
+ SQL_IC_UPPER => 1
+, SQL_IC_LOWER => 2
+, SQL_IC_SENSITIVE => 3
+, SQL_IC_MIXED => 4
+};
+$ReturnValues{SQL_NULL_COLLATION} =
+{
+ SQL_NC_HIGH => 1
+, SQL_NC_LOW => 2
+};
+$ReturnValues{SQL_OUTER_JOIN_CAPABILITIES} =
+{
+ SQL_OUTER_JOIN_LEFT => 0x00000001
+, SQL_OUTER_JOIN_RIGHT => 0x00000002
+, SQL_OUTER_JOIN_FULL => 0x00000004
+, SQL_OUTER_JOIN_NESTED => 0x00000008
+, SQL_OUTER_JOIN_NOT_ORDERED => 0x00000010
+, SQL_OUTER_JOIN_INNER => 0x00000020
+, SQL_OUTER_JOIN_ALL_COMPARISON_OPS => 0x00000040
+};
+$ReturnValues{SQL_SCROLL_CONCURRENCY} =
+{
+ SQL_SCCO_READ_ONLY => 0x00000001
+, SQL_SCCO_LOCK => 0x00000002
+, SQL_SCCO_OPT_ROWVER => 0x00000004
+, SQL_SCCO_OPT_VALUES => 0x00000008
+};
+$ReturnValues{SQL_TRANSACTION_ACCESS_MODE} =
+{
+ SQL_TRANSACTION_READ_ONLY => 0x00000001
+, SQL_TRANSACTION_READ_WRITE => 0x00000002
+};
+$ReturnValues{SQL_TRANSACTION_CAPABLE} =
+{
+ SQL_TC_NONE => 0
+, SQL_TC_DML => 1
+, SQL_TC_ALL => 2
+, SQL_TC_DDL_COMMIT => 3
+, SQL_TC_DDL_IGNORE => 4
+};
+$ReturnValues{SQL_TRANSACTION_ISOLATION} =
+{
+ SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001
+, SQL_TRANSACTION_READ_COMMITTED => 0x00000002
+, SQL_TRANSACTION_REPEATABLE_READ => 0x00000004
+, SQL_TRANSACTION_SERIALIZABLE => 0x00000008
+};
+
+1;
+
+=head1 TODO
+
+Corrections, e.g.:
+
+ SQL_TRANSACTION_ISOLATION_OPTION vs. SQL_TRANSACTION_ISOLATION
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ODBC.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ODBC.pm
new file mode 100755
index 00000000000..0f71a064e11
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfo/ODBC.pm
@@ -0,0 +1,1363 @@
+# $Id: ODBC.pm 11373 2008-06-02 19:01:33Z timbo $
+#
+# Copyright (c) 2002 Tim Bunce Ireland
+#
+# Constant data describing Microsoft ODBC info types and return values
+# for the SQLGetInfo() method of ODBC.
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+package DBI::Const::GetInfo::ODBC;
+
+=head1 NAME
+
+DBI::Const::GetInfo::ODBC - ODBC Constants for GetInfo
+
+=head1 SYNOPSIS
+
+ The API for this module is private and subject to change.
+
+=head1 DESCRIPTION
+
+Information requested by GetInfo().
+
+The API for this module is private and subject to change.
+
+=head1 REFERENCES
+
+ MDAC SDK 2.6
+ ODBC version number (0x0351)
+
+ sql.h
+ sqlext.h
+
+=cut
+
+my
+$VERSION = sprintf("2.%06d", q$Revision: 11373 $ =~ /(\d+)/o);
+
+
+%InfoTypes =
+(
+ SQL_ACCESSIBLE_PROCEDURES => 20
+, SQL_ACCESSIBLE_TABLES => 19
+, SQL_ACTIVE_CONNECTIONS => 0
+, SQL_ACTIVE_ENVIRONMENTS => 116
+, SQL_ACTIVE_STATEMENTS => 1
+, SQL_AGGREGATE_FUNCTIONS => 169
+, SQL_ALTER_DOMAIN => 117
+, SQL_ALTER_TABLE => 86
+, SQL_ASYNC_MODE => 10021
+, SQL_BATCH_ROW_COUNT => 120
+, SQL_BATCH_SUPPORT => 121
+, SQL_BOOKMARK_PERSISTENCE => 82
+, SQL_CATALOG_LOCATION => 114 # SQL_QUALIFIER_LOCATION
+, SQL_CATALOG_NAME => 10003
+, SQL_CATALOG_NAME_SEPARATOR => 41 # SQL_QUALIFIER_NAME_SEPARATOR
+, SQL_CATALOG_TERM => 42 # SQL_QUALIFIER_TERM
+, SQL_CATALOG_USAGE => 92 # SQL_QUALIFIER_USAGE
+, SQL_COLLATION_SEQ => 10004
+, SQL_COLUMN_ALIAS => 87
+, SQL_CONCAT_NULL_BEHAVIOR => 22
+, SQL_CONVERT_BIGINT => 53
+, SQL_CONVERT_BINARY => 54
+, SQL_CONVERT_BIT => 55
+, SQL_CONVERT_CHAR => 56
+, SQL_CONVERT_DATE => 57
+, SQL_CONVERT_DECIMAL => 58
+, SQL_CONVERT_DOUBLE => 59
+, SQL_CONVERT_FLOAT => 60
+, SQL_CONVERT_FUNCTIONS => 48
+, SQL_CONVERT_GUID => 173
+, SQL_CONVERT_INTEGER => 61
+, SQL_CONVERT_INTERVAL_DAY_TIME => 123
+, SQL_CONVERT_INTERVAL_YEAR_MONTH => 124
+, SQL_CONVERT_LONGVARBINARY => 71
+, SQL_CONVERT_LONGVARCHAR => 62
+, SQL_CONVERT_NUMERIC => 63
+, SQL_CONVERT_REAL => 64
+, SQL_CONVERT_SMALLINT => 65
+, SQL_CONVERT_TIME => 66
+, SQL_CONVERT_TIMESTAMP => 67
+, SQL_CONVERT_TINYINT => 68
+, SQL_CONVERT_VARBINARY => 69
+, SQL_CONVERT_VARCHAR => 70
+, SQL_CONVERT_WCHAR => 122
+, SQL_CONVERT_WLONGVARCHAR => 125
+, SQL_CONVERT_WVARCHAR => 126
+, SQL_CORRELATION_NAME => 74
+, SQL_CREATE_ASSERTION => 127
+, SQL_CREATE_CHARACTER_SET => 128
+, SQL_CREATE_COLLATION => 129
+, SQL_CREATE_DOMAIN => 130
+, SQL_CREATE_SCHEMA => 131
+, SQL_CREATE_TABLE => 132
+, SQL_CREATE_TRANSLATION => 133
+, SQL_CREATE_VIEW => 134
+, SQL_CURSOR_COMMIT_BEHAVIOR => 23
+, SQL_CURSOR_ROLLBACK_BEHAVIOR => 24
+, SQL_CURSOR_SENSITIVITY => 10001
+, SQL_DATA_SOURCE_NAME => 2
+, SQL_DATA_SOURCE_READ_ONLY => 25
+, SQL_DATABASE_NAME => 16
+, SQL_DATETIME_LITERALS => 119
+, SQL_DBMS_NAME => 17
+, SQL_DBMS_VER => 18
+, SQL_DDL_INDEX => 170
+, SQL_DEFAULT_TXN_ISOLATION => 26
+, SQL_DESCRIBE_PARAMETER => 10002
+, SQL_DM_VER => 171
+, SQL_DRIVER_HDBC => 3
+, SQL_DRIVER_HDESC => 135
+, SQL_DRIVER_HENV => 4
+, SQL_DRIVER_HLIB => 76
+, SQL_DRIVER_HSTMT => 5
+, SQL_DRIVER_NAME => 6
+, SQL_DRIVER_ODBC_VER => 77
+, SQL_DRIVER_VER => 7
+, SQL_DROP_ASSERTION => 136
+, SQL_DROP_CHARACTER_SET => 137
+, SQL_DROP_COLLATION => 138
+, SQL_DROP_DOMAIN => 139
+, SQL_DROP_SCHEMA => 140
+, SQL_DROP_TABLE => 141
+, SQL_DROP_TRANSLATION => 142
+, SQL_DROP_VIEW => 143
+, SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 144
+, SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 145
+, SQL_EXPRESSIONS_IN_ORDERBY => 27
+, SQL_FETCH_DIRECTION => 8
+, SQL_FILE_USAGE => 84
+, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 146
+, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 147
+, SQL_GETDATA_EXTENSIONS => 81
+, SQL_GROUP_BY => 88
+, SQL_IDENTIFIER_CASE => 28
+, SQL_IDENTIFIER_QUOTE_CHAR => 29
+, SQL_INDEX_KEYWORDS => 148
+# SQL_INFO_DRIVER_START => 1000
+# SQL_INFO_FIRST => 0
+# SQL_INFO_LAST => 114 # SQL_QUALIFIER_LOCATION
+, SQL_INFO_SCHEMA_VIEWS => 149
+, SQL_INSERT_STATEMENT => 172
+, SQL_INTEGRITY => 73
+, SQL_KEYSET_CURSOR_ATTRIBUTES1 => 150
+, SQL_KEYSET_CURSOR_ATTRIBUTES2 => 151
+, SQL_KEYWORDS => 89
+, SQL_LIKE_ESCAPE_CLAUSE => 113
+, SQL_LOCK_TYPES => 78
+, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34 # SQL_MAX_CATALOG_NAME_LEN
+, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97 # SQL_MAX_COLUMNS_IN_GROUP_BY
+, SQL_MAXIMUM_COLUMNS_IN_INDEX => 98 # SQL_MAX_COLUMNS_IN_INDEX
+, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99 # SQL_MAX_COLUMNS_IN_ORDER_BY
+, SQL_MAXIMUM_COLUMNS_IN_SELECT => 100 # SQL_MAX_COLUMNS_IN_SELECT
+, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30 # SQL_MAX_COLUMN_NAME_LEN
+, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1 # SQL_MAX_CONCURRENT_ACTIVITIES
+, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31 # SQL_MAX_CURSOR_NAME_LEN
+, SQL_MAXIMUM_DRIVER_CONNECTIONS => 0 # SQL_MAX_DRIVER_CONNECTIONS
+, SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005 # SQL_MAX_IDENTIFIER_LEN
+, SQL_MAXIMUM_INDEX_SIZE => 102 # SQL_MAX_INDEX_SIZE
+, SQL_MAXIMUM_ROW_SIZE => 104 # SQL_MAX_ROW_SIZE
+, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32 # SQL_MAX_SCHEMA_NAME_LEN
+, SQL_MAXIMUM_STATEMENT_LENGTH => 105 # SQL_MAX_STATEMENT_LEN
+, SQL_MAXIMUM_TABLES_IN_SELECT => 106 # SQL_MAX_TABLES_IN_SELECT
+, SQL_MAXIMUM_USER_NAME_LENGTH => 107 # SQL_MAX_USER_NAME_LEN
+, SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 10022
+, SQL_MAX_BINARY_LITERAL_LEN => 112
+, SQL_MAX_CATALOG_NAME_LEN => 34
+, SQL_MAX_CHAR_LITERAL_LEN => 108
+, SQL_MAX_COLUMNS_IN_GROUP_BY => 97
+, SQL_MAX_COLUMNS_IN_INDEX => 98
+, SQL_MAX_COLUMNS_IN_ORDER_BY => 99
+, SQL_MAX_COLUMNS_IN_SELECT => 100
+, SQL_MAX_COLUMNS_IN_TABLE => 101
+, SQL_MAX_COLUMN_NAME_LEN => 30
+, SQL_MAX_CONCURRENT_ACTIVITIES => 1
+, SQL_MAX_CURSOR_NAME_LEN => 31
+, SQL_MAX_DRIVER_CONNECTIONS => 0
+, SQL_MAX_IDENTIFIER_LEN => 10005
+, SQL_MAX_INDEX_SIZE => 102
+, SQL_MAX_OWNER_NAME_LEN => 32
+, SQL_MAX_PROCEDURE_NAME_LEN => 33
+, SQL_MAX_QUALIFIER_NAME_LEN => 34
+, SQL_MAX_ROW_SIZE => 104
+, SQL_MAX_ROW_SIZE_INCLUDES_LONG => 103
+, SQL_MAX_SCHEMA_NAME_LEN => 32
+, SQL_MAX_STATEMENT_LEN => 105
+, SQL_MAX_TABLES_IN_SELECT => 106
+, SQL_MAX_TABLE_NAME_LEN => 35
+, SQL_MAX_USER_NAME_LEN => 107
+, SQL_MULTIPLE_ACTIVE_TXN => 37
+, SQL_MULT_RESULT_SETS => 36
+, SQL_NEED_LONG_DATA_LEN => 111
+, SQL_NON_NULLABLE_COLUMNS => 75
+, SQL_NULL_COLLATION => 85
+, SQL_NUMERIC_FUNCTIONS => 49
+, SQL_ODBC_API_CONFORMANCE => 9
+, SQL_ODBC_INTERFACE_CONFORMANCE => 152
+, SQL_ODBC_SAG_CLI_CONFORMANCE => 12
+, SQL_ODBC_SQL_CONFORMANCE => 15
+, SQL_ODBC_SQL_OPT_IEF => 73
+, SQL_ODBC_VER => 10
+, SQL_OJ_CAPABILITIES => 115
+, SQL_ORDER_BY_COLUMNS_IN_SELECT => 90
+, SQL_OUTER_JOINS => 38
+, SQL_OUTER_JOIN_CAPABILITIES => 115 # SQL_OJ_CAPABILITIES
+, SQL_OWNER_TERM => 39
+, SQL_OWNER_USAGE => 91
+, SQL_PARAM_ARRAY_ROW_COUNTS => 153
+, SQL_PARAM_ARRAY_SELECTS => 154
+, SQL_POSITIONED_STATEMENTS => 80
+, SQL_POS_OPERATIONS => 79
+, SQL_PROCEDURES => 21
+, SQL_PROCEDURE_TERM => 40
+, SQL_QUALIFIER_LOCATION => 114
+, SQL_QUALIFIER_NAME_SEPARATOR => 41
+, SQL_QUALIFIER_TERM => 42
+, SQL_QUALIFIER_USAGE => 92
+, SQL_QUOTED_IDENTIFIER_CASE => 93
+, SQL_ROW_UPDATES => 11
+, SQL_SCHEMA_TERM => 39 # SQL_OWNER_TERM
+, SQL_SCHEMA_USAGE => 91 # SQL_OWNER_USAGE
+, SQL_SCROLL_CONCURRENCY => 43
+, SQL_SCROLL_OPTIONS => 44
+, SQL_SEARCH_PATTERN_ESCAPE => 14
+, SQL_SERVER_NAME => 13
+, SQL_SPECIAL_CHARACTERS => 94
+, SQL_SQL92_DATETIME_FUNCTIONS => 155
+, SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 156
+, SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 157
+, SQL_SQL92_GRANT => 158
+, SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 159
+, SQL_SQL92_PREDICATES => 160
+, SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 161
+, SQL_SQL92_REVOKE => 162
+, SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 163
+, SQL_SQL92_STRING_FUNCTIONS => 164
+, SQL_SQL92_VALUE_EXPRESSIONS => 165
+, SQL_SQL_CONFORMANCE => 118
+, SQL_STANDARD_CLI_CONFORMANCE => 166
+, SQL_STATIC_CURSOR_ATTRIBUTES1 => 167
+, SQL_STATIC_CURSOR_ATTRIBUTES2 => 168
+, SQL_STATIC_SENSITIVITY => 83
+, SQL_STRING_FUNCTIONS => 50
+, SQL_SUBQUERIES => 95
+, SQL_SYSTEM_FUNCTIONS => 51
+, SQL_TABLE_TERM => 45
+, SQL_TIMEDATE_ADD_INTERVALS => 109
+, SQL_TIMEDATE_DIFF_INTERVALS => 110
+, SQL_TIMEDATE_FUNCTIONS => 52
+, SQL_TRANSACTION_CAPABLE => 46 # SQL_TXN_CAPABLE
+, SQL_TRANSACTION_ISOLATION_OPTION => 72 # SQL_TXN_ISOLATION_OPTION
+, SQL_TXN_CAPABLE => 46
+, SQL_TXN_ISOLATION_OPTION => 72
+, SQL_UNION => 96
+, SQL_UNION_STATEMENT => 96 # SQL_UNION
+, SQL_USER_NAME => 47
+, SQL_XOPEN_CLI_YEAR => 10000
+);
+
+=head2 %ReturnTypes
+
+See: mk:@MSITStore:X:\dm\cli\mdac\sdk26\Docs\odbc.chm::/htm/odbcsqlgetinfo.htm
+
+ => : alias
+ => !!! : edited
+
+=cut
+
+%ReturnTypes =
+(
+ SQL_ACCESSIBLE_PROCEDURES => 'SQLCHAR' # 20
+, SQL_ACCESSIBLE_TABLES => 'SQLCHAR' # 19
+, SQL_ACTIVE_CONNECTIONS => 'SQLUSMALLINT' # 0 =>
+, SQL_ACTIVE_ENVIRONMENTS => 'SQLUSMALLINT' # 116
+, SQL_ACTIVE_STATEMENTS => 'SQLUSMALLINT' # 1 =>
+, SQL_AGGREGATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 169
+, SQL_ALTER_DOMAIN => 'SQLUINTEGER bitmask' # 117
+, SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # 86
+, SQL_ASYNC_MODE => 'SQLUINTEGER' # 10021
+, SQL_BATCH_ROW_COUNT => 'SQLUINTEGER bitmask' # 120
+, SQL_BATCH_SUPPORT => 'SQLUINTEGER bitmask' # 121
+, SQL_BOOKMARK_PERSISTENCE => 'SQLUINTEGER bitmask' # 82
+, SQL_CATALOG_LOCATION => 'SQLUSMALLINT' # 114
+, SQL_CATALOG_NAME => 'SQLCHAR' # 10003
+, SQL_CATALOG_NAME_SEPARATOR => 'SQLCHAR' # 41
+, SQL_CATALOG_TERM => 'SQLCHAR' # 42
+, SQL_CATALOG_USAGE => 'SQLUINTEGER bitmask' # 92
+, SQL_COLLATION_SEQ => 'SQLCHAR' # 10004
+, SQL_COLUMN_ALIAS => 'SQLCHAR' # 87
+, SQL_CONCAT_NULL_BEHAVIOR => 'SQLUSMALLINT' # 22
+, SQL_CONVERT_BIGINT => 'SQLUINTEGER bitmask' # 53
+, SQL_CONVERT_BINARY => 'SQLUINTEGER bitmask' # 54
+, SQL_CONVERT_BIT => 'SQLUINTEGER bitmask' # 55
+, SQL_CONVERT_CHAR => 'SQLUINTEGER bitmask' # 56
+, SQL_CONVERT_DATE => 'SQLUINTEGER bitmask' # 57
+, SQL_CONVERT_DECIMAL => 'SQLUINTEGER bitmask' # 58
+, SQL_CONVERT_DOUBLE => 'SQLUINTEGER bitmask' # 59
+, SQL_CONVERT_FLOAT => 'SQLUINTEGER bitmask' # 60
+, SQL_CONVERT_FUNCTIONS => 'SQLUINTEGER bitmask' # 48
+, SQL_CONVERT_GUID => 'SQLUINTEGER bitmask' # 173
+, SQL_CONVERT_INTEGER => 'SQLUINTEGER bitmask' # 61
+, SQL_CONVERT_INTERVAL_DAY_TIME => 'SQLUINTEGER bitmask' # 123
+, SQL_CONVERT_INTERVAL_YEAR_MONTH => 'SQLUINTEGER bitmask' # 124
+, SQL_CONVERT_LONGVARBINARY => 'SQLUINTEGER bitmask' # 71
+, SQL_CONVERT_LONGVARCHAR => 'SQLUINTEGER bitmask' # 62
+, SQL_CONVERT_NUMERIC => 'SQLUINTEGER bitmask' # 63
+, SQL_CONVERT_REAL => 'SQLUINTEGER bitmask' # 64
+, SQL_CONVERT_SMALLINT => 'SQLUINTEGER bitmask' # 65
+, SQL_CONVERT_TIME => 'SQLUINTEGER bitmask' # 66
+, SQL_CONVERT_TIMESTAMP => 'SQLUINTEGER bitmask' # 67
+, SQL_CONVERT_TINYINT => 'SQLUINTEGER bitmask' # 68
+, SQL_CONVERT_VARBINARY => 'SQLUINTEGER bitmask' # 69
+, SQL_CONVERT_VARCHAR => 'SQLUINTEGER bitmask' # 70
+, SQL_CONVERT_WCHAR => 'SQLUINTEGER bitmask' # 122 => !!!
+, SQL_CONVERT_WLONGVARCHAR => 'SQLUINTEGER bitmask' # 125 => !!!
+, SQL_CONVERT_WVARCHAR => 'SQLUINTEGER bitmask' # 126 => !!!
+, SQL_CORRELATION_NAME => 'SQLUSMALLINT' # 74
+, SQL_CREATE_ASSERTION => 'SQLUINTEGER bitmask' # 127
+, SQL_CREATE_CHARACTER_SET => 'SQLUINTEGER bitmask' # 128
+, SQL_CREATE_COLLATION => 'SQLUINTEGER bitmask' # 129
+, SQL_CREATE_DOMAIN => 'SQLUINTEGER bitmask' # 130
+, SQL_CREATE_SCHEMA => 'SQLUINTEGER bitmask' # 131
+, SQL_CREATE_TABLE => 'SQLUINTEGER bitmask' # 132
+, SQL_CREATE_TRANSLATION => 'SQLUINTEGER bitmask' # 133
+, SQL_CREATE_VIEW => 'SQLUINTEGER bitmask' # 134
+, SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # 23
+, SQL_CURSOR_ROLLBACK_BEHAVIOR => 'SQLUSMALLINT' # 24
+, SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # 10001
+, SQL_DATA_SOURCE_NAME => 'SQLCHAR' # 2
+, SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # 25
+, SQL_DATABASE_NAME => 'SQLCHAR' # 16
+, SQL_DATETIME_LITERALS => 'SQLUINTEGER bitmask' # 119
+, SQL_DBMS_NAME => 'SQLCHAR' # 17
+, SQL_DBMS_VER => 'SQLCHAR' # 18
+, SQL_DDL_INDEX => 'SQLUINTEGER bitmask' # 170
+, SQL_DEFAULT_TXN_ISOLATION => 'SQLUINTEGER' # 26
+, SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # 10002
+, SQL_DM_VER => 'SQLCHAR' # 171
+, SQL_DRIVER_HDBC => 'SQLUINTEGER' # 3
+, SQL_DRIVER_HDESC => 'SQLUINTEGER' # 135
+, SQL_DRIVER_HENV => 'SQLUINTEGER' # 4
+, SQL_DRIVER_HLIB => 'SQLUINTEGER' # 76
+, SQL_DRIVER_HSTMT => 'SQLUINTEGER' # 5
+, SQL_DRIVER_NAME => 'SQLCHAR' # 6
+, SQL_DRIVER_ODBC_VER => 'SQLCHAR' # 77
+, SQL_DRIVER_VER => 'SQLCHAR' # 7
+, SQL_DROP_ASSERTION => 'SQLUINTEGER bitmask' # 136
+, SQL_DROP_CHARACTER_SET => 'SQLUINTEGER bitmask' # 137
+, SQL_DROP_COLLATION => 'SQLUINTEGER bitmask' # 138
+, SQL_DROP_DOMAIN => 'SQLUINTEGER bitmask' # 139
+, SQL_DROP_SCHEMA => 'SQLUINTEGER bitmask' # 140
+, SQL_DROP_TABLE => 'SQLUINTEGER bitmask' # 141
+, SQL_DROP_TRANSLATION => 'SQLUINTEGER bitmask' # 142
+, SQL_DROP_VIEW => 'SQLUINTEGER bitmask' # 143
+, SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 144
+, SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 145
+, SQL_EXPRESSIONS_IN_ORDERBY => 'SQLCHAR' # 27
+, SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # 8 => !!!
+, SQL_FILE_USAGE => 'SQLUSMALLINT' # 84
+, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 146
+, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 147
+, SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # 81
+, SQL_GROUP_BY => 'SQLUSMALLINT' # 88
+, SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # 28
+, SQL_IDENTIFIER_QUOTE_CHAR => 'SQLCHAR' # 29
+, SQL_INDEX_KEYWORDS => 'SQLUINTEGER bitmask' # 148
+# SQL_INFO_DRIVER_START => '' # 1000 =>
+# SQL_INFO_FIRST => 'SQLUSMALLINT' # 0 =>
+# SQL_INFO_LAST => 'SQLUSMALLINT' # 114 =>
+, SQL_INFO_SCHEMA_VIEWS => 'SQLUINTEGER bitmask' # 149
+, SQL_INSERT_STATEMENT => 'SQLUINTEGER bitmask' # 172
+, SQL_INTEGRITY => 'SQLCHAR' # 73
+, SQL_KEYSET_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 150
+, SQL_KEYSET_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 151
+, SQL_KEYWORDS => 'SQLCHAR' # 89
+, SQL_LIKE_ESCAPE_CLAUSE => 'SQLCHAR' # 113
+, SQL_LOCK_TYPES => 'SQLUINTEGER bitmask' # 78 => !!!
+, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # 34 =>
+, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97 =>
+, SQL_MAXIMUM_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98 =>
+, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99 =>
+, SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100 =>
+, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # 30 =>
+, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1 =>
+, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # 31 =>
+, SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0 =>
+, SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # 10005 =>
+, SQL_MAXIMUM_INDEX_SIZE => 'SQLUINTEGER' # 102 =>
+, SQL_MAXIMUM_ROW_SIZE => 'SQLUINTEGER' # 104 =>
+, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # 32 =>
+, SQL_MAXIMUM_STATEMENT_LENGTH => 'SQLUINTEGER' # 105 =>
+, SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106 =>
+, SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # 107 =>
+, SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 'SQLUINTEGER' # 10022
+, SQL_MAX_BINARY_LITERAL_LEN => 'SQLUINTEGER' # 112
+, SQL_MAX_CATALOG_NAME_LEN => 'SQLUSMALLINT' # 34
+, SQL_MAX_CHAR_LITERAL_LEN => 'SQLUINTEGER' # 108
+, SQL_MAX_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97
+, SQL_MAX_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98
+, SQL_MAX_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99
+, SQL_MAX_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100
+, SQL_MAX_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # 101
+, SQL_MAX_COLUMN_NAME_LEN => 'SQLUSMALLINT' # 30
+, SQL_MAX_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1
+, SQL_MAX_CURSOR_NAME_LEN => 'SQLUSMALLINT' # 31
+, SQL_MAX_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0
+, SQL_MAX_IDENTIFIER_LEN => 'SQLUSMALLINT' # 10005
+, SQL_MAX_INDEX_SIZE => 'SQLUINTEGER' # 102
+, SQL_MAX_OWNER_NAME_LEN => 'SQLUSMALLINT' # 32 =>
+, SQL_MAX_PROCEDURE_NAME_LEN => 'SQLUSMALLINT' # 33
+, SQL_MAX_QUALIFIER_NAME_LEN => 'SQLUSMALLINT' # 34 =>
+, SQL_MAX_ROW_SIZE => 'SQLUINTEGER' # 104
+, SQL_MAX_ROW_SIZE_INCLUDES_LONG => 'SQLCHAR' # 103
+, SQL_MAX_SCHEMA_NAME_LEN => 'SQLUSMALLINT' # 32
+, SQL_MAX_STATEMENT_LEN => 'SQLUINTEGER' # 105
+, SQL_MAX_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106
+, SQL_MAX_TABLE_NAME_LEN => 'SQLUSMALLINT' # 35
+, SQL_MAX_USER_NAME_LEN => 'SQLUSMALLINT' # 107
+, SQL_MULTIPLE_ACTIVE_TXN => 'SQLCHAR' # 37
+, SQL_MULT_RESULT_SETS => 'SQLCHAR' # 36
+, SQL_NEED_LONG_DATA_LEN => 'SQLCHAR' # 111
+, SQL_NON_NULLABLE_COLUMNS => 'SQLUSMALLINT' # 75
+, SQL_NULL_COLLATION => 'SQLUSMALLINT' # 85
+, SQL_NUMERIC_FUNCTIONS => 'SQLUINTEGER bitmask' # 49
+, SQL_ODBC_API_CONFORMANCE => 'SQLUSMALLINT' # 9 => !!!
+, SQL_ODBC_INTERFACE_CONFORMANCE => 'SQLUINTEGER' # 152
+, SQL_ODBC_SAG_CLI_CONFORMANCE => 'SQLUSMALLINT' # 12 => !!!
+, SQL_ODBC_SQL_CONFORMANCE => 'SQLUSMALLINT' # 15 => !!!
+, SQL_ODBC_SQL_OPT_IEF => 'SQLCHAR' # 73 =>
+, SQL_ODBC_VER => 'SQLCHAR' # 10
+, SQL_OJ_CAPABILITIES => 'SQLUINTEGER bitmask' # 115
+, SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # 90
+, SQL_OUTER_JOINS => 'SQLCHAR' # 38 => !!!
+, SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # 115 =>
+, SQL_OWNER_TERM => 'SQLCHAR' # 39 =>
+, SQL_OWNER_USAGE => 'SQLUINTEGER bitmask' # 91 =>
+, SQL_PARAM_ARRAY_ROW_COUNTS => 'SQLUINTEGER' # 153
+, SQL_PARAM_ARRAY_SELECTS => 'SQLUINTEGER' # 154
+, SQL_POSITIONED_STATEMENTS => 'SQLUINTEGER bitmask' # 80 => !!!
+, SQL_POS_OPERATIONS => 'SQLINTEGER bitmask' # 79
+, SQL_PROCEDURES => 'SQLCHAR' # 21
+, SQL_PROCEDURE_TERM => 'SQLCHAR' # 40
+, SQL_QUALIFIER_LOCATION => 'SQLUSMALLINT' # 114 =>
+, SQL_QUALIFIER_NAME_SEPARATOR => 'SQLCHAR' # 41 =>
+, SQL_QUALIFIER_TERM => 'SQLCHAR' # 42 =>
+, SQL_QUALIFIER_USAGE => 'SQLUINTEGER bitmask' # 92 =>
+, SQL_QUOTED_IDENTIFIER_CASE => 'SQLUSMALLINT' # 93
+, SQL_ROW_UPDATES => 'SQLCHAR' # 11
+, SQL_SCHEMA_TERM => 'SQLCHAR' # 39
+, SQL_SCHEMA_USAGE => 'SQLUINTEGER bitmask' # 91
+, SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # 43 => !!!
+, SQL_SCROLL_OPTIONS => 'SQLUINTEGER bitmask' # 44
+, SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # 14
+, SQL_SERVER_NAME => 'SQLCHAR' # 13
+, SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # 94
+, SQL_SQL92_DATETIME_FUNCTIONS => 'SQLUINTEGER bitmask' # 155
+, SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 'SQLUINTEGER bitmask' # 156
+, SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 'SQLUINTEGER bitmask' # 157
+, SQL_SQL92_GRANT => 'SQLUINTEGER bitmask' # 158
+, SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 'SQLUINTEGER bitmask' # 159
+, SQL_SQL92_PREDICATES => 'SQLUINTEGER bitmask' # 160
+, SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 'SQLUINTEGER bitmask' # 161
+, SQL_SQL92_REVOKE => 'SQLUINTEGER bitmask' # 162
+, SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 'SQLUINTEGER bitmask' # 163
+, SQL_SQL92_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 164
+, SQL_SQL92_VALUE_EXPRESSIONS => 'SQLUINTEGER bitmask' # 165
+, SQL_SQL_CONFORMANCE => 'SQLUINTEGER' # 118
+, SQL_STANDARD_CLI_CONFORMANCE => 'SQLUINTEGER bitmask' # 166
+, SQL_STATIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 167
+, SQL_STATIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 168
+, SQL_STATIC_SENSITIVITY => 'SQLUINTEGER bitmask' # 83 => !!!
+, SQL_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 50
+, SQL_SUBQUERIES => 'SQLUINTEGER bitmask' # 95
+, SQL_SYSTEM_FUNCTIONS => 'SQLUINTEGER bitmask' # 51
+, SQL_TABLE_TERM => 'SQLCHAR' # 45
+, SQL_TIMEDATE_ADD_INTERVALS => 'SQLUINTEGER bitmask' # 109
+, SQL_TIMEDATE_DIFF_INTERVALS => 'SQLUINTEGER bitmask' # 110
+, SQL_TIMEDATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 52
+, SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # 46 =>
+, SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72 =>
+, SQL_TXN_CAPABLE => 'SQLUSMALLINT' # 46
+, SQL_TXN_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72
+, SQL_UNION => 'SQLUINTEGER bitmask' # 96
+, SQL_UNION_STATEMENT => 'SQLUINTEGER bitmask' # 96 =>
+, SQL_USER_NAME => 'SQLCHAR' # 47
+, SQL_XOPEN_CLI_YEAR => 'SQLCHAR' # 10000
+);
+
+=head2 %ReturnValues
+
+See: sql.h, sqlext.h
+Edited:
+ SQL_TXN_ISOLATION_OPTION
+
+=cut
+
+$ReturnValues{SQL_AGGREGATE_FUNCTIONS} =
+{
+ SQL_AF_AVG => 0x00000001
+, SQL_AF_COUNT => 0x00000002
+, SQL_AF_MAX => 0x00000004
+, SQL_AF_MIN => 0x00000008
+, SQL_AF_SUM => 0x00000010
+, SQL_AF_DISTINCT => 0x00000020
+, SQL_AF_ALL => 0x00000040
+};
+$ReturnValues{SQL_ALTER_DOMAIN} =
+{
+ SQL_AD_CONSTRAINT_NAME_DEFINITION => 0x00000001
+, SQL_AD_ADD_DOMAIN_CONSTRAINT => 0x00000002
+, SQL_AD_DROP_DOMAIN_CONSTRAINT => 0x00000004
+, SQL_AD_ADD_DOMAIN_DEFAULT => 0x00000008
+, SQL_AD_DROP_DOMAIN_DEFAULT => 0x00000010
+, SQL_AD_ADD_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020
+, SQL_AD_ADD_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040
+, SQL_AD_ADD_CONSTRAINT_DEFERRABLE => 0x00000080
+, SQL_AD_ADD_CONSTRAINT_NON_DEFERRABLE => 0x00000100
+};
+$ReturnValues{SQL_ALTER_TABLE} =
+{
+ SQL_AT_ADD_COLUMN => 0x00000001
+, SQL_AT_DROP_COLUMN => 0x00000002
+, SQL_AT_ADD_CONSTRAINT => 0x00000008
+, SQL_AT_ADD_COLUMN_SINGLE => 0x00000020
+, SQL_AT_ADD_COLUMN_DEFAULT => 0x00000040
+, SQL_AT_ADD_COLUMN_COLLATION => 0x00000080
+, SQL_AT_SET_COLUMN_DEFAULT => 0x00000100
+, SQL_AT_DROP_COLUMN_DEFAULT => 0x00000200
+, SQL_AT_DROP_COLUMN_CASCADE => 0x00000400
+, SQL_AT_DROP_COLUMN_RESTRICT => 0x00000800
+, SQL_AT_ADD_TABLE_CONSTRAINT => 0x00001000
+, SQL_AT_DROP_TABLE_CONSTRAINT_CASCADE => 0x00002000
+, SQL_AT_DROP_TABLE_CONSTRAINT_RESTRICT => 0x00004000
+, SQL_AT_CONSTRAINT_NAME_DEFINITION => 0x00008000
+, SQL_AT_CONSTRAINT_INITIALLY_DEFERRED => 0x00010000
+, SQL_AT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00020000
+, SQL_AT_CONSTRAINT_DEFERRABLE => 0x00040000
+, SQL_AT_CONSTRAINT_NON_DEFERRABLE => 0x00080000
+};
+$ReturnValues{SQL_ASYNC_MODE} =
+{
+ SQL_AM_NONE => 0
+, SQL_AM_CONNECTION => 1
+, SQL_AM_STATEMENT => 2
+};
+$ReturnValues{SQL_ATTR_MAX_ROWS} =
+{
+ SQL_CA2_MAX_ROWS_SELECT => 0x00000080
+, SQL_CA2_MAX_ROWS_INSERT => 0x00000100
+, SQL_CA2_MAX_ROWS_DELETE => 0x00000200
+, SQL_CA2_MAX_ROWS_UPDATE => 0x00000400
+, SQL_CA2_MAX_ROWS_CATALOG => 0x00000800
+# SQL_CA2_MAX_ROWS_AFFECTS_ALL =>
+};
+$ReturnValues{SQL_ATTR_SCROLL_CONCURRENCY} =
+{
+ SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001
+, SQL_CA2_LOCK_CONCURRENCY => 0x00000002
+, SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004
+, SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008
+, SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010
+, SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020
+, SQL_CA2_SENSITIVITY_UPDATES => 0x00000040
+};
+$ReturnValues{SQL_BATCH_ROW_COUNT} =
+{
+ SQL_BRC_PROCEDURES => 0x0000001
+, SQL_BRC_EXPLICIT => 0x0000002
+, SQL_BRC_ROLLED_UP => 0x0000004
+};
+$ReturnValues{SQL_BATCH_SUPPORT} =
+{
+ SQL_BS_SELECT_EXPLICIT => 0x00000001
+, SQL_BS_ROW_COUNT_EXPLICIT => 0x00000002
+, SQL_BS_SELECT_PROC => 0x00000004
+, SQL_BS_ROW_COUNT_PROC => 0x00000008
+};
+$ReturnValues{SQL_BOOKMARK_PERSISTENCE} =
+{
+ SQL_BP_CLOSE => 0x00000001
+, SQL_BP_DELETE => 0x00000002
+, SQL_BP_DROP => 0x00000004
+, SQL_BP_TRANSACTION => 0x00000008
+, SQL_BP_UPDATE => 0x00000010
+, SQL_BP_OTHER_HSTMT => 0x00000020
+, SQL_BP_SCROLL => 0x00000040
+};
+$ReturnValues{SQL_CATALOG_LOCATION} =
+{
+ SQL_CL_START => 0x0001 # SQL_QL_START
+, SQL_CL_END => 0x0002 # SQL_QL_END
+};
+$ReturnValues{SQL_CATALOG_USAGE} =
+{
+ SQL_CU_DML_STATEMENTS => 0x00000001 # SQL_QU_DML_STATEMENTS
+, SQL_CU_PROCEDURE_INVOCATION => 0x00000002 # SQL_QU_PROCEDURE_INVOCATION
+, SQL_CU_TABLE_DEFINITION => 0x00000004 # SQL_QU_TABLE_DEFINITION
+, SQL_CU_INDEX_DEFINITION => 0x00000008 # SQL_QU_INDEX_DEFINITION
+, SQL_CU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_QU_PRIVILEGE_DEFINITION
+};
+$ReturnValues{SQL_CONCAT_NULL_BEHAVIOR} =
+{
+ SQL_CB_NULL => 0x0000
+, SQL_CB_NON_NULL => 0x0001
+};
+$ReturnValues{SQL_CONVERT_} =
+{
+ SQL_CVT_CHAR => 0x00000001
+, SQL_CVT_NUMERIC => 0x00000002
+, SQL_CVT_DECIMAL => 0x00000004
+, SQL_CVT_INTEGER => 0x00000008
+, SQL_CVT_SMALLINT => 0x00000010
+, SQL_CVT_FLOAT => 0x00000020
+, SQL_CVT_REAL => 0x00000040
+, SQL_CVT_DOUBLE => 0x00000080
+, SQL_CVT_VARCHAR => 0x00000100
+, SQL_CVT_LONGVARCHAR => 0x00000200
+, SQL_CVT_BINARY => 0x00000400
+, SQL_CVT_VARBINARY => 0x00000800
+, SQL_CVT_BIT => 0x00001000
+, SQL_CVT_TINYINT => 0x00002000
+, SQL_CVT_BIGINT => 0x00004000
+, SQL_CVT_DATE => 0x00008000
+, SQL_CVT_TIME => 0x00010000
+, SQL_CVT_TIMESTAMP => 0x00020000
+, SQL_CVT_LONGVARBINARY => 0x00040000
+, SQL_CVT_INTERVAL_YEAR_MONTH => 0x00080000
+, SQL_CVT_INTERVAL_DAY_TIME => 0x00100000
+, SQL_CVT_WCHAR => 0x00200000
+, SQL_CVT_WLONGVARCHAR => 0x00400000
+, SQL_CVT_WVARCHAR => 0x00800000
+, SQL_CVT_GUID => 0x01000000
+};
+$ReturnValues{SQL_CONVERT_BIGINT } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_BINARY } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_BIT } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_CHAR } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_DATE } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_DECIMAL } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_DOUBLE } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_FLOAT } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_GUID } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_INTEGER } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_INTERVAL_DAY_TIME } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_INTERVAL_YEAR_MONTH} = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_LONGVARBINARY } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_LONGVARCHAR } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_NUMERIC } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_REAL } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_SMALLINT } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_TIME } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_TIMESTAMP } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_TINYINT } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_VARBINARY } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_VARCHAR } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_WCHAR } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_WLONGVARCHAR } = $ReturnValues{SQL_CONVERT_};
+$ReturnValues{SQL_CONVERT_WVARCHAR } = $ReturnValues{SQL_CONVERT_};
+
+$ReturnValues{SQL_CONVERT_FUNCTIONS} =
+{
+ SQL_FN_CVT_CONVERT => 0x00000001
+, SQL_FN_CVT_CAST => 0x00000002
+};
+$ReturnValues{SQL_CORRELATION_NAME} =
+{
+ SQL_CN_NONE => 0x0000
+, SQL_CN_DIFFERENT => 0x0001
+, SQL_CN_ANY => 0x0002
+};
+$ReturnValues{SQL_CREATE_ASSERTION} =
+{
+ SQL_CA_CREATE_ASSERTION => 0x00000001
+, SQL_CA_CONSTRAINT_INITIALLY_DEFERRED => 0x00000010
+, SQL_CA_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000020
+, SQL_CA_CONSTRAINT_DEFERRABLE => 0x00000040
+, SQL_CA_CONSTRAINT_NON_DEFERRABLE => 0x00000080
+};
+$ReturnValues{SQL_CREATE_CHARACTER_SET} =
+{
+ SQL_CCS_CREATE_CHARACTER_SET => 0x00000001
+, SQL_CCS_COLLATE_CLAUSE => 0x00000002
+, SQL_CCS_LIMITED_COLLATION => 0x00000004
+};
+$ReturnValues{SQL_CREATE_COLLATION} =
+{
+ SQL_CCOL_CREATE_COLLATION => 0x00000001
+};
+$ReturnValues{SQL_CREATE_DOMAIN} =
+{
+ SQL_CDO_CREATE_DOMAIN => 0x00000001
+, SQL_CDO_DEFAULT => 0x00000002
+, SQL_CDO_CONSTRAINT => 0x00000004
+, SQL_CDO_COLLATION => 0x00000008
+, SQL_CDO_CONSTRAINT_NAME_DEFINITION => 0x00000010
+, SQL_CDO_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020
+, SQL_CDO_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040
+, SQL_CDO_CONSTRAINT_DEFERRABLE => 0x00000080
+, SQL_CDO_CONSTRAINT_NON_DEFERRABLE => 0x00000100
+};
+$ReturnValues{SQL_CREATE_SCHEMA} =
+{
+ SQL_CS_CREATE_SCHEMA => 0x00000001
+, SQL_CS_AUTHORIZATION => 0x00000002
+, SQL_CS_DEFAULT_CHARACTER_SET => 0x00000004
+};
+$ReturnValues{SQL_CREATE_TABLE} =
+{
+ SQL_CT_CREATE_TABLE => 0x00000001
+, SQL_CT_COMMIT_PRESERVE => 0x00000002
+, SQL_CT_COMMIT_DELETE => 0x00000004
+, SQL_CT_GLOBAL_TEMPORARY => 0x00000008
+, SQL_CT_LOCAL_TEMPORARY => 0x00000010
+, SQL_CT_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020
+, SQL_CT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040
+, SQL_CT_CONSTRAINT_DEFERRABLE => 0x00000080
+, SQL_CT_CONSTRAINT_NON_DEFERRABLE => 0x00000100
+, SQL_CT_COLUMN_CONSTRAINT => 0x00000200
+, SQL_CT_COLUMN_DEFAULT => 0x00000400
+, SQL_CT_COLUMN_COLLATION => 0x00000800
+, SQL_CT_TABLE_CONSTRAINT => 0x00001000
+, SQL_CT_CONSTRAINT_NAME_DEFINITION => 0x00002000
+};
+$ReturnValues{SQL_CREATE_TRANSLATION} =
+{
+ SQL_CTR_CREATE_TRANSLATION => 0x00000001
+};
+$ReturnValues{SQL_CREATE_VIEW} =
+{
+ SQL_CV_CREATE_VIEW => 0x00000001
+, SQL_CV_CHECK_OPTION => 0x00000002
+, SQL_CV_CASCADED => 0x00000004
+, SQL_CV_LOCAL => 0x00000008
+};
+$ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} =
+{
+ SQL_CB_DELETE => 0
+, SQL_CB_CLOSE => 1
+, SQL_CB_PRESERVE => 2
+};
+$ReturnValues{SQL_CURSOR_ROLLBACK_BEHAVIOR} = $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR};
+
+$ReturnValues{SQL_CURSOR_SENSITIVITY} =
+{
+ SQL_UNSPECIFIED => 0
+, SQL_INSENSITIVE => 1
+, SQL_SENSITIVE => 2
+};
+$ReturnValues{SQL_DATETIME_LITERALS} =
+{
+ SQL_DL_SQL92_DATE => 0x00000001
+, SQL_DL_SQL92_TIME => 0x00000002
+, SQL_DL_SQL92_TIMESTAMP => 0x00000004
+, SQL_DL_SQL92_INTERVAL_YEAR => 0x00000008
+, SQL_DL_SQL92_INTERVAL_MONTH => 0x00000010
+, SQL_DL_SQL92_INTERVAL_DAY => 0x00000020
+, SQL_DL_SQL92_INTERVAL_HOUR => 0x00000040
+, SQL_DL_SQL92_INTERVAL_MINUTE => 0x00000080
+, SQL_DL_SQL92_INTERVAL_SECOND => 0x00000100
+, SQL_DL_SQL92_INTERVAL_YEAR_TO_MONTH => 0x00000200
+, SQL_DL_SQL92_INTERVAL_DAY_TO_HOUR => 0x00000400
+, SQL_DL_SQL92_INTERVAL_DAY_TO_MINUTE => 0x00000800
+, SQL_DL_SQL92_INTERVAL_DAY_TO_SECOND => 0x00001000
+, SQL_DL_SQL92_INTERVAL_HOUR_TO_MINUTE => 0x00002000
+, SQL_DL_SQL92_INTERVAL_HOUR_TO_SECOND => 0x00004000
+, SQL_DL_SQL92_INTERVAL_MINUTE_TO_SECOND => 0x00008000
+};
+$ReturnValues{SQL_DDL_INDEX} =
+{
+ SQL_DI_CREATE_INDEX => 0x00000001
+, SQL_DI_DROP_INDEX => 0x00000002
+};
+$ReturnValues{SQL_DIAG_CURSOR_ROW_COUNT} =
+{
+ SQL_CA2_CRC_EXACT => 0x00001000
+, SQL_CA2_CRC_APPROXIMATE => 0x00002000
+, SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000
+, SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000
+, SQL_CA2_SIMULATE_UNIQUE => 0x00010000
+};
+$ReturnValues{SQL_DROP_ASSERTION} =
+{
+ SQL_DA_DROP_ASSERTION => 0x00000001
+};
+$ReturnValues{SQL_DROP_CHARACTER_SET} =
+{
+ SQL_DCS_DROP_CHARACTER_SET => 0x00000001
+};
+$ReturnValues{SQL_DROP_COLLATION} =
+{
+ SQL_DC_DROP_COLLATION => 0x00000001
+};
+$ReturnValues{SQL_DROP_DOMAIN} =
+{
+ SQL_DD_DROP_DOMAIN => 0x00000001
+, SQL_DD_RESTRICT => 0x00000002
+, SQL_DD_CASCADE => 0x00000004
+};
+$ReturnValues{SQL_DROP_SCHEMA} =
+{
+ SQL_DS_DROP_SCHEMA => 0x00000001
+, SQL_DS_RESTRICT => 0x00000002
+, SQL_DS_CASCADE => 0x00000004
+};
+$ReturnValues{SQL_DROP_TABLE} =
+{
+ SQL_DT_DROP_TABLE => 0x00000001
+, SQL_DT_RESTRICT => 0x00000002
+, SQL_DT_CASCADE => 0x00000004
+};
+$ReturnValues{SQL_DROP_TRANSLATION} =
+{
+ SQL_DTR_DROP_TRANSLATION => 0x00000001
+};
+$ReturnValues{SQL_DROP_VIEW} =
+{
+ SQL_DV_DROP_VIEW => 0x00000001
+, SQL_DV_RESTRICT => 0x00000002
+, SQL_DV_CASCADE => 0x00000004
+};
+$ReturnValues{SQL_CURSOR_ATTRIBUTES1} =
+{
+ SQL_CA1_NEXT => 0x00000001
+, SQL_CA1_ABSOLUTE => 0x00000002
+, SQL_CA1_RELATIVE => 0x00000004
+, SQL_CA1_BOOKMARK => 0x00000008
+, SQL_CA1_LOCK_NO_CHANGE => 0x00000040
+, SQL_CA1_LOCK_EXCLUSIVE => 0x00000080
+, SQL_CA1_LOCK_UNLOCK => 0x00000100
+, SQL_CA1_POS_POSITION => 0x00000200
+, SQL_CA1_POS_UPDATE => 0x00000400
+, SQL_CA1_POS_DELETE => 0x00000800
+, SQL_CA1_POS_REFRESH => 0x00001000
+, SQL_CA1_POSITIONED_UPDATE => 0x00002000
+, SQL_CA1_POSITIONED_DELETE => 0x00004000
+, SQL_CA1_SELECT_FOR_UPDATE => 0x00008000
+, SQL_CA1_BULK_ADD => 0x00010000
+, SQL_CA1_BULK_UPDATE_BY_BOOKMARK => 0x00020000
+, SQL_CA1_BULK_DELETE_BY_BOOKMARK => 0x00040000
+, SQL_CA1_BULK_FETCH_BY_BOOKMARK => 0x00080000
+};
+$ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
+$ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
+$ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
+$ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
+
+$ReturnValues{SQL_CURSOR_ATTRIBUTES2} =
+{
+ SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001
+, SQL_CA2_LOCK_CONCURRENCY => 0x00000002
+, SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004
+, SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008
+, SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010
+, SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020
+, SQL_CA2_SENSITIVITY_UPDATES => 0x00000040
+, SQL_CA2_MAX_ROWS_SELECT => 0x00000080
+, SQL_CA2_MAX_ROWS_INSERT => 0x00000100
+, SQL_CA2_MAX_ROWS_DELETE => 0x00000200
+, SQL_CA2_MAX_ROWS_UPDATE => 0x00000400
+, SQL_CA2_MAX_ROWS_CATALOG => 0x00000800
+, SQL_CA2_CRC_EXACT => 0x00001000
+, SQL_CA2_CRC_APPROXIMATE => 0x00002000
+, SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000
+, SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000
+, SQL_CA2_SIMULATE_UNIQUE => 0x00010000
+};
+$ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
+$ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
+$ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
+$ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
+
+$ReturnValues{SQL_FETCH_DIRECTION} =
+{
+ SQL_FD_FETCH_NEXT => 0x00000001
+, SQL_FD_FETCH_FIRST => 0x00000002
+, SQL_FD_FETCH_LAST => 0x00000004
+, SQL_FD_FETCH_PRIOR => 0x00000008
+, SQL_FD_FETCH_ABSOLUTE => 0x00000010
+, SQL_FD_FETCH_RELATIVE => 0x00000020
+, SQL_FD_FETCH_RESUME => 0x00000040
+, SQL_FD_FETCH_BOOKMARK => 0x00000080
+};
+$ReturnValues{SQL_FILE_USAGE} =
+{
+ SQL_FILE_NOT_SUPPORTED => 0x0000
+, SQL_FILE_TABLE => 0x0001
+, SQL_FILE_QUALIFIER => 0x0002
+, SQL_FILE_CATALOG => 0x0002 # SQL_FILE_QUALIFIER
+};
+$ReturnValues{SQL_GETDATA_EXTENSIONS} =
+{
+ SQL_GD_ANY_COLUMN => 0x00000001
+, SQL_GD_ANY_ORDER => 0x00000002
+, SQL_GD_BLOCK => 0x00000004
+, SQL_GD_BOUND => 0x00000008
+};
+$ReturnValues{SQL_GROUP_BY} =
+{
+ SQL_GB_NOT_SUPPORTED => 0x0000
+, SQL_GB_GROUP_BY_EQUALS_SELECT => 0x0001
+, SQL_GB_GROUP_BY_CONTAINS_SELECT => 0x0002
+, SQL_GB_NO_RELATION => 0x0003
+, SQL_GB_COLLATE => 0x0004
+};
+$ReturnValues{SQL_IDENTIFIER_CASE} =
+{
+ SQL_IC_UPPER => 1
+, SQL_IC_LOWER => 2
+, SQL_IC_SENSITIVE => 3
+, SQL_IC_MIXED => 4
+};
+$ReturnValues{SQL_INDEX_KEYWORDS} =
+{
+ SQL_IK_NONE => 0x00000000
+, SQL_IK_ASC => 0x00000001
+, SQL_IK_DESC => 0x00000002
+# SQL_IK_ALL =>
+};
+$ReturnValues{SQL_INFO_SCHEMA_VIEWS} =
+{
+ SQL_ISV_ASSERTIONS => 0x00000001
+, SQL_ISV_CHARACTER_SETS => 0x00000002
+, SQL_ISV_CHECK_CONSTRAINTS => 0x00000004
+, SQL_ISV_COLLATIONS => 0x00000008
+, SQL_ISV_COLUMN_DOMAIN_USAGE => 0x00000010
+, SQL_ISV_COLUMN_PRIVILEGES => 0x00000020
+, SQL_ISV_COLUMNS => 0x00000040
+, SQL_ISV_CONSTRAINT_COLUMN_USAGE => 0x00000080
+, SQL_ISV_CONSTRAINT_TABLE_USAGE => 0x00000100
+, SQL_ISV_DOMAIN_CONSTRAINTS => 0x00000200
+, SQL_ISV_DOMAINS => 0x00000400
+, SQL_ISV_KEY_COLUMN_USAGE => 0x00000800
+, SQL_ISV_REFERENTIAL_CONSTRAINTS => 0x00001000
+, SQL_ISV_SCHEMATA => 0x00002000
+, SQL_ISV_SQL_LANGUAGES => 0x00004000
+, SQL_ISV_TABLE_CONSTRAINTS => 0x00008000
+, SQL_ISV_TABLE_PRIVILEGES => 0x00010000
+, SQL_ISV_TABLES => 0x00020000
+, SQL_ISV_TRANSLATIONS => 0x00040000
+, SQL_ISV_USAGE_PRIVILEGES => 0x00080000
+, SQL_ISV_VIEW_COLUMN_USAGE => 0x00100000
+, SQL_ISV_VIEW_TABLE_USAGE => 0x00200000
+, SQL_ISV_VIEWS => 0x00400000
+};
+$ReturnValues{SQL_INSERT_STATEMENT} =
+{
+ SQL_IS_INSERT_LITERALS => 0x00000001
+, SQL_IS_INSERT_SEARCHED => 0x00000002
+, SQL_IS_SELECT_INTO => 0x00000004
+};
+$ReturnValues{SQL_LOCK_TYPES} =
+{
+ SQL_LCK_NO_CHANGE => 0x00000001
+, SQL_LCK_EXCLUSIVE => 0x00000002
+, SQL_LCK_UNLOCK => 0x00000004
+};
+$ReturnValues{SQL_NON_NULLABLE_COLUMNS} =
+{
+ SQL_NNC_NULL => 0x0000
+, SQL_NNC_NON_NULL => 0x0001
+};
+$ReturnValues{SQL_NULL_COLLATION} =
+{
+ SQL_NC_HIGH => 0
+, SQL_NC_LOW => 1
+, SQL_NC_START => 0x0002
+, SQL_NC_END => 0x0004
+};
+$ReturnValues{SQL_NUMERIC_FUNCTIONS} =
+{
+ SQL_FN_NUM_ABS => 0x00000001
+, SQL_FN_NUM_ACOS => 0x00000002
+, SQL_FN_NUM_ASIN => 0x00000004
+, SQL_FN_NUM_ATAN => 0x00000008
+, SQL_FN_NUM_ATAN2 => 0x00000010
+, SQL_FN_NUM_CEILING => 0x00000020
+, SQL_FN_NUM_COS => 0x00000040
+, SQL_FN_NUM_COT => 0x00000080
+, SQL_FN_NUM_EXP => 0x00000100
+, SQL_FN_NUM_FLOOR => 0x00000200
+, SQL_FN_NUM_LOG => 0x00000400
+, SQL_FN_NUM_MOD => 0x00000800
+, SQL_FN_NUM_SIGN => 0x00001000
+, SQL_FN_NUM_SIN => 0x00002000
+, SQL_FN_NUM_SQRT => 0x00004000
+, SQL_FN_NUM_TAN => 0x00008000
+, SQL_FN_NUM_PI => 0x00010000
+, SQL_FN_NUM_RAND => 0x00020000
+, SQL_FN_NUM_DEGREES => 0x00040000
+, SQL_FN_NUM_LOG10 => 0x00080000
+, SQL_FN_NUM_POWER => 0x00100000
+, SQL_FN_NUM_RADIANS => 0x00200000
+, SQL_FN_NUM_ROUND => 0x00400000
+, SQL_FN_NUM_TRUNCATE => 0x00800000
+};
+$ReturnValues{SQL_ODBC_API_CONFORMANCE} =
+{
+ SQL_OAC_NONE => 0x0000
+, SQL_OAC_LEVEL1 => 0x0001
+, SQL_OAC_LEVEL2 => 0x0002
+};
+$ReturnValues{SQL_ODBC_INTERFACE_CONFORMANCE} =
+{
+ SQL_OIC_CORE => 1
+, SQL_OIC_LEVEL1 => 2
+, SQL_OIC_LEVEL2 => 3
+};
+$ReturnValues{SQL_ODBC_SAG_CLI_CONFORMANCE} =
+{
+ SQL_OSCC_NOT_COMPLIANT => 0x0000
+, SQL_OSCC_COMPLIANT => 0x0001
+};
+$ReturnValues{SQL_ODBC_SQL_CONFORMANCE} =
+{
+ SQL_OSC_MINIMUM => 0x0000
+, SQL_OSC_CORE => 0x0001
+, SQL_OSC_EXTENDED => 0x0002
+};
+$ReturnValues{SQL_OJ_CAPABILITIES} =
+{
+ SQL_OJ_LEFT => 0x00000001
+, SQL_OJ_RIGHT => 0x00000002
+, SQL_OJ_FULL => 0x00000004
+, SQL_OJ_NESTED => 0x00000008
+, SQL_OJ_NOT_ORDERED => 0x00000010
+, SQL_OJ_INNER => 0x00000020
+, SQL_OJ_ALL_COMPARISON_OPS => 0x00000040
+};
+$ReturnValues{SQL_OWNER_USAGE} =
+{
+ SQL_OU_DML_STATEMENTS => 0x00000001
+, SQL_OU_PROCEDURE_INVOCATION => 0x00000002
+, SQL_OU_TABLE_DEFINITION => 0x00000004
+, SQL_OU_INDEX_DEFINITION => 0x00000008
+, SQL_OU_PRIVILEGE_DEFINITION => 0x00000010
+};
+$ReturnValues{SQL_PARAM_ARRAY_ROW_COUNTS} =
+{
+ SQL_PARC_BATCH => 1
+, SQL_PARC_NO_BATCH => 2
+};
+$ReturnValues{SQL_PARAM_ARRAY_SELECTS} =
+{
+ SQL_PAS_BATCH => 1
+, SQL_PAS_NO_BATCH => 2
+, SQL_PAS_NO_SELECT => 3
+};
+$ReturnValues{SQL_POSITIONED_STATEMENTS} =
+{
+ SQL_PS_POSITIONED_DELETE => 0x00000001
+, SQL_PS_POSITIONED_UPDATE => 0x00000002
+, SQL_PS_SELECT_FOR_UPDATE => 0x00000004
+};
+$ReturnValues{SQL_POS_OPERATIONS} =
+{
+ SQL_POS_POSITION => 0x00000001
+, SQL_POS_REFRESH => 0x00000002
+, SQL_POS_UPDATE => 0x00000004
+, SQL_POS_DELETE => 0x00000008
+, SQL_POS_ADD => 0x00000010
+};
+$ReturnValues{SQL_QUALIFIER_LOCATION} =
+{
+ SQL_QL_START => 0x0001
+, SQL_QL_END => 0x0002
+};
+$ReturnValues{SQL_QUALIFIER_USAGE} =
+{
+ SQL_QU_DML_STATEMENTS => 0x00000001
+, SQL_QU_PROCEDURE_INVOCATION => 0x00000002
+, SQL_QU_TABLE_DEFINITION => 0x00000004
+, SQL_QU_INDEX_DEFINITION => 0x00000008
+, SQL_QU_PRIVILEGE_DEFINITION => 0x00000010
+};
+$ReturnValues{SQL_QUOTED_IDENTIFIER_CASE} = $ReturnValues{SQL_IDENTIFIER_CASE};
+
+$ReturnValues{SQL_SCHEMA_USAGE} =
+{
+ SQL_SU_DML_STATEMENTS => 0x00000001 # SQL_OU_DML_STATEMENTS
+, SQL_SU_PROCEDURE_INVOCATION => 0x00000002 # SQL_OU_PROCEDURE_INVOCATION
+, SQL_SU_TABLE_DEFINITION => 0x00000004 # SQL_OU_TABLE_DEFINITION
+, SQL_SU_INDEX_DEFINITION => 0x00000008 # SQL_OU_INDEX_DEFINITION
+, SQL_SU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_OU_PRIVILEGE_DEFINITION
+};
+$ReturnValues{SQL_SCROLL_CONCURRENCY} =
+{
+ SQL_SCCO_READ_ONLY => 0x00000001
+, SQL_SCCO_LOCK => 0x00000002
+, SQL_SCCO_OPT_ROWVER => 0x00000004
+, SQL_SCCO_OPT_VALUES => 0x00000008
+};
+$ReturnValues{SQL_SCROLL_OPTIONS} =
+{
+ SQL_SO_FORWARD_ONLY => 0x00000001
+, SQL_SO_KEYSET_DRIVEN => 0x00000002
+, SQL_SO_DYNAMIC => 0x00000004
+, SQL_SO_MIXED => 0x00000008
+, SQL_SO_STATIC => 0x00000010
+};
+$ReturnValues{SQL_SQL92_DATETIME_FUNCTIONS} =
+{
+ SQL_SDF_CURRENT_DATE => 0x00000001
+, SQL_SDF_CURRENT_TIME => 0x00000002
+, SQL_SDF_CURRENT_TIMESTAMP => 0x00000004
+};
+$ReturnValues{SQL_SQL92_FOREIGN_KEY_DELETE_RULE} =
+{
+ SQL_SFKD_CASCADE => 0x00000001
+, SQL_SFKD_NO_ACTION => 0x00000002
+, SQL_SFKD_SET_DEFAULT => 0x00000004
+, SQL_SFKD_SET_NULL => 0x00000008
+};
+$ReturnValues{SQL_SQL92_FOREIGN_KEY_UPDATE_RULE} =
+{
+ SQL_SFKU_CASCADE => 0x00000001
+, SQL_SFKU_NO_ACTION => 0x00000002
+, SQL_SFKU_SET_DEFAULT => 0x00000004
+, SQL_SFKU_SET_NULL => 0x00000008
+};
+$ReturnValues{SQL_SQL92_GRANT} =
+{
+ SQL_SG_USAGE_ON_DOMAIN => 0x00000001
+, SQL_SG_USAGE_ON_CHARACTER_SET => 0x00000002
+, SQL_SG_USAGE_ON_COLLATION => 0x00000004
+, SQL_SG_USAGE_ON_TRANSLATION => 0x00000008
+, SQL_SG_WITH_GRANT_OPTION => 0x00000010
+, SQL_SG_DELETE_TABLE => 0x00000020
+, SQL_SG_INSERT_TABLE => 0x00000040
+, SQL_SG_INSERT_COLUMN => 0x00000080
+, SQL_SG_REFERENCES_TABLE => 0x00000100
+, SQL_SG_REFERENCES_COLUMN => 0x00000200
+, SQL_SG_SELECT_TABLE => 0x00000400
+, SQL_SG_UPDATE_TABLE => 0x00000800
+, SQL_SG_UPDATE_COLUMN => 0x00001000
+};
+$ReturnValues{SQL_SQL92_NUMERIC_VALUE_FUNCTIONS} =
+{
+ SQL_SNVF_BIT_LENGTH => 0x00000001
+, SQL_SNVF_CHAR_LENGTH => 0x00000002
+, SQL_SNVF_CHARACTER_LENGTH => 0x00000004
+, SQL_SNVF_EXTRACT => 0x00000008
+, SQL_SNVF_OCTET_LENGTH => 0x00000010
+, SQL_SNVF_POSITION => 0x00000020
+};
+$ReturnValues{SQL_SQL92_PREDICATES} =
+{
+ SQL_SP_EXISTS => 0x00000001
+, SQL_SP_ISNOTNULL => 0x00000002
+, SQL_SP_ISNULL => 0x00000004
+, SQL_SP_MATCH_FULL => 0x00000008
+, SQL_SP_MATCH_PARTIAL => 0x00000010
+, SQL_SP_MATCH_UNIQUE_FULL => 0x00000020
+, SQL_SP_MATCH_UNIQUE_PARTIAL => 0x00000040
+, SQL_SP_OVERLAPS => 0x00000080
+, SQL_SP_UNIQUE => 0x00000100
+, SQL_SP_LIKE => 0x00000200
+, SQL_SP_IN => 0x00000400
+, SQL_SP_BETWEEN => 0x00000800
+, SQL_SP_COMPARISON => 0x00001000
+, SQL_SP_QUANTIFIED_COMPARISON => 0x00002000
+};
+$ReturnValues{SQL_SQL92_RELATIONAL_JOIN_OPERATORS} =
+{
+ SQL_SRJO_CORRESPONDING_CLAUSE => 0x00000001
+, SQL_SRJO_CROSS_JOIN => 0x00000002
+, SQL_SRJO_EXCEPT_JOIN => 0x00000004
+, SQL_SRJO_FULL_OUTER_JOIN => 0x00000008
+, SQL_SRJO_INNER_JOIN => 0x00000010
+, SQL_SRJO_INTERSECT_JOIN => 0x00000020
+, SQL_SRJO_LEFT_OUTER_JOIN => 0x00000040
+, SQL_SRJO_NATURAL_JOIN => 0x00000080
+, SQL_SRJO_RIGHT_OUTER_JOIN => 0x00000100
+, SQL_SRJO_UNION_JOIN => 0x00000200
+};
+$ReturnValues{SQL_SQL92_REVOKE} =
+{
+ SQL_SR_USAGE_ON_DOMAIN => 0x00000001
+, SQL_SR_USAGE_ON_CHARACTER_SET => 0x00000002
+, SQL_SR_USAGE_ON_COLLATION => 0x00000004
+, SQL_SR_USAGE_ON_TRANSLATION => 0x00000008
+, SQL_SR_GRANT_OPTION_FOR => 0x00000010
+, SQL_SR_CASCADE => 0x00000020
+, SQL_SR_RESTRICT => 0x00000040
+, SQL_SR_DELETE_TABLE => 0x00000080
+, SQL_SR_INSERT_TABLE => 0x00000100
+, SQL_SR_INSERT_COLUMN => 0x00000200
+, SQL_SR_REFERENCES_TABLE => 0x00000400
+, SQL_SR_REFERENCES_COLUMN => 0x00000800
+, SQL_SR_SELECT_TABLE => 0x00001000
+, SQL_SR_UPDATE_TABLE => 0x00002000
+, SQL_SR_UPDATE_COLUMN => 0x00004000
+};
+$ReturnValues{SQL_SQL92_ROW_VALUE_CONSTRUCTOR} =
+{
+ SQL_SRVC_VALUE_EXPRESSION => 0x00000001
+, SQL_SRVC_NULL => 0x00000002
+, SQL_SRVC_DEFAULT => 0x00000004
+, SQL_SRVC_ROW_SUBQUERY => 0x00000008
+};
+$ReturnValues{SQL_SQL92_STRING_FUNCTIONS} =
+{
+ SQL_SSF_CONVERT => 0x00000001
+, SQL_SSF_LOWER => 0x00000002
+, SQL_SSF_UPPER => 0x00000004
+, SQL_SSF_SUBSTRING => 0x00000008
+, SQL_SSF_TRANSLATE => 0x00000010
+, SQL_SSF_TRIM_BOTH => 0x00000020
+, SQL_SSF_TRIM_LEADING => 0x00000040
+, SQL_SSF_TRIM_TRAILING => 0x00000080
+};
+$ReturnValues{SQL_SQL92_VALUE_EXPRESSIONS} =
+{
+ SQL_SVE_CASE => 0x00000001
+, SQL_SVE_CAST => 0x00000002
+, SQL_SVE_COALESCE => 0x00000004
+, SQL_SVE_NULLIF => 0x00000008
+};
+$ReturnValues{SQL_SQL_CONFORMANCE} =
+{
+ SQL_SC_SQL92_ENTRY => 0x00000001
+, SQL_SC_FIPS127_2_TRANSITIONAL => 0x00000002
+, SQL_SC_SQL92_INTERMEDIATE => 0x00000004
+, SQL_SC_SQL92_FULL => 0x00000008
+};
+$ReturnValues{SQL_STANDARD_CLI_CONFORMANCE} =
+{
+ SQL_SCC_XOPEN_CLI_VERSION1 => 0x00000001
+, SQL_SCC_ISO92_CLI => 0x00000002
+};
+$ReturnValues{SQL_STATIC_SENSITIVITY} =
+{
+ SQL_SS_ADDITIONS => 0x00000001
+, SQL_SS_DELETIONS => 0x00000002
+, SQL_SS_UPDATES => 0x00000004
+};
+$ReturnValues{SQL_STRING_FUNCTIONS} =
+{
+ SQL_FN_STR_CONCAT => 0x00000001
+, SQL_FN_STR_INSERT => 0x00000002
+, SQL_FN_STR_LEFT => 0x00000004
+, SQL_FN_STR_LTRIM => 0x00000008
+, SQL_FN_STR_LENGTH => 0x00000010
+, SQL_FN_STR_LOCATE => 0x00000020
+, SQL_FN_STR_LCASE => 0x00000040
+, SQL_FN_STR_REPEAT => 0x00000080
+, SQL_FN_STR_REPLACE => 0x00000100
+, SQL_FN_STR_RIGHT => 0x00000200
+, SQL_FN_STR_RTRIM => 0x00000400
+, SQL_FN_STR_SUBSTRING => 0x00000800
+, SQL_FN_STR_UCASE => 0x00001000
+, SQL_FN_STR_ASCII => 0x00002000
+, SQL_FN_STR_CHAR => 0x00004000
+, SQL_FN_STR_DIFFERENCE => 0x00008000
+, SQL_FN_STR_LOCATE_2 => 0x00010000
+, SQL_FN_STR_SOUNDEX => 0x00020000
+, SQL_FN_STR_SPACE => 0x00040000
+, SQL_FN_STR_BIT_LENGTH => 0x00080000
+, SQL_FN_STR_CHAR_LENGTH => 0x00100000
+, SQL_FN_STR_CHARACTER_LENGTH => 0x00200000
+, SQL_FN_STR_OCTET_LENGTH => 0x00400000
+, SQL_FN_STR_POSITION => 0x00800000
+};
+$ReturnValues{SQL_SUBQUERIES} =
+{
+ SQL_SQ_COMPARISON => 0x00000001
+, SQL_SQ_EXISTS => 0x00000002
+, SQL_SQ_IN => 0x00000004
+, SQL_SQ_QUANTIFIED => 0x00000008
+, SQL_SQ_CORRELATED_SUBQUERIES => 0x00000010
+};
+$ReturnValues{SQL_SYSTEM_FUNCTIONS} =
+{
+ SQL_FN_SYS_USERNAME => 0x00000001
+, SQL_FN_SYS_DBNAME => 0x00000002
+, SQL_FN_SYS_IFNULL => 0x00000004
+};
+$ReturnValues{SQL_TIMEDATE_ADD_INTERVALS} =
+{
+ SQL_FN_TSI_FRAC_SECOND => 0x00000001
+, SQL_FN_TSI_SECOND => 0x00000002
+, SQL_FN_TSI_MINUTE => 0x00000004
+, SQL_FN_TSI_HOUR => 0x00000008
+, SQL_FN_TSI_DAY => 0x00000010
+, SQL_FN_TSI_WEEK => 0x00000020
+, SQL_FN_TSI_MONTH => 0x00000040
+, SQL_FN_TSI_QUARTER => 0x00000080
+, SQL_FN_TSI_YEAR => 0x00000100
+};
+$ReturnValues{SQL_TIMEDATE_FUNCTIONS} =
+{
+ SQL_FN_TD_NOW => 0x00000001
+, SQL_FN_TD_CURDATE => 0x00000002
+, SQL_FN_TD_DAYOFMONTH => 0x00000004
+, SQL_FN_TD_DAYOFWEEK => 0x00000008
+, SQL_FN_TD_DAYOFYEAR => 0x00000010
+, SQL_FN_TD_MONTH => 0x00000020
+, SQL_FN_TD_QUARTER => 0x00000040
+, SQL_FN_TD_WEEK => 0x00000080
+, SQL_FN_TD_YEAR => 0x00000100
+, SQL_FN_TD_CURTIME => 0x00000200
+, SQL_FN_TD_HOUR => 0x00000400
+, SQL_FN_TD_MINUTE => 0x00000800
+, SQL_FN_TD_SECOND => 0x00001000
+, SQL_FN_TD_TIMESTAMPADD => 0x00002000
+, SQL_FN_TD_TIMESTAMPDIFF => 0x00004000
+, SQL_FN_TD_DAYNAME => 0x00008000
+, SQL_FN_TD_MONTHNAME => 0x00010000
+, SQL_FN_TD_CURRENT_DATE => 0x00020000
+, SQL_FN_TD_CURRENT_TIME => 0x00040000
+, SQL_FN_TD_CURRENT_TIMESTAMP => 0x00080000
+, SQL_FN_TD_EXTRACT => 0x00100000
+};
+$ReturnValues{SQL_TXN_CAPABLE} =
+{
+ SQL_TC_NONE => 0
+, SQL_TC_DML => 1
+, SQL_TC_ALL => 2
+, SQL_TC_DDL_COMMIT => 3
+, SQL_TC_DDL_IGNORE => 4
+};
+$ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION} =
+{
+ SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001 # SQL_TXN_READ_UNCOMMITTED
+, SQL_TRANSACTION_READ_COMMITTED => 0x00000002 # SQL_TXN_READ_COMMITTED
+, SQL_TRANSACTION_REPEATABLE_READ => 0x00000004 # SQL_TXN_REPEATABLE_READ
+, SQL_TRANSACTION_SERIALIZABLE => 0x00000008 # SQL_TXN_SERIALIZABLE
+};
+$ReturnValues{SQL_DEFAULT_TRANSACTION_ISOLATION} = $ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION};
+
+$ReturnValues{SQL_TXN_ISOLATION_OPTION} =
+{
+ SQL_TXN_READ_UNCOMMITTED => 0x00000001
+, SQL_TXN_READ_COMMITTED => 0x00000002
+, SQL_TXN_REPEATABLE_READ => 0x00000004
+, SQL_TXN_SERIALIZABLE => 0x00000008
+};
+$ReturnValues{SQL_DEFAULT_TXN_ISOLATION} = $ReturnValues{SQL_TXN_ISOLATION_OPTION};
+
+$ReturnValues{SQL_TXN_VERSIONING} =
+{
+ SQL_TXN_VERSIONING => 0x00000010
+};
+$ReturnValues{SQL_UNION} =
+{
+ SQL_U_UNION => 0x00000001
+, SQL_U_UNION_ALL => 0x00000002
+};
+$ReturnValues{SQL_UNION_STATEMENT} =
+{
+ SQL_US_UNION => 0x00000001 # SQL_U_UNION
+, SQL_US_UNION_ALL => 0x00000002 # SQL_U_UNION_ALL
+};
+
+1;
+
+=head1 TODO
+
+ Corrections?
+ SQL_NULL_COLLATION: ODBC vs ANSI
+ Unique values for $ReturnValues{...}?, e.g. SQL_FILE_USAGE
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm
new file mode 100755
index 00000000000..d07b7ac8544
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm
@@ -0,0 +1,105 @@
+# $Id: GetInfoReturn.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# Copyright (c) 2002 Tim Bunce Ireland
+#
+# Constant data describing return values from the DBI getinfo function.
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+package DBI::Const::GetInfoReturn;
+
+use strict;
+
+use Exporter ();
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoReturnTypes %GetInfoReturnValues);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(%GetInfoReturnTypes %GetInfoReturnValues);
+
+my
+$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+
+=head1 NAME
+
+DBI::Const::GetInfoReturn - Data and functions for describing GetInfo results
+
+=head1 SYNOPSIS
+
+The interface to this module is undocumented and liable to change.
+
+=head1 DESCRIPTION
+
+Data and functions for describing GetInfo results
+
+=cut
+
+use DBI::Const::GetInfoType;
+
+use DBI::Const::GetInfo::ANSI ();
+use DBI::Const::GetInfo::ODBC ();
+
+%GetInfoReturnTypes =
+(
+ %DBI::Const::GetInfo::ANSI::ReturnTypes
+, %DBI::Const::GetInfo::ODBC::ReturnTypes
+);
+
+%GetInfoReturnValues = ();
+{
+ my $A = \%DBI::Const::GetInfo::ANSI::ReturnValues;
+ my $O = \%DBI::Const::GetInfo::ODBC::ReturnValues;
+ while ( my ($k, $v) = each %$A ) {
+ my %h = ( exists $O->{$k} ) ? ( %$v, %{$O->{$k}} ) : %$v;
+ $GetInfoReturnValues{$k} = \%h;
+ }
+ while ( my ($k, $v) = each %$O ) {
+ next if exists $A->{$k};
+ my %h = %$v;
+ $GetInfoReturnValues{$k} = \%h;
+ }
+}
+
+# -----------------------------------------------------------------------------
+
+sub Format {
+ my $InfoType = shift;
+ my $Value = shift;
+
+ return '' unless defined $Value;
+
+ my $ReturnType = $GetInfoReturnTypes{$InfoType};
+
+ return sprintf '0x%08X', $Value if $ReturnType eq 'SQLUINTEGER bitmask';
+ return sprintf '0x%08X', $Value if $ReturnType eq 'SQLINTEGER bitmask';
+# return '"' . $Value . '"' if $ReturnType eq 'SQLCHAR';
+ return $Value;
+}
+
+
+sub Explain {
+ my $InfoType = shift;
+ my $Value = shift;
+
+ return '' unless defined $Value;
+ return '' unless exists $GetInfoReturnValues{$InfoType};
+
+ $Value = int $Value;
+ my $ReturnType = $GetInfoReturnTypes{$InfoType};
+ my %h = reverse %{$GetInfoReturnValues{$InfoType}};
+
+ if ( $ReturnType eq 'SQLUINTEGER bitmask'|| $ReturnType eq 'SQLINTEGER bitmask') {
+ my @a = ();
+ for my $k ( sort { $a <=> $b } keys %h ) {
+ push @a, $h{$k} if $Value & $k;
+ }
+ return wantarray ? @a : join(' ', @a );
+ }
+ else {
+ return $h{$Value} ||'?';
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoType.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoType.pm
new file mode 100755
index 00000000000..7c017788683
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoType.pm
@@ -0,0 +1,54 @@
+# $Id: GetInfoType.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# Copyright (c) 2002 Tim Bunce Ireland
+#
+# Constant data describing info type codes for the DBI getinfo function.
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+package DBI::Const::GetInfoType;
+
+use strict;
+
+use Exporter ();
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoType);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(%GetInfoType);
+
+my
+$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+
+=head1 NAME
+
+DBI::Const::GetInfoType - Data describing GetInfo type codes
+
+=head1 SYNOPSIS
+
+ use DBI::Const::GetInfoType;
+
+=head1 DESCRIPTION
+
+Imports a %GetInfoType hash which maps names for GetInfo Type Codes
+into their corresponding numeric values. For example:
+
+ $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} );
+
+The interface to this module is new and nothing beyond what is
+written here is guaranteed.
+
+=cut
+
+use DBI::Const::GetInfo::ANSI (); # liable to change
+use DBI::Const::GetInfo::ODBC (); # liable to change
+
+%GetInfoType =
+(
+ %DBI::Const::GetInfo::ANSI::InfoTypes # liable to change
+, %DBI::Const::GetInfo::ODBC::InfoTypes # liable to change
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/DBD.pm b/Master/tlpkg/tlperl.straw/lib/DBI/DBD.pm
new file mode 100755
index 00000000000..fedfc732317
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/DBD.pm
@@ -0,0 +1,3385 @@
+package DBI::DBD;
+# vim:ts=8:sw=4
+
+use vars qw($VERSION); # set $VERSION early so we don't confuse PAUSE/CPAN etc
+
+# don't use Revision here because that's not in svn:keywords so that the
+# examples that use it below won't be messed up
+$VERSION = sprintf("12.%06d", q$Id: DBD.pm 11723 2008-09-02 10:09:51Z mjevans $ =~ /(\d+)/o);
+
+
+# $Id: DBD.pm 11723 2008-09-02 10:09:51Z mjevans $
+#
+# Copyright (c) 1997-2006 Jonathan Leffler, Jochen Wiedmann, Steffen
+# Goeldner and Tim Bunce
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+=head1 NAME
+
+DBI::DBD - Perl DBI Database Driver Writer's Guide
+
+=head1 SYNOPSIS
+
+ perldoc DBI::DBD
+
+=head2 Version and volatility
+
+This document is I<still> a minimal draft which is in need of further work.
+
+The changes will occur both because the B<DBI> specification is changing
+and hence the requirements on B<DBD> drivers change, and because feedback
+from people reading this document will suggest improvements to it.
+
+Please read the B<DBI> documentation first and fully, including the B<DBI> FAQ.
+Then reread the B<DBI> specification again as you're reading this. It'll help.
+
+This document is a patchwork of contributions from various authors.
+More contributions (preferably as patches) are very welcome.
+
+=head1 DESCRIPTION
+
+This document is primarily intended to help people writing new
+database drivers for the Perl Database Interface (Perl DBI).
+It may also help others interested in discovering why the internals of
+a B<DBD> driver are written the way they are.
+
+This is a guide. Few (if any) of the statements in it are completely
+authoritative under all possible circumstances. This means you will
+need to use judgement in applying the guidelines in this document.
+If in I<any> doubt at all, please do contact the I<dbi-dev> mailing list
+(details given below) where Tim Bunce and other driver authors can help.
+
+=head1 CREATING A NEW DRIVER
+
+The first rule for creating a new database driver for the Perl DBI is
+very simple: B<DON'T!>
+
+There is usually a driver already available for the database you want
+to use, almost regardless of which database you choose. Very often, the
+database will provide an ODBC driver interface, so you can often use
+B<DBD::ODBC> to access the database. This is typically less convenient
+on a Unix box than on a Microsoft Windows box, but there are numerous
+options for ODBC driver managers on Unix too, and very often the ODBC
+driver is provided by the database supplier.
+
+Before deciding that you need to write a driver, do your homework to
+ensure that you are not wasting your energies.
+
+[As of December 2002, the consensus is that if you need an ODBC driver
+manager on Unix, then the unixODBC driver (available from
+L<http://www.unixodbc.org/>) is the way to go.]
+
+The second rule for creating a new database driver for the Perl DBI is
+also very simple: B<Don't -- get someone else to do it for you!>
+
+Nevertheless, there are occasions when it is necessary to write a new
+driver, often to use a proprietary language or API to access the
+database more swiftly, or more comprehensively, than an ODBC driver can.
+Then you should read this document very carefully, but with a suitably
+sceptical eye.
+
+If there is something in here that does not make any sense, question it.
+You might be right that the information is bogus, but don't come to that
+conclusion too quickly.
+
+=head2 URLs and mailing lists
+
+The primary web-site for locating B<DBI> software and information is
+
+ http://dbi.perl.org/
+
+There are two main and one auxiliary mailing lists for people working
+with B<DBI>. The primary lists are I<dbi-users@perl.org> for general users
+of B<DBI> and B<DBD> drivers, and I<dbi-dev@perl.org> mainly for B<DBD> driver
+writers (don't join the I<dbi-dev> list unless you have a good reason).
+The auxiliary list is I<dbi-announce@perl.org> for announcing new
+releases of B<DBI> or B<DBD> drivers.
+
+You can join these lists by accessing the web-site L<http://dbi.perl.org/>.
+The lists are closed so you cannot send email to any of the lists
+unless you join the list first.
+
+You should also consider monitoring the I<comp.lang.perl.*> newsgroups,
+especially I<comp.lang.perl.modules>.
+
+=head2 The Cheetah book
+
+The definitive book on Perl DBI is the Cheetah book, so called because
+of the picture on the cover. Its proper title is 'I<Programming the
+Perl DBI: Database programming with Perl>' by Alligator Descartes
+and Tim Bunce, published by O'Reilly Associates, February 2000, ISBN
+1-56592-699-4. Buy it now if you have not already done so, and read it.
+
+=head2 Locating drivers
+
+Before writing a new driver, it is in your interests to find out
+whether there already is a driver for your database. If there is such
+a driver, it would be much easier to make use of it than to write your
+own!
+
+The primary web-site for locating Perl software is
+L<http://search.cpan.org/>. You should look under the various
+modules listings for the software you are after. For example:
+
+ http://search.cpan.org/modlist/Database_Interfaces
+
+Follow the B<DBD::> and B<DBIx::> links at the top to see those subsets.
+
+See the B<DBI> docs for information on B<DBI> web sites and mailing lists.
+
+=head2 Registering a new driver
+
+Before going through any official registration process, you will need
+to establish that there is no driver already in the works. You'll do
+that by asking the B<DBI> mailing lists whether there is such a driver
+available, or whether anybody is working on one.
+
+When you get the go ahead, you will need to establish the name of the
+driver and a prefix for the driver. Typically, the name is based on the
+name of the database software it uses, and the prefix is a contraction
+of that. Hence, B<DBD::Oracle> has the name I<Oracle> and the prefix
+'I<ora_>'. The prefix must be lowercase and contain no underscores other
+than the one at the end.
+
+This information will be recorded in the B<DBI> module. Apart from
+documentation purposes, registration is a prerequisite for
+L<installing private methods|DBI/install_method>.
+
+If you are writing a driver which will not be distributed on CPAN, then
+you should choose a prefix beginning with 'I<x_>', to avoid potential
+prefix collisions with drivers registered in the future. Thus, if you
+wrote a non-CPAN distributed driver called B<DBD::CustomDB>, the prefix
+might be 'I<x_cdb_>'.
+
+This document assumes you are writing a driver called B<DBD::Driver>, and
+that the prefix 'I<drv_>' is assigned to the driver.
+
+=head2 Two styles of database driver
+
+There are two distinct styles of database driver that can be written to
+work with the Perl DBI.
+
+Your driver can be written in pure Perl, requiring no C compiler.
+When feasible, this is the best solution, but most databases are not
+written in such a way that this can be done. Some examples of pure
+Perl drivers are B<DBD::File> and B<DBD::CSV>.
+
+Alternatively, and most commonly, your driver will need to use some C
+code to gain access to the database. This will be classified as a C/XS
+driver.
+
+=head2 What code will you write?
+
+There are a number of files that need to be written for either a pure
+Perl driver or a C/XS driver. There are no extra files needed only by
+a pure Perl driver, but there are several extra files needed only by a
+C/XS driver.
+
+=head3 Files common to pure Perl and C/XS drivers
+
+Assuming that your driver is called B<DBD::Driver>, these files are:
+
+=over 4
+
+=item * F<Makefile.PL>
+
+=item * F<META.yml>
+
+=item * F<README>
+
+=item * F<MANIFEST>
+
+=item * F<Driver.pm>
+
+=item * F<lib/Bundle/DBD/Driver.pm>
+
+=item * F<lib/DBD/Driver/Summary.pm>
+
+=item * F<t/*.t>
+
+=back
+
+The first four files are mandatory. F<Makefile.PL> is used to control
+how the driver is built and installed. The F<README> file tells people
+who download the file about how to build the module and any prerequisite
+software that must be installed. The F<MANIFEST> file is used by the
+standard Perl module distribution mechanism. It lists all the source
+files that need to be distributed with your module. F<Driver.pm> is what
+is loaded by the B<DBI> code; it contains the methods peculiar to your
+driver.
+
+Although the F<META.yml> file is not B<required> you are advised to
+create one. Of particular importance are the I<build_requires> and
+I<configure_requires> attributes which newer CPAN modules understand.
+You use these to tell the CPAN module (and CPANPLUS) that your build
+and configure mechanisms require DBI. The best reference for META.yml
+(at the time of writing) is
+L<http://module-build.sourceforge.net/META-spec-v1.2.html>. You can find
+a reasonable example of a F<META.yml> in DBD::ODBC.
+
+The F<lib/Bundle/DBD/Driver.pm> file allows you to specify other Perl
+modules on which yours depends in a format that allows someone to type a
+simple command and ensure that all the pre-requisites are in place as
+well as building your driver.
+
+The F<lib/DBD/Driver/Summary.pm> file contains (an updated version of) the
+information that was included - or that would have been included - in
+the appendices of the Cheetah book as a summary of the abilities of your
+driver and the associated database.
+
+The files in the F<t> subdirectory are unit tests for your driver.
+You should write your tests as stringently as possible, while taking
+into account the diversity of installations that you can encounter:
+
+=over 4
+
+=item *
+
+Your tests should not casually modify operational databases.
+
+=item *
+
+You should never damage existing tables in a database.
+
+=item *
+
+You should code your tests to use a constrained name space within the
+database. For example, the tables (and all other named objects) that are
+created could all begin with 'I<dbd_drv_>'.
+
+=item *
+
+At the end of a test run, there should be no testing objects left behind
+in the database.
+
+=item *
+
+If you create any databases, you should remove them.
+
+=item *
+
+If your database supports temporary tables that are automatically
+removed at the end of a session, then exploit them as often as possible.
+
+=item *
+
+Try to make your tests independent of each other. If you have a
+test F<t/t11dowhat.t> that depends upon the successful running
+of F<t/t10thingamy.t>, people cannot run the single test case
+F<t/t11dowhat.t>. Further, running F<t/t11dowhat.t> twice in a row is
+likely to fail (at least, if F<t/t11dowhat.t> modifies the database at
+all) because the database at the start of the second run is not what you
+saw at the start of the first run.
+
+=item *
+
+Document in your F<README> file what you do, and what privileges people
+need to do it.
+
+=item *
+
+You can, and probably should, sequence your tests by including a test
+number before an abbreviated version of the test name; the tests are run
+in the order in which the names are expanded by shell-style globbing.
+
+=item *
+
+It is in your interests to ensure that your tests work as widely
+as possible.
+
+=back
+
+Many drivers also install sub-modules B<DBD::Driver::SubModule>
+for any of a variety of different reasons, such as to support
+the metadata methods (see the discussion of L</METADATA METHODS>
+below). Such sub-modules are conventionally stored in the directory
+F<lib/DBD/Driver>. The module itself would usually be in a file
+F<SubModule.pm>. All such sub-modules should themselves be version
+stamped (see the discussions far below).
+
+=head3 Extra files needed by C/XS drivers
+
+The software for a C/XS driver will typically contain at least four
+extra files that are not relevant to a pure Perl driver.
+
+=over 4
+
+=item * F<Driver.xs>
+
+=item * F<Driver.h>
+
+=item * F<dbdimp.h>
+
+=item * F<dbdimp.c>
+
+=back
+
+The F<Driver.xs> file is used to generate C code that Perl can call to gain
+access to the C functions you write that will, in turn, call down onto
+your database software.
+
+The F<Driver.h> header is a stylized header that ensures you can access the
+necessary Perl and B<DBI> macros, types, and function declarations.
+
+The F<dbdimp.h> is used to specify which functions have been implemented by
+your driver.
+
+The F<dbdimp.c> file is where you write the C code that does the real work
+of translating between Perl-ish data types and what the database expects
+to use and return.
+
+There are some (mainly small, but very important) differences between
+the contents of F<Makefile.PL> and F<Driver.pm> for pure Perl and C/XS
+drivers, so those files are described both in the section on creating a
+pure Perl driver and in the section on creating a C/XS driver.
+
+Obviously, you can add extra source code files to the list.
+
+=head2 Requirements on a driver and driver writer
+
+To be remotely useful, your driver must be implemented in a format that
+allows it to be distributed via CPAN, the Comprehensive Perl Archive
+Network (L<http://www.cpan.org/> and L<http://search.cpan.org>).
+Of course, it is easier if you do not have to meet this criterion, but
+you will not be able to ask for much help if you do not do so, and
+no-one is likely to want to install your module if they have to learn a
+new installation mechanism.
+
+=head1 CREATING A PURE PERL DRIVER
+
+Writing a pure Perl driver is surprisingly simple. However, there are
+some problems you should be aware of. The best option is of course
+picking up an existing driver and carefully modifying one method
+after the other.
+
+Also look carefully at B<DBD::AnyData> and B<DBD::Template>.
+
+As an example we take a look at the B<DBD::File> driver, a driver for
+accessing plain files as tables, which is part of the B<DBD::CSV> package.
+
+The minimal set of files we have to implement are F<Makefile.PL>,
+F<README>, F<MANIFEST> and F<Driver.pm>.
+
+=head2 Pure Perl version of Makefile.PL
+
+You typically start with writing F<Makefile.PL>, a Makefile
+generator. The contents of this file are described in detail in
+the L<ExtUtils::MakeMaker> man pages. It is definitely a good idea
+if you start reading them. At least you should know about the
+variables I<CONFIGURE>, I<DEFINED>, I<PM>, I<DIR>, I<EXE_FILES>,
+I<INC>, I<LIBS>, I<LINKTYPE>, I<NAME>, I<OPTIMIZE>, I<PL_FILES>,
+I<VERSION>, I<VERSION_FROM>, I<clean>, I<depend>, I<realclean> from
+the L<ExtUtils::MakeMaker> man page: these are used in almost any
+F<Makefile.PL>.
+
+Additionally read the section on I<Overriding MakeMaker Methods> and the
+descriptions of the I<distcheck>, I<disttest> and I<dist> targets: They
+will definitely be useful for you.
+
+Of special importance for B<DBI> drivers is the I<postamble> method from
+the L<ExtUtils::MM_Unix> man page.
+
+For Emacs users, I recommend the I<libscan> method, which removes
+Emacs backup files (file names which end with a tilde '~') from lists of
+files.
+
+Now an example, I use the word C<Driver> wherever you should insert
+your driver's name:
+
+ # -*- perl -*-
+
+ use ExtUtils::MakeMaker;
+
+ WriteMakefile(
+ dbd_edit_mm_attribs( {
+ 'NAME' => 'DBD::Driver',
+ 'VERSION_FROM' => 'Driver.pm',
+ 'INC' => '',
+ 'dist' => { 'SUFFIX' => '.gz',
+ 'COMPRESS' => 'gzip -9f' },
+ 'realclean' => { FILES => '*.xsi' },
+ 'PREREQ_PM' => '1.03',
+ 'CONFIGURE' => sub {
+ eval {require DBI::DBD;};
+ if ($@) {
+ warn $@;
+ exit 0;
+ }
+ my $dbi_arch_dir = dbd_dbi_arch_dir();
+ if (exists($opts{INC})) {
+ return {INC => "$opts{INC} -I$dbi_arch_dir"};
+ } else {
+ return {INC => "-I$dbi_arch_dir"};
+ }
+ }
+ },
+ { create_pp_tests => 1})
+ );
+
+ package MY;
+ sub postamble { return main::dbd_postamble(@_); }
+ sub libscan {
+ my ($self, $path) = @_;
+ ($path =~ m/\~$/) ? undef : $path;
+ }
+
+Note the calls to C<dbd_edit_mm_attribs()> and C<dbd_postamble()>.
+
+The second hash reference in the call to C<dbd_edit_mm_attribs()>
+(containing C<create_pp_tests()>) is optional; you should not use it
+unless your driver is a pure Perl driver (that is, it does not use C and
+XS code). Therefore, the call to C<dbd_edit_mm_attribs()> is not
+relevant for C/XS drivers and may be omitted; simply use the (single)
+hash reference containing NAME etc as the only argument to C<WriteMakefile()>.
+
+Note that the C<dbd_edit_mm_attribs()> code will fail if you do not have a
+F<t> sub-directory containing at least one test case.
+
+I<PREREQ_PM> tells MakeMaker that DBI (version 1.03 in this case) is
+required for this module. This will issue a warning that DBI 1.03 is
+missing if someone attempts to install your DBD without DBI 1.03. See
+I<CONFIGURE> below for why this does not work reliably in stopping cpan
+testers failing your module if DBI is not installed.
+
+I<CONFIGURE> is a subroutine called by MakeMaker during
+C<WriteMakefile>. By putting the C<require DBI::DBD> in this section
+we can attempt to load DBI::DBD but if it is missing we exit with
+success. As we exit successfully without creating a Makefile when
+DBI::DBD is missing cpan testers will not report a failure. This may
+seem at odds with I<PREREQ_PM> but I<PREREQ_PM> does not cause
+C<WriteMakefile> to fail (unless you also specify PREREQ_FATAL which
+is strongly discouraged by MakeMaker) so C<WriteMakefile> would
+continue to call C<dbd_dbi_arch_dir> and fail.
+
+All drivers must use C<dbd_postamble()> or risk running into problems.
+
+Note the specification of I<VERSION_FROM>; the named file
+(F<Driver.pm>) will be scanned for the first line that looks like an
+assignment to I<$VERSION>, and the subsequent text will be used to
+determine the version number. Note the commentary in
+L<ExtUtils::MakeMaker> on the subject of correctly formatted version
+numbers.
+
+If your driver depends upon external software (it usually will), you
+will need to add code to ensure that your environment is workable
+before the call to C<WriteMakefile()>. If you need to check for the
+existence of an external library and perhaps modify I<INC> to include
+the paths to where the external library header files are located and
+you cannot find the library or header files make sure you output a
+message saying they cannot be found but C<exit 0> (success) B<before>
+calling C<WriteMakefile> or CPAN testers will fail your module if the
+external library is not found.
+
+A full-fledged I<Makefile.PL> can be quite large (for example, the
+files for B<DBD::Oracle> and B<DBD::Informix> are both over 1000 lines
+long, and the Informix one uses - and creates - auxiliary modules
+too).
+
+See also L<ExtUtils::MakeMaker> and L<ExtUtils::MM_Unix>. Consider using
+L<CPAN::MakeMaker> in place of I<ExtUtils::MakeMaker>.
+
+=head2 README
+
+The L<README> file should describe what the driver is for, the
+pre-requisites for the build process, the actual build process, how to
+report errors, and who to report them to.
+
+Users will find ways of breaking the driver build and test process
+which you would never even have dreamed to be possible in your worst
+nightmares. Therefore, you need to write this document defensively,
+precisely and concisely.
+
+As always, use the F<README> from one of the established drivers as a basis
+for your own; the version in B<DBD::Informix> is worth a look as it has
+been quite successful in heading off problems.
+
+=over 4
+
+=item *
+
+Note that users will have versions of Perl and B<DBI> that are both older
+and newer than you expected, but this will seldom cause much trouble.
+When it does, it will be because you are using features of B<DBI> that are
+not supported in the version they are using.
+
+=item *
+
+Note that users will have versions of the database software that are
+both older and newer than you expected. You will save yourself time in
+the long run if you can identify the range of versions which have been
+tested and warn about versions which are not known to be OK.
+
+=item *
+
+Note that many people trying to install your driver will not be experts
+in the database software.
+
+=item *
+
+Note that many people trying to install your driver will not be experts
+in C or Perl.
+
+=back
+
+=head2 MANIFEST
+
+The F<MANIFEST> will be used by the Makefile's dist target to build the
+distribution tar file that is uploaded to CPAN. It should list every
+file that you want to include in your distribution, one per line.
+
+=head2 lib/Bundle/DBD/Driver.pm
+
+The CPAN module provides an extremely powerful bundle mechanism that
+allows you to specify pre-requisites for your driver.
+
+The primary pre-requisite is B<Bundle::DBI>; you may want or need to add
+some more. With the bundle set up correctly, the user can type:
+
+ perl -MCPAN -e 'install Bundle::DBD::Driver'
+
+and Perl will download, compile, test and install all the Perl modules
+needed to build your driver.
+
+The prerequisite modules are listed in the C<CONTENTS> section, with the
+official name of the module followed by a dash and an informal name or
+description.
+
+=over 4
+
+=item *
+
+Listing B<Bundle::DBI> as the main pre-requisite simplifies life.
+
+=item *
+
+Don't forget to list your driver.
+
+=item *
+
+Note that unless the DBMS is itself a Perl module, you cannot list it as
+a pre-requisite in this file.
+
+=item *
+
+You should keep the version of the bundle the same as the version of
+your driver.
+
+=item *
+
+You should add configuration management, copyright, and licencing
+information at the top.
+
+=back
+
+A suitable skeleton for this file is shown below.
+
+ package Bundle::DBD::Driver;
+
+ $VERSION = '0.01';
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Bundle::DBD::Driver - A bundle to install all DBD::Driver related modules
+
+ =head1 SYNOPSIS
+
+ C<perl -MCPAN -e 'install Bundle::DBD::Driver'>
+
+ =head1 CONTENTS
+
+ Bundle::DBI - Bundle for DBI by TIMB (Tim Bunce)
+
+ DBD::Driver - DBD::Driver by YOU (Your Name)
+
+ =head1 DESCRIPTION
+
+ This bundle includes all the modules used by the Perl Database
+ Interface (DBI) driver for Driver (DBD::Driver), assuming the
+ use of DBI version 1.13 or later, created by Tim Bunce.
+
+ If you've not previously used the CPAN module to install any
+ bundles, you will be interrogated during its setup phase.
+ But when you've done it once, it remembers what you told it.
+ You could start by running:
+
+ C<perl -MCPAN -e 'install Bundle::CPAN'>
+
+ =head1 SEE ALSO
+
+ Bundle::DBI
+
+ =head1 AUTHOR
+
+ Your Name E<lt>F<you@yourdomain.com>E<gt>
+
+ =head1 THANKS
+
+ This bundle was created by ripping off Bundle::libnet created by
+ Graham Barr E<lt>F<gbarr@ti.com>E<gt>, and radically simplified
+ with some information from Jochen Wiedmann E<lt>F<joe@ispsoft.de>E<gt>.
+ The template was then included in the DBI::DBD documentation by
+ Jonathan Leffler E<lt>F<jleffler@informix.com>E<gt>.
+
+ =cut
+
+=head2 lib/DBD/Driver/Summary.pm
+
+There is no substitute for taking the summary file from a driver that
+was documented in the Perl book (such as B<DBD::Oracle> or B<DBD::Informix> or
+B<DBD::ODBC>, to name but three), and adapting it to describe the
+facilities available via B<DBD::Driver> when accessing the Driver database.
+
+=head2 Pure Perl version of Driver.pm
+
+The F<Driver.pm> file defines the Perl module B<DBD::Driver> for your driver.
+It will define a package B<DBD::Driver> along with some version information,
+some variable definitions, and a function C<driver()> which will have a more
+or less standard structure.
+
+It will also define three sub-packages of B<DBD::Driver>:
+
+=over 4
+
+=item DBD::Driver::dr
+
+with methods C<connect()>, C<data_sources()> and C<disconnect_all()>;
+
+=item DBD::Driver::db
+
+with methods such as C<prepare()>;
+
+=item DBD::Driver::st
+
+with methods such as C<execute()> and C<fetch()>.
+
+=back
+
+The F<Driver.pm> file will also contain the documentation specific to
+B<DBD::Driver> in the format used by perldoc.
+
+In a pure Perl driver, the F<Driver.pm> file is the core of the
+implementation. You will need to provide all the key methods needed by B<DBI>.
+
+Now let's take a closer look at an excerpt of F<File.pm> as an example.
+We ignore things that are common to any module (even non-DBI modules)
+or really specific to the B<DBD::File> package.
+
+=head3 The DBD::Driver package
+
+=head4 The header
+
+ package DBD::File;
+
+ use strict;
+ use vars qw($VERSION $drh);
+
+ $VERSION = "1.23.00" # Version number of DBD::File
+
+This is where the version number of your driver is specified, and is
+where F<Makefile.PL> looks for this information. Please ensure that any
+other modules added with your driver are also version stamped so that
+CPAN does not get confused.
+
+It is recommended that you use a two-part (1.23) or three-part (1.23.45)
+version number. Also consider the CPAN system, which gets confused and
+considers version 1.10 to precede version 1.9, so that using a raw CVS,
+RCS or SCCS version number is probably not appropriate (despite being
+very common).
+
+For Subversion you could use:
+
+ $VERSION = sprintf("12.%06d", q$Revision: 12345 $ =~ /(\d+)/o);
+
+(use lots of leading zeros on the second portion so if you move the code to a
+shared repository like svn.perl.org the much larger revision numbers won't
+cause a problem, at least not for a few years). For RCS or CVS you can use:
+
+ $VERSION = sprintf "%d.%02d", '$Revision: 11.21 $ ' =~ /(\d+)\.(\d+)/;
+
+which pads out the fractional part with leading zeros so all is well
+(so long as you don't go past x.99)
+
+ $drh = undef; # holds driver handle once initialized
+
+This is where the driver handle will be stored, once created.
+Note that you may assume there is only one handle for your driver.
+
+=head4 The driver constructor
+
+The C<driver()> method is the driver handle constructor. Note that
+the C<driver()> method is in the B<DBD::Driver> package, not in
+one of the sub-packages B<DBD::Driver::dr>, B<DBD::Driver::db>, or
+B<DBD::Driver::db>.
+
+ sub driver
+ {
+ return $drh if $drh; # already created - return same one
+ my ($class, $attr) = @_;
+
+ $class .= "::dr";
+
+ DBD::Driver::db->install_method('drv_example_dbh_method');
+ DBD::Driver::st->install_method('drv_example_sth_method');
+
+ # not a 'my' since we use it above to prevent multiple drivers
+ $drh = DBI::_new_drh($class, {
+ 'Name' => 'File',
+ 'Version' => $VERSION,
+ 'Attribution' => 'DBD::File by Jochen Wiedmann',
+ })
+ or return undef;
+
+ return $drh;
+ }
+
+This is a reasonable example of how B<DBI> implements its handles. There
+are three kinds: B<driver handles> (typically stored in I<$drh>; from
+now on called I<drh> or I<$drh>), B<database handles> (from now on
+called I<dbh> or I<$dbh>) and B<statement handles> (from now on called
+I<sth> or I<$sth>).
+
+The prototype of C<DBI::_new_drh()> is
+
+ $drh = DBI::_new_drh($class, $public_attrs, $private_attrs);
+
+with the following arguments:
+
+=over 4
+
+=item I<$class>
+
+is typically the class for your driver, (for example, "DBD::File::dr"),
+passed as the first argument to the C<driver()> method.
+
+=item I<$public_attrs>
+
+is a hash ref to attributes like I<Name>, I<Version>, and I<Attribution>.
+These are processed and used by B<DBI>. You had better not make any
+assumptions about them nor should you add private attributes here.
+
+=item I<$private_attrs>
+
+This is another (optional) hash ref with your private attributes.
+B<DBI> will store them and otherwise leave them alone.
+
+=back
+
+The C<DBI::_new_drh()> method and the C<driver()> method both return C<undef>
+for failure (in which case you must look at I<$DBI::err> and I<$DBI::errstr>
+for the failure information, because you have no driver handle to use).
+
+
+=head4 Using install_method() to expose driver-private methods
+
+ DBD::Foo::db->install_method($method_name, \%attr);
+
+Installs the driver-private method named by $method_name into the
+DBI method dispatcher so it can be called directly, avoiding the
+need to use the func() method.
+
+It is called as a static method on the driver class to which the
+method belongs. The method name must begin with the corresponding
+registered driver-private prefix. For example, for DBD::Oracle
+$method_name must being with 'C<ora_>', and for DBD::AnyData it
+must begin with 'C<ad_>'.
+
+The attributes can be used to provide fine control over how the DBI
+dispatcher handles the dispatching of the method. However, at this
+point, it's undocumented and very liable to change. (Volunteers to
+polish up and document the interface are very welcome to get in
+touch via dbi-dev@perl.org)
+
+Methods installed using install_method default to the standard error
+handling behaviour for DBI methods: clearing err and errstr before
+calling the method, and checking for errors to trigger RaiseError
+etc. on return. This differs from the default behaviour of func().
+
+Note for driver authors: The DBD::Foo::xx->install_method call won't
+work until the class-hierarchy has been setup. Normally the DBI
+looks after that just after the driver is loaded. This means
+install_method() can't be called at the time the driver is loaded
+unless the class-hierarchy is set up first. The way to do that is
+to call the setup_driver() method:
+
+ DBI->setup_driver('DBD::Foo');
+
+before using install_method().
+
+
+=head4 The CLONE special subroutine
+
+Also needed here, in the B<DBD::Driver> package, is a C<CLONE()> method
+that will be called by perl when an interpreter is cloned. All your
+C<CLONE()> method needs to do, currently, is clear the cached I<$drh> so
+the new interpreter won't start using the cached I<$drh> from the old
+interpreter:
+
+ sub CLONE {
+ undef $drh;
+ }
+
+See L<http://search.cpan.org/dist/perl/pod/perlmod.pod#Making_your_module_threadsafe>
+for details.
+
+=head3 The DBD::Driver::dr package
+
+The next lines of code look as follows:
+
+ package DBD::Driver::dr; # ====== DRIVER ======
+
+ $DBD::Driver::dr::imp_data_size = 0;
+
+Note that no I<@ISA> is needed here, or for the other B<DBD::Driver::*>
+classes, because the B<DBI> takes care of that for you when the driver is
+loaded.
+
+ *FIX ME* Explain what the imp_data_size is, so that implementors aren't
+ practicing cargo-cult programming.
+
+=head4 The database handle constructor
+
+The database handle constructor is the driver's (hence the changed
+namespace) C<connect()> method:
+
+ sub connect
+ {
+ my ($drh, $dr_dsn, $user, $auth, $attr) = @_;
+
+ # Some database specific verifications, default settings
+ # and the like can go here. This should only include
+ # syntax checks or similar stuff where it's legal to
+ # 'die' in case of errors.
+ # For example, many database packages requires specific
+ # environment variables to be set; this could be where you
+ # validate that they are set, or default them if they are not set.
+
+ my $driver_prefix = "drv_"; # the assigned prefix for this driver
+
+ # Process attributes from the DSN; we assume ODBC syntax
+ # here, that is, the DSN looks like var1=val1;...;varN=valN
+ foreach my $var ( split /;/, $dr_dsn ) {
+ my ($attr_name, $attr_value) = split '=', $var, 2;
+ return $drh->set_err($DBI::stderr, "Can't parse DSN part '$var'")
+ unless defined $attr_value;
+
+ # add driver prefix to attribute name if it doesn't have it already
+ $attr_name = $driver_prefix.$attr_name
+ unless $attr_name =~ /^$driver_prefix/o;
+
+ # Store attribute into %$attr, replacing any existing value.
+ # The DBI will STORE() these into $dbh after we've connected
+ $attr->{$attr_name} = $attr_value;
+ }
+
+ # Get the attributes we'll use to connect.
+ # We use delete here because these no need to STORE them
+ my $db = delete $attr->{drv_database} || delete $attr->{drv_db}
+ or return $drh->set_err($DBI::stderr, "No database name given in DSN '$dr_dsn'");
+ my $host = delete $attr->{drv_host} || 'localhost';
+ my $port = delete $attr->{drv_port} || 123456;
+
+ # Assume you can attach to your database via drv_connect:
+ my $connection = drv_connect($db, $host, $port, $user, $auth)
+ or return $drh->set_err($DBI::stderr, "Can't connect to $dr_dsn: ...");
+
+ # create a 'blank' dbh (call superclass constructor)
+ my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dr_dsn });
+
+ $dbh->STORE('Active', 1 );
+ $dbh->{drv_connection} = $connection;
+
+ return $outer;
+ }
+
+This is mostly the same as in the I<driver handle constructor> above.
+The arguments are described in L<DBI>.
+
+The constructor C<DBI::_new_dbh()> is called, returning a database handle.
+The constructor's prototype is:
+
+ ($outer, $inner) = DBI::_new_dbh($drh, $public_attr, $private_attr);
+
+with similar arguments to those in the I<driver handle constructor>,
+except that the I<$class> is replaced by I<$drh>. The I<Name> attribute
+is a standard B<DBI> attribute (see L<DBI/Database Handle Attributes>).
+
+In scalar context, only the outer handle is returned.
+
+Note the use of the C<STORE()> method for setting the I<dbh> attributes.
+That's because within the driver code, the handle object you have is
+the 'inner' handle of a tied hash, not the outer handle that the
+users of your driver have.
+
+Because you have the inner handle, tie magic doesn't get invoked
+when you get or set values in the hash. This is often very handy for
+speed when you want to get or set simple non-special driver-specific
+attributes.
+
+However, some attribute values, such as those handled by the B<DBI> like
+I<PrintError>, don't actually exist in the hash and must be read via
+C<$h-E<gt>FETCH($attrib)> and set via C<$h-E<gt>STORE($attrib, $value)>.
+If in any doubt, use these methods.
+
+=head4 The data_sources() method
+
+The C<data_sources()> method must populate and return a list of valid data
+sources, prefixed with the "I<dbi:Driver>" incantation that allows them to
+be used in the first argument of the C<DBI-E<gt>connect()> method.
+An example of this might be scanning the F<$HOME/.odbcini> file on Unix
+for ODBC data sources (DSNs).
+
+As a trivial example, consider a fixed list of data sources:
+
+ sub data_sources
+ {
+ my($drh, $attr) = @_;
+ my(@list) = ();
+ # You need more sophisticated code than this to set @list...
+ push @list, "dbi:Driver:abc";
+ push @list, "dbi:Driver:def";
+ push @list, "dbi:Driver:ghi";
+ # End of code to set @list
+ return @list;
+ }
+
+=head4 The disconnect_all() method
+
+If you need to release any resources when the driver is unloaded, you
+can provide a disconnect_all method.
+
+=head4 Other driver handle methods
+
+If you need any other driver handle methods, they can follow here.
+
+=head4 Error handling
+
+It is quite likely that something fails in the connect method.
+With B<DBD::File> for example, you might catch an error when setting the
+current directory to something not existent by using the
+(driver-specific) I<f_dir> attribute.
+
+To report an error, you use the C<set_err()> method:
+
+ $h->set_err($err, $errmsg, $state);
+
+This will ensure that the error is recorded correctly and that
+I<RaiseError> and I<PrintError> etc are handled correctly.
+
+Typically you'll always use the method instance, aka your method's first
+argument.
+
+As C<set_err()> always returns C<undef> your error handling code can
+usually be simplified to something like this:
+
+ return $h->set_err($err, $errmsg, $state) if ...;
+
+=head3 The DBD::Driver::db package
+
+ package DBD::Driver::db; # ====== DATABASE ======
+
+ $DBD::Driver::db::imp_data_size = 0;
+
+=head4 The statement handle constructor
+
+There's nothing much new in the statement handle constructor, which
+is the C<prepare()> method:
+
+ sub prepare
+ {
+ my ($dbh, $statement, @attribs) = @_;
+
+ # create a 'blank' sth
+ my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement });
+
+ $sth->STORE('NUM_OF_PARAMS', ($statement =~ tr/?//));
+
+ $sth->{drv_params} = [];
+
+ return $outer;
+ }
+
+This is still the same -- check the arguments and call the super class
+constructor C<DBI::_new_sth()>. Again, in scalar context, only the outer
+handle is returned. The I<Statement> attribute should be cached as
+shown.
+
+Note the prefix I<drv_> in the attribute names: it is required that
+all your private attributes use a lowercase prefix unique to your driver.
+As mentioned earlier in this document, the B<DBI> contains a registry of
+known driver prefixes and may one day warn about unknown attributes
+that don't have a registered prefix.
+
+Note that we parse the statement here in order to set the attribute
+I<NUM_OF_PARAMS>. The technique illustrated is not very reliable; it can
+be confused by question marks appearing in quoted strings, delimited
+identifiers or in SQL comments that are part of the SQL statement. We
+could set I<NUM_OF_PARAMS> in the C<execute()> method instead because
+the B<DBI> specification explicitly allows a driver to defer this, but then
+the user could not call C<bind_param()>.
+
+=head4 Transaction handling
+
+Pure Perl drivers will rarely support transactions. Thus your C<commit()>
+and C<rollback()> methods will typically be quite simple:
+
+ sub commit
+ {
+ my ($dbh) = @_;
+ if ($dbh->FETCH('Warn')) {
+ warn("Commit ineffective while AutoCommit is on");
+ }
+ 0;
+ }
+
+ sub rollback {
+ my ($dbh) = @_;
+ if ($dbh->FETCH('Warn')) {
+ warn("Rollback ineffective while AutoCommit is on");
+ }
+ 0;
+ }
+
+Or even simpler, just use the default methods provided by the B<DBI> that
+do nothing except return C<undef>.
+
+The B<DBI>'s default C<begin_work()> method can be used by inheritance.
+
+=head4 The STORE() and FETCH() methods
+
+These methods (that we have already used, see above) are called for
+you, whenever the user does a:
+
+ $dbh->{$attr} = $val;
+
+or, respectively,
+
+ $val = $dbh->{$attr};
+
+See L<perltie> for details on tied hash refs to understand why these
+methods are required.
+
+The B<DBI> will handle most attributes for you, in particular attributes
+like I<RaiseError> or I<PrintError>. All you have to do is handle your
+driver's private attributes and any attributes, like I<AutoCommit> and
+I<ChopBlanks>, that the B<DBI> can't handle for you.
+
+A good example might look like this:
+
+ sub STORE
+ {
+ my ($dbh, $attr, $val) = @_;
+ if ($attr eq 'AutoCommit') {
+ # AutoCommit is currently the only standard attribute we have
+ # to consider.
+ if (!$val) { die "Can't disable AutoCommit"; }
+ return 1;
+ }
+ if ($attr =~ m/^drv_/) {
+ # Handle only our private attributes here
+ # Note that we could trigger arbitrary actions.
+ # Ideally we should warn about unknown attributes.
+ $dbh->{$attr} = $val; # Yes, we are allowed to do this,
+ return 1; # but only for our private attributes
+ }
+ # Else pass up to DBI to handle for us
+ $dbh->SUPER::STORE($attr, $val);
+ }
+
+ sub FETCH
+ {
+ my ($dbh, $attr) = @_;
+ if ($attr eq 'AutoCommit') { return 1; }
+ if ($attr =~ m/^drv_/) {
+ # Handle only our private attributes here
+ # Note that we could trigger arbitrary actions.
+ return $dbh->{$attr}; # Yes, we are allowed to do this,
+ # but only for our private attributes
+ }
+ # Else pass up to DBI to handle
+ $dbh->SUPER::FETCH($attr);
+ }
+
+The B<DBI> will actually store and fetch driver-specific attributes (with all
+lowercase names) without warning or error, so there's actually no need to
+implement driver-specific any code in your C<FETCH()> and C<STORE()>
+methods unless you need extra logic/checks, beyond getting or setting
+the value.
+
+Unless your driver documentation indicates otherwise, the return value of
+the C<STORE()> method is unspecified and the caller shouldn't use that value.
+
+=head4 Other database handle methods
+
+As with the driver package, other database handle methods may follow here.
+In particular you should consider a (possibly empty) C<disconnect()>
+method and possibly a C<quote()> method if B<DBI>'s default isn't correct for
+you. You may also need the C<type_info_all()> and C<get_info()> methods,
+as described elsewhere in this document.
+
+Where reasonable use C<$h-E<gt>SUPER::foo()> to call the B<DBI>'s method in
+some or all cases and just wrap your custom behavior around that.
+
+If you want to use private trace flags you'll probably want to be
+able to set them by name. To do that you'll need to define a
+C<parse_trace_flag()> method (note that's "parse_trace_flag", singular,
+not "parse_trace_flags", plural).
+
+ sub parse_trace_flag {
+ my ($h, $name) = @_;
+ return 0x01000000 if $name eq 'foo';
+ return 0x02000000 if $name eq 'bar';
+ return 0x04000000 if $name eq 'baz';
+ return 0x08000000 if $name eq 'boo';
+ return 0x10000000 if $name eq 'bop';
+ return $h->SUPER::parse_trace_flag($name);
+ }
+
+All private flag names must be lowercase, and all private flags
+must be in the top 8 of the 32 bits.
+
+=head3 The DBD::Driver::st package
+
+This package follows the same pattern the others do:
+
+ package DBD::Driver::st;
+
+ $DBD::Driver::st::imp_data_size = 0;
+
+=head4 The execute() and bind_param() methods
+
+This is perhaps the most difficult method because we have to consider
+parameter bindings here. In addition to that, there are a number of
+statement attributes which must be set for inherited B<DBI> methods to
+function correctly (see L</Statement attributes> below).
+
+We present a simplified implementation by using the I<drv_params>
+attribute from above:
+
+ sub bind_param
+ {
+ my ($sth, $pNum, $val, $attr) = @_;
+ my $type = (ref $attr) ? $attr->{TYPE} : $attr;
+ if ($type) {
+ my $dbh = $sth->{Database};
+ $val = $dbh->quote($sth, $type);
+ }
+ my $params = $sth->{drv_params};
+ $params->[$pNum-1] = $val;
+ 1;
+ }
+
+ sub execute
+ {
+ my ($sth, @bind_values) = @_;
+
+ # start of by finishing any previous execution if still active
+ $sth->finish if $sth->FETCH('Active');
+
+ my $params = (@bind_values) ?
+ \@bind_values : $sth->{drv_params};
+ my $numParam = $sth->FETCH('NUM_OF_PARAMS');
+ return $sth->set_err($DBI::stderr, "Wrong number of parameters")
+ if @$params != $numParam;
+ my $statement = $sth->{'Statement'};
+ for (my $i = 0; $i < $numParam; $i++) {
+ $statement =~ s/?/$params->[$i]/; # XXX doesn't deal with quoting etc!
+ }
+ # Do anything ... we assume that an array ref of rows is
+ # created and store it:
+ $sth->{'drv_data'} = $data;
+ $sth->{'drv_rows'} = @$data; # number of rows
+ $sth->STORE('NUM_OF_FIELDS') = $numFields;
+ $sth->{Active} = 1;
+ @$data || '0E0';
+ }
+
+There are a number of things you should note here.
+
+We initialize the I<NUM_OF_FIELDS> and I<Active> attributes here,
+because they are essential for C<bind_columns()> to work.
+
+We use attribute C<$sth-E<gt>{Statement}> which we created
+within C<prepare()>. The attribute C<$sth-E<gt>{Database}>, which is
+nothing else than the I<dbh>, was automatically created by B<DBI>.
+
+Finally, note that (as specified in the B<DBI> specification) we return the
+string C<'0E0'> instead of the number 0, so that the result tests true but
+equal to zero.
+
+ $sth->execute() or die $sth->errstr;
+
+=head4 The execute_array(), execute_for_fetch() and bind_param_array() methods
+
+In general, DBD's only need to implement C<execute_for_fetch()> and
+C<bind_param_array>. DBI's default C<execute_array()> will invoke the
+DBD's C<execute_for_fetch()> as needed.
+
+The following sequence describes the interaction between
+DBI C<execute_array> and a DBD's C<execute_for_fetch>:
+
+=over
+
+=item 1
+
+App calls C<$sth-E<gt>execute_array(\%attrs, @array_of_arrays)>
+
+=item 2
+
+If C<@array_of_arrays> was specified, DBI processes C<@array_of_arrays> by calling
+DBD's C<bind_param_array()>. Alternately, App may have directly called
+C<bind_param_array()>
+
+=item 3
+
+DBD validates and binds each array
+
+=item 4
+
+DBI retrieves the validated param arrays from DBD's ParamArray attribute
+
+=item 5
+
+DBI calls DBD's C<execute_for_fetch($fetch_tuple_sub, \@tuple_status)>,
+where C<&$fetch_tuple_sub> is a closure to iterate over the
+returned ParamArray values, and C<\@tuple_status> is an array to receive
+the disposition status of each tuple.
+
+=item 6
+
+DBD iteratively calls C<&$fetch_tuple_sub> to retrieve parameter tuples
+to be added to its bulk database operation/request.
+
+=item 7
+
+when DBD reaches the limit of tuples it can handle in a single database
+operation/request, or the C<&$fetch_tuple_sub> indicates no more
+tuples by returning undef, the DBD executes the bulk operation, and
+reports the disposition of each tuple in \@tuple_status.
+
+=item 8
+
+DBD repeats steps 6 and 7 until all tuples are processed.
+
+=back
+
+E.g., here's the essence of L<DBD::Oracle>'s execute_for_fetch:
+
+ while (1) {
+ my @tuple_batch;
+ for (my $i = 0; $i < $batch_size; $i++) {
+ push @tuple_batch, [ @{$fetch_tuple_sub->() || last} ];
+ }
+ last unless @tuple_batch;
+ my $res = ora_execute_array($sth, \@tuple_batch,
+ scalar(@tuple_batch), $tuple_batch_status);
+ push @$tuple_status, @$tuple_batch_status;
+ }
+
+Note that DBI's default execute_array()/execute_for_fetch() implementation
+requires the use of positional (i.e., '?') placeholders. Drivers
+which B<require> named placeholders must either emulate positional
+placeholders (e.g., see L<DBD::Oracle>), or must implement their own
+execute_array()/execute_for_fetch() methods to properly sequence bound
+parameter arrays.
+
+=head4 Fetching data
+
+Only one method needs to be written for fetching data, C<fetchrow_arrayref()>.
+The other methods, C<fetchrow_array()>, C<fetchall_arrayref()>, etc, as well
+as the database handle's C<select*> methods are part of B<DBI>, and call
+C<fetchrow_arrayref()> as necessary.
+
+ sub fetchrow_arrayref
+ {
+ my ($sth) = @_;
+ my $data = $sth->{drv_data};
+ my $row = shift @$data;
+ if (!$row) {
+ $sth->STORE(Active => 0); # mark as no longer active
+ return undef;
+ }
+ if ($sth->FETCH('ChopBlanks')) {
+ map { $_ =~ s/\s+$//; } @$row;
+ }
+ return $sth->_set_fbav($row);
+ }
+ *fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref
+
+Note the use of the method C<_set_fbav()> -- this is required so that
+C<bind_col()> and C<bind_columns()> work.
+
+If an error occurs which leaves the I<$sth> in a state where remaining rows
+can't be fetched then I<Active> should be turned off before the method returns.
+
+The C<rows()> method for this driver can be implemented like this:
+
+ sub rows { shift->{drv_rows} }
+
+because it knows in advance how many rows it has fetched.
+Alternatively you could delete that method and so fallback
+to the B<DBI>'s own method which does the right thing based
+on the number of calls to C<_set_fbav()>.
+
+=head4 The more_results method
+
+If your driver doesn't support multiple result sets, then don't even implement this method.
+
+Otherwise, this method needs to get the statement handle ready to fetch results
+from the next result set, if there is one. Typically you'd start with:
+
+ $sth->finish;
+
+then you should delete all the attributes from the attribute cache that may no
+longer be relevant for the new result set:
+
+ delete $sth->{$_}
+ for qw(NAME TYPE PRECISION SCALE ...);
+
+for drivers written in C use:
+
+ hv_delete((HV*)SvRV(sth), "NAME", 4, G_DISCARD);
+ hv_delete((HV*)SvRV(sth), "NULLABLE", 8, G_DISCARD);
+ hv_delete((HV*)SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD);
+ hv_delete((HV*)SvRV(sth), "PRECISION", 9, G_DISCARD);
+ hv_delete((HV*)SvRV(sth), "SCALE", 5, G_DISCARD);
+ hv_delete((HV*)SvRV(sth), "TYPE", 4, G_DISCARD);
+
+Don't forget to also delete, or update, any driver-private attributes that may
+not be correct for the next resultset.
+
+The NUM_OF_FIELDS attribute is a special case. It should be set using STORE:
+
+ $sth->STORE(NUM_OF_FIELDS => 0); /* for DBI <= 1.53 */
+ $sth->STORE(NUM_OF_FIELDS => $new_value);
+
+for drivers written in C use this incantation:
+
+ /* Adjust NUM_OF_FIELDS - which also adjusts the row buffer size */
+ DBIc_NUM_FIELDS(imp_sth) = 0; /* for DBI <= 1.53 */
+ DBIc_STATE(imp_xxh)->set_attr_k(sth, sv_2mortal(newSVpvn("NUM_OF_FIELDS",13)), 0,
+ sv_2mortal(newSViv(mysql_num_fields(imp_sth->result)))
+ );
+
+For DBI versions prior to 1.54 you'll also need to explicitly adjust the
+number of elements in the row buffer array (C<DBIc_FIELDS_AV(imp_sth)>)
+to match the new result set. Fill any new values with newSV(0) not &sv_undef.
+Alternatively you could free DBIc_FIELDS_AV(imp_sth) and set it to null,
+but that would mean bind_columns() wouldn't work across result sets.
+
+
+=head4 Statement attributes
+
+The main difference between I<dbh> and I<sth> attributes is, that you
+should implement a lot of attributes here that are required by
+the B<DBI>, such as I<NAME>, I<NULLABLE>, I<TYPE>, etc. See
+L<DBI/Statement Handle Attributes> for a complete list.
+
+Pay attention to attributes which are marked as read only, such as
+I<NUM_OF_PARAMS>. These attributes can only be set the first time
+a statement is executed. If a statement is prepared, then executed
+multiple times, warnings may be generated.
+
+You can protect against these warnings, and prevent the recalculation
+of attributes which might be expensive to calculate (such as the
+I<NAME> and I<NAME_*> attributes):
+
+ my $storedNumParams = $sth->FETCH('NUM_OF_PARAMS');
+ if (!defined $storedNumParams or $storedNumFields < 0) {
+ $sth->STORE('NUM_OF_PARAMS') = $numParams;
+
+ # Set other useful attributes that only need to be set once
+ # for a statement, like $sth->{NAME} and $sth->{TYPE}
+ }
+
+One particularly important attribute to set correctly (mentioned in
+L<DBI/ATTRIBUTES COMMON TO ALL HANDLES> is I<Active>. Many B<DBI> methods,
+including C<bind_columns()>, depend on this attribute.
+
+Besides that the C<STORE()> and C<FETCH()> methods are mainly the same
+as above for I<dbh>'s.
+
+=head4 Other statement methods
+
+A trivial C<finish()> method to discard stored data, reset any attributes
+(such as I<Active>) and do C<$sth-E<gt>SUPER::finish()>.
+
+If you've defined a C<parse_trace_flag()> method in B<::db> you'll also want
+it in B<::st>, so just alias it in:
+
+ *parse_trace_flag = \&DBD::foo:db::parse_trace_flag;
+
+And perhaps some other methods that are not part of the B<DBI>
+specification, in particular to make metadata available.
+Remember that they must have names that begin with your drivers
+registered prefix so they can be installed using C<install_method()>.
+
+If C<DESTROY()> is called on a statement handle that's still active
+(C<$sth-E<gt>{Active}> is true) then it should effectively call C<finish()>.
+
+ sub DESTROY {
+ my $sth = shift;
+ $sth->finish if $sth->FETCH('Active');
+ }
+
+=head2 Tests
+
+The test process should conform as closely as possibly to the Perl
+standard test harness.
+
+In particular, most (all) of the tests should be run in the F<t> sub-directory,
+and should simply produce an C<ok> when run under C<make test>.
+For details on how this is done, see the Camel book and the section in
+Chapter 7, "The Standard Perl Library" on L<Test::Harness>.
+
+The tests may need to adapt to the type of database which is being used
+for testing, and to the privileges of the user testing the driver. For
+example, the B<DBD::Informix> test code has to adapt in a number of
+places to the type of database to which it is connected as different
+Informix databases have different capabilities: some of the tests are
+for databases without transaction logs; others are for databases with a
+transaction log; some versions of the server have support for blobs, or
+stored procedures, or user-defined data types, and others do not.
+
+When a complete file of tests must be skipped, you can provide a reason
+in a pseudo-comment:
+
+ if ($no_transactions_available)
+ {
+ print "1..0 # Skip: No transactions available\n";
+ exit 0;
+ }
+
+Consider downloading the B<DBD::Informix> code and look at the code in
+F<DBD/Informix/TestHarness.pm> which is used throughout the
+B<DBD::Informix> tests in the F<t> sub-directory.
+
+=head1 CREATING A C/XS DRIVER
+
+Please also see the section under L<CREATING A PURE PERL DRIVER>
+regarding the creation of the F<Makefile.PL>.
+
+Creating a new C/XS driver from scratch will always be a daunting task.
+You can and should greatly simplify your task by taking a good
+reference driver implementation and modifying that to match the
+database product for which you are writing a driver.
+
+The de facto reference driver has been the one for B<DBD::Oracle> written
+by Tim Bunce, who is also the author of the B<DBI> package. The B<DBD::Oracle>
+module is a good example of a driver implemented around a C-level API.
+
+Nowadays it it seems better to base on B<DBD::ODBC>, another driver
+maintained by Tim and Jeff Urlwin, because it offers a lot of metadata
+and seems to become the guideline for the future development. (Also as
+B<DBD::Oracle> digs deeper into the Oracle 8 OCI interface it'll get even
+more hairy than it is now.)
+
+The B<DBD::Informix> driver is one driver implemented using embedded SQL
+instead of a function-based API.
+B<DBD::Ingres> may also be worth a look.
+
+=head2 C/XS version of Driver.pm
+
+A lot of the code in the F<Driver.pm> file is very similar to the code for pure Perl modules
+- see above. However,
+there are also some subtle (and not so subtle) differences, including:
+
+=over 8
+
+=item *
+
+The variables I<$DBD::Driver::{dr|db|st}::imp_data_size> are not defined
+here, but in the XS code, because they declare the size of certain
+C structures.
+
+=item *
+
+Some methods are typically moved to the XS code, in particular
+C<prepare()>, C<execute()>, C<disconnect()>, C<disconnect_all()> and the
+C<STORE()> and C<FETCH()> methods.
+
+=item *
+
+Other methods are still part of F<Driver.pm>, but have callbacks to
+the XS code.
+
+=item *
+
+If the driver-specific parts of the I<imp_drh_t> structure need to be
+formally initialized (which does not seem to be a common requirement),
+then you need to add a call to an appropriate XS function in the driver
+method of C<DBD::Driver::driver()>, and you define the corresponding function
+in F<Driver.xs>, and you define the C code in F<dbdimp.c> and the prototype in
+F<dbdimp.h>.
+
+For example, B<DBD::Informix> has such a requirement, and adds the
+following call after the call to C<_new_drh()> in F<Informix.pm>:
+
+ DBD::Informix::dr::driver_init($drh);
+
+and the following code in F<Informix.xs>:
+
+ # Initialize the DBD::Informix driver data structure
+ void
+ driver_init(drh)
+ SV *drh
+ CODE:
+ ST(0) = dbd_ix_dr_driver_init(drh) ? &sv_yes : &sv_no;
+
+and the code in F<dbdimp.h> declares:
+
+ extern int dbd_ix_dr_driver_init(SV *drh);
+
+and the code in F<dbdimp.ec> (equivalent to F<dbdimp.c>) defines:
+
+ /* Formally initialize the DBD::Informix driver structure */
+ int
+ dbd_ix_dr_driver(SV *drh)
+ {
+ D_imp_drh(drh);
+ imp_drh->n_connections = 0; /* No active connections */
+ imp_drh->current_connection = 0; /* No current connection */
+ imp_drh->multipleconnections = (ESQLC_VERSION >= 600) ? True : False;
+ dbd_ix_link_newhead(&imp_drh->head); /* Empty linked list of connections */
+ return 1;
+ }
+
+B<DBD::Oracle> has a similar requirement but gets around it by checking
+whether the private data part of the driver handle is all zeroed out,
+rather than add extra functions.
+
+=back
+
+Now let's take a closer look at an excerpt from F<Oracle.pm> (revised
+heavily to remove idiosyncrasies) as an example, ignoring things that
+were already discussed for pure Perl drivers.
+
+=head3 The connect method
+
+The connect method is the database handle constructor.
+You could write either of two versions of this method: either one which
+takes connection attributes (new code) and one which ignores them (old
+code only).
+
+If you ignore the connection attributes, then you omit all mention of
+the I<$auth> variable (which is a reference to a hash of attributes), and
+the XS system manages the differences for you.
+
+ sub connect
+ {
+ my ($drh, $dbname, $user, $auth, $attr) = @_;
+
+ # Some database specific verifications, default settings
+ # and the like following here. This should only include
+ # syntax checks or similar stuff where it's legal to
+ # 'die' in case of errors.
+
+ my $dbh = DBI::_new_dbh($drh, {
+ 'Name' => $dbname,
+ })
+ or return undef;
+
+ # Call the driver-specific function _login in Driver.xs file which
+ # calls the DBMS-specific function(s) to connect to the database,
+ # and populate internal handle data.
+ DBD::Driver::db::_login($dbh, $dbname, $user, $auth, $attr)
+ or return undef;
+
+ $dbh;
+ }
+
+This is mostly the same as in the pure Perl case, the exception being
+the use of the private C<_login()> callback, which is the function
+that will really connect to the database. It is implemented in
+F<Driver.xst> (you should not implement it) and calls
+C<dbd_db_login6()> or C<dbd_db_login6_sv> from F<dbdimp.c>. See below
+for details.
+
+If your driver has driver-specific attributes which may be passed in the
+connect method and hence end up in C<$attr> in C<dbd_db_login6> then it
+is best to delete any you process so DBI does not send them again
+via STORE after connect. You can do this in C like this:
+
+ DBD_ATTRIB_DELETE(attr, "my_attribute_name",
+ strlen("my_attribute_name"));
+
+However, prior to DBI subversion version 11605 (and fixed post 1.607)
+DBD_ATTRIB_DELETE segfaulted so if you cannot guarantee the DBI version
+will be post 1.607 you need to use:
+
+ hv_delete((HV*)SvRV(attr), "my_attribute_name",
+ strlen("my_attribute_name"), G_DISCARD);
+
+ *FIX ME* Discuss removing attributes in Perl code.
+
+=head3 The disconnect_all method
+
+ *FIX ME* T.B.S
+
+=head3 The data_sources method
+
+If your C<data_sources()> method can be implemented in pure Perl, then do
+so because it is easier than doing it in XS code (see the section above
+for pure Perl drivers).
+
+If your C<data_sources()> method must call onto compiled functions, then
+you will need to define I<dbd_dr_data_sources> in your F<dbdimp.h> file, which
+will trigger F<Driver.xst> (in B<DBI> v1.33 or greater) to generate the XS
+code that calls your actual C function (see the discussion below for
+details) and you do not code anything in F<Driver.pm> to handle it.
+
+=head3 The prepare method
+
+The prepare method is the statement handle constructor, and most of it
+is not new. Like the C<connect()> method, it now has a C callback:
+
+ package DBD::Driver::db; # ====== DATABASE ======
+ use strict;
+
+ sub prepare
+ {
+ my ($dbh, $statement, $attribs) = @_;
+
+ # create a 'blank' sth
+ my $sth = DBI::_new_sth($dbh, {
+ 'Statement' => $statement,
+ })
+ or return undef;
+
+ # Call the driver-specific function _prepare in Driver.xs file
+ # which calls the DBMS-specific function(s) to prepare a statement
+ # and populate internal handle data.
+ DBD::Driver::st::_prepare($sth, $statement, $attribs)
+ or return undef;
+ $sth;
+ }
+
+=head3 The execute method
+
+ *FIX ME* T.B.S
+
+=head3 The fetchrow_arrayref method
+
+ *FIX ME* T.B.S
+
+=head3 Other methods?
+
+ *FIX ME* T.B.S
+
+=head2 Driver.xs
+
+F<Driver.xs> should look something like this:
+
+ #include "Driver.h"
+
+ DBISTATE_DECLARE;
+
+ INCLUDE: Driver.xsi
+
+ MODULE = DBD::Driver PACKAGE = DBD::Driver::dr
+
+ /* Non-standard drh XS methods following here, if any. */
+ /* If none (the usual case), omit the MODULE line above too. */
+
+ MODULE = DBD::Driver PACKAGE = DBD::Driver::db
+
+ /* Non-standard dbh XS methods following here, if any. */
+ /* Currently this includes things like _list_tables from */
+ /* DBD::mSQL and DBD::mysql. */
+
+ MODULE = DBD::Driver PACKAGE = DBD::Driver::st
+
+ /* Non-standard sth XS methods following here, if any. */
+ /* In particular this includes things like _list_fields from */
+ /* DBD::mSQL and DBD::mysql for accessing metadata. */
+
+Note especially the include of F<Driver.xsi> here: B<DBI> inserts stub
+functions for almost all private methods here which will typically do
+much work for you.
+
+Wherever you really have to implement something, it will call a private
+function in F<dbdimp.c>, and this is what you have to implement.
+
+You need to set up an extra routine if your driver needs to export
+constants of its own, analogous to the SQL types available when you say:
+
+ use DBI qw(:sql_types);
+
+ *FIX ME* T.B.S
+
+=head2 Driver.h
+
+F<Driver.h> is very simple and the operational contents should look like this:
+
+ #ifndef DRIVER_H_INCLUDED
+ #define DRIVER_H_INCLUDED
+
+ #define NEED_DBIXS_VERSION 93 /* 93 for DBI versions 1.00 to 1.51+ */
+ #define PERL_NO_GET_CONTEXT /* if used require DBI 1.51+ */
+
+ #include <DBIXS.h> /* installed by the DBI module */
+
+ #include "dbdimp.h"
+
+ #include "dbivport.h" /* see below */
+
+ #include <dbd_xsh.h> /* installed by the DBI module */
+
+ #endif /* DRIVER_H_INCLUDED */
+
+The F<DBIXS.h> header defines most of the interesting information that
+the writer of a driver needs.
+
+The file F<dbd_xsh.h> header provides prototype declarations for the C
+functions that you might decide to implement. Note that you should
+normally only define one of C<dbd_db_login()>, C<dbd_db_login6()> or
+C<dbd_db_login6_sv> unless you are intent on supporting really old
+versions of B<DBI> (prior to B<DBI> 1.06) as well as modern
+versions. The only standard, B<DBI>-mandated functions that you need
+write are those specified in the F<dbd_xsh.h> header. You might also
+add extra driver-specific functions in F<Driver.xs>.
+
+The F<dbivport.h> file should be I<copied> from the latest B<DBI> release
+into your distribution each time you modify your driver. Its job is to
+allow you to enhance your code to work with the latest B<DBI> API while
+still allowing your driver to be compiled and used with older versions
+of the B<DBI> (for example, when the C<DBIh_SET_ERR_CHAR()> macro was added
+to B<DBI> 1.41, an emulation of it was added to F<dbivport.h>). This makes
+users happy and your life easier. Always read the notes in F<dbivport.h>
+to check for any limitations in the emulation that you should be aware
+of.
+
+With B<DBI> v1.51 or better I recommend that the driver defines
+I<PERL_NO_GET_CONTEXT> before F<DBIXS.h> is included. This can significantly
+improve efficiency when running under a thread enabled perl. (Remember that
+the standard perl in most Linux distributions is built with threads enabled.
+So is ActiveState perl for Windows, and perl built for Apache mod_perl2.)
+If you do this there are some things to keep in mind:
+
+=over 4
+
+=item *
+
+If I<PERL_NO_GET_CONTEXT> is defined, then every function that calls the Perl
+API will need to start out with a C<dTHX;> declaration.
+
+=item *
+
+You'll know which functions need this, because the C compiler will
+complain that the undeclared identifier C<my_perl> is used if I<and only if>
+the perl you are using to develop and test your driver has threads enabled.
+
+=item *
+
+If you don't remember to test with a thread-enabled perl before making
+a release it's likely that you'll get failure reports from users who are.
+
+=item *
+
+For driver private functions it is possible to gain even more
+efficiency by replacing C<dTHX;> with C<pTHX_> prepended to the
+parameter list and then C<aTHX_> prepended to the argument list where
+the function is called.
+
+=back
+
+See L<perlguts/How multiple interpreters and concurrency are supported> for
+additional information about I<PERL_NO_GET_CONTEXT>.
+
+=head2 Implementation header dbdimp.h
+
+This header file has two jobs:
+
+First it defines data structures for your private part of the handles.
+
+Second it defines macros that rename the generic names like
+C<dbd_db_login()> to database specific names like C<ora_db_login()>. This
+avoids name clashes and enables use of different drivers when you work
+with a statically linked perl.
+
+It also will have the important task of disabling XS methods that you
+don't want to implement.
+
+Finally, the macros will also be used to select alternate
+implementations of some functions. For example, the C<dbd_db_login()>
+function is not passed the attribute hash.
+
+Since B<DBI> v1.06, if a C<dbd_db_login6()> macro is defined (for a function
+with 6 arguments), it will be used instead with the attribute hash
+passed as the sixth argument.
+
+Since B<DBI> post v1.607, if a C<dbd_db_login6_sv()> macro is defined (for
+a function like dbd_db_login6 but with scalar pointers for the dbname,
+username and password), it will be used instead. This will allow your
+login6 function to see if there are any unicode characters in the
+dbname.
+
+People used to just pick Oracle's F<dbdimp.c> and use the same names,
+structures and types. I strongly recommend against that. At first glance
+this saves time, but your implementation will be less readable. It was
+just hell when I had to separate B<DBI> specific parts, Oracle specific
+parts, mSQL specific parts and mysql specific parts in B<DBD::mysql>'s
+I<dbdimp.h> and I<dbdimp.c>. (B<DBD::mysql> was a port of B<DBD::mSQL>
+which was based on B<DBD::Oracle>.) [Seconded, based on the experience
+taking B<DBD::Informix> apart, even though the version inherited in 1996
+was only based on B<DBD::Oracle>.]
+
+This part of the driver is I<your exclusive part>. Rewrite it from
+scratch, so it will be clean and short: in other words, a better piece
+of code. (Of course keep an eye on other people's work.)
+
+ struct imp_drh_st {
+ dbih_drc_t com; /* MUST be first element in structure */
+ /* Insert your driver handle attributes here */
+ };
+
+ struct imp_dbh_st {
+ dbih_dbc_t com; /* MUST be first element in structure */
+ /* Insert your database handle attributes here */
+ };
+
+ struct imp_sth_st {
+ dbih_stc_t com; /* MUST be first element in structure */
+ /* Insert your statement handle attributes here */
+ };
+
+ /* Rename functions for avoiding name clashes; prototypes are */
+ /* in dbd_xst.h */
+ #define dbd_init drv_dr_init
+ #define dbd_db_login6_sv drv_db_login_sv
+ #define dbd_db_do drv_db_do
+ ... many more here ...
+
+These structures implement your private part of the handles.
+
+You I<have> to use the name C<imp_dbh_{dr|db|st}> and the first field
+I<must> be of type I<dbih_drc_t|_dbc_t|_stc_t> and I<must> be called
+C<com>.
+
+You should never access these fields directly, except by using the
+I<DBIc_xxx()> macros below.
+
+=head2 Implementation source dbdimp.c
+
+Conventionally, F<dbdimp.c> is the main implementation file (but
+B<DBD::Informix> calls the file F<dbdimp.ec>). This section includes a
+short note on each function that is used in the F<Driver.xsi> template
+and thus I<has> to be implemented.
+
+Of course, you will probably also need to implement other support
+functions, which should usually be file static if they are placed in
+F<dbdimp.c>. If they are placed in other files, you need to list those
+files in F<Makefile.PL> (and F<MANIFEST>) to handle them correctly.
+
+It is wise to adhere to a namespace convention for your functions to
+avoid conflicts. For example, for a driver with prefix I<drv_>, you
+might call externally visible functions I<dbd_drv_xxxx>. You should also
+avoid non-constant global variables as much as possible to improve the
+support for threading.
+
+Since Perl requires support for function prototypes (ANSI or ISO or
+Standard C), you should write your code using function prototypes too.
+
+It is possible to use either the unmapped names such as C<dbd_init()> or
+the mapped names such as C<dbd_ix_dr_init()> in the F<dbdimp.c> file.
+B<DBD::Informix> uses the mapped names which makes it easier to identify
+where to look for linkage problems at runtime (which will report errors
+using the mapped names).
+
+Most other drivers, and in particular B<DBD::Oracle>, use the unmapped
+names in the source code which makes it a little easier to compare code
+between drivers and eases discussions on the I<dbi-dev> mailing list.
+The majority of the code fragments here will use the unmapped names.
+
+Ultimately, you should provide implementations for most of the
+functions listed in the F<dbd_xsh.h> header. The exceptions are
+optional functions (such as C<dbd_st_rows()>) and those functions with
+alternative signatures, such as C<dbd_db_login6_sv>,
+C<dbd_db_login6()> and I<dbd_db_login()>. Then you should only
+implement one of the alternatives, and generally the newer one of the
+alternatives.
+
+=head3 The dbd_init method
+
+ #include "Driver.h"
+
+ DBISTATE_DECLARE;
+
+ void dbd_init(dbistate_t* dbistate)
+ {
+ DBISTATE_INIT; /* Initialize the DBI macros */
+ }
+
+The C<dbd_init()> function will be called when your driver is first
+loaded; the bootstrap command in C<DBD::Driver::dr::driver()> triggers this,
+and the call is generated in the I<BOOT> section of F<Driver.xst>.
+These statements are needed to allow your driver to use the B<DBI> macros.
+They will include your private header file F<dbdimp.h> in turn.
+Note that I<DBISTATE_INIT> requires the name of the argument to C<dbd_init()>
+to be called C<dbistate()>.
+
+=head3 The dbd_drv_error method
+
+You need a function to record errors so B<DBI> can access them properly.
+You can call it whatever you like, but we'll call it C<dbd_drv_error()>
+here.
+
+The argument list depends on your database software; different systems
+provide different ways to get at error information.
+
+ static void dbd_drv_error(SV *h, int rc, const char *what)
+ {
+
+Note that I<h> is a generic handle, may it be a driver handle, a
+database or a statement handle.
+
+ D_imp_xxh(h);
+
+This macro will declare and initialize a variable I<imp_xxh> with
+a pointer to your private handle pointer. You may cast this to
+to I<imp_drh_t>, I<imp_dbh_t> or I<imp_sth_t>.
+
+To record the error correctly, equivalent to the C<set_err()> method,
+use one of the C<DBIh_SET_ERR_CHAR(...)> or C<DBIh_SET_ERR_SV(...)> macros,
+which were added in B<DBI> 1.41:
+
+ DBIh_SET_ERR_SV(h, imp_xxh, err, errstr, state, method);
+ DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method);
+
+For C<DBIh_SET_ERR_SV> the I<err>, I<errstr>, I<state>, and I<method>
+parameters are C<SV*>.
+
+For C<DBIh_SET_ERR_CHAR> the I<err_c>, I<errstr>, I<state>, I<method>
+parameters are C<char*>.
+
+The I<err_i> parameter is an C<IV> that's used instead of I<err_c> if
+I<err_c> is C<Null>.
+
+The I<method> parameter can be ignored.
+
+The C<DBIh_SET_ERR_CHAR> macro is usually the simplest to use when you
+just have an integer error code and an error message string:
+
+ DBIh_SET_ERR_CHAR(h, imp_xxh, Nullch, rc, what, Nullch, Nullch);
+
+As you can see, any parameters that aren't relevant to you can be C<Null>.
+
+To make drivers compatible with B<DBI> < 1.41 you should be using F<dbivport.h>
+as described in L</Driver.h> above.
+
+The (obsolete) macros such as C<DBIh_EVENT2> should be removed from drivers.
+
+The names C<dbis> and C<DBIS>, which were used in previous versions of
+this document, should be replaced with the C<DBIc_STATE(imp_xxh)> macro.
+
+The name C<DBILOGFP>, which was also used in previous versions of this
+document, should be replaced by C<DBIc_LOGPIO(imp_xxh)>.
+
+Your code should not call the C C<E<lt>stdio.hE<gt>> I/O functions; you
+should use C<PerlIO_printf()> as shown:
+
+ if (DBIc_TRACE_LEVEL(imp_xxh) >= 2)
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar %s: %s\n",
+ foo, neatsvpv(errstr,0));
+
+That's the first time we see how tracing works within a B<DBI> driver. Make
+use of this as often as you can, but don't output anything at a trace
+level less than 3. Levels 1 and 2 are reserved for the B<DBI>.
+
+You can define up to 8 private trace flags using the top 8 bits
+of C<DBIc_TRACE_FLAGS(imp)>, that is: C<0xFF000000>. See the
+C<parse_trace_flag()> method elsewhere in this document.
+
+=head3 The dbd_dr_data_sources method
+
+This method is optional; the support for it was added in B<DBI> v1.33.
+
+As noted in the discussion of F<Driver.pm>, if the data sources
+can be determined by pure Perl code, do it that way. If, as in
+B<DBD::Informix>, the information is obtained by a C function call, then
+you need to define a function that matches the prototype:
+
+ extern AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attrs);
+
+An outline implementation for B<DBD::Informix> follows, assuming that the
+C<sqgetdbs()> function call shown will return up to 100 databases names,
+with the pointers to each name in the array dbsname and the name strings
+themselves being stores in dbsarea.
+
+ AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attr)
+ {
+ int ndbs;
+ int i;
+ char *dbsname[100];
+ char dbsarea[10000];
+ AV *av = Nullav;
+
+ if (sqgetdbs(&ndbs, dbsname, 100, dbsarea, sizeof(dbsarea)) == 0)
+ {
+ av = NewAV();
+ av_extend(av, (I32)ndbs);
+ sv_2mortal((SV *)av);
+ for (i = 0; i < ndbs; i++)
+ av_store(av, i, newSVpvf("dbi:Informix:%s", dbsname[i]));
+ }
+ return(av);
+ }
+
+The actual B<DBD::Informix> implementation has a number of extra lines of
+code, logs function entry and exit, reports the error from C<sqgetdbs()>,
+and uses C<#define>'d constants for the array sizes.
+
+=head3 The dbd_db_login6 method
+
+ int dbd_db_login6_sv(SV* dbh, imp_dbh_t* imp_dbh, SV* dbname,
+ SV* user, SV* auth, SV *attr);
+
+ or
+
+ int dbd_db_login6(SV* dbh, imp_dbh_t* imp_dbh, char* dbname,
+ char* user, char* auth, SV *attr);
+
+This function will really connect to the database. The argument I<dbh>
+is the database handle. I<imp_dbh> is the pointer to the handles private
+data, as is I<imp_xxx> in C<dbd_drv_error()> above. The arguments
+I<dbname>, I<user>, I<auth> and I<attr> correspond to the arguments of
+the driver handle's C<connect()> method.
+
+You will quite often use database specific attributes here, that are
+specified in the DSN. I recommend you parse the DSN (using Perl) within
+the C<connect()> method and pass the segments of the DSN via the
+attributes parameter through C<_login()> to C<dbd_db_login6()>.
+
+Here's how you fetch them; as an example we use I<hostname> attribute,
+which can be up to 12 characters long excluding null terminator:
+
+ SV** svp;
+ STRLEN len;
+ char* hostname;
+
+ if ( (svp = DBD_ATTRIB_GET_SVP(attr, "drv_hostname", 12)) && SvTRUE(*svp)) {
+ hostname = SvPV(*svp, len);
+ DBD_ATTRIB_DELETE(attr, "drv_hostname", 12); /* avoid later STORE */
+ } else {
+ hostname = "localhost";
+ }
+
+If you handle any driver specific attributes in the dbd_db_login6
+method you probably want to delete them from C<attr> (as above with
+DBD_ATTRIB_DELETE). If you don't delete your handled attributes DBI
+will call C<STORE> for each attribute after the connect/login and this
+is at best redundant for attributes you have already processed.
+
+B<Note: Until revision 11605 (post DBI 1.607), there was a problem with
+DBD_ATTRIBUTE_DELETE so unless you require a DBI version after 1.607
+you need to replace each DBD_ATTRIBUTE_DELETE call with:>
+
+ hv_delete((HV*)SvRV(attr), key, key_len, G_DISCARD)
+
+Note that you can also obtain standard attributes such as I<AutoCommit> and
+I<ChopBlanks> from the attributes parameter, using C<DBD_ATTRIB_GET_IV> for
+integer attributes.
+
+If, for example, your database does not support transactions but
+I<AutoCommit> is set off (requesting transaction support), then you can
+emulate a 'failure to connect'.
+
+Now you should really connect to the database. In general, if the
+connection fails, it is best to ensure that all allocated resources are
+released so that the handle does not need to be destroyed separately. If
+you are successful (and possibly even if you fail but you have allocated
+some resources), you should use the following macros:
+
+ DBIc_IMPSET_on(imp_dbh);
+
+This indicates that the driver (implementor) has allocated resources in
+the I<imp_dbh> structure and that the implementors private C<dbd_db_destroy()>
+function should be called when the handle is destroyed.
+
+ DBIc_ACTIVE_on(imp_dbh);
+
+This indicates that the handle has an active connection to the server
+and that the C<dbd_db_disconnect()> function should be called before the
+handle is destroyed.
+
+Note that if you do need to fail, you should report errors via the I<drh>
+or I<imp_drh> rather than via I<dbh> or I<imp_dbh> because I<imp_dbh> will be
+destroyed by the failure, so errors recorded in that handle will not be
+visible to B<DBI>, and hence not the user either.
+
+Note too, that the function is passed I<dbh> and I<imp_dbh>, and there
+is a macro C<D_imp_drh_from_dbh> which can recover the I<imp_drh> from
+the I<imp_dbh>. However, there is no B<DBI> macro to provide you with the
+I<drh> given either the I<imp_dbh> or the I<dbh> or the I<imp_drh> (and
+there's no way to recover the I<dbh> given just the I<imp_dbh>).
+
+This suggests that, despite the above notes about C<dbd_drv_error()>
+taking an C<SV *>, it may be better to have two error routines, one
+taking I<imp_dbh> and one taking I<imp_drh> instead. With care, you can
+factor most of the formatting code out so that these are small routines
+calling a common error formatter. See the code in B<DBD::Informix>
+1.05.00 for more information.
+
+The C<dbd_db_login6()> function should return I<TRUE> for success,
+I<FALSE> otherwise.
+
+Drivers implemented long ago may define the five-argument function
+C<dbd_db_login()> instead of C<dbd_db_login6()>. The missing argument is
+the attributes. There are ways to work around the missing attributes,
+but they are ungainly; it is much better to use the 6-argument form.
+Even later drivers will use C<dbd_db_login6_sv()> which provides the
+dbname, username and password as SVs.
+
+=head3 The dbd_db_commit and dbd_db_rollback methods
+
+ int dbd_db_commit(SV *dbh, imp_dbh_t *imp_dbh);
+ int dbd_db_rollback(SV* dbh, imp_dbh_t* imp_dbh);
+
+These are used for commit and rollback. They should return I<TRUE> for
+success, I<FALSE> for error.
+
+The arguments I<dbh> and I<imp_dbh> are the same as for C<dbd_db_login6()>
+above; I will omit describing them in what follows, as they appear
+always.
+
+These functions should return I<TRUE> for success, I<FALSE> otherwise.
+
+=head3 The dbd_db_disconnect method
+
+This is your private part of the C<disconnect()> method. Any I<dbh> with
+the I<ACTIVE> flag on must be disconnected. (Note that you have to set
+it in C<dbd_db_connect()> above.)
+
+ int dbd_db_disconnect(SV* dbh, imp_dbh_t* imp_dbh);
+
+The database handle will return I<TRUE> for success, I<FALSE> otherwise.
+In any case it should do a:
+
+ DBIc_ACTIVE_off(imp_dbh);
+
+before returning so B<DBI> knows that C<dbd_db_disconnect()> was executed.
+
+Note that there's nothing to stop a I<dbh> being I<disconnected> while
+it still have active children. If your database API reacts badly to
+trying to use an I<sth> in this situation then you'll need to add code
+like this to all I<sth> methods:
+
+ if (!DBIc_ACTIVE(DBIc_PARENT_COM(imp_sth)))
+ return 0;
+
+Alternatively, you can add code to your driver to keep explicit track of
+the statement handles that exist for each database handle and arrange
+to destroy those handles before disconnecting from the database. There
+is code to do this in B<DBD::Informix>. Similar comments apply to the
+driver handle keeping track of all the database handles.
+
+Note that the code which destroys the subordinate handles should only
+release the associated database resources and mark the handles inactive;
+it does not attempt to free the actual handle structures.
+
+This function should return I<TRUE> for success, I<FALSE> otherwise, but
+it is not clear what anything can do about a failure.
+
+=head3 The dbd_db_discon_all method
+
+ int dbd_discon_all (SV *drh, imp_drh_t *imp_drh);
+
+This function may be called at shutdown time. It should make
+best-efforts to disconnect all database handles - if possible. Some
+databases don't support that, in which case you can do nothing
+but return 'success'.
+
+This function should return I<TRUE> for success, I<FALSE> otherwise, but
+it is not clear what anything can do about a failure.
+
+=head3 The dbd_db_destroy method
+
+This is your private part of the database handle destructor. Any I<dbh> with
+the I<IMPSET> flag on must be destroyed, so that you can safely free
+resources. (Note that you have to set it in C<dbd_db_connect()> above.)
+
+ void dbd_db_destroy(SV* dbh, imp_dbh_t* imp_dbh)
+ {
+ DBIc_IMPSET_off(imp_dbh);
+ }
+
+The B<DBI> F<Driver.xst> code will have called C<dbd_db_disconnect()> for you,
+if the handle is still 'active', before calling C<dbd_db_destroy()>.
+
+Before returning the function must switch I<IMPSET> to off, so B<DBI> knows
+that the destructor was called.
+
+A B<DBI> handle doesn't keep references to its children. But children
+do keep references to their parents. So a database handle won't be
+C<DESTROY>'d until all its children have been C<DESTROY>'d.
+
+=head3 The dbd_db_STORE_attrib method
+
+This function handles
+
+ $dbh->{$key} = $value;
+
+Its prototype is:
+
+ int dbd_db_STORE_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv,
+ SV* valuesv);
+
+You do not handle all attributes; on the contrary, you should not handle
+B<DBI> attributes here: leave this to B<DBI>. (There are two exceptions,
+I<AutoCommit> and I<ChopBlanks>, which you should care about.)
+
+The return value is I<TRUE> if you have handled the attribute or I<FALSE>
+otherwise. If you are handling an attribute and something fails, you
+should call C<dbd_drv_error()>, so B<DBI> can raise exceptions, if desired.
+If C<dbd_drv_error()> returns, however, you have a problem: the user will
+never know about the error, because he typically will not check
+C<$dbh-E<gt>errstr()>.
+
+I cannot recommend a general way of going on, if C<dbd_drv_error()> returns,
+but there are examples where even the B<DBI> specification expects that
+you C<croak()>. (See the I<AutoCommit> method in L<DBI>.)
+
+If you have to store attributes, you should either use your private
+data structure I<imp_xxx>, the handle hash (via C<(HV*)SvRV(dbh)>), or use
+the private I<imp_data>.
+
+The first is best for internal C values like integers or pointers and
+where speed is important within the driver. The handle hash is best for
+values the user may want to get/set via driver-specific attributes.
+The private I<imp_data> is an additional C<SV> attached to the handle. You
+could think of it as an unnamed handle attribute. It's not normally used.
+
+=head3 The dbd_db_FETCH_attrib method
+
+This is the counterpart of C<dbd_db_STORE_attrib()>, needed for:
+
+ $value = $dbh->{$key};
+
+Its prototype is:
+
+ SV* dbd_db_FETCH_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv);
+
+Unlike all previous methods this returns an C<SV> with the value. Note
+that you should normally execute C<sv_2mortal()>, if you return a nonconstant
+value. (Constant values are C<&sv_undef>, C<&sv_no> and C<&sv_yes>.)
+
+Note, that B<DBI> implements a caching algorithm for attribute values.
+If you think, that an attribute may be fetched, you store it in the
+I<dbh> itself:
+
+ if (cacheit) /* cache value for later DBI 'quick' fetch? */
+ hv_store((HV*)SvRV(dbh), key, kl, cachesv, 0);
+
+=head3 The dbd_st_prepare method
+
+This is the private part of the C<prepare()> method. Note that you
+B<must not> really execute the statement here. You may, however,
+preparse and validate the statement, or do similar things.
+
+ int dbd_st_prepare(SV* sth, imp_sth_t* imp_sth, char* statement,
+ SV* attribs);
+
+A typical, simple, possibility is to do nothing and rely on the perl
+C<prepare()> code that set the I<Statement> attribute on the handle. This
+attribute can then be used by C<dbd_st_execute()>.
+
+If the driver supports placeholders then the I<NUM_OF_PARAMS> attribute
+must be set correctly by C<dbd_st_prepare()>:
+
+ DBIc_NUM_PARAMS(imp_sth) = ...
+
+If you can, you should also setup attributes like I<NUM_OF_FIELDS>, I<NAME>,
+etc. here, but B<DBI> doesn't require that - they can be deferred until
+execute() is called. However, if you do, document it.
+
+In any case you should set the I<IMPSET> flag, as you did in
+C<dbd_db_connect()> above:
+
+ DBIc_IMPSET_on(imp_sth);
+
+=head3 The dbd_st_execute method
+
+This is where a statement will really be executed.
+
+ int dbd_st_execute(SV* sth, imp_sth_t* imp_sth);
+
+Note that you must be aware a statement may be executed repeatedly.
+Also, you should not expect that C<finish()> will be called between two
+executions, so you might need code, like the following, near the start
+of the function:
+
+ if (DBIc_ACTIVE(imp_sth))
+ dbd_st_finish(h, imp_sth);
+
+If your driver supports the binding of parameters (it should!), but the
+database doesn't, you must do it here. This can be done as follows:
+
+ SV *svp;
+ char* statement = DBD_ATTRIB_GET_PV(h, "Statement", 9, svp, "");
+ int numParam = DBIc_NUM_PARAMS(imp_sth);
+ int i;
+
+ for (i = 0; i < numParam; i++)
+ {
+ char* value = dbd_db_get_param(sth, imp_sth, i);
+ /* It is your drivers task to implement dbd_db_get_param, */
+ /* it must be setup as a counterpart of dbd_bind_ph. */
+ /* Look for '?' and replace it with 'value'. Difficult */
+ /* task, note that you may have question marks inside */
+ /* quotes and comments the like ... :-( */
+ /* See DBD::mysql for an example. (Don't look too deep into */
+ /* the example, you will notice where I was lazy ...) */
+ }
+
+The next thing is to really execute the statement.
+
+Note that you must set the attributes I<NUM_OF_FIELDS>, I<NAME>, etc
+when the statement is successfully executed if the driver has not
+already done so: they may be used even before a potential C<fetchrow()>.
+In particular you have to tell B<DBI> the number of fields that the
+statement has, because it will be used by B<DBI> internally. Thus the
+function will typically ends with:
+
+ if (isSelectStatement) {
+ DBIc_NUM_FIELDS(imp_sth) = numFields;
+ DBIc_ACTIVE_on(imp_sth);
+ }
+
+It is important that the I<ACTIVE> flag only be set for C<SELECT>
+statements (or any other statements that can return many
+values from the database using a cursor-like mechanism). See
+C<dbd_db_connect()> above for more explanations.
+
+There plans for a preparse function to be provided by B<DBI>, but this has
+not reached fruition yet.
+Meantime, if you want to know how ugly it can get, try looking at the
+C<dbd_ix_preparse()> in B<DBD::Informix> F<dbdimp.ec> and the related
+functions in F<iustoken.c> and F<sqltoken.c>.
+
+=head3 The dbd_st_fetch method
+
+This function fetches a row of data. The row is stored in in an array,
+of C<SV>'s that B<DBI> prepares for you. This has two advantages: it is fast
+(you even reuse the C<SV>'s, so they don't have to be created after the
+first C<fetchrow()>), and it guarantees that B<DBI> handles C<bind_cols()> for
+you.
+
+What you do is the following:
+
+ AV* av;
+ int numFields = DBIc_NUM_FIELDS(imp_sth); /* Correct, if NUM_FIELDS
+ is constant for this statement. There are drivers where this is
+ not the case! */
+ int chopBlanks = DBIc_is(imp_sth, DBIcf_ChopBlanks);
+ int i;
+
+ if (!fetch_new_row_of_data(...)) {
+ ... /* check for error or end-of-data */
+ DBIc_ACTIVE_off(imp_sth); /* turn off Active flag automatically */
+ return Nullav;
+ }
+ /* get the fbav (field buffer array value) for this row */
+ /* it is very important to only call this after you know */
+ /* that you have a row of data to return. */
+ av = DBIc_DBISTATE(imp_sth)->get_fbav(imp_sth);
+ for (i = 0; i < numFields; i++) {
+ SV* sv = fetch_a_field(..., i);
+ if (chopBlanks && SvOK(sv) && type_is_blank_padded(field_type[i])) {
+ /* Remove white space from end (only) of sv */
+ }
+ sv_setsv(AvARRAY(av)[i], sv); /* Note: (re)use! */
+ }
+ return av;
+
+There's no need to use a C<fetch_a_field()> function returning an C<SV*>.
+It's more common to use your database API functions to fetch the
+data as character strings and use code like this:
+
+ sv_setpvn(AvARRAY(av)[i], char_ptr, char_count);
+
+C<NULL> values must be returned as C<undef>. You can use code like this:
+
+ SvOK_off(AvARRAY(av)[i]);
+
+The function returns the C<AV> prepared by B<DBI> for success or C<Nullav>
+otherwise.
+
+ *FIX ME* Discuss what happens when there's no more data to fetch.
+ Are errors permitted if another fetch occurs after the first fetch
+ that reports no more data. (Permitted, not required.)
+
+If an error occurs which leaves the I<$sth> in a state where remaining
+rows can't be fetched then I<Active> should be turned off before the
+method returns.
+
+=head3 The dbd_st_finish3 method
+
+The C<$sth-E<gt>finish()> method can be called if the user wishes to
+indicate that no more rows will be fetched even if the database has more
+rows to offer, and the B<DBI> code can call the function when handles are
+being destroyed. See the B<DBI> specification for more background details.
+
+In both circumstances, the B<DBI> code ends up calling the
+C<dbd_st_finish3()> method (if you provide a mapping for
+C<dbd_st_finish3()> in F<dbdimp.h>), or C<dbd_st_finish()> otherwise.
+The difference is that C<dbd_st_finish3()> takes a third argument which
+is an C<int> with the value 1 if it is being called from a C<destroy()>
+method and 0 otherwise.
+
+Note that B<DBI> v1.32 and earlier test on C<dbd_db_finish3()> to call
+C<dbd_st_finish3()>; if you provide C<dbd_st_finish3()>, either define
+C<dbd_db_finish3()> too, or insist on B<DBI> v1.33 or later.
+
+All it I<needs> to do is turn off the I<Active> flag for the I<sth>.
+It will only be called by F<Driver.xst> code, if the driver has set I<ACTIVE>
+to on for the I<sth>.
+
+Outline example:
+
+ int dbd_st_finish3(SV* sth, imp_sth_t* imp_sth, int from_destroy) {
+ if (DBIc_ACTIVE(imp_sth))
+ {
+ /* close cursor or equivalent action */
+ DBIc_ACTIVE_off(imp_sth);
+ }
+ return 1;
+ }
+
+The from_destroy parameter is true if C<dbd_st_finish3()> is being called
+from C<DESTROY()> - and so the statement is about to be destroyed.
+For many drivers there is no point in doing anything more than turning off
+the I<Active> flag in this case.
+
+The function returns I<TRUE> for success, I<FALSE> otherwise, but there isn't
+a lot anyone can do to recover if there is an error.
+
+=head3 The dbd_st_destroy method
+
+This function is the private part of the statement handle destructor.
+
+ void dbd_st_destroy(SV* sth, imp_sth_t* imp_sth) {
+ ... /* any clean-up that's needed */
+ DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
+ }
+
+The B<DBI> F<Driver.xst> code will call C<dbd_st_finish()> for you, if the
+I<sth> has the I<ACTIVE> flag set, before calling C<dbd_st_destroy()>.
+
+=head3 The dbd_st_STORE_attrib and dbd_st_FETCH_attrib methods
+
+These functions correspond to C<dbd_db_STORE()> and C<dbd_db_FETCH()> attrib
+above, except that they are for statement handles.
+See above.
+
+ int dbd_st_STORE_attrib(SV* sth, imp_sth_t* imp_sth, SV* keysv,
+ SV* valuesv);
+ SV* dbd_st_FETCH_attrib(SV* sth, imp_sth_t* imp_sth, SV* keysv);
+
+=head3 The dbd_bind_ph method
+
+This function is internally used by the C<bind_param()> method, the
+C<bind_param_inout()> method and by the B<DBI> F<Driver.xst> code if
+C<execute()> is called with any bind parameters.
+
+ int dbd_bind_ph (SV *sth, imp_sth_t *imp_sth, SV *param,
+ SV *value, IV sql_type, SV *attribs,
+ int is_inout, IV maxlen);
+
+The I<param> argument holds an C<IV> with the parameter number (1, 2, ...).
+The I<value> argument is the parameter value and I<sql_type> is its type.
+
+If your driver does not support C<bind_param_inout()> then you should
+ignore I<maxlen> and croak if I<is_inout> is I<TRUE>.
+
+If your driver I<does> support C<bind_param_inout()> then you should
+note that I<value> is the C<SV> I<after> dereferencing the reference
+passed to C<bind_param_inout()>.
+
+In drivers of simple databases the function will, for example, store
+the value in a parameter array and use it later in C<dbd_st_execute()>.
+See the B<DBD::mysql> driver for an example.
+
+=head3 Implementing bind_param_inout support
+
+To provide support for parameters bound by reference rather than by
+value, the driver must do a number of things. First, and most
+importantly, it must note the references and stash them in its own
+driver structure. Secondly, when a value is bound to a column, the
+driver must discard any previous reference bound to the column. On
+each execute, the driver must evaluate the references and internally
+bind the values resulting from the references. This is only applicable
+if the user writes:
+
+ $sth->execute;
+
+If the user writes:
+
+ $sth->execute(@values);
+
+then B<DBI> automatically calls the binding code for each element of
+I<@values>. These calls are indistinguishable from explicit user calls to
+C<bind_param()>.
+
+=head2 C/XS version of Makefile.PL
+
+The F<Makefile.PL> file for a C/XS driver is similar to the code needed
+for a pure Perl driver, but there are a number of extra bits of
+information needed by the build system.
+
+For example, the attributes list passed to C<WriteMakefile()> needs
+to specify the object files that need to be compiled and built into
+the shared object (DLL). This is often, but not necessarily, just
+F<dbdimp.o> (unless that should be F<dbdimp.obj> because you're building
+on MS Windows).
+
+Note that you can reliably determine the extension of the object files
+from the I<$Config{obj_ext}> values, and there are many other useful pieces
+of configuration information lurking in that hash.
+You get access to it with:
+
+ use Config;
+
+=head2 Methods which do not need to be written
+
+The B<DBI> code implements the majority of the methods which are accessed
+using the notation C<DBI-E<gt>function()>, the only exceptions being
+C<DBI-E<gt>connect()> and C<DBI-E<gt>data_sources()> which require
+support from the driver.
+
+The B<DBI> code implements the following documented driver, database and
+statement functions which do not need to be written by the B<DBD> driver
+writer.
+
+=over 4
+
+=item $dbh->do()
+
+The default implementation of this function prepares, executes and
+destroys the statement. This can be replaced if there is a better
+way to implement this, such as C<EXECUTE IMMEDIATE> which can
+sometimes be used if there are no parameters.
+
+=item $h->errstr()
+
+=item $h->err()
+
+=item $h->state()
+
+=item $h->trace()
+
+The B<DBD> driver does not need to worry about these routines at all.
+
+=item $h->{ChopBlanks}
+
+This attribute needs to be honored during C<fetch()> operations, but does
+not need to be handled by the attribute handling code.
+
+=item $h->{RaiseError}
+
+The B<DBD> driver does not need to worry about this attribute at all.
+
+=item $h->{PrintError}
+
+The B<DBD> driver does not need to worry about this attribute at all.
+
+=item $sth->bind_col()
+
+Assuming the driver uses the C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()>
+function (C drivers, see below), or the C<$sth-E<gt>_set_fbav($data)>
+method (Perl drivers) the driver does not need to do anything about this
+routine.
+
+=item $sth->bind_columns()
+
+Regardless of whether the driver uses
+C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()>, the driver does not need
+to do anything about this routine as it simply iteratively calls
+C<$sth-E<gt>bind_col()>.
+
+=back
+
+The B<DBI> code implements a default implementation of the following
+functions which do not need to be written by the B<DBD> driver writer
+unless the default implementation is incorrect for the Driver.
+
+=over 4
+
+=item $dbh->quote()
+
+This should only be written if the database does not accept the ANSI
+SQL standard for quoting strings, with the string enclosed in single
+quotes and any embedded single quotes replaced by two consecutive
+single quotes.
+
+For the two argument form of quote, you need to implement the
+C<type_info()> method to provide the information that quote needs.
+
+=item $dbh->ping()
+
+This should be implemented as a simple efficient way to determine
+whether the connection to the database is still alive. Typically
+code like this:
+
+ sub ping {
+ my $dbh = shift;
+ $sth = $dbh->prepare_cached(q{
+ select * from A_TABLE_NAME where 1=0
+ }) or return 0;
+ $sth->execute or return 0;
+ $sth->finish;
+ return 1;
+ }
+
+where I<A_TABLE_NAME> is the name of a table that always exists (such as a
+database system catalogue).
+
+=back
+
+=head1 METADATA METHODS
+
+The exposition above ignores the B<DBI> MetaData methods.
+The metadata methods are all associated with a database handle.
+
+=head2 Using DBI::DBD::Metadata
+
+The B<DBI::DBD::Metadata> module is a good semi-automatic way for the
+developer of a B<DBD> module to write the C<get_info()> and C<type_info()>
+functions quickly and accurately.
+
+=head3 Generating the get_info method
+
+Prior to B<DBI> v1.33, this existed as the method C<write_getinfo_pm()>
+in the B<DBI::DBD> module. From B<DBI> v1.33, it exists as the method
+C<write_getinfo_pm()> in the B<DBI::DBD::Metadata> module. This
+discussion assumes you have B<DBI> v1.33 or later.
+
+You examine the documentation for C<write_getinfo_pm()> using:
+
+ perldoc DBI::DBD::Metadata
+
+To use it, you need a Perl B<DBI> driver for your database which implements
+the C<get_info()> method. In practice, this means you need to install
+B<DBD::ODBC>, an ODBC driver manager, and an ODBC driver for your
+database.
+
+With the pre-requisites in place, you might type:
+
+ perl -MDBI::DBD::Metadata -we \
+ "write_getinfo_pm (qw{ dbi:ODBC:foo_db username password Driver })"
+
+The procedure writes to standard output the code that should be added to
+your F<Driver.pm> file and the code that should be written to
+F<lib/DBD/Driver/GetInfo.pm>.
+
+You should review the output to ensure that it is sensible.
+
+=head3 Generating the type_info method
+
+Given the idea of the C<write_getinfo_pm()> method, it was not hard
+to devise a parallel method, C<write_typeinfo_pm()>, which does the
+analogous job for the B<DBI> C<type_info_all()> metadata method. The
+C<write_typeinfo_pm()> method was added to B<DBI> v1.33.
+
+You examine the documentation for C<write_typeinfo_pm()> using:
+
+ perldoc DBI::DBD::Metadata
+
+The setup is exactly analogous to the mechanism described in
+L</Generating the get_info method>.
+
+With the pre-requisites in place, you might type:
+
+ perl -MDBI::DBD::Metadata -we \
+ "write_typeinfo (qw{ dbi:ODBC:foo_db username password Driver })"
+
+The procedure writes to standard output the code that should be added to
+your F<Driver.pm> file and the code that should be written to
+F<lib/DBD/Driver/TypeInfo.pm>.
+
+You should review the output to ensure that it is sensible.
+
+=head2 Writing DBD::Driver::db::get_info
+
+If you use the B<DBI::DBD::Metadata> module, then the code you need is
+generated for you.
+
+If you decide not to use the B<DBI::DBD::Metadata> module, you
+should probably borrow the code from a driver that has done so (eg
+B<DBD::Informix> from version 1.05 onwards) and crib the code from
+there, or look at the code that generates that module and follow
+that. The method in F<Driver.pm> will be very simple; the method in
+F<lib/DBD/Driver/GetInfo.pm> is not very much more complex unless your
+DBMS itself is much more complex.
+
+Note that some of the B<DBI> utility methods rely on information from the
+C<get_info()> method to perform their operations correctly. See, for
+example, the C<quote_identifier()> and quote methods, discussed below.
+
+=head2 Writing DBD::Driver::db::type_info_all
+
+If you use the C<DBI::DBD::Metadata> module, then the code you need is
+generated for you.
+
+If you decide not to use the C<DBI::DBD::Metadata> module, you
+should probably borrow the code from a driver that has done so (eg
+C<DBD::Informix> from version 1.05 onwards) and crib the code from
+there, or look at the code that generates that module and follow
+that. The method in F<Driver.pm> will be very simple; the method in
+F<lib/DBD/Driver/TypeInfo.pm> is not very much more complex unless your
+DBMS itself is much more complex.
+
+=head2 Writing DBD::Driver::db::type_info
+
+The guidelines on writing this method are still not really clear.
+No sample implementation is available.
+
+=head2 Writing DBD::Driver::db::table_info
+
+ *FIX ME* The guidelines on writing this method have not been written yet.
+ No sample implementation is available.
+
+=head2 Writing DBD::Driver::db::column_info
+
+ *FIX ME* The guidelines on writing this method have not been written yet.
+ No sample implementation is available.
+
+=head2 Writing DBD::Driver::db::primary_key_info
+
+ *FIX ME* The guidelines on writing this method have not been written yet.
+ No sample implementation is available.
+
+=head2 Writing DBD::Driver::db::primary_key
+
+ *FIX ME* The guidelines on writing this method have not been written yet.
+ No sample implementation is available.
+
+=head2 Writing DBD::Driver::db::foreign_key_info
+
+ *FIX ME* The guidelines on writing this method have not been written yet.
+ No sample implementation is available.
+
+=head2 Writing DBD::Driver::db::tables
+
+This method generates an array of names in a format suitable for being
+embedded in SQL statements in places where a table name is expected.
+
+If your database hews close enough to the SQL standard or if you have
+implemented an appropriate C<table_info()> function and and the appropriate
+C<quote_identifier()> function, then the B<DBI> default version of this method
+will work for your driver too.
+
+Otherwise, you have to write a function yourself, such as:
+
+ sub tables
+ {
+ my($dbh, $cat, $sch, $tab, $typ) = @_;
+ my(@res);
+ my($sth) = $dbh->table_info($cat, $sch, $tab, $typ);
+ my(@arr);
+ while (@arr = $sth->fetchrow_array)
+ {
+ push @res, $dbh->quote_identifier($arr[0], $arr[1], $arr[2]);
+ }
+ return @res;
+ }
+
+See also the default implementation in F<DBI.pm>.
+
+=head2 Writing DBD::Driver::db::quote
+
+This method takes a value and converts it into a string suitable for
+embedding in an SQL statement as a string literal.
+
+If your DBMS accepts the SQL standard notation for strings (single
+quotes around the string as a whole with any embedded single quotes
+doubled up), then you do not need to write this method as B<DBI> provides a
+default method that does it for you.
+
+If your DBMS uses an alternative notation or escape mechanism, then you
+need to provide an equivalent function. For example, suppose your DBMS
+used C notation with double quotes around the string and backslashes
+escaping both double quotes and backslashes themselves. Then you might
+write the function as:
+
+ sub quote
+ {
+ my($dbh, $str) = @_;
+ $str =~ s/["\\]/\\$&/gmo;
+ return qq{"$str"};
+ }
+
+Handling newlines and other control characters is left as an exercise
+for the reader.
+
+This sample method ignores the I<$data_type> indicator which is the
+optional second argument to the method.
+
+=head2 Writing DBD::Driver::db::quote_identifier
+
+This method is called to ensure that the name of the given table (or
+other database object) can be embedded into an SQL statement without
+danger of misinterpretation. The result string should be usable in the
+text of an SQL statement as the identifier for a table.
+
+If your DBMS accepts the SQL standard notation for quoted identifiers
+(which uses double quotes around the identifier as a whole, with any
+embedded double quotes doubled up) and accepts I<"schema"."identifier">
+(and I<"catalog"."schema"."identifier"> when a catalog is specified), then
+you do not need to write this method as B<DBI> provides a default method
+that does it for you.
+
+In fact, even if your DBMS does not handle exactly that notation but
+you have implemented the C<get_info()> method and it gives the correct
+responses, then it will work for you. If your database is fussier, then
+you need to implement your own version of the function.
+
+For example, B<DBD::Informix> has to deal with an environment variable
+I<DELIMIDENT>. If it is not set, then the DBMS treats names enclosed in
+double quotes as strings rather than names, which is usually a syntax
+error. Additionally, the catalog portion of the name is separated from
+the schema and table by a different delimiter (colon instead of dot),
+and the catalog portion is never enclosed in quotes. (Fortunately,
+valid strings for the catalog will never contain weird characters that
+might need to be escaped, unless you count dots, dashes, slashes and
+at-signs as weird.) Finally, an Informix database can contain objects
+that cannot be accessed because they were created by a user with the
+I<DELIMIDENT> environment variable set, but the current user does not
+have it set. By design choice, the C<quote_identifier()> method encloses
+those identifiers in double quotes anyway, which generally triggers a
+syntax error, and the metadata methods which generate lists of tables
+etc omit those identifiers from the result sets.
+
+ sub quote_identifier
+ {
+ my($dbh, $cat, $sch, $obj) = @_;
+ my($rv) = "";
+ my($qq) = (defined $ENV{DELIMIDENT}) ? '"' : '';
+ $rv .= qq{$cat:} if (defined $cat);
+ if (defined $sch)
+ {
+ if ($sch !~ m/^\w+$/o)
+ {
+ $qq = '"';
+ $sch =~ s/$qq/$qq$qq/gm;
+ }
+ $rv .= qq{$qq$sch$qq.};
+ }
+ if (defined $obj)
+ {
+ if ($obj !~ m/^\w+$/o)
+ {
+ $qq = '"';
+ $obj =~ s/$qq/$qq$qq/gm;
+ }
+ $rv .= qq{$qq$obj$qq};
+ }
+ return $rv;
+ }
+
+Handling newlines and other control characters is left as an exercise
+for the reader.
+
+Note that there is an optional fourth parameter to this function which
+is a reference to a hash of attributes; this sample implementation
+ignores that.
+
+This sample implementation also ignores the single-argument variant of
+the method.
+
+=head1 TRACING
+
+Tracing in DBI is controlled with a combination of a trace level and a
+set of flags which together are known as the trace settings. The trace
+settings are stored in a single integer and divided into levels and
+flags by a set of masks (C<DBIc_TRACE_LEVEL_MASK> and
+C<DBIc_TRACE_FLAGS_MASK>).
+
+Each handle has it's own trace settings and so does the DBI. When you
+call a method the DBI merges the handles settings into its own for the
+duration of the call: the trace flags of the handle are OR'd into the
+trace flags of the DBI, and if the handle has a higher trace level
+then the DBI trace level is raised to match it. The previous DBI trace
+setings are restored when the called method returns.
+
+=head2 Trace Level
+
+The trace level is the first 4 bits of the trace settings (masked by
+C<DBIc_TRACE_FLAGS_MASK>) and represents trace levels of 1 to 15. Do
+not output anything at trace levels less than 3 as they are reserved
+for DBI.
+
+For advice on what to output at each level see "Trace Levels" in
+L<DBI>.
+
+To test for a trace level you can use the C<DBIc_TRACE_LEVEL> macro
+like this:
+
+ if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) {
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar");
+ }
+
+Also B<note> the use of PerlIO_printf which you should always use for
+tracing and never the C C<stdio.h> I/O functions.
+
+=head2 Trace Flags
+
+Trace flags are used to enable tracing of specific activities within
+the DBI and drivers. The DBI defines some trace flags and drivers can
+define others. DBI trace flag names begin with a capital letter and
+driver specific names begin with a lowercase letter. For a list of DBI
+defined trace flags see "Trace Flags" in L<DBI>.
+
+If you want to use private trace flags you'll probably want to be able
+to set them by name. Drivers are expected to override the
+parse_trace_flag (note the singular) and check if $trace_flag_name is
+a driver specific trace flags and, if not, then call the DBIs default
+parse_trace_flag(). To do that you'll need to define a
+parse_trace_flag() method like this:
+
+ sub parse_trace_flag {
+ my ($h, $name) = @_;
+ return 0x01000000 if $name eq 'foo';
+ return 0x02000000 if $name eq 'bar';
+ return 0x04000000 if $name eq 'baz';
+ return 0x08000000 if $name eq 'boo';
+ return 0x10000000 if $name eq 'bop';
+ return $h->SUPER::parse_trace_flag($name);
+ }
+
+All private flag names must be lowercase, and all private flags must
+be in the top 8 of the 32 bits of C<DBIc_TRACE_FLAGS(imp)> i.e.,
+0xFF000000.
+
+If you've defined a parse_trace_flag() method in ::db you'll also want
+it in ::st, so just alias it in:
+
+ *parse_trace_flag = \&DBD::foo:db::parse_trace_flag;
+
+You may want to act on the current 'SQL' trace flag that DBI defines
+to output SQL prepared/executed as DBI currently does not do SQL
+tracing.
+
+=head2 Trace Macros
+
+Access to the trace level and trace flags is via a set of macros.
+
+ DBIc_TRACE_SETTINGS(imp) returns the trace settings
+ DBIc_TRACE_LEVEL(imp) returns the trace level
+ DBIc_TRACE_FLAGS(imp) returns the trace flags
+ DBIc_TRACE(imp, flags, flaglevel, level)
+
+ e.g.,
+
+ DBIc_TRACE(imp, 0, 0, 4)
+ if level >= 4
+
+ DBIc_TRACE(imp, DBDtf_FOO, 2, 4)
+ if tracing DBDtf_FOO & level>=2 or level>=4
+
+ DBIc_TRACE(imp, DBDtf_FOO, 2, 0)
+ as above but never trace just due to level
+
+=head1 WRITING AN EMULATION LAYER FOR AN OLD PERL INTERFACE
+
+Study F<Oraperl.pm> (supplied with B<DBD::Oracle>) and F<Ingperl.pm> (supplied
+with B<DBD::Ingres>) and the corresponding I<dbdimp.c> files for ideas.
+
+Note that the emulation code sets C<$dbh-E<gt>{CompatMode} = 1;> for each
+connection so that the internals of the driver can implement behaviour
+compatible with the old interface when dealing with those handles.
+
+=head2 Setting emulation perl variables
+
+For example, ingperl has a I<$sql_rowcount> variable. Rather than try
+to manually update this in F<Ingperl.pm> it can be done faster in C code.
+In C<dbd_init()>:
+
+ sql_rowcount = perl_get_sv("Ingperl::sql_rowcount", GV_ADDMULTI);
+
+In the relevant places do:
+
+ if (DBIc_COMPAT(imp_sth)) /* only do this for compatibility mode handles */
+ sv_setiv(sql_rowcount, the_row_count);
+
+=head1 OTHER MISCELLANEOUS INFORMATION
+
+=head2 The imp_xyz_t types
+
+Any handle has a corresponding C structure filled with private data.
+Some of this data is reserved for use by B<DBI> (except for using the
+DBIc macros below), some is for you. See the description of the
+F<dbdimp.h> file above for examples. Most functions in F<dbdimp.c>
+are passed both the handle C<xyz> and a pointer to C<imp_xyz>. In
+rare cases, however, you may use the following macros:
+
+=over 4
+
+=item D_imp_dbh(dbh)
+
+Given a function argument I<dbh>, declare a variable I<imp_dbh> and
+initialize it with a pointer to the handles private data. Note: This
+must be a part of the function header, because it declares a variable.
+
+=item D_imp_sth(sth)
+
+Likewise for statement handles.
+
+=item D_imp_xxx(h)
+
+Given any handle, declare a variable I<imp_xxx> and initialize it
+with a pointer to the handles private data. It is safe, for example,
+to cast I<imp_xxx> to C<imp_dbh_t*>, if C<DBIc_TYPE(imp_xxx) == DBIt_DB>.
+(You can also call C<sv_derived_from(h, "DBI::db")>, but that's much
+slower.)
+
+=item D_imp_dbh_from_sth
+
+Given a I<imp_sth>, declare a variable I<imp_dbh> and initialize it with a
+pointer to the parent database handle's implementors structure.
+
+=back
+
+=head2 Using DBIc_IMPSET_on
+
+The driver code which initializes a handle should use C<DBIc_IMPSET_on()>
+as soon as its state is such that the cleanup code must be called.
+When this happens is determined by your driver code.
+
+B<Failure to call this can lead to corruption of data structures.>
+
+For example, B<DBD::Informix> maintains a linked list of database
+handles in the driver, and within each handle, a linked list of
+statements. Once a statement is added to the linked list, it is crucial
+that it is cleaned up (removed from the list). When I<DBIc_IMPSET_on()>
+was being called too late, it was able to cause all sorts of problems.
+
+=head2 Using DBIc_is(), DBIc_has(), DBIc_on() and DBIc_off()
+
+Once upon a long time ago, the only way of handling the internal B<DBI>
+boolean flags/attributes was through macros such as:
+
+ DBIc_WARN DBIc_WARN_on DBIc_WARN_off
+ DBIc_COMPAT DBIc_COMPAT_on DBIc_COMPAT_off
+
+Each of these took an I<imp_xxh> pointer as an argument.
+
+Since then, new attributes have been added such as I<ChopBlanks>,
+I<RaiseError> and I<PrintError>, and these do not have the full set of
+macros. The approved method for handling these is now the four macros:
+
+ DBIc_is(imp, flag)
+ DBIc_has(imp, flag) an alias for DBIc_is
+ DBIc_on(imp, flag)
+ DBIc_off(imp, flag)
+ DBIc_set(imp, flag, on) set if on is true, else clear
+
+Consequently, the C<DBIc_XXXXX> family of macros is now mostly deprecated
+and new drivers should avoid using them, even though the older drivers
+will probably continue to do so for quite a while yet. However...
+
+There is an I<important exception> to that. The I<ACTIVE> and I<IMPSET>
+flags should be set via the C<DBIc_ACTIVE_on()> and C<DBIc_IMPSET_on()> macros,
+and unset via the C<DBIc_ACTIVE_off()> and C<DBIc_IMPSET_off()> macros.
+
+=head2 Using the get_fbav() method
+
+B<THIS IS CRITICAL for C/XS drivers>.
+
+The C<$sth-E<gt>bind_col()> and C<$sth-E<gt>bind_columns()> documented
+in the B<DBI> specification do not have to be implemented by the driver
+writer because B<DBI> takes care of the details for you.
+
+However, the key to ensuring that bound columns work is to call the
+function C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()> in the code which
+fetches a row of data.
+
+This returns an C<AV>, and each element of the C<AV> contains the C<SV> which
+should be set to contain the returned data.
+
+The pure Perl equivalent is the C<$sth-E<gt>_set_fbav($data)> method, as
+described in the part on pure Perl drivers.
+
+=head1 SUBCLASSING DBI DRIVERS
+
+This is definitely an open subject. It can be done, as demonstrated by
+the B<DBD::File> driver, but it is not as simple as one might think.
+
+(Note that this topic is different from subclassing the B<DBI>. For an
+example of that, see the F<t/subclass.t> file supplied with the B<DBI>.)
+
+The main problem is that the I<dbh>'s and I<sth>'s that your C<connect()> and
+C<prepare()> methods return are not instances of your B<DBD::Driver::db>
+or B<DBD::Driver::st> packages, they are not even derived from it.
+Instead they are instances of the B<DBI::db> or B<DBI::st> classes or
+a derived subclass. Thus, if you write a method C<mymethod()> and do a
+
+ $dbh->mymethod()
+
+then the autoloader will search for that method in the package B<DBI::db>.
+Of course you can instead to a
+
+ $dbh->func('mymethod')
+
+and that will indeed work, even if C<mymethod()> is inherited, but not
+without additional work. Setting I<@ISA> is not sufficient.
+
+=head2 Overwriting methods
+
+The first problem is, that the C<connect()> method has no idea of
+subclasses. For example, you cannot implement base class and subclass
+in the same file: The C<install_driver()> method wants to do a
+
+ require DBD::Driver;
+
+In particular, your subclass B<has> to be a separate driver, from
+the view of B<DBI>, and you cannot share driver handles.
+
+Of course that's not much of a problem. You should even be able
+to inherit the base classes C<connect()> method. But you cannot
+simply overwrite the method, unless you do something like this,
+quoted from B<DBD::CSV>:
+
+ sub connect ($$;$$$) {
+ my ($drh, $dbname, $user, $auth, $attr) = @_;
+
+ my $this = $drh->DBD::File::dr::connect($dbname, $user, $auth, $attr);
+ if (!exists($this->{csv_tables})) {
+ $this->{csv_tables} = {};
+ }
+
+ $this;
+ }
+
+Note that we cannot do a
+
+ $drh->SUPER::connect($dbname, $user, $auth, $attr);
+
+as we would usually do in a an OO environment, because I<$drh> is an instance
+of B<DBI::dr>. And note, that the C<connect()> method of B<DBD::File> is
+able to handle subclass attributes. See the description of Pure Perl
+drivers above.
+
+It is essential that you always call superclass method in the above
+manner. However, that should do.
+
+=head2 Attribute handling
+
+Fortunately the B<DBI> specifications allow a simple, but still
+performant way of handling attributes. The idea is based on the
+convention that any driver uses a prefix I<driver_> for its private
+methods. Thus it's always clear whether to pass attributes to the super
+class or not. For example, consider this C<STORE()> method from the
+B<DBD::CSV> class:
+
+ sub STORE {
+ my ($dbh, $attr, $val) = @_;
+ if ($attr !~ /^driver_/) {
+ return $dbh->DBD::File::db::STORE($attr, $val);
+ }
+ if ($attr eq 'driver_foo') {
+ ...
+ }
+
+=cut
+
+use Exporter ();
+use Config qw(%Config);
+use Carp;
+use Cwd;
+use File::Spec;
+use strict;
+use vars qw(
+ @ISA @EXPORT
+ $is_dbi
+);
+
+BEGIN {
+ if ($^O eq 'VMS') {
+ require vmsish;
+ import vmsish;
+ require VMS::Filespec;
+ import VMS::Filespec;
+ }
+ else {
+ *vmsify = sub { return $_[0] };
+ *unixify = sub { return $_[0] };
+ }
+}
+
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+ dbd_dbi_dir
+ dbd_dbi_arch_dir
+ dbd_edit_mm_attribs
+ dbd_postamble
+);
+
+BEGIN {
+ $is_dbi = (-r 'DBI.pm' && -r 'DBI.xs' && -r 'DBIXS.h');
+ require DBI unless $is_dbi;
+}
+
+my $done_inst_checks;
+
+sub _inst_checks {
+ return if $done_inst_checks++;
+ my $cwd = cwd();
+ if ($cwd =~ /\Q$Config{path_sep}/) {
+ warn "*** Warning: Path separator characters (`$Config{path_sep}') ",
+ "in the current directory path ($cwd) may cause problems\a\n\n";
+ sleep 2;
+ }
+ if ($cwd =~ /\s/) {
+ warn "*** Warning: whitespace characters ",
+ "in the current directory path ($cwd) may cause problems\a\n\n";
+ sleep 2;
+ }
+ if ( $^O eq 'MSWin32'
+ && $Config{cc} eq 'cl'
+ && !(exists $ENV{'LIB'} && exists $ENV{'INCLUDE'}))
+ {
+ die <<EOT;
+*** You're using Microsoft Visual C++ compiler or similar but
+ the LIB and INCLUDE environment variables are not both set.
+
+ You need to run the VCVARS32.BAT batch file that was supplied
+ with the compiler before you can use it.
+
+ A copy of vcvars32.bat can typically be found in the following
+ directories under your Visual Studio install directory:
+ Visual C++ 6.0: vc98\\bin
+ Visual Studio .NET: vc7\\bin
+
+ Find it, run it, then retry this.
+
+ If you think this error is not correct then just set the LIB and
+ INCLUDE environment variables to some value to disable the check.
+EOT
+ }
+}
+
+sub dbd_edit_mm_attribs {
+ # this both edits the attribs in-place and returns the flattened attribs
+ my $mm_attr = shift;
+ my $dbd_attr = shift || {};
+ croak "dbd_edit_mm_attribs( \%makemaker [, \%other ]): too many parameters"
+ if @_;
+ _inst_checks();
+
+ # decide what needs doing
+
+ # do whatever needs doing
+ if ($dbd_attr->{create_pp_tests}) {
+ # XXX need to convert this to work within the generated Makefile
+ # so 'make' creates them and 'make clean' deletes them
+ my %test_variants = (
+ p => { name => "DBI::PurePerl",
+ add => [ '$ENV{DBI_PUREPERL} = 2' ],
+ },
+ g => { name => "DBD::Gofer",
+ add => [ q{$ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=null;policy=pedantic'} ],
+ },
+ xgp => { name => "PurePerl & Gofer",
+ add => [ q{$ENV{DBI_PUREPERL} = 2; $ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=null;policy=pedantic'} ],
+ },
+ # mx => { name => "DBD::Multiplex",
+ # add => [ q{local $ENV{DBI_AUTOPROXY} = 'dbi:Multiplex:';} ],
+ # }
+ # px => { name => "DBD::Proxy",
+ # need mechanism for starting/stopping the proxy server
+ # add => [ q{local $ENV{DBI_AUTOPROXY} = 'dbi:Proxy:XXX';} ],
+ # }
+ );
+
+ opendir DIR, 't' or die "Can't read 't' directory: $!";
+ my @tests = grep { /\.t$/ } readdir DIR;
+ closedir DIR;
+
+ while ( my ($v_type, $v_info) = each %test_variants ) {
+ printf "Creating test wrappers for $v_info->{name}:\n";
+
+ foreach my $test (sort @tests) {
+ next if $test !~ /^\d/;
+ my $usethr = ($test =~ /(\d+|\b)thr/ && $] >= 5.008 && $Config{useithreads});
+ my $v_test = "t/zv${v_type}_$test";
+ my $v_perl = ($test =~ /taint/) ? "perl -wT" : "perl -w";
+ printf "%s %s\n", $v_test, ($usethr) ? "(use threads)" : "";
+ open PPT, ">$v_test" or warn "Can't create $v_test: $!";
+ print PPT "#!$v_perl\n";
+ print PPT "use threads;\n" if $usethr;
+ print PPT "$_;\n" foreach @{$v_info->{add}};
+ print PPT "require './t/$test'; # or warn \$!;\n";
+ close PPT or warn "Error writing $v_test: $!";
+ }
+ }
+ }
+ return %$mm_attr;
+}
+
+sub dbd_dbi_dir {
+ _inst_checks();
+ return '.' if $is_dbi;
+ my $dbidir = $INC{'DBI.pm'} || die "DBI.pm not in %INC!";
+ $dbidir =~ s:/DBI\.pm$::;
+ return $dbidir;
+}
+
+sub dbd_dbi_arch_dir {
+ _inst_checks();
+ return '$(INST_ARCHAUTODIR)' if $is_dbi;
+ my $dbidir = dbd_dbi_dir();
+ my %seen;
+ my @try = grep { not $seen{$_}++ } map { vmsify( unixify($_) . "/auto/DBI/" ) } @INC;
+ my @xst = grep { -f vmsify( unixify($_) . "/Driver.xst" ) } @try;
+ Carp::croak("Unable to locate Driver.xst in @try") unless @xst;
+ Carp::carp( "Multiple copies of Driver.xst found in: @xst") if @xst > 1;
+ print "Using DBI $DBI::VERSION (for perl $] on $Config{archname}) installed in $xst[0]\n";
+ return File::Spec->canonpath($xst[0]);
+}
+
+sub dbd_postamble {
+ my $self = shift;
+ _inst_checks();
+ my $dbi_instarch_dir = ($is_dbi) ? "." : dbd_dbi_arch_dir();
+ my $dbi_driver_xst= File::Spec->catfile($dbi_instarch_dir, 'Driver.xst');
+ my $xstf_h = File::Spec->catfile($dbi_instarch_dir, 'Driver_xst.h');
+
+ # we must be careful of quotes, expecially for Win32 here.
+ return '
+# --- This section was generated by DBI::DBD::dbd_postamble()
+DBI_INSTARCH_DIR='.$dbi_instarch_dir.'
+DBI_DRIVER_XST='.$dbi_driver_xst.'
+
+# The main dependancy (technically correct but probably not used)
+$(BASEEXT).c: $(BASEEXT).xsi
+
+# This dependancy is needed since MakeMaker uses the .xs.o rule
+$(BASEEXT)$(OBJ_EXT): $(BASEEXT).xsi
+
+$(BASEEXT).xsi: $(DBI_DRIVER_XST) '.$xstf_h.'
+ $(PERL) -p -e "s/~DRIVER~/$(BASEEXT)/g" $(DBI_DRIVER_XST) > $(BASEEXT).xsi
+
+# ---
+';
+}
+
+package DBDI; # just to reserve it via PAUSE for the future
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>),
+Jochen Wiedmann <joe@ispsoft.de>,
+Steffen Goeldner <sgoeldner@cpan.org>,
+and Tim Bunce <dbi-users@perl.org>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/DBD/Metadata.pm b/Master/tlpkg/tlperl.straw/lib/DBI/DBD/Metadata.pm
new file mode 100755
index 00000000000..31d5b59b04f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/DBD/Metadata.pm
@@ -0,0 +1,493 @@
+package DBI::DBD::Metadata;
+
+# $Id: Metadata.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# Copyright (c) 1997-2003 Jonathan Leffler, Jochen Wiedmann,
+# Steffen Goeldner and Tim Bunce
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use Exporter ();
+use Carp;
+
+use DBI;
+use DBI::Const::GetInfoType qw(%GetInfoType);
+
+# Perl 5.005_03 does not recognize 'our'
+@ISA = qw(Exporter);
+@EXPORT = qw(write_getinfo_pm write_typeinfo_pm);
+
+$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+
+use strict;
+
+=head1 NAME
+
+DBI::DBD::Metadata - Generate the code and data for some DBI metadata methods
+
+=head1 SYNOPSIS
+
+The idea is to extract metadata information from a good quality
+ODBC driver and use it to generate code and data to use in your own
+DBI driver for the same database.
+
+For generating code to support the get_info method:
+
+ perl -MDBI::DBD::Metadata -e "write_getinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')"
+
+ perl -MDBI::DBD::Metadata -e write_getinfo_pm dbi:ODBC:foo_db username password Driver
+
+For generating code to support the type_info method:
+
+ perl -MDBI::DBD::Metadata -e "write_typeinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')"
+
+ perl -MDBI::DBD::Metadata -e write_typeinfo_pm dbi:ODBC:dsn-name user pass Driver
+
+Where C<dbi:ODBC:dsn-name> is the connection to use to extract the
+data, and C<Driver> is the name of the driver you want the code
+generated for (the driver name gets embedded into the output in
+many places).
+
+=head1 Generating a GetInfo package for a driver
+
+The C<write_getinfo_pm> in the DBI::DBD::Metadata module generates a
+DBD::Driver::GetInfo package on standard output.
+
+This method generates a DBD::Driver::GetInfo package from the data
+source you specified in the parameter list or in the environment
+variable DBI_DSN.
+DBD::Driver::GetInfo should help a DBD author implementing the DBI
+get_info() method.
+Because you are just creating this package, it's very unlikely that
+DBD::Driver already provides a good implementation for get_info().
+Thus you will probably connect via DBD::ODBC.
+
+Once you are sure that it is producing semi-sane data, you would
+typically redirect the standard output to lib/DBD/Driver/GetInfo.pm, and
+then hand edit the result.
+Do not forget to update your Makefile.PL and MANIFEST to include this as
+an extra PM file that should be installed.
+
+If you connect via DBD::ODBC, you should use version 0.38 or greater;
+
+Please take a critical look at the data returned!
+ODBC drivers vary dramatically in their quality.
+
+The generator assumes that most values are static and places these
+values directly in the %info hash.
+A few examples show the use of CODE references and the implementation
+via subroutines.
+It is very likely that you have to write additional subroutines for
+values depending on the session state or server version, e.g.
+SQL_DBMS_VER.
+
+A possible implementation of DBD::Driver::db::get_info() may look like:
+
+ sub get_info {
+ my($dbh, $info_type) = @_;
+ require DBD::Driver::GetInfo;
+ my $v = $DBD::Driver::GetInfo::info{int($info_type)};
+ $v = $v->($dbh) if ref $v eq 'CODE';
+ return $v;
+ }
+
+Please replace Driver (or "<foo>") with the name of your driver.
+Note that this stub function is generated for you by write_getinfo_pm
+function, but you must manually transfer the code to Driver.pm.
+
+=cut
+
+sub write_getinfo_pm
+{
+ my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV;
+ my $dbh = DBI->connect($dsn, $user, $pass, {RaiseError=>1});
+ $driver = "<foo>" unless defined $driver;
+
+ print <<PERL;
+
+# Transfer this to ${driver}.pm
+
+# The get_info function was automatically generated by
+# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION.
+
+package DBD::${driver}::db; # This line can be removed once transferred.
+
+ sub get_info {
+ my(\$dbh, \$info_type) = \@_;
+ require DBD::${driver}::GetInfo;
+ my \$v = \$DBD::${driver}::GetInfo::info{int(\$info_type)};
+ \$v = \$v->(\$dbh) if ref \$v eq 'CODE';
+ return \$v;
+ }
+
+# Transfer this to lib/DBD/${driver}/GetInfo.pm
+
+# The \%info hash was automatically generated by
+# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION.
+
+package DBD::${driver}::GetInfo;
+
+use strict;
+use DBD::${driver};
+
+# Beware: not officially documented interfaces...
+# use DBI::Const::GetInfoType qw(\%GetInfoType);
+# use DBI::Const::GetInfoReturn qw(\%GetInfoReturnTypes \%GetInfoReturnValues);
+
+my \$sql_driver = '${driver}';
+my \$sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.#####
+my \$sql_driver_ver = sprintf \$sql_ver_fmt, split (/\\./, \$DBD::${driver}::VERSION);
+PERL
+
+my $kw_map = 0;
+{
+# Informix CLI (ODBC) v3.81.0000 does not return a list of keywords.
+ local $\ = "\n";
+ local $, = "\n";
+ my ($kw) = $dbh->get_info($GetInfoType{SQL_KEYWORDS});
+ if ($kw)
+ {
+ print "\nmy \@Keywords = qw(\n";
+ print sort split /,/, $kw;
+ print ");\n\n";
+ print "sub sql_keywords {\n";
+ print q% return join ',', @Keywords;%;
+ print "\n}\n\n";
+ $kw_map = 1;
+ }
+}
+
+ print <<'PERL';
+
+sub sql_data_source_name {
+ my $dbh = shift;
+ return "dbi:$sql_driver:" . $dbh->{Name};
+}
+
+sub sql_user_name {
+ my $dbh = shift;
+ # CURRENT_USER is a non-standard attribute, probably undef
+ # Username is a standard DBI attribute
+ return $dbh->{CURRENT_USER} || $dbh->{Username};
+}
+
+PERL
+
+ print "\nour \%info = (\n";
+ foreach my $key (sort keys %GetInfoType)
+ {
+ my $num = $GetInfoType{$key};
+ my $val = eval { $dbh->get_info($num); };
+ if ($key eq 'SQL_DATA_SOURCE_NAME') {
+ $val = '\&sql_data_source_name';
+ }
+ elsif ($key eq 'SQL_KEYWORDS') {
+ $val = ($kw_map) ? '\&sql_keywords' : 'undef';
+ }
+ elsif ($key eq 'SQL_DRIVER_NAME') {
+ $val = "\$INC{'DBD/$driver.pm'}";
+ }
+ elsif ($key eq 'SQL_DRIVER_VER') {
+ $val = '$sql_driver_ver';
+ }
+ elsif ($key eq 'SQL_USER_NAME') {
+ $val = '\&sql_user_name';
+ }
+ elsif (not defined $val) {
+ $val = 'undef';
+ }
+ elsif ($val eq '') {
+ $val = "''";
+ }
+ elsif ($val =~ /\D/) {
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/'/\\'/g;
+ $val = "'$val'";
+ }
+ printf "%s %5d => %-30s # %s\n", (($val eq 'undef') ? '#' : ' '), $num, "$val,", $key;
+ }
+ print ");\n\n1;\n\n__END__\n";
+}
+
+
+
+=head1 Generating a TypeInfo package for a driver
+
+The C<write_typeinfo_pm> function in the DBI::DBD::Metadata module generates
+on standard output the data needed for a driver's type_info_all method.
+It also provides default implementations of the type_info_all
+method for inclusion in the driver's main implementation file.
+
+The driver parameter is the name of the driver for which the methods
+will be generated; for the sake of examples, this will be "Driver".
+Typically, the dsn parameter will be of the form "dbi:ODBC:odbc_dsn",
+where the odbc_dsn is a DSN for one of the driver's databases.
+The user and pass parameters are the other optional connection
+parameters that will be provided to the DBI connect method.
+
+Once you are sure that it is producing semi-sane data, you would
+typically redirect the standard output to lib/DBD/Driver/TypeInfo.pm,
+and then hand edit the result if necessary.
+Do not forget to update your Makefile.PL and MANIFEST to include this as
+an extra PM file that should be installed.
+
+Please take a critical look at the data returned!
+ODBC drivers vary dramatically in their quality.
+
+The generator assumes that all the values are static and places these
+values directly in the %info hash.
+
+A possible implementation of DBD::Driver::type_info_all() may look like:
+
+ sub type_info_all {
+ my ($dbh) = @_;
+ require DBD::Driver::TypeInfo;
+ return [ @$DBD::Driver::TypeInfo::type_info_all ];
+ }
+
+Please replace Driver (or "<foo>") with the name of your driver.
+Note that this stub function is generated for you by the write_typeinfo_pm
+function, but you must manually transfer the code to Driver.pm.
+
+=cut
+
+
+# These two are used by fmt_value...
+my %dbi_inv;
+my %sql_type_inv;
+
+#-DEBUGGING-#
+#sub print_hash
+#{
+# my ($name, %hash) = @_;
+# print "Hash: $name\n";
+# foreach my $key (keys %hash)
+# {
+# print "$key => $hash{$key}\n";
+# }
+#}
+#-DEBUGGING-#
+
+sub inverse_hash
+{
+ my (%hash) = @_;
+ my (%inv);
+ foreach my $key (keys %hash)
+ {
+ my $val = $hash{$key};
+ die "Double mapping for key value $val ($inv{$val}, $key)!"
+ if (defined $inv{$val});
+ $inv{$val} = $key;
+ }
+ return %inv;
+}
+
+sub fmt_value
+{
+ my ($num, $val) = @_;
+ if (!defined $val)
+ {
+ $val = "undef";
+ }
+ elsif ($val !~ m/^[-+]?\d+$/)
+ {
+ # All the numbers in type_info_all are integers!
+ # Anything that isn't an integer is a string.
+ # Ensure that no double quotes screw things up.
+ $val =~ s/"/\\"/g if ($val =~ m/"/o);
+ $val = qq{"$val"};
+ }
+ elsif ($dbi_inv{$num} =~ m/^(SQL_)?DATA_TYPE$/)
+ {
+ # All numeric...
+ $val = $sql_type_inv{$val}
+ if (defined $sql_type_inv{$val});
+ }
+ return $val;
+}
+
+sub write_typeinfo_pm
+{
+ my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV;
+ my $dbh = DBI->connect($dsn, $user, $pass, {AutoCommit=>1, RaiseError=>1});
+ $driver = "<foo>" unless defined $driver;
+
+ print <<PERL;
+
+# Transfer this to ${driver}.pm
+
+# The type_info_all function was automatically generated by
+# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION.
+
+package DBD::${driver}::db; # This line can be removed once transferred.
+
+ sub type_info_all
+ {
+ my (\$dbh) = \@_;
+ require DBD::${driver}::TypeInfo;
+ return [ \@\$DBD::${driver}::TypeInfo::type_info_all ];
+ }
+
+# Transfer this to lib/DBD/${driver}/TypeInfo.pm.
+# Don't forget to add version and intellectual property control information.
+
+# The \%type_info_all hash was automatically generated by
+# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION.
+
+package DBD::${driver}::TypeInfo;
+
+{
+ require Exporter;
+ require DynaLoader;
+ \@ISA = qw(Exporter DynaLoader);
+ \@EXPORT = qw(type_info_all);
+ use DBI qw(:sql_types);
+
+PERL
+
+ # Generate SQL type name mapping hashes.
+ # See code fragment in DBI specification.
+ my %sql_type_map;
+ foreach (@{$DBI::EXPORT_TAGS{sql_types}})
+ {
+ no strict 'refs';
+ $sql_type_map{$_} = &{"DBI::$_"}();
+ $sql_type_inv{$sql_type_map{$_}} = $_;
+ }
+ #-DEBUG-# print_hash("sql_type_map", %sql_type_map);
+ #-DEBUG-# print_hash("sql_type_inv", %sql_type_inv);
+
+ my %dbi_map =
+ (
+ TYPE_NAME => 0,
+ DATA_TYPE => 1,
+ COLUMN_SIZE => 2,
+ LITERAL_PREFIX => 3,
+ LITERAL_SUFFIX => 4,
+ CREATE_PARAMS => 5,
+ NULLABLE => 6,
+ CASE_SENSITIVE => 7,
+ SEARCHABLE => 8,
+ UNSIGNED_ATTRIBUTE => 9,
+ FIXED_PREC_SCALE => 10,
+ AUTO_UNIQUE_VALUE => 11,
+ LOCAL_TYPE_NAME => 12,
+ MINIMUM_SCALE => 13,
+ MAXIMUM_SCALE => 14,
+ SQL_DATA_TYPE => 15,
+ SQL_DATETIME_SUB => 16,
+ NUM_PREC_RADIX => 17,
+ INTERVAL_PRECISION => 18,
+ );
+
+ #-DEBUG-# print_hash("dbi_map", %dbi_map);
+
+ %dbi_inv = inverse_hash(%dbi_map);
+
+ #-DEBUG-# print_hash("dbi_inv", %dbi_inv);
+
+ my $maxlen = 0;
+ foreach my $key (keys %dbi_map)
+ {
+ $maxlen = length($key) if length($key) > $maxlen;
+ }
+
+ # Print the name/value mapping entry in the type_info_all array;
+ my $fmt = " \%-${maxlen}s => \%2d,\n";
+ my $numkey = 0;
+ my $maxkey = 0;
+ print " \$type_info_all = [\n {\n";
+ foreach my $i (sort { $a <=> $b } keys %dbi_inv)
+ {
+ printf($fmt, $dbi_inv{$i}, $i);
+ $numkey++;
+ $maxkey = $i;
+ }
+ print " },\n";
+
+ print STDERR "### WARNING - Non-dense set of keys ($numkey keys, $maxkey max key)\n"
+ unless $numkey = $maxkey + 1;
+
+ my $h = $dbh->type_info_all;
+ my @tia = @$h;
+ my %odbc_map = map { uc $_ => $tia[0]->{$_} } keys %{$tia[0]};
+ shift @tia; # Remove the mapping reference.
+ my $numtyp = $#tia;
+
+ #-DEBUG-# print_hash("odbc_map", %odbc_map);
+
+ # In theory, the key/number mapping sequence for %dbi_map
+ # should be the same as the one from the ODBC driver. However, to
+ # prevent the possibility of mismatches, and to deal with older
+ # missing attributes or unexpected new ones, we chase back through
+ # the %dbi_inv and %odbc_map hashes, generating @dbi_to_odbc
+ # to map our new key number to the old one.
+ # Report if @dbi_to_odbc is not an identity mapping.
+ my @dbi_to_odbc;
+ foreach my $num (sort { $a <=> $b } keys %dbi_inv)
+ {
+ # Find the name in %dbi_inv that matches this index number.
+ my $dbi_key = $dbi_inv{$num};
+ #-DEBUG-# print "dbi_key = $dbi_key\n";
+ #-DEBUG-# print "odbc_key = $odbc_map{$dbi_key}\n";
+ # Find the index in %odbc_map that has this key.
+ $dbi_to_odbc[$num] = (defined $odbc_map{$dbi_key}) ? $odbc_map{$dbi_key} : undef;
+ }
+
+ # Determine the length of the longest formatted value in each field
+ my @len;
+ for (my $i = 0; $i <= $numtyp; $i++)
+ {
+ my @odbc_val = @{$tia[$i]};
+ for (my $num = 0; $num <= $maxkey; $num++)
+ {
+ # Find the value of the entry in the @odbc_val array.
+ my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef;
+ $val = fmt_value($num, $val);
+ #-DEBUG-# print "val = $val\n";
+ $val = "$val,";
+ $len[$num] = length($val) if !defined $len[$num] || length($val) > $len[$num];
+ }
+ }
+
+ # Generate format strings to left justify each string in maximum field width.
+ my @fmt;
+ for (my $i = 0; $i <= $maxkey; $i++)
+ {
+ $fmt[$i] = "%-$len[$i]s";
+ #-DEBUG-# print "fmt[$i] = $fmt[$i]\n";
+ }
+
+ # Format the data from type_info_all
+ for (my $i = 0; $i <= $numtyp; $i++)
+ {
+ my @odbc_val = @{$tia[$i]};
+ print " [ ";
+ for (my $num = 0; $num <= $maxkey; $num++)
+ {
+ # Find the value of the entry in the @odbc_val array.
+ my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef;
+ $val = fmt_value($num, $val);
+ printf $fmt[$num], "$val,";
+ }
+ print " ],\n";
+ }
+
+ print " ];\n\n 1;\n}\n\n__END__\n";
+
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>),
+Jochen Wiedmann <joe@ispsoft.de>,
+Steffen Goeldner <sgoeldner@cpan.org>,
+and Tim Bunce <dbi-users@perl.org>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/FAQ.pm b/Master/tlpkg/tlperl.straw/lib/DBI/FAQ.pm
new file mode 100755
index 00000000000..b7593c45f0c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/FAQ.pm
@@ -0,0 +1,975 @@
+###
+### $Id: FAQ.pm 10253 2007-11-15 09:26:16Z timbo $
+###
+### DBI Frequently Asked Questions POD
+###
+### Copyright section reproduced from below.
+###
+### This document is Copyright (c)1994-2000 Alligator Descartes, with portions
+### Copyright (c)1994-2000 their original authors. This module is released under
+### the 'Artistic' license which you can find in the perl distribution.
+###
+### This document is Copyright (c)1997-2000 Alligator Descartes. All rights reserved.
+### Permission to distribute this document, in full or in part, via email,
+### Usenet, ftp archives or http is granted providing that no charges are involved,
+### reasonable attempt is made to use the most current version and all credits
+### and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
+### Requests for other distribution rights, including incorporation into
+### commercial products, such as books, magazine articles or CD-ROMs should be
+### made to Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
+###
+
+package DBI::FAQ;
+
+our $VERSION = sprintf("1.%06d", q$Revision: 10253 $ =~ /(\d+)/o);
+
+
+=head1 NAME
+
+DBI::FAQ -- The Frequently Asked Questions for the Perl5 Database Interface
+
+=for html
+<BODY BGCOLOR="#ffffff" TEXT="#000000" LINK="#3a15ff" ALINK="#ff0000" VLINK="#ff282d">
+<!--#include virtual="/technology/perl/DBI/templatetop.html" -->
+<CENTER>
+<FONT SIZE="+2">
+DBI Frequently Asked Questions v.0.38
+</FONT>
+<BR>
+<FONT SIZE="-1">
+<I>Last updated: February 8th, 2000</I>
+</FONT>
+</CENTER>
+<P>
+
+=head1 SYNOPSIS
+
+ perldoc DBI::FAQ
+
+=head1 VERSION
+
+This document is currently at version I<0.38>, as of I<February 8th, 2000>.
+
+That's B<very> old. A newer FAQ can be found at L<http://faq.dbi-support.com/>
+
+=head1 DESCRIPTION
+
+This document serves to answer the most frequently asked questions on both
+the DBI Mailing Lists and personally to members of the DBI development team.
+
+=head1 Basic Information & Information Sources
+
+=head2 1.1 What is DBI, DBperl, Oraperl and *perl?
+
+To quote Tim Bunce, the architect and author of DBI:
+
+ ``DBI is a database access Application Programming Interface (API)
+ for the Perl Language. The DBI API Specification defines a set
+ of functions, variables and conventions that provide a consistent
+ database interface independant of the actual database being used.''
+
+In simple language, the DBI interface allows users to access multiple database
+types transparently. So, if you connecting to an Oracle, Informix, mSQL, Sybase
+or whatever database, you don't need to know the underlying mechanics of the
+3GL layer. The API defined by DBI will work on I<all> these database types.
+
+A similar benefit is gained by the ability to connect to two I<different>
+databases of different vendor within the one perl script, I<ie>, I want
+to read data from an Oracle database and insert it back into an Informix
+database all within one program. The DBI layer allows you to do this simply
+and powerfully.
+
+
+=for html
+Here's a diagram that demonstrates the principle:
+<P>
+<CENTER>
+<IMG SRC="img/dbiarch.gif" WIDTH=451 HEIGHT=321 ALT="[ DBI Architecture ]">
+</CENTER>
+<P>
+
+I<DBperl> is the old name for the interface specification. It's usually
+now used to denote perlI<4> modules on database interfacing, such as,
+I<oraperl>, I<isqlperl>, I<ingperl> and so on. These interfaces
+didn't have a standard API and are generally I<not> supported.
+
+Here's a list of DBperl modules, their corresponding DBI counterparts and
+support information. I<Please note>, the author's listed here generally
+I<do not> maintain the DBI module for the same database. These email
+addresses are unverified and should only be used for queries concerning the
+perl4 modules listed below. DBI driver queries should be directed to the
+I<dbi-users> mailing list.
+
+ Module Name Database Required Author DBI
+ ----------- ----------------- ------ ---
+ Sybperl Sybase Michael Peppler DBD::Sybase
+ <mpeppler@itf.ch>
+ Oraperl Oracle 6 & 7 Kevin Stock DBD::Oracle
+ <dbi-users@perl.org>
+ Ingperl Ingres Tim Bunce & DBD::Ingres
+ Ted Lemon
+ <dbi-users@perl.org>
+ Interperl Interbase Buzz Moschetti DBD::Interbase
+ <buzz@bear.com>
+ Uniperl Unify 5.0 Rick Wargo None
+ <rickers@coe.drexel.edu>
+ Pgperl Postgres Igor Metz DBD::Pg
+ <metz@iam.unibe.ch>
+ Btreeperl NDBM John Conover SDBM?
+ <john@johncon.com>
+ Ctreeperl C-Tree John Conover None
+ <john@johncon.com>
+ Cisamperl Informix C-ISAM Mathias Koerber None
+ <mathias@unicorn.swi.com.sg>
+ Duaperl X.500 Directory Eric Douglas None
+ User Agent
+
+However, some DBI modules have DBperl emulation layers, so, I<DBD::Oracle>
+comes with an Oraperl emulation layer, which allows you to run legacy oraperl
+scripts without modification. The emulation layer translates the oraperl API
+calls into DBI calls and executes them through the DBI switch.
+
+Here's a table of emulation layer information:
+
+ Module Emulation Layer Status
+ ------ --------------- ------
+ DBD::Oracle Oraperl Complete
+ DBD::Informix Isqlperl Under development
+ DBD::Ingres Ingperl Complete?
+ DBD::Sybase Sybperl Working? ( Needs verification )
+ DBD::mSQL Msqlperl Experimentally released with
+ DBD::mSQL-0.61
+
+The I<Msqlperl> emulation is a special case. I<Msqlperl> is a perl5 driver
+for I<mSQL> databases, but does not conform to the DBI Specification. It's
+use is being deprecated in favour of I<DBD::mSQL>. I<Msqlperl> may be downloaded
+from CPAN I<via>:
+
+ http://www.perl.com/cgi-bin/cpan_mod?module=Msqlperl
+
+=head2 1.2. Where can I get it from?
+
+The Comprehensive Perl Archive Network
+resources should be used for retrieving up-to-date versions of the DBI
+and drivers. CPAN may be accessed I<via> Tom Christiansen's splendid
+I<CPAN multiplexer> program located at:
+
+ http://www.perl.com/CPAN/
+
+For more specific version information and exact URLs of drivers, please see
+the DBI drivers list and the DBI module pages which can be found on:
+
+ http://dbi.perl.org/
+ http://www.symbolstone.org/technology/perl/DBI
+
+This list is automatically generated on a nightly basis from CPAN and should
+be up-to-date.
+
+=head2 1.3. Where can I get more information?
+
+There are a few information sources on DBI.
+
+=over 4
+
+=item I<"Programming the Perl DBI">
+
+"Programming the Perl DBI" is the I<official> book on the DBI written by
+Alligator Descartes and Tim Bunce and published by O'Reilly & Associates.
+The book was released on February 9th, 2000.
+
+The table of contents is:
+
+ Preface
+ 1. Introduction
+ From Mainframes to Workstations
+ Perl
+ DBI in the Real World
+ A Historical Interlude and Standing Stones
+ 2. Basic Non-DBI Databases
+ Storage Managers and Layers
+ Query Languages and Data Functions
+ Standing Stones and the Sample Database
+ Flat-File Databases
+ Putting Complex Data into Flat Files
+ Concurrent Database Access and Locking
+ DBM Files and the Berkeley Database Manager
+ The MLDBM Module
+ Summary
+ 3. SQL and Relational Databases
+ The Relational Database Methodology
+ Datatypes and NULL Values
+ Querying Data
+ Modifying Data Within Tables
+ Creating and Destroying Tables
+ 4. Programming with the DBI
+ DBI Architecture
+ Handles
+ Data Source Names
+ Connection and Disconnection
+ Error Handling
+ Utility Methods and Functions
+ 5. Interacting with the Database
+ Issuing Simple Queries
+ Executing Non-SELECT Statements
+ Binding Parameters to Statements
+ Binding Output Columns
+ do() Versus prepare()
+ Atomic and Batch Fetching
+ 6. Advanced DBI
+ Handle Attributes and Metadata
+ Handling LONG/LOB Data
+ Transactions, Locking, and Isolation
+ 7. ODBC and the DBI
+ ODBC -- Embraced and Extended
+ DBI -- Thrashed and Mutated
+ The Nuts and Bolts of ODBC
+ ODBC from Perl
+ The Marriage of DBI and ODBC
+ Questions and Choices
+ Moving Between Win32::ODBC and the DBI
+ And What About ADO?
+ 8. DBI Shell and Database Proxying
+ dbish -- The DBI Shell
+ Database Proxying
+ A. DBI Specification
+ B. Driver and Database Characteristics
+ C. ASLaN Sacred Site Charter
+ Index
+
+The book should be available from all good bookshops and can be ordered online
+either <I>via</I> O'Reilly & Associates
+
+ http://www.oreilly.com/catalog/perldbi
+
+or Amazon
+
+ http://www.amazon.com/exec/obidos/ASIN/1565926994/dbi
+
+=item I<POD documentation>
+
+I<POD>s are chunks of documentation usually embedded within perl programs
+that document the code ``I<in place>'', providing a useful resource for
+programmers and users of modules. POD for DBI and drivers is beginning to
+become more commonplace, and documentation for these modules can be read
+with the C<perldoc> program included with Perl.
+
+=over 4
+
+=item The DBI Specification
+
+The POD for the DBI Specification can be read with the:
+
+ perldoc DBI
+
+command. The Specification also forms Appendix A of "Programming the Perl
+DBI".
+
+=item Oraperl
+
+Users of the Oraperl emulation layer bundled with I<DBD::Oracle>, may read
+up on how to program with the Oraperl interface by typing:
+
+ perldoc Oraperl
+
+This will produce an updated copy of the original oraperl man page written by
+Kevin Stock for perl4. The oraperl API is fully listed and described there.
+
+=item Drivers
+
+Users of the DBD modules may read about some of the private functions
+and quirks of that driver by typing:
+
+ perldoc <driver>
+
+For example, the I<DBD::mSQL> driver is bundled with driver-specific
+documentation that can be accessed by typing
+
+ perldoc DBD::mSQL
+
+=item Frequently Asked Questions
+
+This document, the I<Frequently Asked Questions> is also available as POD
+documentation! You can read this on your own system by typing:
+
+ perldoc DBI::FAQ
+
+This may be more convenient to persons not permanently, or conveniently,
+connected to the Internet. The I<DBI::FAQ> module should be downloaded and
+installed for the more up-to-date version.
+
+The version of I<DBI::FAQ> shipped with the C<DBI> module may be slightly out
+of date.
+
+=item POD in general
+
+Information on writing POD, and on the philosophy of POD in general, can be
+read by typing:
+
+ perldoc perlpod
+
+Users with the Tk module installed may be interested to learn there is a
+Tk-based POD reader available called C<tkpod>, which formats POD in a convenient
+and readable way. This is available I<via> CPAN as the module called
+I<Tk::POD> and is highly recommended.
+
+=back
+
+=item I<Driver and Database Characteristics>
+
+The driver summaries that were produced for Appendix B of "Programming the
+Perl DBI" are available online at:
+
+ http://dbi.perl.org/
+ http://www.symbolstone.org/technology/perl/DBI
+
+in the driver information table. These summaries contain standardised
+information on each driver and database which should aid you in selecting
+a database to use. It will also inform you quickly of any issues within
+drivers or whether a driver is not fully compliant with the DBI Specification.
+
+=item I<Rambles, Tidbits and Observations>
+
+ http://dbi.perl.org/tidbits
+ http://www.symbolstone.org/technology/perl/DBI/tidbits
+
+There are a series of occasional rambles from various people on the
+DBI mailing lists who, in an attempt to clear up a simple point, end up
+drafting fairly comprehensive documents. These are quite often varying in
+quality, but do provide some insights into the workings of the interfaces.
+
+=item I<Articles>
+
+A list of articles discussing the DBI can be found on the DBI WWW page at:
+
+ http://dbi.perl.org/
+ http://www.symbolstone.org/technology/perl/DBI
+
+These articles are of varying quality and age, from the original Perl Journal
+article written by Alligator and Tim, to more recent debacles published online
+from about.com.
+
+=item I<README files>
+
+The I<README> files included with each driver occasionally contains
+some useful information ( no, really! ) that may be pertinent to the user.
+Please read them. It makes our worthless existences more bearable. These
+can all be read from the main DBI WWW page at:
+
+ http://dbi.perl.org/
+ http://www.symbolstone.org/technology/perl/DBI
+
+=item I<Mailing Lists>
+
+There are three mailing lists for DBI:
+
+ dbi-announce@perl.org -- for announcements, very low traffic
+ dbi-users@perl.org -- general user support
+ dbi-dev@perl.org -- for driver developers (no user support)
+
+For information on how to subscribe, set digest mode etc, and unsubscribe,
+send an email message (the content will be ignored) to:
+
+ dbi-announce-help@perl.org
+ dbi-users-help@perl.org
+ dbi-dev-help@perl.org
+
+=item I<Mailing List Archives>
+
+=over 4
+
+=item I<US Mailing List Archives>
+
+ http://outside.organic.com/mail-archives/dbi-users/
+
+Searchable hypermail archives of the three mailing lists, and some of the
+much older traffic have been set up for users to browse.
+
+=item I<European Mailing List Archives>
+
+ http://www.rosat.mpe-garching.mpg.de/mailing-lists/PerlDB-Interest
+
+As per the US archive above.
+
+=back
+
+=back
+
+=head1 Compilation Problems
+
+=head2 2.1. Compilation problems or "It fails the test!"
+
+First off, consult the README for that driver in case there is useful
+information about the problem. It may be a known problem for your given
+architecture and operating system or database. You can check the README
+files for each driver in advance online at:
+
+ http://dbi.perl.org/
+ http://www.symbolstone.org/technology/perl/DBI
+
+If it's a known problem, you'll probably have to wait till it gets fixed. If
+you're I<really> needing it fixed, try the following:
+
+=over 4
+
+=item I<Attempt to fix it yourself>
+
+This technique is generally I<not> recommended to the faint-hearted.
+If you do think you have managed to fix it, then, send a patch file
+( context diff ) to the author with an explanation of:
+
+=over 4
+
+=item *
+
+What the problem was, and test cases, if possible.
+
+=item *
+
+What you needed to do to fix it. Please make sure you mention everything.
+
+=item *
+
+Platform information, database version, perl version, module version and
+DBI version.
+
+=back
+
+=item I<Email the author> Do I<NOT> whinge!
+
+Please email the address listed in the WWW pages for whichever driver you
+are having problems with. Do I<not> directly email the author at a
+known address unless it corresponds with the one listed.
+
+We tend to have real jobs to do, and we do read the mailing lists for
+problems. Besides, we may not have access to <I<insert your
+favourite brain-damaged platform here>> and couldn't be of any
+assistance anyway! Apologies for sounding harsh, but that's the way of it!
+
+However, you might catch one of these creative genii at 3am when we're
+doing this sort of stuff anyway, and get a patch within 5 minutes. The
+atmosphere in the DBI circle is that we I<do> appreciate the users'
+problems, since we work in similar environments.
+
+If you are planning to email the author, please furnish as much information
+as possible, I<ie>:
+
+=over 4
+
+=item *
+
+I<ALL> the information asked for in the README file in
+the problematic module. And we mean I<ALL> of it. We don't
+put lines like that in documentation for the good of our health, or
+to meet obscure README file standards of length.
+
+=item *
+
+If you have a core dump, try the I<Devel::CoreStack> module for
+generating a stack trace from the core dump. Send us that too.
+I<Devel::CoreStack> can be found on CPAN at:
+
+ http://www.perl.com/cgi-bin/cpan_mod?module=Devel::CoreStack
+
+=item *
+
+Module versions, perl version, test cases, operating system versions
+and I<any other pertinent information>.
+
+=back
+
+Remember, the more information you send us, the quicker we can track
+problems down. If you send us no useful information, expect nothing back.
+
+Finally, please be aware that some authors, including Tim Bunce, specifically
+request that you do I<not> mail them directly. Please respect their wishes and
+use the email addresses listed in the appropriate module C<README> file.
+
+=item I<Email the dbi-users Mailing List>
+
+It's usually a fairly intelligent idea to I<cc> the mailing list
+anyway with problems. The authors all read the lists, so you lose nothing
+by mailing there.
+
+=back
+
+=head1 Platform and Driver Issues
+
+=head2 3.1 What's the difference between ODBC and DBI?
+
+In terms of architecture - not much: Both define programming
+interfaces. Both allow multiple drivers to be loaded to do the
+actual work.
+
+In terms of ease of use - much: The DBI is a 'high level' interface
+that, like Perl itself, strives to make the simple things easy while
+still making the hard things possible. The ODBC is a 'low level'
+interface. All nuts-bolts-knobs-and-dials.
+
+Now there's an ODBC driver for the DBI (DBD::ODBC) the "What's the
+difference" question is more usefully rephrased as:
+
+Chapter 7 of "Programming the Perl DBI" covers this topic in far more
+detail and should be consulted.
+
+=head2 3.2 What's the difference between Win32::ODBC and DBD::ODBC?
+
+The DBI, and thus DBD::ODBC, has a different philosophy from the
+Win32::ODBC module:
+
+The Win32::ODBC module is a 'thin' layer over the low-level ODBC API.
+The DBI defines a simpler 'higher level' interface.
+
+The Win32::ODBC module gives you access to more of the ODBC API.
+The DBI and DBD::ODBC give you access to only the essentials.
+(But, unlike Win32::ODBC, the DBI and DBD::ODBC do support parameter
+binding and multiple prepared statements which reduces the load on
+the database server and can dramatically increase performance.)
+
+The Win32::ODBC module only works on Win32 systems.
+The DBI and DBD::ODBC are very portable and work on Win32 and Unix.
+
+The DBI and DBD::ODBC modules are supplied as a standard part of the
+Perl 5.004 binary distribution for Win32 (they don't work with the
+older, non-standard, ActiveState port).
+
+Scripts written with the DBI and DBD::ODBC are faster than Win32::ODBC
+on Win32 and are trivially portable to other supported database types.
+
+The DBI offers optional automatic printing or die()ing on errors which
+makes applications simpler and more robust.
+
+The current DBD::ODBC driver version 0.16 is new and not yet fully stable.
+A new release is due soon [relative to the date of the next TPJ issue :-]
+and will be much improved and offer more ODBC functionality.
+
+To summarise: The Win32::ODBC module is your best choice if you need
+access to more of the ODBC API than the DBI gives you. Otherwise, the
+DBI and DBD::ODBC combination may be your best bet.
+
+Chapter 7 of "Programming the Perl DBI" covers this topic in far more
+detail and should be consulted.
+
+=head2 3.3 Is DBI supported under Windows 95 / NT platforms?
+
+Finally, yes! Jeff Urlwin has been working diligently on building
+I<DBI> and I<DBD::ODBC> under these platforms, and, with the
+advent of a stabler perl and a port of I<MakeMaker>, the project has
+come on by great leaps and bounds.
+
+The I<DBI> and I<DBD::Oracle> Win32 ports are now a standard part of DBI,
+so, downloading I<DBI> of version higher than I<0.81> should work fine as
+should using the most recent I<DBD::Oracle> version.
+
+=head2 3.4 Can I access Microsoft Access or SQL-Server databases with DBI?
+
+Yes, use the I<DBD::ODBC> driver.
+
+=head2 3.5 Is the a DBD for <I<insert favourite database here>>?
+
+Is is listed on the DBI drivers page?
+
+ http://dbi.perl.org/
+ http://www.symbolstone.org/technology/perl/DBI
+
+If not, no. A complete absence of a given database driver from that
+page means that no-one has announced any intention to work on it, not that
+such a driver is impossible to write.
+
+A corollary of the above statement implies that if you see an announcement
+for a driver I<not> on the above page, there's a good chance it's not
+actually a I<DBI> driver, and may not conform to the specifications. Therefore,
+questions concerning problems with that code should I<not> really be addressed
+to the DBI Mailing Lists.
+
+=head2 3.6 What's DBM? And why should I use DBI instead?
+
+Extracted from ``I<DBI - The Database Interface for Perl 5>'':
+
+ ``UNIX was originally blessed with simple file-based ``databases'', namely
+ the dbm system. dbm lets you store data in files, and retrieve
+ that data quickly. However, it also has serious drawbacks.
+
+ File Locking
+
+ The dbm systems did not allow particularly robust file locking
+ capabilities, nor any capability for correcting problems arising through
+ simultaneous writes [ to the database ].
+
+ Arbitrary Data Structures
+
+ The dbm systems only allows a single fixed data structure:
+ key-value pairs. That value could be a complex object, such as a
+ [ C ] struct, but the key had to be unique. This was a large
+ limitation on the usefulness of dbm systems.
+
+ However, dbm systems still provide a useful function for users with
+ simple datasets and limited resources, since they are fast, robust and
+ extremely well-tested. Perl modules to access dbm systems have now
+ been integrated into the core Perl distribution via the
+ AnyDBM_File module.''
+
+To sum up, DBM is a perfectly satisfactory solution for essentially read-only
+databases, or small and simple datasets. However, for more
+scaleable dataset handling, not to mention robust transactional locking,
+users are recommended to use a more powerful database engine I<via> I<DBI>.
+
+Chapter 2 of "Programming the Perl DBI" discusses DBM files in detail.
+
+=head2 3.7 What database do you recommend me using?
+
+This is a particularly thorny area in which an objective answer is difficult
+to come by, since each dataset, proposed usage and system configuration
+differs from person to person.
+
+From the current author's point of view, if the dataset is relatively
+small, being tables of less than 1 million rows, and less than 1000 tables
+in a given database, then I<mSQL> is a perfectly acceptable solution
+to your problem. This database is extremely cheap, is wonderfully robust
+and has excellent support. More information is available on the Hughes
+Technology WWW site at:
+
+ http://www.hughes.com.au
+
+You may also wish to look at MySQL which is a more powerful database engine
+that has a similar feel to mSQL.
+
+ http://www.tcx.se
+
+If the dataset is larger than 1 million row tables or 1000 tables, or if you
+have either more money, or larger machines, I would recommend I<Oracle RDBMS>.
+Oracle's WWW site is an excellent source of more information.
+
+ http://www.oracle.com
+
+I<Informix> is another high-end RDBMS that is worth considering. There are
+several differences between Oracle and Informix which are too complex for
+this document to detail. Information on Informix can be found on their
+WWW site at:
+
+ http://www.informix.com
+
+In the case of WWW fronted applications, I<mSQL> may be a better option
+due to slow connection times between a CGI script and the Oracle RDBMS and
+also the amount of resource each Oracle connection will consume. I<mSQL>
+is lighter resource-wise and faster.
+
+These views are not necessarily representative of anyone else's opinions,
+and do not reflect any corporate sponsorship or views. They are provided
+I<as-is>.
+
+=head2 3.8 Is <I<insert feature here>> supported in DBI?
+
+Given that we're making the assumption that the feature you have requested
+is a non-standard database-specific feature, then the answer will be I<no>.
+
+DBI reflects a I<generic> API that will work for most databases, and has
+no database-specific functionality.
+
+However, driver authors may, if they so desire, include hooks to database-specific
+functionality through the C<func()> method defined in the DBI API.
+Script developers should note that use of functionality provided I<via>
+the C<func()> methods is very unlikely to be portable across databases.
+
+=head1 Programming Questions
+
+=head2 4.1 Is DBI any use for CGI programming?
+
+In a word, yes! DBI is hugely useful for CGI programming! In fact, I would
+tentatively say that CGI programming is one of two top uses for DBI.
+
+DBI confers the ability to CGI programmers to power WWW-fronted databases
+to their users, which provides users with vast quantities of ordered
+data to play with. DBI also provides the possibility that, if a site is
+receiving far too much traffic than their database server can cope with, they
+can upgrade the database server behind the scenes with no alterations to
+the CGI scripts.
+
+=head2 4.2 How do I get faster connection times with DBD::Oracle and CGI?
+
+ Contributed by John D. Groenveld
+
+The Apache C<httpd> maintains a pool of C<httpd> children to service client
+requests.
+
+Using the Apache I<mod_perl> module by I<Doug MacEachern>, the perl
+interpreter is embedded with the C<httpd> children. The CGI, DBI, and your
+other favorite modules can be loaded at the startup of each child. These
+modules will not be reloaded unless changed on disk.
+
+For more information on Apache, see the Apache Project's WWW site:
+
+ http://www.apache.org
+
+The I<mod_perl> module can be downloaded from CPAN I<via>:
+
+ http://www.perl.com/cgi-bin/cpan_mod?module=Apache
+
+=head2 4.3 How do I get persistent connections with DBI and CGI?
+
+ Contributed by John D. Groenveld
+
+Using Edmund Mergl's I<Apache::DBI> module, database logins are stored in a
+hash with each of these C<httpd> child. If your application is based on a
+single database user, this connection can be started with each child.
+Currently, database connections cannot be shared between C<httpd> children.
+
+I<Apache::DBI> can be downloaded from CPAN I<via>:
+
+ http://www.perl.com/cgi-bin/cpan_mod?module=Apache::DBI
+
+=head2 4.4 ``When I run a perl script from the command line, it works, but, when I run it under the C<httpd>, it fails!'' Why?
+
+Basically, a good chance this is occurring is due to the fact that the user
+that you ran it from the command line as has a correctly configured set of
+environment variables, in the case of I<DBD::Oracle>, variables like
+C<ORACLE_HOME>, C<ORACLE_SID> or C<TWO_TASK>.
+
+The C<httpd> process usually runs under the user id of C<nobody>,
+which implies there is no configured environment. Any scripts attempting to
+execute in this situation will correctly fail.
+
+One way to solve this problem is to set the environment for your database in a
+C<BEGIN { }> block at the top of your script. Another technique is to configure
+your WWW server to pass-through certain environment variables to your CGI
+scripts.
+
+Similarly, you should check your C<httpd> error logfile for any clues,
+as well as the ``Idiot's Guide To Solving Perl / CGI Problems'' and
+``Perl CGI Programming FAQ'' for further information. It is
+unlikely the problem is DBI-related.
+
+The ``Idiot's Guide To Solving Perl / CGI Problems'' can be located at:
+
+ http://www.perl.com/perl/faq/index.html
+
+as can the ``Perl CGI Programming FAQ''. Read I<BOTH> these documents
+carefully!
+
+=head2 4.5 How do I get the number of rows returned from a C<SELECT> statement?
+
+Count them. Read the DBI docs for the C<rows()> method.
+
+=head1 Miscellaneous Questions
+
+=head2 5.1 Can I do multi-threading with DBI?
+
+Perl version 5.005 and later can be built to support multi-threading.
+The DBI, as of version 1.02, does not yet support multi-threading
+so it would be unsafe to let more than one thread enter the DBI at
+the same time.
+
+It is expected that some future version of the DBI will at least be
+thread-safe (but not thread-hot) by automatically blocking threads
+intering the DBI while it's already in use.
+
+For some OCI example code for Oracle that has multi-threaded C<SELECT>
+statements, see:
+
+ http://www.symbolstone.org/technology/oracle/oci/orathreads.tar.gz
+
+=head2 5.2 How do I handle BLOB data with DBI?
+
+Handling BLOB data with the DBI is very straight-forward. BLOB columns are
+specified in a SELECT statement as per normal columns. However, you also
+need to specify a maximum BLOB size that the <I>database handle</I> can
+fetch using the C<LongReadLen> attribute.
+
+For example:
+
+ ### $dbh is a connected database handle
+ $sth = $dbh->prepare( "SELECT blob_column FROM blobby_table" );
+ $sth->execute;
+
+would fail.
+
+ ### $dbh is a connected database handle
+ ### Set the maximum BLOB size...
+ $dbh->{LongReadLen} = 16384; ### 16Kb...Not much of a BLOB!
+
+ $sth = $dbh->prepare( "..." );
+
+would succeed <I>provided no column values were larger than the specified
+value</I>.
+
+If the BLOB data is longer than the value of C<LongReadLen>, then an
+error will occur. However, the DBI provides an additional piece of
+functionality that will automatically truncate the fetched BLOB to the
+size of C<LongReadLen> if it is longer. This does not cause an error to
+occur, but may make your fetched BLOB data useless.
+
+This behaviour is regulated by the C<LongTruncOk> attribute which is
+defaultly set to a false value ( thus making overlong BLOB fetches fail ).
+
+ ### Set BLOB handling such that it's 16Kb and can be truncated
+ $dbh->{LongReadLen} = 16384;
+ $dbh->{LongTruncOk} = 1;
+
+Truncation of BLOB data may not be a big deal in cases where the BLOB
+contains run-length encoded data, but data containing checksums at the end,
+for example, a ZIP file, would be rendered useless.
+
+=head2 5.3 How can I invoke stored procedures with DBI?
+
+The DBI does not define a database-independent way of calling stored procedures.
+
+However, most database that support them also provide a way to call
+them from SQL statements - and the DBI certainly supports that.
+
+So, assuming that you have created a stored procedure within the target
+database, I<eg>, an Oracle database, you can use C<$dbh>->C<do()> to
+immediately execute the procedure. For example,
+
+ $dbh->do( "BEGIN someProcedure; END;" ); # Oracle-specific
+
+You should also be able to C<prepare> and C<execute>, which is
+the recommended way if you'll be calling the procedure often.
+
+=head2 5.4 How can I get return values from stored procedures with DBI?
+
+ Contributed by Jeff Urlwin
+
+ $sth = $dbh->prepare( "BEGIN foo(:1, :2, :3); END;" );
+ $sth->bind_param(1, $a);
+ $sth->bind_param_inout(2, \$path, 2000);
+ $sth->bind_param_inout(3, \$success, 2000);
+ $sth->execute;
+
+Remember to perform error checking, though! ( Or use the C<RaiseError>
+attribute ).
+
+=head2 5.5 How can I create or drop a database with DBI?
+
+Database creation and deletion are concepts that are entirely too abstract
+to be adequately supported by DBI. For example, Oracle does not support the
+concept of dropping a database at all! Also, in Oracle, the database
+I<server> essentially I<is> the database, whereas in mSQL, the
+server process runs happily without any databases created in it. The
+problem is too disparate to attack in a worthwhile way.
+
+Some drivers, therefore, support database creation and deletion through
+the private C<func()> methods. You should check the documentation for
+the drivers you are using to see if they support this mechanism.
+
+=head2 5.6 How can I C<commit> or C<rollback> a statement with DBI?
+
+See the C<commit()> and C<rollback()> methods in the DBI Specification.
+
+Chapter 6 of "Programming the Perl DBI" discusses transaction handling within
+the context of DBI in more detail.
+
+=head2 5.7 How are C<NULL> values handled by DBI?
+
+C<NULL> values in DBI are specified to be treated as the value C<undef>.
+C<NULL>s can be inserted into databases as C<NULL>, for example:
+
+ $rv = $dbh->do( "INSERT INTO table VALUES( NULL )" );
+
+but when queried back, the C<NULL>s should be tested against C<undef>.
+This is standard across all drivers.
+
+=head2 5.8 What are these C<func()> methods all about?
+
+The C<func()> method is defined within DBI as being an entry point
+for database-specific functionality, I<eg>, the ability to create or
+drop databases. Invoking these driver-specific methods is simple, for example,
+to invoke a C<createDatabase> method that has one argument, we would
+write:
+
+ $rv =$dbh->func( 'argument', 'createDatabase' );
+
+Software developers should note that the C<func()> methods are
+non-portable between databases.
+
+=head2 5.9 Is DBI Year 2000 Compliant?
+
+DBI has no knowledge of understanding of what dates are. Therefore, DBI
+itself does not have a Year 2000 problem. Individual drivers may use date
+handling code internally and therefore be potentially susceptible to the
+Year 2000 problem, but this is unlikely.
+
+You may also wish to read the ``Does Perl have a Year 2000 problem?'' section
+of the Perl FAQ at:
+
+ http://www.perl.com/CPAN/doc/FAQs/FAQ/PerlFAQ.html
+
+=head1 Support and Training
+
+The Perl5 Database Interface is I<FREE> software. IT COMES WITHOUT WARRANTY
+OF ANY KIND. See the DBI README for more details.
+
+However, some organizations are providing either technical support or
+training programs on DBI. The present author has no knowledge as
+to the quality of these services. The links are included for reference
+purposes only and should not be regarded as recommendations in any way.
+I<Caveat emptor>.
+
+=head2 Commercial Support
+
+=over 4
+
+=item The Perl Clinic
+
+The Perl Clinic provides commercial support for I<Perl> and Perl
+related problems, including the I<DBI> and its drivers. Support is
+provided by the company with whom Tim Bunce, author of I<DBI> and
+I<DBD::Oracle>, works and ActiveState. For more information on their
+services, please see:
+
+ http://www.perlclinic.com
+
+=back
+
+=head2 Training
+
+=over 4
+
+=item Westlake Solutions
+
+A hands-on class for experienced Perl CGI developers that teaches
+how to write database-connected CGI scripts using Perl and DBI.pm. This
+course, along with four other courses on CGI scripting with Perl, is
+taught in Washington, DC; Arlington, Virginia; and on-site worldwide upon
+request.
+
+See:
+
+ http://www.westlake.com/training
+
+for more details.
+
+=back
+
+=head1 Other References
+
+In this section, we present some miscellaneous WWW links that may be of
+some interest to DBI users. These are not verified and may result in
+unknown sites or missing documents.
+
+ http://www-ccs.cs.umass.edu/db.html
+ http://www.odmg.org/odmg93/updates_dbarry.html
+ http://www.jcc.com/sql_stnd.html
+
+=head1 AUTHOR
+
+Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
+Portions are Copyright their original stated authors.
+
+=head1 COPYRIGHT
+
+This document is Copyright (c)1994-2000 Alligator Descartes, with portions
+Copyright (c)1994-2000 their original authors. This module is released under
+the 'Artistic' license which you can find in the perl distribution.
+
+This document is Copyright (c)1997-2000 Alligator Descartes. All rights reserved.
+Permission to distribute this document, in full or in part, via email,
+Usenet, ftp archives or http is granted providing that no charges are involved,
+reasonable attempt is made to use the most current version and all credits
+and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
+Requests for other distribution rights, including incorporation into
+commercial products, such as books, magazine articles or CD-ROMs should be
+made to Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
+
+=for html
+<!--#include virtual="/technology/perl/DBI/templatebottom.html" -->
+</BODY>
+</HTML>
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Execute.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Execute.pm
new file mode 100755
index 00000000000..95656c727f8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Execute.pm
@@ -0,0 +1,900 @@
+package DBI::Gofer::Execute;
+
+# $Id: Execute.pm 11769 2008-09-12 13:18:59Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+use Carp;
+
+use DBI qw(dbi_time);
+use DBI::Gofer::Request;
+use DBI::Gofer::Response;
+
+use base qw(DBI::Util::_accessor);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 11769 $ =~ /(\d+)/o);
+
+our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common};
+our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)||undef) } @all_dbh_methods;
+
+our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr
+
+our $current_dbh; # the dbh we're using for this request
+
+
+# set trace for server-side gofer
+# Could use DBI_TRACE env var when it's an unrelated separate process
+# but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream)
+DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE};
+
+
+# define valid configuration attributes (args to new())
+# the values here indicate the basic type of values allowed
+my %configuration_attributes = (
+ gofer_execute_class => 1,
+ default_connect_dsn => 1,
+ forced_connect_dsn => 1,
+ default_connect_attributes => {},
+ forced_connect_attributes => {},
+ track_recent => 1,
+ check_request_sub => sub {},
+ check_response_sub => sub {},
+ forced_single_resultset => 1,
+ max_cached_dbh_per_drh => 1,
+ max_cached_sth_per_dbh => 1,
+ forced_response_attributes => {},
+ forced_gofer_random => 1,
+ stats => {},
+);
+
+__PACKAGE__->mk_accessors(
+ keys %configuration_attributes
+);
+
+
+
+sub new {
+ my ($self, $args) = @_;
+ $args->{default_connect_attributes} ||= {};
+ $args->{forced_connect_attributes} ||= {};
+ $args->{max_cached_sth_per_dbh} ||= 1000;
+ $args->{stats} ||= {};
+ return $self->SUPER::new($args);
+}
+
+
+sub valid_configuration_attributes {
+ my $self = shift;
+ return { %configuration_attributes };
+}
+
+
+my %extra_attr = (
+ # Only referenced if the driver doesn't support private_attribute_info method.
+ # What driver-specific attributes should be returned for the driver being used?
+ # keyed by $dbh->{Driver}{Name}
+ # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others
+ # which would reduce processing/traffic for non-select statements
+ mysql => {
+ dbh => [qw(
+ mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid
+ mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id
+ )],
+ sth => [qw(
+ mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment
+ mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid
+ )],
+ # XXX this dbh_after_sth stuff is a temporary, but important, hack.
+ # should be done via hash instead of arrays where the hash value contains
+ # flags that can indicate which attributes need to be handled in this way
+ dbh_after_sth => [qw(
+ mysql_insertid
+ )],
+ },
+ Pg => {
+ dbh => [qw(
+ pg_protocol pg_lib_version pg_server_version
+ pg_db pg_host pg_port pg_default_port
+ pg_options pg_pid
+ )],
+ sth => [qw(
+ pg_size pg_type pg_oid_status pg_cmd_status
+ )],
+ },
+ Sybase => {
+ dbh => [qw(
+ syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string
+ )],
+ sth => [qw(
+ syb_types syb_proc_status syb_result_type
+ )],
+ },
+ SQLite => {
+ dbh => [qw(
+ sqlite_version
+ )],
+ sth => [qw(
+ )],
+ },
+ ExampleP => {
+ dbh => [qw(
+ examplep_private_dbh_attrib
+ )],
+ sth => [qw(
+ examplep_private_sth_attrib
+ )],
+ dbh_after_sth => [qw(
+ examplep_insertid
+ )],
+ },
+);
+
+
+sub _connect {
+ my ($self, $request) = @_;
+
+ my $stats = $self->{stats};
+
+ # discard CachedKids from time to time
+ if (++$stats->{_requests_served} % 1000 == 0 # XXX config?
+ and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh}
+ ) {
+ my %drivers = DBI->installed_drivers();
+ while ( my ($driver, $drh) = each %drivers ) {
+ next unless my $CK = $drh->{CachedKids};
+ next unless keys %$CK > $max_cached_dbh_per_drh;
+ next if $driver eq 'Gofer'; # ie transport=null when testing
+ DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver",
+ scalar keys %$CK, $self->{max_cached_dbh_per_drh});
+ $_->{Active} && $_->disconnect for values %$CK;
+ %$CK = ();
+ }
+ }
+
+ # local $ENV{...} can leak, so only do it if required
+ local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};
+
+ my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call };
+ $connect_method ||= 'connect_cached';
+ $stats->{method_calls_dbh}->{$connect_method}++;
+
+ # delete attributes we don't want to affect the server-side
+ # (Could just do this on client-side and trust the client. DoS?)
+ delete @{$attr}{qw(Profile InactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)};
+
+ $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn
+ or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request";
+
+ my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || '';
+
+ my $connect_attr = {
+
+ # the configured default attributes, if any
+ %{ $self->default_connect_attributes },
+
+ # pass username and password as attributes
+ # then they can be overridden by forced_connect_attributes
+ Username => $username,
+ Password => $password,
+
+ # the requested attributes
+ %$attr,
+
+ # force some attributes the way we'd like them
+ PrintWarn => $local_log,
+ PrintError => $local_log,
+
+ # the configured default attributes, if any
+ %{ $self->forced_connect_attributes },
+
+ # RaiseError must be enabled
+ RaiseError => 1,
+
+ # reset Executed flag (of the cached handle) so we can use it to tell
+ # if errors happened before the main part of the request was executed
+ Executed => 0,
+
+ # ensure this connect_cached doesn't have the same args as the client
+ # because that causes subtle issues if in the same process (ie transport=null)
+ # include pid to avoid problems with forking (ie null transport in mod_perl)
+ # include gofer-random to avoid random behaviour leaking to other handles
+ dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random),
+ };
+
+ # XXX implement our own private connect_cached method? (with rate-limited ping)
+ my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr);
+
+ $dbh->{ShowErrorStatement} = 1 if $local_log;
+
+ # XXX should probably just be a Callbacks => arg to connect_cached
+ # with a cache of pre-built callback hooks (memoized, without $self)
+ if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) {
+ $self->_install_rand_callbacks($dbh, $random);
+ }
+
+ my $CK = $dbh->{CachedKids};
+ if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) {
+ %$CK = (); # clear all statement handles
+ }
+
+ #$dbh->trace(0);
+ $current_dbh = $dbh;
+ return $dbh;
+}
+
+
+sub reset_dbh {
+ my ($self, $dbh) = @_;
+ $dbh->set_err(undef, undef); # clear any error state
+}
+
+
+sub new_response_with_err {
+ my ($self, $rv, $eval_error, $dbh) = @_;
+ # this is the usual way to create a response for both success and failure
+ # capture err+errstr etc and merge in $eval_error ($@)
+
+ my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);
+
+ if ($eval_error) {
+ $err ||= $DBI::stderr || 1; # ensure err is true
+ if ($errstr) {
+ $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr;
+ chomp $errstr;
+ $errstr .= "; $eval_error";
+ }
+ else {
+ $errstr = $eval_error;
+ }
+ }
+ chomp $errstr if $errstr;
+
+ my $flags;
+ # (XXX if we ever add transaction support then we'll need to take extra
+ # steps because the commit/rollback would reset Executed before we get here)
+ $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed};
+
+ my $response = DBI::Gofer::Response->new({
+ rv => $rv,
+ err => $err,
+ errstr => $errstr,
+ state => $state,
+ flags => $flags,
+ });
+
+ return $response;
+}
+
+
+sub execute_request {
+ my ($self, $request) = @_;
+ # should never throw an exception
+
+ DBI->trace_msg("-----> execute_request\n");
+
+ my @warnings;
+ local $SIG{__WARN__} = sub {
+ push @warnings, @_;
+ warn @_ if $local_log;
+ };
+
+ my $response = eval {
+
+ if (my $check_request_sub = $self->check_request_sub) {
+ $request = $check_request_sub->($request, $self)
+ or die "check_request_sub failed";
+ }
+
+ my $version = $request->version || 0;
+ die ref($request)." version $version is not supported"
+ if $version < 0.009116 or $version >= 1;
+
+ ($request->is_sth_request)
+ ? $self->execute_sth_request($request)
+ : $self->execute_dbh_request($request);
+ };
+ $response ||= $self->new_response_with_err(undef, $@, $current_dbh);
+
+ if (my $check_response_sub = $self->check_response_sub) {
+ # not protected with an eval so it can choose to throw an exception
+ my $new = $check_response_sub->($response, $self, $request);
+ $response = $new if ref $new;
+ }
+
+ undef $current_dbh;
+
+ $response->warnings(\@warnings) if @warnings;
+ DBI->trace_msg("<----- execute_request\n");
+ return $response;
+}
+
+
+sub execute_dbh_request {
+ my ($self, $request) = @_;
+ my $stats = $self->{stats};
+
+ my $dbh;
+ my $rv_ref = eval {
+ $dbh = $self->_connect($request);
+ my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ]
+ my $wantarray = shift @$args;
+ my $meth = shift @$args;
+ $stats->{method_calls_dbh}->{$meth}++;
+ my @rv = ($wantarray)
+ ? $dbh->$meth(@$args)
+ : scalar $dbh->$meth(@$args);
+ \@rv;
+ } || [];
+ my $response = $self->new_response_with_err($rv_ref, $@, $dbh);
+
+ return $response if not $dbh;
+
+ # does this request also want any dbh attributes returned?
+ if (my $dbh_attributes = $request->dbh_attributes) {
+ $response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) );
+ }
+
+ if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
+ $stats->{method_calls_dbh}->{last_insert_id}++;
+ my $id = $dbh->last_insert_id( @$lid_args );
+ $response->last_insert_id( $id );
+ }
+
+ if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) {
+ # dbh_method_call was probably a metadata method like table_info
+ # that returns a statement handle, so turn the $sth into resultset
+ my $sth = $rv_ref->[0];
+ $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) );
+ $response->rv("(sth)"); # don't try to return actual sth
+ }
+
+ # we're finished with this dbh for this request
+ $self->reset_dbh($dbh);
+
+ return $response;
+}
+
+
+sub gather_dbh_attributes {
+ my ($self, $dbh, $dbh_attributes) = @_;
+ my @req_attr_names = @$dbh_attributes;
+ if ($req_attr_names[0] eq '*') { # auto include std + private
+ shift @req_attr_names;
+ push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) };
+ }
+ my %dbh_attr_values;
+ @dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names);
+
+ # XXX piggyback installed_methods onto dbh_attributes for now
+ $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods };
+
+ # XXX piggyback default_methods onto dbh_attributes for now
+ $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh);
+
+ return \%dbh_attr_values;
+}
+
+
+sub _std_response_attribute_names {
+ my ($self, $h) = @_;
+ $h = tied(%$h) || $h; # switch to inner handle
+
+ # cache the private_attribute_info data for each handle
+ # XXX might be better to cache it in the executor
+ # as it's unlikely to change
+ # or perhaps at least cache it in the dbh even for sth
+ # as the sth are typically very short lived
+
+ my ($dbh, $h_type, $driver_name, @attr_names);
+
+ if ($dbh = $h->{Database}) { # is an sth
+
+ # does the dbh already have the answer cached?
+ return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth};
+
+ ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name});
+ push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE);
+ }
+ else { # is a dbh
+ return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh};
+
+ ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h);
+ # explicitly add these because drivers may have different defaults
+ # add Name so the client gets the real Name of the connection
+ push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name);
+ }
+
+ if (my $pai = $h->private_attribute_info) {
+ push @attr_names, keys %$pai;
+ }
+ else {
+ push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []};
+ }
+ if (my $fra = $self->{forced_response_attributes}) {
+ push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []}
+ }
+ $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n");
+
+ # cache into the dbh even for sth, as the dbh is usually longer lived
+ return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names;
+}
+
+
+sub execute_sth_request {
+ my ($self, $request) = @_;
+ my $dbh;
+ my $sth;
+ my $last_insert_id;
+ my $stats = $self->{stats};
+
+ my $rv = eval {
+ $dbh = $self->_connect($request);
+
+ my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ]
+ shift @$args; # discard wantarray
+ my $meth = shift @$args;
+ $stats->{method_calls_sth}->{$meth}++;
+ $sth = $dbh->$meth(@$args);
+ my $last = '(sth)'; # a true value (don't try to return actual sth)
+
+ # execute methods on the sth, e.g., bind_param & execute
+ if (my $calls = $request->sth_method_calls) {
+ for my $meth_call (@$calls) {
+ my $method = shift @$meth_call;
+ $stats->{method_calls_sth}->{$method}++;
+ $last = $sth->$method(@$meth_call);
+ }
+ }
+
+ if (my $lid_args = $request->dbh_last_insert_id_args) {
+ $stats->{method_calls_sth}->{last_insert_id}++;
+ $last_insert_id = $dbh->last_insert_id( @$lid_args );
+ }
+
+ $last;
+ };
+ my $response = $self->new_response_with_err($rv, $@, $dbh);
+
+ return $response if not $dbh;
+
+ $response->last_insert_id( $last_insert_id )
+ if defined $last_insert_id;
+
+ # even if the eval failed we still want to try to gather attribute values
+ # (XXX would be nice to be able to support streaming of results.
+ # which would reduce memory usage and latency for large results)
+ if ($sth) {
+ $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) );
+ $sth->finish;
+ }
+
+ # does this request also want any dbh attributes returned?
+ my $dbh_attr_set;
+ if (my $dbh_attributes = $request->dbh_attributes) {
+ $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes);
+ }
+ # XXX needs to be integrated with private_attribute_info() etc
+ if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) {
+ @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr);
+ }
+ $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set;
+
+ $self->reset_dbh($dbh);
+
+ return $response;
+}
+
+
+sub gather_sth_resultsets {
+ my ($self, $sth, $request, $response) = @_;
+ my $resultsets = eval {
+
+ my $attr_names = $self->_std_response_attribute_names($sth);
+ my $sth_attr = {};
+ $sth_attr->{$_} = 1 for @$attr_names;
+
+ # let the client add/remove sth atributes
+ if (my $sth_result_attr = $request->sth_result_attr) {
+ $sth_attr->{$_} = $sth_result_attr->{$_}
+ for keys %$sth_result_attr;
+ }
+ my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr;
+
+ my $row_count = 0;
+ my $rs_list = [];
+ while (1) {
+ my $rs = $self->fetch_result_set($sth, \@sth_attr);
+ push @$rs_list, $rs;
+ if (my $rows = $rs->{rowset}) {
+ $row_count += @$rows;
+ }
+ last if $self->{forced_single_resultset};
+ last if !($sth->more_results || $sth->{syb_more_results});
+ }
+
+ my $stats = $self->{stats};
+ $stats->{rows_returned_total} += $row_count;
+ $stats->{rows_returned_max} = $row_count
+ if $row_count > ($stats->{rows_returned_max}||0);
+
+ $rs_list;
+ };
+ $response->add_err(1, $@) if $@;
+ return $resultsets;
+}
+
+
+sub fetch_result_set {
+ my ($self, $sth, $sth_attr) = @_;
+ my %meta;
+ eval {
+ @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr);
+ # we assume @$sth_attr contains NUM_OF_FIELDS
+ $meta{rowset} = $sth->fetchall_arrayref()
+ if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT
+ # the fetchall_arrayref may fail with a 'not executed' kind of error
+ # because gather_sth_resultsets/fetch_result_set are called even if
+ # execute() failed, or even if there was no execute() call at all.
+ # The corresponding error goes into the resultset err, not the top-level
+ # response err, so in most cases this resultset err is never noticed.
+ };
+ if ($@) {
+ chomp $@;
+ $meta{err} = $DBI::err || 1;
+ $meta{errstr} = $DBI::errstr || $@;
+ $meta{state} = $DBI::state;
+ }
+ return \%meta;
+}
+
+
+sub _get_default_methods {
+ my ($dbh) = @_;
+ # returns a ref to a hash of dbh method names for methods which the driver
+ # hasn't overridden i.e., quote(). These don't need to be forwarded via gofer.
+ my $ImplementorClass = $dbh->{ImplementorClass} or die;
+ my %default_methods;
+ for my $method (@all_dbh_methods) {
+ my $dbi_sub = $all_dbh_methods{$method} || 42;
+ my $imp_sub = $ImplementorClass->can($method) || 42;
+ next if $imp_sub != $dbi_sub;
+ #warn("default $method\n");
+ $default_methods{$method} = 1;
+ }
+ return \%default_methods;
+}
+
+
+# XXX would be nice to make this a generic DBI module
+sub _install_rand_callbacks {
+ my ($self, $dbh, $dbi_gofer_random) = @_;
+
+ my $callbacks = $dbh->{Callbacks} || {};
+ my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {};
+
+ # return if we've already setup this handle with callbacks for these specs
+ return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random);
+ #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}";
+ $callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random;
+
+ my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note);
+ my @specs = split /,/, $dbi_gofer_random;
+ for my $spec (@specs) {
+ if ($spec =~ m/^fail=(-?[.\d]+)%?$/) {
+ $fail_percent = $1;
+ $spec_part{fail} = $spec;
+ next;
+ }
+ if ($spec =~ m/^err=(-?\d+)$/) {
+ $fail_err = $1;
+ $spec_part{err} = $spec;
+ next;
+ }
+ if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) {
+ $delay_duration = $1;
+ $delay_percent = $2;
+ $spec_part{delay} = $spec;
+ next;
+ }
+ elsif ($spec !~ m/^(\w+|\*)$/) {
+ warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name";
+ next;
+ }
+
+ my $method = $spec;
+ if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) {
+ warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n";
+ next;
+ }
+ unless (defined $fail_percent or defined $delay_percent) {
+ warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceeded by 'fail=N' and/or 'delayN=N'";
+ next;
+ }
+
+ push @spec_note, join(",", values(%spec_part), $method);
+ $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err);
+ }
+ warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n"
+ if @spec_note;
+ $dbh->{Callbacks} = $callbacks;
+ $dbh->{private_gofer_rand_fail_callbacks} = $callbacks;
+}
+
+my %_mk_rand_callback_seqn;
+
+sub _mk_rand_callback {
+ my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_;
+ my ($fail_modrate, $delay_modrate);
+ $fail_percent ||= 0; $fail_modrate = int(1/(-$fail_percent )*100) if $fail_percent;
+ $delay_percent ||= 0; $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent;
+ # note that $method may be "*" but that's not recommended or documented or wise
+ return sub {
+ my ($h) = @_;
+ my $seqn = ++$_mk_rand_callback_seqn{$method};
+ my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent :
+ ($delay_percent < 0) ? !($seqn % $delay_modrate): 0;
+ my $fail = ($fail_percent > 0) ? rand(100) < $fail_percent :
+ ($fail_percent < 0) ? !($seqn % $fail_modrate) : 0;
+ #no warnings 'uninitialized';
+ #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay";
+ if ($delay) {
+ my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n";
+ # Note what's happening in a trace message. If the delay percent is an even
+ # number then use warn() instead so it's sent back to the client.
+ ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg);
+ select undef, undef, undef, $delay_duration; # allows floating point value
+ }
+ if ($fail) {
+ undef $_; # tell DBI to not call the method
+ # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr
+ # as it's checked for in a few places, such as the gofer retry logic
+ return $h->set_err($fail_err || $DBI::stderr,
+ "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)");
+ }
+ return;
+ }
+}
+
+
+sub update_stats {
+ my ($self,
+ $request, $response,
+ $frozen_request, $frozen_response,
+ $time_received,
+ $store_meta, $other_meta,
+ ) = @_;
+
+ # should always have a response object here
+ carp("No response object provided") unless $request;
+
+ my $stats = $self->{stats};
+ $stats->{frozen_request_max_bytes} = length($frozen_request)
+ if $frozen_request
+ && length($frozen_request) > ($stats->{frozen_request_max_bytes}||0);
+ $stats->{frozen_response_max_bytes} = length($frozen_response)
+ if $frozen_response
+ && length($frozen_response) > ($stats->{frozen_response_max_bytes}||0);
+
+ my $recent;
+ if (my $track_recent = $self->{track_recent}) {
+ $recent = {
+ request => $frozen_request,
+ response => $frozen_response,
+ time_received => $time_received,
+ duration => dbi_time()-$time_received,
+ # for any other info
+ ($store_meta) ? (meta => $store_meta) : (),
+ };
+ $recent->{request_object} = $request
+ if !$frozen_request && $request;
+ $recent->{response_object} = $response
+ if !$frozen_response;
+ my @queues = ($stats->{recent_requests} ||= []);
+ push @queues, ($stats->{recent_errors} ||= [])
+ if !$response or $response->err;
+ for my $queue (@queues) {
+ push @$queue, $recent;
+ shift @$queue if @$queue > $track_recent;
+ }
+ }
+ return $recent;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+DBI::Gofer::Execute - Executes Gofer requests and returns Gofer responses
+
+=head1 SYNOPSIS
+
+ $executor = DBI::Gofer::Execute->new( { ...config... });
+
+ $response = $executor->execute_request( $request );
+
+=head1 DESCRIPTION
+
+Accepts a DBI::Gofer::Request object, executes the requested DBI method calls,
+and returns a DBI::Gofer::Response object.
+
+Any error, including any internal 'fatal' errors are caught and converted into
+a DBI::Gofer::Response object.
+
+This module is usually invoked by a 'server-side' Gofer transport module.
+They usually have names in the "C<DBI::Gofer::Transport::*>" namespace.
+Examples include: L<DBI::Gofer::Transport::stream> and L<DBI::Gofer::Transport::mod_perl>.
+
+=head1 CONFIGURATION
+
+=head2 check_request_sub
+
+If defined, it must be a reference to a subroutine that will 'check' the request.
+It is passed the request object and the executor as its only arguments.
+
+The subroutine can either return the original request object or die with a
+suitable error message (which will be turned into a Gofer response).
+
+It can also construct and return a new request that should be executed instead
+of the original request.
+
+=head2 check_response_sub
+
+If defined, it must be a reference to a subroutine that will 'check' the response.
+It is passed the response object, the executor, and the request object.
+The sub may alter the response object and return undef, or return a new response object.
+
+This mechanism can be used to, for example, terminate the service if specific
+database errors are seen.
+
+=head2 forced_connect_dsn
+
+If set, this DSN is always used instead of the one in the request.
+
+=head2 default_connect_dsn
+
+If set, this DSN is used if C<forced_connect_dsn> is not set and the request does not contain a DSN itself.
+
+=head2 forced_connect_attributes
+
+A reference to a hash of connect() attributes. Individual attributes in
+C<forced_connect_attributes> will take precedence over corresponding attributes
+in the request.
+
+=head2 default_connect_attributes
+
+A reference to a hash of connect() attributes. Individual attributes in the
+request take precedence over corresponding attributes in C<default_connect_attributes>.
+
+=head2 max_cached_dbh_per_drh
+
+If set, the loaded drivers will be checked to ensure they don't have more than
+this number of cached connections. There is no default value. This limit is not
+enforced for every request.
+
+=head2 max_cached_sth_per_dbh
+
+If set, all the cached statement handles will be cleared once the number of
+cached statement handles rises above this limit. The default is 1000.
+
+=head2 forced_single_resultset
+
+If true, then only the first result set will be fetched and returned in the response.
+
+=head2 forced_response_attributes
+
+A reference to a data structure that can specify extra attributes to be returned in responses.
+
+ forced_response_attributes => {
+ DriverName => {
+ dbh => [ qw(dbh_attrib_name) ],
+ sth => [ qw(sth_attrib_name) ],
+ },
+ },
+
+This can be useful in cases where the driver has not implemented the
+private_attribute_info() method and DBI::Gofer::Execute's own fallback list of
+private attributes doesn't include the driver or attributes you need.
+
+=head2 track_recent
+
+If set, specifies the number of recent requests and responses that should be
+kept by the update_stats() method for diagnostics. See L<DBI::Gofer::Transport::mod_perl>.
+
+Note that this setting can significantly increase memory use. Use with caution.
+
+=head2 forced_gofer_random
+
+Enable forced random failures and/or delays for testing. See L</DBI_GOFER_RANDOM> below.
+
+=head1 DRIVER-SPECIFIC ISSUES
+
+Gofer needs to know about any driver-private attributes that should have their
+values sent back to the client.
+
+If the driver doesn't support private_attribute_info() method, and very few do,
+then the module fallsback to using some hard-coded details, if available, for
+the driver being used. Currently hard-coded details are available for the
+mysql, Pg, Sybase, and SQLite drivers.
+
+=head1 TESTING
+
+DBD::Gofer, DBD::Execute and related packages are well tested by executing the
+DBI test suite with DBI_AUTOPROXY configured to route all DBI calls via DBD::Gofer.
+
+Because Gofer includes timeout and 'retry on error' mechanisms there is a need
+for some way to trigger delays and/or errors. This can be done via the
+C<forced_gofer_random> configuration item, or else the DBI_GOFER_RANDOM environment
+variable.
+
+=head2 DBI_GOFER_RANDOM
+
+The value of the C<forced_gofer_random> configuration item (or else the
+DBI_GOFER_RANDOM environment variable) is treated as a series of tokens
+separated by commas.
+
+The tokens can be one of three types:
+
+=over 4
+
+=item fail=R%
+
+Set the current failure rate to R where R is a percentage.
+The value R can be floating point, e.g., C<fail=0.05%>.
+Negative values for R have special meaning, see below.
+
+=item err=N
+
+Sets the current failure err vaue to N (instead of the DBI's default 'standard
+err value' of 2000000000). This is useful when you want to simulate a
+specific error.
+
+=item delayN=R%
+
+Set the current random delay rate to R where R is a percentage, and set the
+current delay duration to N seconds. The values of R and N can be floating point,
+e.g., C<delay0.5=0.2%>. Negative values for R have special meaning, see below.
+
+If R is an odd number (R % 2 == 1) then a message is logged via warn() which
+will be returned to, and echoed at, the client.
+
+=item methodname
+
+Applies the current fail, err, and delay values to the named method.
+If neither a fail nor delay have been set yet then a warning is generated.
+
+=back
+
+For example:
+
+ $executor = DBI::Gofer::Execute->new( {
+ forced_gofer_random => "fail=0.01%,do,delay60=1%,execute",
+ });
+
+will cause the do() method to fail for 0.01% of calls, and the execute() method to
+fail 0.01% of calls and be delayed by 60 seconds on 1% of calls.
+
+If the percentage value (C<R>) is negative then instead of the failures being
+triggered randomly (via the rand() function) they are triggered via a sequence
+number. In other words "C<fail=-20%>" will mean every fifth call will fail.
+Each method has a distinct sequence number.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Request.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Request.pm
new file mode 100755
index 00000000000..d6464a67bf5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Request.pm
@@ -0,0 +1,200 @@
+package DBI::Gofer::Request;
+
+# $Id: Request.pm 12536 2009-02-24 22:37:09Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+
+use DBI qw(neat neat_list);
+
+use base qw(DBI::Util::_accessor);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
+
+use constant GOf_REQUEST_IDEMPOTENT => 0x0001;
+use constant GOf_REQUEST_READONLY => 0x0002;
+
+our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY);
+
+
+__PACKAGE__->mk_accessors(qw(
+ version
+ flags
+ dbh_connect_call
+ dbh_method_call
+ dbh_attributes
+ dbh_last_insert_id_args
+ sth_method_calls
+ sth_result_attr
+));
+__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
+ meta
+));
+
+
+sub new {
+ my ($self, $args) = @_;
+ $args->{version} ||= $VERSION;
+ return $self->SUPER::new($args);
+}
+
+
+sub reset {
+ my ($self, $flags) = @_;
+ # remove everything except connect and version
+ %$self = (
+ version => $self->{version},
+ dbh_connect_call => $self->{dbh_connect_call},
+ );
+ $self->{flags} = $flags if $flags;
+}
+
+
+sub init_request {
+ my ($self, $method_and_args, $dbh) = @_;
+ $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 );
+ $self->dbh_method_call($method_and_args);
+}
+
+
+sub is_sth_request {
+ return shift->{sth_result_attr};
+}
+
+
+sub statements {
+ my $self = shift;
+ my @statements;
+ if (my $dbh_method_call = $self->dbh_method_call) {
+ my $statement_method_regex = qr/^(?:do|prepare)$/;
+ my (undef, $method, $arg1) = @$dbh_method_call;
+ push @statements, $arg1 if $method && $method =~ $statement_method_regex;
+ }
+ return @statements;
+}
+
+
+sub is_idempotent {
+ my $self = shift;
+
+ if (my $flags = $self->flags) {
+ return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY);
+ }
+
+ # else check if all statements are SELECT statement that don't include FOR UPDATE
+ my @statements = $self->statements;
+ # XXX this is very minimal for now, doesn't even allow comments before the select
+ # (and can't ever work for "exec stored_procedure_name" kinds of statements)
+ # XXX it also doesn't deal with multiple statements: prepare("select foo; update bar")
+ return 1 if @statements == grep {
+ m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi
+ } @statements;
+
+ return 0;
+}
+
+
+sub summary_as_text {
+ my $self = shift;
+ my ($context) = @_;
+ my @s = '';
+
+ if ($context && %$context) {
+ my @keys = sort keys %$context;
+ push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
+ }
+
+ my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call };
+ $method ||= 'connect_cached';
+ $pass = '***' if defined $pass;
+ my $tmp = '';
+ if ($attr) {
+ $tmp = { %{$attr||{}} }; # copy so we can edit
+ $tmp->{Password} = '***' if exists $tmp->{Password};
+ $tmp = "{ ".neat_list([ %$tmp ])." }";
+ }
+ push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp;
+
+ if (my $flags = $self->flags) {
+ push @s, sprintf "flags: 0x%x", $flags;
+ }
+
+ if (my $dbh_attr = $self->dbh_attributes) {
+ push @s, sprintf "dbh->FETCH: %s", @$dbh_attr
+ if @$dbh_attr;
+ }
+
+ my ($wantarray, $meth, @args) = @{ $self->dbh_method_call };
+ my $args = neat_list(\@args);
+ $args =~ s/\n+/ /g;
+ push @s, sprintf "dbh->%s(%s)", $meth, $args;
+
+ if (my $lii_args = $self->dbh_last_insert_id_args) {
+ push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args);
+ }
+
+ for my $call (@{ $self->sth_method_calls || [] }) {
+ my ($meth, @args) = @$call;
+ ($args = neat_list(\@args)) =~ s/\n+/ /g;
+ push @s, sprintf "sth->%s(%s)", $meth, $args;
+ }
+
+ if (my $sth_attr = $self->sth_result_attr) {
+ push @s, sprintf "sth->FETCH: %s", %$sth_attr
+ if %$sth_attr;
+ }
+
+ return join("\n\t", @s) . "\n";
+}
+
+
+sub outline_as_text { # one-line version of summary_as_text
+ my $self = shift;
+ my @s = '';
+ my $neatlen = 80;
+
+ if (my $flags = $self->flags) {
+ push @s, sprintf "flags=0x%x", $flags;
+ }
+
+ my (undef, $meth, @args) = @{ $self->dbh_method_call };
+ push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen);
+
+ for my $call (@{ $self->sth_method_calls || [] }) {
+ my ($meth, @args) = @$call;
+ push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen);
+ }
+
+ my ($method, $dsn) = @{ $self->dbh_connect_call };
+ push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting
+
+ (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines
+ return $outline;
+}
+
+1;
+
+=head1 NAME
+
+DBI::Gofer::Request - Encapsulate a request from DBD::Gofer to DBI::Gofer::Execute
+
+=head1 DESCRIPTION
+
+This is an internal class.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Response.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Response.pm
new file mode 100755
index 00000000000..b09782e631b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Response.pm
@@ -0,0 +1,218 @@
+package DBI::Gofer::Response;
+
+# $Id: Response.pm 11565 2008-07-22 20:17:33Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+
+use Carp;
+use DBI qw(neat neat_list);
+
+use base qw(DBI::Util::_accessor Exporter);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 11565 $ =~ /(\d+)/o);
+
+use constant GOf_RESPONSE_EXECUTED => 0x0001;
+
+our @EXPORT = qw(GOf_RESPONSE_EXECUTED);
+
+
+__PACKAGE__->mk_accessors(qw(
+ version
+ rv
+ err
+ errstr
+ state
+ flags
+ last_insert_id
+ dbh_attributes
+ sth_resultsets
+ warnings
+));
+__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
+ meta
+));
+
+
+sub new {
+ my ($self, $args) = @_;
+ $args->{version} ||= $VERSION;
+ chomp $args->{errstr} if $args->{errstr};
+ return $self->SUPER::new($args);
+}
+
+
+sub err_errstr_state {
+ my $self = shift;
+ return @{$self}{qw(err errstr state)};
+}
+
+sub executed_flag_set {
+ my $flags = shift->flags
+ or return 0;
+ return $flags & GOf_RESPONSE_EXECUTED;
+}
+
+
+sub add_err {
+ my ($self, $err, $errstr, $state, $trace) = @_;
+
+ # acts like the DBI's set_err method.
+ # this code copied from DBI::PurePerl's set_err method.
+
+ chomp $errstr if $errstr;
+ $state ||= '';
+ carp ref($self)."->add_err($err, $errstr, $state)"
+ if $trace and defined($err) || $errstr;
+
+ my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr}, $self->{state});
+
+ if ($r_errstr) {
+ $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err
+ if $r_err && $err && $r_err ne $err;
+ $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state
+ if $r_state and $r_state ne "S1000" && $state && $r_state ne $state;
+ $r_errstr .= "\n$errstr" if $r_errstr ne $errstr;
+ }
+ else {
+ $r_errstr = $errstr;
+ }
+
+ # assign if higher priority: err > "0" > "" > undef
+ my $err_changed;
+ if ($err # new error: so assign
+ or !defined $r_err # no existing warn/info: so assign
+ # new warn ("0" len 1) > info ("" len 0): so assign
+ or defined $err && length($err) > length($r_err)
+ ) {
+ $r_err = $err;
+ ++$err_changed;
+ }
+
+ $r_state = ($state eq "00000") ? "" : $state
+ if $state && $err_changed;
+
+ ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr, $r_state);
+
+ return undef;
+}
+
+
+sub summary_as_text {
+ my $self = shift;
+ my ($context) = @_;
+
+ my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state});
+
+ my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
+ $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr))
+ if defined $err;
+ $s[-1] .= sprintf(", flags=0x%x", $self->{flags})
+ if defined $self->{flags};
+
+ push @s, "last_insert_id=%s", $self->last_insert_id
+ if defined $self->last_insert_id;
+
+ if (my $dbh_attr = $self->dbh_attributes) {
+ my @keys = sort keys %$dbh_attr;
+ push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys)
+ if @keys;
+ }
+
+ for my $rs (@{$self->sth_resultsets || []}) {
+ my ($rowset, $err, $errstr, $state)
+ = @{$rs}{qw(rowset err errstr state)};
+ my $summary = "rowset: ";
+ my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
+ my $rows = $rowset ? @$rowset : 0;
+ if ($rowset || $NUM_OF_FIELDS > 0) {
+ $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS;
+ }
+ $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err;
+ if ($rows) {
+ my $NAME = $rs->{NAME};
+ # generate
+ my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1;
+ $summary .= sprintf " [%s]", join ", ", @colinfo;
+ $summary .= ",..." if $rows > 1;
+ # we can be a little more helpful for Sybase/MSSQL user
+ $summary .= " syb_result_type=$rs->{syb_result_type}"
+ if $rs->{syb_result_type} and $rs->{syb_result_type} != 4040;
+ }
+ push @s, $summary;
+ }
+ for my $w (@{$self->warnings || []}) {
+ chomp $w;
+ push @s, "warning: $w";
+ }
+ if ($context && %$context) {
+ my @keys = sort keys %$context;
+ push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
+ }
+ return join("\n\t", @s). "\n";
+}
+
+
+sub outline_as_text { # one-line version of summary_as_text
+ my $self = shift;
+ my ($context) = @_;
+
+ my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state});
+
+ my $s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
+ $s .= sprintf(", err=%s %s", $err, neat($errstr))
+ if defined $err;
+ $s .= sprintf(", flags=0x%x", $self->{flags})
+ if $self->{flags};
+
+ if (my $sth_resultsets = $self->sth_resultsets) {
+ $s .= sprintf(", %d resultsets ", scalar @$sth_resultsets);
+
+ my @rs;
+ for my $rs (@{$self->sth_resultsets || []}) {
+ my $summary = "";
+ my ($rowset, $err, $errstr)
+ = @{$rs}{qw(rowset err errstr)};
+ my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
+ my $rows = $rowset ? @$rowset : 0;
+ if ($rowset || $NUM_OF_FIELDS > 0) {
+ $summary .= sprintf "%dr x %dc", $rows, $NUM_OF_FIELDS;
+ }
+ $summary .= sprintf "%serr %s %s", ($summary?", ":""), $err, neat($errstr)
+ if defined $err;
+ push @rs, $summary;
+ }
+ $s .= join "; ", map { "[$_]" } @rs;
+ }
+
+ return $s;
+}
+
+
+1;
+
+=head1 NAME
+
+DBI::Gofer::Response - Encapsulate a response from DBI::Gofer::Execute to DBD::Gofer
+
+=head1 DESCRIPTION
+
+This is an internal class.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Base.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Base.pm
new file mode 100755
index 00000000000..53fc7e706e1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Base.pm
@@ -0,0 +1,64 @@
+package DBI::Gofer::Serializer::Base;
+
+# $Id: Base.pm 9949 2007-09-18 09:38:15Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+=head1 NAME
+
+DBI::Gofer::Serializer::Base - base class for Gofer serialization
+
+=head1 SYNOPSIS
+
+ $serializer = $serializer_class->new();
+
+ $string = $serializer->serialize( $data );
+ ($string, $deserializer_class) = $serializer->serialize( $data );
+
+ $data = $serializer->deserialize( $string );
+
+=head1 DESCRIPTION
+
+DBI::Gofer::Serializer::* classes implement a very minimal subset of the L<Data::Serializer> API.
+
+Gofer serializers are expected to be very fast and are not required to deal
+with anything other than non-blessed references to arrays and hashes, and plain scalars.
+
+=cut
+
+
+use strict;
+use warnings;
+
+use Carp qw(croak);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
+
+
+sub new {
+ my $class = shift;
+ my $deserializer_class = $class->deserializer_class;
+ return bless { deserializer_class => $deserializer_class } => $class;
+}
+
+sub deserializer_class {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ $class =~ s/^DBI::Gofer::Serializer:://;
+ return $class;
+}
+
+sub serialize {
+ my $self = shift;
+ croak ref($self)." has not implemented the serialize method";
+}
+
+sub deserialize {
+ my $self = shift;
+ croak ref($self)." has not implemented the deserialize method";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/DataDumper.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/DataDumper.pm
new file mode 100755
index 00000000000..c6fc3a1f80e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/DataDumper.pm
@@ -0,0 +1,53 @@
+package DBI::Gofer::Serializer::DataDumper;
+
+use strict;
+use warnings;
+
+our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
+
+# $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+=head1 NAME
+
+DBI::Gofer::Serializer::DataDumper - Gofer serialization using DataDumper
+
+=head1 SYNOPSIS
+
+ $serializer = DBI::Gofer::Serializer::DataDumper->new();
+
+ $string = $serializer->serialize( $data );
+
+=head1 DESCRIPTION
+
+Uses DataDumper to serialize. Deserialization is not supported.
+The output of this class is only meant for human consumption.
+
+See also L<DBI::Gofer::Serializer::Base>.
+
+=cut
+
+use Data::Dumper;
+
+use base qw(DBI::Gofer::Serializer::Base);
+
+
+sub serialize {
+ my $self = shift;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Useqq = 0; # enabling this disables xs
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Deparse = 0;
+ local $Data::Dumper::Purity = 0;
+ my $frozen = Data::Dumper::Dumper(shift);
+ return $frozen unless wantarray;
+ return ($frozen, $self->{deserializer_class});
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Storable.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Storable.pm
new file mode 100755
index 00000000000..9a571bd96fb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Serializer/Storable.pm
@@ -0,0 +1,59 @@
+package DBI::Gofer::Serializer::Storable;
+
+use strict;
+use warnings;
+
+use base qw(DBI::Gofer::Serializer::Base);
+
+# $Id: Storable.pm 9949 2007-09-18 09:38:15Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+=head1 NAME
+
+DBI::Gofer::Serializer::Storable - Gofer serialization using Storable
+
+=head1 SYNOPSIS
+
+ $serializer = DBI::Gofer::Serializer::Storable->new();
+
+ $string = $serializer->serialize( $data );
+ ($string, $deserializer_class) = $serializer->serialize( $data );
+
+ $data = $serializer->deserialize( $string );
+
+=head1 DESCRIPTION
+
+Uses Storable::nfreeze() to serialize and Storable::thaw() to deserialize.
+
+The serialize() method sets local $Storable::forgive_me = 1; so it doesn't
+croak if it encounters any data types that can't be serialized, such as code refs.
+
+See also L<DBI::Gofer::Serializer::Base>.
+
+=cut
+
+use Storable qw(nfreeze thaw);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
+
+use base qw(DBI::Gofer::Serializer::Base);
+
+
+sub serialize {
+ my $self = shift;
+ local $Storable::forgive_me = 1; # for CODE refs etc
+ my $frozen = nfreeze(shift);
+ return $frozen unless wantarray;
+ return ($frozen, $self->{deserializer_class});
+}
+
+sub deserialize {
+ my $self = shift;
+ return thaw(shift);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/Base.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/Base.pm
new file mode 100755
index 00000000000..b688689b477
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/Base.pm
@@ -0,0 +1,176 @@
+package DBI::Gofer::Transport::Base;
+
+# $Id: Base.pm 12536 2009-02-24 22:37:09Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+use DBI;
+
+use base qw(DBI::Util::_accessor);
+
+use DBI::Gofer::Serializer::Storable;
+use DBI::Gofer::Serializer::DataDumper;
+
+
+our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
+
+
+__PACKAGE__->mk_accessors(qw(
+ trace
+ keep_meta_frozen
+ serializer_obj
+));
+
+
+# see also $ENV{DBI_GOFER_TRACE} in DBI::Gofer::Execute
+sub _init_trace { (split(/=/,$ENV{DBI_GOFER_TRACE}||0))[0] }
+
+
+sub new {
+ my ($class, $args) = @_;
+ $args->{trace} ||= $class->_init_trace;
+ $args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new();
+ my $self = bless {}, $class;
+ $self->$_( $args->{$_} ) for keys %$args;
+ $self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace;
+ return $self;
+}
+
+my $packet_header_text = "GoFER1:";
+my $packet_header_regex = qr/^GoFER(\d+):/;
+
+
+sub _freeze_data {
+ my ($self, $data, $serializer, $skip_trace) = @_;
+ my $frozen = eval {
+ $self->_dump("freezing $self->{trace} ".ref($data), $data)
+ if !$skip_trace and $self->trace;
+
+ local $data->{meta}; # don't include meta in serialization
+ $serializer ||= $self->{serializer_obj};
+ my ($data, $deserializer_class) = $serializer->serialize($data);
+
+ $packet_header_text . $data;
+ };
+ if ($@) {
+ chomp $@;
+ die "Error freezing ".ref($data)." object: $@";
+ }
+
+ # stash the frozen data into the data structure itself
+ # to make life easy for the client caching code in DBD::Gofer::Transport::Base
+ $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen;
+
+ return $frozen;
+}
+# public aliases used by subclasses
+*freeze_request = \&_freeze_data;
+*freeze_response = \&_freeze_data;
+
+
+sub _thaw_data {
+ my ($self, $frozen_data, $serializer, $skip_trace) = @_;
+ my $data;
+ eval {
+ # check for and extract our gofer header and the info it contains
+ (my $frozen = $frozen_data) =~ s/$packet_header_regex//o
+ or die "does not have gofer header\n";
+ my ($t_version) = $1;
+ $serializer ||= $self->{serializer_obj};
+ $data = $serializer->deserialize($frozen);
+ die ref($serializer)."->deserialize didn't return a reference"
+ unless ref $data;
+ $data->{_transport}{version} = $t_version;
+
+ $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen;
+ };
+ if ($@) {
+ chomp(my $err = $@);
+ # remove extra noise from Storable
+ $err =~ s{ at \S+?/Storable.pm \(autosplit into \S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{};
+ my $msg = sprintf "Error thawing: %s (data=%s)", $err, DBI::neat($frozen_data,50);
+ Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if $self->trace;
+ die $msg;
+ }
+ $self->_dump("thawing $self->{trace} ".ref($data), $data)
+ if !$skip_trace and $self->trace;
+
+ return $data;
+}
+# public aliases used by subclasses
+*thaw_request = \&_thaw_data;
+*thaw_response = \&_thaw_data;
+
+
+# this should probably live in the request and response classes
+# and the tace level passed in
+sub _dump {
+ my ($self, $label, $data) = @_;
+
+ # don't dump the binary
+ local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen};
+
+ my $trace_level = $self->trace;
+ my $summary;
+ if ($trace_level >= 4) {
+ require Data::Dumper;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Useqq = 0;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Deparse = 0;
+ local $Data::Dumper::Purity = 0;
+ $summary = Data::Dumper::Dumper($data);
+ }
+ elsif ($trace_level >= 2) {
+ $summary = eval { $data->summary_as_text } || $@ || "no summary available\n";
+ }
+ else {
+ $summary = eval { $data->outline_as_text."\n" } || $@ || "no summary available\n";
+ }
+ $self->trace_msg("$label: $summary");
+}
+
+
+sub trace_msg {
+ my ($self, $msg, $min_level) = @_;
+ $min_level = 1 unless defined $min_level;
+ # transport trace level can override DBI's trace level
+ $min_level = 0 if $self->trace >= $min_level;
+ return DBI->trace_msg("gofer ".$msg, $min_level);
+}
+
+1;
+
+=head1 NAME
+
+DBI::Gofer::Transport::Base - Base class for Gofer transports
+
+=head1 DESCRIPTION
+
+This is the base class for server-side Gofer transports.
+
+It's also the base class for the client-side base class L<DBD::Gofer::Transport::Base>.
+
+This is an internal class.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/pipeone.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/pipeone.pm
new file mode 100755
index 00000000000..d79c2ebee07
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/pipeone.pm
@@ -0,0 +1,61 @@
+package DBI::Gofer::Transport::pipeone;
+
+# $Id: pipeone.pm 12536 2009-02-24 22:37:09Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+use DBI::Gofer::Execute;
+
+use base qw(DBI::Gofer::Transport::Base Exporter);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
+
+our @EXPORT = qw(run_one_stdio);
+
+my $executor = DBI::Gofer::Execute->new();
+
+sub run_one_stdio {
+
+ my $transport = DBI::Gofer::Transport::pipeone->new();
+
+ my $frozen_request = do { local $/; <STDIN> };
+
+ my $response = $executor->execute_request( $transport->thaw_request($frozen_request) );
+
+ my $frozen_response = $transport->freeze_response($response);
+
+ print $frozen_response;
+
+ # no point calling $executor->update_stats(...) for pipeONE
+}
+
+1;
+__END__
+
+=head1 NAME
+
+DBI::Gofer::Transport::pipeone - DBD::Gofer server-side transport for pipeone
+
+=head1 SYNOPSIS
+
+See L<DBD::Gofer::Transport::pipeone>.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/stream.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/stream.pm
new file mode 100755
index 00000000000..49de55042c6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Gofer/Transport/stream.pm
@@ -0,0 +1,76 @@
+package DBI::Gofer::Transport::stream;
+
+# $Id: stream.pm 12536 2009-02-24 22:37:09Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+use DBI qw(dbi_time);
+use DBI::Gofer::Execute;
+
+use base qw(DBI::Gofer::Transport::pipeone Exporter);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
+
+our @EXPORT = qw(run_stdio_hex);
+
+my $executor = DBI::Gofer::Execute->new();
+
+sub run_stdio_hex {
+
+ my $transport = DBI::Gofer::Transport::stream->new();
+ local $| = 1;
+
+ DBI->trace_msg("$0 started (pid $$)\n");
+
+ local $\; # OUTPUT_RECORD_SEPARATOR
+ local $/ = "\012"; # INPUT_RECORD_SEPARATOR
+ while ( defined( my $encoded_request = <STDIN> ) ) {
+ my $time_received = dbi_time();
+ $encoded_request =~ s/\015?\012$//;
+
+ my $frozen_request = pack "H*", $encoded_request;
+ my $request = $transport->thaw_request( $frozen_request );
+
+ my $response = $executor->execute_request( $request );
+
+ my $frozen_response = $transport->freeze_response($response);
+ my $encoded_response = unpack "H*", $frozen_response;
+
+ print $encoded_response, "\015\012"; # autoflushed due to $|=1
+
+ # there's no way to access the stats currently
+ # so this just serves as a basic test and illustration of update_stats()
+ $executor->update_stats($request, $response, $frozen_request, $frozen_response, $time_received, 1);
+ }
+ DBI->trace_msg("$0 ending (pid $$)\n");
+}
+
+1;
+__END__
+
+=head1 NAME
+
+DBI::Gofer::Transport::stream - DBD::Gofer server-side transport for stream
+
+=head1 SYNOPSIS
+
+See L<DBD::Gofer::Transport::stream>.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Profile.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Profile.pm
new file mode 100755
index 00000000000..bdda9c12ec1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Profile.pm
@@ -0,0 +1,943 @@
+package DBI::Profile;
+
+=head1 NAME
+
+DBI::Profile - Performance profiling and benchmarking for the DBI
+
+=head1 SYNOPSIS
+
+The easiest way to enable DBI profiling is to set the DBI_PROFILE
+environment variable to 2 and then run your code as usual:
+
+ DBI_PROFILE=2 prog.pl
+
+This will profile your program and then output a textual summary
+grouped by query when the program exits. You can also enable profiling by
+setting the Profile attribute of any DBI handle:
+
+ $dbh->{Profile} = 2;
+
+Then the summary will be printed when the handle is destroyed.
+
+Many other values apart from are possible - see L<"ENABLING A PROFILE"> below.
+
+=head1 DESCRIPTION
+
+The DBI::Profile module provides a simple interface to collect and
+report performance and benchmarking data from the DBI.
+
+For a more elaborate interface, suitable for larger programs, see
+L<DBI::ProfileDumper|DBI::ProfileDumper> and L<dbiprof|dbiprof>.
+For Apache/mod_perl applications see
+L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>.
+
+=head1 OVERVIEW
+
+Performance data collection for the DBI is built around several
+concepts which are important to understand clearly.
+
+=over 4
+
+=item Method Dispatch
+
+Every method call on a DBI handle passes through a single 'dispatch'
+function which manages all the common aspects of DBI method calls,
+such as handling the RaiseError attribute.
+
+=item Data Collection
+
+If profiling is enabled for a handle then the dispatch code takes
+a high-resolution timestamp soon after it is entered. Then, after
+calling the appropriate method and just before returning, it takes
+another high-resolution timestamp and calls a function to record
+the information. That function is passed the two timestamps
+plus the DBI handle and the name of the method that was called.
+That data about a single DBI method call is called a I<profile sample>.
+
+=item Data Filtering
+
+If the method call was invoked by the DBI or by a driver then the call is
+ignored for profiling because the time spent will be accounted for by the
+original 'outermost' call for your code.
+
+For example, the calls that the selectrow_arrayref() method makes
+to prepare() and execute() etc. are not counted individually
+because the time spent in those methods is going to be allocated
+to the selectrow_arrayref() method when it returns. If this was not
+done then it would be very easy to double count time spent inside
+the DBI.
+
+=item Data Storage Tree
+
+The profile data is accumulated as 'leaves on a tree'. The 'path' through the
+branches of the tree to a particular leaf is determined dynamically for each sample.
+This is a key feature of DBI profiliing.
+
+For each profiled method call the DBI walks along the Path and uses each value
+in the Path to step into and grow the Data tree.
+
+For example, if the Path is
+
+ [ 'foo', 'bar', 'baz' ]
+
+then the new profile sample data will be I<merged> into the tree at
+
+ $h->{Profile}->{Data}->{foo}->{bar}->{baz}
+
+But it's not very useful to merge all the call data into one leaf node (except
+to get an overall 'time spent inside the DBI' total). It's more common to want
+the Path to include dynamic values such as the current statement text and/or
+the name of the method called to show what the time spent inside the DBI was for.
+
+The Path can contain some 'magic cookie' values that are automatically replaced
+by corresponding dynamic values when they're used. These magic cookies always
+start with a punctuation character.
+
+For example a value of 'C<!MethodName>' in the Path causes the corresponding
+entry in the Data to be the name of the method that was called.
+For example, if the Path was:
+
+ [ 'foo', '!MethodName', 'bar' ]
+
+and the selectall_arrayref() method was called, then the profile sample data
+for that call will be merged into the tree at:
+
+ $h->{Profile}->{Data}->{foo}->{selectall_arrayref}->{bar}
+
+=item Profile Data
+
+Profile data is stored at the 'leaves' of the tree as references
+to an array of numeric values. For example:
+
+ [
+ 106, # 0: count of samples at this node
+ 0.0312958955764771, # 1: total duration
+ 0.000490069389343262, # 2: first duration
+ 0.000176072120666504, # 3: shortest duration
+ 0.00140702724456787, # 4: longest duration
+ 1023115819.83019, # 5: time of first sample
+ 1023115819.86576, # 6: time of last sample
+ ]
+
+After the first sample, later samples always update elements 0, 1, and 6, and
+may update 3 or 4 depending on the duration of the sampled call.
+
+=back
+
+=head1 ENABLING A PROFILE
+
+Profiling is enabled for a handle by assigning to the Profile
+attribute. For example:
+
+ $h->{Profile} = DBI::Profile->new();
+
+The Profile attribute holds a blessed reference to a hash object
+that contains the profile data and attributes relating to it.
+
+The class the Profile object is blessed into is expected to
+provide at least a DESTROY method which will dump the profile data
+to the DBI trace file handle (STDERR by default).
+
+All these examples have the same effect as each other:
+
+ $h->{Profile} = 0;
+ $h->{Profile} = "/DBI::Profile";
+ $h->{Profile} = DBI::Profile->new();
+ $h->{Profile} = {};
+ $h->{Profile} = { Path => [] };
+
+Similarly, these examples have the same effect as each other:
+
+ $h->{Profile} = 6;
+ $h->{Profile} = "6/DBI::Profile";
+ $h->{Profile} = "!Statement:!MethodName/DBI::Profile";
+ $h->{Profile} = { Path => [ '!Statement', '!MethodName' ] };
+
+If a non-blessed hash reference is given then the DBI::Profile
+module is automatically C<require>'d and the reference is blessed
+into that class.
+
+If a string is given then it is processed like this:
+
+ ($path, $module, $args) = split /\//, $string, 3
+
+ @path = split /:/, $path
+ @args = split /:/, $args
+
+ eval "require $module" if $module
+ $module ||= "DBI::Profile"
+
+ $module->new( Path => \@Path, @args )
+
+So the first value is used to select the Path to be used (see below).
+The second value, if present, is used as the name of a module which
+will be loaded and it's C<new> method called. If not present it
+defaults to DBI::Profile. Any other values are passed as arguments
+to the C<new> method. For example: "C<2/DBIx::OtherProfile/Foo:42>".
+
+Numbers can be used as a shorthand way to enable common Path values.
+The simplest way to explain how the values are interpreted is to show the code:
+
+ push @Path, "DBI" if $path_elem & 0x01;
+ push @Path, "!Statement" if $path_elem & 0x02;
+ push @Path, "!MethodName" if $path_elem & 0x04;
+ push @Path, "!MethodClass" if $path_elem & 0x08;
+ push @Path, "!Caller2" if $path_elem & 0x10;
+
+So "2" is the same as "!Statement" and "6" (2+4) is the same as
+"!Statement:!Method". Those are the two most commonly used values. Using a
+negative number will reverse the path. Thus "-6" will group by method name then
+statement.
+
+The spliting and parsing of string values assigned to the Profile
+attribute may seem a little odd, but there's a good reason for it.
+Remember that attributes can be embedded in the Data Source Name
+string which can be passed in to a script as a parameter. For
+example:
+
+ dbi:DriverName(Profile=>2):dbname
+ dbi:DriverName(Profile=>{Username}:!Statement/MyProfiler/Foo:42):dbname
+
+And also, if the C<DBI_PROFILE> environment variable is set then
+The DBI arranges for every driver handle to share the same profile
+object. When perl exits a single profile summary will be generated
+that reflects (as nearly as practical) the total use of the DBI by
+the application.
+
+
+=head1 THE PROFILE OBJECT
+
+The DBI core expects the Profile attribute value to be a hash
+reference and if the following values don't exist it will create
+them as needed:
+
+=head2 Data
+
+A reference to a hash containing the collected profile data.
+
+=head2 Path
+
+The Path value is a reference to an array. Each element controls the
+value to use at the corresponding level of the profile Data tree.
+
+If the value of Path is anything other than an array reference,
+it is treated as if it was:
+
+ [ '!Statement' ]
+
+The elements of Path array can be one of the following types:
+
+=head3 Special Constant
+
+B<!Statement>
+
+Use the current Statement text. Typically that's the value of the Statement
+attribute for the handle the method was called with. Some methods, like
+commit() and rollback(), are unrelated to a particular statement. For those
+methods !Statement records an empty string.
+
+For statement handles this is always simply the string that was
+given to prepare() when the handle was created. For database handles
+this is the statement that was last prepared or executed on that
+database handle. That can lead to a little 'fuzzyness' because, for
+example, calls to the quote() method to build a new statement will
+typically be associated with the previous statement. In practice
+this isn't a significant issue and the dynamic Path mechanism can
+be used to setup your own rules.
+
+B<!MethodName>
+
+Use the name of the DBI method that the profile sample relates to.
+
+B<!MethodClass>
+
+Use the fully qualified name of the DBI method, including
+the package, that the profile sample relates to. This shows you
+where the method was implemented. For example:
+
+ 'DBD::_::db::selectrow_arrayref' =>
+ 0.022902s
+ 'DBD::mysql::db::selectrow_arrayref' =>
+ 2.244521s / 99 = 0.022445s avg (first 0.022813s, min 0.022051s, max 0.028932s)
+
+The "DBD::_::db::selectrow_arrayref" shows that the driver has
+inherited the selectrow_arrayref method provided by the DBI.
+
+But you'll note that there is only one call to
+DBD::_::db::selectrow_arrayref but another 99 to
+DBD::mysql::db::selectrow_arrayref. Currently the first
+call Pern't record the true location. That may change.
+
+B<!Caller>
+
+Use a string showing the filename and line number of the code calling the method.
+
+B<!Caller2>
+
+Use a string showing the filename and line number of the code calling the
+method, as for !Caller, but also include filename and line number of the code
+that called that. Calls from DBI:: and DBD:: packages are skipped.
+
+B<!File>
+
+Same as !Caller above except that only the filename is included, not the line number.
+
+B<!File2>
+
+Same as !Caller2 above except that only the filenames are included, not the line number.
+
+B<!Time>
+
+Use the current value of time(). Rarely used. See the more useful C<!Time~N> below.
+
+B<!Time~N>
+
+Where C<N> is an integer. Use the current value of time() but with reduced precision.
+The value used is determined in this way:
+
+ int( time() / N ) * N
+
+This is a useful way to segregate a profile into time slots. For example:
+
+ [ '!Time~60', '!Statement' ]
+
+=head3 Code Reference
+
+The subroutine is passed the handle it was called on and the DBI method name.
+The current Statement is in $_. The statement string should not be modified,
+so most subs start with C<local $_ = $_;>.
+
+The list of values it returns is used at that point in the Profile Path.
+
+The sub can 'veto' (reject) a profile sample by including a reference to undef
+in the returned list. That can be useful when you want to only profile
+statements that match a certain pattern, or only profile certain methods.
+
+=head3 Subroutine Specifier
+
+A Path element that begins with 'C<&>' is treated as the name of a subroutine
+in the DBI::ProfileSubs namespace and replaced with the corresponding code reference.
+
+Currently this only works when the Path is specified by the C<DBI_PROFILE>
+environment variable.
+
+Also, currently, the only subroutine in the DBI::ProfileSubs namespace is
+C<'&norm_std_n3'>. That's a very handy subroutine when profiling code that
+doesn't use placeholders. See L<DBI::ProfileSubs> for more information.
+
+=head3 Attribute Specifier
+
+A string enclosed in braces, such as 'C<{Username}>', specifies that the current
+value of the corresponding database handle attribute should be used at that
+point in the Path.
+
+=head3 Reference to a Scalar
+
+Specifies that the current value of the referenced scalar be used at that point
+in the Path. This provides an efficient way to get 'contextual' values into
+your profile.
+
+=head3 Other Values
+
+Any other values are stringified and used literally.
+
+(References, and values that begin with punctuation characters are reserved.)
+
+
+=head1 REPORTING
+
+=head2 Report Format
+
+The current accumulated profile data can be formatted and output using
+
+ print $h->{Profile}->format;
+
+To discard the profile data and start collecting fresh data
+you can do:
+
+ $h->{Profile}->{Data} = undef;
+
+
+The default results format looks like this:
+
+ DBI::Profile: 0.001015s 42.7% (5 calls) programname @ YYYY-MM-DD HH:MM:SS
+ '' =>
+ 0.000024s / 2 = 0.000012s avg (first 0.000015s, min 0.000009s, max 0.000015s)
+ 'SELECT mode,size,name FROM table' =>
+ 0.000991s / 3 = 0.000330s avg (first 0.000678s, min 0.000009s, max 0.000678s)
+
+Which shows the total time spent inside the DBI, with a count of
+the total number of method calls and the name of the script being
+run, then a formated version of the profile data tree.
+
+If the results are being formated when the perl process is exiting
+(which is usually the case when the DBI_PROFILE environment variable
+is used) then the percentage of time the process spent inside the
+DBI is also shown. If the process is not exiting then the percentage is
+calculated using the time between the first and last call to the DBI.
+
+In the example above the paths in the tree are only one level deep and
+use the Statement text as the value (that's the default behaviour).
+
+The merged profile data at the 'leaves' of the tree are presented
+as total time spent, count, average time spent (which is simply total
+time divided by the count), then the time spent on the first call,
+the time spent on the fastest call, and finally the time spent on
+the slowest call.
+
+The 'avg', 'first', 'min' and 'max' times are not particularly
+useful when the profile data path only contains the statement text.
+Here's an extract of a more detailed example using both statement
+text and method name in the path:
+
+ 'SELECT mode,size,name FROM table' =>
+ 'FETCH' =>
+ 0.000076s
+ 'fetchrow_hashref' =>
+ 0.036203s / 108 = 0.000335s avg (first 0.000490s, min 0.000152s, max 0.002786s)
+
+Here you can see the 'avg', 'first', 'min' and 'max' for the
+108 calls to fetchrow_hashref() become rather more interesting.
+Also the data for FETCH just shows a time value because it was only
+called once.
+
+Currently the profile data is output sorted by branch names. That
+may change in a later version so the leaf nodes are sorted by total
+time per leaf node.
+
+
+=head2 Report Destination
+
+The default method of reporting is for the DESTROY method of the
+Profile object to format the results and write them using:
+
+ DBI->trace_msg($results, 0); # see $ON_DESTROY_DUMP below
+
+to write them to the DBI trace() filehandle (which defaults to
+STDERR). To direct the DBI trace filehandle to write to a file
+without enabling tracing the trace() method can be called with a
+trace level of 0. For example:
+
+ DBI->trace(0, $filename);
+
+The same effect can be achieved without changing the code by
+setting the C<DBI_TRACE> environment variable to C<0=filename>.
+
+The $DBI::Profile::ON_DESTROY_DUMP variable holds a code ref
+that's called to perform the output of the formatted results.
+The default value is:
+
+ $ON_DESTROY_DUMP = sub { DBI->trace_msg($results, 0) };
+
+Apart from making it easy to send the dump elsewhere, it can also
+be useful as a simple way to disable dumping results.
+
+=head1 CHILD HANDLES
+
+Child handles inherit a reference to the Profile attribute value
+of their parent. So if profiling is enabled for a database handle
+then by default the statement handles created from it all contribute
+to the same merged profile data tree.
+
+
+=head1 PROFILE OBJECT METHODS
+
+=head2 format
+
+See L</REPORTING>.
+
+=head2 as_node_path_list
+
+ @ary = $dbh->{Profile}->as_node_path_list();
+ @ary = $dbh->{Profile}->as_node_path_list($node, $path);
+
+Returns the collected data ($dbh->{Profile}{Data}) restructured into a list of
+array refs, one for each leaf node in the Data tree. This 'flat' structure is
+often much simpler for applications to work with.
+
+The first element of each array ref is a reference to the leaf node.
+The remaining elements are the 'path' through the data tree to that node.
+
+For example, given a data tree like this:
+
+ {key1a}{key2a}[node1]
+ {key1a}{key2b}[node2]
+ {key1b}{key2a}{key3a}[node3]
+
+The as_node_path_list() method will return this list:
+
+ [ [node1], 'key1a', 'key2a' ]
+ [ [node2], 'key1a', 'key2b' ]
+ [ [node3], 'key1b', 'key2a', 'key3a' ]
+
+The nodes are ordered by key, depth-first.
+
+The $node argument can be used to focus on a sub-tree.
+If not specified it defaults to $dbh->{Profile}{Data}.
+
+The $path argument can be used to specify a list of path elements that will be
+added to each element of the returned list. If not specified it defaults to a a
+ref to an empty array.
+
+=head2 as_text
+
+ @txt = $dbh->{Profile}->as_text();
+ $txt = $dbh->{Profile}->as_text({
+ node => undef,
+ path => [],
+ separator => " > ",
+ format => '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n";
+ sortsub => sub { ... },
+ );
+
+Returns the collected data ($dbh->{Profile}{Data}) reformatted into a list of formatted strings.
+In scalar context the list is returned as a single contatenated string.
+
+A hashref can be used to pass in arguments, the default values are shown in the example above.
+
+The C<node> and <path> arguments are passed to as_node_path_list().
+
+The C<separator> argument is used to join the elemets of the path for each leaf node.
+
+The C<sortsub> argument is used to pass in a ref to a sub that will order the list.
+The subroutine will be passed a reference to the array returned by
+as_node_path_list() and should sort the contents of the array in place.
+The return value from the sub is ignored. For example, to sort the nodes by the
+second level key you could use:
+
+ sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary }
+
+The C<format> argument is a C<sprintf> format string that specifies the format
+to use for each leaf node. It uses the explicit format parameter index
+mechanism to specify which of the arguments should appear where in the string.
+The arguments to sprintf are:
+
+ 1: path to node, joined with the separator
+ 2: average duration (total duration/count)
+ (3 thru 9 are currently unused)
+ 10: count
+ 11: total duration
+ 12: first duration
+ 13: smallest duration
+ 14: largest duration
+ 15: time of first call
+ 16: time of first call
+
+=head1 CUSTOM DATA MANIPULATION
+
+Recall that C<$h->{Profile}->{Data}> is a reference to the collected data.
+Either to a 'leaf' array (when the Path is empty, i.e., DBI_PROFILE env var is 1),
+or a reference to hash containing values that are either further hash
+references or leaf array references.
+
+Sometimes it's useful to be able to summarise some or all of the collected data.
+The dbi_profile_merge_nodes() function can be used to merge leaf node values.
+
+=head2 dbi_profile_merge_nodes
+
+ use DBI qw(dbi_profile_merge_nodes);
+
+ $time_in_dbi = dbi_profile_merge_nodes(my $totals=[], @$leaves);
+
+Merges profile data node. Given a reference to a destination array, and zero or
+more references to profile data, merges the profile data into the destination array.
+For example:
+
+ $time_in_dbi = dbi_profile_merge_nodes(
+ my $totals=[],
+ [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
+ [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
+ );
+
+$totals will then contain
+
+ [ 25, 0.93, 0.11, 0.01, 0.23, 1023110000, 1023110010 ]
+
+and $time_in_dbi will be 0.93;
+
+The second argument need not be just leaf nodes. If given a reference to a hash
+then the hash is recursively searched for for leaf nodes and all those found
+are merged.
+
+For example, to get the time spent 'inside' the DBI during an http request,
+your logging code run at the end of the request (i.e. mod_perl LogHandler)
+could use:
+
+ my $time_in_dbi = 0;
+ if (my $Profile = $dbh->{Profile}) { # if DBI profiling is enabled
+ $time_in_dbi = dbi_profile_merge_nodes(my $total=[], $Profile->{Data});
+ $Profile->{Data} = {}; # reset the profile data
+ }
+
+If profiling has been enabled then $time_in_dbi will hold the time spent inside
+the DBI for that handle (and any other handles that share the same profile data)
+since the last request.
+
+Prior to DBI 1.56 the dbi_profile_merge_nodes() function was called dbi_profile_merge().
+That name still exists as an alias.
+
+=head1 CUSTOM DATA COLLECTION
+
+=head2 Using The Path Attribute
+
+ XXX example to be added later using a selectall_arrayref call
+ XXX nested inside a fetch loop where the first column of the
+ XXX outer loop is bound to the profile Path using
+ XXX bind_column(1, \${ $dbh->{Profile}->{Path}->[0] })
+ XXX so you end up with separate profiles for each loop
+ XXX (patches welcome to add this to the docs :)
+
+=head2 Adding Your Own Samples
+
+The dbi_profile() function can be used to add extra sample data
+into the profile data tree. For example:
+
+ use DBI;
+ use DBI::Profile (dbi_profile dbi_time);
+
+ my $t1 = dbi_time(); # floating point high-resolution time
+
+ ... execute code you want to profile here ...
+
+ my $t2 = dbi_time();
+ dbi_profile($h, $statement, $method, $t1, $t2);
+
+The $h parameter is the handle the extra profile sample should be
+associated with. The $statement parameter is the string to use where
+the Path specifies !Statement. If $statement is undef
+then $h->{Statement} will be used. Similarly $method is the string
+to use if the Path specifies !MethodName. There is no
+default value for $method.
+
+The $h->{Profile}{Path} attribute is processed by dbi_profile() in
+the usual way.
+
+The $h parameter is usually a DBI handle but it can also be a reference to a
+hash, in which case the dbi_profile() acts on each defined value in the hash.
+This is an efficient way to update multiple profiles with a single sample,
+and is used by the L<DashProfiler> module.
+
+=head1 SUBCLASSING
+
+Alternate profile modules must subclass DBI::Profile to help ensure
+they work with future versions of the DBI.
+
+
+=head1 CAVEATS
+
+Applications which generate many different statement strings
+(typically because they don't use placeholders) and profile with
+!Statement in the Path (the default) will consume memory
+in the Profile Data structure for each statement. Use a code ref
+in the Path to return an edited (simplified) form of the statement.
+
+If a method throws an exception itself (not via RaiseError) then
+it won't be counted in the profile.
+
+If a HandleError subroutine throws an exception (rather than returning
+0 and letting RaiseError do it) then the method call won't be counted
+in the profile.
+
+Time spent in DESTROY is added to the profile of the parent handle.
+
+Time spent in DBI->*() methods is not counted. The time spent in
+the driver connect method, $drh->connect(), when it's called by
+DBI->connect is counted if the DBI_PROFILE environment variable is set.
+
+Time spent fetching tied variables, $DBI::errstr, is counted.
+
+Time spent in FETCH for $h->{Profile} is not counted, so getting the profile
+data doesn't alter it.
+
+DBI::PurePerl does not support profiling (though it could in theory).
+
+A few platforms don't support the gettimeofday() high resolution
+time function used by the DBI (and available via the dbi_time() function).
+In which case you'll get integer resolution time which is mostly useless.
+
+On Windows platforms the dbi_time() function is limited to millisecond
+resolution. Which isn't sufficiently fine for our needs, but still
+much better than integer resolution. This limited resolution means
+that fast method calls will often register as taking 0 time. And
+timings in general will have much more 'jitter' depending on where
+within the 'current millisecond' the start and and timing was taken.
+
+This documentation could be more clear. Probably needs to be reordered
+to start with several examples and build from there. Trying to
+explain the concepts first seems painful and to lead to just as
+many forward references. (Patches welcome!)
+
+=cut
+
+
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+use Exporter ();
+use UNIVERSAL ();
+use Carp;
+
+use DBI qw(dbi_time dbi_profile dbi_profile_merge_nodes dbi_profile_merge);
+
+$VERSION = sprintf("2.%06d", q$Revision: 10916 $ =~ /(\d+)/o);
+
+
+@ISA = qw(Exporter);
+@EXPORT = qw(
+ DBIprofile_Statement
+ DBIprofile_MethodName
+ DBIprofile_MethodClass
+ dbi_profile
+ dbi_profile_merge_nodes
+ dbi_profile_merge
+ dbi_time
+);
+@EXPORT_OK = qw(
+ format_profile_thingy
+);
+
+use constant DBIprofile_Statement => '!Statement';
+use constant DBIprofile_MethodName => '!MethodName';
+use constant DBIprofile_MethodClass => '!MethodClass';
+
+our $ON_DESTROY_DUMP = sub { DBI->trace_msg(shift, 0) };
+our $ON_FLUSH_DUMP = sub { DBI->trace_msg(shift, 0) };
+
+sub new {
+ my $class = shift;
+ my $profile = { @_ };
+ return bless $profile => $class;
+}
+
+
+sub _auto_new {
+ my $class = shift;
+ my ($arg) = @_;
+
+ # This sub is called by DBI internals when a non-hash-ref is
+ # assigned to the Profile attribute. For example
+ # dbi:mysql(RaiseError=>1,Profile=>!Statement:!MethodName/DBIx::MyProfile/arg1:arg2):dbname
+ # This sub works out what to do and returns a suitable hash ref.
+
+ $arg =~ s/^DBI::/2\/DBI::/
+ and carp "Automatically changed old-style DBI::Profile specification to $arg";
+
+ # it's a path/module/arg/arg/arg list
+ my ($path, $package, $args) = split /\//, $arg, 3;
+ my @args = (defined $args) ? split(/:/, $args, -1) : ();
+ my @Path;
+
+ for my $element (split /:/, $path) {
+ if (DBI::looks_like_number($element)) {
+ my $reverse = ($element < 0) ? ($element=-$element, 1) : 0;
+ my @p;
+ # a single "DBI" is special-cased in format()
+ push @p, "DBI" if $element & 0x01;
+ push @p, DBIprofile_Statement if $element & 0x02;
+ push @p, DBIprofile_MethodName if $element & 0x04;
+ push @p, DBIprofile_MethodClass if $element & 0x08;
+ push @p, '!Caller2' if $element & 0x10;
+ push @Path, ($reverse ? reverse @p : @p);
+ }
+ elsif ($element =~ m/^&(\w.*)/) {
+ my $name = "DBI::ProfileSubs::$1"; # capture $1 early
+ require DBI::ProfileSubs;
+ my $code = do { no strict; *{$name}{CODE} };
+ if (defined $code) {
+ push @Path, $code;
+ }
+ else {
+ warn "$name: subroutine not found\n";
+ push @Path, $element;
+ }
+ }
+ else {
+ push @Path, $element;
+ }
+ }
+
+ eval "require $package" if $package; # sliently ignores errors
+ $package ||= $class;
+
+ return $package->new(Path => \@Path, @args);
+}
+
+
+sub empty { # empty out profile data
+ my $self = shift;
+ DBI->trace_msg("profile data discarded\n",0) if $self->{Trace};
+ $self->{Data} = undef;
+}
+
+sub filename { # baseclass method, see DBI::ProfileDumper
+ return undef;
+}
+
+sub flush_to_disk { # baseclass method, see DBI::ProfileDumper & DashProfiler::Core
+ my $self = shift;
+ return unless $ON_FLUSH_DUMP;
+ return unless $self->{Data};
+ my $detail = $self->format();
+ $ON_FLUSH_DUMP->($detail) if $detail;
+}
+
+
+sub as_node_path_list {
+ my ($self, $node, $path) = @_;
+ # convert the tree into an array of arrays
+ # from
+ # {key1a}{key2a}[node1]
+ # {key1a}{key2b}[node2]
+ # {key1b}{key2a}{key3a}[node3]
+ # to
+ # [ [node1], 'key1a', 'key2a' ]
+ # [ [node2], 'key1a', 'key2b' ]
+ # [ [node3], 'key1b', 'key2a', 'key3a' ]
+
+ $node ||= $self->{Data} or return;
+ $path ||= [];
+ if (ref $node eq 'HASH') { # recurse
+ $path = [ @$path, undef ];
+ return map {
+ $path->[-1] = $_;
+ ($node->{$_}) ? $self->as_node_path_list($node->{$_}, $path) : ()
+ } sort keys %$node;
+ }
+ return [ $node, @$path ];
+}
+
+
+sub as_text {
+ my ($self, $args_ref) = @_;
+ my $separator = $args_ref->{separator} || " > ";
+ my $format_path_element = $args_ref->{format_path_element}
+ || "%s"; # or e.g., " key%2$d='%s'"
+ my $format = $args_ref->{format}
+ || '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n";
+
+ my @node_path_list = $self->as_node_path_list(undef, $args_ref->{path});
+
+ $args_ref->{sortsub}->(\@node_path_list) if $args_ref->{sortsub};
+
+ my $eval = "qr/".quotemeta($separator)."/";
+ my $separator_re = eval($eval) || quotemeta($separator);
+ #warn "[$eval] = [$separator_re]";
+ my @text;
+ my @spare_slots = (undef) x 7;
+ for my $node_path (@node_path_list) {
+ my ($node, @path) = @$node_path;
+ my $idx = 0;
+ for (@path) {
+ s/[\r\n]+/ /g;
+ s/$separator_re/ /g;
+ $_ = sprintf $format_path_element, $_, ++$idx;
+ }
+ push @text, sprintf $format,
+ join($separator, @path), # 1=path
+ ($node->[0] ? $node->[1]/$node->[0] : 0), # 2=avg
+ @spare_slots,
+ @$node; # 10=count, 11=dur, 12=first_dur, 13=min, 14=max, 15=first_called, 16=last_called
+ }
+ return @text if wantarray;
+ return join "", @text;
+}
+
+
+sub format {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+ my $prologue = "$class: ";
+ my $detail = $self->format_profile_thingy(
+ $self->{Data}, 0, " ",
+ my $path = [],
+ my $leaves = [],
+ )."\n";
+
+ if (@$leaves) {
+ dbi_profile_merge_nodes(my $totals=[], @$leaves);
+ my ($count, $time_in_dbi, undef, undef, undef, $t1, $t2) = @$totals;
+ (my $progname = $0) =~ s:.*/::;
+ if ($count) {
+ $prologue .= sprintf "%fs ", $time_in_dbi;
+ my $perl_time = ($DBI::PERL_ENDING) ? time() - $^T : $t2-$t1;
+ $prologue .= sprintf "%.2f%% ", $time_in_dbi/$perl_time*100 if $perl_time;
+ my @lt = localtime(time);
+ my $ts = sprintf "%d-%02d-%02d %02d:%02d:%02d",
+ 1900+$lt[5], $lt[4]+1, @lt[3,2,1,0];
+ $prologue .= sprintf "(%d calls) $progname \@ $ts\n", $count;
+ }
+ if (@$leaves == 1 && ref($self->{Data}) eq 'HASH' && $self->{Data}->{DBI}) {
+ $detail = ""; # hide the "DBI" from DBI_PROFILE=1
+ }
+ }
+ return ($prologue, $detail) if wantarray;
+ return $prologue.$detail;
+}
+
+
+sub format_profile_leaf {
+ my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
+ croak "format_profile_leaf called on non-leaf ($thingy)"
+ unless UNIVERSAL::isa($thingy,'ARRAY');
+
+ push @$leaves, $thingy if $leaves;
+ my ($count, $total_time, $first_time, $min, $max, $first_called, $last_called) = @$thingy;
+ return sprintf "%s%fs\n", ($pad x $depth), $total_time
+ if $count <= 1;
+ return sprintf "%s%fs / %d = %fs avg (first %fs, min %fs, max %fs)\n",
+ ($pad x $depth), $total_time, $count, $count ? $total_time/$count : 0,
+ $first_time, $min, $max;
+}
+
+
+sub format_profile_branch {
+ my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
+ croak "format_profile_branch called on non-branch ($thingy)"
+ unless UNIVERSAL::isa($thingy,'HASH');
+ my @chunk;
+ my @keys = sort keys %$thingy;
+ while ( @keys ) {
+ my $k = shift @keys;
+ my $v = $thingy->{$k};
+ push @$path, $k;
+ push @chunk, sprintf "%s'%s' =>\n%s",
+ ($pad x $depth), $k,
+ $self->format_profile_thingy($v, $depth+1, $pad, $path, $leaves);
+ pop @$path;
+ }
+ return join "", @chunk;
+}
+
+
+sub format_profile_thingy {
+ my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
+ return "undef" if not defined $thingy;
+ return $self->format_profile_leaf( $thingy, $depth, $pad, $path, $leaves)
+ if UNIVERSAL::isa($thingy,'ARRAY');
+ return $self->format_profile_branch($thingy, $depth, $pad, $path, $leaves)
+ if UNIVERSAL::isa($thingy,'HASH');
+ return "$thingy\n";
+}
+
+
+sub on_destroy {
+ my $self = shift;
+ return unless $ON_DESTROY_DUMP;
+ return unless $self->{Data};
+ my $detail = $self->format();
+ $ON_DESTROY_DUMP->($detail) if $detail;
+}
+
+sub DESTROY {
+ my $self = shift;
+ local $@;
+ eval { $self->on_destroy };
+ if ($@) {
+ chomp $@;
+ my $class = ref($self) || $self;
+ DBI->trace_msg("$class on_destroy failed: $@", 0);
+ }
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/ProfileData.pm b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileData.pm
new file mode 100755
index 00000000000..b2db08768fe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileData.pm
@@ -0,0 +1,737 @@
+package DBI::ProfileData;
+use strict;
+
+=head1 NAME
+
+DBI::ProfileData - manipulate DBI::ProfileDumper data dumps
+
+=head1 SYNOPSIS
+
+The easiest way to use this module is through the dbiprof frontend
+(see L<dbiprof> for details):
+
+ dbiprof --number 15 --sort count
+
+This module can also be used to roll your own profile analysis:
+
+ # load data from dbi.prof
+ $prof = DBI::ProfileData->new(File => "dbi.prof");
+
+ # get a count of the records (unique paths) in the data set
+ $count = $prof->count();
+
+ # sort by longest overall time
+ $prof->sort(field => "longest");
+
+ # sort by longest overall time, least to greatest
+ $prof->sort(field => "longest", reverse => 1);
+
+ # exclude records with key2 eq 'disconnect'
+ $prof->exclude(key2 => 'disconnect');
+
+ # exclude records with key1 matching /^UPDATE/i
+ $prof->exclude(key1 => qr/^UPDATE/i);
+
+ # remove all records except those where key1 matches /^SELECT/i
+ $prof->match(key1 => qr/^SELECT/i);
+
+ # produce a formatted report with the given number of items
+ $report = $prof->report(number => 10);
+
+ # clone the profile data set
+ $clone = $prof->clone();
+
+ # get access to hash of header values
+ $header = $prof->header();
+
+ # get access to sorted array of nodes
+ $nodes = $prof->nodes();
+
+ # format a single node in the same style as report()
+ $text = $prof->format($nodes->[0]);
+
+ # get access to Data hash in DBI::Profile format
+ $Data = $prof->Data();
+
+=head1 DESCRIPTION
+
+This module offers the ability to read, manipulate and format
+DBI::ProfileDumper profile data.
+
+Conceptually, a profile consists of a series of records, or nodes,
+each of each has a set of statistics and set of keys. Each record
+must have a unique set of keys, but there is no requirement that every
+record have the same number of keys.
+
+=head1 METHODS
+
+The following methods are supported by DBI::ProfileData objects.
+
+=cut
+
+
+our $VERSION = sprintf("2.%06d", q$Revision: 10007 $ =~ /(\d+)/o);
+
+use Carp qw(croak);
+use Symbol;
+use Fcntl qw(:flock);
+
+use DBI::Profile qw(dbi_profile_merge);
+
+# some constants for use with node data arrays
+sub COUNT () { 0 };
+sub TOTAL () { 1 };
+sub FIRST () { 2 };
+sub SHORTEST () { 3 };
+sub LONGEST () { 4 };
+sub FIRST_AT () { 5 };
+sub LAST_AT () { 6 };
+sub PATH () { 7 };
+
+
+my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK})
+ ? $ENV{DBI_PROFILE_FLOCK}
+ : do { local $@; eval { flock STDOUT, 0; 1 } };
+
+
+=head2 $prof = DBI::ProfileData->new(File => "dbi.prof")
+
+=head2 $prof = DBI::ProfileData->new(File => "dbi.prof", Filter => sub { ... })
+
+=head2 $prof = DBI::ProfileData->new(Files => [ "dbi.prof.1", "dbi.prof.2" ])
+
+Creates a a new DBI::ProfileData object. Takes either a single file
+through the File option or a list of Files in an array ref. If
+multiple files are specified then the header data from the first file
+is used.
+
+=head3 Files
+
+Reference to an array of file names to read.
+
+=head3 File
+
+Name of file to read. Takes precedence over C<Files>.
+
+=head3 DeleteFiles
+
+If true, the files are deleted after being read.
+
+Actually the files are renamed with a C.deleteme> suffix before being read,
+and then, after reading all the files, they're all deleted together.
+
+The files are locked while being read which, combined with the rename, makes it
+safe to 'consume' files that are still being generated by L<DBI::ProfileDumper>.
+
+=head3 Filter
+
+The C<Filter> parameter can be used to supply a code reference that can
+manipulate the profile data as it is being read. This is most useful for
+editing SQL statements so that slightly different statements in the raw data
+will be merged and aggregated in the loaded data. For example:
+
+ Filter => sub {
+ my ($path_ref, $data_ref) = @_;
+ s/foo = '.*?'/foo = '...'/ for @$path_ref;
+ }
+
+Here's an example that performs some normalization on the SQL. It converts all
+numbers to C<N> and all quoted strings to C<S>. It can also convert digits to
+N within names. Finally, it summarizes long "IN (...)" clauses.
+
+It's aggressive and simplistic, but it's often sufficient, and serves as an
+example that you can tailor to suit your own needs:
+
+ Filter => sub {
+ my ($path_ref, $data_ref) = @_;
+ local $_ = $path_ref->[0]; # whichever element contains the SQL Statement
+ s/\b\d+\b/N/g; # 42 -> N
+ s/\b0x[0-9A-Fa-f]+\b/N/g; # 0xFE -> N
+ s/'.*?'/'S'/g; # single quoted strings (doesn't handle escapes)
+ s/".*?"/"S"/g; # double quoted strings (doesn't handle escapes)
+ # convert names like log_20001231 into log_NNNNNNNN, controlled by $opt{n}
+ s/([a-z_]+)(\d{$opt{n},})/$1.('N' x length($2))/ieg if $opt{n};
+ # abbreviate massive "in (...)" statements and similar
+ s!(([NS],){100,})!sprintf("$2,{repeated %d times}",length($1)/2)!eg;
+ }
+
+It's often better to perform this kinds of normalization in the DBI while the
+data is being collected, to avoid too much memory being used by storing profile
+data for many different SQL statement. See L<DBI::Profile>.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my $self = {
+ Files => [ "dbi.prof" ],
+ Filter => undef,
+ DeleteFiles => 0,
+ LockFile => $HAS_FLOCK,
+ _header => {},
+ _nodes => [],
+ _node_lookup => {},
+ _sort => 'none',
+ @_
+ };
+ bless $self, $pkg;
+
+ # File (singular) overrides Files (plural)
+ $self->{Files} = [ $self->{File} ] if exists $self->{File};
+
+ $self->_read_files();
+ return $self;
+}
+
+# read files into _header and _nodes
+sub _read_files {
+ my $self = shift;
+ my $files = $self->{Files};
+ my $read_header = 0;
+ my @files_to_delete;
+
+ my $fh = gensym;
+ foreach (@$files) {
+ my $filename = $_;
+
+ if ($self->{DeleteFiles}) {
+ my $newfilename = $filename . ".deleteme";
+ if ($^O eq 'VMS') {
+ # VMS default filesystem can only have one period
+ $newfilename = $filename . 'deleteme';
+ }
+ # will clobber an existing $newfilename
+ rename($filename, $newfilename)
+ or croak "Can't rename($filename, $newfilename): $!";
+ # On a versioned filesystem we want old versions to be removed
+ 1 while (unlink $filename);
+ $filename = $newfilename;
+ }
+
+ open($fh, "<", $filename)
+ or croak("Unable to read profile file '$filename': $!");
+
+ # lock the file in case it's still being written to
+ # (we'll be foced to wait till the write is complete)
+ flock($fh, LOCK_SH) if $self->{LockFile};
+
+ if (-s $fh) { # not empty
+ $self->_read_header($fh, $filename, $read_header ? 0 : 1);
+ $read_header = 1;
+ $self->_read_body($fh, $filename);
+ }
+ close($fh); # and release lock
+
+ push @files_to_delete, $filename
+ if $self->{DeleteFiles};
+ }
+ for (@files_to_delete){
+ # for versioned file systems
+ 1 while (unlink $_);
+ if(-e $_){
+ warn "Can't delete '$_': $!";
+ }
+ }
+
+ # discard node_lookup now that all files are read
+ delete $self->{_node_lookup};
+}
+
+# read the header from the given $fh named $filename. Discards the
+# data unless $keep.
+sub _read_header {
+ my ($self, $fh, $filename, $keep) = @_;
+
+ # get profiler module id
+ my $first = <$fh>;
+ chomp $first;
+ $self->{_profiler} = $first if $keep;
+
+ # collect variables from the header
+ local $_;
+ while (<$fh>) {
+ chomp;
+ last unless length $_;
+ /^(\S+)\s*=\s*(.*)/
+ or croak("Syntax error in header in $filename line $.: $_");
+ # XXX should compare new with existing (from previous file)
+ # and warn if they differ (diferent program or path)
+ $self->{_header}{$1} = unescape_key($2) if $keep;
+ }
+}
+
+
+sub unescape_key { # inverse of escape_key() in DBI::ProfileDumper
+ local $_ = shift;
+ s/(?<!\\)\\n/\n/g; # expand \n, unless it's a \\n
+ s/(?<!\\)\\r/\r/g; # expand \r, unless it's a \\r
+ s/\\\\/\\/g; # \\ to \
+ return $_;
+}
+
+
+# reads the body of the profile data
+sub _read_body {
+ my ($self, $fh, $filename) = @_;
+ my $nodes = $self->{_nodes};
+ my $lookup = $self->{_node_lookup};
+ my $filter = $self->{Filter};
+
+ # build up node array
+ my @path = ("");
+ my (@data, $path_key);
+ local $_;
+ while (<$fh>) {
+ chomp;
+ if (/^\+\s+(\d+)\s?(.*)/) {
+ # it's a key
+ my ($key, $index) = ($2, $1 - 1);
+
+ $#path = $index; # truncate path to new length
+ $path[$index] = unescape_key($key); # place new key at end
+
+ }
+ elsif (s/^=\s+//) {
+ # it's data - file in the node array with the path in index 0
+ # (the optional minus is to make it more robust against systems
+ # with unstable high-res clocks - typically due to poor NTP config
+ # of kernel SMP behaviour, i.e. min time may be -0.000008))
+
+ @data = split / /, $_;
+
+ # corrupt data?
+ croak("Invalid number of fields in $filename line $.: $_")
+ unless @data == 7;
+ croak("Invalid leaf node characters $filename line $.: $_")
+ unless m/^[-+ 0-9eE\.]+$/;
+
+ # hook to enable pre-processing of the data - such as mangling SQL
+ # so that slightly different statements get treated as the same
+ # and so merged in the results
+ $filter->(\@path, \@data) if $filter;
+
+ # elements of @path can't have NULLs in them, so this
+ # forms a unique string per @path. If there's some way I
+ # can get this without arbitrarily stripping out a
+ # character I'd be happy to hear it!
+ $path_key = join("\0",@path);
+
+ # look for previous entry
+ if (exists $lookup->{$path_key}) {
+ # merge in the new data
+ dbi_profile_merge($nodes->[$lookup->{$path_key}], \@data);
+ } else {
+ # insert a new node - nodes are arrays with data in 0-6
+ # and path data after that
+ push(@$nodes, [ @data, @path ]);
+
+ # record node in %seen
+ $lookup->{$path_key} = $#$nodes;
+ }
+ }
+ else {
+ croak("Invalid line type syntax error in $filename line $.: $_");
+ }
+ }
+}
+
+
+
+=head2 $copy = $prof->clone();
+
+Clone a profile data set creating a new object.
+
+=cut
+
+sub clone {
+ my $self = shift;
+
+ # start with a simple copy
+ my $clone = bless { %$self }, ref($self);
+
+ # deep copy nodes
+ $clone->{_nodes} = [ map { [ @$_ ] } @{$self->{_nodes}} ];
+
+ # deep copy header
+ $clone->{_header} = { %{$self->{_header}} };
+
+ return $clone;
+}
+
+=head2 $header = $prof->header();
+
+Returns a reference to a hash of header values. These are the key
+value pairs included in the header section of the DBI::ProfileDumper
+data format. For example:
+
+ $header = {
+ Path => [ '!Statement', '!MethodName' ],
+ Program => 't/42profile_data.t',
+ };
+
+Note that modifying this hash will modify the header data stored
+inside the profile object.
+
+=cut
+
+sub header { shift->{_header} }
+
+
+=head2 $nodes = $prof->nodes()
+
+Returns a reference the sorted nodes array. Each element in the array
+is a single record in the data set. The first seven elements are the
+same as the elements provided by DBI::Profile. After that each key is
+in a separate element. For example:
+
+ $nodes = [
+ [
+ 2, # 0, count
+ 0.0312958955764771, # 1, total duration
+ 0.000490069389343262, # 2, first duration
+ 0.000176072120666504, # 3, shortest duration
+ 0.00140702724456787, # 4, longest duration
+ 1023115819.83019, # 5, time of first event
+ 1023115819.86576, # 6, time of last event
+ 'SELECT foo FROM bar' # 7, key1
+ 'execute' # 8, key2
+ # 6+N, keyN
+ ],
+ # ...
+ ];
+
+Note that modifying this array will modify the node data stored inside
+the profile object.
+
+=cut
+
+sub nodes { shift->{_nodes} }
+
+
+=head2 $count = $prof->count()
+
+Returns the number of items in the profile data set.
+
+=cut
+
+sub count { scalar @{shift->{_nodes}} }
+
+
+=head2 $prof->sort(field => "field")
+
+=head2 $prof->sort(field => "field", reverse => 1)
+
+Sorts data by the given field. Available fields are:
+
+ longest
+ total
+ count
+ shortest
+
+The default sort is greatest to smallest, which is the opposite of the
+normal Perl meaning. This, however, matches the expected behavior of
+the dbiprof frontend.
+
+=cut
+
+
+# sorts data by one of the available fields
+{
+ my %FIELDS = (
+ longest => LONGEST,
+ total => TOTAL,
+ count => COUNT,
+ shortest => SHORTEST,
+ key1 => PATH+0,
+ key2 => PATH+1,
+ key3 => PATH+2,
+ );
+ sub sort {
+ my $self = shift;
+ my $nodes = $self->{_nodes};
+ my %opt = @_;
+
+ croak("Missing required field option.") unless $opt{field};
+
+ my $index = $FIELDS{$opt{field}};
+
+ croak("Unrecognized sort field '$opt{field}'.")
+ unless defined $index;
+
+ # sort over index
+ if ($opt{reverse}) {
+ @$nodes = sort {
+ $a->[$index] <=> $b->[$index]
+ } @$nodes;
+ } else {
+ @$nodes = sort {
+ $b->[$index] <=> $a->[$index]
+ } @$nodes;
+ }
+
+ # remember how we're sorted
+ $self->{_sort} = $opt{field};
+
+ return $self;
+ }
+}
+
+
+=head2 $count = $prof->exclude(key2 => "disconnect")
+
+=head2 $count = $prof->exclude(key2 => "disconnect", case_sensitive => 1)
+
+=head2 $count = $prof->exclude(key1 => qr/^SELECT/i)
+
+Removes records from the data set that match the given string or
+regular expression. This method modifies the data in a permanent
+fashion - use clone() first to maintain the original data after
+exclude(). Returns the number of nodes left in the profile data set.
+
+=cut
+
+sub exclude {
+ my $self = shift;
+ my $nodes = $self->{_nodes};
+ my %opt = @_;
+
+ # find key index number
+ my ($index, $val);
+ foreach (keys %opt) {
+ if (/^key(\d+)$/) {
+ $index = PATH + $1 - 1;
+ $val = $opt{$_};
+ last;
+ }
+ }
+ croak("Missing required keyN option.") unless $index;
+
+ if (UNIVERSAL::isa($val,"Regexp")) {
+ # regex match
+ @$nodes = grep {
+ $#$_ < $index or $_->[$index] !~ /$val/
+ } @$nodes;
+ } else {
+ if ($opt{case_sensitive}) {
+ @$nodes = grep {
+ $#$_ < $index or $_->[$index] ne $val;
+ } @$nodes;
+ } else {
+ $val = lc $val;
+ @$nodes = grep {
+ $#$_ < $index or lc($_->[$index]) ne $val;
+ } @$nodes;
+ }
+ }
+
+ return scalar @$nodes;
+}
+
+
+=head2 $count = $prof->match(key2 => "disconnect")
+
+=head2 $count = $prof->match(key2 => "disconnect", case_sensitive => 1)
+
+=head2 $count = $prof->match(key1 => qr/^SELECT/i)
+
+Removes records from the data set that do not match the given string
+or regular expression. This method modifies the data in a permanent
+fashion - use clone() first to maintain the original data after
+match(). Returns the number of nodes left in the profile data set.
+
+=cut
+
+sub match {
+ my $self = shift;
+ my $nodes = $self->{_nodes};
+ my %opt = @_;
+
+ # find key index number
+ my ($index, $val);
+ foreach (keys %opt) {
+ if (/^key(\d+)$/) {
+ $index = PATH + $1 - 1;
+ $val = $opt{$_};
+ last;
+ }
+ }
+ croak("Missing required keyN option.") unless $index;
+
+ if (UNIVERSAL::isa($val,"Regexp")) {
+ # regex match
+ @$nodes = grep {
+ $#$_ >= $index and $_->[$index] =~ /$val/
+ } @$nodes;
+ } else {
+ if ($opt{case_sensitive}) {
+ @$nodes = grep {
+ $#$_ >= $index and $_->[$index] eq $val;
+ } @$nodes;
+ } else {
+ $val = lc $val;
+ @$nodes = grep {
+ $#$_ >= $index and lc($_->[$index]) eq $val;
+ } @$nodes;
+ }
+ }
+
+ return scalar @$nodes;
+}
+
+
+=head2 $Data = $prof->Data()
+
+Returns the same Data hash structure as seen in DBI::Profile. This
+structure is not sorted. The nodes() structure probably makes more
+sense for most analysis.
+
+=cut
+
+sub Data {
+ my $self = shift;
+ my (%Data, @data, $ptr);
+
+ foreach my $node (@{$self->{_nodes}}) {
+ # traverse to key location
+ $ptr = \%Data;
+ foreach my $key (@{$node}[PATH .. $#$node - 1]) {
+ $ptr->{$key} = {} unless exists $ptr->{$key};
+ $ptr = $ptr->{$key};
+ }
+
+ # slice out node data
+ $ptr->{$node->[-1]} = [ @{$node}[0 .. 6] ];
+ }
+
+ return \%Data;
+}
+
+
+=head2 $text = $prof->format($nodes->[0])
+
+Formats a single node into a human-readable block of text.
+
+=cut
+
+sub format {
+ my ($self, $node) = @_;
+ my $format;
+
+ # setup keys
+ my $keys = "";
+ for (my $i = PATH; $i <= $#$node; $i++) {
+ my $key = $node->[$i];
+
+ # remove leading and trailing space
+ $key =~ s/^\s+//;
+ $key =~ s/\s+$//;
+
+ # if key has newlines or is long take special precautions
+ if (length($key) > 72 or $key =~ /\n/) {
+ $keys .= " Key " . ($i - PATH + 1) . " :\n\n$key\n\n";
+ } else {
+ $keys .= " Key " . ($i - PATH + 1) . " : $key\n";
+ }
+ }
+
+ # nodes with multiple runs get the long entry format, nodes with
+ # just one run get a single count.
+ if ($node->[COUNT] > 1) {
+ $format = <<END;
+ Count : %d
+ Total Time : %3.6f seconds
+ Longest Time : %3.6f seconds
+ Shortest Time : %3.6f seconds
+ Average Time : %3.6f seconds
+END
+ return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST],
+ $node->[TOTAL] / $node->[COUNT]) . $keys;
+ } else {
+ $format = <<END;
+ Count : %d
+ Time : %3.6f seconds
+END
+
+ return sprintf($format, @{$node}[COUNT,TOTAL]) . $keys;
+
+ }
+}
+
+
+=head2 $text = $prof->report(number => 10)
+
+Produces a report with the given number of items.
+
+=cut
+
+sub report {
+ my $self = shift;
+ my $nodes = $self->{_nodes};
+ my %opt = @_;
+
+ croak("Missing required number option") unless exists $opt{number};
+
+ $opt{number} = @$nodes if @$nodes < $opt{number};
+
+ my $report = $self->_report_header($opt{number});
+ for (0 .. $opt{number} - 1) {
+ $report .= sprintf("#" x 5 . "[ %d ]". "#" x 59 . "\n",
+ $_ + 1);
+ $report .= $self->format($nodes->[$_]);
+ $report .= "\n";
+ }
+ return $report;
+}
+
+# format the header for report()
+sub _report_header {
+ my ($self, $number) = @_;
+ my $nodes = $self->{_nodes};
+ my $node_count = @$nodes;
+
+ # find total runtime and method count
+ my ($time, $count) = (0,0);
+ foreach my $node (@$nodes) {
+ $time += $node->[TOTAL];
+ $count += $node->[COUNT];
+ }
+
+ my $header = <<END;
+
+DBI Profile Data ($self->{_profiler})
+
+END
+
+ # output header fields
+ while (my ($key, $value) = each %{$self->{_header}}) {
+ $header .= sprintf(" %-13s : %s\n", $key, $value);
+ }
+
+ # output summary data fields
+ $header .= sprintf(<<END, $node_count, $number, $self->{_sort}, $count, $time);
+ Total Records : %d (showing %d, sorted by %s)
+ Total Count : %d
+ Total Runtime : %3.6f seconds
+
+END
+
+ return $header;
+}
+
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/ProfileDumper.pm b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileDumper.pm
new file mode 100755
index 00000000000..5887f16cfe8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileDumper.pm
@@ -0,0 +1,342 @@
+package DBI::ProfileDumper;
+use strict;
+
+=head1 NAME
+
+DBI::ProfileDumper - profile DBI usage and output data to a file
+
+=head1 SYNOPSIS
+
+To profile an existing program using DBI::ProfileDumper, set the
+DBI_PROFILE environment variable and run your program as usual. For
+example, using bash:
+
+ DBI_PROFILE=2/DBI::ProfileDumper program.pl
+
+Then analyze the generated file (F<dbi.prof>) with L<dbiprof|dbiprof>:
+
+ dbiprof
+
+You can also activate DBI::ProfileDumper from within your code:
+
+ use DBI;
+
+ # profile with default path (2) and output file (dbi.prof)
+ $dbh->{Profile} = "!Statement/DBI::ProfileDumper";
+
+ # same thing, spelled out
+ $dbh->{Profile} = "!Statement/DBI::ProfileDumper/File:dbi.prof";
+
+ # another way to say it
+ use DBI::ProfileDumper;
+ $dbh->{Profile} = DBI::ProfileDumper->new(
+ Path => [ '!Statement' ]
+ File => 'dbi.prof' );
+
+ # using a custom path
+ $dbh->{Profile} = DBI::ProfileDumper->new(
+ Path => [ "foo", "bar" ],
+ File => 'dbi.prof',
+ );
+
+
+=head1 DESCRIPTION
+
+DBI::ProfileDumper is a subclass of L<DBI::Profile|DBI::Profile> which
+dumps profile data to disk instead of printing a summary to your
+screen. You can then use L<dbiprof|dbiprof> to analyze the data in
+a number of interesting ways, or you can roll your own analysis using
+L<DBI::ProfileData|DBI::ProfileData>.
+
+B<NOTE:> For Apache/mod_perl applications, use
+L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>.
+
+=head1 USAGE
+
+One way to use this module is just to enable it in your C<$dbh>:
+
+ $dbh->{Profile} = "1/DBI::ProfileDumper";
+
+This will write out profile data by statement into a file called
+F<dbi.prof>. If you want to modify either of these properties, you
+can construct the DBI::ProfileDumper object yourself:
+
+ use DBI::ProfileDumper;
+ $dbh->{Profile} = DBI::ProfileDumper->new(
+ Path => [ '!Statement' ],
+ File => 'dbi.prof'
+ );
+
+The C<Path> option takes the same values as in
+L<DBI::Profile>. The C<File> option gives the name of the
+file where results will be collected. If it already exists it will be
+overwritten.
+
+You can also activate this module by setting the DBI_PROFILE
+environment variable:
+
+ $ENV{DBI_PROFILE} = "!Statement/DBI::ProfileDumper";
+
+This will cause all DBI handles to share the same profiling object.
+
+=head1 METHODS
+
+The following methods are available to be called using the profile
+object. You can get access to the profile object from the Profile key
+in any DBI handle:
+
+ my $profile = $dbh->{Profile};
+
+=head2 flush_to_disk
+
+ $profile->flush_to_disk()
+
+Flushes all collected profile data to disk and empties the Data hash. Returns
+the filename writen to. If no profile data has been collected then the file is
+not written and flush_to_disk() returns undef.
+
+The file is locked while it's being written. A process 'consuming' the files
+while they're being written to, should rename the file first, then lock it,
+then read it, then close and delete it. The C<DeleteFiles> option to
+L<DBI::ProfileData> does the right thing.
+
+This method may be called multiple times during a program run.
+
+=head2 empty
+
+ $profile->empty()
+
+Clears the Data hash without writing to disk.
+
+=head2 filename
+
+ $filename = $profile->filename();
+
+Get or set the filename.
+
+The filename can be specified as a CODE reference, in which case the referenced
+code should return the filename to be used. The code will be called with the
+profile object as its first argument.
+
+=head1 DATA FORMAT
+
+The data format written by DBI::ProfileDumper starts with a header
+containing the version number of the module used to generate it. Then
+a block of variable declarations describes the profile. After two
+newlines, the profile data forms the body of the file. For example:
+
+ DBI::ProfileDumper 2.003762
+ Path = [ '!Statement', '!MethodName' ]
+ Program = t/42profile_data.t
+
+ + 1 SELECT name FROM users WHERE id = ?
+ + 2 prepare
+ = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+ + 2 execute
+ 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+ + 2 fetchrow_hashref
+ = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+ + 1 UPDATE users SET name = ? WHERE id = ?
+ + 2 prepare
+ = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+ + 2 execute
+ = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+
+The lines beginning with C<+> signs signify keys. The number after
+the C<+> sign shows the nesting level of the key. Lines beginning
+with C<=> are the actual profile data, in the same order as
+in DBI::Profile.
+
+Note that the same path may be present multiple times in the data file
+since C<format()> may be called more than once. When read by
+DBI::ProfileData the data points will be merged to produce a single
+data set for each distinct path.
+
+The key strings are transformed in three ways. First, all backslashes
+are doubled. Then all newlines and carriage-returns are transformed
+into C<\n> and C<\r> respectively. Finally, any NULL bytes (C<\0>)
+are entirely removed. When DBI::ProfileData reads the file the first
+two transformations will be reversed, but NULL bytes will not be
+restored.
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=cut
+
+# inherit from DBI::Profile
+use DBI::Profile;
+
+our @ISA = ("DBI::Profile");
+
+our $VERSION = sprintf("2.%06d", q$Revision: 9894 $ =~ /(\d+)/o);
+
+use Carp qw(croak);
+use Fcntl qw(:flock);
+use Symbol;
+
+my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK})
+ ? $ENV{DBI_PROFILE_FLOCK}
+ : do { local $@; eval { flock STDOUT, 0; 1 } };
+
+my $program_header;
+
+
+# validate params and setup default
+sub new {
+ my $pkg = shift;
+ my $self = $pkg->SUPER::new(
+ LockFile => $HAS_FLOCK,
+ @_,
+ );
+
+ # provide a default filename
+ $self->filename("dbi.prof") unless $self->filename;
+
+ return $self;
+}
+
+
+# get/set filename to use
+sub filename {
+ my $self = shift;
+ $self->{File} = shift if @_;
+ my $filename = $self->{File};
+ $filename = $filename->($self) if ref($filename) eq 'CODE';
+ return $filename;
+}
+
+
+# flush available data to disk
+sub flush_to_disk {
+ my $self = shift;
+ my $class = ref $self;
+ my $filename = $self->filename;
+ my $data = $self->{Data};
+
+ if (1) { # make an option
+ if (not $data or ref $data eq 'HASH' && !%$data) {
+ DBI->trace_msg("flush_to_disk skipped for empty profile\n",0) if $self->{Trace};
+ return undef;
+ }
+ }
+
+ my $fh = gensym;
+ if (($self->{_wrote_header}||'') eq $filename) {
+ # append more data to the file
+ # XXX assumes that Path hasn't changed
+ open($fh, ">>", $filename)
+ or croak("Unable to open '$filename' for $class output: $!");
+ } else {
+ # create new file (or overwrite existing)
+ open($fh, ">", $filename)
+ or croak("Unable to open '$filename' for $class output: $!");
+ }
+ # lock the file (before checking size and writing the header)
+ flock($fh, LOCK_EX) if $self->{LockFile};
+ # write header if file is empty - typically because we just opened it
+ # in '>' mode, or perhaps we used '>>' but the file had been truncated externally.
+ if (-s $fh == 0) {
+ DBI->trace_msg("flush_to_disk wrote header to $filename\n",0) if $self->{Trace};
+ $self->write_header($fh);
+ $self->{_wrote_header} = $filename;
+ }
+
+ my $lines = $self->write_data($fh, $self->{Data}, 1);
+ DBI->trace_msg("flush_to_disk wrote $lines lines to $filename\n",0) if $self->{Trace};
+
+ close($fh) # unlocks the file
+ or croak("Error closing '$filename': $!");
+
+ $self->empty();
+
+
+ return $filename;
+}
+
+
+# write header to a filehandle
+sub write_header {
+ my ($self, $fh) = @_;
+
+ # isolate us against globals which effect print
+ local($\, $,);
+
+ # $self->VERSION can return undef during global destruction
+ my $version = $self->VERSION || $VERSION;
+
+ # module name and version number
+ print $fh ref($self)." $version\n";
+
+ # print out Path (may contain CODE refs etc)
+ my @path_words = map { escape_key($_) } @{ $self->{Path} || [] };
+ print $fh "Path = [ ", join(', ', @path_words), " ]\n";
+
+ # print out $0 and @ARGV
+ if (!$program_header) {
+ # XXX should really quote as well as escape
+ $program_header = "Program = "
+ . join(" ", map { escape_key($_) } $0, @ARGV)
+ . "\n";
+ }
+ print $fh $program_header;
+
+ # all done
+ print $fh "\n";
+}
+
+
+# write data in the proscribed format
+sub write_data {
+ my ($self, $fh, $data, $level) = @_;
+
+ # XXX it's valid for $data to be an ARRAY ref, i.e., Path is empty.
+ # produce an empty profile for invalid $data
+ return 0 unless $data and UNIVERSAL::isa($data,'HASH');
+
+ # isolate us against globals which affect print
+ local ($\, $,);
+
+ my $lines = 0;
+ while (my ($key, $value) = each(%$data)) {
+ # output a key
+ print $fh "+ $level ". escape_key($key). "\n";
+ if (UNIVERSAL::isa($value,'ARRAY')) {
+ # output a data set for a leaf node
+ print $fh "= ".join(' ', @$value)."\n";
+ $lines += 1;
+ } else {
+ # recurse through keys - this could be rewritten to use a
+ # stack for some small performance gain
+ $lines += $self->write_data($fh, $value, $level + 1);
+ }
+ }
+ return $lines;
+}
+
+
+# escape a key for output
+sub escape_key {
+ my $key = shift;
+ $key =~ s!\\!\\\\!g;
+ $key =~ s!\n!\\n!g;
+ $key =~ s!\r!\\r!g;
+ $key =~ s!\0!!g;
+ return $key;
+}
+
+
+# flush data to disk when profile object goes out of scope
+sub on_destroy {
+ shift->flush_to_disk();
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/ProfileDumper/Apache.pm b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileDumper/Apache.pm
new file mode 100755
index 00000000000..4d514c6af49
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileDumper/Apache.pm
@@ -0,0 +1,230 @@
+package DBI::ProfileDumper::Apache;
+
+use strict;
+
+=head1 NAME
+
+DBI::ProfileDumper::Apache - capture DBI profiling data from Apache/mod_perl
+
+=head1 SYNOPSIS
+
+Add this line to your F<httpd.conf>:
+
+ PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
+
+(If you're using mod_perl2, see L</When using mod_perl2> for some additional notes.)
+
+Then restart your server. Access the code you wish to test using a
+web browser, then shutdown your server. This will create a set of
+F<dbi.prof.*> files in your Apache log directory.
+
+Get a profiling report with L<dbiprof|dbiprof>:
+
+ dbiprof /path/to/your/apache/logs/dbi.prof.*
+
+When you're ready to perform another profiling run, delete the old files and start again.
+
+=head1 DESCRIPTION
+
+This module interfaces DBI::ProfileDumper to Apache/mod_perl. Using
+this module you can collect profiling data from mod_perl applications.
+It works by creating a DBI::ProfileDumper data file for each Apache
+process. These files are created in your Apache log directory. You
+can then use the dbiprof utility to analyze the profile files.
+
+=head1 USAGE
+
+=head2 LOADING THE MODULE
+
+The easiest way to use this module is just to set the DBI_PROFILE
+environment variable in your F<httpd.conf>:
+
+ PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
+
+The DBI will look after loading and using the module when the first DBI handle
+is created.
+
+It's also possible to use this module by setting the Profile attribute
+of any DBI handle:
+
+ $dbh->{Profile} = "2/DBI::ProfileDumper::Apache";
+
+See L<DBI::ProfileDumper> for more possibilities, and L<DBI::Profile> for full
+details of the DBI's profiling mechanism.
+
+=head2 WRITING PROFILE DATA
+
+The profile data files will be written to your Apache log directory by default.
+
+The user that the httpd processes run as will need write access to the
+directory. So, for example, if you're running the child httpds as user 'nobody'
+and using chronolog to write to the logs directory, then you'll need to change
+the default.
+
+You can change the destination directory either by secifying a C<Dir> value
+when creating the profile (like C<File> in the L<DBI::ProfileDumper> docs),
+or you can use the C<DBI_PROFILE_APACHE_LOG_DIR> env var to change that. For example:
+
+ PerlSetEnv DBI_PROFILE_APACHE_LOG_DIR /server_root/logs
+
+=head3 When using mod_perl2
+
+Under mod_perl2 you'll need to either set the C<DBI_PROFILE_APACHE_LOG_DIR> env var,
+or enable the mod_perl2 C<GlobalRequest> option, like this:
+
+ PerlOptions +GlobalRequest
+
+to the global config section you're about test with DBI::ProfileDumper::Apache.
+If you don't do one of those then you'll see messages in your error_log similar to:
+
+ DBI::ProfileDumper::Apache on_destroy failed: Global $r object is not available. Set:
+ PerlOptions +GlobalRequest in httpd.conf at ..../DBI/ProfileDumper/Apache.pm line 144
+
+=head3 Naming the files
+
+The default file name is inherited from L<DBI::ProfileDumper> via the
+filename() method, but DBI::ProfileDumper::Apache appends the parent pid and
+the current pid, separated by dots, to that name.
+
+=head3 Silencing the log
+
+By default a message is written to STDERR (i.e., the apache error_log file)
+when flush_to_disk() is called (either explicitly, or implicitly via DESTROY).
+
+That's usually very useful. If you don't want the log message you can silence
+it by setting the C<Quiet> attribute true.
+
+ PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache/Quiet:1
+
+ $dbh->{Profile} = "!Statement/DBI::ProfileDumper/Quiet:1";
+
+ $dbh->{Profile} = DBI::ProfileDumper->new(
+ Path => [ '!Statement' ]
+ Quiet => 1
+ );
+
+
+=head2 GATHERING PROFILE DATA
+
+Once you have the module loaded, use your application as you normally
+would. Stop the webserver when your tests are complete. Profile data
+files will be produced when Apache exits and you'll see something like
+this in your error_log:
+
+ DBI::ProfileDumper::Apache writing to /usr/local/apache/logs/dbi.prof.2604.2619
+
+Now you can use dbiprof to examine the data:
+
+ dbiprof /usr/local/apache/logs/dbi.prof.2604.*
+
+By passing dbiprof a list of all generated files, dbiprof will
+automatically merge them into one result set. You can also pass
+dbiprof sorting and querying options, see L<dbiprof> for details.
+
+=head2 CLEANING UP
+
+Once you've made some code changes, you're ready to start again.
+First, delete the old profile data files:
+
+ rm /usr/local/apache/logs/dbi.prof.*
+
+Then restart your server and get back to work.
+
+=head1 OTHER ISSUES
+
+=head2 Memory usage
+
+DBI::Profile can use a lot of memory for very active applications because it
+collects profiling data in memory for each distinct query run.
+Calling C<flush_to_disk()> will write the current data to disk and free the
+memory it's using. For example:
+
+ $dbh->{Profile}->flush_to_disk() if $dbh->{Profile};
+
+or, rather than flush every time, you could flush less often:
+
+ $dbh->{Profile}->flush_to_disk()
+ if $dbh->{Profile} and ++$i % 100;
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=cut
+
+our $VERSION = sprintf("2.%06d", q$Revision: 9618 $ =~ /(\d+)/o);
+
+our @ISA = qw(DBI::ProfileDumper);
+
+use DBI::ProfileDumper;
+use File::Spec;
+
+my $parent_pid = $$; # init to pid because we are currently the parent of the children-to-be
+
+use constant MP2 => ($ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;
+
+my $apache_server;
+my $server_root_dir;
+
+if (MP2) {
+ require Apache2::Const;
+ Apache2::Const->import(-compile => qw(OK DECLINED));
+ require Apache2::ServerUtil;
+ $apache_server = Apache2::ServerUtil->server;
+ $server_root_dir = Apache2::ServerUtil::server_root();
+}
+else {
+ require Apache;
+ require Apache::Constants;
+ Apache::Constants->import(qw(OK DECLINED));
+ $apache_server = "Apache";
+ $server_root_dir = eval { Apache->server_root_relative('') } || "/tmp";
+}
+
+
+if (UNIVERSAL::can($apache_server, "push_handlers")) {
+ $apache_server->push_handlers(PerlChildInitHandler => sub {
+ $parent_pid = getppid();
+ #warn "PerlChildInitHandler pid$$ has ppid $parent_pid";
+ OK();
+ });
+}
+
+sub dirname {
+ my $self = shift;
+ return $self->{Dir} if $self->{Dir};
+ $self->{Dir} ||= $ENV{DBI_PROFILE_APACHE_LOG_DIR};
+ return $self->{Dir} || File::Spec->catdir($server_root_dir, "logs");
+}
+
+sub filename {
+ my $self = shift;
+ my $filename = $self->SUPER::filename(@_);
+ # to be able to identify groups of profile files from the same set of
+ # apache processes, we include the parent pid in the file name
+ # as well as the pid.
+ $filename .= ".$parent_pid.$$";
+ return $filename if File::Spec->file_name_is_absolute($filename);
+ return File::Spec->catfile($self->dirname, $filename);
+}
+
+
+sub flush_to_disk {
+ my $self = shift;
+
+ my $filename = $self->SUPER::flush_to_disk(@_);
+
+ print STDERR ref($self)." pid$$ written to $filename\n"
+ if $filename && not $self->{Quiet};
+
+ return $filename;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/ProfileSubs.pm b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileSubs.pm
new file mode 100755
index 00000000000..02ca64d1d61
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/ProfileSubs.pm
@@ -0,0 +1,50 @@
+package DBI::ProfileSubs;
+
+our $VERSION = sprintf("0.%06d", q$Revision: 9395 $ =~ /(\d+)/o);
+
+=head1 NAME
+
+DBI::ProfileSubs - Subroutines for dynamic profile Path
+
+=head1 SYNOPSIS
+
+ DBI_PROFILE='&norm_std_n3' prog.pl
+
+This is new and still experimental.
+
+=head1 TO DO
+
+Define come kind of naming convention for the subs.
+
+=cut
+
+use strict;
+use warnings;
+
+
+# would be good to refactor these regex into separate subs and find some
+# way to compose them in various combinations into multiple subs.
+# Perhaps via AUTOLOAD where \&auto_X_Y_Z creates a sub that does X, Y, and Z.
+# The final subs always need to be very fast.
+#
+
+sub norm_std_n3 {
+ # my ($h, $method_name) = @_;
+ local $_ = $_;
+
+ s/\b\d+\b/<N>/g; # 42 -> <N>
+ s/\b0x[0-9A-Fa-f]+\b/<N>/g; # 0xFE -> <N>
+
+ s/'.*?'/'<S>'/g; # single quoted strings (doesn't handle escapes)
+ s/".*?"/"<S>"/g; # double quoted strings (doesn't handle escapes)
+
+ # convert names like log20001231 into log<N>
+ s/([a-z_]+)(\d{3,})\b/${1}<N>/ig;
+
+ # abbreviate massive "in (...)" statements and similar
+ s!((\s*<[NS]>\s*,\s*){100,})!sprintf("$2,<repeated %d times>",length($1)/2)!eg;
+
+ return $_;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/ProxyServer.pm b/Master/tlpkg/tlperl.straw/lib/DBI/ProxyServer.pm
new file mode 100755
index 00000000000..44581f19674
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/ProxyServer.pm
@@ -0,0 +1,890 @@
+# $Header: /home/timbo/dbi/lib/DBI/RCS/ProxyServer.pm,v 11.9 2003/05/14 11:08:17 timbo Exp $
+# -*- perl -*-
+#
+# DBI::ProxyServer - a proxy server for DBI drivers
+#
+# Copyright (c) 1997 Jochen Wiedmann
+#
+# The DBD::Proxy module is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself. In particular permission
+# is granted to Tim Bunce for distributing this as a part of the DBI.
+#
+#
+# Author: Jochen Wiedmann
+# Am Eisteich 9
+# 72555 Metzingen
+# Germany
+#
+# Email: joe@ispsoft.de
+# Phone: +49 7123 14881
+#
+#
+##############################################################################
+
+
+require 5.004;
+use strict;
+
+use RPC::PlServer 0.2001;
+# require DBI; # deferred till AcceptVersion() to aid threading
+require Config;
+
+
+package DBI::ProxyServer;
+
+
+
+############################################################################
+#
+# Constants
+#
+############################################################################
+
+use vars qw($VERSION @ISA);
+
+$VERSION = "0.3005";
+@ISA = qw(RPC::PlServer DBI);
+
+
+# Most of the options below are set to default values, we note them here
+# just for the sake of documentation.
+my %DEFAULT_SERVER_OPTIONS;
+{
+ my $o = \%DEFAULT_SERVER_OPTIONS;
+ $o->{'chroot'} = undef, # To be used in the initfile,
+ # after loading the required
+ # DBI drivers.
+ $o->{'clients'} =
+ [ { 'mask' => '.*',
+ 'accept' => 1,
+ 'cipher' => undef
+ }
+ ];
+ $o->{'configfile'} = '/etc/dbiproxy.conf' if -f '/etc/dbiproxy.conf';
+ $o->{'debug'} = 0;
+ $o->{'facility'} = 'daemon';
+ $o->{'group'} = undef;
+ $o->{'localaddr'} = undef; # Bind to any local IP number
+ $o->{'localport'} = undef; # Must set port number on the
+ # command line.
+ $o->{'logfile'} = undef; # Use syslog or EventLog.
+
+ # XXX don't restrict methods that can be called (trust users once connected)
+ $o->{'XXX_methods'} = {
+ 'DBI::ProxyServer' => {
+ 'Version' => 1,
+ 'NewHandle' => 1,
+ 'CallMethod' => 1,
+ 'DestroyHandle' => 1
+ },
+ 'DBI::ProxyServer::db' => {
+ 'prepare' => 1,
+ 'commit' => 1,
+ 'rollback' => 1,
+ 'STORE' => 1,
+ 'FETCH' => 1,
+ 'func' => 1,
+ 'quote' => 1,
+ 'type_info_all' => 1,
+ 'table_info' => 1,
+ 'disconnect' => 1,
+ },
+ 'DBI::ProxyServer::st' => {
+ 'execute' => 1,
+ 'STORE' => 1,
+ 'FETCH' => 1,
+ 'func' => 1,
+ 'fetch' => 1,
+ 'finish' => 1
+ }
+ };
+ if ($Config::Config{'usethreads'} eq 'define') {
+ $o->{'mode'} = 'threads';
+ } elsif ($Config::Config{'d_fork'} eq 'define') {
+ $o->{'mode'} = 'fork';
+ } else {
+ $o->{'mode'} = 'single';
+ }
+ # No pidfile by default, configuration must provide one if needed
+ $o->{'pidfile'} = 'none';
+ $o->{'user'} = undef;
+};
+
+
+############################################################################
+#
+# Name: Version
+#
+# Purpose: Return version string
+#
+# Inputs: $class - This class
+#
+# Result: Version string; suitable for printing by "--version"
+#
+############################################################################
+
+sub Version {
+ my $version = $DBI::ProxyServer::VERSION;
+ "DBI::ProxyServer $version, Copyright (C) 1998, Jochen Wiedmann";
+}
+
+
+############################################################################
+#
+# Name: AcceptApplication
+#
+# Purpose: Verify DBI DSN
+#
+# Inputs: $self - This instance
+# $dsn - DBI dsn
+#
+# Returns: TRUE for a valid DSN, FALSE otherwise
+#
+############################################################################
+
+sub AcceptApplication {
+ my $self = shift; my $dsn = shift;
+ $dsn =~ /^dbi:\w+:/i;
+}
+
+
+############################################################################
+#
+# Name: AcceptVersion
+#
+# Purpose: Verify requested DBI version
+#
+# Inputs: $self - Instance
+# $version - DBI version being requested
+#
+# Returns: TRUE for ok, FALSE otherwise
+#
+############################################################################
+
+sub AcceptVersion {
+ my $self = shift; my $version = shift;
+ require DBI;
+ DBI::ProxyServer->init_rootclass();
+ $DBI::VERSION >= $version;
+}
+
+
+############################################################################
+#
+# Name: AcceptUser
+#
+# Purpose: Verify user and password by connecting to the client and
+# creating a database connection
+#
+# Inputs: $self - Instance
+# $user - User name
+# $password - Password
+#
+############################################################################
+
+sub AcceptUser {
+ my $self = shift; my $user = shift; my $password = shift;
+ return 0 if (!$self->SUPER::AcceptUser($user, $password));
+ my $dsn = $self->{'application'};
+ $self->Debug("Connecting to $dsn as $user");
+ local $ENV{DBI_AUTOPROXY} = ''; # :-)
+ $self->{'dbh'} = eval {
+ DBI::ProxyServer->connect($dsn, $user, $password,
+ { 'PrintError' => 0,
+ 'Warn' => 0,
+ 'RaiseError' => 1,
+ 'HandleError' => sub {
+ my $err = $_[1]->err;
+ my $state = $_[1]->state || '';
+ $_[0] .= " [err=$err,state=$state]";
+ return 0;
+ } })
+ };
+ if ($@) {
+ $self->Error("Error while connecting to $dsn as $user: $@");
+ return 0;
+ }
+ [1, $self->StoreHandle($self->{'dbh'}) ];
+}
+
+
+sub CallMethod {
+ my $server = shift;
+ my $dbh = $server->{'dbh'};
+ # We could store the private_server attribute permanently in
+ # $dbh. However, we'd have a reference loop in that case and
+ # I would be concerned about garbage collection. :-(
+ $dbh->{'private_server'} = $server;
+ $server->Debug("CallMethod: => " . do { local $^W; join(",", @_)});
+ my @result = eval { $server->SUPER::CallMethod(@_) };
+ my $msg = $@;
+ undef $dbh->{'private_server'};
+ if ($msg) {
+ $server->Debug("CallMethod died with: $@");
+ die $msg;
+ } else {
+ $server->Debug("CallMethod: <= " . do { local $^W; join(",", @result) });
+ }
+ @result;
+}
+
+
+sub main {
+ my $server = DBI::ProxyServer->new(\%DEFAULT_SERVER_OPTIONS, \@_);
+ $server->Bind();
+}
+
+
+############################################################################
+#
+# The DBI part of the proxyserver is implemented as a DBI subclass.
+# Thus we can reuse some of the DBI methods and overwrite only
+# those that need additional handling.
+#
+############################################################################
+
+package DBI::ProxyServer::dr;
+
+@DBI::ProxyServer::dr::ISA = qw(DBI::dr);
+
+
+package DBI::ProxyServer::db;
+
+@DBI::ProxyServer::db::ISA = qw(DBI::db);
+
+sub prepare {
+ my($dbh, $statement, $attr, $params, $proto_ver) = @_;
+ my $server = $dbh->{'private_server'};
+ if (my $client = $server->{'client'}) {
+ if ($client->{'sql'}) {
+ if ($statement =~ /^\s*(\S+)/) {
+ my $st = $1;
+ if (!($statement = $client->{'sql'}->{$st})) {
+ die "Unknown SQL query: $st";
+ }
+ } else {
+ die "Cannot parse restricted SQL statement: $statement";
+ }
+ }
+ }
+ my $sth = $dbh->SUPER::prepare($statement, $attr);
+ my $handle = $server->StoreHandle($sth);
+
+ if ( $proto_ver and $proto_ver > 1 ) {
+ $sth->{private_proxyserver_described} = 0;
+ return $handle;
+
+ } else {
+ # The difference between the usual prepare and ours is that we implement
+ # a combined prepare/execute. The DBD::Proxy driver doesn't call us for
+ # prepare. Only if an execute happens, then we are called with method
+ # "prepare". Further execute's are called as "execute".
+ my @result = $sth->execute($params);
+ my ($NAME, $TYPE);
+ my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS};
+ if ($NUM_OF_FIELDS) { # is a SELECT
+ $NAME = $sth->{NAME};
+ $TYPE = $sth->{TYPE};
+ }
+ ($handle, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'},
+ $NAME, $TYPE, @result);
+ }
+}
+
+sub table_info {
+ my $dbh = shift;
+ my $sth = $dbh->SUPER::table_info();
+ my $numFields = $sth->{'NUM_OF_FIELDS'};
+ my $names = $sth->{'NAME'};
+ my $types = $sth->{'TYPE'};
+
+ # We wouldn't need to send all the rows at this point, instead we could
+ # make use of $rsth->fetch() on the client as usual.
+ # The problem is that some drivers (namely DBD::ExampleP, DBD::mysql and
+ # DBD::mSQL) are returning foreign sth's here, thus an instance of
+ # DBI::st and not DBI::ProxyServer::st. We could fix this by permitting
+ # the client to execute method DBI::st, but I don't like this.
+ my @rows;
+ while (my ($row) = $sth->fetch()) {
+ last unless defined $row;
+ push(@rows, [@$row]);
+ }
+ ($numFields, $names, $types, @rows);
+}
+
+
+package DBI::ProxyServer::st;
+
+@DBI::ProxyServer::st::ISA = qw(DBI::st);
+
+sub execute {
+ my $sth = shift; my $params = shift; my $proto_ver = shift;
+ my @outParams;
+ if ($params) {
+ for (my $i = 0; $i < @$params;) {
+ my $param = $params->[$i++];
+ if (!ref($param)) {
+ $sth->bind_param($i, $param);
+ }
+ else {
+ if (!ref(@$param[0])) {#It's not a reference
+ $sth->bind_param($i, @$param);
+ }
+ else {
+ $sth->bind_param_inout($i, @$param);
+ my $ref = shift @$param;
+ push(@outParams, $ref);
+ }
+ }
+ }
+ }
+ my $rows = $sth->SUPER::execute();
+ if ( $proto_ver and $proto_ver > 1 and not $sth->{private_proxyserver_described} ) {
+ my ($NAME, $TYPE);
+ my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS};
+ if ($NUM_OF_FIELDS) { # is a SELECT
+ $NAME = $sth->{NAME};
+ $TYPE = $sth->{TYPE};
+ }
+ $sth->{private_proxyserver_described} = 1;
+ # First execution, we ship back description.
+ return ($rows, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'}, $NAME, $TYPE, @outParams);
+ }
+ ($rows, @outParams);
+}
+
+sub fetch {
+ my $sth = shift; my $numRows = shift || 1;
+ my($ref, @rows);
+ while ($numRows-- && ($ref = $sth->SUPER::fetch())) {
+ push(@rows, [@$ref]);
+ }
+ @rows;
+}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+DBI::ProxyServer - a server for the DBD::Proxy driver
+
+=head1 SYNOPSIS
+
+ use DBI::ProxyServer;
+ DBI::ProxyServer::main(@ARGV);
+
+=head1 DESCRIPTION
+
+DBI::Proxy Server is a module for implementing a proxy for the DBI proxy
+driver, DBD::Proxy. It allows access to databases over the network if the
+DBMS does not offer networked operations. But the proxy server might be
+useful for you, even if you have a DBMS with integrated network
+functionality: It can be used as a DBI proxy in a firewalled environment.
+
+DBI::ProxyServer runs as a daemon on the machine with the DBMS or on the
+firewall. The client connects to the agent using the DBI driver DBD::Proxy,
+thus in the exactly same way than using DBD::mysql, DBD::mSQL or any other
+DBI driver.
+
+The agent is implemented as a RPC::PlServer application. Thus you have
+access to all the possibilities of this module, in particular encryption
+and a similar configuration file. DBI::ProxyServer adds the possibility of
+query restrictions: You can define a set of queries that a client may
+execute and restrict access to those. (Requires a DBI driver that supports
+parameter binding.) See L</CONFIGURATION FILE>.
+
+The provided driver script, L<dbiproxy>, may either be used as it is or
+used as the basis for a local version modified to meet your needs.
+
+=head1 OPTIONS
+
+When calling the DBI::ProxyServer::main() function, you supply an
+array of options. These options are parsed by the Getopt::Long module.
+The ProxyServer inherits all of RPC::PlServer's and hence Net::Daemon's
+options and option handling, in particular the ability to read
+options from either the command line or a config file. See
+L<RPC::PlServer>. See L<Net::Daemon>. Available options include
+
+=over 4
+
+=item I<chroot> (B<--chroot=dir>)
+
+(UNIX only) After doing a bind(), change root directory to the given
+directory by doing a chroot(). This is useful for security, but it
+restricts the environment a lot. For example, you need to load DBI
+drivers in the config file or you have to create hard links to Unix
+sockets, if your drivers are using them. For example, with MySQL, a
+config file might contain the following lines:
+
+ my $rootdir = '/var/dbiproxy';
+ my $unixsockdir = '/tmp';
+ my $unixsockfile = 'mysql.sock';
+ foreach $dir ($rootdir, "$rootdir$unixsockdir") {
+ mkdir 0755, $dir;
+ }
+ link("$unixsockdir/$unixsockfile",
+ "$rootdir$unixsockdir/$unixsockfile");
+ require DBD::mysql;
+
+ {
+ 'chroot' => $rootdir,
+ ...
+ }
+
+If you don't know chroot(), think of an FTP server where you can see a
+certain directory tree only after logging in. See also the --group and
+--user options.
+
+=item I<clients>
+
+An array ref with a list of clients. Clients are hash refs, the attributes
+I<accept> (0 for denying access and 1 for permitting) and I<mask>, a Perl
+regular expression for the clients IP number or its host name.
+
+=item I<configfile> (B<--configfile=file>)
+
+Config files are assumed to return a single hash ref that overrides the
+arguments of the new method. However, command line arguments in turn take
+precedence over the config file. See the L<"CONFIGURATION FILE"> section
+below for details on the config file.
+
+=item I<debug> (B<--debug>)
+
+Turn debugging mode on. Mainly this asserts that logging messages of
+level "debug" are created.
+
+=item I<facility> (B<--facility=mode>)
+
+(UNIX only) Facility to use for L<Sys::Syslog>. The default is
+B<daemon>.
+
+=item I<group> (B<--group=gid>)
+
+After doing a bind(), change the real and effective GID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --user option.
+
+GID's can be passed as group names or numeric values.
+
+=item I<localaddr> (B<--localaddr=ip>)
+
+By default a daemon is listening to any IP number that a machine
+has. This attribute allows to restrict the server to the given
+IP number.
+
+=item I<localport> (B<--localport=port>)
+
+This attribute sets the port on which the daemon is listening. It
+must be given somehow, as there's no default.
+
+=item I<logfile> (B<--logfile=file>)
+
+Be default logging messages will be written to the syslog (Unix) or
+to the event log (Windows NT). On other operating systems you need to
+specify a log file. The special value "STDERR" forces logging to
+stderr. See L<Net::Daemon::Log> for details.
+
+=item I<mode> (B<--mode=modename>)
+
+The server can run in three different modes, depending on the environment.
+
+If you are running Perl 5.005 and did compile it for threads, then the
+server will create a new thread for each connection. The thread will
+execute the server's Run() method and then terminate. This mode is the
+default, you can force it with "--mode=threads".
+
+If threads are not available, but you have a working fork(), then the
+server will behave similar by creating a new process for each connection.
+This mode will be used automatically in the absence of threads or if
+you use the "--mode=fork" option.
+
+Finally there's a single-connection mode: If the server has accepted a
+connection, he will enter the Run() method. No other connections are
+accepted until the Run() method returns (if the client disconnects).
+This operation mode is useful if you have neither threads nor fork(),
+for example on the Macintosh. For debugging purposes you can force this
+mode with "--mode=single".
+
+=item I<pidfile> (B<--pidfile=file>)
+
+(UNIX only) If this option is present, a PID file will be created at the
+given location. Default is to not create a pidfile.
+
+=item I<user> (B<--user=uid>)
+
+After doing a bind(), change the real and effective UID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --group and the --chroot options.
+
+UID's can be passed as group names or numeric values.
+
+=item I<version> (B<--version>)
+
+Supresses startup of the server; instead the version string will
+be printed and the program exits immediately.
+
+=back
+
+=head1 SHUTDOWN
+
+DBI::ProxyServer is built on L<RPC::PlServer> which is, in turn, built on L<Net::Daemon>.
+
+You should refer to L<Net::Daemon> for how to shutdown the server, except that
+you can't because it's not currently documented there (as of v0.43).
+The bottom-line is that it seems that there's no support for graceful shutdown.
+
+=head1 CONFIGURATION FILE
+
+The configuration file is just that of I<RPC::PlServer> or I<Net::Daemon>
+with some additional attributes in the client list.
+
+The config file is a Perl script. At the top of the file you may include
+arbitraty Perl source, for example load drivers at the start (useful
+to enhance performance), prepare a chroot environment and so on.
+
+The important thing is that you finally return a hash ref of option
+name/value pairs. The possible options are listed above.
+
+All possibilities of Net::Daemon and RPC::PlServer apply, in particular
+
+=over 4
+
+=item Host and/or User dependent access control
+
+=item Host and/or User dependent encryption
+
+=item Changing UID and/or GID after binding to the port
+
+=item Running in a chroot() environment
+
+=back
+
+Additionally the server offers you query restrictions. Suggest the
+following client list:
+
+ 'clients' => [
+ { 'mask' => '^admin\.company\.com$',
+ 'accept' => 1,
+ 'users' => [ 'root', 'wwwrun' ],
+ },
+ {
+ 'mask' => '^admin\.company\.com$',
+ 'accept' => 1,
+ 'users' => [ 'root', 'wwwrun' ],
+ 'sql' => {
+ 'select' => 'SELECT * FROM foo',
+ 'insert' => 'INSERT INTO foo VALUES (?, ?, ?)'
+ }
+ }
+
+then only the users root and wwwrun may connect from admin.company.com,
+executing arbitrary queries, but only wwwrun may connect from other
+hosts and is restricted to
+
+ $sth->prepare("select");
+
+or
+
+ $sth->prepare("insert");
+
+which in fact are "SELECT * FROM foo" or "INSERT INTO foo VALUES (?, ?, ?)".
+
+
+=head1 Proxyserver Configuration file (bigger example)
+
+This section tells you how to restrict a DBI-Proxy: Not every user from
+every workstation shall be able to execute every query.
+
+There is a perl program "dbiproxy" which runs on a machine which is able
+to connect to all the databases we wish to reach. All Perl-DBD-drivers must
+be installed on this machine. You can also reach databases for which drivers
+are not available on the machine where you run the programm querying the
+database, e.g. ask MS-Access-database from Linux.
+
+Create a configuration file "proxy_oracle.cfg" at the dbproxy-server:
+
+ {
+ # This shall run in a shell or a DOS-window
+ # facility => 'daemon',
+ pidfile => 'your_dbiproxy.pid',
+ logfile => 1,
+ debug => 0,
+ mode => 'single',
+ localport => '12400',
+
+ # Access control, the first match in this list wins!
+ # So the order is important
+ clients => [
+ # hint to organize:
+ # the most specialized rules for single machines/users are 1st
+ # then the denying rules
+ # the the rules about whole networks
+
+ # rule: internal_webserver
+ # desc: to get statistical information
+ {
+ # this IP-address only is meant
+ mask => '^10\.95\.81\.243$',
+ # accept (not defer) connections like this
+ accept => 1,
+ # only users from this list
+ # are allowed to log on
+ users => [ 'informationdesk' ],
+ # only this statistical query is allowed
+ # to get results for a web-query
+ sql => {
+ alive => 'select count(*) from dual',
+ statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?',
+ }
+ },
+
+ # rule: internal_bad_guy_1
+ {
+ mask => '^10\.95\.81\.1$',
+ accept => 0,
+ },
+
+ # rule: employee_workplace
+ # desc: get detailled informations
+ {
+ # any IP-address is meant here
+ mask => '^10\.95\.81\.(\d+)$',
+ # accept (not defer) connections like this
+ accept => 1,
+ # only users from this list
+ # are allowed to log on
+ users => [ 'informationdesk', 'lippmann' ],
+ # all these queries are allowed:
+ sql => {
+ search_city => 'select ort_nr, plz, ort from e01admin.e01e200 where plz like ?',
+ search_area => 'select gebiettyp, geb_bezei from e01admin.e01e203 where geb_bezei like ? or geb_bezei like ?',
+ }
+ },
+
+ # rule: internal_bad_guy_2
+ # This does NOT work, because rule "employee_workplace" hits
+ # with its ip-address-mask of the whole network
+ {
+ # don't accept connection from this ip-address
+ mask => '^10\.95\.81\.5$',
+ accept => 0,
+ }
+ ]
+ }
+
+Start the proxyserver like this:
+
+ rem well-set Oracle_home needed for Oracle
+ set ORACLE_HOME=d:\oracle\ora81
+ dbiproxy --configfile proxy_oracle.cfg
+
+
+=head2 Testing the connection from a remote machine
+
+Call a programm "dbish" from your commandline. I take the machine from rule "internal_webserver"
+
+ dbish "dbi:Proxy:hostname=oracle.zdf;port=12400;dsn=dbi:Oracle:e01" informationdesk xxx
+
+There will be a shell-prompt:
+
+ informationdesk@dbi...> alive
+
+ Current statement buffer (enter '/'...):
+ alive
+
+ informationdesk@dbi...> /
+ COUNT(*)
+ '1'
+ [1 rows of 1 fields returned]
+
+
+=head2 Testing the connection with a perl-script
+
+Create a perl-script like this:
+
+ # file: oratest.pl
+ # call me like this: perl oratest.pl user password
+
+ use strict;
+ use DBI;
+
+ my $user = shift || die "Usage: $0 user password";
+ my $pass = shift || die "Usage: $0 user password";
+ my $config = {
+ dsn_at_proxy => "dbi:Oracle:e01",
+ proxy => "hostname=oechsle.zdf;port=12400",
+ };
+ my $dsn = sprintf "dbi:Proxy:%s;dsn=%s",
+ $config->{proxy},
+ $config->{dsn_at_proxy};
+
+ my $dbh = DBI->connect( $dsn, $user, $pass )
+ || die "connect did not work: $DBI::errstr";
+
+ my $sql = "search_city";
+ printf "%s\n%s\n%s\n", "="x40, $sql, "="x40;
+ my $cur = $dbh->prepare($sql);
+ $cur->bind_param(1,'905%');
+ &show_result ($cur);
+
+ my $sql = "search_area";
+ printf "%s\n%s\n%s\n", "="x40, $sql, "="x40;
+ my $cur = $dbh->prepare($sql);
+ $cur->bind_param(1,'Pfarr%');
+ $cur->bind_param(2,'Bronnamberg%');
+ &show_result ($cur);
+
+ my $sql = "statistic_area";
+ printf "%s\n%s\n%s\n", "="x40, $sql, "="x40;
+ my $cur = $dbh->prepare($sql);
+ $cur->bind_param(1,'Pfarr%');
+ &show_result ($cur);
+
+ $dbh->disconnect;
+ exit;
+
+
+ sub show_result {
+ my $cur = shift;
+ unless ($cur->execute()) {
+ print "Could not execute\n";
+ return;
+ }
+
+ my $rownum = 0;
+ while (my @row = $cur->fetchrow_array()) {
+ printf "Row is: %s\n", join(", ",@row);
+ if ($rownum++ > 5) {
+ print "... and so on\n";
+ last;
+ }
+ }
+ $cur->finish;
+ }
+
+The result
+
+ C:\>perl oratest.pl informationdesk xxx
+ ========================================
+ search_city
+ ========================================
+ Row is: 3322, 9050, Chemnitz
+ Row is: 3678, 9051, Chemnitz
+ Row is: 10447, 9051, Chemnitz
+ Row is: 12128, 9051, Chemnitz
+ Row is: 10954, 90513, Zirndorf
+ Row is: 5808, 90513, Zirndorf
+ Row is: 5715, 90513, Zirndorf
+ ... and so on
+ ========================================
+ search_area
+ ========================================
+ Row is: 101, Bronnamberg
+ Row is: 400, Pfarramt Zirndorf
+ Row is: 400, Pfarramt Rosstal
+ Row is: 400, Pfarramt Oberasbach
+ Row is: 401, Pfarramt Zirndorf
+ Row is: 401, Pfarramt Rosstal
+ ========================================
+ statistic_area
+ ========================================
+ DBD::Proxy::st execute failed: Server returned error: Failed to execute method CallMethod: Unknown SQL query: statistic_area at E:/Perl/site/lib/DBI/ProxyServer.pm line 258.
+ Could not execute
+
+
+=head2 How the configuration works
+
+The most important section to control access to your dbi-proxy is "client=>"
+in the file "proxy_oracle.cfg":
+
+Controlling which person at which machine is allowed to access
+
+=over 4
+
+=item * "mask" is a perl regular expression against the plain ip-address of the machine which wishes to connect _or_ the reverse-lookup from a nameserver.
+
+=item * "accept" tells the dbiproxy-server wether ip-adresse like in "mask" are allowed to connect or not (0/1)
+
+=item * "users" is a reference to a list of usernames which must be matched, this is NOT a regular expression.
+
+=back
+
+Controlling which SQL-statements are allowed
+
+You can put every SQL-statement you like in simply ommiting "sql => ...", but the more important thing is to restrict the connection so that only allowed queries are possible.
+
+If you include an sql-section in your config-file like this:
+
+ sql => {
+ alive => 'select count(*) from dual',
+ statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?',
+ }
+
+The user is allowed to put two queries against the dbi-proxy. The queries are _not_ "select count(*)...", the queries are "alive" and "statistic_area"! These keywords are replaced by the real query. So you can run a query for "alive":
+
+ my $sql = "alive";
+ my $cur = $dbh->prepare($sql);
+ ...
+
+The flexibility is that you can put parameters in the where-part of the query so the query are not static. Simply replace a value in the where-part of the query through a question mark and bind it as a parameter to the query.
+
+ my $sql = "statistic_area";
+ my $cur = $dbh->prepare($sql);
+ $cur->bind_param(1,'905%');
+ # A second parameter would be called like this:
+ # $cur->bind_param(2,'98%');
+
+The result is this query:
+
+ select count(*) from e01admin.e01e203
+ where geb_bezei like '905%'
+
+Don't try to put parameters into the sql-query like this:
+
+ # Does not work like you think.
+ # Only the first word of the query is parsed,
+ # so it's changed to "statistic_area", the rest is omitted.
+ # You _have_ to work with $cur->bind_param.
+ my $sql = "statistic_area 905%";
+ my $cur = $dbh->prepare($sql);
+ ...
+
+
+=head2 Problems
+
+=over 4
+
+=item * I don't know how to restrict users to special databases.
+
+=item * I don't know how to pass query-parameters via dbish
+
+=back
+
+
+=head1 AUTHOR
+
+ Copyright (c) 1997 Jochen Wiedmann
+ Am Eisteich 9
+ 72555 Metzingen
+ Germany
+
+ Email: joe@ispsoft.de
+ Phone: +49 7123 14881
+
+The DBI::ProxyServer module is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself. In particular
+permission is granted to Tim Bunce for distributing this as a part of
+the DBI.
+
+
+=head1 SEE ALSO
+
+L<dbiproxy>, L<DBD::Proxy>, L<DBI>, L<RPC::PlServer>,
+L<RPC::PlClient>, L<Net::Daemon>, L<Net::Daemon::Log>,
+L<Sys::Syslog>, L<Win32::EventLog>, L<syslog>
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/PurePerl.pm b/Master/tlpkg/tlperl.straw/lib/DBI/PurePerl.pm
new file mode 100755
index 00000000000..2e4598363d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/PurePerl.pm
@@ -0,0 +1,1205 @@
+########################################################################
+package # hide from PAUSE
+ DBI;
+# vim: ts=8:sw=4
+########################################################################
+#
+# Copyright (c) 2002,2003 Tim Bunce Ireland.
+#
+# See COPYRIGHT section in DBI.pm for usage and distribution rights.
+#
+########################################################################
+#
+# Please send patches and bug reports to
+#
+# Jeff Zucker <jeff@vpservices.com> with cc to <dbi-dev@perl.org>
+#
+########################################################################
+
+use strict;
+use Carp;
+require Symbol;
+
+require utf8;
+*utf8::is_utf8 = sub { # hack for perl 5.6
+ require bytes;
+ return unless defined $_[0];
+ return !(length($_[0]) == bytes::length($_[0]))
+} unless defined &utf8::is_utf8;
+
+$DBI::PurePerl = $ENV{DBI_PUREPERL} || 1;
+$DBI::PurePerl::VERSION = sprintf("2.%06d", q$Revision: 11372 $ =~ /(\d+)/o);
+
+$DBI::neat_maxlen ||= 400;
+
+$DBI::tfh = Symbol::gensym();
+open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!";
+select( (select($DBI::tfh), $| = 1)[0] ); # autoflush
+
+# check for weaken support, used by ChildHandles
+my $HAS_WEAKEN = eval {
+ require Scalar::Util;
+ # this will croak() if this Scalar::Util doesn't have a working weaken().
+ Scalar::Util::weaken( my $test = [] );
+ 1;
+};
+
+%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err);
+
+use constant SQL_ALL_TYPES => 0;
+use constant SQL_ARRAY => 50;
+use constant SQL_ARRAY_LOCATOR => 51;
+use constant SQL_BIGINT => (-5);
+use constant SQL_BINARY => (-2);
+use constant SQL_BIT => (-7);
+use constant SQL_BLOB => 30;
+use constant SQL_BLOB_LOCATOR => 31;
+use constant SQL_BOOLEAN => 16;
+use constant SQL_CHAR => 1;
+use constant SQL_CLOB => 40;
+use constant SQL_CLOB_LOCATOR => 41;
+use constant SQL_DATE => 9;
+use constant SQL_DATETIME => 9;
+use constant SQL_DECIMAL => 3;
+use constant SQL_DOUBLE => 8;
+use constant SQL_FLOAT => 6;
+use constant SQL_GUID => (-11);
+use constant SQL_INTEGER => 4;
+use constant SQL_INTERVAL => 10;
+use constant SQL_INTERVAL_DAY => 103;
+use constant SQL_INTERVAL_DAY_TO_HOUR => 108;
+use constant SQL_INTERVAL_DAY_TO_MINUTE => 109;
+use constant SQL_INTERVAL_DAY_TO_SECOND => 110;
+use constant SQL_INTERVAL_HOUR => 104;
+use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111;
+use constant SQL_INTERVAL_HOUR_TO_SECOND => 112;
+use constant SQL_INTERVAL_MINUTE => 105;
+use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113;
+use constant SQL_INTERVAL_MONTH => 102;
+use constant SQL_INTERVAL_SECOND => 106;
+use constant SQL_INTERVAL_YEAR => 101;
+use constant SQL_INTERVAL_YEAR_TO_MONTH => 107;
+use constant SQL_LONGVARBINARY => (-4);
+use constant SQL_LONGVARCHAR => (-1);
+use constant SQL_MULTISET => 55;
+use constant SQL_MULTISET_LOCATOR => 56;
+use constant SQL_NUMERIC => 2;
+use constant SQL_REAL => 7;
+use constant SQL_REF => 20;
+use constant SQL_ROW => 19;
+use constant SQL_SMALLINT => 5;
+use constant SQL_TIME => 10;
+use constant SQL_TIMESTAMP => 11;
+use constant SQL_TINYINT => (-6);
+use constant SQL_TYPE_DATE => 91;
+use constant SQL_TYPE_TIME => 92;
+use constant SQL_TYPE_TIMESTAMP => 93;
+use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95;
+use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94;
+use constant SQL_UDT => 17;
+use constant SQL_UDT_LOCATOR => 18;
+use constant SQL_UNKNOWN_TYPE => 0;
+use constant SQL_VARBINARY => (-3);
+use constant SQL_VARCHAR => 12;
+use constant SQL_WCHAR => (-8);
+use constant SQL_WLONGVARCHAR => (-10);
+use constant SQL_WVARCHAR => (-9);
+
+# for Cursor types
+use constant SQL_CURSOR_FORWARD_ONLY => 0;
+use constant SQL_CURSOR_KEYSET_DRIVEN => 1;
+use constant SQL_CURSOR_DYNAMIC => 2;
+use constant SQL_CURSOR_STATIC => 3;
+use constant SQL_CURSOR_TYPE_DEFAULT => SQL_CURSOR_FORWARD_ONLY;
+
+use constant IMA_HAS_USAGE => 0x0001; #/* check parameter usage */
+use constant IMA_FUNC_REDIRECT => 0x0002; #/* is $h->func(..., "method")*/
+use constant IMA_KEEP_ERR => 0x0004; #/* don't reset err & errstr */
+use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */
+use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted args*/
+use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */
+use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */
+use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */
+use constant IMA_STUB => 0x0100; #/* donothing eg $dbh->connected */
+use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */
+use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */
+use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */
+use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */
+use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/
+use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */
+use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */
+use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before call */
+
+my %is_flag_attribute = map {$_ =>1 } qw(
+ Active
+ AutoCommit
+ ChopBlanks
+ CompatMode
+ Executed
+ Taint
+ TaintIn
+ TaintOut
+ InactiveDestroy
+ LongTruncOk
+ MultiThread
+ PrintError
+ PrintWarn
+ RaiseError
+ ShowErrorStatement
+ Warn
+);
+my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw(
+ ActiveKids
+ Attribution
+ BegunWork
+ CachedKids
+ Callbacks
+ ChildHandles
+ CursorName
+ Database
+ DebugDispatch
+ Driver
+ Err
+ Errstr
+ ErrCount
+ FetchHashKeyName
+ HandleError
+ HandleSetErr
+ ImplementorClass
+ Kids
+ LongReadLen
+ NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash
+ NULLABLE
+ NUM_OF_FIELDS
+ NUM_OF_PARAMS
+ Name
+ PRECISION
+ ParamValues
+ Profile
+ Provider
+ ReadOnly
+ RootClass
+ RowCacheSize
+ RowsInCache
+ SCALE
+ State
+ Statement
+ TYPE
+ Type
+ TraceLevel
+ Username
+ Version
+));
+
+sub valid_attribute {
+ my $attr = shift;
+ return 1 if $is_valid_attribute{$attr};
+ return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter
+ return 0
+}
+
+my $initial_setup;
+sub initial_setup {
+ $initial_setup = 1;
+ print $DBI::tfh __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n"
+ if $DBI::dbi_debug & 0xF;
+ untie $DBI::err;
+ untie $DBI::errstr;
+ untie $DBI::state;
+ untie $DBI::rows;
+ #tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
+}
+
+sub _install_method {
+ my ( $caller, $method, $from, $param_hash ) = @_;
+ initial_setup() unless $initial_setup;
+
+ my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/;
+ my $bitmask = $param_hash->{'O'} || 0;
+ my @pre_call_frag;
+
+ return if $method_name eq 'can';
+
+ push @pre_call_frag, q{
+ return if $h_inner; # ignore DESTROY for outer handle
+ # copy err/errstr/state up to driver so $DBI::err etc still work
+ if ($h->{err} and my $drh = $h->{Driver}) {
+ $drh->{$_} = $h->{$_} for ('err','errstr','state');
+ }
+ } if $method_name eq 'DESTROY';
+
+ push @pre_call_frag, q{
+ return $h->{$_[0]} if exists $h->{$_[0]};
+ } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ?
+
+ push @pre_call_frag, "return;"
+ if IMA_STUB & $bitmask;
+
+ push @pre_call_frag, q{
+ $method_name = pop @_;
+ } if IMA_FUNC_REDIRECT & $bitmask;
+
+ push @pre_call_frag, q{
+ my $parent_dbh = $h->{Database};
+ } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask;
+
+ push @pre_call_frag, q{
+ warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems
+ $parent_dbh->{Statement} = $h->{Statement} if $parent_dbh;
+ } if IMA_COPY_UP_STMT & $bitmask;
+
+ push @pre_call_frag, q{
+ $h->{Executed} = 1;
+ $parent_dbh->{Executed} = 1 if $parent_dbh;
+ } if IMA_EXECUTE & $bitmask;
+
+ push @pre_call_frag, q{
+ %{ $h->{CachedKids} } = () if $h->{CachedKids};
+ } if IMA_CLEAR_CACHED_KIDS & $bitmask;
+
+ if (IMA_KEEP_ERR & $bitmask) {
+ push @pre_call_frag, q{
+ my $keep_error = 1;
+ };
+ }
+ else {
+ my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask)
+ ? q{= $h->{dbi_pp_parent}->{dbi_pp_call_depth} }
+ : "";
+ push @pre_call_frag, qq{
+ my \$keep_error $ke_init;
+ };
+ my $keep_error_code = q{
+ #warn "$method_name cleared err";
+ $h->{err} = $DBI::err = undef;
+ $h->{errstr} = $DBI::errstr = undef;
+ $h->{state} = $DBI::state = '';
+ };
+ $keep_error_code = q{
+ printf $DBI::tfh " !! %s: %s CLEARED by call to }.$method_name.q{ method\n".
+ $h->{err}, $h->{err}
+ if defined $h->{err} && $DBI::dbi_debug & 0xF;
+ }. $keep_error_code
+ if exists $ENV{DBI_TRACE};
+ push @pre_call_frag, ($ke_init)
+ ? qq{ unless (\$keep_error) { $keep_error_code }}
+ : $keep_error_code
+ unless $method_name eq 'set_err';
+ }
+
+ push @pre_call_frag, q{
+ my $ErrCount = $h->{ErrCount};
+ };
+
+ push @pre_call_frag, q{
+ if (($DBI::dbi_debug & 0xF) >= 2) {
+ local $^W;
+ my $args = join " ", map { DBI::neat($_) } ($h, @_);
+ printf $DBI::tfh " > $method_name in $imp ($args) [$@]\n";
+ }
+ } if exists $ENV{DBI_TRACE}; # note use of 'exists'
+
+ push @pre_call_frag, q{
+ $h->{'dbi_pp_last_method'} = $method_name;
+ } unless exists $DBI::last_method_except{$method_name};
+
+ # --- post method call code fragments ---
+ my @post_call_frag;
+
+ push @post_call_frag, q{
+ if (my $trace_level = ($DBI::dbi_debug & 0xF)) {
+ if ($h->{err}) {
+ printf $DBI::tfh " !! ERROR: %s %s\n", $h->{err}, $h->{errstr};
+ }
+ my $ret = join " ", map { DBI::neat($_) } @ret;
+ my $msg = " < $method_name= $ret";
+ $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n";
+ print $DBI::tfh $msg;
+ }
+ } if exists $ENV{DBI_TRACE}; # note use of exists
+
+ push @post_call_frag, q{
+ $h->{Executed} = 0;
+ if ($h->{BegunWork}) {
+ $h->{BegunWork} = 0;
+ $h->{AutoCommit} = 1;
+ }
+ } if IMA_END_WORK & $bitmask;
+
+ push @post_call_frag, q{
+ if ( ref $ret[0] and
+ UNIVERSAL::isa($ret[0], 'DBI::_::common') and
+ defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} )
+ ) {
+ # copy up info/warn to drh so PrintWarn on connect is triggered
+ $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state})
+ }
+ } if IMA_IS_FACTORY & $bitmask;
+
+ push @post_call_frag, q{
+ $keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount;
+
+ $DBI::err = $h->{err};
+ $DBI::errstr = $h->{errstr};
+ $DBI::state = $h->{state};
+
+ if ( !$keep_error
+ && defined(my $err = $h->{err})
+ && ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth})
+ ) {
+
+ my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)};
+ my $msg;
+
+ if ($err && ($pe || $re || $he) # error
+ or (!$err && length($err) && $pw) # warning
+ ) {
+ my $last = ($DBI::last_method_except{$method_name})
+ ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name;
+ my $errstr = $h->{errstr} || $DBI::errstr || $err || '';
+ my $msg = sprintf "%s %s %s: %s", $imp, $last,
+ ($err eq "0") ? "warning" : "failed", $errstr;
+
+ if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) {
+ $msg .= ' [for Statement "' . $Statement;
+ if (my $ParamValues = $h->FETCH('ParamValues')) {
+ $msg .= '" with ParamValues: ';
+ $msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef);
+ $msg .= "]";
+ }
+ else {
+ $msg .= '"]';
+ }
+ }
+ if ($err eq "0") { # is 'warning' (not info)
+ carp $msg if $pw;
+ }
+ else {
+ my $do_croak = 1;
+ if (my $subsub = $h->{'HandleError'}) {
+ $do_croak = 0 if &$subsub($msg,$h,$ret[0]);
+ }
+ if ($do_croak) {
+ printf $DBI::tfh " $method_name has failed ($h->{PrintError},$h->{RaiseError})\n"
+ if ($DBI::dbi_debug & 0xF) >= 4;
+ carp $msg if $pe;
+ die $msg if $h->{RaiseError};
+ }
+ }
+ }
+ }
+ };
+
+
+ my $method_code = q[
+ sub {
+ my $h = shift;
+ my $h_inner = tied(%$h);
+ $h = $h_inner if $h_inner;
+
+ my $imp;
+ if ($method_name eq 'DESTROY') {
+ # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value"
+ # implying that tied() above lied to us, so we need to use eval
+ local $@; # protect $@
+ $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction
+ }
+ else {
+ $imp = $h->{"ImplementorClass"} or do {
+ warn "Can't call $method_name method on handle $h after take_imp_data()\n"
+ if not exists $h->{Active};
+ return; # or, more likely, global destruction
+ };
+ }
+
+ ] . join("\n", '', @pre_call_frag, '') . q[
+
+ my $call_depth = $h->{'dbi_pp_call_depth'} + 1;
+ local ($h->{'dbi_pp_call_depth'}) = $call_depth;
+
+ my @ret;
+ my $sub = $imp->can($method_name);
+ if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) {
+ push @_, $method_name;
+ }
+ if ($sub) {
+ (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_));
+ }
+ else {
+ # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc
+ # which would then let Multiplex pass PurePerl tests, but some
+ # hook into install_method may be better.
+ croak "Can't locate DBI object method \"$method_name\" via package \"$imp\""
+ if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[;
+ }
+
+ ] . join("\n", '', @post_call_frag, '') . q[
+
+ return (wantarray) ? @ret : $ret[0];
+ }
+ ];
+ no strict qw(refs);
+ my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code};
+ warn "$@\n$method_code\n" if $@;
+ die "$@\n$method_code\n" if $@;
+ *$method = $code_ref;
+ if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool
+ my $l=0; # show line-numbered code for method
+ warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code);
+ }
+}
+
+
+sub _new_handle {
+ my ($class, $parent, $attr, $imp_data, $imp_class) = @_;
+
+ DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n")
+ if $DBI::dbi_debug >= 3;
+
+ $attr->{ImplementorClass} = $imp_class
+ or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given");
+
+ # This is how we create a DBI style Object:
+ # %outer gets tied to %$attr (which becomes the 'inner' handle)
+ my (%outer, $i, $h);
+ $i = tie %outer, $class, $attr; # ref to inner hash (for driver)
+ $h = bless \%outer, $class; # ref to outer hash (for application)
+ # The above tie and bless may migrate down into _setup_handle()...
+ # Now add magic so DBI method dispatch works
+ DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
+ return $h unless wantarray;
+ return ($h, $i);
+}
+
+sub _setup_handle {
+ my($h, $imp_class, $parent, $imp_data) = @_;
+ my $h_inner = tied(%$h) || $h;
+ if (($DBI::dbi_debug & 0xF) >= 4) {
+ local $^W;
+ print $DBI::tfh " _setup_handle(@_)\n";
+ }
+ $h_inner->{"imp_data"} = $imp_data;
+ $h_inner->{"ImplementorClass"} = $imp_class;
+ $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained
+ if ($parent) {
+ foreach (qw(
+ RaiseError PrintError PrintWarn HandleError HandleSetErr
+ Warn LongTruncOk ChopBlanks AutoCommit ReadOnly
+ ShowErrorStatement FetchHashKeyName LongReadLen CompatMode
+ )) {
+ $h_inner->{$_} = $parent->{$_}
+ if exists $parent->{$_} && !exists $h_inner->{$_};
+ }
+ if (ref($parent) =~ /::db$/) {
+ $h_inner->{Database} = $parent;
+ $parent->{Statement} = $h_inner->{Statement};
+ $h_inner->{NUM_OF_PARAMS} = 0;
+ }
+ elsif (ref($parent) =~ /::dr$/){
+ $h_inner->{Driver} = $parent;
+ }
+ $h_inner->{dbi_pp_parent} = $parent;
+
+ # add to the parent's ChildHandles
+ if ($HAS_WEAKEN) {
+ my $handles = $parent->{ChildHandles} ||= [];
+ push @$handles, $h;
+ Scalar::Util::weaken($handles->[-1]);
+ # purge destroyed handles occasionally
+ if (@$handles % 120 == 0) {
+ @$handles = grep { defined } @$handles;
+ Scalar::Util::weaken($_) for @$handles; # re-weaken after grep
+ }
+ }
+ }
+ else { # setting up a driver handle
+ $h_inner->{Warn} = 1;
+ $h_inner->{PrintWarn} = $^W;
+ $h_inner->{AutoCommit} = 1;
+ $h_inner->{TraceLevel} = 0;
+ $h_inner->{CompatMode} = (1==0);
+ $h_inner->{FetchHashKeyName} ||= 'NAME';
+ $h_inner->{LongReadLen} ||= 80;
+ $h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN;
+ $h_inner->{Type} ||= 'dr';
+ }
+ $h_inner->{"dbi_pp_call_depth"} = 0;
+ $h_inner->{ErrCount} = 0;
+ $h_inner->{Active} = 1;
+}
+
+sub constant {
+ warn "constant(@_) called unexpectedly"; return undef;
+}
+
+sub trace {
+ my ($h, $level, $file) = @_;
+ $level = $h->parse_trace_flags($level)
+ if defined $level and !DBI::looks_like_number($level);
+ my $old_level = $DBI::dbi_debug;
+ _set_trace_file($file) if $level;
+ if (defined $level) {
+ $DBI::dbi_debug = $level;
+ print $DBI::tfh " DBI $DBI::VERSION (PurePerl) "
+ . "dispatch trace level set to $DBI::dbi_debug\n"
+ if $DBI::dbi_debug & 0xF;
+ }
+ _set_trace_file($file) if !$level;
+ return $old_level;
+}
+
+sub _set_trace_file {
+ my ($file) = @_;
+ #
+ # DAA add support for filehandle inputs
+ #
+ # DAA required to avoid closing a prior fh trace()
+ $DBI::tfh = undef unless $DBI::tfh_needs_close;
+
+ if (ref $file eq 'GLOB') {
+ $DBI::tfh = $file;
+ select((select($DBI::tfh), $| = 1)[0]);
+ $DBI::tfh_needs_close = 0;
+ return 1;
+ }
+ $DBI::tfh_needs_close = 1;
+ if (!$file || $file eq 'STDERR') {
+ open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!";
+ }
+ elsif ($file eq 'STDOUT') {
+ open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!";
+ }
+ else {
+ open $DBI::tfh, ">>$file" or carp "Can't open $file: $!";
+ }
+ select((select($DBI::tfh), $| = 1)[0]);
+ return 1;
+}
+sub _get_imp_data { shift->{"imp_data"}; }
+sub _svdump { }
+sub dump_handle {
+ my ($h,$msg,$level) = @_;
+ $msg||="dump_handle $h";
+ print $DBI::tfh "$msg:\n";
+ for my $attrib (sort keys %$h) {
+ print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n";
+ }
+}
+
+sub _handles {
+ my $h = shift;
+ my $h_inner = tied %$h;
+ if ($h_inner) { # this is okay
+ return $h unless wantarray;
+ return ($h, $h_inner);
+ }
+ # XXX this isn't okay... we have an inner handle but
+ # currently have no way to get at its outer handle,
+ # so we just warn and return the inner one for both...
+ Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl");
+ return $h unless wantarray;
+ return ($h,$h);
+}
+
+sub hash {
+ my ($key, $type) = @_;
+ my ($hash);
+ if (!$type) {
+ $hash = 0;
+ # XXX The C version uses the "char" type, which could be either
+ # signed or unsigned. I use signed because so do the two
+ # compilers on my system.
+ for my $char (unpack ("c*", $key)) {
+ $hash = $hash * 33 + $char;
+ }
+ $hash &= 0x7FFFFFFF; # limit to 31 bits
+ $hash |= 0x40000000; # set bit 31
+ return -$hash; # return negative int
+ }
+ elsif ($type == 1) { # Fowler/Noll/Vo hash
+ # see http://www.isthe.com/chongo/tech/comp/fnv/
+ require Math::BigInt; # feel free to reimplement w/o BigInt!
+ (my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01"
+ if ($version >= 1.56) {
+ $hash = Math::BigInt->new(0x811c9dc5);
+ for my $uchar (unpack ("C*", $key)) {
+ # multiply by the 32 bit FNV magic prime mod 2^64
+ $hash = ($hash * 0x01000193) & 0xffffffff;
+ # xor the bottom with the current octet
+ $hash ^= $uchar;
+ }
+ # cast to int
+ return unpack "i", pack "i", $hash;
+ }
+ croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)");
+ }
+ else {
+ croak("bad hash type $type");
+ }
+}
+
+sub looks_like_number {
+ my @new = ();
+ for my $thing(@_) {
+ if (!defined $thing or $thing eq '') {
+ push @new, undef;
+ }
+ else {
+ push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0;
+ }
+ }
+ return (@_ >1) ? @new : $new[0];
+}
+
+sub neat {
+ my $v = shift;
+ return "undef" unless defined $v;
+ my $quote = q{"};
+ if (not utf8::is_utf8($v)) {
+ return $v if (($v & ~ $v) eq "0"); # is SvNIOK
+ $quote = q{'};
+ }
+ my $maxlen = shift || $DBI::neat_maxlen;
+ if ($maxlen && $maxlen < length($v) + 2) {
+ $v = substr($v,0,$maxlen-5);
+ $v .= '...';
+ }
+ $v =~ s/[^[:print:]]/./g;
+ return "$quote$v$quote";
+}
+
+sub dbi_time {
+ return time();
+}
+
+sub DBI::st::TIEHASH { bless $_[1] => $_[0] };
+
+sub _concat_hash_sorted {
+ my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_;
+ # $num_sort: 0=lexical, 1=numeric, undef=try to guess
+
+ return undef unless defined $hash_ref;
+ die "hash is not a hash reference" unless ref $hash_ref eq 'HASH';
+ my $keys = _get_sorted_hash_keys($hash_ref, $num_sort);
+ my $string = '';
+ for my $key (@$keys) {
+ $string .= $pair_separator if length $string > 0;
+ my $value = $hash_ref->{$key};
+ if ($use_neat) {
+ $value = DBI::neat($value, 0);
+ }
+ else {
+ $value = (defined $value) ? "'$value'" : 'undef';
+ }
+ $string .= $key . $kv_separator . $value;
+ }
+ return $string;
+}
+
+sub _get_sorted_hash_keys {
+ my ($hash_ref, $num_sort) = @_;
+ if (not defined $num_sort) {
+ my $sort_guess = 1;
+ $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess
+ for keys %$hash_ref;
+ $num_sort = $sort_guess;
+ }
+
+ my @keys = keys %$hash_ref;
+ no warnings 'numeric';
+ my @sorted = ($num_sort)
+ ? sort { $a <=> $b or $a cmp $b } @keys
+ : sort @keys;
+ return \@sorted;
+}
+
+
+
+package
+ DBI::var;
+
+sub FETCH {
+ my($key)=shift;
+ return $DBI::err if $$key eq '*err';
+ return $DBI::errstr if $$key eq '&errstr';
+ Carp::confess("FETCH $key not supported when using DBI::PurePerl");
+}
+
+package
+ DBD::_::common;
+
+sub swap_inner_handle {
+ my ($h1, $h2) = @_;
+ # can't make this work till we can get the outer handle from the inner one
+ # probably via a WeakRef
+ return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl");
+}
+
+sub trace { # XXX should set per-handle level, not global
+ my ($h, $level, $file) = @_;
+ $level = $h->parse_trace_flags($level)
+ if defined $level and !DBI::looks_like_number($level);
+ my $old_level = $DBI::dbi_debug;
+ DBI::_set_trace_file($file) if defined $file;
+ if (defined $level) {
+ $DBI::dbi_debug = $level;
+ if ($DBI::dbi_debug) {
+ printf $DBI::tfh
+ " %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n",
+ $h, $DBI::dbi_debug;
+ print $DBI::tfh " Full trace not available because DBI_TRACE is not in environment\n"
+ unless exists $ENV{DBI_TRACE};
+ }
+ }
+ return $old_level;
+}
+*debug = \&trace; *debug = \&trace; # twice to avoid typo warning
+
+sub FETCH {
+ my($h,$key)= @_;
+ my $v = $h->{$key};
+ #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n");
+ return $v if defined $v;
+ if ($key =~ /^NAME_.c$/) {
+ my $cols = $h->FETCH('NAME');
+ return undef unless $cols;
+ my @lcols = map { lc $_ } @$cols;
+ $h->{NAME_lc} = \@lcols;
+ my @ucols = map { uc $_ } @$cols;
+ $h->{NAME_uc} = \@ucols;
+ return $h->FETCH($key);
+ }
+ if ($key =~ /^NAME.*_hash$/) {
+ my $i=0;
+ for my $c(@{$h->FETCH('NAME')||[]}) {
+ $h->{'NAME_hash'}->{$c} = $i;
+ $h->{'NAME_lc_hash'}->{"\L$c"} = $i;
+ $h->{'NAME_uc_hash'}->{"\U$c"} = $i;
+ $i++;
+ }
+ return $h->{$key};
+ }
+ if (!defined $v && !exists $h->{$key}) {
+ return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint';
+ return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef
+ return $DBI::dbi_debug if $key eq 'TraceLevel';
+ return [] if $key eq 'ChildHandles' && $HAS_WEAKEN;
+ if ($key eq 'Type') {
+ return "dr" if $h->isa('DBI::dr');
+ return "db" if $h->isa('DBI::db');
+ return "st" if $h->isa('DBI::st');
+ Carp::carp( sprintf "Can't determine Type for %s",$h );
+ }
+ if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) {
+ local $^W; # hide undef warnings
+ Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key )
+ }
+ }
+ return $v;
+}
+sub STORE {
+ my ($h,$key,$value) = @_;
+ if ($key eq 'AutoCommit') {
+ Carp::croak("DBD driver has not implemented the AutoCommit attribute")
+ unless $value == -900 || $value == -901;
+ $value = ($value == -901);
+ }
+ elsif ($key =~ /^Taint/ ) {
+ Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key)
+ if $value;
+ }
+ elsif ($key eq 'TraceLevel') {
+ $h->trace($value);
+ return 1;
+ }
+ elsif ($key eq 'NUM_OF_FIELDS') {
+ $h->{$key} = $value;
+ if ($value) {
+ my $fbav = DBD::_::st::dbih_setup_fbav($h);
+ @$fbav = (undef) x $value if @$fbav != $value;
+ }
+ return 1;
+ }
+ elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) {
+ Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s",
+ $h,$key,$value);
+ }
+ $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value;
+ return 1;
+}
+sub err { return shift->{err} }
+sub errstr { return shift->{errstr} }
+sub state { return shift->{state} }
+sub set_err {
+ my ($h, $errnum,$msg,$state, $method, $rv) = @_;
+ $h = tied(%$h) || $h;
+
+ if (my $hss = $h->{HandleSetErr}) {
+ return if $hss->($h, $errnum, $msg, $state, $method);
+ }
+
+ if (!defined $errnum) {
+ $h->{err} = $DBI::err = undef;
+ $h->{errstr} = $DBI::errstr = undef;
+ $h->{state} = $DBI::state = '';
+ return;
+ }
+
+ if ($h->{errstr}) {
+ $h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum
+ if $h->{err} && $errnum && $h->{err} ne $errnum;
+ $h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state
+ if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state;
+ $h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg;
+ $DBI::errstr = $h->{errstr};
+ }
+ else {
+ $h->{errstr} = $DBI::errstr = $msg;
+ }
+
+ # assign if higher priority: err > "0" > "" > undef
+ my $err_changed;
+ if ($errnum # new error: so assign
+ or !defined $h->{err} # no existing warn/info: so assign
+ # new warn ("0" len 1) > info ("" len 0): so assign
+ or defined $errnum && length($errnum) > length($h->{err})
+ ) {
+ $h->{err} = $DBI::err = $errnum;
+ ++$h->{ErrCount} if $errnum;
+ ++$err_changed;
+ }
+
+ if ($err_changed) {
+ $state ||= "S1000" if $DBI::err;
+ $h->{state} = $DBI::state = ($state eq "00000") ? "" : $state
+ if $state;
+ }
+
+ if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY)
+ $p->{err} = $DBI::err;
+ $p->{errstr} = $DBI::errstr;
+ $p->{state} = $DBI::state;
+ }
+
+ $h->{'dbi_pp_last_method'} = $method;
+ return $rv; # usually undef
+}
+sub trace_msg {
+ my ($h, $msg, $minlevel)=@_;
+ $minlevel = 1 unless defined $minlevel;
+ return unless $minlevel <= ($DBI::dbi_debug & 0xF);
+ print $DBI::tfh $msg;
+ return 1;
+}
+sub private_data {
+ warn "private_data @_";
+}
+sub take_imp_data {
+ my $dbh = shift;
+ # A reasonable default implementation based on the one in DBI.xs.
+ # Typically a pure-perl driver would have their own take_imp_data method
+ # that would delete all but the essential items in the hash before einding with:
+ # return $dbh->SUPER::take_imp_data();
+ # Of course it's useless if the driver doesn't also implement support for
+ # the dbi_imp_data attribute to the connect() method.
+ require Storable;
+ croak("Can't take_imp_data from handle that's not Active")
+ unless $dbh->{Active};
+ for my $sth (@{ $dbh->{ChildHandles} || [] }) {
+ next unless $sth;
+ $sth->finish if $sth->{Active};
+ bless $sth, 'DBI::zombie';
+ }
+ delete $dbh->{$_} for (keys %is_valid_attribute);
+ delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh;
+ # warn "@{[ %$dbh ]}";
+ local $Storable::forgive_me = 1; # in case there are some CODE refs
+ my $imp_data = Storable::freeze($dbh);
+ # XXX um, should probably untie here - need to check dispatch behaviour
+ return $imp_data;
+}
+sub rows {
+ return -1; # always returns -1 here, see DBD::_::st::rows below
+}
+sub DESTROY {
+}
+
+package
+ DBD::_::dr;
+
+sub dbixs_revision {
+ return 0;
+}
+
+package
+ DBD::_::db;
+
+sub connected {
+}
+
+
+package
+ DBD::_::st;
+
+sub fetchrow_arrayref {
+ my $h = shift;
+ # if we're here then driver hasn't implemented fetch/fetchrow_arrayref
+ # so we assume they've implemented fetchrow_array and call that instead
+ my @row = $h->fetchrow_array or return;
+ return $h->_set_fbav(\@row);
+}
+# twice to avoid typo warning
+*fetch = \&fetchrow_arrayref; *fetch = \&fetchrow_arrayref;
+
+sub fetchrow_array {
+ my $h = shift;
+ # if we're here then driver hasn't implemented fetchrow_array
+ # so we assume they've implemented fetch/fetchrow_arrayref
+ my $row = $h->fetch or return;
+ return @$row;
+}
+*fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array;
+
+sub fetchrow_hashref {
+ my $h = shift;
+ my $row = $h->fetch or return;
+ my $FetchCase = shift;
+ my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME';
+ my $FetchHashKeys = $h->FETCH($FetchHashKeyName);
+ my %rowhash;
+ @rowhash{ @$FetchHashKeys } = @$row;
+ return \%rowhash;
+}
+sub dbih_setup_fbav {
+ my $h = shift;
+ return $h->{'_fbav'} || do {
+ $DBI::rows = $h->{'_rows'} = 0;
+ my $fields = $h->{'NUM_OF_FIELDS'}
+ or DBI::croak("NUM_OF_FIELDS not set");
+ my @row = (undef) x $fields;
+ \@row;
+ };
+}
+sub _get_fbav {
+ my $h = shift;
+ my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h);
+ $DBI::rows = ++$h->{'_rows'};
+ return $av;
+}
+sub _set_fbav {
+ my $h = shift;
+ my $fbav = $h->{'_fbav'};
+ if ($fbav) {
+ $DBI::rows = ++$h->{'_rows'};
+ }
+ else {
+ $fbav = $h->_get_fbav;
+ }
+ my $row = shift;
+ if (my $bc = $h->{'_bound_cols'}) {
+ for my $i (0..@$row-1) {
+ my $bound = $bc->[$i];
+ $fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i];
+ }
+ }
+ else {
+ @$fbav = @$row;
+ }
+ return $fbav;
+}
+sub bind_col {
+ my ($h, $col, $value_ref,$from_bind_columns) = @_;
+ my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav()
+ my $num_of_fields = @$fbav;
+ DBI::croak("bind_col: column $col is not a valid column (1..$num_of_fields)")
+ if $col < 1 or $col > $num_of_fields;
+ return 1 if not defined $value_ref; # ie caller is just trying to set TYPE
+ DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar")
+ unless ref $value_ref eq 'SCALAR';
+ $h->{'_bound_cols'}->[$col-1] = $value_ref;
+ return 1;
+}
+sub finish {
+ my $h = shift;
+ $h->{'_fbav'} = undef;
+ $h->{'Active'} = 0;
+ return 1;
+}
+sub rows {
+ my $h = shift;
+ my $rows = $h->{'_rows'};
+ return -1 unless defined $rows;
+ return $rows;
+}
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+DBI::PurePerl -- a DBI emulation using pure perl (no C/XS compilation required)
+
+=head1 SYNOPSIS
+
+ BEGIN { $ENV{DBI_PUREPERL} = 2 }
+ use DBI;
+
+=head1 DESCRIPTION
+
+This is a pure perl emulation of the DBI internals. In almost all
+cases you will be better off using standard DBI since the portions
+of the standard version written in C make it *much* faster.
+
+However, if you are in a situation where it isn't possible to install
+a compiled version of standard DBI, and you're using pure-perl DBD
+drivers, then this module allows you to use most common features
+of DBI without needing any changes in your scripts.
+
+=head1 EXPERIMENTAL STATUS
+
+DBI::PurePerl is new so please treat it as experimental pending
+more extensive testing. So far it has passed all tests with DBD::CSV,
+DBD::AnyData, DBD::XBase, DBD::Sprite, DBD::mysqlPP. Please send
+bug reports to Jeff Zucker at <jeff@vpservices.com> with a cc to
+<dbi-dev@perl.org>.
+
+=head1 USAGE
+
+The usage is the same as for standard DBI with the exception
+that you need to set the enviornment variable DBI_PUREPERL if
+you want to use the PurePerl version.
+
+ DBI_PUREPERL == 0 (the default) Always use compiled DBI, die
+ if it isn't properly compiled & installed
+
+ DBI_PUREPERL == 1 Use compiled DBI if it is properly compiled
+ & installed, otherwise use PurePerl
+
+ DBI_PUREPERL == 2 Always use PurePerl
+
+You may set the enviornment variable in your shell (e.g. with
+set or setenv or export, etc) or else set it in your script like
+this:
+
+ BEGIN { $ENV{DBI_PUREPERL}=2 }
+
+before you C<use DBI;>.
+
+=head1 INSTALLATION
+
+In most situations simply install DBI (see the DBI pod for details).
+
+In the situation in which you can not install DBI itself, you
+may manually copy DBI.pm and PurePerl.pm into the appropriate
+directories.
+
+For example:
+
+ cp DBI.pm /usr/jdoe/mylibs/.
+ cp PurePerl.pm /usr/jdoe/mylibs/DBI/.
+
+Then add this to the top of scripts:
+
+ BEGIN {
+ $ENV{DBI_PUREPERL} = 1; # or =2
+ unshift @INC, '/usr/jdoe/mylibs';
+ }
+
+(Or should we perhaps patch Makefile.PL so that if DBI_PUREPERL
+is set to 2 prior to make, the normal compile process is skipped
+and the files are installed automatically?)
+
+=head1 DIFFERENCES BETWEEN DBI AND DBI::PurePerl
+
+=head2 Attributes
+
+Boolean attributes still return boolean values but the actual values
+used may be different, i.e., 0 or undef instead of an empty string.
+
+Some handle attributes are either not supported or have very limited
+functionality:
+
+ ActiveKids
+ InactiveDestroy
+ Kids
+ Taint
+ TaintIn
+ TaintOut
+
+(and probably others)
+
+=head2 Tracing
+
+Trace functionality is more limited and the code to handle tracing is
+only embeded into DBI:PurePerl if the DBI_TRACE environment variable
+is defined. To enable total tracing you can set the DBI_TRACE
+environment variable as usual. But to enable individual handle
+tracing using the trace() method you also need to set the DBI_TRACE
+environment variable, but set it to 0.
+
+=head2 Parameter Usage Checking
+
+The DBI does some basic parameter count checking on method calls.
+DBI::PurePerl doesn't.
+
+=head2 Speed
+
+DBI::PurePerl is slower. Although, with some drivers in some
+contexts this may not be very significant for you.
+
+By way of example... the test.pl script in the DBI source
+distribution has a simple benchmark that just does:
+
+ my $null_dbh = DBI->connect('dbi:NullP:','','');
+ my $i = 10_000;
+ $null_dbh->prepare('') while $i--;
+
+In other words just prepares a statement, creating and destroying
+a statement handle, over and over again. Using the real DBI this
+runs at ~4550 handles per second whereas DBI::PurePerl manages
+~2800 per second on the same machine (not too bad really).
+
+=head2 May not fully support hash()
+
+If you want to use type 1 hash, i.e., C<hash($string,1)> with
+DBI::PurePerl, you'll need version 1.56 or higher of Math::BigInt
+(available on CPAN).
+
+=head2 Doesn't support preparse()
+
+The DBI->preparse() method isn't supported in DBI::PurePerl.
+
+=head2 Doesn't support DBD::Proxy
+
+There's a subtle problem somewhere I've not been able to identify.
+DBI::ProxyServer seem to work fine with DBI::PurePerl but DBD::Proxy
+does not work 100% (which is sad because that would be far more useful :)
+Try re-enabling t/80proxy.t for DBI::PurePerl to see if the problem
+that remains will affect you're usage.
+
+=head2 Others
+
+ can() - doesn't have any special behaviour
+
+Please let us know if you find any other differences between DBI
+and DBI::PurePerl.
+
+=head1 AUTHORS
+
+Tim Bunce and Jeff Zucker.
+
+Tim provided the direction and basis for the code. The original
+idea for the module and most of the brute force porting from C to
+Perl was by Jeff. Tim then reworked some core parts to boost the
+performance and accuracy of the emulation. Thanks also to Randal
+Schwartz and John Tobey for patches.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002 Tim Bunce Ireland.
+
+See COPYRIGHT section in DBI.pm for usage and distribution rights.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Roadmap.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Roadmap.pm
new file mode 100755
index 00000000000..69fd9d8d90a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Roadmap.pm
@@ -0,0 +1,394 @@
+=head1 NAME
+
+DBI::Roadmap - Planned Enhancements for the DBI
+
+Tim Bunce - 12th November 2004
+
+=head1 SYNOPSIS
+
+This document gives a high level overview of the future of the Perl
+DBI module.
+
+The DBI module is the standard database interface for Perl applications.
+It is used worldwide in countless applications, in every kind of
+business, and on platforms from clustered super-computers to PDAs.
+Database interface drivers are available for all common databases
+and many not-so-common ones.
+
+The planned enhancements cover testing, performance, high availability
+and load balancing, batch statements, Unicode, database portability,
+and more.
+
+Addressing these issues together, in coordinated way, will help
+ensure maximum future functionality with minimal disruptive
+(incompatible) upgrades.
+
+=head1 SCOPE
+
+Broad categories of changes are outlined here along with some
+rationale, but implementation details and minor planned enhancements
+are omitted. More details can be found in:
+L<http://svn.perl.org/modules/dbi/trunk/ToDo>
+
+
+=head1 CHANGES AND ENHANCEMENTS
+
+These are grouped into categories and are not listed in any particular order.
+
+=head2 Performance
+
+The DBI has always treated performance as a priority. Some parts
+of the implementation, however, remain unoptimized, especially in
+relation to threads.
+
+* When the DBI is used with a Perl built with thread support enabled
+(such as for Apache mod_perl 2, and some common Linux distributions)
+it runs significantly slower. There are two reasons for this and
+both can be fixed but require non-trivial changes to both the DBI
+and drivers.
+
+* Connection pooling in a threaded application, such as mod_perl,
+is difficult because DBI handles cannot be passed between threads.
+An alternative mechanism for passing connections between threads
+has been defined, and an experimental connection pool module
+implemented using it, but development has stalled.
+
+* The majority of DBI handle creation code is implemented in Perl.
+Moving most of this to C will speed up handle creation significantly.
+
+* The popular fetchrow_hashref() method is many times slower than
+fetchrow_arrayref(). It has to get the names of the columns, then
+create and load a new hash each time. A $h->{FetchHashReuse} attribute
+would allow the same hash to be reused each time making fetchrow_hashref()
+about the same speed as fetchrow_arrayref().
+
+* Support for asynchronous (non-blocking) DBI method calls would
+enable applications to continue processing in parallel with database
+activity. This is also relevant for GUI and other event-driven
+applications. The DBI needs to define a standard interface for
+this so drivers can implement it in a portable way, where possible.
+
+These changes would significantly enhance the performance of the
+DBI and many applications which use the DBI.
+
+
+=head2 Testing
+
+The DBI has a test suite. Every driver has a test suite. Each is
+limited in its scope. The driver test suite is testing for behavior
+that the driver author I<thinks> the DBI specifies, but may be
+subtly incorrect. These test suites are poorly maintained because
+the return on investment for a single driver is too low to provide
+sufficient incentive.
+
+A common test suite that can be reused by all the drivers is needed.
+It would:
+
+* Improve the quality of the DBI and drivers.
+
+* Ensure all drivers conform to the DBI specification. Easing the
+porting of applications between databases, and the implementation
+of database independent modules layered over the DBI.
+
+* Improve the DBI specification by clarifying unclear issues in
+order to implement test cases.
+
+* Encourage expansion of the test suite as driver authors and others
+will be motivated by the greater benefits of their contributions.
+
+* Detect and record optional functionality that a driver has not
+yet implemented.
+
+* Improve the testing of DBI subclassing, DBI::PurePerl and the
+various "transparent" drivers, such as DBD::Proxy and DBD::Multiplex,
+by automatically running the test suite through them.
+
+These changes would improve the quality of all applications using
+the DBI.
+
+
+=head2 High Availability and Load Balancing
+
+* The DBD::Multiplex driver provides a framework to enable a wide
+range of dynamic functionality, including support for high-availability,
+failover, load-balancing, caching, and access to distributed data.
+It is currently being enhanced but development has stalled.
+
+* The DBD::Proxy module is complex and relatively inefficient because
+it's trying to be a complete proxy for most DBI method calls. For
+many applications a simpler proxy architecture that operates with
+a single round-trip to the server would be simpler, faster, and more
+flexible.
+
+New proxy client and server classes are needed, which could be
+subclassed to support specific client to server transport mechanisms
+(such as HTTP and Spread::Queue). Apart from the efficiency gains,
+this would also enable the use of a load-balanced pool of stateless
+servers for greater scalability and reliability.
+
+* The DBI currently offers no support for distributed transactions.
+The most useful elements of the standard XA distributed transaction
+interface standard could be included in the DBI specification.
+Drivers for databases which support distributed transactions could
+then be extended to support it.
+
+These changes would enable new kinds of DBI applications for critical
+environments.
+
+
+=head2 Unicode
+
+Use of Unicode with the DBI is growing rapidly. The DBI should do
+more to help drivers support Unicode and help applications work
+with drivers that don't yet support Unicode directly.
+
+* Define expected behavior for fetching data and binding parameters.
+
+* Provide interfaces to support Unicode issues for XS and pure Perl
+drivers and applications.
+
+* Provide functions for applications to help diagnose inconsistencies
+between byte string contents and setting of the SvUTF8 flag.
+
+These changes would smooth the transition to Unicode for many
+applications and drivers.
+
+
+=head2 Batch Statements
+
+Batch statements are a sequence of SQL statements, or a stored
+procedure containing a sequence of SQL statements, which can be
+executed as a whole.
+
+Currently the DBI has no standard interface for dealing with multiple
+results from batch statements. After considerable discussion, an
+interface design has been agreed upon with driver authors, but has
+not yet been implemented.
+
+These changes would enable greater application portability between
+databases, and greater performance for databases that directly
+support batch statements.
+
+
+=head2 Introspection
+
+* The methods of the DBI API are installed dynamically when the DBI
+is loaded. The data structure used to define the methods and their
+dispatch behavior should be made part of the DBI API. This would
+enable more flexible and correct behavior by modules subclassing
+the DBI and by dynamic drivers such as DBD::Proxy and DBD::Multiplex.
+
+* Handle attribute information should also be made available, for
+the same reasons.
+
+* Currently is it not possible to discover all the child statement
+handles that belong to a database handle (or all database handles
+that belong to a driver handle). This makes certain tasks more
+difficult, especially some debugging scenarios. A cache of weak
+references to child handles would solve the problem without creating
+reference loops.
+
+* It is often useful to know which handle attributes have been
+changed since the handle was created (e.g., in mod_perl where a
+handle needs to be reset or cloned). This will become more important
+as developers start exploring use of the newly added
+$h1->swap_inner_handle($h2) method.
+
+These changes would simplify and improve the stability of many
+advanced uses of the DBI.
+
+
+=head2 Extensibility
+
+The DBI can be extended in three main dimensions: subclassing the
+DBI, subclassing a driver, and callback hooks. Each has different
+pros and cons, each is applicable in different situations, and
+all need enhancing.
+
+* Subclassing the DBI is functional but not well defined and some
+key elements are incomplete, particularly the DbTypeSubclass mechanism
+(that automatically subclasses to a class tree according to the
+type of database being used). It also needs more thorough testing.
+
+* Subclassing a driver is undocumented, poorly tested and very
+probably incomplete. However it's a powerful way to embed certain
+kinds of functionality 'below' applications while avoiding some of
+the side-effects of subclassing the DBI (especially in relation to
+error handling).
+
+* Callbacks are currently limited to error handling (the HandleError
+and HandleSetError attributes). Providing callback hooks for more
+events, such as a row being fetched, would enable utility modules,
+for example, to modify the behavior of a handle independent of any
+subclassing in use.
+
+These changes would enable cleaner and more powerful integration
+between applications, layered modules, and the DBI.
+
+
+=head2 Debugability
+
+* Enabling DBI trace output at a high level of detail causes a large
+volume of output, much of it probably unrelated to the problem being
+investigated. Trace output should be controlled by the new named-topic
+mechanism instead of just the trace level.
+
+* Calls to XS functions (such as many DBI and driver methods) don't
+normally appear in the call stack. Optionally enabling that would
+enable more useful diagnostics to be produced.
+
+* Integration with the Perl debugger would make it simpler to perform
+actions on a per-handle basis (such as breakpoint on execute,
+breakpoint on error).
+
+These changes would enable more rapid application development and
+fault finding.
+
+
+=head2 Database Portability
+
+* The DBI has not yet addressed the issue of portability among SQL
+dialects. This is the main hurdle limiting database portability
+for DBI applications.
+
+The goal is I<not> to fully parse the SQL and rewrite it in a
+different dialect. That's well beyond the scope of the DBI and
+should be left to layered modules. A simple token rewriting mechanism
+for five comment styles, two quoting styles, four placeholder styles,
+plus the ODBC "{foo ...}" escape syntax, is sufficient to significantly
+raise the level of SQL portability.
+
+* Another problem area is date/time formatting. Since version 1.41
+the DBI has defined a way to express that dates should be fetched
+in SQL standard date format (YYYY-MM-DD). This is one example of
+the more general case where bind_col() needs to be called with
+particular attributes on all columns of a particular type.
+
+A mechanism is needed whereby an application can specify default
+bind_col() attributes to be applied automatically for each column
+type. With a single step, all DATE type columns, for example, can
+be set to be returned in the standard format.
+
+These changes would enable greater database portability for
+applications and greater functionality for layered modules.
+
+
+=head2 Intellectual Property
+
+* Clarify current intellectual property status, including a review
+ of past contributions to ensure the DBI is unemcumbered.
+
+* Establish a procedure for vetting future contributions for any
+ intellectual property issues.
+
+These changes are important for companies taking a formal approach
+to assessing their risks in using Open Source software.
+
+
+=head2 Other Enhancements
+
+* Reduce the work needed to create new database interface drivers.
+
+* Definition of an interface to support scrollable cursors.
+
+
+=head2 Parrot and Perl 6
+
+The current DBI implementation in C code is unlikely to run on Perl 6.
+Perl 6 will target the Parrot virtual machine and so the internal
+architecture will be radically different from Perl 5.
+
+One of the goals of the Parrot project is to be a platform for many
+dynamic languages (including Python, PHP, Ruby, etc) and to enable
+those languages to reuse each others modules. A database interface
+for Parrot is also a database interface for any and all languages
+that run on Parrot.
+
+The Perl DBI would make an excellent base for a Parrot database
+interface because it has more functionality, and is more mature and
+extensible, than the database interfaces of the other dynamic
+languages.
+
+I plan to better define the API between the DBI and the drivers and
+use that API as the primary API for the 'raw' Parrot database
+interface. This project is known a Parrot DBDI (for "DataBase
+Driver Interface"). The announcement can be read in
+<http://groups.google.com/groups?selm=20040127225639.GF38394@dansat.data-plan.com>
+
+The bulk of the work will be translating the DBI C and Perl base
+class code into Parrot PIR, or a suitable language that generates
+PIR. The project stalled, due to Parrot not having key functionality
+at the time. That has been resolved but the project has not yet
+restarted.
+
+Each language targeting Parrot would implement their own small
+'thin' language-specific method dispatcher (a "Perl6 DBI", "Python
+DBI", "PHP DBI" etc) layered over the common Parrot DBDI interface
+and drivers.
+
+The major benefit of the DBDI project is that a much wider community
+of developers share the same database drivers. There would be more
+developers maintaining less code so the benefits of the Open Source
+model are magnified.
+
+
+=head1 PRIORITIES
+
+=head2 Transition Drivers
+
+The first priority is to make all the infrastructure changes that
+impact drivers and make an alpha release available for driver authors.
+
+As far as possible, the changes will be implemented in a way that
+enables driver authors use the same code base for DBI v1 and DBI v2.
+
+The main changes required by driver authors are:
+
+* Code changes for PERL_NO_GET_CONTEXT, plus removing PERL_POLLUTE
+and DBIS
+
+* Code changes in DBI/DBD interface (new way to create handles, new
+callbacks etc)
+
+* Common test suite infrastructure (driver-specific test base class)
+
+=head2 Transition Applications
+
+A small set of incompatible changes that may impact some applications
+will also be made in v2.0. See http://svn.perl.org/modules/dbi/trunk/ToDo
+
+=head2 Incremental Developments
+
+Once DBI v2.0 is available, the other enhancements can be implemented
+incrementally on the updated foundations. Priorities for those
+changes have not been set.
+
+=head2 DBI v1
+
+DBI v1 will continue to be maintained on a separate branch for
+bug fixes and any enhancements that ease the transition to DBI v2.
+
+=head1 RESOURCES AND CONTRIBUTIONS
+
+See L<http://dbi.perl.org/contributing> for I<how you can help>.
+
+If your company has benefited from the DBI, please consider if
+it could make a donation to The Perl Foundation "DBI Development"
+fund at L<http://dbi.perl.org/donate> to secure future development.
+
+Alternatively, if your company would benefit from a specific new
+DBI feature, please consider sponsoring its development through my
+consulting company, Data Plan Services. Work is performed rapidly
+on a fixed-price payment-on-delivery basis. Contact me for details.
+
+Using such targeted financing allows you to contribute to DBI
+development and rapidly get something specific and directly valuable
+to you in return.
+
+My company also offers annual support contracts for the DBI, which
+provide another way to support the DBI and get something specific
+in return. Contact me for details.
+
+Thank you.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/SQL/Nano.pm b/Master/tlpkg/tlperl.straw/lib/DBI/SQL/Nano.pm
new file mode 100755
index 00000000000..fb4a5bf6b11
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/SQL/Nano.pm
@@ -0,0 +1,692 @@
+#######################################################################
+#
+# DBI::SQL::Nano - a very tiny SQL engine
+#
+# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
+#
+# All rights reserved.
+#
+# You may freely distribute and/or modify this module under the terms
+# of either the GNU General Public License (GPL) or the Artistic License,
+# as specified in the Perl README file.
+#
+# See the pod at the bottom of this file for help information
+#
+#######################################################################
+
+#######################
+package DBI::SQL::Nano;
+#######################
+use strict;
+use warnings;
+require DBI; # for looks_like_number()
+use vars qw( $VERSION $versions );
+BEGIN {
+ $VERSION = sprintf("1.%06d", q$Revision: 9744 $ =~ /(\d+)/o);
+
+ $versions->{nano_version} = $VERSION;
+ if ($ENV{DBI_SQL_NANO} || !eval { require "SQL/Statement.pm" }) {
+ @DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_);
+ @DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_);
+ }
+ else {
+ @DBI::SQL::Nano::Statement::ISA = qw( SQL::Statement );
+ @DBI::SQL::Nano::Table::ISA = qw( SQL::Eval::Table);
+ $versions->{statement_version} = $SQL::Statement::VERSION;
+ }
+}
+
+###################################
+package DBI::SQL::Nano::Statement_;
+###################################
+
+sub new {
+ my($class,$sql) = @_;
+ my $self = {};
+ bless $self, $class;
+ return $self->prepare($sql);
+}
+
+#####################################################################
+# PREPARE
+#####################################################################
+sub prepare {
+ my($self,$sql) = @_;
+ $sql =~ s/\s+$//;
+ for ($sql) {
+ /^\s*CREATE\s+TABLE\s+(.*?)\s*\((.+)\)\s*$/is
+ &&do{
+ $self->{command} = 'CREATE';
+ $self->{table_name} = $1;
+ $self->{column_names} = parse_coldef_list($2) if $2;
+ die "Can't find columns\n" unless $self->{column_names};
+ };
+ /^\s*DROP\s+TABLE\s+(IF\s+EXISTS\s+)?(.*?)\s*$/is
+ &&do{
+ $self->{command} = 'DROP';
+ $self->{table_name} = $2;
+ $self->{ignore_missing_table} = 1 if $1;
+ };
+ /^\s*SELECT\s+(.*?)\s+FROM\s+(\S+)((.*))?/is
+ &&do{
+ $self->{command} = 'SELECT';
+ $self->{column_names} = parse_comma_list($1) if $1;
+ die "Can't find columns\n" unless $self->{column_names};
+ $self->{table_name} = $2;
+ if ( my $clauses = $4) {
+ if ($clauses =~ /^(.*)\s+ORDER\s+BY\s+(.*)$/is) {
+ $clauses = $1;
+ $self->{order_clause} = $self->parse_order_clause($2);
+ }
+ $self->{where_clause}=$self->parse_where_clause($clauses)
+ if $clauses;
+ }
+ };
+ /^\s*INSERT\s+INTO\s+(\S+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is
+ &&do{
+ $self->{command} = 'INSERT';
+ $self->{table_name} = $1;
+ $self->{column_names} = parse_comma_list($2) if $2;
+ $self->{values} = $self->parse_values_list($4) if $4;
+ die "Can't parse values\n" unless $self->{values};
+ };
+ /^\s*DELETE\s+FROM\s+(\S+)((.*))?/is
+ &&do{
+ $self->{command} = 'DELETE';
+ $self->{table_name} = $1;
+ $self->{where_clause} = $self->parse_where_clause($3) if $3;
+ };
+ /^\s*UPDATE\s+(\S+)\s+SET\s+(.+)(\s+WHERE\s+.+)/is
+ &&do{
+ $self->{command} = 'UPDATE';
+ $self->{table_name} = $1;
+ $self->parse_set_clause($2) if $2;
+ $self->{where_clause} = $self->parse_where_clause($3) if $3;
+ };
+ }
+ die "Couldn't parse\n"
+ unless $self->{command} and $self->{table_name};
+ return $self;
+}
+sub parse_order_clause {
+ my($self,$str) = @_;
+ my @clause = split /\s+/,$str;
+ return { $clause[0] => 'ASC' } if @clause == 1;
+ die "Bad ORDER BY clause '$str'\n" if @clause > 2;
+ $clause[1] ||= '';
+ return { $clause[0] => uc $clause[1] } if $clause[1] =~ /^ASC$/i
+ or $clause[1] =~ /^DESC$/i;
+ die "Bad ORDER BY clause '$clause[1]'\n";
+}
+sub parse_coldef_list { # check column definitions
+ my @col_defs;
+ for ( split',',shift ) {
+ my $col = clean_parse_str($_);
+ if ( $col =~ /^(\S+?)\s+.+/ ) { # doesn't check what it is
+ $col = $1; # just checks if it exists
+ }
+ else {
+ die "No column definition for '$_'\n";
+ }
+ push @col_defs,$col;
+ }
+ return \@col_defs;
+}
+sub parse_comma_list {[map{clean_parse_str($_)} split(',',shift)]}
+sub clean_parse_str { local $_ = shift; s/\(//;s/\)//;s/^\s+//; s/\s+$//; $_; }
+sub parse_values_list {
+ my($self,$str) = @_;
+ [map{$self->parse_value(clean_parse_str($_))}split(',',$str)]
+}
+sub parse_set_clause {
+ my $self = shift;
+ my @cols = split /,/, shift;
+ my $set_clause;
+ for my $col(@cols) {
+ my($col_name,$value)= $col =~ /^\s*(.+?)\s*=\s*(.+?)\s*$/s;
+ push @{$self->{column_names}}, $col_name;
+ push @{$self->{values}}, $self->parse_value($value);
+ }
+ die "Can't parse set clause\n"
+ unless $self->{column_names}
+ and $self->{values};
+}
+sub parse_value {
+ my($self,$str) = @_;
+ return undef unless defined $str;
+ $str =~ s/\s+$//;
+ $str =~ s/^\s+//;
+ if ($str =~ /^\?$/) {
+ push @{$self->{params}},'?';
+ return { value=>'?' ,type=> 'placeholder' };
+ }
+ return { value=>undef,type=> 'NULL' } if $str =~ /^NULL$/i;
+ return { value=>$1 ,type=> 'string' } if $str =~ /^'(.+)'$/s;
+ return { value=>$str ,type=> 'number' } if DBI::looks_like_number($str);
+ return { value=>$str ,type=> 'column' };
+}
+sub parse_where_clause {
+ my($self,$str) = @_;
+ $str =~ s/\s+$//;
+ if ($str =~ /^\s*WHERE\s+(.*)/i) {
+ $str = $1;
+ }
+ else {
+ die "Couldn't find WHERE clause in '$str'\n";
+ }
+ my($neg) = $str =~ s/^\s*(NOT)\s+//is;
+ my $opexp = '=|<>|<=|>=|<|>|LIKE|CLIKE|IS';
+ my($val1,$op,$val2) = $str =~ /^(.+?)\s*($opexp)\s*(.+)\s*$/iso;
+ die "Couldn't parse WHERE expression '$str'\n"
+ unless defined $val1 and defined $op and defined $val2;
+ return {
+ arg1 => $self->parse_value($val1),
+ arg2 => $self->parse_value($val2),
+ op => $op,
+ neg => $neg,
+ }
+}
+
+#####################################################################
+# EXECUTE
+#####################################################################
+sub execute {
+ my($self, $data, $params) = @_;
+ my $num_placeholders = $self->params;
+ my $num_params = scalar @$params || 0;
+ die "Number of params '$num_params' does not match "
+ . "number of placeholders '$num_placeholders'\n"
+ unless $num_placeholders == $num_params;
+ if (scalar @$params) {
+ for my $i(0..$#{$self->{values}}) {
+ if ($self->{values}->[$i]->{type} eq 'placeholder') {
+ $self->{values}->[$i]->{value} = shift @$params;
+ }
+ }
+ if ($self->{where_clause}) {
+ if ($self->{where_clause}->{arg1}->{type} eq 'placeholder') {
+ $self->{where_clause}->{arg1}->{value} = shift @$params;
+ }
+ if ($self->{where_clause}->{arg2}->{type} eq 'placeholder') {
+ $self->{where_clause}->{arg2}->{value} = shift @$params;
+ }
+ }
+ }
+ my $command = $self->{command};
+ ( $self->{'NUM_OF_ROWS'},
+ $self->{'NUM_OF_FIELDS'},
+ $self->{'data'},
+ ) = $self->$command($data, $params);
+ $self->{NAME} ||= $self->{column_names};
+ $self->{'NUM_OF_ROWS'} || '0E0';
+}
+sub DROP ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 0);
+ $table->drop($data);
+ (-1, 0);
+}
+sub CREATE ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 1, 1);
+ $table->push_names($data, $self->{column_names});
+ (0, 0);
+}
+sub INSERT ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 1);
+ $self->verify_columns($table);
+ $table->seek($data, 0, 2);
+ my($array) = [];
+ my($val, $col, $i);
+ $self->{column_names}=$table->{col_names} unless $self->{column_names};
+ my $cNum = scalar(@{$self->{column_names}}) if $self->{column_names};
+ my $param_num = 0;
+ if ($cNum) {
+ for ($i = 0; $i < $cNum; $i++) {
+ $col = $self->{column_names}->[$i];
+ $array->[$self->column_nums($table,$col)] = $self->row_values($i);
+ }
+ } else {
+ die "Bad col names in INSERT";
+ }
+ $table->push_row($data, $array);
+ (1, 0);
+}
+sub DELETE ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 1);
+ $self->verify_columns($table);
+ my($affected) = 0;
+ my(@rows, $array);
+ if ( $table->can('delete_one_row') ) {
+ while (my $array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ ++$affected;
+ $array = $self->{fetched_value} if $self->{fetched_from_key};
+ $table->delete_one_row($data,$array);
+ return ($affected, 0) if $self->{fetched_from_key};
+ }
+ }
+ return ($affected, 0);
+ }
+ while ($array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ ++$affected;
+ } else {
+ push(@rows, $array);
+ }
+ }
+ $table->seek($data, 0, 0);
+ foreach $array (@rows) {
+ $table->push_row($data, $array);
+ }
+ $table->truncate($data);
+ return ($affected, 0);
+}
+sub SELECT ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 0);
+ $self->verify_columns($table);
+ my $tname = $self->{table_name};
+ my($affected) = 0;
+ my(@rows, $array, $val, $col, $i);
+ while ($array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ $array = $self->{fetched_value} if $self->{fetched_from_key};
+ my $col_nums = $self->column_nums($table);
+ my %cols = reverse %{ $col_nums };
+ my $rowhash;
+ for (sort keys %cols) {
+ $rowhash->{$cols{$_}} = $array->[$_];
+ }
+ my @newarray;
+ for ($i = 0; $i < @{$self->{column_names}}; $i++) {
+ $col = $self->{column_names}->[$i];
+ push @newarray,$rowhash->{$col};
+ }
+ push(@rows, \@newarray);
+ return (scalar(@rows),scalar @{$self->{column_names}},\@rows)
+ if $self->{fetched_from_key};
+ }
+ }
+ if ( $self->{order_clause} ) {
+ my( $sort_col, $desc ) = each %{$self->{order_clause}};
+ undef $desc unless $desc eq 'DESC';
+ my @sortCols = ( $self->column_nums($table,$sort_col,1) );
+ my($c, $d, $colNum);
+ my $sortFunc = sub {
+ my $result;
+ $i = 0;
+ do {
+ $colNum = $sortCols[$i++];
+ # $desc = $sortCols[$i++];
+ $c = $a->[$colNum];
+ $d = $b->[$colNum];
+ if (!defined($c)) {
+ $result = defined $d ? -1 : 0;
+ } elsif (!defined($d)) {
+ $result = 1;
+ } elsif ( DBI::looks_like_number($c) && DBI::looks_like_number($d) ) {
+ $result = ($c <=> $d);
+ } else {
+ if ($self->{"case_fold"}) {
+ $result = lc $c cmp lc $d || $c cmp $d;
+ }
+ else {
+ $result = $c cmp $d;
+ }
+ }
+ if ($desc) {
+ $result = -$result;
+ }
+ } while (!$result && $i < @sortCols);
+ $result;
+ };
+ @rows = (sort $sortFunc @rows);
+ }
+ (scalar(@rows), scalar @{$self->{column_names}}, \@rows);
+}
+sub UPDATE ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 1);
+ $self->verify_columns($table);
+ return undef unless $table;
+ my($affected) = 0;
+ my(@rows, $array, $f_array, $val, $col, $i);
+ while ($array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ $array = $self->{fetched_value} if $self->{fetched_from_key}
+ and $table->can('update_one_row');
+ my $col_nums = $self->column_nums($table);
+ my %cols = reverse %{ $col_nums };
+ my $rowhash;
+ for (sort keys %cols) {
+ $rowhash->{$cols{$_}} = $array->[$_];
+ }
+ for ($i = 0; $i < @{$self->{column_names}}; $i++) {
+ $col = $self->{column_names}->[$i];
+ $array->[$self->column_nums($table,$col)]=$self->row_values($i);
+ }
+ $affected++;
+ if ($self->{fetched_from_key}){
+ $table->update_one_row($data,$array);
+ return ($affected, 0);
+ }
+ push(@rows, $array);
+ }
+ else {
+ push(@rows, $array);
+ }
+ }
+ $table->seek($data, 0, 0);
+ foreach my $array (@rows) {
+ $table->push_row($data, $array);
+ }
+ $table->truncate($data);
+ ($affected, 0);
+}
+sub verify_columns {
+ my($self,$table) = @_;
+ my @cols = @{$self->{column_names}};
+ if ($self->{where_clause}) {
+ if (my $col = $self->{where_clause}->{arg1}) {
+ push @cols, $col->{value} if $col->{type} eq 'column';
+ }
+ if (my $col = $self->{where_clause}->{arg2}) {
+ push @cols, $col->{value} if $col->{type} eq 'column';
+ }
+ }
+ for (@cols) {
+ $self->column_nums($table,$_);
+ }
+}
+sub column_nums {
+ my($self,$table,$stmt_col_name,$find_in_stmt)=@_;
+ my %dbd_nums = %{ $table->{col_nums} };
+ my @dbd_cols = @{ $table->{col_names} };
+ my %stmt_nums;
+ if ($stmt_col_name and !$find_in_stmt) {
+ while(my($k,$v)=each %dbd_nums) {
+ return $v if uc $k eq uc $stmt_col_name;
+ }
+ die "No such column '$stmt_col_name'\n";
+ }
+ if ($stmt_col_name and $find_in_stmt) {
+ for my $i(0..@{$self->{column_names}}) {
+ return $i if uc $stmt_col_name eq uc $self->{column_names}->[$i];
+ }
+ die "No such column '$stmt_col_name'\n";
+ }
+ for my $i(0 .. $#dbd_cols) {
+ for my $stmt_col(@{$self->{column_names}}) {
+ $stmt_nums{$stmt_col} = $i if uc $dbd_cols[$i] eq uc $stmt_col;
+ }
+ }
+ return \%stmt_nums;
+}
+sub eval_where {
+ my $self = shift;
+ my $table = shift;
+ my $rowary = shift;
+ my $where = $self->{"where_clause"} || return 1;
+ my $col_nums = $table->{"col_nums"} ;
+ my %cols = reverse %{ $col_nums };
+ my $rowhash;
+ for (sort keys %cols) {
+ $rowhash->{uc $cols{$_}} = $rowary->[$_];
+ }
+ return $self->process_predicate($where,$table,$rowhash);
+}
+sub process_predicate {
+ my($self,$pred,$table,$rowhash) = @_;
+ my $val1 = $pred->{arg1};
+ if ($val1->{type} eq 'column') {
+ $val1 = $rowhash->{ uc $val1->{value}};
+ }
+ else {
+ $val1 = $val1->{value};
+ }
+ my $val2 = $pred->{arg2};
+ if ($val2->{type}eq 'column') {
+ $val2 = $rowhash->{uc $val2->{value}};
+ }
+ else {
+ $val2 = $val2->{value};
+ }
+ my $op = $pred->{op};
+ my $neg = $pred->{neg};
+ my $match;
+ if ( $op eq '=' and !$neg and $table->can('fetch_one_row')
+ ) {
+ my $key_col = $table->fetch_one_row(1,1);
+ if ($pred->{arg1}->{value} =~ /^$key_col$/i) {
+ $self->{fetched_from_key}=1;
+ $self->{fetched_value} = $table->fetch_one_row(
+ 0,$pred->{arg2}->{value}
+ );
+ return 1;
+ }
+ }
+ $match = $self->is_matched($val1,$op,$val2) || 0;
+ if ($neg) { $match = $match ? 0 : 1; }
+ return $match;
+}
+sub is_matched {
+ my($self,$val1,$op,$val2)=@_;
+ if ($op eq 'IS') {
+ return 1 if (!defined $val1 or $val1 eq '');
+ return 0;
+ }
+ $val1 = '' unless defined $val1;
+ $val2 = '' unless defined $val2;
+ if ($op =~ /LIKE|CLIKE/i) {
+ $val2 = quotemeta($val2);
+ $val2 =~ s/\\%/.*/g;
+ $val2 =~ s/_/./g;
+ }
+ if ($op eq 'LIKE' ) { return $val1 =~ /^$val2$/s; }
+ if ($op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; }
+ if ( DBI::looks_like_number($val1) && DBI::looks_like_number($val2) ) {
+ if ($op eq '<' ) { return $val1 < $val2; }
+ if ($op eq '>' ) { return $val1 > $val2; }
+ if ($op eq '=' ) { return $val1 == $val2; }
+ if ($op eq '<>' ) { return $val1 != $val2; }
+ if ($op eq '<=' ) { return $val1 <= $val2; }
+ if ($op eq '>=' ) { return $val1 >= $val2; }
+ }
+ else {
+ if ($op eq '<' ) { return $val1 lt $val2; }
+ if ($op eq '>' ) { return $val1 gt $val2; }
+ if ($op eq '=' ) { return $val1 eq $val2; }
+ if ($op eq '<>' ) { return $val1 ne $val2; }
+ if ($op eq '<=' ) { return $val1 ge $val2; }
+ if ($op eq '>=' ) { return $val1 le $val2; }
+ }
+}
+sub params {
+ my $self = shift;
+ my $val_num = shift;
+ if (!$self->{"params"}) { return 0; }
+ if (defined $val_num) {
+ return $self->{"params"}->[$val_num];
+ }
+ if (wantarray) {
+ return @{$self->{"params"}};
+ }
+ else {
+ return scalar @{ $self->{"params"} };
+ }
+
+}
+sub open_tables {
+ my($self, $data, $createMode, $lockMode) = @_;
+ my $table_name = $self->{table_name};
+ my $table;
+ eval{$table = $self->open_table($data,$table_name,$createMode,$lockMode)};
+ die $@ if $@;
+ die "Couldn't open table '$table_name'" unless $table;
+ if (!$self->{column_names} or $self->{column_names}->[0] eq '*') {
+ $self->{column_names} = $table->{col_names};
+ }
+ return $table;
+}
+sub row_values {
+ my $self = shift;
+ my $val_num = shift;
+ if (!$self->{"values"}) { return 0; }
+ if (defined $val_num) {
+ return $self->{"values"}->[$val_num]->{value};
+ }
+ if (wantarray) {
+ return map{$_->{"value"} } @{$self->{"values"}};
+ }
+ else {
+ return scalar @{ $self->{"values"} };
+ }
+}
+
+###############################
+package DBI::SQL::Nano::Table_;
+###############################
+sub new ($$) {
+ my($proto, $attr) = @_;
+ my($self) = { %$attr };
+ bless($self, (ref($proto) || $proto));
+ $self;
+}
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+DBI::SQL::Nano - a very tiny SQL engine
+
+=head1 SYNOPSIS
+
+ BEGIN { $ENV{DBI_SQL_NANO}=1 } # forces use of Nano rather than SQL::Statement
+ use DBI::SQL::Nano;
+ use Data::Dumper;
+ my $stmt = DBI::SQL::Nano::Statement->new(
+ "SELECT bar,baz FROM foo WHERE qux = 1"
+ ) or die "Couldn't parse";
+ print Dumper $stmt;
+
+=head1 DESCRIPTION
+
+DBI::SQL::Nano is meant as a *very* minimal SQL engine for use in situations where SQL::Statement is not available. In most situations you are better off installing SQL::Statement although DBI::SQL::Nano may be faster for some very simple tasks.
+
+DBI::SQL::Nano, like SQL::Statement is primarily intended to provide a SQL engine for use with some pure perl DBDs including DBD::DBM, DBD::CSV, DBD::AnyData, and DBD::Excel. It isn't of much use in and of itself. You can dump out the structure of a parsed SQL statement, but that's about it.
+
+=head1 USAGE
+
+=head2 Setting the DBI_SQL_NANO flag
+
+By default, when a DBD uses DBI::SQL::Nano, the module will look to see if SQL::Statement is installed. If it is, SQL::Statement objects are used. If SQL::Statement is not available, DBI::SQL::Nano objects are used.
+
+In some cases, you may wish to use DBI::SQL::Nano objects even if SQL::Statement is available. To force usage of DBI::SQL::Nano objects regardless of the availability of SQL::Statement, set the environment variable DBI_SQL_NANO to 1.
+
+You can set the environment variable in your shell prior to running your script (with SET or EXPORT or whatever), or else you can set it in your script by putting this at the top of the script:
+
+ BEGIN { $ENV{DBI_SQL_NANO} = 1 }
+
+=head2 Supported SQL syntax
+
+ Here's a pseudo-BNF. Square brackets [] indicate optional items;
+ Angle brackets <> indicate items defined elsewhere in the BNF.
+
+ statement ::=
+ DROP TABLE [IF EXISTS] <table_name>
+ | CREATE TABLE <table_name> <col_def_list>
+ | INSERT INTO <table_name> [<insert_col_list>] VALUES <val_list>
+ | DELETE FROM <table_name> [<where_clause>]
+ | UPDATE <table_name> SET <set_clause> <where_clause>
+ | SELECT <select_col_list> FROM <table_name> [<where_clause>]
+ [<order_clause>]
+
+ the optional IF EXISTS clause ::=
+ * similar to MySQL - prevents errors when trying to drop
+ a table that doesn't exist
+
+ identifiers ::=
+ * table and column names should be valid SQL identifiers
+ * especially avoid using spaces and commas in identifiers
+ * note: there is no error checking for invalid names, some
+ will be accepted, others will cause parse failures
+
+ table_name ::=
+ * only one table (no multiple table operations)
+ * see identifier for valid table names
+
+ col_def_list ::=
+ * a parens delimited, comma-separated list of column names
+ * see identifier for valid column names
+ * column types and column constraints may be included but are ignored
+ e.g. these are all the same:
+ (id,phrase)
+ (id INT, phrase VARCHAR(40))
+ (id INT PRIMARY KEY, phrase VARCHAR(40) NOT NULL)
+ * you are *strongly* advised to put in column types even though
+ they are ignored ... it increases portability
+
+ insert_col_list ::=
+ * a parens delimited, comma-separated list of column names
+ * as in standard SQL, this is optional
+
+ select_col_list ::=
+ * a comma-separated list of column names
+ * or an asterisk denoting all columns
+
+ val_list ::=
+ * a parens delimited, comma-separated list of values which can be:
+ * placeholders (an unquoted question mark)
+ * numbers (unquoted numbers)
+ * column names (unquoted strings)
+ * nulls (unquoted word NULL)
+ * strings (delimited with single quote marks);
+ * note: leading and trailing percent mark (%) and underscore (_)
+ can be used as wildcards in quoted strings for use with
+ the LIKE and CLIKE operators
+ * note: escaped single quote marks within strings are not
+ supported, neither are embedded commas, use placeholders instead
+
+ set_clause ::=
+ * a comma-separated list of column = value pairs
+ * see val_list for acceptable value formats
+
+ where_clause ::=
+ * a single "column/value <op> column/value" predicate, optionally
+ preceded by "NOT"
+ * note: multiple predicates combined with ORs or ANDs are not supported
+ * see val_list for acceptable value formats
+ * op may be one of:
+ < > >= <= = <> LIKE CLIKE IS
+ * CLIKE is a case insensitive LIKE
+
+ order_clause ::= column_name [ASC|DESC]
+ * a single column optional ORDER BY clause is supported
+ * as in standard SQL, if neither ASC (ascending) nor
+ DESC (descending) is specified, ASC becomes the default
+
+=head1 ACKNOWLEDGEMENTS
+
+Tim Bunce provided the original idea for this module, helped me out of the tangled trap of namespace, and provided help and advice all along the way. Although I wrote it from the ground up, it is based on Jochen Weidmann's orignal design of SQL::Statement, so much of the credit for the API goes to him.
+
+=head1 AUTHOR AND COPYRIGHT
+
+This module is written and maintained by
+
+Jeff Zucker < jzucker AT cpan.org >
+
+Copyright (C) 2004 by Jeff Zucker, all rights reserved.
+
+You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in
+the Perl README file.
+
+=cut
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Util/CacheMemory.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Util/CacheMemory.pm
new file mode 100755
index 00000000000..f111432c977
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Util/CacheMemory.pm
@@ -0,0 +1,117 @@
+package DBI::Util::CacheMemory;
+
+# $Id: CacheMemory.pm 10314 2007-11-26 22:25:33Z timbo $
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBI::Util::CacheMemory - a very fast but very minimal subset of Cache::Memory
+
+=head1 DESCRIPTION
+
+Like Cache::Memory (part of the Cache distribution) but doesn't support any fancy features.
+
+This module aims to be a very fast compatible strict sub-set for simple cases,
+such as basic client-side caching for DBD::Gofer.
+
+Like Cache::Memory, and other caches in the Cache and Cache::Cache
+distributions, the data will remain in the cache until cleared, it expires,
+or the process dies. The cache object simply going out of scope will I<not>
+destroy the data.
+
+=head1 METHODS WITH CHANGES
+
+=head2 new
+
+All options except C<namespace> are ignored.
+
+=head2 set
+
+Doesn't support expiry.
+
+=head2 purge
+
+Same as clear() - deletes everything in the namespace.
+
+=head1 METHODS WITHOUT CHANGES
+
+=over
+
+=item clear
+
+=item count
+
+=item exists
+
+=item remove
+
+=back
+
+=head1 UNSUPPORTED METHODS
+
+If it's not listed above, it's not supported.
+
+=cut
+
+our $VERSION = sprintf("0.%06d", q$Revision: 10314 $ =~ /(\d+)/o);
+
+my %cache;
+
+sub new {
+ my ($class, %options ) = @_;
+ my $namespace = $options{namespace} ||= 'Default';
+ #$options{_cache} = \%cache; # can be handy for debugging/dumping
+ my $self = bless \%options => $class;
+ $cache{ $namespace } ||= {}; # init - ensure it exists
+ return $self;
+}
+
+sub set {
+ my ($self, $key, $value) = @_;
+ $cache{ $self->{namespace} }->{$key} = $value;
+}
+
+sub get {
+ my ($self, $key) = @_;
+ return $cache{ $self->{namespace} }->{$key};
+}
+
+sub exists {
+ my ($self, $key) = @_;
+ return exists $cache{ $self->{namespace} }->{$key};
+}
+
+sub remove {
+ my ($self, $key) = @_;
+ return delete $cache{ $self->{namespace} }->{$key};
+}
+
+sub purge {
+ return shift->clear;
+}
+
+sub clear {
+ $cache{ shift->{namespace} } = {};
+}
+
+sub count {
+ return scalar keys %{ $cache{ shift->{namespace} } };
+}
+
+sub size {
+ my $c = $cache{ shift->{namespace} };
+ my $size = 0;
+ while ( my ($k,$v) = each %$c ) {
+ $size += length($k) + length($v);
+ }
+ return $size;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Util/_accessor.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Util/_accessor.pm
new file mode 100755
index 00000000000..7836ebea952
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/Util/_accessor.pm
@@ -0,0 +1,65 @@
+package DBI::Util::_accessor;
+use strict;
+use Carp;
+our $VERSION = sprintf("0.%06d", q$Revision: 9478 $ =~ /(\d+)/);
+
+# inspired by Class::Accessor::Fast
+
+sub new {
+ my($proto, $fields) = @_;
+ my($class) = ref $proto || $proto;
+ $fields ||= {};
+
+ my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields;
+ carp "$class doesn't have accessors for fields: @dubious" if @dubious;
+
+ # make a (shallow) copy of $fields.
+ bless {%$fields}, $class;
+}
+
+sub mk_accessors {
+ my($self, @fields) = @_;
+ $self->mk_accessors_using('make_accessor', @fields);
+}
+
+sub mk_accessors_using {
+ my($self, $maker, @fields) = @_;
+ my $class = ref $self || $self;
+
+ # So we don't have to do lots of lookups inside the loop.
+ $maker = $self->can($maker) unless ref $maker;
+
+ no strict 'refs';
+ foreach my $field (@fields) {
+ my $accessor = $self->$maker($field);
+ *{$class."\:\:$field"} = $accessor
+ unless defined &{$class."\:\:$field"};
+ }
+ #my $hash_ref = \%{$class."\:\:_accessors_hash};
+ #$hash_ref->{$_}++ for @fields;
+ # XXX also copy down _accessors_hash of base class(es)
+ # so one in this class is complete
+ return;
+}
+
+sub make_accessor {
+ my($class, $field) = @_;
+ return sub {
+ my $self = shift;
+ return $self->{$field} unless @_;
+ croak "Too many arguments to $field" if @_ > 1;
+ return $self->{$field} = shift;
+ };
+}
+
+sub make_accessor_autoviv_hashref {
+ my($class, $field) = @_;
+ return sub {
+ my $self = shift;
+ return $self->{$field} ||= {} unless @_;
+ croak "Too many arguments to $field" if @_ > 1;
+ return $self->{$field} = shift;
+ };
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/W32ODBC.pm b/Master/tlpkg/tlperl.straw/lib/DBI/W32ODBC.pm
new file mode 100755
index 00000000000..ac2aea11699
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBI/W32ODBC.pm
@@ -0,0 +1,181 @@
+package
+ DBI; # hide this non-DBI package from simple indexers
+
+# $Id: W32ODBC.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# Copyright (c) 1997,1999 Tim Bunce
+# With many thanks to Patrick Hollins for polishing.
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+=head1 NAME
+
+DBI::W32ODBC - An experimental DBI emulation layer for Win32::ODBC
+
+=head1 SYNOPSIS
+
+ use DBI::W32ODBC;
+
+ # apart from the line above everything is just the same as with
+ # the real DBI when using a basic driver with few features.
+
+=head1 DESCRIPTION
+
+This is an experimental pure perl DBI emulation layer for Win32::ODBC
+
+If you can improve this code I'd be interested in hearing about it. If
+you are having trouble using it please respect the fact that it's very
+experimental. Ideally fix it yourself and send me the details.
+
+=head2 Some Things Not Yet Implemented
+
+ Most attributes including PrintError & RaiseError.
+ type_info and table_info
+
+Volunteers welcome!
+
+=cut
+
+${'DBI::VERSION'} # hide version from PAUSE indexer
+ = "0.01";
+
+my $Revision = sprintf("12.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+
+sub DBI::W32ODBC::import { } # must trick here since we're called DBI/W32ODBC.pm
+
+
+use Carp;
+
+use Win32::ODBC;
+
+@ISA = qw(Win32::ODBC);
+
+use strict;
+
+$DBI::dbi_debug = $ENV{PERL_DBI_DEBUG} || 0;
+carp "Loaded (W32ODBC) DBI.pm ${'DBI::VERSION'} (debug $DBI::dbi_debug)"
+ if $DBI::dbi_debug;
+
+
+
+sub connect {
+ my ($class, $dbname, $dbuser, $dbpasswd, $module, $attr) = @_;
+ $dbname .= ";UID=$dbuser" if $dbuser;
+ $dbname .= ";PWD=$dbpasswd" if $dbpasswd;
+ my $h = new Win32::ODBC $dbname;
+ warn "Error connecting to $dbname: ".Win32::ODBC::Error()."\n" unless $h;
+ bless $h, $class if $h; # rebless into our class
+ $h;
+}
+
+
+sub quote {
+ my ($h, $string) = @_;
+ return "NULL" if !defined $string;
+ $string =~ s/'/''/g; # standard
+ # This hack seems to be required for Access but probably breaks for
+ # other databases when using \r and \n. It would be better if we could
+ # use ODBC options to detect that we're actually using Access.
+ $string =~ s/\r/' & chr\$(13) & '/g;
+ $string =~ s/\n/' & chr\$(10) & '/g;
+ "'$string'";
+}
+
+sub do {
+ my($h, $statement, $attribs, @params) = @_;
+ Carp::carp "\$h->do() attribs unused" if $attribs;
+ my $new_h = $h->prepare($statement) or return undef; ##
+ pop @{ $h->{'___sths'} }; ## certian death assured
+ $new_h->execute(@params) or return undef; ##
+ my $rows = $new_h->rows; ##
+ $new_h->finish; ## bang bang
+ ($rows == 0) ? "0E0" : $rows;
+}
+
+# ---
+
+sub prepare {
+ my ($h, $sql) = @_;
+ ## opens a new connection with every prepare to allow
+ ## multiple, concurrent queries
+ my $new_h = new Win32::ODBC $h->{DSN}; ##
+ return undef if not $new_h; ## bail if no connection
+ bless $new_h; ## shouldn't be sub-classed...
+ $new_h->{'__prepare'} = $sql; ##
+ $new_h->{NAME} = []; ##
+ $new_h->{NUM_OF_FIELDS} = -1; ##
+ push @{ $h->{'___sths'} } ,$new_h; ## save sth in parent for mass destruction
+ return $new_h; ##
+}
+
+sub execute {
+ my ($h) = @_;
+ my $rc = $h->Sql($h->{'__prepare'});
+ return undef if $rc;
+ my @fields = $h->FieldNames;
+ $h->{NAME} = \@fields;
+ $h->{NUM_OF_FIELDS} = scalar @fields;
+ $h; # return dbh as pseudo sth
+}
+
+
+sub fetchrow_hashref { ## provide DBI compatibility
+ my $h = shift;
+ my $NAME = shift || "NAME";
+ my $row = $h->fetchrow_arrayref or return undef;
+ my %hash;
+ @hash{ @{ $h->{$NAME} } } = @$row;
+ return \%hash;
+}
+
+sub fetchrow {
+ my $h = shift;
+ return unless $h->FetchRow();
+ my $fields_r = $h->{NAME};
+ return $h->Data(@$fields_r);
+}
+sub fetch {
+ my @row = shift->fetchrow;
+ return undef unless @row;
+ return \@row;
+}
+*fetchrow_arrayref = \&fetch; ## provide DBI compatibility
+*fetchrow_array = \&fetchrow; ## provide DBI compatibility
+
+sub rows {
+ shift->RowCount;
+}
+
+sub finish {
+ shift->Close; ## uncommented this line
+}
+
+# ---
+
+sub commit {
+ shift->Transact(ODBC::SQL_COMMIT);
+}
+sub rollback {
+ shift->Transact(ODBC::SQL_ROLLBACK);
+}
+
+sub disconnect {
+ my ($h) = shift; ## this will kill all the statement handles
+ foreach (@{$h->{'___sths'}}) { ## created for a specific connection
+ $_->Close if $_->{DSN}; ##
+ } ##
+ $h->Close; ##
+}
+
+sub err {
+ (shift->Error)[0];
+}
+sub errstr {
+ scalar( shift->Error );
+}
+
+# ---
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/DBM_Filter.pm b/Master/tlpkg/tlperl.straw/lib/DBM_Filter.pm
new file mode 100755
index 00000000000..8947c0c3d40
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/DBM_Filter.pm
@@ -0,0 +1,605 @@
+package DBM_Filter ;
+
+use strict;
+use warnings;
+our $VERSION = '0.02';
+
+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 ( ! defined %{ "${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.straw/lib/Data/Buffer.pm b/Master/tlpkg/tlperl.straw/lib/Data/Buffer.pm
new file mode 100755
index 00000000000..0f085ad30d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Buffer.pm
@@ -0,0 +1,465 @@
+# $Id: Buffer.pm,v 1.9 2001/07/28 06:36:50 btrott Exp $
+
+package Data::Buffer;
+use strict;
+
+use vars qw( $VERSION );
+$VERSION = '0.04';
+
+sub new {
+ my $class = shift;
+ my %arg = @_;
+ bless { buf => "", offset => 0, template => "" }, $class;
+}
+
+sub new_with_init {
+ my $class = shift;
+ my $buf = $class->new;
+ $buf->append($_) for @_;
+ $buf;
+}
+
+sub extract {
+ my $buf = shift;
+ my($nbytes) = @_;
+ my $new = ref($buf)->new;
+ $new->append( $buf->get_bytes($nbytes) );
+ $new;
+}
+
+sub empty {
+ my $buf = shift;
+ $buf->{buf} = "";
+ $buf->{offset} = 0;
+ $buf->{template} = "";
+}
+
+sub set_offset { $_[0]->{offset} = $_[1] }
+sub reset_offset { $_[0]->set_offset(0) }
+
+sub insert_template {
+ my $buf = shift;
+ $buf->bytes(0, 0, $buf->{template} . chr(0));
+}
+
+sub append {
+ my $buf = shift;
+ $buf->{buf} .= $_[0];
+}
+
+sub bytes {
+ my $buf = shift;
+ my($off, $len, $rep) = @_;
+ $off ||= 0;
+ $len = length $buf->{buf} unless defined $len;
+ return defined $rep ?
+ substr($buf->{buf}, $off, $len, $rep) :
+ substr($buf->{buf}, $off, $len);
+}
+
+sub length { length $_[0]->{buf} }
+sub offset { $_[0]->{offset} }
+sub template { $_[0]->{template} }
+
+sub dump {
+ my $buf = shift;
+ my @r;
+ for my $c (split //, $buf->bytes(@_)) {
+ push @r, sprintf "%02x", ord $c;
+ push @r, "\n" unless @r % 24;
+ }
+ join ' ', @r
+}
+
+sub get_all {
+ my $buf = shift;
+ my($tmpl, $data) = $buf->{buf} =~ /^([NYaCn\d]+)\0(.+)$/s or
+ die "Buffer $buf does not appear to contain a template";
+ my $b = __PACKAGE__->new;
+ $b->append($data);
+ my @tmpl = split //, $tmpl;
+ my @data;
+ while (@tmpl) {
+ my $el = shift @tmpl;
+ if ($el eq "N") {
+ next if $tmpl[0] eq "Y"; ## Peek ahead: is it a string?
+ push @data, $b->get_int32;
+ }
+ elsif ($el eq "n") {
+ push @data, $b->get_int16;
+ }
+ elsif ($el eq "C") {
+ push @data, $b->get_int8;
+ }
+ elsif ($el eq "a") {
+ my $len = shift @tmpl;
+ push @data, $b->get_char for 1..$len;
+ }
+ elsif ($el eq "Y") {
+ push @data, $b->get_str;
+ }
+ else {
+ die "Unrecognized template token: $el";
+ }
+ }
+ @data;
+}
+
+sub get_int8 {
+ my $buf = shift;
+ my $off = defined $_[0] ? shift : $buf->{offset};
+ $buf->{offset} += 1;
+ unpack "C", $buf->bytes($off, 1);
+}
+
+sub put_int8 {
+ my $buf = shift;
+ $buf->{buf} .= pack "C", $_[0];
+ $buf->{template} .= "C";
+}
+
+sub get_int16 {
+ my $buf = shift;
+ my $off = defined $_[0] ? shift : $buf->{offset};
+ $buf->{offset} += 2;
+ unpack "n", $buf->bytes($off, 2);
+}
+
+sub put_int16 {
+ my $buf = shift;
+ $buf->{buf} .= pack "n", $_[0];
+ $buf->{template} .= "n";
+}
+
+sub get_int32 {
+ my $buf = shift;
+ my $off = defined $_[0] ? shift : $buf->{offset};
+ $buf->{offset} += 4;
+ unpack "N", $buf->bytes($off, 4);
+}
+
+sub put_int32 {
+ my $buf = shift;
+ $buf->{buf} .= pack "N", $_[0];
+ $buf->{template} .= "N";
+}
+
+sub get_char {
+ my $buf = shift;
+ my $off = defined $_[0] ? shift : $buf->{offset};
+ $buf->{offset}++;
+ $buf->bytes($off, 1);
+}
+
+sub put_char {
+ my $buf = shift;
+ $buf->{buf} .= $_[0];
+ $buf->{template} .= "a" . CORE::length($_[0]);
+}
+
+sub get_bytes {
+ my $buf = shift;
+ my($nbytes) = @_;
+ my $d = $buf->bytes($buf->{offset}, $nbytes);
+ $buf->{offset} += $nbytes;
+ $d;
+}
+
+sub put_bytes {
+ my $buf = shift;
+ my($str, $nbytes) = @_;
+ $buf->{buf} .= $nbytes ? substr($str, 0, $nbytes) : $str;
+ $buf->{template} .= "a" . ($nbytes ? $nbytes : CORE::length($str));
+}
+
+*put_chars = \&put_char;
+
+sub get_str {
+ my $buf = shift;
+ my $off = defined $_[0] ? shift : $buf->{offset};
+ my $len = $buf->get_int32;
+ $buf->{offset} += $len;
+ $buf->bytes($off+4, $len);
+}
+
+sub put_str {
+ my $buf = shift;
+ my $str = shift;
+ $str = "" unless defined $str;
+ $buf->put_int32(CORE::length($str));
+ $buf->{buf} .= $str;
+ $buf->{template} .= "Y";
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Data::Buffer - Read/write buffer class
+
+=head1 SYNOPSIS
+
+ use Data::Buffer;
+ my $buffer = Data::Buffer->new;
+
+ ## Add a 32-bit integer.
+ $buffer->put_int32(10932930);
+
+ ## Get it back.
+ my $int = $buffer->get_int32;
+
+=head1 DESCRIPTION
+
+I<Data::Buffer> implements a low-level binary buffer in which
+you can get and put integers, strings, and other data.
+Internally the implementation is based on C<pack> and C<unpack>,
+such that I<Data::Buffer> is really a layer on top of those
+built-in functions.
+
+All of the I<get_*> and I<put_*> methods respect the
+internal offset state in the buffer object. This means that
+you should read data out of the buffer in the same order that
+you put it in. For example:
+
+ $buf->put_int16(24);
+ $buf->put_int32(1233455);
+ $buf->put_int16(99);
+
+ $buf->get_int16; # 24
+ $buf->get_int32; # 1233455
+ $buf->get_int16; # 99
+
+Of course, this assumes that you I<know> the order of the data
+items in the buffer. If your setup is such that your sending
+and receiving processes won't necessarily know what's inside
+the buffers they receive, take a look at the I<TEMPLATE USAGE>
+section.
+
+=head1 USAGE
+
+=head2 Data::Buffer->new
+
+Creates a new buffer object and returns it. The buffer is
+initially empty.
+
+This method takes no arguments.
+
+=head2 Data::Buffer->new_with_init(@strs)
+
+Creates a new buffer object and appends to it each of the
+octet strings in I<@strs>.
+
+Returns the new buffer object.
+
+=head2 $buffer->get_int8
+
+Returns the next 8-bit integer from the buffer (which
+is really just the ASCII code for the next character/byte
+in the buffer).
+
+=head2 $buffer->put_int8
+
+Appends an 8-bit integer to the buffer (which is really
+just the character corresponding to that integer, in
+ASCII).
+
+=head2 $buffer->get_int16
+
+Returns the next 16-bit integer from the buffer.
+
+=head2 $buffer->put_int16($integer)
+
+Appends a 16-bit integer to the buffer.
+
+=head2 $buffer->get_int32
+
+Returns the next 32-bit integer from the buffer.
+
+=head2 $buffer->put_int32($integer)
+
+Appends a 32-bit integer to the buffer.
+
+=head2 $buffer->get_char
+
+More appropriately called I<get_byte>, perhaps, this
+returns the next byte from the buffer.
+
+=head2 $buffer->put_char($bytes)
+
+Appends a byte (or a sequence of bytes) to the buffer.
+There is no restriction on the length of the byte
+string I<$bytes>; if it makes you uncomfortable to call
+I<put_char> to put multiple bytes, you can instead
+call this method as I<put_chars>. It's the same thing.
+
+=head2 $buffer->get_bytes($n)
+
+Grabs I<$n> bytes from the buffer, where I<$n> is a positive
+integer. Increments the internal offset state by I<$n>.
+
+=head2 $buffer->put_bytes($bytes [, $n ])
+
+Appends a sequence of bytes to the buffer; if I<$n> is
+unspecified, appends the entire length of I<$bytes>.
+Otherwise appends only the first I<$n> bytes of I<$bytes>.
+
+=head2 $buffer->get_str
+
+Returns the next "string" from the buffer. A string here
+is represented as the length of the string (a 32-bit
+integer) followed by the string itself.
+
+=head2 $buffer->put_str($string)
+
+Appends a string (32-bit integer length and the string
+itself) to the buffer.
+
+=head2 $buffer->extract($n)
+
+Extracts the next I<$n> bytes from the buffer I<$buffer>,
+increments the offset state in I<$buffer>, and returns a
+new buffer object containing the extracted bytes.
+
+=head1 TEMPLATE USAGE
+
+Generally when you use I<Data::Buffer> it's to communicate
+with another process (perhaps a C program) that bundles up
+its data into binary buffers. In those cases, it's very likely
+that the data will be in some well-known order in the buffer:
+in other words, it might be documented that a certain C program
+creates a buffer containing:
+
+=over 4
+
+=item * an int8
+
+=item * a string
+
+=item * an int32
+
+=back
+
+In this case, you would presumably know about the order of the
+data in the buffer, and you could extract it accordingly:
+
+ $buffer->get_int8;
+ $buffer->get_str;
+ $buffer->get_int32;
+
+In other cases, however, there may not be a well-defined order
+of data items in the buffer. This might be the case if you're
+inventing your own protocol, and you want your binary buffers
+to "know" about their contents. In this case, you'll want to
+use the templating features of I<Data::Buffer>.
+
+When you use the I<put_> methods to place data in a buffer,
+I<Data::Buffer> keeps track of the types of data that you're
+inserting in a template description of the buffer. This template
+contains all of the information necessary for a process to
+receive a buffer and extract the data in the buffer without
+knowledge of the order of the items.
+
+To use this feature, simply use the I<insert_template> method
+after you've filled your buffer to completion. For example:
+
+ my $buffer = Data::Buffer->new;
+ $buffer->put_str("foo");
+ $buffer->put_int32(9999);
+ $buffer->insert_template;
+
+ ## Ship off the buffer to another process.
+
+The receiving process should then invoke the I<get_all> method
+on the buffer to extract all of the data:
+
+ my $buffer = Data::Buffer->new;
+ $buffer->append( $received_buffer_data );
+ my @data = $buffer->get_all;
+
+@data will now contain two elements: C<"foo"> and C<9999>.
+
+=head1 LOW-LEVEL METHODS
+
+=head2 $buffer->append($bytes)
+
+Appends raw data I<$bytes> to the end of the in-memory
+buffer. Generally you don't need to use this method
+unless you're initializing an empty buffer, because
+when you need to add data to a buffer you should
+generally use one of the I<put_*> methods.
+
+=head2 $buffer->empty
+
+Empties out the buffer object.
+
+=head2 $buffer->bytes([ $offset [, $length [, $replacement ]]])
+
+Behaves exactly like the I<substr> built-in function,
+except on the buffer I<$buffer>. Given no arguments,
+I<bytes> returns the entire buffer; given one argument
+I<$offset>, returns everything from that position to
+the end of the string; given I<$offset> and I<$length>,
+returns the segment of the buffer starting at I<$offset>
+and consisting of I<$length> bytes; and given all three
+arguments, replaces that segment with I<$replacement>.
+
+This is a very low-level method, and you generally
+won't need to use it.
+
+Also be warned that you should not intermix use of this
+method with use of the I<get_*> and I<put_*> methods;
+the latter classes of methods maintain internal state
+of the buffer offset where arguments will be gotten from
+and put, respectively. The I<bytes> method gives no
+thought to this internal offset state.
+
+=head2 $buffer->length
+
+Returns the length of the buffer object.
+
+=head2 $buffer->offset
+
+Returns the internal offset state.
+
+If you insist on intermixing calls to I<bytes> with calls
+to the I<get_*> and I<put_*> methods, you'll probably
+want to use this method to get some status on that
+internal offset.
+
+=head2 $buffer->set_offset($offset)
+
+Sets the internal offset state to I<$offset>.
+
+=head2 $buffer->reset_offset
+
+Sets the internal offset state to 0.
+
+=head2 $buffer->dump(@args)
+
+Returns a hex dump of the buffer. The dump is of the I<entire>
+buffer I<$buffer>; in other words, I<dump> doesn't respect the
+internal offset pointer.
+
+I<@args> is passed directly through to the I<bytes> method,
+which means that you can supply arguments to emulate support
+of the internal offset:
+
+ my $dump = $buffer->dump($buffer->offset);
+
+=head2 $buffer->insert_padding
+
+A helper method: pads out the buffer so that the length
+of the transferred packet will be evenly divisible by
+8, which is a requirement of the SSH protocol.
+
+=head1 AUTHOR & COPYRIGHTS
+
+Benjamin Trott, ben@rhumba.pair.com
+
+Except where otherwise noted, Data::Buffer is Copyright 2001
+Benjamin Trott. All rights reserved. Data::Buffer is free
+software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Data/Compare.pm b/Master/tlpkg/tlperl.straw/lib/Data/Compare.pm
new file mode 100755
index 00000000000..3c7b2cb78ec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Compare.pm
@@ -0,0 +1,436 @@
+# $Id: Compare.pm,v 1.10 2008/08/26 20:51:36 drhyde Exp $
+# Data::Compare - compare perl data structures
+# Author: Fabien Tassin <fta@sofaraway.org>
+# updated by David Cantrell <david@cantrell.org.uk>
+# Copyright 1999-2001 Fabien Tassin <fta@sofaraway.org>
+# portions Copyright 2003 - 2008 David Cantrell
+
+package Data::Compare;
+
+use strict;
+use warnings;
+
+use vars qw(@ISA @EXPORT $VERSION $DEBUG %been_there);
+use Exporter;
+use Carp;
+use Scalar::Util;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(Compare);
+$VERSION = 1.2101;
+$DEBUG = 0;
+
+my %handler;
+
+use Cwd;
+
+sub import {
+ if(eval { chdir(getcwd()) }) { # chdir(getcwd()) isn't taint-safe
+ register_plugins();
+ }
+ __PACKAGE__->export_to_level(1, @EXPORT);
+}
+
+# finds and registers plugins
+sub register_plugins {
+ eval 'use File::Find::Rule';
+ foreach my $file (
+ File::Find::Rule
+ ->file()
+ ->name('*.pm')
+ ->in(
+ map { "$_/Data/Compare/Plugins" }
+ grep { -d "$_/Data/Compare/Plugins" }
+ @INC
+ )
+ ) {
+ # all of this just to avoid loading the same plugin twice and
+ # generating a pile of warnings. Grargh!
+ $file =~ s!.*(Data/Compare/Plugins/.*)\.pm$!$1!;
+ $file =~ s!/!::!g;
+ # ignore badly named example from earlier version, oops
+ next if($file eq 'Data::Compare::Plugins::Scalar-Properties');
+ my $requires = eval "require $file";
+ next if($requires eq '1'); # already loaded this plugin?
+
+ # not an arrayref? bail
+ if(ref($requires) ne 'ARRAY') {
+ warn("$file isn't a valid Data::Compare plugin (didn't return arrayref)\n");
+ return;
+ }
+ # coerce into arrayref of arrayrefs if necessary
+ if(ref((@{$requires})[0]) ne 'ARRAY') { $requires = [$requires] }
+
+ # register all the handlers
+ foreach my $require (@{$requires}) {
+ my($handler, $type1, $type2, $cruft) = reverse @{$require};
+ $type2 = $type1 unless(defined($type2));
+ ($type1, $type2) = sort($type1, $type2);
+ if(!defined($type1) || ref($type1) ne '' || !defined($type2) || ref($type2) ne '') {
+ warn("$file isn't a valid Data::Compare plugin (invalid type)\n");
+ } elsif(defined($cruft)) {
+ warn("$file isn't a valid Data::Compare plugin (extra data)\n");
+ } elsif(ref($handler) ne 'CODE') {
+ warn("$file isn't a valid Data::Compare plugin (no coderef)\n");
+ } else {
+ $handler{$type1}{$type2} = $handler;
+ }
+ }
+ }
+}
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = {};
+ bless $self, $class;
+ $self->{'x'} = shift;
+ $self->{'y'} = shift;
+ return $self;
+}
+
+sub Cmp {
+ my $self = shift;
+
+ croak "Usage: DataCompareObj->Cmp(x, y)" unless $#_ == 1 || $#_ == -1;
+ my $x = shift || $self->{'x'};
+ my $y = shift || $self->{'y'};
+
+ return Compare($x, $y);
+}
+
+sub Compare {
+ croak "Usage: Data::Compare::Compare(x, y, [opts])\n" unless $#_ == 1 || $#_ == 2;
+
+ my $x = shift;
+ my $y = shift;
+ my $opts = shift || {};
+ my($xparent, $xpos, $yparent, $ypos) = map {
+ $opts->{$_} || ''
+ } qw(xparent xpos yparent ypos);
+
+ my $rval = '';
+
+ if(!exists($opts->{recursion_detector})) {
+ %been_there = ();
+ $opts->{recursion_detector} = 0;
+ }
+ $opts->{recursion_detector}++;
+
+ warn "Yaroo! deep recursion!\n" if($opts->{recursion_detector} == 99);
+
+ if(
+ (ref($x) && exists($been_there{"$x-$xpos-$xparent"}) && $been_there{"$x-$xpos-$xparent"} > 1) ||
+ (ref($y) && exists($been_there{"$y-$ypos-$yparent"}) && $been_there{"$y-$ypos-$yparent"} > 1)
+ ) {
+ $rval = 0; # is this the right thing to do?
+ } else {
+ $been_there{"$x-$xpos-$xparent"}++ if(ref($x));
+ $been_there{"$y-$ypos-$yparent"}++ if(ref($y));
+
+ $opts->{ignore_hash_keys} = { map {
+ ($_, 1)
+ } @{$opts->{ignore_hash_keys}} } if(ref($opts->{ignore_hash_keys}) eq 'ARRAY');
+
+ my $refx = ref $x;
+ my $refy = ref $y;
+
+ if(exists($handler{$refx}) && exists($handler{$refx}{$refy})) {
+ $rval = &{$handler{$refx}{$refy}}($x, $y, $opts);
+ } elsif(exists($handler{$refy}) && exists($handler{$refy}{$refx})) {
+ $rval = &{$handler{$refy}{$refx}}($x, $y, $opts);
+ }
+
+ elsif(!$refx && !$refy) { # both are scalars
+ if(defined $x && defined $y) { # both are defined
+ $rval = $x eq $y;
+ } else { $rval = !(defined $x || defined $y); }
+ }
+ elsif ($refx ne $refy) { # not the same type
+ $rval = 0;
+ }
+ elsif ($x == $y) { # exactly the same reference
+ $rval = 1;
+ }
+ elsif ($refx eq 'SCALAR' || $refx eq 'REF') {
+ $rval = Compare(${$x}, ${$y}, $opts);
+ }
+ elsif ($refx eq 'ARRAY') {
+ if ($#{$x} == $#{$y}) { # same length
+ my $i = -1;
+ $rval = 1;
+ for (@$x) {
+ $i++;
+ $rval = 0 unless Compare($x->[$i], $y->[$i], { %{$opts}, xparent => $x, xpos => $i, yparent => $y, ypos => $i});
+ }
+ }
+ else {
+ $rval = 0;
+ }
+ }
+ elsif ($refx eq 'HASH') {
+ my @kx = grep { !$opts->{ignore_hash_keys}->{$_} } keys %$x;
+ my @ky = grep { !$opts->{ignore_hash_keys}->{$_} } keys %$y; # heh, KY
+ $rval = 1;
+ $rval = 0 unless scalar @kx == scalar @ky;
+
+ for (@kx) {
+ next unless defined $x->{$_} || defined $y->{$_};
+ $rval = 0 unless defined $y->{$_} && Compare($x->{$_}, $y->{$_}, { %{$opts}, xparent => $x, xpos => $_, yparent => $y, ypos => $_});
+ }
+ }
+ elsif($refx eq 'Regexp') {
+ $rval = Compare($x.'', $y.'', $opts);
+ }
+ elsif ($refx eq 'CODE') {
+ $rval = 0;
+ }
+ elsif ($refx eq 'GLOB') {
+ $rval = 0;
+ }
+ else { # a package name (object blessed)
+ my ($type) = "$x" =~ m/^$refx=(\S+)\(/;
+ if ($type eq 'HASH') {
+ my %x = %$x;
+ my %y = %$y;
+ $rval = Compare(\%x, \%y, { %{$opts}, xparent => $xparent, xpos => $xpos, yparent => $yparent, ypos => $ypos});
+ $been_there{\%x."-$xpos-$xparent"}--; # decrement count for temp structures
+ $been_there{\%y."-$ypos-$yparent"}--;
+ }
+ elsif ($type eq 'ARRAY') {
+ my @x = @$x;
+ my @y = @$y;
+ $rval = Compare(\@x, \@y, { %{$opts}, xparent => $xparent, xpos => $xpos, yparent => $yparent, ypos => $ypos});
+ $been_there{\@x."-$xpos-$xparent"}--;
+ $been_there{\@y."-$ypos-$yparent"}--;
+ }
+ elsif ($type eq 'SCALAR' || $type eq 'REF') {
+ my $x = ${$x};
+ my $y = ${$y};
+ $rval = Compare($x, $y, $opts);
+ # $been_there{\$x}--;
+ # $been_there{\$y}--;
+ }
+ elsif ($type eq 'GLOB') {
+ $rval = 0;
+ }
+ elsif ($type eq 'CODE') {
+ $rval = 0;
+ }
+ else {
+ croak "Can't handle $type type.";
+ $rval = 0;
+ }
+ }
+ }
+ $opts->{recursion_detector}--;
+ return $rval;
+}
+
+sub plugins {
+ return { map { (($_ eq '') ? '[scalar]' : $_, [map { $_ eq '' ? '[scalar]' : $_ } keys %{$handler{$_}}]) } keys %handler };
+}
+
+sub plugins_printable {
+ my $r = "The following comparisons are available through plugins\n\n";
+ foreach my $key (sort keys %handler) {
+ foreach(sort keys %{$handler{$key}}) {
+ $r .= join(":\t", map { $_ eq '' ? '[scalar]' : $_ } ($key, $_))."\n";
+ }
+ }
+ return $r;
+}
+
+1;
+
+=head1 NAME
+
+Data::Compare - compare perl data structures
+
+=head1 SYNOPSIS
+
+ use Data::Compare;
+
+ my $h1 = { 'foo' => [ 'bar', 'baz' ], 'FOO' => [ 'one', 'two' ] };
+ my $h2 = { 'foo' => [ 'bar', 'barf' ], 'FOO' => [ 'one', 'two' ] };
+ my @a1 = ('one', 'two');
+ my @a2 = ('bar', 'baz');
+ my %v = ( 'FOO', \@a1, 'foo', \@a2 );
+
+ # simple procedural interface
+ print 'structures of $h1 and \%v are ',
+ Compare($h1, \%v) ? "" : "not ", "identical.\n";
+
+ print 'structures of $h1 and $h2 are ',
+ Compare($h1, $h2, { ignore_hash_keys => [qw(foo)] }) ? '' : 'not ',
+ "close enough to identical.\n";
+
+ # OO usage
+ my $c = new Data::Compare($h1, \%v);
+ print 'structures of $h1 and \%v are ',
+ $c->Cmp ? "" : "not ", "identical.\n";
+ # or
+ my $c = new Data::Compare;
+ print 'structures of $h and \%v are ',
+ $c->Cmp($h1, \%v) ? "" : "not ", "identical.\n";
+
+=head1 DESCRIPTION
+
+Compare two perl data structures recursively. Returns 0 if the
+structures differ, else returns 1.
+
+A few data types are treated as special cases:
+
+=over 4
+
+=item Scalar::Properties objects
+
+This has been moved into a plugin, although functionality remains the
+same as with the previous version. Full documentation is in
+L<Data::Compare::Plugins::Scalar::Properties>.
+
+=item Compiled regular expressions, eg qr/foo/
+
+These are stringified before comparison, so the following will match:
+
+ $r = qr/abc/i;
+ $s = qr/abc/i;
+ Compare($r, $s);
+
+and the following won't, despite them matching *exactly* the same text:
+
+ $r = qr/abc/i;
+ $s = qr/[aA][bB][cC]/;
+ Compare($r, $s);
+
+Sorry, that's the best we can do.
+
+=item CODE and GLOB references
+
+These are assumed not to match unless the references are identical - ie,
+both are references to the same thing.
+
+=back
+
+You may also customise how we compare structures by supplying options in
+a hashref as a third parameter to the C<Compare()> function. This is not
+yet available through the OO-ish interface. These options will be in
+force for the *whole* of your comparison, so will apply to structures
+that are lurking deep down in your data as well as at the top level, so
+beware!
+
+=over 4
+
+=item ignore_hash_keys
+
+an arrayref of strings. When comparing two hashes, any keys mentioned in
+this list will be ignored.
+
+=back
+
+=head1 CIRCULAR STRUCTURES
+
+Comparing a circular structure to itself returns true:
+
+ $x = \$y;
+ $y = \$x;
+ Compare([$x, $y], [$x, $y]);
+
+But comparing two different circular structures returns false:
+
+ $x = \$y;
+ $y = \$x;
+ Compare([$x, $y], [$y, $x]); # <-- note different order
+
+And on a sort-of-related note, if you try to compare insanely deeply nested
+structures, the module will spit a warning. For this to affect you, you need to go
+around a hundred levels deep though, and if you do that you have bigger
+problems which I can't help you with ;-)
+
+=head1 PLUGINS
+
+The module takes plug-ins so you can provide specialised routines for
+comparing your own objects and data-types. For details see
+L<Data::Compare::Plugins>.
+
+Plugins are *not* available when running in "taint" mode. You may
+also make it not load plugins by providing an empty list as the
+argument to import() - ie, by doing this:
+
+ use Data::Compare ();
+
+A couple of functions are provided to examine what goodies have been
+made available through plugins:
+
+=over 4
+
+=item plugins
+
+Returns a structure (a hash ref) describing all the comparisons made
+available through plugins.
+This function is *not* exported, so should be called as Data::Compare::plugins().
+It takes no parameters.
+
+=item plugins_printable
+
+Returns formatted text
+
+=back
+
+=head1 EXPORTS
+
+For historical reasons, the Compare() function is exported. If you
+don't want this, then pass an empty list to import() as explained
+under PLUGINS. If you want no export but do want plugins, then pass
+the empty list, and then call the register_plugins class method:
+
+ use Data::Compare ();
+ Data::Compare->register_plugins;
+
+or you could call it as a function if that floats your boat.
+
+=head1 CODE REPOSITORY
+
+L<http://www.cantrell.org.uk/cgit/cgit.cgi/perlmodules/>
+
+=head1 BUGS
+
+Plugin support is not quite finished (see the TODO file for details) but
+is usable. The missing bits are bells and whistles rather than core
+functionality.
+
+Plugins are unavailable if you can't change to the current directory. This
+might happen if you started your process as a priveleged user and then
+dropped priveleges. This is due to how we check for Taintedness. If this
+affects you, please supply a portable patch.
+
+Please report any other bugs either by email to David Cantrell (see below
+for address) or using rt.cpan.org:
+
+L<https://rt.cpan.org/Ticket/Create.html?Queue=Data-Compare>
+
+=head1 AUTHOR
+
+Fabien Tassin E<lt>fta@sofaraway.orgE<gt>
+
+Portions by David Cantrell E<lt>david@cantrell.org.ukE<gt>
+
+=head1 COPYRIGHT and LICENCE
+
+Copyright (c) 1999-2001 Fabien Tassin. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+Some parts copyright 2003 - 2009 David Cantrell.
+
+Seeing that Fabien seems to have disappeared, David Cantrell has become
+a co-maintainer so he can apply needed patches. The licence, of course,
+remains the same. As the "perl licence" is "Artistic or GPL, your choice",
+you can find them as the files ARTISTIC.txt and GPL2.txt in the
+distribution.
+
+=head1 SEE ALSO
+
+perl(1), perlref(1)
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Data/Compare/Plugins.pod b/Master/tlpkg/tlperl.straw/lib/Data/Compare/Plugins.pod
new file mode 100755
index 00000000000..97747fba731
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Compare/Plugins.pod
@@ -0,0 +1,101 @@
+=head1 NAME
+
+Data::Compare::Plugins - how to extend Data::Compare
+
+=head1 DESCRIPTION
+
+Data::Compare natively handles several built-in data types - scalars,
+references to scalars,
+references to arrays, references to hashes, references to
+subroutines, compiled regular expressions, and globs. For objects,
+it tries to Do The Right Thing and compares the underlying data type.
+However, this is not always what you want. This is especially true if
+you have complex objects which overload stringification and/or
+numification.
+
+Hence we allow for plugins.
+
+=head1 FINDING PLUGINS
+
+Data::Compare will try to load any module installed on your system under
+the various @INC/Data/Compare/Plugins/ directories. If there is a problem
+loading any of them, an appropriate warning will be issued.
+
+Because of how we find plugins, no plugins are available when running in
+"taint" mode.
+
+=head1 WRITING PLUGINS
+
+Internally, plugins are C<require>d into Data::Compare. This means that
+they need to evaluate to true. We make use of that true value. Where
+normally you just put:
+
+ 1;
+
+at the end of an included file, you should instead ensure that you return
+a reference to an array. This is treated as being true so satisfies perl,
+and is a damned sight more useful.
+
+Inside that array should be either a description of what this plugin is to
+do, or references to several arrays containing such descriptions. A
+description consists of two or three items. First a string telling
+us what the first data-type handled by your plugin is. Second, (and
+optional, defaulting to the same as the first) the second data-type
+to compare. To handle comparisons to ordinary scalars, give the empty string
+for the data-type, ie:
+
+ ['MyType', '', sub { ...}]
+
+Third and last, we need a reference to the
+subroutine which does the comparison.
+That subroutine should expect to take two parameters, which will be of
+the specified type. It should return 1 if they compare
+the same, or 0 if they compare different.
+
+Be aware that while you might give a description like:
+
+ ['Type1', 'Type2', sub { ... }]
+
+this will handle both comparing Type1 to Type2, and comparing Type2 to
+Type1. ie, comparison is commutative.
+
+If you want to use Data::Compare's own comparison function from within
+your handler (to, for example, compare a data structure that you have
+stored somewhere in your object) then you will need to call it as
+Data::Compare::Compare. However, you must be careful to avoid infinite
+recursion by calling D::C::Compare which in turn calls back to your
+handler.
+
+The name of
+your plugins does not matter, only that it lives in one of those directories.
+Of course, giving it a sensible name means that the usual installation
+mechanisms will put it in the right place, and meaningful names will make
+it easier to debug your code.
+
+For an example, look at the plugin that handles Scalar::Properties
+objects, which is distributed with Data::Compare.
+
+=head1 DISTRIBUTION
+
+Provided that the above rules are followed I see no reason for you to not
+upload your plugin to the CPAN yourself. You will need to make Data::Compare
+a pre-requisite, so that the CPAN.pm installer does the right thing.
+
+Alternatively, if you would prefer me to roll your plugin in with the
+Data::Compare distribution, I'd be happy to do so provided that the code
+is clear and well-commented, and that you include tests and documentation.
+
+=head1 SEE ALSO
+
+L<Data::Compare>
+
+L<Data::Compare::Plugins::Scalar::Properties>
+
+=head1 AUTHOR
+
+Copyright (c) 2004 David Cantrell <david@cantrell.org.uk>.
+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.straw/lib/Data/Compare/Plugins/Scalar/Properties.pm b/Master/tlpkg/tlperl.straw/lib/Data/Compare/Plugins/Scalar/Properties.pm
new file mode 100755
index 00000000000..0c46b6b9942
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Compare/Plugins/Scalar/Properties.pm
@@ -0,0 +1,94 @@
+package Data::Compare::Plugins::Scalar::Properties;
+
+use strict;
+use vars qw($VERSION);
+use Data::Compare;
+
+$VERSION = 1.0;
+
+sub register {
+ return [
+ ['Scalar::Properties', \&sp_scalar_compare],
+ ['', 'Scalar::Properties', \&sp_scalar_compare],
+ ];
+}
+
+# note that when S::Ps are involved we can't use Data::Compare's default
+# Compare function, so we use eq to check that values are the same. But
+# we *do* use D::C::Compare whenever possible.
+
+# Compare a S::P and a scalar, or if we figure out that we've got two
+# S::Ps, call sp_sp_compare instead
+
+sub sp_scalar_compare {
+ my($scalar, $sp) = @_;
+
+ # we don't care what order the two params are, so swap if necessary
+ ($scalar, $sp) = ($sp, $scalar) if(ref($scalar));
+
+ # got two S::Ps?
+ return sp_sp_compare($scalar, $sp) if(ref($scalar));
+
+ # we've really got a scalar and an S::P, so just compare values
+ return 1 if($scalar eq $sp);
+ return 0;
+}
+
+# Compare two S::Ps
+
+sub sp_sp_compare {
+ my($sp1, $sp2) = @_;
+
+ # first check the values
+ return 0 unless($sp1 eq $sp2);
+
+ # now check that we have all the same properties
+ return 0 unless(Data::Compare::Compare([sort $sp1->get_props()], [sort $sp2->get_props()]));
+
+ # and that all properties have the same values
+ return 0 if(
+ grep { !Data::Compare::Compare(eval "\$sp1->$_()", eval "\$sp2->$_()") } $sp1->get_props()
+ );
+
+ # if we get here, all is tickety-boo
+ return 1;
+}
+
+register();
+
+=head1 NAME
+
+Data::Compare::Plugin::Scalar::Properties - plugin for Data::Compare to
+handle Scalar::Properties objects.
+
+=head1 DESCRIPTION
+
+Enables Data::Compare to Do The Right Thing for Scalar::Properties
+objects.
+
+=over 4
+
+=item comparing a Scalar::Properties object and an ordinary scalar
+
+If you compare
+a scalar and a Scalar::Properties, then they will be considered the same
+if the two values are the same, regardless of the presence of properties.
+
+=item comparing two Scalar::Properties objects
+
+If you compare two Scalar::Properties objects, then they will only be
+considered the same if the values and the properties match.
+
+=back
+
+=head1 AUTHOR
+
+Copyright (c) 2004 David Cantrell. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Data::Compare>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Data/Dumper.pm b/Master/tlpkg/tlperl.straw/lib/Data/Dumper.pm
new file mode 100755
index 00000000000..0eb8bf74fd6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Dumper.pm
@@ -0,0 +1,1306 @@
+#
+# Data/Dumper.pm
+#
+# convert perl data structures into perl syntax suitable for both printing
+# and eval
+#
+# Documentation at the __END__
+#
+
+package Data::Dumper;
+
+$VERSION = '2.125'; # Don't forget to set version and release date in POD!
+
+#$| = 1;
+
+use 5.006_001;
+require Exporter;
+require overload;
+
+use Carp;
+
+BEGIN {
+ @ISA = qw(Exporter);
+ @EXPORT = qw(Dumper);
+ @EXPORT_OK = qw(DumperX);
+
+ # if run under miniperl, or otherwise lacking dynamic loading,
+ # XSLoader should be attempted to load, or the pure perl flag
+ # toggled on load failure.
+ eval {
+ require XSLoader;
+ };
+ $Useperl = 1 if $@;
+}
+
+XSLoader::load( 'Data::Dumper' ) unless $Useperl;
+
+# module vars and their defaults
+$Indent = 2 unless defined $Indent;
+$Purity = 0 unless defined $Purity;
+$Pad = "" unless defined $Pad;
+$Varname = "VAR" unless defined $Varname;
+$Useqq = 0 unless defined $Useqq;
+$Terse = 0 unless defined $Terse;
+$Freezer = "" unless defined $Freezer;
+$Toaster = "" unless defined $Toaster;
+$Deepcopy = 0 unless defined $Deepcopy;
+$Quotekeys = 1 unless defined $Quotekeys;
+$Bless = "bless" unless defined $Bless;
+#$Expdepth = 0 unless defined $Expdepth;
+$Maxdepth = 0 unless defined $Maxdepth;
+$Pair = ' => ' unless defined $Pair;
+$Useperl = 0 unless defined $Useperl;
+$Sortkeys = 0 unless defined $Sortkeys;
+$Deparse = 0 unless defined $Deparse;
+
+#
+# expects an arrayref of values to be dumped.
+# can optionally pass an arrayref of names for the values.
+# names must have leading $ sign stripped. begin the name with *
+# to cause output of arrays and hashes rather than refs.
+#
+sub new {
+ my($c, $v, $n) = @_;
+
+ croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])"
+ unless (defined($v) && (ref($v) eq 'ARRAY'));
+ $n = [] unless (defined($n) && (ref($n) eq 'ARRAY'));
+
+ my($s) = {
+ level => 0, # current recursive depth
+ indent => $Indent, # various styles of indenting
+ pad => $Pad, # all lines prefixed by this string
+ xpad => "", # padding-per-level
+ apad => "", # added padding for hash keys n such
+ sep => "", # list separator
+ pair => $Pair, # hash key/value separator: defaults to ' => '
+ seen => {}, # local (nested) refs (id => [name, val])
+ todump => $v, # values to dump []
+ names => $n, # optional names for values []
+ varname => $Varname, # prefix to use for tagging nameless ones
+ purity => $Purity, # degree to which output is evalable
+ useqq => $Useqq, # use "" for strings (backslashitis ensues)
+ terse => $Terse, # avoid name output (where feasible)
+ freezer => $Freezer, # name of Freezer method for objects
+ toaster => $Toaster, # name of method to revive objects
+ deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion
+ quotekeys => $Quotekeys, # quote hash keys
+ 'bless' => $Bless, # keyword to use for "bless"
+# expdepth => $Expdepth, # cutoff depth for explicit dumping
+ maxdepth => $Maxdepth, # depth beyond which we give up
+ useperl => $Useperl, # use the pure Perl implementation
+ sortkeys => $Sortkeys, # flag or filter for sorting hash keys
+ deparse => $Deparse, # use B::Deparse for coderefs
+ };
+
+ if ($Indent > 0) {
+ $s->{xpad} = " ";
+ $s->{sep} = "\n";
+ }
+ return bless($s, $c);
+}
+
+if ($] >= 5.008) {
+ # Packed numeric addresses take less memory. Plus pack is faster than sprintf
+ *init_refaddr_format = sub {};
+
+ *format_refaddr = sub {
+ require Scalar::Util;
+ pack "J", Scalar::Util::refaddr(shift);
+ };
+} else {
+ *init_refaddr_format = sub {
+ require Config;
+ my $f = $Config::Config{uvxformat};
+ $f =~ tr/"//d;
+ our $refaddr_format = "0x%" . $f;
+ };
+
+ *format_refaddr = sub {
+ require Scalar::Util;
+ sprintf our $refaddr_format, Scalar::Util::refaddr(shift);
+ }
+}
+
+#
+# add-to or query the table of already seen references
+#
+sub Seen {
+ my($s, $g) = @_;
+ if (defined($g) && (ref($g) eq 'HASH')) {
+ init_refaddr_format();
+ my($k, $v, $id);
+ while (($k, $v) = each %$g) {
+ if (defined $v and ref $v) {
+ $id = format_refaddr($v);
+ if ($k =~ /^[*](.*)$/) {
+ $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
+ (ref $v eq 'HASH') ? ( "\\\%" . $1 ) :
+ (ref $v eq 'CODE') ? ( "\\\&" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ elsif ($k !~ /^\$/) {
+ $k = "\$" . $k;
+ }
+ $s->{seen}{$id} = [$k, $v];
+ }
+ else {
+ carp "Only refs supported, ignoring non-ref item \$$k";
+ }
+ }
+ return $s;
+ }
+ else {
+ return map { @$_ } values %{$s->{seen}};
+ }
+}
+
+#
+# set or query the values to be dumped
+#
+sub Values {
+ my($s, $v) = @_;
+ if (defined($v) && (ref($v) eq 'ARRAY')) {
+ $s->{todump} = [@$v]; # make a copy
+ return $s;
+ }
+ else {
+ return @{$s->{todump}};
+ }
+}
+
+#
+# set or query the names of the values to be dumped
+#
+sub Names {
+ my($s, $n) = @_;
+ if (defined($n) && (ref($n) eq 'ARRAY')) {
+ $s->{names} = [@$n]; # make a copy
+ return $s;
+ }
+ else {
+ return @{$s->{names}};
+ }
+}
+
+sub DESTROY {}
+
+sub Dump {
+ return &Dumpxs
+ unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ||
+ $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) ||
+ $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
+ return &Dumpperl;
+}
+
+#
+# dump the refs in the current dumper object.
+# expects same args as new() if called via package name.
+#
+sub Dumpperl {
+ my($s) = shift;
+ my(@out, $val, $name);
+ my($i) = 0;
+ local(@post);
+ init_refaddr_format();
+
+ $s = $s->new(@_) unless ref $s;
+
+ for $val (@{$s->{todump}}) {
+ my $out = "";
+ @post = ();
+ $name = $s->{names}[$i++];
+ if (defined $name) {
+ if ($name =~ /^[*](.*)$/) {
+ if (defined $val) {
+ $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
+ (ref $val eq 'HASH') ? ( "\%" . $1 ) :
+ (ref $val eq 'CODE') ? ( "\*" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ else {
+ $name = "\$" . $1;
+ }
+ }
+ elsif ($name !~ /^\$/) {
+ $name = "\$" . $name;
+ }
+ }
+ else {
+ $name = "\$" . $s->{varname} . $i;
+ }
+
+ my $valstr;
+ {
+ local($s->{apad}) = $s->{apad};
+ $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
+ $valstr = $s->_dump($val, $name);
+ }
+
+ $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
+ $out .= $s->{pad} . $valstr . $s->{sep};
+ $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post)
+ . ';' . $s->{sep} if @post;
+
+ push @out, $out;
+ }
+ return wantarray ? @out : join('', @out);
+}
+
+# wrap string in single quotes (escaping if needed)
+sub _quote {
+ my $val = shift;
+ $val =~ s/([\\\'])/\\$1/g;
+ return "'" . $val . "'";
+}
+
+#
+# twist, toil and turn;
+# and recurse, of course.
+# sometimes sordidly;
+# and curse if no recourse.
+#
+sub _dump {
+ my($s, $val, $name) = @_;
+ my($sname);
+ my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
+
+ $type = ref $val;
+ $out = "";
+
+ if ($type) {
+
+ # Call the freezer method if it's specified and the object has the
+ # method. Trap errors and warn() instead of die()ing, like the XS
+ # implementation.
+ my $freezer = $s->{freezer};
+ if ($freezer and UNIVERSAL::can($val, $freezer)) {
+ eval { $val->$freezer() };
+ warn "WARNING(Freezer method call failed): $@" if $@;
+ }
+
+ require Scalar::Util;
+ $realpack = Scalar::Util::blessed($val);
+ $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val;
+ $id = format_refaddr($val);
+
+ # if it has a name, we need to either look it up, or keep a tab
+ # on it so we know when we hit it later
+ if (defined($name) and length($name)) {
+ # keep a tab on it so that we dont fall into recursive pit
+ if (exists $s->{seen}{$id}) {
+# if ($s->{expdepth} < $s->{level}) {
+ if ($s->{purity} and $s->{level} > 0) {
+ $out = ($realtype eq 'HASH') ? '{}' :
+ ($realtype eq 'ARRAY') ? '[]' :
+ 'do{my $o}' ;
+ push @post, $name . " = " . $s->{seen}{$id}[0];
+ }
+ else {
+ $out = $s->{seen}{$id}[0];
+ if ($name =~ /^([\@\%])/) {
+ my $start = $1;
+ if ($out =~ /^\\$start/) {
+ $out = substr($out, 1);
+ }
+ else {
+ $out = $start . '{' . $out . '}';
+ }
+ }
+ }
+ return $out;
+# }
+ }
+ else {
+ # store our name
+ $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) :
+ ($realtype eq 'CODE' and
+ $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) :
+ $name ),
+ $val ];
+ }
+ }
+ my $no_bless = 0;
+ my $is_regex = 0;
+ if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) {
+ $is_regex = 1;
+ $no_bless = $realpack eq 'Regexp';
+ }
+
+ # If purity is not set and maxdepth is set, then check depth:
+ # if we have reached maximum depth, return the string
+ # representation of the thing we are currently examining
+ # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
+ if (!$s->{purity}
+ and $s->{maxdepth} > 0
+ and $s->{level} >= $s->{maxdepth})
+ {
+ return qq['$val'];
+ }
+
+ # we have a blessed ref
+ if ($realpack and !$no_bless) {
+ $out = $s->{'bless'} . '( ';
+ $blesspad = $s->{apad};
+ $s->{apad} .= ' ' if ($s->{indent} >= 2);
+ }
+
+ $s->{level}++;
+ $ipad = $s->{xpad} x $s->{level};
+
+ if ($is_regex) {
+ my $pat;
+ # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in
+ # universal.c, and even worse we cant just require that re to be loaded
+ # we *have* to use() it.
+ # We should probably move it to universal.c for 5.10.1 and fix this.
+ # Currently we only use re::regexp_pattern when the re is blessed into another
+ # package. This has the disadvantage of meaning that a DD dump won't round trip
+ # as the pattern will be repeatedly wrapped with the same modifiers.
+ # This is an aesthetic issue so we will leave it for now, but we could use
+ # regexp_pattern() in list context to get the modifiers separately.
+ # But since this means loading the full debugging engine in process we wont
+ # bother unless its necessary for accuracy.
+ if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) {
+ $pat = re::regexp_pattern($val);
+ } else {
+ $pat = "$val";
+ }
+ $pat =~ s,/,\\/,g;
+ $out .= "qr/$pat/";
+ }
+ elsif ($realtype eq 'SCALAR' || $realtype eq 'REF') {
+ if ($realpack) {
+ $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
+ }
+ else {
+ $out .= '\\' . $s->_dump($$val, "\${$name}");
+ }
+ }
+ elsif ($realtype eq 'GLOB') {
+ $out .= '\\' . $s->_dump($$val, "*{$name}");
+ }
+ elsif ($realtype eq 'ARRAY') {
+ my($pad, $mname);
+ my($i) = 0;
+ $out .= ($name =~ /^\@/) ? '(' : '[';
+ $pad = $s->{sep} . $s->{pad} . $s->{apad};
+ ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) :
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
+ $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
+ for my $v (@$val) {
+ $sname = $mname . '[' . $i . ']';
+ $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
+ $out .= $pad . $ipad . $s->_dump($v, $sname);
+ $out .= "," if $i++ < $#$val;
+ }
+ $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
+ $out .= ($name =~ /^\@/) ? ')' : ']';
+ }
+ elsif ($realtype eq 'HASH') {
+ my($k, $v, $pad, $lpad, $mname, $pair);
+ $out .= ($name =~ /^\%/) ? '(' : '{';
+ $pad = $s->{sep} . $s->{pad} . $s->{apad};
+ $lpad = $s->{apad};
+ $pair = $s->{pair};
+ ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
+ $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
+ my ($sortkeys, $keys, $key) = ("$s->{sortkeys}");
+ if ($sortkeys) {
+ if (ref($s->{sortkeys}) eq 'CODE') {
+ $keys = $s->{sortkeys}($val);
+ unless (ref($keys) eq 'ARRAY') {
+ carp "Sortkeys subroutine did not return ARRAYREF";
+ $keys = [];
+ }
+ }
+ else {
+ $keys = [ sort keys %$val ];
+ }
+ }
+
+ # Ensure hash iterator is reset
+ keys(%$val);
+
+ while (($k, $v) = ! $sortkeys ? (each %$val) :
+ @$keys ? ($key = shift(@$keys), $val->{$key}) :
+ () )
+ {
+ my $nk = $s->_dump($k, "");
+ $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
+ $sname = $mname . '{' . $nk . '}';
+ $out .= $pad . $ipad . $nk . $pair;
+
+ # temporarily alter apad
+ $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
+ $out .= $s->_dump($val->{$k}, $sname) . ",";
+ $s->{apad} = $lpad if $s->{indent} >= 2;
+ }
+ if (substr($out, -1) eq ',') {
+ chop $out;
+ $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
+ }
+ $out .= ($name =~ /^\%/) ? ')' : '}';
+ }
+ elsif ($realtype eq 'CODE') {
+ if ($s->{deparse}) {
+ require B::Deparse;
+ my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val);
+ $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1);
+ $sub =~ s/\n/$pad/gse;
+ $out .= $sub;
+ } else {
+ $out .= 'sub { "DUMMY" }';
+ carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
+ }
+ }
+ else {
+ croak "Can\'t handle $realtype type.";
+ }
+
+ if ($realpack and !$no_bless) { # we have a blessed ref
+ $out .= ', ' . _quote($realpack) . ' )';
+ $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne '';
+ $s->{apad} = $blesspad;
+ }
+ $s->{level}--;
+
+ }
+ else { # simple scalar
+
+ my $ref = \$_[1];
+ # first, catalog the scalar
+ if ($name ne '') {
+ $id = format_refaddr($ref);
+ if (exists $s->{seen}{$id}) {
+ if ($s->{seen}{$id}[2]) {
+ $out = $s->{seen}{$id}[0];
+ #warn "[<$out]\n";
+ return "\${$out}";
+ }
+ }
+ else {
+ #warn "[>\\$name]\n";
+ $s->{seen}{$id} = ["\\$name", $ref];
+ }
+ }
+ if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob
+ my $name = substr($val, 1);
+ if ($name =~ /^[A-Za-z_][\w:]*$/) {
+ $name =~ s/^main::/::/;
+ $sname = $name;
+ }
+ else {
+ $sname = $s->_dump($name, "");
+ $sname = '{' . $sname . '}';
+ }
+ if ($s->{purity}) {
+ my $k;
+ local ($s->{level}) = 0;
+ for $k (qw(SCALAR ARRAY HASH)) {
+ my $gval = *$val{$k};
+ next unless defined $gval;
+ next if $k eq "SCALAR" && ! defined $$gval; # always there
+
+ # _dump can push into @post, so we hold our place using $postlen
+ my $postlen = scalar @post;
+ $post[$postlen] = "\*$sname = ";
+ local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
+ $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
+ }
+ }
+ $out .= '*' . $sname;
+ }
+ elsif (!defined($val)) {
+ $out .= "undef";
+ }
+ elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number
+ $out .= $val;
+ }
+ else { # string
+ if ($s->{useqq} or $val =~ tr/\0-\377//c) {
+ # Fall back to qq if there's Unicode
+ $out .= qquote($val, $s->{useqq});
+ }
+ else {
+ $out .= _quote($val);
+ }
+ }
+ }
+ if ($id) {
+ # if we made it this far, $id was added to seen list at current
+ # level, so remove it to get deep copies
+ if ($s->{deepcopy}) {
+ delete($s->{seen}{$id});
+ }
+ elsif ($name) {
+ $s->{seen}{$id}[2] = 1;
+ }
+ }
+ return $out;
+}
+
+#
+# non-OO style of earlier version
+#
+sub Dumper {
+ return Data::Dumper->Dump([@_]);
+}
+
+# compat stub
+sub DumperX {
+ return Data::Dumper->Dumpxs([@_], []);
+}
+
+sub Dumpf { return Data::Dumper->Dump(@_) }
+
+sub Dumpp { print Data::Dumper->Dump(@_) }
+
+#
+# reset the "seen" cache
+#
+sub Reset {
+ my($s) = shift;
+ $s->{seen} = {};
+ return $s;
+}
+
+sub Indent {
+ my($s, $v) = @_;
+ if (defined($v)) {
+ if ($v == 0) {
+ $s->{xpad} = "";
+ $s->{sep} = "";
+ }
+ else {
+ $s->{xpad} = " ";
+ $s->{sep} = "\n";
+ }
+ $s->{indent} = $v;
+ return $s;
+ }
+ else {
+ return $s->{indent};
+ }
+}
+
+sub Pair {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair};
+}
+
+sub Pad {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
+}
+
+sub Varname {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
+}
+
+sub Purity {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
+}
+
+sub Useqq {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
+}
+
+sub Terse {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
+}
+
+sub Freezer {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
+}
+
+sub Toaster {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
+}
+
+sub Deepcopy {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
+}
+
+sub Quotekeys {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
+}
+
+sub Bless {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
+}
+
+sub Maxdepth {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
+}
+
+sub Useperl {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
+}
+
+sub Sortkeys {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'};
+}
+
+sub Deparse {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'};
+}
+
+# used by qquote below
+my %esc = (
+ "\a" => "\\a",
+ "\b" => "\\b",
+ "\t" => "\\t",
+ "\n" => "\\n",
+ "\f" => "\\f",
+ "\r" => "\\r",
+ "\e" => "\\e",
+);
+
+# put a string value in double quotes
+sub qquote {
+ local($_) = shift;
+ s/([\\\"\@\$])/\\$1/g;
+ my $bytes; { use bytes; $bytes = length }
+ s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
+ return qq("$_") unless
+ /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit
+
+ my $high = shift || "";
+ s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
+
+ if (ord('^')==94) { # ascii
+ # no need for 3 digits in escape for these
+ s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
+ s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
+ # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
+ if ($high eq "iso8859") {
+ s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
+ } elsif ($high eq "utf8") {
+# use utf8;
+# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
+ } elsif ($high eq "8bit") {
+ # leave it as it is
+ } else {
+ s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
+ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
+ }
+ }
+ else { # ebcdic
+ s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
+ {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
+ s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
+ {'\\'.sprintf('%03o',ord($1))}eg;
+ }
+
+ return qq("$_");
+}
+
+# helper sub to sort hash keys in Perl < 5.8.0 where we don't have
+# access to sortsv() from XS
+sub _sortkeys { [ sort keys %{$_[0]} ] }
+
+1;
+__END__
+
+=head1 NAME
+
+Data::Dumper - stringified perl data structures, suitable for both printing and C<eval>
+
+=head1 SYNOPSIS
+
+ use Data::Dumper;
+
+ # simple procedural interface
+ print Dumper($foo, $bar);
+
+ # extended usage with names
+ print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
+
+ # configuration variables
+ {
+ local $Data::Dumper::Purity = 1;
+ eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
+ }
+
+ # OO usage
+ $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]);
+ ...
+ print $d->Dump;
+ ...
+ $d->Purity(1)->Terse(1)->Deepcopy(1);
+ eval $d->Dump;
+
+
+=head1 DESCRIPTION
+
+Given a list of scalars or reference variables, writes out their contents in
+perl syntax. The references can also be objects. The content of each
+variable is output in a single Perl statement. Handles self-referential
+structures correctly.
+
+The return value can be C<eval>ed to get back an identical copy of the
+original reference structure.
+
+Any references that are the same as one of those passed in will be named
+C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references
+to substructures within C<$VAR>I<n> will be appropriately labeled using arrow
+notation. You can specify names for individual values to be dumped if you
+use the C<Dump()> method, or you can change the default C<$VAR> prefix to
+something else. See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse>
+below.
+
+The default output of self-referential structures can be C<eval>ed, but the
+nested references to C<$VAR>I<n> will be undefined, since a recursive
+structure cannot be constructed using one Perl statement. You should set the
+C<Purity> flag to 1 to get additional statements that will correctly fill in
+these references. Moreover, if C<eval>ed when strictures are in effect,
+you need to ensure that any variables it accesses are previously declared.
+
+In the extended usage form, the references to be dumped can be given
+user-specified names. If a name begins with a C<*>, the output will
+describe the dereferenced type of the supplied reference for hashes and
+arrays, and coderefs. Output of names will be avoided where possible if
+the C<Terse> flag is set.
+
+In many cases, methods that are used to set the internal state of the
+object will return the object itself, so method calls can be conveniently
+chained together.
+
+Several styles of output are possible, all controlled by setting
+the C<Indent> flag. See L<Configuration Variables or Methods> below
+for details.
+
+
+=head2 Methods
+
+=over 4
+
+=item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>)
+
+Returns a newly created C<Data::Dumper> object. The first argument is an
+anonymous array of values to be dumped. The optional second argument is an
+anonymous array of names for the values. The names need not have a leading
+C<$> sign, and must be comprised of alphanumeric characters. You can begin
+a name with a C<*> to specify that the dereferenced type must be dumped
+instead of the reference itself, for ARRAY and HASH references.
+
+The prefix specified by C<$Data::Dumper::Varname> will be used with a
+numeric suffix if the name for a value is undefined.
+
+Data::Dumper will catalog all references encountered while dumping the
+values. Cross-references (in the form of names of substructures in perl
+syntax) will be inserted at all possible points, preserving any structural
+interdependencies in the original set of values. Structure traversal is
+depth-first, and proceeds in order from the first supplied value to
+the last.
+
+=item I<$OBJ>->Dump I<or> I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>)
+
+Returns the stringified form of the values stored in the object (preserving
+the order in which they were supplied to C<new>), subject to the
+configuration options below. In a list context, it returns a list
+of strings corresponding to the supplied values.
+
+The second form, for convenience, simply calls the C<new> method on its
+arguments before dumping the object immediately.
+
+=item I<$OBJ>->Seen(I<[HASHREF]>)
+
+Queries or adds to the internal table of already encountered references.
+You must use C<Reset> to explicitly clear the table if needed. Such
+references are not dumped; instead, their names are inserted wherever they
+are encountered subsequently. This is useful especially for properly
+dumping subroutine references.
+
+Expects an anonymous hash of name => value pairs. Same rules apply for names
+as in C<new>. If no argument is supplied, will return the "seen" list of
+name => value pairs, in a list context. Otherwise, returns the object
+itself.
+
+=item I<$OBJ>->Values(I<[ARRAYREF]>)
+
+Queries or replaces the internal array of values that will be dumped.
+When called without arguments, returns the values. Otherwise, returns the
+object itself.
+
+=item I<$OBJ>->Names(I<[ARRAYREF]>)
+
+Queries or replaces the internal array of user supplied names for the values
+that will be dumped. When called without arguments, returns the names.
+Otherwise, returns the object itself.
+
+=item I<$OBJ>->Reset
+
+Clears the internal table of "seen" references and returns the object
+itself.
+
+=back
+
+=head2 Functions
+
+=over 4
+
+=item Dumper(I<LIST>)
+
+Returns the stringified form of the values in the list, subject to the
+configuration options below. The values will be named C<$VAR>I<n> in the
+output, where I<n> is a numeric suffix. Will return a list of strings
+in a list context.
+
+=back
+
+=head2 Configuration Variables or Methods
+
+Several configuration variables can be used to control the kind of output
+generated when using the procedural interface. These variables are usually
+C<local>ized in a block so that other parts of the code are not affected by
+the change.
+
+These variables determine the default state of the object created by calling
+the C<new> method, but cannot be used to alter the state of the object
+thereafter. The equivalent method names should be used instead to query
+or set the internal state of the object.
+
+The method forms return the object itself when called with arguments,
+so that they can be chained together nicely.
+
+=over 4
+
+=item *
+
+$Data::Dumper::Indent I<or> I<$OBJ>->Indent(I<[NEWVAL]>)
+
+Controls the style of indentation. It can be set to 0, 1, 2 or 3. Style 0
+spews output without any newlines, indentation, or spaces between list
+items. It is the most compact format possible that can still be called
+valid perl. Style 1 outputs a readable form with newlines but no fancy
+indentation (each level in the structure is simply indented by a fixed
+amount of whitespace). Style 2 (the default) outputs a very readable form
+which takes into account the length of hash keys (so the hash value lines
+up). Style 3 is like style 2, but also annotates the elements of arrays
+with their index (but the comment is on its own line, so array output
+consumes twice the number of lines). Style 2 is the default.
+
+=item *
+
+$Data::Dumper::Purity I<or> I<$OBJ>->Purity(I<[NEWVAL]>)
+
+Controls the degree to which the output can be C<eval>ed to recreate the
+supplied reference structures. Setting it to 1 will output additional perl
+statements that will correctly recreate nested references. The default is
+0.
+
+=item *
+
+$Data::Dumper::Pad I<or> I<$OBJ>->Pad(I<[NEWVAL]>)
+
+Specifies the string that will be prefixed to every line of the output.
+Empty string by default.
+
+=item *
+
+$Data::Dumper::Varname I<or> I<$OBJ>->Varname(I<[NEWVAL]>)
+
+Contains the prefix to use for tagging variable names in the output. The
+default is "VAR".
+
+=item *
+
+$Data::Dumper::Useqq I<or> I<$OBJ>->Useqq(I<[NEWVAL]>)
+
+When set, enables the use of double quotes for representing string values.
+Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe"
+characters will be backslashed, and unprintable characters will be output as
+quoted octal integers. Since setting this variable imposes a performance
+penalty, the default is 0. C<Dump()> will run slower if this flag is set,
+since the fast XSUB implementation doesn't support it yet.
+
+=item *
+
+$Data::Dumper::Terse I<or> I<$OBJ>->Terse(I<[NEWVAL]>)
+
+When set, Data::Dumper will emit single, non-self-referential values as
+atoms/terms rather than statements. This means that the C<$VAR>I<n> names
+will be avoided where possible, but be advised that such output may not
+always be parseable by C<eval>.
+
+=item *
+
+$Data::Dumper::Freezer I<or> $I<OBJ>->Freezer(I<[NEWVAL]>)
+
+Can be set to a method name, or to an empty string to disable the feature.
+Data::Dumper will invoke that method via the object before attempting to
+stringify it. This method can alter the contents of the object (if, for
+instance, it contains data allocated from C), and even rebless it in a
+different package. The client is responsible for making sure the specified
+method can be called via the object, and that the object ends up containing
+only perl data types after the method has been called. Defaults to an empty
+string.
+
+If an object does not support the method specified (determined using
+UNIVERSAL::can()) then the call will be skipped. If the method dies a
+warning will be generated.
+
+=item *
+
+$Data::Dumper::Toaster I<or> $I<OBJ>->Toaster(I<[NEWVAL]>)
+
+Can be set to a method name, or to an empty string to disable the feature.
+Data::Dumper will emit a method call for any objects that are to be dumped
+using the syntax C<bless(DATA, CLASS)-E<gt>METHOD()>. Note that this means that
+the method specified will have to perform any modifications required on the
+object (like creating new state within it, and/or reblessing it in a
+different package) and then return it. The client is responsible for making
+sure the method can be called via the object, and that it returns a valid
+object. Defaults to an empty string.
+
+=item *
+
+$Data::Dumper::Deepcopy I<or> $I<OBJ>->Deepcopy(I<[NEWVAL]>)
+
+Can be set to a boolean value to enable deep copies of structures.
+Cross-referencing will then only be done when absolutely essential
+(i.e., to break reference cycles). Default is 0.
+
+=item *
+
+$Data::Dumper::Quotekeys I<or> $I<OBJ>->Quotekeys(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether hash keys are quoted.
+A false value will avoid quoting hash keys when it looks like a simple
+string. Default is 1, which will always enclose hash keys in quotes.
+
+=item *
+
+$Data::Dumper::Bless I<or> $I<OBJ>->Bless(I<[NEWVAL]>)
+
+Can be set to a string that specifies an alternative to the C<bless>
+builtin operator used to create objects. A function with the specified
+name should exist, and should accept the same arguments as the builtin.
+Default is C<bless>.
+
+=item *
+
+$Data::Dumper::Pair I<or> $I<OBJ>->Pair(I<[NEWVAL]>)
+
+Can be set to a string that specifies the separator between hash keys
+and values. To dump nested hash, array and scalar values to JavaScript,
+use: C<$Data::Dumper::Pair = ' : ';>. Implementing C<bless> in JavaScript
+is left as an exercise for the reader.
+A function with the specified name exists, and accepts the same arguments
+as the builtin.
+
+Default is: C< =E<gt> >.
+
+=item *
+
+$Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<[NEWVAL]>)
+
+Can be set to a positive integer that specifies the depth beyond which
+we don't venture into a structure. Has no effect when
+C<Data::Dumper::Purity> is set. (Useful in debugger when we often don't
+want to see more than enough). Default is 0, which means there is
+no maximum depth.
+
+=item *
+
+$Data::Dumper::Useperl I<or> $I<OBJ>->Useperl(I<[NEWVAL]>)
+
+Can be set to a boolean value which controls whether the pure Perl
+implementation of C<Data::Dumper> is used. The C<Data::Dumper> module is
+a dual implementation, with almost all functionality written in both
+pure Perl and also in XS ('C'). Since the XS version is much faster, it
+will always be used if possible. This option lets you override the
+default behavior, usually for testing purposes only. Default is 0, which
+means the XS implementation will be used if possible.
+
+=item *
+
+$Data::Dumper::Sortkeys I<or> $I<OBJ>->Sortkeys(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether hash keys are dumped in
+sorted order. A true value will cause the keys of all hashes to be
+dumped in Perl's default sort order. Can also be set to a subroutine
+reference which will be called for each hash that is dumped. In this
+case C<Data::Dumper> will call the subroutine once for each hash,
+passing it the reference of the hash. The purpose of the subroutine is
+to return a reference to an array of the keys that will be dumped, in
+the order that they should be dumped. Using this feature, you can
+control both the order of the keys, and which keys are actually used. In
+other words, this subroutine acts as a filter by which you can exclude
+certain keys from being dumped. Default is 0, which means that hash keys
+are not sorted.
+
+=item *
+
+$Data::Dumper::Deparse I<or> $I<OBJ>->Deparse(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether code references are
+turned into perl source code. If set to a true value, C<B::Deparse>
+will be used to get the source of the code reference. Using this option
+will force using the Perl implementation of the dumper, since the fast
+XSUB implementation doesn't support it.
+
+Caution : use this option only if you know that your coderefs will be
+properly reconstructed by C<B::Deparse>.
+
+=back
+
+=head2 Exports
+
+=over 4
+
+=item Dumper
+
+=back
+
+=head1 EXAMPLES
+
+Run these code snippets to get a quick feel for the behavior of this
+module. When you are through with these examples, you may want to
+add or change the various configuration variables described above,
+to see their behavior. (See the testsuite in the Data::Dumper
+distribution for more examples.)
+
+
+ use Data::Dumper;
+
+ package Foo;
+ sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]};
+
+ package Fuz; # a weird REF-REF-SCALAR object
+ sub new {bless \($_ = \ 'fu\'z'), $_[0]};
+
+ package main;
+ $foo = Foo->new;
+ $fuz = Fuz->new;
+ $boo = [ 1, [], "abcd", \*foo,
+ {1 => 'a', 023 => 'b', 0x45 => 'c'},
+ \\"p\q\'r", $foo, $fuz];
+
+ ########
+ # simple usage
+ ########
+
+ $bar = eval(Dumper($boo));
+ print($@) if $@;
+ print Dumper($boo), Dumper($bar); # pretty print (no array indices)
+
+ $Data::Dumper::Terse = 1; # don't output names where feasible
+ $Data::Dumper::Indent = 0; # turn off all pretty print
+ print Dumper($boo), "\n";
+
+ $Data::Dumper::Indent = 1; # mild pretty print
+ print Dumper($boo);
+
+ $Data::Dumper::Indent = 3; # pretty print with array indices
+ print Dumper($boo);
+
+ $Data::Dumper::Useqq = 1; # print strings in double quotes
+ print Dumper($boo);
+
+ $Data::Dumper::Pair = " : "; # specify hash key/value separator
+ print Dumper($boo);
+
+
+ ########
+ # recursive structures
+ ########
+
+ @c = ('c');
+ $c = \@c;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+ print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]);
+
+
+ $Data::Dumper::Purity = 1; # fill in the holes for eval
+ print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b
+
+
+ $Data::Dumper::Deepcopy = 1; # avoid cross-refs
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
+
+
+ $Data::Dumper::Purity = 0; # avoid cross-refs
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
+
+ ########
+ # deep structures
+ ########
+
+ $a = "pearl";
+ $b = [ $a ];
+ $c = { 'b' => $b };
+ $d = [ $c ];
+ $e = { 'd' => $d };
+ $f = { 'e' => $e };
+ print Data::Dumper->Dump([$f], [qw(f)]);
+
+ $Data::Dumper::Maxdepth = 3; # no deeper than 3 refs down
+ print Data::Dumper->Dump([$f], [qw(f)]);
+
+
+ ########
+ # object-oriented usage
+ ########
+
+ $d = Data::Dumper->new([$a,$b], [qw(a b)]);
+ $d->Seen({'*c' => $c}); # stash a ref without printing it
+ $d->Indent(3);
+ print $d->Dump;
+ $d->Reset->Purity(0); # empty the seen cache
+ print join "----\n", $d->Dump;
+
+
+ ########
+ # persistence
+ ########
+
+ package Foo;
+ sub new { bless { state => 'awake' }, shift }
+ sub Freeze {
+ my $s = shift;
+ print STDERR "preparing to sleep\n";
+ $s->{state} = 'asleep';
+ return bless $s, 'Foo::ZZZ';
+ }
+
+ package Foo::ZZZ;
+ sub Thaw {
+ my $s = shift;
+ print STDERR "waking up\n";
+ $s->{state} = 'awake';
+ return bless $s, 'Foo';
+ }
+
+ package Foo;
+ use Data::Dumper;
+ $a = Foo->new;
+ $b = Data::Dumper->new([$a], ['c']);
+ $b->Freezer('Freeze');
+ $b->Toaster('Thaw');
+ $c = $b->Dump;
+ print $c;
+ $d = eval $c;
+ print Data::Dumper->Dump([$d], ['d']);
+
+
+ ########
+ # symbol substitution (useful for recreating CODE refs)
+ ########
+
+ sub foo { print "foo speaking\n" }
+ *other = \&foo;
+ $bar = [ \&other ];
+ $d = Data::Dumper->new([\&other,$bar],['*other','bar']);
+ $d->Seen({ '*foo' => \&foo });
+ print $d->Dump;
+
+
+ ########
+ # sorting and filtering hash keys
+ ########
+
+ $Data::Dumper::Sortkeys = \&my_filter;
+ my $foo = { map { (ord, "$_$_$_") } 'I'..'Q' };
+ my $bar = { %$foo };
+ my $baz = { reverse %$foo };
+ print Dumper [ $foo, $bar, $baz ];
+
+ sub my_filter {
+ my ($hash) = @_;
+ # return an array ref containing the hash keys to dump
+ # in the order that you want them to be dumped
+ return [
+ # Sort the keys of %$foo in reverse numeric order
+ $hash eq $foo ? (sort {$b <=> $a} keys %$hash) :
+ # Only dump the odd number keys of %$bar
+ $hash eq $bar ? (grep {$_ % 2} keys %$hash) :
+ # Sort keys in default order for all other hashes
+ (sort keys %$hash)
+ ];
+ }
+
+=head1 BUGS
+
+Due to limitations of Perl subroutine call semantics, you cannot pass an
+array or hash. Prepend it with a C<\> to pass its reference instead. This
+will be remedied in time, now that Perl has subroutine prototypes.
+For now, you need to use the extended usage form, and prepend the
+name with a C<*> to output it as a hash or array.
+
+C<Data::Dumper> cheats with CODE references. If a code reference is
+encountered in the structure being processed (and if you haven't set
+the C<Deparse> flag), an anonymous subroutine that
+contains the string '"DUMMY"' will be inserted in its place, and a warning
+will be printed if C<Purity> is set. You can C<eval> the result, but bear
+in mind that the anonymous sub that gets created is just a placeholder.
+Someday, perl will have a switch to cache-on-demand the string
+representation of a compiled piece of code, I hope. If you have prior
+knowledge of all the code refs that your data structures are likely
+to have, you can use the C<Seen> method to pre-seed the internal reference
+table and make the dumped output point to them, instead. See L</EXAMPLES>
+above.
+
+The C<Useqq> and C<Deparse> flags makes Dump() run slower, since the
+XSUB implementation does not support them.
+
+SCALAR objects have the weirdest looking C<bless> workaround.
+
+Pure Perl version of C<Data::Dumper> escapes UTF-8 strings correctly
+only in Perl 5.8.0 and later.
+
+=head2 NOTE
+
+Starting from Perl 5.8.1 different runs of Perl will have different
+ordering of hash keys. The change was done for greater security,
+see L<perlsec/"Algorithmic Complexity Attacks">. This means that
+different runs of Perl will have different Data::Dumper outputs if
+the data contains hashes. If you need to have identical Data::Dumper
+outputs from different runs of Perl, use the environment variable
+PERL_HASH_SEED, see L<perlrun/PERL_HASH_SEED>. Using this restores
+the old (platform-specific) ordering: an even prettier solution might
+be to use the C<Sortkeys> filter of Data::Dumper.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@activestate.com
+
+Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 VERSION
+
+Version 2.125 (Aug 8 2009)
+
+=head1 SEE ALSO
+
+perl(1)
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Data/Random.pm b/Master/tlpkg/tlperl.straw/lib/Data/Random.pm
new file mode 100755
index 00000000000..f6e119fcf73
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Random.pm
@@ -0,0 +1,850 @@
+################################################################################
+# Data::Random
+#
+# A module used to generate random data.
+################################################################################
+
+package Data::Random;
+
+################################################################################
+# - Modules and Libraries
+################################################################################
+#require 5.005_62;
+
+use lib qw(..);
+use Carp qw(cluck);
+
+#use Data::Random::WordList;
+
+require Exporter;
+
+################################################################################
+# - Global Constants and Variables
+################################################################################
+use vars qw(
+ @ISA
+ %EXPORT_TAGS
+ @EXPORT_OK
+ @EXPORT
+);
+
+@ISA = qw(Exporter);
+
+%EXPORT_TAGS = (
+ 'all' => [
+ qw(
+ rand_words
+ rand_chars
+ rand_set
+ rand_enum
+ rand_date
+ rand_time
+ rand_datetime
+ rand_image
+ )
+ ]
+);
+
+@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+@EXPORT = qw();
+
+$Data::Random::VERSION = '0.05';
+
+################################################################################
+# - Subroutines
+################################################################################
+
+################################################################################
+# rand_words()
+################################################################################
+sub rand_words {
+
+ # Get the options hash
+ my %options = @_;
+
+ # Initialize max and min vars
+ $options{'min'} ||= 1;
+ $options{'max'} ||= 1;
+
+ # Initialize the wordlist param
+ $options{'wordlist'} ||= '';
+
+ # Make sure the max and min vars are OK
+ cluck('min value cannot be larger than max value') && return
+ if $options{'min'} > $options{'max'};
+ cluck('min value must be a positive integer') && return
+ if $options{'min'} < 0 || $options{'min'} != int( $options{'min'} );
+ cluck('max value must be a positive integer') && return
+ if $options{'max'} < 0 || $options{'max'} != int( $options{'max'} );
+
+ # Initialize the size var
+ $options{'size'} ||=
+ int( rand( $options{'max'} - $options{'min'} + 1 ) ) + $options{'min'};
+
+ # Make sure the size var is OK
+ cluck('size value must be a positive integer') && return
+ if $options{'size'} < 0 || $options{'size'} != int( $options{'size'} );
+
+ # Initialize the shuffle flag
+ $options{'shuffle'} =
+ exists( $options{'shuffle'} ) ? $options{'shuffle'} : 1;
+
+ my $wl;
+ my $close_wl = 1;
+
+ # Check for a pre-existing wordlist object
+ if ( ref( $options{'wordlist'} ) ) {
+ $wl = $options{'wordlist'};
+ $close_wl = 0;
+ }
+ else {
+ require Data::Random::WordList;
+
+ # Create a new wordlist object
+ $wl = new Data::Random::WordList( wordlist => $options{'wordlist'} );
+ }
+
+ # Get the random words
+ my $rand_words = $wl->get_words( $options{'size'} );
+
+ # Close the word list
+ $wl->close() if $close_wl;
+
+ # Shuffle the words around
+ shuffle($rand_words) if $options{'shuffle'};
+
+# Return an array or an array reference, depending on the context in which the sub was called
+ if ( wantarray() ) {
+ return @$rand_words;
+ }
+ else {
+ return $rand_words;
+ }
+}
+
+################################################################################
+# rand_chars()
+################################################################################
+sub rand_chars {
+
+ # Get the options hash
+ my %options = @_;
+
+ # Build named character sets if one wasn't supplied
+ if ( ref( $options{'set'} ) ne 'ARRAY' ) {
+ my @charset = ();
+
+ if ( $options{'set'} eq 'all' ) {
+ @charset =
+ ( 0 .. 9, 'a' .. 'z', 'A' .. 'Z', '#', ',',
+ qw(~ ! @ $ % ^ & * ( ) _ + = - { } | : " < > ? / . ' ; ] [ \ `)
+ );
+ }
+ elsif ( $options{'set'} eq 'alpha' ) {
+ @charset = ( 'a' .. 'z', 'A' .. 'Z' );
+ }
+ elsif ( $options{'set'} eq 'upperalpha' ) {
+ @charset = ( 'A' .. 'Z' );
+ }
+ elsif ( $options{'set'} eq 'loweralpha' ) {
+ @charset = ( 'a' .. 'z' );
+ }
+ elsif ( $options{'set'} eq 'numeric' ) {
+ @charset = ( 0 .. 9 );
+ }
+ elsif ( $options{'set'} eq 'alphanumeric' ) {
+ @charset = ( 0 .. 9, 'a' .. 'z', 'A' .. 'Z' );
+ }
+ elsif ( $options{'set'} eq 'misc' ) {
+ @charset =
+ ( '#', ',',
+ qw(~ ! @ $ % ^ & * ( ) _ + = - { } | : " < > ? / . ' ; ] [ \ `)
+ );
+ }
+
+ $options{'set'} = \@charset;
+ }
+
+ return rand_set(%options);
+}
+
+################################################################################
+# rand_set()
+################################################################################
+sub rand_set {
+
+ # Get the options hash
+ my %options = @_;
+
+ # Make sure the set array was defined
+ cluck('set array is not defined') && return if !$options{'set'};
+
+ $options{'size'} = 1
+ unless exists( $options{'min'} ) || exists( $options{'max'} )
+ || exists( $options{'size'} );
+
+ # Initialize max and min vars
+ $options{'min'} ||= 0;
+ $options{'max'} ||= @{ $options{'set'} };
+
+ # Make sure the max and min vars are OK
+ cluck('min value cannot be larger than max value') && return
+ if $options{'min'} > $options{'max'};
+ cluck('min value must be a positive integer') && return
+ if $options{'min'} < 0 || $options{'min'} != int( $options{'min'} );
+ cluck('max value must be a positive integer') && return
+ if $options{'max'} < 0 || $options{'max'} != int( $options{'max'} );
+
+ # Initialize the size var
+ $options{'size'} ||=
+ int( rand( $options{'max'} - $options{'min'} + 1 ) ) + $options{'min'};
+
+ # Make sure the size var is OK
+ cluck('size value must be a positive integer') && return
+ if $options{'size'} < 0 || $options{'size'} != int( $options{'size'} );
+ cluck('size value exceeds set size') && return
+ if $options{'size'} > @{ $options{'set'} };
+
+ # Initialize the shuffle flag
+ $options{'shuffle'} =
+ exists( $options{'shuffle'} ) ? $options{'shuffle'} : 1;
+
+ # Get the random items
+ my %results = ();
+ for ( my $i = 0 ; $i < $options{'size'} ; $i++ ) {
+ my $result;
+
+ do {
+ $result = int( rand( @{ $options{'set'} } ) );
+ } while ( exists( $results{$result} ) );
+
+ $results{$result} = 1;
+ }
+
+ my @results = sort { $a <=> $b } keys %results;
+
+ # Shuffle the items
+ shuffle( \@results ) if $options{'shuffle'};
+
+# Return an array or an array reference, depending on the context in which the sub was called
+ if ( wantarray() ) {
+ return @{ $options{'set'} }[@results];
+ }
+ else {
+ return \@{ $options{'set'} }[@results];
+ }
+}
+
+################################################################################
+# rand_enum()
+################################################################################
+sub rand_enum {
+
+ # Get the options hash
+ my %options = @_;
+
+ # Make sure the set array was defined
+ cluck('set array is not defined') && return if !$options{'set'};
+
+ return $options{'set'}->[ int( rand( @{ $options{'set'} } ) ) ];
+}
+
+################################################################################
+# rand_date()
+################################################################################
+sub rand_date {
+
+ # Get the options hash
+ my %options = @_;
+
+ # use the Date::Calc module
+ eval q{ use Date::Calc };
+
+ cluck($@) && return if $@;
+
+ my ( $min_year, $min_month, $min_day, $max_year, $max_month, $max_day );
+
+ # Get today's date
+ my ( $year, $month, $day ) = Date::Calc::Today();
+
+ if ( $options{'min'} ) {
+ if ( $options{'min'} eq 'now' ) {
+ ( $min_year, $min_month, $min_day ) = ( $year, $month, $day );
+ }
+ else {
+ ( $min_year, $min_month, $min_day ) =
+ split ( /\-/, $options{'min'} );
+ }
+ }
+ else {
+ ( $min_year, $min_month, $min_day ) = ( $year, $month, $day );
+ }
+
+ if ( $options{'max'} ) {
+ if ( $options{'max'} eq 'now' ) {
+ ( $max_year, $max_month, $max_day ) = ( $year, $month, $day );
+ }
+ else {
+ ( $max_year, $max_month, $max_day ) =
+ split ( /\-/, $options{'max'} );
+ }
+ }
+ else {
+ ( $max_year, $max_month, $max_day ) =
+ Date::Calc::Add_Delta_YMD( $min_year, $min_month, $min_day, 1, 0, 0 );
+ }
+
+ my $delta_days =
+ Date::Calc::Delta_Days( $min_year, $min_month, $min_day, $max_year,
+ $max_month, $max_day, );
+
+ cluck('max date is later than min date') && return if $delta_days < 0;
+
+ $delta_days = int( rand( $delta_days + 1 ) );
+
+ ( $year, $month, $day ) =
+ Date::Calc::Add_Delta_Days( $min_year, $min_month, $min_day,
+ $delta_days );
+
+ return sprintf( "%04u-%02u-%02u", $year, $month, $day );
+}
+
+################################################################################
+# rand_time()
+################################################################################
+sub rand_time {
+
+ # Get the options hash
+ my %options = @_;
+
+ my ( $min_hour, $min_min, $min_sec, $max_hour, $max_min, $max_sec );
+
+ if ( $options{'min'} ) {
+ if ( $options{'min'} eq 'now' ) {
+
+ # Get the current time
+ my ( $hour, $min, $sec ) = ( localtime() )[ 2, 1, 0 ];
+
+ ( $min_hour, $min_min, $min_sec ) = ( $hour, $min, $sec );
+ }
+ else {
+ ( $min_hour, $min_min, $min_sec ) = split ( /\:/, $options{'min'} );
+
+ cluck('minimum time is not in valid time format HH:MM:SS') && return
+ if ( $min_hour > 23 ) || ( $min_hour < 0 );
+ cluck('minimum time is not in valid time format HH:MM:SS') && return
+ if ( $min_min > 59 ) || ( $min_min < 0 );
+ cluck('minimum time is not in valid time format HH:MM:SS') && return
+ if ( $min_sec > 59 ) || ( $min_sec < 0 );
+ }
+ }
+ else {
+ ( $min_hour, $min_min, $min_sec ) = ( 0, 0, 0 );
+ }
+
+ if ( $options{'max'} ) {
+ if ( $options{'max'} eq 'now' ) {
+
+ # Get the current time
+ my ( $hour, $min, $sec ) = ( localtime() )[ 2, 1, 0 ];
+
+ ( $max_hour, $max_min, $max_sec ) = ( $hour, $min, $sec );
+ }
+ else {
+ ( $max_hour, $max_min, $max_sec ) = split ( /\:/, $options{'max'} );
+
+ cluck('maximum time is not in valid time format HH:MM:SS') && return
+ if ( $max_hour > 23 ) || ( $max_hour < 0 );
+ cluck('maximum time is not in valid time format HH:MM:SS') && return
+ if ( $max_min > 59 ) || ( $max_min < 0 );
+ cluck('maximum time is not in valid time format HH:MM:SS') && return
+ if ( $max_sec > 59 ) || ( $max_sec < 0 );
+ }
+ }
+ else {
+ ( $max_hour, $max_min, $max_sec ) = ( 23, 59, 59 );
+ }
+
+ my $min_secs = $min_hour * 3600 + $min_min * 60 + $min_sec;
+ my $max_secs = ( $max_hour * 3600 ) + ( $max_min * 60 ) + $max_sec;
+
+ my $delta_secs = $max_secs - $min_secs;
+
+ cluck('min time is later than max time') && return if $delta_secs < 0;
+
+ $delta_secs = int( rand( $delta_secs + 1 ) );
+
+ my $result_secs = $min_secs + $delta_secs;
+
+ my $hour = int( $result_secs / 3600 );
+ my $min = int( ( $result_secs - ( $hour * 3600 ) ) / 60 );
+ my $sec = $result_secs % 60;
+
+ return sprintf( "%02u:%02u:%02u", $hour, $min, $sec );
+}
+
+################################################################################
+# rand_datetime()
+################################################################################
+sub rand_datetime {
+
+ # Get the options hash
+ my %options = @_;
+
+ # use the Date::Calc module
+ eval q{ use Date::Calc };
+
+ cluck($@) && return if $@;
+
+ my (
+ $min_year, $min_month, $min_day, $min_hour, $min_min, $min_sec,
+ $max_year, $max_month, $max_day, $max_hour, $max_min, $max_sec
+ );
+
+ # Get today's date
+ my ( $year, $month, $day, $hour, $min, $sec ) = Date::Calc::Today_and_Now();
+
+ if ( $options{'min'} ) {
+ if ( $options{'min'} eq 'now' ) {
+ ( $min_year, $min_month, $min_day,
+ $min_hour, $min_min, $min_sec )
+ = ( $year, $month, $day, $hour, $min, $sec );
+ }
+ else {
+ ( $min_year, $min_month, $min_day,
+ $min_hour, $min_min, $min_sec )
+ = $options{'min'} =~ /^(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)$/;
+ }
+ }
+ else {
+ ( $min_year, $min_month, $min_day, $min_hour, $min_min, $min_sec ) =
+ ( $year, $month, $day, 0, 0, 0 );
+ }
+
+ if ( $options{'max'} ) {
+ if ( $options{'max'} eq 'now' ) {
+ ( $max_year, $max_month, $max_day,
+ $max_hour, $max_min, $max_sec )
+ = ( $year, $month, $day, $hour, $min, $sec );
+ }
+ else {
+ ( $max_year, $max_month, $max_day,
+ $max_hour, $max_min, $max_sec )
+ = $options{'max'} =~ /^(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)$/;
+ }
+ }
+ else {
+ ( $max_year, $max_month, $max_day, $max_hour, $max_min, $max_sec ) =
+ ( Date::Calc::Add_Delta_YMD( $min_year, $min_month, $min_day, 1, 0,
+ 0 ), 23, 59, 59 );
+ }
+
+ my ( $delta_days, $delta_hours, $delta_mins, $delta_secs ) =
+ Date::Calc::Delta_DHMS(
+ $min_year, $min_month, $min_day, $min_hour, $min_min, $min_sec,
+ $max_year, $max_month, $max_day, $max_hour, $max_min, $max_sec,
+ );
+
+ cluck('max date is later than min date') && return
+ if ( $delta_days < 0 ) || ( $delta_hours < 0 ) || ( $delta_mins < 0 )
+ || ( $delta_secs < 0 );
+
+ $delta_secs =
+ ( $delta_days * 86400 ) + ( $delta_hours * 3600 ) + ( $delta_mins * 60 ) +
+ $delta_secs;
+
+ $delta_secs = int( rand( $delta_secs + 1 ) );
+
+ ( $year, $month, $day, $hour, $min, $sec ) = Date::Calc::Add_Delta_DHMS(
+ $min_year, $min_month, $min_day, $min_hour,
+ $min_min, $min_sec, 0, 0,
+ 0, $delta_secs
+ );
+
+ return
+ sprintf( "%04u-%02u-%02u %02u:%02u:%02u", $year, $month, $day, $hour,
+ $min, $sec );
+}
+
+################################################################################
+# rand_image()
+################################################################################
+sub rand_image {
+
+ # Get the options hash
+ my %options = @_;
+
+ $options{'minwidth'} ||= 1;
+ $options{'maxwidth'} ||= 100;
+ $options{'width'} ||=
+ int( rand( $options{'maxwidth'} - $options{'minwidth'} + 1 ) ) +
+ $options{'minwidth'};
+
+ $options{'minheight'} ||= 1;
+ $options{'maxheight'} ||= 100;
+ $options{'height'} ||=
+ int( rand( $options{'maxheight'} - $options{'minheight'} + 1 ) ) +
+ $options{'minheight'};
+
+ $options{'minpixels'} ||= 0;
+ $options{'maxpixels'} ||= $options{'width'} * $options{'height'};
+ $options{'pixels'} ||=
+ int( rand( $options{'maxpixels'} - $options{'minpixels'} + 1 ) ) +
+ $options{'minpixels'};
+
+ $options{'bgcolor'} ||= _color();
+ $options{'fgcolor'} ||= _color();
+
+ eval q{ use GD; };
+
+ cluck($@) && return if $@;
+
+ my $image = new GD::Image( $options{'width'}, $options{'height'} );
+
+ my $bgcolor = $image->colorAllocate( @{ $options{'bgcolor'} } );
+ my $fgcolor = $image->colorAllocate( @{ $options{'fgcolor'} } );
+
+ $image->rectangle( 0, 0, $options{'width'}, $options{'height'}, $bgcolor );
+
+ for ( my $i = 0 ; $i < $options{'pixels'} ; $i++ ) {
+ my $x = int( rand( $options{'width'} + 1 ) );
+ my $y = int( rand( $options{'height'} + 1 ) );
+
+ $image->setPixel( $x, $y, $fgcolor );
+ }
+
+ return $image->png();
+
+ sub _color {
+ return [ int( rand(266) ), int( rand(266) ), int( rand(266) ) ];
+ }
+}
+
+################################################################################
+# shuffle()
+################################################################################
+sub shuffle {
+ my $array = shift;
+
+ for ( my $i = @$array - 1 ; $i >= 0 ; $i-- ) {
+ my $j = int( rand( $i + 1 ) );
+
+ @$array[ $i, $j ] = @$array[ $j, $i ] if $i != $j;
+ }
+}
+
+1;
+
+=head1 NAME
+
+Data::Random - Perl module to generate random data
+
+
+=head1 SYNOPSIS
+
+ use Data::Random qw(:all);
+
+ my @random_words = rand_words( size => 10 );
+
+ my @random_chars = rand_chars( set => 'all', min => 5, max => 8 );
+
+ my @random_set = rand_set( set => \@set, size => 5 );
+
+ my $random_enum = rand_enum( set => \@set );
+
+ my $random_date = rand_date();
+
+ my $random_time = rand_time();
+
+ my $random_datetime = rand_datetime();
+
+ open(FILE, ">rand_image.png") or die $!;
+ binmode(FILE);
+ print FILE rand_image( bgcolor => [0, 0, 0] );
+ close(FILE);
+
+
+=head1 DESCRIPTION
+
+A module used to generate random data. Useful mostly for test programs.
+
+
+=head1 METHODS
+
+=head2 rand_words()
+
+This returns a list of random words given a wordlist. See below for possible parameters.
+
+=over 4
+
+=item *
+
+wordlist - the path to the wordlist file. A lot of systems have one at /usr/dict/words. You can also optionally supply a Data::Random::WordList object to keep a persistent wordlist. The default is the wordlist distributed with this module.
+
+=item *
+
+min - the minimum number of words to return. The default is 1.
+
+=item *
+
+max - the maximum number of words to return. The default is 1.
+
+=item *
+
+size - the number of words to return. The default is 1. If you supply a value for 'size', then 'min' and 'max' aren't paid attention to.
+
+=item *
+
+shuffle - whether or not the words should be randomly shuffled. Set this to 0 if you don't want the words shuffled. The default is 1. Random::Data::WordList returns words in the order that they're viewed in the word list file, so shuffling will make sure that the results are a little more random.
+
+=back 4
+
+
+=head2 rand_chars()
+
+This returns a list of random characters given a set of characters. See below for possible parameters.
+
+=over 4
+
+=item *
+
+set - the set of characters to be used. This value can be either a reference to an array of strings, or one of the following:
+
+ alpha - alphabetic characters: a-z, A-Z
+ upperalpha - upper case alphabetic characters: A-Z
+ loweralpha - lower case alphabetic characters: a-z
+ numeric - numeric characters: 0-9
+ alphanumeric - alphanumeric characters: a-z, A-Z, 0-9
+ char - non-alphanumeric characters: # ~ ! @ $ % ^ & * ( ) _ + = - { } | : " < > ? / . ' ; ] [ \ `
+ all - all of the above
+
+=item *
+
+min - the minimum number of characters to return. The default is 0.
+
+=item *
+
+max - the maximum number of characters to return. The default is the size of the set.
+
+=item *
+
+size - the number of characters to return. The default is 1. If you supply a value for 'size', then 'min' and 'max' aren't paid attention to.
+
+=item *
+
+shuffle - whether or not the characters should be randomly shuffled. Set this to 0 if you want the characters to stay in the order received. The default is 1.
+
+=back 4
+
+
+=head2 rand_set()
+
+This returns a random set of elements given an initial set. See below for possible parameters.
+
+=over 4
+
+=item *
+
+set - the set of strings to be used. This should be a reference to an array of strings.
+
+=item *
+
+min - the minimum number of strings to return. The default is 0.
+
+=item *
+
+max - the maximum number of strings to return. The default is the size of the set.
+
+=item *
+
+size - the number of strings to return. The default is 1. If you supply a value for 'size', then 'min' and 'max' aren't paid attention to.
+
+=item *
+
+shuffle - whether or not the strings should be randomly shuffled. Set this to 0 if you want the strings to stay in the order received. The default is 1.
+
+=back 4
+
+
+=head2 rand_enum()
+
+This returns a random element given an initial set. See below for possible parameters.
+
+=over 4
+
+=item *
+
+set - the set of strings to be used. This should be a reference to an array of strings.
+
+=back 4
+
+
+=head2 rand_date()
+
+This returns a random date in the form "YYYY-MM-DD". 2-digit years are not currently supported. Efforts are made to make sure you're returned a truly valid date--ie, you'll never be returned the date February 31st. See the options below to find out how to control the date range. Here are a few examples:
+
+ # returns a date somewhere in between the current date, and one year from the current date
+ $date = rand_date();
+
+ # returns a date somewhere in between September 21, 1978 and September 21, 1979
+ $date = rand_date( min => '1978-9-21' );
+
+ # returns a date somewhere in between September 21, 1978 and the current date
+ $date = rand_date( min => '1978-9-21', max => 'now' );
+
+ # returns a date somewhere in between the current date and September 21, 2008
+ $date = rand_date( min => 'now', max => '2008-9-21' );
+
+See below for possible parameters.
+
+=over 4
+
+=item *
+
+min - the minimum date to be returned. It should be in the form "YYYY-MM-DD" or you can alternatively use the string "now" to represent the current date. The default is the current date;
+
+=item *
+
+max - the maximum date to be returned. It should be in the form "YYYY-MM-DD" or you can alternatively use the string "now" to represent the current date. The default is one year from the minimum date;
+
+=back 4
+
+
+=head2 rand_time()
+
+This returns a random time in the form "HH:MM:SS". 24 hour times are supported. See the options below to find out how to control the time range. Here are a few examples:
+
+ # returns a random 24-hr time (between 00:00:00 and 23:59:59)
+ $time = rand_time();
+
+ # returns a time somewhere in between 04:00:00 and the end of the day
+ $time = rand_time( min => '4:0:0' );
+
+ # returns a time somewhere in between 8:00:00 and the current time (if it's after 8:00)
+ $time = rand_time( min => '12:00:00', max => 'now' );
+
+ # returns a date somewhere in between the current time and the end of the day
+ $time = rand_time( min => 'now' );
+
+See below for possible parameters.
+
+=over 4
+
+=item *
+
+min - the minimum time to be returned. It should be in the form "HH:MM:SS" or you can alternatively use the string "now" to represent the current time. The default is 00:00:00;
+
+=item *
+
+max - the maximum time to be returned. It should be in the form "HH:MM:SS" or you can alternatively use the string "now" to represent the current time. The default is 23:59:59;
+
+=back 4
+
+
+=head2 rand_datetime()
+
+This returns a random date and time in the form "YYYY-MM-DD HH:MM:SS". See the options below to find out how to control the date/time range. Here are a few examples:
+
+ # returns a date somewhere in between the current date/time, and one year from the current date/time
+ $datetime = rand_datetime();
+
+ # returns a date somewhere in between 4:00 September 21, 1978 and 4:00 September 21, 1979
+ $datetime = rand_datetime( min => '1978-9-21 4:0:0' );
+
+ # returns a date somewhere in between 4:00 September 21, 1978 and the current date
+ $datetime = rand_datetime( min => '1978-9-21 4:0:0', max => 'now' );
+
+ # returns a date somewhere in between the current date/time and the end of the day September 21, 2008
+ $datetime = rand_datetime( min => 'now', max => '2008-9-21 23:59:59' );
+
+See below for possible parameters.
+
+=over 4
+
+=item *
+
+min - the minimum date/time to be returned. It should be in the form "YYYY-MM-DD HH:MM:SS" or you can alternatively use the string "now" to represent the current date/time. The default is the current date/time;
+
+=item *
+
+max - the maximum date/time to be returned. It should be in the form "YYYY-MM-DD HH:MM:SS" or you can alternatively use the string "now" to represent the current date/time. The default is one year from the minimum date/time;
+
+=back 4
+
+
+=head2 rand_image()
+
+This returns a random image. Currently only PNG images are supported. See below for possible parameters.
+
+=over 4
+
+=item *
+
+minwidth - the minimum width of the image. The default is 1.
+
+=item *
+
+maxwidth - the maximum width of the image. The default is 100.
+
+=item *
+
+width - the width of the image. If you supply a value for 'width', then 'minwidth' and 'maxwidth' aren't paid attention to.
+
+=item *
+
+minheight - the minimum height of the image. The default is 1.
+
+=item *
+
+maxheight - the maximum height of the image. The default is 100.
+
+=item *
+
+height - the height of the image. If you supply a value for 'width', then 'minwidth' and 'maxwidth' aren't paid attention to.
+
+=item *
+
+minpixels - the minimum number of random pixels to display on the image. The default is 0.
+
+=item *
+
+maxpixels - the maximum number of random pixels to display on the image. The default is width * height.
+
+=item *
+
+pixels - the number of random pixels to display on the image. If you supply a value for 'pixels', then 'minpixels' and 'maxpixels' aren't paid attention to.
+
+=item *
+
+bgcolor - the background color of the image. The value must be a reference to an RGB array where each element is an integer between 0 and 255 (eg. [ 55, 120, 255 ]).
+
+=item *
+
+fgcolor - the foreground color of the image. The value must be a reference to an RGB array where each element is an integer between 0 and 255 (eg. [ 55, 120, 255 ]).
+
+=back 4
+
+
+=head1 VERSION
+
+0.05
+
+=head1 AUTHOR
+
+Adekunle Olonoh, koolade@users.sourceforge.net
+
+=head1 CREDITS
+
+Hiroki Chalfant
+David Sarno
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Adekunle Olonoh. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Data::Random::WordList
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Data/Random/WordList.pm b/Master/tlpkg/tlperl.straw/lib/Data/Random/WordList.pm
new file mode 100755
index 00000000000..217c3304ac5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Random/WordList.pm
@@ -0,0 +1,185 @@
+################################################################################
+# Data::Random
+#
+# A module used to generate random data.
+#
+# Author: Adekunle Olonoh
+# Date: October 2000
+################################################################################
+
+package Data::Random::WordList;
+
+################################################################################
+# - Modules and Libraries
+################################################################################
+#require 5.005_62;
+use FileHandle;
+use File::Basename qw(dirname);
+
+################################################################################
+# - Global Constants and Variables
+################################################################################
+$Data::Random::WordList::VERSION = '0.05';
+
+################################################################################
+# - Subroutines
+################################################################################
+
+################################################################################
+# new()
+################################################################################
+sub new {
+ my $proto = shift;
+ my %options = @_;
+
+ # Check if what was passed in was a prototype reference or a class name
+ my $class = ref($proto) || $proto;
+
+ $options{'wordlist'} ||= dirname($INC{'Data/Random.pm'}).'/Random/dict';
+
+ # Create a new filehandle object
+ my $fh = new FileHandle $options{'wordlist'}
+ or die "could not open $options{'wordlist'} : $!";
+
+ # Calculate the number of lines in the file
+ my $size = 0;
+ while (<$fh>) {
+ $size++;
+ }
+
+ # Create the object
+ my $self = bless {
+ 'fh' => $fh,
+ 'size' => $size,
+ }, $class;
+
+ return $self;
+}
+
+################################################################################
+# close()
+################################################################################
+sub close {
+ my $self = shift;
+
+ # Close the filehandle
+ $self->{'fh'}->close;
+}
+
+################################################################################
+# get_words()
+################################################################################
+sub get_words {
+ my $self = shift;
+ my $num = shift || 1;
+
+ my $fh = $self->{'fh'};
+
+ # Perform some error checking
+ die 'the size value must be a positive integer'
+ if $num < 0 || $num != int($num);
+ die
+"$num words were requested but only $self->{'size'} words exist in the wordlist"
+ if $num > $self->{'size'};
+
+ # Pick which lines we want
+ my %rand_lines = ();
+ for ( my $i = 0 ; $i < $num ; $i++ ) {
+ my $rand_line;
+
+ do {
+ $rand_line = int( rand( $self->{'size'} ) );
+ } while ( exists( $rand_lines{$rand_line} ) );
+
+ $rand_lines{$rand_line} = 1;
+ }
+
+ my $line = 0;
+ my @rand_words = ();
+
+ # Seek to the beginning of the filehandle
+ $fh->seek( 0, 0 ) or die "could not seek to position 0 in wordlist: $!";
+
+ # Now get the lines
+ while (<$fh>) {
+ chomp;
+ push ( @rand_words, $_ ) if $rand_lines{$line};
+
+ $line++;
+ }
+
+# Return an array or an array reference, depending on the context in which the sub was called
+ if ( wantarray() ) {
+ return @rand_words;
+ }
+ else {
+ return \@rand_words;
+ }
+}
+
+1;
+
+=head1 NAME
+
+Data::Random::WordList - Perl module to get random words from a word list
+
+=head1 SYNOPSIS
+
+ use Data::Random::WordList;
+
+ my $wl = new Data::Random::WordList( wordlist => '/usr/dict/words' );
+
+ my @rand_words = $wl->get_words(10);
+
+ $wl->close();
+
+=head1 DESCRIPTION
+
+Data::Random::WordList is a module that manages a file containing a list of words.
+
+The module expects each line of the word list file to contain only one word. It could thus be easily used to select random lines from a file, but for coherency's sake, I'll keep referring to each line as a word.
+
+The module uses a persistent filehandle so that there isn't a lot of overhead every time you want to fetch a list of random words. However, it's much more efficient to grab multiple words at a time than it is to fetch one word at a time multiple times.
+
+The module also refrains from reading the whole file into memory, so it can be safer to use with larger files.
+
+=head1 METHODS
+
+=head2 new()
+
+Returns a reference to a new Data::Random::WordList object. Use the "wordlist" param to initialize the object:
+
+=over 4
+
+=item *
+
+wordlist - the path to the wordlist file. If a path isn't supplied, the wordlist distributed with this module is used.
+
+=back 4
+
+=head2 get_words([NUM])
+
+NUM contains the number of words you want from the wordlist. NUM defaults to 1 if it's not specified. get_words() dies if NUM is greater than the number of words in the wordlist. This function returns an array or an array reference depending on the context in which it's called.
+
+=head2 close()
+
+Closes the filehandle associated with the word list. It's good practice to do this every time you're done with the word list.
+
+=head1 VERSION
+
+0.05
+
+=head1 AUTHOR
+
+Adekunle Olonoh, koolade@users.sourceforge.net
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Adekunle Olonoh. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Data::Random
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Data/Random/dict b/Master/tlpkg/tlperl.straw/lib/Data/Random/dict
new file mode 100755
index 00000000000..3e6e945e57c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Data/Random/dict
@@ -0,0 +1,45427 @@
+Aarhus
+Aaron
+Ababa
+aback
+abaft
+abandon
+abandoned
+abandoning
+abandonment
+abandons
+abase
+abased
+abasement
+abasements
+abases
+abash
+abashed
+abashes
+abashing
+abasing
+abate
+abated
+abatement
+abatements
+abater
+abates
+abating
+Abba
+abbe
+abbey
+abbeys
+abbot
+abbots
+Abbott
+abbreviate
+abbreviated
+abbreviates
+abbreviating
+abbreviation
+abbreviations
+Abby
+abdomen
+abdomens
+abdominal
+abduct
+abducted
+abduction
+abductions
+abductor
+abductors
+abducts
+Abe
+abed
+Abel
+Abelian
+Abelson
+Aberdeen
+Abernathy
+aberrant
+aberration
+aberrations
+abet
+abets
+abetted
+abetter
+abetting
+abeyance
+abhor
+abhorred
+abhorrent
+abhorrer
+abhorring
+abhors
+abide
+abided
+abides
+abiding
+Abidjan
+Abigail
+Abilene
+abilities
+ability
+abject
+abjection
+abjections
+abjectly
+abjectness
+abjure
+abjured
+abjures
+abjuring
+ablate
+ablated
+ablates
+ablating
+ablation
+ablative
+ablaze
+able
+abler
+ablest
+ably
+Abner
+abnormal
+abnormalities
+abnormality
+abnormally
+Abo
+aboard
+abode
+abodes
+abolish
+abolished
+abolisher
+abolishers
+abolishes
+abolishing
+abolishment
+abolishments
+abolition
+abolitionist
+abolitionists
+abominable
+abominate
+aboriginal
+aborigine
+aborigines
+abort
+aborted
+aborting
+abortion
+abortions
+abortive
+abortively
+aborts
+Abos
+abound
+abounded
+abounding
+abounds
+about
+above
+aboveboard
+aboveground
+abovementioned
+abrade
+abraded
+abrades
+abrading
+Abraham
+Abram
+Abrams
+Abramson
+abrasion
+abrasions
+abrasive
+abreaction
+abreactions
+abreast
+abridge
+abridged
+abridges
+abridging
+abridgment
+abroad
+abrogate
+abrogated
+abrogates
+abrogating
+abrupt
+abruptly
+abruptness
+abscess
+abscessed
+abscesses
+abscissa
+abscissas
+abscond
+absconded
+absconding
+absconds
+absence
+absences
+absent
+absented
+absentee
+absenteeism
+absentees
+absentia
+absenting
+absently
+absentminded
+absents
+absinthe
+absolute
+absolutely
+absoluteness
+absolutes
+absolution
+absolve
+absolved
+absolves
+absolving
+absorb
+absorbed
+absorbency
+absorbent
+absorber
+absorbing
+absorbs
+absorption
+absorptions
+absorptive
+abstain
+abstained
+abstainer
+abstaining
+abstains
+abstention
+abstentions
+abstinence
+abstract
+abstracted
+abstracting
+abstraction
+abstractionism
+abstractionist
+abstractions
+abstractly
+abstractness
+abstractor
+abstractors
+abstracts
+abstruse
+abstruseness
+absurd
+absurdities
+absurdity
+absurdly
+Abu
+abundance
+abundant
+abundantly
+abuse
+abused
+abuses
+abusing
+abusive
+abut
+abutment
+abuts
+abutted
+abutter
+abutters
+abutting
+abysmal
+abysmally
+abyss
+abysses
+Abyssinia
+Abyssinian
+Abyssinians
+acacia
+academia
+academic
+academically
+academics
+academies
+academy
+Acadia
+Acapulco
+accede
+acceded
+accedes
+accelerate
+accelerated
+accelerates
+accelerating
+acceleration
+accelerations
+accelerator
+accelerators
+accelerometer
+accelerometers
+accent
+accented
+accenting
+accents
+accentual
+accentuate
+accentuated
+accentuates
+accentuating
+accentuation
+accept
+acceptability
+acceptable
+acceptably
+acceptance
+acceptances
+accepted
+accepter
+accepters
+accepting
+acceptor
+acceptors
+accepts
+access
+accessed
+accesses
+accessibility
+accessible
+accessibly
+accessing
+accession
+accessions
+accessories
+accessors
+accessory
+accident
+accidental
+accidentally
+accidently
+accidents
+acclaim
+acclaimed
+acclaiming
+acclaims
+acclamation
+acclimate
+acclimated
+acclimates
+acclimating
+acclimatization
+acclimatized
+accolade
+accolades
+accommodate
+accommodated
+accommodates
+accommodating
+accommodation
+accommodations
+accompanied
+accompanies
+accompaniment
+accompaniments
+accompanist
+accompanists
+accompany
+accompanying
+accomplice
+accomplices
+accomplish
+accomplished
+accomplisher
+accomplishers
+accomplishes
+accomplishing
+accomplishment
+accomplishments
+accord
+accordance
+accorded
+accorder
+accorders
+according
+accordingly
+accordion
+accordions
+accords
+accost
+accosted
+accosting
+accosts
+account
+accountability
+accountable
+accountably
+accountancy
+accountant
+accountants
+accounted
+accounting
+accounts
+Accra
+accredit
+accreditation
+accreditations
+accredited
+accretion
+accretions
+accrue
+accrued
+accrues
+accruing
+acculturate
+acculturated
+acculturates
+acculturating
+acculturation
+accumulate
+accumulated
+accumulates
+accumulating
+accumulation
+accumulations
+accumulator
+accumulators
+accuracies
+accuracy
+accurate
+accurately
+accurateness
+accursed
+accusal
+accusation
+accusations
+accusative
+accuse
+accused
+accuser
+accuses
+accusing
+accusingly
+accustom
+accustomed
+accustoming
+accustoms
+ace
+aces
+acetate
+acetone
+acetylene
+Achaean
+Achaeans
+ache
+ached
+aches
+achievable
+achieve
+achieved
+achievement
+achievements
+achiever
+achievers
+achieves
+achieving
+Achilles
+aching
+acid
+acidic
+acidities
+acidity
+acidly
+acids
+acidulous
+Ackerman
+Ackley
+acknowledge
+acknowledgeable
+acknowledged
+acknowledgement
+acknowledgements
+acknowledger
+acknowledgers
+acknowledges
+acknowledging
+acknowledgment
+acknowledgments
+acme
+acne
+acolyte
+acolytes
+acorn
+acorns
+acoustic
+acoustical
+acoustically
+acoustician
+acoustics
+acquaint
+acquaintance
+acquaintances
+acquainted
+acquainting
+acquaints
+acquiesce
+acquiesced
+acquiescence
+acquiescent
+acquiesces
+acquiescing
+acquirable
+acquire
+acquired
+acquires
+acquiring
+acquisition
+acquisitions
+acquisitive
+acquisitiveness
+acquit
+acquits
+acquittal
+acquitted
+acquitter
+acquitting
+acre
+acreage
+acres
+acrid
+acrimonious
+acrimony
+acrobat
+acrobatic
+acrobatics
+acrobats
+acronym
+acronyms
+acropolis
+across
+acrylic
+act
+Acta
+Actaeon
+acted
+acting
+actinium
+actinometer
+actinometers
+action
+actions
+activate
+activated
+activates
+activating
+activation
+activations
+activator
+activators
+active
+actively
+activism
+activist
+activists
+activities
+activity
+Acton
+actor
+actors
+actress
+actresses
+Acts
+actual
+actualities
+actuality
+actualization
+actually
+actuals
+actuarial
+actuarially
+actuate
+actuated
+actuates
+actuating
+actuator
+actuators
+acuity
+acumen
+acute
+acutely
+acuteness
+acyclic
+acyclically
+ad
+Ada
+adage
+adages
+adagio
+adagios
+Adair
+Adam
+adamant
+adamantly
+Adams
+Adamson
+adapt
+adaptability
+adaptable
+adaptation
+adaptations
+adapted
+adapter
+adapters
+adapting
+adaptive
+adaptively
+adaptor
+adaptors
+adapts
+add
+added
+addend
+addenda
+addendum
+adder
+adders
+addict
+addicted
+addicting
+addiction
+addictions
+addicts
+adding
+Addis
+Addison
+addition
+additional
+additionally
+additions
+additive
+additives
+additivity
+address
+addressability
+addressable
+addressed
+addressee
+addressees
+addresser
+addressers
+addresses
+addressing
+Addressograph
+adds
+adduce
+adduced
+adduces
+adducible
+adducing
+adduct
+adducted
+adducting
+adduction
+adductor
+adducts
+Adelaide
+Adele
+Adelia
+Aden
+adept
+adequacies
+adequacy
+adequate
+adequately
+adhere
+adhered
+adherence
+adherent
+adherents
+adherer
+adherers
+adheres
+adhering
+adhesion
+adhesions
+adhesive
+adhesives
+adiabatic
+adiabatically
+adieu
+Adirondack
+Adirondacks
+adjacency
+adjacent
+adjective
+adjectives
+adjoin
+adjoined
+adjoining
+adjoins
+adjourn
+adjourned
+adjourning
+adjournment
+adjourns
+adjudge
+adjudged
+adjudges
+adjudging
+adjudicate
+adjudicated
+adjudicates
+adjudicating
+adjudication
+adjudications
+adjunct
+adjuncts
+adjure
+adjured
+adjures
+adjuring
+adjust
+adjustable
+adjustably
+adjusted
+adjuster
+adjusters
+adjusting
+adjustment
+adjustments
+adjustor
+adjustors
+adjusts
+adjutant
+adjutants
+Adkins
+Adler
+Adlerian
+administer
+administered
+administering
+administerings
+administers
+administrable
+administrate
+administration
+administrations
+administrative
+administratively
+administrator
+administrators
+admirable
+admirably
+admiral
+admirals
+admiralty
+admiration
+admirations
+admire
+admired
+admirer
+admirers
+admires
+admiring
+admiringly
+admissibility
+admissible
+admission
+admissions
+admit
+admits
+admittance
+admitted
+admittedly
+admitter
+admitters
+admitting
+admix
+admixed
+admixes
+admixture
+admonish
+admonished
+admonishes
+admonishing
+admonishment
+admonishments
+admonition
+admonitions
+ado
+adobe
+adolescence
+adolescent
+adolescents
+Adolph
+Adolphus
+Adonis
+adopt
+adopted
+adopter
+adopters
+adopting
+adoption
+adoptions
+adoptive
+adopts
+adorable
+adoration
+adore
+adored
+adores
+adorn
+adorned
+adornment
+adornments
+adorns
+adrenal
+adrenaline
+Adrian
+Adriatic
+Adrienne
+adrift
+adroit
+adroitness
+ads
+adsorb
+adsorbed
+adsorbing
+adsorbs
+adsorption
+adulate
+adulating
+adulation
+adult
+adulterate
+adulterated
+adulterates
+adulterating
+adulterer
+adulterers
+adulterous
+adulterously
+adultery
+adulthood
+adults
+adumbrate
+adumbrated
+adumbrates
+adumbrating
+adumbration
+advance
+advanced
+advancement
+advancements
+advances
+advancing
+advantage
+advantaged
+advantageous
+advantageously
+advantages
+advent
+adventist
+adventists
+adventitious
+adventure
+adventured
+adventurer
+adventurers
+adventures
+adventuring
+adventurous
+adverb
+adverbial
+adverbs
+adversaries
+adversary
+adverse
+adversely
+adversities
+adversity
+advert
+advertise
+advertised
+advertisement
+advertisements
+advertiser
+advertisers
+advertises
+advertising
+advice
+advisability
+advisable
+advisably
+advise
+advised
+advisedly
+advisee
+advisees
+advisement
+advisements
+adviser
+advisers
+advises
+advising
+advisor
+advisors
+advisory
+advocacy
+advocate
+advocated
+advocates
+advocating
+Aegean
+aegis
+Aeneas
+Aeneid
+Aeolus
+aerate
+aerated
+aerates
+aerating
+aeration
+aerator
+aerators
+aerial
+aerials
+aeroacoustic
+Aerobacter
+aerobic
+aerobics
+aerodynamic
+aerodynamics
+aeronautic
+aeronautical
+aeronautics
+aerosol
+aerosolize
+aerosols
+aerospace
+Aeschylus
+Aesop
+aesthetic
+aesthetically
+aesthetics
+afar
+affable
+affair
+affairs
+affect
+affectation
+affectations
+affected
+affecting
+affectingly
+affection
+affectionate
+affectionately
+affections
+affective
+affects
+afferent
+affianced
+affidavit
+affidavits
+affiliate
+affiliated
+affiliates
+affiliating
+affiliation
+affiliations
+affinities
+affinity
+affirm
+affirmation
+affirmations
+affirmative
+affirmatively
+affirmed
+affirming
+affirms
+affix
+affixed
+affixes
+affixing
+afflict
+afflicted
+afflicting
+affliction
+afflictions
+afflictive
+afflicts
+affluence
+affluent
+afford
+affordable
+afforded
+affording
+affords
+affricate
+affricates
+affright
+affront
+affronted
+affronting
+affronts
+Afghan
+Afghanistan
+Afghans
+aficionado
+afield
+afire
+aflame
+afloat
+afoot
+afore
+aforementioned
+aforesaid
+aforethought
+afoul
+afraid
+afresh
+Africa
+African
+Africanization
+Africanizations
+Africanize
+Africanized
+Africanizes
+Africanizing
+Africans
+Afrikaans
+Afrikaner
+Afrikaners
+aft
+after
+aftereffect
+afterglow
+afterimage
+afterlife
+aftermath
+aftermost
+afternoon
+afternoons
+aftershock
+aftershocks
+afterthought
+afterthoughts
+afterward
+afterwards
+again
+against
+Agamemnon
+agape
+agar
+agate
+agates
+Agatha
+age
+aged
+Agee
+ageless
+agencies
+agency
+agenda
+agendas
+agent
+agents
+ager
+agers
+ages
+Aggie
+Aggies
+agglomerate
+agglomerated
+agglomerates
+agglomeration
+agglutinate
+agglutinated
+agglutinates
+agglutinating
+agglutination
+agglutinin
+agglutinins
+aggrandize
+aggravate
+aggravated
+aggravates
+aggravation
+aggregate
+aggregated
+aggregately
+aggregates
+aggregating
+aggregation
+aggregations
+aggression
+aggressions
+aggressive
+aggressively
+aggressiveness
+aggressor
+aggressors
+aggrieve
+aggrieved
+aggrieves
+aggrieving
+aghast
+agile
+agilely
+agility
+aging
+agitate
+agitated
+agitates
+agitating
+agitation
+agitations
+agitator
+agitators
+agleam
+aglow
+Agnes
+Agnew
+agnostic
+agnostics
+ago
+agog
+agonies
+agonize
+agonized
+agonizes
+agonizing
+agonizingly
+agony
+agrarian
+agree
+agreeable
+agreeably
+agreed
+agreeing
+agreement
+agreements
+agreer
+agreers
+agrees
+Agricola
+agricultural
+agriculturally
+agriculture
+ague
+Agway
+ah
+ahead
+Ahmadabad
+Ahmedabad
+aid
+Aida
+aide
+aided
+Aides
+aiding
+aids
+Aiken
+ail
+Aileen
+aileron
+ailerons
+ailing
+ailment
+ailments
+aim
+aimed
+aimer
+aimers
+aiming
+aimless
+aimlessly
+aims
+Ainu
+Ainus
+air
+airbag
+airbags
+airborne
+Airbus
+aircraft
+airdrop
+airdrops
+aired
+Airedale
+airer
+airers
+Aires
+airfare
+airfield
+airfields
+airflow
+airfoil
+airfoils
+airframe
+airframes
+airily
+airing
+airings
+airless
+airlift
+airlifts
+airline
+airliner
+airlines
+airlock
+airlocks
+airmail
+airmails
+airman
+airmen
+airplane
+airplanes
+airport
+airports
+airs
+airship
+airships
+airspace
+airspeed
+airstrip
+airstrips
+airtight
+airway
+airways
+airy
+aisle
+Aitken
+ajar
+Ajax
+Akers
+akimbo
+akin
+Akron
+Al
+Alabama
+Alabamans
+Alabamian
+alabaster
+alacrity
+Aladdin
+Alameda
+Alamo
+Alamos
+Alan
+Alar
+alarm
+alarmed
+alarming
+alarmingly
+alarmist
+alarms
+alas
+Alaska
+Alaskan
+Alastair
+alba
+albacore
+Albania
+Albanian
+Albanians
+Albany
+albatross
+albeit
+Alberich
+Albert
+Alberta
+Alberto
+Albrecht
+Albright
+album
+albumin
+albums
+Albuquerque
+Alcestis
+alchemy
+Alcibiades
+Alcmena
+Alcoa
+alcohol
+alcoholic
+alcoholics
+alcoholism
+alcohols
+Alcott
+alcove
+alcoves
+Aldebaran
+Alden
+alder
+alderman
+aldermen
+Aldrich
+ale
+Alec
+Aleck
+alee
+alert
+alerted
+alertedly
+alerter
+alerters
+alerting
+alertly
+alertness
+alerts
+Aleut
+Aleutian
+Alex
+Alexander
+Alexandra
+Alexandre
+Alexandria
+Alexandrine
+Alexei
+Alexis
+Alfa
+alfalfa
+Alfonso
+Alfred
+Alfredo
+alfresco
+alga
+algae
+algaecide
+algebra
+algebraic
+algebraically
+algebras
+Algenib
+Alger
+Algeria
+Algerian
+Algiers
+alginate
+ALGOL
+Algol
+Algonquian
+Algonquin
+algorithm
+algorithmic
+algorithmically
+algorithms
+Alhambra
+Ali
+alias
+aliased
+aliases
+aliasing
+alibi
+alibis
+Alice
+Alicia
+alien
+alienate
+alienated
+alienates
+alienating
+alienation
+aliens
+alight
+align
+aligned
+aligning
+alignment
+alignments
+aligns
+alike
+aliment
+aliments
+alimony
+Alison
+Alistair
+alive
+alkali
+alkaline
+alkalis
+alkaloid
+alkaloids
+alkyl
+all
+Allah
+Allan
+allay
+allayed
+allaying
+allays
+allegation
+allegations
+allege
+alleged
+allegedly
+alleges
+Alleghenies
+Allegheny
+allegiance
+allegiances
+alleging
+allegoric
+allegorical
+allegorically
+allegories
+allegory
+Allegra
+allegretto
+allegrettos
+allele
+alleles
+allemande
+Allen
+Allendale
+Allentown
+allergic
+allergies
+allergy
+alleviate
+alleviated
+alleviates
+alleviating
+alleviation
+alley
+alleys
+alleyway
+alleyways
+alliance
+alliances
+allied
+allies
+alligator
+alligators
+Allis
+Allison
+alliteration
+alliterations
+alliterative
+allocatable
+allocate
+allocated
+allocates
+allocating
+allocation
+allocations
+allocator
+allocators
+allophone
+allophones
+allophonic
+allot
+allotment
+allotments
+allotrope
+allotropic
+allots
+allotted
+allotter
+allotting
+allow
+allowable
+allowably
+allowance
+allowances
+allowed
+allowing
+allows
+alloy
+alloys
+Allstate
+allude
+alluded
+alludes
+alluding
+allure
+allurement
+alluring
+allusion
+allusions
+allusive
+allusiveness
+ally
+allying
+Allyn
+alma
+Almaden
+almanac
+almanacs
+almighty
+almond
+almonds
+almoner
+almost
+alms
+almsman
+alnico
+aloe
+aloes
+aloft
+aloha
+alone
+aloneness
+along
+alongside
+aloof
+aloofness
+aloud
+Alpert
+alpha
+alphabet
+alphabetic
+alphabetical
+alphabetically
+alphabetics
+alphabetize
+alphabetized
+alphabetizes
+alphabetizing
+alphabets
+alphanumeric
+Alpheratz
+Alphonse
+alpine
+Alps
+already
+Alsatian
+Alsatians
+also
+Alsop
+Altair
+altar
+altars
+alter
+alterable
+alteration
+alterations
+altercation
+altercations
+altered
+alterer
+alterers
+altering
+alternate
+alternated
+alternately
+alternates
+alternating
+alternation
+alternations
+alternative
+alternatively
+alternatives
+alternator
+alternators
+alters
+Althaea
+although
+altitude
+altitudes
+altogether
+Alton
+Altos
+altruism
+altruist
+altruistic
+altruistically
+alum
+aluminum
+alumna
+alumnae
+alumni
+alumnus
+alundum
+Alva
+Alvarez
+alveolar
+alveoli
+alveolus
+Alvin
+always
+Alyssa
+am
+Amadeus
+amain
+amalgam
+amalgamate
+amalgamated
+amalgamates
+amalgamating
+amalgamation
+amalgams
+Amanda
+amanuensis
+amaretto
+Amarillo
+amass
+amassed
+amasses
+amassing
+amateur
+amateurish
+amateurishness
+amateurism
+amateurs
+amatory
+amaze
+amazed
+amazedly
+amazement
+amazer
+amazers
+amazes
+amazing
+amazingly
+Amazon
+Amazons
+ambassador
+ambassadors
+amber
+ambiance
+ambidextrous
+ambidextrously
+ambient
+ambiguities
+ambiguity
+ambiguous
+ambiguously
+ambition
+ambitions
+ambitious
+ambitiously
+ambivalence
+ambivalent
+ambivalently
+amble
+ambled
+ambler
+ambles
+ambling
+ambrosial
+ambulance
+ambulances
+ambulatory
+ambuscade
+ambush
+ambushed
+ambushes
+Amdahl
+Amelia
+ameliorate
+ameliorated
+ameliorating
+amelioration
+amen
+amenable
+amend
+amended
+amending
+amendment
+amendments
+amends
+amenities
+amenity
+amenorrhea
+Amerada
+America
+American
+Americana
+Americanism
+Americanization
+Americanizations
+Americanize
+Americanizer
+Americanizers
+Americanizes
+Americans
+Americas
+americium
+Ames
+Amharic
+Amherst
+amiable
+amicable
+amicably
+amid
+amide
+amidst
+Amiga
+amigo
+amino
+amiss
+amity
+Amman
+Ammerman
+ammo
+ammonia
+ammoniac
+ammonium
+ammunition
+amnesty
+Amoco
+amoeba
+amoebae
+amoebas
+amok
+among
+amongst
+Amontillado
+amoral
+amorality
+amorist
+amorous
+amorphous
+amorphously
+amortize
+amortized
+amortizes
+amortizing
+Amos
+amount
+amounted
+amounter
+amounters
+amounting
+amounts
+amour
+amperage
+ampere
+amperes
+ampersand
+ampersands
+Ampex
+amphetamine
+amphetamines
+amphibian
+amphibians
+amphibious
+amphibiously
+amphibology
+amphitheater
+amphitheaters
+ample
+amplification
+amplified
+amplifier
+amplifiers
+amplifies
+amplify
+amplifying
+amplitude
+amplitudes
+amply
+ampoule
+ampoules
+amputate
+amputated
+amputates
+amputating
+Amsterdam
+Amtrak
+amulet
+amulets
+amuse
+amused
+amusedly
+amusement
+amusements
+amuser
+amusers
+amuses
+amusing
+amusingly
+Amy
+amyl
+an
+Anabaptist
+Anabaptists
+Anabel
+anachronism
+anachronisms
+anachronistically
+anaconda
+anacondas
+Anacreon
+anaerobic
+anagram
+anagrams
+Anaheim
+anal
+Analects
+analog
+analogical
+analogies
+analogous
+analogously
+analogue
+analogues
+analogy
+analyses
+analysis
+analyst
+analysts
+analytic
+analytical
+analytically
+analyticities
+analyticity
+analyzable
+analyze
+analyzed
+analyzer
+analyzers
+analyzes
+analyzing
+anaphora
+anaphoric
+anaphorically
+anaplasmosis
+anarchic
+anarchical
+anarchism
+anarchist
+anarchists
+anarchy
+Anastasia
+anastomoses
+anastomosis
+anastomotic
+anathema
+Anatole
+Anatolia
+Anatolian
+anatomic
+anatomical
+anatomically
+anatomy
+ancestor
+ancestors
+ancestral
+ancestry
+anchor
+anchorage
+anchorages
+anchored
+anchoring
+anchorite
+anchoritism
+anchors
+anchovies
+anchovy
+ancient
+anciently
+ancients
+ancillary
+and
+Andalusia
+Andalusian
+Andalusians
+Andean
+anders
+Andersen
+Anderson
+Andes
+anding
+Andorra
+Andover
+Andre
+Andrea
+Andrei
+Andrew
+Andrews
+Andromache
+Andromeda
+Andy
+anecdotal
+anecdote
+anecdotes
+anechoic
+anemia
+anemic
+anemometer
+anemometers
+anemometry
+anemone
+anesthesia
+anesthetic
+anesthetically
+anesthetics
+anesthetize
+anesthetized
+anesthetizes
+anesthetizing
+anew
+angel
+Angela
+Angeleno
+Angelenos
+Angeles
+angelic
+Angelica
+Angelina
+Angeline
+Angelo
+angels
+anger
+angered
+angering
+angers
+Angie
+angiography
+angle
+angled
+angler
+anglers
+Angles
+Anglia
+Anglican
+Anglicanism
+Anglicanize
+Anglicanizes
+Anglicans
+angling
+Anglo
+Anglophilia
+Anglophobia
+Angola
+Angora
+angrier
+angriest
+angrily
+angry
+angst
+angstrom
+anguish
+anguished
+angular
+angularly
+Angus
+Anheuser
+anhydrous
+anhydrously
+aniline
+animal
+animals
+animate
+animated
+animatedly
+animately
+animateness
+animates
+animating
+animation
+animations
+animator
+animators
+animism
+animized
+animosity
+anion
+anionic
+anions
+anise
+aniseikonic
+anisotropic
+anisotropy
+Anita
+Ankara
+ankle
+ankles
+Ann
+Anna
+annal
+Annalist
+Annalistic
+annals
+Annapolis
+Anne
+Annette
+annex
+annexation
+annexed
+annexes
+annexing
+Annie
+annihilate
+annihilated
+annihilates
+annihilating
+annihilation
+anniversaries
+anniversary
+annotate
+annotated
+annotates
+annotating
+annotation
+annotations
+announce
+announced
+announcement
+announcements
+announcer
+announcers
+announces
+announcing
+annoy
+annoyance
+annoyances
+annoyed
+annoyer
+annoyers
+annoying
+annoyingly
+annoys
+annual
+annually
+annuals
+annuity
+annul
+annular
+annuli
+annulled
+annulling
+annulment
+annulments
+annuls
+annulus
+annum
+annunciate
+annunciated
+annunciates
+annunciating
+annunciator
+annunciators
+anode
+anodes
+anodize
+anodized
+anodizes
+anoint
+anointed
+anointing
+anoints
+anomalies
+anomalous
+anomalously
+anomaly
+anomic
+anomie
+anon
+anonymity
+anonymous
+anonymously
+anorexia
+another
+Anselm
+Anselmo
+ANSI
+answer
+answerable
+answered
+answerer
+answerers
+answering
+answers
+ant
+Antaeus
+antagonism
+antagonisms
+antagonist
+antagonistic
+antagonistically
+antagonists
+antagonize
+antagonized
+antagonizes
+antagonizing
+antarctic
+Antarctica
+Antares
+ante
+anteater
+anteaters
+antecedent
+antecedents
+antedate
+antelope
+antelopes
+antenna
+antennae
+antennas
+anterior
+anthem
+anthems
+anther
+anthologies
+anthology
+Anthony
+anthracite
+anthropological
+anthropologically
+anthropologist
+anthropologists
+anthropology
+anthropomorphic
+anthropomorphically
+anti
+antibacterial
+antibiotic
+antibiotics
+antibodies
+antibody
+antic
+anticipate
+anticipated
+anticipates
+anticipating
+anticipation
+anticipations
+anticipatory
+anticoagulation
+anticompetitive
+antics
+antidisestablishmentarianism
+antidote
+antidotes
+Antietam
+antiformant
+antifundamentalist
+antigen
+antigens
+Antigone
+antihistorical
+Antilles
+antimicrobial
+antimony
+antinomian
+antinomy
+Antioch
+antipathy
+antiphonal
+antipode
+antipodes
+antiquarian
+antiquarians
+antiquate
+antiquated
+antique
+antiques
+antiquities
+antiquity
+antiredeposition
+antiresonance
+antiresonator
+antisemitic
+antisemitism
+antiseptic
+antisera
+antiserum
+antislavery
+antisocial
+antisubmarine
+antisymmetric
+antisymmetry
+antithesis
+antithetical
+antithyroid
+antitoxin
+antitoxins
+antitrust
+antler
+antlered
+Antoine
+Antoinette
+Anton
+Antonio
+Antonovics
+Antony
+ants
+Antwerp
+anus
+anvil
+anvils
+anxieties
+anxiety
+anxious
+anxiously
+any
+anybody
+anyhow
+anymore
+anyone
+anyplace
+anything
+anytime
+anyway
+anywhere
+aorta
+apace
+Apaches
+Apalachicola
+apart
+apartment
+apartments
+apathetic
+apathy
+Apatosaurus
+ape
+aped
+aperiodic
+aperiodicity
+aperture
+apes
+Apetalous
+apex
+aphasia
+aphasic
+aphelion
+aphid
+aphids
+aphonic
+aphorism
+aphorisms
+Aphrodite
+apiaries
+apiary
+apical
+apiece
+aping
+apish
+aplenty
+aplomb
+apocalypse
+apocalyptic
+Apocrypha
+apocryphal
+apogee
+apogees
+Apollinaire
+Apollo
+Apollonian
+apologetic
+apologetically
+apologia
+apologies
+apologist
+apologists
+apologize
+apologized
+apologizes
+apologizing
+apology
+apostate
+apostle
+apostles
+apostolic
+apostrophe
+apostrophes
+apothecary
+apothegm
+apotheoses
+apotheosis
+Appalachia
+Appalachian
+Appalachians
+appall
+appalled
+appalling
+appallingly
+Appaloosas
+appanage
+apparatus
+apparel
+appareled
+apparent
+apparently
+apparition
+apparitions
+appeal
+appealed
+appealer
+appealers
+appealing
+appealingly
+appeals
+appear
+appearance
+appearances
+appeared
+appearer
+appearers
+appearing
+appears
+appease
+appeased
+appeasement
+appeases
+appeasing
+appellant
+appellants
+appellate
+appellation
+append
+appendage
+appendages
+appended
+appender
+appenders
+appendices
+appendicitis
+appending
+appendix
+appendixes
+appends
+appertain
+appertains
+appetite
+appetites
+appetizer
+appetizing
+Appia
+Appian
+applaud
+applauded
+applauding
+applauds
+applause
+apple
+Appleby
+applejack
+apples
+Appleton
+appliance
+appliances
+applicability
+applicable
+applicant
+applicants
+application
+applications
+applicative
+applicatively
+applicator
+applicators
+applied
+applier
+appliers
+applies
+applique
+apply
+applying
+appoint
+appointed
+appointee
+appointees
+appointer
+appointers
+appointing
+appointive
+appointment
+appointments
+appoints
+Appomattox
+apportion
+apportioned
+apportioning
+apportionment
+apportionments
+apportions
+apposite
+appraisal
+appraisals
+appraise
+appraised
+appraiser
+appraisers
+appraises
+appraising
+appraisingly
+appreciable
+appreciably
+appreciate
+appreciated
+appreciates
+appreciating
+appreciation
+appreciations
+appreciative
+appreciatively
+apprehend
+apprehended
+apprehensible
+apprehension
+apprehensions
+apprehensive
+apprehensively
+apprehensiveness
+apprentice
+apprenticed
+apprentices
+apprenticeship
+apprise
+apprised
+apprises
+apprising
+approach
+approachability
+approachable
+approached
+approacher
+approachers
+approaches
+approaching
+approbate
+approbation
+appropriate
+appropriated
+appropriately
+appropriateness
+appropriates
+appropriating
+appropriation
+appropriations
+appropriator
+appropriators
+approval
+approvals
+approve
+approved
+approver
+approvers
+approves
+approving
+approvingly
+approximate
+approximated
+approximately
+approximates
+approximating
+approximation
+approximations
+appurtenance
+appurtenances
+apricot
+apricots
+April
+Aprils
+apron
+aprons
+apropos
+apse
+apsis
+apt
+aptitude
+aptitudes
+aptly
+aptness
+aqua
+aquaria
+aquarium
+Aquarius
+aquatic
+aqueduct
+aqueducts
+aqueous
+aquifer
+aquifers
+Aquila
+Aquinas
+Arab
+arabesque
+Arabia
+Arabian
+Arabianize
+Arabianizes
+Arabians
+Arabic
+Arabicize
+Arabicizes
+arable
+Arabs
+Araby
+Arachne
+arachnid
+arachnids
+Aramco
+Arapaho
+arbiter
+arbiters
+arbitrarily
+arbitrariness
+arbitrary
+arbitrate
+arbitrated
+arbitrates
+arbitrating
+arbitration
+arbitrator
+arbitrators
+arbor
+arboreal
+arbors
+arc
+arcade
+arcaded
+arcades
+Arcadia
+Arcadian
+arcane
+arced
+arch
+Archaeopteryx
+archaic
+archaically
+archaicness
+archaism
+archaize
+archangel
+archangels
+archbishop
+archdiocese
+archdioceses
+arched
+archenemy
+archeological
+archeologist
+archeology
+Archer
+archers
+archery
+arches
+archetype
+archfool
+Archibald
+Archie
+Archimedes
+arching
+archipelago
+archipelagoes
+architect
+architectonic
+architects
+architectural
+architecturally
+architecture
+architectures
+archival
+archive
+archived
+archiver
+archivers
+archives
+archiving
+archivist
+archly
+arcing
+arclike
+ARCO
+arcs
+arcsine
+arctangent
+arctic
+Arcturus
+Arden
+ardent
+ardently
+ardor
+arduous
+arduously
+arduousness
+are
+area
+areas
+arena
+arenas
+Arequipa
+Ares
+Argentina
+Argentinian
+Argive
+Argo
+argon
+Argonaut
+argonauts
+Argonne
+Argos
+argot
+arguable
+arguably
+argue
+argued
+arguer
+arguers
+argues
+arguing
+argument
+argumentation
+argumentative
+arguments
+Argus
+Ariadne
+Arianism
+Arianist
+Arianists
+arid
+aridity
+Aries
+aright
+arise
+arisen
+ariser
+arises
+arising
+arisings
+aristocracy
+aristocrat
+aristocratic
+aristocratically
+aristocrats
+Aristotelian
+Aristotle
+arithmetic
+arithmetical
+arithmetically
+arithmetics
+arithmetize
+arithmetized
+arithmetizes
+Arizona
+ark
+Arkansan
+Arkansas
+Arlen
+Arlene
+Arlington
+arm
+Armada
+armadillo
+armadillos
+Armageddon
+Armagnac
+armament
+armaments
+Armata
+armchair
+armchairs
+Armco
+armed
+Armenia
+Armenian
+armer
+armers
+armful
+armhole
+armies
+arming
+armistice
+armload
+Armonk
+armor
+armored
+armorer
+armory
+Armour
+armpit
+armpits
+arms
+Armstrong
+army
+Arnold
+aroma
+aromas
+aromatic
+arose
+around
+arousal
+arouse
+aroused
+arouses
+arousing
+ARPA
+ARPANET
+Arpanet
+arpeggio
+arpeggios
+arrack
+Arragon
+arraign
+arraigned
+arraigning
+arraignment
+arraignments
+arraigns
+arrange
+arranged
+arrangement
+arrangements
+arranger
+arrangers
+arranges
+arranging
+arrant
+array
+arrayed
+arrays
+arrears
+arrest
+arrested
+arrester
+arresters
+arresting
+arrestingly
+arrestor
+arrestors
+arrests
+Arrhenius
+arrival
+arrivals
+arrive
+arrived
+arrives
+arriving
+arrogance
+arrogant
+arrogantly
+arrogate
+arrogated
+arrogates
+arrogating
+arrogation
+arrow
+arrowed
+arrowhead
+arrowheads
+arrows
+arroyo
+arroyos
+arsenal
+arsenals
+arsenic
+arsine
+arson
+art
+Artemia
+Artemis
+arterial
+arteries
+arteriolar
+arteriole
+arterioles
+arteriosclerosis
+artery
+artful
+artfully
+artfulness
+arthritis
+arthropod
+arthropods
+Arthur
+artichoke
+artichokes
+article
+articles
+articulate
+articulated
+articulately
+articulateness
+articulates
+articulating
+articulation
+articulations
+articulator
+articulators
+articulatory
+Artie
+artifact
+artifacts
+artifice
+artificer
+artifices
+artificial
+artificialities
+artificiality
+artificially
+artificialness
+artillerist
+artillery
+artisan
+artisans
+artist
+artistic
+artistically
+artistry
+artists
+artless
+arts
+Arturo
+artwork
+Aruba
+Aryan
+Aryans
+as
+asbestos
+ascend
+ascendancy
+ascendant
+ascended
+ascendency
+ascendent
+ascender
+ascenders
+ascending
+ascends
+ascension
+ascensions
+ascent
+ascertain
+ascertainable
+ascertained
+ascertaining
+ascertains
+ascetic
+asceticism
+ascetics
+ASCII
+ascot
+ascribable
+ascribe
+ascribed
+ascribes
+ascribing
+ascription
+aseptic
+ash
+ashamed
+ashamedly
+ashen
+Asher
+ashes
+Asheville
+Ashland
+Ashley
+ashman
+Ashmolean
+ashore
+ashtray
+ashtrays
+Asia
+Asian
+Asians
+Asiatic
+Asiaticization
+Asiaticizations
+Asiaticize
+Asiaticizes
+Asiatics
+aside
+Asilomar
+asinine
+ask
+askance
+asked
+asker
+askers
+askew
+asking
+asks
+asleep
+asocial
+asp
+asparagus
+aspect
+aspects
+aspen
+aspersion
+aspersions
+asphalt
+asphyxia
+aspic
+aspirant
+aspirants
+aspirate
+aspirated
+aspirates
+aspirating
+aspiration
+aspirations
+aspirator
+aspirators
+aspire
+aspired
+aspires
+aspirin
+aspiring
+aspirins
+ass
+assail
+assailant
+assailants
+assailed
+assailing
+assails
+Assam
+assassin
+assassinate
+assassinated
+assassinates
+assassinating
+assassination
+assassinations
+assassins
+assault
+assaulted
+assaulting
+assaults
+assay
+assayed
+assaying
+assemblage
+assemblages
+assemble
+assembled
+assembler
+assemblers
+assembles
+assemblies
+assembling
+assembly
+assent
+assented
+assenter
+assenting
+assents
+assert
+asserted
+asserter
+asserters
+asserting
+assertion
+assertions
+assertive
+assertively
+assertiveness
+asserts
+asses
+assess
+assessed
+assesses
+assessing
+assessment
+assessments
+assessor
+assessors
+asset
+assets
+assiduity
+assiduous
+assiduously
+assign
+assignable
+assigned
+assignee
+assignees
+assigner
+assigners
+assigning
+assignment
+assignments
+assigns
+assimilate
+assimilated
+assimilates
+assimilating
+assimilation
+assimilations
+assist
+assistance
+assistances
+assistant
+assistants
+assistantship
+assistantships
+assisted
+assisting
+assists
+associate
+associated
+associates
+associating
+association
+associational
+associations
+associative
+associatively
+associativity
+associator
+associators
+assonance
+assonant
+assort
+assorted
+assortment
+assortments
+assorts
+assuage
+assuaged
+assuages
+assume
+assumed
+assumes
+assuming
+assumption
+assumptions
+assurance
+assurances
+assure
+assured
+assuredly
+assurer
+assurers
+assures
+assuring
+assuringly
+Assyria
+Assyrian
+Assyrianize
+Assyrianizes
+Assyriology
+Astaire
+Astaires
+Astarte
+astatine
+aster
+asterisk
+asterisks
+asteroid
+asteroidal
+asteroids
+asters
+asthma
+Aston
+astonish
+astonished
+astonishes
+astonishing
+astonishingly
+astonishment
+Astor
+Astoria
+astound
+astounded
+astounding
+astounds
+astral
+astray
+astride
+astringency
+astringent
+astrology
+astronaut
+astronautics
+astronauts
+astronomer
+astronomers
+astronomical
+astronomically
+astronomy
+astrophysical
+astrophysics
+astute
+astutely
+astuteness
+Asuncion
+asunder
+asylum
+asymmetric
+asymmetrically
+asymmetry
+asymptomatically
+asymptote
+asymptotes
+asymptotic
+asymptotically
+asynchronism
+asynchronous
+asynchronously
+asynchrony
+at
+Atalanta
+Atari
+atavistic
+Atchison
+ate
+atemporal
+Athabascan
+atheism
+atheist
+atheistic
+atheists
+Athena
+Athenian
+Athenians
+Athens
+atherosclerosis
+athlete
+athletes
+athletic
+athleticism
+athletics
+Atkins
+Atkinson
+Atlanta
+Atlantic
+Atlantica
+Atlantis
+atlas
+atmosphere
+atmospheres
+atmospheric
+atoll
+atolls
+atom
+atomic
+atomically
+atomics
+atomization
+atomize
+atomized
+atomizes
+atomizing
+atoms
+atonal
+atonally
+atone
+atoned
+atonement
+atones
+atop
+Atreus
+atrocious
+atrociously
+atrocities
+atrocity
+atrophic
+atrophied
+atrophies
+atrophy
+atrophying
+Atropos
+attach
+attache
+attached
+attacher
+attachers
+attaches
+attaching
+attachment
+attachments
+attack
+attackable
+attacked
+attacker
+attackers
+attacking
+attacks
+attain
+attainable
+attainably
+attained
+attainer
+attainers
+attaining
+attainment
+attainments
+attains
+attempt
+attempted
+attempter
+attempters
+attempting
+attempts
+attend
+attendance
+attendances
+attendant
+attendants
+attended
+attendee
+attendees
+attender
+attenders
+attending
+attends
+attention
+attentional
+attentionality
+attentions
+attentive
+attentively
+attentiveness
+attenuate
+attenuated
+attenuates
+attenuating
+attenuation
+attenuator
+attenuators
+attest
+attested
+attesting
+attests
+attic
+Attica
+attics
+attire
+attired
+attires
+attiring
+attitude
+attitudes
+attitudinal
+Attlee
+attorney
+attorneys
+attract
+attracted
+attracting
+attraction
+attractions
+attractive
+attractively
+attractiveness
+attractor
+attractors
+attracts
+attributable
+attribute
+attributed
+attributes
+attributing
+attribution
+attributions
+attributive
+attributively
+attrition
+attune
+attuned
+attunes
+attuning
+Atwater
+Atwood
+atypical
+atypically
+Auberge
+Aubrey
+auburn
+Auckland
+auction
+auctioneer
+auctioneers
+audacious
+audaciously
+audaciousness
+audacity
+audible
+audibly
+audience
+audiences
+audio
+audiogram
+audiograms
+audiological
+audiologist
+audiologists
+audiology
+audiometer
+audiometers
+audiometric
+audiometry
+audit
+audited
+auditing
+audition
+auditioned
+auditioning
+auditions
+auditor
+auditorium
+auditors
+auditory
+audits
+Audrey
+Audubon
+Auerbach
+Augean
+auger
+augers
+aught
+augment
+augmentation
+augmented
+augmenting
+augments
+augur
+augurs
+august
+Augusta
+Augustan
+Augustine
+augustly
+augustness
+Augustus
+aunt
+aunts
+aura
+aural
+aurally
+auras
+Aurelius
+aureole
+aureomycin
+Auriga
+aurora
+Auschwitz
+auscultate
+auscultated
+auscultates
+auscultating
+auscultation
+auscultations
+auspice
+auspices
+auspicious
+auspiciously
+austere
+austerely
+austerity
+Austin
+Australia
+Australian
+Australianize
+Australianizes
+Australis
+Austria
+Austrian
+Austrianize
+Austrianizes
+authentic
+authentically
+authenticate
+authenticated
+authenticates
+authenticating
+authentication
+authentications
+authenticator
+authenticators
+authenticity
+author
+authored
+authoring
+authoritarian
+authoritarianism
+authoritative
+authoritatively
+authorities
+authority
+authorization
+authorizations
+authorize
+authorized
+authorizer
+authorizers
+authorizes
+authorizing
+authors
+authorship
+autism
+autistic
+auto
+autobiographic
+autobiographical
+autobiographies
+autobiography
+autocollimator
+autocorrelate
+autocorrelation
+autocracies
+autocracy
+autocrat
+autocratic
+autocratically
+autocrats
+autodecrement
+autodecremented
+autodecrements
+autodialer
+autofluorescence
+autograph
+autographed
+autographing
+autographs
+autoincrement
+autoincremented
+autoincrements
+autoindex
+autoindexing
+automata
+automate
+automated
+automates
+automatic
+automatically
+automating
+automation
+automaton
+automobile
+automobiles
+automotive
+autonavigator
+autonavigators
+autonomic
+autonomous
+autonomously
+autonomy
+autopilot
+autopilots
+autopsied
+autopsies
+autopsy
+autoregressive
+autos
+autosuggestibility
+autotransformer
+autumn
+autumnal
+autumns
+auxiliaries
+auxiliary
+avail
+availabilities
+availability
+available
+availably
+availed
+availer
+availers
+availing
+avails
+avalanche
+avalanched
+avalanches
+avalanching
+avant
+avarice
+avaricious
+avariciously
+avenge
+avenged
+avenger
+avenges
+avenging
+Aventine
+Aventino
+avenue
+avenues
+aver
+average
+averaged
+averages
+averaging
+Avernus
+averred
+averrer
+averring
+avers
+averse
+aversion
+aversions
+avert
+averted
+averting
+averts
+Avery
+Avesta
+avian
+aviaries
+aviary
+aviation
+aviator
+aviators
+avid
+avidity
+avidly
+Avignon
+avionic
+avionics
+Avis
+Aviv
+avocado
+avocados
+avocation
+avocations
+Avogadro
+avoid
+avoidable
+avoidably
+avoidance
+avoided
+avoider
+avoiders
+avoiding
+avoids
+Avon
+avouch
+avow
+avowal
+avowed
+avows
+await
+awaited
+awaiting
+awaits
+awake
+awaken
+awakened
+awakening
+awakens
+awakes
+awaking
+award
+awarded
+awarder
+awarders
+awarding
+awards
+aware
+awareness
+awash
+away
+awe
+awed
+awesome
+awful
+awfully
+awfulness
+awhile
+awkward
+awkwardly
+awkwardness
+awl
+awls
+awning
+awnings
+awoke
+awry
+ax
+axed
+Axel
+axer
+axers
+axes
+axial
+axially
+axing
+axiological
+axiom
+axiomatic
+axiomatically
+axiomatization
+axiomatizations
+axiomatize
+axiomatized
+axiomatizes
+axiomatizing
+axioms
+axis
+axle
+axles
+axolotl
+axolotls
+axon
+axons
+aye
+Ayers
+ayes
+Aylesbury
+azalea
+azaleas
+Azerbaijan
+azimuth
+azimuths
+Azores
+Aztec
+Aztecan
+azure
+Babbage
+babble
+babbled
+babbles
+babbling
+Babcock
+babe
+Babel
+Babelize
+Babelizes
+babes
+babied
+babies
+Babka
+baboon
+baboons
+Babul
+baby
+babyhood
+babying
+babyish
+Babylon
+Babylonian
+Babylonians
+Babylonize
+Babylonizes
+babysit
+babysitting
+baccalaureate
+Bacchus
+Bach
+bachelor
+bachelors
+bacilli
+bacillus
+back
+backache
+backaches
+backarrow
+backbend
+backbends
+backboard
+backbone
+backbones
+backdrop
+backdrops
+backed
+backer
+backers
+backfill
+backfiring
+background
+backgrounds
+backhand
+backing
+backlash
+backlog
+backlogged
+backlogs
+backorder
+backpack
+backpacks
+backplane
+backplanes
+backplate
+backs
+backscatter
+backscattered
+backscattering
+backscatters
+backside
+backslash
+backslashes
+backspace
+backspaced
+backspaces
+backspacing
+backstage
+backstairs
+backstitch
+backstitched
+backstitches
+backstitching
+backstop
+backtrack
+backtracked
+backtracker
+backtrackers
+backtracking
+backtracks
+backup
+backups
+Backus
+backward
+backwardness
+backwards
+backwater
+backwaters
+backwoods
+backyard
+backyards
+bacon
+bacteria
+bacterial
+bacterium
+bad
+bade
+Baden
+badge
+badger
+badgered
+badgering
+badgers
+badges
+badlands
+badly
+badminton
+badness
+Baffin
+baffle
+baffled
+baffler
+bafflers
+baffling
+bag
+bagatelle
+bagatelles
+bagel
+bagels
+baggage
+bagged
+bagger
+baggers
+bagging
+baggy
+Baghdad
+Bagley
+bagpipe
+bagpipes
+Bagrodia
+Bagrodias
+bags
+bah
+Bahama
+Bahamas
+Bahrein
+bail
+Bailey
+Baileys
+bailiff
+bailiffs
+bailing
+Baird
+Bairdi
+Bairn
+bait
+baited
+baiter
+baiting
+baits
+Baja
+bake
+baked
+Bakelite
+baker
+bakeries
+bakers
+Bakersfield
+bakery
+bakes
+Bakhtiari
+baking
+baklava
+Baku
+balalaika
+balalaikas
+balance
+balanced
+balancer
+balancers
+balances
+balancing
+Balboa
+balconies
+balcony
+bald
+balding
+baldly
+baldness
+Baldwin
+bale
+baleful
+baler
+bales
+Balfour
+Bali
+Balinese
+balk
+Balkan
+Balkanization
+Balkanizations
+Balkanize
+balkanized
+Balkanizes
+balkanizing
+Balkans
+balked
+balkiness
+balking
+balks
+balky
+ball
+ballad
+ballads
+Ballard
+Ballards
+ballast
+ballasts
+balled
+baller
+ballerina
+ballerinas
+ballers
+ballet
+ballets
+ballgown
+balling
+ballistic
+ballistics
+balloon
+ballooned
+ballooner
+ballooners
+ballooning
+balloons
+ballot
+ballots
+ballpark
+ballparks
+ballplayer
+ballplayers
+ballroom
+ballrooms
+balls
+ballyhoo
+balm
+balms
+balmy
+balsa
+balsam
+Baltic
+Baltimore
+Baltimorean
+balustrade
+balustrades
+Balzac
+Bamako
+Bamberger
+Bambi
+bamboo
+ban
+Banach
+banal
+banally
+banana
+bananas
+Banbury
+Bancroft
+band
+bandage
+bandaged
+bandages
+bandaging
+banded
+bandied
+bandies
+banding
+bandit
+bandits
+bandpass
+bands
+bandstand
+bandstands
+bandwagon
+bandwagons
+bandwidth
+bandwidths
+bandy
+bandying
+bane
+baneful
+bang
+banged
+banging
+Bangladesh
+bangle
+bangles
+Bangor
+bangs
+Bangui
+banish
+banished
+banishes
+banishing
+banishment
+banister
+banisters
+banjo
+banjos
+bank
+banked
+banker
+bankers
+banking
+bankrupt
+bankruptcies
+bankruptcy
+bankrupted
+bankrupting
+bankrupts
+Banks
+banned
+banner
+banners
+banning
+banquet
+banqueting
+banquetings
+banquets
+bans
+banshee
+banshees
+bantam
+banter
+bantered
+bantering
+banters
+Bantu
+Bantus
+baptism
+baptismal
+baptisms
+Baptist
+Baptiste
+baptistery
+baptistries
+baptistry
+Baptists
+baptize
+baptized
+baptizes
+baptizing
+bar
+barb
+Barbados
+Barbara
+barbarian
+barbarians
+barbaric
+barbarism
+barbarities
+barbarity
+barbarous
+barbarously
+barbecue
+barbecued
+barbecues
+barbed
+barbell
+barbells
+barber
+barbital
+barbiturate
+barbiturates
+Barbour
+barbs
+Barcelona
+Barclay
+bard
+bards
+bare
+bared
+barefaced
+barefoot
+barefooted
+barely
+bareness
+barer
+bares
+barest
+barflies
+barfly
+bargain
+bargained
+bargaining
+bargains
+barge
+barges
+barging
+Barhop
+baring
+baritone
+baritones
+barium
+bark
+barked
+barker
+barkers
+barking
+barks
+barley
+Barlow
+barn
+Barnabas
+Barnard
+Barnes
+Barnet
+Barnett
+Barney
+Barnhard
+barns
+barnstorm
+barnstormed
+barnstorming
+barnstorms
+Barnum
+barnyard
+barnyards
+barometer
+barometers
+barometric
+baron
+baroness
+baronial
+baronies
+barons
+barony
+baroque
+baroqueness
+Barr
+barrack
+barracks
+barrage
+barrages
+barred
+barrel
+barrelled
+barrelling
+barrels
+barren
+barrenness
+Barrett
+barricade
+barricades
+barrier
+barriers
+barring
+barringer
+Barrington
+Barron
+barrow
+Barry
+Barrymore
+Barrymores
+bars
+Barstow
+Bart
+bartender
+bartenders
+barter
+bartered
+bartering
+barters
+Barth
+Bartholomew
+Bartlett
+Bartok
+Barton
+basal
+basalt
+Bascom
+base
+baseball
+baseballs
+baseband
+baseboard
+baseboards
+based
+Basel
+baseless
+baseline
+baselines
+basely
+baseman
+basement
+basements
+baseness
+baser
+bases
+bash
+bashed
+bashes
+bashful
+bashfulness
+bashing
+BASIC
+Basic
+basic
+basically
+basics
+Basie
+basil
+basin
+basing
+basins
+basis
+bask
+basked
+basket
+basketball
+basketballs
+baskets
+basking
+Basque
+bass
+basses
+basset
+Bassett
+bassinet
+bassinets
+bastard
+bastards
+baste
+basted
+bastes
+basting
+bastion
+bastions
+bat
+Batavia
+batch
+batched
+Batchelder
+batches
+Bateman
+Bates
+bath
+bathe
+bathed
+bather
+bathers
+bathes
+bathing
+bathos
+bathrobe
+bathrobes
+bathroom
+bathrooms
+baths
+bathtub
+bathtubs
+Bathurst
+Batista
+baton
+batons
+Bator
+bats
+battalion
+battalions
+batted
+Battelle
+batten
+battens
+batter
+battered
+batteries
+battering
+batters
+battery
+batting
+battle
+battled
+battlefield
+battlefields
+battlefront
+battlefronts
+battleground
+battlegrounds
+battlement
+battlements
+battler
+battlers
+battles
+battleship
+battleships
+battling
+bauble
+baubles
+baud
+Baudelaire
+Bauer
+Bauhaus
+Bausch
+bauxite
+Bavaria
+Bavarian
+bawdy
+bawl
+bawled
+bawling
+bawls
+Baxter
+bay
+Bayda
+bayed
+Bayes
+Bayesian
+baying
+Baylor
+bayonet
+bayonets
+Bayonne
+bayou
+bayous
+Bayport
+Bayreuth
+bays
+bazaar
+bazaars
+be
+beach
+beached
+beaches
+beachhead
+beachheads
+beaching
+beacon
+beacons
+bead
+beaded
+beading
+beadle
+beadles
+beads
+beady
+beagle
+beagles
+beak
+beaked
+beaker
+beakers
+beaks
+beam
+beamed
+beamer
+beamers
+beaming
+beams
+bean
+beanbag
+beaned
+beaner
+beaners
+beaning
+beans
+bear
+bearable
+bearably
+beard
+bearded
+beardless
+beards
+Beardsley
+bearer
+bearers
+bearing
+bearings
+bearish
+bears
+beast
+beastly
+beasts
+beat
+beatable
+beatably
+beaten
+beater
+beaters
+beatific
+beatification
+beatify
+beating
+beatings
+beatitude
+beatitudes
+beatnik
+beatniks
+Beatrice
+beats
+beau
+Beauchamps
+Beaujolais
+Beaumont
+Beauregard
+beaus
+beauteous
+beauteously
+beauties
+beautifications
+beautified
+beautifier
+beautifiers
+beautifies
+beautiful
+beautifully
+beautify
+beautifying
+beauty
+beaver
+beavers
+Beaverton
+becalm
+becalmed
+becalming
+becalms
+became
+because
+Bechtel
+beck
+Becker
+Beckman
+beckon
+beckoned
+beckoning
+beckons
+Becky
+become
+becomes
+becoming
+becomingly
+bed
+bedazzle
+bedazzled
+bedazzlement
+bedazzles
+bedazzling
+bedbug
+bedbugs
+bedded
+bedder
+bedders
+bedding
+bedevil
+bedeviled
+bedeviling
+bedevils
+bedfast
+Bedford
+bedlam
+bedpost
+bedposts
+bedraggle
+bedraggled
+bedridden
+bedrock
+bedroom
+bedrooms
+beds
+bedside
+bedspread
+bedspreads
+bedspring
+bedsprings
+bedstead
+bedsteads
+bedtime
+bee
+Beebe
+beech
+Beecham
+beechen
+beecher
+beef
+beefed
+beefer
+beefers
+beefing
+beefs
+beefsteak
+beefy
+beehive
+beehives
+been
+beep
+beeps
+beer
+beers
+bees
+beet
+Beethoven
+beetle
+beetled
+beetles
+beetling
+beets
+befall
+befallen
+befalling
+befalls
+befell
+befit
+befits
+befitted
+befitting
+befog
+befogged
+befogging
+before
+beforehand
+befoul
+befouled
+befouling
+befouls
+befriend
+befriended
+befriending
+befriends
+befuddle
+befuddled
+befuddles
+befuddling
+beg
+began
+beget
+begets
+begetting
+beggar
+beggarly
+beggars
+beggary
+begged
+begging
+begin
+beginner
+beginners
+beginning
+beginnings
+begins
+begot
+begotten
+begrudge
+begrudged
+begrudges
+begrudging
+begrudgingly
+begs
+beguile
+beguiled
+beguiles
+beguiling
+begun
+behalf
+behave
+behaved
+behaves
+behaving
+behavior
+behavioral
+behaviorally
+behaviorism
+behavioristic
+behaviors
+behead
+beheading
+beheld
+behemoth
+behemoths
+behest
+behind
+behold
+beholden
+beholder
+beholders
+beholding
+beholds
+behoove
+behooves
+beige
+Beijing
+being
+beings
+Beirut
+Bela
+belabor
+belabored
+belaboring
+belabors
+belated
+belatedly
+belay
+belayed
+belaying
+belays
+belch
+belched
+belches
+belching
+Belfast
+belfries
+belfry
+Belgian
+Belgians
+Belgium
+Belgrade
+belie
+belied
+belief
+beliefs
+belies
+believable
+believably
+believe
+believed
+believer
+believers
+believes
+believing
+belittle
+belittled
+belittles
+belittling
+Belize
+bell
+Bella
+Bellamy
+Bellatrix
+bellboy
+bellboys
+belle
+belles
+Belleville
+bellhop
+bellhops
+bellicose
+bellicosity
+bellies
+belligerence
+belligerent
+belligerently
+belligerents
+Bellingham
+Bellini
+bellman
+bellmen
+Bellovin
+bellow
+bellowed
+bellowing
+bellows
+bells
+bellum
+bellwether
+bellwethers
+Bellwood
+belly
+bellyache
+bellyfull
+Belmont
+Beloit
+belong
+belonged
+belonging
+belongings
+belongs
+beloved
+below
+Belshazzar
+belt
+belted
+belting
+Belton
+belts
+Beltsville
+Belushi
+bely
+belying
+bemoan
+bemoaned
+bemoaning
+bemoans
+Ben
+Benares
+bench
+benched
+benches
+benchmark
+benchmarking
+benchmarks
+bend
+bendable
+Bender
+benders
+bending
+Bendix
+bends
+beneath
+Benedict
+Benedictine
+benediction
+benedictions
+Benedikt
+benefactor
+benefactors
+beneficence
+beneficences
+beneficent
+beneficial
+beneficially
+beneficiaries
+beneficiary
+benefit
+benefited
+benefiting
+benefits
+benefitted
+benefitting
+Benelux
+benevolence
+benevolent
+Bengal
+Bengali
+benighted
+benign
+benignly
+Benjamin
+Bennett
+Bennington
+Benny
+Benson
+bent
+Bentham
+Bentley
+Bentleys
+Benton
+Benz
+Benzedrine
+benzene
+Beograd
+Beowulf
+bequeath
+bequeathal
+bequeathed
+bequeathing
+bequeaths
+bequest
+bequests
+berate
+berated
+berates
+berating
+Berea
+bereave
+bereaved
+bereavement
+bereavements
+bereaves
+bereaving
+bereft
+Berenices
+Beresford
+beret
+berets
+Bergen
+Bergland
+Berglund
+Bergman
+Bergson
+Bergsten
+Bergstrom
+beribboned
+beriberi
+Beringer
+Berkeley
+berkelium
+Berkowitz
+Berkshire
+Berkshires
+Berlin
+Berliner
+Berliners
+Berlinize
+Berlinizes
+Berlioz
+Berlitz
+Berman
+Bermuda
+Bern
+Bernadine
+Bernard
+Bernardine
+Bernardino
+Bernardo
+berne
+Bernet
+Bernhard
+Bernice
+Bernie
+Berniece
+Bernini
+Bernoulli
+Bernstein
+Berra
+berries
+berry
+berserk
+Bert
+berth
+Bertha
+berths
+Bertie
+Bertram
+Bertrand
+Berwick
+beryl
+beryllium
+beseech
+beseeches
+beseeching
+beset
+besets
+besetting
+beside
+besides
+besiege
+besieged
+besieger
+besiegers
+besieging
+besmirch
+besmirched
+besmirches
+besmirching
+besotted
+besotter
+besotting
+besought
+bespeak
+bespeaks
+bespectacled
+bespoke
+Bess
+Bessel
+Bessemer
+Bessemerize
+Bessemerizes
+Bessie
+best
+bested
+bestial
+besting
+bestir
+bestirring
+bestow
+bestowal
+bestowed
+bests
+bestseller
+bestsellers
+bestselling
+bet
+beta
+betatron
+betel
+Betelgeuse
+Bethesda
+Bethlehem
+betide
+betray
+betrayal
+betrayed
+betrayer
+betraying
+betrays
+betroth
+betrothal
+betrothed
+bets
+Betsey
+Betsy
+Bette
+better
+bettered
+bettering
+betterment
+betterments
+betters
+Betties
+betting
+Betty
+between
+betwixt
+bevel
+beveled
+beveling
+bevels
+beverage
+beverages
+Beverly
+bevy
+bewail
+bewailed
+bewailing
+bewails
+beware
+bewhiskered
+bewilder
+bewildered
+bewildering
+bewilderingly
+bewilderment
+bewilders
+bewitch
+bewitched
+bewitches
+bewitching
+beyond
+Bhagavad-Gita
+Bhutan
+Bialystok
+Bianco
+biannual
+bias
+biased
+biases
+biasing
+bib
+bibbed
+bibbing
+Bible
+bibles
+biblical
+biblically
+bibliographic
+bibliographical
+bibliographies
+bibliography
+bibliophile
+bibs
+bicameral
+bicarbonate
+bicentennial
+bicep
+biceps
+bicker
+bickered
+bickering
+bickers
+biconcave
+biconnected
+biconvex
+bicycle
+bicycled
+bicycler
+bicyclers
+bicycles
+bicycling
+bid
+biddable
+bidden
+bidder
+bidders
+biddies
+bidding
+Biddle
+biddy
+bide
+bidirectional
+bids
+Bien
+biennial
+biennium
+Bienville
+bier
+Bierce
+bifocal
+bifocals
+bifurcate
+big
+Bigelow
+bigger
+biggest
+Biggs
+bight
+bights
+bigness
+bigot
+bigoted
+bigotry
+bigots
+biharmonic
+bijection
+bijections
+bijective
+bijectively
+bike
+bikes
+biking
+bikini
+bikinis
+bilabial
+bilateral
+bilaterally
+Bilbao
+Bilbo
+bile
+bilge
+bilges
+bilinear
+bilingual
+bilk
+bilked
+bilking
+bilks
+bill
+billboard
+billboards
+billed
+biller
+billers
+billet
+billeted
+billeting
+billets
+billiard
+billiards
+Billie
+Billiken
+Billikens
+billing
+Billings
+billion
+billions
+billionth
+billow
+billowed
+billows
+bills
+Biltmore
+bimetallic
+bimetallism
+Bimini
+bimodal
+bimolecular
+bimonthlies
+bimonthly
+bin
+binaries
+binary
+binaural
+bind
+binder
+binders
+binding
+bindings
+binds
+bing
+binge
+binges
+Bingham
+Binghamton
+bingo
+Bini
+binocular
+binoculars
+binomial
+bins
+binuclear
+biochemical
+biochemist
+biochemistry
+biofeedback
+biographer
+biographers
+biographic
+biographical
+biographically
+biographies
+biography
+biological
+biologically
+biologist
+biologists
+biology
+biomedical
+biomedicine
+biophysical
+biophysicist
+biophysics
+biopsies
+biopsy
+bioscience
+biosphere
+biostatistic
+biosynthesize
+biota
+biotic
+bipartisan
+bipartite
+biped
+bipeds
+biplane
+biplanes
+bipolar
+biracial
+birch
+birchen
+birches
+bird
+birdbath
+birdbaths
+birdie
+birdied
+birdies
+birdlike
+birds
+birefringence
+birefringent
+Birgit
+Birmingham
+Birminghamize
+Birminghamizes
+birth
+birthday
+birthdays
+birthed
+birthplace
+birthplaces
+birthright
+birthrights
+births
+Biscayne
+biscuit
+biscuits
+bisect
+bisected
+bisecting
+bisection
+bisections
+bisector
+bisectors
+bisects
+bishop
+bishops
+Bismarck
+Bismark
+bismuth
+bison
+bisons
+bisque
+bisques
+Bissau
+bistable
+bistate
+bit
+bitch
+bitches
+bite
+biter
+biters
+bites
+biting
+bitingly
+bitmap
+BITNET
+bits
+bitten
+bitter
+bitterer
+bitterest
+bitterly
+bitterness
+bitternut
+bitterroot
+bitters
+bittersweet
+bitumen
+bituminous
+bitwise
+bivalve
+bivalves
+bivariate
+bivouac
+bivouacs
+biweekly
+bizarre
+Bizet
+blab
+blabbed
+blabbermouth
+blabbermouths
+blabbing
+blabs
+black
+blackberries
+blackberry
+blackbird
+blackbirds
+blackboard
+blackboards
+Blackburn
+blacked
+blacken
+blackened
+blackening
+blackens
+blacker
+blackest
+Blackfeet
+Blackfoot
+Blackfoots
+blacking
+blackjack
+blackjacks
+blacklist
+blacklisted
+blacklisting
+blacklists
+blackly
+blackmail
+blackmailed
+blackmailer
+blackmailers
+blackmailing
+blackmails
+Blackman
+Blackmer
+blackness
+blackout
+blackouts
+blacks
+blacksmith
+blacksmiths
+Blackstone
+Blackwell
+Blackwells
+bladder
+bladders
+blade
+blades
+Blaine
+Blair
+Blake
+Blakey
+blamable
+blame
+blamed
+blameless
+blamelessness
+blamer
+blamers
+blames
+blameworthy
+blaming
+blanch
+Blanchard
+Blanche
+blanched
+blanches
+blanching
+bland
+blandly
+blandness
+blank
+blanked
+blanker
+blankest
+blanket
+blanketed
+blanketer
+blanketers
+blanketing
+blankets
+blanking
+blankly
+blankness
+blanks
+Blanton
+blare
+blared
+blares
+blaring
+blase
+blaspheme
+blasphemed
+blasphemes
+blasphemies
+blaspheming
+blasphemous
+blasphemously
+blasphemousness
+blasphemy
+blast
+blasted
+blaster
+blasters
+blasting
+blasts
+blatant
+blatantly
+Blatz
+blaze
+blazed
+blazer
+blazers
+blazes
+blazing
+bleach
+bleached
+bleacher
+bleachers
+bleaches
+bleaching
+bleak
+bleaker
+bleakly
+bleakness
+blear
+bleary
+bleat
+bleating
+bleats
+bled
+bleed
+bleeder
+bleeding
+bleedings
+bleeds
+Bleeker
+blemish
+blemishes
+blend
+blended
+blender
+blending
+blends
+Blenheim
+bless
+blessed
+blessing
+blessings
+blew
+blight
+blighted
+blimp
+blimps
+blind
+blinded
+blinder
+blinders
+blindfold
+blindfolded
+blindfolding
+blindfolds
+blinding
+blindingly
+blindly
+blindness
+blinds
+blink
+blinked
+blinker
+blinkers
+blinking
+blinks
+Blinn
+blip
+blips
+bliss
+blissful
+blissfully
+blister
+blistered
+blistering
+blisters
+blithe
+blithely
+blitz
+blitzes
+blitzkrieg
+blizzard
+blizzards
+bloat
+bloated
+bloater
+bloating
+bloats
+blob
+blobs
+bloc
+Bloch
+block
+blockade
+blockaded
+blockades
+blockading
+blockage
+blockages
+blocked
+blocker
+blockers
+blockhouse
+blockhouses
+blocking
+blocks
+blocs
+bloke
+blokes
+Blomberg
+Blomquist
+blond
+blonde
+blondes
+blonds
+blood
+bloodbath
+blooded
+bloodhound
+bloodhounds
+bloodied
+bloodiest
+bloodless
+bloods
+bloodshed
+bloodshot
+bloodstain
+bloodstained
+bloodstains
+bloodstream
+bloody
+bloom
+bloomed
+bloomers
+Bloomfield
+blooming
+Bloomington
+blooms
+blooper
+blossom
+blossomed
+blossoms
+blot
+blots
+blotted
+blotting
+blouse
+blouses
+blow
+blower
+blowers
+blowfish
+blowing
+blown
+blowout
+blows
+blowup
+blubber
+bludgeon
+bludgeoned
+bludgeoning
+bludgeons
+blue
+blueberries
+blueberry
+bluebird
+bluebirds
+bluebonnet
+bluebonnets
+bluefish
+blueness
+blueprint
+blueprints
+bluer
+blues
+bluest
+bluestocking
+bluff
+bluffing
+bluffs
+bluing
+bluish
+Blum
+Blumenthal
+blunder
+blunderbuss
+blundered
+blundering
+blunderings
+blunders
+blunt
+blunted
+blunter
+bluntest
+blunting
+bluntly
+bluntness
+blunts
+blur
+blurb
+blurred
+blurring
+blurry
+blurs
+blurt
+blurted
+blurting
+blurts
+blush
+blushed
+blushes
+blushing
+bluster
+blustered
+blustering
+blusters
+blustery
+Blythe
+boa
+boar
+board
+boarded
+boarder
+boarders
+boarding
+boardinghouse
+boardinghouses
+boards
+Boarsh
+boast
+boasted
+boaster
+boasters
+boastful
+boastfully
+boasting
+boastings
+boasts
+boat
+boater
+boaters
+boathouse
+boathouses
+boating
+boatload
+boatloads
+boatman
+boatmen
+boats
+boatsman
+boatsmen
+boatswain
+boatswains
+boatyard
+boatyards
+bob
+bobbed
+Bobbie
+bobbin
+bobbing
+bobbins
+Bobbsey
+bobby
+bobolink
+bobolinks
+Bobrow
+bobs
+bobwhite
+bobwhites
+Boca
+bode
+Bodenheim
+bodes
+bodice
+bodied
+bodies
+bodily
+Bodleian
+body
+bodybuilder
+bodybuilders
+bodybuilding
+bodyguard
+bodyguards
+bodyweight
+Boeing
+Boeotia
+Boeotian
+Boer
+Boers
+bog
+Bogart
+Bogartian
+bogeymen
+bogged
+boggle
+boggled
+boggles
+boggling
+Bogota
+bogs
+bogus
+Boheme
+Bohemia
+Bohemian
+Bohemianism
+Bohr
+boil
+boiled
+boiler
+boilerplate
+boilers
+boiling
+boils
+Bois
+Boise
+boisterous
+boisterously
+bold
+bolder
+boldest
+boldface
+boldly
+boldness
+Bolivia
+Bolivian
+boll
+Bologna
+Bolshevik
+Bolsheviks
+Bolshevism
+Bolshevist
+Bolshevistic
+Bolshoi
+bolster
+bolstered
+bolstering
+bolsters
+bolt
+bolted
+bolting
+Bolton
+bolts
+Boltzmann
+bomb
+bombard
+bombarded
+bombarding
+bombardment
+bombards
+bombast
+bombastic
+Bombay
+bombed
+bomber
+bombers
+bombing
+bombings
+bombproof
+bombs
+bonanza
+bonanzas
+Bonaparte
+Bonaventure
+bond
+bondage
+bonded
+bonder
+bonders
+bonding
+bonds
+bondsman
+bondsmen
+bone
+boned
+boner
+boners
+bones
+bonfire
+bonfires
+bong
+Bonham
+Boniface
+boning
+Bonn
+bonnet
+bonneted
+bonnets
+Bonneville
+Bonnie
+bonny
+Bontempo
+bonus
+bonuses
+bony
+boo
+boob
+booboo
+booby
+book
+bookcase
+bookcases
+booked
+booker
+bookers
+bookie
+bookies
+booking
+bookings
+bookish
+bookkeeper
+bookkeepers
+bookkeeping
+booklet
+booklets
+bookmark
+books
+bookseller
+booksellers
+bookshelf
+bookshelves
+bookstore
+bookstores
+bookworm
+boolean
+Booleans
+boom
+boomed
+boomerang
+boomerangs
+booming
+booms
+boon
+Boone
+Boonton
+boor
+boorish
+boors
+boos
+boost
+boosted
+booster
+boosting
+boosts
+boot
+bootable
+booted
+Bootes
+booth
+booths
+booting
+Bootle
+bootleg
+bootlegged
+bootlegger
+bootleggers
+bootlegging
+bootlegs
+boots
+bootstrap
+bootstrapped
+bootstrapping
+bootstraps
+booty
+booze
+borate
+borates
+borax
+Bordeaux
+bordello
+bordellos
+Borden
+border
+bordered
+bordering
+borderings
+borderland
+borderlands
+borderline
+borders
+bore
+Borealis
+Boreas
+bored
+boredom
+borer
+bores
+Borg
+boric
+boring
+Boris
+born
+borne
+Borneo
+boron
+borough
+boroughs
+Borroughs
+borrow
+borrowed
+borrower
+borrowers
+borrowing
+borrows
+Bosch
+Bose
+bosom
+bosoms
+Bosporus
+boss
+bossed
+bosses
+Bostitch
+Boston
+Bostonian
+Bostonians
+bosun
+Boswell
+Boswellize
+Boswellizes
+botanical
+botanist
+botanists
+botany
+botch
+botched
+botcher
+botchers
+botches
+botching
+both
+bother
+bothered
+bothering
+bothers
+bothersome
+Botswana
+bottle
+bottled
+bottleneck
+bottlenecks
+bottler
+bottlers
+bottles
+bottling
+bottom
+bottomed
+bottoming
+bottomless
+bottoms
+botulinus
+botulism
+Boucher
+bouffant
+bough
+boughs
+bought
+boulder
+boulders
+boulevard
+boulevards
+bounce
+bounced
+bouncer
+bounces
+bouncing
+bouncy
+bound
+boundaries
+boundary
+bounded
+bounden
+bounding
+boundless
+boundlessness
+bounds
+bounteous
+bounteously
+bounties
+bountiful
+bounty
+bouquet
+bouquets
+Bourbaki
+bourbon
+bourgeois
+bourgeoisie
+Bourne
+boustrophedon
+boustrophedonic
+bout
+boutique
+bouts
+Bouvier
+bovine
+bovines
+bow
+Bowditch
+bowdlerize
+bowdlerized
+bowdlerizes
+bowdlerizing
+Bowdoin
+bowed
+bowel
+bowels
+Bowen
+bower
+bowers
+Bowes
+bowing
+bowl
+bowled
+bowler
+bowlers
+bowline
+bowlines
+bowling
+bowls
+bowman
+bows
+bowstring
+bowstrings
+box
+boxcar
+boxcars
+boxed
+boxer
+boxers
+boxes
+Boxford
+boxing
+boxtop
+boxtops
+boxwood
+boy
+Boyce
+boycott
+boycotted
+boycotts
+Boyd
+boyfriend
+boyfriends
+boyhood
+boyish
+boyishness
+Boyle
+Boylston
+boys
+bra
+brace
+braced
+bracelet
+bracelets
+braces
+bracing
+bracket
+bracketed
+bracketing
+brackets
+brackish
+Bradbury
+Bradford
+Bradley
+Bradshaw
+Brady
+brae
+braes
+brag
+Bragg
+bragged
+bragger
+bragging
+brags
+Brahmaputra
+Brahms
+Brahmsian
+braid
+braided
+braiding
+braids
+Braille
+brain
+Brainard
+Brainards
+brainchild
+brained
+braining
+brains
+brainstem
+brainstems
+brainstorm
+brainstorms
+brainwash
+brainwashed
+brainwashes
+brainwashing
+brainy
+brake
+braked
+brakeman
+brakes
+braking
+bramble
+brambles
+brambly
+bran
+branch
+branched
+branches
+branching
+branchings
+Branchville
+brand
+branded
+Brandeis
+Brandel
+Brandenburg
+branding
+brandish
+brandishes
+brandishing
+Brandon
+brands
+Brandt
+brandy
+brandywine
+Braniff
+Brannon
+bras
+brash
+brashly
+brashness
+Brasilia
+brass
+brasses
+brassiere
+Brasstown
+brassy
+brat
+brats
+Braun
+bravado
+brave
+braved
+bravely
+braveness
+braver
+bravery
+braves
+bravest
+braving
+bravo
+bravos
+brawl
+brawler
+brawling
+brawn
+bray
+brayed
+brayer
+braying
+brays
+braze
+brazed
+brazen
+brazenly
+brazenness
+brazes
+brazier
+braziers
+Brazil
+Brazilian
+brazing
+Brazzaville
+breach
+breached
+breacher
+breachers
+breaches
+breaching
+bread
+breadboard
+breadboards
+breadbox
+breadboxes
+breaded
+breading
+breads
+breadth
+breadwinner
+breadwinners
+break
+breakable
+breakables
+breakage
+breakaway
+breakdown
+breakdowns
+breaker
+breakers
+breakfast
+breakfasted
+breakfaster
+breakfasters
+breakfasting
+breakfasts
+breaking
+breakpoint
+breakpoints
+breaks
+breakthrough
+breakthroughes
+breakthroughs
+breakup
+breakwater
+breakwaters
+breast
+breasted
+breasts
+breastwork
+breastworks
+breath
+breathable
+breathe
+breathed
+breather
+breathers
+breathes
+breathing
+breathless
+breathlessly
+breaths
+breathtaking
+breathtakingly
+breathy
+bred
+breech
+breeches
+breed
+breeder
+breeding
+breeds
+breeze
+breezes
+breezily
+breezy
+Bremen
+bremsstrahlung
+Brenda
+Brendan
+Brennan
+Brenner
+Brent
+Bresenham
+Brest
+brethren
+Breton
+Bretons
+Brett
+breve
+brevet
+breveted
+breveting
+brevets
+brevity
+brew
+brewed
+brewer
+breweries
+brewers
+brewery
+brewing
+brews
+Brewster
+Brian
+briar
+briars
+bribe
+bribed
+briber
+bribers
+bribery
+bribes
+bribing
+Brice
+brick
+brickbat
+bricked
+bricker
+bricklayer
+bricklayers
+bricklaying
+bricks
+bridal
+bride
+bridegroom
+brides
+bridesmaid
+bridesmaids
+Bridewell
+bridge
+bridgeable
+bridged
+bridgehead
+bridgeheads
+Bridgeport
+bridges
+Bridget
+Bridgetown
+Bridgewater
+bridgework
+bridging
+bridle
+bridled
+bridles
+bridling
+Brie
+brief
+briefcase
+briefcases
+briefed
+briefer
+briefest
+briefing
+briefings
+briefly
+briefness
+briefs
+Brien
+brier
+brig
+brigade
+brigades
+brigadier
+brigadiers
+Brigadoon
+brigantine
+Briggs
+Brigham
+bright
+brighten
+brightened
+brightener
+brighteners
+brightening
+brightens
+brighter
+brightest
+brightly
+brightness
+Brighton
+brigs
+brilliance
+brilliancy
+brilliant
+brilliantly
+Brillouin
+brim
+brimful
+brimmed
+brimming
+brimstone
+Brindisi
+brindle
+brindled
+brine
+bring
+bringer
+bringers
+bringing
+brings
+brink
+Brinkley
+brinkmanship
+briny
+Brisbane
+brisk
+brisker
+briskly
+briskness
+bristle
+bristled
+bristles
+bristling
+Bristol
+Britain
+Britannic
+Britannica
+britches
+British
+Britisher
+Britishly
+Briton
+Britons
+Brittany
+Britten
+brittle
+brittleness
+broach
+broached
+broaches
+broaching
+broad
+broadband
+broadcast
+broadcasted
+broadcaster
+broadcasters
+broadcasting
+broadcastings
+broadcasts
+broaden
+broadened
+broadener
+broadeners
+broadening
+broadenings
+broadens
+broader
+broadest
+broadly
+broadness
+broadside
+Broadway
+brocade
+brocaded
+broccoli
+brochure
+brochures
+Brock
+Broglie
+broil
+broiled
+broiler
+broilers
+broiling
+broils
+broke
+broken
+brokenly
+brokenness
+broker
+brokerage
+brokers
+Bromfield
+bromide
+bromides
+bromine
+Bromley
+bronchi
+bronchial
+bronchiole
+bronchioles
+bronchitis
+bronchus
+Brontosaurus
+Bronx
+bronze
+bronzed
+bronzes
+brooch
+brooches
+brood
+brooder
+brooding
+broods
+brook
+Brookdale
+Brooke
+brooked
+Brookfield
+Brookhaven
+Brookline
+Brooklyn
+Brookmont
+brooks
+broom
+brooms
+broomstick
+broomsticks
+broth
+brothel
+brothels
+brother
+brotherhood
+brotherliness
+brotherly
+brothers
+brought
+brow
+browbeat
+browbeaten
+browbeating
+browbeats
+brown
+Browne
+browned
+Brownell
+browner
+brownest
+Brownian
+brownie
+brownies
+browning
+brownish
+brownness
+browns
+brows
+browse
+browsing
+Bruce
+Bruckner
+Bruegel
+bruise
+bruised
+bruises
+bruising
+Brumidi
+brunch
+brunches
+brunette
+Brunhilde
+Bruno
+Brunswick
+brunt
+brush
+brushed
+brushes
+brushfire
+brushfires
+brushing
+brushlike
+brushy
+brusque
+brusquely
+Brussels
+brutal
+brutalities
+brutality
+brutalize
+brutalized
+brutalizes
+brutalizing
+brutally
+brute
+brutes
+brutish
+Bruxelles
+Bryan
+Bryant
+Bryce
+Bryn
+bubble
+bubbled
+bubbles
+bubbling
+bubbly
+Buchanan
+Bucharest
+Buchenwald
+Buchwald
+buck
+buckboard
+buckboards
+bucked
+bucket
+buckets
+bucking
+buckle
+buckled
+buckler
+buckles
+Buckley
+buckling
+Bucknell
+bucks
+buckshot
+buckskin
+buckskins
+buckwheat
+Bucky
+bucolic
+bud
+Budapest
+Budd
+budded
+Buddha
+Buddhism
+Buddhist
+Buddhists
+buddies
+budding
+buddy
+budge
+budged
+budges
+budget
+budgetary
+budgeted
+budgeter
+budgeters
+budgeting
+budgets
+budging
+buds
+Budweiser
+Budweisers
+Buehring
+Buena
+Buenos
+buff
+buffalo
+buffaloes
+buffer
+buffered
+buffering
+buffers
+buffet
+buffeted
+buffeting
+buffetings
+buffets
+buffoon
+buffoons
+buffs
+bug
+bugaboo
+Bugatti
+bugeyed
+bugged
+bugger
+buggers
+buggies
+bugging
+buggy
+bugle
+bugled
+bugler
+bugles
+bugling
+bugs
+Buick
+build
+builder
+builders
+building
+buildings
+builds
+buildup
+buildups
+built
+builtin
+Bujumbura
+bulb
+Bulba
+bulbs
+Bulgaria
+Bulgarian
+bulge
+bulged
+bulging
+bulk
+bulked
+bulkhead
+bulkheads
+bulks
+bulky
+bull
+bulldog
+bulldogs
+bulldoze
+bulldozed
+bulldozer
+bulldozes
+bulldozing
+bulled
+bullet
+bulletin
+bulletins
+bullets
+bullfrog
+bullied
+bullies
+bulling
+bullion
+bullish
+bullock
+bulls
+bullseye
+bully
+bullying
+bulwark
+bum
+bumble
+bumblebee
+bumblebees
+bumbled
+bumbler
+bumblers
+bumbles
+bumbling
+Bumbry
+bummed
+bumming
+bump
+bumped
+bumper
+bumpers
+bumping
+bumps
+bumptious
+bumptiously
+bumptiousness
+bums
+bun
+bunch
+bunched
+bunches
+bunching
+Bundestag
+bundle
+bundled
+bundles
+bundling
+Bundoora
+Bundy
+bungalow
+bungalows
+bungle
+bungled
+bungler
+bunglers
+bungles
+bungling
+bunion
+bunions
+bunk
+bunker
+bunkered
+bunkers
+bunkhouse
+bunkhouses
+bunkmate
+bunkmates
+bunks
+bunnies
+bunny
+buns
+Bunsen
+bunt
+bunted
+bunter
+bunters
+bunting
+bunts
+Bunyan
+buoy
+buoyancy
+buoyant
+buoyed
+buoys
+Burbank
+Burch
+burden
+burdened
+burdening
+burdens
+burdensome
+bureau
+bureaucracies
+bureaucracy
+bureaucrat
+bureaucratic
+bureaucrats
+bureaus
+burgeon
+burgeoned
+burgeoning
+burgess
+burgesses
+burgher
+burghers
+burglar
+burglaries
+burglarize
+burglarized
+burglarizes
+burglarizing
+burglarproof
+burglarproofed
+burglarproofing
+burglarproofs
+burglars
+burglary
+Burgundian
+Burgundies
+Burgundy
+burial
+buried
+buries
+Burke
+Burkes
+burl
+burlesque
+burlesques
+Burlingame
+Burlington
+burly
+Burma
+Burmese
+burn
+Burne
+burned
+burner
+burners
+Burnes
+Burnett
+Burnham
+burning
+burningly
+burnings
+burnish
+burnished
+burnishes
+burnishing
+burns
+Burnside
+Burnsides
+burnt
+burntly
+burntness
+burp
+burped
+burping
+burps
+Burr
+Burroughs
+burrow
+burrowed
+burrower
+burrowing
+burrows
+burrs
+bursa
+bursar
+bursitis
+burst
+burstiness
+bursting
+bursts
+bursty
+Burt
+Burton
+Burtt
+Burundi
+bury
+burying
+bus
+busboy
+busboys
+Busch
+bused
+buses
+bush
+bushel
+bushels
+bushes
+bushing
+Bushnell
+bushwhack
+bushwhacked
+bushwhacking
+bushwhacks
+bushy
+busied
+busier
+busiest
+busily
+business
+businesses
+businesslike
+businessman
+businessmen
+busing
+buss
+bussed
+busses
+bussing
+bust
+bustard
+bustards
+busted
+buster
+bustle
+bustling
+busts
+busy
+but
+butane
+butcher
+butchered
+butchers
+butchery
+butler
+butlers
+butt
+butte
+butted
+butter
+butterball
+buttercup
+buttered
+butterer
+butterers
+butterfat
+Butterfield
+butterflies
+butterfly
+buttering
+buttermilk
+butternut
+butters
+buttery
+buttes
+butting
+buttock
+buttocks
+button
+buttoned
+buttonhole
+buttonholes
+buttoning
+buttons
+buttress
+buttressed
+buttresses
+buttressing
+Buttrick
+butts
+butyl
+butyrate
+buxom
+Buxtehude
+Buxton
+buy
+buyer
+buyers
+buying
+buys
+buzz
+Buzzard
+buzzards
+buzzed
+buzzer
+buzzes
+buzzing
+buzzword
+buzzwords
+buzzy
+by
+bye
+Byers
+bygone
+bylaw
+bylaws
+byline
+bylines
+bypass
+bypassed
+bypasses
+bypassing
+byproduct
+byproducts
+Byrd
+Byrne
+Byron
+Byronic
+Byronism
+Byronize
+Byronizes
+bystander
+bystanders
+byte
+bytes
+byway
+byways
+byword
+bywords
+Byzantine
+Byzantinize
+Byzantinizes
+Byzantium
+cab
+cabal
+cabana
+cabaret
+cabbage
+cabbages
+cabdriver
+cabin
+cabinet
+cabinets
+cabins
+cable
+cabled
+cables
+cabling
+caboose
+Cabot
+cabs
+cache
+cached
+caches
+caching
+cackle
+cackled
+cackler
+cackles
+cackling
+cacti
+cactus
+cadaver
+cadence
+cadenced
+Cadillac
+Cadillacs
+cadres
+Cady
+Caesar
+Caesarian
+Caesarize
+Caesarizes
+cafe
+cafes
+cafeteria
+caffein
+caffeinated
+caffeine
+cage
+caged
+cager
+cagers
+cages
+caging
+Cahill
+caiman
+Cain
+Caine
+cairn
+Cairo
+cajole
+cajoled
+cajoles
+cajoling
+Cajun
+Cajuns
+cake
+caked
+cakes
+caking
+Calais
+calamities
+calamitous
+calamity
+Calceolaria
+calcify
+calcium
+CALCOMP
+CalComp
+Calcomp
+calculate
+calculated
+calculates
+calculating
+calculation
+calculations
+calculative
+calculator
+calculators
+calculi
+calculus
+Calcutta
+Calder
+caldera
+Caldwell
+Caleb
+calendar
+calendars
+calf
+calfskin
+Calgary
+Calhoun
+caliber
+calibers
+calibrate
+calibrated
+calibrates
+calibrating
+calibration
+calibrations
+calico
+California
+Californian
+Californians
+Caligula
+caliph
+caliphs
+Calkins
+call
+callable
+Callaghan
+Callahan
+Callan
+called
+caller
+callers
+calling
+calliope
+Callisto
+callous
+calloused
+callously
+callousness
+calls
+callus
+calm
+calmed
+calmer
+calmest
+calming
+calmingly
+calmly
+calmness
+calms
+caloric
+calorie
+calories
+calorimeter
+calorimetric
+calorimetry
+Caltech
+calumny
+Calvary
+calve
+Calvert
+calves
+Calvin
+Calvinist
+Calvinize
+Calvinizes
+calypso
+cam
+Cambodia
+Cambrian
+Cambridge
+Camden
+came
+camel
+Camelot
+camels
+Camembert
+camera
+cameraman
+cameramen
+cameras
+Cameron
+Cameroon
+Cameroun
+Camilla
+Camille
+Camino
+camouflage
+camouflaged
+camouflages
+camouflaging
+camp
+campaign
+campaigned
+campaigner
+campaigners
+campaigning
+campaigns
+Campbell
+Campbellsport
+camped
+camper
+campers
+campfire
+campground
+camping
+camps
+campsite
+campus
+campuses
+can
+Canaan
+Canada
+Canadian
+Canadianization
+Canadianizations
+Canadianize
+Canadianizes
+Canadians
+canal
+canals
+canaries
+canary
+Canaveral
+Canberra
+cancel
+canceled
+canceling
+cancellation
+cancellations
+cancels
+cancer
+cancerous
+cancers
+Candace
+candid
+candidacy
+candidate
+candidates
+Candide
+candidly
+candidness
+candied
+candies
+candle
+candlelight
+candler
+candles
+candlestick
+candlesticks
+Candlewick
+candor
+candy
+cane
+caner
+Canfield
+canine
+Canis
+canister
+canker
+cankerworm
+cannabis
+canned
+cannel
+canner
+canners
+cannery
+cannibal
+cannibalize
+cannibalized
+cannibalizes
+cannibalizing
+cannibals
+canning
+cannister
+cannisters
+cannon
+cannonball
+cannons
+cannot
+canny
+canoe
+canoes
+Canoga
+canon
+canonic
+canonical
+canonicalization
+canonicalize
+canonicalized
+canonicalizes
+canonicalizing
+canonically
+canonicals
+canons
+Canopus
+canopy
+cans
+cant
+Cantabrigian
+cantaloupe
+cantankerous
+cantankerously
+canteen
+Canterbury
+cantilever
+canto
+canton
+Cantonese
+cantons
+cantor
+cantors
+Canute
+canvas
+canvases
+canvass
+canvassed
+canvasser
+canvassers
+canvasses
+canvassing
+canyon
+canyons
+cap
+capabilities
+capability
+capable
+capably
+capacious
+capaciously
+capaciousness
+capacitance
+capacitances
+capacities
+capacitive
+capacitor
+capacitors
+capacity
+cape
+caper
+capers
+capes
+Capet
+Capetown
+capillary
+Capistrano
+capita
+capital
+capitalism
+capitalist
+capitalists
+capitalization
+capitalizations
+capitalize
+capitalized
+capitalizer
+capitalizers
+capitalizes
+capitalizing
+capitally
+capitals
+Capitan
+capitol
+Capitoline
+capitols
+capped
+capping
+Cappy
+caprice
+capricious
+capriciously
+capriciousness
+Capricorn
+caps
+Capsicum
+capstan
+capstone
+capsule
+captain
+captained
+captaining
+captains
+caption
+captions
+captivate
+captivated
+captivates
+captivating
+captivation
+captive
+captives
+captivity
+captor
+captors
+capture
+captured
+capturer
+capturers
+captures
+capturing
+Caputo
+capybara
+car
+Caracas
+caramel
+caravan
+caravans
+caraway
+carbohydrate
+carbolic
+Carboloy
+carbon
+carbonate
+carbonated
+carbonates
+carbonation
+Carbondale
+Carbone
+Carbones
+carbonic
+carbonization
+carbonize
+carbonized
+carbonizer
+carbonizers
+carbonizes
+carbonizing
+carbons
+carborundum
+carbuncle
+carcass
+carcasses
+carcinogen
+carcinogenic
+carcinoma
+card
+cardboard
+carder
+cardiac
+Cardiff
+cardinal
+cardinalities
+cardinality
+cardinally
+cardinals
+Cardiod
+cardiology
+cardiovascular
+cards
+care
+cared
+careen
+career
+careers
+carefree
+careful
+carefully
+carefulness
+careless
+carelessly
+carelessness
+cares
+caress
+caressed
+caresser
+caresses
+caressing
+caret
+caretaker
+Carey
+Cargill
+cargo
+cargoes
+Carib
+Caribbean
+caribou
+caricature
+caring
+Carl
+Carla
+Carleton
+Carletonian
+Carlin
+Carlisle
+Carlo
+carload
+Carlsbad
+Carlsbads
+Carlson
+Carlton
+Carlyle
+Carmela
+Carmen
+Carmichael
+carnage
+carnal
+carnation
+Carnegie
+carnival
+carnivals
+carnivore
+carnivorous
+carnivorously
+carol
+Carolina
+Carolinas
+Caroline
+Carolingian
+Carolinian
+Carolinians
+carols
+Carolyn
+carp
+Carpathia
+Carpathians
+carpenter
+carpenters
+carpentry
+carpet
+carpeted
+carpeting
+carpets
+carport
+Carr
+Carrara
+carriage
+carriages
+Carrie
+carried
+carrier
+carriers
+carries
+carrion
+Carroll
+carrot
+carrots
+Carruthers
+carry
+carrying
+carryover
+carryovers
+cars
+Carson
+cart
+carted
+cartel
+carter
+carters
+Cartesian
+Carthage
+Carthaginian
+cartilage
+carting
+cartographer
+cartographic
+cartography
+carton
+cartons
+cartoon
+cartoons
+cartridge
+cartridges
+carts
+cartwheel
+Carty
+Caruso
+carve
+carved
+carver
+carves
+carving
+carvings
+Casanova
+cascadable
+cascade
+cascaded
+cascades
+cascading
+case
+cased
+casement
+casements
+cases
+casework
+Casey
+cash
+cashed
+casher
+cashers
+cashes
+cashew
+cashier
+cashiers
+cashing
+cashmere
+casing
+casings
+casino
+cask
+casket
+caskets
+casks
+Caspian
+Cassandra
+casserole
+casseroles
+cassette
+Cassiopeia
+Cassite
+Cassites
+Cassius
+cassock
+cast
+caste
+caster
+casters
+castes
+castigate
+Castillo
+casting
+castle
+castled
+castles
+castor
+Castro
+Castroism
+casts
+casual
+casually
+casualness
+casuals
+casualties
+casualty
+cat
+cataclysmic
+Catalan
+Catalina
+catalog
+cataloged
+cataloger
+cataloging
+catalogs
+Catalonia
+catalyst
+catalysts
+catalytic
+catapult
+cataract
+catastrophe
+catastrophes
+catastrophic
+Catawba
+catch
+catchable
+catcher
+catchers
+catches
+catching
+categorical
+categorically
+categories
+categorization
+categorize
+categorized
+categorizer
+categorizers
+categorizes
+categorizing
+category
+cater
+catered
+caterer
+catering
+caterpillar
+caterpillars
+caters
+cathedral
+cathedrals
+Catherine
+Catherwood
+catheter
+catheters
+cathode
+cathodes
+Catholic
+Catholicism
+Catholicisms
+Catholics
+Cathy
+catlike
+catnip
+cats
+Catskill
+Catskills
+catsup
+cattail
+cattle
+cattleman
+cattlemen
+Caucasian
+Caucasians
+Caucasus
+Cauchy
+caucus
+caught
+cauldron
+cauldrons
+cauliflower
+caulk
+causal
+causality
+causally
+causation
+causations
+cause
+caused
+causer
+causes
+causeway
+causeways
+causing
+caustic
+causticly
+caustics
+caution
+cautioned
+cautioner
+cautioners
+cautioning
+cautionings
+cautions
+cautious
+cautiously
+cautiousness
+cavalier
+cavalierly
+cavalierness
+cavalry
+cave
+caveat
+caveats
+caved
+caveman
+cavemen
+Cavendish
+cavern
+cavernous
+caverns
+caves
+caviar
+cavil
+Caviness
+caving
+cavities
+cavity
+caw
+cawing
+Cayley
+Cayuga
+cease
+ceased
+ceaseless
+ceaselessly
+ceaselessness
+ceases
+ceasing
+Cecil
+Cecilia
+Cecropia
+cedar
+cede
+ceded
+ceding
+Cedric
+ceiling
+ceilings
+Celanese
+Celebes
+celebrate
+celebrated
+celebrates
+celebrating
+celebration
+celebrations
+celebrities
+celebrity
+celerity
+celery
+Celeste
+celestial
+celestially
+Celia
+cell
+cellar
+cellars
+celled
+cellist
+cellists
+cellophane
+cells
+cellular
+cellulose
+Celsius
+Celt
+Celtic
+Celticize
+Celticizes
+cement
+cemented
+cementing
+cements
+cemeteries
+cemetery
+Cenozoic
+censor
+censored
+censoring
+censors
+censorship
+censure
+censured
+censurer
+censures
+census
+censuses
+cent
+centaur
+centenary
+centennial
+center
+centered
+centering
+centerpiece
+centerpieces
+centers
+centigrade
+centimeter
+centimeters
+centipede
+centipedes
+central
+Centralia
+centralism
+centralist
+centralization
+centralize
+centralized
+centralizes
+centralizing
+centrally
+CENTREX
+Centrex
+centrifugal
+centrifuge
+centripetal
+centrist
+centroid
+cents
+centuries
+century
+Cepheus
+ceramic
+Cerberus
+cereal
+cereals
+cerebellum
+cerebral
+ceremonial
+ceremonially
+ceremonialness
+ceremonies
+ceremony
+Ceres
+CERN
+certain
+certainly
+certainties
+certainty
+certifiable
+certificate
+certificates
+certification
+certifications
+certified
+certifier
+certifiers
+certifies
+certify
+certifying
+Cervantes
+Cesare
+cessation
+cessations
+Cessna
+Cetus
+Ceylon
+Cezanne
+Cezannes
+Chablis
+Chablises
+Chad
+Chadwick
+chafe
+chafer
+chaff
+chaffer
+Chaffey
+chaffing
+chafing
+chagrin
+chain
+chained
+chaining
+chains
+chair
+chaired
+chairing
+chairlady
+chairman
+chairmen
+chairperson
+chairpersons
+chairs
+chairwoman
+chairwomen
+chalice
+chalices
+chalk
+chalked
+chalking
+chalks
+challenge
+challenged
+challenger
+challengers
+challenges
+challenging
+Chalmers
+chamber
+chambered
+chamberlain
+chamberlains
+chambermaid
+Chambers
+chameleon
+champagne
+Champaign
+champion
+championed
+championing
+champions
+championship
+championships
+Champlain
+chance
+chanced
+chancellor
+Chancellorsville
+chancery
+chances
+chancing
+chandelier
+chandeliers
+Chandigarh
+Chang
+change
+changeability
+changeable
+changeably
+changed
+changeover
+changer
+changers
+changes
+changing
+channel
+channeled
+channeling
+channelled
+channeller
+channellers
+channelling
+channels
+Channing
+chant
+chanted
+chanter
+chanticleer
+chanticleers
+Chantilly
+chanting
+chants
+Chao
+chaos
+chaotic
+chap
+chapel
+chapels
+chaperon
+chaperone
+chaperoned
+chaplain
+chaplains
+Chaplin
+Chapman
+chaps
+chapter
+chapters
+char
+character
+characteristic
+characteristically
+characteristics
+characterizable
+characterization
+characterizations
+characterize
+characterized
+characterizer
+characterizers
+characterizes
+characterizing
+characters
+charcoal
+charcoaled
+charge
+chargeable
+charged
+charger
+chargers
+charges
+charging
+chariot
+chariots
+charisma
+charismatic
+charitable
+charitableness
+charities
+charity
+Charlemagne
+Charlemagnes
+Charles
+Charleston
+Charley
+Charlie
+Charlotte
+Charlottesville
+charm
+charmed
+charmer
+charmers
+charming
+charmingly
+charms
+Charon
+chars
+chart
+Charta
+chartable
+charted
+charter
+chartered
+chartering
+charters
+charting
+chartings
+Chartres
+chartreuse
+charts
+Charybdis
+chase
+chased
+chaser
+chasers
+chases
+chasing
+chasm
+chasms
+chassis
+chaste
+chastely
+chasteness
+chastise
+chastised
+chastiser
+chastisers
+chastises
+chastising
+chastity
+chat
+chateau
+chateaus
+Chatham
+Chattahoochee
+Chattanooga
+chattel
+chatter
+chattered
+chatterer
+chattering
+chatters
+chatting
+chatty
+Chaucer
+chauffeur
+chauffeured
+Chauncey
+Chautauqua
+cheap
+cheapen
+cheapened
+cheapening
+cheapens
+cheaper
+cheapest
+cheaply
+cheapness
+cheat
+cheated
+cheater
+cheaters
+cheating
+cheats
+check
+checkable
+checkbook
+checkbooks
+checked
+checker
+checkerboard
+checkerboarded
+checkerboarding
+checkers
+checking
+checklist
+checkout
+checkpoint
+checkpoints
+checks
+checksum
+checksummed
+checksumming
+checksums
+checkup
+cheek
+cheekbone
+cheeks
+cheeky
+cheer
+cheered
+cheerer
+cheerful
+cheerfully
+cheerfulness
+cheerily
+cheeriness
+cheering
+cheerleader
+cheerless
+cheerlessly
+cheerlessness
+cheers
+cheery
+cheese
+cheesecloth
+cheeses
+cheesy
+cheetah
+chef
+chefs
+Chekhov
+Chelsea
+chemical
+chemically
+chemicals
+chemise
+chemist
+chemistries
+chemistry
+chemists
+Chen
+Cheney
+Cheng
+cherish
+cherished
+cherishes
+cherishing
+Cheriton
+Cherokee
+Cherokees
+cherries
+cherry
+cherub
+cherubim
+cherubs
+Cheryl
+Chesapeake
+Cheshire
+chess
+chest
+Chester
+Chesterfield
+Chesterton
+chestnut
+chestnuts
+chests
+Chevrolet
+Chevy
+chew
+chewed
+chewer
+chewers
+chewing
+chews
+Cheyenne
+Cheyennes
+Chiang
+chic
+Chicago
+Chicagoan
+Chicagoans
+Chicana
+Chicanas
+chicanery
+Chicano
+Chicanos
+chick
+chickadee
+chickadees
+Chickasaws
+chicken
+chickens
+chicks
+chide
+chided
+chides
+chiding
+chief
+chiefly
+chiefs
+chieftain
+chieftains
+chiffon
+child
+childbirth
+childhood
+childish
+childishly
+childishness
+childlike
+children
+Chile
+Chilean
+Chiles
+chili
+chill
+chilled
+chiller
+chillers
+chillier
+chilliness
+chilling
+chillingly
+chills
+chilly
+chime
+chimera
+chimes
+chimney
+chimneys
+chimpanzee
+chin
+China
+Chinaman
+Chinamen
+Chinas
+Chinatown
+Chinese
+Ching
+chink
+chinked
+chinks
+chinned
+chinner
+chinners
+chinning
+Chinook
+chins
+chintz
+chip
+chipmunk
+chipmunks
+Chippendale
+Chippewa
+chips
+chiropractor
+chirp
+chirped
+chirping
+chirps
+chisel
+chiseled
+chiseler
+chisels
+Chisholm
+chit
+chivalrous
+chivalrously
+chivalrousness
+chivalry
+Chloe
+chlorine
+chloroform
+chlorophyll
+chloroplast
+chloroplasts
+chock
+chocks
+chocolate
+chocolates
+Choctaw
+Choctaws
+choice
+choices
+choicest
+choir
+choirs
+choke
+choked
+choker
+chokers
+chokes
+choking
+cholera
+Chomsky
+choose
+chooser
+choosers
+chooses
+choosing
+chop
+Chopin
+chopped
+chopper
+choppers
+chopping
+choppy
+chops
+choral
+chord
+chordate
+chorded
+chording
+chords
+chore
+choreograph
+choreography
+chores
+choring
+chortle
+chorus
+chorused
+choruses
+chose
+chosen
+Chou
+chowder
+Chris
+Christ
+christen
+Christendom
+christened
+christening
+christens
+Christensen
+Christenson
+Christian
+Christiana
+Christianity
+Christianization
+Christianizations
+Christianize
+Christianizer
+Christianizers
+Christianizes
+Christianizing
+Christians
+Christiansen
+Christianson
+Christie
+Christina
+Christine
+Christlike
+Christmas
+Christoffel
+Christoph
+Christopher
+Christy
+chromatogram
+chromatograph
+chromatography
+chrome
+chromium
+chromosphere
+chronic
+chronicle
+chronicled
+chronicler
+chroniclers
+chronicles
+chronograph
+chronography
+chronological
+chronologically
+chronologies
+chronology
+chrysanthemum
+Chrysler
+chubbier
+chubbiest
+chubbiness
+chubby
+chuck
+chuckle
+chuckled
+chuckles
+chucks
+chum
+Chungking
+chunk
+chunks
+chunky
+church
+churches
+churchgoer
+churchgoing
+Churchill
+Churchillian
+churchly
+churchman
+churchmen
+churchwoman
+churchwomen
+churchyard
+churchyards
+churn
+churned
+churning
+churns
+chute
+chutes
+chutzpah
+cicada
+Cicero
+Ciceronian
+Ciceronianize
+Ciceronianizes
+cider
+cigar
+cigarette
+cigarettes
+cigars
+cilia
+Cincinnati
+cinder
+Cinderella
+cinders
+Cindy
+cinema
+cinematic
+Cinerama
+cinnamon
+cipher
+ciphers
+ciphertext
+ciphertexts
+circa
+Circe
+circle
+circled
+circles
+circlet
+circling
+circuit
+circuitous
+circuitously
+circuitry
+circuits
+circulant
+circular
+circularity
+circularly
+circulate
+circulated
+circulates
+circulating
+circulation
+circumcise
+circumcision
+circumference
+circumflex
+circumlocution
+circumlocutions
+circumnavigate
+circumnavigated
+circumnavigates
+circumpolar
+circumscribe
+circumscribed
+circumscribing
+circumscription
+circumspect
+circumspection
+circumspectly
+circumstance
+circumstanced
+circumstances
+circumstantial
+circumstantially
+circumvent
+circumventable
+circumvented
+circumventing
+circumvents
+circus
+circuses
+cistern
+cisterns
+citadel
+citadels
+citation
+citations
+cite
+cited
+cites
+cities
+citing
+citizen
+citizens
+citizenship
+Citroen
+citrus
+city
+cityscape
+citywide
+civet
+civic
+civics
+civil
+civilian
+civilians
+civility
+civilization
+civilizations
+civilize
+civilized
+civilizes
+civilizing
+civilly
+clad
+cladding
+claim
+claimable
+claimant
+claimants
+claimed
+claiming
+claims
+Claire
+clairvoyant
+clairvoyantly
+clam
+clamber
+clambered
+clambering
+clambers
+clamor
+clamored
+clamoring
+clamorous
+clamors
+clamp
+clamped
+clamping
+clamps
+clams
+clan
+clandestine
+clang
+clanged
+clanging
+clangs
+clank
+clannish
+clap
+clapboard
+Clapeyron
+clapping
+claps
+Clara
+Clare
+Claremont
+Clarence
+Clarendon
+clarification
+clarifications
+clarified
+clarifies
+clarify
+clarifying
+clarinet
+clarity
+Clark
+Clarke
+Clarridge
+clash
+clashed
+clashes
+clashing
+clasp
+clasped
+clasping
+clasps
+class
+classed
+classes
+classic
+classical
+classically
+classics
+classifiable
+classification
+classifications
+classified
+classifier
+classifiers
+classifies
+classify
+classifying
+classmate
+classmates
+classroom
+classrooms
+classy
+clatter
+clattered
+clattering
+Claude
+Claudia
+Claudio
+Claus
+clause
+Clausen
+clauses
+Clausius
+claustrophobia
+claustrophobic
+claw
+clawed
+clawing
+claws
+clay
+clays
+Clayton
+clean
+cleaned
+cleaner
+cleaners
+cleanest
+cleaning
+cleanliness
+cleanly
+cleanness
+cleans
+cleanse
+cleansed
+cleanser
+cleansers
+cleanses
+cleansing
+cleanup
+clear
+clearance
+clearances
+cleared
+clearer
+clearest
+clearing
+clearings
+clearly
+clearness
+clears
+Clearwater
+cleavage
+cleave
+cleaved
+cleaver
+cleavers
+cleaves
+cleaving
+cleft
+clefts
+clemency
+Clemens
+clement
+Clemente
+Clemson
+clench
+clenched
+clenches
+clergy
+clergyman
+clergymen
+clerical
+clerk
+clerked
+clerking
+clerks
+Cleveland
+clever
+cleverer
+cleverest
+cleverly
+cleverness
+cliche
+cliches
+click
+clicked
+clicking
+clicks
+client
+clientele
+clients
+cliff
+Clifford
+cliffs
+Clifton
+climate
+climates
+climatic
+climatically
+climatology
+climax
+climaxed
+climaxes
+climb
+climbed
+climber
+climbers
+climbing
+climbs
+clime
+climes
+clinch
+clinched
+clincher
+clinches
+cling
+clinging
+clings
+clinic
+clinical
+clinically
+clinician
+clinics
+clink
+clinked
+clinker
+Clint
+Clinton
+Clio
+clip
+clipboard
+clipped
+clipper
+clippers
+clipping
+clippings
+clips
+clique
+cliques
+clitoris
+Clive
+cloak
+cloakroom
+cloaks
+clobber
+clobbered
+clobbering
+clobbers
+clock
+clocked
+clocker
+clockers
+clocking
+clockings
+clocks
+clockwatcher
+clockwise
+clockwork
+clod
+clods
+clog
+clogged
+clogging
+clogs
+cloister
+cloisters
+clone
+cloned
+clones
+cloning
+close
+closed
+closely
+closeness
+closenesses
+closer
+closers
+closes
+closest
+closet
+closeted
+closets
+closeup
+closing
+closure
+closures
+clot
+cloth
+clothe
+clothed
+clothes
+clotheshorse
+clothesline
+clothing
+Clotho
+clotting
+cloture
+cloud
+cloudburst
+clouded
+cloudier
+cloudiest
+cloudiness
+clouding
+cloudless
+clouds
+cloudy
+clout
+clove
+clover
+cloves
+clown
+clowning
+clowns
+club
+clubbed
+clubbing
+clubhouse
+clubroom
+clubs
+cluck
+clucked
+clucking
+clucks
+clue
+clues
+Cluj
+clump
+clumped
+clumping
+clumps
+clumsily
+clumsiness
+clumsy
+clung
+cluster
+clustered
+clustering
+clusterings
+clusters
+clutch
+clutched
+clutches
+clutching
+clutter
+cluttered
+cluttering
+clutters
+Clyde
+Clytemnestra
+coach
+coached
+coacher
+coaches
+coaching
+coachman
+coachmen
+coagulate
+coal
+coalesce
+coalesced
+coalesces
+coalescing
+coalition
+coals
+coarse
+coarsely
+coarsen
+coarsened
+coarseness
+coarser
+coarsest
+coast
+coastal
+coasted
+coaster
+coasters
+coasting
+coastline
+coasts
+coat
+coated
+Coates
+coating
+coatings
+coats
+coattail
+coauthor
+coax
+coaxed
+coaxer
+coaxes
+coaxial
+coaxing
+cobalt
+Cobb
+cobble
+cobbler
+cobblers
+cobblestone
+COBOL
+Cobol
+cobra
+cobweb
+cobwebs
+coca
+cocaine
+Cochise
+Cochran
+Cochrane
+cock
+cocked
+cocking
+cockpit
+cockroach
+cocks
+cocktail
+cocktails
+cocky
+coco
+cocoa
+coconut
+coconuts
+cocoon
+cocoons
+cod
+Coddington
+coddle
+code
+coded
+codeine
+coder
+coders
+codes
+codeword
+codewords
+codfish
+codicil
+codification
+codifications
+codified
+codifier
+codifiers
+codifies
+codify
+codifying
+coding
+codings
+codpiece
+Cody
+coed
+coeditor
+coeducation
+coefficient
+coefficients
+coequal
+coerce
+coerced
+coerces
+coercible
+coercing
+coercion
+coercive
+coexist
+coexisted
+coexistence
+coexisting
+coexists
+cofactor
+coffee
+coffeecup
+coffeepot
+coffees
+coffer
+coffers
+Coffey
+coffin
+coffins
+Coffman
+cog
+cogent
+cogently
+cogitate
+cogitated
+cogitates
+cogitating
+cogitation
+cognac
+cognition
+cognitive
+cognitively
+cognizance
+cognizant
+cogs
+cohabitation
+cohabitations
+Cohen
+cohere
+cohered
+coherence
+coherent
+coherently
+coheres
+cohering
+cohesion
+cohesive
+cohesively
+cohesiveness
+Cohn
+cohort
+coil
+coiled
+coiling
+coils
+coin
+coinage
+coincide
+coincided
+coincidence
+coincidences
+coincident
+coincidental
+coincides
+coinciding
+coined
+coiner
+coining
+coins
+coke
+cokes
+colander
+Colby
+cold
+colder
+coldest
+coldly
+coldness
+colds
+Cole
+Coleman
+Coleridge
+Colette
+Colgate
+colicky
+coliform
+coliseum
+collaborate
+collaborated
+collaborates
+collaborating
+collaboration
+collaborations
+collaborative
+collaborator
+collaborators
+collagen
+collapse
+collapsed
+collapses
+collapsible
+collapsing
+collar
+collarbone
+collared
+collaring
+collars
+collate
+collateral
+colleague
+colleagues
+collect
+collected
+collectible
+collecting
+collection
+collections
+collective
+collectively
+collectives
+collector
+collectors
+collects
+college
+colleges
+collegian
+collegiate
+collide
+collided
+collides
+colliding
+collie
+Collier
+collies
+Collins
+collision
+collisions
+colloidal
+colloquia
+colloquial
+colloquium
+colloquy
+collusion
+Cologne
+Colombia
+Colombian
+Colombians
+Colombo
+colon
+colonel
+colonels
+colonial
+colonially
+colonials
+colonies
+colonist
+colonists
+colonization
+colonize
+colonized
+colonizer
+colonizers
+colonizes
+colonizing
+colons
+colony
+color
+Colorado
+colored
+colorer
+colorers
+colorful
+coloring
+colorings
+colorless
+colors
+colossal
+Colosseum
+colt
+colts
+Columbia
+Columbian
+Columbus
+column
+columnize
+columnized
+columnizes
+columnizing
+columns
+Comanche
+comb
+combat
+combatant
+combatants
+combated
+combating
+combative
+combats
+combed
+comber
+combers
+combination
+combinational
+combinations
+combinator
+combinatorial
+combinatorially
+combinatoric
+combinatorics
+combinators
+combine
+combined
+combines
+combing
+combings
+combining
+combs
+combustible
+combustion
+Comdex
+come
+comeback
+comedian
+comedians
+comedic
+comedies
+comedy
+comeliness
+comely
+comer
+comers
+comes
+comestible
+comet
+cometary
+comets
+comfort
+comfortabilities
+comfortability
+comfortable
+comfortably
+comforted
+comforter
+comforters
+comforting
+comfortingly
+comforts
+comic
+comical
+comically
+comics
+Cominform
+coming
+comings
+comma
+command
+commandant
+commandants
+commanded
+commandeer
+commander
+commanders
+commanding
+commandingly
+commandment
+commandments
+commando
+commands
+commas
+commemorate
+commemorated
+commemorates
+commemorating
+commemoration
+commemorative
+commence
+commenced
+commencement
+commencements
+commences
+commencing
+commend
+commendation
+commendations
+commended
+commending
+commends
+commensurate
+comment
+commentaries
+commentary
+commentator
+commentators
+commented
+commenting
+comments
+commerce
+commercial
+commercially
+commercialness
+commercials
+commission
+commissioned
+commissioner
+commissioners
+commissioning
+commissions
+commit
+commitment
+commitments
+commits
+committed
+committee
+committeeman
+committeemen
+committees
+committeewoman
+committeewomen
+committing
+commodities
+commodity
+commodore
+commodores
+common
+commonalities
+commonality
+commoner
+commoners
+commonest
+commonly
+commonness
+commonplace
+commonplaces
+commons
+commonwealth
+commonwealths
+commotion
+communal
+communally
+commune
+communes
+communicant
+communicants
+communicate
+communicated
+communicates
+communicating
+communication
+communications
+communicative
+communicator
+communicators
+communion
+communist
+communists
+communities
+community
+commutative
+commutativity
+commute
+commuted
+commuter
+commuters
+commutes
+commuting
+compact
+compacted
+compacter
+compactest
+compacting
+compaction
+compactly
+compactness
+compactor
+compactors
+compacts
+companies
+companion
+companionable
+companions
+companionship
+company
+comparability
+comparable
+comparably
+comparative
+comparatively
+comparatives
+comparator
+comparators
+compare
+compared
+compares
+comparing
+comparison
+comparisons
+compartment
+compartmentalize
+compartmentalized
+compartmentalizes
+compartmentalizing
+compartmented
+compartments
+compass
+compassion
+compassionate
+compassionately
+compatibilities
+compatibility
+compatible
+compatibles
+compatibly
+compel
+compelled
+compelling
+compellingly
+compels
+compendium
+compensate
+compensated
+compensates
+compensating
+compensation
+compensations
+compensatory
+compete
+competed
+competence
+competency
+competent
+competently
+competes
+competing
+competition
+competitions
+competitive
+competitively
+competitor
+competitors
+compilation
+compilations
+compile
+compiled
+compiler
+compilers
+compiles
+compiling
+complacency
+complain
+complained
+complainer
+complainers
+complaining
+complains
+complaint
+complaints
+complement
+complementary
+complemented
+complementer
+complementers
+complementing
+complements
+complete
+completed
+completely
+completeness
+completes
+completing
+completion
+completions
+complex
+complexes
+complexion
+complexities
+complexity
+complexly
+compliance
+compliant
+complicate
+complicated
+complicates
+complicating
+complication
+complications
+complicator
+complicators
+complicity
+complied
+compliment
+complimentary
+complimented
+complimenter
+complimenters
+complimenting
+compliments
+comply
+complying
+component
+componentry
+components
+componentwise
+compose
+composed
+composedly
+composer
+composers
+composes
+composing
+composite
+composites
+composition
+compositional
+compositions
+compost
+composure
+compound
+compounded
+compounding
+compounds
+comprehend
+comprehended
+comprehending
+comprehends
+comprehensibility
+comprehensible
+comprehension
+comprehensive
+comprehensively
+compress
+compressed
+compresses
+compressible
+compressing
+compression
+compressive
+compressor
+comprise
+comprised
+comprises
+comprising
+compromise
+compromised
+compromiser
+compromisers
+compromises
+compromising
+compromisingly
+Compton
+comptroller
+comptrollers
+compulsion
+compulsions
+compulsive
+compulsory
+compunction
+Compuserve
+computability
+computable
+computation
+computational
+computationally
+computations
+compute
+computed
+computer
+computerize
+computerized
+computerizes
+computerizing
+computers
+computes
+computing
+comrade
+comradely
+comrades
+comradeship
+con
+Conakry
+Conant
+concatenate
+concatenated
+concatenates
+concatenating
+concatenation
+concatenations
+concave
+conceal
+concealed
+concealer
+concealers
+concealing
+concealment
+conceals
+concede
+conceded
+concedes
+conceding
+conceit
+conceited
+conceits
+conceivable
+conceivably
+conceive
+conceived
+conceives
+conceiving
+concentrate
+concentrated
+concentrates
+concentrating
+concentration
+concentrations
+concentrator
+concentrators
+concentric
+concept
+conception
+conceptions
+concepts
+conceptual
+conceptualization
+conceptualizations
+conceptualize
+conceptualized
+conceptualizes
+conceptualizing
+conceptually
+concern
+concerned
+concernedly
+concerning
+concerns
+concert
+concerted
+concertmaster
+concerto
+concerts
+concession
+concessions
+conciliate
+conciliatory
+concise
+concisely
+conciseness
+conclave
+conclude
+concluded
+concludes
+concluding
+conclusion
+conclusions
+conclusive
+conclusively
+concoct
+concomitant
+concord
+concordant
+Concorde
+Concordia
+concourse
+concrete
+concretely
+concreteness
+concretes
+concretion
+concubine
+concur
+concurred
+concurrence
+concurrencies
+concurrency
+concurrent
+concurrently
+concurring
+concurs
+concussion
+condemn
+condemnation
+condemnations
+condemned
+condemner
+condemners
+condemning
+condemns
+condensation
+condense
+condensed
+condenser
+condenses
+condensing
+condescend
+condescending
+condition
+conditional
+conditionally
+conditionals
+conditioned
+conditioner
+conditioners
+conditioning
+conditions
+condom
+condone
+condoned
+condones
+condoning
+conduce
+conducive
+conduciveness
+conduct
+conductance
+conducted
+conducting
+conduction
+conductive
+conductivity
+conductor
+conductors
+conducts
+conduit
+cone
+cones
+Conestoga
+confectionery
+confederacy
+confederate
+confederates
+confederation
+confederations
+confer
+conferee
+conference
+conferences
+conferred
+conferrer
+conferrers
+conferring
+confers
+confess
+confessed
+confesses
+confessing
+confession
+confessions
+confessor
+confessors
+confidant
+confidants
+confide
+confided
+confidence
+confidences
+confident
+confidential
+confidentiality
+confidentially
+confidently
+confides
+confiding
+confidingly
+configurable
+configuration
+configurations
+configure
+configured
+configures
+configuring
+confine
+confined
+confinement
+confinements
+confiner
+confines
+confining
+confirm
+confirmation
+confirmations
+confirmatory
+confirmed
+confirming
+confirms
+confiscate
+confiscated
+confiscates
+confiscating
+confiscation
+confiscations
+conflagration
+conflict
+conflicted
+conflicting
+conflicts
+confluent
+confocal
+conform
+conformal
+conformance
+conformed
+conforming
+conformity
+conforms
+confound
+confounded
+confounding
+confounds
+confront
+confrontation
+confrontations
+confronted
+confronter
+confronters
+confronting
+confronts
+Confucian
+Confucianism
+Confucius
+confuse
+confused
+confuser
+confusers
+confuses
+confusing
+confusingly
+confusion
+confusions
+congenial
+congenially
+congenital
+congest
+congested
+congestion
+congestive
+conglomerate
+Congo
+Congolese
+congratulate
+congratulated
+congratulation
+congratulations
+congratulatory
+congregate
+congregated
+congregates
+congregating
+congregation
+congregations
+congress
+congresses
+congressional
+congressionally
+congressman
+congressmen
+congresswoman
+congresswomen
+congruence
+congruent
+conic
+conifer
+coniferous
+conjecture
+conjectured
+conjectures
+conjecturing
+conjoined
+conjugal
+conjugate
+conjunct
+conjuncted
+conjunction
+conjunctions
+conjunctive
+conjunctively
+conjuncts
+conjuncture
+conjure
+conjured
+conjurer
+conjures
+conjuring
+Conklin
+Conley
+Connally
+connect
+connected
+connectedness
+Connecticut
+connecting
+connection
+connectionless
+connections
+connective
+connectives
+connectivity
+connector
+connectors
+connects
+Connelly
+Conner
+Connie
+connivance
+connive
+connoisseur
+connoisseurs
+Connors
+connotation
+connotative
+connote
+connoted
+connotes
+connoting
+connubial
+conquer
+conquerable
+conquered
+conquerer
+conquerers
+conquering
+conqueror
+conquerors
+conquers
+conquest
+conquests
+Conrad
+Conrail
+conscience
+consciences
+conscientious
+conscientiously
+conscious
+consciously
+consciousness
+conscript
+conscription
+consecrate
+consecration
+consecutive
+consecutively
+consensual
+consensus
+consent
+consented
+consenter
+consenters
+consenting
+consents
+consequence
+consequences
+consequent
+consequential
+consequentialities
+consequentiality
+consequently
+consequents
+conservation
+conservationist
+conservationists
+conservations
+conservatism
+conservative
+conservatively
+conservatives
+conservator
+conserve
+conserved
+conserves
+conserving
+consider
+considerable
+considerably
+considerate
+considerately
+consideration
+considerations
+considered
+considering
+considers
+consign
+consigned
+consigning
+consigns
+consist
+consisted
+consistency
+consistent
+consistently
+consisting
+consists
+consolable
+consolation
+consolations
+console
+consoled
+consoler
+consolers
+consoles
+consolidate
+consolidated
+consolidates
+consolidating
+consolidation
+consoling
+consolingly
+consonant
+consonants
+consort
+consorted
+consorting
+consortium
+consorts
+conspicuous
+conspicuously
+conspiracies
+conspiracy
+conspirator
+conspirators
+conspire
+conspired
+conspires
+conspiring
+constable
+constables
+Constance
+constancy
+constant
+Constantine
+Constantinople
+constantly
+constants
+constellation
+constellations
+consternation
+constituencies
+constituency
+constituent
+constituents
+constitute
+constituted
+constitutes
+constituting
+constitution
+constitutional
+constitutionality
+constitutionally
+constitutions
+constitutive
+constrain
+constrained
+constraining
+constrains
+constraint
+constraints
+constrict
+construct
+constructed
+constructibility
+constructible
+constructing
+construction
+constructions
+constructive
+constructively
+constructor
+constructors
+constructs
+construe
+construed
+construing
+consul
+consular
+consulate
+consulates
+consuls
+consult
+consultant
+consultants
+consultation
+consultations
+consultative
+consulted
+consulting
+consults
+consumable
+consume
+consumed
+consumer
+consumers
+consumes
+consuming
+consummate
+consummated
+consummately
+consummation
+consumption
+consumptions
+consumptive
+consumptively
+contact
+contacted
+contacting
+contacts
+contagion
+contagious
+contagiously
+contain
+containable
+contained
+container
+containers
+containing
+containment
+containments
+contains
+contaminate
+contaminated
+contaminates
+contaminating
+contamination
+contemplate
+contemplated
+contemplates
+contemplating
+contemplation
+contemplations
+contemplative
+contemporaries
+contemporariness
+contemporary
+contempt
+contemptible
+contemptuous
+contemptuously
+contend
+contended
+contender
+contenders
+contending
+contends
+content
+contented
+contenting
+contention
+contentions
+contently
+contentment
+contents
+contest
+contestable
+contestant
+contested
+contester
+contesters
+contesting
+contests
+context
+contexts
+contextual
+contextually
+contiguity
+contiguous
+contiguously
+continent
+continental
+continentally
+continents
+contingencies
+contingency
+contingent
+contingents
+continual
+continually
+continuance
+continuances
+continuation
+continuations
+continue
+continued
+continues
+continuing
+continuities
+continuity
+continuous
+continuously
+continuum
+contortions
+contour
+contoured
+contouring
+contours
+contraband
+contraception
+contraceptive
+contract
+contracted
+contracting
+contraction
+contractions
+contractor
+contractors
+contracts
+contractual
+contractually
+contradict
+contradicted
+contradicting
+contradiction
+contradictions
+contradictory
+contradicts
+contradistinction
+contradistinctions
+contrapositive
+contrapositives
+contraption
+contraptions
+contrariness
+contrary
+contrast
+contrasted
+contraster
+contrasters
+contrasting
+contrastingly
+contrasts
+contribute
+contributed
+contributes
+contributing
+contribution
+contributions
+contributor
+contributorily
+contributors
+contributory
+contrite
+contrition
+contrivance
+contrivances
+contrive
+contrived
+contriver
+contrives
+contriving
+control
+controllability
+controllable
+controllably
+controlled
+controller
+controllers
+controlling
+controls
+controversial
+controversies
+controversy
+controvertible
+contumacious
+contumacy
+conundrum
+conundrums
+Convair
+convalescent
+convect
+convene
+convened
+convenes
+convenience
+conveniences
+convenient
+conveniently
+convening
+convent
+convention
+conventional
+conventionally
+conventions
+convents
+converge
+converged
+convergence
+convergent
+converges
+converging
+conversant
+conversantly
+conversation
+conversational
+conversationally
+conversations
+converse
+conversed
+conversely
+converses
+conversing
+conversion
+conversions
+convert
+converted
+converter
+converters
+convertibility
+convertible
+converting
+converts
+convex
+convey
+conveyance
+conveyances
+conveyed
+conveyer
+conveyers
+conveying
+conveyor
+conveys
+convict
+convicted
+convicting
+conviction
+convictions
+convicts
+convince
+convinced
+convincer
+convincers
+convinces
+convincing
+convincingly
+convivial
+convoke
+convoluted
+convolution
+convoy
+convoyed
+convoying
+convoys
+convulse
+convulsion
+convulsions
+Conway
+coo
+cooing
+cook
+cookbook
+Cooke
+cooked
+cookery
+cookie
+cookies
+cooking
+cooks
+cooky
+cool
+cooled
+cooler
+coolers
+coolest
+Cooley
+Coolidge
+coolie
+coolies
+cooling
+coolly
+coolness
+cools
+coon
+coons
+coop
+cooped
+cooper
+cooperate
+cooperated
+cooperates
+cooperating
+cooperation
+cooperations
+cooperative
+cooperatively
+cooperatives
+cooperator
+cooperators
+coopers
+coops
+coordinate
+coordinated
+coordinates
+coordinating
+coordination
+coordinations
+coordinator
+coordinators
+Coors
+cop
+cope
+coped
+Copeland
+Copenhagen
+Copernican
+Copernicus
+copes
+copied
+copier
+copiers
+copies
+coping
+copings
+copious
+copiously
+copiousness
+coplanar
+copper
+Copperfield
+copperhead
+coppers
+copra
+coprocessor
+cops
+copse
+copy
+copying
+copyright
+copyrightable
+copyrighted
+copyrights
+copywriter
+coquette
+coral
+Corbett
+Corcoran
+cord
+corded
+corder
+cordial
+cordiality
+cordially
+cords
+core
+cored
+corer
+corers
+cores
+Corey
+coriander
+coring
+Corinth
+Corinthian
+Corinthianize
+Corinthianizes
+Corinthians
+Coriolanus
+cork
+corked
+corker
+corkers
+corking
+corks
+corkscrew
+cormorant
+corn
+cornea
+Cornelia
+Cornelian
+Cornelius
+Cornell
+corner
+cornered
+corners
+cornerstone
+cornerstones
+cornet
+cornfield
+cornfields
+corning
+Cornish
+cornmeal
+corns
+cornstarch
+cornucopia
+Cornwall
+Cornwallis
+corny
+corollaries
+corollary
+Coronado
+coronaries
+coronary
+coronation
+coroner
+coronet
+coronets
+coroutine
+coroutines
+corporal
+corporals
+corporate
+corporately
+corporation
+corporations
+corps
+corpse
+corpses
+corpulent
+corpus
+corpuscular
+corral
+correct
+correctable
+corrected
+correcting
+correction
+corrections
+corrective
+correctively
+correctives
+correctly
+correctness
+corrector
+corrects
+correlate
+correlated
+correlates
+correlating
+correlation
+correlations
+correlative
+correspond
+corresponded
+correspondence
+correspondences
+correspondent
+correspondents
+corresponding
+correspondingly
+corresponds
+corridor
+corridors
+corrigenda
+corrigendum
+corrigible
+corroborate
+corroborated
+corroborates
+corroborating
+corroboration
+corroborations
+corroborative
+corrode
+corrosion
+corrosive
+corrugate
+corrupt
+corrupted
+corrupter
+corruptible
+corrupting
+corruption
+corruptions
+corrupts
+corset
+Corsica
+Corsican
+cortex
+Cortez
+cortical
+Cortland
+Corvallis
+Corvus
+Corydoras
+Cosgrove
+cosine
+cosines
+cosmetic
+cosmetics
+cosmic
+cosmology
+cosmopolitan
+cosmos
+cosponsor
+Cossack
+cost
+Costa
+costed
+Costello
+costing
+costly
+costs
+costume
+costumed
+costumer
+costumes
+costuming
+cosy
+cot
+cotangent
+cotillion
+cots
+cottage
+cottager
+cottages
+cotton
+cottonmouth
+cottons
+cottonseed
+cottonwood
+Cottrell
+cotyledon
+cotyledons
+couch
+couched
+couches
+couching
+cougar
+cough
+coughed
+coughing
+coughs
+could
+coulomb
+Coulter
+council
+councillor
+councillors
+councilman
+councilmen
+councils
+councilwoman
+councilwomen
+counsel
+counseled
+counseling
+counselled
+counselling
+counsellor
+counsellors
+counselor
+counselors
+counsels
+count
+countable
+countably
+counted
+countenance
+counter
+counteract
+counteracted
+counteracting
+counteractive
+counterargument
+counterattack
+counterbalance
+counterclockwise
+countered
+counterexample
+counterexamples
+counterfeit
+counterfeited
+counterfeiter
+counterfeiting
+counterflow
+countering
+counterintuitive
+counterman
+countermeasure
+countermeasures
+countermen
+counterpart
+counterparts
+counterpoint
+counterpointing
+counterpoise
+counterproductive
+counterproposal
+counterrevolution
+counters
+countersink
+countersunk
+countess
+counties
+counting
+countless
+countries
+country
+countryman
+countrymen
+countryside
+countrywide
+counts
+county
+countywide
+couple
+coupled
+coupler
+couplers
+couples
+coupling
+couplings
+coupon
+coupons
+courage
+courageous
+courageously
+courier
+couriers
+course
+coursed
+courser
+courses
+coursing
+court
+courted
+courteous
+courteously
+courter
+courters
+courtesan
+courtesies
+courtesy
+courthouse
+courthouses
+courtier
+courtiers
+courting
+courtly
+Courtney
+courtroom
+courtrooms
+courts
+courtship
+courtyard
+courtyards
+cousin
+cousins
+covalent
+covariant
+cove
+covenant
+covenants
+Covent
+Coventry
+cover
+coverable
+coverage
+covered
+covering
+coverings
+coverlet
+coverlets
+covers
+covert
+covertly
+coves
+covet
+coveted
+coveting
+covetous
+covetousness
+covets
+cow
+Cowan
+coward
+cowardice
+cowardly
+cowboy
+cowboys
+cowed
+cower
+cowered
+cowerer
+cowerers
+cowering
+coweringly
+cowers
+cowherd
+cowhide
+cowing
+cowl
+cowlick
+cowling
+cowls
+coworker
+cows
+cowslip
+cowslips
+coyote
+coyotes
+coypu
+cozier
+coziness
+cozy
+crab
+crabapple
+crabs
+crack
+cracked
+cracker
+crackers
+cracking
+crackle
+crackled
+crackles
+crackling
+crackpot
+cracks
+cradle
+cradled
+cradles
+craft
+crafted
+crafter
+craftiness
+crafting
+crafts
+craftsman
+craftsmen
+craftspeople
+craftsperson
+crafty
+crag
+craggy
+crags
+Craig
+cram
+Cramer
+cramming
+cramp
+cramps
+crams
+cranberries
+cranberry
+Crandall
+crane
+cranes
+Cranford
+crania
+cranium
+crank
+crankcase
+cranked
+crankier
+crankiest
+crankily
+cranking
+cranks
+crankshaft
+cranky
+cranny
+Cranston
+crash
+crashed
+crasher
+crashers
+crashes
+crashing
+crass
+crate
+crater
+craters
+crates
+cravat
+cravats
+crave
+craved
+craven
+craves
+craving
+Crawford
+crawl
+crawled
+crawler
+crawlers
+crawling
+crawls
+Cray
+crayon
+Crays
+craze
+crazed
+crazes
+crazier
+craziest
+crazily
+craziness
+crazing
+crazy
+creak
+creaked
+creaking
+creaks
+creaky
+cream
+creamed
+creamer
+creamers
+creamery
+creaming
+creams
+creamy
+crease
+creased
+creases
+creasing
+create
+created
+creates
+creating
+creation
+creations
+creative
+creatively
+creativeness
+creativity
+creator
+creators
+creature
+creatures
+credence
+credential
+credibility
+credible
+credibly
+credit
+creditable
+creditably
+credited
+crediting
+creditor
+creditors
+credits
+credulity
+credulous
+credulousness
+Cree
+creed
+creeds
+creek
+creeks
+creep
+creeper
+creepers
+creeping
+creeps
+creepy
+Creighton
+cremate
+cremated
+cremates
+cremating
+cremation
+cremations
+crematory
+Creole
+Creon
+crepe
+crept
+crescent
+crescents
+crest
+crested
+crestfallen
+crests
+Crestview
+Cretaceous
+Cretaceously
+Cretan
+Crete
+cretin
+crevice
+crevices
+crew
+crewcut
+crewed
+crewing
+crews
+crib
+cribs
+cricket
+crickets
+cried
+crier
+criers
+cries
+crime
+Crimea
+Crimean
+crimes
+criminal
+criminally
+criminals
+criminate
+crimson
+crimsoning
+cringe
+cringed
+cringes
+cringing
+cripple
+crippled
+cripples
+crippling
+crises
+crisis
+crisp
+Crispin
+crisply
+crispness
+crisscross
+criteria
+criterion
+critic
+critical
+critically
+criticism
+criticisms
+criticize
+criticized
+criticizes
+criticizing
+critics
+critique
+critiques
+critiquing
+critter
+croak
+croaked
+croaking
+croaks
+Croatia
+Croatian
+crochet
+crochets
+crock
+crockery
+Crockett
+crocks
+crocodile
+crocus
+croft
+Croix
+Cromwell
+Cromwellian
+crook
+crooked
+crooks
+crop
+cropped
+cropper
+croppers
+cropping
+crops
+Crosby
+cross
+crossable
+crossbar
+crossbars
+crossed
+crosser
+crossers
+crosses
+crossing
+crossings
+crossly
+crossover
+crossovers
+crosspoint
+crossroad
+crosstalk
+crosswalk
+crossword
+crosswords
+crotch
+crotchety
+crouch
+crouched
+crouching
+crow
+crowd
+crowded
+crowder
+crowding
+crowds
+crowed
+crowing
+Crowley
+crown
+crowned
+crowning
+crowns
+crows
+Croydon
+crucial
+crucially
+crucible
+crucified
+crucifies
+crucifix
+crucifixion
+crucify
+crucifying
+crud
+cruddy
+crude
+crudely
+crudeness
+cruder
+crudest
+cruel
+crueler
+cruelest
+cruelly
+cruelty
+Cruickshank
+cruise
+cruiser
+cruisers
+cruises
+cruising
+crumb
+crumble
+crumbled
+crumbles
+crumbling
+crumbly
+crumbs
+crummy
+crumple
+crumpled
+crumples
+crumpling
+crunch
+crunched
+crunches
+crunchier
+crunchiest
+crunching
+crunchy
+crusade
+crusader
+crusaders
+crusades
+crusading
+crush
+crushable
+crushed
+crusher
+crushers
+crushes
+crushing
+crushingly
+Crusoe
+crust
+crustacean
+crustaceans
+crusts
+crutch
+crutches
+crux
+cruxes
+Cruz
+cry
+crying
+cryogenic
+crypt
+cryptanalysis
+cryptanalyst
+cryptanalytic
+cryptic
+cryptogram
+cryptographer
+cryptographic
+cryptographically
+cryptography
+cryptologist
+cryptology
+crystal
+crystalline
+crystallize
+crystallized
+crystallizes
+crystallizing
+crystals
+cub
+Cuba
+Cuban
+Cubanize
+Cubanizes
+Cubans
+cubbyhole
+cube
+cubed
+cubes
+cubic
+cubs
+cuckoo
+cuckoos
+cucumber
+cucumbers
+cuddle
+cuddled
+cuddly
+cudgel
+cudgels
+cue
+cued
+cues
+cuff
+cufflink
+cuffs
+cuisine
+Culbertson
+culinary
+cull
+culled
+culler
+culling
+culls
+culminate
+culminated
+culminates
+culminating
+culmination
+culpa
+culpable
+culprit
+culprits
+cult
+cultivable
+cultivate
+cultivated
+cultivates
+cultivating
+cultivation
+cultivations
+cultivator
+cultivators
+cults
+cultural
+culturally
+culture
+cultured
+cultures
+culturing
+Culver
+Culvers
+Cumberland
+cumbersome
+Cummings
+Cummins
+cumulative
+cumulatively
+Cunard
+cunnilingus
+cunning
+Cunningham
+cunningly
+cup
+cupboard
+cupboards
+Cupertino
+cupful
+Cupid
+cupped
+cupping
+cups
+curable
+curably
+curb
+curbing
+curbs
+curd
+curdle
+cure
+cured
+cures
+curfew
+curfews
+curing
+curiosities
+curiosity
+curious
+curiouser
+curiousest
+curiously
+curl
+curled
+curler
+curlers
+curlicue
+curling
+curls
+curly
+Curran
+currant
+currants
+currencies
+currency
+current
+currently
+currentness
+currents
+curricular
+curriculum
+curriculums
+curried
+curries
+curry
+currying
+curs
+curse
+cursed
+curses
+cursing
+cursive
+cursor
+cursorily
+cursors
+cursory
+curt
+curtail
+curtailed
+curtails
+curtain
+curtained
+curtains
+curtate
+Curtis
+curtly
+curtness
+curtsies
+curtsy
+curvaceous
+curvature
+curve
+curved
+curves
+curvilinear
+curving
+Cushing
+cushion
+cushioned
+cushioning
+cushions
+Cushman
+cusp
+cusps
+custard
+Custer
+custodial
+custodian
+custodians
+custody
+custom
+customarily
+customary
+customer
+customers
+customizable
+customization
+customizations
+customize
+customized
+customizer
+customizers
+customizes
+customizing
+customs
+cut
+cutaneous
+cutback
+cute
+cutest
+cutlass
+cutlet
+cutoff
+cutout
+cutover
+cuts
+cutter
+cutters
+cutthroat
+cutting
+cuttingly
+cuttings
+cuttlefish
+Cuvier
+Cuzco
+Cyanamid
+cyanide
+cybernetic
+cybernetics
+cyberspace
+Cyclades
+cycle
+cycled
+cycles
+cyclic
+cyclically
+cycling
+cycloid
+cycloidal
+cycloids
+cyclone
+cyclones
+Cyclops
+cyclotron
+cyclotrons
+Cygnus
+cylinder
+cylinders
+cylindrical
+cymbal
+cymbals
+cynic
+cynical
+cynically
+Cynthia
+cypress
+Cyprian
+Cypriot
+Cyprus
+Cyril
+Cyrillic
+Cyrus
+cyst
+cysts
+cytology
+cytoplasm
+czar
+Czech
+Czechization
+Czechizations
+Czechoslovakia
+Czerniak
+dabble
+dabbled
+dabbler
+dabbles
+dabbling
+Dacca
+Dacron
+dactyl
+dactylic
+dad
+Dada
+Dadaism
+Dadaist
+Dadaistic
+daddy
+Dade
+dads
+Daedalus
+daemon
+daemons
+daffodil
+daffodils
+dagger
+Dahl
+dahlia
+Dahomey
+Dailey
+dailies
+daily
+Daimler
+daintily
+daintiness
+dainty
+dairy
+Dairylea
+daisies
+daisy
+Dakar
+Dakota
+dale
+dales
+Daley
+Dalhousie
+Dali
+Dallas
+Dalton
+Daly
+Dalzell
+dam
+damage
+damaged
+damager
+damagers
+damages
+damaging
+Damascus
+damask
+dame
+damming
+damn
+damnation
+damned
+damning
+damns
+Damocles
+Damon
+damp
+dampen
+dampens
+damper
+damping
+dampness
+dams
+damsel
+damsels
+Dan
+Dana
+Danbury
+dance
+danced
+dancer
+dancers
+dances
+dancing
+dandelion
+dandelions
+dandy
+Dane
+Danes
+danger
+dangerous
+dangerously
+dangers
+dangle
+dangled
+dangles
+dangling
+Daniel
+Daniels
+Danielson
+Danish
+Danization
+Danizations
+Danize
+Danizes
+Danny
+Dante
+Danube
+Danubian
+Danville
+Danzig
+Daphne
+Dar
+dare
+dared
+darer
+darers
+dares
+daresay
+daring
+daringly
+Darius
+dark
+darken
+darker
+darkest
+darkly
+darkness
+darkroom
+Darlene
+darling
+darlings
+Darlington
+darn
+darned
+darner
+darning
+darns
+DARPA
+Darrell
+Darrow
+Darry
+dart
+darted
+darter
+darting
+Dartmouth
+darts
+Darwin
+Darwinian
+Darwinism
+Darwinistic
+Darwinize
+Darwinizes
+dash
+dashboard
+dashed
+dasher
+dashers
+dashes
+dashing
+dashingly
+data
+database
+databases
+datagram
+datagrams
+Datamation
+Datamedia
+date
+dated
+dateline
+dater
+dates
+dating
+dative
+Datsun
+datum
+Daugherty
+daughter
+daughterly
+daughters
+daunt
+daunted
+dauntless
+Dave
+David
+Davidson
+Davie
+Davies
+Davinich
+Davis
+Davison
+Davy
+dawn
+dawned
+dawning
+dawns
+Dawson
+day
+daybreak
+daydream
+daydreaming
+daydreams
+daylight
+daylights
+days
+daytime
+Dayton
+Daytona
+daze
+dazed
+dazzle
+dazzled
+dazzler
+dazzles
+dazzling
+dazzlingly
+De
+deacon
+deacons
+deactivate
+dead
+deaden
+deadline
+deadlines
+deadlock
+deadlocked
+deadlocking
+deadlocks
+deadly
+deadness
+deadwood
+deaf
+deafen
+deafer
+deafest
+deafness
+deal
+dealer
+dealers
+dealership
+dealing
+dealings
+deallocate
+deallocated
+deallocating
+deallocation
+deallocations
+deals
+dealt
+dean
+Deane
+Deanna
+deans
+dear
+Dearborn
+dearer
+dearest
+dearly
+dearness
+dearth
+dearths
+death
+deathbed
+deathly
+deaths
+debacle
+debar
+debase
+debatable
+debate
+debated
+debater
+debaters
+debates
+debating
+debauch
+debauchery
+Debbie
+Debby
+debilitate
+debilitated
+debilitates
+debilitating
+debility
+debit
+debited
+Deborah
+Debra
+debrief
+debris
+debt
+debtor
+debts
+debug
+debugged
+debugger
+debuggers
+debugging
+debugs
+debunk
+Debussy
+debutante
+DEC
+decade
+decadence
+decadent
+decadently
+decades
+decal
+decathlon
+Decatur
+decay
+decayed
+decaying
+decays
+Decca
+decease
+deceased
+deceases
+deceasing
+decedent
+deceit
+deceitful
+deceitfully
+deceitfulness
+deceive
+deceived
+deceiver
+deceivers
+deceives
+deceiving
+decelerate
+decelerated
+decelerates
+decelerating
+deceleration
+December
+Decembers
+decencies
+decency
+decennial
+decent
+decently
+decentralization
+decentralized
+deception
+deceptions
+deceptive
+deceptively
+decertify
+decibel
+decidability
+decidable
+decide
+decided
+decidedly
+decides
+deciding
+deciduous
+decimal
+decimals
+decimate
+decimated
+decimates
+decimating
+decimation
+decipher
+deciphered
+decipherer
+deciphering
+deciphers
+decision
+decisions
+decisive
+decisively
+decisiveness
+deck
+decked
+Decker
+decking
+deckings
+decks
+declaration
+declarations
+declarative
+declaratively
+declaratives
+declarator
+declaratory
+declare
+declared
+declarer
+declarers
+declares
+declaring
+declassify
+declination
+declinations
+decline
+declined
+decliner
+decliners
+declines
+declining
+DECnet
+decode
+decoded
+decoder
+decoders
+decodes
+decoding
+decodings
+decolletage
+decollimate
+decompile
+decomposability
+decomposable
+decompose
+decomposed
+decomposes
+decomposing
+decomposition
+decompositions
+decompress
+decompression
+decorate
+decorated
+decorates
+decorating
+decoration
+decorations
+decorative
+decorum
+decouple
+decoupled
+decouples
+decoupling
+decoy
+decoys
+decrease
+decreased
+decreases
+decreasing
+decreasingly
+decree
+decreed
+decreeing
+decrees
+decrement
+decremented
+decrementing
+decrements
+decrypt
+decrypted
+decrypting
+decryption
+decrypts
+DECstation
+DECsystem
+DECtape
+dedicate
+dedicated
+dedicates
+dedicating
+dedication
+deduce
+deduced
+deducer
+deduces
+deducible
+deducing
+deduct
+deducted
+deductible
+deducting
+deduction
+deductions
+deductive
+Dee
+deed
+deeded
+deeding
+deeds
+deem
+deemed
+deeming
+deemphasize
+deemphasized
+deemphasizes
+deemphasizing
+deems
+deep
+deepen
+deepened
+deepening
+deepens
+deeper
+deepest
+deeply
+deeps
+deer
+Deere
+deface
+default
+defaulted
+defaulter
+defaulting
+defaults
+defeat
+defeated
+defeating
+defeats
+defecate
+defect
+defected
+defecting
+defection
+defections
+defective
+defects
+defend
+defendant
+defendants
+defended
+defender
+defenders
+defending
+defends
+defenestrate
+defenestrated
+defenestrates
+defenestrating
+defenestration
+defense
+defenseless
+defenses
+defensible
+defensive
+defer
+deference
+deferment
+deferments
+deferrable
+deferred
+deferrer
+deferrers
+deferring
+defers
+defiance
+defiant
+defiantly
+deficiencies
+deficiency
+deficient
+deficit
+deficits
+defied
+defies
+defile
+defiling
+definable
+define
+defined
+definer
+defines
+defining
+definite
+definitely
+definiteness
+definition
+definitional
+definitions
+definitive
+deflate
+deflater
+deflect
+defocus
+Defoe
+deforest
+deforestation
+deform
+deformation
+deformations
+deformed
+deformities
+deformity
+defraud
+defray
+defrost
+deftly
+defunct
+defy
+defying
+degeneracy
+degenerate
+degenerated
+degenerates
+degenerating
+degeneration
+degenerative
+degradable
+degradation
+degradations
+degrade
+degraded
+degrades
+degrading
+degree
+degrees
+dehumidify
+dehydrate
+deify
+deign
+deigned
+deigning
+deigns
+Deimos
+Deirdre
+Deirdres
+deities
+deity
+dejected
+dejectedly
+DeKalb
+DeKastere
+Del
+Delaney
+Delano
+Delaware
+delay
+delayed
+delaying
+delays
+delegate
+delegated
+delegates
+delegating
+delegation
+delegations
+delete
+deleted
+deleter
+deleterious
+deletes
+deleting
+deletion
+deletions
+Delft
+Delhi
+Delia
+deliberate
+deliberated
+deliberately
+deliberateness
+deliberates
+deliberating
+deliberation
+deliberations
+deliberative
+deliberator
+deliberators
+delicacies
+delicacy
+delicate
+delicately
+delicatessen
+delicious
+deliciously
+delight
+delighted
+delightedly
+delightful
+delightfully
+delighting
+delights
+Delilah
+delimit
+delimitation
+delimited
+delimiter
+delimiters
+delimiting
+delimits
+delineament
+delineate
+delineated
+delineates
+delineating
+delineation
+delinquency
+delinquent
+delirious
+deliriously
+delirium
+deliver
+deliverable
+deliverables
+deliverance
+delivered
+deliverer
+deliverers
+deliveries
+delivering
+delivers
+delivery
+dell
+Della
+dells
+Dellwood
+Delmarva
+Delphi
+Delphic
+Delphically
+Delphinus
+delta
+deltas
+delude
+deluded
+deludes
+deluding
+deluge
+deluged
+deluges
+delusion
+delusions
+deluxe
+delve
+delves
+delving
+demagnify
+demagogue
+demand
+demanded
+demander
+demanding
+demandingly
+demands
+demarcate
+demeanor
+demented
+demerit
+Demeter
+demigod
+demise
+demo
+democracies
+democracy
+democrat
+democratic
+democratically
+democrats
+demodulate
+demodulator
+demographic
+demolish
+demolished
+demolishes
+demolition
+demon
+demoniac
+demonic
+demons
+demonstrable
+demonstrate
+demonstrated
+demonstrates
+demonstrating
+demonstration
+demonstrations
+demonstrative
+demonstratively
+demonstrator
+demonstrators
+demoralize
+demoralized
+demoralizes
+demoralizing
+DeMorgan
+demote
+demountable
+Dempsey
+demultiplex
+demultiplexed
+demultiplexer
+demultiplexers
+demultiplexing
+demur
+demythologize
+den
+denature
+Deneb
+Denebola
+Deneen
+deniable
+denial
+denials
+denied
+denier
+denies
+denigrate
+denigrated
+denigrates
+denigrating
+denizen
+Denmark
+Dennis
+Denny
+denominate
+denomination
+denominations
+denominator
+denominators
+denotable
+denotation
+denotational
+denotationally
+denotations
+denotative
+denote
+denoted
+denotes
+denoting
+denounce
+denounced
+denounces
+denouncing
+dens
+dense
+densely
+denseness
+denser
+densest
+densities
+density
+dent
+dental
+dentally
+dented
+denting
+dentist
+dentistry
+dentists
+Denton
+dents
+denture
+denude
+denumerable
+denunciate
+denunciation
+Denver
+deny
+denying
+deodorant
+deoxyribonucleic
+depart
+departed
+departing
+department
+departmental
+departments
+departs
+departure
+departures
+depend
+dependability
+dependable
+dependably
+depended
+dependence
+dependencies
+dependency
+dependent
+dependently
+dependents
+depending
+depends
+depict
+depicted
+depicting
+depicts
+deplete
+depleted
+depletes
+depleting
+depletion
+depletions
+deplorable
+deplore
+deplored
+deplores
+deploring
+deploy
+deployed
+deploying
+deployment
+deployments
+deploys
+deport
+deportation
+deportee
+deportment
+depose
+deposed
+deposes
+deposit
+depositary
+deposited
+depositing
+deposition
+depositions
+depositor
+depositors
+depository
+deposits
+depot
+depots
+deprave
+depraved
+depravity
+deprecate
+depreciate
+depreciated
+depreciates
+depreciation
+depress
+depressed
+depresses
+depressing
+depression
+depressions
+deprivation
+deprivations
+deprive
+deprived
+deprives
+depriving
+depth
+depths
+deputies
+deputy
+dequeue
+dequeued
+dequeues
+dequeuing
+derail
+derailed
+derailing
+derails
+derby
+Derbyshire
+dereference
+deregulate
+deregulated
+Derek
+deride
+derision
+derivable
+derivation
+derivations
+derivative
+derivatives
+derive
+derived
+derives
+deriving
+derogatory
+derrick
+derriere
+dervish
+Des
+Descartes
+descend
+descendant
+descendants
+descended
+descendent
+descender
+descenders
+descending
+descends
+descent
+descents
+describable
+describe
+described
+describer
+describes
+describing
+description
+descriptions
+descriptive
+descriptively
+descriptives
+descriptor
+descriptors
+descry
+desecrate
+desegregate
+desert
+deserted
+deserter
+deserters
+deserting
+desertion
+desertions
+deserts
+deserve
+deserved
+deserves
+deserving
+deservingly
+deservings
+desiderata
+desideratum
+design
+designate
+designated
+designates
+designating
+designation
+designations
+designator
+designators
+designed
+designer
+designers
+designing
+designs
+desirability
+desirable
+desirably
+desire
+desired
+desires
+desiring
+desirous
+desist
+desk
+desks
+desktop
+Desmond
+desolate
+desolately
+desolation
+desolations
+despair
+despaired
+despairing
+despairingly
+despairs
+despatch
+despatched
+desperado
+desperate
+desperately
+desperation
+despicable
+despise
+despised
+despises
+despising
+despite
+despoil
+despondent
+despot
+despotic
+despotism
+despots
+dessert
+desserts
+desiccate
+destabilize
+destination
+destinations
+destine
+destined
+destinies
+destiny
+destitute
+destitution
+destroy
+destroyed
+destroyer
+destroyers
+destroying
+destroys
+destruct
+destruction
+destructions
+destructive
+destructively
+destructiveness
+destructor
+destuff
+destuffing
+destuffs
+desuetude
+desultory
+desynchronize
+detach
+detached
+detacher
+detaches
+detaching
+detachment
+detachments
+detail
+detailed
+detailing
+details
+detain
+detained
+detaining
+detains
+detect
+detectable
+detectably
+detected
+detecting
+detection
+detections
+detective
+detectives
+detector
+detectors
+detects
+detente
+detention
+deter
+detergent
+deteriorate
+deteriorated
+deteriorates
+deteriorating
+deterioration
+determinable
+determinacy
+determinant
+determinants
+determinate
+determinately
+determination
+determinations
+determinative
+determine
+determined
+determiner
+determiners
+determines
+determining
+determinism
+deterministic
+deterministically
+deterred
+deterrent
+deterring
+detest
+detestable
+detested
+detour
+detract
+detractor
+detractors
+detracts
+detriment
+detrimental
+Detroit
+deuce
+deus
+deuterium
+Deutsch
+devastate
+devastated
+devastates
+devastating
+devastation
+develop
+developed
+developer
+developers
+developing
+development
+developmental
+developments
+develops
+deviant
+deviants
+deviate
+deviated
+deviates
+deviating
+deviation
+deviations
+device
+devices
+devil
+devilish
+devilishly
+devils
+devious
+devise
+devised
+devises
+devising
+devisings
+devoid
+devolve
+Devon
+Devonshire
+devote
+devoted
+devotedly
+devotee
+devotees
+devotes
+devoting
+devotion
+devotions
+devour
+devoured
+devourer
+devours
+devout
+devoutly
+devoutness
+dew
+dewdrop
+dewdrops
+Dewey
+Dewitt
+dewy
+Dexedrine
+dexterity
+Dhabi
+diabetes
+diabetic
+diabolic
+diachronic
+diacritical
+diadem
+diagnosable
+diagnose
+diagnosed
+diagnoses
+diagnosing
+diagnosis
+diagnostic
+diagnostician
+diagnostics
+diagonal
+diagonally
+diagonals
+diagram
+diagrammable
+diagrammatic
+diagrammatically
+diagrammed
+diagrammer
+diagrammers
+diagramming
+diagrams
+dial
+dialect
+dialectic
+dialects
+dialed
+dialer
+dialers
+dialing
+dialog
+dialogs
+dialogue
+dialogues
+dials
+dialup
+dialysis
+diamagnetic
+diameter
+diameters
+diametric
+diametrically
+diamond
+diamonds
+Diana
+Diane
+Dianne
+diaper
+diapers
+diaphragm
+diaphragms
+diaries
+diarrhea
+diary
+diatribe
+diatribes
+dibble
+dice
+dichotomize
+dichotomy
+dickens
+Dickerson
+Dickinson
+Dickson
+dicky
+dictate
+dictated
+dictates
+dictating
+dictation
+dictations
+dictator
+dictatorial
+dictators
+dictatorship
+diction
+dictionaries
+dictionary
+dictum
+dictums
+did
+didactic
+diddle
+Dido
+die
+Diebold
+died
+Diego
+diehard
+dielectric
+dielectrics
+diem
+dies
+diesel
+diet
+dietary
+dieter
+dieters
+dietetic
+dietician
+dietitian
+dietitians
+Dietrich
+diets
+Dietz
+differ
+differed
+difference
+differences
+different
+differentiable
+differential
+differentials
+differentiate
+differentiated
+differentiates
+differentiating
+differentiation
+differentiations
+differentiators
+differently
+differer
+differers
+differing
+differs
+difficult
+difficulties
+difficultly
+difficulty
+diffract
+diffuse
+diffused
+diffusely
+diffuser
+diffusers
+diffuses
+diffusible
+diffusing
+diffusion
+diffusions
+diffusive
+dig
+digest
+digested
+digestible
+digesting
+digestion
+digestive
+digests
+digger
+diggers
+digging
+diggings
+digit
+digital
+digitalis
+digitally
+digitization
+digitize
+digitized
+digitizes
+digitizing
+digits
+dignified
+dignify
+dignitary
+dignities
+dignity
+digram
+digress
+digressed
+digresses
+digressing
+digression
+digressions
+digressive
+digs
+dihedral
+Dijkstra
+Dijon
+dike
+dikes
+dilapidate
+dilatation
+dilate
+dilated
+dilates
+dilating
+dilation
+dildo
+dilemma
+dilemmas
+diligence
+diligent
+diligently
+dill
+Dillon
+dilogarithm
+dilute
+diluted
+dilutes
+diluting
+dilution
+dim
+DiMaggio
+dime
+dimension
+dimensional
+dimensionality
+dimensionally
+dimensioned
+dimensioning
+dimensions
+dimes
+dimetrodon
+diminish
+diminished
+diminishes
+diminishing
+diminution
+diminutive
+dimly
+dimmed
+dimmer
+dimmers
+dimmest
+dimming
+dimness
+dimple
+dims
+din
+Dinah
+dine
+dined
+diner
+diners
+dines
+ding
+dinghy
+dinginess
+dingo
+dingy
+dining
+dinner
+dinners
+dinnertime
+dinnerware
+dinosaur
+dint
+Diocletian
+diode
+diodes
+Diogenes
+Dion
+Dionysian
+Dionysus
+Diophantine
+diopter
+diorama
+dioxide
+dip
+diphtheria
+diphthong
+Diplodocus
+diploma
+diplomacy
+diplomas
+diplomat
+diplomatic
+diplomats
+dipole
+dipped
+dipper
+dippers
+dipping
+dippings
+dips
+Dirac
+dire
+direct
+directed
+directing
+direction
+directional
+directionality
+directionally
+directions
+directive
+directives
+directly
+directness
+director
+directorate
+directories
+directors
+directory
+directrices
+directrix
+directs
+dirge
+dirges
+Dirichlet
+dirt
+dirtier
+dirtiest
+dirtily
+dirtiness
+dirts
+dirty
+Dis
+disabilities
+disability
+disable
+disabled
+disabler
+disablers
+disables
+disabling
+disadvantage
+disadvantageous
+disadvantages
+disaffected
+disaffection
+disagree
+disagreeable
+disagreed
+disagreeing
+disagreement
+disagreements
+disagrees
+disallow
+disallowed
+disallowing
+disallows
+disambiguate
+disambiguated
+disambiguates
+disambiguating
+disambiguation
+disambiguations
+disappear
+disappearance
+disappearances
+disappeared
+disappearing
+disappears
+disappoint
+disappointed
+disappointing
+disappointment
+disappointments
+disapproval
+disapprove
+disapproved
+disapproves
+disarm
+disarmament
+disarmed
+disarming
+disarms
+disassemble
+disassembled
+disassembles
+disassembling
+disassembly
+disaster
+disasters
+disastrous
+disastrously
+disband
+disbanded
+disbanding
+disbands
+disburse
+disbursed
+disbursement
+disbursements
+disburses
+disbursing
+disc
+discard
+discarded
+discarding
+discards
+discern
+discerned
+discernibility
+discernible
+discernibly
+discerning
+discerningly
+discernment
+discerns
+discharge
+discharged
+discharges
+discharging
+disciple
+disciples
+disciplinary
+discipline
+disciplined
+disciplines
+disciplining
+disclaim
+disclaimed
+disclaimer
+disclaims
+disclose
+disclosed
+discloses
+disclosing
+disclosure
+disclosures
+discomfort
+disconcert
+disconcerting
+disconcertingly
+disconnect
+disconnected
+disconnecting
+disconnection
+disconnects
+discontent
+discontented
+discontinuance
+discontinue
+discontinued
+discontinues
+discontinuities
+discontinuity
+discontinuous
+discord
+discordant
+discount
+discounted
+discounting
+discounts
+discourage
+discouraged
+discouragement
+discourages
+discouraging
+discourse
+discourses
+discover
+discovered
+discoverer
+discoverers
+discoveries
+discovering
+discovers
+discovery
+discredit
+discredited
+discreet
+discreetly
+discrepancies
+discrepancy
+discrete
+discretely
+discreteness
+discretion
+discretionary
+discriminant
+discriminate
+discriminated
+discriminates
+discriminating
+discrimination
+discriminatory
+discs
+discuss
+discussant
+discussed
+discusses
+discussing
+discussion
+discussions
+disdain
+disdaining
+disdains
+disease
+diseased
+diseases
+disembowel
+disengage
+disengaged
+disengages
+disengaging
+disentangle
+disentangling
+disfigure
+disfigured
+disfigures
+disfiguring
+disgorge
+disgrace
+disgraced
+disgraceful
+disgracefully
+disgraces
+disgruntle
+disgruntled
+disguise
+disguised
+disguises
+disgust
+disgusted
+disgustedly
+disgustful
+disgusting
+disgustingly
+disgusts
+dish
+dishearten
+disheartening
+dished
+dishes
+dishevel
+dishing
+dishonest
+dishonestly
+dishonesty
+dishonor
+dishonorable
+dishonored
+dishonoring
+dishonors
+dishwasher
+dishwashers
+dishwashing
+dishwater
+disillusion
+disillusioned
+disillusioning
+disillusionment
+disillusionments
+disinclined
+disingenuous
+disinterested
+disinterestedness
+disjoint
+disjointed
+disjointly
+disjointness
+disjunct
+disjunction
+disjunctions
+disjunctive
+disjunctively
+disjuncts
+disk
+diskette
+diskettes
+disks
+dislike
+disliked
+dislikes
+disliking
+dislocate
+dislocated
+dislocates
+dislocating
+dislocation
+dislocations
+dislodge
+dislodged
+dismal
+dismally
+dismay
+dismayed
+dismaying
+dismember
+dismembered
+dismemberment
+dismembers
+dismiss
+dismissal
+dismissals
+dismissed
+dismisser
+dismissers
+dismisses
+dismissing
+dismount
+dismounted
+dismounting
+dismounts
+Disney
+Disneyland
+disobedience
+disobedient
+disobey
+disobeyed
+disobeying
+disobeys
+disorder
+disordered
+disorderly
+disorders
+disorganized
+disown
+disowned
+disowning
+disowns
+disparage
+disparate
+disparities
+disparity
+dispassionate
+dispatch
+dispatched
+dispatcher
+dispatchers
+dispatches
+dispatching
+dispel
+dispell
+dispelled
+dispelling
+dispels
+dispensary
+dispensation
+dispense
+dispensed
+dispenser
+dispensers
+dispenses
+dispensing
+dispersal
+disperse
+dispersed
+disperses
+dispersing
+dispersion
+dispersions
+displace
+displaced
+displacement
+displacements
+displaces
+displacing
+display
+displayable
+displayed
+displayer
+displaying
+displays
+displease
+displeased
+displeases
+displeasing
+displeasure
+disposable
+disposal
+disposals
+dispose
+disposed
+disposer
+disposes
+disposing
+disposition
+dispositions
+dispossessed
+disproportionate
+disprove
+disproved
+disproves
+disproving
+dispute
+disputed
+disputer
+disputers
+disputes
+disputing
+disqualification
+disqualified
+disqualifies
+disqualify
+disqualifying
+disquiet
+disquieting
+Disraeli
+disregard
+disregarded
+disregarding
+disregards
+disrespectful
+disrupt
+disrupted
+disrupting
+disruption
+disruptions
+disruptive
+disrupts
+dissatisfaction
+dissatisfactions
+dissatisfactory
+dissatisfied
+dissect
+dissects
+dissemble
+disseminate
+disseminated
+disseminates
+disseminating
+dissemination
+dissension
+dissensions
+dissent
+dissented
+dissenter
+dissenters
+dissenting
+dissents
+dissertation
+dissertations
+disservice
+dissident
+dissidents
+dissimilar
+dissimilarities
+dissimilarity
+dissipate
+dissipated
+dissipates
+dissipating
+dissipation
+dissociate
+dissociated
+dissociates
+dissociating
+dissociation
+dissolution
+dissolutions
+dissolve
+dissolved
+dissolves
+dissolving
+dissonant
+dissuade
+distaff
+distal
+distally
+distance
+distances
+distant
+distantly
+distaste
+distasteful
+distastefully
+distastes
+distemper
+distempered
+distempers
+distill
+distillation
+distilled
+distiller
+distillers
+distillery
+distilling
+distills
+distinct
+distinction
+distinctions
+distinctive
+distinctively
+distinctiveness
+distinctly
+distinctness
+distinguish
+distinguishable
+distinguished
+distinguishes
+distinguishing
+distort
+distorted
+distorting
+distortion
+distortions
+distorts
+distract
+distracted
+distracting
+distraction
+distractions
+distracts
+distraught
+distress
+distressed
+distresses
+distressing
+distribute
+distributed
+distributes
+distributing
+distribution
+distributional
+distributions
+distributive
+distributivity
+distributor
+distributors
+district
+districts
+distrust
+distrusted
+disturb
+disturbance
+disturbances
+disturbed
+disturber
+disturbing
+disturbingly
+disturbs
+disuse
+ditch
+ditches
+dither
+ditto
+ditty
+Ditzel
+diurnal
+divan
+divans
+dive
+dived
+diver
+diverge
+diverged
+divergence
+divergences
+divergent
+diverges
+diverging
+divers
+diverse
+diversely
+diversification
+diversified
+diversifies
+diversify
+diversifying
+diversion
+diversionary
+diversions
+diversities
+diversity
+divert
+diverted
+diverting
+diverts
+dives
+divest
+divested
+divesting
+divestiture
+divests
+divide
+divided
+dividend
+dividends
+divider
+dividers
+divides
+dividing
+divine
+divinely
+diviner
+diving
+divining
+divinities
+divinity
+divisibility
+divisible
+division
+divisional
+divisions
+divisive
+divisor
+divisors
+divorce
+divorced
+divorcee
+divulge
+divulged
+divulges
+divulging
+Dixie
+Dixiecrats
+Dixieland
+Dixon
+dizziness
+dizzy
+Djakarta
+Dmitri
+Dnieper
+do
+Dobbin
+Dobbs
+Doberman
+Doc
+docile
+dock
+docked
+docket
+docks
+dockside
+dockyard
+doctor
+doctoral
+doctorate
+doctorates
+doctored
+doctors
+doctrinaire
+doctrinal
+doctrine
+doctrines
+document
+documentaries
+documentary
+documentation
+documentations
+documented
+documenter
+documenters
+documenting
+documents
+Dodd
+dodecahedra
+dodecahedral
+dodecahedron
+dodge
+dodged
+dodger
+dodgers
+dodging
+Dodington
+Dodson
+doe
+doer
+doers
+does
+dog
+Doge
+dogged
+doggedly
+doggedness
+dogging
+doghouse
+dogma
+dogmas
+dogmatic
+dogmatism
+dogs
+Dogtown
+Doherty
+doing
+doings
+Dolan
+doldrum
+dole
+doled
+doleful
+dolefully
+doles
+doll
+dollar
+dollars
+dollies
+dolls
+dolly
+Dolores
+dolphin
+dolphins
+domain
+domains
+dome
+domed
+Domenico
+domes
+Domesday
+domestic
+domestically
+domesticate
+domesticated
+domesticates
+domesticating
+domestication
+domicile
+dominance
+dominant
+dominantly
+dominate
+dominated
+dominates
+dominating
+domination
+domineer
+domineering
+Domingo
+Dominic
+Dominican
+Dominicans
+Dominick
+dominion
+Dominique
+domino
+don
+Donahue
+Donald
+Donaldson
+donate
+donated
+donates
+donating
+donation
+done
+Doneck
+donkey
+donkeys
+Donna
+Donnelly
+Donner
+donnybrook
+donor
+Donovan
+dons
+doodle
+Dooley
+Doolittle
+doom
+doomed
+dooming
+dooms
+doomsday
+door
+doorbell
+doorkeeper
+doorman
+doormen
+doors
+doorstep
+doorsteps
+doorway
+doorways
+dope
+doped
+doper
+dopers
+dopes
+doping
+Doppler
+Dora
+Dorado
+Dorcas
+Dorchester
+Doreen
+Doria
+Doric
+Doricize
+Doricizes
+Doris
+dormant
+dormitories
+dormitory
+Dorothea
+Dorothy
+Dorset
+Dortmund
+dosage
+dose
+dosed
+doses
+dossier
+dossiers
+Dostoevsky
+dot
+dote
+doted
+dotes
+doting
+dotingly
+dots
+dotted
+dotting
+double
+doubled
+Doubleday
+doubleheader
+doubler
+doublers
+doubles
+doublet
+doubleton
+doublets
+doubling
+doubloon
+doubly
+doubt
+doubtable
+doubted
+doubter
+doubters
+doubtful
+doubtfully
+doubting
+doubtless
+doubtlessly
+doubts
+Doug
+dough
+Dougherty
+doughnut
+doughnuts
+Douglas
+Douglass
+dove
+dover
+doves
+dovetail
+Dow
+dowager
+dowel
+Dowling
+down
+downcast
+downed
+downers
+Downey
+downfall
+downfallen
+downgrade
+downhill
+Downing
+downlink
+downlinks
+download
+downloaded
+downloading
+downloads
+downplay
+downplayed
+downplaying
+downplays
+downpour
+downright
+Downs
+downside
+downstairs
+downstream
+downtown
+downtowns
+downtrodden
+downturn
+downward
+downwards
+downy
+dowry
+Doyle
+doze
+dozed
+dozen
+dozens
+dozenth
+dozes
+dozing
+drab
+Draco
+Draconian
+draft
+drafted
+draftee
+drafter
+drafters
+drafting
+drafts
+draftsman
+draftsmen
+drafty
+drag
+dragged
+dragging
+dragnet
+dragon
+dragonfly
+dragonhead
+dragons
+dragoon
+dragooned
+dragoons
+drags
+drain
+drainage
+drained
+drainer
+draining
+drains
+drake
+dram
+drama
+Dramamine
+dramas
+dramatic
+dramatically
+dramatics
+dramatist
+dramatists
+drank
+drape
+draped
+draper
+draperies
+drapers
+drapery
+drapes
+drastic
+drastically
+draught
+draughts
+Dravidian
+draw
+drawback
+drawbacks
+drawbridge
+drawbridges
+drawer
+drawers
+drawing
+drawings
+drawl
+drawled
+drawling
+drawls
+drawn
+drawnly
+drawnness
+draws
+dread
+dreaded
+dreadful
+dreadfully
+dreading
+dreadnought
+dreads
+dream
+dreamboat
+dreamed
+dreamer
+dreamers
+dreamily
+dreaming
+dreamlike
+dreams
+dreamt
+dreamy
+dreariness
+dreary
+dredge
+dregs
+drench
+drenched
+drenches
+drenching
+dress
+dressed
+dresser
+dressers
+dresses
+dressing
+dressings
+dressmaker
+dressmakers
+drew
+Drexel
+Dreyfuss
+dried
+drier
+driers
+dries
+driest
+drift
+drifted
+drifter
+drifters
+drifting
+drifts
+drill
+drilled
+driller
+drilling
+drills
+drily
+drink
+drinkable
+drinker
+drinkers
+drinking
+drinks
+drip
+dripping
+drippy
+drips
+Driscoll
+drive
+driven
+driver
+drivers
+drives
+driveway
+driveways
+driving
+drizzle
+drizzly
+droll
+dromedary
+drone
+drones
+drool
+droop
+drooped
+drooping
+droops
+droopy
+drop
+droplet
+dropout
+dropped
+dropper
+droppers
+dropping
+droppings
+drops
+drosophila
+drought
+droughts
+drove
+drover
+drovers
+droves
+drown
+drowned
+drowning
+drownings
+drowns
+drowsiness
+drowsy
+drubbing
+drudge
+drudgery
+drug
+druggist
+druggists
+drugs
+drugstore
+drum
+drumhead
+drummed
+drummer
+drummers
+drumming
+Drummond
+drums
+drunk
+drunkard
+drunkards
+drunken
+drunkenness
+drunker
+drunkly
+drunks
+Drury
+dry
+Dryden
+drying
+dryly
+dual
+dualism
+dualities
+duality
+Duane
+dub
+dubbed
+Dubhe
+dubious
+dubiously
+dubiousness
+Dublin
+dubs
+Dubuque
+duchess
+duchesses
+duchy
+duck
+ducked
+ducking
+duckling
+ducks
+duct
+ducts
+dud
+Dudley
+due
+duel
+dueling
+duels
+dues
+duet
+Duffy
+dug
+Dugan
+duke
+dukes
+dull
+dulled
+duller
+Dulles
+dullest
+dulling
+dullness
+dulls
+dully
+Duluth
+duly
+dumb
+dumbbell
+dumbbells
+dumber
+dumbest
+dumbly
+dumbness
+dummies
+dummy
+dump
+dumped
+dumper
+dumping
+dumps
+Dumpty
+Dunbar
+Duncan
+dunce
+dunces
+Dundee
+dune
+Dunedin
+dunes
+dung
+dungeon
+dungeons
+Dunham
+dunk
+Dunkirk
+Dunlap
+Dunlop
+Dunn
+Dunne
+dupe
+duplex
+duplicable
+duplicate
+duplicated
+duplicates
+duplicating
+duplication
+duplications
+duplicator
+duplicators
+duplicity
+DuPont
+Dupont
+DuPonts
+Duponts
+Duquesne
+durabilities
+durability
+durable
+durably
+Durango
+duration
+durations
+Durer
+Durers
+duress
+Durham
+during
+Durkee
+Durkin
+Durrell
+Durward
+Dusenberg
+Dusenbury
+dusk
+duskiness
+dusky
+Dusseldorf
+dust
+dustbin
+dusted
+duster
+dusters
+dustier
+dustiest
+Dustin
+dusting
+dusts
+dusty
+Dutch
+dutchess
+Dutchman
+Dutchmen
+duties
+dutiful
+dutifully
+dutifulness
+Dutton
+duty
+Dvorak
+dwarf
+dwarfed
+dwarfs
+dwarves
+dwell
+dwelled
+dweller
+dwellers
+dwelling
+dwellings
+dwells
+dwelt
+Dwight
+dwindle
+dwindled
+dwindling
+Dwyer
+dyad
+dyadic
+dye
+dyed
+dyeing
+dyer
+dyers
+dyes
+dying
+Dyke
+Dylan
+dynamic
+dynamically
+dynamics
+dynamism
+dynamite
+dynamited
+dynamites
+dynamiting
+dynamo
+dynastic
+dynasties
+dynasty
+dyne
+dysentery
+dyspeptic
+dystrophy
+each
+Eagan
+eager
+eagerly
+eagerness
+eagle
+eagles
+ear
+eardrum
+eared
+earl
+earlier
+earliest
+earliness
+earls
+early
+earmark
+earmarked
+earmarking
+earmarkings
+earmarks
+earn
+earned
+earner
+earners
+earnest
+earnestly
+earnestness
+earning
+earnings
+earns
+Earp
+earphone
+earring
+earrings
+ears
+earsplitting
+earth
+earthen
+earthenware
+earthliness
+earthling
+earthly
+Earthman
+Earthmen
+earthmover
+earthquake
+earthquakes
+earths
+earthworm
+earthworms
+earthy
+ease
+eased
+easel
+easement
+easements
+eases
+easier
+easiest
+easily
+easiness
+easing
+east
+eastbound
+easter
+eastern
+easterner
+easterners
+easternmost
+Easthampton
+Eastland
+Eastman
+eastward
+eastwards
+Eastwick
+Eastwood
+easy
+easygoing
+eat
+eaten
+eater
+eaters
+eating
+eatings
+Eaton
+eats
+eaves
+eavesdrop
+eavesdropped
+eavesdropper
+eavesdroppers
+eavesdropping
+eavesdrops
+ebb
+ebbing
+ebbs
+Eben
+ebony
+eccentric
+eccentricities
+eccentricity
+eccentrics
+Eccles
+ecclesiastical
+echelon
+echo
+echoed
+echoes
+echoing
+eclectic
+eclipse
+eclipsed
+eclipses
+eclipsing
+ecliptic
+Ecole
+ecology
+econometric
+Econometrica
+economic
+economical
+economically
+economics
+economies
+economist
+economists
+economize
+economized
+economizer
+economizers
+economizes
+economizing
+economy
+ecosystem
+ecstasy
+ecstatic
+Ecuador
+Ecuadorian
+Ed
+Eddie
+eddies
+eddy
+Eden
+Edenization
+Edenizations
+Edenize
+Edenizes
+Edgar
+edge
+edged
+Edgerton
+edges
+Edgewater
+Edgewood
+edging
+edible
+edict
+edicts
+edifice
+edifices
+Edinburgh
+Edison
+edit
+edited
+Edith
+editing
+edition
+editions
+editor
+editorial
+editorially
+editorials
+editors
+edits
+Edmonds
+Edmondson
+Edmonton
+Edmund
+Edna
+Edsger
+Eduard
+Eduardo
+educable
+educate
+educated
+educates
+educating
+education
+educational
+educationally
+educations
+educator
+educators
+Edward
+Edwardian
+Edwardine
+Edwards
+Edwin
+Edwina
+eel
+eelgrass
+eels
+eerie
+eerily
+effect
+effected
+effecting
+effective
+effectively
+effectiveness
+effector
+effectors
+effects
+effectually
+effectuate
+effeminate
+efficacy
+efficiencies
+efficiency
+efficient
+efficiently
+Effie
+effigy
+effort
+effortless
+effortlessly
+effortlessness
+efforts
+egalitarian
+Egan
+egg
+egged
+egghead
+egging
+eggplant
+eggs
+eggshell
+ego
+egocentric
+egos
+egotism
+egotist
+Egypt
+Egyptian
+Egyptianization
+Egyptianizations
+Egyptianize
+Egyptianizes
+Egyptians
+Egyptize
+Egyptizes
+Egyptology
+Ehrlich
+Eichmann
+Eiffel
+eigenfunction
+eigenstate
+eigenvalue
+eigenvalues
+eigenvector
+eight
+eighteen
+eighteens
+eighteenth
+eightfold
+eighth
+eighthes
+eighties
+eightieth
+eights
+eighty
+Eileen
+Einstein
+Einsteinian
+Eire
+Eisenhower
+Eisner
+either
+ejaculate
+ejaculated
+ejaculates
+ejaculating
+ejaculation
+ejaculations
+eject
+ejected
+ejecting
+ejects
+Ekberg
+eke
+eked
+ekes
+Ekstrom
+Ektachrome
+elaborate
+elaborated
+elaborately
+elaborateness
+elaborates
+elaborating
+elaboration
+elaborations
+elaborators
+Elaine
+elapse
+elapsed
+elapses
+elapsing
+elastic
+elastically
+elasticity
+Elba
+elbow
+elbowing
+elbows
+elder
+elderly
+elders
+eldest
+Eldon
+Eleanor
+Eleazar
+elect
+elected
+electing
+election
+elections
+elective
+electives
+elector
+electoral
+electorate
+electors
+Electra
+electric
+electrical
+electrically
+electricalness
+electrician
+electricity
+electrification
+electrify
+electrifying
+electro
+electrocardiogram
+electrocardiograph
+electrocute
+electrocuted
+electrocutes
+electrocuting
+electrocution
+electrocutions
+electrode
+electrodes
+electroencephalogram
+electroencephalograph
+electroencephalography
+electrolysis
+electrolyte
+electrolytes
+electrolytic
+electromagnetic
+electromechanical
+electron
+electronic
+electronically
+electronics
+electrons
+electrophoresis
+electrophorus
+elects
+elegance
+elegant
+elegantly
+elegy
+element
+elemental
+elementals
+elementary
+elements
+Elena
+elephant
+elephants
+elevate
+elevated
+elevates
+elevation
+elevator
+elevators
+eleven
+elevens
+eleventh
+elf
+Elgin
+Eli
+elicit
+elicited
+eliciting
+elicits
+elide
+eligibility
+eligible
+Elijah
+eliminate
+eliminated
+eliminates
+eliminating
+elimination
+eliminations
+eliminator
+eliminators
+Elinor
+Eliot
+Elisabeth
+Elisha
+elision
+elite
+elitist
+Elizabeth
+Elizabethan
+Elizabethanize
+Elizabethanizes
+Elizabethans
+elk
+Elkhart
+elks
+Ella
+Ellen
+Ellie
+Elliot
+Elliott
+ellipse
+ellipses
+ellipsis
+ellipsoid
+ellipsoidal
+ellipsoids
+elliptic
+elliptical
+elliptically
+Ellis
+Ellison
+Ellsworth
+Ellwood
+elm
+Elmer
+Elmhurst
+Elmira
+elms
+Elmsford
+Eloise
+elope
+eloquence
+eloquent
+eloquently
+Elroy
+else
+Elsevier
+elsewhere
+Elsie
+Elsinore
+Elton
+elucidate
+elucidated
+elucidates
+elucidating
+elucidation
+elude
+eluded
+eludes
+eluding
+elusive
+elusively
+elusiveness
+elves
+Elvis
+Ely
+Elysee
+Elysees
+Elysium
+em
+emaciate
+emaciated
+emacs
+emanate
+emanating
+emancipate
+emancipation
+Emanuel
+emasculate
+embalm
+embargo
+embargoes
+embark
+embarked
+embarks
+embarrass
+embarrassed
+embarrasses
+embarrassing
+embarrassment
+embassies
+embassy
+embed
+embedded
+embedding
+embeds
+embellish
+embellished
+embellishes
+embellishing
+embellishment
+embellishments
+ember
+embezzle
+emblem
+embodied
+embodies
+embodiment
+embodiments
+embody
+embodying
+embolden
+embrace
+embraced
+embraces
+embracing
+embroider
+embroidered
+embroideries
+embroiders
+embroidery
+embroil
+embryo
+embryology
+embryos
+emerald
+emeralds
+emerge
+emerged
+emergence
+emergencies
+emergency
+emergent
+emerges
+emerging
+emeritus
+Emerson
+Emery
+emigrant
+emigrants
+emigrate
+emigrated
+emigrates
+emigrating
+emigration
+Emil
+Emile
+Emilio
+Emily
+eminence
+eminent
+eminently
+emissary
+emission
+emit
+emits
+emitted
+emitter
+emitting
+Emma
+Emmanuel
+Emmett
+Emory
+emotion
+emotional
+emotionally
+emotions
+empathy
+emperor
+emperors
+emphases
+emphasis
+emphasize
+emphasized
+emphasizes
+emphasizing
+emphatic
+emphatically
+empire
+empires
+empirical
+empirically
+empiricist
+empiricists
+employ
+employable
+employed
+employee
+employees
+employer
+employers
+employing
+employment
+employments
+employs
+emporium
+empower
+empowered
+empowering
+empowers
+empress
+emptied
+emptier
+empties
+emptiest
+emptily
+emptiness
+empty
+emptying
+emulate
+emulated
+emulates
+emulating
+emulation
+emulations
+emulator
+emulators
+en
+enable
+enabled
+enabler
+enablers
+enables
+enabling
+enact
+enacted
+enacting
+enactment
+enacts
+enamel
+enameled
+enameling
+enamels
+encamp
+encamped
+encamping
+encamps
+encapsulate
+encapsulated
+encapsulates
+encapsulating
+encapsulation
+encased
+enchant
+enchanted
+enchanter
+enchanting
+enchantment
+enchantress
+enchants
+encipher
+enciphered
+enciphering
+enciphers
+encircle
+encircled
+encircles
+enclose
+enclosed
+encloses
+enclosing
+enclosure
+enclosures
+encode
+encoded
+encoder
+encoders
+encodes
+encoding
+encodings
+encompass
+encompassed
+encompasses
+encompassing
+encore
+encounter
+encountered
+encountering
+encounters
+encourage
+encouraged
+encouragement
+encouragements
+encourages
+encouraging
+encouragingly
+encroach
+encrust
+encrypt
+encrypted
+encrypting
+encryption
+encryptions
+encrypts
+encumber
+encumbered
+encumbering
+encumbers
+encyclopedia
+encyclopedias
+encyclopedic
+end
+endanger
+endangered
+endangering
+endangers
+endear
+endeared
+endearing
+endears
+endeavor
+endeavored
+endeavoring
+endeavors
+ended
+endemic
+ender
+enders
+endgame
+Endicott
+ending
+endings
+endless
+endlessly
+endlessness
+endorse
+endorsed
+endorsement
+endorses
+endorsing
+endow
+endowed
+endowing
+endowment
+endowments
+endows
+endpoint
+ends
+endurable
+endurably
+endurance
+endure
+endured
+endures
+enduring
+enduringly
+enema
+enemas
+enemies
+enemy
+energetic
+energies
+energize
+energy
+enervate
+enfeeble
+Enfield
+enforce
+enforceable
+enforced
+enforcement
+enforcer
+enforcers
+enforces
+enforcing
+enfranchise
+Eng
+engage
+engaged
+engagement
+engagements
+engages
+engaging
+engagingly
+Engel
+Engels
+engender
+engendered
+engendering
+engenders
+engine
+engineer
+engineered
+engineering
+engineers
+engines
+England
+Englander
+Englanders
+Engle
+Englewood
+English
+Englishize
+Englishizes
+Englishman
+Englishmen
+engrave
+engraved
+engraver
+engraves
+engraving
+engravings
+engross
+engrossed
+engrossing
+engulf
+enhance
+enhanced
+enhancement
+enhancements
+enhances
+enhancing
+Enid
+enigma
+enigmatic
+enjoin
+enjoined
+enjoining
+enjoins
+enjoy
+enjoyable
+enjoyably
+enjoyed
+enjoying
+enjoyment
+enjoys
+enlarge
+enlarged
+enlargement
+enlargements
+enlarger
+enlargers
+enlarges
+enlarging
+enlighten
+enlightened
+enlightening
+enlightenment
+enlist
+enlisted
+enlistment
+enlists
+enliven
+enlivened
+enlivening
+enlivens
+enmities
+enmity
+ennoble
+ennobled
+ennobles
+ennobling
+ennui
+Enoch
+enormities
+enormity
+enormous
+enormously
+Enos
+enough
+enqueue
+enqueued
+enqueues
+enquire
+enquired
+enquirer
+enquires
+enquiry
+enrage
+enraged
+enrages
+enraging
+enrapture
+enrich
+enriched
+enriches
+enriching
+Enrico
+enroll
+enrolled
+enrolling
+enrollment
+enrollments
+enrolls
+ensemble
+ensembles
+ensign
+ensigns
+enslave
+enslaved
+enslaves
+enslaving
+ensnare
+ensnared
+ensnares
+ensnaring
+Ensolite
+ensue
+ensued
+ensues
+ensuing
+ensure
+ensured
+ensurer
+ensurers
+ensures
+ensuring
+entail
+entailed
+entailing
+entails
+entangle
+enter
+entered
+entering
+enterprise
+enterprises
+enterprising
+enters
+entertain
+entertained
+entertainer
+entertainers
+entertaining
+entertainingly
+entertainment
+entertainments
+entertains
+enthusiasm
+enthusiasms
+enthusiast
+enthusiastic
+enthusiastically
+enthusiasts
+entice
+enticed
+enticer
+enticers
+entices
+enticing
+entire
+entirely
+entireties
+entirety
+entities
+entitle
+entitled
+entitles
+entitling
+entity
+entomb
+entrance
+entranced
+entrances
+entrap
+entreat
+entreated
+entreaty
+entree
+entrench
+entrenched
+entrenches
+entrenching
+entrepreneur
+entrepreneurial
+entrepreneurs
+entries
+entropy
+entrust
+entrusted
+entrusting
+entrusts
+entry
+enumerable
+enumerate
+enumerated
+enumerates
+enumerating
+enumeration
+enumerative
+enumerator
+enumerators
+enunciation
+envelop
+envelope
+enveloped
+enveloper
+envelopes
+enveloping
+envelops
+envied
+envies
+envious
+enviously
+enviousness
+environ
+environing
+environment
+environmental
+environments
+environs
+envisage
+envisaged
+envisages
+envision
+envisioned
+envisioning
+envisions
+envoy
+envoys
+envy
+enzyme
+Eocene
+epaulet
+epaulets
+ephemeral
+Ephesian
+Ephesians
+Ephesus
+Ephraim
+epic
+epicenter
+epics
+Epicurean
+Epicurize
+Epicurizes
+Epicurus
+epidemic
+epidemics
+epidermis
+epigram
+epileptic
+epilogue
+Epiphany
+episcopal
+Episcopalian
+Episcopalianize
+Episcopalianizes
+episode
+episodes
+epistemological
+epistemology
+epistle
+epistles
+epitaph
+epitaphs
+epitaxial
+epitaxially
+epithet
+epithets
+epitomize
+epitomized
+epitomizes
+epitomizing
+epoch
+epochs
+epsilon
+Epsom
+Epstein
+equal
+equaled
+equaling
+equalities
+equality
+equalization
+equalize
+equalized
+equalizer
+equalizers
+equalizes
+equalizing
+equally
+equals
+equate
+equated
+equates
+equating
+equation
+equations
+equator
+equatorial
+equators
+equestrian
+equidistant
+equilateral
+equilibrate
+equilibria
+equilibrium
+equilibriums
+equinox
+equip
+equipment
+equipoise
+equipped
+equipping
+equips
+equitable
+equitably
+equity
+equivalence
+equivalences
+equivalent
+equivalently
+equivalents
+equivocal
+equivocally
+era
+eradicate
+eradicated
+eradicates
+eradicating
+eradication
+eras
+erasable
+erase
+erased
+eraser
+erasers
+erases
+erasing
+Erasmus
+Erastus
+erasure
+Erato
+Eratosthenes
+ere
+erect
+erected
+erecting
+erection
+erections
+erector
+erectors
+erects
+erg
+ergo
+ergodic
+Eric
+Erich
+Erickson
+Ericsson
+Erie
+Erik
+Erikson
+Eris
+Erlang
+Erlenmeyer
+Erlenmeyers
+ermine
+ermines
+Erne
+Ernest
+Ernestine
+Ernie
+Ernst
+erode
+Eros
+erosion
+erotic
+erotica
+err
+errand
+errant
+errata
+erratic
+erratum
+erred
+erring
+erringly
+Errol
+erroneous
+erroneously
+erroneousness
+error
+errors
+errs
+ersatz
+Erskine
+erudite
+erupt
+eruption
+Ervin
+Erwin
+escalate
+escalated
+escalates
+escalating
+escalation
+escapable
+escapade
+escapades
+escape
+escaped
+escapee
+escapees
+escapes
+escaping
+Escherichia
+eschew
+eschewed
+eschewing
+eschews
+escort
+escorted
+escorting
+escorts
+escrow
+Eskimo
+Eskimoized
+Eskimoizeds
+Eskimos
+Esmark
+esoteric
+Espagnol
+especial
+especially
+espionage
+Esposito
+espouse
+espoused
+espouses
+espousing
+esprit
+espy
+esquire
+esquires
+essay
+essayed
+essays
+Essen
+essence
+essences
+Essenize
+Essenizes
+essential
+essentially
+essentials
+Essex
+establish
+established
+establishes
+establishing
+establishment
+establishments
+estate
+estates
+esteem
+esteemed
+esteeming
+esteems
+Estella
+Estes
+Esther
+esthetics
+estimate
+estimated
+estimates
+estimating
+estimation
+estimations
+Estonia
+Estonian
+et
+etch
+etching
+eternal
+eternally
+eternities
+eternity
+Ethan
+Ethel
+ether
+ethereal
+ethereally
+Ethernet
+Ethernets
+ethers
+ethic
+ethical
+ethically
+ethics
+Ethiopia
+Ethiopians
+ethnic
+etiquette
+Etruria
+Etruscan
+etymology
+eucalyptus
+Eucharist
+Euclid
+Euclidean
+Eugene
+Eugenia
+Euler
+Eulerian
+Eumenides
+Eunice
+eunuch
+eunuchs
+euphemism
+euphemisms
+euphoria
+euphoric
+Euphrates
+Eurasia
+Eurasian
+eureka
+Euripides
+Europa
+Europe
+European
+Europeanization
+Europeanizations
+Europeanize
+Europeanized
+Europeanizes
+Europeans
+Eurydice
+Euterpe
+euthanasia
+Eva
+evacuate
+evacuated
+evacuation
+evade
+evaded
+evades
+evading
+evaluate
+evaluated
+evaluates
+evaluating
+evaluation
+evaluations
+evaluative
+evaluator
+evaluators
+Evangeline
+Evans
+Evanston
+Evansville
+evaporate
+evaporated
+evaporating
+evaporation
+evaporative
+evasion
+evasive
+Eve
+Evelyn
+even
+evened
+evenhanded
+evenhandedly
+evenhandedness
+evening
+evenings
+evenly
+evenness
+evens
+Evensen
+event
+eventful
+eventfully
+events
+eventual
+eventualities
+eventuality
+eventually
+ever
+Eveready
+Everest
+Everett
+Everglade
+Everglades
+evergreen
+Everhart
+everlasting
+everlastingly
+evermore
+every
+everybody
+everyday
+everyone
+everything
+everywhere
+evict
+evicted
+evicting
+eviction
+evictions
+evicts
+evidence
+evidenced
+evidences
+evidencing
+evident
+evidently
+evil
+eviller
+evilly
+evils
+evince
+evinced
+evinces
+evoke
+evoked
+evokes
+evoking
+evolute
+evolutes
+evolution
+evolutionary
+evolutions
+evolve
+evolved
+evolves
+evolving
+ewe
+Ewen
+ewes
+Ewing
+ex
+exacerbate
+exacerbated
+exacerbates
+exacerbating
+exacerbation
+exacerbations
+exact
+exacted
+exacting
+exactingly
+exaction
+exactions
+exactitude
+exactly
+exactness
+exacts
+exaggerate
+exaggerated
+exaggerates
+exaggerating
+exaggeration
+exaggerations
+exalt
+exaltation
+exalted
+exalting
+exalts
+exam
+examination
+examinations
+examine
+examined
+examiner
+examiners
+examines
+examining
+example
+examples
+exams
+exasperate
+exasperated
+exasperates
+exasperating
+exasperation
+excavate
+excavated
+excavates
+excavating
+excavation
+excavations
+exceed
+exceeded
+exceeding
+exceedingly
+exceeds
+excel
+excelled
+excellence
+excellences
+excellency
+excellent
+excellently
+excelling
+excels
+except
+excepted
+excepting
+exception
+exceptionable
+exceptional
+exceptionally
+exceptions
+excepts
+excerpt
+excerpted
+excerpts
+excess
+excesses
+excessive
+excessively
+exchange
+exchangeable
+exchanged
+exchanges
+exchanging
+exchequer
+exchequers
+excise
+excised
+excises
+excising
+excision
+excitable
+excitation
+excitations
+excite
+excited
+excitedly
+excitement
+excites
+exciting
+excitingly
+exciton
+exclaim
+exclaimed
+exclaimer
+exclaimers
+exclaiming
+exclaims
+exclamation
+exclamations
+exclamatory
+exclude
+excluded
+excludes
+excluding
+exclusion
+exclusionary
+exclusions
+exclusive
+exclusively
+exclusiveness
+exclusivity
+excommunicate
+excommunicated
+excommunicates
+excommunicating
+excommunication
+excrete
+excreted
+excretes
+excreting
+excretion
+excretions
+excretory
+excruciate
+excursion
+excursions
+excusable
+excusably
+excuse
+excused
+excuses
+excusing
+exec
+executable
+execute
+executed
+executes
+executing
+execution
+executional
+executioner
+executions
+executive
+executives
+executor
+executors
+exemplar
+exemplary
+exemplification
+exemplified
+exemplifier
+exemplifiers
+exemplifies
+exemplify
+exemplifying
+exempt
+exempted
+exempting
+exemption
+exempts
+exercise
+exercised
+exerciser
+exercisers
+exercises
+exercising
+exert
+exerted
+exerting
+exertion
+exertions
+exerts
+Exeter
+exhale
+exhaled
+exhales
+exhaling
+exhaust
+exhausted
+exhaustedly
+exhausting
+exhaustion
+exhaustive
+exhaustively
+exhausts
+exhibit
+exhibited
+exhibiting
+exhibition
+exhibitions
+exhibitor
+exhibitors
+exhibits
+exhilarate
+exhort
+exhortation
+exhortations
+exhume
+exigency
+exile
+exiled
+exiles
+exiling
+exist
+existed
+existence
+existent
+existential
+existentialism
+existentialist
+existentialists
+existentially
+existing
+exists
+exit
+exited
+exiting
+exits
+exodus
+exorbitant
+exorbitantly
+exorcism
+exorcist
+exoskeleton
+exotic
+expand
+expandable
+expanded
+expander
+expanders
+expanding
+expands
+expanse
+expanses
+expansible
+expansion
+expansionism
+expansions
+expansive
+expect
+expectancy
+expectant
+expectantly
+expectation
+expectations
+expected
+expectedly
+expecting
+expectingly
+expects
+expediency
+expedient
+expediently
+expedite
+expedited
+expedites
+expediting
+expedition
+expeditions
+expeditious
+expeditiously
+expel
+expelled
+expelling
+expels
+expend
+expendable
+expended
+expending
+expenditure
+expenditures
+expends
+expense
+expenses
+expensive
+expensively
+experience
+experienced
+experiences
+experiencing
+experiment
+experimental
+experimentally
+experimentation
+experimentations
+experimented
+experimenter
+experimenters
+experimenting
+experiments
+expert
+expertise
+expertly
+expertness
+experts
+expiration
+expirations
+expire
+expired
+expires
+expiring
+explain
+explainable
+explained
+explainer
+explainers
+explaining
+explains
+explanation
+explanations
+explanatory
+expletive
+explicit
+explicitly
+explicitness
+explode
+exploded
+explodes
+exploding
+exploit
+exploitable
+exploitation
+exploitations
+exploited
+exploiter
+exploiters
+exploiting
+exploits
+exploration
+explorations
+exploratory
+explore
+explored
+explorer
+explorers
+explores
+exploring
+explosion
+explosions
+explosive
+explosively
+explosives
+exponent
+exponential
+exponentially
+exponentials
+exponentiate
+exponentiated
+exponentiates
+exponentiating
+exponentiation
+exponentiations
+exponents
+export
+exportation
+exported
+exporter
+exporters
+exporting
+exports
+expose
+exposed
+exposer
+exposers
+exposes
+exposing
+exposition
+expositions
+expository
+exposure
+exposures
+expound
+expounded
+expounder
+expounding
+expounds
+express
+expressed
+expresses
+expressibility
+expressible
+expressibly
+expressing
+expression
+expressions
+expressive
+expressively
+expressiveness
+expressly
+expulsion
+expunge
+expunged
+expunges
+expunging
+expurgate
+exquisite
+exquisitely
+exquisiteness
+extant
+extemporaneous
+extend
+extendable
+extended
+extending
+extends
+extensibility
+extensible
+extension
+extensions
+extensive
+extensively
+extent
+extents
+extenuate
+extenuated
+extenuating
+extenuation
+exterior
+exteriors
+exterminate
+exterminated
+exterminates
+exterminating
+extermination
+external
+externally
+extinct
+extinction
+extinguish
+extinguished
+extinguisher
+extinguishes
+extinguishing
+extirpate
+extol
+extort
+extorted
+extortion
+extra
+extract
+extracted
+extracting
+extraction
+extractions
+extractor
+extractors
+extracts
+extracurricular
+extramarital
+extraneous
+extraneously
+extraneousness
+extraordinarily
+extraordinariness
+extraordinary
+extrapolate
+extrapolated
+extrapolates
+extrapolating
+extrapolation
+extrapolations
+extras
+extraterrestrial
+extravagance
+extravagant
+extravagantly
+extravaganza
+extremal
+extreme
+extremely
+extremes
+extremist
+extremists
+extremities
+extremity
+extricate
+extrinsic
+extrovert
+exuberance
+exult
+exultation
+Exxon
+eye
+eyeball
+eyebrow
+eyebrows
+eyed
+eyeful
+eyeglass
+eyeglasses
+eyeing
+eyelash
+eyelid
+eyelids
+eyepiece
+eyepieces
+eyer
+eyers
+eyes
+eyesight
+eyewitness
+eyewitnesses
+eying
+Ezekiel
+Ezra
+Faber
+Fabian
+fable
+fabled
+fables
+fabric
+fabricate
+fabricated
+fabricates
+fabricating
+fabrication
+fabrics
+fabulous
+fabulously
+facade
+facaded
+facades
+face
+faced
+faces
+facet
+faceted
+facetious
+facets
+facial
+facile
+facilely
+facilitate
+facilitated
+facilitates
+facilitating
+facilities
+facility
+facing
+facings
+facsimile
+facsimiles
+fact
+faction
+factions
+factious
+facto
+factor
+factored
+factorial
+factories
+factoring
+factorization
+factorizations
+factors
+factory
+facts
+factual
+factually
+faculties
+faculty
+fade
+faded
+fadeout
+fader
+faders
+fades
+fading
+Fafnir
+fag
+Fagin
+fags
+Fahey
+Fahrenheit
+Fahrenheits
+fail
+failed
+failing
+failings
+fails
+failsoft
+failure
+failures
+fain
+faint
+fainted
+fainter
+faintest
+fainting
+faintly
+faintness
+faints
+fair
+Fairbanks
+Fairchild
+fairer
+fairest
+Fairfax
+Fairfield
+fairies
+fairing
+fairly
+Fairmont
+fairness
+Fairport
+fairs
+Fairview
+fairy
+fairyland
+faith
+faithful
+faithfully
+faithfulness
+faithless
+faithlessly
+faithlessness
+faiths
+fake
+faked
+faker
+fakes
+faking
+falcon
+falconer
+falcons
+Falk
+Falkland
+Falklands
+fall
+fallacies
+fallacious
+fallacy
+fallen
+fallibility
+fallible
+falling
+Fallopian
+fallout
+fallow
+falls
+Falmouth
+false
+falsehood
+falsehoods
+falsely
+falseness
+falsification
+falsified
+falsifies
+falsify
+falsifying
+falsity
+Falstaff
+falter
+faltered
+falters
+fame
+famed
+fames
+familial
+familiar
+familiarities
+familiarity
+familiarization
+familiarize
+familiarized
+familiarizes
+familiarizing
+familiarly
+familiarness
+families
+familism
+family
+famine
+famines
+famish
+famous
+famously
+fan
+fanatic
+fanaticism
+fanatics
+fancied
+fancier
+fanciers
+fancies
+fanciest
+fanciful
+fancifully
+fancily
+fanciness
+fancy
+fancying
+fanfare
+fanfold
+fang
+fangled
+fangs
+fanned
+Fannies
+fanning
+Fanny
+fanout
+fans
+fantasies
+fantasize
+fantastic
+fantasy
+FAQ
+far
+farad
+Faraday
+faraway
+Farber
+farce
+farces
+fare
+fared
+fares
+farewell
+farewells
+farfetched
+Fargo
+farina
+faring
+Farkas
+Farley
+farm
+farmed
+farmer
+farmers
+farmhouse
+farmhouses
+farming
+Farmington
+farmland
+farms
+farmyard
+farmyards
+Farnsworth
+Farrell
+farsighted
+farther
+farthest
+farthing
+fascicle
+fascinate
+fascinated
+fascinates
+fascinating
+fascination
+fascism
+fascist
+fashion
+fashionable
+fashionably
+fashioned
+fashioning
+fashions
+fast
+fasted
+fasten
+fastened
+fastener
+fasteners
+fastening
+fastenings
+fastens
+faster
+fastest
+fastidious
+fasting
+fastness
+fasts
+fat
+fatal
+fatalities
+fatality
+fatally
+fatals
+fate
+fated
+fateful
+fates
+father
+fathered
+fatherland
+fatherly
+fathers
+fathom
+fathomed
+fathoming
+fathoms
+fatigue
+fatigued
+fatigues
+fatiguing
+Fatima
+fatness
+fats
+fatten
+fattened
+fattener
+fatteners
+fattening
+fattens
+fatter
+fattest
+fatty
+faucet
+Faulkner
+Faulknerian
+fault
+faulted
+faulting
+faultless
+faultlessly
+faults
+faulty
+faun
+fauna
+Fauntleroy
+Faust
+Faustian
+Faustus
+favor
+favorable
+favorably
+favored
+favorer
+favoring
+favorite
+favorites
+favoritism
+favors
+Fawkes
+fawn
+fawned
+fawning
+fawns
+Fayette
+Fayetteville
+faze
+Fe
+fear
+feared
+fearful
+fearfully
+fearing
+fearless
+fearlessly
+fearlessness
+fears
+fearsome
+feasibility
+feasible
+feast
+feasted
+feasting
+feasts
+feat
+feather
+featherbed
+featherbedding
+feathered
+featherer
+featherers
+feathering
+Featherman
+feathers
+featherweight
+feathery
+feats
+feature
+featured
+features
+featuring
+Februaries
+February
+fecund
+fed
+Fedders
+federal
+federalist
+federally
+federals
+federation
+Fedora
+fee
+feeble
+feebleness
+feebler
+feeblest
+feebly
+feed
+feedback
+feeder
+feeders
+feeding
+feedings
+feeds
+feel
+feeler
+feelers
+feeling
+feelingly
+feelings
+feels
+Feeney
+fees
+feet
+feign
+feigned
+feigning
+Felder
+Feldman
+Felice
+Felicia
+felicities
+felicity
+feline
+Felix
+fell
+fellatio
+felled
+felling
+Fellini
+fellow
+fellows
+fellowship
+fellowships
+felon
+felonious
+felony
+felt
+felts
+female
+females
+feminine
+femininity
+feminism
+feminist
+femur
+femurs
+fen
+fence
+fenced
+fencer
+fencers
+fences
+fencing
+fend
+Fenton
+Fenwick
+Ferber
+Ferdinand
+Ferdinando
+Ferguson
+Fermat
+ferment
+fermentation
+fermentations
+fermented
+fermenting
+ferments
+Fermi
+fern
+Fernando
+ferns
+ferocious
+ferociously
+ferociousness
+ferocity
+Ferreira
+Ferrer
+ferret
+ferried
+ferries
+ferrite
+ferry
+fertile
+fertilely
+fertility
+fertilization
+fertilize
+fertilized
+fertilizer
+fertilizers
+fertilizes
+fertilizing
+fervent
+fervently
+fervor
+fervors
+Fess
+festival
+festivals
+festive
+festively
+festivities
+festivity
+fetal
+fetch
+fetched
+fetches
+fetching
+fetchingly
+fetid
+fetish
+fetter
+fettered
+fetters
+fettle
+fetus
+feud
+feudal
+feudalism
+feuds
+fever
+fevered
+feverish
+feverishly
+fevers
+few
+fewer
+fewest
+fewness
+fiance
+fiancee
+fiasco
+fiat
+fib
+fibbing
+fiber
+Fiberglas
+fibers
+Fibonacci
+fibrosities
+fibrosity
+fibrous
+fibrously
+fickle
+fickleness
+fiction
+fictional
+fictionally
+fictions
+fictitious
+fictitiously
+fiddle
+fiddled
+fiddler
+fiddles
+fiddlestick
+fiddlesticks
+fiddling
+Fidel
+fidelity
+fidget
+fiducial
+fief
+fiefdom
+field
+fielded
+fielder
+fielders
+fielding
+Fields
+fieldwork
+fiend
+fiendish
+fierce
+fiercely
+fierceness
+fiercer
+fiercest
+fiery
+fife
+fifteen
+fifteens
+fifteenth
+fifth
+fifties
+fiftieth
+fifty
+fig
+Figaro
+fight
+fighter
+fighters
+fighting
+fights
+figs
+figurative
+figuratively
+figure
+figured
+figures
+figuring
+figurings
+Fiji
+Fijian
+Fijians
+filament
+filaments
+file
+filed
+filename
+filenames
+filer
+files
+filial
+filibuster
+filing
+filings
+Filipino
+Filipinos
+Filippo
+fill
+fillable
+filled
+filler
+fillers
+filling
+fillings
+Fillmore
+fills
+filly
+film
+filmed
+filming
+films
+filter
+filtered
+filtering
+filters
+filth
+filthier
+filthiest
+filthiness
+filthy
+fin
+final
+finality
+finalization
+finalize
+finalized
+finalizes
+finalizing
+finally
+finals
+finance
+financed
+finances
+financial
+financially
+financier
+financiers
+financing
+find
+finder
+finders
+finding
+findings
+finds
+fine
+fined
+finely
+fineness
+finer
+fines
+finesse
+finessed
+finessing
+finest
+finger
+fingered
+fingering
+fingerings
+fingernail
+fingerprint
+fingerprints
+fingers
+fingertip
+finicky
+fining
+finish
+finished
+finisher
+finishers
+finishes
+finishing
+finite
+finitely
+finiteness
+fink
+Finland
+Finley
+Finn
+Finnegan
+Finnish
+Finns
+finny
+fins
+Fiorello
+Fiori
+fir
+fire
+firearm
+firearms
+fireboat
+firebreak
+firebug
+firecracker
+fired
+fireflies
+firefly
+firehouse
+firelight
+fireman
+firemen
+fireplace
+fireplaces
+firepower
+fireproof
+firer
+firers
+fires
+fireside
+Firestone
+firewall
+firewood
+fireworks
+firing
+firings
+firm
+firmament
+firmed
+firmer
+firmest
+firming
+firmly
+firmness
+firms
+firmware
+first
+firsthand
+firstly
+firsts
+fiscal
+fiscally
+Fischbein
+Fischer
+fish
+fished
+fisher
+fisherman
+fishermen
+fishers
+fishery
+fishes
+fishing
+Fishkill
+fishmonger
+fishpond
+fishy
+Fisk
+Fiske
+fission
+fissure
+fissured
+fist
+fisted
+fisticuff
+fists
+fit
+Fitch
+Fitchburg
+fitful
+fitfully
+fitly
+fitness
+fits
+fitted
+fitter
+fitters
+fitting
+fittingly
+fittings
+Fitzgerald
+Fitzpatrick
+Fitzroy
+five
+fivefold
+fives
+fix
+fixate
+fixated
+fixates
+fixating
+fixation
+fixations
+fixed
+fixedly
+fixedness
+fixer
+fixers
+fixes
+fixing
+fixings
+fixture
+fixtures
+Fizeau
+fizzle
+fizzled
+flabbergast
+flabbergasted
+flack
+flag
+flagellate
+flagged
+flagging
+Flagler
+flagpole
+flagrant
+flagrantly
+flags
+Flagstaff
+flail
+flair
+flak
+flake
+flaked
+flakes
+flaking
+flaky
+flam
+flamboyant
+flame
+flamed
+flamer
+flamers
+flames
+flaming
+flammable
+Flanagan
+Flanders
+flank
+flanked
+flanker
+flanking
+flanks
+flannel
+flannels
+flap
+flaps
+flare
+flared
+flares
+flaring
+flash
+flashback
+flashed
+flasher
+flashers
+flashes
+flashing
+flashlight
+flashlights
+flashy
+flask
+flat
+flatbed
+flatly
+flatness
+flats
+flatten
+flattened
+flattening
+flatter
+flattered
+flatterer
+flattering
+flattery
+flattest
+flatulent
+flatus
+flatworm
+flaunt
+flaunted
+flaunting
+flaunts
+flavor
+flavored
+flavoring
+flavorings
+flavors
+flaw
+flawed
+flawless
+flawlessly
+flaws
+flax
+flaxen
+flea
+fleas
+fled
+Fledermaus
+fledged
+fledgling
+fledglings
+flee
+fleece
+fleeces
+fleecy
+fleeing
+flees
+fleet
+fleetest
+fleeting
+fleetly
+fleetness
+fleets
+Fleischman
+Fleisher
+Fleming
+Flemings
+Flemish
+Flemished
+Flemishes
+Flemishing
+flesh
+fleshed
+fleshes
+fleshing
+fleshly
+fleshy
+Fletcher
+Fletcherize
+Fletcherizes
+flew
+flex
+flexibilities
+flexibility
+flexible
+flexibly
+flick
+flicked
+flicker
+flickering
+flicking
+flicks
+flier
+fliers
+flies
+flight
+flights
+flimsy
+flinch
+flinched
+flinches
+flinching
+fling
+flings
+flint
+flinty
+flip
+flipflop
+flipped
+flips
+flirt
+flirtation
+flirtatious
+flirted
+flirting
+flirts
+flit
+flitting
+Flo
+float
+floated
+floater
+floating
+floats
+flock
+flocked
+flocking
+flocks
+flog
+flogging
+flood
+flooded
+flooding
+floodlight
+floodlit
+floods
+floor
+floored
+flooring
+floorings
+floors
+flop
+floppies
+floppily
+flopping
+floppy
+flops
+flora
+floral
+Florence
+Florentine
+florid
+Florida
+Floridian
+Floridians
+florin
+florist
+floss
+flossed
+flosses
+flossing
+flotation
+flotilla
+flounder
+floundered
+floundering
+flounders
+flour
+floured
+flourish
+flourished
+flourishes
+flourishing
+flow
+flowchart
+flowcharting
+flowcharts
+flowed
+flower
+flowered
+floweriness
+flowering
+flowerpot
+flowers
+flowery
+flowing
+flown
+flows
+Floyd
+flu
+fluctuate
+fluctuates
+fluctuating
+fluctuation
+fluctuations
+flue
+fluency
+fluent
+fluently
+fluff
+fluffier
+fluffiest
+fluffy
+fluid
+fluidity
+fluidly
+fluids
+fluke
+flung
+flunked
+fluoresce
+fluorescent
+flurried
+flurry
+flush
+flushed
+flushes
+flushing
+flute
+fluted
+fluting
+flutter
+fluttered
+fluttering
+flutters
+flux
+fly
+flyable
+flyer
+flyers
+flying
+Flynn
+foal
+foam
+foamed
+foaming
+foams
+foamy
+fob
+fobbing
+focal
+focally
+foci
+focus
+focused
+focuses
+focusing
+focussed
+fodder
+foe
+foes
+fog
+Fogarty
+fogged
+foggier
+foggiest
+foggily
+fogging
+foggy
+fogs
+fogy
+foible
+foil
+foiled
+foiling
+foils
+foist
+fold
+folded
+folder
+folders
+folding
+foldout
+folds
+Foley
+foliage
+folk
+folklore
+folks
+folksong
+folksy
+follies
+follow
+followed
+follower
+followers
+following
+followings
+follows
+folly
+Folsom
+Fomalhaut
+fond
+fonder
+fondle
+fondled
+fondles
+fondling
+fondly
+fondness
+font
+Fontaine
+Fontainebleau
+Fontana
+fonts
+food
+foods
+foodstuff
+foodstuffs
+fool
+fooled
+foolhardy
+fooling
+foolish
+foolishly
+foolishness
+foolproof
+fools
+foot
+footage
+football
+footballs
+footbridge
+Foote
+footed
+footer
+footers
+footfall
+foothill
+foothold
+footing
+footman
+footnote
+footnotes
+footpath
+footprint
+footprints
+footstep
+footsteps
+for
+forage
+foraged
+forages
+foraging
+foray
+forays
+forbade
+forbear
+forbearance
+forbears
+Forbes
+forbid
+forbidden
+forbidding
+forbids
+force
+forced
+forceful
+forcefully
+forcefulness
+forcer
+forces
+forcible
+forcibly
+forcing
+ford
+Fordham
+fords
+fore
+forearm
+forearms
+foreboding
+forecast
+forecasted
+forecaster
+forecasters
+forecasting
+forecastle
+forecasts
+forefather
+forefathers
+forefinger
+forefingers
+forego
+foregoes
+foregoing
+foregone
+foreground
+forehead
+foreheads
+foreign
+foreigner
+foreigners
+foreigns
+foreman
+foremost
+forenoon
+forensic
+forerunners
+foresee
+foreseeable
+foreseen
+foresees
+foresight
+foresighted
+forest
+forestall
+forestalled
+forestalling
+forestallment
+forestalls
+forested
+forester
+foresters
+forestry
+forests
+foretell
+foretelling
+foretells
+foretold
+forever
+forewarn
+forewarned
+forewarning
+forewarnings
+forewarns
+forfeit
+forfeited
+forfeiture
+forgave
+forge
+forged
+forger
+forgeries
+forgery
+forges
+forget
+forgetful
+forgetfulness
+forgets
+forgettable
+forgettably
+forgetting
+forging
+forgivable
+forgivably
+forgive
+forgiven
+forgiveness
+forgives
+forgiving
+forgivingly
+forgot
+forgotten
+fork
+forked
+forking
+forklift
+forks
+forlorn
+forlornly
+form
+formal
+formalism
+formalisms
+formalities
+formality
+formalization
+formalizations
+formalize
+formalized
+formalizes
+formalizing
+formally
+formant
+formants
+format
+formation
+formations
+formative
+formatively
+formats
+formatted
+formatter
+formatters
+formatting
+formed
+former
+formerly
+Formica
+Formicas
+formidable
+forming
+Formosa
+Formosan
+forms
+formula
+formulae
+formulas
+formulate
+formulated
+formulates
+formulating
+formulation
+formulations
+formulator
+formulators
+fornication
+Forrest
+forsake
+forsaken
+forsakes
+forsaking
+Forsythe
+fort
+forte
+Fortescue
+FORTH
+forthcoming
+forthright
+forthwith
+fortier
+forties
+fortieth
+fortification
+fortifications
+fortified
+fortifies
+fortify
+fortifying
+fortiori
+fortitude
+fortnight
+fortnightly
+FORTRAN
+Fortran
+fortress
+fortresses
+forts
+fortuitous
+fortuitously
+fortunate
+fortunately
+fortune
+fortunes
+forty
+forum
+forums
+forward
+forwarded
+forwarder
+forwarding
+forwardness
+forwards
+Foss
+fossil
+foster
+fostered
+fostering
+fosters
+fought
+foul
+fouled
+foulest
+fouling
+foully
+foulmouth
+foulness
+fouls
+found
+foundation
+foundations
+founded
+founder
+foundered
+founders
+founding
+foundling
+foundries
+foundry
+founds
+fount
+fountain
+fountains
+founts
+four
+fourfold
+Fourier
+fours
+fourscore
+foursome
+foursquare
+fourteen
+fourteens
+fourteenth
+fourth
+fowl
+fowler
+fowls
+fox
+foxes
+Foxhall
+fraction
+fractional
+fractionally
+fractions
+fracture
+fractured
+fractures
+fracturing
+fragile
+fragment
+fragmentary
+fragmentation
+fragmented
+fragmenting
+fragments
+fragrance
+fragrances
+fragrant
+fragrantly
+frail
+frailest
+frailty
+frame
+framed
+framer
+frames
+framework
+frameworks
+framing
+Fran
+franc
+Francaise
+France
+Frances
+Francesca
+Francesco
+franchise
+franchises
+Francie
+Francine
+Francis
+Franciscan
+Franciscans
+Francisco
+Francize
+Francizes
+Franco
+Francois
+Francoise
+francs
+frank
+franked
+Frankel
+franker
+frankest
+Frankfort
+Frankfurt
+Frankie
+franking
+Franklinization
+Franklinizations
+frankly
+frankness
+franks
+Franny
+frantic
+frantically
+Franz
+Fraser
+fraternal
+fraternally
+fraternities
+fraternity
+Frau
+fraud
+frauds
+fraudulent
+fraught
+fray
+frayed
+fraying
+Frayne
+frays
+Frazier
+frazzle
+freak
+freakish
+freaks
+freckle
+freckled
+freckles
+Fred
+Freddie
+Freddy
+Frederic
+Frederick
+Fredericks
+Fredericksburg
+Frederico
+Fredericton
+Fredholm
+Fredrick
+Fredrickson
+free
+freed
+Freedman
+freedom
+freedoms
+freeing
+freeings
+freely
+freeman
+Freemason
+Freemasonry
+Freemasons
+freeness
+Freeport
+freer
+frees
+freest
+freestyle
+Freetown
+freeway
+freewheel
+freeze
+freezer
+freezers
+freezes
+freezing
+Freida
+freight
+freighted
+freighter
+freighters
+freighting
+freights
+French
+Frenchize
+Frenchizes
+Frenchman
+Frenchmen
+frenetic
+frenzied
+frenzy
+freon
+frequencies
+frequency
+frequent
+frequented
+frequenter
+frequenters
+frequenting
+frequently
+frequents
+fresco
+frescoes
+fresh
+freshen
+freshened
+freshener
+fresheners
+freshening
+freshens
+fresher
+freshest
+freshly
+freshman
+freshmen
+freshness
+freshwater
+Fresnel
+Fresno
+fret
+fretful
+fretfully
+fretfulness
+Freud
+Freudian
+Freudianism
+Freudianisms
+Freudians
+Frey
+Freya
+friar
+friars
+fricative
+fricatives
+Frick
+friction
+frictionless
+frictions
+Friday
+Fridays
+fried
+Friedman
+Friedrich
+friend
+friendless
+friendlier
+friendliest
+friendliness
+friendly
+friends
+friendship
+friendships
+fries
+Friesland
+frieze
+friezes
+frigate
+frigates
+Frigga
+fright
+frighten
+frightened
+frightening
+frighteningly
+frightens
+frightful
+frightfully
+frightfulness
+frigid
+Frigidaire
+frill
+frills
+fringe
+fringed
+Frisbee
+Frisia
+Frisian
+frisk
+frisked
+frisking
+frisks
+frisky
+Frito
+fritter
+Fritz
+frivolity
+frivolous
+frivolously
+fro
+frock
+frocks
+frog
+frogs
+frolic
+frolics
+from
+front
+frontage
+frontal
+fronted
+frontier
+frontiers
+frontiersman
+frontiersmen
+fronting
+fronts
+frost
+Frostbelt
+frostbite
+frostbitten
+frosted
+frosting
+frosts
+frosty
+froth
+frothing
+frothy
+frown
+frowned
+frowning
+frowns
+froze
+frozen
+frozenly
+fructose
+Fruehauf
+frugal
+frugally
+fruit
+fruitful
+fruitfully
+fruitfulness
+fruition
+fruitless
+fruitlessly
+fruits
+frustrate
+frustrated
+frustrates
+frustrating
+frustration
+frustrations
+fry
+Frye
+Fuchs
+Fuchsia
+fudge
+fuel
+fueled
+fueling
+fuels
+fugitive
+fugitives
+fugue
+Fuji
+Fujitsu
+Fulbright
+Fulbrights
+fulcrum
+fulfill
+fulfilled
+fulfilling
+fulfillment
+fulfillments
+fulfills
+full
+fuller
+Fullerton
+fullest
+fullness
+fully
+fulminate
+Fulton
+fumble
+fumbled
+fumbling
+fume
+fumed
+fumes
+fuming
+fun
+function
+functional
+functionalities
+functionality
+functionally
+functionals
+functionary
+functioned
+functioning
+functions
+functor
+functors
+fund
+fundamental
+fundamentally
+fundamentals
+funded
+funder
+funders
+funding
+funds
+funeral
+funerals
+funereal
+fungal
+fungi
+fungible
+fungicide
+fungus
+funk
+funnel
+funneled
+funneling
+funnels
+funnier
+funniest
+funnily
+funniness
+funny
+fur
+furies
+furious
+furiouser
+furiously
+furlong
+furlough
+Furman
+furnace
+furnaces
+furnish
+furnished
+furnishes
+furnishing
+furnishings
+furniture
+furrier
+furrow
+furrowed
+furrows
+furry
+furs
+further
+furthered
+furthering
+furthermore
+furthermost
+furthers
+furthest
+furtive
+furtively
+furtiveness
+fury
+fuse
+fused
+fuses
+fusing
+fusion
+fuss
+fussing
+fussy
+futile
+futility
+future
+futures
+futuristic
+fuzz
+fuzzier
+fuzziness
+fuzzy
+gab
+gabardine
+gabbing
+Gaberones
+gable
+gabled
+gabler
+gables
+Gabon
+Gaborone
+Gabriel
+Gabrielle
+gad
+gadfly
+gadget
+gadgetry
+gadgets
+Gaelic
+Gaelicization
+Gaelicizations
+Gaelicize
+Gaelicizes
+gag
+gagged
+gagging
+gaging
+gags
+gaieties
+gaiety
+Gail
+gaily
+gain
+gained
+gainer
+gainers
+Gaines
+Gainesville
+gainful
+gaining
+gains
+gait
+gaited
+gaiter
+gaiters
+Gaithersburg
+galactic
+galactose
+Galahad
+Galapagos
+Galatea
+Galatean
+Galateans
+Galatia
+Galatians
+galaxies
+galaxy
+Galbreath
+gale
+Galen
+Galilean
+Galilee
+Galileo
+gall
+Gallagher
+gallant
+gallantly
+gallantry
+gallants
+galled
+galleried
+galleries
+gallery
+galley
+galleys
+galling
+gallon
+gallons
+gallop
+galloped
+galloper
+galloping
+gallops
+Galloway
+gallows
+galls
+gallstone
+Gallup
+Galois
+Galt
+Galveston
+Galvin
+Galway
+Gambia
+gambit
+gamble
+gambled
+gambler
+gamblers
+gambles
+gambling
+gambol
+game
+gamed
+gamely
+gameness
+games
+gaming
+gamma
+gander
+Gandhi
+Gandhian
+gang
+Ganges
+gangland
+gangling
+gangplank
+gangrene
+gangs
+gangster
+gangsters
+Gannett
+gantry
+Ganymede
+gap
+gape
+gaped
+gapes
+gaping
+gaps
+garage
+garaged
+garages
+garb
+garbage
+garbages
+garbed
+garble
+garbled
+Garcia
+garden
+gardened
+gardener
+gardeners
+gardening
+gardens
+Gardner
+Garfield
+Garfunkel
+gargantuan
+gargle
+gargled
+gargles
+gargling
+Garibaldi
+garland
+garlanded
+garlic
+garment
+garments
+garner
+garnered
+Garnett
+garnish
+Garrett
+garrison
+garrisoned
+Garrisonian
+Garry
+garter
+garters
+Garth
+Garvey
+Gary
+gas
+Gascony
+gaseous
+gaseously
+gases
+gash
+gashes
+gasket
+gaslight
+gasoline
+gasp
+gasped
+Gaspee
+gasping
+gasps
+gassed
+gasser
+Gasset
+gassing
+gassings
+gassy
+Gaston
+gastric
+gastrointestinal
+gastronome
+gastronomy
+gate
+gated
+Gates
+gateway
+gateways
+gather
+gathered
+gatherer
+gatherers
+gathering
+gatherings
+gathers
+gating
+Gatlinburg
+gator
+Gatsby
+gauche
+gaudiness
+gaudy
+gauge
+gauged
+gauges
+Gauguin
+Gaul
+Gaulle
+Gauls
+gaunt
+Gauntley
+gauntness
+Gaussian
+Gautama
+gauze
+gave
+gavel
+Gavin
+gawk
+gawky
+gay
+gayer
+gayest
+gayety
+Gaylor
+Gaylord
+gayly
+gayness
+Gaynor
+gaze
+gazed
+gazelle
+gazer
+gazers
+gazes
+gazette
+gazing
+gear
+geared
+gearing
+gears
+Geary
+gecko
+geese
+Gehrig
+Geiger
+Geigy
+geisha
+gel
+gelatin
+gelatine
+gelatinous
+geld
+gelled
+gelling
+gels
+gem
+Gemini
+Geminid
+Gemma
+gems
+gender
+genders
+gene
+genealogy
+general
+generalist
+generalists
+generalities
+generality
+generalization
+generalizations
+generalize
+generalized
+generalizer
+generalizers
+generalizes
+generalizing
+generally
+generals
+generate
+generated
+generates
+generating
+generation
+generations
+generative
+generator
+generators
+generic
+generically
+generosities
+generosity
+generous
+generously
+generousness
+genes
+Genesco
+genesis
+genetic
+genetically
+Geneva
+Genevieve
+genial
+genially
+genie
+genius
+geniuses
+Genoa
+genre
+genres
+gent
+genteel
+gentile
+gentle
+gentleman
+gentlemanly
+gentlemen
+gentleness
+gentler
+gentlest
+gentlewoman
+gently
+gentry
+genuine
+genuinely
+genuineness
+genus
+geocentric
+geodesic
+geodesy
+geodetic
+Geoff
+Geoffrey
+geographer
+geographic
+geographical
+geographically
+geography
+geological
+geologist
+geologists
+geology
+geometric
+geometrical
+geometrically
+geometrician
+geometries
+geometry
+geophysical
+geophysics
+George
+Georges
+Georgetown
+Georgia
+Georgian
+Georgians
+geosynchronous
+Gerald
+Geraldine
+geranium
+Gerard
+Gerber
+gerbil
+Gerhard
+Gerhardt
+geriatric
+germ
+German
+germane
+Germania
+Germanic
+Germans
+Germantown
+Germany
+germicide
+germinal
+germinate
+germinated
+germinates
+germinating
+germination
+germs
+Gerome
+Gerry
+Gershwin
+Gershwins
+Gertrude
+gerund
+Gestapo
+gesture
+gestured
+gestures
+gesturing
+get
+getaway
+gets
+getter
+getters
+getting
+Getty
+Gettysburg
+geyser
+Ghana
+Ghanian
+ghastly
+Ghent
+ghetto
+ghost
+ghosted
+ghostly
+ghosts
+Giacomo
+giant
+giants
+gibberish
+Gibbons
+Gibbs
+Gibby
+Gibraltar
+Gibson
+giddiness
+Giddings
+giddy
+Gideon
+Gifford
+gift
+gifted
+gifts
+gig
+gigabit
+gigabits
+gigabyte
+gigabytes
+gigacycle
+gigahertz
+gigantic
+gigavolt
+gigawatt
+giggle
+giggled
+giggles
+giggling
+Gil
+Gilbertson
+Gilchrist
+gild
+gilded
+gilding
+gilds
+Gilead
+Giles
+Gilkson
+gill
+Gillespie
+Gillette
+Gilligan
+gills
+Gilmore
+gilt
+Gimbel
+gimmick
+gimmicks
+gin
+Gina
+ginger
+gingerbread
+gingerly
+gingham
+ginghams
+Ginn
+Gino
+gins
+Ginsberg
+Ginsburg
+Gioconda
+Giorgio
+Giovanni
+Gipsies
+Gipsy
+giraffe
+giraffes
+gird
+girder
+girders
+girdle
+girl
+girlfriend
+girlie
+girlish
+girls
+girt
+girth
+gist
+Giuliano
+Giuseppe
+give
+giveaway
+given
+giver
+givers
+gives
+giving
+glacial
+glacier
+glaciers
+glad
+gladden
+gladder
+gladdest
+glade
+gladiator
+gladly
+gladness
+Gladstone
+Gladys
+glamor
+glamorous
+glamour
+glance
+glanced
+glances
+glancing
+gland
+glands
+glandular
+glare
+glared
+glares
+glaring
+glaringly
+Glasgow
+glass
+glassed
+glasses
+glassy
+Glaswegian
+glaucoma
+glaze
+glazed
+glazer
+glazes
+glazing
+gleam
+gleamed
+gleaming
+gleams
+glean
+gleaned
+gleaner
+gleaning
+gleanings
+gleans
+Gleason
+glee
+gleeful
+gleefully
+glees
+glen
+Glenda
+Glendale
+Glenn
+glens
+Glidden
+glide
+glided
+glider
+gliders
+glides
+glimmer
+glimmered
+glimmering
+glimmers
+glimpse
+glimpsed
+glimpses
+glint
+glinted
+glinting
+glints
+glisten
+glistened
+glistening
+glistens
+glitch
+glitter
+glittered
+glittering
+glitters
+gloat
+global
+globally
+globe
+globes
+globular
+globularity
+gloom
+gloomily
+gloomy
+Gloria
+Gloriana
+glories
+glorification
+glorified
+glorifies
+glorify
+glorious
+gloriously
+glory
+glorying
+gloss
+glossaries
+glossary
+glossed
+glosses
+glossing
+glossy
+glottal
+Gloucester
+glove
+gloved
+glover
+glovers
+gloves
+gloving
+glow
+glowed
+glower
+glowers
+glowing
+glowingly
+glows
+glucose
+glue
+glued
+glues
+gluing
+glut
+glutton
+Glynn
+gnash
+gnat
+gnats
+gnaw
+gnawed
+gnawing
+gnaws
+gnome
+gnomon
+gnu
+go
+Goa
+goad
+goaded
+goal
+goals
+goat
+goatee
+goatees
+goats
+gobble
+gobbled
+gobbler
+gobblers
+gobbles
+Gobi
+goblet
+goblets
+goblin
+goblins
+god
+Goddard
+goddess
+goddesses
+godfather
+Godfrey
+godhead
+godlike
+godly
+godmother
+godmothers
+Godot
+godparent
+gods
+godsend
+godson
+Godwin
+Godzilla
+goes
+Goethe
+Goff
+goggles
+Gogh
+going
+goings
+gold
+Golda
+Goldberg
+golden
+goldenly
+goldenness
+goldenrod
+Goldfield
+goldfish
+golding
+Goldman
+golds
+goldsmith
+Goldstein
+Goldstine
+Goldwater
+Goleta
+golf
+golfer
+golfers
+golfing
+Goliath
+golly
+Gomez
+gondola
+gone
+goner
+gong
+gongs
+Gonzales
+Gonzalez
+good
+goodby
+goodbye
+Goode
+goodies
+goodly
+Goodman
+goodness
+Goodrich
+goods
+goodwill
+Goodwin
+goody
+Goodyear
+goof
+goofed
+goofs
+goofy
+goose
+gopher
+Gordian
+Gordon
+gore
+Goren
+gorge
+gorgeous
+gorgeously
+gorges
+gorging
+Gorham
+gorilla
+gorillas
+Gorky
+Gorton
+gory
+gosh
+gospel
+gospelers
+gospels
+gossip
+gossiped
+gossiping
+gossips
+got
+Gotham
+Gothic
+Gothically
+Gothicism
+Gothicize
+Gothicized
+Gothicizer
+Gothicizers
+Gothicizes
+Gothicizing
+GOTO
+GOTOs
+gotten
+Gottfried
+Goucher
+Gouda
+gouge
+gouged
+gouges
+gouging
+Gould
+gourd
+gourmet
+gout
+govern
+governance
+governed
+governess
+governing
+government
+governmental
+governmentally
+governments
+governor
+governors
+governs
+gown
+gowned
+gowns
+grab
+grabbed
+grabber
+grabbers
+grabbing
+grabbings
+grabs
+grace
+graced
+graceful
+gracefully
+gracefulness
+graces
+Gracie
+gracing
+gracious
+graciously
+graciousness
+grad
+gradation
+gradations
+grade
+graded
+grader
+graders
+grades
+gradient
+gradients
+grading
+gradings
+gradual
+gradually
+graduate
+graduated
+graduates
+graduating
+graduation
+graduations
+Grady
+Graff
+graft
+grafted
+grafter
+grafting
+Grafton
+grafts
+graham
+grahams
+grail
+grain
+grained
+graining
+grains
+gram
+grammar
+grammarian
+grammars
+grammatic
+grammatical
+grammatically
+grams
+granaries
+granary
+grand
+grandchild
+grandchildren
+granddaughter
+grander
+grandest
+grandeur
+grandfather
+grandfathers
+grandiose
+grandly
+grandma
+grandmother
+grandmothers
+grandnephew
+grandness
+grandniece
+grandpa
+grandparent
+grands
+grandson
+grandsons
+grandstand
+grange
+granite
+granny
+granola
+grant
+granted
+grantee
+granter
+granting
+grantor
+grants
+granularity
+granulate
+granulated
+granulates
+granulating
+Granville
+grape
+grapefruit
+grapes
+grapevine
+graph
+graphed
+graphic
+graphical
+graphically
+graphics
+graphing
+graphite
+graphs
+grapple
+grappled
+grappling
+grasp
+graspable
+grasped
+grasping
+graspingly
+grasps
+grass
+grassed
+grassers
+grasses
+grassier
+grassiest
+grassland
+grassy
+grate
+grated
+grateful
+gratefully
+gratefulness
+grater
+grates
+gratification
+gratified
+gratify
+gratifying
+grating
+gratings
+gratis
+gratitude
+gratuities
+gratuitous
+gratuitously
+gratuitousness
+gratuity
+grave
+gravel
+gravelly
+gravely
+graven
+graveness
+graver
+Graves
+gravest
+gravestone
+graveyard
+gravitate
+gravitation
+gravitational
+gravity
+gravy
+gray
+grayed
+grayer
+grayest
+graying
+grayness
+Grayson
+graze
+grazed
+grazer
+grazing
+grease
+greased
+greases
+greasy
+great
+greater
+greatest
+greatly
+greatness
+Grecian
+Grecianize
+Grecianizes
+Greece
+greed
+greedily
+greediness
+greedy
+Greek
+Greekize
+Greekizes
+Greeks
+green
+Greenbelt
+Greenberg
+Greenblatt
+Greenbriar
+Greene
+greener
+greenery
+greenest
+Greenfeld
+Greenfield
+greengrocer
+greenhouse
+greenhouses
+greening
+greenish
+Greenland
+greenly
+greenness
+greens
+Greensboro
+Greensville
+Greentree
+Greenville
+greenware
+Greenwich
+Greer
+greet
+greeted
+greeter
+greeting
+greetings
+greets
+Greg
+gregarious
+Gregg
+Gregorian
+Gregory
+grenade
+grenades
+Grendel
+Grenier
+Grenoble
+Grenville
+Gresham
+Greta
+Gretchen
+grew
+grey
+greyest
+greyhound
+greying
+grid
+griddle
+gridiron
+grids
+grief
+griefs
+grievance
+grievances
+grieve
+grieved
+griever
+grievers
+grieves
+grieving
+grievingly
+grievous
+grievously
+Griffith
+grill
+grilled
+grilling
+grills
+grim
+grimace
+Grimaldi
+grime
+grimed
+Grimes
+grimly
+Grimm
+grimness
+grin
+grind
+grinder
+grinders
+grinding
+grindings
+grinds
+grindstone
+grindstones
+grinning
+grins
+grip
+gripe
+griped
+gripes
+griping
+gripped
+gripping
+grippingly
+grips
+Gris
+grisly
+grist
+Griswold
+grit
+grits
+gritty
+grizzly
+groan
+groaned
+groaner
+groaners
+groaning
+groans
+grocer
+groceries
+grocers
+grocery
+groggy
+groin
+groom
+groomed
+grooming
+grooms
+Groot
+groove
+grooved
+grooves
+grope
+groped
+gropes
+groping
+gross
+grossed
+grosser
+grosses
+grossest
+Grosset
+grossing
+grossly
+Grossman
+grossness
+Grosvenor
+grotesque
+grotesquely
+grotesques
+Groton
+grotto
+grottos
+ground
+grounded
+grounder
+grounders
+grounding
+grounds
+groundwork
+group
+grouped
+grouping
+groupings
+groups
+grouse
+grove
+grovel
+groveled
+groveling
+grovels
+Grover
+grovers
+groves
+grow
+grower
+growers
+growing
+growl
+growled
+growling
+growls
+grown
+grownup
+grownups
+grows
+growth
+growths
+grub
+grubby
+grubs
+grudge
+grudges
+grudgingly
+gruesome
+gruff
+gruffly
+grumble
+grumbled
+grumbles
+grumbling
+Grumman
+grunt
+grunted
+grunting
+grunts
+Grusky
+Gruyere
+Guadalupe
+Guam
+guano
+guarantee
+guaranteed
+guaranteeing
+guaranteer
+guaranteers
+guarantees
+guaranty
+guard
+guarded
+guardedly
+guardhouse
+Guardia
+guardian
+guardians
+guardianship
+guarding
+guards
+Guatemala
+Guatemalan
+gubernatorial
+Guelph
+Guenther
+guerrilla
+guerrillas
+guess
+guessed
+guesses
+guessing
+guesswork
+guest
+guests
+Guggenheim
+Guhleman
+Guiana
+guidance
+guide
+guidebook
+guidebooks
+guided
+guideline
+guidelines
+guides
+guiding
+guild
+guilder
+guilders
+guile
+Guilford
+guilt
+guiltier
+guiltiest
+guiltily
+guiltiness
+guiltless
+guiltlessly
+guilty
+guinea
+Guinevere
+guise
+guises
+guitar
+guitars
+Gujarat
+Gujarati
+gulch
+gulches
+gulf
+gulfs
+gull
+Gullah
+gulled
+gullible
+gullies
+gulling
+gulls
+gully
+gulp
+gulped
+gulps
+gum
+gumming
+gumption
+gums
+gun
+Gunderson
+gunfire
+gunman
+gunmen
+Gunnar
+gunned
+gunner
+gunners
+gunnery
+gunning
+gunny
+gunplay
+gunpowder
+guns
+gunshot
+Gunther
+gurgle
+Gurkha
+guru
+Gus
+gush
+gushed
+gusher
+gushes
+gushing
+gust
+Gustafson
+Gustav
+Gustave
+Gustavus
+gusto
+gusts
+gusty
+gut
+Gutenberg
+Guthrie
+guts
+gutsy
+gutter
+guttered
+gutters
+gutting
+guttural
+guy
+Guyana
+guyed
+guyer
+guyers
+guying
+guys
+Gwen
+Gwyn
+gymnasium
+gymnasiums
+gymnast
+gymnastic
+gymnastics
+gymnasts
+gypsies
+gypsy
+gyro
+gyrocompass
+gyroscope
+gyroscopes
+ha
+Haag
+Haas
+habeas
+Haberman
+Habib
+habit
+habitat
+habitation
+habitations
+habitats
+habits
+habitual
+habitually
+habitualness
+hack
+hacked
+hacker
+hackers
+Hackett
+hacking
+hackneyed
+hacks
+hacksaw
+had
+Hadamard
+Haddad
+haddock
+Hades
+Hadley
+Hadrian
+Hafiz
+hag
+Hagen
+Hager
+haggard
+haggardly
+haggle
+Hagstrom
+Hague
+Hahn
+Haifa
+hail
+hailed
+hailing
+hails
+hailstone
+hailstorm
+Haines
+hair
+haircut
+haircuts
+hairier
+hairiness
+hairless
+hairpin
+hairs
+hairy
+Haiti
+Haitian
+Hal
+halcyon
+hale
+haler
+Haley
+half
+halfhearted
+halfway
+Halifax
+hall
+Halley
+Hallinan
+hallmark
+hallmarks
+hallow
+hallowed
+Halloween
+halls
+hallucinate
+hallway
+hallways
+halogen
+Halpern
+Halsey
+Halstead
+halt
+halted
+halter
+halters
+halting
+haltingly
+halts
+halve
+halved
+halvers
+Halverson
+halves
+halving
+ham
+Hamal
+Hamburg
+hamburger
+hamburgers
+Hamey
+Hamilton
+Hamiltonian
+Hamiltonians
+hamlet
+hamlets
+Hamlin
+hammer
+hammered
+hammering
+hammers
+Hammett
+hamming
+hammock
+hammocks
+Hammond
+hamper
+hampered
+hampers
+Hampshire
+Hampton
+hams
+hamster
+Han
+Hancock
+hand
+handbag
+handbags
+handbook
+handbooks
+handcuff
+handcuffed
+handcuffing
+handcuffs
+handed
+Handel
+handful
+handfuls
+handgun
+handicap
+handicapped
+handicaps
+handier
+handiest
+handily
+handiness
+handing
+handiwork
+handkerchief
+handkerchiefs
+handle
+handled
+handler
+handlers
+handles
+handling
+handmaid
+handout
+hands
+handshake
+handshakes
+handshaking
+handsome
+handsomely
+handsomeness
+handsomer
+handsomest
+handwriting
+handwritten
+handy
+Haney
+Hanford
+hang
+hangar
+hangars
+hanged
+hanger
+hangers
+hanging
+hangman
+hangmen
+hangout
+hangover
+hangovers
+hangs
+Hankel
+Hanley
+Hanlon
+Hanna
+Hannah
+Hannibal
+Hanoi
+Hanover
+Hanoverian
+Hanoverianize
+Hanoverianizes
+Hanoverize
+Hanoverizes
+Hans
+Hansel
+Hansen
+Hanson
+Hanukkah
+hap
+Hapgood
+haphazard
+haphazardly
+haphazardness
+hapless
+haplessly
+haplessness
+haply
+happen
+happened
+happening
+happenings
+happens
+happier
+happiest
+happily
+happiness
+happy
+Hapsburg
+harass
+harassed
+harasses
+harassing
+harassment
+Harbin
+harbinger
+harbor
+harbored
+harboring
+harbors
+Harcourt
+hard
+hardboiled
+hardcopy
+harden
+harder
+hardest
+hardhat
+Hardin
+hardiness
+Harding
+hardly
+hardness
+hardscrabble
+hardship
+hardships
+hardware
+hardwired
+hardworking
+hardy
+hare
+harelip
+harem
+hares
+hark
+harken
+Harlan
+Harlem
+Harley
+harlot
+harlots
+harm
+harmed
+harmful
+harmfully
+harmfulness
+harming
+harmless
+harmlessly
+harmlessness
+Harmon
+harmonic
+harmonics
+harmonies
+harmonious
+harmoniously
+harmoniousness
+Harmonist
+Harmonistic
+Harmonistically
+harmonize
+harmony
+harms
+harness
+harnessed
+harnessing
+Harold
+harp
+harper
+harpers
+harping
+Harpy
+harried
+harrier
+Harriet
+Harriman
+Harrington
+Harris
+Harrisburg
+Harrison
+Harrisonburg
+harrow
+harrowed
+harrowing
+harrows
+harry
+harsh
+harsher
+harshly
+harshness
+hart
+Hartford
+Hartley
+Hartman
+Harvard
+Harvardize
+Harvardizes
+harvest
+harvested
+harvester
+harvesting
+harvests
+Harvey
+Harveyize
+Harveyizes
+Harveys
+has
+hash
+hashed
+hasher
+hashes
+hashing
+hashish
+Haskell
+Haskins
+hassle
+haste
+hasten
+hastened
+hastening
+hastens
+hastily
+hastiness
+Hastings
+hasty
+hat
+hatch
+hatched
+hatchet
+hatchets
+hatching
+Hatchure
+hate
+hated
+hateful
+hatefully
+hatefulness
+hater
+hates
+Hatfield
+Hathaway
+hating
+hatred
+hats
+Hatteras
+Hattie
+Hattiesburg
+Hattize
+Hattizes
+Haugen
+haughtily
+haughtiness
+haughty
+haul
+hauled
+hauler
+hauling
+hauls
+haunch
+haunches
+haunt
+haunted
+haunter
+haunting
+haunts
+Hausa
+Hausdorff
+Hauser
+Havana
+have
+haven
+havens
+haves
+Havilland
+having
+havoc
+Hawaii
+Hawaiian
+hawk
+hawked
+hawker
+hawkers
+Hawkins
+hawks
+Hawley
+Hawthorne
+hay
+Hayden
+Haydn
+Hayes
+haying
+Haynes
+Hays
+haystack
+Hayward
+Haywood
+hazard
+hazardous
+hazards
+haze
+hazel
+hazes
+haziness
+hazy
+he
+head
+headache
+headaches
+headed
+header
+headers
+headgear
+heading
+headings
+headland
+headlands
+headlight
+headline
+headlined
+headlines
+headlining
+headlong
+headmaster
+headphone
+headquarters
+headroom
+heads
+headset
+headway
+heal
+healed
+healer
+healers
+Healey
+healing
+heals
+health
+healthful
+healthfully
+healthfulness
+healthier
+healthiest
+healthily
+healthiness
+healthy
+Healy
+heap
+heaped
+heaping
+heaps
+hear
+heard
+hearer
+hearers
+hearing
+hearings
+hearken
+hears
+hearsay
+Hearst
+heart
+heartbeat
+heartbreak
+hearten
+heartiest
+heartily
+heartiness
+heartless
+hearts
+Heartwood
+hearty
+heat
+heatable
+heated
+heatedly
+heater
+heaters
+heath
+heathen
+heather
+Heathkit
+Heathman
+heating
+heats
+heave
+heaved
+heaven
+heavenly
+heavens
+heaver
+heavers
+heaves
+heavier
+heaviest
+heavily
+heaviness
+heaving
+heavy
+heavyweight
+Hebe
+Hebraic
+Hebraicize
+Hebraicizes
+Hebrew
+Hebrews
+Hebrides
+Hecate
+heck
+heckle
+Heckman
+hectic
+Hecuba
+Hedda
+hedge
+hedged
+hedgehog
+hedgehogs
+hedges
+hedonism
+hedonist
+heed
+heeded
+heedless
+heedlessly
+heedlessness
+heeds
+heel
+heeled
+heelers
+heeling
+heels
+hefty
+Hegel
+Hegelian
+Hegelianize
+Hegelianizes
+hegemony
+Heidegger
+Heidelberg
+heifer
+height
+heighten
+heightened
+heightening
+heightens
+heights
+Heine
+Heinlein
+heinous
+heinously
+Heinrich
+Heinz
+Heinze
+heir
+heiress
+heiresses
+heirs
+Heisenberg
+Heiser
+held
+Helen
+Helena
+Helene
+Helga
+helical
+helicopter
+heliocentric
+Heliopolis
+helium
+helix
+hell
+Hellenic
+Hellenization
+Hellenizations
+Hellenize
+Hellenized
+Hellenizes
+Hellenizing
+Hellespont
+hellfire
+hellish
+Hellman
+hello
+hells
+helm
+helmet
+helmets
+Helmholtz
+helmsman
+Helmut
+help
+helped
+helper
+helpers
+helpful
+helpfully
+helpfulness
+helping
+helpless
+helplessly
+helplessness
+helpmate
+helps
+Helsinki
+Helvetica
+hem
+Hemingway
+hemisphere
+hemispheres
+hemlock
+hemlocks
+hemoglobin
+hemorrhoid
+hemostat
+hemostats
+hemp
+hempen
+Hempstead
+hems
+hen
+hence
+henceforth
+henchman
+henchmen
+Henderson
+Hendrick
+Hendricks
+Hendrickson
+Hendrix
+Henley
+Hennessey
+Hennessy
+Henning
+henpeck
+Henri
+Henrietta
+hens
+hepatitis
+Hepburn
+her
+Hera
+Heraclitus
+herald
+heralded
+heralding
+heralds
+herb
+Herbert
+herbivore
+herbivorous
+herbs
+Herculean
+Hercules
+herd
+herded
+herder
+herding
+herds
+here
+hereabout
+hereabouts
+hereafter
+hereby
+hereditary
+heredity
+Hereford
+herein
+hereinafter
+hereof
+heres
+heresy
+heretic
+heretics
+hereto
+heretofore
+hereunder
+herewith
+heritage
+heritages
+Herkimer
+Herman
+Hermann
+Hermes
+hermetic
+hermetically
+hermit
+Hermite
+hermitian
+hermits
+Hermosa
+Hernandez
+hero
+Herodotus
+heroes
+heroic
+heroically
+heroics
+heroin
+heroine
+heroines
+heroism
+heron
+herons
+herpes
+Herr
+herring
+herrings
+Herrington
+hers
+Herschel
+herself
+Hersey
+Hershel
+Hershey
+hertz
+Hertzog
+hesitant
+hesitantly
+hesitate
+hesitated
+hesitates
+hesitating
+hesitatingly
+hesitation
+hesitations
+Hesperus
+Hess
+Hesse
+Hessian
+Hessians
+Hester
+heterogeneity
+heterogeneous
+heterogeneously
+heterogeneousness
+heterogenous
+heterosexual
+Hetman
+Hettie
+Hetty
+Heublein
+heuristic
+heuristically
+heuristics
+Heusen
+Heuser
+hew
+hewed
+hewer
+Hewett
+Hewitt
+Hewlett
+hews
+hex
+hexadecimal
+hexagon
+hexagonal
+hexagonally
+hexagons
+hey
+Heywood
+hi
+Hiatt
+Hiawatha
+Hibbard
+hibernate
+Hibernia
+hick
+Hickey
+Hickeys
+Hickman
+Hickok
+hickory
+Hicks
+hid
+hidden
+hide
+hideous
+hideously
+hideousness
+hideout
+hideouts
+hides
+hiding
+hierarchal
+hierarchic
+hierarchical
+hierarchically
+hierarchies
+hierarchy
+Hieronymus
+Higgins
+high
+higher
+highest
+Highfield
+highland
+highlander
+highlands
+highlight
+highlighted
+highlighting
+highlights
+highly
+highness
+highnesses
+highway
+highwayman
+highwaymen
+highways
+hijack
+hijacked
+hike
+hiked
+hiker
+hikes
+hiking
+hilarious
+hilariously
+hilarity
+Hilbert
+Hildebrand
+hill
+Hillary
+hillbilly
+Hillcrest
+Hillel
+hillock
+hills
+Hillsboro
+Hillsdale
+hillside
+hillsides
+hilltop
+hilltops
+hilt
+Hilton
+hilts
+him
+Himalaya
+Himalayas
+Himmler
+himself
+hind
+hinder
+hindered
+hindering
+hinders
+Hindi
+hindrance
+hindrances
+hindsight
+Hindu
+Hinduism
+Hindus
+Hindustan
+Hines
+hinge
+hinged
+hinges
+Hinkle
+Hinman
+Hinsdale
+hint
+hinted
+hinting
+hints
+hip
+hippo
+Hippocrates
+Hippocratic
+hippopotamus
+hips
+Hiram
+hire
+hired
+hirer
+hirers
+hires
+Hirey
+hiring
+hirings
+Hiroshi
+Hiroshima
+Hirsch
+his
+Hispanic
+Hispanicize
+Hispanicizes
+Hispanics
+hiss
+hissed
+hisses
+hissing
+histogram
+histograms
+historian
+historians
+historic
+historical
+historically
+histories
+history
+hit
+Hitachi
+hitch
+Hitchcock
+hitched
+hitchhike
+hitchhiked
+hitchhiker
+hitchhikers
+hitchhikes
+hitchhiking
+hitching
+hither
+hitherto
+Hitler
+Hitlerian
+Hitlerism
+Hitlerite
+Hitlerites
+hits
+hitter
+hitters
+hitting
+hive
+Hoagland
+hoar
+hoard
+hoarder
+hoarding
+hoariness
+hoarse
+hoarsely
+hoarseness
+hoary
+Hobart
+Hobbes
+hobbies
+hobble
+hobbled
+hobbles
+hobbling
+Hobbs
+hobby
+hobbyhorse
+hobbyist
+hobbyists
+Hobday
+Hoboken
+hockey
+hodgepodge
+Hodges
+Hodgkin
+hoe
+hoes
+Hoff
+Hoffman
+hog
+hogging
+hogs
+hoist
+hoisted
+hoisting
+hoists
+Hokan
+Holbrook
+Holcomb
+hold
+holden
+holder
+holders
+holding
+holdings
+holds
+hole
+holed
+holes
+holiday
+holidays
+holies
+holiness
+holistic
+Holland
+Hollandaise
+Hollander
+Hollerith
+Hollingsworth
+Hollister
+hollow
+Holloway
+hollowed
+hollowing
+hollowly
+hollowness
+hollows
+holly
+Hollywood
+Hollywoodize
+Hollywoodizes
+Holm
+Holman
+Holmdel
+Holmes
+holocaust
+Holocene
+hologram
+holograms
+Holst
+Holstein
+holy
+Holyoke
+Holzman
+Hom
+homage
+home
+home-brew
+homed
+homeless
+homely
+homemade
+homemaker
+homemakers
+homeomorphic
+homeomorphism
+homeomorphisms
+homeopath
+homeowner
+homer
+Homeric
+homers
+homes
+homesick
+homesickness
+homespun
+homestead
+homesteader
+homesteaders
+homesteads
+homeward
+homewards
+homework
+homicidal
+homicide
+homing
+homo
+homogeneities
+homogeneity
+homogeneous
+homogeneously
+homogeneousness
+homomorphic
+homomorphism
+homomorphisms
+homosexual
+Honda
+Hondo
+Honduras
+hone
+honed
+honer
+hones
+honest
+honestly
+honesty
+honey
+honeybee
+honeycomb
+honeycombed
+honeydew
+honeymoon
+honeymooned
+honeymooner
+honeymooners
+honeymooning
+honeymoons
+honeysuckle
+Honeywell
+honing
+Honolulu
+honor
+honorable
+honorableness
+honorably
+honoraries
+honorarium
+honorary
+honored
+honorer
+honoring
+honors
+Honshu
+hood
+hooded
+hoodlum
+hoods
+hoodwink
+hoodwinked
+hoodwinking
+hoodwinks
+hoof
+hoofs
+hook
+hooked
+hooker
+hookers
+hooking
+hooks
+hookup
+hookups
+hoop
+hooper
+hoops
+Hoosier
+Hoosierize
+Hoosierizes
+hoot
+hooted
+hooter
+hooting
+hoots
+Hoover
+Hooverize
+Hooverizes
+hooves
+hop
+hope
+hoped
+hopeful
+hopefully
+hopefulness
+hopefuls
+hopeless
+hopelessly
+hopelessness
+hopes
+Hopi
+hoping
+Hopkins
+Hopkinsian
+hopper
+hoppers
+hopping
+hops
+Horace
+Horatio
+horde
+hordes
+horizon
+horizons
+horizontal
+horizontally
+hormone
+hormones
+horn
+Hornblower
+horned
+hornet
+hornets
+horns
+horny
+Horowitz
+horrendous
+horrendously
+horrible
+horribleness
+horribly
+horrid
+horridly
+horrified
+horrifies
+horrify
+horrifying
+horror
+horrors
+horse
+horseback
+horseflesh
+horsefly
+horseman
+horseplay
+horsepower
+horses
+horseshoe
+horseshoer
+horticulture
+Horton
+Horus
+hose
+hoses
+hospitable
+hospitably
+hospital
+hospitality
+hospitalize
+hospitalized
+hospitalizes
+hospitalizing
+hospitals
+host
+hostage
+hostages
+hosted
+hostess
+hostesses
+hostile
+hostilely
+hostilities
+hostility
+hosting
+hosts
+hot
+hotel
+hotels
+hotly
+hotness
+Hottentot
+hotter
+hottest
+Houdaille
+Houdini
+Houghton
+hound
+hounded
+hounding
+hounds
+hour
+hourglass
+hourly
+hours
+house
+houseboat
+housebroken
+housed
+houseflies
+housefly
+household
+householder
+householders
+households
+housekeeper
+housekeepers
+housekeeping
+houses
+housetop
+housetops
+housewife
+housewifely
+housewives
+housework
+housing
+Houston
+hovel
+hovels
+hover
+hovered
+hovering
+hovers
+how
+Howard
+Howe
+Howell
+however
+howl
+howled
+howler
+howling
+howls
+Hoyt
+Hrothgar
+hub
+Hubbard
+Hubbell
+Huber
+Hubert
+hubris
+hubs
+Huck
+huddle
+huddled
+huddling
+Hudson
+hue
+hues
+Huey
+Huffman
+hug
+huge
+hugely
+hugeness
+hugging
+Huggins
+Hugh
+Hughes
+Hugo
+huh
+hull
+hulls
+hum
+human
+humane
+humanely
+humaneness
+humanitarian
+humanities
+humanity
+humanly
+humanness
+humans
+humble
+humbled
+humbleness
+humbler
+humblest
+humbling
+humbly
+Humboldt
+humbug
+Hume
+humerus
+humid
+humidification
+humidified
+humidifier
+humidifiers
+humidifies
+humidify
+humidifying
+humidity
+humidly
+humiliate
+humiliated
+humiliates
+humiliating
+humiliation
+humiliations
+humility
+hummed
+Hummel
+humming
+hummingbird
+humor
+humored
+humorer
+humorers
+humoring
+humorous
+humorously
+humorousness
+humors
+hump
+humpback
+humped
+Humphrey
+Humpty
+hums
+Hun
+hunch
+hunched
+hunches
+hundred
+hundredfold
+hundreds
+hundredth
+hung
+Hungarian
+Hungary
+hunger
+hungered
+hungering
+hungers
+hungrier
+hungriest
+hungrily
+hungry
+hunk
+hunks
+Huns
+hunt
+hunted
+Hunter
+hunters
+hunting
+Huntington
+Huntley
+hunts
+huntsman
+Huntsville
+Hurd
+hurdle
+hurl
+hurled
+hurler
+hurlers
+hurling
+Huron
+Hurons
+hurrah
+hurricane
+hurricanes
+hurried
+hurriedly
+hurries
+hurry
+hurrying
+Hurst
+hurt
+hurting
+hurtle
+hurtling
+hurts
+Hurwitz
+husband
+husbandry
+husbands
+hush
+hushed
+hushes
+hushing
+husk
+husked
+husker
+huskiness
+husking
+husks
+husky
+hustle
+hustled
+hustler
+hustles
+hustling
+Huston
+hut
+hutch
+Hutchins
+Hutchinson
+Hutchison
+huts
+Huxley
+Huxtable
+hyacinth
+Hyades
+Hyannis
+hybrid
+Hyde
+hydra
+hydrant
+hydraulic
+hydro
+hydrodynamic
+hydrodynamics
+hydrogen
+hydrogens
+hyena
+hygiene
+Hyman
+hymen
+hymn
+hymns
+hyper
+hyperbola
+hyperbolic
+hypertext
+hyphen
+hyphenate
+hyphens
+hypnosis
+hypnotic
+hypocrisies
+hypocrisy
+hypocrite
+hypocrites
+hypodermic
+hypodermics
+hypotheses
+hypothesis
+hypothesize
+hypothesized
+hypothesizer
+hypothesizes
+hypothesizing
+hypothetical
+hypothetically
+hysteresis
+hysterical
+hysterically
+Ian
+Iberia
+Iberian
+Ibero-
+ibex
+ibid
+ibis
+Ibn
+Ibsen
+Icarus
+ice
+iceberg
+icebergs
+icebox
+iced
+Iceland
+Icelandic
+ices
+icicle
+iciness
+icing
+icings
+icon
+iconoclasm
+iconoclast
+icons
+icosahedra
+icosahedral
+icosahedron
+icy
+Ida
+Idaho
+idea
+ideal
+idealism
+idealistic
+idealization
+idealizations
+idealize
+idealized
+idealizes
+idealizing
+ideally
+ideals
+ideas
+idem
+idempotency
+idempotent
+identical
+identically
+identifiable
+identifiably
+identification
+identifications
+identified
+identifier
+identifiers
+identifies
+identify
+identifying
+identities
+identity
+ideological
+ideologically
+ideology
+idiocy
+idiom
+idiosyncrasies
+idiosyncrasy
+idiosyncratic
+idiot
+idiotic
+idiots
+idle
+idled
+idleness
+idler
+idlers
+idles
+idlest
+idling
+idly
+idol
+idolatry
+idols
+if
+Ifni
+igloo
+ignite
+ignition
+ignoble
+ignominious
+ignoramus
+ignorance
+ignorant
+ignorantly
+ignore
+ignored
+ignores
+ignoring
+Igor
+Ike
+Iliad
+Iliadize
+Iliadizes
+ill
+illegal
+illegalities
+illegality
+illegally
+illegitimate
+illicit
+illicitly
+Illinois
+illiteracy
+illiterate
+illness
+illnesses
+illogical
+illogically
+ills
+illuminate
+illuminated
+illuminates
+illuminating
+illumination
+illuminations
+illusion
+illusions
+illusive
+illusively
+illusory
+illustrate
+illustrated
+illustrates
+illustrating
+illustration
+illustrations
+illustrative
+illustratively
+illustrator
+illustrators
+illustrious
+illustriousness
+illy
+Ilona
+Ilyushin
+image
+Imagen
+imagery
+images
+imaginable
+imaginably
+imaginary
+imagination
+imaginations
+imaginative
+imaginatively
+imagine
+imagined
+imagines
+imaging
+imagining
+imaginings
+imbalance
+imbalances
+imbecile
+imbibe
+Imbrium
+imitate
+imitated
+imitates
+imitating
+imitation
+imitations
+imitative
+immaculate
+immaculately
+immaterial
+immaterially
+immature
+immaturity
+immediacies
+immediacy
+immediate
+immediately
+immemorial
+immense
+immensely
+immerse
+immersed
+immerses
+immersion
+immigrant
+immigrants
+immigrate
+immigrated
+immigrates
+immigrating
+immigration
+imminent
+imminently
+immoderate
+immodest
+immoral
+immortal
+immortality
+immortally
+immovability
+immovable
+immovably
+immune
+immunities
+immunity
+immunization
+immutable
+imp
+impact
+impacted
+impacting
+impaction
+impactor
+impactors
+impacts
+impair
+impaired
+impairing
+impairs
+impale
+impart
+imparted
+impartial
+impartially
+imparts
+impasse
+impassive
+impatience
+impatient
+impatiently
+impeach
+impeachable
+impeached
+impeachment
+impeccable
+impedance
+impedances
+impede
+impeded
+impedes
+impediment
+impediments
+impeding
+impel
+impelled
+impelling
+impend
+impending
+impenetrability
+impenetrable
+impenetrably
+imperative
+imperatively
+imperatives
+imperceivable
+imperceptible
+imperfect
+imperfection
+imperfections
+imperfectly
+imperial
+imperialism
+imperialist
+imperialists
+imperil
+imperiled
+imperious
+imperiously
+impermanence
+impermanent
+impermeable
+impermissible
+impersonal
+impersonally
+impersonate
+impersonated
+impersonates
+impersonating
+impersonation
+impersonations
+impertinent
+impertinently
+impervious
+imperviously
+impetuous
+impetuously
+impetus
+impinge
+impinged
+impinges
+impinging
+impious
+implacable
+implant
+implanted
+implanting
+implants
+implausible
+implement
+implementable
+implementation
+implementations
+implemented
+implementer
+implementing
+implementor
+implementors
+implements
+implicant
+implicants
+implicate
+implicated
+implicates
+implicating
+implication
+implications
+implicit
+implicitly
+implicitness
+implied
+implies
+implore
+implored
+imploring
+imply
+implying
+impolite
+import
+importance
+important
+importantly
+importation
+imported
+importer
+importers
+importing
+imports
+impose
+imposed
+imposes
+imposing
+imposition
+impositions
+impossibilities
+impossibility
+impossible
+impossibly
+impostor
+impostors
+impotence
+impotency
+impotent
+impound
+impoverish
+impoverished
+impoverishment
+impracticable
+impractical
+impracticality
+impractically
+imprecise
+imprecisely
+imprecision
+impregnable
+impregnate
+impress
+impressed
+impresser
+impresses
+impressible
+impressing
+impression
+impressionable
+impressionist
+impressionistic
+impressions
+impressive
+impressively
+impressiveness
+impressment
+imprimatur
+imprint
+imprinted
+imprinting
+imprints
+imprison
+imprisoned
+imprisoning
+imprisonment
+imprisonments
+imprisons
+improbability
+improbable
+impromptu
+improper
+improperly
+impropriety
+improve
+improved
+improvement
+improvements
+improves
+improving
+improvisation
+improvisational
+improvisations
+improvise
+improvised
+improviser
+improvisers
+improvises
+improvising
+imprudent
+imps
+impudent
+impudently
+impugn
+impulse
+impulses
+impulsion
+impulsive
+impunity
+impure
+impurities
+impurity
+impute
+imputed
+in
+inability
+inaccessible
+inaccuracies
+inaccuracy
+inaccurate
+inaction
+inactivate
+inactive
+inactivity
+inadequacies
+inadequacy
+inadequate
+inadequately
+inadequateness
+inadmissibility
+inadmissible
+inadvertent
+inadvertently
+inadvisable
+inalienable
+inalterable
+inane
+inanimate
+inanimately
+Inanna
+inapplicable
+inapproachable
+inappropriate
+inappropriateness
+inasmuch
+inattention
+inaudible
+inaugural
+inaugurate
+inaugurated
+inaugurating
+inauguration
+inauspicious
+inboard
+inbound
+inbreed
+Inca
+incalculable
+incandescent
+incantation
+incapable
+incapacitate
+incapacitating
+incarcerate
+incarnation
+incarnations
+Incas
+incendiaries
+incendiary
+incense
+incensed
+incenses
+incentive
+incentives
+inception
+incessant
+incessantly
+incest
+incestuous
+inch
+inched
+inches
+inching
+incidence
+incident
+incidental
+incidentally
+incidentals
+incidents
+incinerate
+incipient
+incisive
+incite
+incited
+incitement
+incites
+inciting
+inclement
+inclination
+inclinations
+incline
+inclined
+inclines
+inclining
+inclose
+inclosed
+incloses
+inclosing
+include
+included
+includes
+including
+inclusion
+inclusions
+inclusive
+inclusively
+inclusiveness
+incoherence
+incoherent
+incoherently
+income
+incomes
+incoming
+incommensurable
+incommensurate
+incommunicable
+incomparable
+incomparably
+incompatibilities
+incompatibility
+incompatible
+incompatibly
+incompetence
+incompetent
+incompetents
+incomplete
+incompletely
+incompleteness
+incomprehensibility
+incomprehensible
+incomprehensibly
+incomprehension
+incompressible
+incomputable
+inconceivable
+inconclusive
+incongruity
+incongruous
+inconsequential
+inconsequentially
+inconsiderable
+inconsiderate
+inconsiderately
+inconsiderateness
+inconsistencies
+inconsistency
+inconsistent
+inconsistently
+inconspicuous
+incontestable
+incontrovertible
+incontrovertibly
+inconvenience
+inconvenienced
+inconveniences
+inconveniencing
+inconvenient
+inconveniently
+inconvertible
+incorporate
+incorporated
+incorporates
+incorporating
+incorporation
+incorrect
+incorrectly
+incorrectness
+incorrigible
+increase
+increased
+increases
+increasing
+increasingly
+incredible
+incredibly
+incredulity
+incredulous
+incredulously
+increment
+incremental
+incrementally
+incremented
+incrementer
+incrementing
+increments
+incriminate
+incubate
+incubated
+incubates
+incubating
+incubation
+incubator
+incubators
+inculcate
+incumbent
+incur
+incurable
+incurred
+incurring
+incurs
+incursion
+indebted
+indebtedness
+indecent
+indecipherable
+indecision
+indecisive
+indeed
+indefatigable
+indefensible
+indefinite
+indefinitely
+indefiniteness
+indelible
+indemnify
+indemnity
+indent
+indentation
+indentations
+indented
+indenting
+indents
+indenture
+independence
+independent
+independently
+indescribable
+indestructible
+indeterminacies
+indeterminacy
+indeterminate
+indeterminately
+index
+indexable
+indexed
+indexes
+indexing
+India
+Indian
+Indiana
+Indianapolis
+Indians
+indicate
+indicated
+indicates
+indicating
+indication
+indications
+indicative
+indicator
+indicators
+indices
+indict
+indictment
+indictments
+Indies
+indifference
+indifferent
+indifferently
+indigenous
+indigenously
+indigenousness
+indigestible
+indigestion
+indignant
+indignantly
+indignation
+indignities
+indignity
+indigo
+Indira
+indirect
+indirected
+indirecting
+indirection
+indirections
+indirectly
+indirects
+indiscreet
+indiscretion
+indiscriminate
+indiscriminately
+indispensability
+indispensable
+indispensably
+indisputable
+indistinct
+indistinguishable
+individual
+individualism
+individualistic
+individuality
+individualize
+individualized
+individualizes
+individualizing
+individually
+individuals
+indivisibility
+indivisible
+Indo
+Indochina
+Indochinese
+indoctrinate
+indoctrinated
+indoctrinates
+indoctrinating
+indoctrination
+Indoeuropean
+indolent
+indolently
+indomitable
+Indonesia
+Indonesian
+indoor
+indoors
+indubitable
+induce
+induced
+inducement
+inducements
+inducer
+induces
+inducing
+induct
+inductance
+inductances
+inducted
+inductee
+inducting
+induction
+inductions
+inductive
+inductively
+inductor
+inductors
+inducts
+indulge
+indulged
+indulgence
+indulgences
+indulgent
+indulging
+Indus
+industrial
+industrialism
+industrialist
+industrialists
+industrialization
+industrialized
+industrially
+industrials
+industries
+industrious
+industriously
+industriousness
+industry
+Indy
+ineffective
+ineffectively
+ineffectiveness
+ineffectual
+inefficiencies
+inefficiency
+inefficient
+inefficiently
+inelegant
+ineligible
+inept
+inequalities
+inequality
+inequitable
+inequity
+inert
+inertia
+inertial
+inertly
+inertness
+inescapable
+inescapably
+inessential
+inestimable
+inevitabilities
+inevitability
+inevitable
+inevitably
+inexact
+inexcusable
+inexcusably
+inexhaustible
+inexorable
+inexorably
+inexpensive
+inexpensively
+inexperience
+inexperienced
+inexplicable
+infallibility
+infallible
+infallibly
+infamous
+infamously
+infamy
+infancy
+infant
+infantile
+infantry
+infantryman
+infantrymen
+infants
+infarct
+infatuate
+infeasible
+infect
+infected
+infecting
+infection
+infections
+infectious
+infectiously
+infective
+infects
+infer
+inference
+inferences
+inferential
+inferior
+inferiority
+inferiors
+infernal
+infernally
+inferno
+infernos
+inferred
+inferring
+infers
+infertile
+infest
+infested
+infesting
+infests
+infidel
+infidelity
+infidels
+infighting
+infiltrate
+infinite
+infinitely
+infiniteness
+infinitesimal
+infinitive
+infinitives
+infinitude
+infinitum
+infinity
+infirm
+infirmary
+infirmity
+infix
+inflame
+inflamed
+inflammable
+inflammation
+inflammatory
+inflatable
+inflate
+inflated
+inflater
+inflates
+inflating
+inflation
+inflationary
+inflexibility
+inflexible
+inflict
+inflicted
+inflicting
+inflicts
+inflow
+influence
+influenced
+influences
+influencing
+influential
+influentially
+influenza
+inform
+informal
+informality
+informally
+informant
+informants
+Informatica
+information
+informational
+informative
+informatively
+informed
+informer
+informers
+informing
+informs
+infra
+infrared
+infrastructure
+infrequent
+infrequently
+infringe
+infringed
+infringement
+infringements
+infringes
+infringing
+infuriate
+infuriated
+infuriates
+infuriating
+infuriation
+infuse
+infused
+infuses
+infusing
+infusion
+infusions
+ingenious
+ingeniously
+ingeniousness
+ingenuity
+ingenuous
+Ingersoll
+ingest
+ingestion
+inglorious
+ingot
+Ingram
+ingrate
+ingratiate
+ingratitude
+ingredient
+ingredients
+ingrown
+inhabit
+inhabitable
+inhabitance
+inhabitant
+inhabitants
+inhabited
+inhabiting
+inhabits
+inhale
+inhaled
+inhaler
+inhales
+inhaling
+inhere
+inherent
+inherently
+inheres
+inherit
+inheritable
+inheritance
+inheritances
+inherited
+inheriting
+inheritor
+inheritors
+inheritress
+inheritresses
+inheritrices
+inheritrix
+inherits
+inhibit
+inhibited
+inhibiting
+inhibition
+inhibitions
+inhibitor
+inhibitors
+inhibitory
+inhibits
+inhomogeneities
+inhomogeneity
+inhomogeneous
+inhospitable
+inhuman
+inhumane
+inimical
+inimitable
+iniquities
+iniquity
+initial
+initialed
+initialing
+initialization
+initializations
+initialize
+initialized
+initializer
+initializers
+initializes
+initializing
+initially
+initials
+initiate
+initiated
+initiates
+initiating
+initiation
+initiations
+initiative
+initiatives
+initiator
+initiators
+inject
+injected
+injecting
+injection
+injections
+injective
+injects
+injudicious
+Injun
+injunction
+injunctions
+Injuns
+injure
+injured
+injures
+injuries
+injuring
+injurious
+injury
+injustice
+injustices
+ink
+inked
+inker
+inkers
+inking
+inkings
+inkling
+inklings
+inks
+inlaid
+inland
+inlay
+inlet
+inlets
+inline
+Inman
+inmate
+inmates
+inn
+innards
+innate
+innately
+inner
+innermost
+inning
+innings
+innocence
+innocent
+innocently
+innocents
+innocuous
+innocuously
+innocuousness
+innovate
+innovation
+innovations
+innovative
+inns
+innuendo
+innumerability
+innumerable
+innumerably
+inoculate
+inoperable
+inoperative
+inopportune
+inordinate
+inordinately
+inorganic
+input
+inputs
+inquest
+inquire
+inquired
+inquirer
+inquirers
+inquires
+inquiries
+inquiring
+inquiry
+inquisition
+inquisitions
+inquisitive
+inquisitively
+inquisitiveness
+inroad
+inroads
+insane
+insanely
+insanity
+insatiable
+inscribe
+inscribed
+inscribes
+inscribing
+inscription
+inscriptions
+inscrutable
+insect
+insecticide
+insects
+insecure
+insecurely
+inseminate
+insensible
+insensitive
+insensitively
+insensitivity
+inseparable
+insert
+inserted
+inserting
+insertion
+insertions
+inserts
+inset
+inside
+insider
+insiders
+insides
+insidious
+insidiously
+insidiousness
+insight
+insightful
+insights
+insignia
+insignificance
+insignificant
+insincere
+insincerity
+insinuate
+insinuated
+insinuates
+insinuating
+insinuation
+insinuations
+insipid
+insist
+insisted
+insistence
+insistent
+insistently
+insisting
+insists
+insofar
+insolence
+insolent
+insolently
+insoluble
+insolvable
+insolvent
+insomnia
+insomniac
+inspect
+inspected
+inspecting
+inspection
+inspections
+inspector
+inspectors
+inspects
+inspiration
+inspirations
+inspire
+inspired
+inspirer
+inspires
+inspiring
+instabilities
+instability
+install
+installation
+installations
+installed
+installer
+installers
+installing
+installment
+installments
+installs
+instance
+instances
+instant
+instantaneous
+instantaneously
+instanter
+instantiate
+instantiated
+instantiates
+instantiating
+instantiation
+instantiations
+instantly
+instants
+instead
+instigate
+instigated
+instigates
+instigating
+instigator
+instigators
+instill
+instinct
+instinctive
+instinctively
+instincts
+instinctual
+institute
+instituted
+instituter
+instituters
+institutes
+instituting
+institution
+institutional
+institutionalize
+institutionalized
+institutionalizes
+institutionalizing
+institutionally
+institutions
+instruct
+instructed
+instructing
+instruction
+instructional
+instructions
+instructive
+instructively
+instructor
+instructors
+instructs
+instrument
+instrumental
+instrumentalist
+instrumentalists
+instrumentally
+instrumentals
+instrumentation
+instrumented
+instrumenting
+instruments
+insubordinate
+insufferable
+insufficient
+insufficiently
+insular
+insulate
+insulated
+insulates
+insulating
+insulation
+insulator
+insulators
+insulin
+insult
+insulted
+insulting
+insults
+insuperable
+insupportable
+insurance
+insure
+insured
+insurer
+insurers
+insures
+insurgent
+insurgents
+insuring
+insurmountable
+insurrection
+insurrections
+intact
+intangible
+intangibles
+integer
+integers
+integrable
+integral
+integrals
+integrand
+integrate
+integrated
+integrates
+integrating
+integration
+integrations
+integrative
+integrity
+Intel
+intellect
+intellects
+intellectual
+intellectually
+intellectuals
+intelligence
+intelligent
+intelligently
+intelligentsia
+intelligibility
+intelligible
+intelligibly
+Intelsat
+intemperate
+intend
+intended
+intending
+intends
+intense
+intensely
+intensification
+intensified
+intensifier
+intensifiers
+intensifies
+intensify
+intensifying
+intensities
+intensity
+intensive
+intensively
+intent
+intention
+intentional
+intentionally
+intentioned
+intentions
+intently
+intentness
+intents
+inter
+interact
+interacted
+interacting
+interaction
+interactions
+interactive
+interactively
+interactivity
+interacts
+intercept
+intercepted
+intercepting
+interception
+interceptor
+intercepts
+interchange
+interchangeability
+interchangeable
+interchangeably
+interchanged
+interchanger
+interchanges
+interchanging
+interchangings
+interchannel
+intercity
+intercom
+intercommunicate
+intercommunicated
+intercommunicates
+intercommunicating
+intercommunication
+interconnect
+interconnected
+interconnecting
+interconnection
+interconnections
+interconnects
+intercontinental
+intercourse
+Interdata
+interdependence
+interdependencies
+interdependency
+interdependent
+interdict
+interdiction
+interdisciplinary
+interest
+interested
+interesting
+interestingly
+interests
+interface
+interfaced
+interfacer
+interfaces
+interfacing
+interfere
+interfered
+interference
+interferences
+interferes
+interfering
+interferingly
+interferometer
+interferometric
+interferometry
+interframe
+intergroup
+interim
+interior
+interiors
+interject
+interlace
+interlaced
+interlaces
+interlacing
+interleave
+interleaved
+interleaves
+interleaving
+interlink
+interlinked
+interlinks
+interlisp
+intermediary
+intermediate
+intermediates
+interminable
+intermingle
+intermingled
+intermingles
+intermingling
+intermission
+intermittent
+intermittently
+intermix
+intermixed
+intermodule
+intern
+internal
+internalize
+internalized
+internalizes
+internalizing
+internally
+internals
+international
+internationality
+internationally
+interned
+INTERNET
+Internet
+internetwork
+interning
+interns
+internship
+interoffice
+interpersonal
+interplay
+Interpol
+interpolate
+interpolated
+interpolates
+interpolating
+interpolation
+interpolations
+interpose
+interposed
+interposes
+interposing
+interpret
+interpretable
+interpretation
+interpretations
+interpreted
+interpreter
+interpreters
+interpreting
+interpretive
+interpretively
+interprets
+interprocess
+interrelate
+interrelated
+interrelates
+interrelating
+interrelation
+interrelations
+interrelationship
+interrelationships
+interrogate
+interrogated
+interrogates
+interrogating
+interrogation
+interrogations
+interrogative
+interrupt
+interrupted
+interruptible
+interrupting
+interruption
+interruptions
+interruptive
+interrupts
+intersect
+intersected
+intersecting
+intersection
+intersections
+intersects
+intersperse
+interspersed
+intersperses
+interspersing
+interspersion
+interstage
+interstate
+intertwine
+intertwined
+intertwines
+intertwining
+interval
+intervals
+intervene
+intervened
+intervenes
+intervening
+intervention
+interventions
+interview
+interviewed
+interviewee
+interviewer
+interviewers
+interviewing
+interviews
+interwoven
+intestate
+intestinal
+intestine
+intestines
+intimacy
+intimate
+intimated
+intimately
+intimating
+intimation
+intimations
+intimidate
+intimidated
+intimidates
+intimidating
+intimidation
+into
+intolerable
+intolerably
+intolerance
+intolerant
+intonation
+intonations
+intone
+intoxicant
+intoxicate
+intoxicated
+intoxicating
+intoxication
+intractability
+intractable
+intractably
+intragroup
+intraline
+intramural
+intramuscular
+intransigent
+intransitive
+intransitively
+intraoffice
+intraprocess
+intrastate
+intravenous
+intrepid
+intricacies
+intricacy
+intricate
+intricately
+intrigue
+intrigued
+intrigues
+intriguing
+intrinsic
+intrinsically
+introduce
+introduced
+introduces
+introducing
+introduction
+introductions
+introductory
+introspect
+introspection
+introspections
+introspective
+introvert
+introverted
+intrude
+intruded
+intruder
+intruders
+intrudes
+intruding
+intrusion
+intrusions
+intrust
+intubate
+intubated
+intubates
+intubation
+intuition
+intuitionist
+intuitions
+intuitive
+intuitively
+inundate
+invade
+invaded
+invader
+invaders
+invades
+invading
+invalid
+invalidate
+invalidated
+invalidates
+invalidating
+invalidation
+invalidations
+invalidities
+invalidity
+invalidly
+invalids
+invaluable
+invariable
+invariably
+invariance
+invariant
+invariantly
+invariants
+invasion
+invasions
+invective
+invent
+invented
+inventing
+invention
+inventions
+inventive
+inventively
+inventiveness
+inventor
+inventories
+inventors
+inventory
+invents
+Inverness
+inverse
+inversely
+inverses
+inversion
+inversions
+invert
+invertebrate
+invertebrates
+inverted
+inverter
+inverters
+invertible
+inverting
+inverts
+invest
+invested
+investigate
+investigated
+investigates
+investigating
+investigation
+investigations
+investigative
+investigator
+investigators
+investigatory
+investing
+investment
+investments
+investor
+investors
+invests
+inveterate
+invigorate
+invincible
+invisibility
+invisible
+invisibly
+invitation
+invitations
+invite
+invited
+invites
+inviting
+invocable
+invocation
+invocations
+invoice
+invoiced
+invoices
+invoicing
+invoke
+invoked
+invoker
+invokes
+invoking
+involuntarily
+involuntary
+involve
+involved
+involvement
+involvements
+involves
+involving
+inward
+inwardly
+inwardness
+inwards
+Io
+iodine
+ion
+Ionian
+Ionians
+Ionicization
+Ionicizations
+Ionicize
+Ionicizes
+ionosphere
+ionospheric
+ions
+iota
+Iowa
+Ira
+Iran
+Iranian
+Iranians
+Iranize
+Iranizes
+Iraq
+Iraqi
+Iraqis
+irate
+irately
+irateness
+ire
+Ireland
+Irene
+ires
+iris
+Irish
+Irishize
+Irishizes
+Irishman
+Irishmen
+irk
+irked
+irking
+irks
+irksome
+Irma
+iron
+ironed
+ironic
+ironical
+ironically
+ironies
+ironing
+ironings
+irons
+irony
+Iroquois
+irradiate
+irrational
+irrationally
+irrationals
+Irrawaddy
+irreconcilable
+irrecoverable
+irreducible
+irreducibly
+irreflexive
+irrefutable
+irregular
+irregularities
+irregularity
+irregularly
+irregulars
+irrelevance
+irrelevances
+irrelevant
+irrelevantly
+irreplaceable
+irrepressible
+irreproducibility
+irreproducible
+irresistible
+irrespective
+irrespectively
+irresponsible
+irresponsibly
+irretrievably
+irreverent
+irreversibility
+irreversible
+irreversibly
+irrevocable
+irrevocably
+irrigate
+irrigated
+irrigates
+irrigating
+irrigation
+irritable
+irritant
+irritate
+irritated
+irritates
+irritating
+irritation
+irritations
+Irvin
+Irvine
+Irving
+Irwin
+is
+Isaac
+Isaacs
+Isaacson
+Isabel
+Isabella
+Isadore
+Isaiah
+Isfahan
+Ising
+Isis
+Islam
+Islamabad
+Islamic
+Islamization
+Islamizations
+Islamize
+Islamizes
+island
+islander
+islanders
+Islandia
+islands
+isle
+isles
+islet
+islets
+isolate
+isolated
+isolates
+isolating
+isolation
+isolations
+Isolde
+isometric
+isomorphic
+isomorphically
+isomorphism
+isomorphisms
+isotope
+isotopes
+Israel
+Israeli
+Israelis
+Israelite
+Israelites
+Israelitize
+Israelitizes
+issuance
+issue
+issued
+issuer
+issuers
+issues
+issuing
+Istanbul
+isthmus
+Istvan
+it
+Italian
+Italianization
+Italianizations
+Italianize
+Italianizer
+Italianizers
+Italianizes
+Italians
+italic
+italicize
+italicized
+italics
+Italy
+itch
+itches
+itching
+Itel
+item
+itemization
+itemizations
+itemize
+itemized
+itemizes
+itemizing
+items
+iterate
+iterated
+iterates
+iterating
+iteration
+iterations
+iterative
+iteratively
+iterator
+iterators
+Ithaca
+Ithacan
+itineraries
+itinerary
+Ito
+its
+itself
+Ivan
+Ivanhoe
+Iverson
+ivies
+ivory
+ivy
+Izaak
+Izvestia
+jab
+jabbed
+jabbing
+Jablonsky
+jabs
+jack
+jackass
+jacket
+jacketed
+jackets
+Jackie
+jacking
+jackknife
+Jackman
+jackpot
+Jackson
+Jacksonian
+Jacksons
+Jacksonville
+Jacky
+Jacob
+Jacobean
+Jacobi
+Jacobian
+Jacobinize
+Jacobite
+Jacobs
+Jacobsen
+Jacobson
+Jacobus
+Jacoby
+Jacqueline
+Jacques
+jade
+jaded
+Jaeger
+jaguar
+jail
+jailed
+jailer
+jailers
+jailing
+jails
+Jaime
+Jakarta
+Jake
+Jakes
+jam
+Jamaica
+Jamaican
+James
+Jameson
+Jamestown
+jammed
+jamming
+jams
+Jane
+Janeiro
+Janesville
+Janet
+Janice
+Janis
+janitor
+janitors
+Janos
+Jansen
+Jansenist
+Januaries
+January
+Janus
+Japan
+Japanese
+Japanization
+Japanizations
+Japanize
+Japanized
+Japanizes
+Japanizing
+jar
+jargon
+jarred
+jarring
+jarringly
+jars
+Jarvin
+Jason
+Jastrow
+jaundice
+jaunt
+jauntiness
+jaunts
+jaunty
+Java
+Javanese
+javelin
+javelins
+jaw
+jawbone
+jaws
+jay
+Jaycee
+Jaycees
+jazz
+jazzy
+jealous
+jealousies
+jealously
+jealousy
+jean
+Jeanne
+Jeannie
+jeans
+Jed
+jeep
+jeeps
+jeer
+jeers
+Jeff
+Jefferson
+Jeffersonian
+Jeffersonians
+Jeffrey
+Jehovah
+jellies
+Jello
+jelly
+jellyfish
+Jenkins
+Jennie
+Jennifer
+Jennings
+jenny
+Jensen
+jeopardize
+jeopardized
+jeopardizes
+jeopardizing
+jeopardy
+Jeremiah
+Jeremy
+Jeres
+Jericho
+jerk
+jerked
+jerkiness
+jerking
+jerkings
+jerks
+jerky
+Jeroboam
+Jerome
+Jerry
+jersey
+jerseys
+Jerusalem
+Jesse
+Jessica
+Jessie
+Jessy
+jest
+jested
+jester
+jesting
+jests
+Jesuit
+Jesuitism
+Jesuitize
+Jesuitized
+Jesuitizes
+Jesuitizing
+Jesuits
+Jesus
+jet
+jetliner
+jets
+jetted
+jetting
+Jew
+jewel
+jeweled
+jeweler
+Jewell
+Jewelled
+jewelries
+jewelry
+jewels
+Jewett
+Jewish
+Jewishness
+Jews
+jiffy
+jig
+jigs
+jigsaw
+Jill
+Jim
+Jimenez
+Jimmie
+jingle
+jingled
+jingling
+Jinny
+jitter
+jitterbug
+jittery
+Jo
+Joan
+Joanna
+Joanne
+Joaquin
+job
+Jobrel
+jobs
+jockey
+jockstrap
+jocund
+Jody
+Joe
+Joel
+Joes
+jog
+jogging
+jogs
+Johann
+Johanna
+Johannes
+Johannesburg
+Johansen
+Johanson
+John
+Johnnie
+Johnny
+Johns
+Johnsen
+Johnson
+Johnston
+Johnstown
+join
+joined
+joiner
+joiners
+joining
+joins
+joint
+jointly
+joints
+joke
+joked
+joker
+jokers
+jokes
+joking
+jokingly
+Joliet
+Jolla
+jolly
+jolt
+jolted
+jolting
+jolts
+Jon
+Jonas
+Jonathan
+Jonathanization
+Jonathanizations
+Jones
+Joneses
+jonquil
+Joplin
+Jordan
+Jordanian
+Jorge
+Jorgensen
+Jorgenson
+Jose
+Josef
+Joseph
+Josephine
+Josephson
+Josephus
+Joshua
+Josiah
+jostle
+jostled
+jostles
+jostling
+jot
+jots
+jotted
+jotting
+joule
+journal
+journalism
+journalist
+journalists
+journalize
+journalized
+journalizes
+journalizing
+journals
+journey
+journeyed
+journeying
+journeyings
+journeyman
+journeymen
+journeys
+joust
+jousted
+jousting
+jousts
+Jovanovich
+Jove
+jovial
+Jovian
+joy
+Joyce
+joyful
+joyfully
+joyous
+joyously
+joyousness
+joyride
+joys
+joystick
+Juan
+Juanita
+Jubal
+jubilee
+Judaica
+Judaism
+Judas
+Judd
+Judder
+Juddered
+Juddering
+Judders
+Jude
+Judea
+judge
+judged
+judges
+judging
+judgment
+judgments
+judicial
+judiciary
+judicious
+judiciously
+Judith
+judo
+Judson
+Judy
+jug
+juggle
+juggler
+jugglers
+juggles
+juggling
+Jugoslavia
+jugs
+juice
+juices
+juiciest
+juicy
+Jukes
+Jules
+Julia
+Julian
+Julie
+Julies
+Juliet
+Julio
+Julius
+July
+jumble
+jumbled
+jumbles
+jumbo
+jump
+jumped
+jumper
+jumpers
+jumping
+jumps
+jumpy
+junction
+junctions
+juncture
+junctures
+June
+Juneau
+Junes
+Jung
+Jungian
+jungle
+jungles
+junior
+juniors
+juniper
+junk
+junker
+junkers
+junks
+junky
+Juno
+junta
+Jupiter
+Jura
+Juras
+Jurassic
+jure
+juries
+jurisdiction
+jurisdictions
+jurisprudence
+jurist
+juror
+jurors
+jury
+just
+justice
+justices
+justifiable
+justifiably
+justification
+justifications
+justified
+justifier
+justifiers
+justifies
+justify
+justifying
+Justine
+Justinian
+justly
+justness
+jut
+Jutish
+Jutland
+jutting
+juvenile
+juveniles
+juxtapose
+juxtaposed
+juxtaposes
+juxtaposing
+Kabuki
+Kabul
+Kaddish
+Kafka
+Kafkaesque
+Kahn
+Kajar
+Kalamazoo
+Kali
+Kalmuk
+Kamchatka
+Kamikaze
+Kamikazes
+Kampala
+Kampuchea
+Kanarese
+Kane
+kangaroo
+kanji
+Kankakee
+Kannada
+Kansas
+Kant
+Kantian
+Kaplan
+kappa
+Karachi
+Karamazov
+karate
+Karen
+Karl
+Karol
+Karp
+Kashmir
+Kaskaskia
+Kate
+Katharine
+Katherine
+Kathleen
+Kathy
+Katie
+Katmandu
+Katowice
+Katz
+Kauffman
+Kaufman
+Kay
+Keaton
+Keats
+Keegan
+keel
+keeled
+keeling
+keels
+keen
+Keenan
+keener
+keenest
+keenly
+keenness
+keep
+keeper
+keepers
+keeping
+keeps
+Keith
+Keller
+Kelley
+Kellogg
+Kelly
+Kelsey
+Kelvin
+Kemp
+ken
+Kendall
+Kenilworth
+Kennan
+Kennecott
+Kennedy
+kennel
+kennels
+Kenneth
+Kenney
+Kenning
+Kenny
+Kenosha
+Kensington
+Kent
+Kenton
+Kentucky
+Kenya
+Kenyon
+Kepler
+kept
+kerchief
+kerchiefs
+Kermit
+kern
+kernel
+kernels
+Kernighan
+kerosene
+Kerouac
+Kerr
+Kessler
+ketchup
+Kettering
+kettle
+kettles
+Kevin
+Kewaskum
+Kewaunee
+key
+keyboard
+keyboards
+keyed
+Keyes
+keyhole
+keying
+Keynes
+Keynesian
+keynote
+keypad
+keypads
+keys
+keystroke
+keystrokes
+keyword
+keywords
+Khartoum
+Khmer
+Khrushchev
+Khrushchevs
+kick
+Kickapoo
+kicked
+kicker
+kickers
+kicking
+kickoff
+kicks
+kid
+Kidde
+kidded
+kiddie
+kidding
+kidnap
+kidnapper
+kidnappers
+kidnapping
+kidnappings
+kidnaps
+kidney
+kidneys
+kids
+Kieffer
+Kiel
+Kiev
+Kiewit
+Kigali
+Kikuyu
+Kilgore
+Kilimanjaro
+kill
+Killebrew
+killed
+killer
+killers
+killing
+killingly
+killings
+killjoy
+kills
+kilobit
+kilobits
+kiloblock
+kilobyte
+kilobytes
+kilogram
+kilograms
+kilohertz
+kilohm
+kilojoule
+kilometer
+kilometers
+kiloton
+kilovolt
+kilowatt
+kiloword
+Kim
+Kimball
+Kimberly
+kimono
+kin
+kind
+kinder
+kindergarten
+kindest
+kindhearted
+kindle
+kindled
+kindles
+kindling
+kindly
+kindness
+kindred
+kinds
+kinetic
+king
+kingdom
+kingdoms
+kingly
+kingpin
+kings
+Kingsbury
+Kingsley
+Kingston
+Kingstown
+Kingwood
+kink
+kinky
+Kinney
+Kinnickinnic
+Kinsey
+Kinshasha
+kinship
+kinsman
+kiosk
+Kiowa
+Kipling
+Kirby
+Kirchner
+Kirchoff
+Kirk
+Kirkland
+Kirkpatrick
+Kirkwood
+Kirov
+kiss
+kissed
+kisser
+kissers
+kisses
+kissing
+kit
+Kitakyushu
+kitchen
+kitchenette
+kitchens
+kite
+kited
+kites
+kiting
+kits
+kitten
+kittenish
+kittens
+kitty
+Kiwanis
+Klan
+Klaus
+klaxon
+Klein
+Kleinrock
+Kline
+kludge
+kludges
+Klux
+klystron
+knack
+Knapp
+knapsack
+knapsacks
+Knauer
+knave
+knaves
+knead
+kneads
+knee
+kneecap
+kneed
+kneeing
+kneel
+kneeled
+kneeling
+kneels
+knees
+knell
+knells
+knelt
+knew
+Knickerbocker
+Knickerbockers
+knife
+knifed
+knifes
+knifing
+knight
+knighted
+knighthood
+knighting
+knightly
+knights
+Knightsbridge
+knit
+knits
+knives
+knob
+Knobeloch
+knobs
+knock
+knockdown
+knocked
+knocker
+knockers
+knocking
+knockout
+knocks
+knoll
+knolls
+Knossos
+knot
+knots
+Knott
+knotted
+knotting
+know
+knowable
+knower
+knowhow
+knowing
+knowingly
+knowledge
+knowledgeable
+Knowles
+Knowlton
+known
+knows
+Knox
+Knoxville
+knuckle
+knuckled
+knuckles
+Knudsen
+Knudson
+Knuth
+Knutsen
+Knutson
+koala
+Kobayashi
+Koch
+Kochab
+Kodachrome
+Kodak
+Kodiak
+Koenig
+Koenigsberg
+Kohler
+Kong
+Konrad
+Koppers
+Koran
+Korea
+Korean
+Koreans
+kosher
+Kovacs
+Kowalewski
+Kowalski
+Kowloon
+Kowtow
+Kraemer
+Krakatoa
+Krakow
+Kramer
+Krause
+Krebs
+Kremlin
+Kresge
+Krieger
+Krishna
+Kristin
+Kronecker
+Krueger
+Kruger
+Kruse
+Ku
+Kuala
+kudo
+Kuenning
+Kuhn
+Kumar
+Kurd
+Kurdish
+Kurt
+Kuwait
+Kuwaiti
+Kyoto
+lab
+Laban
+label
+labeled
+labeling
+labelled
+labeller
+labellers
+labelling
+labels
+labor
+laboratories
+laboratory
+labored
+laborer
+laborers
+laboring
+laborings
+laborious
+laboriously
+labors
+Labrador
+labs
+labyrinth
+labyrinths
+Lac
+lace
+laced
+lacerate
+lacerated
+lacerates
+lacerating
+laceration
+lacerations
+Lacerta
+laces
+Lacey
+Lachesis
+lacing
+lack
+Lackawanna
+lacked
+lackey
+lacking
+lacks
+lacquer
+lacquered
+lacquers
+lacrosse
+lactose
+lacy
+lad
+ladder
+laden
+ladies
+lading
+ladle
+lads
+lady
+ladylike
+Lafayette
+lag
+lager
+lagers
+lagoon
+lagoons
+Lagos
+Lagrange
+Lagrangian
+lags
+Laguerre
+Laguna
+Lahore
+laid
+Laidlaw
+lain
+lair
+lairs
+laissez
+lake
+Lakehurst
+lakes
+Lakewood
+Lamar
+Lamarck
+lamb
+lambda
+lambdas
+lambert
+lambs
+lame
+lamed
+lamely
+lameness
+lament
+lamentable
+lamentation
+lamentations
+lamented
+lamenting
+laments
+lames
+laminar
+laming
+lamp
+lamplight
+lampoon
+Lamport
+lamprey
+lamps
+Lana
+Lancashire
+Lancaster
+lance
+lanced
+Lancelot
+lancer
+lances
+land
+landed
+lander
+landers
+landfill
+landing
+landings
+Landis
+landladies
+landlady
+landlord
+landlords
+landmark
+landmarks
+landowner
+landowners
+lands
+landscape
+landscaped
+landscapes
+landscaping
+landslide
+Landwehr
+lane
+lanes
+Lang
+Lange
+Langeland
+Langford
+Langley
+Langmuir
+language
+languages
+languid
+languidly
+languidness
+languish
+languished
+languishes
+languishing
+Lanka
+Lansing
+lantern
+lanterns
+Lao
+Laocoon
+Laos
+Laotian
+Laotians
+lap
+lapel
+lapels
+Laplace
+Laplacian
+lapping
+laps
+lapse
+lapsed
+lapses
+lapsing
+Laramie
+lard
+larder
+Laredo
+Lares
+large
+largely
+largeness
+larger
+largest
+lark
+Larkin
+larks
+Larry
+Lars
+Larsen
+Larson
+larva
+larvae
+larynx
+lascivious
+laser
+lasers
+lash
+lashed
+lashes
+lashing
+lashings
+lass
+lasses
+lasso
+last
+lasted
+lasting
+lastly
+lasts
+Laszlo
+latch
+latched
+latches
+latching
+late
+lately
+latency
+lateness
+latent
+later
+lateral
+laterally
+Lateran
+latest
+LaTeX
+lathe
+Lathrop
+Latin
+Latinate
+Latinity
+Latinization
+Latinizations
+Latinize
+Latinized
+Latinizer
+Latinizers
+Latinizes
+Latinizing
+latitude
+latitudes
+latrine
+latrines
+Latrobe
+latter
+latterly
+lattice
+lattices
+Lattimer
+Latvia
+laudable
+Lauderdale
+Laue
+laugh
+laughable
+laughably
+laughed
+laughing
+laughingly
+laughingstock
+Laughlin
+laughs
+laughter
+launch
+launched
+launcher
+launches
+launching
+launchings
+launder
+laundered
+launderer
+laundering
+launderings
+launders
+Laundromat
+Laundromats
+laundry
+laureate
+laurel
+laurels
+Lauren
+Laurence
+Laurent
+Laurentian
+Laurie
+Lausanne
+lava
+lavatories
+lavatory
+lavender
+lavish
+lavished
+lavishing
+lavishly
+Lavoisier
+law
+lawbreaker
+Lawford
+lawful
+lawfully
+lawgiver
+lawless
+lawlessness
+lawn
+lawns
+Lawrence
+Lawrenceville
+laws
+Lawson
+lawsuit
+lawsuits
+lawyer
+lawyers
+lax
+laxative
+lay
+layer
+layered
+layering
+layers
+laying
+layman
+laymen
+layoff
+layoffs
+layout
+layouts
+lays
+Layton
+Lazarus
+lazed
+lazier
+laziest
+lazily
+laziness
+lazing
+lazy
+lazybones
+lead
+leaded
+leaden
+leader
+leaders
+leadership
+leaderships
+leading
+leadings
+leads
+leaf
+leafed
+leafiest
+leafing
+leafless
+leaflet
+leaflets
+leafy
+league
+leagued
+leaguer
+leaguers
+leagues
+leak
+leakage
+leakages
+leaked
+leaking
+leaks
+leaky
+lean
+Leander
+leaned
+leaner
+leanest
+leaning
+leanness
+leans
+leap
+leaped
+leapfrog
+leaping
+leaps
+leapt
+Lear
+learn
+learned
+learner
+learners
+learning
+learns
+Leary
+lease
+leased
+leases
+leash
+leashes
+leasing
+least
+leather
+leathered
+leathern
+leatherneck
+leathers
+leave
+leaved
+leaven
+leavened
+leavening
+Leavenworth
+leaves
+leaving
+leavings
+Lebanese
+Lebanon
+Lebesgue
+lechery
+lecture
+lectured
+lecturer
+lecturers
+lectures
+lecturing
+led
+ledge
+ledger
+ledgers
+ledges
+lee
+leech
+leeches
+Leeds
+leek
+leer
+leery
+lees
+Leeuwenhoek
+leeward
+leeway
+left
+leftist
+leftists
+leftmost
+leftover
+leftovers
+leftward
+leg
+legacies
+legacy
+legal
+legality
+legalization
+legalize
+legalized
+legalizes
+legalizing
+legally
+legend
+legendary
+Legendre
+legends
+Leger
+Legers
+legged
+leggings
+legibility
+legible
+legibly
+legion
+legions
+legislate
+legislated
+legislates
+legislating
+legislation
+legislative
+legislator
+legislators
+legislature
+legislatures
+legitimacy
+legitimate
+legitimately
+legs
+legume
+Lehigh
+Lehman
+Leibniz
+Leiden
+Leigh
+Leighton
+Leila
+Leipzig
+leisure
+leisurely
+Leland
+Lemke
+lemma
+lemmas
+lemming
+lemmings
+lemon
+lemonade
+lemons
+Lemuel
+Len
+Lena
+lend
+lender
+lenders
+lending
+lends
+length
+lengthen
+lengthened
+lengthening
+lengthens
+lengthly
+lengths
+lengthwise
+lengthy
+leniency
+lenient
+leniently
+Lenin
+Leningrad
+Leninism
+Leninist
+Lennox
+Lenny
+Lenore
+lens
+lenses
+lent
+Lenten
+lentil
+lentils
+Leo
+Leon
+Leona
+Leonard
+Leonardo
+Leone
+Leonid
+leopard
+leopards
+Leopold
+Leopoldville
+leper
+leprosy
+Leroy
+Lesbian
+Lesbians
+Leslie
+Lesotho
+less
+lessen
+lessened
+lessening
+lessens
+lesser
+lesson
+lessons
+lessor
+lest
+Lester
+let
+lethal
+Lethe
+Letitia
+lets
+letter
+lettered
+letterer
+letterhead
+lettering
+letters
+letting
+lettuce
+leukemia
+Lev
+levee
+levees
+level
+leveled
+leveler
+leveling
+levelled
+leveller
+levellest
+levelling
+levelly
+levelness
+levels
+lever
+leverage
+levers
+Levi
+Leviable
+levied
+levies
+Levin
+Levine
+Levis
+Leviticus
+Levitt
+levity
+levy
+levying
+Lew
+lewd
+lewdly
+lewdness
+Lewellyn
+lexical
+lexically
+lexicographic
+lexicographical
+lexicographically
+lexicon
+lexicons
+Lexington
+Leyden
+liabilities
+liability
+liable
+liaison
+liaisons
+liar
+liars
+libel
+libelous
+Liberace
+liberal
+liberalize
+liberalized
+liberalizes
+liberalizing
+liberally
+liberals
+liberate
+liberated
+liberates
+liberating
+liberation
+liberator
+liberators
+Liberia
+libertarian
+liberties
+liberty
+libido
+librarian
+librarians
+libraries
+library
+libretto
+Libreville
+Libya
+Libyan
+lice
+license
+licensed
+licensee
+licenses
+licensing
+licensor
+licentious
+lichen
+lichens
+Lichter
+lick
+licked
+licking
+licks
+licorice
+lid
+lids
+lie
+Lieberman
+Liechtenstein
+lied
+liege
+lien
+liens
+lies
+lieu
+lieutenant
+lieutenants
+life
+lifeblood
+lifeboat
+lifeguard
+lifeless
+lifelessness
+lifelike
+lifelong
+lifer
+lifespan
+lifestyle
+lifestyles
+lifetime
+lifetimes
+lift
+lifted
+lifter
+lifters
+lifting
+lifts
+ligament
+ligature
+Ligget
+Liggett
+light
+lighted
+lighten
+lightens
+lighter
+lighters
+lightest
+lightface
+lighthearted
+lighthouse
+lighthouses
+lighting
+lightly
+lightness
+lightning
+lightnings
+lights
+lightweight
+like
+liked
+likelier
+likeliest
+likelihood
+likelihoods
+likeliness
+likely
+liken
+likened
+likeness
+likenesses
+likening
+likens
+likes
+likewise
+liking
+Lila
+lilac
+lilacs
+Lilian
+lilies
+Lillian
+Lilliput
+Lilliputian
+Lilliputianize
+Lilliputianizes
+Lilly
+lily
+Lima
+Liman
+limb
+limber
+limbo
+limbs
+lime
+limelight
+Limerick
+limes
+limestone
+limit
+limitability
+limitably
+limitation
+limitations
+limited
+limiter
+limiters
+limiting
+limitless
+limits
+limousine
+limp
+limped
+limping
+limply
+limpness
+limps
+Lin
+Lincoln
+Lind
+Linda
+Lindberg
+Lindbergh
+linden
+Lindholm
+Lindquist
+Lindsay
+Lindsey
+Lindstrom
+Lindy
+line
+linear
+linearities
+linearity
+linearizable
+linearize
+linearized
+linearizes
+linearizing
+linearly
+lined
+linen
+linens
+liner
+liners
+lines
+lineup
+linger
+lingered
+lingerie
+lingering
+lingers
+lingo
+lingua
+linguist
+linguistic
+linguistically
+linguistics
+linguists
+lining
+linings
+link
+linkage
+linkages
+linked
+linker
+linkers
+linking
+links
+Linnaeus
+linoleum
+Linotype
+linseed
+lint
+Linton
+Linus
+Linux
+lion
+Lionel
+lioness
+lionesses
+lions
+lip
+Lippincott
+lips
+Lipschitz
+Lipscomb
+lipstick
+Lipton
+liquid
+liquidate
+liquidation
+liquidations
+liquidity
+liquids
+liquor
+liquors
+Lisa
+Lisbon
+Lise
+lisp
+lisped
+lisping
+lisps
+Liss
+Lissajous
+list
+listed
+listen
+listened
+listener
+listeners
+listening
+listens
+Lister
+Listerize
+Listerizes
+listers
+listing
+listings
+listless
+Liston
+lists
+lit
+litany
+liter
+literacy
+literal
+literally
+literalness
+literals
+literary
+literate
+literature
+literatures
+liters
+lithe
+lithograph
+lithography
+Lithuania
+Lithuanian
+litigant
+litigate
+litigation
+litigious
+litmus
+litter
+litterbug
+littered
+littering
+litters
+little
+littleness
+littler
+littlest
+Littleton
+Litton
+livable
+livably
+live
+lived
+livelihood
+lively
+liveness
+liver
+liveried
+Livermore
+Liverpool
+Liverpudlian
+livers
+livery
+lives
+livestock
+livid
+living
+Livingston
+Liz
+lizard
+lizards
+Lizzie
+Lizzy
+Lloyd
+load
+loaded
+loader
+loaders
+loading
+loadings
+loads
+loaf
+loafed
+loafer
+loan
+loaned
+loaning
+loans
+loath
+loathe
+loathed
+loathing
+loathly
+loathsome
+loaves
+lobbied
+lobbies
+lobby
+lobbying
+lobe
+lobes
+lobster
+lobsters
+local
+localities
+locality
+localization
+localize
+localized
+localizes
+localizing
+locally
+locals
+locate
+located
+locates
+locating
+location
+locations
+locative
+locatives
+locator
+locators
+loci
+lock
+Locke
+locked
+locker
+lockers
+Lockhart
+Lockheed
+Lockian
+locking
+lockings
+lockout
+lockouts
+locks
+locksmith
+lockstep
+lockup
+lockups
+Lockwood
+locomotion
+locomotive
+locomotives
+locus
+locust
+locusts
+lodge
+lodged
+lodger
+lodges
+lodging
+lodgings
+Lodowick
+Loeb
+loft
+loftiness
+lofts
+lofty
+Logan
+logarithm
+logarithmic
+logarithmically
+logarithms
+logged
+logger
+loggers
+logging
+logic
+logical
+logically
+logician
+logicians
+logics
+login
+logins
+logistic
+logistics
+logjam
+logo
+logs
+loin
+loincloth
+loins
+Loire
+Lois
+loiter
+loitered
+loiterer
+loitering
+loiters
+Loki
+Lola
+Lomb
+Lombard
+Lombardy
+Lome
+London
+Londonderry
+Londoner
+Londonization
+Londonizations
+Londonize
+Londonizes
+lone
+lonelier
+loneliest
+loneliness
+lonely
+loner
+loners
+lonesome
+long
+longed
+longer
+longest
+longevity
+Longfellow
+longhand
+longing
+longings
+longitude
+longitudes
+longs
+longstanding
+Longstreet
+look
+lookahead
+looked
+looker
+lookers
+looking
+lookout
+looks
+lookup
+lookups
+loom
+loomed
+looming
+Loomis
+looms
+loon
+loop
+looped
+loophole
+loopholes
+looping
+loops
+loose
+loosed
+looseleaf
+loosely
+loosen
+loosened
+looseness
+loosening
+loosens
+looser
+looses
+loosest
+loosing
+loot
+looted
+looter
+looting
+loots
+Lopez
+lopsided
+lord
+lordly
+lords
+lordship
+lore
+Lorelei
+Loren
+Lorentzian
+Lorenz
+Loretta
+Lorinda
+Lorraine
+lorry
+Los
+lose
+loser
+losers
+loses
+losing
+loss
+losses
+lossier
+lossiest
+lossy
+lost
+lot
+Lothario
+lotion
+lots
+Lotte
+lottery
+Lottie
+lotus
+Lou
+loud
+louder
+loudest
+loudly
+loudness
+loudspeaker
+loudspeakers
+Louis
+Louisa
+Louise
+Louisiana
+Louisianan
+Louisville
+lounge
+lounged
+lounges
+lounging
+Lounsbury
+Lourdes
+louse
+lousy
+lout
+Louvre
+lovable
+lovably
+love
+loved
+Lovejoy
+Lovelace
+Loveland
+lovelier
+lovelies
+loveliest
+loveliness
+lovelorn
+lovely
+lover
+lovers
+loves
+loving
+lovingly
+low
+Lowe
+Lowell
+lower
+lowered
+lowering
+lowers
+lowest
+lowland
+lowlands
+lowliest
+lowly
+lowness
+Lowry
+lows
+Loy
+loyal
+loyally
+loyalties
+loyalty
+Loyola
+Lubbock
+Lubell
+lubricant
+lubricate
+lubrication
+Lucas
+Lucerne
+Lucia
+Lucian
+lucid
+Lucien
+Lucifer
+Lucille
+Lucius
+luck
+lucked
+luckier
+luckiest
+luckily
+luckless
+lucks
+lucky
+lucrative
+Lucretia
+Lucretius
+Lucy
+ludicrous
+ludicrously
+ludicrousness
+Ludlow
+Ludmilla
+Ludwig
+Lufthansa
+Luftwaffe
+luggage
+Luis
+Luke
+lukewarm
+lull
+lullaby
+lulled
+lulls
+lumber
+lumbered
+lumbering
+luminous
+luminously
+lummox
+lump
+lumped
+lumping
+lumps
+Lumpur
+lumpy
+lunar
+lunatic
+lunch
+lunched
+luncheon
+luncheons
+lunches
+lunching
+Lund
+Lundberg
+Lundquist
+lung
+lunged
+lungs
+Lura
+lurch
+lurched
+lurches
+lurching
+lure
+lured
+lures
+luring
+lurk
+lurked
+lurking
+lurks
+Lusaka
+luscious
+lusciously
+lusciousness
+lush
+lust
+luster
+lustful
+lustily
+lustiness
+lustrous
+lusts
+lusty
+lute
+lutes
+Luther
+Lutheran
+Lutheranize
+Lutheranizer
+Lutheranizers
+Lutheranizes
+Lutz
+Luxembourg
+Luxemburg
+luxuriant
+luxuriantly
+luxuries
+luxurious
+luxuriously
+luxury
+Luzon
+L'vov
+Lydia
+lying
+Lykes
+Lyle
+Lyman
+lymph
+lynch
+Lynchburg
+lynched
+lyncher
+lynches
+Lyndon
+Lynn
+lynx
+lynxes
+Lyon
+Lyons
+Lyra
+lyre
+lyric
+lyrics
+Lysenko
+Mabel
+Mac
+Macadamia
+MacArthur
+Macarthur
+Macassar
+Macaulay
+Macaulayan
+Macaulayism
+Macaulayisms
+Macbeth
+MacDonald
+Macdonald
+MacDougall
+Macdougall
+MacDraw
+mace
+maced
+Macedon
+Macedonia
+Macedonian
+maces
+MacGregor
+Macgregor
+Mach
+Machiavelli
+Machiavellian
+machination
+machine
+machined
+machinelike
+machinery
+machines
+machining
+macho
+MacIntosh
+Macintosh
+macintosh
+MacKenzie
+Mackenzie
+mackerel
+Mackey
+Mackinac
+Mackinaw
+MacMahon
+MacMillan
+Macmillan
+Macon
+MacPaint
+macro
+macroeconomics
+macromolecule
+macromolecules
+macrophage
+macros
+macroscopic
+mad
+Madagascar
+madam
+Madame
+Madames
+madden
+maddening
+madder
+maddest
+Maddox
+made
+Madeira
+Madeleine
+Madeline
+madhouse
+Madhya
+Madison
+madly
+madman
+madmen
+madness
+Madonna
+Madonnas
+madras
+Madrid
+Madsen
+Mae
+Maelstrom
+maestro
+Mafia
+Mafiosi
+magazine
+magazines
+Magdalene
+Magellan
+Magellanic
+magenta
+Maggie
+maggot
+maggots
+magic
+magical
+magically
+magician
+magicians
+Magill
+magistrate
+magistrates
+magna
+magnesium
+magnet
+magnetic
+magnetically
+magnetism
+magnetisms
+magnetizable
+magnetized
+magneto
+magnification
+magnificence
+magnificent
+magnificently
+magnified
+magnifier
+magnifies
+magnify
+magnifying
+magnitude
+magnitudes
+magnolia
+magnum
+Magnuson
+Magog
+magpie
+Magruder
+Maguire
+Maguires
+Maharashtra
+Mahayana
+Mahayanist
+mahogany
+Mahoney
+maid
+maiden
+maidens
+maids
+Maier
+mail
+mailable
+mailbox
+mailboxes
+mailed
+mailer
+mailing
+mailings
+mailman
+mailmen
+mails
+maim
+maimed
+maiming
+maims
+main
+Maine
+mainframe
+mainframes
+mainland
+mainline
+mainly
+mains
+mainstay
+mainstream
+maintain
+maintainability
+maintainable
+maintained
+maintainer
+maintainers
+maintaining
+maintains
+maintenance
+maintenances
+maize
+majestic
+majesties
+majesty
+major
+Majorca
+majored
+majoring
+majorities
+majority
+majors
+makable
+make
+maker
+makers
+makes
+makeshift
+makeup
+makeups
+making
+makings
+Malabar
+maladies
+malady
+Malagasy
+Malamud
+malaria
+Malawi
+Malay
+Malayize
+Malayizes
+Malaysia
+Malaysian
+Malcolm
+malcontent
+Malden
+Maldive
+male
+malefactor
+malefactors
+maleness
+males
+malevolent
+malformed
+malfunction
+malfunctioned
+malfunctioning
+malfunctions
+Mali
+Malibu
+malice
+malicious
+maliciously
+maliciousness
+malign
+malignant
+malignantly
+mall
+mallard
+mallet
+mallets
+Mallory
+malnutrition
+Malone
+Maloney
+malpractice
+Malraux
+malt
+Malta
+malted
+Maltese
+Malthus
+Malthusian
+Malton
+malts
+mama
+mamma
+mammal
+mammalian
+mammals
+mammas
+mammoth
+man
+manage
+manageable
+manageableness
+managed
+management
+managements
+manager
+managerial
+managers
+manages
+managing
+Managua
+Manama
+Manchester
+Manchuria
+mandarin
+mandate
+mandated
+mandates
+mandating
+mandatory
+Mandelbrot
+mandible
+mane
+manes
+maneuver
+maneuvered
+maneuvering
+maneuvers
+Manfred
+manger
+mangers
+mangle
+mangled
+mangler
+mangles
+mangling
+Manhattan
+Manhattanize
+Manhattanizes
+manhole
+manhood
+mania
+maniac
+maniacal
+maniacs
+manic
+manicure
+manicured
+manicures
+manicuring
+manifest
+manifestation
+manifestations
+manifested
+manifesting
+manifestly
+manifests
+manifold
+manifolds
+Manila
+manipulability
+manipulable
+manipulatable
+manipulate
+manipulated
+manipulates
+manipulating
+manipulation
+manipulations
+manipulative
+manipulator
+manipulators
+manipulatory
+Manitoba
+Manitowoc
+mankind
+Mankowski
+Manley
+manly
+Mann
+manned
+manner
+mannered
+mannerly
+manners
+manning
+manometer
+manometers
+manor
+manors
+manpower
+Mans
+Mansfield
+mansion
+mansions
+manslaughter
+mantel
+mantels
+mantis
+mantissa
+mantissas
+mantle
+mantlepiece
+mantles
+manual
+manually
+manuals
+Manuel
+manufacture
+manufactured
+manufacturer
+manufacturers
+manufactures
+manufacturing
+manure
+manuscript
+manuscripts
+Manville
+many
+Mao
+Maori
+map
+maple
+Maplecrest
+maples
+mappable
+mapped
+mapping
+mappings
+maps
+marathon
+marble
+marbles
+marbling
+Marc
+Marceau
+Marcel
+Marcello
+march
+marched
+marcher
+marches
+marching
+Marcia
+Marco
+Marcotte
+Marcus
+Marcy
+Mardi
+Mardis
+mare
+mares
+Margaret
+margarine
+Margery
+margin
+marginal
+marginally
+margins
+Margo
+Marguerite
+Marianne
+Marie
+Marietta
+marigold
+marijuana
+Marilyn
+Marin
+marina
+marinade
+marinate
+marine
+mariner
+marines
+Marino
+Mario
+Marion
+marionette
+marital
+maritime
+Marjorie
+Marjory
+mark
+markable
+marked
+markedly
+marker
+markers
+market
+marketability
+marketable
+marketed
+marketing
+marketings
+marketplace
+marketplaces
+markets
+Markham
+marking
+markings
+Markism
+Markov
+Markovian
+Markovitz
+Marks
+Marlboro
+Marlborough
+Marlene
+Marlowe
+marmalade
+marmot
+maroon
+Marquette
+marquis
+marriage
+marriageable
+marriages
+married
+marries
+Marriott
+marrow
+marry
+marrying
+Mars
+Marseilles
+marsh
+Marsha
+marshal
+marshaled
+marshaling
+Marshall
+Marshalled
+Marshalling
+marshals
+marshes
+marshmallow
+mart
+marten
+Martha
+martial
+Martian
+Martians
+Martinez
+martingale
+martini
+Martinique
+Martinson
+marts
+Marty
+martyr
+martyrdom
+martyrs
+marvel
+marveled
+marvelled
+marvelling
+marvelous
+marvelously
+marvelousness
+marvels
+Marvin
+Marx
+Marxian
+Marxism
+Marxisms
+Marxist
+Mary
+Maryland
+Marylanders
+mascara
+masculine
+masculinely
+masculinity
+Maseru
+mash
+mashed
+mashes
+mashing
+mask
+maskable
+masked
+masker
+masking
+maskings
+masks
+masochist
+masochists
+mason
+Masonic
+Masonite
+masonry
+masons
+masquerade
+masquerader
+masquerades
+masquerading
+mass
+Massachusetts
+massacre
+massacred
+massacres
+massage
+massages
+massaging
+massed
+masses
+Massey
+massing
+massive
+mast
+masted
+master
+mastered
+masterful
+masterfully
+mastering
+masterings
+masterly
+mastermind
+masterpiece
+masterpieces
+masters
+mastery
+mastodon
+masts
+masturbate
+masturbated
+masturbates
+masturbating
+masturbation
+mat
+match
+matchable
+matched
+matcher
+matchers
+matches
+matching
+matchings
+matchless
+mate
+mated
+Mateo
+mater
+material
+materialist
+materialize
+materialized
+materializes
+materializing
+materially
+materials
+maternal
+maternally
+maternity
+mates
+math
+Mathematica
+mathematical
+mathematically
+mathematician
+mathematicians
+mathematics
+Mathematik
+Mathewson
+Mathias
+Mathieu
+Matilda
+mating
+matings
+Matisse
+Matisses
+matriarch
+matriarchal
+matrices
+matriculate
+matriculation
+matrimonial
+matrimony
+matrix
+matroid
+matron
+matronly
+mats
+Matson
+Matsumoto
+Matt
+matted
+matter
+mattered
+matters
+Matthew
+Matthews
+Mattie
+mattress
+mattresses
+Mattson
+maturation
+mature
+matured
+maturely
+matures
+maturing
+maturities
+maturity
+Maude
+maul
+Maureen
+Maurice
+Mauricio
+Maurine
+Mauritania
+Mauritius
+mausoleum
+maverick
+Mavis
+Mawr
+Max
+maxim
+maxima
+maximal
+maximally
+Maximilian
+maximize
+maximized
+maximizer
+maximizers
+maximizes
+maximizing
+maxims
+maximum
+maximums
+Maxine
+Maxtor
+Maxwell
+Maxwellian
+May
+Maya
+Mayans
+maybe
+Mayer
+Mayfair
+Mayflower
+mayhap
+mayhem
+Maynard
+Mayo
+mayonnaise
+mayor
+mayoral
+mayors
+Mazda
+maze
+mazes
+Mbabane
+McAdam
+McAdams
+McAllister
+McBride
+McCabe
+McCall
+McCallum
+McCann
+McCarthy
+McCarty
+McCauley
+McClain
+McClellan
+McClure
+McCluskey
+McConnel
+McConnell
+McCormick
+McCoy
+McCracken
+McCullough
+McDaniel
+McDermott
+McDonald
+McDonnell
+McDougall
+McDowell
+McElhaney
+McElroy
+McFadden
+McFarland
+McGee
+McGill
+McGinnis
+McGovern
+McGowan
+McGrath
+McGraw
+McGregor
+McGuire
+McHugh
+McIntosh
+McIntyre
+McKay
+McKee
+McKenna
+McKenzie
+McKeon
+McKesson
+McKinley
+McKinney
+McKnight
+McLanahan
+McLaughlin
+McLean
+McLeod
+McMahon
+McMartin
+McMillan
+McMullen
+McNally
+McNaughton
+McNeil
+McNulty
+McPherson
+me
+mead
+meadow
+meadows
+meager
+meagerly
+meagerness
+meal
+meals
+mealtime
+mealy
+mean
+meander
+meandered
+meandering
+meanders
+meaner
+meanest
+meaning
+meaningful
+meaningfully
+meaningfulness
+meaningless
+meaninglessly
+meaninglessness
+meanings
+meanly
+meanness
+means
+meant
+meantime
+meanwhile
+measle
+measles
+measurable
+measurably
+measure
+measured
+measurement
+measurements
+measurer
+measures
+measuring
+meat
+meats
+meaty
+Mecca
+mechanic
+mechanical
+mechanically
+mechanics
+mechanism
+mechanisms
+mechanization
+mechanizations
+mechanize
+mechanized
+mechanizes
+mechanizing
+medal
+medallion
+medallions
+medals
+meddle
+meddled
+meddler
+meddles
+meddling
+Medea
+Medfield
+Medford
+media
+median
+medians
+mediate
+mediated
+mediates
+mediating
+mediation
+mediations
+mediator
+medic
+Medicaid
+medical
+medically
+Medicare
+Medici
+medicinal
+medicinally
+medicine
+medicines
+Medicis
+medics
+medieval
+mediocre
+mediocrity
+meditate
+meditated
+meditates
+meditating
+meditation
+meditations
+meditative
+Mediterranean
+Mediterraneanization
+Mediterraneanizations
+Mediterraneanize
+Mediterraneanizes
+medium
+mediums
+medley
+Medusa
+Medusan
+meek
+meeker
+meekest
+meekly
+meekness
+meet
+meeting
+meetinghouse
+meetings
+meets
+Meg
+megabaud
+megabit
+megabits
+megabyte
+megabytes
+megahertz
+megalomania
+megaton
+megavolt
+megawatt
+megaword
+megawords
+megohm
+Meier
+Meiji
+Meister
+Meistersinger
+Mekong
+Mel
+Melampus
+melancholy
+Melanesia
+Melanesian
+Melanie
+Melbourne
+Melcher
+Melinda
+Melisande
+Melissa
+Mellon
+mellow
+mellowed
+mellowing
+mellowness
+mellows
+melodies
+melodious
+melodiously
+melodiousness
+melodrama
+melodramas
+melodramatic
+melody
+melon
+melons
+Melpomene
+melt
+melted
+melting
+meltingly
+melts
+Melville
+Melvin
+member
+members
+membership
+memberships
+membrane
+memento
+memo
+memoir
+memoirs
+memorabilia
+memorable
+memorableness
+memoranda
+memorandum
+memorial
+memorially
+memorials
+memories
+memorization
+memorize
+memorized
+memorizer
+memorizes
+memorizing
+memory
+memoryless
+memos
+Memphis
+men
+menace
+menaced
+menacing
+menagerie
+menarche
+Mencken
+mend
+mendacious
+mendacity
+mended
+Mendel
+Mendelian
+Mendelize
+Mendelizes
+Mendelssohn
+mender
+mending
+Mendoza
+mends
+Menelaus
+menial
+menials
+Menlo
+Mennonite
+Mennonites
+Menominee
+Menorca
+mens
+Mensch
+menstruate
+mensurable
+mensuration
+mental
+mentalities
+mentality
+mentally
+mention
+mentionable
+mentioned
+mentioner
+mentioners
+mentioning
+mentions
+mentor
+mentors
+menu
+menus
+Menzies
+Mephistopheles
+mercantile
+Mercator
+Mercedes
+mercenaries
+mercenariness
+mercenary
+merchandise
+merchandiser
+merchandising
+merchant
+merchants
+merciful
+mercifully
+merciless
+mercilessly
+Merck
+mercurial
+mercury
+mercy
+mere
+Meredith
+merely
+merest
+merge
+merged
+merger
+mergers
+merges
+merging
+meridian
+meringue
+merit
+merited
+meriting
+meritorious
+meritoriously
+meritoriousness
+merits
+Meriwether
+Merle
+mermaid
+Merriam
+Merrick
+merriest
+Merrill
+merrily
+Merrimac
+Merrimack
+merriment
+Merritt
+merry
+Merrymake
+Mervin
+mescaline
+mesh
+meson
+Mesopotamia
+mesosphere
+Mesozoic
+mesquite
+mess
+message
+messages
+messed
+messenger
+messengers
+messes
+Messiah
+messiahs
+messier
+messiest
+messily
+messiness
+messing
+messy
+met
+meta
+metabolic
+metabolism
+metacircular
+metacircularity
+metal
+metalanguage
+metallic
+metallization
+metallizations
+metallurgy
+metals
+metamathematical
+metamorphosis
+metaphor
+metaphorical
+metaphorically
+metaphors
+metaphysical
+metaphysically
+metaphysics
+metavariable
+Metcalf
+mete
+meted
+meteor
+meteoric
+meteorite
+meteoritic
+meteorology
+meteors
+meter
+metering
+meters
+metes
+methane
+method
+methodical
+methodically
+methodicalness
+Methodism
+Methodist
+methodists
+methodological
+methodologically
+methodologies
+methodologists
+methodology
+methods
+Methuen
+Methuselah
+Methuselahs
+meticulously
+meting
+Metrecal
+metric
+metrical
+metrics
+metro
+metronome
+metropolis
+metropolitan
+mets
+mettle
+mettlesome
+Metzler
+mew
+mewed
+mews
+Mexican
+Mexicanize
+Mexicanizes
+Mexicans
+Mexico
+Meyer
+Meyers
+Miami
+miasma
+mica
+mice
+Michael
+Michaels
+Michel
+Michelangelo
+Michele
+Michelin
+Michelson
+Michigan
+Mick
+Mickey
+Mickie
+Micky
+micro
+microarchitects
+microarchitecture
+microarchitectures
+microbial
+microbicidal
+microbicide
+microcode
+microcoded
+microcodes
+microcoding
+microcomputer
+microcomputers
+microcosm
+microcycle
+microcycles
+microeconomics
+microelectronics
+microfilm
+microfilms
+microgramming
+microinstruction
+microinstructions
+microjump
+microjumps
+microlevel
+micron
+Micronesia
+Micronesian
+microoperations
+microphone
+microphones
+microphoning
+Microport
+microprocedure
+microprocedures
+microprocessing
+microprocessor
+microprocessors
+microprogram
+microprogrammable
+microprogrammed
+microprogrammer
+microprogramming
+microprograms
+micros
+microscope
+microscopes
+microscopic
+microscopy
+microsecond
+microseconds
+Microsoft
+microstore
+microsystems
+MicroVAX
+MicroVAXes
+microwave
+microwaves
+microword
+microwords
+mid
+Midas
+midday
+middle
+Middlebury
+middleman
+middlemen
+middles
+Middlesex
+Middleton
+Middletown
+middling
+midget
+Midlandize
+Midlandizes
+midnight
+midnights
+midpoint
+midpoints
+midrange
+midscale
+midsection
+midshipman
+midshipmen
+midst
+midstream
+midsts
+midsummer
+midway
+midweek
+Midwest
+Midwestern
+Midwesterner
+Midwesterners
+midwife
+midwinter
+midwives
+mien
+might
+mightier
+mightiest
+mightily
+mightiness
+mighty
+migrant
+migrate
+migrated
+migrates
+migrating
+migration
+migrations
+migratory
+Miguel
+mike
+Mikhail
+Mikoyan
+Milan
+mild
+milder
+mildest
+mildew
+mildly
+mildness
+Mildred
+mile
+mileage
+Miles
+milestone
+milestones
+militant
+militantly
+militarily
+militarism
+military
+militia
+milk
+milked
+milker
+milkers
+milkiness
+milking
+milkmaid
+milkmaids
+milks
+milky
+mill
+Millard
+milled
+millennium
+miller
+millet
+milliammeter
+milliampere
+Millie
+millijoule
+Millikan
+millimeter
+millimeters
+millinery
+milling
+Millington
+million
+millionaire
+millionaires
+millions
+millionth
+millipede
+millipedes
+millisecond
+milliseconds
+millivolt
+millivoltmeter
+milliwatt
+Mills
+millstone
+millstones
+Milne
+Milquetoast
+Milquetoasts
+Milton
+Miltonian
+Miltonic
+Miltonism
+Miltonist
+Miltonize
+Miltonized
+Miltonizes
+Miltonizing
+Milwaukee
+mimeograph
+Mimi
+mimic
+mimicked
+mimicking
+mimics
+minaret
+mince
+minced
+mincemeat
+minces
+mincing
+mind
+Mindanao
+minded
+mindful
+mindfully
+mindfulness
+minding
+mindless
+mindlessly
+minds
+mine
+mined
+minefield
+miner
+mineral
+minerals
+miners
+Minerva
+mines
+minesweeper
+mingle
+mingled
+mingles
+mingling
+mini
+miniature
+miniatures
+miniaturization
+miniaturize
+miniaturized
+miniaturizes
+miniaturizing
+minicomputer
+minicomputers
+minima
+minimal
+minimally
+minimax
+minimization
+minimizations
+minimize
+minimized
+minimizer
+minimizers
+minimizes
+minimizing
+minimum
+mining
+minion
+minis
+minister
+ministered
+ministering
+ministers
+ministries
+ministry
+mink
+minks
+Minneapolis
+Minnesota
+Minnie
+minnow
+minnows
+Minoan
+minor
+minoring
+minorities
+minority
+minors
+Minos
+Minotaur
+Minsk
+Minsky
+minstrel
+minstrels
+mint
+minted
+minter
+minting
+mints
+minuend
+minuet
+minus
+minuscule
+minute
+minutely
+minuteman
+minutemen
+minuteness
+minuter
+minutes
+Miocene
+MIPS
+Mira
+miracle
+miracles
+miraculous
+miraculously
+mirage
+Miranda
+mire
+mired
+mires
+Mirfak
+Miriam
+mirror
+mirrored
+mirroring
+mirrors
+mirth
+misanthrope
+misbehaving
+miscalculation
+miscalculations
+miscarriage
+miscarry
+miscegenation
+miscellaneous
+miscellaneously
+miscellaneousness
+mischief
+mischievous
+mischievously
+mischievousness
+misconception
+misconceptions
+misconduct
+misconstrue
+misconstrued
+misconstrues
+misdemeanors
+miser
+miserable
+miserableness
+miserably
+miseries
+miserly
+misers
+misery
+misfit
+misfits
+misfortune
+misfortunes
+misgiving
+misgivings
+misguided
+mishap
+mishaps
+misinformed
+misjudged
+misjudgment
+mislead
+misleading
+misleads
+misled
+mismanagement
+mismatch
+mismatched
+mismatches
+mismatching
+misnomer
+misplace
+misplaced
+misplaces
+misplacing
+mispronunciation
+misrepresentation
+misrepresentations
+miss
+missed
+misses
+misshapen
+missile
+missiles
+missing
+mission
+missionaries
+missionary
+missioner
+missions
+Mississippi
+Mississippian
+Mississippians
+missive
+Missoula
+Missouri
+misspell
+misspelled
+misspelling
+misspellings
+misspells
+Missy
+mist
+mistakable
+mistake
+mistaken
+mistakenly
+mistakes
+mistaking
+misted
+mister
+misters
+mistiness
+misting
+mistletoe
+mistress
+mistrust
+mistrusted
+mists
+misty
+mistype
+mistyped
+mistypes
+mistyping
+misunderstand
+misunderstander
+misunderstanders
+misunderstanding
+misunderstandings
+misunderstood
+misuse
+misused
+misuses
+misusing
+Mitch
+Mitchell
+miter
+mitigate
+mitigated
+mitigates
+mitigating
+mitigation
+mitigative
+MITRE
+MITREs
+mitten
+mittens
+mix
+mixed
+mixer
+mixers
+mixes
+mixing
+mixture
+mixtures
+mixup
+Mizar
+mnemonic
+mnemonically
+mnemonics
+moan
+moaned
+moans
+moat
+moats
+mob
+Mobil
+mobile
+mobility
+mobs
+mobster
+moccasin
+moccasins
+mock
+mocked
+mocker
+mockery
+mocking
+mockingbird
+mocks
+mockup
+modal
+modalities
+modality
+modally
+mode
+model
+modeled
+modeling
+modelings
+models
+modem
+modems
+moderate
+moderated
+moderately
+moderateness
+moderates
+moderating
+moderation
+modern
+modernity
+modernize
+modernized
+modernizer
+modernizing
+modernly
+modernness
+moderns
+modes
+modest
+modestly
+Modesto
+modesty
+modicum
+modifiability
+modifiable
+modification
+modifications
+modified
+modifier
+modifiers
+modifies
+modify
+modifying
+Modula
+Modula-2
+Modula-3
+modular
+modularity
+modularization
+modularize
+modularized
+modularizes
+modularizing
+modularly
+modulate
+modulated
+modulates
+modulating
+modulation
+modulations
+modulator
+modulators
+module
+modules
+moduli
+modulo
+modulus
+modus
+Moe
+Moen
+Mogadiscio
+Mogadishu
+Moghul
+Mohammed
+Mohammedan
+Mohammedanism
+Mohammedanization
+Mohammedanizations
+Mohammedanize
+Mohammedanizes
+Mohawk
+Mohr
+Moines
+Moiseyev
+moist
+moisten
+moistly
+moistness
+moisture
+molar
+molasses
+mold
+Moldavia
+molded
+molder
+molding
+molds
+mole
+molecular
+molecule
+molecules
+molehill
+moles
+molest
+molested
+molesting
+molests
+Moliere
+Moline
+Moll
+Mollie
+mollify
+mollusk
+Molly
+mollycoddle
+Moloch
+Molochize
+Molochizes
+Molotov
+molten
+Moluccas
+moment
+momentarily
+momentariness
+momentary
+momentous
+momentously
+momentousness
+moments
+momentum
+mommy
+Mona
+Monaco
+monadic
+monarch
+monarchies
+monarchs
+monarchy
+Monash
+monasteries
+monastery
+monastic
+Monday
+Mondays
+Monet
+monetarism
+monetary
+money
+moneyed
+moneys
+Monfort
+Mongolia
+Mongolian
+Mongolianism
+mongoose
+Monica
+monitor
+monitored
+monitoring
+monitors
+monk
+monkey
+monkeyed
+monkeying
+monkeys
+monkish
+monks
+Monmouth
+monoalphabetic
+Monoceros
+monochromatic
+monochrome
+monocotyledon
+monocular
+monogamous
+monogamy
+monogram
+monograms
+monograph
+monographes
+monographs
+monolith
+monolithic
+monologue
+Monongahela
+monopolies
+monopolize
+monopolized
+monopolizing
+monopoly
+monoprogrammed
+monoprogramming
+monostable
+monotheism
+monotone
+monotonic
+monotonically
+monotonicity
+monotonous
+monotonously
+monotonousness
+monotony
+Monroe
+Monrovia
+Monsanto
+monsoon
+monster
+monsters
+monstrosity
+monstrous
+monstrously
+Mont
+Montague
+Montaigne
+Montana
+Montanan
+Montclair
+Montenegrin
+Montenegro
+Monterey
+Monteverdi
+Montevideo
+Montgomery
+month
+monthly
+months
+Monticello
+Montmartre
+Montpelier
+Montrachet
+Montreal
+Monty
+monument
+monumental
+monumentally
+monuments
+moo
+mood
+moodiness
+moods
+moody
+Moon
+mooned
+Mooney
+mooning
+moonlight
+moonlighter
+moonlighting
+Moonlike
+moonlit
+moons
+moonshine
+Moor
+Moore
+moored
+mooring
+moorings
+Moorish
+Moors
+moose
+moot
+mop
+moped
+mops
+moraine
+moral
+morale
+moralities
+morality
+morally
+morals
+Moran
+morass
+moratorium
+Moravia
+Moravian
+Moravianized
+Moravianizeds
+morbid
+morbidly
+morbidness
+more
+Morehouse
+Moreland
+moreover
+mores
+Moresby
+Morgan
+Moriarty
+moribund
+Morley
+Mormon
+morn
+morning
+mornings
+Moroccan
+Morocco
+moron
+morose
+morphine
+morphism
+morphisms
+morphological
+morphology
+Morrill
+Morris
+Morrison
+Morrissey
+Morristown
+morrow
+Morse
+morsel
+morsels
+mortal
+mortality
+mortally
+mortals
+mortar
+mortared
+mortaring
+mortars
+mortem
+mortgage
+mortgages
+mortician
+mortification
+mortified
+mortifies
+mortify
+mortifying
+Mortimer
+Morton
+mosaic
+mosaics
+Moscone
+Moscow
+Moser
+Moses
+Moslem
+Moslemize
+Moslemizes
+Moslems
+mosque
+mosquito
+mosquitoes
+moss
+Mossberg
+mosses
+mossy
+most
+mostly
+motel
+motels
+moth
+mothball
+mothballs
+mother
+mothered
+motherer
+motherers
+motherhood
+mothering
+motherland
+motherly
+mothers
+motif
+motifs
+motion
+motioned
+motioning
+motionless
+motionlessly
+motionlessness
+motions
+motivate
+motivated
+motivates
+motivating
+motivation
+motivations
+motive
+motives
+motley
+motor
+motorcar
+motorcars
+motorcycle
+motorcycles
+motoring
+motorist
+motorists
+motorize
+motorized
+motorizes
+motorizing
+Motorola
+motors
+motto
+mottoes
+mould
+moulding
+Moulton
+mound
+mounded
+mounds
+mount
+mountable
+mountain
+mountaineer
+mountaineering
+mountaineers
+mountainous
+mountainously
+mountains
+mounted
+mounter
+mounting
+mountings
+mounts
+mourn
+mourned
+mourner
+mourners
+mournful
+mournfully
+mournfulness
+mourning
+mourns
+mouse
+mouser
+mouses
+mousetrap
+mousy
+mouth
+Mouthe
+mouthed
+mouthes
+mouthful
+mouthing
+mouthpiece
+mouths
+Mouton
+movable
+move
+moved
+movement
+movements
+mover
+movers
+moves
+movie
+movies
+moving
+movings
+mow
+mowed
+mower
+mows
+Moyer
+Mozart
+mu
+much
+muck
+mucker
+mucking
+mucilage
+mucus
+mud
+Mudd
+muddied
+muddiness
+muddle
+muddled
+muddlehead
+muddler
+muddlers
+muddles
+muddling
+muddy
+Mueller
+Muenster
+muff
+muffin
+muffins
+muffle
+muffled
+muffler
+muffles
+muffling
+muffs
+mug
+mugging
+mugs
+Muhammad
+Muir
+Mukden
+mulatto
+mulberries
+mulberry
+mule
+mules
+mull
+mullah
+Mullen
+multi
+multibit
+Multibus
+multibyte
+multicast
+multicasting
+multicasts
+multicellular
+multicomputer
+MULTICS
+Multics
+multidimensional
+multilateral
+multilayer
+multilayered
+multilevel
+multimedia
+multinational
+multiple
+multiples
+multiplex
+multiplexed
+multiplexer
+multiplexers
+multiplexes
+multiplexing
+multiplexor
+multiplexors
+multiplicand
+multiplicands
+multiplication
+multiplications
+multiplicative
+multiplicatives
+multiplicity
+multiplied
+multiplier
+multipliers
+multiplies
+multiply
+multiplying
+multiprocess
+multiprocessing
+multiprocessor
+multiprocessors
+multiprogram
+multiprogrammed
+multiprogramming
+multistage
+multitude
+multitudes
+multiuser
+multivariate
+multiword
+mumble
+mumbled
+mumbler
+mumblers
+mumbles
+mumbling
+mumblings
+Mumford
+mummies
+mummy
+munch
+munched
+munching
+Muncie
+mundane
+mundanely
+Mundt
+mung
+Munich
+municipal
+municipalities
+municipality
+municipally
+munition
+munitions
+Munroe
+Munsey
+Munson
+Muong
+mural
+murder
+murdered
+murderer
+murderers
+murdering
+murderous
+murderously
+murders
+Muriel
+murky
+murmur
+murmured
+murmurer
+murmuring
+murmurs
+Murphy
+Murray
+Murrow
+Muscat
+muscle
+muscled
+muscles
+muscling
+Muscovite
+Muscovy
+muscular
+musculature
+muse
+mused
+muses
+museum
+museums
+mush
+mushroom
+mushroomed
+mushrooming
+mushrooms
+mushy
+music
+musical
+musically
+musicals
+musician
+musicianly
+musicians
+musicology
+musing
+musings
+musk
+Muskegon
+musket
+muskets
+muskox
+muskoxen
+muskrat
+muskrats
+musks
+Muslim
+Muslims
+muslin
+mussel
+mussels
+Mussolini
+Mussolinis
+Mussorgsky
+must
+mustache
+mustached
+mustaches
+mustard
+muster
+mustiness
+musts
+musty
+mutability
+mutable
+mutableness
+mutandis
+mutant
+mutate
+mutated
+mutates
+mutating
+mutation
+mutations
+mutatis
+mutative
+mute
+muted
+mutely
+muteness
+mutilate
+mutilated
+mutilates
+mutilating
+mutilation
+mutinies
+mutiny
+mutt
+mutter
+muttered
+mutterer
+mutterers
+muttering
+mutters
+mutton
+mutual
+mutually
+Muzak
+Muzo
+muzzle
+muzzles
+my
+Mycenae
+Mycenaean
+Myers
+Mynheer
+Myra
+myriad
+Myron
+myrtle
+myself
+Mysore
+mysteries
+mysterious
+mysteriously
+mysteriousness
+mystery
+mystic
+mystical
+mystics
+mystify
+myth
+mythical
+mythologies
+mythology
+nab
+Nabisco
+nabla
+nablas
+Nadia
+Nadine
+nadir
+nag
+Nagasaki
+nagged
+nagging
+Nagoya
+nags
+Nagy
+nail
+nailed
+nailing
+nails
+Nair
+Nairobi
+naive
+naively
+naiveness
+naivete
+Nakamura
+Nakayama
+naked
+nakedly
+nakedness
+Nakoma
+name
+nameable
+named
+nameless
+namelessly
+namely
+namer
+namers
+names
+namesake
+namesakes
+naming
+Nan
+Nancy
+Nanette
+Nanking
+nanoinstruction
+nanoinstructions
+Nanook
+nanoprogram
+nanoprogramming
+nanosecond
+nanoseconds
+nanostore
+nanostores
+Nantucket
+Naomi
+nap
+napkin
+napkins
+Naples
+Napoleon
+Napoleonic
+Napoleonize
+Napoleonizes
+naps
+Narbonne
+narcissus
+narcotic
+narcotics
+Narragansett
+narrate
+narration
+narrative
+narratives
+narrow
+narrowed
+narrower
+narrowest
+narrowing
+narrowly
+narrowness
+narrows
+nary
+NASA
+nasal
+nasally
+NASAs
+Nash
+Nashua
+Nashville
+Nassau
+nastier
+nastiest
+nastily
+nastiness
+nasty
+Nat
+natal
+Natalie
+Natchez
+Nate
+Nathan
+Nathaniel
+nation
+national
+nationalist
+nationalists
+nationalities
+nationality
+nationalization
+nationalize
+nationalized
+nationalizes
+nationalizing
+nationally
+nationals
+nationhood
+nations
+nationwide
+native
+natively
+natives
+nativity
+NATO
+NATOs
+natural
+naturalism
+naturalist
+naturalization
+naturally
+naturalness
+naturals
+nature
+natured
+natures
+naught
+naughtier
+naughtiness
+naughty
+Naur
+nausea
+nauseate
+nauseum
+Navaho
+Navajo
+naval
+navally
+navel
+navies
+navigable
+navigate
+navigated
+navigates
+navigating
+navigation
+navigator
+navigators
+Navona
+navy
+nay
+Nazarene
+Nazareth
+Nazi
+Nazis
+Nazism
+Ndjamena
+Neal
+Neanderthal
+Neapolitan
+near
+nearby
+neared
+nearer
+nearest
+nearing
+nearly
+nearness
+nears
+nearsighted
+neat
+neater
+neatest
+neatly
+neatness
+Nebraska
+Nebraskan
+Nebuchadnezzar
+nebula
+nebular
+nebulous
+necessaries
+necessarily
+necessary
+necessitate
+necessitated
+necessitates
+necessitating
+necessitation
+necessities
+necessity
+neck
+necking
+necklace
+necklaces
+neckline
+necks
+necktie
+neckties
+necrosis
+nectar
+Ned
+need
+needed
+needful
+Needham
+needing
+needle
+needled
+needler
+needlers
+needles
+needless
+needlessly
+needlessness
+needlework
+needling
+needs
+needy
+Neff
+negate
+negated
+negates
+negating
+negation
+negations
+negative
+negatively
+negatives
+negator
+negators
+neglect
+neglected
+neglecting
+neglects
+negligee
+negligence
+negligent
+negligible
+negotiable
+negotiate
+negotiated
+negotiates
+negotiating
+negotiation
+negotiations
+Negro
+Negroes
+Negroid
+Negroization
+Negroizations
+Negroize
+Negroizes
+Nehru
+neigh
+neighbor
+neighborhood
+neighborhoods
+neighboring
+neighborly
+neighbors
+Neil
+neither
+Nell
+Nellie
+Nelsen
+Nelson
+nemesis
+neoclassic
+neon
+neonatal
+neophyte
+neophytes
+Nepal
+Nepali
+nephew
+nephews
+Neptune
+Nero
+nerve
+nerves
+nervous
+nervously
+nervousness
+Ness
+nest
+nested
+nester
+nesting
+nestle
+nestled
+nestles
+nestling
+Nestor
+nests
+net
+nether
+Netherlands
+nets
+netted
+netting
+nettle
+nettled
+network
+networked
+networking
+networks
+Neumann
+neural
+neuritis
+neurological
+neurologists
+neuron
+neurons
+neuroses
+neurosis
+neurotic
+neuter
+neutral
+neutralities
+neutrality
+neutralize
+neutralized
+neutralizing
+neutrally
+neutrino
+neutrinos
+neutron
+Neva
+Nevada
+never
+nevertheless
+Nevins
+new
+Newark
+Newbold
+newborn
+Newbury
+Newburyport
+Newcastle
+newcomer
+newcomers
+Newell
+newer
+newest
+Newfoundland
+newly
+newlywed
+Newman
+Newmanize
+Newmanizes
+newness
+Newport
+NeWS
+newscast
+newsgroup
+newsletter
+newsletters
+newsman
+newsmen
+newspaper
+newspapers
+newsstand
+Newsweek
+Newsweekly
+newt
+Newton
+Newtonian
+next
+Nguyen
+Niagara
+Niamey
+nibble
+nibbled
+nibbler
+nibblers
+nibbles
+nibbling
+Nibelung
+Nicaragua
+Niccolo
+nice
+nicely
+niceness
+nicer
+nicest
+niche
+Nicholas
+Nicholls
+Nichols
+Nicholson
+nick
+nicked
+nickel
+nickels
+nicker
+nicking
+Nicklaus
+nickname
+nicknamed
+nicknames
+nicks
+Nicodemus
+Nicosia
+nicotine
+niece
+nieces
+Nielsen
+Nielson
+Nietzsche
+nifty
+Niger
+Nigeria
+Nigerian
+nigh
+night
+nightcap
+nightclub
+nightfall
+nightgown
+nightingale
+nightingales
+nightly
+nightmare
+nightmares
+nightmarish
+nights
+nighttime
+nihilism
+Nijinsky
+Nikko
+Nikolai
+nil
+Nile
+Nilsen
+Nilsson
+nimble
+nimbleness
+nimbler
+nimbly
+nimbus
+Nina
+nine
+ninefold
+nines
+nineteen
+nineteens
+nineteenth
+nineties
+ninetieth
+ninety
+Nineveh
+ninth
+Niobe
+nip
+nipple
+Nippon
+Nipponize
+Nipponizes
+nips
+nitric
+nitrogen
+nitrous
+nitty
+Nixon
+no
+Noah
+Nobel
+nobility
+noble
+nobleman
+nobleness
+nobler
+nobles
+noblest
+nobly
+nobody
+nocturnal
+nocturnally
+nod
+nodal
+nodded
+nodding
+node
+nodes
+nods
+nodular
+nodule
+Noel
+Noetherian
+noise
+noiseless
+noiselessly
+noises
+noisier
+noisily
+noisiness
+noisy
+Nolan
+Noll
+nomenclature
+nominal
+nominally
+nominate
+nominated
+nominating
+nomination
+nominative
+nominee
+non
+nonadaptive
+nonbiodegradable
+nonblocking
+nonce
+nonchalant
+noncommercial
+noncommunication
+nonconsecutively
+nonconservative
+noncritical
+noncyclic
+nondecreasing
+nondescript
+nondescriptly
+nondestructively
+nondeterminacy
+nondeterminate
+nondeterminately
+nondeterminism
+nondeterministic
+nondeterministically
+none
+nonempty
+nonetheless
+nonexistence
+nonexistent
+nonextensible
+nonfunctional
+nongovernmental
+nonidempotent
+noninteracting
+noninterference
+noninterleaved
+nonintrusive
+nonintuitive
+noninverting
+nonlinear
+nonlinearities
+nonlinearity
+nonlinearly
+nonlocal
+nonmaskable
+nonmathematical
+nonmilitary
+nonnegative
+nonnegligible
+nonnumerical
+nonogenarian
+nonorthogonal
+nonorthogonality
+nonperishable
+nonpersistent
+nonportable
+nonprocedural
+nonprocedurally
+nonprofit
+nonprogrammable
+nonprogrammer
+nonsegmented
+nonsense
+nonsensical
+nonsequential
+nonspecialist
+nonspecialists
+nonstandard
+nonsynchronous
+nontechnical
+nonterminal
+nonterminals
+nonterminating
+nontermination
+nonthermal
+nontransparent
+nontrivial
+nonuniform
+nonuniformity
+nonzero
+noodle
+nook
+nooks
+noon
+noonday
+noons
+noontide
+noontime
+noose
+nor
+Nora
+Nordhoff
+Nordic
+Nordstrom
+Noreen
+Norfolk
+norm
+Norma
+normal
+normalcy
+normality
+normalization
+normalize
+normalized
+normalizes
+normalizing
+normally
+normals
+Norman
+Normandy
+Normanization
+Normanizations
+Normanize
+Normanizer
+Normanizers
+Normanizes
+normative
+norms
+Norris
+Norristown
+Norse
+north
+Northampton
+northbound
+northeast
+northeaster
+northeastern
+northerly
+northern
+northerner
+northerners
+northernly
+Northfield
+Northrop
+Northrup
+Northumberland
+northward
+northwards
+northwest
+northwestern
+Norton
+Norwalk
+Norway
+Norwegian
+Norwich
+nose
+nosed
+noses
+nosing
+nostalgia
+nostalgic
+Nostradamus
+Nostrand
+nostril
+nostrils
+not
+notable
+notables
+notably
+notarize
+notarized
+notarizes
+notarizing
+notary
+notation
+notational
+notations
+notch
+notched
+notches
+notching
+note
+notebook
+notebooks
+noted
+notes
+noteworthy
+nothing
+nothingness
+nothings
+notice
+noticeable
+noticeably
+noticed
+notices
+noticing
+notification
+notifications
+notified
+notifier
+notifiers
+notifies
+notify
+notifying
+noting
+notion
+notions
+notoriety
+notorious
+notoriously
+Notre
+Nottingham
+notwithstanding
+Nouakchott
+noun
+nouns
+nourish
+nourished
+nourishes
+nourishing
+nourishment
+Novak
+novel
+novelist
+novelists
+novels
+novelties
+novelty
+November
+Novembers
+novice
+novices
+Novosibirsk
+now
+nowadays
+nowhere
+noxious
+Noyes
+nozzle
+nu
+nuance
+nuances
+Nubia
+Nubian
+nubile
+nuclear
+nuclei
+nucleic
+nucleotide
+nucleotides
+nucleus
+nuclide
+nude
+nudge
+nudged
+nudity
+Nugent
+nugget
+nuisance
+nuisances
+null
+nullary
+nulled
+nullified
+nullifiers
+nullifies
+nullify
+nullifying
+nulls
+numb
+numbed
+number
+numbered
+numberer
+numbering
+numberless
+numbers
+numbing
+numbly
+numbness
+numbs
+numerable
+numeral
+numerals
+numerator
+numerators
+numeric
+numerical
+numerically
+numerics
+numerous
+numismatic
+numismatist
+nun
+nuns
+nuptial
+nurse
+nursed
+nurseries
+nursery
+nurses
+nursing
+nurture
+nurtured
+nurtures
+nurturing
+nut
+nutate
+nutria
+nutrient
+nutrition
+nutritious
+nuts
+nutshell
+nutshells
+nuzzle
+nylon
+nymph
+nymphomania
+nymphomaniac
+nymphs
+Nyquist
+oaf
+oak
+oaken
+Oakland
+Oakley
+Oakmont
+oaks
+oar
+oars
+oases
+oasis
+oat
+oaten
+oath
+oaths
+oatmeal
+oats
+obedience
+obediences
+obedient
+obediently
+obelisk
+Oberlin
+Oberon
+obese
+obey
+obeyed
+obeying
+obeys
+obfuscate
+obfuscatory
+obituary
+object
+objected
+objecting
+objection
+objectionable
+objections
+objective
+objectively
+objectives
+objector
+objectors
+objects
+obligated
+obligation
+obligations
+obligatory
+oblige
+obliged
+obliges
+obliging
+obligingly
+oblique
+obliquely
+obliqueness
+obliterate
+obliterated
+obliterates
+obliterating
+obliteration
+oblivion
+oblivious
+obliviously
+obliviousness
+oblong
+obnoxious
+oboe
+O'Brien
+obscene
+obscure
+obscured
+obscurely
+obscurer
+obscures
+obscuring
+obscurities
+obscurity
+obsequious
+observable
+observance
+observances
+observant
+observation
+observations
+observatory
+observe
+observed
+observer
+observers
+observes
+observing
+obsession
+obsessions
+obsessive
+obsolescence
+obsolescent
+obsolete
+obsoleted
+obsoletes
+obsoleting
+obstacle
+obstacles
+obstinacy
+obstinate
+obstinately
+obstruct
+obstructed
+obstructing
+obstruction
+obstructions
+obstructive
+obtain
+obtainable
+obtainably
+obtained
+obtaining
+obtains
+obviate
+obviated
+obviates
+obviating
+obviation
+obviations
+obvious
+obviously
+obviousness
+Occam
+occasion
+occasional
+occasionally
+occasioned
+occasioning
+occasionings
+occasions
+Occident
+Occidental
+Occidentalization
+Occidentalizations
+Occidentalize
+Occidentalized
+Occidentalizes
+Occidentalizing
+Occidentals
+occipital
+occlude
+occluded
+occludes
+occlusion
+occlusions
+occult
+occupancies
+occupancy
+occupant
+occupants
+occupation
+occupational
+occupationally
+occupations
+occupied
+occupier
+occupies
+occupy
+occupying
+occur
+occurred
+occurrence
+occurrences
+occurring
+occurs
+ocean
+Oceania
+oceanic
+oceanography
+oceans
+O'Connell
+O'Connor
+Oconomowoc
+octagon
+octagonal
+octahedra
+octahedral
+octahedron
+octal
+octane
+octave
+octaves
+Octavia
+octet
+octets
+October
+Octobers
+octogenarian
+octopus
+odd
+odder
+oddest
+oddities
+oddity
+oddly
+oddness
+odds
+ode
+O'Dell
+Oderberg
+Oderbergs
+odes
+Odessa
+Odin
+odious
+odiously
+odiousness
+odium
+O'Donnell
+odor
+odorous
+odorously
+odorousness
+odors
+O'Dwyer
+Odysseus
+Odyssey
+Oedipal
+Oedipally
+Oedipus
+of
+off
+Offenbach
+offend
+offended
+offender
+offenders
+offending
+offends
+offense
+offenses
+offensive
+offensively
+offensiveness
+offer
+offered
+offerer
+offerers
+offering
+offerings
+offers
+offhand
+office
+officemate
+officer
+officers
+offices
+official
+officialdom
+officially
+officials
+officiate
+officio
+officious
+officiously
+officiousness
+offing
+offload
+offs
+offset
+offsets
+offsetting
+offshore
+offspring
+oft
+often
+oftentimes
+Ogden
+oh
+O'Hare
+Ohio
+ohm
+ohmmeter
+oil
+oilcloth
+oiled
+oiler
+oilers
+oilier
+oiliest
+oiling
+oils
+oily
+ointment
+Ojibwa
+Okamoto
+okay
+Okinawa
+Oklahoma
+Oklahoman
+Olaf
+Olav
+old
+olden
+Oldenburg
+older
+oldest
+oldness
+Oldsmobile
+Olduvai
+oldy
+oleander
+O'Leary
+Oleg
+oleomargarine
+Olga
+oligarchy
+Oligocene
+Olin
+olive
+Oliver
+Olivers
+olives
+Olivetti
+Olivia
+Olivier
+Olsen
+Olson
+Olympia
+Olympian
+Olympianize
+Olympianizes
+Olympic
+Olympics
+Olympus
+Omaha
+Oman
+omega
+omelet
+omen
+omens
+omicron
+ominous
+ominously
+ominousness
+omission
+omissions
+omit
+omits
+omitted
+omitting
+omnibus
+omnidirectional
+omnipotent
+omnipresent
+omniscient
+omnisciently
+omnivore
+on
+onanism
+once
+oncology
+one
+Oneida
+O'Neill
+oneness
+onerous
+ones
+oneself
+onetime
+ongoing
+onion
+onions
+online
+onlooker
+only
+Onondaga
+onrush
+onset
+onsets
+onslaught
+Ontario
+onto
+ontology
+onus
+onward
+onwards
+onyx
+ooze
+oozed
+opacity
+opal
+opals
+opaque
+opaquely
+opaqueness
+opcode
+OPEC
+Opel
+open
+opened
+opener
+openers
+opening
+openings
+openly
+openness
+opens
+opera
+operable
+operand
+operandi
+operands
+operas
+operate
+operated
+operates
+operating
+operation
+operational
+operationally
+operations
+operative
+operatives
+operator
+operators
+operetta
+Ophiuchus
+Ophiucus
+opiate
+opinion
+opinions
+opium
+opossum
+Oppenheimer
+opponent
+opponents
+opportune
+opportunely
+opportunism
+opportunistic
+opportunities
+opportunity
+opposable
+oppose
+opposed
+opposes
+opposing
+opposite
+oppositely
+oppositeness
+opposites
+opposition
+oppress
+oppressed
+oppresses
+oppressing
+oppression
+oppressive
+oppressor
+oppressors
+opprobrium
+opt
+opted
+opthalmic
+optic
+optical
+optically
+optics
+optima
+optimal
+optimality
+optimally
+optimism
+optimist
+optimistic
+optimistically
+optimization
+optimizations
+optimize
+optimized
+optimizer
+optimizers
+optimizes
+optimizing
+optimum
+opting
+option
+optional
+optionally
+options
+optoacoustic
+optometrist
+optometry
+opts
+opulence
+opulent
+opus
+or
+oracle
+oracles
+oral
+orally
+orange
+oranges
+orangutan
+oration
+orations
+orator
+oratories
+orators
+oratory
+orb
+orbit
+orbital
+orbitally
+orbited
+orbiter
+orbiters
+orbiting
+orbits
+orchard
+orchards
+orchestra
+orchestral
+orchestras
+orchestrate
+orchid
+orchids
+ordain
+ordained
+ordaining
+ordains
+ordeal
+order
+ordered
+ordering
+orderings
+orderlies
+orderly
+orders
+ordinal
+ordinance
+ordinances
+ordinarily
+ordinariness
+ordinary
+ordinate
+ordinates
+ordination
+ore
+oregano
+Oregon
+Oregonians
+ores
+Oresteia
+Orestes
+organ
+organic
+organism
+organisms
+organist
+organists
+organizable
+organization
+organizational
+organizationally
+organizations
+organize
+organized
+organizer
+organizers
+organizes
+organizing
+organs
+orgasm
+orgiastic
+orgies
+orgy
+Orient
+Oriental
+Orientalization
+Orientalizations
+Orientalize
+Orientalized
+Orientalizes
+Orientalizing
+Orientals
+orientation
+orientations
+oriented
+orienting
+orients
+orifice
+orifices
+origin
+original
+originality
+originally
+originals
+originate
+originated
+originates
+originating
+origination
+originator
+originators
+origins
+Orin
+Orinoco
+oriole
+Orion
+Orkney
+Orlando
+Orleans
+Orlick
+Orly
+ornament
+ornamental
+ornamentally
+ornamentation
+ornamented
+ornamenting
+ornaments
+ornate
+ornery
+Orono
+orphan
+orphanage
+orphaned
+orphans
+Orpheus
+Orphic
+Orphically
+Orr
+Ortega
+orthant
+orthodontist
+orthodox
+orthodoxy
+orthogonal
+orthogonality
+orthogonally
+orthopedic
+Orville
+Orwell
+Orwellian
+Osaka
+Osbert
+Osborn
+Osborne
+Oscar
+oscillate
+oscillated
+oscillates
+oscillating
+oscillation
+oscillations
+oscillator
+oscillators
+oscillatory
+oscilloscope
+oscilloscopes
+Osgood
+O'Shea
+Oshkosh
+Osiris
+Oslo
+osmosis
+osmotic
+ossify
+ostensible
+ostensibly
+ostentatious
+osteopath
+osteopathic
+osteopathy
+osteoporosis
+ostracism
+Ostrander
+ostrich
+ostriches
+O'Sullivan
+Oswald
+Othello
+other
+others
+otherwise
+otherworldly
+Otis
+Ott
+Ottawa
+otter
+otters
+Otto
+Ottoman
+Ottomanization
+Ottomanizations
+Ottomanize
+Ottomanizes
+Ouagadougou
+ouch
+ought
+ounce
+ounces
+our
+ours
+ourself
+ourselves
+oust
+out
+outbound
+outbreak
+outbreaks
+outburst
+outbursts
+outcast
+outcasts
+outcome
+outcomes
+outcries
+outcry
+outdated
+outdo
+outdoor
+outdoors
+outer
+outermost
+outfit
+outfits
+outfitted
+outgoing
+outgrew
+outgrow
+outgrowing
+outgrown
+outgrows
+outgrowth
+outing
+outlandish
+outlast
+outlasts
+outlaw
+outlawed
+outlawing
+outlaws
+outlay
+outlays
+outlet
+outlets
+outline
+outlined
+outlines
+outlining
+outlive
+outlived
+outlives
+outliving
+outlook
+outlying
+outnumbered
+outperform
+outperformed
+outperforming
+outperforms
+outpost
+outposts
+output
+outputs
+outputting
+outrage
+outraged
+outrageous
+outrageously
+outrages
+outright
+outrun
+outruns
+outs
+outset
+outside
+outsider
+outsiders
+outskirts
+outstanding
+outstandingly
+outstretched
+outstrip
+outstripped
+outstripping
+outstrips
+outvote
+outvoted
+outvotes
+outvoting
+outward
+outwardly
+outweigh
+outweighed
+outweighing
+outweighs
+outwit
+outwits
+outwitted
+outwitting
+oval
+ovals
+ovaries
+ovary
+oven
+ovens
+over
+overall
+overalls
+overboard
+overcame
+overcoat
+overcoats
+overcome
+overcomes
+overcoming
+overcrowd
+overcrowded
+overcrowding
+overcrowds
+overdone
+overdose
+overdraft
+overdrafts
+overdue
+overemphasis
+overemphasized
+overestimate
+overestimated
+overestimates
+overestimating
+overestimation
+overflow
+overflowed
+overflowing
+overflows
+overgrown
+overhang
+overhanging
+overhangs
+overhaul
+overhauling
+overhead
+overheads
+overhear
+overheard
+overhearing
+overhears
+overjoy
+overjoyed
+overkill
+overland
+overlap
+overlapped
+overlapping
+overlaps
+overlay
+overlaying
+overlays
+overload
+overloaded
+overloading
+overloads
+overlook
+overlooked
+overlooking
+overlooks
+overly
+overnight
+overnighter
+overnighters
+overpower
+overpowered
+overpowering
+overpowers
+overprint
+overprinted
+overprinting
+overprints
+overproduction
+overridden
+override
+overrides
+overriding
+overrode
+overrule
+overruled
+overrules
+overrun
+overrunning
+overruns
+overseas
+oversee
+overseeing
+overseer
+overseers
+oversees
+overshadow
+overshadowed
+overshadowing
+overshadows
+overshoot
+overshot
+oversight
+oversights
+oversimplified
+oversimplifies
+oversimplify
+oversimplifying
+oversized
+overstate
+overstated
+overstatement
+overstatements
+overstates
+overstating
+overstocks
+oversubscribed
+overt
+overtake
+overtaken
+overtaker
+overtakers
+overtakes
+overtaking
+overthrew
+overthrow
+overthrown
+overtime
+overtly
+overtone
+overtones
+overtook
+overture
+overtures
+overturn
+overturned
+overturning
+overturns
+overuse
+overview
+overviews
+overwhelm
+overwhelmed
+overwhelming
+overwhelmingly
+overwhelms
+overwork
+overworked
+overworking
+overworks
+overwrite
+overwrites
+overwriting
+overwritten
+overzealous
+Ovid
+owe
+owed
+Owen
+Owens
+owes
+owing
+owl
+owls
+own
+owned
+owner
+owners
+ownership
+ownerships
+owning
+owns
+ox
+oxen
+Oxford
+oxide
+oxides
+oxidize
+oxidized
+Oxnard
+Oxonian
+oxygen
+oyster
+oysters
+Oz
+Ozark
+Ozarks
+ozone
+Ozzie
+Pablo
+Pabst
+pace
+paced
+pacemaker
+pacer
+pacers
+paces
+pacific
+pacification
+pacified
+pacifier
+pacifies
+pacifism
+pacifist
+pacify
+pacing
+pack
+package
+packaged
+packager
+packagers
+packages
+packaging
+packagings
+Packard
+Packards
+packed
+packer
+packers
+packet
+packets
+packing
+packs
+Packwood
+pact
+pacts
+pad
+padded
+padding
+paddle
+paddock
+paddy
+padlock
+pads
+pagan
+Paganini
+pagans
+page
+pageant
+pageantry
+pageants
+paged
+pager
+pagers
+pages
+paginate
+paginated
+paginates
+paginating
+pagination
+paging
+pagoda
+paid
+pail
+pails
+pain
+Paine
+pained
+painful
+painfully
+painless
+pains
+painstaking
+painstakingly
+paint
+painted
+painter
+painters
+painting
+paintings
+paints
+pair
+paired
+pairing
+pairings
+pairs
+pairwise
+pajama
+pajamas
+Pakistan
+Pakistani
+Pakistanis
+pal
+palace
+palaces
+palate
+palates
+Palatine
+pale
+paled
+palely
+paleness
+Paleolithic
+Paleozoic
+paler
+Palermo
+pales
+palest
+Palestine
+Palestinian
+palfrey
+palindrome
+palindromic
+paling
+pall
+Palladian
+palladium
+palliate
+palliative
+pallid
+palm
+palmed
+palmer
+palming
+Palmolive
+palms
+Palmyra
+Palo
+Palomar
+palpable
+pals
+palsy
+Pam
+Pamela
+pamper
+pamphlet
+pamphlets
+pan
+panacea
+panaceas
+panama
+Panamanian
+pancake
+pancakes
+Pancho
+panda
+Pandanus
+pandas
+pandemic
+pandemonium
+pander
+Pandora
+pane
+panel
+paneled
+paneling
+panelist
+panelists
+panels
+panes
+pang
+Pangaea
+pangs
+panic
+panicked
+panicking
+panicky
+panics
+panned
+panning
+panorama
+panoramic
+pans
+pansies
+pansy
+pant
+panted
+pantheism
+pantheist
+pantheon
+panther
+panthers
+panties
+panting
+pantomime
+pantries
+pantry
+pants
+panty
+pantyhose
+Paoli
+papa
+papal
+paper
+paperback
+paperbacks
+papered
+paperer
+paperers
+papering
+paperings
+papers
+paperweight
+paperwork
+papoose
+Pappas
+Papua
+papyrus
+par
+parabola
+parabolic
+paraboloid
+paraboloidal
+parachute
+parachuted
+parachutes
+parade
+paraded
+parades
+paradigm
+paradigms
+parading
+paradise
+paradox
+paradoxes
+paradoxical
+paradoxically
+paraffin
+paragon
+paragons
+paragraph
+paragraphing
+paragraphs
+Paraguay
+Paraguayan
+Paraguayans
+parakeet
+parallax
+parallel
+paralleled
+paralleling
+parallelism
+parallelize
+parallelized
+parallelizes
+parallelizing
+parallelogram
+parallelograms
+parallels
+paralysis
+paralyze
+paralyzed
+paralyzes
+paralyzing
+parameter
+parameterizable
+parameterization
+parameterizations
+parameterize
+parameterized
+parameterizes
+parameterizing
+parameterless
+parameters
+parametric
+parametrized
+paramilitary
+paramount
+Paramus
+paranoia
+paranoiac
+paranoid
+paranormal
+parapet
+parapets
+paraphernalia
+paraphrase
+paraphrased
+paraphrases
+paraphrasing
+parapsychology
+parasite
+parasites
+parasitic
+parasitics
+parasol
+parboil
+PARC
+parcel
+parceled
+parceling
+parcels
+parch
+parched
+parchment
+pardon
+pardonable
+pardonably
+pardoned
+pardoner
+pardoners
+pardoning
+pardons
+pare
+paregoric
+parent
+parentage
+parental
+parentheses
+parenthesis
+parenthesized
+parenthesizes
+parenthesizing
+parenthetic
+parenthetical
+parenthetically
+parenthood
+parents
+pares
+Pareto
+pariah
+parimutuel
+paring
+parings
+Paris
+parish
+parishes
+parishioner
+Parisian
+Parisianization
+Parisianizations
+Parisianize
+Parisianizes
+parity
+park
+Parke
+parked
+parker
+parkers
+Parkersburg
+Parkhouse
+parking
+Parkinson
+Parkinsonian
+parkland
+parklike
+Parks
+parkway
+parlay
+parley
+parliament
+parliamentarian
+parliamentary
+parliaments
+parlor
+parlors
+Parmesan
+parochial
+parody
+parole
+paroled
+paroles
+paroling
+Parr
+parried
+Parrish
+parrot
+parroting
+parrots
+Parrs
+parry
+pars
+parse
+parsed
+parser
+parsers
+parses
+Parsi
+Parsifal
+parsimony
+parsing
+parsings
+parsley
+parson
+Parsons
+part
+partake
+partaker
+partakes
+partaking
+parted
+parter
+parters
+Parthenon
+Parthia
+partial
+partiality
+partially
+participant
+participants
+participate
+participated
+participates
+participating
+participation
+participle
+particle
+particles
+particular
+particularly
+particulars
+particulate
+parties
+parting
+partings
+partisan
+partisans
+partition
+partitioned
+partitioning
+partitions
+partly
+partner
+partnered
+partners
+partnership
+partook
+partridge
+partridges
+parts
+party
+Pasadena
+PASCAL
+Pascal
+Paso
+pass
+passage
+passages
+passageway
+Passaic
+passe
+passed
+passenger
+passengers
+passer
+passers
+passes
+passing
+passion
+passionate
+passionately
+passions
+passivate
+passive
+passively
+passiveness
+passivity
+Passover
+passport
+passports
+password
+passwords
+past
+paste
+pasted
+pastel
+Pasternak
+pastes
+Pasteur
+pastime
+pastimes
+pasting
+pastness
+pastor
+pastoral
+pastors
+pastry
+pasts
+pasture
+pastures
+pat
+Patagonia
+Patagonians
+patch
+patched
+patches
+patching
+patchwork
+patchy
+pate
+paten
+patent
+patentable
+patented
+patenter
+patenters
+patenting
+patently
+patents
+paternal
+paternally
+paternoster
+Paterson
+path
+pathetic
+pathname
+pathnames
+pathogen
+pathogenesis
+pathological
+pathology
+pathos
+paths
+pathway
+pathways
+patience
+patient
+patiently
+patients
+patina
+patio
+patriarch
+patriarchal
+patriarchs
+patriarchy
+Patrice
+Patricia
+patrician
+patricians
+Patrick
+patrimonial
+patrimony
+patriot
+patriotic
+patriotism
+patriots
+patrol
+patrolled
+patrolling
+patrolman
+patrolmen
+patrols
+patron
+patronage
+patronize
+patronized
+patronizes
+patronizing
+patrons
+pats
+Patsies
+Patsy
+patter
+pattered
+pattering
+patterings
+pattern
+patterned
+patterning
+patterns
+patters
+Patterson
+Patti
+patties
+Patton
+patty
+paucity
+Paul
+Paula
+Paulette
+Pauli
+Pauline
+Pauling
+Paulinize
+Paulinizes
+Paulo
+Paulsen
+Paulson
+Paulus
+paunch
+paunchy
+pauper
+pause
+paused
+pauses
+pausing
+pave
+paved
+pavement
+pavements
+paves
+pavilion
+pavilions
+paving
+Pavlov
+Pavlovian
+paw
+pawing
+pawn
+pawns
+pawnshop
+paws
+Pawtucket
+pay
+payable
+paycheck
+paychecks
+payed
+payer
+payers
+paying
+payment
+payments
+Payne
+Paynes
+Paynize
+Paynizes
+payoff
+payoffs
+payroll
+pays
+Payson
+Paz
+pea
+Peabody
+peace
+peaceable
+peaceful
+peacefully
+peacefulness
+peacetime
+peach
+peaches
+Peachtree
+peacock
+peacocks
+peak
+peaked
+peaks
+peal
+Peale
+pealed
+pealing
+peals
+peanut
+peanuts
+pear
+Pearce
+pearl
+pearls
+pearly
+pears
+Pearson
+peas
+peasant
+peasantry
+peasants
+Pease
+peat
+pebble
+pebbles
+peccary
+peck
+pecked
+pecking
+pecks
+Pecos
+pectoral
+peculiar
+peculiarities
+peculiarity
+peculiarly
+pecuniary
+pedagogic
+pedagogical
+pedagogically
+pedagogy
+pedal
+pedant
+pedantic
+pedantry
+peddle
+peddler
+peddlers
+pedestal
+pedestrian
+pedestrians
+pediatric
+pediatrician
+pediatrics
+pedigree
+Pedro
+peek
+peeked
+peeking
+peeks
+peel
+peeled
+peeling
+peels
+peep
+peeped
+peeper
+peephole
+peeping
+peeps
+peer
+peered
+peering
+peerless
+peers
+peg
+Pegasus
+pegboard
+Peggy
+pegs
+Peiping
+pejorative
+Peking
+Pelham
+pelican
+pellagra
+Peloponnese
+pelt
+pelting
+pelts
+pelvic
+pelvis
+Pembroke
+pen
+penal
+penalize
+penalized
+penalizes
+penalizing
+penalties
+penalty
+penance
+pence
+penchant
+pencil
+penciled
+pencils
+pend
+pendant
+pended
+pending
+Pendleton
+pends
+pendulum
+pendulums
+Penelope
+penetrable
+penetrate
+penetrated
+penetrates
+penetrating
+penetratingly
+penetration
+penetrations
+penetrative
+penetrator
+penetrators
+penguin
+penguins
+Penh
+penicillin
+peninsula
+peninsulas
+penis
+penises
+penitent
+penitentiary
+Penn
+penned
+pennies
+penniless
+penning
+Pennsylvania
+penny
+Penrose
+pens
+Pensacola
+pension
+pensioner
+pensions
+pensive
+pent
+pentagon
+pentagons
+Pentateuch
+Pentecost
+pentecostal
+penthouse
+penultimate
+penumbra
+peony
+people
+peopled
+peoples
+Peoria
+pep
+pepper
+peppered
+peppering
+peppermint
+pepperoni
+peppers
+peppery
+peppy
+Pepsi
+PepsiCo
+Pepsico
+peptide
+per
+perceivable
+perceivably
+perceive
+perceived
+perceiver
+perceivers
+perceives
+perceiving
+percent
+percentage
+percentages
+percentile
+percentiles
+percents
+perceptible
+perceptibly
+perception
+perceptions
+perceptive
+perceptively
+perceptual
+perceptually
+perch
+perchance
+perched
+perches
+perching
+Percival
+percussion
+percutaneous
+Percy
+peremptory
+perennial
+perennially
+Perez
+perfect
+perfected
+perfectible
+perfecting
+perfection
+perfectionist
+perfectionists
+perfectly
+perfectness
+perfects
+perforce
+perform
+performance
+performances
+performed
+performer
+performers
+performing
+performs
+perfume
+perfumed
+perfumes
+perfuming
+perfunctory
+Pergamon
+perhaps
+Periclean
+Pericles
+perihelion
+peril
+Perilla
+perilous
+perilously
+perils
+perimeter
+period
+periodic
+periodical
+periodically
+periodicals
+periods
+peripheral
+peripherally
+peripherals
+peripheries
+periphery
+periscope
+perish
+perishable
+perishables
+perished
+perisher
+perishers
+perishes
+perishing
+perjure
+perjury
+perk
+Perkins
+perky
+Perle
+permanence
+permanent
+permanently
+permeable
+permeate
+permeated
+permeates
+permeating
+permeation
+Permian
+permissibility
+permissible
+permissibly
+permission
+permissions
+permissive
+permissively
+permit
+permits
+permitted
+permitting
+permutation
+permutations
+permute
+permuted
+permutes
+permuting
+pernicious
+Pernod
+peroxide
+perpendicular
+perpendicularly
+perpendiculars
+perpetrate
+perpetrated
+perpetrates
+perpetrating
+perpetration
+perpetrations
+perpetrator
+perpetrators
+perpetual
+perpetually
+perpetuate
+perpetuated
+perpetuates
+perpetuating
+perpetuation
+perpetuity
+perplex
+perplexed
+perplexing
+perplexity
+Perry
+persecute
+persecuted
+persecutes
+persecuting
+persecution
+persecutor
+persecutors
+Perseid
+Persephone
+Perseus
+perseverance
+persevere
+persevered
+perseveres
+persevering
+Pershing
+Persia
+Persian
+Persianization
+Persianizations
+Persianize
+Persianizes
+Persians
+persist
+persisted
+persistence
+persistent
+persistently
+persisting
+persists
+person
+personage
+personages
+personal
+personalities
+personality
+personalization
+personalize
+personalized
+personalizes
+personalizing
+personally
+personification
+personified
+personifies
+personify
+personifying
+personnel
+persons
+perspective
+perspectives
+perspicuous
+perspicuously
+perspiration
+perspire
+persuadable
+persuade
+persuaded
+persuader
+persuaders
+persuades
+persuading
+persuasion
+persuasions
+persuasive
+persuasively
+persuasiveness
+pertain
+pertained
+pertaining
+pertains
+Perth
+pertinent
+perturb
+perturbation
+perturbations
+perturbed
+Peru
+perusal
+peruse
+perused
+peruser
+perusers
+peruses
+perusing
+Peruvian
+Peruvianize
+Peruvianizes
+Peruvians
+pervade
+pervaded
+pervades
+pervading
+pervasive
+pervasively
+perversion
+pervert
+perverted
+perverts
+pessimism
+pessimist
+pessimistic
+pest
+pester
+pesticide
+pestilence
+pestilent
+pests
+pet
+petal
+petals
+Pete
+Peter
+Peters
+Petersburg
+Petersen
+Peterson
+petition
+petitioned
+petitioner
+petitioning
+petitions
+Petkiewicz
+petri
+petroleum
+pets
+petted
+petter
+petters
+Pettibone
+petticoat
+petticoats
+pettiness
+petting
+petty
+petulance
+petulant
+Peugeot
+pew
+Pewaukee
+pews
+pewter
+Pfizer
+Phaedra
+phantom
+phantoms
+pharmaceutic
+pharmacist
+pharmacology
+pharmacopoeia
+pharmacy
+phase
+phased
+phaser
+phasers
+phases
+phasing
+pheasant
+pheasants
+Phelps
+phenomena
+phenomenal
+phenomenally
+phenomenological
+phenomenologically
+phenomenologies
+phenomenology
+phenomenon
+phi
+PHIGS
+Phil
+Philadelphia
+philanthropy
+Philco
+philharmonic
+Philip
+Philippe
+Philippians
+Philippine
+Philippines
+Philistine
+Philistines
+Philistinize
+Philistinizes
+Phillies
+Phillip
+Phillips
+Philly
+philosopher
+philosophers
+philosophic
+philosophical
+philosophically
+philosophies
+philosophize
+philosophized
+philosophizer
+philosophizers
+philosophizes
+philosophizing
+philosophy
+Phipps
+Phobos
+Phoenicia
+phoenix
+phone
+phoned
+phoneme
+phonemes
+phonemic
+phones
+phonetic
+phonetics
+phoning
+phonograph
+phonographs
+phony
+phosgene
+phosphate
+phosphates
+phosphor
+phosphorescent
+phosphoric
+phosphorus
+photo
+photocopied
+photocopier
+photocopiers
+photocopies
+photocopy
+photocopying
+photodiode
+photodiodes
+photogenic
+photograph
+photographed
+photographer
+photographers
+photographic
+photographing
+photographs
+photography
+photon
+photos
+photosensitive
+phototypesetter
+phototypesetters
+phrase
+phrased
+phraseology
+phrases
+phrasing
+phrasings
+phyla
+Phyllis
+phylum
+physic
+physical
+physically
+physicalness
+physicals
+physician
+physicians
+physicist
+physicists
+physics
+physiological
+physiologically
+physiology
+physiotherapist
+physiotherapy
+physique
+phytoplankton
+pi
+pianist
+piano
+pianos
+pica
+picas
+Picasso
+picayune
+Piccadilly
+piccolo
+pick
+pickaxe
+picked
+picker
+Pickering
+pickers
+picket
+picketed
+picketer
+picketers
+picketing
+pickets
+Pickett
+Pickford
+picking
+pickings
+pickle
+pickled
+pickles
+pickling
+Pickman
+picks
+pickup
+pickups
+picky
+picnic
+picnicked
+picnicking
+picnics
+picofarad
+picojoule
+picosecond
+Pict
+pictorial
+pictorially
+picture
+pictured
+pictures
+picturesque
+picturesqueness
+picturing
+piddle
+pidgin
+pie
+piece
+pieced
+piecemeal
+pieces
+piecewise
+piecing
+Piedfort
+Piedmont
+pier
+pierce
+pierced
+pierces
+piercing
+Pierre
+piers
+Pierson
+pies
+piety
+piezoelectric
+pig
+pigeon
+pigeonhole
+pigeons
+piggish
+piggy
+piggyback
+piggybacked
+piggybacking
+piggybacks
+pigment
+pigmentation
+pigmented
+pigments
+pigpen
+pigs
+pigskin
+pigtail
+pike
+piker
+pikes
+Pilate
+pile
+piled
+pilers
+piles
+pilfer
+pilferage
+pilgrim
+pilgrimage
+pilgrimages
+pilgrims
+piling
+pilings
+pill
+pillage
+pillaged
+pillar
+pillared
+pillars
+pillory
+pillow
+pillows
+pills
+Pillsbury
+pilot
+piloting
+pilots
+pimp
+pimple
+pin
+pinafore
+pinball
+pinch
+pinched
+pinches
+pinching
+pincushion
+pine
+pineapple
+pineapples
+pined
+Pinehurst
+pines
+ping
+pinhead
+pinhole
+pining
+pinion
+pink
+pinker
+pinkest
+pinkie
+pinkish
+pinkly
+pinkness
+pinks
+pinnacle
+pinnacles
+pinned
+pinning
+pinnings
+pinochle
+pinpoint
+pinpointing
+pinpoints
+pins
+pinscher
+Pinsky
+pint
+pinto
+pints
+pinwheel
+pion
+pioneer
+pioneered
+pioneering
+pioneers
+Piotr
+pious
+piously
+pip
+pipe
+piped
+pipeline
+pipelined
+pipelines
+pipelining
+Piper
+pipers
+pipes
+Pipestone
+pipette
+piping
+pique
+piracy
+Piraeus
+pirate
+pirates
+Pisa
+Piscataway
+Pisces
+piss
+pistachio
+pistil
+pistils
+pistol
+pistols
+piston
+pistons
+pit
+pitch
+pitched
+pitcher
+pitchers
+pitches
+pitchfork
+pitching
+piteous
+piteously
+pitfall
+pitfalls
+pith
+pithed
+pithes
+pithier
+pithiest
+pithiness
+pithing
+pithy
+pitiable
+pitied
+pitier
+pitiers
+pities
+pitiful
+pitifully
+pitiless
+pitilessly
+Pitney
+pits
+Pitt
+pitted
+Pittsburgh
+Pittsburghers
+Pittsfield
+Pittston
+pituitary
+pity
+pitying
+pityingly
+Pius
+pivot
+pivotal
+pivoting
+pivots
+pixel
+pixels
+Pizarro
+pizza
+placard
+placards
+placate
+place
+placebo
+placed
+placeholder
+placement
+placements
+placenta
+placental
+placer
+places
+placid
+placidly
+placing
+plagiarism
+plagiarist
+plague
+plagued
+plagues
+plaguing
+plaid
+plaids
+plain
+plainer
+plainest
+Plainfield
+plainly
+plainness
+plains
+plaintext
+plaintexts
+plaintiff
+plaintiffs
+plaintive
+plaintively
+plaintiveness
+Plainview
+plait
+plaits
+plan
+planar
+planarity
+Planck
+plane
+planed
+planeload
+planer
+planers
+planes
+planet
+planetaria
+planetarium
+planetary
+planetesimal
+planetoid
+planets
+planing
+plank
+planking
+planks
+plankton
+planned
+planner
+planners
+planning
+planoconcave
+planoconvex
+plans
+plant
+plantation
+plantations
+planted
+planter
+planters
+planting
+plantings
+plants
+plaque
+plasma
+plaster
+plastered
+plasterer
+plastering
+plasters
+plastic
+plasticity
+plastics
+plate
+plateau
+plateaus
+plated
+platelet
+platelets
+platen
+platens
+plates
+platform
+platforms
+plating
+platinum
+platitude
+Plato
+platonic
+Platonism
+Platonist
+platoon
+Platte
+platter
+platters
+Platteville
+plausibility
+plausible
+play
+playable
+playback
+playboy
+played
+player
+players
+playful
+playfully
+playfulness
+playground
+playgrounds
+playhouse
+playing
+playmate
+playmates
+playoff
+playroom
+plays
+plaything
+playthings
+playtime
+playwright
+playwrights
+playwriting
+plaza
+plea
+plead
+pleaded
+pleader
+pleading
+pleads
+pleas
+pleasant
+pleasantly
+pleasantness
+please
+pleased
+pleases
+pleasing
+pleasingly
+pleasure
+pleasures
+pleat
+plebeian
+plebian
+plebiscite
+plebiscites
+pledge
+pledged
+pledges
+Pleiades
+Pleistocene
+plenary
+plenipotentiary
+plenteous
+plentiful
+plentifully
+plenty
+plethora
+pleurisy
+Plexiglas
+pliable
+pliant
+plied
+pliers
+plies
+plight
+Pliny
+Pliocene
+plod
+plodding
+plot
+plots
+plotted
+plotter
+plotters
+plotting
+plow
+plowed
+plower
+plowing
+plowman
+plows
+plowshare
+ploy
+ploys
+pluck
+plucked
+plucking
+plucks
+plucky
+plug
+pluggable
+plugged
+plugging
+plugs
+plum
+plumage
+plumb
+plumbed
+plumbing
+plumbs
+plume
+plumed
+plumes
+plummet
+plummeting
+plump
+plumped
+plumpness
+plums
+plunder
+plundered
+plunderer
+plunderers
+plundering
+plunders
+plunge
+plunged
+plunger
+plungers
+plunges
+plunging
+plunk
+plural
+plurality
+plurals
+plus
+pluses
+plush
+Plutarch
+Pluto
+plutonium
+ply
+Plymouth
+plywood
+pneumatic
+pneumonia
+Po
+poach
+poacher
+poaches
+Pocahontas
+pocket
+pocketbook
+pocketbooks
+pocketed
+pocketful
+pocketing
+pockets
+Pocono
+Poconos
+pod
+podia
+podium
+pods
+Podunk
+Poe
+poem
+poems
+poet
+poetic
+poetical
+poetically
+poetics
+poetries
+poetry
+poets
+pogo
+pogrom
+poignancy
+poignant
+Poincare
+Poindexter
+point
+pointed
+pointedly
+pointer
+pointers
+pointing
+pointless
+points
+pointy
+poise
+poised
+poises
+poison
+poisoned
+poisoner
+poisoning
+poisonous
+poisonousness
+poisons
+Poisson
+poke
+poked
+poker
+pokerface
+pokes
+poking
+Poland
+polar
+Polaris
+polarities
+polarity
+Polaroid
+pole
+polecat
+poled
+polemic
+polemics
+poles
+police
+policed
+policeman
+policemen
+polices
+policies
+policing
+policy
+poling
+polio
+polish
+polished
+polisher
+polishers
+polishes
+polishing
+Politburo
+polite
+politely
+politeness
+politer
+politest
+politic
+political
+politically
+politician
+politicians
+politicking
+politics
+Polk
+polka
+poll
+Pollard
+polled
+pollen
+polling
+polloi
+polls
+pollutant
+pollute
+polluted
+pollutes
+polluting
+pollution
+Pollux
+polo
+polyalphabetic
+polygon
+polygons
+Polyhymnia
+polymer
+polymers
+polymorphic
+Polynesia
+Polynesian
+polynomial
+polynomials
+Polyphemus
+polytechnic
+polytheist
+Pomerania
+Pomeranian
+Pomona
+pomp
+pompadour
+Pompeii
+Pompey
+pomposity
+pompous
+pompously
+pompousness
+Ponce
+Ponchartrain
+poncho
+pond
+ponder
+pondered
+pondering
+ponderous
+ponders
+ponds
+pong
+ponies
+Pontiac
+pontiff
+pontific
+pontificate
+pony
+pooch
+poodle
+pool
+Poole
+pooled
+pooling
+pools
+poor
+poorer
+poorest
+poorly
+poorness
+pop
+popcorn
+Pope
+Popek
+Popeks
+popish
+poplar
+poplin
+popped
+poppies
+popping
+poppy
+pops
+Popsicle
+Popsicles
+populace
+popular
+popularity
+popularization
+popularize
+popularized
+popularizes
+popularizing
+popularly
+populate
+populated
+populates
+populating
+population
+populations
+populous
+populousness
+porcelain
+porch
+porches
+porcine
+porcupine
+porcupines
+pore
+pored
+pores
+poring
+pork
+porker
+pornographer
+pornographic
+pornography
+porous
+porpoise
+porridge
+port
+portability
+portable
+portage
+portal
+portals
+Porte
+ported
+portend
+portended
+portending
+portends
+portent
+portentous
+porter
+porterhouse
+porters
+portfolio
+portfolios
+Portia
+portico
+porting
+portion
+portions
+Portland
+portly
+portmanteau
+Porto
+portrait
+portraits
+portray
+portrayal
+portrayed
+portraying
+portrays
+ports
+Portsmouth
+Portugal
+Portuguese
+pose
+posed
+Poseidon
+poser
+posers
+poses
+posh
+posing
+posit
+posited
+positing
+position
+positional
+positioned
+positioning
+positions
+positive
+positively
+positiveness
+positives
+positron
+posits
+Posner
+posse
+possess
+possessed
+possesses
+possessing
+possession
+possessional
+possessions
+possessive
+possessively
+possessiveness
+possessor
+possessors
+possibilities
+possibility
+possible
+possibly
+possum
+possums
+post
+postage
+postal
+postcard
+postcondition
+postdoctoral
+posted
+poster
+posterior
+posteriori
+posterity
+posters
+postfix
+postgraduate
+posting
+postlude
+postman
+postmark
+postmaster
+postmasters
+postmortem
+postoperative
+postorder
+postpone
+postponed
+postponing
+postprocess
+postprocessor
+posts
+postscript
+postscripts
+postulate
+postulated
+postulates
+postulating
+postulation
+postulations
+posture
+postures
+pot
+potable
+potash
+potassium
+potato
+potatoes
+potbelly
+Potemkin
+potent
+potentate
+potentates
+potential
+potentialities
+potentiality
+potentially
+potentials
+potentiating
+potentiometer
+potentiometers
+pothole
+potion
+potlatch
+Potomac
+potpourri
+pots
+Potsdam
+Pottawatomie
+potted
+potter
+potters
+pottery
+potting
+Potts
+pouch
+pouches
+Poughkeepsie
+poultice
+poultry
+pounce
+pounced
+pounces
+pouncing
+pound
+pounded
+pounder
+pounders
+pounding
+pounds
+pour
+poured
+pourer
+pourers
+pouring
+pours
+Poussin
+Poussins
+pout
+pouted
+pouting
+pouts
+poverty
+powder
+powdered
+powdering
+powderpuff
+powders
+powdery
+Powell
+power
+powered
+powerful
+powerfully
+powerfulness
+powering
+powerless
+powerlessly
+powerlessness
+Powers
+pox
+Poynting
+practicable
+practicably
+practical
+practicality
+practically
+practice
+practiced
+practices
+practicing
+practitioner
+practitioners
+Pradesh
+Prado
+pragmatic
+pragmatically
+pragmatics
+pragmatism
+pragmatist
+Prague
+prairie
+praise
+praised
+praiser
+praisers
+praises
+praiseworthy
+praising
+praisingly
+prance
+pranced
+prancer
+prancing
+prank
+pranks
+prate
+Pratt
+Prattville
+Pravda
+pray
+prayed
+prayer
+prayers
+praying
+preach
+preached
+preacher
+preachers
+preaches
+preaching
+preallocate
+preallocated
+preallocating
+preamble
+preambles
+preassign
+preassigned
+preassigning
+preassigns
+Precambrian
+precarious
+precariously
+precariousness
+precaution
+precautions
+precede
+preceded
+precedence
+precedences
+precedent
+precedented
+precedents
+precedes
+preceding
+precept
+precepts
+precess
+precession
+precinct
+precincts
+precious
+preciously
+preciousness
+precipice
+precipitable
+precipitate
+precipitated
+precipitately
+precipitateness
+precipitates
+precipitating
+precipitation
+precipitous
+precipitously
+precise
+precisely
+preciseness
+precision
+precisions
+preclude
+precluded
+precludes
+precluding
+precocious
+precociously
+precocity
+precompute
+precomputed
+precomputing
+preconceive
+preconceived
+preconception
+preconceptions
+precondition
+preconditioned
+preconditions
+precursor
+precursors
+predate
+predated
+predates
+predating
+predatory
+predecessor
+predecessors
+predefine
+predefined
+predefines
+predefining
+predefinition
+predefinitions
+predetermination
+predetermine
+predetermined
+predetermines
+predetermining
+predicament
+predicate
+predicated
+predicates
+predicating
+predication
+predications
+predict
+predictability
+predictable
+predictably
+predicted
+predicting
+prediction
+predictions
+predictive
+predictor
+predicts
+predilection
+predilections
+predisposition
+predominant
+predominantly
+predominate
+predominated
+predominately
+predominates
+predominating
+predomination
+preeminence
+preeminent
+preempt
+preempted
+preempting
+preemption
+preemptive
+preemptor
+preempts
+preen
+preexisting
+prefab
+prefabricate
+preface
+prefaced
+prefaces
+prefacing
+prefer
+preferable
+preferably
+preference
+preferences
+preferential
+preferentially
+preferred
+preferring
+prefers
+prefix
+prefixed
+prefixes
+prefixing
+pregnancy
+pregnant
+prehistoric
+preinitialize
+preinitialized
+preinitializes
+preinitializing
+prejudge
+prejudged
+prejudice
+prejudiced
+prejudices
+prejudicial
+prelate
+preliminaries
+preliminary
+prelude
+preludes
+premature
+prematurely
+prematurity
+premeditated
+premeditation
+premier
+premiers
+premise
+premises
+premium
+premiums
+premonition
+prenatal
+Prentice
+Prenticed
+Prenticing
+preoccupation
+preoccupied
+preoccupies
+preoccupy
+prep
+preparation
+preparations
+preparative
+preparatives
+preparatory
+prepare
+prepared
+prepares
+preparing
+prepend
+prepended
+prepending
+preposition
+prepositional
+prepositions
+preposterous
+preposterously
+preprocessed
+preprocessing
+preprocessor
+preprocessors
+preproduction
+preprogrammed
+prerequisite
+prerequisites
+prerogative
+prerogatives
+Presbyterian
+Presbyterianism
+Presbyterianize
+Presbyterianizes
+Prescott
+prescribe
+prescribed
+prescribes
+prescription
+prescriptions
+prescriptive
+preselect
+preselected
+preselecting
+preselects
+presence
+presences
+present
+presentation
+presentations
+presented
+presenter
+presenting
+presently
+presentness
+presents
+preservation
+preservations
+preserve
+preserved
+preserver
+preservers
+preserves
+preserving
+preset
+preside
+presided
+presidency
+president
+presidential
+presidents
+presides
+presiding
+Presley
+press
+pressed
+presser
+presses
+pressing
+pressings
+pressure
+pressured
+pressures
+pressuring
+pressurize
+pressurized
+prestidigitate
+prestige
+prestigious
+Preston
+presumably
+presume
+presumed
+presumes
+presuming
+presumption
+presumptions
+presumptive
+presumptuous
+presumptuousness
+presuppose
+presupposed
+presupposes
+presupposing
+presupposition
+pretend
+pretended
+pretender
+pretenders
+pretending
+pretends
+pretense
+pretenses
+pretension
+pretensions
+pretentious
+pretentiously
+pretentiousness
+pretext
+pretexts
+Pretoria
+Pretorian
+prettier
+prettiest
+prettily
+prettiness
+pretty
+prevail
+prevailed
+prevailing
+prevailingly
+prevails
+prevalence
+prevalent
+prevalently
+prevent
+preventable
+preventably
+prevented
+preventing
+prevention
+preventive
+preventives
+prevents
+preview
+previewed
+previewing
+previews
+previous
+previously
+prey
+preyed
+preying
+preys
+Priam
+price
+priced
+priceless
+pricer
+pricers
+prices
+pricing
+prick
+pricked
+pricking
+prickly
+pricks
+pride
+prided
+prides
+priding
+priest
+Priestley
+priggish
+prim
+prima
+primacy
+primal
+primaries
+primarily
+primary
+primate
+prime
+primed
+primeness
+primer
+primers
+primes
+primeval
+priming
+primitive
+primitively
+primitiveness
+primitives
+primrose
+prince
+princely
+princes
+princess
+princesses
+Princeton
+principal
+principalities
+principality
+principally
+principals
+Principia
+principle
+principled
+principles
+print
+printable
+printably
+printed
+printer
+printers
+printing
+printout
+prints
+prior
+priori
+priorities
+priority
+priory
+Priscilla
+prism
+prisms
+prison
+prisoner
+prisoners
+prisons
+pristine
+Pritchard
+privacies
+privacy
+private
+privately
+privates
+privation
+privations
+privies
+privilege
+privileged
+privileges
+privy
+prize
+prized
+prizer
+prizers
+prizes
+prizewinning
+prizing
+pro
+probabilistic
+probabilistically
+probabilities
+probability
+probable
+probably
+probate
+probated
+probates
+probating
+probation
+probative
+probe
+probed
+probes
+probing
+probings
+probity
+problem
+problematic
+problematical
+problematically
+problems
+procaine
+procedural
+procedurally
+procedure
+procedures
+proceed
+proceeded
+proceeding
+proceedings
+proceeds
+process
+processed
+processes
+processing
+procession
+processor
+processors
+proclaim
+proclaimed
+proclaimer
+proclaimers
+proclaiming
+proclaims
+proclamation
+proclamations
+proclivities
+proclivity
+procotols
+procrastinate
+procrastinated
+procrastinates
+procrastinating
+procrastination
+procreate
+Procrustean
+Procrusteanize
+Procrusteanizes
+Procrustes
+Procter
+procure
+procured
+procurement
+procurements
+procurer
+procurers
+procures
+procuring
+Procyon
+prod
+prodigal
+prodigally
+prodigious
+prodigy
+produce
+produced
+producer
+producers
+produces
+producible
+producing
+product
+production
+productions
+productive
+productively
+productivity
+products
+profane
+profanely
+profess
+professed
+professes
+professing
+profession
+professional
+professionalism
+professionally
+professionals
+professions
+professor
+professorial
+professors
+proffer
+proffered
+proffers
+proficiency
+proficient
+proficiently
+profile
+profiled
+profiles
+profiling
+profit
+profitability
+profitable
+profitably
+profited
+profiteer
+profiteers
+profiting
+profits
+profitted
+profligate
+profound
+profoundest
+profoundly
+profundity
+profuse
+profusion
+progenitor
+progeny
+prognosis
+prognosticate
+program
+programmability
+programmable
+programmed
+programmer
+programmers
+programming
+programs
+progress
+progressed
+progresses
+progressing
+progression
+progressions
+progressive
+progressively
+prohibit
+prohibited
+prohibiting
+prohibition
+prohibitions
+prohibitive
+prohibitively
+prohibitory
+prohibits
+project
+projected
+projectile
+projecting
+projection
+projections
+projective
+projectively
+projector
+projectors
+projects
+Prokofieff
+Prokofiev
+prolate
+prolegomena
+proletariat
+proliferate
+proliferated
+proliferates
+proliferating
+proliferation
+prolific
+prolix
+prolog
+prologue
+prolong
+prolongate
+prolonged
+prolonging
+prolongs
+promenade
+promenades
+Promethean
+Prometheus
+prominence
+prominent
+prominently
+promiscuous
+promise
+promised
+promises
+promising
+promontory
+promote
+promoted
+promoter
+promoters
+promotes
+promoting
+promotion
+promotional
+promotions
+prompt
+prompted
+prompter
+promptest
+prompting
+promptings
+promptly
+promptness
+prompts
+promulgate
+promulgated
+promulgates
+promulgating
+promulgation
+prone
+proneness
+prong
+pronged
+prongs
+pronoun
+pronounce
+pronounceable
+pronounced
+pronouncement
+pronouncements
+pronounces
+pronouncing
+pronouns
+pronunciation
+pronunciations
+proof
+proofread
+proofreader
+proofs
+prop
+propaganda
+propagandist
+propagate
+propagated
+propagates
+propagating
+propagation
+propagations
+propane
+propel
+propellant
+propelled
+propeller
+propellers
+propelling
+propels
+propensity
+proper
+properly
+properness
+propertied
+properties
+property
+prophecies
+prophecy
+prophesied
+prophesier
+prophesies
+prophesy
+prophet
+prophetic
+prophets
+propitious
+proponent
+proponents
+proportion
+proportional
+proportionally
+proportionately
+proportioned
+proportioning
+proportionment
+proportions
+propos
+proposal
+proposals
+propose
+proposed
+proposer
+proposes
+proposing
+proposition
+propositional
+propositionally
+propositioned
+propositioning
+propositions
+propound
+propounded
+propounding
+propounds
+proprietary
+proprietor
+proprietors
+propriety
+props
+propulsion
+propulsions
+prorate
+prorated
+prorates
+pros
+proscenium
+proscribe
+proscription
+prose
+prosecute
+prosecuted
+prosecutes
+prosecuting
+prosecution
+prosecutions
+prosecutor
+proselytize
+proselytized
+proselytizes
+proselytizing
+Proserpine
+prosodic
+prosodics
+prospect
+prospected
+prospecting
+prospection
+prospections
+prospective
+prospectively
+prospectives
+prospector
+prospectors
+prospects
+prospectus
+prosper
+prospered
+prospering
+prosperity
+prosperous
+prospers
+prostate
+prosthetic
+prostitute
+prostitution
+prostrate
+prostration
+protagonist
+protean
+protect
+protected
+protecting
+protection
+protections
+protective
+protectively
+protectiveness
+protector
+protectorate
+protectors
+protects
+protege
+proteges
+protein
+proteins
+protest
+protestant
+Protestantism
+Protestantize
+Protestantizes
+protestation
+protestations
+protested
+protesting
+protestingly
+protestor
+protests
+Protista
+protocol
+protocols
+proton
+protons
+Protophyta
+protoplasm
+prototype
+prototyped
+prototypes
+prototypical
+prototypically
+prototyping
+Protozoa
+protozoan
+protract
+protrude
+protruded
+protrudes
+protruding
+protrusion
+protrusions
+protuberant
+proud
+prouder
+proudest
+proudly
+Proust
+provability
+provable
+provably
+prove
+proved
+proven
+provenance
+Provence
+prover
+proverb
+proverbial
+proverbs
+provers
+proves
+provide
+provided
+providence
+provident
+provider
+providers
+provides
+providing
+province
+provinces
+provincial
+proving
+provision
+provisional
+provisionally
+provisioned
+provisioning
+provisions
+proviso
+provocation
+provoke
+provoked
+provokes
+provost
+prow
+prowess
+prowl
+prowled
+prowler
+prowlers
+prowling
+prows
+proximal
+proximate
+proximity
+Proxmire
+proxy
+prudence
+prudent
+prudential
+prudently
+prune
+pruned
+pruner
+pruners
+prunes
+pruning
+prurient
+Prussia
+Prussian
+Prussianization
+Prussianizations
+Prussianize
+Prussianizer
+Prussianizers
+Prussianizes
+pry
+prying
+psalm
+psalms
+pseudo
+pseudofiles
+pseudoinstruction
+pseudoinstructions
+pseudonym
+pseudoparallelism
+psilocybin
+psych
+psyche
+psychedelic
+psyches
+psychiatric
+psychiatrist
+psychiatrists
+psychiatry
+psychic
+psycho
+psychoanalysis
+psychoanalyst
+psychoanalytic
+psychobiology
+psychological
+psychologically
+psychologist
+psychologists
+psychology
+psychopath
+psychopathic
+psychophysic
+psychoses
+psychosis
+psychosocial
+psychosomatic
+psychotherapeutic
+psychotherapist
+psychotherapy
+psychotic
+Pteranodon
+Pterodactyl
+Ptolemaic
+Ptolemaists
+Ptolemy
+pub
+puberty
+public
+publication
+publications
+publicity
+publicize
+publicized
+publicizes
+publicizing
+publicly
+publish
+published
+publisher
+publishers
+publishes
+publishing
+pubs
+Puccini
+pucker
+puckered
+puckering
+puckers
+pudding
+puddings
+puddle
+puddles
+puddling
+Puerto
+puff
+puffed
+puffin
+puffing
+puffs
+Pugh
+puke
+Pulaski
+Pulitzer
+pull
+pulled
+puller
+pulley
+pulleys
+pulling
+pullings
+Pullman
+Pullmanize
+Pullmanizes
+Pullmans
+pullover
+pulls
+pulmonary
+pulp
+pulping
+pulpit
+pulpits
+pulsar
+pulsate
+pulsation
+pulsations
+pulse
+pulsed
+pulses
+pulsing
+puma
+pumice
+pummel
+pump
+pumped
+pumping
+pumpkin
+pumpkins
+pumps
+pun
+punch
+punched
+puncher
+punches
+punching
+punctual
+punctually
+punctuation
+puncture
+punctured
+punctures
+puncturing
+pundit
+pungent
+Punic
+punish
+punishable
+punished
+punishes
+punishing
+punishment
+punishments
+punitive
+Punjab
+Punjabi
+puns
+punt
+punted
+punting
+punts
+puny
+pup
+pupa
+pupil
+pupils
+puppet
+puppeteer
+puppets
+puppies
+puppy
+pups
+Purcell
+purchase
+purchased
+purchaser
+purchasers
+purchases
+purchasing
+Purdue
+pure
+purely
+purer
+purest
+purgatory
+purge
+purged
+purges
+purging
+purification
+purifications
+purified
+purifier
+purifiers
+purifies
+purify
+purifying
+Purina
+purist
+Puritan
+puritanic
+Puritanize
+Puritanizer
+Puritanizers
+Puritanizes
+purity
+purple
+purpler
+purplest
+purport
+purported
+purportedly
+purporter
+purporters
+purporting
+purports
+purpose
+purposed
+purposeful
+purposefully
+purposely
+purposes
+purposive
+purr
+purred
+purring
+purrs
+purse
+pursed
+purser
+purses
+pursuant
+pursue
+pursued
+pursuer
+pursuers
+pursues
+pursuing
+pursuit
+pursuits
+purveyor
+purview
+pus
+Pusan
+Pusey
+push
+pushbutton
+pushdown
+pushed
+pusher
+pushers
+pushes
+pushing
+puss
+pussy
+pussycat
+put
+Putnam
+puts
+putt
+putter
+puttering
+putters
+putting
+putty
+puzzle
+puzzled
+puzzlement
+puzzler
+puzzlers
+puzzles
+puzzling
+puzzlings
+Pygmalion
+pygmies
+pygmy
+Pyle
+Pyongyang
+Pyotr
+pyramid
+pyramids
+pyre
+Pyrex
+Pyrrhic
+Pythagoras
+Pythagorean
+Pythagoreanize
+Pythagoreanizes
+Pythagoreans
+python
+Qatar
+qua
+quack
+quacked
+quackery
+quacks
+quad
+quadrangle
+quadrangular
+quadrant
+quadrants
+quadratic
+quadratical
+quadratically
+quadratics
+quadrature
+quadratures
+quadrennial
+quadrilateral
+quadrillion
+quadruple
+quadrupled
+quadruples
+quadrupling
+quadrupole
+quaff
+quagmire
+quagmires
+quahog
+quail
+quails
+quaint
+quaintly
+quaintness
+quake
+quaked
+quaker
+Quakeress
+Quakerization
+Quakerizations
+Quakerize
+Quakerizes
+quakers
+quakes
+quaking
+qualification
+qualifications
+qualified
+qualifier
+qualifiers
+qualifies
+qualify
+qualifying
+qualitative
+qualitatively
+qualities
+quality
+qualm
+quandaries
+quandary
+quanta
+Quantico
+quantifiable
+quantification
+quantifications
+quantified
+quantifier
+quantifiers
+quantifies
+quantify
+quantifying
+quantile
+quantitative
+quantitatively
+quantities
+quantity
+quantization
+quantize
+quantized
+quantizes
+quantizing
+quantum
+quarantine
+quarantines
+quarantining
+quark
+quarrel
+quarreled
+quarreling
+quarrels
+quarrelsome
+quarries
+quarry
+quart
+quarter
+quarterback
+quartered
+quartering
+quarterly
+quartermaster
+quarters
+quartet
+quartets
+quartile
+quarts
+quartz
+quartzite
+quasar
+quash
+quashed
+quashes
+quashing
+quasi
+Quasimodo
+quaternary
+quaver
+quavered
+quavering
+quavers
+quay
+queasy
+Quebec
+queen
+queenly
+queens
+Queensland
+queer
+queerer
+queerest
+queerly
+queerness
+quell
+quelling
+quench
+quenched
+quenches
+quenching
+queried
+queries
+query
+querying
+quest
+quested
+quester
+questers
+questing
+question
+questionable
+questionably
+questioned
+questioner
+questioners
+questioning
+questioningly
+questionings
+questionnaire
+questionnaires
+questions
+quests
+queue
+queued
+queueing
+queuer
+queuers
+queues
+queuing
+Quezon
+quibble
+Quichua
+quick
+quicken
+quickened
+quickening
+quickens
+quicker
+quickest
+quickie
+quicklime
+quickly
+quickness
+quicksand
+quicksilver
+quiescent
+quiet
+quieted
+quieter
+quietest
+quieting
+quietly
+quietness
+quiets
+quietude
+quill
+quilt
+quilted
+quilting
+quilts
+quince
+quinine
+Quinn
+quint
+quintet
+quintillion
+quip
+Quirinal
+quirk
+quirky
+quit
+quite
+Quito
+quits
+quitter
+quitters
+quitting
+quiver
+quivered
+quivering
+quivers
+Quixote
+quixotic
+Quixotism
+quiz
+quizzed
+quizzes
+quizzical
+quizzing
+quo
+quonset
+quorum
+quota
+quotas
+quotation
+quotations
+quote
+quoted
+quotes
+quoth
+quotient
+quotients
+quoting
+Rabat
+rabbi
+rabbit
+rabbits
+rabble
+rabid
+rabies
+Rabin
+raccoon
+raccoons
+race
+raced
+racer
+racers
+races
+racetrack
+Rachel
+Rachmaninoff
+racial
+racially
+Racine
+racing
+rack
+racked
+racket
+racketeer
+racketeering
+racketeers
+rackets
+racking
+racks
+radar
+radars
+Radcliffe
+radial
+radially
+radian
+radiance
+radiant
+radiantly
+radiate
+radiated
+radiates
+radiating
+radiation
+radiations
+radiator
+radiators
+radical
+radically
+radicals
+radices
+radii
+radio
+radioactive
+radioastronomy
+radioed
+radiography
+radioing
+radiology
+radios
+radish
+radishes
+radium
+radius
+radix
+radon
+Rae
+Rafael
+Rafferty
+raft
+rafter
+rafters
+rafts
+rag
+rage
+raged
+rages
+ragged
+raggedly
+raggedness
+raging
+rags
+Ragusan
+ragweed
+raid
+raided
+raider
+raiders
+raiding
+raids
+rail
+railed
+railer
+railers
+railing
+railroad
+railroaded
+railroader
+railroaders
+railroading
+railroads
+rails
+railway
+railways
+raiment
+rain
+rainbow
+raincoat
+raincoats
+raindrop
+raindrops
+rained
+rainfall
+rainier
+rainiest
+raining
+rains
+rainstorm
+rainy
+raise
+raised
+raiser
+raisers
+raises
+raisin
+raising
+rake
+raked
+rakes
+raking
+Raleigh
+rallied
+rallies
+rally
+rallying
+Ralph
+Ralston
+ram
+Ramada
+Raman
+ramble
+rambler
+rambles
+rambling
+ramblings
+ramification
+ramifications
+Ramirez
+Ramo
+Ramona
+ramp
+rampage
+rampant
+rampart
+ramps
+ramrod
+rams
+Ramsey
+ran
+ranch
+ranched
+rancher
+ranchers
+ranches
+ranching
+rancid
+Rand
+Randall
+Randolph
+random
+randomization
+randomize
+randomized
+randomizes
+randomly
+randomness
+randy
+rang
+range
+ranged
+rangeland
+ranger
+rangers
+ranges
+ranging
+Rangoon
+rangy
+Ranier
+rank
+ranked
+ranker
+rankers
+rankest
+Rankin
+Rankine
+ranking
+rankings
+rankle
+rankly
+rankness
+ranks
+ransack
+ransacked
+ransacking
+ransacks
+ransom
+ransomer
+ransoming
+ransoms
+rant
+ranted
+ranter
+ranters
+ranting
+rants
+Raoul
+rap
+rapacious
+rape
+raped
+raper
+rapes
+Raphael
+rapid
+rapidity
+rapidly
+rapids
+rapier
+raping
+rapport
+rapprochement
+raps
+rapt
+raptly
+rapture
+raptures
+rapturous
+Rapunzel
+rare
+rarely
+rareness
+rarer
+rarest
+Raritan
+rarity
+rascal
+rascally
+rascals
+rash
+rasher
+rashly
+rashness
+Rasmussen
+rasp
+raspberry
+rasped
+rasping
+rasps
+raster
+Rastus
+rat
+rate
+rated
+rater
+raters
+rates
+Ratfor
+rather
+ratification
+ratified
+ratifies
+ratify
+ratifying
+rating
+ratings
+ratio
+ration
+rational
+rationale
+rationales
+rationalities
+rationality
+rationalization
+rationalizations
+rationalize
+rationalized
+rationalizes
+rationalizing
+rationally
+rationals
+rationing
+rations
+ratios
+rats
+rattle
+rattled
+rattler
+rattlers
+rattles
+rattlesnake
+rattlesnakes
+rattling
+raucous
+Raul
+ravage
+ravaged
+ravager
+ravagers
+ravages
+ravaging
+rave
+raved
+raven
+ravening
+ravenous
+ravenously
+ravens
+raves
+ravine
+ravines
+raving
+ravings
+raw
+rawer
+rawest
+Rawlings
+Rawlins
+Rawlinson
+rawly
+rawness
+Rawson
+ray
+Rayburn
+Rayleigh
+Raymond
+Raymondville
+rays
+Raytheon
+raze
+razor
+razors
+re
+reabbreviate
+reabbreviated
+reabbreviates
+reabbreviating
+reach
+reachability
+reachable
+reachably
+reached
+reacher
+reaches
+reaching
+reacquired
+react
+reacted
+reacting
+reaction
+reactionaries
+reactionary
+reactions
+reactivate
+reactivated
+reactivates
+reactivating
+reactivation
+reactive
+reactively
+reactivity
+reactor
+reactors
+reacts
+read
+readability
+readable
+reader
+readers
+readied
+readier
+readies
+readiest
+readily
+readiness
+reading
+readings
+readjusted
+readout
+readouts
+reads
+ready
+readying
+Reagan
+real
+realest
+realign
+realigned
+realigning
+realigns
+realism
+realist
+realistic
+realistically
+realists
+realities
+reality
+realizable
+realizably
+realization
+realizations
+realize
+realized
+realizes
+realizing
+reallocate
+really
+realm
+realms
+realness
+reals
+realtor
+ream
+reanalyze
+reanalyzes
+reanalyzing
+reap
+reaped
+reaper
+reaping
+reappear
+reappeared
+reappearing
+reappears
+reappraisal
+reappraisals
+reaps
+rear
+reared
+rearing
+rearrange
+rearrangeable
+rearranged
+rearrangement
+rearrangements
+rearranges
+rearranging
+rearrest
+rearrested
+rears
+reason
+reasonable
+reasonableness
+reasonably
+reasoned
+reasoner
+reasoning
+reasonings
+reasons
+reassemble
+reassembled
+reassembles
+reassembling
+reassembly
+reassessment
+reassessments
+reassign
+reassigned
+reassigning
+reassignment
+reassignments
+reassigns
+reassure
+reassured
+reassures
+reassuring
+reawaken
+reawakened
+reawakening
+reawakens
+rebate
+rebates
+Rebecca
+rebel
+rebelled
+rebelling
+rebellion
+rebellions
+rebellious
+rebelliously
+rebelliousness
+rebels
+rebind
+rebinding
+rebinds
+reboot
+rebooted
+rebooting
+reboots
+rebound
+rebounded
+rebounding
+rebounds
+rebroadcast
+rebroadcasting
+rebroadcasts
+rebuff
+rebuffed
+rebuild
+rebuilding
+rebuilds
+rebuilt
+rebuke
+rebuked
+rebukes
+rebuking
+rebuttal
+rebutted
+rebutting
+recalcitrant
+recalculate
+recalculated
+recalculates
+recalculating
+recalculation
+recalculations
+recalibrate
+recalibrated
+recalibrates
+recalibrating
+recall
+recalled
+recalling
+recalls
+recant
+recapitulate
+recapitulated
+recapitulates
+recapitulation
+recapture
+recaptured
+recaptures
+recapturing
+recast
+recasting
+recasts
+recede
+receded
+recedes
+receding
+receipt
+receipts
+receivable
+receive
+received
+receiver
+receivers
+receives
+receiving
+recent
+recently
+recentness
+receptacle
+receptacles
+reception
+receptionist
+receptions
+receptive
+receptively
+receptiveness
+receptivity
+receptor
+recess
+recessed
+recesses
+recession
+recessive
+Recife
+recipe
+recipes
+recipient
+recipients
+reciprocal
+reciprocally
+reciprocate
+reciprocated
+reciprocates
+reciprocating
+reciprocation
+reciprocity
+recirculate
+recirculated
+recirculates
+recirculating
+recital
+recitals
+recitation
+recitations
+recite
+recited
+reciter
+recites
+reciting
+reckless
+recklessly
+recklessness
+reckon
+reckoned
+reckoner
+reckoning
+reckonings
+reckons
+reclaim
+reclaimable
+reclaimed
+reclaimer
+reclaimers
+reclaiming
+reclaims
+reclamation
+reclamations
+reclassification
+reclassified
+reclassifies
+reclassify
+reclassifying
+recline
+reclining
+recode
+recoded
+recodes
+recoding
+recognition
+recognitions
+recognizability
+recognizable
+recognizably
+recognize
+recognized
+recognizer
+recognizers
+recognizes
+recognizing
+recoil
+recoiled
+recoiling
+recoils
+recollect
+recollected
+recollecting
+recollection
+recollections
+recombination
+recombine
+recombined
+recombines
+recombining
+recommend
+recommendation
+recommendations
+recommended
+recommender
+recommending
+recommends
+recompense
+recompile
+recompiled
+recompiles
+recompiling
+recompute
+recomputed
+recomputes
+recomputing
+reconcile
+reconciled
+reconciler
+reconciles
+reconciliation
+reconciling
+reconfigurable
+reconfiguration
+reconfigurations
+reconfigure
+reconfigured
+reconfigurer
+reconfigures
+reconfiguring
+reconnect
+reconnected
+reconnecting
+reconnection
+reconnects
+reconsider
+reconsideration
+reconsidered
+reconsidering
+reconsiders
+reconstituted
+reconstruct
+reconstructed
+reconstructing
+reconstruction
+reconstructs
+reconverted
+reconverts
+record
+recorded
+recorder
+recorders
+recording
+recordings
+records
+recount
+recounted
+recounting
+recounts
+recourse
+recover
+recoverable
+recovered
+recoveries
+recovering
+recovers
+recovery
+recreate
+recreated
+recreates
+recreating
+recreation
+recreational
+recreations
+recreative
+recruit
+recruited
+recruiter
+recruiting
+recruits
+recta
+rectangle
+rectangles
+rectangular
+rectify
+rector
+rectors
+rectum
+rectums
+recuperate
+recur
+recurrence
+recurrences
+recurrent
+recurrently
+recurring
+recurs
+recurse
+recursed
+recurses
+recursing
+recursion
+recursions
+recursive
+recursively
+recyclable
+recycle
+recycled
+recycles
+recycling
+red
+redbreast
+redcoat
+redden
+reddened
+redder
+reddest
+reddish
+reddishness
+redeclare
+redeclared
+redeclares
+redeclaring
+redeem
+redeemed
+redeemer
+redeemers
+redeeming
+redeems
+redefine
+redefined
+redefines
+redefining
+redefinition
+redefinitions
+redemption
+redesign
+redesigned
+redesigning
+redesigns
+redevelopment
+Redford
+redhead
+Redhook
+redirect
+redirected
+redirecting
+redirection
+redirections
+redisplay
+redisplayed
+redisplaying
+redisplays
+redistribute
+redistributed
+redistributes
+redistributing
+redly
+Redmond
+redneck
+redness
+redo
+redone
+redouble
+redoubled
+redraw
+redrawn
+redress
+redressed
+redresses
+redressing
+reds
+Redstone
+reduce
+reduced
+reducer
+reducers
+reduces
+reducibility
+reducible
+reducibly
+reducing
+reduction
+reductions
+redundancies
+redundancy
+redundant
+redundantly
+redwood
+reed
+reeds
+reeducation
+Reedville
+reef
+reefer
+reefs
+reel
+reelect
+reelected
+reelecting
+reelects
+reeled
+reeler
+reeling
+reels
+reemphasize
+reemphasized
+reemphasizes
+reemphasizing
+reenabled
+reenforcement
+reenter
+reentered
+reentering
+reenters
+reentrant
+Reese
+reestablish
+reestablished
+reestablishes
+reestablishing
+reevaluate
+reevaluated
+reevaluates
+reevaluating
+reevaluation
+Reeves
+reexamine
+reexamined
+reexamines
+reexamining
+reexecuted
+refer
+referee
+refereed
+refereeing
+referees
+reference
+referenced
+referencer
+references
+referencing
+referenda
+referendum
+referendums
+referent
+referential
+referentiality
+referentially
+referents
+referral
+referrals
+referred
+referring
+refers
+refill
+refillable
+refilled
+refilling
+refills
+refine
+refined
+refinement
+refinements
+refiner
+refinery
+refines
+refining
+reflect
+reflected
+reflecting
+reflection
+reflections
+reflective
+reflectively
+reflectivity
+reflector
+reflectors
+reflects
+reflex
+reflexes
+reflexive
+reflexively
+reflexiveness
+reflexivity
+reforestation
+reform
+reformable
+reformat
+reformation
+reformatory
+reformats
+reformatted
+reformatting
+reformed
+reformer
+reformers
+reforming
+reforms
+reformulate
+reformulated
+reformulates
+reformulating
+reformulation
+refract
+refracted
+refraction
+refractory
+refragment
+refrain
+refrained
+refraining
+refrains
+refresh
+refreshed
+refresher
+refreshers
+refreshes
+refreshing
+refreshingly
+refreshment
+refreshments
+refrigerate
+refrigerator
+refrigerators
+refuel
+refueled
+refueling
+refuels
+refuge
+refugee
+refugees
+refusal
+refuse
+refused
+refuses
+refusing
+refutable
+refutation
+refute
+refuted
+refuter
+refutes
+refuting
+regain
+regained
+regaining
+regains
+regal
+regaled
+regally
+regard
+regarded
+regarding
+regardless
+regards
+regatta
+regenerate
+regenerated
+regenerates
+regenerating
+regeneration
+regenerative
+regenerator
+regenerators
+regent
+regents
+regime
+regimen
+regiment
+regimentation
+regimented
+regiments
+regimes
+Regina
+Reginald
+region
+regional
+regionally
+regions
+Regis
+register
+registered
+registering
+registers
+registrar
+registration
+registrations
+registry
+regress
+regressed
+regresses
+regressing
+regression
+regressions
+regressive
+regret
+regretful
+regretfully
+regrets
+regrettable
+regrettably
+regretted
+regretting
+regroup
+regrouped
+regrouping
+regular
+regularities
+regularity
+regularly
+regulars
+regulate
+regulated
+regulates
+regulating
+regulation
+regulations
+regulative
+regulator
+regulators
+regulatory
+Regulus
+rehabilitate
+rehearsal
+rehearsals
+rehearse
+rehearsed
+rehearser
+rehearses
+rehearsing
+Reich
+Reichenberg
+Reichstag
+Reid
+reign
+reigned
+reigning
+reigns
+Reilly
+reimbursable
+reimburse
+reimbursed
+reimbursement
+reimbursements
+rein
+reincarnate
+reincarnated
+reincarnation
+reindeer
+reined
+reinforce
+reinforced
+reinforcement
+reinforcements
+reinforcer
+reinforces
+reinforcing
+Reinhard
+Reinhardt
+Reinhold
+reinitialize
+reinitialized
+reinitializing
+reins
+reinsert
+reinserted
+reinserting
+reinserts
+reinstate
+reinstated
+reinstatement
+reinstates
+reinstating
+reinterpret
+reinterpreted
+reinterpreting
+reinterprets
+reintroduce
+reintroduced
+reintroduces
+reintroducing
+reinvent
+reinvented
+reinventing
+reinvents
+reiterate
+reiterated
+reiterates
+reiterating
+reiteration
+reject
+rejected
+rejecting
+rejection
+rejections
+rejector
+rejectors
+rejects
+rejoice
+rejoiced
+rejoicer
+rejoices
+rejoicing
+rejoin
+rejoinder
+rejoined
+rejoining
+rejoins
+relabel
+relabeled
+relabeling
+relabelled
+relabelling
+relabels
+relapse
+relate
+related
+relater
+relates
+relating
+relation
+relational
+relationally
+relations
+relationship
+relationships
+relative
+relatively
+relativeness
+relatives
+relativism
+relativistic
+relativistically
+relativity
+relax
+relaxation
+relaxations
+relaxed
+relaxer
+relaxes
+relaxing
+relay
+relayed
+relaying
+relays
+release
+released
+releases
+releasing
+relegate
+relegated
+relegates
+relegating
+relent
+relented
+relenting
+relentless
+relentlessly
+relentlessness
+relents
+relevance
+relevances
+relevant
+relevantly
+reliability
+reliable
+reliably
+reliance
+reliant
+relic
+relics
+relied
+relief
+relies
+relieve
+relieved
+reliever
+relievers
+relieves
+relieving
+religion
+religions
+religious
+religiously
+religiousness
+relink
+relinquish
+relinquished
+relinquishes
+relinquishing
+relish
+relished
+relishes
+relishing
+relive
+relives
+reliving
+reload
+reloaded
+reloader
+reloading
+reloads
+relocatable
+relocate
+relocated
+relocates
+relocating
+relocation
+relocations
+reluctance
+reluctant
+reluctantly
+rely
+relying
+remain
+remainder
+remainders
+remained
+remaining
+remains
+remark
+remarkable
+remarkableness
+remarkably
+remarked
+remarking
+remarks
+Rembrandt
+remedial
+remedied
+remedies
+remedy
+remedying
+remember
+remembered
+remembering
+remembers
+remembrance
+remembrances
+remind
+reminded
+reminder
+reminders
+reminding
+reminds
+Remington
+reminiscence
+reminiscences
+reminiscent
+reminiscently
+remiss
+remission
+remit
+remittance
+remnant
+remnants
+remodel
+remodeled
+remodeling
+remodels
+remonstrate
+remonstrated
+remonstrates
+remonstrating
+remonstration
+remonstrative
+remorse
+remorseful
+remote
+remotely
+remoteness
+remotest
+removable
+removal
+removals
+remove
+removed
+remover
+removes
+removing
+remunerate
+remuneration
+Remus
+Remy
+Rena
+renaissance
+renal
+rename
+renamed
+renames
+renaming
+Renault
+Renaults
+rend
+render
+rendered
+rendering
+renderings
+renders
+rendezvous
+rending
+rendition
+renditions
+rends
+Rene
+Renee
+renegade
+renegotiable
+renew
+renewable
+renewal
+renewed
+renewer
+renewing
+renews
+Reno
+Renoir
+renounce
+renounces
+renouncing
+renovate
+renovated
+renovation
+renown
+renowned
+Rensselaer
+rent
+rental
+rentals
+rented
+renting
+rents
+renumber
+renumbering
+renumbers
+renunciate
+renunciation
+Renville
+reoccur
+reopen
+reopened
+reopening
+reopens
+reorder
+reordered
+reordering
+reorders
+reorganization
+reorganizations
+reorganize
+reorganized
+reorganizes
+reorganizing
+repackage
+repaid
+repair
+repaired
+repairer
+repairing
+repairman
+repairmen
+repairs
+reparation
+reparations
+repartee
+repartition
+repast
+repasts
+repay
+repaying
+repays
+repeal
+repealed
+repealer
+repealing
+repeals
+repeat
+repeatable
+repeated
+repeatedly
+repeater
+repeaters
+repeating
+repeats
+repel
+repelled
+repellent
+repels
+repent
+repentance
+repented
+repenting
+repents
+repercussion
+repercussions
+repertoire
+repertory
+repetition
+repetitions
+repetitious
+repetitive
+repetitively
+repetitiveness
+rephrase
+rephrased
+rephrases
+rephrasing
+repine
+replace
+replaceable
+replaced
+replacement
+replacements
+replacer
+replaces
+replacing
+replay
+replayed
+replaying
+replays
+replenish
+replenished
+replenishes
+replenishing
+replete
+repleteness
+repletion
+replica
+replicas
+replicate
+replicated
+replicates
+replicating
+replication
+replications
+replied
+replies
+reply
+replying
+report
+reported
+reportedly
+reporter
+reporters
+reporting
+reports
+repose
+reposed
+reposes
+reposing
+reposition
+repositioned
+repositioning
+repositions
+repositories
+repository
+reprehensible
+represent
+representable
+representably
+representation
+representational
+representationally
+representations
+representative
+representatively
+representativeness
+representatives
+represented
+representing
+represents
+repress
+repressed
+represses
+repressing
+repression
+repressions
+repressive
+reprieve
+reprieved
+reprieves
+reprieving
+reprimand
+reprint
+reprinted
+reprinting
+reprints
+reprisal
+reprisals
+reproach
+reproached
+reproaches
+reproaching
+reprobate
+reproduce
+reproduced
+reproducer
+reproducers
+reproduces
+reproducibilities
+reproducibility
+reproducible
+reproducibly
+reproducing
+reproduction
+reproductions
+reprogram
+reprogrammed
+reprogramming
+reprograms
+reproof
+reprove
+reprover
+reptile
+reptiles
+reptilian
+republic
+republican
+republicans
+republics
+repudiate
+repudiated
+repudiates
+repudiating
+repudiation
+repudiations
+repugnant
+repulse
+repulsed
+repulses
+repulsing
+repulsion
+repulsions
+repulsive
+reputable
+reputably
+reputation
+reputations
+repute
+reputed
+reputedly
+reputes
+request
+requested
+requester
+requesters
+requesting
+requests
+require
+required
+requirement
+requirements
+requires
+requiring
+requisite
+requisites
+requisition
+requisitioned
+requisitioning
+requisitions
+reread
+reregister
+reroute
+rerouted
+reroutes
+rerouting
+rerun
+reruns
+reschedule
+rescind
+rescue
+rescued
+rescuer
+rescuers
+rescues
+rescuing
+research
+researched
+researcher
+researchers
+researches
+researching
+reselect
+reselected
+reselecting
+reselects
+resell
+reselling
+resemblance
+resemblances
+resemble
+resembled
+resembles
+resembling
+resent
+resented
+resentful
+resentfully
+resenting
+resentment
+resents
+reserpine
+reservation
+reservations
+reserve
+reserved
+reserver
+reserves
+reserving
+reservoir
+reservoirs
+reset
+resets
+resetting
+resettings
+reside
+resided
+residence
+residences
+resident
+residential
+residentially
+residents
+resides
+residing
+residual
+residue
+residues
+resign
+resignation
+resignations
+resigned
+resigning
+resigns
+resilient
+resin
+resins
+resist
+resistable
+resistance
+resistances
+resistant
+resistantly
+resisted
+resistible
+resisting
+resistive
+resistivity
+resistor
+resistors
+resists
+resolute
+resolutely
+resoluteness
+resolution
+resolutions
+resolvable
+resolve
+resolved
+resolver
+resolvers
+resolves
+resolving
+resonance
+resonances
+resonant
+resonate
+resort
+resorted
+resorting
+resorts
+resound
+resounding
+resounds
+resource
+resourceful
+resourcefully
+resourcefulness
+resources
+respect
+respectability
+respectable
+respectably
+respected
+respecter
+respectful
+respectfully
+respectfulness
+respecting
+respective
+respectively
+respects
+respiration
+respirator
+respiratory
+respite
+resplendent
+resplendently
+respond
+responded
+respondent
+respondents
+responder
+responding
+responds
+response
+responses
+responsibilities
+responsibility
+responsible
+responsibleness
+responsibly
+responsive
+responsively
+responsiveness
+rest
+restart
+restarted
+restarting
+restarts
+restate
+restated
+restatement
+restates
+restating
+restaurant
+restaurants
+restaurateur
+rested
+restful
+restfully
+restfulness
+resting
+restitution
+restive
+restless
+restlessly
+restlessness
+restoration
+restorations
+restore
+restored
+restorer
+restorers
+restores
+restoring
+restrain
+restrained
+restrainer
+restrainers
+restraining
+restrains
+restraint
+restraints
+restrict
+restricted
+restricting
+restriction
+restrictions
+restrictive
+restrictively
+restricts
+restroom
+restructure
+restructured
+restructures
+restructuring
+rests
+result
+resultant
+resultantly
+resultants
+resulted
+resulting
+results
+resumable
+resume
+resumed
+resumes
+resuming
+resumption
+resumptions
+resurgent
+resurrect
+resurrected
+resurrecting
+resurrection
+resurrections
+resurrector
+resurrectors
+resurrects
+resuscitate
+resynchronization
+resynchronize
+resynchronized
+resynchronizing
+retail
+retailer
+retailers
+retailing
+retain
+retained
+retainer
+retainers
+retaining
+retainment
+retains
+retaliate
+retaliation
+retaliatory
+retard
+retarded
+retarder
+retarding
+retch
+retention
+retentions
+retentive
+retentively
+retentiveness
+reticle
+reticles
+reticular
+reticulate
+reticulated
+reticulately
+reticulates
+reticulating
+reticulation
+retina
+retinal
+retinas
+retinue
+retire
+retired
+retiree
+retirement
+retirements
+retires
+retiring
+retort
+retorted
+retorts
+retrace
+retraced
+retraces
+retracing
+retract
+retracted
+retracting
+retraction
+retractions
+retracts
+retrain
+retrained
+retraining
+retrains
+retranslate
+retranslated
+retransmission
+retransmissions
+retransmit
+retransmits
+retransmitted
+retransmitting
+retreat
+retreated
+retreating
+retreats
+retribution
+retried
+retrier
+retriers
+retries
+retrievable
+retrieval
+retrievals
+retrieve
+retrieved
+retriever
+retrievers
+retrieves
+retrieving
+retroactive
+retroactively
+retrofit
+retrofitting
+retrograde
+retrospect
+retrospection
+retrospective
+retry
+retrying
+return
+returnable
+returned
+returner
+returning
+returns
+retype
+retyped
+retypes
+retyping
+Reub
+Reuben
+reunion
+reunions
+reunite
+reunited
+reuniting
+reusable
+reuse
+reused
+reuses
+reusing
+Reuters
+Reuther
+revamp
+revamped
+revamping
+revamps
+reveal
+revealed
+revealing
+reveals
+revel
+revelation
+revelations
+reveled
+reveler
+reveling
+revelry
+revels
+revenge
+revenger
+revenue
+revenuers
+revenues
+reverberate
+revere
+revered
+reverence
+reverend
+reverends
+reverent
+reverently
+reveres
+reverie
+reverified
+reverifies
+reverify
+reverifying
+revering
+reversal
+reversals
+reverse
+reversed
+reversely
+reverser
+reverses
+reversible
+reversing
+reversion
+revert
+reverted
+reverting
+reverts
+review
+reviewed
+reviewer
+reviewers
+reviewing
+reviews
+revile
+reviled
+reviler
+reviling
+revise
+revised
+reviser
+revises
+revising
+revision
+revisionary
+revisions
+revisit
+revisited
+revisiting
+revisits
+revival
+revivals
+revive
+revived
+reviver
+revives
+reviving
+revocable
+revocation
+revoke
+revoked
+revoker
+revokes
+revoking
+revolt
+revolted
+revolter
+revolting
+revoltingly
+revolts
+revolution
+revolutionaries
+revolutionary
+revolutionize
+revolutionized
+revolutionizer
+revolutions
+revolve
+revolved
+revolver
+revolvers
+revolves
+revolving
+revulsion
+reward
+rewarded
+rewarding
+rewardingly
+rewards
+rewind
+rewinding
+rewinds
+rewire
+rework
+reworked
+reworking
+reworks
+rewound
+rewrite
+rewrites
+rewriting
+rewritten
+Rex
+Reykjavik
+Reynolds
+rhapsody
+Rhea
+Rheims
+Rheinholdt
+Rhenish
+rhesus
+rhetoric
+rheumatic
+rheumatism
+Rhine
+rhinestone
+rhino
+rhinoceros
+rho
+Rhoda
+Rhode
+Rhodes
+Rhodesia
+rhododendron
+rhombic
+rhombus
+rhubarb
+rhyme
+rhymed
+rhymes
+rhyming
+rhythm
+rhythmic
+rhythmically
+rhythms
+rib
+ribald
+ribbed
+ribbing
+ribbon
+ribbons
+riboflavin
+ribonucleic
+ribs
+Rica
+Rican
+Ricanism
+Ricans
+rice
+rich
+Richard
+Richards
+Richardson
+richer
+riches
+richest
+Richey
+Richfield
+Richland
+richly
+Richmond
+richness
+Richter
+Rick
+Rickenbaugh
+rickets
+Rickettsia
+rickety
+rickshaw
+rickshaws
+Rico
+ricochet
+rid
+riddance
+ridden
+ridding
+riddle
+riddled
+riddles
+riddling
+ride
+rider
+riders
+rides
+ridge
+Ridgefield
+ridgepole
+ridges
+Ridgway
+ridicule
+ridiculed
+ridicules
+ridiculing
+ridiculous
+ridiculously
+ridiculousness
+riding
+rids
+Riemann
+Riemannian
+rifle
+rifled
+rifleman
+rifler
+rifles
+rifling
+rift
+rig
+Riga
+Rigel
+rigging
+Riggs
+right
+righted
+righteous
+righteously
+righteousness
+righter
+rightful
+rightfully
+rightfulness
+righting
+rightly
+rightmost
+rightness
+rights
+rightward
+rigid
+rigidity
+rigidly
+rigor
+rigorous
+rigorously
+rigors
+rigs
+Riley
+Rilke
+rill
+rim
+rime
+rims
+rind
+rinds
+Rinehart
+ring
+ringed
+ringer
+ringers
+ringing
+ringingly
+ringings
+rings
+ringside
+rink
+rinse
+rinsed
+rinser
+rinses
+rinsing
+Rio
+Riordan
+riot
+rioted
+rioter
+rioters
+rioting
+riotous
+riots
+rip
+ripe
+ripely
+ripen
+ripeness
+Ripley
+ripoff
+ripped
+ripping
+ripple
+rippled
+ripples
+rippling
+rips
+RISC
+rise
+risen
+riser
+risers
+rises
+rising
+risings
+risk
+risked
+risking
+risks
+risky
+Ritchie
+rite
+rites
+Ritter
+ritual
+ritually
+rituals
+Ritz
+rival
+rivaled
+rivalled
+rivalling
+rivalries
+rivalry
+rivals
+river
+riverbank
+riverfront
+rivers
+riverside
+Riverview
+rivet
+riveter
+rivets
+Riviera
+rivulet
+rivulets
+Riyadh
+roach
+road
+roadbed
+roadblock
+roads
+roadside
+roadster
+roadsters
+roadway
+roadways
+roam
+roamed
+roaming
+roams
+roar
+roared
+roarer
+roaring
+roars
+roast
+roasted
+roaster
+roasting
+roasts
+rob
+robbed
+robber
+robberies
+robbers
+robbery
+Robbie
+Robbin
+robbing
+Robbins
+robe
+robed
+Robert
+Roberta
+Roberto
+Roberts
+Robertson
+Robertsons
+robes
+robin
+robing
+robins
+Robinson
+Robinsonville
+robot
+robotic
+robotics
+robots
+robs
+robust
+robustly
+robustness
+Rocco
+Rochester
+Rochford
+rock
+rockabye
+Rockaway
+Rockaways
+rocked
+Rockefeller
+rocker
+rockers
+rocket
+rocketed
+rocketing
+rockets
+Rockford
+Rockies
+rocking
+Rockland
+rocks
+Rockville
+Rockwell
+rocky
+rod
+rode
+rodent
+rodents
+rodeo
+Rodgers
+Rodney
+Rodriguez
+rods
+roe
+Roentgen
+Roger
+Rogers
+rogue
+rogues
+Roland
+role
+roles
+roll
+rollback
+rolled
+roller
+rollers
+Rollie
+rolling
+Rollins
+rolls
+Roman
+romance
+romancer
+romancers
+romances
+romancing
+Romanesque
+Romania
+Romanizations
+Romanizer
+Romanizers
+Romanizes
+Romano
+Romans
+romantic
+romantics
+Rome
+Romeldale
+Romeo
+romp
+romped
+romper
+romping
+romps
+Romulus
+Ron
+Ronald
+Ronnie
+roof
+roofed
+roofer
+roofing
+roofs
+rooftop
+rook
+rookie
+room
+roomed
+roomer
+roomers
+roomful
+rooming
+roommate
+rooms
+roomy
+Rooney
+Roosevelt
+Rooseveltian
+roost
+rooster
+roosters
+root
+rooted
+rooter
+rooting
+roots
+rope
+roped
+roper
+ropers
+ropes
+roping
+Roquemore
+Rorschach
+Rosa
+Rosabelle
+Rosalie
+rosary
+Rose
+rosebud
+rosebuds
+rosebush
+Roseland
+Rosella
+rosemary
+Rosen
+Rosenberg
+Rosenblum
+Rosenthal
+Rosenzweig
+roses
+Rosetta
+rosette
+Rosie
+rosiness
+Ross
+Rossi
+roster
+rostrum
+Roswell
+rosy
+rot
+Rotarian
+Rotarians
+rotary
+rotate
+rotated
+rotates
+rotating
+rotation
+rotational
+rotations
+rotator
+Roth
+Rothschild
+rotor
+rots
+rotten
+rottenness
+Rotterdam
+rotting
+rotund
+rotunda
+rouge
+rough
+roughed
+roughen
+rougher
+roughest
+roughly
+roughneck
+roughness
+roulette
+round
+roundabout
+rounded
+roundedness
+rounder
+roundest
+roundhead
+roundhouse
+rounding
+roundly
+roundness
+roundoff
+rounds
+roundtable
+roundup
+roundworm
+Rourke
+rouse
+roused
+rouses
+rousing
+Rousseau
+roustabout
+rout
+route
+routed
+router
+routers
+routes
+routine
+routinely
+routines
+routing
+routings
+rove
+roved
+rover
+roves
+roving
+row
+rowboat
+rowdy
+Rowe
+rowed
+Rowena
+rower
+rowing
+Rowland
+Rowley
+rows
+Roxbury
+Roxy
+Roy
+royal
+royalist
+royalists
+royally
+royalties
+royalty
+Royce
+Rozelle
+Ruanda
+rub
+Rubaiyat
+rubbed
+rubber
+rubbers
+rubbery
+rubbing
+rubbish
+rubble
+rubdown
+Rube
+Ruben
+Rubens
+rubies
+Rubin
+ruble
+rubles
+rubout
+rubs
+ruby
+rudder
+rudders
+ruddiness
+ruddy
+rude
+rudely
+rudeness
+rudiment
+rudimentary
+rudiments
+Rudolf
+Rudolph
+Rudy
+Rudyard
+rue
+ruefully
+ruffian
+ruffianly
+ruffians
+ruffle
+ruffled
+ruffles
+Rufus
+rug
+rugged
+ruggedly
+ruggedness
+rugs
+ruin
+ruination
+ruinations
+ruined
+ruining
+ruinous
+ruinously
+ruins
+rule
+ruled
+ruler
+rulers
+rules
+ruling
+rulings
+rum
+Rumania
+Rumanian
+Rumanians
+rumble
+rumbled
+rumbler
+rumbles
+rumbling
+rumen
+Rumford
+rummage
+Rummel
+rummy
+rumor
+rumored
+rumors
+rump
+rumple
+rumpled
+rumply
+rumpus
+run
+runaway
+rundown
+rung
+Runge
+rungs
+runnable
+runner
+runners
+running
+Runnymede
+runoff
+runs
+runt
+runtime
+Runyon
+rupee
+Ruppert
+rupture
+ruptured
+ruptures
+rupturing
+rural
+rurally
+rush
+rushed
+rusher
+rushes
+rushing
+Rushmore
+Russ
+Russell
+russet
+Russia
+Russian
+Russianizations
+Russianizes
+Russians
+Russo
+rust
+rusted
+rustic
+rusticate
+rusticated
+rusticates
+rusticating
+rustication
+rusting
+rustle
+rustled
+rustler
+rustlers
+rustling
+rusts
+rusty
+rut
+Rutgers
+Ruth
+Rutherford
+ruthless
+ruthlessly
+ruthlessness
+Rutland
+Rutledge
+ruts
+Rwanda
+Ryan
+Rydberg
+Ryder
+rye
+sabbath
+Sabbathize
+Sabbathizes
+sabbatical
+saber
+sabers
+Sabina
+Sabine
+sable
+sables
+sabotage
+Sachs
+sack
+sacker
+sacking
+sacks
+sacrament
+Sacramento
+sacred
+sacredly
+sacredness
+sacrifice
+sacrificed
+sacrificer
+sacrificers
+sacrifices
+sacrificial
+sacrificially
+sacrificing
+sacrilege
+sacrilegious
+sacrosanct
+sad
+sadden
+saddened
+saddens
+sadder
+saddest
+saddle
+saddlebag
+saddled
+saddles
+Sadie
+sadism
+sadist
+sadistic
+sadistically
+sadists
+Sadler
+sadly
+sadness
+safari
+safe
+safeguard
+safeguarded
+safeguarding
+safeguards
+safekeeping
+safely
+safeness
+safer
+safes
+safest
+safeties
+safety
+saffron
+sag
+saga
+sagacious
+sagacity
+sage
+sagebrush
+sagely
+sages
+sagging
+Saginaw
+sagittal
+Sagittarius
+sags
+saguaro
+Sahara
+said
+Saigon
+sail
+sailboat
+sailed
+sailfish
+sailing
+sailor
+sailorly
+sailors
+sails
+saint
+sainted
+sainthood
+saintly
+saints
+sake
+sakes
+Sal
+Salaam
+salable
+salad
+salads
+salamander
+salami
+salaried
+salaries
+salary
+sale
+Salem
+Salerno
+sales
+salesgirl
+Salesian
+saleslady
+salesman
+salesmen
+salesperson
+salient
+Salina
+saline
+Salisbury
+Salish
+saliva
+salivary
+salivate
+Salk
+Salle
+sallies
+sallow
+Sally
+sallying
+salmon
+salon
+salons
+saloon
+saloons
+salt
+salted
+salter
+salters
+saltier
+saltiest
+saltiness
+salting
+Salton
+salts
+salty
+salutary
+salutation
+salutations
+salute
+saluted
+salutes
+saluting
+Salvador
+Salvadoran
+salvage
+salvaged
+salvager
+salvages
+salvaging
+salvation
+Salvatore
+salve
+salver
+salves
+Salz
+Sam
+Samaritan
+same
+sameness
+Sammy
+Samoa
+Samoan
+sample
+sampled
+sampler
+samplers
+samples
+sampling
+samplings
+Sampson
+Samson
+Samuel
+Samuels
+Samuelson
+San
+Sana
+sanatoria
+sanatorium
+Sanborn
+Sanchez
+Sancho
+sanctification
+sanctified
+sanctify
+sanctimonious
+sanction
+sanctioned
+sanctioning
+sanctions
+sanctity
+sanctuaries
+sanctuary
+sanctum
+sand
+sandal
+sandals
+sandbag
+Sandburg
+sanded
+sander
+Sanderling
+Sanders
+Sanderson
+Sandia
+sanding
+sandman
+sandpaper
+Sandra
+sands
+sandstone
+Sandusky
+sandwich
+sandwiches
+sandy
+sane
+sanely
+saner
+sanest
+Sanford
+sang
+sanguine
+Sanhedrin
+sanitarium
+sanitary
+sanitation
+sanity
+sank
+Sanskrit
+Sanskritic
+Sanskritize
+Santa
+Santayana
+Santiago
+Santo
+Sao
+sap
+sapiens
+sapling
+saplings
+sapphire
+Sappho
+saps
+sapsucker
+Sara
+Saracen
+Saracens
+Sarah
+Saran
+Sarasota
+Saratoga
+sarcasm
+sarcasms
+sarcastic
+sardine
+Sardinia
+sardonic
+Sargent
+sari
+Sartre
+sash
+Saskatchewan
+Saskatoon
+sat
+Satan
+satanic
+Satanism
+Satanist
+satchel
+satchels
+sate
+sated
+satellite
+satellites
+sates
+satin
+sating
+satire
+satires
+satiric
+satisfaction
+satisfactions
+satisfactorily
+satisfactory
+satisfiability
+satisfiable
+satisfied
+satisfies
+satisfy
+satisfying
+saturate
+saturated
+saturates
+saturating
+saturation
+Saturday
+Saturdays
+Saturn
+Saturnalia
+Saturnism
+satyr
+sauce
+saucepan
+saucepans
+saucer
+saucers
+sauces
+saucy
+Saud
+Saudi
+Saukville
+Saul
+Sault
+Saunders
+saunter
+sausage
+sausages
+savage
+savaged
+savagely
+savageness
+savager
+savagers
+savages
+savaging
+Savannah
+save
+saved
+saver
+savers
+saves
+saving
+savings
+savior
+saviors
+Saviour
+Savonarola
+savor
+savored
+savoring
+savors
+savory
+Savoy
+Savoyard
+Savoyards
+saw
+sawdust
+sawed
+sawfish
+sawing
+sawmill
+sawmills
+saws
+sawtooth
+sax
+Saxon
+Saxonization
+Saxonizations
+Saxonize
+Saxonizes
+Saxons
+Saxony
+saxophone
+Saxton
+say
+sayer
+sayers
+saying
+sayings
+says
+scab
+scabbard
+scabbards
+scabrous
+scaffold
+scaffolding
+scaffoldings
+scaffolds
+Scala
+scalable
+scalar
+scalars
+scald
+scalded
+scalding
+scale
+scaled
+scales
+scaling
+scalings
+scallop
+scalloped
+scallops
+scalp
+scalps
+scaly
+scamper
+scampering
+scampers
+scan
+scandal
+scandalous
+scandals
+Scandinavia
+Scandinavian
+Scandinavians
+scanned
+scanner
+scanners
+scanning
+scans
+scant
+scantier
+scantiest
+scantily
+scantiness
+scantly
+scanty
+scapegoat
+scar
+Scarborough
+scarce
+scarcely
+scarceness
+scarcer
+scarcity
+scare
+scarecrow
+scared
+scares
+scarf
+scaring
+Scarlatti
+scarlet
+scars
+Scarsdale
+scarves
+scary
+scatter
+scatterbrain
+scattered
+scattering
+scatters
+scenario
+scenarios
+scene
+scenery
+scenes
+scenic
+scent
+scented
+scents
+scepter
+scepters
+Schaefer
+Schaeffer
+Schafer
+Schaffner
+Schantz
+Schapiro
+schedulable
+schedule
+scheduled
+scheduler
+schedulers
+schedules
+scheduling
+Scheherazade
+Schelling
+schema
+schemas
+schemata
+schematic
+schematically
+schematics
+scheme
+schemed
+schemer
+schemers
+schemes
+scheming
+Schiller
+schism
+schizophrenia
+Schlesinger
+Schlitz
+Schloss
+Schmidt
+Schmitt
+Schnabel
+Schneider
+Schoenberg
+Schofield
+scholar
+scholarly
+scholars
+scholarship
+scholarships
+scholastic
+scholastically
+scholastics
+school
+schoolboy
+schoolboys
+schooled
+schooler
+schoolers
+schoolhouse
+schoolhouses
+schooling
+schoolmaster
+schoolmasters
+schoolroom
+schoolrooms
+schools
+schooner
+Schopenhauer
+Schottky
+Schroeder
+Schroedinger
+Schubert
+Schultz
+Schulz
+Schumacher
+Schuman
+Schumann
+Schuster
+Schuyler
+Schuylkill
+Schwab
+Schwartz
+Schweitzer
+science
+sciences
+scientific
+scientifically
+scientist
+scientists
+scissor
+scissored
+scissoring
+scissors
+sclerosis
+sclerotic
+scoff
+scoffed
+scoffer
+scoffing
+scoffs
+scold
+scolded
+scolding
+scolds
+scoop
+scooped
+scooping
+scoops
+scoot
+scope
+scoped
+scopes
+scoping
+scorch
+scorched
+scorcher
+scorches
+scorching
+score
+scoreboard
+scorecard
+scored
+scorer
+scorers
+scores
+scoring
+scorings
+scorn
+scorned
+scorner
+scornful
+scornfully
+scorning
+scorns
+Scorpio
+scorpion
+scorpions
+Scot
+scotch
+Scotchgard
+Scotchman
+Scotia
+Scotian
+Scotland
+Scots
+Scotsman
+Scotsmen
+Scott
+Scottish
+Scottsdale
+Scotty
+scoundrel
+scoundrels
+scour
+scoured
+scourge
+scouring
+scours
+scout
+scouted
+scouting
+scouts
+scow
+scowl
+scowled
+scowling
+scowls
+scram
+scramble
+scrambled
+scrambler
+scrambles
+scrambling
+Scranton
+scrap
+scrape
+scraped
+scraper
+scrapers
+scrapes
+scraping
+scrapings
+scrapped
+scraps
+scratch
+scratched
+scratcher
+scratchers
+scratches
+scratching
+scratchy
+scrawl
+scrawled
+scrawling
+scrawls
+scrawny
+scream
+screamed
+screamer
+screamers
+screaming
+screams
+screech
+screeched
+screeches
+screeching
+screen
+screened
+screening
+screenings
+screenplay
+screens
+screw
+screwball
+screwdriver
+screwed
+screwing
+screws
+scribble
+scribbled
+scribbler
+scribbles
+scribe
+scribes
+scribing
+Scribners
+scrimmage
+Scripps
+script
+scripts
+scripture
+scriptures
+scroll
+scrolled
+scrolling
+scrolls
+Scrooge
+scrounge
+scrub
+scrumptious
+scruple
+scrupulous
+scrupulously
+scrutinize
+scrutinized
+scrutinizing
+scrutiny
+scuba
+scud
+scuffle
+scuffled
+scuffles
+scuffling
+sculpt
+sculpted
+sculptor
+sculptors
+sculpts
+sculpture
+sculptured
+sculptures
+scurried
+scurry
+scurvy
+scuttle
+scuttled
+scuttles
+scuttling
+Scylla
+scythe
+scythes
+Scythia
+sea
+seaboard
+Seaborg
+Seabrook
+seacoast
+seacoasts
+seafood
+Seagate
+Seagram
+seagull
+seahorse
+seal
+sealed
+sealer
+sealing
+seals
+sealy
+seam
+seaman
+seamed
+seamen
+seaming
+seams
+seamy
+Sean
+seaport
+seaports
+Seaquarium
+sear
+search
+searched
+searcher
+searchers
+searches
+searching
+searchingly
+searchings
+searchlight
+seared
+searing
+searingly
+Sears
+seas
+seashore
+seashores
+seaside
+season
+seasonable
+seasonably
+seasonal
+seasonally
+seasoned
+seasoner
+seasoners
+seasoning
+seasonings
+seasons
+seat
+seated
+seating
+seats
+Seattle
+seaward
+seaweed
+Sebastian
+secant
+secede
+seceded
+secedes
+seceding
+secession
+seclude
+secluded
+seclusion
+second
+secondaries
+secondarily
+secondary
+seconded
+seconder
+seconders
+secondhand
+seconding
+secondly
+seconds
+secrecy
+secret
+secretarial
+secretariat
+secretaries
+secretary
+secrete
+secreted
+secretes
+secreting
+secretion
+secretions
+secretive
+secretively
+secretly
+secrets
+sect
+sectarian
+section
+sectional
+sectioned
+sectioning
+sections
+sector
+sectors
+sects
+secular
+secure
+secured
+securely
+secures
+securing
+securings
+securities
+security
+sedan
+sedate
+sedge
+Sedgwick
+sediment
+sedimentary
+sediments
+sedition
+seditious
+seduce
+seduced
+seducer
+seducers
+seduces
+seducing
+seduction
+seductive
+see
+seed
+seeded
+seeder
+seeders
+seeding
+seedings
+seedling
+seedlings
+seeds
+seedy
+seeing
+seek
+seeker
+seekers
+seeking
+seeks
+Seeley
+seem
+seemed
+seeming
+seemingly
+seemly
+seems
+seen
+seep
+seepage
+seeped
+seeping
+seeps
+seer
+seers
+seersucker
+sees
+seethe
+seethed
+seethes
+seething
+segment
+segmentation
+segmentations
+segmented
+segmenting
+segments
+Segovia
+segregate
+segregated
+segregates
+segregating
+segregation
+Segundo
+Seidel
+seismic
+seismograph
+seismology
+seize
+seized
+seizes
+seizing
+seizure
+seizures
+seldom
+select
+selected
+selecting
+selection
+selections
+selective
+selectively
+selectivity
+selectman
+selectmen
+selector
+selectors
+Selectric
+selects
+Selena
+selenium
+self
+selfish
+selfishly
+selfishness
+Selfridge
+selfsame
+Selkirk
+sell
+seller
+sellers
+selling
+sellout
+sells
+Selma
+seltzer
+selves
+Selwyn
+semantic
+semantical
+semantically
+semanticist
+semanticists
+semantics
+semaphore
+semaphores
+semblance
+semester
+semesters
+semi
+semiautomated
+semicolon
+semicolons
+semiconductor
+semiconductors
+seminal
+seminar
+seminarian
+seminaries
+seminars
+seminary
+Seminole
+semipermanent
+semipermanently
+Semiramis
+Semite
+Semitic
+Semiticize
+Semiticizes
+Semitization
+Semitizations
+Semitize
+Semitizes
+senate
+senates
+senator
+senatorial
+senators
+send
+sender
+senders
+sending
+sends
+Seneca
+Senegal
+senile
+senior
+seniority
+seniors
+sensation
+sensational
+sensationally
+sensations
+sense
+sensed
+senseless
+senselessly
+senselessness
+senses
+sensibilities
+sensibility
+sensible
+sensibly
+sensing
+sensitive
+sensitively
+sensitiveness
+sensitives
+sensitivities
+sensitivity
+sensor
+sensors
+sensory
+sensual
+sensuous
+sent
+sentence
+sentenced
+sentences
+sentencing
+sentential
+sentiment
+sentimental
+sentimentally
+sentiments
+sentinel
+sentinels
+sentries
+sentry
+Seoul
+separable
+separate
+separated
+separately
+separateness
+separates
+separating
+separation
+separations
+separator
+separators
+sepia
+Sepoy
+sept
+September
+Septembers
+sepulcher
+sepulchers
+sequel
+sequels
+sequence
+sequenced
+sequencer
+sequencers
+sequences
+sequencing
+sequencings
+sequential
+sequentiality
+sequentialize
+sequentialized
+sequentializes
+sequentializing
+sequentially
+sequester
+Sequoia
+Serafin
+Serbia
+Serbian
+Serbians
+Serbo-
+serendipitous
+serendipity
+serene
+serenely
+serenity
+serf
+serfs
+sergeant
+sergeants
+Sergei
+serial
+serializability
+serializable
+serialization
+serializations
+serialize
+serialized
+serializes
+serializing
+serially
+serials
+series
+serif
+serious
+seriously
+seriousness
+sermon
+sermons
+Serpens
+serpent
+serpentine
+serpents
+Serra
+serum
+serums
+servant
+servants
+serve
+served
+server
+servers
+serves
+service
+serviceability
+serviceable
+serviced
+serviceman
+servicemen
+services
+servicing
+servile
+serving
+servings
+servitude
+servo
+servomechanism
+sesame
+session
+sessions
+set
+setback
+Seth
+sets
+settable
+setter
+setters
+setting
+settings
+settle
+settled
+settlement
+settlements
+settler
+settlers
+settles
+settling
+setup
+setups
+seven
+sevenfold
+sevens
+seventeen
+seventeens
+seventeenth
+seventh
+seventies
+seventieth
+seventy
+sever
+several
+severalfold
+severally
+severance
+severe
+severed
+severely
+severer
+severest
+severing
+severities
+severity
+Severn
+severs
+Seville
+sew
+sewage
+Seward
+sewed
+sewer
+sewers
+sewing
+sews
+sex
+sexed
+sexes
+sexist
+Sextans
+sextet
+sextillion
+sexton
+sextuple
+sextuplet
+sexual
+sexuality
+sexually
+sexy
+Seychelles
+Seymour
+shabby
+shack
+shacked
+shackle
+shackled
+shackles
+shackling
+shacks
+shade
+shaded
+shades
+shadier
+shadiest
+shadily
+shadiness
+shading
+shadings
+shadow
+shadowed
+shadowing
+shadows
+shadowy
+shady
+Shafer
+Shaffer
+shaft
+shafts
+shaggy
+shakable
+shakably
+shake
+shakedown
+shaken
+shaker
+shakers
+shakes
+Shakespeare
+Shakespearean
+Shakespearian
+Shakespearize
+Shakespearizes
+shakiness
+shaking
+shaky
+shale
+shall
+shallow
+shallower
+shallowly
+shallowness
+sham
+shambles
+shame
+shamed
+shameful
+shamefully
+shameless
+shamelessly
+shames
+shaming
+shampoo
+shamrock
+shams
+Shanghai
+Shanghaied
+Shanghaiing
+Shanghaiings
+Shanghais
+Shannon
+shanties
+Shantung
+shanty
+shape
+shaped
+shapeless
+shapelessly
+shapelessness
+shapely
+shaper
+shapers
+shapes
+shaping
+Shapiro
+sharable
+shard
+share
+shareable
+sharecropper
+sharecroppers
+shared
+shareholder
+shareholders
+sharer
+sharers
+shares
+Shari
+sharing
+shark
+sharks
+Sharon
+sharp
+Sharpe
+sharpen
+sharpened
+sharpening
+sharpens
+sharper
+sharpest
+sharply
+sharpness
+sharpshoot
+Shasta
+shatter
+shattered
+shattering
+shatterproof
+shatters
+Shattuck
+shave
+shaved
+shaven
+shaves
+shaving
+shavings
+Shawano
+shawl
+shawls
+Shawnee
+she
+Shea
+sheaf
+shear
+sheared
+Shearer
+shearing
+shears
+sheath
+sheathing
+sheaths
+sheaves
+Sheboygan
+shed
+shedding
+Shedir
+sheds
+Sheehan
+sheen
+sheep
+sheepskin
+sheer
+sheered
+sheet
+sheeted
+sheeting
+sheets
+Sheffield
+sheik
+Sheila
+Shelby
+Sheldon
+shelf
+shell
+shelled
+sheller
+Shelley
+shelling
+shells
+shelter
+sheltered
+sheltering
+shelters
+Shelton
+shelve
+shelved
+shelves
+shelving
+Shenandoah
+shenanigan
+Shepard
+shepherd
+shepherds
+Sheppard
+Sheraton
+sherbet
+Sheridan
+sheriff
+sheriffs
+Sherlock
+Sherman
+Sherrill
+sherry
+Sherwin
+Sherwood
+shibboleth
+shied
+shield
+shielded
+shielding
+Shields
+shies
+shift
+shifted
+shifter
+shifters
+shiftier
+shiftiest
+shiftily
+shiftiness
+shifting
+shifts
+shifty
+Shiite
+Shiites
+shill
+shilling
+shillings
+Shillong
+Shiloh
+shimmer
+shimmering
+shin
+shinbone
+shine
+shined
+shiner
+shiners
+shines
+shingle
+shingles
+shining
+shiningly
+Shinto
+Shintoism
+Shintoize
+Shintoizes
+shiny
+ship
+shipboard
+shipbuilding
+Shipley
+shipmate
+shipment
+shipments
+shipped
+shipper
+shippers
+shipping
+ships
+shipshape
+shipwreck
+shipwrecked
+shipwrecks
+shipyard
+shire
+shirk
+shirker
+shirking
+shirks
+Shirley
+shirt
+shirting
+shirts
+shit
+Shiva
+shiver
+shivered
+shiverer
+shivering
+shivers
+Shmuel
+shoal
+shoals
+shock
+shocked
+shocker
+shockers
+shocking
+shockingly
+Shockley
+shocks
+shod
+shoddy
+shoe
+shoed
+shoehorn
+shoeing
+shoelace
+shoemaker
+shoes
+shoestring
+Shoji
+shone
+shook
+shoot
+shooter
+shooters
+shooting
+shootings
+shoots
+shop
+shopkeeper
+shopkeepers
+shopped
+shopper
+shoppers
+shopping
+shops
+shopworn
+shore
+shoreline
+shores
+Shorewood
+shorn
+short
+shortage
+shortages
+shortcoming
+shortcomings
+shortcut
+shortcuts
+shorted
+shorten
+shortened
+shortening
+shortens
+shorter
+shortest
+shortfall
+shorthand
+shorthanded
+shorting
+shortish
+shortly
+shortness
+shorts
+shortsighted
+shortstop
+Shoshone
+shot
+shotgun
+shotguns
+shots
+should
+shoulder
+shouldered
+shouldering
+shoulders
+shout
+shouted
+shouter
+shouters
+shouting
+shouts
+shove
+shoved
+shovel
+shoveled
+shovels
+shoves
+shoving
+show
+showboat
+showcase
+showdown
+showed
+shower
+showered
+showering
+showers
+showing
+showings
+shown
+showpiece
+showroom
+shows
+showy
+shrank
+shrapnel
+shred
+shredder
+shredding
+shreds
+Shreveport
+shrew
+shrewd
+shrewdest
+shrewdly
+shrewdness
+shrews
+shriek
+shrieked
+shrieking
+shrieks
+shrill
+shrilled
+shrilling
+shrillness
+shrilly
+shrimp
+shrine
+shrines
+shrink
+shrinkable
+shrinkage
+shrinking
+shrinks
+shrivel
+shriveled
+shroud
+shrouded
+shrub
+shrubbery
+shrubs
+shrug
+shrugs
+shrunk
+shrunken
+Shu
+shudder
+shuddered
+shuddering
+shudders
+shuffle
+shuffleboard
+shuffled
+shuffles
+shuffling
+Shulman
+shun
+shuns
+shunt
+shut
+shutdown
+shutdowns
+shutoff
+shutout
+shuts
+shutter
+shuttered
+shutters
+shutting
+shuttle
+shuttlecock
+shuttled
+shuttles
+shuttling
+shy
+Shylock
+Shylockian
+shyly
+shyness
+Siam
+Siamese
+Sian
+Siberia
+Siberian
+Sibley
+sibling
+siblings
+Sicilian
+Siciliana
+Sicilians
+Sicily
+sick
+sicken
+sicker
+sickest
+sickle
+sickly
+sickness
+sicknesses
+sickroom
+side
+sidearm
+sideband
+sideboard
+sideboards
+sideburns
+sidecar
+sided
+sidelight
+sidelights
+sideline
+sidereal
+sides
+sidesaddle
+sideshow
+sidestep
+sidetrack
+sidewalk
+sidewalks
+sideways
+sidewise
+siding
+sidings
+Sidney
+siege
+Siegel
+sieges
+Siegfried
+Sieglinda
+Siegmund
+Siemens
+Siena
+sierra
+sieve
+sieves
+Sifford
+sift
+sifted
+sifter
+sifting
+SIGGRAPH
+sigh
+sighed
+sighing
+sighs
+sight
+sighted
+sighting
+sightings
+sightly
+sights
+sightseeing
+sigma
+Sigmund
+sign
+signal
+signaled
+signaling
+signalled
+signalling
+signally
+signals
+signature
+signatures
+signed
+signer
+signers
+signet
+significance
+significant
+significantly
+significants
+signification
+signified
+signifies
+signify
+signifying
+signing
+signs
+Sikh
+Sikhes
+Sikhs
+Sikkim
+Sikkimese
+Sikorsky
+Silas
+silence
+silenced
+silencer
+silencers
+silences
+silencing
+silent
+silently
+silhouette
+silhouetted
+silhouettes
+silica
+silicate
+silicon
+silicone
+silk
+silken
+silkier
+silkiest
+silkily
+Silkine
+silks
+silky
+sill
+silliest
+silliness
+sills
+silly
+silo
+silt
+silted
+silting
+silts
+silver
+silvered
+silvering
+Silverman
+silvers
+silversmith
+Silverstein
+silverware
+silvery
+similar
+similarities
+similarity
+similarly
+simile
+similitude
+Simla
+simmer
+simmered
+simmering
+simmers
+Simmons
+Simmonsville
+Simms
+Simon
+Simons
+Simonson
+simple
+simpleminded
+simpleness
+simpler
+simplest
+simpleton
+simplex
+simplicities
+simplicity
+simplification
+simplifications
+simplified
+simplifier
+simplifiers
+simplifies
+simplify
+simplifying
+simplistic
+simply
+Simpson
+Sims
+SIMULA
+Simula
+simulate
+simulated
+simulates
+simulating
+simulation
+simulations
+simulator
+simulators
+simulcast
+simultaneity
+simultaneous
+simultaneously
+Sinai
+Sinatra
+Sinbad
+since
+sincere
+sincerely
+sincerest
+sincerity
+Sinclair
+sine
+sines
+sinew
+sinews
+sinewy
+sinful
+sinfully
+sinfulness
+sing
+singable
+Singapore
+Singborg
+singe
+singed
+singer
+singers
+singing
+singingly
+single
+singled
+singlehanded
+singleness
+singles
+singlet
+singleton
+singletons
+singling
+singly
+sings
+singsong
+singular
+singularities
+singularity
+singularly
+sinister
+sink
+sinked
+sinker
+sinkers
+sinkhole
+sinking
+sinks
+sinned
+sinner
+sinners
+sinning
+Sino-
+sins
+sinuous
+sinus
+sinusoid
+sinusoidal
+sinusoids
+Sioux
+sip
+siphon
+siphoning
+sipping
+sips
+sir
+sire
+sired
+siren
+sirens
+sires
+Sirius
+sirs
+sirup
+sister
+sisterly
+sisters
+Sistine
+Sisyphean
+Sisyphus
+sit
+site
+sited
+sites
+siting
+sits
+sitter
+sitters
+sitting
+sittings
+situ
+situate
+situated
+situates
+situating
+situation
+situational
+situationally
+situations
+Siva
+six
+sixes
+sixfold
+sixgun
+sixpence
+sixteen
+sixteens
+sixteenth
+sixth
+sixties
+sixtieth
+sixty
+sizable
+size
+sized
+sizes
+sizing
+sizings
+sizzle
+skate
+skated
+skater
+skaters
+skates
+skating
+skeletal
+skeleton
+skeletons
+skeptic
+skeptical
+skeptically
+skepticism
+skeptics
+sketch
+sketchbook
+sketched
+sketches
+sketchily
+sketching
+sketchpad
+sketchy
+skew
+skewed
+skewer
+skewers
+skewing
+skews
+ski
+skid
+skidding
+skied
+skies
+skiff
+skiing
+skill
+skilled
+skillet
+skillful
+skillfully
+skillfulness
+skills
+skim
+skimmed
+skimming
+skimp
+skimped
+skimping
+skimps
+skimpy
+skims
+skin
+skindive
+skinned
+skinner
+skinners
+skinning
+skinny
+skins
+skip
+skipped
+skipper
+skippers
+skipping
+Skippy
+skips
+skirmish
+skirmished
+skirmisher
+skirmishers
+skirmishes
+skirmishing
+skirt
+skirted
+skirting
+skirts
+skis
+skit
+Skopje
+skulk
+skulked
+skulker
+skulking
+skulks
+skull
+skullcap
+skullduggery
+skulls
+skunk
+skunks
+sky
+Skye
+skyhook
+skyjack
+skylark
+skylarking
+skylarks
+skylight
+skylights
+skyline
+skyrockets
+skyscraper
+skyscrapers
+slab
+slack
+slacken
+slacker
+slacking
+slackly
+slackness
+slacks
+slain
+slam
+slammed
+slamming
+slams
+slander
+slanderer
+slanderous
+slanders
+slang
+slant
+slanted
+slanting
+slants
+slap
+slapped
+slapping
+slaps
+slapstick
+slash
+slashed
+slashes
+slashing
+slat
+slate
+slated
+slater
+slates
+slats
+slaughter
+slaughtered
+slaughterhouse
+slaughtering
+slaughters
+Slav
+slave
+slaver
+slavery
+slaves
+Slavic
+Slavicize
+Slavicizes
+slavish
+Slavization
+Slavizations
+Slavize
+Slavizes
+Slavonic
+Slavonicize
+Slavonicizes
+Slavs
+slay
+slayer
+slayers
+slaying
+slays
+sled
+sledding
+sledge
+sledgehammer
+sledges
+sleds
+sleek
+sleep
+sleeper
+sleepers
+sleepily
+sleepiness
+sleeping
+sleepless
+sleeplessly
+sleeplessness
+sleeps
+sleepwalk
+sleepy
+sleet
+sleeve
+sleeves
+sleigh
+sleighs
+sleight
+slender
+slenderer
+slept
+Slesinger
+sleuth
+slew
+slewing
+slice
+sliced
+slicer
+slicers
+slices
+slicing
+slick
+slicker
+slickers
+slicks
+slid
+slide
+slider
+sliders
+slides
+sliding
+slight
+slighted
+slighter
+slightest
+slighting
+slightly
+slightness
+slights
+slim
+slime
+slimed
+slimly
+slimy
+sling
+slinging
+slings
+slingshot
+slip
+slippage
+slipped
+slipper
+slipperiness
+slippers
+slippery
+slipping
+slips
+slit
+slither
+slits
+sliver
+Sloan
+Sloane
+slob
+Slocum
+slogan
+slogans
+sloop
+slop
+slope
+sloped
+sloper
+slopers
+slopes
+sloping
+slopped
+sloppiness
+slopping
+sloppy
+slops
+slot
+sloth
+slothful
+sloths
+slots
+slotted
+slotting
+slouch
+slouched
+slouches
+slouching
+Slovakia
+Slovenia
+slow
+slowdown
+slowed
+slower
+slowest
+slowing
+slowly
+slowness
+slows
+sludge
+slug
+sluggish
+sluggishly
+sluggishness
+slugs
+sluice
+slum
+slumber
+slumbered
+slumming
+slump
+slumped
+slumps
+slums
+slung
+slur
+slurp
+slurring
+slurry
+slurs
+sly
+slyly
+smack
+smacked
+smacking
+smacks
+small
+smaller
+smallest
+Smalley
+smallish
+smallness
+smallpox
+smalltime
+Smallwood
+smart
+smarted
+smarter
+smartest
+smartly
+smartness
+smash
+smashed
+smasher
+smashers
+smashes
+smashing
+smashingly
+smattering
+smear
+smeared
+smearing
+smears
+smell
+smelled
+smelling
+smells
+smelly
+smelt
+smelter
+smelts
+smile
+smiled
+smiles
+smiling
+smilingly
+smirk
+smite
+smith
+smithereens
+Smithfield
+smiths
+Smithson
+Smithsonian
+Smithtown
+smithy
+smitten
+smock
+smocking
+smocks
+smog
+smokable
+smoke
+smoked
+smoker
+smokers
+smokes
+smokescreen
+smokestack
+smokies
+smoking
+smoky
+smolder
+smoldered
+smoldering
+smolders
+smooch
+smooth
+smoothbore
+smoothed
+smoother
+smoothes
+smoothest
+smoothing
+smoothly
+smoothness
+smote
+smother
+smothered
+smothering
+smothers
+Smucker
+smudge
+smug
+smuggle
+smuggled
+smuggler
+smugglers
+smuggles
+smuggling
+smut
+smutty
+Smyrna
+Smythe
+snack
+snafu
+snag
+snail
+snails
+snake
+snaked
+snakelike
+snakes
+snap
+snapdragon
+snapped
+snapper
+snappers
+snappily
+snapping
+snappy
+snaps
+snapshot
+snapshots
+snare
+snared
+snares
+snaring
+snark
+snarl
+snarled
+snarling
+snatch
+snatched
+snatches
+snatching
+snazzy
+Snead
+sneak
+sneaked
+sneaker
+sneakers
+sneakier
+sneakiest
+sneakily
+sneakiness
+sneaking
+sneaks
+sneaky
+Sneed
+sneer
+sneered
+sneering
+sneers
+sneeze
+sneezed
+sneezes
+sneezing
+Snider
+sniff
+sniffed
+sniffing
+sniffle
+sniffs
+snifter
+snigger
+snip
+snipe
+snippet
+snivel
+snob
+snobbery
+snobbish
+Snodgrass
+snoop
+snooped
+snooping
+snoops
+snoopy
+snore
+snored
+snores
+snoring
+snorkel
+snort
+snorted
+snorting
+snorts
+snotty
+snout
+snouts
+snow
+snowball
+Snowbelt
+snowed
+snowfall
+snowflake
+snowier
+snowiest
+snowily
+snowing
+snowman
+snowmen
+snows
+snowshoe
+snowshoes
+snowstorm
+snowy
+snub
+snuff
+snuffed
+snuffer
+snuffing
+snuffs
+snug
+snuggle
+snuggled
+snuggles
+snuggling
+snugly
+snugness
+Snyder
+so
+soak
+soaked
+soaking
+soaks
+soap
+soaped
+soaping
+soaps
+soapy
+soar
+soared
+soaring
+soars
+sob
+sobbing
+sober
+sobered
+sobering
+soberly
+soberness
+sobers
+sobriety
+sobs
+soccer
+sociability
+sociable
+sociably
+social
+socialism
+socialist
+socialists
+socialize
+socialized
+socializes
+socializing
+socially
+societal
+societies
+society
+socioeconomic
+sociological
+sociologically
+sociologist
+sociologists
+sociology
+sock
+socked
+socket
+sockets
+socking
+socks
+Socrates
+Socratic
+sod
+soda
+Soddy
+sodium
+sodomy
+sods
+sofa
+sofas
+Sofia
+soft
+softball
+soften
+softened
+softening
+softens
+softer
+softest
+softly
+softness
+software
+softwares
+soggy
+soil
+soiled
+soiling
+soils
+soiree
+sojourn
+sojourner
+sojourners
+Sol
+solace
+solaced
+solar
+sold
+solder
+soldered
+soldier
+soldiering
+soldierly
+soldiers
+sole
+solely
+solemn
+solemnity
+solemnly
+solemnness
+solenoid
+soles
+solicit
+solicitation
+solicited
+soliciting
+solicitor
+solicitous
+solicits
+solicitude
+solid
+solidarity
+solidification
+solidified
+solidifies
+solidify
+solidifying
+solidity
+solidly
+solidness
+solids
+soliloquy
+solitaire
+solitary
+solitude
+solitudes
+Solly
+solo
+Solomon
+Solon
+solos
+Soloviev
+solstice
+solubility
+soluble
+solution
+solutions
+solvable
+solve
+solved
+solvent
+solvents
+solver
+solvers
+solves
+solving
+Somali
+Somalia
+Somalis
+somatic
+somber
+somberly
+some
+somebody
+someday
+somehow
+someone
+someplace
+Somers
+somersault
+Somerset
+Somerville
+something
+sometime
+sometimes
+somewhat
+somewhere
+sommelier
+Sommerfeld
+somnolent
+son
+sonar
+sonata
+Sonenberg
+song
+songbook
+songs
+sonic
+sonnet
+sonnets
+sonny
+Sonoma
+Sonora
+sons
+Sony
+soon
+sooner
+soonest
+soot
+sooth
+soothe
+soothed
+soother
+soothes
+soothing
+soothsayer
+Sophia
+Sophias
+Sophie
+sophisticated
+sophistication
+sophistry
+Sophoclean
+Sophocles
+sophomore
+sophomores
+soprano
+sorcerer
+sorcerers
+sorcery
+sordid
+sordidly
+sordidness
+sore
+sorely
+soreness
+Sorensen
+Sorenson
+sorer
+sores
+sorest
+sorghum
+sorority
+sorrel
+Sorrentine
+sorrier
+sorriest
+sorrow
+sorrowful
+sorrowfully
+sorrows
+sorry
+sort
+sorted
+sorter
+sorters
+sortie
+sorting
+sorts
+sought
+soul
+soulful
+souls
+sound
+sounded
+sounder
+soundest
+sounding
+soundings
+soundly
+soundness
+soundproof
+sounds
+soup
+souped
+soups
+sour
+source
+sources
+sourdough
+soured
+sourer
+sourest
+souring
+sourly
+sourness
+sours
+Sousa
+south
+Southampton
+southbound
+southeast
+southeastern
+southern
+southerner
+southerners
+southernmost
+Southernwood
+Southey
+Southfield
+southland
+southpaw
+southward
+southwest
+southwestern
+souvenir
+sovereign
+sovereigns
+sovereignty
+soviet
+soviets
+sow
+sown
+soy
+soya
+soybean
+spa
+space
+spacecraft
+spaced
+spacer
+spacers
+spaces
+spaceship
+spaceships
+spacesuit
+Spacewar
+spacing
+spacings
+spacious
+spaded
+spades
+spading
+Spafford
+Spahn
+Spain
+Spalding
+span
+spandrel
+Spaniard
+Spaniardization
+Spaniardizations
+Spaniardize
+Spaniardizes
+Spaniards
+spaniel
+Spanish
+Spanishize
+Spanishizes
+spank
+spanked
+spanking
+spanks
+spanned
+spanner
+spanners
+spanning
+spans
+SPARC
+SPARCstation
+spare
+spared
+sparely
+spareness
+sparer
+spares
+sparest
+sparing
+sparingly
+spark
+sparked
+sparking
+sparkle
+sparkling
+Sparkman
+sparks
+sparring
+sparrow
+sparrows
+sparse
+sparsely
+sparseness
+sparser
+sparsest
+Sparta
+Spartan
+Spartanize
+Spartanizes
+spasm
+spastic
+spat
+spate
+spates
+spatial
+spatially
+spatter
+spattered
+spatula
+Spaulding
+spawn
+spawned
+spawning
+spawns
+spayed
+speak
+speakable
+speakeasy
+speaker
+Speakerphone
+Speakerphones
+speakers
+speaking
+speaks
+spear
+speared
+spearmint
+spears
+spec
+special
+specialist
+specialists
+specialization
+specializations
+specialize
+specialized
+specializes
+specializing
+specially
+specials
+specialties
+specialty
+specie
+species
+specifiable
+specific
+specifically
+specification
+specifications
+specificity
+specifics
+specified
+specifier
+specifiers
+specifies
+specify
+specifying
+specimen
+specimens
+specious
+speck
+speckle
+speckled
+speckles
+specks
+spectacle
+spectacled
+spectacles
+spectacular
+spectacularly
+spectator
+spectators
+specter
+specters
+Spector
+spectra
+spectral
+spectrogram
+spectrograms
+spectrograph
+spectrographic
+spectrography
+spectrometer
+spectrophotometer
+spectrophotometry
+spectroscope
+spectroscopic
+spectroscopy
+spectrum
+speculate
+speculated
+speculates
+speculating
+speculation
+speculations
+speculative
+speculator
+speculators
+sped
+speech
+speeches
+speechless
+speechlessness
+speed
+speedboat
+speeded
+speeder
+speeders
+speedily
+speeding
+speedometer
+speeds
+speedup
+speedups
+speedy
+spell
+spellbound
+spelled
+speller
+spellers
+spelling
+spellings
+spells
+Spencer
+Spencerian
+spend
+spender
+spenders
+spending
+spends
+Spenglerian
+spent
+sperm
+Sperry
+sphere
+spheres
+spherical
+spherically
+spheroid
+spheroidal
+sphinx
+Spica
+spice
+spiced
+spices
+spiciness
+spicy
+spider
+spiders
+spidery
+Spiegel
+spies
+spigot
+spike
+spiked
+spikes
+spill
+spilled
+spiller
+spilling
+spills
+spilt
+spin
+spinach
+spinal
+spinally
+spindle
+spindled
+spindling
+spine
+spinnaker
+spinner
+spinners
+spinning
+spinoff
+spins
+spinster
+spiny
+spiral
+spiraled
+spiraling
+spirally
+spire
+spires
+spirit
+spirited
+spiritedly
+spiriting
+spirits
+spiritual
+spiritually
+spirituals
+Spiro
+spit
+spite
+spited
+spiteful
+spitefully
+spitefulness
+spites
+spitfire
+spiting
+spits
+spitting
+spittle
+Spitz
+splash
+splashed
+splashes
+splashing
+splashy
+spleen
+splendid
+splendidly
+splendor
+splenetic
+splice
+spliced
+splicer
+splicers
+splices
+splicing
+splicings
+spline
+splines
+splint
+splinter
+splintered
+splinters
+splintery
+split
+splits
+splitter
+splitters
+splitting
+splurge
+spoil
+spoilage
+spoiled
+spoiler
+spoilers
+spoiling
+spoils
+Spokane
+spoke
+spoked
+spoken
+spokes
+spokesman
+spokesmen
+sponge
+sponged
+sponger
+spongers
+sponges
+sponging
+spongy
+sponsor
+sponsored
+sponsoring
+sponsors
+sponsorship
+spontaneity
+spontaneous
+spontaneously
+spoof
+spook
+spooky
+spool
+spooled
+spooler
+spoolers
+spooling
+spools
+spoon
+spooned
+spoonful
+spooning
+spoons
+sporadic
+spore
+spores
+sport
+sported
+sporting
+sportingly
+sportive
+sports
+sportsman
+sportsmen
+sportswear
+sportswriter
+sportswriting
+sporty
+Sposato
+spot
+spotless
+spotlessly
+spotlight
+spots
+spotted
+spotter
+spotters
+spotting
+spotty
+spouse
+spouses
+spout
+spouted
+spouting
+spouts
+Sprague
+sprain
+sprang
+sprawl
+sprawled
+sprawling
+sprawls
+spray
+sprayed
+sprayer
+spraying
+sprays
+spread
+spreader
+spreaders
+spreading
+spreadings
+spreads
+spreadsheet
+spree
+sprees
+sprig
+sprightly
+spring
+springboard
+springer
+springers
+Springfield
+springier
+springiest
+springiness
+springing
+springs
+springtime
+springy
+sprinkle
+sprinkled
+sprinkler
+sprinkles
+sprinkling
+sprint
+sprinted
+sprinter
+sprinters
+sprinting
+sprints
+sprite
+sprocket
+Sproul
+sprout
+sprouted
+sprouting
+spruce
+spruced
+sprung
+Spuds
+spun
+spunk
+spur
+spurious
+spurn
+spurned
+spurning
+spurns
+spurs
+spurt
+spurted
+spurting
+spurts
+sputter
+sputtered
+spy
+spyglass
+spying
+squabble
+squabbled
+squabbles
+squabbling
+squad
+squadron
+squadrons
+squads
+squalid
+squall
+squalls
+squander
+square
+squared
+squarely
+squareness
+squarer
+squares
+squarest
+Squaresville
+squaring
+squash
+squashed
+squashing
+squat
+squats
+squatting
+squaw
+squawk
+squawked
+squawking
+squawks
+squeak
+squeaked
+squeaking
+squeaks
+squeaky
+squeal
+squealed
+squealing
+squeals
+squeamish
+squeeze
+squeezed
+squeezer
+squeezes
+squeezing
+squelch
+Squibb
+squid
+squint
+squinted
+squinting
+squire
+squires
+squirm
+squirmed
+squirms
+squirmy
+squirrel
+squirreled
+squirreling
+squirrels
+squirt
+squishy
+Sri
+stab
+stabbed
+stabbing
+stabile
+stabilities
+stability
+stabilize
+stabilized
+stabilizer
+stabilizers
+stabilizes
+stabilizing
+stable
+stabled
+stabler
+stables
+stabling
+stably
+stabs
+stack
+stacked
+stacking
+stacks
+Stacy
+stadia
+stadium
+staff
+staffed
+staffer
+staffers
+staffing
+Stafford
+Staffordshire
+staffs
+stag
+stage
+stagecoach
+stagecoaches
+staged
+stager
+stagers
+stages
+stagger
+staggered
+staggering
+staggers
+staging
+stagnant
+stagnate
+stagnation
+stags
+Stahl
+staid
+stain
+stained
+staining
+stainless
+stains
+stair
+staircase
+staircases
+stairs
+stairway
+stairways
+stairwell
+stake
+staked
+stakes
+stalactite
+stale
+stalemate
+Staley
+Stalin
+Stalinist
+Stalins
+stalk
+stalked
+stalking
+stall
+stalled
+stalling
+stallings
+stallion
+stalls
+stalwart
+stalwartly
+stamen
+stamens
+Stamford
+stamina
+stammer
+stammered
+stammerer
+stammering
+stammers
+stamp
+stamped
+stampede
+stampeded
+stampedes
+stampeding
+stamper
+stampers
+stamping
+stamps
+Stan
+stanch
+stanchest
+stanchion
+stand
+standard
+standardization
+standardize
+standardized
+standardizes
+standardizing
+standardly
+standards
+standby
+standing
+standings
+Standish
+standoff
+standpoint
+standpoints
+stands
+standstill
+Stanford
+Stanhope
+Stanley
+Stans
+Stanton
+stanza
+stanzas
+staphylococcus
+staple
+stapler
+staples
+Stapleton
+stapling
+star
+starboard
+starch
+starched
+stardom
+stare
+stared
+starer
+stares
+starfish
+Stargate
+staring
+stark
+Starkey
+starkly
+starlet
+starlight
+starling
+Starr
+starred
+starring
+starry
+stars
+start
+started
+starter
+starters
+starting
+startle
+startled
+startles
+startling
+starts
+startup
+startups
+starvation
+starve
+starved
+starves
+starving
+state
+stated
+stately
+statement
+statements
+Staten
+states
+statesman
+statesmanlike
+statesmen
+statewide
+static
+statically
+stating
+station
+stationary
+stationed
+stationer
+stationery
+stationing
+stationmaster
+stations
+statistic
+statistical
+statistically
+statistician
+statisticians
+statistics
+Statler
+statue
+statues
+statuesque
+statuesquely
+statuesqueness
+statuette
+stature
+status
+statuses
+statute
+statutes
+statutorily
+statutoriness
+statutory
+Stauffer
+staunch
+staunchest
+staunchly
+Staunton
+stave
+staved
+staves
+stay
+stayed
+staying
+stays
+stead
+steadfast
+steadfastly
+steadfastness
+steadied
+steadier
+steadies
+steadiest
+steadily
+steadiness
+steady
+steadying
+steak
+steaks
+steal
+stealer
+stealing
+steals
+stealth
+stealthily
+stealthy
+steam
+steamboat
+steamboats
+steamed
+steamer
+steamers
+steaming
+steams
+steamship
+steamships
+steamy
+Stearns
+steed
+steel
+Steele
+steeled
+steelers
+steeling
+steelmaker
+steels
+steely
+Steen
+steep
+steeped
+steeper
+steepest
+steeping
+steeple
+steeples
+steeply
+steepness
+steeps
+steer
+steerable
+steered
+steering
+steers
+Stefan
+Stegosaurus
+Steinbeck
+Steinberg
+Steiner
+Stella
+stellar
+stem
+stemmed
+stemming
+stems
+stench
+stenches
+stencil
+stencils
+Stendhal
+Stendler
+stenographer
+stenographers
+stenotype
+step
+stepchild
+Stephan
+Stephanie
+Stephen
+Stephens
+Stephenson
+stepmother
+stepmothers
+stepped
+stepper
+stepping
+steps
+stepson
+stepwise
+stereo
+stereos
+stereoscopic
+stereotype
+stereotyped
+stereotypes
+stereotypical
+sterile
+sterilization
+sterilizations
+sterilize
+sterilized
+sterilizer
+sterilizes
+sterilizing
+sterling
+stern
+Sternberg
+sternly
+sternness
+Sterno
+sterns
+stethoscope
+Stetson
+Stetsons
+Steuben
+Steve
+stevedore
+Steven
+Stevens
+Stevenson
+Stevie
+stew
+steward
+stewardess
+stewards
+Stewart
+stewed
+stews
+stick
+sticker
+stickers
+stickier
+stickiest
+stickily
+stickiness
+sticking
+stickleback
+sticks
+sticky
+stiff
+stiffen
+stiffens
+stiffer
+stiffest
+stiffly
+stiffness
+stiffs
+stifle
+stifled
+stifles
+stifling
+stigma
+stigmata
+stile
+stiles
+stiletto
+still
+stillbirth
+stillborn
+stilled
+stiller
+stillest
+stilling
+stillness
+stills
+Stillwell
+stilt
+stilts
+Stimson
+stimulant
+stimulants
+stimulate
+stimulated
+stimulates
+stimulating
+stimulation
+stimulations
+stimulative
+stimuli
+stimulus
+sting
+stinging
+stings
+stingy
+stink
+stinker
+stinkers
+stinking
+stinks
+stint
+stipend
+stipends
+stipulate
+stipulated
+stipulates
+stipulating
+stipulation
+stipulations
+stir
+Stirling
+stirred
+stirrer
+stirrers
+stirring
+stirringly
+stirrings
+stirrup
+stirs
+stitch
+stitched
+stitches
+stitching
+stochastic
+stochastically
+stock
+stockade
+stockades
+stockbroker
+stocked
+stocker
+stockers
+stockholder
+stockholders
+Stockholm
+stocking
+stockings
+stockpile
+stockroom
+stocks
+Stockton
+stocky
+stodgy
+stoichiometry
+stoke
+Stokes
+stole
+stolen
+stoles
+stolid
+stomach
+stomached
+stomacher
+stomaches
+stomaching
+stomp
+Stone
+stoned
+Stonehenge
+stones
+stoning
+stony
+stood
+stooge
+stool
+stoop
+stooped
+stooping
+stoops
+stop
+stopcock
+stopcocks
+stopgap
+stopover
+stoppable
+stoppage
+stopped
+stopper
+stoppers
+stopping
+stops
+stopwatch
+storage
+storages
+store
+stored
+storehouse
+storehouses
+storekeeper
+storeroom
+stores
+Storey
+Storeyed
+Storeys
+storied
+stories
+storing
+stork
+storks
+storm
+stormed
+stormier
+stormiest
+storminess
+storming
+storms
+stormy
+story
+storyboard
+storyteller
+Stouffer
+stout
+stouter
+stoutest
+stoutly
+stoutness
+stove
+stoves
+stow
+Stowe
+stowed
+straddle
+strafe
+straggle
+straggled
+straggler
+stragglers
+straggles
+straggling
+straight
+straightaway
+straighten
+straightened
+straightens
+straighter
+straightest
+straightforward
+straightforwardly
+straightforwardness
+straightness
+straightway
+strain
+strained
+strainer
+strainers
+straining
+strains
+strait
+straiten
+straits
+strand
+stranded
+stranding
+strands
+strange
+strangely
+strangeness
+stranger
+strangers
+strangest
+strangle
+strangled
+strangler
+stranglers
+strangles
+strangling
+stranglings
+strangulation
+strangulations
+strap
+straps
+Strasbourg
+stratagem
+stratagems
+strategic
+strategies
+strategist
+strategy
+Stratford
+stratification
+stratifications
+stratified
+stratifies
+stratify
+stratosphere
+stratospheric
+Stratton
+stratum
+Strauss
+Stravinsky
+straw
+strawberries
+strawberry
+straws
+stray
+strayed
+strays
+streak
+streaked
+streaks
+stream
+streamed
+streamer
+streamers
+streaming
+streamline
+streamlined
+streamliner
+streamlines
+streamlining
+streams
+street
+streetcar
+streetcars
+streeters
+streets
+strength
+strengthen
+strengthened
+strengthener
+strengthening
+strengthens
+strengths
+strenuous
+strenuously
+streptococcus
+stress
+stressed
+stresses
+stressful
+stressing
+stretch
+stretched
+stretcher
+stretchers
+stretches
+stretching
+strew
+strewn
+strews
+stricken
+Strickland
+strict
+stricter
+strictest
+strictly
+strictness
+stricture
+stride
+strider
+strides
+striding
+strife
+strike
+strikebreaker
+striker
+strikers
+strikes
+striking
+strikingly
+Strindberg
+string
+stringed
+stringent
+stringently
+stringer
+stringers
+stringier
+stringiest
+stringiness
+stringing
+strings
+stringy
+strip
+stripe
+striped
+stripes
+stripped
+stripper
+strippers
+stripping
+strips
+striptease
+strive
+striven
+strives
+striving
+strivings
+strobe
+strobed
+strobes
+stroboscopic
+strode
+stroke
+stroked
+stroker
+strokers
+strokes
+stroking
+stroll
+strolled
+stroller
+strolling
+strolls
+Strom
+Stromberg
+strong
+stronger
+strongest
+Strongheart
+stronghold
+strongly
+strontium
+strove
+struck
+structural
+structurally
+structure
+structured
+structurer
+structures
+structuring
+struggle
+struggled
+struggles
+struggling
+strung
+strut
+struts
+strutting
+strychnine
+Stu
+Stuart
+stub
+stubble
+Stubblefield
+Stubblefields
+stubborn
+stubbornly
+stubbornness
+stubby
+stubs
+stucco
+stuck
+stud
+Studebaker
+student
+students
+studied
+studies
+studio
+studios
+studious
+studiously
+studs
+study
+studying
+stuff
+stuffed
+stuffier
+stuffiest
+stuffing
+stuffs
+stuffy
+stumble
+stumbled
+stumbles
+stumbling
+stump
+stumped
+stumping
+stumps
+stun
+stung
+stunning
+stunningly
+stunt
+stunts
+stupefy
+stupefying
+stupendous
+stupendously
+stupid
+stupidest
+stupidities
+stupidity
+stupidly
+stupor
+Sturbridge
+sturdiness
+sturdy
+sturgeon
+Sturm
+stutter
+Stuttgart
+Stuyvesant
+Stygian
+style
+styled
+styler
+stylers
+styles
+styli
+styling
+stylish
+stylishly
+stylishness
+stylistic
+stylistically
+stylized
+stylus
+Styrofoam
+Styx
+suave
+sub
+subatomic
+subchannel
+subchannels
+subclass
+subclasses
+subcommittees
+subcomponent
+subcomponents
+subcomputation
+subcomputations
+subconscious
+subconsciously
+subculture
+subcultures
+subcycle
+subcycles
+subdirectories
+subdirectory
+subdivide
+subdivided
+subdivides
+subdividing
+subdivision
+subdivisions
+subdomains
+subdue
+subdued
+subdues
+subduing
+subexpression
+subexpressions
+subfield
+subfields
+subfile
+subfiles
+subgoal
+subgoals
+subgraph
+subgraphs
+subgroup
+subgroups
+subinterval
+subintervals
+subject
+subjected
+subjecting
+subjection
+subjective
+subjectively
+subjectivity
+subjects
+sublanguage
+sublanguages
+sublayer
+sublayers
+sublimation
+sublimations
+sublime
+sublimed
+sublist
+sublists
+submarine
+submariner
+submariners
+submarines
+submerge
+submerged
+submerges
+submerging
+submission
+submissions
+submissive
+submit
+submits
+submittal
+submitted
+submitting
+submode
+submodes
+submodule
+submodules
+submultiplexed
+subnet
+subnets
+subnetwork
+subnetworks
+suboptimal
+subordinate
+subordinated
+subordinates
+subordination
+subparts
+subphases
+subpoena
+subproblem
+subproblems
+subprocesses
+subprogram
+subprograms
+subproject
+subproof
+subproofs
+subrange
+subranges
+subroutine
+subroutines
+subs
+subschema
+subschemas
+subscribe
+subscribed
+subscriber
+subscribers
+subscribes
+subscribing
+subscript
+subscripted
+subscripting
+subscription
+subscriptions
+subscripts
+subsection
+subsections
+subsegment
+subsegments
+subsequence
+subsequences
+subsequent
+subsequently
+subservient
+subset
+subsets
+subside
+subsided
+subsides
+subsidiaries
+subsidiary
+subsidies
+subsiding
+subsidize
+subsidized
+subsidizes
+subsidizing
+subsidy
+subsist
+subsisted
+subsistence
+subsistent
+subsisting
+subsists
+subslot
+subslots
+subspace
+subspaces
+substance
+substances
+substantial
+substantially
+substantiate
+substantiated
+substantiates
+substantiating
+substantiation
+substantiations
+substantive
+substantively
+substantivity
+substation
+substations
+substitutability
+substitutable
+substitute
+substituted
+substitutes
+substituting
+substitution
+substitutions
+substrate
+substrates
+substring
+substrings
+substructure
+substructures
+subsume
+subsumed
+subsumes
+subsuming
+subsystem
+subsystems
+subtask
+subtasks
+subterfuge
+subterranean
+subtitle
+subtitled
+subtitles
+subtle
+subtleness
+subtler
+subtlest
+subtleties
+subtlety
+subtly
+subtotal
+subtract
+subtracted
+subtracting
+subtraction
+subtractions
+subtractor
+subtractors
+subtracts
+subtrahend
+subtrahends
+subtree
+subtrees
+subunit
+subunits
+suburb
+suburban
+suburbia
+suburbs
+subversion
+subversive
+subvert
+subverted
+subverter
+subverting
+subverts
+subway
+subways
+succeed
+succeeded
+succeeding
+succeeds
+success
+successes
+successful
+successfully
+succession
+successions
+successive
+successively
+successor
+successors
+succinct
+succinctly
+succinctness
+succor
+succumb
+succumbed
+succumbing
+succumbs
+such
+suck
+sucked
+sucker
+suckers
+sucking
+suckle
+suckling
+sucks
+sucrose
+suction
+Sudan
+Sudanese
+Sudanic
+sudden
+suddenly
+suddenness
+suds
+sudsing
+sue
+sued
+sues
+Suez
+suffer
+sufferance
+suffered
+sufferer
+sufferers
+suffering
+sufferings
+suffers
+suffice
+sufficed
+suffices
+sufficiency
+sufficient
+sufficiently
+sufficing
+suffix
+suffixed
+suffixer
+suffixes
+suffixing
+suffocate
+suffocated
+suffocates
+suffocating
+suffocation
+Suffolk
+suffrage
+suffragette
+sugar
+sugared
+sugaring
+sugarings
+sugars
+suggest
+suggested
+suggestible
+suggesting
+suggestion
+suggestions
+suggestive
+suggestively
+suggests
+suicidal
+suicidally
+suicide
+suicides
+suing
+suit
+suitability
+suitable
+suitableness
+suitably
+suitcase
+suitcases
+suite
+suited
+suiters
+suites
+suiting
+suitor
+suitors
+suits
+Sukarno
+sulfa
+sulfur
+sulfuric
+sulfurous
+sulk
+sulked
+sulkiness
+sulking
+sulks
+sulky
+sullen
+sullenly
+sullenness
+Sullivan
+sulphate
+sulphur
+sulphured
+sulphuric
+sultan
+sultans
+sultry
+Sulzberger
+sum
+sumac
+Sumatra
+Sumeria
+Sumerian
+summand
+summands
+summaries
+summarily
+summarization
+summarizations
+summarize
+summarized
+summarizes
+summarizing
+summary
+summation
+summations
+summed
+Summer
+Summerdale
+Summers
+summertime
+summing
+summit
+summitry
+summon
+summoned
+summoner
+summoners
+summoning
+summons
+summonses
+Sumner
+sumptuous
+sums
+Sumter
+sun
+sunbeam
+sunbeams
+Sunbelt
+sunbonnet
+sunburn
+sunburnt
+Sunday
+Sundays
+sunder
+sundial
+sundown
+sundries
+sundry
+sunflower
+sung
+sunglass
+sunglasses
+sunk
+sunken
+sunlight
+sunlit
+sunned
+sunning
+sunny
+Sunnyvale
+sunrise
+suns
+sunset
+sunshine
+sunspot
+suntan
+suntanned
+suntanning
+super
+superb
+superblock
+superbly
+supercomputer
+supercomputers
+superego
+superegos
+superficial
+superficially
+superfluities
+superfluity
+superfluous
+superfluously
+supergroup
+supergroups
+superhuman
+superhumanly
+superimpose
+superimposed
+superimposes
+superimposing
+superintend
+superintendent
+superintendents
+superior
+superiority
+superiors
+superlative
+superlatively
+superlatives
+supermarket
+supermarkets
+supermini
+superminis
+supernatural
+superpose
+superposed
+superposes
+superposing
+superposition
+superscript
+superscripted
+superscripting
+superscripts
+supersede
+superseded
+supersedes
+superseding
+superset
+supersets
+superstition
+superstitions
+superstitious
+superuser
+supervise
+supervised
+supervises
+supervising
+supervision
+supervisor
+supervisors
+supervisory
+supine
+supper
+suppers
+supplant
+supplanted
+supplanting
+supplants
+supple
+supplement
+supplemental
+supplementary
+supplemented
+supplementing
+supplements
+suppleness
+supplication
+supplied
+supplier
+suppliers
+supplies
+supply
+supplying
+support
+supportable
+supported
+supporter
+supporters
+supporting
+supportingly
+supportive
+supportively
+supports
+suppose
+supposed
+supposedly
+supposes
+supposing
+supposition
+suppositions
+suppress
+suppressed
+suppresses
+suppressing
+suppression
+suppressor
+suppressors
+supranational
+supremacy
+supreme
+supremely
+surcharge
+sure
+surely
+sureness
+sureties
+surety
+surf
+surface
+surfaced
+surfaceness
+surfaces
+surfacing
+surge
+surged
+surgeon
+surgeons
+surgery
+surges
+surgical
+surgically
+surging
+surliness
+surly
+surmise
+surmised
+surmises
+surmount
+surmounted
+surmounting
+surmounts
+surname
+surnames
+surpass
+surpassed
+surpasses
+surpassing
+surplus
+surpluses
+surprise
+surprised
+surprises
+surprising
+surprisingly
+surreal
+surrender
+surrendered
+surrendering
+surrenders
+surreptitious
+surrey
+surrogate
+surrogates
+surround
+surrounded
+surrounding
+surroundings
+surrounds
+surtax
+survey
+surveyed
+surveying
+surveyor
+surveyors
+surveys
+survival
+survivals
+survive
+survived
+survives
+surviving
+survivor
+survivors
+Sus
+Susan
+Susanne
+susceptible
+Susie
+suspect
+suspected
+suspecting
+suspects
+suspend
+suspended
+suspender
+suspenders
+suspending
+suspends
+suspense
+suspenses
+suspension
+suspensions
+suspicion
+suspicions
+suspicious
+suspiciously
+Susquehanna
+Sussex
+sustain
+sustained
+sustaining
+sustains
+sustenance
+Sutherland
+Sutton
+suture
+sutures
+Suwanee
+Suzanne
+suzerainty
+Suzuki
+svelte
+Svetlana
+swab
+swabbing
+swagger
+swaggered
+swaggering
+Swahili
+swain
+swains
+swallow
+swallowed
+swallowing
+swallows
+swallowtail
+swam
+swami
+swamp
+swamped
+swamping
+swamps
+swampy
+swan
+swank
+swanky
+swanlike
+swans
+Swansea
+Swanson
+swap
+swapped
+swapping
+swaps
+swarm
+swarmed
+swarming
+swarms
+Swarthmore
+Swarthout
+swarthy
+Swartz
+swastika
+swat
+swatted
+sway
+swayed
+swaying
+Swaziland
+swear
+swearer
+swearing
+swears
+sweat
+sweated
+sweater
+sweaters
+sweating
+sweats
+sweatshirt
+sweaty
+Swede
+Sweden
+Swedes
+Swedish
+Sweeney
+Sweeneys
+sweep
+sweeper
+sweepers
+sweeping
+sweepings
+sweeps
+sweepstakes
+sweet
+sweeten
+sweetened
+sweetener
+sweeteners
+sweetening
+sweetenings
+sweetens
+sweeter
+sweetest
+sweetheart
+sweethearts
+sweetish
+sweetly
+sweetness
+sweets
+swell
+swelled
+swelling
+swellings
+swells
+swelter
+Swenson
+swept
+swerve
+swerved
+swerves
+swerving
+swift
+swifter
+swiftest
+swiftly
+swiftness
+swim
+swimmer
+swimmers
+swimming
+swimmingly
+swims
+swimsuit
+Swinburne
+swindle
+swine
+swing
+swinger
+swingers
+swinging
+swings
+Swink
+swipe
+swirl
+swirled
+swirling
+swish
+swished
+swiss
+switch
+switchblade
+switchboard
+switchboards
+switched
+switcher
+switchers
+switches
+switching
+switchings
+switchman
+Switzer
+Switzerland
+swivel
+swizzle
+swollen
+swoon
+swoop
+swooped
+swooping
+swoops
+sword
+swordfish
+swords
+swore
+sworn
+swum
+swung
+Sybil
+sycamore
+sycophant
+sycophantic
+Sydney
+Sykes
+syllable
+syllables
+syllogism
+syllogisms
+syllogistic
+Sylow
+sylvan
+Sylvania
+Sylvester
+Sylvia
+Sylvie
+symbiosis
+symbiotic
+symbol
+symbolic
+symbolically
+symbolics
+symbolism
+symbolization
+symbolize
+symbolized
+symbolizes
+symbolizing
+symbols
+Symington
+symmetric
+symmetrical
+symmetrically
+symmetries
+symmetry
+sympathetic
+sympathies
+sympathize
+sympathized
+sympathizer
+sympathizers
+sympathizes
+sympathizing
+sympathizingly
+sympathy
+symphonic
+symphonies
+symphony
+symposia
+symposium
+symposiums
+symptom
+symptomatic
+symptoms
+synagogue
+synapse
+synapses
+synaptic
+synchronism
+synchronization
+synchronize
+synchronized
+synchronizer
+synchronizers
+synchronizes
+synchronizing
+synchronous
+synchronously
+synchrony
+synchrotron
+syncopate
+syndicate
+syndicated
+syndicates
+syndication
+syndrome
+syndromes
+synergism
+synergistic
+synergy
+Synge
+synod
+synonym
+synonymous
+synonymously
+synonyms
+synopses
+synopsis
+syntactic
+syntactical
+syntactically
+syntax
+syntaxes
+synthesis
+synthesize
+synthesized
+synthesizer
+synthesizers
+synthesizes
+synthesizing
+synthetic
+synthetics
+Syracuse
+Syria
+Syrian
+Syrianize
+Syrianizes
+Syrians
+syringe
+syringes
+syrup
+syrupy
+system
+systematic
+systematically
+systematize
+systematized
+systematizes
+systematizing
+systemic
+systems
+systemwide
+Szilard
+tab
+tabernacle
+tabernacles
+table
+tableau
+tableaus
+tablecloth
+tablecloths
+tabled
+tables
+tablespoon
+tablespoonful
+tablespoonfuls
+tablespoons
+tablet
+tablets
+tabling
+taboo
+taboos
+tabs
+tabular
+tabulate
+tabulated
+tabulates
+tabulating
+tabulation
+tabulations
+tabulator
+tabulators
+tachometer
+tachometers
+tacit
+tacitly
+Tacitus
+tack
+tacked
+tacking
+tackle
+tackles
+Tacoma
+tact
+tactic
+tactics
+tactile
+Taft
+tag
+tagged
+tagging
+tags
+Tahiti
+Tahoe
+tail
+tailed
+tailing
+tailor
+tailored
+tailoring
+tailors
+tails
+taint
+tainted
+Taipei
+Taiwan
+Taiwanese
+take
+taken
+taker
+takers
+takes
+taking
+takings
+tale
+talent
+talented
+talents
+tales
+talk
+talkative
+talkatively
+talkativeness
+talked
+talker
+talkers
+talkie
+talking
+talks
+tall
+Talladega
+Tallahassee
+Tallahatchie
+Tallahoosa
+Tallchief
+taller
+tallest
+Talleyrand
+tallness
+tallow
+tally
+Talmud
+Talmudism
+Talmudization
+Talmudizations
+Talmudize
+Talmudizes
+tame
+tamed
+tamely
+tameness
+tamer
+tames
+Tamil
+taming
+Tammany
+Tammanyize
+Tammanyizes
+Tampa
+tamper
+tampered
+tampering
+tampers
+tan
+Tanaka
+Tananarive
+tandem
+tang
+Tanganyika
+tangent
+tangential
+tangents
+tangible
+tangibly
+tangle
+tangled
+tangy
+tank
+tanker
+tankers
+tanks
+Tannenbaum
+tanner
+tanners
+tantalizing
+tantalizingly
+Tantalus
+tantamount
+tantrum
+tantrums
+Tanya
+Tanzania
+Taoism
+Taoist
+Taos
+tap
+tape
+taped
+taper
+tapered
+tapering
+tapers
+tapes
+tapestries
+tapestry
+taping
+tapings
+tapped
+tapper
+tappers
+tapping
+taproot
+taproots
+taps
+tar
+Tara
+Tarbell
+tardiness
+tardy
+target
+targeted
+targeting
+targets
+tariff
+tariffs
+tarry
+Tarrytown
+tart
+Tartary
+tartly
+tartness
+Tartuffe
+Tarzan
+task
+tasked
+tasking
+tasks
+Tasmania
+Tass
+tassel
+tassels
+taste
+tasted
+tasteful
+tastefully
+tastefulness
+tasteless
+tastelessly
+taster
+tasters
+tastes
+tasting
+Tate
+tatter
+tattered
+tattoo
+tattooed
+tattoos
+tau
+taught
+taunt
+taunted
+taunter
+taunting
+taunts
+Taurus
+taut
+tautly
+tautness
+tautological
+tautologically
+tautologies
+tautology
+tavern
+taverns
+Tawney
+tawny
+tax
+taxable
+taxation
+taxed
+taxes
+taxi
+taxicab
+taxicabs
+taxied
+taxiing
+taxing
+taxis
+taxonomic
+taxonomically
+taxonomy
+taxpayer
+taxpayers
+Taylor
+Taylorize
+Taylorizes
+Taylors
+Tchaikovsky
+tea
+teach
+teachable
+teacher
+teachers
+teaches
+teaching
+teachings
+teacup
+team
+teamed
+teaming
+teams
+tear
+teared
+tearful
+tearfully
+tearing
+tears
+teas
+tease
+teased
+teases
+teasing
+teaspoon
+teaspoonful
+teaspoonfuls
+teaspoons
+technical
+technicalities
+technicality
+technically
+technician
+technicians
+Technion
+technique
+techniques
+technological
+technologically
+technologies
+technologist
+technologists
+technology
+Ted
+Teddy
+tedious
+tediously
+tediousness
+tedium
+teem
+teemed
+teeming
+teems
+teen
+teenage
+teenaged
+teenager
+teenagers
+teens
+teeth
+teethe
+teethed
+teethes
+teething
+Teflon
+Tegucigalpa
+Teheran
+Tehran
+Tektronix
+telecommunication
+telecommunications
+Teledyne
+Telefunken
+telegram
+telegrams
+telegraph
+telegraphed
+telegrapher
+telegraphers
+telegraphic
+telegraphing
+telegraphs
+Telemann
+telemetry
+teleological
+teleologically
+teleology
+telepathy
+telephone
+telephoned
+telephoner
+telephoners
+telephones
+telephonic
+telephoning
+telephony
+teleprocessing
+telescope
+telescoped
+telescopes
+telescoping
+Teletex
+Teletext
+teletype
+teletypes
+televise
+televised
+televises
+televising
+television
+televisions
+televisor
+televisors
+Telex
+tell
+teller
+tellers
+telling
+tells
+TELNET
+Telnet
+temper
+temperament
+temperamental
+temperaments
+temperance
+temperate
+temperately
+temperateness
+temperature
+temperatures
+tempered
+tempering
+tempers
+tempest
+tempestuous
+tempestuously
+template
+templates
+temple
+Templeman
+temples
+Templeton
+temporal
+temporally
+temporaries
+temporarily
+temporary
+tempt
+temptation
+temptations
+tempted
+tempter
+tempters
+tempting
+temptingly
+tempts
+ten
+tenacious
+tenaciously
+tenant
+tenants
+tend
+tended
+tendencies
+tendency
+tender
+tenderly
+tenderness
+tenders
+tending
+tends
+tenement
+tenements
+TENEX
+Tenex
+tenfold
+Tenneco
+Tennessee
+Tenney
+tennis
+Tennyson
+tenor
+tenors
+tens
+tense
+tensed
+tensely
+tenseness
+tenser
+tenses
+tensest
+tensing
+tension
+tensions
+tent
+tentacle
+tentacled
+tentacles
+tentative
+tentatively
+tented
+tenth
+tenting
+tents
+tenure
+Teresa
+term
+termed
+terminal
+terminally
+terminals
+terminate
+terminated
+terminates
+terminating
+termination
+terminations
+terminator
+terminators
+terming
+terminologies
+terminology
+terminus
+terms
+termwise
+ternary
+Terpsichore
+Terra
+terrace
+terraced
+terraces
+terrain
+terrains
+Terran
+Terre
+terrestrial
+terrestrials
+terrible
+terribly
+terrier
+terriers
+terrific
+terrified
+terrifies
+terrify
+terrifying
+territorial
+territories
+territory
+terror
+terrorism
+terrorist
+terroristic
+terrorists
+terrorize
+terrorized
+terrorizes
+terrorizing
+terrors
+tertiary
+Tess
+Tessie
+test
+testability
+testable
+testament
+testaments
+tested
+tester
+testers
+testicle
+testicles
+testified
+testifier
+testifiers
+testifies
+testify
+testifying
+testimonies
+testimony
+testing
+testings
+tests
+Teutonic
+TeX
+Tex
+Texaco
+Texan
+Texans
+Texas
+Texases
+text
+textbook
+textbooks
+textile
+textiles
+Textron
+texts
+textual
+textually
+texture
+textured
+textures
+Thai
+Thailand
+Thalia
+Thames
+than
+thank
+thanked
+thankful
+thankfully
+thankfulness
+thanking
+thankless
+thanklessly
+thanklessness
+thanks
+thanksgiving
+thanksgivings
+that
+thatch
+thatches
+thats
+thaw
+thawed
+thawing
+thaws
+Thayer
+the
+Thea
+theater
+theaters
+theatrical
+theatrically
+theatricals
+Thebes
+theft
+thefts
+their
+theirs
+Thelma
+them
+thematic
+theme
+themes
+themselves
+then
+thence
+thenceforth
+Theodore
+Theodosian
+Theodosius
+theological
+theology
+theorem
+theorems
+theoretic
+theoretical
+theoretically
+theoreticians
+theories
+theorist
+theorists
+theorization
+theorizations
+theorize
+theorized
+theorizer
+theorizers
+theorizes
+theorizing
+theory
+therapeutic
+therapies
+therapist
+therapists
+therapy
+there
+thereabouts
+thereafter
+thereby
+therefore
+therein
+thereof
+thereon
+Theresa
+thereto
+thereupon
+therewith
+thermal
+thermodynamic
+thermodynamics
+Thermofax
+thermometer
+thermometers
+thermosphere
+thermostat
+thermostats
+these
+theses
+Theseus
+thesis
+Thessalonian
+Thessaly
+Thetis
+they
+thick
+thicken
+thickens
+thicker
+thickest
+thicket
+thickets
+thickly
+thickness
+thief
+Thiensville
+thieve
+thieves
+thieving
+thigh
+thighs
+thimble
+thimbles
+Thimbu
+thin
+thing
+things
+think
+thinkable
+thinkably
+thinker
+thinkers
+thinking
+thinks
+thinly
+thinner
+thinness
+thinnest
+third
+thirdly
+thirds
+thirst
+thirsted
+thirsts
+thirsty
+thirteen
+thirteens
+thirteenth
+thirties
+thirtieth
+thirty
+this
+thistle
+Thomas
+Thomistic
+Thompson
+Thomson
+thong
+Thor
+Thoreau
+thorn
+Thornburg
+thorns
+Thornton
+thorny
+thorough
+thoroughfare
+thoroughfares
+thoroughly
+thoroughness
+Thorpe
+Thorstein
+those
+though
+thought
+thoughtful
+thoughtfully
+thoughtfulness
+thoughtless
+thoughtlessly
+thoughtlessness
+thoughts
+thousand
+thousands
+thousandth
+Thrace
+Thracian
+thrash
+thrashed
+thrasher
+thrashes
+thrashing
+thread
+threaded
+threader
+threaders
+threading
+threads
+threat
+threaten
+threatened
+threatening
+threatens
+threats
+three
+threefold
+threes
+threescore
+threshold
+thresholds
+threw
+thrice
+thrift
+thrifty
+thrill
+thrilled
+thriller
+thrillers
+thrilling
+thrillingly
+thrills
+thrive
+thrived
+thrives
+thriving
+throat
+throated
+throats
+throb
+throbbed
+throbbing
+throbs
+throne
+Throneberry
+thrones
+throng
+throngs
+throttle
+throttled
+throttles
+throttling
+through
+throughout
+throughput
+throw
+thrower
+throwing
+thrown
+throws
+thrush
+thrust
+thruster
+thrusters
+thrusting
+thrusts
+Thuban
+thud
+thuds
+thug
+thugs
+Thule
+thumb
+thumbed
+thumbing
+thumbs
+thump
+thumped
+thumping
+thunder
+thunderbolt
+thunderbolts
+thundered
+thunderer
+thunderers
+thundering
+thunders
+thunderstorm
+thunderstorms
+Thurber
+Thurman
+Thursday
+Thursdays
+thus
+thusly
+thwart
+thwarted
+thwarting
+thwarts
+thyself
+Tiber
+Tibet
+Tibetan
+Tiburon
+tick
+ticked
+ticker
+tickers
+ticket
+tickets
+ticking
+tickle
+tickled
+tickles
+tickling
+ticklish
+ticks
+Ticonderoga
+tidal
+tidally
+tide
+tided
+tides
+tidied
+tidiness
+tiding
+tidings
+tidy
+tidying
+tie
+Tieck
+tied
+Tientsin
+tier
+tiers
+ties
+Tiffany
+tiger
+tigers
+tight
+tighten
+tightened
+tightener
+tighteners
+tightening
+tightenings
+tightens
+tighter
+tightest
+tightly
+tightness
+Tigris
+Tijuana
+tilde
+tile
+tiled
+tiles
+tiling
+till
+tillable
+tilled
+tiller
+tillers
+Tillich
+Tillie
+tilling
+tills
+tilt
+tilted
+tilting
+tilts
+Tim
+timber
+timbered
+timbering
+timbers
+time
+timed
+timeless
+timelessly
+timelessness
+timely
+timeout
+timeouts
+timer
+timers
+times
+timeshare
+timeshares
+timesharing
+timestamp
+timestamps
+timetable
+timetables
+Timex
+timid
+timidity
+timidly
+timing
+timings
+Timmy
+Timon
+Timonize
+Timonizes
+Tims
+tin
+Tina
+tincture
+tinge
+tinged
+tingle
+tingled
+tingles
+tingling
+tinier
+tiniest
+tinily
+tininess
+tinker
+tinkered
+tinkering
+tinkers
+tinkle
+tinkled
+tinkles
+tinkling
+tinnier
+tinniest
+tinnily
+tinniness
+tinny
+tins
+Tinseltown
+tint
+tinted
+tinting
+tints
+tiny
+Tioga
+tip
+Tippecanoe
+tipped
+tipper
+Tipperary
+tippers
+tipping
+tips
+tiptoe
+Tirana
+tire
+tired
+tiredly
+tireless
+tirelessly
+tirelessness
+tires
+tiresome
+tiresomely
+tiresomeness
+tiring
+tissue
+tissues
+tit
+Titan
+tithe
+tither
+tithes
+tithing
+title
+titled
+titles
+Tito
+tits
+titter
+titters
+Titus
+to
+toad
+toads
+toast
+toasted
+toaster
+toasting
+toasts
+tobacco
+Tobago
+Toby
+today
+todays
+Todd
+toe
+toes
+together
+togetherness
+toggle
+toggled
+toggles
+toggling
+Togo
+toil
+toiled
+toiler
+toilet
+toilets
+toiling
+toils
+token
+tokens
+Tokyo
+Toland
+told
+Toledo
+tolerability
+tolerable
+tolerably
+tolerance
+tolerances
+tolerant
+tolerantly
+tolerate
+tolerated
+tolerates
+tolerating
+toleration
+toll
+tolled
+Tolley
+tolls
+Tolstoy
+Tom
+tomahawk
+tomahawks
+tomato
+tomatoes
+tomb
+Tombigbee
+tombs
+Tomlinson
+Tommie
+tomography
+tomorrow
+tomorrows
+Tompkins
+ton
+tone
+toned
+toner
+tones
+tongs
+tongue
+tongued
+tongues
+Toni
+tonic
+tonics
+tonight
+toning
+Tonio
+tonnage
+tons
+tonsil
+too
+took
+tool
+tooled
+tooler
+toolers
+tooling
+tools
+Toomey
+tooth
+toothbrush
+toothbrushes
+toothpaste
+toothpick
+toothpicks
+top
+Topeka
+toper
+topic
+topical
+topically
+topics
+topmost
+topography
+topological
+topologies
+topology
+topple
+toppled
+topples
+toppling
+tops
+Topsy
+Torah
+torch
+torches
+tore
+Tories
+torment
+tormented
+tormenter
+tormenters
+tormenting
+torn
+tornado
+tornadoes
+Toronto
+torpedo
+torpedoes
+torque
+Torquemada
+Torrance
+torrent
+torrents
+torrid
+tortoise
+tortoises
+torture
+tortured
+torturer
+torturers
+tortures
+torturing
+torus
+toruses
+Tory
+Toryize
+Toryizes
+Tosca
+Toscanini
+Toshiba
+toss
+tossed
+tosses
+tossing
+total
+totaled
+totaling
+totalities
+totality
+totalled
+totaller
+totallers
+totalling
+totally
+totals
+Toto
+totter
+tottered
+tottering
+totters
+touch
+touchable
+touched
+touches
+touchier
+touchiest
+touchily
+touchiness
+touching
+touchingly
+touchy
+tough
+toughen
+tougher
+toughest
+toughly
+toughness
+Toulouse
+tour
+toured
+touring
+tourist
+tourists
+tournament
+tournaments
+tours
+tow
+toward
+towards
+towed
+towel
+toweling
+towelled
+towelling
+towels
+tower
+towered
+towering
+towers
+town
+Townley
+towns
+Townsend
+township
+townships
+Towsley
+toy
+toyed
+toying
+Toynbee
+Toyota
+toys
+trace
+traceable
+traced
+tracer
+tracers
+traces
+tracing
+tracings
+track
+tracked
+tracker
+trackers
+tracking
+tracks
+tract
+tractability
+tractable
+Tractarians
+tractive
+tractor
+tractors
+tracts
+Tracy
+trade
+traded
+trademark
+trademarks
+tradeoff
+tradeoffs
+trader
+traders
+trades
+tradesman
+trading
+tradition
+traditional
+traditionally
+traditions
+traffic
+trafficked
+trafficker
+traffickers
+trafficking
+traffics
+tragedies
+tragedy
+tragic
+tragically
+trail
+trailed
+trailer
+trailers
+trailing
+trailings
+trails
+train
+trained
+trainee
+trainees
+trainer
+trainers
+training
+trains
+trait
+traitor
+traitors
+traits
+trajectories
+trajectory
+tramp
+tramped
+tramping
+trample
+trampled
+trampler
+tramples
+trampling
+tramps
+trance
+trances
+tranquil
+tranquility
+tranquilly
+transact
+transaction
+transactions
+transatlantic
+transceive
+transceiver
+transceivers
+transcend
+transcended
+transcendent
+transcending
+transcends
+transcontinental
+transcribe
+transcribed
+transcriber
+transcribers
+transcribes
+transcribing
+transcript
+transcription
+transcriptions
+transcripts
+transfer
+transferability
+transferable
+transferal
+transferals
+transference
+transferred
+transferrer
+transferrers
+transferring
+transfers
+transfinite
+transform
+transformable
+transformation
+transformational
+transformations
+transformed
+transformer
+transformers
+transforming
+transforms
+transgress
+transgressed
+transgression
+transgressions
+transience
+transiency
+transient
+transiently
+transients
+transistor
+transistorize
+transistorized
+transistorizing
+transistors
+transit
+Transite
+transition
+transitional
+transitioned
+transitions
+transitive
+transitively
+transitiveness
+transitivity
+transitory
+translatability
+translatable
+translate
+translated
+translates
+translating
+translation
+translational
+translations
+translator
+translators
+translucent
+transmission
+transmissions
+transmit
+transmits
+transmittal
+transmitted
+transmitter
+transmitters
+transmitting
+transmogrification
+transmogrify
+transpacific
+transparencies
+transparency
+transparent
+transparently
+transpire
+transpired
+transpires
+transpiring
+transplant
+transplanted
+transplanting
+transplants
+transponder
+transponders
+transport
+transportability
+transportation
+transported
+transporter
+transporters
+transporting
+transports
+transpose
+transposed
+transposes
+transposing
+transposition
+Transputer
+Transvaal
+Transylvania
+trap
+trapezoid
+trapezoidal
+trapezoids
+trapped
+trapper
+trappers
+trapping
+trappings
+traps
+trash
+Trastevere
+trauma
+traumatic
+travail
+travel
+traveled
+traveler
+travelers
+traveling
+travelings
+travels
+traversal
+traversals
+traverse
+traversed
+traverses
+traversing
+travesties
+travesty
+Travis
+tray
+trays
+treacheries
+treacherous
+treacherously
+treachery
+tread
+treading
+treads
+Treadwell
+treason
+treasure
+treasured
+treasurer
+treasures
+treasuries
+treasuring
+treasury
+treat
+treated
+treaties
+treating
+treatise
+treatises
+treatment
+treatments
+treats
+treaty
+treble
+tree
+trees
+treetop
+treetops
+trek
+treks
+tremble
+trembled
+trembles
+trembling
+tremendous
+tremendously
+tremor
+tremors
+trench
+trencher
+trenches
+trend
+trending
+trends
+Trenton
+trespass
+trespassed
+trespasser
+trespassers
+trespasses
+tress
+tresses
+Trevelyan
+trial
+trials
+triangle
+triangles
+triangular
+triangularly
+Triangulum
+Trianon
+Triassic
+tribal
+tribe
+tribes
+tribunal
+tribunals
+tribune
+tribunes
+tributary
+tribute
+tributes
+Triceratops
+Trichinella
+trichotomy
+trick
+tricked
+trickier
+trickiest
+trickiness
+tricking
+trickle
+trickled
+trickles
+trickling
+tricks
+tricky
+tried
+trier
+triers
+tries
+trifle
+trifler
+trifles
+trifling
+trigger
+triggered
+triggering
+triggers
+trigonometric
+trigonometry
+trigram
+trigrams
+trihedral
+trilateral
+trill
+trilled
+trillion
+trillions
+trillionth
+trim
+Trimble
+trimly
+trimmed
+trimmer
+trimmest
+trimming
+trimmings
+trimness
+trims
+Trinidad
+trinket
+trinkets
+trio
+trip
+triple
+tripled
+triples
+triplet
+triplets
+Triplett
+tripling
+tripod
+trips
+Tristan
+triumph
+triumphal
+triumphant
+triumphantly
+triumphed
+triumphing
+triumphs
+trivia
+trivial
+trivialities
+triviality
+trivially
+Trobriand
+trod
+Trojan
+troll
+trolley
+trolleys
+trolls
+troop
+trooper
+troopers
+troops
+Tropez
+trophies
+trophy
+tropic
+tropical
+tropics
+trot
+trots
+Trotsky
+trouble
+troubled
+troublemaker
+troublemakers
+troubles
+troubleshoot
+troubleshooter
+troubleshooters
+troubleshooting
+troubleshoots
+troublesome
+troublesomely
+troubling
+trough
+trouser
+trousers
+trout
+Troutman
+trowel
+trowels
+Troy
+truant
+truants
+truce
+truck
+trucked
+Truckee
+trucker
+truckers
+trucking
+trucks
+Trudeau
+trudge
+trudged
+Trudy
+true
+trued
+truer
+trues
+truest
+truing
+truism
+truisms
+Trujillo
+Truk
+truly
+Truman
+Trumbull
+trump
+trumped
+trumpet
+trumpeter
+trumps
+truncate
+truncated
+truncates
+truncating
+truncation
+truncations
+trunk
+trunks
+trust
+trusted
+trustee
+trustees
+trustful
+trustfully
+trustfulness
+trusting
+trustingly
+trusts
+trustworthiness
+trustworthy
+trusty
+truth
+truthful
+truthfully
+truthfulness
+truths
+try
+trying
+Tsunematsu
+tub
+tube
+tuber
+tuberculosis
+tubers
+tubes
+tubing
+tubs
+tuck
+tucked
+Tucker
+tucking
+tucks
+Tucson
+Tudor
+Tuesday
+Tuesdays
+tuft
+tufts
+tug
+tugs
+tuition
+Tulane
+tulip
+tulips
+Tulsa
+tumble
+tumbled
+tumbler
+tumblers
+tumbles
+tumbling
+tumor
+tumors
+tumult
+tumults
+tumultuous
+tunable
+tune
+tuned
+tuner
+tuners
+tunes
+tunic
+tunics
+tuning
+Tunis
+Tunisia
+Tunisian
+tunnel
+tunneled
+tunnels
+tuple
+tuples
+turban
+turbans
+turbulence
+turbulent
+turbulently
+turf
+turgid
+turgidly
+Turin
+Turing
+turkey
+turkeys
+Turkish
+Turkize
+Turkizes
+turmoil
+turmoils
+turn
+turnable
+turnaround
+turned
+turner
+turners
+turning
+turnings
+turnip
+turnips
+turnover
+turns
+turpentine
+turquoise
+turret
+turrets
+turtle
+turtleneck
+turtles
+Tuscaloosa
+Tuscan
+Tuscanize
+Tuscanizes
+Tuscany
+Tuscarora
+Tuskegee
+Tutankhamen
+Tutankhamon
+Tutankhamun
+Tutenkhamon
+tutor
+tutored
+tutorial
+tutorials
+tutoring
+tutors
+Tuttle
+twain
+twang
+twas
+tweed
+twelfth
+twelve
+twelves
+twenties
+twentieth
+twenty
+twice
+twig
+twigs
+twilight
+twilights
+twill
+twin
+twine
+twined
+twiner
+twinkle
+twinkled
+twinkler
+twinkles
+twinkling
+twins
+twirl
+twirled
+twirler
+twirling
+twirls
+twist
+twisted
+twister
+twisters
+twisting
+twists
+twitch
+twitched
+twitching
+twitter
+twittered
+twittering
+two
+twofold
+Twombly
+twos
+Tyburn
+tying
+Tyler
+Tylerize
+Tylerizes
+Tyndall
+type
+typed
+typeout
+types
+typesetter
+typewriter
+typewriters
+typhoid
+Typhon
+typical
+typically
+typicalness
+typified
+typifies
+typify
+typifying
+typing
+typist
+typists
+typo
+typographic
+typographical
+typographically
+typography
+tyrannical
+Tyrannosaurus
+tyranny
+tyrant
+tyrants
+Tyson
+Tzeltal
+ubiquitous
+ubiquitously
+ubiquity
+Udall
+Uganda
+ugh
+uglier
+ugliest
+ugliness
+ugly
+Ukraine
+Ukrainian
+Ukrainians
+Ulan
+ulcer
+ulcers
+Ullman
+Ulster
+ultimate
+ultimately
+ultra
+ultrasonic
+ULTRIX
+Ultrix
+Ulysses
+umbrage
+umbrella
+umbrellas
+umpire
+umpires
+unabated
+unabbreviated
+unable
+unacceptability
+unacceptable
+unacceptably
+unaccountable
+unaccustomed
+unachievable
+unacknowledged
+unadulterated
+unaesthetically
+unaffected
+unaffectedly
+unaffectedness
+unaided
+unalienability
+unalienable
+unalterably
+unaltered
+unambiguous
+unambiguously
+unambitious
+unanalyzable
+unanimity
+unanimous
+unanimously
+unanswerable
+unanswered
+unanticipated
+unarmed
+unary
+unassailable
+unassigned
+unassisted
+unattainability
+unattainable
+unattended
+unattractive
+unattractively
+unauthorized
+unavailability
+unavailable
+unavoidable
+unavoidably
+unaware
+unawareness
+unawares
+unbalanced
+unbearable
+unbecoming
+unbelievable
+unbiased
+unbind
+unblock
+unblocked
+unblocking
+unblocks
+unborn
+unbound
+unbounded
+unbreakable
+unbridled
+unbroken
+unbuffered
+uncancelled
+uncanny
+uncapitalized
+uncaught
+uncertain
+uncertainly
+uncertainties
+uncertainty
+unchangeable
+unchanged
+unchanging
+unclaimed
+unclassified
+uncle
+unclean
+uncleanly
+uncleanness
+unclear
+uncleared
+uncles
+unclosed
+uncomfortable
+uncomfortably
+uncommitted
+uncommon
+uncommonly
+uncompromising
+uncomputable
+unconcerned
+unconcernedly
+unconditional
+unconditionally
+unconnected
+unconscionable
+unconscious
+unconsciously
+unconsciousness
+unconstitutional
+unconstrained
+uncontrollability
+uncontrollable
+uncontrollably
+uncontrolled
+unconventional
+unconventionally
+unconvinced
+unconvincing
+uncoordinated
+uncorrectable
+uncorrected
+uncountable
+uncountably
+uncouth
+uncover
+uncovered
+uncovering
+uncovers
+undamaged
+undaunted
+undauntedly
+undecidable
+undecided
+undeclared
+undecomposable
+undefinability
+undefined
+undeleted
+undeniable
+undeniably
+under
+underbrush
+underdone
+underestimate
+underestimated
+underestimates
+underestimating
+underestimation
+underflow
+underflowed
+underflowing
+underflows
+underfoot
+undergo
+undergoes
+undergoing
+undergone
+undergraduate
+undergraduates
+underground
+underlie
+underlies
+underline
+underlined
+underlines
+underling
+underlings
+underlining
+underlinings
+underloaded
+underlying
+undermine
+undermined
+undermines
+undermining
+underneath
+underpinning
+underpinnings
+underplay
+underplayed
+underplaying
+underplays
+underscore
+underscored
+underscores
+understand
+understandability
+understandable
+understandably
+understanding
+understandingly
+understandings
+understands
+understated
+understood
+undertake
+undertaken
+undertaker
+undertakers
+undertakes
+undertaking
+undertakings
+undertook
+underwater
+underway
+underwear
+underwent
+underworld
+underwrite
+underwriter
+underwriters
+underwrites
+underwriting
+undesirability
+undesirable
+undetectable
+undetected
+undetermined
+undeveloped
+undid
+undiminished
+undirected
+undisciplined
+undiscovered
+undisturbed
+undivided
+undo
+undocumented
+undoes
+undoing
+undoings
+undone
+undoubtedly
+undress
+undressed
+undresses
+undressing
+undue
+unduly
+uneasily
+uneasiness
+uneasy
+uneconomic
+uneconomical
+unembellished
+unemployed
+unemployment
+unencrypted
+unending
+unenlightening
+unequal
+unequaled
+unequally
+unequivocal
+unequivocally
+UNESCO
+unessential
+unevaluated
+uneven
+unevenly
+unevenness
+uneventful
+unexcused
+unexpanded
+unexpected
+unexpectedly
+unexplained
+unexplored
+unextended
+unfair
+unfairly
+unfairness
+unfaithful
+unfaithfully
+unfaithfulness
+unfamiliar
+unfamiliarity
+unfamiliarly
+unfavorable
+unfettered
+unfinished
+unfit
+unfitness
+unflagging
+unfold
+unfolded
+unfolding
+unfolds
+unforeseen
+unforgeable
+unforgiving
+unformatted
+unfortunate
+unfortunately
+unfortunates
+unfounded
+unfriendliness
+unfriendly
+unfulfilled
+ungrammatical
+ungrateful
+ungratefully
+ungratefulness
+ungrounded
+unguarded
+unguided
+unhappier
+unhappiest
+unhappily
+unhappiness
+unhappy
+unharmed
+unhealthy
+unheard
+unheeded
+Unibus
+unicorn
+unicorns
+unicycle
+unidentified
+unidirectional
+unidirectionality
+unidirectionally
+unification
+unifications
+unified
+unifier
+unifiers
+unifies
+uniform
+uniformed
+uniformity
+uniformly
+uniforms
+unify
+unifying
+unilluminating
+unimaginable
+unimpeded
+unimplemented
+unimportant
+unindented
+uninitialized
+uninsulated
+unintelligible
+unintended
+unintentional
+unintentionally
+uninteresting
+uninterestingly
+uninterpreted
+uninterrupted
+uninterruptedly
+union
+unionization
+unionize
+unionized
+unionizer
+unionizers
+unionizes
+unionizing
+unions
+UniPlus
+uniprocessor
+unique
+uniquely
+uniqueness
+Uniroyal
+UniSoft
+unison
+unit
+Unitarian
+Unitarianize
+Unitarianizes
+Unitarians
+unite
+united
+unites
+unities
+uniting
+units
+unity
+Univac
+univalve
+univalves
+universal
+universality
+universally
+universals
+universe
+universes
+universities
+university
+UNIX
+Unix
+unjust
+unjustifiable
+unjustified
+unjustly
+unkind
+unkindly
+unkindness
+unknowable
+unknowing
+unknowingly
+unknown
+unknowns
+unlabelled
+unlawful
+unlawfully
+unleash
+unleashed
+unleashes
+unleashing
+unless
+unlike
+unlikely
+unlikeness
+unlimited
+unlink
+unlinked
+unlinking
+unlinks
+unload
+unloaded
+unloading
+unloads
+unlock
+unlocked
+unlocking
+unlocks
+unlucky
+unmanageable
+unmanageably
+unmanned
+unmarked
+unmarried
+unmask
+unmasked
+unmatched
+unmentionable
+unmerciful
+unmercifully
+unmistakable
+unmistakably
+unmodified
+unmoved
+unnamed
+unnatural
+unnaturally
+unnaturalness
+unnecessarily
+unnecessary
+unneeded
+unnerve
+unnerved
+unnerves
+unnerving
+unnoticed
+unobservable
+unobserved
+unobtainable
+unoccupied
+unofficial
+unofficially
+unopened
+unordered
+unpack
+unpacked
+unpacking
+unpacks
+unpaid
+unparalleled
+unparsed
+unplanned
+unpleasant
+unpleasantly
+unpleasantness
+unplug
+unpopular
+unpopularity
+unprecedented
+unpredictable
+unpredictably
+unprescribed
+unpreserved
+unprimed
+unprofitable
+unprojected
+unprotected
+unprovability
+unprovable
+unproven
+unpublished
+unqualified
+unqualifiedly
+unquestionably
+unquestioned
+unquoted
+unravel
+unraveled
+unraveling
+unravels
+unreachable
+unreal
+unrealistic
+unrealistically
+unreasonable
+unreasonableness
+unreasonably
+unrecognizable
+unrecognized
+unregulated
+unrelated
+unreliability
+unreliable
+unreported
+unrepresentable
+unresolved
+unresponsive
+unrest
+unrestrained
+unrestricted
+unrestrictedly
+unrestrictive
+unroll
+unrolled
+unrolling
+unrolls
+unruly
+unsafe
+unsafely
+unsanitary
+unsatisfactory
+unsatisfiability
+unsatisfiable
+unsatisfied
+unsatisfying
+unscrupulous
+unseeded
+unseen
+unselected
+unselfish
+unselfishly
+unselfishness
+unsent
+unsettled
+unsettling
+unshaken
+unshared
+unsigned
+unskilled
+unslotted
+unsolvable
+unsolved
+unsophisticated
+unsound
+unspeakable
+unspecified
+unstable
+unsteadiness
+unsteady
+unstructured
+unsuccessful
+unsuccessfully
+unsuitable
+unsuited
+unsupported
+unsure
+unsurprising
+unsurprisingly
+unsynchronized
+untagged
+untapped
+untenable
+unterminated
+untested
+unthinkable
+unthinking
+untidiness
+untidy
+untie
+untied
+unties
+until
+untimely
+unto
+untold
+untouchable
+untouchables
+untouched
+untoward
+untrained
+untranslated
+untreated
+untried
+untrue
+untruthful
+untruthfulness
+untying
+unusable
+unused
+unusual
+unusually
+unvarying
+unveil
+unveiled
+unveiling
+unveils
+unwanted
+unwelcome
+unwholesome
+unwieldiness
+unwieldy
+unwilling
+unwillingly
+unwillingness
+unwind
+unwinder
+unwinders
+unwinding
+unwinds
+unwise
+unwisely
+unwiser
+unwisest
+unwitting
+unwittingly
+unworthiness
+unworthy
+unwound
+unwrap
+unwrapped
+unwrapping
+unwraps
+unwritten
+up
+upbraid
+upcoming
+update
+updated
+updater
+updates
+updating
+upgrade
+upgraded
+upgrades
+upgrading
+upheld
+uphill
+uphold
+upholder
+upholders
+upholding
+upholds
+upholster
+upholstered
+upholsterer
+upholstering
+upholsters
+upkeep
+upland
+uplands
+uplift
+uplink
+uplinks
+upload
+upon
+upper
+uppermost
+upright
+uprightly
+uprightness
+uprising
+uprisings
+uproar
+uproot
+uprooted
+uprooting
+uproots
+upset
+upsets
+upshot
+upshots
+upside
+upstairs
+upstream
+Upton
+upturn
+upturned
+upturning
+upturns
+upward
+upwards
+Urania
+Uranus
+urban
+Urbana
+urchin
+urchins
+Urdu
+urge
+urged
+urgent
+urgently
+urges
+urging
+urgings
+Uri
+urinate
+urinated
+urinates
+urinating
+urination
+urine
+Uris
+urn
+urns
+Urquhart
+Ursa
+Ursula
+Ursuline
+Uruguay
+Uruguay'a
+Uruguayan
+Uruguayans
+us
+usability
+usable
+usably
+usage
+usages
+use
+used
+useful
+usefully
+usefulness
+useless
+uselessly
+uselessness
+Usenet
+Usenix
+user
+users
+uses
+usher
+ushered
+ushering
+ushers
+using
+usual
+usually
+usurp
+usurped
+usurper
+Utah
+utensil
+utensils
+Utica
+utilities
+utility
+utilization
+utilizations
+utilize
+utilized
+utilizes
+utilizing
+utmost
+utopia
+utopian
+Utopianize
+Utopianizes
+utopians
+Utrecht
+utter
+utterance
+utterances
+uttered
+uttering
+utterly
+uttermost
+utters
+Uzi
+vacancies
+vacancy
+vacant
+vacantly
+vacate
+vacated
+vacates
+vacating
+vacation
+vacationed
+vacationer
+vacationers
+vacationing
+vacations
+vacuo
+vacuous
+vacuously
+vacuum
+vacuumed
+vacuuming
+Vaduz
+vagabond
+vagabonds
+vagaries
+vagary
+vagina
+vaginas
+vagrant
+vagrantly
+vague
+vaguely
+vagueness
+vaguer
+vaguest
+Vail
+vain
+vainly
+vale
+valence
+valences
+valentine
+valentines
+Valerie
+Valery
+vales
+valet
+valets
+Valhalla
+valiant
+valiantly
+valid
+validate
+validated
+validates
+validating
+validation
+validity
+validly
+validness
+Valkyrie
+Valletta
+valley
+valleys
+Valois
+valor
+Valparaiso
+valuable
+valuables
+valuably
+valuation
+valuations
+value
+valued
+valuer
+valuers
+values
+valuing
+valve
+valves
+vampire
+van
+Vance
+Vancement
+Vancouver
+vandalize
+vandalized
+vandalizes
+vandalizing
+Vandenberg
+Vanderbilt
+Vanderburgh
+Vanderpoel
+vane
+vanes
+Vanessa
+vanguard
+vanilla
+vanish
+vanished
+vanisher
+vanishes
+vanishing
+vanishingly
+vanities
+vanity
+vanquish
+vanquished
+vanquishes
+vanquishing
+vans
+vantage
+vapor
+vaporing
+vapors
+variability
+variable
+variableness
+variables
+variably
+Varian
+variance
+variances
+variant
+variantly
+variants
+variation
+variations
+varied
+varies
+varieties
+variety
+various
+variously
+Varitype
+Varityping
+varnish
+varnishes
+vary
+varying
+varyings
+vase
+vases
+Vasquez
+vassal
+Vassar
+vast
+vaster
+vastest
+vastly
+vastness
+vat
+Vatican
+Vaticanization
+Vaticanizations
+Vaticanize
+Vaticanizes
+vats
+vaudeville
+Vaudois
+Vaughan
+Vaughn
+vault
+vaulted
+vaulter
+vaulting
+vaults
+vaunt
+vaunted
+VAX
+VAXes
+veal
+vector
+vectorization
+vectorizing
+vectors
+Veda
+veer
+veered
+veering
+veers
+Vega
+Veganism
+Vegas
+vegetable
+vegetables
+vegetarian
+vegetarians
+vegetate
+vegetated
+vegetates
+vegetating
+vegetation
+vegetative
+vehemence
+vehement
+vehemently
+vehicle
+vehicles
+vehicular
+veil
+veiled
+veiling
+veils
+vein
+veined
+veining
+veins
+Vela
+Velasquez
+Vella
+Velociraptor
+velocities
+velocity
+velvet
+vendor
+vendors
+venerable
+veneration
+Venetian
+Veneto
+Venezuela
+Venezuelan
+vengeance
+venial
+Venice
+venison
+Venn
+venom
+venomous
+venomously
+vent
+vented
+ventilate
+ventilated
+ventilates
+ventilating
+ventilation
+ventricle
+ventricles
+vents
+Ventura
+venture
+ventured
+venturer
+venturers
+ventures
+venturing
+venturings
+Venus
+Venusian
+Venusians
+Vera
+veracity
+veranda
+verandas
+verb
+verbal
+verbalize
+verbalized
+verbalizes
+verbalizing
+verbally
+verbose
+verbs
+Verde
+Verderer
+Verdi
+verdict
+verdure
+verge
+verger
+verges
+Vergil
+verifiability
+verifiable
+verification
+verifications
+verified
+verifier
+verifiers
+verifies
+verify
+verifying
+verily
+veritable
+Verlag
+vermin
+Vermont
+Vern
+Verna
+vernacular
+Verne
+Vernon
+Verona
+Veronica
+versa
+Versailles
+Versatec
+versatile
+versatility
+verse
+versed
+verses
+versing
+version
+versions
+versus
+vertebrate
+vertebrates
+vertex
+vertical
+vertically
+verticalness
+vertices
+very
+vessel
+vessels
+vest
+vested
+vestige
+vestiges
+vestigial
+vests
+Vesuvius
+veteran
+veterans
+veterinarian
+veterinarians
+veterinary
+veto
+vetoed
+vetoer
+vetoes
+vex
+vexation
+vexed
+vexes
+vexing
+via
+viability
+viable
+viably
+vial
+vials
+vibrate
+vibrated
+vibrating
+vibration
+vibrations
+vibrator
+Vic
+vice
+viceroy
+vices
+Vichy
+vicinity
+vicious
+viciously
+viciousness
+vicissitude
+vicissitudes
+Vickers
+Vicksburg
+Vicky
+victim
+victimize
+victimized
+victimizer
+victimizers
+victimizes
+victimizing
+victims
+victor
+Victoria
+Victorian
+Victorianize
+Victorianizes
+Victorians
+victories
+victorious
+victoriously
+victors
+victory
+Victrola
+victual
+victualer
+victuals
+Vida
+Vidal
+video
+videotape
+videotapes
+Videotex
+vie
+vied
+Vienna
+Viennese
+Vientiane
+vier
+vies
+Viet
+Vietnam
+Vietnamese
+view
+viewable
+viewed
+viewer
+viewers
+viewing
+viewpoint
+viewpoints
+views
+vigilance
+vigilant
+vigilante
+vigilantes
+vigilantly
+vignette
+vignettes
+vigor
+vigorous
+vigorously
+Viking
+Vikings
+Vikram
+vile
+vilely
+vileness
+vilification
+vilifications
+vilified
+vilifies
+vilify
+vilifying
+villa
+village
+villager
+villagers
+villages
+villain
+villainous
+villainously
+villainousness
+villains
+villainy
+villas
+Vince
+Vincent
+Vinci
+vindicate
+vindicated
+vindication
+vindictive
+vindictively
+vindictiveness
+vine
+vinegar
+vines
+vineyard
+vineyards
+Vinson
+vintage
+violate
+violated
+violates
+violating
+violation
+violations
+violator
+violators
+violence
+violent
+violently
+violet
+violets
+violin
+violinist
+violinists
+violins
+viper
+vipers
+Virgil
+virgin
+Virginia
+Virginian
+Virginians
+virginity
+virgins
+Virgo
+virtual
+virtually
+virtue
+virtues
+virtuoso
+virtuosos
+virtuous
+virtuously
+virulent
+virus
+viruses
+visa
+visage
+visas
+viscount
+viscounts
+viscous
+Vishnu
+visibility
+visible
+visibly
+Visigoth
+Visigoths
+vision
+visionary
+visions
+visit
+visitation
+visitations
+visited
+visiting
+visitor
+visitors
+visits
+visor
+visors
+vista
+vistas
+visual
+visualize
+visualized
+visualizer
+visualizes
+visualizing
+visually
+vita
+vitae
+vital
+vitality
+vitally
+vitals
+Vito
+Vitus
+Vivaldi
+Vivian
+vivid
+vividly
+vividness
+vizier
+Vladimir
+Vladivostok
+vocabularies
+vocabulary
+vocal
+vocally
+vocals
+vocation
+vocational
+vocationally
+vocations
+Vogel
+vogue
+voice
+voiced
+voicer
+voicers
+voices
+voicing
+void
+voided
+voider
+voiding
+voids
+volatile
+volatilities
+volatility
+volcanic
+volcano
+volcanos
+volition
+Volkswagen
+Volkswagens
+volley
+volleyball
+volleyballs
+Volstead
+volt
+Volta
+voltage
+voltages
+Voltaire
+Volterra
+volts
+volume
+volumes
+voluntarily
+voluntary
+volunteer
+volunteered
+volunteering
+volunteers
+Volvo
+vomit
+vomited
+vomiting
+vomits
+vortex
+Voss
+vote
+voted
+voter
+voters
+votes
+voting
+votive
+vouch
+voucher
+vouchers
+vouches
+vouching
+Vought
+vow
+vowed
+vowel
+vowels
+vower
+vowing
+vows
+voyage
+voyaged
+voyager
+voyagers
+voyages
+voyaging
+voyagings
+Vreeland
+Vulcan
+Vulcanism
+vulgar
+vulgarly
+vulnerabilities
+vulnerability
+vulnerable
+vulture
+vultures
+Waals
+Wabash
+Wacke
+wacky
+Waco
+wade
+waded
+wader
+wades
+wading
+Wadsworth
+wafer
+wafers
+waffle
+waffles
+waft
+wag
+wage
+waged
+wager
+wagers
+wages
+waging
+Wagner
+Wagnerian
+Wagnerize
+Wagnerizes
+wagon
+wagoner
+wagons
+wags
+Wahl
+wail
+wailed
+wailing
+wails
+Wainwright
+waist
+waistcoat
+waistcoats
+waists
+wait
+Waite
+waited
+waiter
+waiters
+waiting
+waitress
+waitresses
+waits
+waive
+waived
+waiver
+waiverable
+waives
+waiving
+wake
+waked
+Wakefield
+waken
+wakened
+wakening
+wakes
+wakeup
+waking
+Walbridge
+Walcott
+Walden
+Waldensian
+Waldo
+Waldorf
+Waldron
+wales
+Walford
+Walgreen
+walk
+walked
+walker
+walkers
+walking
+walks
+wall
+Wallace
+walled
+Wallenstein
+Waller
+wallet
+wallets
+walling
+Wallis
+wallow
+wallowed
+wallowing
+wallows
+Walls
+walnut
+walnuts
+Walpole
+walrus
+walruses
+Walsh
+Walt
+Walter
+Walters
+Waltham
+Walton
+waltz
+waltzed
+waltzes
+waltzing
+Walworth
+wan
+wand
+wander
+wandered
+wanderer
+wanderers
+wandering
+wanderings
+wanders
+wane
+waned
+wanes
+Wang
+waning
+wanly
+Wansee
+Wansley
+want
+wanted
+wanting
+wanton
+wantonly
+wantonness
+wants
+Wapato
+Wappinger
+war
+warble
+warbled
+warbler
+warbles
+warbling
+Warburton
+ward
+warden
+wardens
+warder
+wardrobe
+wardrobes
+wards
+ware
+warehouse
+warehouses
+warehousing
+wares
+warfare
+Warfield
+warily
+wariness
+Waring
+warlike
+warm
+warmed
+warmer
+warmers
+warmest
+warming
+warmly
+warms
+warmth
+warn
+warned
+warner
+warning
+warningly
+warnings
+Warnock
+warns
+warp
+warped
+warping
+warps
+warrant
+warranted
+warranties
+warranting
+warrants
+warranty
+warred
+warring
+warrior
+warriors
+wars
+Warsaw
+warship
+warships
+wart
+wartime
+warts
+Warwick
+wary
+was
+wash
+Washburn
+washed
+washer
+washers
+washes
+washing
+washings
+Washington
+Washoe
+wasp
+wasps
+Wasserman
+waste
+wasted
+wasteful
+wastefully
+wastefulness
+wastes
+wasting
+Watanabe
+watch
+watched
+watcher
+watchers
+watches
+watchful
+watchfully
+watchfulness
+watching
+watchings
+watchman
+watchword
+watchwords
+water
+Waterbury
+watered
+waterfall
+waterfalls
+Watergate
+Waterhouse
+watering
+waterings
+Waterloo
+Waterman
+waterproof
+waterproofing
+Waters
+Watertown
+waterway
+waterways
+watery
+Watkins
+Watson
+Wattenberg
+Watterson
+Watts
+Waukesha
+Waunona
+Waupaca
+Waupun
+Wausau
+Wauwatosa
+wave
+waved
+waveform
+waveforms
+wavefront
+wavefronts
+waveguides
+Waveland
+wavelength
+wavelengths
+waver
+wavers
+waves
+waving
+wax
+waxed
+waxen
+waxer
+waxers
+waxes
+waxing
+waxy
+way
+Wayne
+Waynesboro
+ways
+wayside
+wayward
+we
+weak
+weaken
+weakened
+weakening
+weakens
+weaker
+weakest
+weakly
+weakness
+weaknesses
+wealth
+wealthiest
+wealths
+wealthy
+wean
+weaned
+weaning
+weapon
+weapons
+wear
+wearable
+wearer
+wearied
+wearier
+weariest
+wearily
+weariness
+wearing
+wearisome
+wearisomely
+wears
+weary
+wearying
+weasel
+weasels
+weather
+weathercock
+weathercocks
+weathered
+Weatherford
+weathering
+weathers
+weave
+weaver
+weaves
+weaving
+web
+Webb
+Webber
+webs
+Webster
+Websterville
+wedded
+wedding
+weddings
+wedge
+wedged
+wedges
+wedging
+wedlock
+Wednesday
+Wednesdays
+weds
+wee
+weed
+weeds
+week
+weekend
+weekends
+weekly
+Weeks
+weep
+weeper
+weeping
+weeps
+Wehr
+Wei
+Weibull
+Weider
+Weidman
+Weierstrass
+weigh
+weighed
+weighing
+weighings
+weighs
+weight
+weighted
+weighting
+weights
+weighty
+Weinberg
+Weiner
+Weinstein
+weird
+weirdly
+Weisenheimer
+Weiss
+Weissman
+Weissmuller
+Welch
+Welcher
+Welches
+welcome
+welcomed
+welcomes
+welcoming
+weld
+welded
+welder
+welding
+Weldon
+welds
+Weldwood
+welfare
+well
+welled
+Weller
+Welles
+Wellesley
+welling
+Wellington
+Wellman
+Wells
+Wellsville
+Welmers
+welsh
+Welton
+wench
+wenches
+Wendell
+Wendy
+went
+Wentworth
+wept
+were
+Werner
+Werther
+Wesley
+Wesleyan
+Wesson
+west
+westbound
+Westbrook
+Westchester
+western
+westerner
+westerners
+Westfield
+Westhampton
+Westinghouse
+Westminster
+Westmore
+Weston
+Westphalia
+Westport
+westward
+westwards
+Westwood
+wet
+wetly
+wetness
+wets
+wetted
+wetter
+wettest
+wetting
+Weyerhauser
+whack
+whacked
+whacking
+whacks
+whale
+Whalen
+whaler
+whales
+whaling
+wharf
+Wharton
+wharves
+what
+whatever
+Whatley
+whatsoever
+wheat
+wheaten
+Wheatland
+Wheaton
+Wheatstone
+wheel
+wheeled
+wheeler
+wheelers
+wheeling
+wheelings
+Wheelock
+wheels
+Whelan
+Wheller
+whelp
+when
+whence
+whenever
+where
+whereabouts
+whereas
+whereby
+wherein
+whereupon
+wherever
+whether
+which
+whichever
+while
+whim
+whimper
+whimpered
+whimpering
+whimpers
+whims
+whimsical
+whimsically
+whimsies
+whimsy
+whine
+whined
+whines
+whining
+whip
+Whippany
+whipped
+whipper
+whippers
+whipping
+whippings
+Whipple
+whips
+whirl
+whirled
+whirling
+whirlpool
+whirlpools
+whirls
+whirlwind
+whirr
+whirring
+whisk
+whisked
+whisker
+whiskers
+whiskey
+whisking
+whisks
+whisper
+whispered
+whispering
+whisperings
+whispers
+whistle
+whistled
+whistler
+whistlers
+whistles
+whistling
+whit
+Whitaker
+Whitcomb
+white
+Whitehall
+Whitehorse
+Whiteleaf
+Whiteley
+whitely
+whiten
+whitened
+whitener
+whiteners
+whiteness
+whitening
+whitens
+whiter
+whites
+whitespace
+whitest
+whitewash
+whitewashed
+Whitewater
+Whitfield
+whiting
+Whitlock
+Whitman
+Whitmanize
+Whitmanizes
+Whitney
+Whittaker
+Whittier
+whittle
+whittled
+whittles
+whittling
+whiz
+whizzed
+whizzes
+whizzing
+who
+whoever
+whole
+wholehearted
+wholeheartedly
+wholeness
+wholes
+wholesale
+wholesaler
+wholesalers
+wholesome
+wholesomeness
+wholly
+whom
+whomever
+whoop
+whooped
+whooping
+whoops
+whore
+whores
+whorl
+whorls
+whose
+why
+Wichita
+wick
+wicked
+wickedly
+wickedness
+wicker
+wicks
+wide
+wideband
+widely
+widen
+widened
+widener
+widening
+widens
+wider
+widespread
+widest
+widget
+widow
+widowed
+widower
+widowers
+widows
+width
+widths
+Wieland
+wield
+wielded
+wielder
+wielding
+wields
+Wier
+wife
+wifely
+wig
+Wiggins
+Wightman
+wigs
+wigwam
+Wilbur
+Wilcox
+wild
+wildcat
+wildcats
+wilder
+wilderness
+wildest
+wildly
+wildness
+wile
+wiles
+Wiley
+Wilfred
+Wilhelm
+Wilhelmina
+wiliness
+Wilkes
+Wilkie
+Wilkins
+Wilkinson
+will
+Willa
+Willamette
+Willard
+Willcox
+willed
+Willem
+willful
+willfully
+William
+Williams
+Williamsburg
+Williamson
+Willie
+Willied
+Willies
+willing
+willingly
+willingness
+Willis
+Willisson
+Willoughby
+willow
+willows
+Wills
+Willy
+Wilma
+Wilmette
+Wilmington
+Wilshire
+Wilson
+Wilsonian
+wilt
+wilted
+wilting
+wilts
+Wiltshire
+wily
+win
+wince
+winced
+winces
+Winchell
+Winchester
+wincing
+wind
+winded
+winder
+winders
+winding
+windmill
+windmills
+window
+windows
+winds
+Windsor
+windy
+wine
+wined
+Winehead
+winer
+winers
+wines
+Winfield
+wing
+winged
+winging
+wings
+Winifred
+wining
+wink
+winked
+winker
+winking
+winks
+Winnebago
+winner
+winners
+Winnetka
+Winnie
+winning
+winningly
+winnings
+Winnipeg
+Winnipesaukee
+Winograd
+Winooski
+wins
+Winsborough
+Winsett
+Winslow
+Winston
+winter
+wintered
+wintering
+Winters
+Winthrop
+wintry
+wipe
+wiped
+wiper
+wipers
+wipes
+wiping
+wire
+wired
+wireless
+wires
+wiretap
+wiretappers
+wiretapping
+wiretaps
+wiriness
+wiring
+wiry
+Wisconsin
+wisdom
+wisdoms
+wise
+wised
+wisely
+Wisenheimer
+wiser
+wisest
+wish
+wished
+wisher
+wishers
+wishes
+wishful
+wishing
+wisp
+wisps
+wistful
+wistfully
+wistfulness
+wit
+witch
+witchcraft
+witches
+witching
+with
+withal
+withdraw
+withdrawal
+withdrawals
+withdrawing
+withdrawn
+withdraws
+withdrew
+wither
+withers
+Witherspoon
+withheld
+withhold
+withholder
+withholders
+withholding
+withholdings
+withholds
+within
+without
+withstand
+withstanding
+withstands
+withstood
+witness
+witnessed
+witnesses
+witnessing
+wits
+Witt
+Wittgenstein
+witty
+wives
+wizard
+wizards
+woe
+woeful
+woefully
+woke
+Wolcott
+wolf
+Wolfe
+Wolff
+Wolfgang
+Wolverton
+wolves
+woman
+womanhood
+womanly
+womb
+wombs
+women
+won
+wonder
+wondered
+wonderful
+wonderfully
+wonderfulness
+wondering
+wonderingly
+wonderment
+wonders
+wondrous
+wondrously
+Wong
+wont
+wonted
+woo
+wood
+Woodard
+Woodberry
+Woodbury
+woodchuck
+woodchucks
+woodcock
+woodcocks
+wooded
+wooden
+woodenly
+woodenness
+woodland
+Woodlawn
+woodman
+woodpecker
+woodpeckers
+Woodrow
+Woods
+Woodstock
+Woodward
+Woodwards
+woodwork
+woodworking
+woody
+wooed
+wooer
+woof
+woofed
+woofer
+woofers
+woofing
+woofs
+wooing
+wool
+woolen
+woolly
+wools
+Woolworth
+Woonsocket
+woos
+Wooster
+Worcester
+Worcestershire
+word
+worded
+wordily
+wordiness
+wording
+words
+Wordsworth
+wordy
+wore
+work
+workable
+workably
+workbench
+workbenches
+workbook
+workbooks
+worked
+worker
+workers
+workhorse
+workhorses
+working
+workingman
+workings
+workload
+workman
+workmanship
+workmen
+works
+workshop
+workshops
+workspace
+workstation
+workstations
+world
+worldliness
+worldly
+worlds
+worldwide
+worm
+wormed
+worming
+worms
+worn
+worried
+worrier
+worriers
+worries
+worrisome
+worry
+worrying
+worryingly
+worse
+worship
+worshiped
+worshiper
+worshipful
+worshiping
+worships
+worst
+worsted
+worth
+worthiest
+worthiness
+Worthington
+worthless
+worthlessness
+worths
+worthwhile
+worthwhileness
+worthy
+Wotan
+would
+wound
+wounded
+wounding
+wounds
+wove
+woven
+wrangle
+wrangled
+wrangler
+wrap
+wraparound
+wrapped
+wrapper
+wrappers
+wrapping
+wrappings
+wraps
+wrath
+wreak
+wreaks
+wreath
+wreathed
+wreathes
+wreck
+wreckage
+wrecked
+wrecker
+wreckers
+wrecking
+wrecks
+wren
+wrench
+wrenched
+wrenches
+wrenching
+wrens
+wrest
+wrestle
+wrestler
+wrestles
+wrestling
+wrestlings
+wretch
+wretched
+wretchedness
+wretches
+wriggle
+wriggled
+wriggler
+wriggles
+wriggling
+Wrigley
+wring
+wringer
+wrings
+wrinkle
+wrinkled
+wrinkles
+wrist
+wrists
+wristwatch
+wristwatches
+writ
+writable
+write
+writer
+writers
+writes
+writhe
+writhed
+writhes
+writhing
+writing
+writings
+writs
+written
+wrong
+wronged
+wronging
+wrongly
+wrongs
+Wronskian
+wrote
+wrought
+wrung
+Wu
+Wuhan
+Wyandotte
+Wyatt
+Wyeth
+Wylie
+Wyman
+Wyner
+Wynn
+Wyoming
+Xanthus
+Xavier
+Xebec
+Xenakis
+Xenia
+Xenix
+Xerox
+Xeroxed
+Xeroxes
+Xeroxing
+Xerxes
+Xhosa
+Yagi
+Yakima
+Yale
+Yalies
+Yalta
+Yamaha
+yank
+yanked
+Yankee
+Yankees
+yanking
+yanks
+Yankton
+Yaounde
+Yaqui
+yard
+yards
+yardstick
+yardsticks
+Yarmouth
+yarn
+yarns
+Yates
+Yaunde
+yawn
+yawner
+yawning
+yea
+Yeager
+year
+yearly
+yearn
+yearned
+yearning
+yearnings
+years
+yeas
+yeast
+yeasts
+Yeats
+yell
+yelled
+yeller
+yelling
+yellow
+yellowed
+yellower
+yellowest
+yellowing
+yellowish
+Yellowknife
+yellowness
+yellows
+Yellowstone
+yelp
+yelped
+yelping
+yelps
+Yemen
+Yentl
+yeoman
+yeomen
+Yerkes
+yes
+yesterday
+yesterdays
+yet
+Yiddish
+yield
+yielded
+yielding
+yields
+Yoder
+yoke
+yokes
+Yoknapatawpha
+Yokohama
+Yokuts
+yon
+yonder
+Yonkers
+Yorick
+York
+Yorker
+Yorkers
+Yorkshire
+Yorktown
+Yosemite
+Yost
+you
+young
+younger
+youngest
+youngly
+youngster
+youngsters
+Youngstown
+your
+yours
+yourself
+yourselves
+youth
+youthes
+youthful
+youthfully
+youthfulness
+Ypsilanti
+Yuba
+Yucatan
+Yugoslav
+Yugoslavia
+Yugoslavian
+Yugoslavians
+Yuh
+Yuki
+Yukon
+Yuri
+Yves
+Yvette
+Zachary
+Zagreb
+Zaire
+Zambia
+Zan
+Zanzibar
+zeal
+Zealand
+zealous
+zealously
+zealousness
+zebra
+zebras
+Zeffirelli
+Zeiss
+Zellerbach
+Zen
+zenith
+Zennist
+zero
+zeroed
+zeroes
+zeroing
+zeros
+zeroth
+zest
+Zeus
+Ziegfeld
+Ziegfelds
+Ziegler
+Ziggy
+zigzag
+zillions
+Zimmerman
+zinc
+Zion
+Zionism
+Zionist
+Zionists
+Zions
+zodiac
+Zoe
+Zomba
+zonal
+zonally
+zone
+zoned
+zones
+zoning
+zoo
+zoological
+zoologically
+zoom
+zooms
+zoos
+Zorn
+Zoroaster
+Zoroastrian
+Zulu
+Zulus
+Zurich
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest.pm b/Master/tlpkg/tlperl.straw/lib/Digest.pm
new file mode 100755
index 00000000000..384dfc82668
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Digest/BubbleBabble.pm b/Master/tlpkg/tlperl.straw/lib/Digest/BubbleBabble.pm
new file mode 100755
index 00000000000..10a954d0588
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/BubbleBabble.pm
@@ -0,0 +1,105 @@
+package Digest::BubbleBabble;
+use strict;
+
+use Exporter;
+use vars qw( @EXPORT_OK @ISA $VERSION );
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( bubblebabble );
+
+$VERSION = '0.01';
+
+use vars qw( @VOWELS @CONSONANTS );
+@VOWELS = qw( a e i o u y );
+@CONSONANTS = qw( b c d f g h k l m n p r s t v z x );
+
+sub bubblebabble {
+ my %param = @_;
+ my @dgst = map ord, split //, $param{Digest};
+ my $dlen = length $param{Digest};
+
+ my $seed = 1;
+ my $rounds = ($dlen / 2) + 1;
+ my $retval = 'x';
+ for my $i (0..$rounds-1) {
+ if ($i+1 < $rounds || $dlen % 2) {
+ my $idx0 = ((($dgst[2 * $i] >> 6) & 3) + $seed) % 6;
+ my $idx1 = ($dgst[2 * $i] >> 2) & 15;
+ my $idx2 = (($dgst[2 * $i] & 3) + $seed / 6) % 6;
+ $retval .= $VOWELS[$idx0] . $CONSONANTS[$idx1] . $VOWELS[$idx2];
+ if ($i+1 < $rounds) {
+ my $idx3 = ($dgst[2 * $i + 1] >> 4) & 15;
+ my $idx4 = $dgst[2 * $i + 1] & 15;
+ $retval .= $CONSONANTS[$idx3] . '-' . $CONSONANTS[$idx4];
+ $seed = ($seed * 5 + $dgst[2 * $i] * 7 +
+ $dgst[2 * $i + 1]) % 36;
+ }
+ }
+ else {
+ my $idx0 = $seed % 6;
+ my $idx1 = 16;
+ my $idx2 = $seed / 6;
+ $retval .= $VOWELS[$idx0] . $CONSONANTS[$idx1] . $VOWELS[$idx2];
+ }
+ }
+ $retval .= 'x';
+ $retval;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::BubbleBabble - Create bubble-babble fingerprints
+
+=head1 SYNOPSIS
+
+ use Digest::BubbleBabble qw( bubblebabble );
+ use Digest::SHA1 qw( sha1 );
+
+ my $fingerprint = bubblebabble( Digest => sha1($message) );
+
+=head1 DESCRIPTION
+
+I<Digest::BubbleBabble> takes a message digest (generated by
+either of the MD5 or SHA-1 message digest algorithms) and creates
+a fingerprint of that digest in "bubble babble" format.
+Bubble babble is a method of representing a message digest
+as a string of "real" words, to make the fingerprint easier
+to remember. The "words" are not necessarily real words, but
+they look more like words than a string of hex characters.
+
+Bubble babble fingerprinting is used by the SSH2 suite
+(and, consequently, by I<Net::SSH::Perl>, the Perl SSH
+implementation) to display easy-to-remember key fingerprints.
+The key (a DSA or RSA key) is converted into a textual form,
+digested using I<Digest::SHA1>, and run through I<bubblebabble>
+to create the key fingerprint.
+
+=head1 USAGE
+
+I<Digest::BubbleBabble> conditionally exports one function called
+I<bubblebabble>; to import the function you must choose to
+import it, like this:
+
+ use Digest::BubbleBabble qw( bubblebabble );
+
+=head2 bubblebabble( Digest => $digest )
+
+Currently takes only one pair of arguments, the key of
+which must be I<Digest>, the value of which is the actual
+message digest I<$digest>. You should generate this message
+digest yourself using either I<Digest::MD5> of I<Digest::SHA1>.
+
+Returns the bubble babble form of the digest.
+
+=head1 AUTHOR & COPYRIGHTS
+
+Benjamin Trott, ben@rhumba.pair.com
+
+Except where otherwise noted, Digest::BubbleBabble is Copyright
+2001 Benjamin Trott. All rights reserved. Digest::BubbleBabble is
+free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/HMAC.pm b/Master/tlpkg/tlperl.straw/lib/Digest/HMAC.pm
new file mode 100755
index 00000000000..5a548bc4b78
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/HMAC.pm
@@ -0,0 +1,111 @@
+package Digest::HMAC;
+$VERSION = "1.02";
+
+use strict;
+
+# OO interface
+
+sub new
+{
+ my($class, $key, $hasher, $block_size) = @_;
+ $block_size ||= 64;
+ $key = $hasher->new->add($key)->digest if length($key) > $block_size;
+
+ my $self = bless {}, $class;
+ $self->{k_ipad} = $key ^ (chr(0x36) x $block_size);
+ $self->{k_opad} = $key ^ (chr(0x5c) x $block_size);
+ $self->{hasher} = $hasher->new->add($self->{k_ipad});
+ $self;
+}
+
+sub reset
+{
+ my $self = shift;
+ $self->{hasher}->reset->add($self->{k_ipad});
+ $self;
+}
+
+sub add { my $self = shift; $self->{hasher}->add(@_); $self; }
+sub addfile { my $self = shift; $self->{hasher}->addfile(@_); $self; }
+
+sub _digest
+{
+ my $self = shift;
+ my $inner_digest = $self->{hasher}->digest;
+ $self->{hasher}->reset->add($self->{k_opad}, $inner_digest);
+}
+
+sub digest { shift->_digest->digest; }
+sub hexdigest { shift->_digest->hexdigest; }
+sub b64digest { shift->_digest->b64digest; }
+
+
+# Functional interface
+
+require Exporter;
+*import = \&Exporter::import;
+use vars qw(@EXPORT_OK);
+@EXPORT_OK = qw(hmac hmac_hex);
+
+sub hmac
+{
+ my($data, $key, $hash_func, $block_size) = @_;
+ $block_size ||= 64;
+ $key = &$hash_func($key) if length($key) > $block_size;
+
+ my $k_ipad = $key ^ (chr(0x36) x $block_size);
+ my $k_opad = $key ^ (chr(0x5c) x $block_size);
+
+ &$hash_func($k_opad, &$hash_func($k_ipad, $data));
+}
+
+sub hmac_hex { unpack("H*", &hmac); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest::HMAC - Keyed-Hashing for Message Authentication
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::HMAC qw(hmac hmac_hex);
+ $digest = hmac($data, $key, \&myhash);
+ print hmac_hex($data, $key, \&myhash);
+
+ # OO style
+ use Digest::HMAC;
+ $hmac = Digest::HMAC->new($key, "Digest::MyHash");
+
+ $hmac->add($data);
+ $hmac->addfile(*FILE);
+
+ $digest = $hmac->digest;
+ $digest = $hmac->hexdigest;
+ $digest = $hmac->b64digest;
+
+=head1 DESCRIPTION
+
+HMAC is used for message integrity checks between two parties that
+share a secret key, and works in combination with some other Digest
+algorithm, usually MD5 or SHA-1. The HMAC mechanism is described in
+RFC 2104.
+
+HMAC follow the common C<Digest::> interface, but the constructor
+takes the secret key and the name of some other simple C<Digest::>
+as argument.
+
+=head1 SEE ALSO
+
+L<Digest::HMAC_MD5>, L<Digest::HMAC_SHA1>
+
+RFC 2104
+
+=head1 AUTHORS
+
+Graham Barr <gbarr@ti.com>, Gisle Aas <gisle@aas.no>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/HMAC_MD5.pm b/Master/tlpkg/tlperl.straw/lib/Digest/HMAC_MD5.pm
new file mode 100755
index 00000000000..6efa0a12b3c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/HMAC_MD5.pm
@@ -0,0 +1,71 @@
+package Digest::HMAC_MD5;
+$VERSION="1.01";
+
+use strict;
+use Digest::MD5 qw(md5);
+use Digest::HMAC qw(hmac);
+
+# OO interface
+use vars qw(@ISA);
+@ISA=qw(Digest::HMAC);
+sub new
+{
+ my $class = shift;
+ $class->SUPER::new($_[0], "Digest::MD5", 64);
+}
+
+# Functional interface
+require Exporter;
+*import = \&Exporter::import;
+use vars qw(@EXPORT_OK);
+@EXPORT_OK=qw(hmac_md5 hmac_md5_hex);
+
+sub hmac_md5
+{
+ hmac($_[0], $_[1], \&md5, 64);
+}
+
+sub hmac_md5_hex
+{
+ unpack("H*", &hmac_md5)
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest::HMAC_MD5 - Keyed-Hashing for Message Authentication
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::HMAC_MD5 qw(hmac_md5 hmac_md5_hex);
+ $digest = hmac_md5($data, $key);
+ print hmac_md5_hex($data, $key);
+
+ # OO style
+ use Digest::HMAC_MD5;
+ $hmac = Digest::HMAC_MD5->new($key);
+
+ $hmac->add($data);
+ $hmac->addfile(*FILE);
+
+ $digest = $hmac->digest;
+ $digest = $hmac->hexdigest;
+ $digest = $hmac->b64digest;
+
+=head1 DESCRIPTION
+
+This module provide HMAC-MD5 hashing.
+
+=head1 SEE ALSO
+
+L<Digest::HMAC>, L<Digest::MD5>, L<Digest::HMAC_SHA1>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/HMAC_SHA1.pm b/Master/tlpkg/tlperl.straw/lib/Digest/HMAC_SHA1.pm
new file mode 100755
index 00000000000..fadfb403915
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/HMAC_SHA1.pm
@@ -0,0 +1,71 @@
+package Digest::HMAC_SHA1;
+$VERSION="1.01";
+
+use strict;
+use Digest::SHA1 qw(sha1);
+use Digest::HMAC qw(hmac);
+
+# OO interface
+use vars qw(@ISA);
+@ISA=qw(Digest::HMAC);
+sub new
+{
+ my $class = shift;
+ $class->SUPER::new($_[0], "Digest::SHA1", 64);
+}
+
+# Functional interface
+require Exporter;
+*import = \&Exporter::import;
+use vars qw(@EXPORT_OK);
+@EXPORT_OK=qw(hmac_sha1 hmac_sha1_hex);
+
+sub hmac_sha1
+{
+ hmac($_[0], $_[1], \&sha1, 64);
+}
+
+sub hmac_sha1_hex
+{
+ unpack("H*", &hmac_sha1)
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest::HMAC_SHA1 - Keyed-Hashing for Message Authentication
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::HMAC_SHA1 qw(hmac_sha1 hmac_sha1_hex);
+ $digest = hmac_sha1($data, $key);
+ print hmac_sha1_hex($data, $key);
+
+ # OO style
+ use Digest::HMAC_SHA1;
+ $hmac = Digest::HMAC_SHA1->new($key);
+
+ $hmac->add($data);
+ $hmac->addfile(*FILE);
+
+ $digest = $hmac->digest;
+ $digest = $hmac->hexdigest;
+ $digest = $hmac->b64digest;
+
+=head1 DESCRIPTION
+
+This module provide HMAC-SHA-1 hashing.
+
+=head1 SEE ALSO
+
+L<Digest::HMAC>, L<Digest::SHA1>, L<Digest::HMAC_MD5>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/MD2.pm b/Master/tlpkg/tlperl.straw/lib/Digest/MD2.pm
new file mode 100755
index 00000000000..59b6ea0d041
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/MD2.pm
@@ -0,0 +1,72 @@
+package Digest::MD2;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = '2.03'; # $Date: 2003/07/23 06:33:38 $
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(md2 md2_hex md2_base64);
+
+require DynaLoader;
+@ISA=qw(DynaLoader);
+Digest::MD2->bootstrap($VERSION);
+
+*reset = \&new;
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::MD2 - Perl interface to the MD2 Algorithm
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::MD2 qw(md2 md2_hex md2_base64);
+
+ $digest = md2($data);
+ $digest = md2_hex($data);
+ $digest = md2_base64($data);
+
+ # OO style
+ use Digest::MD2;
+
+ $ctx = Digest::MD2->new;
+
+ $ctx->add($data);
+ $ctx->addfile(*FILE);
+
+ $digest = $ctx->digest;
+ $digest = $ctx->hexdigest;
+ $digest = $ctx->b64digest;
+
+=head1 DESCRIPTION
+
+The C<Digest::MD2> module allows you to use the RSA Data Security
+Inc. MD2 Message Digest algorithm from within Perl programs. The
+algorithm takes as input a message of arbitrary length and produces as
+output a 128-bit "fingerprint" or "message digest" of the input.
+
+The C<Digest::MD2> programming interface is identical to the interface
+of C<Digest::MD5>.
+
+=head1 SEE ALSO
+
+L<Digest::MD5>
+
+=head1 COPYRIGHT
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+ Copyright 1998-2003 Gisle Aas.
+ Copyright 1990-1992 RSA Data Security, Inc.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/MD5.pm b/Master/tlpkg/tlperl.straw/lib/Digest/MD5.pm
new file mode 100755
index 00000000000..4e2adbe3460
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/MD5.pm
@@ -0,0 +1,376 @@
+package Digest::MD5;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = '2.39';
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(md5 md5_hex md5_base64);
+
+eval {
+ require Digest::base;
+ push(@ISA, 'Digest::base');
+};
+if ($@) {
+ my $err = $@;
+ *add_bits = sub { die $err };
+}
+
+
+eval {
+ require XSLoader;
+ XSLoader::load('Digest::MD5', $VERSION);
+};
+if ($@) {
+ my $olderr = $@;
+ eval {
+ # Try to load the pure perl version
+ require Digest::Perl::MD5;
+
+ Digest::Perl::MD5->import(qw(md5 md5_hex md5_base64));
+ push(@ISA, "Digest::Perl::MD5"); # make OO interface work
+ };
+ if ($@) {
+ # restore the original error
+ die $olderr;
+ }
+}
+else {
+ *reset = \&new;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::MD5 - Perl interface to the MD5 Algorithm
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::MD5 qw(md5 md5_hex md5_base64);
+
+ $digest = md5($data);
+ $digest = md5_hex($data);
+ $digest = md5_base64($data);
+
+ # OO style
+ use Digest::MD5;
+
+ $ctx = Digest::MD5->new;
+
+ $ctx->add($data);
+ $ctx->addfile(*FILE);
+
+ $digest = $ctx->digest;
+ $digest = $ctx->hexdigest;
+ $digest = $ctx->b64digest;
+
+=head1 DESCRIPTION
+
+The C<Digest::MD5> module allows you to use the RSA Data Security
+Inc. MD5 Message Digest algorithm from within Perl programs. The
+algorithm takes as input a message of arbitrary length and produces as
+output a 128-bit "fingerprint" or "message digest" of the input.
+
+Note that the MD5 algorithm is not as strong as it used to be. It has
+since 2005 been easy to generate different messages that produce the
+same MD5 digest. It still seems hard to generate messages that
+produce a given digest, but it is probably wise to move to stronger
+algorithms for applications that depend on the digest to uniquely identify
+a message.
+
+The C<Digest::MD5> module provide a procedural interface for simple
+use, as well as an object oriented interface that can handle messages
+of arbitrary length and which can read files directly.
+
+=head1 FUNCTIONS
+
+The following functions are provided by the C<Digest::MD5> module.
+None of these functions are exported by default.
+
+=over 4
+
+=item md5($data,...)
+
+This function will concatenate all arguments, calculate the MD5 digest
+of this "message", and return it in binary form. The returned string
+will be 16 bytes long.
+
+The result of md5("a", "b", "c") will be exactly the same as the
+result of md5("abc").
+
+=item md5_hex($data,...)
+
+Same as md5(), but will return the digest in hexadecimal form. The
+length of the returned string will be 32 and it will only contain
+characters from this set: '0'..'9' and 'a'..'f'.
+
+=item md5_base64($data,...)
+
+Same as md5(), but will return the digest as a base64 encoded string.
+The length of the returned string will be 22 and it will only contain
+characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' and
+'/'.
+
+Note that the base64 encoded string returned is not padded to be a
+multiple of 4 bytes long. If you want interoperability with other
+base64 encoded md5 digests you might want to append the redundant
+string "==" to the result.
+
+=back
+
+=head1 METHODS
+
+The object oriented interface to C<Digest::MD5> is described in this
+section. After a C<Digest::MD5> object has been created, you will add
+data to it and finally ask for the digest in a suitable format. A
+single object can be used to calculate multiple digests.
+
+The following methods are provided:
+
+=over 4
+
+=item $md5 = Digest::MD5->new
+
+The constructor returns a new C<Digest::MD5> object which encapsulate
+the state of the MD5 message-digest algorithm.
+
+If called as an instance method (i.e. $md5->new) it will just reset the
+state the object to the state of a newly created object. No new
+object is created in this case.
+
+=item $md5->reset
+
+This is just an alias for $md5->new.
+
+=item $md5->clone
+
+This a copy of the $md5 object. It is useful when you do not want to
+destroy the digests state, but need an intermediate value of the
+digest, e.g. when calculating digests iteratively on a continuous data
+stream. Example:
+
+ my $md5 = Digest::MD5->new;
+ while (<>) {
+ $md5->add($_);
+ print "Line $.: ", $md5->clone->hexdigest, "\n";
+ }
+
+=item $md5->add($data,...)
+
+The $data provided as argument are appended to the message we
+calculate the digest for. The return value is the $md5 object itself.
+
+All these lines will have the same effect on the state of the $md5
+object:
+
+ $md5->add("a"); $md5->add("b"); $md5->add("c");
+ $md5->add("a")->add("b")->add("c");
+ $md5->add("a", "b", "c");
+ $md5->add("abc");
+
+=item $md5->addfile($io_handle)
+
+The $io_handle will be read until EOF and its content appended to the
+message we calculate the digest for. The return value is the $md5
+object itself.
+
+The addfile() method will croak() if it fails reading data for some
+reason. If it croaks it is unpredictable what the state of the $md5
+object will be in. The addfile() method might have been able to read
+the file partially before it failed. It is probably wise to discard
+or reset the $md5 object if this occurs.
+
+In most cases you want to make sure that the $io_handle is in
+C<binmode> before you pass it as argument to the addfile() method.
+
+=item $md5->add_bits($data, $nbits)
+
+=item $md5->add_bits($bitstring)
+
+Since the MD5 algorithm is byte oriented you might only add bits as
+multiples of 8, so you probably want to just use add() instead. The
+add_bits() method is provided for compatibility with other digest
+implementations. See L<Digest> for description of the arguments
+that add_bits() take.
+
+=item $md5->digest
+
+Return the binary digest for the message. The returned string will be
+16 bytes long.
+
+Note that the C<digest> operation is effectively a destructive,
+read-once operation. Once it has been performed, the C<Digest::MD5>
+object is automatically C<reset> and can be used to calculate another
+digest value. Call $md5->clone->digest if you want to calculate the
+digest without resetting the digest state.
+
+=item $md5->hexdigest
+
+Same as $md5->digest, but will return the digest in hexadecimal
+form. The length of the returned string will be 32 and it will only
+contain characters from this set: '0'..'9' and 'a'..'f'.
+
+=item $md5->b64digest
+
+Same as $md5->digest, but will return the digest as a base64 encoded
+string. The length of the returned string will be 22 and it will only
+contain characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+'
+and '/'.
+
+
+The base64 encoded string returned is not padded to be a multiple of 4
+bytes long. If you want interoperability with other base64 encoded
+md5 digests you might want to append the string "==" to the result.
+
+=back
+
+
+=head1 EXAMPLES
+
+The simplest way to use this library is to import the md5_hex()
+function (or one of its cousins):
+
+ use Digest::MD5 qw(md5_hex);
+ print "Digest is ", md5_hex("foobarbaz"), "\n";
+
+The above example would print out the message:
+
+ Digest is 6df23dc03f9b54cc38a0fc1483df6e21
+
+The same checksum can also be calculated in OO style:
+
+ use Digest::MD5;
+
+ $md5 = Digest::MD5->new;
+ $md5->add('foo', 'bar');
+ $md5->add('baz');
+ $digest = $md5->hexdigest;
+
+ print "Digest is $digest\n";
+
+With OO style you can break the message arbitrary. This means that we
+are no longer limited to have space for the whole message in memory, i.e.
+we can handle messages of any size.
+
+This is useful when calculating checksum for files:
+
+ use Digest::MD5;
+
+ my $file = shift || "/etc/passwd";
+ open(FILE, $file) or die "Can't open '$file': $!";
+ binmode(FILE);
+
+ $md5 = Digest::MD5->new;
+ while (<FILE>) {
+ $md5->add($_);
+ }
+ close(FILE);
+ print $md5->b64digest, " $file\n";
+
+Or we can use the addfile method for more efficient reading of
+the file:
+
+ use Digest::MD5;
+
+ my $file = shift || "/etc/passwd";
+ open(FILE, $file) or die "Can't open '$file': $!";
+ binmode(FILE);
+
+ print Digest::MD5->new->addfile(*FILE)->hexdigest, " $file\n";
+
+Perl 5.8 support Unicode characters in strings. Since the MD5
+algorithm is only defined for strings of bytes, it can not be used on
+strings that contains chars with ordinal number above 255. The MD5
+functions and methods will croak if you try to feed them such input
+data:
+
+ use Digest::MD5 qw(md5_hex);
+
+ my $str = "abc\x{300}";
+ print md5_hex($str), "\n"; # croaks
+ # Wide character in subroutine entry
+
+What you can do is calculate the MD5 checksum of the UTF-8
+representation of such strings. This is achieved by filtering the
+string through encode_utf8() function:
+
+ use Digest::MD5 qw(md5_hex);
+ use Encode qw(encode_utf8);
+
+ my $str = "abc\x{300}";
+ print md5_hex(encode_utf8($str)), "\n";
+ # 8c2d46911f3f5a326455f0ed7a8ed3b3
+
+=head1 SEE ALSO
+
+L<Digest>,
+L<Digest::MD2>,
+L<Digest::SHA>,
+L<Digest::HMAC>
+
+L<md5sum(1)>
+
+RFC 1321
+
+http://en.wikipedia.org/wiki/MD5
+
+The paper "How to Break MD5 and Other Hash Functions" by Xiaoyun Wang
+and Hongbo Yu.
+
+=head1 COPYRIGHT
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+ Copyright 1998-2003 Gisle Aas.
+ Copyright 1995-1996 Neil Winton.
+ Copyright 1991-1992 RSA Data Security, Inc.
+
+The MD5 algorithm is defined in RFC 1321. This implementation is
+derived from the reference C code in RFC 1321 which is covered by
+the following copyright statement:
+
+=over 4
+
+=item
+
+Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All
+rights reserved.
+
+License to copy and use this software is granted provided that it
+is identified as the "RSA Data Security, Inc. MD5 Message-Digest
+Algorithm" in all material mentioning or referencing this software
+or this function.
+
+License is also granted to make and use derivative works provided
+that such works are identified as "derived from the RSA Data
+Security, Inc. MD5 Message-Digest Algorithm" in all material
+mentioning or referencing the derived work.
+
+RSA Data Security, Inc. makes no representations concerning either
+the merchantability of this software or the suitability of this
+software for any particular purpose. It is provided "as is"
+without express or implied warranty of any kind.
+
+These notices must be retained in any copies of any part of this
+documentation and/or software.
+
+=back
+
+This copyright does not prohibit distribution of any version of Perl
+containing this extension under the terms of the GNU or Artistic
+licenses.
+
+=head1 AUTHORS
+
+The original C<MD5> interface was written by Neil Winton
+(C<N.Winton@axion.bt.co.uk>).
+
+The C<Digest::MD5> module is written by Gisle Aas <gisle@ActiveState.com>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/SHA.pm b/Master/tlpkg/tlperl.straw/lib/Digest/SHA.pm
new file mode 100755
index 00000000000..90893c6f066
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/SHA.pm
@@ -0,0 +1,669 @@
+package Digest::SHA;
+
+require 5.003000;
+
+use strict;
+use integer;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+
+$VERSION = '5.48';
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(
+ hmac_sha1 hmac_sha1_base64 hmac_sha1_hex
+ hmac_sha224 hmac_sha224_base64 hmac_sha224_hex
+ hmac_sha256 hmac_sha256_base64 hmac_sha256_hex
+ hmac_sha384 hmac_sha384_base64 hmac_sha384_hex
+ hmac_sha512 hmac_sha512_base64 hmac_sha512_hex
+ sha1 sha1_base64 sha1_hex
+ sha224 sha224_base64 sha224_hex
+ sha256 sha256_base64 sha256_hex
+ sha384 sha384_base64 sha384_hex
+ sha512 sha512_base64 sha512_hex);
+
+# If possible, inherit from Digest::base (which depends on MIME::Base64)
+
+*addfile = \&Addfile;
+
+eval {
+ require MIME::Base64;
+ require Digest::base;
+ push(@ISA, 'Digest::base');
+};
+if ($@) {
+ *hexdigest = \&Hexdigest;
+ *b64digest = \&B64digest;
+}
+
+# The following routines aren't time-critical, so they can be left in Perl
+
+sub new {
+ my($class, $alg) = @_;
+ $alg =~ s/\D+//g if defined $alg;
+ if (ref($class)) { # instance method
+ unless (defined($alg) && ($alg != $class->algorithm)) {
+ sharewind($$class);
+ return($class);
+ }
+ shaclose($$class) if $$class;
+ $$class = shaopen($alg) || return;
+ return($class);
+ }
+ $alg = 1 unless defined $alg;
+ my $state = shaopen($alg) || return;
+ my $self = \$state;
+ bless($self, $class);
+ return($self);
+}
+
+sub DESTROY {
+ my $self = shift;
+ shaclose($$self) if $$self;
+}
+
+sub clone {
+ my $self = shift;
+ my $state = shadup($$self) || return;
+ my $copy = \$state;
+ bless($copy, ref($self));
+ return($copy);
+}
+
+*reset = \&new;
+
+sub add_bits {
+ my($self, $data, $nbits) = @_;
+ unless (defined $nbits) {
+ $nbits = length($data);
+ $data = pack("B*", $data);
+ }
+ shawrite($data, $nbits, $$self);
+ return($self);
+}
+
+sub _bail {
+ my $msg = shift;
+
+ require Carp;
+ Carp::croak("$msg: $!");
+}
+
+sub _addfile { # this is "addfile" from Digest::base 1.00
+ my ($self, $handle) = @_;
+
+ my $n;
+ my $buf = "";
+
+ while (($n = read($handle, $buf, 4096))) {
+ $self->add($buf);
+ }
+ _bail("Read failed") unless defined $n;
+
+ $self;
+}
+
+sub Addfile {
+ my ($self, $file, $mode) = @_;
+
+ return(_addfile($self, $file)) unless ref(\$file) eq 'SCALAR';
+
+ $mode = defined($mode) ? $mode : "";
+ my ($binary, $portable) = map { $_ eq $mode } ("b", "p");
+ my $text = -T $file;
+
+ local *FH;
+ # protect any leading or trailing whitespace in $file;
+ # otherwise, 2-arg "open" will ignore them
+ $file =~ s#^(\s)#./$1#;
+ open(FH, "< $file\0") or _bail("Open failed");
+ binmode(FH) if $binary || $portable;
+
+ unless ($portable && $text) {
+ $self->_addfile(*FH);
+ close(FH);
+ return($self);
+ }
+
+ my ($n1, $n2);
+ my ($buf1, $buf2) = ("", "");
+
+ while (($n1 = read(FH, $buf1, 4096))) {
+ while (substr($buf1, -1) eq "\015") {
+ $n2 = read(FH, $buf2, 4096);
+ _bail("Read failed") unless defined $n2;
+ last unless $n2;
+ $buf1 .= $buf2;
+ }
+ $buf1 =~ s/\015?\015\012/\012/g; # DOS/Windows
+ $buf1 =~ s/\015/\012/g; # early MacOS
+ $self->add($buf1);
+ }
+ _bail("Read failed") unless defined $n1;
+ close(FH);
+
+ $self;
+}
+
+sub dump {
+ my $self = shift;
+ my $file = shift || "";
+
+ shadump($file, $$self) || return;
+ return($self);
+}
+
+sub load {
+ my $class = shift;
+ my $file = shift || "";
+ if (ref($class)) { # instance method
+ shaclose($$class) if $$class;
+ $$class = shaload($file) || return;
+ return($class);
+ }
+ my $state = shaload($file) || return;
+ my $self = \$state;
+ bless($self, $class);
+ return($self);
+}
+
+Digest::SHA->bootstrap($VERSION);
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::SHA - Perl extension for SHA-1/224/256/384/512
+
+=head1 SYNOPSIS
+
+In programs:
+
+ # Functional interface
+
+ use Digest::SHA qw(sha1 sha1_hex sha1_base64 ...);
+
+ $digest = sha1($data);
+ $digest = sha1_hex($data);
+ $digest = sha1_base64($data);
+
+ $digest = sha256($data);
+ $digest = sha384_hex($data);
+ $digest = sha512_base64($data);
+
+ # Object-oriented
+
+ use Digest::SHA;
+
+ $sha = Digest::SHA->new($alg);
+
+ $sha->add($data); # feed data into stream
+
+ $sha->addfile(*F);
+ $sha->addfile($filename);
+
+ $sha->add_bits($bits);
+ $sha->add_bits($data, $nbits);
+
+ $sha_copy = $sha->clone; # if needed, make copy of
+ $sha->dump($file); # current digest state,
+ $sha->load($file); # or save it on disk
+
+ $digest = $sha->digest; # compute digest
+ $digest = $sha->hexdigest;
+ $digest = $sha->b64digest;
+
+From the command line:
+
+ $ shasum files
+
+ $ shasum --help
+
+=head1 SYNOPSIS (HMAC-SHA)
+
+ # Functional interface only
+
+ use Digest::SHA qw(hmac_sha1 hmac_sha1_hex ...);
+
+ $digest = hmac_sha1($data, $key);
+ $digest = hmac_sha224_hex($data, $key);
+ $digest = hmac_sha256_base64($data, $key);
+
+=head1 ABSTRACT
+
+Digest::SHA is a complete implementation of the NIST Secure Hash
+Standard. It gives Perl programmers a convenient way to calculate
+SHA-1, SHA-224, SHA-256, SHA-384, and SHA-512 message digests.
+The module can handle all types of input, including partial-byte
+data.
+
+=head1 DESCRIPTION
+
+Digest::SHA is written in C for speed. If your platform lacks a
+C compiler, you can install the functionally equivalent (but much
+slower) L<Digest::SHA::PurePerl> module.
+
+The programming interface is easy to use: it's the same one found
+in CPAN's L<Digest> module. So, if your applications currently
+use L<Digest::MD5> and you'd prefer the stronger security of SHA,
+it's a simple matter to convert them.
+
+The interface provides two ways to calculate digests: all-at-once,
+or in stages. To illustrate, the following short program computes
+the SHA-256 digest of "hello world" using each approach:
+
+ use Digest::SHA qw(sha256_hex);
+
+ $data = "hello world";
+ @frags = split(//, $data);
+
+ # all-at-once (Functional style)
+ $digest1 = sha256_hex($data);
+
+ # in-stages (OOP style)
+ $state = Digest::SHA->new(256);
+ for (@frags) { $state->add($_) }
+ $digest2 = $state->hexdigest;
+
+ print $digest1 eq $digest2 ?
+ "whew!\n" : "oops!\n";
+
+To calculate the digest of an n-bit message where I<n> is not a
+multiple of 8, use the I<add_bits()> method. For example, consider
+the 446-bit message consisting of the bit-string "110" repeated
+148 times, followed by "11". Here's how to display its SHA-1
+digest:
+
+ use Digest::SHA;
+ $bits = "110" x 148 . "11";
+ $sha = Digest::SHA->new(1)->add_bits($bits);
+ print $sha->hexdigest, "\n";
+
+Note that for larger bit-strings, it's more efficient to use the
+two-argument version I<add_bits($data, $nbits)>, where I<$data> is
+in the customary packed binary format used for Perl strings.
+
+The module also lets you save intermediate SHA states to disk, or
+display them on standard output. The I<dump()> method generates
+portable, human-readable text describing the current state of
+computation. You can subsequently retrieve the file with I<load()>
+to resume where the calculation left off.
+
+To see what a state description looks like, just run the following:
+
+ use Digest::SHA;
+ Digest::SHA->new->add("Shaw" x 1962)->dump;
+
+As an added convenience, the Digest::SHA module offers routines to
+calculate keyed hashes using the HMAC-SHA-1/224/256/384/512
+algorithms. These services exist in functional form only, and
+mimic the style and behavior of the I<sha()>, I<sha_hex()>, and
+I<sha_base64()> functions.
+
+ # Test vector from draft-ietf-ipsec-ciph-sha-256-01.txt
+
+ use Digest::SHA qw(hmac_sha256_hex);
+ print hmac_sha256_hex("Hi There", chr(0x0b) x 32), "\n";
+
+=head1 NIST STATEMENT ON SHA-1
+
+I<NIST was recently informed that researchers had discovered a way
+to "break" the current Federal Information Processing Standard SHA-1
+algorithm, which has been in effect since 1994. The researchers
+have not yet published their complete results, so NIST has not
+confirmed these findings. However, the researchers are a reputable
+research team with expertise in this area.>
+
+I<Due to advances in computing power, NIST already planned to phase
+out SHA-1 in favor of the larger and stronger hash functions (SHA-224,
+SHA-256, SHA-384 and SHA-512) by 2010. New developments should use
+the larger and stronger hash functions.>
+
+ref. L<http://www.csrc.nist.gov/pki/HashWorkshop/NIST%20Statement/Burr_Mar2005.html>
+
+=head1 PADDING OF BASE64 DIGESTS
+
+By convention, CPAN Digest modules do B<not> pad their Base64 output.
+Problems can occur when feeding such digests to other software that
+expects properly padded Base64 encodings.
+
+For the time being, any necessary padding must be done by the user.
+Fortunately, this is a simple operation: if the length of a Base64-encoded
+digest isn't a multiple of 4, simply append "=" characters to the end
+of the digest until it is:
+
+ while (length($b64_digest) % 4) {
+ $b64_digest .= '=';
+ }
+
+To illustrate, I<sha256_base64("abc")> is computed to be
+
+ ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0
+
+which has a length of 43. So, the properly padded version is
+
+ ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0=
+
+=head1 EXPORT
+
+None by default.
+
+=head1 EXPORTABLE FUNCTIONS
+
+Provided your C compiler supports a 64-bit type (e.g. the I<long
+long> of C99, or I<__int64> used by Microsoft C/C++), all of these
+functions will be available for use. Otherwise, you won't be able
+to perform the SHA-384 and SHA-512 transforms, both of which require
+64-bit operations.
+
+I<Functional style>
+
+=over 4
+
+=item B<sha1($data, ...)>
+
+=item B<sha224($data, ...)>
+
+=item B<sha256($data, ...)>
+
+=item B<sha384($data, ...)>
+
+=item B<sha512($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a binary string.
+
+=item B<sha1_hex($data, ...)>
+
+=item B<sha224_hex($data, ...)>
+
+=item B<sha256_hex($data, ...)>
+
+=item B<sha384_hex($data, ...)>
+
+=item B<sha512_hex($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a hexadecimal string.
+
+=item B<sha1_base64($data, ...)>
+
+=item B<sha224_base64($data, ...)>
+
+=item B<sha256_base64($data, ...)>
+
+=item B<sha384_base64($data, ...)>
+
+=item B<sha512_base64($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a Base64 string.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+I<OOP style>
+
+=over 4
+
+=item B<new($alg)>
+
+Returns a new Digest::SHA object. Allowed values for I<$alg> are
+1, 224, 256, 384, or 512. It's also possible to use common string
+representations of the algorithm (e.g. "sha256", "SHA-384"). If
+the argument is missing, SHA-1 will be used by default.
+
+Invoking I<new> as an instance method will not create a new object;
+instead, it will simply reset the object to the initial state
+associated with I<$alg>. If the argument is missing, the object
+will continue using the same algorithm that was selected at creation.
+
+=item B<reset($alg)>
+
+This method has exactly the same effect as I<new($alg)>. In fact,
+I<reset> is just an alias for I<new>.
+
+=item B<hashsize>
+
+Returns the number of digest bits for this object. The values are
+160, 224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384,
+and SHA-512, respectively.
+
+=item B<algorithm>
+
+Returns the digest algorithm for this object. The values are 1,
+224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384, and
+SHA-512, respectively.
+
+=item B<clone>
+
+Returns a duplicate copy of the object.
+
+=item B<add($data, ...)>
+
+Logically joins the arguments into a single string, and uses it to
+update the current digest state. In other words, the following
+statements have the same effect:
+
+ $sha->add("a"); $sha->add("b"); $sha->add("c");
+ $sha->add("a")->add("b")->add("c");
+ $sha->add("a", "b", "c");
+ $sha->add("abc");
+
+The return value is the updated object itself.
+
+=item B<add_bits($data, $nbits)>
+
+=item B<add_bits($bits)>
+
+Updates the current digest state by appending bits to it. The
+return value is the updated object itself.
+
+The first form causes the most-significant I<$nbits> of I<$data>
+to be appended to the stream. The I<$data> argument is in the
+customary binary format used for Perl strings.
+
+The second form takes an ASCII string of "0" and "1" characters as
+its argument. It's equivalent to
+
+ $sha->add_bits(pack("B*", $bits), length($bits));
+
+So, the following two statements do the same thing:
+
+ $sha->add_bits("111100001010");
+ $sha->add_bits("\xF0\xA0", 12);
+
+=item B<addfile(*FILE)>
+
+Reads from I<FILE> until EOF, and appends that data to the current
+state. The return value is the updated object itself.
+
+=item B<addfile($filename [, $mode])>
+
+Reads the contents of I<$filename>, and appends that data to the current
+state. The return value is the updated object itself.
+
+By default, I<$filename> is simply opened and read; no special modes
+or I/O disciplines are used. To change this, set the optional I<$mode>
+argument to one of the following values:
+
+ "b" read file in binary mode
+
+ "p" use portable mode
+
+The "p" mode is handy since it ensures that the digest value of
+I<$filename> will be the same when computed on different operating
+systems. It accomplishes this by internally translating all newlines in
+text files to UNIX format before calculating the digest. Binary files
+are read in raw mode with no translation whatsoever.
+
+For a fuller discussion of newline formats, refer to CPAN module
+L<File::LocalizeNewlines>. Its "universal line separator" regex forms
+the basis of I<addfile>'s portable mode processing.
+
+=item B<dump($filename)>
+
+Provides persistent storage of intermediate SHA states by writing
+a portable, human-readable representation of the current state to
+I<$filename>. If the argument is missing, or equal to the empty
+string, the state information will be written to STDOUT.
+
+=item B<load($filename)>
+
+Returns a Digest::SHA object representing the intermediate SHA
+state that was previously dumped to I<$filename>. If called as a
+class method, a new object is created; if called as an instance
+method, the object is reset to the state contained in I<$filename>.
+If the argument is missing, or equal to the empty string, the state
+information will be read from STDIN.
+
+=item B<digest>
+
+Returns the digest encoded as a binary string.
+
+Note that the I<digest> method is a read-once operation. Once it
+has been performed, the Digest::SHA object is automatically reset
+in preparation for calculating another digest value. Call
+I<$sha-E<gt>clone-E<gt>digest> if it's necessary to preserve the
+original digest state.
+
+=item B<hexdigest>
+
+Returns the digest encoded as a hexadecimal string.
+
+Like I<digest>, this method is a read-once operation. Call
+I<$sha-E<gt>clone-E<gt>hexdigest> if it's necessary to preserve
+the original digest state.
+
+This method is inherited if L<Digest::base> is installed on your
+system. Otherwise, a functionally equivalent substitute is used.
+
+=item B<b64digest>
+
+Returns the digest encoded as a Base64 string.
+
+Like I<digest>, this method is a read-once operation. Call
+I<$sha-E<gt>clone-E<gt>b64digest> if it's necessary to preserve
+the original digest state.
+
+This method is inherited if L<Digest::base> is installed on your
+system. Otherwise, a functionally equivalent substitute is used.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+I<HMAC-SHA-1/224/256/384/512>
+
+=over 4
+
+=item B<hmac_sha1($data, $key)>
+
+=item B<hmac_sha224($data, $key)>
+
+=item B<hmac_sha256($data, $key)>
+
+=item B<hmac_sha384($data, $key)>
+
+=item B<hmac_sha512($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a binary string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+=item B<hmac_sha1_hex($data, $key)>
+
+=item B<hmac_sha224_hex($data, $key)>
+
+=item B<hmac_sha256_hex($data, $key)>
+
+=item B<hmac_sha384_hex($data, $key)>
+
+=item B<hmac_sha512_hex($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a hexadecimal string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+=item B<hmac_sha1_base64($data, $key)>
+
+=item B<hmac_sha224_base64($data, $key)>
+
+=item B<hmac_sha256_base64($data, $key)>
+
+=item B<hmac_sha384_base64($data, $key)>
+
+=item B<hmac_sha512_base64($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a Base64 string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest>, L<Digest::SHA::PurePerl>
+
+The Secure Hash Standard (FIPS PUB 180-2) can be found at:
+
+L<http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>
+
+The Keyed-Hash Message Authentication Code (HMAC):
+
+L<http://csrc.nist.gov/publications/fips/fips198/fips-198a.pdf>
+
+=head1 AUTHOR
+
+ Mark Shelor <mshelor@cpan.org>
+
+=head1 ACKNOWLEDGMENTS
+
+The author is particularly grateful to
+
+ Gisle Aas
+ Chris Carey
+ Alexandr Ciornii
+ Jim Doble
+ Julius Duque
+ Jeffrey Friedl
+ Robert Gilmour
+ Brian Gladman
+ Adam Kennedy
+ Andy Lester
+ Alex Muntada
+ Steve Peters
+ Chris Skiscim
+ Martin Thurn
+ Gunnar Wolf
+ Adam Woodbury
+
+for their valuable comments and suggestions.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2003-2010 Mark Shelor
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+L<perlartistic>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/SHA1.pm b/Master/tlpkg/tlperl.straw/lib/Digest/SHA1.pm
new file mode 100755
index 00000000000..9ad328759b1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/SHA1.pm
@@ -0,0 +1,246 @@
+package Digest::SHA1;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = '2.12';
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(sha1 sha1_hex sha1_base64 sha1_transform);
+
+require DynaLoader;
+@ISA=qw(DynaLoader);
+
+eval {
+ require Digest::base;
+ push(@ISA, 'Digest::base');
+};
+if ($@) {
+ my $err = $@;
+ *add_bits = sub { die $err };
+}
+
+Digest::SHA1->bootstrap($VERSION);
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::SHA1 - Perl interface to the SHA-1 algorithm
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::SHA1 qw(sha1 sha1_hex sha1_base64);
+
+ $digest = sha1($data);
+ $digest = sha1_hex($data);
+ $digest = sha1_base64($data);
+ $digest = sha1_transform($data);
+
+
+ # OO style
+ use Digest::SHA1;
+
+ $sha1 = Digest::SHA1->new;
+
+ $sha1->add($data);
+ $sha1->addfile(*FILE);
+
+ $sha1_copy = $sha1->clone;
+
+ $digest = $sha1->digest;
+ $digest = $sha1->hexdigest;
+ $digest = $sha1->b64digest;
+ $digest = $sha1->transform;
+
+=head1 DESCRIPTION
+
+The C<Digest::SHA1> module allows you to use the NIST SHA-1 message
+digest algorithm from within Perl programs. The algorithm takes as
+input a message of arbitrary length and produces as output a 160-bit
+"fingerprint" or "message digest" of the input.
+
+In 2005, security flaws were identified in SHA-1, namely that a possible
+mathematical weakness might exist, indicating that a stronger hash function
+would be desirable. The L<Digest::SHA> module implements the stronger
+algorithms in the SHA family.
+
+The C<Digest::SHA1> module provide a procedural interface for simple
+use, as well as an object oriented interface that can handle messages
+of arbitrary length and which can read files directly.
+
+=head1 FUNCTIONS
+
+The following functions can be exported from the C<Digest::SHA1>
+module. No functions are exported by default.
+
+=over 4
+
+=item sha1($data,...)
+
+This function will concatenate all arguments, calculate the SHA-1
+digest of this "message", and return it in binary form. The returned
+string will be 20 bytes long.
+
+The result of sha1("a", "b", "c") will be exactly the same as the
+result of sha1("abc").
+
+=item sha1_hex($data,...)
+
+Same as sha1(), but will return the digest in hexadecimal form. The
+length of the returned string will be 40 and it will only contain
+characters from this set: '0'..'9' and 'a'..'f'.
+
+=item sha1_base64($data,...)
+
+Same as sha1(), but will return the digest as a base64 encoded string.
+The length of the returned string will be 27 and it will only contain
+characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' and
+'/'.
+
+Note that the base64 encoded string returned is not padded to be a
+multiple of 4 bytes long. If you want interoperability with other
+base64 encoded sha1 digests you might want to append the redundant
+string "=" to the result.
+
+=item sha1_transform($data)
+
+Implements the basic SHA1 transform on a 64 byte block. The $data
+argument and the returned $digest are in binary form. This algorithm
+is used in NIST FIPS 186-2
+
+=back
+
+=head1 METHODS
+
+The object oriented interface to C<Digest::SHA1> is described in this
+section. After a C<Digest::SHA1> object has been created, you will add
+data to it and finally ask for the digest in a suitable format. A
+single object can be used to calculate multiple digests.
+
+The following methods are provided:
+
+=over 4
+
+=item $sha1 = Digest::SHA1->new
+
+The constructor returns a new C<Digest::SHA1> object which encapsulate
+the state of the SHA-1 message-digest algorithm.
+
+If called as an instance method (i.e. $sha1->new) it will just reset the
+state the object to the state of a newly created object. No new
+object is created in this case.
+
+=item $sha1->reset
+
+This is just an alias for $sha1->new.
+
+=item $sha1->clone
+
+This a copy of the $sha1 object. It is useful when you do not want to
+destroy the digests state, but need an intermediate value of the
+digest, e.g. when calculating digests iteratively on a continuous data
+stream. Example:
+
+ my $sha1 = Digest::SHA1->new;
+ while (<>) {
+ $sha1->add($_);
+ print "Line $.: ", $sha1->clone->hexdigest, "\n";
+ }
+
+=item $sha1->add($data,...)
+
+The $data provided as argument are appended to the message we
+calculate the digest for. The return value is the $sha1 object itself.
+
+All these lines will have the same effect on the state of the $sha1
+object:
+
+ $sha1->add("a"); $sha1->add("b"); $sha1->add("c");
+ $sha1->add("a")->add("b")->add("c");
+ $sha1->add("a", "b", "c");
+ $sha1->add("abc");
+
+=item $sha1->addfile($io_handle)
+
+The $io_handle will be read until EOF and its content appended to the
+message we calculate the digest for. The return value is the $sha1
+object itself.
+
+The addfile() method will croak() if it fails reading data for some
+reason. If it croaks it is unpredictable what the state of the $sha1
+object will be in. The addfile() method might have been able to read
+the file partially before it failed. It is probably wise to discard
+or reset the $sha1 object if this occurs.
+
+In most cases you want to make sure that the $io_handle is in
+C<binmode> before you pass it as argument to the addfile() method.
+
+=item $sha1->add_bits($data, $nbits)
+
+=item $sha1->add_bits($bitstring)
+
+This implementation of SHA-1 only supports byte oriented input so you
+might only add bits as multiples of 8. If you need bit level support
+please consider using the C<Digest::SHA> module instead. The
+add_bits() method is provided here for compatibility with other digest
+implementations. See L<Digest> for description of the arguments that
+add_bits() take.
+
+=item $sha1->digest
+
+Return the binary digest for the message. The returned string will be
+20 bytes long.
+
+Note that the C<digest> operation is effectively a destructive,
+read-once operation. Once it has been performed, the C<Digest::SHA1>
+object is automatically C<reset> and can be used to calculate another
+digest value. Call $sha1->clone->digest if you want to calculate the
+digest without reseting the digest state.
+
+=item $sha1->hexdigest
+
+Same as $sha1->digest, but will return the digest in hexadecimal
+form. The length of the returned string will be 40 and it will only
+contain characters from this set: '0'..'9' and 'a'..'f'.
+
+=item $sha1->b64digest
+
+Same as $sha1->digest, but will return the digest as a base64 encoded
+string. The length of the returned string will be 27 and it will only
+contain characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+'
+and '/'.
+
+
+The base64 encoded string returned is not padded to be a multiple of 4
+bytes long. If you want interoperability with other base64 encoded
+SHA-1 digests you might want to append the string "=" to the result.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest>, L<Digest::HMAC_SHA1>, L<Digest::SHA>, L<Digest::MD5>
+
+http://www.itl.nist.gov/fipspubs/fip180-1.htm
+
+http://en.wikipedia.org/wiki/SHA_hash_functions
+
+=head1 COPYRIGHT
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+ Copyright 1999-2004 Gisle Aas.
+ Copyright 1997 Uwe Hollerbach.
+
+=head1 AUTHORS
+
+Peter C. Gutmann,
+Uwe Hollerbach <uh@alumni.caltech.edu>,
+Gisle Aas <gisle@aas.no>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/base.pm b/Master/tlpkg/tlperl.straw/lib/Digest/base.pm
new file mode 100755
index 00000000000..b2844ba3400
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/base.pm
@@ -0,0 +1,100 @@
+package Digest::base;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "1.16";
+
+# subclass is supposed to implement at least these
+sub new;
+sub clone;
+sub add;
+sub digest;
+
+sub reset {
+ my $self = shift;
+ $self->new(@_); # ugly
+}
+
+sub addfile {
+ my ($self, $handle) = @_;
+
+ my $n;
+ my $buf = "";
+
+ while (($n = read($handle, $buf, 4*1024))) {
+ $self->add($buf);
+ }
+ unless (defined $n) {
+ require Carp;
+ Carp::croak("Read failed: $!");
+ }
+
+ $self;
+}
+
+sub add_bits {
+ my $self = shift;
+ my $bits;
+ my $nbits;
+ if (@_ == 1) {
+ my $arg = shift;
+ $bits = pack("B*", $arg);
+ $nbits = length($arg);
+ }
+ else {
+ ($bits, $nbits) = @_;
+ }
+ if (($nbits % 8) != 0) {
+ require Carp;
+ Carp::croak("Number of bits must be multiple of 8 for this algorithm");
+ }
+ return $self->add(substr($bits, 0, $nbits/8));
+}
+
+sub hexdigest {
+ my $self = shift;
+ return unpack("H*", $self->digest(@_));
+}
+
+sub b64digest {
+ my $self = shift;
+ require MIME::Base64;
+ my $b64 = MIME::Base64::encode($self->digest(@_), "");
+ $b64 =~ s/=+$//;
+ return $b64;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest::base - Digest base class
+
+=head1 SYNOPSIS
+
+ package Digest::Foo;
+ use base 'Digest::base';
+
+=head1 DESCRIPTION
+
+The C<Digest::base> class provide implementations of the methods
+C<addfile> and C<add_bits> in terms of C<add>, and of the methods
+C<hexdigest> and C<b64digest> in terms of C<digest>.
+
+Digest implementations might want to inherit from this class to get
+this implementations of the alternative I<add> and I<digest> methods.
+A minimal subclass needs to implement the following methods by itself:
+
+ new
+ clone
+ add
+ digest
+
+The arguments and expected behaviour of these methods are described in
+L<Digest>.
+
+=head1 SEE ALSO
+
+L<Digest>
diff --git a/Master/tlpkg/tlperl.straw/lib/Digest/file.pm b/Master/tlpkg/tlperl.straw/lib/Digest/file.pm
new file mode 100755
index 00000000000..3b86e63503a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Digest/file.pm
@@ -0,0 +1,85 @@
+package Digest::file;
+
+use strict;
+
+use Exporter ();
+use Carp qw(croak);
+use Digest ();
+
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = "1.16";
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(digest_file_ctx digest_file digest_file_hex digest_file_base64);
+
+sub digest_file_ctx {
+ my $file = shift;
+ croak("No digest algorithm specified") unless @_;
+ local *F;
+ open(F, "<", $file) || croak("Can't open '$file': $!");
+ binmode(F);
+ my $ctx = Digest->new(@_);
+ $ctx->addfile(*F);
+ close(F);
+ return $ctx;
+}
+
+sub digest_file {
+ digest_file_ctx(@_)->digest;
+}
+
+sub digest_file_hex {
+ digest_file_ctx(@_)->hexdigest;
+}
+
+sub digest_file_base64 {
+ digest_file_ctx(@_)->b64digest;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest::file - Calculate digests of files
+
+=head1 SYNOPSIS
+
+ # Poor mans "md5sum" command
+ use Digest::file qw(digest_file_hex);
+ for (@ARGV) {
+ print digest_file_hex($_, "MD5"), " $_\n";
+ }
+
+=head1 DESCRIPTION
+
+This module provide 3 convenience functions to calculate the digest
+of files. The following functions are provided:
+
+=over
+
+=item digest_file( $file, $algorithm, [$arg,...] )
+
+This function will calculate and return the binary digest of the bytes
+of the given file. The function will croak if it fails to open or
+read the file.
+
+The $algorithm is a string like "MD2", "MD5", "SHA-1", "SHA-512".
+Additional arguments are passed to the constructor for the
+implementation of the given algorithm.
+
+=item digest_file_hex( $file, $algorithm, [$arg,...] )
+
+Same as digest_file(), but return the digest in hex form.
+
+=item digest_file_base64( $file, $algorithm, [$arg,...] )
+
+Same as digest_file(), but return the digest as a base64 encoded
+string.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest>
diff --git a/Master/tlpkg/tlperl.straw/lib/DirHandle.pm b/Master/tlpkg/tlperl.straw/lib/DirHandle.pm
new file mode 100755
index 00000000000..fc27dfb1e63
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/English.pm b/Master/tlpkg/tlperl.straw/lib/English.pm
new file mode 100755
index 00000000000..c11fbed9eba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Errno.pm b/Master/tlpkg/tlperl.straw/lib/Errno.pm
new file mode 100755
index 00000000000..91e092dd95f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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 ERROR_DS_CANT_MOVE_ACCOUNT_GROUP
+ EXCEPTION_INVALID_DISPOSITION ERROR_OPEN_FAILED ERROR_NOT_SUPPORTED
+ ERROR_SXS_XML_E_INVALID_DECIMAL 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_HANDLE_EOF
+ ERROR_HOST_NODE_NOT_GROUP_OWNER ERROR_DS_DUP_OID 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
+ ERROR_DS_DRA_EARLIER_SCHEMA_CONLICT 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 E_INVALIDARG ERROR_NOT_A_REPARSE_POINT
+ 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 ERROR_DS_INSTALL_NO_SCH_VERSION_IN_INIFILE
+ EM_SETMODIFY 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_DS_COULDNT_LOCK_TREE_FOR_DELETE
+ ERROR_INVALID_STACKSEG 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_FLOPPY_UNKNOWN_ERROR ERROR_NOT_SAFEBOOT_SERVICE
+ ERROR_EXTENDED_ERROR ERROR_WRITE_PROTECT ERROR_FAILED_SERVICE_CONTROLLER_CONNECT
+ ERROR_NO_USER_KEYS ERROR_SXS_XML_E_INTERNALERROR ERROR_NO_SUPPORTING_DRIVES
+ EM_GETMODIFY 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 ENHMETA_SIGNATURE ERROR_ALREADY_WAITING
+ 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_DC_NOT_FOUND ERROR_NO_EFS
+ 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_SEM_USER_LIMIT ERROR_DS_CONFIG_PARAM_MISSING 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_DELETING_ICM_XFORM
+ ERROR_MESSAGE_SYNC_ONLY 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 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_NETWORK_BUSY ERROR_OUTOFMEMORY
+ 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
+ EMR_STRETCHDIBITS ERROR_IPSEC_IKE_PROCESS_ERR_VENDOR
+ 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_DECRYPTION_FAILED ERROR_INSTALL_FAILURE
+ 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
+ ERROR_BAD_NET_RESP EXCEPTION_FLT_INEXACT_RESULT 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_TOO_MANY_CONTEXT_IDS ERROR_IPSEC_IKE_MM_LIMIT
+ 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 ERROR_DS_DRA_SOURCE_DISABLED ES_PASSWORD
+ 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_ENCODING_ERROR ERROR_WMI_TRY_AGAIN
+ ERROR_DS_DUP_LDAP_DISPLAY_NAME 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_NAMING_VIOLATION ERROR_DS_PROTOCOL_ERROR 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 EMR_SETWINDOWORGEX EVENTLOG_WARNING_TYPE
+ ERROR_SXS_KEY_NOT_FOUND 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_WORKING_SET_QUOTA
+ ERROR_NESTING_NOT_ALLOWED 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
+ ERROR_DS_RDN_DOESNT_MATCH_SCHEMA EMR_SETWORLDTRANSFORM
+ 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_LOOKUP_FAILURE 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_IPSEC_IKE_GETSPIFAIL
+ ERROR_BAD_UNIT 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_SCREEN_ALREADY_LOCKED
+ ERROR_POSSIBLE_DEADLOCK 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_CTX_CONSOLE_CONNECT ERROR_WMI_INSTANCE_NOT_FOUND
+ 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_CTX_SHADOW_DISABLED
+ ERROR_IPSEC_IKE_BENIGN_REINIT EXCEPTION_NONCONTINUABLE_EXCEPTION
+ ERROR_SXS_WRONG_SECTION_TYPE ERROR_TAG_NOT_PRESENT
+ ENABLERELATIVEWIDTHS 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_REMOTE_CROSSREF_OP_FAILED
+ ERROR_DS_MISSING_SUPREF 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_DS_DRA_OBJ_IS_REP_SOURCE ERROR_INVALID_HANDLE_STATE
+ ERROR_PATCH_TARGET_NOT_FOUND 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_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_GROUP_NOT_FOUND
+ ERROR_DS_CONTROL_NOT_FOUND ERROR_TOO_MANY_LINKS 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_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_CONLICT () { 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.straw/lib/Exporter/Heavy.pm b/Master/tlpkg/tlperl.straw/lib/Exporter/Heavy.pm
new file mode 100755
index 00000000000..d8dff224999
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Exporter/Heavy.pm
@@ -0,0 +1,251 @@
+package Exporter::Heavy;
+
+use strict;
+no strict 'refs';
+
+# On one line so MakeMaker will see it.
+require Exporter; our $VERSION = $Exporter::VERSION;
+
+# Carp 1.05+ does this now for us, but we may be running with an old Carp
+$Carp::Internal{'Exporter::Heavy'}++;
+
+=head1 NAME
+
+Exporter::Heavy - Exporter guts
+
+=head1 SYNOPSIS
+
+(internal use only)
+
+=head1 DESCRIPTION
+
+No user-serviceable parts inside.
+
+=cut
+
+#
+# We go to a lot of trouble not to 'require Carp' at file scope,
+# because Carp requires Exporter, and something has to give.
+#
+
+sub _rebuild_cache {
+ my ($pkg, $exports, $cache) = @_;
+ s/^&// foreach @$exports;
+ @{$cache}{@$exports} = (1) x @$exports;
+ my $ok = \@{"${pkg}::EXPORT_OK"};
+ if (@$ok) {
+ s/^&// foreach @$ok;
+ @{$cache}{@$ok} = (1) x @$ok;
+ }
+}
+
+sub heavy_export {
+
+ # First make import warnings look like they're coming from the "use".
+ local $SIG{__WARN__} = sub {
+ my $text = shift;
+ if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::carp($text);
+ }
+ else {
+ warn $text;
+ }
+ };
+ local $SIG{__DIE__} = sub {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
+ if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
+ };
+
+ my($pkg, $callpkg, @imports) = @_;
+ my($type, $sym, $cache_is_current, $oops);
+ my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
+ $Exporter::Cache{$pkg} ||= {});
+
+ if (@imports) {
+ if (!%$export_cache) {
+ _rebuild_cache ($pkg, $exports, $export_cache);
+ $cache_is_current = 1;
+ }
+
+ if (grep m{^[/!:]}, @imports) {
+ my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
+ my $tagdata;
+ my %imports;
+ my($remove, $spec, @names, @allexports);
+ # negated first item implies starting with default set:
+ unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
+ foreach $spec (@imports){
+ $remove = $spec =~ s/^!//;
+
+ if ($spec =~ s/^://){
+ if ($spec eq 'DEFAULT'){
+ @names = @$exports;
+ }
+ elsif ($tagdata = $tagsref->{$spec}) {
+ @names = @$tagdata;
+ }
+ else {
+ warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
+ ++$oops;
+ next;
+ }
+ }
+ elsif ($spec =~ m:^/(.*)/$:){
+ my $patn = $1;
+ @allexports = keys %$export_cache unless @allexports; # only do keys once
+ @names = grep(/$patn/, @allexports); # not anchored by default
+ }
+ else {
+ @names = ($spec); # is a normal symbol name
+ }
+
+ warn "Import ".($remove ? "del":"add").": @names "
+ if $Exporter::Verbose;
+
+ if ($remove) {
+ foreach $sym (@names) { delete $imports{$sym} }
+ }
+ else {
+ @imports{@names} = (1) x @names;
+ }
+ }
+ @imports = keys %imports;
+ }
+
+ my @carp;
+ foreach $sym (@imports) {
+ if (!$export_cache->{$sym}) {
+ if ($sym =~ m/^\d/) {
+ $pkg->VERSION($sym); # inherit from UNIVERSAL
+ # If the version number was the only thing specified
+ # then we should act as if nothing was specified:
+ if (@imports == 1) {
+ @imports = @$exports;
+ last;
+ }
+ # We need a way to emulate 'use Foo ()' but still
+ # allow an easy version check: "use Foo 1.23, ''";
+ if (@imports == 2 and !$imports[1]) {
+ @imports = ();
+ last;
+ }
+ } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
+ # Last chance - see if they've updated EXPORT_OK since we
+ # cached it.
+
+ unless ($cache_is_current) {
+ %$export_cache = ();
+ _rebuild_cache ($pkg, $exports, $export_cache);
+ $cache_is_current = 1;
+ }
+
+ if (!$export_cache->{$sym}) {
+ # accumulate the non-exports
+ push @carp,
+ qq["$sym" is not exported by the $pkg module\n];
+ $oops++;
+ }
+ }
+ }
+ }
+ if ($oops) {
+ require Carp;
+ Carp::croak("@{carp}Can't continue after import errors");
+ }
+ }
+ else {
+ @imports = @$exports;
+ }
+
+ my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
+ $Exporter::FailCache{$pkg} ||= {});
+
+ if (@$fail) {
+ if (!%$fail_cache) {
+ # Build cache of symbols. Optimise the lookup by adding
+ # barewords twice... both with and without a leading &.
+ # (Technique could be applied to $export_cache at cost of memory)
+ my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
+ warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
+ @{$fail_cache}{@expanded} = (1) x @expanded;
+ }
+ my @failed;
+ foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
+ if (@failed) {
+ @failed = $pkg->export_fail(@failed);
+ foreach $sym (@failed) {
+ require Carp;
+ Carp::carp(qq["$sym" is not implemented by the $pkg module ],
+ "on this architecture");
+ }
+ if (@failed) {
+ require Carp;
+ Carp::croak("Can't continue after import errors");
+ }
+ }
+ }
+
+ warn "Importing into $callpkg from $pkg: ",
+ join(", ",sort @imports) if $Exporter::Verbose;
+
+ foreach $sym (@imports) {
+ # shortcut for the common case of no type character
+ (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
+ unless $sym =~ s/^(\W)//;
+ $type = $1;
+ no warnings 'once';
+ *{"${callpkg}::$sym"} =
+ $type eq '&' ? \&{"${pkg}::$sym"} :
+ $type eq '$' ? \${"${pkg}::$sym"} :
+ $type eq '@' ? \@{"${pkg}::$sym"} :
+ $type eq '%' ? \%{"${pkg}::$sym"} :
+ $type eq '*' ? *{"${pkg}::$sym"} :
+ do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
+ }
+}
+
+sub heavy_export_to_level
+{
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # XXX redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+# Utility functions
+
+sub _push_tags {
+ my($pkg, $var, $syms) = @_;
+ my @nontag = ();
+ my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
+ push(@{"${pkg}::$var"},
+ map { $export_tags->{$_} ? @{$export_tags->{$_}}
+ : scalar(push(@nontag,$_),$_) }
+ (@$syms) ? @$syms : keys %$export_tags);
+ if (@nontag and $^W) {
+ # This may change to a die one day
+ require Carp;
+ Carp::carp(join(", ", @nontag)." are not tags of $pkg");
+ }
+}
+
+sub heavy_require_version {
+ my($self, $wanted) = @_;
+ my $pkg = ref $self || $self;
+ return ${pkg}->VERSION($wanted);
+}
+
+sub heavy_export_tags {
+ _push_tags((caller)[0], "EXPORT", \@_);
+}
+
+sub heavy_export_ok_tags {
+ _push_tags((caller)[0], "EXPORT_OK", \@_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Fatal.pm b/Master/tlpkg/tlperl.straw/lib/Fatal.pm
new file mode 100755
index 00000000000..18e71ed21a3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Filter/Simple.pm b/Master/tlpkg/tlperl.straw/lib/Filter/Simple.pm
new file mode 100755
index 00000000000..135a75dc6fb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Filter/Simple.pm
@@ -0,0 +1,797 @@
+package Filter::Simple;
+
+use Text::Balanced ':ALL';
+
+use vars qw{ $VERSION @EXPORT };
+
+$VERSION = '0.84';
+
+use Filter::Util::Call;
+use Carp;
+
+@EXPORT = qw( FILTER FILTER_ONLY );
+
+
+sub import {
+ if (@_>1) { shift; goto &FILTER }
+ else { *{caller()."::$_"} = \&$_ foreach @EXPORT }
+}
+
+sub fail {
+ croak "FILTER_ONLY: ", @_;
+}
+
+my $exql = sub {
+ my @bits = extract_quotelike $_[0], qr//;
+ return unless $bits[0];
+ return \@bits;
+};
+
+my $ncws = qr/\s+/;
+my $comment = qr/(?<![\$\@%])#.*/;
+my $ws = qr/(?:$ncws|$comment)+/;
+my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/;
+my $EOP = qr/\n\n|\Z/;
+my $CUT = qr/\n=cut.*$EOP/;
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $EOP
+ | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
+ | ^__(DATA|END)__\r?\n.*
+ /smx;
+
+my %extractor_for = (
+ quotelike => [ $ws, \&extract_variable, $id, { MATCH => \&extract_quotelike } ],
+ regex => [ $ws, $pod_or_DATA, $id, $exql ],
+ string => [ $ws, $pod_or_DATA, $id, $exql ],
+ code => [ $ws, { DONT_MATCH => $pod_or_DATA },
+ \&extract_variable,
+ $id, { DONT_MATCH => \&extract_quotelike } ],
+ code_no_comments
+ => [ { DONT_MATCH => $comment },
+ $ncws, { DONT_MATCH => $pod_or_DATA },
+ \&extract_variable,
+ $id, { DONT_MATCH => \&extract_quotelike } ],
+ executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
+ executable_no_comments
+ => [ { DONT_MATCH => $comment },
+ $ncws, { DONT_MATCH => $pod_or_DATA } ],
+ all => [ { MATCH => qr/(?s:.*)/ } ],
+);
+
+my %selector_for = (
+ all => sub { my ($t)=@_; sub{ $_=$$_; $t->(@_); $_} },
+ executable=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
+ quotelike => sub { my ($t)=@_; sub{ref() && do{$_=$$_; $t->(@_)}; $_} },
+ regex => sub { my ($t)=@_;
+ sub{ref() or return $_;
+ my ($ql,undef,$pre,$op,$ld,$pat) = @$_;
+ return $_->[0] unless $op =~ /^(qr|m|s)/
+ || !$op && ($ld eq '/' || $ld eq '?');
+ $_ = $pat;
+ $t->(@_);
+ $ql =~ s/^(\s*\Q$op\E\s*\Q$ld\E)\Q$pat\E/$1$_/;
+ return "$pre$ql";
+ };
+ },
+ string => sub { my ($t)=@_;
+ sub{ref() or return $_;
+ local *args = \@_;
+ my ($pre,$op,$ld1,$str1,$rd1,$ld2,$str2,$rd2,$flg) = @{$_}[2..10];
+ return $_->[0] if $op =~ /^(qr|m)/
+ || !$op && ($ld1 eq '/' || $ld1 eq '?');
+ if (!$op || $op eq 'tr' || $op eq 'y') {
+ local *_ = \$str1;
+ $t->(@args);
+ }
+ if ($op =~ /^(tr|y|s)/) {
+ local *_ = \$str2;
+ $t->(@args);
+ }
+ my $result = "$pre$op$ld1$str1$rd1";
+ $result .= $ld2 if $ld1 =~ m/[[({<]/; #])}>
+ $result .= "$str2$rd2$flg";
+ return $result;
+ };
+ },
+);
+
+
+sub gen_std_filter_for {
+ my ($type, $transform) = @_;
+ return sub {
+ my $instr;
+ local @components;
+ for (extract_multiple($_,$extractor_for{$type})) {
+ if (ref()) { push @components, $_; $instr=0 }
+ elsif ($instr) { $components[-1] .= $_ }
+ else { push @components, $_; $instr=1 }
+ }
+ if ($type =~ /^code/) {
+ my $count = 0;
+ local $placeholder = qr/\Q$;\E(\C{4})\Q$;\E/;
+ my $extractor = qr/\Q$;\E(\C{4})\Q$;\E/;
+ $_ = join "",
+ map { ref $_ ? $;.pack('N',$count++).$; : $_ }
+ @components;
+ @components = grep { ref $_ } @components;
+ $transform->(@_);
+ s/$extractor/${$components[unpack('N',$1)]}/g;
+ }
+ else {
+ my $selector = $selector_for{$type}->($transform);
+ $_ = join "", map $selector->(@_), @components;
+ }
+ }
+};
+
+sub FILTER (&;$) {
+ my $caller = caller;
+ my ($filter, $terminator) = @_;
+ no warnings 'redefine';
+ *{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
+ *{"${caller}::unimport"} = gen_filter_unimport($caller);
+}
+
+sub FILTER_ONLY {
+ my $caller = caller;
+ while (@_ > 1) {
+ my ($what, $how) = splice(@_, 0, 2);
+ fail "Unknown selector: $what"
+ unless exists $extractor_for{$what};
+ fail "Filter for $what is not a subroutine reference"
+ unless ref $how eq 'CODE';
+ push @transforms, gen_std_filter_for($what,$how);
+ }
+ my $terminator = shift;
+
+ my $multitransform = sub {
+ foreach my $transform ( @transforms ) {
+ $transform->(@_);
+ }
+ };
+ no warnings 'redefine';
+ *{"${caller}::import"} =
+ gen_filter_import($caller,$multitransform,$terminator);
+ *{"${caller}::unimport"} = gen_filter_unimport($caller);
+}
+
+my $ows = qr/(?:[ \t]+|#[^\n]*)*/;
+
+sub gen_filter_import {
+ my ($class, $filter, $terminator) = @_;
+ my %terminator;
+ my $prev_import = *{$class."::import"}{CODE};
+ return sub {
+ my ($imported_class, @args) = @_;
+ my $def_terminator =
+ qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)\r?$/;
+ if (!defined $terminator) {
+ $terminator{terminator} = $def_terminator;
+ }
+ elsif (!ref $terminator || ref $terminator eq 'Regexp') {
+ $terminator{terminator} = $terminator;
+ }
+ elsif (ref $terminator ne 'HASH') {
+ croak "Terminator must be specified as scalar or hash ref"
+ }
+ elsif (!exists $terminator->{terminator}) {
+ $terminator{terminator} = $def_terminator;
+ }
+ filter_add(
+ sub {
+ my ($status, $lastline);
+ my $count = 0;
+ my $data = "";
+ while ($status = filter_read()) {
+ return $status if $status < 0;
+ if ($terminator{terminator} &&
+ m/$terminator{terminator}/) {
+ $lastline = $_;
+ last;
+ }
+ $data .= $_;
+ $count++;
+ $_ = "";
+ }
+ return $count if not $count;
+ $_ = $data;
+ $filter->($imported_class, @args) unless $status < 0;
+ if (defined $lastline) {
+ if (defined $terminator{becomes}) {
+ $_ .= $terminator{becomes};
+ }
+ elsif ($lastline =~ $def_terminator) {
+ $_ .= $lastline;
+ }
+ }
+ return $count;
+ }
+ );
+ if ($prev_import) {
+ goto &$prev_import;
+ }
+ elsif ($class->isa('Exporter')) {
+ $class->export_to_level(1,@_);
+ }
+ }
+}
+
+sub gen_filter_unimport {
+ my ($class) = @_;
+ return sub {
+ filter_del();
+ goto &$prev_unimport if $prev_unimport;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Filter::Simple - Simplified source filtering
+
+
+=head1 SYNOPSIS
+
+ # in MyFilter.pm:
+
+ package MyFilter;
+
+ use Filter::Simple;
+
+ FILTER { ... };
+
+ # or just:
+ #
+ # use Filter::Simple sub { ... };
+
+ # in user's code:
+
+ use MyFilter;
+
+ # this code is filtered
+
+ no MyFilter;
+
+ # this code is not
+
+
+=head1 DESCRIPTION
+
+=head2 The Problem
+
+Source filtering is an immensely powerful feature of recent versions of Perl.
+It allows one to extend the language itself (e.g. the Switch module), to
+simplify the language (e.g. Language::Pythonesque), or to completely recast the
+language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use
+the full power of Perl as its own, recursively applied, macro language.
+
+The excellent Filter::Util::Call module (by Paul Marquess) provides a
+usable Perl interface to source filtering, but it is often too powerful
+and not nearly as simple as it could be.
+
+To use the module it is necessary to do the following:
+
+=over 4
+
+=item 1.
+
+Download, build, and install the Filter::Util::Call module.
+(If you have Perl 5.7.1 or later, this is already done for you.)
+
+=item 2.
+
+Set up a module that does a C<use Filter::Util::Call>.
+
+=item 3.
+
+Within that module, create an C<import> subroutine.
+
+=item 4.
+
+Within the C<import> subroutine do a call to C<filter_add>, passing
+it either a subroutine reference.
+
+=item 5.
+
+Within the subroutine reference, call C<filter_read> or C<filter_read_exact>
+to "prime" $_ with source code data from the source file that will
+C<use> your module. Check the status value returned to see if any
+source code was actually read in.
+
+=item 6.
+
+Process the contents of $_ to change the source code in the desired manner.
+
+=item 7.
+
+Return the status value.
+
+=item 8.
+
+If the act of unimporting your module (via a C<no>) should cause source
+code filtering to cease, create an C<unimport> subroutine, and have it call
+C<filter_del>. Make sure that the call to C<filter_read> or
+C<filter_read_exact> in step 5 will not accidentally read past the
+C<no>. Effectively this limits source code filters to line-by-line
+operation, unless the C<import> subroutine does some fancy
+pre-pre-parsing of the source code it's filtering.
+
+=back
+
+For example, here is a minimal source code filter in a module named
+BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG>
+to the sequence C<die 'BANG' if $BANG> in any piece of code following a
+C<use BANG;> statement (until the next C<no BANG;> statement, if any):
+
+ package BANG;
+
+ use Filter::Util::Call ;
+
+ sub import {
+ filter_add( sub {
+ my $caller = caller;
+ my ($status, $no_seen, $data);
+ while ($status = filter_read()) {
+ if (/^\s*no\s+$caller\s*;\s*?$/) {
+ $no_seen=1;
+ last;
+ }
+ $data .= $_;
+ $_ = "";
+ }
+ $_ = $data;
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g
+ unless $status < 0;
+ $_ .= "no $class;\n" if $no_seen;
+ return 1;
+ })
+ }
+
+ sub unimport {
+ filter_del();
+ }
+
+ 1 ;
+
+This level of sophistication puts filtering out of the reach of
+many programmers.
+
+
+=head2 A Solution
+
+The Filter::Simple module provides a simplified interface to
+Filter::Util::Call; one that is sufficient for most common cases.
+
+Instead of the above process, with Filter::Simple the task of setting up
+a source code filter is reduced to:
+
+=over 4
+
+=item 1.
+
+Download and install the Filter::Simple module.
+(If you have Perl 5.7.1 or later, this is already done for you.)
+
+=item 2.
+
+Set up a module that does a C<use Filter::Simple> and then
+calls C<FILTER { ... }>.
+
+=item 3.
+
+Within the anonymous subroutine or block that is passed to
+C<FILTER>, process the contents of $_ to change the source code in
+the desired manner.
+
+=back
+
+In other words, the previous example, would become:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+
+ 1 ;
+
+Note that the source code is passed as a single string, so any regex that
+uses C<^> or C<$> to detect line boundaries will need the C</m> flag.
+
+=head2 Disabling or changing <no> behaviour
+
+By default, the installed filter only filters up to a line consisting of one of
+the three standard source "terminators":
+
+ no ModuleName; # optional comment
+
+or:
+
+ __END__
+
+or:
+
+ __DATA__
+
+but this can be altered by passing a second argument to C<use Filter::Simple>
+or C<FILTER> (just remember: there's I<no> comma after the initial block when
+you use C<FILTER>).
+
+That second argument may be either a C<qr>'d regular expression (which is then
+used to match the terminator line), or a defined false value (which indicates
+that no terminator line should be looked for), or a reference to a hash
+(in which case the terminator is the value associated with the key
+C<'terminator'>.
+
+For example, to cause the previous filter to filter only up to a line of the
+form:
+
+ GNAB esu;
+
+you would write:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ qr/^\s*GNAB\s+esu\s*;\s*?$/;
+
+or:
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ { terminator => qr/^\s*GNAB\s+esu\s*;\s*?$/ };
+
+and to prevent the filter's being turned off in any way:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ ""; # or: 0
+
+or:
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ { terminator => "" };
+
+B<Note that, no matter what you set the terminator pattern to,
+the actual terminator itself I<must> be contained on a single source line.>
+
+
+=head2 All-in-one interface
+
+Separating the loading of Filter::Simple:
+
+ use Filter::Simple;
+
+from the setting up of the filtering:
+
+ FILTER { ... };
+
+is useful because it allows other code (typically parser support code
+or caching variables) to be defined before the filter is invoked.
+However, there is often no need for such a separation.
+
+In those cases, it is easier to just append the filtering subroutine and
+any terminator specification directly to the C<use> statement that loads
+Filter::Simple, like so:
+
+ use Filter::Simple sub {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+
+This is exactly the same as:
+
+ use Filter::Simple;
+ BEGIN {
+ Filter::Simple::FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+ }
+
+except that the C<FILTER> subroutine is not exported by Filter::Simple.
+
+
+=head2 Filtering only specific components of source code
+
+One of the problems with a filter like:
+
+ use Filter::Simple;
+
+ FILTER { s/BANG\s+BANG/die 'BANG' if \$BANG/g };
+
+is that it indiscriminately applies the specified transformation to
+the entire text of your source program. So something like:
+
+ warn 'BANG BANG, YOU'RE DEAD';
+ BANG BANG;
+
+will become:
+
+ warn 'die 'BANG' if $BANG, YOU'RE DEAD';
+ die 'BANG' if $BANG;
+
+It is very common when filtering source to only want to apply the filter
+to the non-character-string parts of the code, or alternatively to I<only>
+the character strings.
+
+Filter::Simple supports this type of filtering by automatically
+exporting the C<FILTER_ONLY> subroutine.
+
+C<FILTER_ONLY> takes a sequence of specifiers that install separate
+(and possibly multiple) filters that act on only parts of the source code.
+For example:
+
+ use Filter::Simple;
+
+ FILTER_ONLY
+ code => sub { s/BANG\s+BANG/die 'BANG' if \$BANG/g },
+ quotelike => sub { s/BANG\s+BANG/CHITTY CHITTY/g };
+
+The C<"code"> subroutine will only be used to filter parts of the source
+code that are not quotelikes, POD, or C<__DATA__>. The C<quotelike>
+subroutine only filters Perl quotelikes (including here documents).
+
+The full list of alternatives is:
+
+=over
+
+=item C<"code">
+
+Filters only those sections of the source code that are not quotelikes, POD, or
+C<__DATA__>.
+
+=item C<"code_no_comments">
+
+Filters only those sections of the source code that are not quotelikes, POD,
+comments, or C<__DATA__>.
+
+=item C<"executable">
+
+Filters only those sections of the source code that are not POD or C<__DATA__>.
+
+=item C<"executable_no_comments">
+
+Filters only those sections of the source code that are not POD, comments, or C<__DATA__>.
+
+=item C<"quotelike">
+
+Filters only Perl quotelikes (as interpreted by
+C<&Text::Balanced::extract_quotelike>).
+
+=item C<"string">
+
+Filters only the string literal parts of a Perl quotelike (i.e. the
+contents of a string literal, either half of a C<tr///>, the second
+half of an C<s///>).
+
+=item C<"regex">
+
+Filters only the pattern literal parts of a Perl quotelike (i.e. the
+contents of a C<qr//> or an C<m//>, the first half of an C<s///>).
+
+=item C<"all">
+
+Filters everything. Identical in effect to C<FILTER>.
+
+=back
+
+Except for C<< FILTER_ONLY code => sub {...} >>, each of
+the component filters is called repeatedly, once for each component
+found in the source code.
+
+Note that you can also apply two or more of the same type of filter in
+a single C<FILTER_ONLY>. For example, here's a simple
+macro-preprocessor that is only applied within regexes,
+with a final debugging pass that prints the resulting source code:
+
+ use Regexp::Common;
+ FILTER_ONLY
+ regex => sub { s/!\[/[^/g },
+ regex => sub { s/%d/$RE{num}{int}/g },
+ regex => sub { s/%f/$RE{num}{real}/g },
+ all => sub { print if $::DEBUG };
+
+
+
+=head2 Filtering only the code parts of source code
+
+Most source code ceases to be grammatically correct when it is broken up
+into the pieces between string literals and regexes. So the C<'code'>
+and C<'code_no_comments'> component filter behave slightly differently
+from the other partial filters described in the previous section.
+
+Rather than calling the specified processor on each individual piece of
+code (i.e. on the bits between quotelikes), the C<'code...'> partial
+filters operate on the entire source code, but with the quotelike bits
+(and, in the case of C<'code_no_comments'>, the comments) "blanked out".
+
+That is, a C<'code...'> filter I<replaces> each quoted string, quotelike,
+regex, POD, and __DATA__ section with a placeholder. The
+delimiters of this placeholder are the contents of the C<$;> variable
+at the time the filter is applied (normally C<"\034">). The remaining
+four bytes are a unique identifier for the component being replaced.
+
+This approach makes it comparatively easy to write code preprocessors
+without worrying about the form or contents of strings, regexes, etc.
+
+For convenience, during a C<'code...'> filtering operation, Filter::Simple
+provides a package variable (C<$Filter::Simple::placeholder>) that
+contains a pre-compiled regex that matches any placeholder...and
+captures the identifier within the placeholder. Placeholders can be
+moved and re-ordered within the source code as needed.
+
+In addition, a second package variable (C<@Filter::Simple::components>)
+contains a list of the various pieces of C<$_>, as they were originally split
+up to allow placeholders to be inserted.
+
+Once the filtering has been applied, the original strings, regexes, POD,
+etc. are re-inserted into the code, by replacing each placeholder with
+the corresponding original component (from C<@components>). Note that
+this means that the C<@components> variable must be treated with extreme
+care within the filter. The C<@components> array stores the "back-
+translations" of each placeholder inserted into C<$_>, as well as the
+interstitial source code between placeholders. If the placeholder
+backtranslations are altered in C<@components>, they will be similarly
+changed when the placeholders are removed from C<$_> after the filter
+is complete.
+
+For example, the following filter detects concatenated pairs of
+strings/quotelikes and reverses the order in which they are
+concatenated:
+
+ package DemoRevCat;
+ use Filter::Simple;
+
+ FILTER_ONLY code => sub {
+ my $ph = $Filter::Simple::placeholder;
+ s{ ($ph) \s* [.] \s* ($ph) }{ $2.$1 }gx
+ };
+
+Thus, the following code:
+
+ use DemoRevCat;
+
+ my $str = "abc" . q(def);
+
+ print "$str\n";
+
+would become:
+
+ my $str = q(def)."abc";
+
+ print "$str\n";
+
+and hence print:
+
+ defabc
+
+
+=head2 Using Filter::Simple with an explicit C<import> subroutine
+
+Filter::Simple generates a special C<import> subroutine for
+your module (see L<"How it works">) which would normally replace any
+C<import> subroutine you might have explicitly declared.
+
+However, Filter::Simple is smart enough to notice your existing
+C<import> and Do The Right Thing with it.
+That is, if you explicitly define an C<import> subroutine in a package
+that's using Filter::Simple, that C<import> subroutine will still
+be invoked immediately after any filter you install.
+
+The only thing you have to remember is that the C<import> subroutine
+I<must> be declared I<before> the filter is installed. If you use C<FILTER>
+to install the filter:
+
+ package Filter::TurnItUpTo11;
+
+ use Filter::Simple;
+
+ FILTER { s/(\w+)/\U$1/ };
+
+that will almost never be a problem, but if you install a filtering
+subroutine by passing it directly to the C<use Filter::Simple>
+statement:
+
+ package Filter::TurnItUpTo11;
+
+ use Filter::Simple sub{ s/(\w+)/\U$1/ };
+
+then you must make sure that your C<import> subroutine appears before
+that C<use> statement.
+
+
+=head2 Using Filter::Simple and Exporter together
+
+Likewise, Filter::Simple is also smart enough
+to Do The Right Thing if you use Exporter:
+
+ package Switch;
+ use base Exporter;
+ use Filter::Simple;
+
+ @EXPORT = qw(switch case);
+ @EXPORT_OK = qw(given when);
+
+ FILTER { $_ = magic_Perl_filter($_) }
+
+Immediately after the filter has been applied to the source,
+Filter::Simple will pass control to Exporter, so it can do its magic too.
+
+Of course, here too, Filter::Simple has to know you're using Exporter
+before it applies the filter. That's almost never a problem, but if you're
+nervous about it, you can guarantee that things will work correctly by
+ensuring that your C<use base Exporter> always precedes your
+C<use Filter::Simple>.
+
+
+=head2 How it works
+
+The Filter::Simple module exports into the package that calls C<FILTER>
+(or C<use>s it directly) -- such as package "BANG" in the above example --
+two automagically constructed
+subroutines -- C<import> and C<unimport> -- which take care of all the
+nasty details.
+
+In addition, the generated C<import> subroutine passes its own argument
+list to the filtering subroutine, so the BANG.pm filter could easily
+be made parametric:
+
+ package BANG;
+
+ use Filter::Simple;
+
+ FILTER {
+ my ($die_msg, $var_name) = @_;
+ s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
+ };
+
+ # and in some user code:
+
+ use BANG "BOOM", "BAM"; # "BANG BANG" becomes: die 'BOOM' if $BAM
+
+
+The specified filtering subroutine is called every time a C<use BANG> is
+encountered, and passed all the source code following that call, up to
+either the next C<no BANG;> (or whatever terminator you've set) or the
+end of the source file, whichever occurs first. By default, any C<no
+BANG;> call must appear by itself on a separate line, or it is ignored.
+
+
+=head1 AUTHOR
+
+Damian Conway
+
+=head1 CONTACT
+
+Filter::Simple is now maintained by the Perl5-Porters.
+Please submit bug via the C<perlbug> tool that comes with your perl.
+For usage instructions, read C<perldoc perlbug> or possibly C<man perlbug>.
+For mostly anything else, please contact E<lt>perl5-porters@perl.orgE<gt>.
+
+Maintainer of the CPAN release is Steffen Mueller E<lt>smueller@cpan.orgE<gt>.
+Contact him with technical difficulties with respect to the packaging of the
+CPAN module.
+
+Praise of the module, flowers, and presents still go to the author,
+Damian Conway E<lt>damian@conway.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENSE
+
+ Copyright (c) 2000-2008, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl.straw/lib/Filter/Util/Call.pm b/Master/tlpkg/tlperl.straw/lib/Filter/Util/Call.pm
new file mode 100755
index 00000000000..1d1b2618f0e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Filter/Util/Call.pm
@@ -0,0 +1,498 @@
+
+# Call.pm
+#
+# Copyright (c) 1995-2009 Paul Marquess. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Filter::Util::Call ;
+
+require 5.005 ;
+require DynaLoader;
+require Exporter;
+use Carp ;
+use strict;
+use warnings;
+use vars qw($VERSION @ISA @EXPORT) ;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ;
+$VERSION = "1.08" ;
+
+sub filter_read_exact($)
+{
+ my ($size) = @_ ;
+ my ($left) = $size ;
+ my ($status) ;
+
+ croak ("filter_read_exact: size parameter must be > 0")
+ unless $size > 0 ;
+
+ # try to read a block which is exactly $size bytes long
+ while ($left and ($status = filter_read($left)) > 0) {
+ $left = $size - length $_ ;
+ }
+
+ # EOF with pending data is a special case
+ return 1 if $status == 0 and length $_ ;
+
+ return $status ;
+}
+
+sub filter_add($)
+{
+ my($obj) = @_ ;
+
+ # Did we get a code reference?
+ my $coderef = (ref $obj eq 'CODE') ;
+
+ # If the parameter isn't already a reference, make it one.
+ $obj = \$obj unless ref $obj ;
+
+ $obj = bless ($obj, (caller)[0]) unless $coderef ;
+
+ # finish off the installation of the filter in C.
+ Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ;
+}
+
+bootstrap Filter::Util::Call ;
+
+1;
+__END__
+
+=head1 NAME
+
+Filter::Util::Call - Perl Source Filter Utility Module
+
+=head1 SYNOPSIS
+
+ use Filter::Util::Call ;
+
+=head1 DESCRIPTION
+
+This module provides you with the framework to write I<Source Filters>
+in Perl.
+
+An alternate interface to Filter::Util::Call is now available. See
+L<Filter::Simple> for more details.
+
+A I<Perl Source Filter> is implemented as a Perl module. The structure
+of the module can take one of two broadly similar formats. To
+distinguish between them, the first will be referred to as I<method
+filter> and the second as I<closure filter>.
+
+Here is a skeleton for the I<method filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+ filter_add([]) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ $status = filter_read() ;
+ $status ;
+ }
+
+ 1 ;
+
+and this is the equivalent skeleton for the I<closure filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+
+ filter_add(
+ sub
+ {
+ my($status) ;
+ $status = filter_read() ;
+ $status ;
+ } )
+ }
+
+ 1 ;
+
+To make use of either of the two filter modules above, place the line
+below in a Perl source file.
+
+ use MyFilter;
+
+In fact, the skeleton modules shown above are fully functional I<Source
+Filters>, albeit fairly useless ones. All they does is filter the
+source stream without modifying it at all.
+
+As you can see both modules have a broadly similar structure. They both
+make use of the C<Filter::Util::Call> module and both have an C<import>
+method. The difference between them is that the I<method filter>
+requires a I<filter> method, whereas the I<closure filter> gets the
+equivalent of a I<filter> method with the anonymous sub passed to
+I<filter_add>.
+
+To make proper use of the I<closure filter> shown above you need to
+have a good understanding of the concept of a I<closure>. See
+L<perlref> for more details on the mechanics of I<closures>.
+
+=head2 B<use Filter::Util::Call>
+
+The following functions are exported by C<Filter::Util::Call>:
+
+ filter_add()
+ filter_read()
+ filter_read_exact()
+ filter_del()
+
+=head2 B<import()>
+
+The C<import> method is used to create an instance of the filter. It is
+called indirectly by Perl when it encounters the C<use MyFilter> line
+in a source file (See L<perlfunc/import> for more details on
+C<import>).
+
+It will always have at least one parameter automatically passed by Perl
+- this corresponds to the name of the package. In the example above it
+will be C<"MyFilter">.
+
+Apart from the first parameter, import can accept an optional list of
+parameters. These can be used to pass parameters to the filter. For
+example:
+
+ use MyFilter qw(a b c) ;
+
+will result in the C<@_> array having the following values:
+
+ @_ [0] => "MyFilter"
+ @_ [1] => "a"
+ @_ [2] => "b"
+ @_ [3] => "c"
+
+Before terminating, the C<import> function must explicitly install the
+filter by calling C<filter_add>.
+
+B<filter_add()>
+
+The function, C<filter_add>, actually installs the filter. It takes one
+parameter which should be a reference. The kind of reference used will
+dictate which of the two filter types will be used.
+
+If a CODE reference is used then a I<closure filter> will be assumed.
+
+If a CODE reference is not used, a I<method filter> will be assumed.
+In a I<method filter>, the reference can be used to store context
+information. The reference will be I<blessed> into the package by
+C<filter_add>.
+
+See the filters at the end of this documents for examples of using
+context information using both I<method filters> and I<closure
+filters>.
+
+=head2 B<filter() and anonymous sub>
+
+Both the C<filter> method used with a I<method filter> and the
+anonymous sub used with a I<closure filter> is where the main
+processing for the filter is done.
+
+The big difference between the two types of filter is that the I<method
+filter> uses the object passed to the method to store any context data,
+whereas the I<closure filter> uses the lexical variables that are
+maintained by the closure.
+
+Note that the single parameter passed to the I<method filter>,
+C<$self>, is the same reference that was passed to C<filter_add>
+blessed into the filter's package. See the example filters later on for
+details of using C<$self>.
+
+Here is a list of the common features of the anonymous sub and the
+C<filter()> method.
+
+=over 5
+
+=item B<$_>
+
+Although C<$_> doesn't actually appear explicitly in the sample filters
+above, it is implicitly used in a number of places.
+
+Firstly, when either C<filter> or the anonymous sub are called, a local
+copy of C<$_> will automatically be created. It will always contain the
+empty string at this point.
+
+Next, both C<filter_read> and C<filter_read_exact> will append any
+source data that is read to the end of C<$_>.
+
+Finally, when C<filter> or the anonymous sub are finished processing,
+they are expected to return the filtered source using C<$_>.
+
+This implicit use of C<$_> greatly simplifies the filter.
+
+=item B<$status>
+
+The status value that is returned by the user's C<filter> method or
+anonymous sub and the C<filter_read> and C<read_exact> functions take
+the same set of values, namely:
+
+ < 0 Error
+ = 0 EOF
+ > 0 OK
+
+=item B<filter_read> and B<filter_read_exact>
+
+These functions are used by the filter to obtain either a line or block
+from the next filter in the chain or the actual source file if there
+aren't any other filters.
+
+The function C<filter_read> takes two forms:
+
+ $status = filter_read() ;
+ $status = filter_read($size) ;
+
+The first form is used to request a I<line>, the second requests a
+I<block>.
+
+In line mode, C<filter_read> will append the next source line to the
+end of the C<$_> scalar.
+
+In block mode, C<filter_read> will append a block of data which is <=
+C<$size> to the end of the C<$_> scalar. It is important to emphasise
+the that C<filter_read> will not necessarily read a block which is
+I<precisely> C<$size> bytes.
+
+If you need to be able to read a block which has an exact size, you can
+use the function C<filter_read_exact>. It works identically to
+C<filter_read> in block mode, except it will try to read a block which
+is exactly C<$size> bytes in length. The only circumstances when it
+will not return a block which is C<$size> bytes long is on EOF or
+error.
+
+It is I<very> important to check the value of C<$status> after I<every>
+call to C<filter_read> or C<filter_read_exact>.
+
+=item B<filter_del>
+
+The function, C<filter_del>, is used to disable the current filter. It
+does not affect the running of the filter. All it does is tell Perl not
+to call filter any more.
+
+See L<Example 4: Using filter_del> for details.
+
+=back
+
+=head1 EXAMPLES
+
+Here are a few examples which illustrate the key concepts - as such
+most of them are of little practical use.
+
+The C<examples> sub-directory has copies of all these filters
+implemented both as I<method filters> and as I<closure filters>.
+
+=head2 Example 1: A simple filter.
+
+Below is a I<method filter> which is hard-wired to replace all
+occurrences of the string C<"Joe"> to C<"Jim">. Not particularly
+Useful, but it is the first example and I wanted to keep it simple.
+
+ package Joe2Jim ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type) = @_ ;
+
+ filter_add(bless []) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ s/Joe/Jim/g
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ }
+
+ 1 ;
+
+Here is an example of using the filter:
+
+ use Joe2Jim ;
+ print "Where is Joe?\n" ;
+
+And this is what the script above will print:
+
+ Where is Jim?
+
+=head2 Example 2: Using the context
+
+The previous example was not particularly useful. To make it more
+general purpose we will make use of the context data and allow any
+arbitrary I<from> and I<to> strings to be used. This time we will use a
+I<closure filter>. To reflect its enhanced role, the filter is called
+C<Subst>.
+
+ package Subst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ croak("usage: use Subst qw(from to)")
+ unless @_ == 3 ;
+ my ($self, $from, $to) = @_ ;
+ filter_add(
+ sub
+ {
+ my ($status) ;
+ s/$from/$to/
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ })
+ }
+ 1 ;
+
+and is used like this:
+
+ use Subst qw(Joe Jim) ;
+ print "Where is Joe?\n" ;
+
+
+=head2 Example 3: Using the context within the filter
+
+Here is a filter which a variation of the C<Joe2Jim> filter. As well as
+substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count
+of the number of substitutions made in the context object.
+
+Once EOF is detected (C<$status> is zero) the filter will insert an
+extra line into the source stream. When this extra line is executed it
+will print a count of the number of substitutions actually made.
+Note that C<$status> is set to C<1> in this case.
+
+ package Count ;
+
+ use Filter::Util::Call ;
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0 ) {
+ s/Joe/Jim/g ;
+ ++ $$self ;
+ }
+ elsif ($$self >= 0) { # EOF
+ $_ = "print q[Made ${$self} substitutions\n]" ;
+ $status = 1 ;
+ $$self = -1 ;
+ }
+
+ $status ;
+ }
+
+ sub import
+ {
+ my ($self) = @_ ;
+ my ($count) = 0 ;
+ filter_add(\$count) ;
+ }
+
+ 1 ;
+
+Here is a script which uses it:
+
+ use Count ;
+ print "Hello Joe\n" ;
+ print "Where is Joe\n" ;
+
+Outputs:
+
+ Hello Jim
+ Where is Jim
+ Made 2 substitutions
+
+=head2 Example 4: Using filter_del
+
+Another variation on a theme. This time we will modify the C<Subst>
+filter to allow a starting and stopping pattern to be specified as well
+as the I<from> and I<to> patterns. If you know the I<vi> editor, it is
+the equivalent of this command:
+
+ :/start/,/stop/s/from/to/
+
+When used as a filter we want to invoke it like this:
+
+ use NewSubst qw(start stop from to) ;
+
+Here is the module.
+
+ package NewSubst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ my ($self, $start, $stop, $from, $to) = @_ ;
+ my ($found) = 0 ;
+ croak("usage: use Subst qw(start stop from to)")
+ unless @_ == 5 ;
+
+ filter_add(
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+
+ $found = 1
+ if $found == 0 and /$start/ ;
+
+ if ($found) {
+ s/$from/$to/ ;
+ filter_del() if /$stop/ ;
+ }
+
+ }
+ $status ;
+ } )
+
+ }
+
+ 1 ;
+
+=head1 Filter::Simple
+
+If you intend using the Filter::Call functionality, I would strongly
+recommend that you check out Damian Conway's excellent Filter::Simple
+module. Damian's module provides a much cleaner interface than
+Filter::Util::Call. Although it doesn't allow the fine control that
+Filter::Util::Call does, it should be adequate for the majority of
+applications. It's available at
+
+ http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
+ http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+26th January 1996
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/GDBM_File.pm b/Master/tlpkg/tlperl.straw/lib/GDBM_File.pm
new file mode 100755
index 00000000000..db39bfe82ac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/GDBM_File.pm
@@ -0,0 +1,86 @@
+# GDBM_File.pm -- Perl 5 interface to GNU gdbm library.
+
+=head1 NAME
+
+GDBM_File - Perl5 access to the gdbm library.
+
+=head1 SYNOPSIS
+
+ use GDBM_File ;
+ tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640;
+ # Use the %hash array.
+ untie %hash ;
+
+=head1 DESCRIPTION
+
+B<GDBM_File> is a module which allows Perl programs to make use of the
+facilities provided by the GNU gdbm library. If you intend to use this
+module you should really have a copy of the gdbm manualpage at hand.
+
+Most of the libgdbm.a functions are available through the GDBM_File
+interface.
+
+=head1 AVAILABILITY
+
+gdbm is available from any GNU archive. The master site is
+C<ftp.gnu.org>, but you are strongly urged to use one of the many
+mirrors. You can obtain a list of mirror sites from
+http://www.gnu.org/order/ftp.html.
+
+=head1 BUGS
+
+The available functions and the gdbm/perl interface need to be documented.
+
+The GDBM error number and error message interface needs to be added.
+
+=head1 SEE ALSO
+
+L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>.
+
+=cut
+
+package GDBM_File;
+
+use strict;
+use warnings;
+our($VERSION, @ISA, @EXPORT, $AUTOLOAD);
+
+require Carp;
+require Tie::Hash;
+require Exporter;
+use XSLoader ();
+@ISA = qw(Tie::Hash Exporter);
+@EXPORT = qw(
+ GDBM_CACHESIZE
+ GDBM_CENTFREE
+ GDBM_COALESCEBLKS
+ GDBM_FAST
+ GDBM_FASTMODE
+ GDBM_INSERT
+ GDBM_NEWDB
+ GDBM_NOLOCK
+ GDBM_OPENMASK
+ GDBM_READER
+ GDBM_REPLACE
+ GDBM_SYNC
+ GDBM_SYNCMODE
+ GDBM_WRCREAT
+ GDBM_WRITER
+);
+
+# This module isn't dual life, so no need for dev version numbers.
+$VERSION = '1.090001';
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
+
+XSLoader::load 'GDBM_File', $VERSION;
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Getopt/Long.pm b/Master/tlpkg/tlperl.straw/lib/Getopt/Long.pm
new file mode 100755
index 00000000000..c827d3c39b3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Getopt/Long.pm
@@ -0,0 +1,2649 @@
+# Getopt::Long.pm -- Universal options parsing
+
+package Getopt::Long;
+
+# RCS Status : $Id: Long.pm,v 2.76 2009/03/30 20:54:30 jv Exp $
+# Author : Johan Vromans
+# Created On : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Mon Mar 30 22:51:17 2009
+# Update Count : 1601
+# Status : Released
+
+################ Module Preamble ################
+
+use 5.004;
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = 2.38;
+# For testing versions only.
+#use vars qw($VERSION_STRING);
+#$VERSION_STRING = "2.38";
+
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+@ISA = qw(Exporter);
+
+# Exported subroutines.
+sub GetOptions(@); # always
+sub GetOptionsFromArray(@); # on demand
+sub GetOptionsFromString(@); # on demand
+sub Configure(@); # on demand
+sub HelpMessage(@); # on demand
+sub VersionMessage(@); # in demand
+
+BEGIN {
+ # Init immediately so their contents can be used in the 'use vars' below.
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
+ &GetOptionsFromArray &GetOptionsFromString);
+}
+
+# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
+use vars qw($error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+ $passthrough);
+# Official invisible variables.
+use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
+
+# Public subroutines.
+sub config(@); # deprecated name
+
+# Private subroutines.
+sub ConfigDefaults();
+sub ParseOptionSpec($$);
+sub OptCtl($);
+sub FindOption($$$$$);
+sub ValidValue ($$$$$);
+
+################ Local Variables ################
+
+# $requested_version holds the version that was mentioned in the 'use'
+# or 'require', if any. It can be used to enable or disable specific
+# features.
+my $requested_version = 0;
+
+################ Resident subroutines ################
+
+sub ConfigDefaults() {
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $genprefix = "(--|-)";
+ $autoabbrev = 0; # no automatic abbrev of options
+ $bundling = 0; # no bundling of single letter switches
+ $getopt_compat = 0; # disallow '+' to start options
+ $order = $REQUIRE_ORDER;
+ }
+ else {
+ $genprefix = "(--|-|\\+)";
+ $autoabbrev = 1; # automatic abbrev of options
+ $bundling = 0; # bundling off by default
+ $getopt_compat = 1; # allow '+' to start options
+ $order = $PERMUTE;
+ }
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $error = 0; # error tally
+ $ignorecase = 1; # ignore case when matching options
+ $passthrough = 0; # leave unrecognized options alone
+ $gnu_compat = 0; # require --opt=val if value is optional
+ $longprefix = "(--)"; # what does a long prefix look like
+}
+
+# Override import.
+sub import {
+ my $pkg = shift; # package
+ my @syms = (); # symbols to import
+ my @config = (); # configuration
+ my $dest = \@syms; # symbols first
+ for ( @_ ) {
+ if ( $_ eq ':config' ) {
+ $dest = \@config; # config next
+ next;
+ }
+ push(@$dest, $_); # push
+ }
+ # Hide one level and call super.
+ local $Exporter::ExportLevel = 1;
+ push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
+ $pkg->SUPER::import(@syms);
+ # And configure.
+ Configure(@config) if @config;
+}
+
+################ Initialization ################
+
+# Values for $order. See GNU getopt.c for details.
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+# Version major/minor numbers.
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+
+ConfigDefaults();
+
+################ OO Interface ################
+
+package Getopt::Long::Parser;
+
+# Store a copy of the default configuration. Since ConfigDefaults has
+# just been called, what we get from Configure is the default.
+my $default_config = do {
+ Getopt::Long::Configure ()
+};
+
+sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my %atts = @_;
+
+ # Register the callers package.
+ my $self = { caller_pkg => (caller)[0] };
+
+ bless ($self, $class);
+
+ # Process config attributes.
+ if ( defined $atts{config} ) {
+ my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
+ $self->{settings} = Getopt::Long::Configure ($save);
+ delete ($atts{config});
+ }
+ # Else use default config.
+ else {
+ $self->{settings} = $default_config;
+ }
+
+ if ( %atts ) { # Oops
+ die(__PACKAGE__.": unhandled attributes: ".
+ join(" ", sort(keys(%atts)))."\n");
+ }
+
+ $self;
+}
+
+sub configure {
+ my ($self) = shift;
+
+ # Restore settings, merge new settings in.
+ my $save = Getopt::Long::Configure ($self->{settings}, @_);
+
+ # Restore orig config and save the new config.
+ $self->{settings} = Getopt::Long::Configure ($save);
+}
+
+sub getoptions {
+ my ($self) = shift;
+
+ # Restore config settings.
+ my $save = Getopt::Long::Configure ($self->{settings});
+
+ # Call main routine.
+ my $ret = 0;
+ $Getopt::Long::caller = $self->{caller_pkg};
+
+ eval {
+ # Locally set exception handler to default, otherwise it will
+ # be called implicitly here, and again explicitly when we try
+ # to deliver the messages.
+ local ($SIG{__DIE__}) = 'DEFAULT';
+ $ret = Getopt::Long::GetOptions (@_);
+ };
+
+ # Restore saved settings.
+ Getopt::Long::Configure ($save);
+
+ # Handle errors and return value.
+ die ($@) if $@;
+ return $ret;
+}
+
+package Getopt::Long;
+
+################ Back to Normal ################
+
+# Indices in option control info.
+# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
+use constant CTL_TYPE => 0;
+#use constant CTL_TYPE_FLAG => '';
+#use constant CTL_TYPE_NEG => '!';
+#use constant CTL_TYPE_INCR => '+';
+#use constant CTL_TYPE_INT => 'i';
+#use constant CTL_TYPE_INTINC => 'I';
+#use constant CTL_TYPE_XINT => 'o';
+#use constant CTL_TYPE_FLOAT => 'f';
+#use constant CTL_TYPE_STRING => 's';
+
+use constant CTL_CNAME => 1;
+
+use constant CTL_DEFAULT => 2;
+
+use constant CTL_DEST => 3;
+ use constant CTL_DEST_SCALAR => 0;
+ use constant CTL_DEST_ARRAY => 1;
+ use constant CTL_DEST_HASH => 2;
+ use constant CTL_DEST_CODE => 3;
+
+use constant CTL_AMIN => 4;
+use constant CTL_AMAX => 5;
+
+# FFU.
+#use constant CTL_RANGE => ;
+#use constant CTL_REPEAT => ;
+
+# Rather liberal patterns to match numbers.
+use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
+use constant PAT_XINT =>
+ "(?:".
+ "[-+]?_*[1-9][0-9_]*".
+ "|".
+ "0x_*[0-9a-f][0-9a-f_]*".
+ "|".
+ "0b_*[01][01_]*".
+ "|".
+ "0[0-7_]*".
+ ")";
+use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
+
+sub GetOptions(@) {
+ # Shift in default array.
+ unshift(@_, \@ARGV);
+ # Try to keep caller() and Carp consitent.
+ goto &GetOptionsFromArray;
+}
+
+sub GetOptionsFromString(@) {
+ my ($string) = shift;
+ require Text::ParseWords;
+ my $args = [ Text::ParseWords::shellwords($string) ];
+ $caller ||= (caller)[0]; # current context
+ my $ret = GetOptionsFromArray($args, @_);
+ return ( $ret, $args ) if wantarray;
+ if ( @$args ) {
+ $ret = 0;
+ warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
+ }
+ $ret;
+}
+
+sub GetOptionsFromArray(@) {
+
+ my ($argv, @optionlist) = @_; # local copy of the option descriptions
+ my $argend = '--'; # option list terminator
+ my %opctl = (); # table of option specs
+ my $pkg = $caller || (caller)[0]; # current context
+ # Needed if linkage is omitted.
+ my @ret = (); # accum for non-options
+ my %linkage; # linkage
+ my $userlinkage; # user supplied HASH
+ my $opt; # current option
+ my $prefix = $genprefix; # current prefix
+
+ $error = '';
+
+ if ( $debug ) {
+ # Avoid some warnings if debugging.
+ local ($^W) = 0;
+ print STDERR
+ ("Getopt::Long $Getopt::Long::VERSION (",
+ '$Revision: 2.76 $', ") ",
+ "called from package \"$pkg\".",
+ "\n ",
+ "argv: (@$argv)",
+ "\n ",
+ "autoabbrev=$autoabbrev,".
+ "bundling=$bundling,",
+ "getopt_compat=$getopt_compat,",
+ "gnu_compat=$gnu_compat,",
+ "order=$order,",
+ "\n ",
+ "ignorecase=$ignorecase,",
+ "requested_version=$requested_version,",
+ "passthrough=$passthrough,",
+ "genprefix=\"$genprefix\",",
+ "longprefix=\"$longprefix\".",
+ "\n");
+ }
+
+ # Check for ref HASH as first argument.
+ # First argument may be an object. It's OK to use this as long
+ # as it is really a hash underneath.
+ $userlinkage = undef;
+ if ( @optionlist && ref($optionlist[0]) and
+ UNIVERSAL::isa($optionlist[0],'HASH') ) {
+ $userlinkage = shift (@optionlist);
+ print STDERR ("=> user linkage: $userlinkage\n") if $debug;
+ }
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ # Be careful not to interpret '<>' as option starters.
+ if ( @optionlist && $optionlist[0] =~ /^\W+$/
+ && !($optionlist[0] eq '<>'
+ && @optionlist > 0
+ && ref($optionlist[1])) ) {
+ $prefix = shift (@optionlist);
+ # Turn into regexp. Needs to be parenthesized!
+ $prefix =~ s/(\W)/\\$1/g;
+ $prefix = "([" . $prefix . "])";
+ print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
+ }
+
+ # Verify correctness of optionlist.
+ %opctl = ();
+ while ( @optionlist ) {
+ my $opt = shift (@optionlist);
+
+ unless ( defined($opt) ) {
+ $error .= "Undefined argument in option spec\n";
+ next;
+ }
+
+ # Strip leading prefix so people can specify "--foo=i" if they like.
+ $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
+
+ if ( $opt eq '<>' ) {
+ if ( (defined $userlinkage)
+ && !(@optionlist > 0 && ref($optionlist[0]))
+ && (exists $userlinkage->{$opt})
+ && ref($userlinkage->{$opt}) ) {
+ unshift (@optionlist, $userlinkage->{$opt});
+ }
+ unless ( @optionlist > 0
+ && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
+ $error .= "Option spec <> requires a reference to a subroutine\n";
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
+ next;
+ }
+ $linkage{'<>'} = shift (@optionlist);
+ next;
+ }
+
+ # Parse option spec.
+ my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
+ unless ( defined $name ) {
+ # Failed. $orig contains the error message. Sorry for the abuse.
+ $error .= $orig;
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
+ next;
+ }
+
+ # If no linkage is supplied in the @optionlist, copy it from
+ # the userlinkage if available.
+ if ( defined $userlinkage ) {
+ unless ( @optionlist > 0 && ref($optionlist[0]) ) {
+ if ( exists $userlinkage->{$orig} &&
+ ref($userlinkage->{$orig}) ) {
+ print STDERR ("=> found userlinkage for \"$orig\": ",
+ "$userlinkage->{$orig}\n")
+ if $debug;
+ unshift (@optionlist, $userlinkage->{$orig});
+ }
+ else {
+ # Do nothing. Being undefined will be handled later.
+ next;
+ }
+ }
+ }
+
+ # Copy the linkage. If omitted, link to global variable.
+ if ( @optionlist > 0 && ref($optionlist[0]) ) {
+ print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
+ if $debug;
+ my $rl = ref($linkage{$orig} = shift (@optionlist));
+
+ if ( $rl eq "ARRAY" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
+ }
+ elsif ( $rl eq "HASH" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
+ }
+ elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
+# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+# my $t = $linkage{$orig};
+# $$t = $linkage{$orig} = [];
+# }
+# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+# }
+# else {
+ # Ok.
+# }
+ }
+ elsif ( $rl eq "CODE" ) {
+ # Ok.
+ }
+ else {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+ }
+ else {
+ # Link to global $opt_XXX variable.
+ # Make sure a valid perl identifier results.
+ my $ov = $orig;
+ $ov =~ s/\W/_/g;
+ if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
+ }
+ elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
+ }
+ else {
+ print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
+ }
+ }
+
+ if ( $opctl{$name}[CTL_TYPE] eq 'I'
+ && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
+ || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
+ ) {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+
+ }
+
+ # Bail out if errors found.
+ die ($error) if $error;
+ $error = 0;
+
+ # Supply --version and --help support, if needed and allowed.
+ if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{version}) ) {
+ $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
+ $linkage{version} = \&VersionMessage;
+ }
+ $auto_version = 1;
+ }
+ if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
+ $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
+ $linkage{help} = \&HelpMessage;
+ }
+ $auto_help = 1;
+ }
+
+ # Show the options tables if debugging.
+ if ( $debug ) {
+ my ($arrow, $k, $v);
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%opctl) ) {
+ print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
+ $arrow = " ";
+ }
+ }
+
+ # Process argument list
+ my $goon = 1;
+ while ( $goon && @$argv > 0 ) {
+
+ # Get next argument.
+ $opt = shift (@$argv);
+ print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
+
+ # Double dash is option list terminator.
+ if ( $opt eq $argend ) {
+ push (@ret, $argend) if $passthrough;
+ last;
+ }
+
+ # Look it up.
+ my $tryopt = $opt;
+ my $found; # success status
+ my $key; # key (if hash type)
+ my $arg; # option argument
+ my $ctl; # the opctl entry
+
+ ($found, $opt, $ctl, $arg, $key) =
+ FindOption ($argv, $prefix, $argend, $opt, \%opctl);
+
+ if ( $found ) {
+
+ # FindOption undefines $opt in case of errors.
+ next unless defined $opt;
+
+ my $argcnt = 0;
+ while ( defined $arg ) {
+
+ # Get the canonical name.
+ print STDERR ("=> cname for \"$opt\" is ") if $debug;
+ $opt = $ctl->[CTL_CNAME];
+ print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
+
+ if ( defined $linkage{$opt} ) {
+ print STDERR ("=> ref(\$L{$opt}) -> ",
+ ref($linkage{$opt}), "\n") if $debug;
+
+ if ( ref($linkage{$opt}) eq 'SCALAR'
+ || ref($linkage{$opt}) eq 'REF' ) {
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined ${$linkage{$opt}} ) {
+ ${$linkage{$opt}} += $arg;
+ }
+ else {
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to ARRAY\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = [];
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to HASH\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = {};
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
+ if $debug;
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( ref($linkage{$opt}) eq 'HASH' ) {
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ elsif ( ref($linkage{$opt}) eq 'CODE' ) {
+ print STDERR ("=> &L{$opt}(\"$opt\"",
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
+ ", \"$arg\")\n")
+ if $debug;
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = 'DEFAULT';
+ eval {
+ &{$linkage{$opt}}
+ (Getopt::Long::CallBack->new
+ (name => $opt,
+ ctl => $ctl,
+ opctl => \%opctl,
+ linkage => \%linkage,
+ prefix => $prefix,
+ ),
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
+ $arg);
+ };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
+ "\" in linkage\n");
+ die("Getopt::Long -- internal error!\n");
+ }
+ }
+ # No entry in linkage means entry in userlinkage.
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
+ if $debug;
+ push (@{$userlinkage->{$opt}}, $arg);
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
+ if $debug;
+ $userlinkage->{$opt} = [$arg];
+ }
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $userlinkage->{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
+ if $debug;
+ $userlinkage->{$opt} = {$key => $arg};
+ }
+ }
+ else {
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ print STDERR ("=> \$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined $userlinkage->{$opt} ) {
+ $userlinkage->{$opt} += $arg;
+ }
+ else {
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+
+ $argcnt++;
+ last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
+ undef($arg);
+
+ # Need more args?
+ if ( $argcnt < $ctl->[CTL_AMIN] ) {
+ if ( @$argv ) {
+ if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
+ $arg = shift(@$argv);
+ $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
+ }
+ warn("Value \"$$argv[0]\" invalid for option $opt\n");
+ $error++;
+ }
+ else {
+ warn("Insufficient arguments for option $opt\n");
+ $error++;
+ }
+ }
+
+ # Any more args?
+ if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
+ $arg = shift(@$argv);
+ $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
+ }
+ }
+ }
+
+ # Not an option. Save it if we $PERMUTE and don't have a <>.
+ elsif ( $order == $PERMUTE ) {
+ # Try non-options call-back.
+ my $cb;
+ if ( (defined ($cb = $linkage{'<>'})) ) {
+ print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
+ if $debug;
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = 'DEFAULT';
+ eval {
+ &$cb
+ (Getopt::Long::CallBack->new
+ (name => $tryopt,
+ ctl => $ctl,
+ opctl => \%opctl,
+ linkage => \%linkage,
+ prefix => $prefix,
+ ));
+ };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("=> saving \"$tryopt\" ",
+ "(not an option, may permute)\n") if $debug;
+ push (@ret, $tryopt);
+ }
+ next;
+ }
+
+ # ...otherwise, terminate.
+ else {
+ # Push this one back and exit.
+ unshift (@$argv, $tryopt);
+ return ($error == 0);
+ }
+
+ }
+
+ # Finish.
+ if ( @ret && $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug;
+ unshift (@$argv, @ret);
+ }
+
+ return ($error == 0);
+}
+
+# A readable representation of what's in an optbl.
+sub OptCtl ($) {
+ my ($v) = @_;
+ my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
+ "[".
+ join(",",
+ "\"$v[CTL_TYPE]\"",
+ "\"$v[CTL_CNAME]\"",
+ "\"$v[CTL_DEFAULT]\"",
+ ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
+ $v[CTL_AMIN] || '',
+ $v[CTL_AMAX] || '',
+# $v[CTL_RANGE] || '',
+# $v[CTL_REPEAT] || '',
+ ). "]";
+}
+
+# Parse an option specification and fill the tables.
+sub ParseOptionSpec ($$) {
+ my ($opt, $opctl) = @_;
+
+ # Match option spec.
+ if ( $opt !~ m;^
+ (
+ # Option name
+ (?: \w+[-\w]* )
+ # Alias names, or "?"
+ (?: \| (?: \? | \w[-\w]* ) )*
+ )?
+ (
+ # Either modifiers ...
+ [!+]
+ |
+ # ... or a value/dest/repeat specification
+ [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
+ |
+ # ... or an optional-with-default spec
+ : (?: -?\d+ | \+ ) [@%]?
+ )?
+ $;x ) {
+ return (undef, "Error in option spec: \"$opt\"\n");
+ }
+
+ my ($names, $spec) = ($1, $2);
+ $spec = '' unless defined $spec;
+
+ # $orig keeps track of the primary name the user specified.
+ # This name will be used for the internal or external linkage.
+ # In other words, if the user specifies "FoO|BaR", it will
+ # match any case combinations of 'foo' and 'bar', but if a global
+ # variable needs to be set, it will be $opt_FoO in the exact case
+ # as specified.
+ my $orig;
+
+ my @names;
+ if ( defined $names ) {
+ @names = split (/\|/, $names);
+ $orig = $names[0];
+ }
+ else {
+ @names = ('');
+ $orig = '';
+ }
+
+ # Construct the opctl entries.
+ my $entry;
+ if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
+ # Fields are hard-wired here.
+ $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
+ }
+ elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
+ my $def = $1;
+ my $dest = $2;
+ my $type = $def eq '+' ? 'I' : 'i';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,$def eq '+' ? undef : $def,
+ $dest,0,1];
+ }
+ else {
+ my ($mand, $type, $dest) =
+ $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
+ return (undef, "Cannot repeat while bundling: \"$opt\"\n")
+ if $bundling && defined($4);
+ my ($mi, $cm, $ma) = ($5, $6, $7);
+ return (undef, "{0} is useless in option spec: \"$opt\"\n")
+ if defined($mi) && !$mi && !defined($ma) && !defined($cm);
+
+ $type = 'i' if $type eq 'n';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Default minargs to 1/0 depending on mand status.
+ $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
+ # Adjust mand status according to minargs.
+ $mand = $mi ? '=' : ':';
+ # Adjust maxargs.
+ $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
+ return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
+ if defined($ma) && !$ma;
+ return (undef, "Max less than min in option spec: \"$opt\"\n")
+ if defined($ma) && $ma < $mi;
+
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
+ }
+
+ # Process all names. First is canonical, the rest are aliases.
+ my $dups = '';
+ foreach ( @names ) {
+
+ $_ = lc ($_)
+ if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
+
+ if ( exists $opctl->{$_} ) {
+ $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
+ }
+
+ if ( $spec eq '!' ) {
+ $opctl->{"no$_"} = $entry;
+ $opctl->{"no-$_"} = $entry;
+ $opctl->{$_} = [@$entry];
+ $opctl->{$_}->[CTL_TYPE] = '';
+ }
+ else {
+ $opctl->{$_} = $entry;
+ }
+ }
+
+ if ( $dups && $^W ) {
+ foreach ( split(/\n+/, $dups) ) {
+ warn($_."\n");
+ }
+ }
+ ($names[0], $orig);
+}
+
+# Option lookup.
+sub FindOption ($$$$$) {
+
+ # returns (1, $opt, $ctl, $arg, $key) if okay,
+ # returns (1, undef) if option in error,
+ # returns (0) otherwise.
+
+ my ($argv, $prefix, $argend, $opt, $opctl) = @_;
+
+ print STDERR ("=> find \"$opt\"\n") if $debug;
+
+ return (0) unless $opt =~ /^$prefix(.*)$/s;
+ return (0) if $opt eq "-" && !defined $opctl->{''};
+
+ $opt = $+;
+ my $starter = $1;
+
+ print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
+
+ my $optarg; # value supplied with --opt=value
+ my $rest; # remainder from unbundling
+
+ # If it is a long option, it may include the value.
+ # With getopt_compat, only if not bundling.
+ if ( ($starter=~/^$longprefix$/
+ || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
+ $opt = $1;
+ $optarg = $2;
+ print STDERR ("=> option \"", $opt,
+ "\", optarg = \"$optarg\"\n") if $debug;
+ }
+
+ #### Look it up ###
+
+ my $tryopt = $opt; # option to try
+
+ if ( $bundling && $starter eq '-' ) {
+
+ # To try overrides, obey case ignore.
+ $tryopt = $ignorecase ? lc($opt) : $opt;
+
+ # If bundling == 2, long options can override bundles.
+ if ( $bundling == 2 && length($tryopt) > 1
+ && defined ($opctl->{$tryopt}) ) {
+ print STDERR ("=> $starter$tryopt overrides unbundling\n")
+ if $debug;
+ }
+ else {
+ $tryopt = $opt;
+ # Unbundle single letter option.
+ $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
+ $tryopt = substr ($tryopt, 0, 1);
+ $tryopt = lc ($tryopt) if $ignorecase > 1;
+ print STDERR ("=> $starter$tryopt unbundled from ",
+ "$starter$tryopt$rest\n") if $debug;
+ $rest = undef unless $rest ne '';
+ }
+ }
+
+ # Try auto-abbreviation.
+ elsif ( $autoabbrev && $opt ne "" ) {
+ # Sort the possible long option names.
+ my @names = sort(keys (%$opctl));
+ # Downcase if allowed.
+ $opt = lc ($opt) if $ignorecase;
+ $tryopt = $opt;
+ # Turn option name into pattern.
+ my $pat = quotemeta ($opt);
+ # Look up in option names.
+ my @hits = grep (/^$pat/, @names);
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "out of ", scalar(@names), "\n") if $debug;
+
+ # Check for ambiguous results.
+ unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
+ # See if all matches are for the same option.
+ my %hit;
+ foreach ( @hits ) {
+ my $hit = $_;
+ $hit = $opctl->{$hit}->[CTL_CNAME]
+ if defined $opctl->{$hit}->[CTL_CNAME];
+ $hit{$hit} = 1;
+ }
+ # Remove auto-supplied options (version, help).
+ if ( keys(%hit) == 2 ) {
+ if ( $auto_version && exists($hit{version}) ) {
+ delete $hit{version};
+ }
+ elsif ( $auto_help && exists($hit{help}) ) {
+ delete $hit{help};
+ }
+ }
+ # Now see if it really is ambiguous.
+ unless ( keys(%hit) == 1 ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " is ambiguous (",
+ join(", ", @hits), ")\n");
+ $error++;
+ return (1, undef);
+ }
+ @hits = keys(%hit);
+ }
+
+ # Complete the option name, if appropriate.
+ if ( @hits == 1 && $hits[0] ne $opt ) {
+ $tryopt = $hits[0];
+ $tryopt = lc ($tryopt) if $ignorecase;
+ print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+ if $debug;
+ }
+ }
+
+ # Map to all lowercase if ignoring case.
+ elsif ( $ignorecase ) {
+ $tryopt = lc ($opt);
+ }
+
+ # Check validity by fetching the info.
+ my $ctl = $opctl->{$tryopt};
+ unless ( defined $ctl ) {
+ return (0) if $passthrough;
+ # Pretend one char when bundling.
+ if ( $bundling == 1 && length($starter) == 1 ) {
+ $opt = substr($opt,0,1);
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ }
+ if ( $opt eq "" ) {
+ warn ("Missing option after ", $starter, "\n");
+ }
+ else {
+ warn ("Unknown option: ", $opt, "\n");
+ }
+ $error++;
+ return (1, undef);
+ }
+ # Apparently valid.
+ $opt = $tryopt;
+ print STDERR ("=> found ", OptCtl($ctl),
+ " for \"", $opt, "\"\n") if $debug;
+
+ #### Determine argument status ####
+
+ # If it is an option w/o argument, we're almost finished with it.
+ my $type = $ctl->[CTL_TYPE];
+ my $arg;
+
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
+ if ( defined $optarg ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " does not take an argument\n");
+ $error++;
+ undef $opt;
+ }
+ elsif ( $type eq '' || $type eq '+' ) {
+ # Supply explicit value.
+ $arg = 1;
+ }
+ else {
+ $opt =~ s/^no-?//i; # strip NO prefix
+ $arg = 0; # supply explicit value
+ }
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, $opt, $ctl, $arg);
+ }
+
+ # Get mandatory status and type info.
+ my $mand = $ctl->[CTL_AMIN];
+
+ # Check if there is an option argument available.
+ if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
+ return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
+ $optarg = 0 unless $type eq 's';
+ }
+
+ # Check if there is an option argument available.
+ if ( defined $optarg
+ ? ($optarg eq '')
+ : !(defined $rest || @$argv > 0) ) {
+ # Complain if this option needs an argument.
+# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
+ if ( $mand ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " requires an argument\n");
+ $error++;
+ return (1, undef);
+ }
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
+ }
+ return (1, $opt, $ctl,
+ defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ $type eq 's' ? '' : 0);
+ }
+
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@$argv)));
+
+ # Get key if this is a "name=value" pair for a hash option.
+ my $key;
+ if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
+ ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
+ : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ ($mand ? undef : ($type eq 's' ? "" : 1)));
+ if (! defined $arg) {
+ warn ("Option $opt, key \"$key\", requires a value\n");
+ $error++;
+ # Push back.
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ }
+
+ #### Check if the argument is valid for this option ####
+
+ my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
+
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1, $opt, $ctl, $arg, $key) if $mand;
+
+ # Same for optional string as a hash value
+ return (1, $opt, $ctl, $arg, $key)
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+
+ # An optional string takes almost anything.
+ return (1, $opt, $ctl, $arg, $key)
+ if defined $optarg || defined $rest;
+ return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
+
+ # Check for option or option list terminator.
+ if ($arg eq $argend ||
+ $arg =~ /^$prefix.+/) {
+ # Push back.
+ unshift (@$argv, $arg);
+ # Supply empty value.
+ $arg = '';
+ }
+ }
+
+ elsif ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
+
+ my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
+
+ if ( $bundling && defined $rest
+ && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg =~ /^$o_valid$/si ) {
+ $arg =~ tr/_//d;
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ }
+ else {
+ if ( defined $optarg || $mand ) {
+ if ( $passthrough ) {
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (",
+ $type eq 'o' ? "extended " : '',
+ "number expected)\n");
+ $error++;
+ # Push back.
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ else {
+ # Push back.
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg);
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
+ }
+ # Supply default value.
+ $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
+ }
+ }
+ }
+
+ elsif ( $type eq 'f' ) { # real number, int is also ok
+ # We require at least one digit before a point or 'e',
+ # and at least one digit following the point and 'e'.
+ # [-]NN[.NN][eNN]
+ my $o_valid = PAT_FLOAT;
+ if ( $bundling && defined $rest &&
+ $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
+ $arg =~ tr/_//d;
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg =~ /^$o_valid$/ ) {
+ $arg =~ tr/_//d;
+ }
+ else {
+ if ( defined $optarg || $mand ) {
+ if ( $passthrough ) {
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ # Push back.
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ else {
+ # Push back.
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0.0;
+ }
+ }
+ }
+ else {
+ die("Getopt::Long internal error (Can't happen)\n");
+ }
+ return (1, $opt, $ctl, $arg, $key);
+}
+
+sub ValidValue ($$$$$) {
+ my ($ctl, $arg, $mand, $argend, $prefix) = @_;
+
+ if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ return 0 unless $arg =~ /[^=]+=(.*)/;
+ $arg = $1;
+ }
+
+ my $type = $ctl->[CTL_TYPE];
+
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1) if $mand;
+
+ return (1) if $arg eq "-";
+
+ # Check for option or option list terminator.
+ return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
+ return 1;
+ }
+
+ elsif ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
+
+ my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
+ return $arg =~ /^$o_valid$/si;
+ }
+
+ elsif ( $type eq 'f' ) { # real number, int is also ok
+ # We require at least one digit before a point or 'e',
+ # and at least one digit following the point and 'e'.
+ # [-]NN[.NN][eNN]
+ my $o_valid = PAT_FLOAT;
+ return $arg =~ /^$o_valid$/;
+ }
+ die("ValidValue: Cannot happen\n");
+}
+
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
+
+ my $prevconfig =
+ [ $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ];
+
+ if ( ref($options[0]) eq 'ARRAY' ) {
+ ( $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ) = @{shift(@options)};
+ }
+
+ my $opt;
+ foreach $opt ( @options ) {
+ my $try = lc ($opt);
+ my $action = 1;
+ if ( $try =~ /^no_?(.*)$/s ) {
+ $action = 0;
+ $try = $+;
+ }
+ if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
+ ConfigDefaults ();
+ }
+ elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
+ local $ENV{POSIXLY_CORRECT};
+ $ENV{POSIXLY_CORRECT} = 1 if $action;
+ ConfigDefaults ();
+ }
+ elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+ $autoabbrev = $action;
+ }
+ elsif ( $try eq 'getopt_compat' ) {
+ $getopt_compat = $action;
+ $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
+ }
+ elsif ( $try eq 'gnu_getopt' ) {
+ if ( $action ) {
+ $gnu_compat = 1;
+ $bundling = 1;
+ $getopt_compat = 0;
+ $genprefix = "(--|-)";
+ $order = $PERMUTE;
+ }
+ }
+ elsif ( $try eq 'gnu_compat' ) {
+ $gnu_compat = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?version$/ ) {
+ $auto_version = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?help$/ ) {
+ $auto_help = $action;
+ }
+ elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+ $ignorecase = $action;
+ }
+ elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
+ $ignorecase = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'bundling' ) {
+ $bundling = $action;
+ }
+ elsif ( $try eq 'bundling_override' ) {
+ $bundling = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'require_order' ) {
+ $order = $action ? $REQUIRE_ORDER : $PERMUTE;
+ }
+ elsif ( $try eq 'permute' ) {
+ $order = $action ? $PERMUTE : $REQUIRE_ORDER;
+ }
+ elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
+ $passthrough = $action;
+ }
+ elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
+ $genprefix = $1;
+ # Turn into regexp. Needs to be parenthesized!
+ $genprefix = "(" . quotemeta($genprefix) . ")";
+ eval { '' =~ /$genprefix/; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
+ $genprefix = $1;
+ # Parenthesize if needed.
+ $genprefix = "(" . $genprefix . ")"
+ unless $genprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$genprefix"; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
+ $longprefix = $1;
+ # Parenthesize if needed.
+ $longprefix = "(" . $longprefix . ")"
+ unless $longprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$longprefix"; };
+ die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
+ }
+ elsif ( $try eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ die("Getopt::Long: unknown config parameter \"$opt\"")
+ }
+ }
+ $prevconfig;
+}
+
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
+}
+
+# Issue a standard message for --version.
+#
+# The arguments are mostly the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub VersionMessage(@) {
+ # Massage args.
+ my $pa = setup_pa_args("version", @_);
+
+ my $v = $main::VERSION;
+ my $fh = $pa->{-output} ||
+ ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
+
+ print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
+ $0, defined $v ? " version $v" : (),
+ "\n",
+ "(", __PACKAGE__, "::", "GetOptions",
+ " version ",
+ defined($Getopt::Long::VERSION_STRING)
+ ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
+ " Perl version ",
+ $] >= 5.006 ? sprintf("%vd", $^V) : $],
+ ")\n");
+ exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
+}
+
+# Issue a standard message for --help.
+#
+# The arguments are the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub HelpMessage(@) {
+ eval {
+ require Pod::Usage;
+ import Pod::Usage;
+ 1;
+ } || die("Cannot provide help: cannot load Pod::Usage\n");
+
+ # Note that pod2usage will issue a warning if -exitval => NOEXIT.
+ pod2usage(setup_pa_args("help", @_));
+
+}
+
+# Helper routine to set up a normalized hash ref to be used as
+# argument to pod2usage.
+sub setup_pa_args($@) {
+ my $tag = shift; # who's calling
+
+ # If called by direct binding to an option, it will get the option
+ # name and value as arguments. Remove these, if so.
+ @_ = () if @_ == 2 && $_[0] eq $tag;
+
+ my $pa;
+ if ( @_ > 1 ) {
+ $pa = { @_ };
+ }
+ else {
+ $pa = shift || {};
+ }
+
+ # At this point, $pa can be a number (exit value), string
+ # (message) or hash with options.
+
+ if ( UNIVERSAL::isa($pa, 'HASH') ) {
+ # Get rid of -msg vs. -message ambiguity.
+ $pa->{-message} = $pa->{-msg};
+ delete($pa->{-msg});
+ }
+ elsif ( $pa =~ /^-?\d+$/ ) {
+ $pa = { -exitval => $pa };
+ }
+ else {
+ $pa = { -message => $pa };
+ }
+
+ # These are _our_ defaults.
+ $pa->{-verbose} = 0 unless exists($pa->{-verbose});
+ $pa->{-exitval} = 0 unless exists($pa->{-exitval});
+ $pa;
+}
+
+# Sneak way to know what version the user requested.
+sub VERSION {
+ $requested_version = $_[1];
+ shift->SUPER::VERSION(@_);
+}
+
+package Getopt::Long::CallBack;
+
+sub new {
+ my ($pkg, %atts) = @_;
+ bless { %atts }, $pkg;
+}
+
+sub name {
+ my $self = shift;
+ ''.$self->{name};
+}
+
+use overload
+ # Treat this object as an ordinary string for legacy API.
+ '""' => \&name,
+ fallback => 1;
+
+1;
+
+################ Documentation ################
+
+=head1 NAME
+
+Getopt::Long - Extended processing of command line options
+
+=head1 SYNOPSIS
+
+ use Getopt::Long;
+ my $data = "file.dat";
+ my $length = 24;
+ my $verbose;
+ $result = GetOptions ("length=i" => \$length, # numeric
+ "file=s" => \$data, # string
+ "verbose" => \$verbose); # flag
+
+=head1 DESCRIPTION
+
+The Getopt::Long module implements an extended getopt function called
+GetOptions(). This function adheres to the POSIX syntax for command
+line options, with GNU extensions. In general, this means that options
+have long names instead of single letters, and are introduced with a
+double dash "--". Support for bundling of command line options, as was
+the case with the more traditional single-letter approach, is provided
+but not enabled by default.
+
+=head1 Command Line Options, an Introduction
+
+Command line operated programs traditionally take their arguments from
+the command line, for example filenames or other information that the
+program needs to know. Besides arguments, these programs often take
+command line I<options> as well. Options are not necessary for the
+program to work, hence the name 'option', but are used to modify its
+default behaviour. For example, a program could do its job quietly,
+but with a suitable option it could provide verbose information about
+what it did.
+
+Command line options come in several flavours. Historically, they are
+preceded by a single dash C<->, and consist of a single letter.
+
+ -l -a -c
+
+Usually, these single-character options can be bundled:
+
+ -lac
+
+Options can have values, the value is placed after the option
+character. Sometimes with whitespace in between, sometimes not:
+
+ -s 24 -s24
+
+Due to the very cryptic nature of these options, another style was
+developed that used long names. So instead of a cryptic C<-l> one
+could use the more descriptive C<--long>. To distinguish between a
+bundle of single-character options and a long one, two dashes are used
+to precede the option name. Early implementations of long options used
+a plus C<+> instead. Also, option values could be specified either
+like
+
+ --size=24
+
+or
+
+ --size 24
+
+The C<+> form is now obsolete and strongly deprecated.
+
+=head1 Getting Started with Getopt::Long
+
+Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
+first Perl module that provided support for handling the new style of
+command line options, hence the name Getopt::Long. This module also
+supports single-character options and bundling. Single character
+options may be any alphabetic character, a question mark, and a dash.
+Long options may consist of a series of letters, digits, and dashes.
+Although this is currently not enforced by Getopt::Long, multiple
+consecutive dashes are not allowed, and the option name must not end
+with a dash.
+
+To use Getopt::Long from a Perl program, you must include the
+following line in your Perl program:
+
+ use Getopt::Long;
+
+This will load the core of the Getopt::Long module and prepare your
+program for using it. Most of the actual Getopt::Long code is not
+loaded until you really call one of its functions.
+
+In the default configuration, options names may be abbreviated to
+uniqueness, case does not matter, and a single dash is sufficient,
+even for long option names. Also, options may be placed between
+non-option arguments. See L<Configuring Getopt::Long> for more
+details on how to configure Getopt::Long.
+
+=head2 Simple options
+
+The most simple options are the ones that take no values. Their mere
+presence on the command line enables the option. Popular examples are:
+
+ --all --verbose --quiet --debug
+
+Handling simple options is straightforward:
+
+ my $verbose = ''; # option variable with default value (false)
+ my $all = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose, 'all' => \$all);
+
+The call to GetOptions() parses the command line arguments that are
+present in C<@ARGV> and sets the option variable to the value C<1> if
+the option did occur on the command line. Otherwise, the option
+variable is not touched. Setting the option value to true is often
+called I<enabling> the option.
+
+The option name as specified to the GetOptions() function is called
+the option I<specification>. Later we'll see that this specification
+can contain more than just the option name. The reference to the
+variable is called the option I<destination>.
+
+GetOptions() will return a true value if the command line could be
+processed successfully. Otherwise, it will write error messages to
+STDERR, and return a false result.
+
+=head2 A little bit less simple options
+
+Getopt::Long supports two useful variants of simple options:
+I<negatable> options and I<incremental> options.
+
+A negatable option is specified with an exclamation mark C<!> after the
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose!' => \$verbose);
+
+Now, using C<--verbose> on the command line will enable C<$verbose>,
+as expected. But it is also allowed to use C<--noverbose>, which will
+disable C<$verbose> by setting its value to C<0>. Using a suitable
+default value, the program can find out whether C<$verbose> is false
+by default, or disabled by using C<--noverbose>.
+
+An incremental option is specified with a plus C<+> after the
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose+' => \$verbose);
+
+Using C<--verbose> on the command line will increment the value of
+C<$verbose>. This way the program can keep track of how many times the
+option occurred on the command line. For example, each occurrence of
+C<--verbose> could increase the verbosity level of the program.
+
+=head2 Mixing command line option with other arguments
+
+Usually programs take command line options as well as other arguments,
+for example, file names. It is good practice to always specify the
+options first, and the other arguments last. Getopt::Long will,
+however, allow the options and arguments to be mixed and 'filter out'
+all the options before passing the rest of the arguments to the
+program. To stop Getopt::Long from processing further arguments,
+insert a double dash C<--> on the command line:
+
+ --size 24 -- --all
+
+In this example, C<--all> will I<not> be treated as an option, but
+passed to the program unharmed, in C<@ARGV>.
+
+=head2 Options with values
+
+For options that take values it must be specified whether the option
+value is required or not, and what kind of value the option expects.
+
+Three kinds of values are supported: integer numbers, floating point
+numbers, and strings.
+
+If the option value is required, Getopt::Long will take the
+command line argument that follows the option and assign this to the
+option variable. If, however, the option value is specified as
+optional, this will only be done if that value does not look like a
+valid command line option itself.
+
+ my $tag = ''; # option variable with default value
+ GetOptions ('tag=s' => \$tag);
+
+In the option specification, the option name is followed by an equals
+sign C<=> and the letter C<s>. The equals sign indicates that this
+option requires a value. The letter C<s> indicates that this value is
+an arbitrary string. Other possible value types are C<i> for integer
+values, and C<f> for floating point values. Using a colon C<:> instead
+of the equals sign indicates that the option value is optional. In
+this case, if no suitable value is supplied, string valued options get
+an empty string C<''> assigned, while numeric options are set to C<0>.
+
+=head2 Options with multiple values
+
+Options sometimes take several values. For example, a program could
+use multiple directories to search for library files:
+
+ --library lib/stdlib --library lib/extlib
+
+To accomplish this behaviour, simply specify an array reference as the
+destination for the option:
+
+ GetOptions ("library=s" => \@libfiles);
+
+Alternatively, you can specify that the option can have multiple
+values by adding a "@", and pass a scalar reference as the
+destination:
+
+ GetOptions ("library=s@" => \$libfiles);
+
+Used with the example above, C<@libfiles> (or C<@$libfiles>) would
+contain two strings upon completion: C<"lib/srdlib"> and
+C<"lib/extlib">, in that order. It is also possible to specify that
+only integer or floating point numbers are acceptable values.
+
+Often it is useful to allow comma-separated lists of values as well as
+multiple occurrences of the options. This is easy using Perl's split()
+and join() operators:
+
+ GetOptions ("library=s" => \@libfiles);
+ @libfiles = split(/,/,join(',',@libfiles));
+
+Of course, it is important to choose the right separator string for
+each purpose.
+
+Warning: What follows is an experimental feature.
+
+Options can take multiple values at once, for example
+
+ --coordinates 52.2 16.4 --rgbcolor 255 255 149
+
+This can be accomplished by adding a repeat specifier to the option
+specification. Repeat specifiers are very similar to the C<{...}>
+repeat specifiers that can be used with regular expression patterns.
+For example, the above command line would be handled as follows:
+
+ GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
+
+The destination for the option must be an array or array reference.
+
+It is also possible to specify the minimal and maximal number of
+arguments an option takes. C<foo=s{2,4}> indicates an option that
+takes at least two and at most 4 arguments. C<foo=s{,}> indicates one
+or more values; C<foo:s{,}> indicates zero or more option values.
+
+=head2 Options with hash values
+
+If the option destination is a reference to a hash, the option will
+take, as value, strings of the form I<key>C<=>I<value>. The value will
+be stored with the specified key in the hash.
+
+ GetOptions ("define=s" => \%defines);
+
+Alternatively you can use:
+
+ GetOptions ("define=s%" => \$defines);
+
+When used with command line options:
+
+ --define os=linux --define vendor=redhat
+
+the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
+with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
+also possible to specify that only integer or floating point numbers
+are acceptable values. The keys are always taken to be strings.
+
+=head2 User-defined subroutines to handle options
+
+Ultimate control over what should be done when (actually: each time)
+an option is encountered on the command line can be achieved by
+designating a reference to a subroutine (or an anonymous subroutine)
+as the option destination. When GetOptions() encounters the option, it
+will call the subroutine with two or three arguments. The first
+argument is the name of the option. (Actually, it is an object that
+stringifies to the name of the option.) For a scalar or array destination,
+the second argument is the value to be stored. For a hash destination,
+the second arguments is the key to the hash, and the third argument
+the value to be stored. It is up to the subroutine to store the value,
+or do whatever it thinks is appropriate.
+
+A trivial application of this mechanism is to implement options that
+are related to each other. For example:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose,
+ 'quiet' => sub { $verbose = 0 });
+
+Here C<--verbose> and C<--quiet> control the same variable
+C<$verbose>, but with opposite values.
+
+If the subroutine needs to signal an error, it should call die() with
+the desired error message as its argument. GetOptions() will catch the
+die(), issue the error message, and record that an error result must
+be returned upon completion.
+
+If the text of the error message starts with an exclamation mark C<!>
+it is interpreted specially by GetOptions(). There is currently one
+special command implemented: C<die("!FINISH")> will cause GetOptions()
+to stop processing options, as if it encountered a double dash C<-->.
+
+In version 2.37 the first argument to the callback function was
+changed from string to object. This was done to make room for
+extensions and more detailed control. The object stringifies to the
+option name so this change should not introduce compatibility
+problems.
+
+=head2 Options with multiple names
+
+Often it is user friendly to supply alternate mnemonic names for
+options. For example C<--height> could be an alternate name for
+C<--length>. Alternate names can be included in the option
+specification, separated by vertical bar C<|> characters. To implement
+the above example:
+
+ GetOptions ('length|height=f' => \$length);
+
+The first name is called the I<primary> name, the other names are
+called I<aliases>. When using a hash to store options, the key will
+always be the primary name.
+
+Multiple alternate names are possible.
+
+=head2 Case and abbreviations
+
+Without additional configuration, GetOptions() will ignore the case of
+option names, and allow the options to be abbreviated to uniqueness.
+
+ GetOptions ('length|height=f' => \$length, "head" => \$head);
+
+This call will allow C<--l> and C<--L> for the length option, but
+requires a least C<--hea> and C<--hei> for the head and height options.
+
+=head2 Summary of Option Specifications
+
+Each option specifier consists of two parts: the name specification
+and the argument specification.
+
+The name specification contains the name of the option, optionally
+followed by a list of alternative names separated by vertical bar
+characters.
+
+ length option name is "length"
+ length|size|l name is "length", aliases are "size" and "l"
+
+The argument specification is optional. If omitted, the option is
+considered boolean, a value of 1 will be assigned when the option is
+used on the command line.
+
+The argument specification can be
+
+=over 4
+
+=item !
+
+The option does not take an argument and may be negated by prefixing
+it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
+1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
+0 will be assigned). If the option has aliases, this applies to the
+aliases as well.
+
+Using negation on a single letter option when bundling is in effect is
+pointless and will result in a warning.
+
+=item +
+
+The option does not take an argument and will be incremented by 1
+every time it appears on the command line. E.g. C<"more+">, when used
+with C<--more --more --more>, will increment the value three times,
+resulting in a value of 3 (provided it was 0 or undefined at first).
+
+The C<+> specifier is ignored if the option destination is not a scalar.
+
+=item = I<type> [ I<desttype> ] [ I<repeat> ]
+
+The option requires an argument of the given type. Supported types
+are:
+
+=over 4
+
+=item s
+
+String. An arbitrary sequence of characters. It is valid for the
+argument to start with C<-> or C<-->.
+
+=item i
+
+Integer. An optional leading plus or minus sign, followed by a
+sequence of digits.
+
+=item o
+
+Extended integer, Perl style. This can be either an optional leading
+plus or minus sign, followed by a sequence of digits, or an octal
+string (a zero, optionally followed by '0', '1', .. '7'), or a
+hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
+insensitive), or a binary string (C<0b> followed by a series of '0'
+and '1').
+
+=item f
+
+Real number. For example C<3.14>, C<-6.23E24> and so on.
+
+=back
+
+The I<desttype> can be C<@> or C<%> to specify that the option is
+list or a hash valued. This is only needed when the destination for
+the option value is not otherwise specified. It should be omitted when
+not needed.
+
+The I<repeat> specifies the number of values this option takes per
+occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
+
+I<min> denotes the minimal number of arguments. It defaults to 1 for
+options with C<=> and to 0 for options with C<:>, see below. Note that
+I<min> overrules the C<=> / C<:> semantics.
+
+I<max> denotes the maximum number of arguments. It must be at least
+I<min>. If I<max> is omitted, I<but the comma is not>, there is no
+upper bound to the number of argument values taken.
+
+=item : I<type> [ I<desttype> ]
+
+Like C<=>, but designates the argument as optional.
+If omitted, an empty string will be assigned to string values options,
+and the value zero to numeric options.
+
+Note that if a string argument starts with C<-> or C<-->, it will be
+considered an option on itself.
+
+=item : I<number> [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the I<number> will be assigned.
+
+=item : + [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the current value for the
+option will be incremented.
+
+=back
+
+=head1 Advanced Possibilities
+
+=head2 Object oriented interface
+
+Getopt::Long can be used in an object oriented way as well:
+
+ use Getopt::Long;
+ $p = new Getopt::Long::Parser;
+ $p->configure(...configuration options...);
+ if ($p->getoptions(...options descriptions...)) ...
+
+Configuration options can be passed to the constructor:
+
+ $p = new Getopt::Long::Parser
+ config => [...configuration options...];
+
+=head2 Thread Safety
+
+Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
+I<not> thread safe when using the older (experimental and now
+obsolete) threads implementation that was added to Perl 5.005.
+
+=head2 Documentation and help texts
+
+Getopt::Long encourages the use of Pod::Usage to produce help
+messages. For example:
+
+ use Getopt::Long;
+ use Pod::Usage;
+
+ my $man = 0;
+ my $help = 0;
+
+ GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
+ pod2usage(1) if $help;
+ pod2usage(-exitstatus => 0, -verbose => 2) if $man;
+
+ __END__
+
+ =head1 NAME
+
+ sample - Using Getopt::Long and Pod::Usage
+
+ =head1 SYNOPSIS
+
+ sample [options] [file ...]
+
+ Options:
+ -help brief help message
+ -man full documentation
+
+ =head1 OPTIONS
+
+ =over 8
+
+ =item B<-help>
+
+ Print a brief help message and exits.
+
+ =item B<-man>
+
+ Prints the manual page and exits.
+
+ =back
+
+ =head1 DESCRIPTION
+
+ B<This program> will read the given input file(s) and do something
+ useful with the contents thereof.
+
+ =cut
+
+See L<Pod::Usage> for details.
+
+=head2 Parsing options from an arbitrary array
+
+By default, GetOptions parses the options that are present in the
+global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
+used to parse options from an arbitrary array.
+
+ use Getopt::Long qw(GetOptionsFromArray);
+ $ret = GetOptionsFromArray(\@myopts, ...);
+
+When used like this, the global C<@ARGV> is not touched at all.
+
+The following two calls behave identically:
+
+ $ret = GetOptions( ... );
+ $ret = GetOptionsFromArray(\@ARGV, ... );
+
+=head2 Parsing options from an arbitrary string
+
+A special entry C<GetOptionsFromString> can be used to parse options
+from an arbitrary string.
+
+ use Getopt::Long qw(GetOptionsFromString);
+ $ret = GetOptionsFromString($string, ...);
+
+The contents of the string are split into arguments using a call to
+C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
+global C<@ARGV> is not touched.
+
+It is possible that, upon completion, not all arguments in the string
+have been processed. C<GetOptionsFromString> will, when called in list
+context, return both the return status and an array reference to any
+remaining arguments:
+
+ ($ret, $args) = GetOptionsFromString($string, ... );
+
+If any arguments remain, and C<GetOptionsFromString> was not called in
+list context, a message will be given and C<GetOptionsFromString> will
+return failure.
+
+=head2 Storing options values in a hash
+
+Sometimes, for example when there are a lot of options, having a
+separate variable for each of them can be cumbersome. GetOptions()
+supports, as an alternative mechanism, storing options values in a
+hash.
+
+To obtain this, a reference to a hash must be passed I<as the first
+argument> to GetOptions(). For each option that is specified on the
+command line, the option value will be stored in the hash with the
+option name as key. Options that are not actually used on the command
+line will not be put in the hash, on other words,
+C<exists($h{option})> (or defined()) can be used to test if an option
+was used. The drawback is that warnings will be issued if the program
+runs under C<use strict> and uses C<$h{option}> without testing with
+exists() or defined() first.
+
+ my %h = ();
+ GetOptions (\%h, 'length=i'); # will store in $h{length}
+
+For options that take list or hash values, it is necessary to indicate
+this by appending an C<@> or C<%> sign after the type:
+
+ GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
+
+To make things more complicated, the hash may contain references to
+the actual destinations, for example:
+
+ my $len = 0;
+ my %h = ('length' => \$len);
+ GetOptions (\%h, 'length=i'); # will store in $len
+
+This example is fully equivalent with:
+
+ my $len = 0;
+ GetOptions ('length=i' => \$len); # will store in $len
+
+Any mixture is possible. For example, the most frequently used options
+could be stored in variables while all other options get stored in the
+hash:
+
+ my $verbose = 0; # frequently referred
+ my $debug = 0; # frequently referred
+ my %h = ('verbose' => \$verbose, 'debug' => \$debug);
+ GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
+ if ( $verbose ) { ... }
+ if ( exists $h{filter} ) { ... option 'filter' was specified ... }
+
+=head2 Bundling
+
+With bundling it is possible to set several single-character options
+at once. For example if C<a>, C<v> and C<x> are all valid options,
+
+ -vax
+
+would set all three.
+
+Getopt::Long supports two levels of bundling. To enable bundling, a
+call to Getopt::Long::Configure is required.
+
+The first level of bundling can be enabled with:
+
+ Getopt::Long::Configure ("bundling");
+
+Configured this way, single-character options can be bundled but long
+options B<must> always start with a double dash C<--> to avoid
+ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
+options,
+
+ -vax
+
+would set C<a>, C<v> and C<x>, but
+
+ --vax
+
+would set C<vax>.
+
+The second level of bundling lifts this restriction. It can be enabled
+with:
+
+ Getopt::Long::Configure ("bundling_override");
+
+Now, C<-vax> would set the option C<vax>.
+
+When any level of bundling is enabled, option values may be inserted
+in the bundle. For example:
+
+ -h24w80
+
+is equivalent to
+
+ -h 24 -w 80
+
+When configured for bundling, single-character options are matched
+case sensitive while long options are matched case insensitive. To
+have the single-character options matched case insensitive as well,
+use:
+
+ Getopt::Long::Configure ("bundling", "ignorecase_always");
+
+It goes without saying that bundling can be quite confusing.
+
+=head2 The lonesome dash
+
+Normally, a lone dash C<-> on the command line will not be considered
+an option. Option processing will terminate (unless "permute" is
+configured) and the dash will be left in C<@ARGV>.
+
+It is possible to get special treatment for a lone dash. This can be
+achieved by adding an option specification with an empty name, for
+example:
+
+ GetOptions ('' => \$stdio);
+
+A lone dash on the command line will now be a legal option, and using
+it will set variable C<$stdio>.
+
+=head2 Argument callback
+
+A special option 'name' C<< <> >> can be used to designate a subroutine
+to handle non-option arguments. When GetOptions() encounters an
+argument that does not look like an option, it will immediately call this
+subroutine and passes it one parameter: the argument name. Well, actually
+it is an object that stringifies to the argument name.
+
+For example:
+
+ my $width = 80;
+ sub process { ... }
+ GetOptions ('width=i' => \$width, '<>' => \&process);
+
+When applied to the following command line:
+
+ arg1 --width=72 arg2 --width=60 arg3
+
+This will call
+C<process("arg1")> while C<$width> is C<80>,
+C<process("arg2")> while C<$width> is C<72>, and
+C<process("arg3")> while C<$width> is C<60>.
+
+This feature requires configuration option B<permute>, see section
+L<Configuring Getopt::Long>.
+
+=head1 Configuring Getopt::Long
+
+Getopt::Long can be configured by calling subroutine
+Getopt::Long::Configure(). This subroutine takes a list of quoted
+strings, each specifying a configuration option to be enabled, e.g.
+C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
+matter. Multiple calls to Configure() are possible.
+
+Alternatively, as of version 2.24, the configuration options may be
+passed together with the C<use> statement:
+
+ use Getopt::Long qw(:config no_ignore_case bundling);
+
+The following options are available:
+
+=over 12
+
+=item default
+
+This option causes all configuration options to be reset to their
+default values.
+
+=item posix_default
+
+This option causes all configuration options to be reset to their
+default values as if the environment variable POSIXLY_CORRECT had
+been set.
+
+=item auto_abbrev
+
+Allow option names to be abbreviated to uniqueness.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
+
+=item getopt_compat
+
+Allow C<+> to start options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
+
+=item gnu_compat
+
+C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
+do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
+C<--opt=> will give option C<opt> and empty value.
+This is the way GNU getopt_long() does it.
+
+=item gnu_getopt
+
+This is a short way of setting C<gnu_compat> C<bundling> C<permute>
+C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
+fully compatible with GNU getopt_long().
+
+=item require_order
+
+Whether command line arguments are allowed to be mixed with options.
+Default is disabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
+
+See also C<permute>, which is the opposite of C<require_order>.
+
+=item permute
+
+Whether command line arguments are allowed to be mixed with options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
+Note that C<permute> is the opposite of C<require_order>.
+
+If C<permute> is enabled, this means that
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo --bar arg1 arg2 arg3
+
+If an argument callback routine is specified, C<@ARGV> will always be
+empty upon successful return of GetOptions() since all options have been
+processed. The only exception is when C<--> is used:
+
+ --foo arg1 --bar arg2 -- arg3
+
+This will call the callback routine for arg1 and arg2, and then
+terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
+
+If C<require_order> is enabled, options processing
+terminates when the first non-option is encountered.
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo -- arg1 --bar arg2 arg3
+
+If C<pass_through> is also enabled, options processing will terminate
+at the first unrecognized option, or non-option, whichever comes
+first.
+
+=item bundling (default: disabled)
+
+Enabling this option will allow single-character options to be
+bundled. To distinguish bundles from long option names, long options
+I<must> be introduced with C<--> and bundles with C<->.
+
+Note that, if you have options C<a>, C<l> and C<all>, and
+auto_abbrev enabled, possible arguments and option settings are:
+
+ using argument sets option(s)
+ ------------------------------------------
+ -a, --a a
+ -l, --l l
+ -al, -la, -ala, -all,... a, l
+ --al, --all all
+
+The surprising part is that C<--a> sets option C<a> (due to auto
+completion), not C<all>.
+
+Note: disabling C<bundling> also disables C<bundling_override>.
+
+=item bundling_override (default: disabled)
+
+If C<bundling_override> is enabled, bundling is enabled as with
+C<bundling> but now long option names override option bundles.
+
+Note: disabling C<bundling_override> also disables C<bundling>.
+
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
+
+=item ignore_case (default: enabled)
+
+If enabled, case is ignored when matching long option names. If,
+however, bundling is enabled as well, single character options will be
+treated case-sensitive.
+
+With C<ignore_case>, option specifications for options that only
+differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
+duplicates.
+
+Note: disabling C<ignore_case> also disables C<ignore_case_always>.
+
+=item ignore_case_always (default: disabled)
+
+When bundling is in effect, case is ignored on single-character
+options also.
+
+Note: disabling C<ignore_case_always> also disables C<ignore_case>.
+
+=item auto_version (default:disabled)
+
+Automatically provide support for the B<--version> option if
+the application did not specify a handler for this option itself.
+
+Getopt::Long will provide a standard version message that includes the
+program name, its version (if $main::VERSION is defined), and the
+versions of Getopt::Long and Perl. The message will be written to
+standard output and processing will terminate.
+
+C<auto_version> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
+
+=item auto_help (default:disabled)
+
+Automatically provide support for the B<--help> and B<-?> options if
+the application did not specify a handler for this option itself.
+
+Getopt::Long will provide a help message using module L<Pod::Usage>. The
+message, derived from the SYNOPSIS POD section, will be written to
+standard output and processing will terminate.
+
+C<auto_help> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
+
+=item pass_through (default: disabled)
+
+Options that are unknown, ambiguous or supplied with an invalid option
+value are passed through in C<@ARGV> instead of being flagged as
+errors. This makes it possible to write wrapper scripts that process
+only part of the user supplied command line arguments, and pass the
+remaining options to some other program.
+
+If C<require_order> is enabled, options processing will terminate at
+the first unrecognized option, or non-option, whichever comes first.
+However, if C<permute> is enabled instead, results can become confusing.
+
+Note that the options terminator (default C<-->), if present, will
+also be passed through in C<@ARGV>.
+
+=item prefix
+
+The string that starts options. If a constant string is not
+sufficient, see C<prefix_pattern>.
+
+=item prefix_pattern
+
+A Perl pattern that identifies the strings that introduce options.
+Default is C<--|-|\+> unless environment variable
+POSIXLY_CORRECT has been set, in which case it is C<--|->.
+
+=item long_prefix_pattern
+
+A Perl pattern that allows the disambiguation of long and short
+prefixes. Default is C<-->.
+
+Typically you only need to set this if you are using nonstandard
+prefixes and want some or all of them to have the same semantics as
+'--' does under normal circumstances.
+
+For example, setting prefix_pattern to C<--|-|\+|\/> and
+long_prefix_pattern to C<--|\/> would add Win32 style argument
+handling.
+
+=item debug (default: disabled)
+
+Enable debugging output.
+
+=back
+
+=head1 Exportable Methods
+
+=over
+
+=item VersionMessage
+
+This subroutine provides a standard version message. Its argument can be:
+
+=over 4
+
+=item *
+
+A string containing the text of a message to print I<before> printing
+the standard message.
+
+=item *
+
+A numeric value corresponding to the desired exit status.
+
+=item *
+
+A reference to a hash.
+
+=back
+
+If more than one argument is given then the entire argument list is
+assumed to be a hash. If a hash is supplied (either as a reference or
+as a list) it should contain one or more elements with the following
+keys:
+
+=over 4
+
+=item C<-message>
+
+=item C<-msg>
+
+The text of a message to print immediately prior to printing the
+program's usage message.
+
+=item C<-exitval>
+
+The desired exit status to pass to the B<exit()> function.
+This should be an integer, or else the string "NOEXIT" to
+indicate that control should simply be returned without
+terminating the invoking process.
+
+=item C<-output>
+
+A reference to a filehandle, or the pathname of a file to which the
+usage message should be written. The default is C<\*STDERR> unless the
+exit value is less than 2 (in which case the default is C<\*STDOUT>).
+
+=back
+
+You cannot tie this routine directly to an option, e.g.:
+
+ GetOptions("version" => \&VersionMessage);
+
+Use this instead:
+
+ GetOptions("version" => sub { VersionMessage() });
+
+=item HelpMessage
+
+This subroutine produces a standard help message, derived from the
+program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
+arguments as VersionMessage(). In particular, you cannot tie it
+directly to an option, e.g.:
+
+ GetOptions("help" => \&HelpMessage);
+
+Use this instead:
+
+ GetOptions("help" => sub { HelpMessage() });
+
+=back
+
+=head1 Return values and Errors
+
+Configuration errors and errors in the option definitions are
+signalled using die() and will terminate the calling program unless
+the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
+}>, or die() was trapped using C<$SIG{__DIE__}>.
+
+GetOptions returns true to indicate success.
+It returns false when the function detected one or more errors during
+option parsing. These errors are signalled using warn() and can be
+trapped with C<$SIG{__WARN__}>.
+
+=head1 Legacy
+
+The earliest development of C<newgetopt.pl> started in 1990, with Perl
+version 4. As a result, its development, and the development of
+Getopt::Long, has gone through several stages. Since backward
+compatibility has always been extremely important, the current version
+of Getopt::Long still supports a lot of constructs that nowadays are
+no longer necessary or otherwise unwanted. This section describes
+briefly some of these 'features'.
+
+=head2 Default destinations
+
+When no destination is specified for an option, GetOptions will store
+the resultant value in a global variable named C<opt_>I<XXX>, where
+I<XXX> is the primary name of this option. When a progam executes
+under C<use strict> (recommended), these variables must be
+pre-declared with our() or C<use vars>.
+
+ our $opt_length = 0;
+ GetOptions ('length=i'); # will store in $opt_length
+
+To yield a usable Perl variable, characters that are not part of the
+syntax for variables are translated to underscores. For example,
+C<--fpp-struct-return> will set the variable
+C<$opt_fpp_struct_return>. Note that this variable resides in the
+namespace of the calling program, not necessarily C<main>. For
+example:
+
+ GetOptions ("size=i", "sizes=i@");
+
+with command line "-size 10 -sizes 24 -sizes 48" will perform the
+equivalent of the assignments
+
+ $opt_size = 10;
+ @opt_sizes = (24, 48);
+
+=head2 Alternative option starters
+
+A string of alternative option starter characters may be passed as the
+first argument (or the first argument after a leading hash reference
+argument).
+
+ my $len = 0;
+ GetOptions ('/', 'length=i' => $len);
+
+Now the command line may look like:
+
+ /length 24 -- arg
+
+Note that to terminate options processing still requires a double dash
+C<-->.
+
+GetOptions() will not interpret a leading C<< "<>" >> as option starters
+if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
+option starters, use C<< "><" >>. Confusing? Well, B<using a starter
+argument is strongly deprecated> anyway.
+
+=head2 Configuration variables
+
+Previous versions of Getopt::Long used variables for the purpose of
+configuring. Although manipulating these variables still work, it is
+strongly encouraged to use the C<Configure> routine that was introduced
+in version 2.17. Besides, it is much easier.
+
+=head1 Tips and Techniques
+
+=head2 Pushing multiple values in a hash option
+
+Sometimes you want to combine the best of hashes and arrays. For
+example, the command line:
+
+ --list add=first --list add=second --list add=third
+
+where each successive 'list add' option will push the value of add
+into array ref $list->{'add'}. The result would be like
+
+ $list->{add} = [qw(first second third)];
+
+This can be accomplished with a destination routine:
+
+ GetOptions('list=s%' =>
+ sub { push(@{$list{$_[1]}}, $_[2]) });
+
+=head1 Troubleshooting
+
+=head2 GetOptions does not return a false result when an option is not supplied
+
+That's why they're called 'options'.
+
+=head2 GetOptions does not split the command line correctly
+
+The command line is not split by GetOptions, but by the command line
+interpreter (CLI). On Unix, this is the shell. On Windows, it is
+COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
+
+It is important to know that these CLIs may behave different when the
+command line contains special characters, in particular quotes or
+backslashes. For example, with Unix shells you can use single quotes
+(C<'>) and double quotes (C<">) to group words together. The following
+alternatives are equivalent on Unix:
+
+ "two words"
+ 'two words'
+ two\ words
+
+In case of doubt, insert the following statement in front of your Perl
+program:
+
+ print STDERR (join("|",@ARGV),"\n");
+
+to verify how your CLI passes the arguments to the program.
+
+=head2 Undefined subroutine &main::GetOptions called
+
+Are you running Windows, and did you write
+
+ use GetOpt::Long;
+
+(note the capital 'O')?
+
+=head2 How do I put a "-?" option into a Getopt::Long?
+
+You can only obtain this using an alias, and Getopt::Long of at least
+version 2.13.
+
+ use Getopt::Long;
+ GetOptions ("help|?"); # -help and -? will both set $opt_help
+
+=head1 AUTHOR
+
+Johan Vromans <jvromans@squirrel.nl>
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+This program is Copyright 1990,2009 by Johan Vromans.
+This program is free software; you can redistribute it and/or
+modify it under the terms of the Perl Artistic License or the
+GNU General Public License as published by the Free Software
+Foundation; either version 2 of the License, or (at your option) any
+later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+If you do not have a copy of the GNU General Public License write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+MA 02139, USA.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Getopt/Std.pm b/Master/tlpkg/tlperl.straw/lib/Getopt/Std.pm
new file mode 100755
index 00000000000..823bc4dd910
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Getopt/Std.pm
@@ -0,0 +1,295 @@
+package Getopt::Std;
+require 5.000;
+require Exporter;
+
+=head1 NAME
+
+getopt, getopts - Process single-character switches with switch clustering
+
+=head1 SYNOPSIS
+
+ use Getopt::Std;
+
+ getopt('oDI'); # -o, -D & -I take arg. Sets $opt_* as a side effect.
+ getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts
+ getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
+ # Sets $opt_* as a side effect.
+ getopts('oif:', \%opts); # options as above. Values in %opts
+
+=head1 DESCRIPTION
+
+The getopt() function processes single-character switches with switch
+clustering. Pass one argument which is a string containing all switches
+that take an argument. For each switch found, sets $opt_x (where x is the
+switch name) to the value of the argument if an argument is expected,
+or 1 otherwise. Switches which take an argument don't care whether
+there is a space between the switch and the argument.
+
+The getopts() function is similar, but you should pass to it the list of all
+switches to be recognized. If unspecified switches are found on the
+command-line, the user will be warned that an unknown option was given.
+The getopts() function returns true unless an invalid option was found.
+
+Note that, if your code is running under the recommended C<use strict
+'vars'> pragma, you will need to declare these package variables
+with "our":
+
+ our($opt_x, $opt_y);
+
+For those of you who don't like additional global variables being created, getopt()
+and getopts() will also accept a hash reference as an optional second argument.
+Hash keys will be x (where x is the switch name) with key values the value of
+the argument or 1 if no argument is specified.
+
+To allow programs to process arguments that look like switches, but aren't,
+both functions will stop processing switches when they see the argument
+C<-->. The C<--> will be removed from @ARGV.
+
+=head1 C<--help> and C<--version>
+
+If C<-> is not a recognized switch letter, getopts() supports arguments
+C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
+C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
+the output file handle, the name of option-processing package, its version,
+and the switches string. If the subroutines are not defined, an attempt is
+made to generate intelligent messages; for best results, define $main::VERSION.
+
+If embedded documentation (in pod format, see L<perlpod>) is detected
+in the script, C<--help> will also show how to access the documentation.
+
+Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
+isn't true (the default is false), then the messages are printed on STDERR,
+and the processing continues after the messages are printed. This being
+the opposite of the standard-conforming behaviour, it is strongly recommended
+to set $Getopt::Std::STANDARD_HELP_VERSION to true.
+
+One can change the output file handle of the messages by setting
+$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
+(without the C<Usage:> line) and C<--version> by calling functions help_mess()
+and version_mess() with the switches string as an argument.
+
+=cut
+
+@ISA = qw(Exporter);
+@EXPORT = qw(getopt getopts);
+$VERSION = '1.06';
+# uncomment the next line to disable 1.03-backward compatibility paranoia
+# $STANDARD_HELP_VERSION = 1;
+
+# Process single-character switches with switch clustering. Pass one argument
+# which is a string containing all switches that take an argument. For each
+# switch found, sets $opt_x (where x is the switch name) to the value of the
+# argument, or 1 if no argument. Switches which take an argument don't care
+# whether there is a space between the switch and the argument.
+
+# Usage:
+# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub getopt (;$$) {
+ my ($argumentative, $hash) = @_;
+ $argumentative = '' if !defined $argumentative;
+ my ($first,$rest);
+ local $_;
+ local @EXPORT;
+
+ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (/^--$/) { # early exit if --
+ shift @ARGV;
+ last;
+ }
+ if (index($argumentative,$first) >= 0) {
+ if ($rest ne '') {
+ shift(@ARGV);
+ }
+ else {
+ shift(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ }
+ else {
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ unless (ref $hash) {
+ local $Exporter::ExportLevel = 1;
+ import Getopt::Std;
+ }
+}
+
+sub output_h () {
+ return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
+ return \*STDOUT if $STANDARD_HELP_VERSION;
+ return \*STDERR;
+}
+
+sub try_exit () {
+ exit 0 if $STANDARD_HELP_VERSION;
+ my $p = __PACKAGE__;
+ print {output_h()} <<EOM;
+ [Now continuing due to backward compatibility and excessive paranoia.
+ See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
+EOM
+}
+
+sub version_mess ($;$) {
+ my $args = shift;
+ my $h = output_h;
+ if (@_ and defined &main::VERSION_MESSAGE) {
+ main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
+ } else {
+ my $v = $main::VERSION;
+ $v = '[unknown]' unless defined $v;
+ my $myv = $VERSION;
+ $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
+ my $perlv = $];
+ $perlv = sprintf "%vd", $^V if $] >= 5.006;
+ print $h <<EOH;
+$0 version $v calling Getopt::Std::getopts (version $myv),
+running under Perl version $perlv.
+EOH
+ }
+}
+
+sub help_mess ($;$) {
+ my $args = shift;
+ my $h = output_h;
+ if (@_ and defined &main::HELP_MESSAGE) {
+ main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
+ } else {
+ my (@witharg) = ($args =~ /(\S)\s*:/g);
+ my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
+ my ($help, $arg) = ('', '');
+ if (@witharg) {
+ $help .= "\n\tWith arguments: -" . join " -", @witharg;
+ $arg = "\nSpace is not required between options and their arguments.";
+ }
+ if (@rest) {
+ $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
+ }
+ my ($scr) = ($0 =~ m,([^/\\]+)$,);
+ print $h <<EOH if @_; # Let the script override this
+
+Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
+EOH
+ print $h <<EOH;
+
+The following single-character options are accepted:$help
+
+Options may be merged together. -- stops processing of options.$arg
+EOH
+ my $has_pod;
+ if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
+ and open my $script, '<', $0 ) {
+ while (<$script>) {
+ $has_pod = 1, last if /^=(pod|head1)/;
+ }
+ }
+ print $h <<EOH if $has_pod;
+
+For more details run
+ perldoc -F $0
+EOH
+ }
+}
+
+# Usage:
+# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
+# # side effect.
+
+sub getopts ($;$) {
+ my ($argumentative, $hash) = @_;
+ my (@args,$first,$rest,$exit);
+ my $errs = 0;
+ local $_;
+ local @EXPORT;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
+ ($first,$rest) = ($1,$2);
+ if (/^--$/) { # early exit if --
+ shift @ARGV;
+ last;
+ }
+ my $pos = index($argumentative,$first);
+ if ($pos >= 0) {
+ if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
+ shift(@ARGV);
+ if ($rest eq '') {
+ ++$errs unless @ARGV;
+ $rest = shift(@ARGV);
+ }
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ }
+ else {
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ if ($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ if ($first eq '-' and $rest eq 'help') {
+ version_mess($argumentative, 'main');
+ help_mess($argumentative, 'main');
+ try_exit();
+ shift(@ARGV);
+ next;
+ } elsif ($first eq '-' and $rest eq 'version') {
+ version_mess($argumentative, 'main');
+ try_exit();
+ shift(@ARGV);
+ next;
+ }
+ warn "Unknown option: $first\n";
+ ++$errs;
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ unless (ref $hash) {
+ local $Exporter::ExportLevel = 1;
+ import Getopt::Std;
+ }
+ $errs == 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/HTML/Entities.pm b/Master/tlpkg/tlperl.straw/lib/HTML/Entities.pm
new file mode 100755
index 00000000000..38cd41e62b0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/Entities.pm
@@ -0,0 +1,500 @@
+package HTML::Entities;
+
+=head1 NAME
+
+HTML::Entities - Encode or decode strings with HTML entities
+
+=head1 SYNOPSIS
+
+ use HTML::Entities;
+
+ $a = "V&aring;re norske tegn b&oslash;r &#230res";
+ decode_entities($a);
+ encode_entities($a, "\200-\377");
+
+For example, this:
+
+ $input = "vis-à-vis Beyoncé's naïve\npapier-mâché résumé";
+ print encode_entities($input), "\n"
+
+Prints this out:
+
+ vis-&agrave;-vis Beyonc&eacute;'s na&iuml;ve
+ papier-m&acirc;ch&eacute; r&eacute;sum&eacute;
+
+=head1 DESCRIPTION
+
+This module deals with encoding and decoding of strings with HTML
+character entities. The module provides the following functions:
+
+=over 4
+
+=item decode_entities( $string, ... )
+
+This routine replaces HTML entities found in the $string with the
+corresponding Unicode character. Under perl 5.6 and earlier only
+characters in the Latin-1 range are replaced. Unrecognized
+entities are left alone.
+
+If multiple strings are provided as argument they are each decoded
+separately and the same number of strings are returned.
+
+If called in void context the arguments are decoded in-place.
+
+This routine is exported by default.
+
+=item _decode_entities( $string, \%entity2char )
+
+=item _decode_entities( $string, \%entity2char, $expand_prefix )
+
+This will in-place replace HTML entities in $string. The %entity2char
+hash must be provided. Named entities not found in the %entity2char
+hash are left alone. Numeric entities are expanded unless their value
+overflow.
+
+The keys in %entity2char are the entity names to be expanded and their
+values are what they should expand into. The values do not have to be
+single character strings. If a key has ";" as suffix,
+then occurrences in $string are only expanded if properly terminated
+with ";". Entities without ";" will be expanded regardless of how
+they are terminated for compatibility with how common browsers treat
+entities in the Latin-1 range.
+
+If $expand_prefix is TRUE then entities without trailing ";" in
+%entity2char will even be expanded as a prefix of a longer
+unrecognized name. The longest matching name in %entity2char will be
+used. This is mainly present for compatibility with an MSIE
+misfeature.
+
+ $string = "foo&nbspbar";
+ _decode_entities($string, { nb => "@", nbsp => "\xA0" }, 1);
+ print $string; # will print "foo bar"
+
+This routine is exported by default.
+
+=item encode_entities( $string )
+
+=item encode_entities( $string, $unsafe_chars )
+
+This routine replaces unsafe characters in $string with their entity
+representation. A second argument can be given to specify which characters to
+consider unsafe. The unsafe characters is specified using the regular
+expression character class syntax (what you find within brackets in regular
+expressions).
+
+The default set of characters to encode are control chars, high-bit chars, and
+the C<< < >>, C<< & >>, C<< > >>, C<< ' >> and C<< " >> characters. But this,
+for example, would encode I<just> the C<< < >>, C<< & >>, C<< > >>, and C<< "
+>> characters:
+
+ $encoded = encode_entities($input, '<>&"');
+
+and this would only encode non-plain ascii:
+
+ $encoded = encode_entities($input, '^\n\x20-\x25\x27-\x7e');
+
+This routine is exported by default.
+
+=item encode_entities_numeric( $string )
+
+=item encode_entities_numeric( $string, $unsafe_chars )
+
+This routine works just like encode_entities, except that the replacement
+entities are always C<&#xI<hexnum>;> and never C<&I<entname>;>. For
+example, C<encode_entities("r\xF4le")> returns "r&ocirc;le", but
+C<encode_entities_numeric("r\xF4le")> returns "r&#xF4;le".
+
+This routine is I<not> exported by default. But you can always
+export it with C<use HTML::Entities qw(encode_entities_numeric);>
+or even C<use HTML::Entities qw(:DEFAULT encode_entities_numeric);>
+
+=back
+
+All these routines modify the string passed as the first argument, if
+called in a void context. In scalar and array contexts, the encoded or
+decoded string is returned (without changing the input string).
+
+If you prefer not to import these routines into your namespace, you can
+call them as:
+
+ use HTML::Entities ();
+ $decoded = HTML::Entities::decode($a);
+ $encoded = HTML::Entities::encode($a);
+ $encoded = HTML::Entities::encode_numeric($a);
+
+The module can also export the %char2entity and the %entity2char
+hashes, which contain the mapping from all characters to the
+corresponding entities (and vice versa, respectively).
+
+=head1 COPYRIGHT
+
+Copyright 1995-2006 Gisle Aas. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+use vars qw(%entity2char %char2entity);
+
+require 5.004;
+require Exporter;
+@ISA = qw(Exporter);
+
+@EXPORT = qw(encode_entities decode_entities _decode_entities);
+@EXPORT_OK = qw(%entity2char %char2entity encode_entities_numeric);
+
+$VERSION = "3.64";
+sub Version { $VERSION; }
+
+require HTML::Parser; # for fast XS implemented decode_entities
+
+
+%entity2char = (
+ # Some normal chars that have special meaning in SGML context
+ amp => '&', # ampersand
+'gt' => '>', # greater than
+'lt' => '<', # less than
+ quot => '"', # double quote
+ apos => "'", # single quote
+
+ # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML
+ AElig => chr(198), # capital AE diphthong (ligature)
+ Aacute => chr(193), # capital A, acute accent
+ Acirc => chr(194), # capital A, circumflex accent
+ Agrave => chr(192), # capital A, grave accent
+ Aring => chr(197), # capital A, ring
+ Atilde => chr(195), # capital A, tilde
+ Auml => chr(196), # capital A, dieresis or umlaut mark
+ Ccedil => chr(199), # capital C, cedilla
+ ETH => chr(208), # capital Eth, Icelandic
+ Eacute => chr(201), # capital E, acute accent
+ Ecirc => chr(202), # capital E, circumflex accent
+ Egrave => chr(200), # capital E, grave accent
+ Euml => chr(203), # capital E, dieresis or umlaut mark
+ Iacute => chr(205), # capital I, acute accent
+ Icirc => chr(206), # capital I, circumflex accent
+ Igrave => chr(204), # capital I, grave accent
+ Iuml => chr(207), # capital I, dieresis or umlaut mark
+ Ntilde => chr(209), # capital N, tilde
+ Oacute => chr(211), # capital O, acute accent
+ Ocirc => chr(212), # capital O, circumflex accent
+ Ograve => chr(210), # capital O, grave accent
+ Oslash => chr(216), # capital O, slash
+ Otilde => chr(213), # capital O, tilde
+ Ouml => chr(214), # capital O, dieresis or umlaut mark
+ THORN => chr(222), # capital THORN, Icelandic
+ Uacute => chr(218), # capital U, acute accent
+ Ucirc => chr(219), # capital U, circumflex accent
+ Ugrave => chr(217), # capital U, grave accent
+ Uuml => chr(220), # capital U, dieresis or umlaut mark
+ Yacute => chr(221), # capital Y, acute accent
+ aacute => chr(225), # small a, acute accent
+ acirc => chr(226), # small a, circumflex accent
+ aelig => chr(230), # small ae diphthong (ligature)
+ agrave => chr(224), # small a, grave accent
+ aring => chr(229), # small a, ring
+ atilde => chr(227), # small a, tilde
+ auml => chr(228), # small a, dieresis or umlaut mark
+ ccedil => chr(231), # small c, cedilla
+ eacute => chr(233), # small e, acute accent
+ ecirc => chr(234), # small e, circumflex accent
+ egrave => chr(232), # small e, grave accent
+ eth => chr(240), # small eth, Icelandic
+ euml => chr(235), # small e, dieresis or umlaut mark
+ iacute => chr(237), # small i, acute accent
+ icirc => chr(238), # small i, circumflex accent
+ igrave => chr(236), # small i, grave accent
+ iuml => chr(239), # small i, dieresis or umlaut mark
+ ntilde => chr(241), # small n, tilde
+ oacute => chr(243), # small o, acute accent
+ ocirc => chr(244), # small o, circumflex accent
+ ograve => chr(242), # small o, grave accent
+ oslash => chr(248), # small o, slash
+ otilde => chr(245), # small o, tilde
+ ouml => chr(246), # small o, dieresis or umlaut mark
+ szlig => chr(223), # small sharp s, German (sz ligature)
+ thorn => chr(254), # small thorn, Icelandic
+ uacute => chr(250), # small u, acute accent
+ ucirc => chr(251), # small u, circumflex accent
+ ugrave => chr(249), # small u, grave accent
+ uuml => chr(252), # small u, dieresis or umlaut mark
+ yacute => chr(253), # small y, acute accent
+ yuml => chr(255), # small y, dieresis or umlaut mark
+
+ # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)
+ copy => chr(169), # copyright sign
+ reg => chr(174), # registered sign
+ nbsp => chr(160), # non breaking space
+
+ # Additional ISO-8859/1 entities listed in rfc1866 (section 14)
+ iexcl => chr(161),
+ cent => chr(162),
+ pound => chr(163),
+ curren => chr(164),
+ yen => chr(165),
+ brvbar => chr(166),
+ sect => chr(167),
+ uml => chr(168),
+ ordf => chr(170),
+ laquo => chr(171),
+'not' => chr(172), # not is a keyword in perl
+ shy => chr(173),
+ macr => chr(175),
+ deg => chr(176),
+ plusmn => chr(177),
+ sup1 => chr(185),
+ sup2 => chr(178),
+ sup3 => chr(179),
+ acute => chr(180),
+ micro => chr(181),
+ para => chr(182),
+ middot => chr(183),
+ cedil => chr(184),
+ ordm => chr(186),
+ raquo => chr(187),
+ frac14 => chr(188),
+ frac12 => chr(189),
+ frac34 => chr(190),
+ iquest => chr(191),
+'times' => chr(215), # times is a keyword in perl
+ divide => chr(247),
+
+ ( $] > 5.007 ? (
+ 'OElig;' => chr(338),
+ 'oelig;' => chr(339),
+ 'Scaron;' => chr(352),
+ 'scaron;' => chr(353),
+ 'Yuml;' => chr(376),
+ 'fnof;' => chr(402),
+ 'circ;' => chr(710),
+ 'tilde;' => chr(732),
+ 'Alpha;' => chr(913),
+ 'Beta;' => chr(914),
+ 'Gamma;' => chr(915),
+ 'Delta;' => chr(916),
+ 'Epsilon;' => chr(917),
+ 'Zeta;' => chr(918),
+ 'Eta;' => chr(919),
+ 'Theta;' => chr(920),
+ 'Iota;' => chr(921),
+ 'Kappa;' => chr(922),
+ 'Lambda;' => chr(923),
+ 'Mu;' => chr(924),
+ 'Nu;' => chr(925),
+ 'Xi;' => chr(926),
+ 'Omicron;' => chr(927),
+ 'Pi;' => chr(928),
+ 'Rho;' => chr(929),
+ 'Sigma;' => chr(931),
+ 'Tau;' => chr(932),
+ 'Upsilon;' => chr(933),
+ 'Phi;' => chr(934),
+ 'Chi;' => chr(935),
+ 'Psi;' => chr(936),
+ 'Omega;' => chr(937),
+ 'alpha;' => chr(945),
+ 'beta;' => chr(946),
+ 'gamma;' => chr(947),
+ 'delta;' => chr(948),
+ 'epsilon;' => chr(949),
+ 'zeta;' => chr(950),
+ 'eta;' => chr(951),
+ 'theta;' => chr(952),
+ 'iota;' => chr(953),
+ 'kappa;' => chr(954),
+ 'lambda;' => chr(955),
+ 'mu;' => chr(956),
+ 'nu;' => chr(957),
+ 'xi;' => chr(958),
+ 'omicron;' => chr(959),
+ 'pi;' => chr(960),
+ 'rho;' => chr(961),
+ 'sigmaf;' => chr(962),
+ 'sigma;' => chr(963),
+ 'tau;' => chr(964),
+ 'upsilon;' => chr(965),
+ 'phi;' => chr(966),
+ 'chi;' => chr(967),
+ 'psi;' => chr(968),
+ 'omega;' => chr(969),
+ 'thetasym;' => chr(977),
+ 'upsih;' => chr(978),
+ 'piv;' => chr(982),
+ 'ensp;' => chr(8194),
+ 'emsp;' => chr(8195),
+ 'thinsp;' => chr(8201),
+ 'zwnj;' => chr(8204),
+ 'zwj;' => chr(8205),
+ 'lrm;' => chr(8206),
+ 'rlm;' => chr(8207),
+ 'ndash;' => chr(8211),
+ 'mdash;' => chr(8212),
+ 'lsquo;' => chr(8216),
+ 'rsquo;' => chr(8217),
+ 'sbquo;' => chr(8218),
+ 'ldquo;' => chr(8220),
+ 'rdquo;' => chr(8221),
+ 'bdquo;' => chr(8222),
+ 'dagger;' => chr(8224),
+ 'Dagger;' => chr(8225),
+ 'bull;' => chr(8226),
+ 'hellip;' => chr(8230),
+ 'permil;' => chr(8240),
+ 'prime;' => chr(8242),
+ 'Prime;' => chr(8243),
+ 'lsaquo;' => chr(8249),
+ 'rsaquo;' => chr(8250),
+ 'oline;' => chr(8254),
+ 'frasl;' => chr(8260),
+ 'euro;' => chr(8364),
+ 'image;' => chr(8465),
+ 'weierp;' => chr(8472),
+ 'real;' => chr(8476),
+ 'trade;' => chr(8482),
+ 'alefsym;' => chr(8501),
+ 'larr;' => chr(8592),
+ 'uarr;' => chr(8593),
+ 'rarr;' => chr(8594),
+ 'darr;' => chr(8595),
+ 'harr;' => chr(8596),
+ 'crarr;' => chr(8629),
+ 'lArr;' => chr(8656),
+ 'uArr;' => chr(8657),
+ 'rArr;' => chr(8658),
+ 'dArr;' => chr(8659),
+ 'hArr;' => chr(8660),
+ 'forall;' => chr(8704),
+ 'part;' => chr(8706),
+ 'exist;' => chr(8707),
+ 'empty;' => chr(8709),
+ 'nabla;' => chr(8711),
+ 'isin;' => chr(8712),
+ 'notin;' => chr(8713),
+ 'ni;' => chr(8715),
+ 'prod;' => chr(8719),
+ 'sum;' => chr(8721),
+ 'minus;' => chr(8722),
+ 'lowast;' => chr(8727),
+ 'radic;' => chr(8730),
+ 'prop;' => chr(8733),
+ 'infin;' => chr(8734),
+ 'ang;' => chr(8736),
+ 'and;' => chr(8743),
+ 'or;' => chr(8744),
+ 'cap;' => chr(8745),
+ 'cup;' => chr(8746),
+ 'int;' => chr(8747),
+ 'there4;' => chr(8756),
+ 'sim;' => chr(8764),
+ 'cong;' => chr(8773),
+ 'asymp;' => chr(8776),
+ 'ne;' => chr(8800),
+ 'equiv;' => chr(8801),
+ 'le;' => chr(8804),
+ 'ge;' => chr(8805),
+ 'sub;' => chr(8834),
+ 'sup;' => chr(8835),
+ 'nsub;' => chr(8836),
+ 'sube;' => chr(8838),
+ 'supe;' => chr(8839),
+ 'oplus;' => chr(8853),
+ 'otimes;' => chr(8855),
+ 'perp;' => chr(8869),
+ 'sdot;' => chr(8901),
+ 'lceil;' => chr(8968),
+ 'rceil;' => chr(8969),
+ 'lfloor;' => chr(8970),
+ 'rfloor;' => chr(8971),
+ 'lang;' => chr(9001),
+ 'rang;' => chr(9002),
+ 'loz;' => chr(9674),
+ 'spades;' => chr(9824),
+ 'clubs;' => chr(9827),
+ 'hearts;' => chr(9829),
+ 'diams;' => chr(9830),
+ ) : ())
+);
+
+
+# Make the opposite mapping
+while (my($entity, $char) = each(%entity2char)) {
+ $entity =~ s/;\z//;
+ $char2entity{$char} = "&$entity;";
+}
+delete $char2entity{"'"}; # only one-way decoding
+
+# Fill in missing entities
+for (0 .. 255) {
+ next if exists $char2entity{chr($_)};
+ $char2entity{chr($_)} = "&#$_;";
+}
+
+my %subst; # compiled encoding regexps
+
+sub decode_entities_old
+{
+ my $array;
+ if (defined wantarray) {
+ $array = [@_]; # copy
+ } else {
+ $array = \@_; # modify in-place
+ }
+ my $c;
+ for (@$array) {
+ s/(&\#(\d+);?)/$2 < 256 ? chr($2) : $1/eg;
+ s/(&\#[xX]([0-9a-fA-F]+);?)/$c = hex($2); $c < 256 ? chr($c) : $1/eg;
+ s/(&(\w+);?)/$entity2char{$2} || $1/eg;
+ }
+ wantarray ? @$array : $array->[0];
+}
+
+sub encode_entities
+{
+ return undef unless defined $_[0];
+ my $ref;
+ if (defined wantarray) {
+ my $x = $_[0];
+ $ref = \$x; # copy
+ } else {
+ $ref = \$_[0]; # modify in-place
+ }
+ if (defined $_[1] and length $_[1]) {
+ unless (exists $subst{$_[1]}) {
+ # Because we can't compile regex we fake it with a cached sub
+ my $chars = $_[1];
+ $chars =~ s,(?<!\\)([]/]),\\$1,g;
+ $chars =~ s,(?<!\\)\\\z,\\\\,;
+ my $code = "sub {\$_[0] =~ s/([$chars])/\$char2entity{\$1} || num_entity(\$1)/ge; }";
+ $subst{$_[1]} = eval $code;
+ die( $@ . " while trying to turn range: \"$_[1]\"\n "
+ . "into code: $code\n "
+ ) if $@;
+ }
+ &{$subst{$_[1]}}($$ref);
+ } else {
+ # Encode control chars, high bit chars and '<', '&', '>', ''' and '"'
+ $$ref =~ s/([^\n\r\t !\#\$%\(-;=?-~])/$char2entity{$1} || num_entity($1)/ge;
+ }
+ $$ref;
+}
+
+sub encode_entities_numeric {
+ local %char2entity;
+ return &encode_entities; # a goto &encode_entities wouldn't work
+}
+
+
+sub num_entity {
+ sprintf "&#x%X;", ord($_[0]);
+}
+
+# Set up aliases
+*encode = \&encode_entities;
+*encode_numeric = \&encode_entities_numeric;
+*encode_numerically = \&encode_entities_numeric;
+*decode = \&decode_entities;
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/HTML/Filter.pm b/Master/tlpkg/tlperl.straw/lib/HTML/Filter.pm
new file mode 100755
index 00000000000..c5aa16e6dd8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/Filter.pm
@@ -0,0 +1,112 @@
+package HTML::Filter;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+require HTML::Parser;
+@ISA=qw(HTML::Parser);
+
+$VERSION = "3.57";
+
+sub declaration { $_[0]->output("<!$_[1]>") }
+sub process { $_[0]->output($_[2]) }
+sub comment { $_[0]->output("<!--$_[1]-->") }
+sub start { $_[0]->output($_[4]) }
+sub end { $_[0]->output($_[2]) }
+sub text { $_[0]->output($_[1]) }
+
+sub output { print $_[1] }
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTML::Filter - Filter HTML text through the parser
+
+=head1 NOTE
+
+B<This module is deprecated.> The C<HTML::Parser> now provides the
+functionally of C<HTML::Filter> much more efficiently with the the
+C<default> handler.
+
+=head1 SYNOPSIS
+
+ require HTML::Filter;
+ $p = HTML::Filter->new->parse_file("index.html");
+
+=head1 DESCRIPTION
+
+C<HTML::Filter> is an HTML parser that by default prints the
+original text of each HTML element (a slow version of cat(1) basically).
+The callback methods may be overridden to modify the filtering for some
+HTML elements and you can override output() method which is called to
+print the HTML text.
+
+C<HTML::Filter> is a subclass of C<HTML::Parser>. This means that
+the document should be given to the parser by calling the $p->parse()
+or $p->parse_file() methods.
+
+=head1 EXAMPLES
+
+The first example is a filter that will remove all comments from an
+HTML file. This is achieved by simply overriding the comment method
+to do nothing.
+
+ package CommentStripper;
+ require HTML::Filter;
+ @ISA=qw(HTML::Filter);
+ sub comment { } # ignore comments
+
+The second example shows a filter that will remove any E<lt>TABLE>s
+found in the HTML file. We specialize the start() and end() methods
+to count table tags and then make output not happen when inside a
+table.
+
+ package TableStripper;
+ require HTML::Filter;
+ @ISA=qw(HTML::Filter);
+ sub start
+ {
+ my $self = shift;
+ $self->{table_seen}++ if $_[0] eq "table";
+ $self->SUPER::start(@_);
+ }
+
+ sub end
+ {
+ my $self = shift;
+ $self->SUPER::end(@_);
+ $self->{table_seen}-- if $_[0] eq "table";
+ }
+
+ sub output
+ {
+ my $self = shift;
+ unless ($self->{table_seen}) {
+ $self->SUPER::output(@_);
+ }
+ }
+
+If you want to collect the parsed text internally you might want to do
+something like this:
+
+ package FilterIntoString;
+ require HTML::Filter;
+ @ISA=qw(HTML::Filter);
+ sub output { push(@{$_[0]->{fhtml}}, $_[1]) }
+ sub filtered_html { join("", @{$_[0]->{fhtml}}) }
+
+=head1 SEE ALSO
+
+L<HTML::Parser>
+
+=head1 COPYRIGHT
+
+Copyright 1997-1999 Gisle Aas.
+
+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.straw/lib/HTML/Form.pm b/Master/tlpkg/tlperl.straw/lib/HTML/Form.pm
new file mode 100755
index 00000000000..bbbd7771716
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/Form.pm
@@ -0,0 +1,1551 @@
+package HTML::Form;
+
+use strict;
+use URI;
+use Carp ();
+
+use vars qw($VERSION $Encode_available);
+$VERSION = "5.829";
+
+eval { require Encode };
+$Encode_available = !$@;
+
+my %form_tags = map {$_ => 1} qw(input textarea button select option);
+
+my %type2class = (
+ text => "TextInput",
+ password => "TextInput",
+ hidden => "TextInput",
+ textarea => "TextInput",
+
+ "reset" => "IgnoreInput",
+
+ radio => "ListInput",
+ checkbox => "ListInput",
+ option => "ListInput",
+
+ button => "SubmitInput",
+ submit => "SubmitInput",
+ image => "ImageInput",
+ file => "FileInput",
+
+ keygen => "KeygenInput",
+);
+
+=head1 NAME
+
+HTML::Form - Class that represents an HTML form element
+
+=head1 SYNOPSIS
+
+ use HTML::Form;
+ $form = HTML::Form->parse($html, $base_uri);
+ $form->value(query => "Perl");
+
+ use LWP::UserAgent;
+ $ua = LWP::UserAgent->new;
+ $response = $ua->request($form->click);
+
+=head1 DESCRIPTION
+
+Objects of the C<HTML::Form> class represents a single HTML
+C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a
+sequence of inputs that usually have names, and which can take on
+various values. The state of a form can be tweaked and it can then be
+asked to provide C<HTTP::Request> objects that can be passed to the
+request() method of C<LWP::UserAgent>.
+
+The following methods are available:
+
+=over 4
+
+=item @forms = HTML::Form->parse( $html_document, $base_uri )
+
+=item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
+
+=item @forms = HTML::Form->parse( $response, %opt )
+
+The parse() class method will parse an HTML document and build up
+C<HTML::Form> objects for each <form> element found. If called in scalar
+context only returns the first <form>. Returns an empty list if there
+are no forms to be found.
+
+The required arguments is the HTML document to parse ($html_document) and the
+URI used to retrieve the document ($base_uri). The base URI is needed to resolve
+relative action URIs. The provided HTML document should be a Unicode string
+(or US-ASCII).
+
+By default HTML::Form assumes that the original document was UTF-8 encoded and
+thus encode forms that don't specify an explict I<accept-charset> as UTF-8.
+The charset assumed can be overridden by providing the C<charset> option to
+parse(). It's a good idea to be explict about this parameter as well, thus
+the recommended simplest invocation becomes:
+
+ my @forms = HTML::Form->parse(
+ Encode::decode($encoding, $html_document_bytes),
+ base => $base_uri,
+ charset => $encoding,
+ );
+
+If the document was retrieved with LWP then the response object provide methods
+to obtain a proper value for C<base> and C<charset>:
+
+ my $ua = LWP::UserAgent->new;
+ my $response = $ua->get("http://www.example.com/form.html");
+ my @forms = HTML::Form->parse($response->decoded_content,
+ base => $response->base,
+ charset => $response->content_charset,
+ );
+
+In fact, the parse() method can parse from an C<HTTP::Response> object
+directly, so the example above can be more conveniently written as:
+
+ my $ua = LWP::UserAgent->new;
+ my $response = $ua->get("http://www.example.com/form.html");
+ my @forms = HTML::Form->parse($response);
+
+Note that any object that implements a decoded_content(), base() and
+content_charset() method with similar behaviour as C<HTTP::Response> will do.
+
+Additional options might be passed in to control how the parse method
+behaves. The following are all the options currently recognized:
+
+=over
+
+=item C<< base => $uri >>
+
+This is the URI used to retrive the original document. This option is not optional ;-)
+
+=item C<< charset => $str >>
+
+Specify what charset the original document was encoded in. This is used as
+the default for accept_charset. If not provided this defaults to "UTF-8".
+
+=item C<< verbose => $bool >>
+
+Warn (print messages to STDERR) about any bad HTML form constructs found.
+You can trap these with $SIG{__WARN__}.
+
+=item C<< strict => $bool >>
+
+Initialize any form objects with the given strict attribute.
+
+=back
+
+=cut
+
+sub parse
+{
+ my $class = shift;
+ my $html = shift;
+ unshift(@_, "base") if @_ == 1;
+ my %opt = @_;
+
+ require HTML::TokeParser;
+ my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
+ die "Failed to create HTML::TokeParser object" unless $p;
+
+ my $base_uri = delete $opt{base};
+ my $charset = delete $opt{charset};
+ my $strict = delete $opt{strict};
+ my $verbose = delete $opt{verbose};
+
+ if ($^W) {
+ Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
+ }
+
+ unless (defined $base_uri) {
+ if (ref($html)) {
+ $base_uri = $html->base;
+ }
+ else {
+ Carp::croak("HTML::Form::parse: No \$base_uri provided");
+ }
+ }
+ unless (defined $charset) {
+ if (ref($html) and $html->can("content_charset")) {
+ $charset = $html->content_charset;
+ }
+ unless ($charset) {
+ $charset = "UTF-8";
+ }
+ }
+
+ my @forms;
+ my $f; # current form
+
+ my %openselect; # index to the open instance of a select
+
+ while (my $t = $p->get_tag) {
+ my($tag,$attr) = @$t;
+ if ($tag eq "form") {
+ my $action = delete $attr->{'action'};
+ $action = "" unless defined $action;
+ $action = URI->new_abs($action, $base_uri);
+ $f = $class->new($attr->{'method'},
+ $action,
+ $attr->{'enctype'});
+ $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
+ $f->{default_charset} = $charset;
+ $f->{attr} = $attr;
+ $f->strict(1) if $strict;
+ %openselect = ();
+ push(@forms, $f);
+ my(%labels, $current_label);
+ while (my $t = $p->get_tag) {
+ my($tag, $attr) = @$t;
+ last if $tag eq "/form";
+
+ # if we are inside a label tag, then keep
+ # appending any text to the current label
+ if(defined $current_label) {
+ $current_label = join " ",
+ grep { defined and length }
+ $current_label,
+ $p->get_phrase;
+ }
+
+ if ($tag eq "input") {
+ $attr->{value_name} =
+ exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
+ defined $current_label ? $current_label :
+ $p->get_phrase;
+ }
+
+ if ($tag eq "label") {
+ $current_label = $p->get_phrase;
+ $labels{ $attr->{for} } = $current_label
+ if exists $attr->{for};
+ }
+ elsif ($tag eq "/label") {
+ $current_label = undef;
+ }
+ elsif ($tag eq "input") {
+ my $type = delete $attr->{type} || "text";
+ $f->push_input($type, $attr, $verbose);
+ }
+ elsif ($tag eq "button") {
+ my $type = delete $attr->{type} || "submit";
+ $f->push_input($type, $attr, $verbose);
+ }
+ elsif ($tag eq "textarea") {
+ $attr->{textarea_value} = $attr->{value}
+ if exists $attr->{value};
+ my $text = $p->get_text("/textarea");
+ $attr->{value} = $text;
+ $f->push_input("textarea", $attr, $verbose);
+ }
+ elsif ($tag eq "select") {
+ # rename attributes reserved to come for the option tag
+ for ("value", "value_name") {
+ $attr->{"select_$_"} = delete $attr->{$_}
+ if exists $attr->{$_};
+ }
+ # count this new select option separately
+ my $name = $attr->{name};
+ $name = "" unless defined $name;
+ $openselect{$name}++;
+
+ while ($t = $p->get_tag) {
+ my $tag = shift @$t;
+ last if $tag eq "/select";
+ next if $tag =~ m,/?optgroup,;
+ next if $tag eq "/option";
+ if ($tag eq "option") {
+ my %a = %{$t->[0]};
+ # rename keys so they don't clash with %attr
+ for (keys %a) {
+ next if $_ eq "value";
+ $a{"option_$_"} = delete $a{$_};
+ }
+ while (my($k,$v) = each %$attr) {
+ $a{$k} = $v;
+ }
+ $a{value_name} = $p->get_trimmed_text;
+ $a{value} = delete $a{value_name}
+ unless defined $a{value};
+ $a{idx} = $openselect{$name};
+ $f->push_input("option", \%a, $verbose);
+ }
+ else {
+ warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
+ if ($tag eq "/form" ||
+ $tag eq "input" ||
+ $tag eq "textarea" ||
+ $tag eq "select" ||
+ $tag eq "keygen")
+ {
+ # MSIE implictly terminate the <select> here, so we
+ # try to do the same. Actually the MSIE behaviour
+ # appears really strange: <input> and <textarea>
+ # do implictly close, but not <select>, <keygen> or
+ # </form>.
+ my $type = ($tag =~ s,^/,,) ? "E" : "S";
+ $p->unget_token([$type, $tag, @$t]);
+ last;
+ }
+ }
+ }
+ }
+ elsif ($tag eq "keygen") {
+ $f->push_input("keygen", $attr, $verbose);
+ }
+ }
+ }
+ elsif ($form_tags{$tag}) {
+ warn("<$tag> outside <form> in $base_uri\n") if $verbose;
+ }
+ }
+ for (@forms) {
+ $_->fixup;
+ }
+
+ wantarray ? @forms : $forms[0];
+}
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->{method} = uc(shift || "GET");
+ $self->{action} = shift || Carp::croak("No action defined");
+ $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
+ $self->{accept_charset} = "UNKNOWN";
+ $self->{default_charset} = "UTF-8";
+ $self->{inputs} = [@_];
+ $self;
+}
+
+
+sub push_input
+{
+ my($self, $type, $attr, $verbose) = @_;
+ $type = lc $type;
+ my $class = $type2class{$type};
+ unless ($class) {
+ Carp::carp("Unknown input type '$type'") if $verbose;
+ $class = "TextInput";
+ }
+ $class = "HTML::Form::$class";
+ my @extra;
+ push(@extra, readonly => 1) if $type eq "hidden";
+ push(@extra, strict => 1) if $self->{strict};
+ if ($type eq "file" && exists $attr->{value}) {
+ # it's not safe to trust the value set by the server
+ # the user always need to explictly set the names of files to upload
+ $attr->{orig_value} = delete $attr->{value};
+ }
+ delete $attr->{type}; # don't confuse the type argument
+ my $input = $class->new(type => $type, %$attr, @extra);
+ $input->add_to_form($self);
+}
+
+
+=item $method = $form->method
+
+=item $form->method( $new_method )
+
+This method is gets/sets the I<method> name used for the
+C<HTTP::Request> generated. It is a string like "GET" or "POST".
+
+=item $action = $form->action
+
+=item $form->action( $new_action )
+
+This method gets/sets the URI which we want to apply the request
+I<method> to.
+
+=item $enctype = $form->enctype
+
+=item $form->enctype( $new_enctype )
+
+This method gets/sets the encoding type for the form data. It is a
+string like "application/x-www-form-urlencoded" or "multipart/form-data".
+
+=item $accept = $form->accept_charset
+
+=item $form->accept_charset( $new_accept )
+
+This method gets/sets the list of charset encodings that the server processing
+the form accepts. Current implementation supports only one-element lists.
+Default value is "UNKNOWN" which we interpret as a request to use document
+charset as specified by the 'charset' parameter of the parse() method. To
+encode character strings you should have modern perl with Encode module. On
+older perls the setting of this attribute has no effect.
+
+=cut
+
+BEGIN {
+ # Set up some accesor
+ for (qw(method action enctype accept_charset)) {
+ my $m = $_;
+ no strict 'refs';
+ *{$m} = sub {
+ my $self = shift;
+ my $old = $self->{$m};
+ $self->{$m} = shift if @_;
+ $old;
+ };
+ }
+ *uri = \&action; # alias
+}
+
+=item $value = $form->attr( $name )
+
+=item $form->attr( $name, $new_value )
+
+This method give access to the original HTML attributes of the <form> tag.
+The $name should always be passed in lower case.
+
+Example:
+
+ @f = HTML::Form->parse( $html, $foo );
+ @f = grep $_->attr("id") eq "foo", @f;
+ die "No form named 'foo' found" unless @f;
+ $foo = shift @f;
+
+=cut
+
+sub attr {
+ my $self = shift;
+ my $name = shift;
+ return undef unless defined $name;
+
+ my $old = $self->{attr}{$name};
+ $self->{attr}{$name} = shift if @_;
+ return $old;
+}
+
+=item $bool = $form->strict
+
+=item $form->strict( $bool )
+
+Gets/sets the strict attribute of a form. If the strict is turned on
+the methods that change values of the form will croak if you try to
+set illegal values or modify readonly fields. The default is not to be strict.
+
+=cut
+
+sub strict {
+ my $self = shift;
+ my $old = $self->{strict};
+ if (@_) {
+ $self->{strict} = shift;
+ for my $input (@{$self->{inputs}}) {
+ $input->strict($self->{strict});
+ }
+ }
+ return $old;
+}
+
+
+=item @inputs = $form->inputs
+
+This method returns the list of inputs in the form. If called in
+scalar context it returns the number of inputs contained in the form.
+See L</INPUTS> for what methods are available for the input objects
+returned.
+
+=cut
+
+sub inputs
+{
+ my $self = shift;
+ @{$self->{'inputs'}};
+}
+
+
+=item $input = $form->find_input( $selector )
+
+=item $input = $form->find_input( $selector, $type )
+
+=item $input = $form->find_input( $selector, $type, $index )
+
+This method is used to locate specific inputs within the form. All
+inputs that match the arguments given are returned. In scalar context
+only the first is returned, or C<undef> if none match.
+
+If $selector is specified, then the input's name, id, class attribute must
+match. A selector prefixed with '#' must match the id attribute of the input.
+A selector prefixed with '.' matches the class attribute. A selector prefixed
+with '^' or with no prefix matches the name attribute.
+
+If $type is specified, then the input must have the specified type.
+The following type names are used: "text", "password", "hidden",
+"textarea", "file", "image", "submit", "radio", "checkbox" and "option".
+
+The $index is the sequence number of the input matched where 1 is the
+first. If combined with $name and/or $type then it select the I<n>th
+input with the given name and/or type.
+
+=cut
+
+sub find_input
+{
+ my($self, $name, $type, $no) = @_;
+ if (wantarray) {
+ my @res;
+ my $c;
+ for (@{$self->{'inputs'}}) {
+ next if defined($name) && !$_->selected($name);
+ next if $type && $type ne $_->{type};
+ $c++;
+ next if $no && $no != $c;
+ push(@res, $_);
+ }
+ return @res;
+
+ }
+ else {
+ $no ||= 1;
+ for (@{$self->{'inputs'}}) {
+ next if defined($name) && !$_->selected($name);
+ next if $type && $type ne $_->{type};
+ next if --$no;
+ return $_;
+ }
+ return undef;
+ }
+}
+
+sub fixup
+{
+ my $self = shift;
+ for (@{$self->{'inputs'}}) {
+ $_->fixup;
+ }
+}
+
+
+=item $value = $form->value( $selector )
+
+=item $form->value( $selector, $new_value )
+
+The value() method can be used to get/set the value of some input. If
+strict is enabled and no input has the indicated name, then this method will croak.
+
+If multiple inputs have the same name, only the first one will be
+affected.
+
+The call:
+
+ $form->value('foo')
+
+is basically a short-hand for:
+
+ $form->find_input('foo')->value;
+
+=cut
+
+sub value
+{
+ my $self = shift;
+ my $key = shift;
+ my $input = $self->find_input($key);
+ unless ($input) {
+ Carp::croak("No such field '$key'") if $self->{strict};
+ return undef unless @_;
+ $input = $self->push_input("text", { name => $key, value => "" });
+ }
+ local $Carp::CarpLevel = 1;
+ $input->value(@_);
+}
+
+=item @names = $form->param
+
+=item @values = $form->param( $name )
+
+=item $form->param( $name, $value, ... )
+
+=item $form->param( $name, \@values )
+
+Alternative interface to examining and setting the values of the form.
+
+If called without arguments then it returns the names of all the
+inputs in the form. The names will not repeat even if multiple inputs
+have the same name. In scalar context the number of different names
+is returned.
+
+If called with a single argument then it returns the value or values
+of inputs with the given name. If called in scalar context only the
+first value is returned. If no input exists with the given name, then
+C<undef> is returned.
+
+If called with 2 or more arguments then it will set values of the
+named inputs. This form will croak if no inputs have the given name
+or if any of the values provided does not fit. Values can also be
+provided as a reference to an array. This form will allow unsetting
+all values with the given name as well.
+
+This interface resembles that of the param() function of the CGI
+module.
+
+=cut
+
+sub param {
+ my $self = shift;
+ if (@_) {
+ my $name = shift;
+ my @inputs;
+ for ($self->inputs) {
+ my $n = $_->name;
+ next if !defined($n) || $n ne $name;
+ push(@inputs, $_);
+ }
+
+ if (@_) {
+ # set
+ die "No '$name' parameter exists" unless @inputs;
+ my @v = @_;
+ @v = @{$v[0]} if @v == 1 && ref($v[0]);
+ while (@v) {
+ my $v = shift @v;
+ my $err;
+ for my $i (0 .. @inputs-1) {
+ eval {
+ $inputs[$i]->value($v);
+ };
+ unless ($@) {
+ undef($err);
+ splice(@inputs, $i, 1);
+ last;
+ }
+ $err ||= $@;
+ }
+ die $err if $err;
+ }
+
+ # the rest of the input should be cleared
+ for (@inputs) {
+ $_->value(undef);
+ }
+ }
+ else {
+ # get
+ my @v;
+ for (@inputs) {
+ if (defined(my $v = $_->value)) {
+ push(@v, $v);
+ }
+ }
+ return wantarray ? @v : $v[0];
+ }
+ }
+ else {
+ # list parameter names
+ my @n;
+ my %seen;
+ for ($self->inputs) {
+ my $n = $_->name;
+ next if !defined($n) || $seen{$n}++;
+ push(@n, $n);
+ }
+ return @n;
+ }
+}
+
+
+=item $form->try_others( \&callback )
+
+This method will iterate over all permutations of unvisited enumerated
+values (<select>, <radio>, <checkbox>) and invoke the callback for
+each. The callback is passed the $form as argument. The return value
+from the callback is ignored and the try_others() method itself does
+not return anything.
+
+=cut
+
+sub try_others
+{
+ my($self, $cb) = @_;
+ my @try;
+ for (@{$self->{'inputs'}}) {
+ my @not_tried_yet = $_->other_possible_values;
+ next unless @not_tried_yet;
+ push(@try, [\@not_tried_yet, $_]);
+ }
+ return unless @try;
+ $self->_try($cb, \@try, 0);
+}
+
+sub _try
+{
+ my($self, $cb, $try, $i) = @_;
+ for (@{$try->[$i][0]}) {
+ $try->[$i][1]->value($_);
+ &$cb($self);
+ $self->_try($cb, $try, $i+1) if $i+1 < @$try;
+ }
+}
+
+
+=item $request = $form->make_request
+
+Will return an C<HTTP::Request> object that reflects the current setting
+of the form. You might want to use the click() method instead.
+
+=cut
+
+sub make_request
+{
+ my $self = shift;
+ my $method = uc $self->{'method'};
+ my $uri = $self->{'action'};
+ my $enctype = $self->{'enctype'};
+ my @form = $self->form;
+
+ my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
+ if ($Encode_available) {
+ foreach my $fi (@form) {
+ $fi = Encode::encode($charset, $fi) unless ref($fi);
+ }
+ }
+
+ if ($method eq "GET") {
+ require HTTP::Request;
+ $uri = URI->new($uri, "http");
+ $uri->query_form(@form);
+ return HTTP::Request->new(GET => $uri);
+ }
+ elsif ($method eq "POST") {
+ require HTTP::Request::Common;
+ return HTTP::Request::Common::POST($uri, \@form,
+ Content_Type => $enctype);
+ }
+ else {
+ Carp::croak("Unknown method '$method'");
+ }
+}
+
+
+=item $request = $form->click
+
+=item $request = $form->click( $selector )
+
+=item $request = $form->click( $x, $y )
+
+=item $request = $form->click( $selector, $x, $y )
+
+Will "click" on the first clickable input (which will be of type
+C<submit> or C<image>). The result of clicking is an C<HTTP::Request>
+object that can then be passed to C<LWP::UserAgent> if you want to
+obtain the server response.
+
+If a $selector is specified, we will click on the first clickable input
+matching the selector, and the method will croak if no matching clickable
+input is found. If $selector is I<not> specified, then it
+is ok if the form contains no clickable inputs. In this case the
+click() method returns the same request as the make_request() method
+would do. See description of the find_input() method above for how
+the $selector is specified.
+
+If there are multiple clickable inputs with the same name, then there
+is no way to get the click() method of the C<HTML::Form> to click on
+any but the first. If you need this you would have to locate the
+input with find_input() and invoke the click() method on the given
+input yourself.
+
+A click coordinate pair can also be provided, but this only makes a
+difference if you clicked on an image. The default coordinate is
+(1,1). The upper-left corner of the image is (0,0), but some badly
+coded CGI scripts are known to not recognize this. Therefore (1,1) was
+selected as a safer default.
+
+=cut
+
+sub click
+{
+ my $self = shift;
+ my $name;
+ $name = shift if (@_ % 2) == 1; # odd number of arguments
+
+ # try to find first submit button to activate
+ for (@{$self->{'inputs'}}) {
+ next unless $_->can("click");
+ next if $name && !$_->selected($name);
+ next if $_->disabled;
+ return $_->click($self, @_);
+ }
+ Carp::croak("No clickable input with name $name") if $name;
+ $self->make_request;
+}
+
+
+=item @kw = $form->form
+
+Returns the current setting as a sequence of key/value pairs. Note
+that keys might be repeated, which means that some values might be
+lost if the return values are assigned to a hash.
+
+In scalar context this method returns the number of key/value pairs
+generated.
+
+=cut
+
+sub form
+{
+ my $self = shift;
+ map { $_->form_name_value($self) } @{$self->{'inputs'}};
+}
+
+
+=item $form->dump
+
+Returns a textual representation of current state of the form. Mainly
+useful for debugging. If called in void context, then the dump is
+printed on STDERR.
+
+=cut
+
+sub dump
+{
+ my $self = shift;
+ my $method = $self->{'method'};
+ my $uri = $self->{'action'};
+ my $enctype = $self->{'enctype'};
+ my $dump = "$method $uri";
+ $dump .= " ($enctype)"
+ if $enctype ne "application/x-www-form-urlencoded";
+ $dump .= " [$self->{attr}{name}]"
+ if exists $self->{attr}{name};
+ $dump .= "\n";
+ for ($self->inputs) {
+ $dump .= " " . $_->dump . "\n";
+ }
+ print STDERR $dump unless defined wantarray;
+ $dump;
+}
+
+
+#---------------------------------------------------
+package HTML::Form::Input;
+
+=back
+
+=head1 INPUTS
+
+An C<HTML::Form> objects contains a sequence of I<inputs>. References to
+the inputs can be obtained with the $form->inputs or $form->find_input
+methods.
+
+Note that there is I<not> a one-to-one correspondence between input
+I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An
+input object basically represents a name/value pair, so when multiple
+HTML elements contribute to the same name/value pair in the submitted
+form they are combined.
+
+The input elements that are mapped one-to-one are "text", "textarea",
+"password", "hidden", "file", "image", "submit" and "checkbox". For
+the "radio" and "option" inputs the story is not as simple: All
+E<lt>input type="radio"E<gt> elements with the same name will
+contribute to the same input radio object. The number of radio input
+objects will be the same as the number of distinct names used for the
+E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element
+without the C<multiple> attribute there will be one input object of
+type of "option". For a E<lt>select multipleE<gt> element there will
+be one input object for each contained E<lt>optionE<gt> element. Each
+one of these option objects will have the same name.
+
+The following methods are available for the I<input> objects:
+
+=over 4
+
+=cut
+
+sub new
+{
+ my $class = shift;
+ my $self = bless {@_}, $class;
+ $self;
+}
+
+sub add_to_form
+{
+ my($self, $form) = @_;
+ push(@{$form->{'inputs'}}, $self);
+ $self;
+}
+
+sub strict {
+ my $self = shift;
+ my $old = $self->{strict};
+ if (@_) {
+ $self->{strict} = shift;
+ }
+ $old;
+}
+
+sub fixup {}
+
+
+=item $input->type
+
+Returns the type of this input. The type is one of the following
+strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
+"radio", "checkbox" or "option".
+
+=cut
+
+sub type
+{
+ shift->{type};
+}
+
+=item $name = $input->name
+
+=item $input->name( $new_name )
+
+This method can be used to get/set the current name of the input.
+
+=item $input->id
+
+=item $input->class
+
+These methods can be used to get/set the current id or class attribute for the input.
+
+=item $input->selected( $selector )
+
+Returns TRUE if the given selector matched the input. See the description of
+the find_input() method above for a description of the selector syntax.
+
+=item $value = $input->value
+
+=item $input->value( $new_value )
+
+This method can be used to get/set the current value of an
+input.
+
+If strict is enabled and the input only can take an enumerated list of values,
+then it is an error to try to set it to something else and the method will
+croak if you try.
+
+You will also be able to set the value of read-only inputs, but a
+warning will be generated if running under C<perl -w>.
+
+=cut
+
+sub name
+{
+ my $self = shift;
+ my $old = $self->{name};
+ $self->{name} = shift if @_;
+ $old;
+}
+
+sub id
+{
+ my $self = shift;
+ my $old = $self->{id};
+ $self->{id} = shift if @_;
+ $old;
+}
+
+sub class
+{
+ my $self = shift;
+ my $old = $self->{class};
+ $self->{class} = shift if @_;
+ $old;
+}
+
+sub selected {
+ my($self, $sel) = @_;
+ return undef unless defined $sel;
+ my $attr =
+ $sel =~ s/^\^// ? "name" :
+ $sel =~ s/^#// ? "id" :
+ $sel =~ s/^\.// ? "class" :
+ "name";
+ return 0 unless defined $self->{$attr};
+ return $self->{$attr} eq $sel;
+}
+
+sub value
+{
+ my $self = shift;
+ my $old = $self->{value};
+ $self->{value} = shift if @_;
+ $old;
+}
+
+=item $input->possible_values
+
+Returns a list of all values that an input can take. For inputs that
+do not have discrete values, this returns an empty list.
+
+=cut
+
+sub possible_values
+{
+ return;
+}
+
+=item $input->other_possible_values
+
+Returns a list of all values not tried yet.
+
+=cut
+
+sub other_possible_values
+{
+ return;
+}
+
+=item $input->value_names
+
+For some inputs the values can have names that are different from the
+values themselves. The number of names returned by this method will
+match the number of values reported by $input->possible_values.
+
+When setting values using the value() method it is also possible to
+use the value names in place of the value itself.
+
+=cut
+
+sub value_names {
+ return
+}
+
+=item $bool = $input->readonly
+
+=item $input->readonly( $bool )
+
+This method is used to get/set the value of the readonly attribute.
+You are allowed to modify the value of readonly inputs, but setting
+the value will generate some noise when warnings are enabled. Hidden
+fields always start out readonly.
+
+=cut
+
+sub readonly {
+ my $self = shift;
+ my $old = $self->{readonly};
+ $self->{readonly} = shift if @_;
+ $old;
+}
+
+=item $bool = $input->disabled
+
+=item $input->disabled( $bool )
+
+This method is used to get/set the value of the disabled attribute.
+Disabled inputs do not contribute any key/value pairs for the form
+value.
+
+=cut
+
+sub disabled {
+ my $self = shift;
+ my $old = $self->{disabled};
+ $self->{disabled} = shift if @_;
+ $old;
+}
+
+=item $input->form_name_value
+
+Returns a (possible empty) list of key/value pairs that should be
+incorporated in the form value from this input.
+
+=cut
+
+sub form_name_value
+{
+ my $self = shift;
+ my $name = $self->{'name'};
+ return unless defined $name;
+ return if $self->disabled;
+ my $value = $self->value;
+ return unless defined $value;
+ return ($name => $value);
+}
+
+sub dump
+{
+ my $self = shift;
+ my $name = $self->name;
+ $name = "<NONAME>" unless defined $name;
+ my $value = $self->value;
+ $value = "<UNDEF>" unless defined $value;
+ my $dump = "$name=$value";
+
+ my $type = $self->type;
+
+ $type .= " disabled" if $self->disabled;
+ $type .= " readonly" if $self->readonly;
+ return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
+
+ my @menu;
+ my $i = 0;
+ for (@{$self->{menu}}) {
+ my $opt = $_->{value};
+ $opt = "<UNDEF>" unless defined $opt;
+ $opt .= "/$_->{name}"
+ if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
+ substr($opt,0,0) = "-" if $_->{disabled};
+ if (exists $self->{current} && $self->{current} == $i) {
+ substr($opt,0,0) = "!" unless $_->{seen};
+ substr($opt,0,0) = "*";
+ }
+ else {
+ substr($opt,0,0) = ":" if $_->{seen};
+ }
+ push(@menu, $opt);
+ $i++;
+ }
+
+ return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
+}
+
+
+#---------------------------------------------------
+package HTML::Form::TextInput;
+@HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
+
+#input/text
+#input/password
+#input/hidden
+#textarea
+
+sub value
+{
+ my $self = shift;
+ my $old = $self->{value};
+ $old = "" unless defined $old;
+ if (@_) {
+ Carp::croak("Input '$self->{name}' is readonly")
+ if $self->{strict} && $self->{readonly};
+ my $new = shift;
+ my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
+ Carp::croak("Input '$self->{name}' has maxlength '$n'")
+ if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
+ $self->{value} = $new;
+ }
+ $old;
+}
+
+#---------------------------------------------------
+package HTML::Form::IgnoreInput;
+@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
+
+#input/button
+#input/reset
+
+sub value { return }
+
+
+#---------------------------------------------------
+package HTML::Form::ListInput;
+@HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
+
+#select/option (val1, val2, ....)
+#input/radio (undef, val1, val2,...)
+#input/checkbox (undef, value)
+#select-multiple/option (undef, value)
+
+sub new
+{
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ my $value = delete $self->{value};
+ my $value_name = delete $self->{value_name};
+ my $type = $self->{type};
+
+ if ($type eq "checkbox") {
+ $value = "on" unless defined $value;
+ $self->{menu} = [
+ { value => undef, name => "off", },
+ { value => $value, name => $value_name, },
+ ];
+ $self->{current} = (delete $self->{checked}) ? 1 : 0;
+ ;
+ }
+ else {
+ $self->{option_disabled}++
+ if $type eq "radio" && delete $self->{disabled};
+ $self->{menu} = [
+ {value => $value, name => $value_name},
+ ];
+ my $checked = $self->{checked} || $self->{option_selected};
+ delete $self->{checked};
+ delete $self->{option_selected};
+ if (exists $self->{multiple}) {
+ unshift(@{$self->{menu}}, { value => undef, name => "off"});
+ $self->{current} = $checked ? 1 : 0;
+ }
+ else {
+ $self->{current} = 0 if $checked;
+ }
+ }
+ $self;
+}
+
+sub add_to_form
+{
+ my($self, $form) = @_;
+ my $type = $self->type;
+
+ return $self->SUPER::add_to_form($form)
+ if $type eq "checkbox";
+
+ if ($type eq "option" && exists $self->{multiple}) {
+ $self->{disabled} ||= delete $self->{option_disabled};
+ return $self->SUPER::add_to_form($form);
+ }
+
+ die "Assert" if @{$self->{menu}} != 1;
+ my $m = $self->{menu}[0];
+ $m->{disabled}++ if delete $self->{option_disabled};
+
+ my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
+ return $self->SUPER::add_to_form($form) unless $prev;
+
+ # merge menues
+ $prev->{current} = @{$prev->{menu}} if exists $self->{current};
+ push(@{$prev->{menu}}, $m);
+}
+
+sub fixup
+{
+ my $self = shift;
+ if ($self->{type} eq "option" && !(exists $self->{current})) {
+ $self->{current} = 0;
+ }
+ $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
+}
+
+sub disabled
+{
+ my $self = shift;
+ my $type = $self->type;
+
+ my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
+ if (@_) {
+ my $v = shift;
+ $self->{disabled} = $v;
+ for (@{$self->{menu}}) {
+ $_->{disabled} = $v;
+ }
+ }
+ return $old;
+}
+
+sub _menu_all_disabled {
+ for (@_) {
+ return 0 unless $_->{disabled};
+ }
+ return 1;
+}
+
+sub value
+{
+ my $self = shift;
+ my $old;
+ $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
+ $old = $self->{value} if exists $self->{value};
+ if (@_) {
+ my $i = 0;
+ my $val = shift;
+ my $cur;
+ my $disabled;
+ for (@{$self->{menu}}) {
+ if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
+ (!defined($val) && !defined($_->{value}))
+ )
+ {
+ $cur = $i;
+ $disabled = $_->{disabled};
+ last unless $disabled;
+ }
+ $i++;
+ }
+ if (!(defined $cur) || $disabled) {
+ if (defined $val) {
+ # try to search among the alternative names as well
+ my $i = 0;
+ my $cur_ignorecase;
+ my $lc_val = lc($val);
+ for (@{$self->{menu}}) {
+ if (defined $_->{name}) {
+ if ($val eq $_->{name}) {
+ $disabled = $_->{disabled};
+ $cur = $i;
+ last unless $disabled;
+ }
+ if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
+ $cur_ignorecase = $i;
+ }
+ }
+ $i++;
+ }
+ unless (defined $cur) {
+ $cur = $cur_ignorecase;
+ if (defined $cur) {
+ $disabled = $self->{menu}[$cur]{disabled};
+ }
+ elsif ($self->{strict}) {
+ my $n = $self->name;
+ Carp::croak("Illegal value '$val' for field '$n'");
+ }
+ }
+ }
+ elsif ($self->{strict}) {
+ my $n = $self->name;
+ Carp::croak("The '$n' field can't be unchecked");
+ }
+ }
+ if ($self->{strict} && $disabled) {
+ my $n = $self->name;
+ Carp::croak("The value '$val' has been disabled for field '$n'");
+ }
+ if (defined $cur) {
+ $self->{current} = $cur;
+ $self->{menu}[$cur]{seen}++;
+ delete $self->{value};
+ }
+ else {
+ $self->{value} = $val;
+ delete $self->{current};
+ }
+ }
+ $old;
+}
+
+=item $input->check
+
+Some input types represent toggles that can be turned on/off. This
+includes "checkbox" and "option" inputs. Calling this method turns
+this input on without having to know the value name. If the input is
+already on, then nothing happens.
+
+This has the same effect as:
+
+ $input->value($input->possible_values[1]);
+
+The input can be turned off with:
+
+ $input->value(undef);
+
+=cut
+
+sub check
+{
+ my $self = shift;
+ $self->{current} = 1;
+ $self->{menu}[1]{seen}++;
+}
+
+sub possible_values
+{
+ my $self = shift;
+ map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
+}
+
+sub other_possible_values
+{
+ my $self = shift;
+ map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
+}
+
+sub value_names {
+ my $self = shift;
+ my @names;
+ for (@{$self->{menu}}) {
+ my $n = $_->{name};
+ $n = $_->{value} unless defined $n;
+ push(@names, $n);
+ }
+ @names;
+}
+
+
+#---------------------------------------------------
+package HTML::Form::SubmitInput;
+@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
+
+#input/image
+#input/submit
+
+=item $input->click($form, $x, $y)
+
+Some input types (currently "submit" buttons and "images") can be
+clicked to submit the form. The click() method returns the
+corresponding C<HTTP::Request> object.
+
+=cut
+
+sub click
+{
+ my($self,$form,$x,$y) = @_;
+ for ($x, $y) { $_ = 1 unless defined; }
+ local($self->{clicked}) = [$x,$y];
+ return $form->make_request;
+}
+
+sub form_name_value
+{
+ my $self = shift;
+ return unless $self->{clicked};
+ return $self->SUPER::form_name_value(@_);
+}
+
+
+#---------------------------------------------------
+package HTML::Form::ImageInput;
+@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
+
+sub form_name_value
+{
+ my $self = shift;
+ my $clicked = $self->{clicked};
+ return unless $clicked;
+ return if $self->{disabled};
+ my $name = $self->{name};
+ $name = (defined($name) && length($name)) ? "$name." : "";
+ return ("${name}x" => $clicked->[0],
+ "${name}y" => $clicked->[1]
+ );
+}
+
+#---------------------------------------------------
+package HTML::Form::FileInput;
+@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
+
+=back
+
+If the input is of type C<file>, then it has these additional methods:
+
+=over 4
+
+=item $input->file
+
+This is just an alias for the value() method. It sets the filename to
+read data from.
+
+For security reasons this field will never be initialized from the parsing
+of a form. This prevents the server from triggering stealth uploads of
+arbitrary files from the client machine.
+
+=cut
+
+sub file {
+ my $self = shift;
+ $self->value(@_);
+}
+
+=item $filename = $input->filename
+
+=item $input->filename( $new_filename )
+
+This get/sets the filename reported to the server during file upload.
+This attribute defaults to the value reported by the file() method.
+
+=cut
+
+sub filename {
+ my $self = shift;
+ my $old = $self->{filename};
+ $self->{filename} = shift if @_;
+ $old = $self->file unless defined $old;
+ $old;
+}
+
+=item $content = $input->content
+
+=item $input->content( $new_content )
+
+This get/sets the file content provided to the server during file
+upload. This method can be used if you do not want the content to be
+read from an actual file.
+
+=cut
+
+sub content {
+ my $self = shift;
+ my $old = $self->{content};
+ $self->{content} = shift if @_;
+ $old;
+}
+
+=item @headers = $input->headers
+
+=item input->headers($key => $value, .... )
+
+This get/set additional header fields describing the file uploaded.
+This can for instance be used to set the C<Content-Type> reported for
+the file.
+
+=cut
+
+sub headers {
+ my $self = shift;
+ my $old = $self->{headers} || [];
+ $self->{headers} = [@_] if @_;
+ @$old;
+}
+
+sub form_name_value {
+ my($self, $form) = @_;
+ return $self->SUPER::form_name_value($form)
+ if $form->method ne "POST" ||
+ $form->enctype ne "multipart/form-data";
+
+ my $name = $self->name;
+ return unless defined $name;
+ return if $self->{disabled};
+
+ my $file = $self->file;
+ my $filename = $self->filename;
+ my @headers = $self->headers;
+ my $content = $self->content;
+ if (defined $content) {
+ $filename = $file unless defined $filename;
+ $file = undef;
+ unshift(@headers, "Content" => $content);
+ }
+ elsif (!defined($file) || length($file) == 0) {
+ return;
+ }
+
+ # legacy (this used to be the way to do it)
+ if (ref($file) eq "ARRAY") {
+ my $f = shift @$file;
+ my $fn = shift @$file;
+ push(@headers, @$file);
+ $file = $f;
+ $filename = $fn unless defined $filename;
+ }
+
+ return ($name => [$file, $filename, @headers]);
+}
+
+package HTML::Form::KeygenInput;
+@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
+
+sub challenge {
+ my $self = shift;
+ return $self->{challenge};
+}
+
+sub keytype {
+ my $self = shift;
+ return lc($self->{keytype} || 'rsa');
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 SEE ALSO
+
+L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2008 Gisle Aas.
+
+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.straw/lib/HTML/HeadParser.pm b/Master/tlpkg/tlperl.straw/lib/HTML/HeadParser.pm
new file mode 100755
index 00000000000..cb1f3b612a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/HeadParser.pm
@@ -0,0 +1,301 @@
+package HTML::HeadParser;
+
+=head1 NAME
+
+HTML::HeadParser - Parse <HEAD> section of a HTML document
+
+=head1 SYNOPSIS
+
+ require HTML::HeadParser;
+ $p = HTML::HeadParser->new;
+ $p->parse($text) and print "not finished";
+
+ $p->header('Title') # to access <title>....</title>
+ $p->header('Content-Base') # to access <base href="http://...">
+ $p->header('Foo') # to access <meta http-equiv="Foo" content="...">
+ $p->header('X-Meta-Author') # to access <meta name="author" content="...">
+ $p->header('X-Meta-Charset') # to access <meta charset="...">
+
+=head1 DESCRIPTION
+
+The C<HTML::HeadParser> is a specialized (and lightweight)
+C<HTML::Parser> that will only parse the E<lt>HEAD>...E<lt>/HEAD>
+section of an HTML document. The parse() method
+will return a FALSE value as soon as some E<lt>BODY> element or body
+text are found, and should not be called again after this.
+
+Note that the C<HTML::HeadParser> might get confused if raw undecoded
+UTF-8 is passed to the parse() method. Make sure the strings are
+properly decoded before passing them on.
+
+The C<HTML::HeadParser> keeps a reference to a header object, and the
+parser will update this header object as the various elements of the
+E<lt>HEAD> section of the HTML document are recognized. The following
+header fields are affected:
+
+=over 4
+
+=item Content-Base:
+
+The I<Content-Base> header is initialized from the E<lt>base
+href="..."> element.
+
+=item Title:
+
+The I<Title> header is initialized from the E<lt>title>...E<lt>/title>
+element.
+
+=item Isindex:
+
+The I<Isindex> header will be added if there is a E<lt>isindex>
+element in the E<lt>head>. The header value is initialized from the
+I<prompt> attribute if it is present. If no I<prompt> attribute is
+given it will have '?' as the value.
+
+=item X-Meta-Foo:
+
+All E<lt>meta> elements containing a C<name> attribute will result in
+headers using the prefix C<X-Meta-> appended with the value of the
+C<name> attribute as the name of the header, and the value of the
+C<content> attribute as the pushed header value.
+
+E<lt>meta> elements containing a C<http-equiv> attribute will result
+in headers as in above, but without the C<X-Meta-> prefix in the
+header name.
+
+E<lt>meta> elements containing a C<charset> attribute will result in
+an C<X-Meta-Charset> header, using the value of the C<charset>
+attribute as the pushed header value.
+
+=back
+
+=head1 METHODS
+
+The following methods (in addition to those provided by the
+superclass) are available:
+
+=over 4
+
+=cut
+
+
+require HTML::Parser;
+@ISA = qw(HTML::Parser);
+
+use HTML::Entities ();
+
+use strict;
+use vars qw($VERSION $DEBUG);
+#$DEBUG = 1;
+$VERSION = "3.62";
+
+=item $hp = HTML::HeadParser->new
+
+=item $hp = HTML::HeadParser->new( $header )
+
+The object constructor. The optional $header argument should be a
+reference to an object that implement the header() and push_header()
+methods as defined by the C<HTTP::Headers> class. Normally it will be
+of some class that is a or delegates to the C<HTTP::Headers> class.
+
+If no $header is given C<HTML::HeadParser> will create an
+C<HTTP::Headers> object by itself (initially empty).
+
+=cut
+
+sub new
+{
+ my($class, $header) = @_;
+ unless ($header) {
+ require HTTP::Headers;
+ $header = HTTP::Headers->new;
+ }
+
+ my $self = $class->SUPER::new(api_version => 3,
+ start_h => ["start", "self,tagname,attr"],
+ end_h => ["end", "self,tagname"],
+ text_h => ["text", "self,text"],
+ ignore_elements => [qw(script style)],
+ );
+ $self->{'header'} = $header;
+ $self->{'tag'} = ''; # name of active element that takes textual content
+ $self->{'text'} = ''; # the accumulated text associated with the element
+ $self;
+}
+
+=item $hp->header;
+
+Returns a reference to the header object.
+
+=item $hp->header( $key )
+
+Returns a header value. It is just a shorter way to write
+C<$hp-E<gt>header-E<gt>header($key)>.
+
+=cut
+
+sub header
+{
+ my $self = shift;
+ return $self->{'header'} unless @_;
+ $self->{'header'}->header(@_);
+}
+
+sub as_string # legacy
+{
+ my $self = shift;
+ $self->{'header'}->as_string;
+}
+
+sub flush_text # internal
+{
+ my $self = shift;
+ my $tag = $self->{'tag'};
+ my $text = $self->{'text'};
+ $text =~ s/^\s+//;
+ $text =~ s/\s+$//;
+ $text =~ s/\s+/ /g;
+ print "FLUSH $tag => '$text'\n" if $DEBUG;
+ if ($tag eq 'title') {
+ HTML::Entities::decode($text);
+ $self->{'header'}->push_header(Title => $text);
+ }
+ $self->{'tag'} = $self->{'text'} = '';
+}
+
+# This is an quote from the HTML3.2 DTD which shows which elements
+# that might be present in a <HEAD>...</HEAD>. Also note that the
+# <HEAD> tags themselves might be missing:
+#
+# <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? &
+# SCRIPT* & META* & LINK*">
+#
+# <!ELEMENT HEAD O O (%head.content)>
+#
+# From HTML 4.01:
+#
+# <!ENTITY % head.misc "SCRIPT|STYLE|META|LINK|OBJECT">
+# <!ENTITY % head.content "TITLE & BASE?">
+# <!ELEMENT HEAD O O (%head.content;) +(%head.misc;)>
+#
+# Added in HTML 5 as of WD-html5-20090423: noscript, command
+
+sub start
+{
+ my($self, $tag, $attr) = @_; # $attr is reference to a HASH
+ print "START[$tag]\n" if $DEBUG;
+ $self->flush_text if $self->{'tag'};
+ if ($tag eq 'meta') {
+ my $key = $attr->{'http-equiv'};
+ if (!defined($key) || !length($key)) {
+ if ($attr->{name}) {
+ $key = "X-Meta-\u$attr->{name}";
+ } elsif ($attr->{charset}) { # HTML 5 <meta charset="...">
+ $key = "X-Meta-Charset";
+ $self->{header}->push_header($key => $attr->{charset});
+ return;
+ } else {
+ return;
+ }
+ }
+ $self->{'header'}->push_header($key => $attr->{content});
+ } elsif ($tag eq 'base') {
+ return unless exists $attr->{href};
+ $self->{'header'}->push_header('Content-Base' => $attr->{href});
+ } elsif ($tag eq 'isindex') {
+ # This is a non-standard header. Perhaps we should just ignore
+ # this element
+ $self->{'header'}->push_header(Isindex => $attr->{prompt} || '?');
+ } elsif ($tag =~ /^(?:title|noscript|object|command)$/) {
+ # Just remember tag. Initialize header when we see the end tag.
+ $self->{'tag'} = $tag;
+ } elsif ($tag eq 'link') {
+ return unless exists $attr->{href};
+ # <link href="http:..." rel="xxx" rev="xxx" title="xxx">
+ my $h_val = "<" . delete($attr->{href}) . ">";
+ for (sort keys %{$attr}) {
+ next if $_ eq "/"; # XHTML junk
+ $h_val .= qq(; $_="$attr->{$_}");
+ }
+ $self->{'header'}->push_header(Link => $h_val);
+ } elsif ($tag eq 'head' || $tag eq 'html') {
+ # ignore
+ } else {
+ # stop parsing
+ $self->eof;
+ }
+}
+
+sub end
+{
+ my($self, $tag) = @_;
+ print "END[$tag]\n" if $DEBUG;
+ $self->flush_text if $self->{'tag'};
+ $self->eof if $tag eq 'head';
+}
+
+sub text
+{
+ my($self, $text) = @_;
+ print "TEXT[$text]\n" if $DEBUG;
+ unless ($self->{first_chunk}) {
+ # drop Unicode BOM if found
+ if ($self->utf8_mode) {
+ $text =~ s/^\xEF\xBB\xBF//;
+ }
+ else {
+ $text =~ s/^\x{FEFF}//;
+ }
+ $self->{first_chunk}++;
+ }
+ my $tag = $self->{tag};
+ if (!$tag && $text =~ /\S/) {
+ # Normal text means start of body
+ $self->eof;
+ return;
+ }
+ return if $tag ne 'title';
+ $self->{'text'} .= $text;
+}
+
+BEGIN {
+ *utf8_mode = sub { 1 } unless HTML::Entities::UNICODE_SUPPORT;;
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 EXAMPLE
+
+ $h = HTTP::Headers->new;
+ $p = HTML::HeadParser->new($h);
+ $p->parse(<<EOT);
+ <title>Stupid example</title>
+ <base href="http://www.linpro.no/lwp/">
+ Normal text starts here.
+ EOT
+ undef $p;
+ print $h->title; # should print "Stupid example"
+
+=head1 SEE ALSO
+
+L<HTML::Parser>, L<HTTP::Headers>
+
+The C<HTTP::Headers> class is distributed as part of the
+I<libwww-perl> package. If you don't have that distribution installed
+you need to provide the $header argument to the C<HTML::HeadParser>
+constructor with your own object that implements the documented
+protocol.
+
+=head1 COPYRIGHT
+
+Copyright 1996-2001 Gisle Aas. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTML/LinkExtor.pm b/Master/tlpkg/tlperl.straw/lib/HTML/LinkExtor.pm
new file mode 100755
index 00000000000..8d50439d15f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/LinkExtor.pm
@@ -0,0 +1,185 @@
+package HTML::LinkExtor;
+
+require HTML::Parser;
+@ISA = qw(HTML::Parser);
+$VERSION = "3.60";
+
+=head1 NAME
+
+HTML::LinkExtor - Extract links from an HTML document
+
+=head1 SYNOPSIS
+
+ require HTML::LinkExtor;
+ $p = HTML::LinkExtor->new(\&cb, "http://www.perl.org/");
+ sub cb {
+ my($tag, %links) = @_;
+ print "$tag @{[%links]}\n";
+ }
+ $p->parse_file("index.html");
+
+=head1 DESCRIPTION
+
+I<HTML::LinkExtor> is an HTML parser that extracts links from an
+HTML document. The I<HTML::LinkExtor> is a subclass of
+I<HTML::Parser>. This means that the document should be given to the
+parser by calling the $p->parse() or $p->parse_file() methods.
+
+=cut
+
+use strict;
+use HTML::Tagset ();
+
+# legacy (some applications grabs this hash directly)
+use vars qw(%LINK_ELEMENT);
+*LINK_ELEMENT = \%HTML::Tagset::linkElements;
+
+=over 4
+
+=item $p = HTML::LinkExtor->new
+
+=item $p = HTML::LinkExtor->new( $callback )
+
+=item $p = HTML::LinkExtor->new( $callback, $base )
+
+The constructor takes two optional arguments. The first is a reference
+to a callback routine. It will be called as links are found. If a
+callback is not provided, then links are just accumulated internally
+and can be retrieved by calling the $p->links() method.
+
+The $base argument is an optional base URL used to absolutize all URLs found.
+You need to have the I<URI> module installed if you provide $base.
+
+The callback is called with the lowercase tag name as first argument,
+and then all link attributes as separate key/value pairs. All
+non-link attributes are removed.
+
+=cut
+
+sub new
+{
+ my($class, $cb, $base) = @_;
+ my $self = $class->SUPER::new(
+ start_h => ["_start_tag", "self,tagname,attr"],
+ report_tags => [keys %HTML::Tagset::linkElements],
+ );
+ $self->{extractlink_cb} = $cb;
+ if ($base) {
+ require URI;
+ $self->{extractlink_base} = URI->new($base);
+ }
+ $self;
+}
+
+sub _start_tag
+{
+ my($self, $tag, $attr) = @_;
+
+ my $base = $self->{extractlink_base};
+ my $links = $HTML::Tagset::linkElements{$tag};
+ $links = [$links] unless ref $links;
+
+ my @links;
+ my $a;
+ for $a (@$links) {
+ next unless exists $attr->{$a};
+ push(@links, $a, $base ? URI->new($attr->{$a}, $base)->abs($base)
+ : $attr->{$a});
+ }
+ return unless @links;
+ $self->_found_link($tag, @links);
+}
+
+sub _found_link
+{
+ my $self = shift;
+ my $cb = $self->{extractlink_cb};
+ if ($cb) {
+ &$cb(@_);
+ } else {
+ push(@{$self->{'links'}}, [@_]);
+ }
+}
+
+=item $p->links
+
+Returns a list of all links found in the document. The returned
+values will be anonymous arrays with the following elements:
+
+ [$tag, $attr => $url1, $attr2 => $url2,...]
+
+The $p->links method will also truncate the internal link list. This
+means that if the method is called twice without any parsing
+between them the second call will return an empty list.
+
+Also note that $p->links will always be empty if a callback routine
+was provided when the I<HTML::LinkExtor> was created.
+
+=cut
+
+sub links
+{
+ my $self = shift;
+ exists($self->{'links'}) ? @{delete $self->{'links'}} : ();
+}
+
+# We override the parse_file() method so that we can clear the links
+# before we start a new file.
+sub parse_file
+{
+ my $self = shift;
+ delete $self->{'links'};
+ $self->SUPER::parse_file(@_);
+}
+
+=back
+
+=head1 EXAMPLE
+
+This is an example showing how you can extract links from a document
+received using LWP:
+
+ use LWP::UserAgent;
+ use HTML::LinkExtor;
+ use URI::URL;
+
+ $url = "http://www.perl.org/"; # for instance
+ $ua = LWP::UserAgent->new;
+
+ # Set up a callback that collect image links
+ my @imgs = ();
+ sub callback {
+ my($tag, %attr) = @_;
+ return if $tag ne 'img'; # we only look closer at <img ...>
+ push(@imgs, values %attr);
+ }
+
+ # Make the parser. Unfortunately, we don't know the base yet
+ # (it might be different from $url)
+ $p = HTML::LinkExtor->new(\&callback);
+
+ # Request document and parse it as it arrives
+ $res = $ua->request(HTTP::Request->new(GET => $url),
+ sub {$p->parse($_[0])});
+
+ # Expand all image URLs to absolute ones
+ my $base = $res->base;
+ @imgs = map { $_ = url($_, $base)->abs; } @imgs;
+
+ # Print them out
+ print join("\n", @imgs), "\n";
+
+=head1 SEE ALSO
+
+L<HTML::Parser>, L<HTML::Tagset>, L<LWP>, L<URI::URL>
+
+=head1 COPYRIGHT
+
+Copyright 1996-2001 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/HTML/Parser.pm b/Master/tlpkg/tlperl.straw/lib/HTML/Parser.pm
new file mode 100755
index 00000000000..55cf8d9c51d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/Parser.pm
@@ -0,0 +1,1240 @@
+package HTML::Parser;
+
+# Copyright 1996-2009, Gisle Aas.
+# Copyright 1999-2000, Michael A. Chase.
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+use strict;
+use vars qw($VERSION @ISA);
+
+$VERSION = "3.64";
+
+require HTML::Entities;
+
+require XSLoader;
+XSLoader::load('HTML::Parser', $VERSION);
+
+sub new
+{
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->init(@_);
+}
+
+
+sub init
+{
+ my $self = shift;
+ $self->_alloc_pstate;
+
+ my %arg = @_;
+ my $api_version = delete $arg{api_version} || (@_ ? 3 : 2);
+ if ($api_version >= 4) {
+ require Carp;
+ Carp::croak("API version $api_version not supported " .
+ "by HTML::Parser $VERSION");
+ }
+
+ if ($api_version < 3) {
+ # Set up method callbacks compatible with HTML-Parser-2.xx
+ $self->handler(text => "text", "self,text,is_cdata");
+ $self->handler(end => "end", "self,tagname,text");
+ $self->handler(process => "process", "self,token0,text");
+ $self->handler(start => "start",
+ "self,tagname,attr,attrseq,text");
+
+ $self->handler(comment =>
+ sub {
+ my($self, $tokens) = @_;
+ for (@$tokens) {
+ $self->comment($_);
+ }
+ }, "self,tokens");
+
+ $self->handler(declaration =>
+ sub {
+ my $self = shift;
+ $self->declaration(substr($_[0], 2, -1));
+ }, "self,text");
+ }
+
+ if (my $h = delete $arg{handlers}) {
+ $h = {@$h} if ref($h) eq "ARRAY";
+ while (my($event, $cb) = each %$h) {
+ $self->handler($event => @$cb);
+ }
+ }
+
+ # In the end we try to assume plain attribute or handler
+ while (my($option, $val) = each %arg) {
+ if ($option =~ /^(\w+)_h$/) {
+ $self->handler($1 => @$val);
+ }
+ elsif ($option =~ /^(text|start|end|process|declaration|comment)$/) {
+ require Carp;
+ Carp::croak("Bad constructor option '$option'");
+ }
+ else {
+ $self->$option($val);
+ }
+ }
+
+ return $self;
+}
+
+
+sub parse_file
+{
+ my($self, $file) = @_;
+ my $opened;
+ if (!ref($file) && ref(\$file) ne "GLOB") {
+ # Assume $file is a filename
+ local(*F);
+ open(F, "<", $file) || return undef;
+ binmode(F); # should we? good for byte counts
+ $opened++;
+ $file = *F;
+ }
+ my $chunk = '';
+ while (read($file, $chunk, 512)) {
+ $self->parse($chunk) || last;
+ }
+ close($file) if $opened;
+ $self->eof;
+}
+
+
+sub netscape_buggy_comment # legacy
+{
+ my $self = shift;
+ require Carp;
+ Carp::carp("netscape_buggy_comment() is deprecated. " .
+ "Please use the strict_comment() method instead");
+ my $old = !$self->strict_comment;
+ $self->strict_comment(!shift) if @_;
+ return $old;
+}
+
+# set up method stubs
+sub text { }
+*start = \&text;
+*end = \&text;
+*comment = \&text;
+*declaration = \&text;
+*process = \&text;
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+HTML::Parser - HTML parser class
+
+=head1 SYNOPSIS
+
+ use HTML::Parser ();
+
+ # Create parser object
+ $p = HTML::Parser->new( api_version => 3,
+ start_h => [\&start, "tagname, attr"],
+ end_h => [\&end, "tagname"],
+ marked_sections => 1,
+ );
+
+ # Parse document text chunk by chunk
+ $p->parse($chunk1);
+ $p->parse($chunk2);
+ #...
+ $p->eof; # signal end of document
+
+ # Parse directly from file
+ $p->parse_file("foo.html");
+ # or
+ open(my $fh, "<:utf8", "foo.html") || die;
+ $p->parse_file($fh);
+
+=head1 DESCRIPTION
+
+Objects of the C<HTML::Parser> class will recognize markup and
+separate it from plain text (alias data content) in HTML
+documents. As different kinds of markup and text are recognized, the
+corresponding event handlers are invoked.
+
+C<HTML::Parser> is not a generic SGML parser. We have tried to
+make it able to deal with the HTML that is actually "out there", and
+it normally parses as closely as possible to the way the popular web
+browsers do it instead of strictly following one of the many HTML
+specifications from W3C. Where there is disagreement, there is often
+an option that you can enable to get the official behaviour.
+
+The document to be parsed may be supplied in arbitrary chunks. This
+makes on-the-fly parsing as documents are received from the network
+possible.
+
+If event driven parsing does not feel right for your application, you
+might want to use C<HTML::PullParser>. This is an C<HTML::Parser>
+subclass that allows a more conventional program structure.
+
+
+=head1 METHODS
+
+The following method is used to construct a new C<HTML::Parser> object:
+
+=over
+
+=item $p = HTML::Parser->new( %options_and_handlers )
+
+This class method creates a new C<HTML::Parser> object and
+returns it. Key/value argument pairs may be provided to assign event
+handlers or initialize parser options. The handlers and parser
+options can also be set or modified later by the method calls described below.
+
+If a top level key is in the form "<event>_h" (e.g., "text_h") then it
+assigns a handler to that event, otherwise it initializes a parser
+option. The event handler specification value must be an array
+reference. Multiple handlers may also be assigned with the 'handlers
+=> [%handlers]' option. See examples below.
+
+If new() is called without any arguments, it will create a parser that
+uses callback methods compatible with version 2 of C<HTML::Parser>.
+See the section on "version 2 compatibility" below for details.
+
+The special constructor option 'api_version => 2' can be used to
+initialize version 2 callbacks while still setting other options and
+handlers. The 'api_version => 3' option can be used if you don't want
+to set any options and don't want to fall back to v2 compatible
+mode.
+
+Examples:
+
+ $p = HTML::Parser->new(api_version => 3,
+ text_h => [ sub {...}, "dtext" ]);
+
+This creates a new parser object with a text event handler subroutine
+that receives the original text with general entities decoded.
+
+ $p = HTML::Parser->new(api_version => 3,
+ start_h => [ 'my_start', "self,tokens" ]);
+
+This creates a new parser object with a start event handler method
+that receives the $p and the tokens array.
+
+ $p = HTML::Parser->new(api_version => 3,
+ handlers => { text => [\@array, "event,text"],
+ comment => [\@array, "event,text"],
+ });
+
+This creates a new parser object that stores the event type and the
+original text in @array for text and comment events.
+
+=back
+
+The following methods feed the HTML document
+to the C<HTML::Parser> object:
+
+=over
+
+=item $p->parse( $string )
+
+Parse $string as the next chunk of the HTML document. Handlers invoked should
+not attempt to modify the $string in-place until $p->parse returns.
+
+If an invoked event handler aborts parsing by calling $p->eof, then $p->parse()
+will return a FALSE value. Otherwise the return value is a reference to the
+parser object ($p).
+
+=item $p->parse( $code_ref )
+
+If a code reference is passed as the argument to be parsed, then the
+chunks to be parsed are obtained by invoking this function repeatedly.
+Parsing continues until the function returns an empty (or undefined)
+result. When this happens $p->eof is automatically signaled.
+
+Parsing will also abort if one of the event handlers calls $p->eof.
+
+The effect of this is the same as:
+
+ while (1) {
+ my $chunk = &$code_ref();
+ if (!defined($chunk) || !length($chunk)) {
+ $p->eof;
+ return $p;
+ }
+ $p->parse($chunk) || return undef;
+ }
+
+But it is more efficient as this loop runs internally in XS code.
+
+=item $p->parse_file( $file )
+
+Parse text directly from a file. The $file argument can be a
+filename, an open file handle, or a reference to an open file
+handle.
+
+If $file contains a filename and the file can't be opened, then the
+method returns an undefined value and $! tells why it failed.
+Otherwise the return value is a reference to the parser object.
+
+If a file handle is passed as the $file argument, then the file will
+normally be read until EOF, but not closed.
+
+If an invoked event handler aborts parsing by calling $p->eof,
+then $p->parse_file() may not have read the entire file.
+
+On systems with multi-byte line terminators, the values passed for the
+offset and length argspecs may be too low if parse_file() is called on
+a file handle that is not in binary mode.
+
+If a filename is passed in, then parse_file() will open the file in
+binary mode.
+
+=item $p->eof
+
+Signals the end of the HTML document. Calling the $p->eof method
+outside a handler callback will flush any remaining buffered text
+(which triggers the C<text> event if there is any remaining text).
+
+Calling $p->eof inside a handler will terminate parsing at that point
+and cause $p->parse to return a FALSE value. This also terminates
+parsing by $p->parse_file().
+
+After $p->eof has been called, the parse() and parse_file() methods
+can be invoked to feed new documents with the parser object.
+
+The return value from eof() is a reference to the parser object.
+
+=back
+
+
+Most parser options are controlled by boolean attributes.
+Each boolean attribute is enabled by calling the corresponding method
+with a TRUE argument and disabled with a FALSE argument. The
+attribute value is left unchanged if no argument is given. The return
+value from each method is the old attribute value.
+
+Methods that can be used to get and/or set parser options are:
+
+=over
+
+=item $p->attr_encoded
+
+=item $p->attr_encoded( $bool )
+
+By default, the C<attr> and C<@attr> argspecs will have general
+entities for attribute values decoded. Enabling this attribute leaves
+entities alone.
+
+=item $p->backquote
+
+=item $p->backquote( $bool )
+
+By default, only ' and " are recognized as quote characters around
+attribute values. MSIE also recognizes backquotes for some reason.
+Enabling this attribute provides compatibility with this behaviour.
+
+=item $p->boolean_attribute_value( $val )
+
+This method sets the value reported for boolean attributes inside HTML
+start tags. By default, the name of the attribute is also used as its
+value. This affects the values reported for C<tokens> and C<attr>
+argspecs.
+
+=item $p->case_sensitive
+
+=item $p->case_sensitive( $bool )
+
+By default, tagnames and attribute names are down-cased. Enabling this
+attribute leaves them as found in the HTML source document.
+
+=item $p->closing_plaintext
+
+=item $p->closing_plaintext( $bool )
+
+By default, "plaintext" element can never be closed. Everything up to
+the end of the document is parsed in CDATA mode. This historical
+behaviour is what at least MSIE does. Enabling this attribute makes
+closing "</plaintext>" tag effective and the parsing process will resume
+after seeing this tag. This emulates early gecko-based browsers.
+
+=item $p->empty_element_tags
+
+=item $p->empty_element_tags( $bool )
+
+By default, empty element tags are not recognized as such and the "/"
+before ">" is just treated like a normal name character (unless
+C<strict_names> is enabled). Enabling this attribute make
+C<HTML::Parser> recognize these tags.
+
+Empty element tags look like start tags, but end with the character
+sequence "/>" instead of ">". When recognized by C<HTML::Parser> they
+cause an artificial end event in addition to the start event. The
+C<text> for the artificial end event will be empty and the C<tokenpos>
+array will be undefined even though the the token array will have one
+element containing the tag name.
+
+=item $p->marked_sections
+
+=item $p->marked_sections( $bool )
+
+By default, section markings like <![CDATA[...]]> are treated like
+ordinary text. When this attribute is enabled section markings are
+honoured.
+
+There are currently no events associated with the marked section
+markup, but the text can be returned as C<skipped_text>.
+
+=item $p->strict_comment
+
+=item $p->strict_comment( $bool )
+
+By default, comments are terminated by the first occurrence of "-->".
+This is the behaviour of most popular browsers (like Mozilla, Opera and
+MSIE), but it is not correct according to the official HTML
+standard. Officially, you need an even number of "--" tokens before
+the closing ">" is recognized and there may not be anything but
+whitespace between an even and an odd "--".
+
+The official behaviour is enabled by enabling this attribute.
+
+Enabling of 'strict_comment' also disables recognizing these forms as
+comments:
+
+ </ comment>
+ <! comment>
+
+
+=item $p->strict_end
+
+=item $p->strict_end( $bool )
+
+By default, attributes and other junk are allowed to be present on end tags in a
+manner that emulates MSIE's behaviour.
+
+The official behaviour is enabled with this attribute. If enabled,
+only whitespace is allowed between the tagname and the final ">".
+
+=item $p->strict_names
+
+=item $p->strict_names( $bool )
+
+By default, almost anything is allowed in tag and attribute names.
+This is the behaviour of most popular browsers and allows us to parse
+some broken tags with invalid attribute values like:
+
+ <IMG SRC=newprevlstGr.gif ALT=[PREV LIST] BORDER=0>
+
+By default, "LIST]" is parsed as a boolean attribute, not as
+part of the ALT value as was clearly intended. This is also what
+Mozilla sees.
+
+The official behaviour is enabled by enabling this attribute. If
+enabled, it will cause the tag above to be reported as text
+since "LIST]" is not a legal attribute name.
+
+=item $p->unbroken_text
+
+=item $p->unbroken_text( $bool )
+
+By default, blocks of text are given to the text handler as soon as
+possible (but the parser takes care always to break text at a
+boundary between whitespace and non-whitespace so single words and
+entities can always be decoded safely). This might create breaks that
+make it hard to do transformations on the text. When this attribute is
+enabled, blocks of text are always reported in one piece. This will
+delay the text event until the following (non-text) event has been
+recognized by the parser.
+
+Note that the C<offset> argspec will give you the offset of the first
+segment of text and C<length> is the combined length of the segments.
+Since there might be ignored tags in between, these numbers can't be
+used to directly index in the original document file.
+
+=item $p->utf8_mode
+
+=item $p->utf8_mode( $bool )
+
+Enable this option when parsing raw undecoded UTF-8. This tells the
+parser that the entities expanded for strings reported by C<attr>,
+C<@attr> and C<dtext> should be expanded as decoded UTF-8 so they end
+up compatible with the surrounding text.
+
+If C<utf8_mode> is enabled then it is an error to pass strings
+containing characters with code above 255 to the parse() method, and
+the parse() method will croak if you try.
+
+Example: The Unicode character "\x{2665}" is "\xE2\x99\xA5" when UTF-8
+encoded. The character can also be represented by the entity
+"&hearts;" or "&#x2665". If we feed the parser:
+
+ $p->parse("\xE2\x99\xA5&hearts;");
+
+then C<dtext> will be reported as "\xE2\x99\xA5\x{2665}" without
+C<utf8_mode> enabled, but as "\xE2\x99\xA5\xE2\x99\xA5" when enabled.
+The later string is what you want.
+
+This option is only available with perl-5.8 or better.
+
+=item $p->xml_mode
+
+=item $p->xml_mode( $bool )
+
+Enabling this attribute changes the parser to allow some XML
+constructs. This enables the behaviour controlled by individually by
+the C<case_sensitive>, C<empty_element_tags>, C<strict_names> and
+C<xml_pic> attributes and also suppresses special treatment of
+elements that are parsed as CDATA for HTML.
+
+=item $p->xml_pic
+
+=item $p->xml_pic( $bool )
+
+By default, I<processing instructions> are terminated by ">". When
+this attribute is enabled, processing instructions are terminated by
+"?>" instead.
+
+=back
+
+As markup and text is recognized, handlers are invoked. The following
+method is used to set up handlers for different events:
+
+=over
+
+=item $p->handler( event => \&subroutine, $argspec )
+
+=item $p->handler( event => $method_name, $argspec )
+
+=item $p->handler( event => \@accum, $argspec )
+
+=item $p->handler( event => "" );
+
+=item $p->handler( event => undef );
+
+=item $p->handler( event );
+
+This method assigns a subroutine, method, or array to handle an event.
+
+Event is one of C<text>, C<start>, C<end>, C<declaration>, C<comment>,
+C<process>, C<start_document>, C<end_document> or C<default>.
+
+The C<\&subroutine> is a reference to a subroutine which is called to handle
+the event.
+
+The C<$method_name> is the name of a method of $p which is called to handle
+the event.
+
+The C<@accum> is an array that will hold the event information as
+sub-arrays.
+
+If the second argument is "", the event is ignored.
+If it is undef, the default handler is invoked for the event.
+
+The C<$argspec> is a string that describes the information to be reported
+for the event. Any requested information that does not apply to a
+specific event is passed as C<undef>. If argspec is omitted, then it
+is left unchanged.
+
+The return value from $p->handler is the old callback routine or a
+reference to the accumulator array.
+
+Any return values from handler callback routines/methods are always
+ignored. A handler callback can request parsing to be aborted by
+invoking the $p->eof method. A handler callback is not allowed to
+invoke the $p->parse() or $p->parse_file() method. An exception will
+be raised if it tries.
+
+Examples:
+
+ $p->handler(start => "start", 'self, attr, attrseq, text' );
+
+This causes the "start" method of object $p to be called for 'start' events.
+The callback signature is $p->start(\%attr, \@attr_seq, $text).
+
+ $p->handler(start => \&start, 'attr, attrseq, text' );
+
+This causes subroutine start() to be called for 'start' events.
+The callback signature is start(\%attr, \@attr_seq, $text).
+
+ $p->handler(start => \@accum, '"S", attr, attrseq, text' );
+
+This causes 'start' event information to be saved in @accum.
+The array elements will be ['S', \%attr, \@attr_seq, $text].
+
+ $p->handler(start => "");
+
+This causes 'start' events to be ignored. It also suppresses
+invocations of any default handler for start events. It is in most
+cases equivalent to $p->handler(start => sub {}), but is more
+efficient. It is different from the empty-sub-handler in that
+C<skipped_text> is not reset by it.
+
+ $p->handler(start => undef);
+
+This causes no handler to be associated with start events.
+If there is a default handler it will be invoked.
+
+=back
+
+Filters based on tags can be set up to limit the number of events
+reported. The main bottleneck during parsing is often the huge number
+of callbacks made from the parser. Applying filters can improve
+performance significantly.
+
+The following methods control filters:
+
+=over
+
+=item $p->ignore_elements( @tags )
+
+Both the C<start> event and the C<end> event as well as any events that
+would be reported in between are suppressed. The ignored elements can
+contain nested occurrences of itself. Example:
+
+ $p->ignore_elements(qw(script style));
+
+The C<script> and C<style> tags will always nest properly since their
+content is parsed in CDATA mode. For most other tags
+C<ignore_elements> must be used with caution since HTML is often not
+I<well formed>.
+
+=item $p->ignore_tags( @tags )
+
+Any C<start> and C<end> events involving any of the tags given are
+suppressed. To reset the filter (i.e. don't suppress any C<start> and
+C<end> events), call C<ignore_tags> without an argument.
+
+=item $p->report_tags( @tags )
+
+Any C<start> and C<end> events involving any of the tags I<not> given
+are suppressed. To reset the filter (i.e. report all C<start> and
+C<end> events), call C<report_tags> without an argument.
+
+=back
+
+Internally, the system has two filter lists, one for C<report_tags>
+and one for C<ignore_tags>, and both filters are applied. This
+effectively gives C<ignore_tags> precedence over C<report_tags>.
+
+Examples:
+
+ $p->ignore_tags(qw(style));
+ $p->report_tags(qw(script style));
+
+results in only C<script> events being reported.
+
+=head2 Argspec
+
+Argspec is a string containing a comma-separated list that describes
+the information reported by the event. The following argspec
+identifier names can be used:
+
+=over
+
+=item C<attr>
+
+Attr causes a reference to a hash of attribute name/value pairs to be
+passed.
+
+Boolean attributes' values are either the value set by
+$p->boolean_attribute_value, or the attribute name if no value has been
+set by $p->boolean_attribute_value.
+
+This passes undef except for C<start> events.
+
+Unless C<xml_mode> or C<case_sensitive> is enabled, the attribute
+names are forced to lower case.
+
+General entities are decoded in the attribute values and
+one layer of matching quotes enclosing the attribute values is removed.
+
+The Unicode character set is assumed for entity decoding. With Perl
+version 5.6 or earlier only the Latin-1 range is supported, and
+entities for characters outside the range 0..255 are left unchanged.
+
+=item C<@attr>
+
+Basically the same as C<attr>, but keys and values are passed as
+individual arguments and the original sequence of the attributes is
+kept. The parameters passed will be the same as the @attr calculated
+here:
+
+ @attr = map { $_ => $attr->{$_} } @$attrseq;
+
+assuming $attr and $attrseq here are the hash and array passed as the
+result of C<attr> and C<attrseq> argspecs.
+
+This passes no values for events besides C<start>.
+
+=item C<attrseq>
+
+Attrseq causes a reference to an array of attribute names to be
+passed. This can be useful if you want to walk the C<attr> hash in
+the original sequence.
+
+This passes undef except for C<start> events.
+
+Unless C<xml_mode> or C<case_sensitive> is enabled, the attribute
+names are forced to lower case.
+
+=item C<column>
+
+Column causes the column number of the start of the event to be passed.
+The first column on a line is 0.
+
+=item C<dtext>
+
+Dtext causes the decoded text to be passed. General entities are
+automatically decoded unless the event was inside a CDATA section or
+was between literal start and end tags (C<script>, C<style>,
+C<xmp>, C<iframe>, C<title>, C<textarea> and C<plaintext>).
+
+The Unicode character set is assumed for entity decoding. With Perl
+version 5.6 or earlier only the Latin-1 range is supported, and
+entities for characters outside the range 0..255 are left unchanged.
+
+This passes undef except for C<text> events.
+
+=item C<event>
+
+Event causes the event name to be passed.
+
+The event name is one of C<text>, C<start>, C<end>, C<declaration>,
+C<comment>, C<process>, C<start_document> or C<end_document>.
+
+=item C<is_cdata>
+
+Is_cdata causes a TRUE value to be passed if the event is inside a CDATA
+section or between literal start and end tags (C<script>,
+C<style>, C<xmp>, C<iframe>, C<title>, C<textarea> and C<plaintext>).
+
+if the flag is FALSE for a text event, then you should normally
+either use C<dtext> or decode the entities yourself before the text is
+processed further.
+
+=item C<length>
+
+Length causes the number of bytes of the source text of the event to
+be passed.
+
+=item C<line>
+
+Line causes the line number of the start of the event to be passed.
+The first line in the document is 1. Line counting doesn't start
+until at least one handler requests this value to be reported.
+
+=item C<offset>
+
+Offset causes the byte position in the HTML document of the start of
+the event to be passed. The first byte in the document has offset 0.
+
+=item C<offset_end>
+
+Offset_end causes the byte position in the HTML document of the end of
+the event to be passed. This is the same as C<offset> + C<length>.
+
+=item C<self>
+
+Self causes the current object to be passed to the handler. If the
+handler is a method, this must be the first element in the argspec.
+
+An alternative to passing self as an argspec is to register closures
+that capture $self by themselves as handlers. Unfortunately this
+creates circular references which prevent the HTML::Parser object
+from being garbage collected. Using the C<self> argspec avoids this
+problem.
+
+=item C<skipped_text>
+
+Skipped_text returns the concatenated text of all the events that have
+been skipped since the last time an event was reported. Events might
+be skipped because no handler is registered for them or because some
+filter applies. Skipped text also includes marked section markup,
+since there are no events that can catch it.
+
+If an C<"">-handler is registered for an event, then the text for this
+event is not included in C<skipped_text>. Skipped text both before
+and after the C<"">-event is included in the next reported
+C<skipped_text>.
+
+=item C<tag>
+
+Same as C<tagname>, but prefixed with "/" if it belongs to an C<end>
+event and "!" for a declaration. The C<tag> does not have any prefix
+for C<start> events, and is in this case identical to C<tagname>.
+
+=item C<tagname>
+
+This is the element name (or I<generic identifier> in SGML jargon) for
+start and end tags. Since HTML is case insensitive, this name is
+forced to lower case to ease string matching.
+
+Since XML is case sensitive, the tagname case is not changed when
+C<xml_mode> is enabled. The same happens if the C<case_sensitive> attribute
+is set.
+
+The declaration type of declaration elements is also passed as a tagname,
+even if that is a bit strange.
+In fact, in the current implementation tagname is
+identical to C<token0> except that the name may be forced to lower case.
+
+=item C<token0>
+
+Token0 causes the original text of the first token string to be
+passed. This should always be the same as $tokens->[0].
+
+For C<declaration> events, this is the declaration type.
+
+For C<start> and C<end> events, this is the tag name.
+
+For C<process> and non-strict C<comment> events, this is everything
+inside the tag.
+
+This passes undef if there are no tokens in the event.
+
+=item C<tokenpos>
+
+Tokenpos causes a reference to an array of token positions to be
+passed. For each string that appears in C<tokens>, this array
+contains two numbers. The first number is the offset of the start of
+the token in the original C<text> and the second number is the length
+of the token.
+
+Boolean attributes in a C<start> event will have (0,0) for the
+attribute value offset and length.
+
+This passes undef if there are no tokens in the event (e.g., C<text>)
+and for artificial C<end> events triggered by empty element tags.
+
+If you are using these offsets and lengths to modify C<text>, you
+should either work from right to left, or be very careful to calculate
+the changes to the offsets.
+
+=item C<tokens>
+
+Tokens causes a reference to an array of token strings to be passed.
+The strings are exactly as they were found in the original text,
+no decoding or case changes are applied.
+
+For C<declaration> events, the array contains each word, comment, and
+delimited string starting with the declaration type.
+
+For C<comment> events, this contains each sub-comment. If
+$p->strict_comments is disabled, there will be only one sub-comment.
+
+For C<start> events, this contains the original tag name followed by
+the attribute name/value pairs. The values of boolean attributes will
+be either the value set by $p->boolean_attribute_value, or the
+attribute name if no value has been set by
+$p->boolean_attribute_value.
+
+For C<end> events, this contains the original tag name (always one token).
+
+For C<process> events, this contains the process instructions (always one
+token).
+
+This passes C<undef> for C<text> events.
+
+=item C<text>
+
+Text causes the source text (including markup element delimiters) to be
+passed.
+
+=item C<undef>
+
+Pass an undefined value. Useful as padding where the same handler
+routine is registered for multiple events.
+
+=item C<'...'>
+
+A literal string of 0 to 255 characters enclosed
+in single (') or double (") quotes is passed as entered.
+
+=back
+
+The whole argspec string can be wrapped up in C<'@{...}'> to signal
+that the resulting event array should be flattened. This only makes a
+difference if an array reference is used as the handler target.
+Consider this example:
+
+ $p->handler(text => [], 'text');
+ $p->handler(text => [], '@{text}']);
+
+With two text events; C<"foo">, C<"bar">; then the first example will end
+up with [["foo"], ["bar"]] and the second with ["foo", "bar"] in
+the handler target array.
+
+
+=head2 Events
+
+Handlers for the following events can be registered:
+
+=over
+
+=item C<comment>
+
+This event is triggered when a markup comment is recognized.
+
+Example:
+
+ <!-- This is a comment -- -- So is this -->
+
+=item C<declaration>
+
+This event is triggered when a I<markup declaration> is recognized.
+
+For typical HTML documents, the only declaration you are
+likely to find is <!DOCTYPE ...>.
+
+Example:
+
+ <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html40/strict.dtd">
+
+DTDs inside <!DOCTYPE ...> will confuse HTML::Parser.
+
+=item C<default>
+
+This event is triggered for events that do not have a specific
+handler. You can set up a handler for this event to catch stuff you
+did not want to catch explicitly.
+
+=item C<end>
+
+This event is triggered when an end tag is recognized.
+
+Example:
+
+ </A>
+
+=item C<end_document>
+
+This event is triggered when $p->eof is called and after any remaining
+text is flushed. There is no document text associated with this event.
+
+=item C<process>
+
+This event is triggered when a processing instructions markup is
+recognized.
+
+The format and content of processing instructions are system and
+application dependent.
+
+Examples:
+
+ <? HTML processing instructions >
+ <? XML processing instructions ?>
+
+=item C<start>
+
+This event is triggered when a start tag is recognized.
+
+Example:
+
+ <A HREF="http://www.perl.com/">
+
+=item C<start_document>
+
+This event is triggered before any other events for a new document. A
+handler for it can be used to initialize stuff. There is no document
+text associated with this event.
+
+=item C<text>
+
+This event is triggered when plain text (characters) is recognized.
+The text may contain multiple lines. A sequence of text may be broken
+between several text events unless $p->unbroken_text is enabled.
+
+The parser will make sure that it does not break a word or a sequence
+of whitespace between two text events.
+
+=back
+
+=head2 Unicode
+
+The C<HTML::Parser> can parse Unicode strings when running under
+perl-5.8 or better. If Unicode is passed to $p->parse() then chunks
+of Unicode will be reported to the handlers. The offset and length
+argspecs will also report their position in terms of characters.
+
+It is safe to parse raw undecoded UTF-8 if you either avoid decoding
+entities and make sure to not use I<argspecs> that do, or enable the
+C<utf8_mode> for the parser. Parsing of undecoded UTF-8 might be
+useful when parsing from a file where you need the reported offsets
+and lengths to match the byte offsets in the file.
+
+If a filename is passed to $p->parse_file() then the file will be read
+in binary mode. This will be fine if the file contains only ASCII or
+Latin-1 characters. If the file contains UTF-8 encoded text then care
+must be taken when decoding entities as described in the previous
+paragraph, but better is to open the file with the UTF-8 layer so that
+it is decoded properly:
+
+ open(my $fh, "<:utf8", "index.html") || die "...: $!";
+ $p->parse_file($fh);
+
+If the file contains text encoded in a charset besides ASCII, Latin-1
+or UTF-8 then decoding will always be needed.
+
+=head1 VERSION 2 COMPATIBILITY
+
+When an C<HTML::Parser> object is constructed with no arguments, a set
+of handlers is automatically provided that is compatible with the old
+HTML::Parser version 2 callback methods.
+
+This is equivalent to the following method calls:
+
+ $p->handler(start => "start", "self, tagname, attr, attrseq, text");
+ $p->handler(end => "end", "self, tagname, text");
+ $p->handler(text => "text", "self, text, is_cdata");
+ $p->handler(process => "process", "self, token0, text");
+ $p->handler(comment =>
+ sub {
+ my($self, $tokens) = @_;
+ for (@$tokens) {$self->comment($_);}},
+ "self, tokens");
+ $p->handler(declaration =>
+ sub {
+ my $self = shift;
+ $self->declaration(substr($_[0], 2, -1));},
+ "self, text");
+
+Setting up these handlers can also be requested with the "api_version =>
+2" constructor option.
+
+=head1 SUBCLASSING
+
+The C<HTML::Parser> class is subclassable. Parser objects are plain
+hashes and C<HTML::Parser> reserves only hash keys that start with
+"_hparser". The parser state can be set up by invoking the init()
+method, which takes the same arguments as new().
+
+=head1 EXAMPLES
+
+The first simple example shows how you might strip out comments from
+an HTML document. We achieve this by setting up a comment handler that
+does nothing and a default handler that will print out anything else:
+
+ use HTML::Parser;
+ HTML::Parser->new(default_h => [sub { print shift }, 'text'],
+ comment_h => [""],
+ )->parse_file(shift || die) || die $!;
+
+An alternative implementation is:
+
+ use HTML::Parser;
+ HTML::Parser->new(end_document_h => [sub { print shift },
+ 'skipped_text'],
+ comment_h => [""],
+ )->parse_file(shift || die) || die $!;
+
+This will in most cases be much more efficient since only a single
+callback will be made.
+
+The next example prints out the text that is inside the <title>
+element of an HTML document. Here we start by setting up a start
+handler. When it sees the title start tag it enables a text handler
+that prints any text found and an end handler that will terminate
+parsing as soon as the title end tag is seen:
+
+ use HTML::Parser ();
+
+ sub start_handler
+ {
+ return if shift ne "title";
+ my $self = shift;
+ $self->handler(text => sub { print shift }, "dtext");
+ $self->handler(end => sub { shift->eof if shift eq "title"; },
+ "tagname,self");
+ }
+
+ my $p = HTML::Parser->new(api_version => 3);
+ $p->handler( start => \&start_handler, "tagname,self");
+ $p->parse_file(shift || die) || die $!;
+ print "\n";
+
+More examples are found in the F<eg/> directory of the C<HTML-Parser>
+distribution: the program C<hrefsub> shows how you can edit all links
+found in a document; the program C<htextsub> shows how to edit the text only; the
+program C<hstrip> shows how you can strip out certain tags/elements
+and/or attributes; and the program C<htext> show how to obtain the
+plain text, but not any script/style content.
+
+You can browse the F<eg/> directory online from the I<[Browse]> link on
+the http://search.cpan.org/~gaas/HTML-Parser/ page.
+
+=head1 BUGS
+
+The <style> and <script> sections do not end with the first "</", but
+need the complete corresponding end tag. The standard behaviour is
+not really practical.
+
+When the I<strict_comment> option is enabled, we still recognize
+comments where there is something other than whitespace between even
+and odd "--" markers.
+
+Once $p->boolean_attribute_value has been set, there is no way to
+restore the default behaviour.
+
+There is currently no way to get both quote characters
+into the same literal argspec.
+
+Empty tags, e.g. "<>" and "</>", are not recognized. SGML allows them
+to repeat the previous start tag or close the previous start tag
+respectively.
+
+NET tags, e.g. "code/.../" are not recognized. This is SGML
+shorthand for "<code>...</code>".
+
+Unclosed start or end tags, e.g. "<tt<b>...</b</tt>" are not
+recognized.
+
+=head1 DIAGNOSTICS
+
+The following messages may be produced by HTML::Parser. The notation
+in this listing is the same as used in L<perldiag>:
+
+=over
+
+=item Not a reference to a hash
+
+(F) The object blessed into or subclassed from HTML::Parser is not a
+hash as required by the HTML::Parser methods.
+
+=item Bad signature in parser state object at %p
+
+(F) The _hparser_xs_state element does not refer to a valid state structure.
+Something must have changed the internal value
+stored in this hash element, or the memory has been overwritten.
+
+=item _hparser_xs_state element is not a reference
+
+(F) The _hparser_xs_state element has been destroyed.
+
+=item Can't find '_hparser_xs_state' element in HTML::Parser hash
+
+(F) The _hparser_xs_state element is missing from the parser hash.
+It was either deleted, or not created when the object was created.
+
+=item API version %s not supported by HTML::Parser %s
+
+(F) The constructor option 'api_version' with an argument greater than
+or equal to 4 is reserved for future extensions.
+
+=item Bad constructor option '%s'
+
+(F) An unknown constructor option key was passed to the new() or
+init() methods.
+
+=item Parse loop not allowed
+
+(F) A handler invoked the parse() or parse_file() method.
+This is not permitted.
+
+=item marked sections not supported
+
+(F) The $p->marked_sections() method was invoked in a HTML::Parser
+module that was compiled without support for marked sections.
+
+=item Unknown boolean attribute (%d)
+
+(F) Something is wrong with the internal logic that set up aliases for
+boolean attributes.
+
+=item Only code or array references allowed as handler
+
+(F) The second argument for $p->handler must be either a subroutine
+reference, then name of a subroutine or method, or a reference to an
+array.
+
+=item No handler for %s events
+
+(F) The first argument to $p->handler must be a valid event name; i.e. one
+of "start", "end", "text", "process", "declaration" or "comment".
+
+=item Unrecognized identifier %s in argspec
+
+(F) The identifier is not a known argspec name.
+Use one of the names mentioned in the argspec section above.
+
+=item Literal string is longer than 255 chars in argspec
+
+(F) The current implementation limits the length of literals in
+an argspec to 255 characters. Make the literal shorter.
+
+=item Backslash reserved for literal string in argspec
+
+(F) The backslash character "\" is not allowed in argspec literals.
+It is reserved to permit quoting inside a literal in a later version.
+
+=item Unterminated literal string in argspec
+
+(F) The terminating quote character for a literal was not found.
+
+=item Bad argspec (%s)
+
+(F) Only identifier names, literals, spaces and commas
+are allowed in argspecs.
+
+=item Missing comma separator in argspec
+
+(F) Identifiers in an argspec must be separated with ",".
+
+=item Parsing of undecoded UTF-8 will give garbage when decoding entities
+
+(W) The first chunk parsed appears to contain undecoded UTF-8 and one
+or more argspecs that decode entities are used for the callback
+handlers.
+
+The result of decoding will be a mix of encoded and decoded characters
+for any entities that expand to characters with code above 127. This
+is not a good thing.
+
+The solution is to use the Encode::encode_utf8() on the data before
+feeding it to the $p->parse(). For $p->parse_file() pass a file that
+has been opened in ":utf8" mode.
+
+The parser can process raw undecoded UTF-8 sanely if the C<utf8_mode>
+is enabled or if the "attr", "@attr" or "dtext" argspecs is avoided.
+
+=item Parsing string decoded with wrong endianness
+
+(W) The first character in the document is U+FFFE. This is not a
+legal Unicode character but a byte swapped BOM. The result of parsing
+will likely be garbage.
+
+=item Parsing of undecoded UTF-32
+
+(W) The parser found the Unicode UTF-32 BOM signature at the start
+of the document. The result of parsing will likely be garbage.
+
+=item Parsing of undecoded UTF-16
+
+(W) The parser found the Unicode UTF-16 BOM signature at the start of
+the document. The result of parsing will likely be garbage.
+
+=back
+
+=head1 SEE ALSO
+
+L<HTML::Entities>, L<HTML::PullParser>, L<HTML::TokeParser>, L<HTML::HeadParser>,
+L<HTML::LinkExtor>, L<HTML::Form>
+
+L<HTML::TreeBuilder> (part of the I<HTML-Tree> distribution)
+
+http://www.w3.org/TR/html4
+
+More information about marked sections and processing instructions may
+be found at C<http://www.sgml.u-net.com/book/sgml-8.htm>.
+
+=head1 COPYRIGHT
+
+ Copyright 1996-2008 Gisle Aas. All rights reserved.
+ Copyright 1999-2000 Michael A. Chase. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/HTML/PullParser.pm b/Master/tlpkg/tlperl.straw/lib/HTML/PullParser.pm
new file mode 100755
index 00000000000..30833793251
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/PullParser.pm
@@ -0,0 +1,209 @@
+package HTML::PullParser;
+
+require HTML::Parser;
+@ISA=qw(HTML::Parser);
+$VERSION = "3.57";
+
+use strict;
+use Carp ();
+
+sub new
+{
+ my($class, %cnf) = @_;
+
+ # Construct argspecs for the various events
+ my %argspec;
+ for (qw(start end text declaration comment process default)) {
+ my $tmp = delete $cnf{$_};
+ next unless defined $tmp;
+ $argspec{$_} = $tmp;
+ }
+ Carp::croak("Info not collected for any events")
+ unless %argspec;
+
+ my $file = delete $cnf{file};
+ my $doc = delete $cnf{doc};
+ Carp::croak("Can't parse from both 'doc' and 'file' at the same time")
+ if defined($file) && defined($doc);
+ Carp::croak("No 'doc' or 'file' given to parse from")
+ unless defined($file) || defined($doc);
+
+ # Create object
+ $cnf{api_version} = 3;
+ my $self = $class->SUPER::new(%cnf);
+
+ my $accum = $self->{pullparser_accum} = [];
+ while (my($event, $argspec) = each %argspec) {
+ $self->SUPER::handler($event => $accum, $argspec);
+ }
+
+ if (defined $doc) {
+ $self->{pullparser_str_ref} = ref($doc) ? $doc : \$doc;
+ $self->{pullparser_str_pos} = 0;
+ }
+ else {
+ if (!ref($file) && ref(\$file) ne "GLOB") {
+ require IO::File;
+ $file = IO::File->new($file, "r") || return;
+ }
+
+ $self->{pullparser_file} = $file;
+ }
+ $self;
+}
+
+
+sub handler
+{
+ Carp::croak("Can't set handlers for HTML::PullParser");
+}
+
+
+sub get_token
+{
+ my $self = shift;
+ while (!@{$self->{pullparser_accum}} && !$self->{pullparser_eof}) {
+ if (my $f = $self->{pullparser_file}) {
+ # must try to parse more from the file
+ my $buf;
+ if (read($f, $buf, 512)) {
+ $self->parse($buf);
+ } else {
+ $self->eof;
+ $self->{pullparser_eof}++;
+ delete $self->{pullparser_file};
+ }
+ }
+ elsif (my $sref = $self->{pullparser_str_ref}) {
+ # must try to parse more from the scalar
+ my $pos = $self->{pullparser_str_pos};
+ my $chunk = substr($$sref, $pos, 512);
+ $self->parse($chunk);
+ $pos += length($chunk);
+ if ($pos < length($$sref)) {
+ $self->{pullparser_str_pos} = $pos;
+ }
+ else {
+ $self->eof;
+ $self->{pullparser_eof}++;
+ delete $self->{pullparser_str_ref};
+ delete $self->{pullparser_str_pos};
+ }
+ }
+ else {
+ die;
+ }
+ }
+ shift @{$self->{pullparser_accum}};
+}
+
+
+sub unget_token
+{
+ my $self = shift;
+ unshift @{$self->{pullparser_accum}}, @_;
+ $self;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTML::PullParser - Alternative HTML::Parser interface
+
+=head1 SYNOPSIS
+
+ use HTML::PullParser;
+
+ $p = HTML::PullParser->new(file => "index.html",
+ start => 'event, tagname, @attr',
+ end => 'event, tagname',
+ ignore_elements => [qw(script style)],
+ ) || die "Can't open: $!";
+ while (my $token = $p->get_token) {
+ #...do something with $token
+ }
+
+=head1 DESCRIPTION
+
+The HTML::PullParser is an alternative interface to the HTML::Parser class.
+It basically turns the HTML::Parser inside out. You associate a file
+(or any IO::Handle object or string) with the parser at construction time and
+then repeatedly call $parser->get_token to obtain the tags and text
+found in the parsed document.
+
+The following methods are provided:
+
+=over 4
+
+=item $p = HTML::PullParser->new( file => $file, %options )
+
+=item $p = HTML::PullParser->new( doc => \$doc, %options )
+
+A C<HTML::PullParser> can be made to parse from either a file or a
+literal document based on whether the C<file> or C<doc> option is
+passed to the parser's constructor.
+
+The C<file> passed in can either be a file name or a file handle
+object. If a file name is passed, and it can't be opened for reading,
+then the constructor will return an undefined value and $! will tell
+you why it failed. Otherwise the argument is taken to be some object
+that the C<HTML::PullParser> can read() from when it needs more data.
+The stream will be read() until EOF, but not closed.
+
+A C<doc> can be passed plain or as a reference
+to a scalar. If a reference is passed then the value of this scalar
+should not be changed before all tokens have been extracted.
+
+Next the information to be returned for the different token types must
+be set up. This is done by simply associating an argspec (as defined
+in L<HTML::Parser>) with the events you have an interest in. For
+instance, if you want C<start> tokens to be reported as the string
+C<'S'> followed by the tagname and the attributes you might pass an
+C<start>-option like this:
+
+ $p = HTML::PullParser->new(
+ doc => $document_to_parse,
+ start => '"S", tagname, @attr',
+ end => '"E", tagname',
+ );
+
+At last other C<HTML::Parser> options, like C<ignore_tags>, and
+C<unbroken_text>, can be passed in. Note that you should not use the
+I<event>_h options to set up parser handlers. That would confuse the
+inner logic of C<HTML::PullParser>.
+
+=item $token = $p->get_token
+
+This method will return the next I<token> found in the HTML document,
+or C<undef> at the end of the document. The token is returned as an
+array reference. The content of this array match the argspec set up
+during C<HTML::PullParser> construction.
+
+=item $p->unget_token( @tokens )
+
+If you find out you have read too many tokens you can push them back,
+so that they are returned again the next time $p->get_token is called.
+
+=back
+
+=head1 EXAMPLES
+
+The 'eg/hform' script shows how we might parse the form section of
+HTML::Documents using HTML::PullParser.
+
+=head1 SEE ALSO
+
+L<HTML::Parser>, L<HTML::TokeParser>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2001 Gisle Aas.
+
+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.straw/lib/HTML/Tagset.pm b/Master/tlpkg/tlperl.straw/lib/HTML/Tagset.pm
new file mode 100755
index 00000000000..754137fd6fe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/Tagset.pm
@@ -0,0 +1,471 @@
+package HTML::Tagset;
+
+use strict;
+
+=head1 NAME
+
+HTML::Tagset - data tables useful in parsing HTML
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+use vars qw( $VERSION );
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use HTML::Tagset;
+ # Then use any of the items in the HTML::Tagset package
+ # as need arises
+
+=head1 DESCRIPTION
+
+This module contains several data tables useful in various kinds of
+HTML parsing operations.
+
+Note that all tag names used are lowercase.
+
+In the following documentation, a "hashset" is a hash being used as a
+set -- the hash conveys that its keys are there, and the actual values
+associated with the keys are not significant. (But what values are
+there, are always true.)
+
+=cut
+
+use vars qw(
+ $VERSION
+ %emptyElement %optionalEndTag %linkElements %boolean_attr
+ %isHeadElement %isBodyElement %isPhraseMarkup
+ %is_Possible_Strict_P_Content
+ %isHeadOrBodyElement
+ %isList %isTableElement %isFormElement
+ %isKnown %canTighten
+ @p_closure_barriers
+ %isCDATA_Parent
+);
+
+=head1 VARIABLES
+
+Note that none of these variables are exported.
+
+=head2 hashset %HTML::Tagset::emptyElement
+
+This hashset has as values the tag-names (GIs) of elements that cannot
+have content. (For example, "base", "br", "hr".) So
+C<$HTML::Tagset::emptyElement{'hr'}> exists and is true.
+C<$HTML::Tagset::emptyElement{'dl'}> does not exist, and so is not true.
+
+=cut
+
+%emptyElement = map {; $_ => 1 } qw(base link meta isindex
+ img br hr wbr
+ input area param
+ embed bgsound spacer
+ basefont col frame
+ ~comment ~literal
+ ~declaration ~pi
+ );
+# The "~"-initial names are for pseudo-elements used by HTML::Entities
+# and TreeBuilder
+
+=head2 hashset %HTML::Tagset::optionalEndTag
+
+This hashset lists tag-names for elements that can have content, but whose
+end-tags are generally, "safely", omissible. Example:
+C<$HTML::Tagset::emptyElement{'li'}> exists and is true.
+
+=cut
+
+%optionalEndTag = map {; $_ => 1 } qw(p li dt dd); # option th tr td);
+
+=head2 hash %HTML::Tagset::linkElements
+
+Values in this hash are tagnames for elements that might contain
+links, and the value for each is a reference to an array of the names
+of attributes whose values can be links.
+
+=cut
+
+%linkElements =
+(
+ 'a' => ['href'],
+ 'applet' => ['archive', 'codebase', 'code'],
+ 'area' => ['href'],
+ 'base' => ['href'],
+ 'bgsound' => ['src'],
+ 'blockquote' => ['cite'],
+ 'body' => ['background'],
+ 'del' => ['cite'],
+ 'embed' => ['pluginspage', 'src'],
+ 'form' => ['action'],
+ 'frame' => ['src', 'longdesc'],
+ 'iframe' => ['src', 'longdesc'],
+ 'ilayer' => ['background'],
+ 'img' => ['src', 'lowsrc', 'longdesc', 'usemap'],
+ 'input' => ['src', 'usemap'],
+ 'ins' => ['cite'],
+ 'isindex' => ['action'],
+ 'head' => ['profile'],
+ 'layer' => ['background', 'src'],
+ 'link' => ['href'],
+ 'object' => ['classid', 'codebase', 'data', 'archive', 'usemap'],
+ 'q' => ['cite'],
+ 'script' => ['src', 'for'],
+ 'table' => ['background'],
+ 'td' => ['background'],
+ 'th' => ['background'],
+ 'tr' => ['background'],
+ 'xmp' => ['href'],
+);
+
+=head2 hash %HTML::Tagset::boolean_attr
+
+This hash (not hashset) lists what attributes of what elements can be
+printed without showing the value (for example, the "noshade" attribute
+of "hr" elements). For elements with only one such attribute, its value
+is simply that attribute name. For elements with many such attributes,
+the value is a reference to a hashset containing all such attributes.
+
+=cut
+
+%boolean_attr = (
+# TODO: make these all hashes
+ 'area' => 'nohref',
+ 'dir' => 'compact',
+ 'dl' => 'compact',
+ 'hr' => 'noshade',
+ 'img' => 'ismap',
+ 'input' => { 'checked' => 1, 'readonly' => 1, 'disabled' => 1 },
+ 'menu' => 'compact',
+ 'ol' => 'compact',
+ 'option' => 'selected',
+ 'select' => 'multiple',
+ 'td' => 'nowrap',
+ 'th' => 'nowrap',
+ 'ul' => 'compact',
+);
+
+#==========================================================================
+# List of all elements from Extensible HTML version 1.0 Transitional DTD:
+#
+# a abbr acronym address applet area b base basefont bdo big
+# blockquote body br button caption center cite code col colgroup
+# dd del dfn dir div dl dt em fieldset font form h1 h2 h3 h4 h5 h6
+# head hr html i iframe img input ins isindex kbd label legend li
+# link map menu meta noframes noscript object ol optgroup option p
+# param pre q s samp script select small span strike strong style
+# sub sup table tbody td textarea tfoot th thead title tr tt u ul
+# var
+#
+# Varia from Mozilla source internal table of tags:
+# Implemented:
+# xmp listing wbr nobr frame frameset noframes ilayer
+# layer nolayer spacer embed multicol
+# But these are unimplemented:
+# sound?? keygen?? server??
+# Also seen here and there:
+# marquee?? app?? (both unimplemented)
+#==========================================================================
+
+=head2 hashset %HTML::Tagset::isPhraseMarkup
+
+This hashset contains all phrasal-level elements.
+
+=cut
+
+%isPhraseMarkup = map {; $_ => 1 } qw(
+ span abbr acronym q sub sup
+ cite code em kbd samp strong var dfn strike
+ b i u s tt small big
+ a img br
+ wbr nobr blink
+ font basefont bdo
+ spacer embed noembed
+); # had: center, hr, table
+
+
+=head2 hashset %HTML::Tagset::is_Possible_Strict_P_Content
+
+This hashset contains all phrasal-level elements that be content of a
+P element, for a strict model of HTML.
+
+=cut
+
+%is_Possible_Strict_P_Content = (
+ %isPhraseMarkup,
+ %isFormElement,
+ map {; $_ => 1} qw( object script map )
+ # I've no idea why there's these latter exceptions.
+ # I'm just following the HTML4.01 DTD.
+);
+
+#from html4 strict:
+#<!ENTITY % fontstyle "TT | I | B | BIG | SMALL">
+#
+#<!ENTITY % phrase "EM | STRONG | DFN | CODE |
+# SAMP | KBD | VAR | CITE | ABBR | ACRONYM" >
+#
+#<!ENTITY % special
+# "A | IMG | OBJECT | BR | SCRIPT | MAP | Q | SUB | SUP | SPAN | BDO">
+#
+#<!ENTITY % formctrl "INPUT | SELECT | TEXTAREA | LABEL | BUTTON">
+#
+#<!-- %inline; covers inline or "text-level" elements -->
+#<!ENTITY % inline "#PCDATA | %fontstyle; | %phrase; | %special; | %formctrl;">
+
+=head2 hashset %HTML::Tagset::isHeadElement
+
+This hashset contains all elements that elements that should be
+present only in the 'head' element of an HTML document.
+
+=cut
+
+%isHeadElement = map {; $_ => 1 }
+ qw(title base link meta isindex script style object bgsound);
+
+=head2 hashset %HTML::Tagset::isList
+
+This hashset contains all elements that can contain "li" elements.
+
+=cut
+
+%isList = map {; $_ => 1 } qw(ul ol dir menu);
+
+=head2 hashset %HTML::Tagset::isTableElement
+
+This hashset contains all elements that are to be found only in/under
+a "table" element.
+
+=cut
+
+%isTableElement = map {; $_ => 1 }
+ qw(tr td th thead tbody tfoot caption col colgroup);
+
+=head2 hashset %HTML::Tagset::isFormElement
+
+This hashset contains all elements that are to be found only in/under
+a "form" element.
+
+=cut
+
+%isFormElement = map {; $_ => 1 }
+ qw(input select option optgroup textarea button label);
+
+=head2 hashset %HTML::Tagset::isBodyMarkup
+
+This hashset contains all elements that are to be found only in/under
+the "body" element of an HTML document.
+
+=cut
+
+%isBodyElement = map {; $_ => 1 } qw(
+ h1 h2 h3 h4 h5 h6
+ p div pre plaintext address blockquote
+ xmp listing
+ center
+
+ multicol
+ iframe ilayer nolayer
+ bgsound
+
+ hr
+ ol ul dir menu li
+ dl dt dd
+ ins del
+
+ fieldset legend
+
+ map area
+ applet param object
+ isindex script noscript
+ table
+ center
+ form
+ ),
+ keys %isFormElement,
+ keys %isPhraseMarkup, # And everything phrasal
+ keys %isTableElement,
+;
+
+
+=head2 hashset %HTML::Tagset::isHeadOrBodyElement
+
+This hashset includes all elements that I notice can fall either in
+the head or in the body.
+
+=cut
+
+%isHeadOrBodyElement = map {; $_ => 1 }
+ qw(script isindex style object map area param noscript bgsound);
+ # i.e., if we find 'script' in the 'body' or the 'head', don't freak out.
+
+
+=head2 hashset %HTML::Tagset::isKnown
+
+This hashset lists all known HTML elements.
+
+=cut
+
+%isKnown = (%isHeadElement, %isBodyElement,
+ map{; $_=>1 }
+ qw( head body html
+ frame frameset noframes
+ ~comment ~pi ~directive ~literal
+));
+ # that should be all known tags ever ever
+
+
+=head2 hashset %HTML::Tagset::canTighten
+
+This hashset lists elements that might have ignorable whitespace as
+children or siblings.
+
+=cut
+
+%canTighten = %isKnown;
+delete @canTighten{
+ keys(%isPhraseMarkup), 'input', 'select',
+ 'xmp', 'listing', 'plaintext', 'pre',
+};
+ # xmp, listing, plaintext, and pre are untightenable, and
+ # in a really special way.
+@canTighten{'hr','br'} = (1,1);
+ # exceptional 'phrasal' things that ARE subject to tightening.
+
+# The one case where I can think of my tightening rules failing is:
+# <p>foo bar<center> <em>baz quux</em> ...
+# ^-- that would get deleted.
+# But that's pretty gruesome code anyhow. You gets what you pays for.
+
+#==========================================================================
+
+=head2 array @HTML::Tagset::p_closure_barriers
+
+This array has a meaning that I have only seen a need for in
+C<HTML::TreeBuilder>, but I include it here on the off chance that someone
+might find it of use:
+
+When we see a "E<lt>pE<gt>" token, we go lookup up the lineage for a p
+element we might have to minimize. At first sight, we might say that
+if there's a p anywhere in the lineage of this new p, it should be
+closed. But that's wrong. Consider this document:
+
+ <html>
+ <head>
+ <title>foo</title>
+ </head>
+ <body>
+ <p>foo
+ <table>
+ <tr>
+ <td>
+ foo
+ <p>bar
+ </td>
+ </tr>
+ </table>
+ </p>
+ </body>
+ </html>
+
+The second p is quite legally inside a much higher p.
+
+My formalization of the reason why this is legal, but this:
+
+ <p>foo<p>bar</p></p>
+
+isn't, is that something about the table constitutes a "barrier" to
+the application of the rule about what p must minimize.
+
+So C<@HTML::Tagset::p_closure_barriers> is the list of all such
+barrier-tags.
+
+=cut
+
+@p_closure_barriers = qw(
+ li blockquote
+ ul ol menu dir
+ dl dt dd
+ td th tr table caption
+ div
+ );
+
+# In an ideal world (i.e., XHTML) we wouldn't have to bother with any of this
+# monkey business of barriers to minimization!
+
+=head2 hashset %isCDATA_Parent
+
+This hashset includes all elements whose content is CDATA.
+
+=cut
+
+%isCDATA_Parent = map {; $_ => 1 }
+ qw(script style xmp listing plaintext);
+
+# TODO: there's nothing else that takes CDATA children, right?
+
+# As the HTML3 DTD (Raggett 1995-04-24) noted:
+# The XMP, LISTING and PLAINTEXT tags are incompatible with SGML
+# and derive from very early versions of HTML. They require non-
+# standard parsers and will cause problems for processing
+# documents with standard SGML tools.
+
+
+=head1 CAVEATS
+
+You may find it useful to alter the behavior of modules (like
+C<HTML::Element> or C<HTML::TreeBuilder>) that use C<HTML::Tagset>'s
+data tables by altering the data tables themselves. You are welcome
+to try, but be careful; and be aware that different modules may or may
+react differently to the data tables being changed.
+
+Note that it may be inappropriate to use these tables for I<producing>
+HTML -- for example, C<%isHeadOrBodyElement> lists the tagnames
+for all elements that can appear either in the head or in the body,
+such as "script". That doesn't mean that I am saying your code that
+produces HTML should feel free to put script elements in either place!
+If you are producing programs that spit out HTML, you should be
+I<intimately> familiar with the DTDs for HTML or XHTML (available at
+C<http://www.w3.org/>), and you should slavishly obey them, not
+the data tables in this document.
+
+=head1 SEE ALSO
+
+L<HTML::Element>, L<HTML::TreeBuilder>, L<HTML::LinkExtor>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 1995-2000 Gisle Aas.
+
+Copyright 2000-2005 Sean M. Burke.
+
+Copyright 2005-2008 Andy Lester.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 ACKNOWLEDGEMENTS
+
+Most of the code/data in this module was adapted from code written
+by Gisle Aas for C<HTML::Element>, C<HTML::TreeBuilder>, and
+C<HTML::LinkExtor>. Then it was maintained by Sean M. Burke.
+
+=head1 AUTHOR
+
+Current maintainer: Andy Lester, C<< <andy at petdance.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-html-tagset at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=HTML-Tagset>. I will
+be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/HTML/TokeParser.pm b/Master/tlpkg/tlperl.straw/lib/HTML/TokeParser.pm
new file mode 100755
index 00000000000..94128dbef75
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTML/TokeParser.pm
@@ -0,0 +1,369 @@
+package HTML::TokeParser;
+
+require HTML::PullParser;
+@ISA=qw(HTML::PullParser);
+$VERSION = "3.57";
+
+use strict;
+use Carp ();
+use HTML::Entities qw(decode_entities);
+use HTML::Tagset ();
+
+my %ARGS =
+(
+ start => "'S',tagname,attr,attrseq,text",
+ end => "'E',tagname,text",
+ text => "'T',text,is_cdata",
+ process => "'PI',token0,text",
+ comment => "'C',text",
+ declaration => "'D',text",
+
+ # options that default on
+ unbroken_text => 1,
+);
+
+
+sub new
+{
+ my $class = shift;
+ my %cnf;
+ if (@_ == 1) {
+ my $type = (ref($_[0]) eq "SCALAR") ? "doc" : "file";
+ %cnf = ($type => $_[0]);
+ }
+ else {
+ %cnf = @_;
+ }
+
+ my $textify = delete $cnf{textify} || {img => "alt", applet => "alt"};
+
+ my $self = $class->SUPER::new(%cnf, %ARGS) || return undef;
+
+ $self->{textify} = $textify;
+ $self;
+}
+
+
+sub get_tag
+{
+ my $self = shift;
+ my $token;
+ while (1) {
+ $token = $self->get_token || return undef;
+ my $type = shift @$token;
+ next unless $type eq "S" || $type eq "E";
+ substr($token->[0], 0, 0) = "/" if $type eq "E";
+ return $token unless @_;
+ for (@_) {
+ return $token if $token->[0] eq $_;
+ }
+ }
+}
+
+
+sub _textify {
+ my($self, $token) = @_;
+ my $tag = $token->[1];
+ return undef unless exists $self->{textify}{$tag};
+
+ my $alt = $self->{textify}{$tag};
+ my $text;
+ if (ref($alt)) {
+ $text = &$alt(@$token);
+ } else {
+ $text = $token->[2]{$alt || "alt"};
+ $text = "[\U$tag]" unless defined $text;
+ }
+ return $text;
+}
+
+
+sub get_text
+{
+ my $self = shift;
+ my @text;
+ while (my $token = $self->get_token) {
+ my $type = $token->[0];
+ if ($type eq "T") {
+ my $text = $token->[1];
+ decode_entities($text) unless $token->[2];
+ push(@text, $text);
+ } elsif ($type =~ /^[SE]$/) {
+ my $tag = $token->[1];
+ if ($type eq "S") {
+ if (defined(my $text = _textify($self, $token))) {
+ push(@text, $text);
+ next;
+ }
+ } else {
+ $tag = "/$tag";
+ }
+ if (!@_ || grep $_ eq $tag, @_) {
+ $self->unget_token($token);
+ last;
+ }
+ push(@text, " ")
+ if $tag eq "br" || !$HTML::Tagset::isPhraseMarkup{$token->[1]};
+ }
+ }
+ join("", @text);
+}
+
+
+sub get_trimmed_text
+{
+ my $self = shift;
+ my $text = $self->get_text(@_);
+ $text =~ s/^\s+//; $text =~ s/\s+$//; $text =~ s/\s+/ /g;
+ $text;
+}
+
+sub get_phrase {
+ my $self = shift;
+ my @text;
+ while (my $token = $self->get_token) {
+ my $type = $token->[0];
+ if ($type eq "T") {
+ my $text = $token->[1];
+ decode_entities($text) unless $token->[2];
+ push(@text, $text);
+ } elsif ($type =~ /^[SE]$/) {
+ my $tag = $token->[1];
+ if ($type eq "S") {
+ if (defined(my $text = _textify($self, $token))) {
+ push(@text, $text);
+ next;
+ }
+ }
+ if (!$HTML::Tagset::isPhraseMarkup{$tag}) {
+ $self->unget_token($token);
+ last;
+ }
+ push(@text, " ") if $tag eq "br";
+ }
+ }
+ my $text = join("", @text);
+ $text =~ s/^\s+//; $text =~ s/\s+$//; $text =~ s/\s+/ /g;
+ $text;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTML::TokeParser - Alternative HTML::Parser interface
+
+=head1 SYNOPSIS
+
+ require HTML::TokeParser;
+ $p = HTML::TokeParser->new("index.html") ||
+ die "Can't open: $!";
+ $p->empty_element_tags(1); # configure its behaviour
+
+ while (my $token = $p->get_token) {
+ #...
+ }
+
+=head1 DESCRIPTION
+
+The C<HTML::TokeParser> is an alternative interface to the
+C<HTML::Parser> class. It is an C<HTML::PullParser> subclass with a
+predeclared set of token types. If you wish the tokens to be reported
+differently you probably want to use the C<HTML::PullParser> directly.
+
+The following methods are available:
+
+=over 4
+
+=item $p = HTML::TokeParser->new( $filename, %opt );
+
+=item $p = HTML::TokeParser->new( $filehandle, %opt );
+
+=item $p = HTML::TokeParser->new( \$document, %opt );
+
+The object constructor argument is either a file name, a file handle
+object, or the complete document to be parsed. Extra options can be
+provided as key/value pairs and are processed as documented by the base
+classes.
+
+If the argument is a plain scalar, then it is taken as the name of a
+file to be opened and parsed. If the file can't be opened for
+reading, then the constructor will return C<undef> and $! will tell
+you why it failed.
+
+If the argument is a reference to a plain scalar, then this scalar is
+taken to be the literal document to parse. The value of this
+scalar should not be changed before all tokens have been extracted.
+
+Otherwise the argument is taken to be some object that the
+C<HTML::TokeParser> can read() from when it needs more data. Typically
+it will be a filehandle of some kind. The stream will be read() until
+EOF, but not closed.
+
+A newly constructed C<HTML::TokeParser> differ from its base classes
+by having the C<unbroken_text> attribute enabled by default. See
+L<HTML::Parser> for a description of this and other attributes that
+influence how the document is parsed. It is often a good idea to enable
+C<empty_element_tags> behaviour.
+
+Note that the parsing result will likely not be valid if raw undecoded
+UTF-8 is used as a source. When parsing UTF-8 encoded files turn
+on UTF-8 decoding:
+
+ open(my $fh, "<:utf8", "index.html") || die "Can't open 'index.html': $!";
+ my $p = HTML::TokeParser->new( $fh );
+ # ...
+
+If a $filename is passed to the constructor the file will be opened in
+raw mode and the parsing result will only be valid if its content is
+Latin-1 or pure ASCII.
+
+If parsing from an UTF-8 encoded string buffer decode it first:
+
+ utf8::decode($document);
+ my $p = HTML::TokeParser->new( \$document );
+ # ...
+
+=item $p->get_token
+
+This method will return the next I<token> found in the HTML document,
+or C<undef> at the end of the document. The token is returned as an
+array reference. The first element of the array will be a string
+denoting the type of this token: "S" for start tag, "E" for end tag,
+"T" for text, "C" for comment, "D" for declaration, and "PI" for
+process instructions. The rest of the token array depend on the type
+like this:
+
+ ["S", $tag, $attr, $attrseq, $text]
+ ["E", $tag, $text]
+ ["T", $text, $is_data]
+ ["C", $text]
+ ["D", $text]
+ ["PI", $token0, $text]
+
+where $attr is a hash reference, $attrseq is an array reference and
+the rest are plain scalars. The L<HTML::Parser/Argspec> explains the
+details.
+
+=item $p->unget_token( @tokens )
+
+If you find you have read too many tokens you can push them back,
+so that they are returned the next time $p->get_token is called.
+
+=item $p->get_tag
+
+=item $p->get_tag( @tags )
+
+This method returns the next start or end tag (skipping any other
+tokens), or C<undef> if there are no more tags in the document. If
+one or more arguments are given, then we skip tokens until one of the
+specified tag types is found. For example:
+
+ $p->get_tag("font", "/font");
+
+will find the next start or end tag for a font-element.
+
+The tag information is returned as an array reference in the same form
+as for $p->get_token above, but the type code (first element) is
+missing. A start tag will be returned like this:
+
+ [$tag, $attr, $attrseq, $text]
+
+The tagname of end tags are prefixed with "/", i.e. end tag is
+returned like this:
+
+ ["/$tag", $text]
+
+=item $p->get_text
+
+=item $p->get_text( @endtags )
+
+This method returns all text found at the current position. It will
+return a zero length string if the next token is not text. Any
+entities will be converted to their corresponding character.
+
+If one or more arguments are given, then we return all text occurring
+before the first of the specified tags found. For example:
+
+ $p->get_text("p", "br");
+
+will return the text up to either a paragraph of linebreak element.
+
+The text might span tags that should be I<textified>. This is
+controlled by the $p->{textify} attribute, which is a hash that
+defines how certain tags can be treated as text. If the name of a
+start tag matches a key in this hash then this tag is converted to
+text. The hash value is used to specify which tag attribute to obtain
+the text from. If this tag attribute is missing, then the upper case
+name of the tag enclosed in brackets is returned, e.g. "[IMG]". The
+hash value can also be a subroutine reference. In this case the
+routine is called with the start tag token content as its argument and
+the return value is treated as the text.
+
+The default $p->{textify} value is:
+
+ {img => "alt", applet => "alt"}
+
+This means that <IMG> and <APPLET> tags are treated as text, and that
+the text to substitute can be found in the ALT attribute.
+
+=item $p->get_trimmed_text
+
+=item $p->get_trimmed_text( @endtags )
+
+Same as $p->get_text above, but will collapse any sequences of white
+space to a single space character. Leading and trailing white space is
+removed.
+
+=item $p->get_phrase
+
+This will return all text found at the current position ignoring any
+phrasal-level tags. Text is extracted until the first non
+phrasal-level tag. Textification of tags is the same as for
+get_text(). This method will collapse white space in the same way as
+get_trimmed_text() does.
+
+The definition of <i>phrasal-level tags</i> is obtained from the
+HTML::Tagset module.
+
+=back
+
+=head1 EXAMPLES
+
+This example extracts all links from a document. It will print one
+line for each link, containing the URL and the textual description
+between the <A>...</A> tags:
+
+ use HTML::TokeParser;
+ $p = HTML::TokeParser->new(shift||"index.html");
+
+ while (my $token = $p->get_tag("a")) {
+ my $url = $token->[1]{href} || "-";
+ my $text = $p->get_trimmed_text("/a");
+ print "$url\t$text\n";
+ }
+
+This example extract the <TITLE> from the document:
+
+ use HTML::TokeParser;
+ $p = HTML::TokeParser->new(shift||"index.html");
+ if ($p->get_tag("title")) {
+ my $title = $p->get_trimmed_text;
+ print "Title: $title\n";
+ }
+
+=head1 SEE ALSO
+
+L<HTML::PullParser>, L<HTML::Parser>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2005 Gisle Aas.
+
+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.straw/lib/HTTP/Config.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Config.pm
new file mode 100755
index 00000000000..454f5e60952
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Config.pm
@@ -0,0 +1,436 @@
+package HTTP::Config;
+
+use strict;
+use URI;
+use vars qw($VERSION);
+
+$VERSION = "5.815";
+
+sub new {
+ my $class = shift;
+ return bless [], $class;
+}
+
+sub entries {
+ my $self = shift;
+ @$self;
+}
+
+sub empty {
+ my $self = shift;
+ not @$self;
+}
+
+sub add {
+ if (@_ == 2) {
+ my $self = shift;
+ push(@$self, shift);
+ return;
+ }
+ my($self, %spec) = @_;
+ push(@$self, \%spec);
+ return;
+}
+
+sub find2 {
+ my($self, %spec) = @_;
+ my @found;
+ my @rest;
+ ITEM:
+ for my $item (@$self) {
+ for my $k (keys %spec) {
+ if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
+ push(@rest, $item);
+ next ITEM;
+ }
+ }
+ push(@found, $item);
+ }
+ return \@found unless wantarray;
+ return \@found, \@rest;
+}
+
+sub find {
+ my $self = shift;
+ my $f = $self->find2(@_);
+ return @$f if wantarray;
+ return $f->[0];
+}
+
+sub remove {
+ my($self, %spec) = @_;
+ my($removed, $rest) = $self->find2(%spec);
+ @$self = @$rest if @$removed;
+ return @$removed;
+}
+
+my %MATCH = (
+ m_scheme => sub {
+ my($v, $uri) = @_;
+ return $uri->_scheme eq $v; # URI known to be canonical
+ },
+ m_secure => sub {
+ my($v, $uri) = @_;
+ my $secure = $uri->_scheme eq "https";
+ return $secure == !!$v;
+ },
+ m_host_port => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("host_port");
+ return $uri->host_port eq $v, 7;
+ },
+ m_host => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("host");
+ return $uri->host eq $v, 6;
+ },
+ m_port => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("port");
+ return $uri->port eq $v;
+ },
+ m_domain => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("host");
+ my $h = $uri->host;
+ $h = "$h.local" unless $h =~ /\./;
+ $v = ".$v" unless $v =~ /^\./;
+ return length($v), 5 if substr($h, -length($v)) eq $v;
+ return 0;
+ },
+ m_path => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("path");
+ return $uri->path eq $v, 4;
+ },
+ m_path_prefix => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("path");
+ my $path = $uri->path;
+ my $len = length($v);
+ return $len, 3 if $path eq $v;
+ return 0 if length($path) <= $len;
+ $v .= "/" unless $v =~ m,/\z,,;
+ return $len, 3 if substr($path, 0, length($v)) eq $v;
+ return 0;
+ },
+ m_path_match => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("path");
+ return $uri->path =~ $v;
+ },
+ m_uri__ => sub {
+ my($v, $k, $uri) = @_;
+ return unless $uri->can($k);
+ return 1 unless defined $v;
+ return $uri->$k eq $v;
+ },
+ m_method => sub {
+ my($v, $uri, $request) = @_;
+ return $request && $request->method eq $v;
+ },
+ m_proxy => sub {
+ my($v, $uri, $request) = @_;
+ return $request && ($request->{proxy} || "") eq $v;
+ },
+ m_code => sub {
+ my($v, $uri, $request, $response) = @_;
+ $v =~ s/xx\z//;
+ return unless $response;
+ return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
+ },
+ m_media_type => sub { # for request too??
+ my($v, $uri, $request, $response) = @_;
+ return unless $response;
+ return 1, 1 if $v eq "*/*";
+ my $ct = $response->content_type;
+ return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
+ return 3, 1 if $v eq "html" && $response->content_is_html;
+ return 4, 1 if $v eq "html" && $response->content_is_xhtml;
+ return 10, 1 if $v eq $ct;
+ return 0;
+ },
+ m_header__ => sub {
+ my($v, $k, $uri, $request, $response) = @_;
+ return unless $request;
+ return 1 if $request->header($k) eq $v;
+ return 1 if $response && $response->header($k) eq $v;
+ return 0;
+ },
+ m_response_attr__ => sub {
+ my($v, $k, $uri, $request, $response) = @_;
+ return unless $response;
+ return 1 if !defined($v) && exists $response->{$k};
+ return 0 unless exists $response->{$k};
+ return 1 if $response->{$k} eq $v;
+ return 0;
+ },
+);
+
+sub matching {
+ my $self = shift;
+ if (@_ == 1) {
+ if ($_[0]->can("request")) {
+ unshift(@_, $_[0]->request);
+ unshift(@_, undef) unless defined $_[0];
+ }
+ unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
+ }
+ my($uri, $request, $response) = @_;
+ $uri = URI->new($uri) unless ref($uri);
+
+ my @m;
+ ITEM:
+ for my $item (@$self) {
+ my $order;
+ for my $ikey (keys %$item) {
+ my $mkey = $ikey;
+ my $k;
+ $k = $1 if $mkey =~ s/__(.*)/__/;
+ if (my $m = $MATCH{$mkey}) {
+ #print "$ikey $mkey\n";
+ my($c, $o);
+ my @arg = (
+ defined($k) ? $k : (),
+ $uri, $request, $response
+ );
+ my $v = $item->{$ikey};
+ $v = [$v] unless ref($v) eq "ARRAY";
+ for (@$v) {
+ ($c, $o) = $m->($_, @arg);
+ #print " - $_ ==> $c $o\n";
+ last if $c;
+ }
+ next ITEM unless $c;
+ $order->[$o || 0] += $c;
+ }
+ }
+ $order->[7] ||= 0;
+ $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
+ push(@m, $item);
+ }
+ @m = sort { $b->{_order} cmp $a->{_order} } @m;
+ delete $_->{_order} for @m;
+ return @m if wantarray;
+ return $m[0];
+}
+
+sub add_item {
+ my $self = shift;
+ my $item = shift;
+ return $self->add(item => $item, @_);
+}
+
+sub remove_items {
+ my $self = shift;
+ return map $_->{item}, $self->remove(@_);
+}
+
+sub matching_items {
+ my $self = shift;
+ return map $_->{item}, $self->matching(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Config - Configuration for request and response objects
+
+=head1 SYNOPSIS
+
+ use HTTP::Config;
+ my $c = HTTP::Config->new;
+ $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
+
+ use HTTP::Request;
+ my $request = HTTP::Request->new(GET => "http://www.example.com");
+
+ if (my @m = $c->matching($request)) {
+ print "Yadayada\n" if $m[0]->{verbose};
+ }
+
+=head1 DESCRIPTION
+
+An C<HTTP::Config> object is a list of entries that
+can be matched against request or request/response pairs. Its
+purpose is to hold configuration data that can be looked up given a
+request or response object.
+
+Each configuration entry is a hash. Some keys specify matching to
+occur against attributes of request/response objects. Other keys can
+be used to hold user data.
+
+The following methods are provided:
+
+=over 4
+
+=item $conf = HTTP::Config->new
+
+Constructs a new empty C<HTTP::Config> object and returns it.
+
+=item $conf->entries
+
+Returns the list of entries in the configuration object.
+In scalar context returns the number of entries.
+
+=item $conf->empty
+
+Return true if there are no entries in the configuration object.
+This is just a shorthand for C<< not $conf->entries >>.
+
+=item $conf->add( %matchspec, %other )
+
+=item $conf->add( \%entry )
+
+Adds a new entry to the configuration.
+You can either pass separate key/value pairs or a hash reference.
+
+=item $conf->remove( %spec )
+
+Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
+If %spec is empty this will match all entries; so it will empty the configuation object.
+
+=item $conf->matching( $uri, $request, $response )
+
+=item $conf->matching( $uri )
+
+=item $conf->matching( $request )
+
+=item $conf->matching( $response )
+
+Returns the entries that match the given $uri, $request and $response triplet.
+
+If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
+If called with a single $response object, then the request object is obtained by calling its 'request' method;
+and then the $uri is obtained as if a single $request was provided.
+
+The entries are returned with the most specific matches first.
+In scalar context returns the most specific match or C<undef> in none match.
+
+=item $conf->add_item( $item, %matchspec )
+
+=item $conf->remove_items( %spec )
+
+=item $conf->matching_items( $uri, $request, $response )
+
+Wrappers that hides the entries themselves.
+
+=back
+
+=head2 Matching
+
+The following keys on a configuration entry specify matching. For all
+of these you can provide an array of values instead of a single value.
+The entry matches if at least one of the values in the array matches.
+
+Entries that require match against a response object attribute will never match
+unless a response object was provided.
+
+=over
+
+=item m_scheme => $scheme
+
+Matches if the URI uses the specified scheme; e.g. "http".
+
+=item m_secure => $bool
+
+If $bool is TRUE; matches if the URI uses a secure scheme. If $bool
+is FALSE; matches if the URI does not use a secure scheme. An example
+of a secure scheme is "https".
+
+=item m_host_port => "$hostname:$port"
+
+Matches if the URI's host_port method return the specified value.
+
+=item m_host => $hostname
+
+Matches if the URI's host method returns the specified value.
+
+=item m_port => $port
+
+Matches if the URI's port method returns the specified value.
+
+=item m_domain => ".$domain"
+
+Matches if the URI's host method return a value that within the given
+domain. The hostname "www.example.com" will for instance match the
+domain ".com".
+
+=item m_path => $path
+
+Matches if the URI's path method returns the specified value.
+
+=item m_path_prefix => $path
+
+Matches if the URI's path is the specified path or has the specified
+path as prefix.
+
+=item m_path_match => $Regexp
+
+Matches if the regular expression matches the URI's path. Eg. qr/\.html$/.
+
+=item m_method => $method
+
+Matches if the request method matches the specified value. Eg. "GET" or "POST".
+
+=item m_code => $digit
+
+=item m_code => $status_code
+
+Matches if the response status code matches. If a single digit is
+specified; matches for all response status codes beginning with that digit.
+
+=item m_proxy => $url
+
+Matches if the request is to be sent to the given Proxy server.
+
+=item m_media_type => "*/*"
+
+=item m_media_type => "text/*"
+
+=item m_media_type => "html"
+
+=item m_media_type => "xhtml"
+
+=item m_media_type => "text/html"
+
+Matches if the response media type matches.
+
+With a value of "html" matches if $response->content_is_html returns TRUE.
+With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
+
+=item m_uri__I<$method> => undef
+
+Matches if the URI object provide the method
+
+=item m_uri__I<$method> => $string
+
+Matches if the URI's $method method returns the given value.
+
+=item m_header__I<$field> => $string
+
+Matches if either the request or the response have a header $field with the given value.
+
+=item m_response_attr__I<$key> => undef
+
+=item m_response_attr__I<$key> => $string
+
+Matches if the response object has a that key; or the entry has the given value.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<HTTP::Request>, L<HTTP::Response>
+
+=head1 COPYRIGHT
+
+Copyright 2008, Gisle Aas
+
+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.straw/lib/HTTP/Cookies.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Cookies.pm
new file mode 100755
index 00000000000..b37bf9d90e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Cookies.pm
@@ -0,0 +1,781 @@
+package HTTP::Cookies;
+
+use strict;
+use HTTP::Date qw(str2time parse_date time2str);
+use HTTP::Headers::Util qw(_split_header_words join_header_words);
+
+use vars qw($VERSION $EPOCH_OFFSET);
+$VERSION = "5.833";
+
+# Legacy: because "use "HTTP::Cookies" used be the ONLY way
+# to load the class HTTP::Cookies::Netscape.
+require HTTP::Cookies::Netscape;
+
+$EPOCH_OFFSET = 0; # difference from Unix epoch
+if ($^O eq "MacOS") {
+ require Time::Local;
+ $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
+}
+
+# A HTTP::Cookies object is a hash. The main attribute is the
+# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}.
+
+sub new
+{
+ my $class = shift;
+ my $self = bless {
+ COOKIES => {},
+ }, $class;
+ my %cnf = @_;
+ for (keys %cnf) {
+ $self->{lc($_)} = $cnf{$_};
+ }
+ $self->load;
+ $self;
+}
+
+
+sub add_cookie_header
+{
+ my $self = shift;
+ my $request = shift || return;
+ my $url = $request->uri;
+ my $scheme = $url->scheme;
+ unless ($scheme =~ /^https?\z/) {
+ return;
+ }
+
+ my $domain = _host($request, $url);
+ $domain = "$domain.local" unless $domain =~ /\./;
+ my $secure_request = ($scheme eq "https");
+ my $req_path = _url_path($url);
+ my $req_port = $url->port;
+ my $now = time();
+ _normalize_path($req_path) if $req_path =~ /%/;
+
+ my @cval; # cookie values for the "Cookie" header
+ my $set_ver;
+ my $netscape_only = 0; # An exact domain match applies to any cookie
+
+ while ($domain =~ /\./) {
+ # Checking $domain for cookies"
+ my $cookies = $self->{COOKIES}{$domain};
+ next unless $cookies;
+ if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
+ my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
+ delete $self->{COOKIES}{$domain};
+ $self->load_cookie($cookie_data->[1]);
+ $cookies = $self->{COOKIES}{$domain};
+ next unless $cookies; # should not really happen
+ }
+
+ # Want to add cookies corresponding to the most specific paths
+ # first (i.e. longest path first)
+ my $path;
+ for $path (sort {length($b) <=> length($a) } keys %$cookies) {
+ if (index($req_path, $path) != 0) {
+ next;
+ }
+
+ my($key,$array);
+ while (($key,$array) = each %{$cookies->{$path}}) {
+ my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
+ if ($secure && !$secure_request) {
+ next;
+ }
+ if ($expires && $expires < $now) {
+ next;
+ }
+ if ($port) {
+ my $found;
+ if ($port =~ s/^_//) {
+ # The corresponding Set-Cookie attribute was empty
+ $found++ if $port eq $req_port;
+ $port = "";
+ }
+ else {
+ my $p;
+ for $p (split(/,/, $port)) {
+ $found++, last if $p eq $req_port;
+ }
+ }
+ unless ($found) {
+ next;
+ }
+ }
+ if ($version > 0 && $netscape_only) {
+ next;
+ }
+
+ # set version number of cookie header.
+ # XXX: What should it be if multiple matching
+ # Set-Cookie headers have different versions themselves
+ if (!$set_ver++) {
+ if ($version >= 1) {
+ push(@cval, "\$Version=$version");
+ }
+ elsif (!$self->{hide_cookie2}) {
+ $request->header(Cookie2 => '$Version="1"');
+ }
+ }
+
+ # do we need to quote the value
+ if ($val =~ /\W/ && $version) {
+ $val =~ s/([\\\"])/\\$1/g;
+ $val = qq("$val");
+ }
+
+ # and finally remember this cookie
+ push(@cval, "$key=$val");
+ if ($version >= 1) {
+ push(@cval, qq(\$Path="$path")) if $path_spec;
+ push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
+ if (defined $port) {
+ my $p = '$Port';
+ $p .= qq(="$port") if length $port;
+ push(@cval, $p);
+ }
+ }
+
+ }
+ }
+
+ } continue {
+ # Try with a more general domain, alternately stripping
+ # leading name components and leading dots. When this
+ # results in a domain with no leading dot, it is for
+ # Netscape cookie compatibility only:
+ #
+ # a.b.c.net Any cookie
+ # .b.c.net Any cookie
+ # b.c.net Netscape cookie only
+ # .c.net Any cookie
+
+ if ($domain =~ s/^\.+//) {
+ $netscape_only = 1;
+ }
+ else {
+ $domain =~ s/[^.]*//;
+ $netscape_only = 0;
+ }
+ }
+
+ if (@cval) {
+ if (my $old = $request->header("Cookie")) {
+ unshift(@cval, $old);
+ }
+ $request->header(Cookie => join("; ", @cval));
+ }
+
+ $request;
+}
+
+
+sub extract_cookies
+{
+ my $self = shift;
+ my $response = shift || return;
+
+ my @set = _split_header_words($response->_header("Set-Cookie2"));
+ my @ns_set = $response->_header("Set-Cookie");
+
+ return $response unless @set || @ns_set; # quick exit
+
+ my $request = $response->request;
+ my $url = $request->uri;
+ my $req_host = _host($request, $url);
+ $req_host = "$req_host.local" unless $req_host =~ /\./;
+ my $req_port = $url->port;
+ my $req_path = _url_path($url);
+ _normalize_path($req_path) if $req_path =~ /%/;
+
+ if (@ns_set) {
+ # The old Netscape cookie format for Set-Cookie
+ # http://curl.haxx.se/rfc/cookie_spec.html
+ # can for instance contain an unquoted "," in the expires
+ # field, so we have to use this ad-hoc parser.
+ my $now = time();
+
+ # Build a hash of cookies that was present in Set-Cookie2
+ # headers. We need to skip them if we also find them in a
+ # Set-Cookie header.
+ my %in_set2;
+ for (@set) {
+ $in_set2{$_->[0]}++;
+ }
+
+ my $set;
+ for $set (@ns_set) {
+ $set =~ s/^\s+//;
+ my @cur;
+ my $param;
+ my $expires;
+ my $first_param = 1;
+ for $param (split(/;\s*/, $set)) {
+ next unless length($param);
+ my($k,$v) = split(/\s*=\s*/, $param, 2);
+ if (defined $v) {
+ $v =~ s/\s+$//;
+ #print "$k => $v\n";
+ }
+ else {
+ $k =~ s/\s+$//;
+ #print "$k => undef";
+ }
+ if (!$first_param && lc($k) eq "expires") {
+ my $etime = str2time($v);
+ if (defined $etime) {
+ push(@cur, "Max-Age" => $etime - $now);
+ $expires++;
+ }
+ else {
+ # parse_date can deal with years outside the range of time_t,
+ my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v);
+ if ($year) {
+ my $thisyear = (gmtime)[5] + 1900;
+ if ($year < $thisyear) {
+ push(@cur, "Max-Age" => -1); # any negative value will do
+ $expires++;
+ }
+ elsif ($year >= $thisyear + 10) {
+ # the date is at least 10 years into the future, just replace
+ # it with something approximate
+ push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60);
+ $expires++;
+ }
+ }
+ }
+ }
+ elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
+ # ignore
+ }
+ else {
+ push(@cur, $k => $v);
+ }
+ $first_param = 0;
+ }
+ next unless @cur;
+ next if $in_set2{$cur[0]};
+
+# push(@cur, "Port" => $req_port);
+ push(@cur, "Discard" => undef) unless $expires;
+ push(@cur, "Version" => 0);
+ push(@cur, "ns-cookie" => 1);
+ push(@set, \@cur);
+ }
+ }
+
+ SET_COOKIE:
+ for my $set (@set) {
+ next unless @$set >= 2;
+
+ my $key = shift @$set;
+ my $val = shift @$set;
+
+ my %hash;
+ while (@$set) {
+ my $k = shift @$set;
+ my $v = shift @$set;
+ my $lc = lc($k);
+ # don't loose case distinction for unknown fields
+ $k = $lc if $lc =~ /^(?:discard|domain|max-age|
+ path|port|secure|version)$/x;
+ if ($k eq "discard" || $k eq "secure") {
+ $v = 1 unless defined $v;
+ }
+ next if exists $hash{$k}; # only first value is significant
+ $hash{$k} = $v;
+ };
+
+ my %orig_hash = %hash;
+ my $version = delete $hash{version};
+ $version = 1 unless defined($version);
+ my $discard = delete $hash{discard};
+ my $secure = delete $hash{secure};
+ my $maxage = delete $hash{'max-age'};
+ my $ns_cookie = delete $hash{'ns-cookie'};
+
+ # Check domain
+ my $domain = delete $hash{domain};
+ $domain = lc($domain) if defined $domain;
+ if (defined($domain)
+ && $domain ne $req_host && $domain ne ".$req_host") {
+ if ($domain !~ /\./ && $domain ne "local") {
+ next SET_COOKIE;
+ }
+ $domain = ".$domain" unless $domain =~ /^\./;
+ if ($domain =~ /\.\d+$/) {
+ next SET_COOKIE;
+ }
+ my $len = length($domain);
+ unless (substr($req_host, -$len) eq $domain) {
+ next SET_COOKIE;
+ }
+ my $hostpre = substr($req_host, 0, length($req_host) - $len);
+ if ($hostpre =~ /\./ && !$ns_cookie) {
+ next SET_COOKIE;
+ }
+ }
+ else {
+ $domain = $req_host;
+ }
+
+ my $path = delete $hash{path};
+ my $path_spec;
+ if (defined $path && $path ne '') {
+ $path_spec++;
+ _normalize_path($path) if $path =~ /%/;
+ if (!$ns_cookie &&
+ substr($req_path, 0, length($path)) ne $path) {
+ next SET_COOKIE;
+ }
+ }
+ else {
+ $path = $req_path;
+ $path =~ s,/[^/]*$,,;
+ $path = "/" unless length($path);
+ }
+
+ my $port;
+ if (exists $hash{port}) {
+ $port = delete $hash{port};
+ if (defined $port) {
+ $port =~ s/\s+//g;
+ my $found;
+ for my $p (split(/,/, $port)) {
+ unless ($p =~ /^\d+$/) {
+ next SET_COOKIE;
+ }
+ $found++ if $p eq $req_port;
+ }
+ unless ($found) {
+ next SET_COOKIE;
+ }
+ }
+ else {
+ $port = "_$req_port";
+ }
+ }
+ $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
+ if $self->set_cookie_ok(\%orig_hash);
+ }
+
+ $response;
+}
+
+sub set_cookie_ok
+{
+ 1;
+}
+
+
+sub set_cookie
+{
+ my $self = shift;
+ my($version,
+ $key, $val, $path, $domain, $port,
+ $path_spec, $secure, $maxage, $discard, $rest) = @_;
+
+ # path and key can not be empty (key can't start with '$')
+ return $self if !defined($path) || $path !~ m,^/, ||
+ !defined($key) || $key =~ m,^\$,;
+
+ # ensure legal port
+ if (defined $port) {
+ return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
+ }
+
+ my $expires;
+ if (defined $maxage) {
+ if ($maxage <= 0) {
+ delete $self->{COOKIES}{$domain}{$path}{$key};
+ return $self;
+ }
+ $expires = time() + $maxage;
+ }
+ $version = 0 unless defined $version;
+
+ my @array = ($version, $val,$port,
+ $path_spec,
+ $secure, $expires, $discard);
+ push(@array, {%$rest}) if defined($rest) && %$rest;
+ # trim off undefined values at end
+ pop(@array) while !defined $array[-1];
+
+ $self->{COOKIES}{$domain}{$path}{$key} = \@array;
+ $self;
+}
+
+
+sub save
+{
+ my $self = shift;
+ my $file = shift || $self->{'file'} || return;
+ local(*FILE);
+ open(FILE, ">$file") or die "Can't open $file: $!";
+ print FILE "#LWP-Cookies-1.0\n";
+ print FILE $self->as_string(!$self->{ignore_discard});
+ close(FILE);
+ 1;
+}
+
+
+sub load
+{
+ my $self = shift;
+ my $file = shift || $self->{'file'} || return;
+ local(*FILE, $_);
+ local $/ = "\n"; # make sure we got standard record separator
+ open(FILE, $file) or return;
+ my $magic = <FILE>;
+ unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
+ warn "$file does not seem to contain cookies";
+ return;
+ }
+ while (<FILE>) {
+ next unless s/^Set-Cookie3:\s*//;
+ chomp;
+ my $cookie;
+ for $cookie (_split_header_words($_)) {
+ my($key,$val) = splice(@$cookie, 0, 2);
+ my %hash;
+ while (@$cookie) {
+ my $k = shift @$cookie;
+ my $v = shift @$cookie;
+ $hash{$k} = $v;
+ }
+ my $version = delete $hash{version};
+ my $path = delete $hash{path};
+ my $domain = delete $hash{domain};
+ my $port = delete $hash{port};
+ my $expires = str2time(delete $hash{expires});
+
+ my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
+ my $secure = exists $hash{secure}; delete $hash{secure};
+ my $discard = exists $hash{discard}; delete $hash{discard};
+
+ my @array = ($version,$val,$port,
+ $path_spec,$secure,$expires,$discard);
+ push(@array, \%hash) if %hash;
+ $self->{COOKIES}{$domain}{$path}{$key} = \@array;
+ }
+ }
+ close(FILE);
+ 1;
+}
+
+
+sub revert
+{
+ my $self = shift;
+ $self->clear->load;
+ $self;
+}
+
+
+sub clear
+{
+ my $self = shift;
+ if (@_ == 0) {
+ $self->{COOKIES} = {};
+ }
+ elsif (@_ == 1) {
+ delete $self->{COOKIES}{$_[0]};
+ }
+ elsif (@_ == 2) {
+ delete $self->{COOKIES}{$_[0]}{$_[1]};
+ }
+ elsif (@_ == 3) {
+ delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
+ }
+ else {
+ require Carp;
+ Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
+ }
+ $self;
+}
+
+
+sub clear_temporary_cookies
+{
+ my($self) = @_;
+
+ $self->scan(sub {
+ if($_[9] or # "Discard" flag set
+ not $_[8]) { # No expire field?
+ $_[8] = -1; # Set the expire/max_age field
+ $self->set_cookie(@_); # Clear the cookie
+ }
+ });
+}
+
+
+sub DESTROY
+{
+ my $self = shift;
+ local($., $@, $!, $^E, $?);
+ $self->save if $self->{'autosave'};
+}
+
+
+sub scan
+{
+ my($self, $cb) = @_;
+ my($domain,$path,$key);
+ for $domain (sort keys %{$self->{COOKIES}}) {
+ for $path (sort keys %{$self->{COOKIES}{$domain}}) {
+ for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
+ my($version,$val,$port,$path_spec,
+ $secure,$expires,$discard,$rest) =
+ @{$self->{COOKIES}{$domain}{$path}{$key}};
+ $rest = {} unless defined($rest);
+ &$cb($version,$key,$val,$path,$domain,$port,
+ $path_spec,$secure,$expires,$discard,$rest);
+ }
+ }
+ }
+}
+
+
+sub as_string
+{
+ my($self, $skip_discard) = @_;
+ my @res;
+ $self->scan(sub {
+ my($version,$key,$val,$path,$domain,$port,
+ $path_spec,$secure,$expires,$discard,$rest) = @_;
+ return if $discard && $skip_discard;
+ my @h = ($key, $val);
+ push(@h, "path", $path);
+ push(@h, "domain" => $domain);
+ push(@h, "port" => $port) if defined $port;
+ push(@h, "path_spec" => undef) if $path_spec;
+ push(@h, "secure" => undef) if $secure;
+ push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
+ push(@h, "discard" => undef) if $discard;
+ my $k;
+ for $k (sort keys %$rest) {
+ push(@h, $k, $rest->{$k});
+ }
+ push(@h, "version" => $version);
+ push(@res, "Set-Cookie3: " . join_header_words(\@h));
+ });
+ join("\n", @res, "");
+}
+
+sub _host
+{
+ my($request, $url) = @_;
+ if (my $h = $request->header("Host")) {
+ $h =~ s/:\d+$//; # might have a port as well
+ return lc($h);
+ }
+ return lc($url->host);
+}
+
+sub _url_path
+{
+ my $url = shift;
+ my $path;
+ if($url->can('epath')) {
+ $path = $url->epath; # URI::URL method
+ }
+ else {
+ $path = $url->path; # URI::_generic method
+ }
+ $path = "/" unless length $path;
+ $path;
+}
+
+sub _normalize_path # so that plain string compare can be used
+{
+ my $x;
+ $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
+ $x = uc($1);
+ $x eq "2F" || $x eq "25" ? "%$x" :
+ pack("C", hex($x));
+ /eg;
+ $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Cookies - HTTP cookie jars
+
+=head1 SYNOPSIS
+
+ use HTTP::Cookies;
+ $cookie_jar = HTTP::Cookies->new(
+ file => "$ENV{'HOME'}/lwp_cookies.dat',
+ autosave => 1,
+ );
+
+ use LWP;
+ my $browser = LWP::UserAgent->new;
+ $browser->cookie_jar($cookie_jar);
+
+Or for an empty and temporary cookie jar:
+
+ use LWP;
+ my $browser = LWP::UserAgent->new;
+ $browser->cookie_jar( {} );
+
+=head1 DESCRIPTION
+
+This class is for objects that represent a "cookie jar" -- that is, a
+database of all the HTTP cookies that a given LWP::UserAgent object
+knows about.
+
+Cookies are a general mechanism which server side connections can use
+to both store and retrieve information on the client side of the
+connection. For more information about cookies refer to
+<URL:http://curl.haxx.se/rfc/cookie_spec.html> and
+<URL:http://www.cookiecentral.com/>. This module also implements the
+new style cookies described in I<RFC 2965>.
+The two variants of cookies are supposed to be able to coexist happily.
+
+Instances of the class I<HTTP::Cookies> are able to store a collection
+of Set-Cookie2: and Set-Cookie: headers and are able to use this
+information to initialize Cookie-headers in I<HTTP::Request> objects.
+The state of a I<HTTP::Cookies> object can be saved in and restored from
+files.
+
+=head1 METHODS
+
+The following methods are provided:
+
+=over 4
+
+=item $cookie_jar = HTTP::Cookies->new
+
+The constructor takes hash style parameters. The following
+parameters are recognized:
+
+ file: name of the file to restore cookies from and save cookies to
+ autosave: save during destruction (bool)
+ ignore_discard: save even cookies that are requested to be discarded (bool)
+ hide_cookie2: do not add Cookie2 header to requests
+
+Future parameters might include (not yet implemented):
+
+ max_cookies 300
+ max_cookies_per_domain 20
+ max_cookie_size 4096
+
+ no_cookies list of domain names that we never return cookies to
+
+=item $cookie_jar->add_cookie_header( $request )
+
+The add_cookie_header() method will set the appropriate Cookie:-header
+for the I<HTTP::Request> object given as argument. The $request must
+have a valid url attribute before this method is called.
+
+=item $cookie_jar->extract_cookies( $response )
+
+The extract_cookies() method will look for Set-Cookie: and
+Set-Cookie2: headers in the I<HTTP::Response> object passed as
+argument. Any of these headers that are found are used to update
+the state of the $cookie_jar.
+
+=item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest )
+
+The set_cookie() method updates the state of the $cookie_jar. The
+$key, $val, $domain, $port and $path arguments are strings. The
+$path_spec, $secure, $discard arguments are boolean values. The $maxage
+value is a number indicating number of seconds that this cookie will
+live. A value <= 0 will delete this cookie. %rest defines
+various other attributes like "Comment" and "CommentURL".
+
+=item $cookie_jar->save
+
+=item $cookie_jar->save( $file )
+
+This method file saves the state of the $cookie_jar to a file.
+The state can then be restored later using the load() method. If a
+filename is not specified we will use the name specified during
+construction. If the attribute I<ignore_discard> is set, then we
+will even save cookies that are marked to be discarded.
+
+The default is to save a sequence of "Set-Cookie3" lines.
+"Set-Cookie3" is a proprietary LWP format, not known to be compatible
+with any browser. The I<HTTP::Cookies::Netscape> sub-class can
+be used to save in a format compatible with Netscape.
+
+=item $cookie_jar->load
+
+=item $cookie_jar->load( $file )
+
+This method reads the cookies from the file and adds them to the
+$cookie_jar. The file must be in the format written by the save()
+method.
+
+=item $cookie_jar->revert
+
+This method empties the $cookie_jar and re-loads the $cookie_jar
+from the last save file.
+
+=item $cookie_jar->clear
+
+=item $cookie_jar->clear( $domain )
+
+=item $cookie_jar->clear( $domain, $path )
+
+=item $cookie_jar->clear( $domain, $path, $key )
+
+Invoking this method without arguments will empty the whole
+$cookie_jar. If given a single argument only cookies belonging to
+that domain will be removed. If given two arguments, cookies
+belonging to the specified path within that domain are removed. If
+given three arguments, then the cookie with the specified key, path
+and domain is removed.
+
+=item $cookie_jar->clear_temporary_cookies
+
+Discard all temporary cookies. Scans for all cookies in the jar
+with either no expire field or a true C<discard> flag. To be
+called when the user agent shuts down according to RFC 2965.
+
+=item $cookie_jar->scan( \&callback )
+
+The argument is a subroutine that will be invoked for each cookie
+stored in the $cookie_jar. The subroutine will be invoked with
+the following arguments:
+
+ 0 version
+ 1 key
+ 2 val
+ 3 path
+ 4 domain
+ 5 port
+ 6 path_spec
+ 7 secure
+ 8 expires
+ 9 discard
+ 10 hash
+
+=item $cookie_jar->as_string
+
+=item $cookie_jar->as_string( $skip_discardables )
+
+The as_string() method will return the state of the $cookie_jar
+represented as a sequence of "Set-Cookie3" header lines separated by
+"\n". If $skip_discardables is TRUE, it will not return lines for
+cookies with the I<Discard> attribute.
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft>
+
+=head1 COPYRIGHT
+
+Copyright 1997-2002 Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Cookies/Microsoft.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Cookies/Microsoft.pm
new file mode 100755
index 00000000000..c5a0bf77087
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Cookies/Microsoft.pm
@@ -0,0 +1,329 @@
+package HTTP::Cookies::Microsoft;
+
+use strict;
+
+use vars qw(@ISA $VERSION);
+
+$VERSION = "5.821";
+
+require HTTP::Cookies;
+@ISA=qw(HTTP::Cookies);
+
+sub load_cookies_from_file
+{
+ my ($file) = @_;
+ my @cookies;
+ my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire);
+ my ($lo_create, $hi_create, $sep);
+
+ open(COOKIES, $file) || return;
+
+ while ($key = <COOKIES>)
+ {
+ chomp($key);
+ chomp($value = <COOKIES>);
+ chomp($domain_path= <COOKIES>);
+ chomp($flags = <COOKIES>); # 0x0001 bit is for secure
+ chomp($lo_expire = <COOKIES>);
+ chomp($hi_expire = <COOKIES>);
+ chomp($lo_create = <COOKIES>);
+ chomp($hi_create = <COOKIES>);
+ chomp($sep = <COOKIES>);
+
+ if (!defined($key) || !defined($value) || !defined($domain_path) ||
+ !defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
+ !defined($hi_create) || !defined($lo_create) || !defined($sep) ||
+ ($sep ne '*'))
+ {
+ last;
+ }
+
+ if ($domain_path =~ /^([^\/]+)(\/.*)$/)
+ {
+ my $domain = $1;
+ my $path = $2;
+
+ push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain,
+ PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
+ LOXP => $lo_expire, HICREATE => $hi_create,
+ LOCREATE => $lo_create});
+ }
+ }
+
+ return \@cookies;
+}
+
+sub get_user_name
+{
+ use Win32;
+ use locale;
+ my $user = lc(Win32::LoginName());
+
+ return $user;
+}
+
+# MSIE stores create and expire times as Win32 FILETIME,
+# which is 64 bits of 100 nanosecond intervals since Jan 01 1601
+#
+# But Cookies code expects time in 32-bit value expressed
+# in seconds since Jan 01 1970
+#
+sub epoch_time_offset_from_win32_filetime
+{
+ my ($high, $low) = @_;
+
+ #--------------------------------------------------------
+ # USEFUL CONSTANT
+ #--------------------------------------------------------
+ # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
+ #
+ # 100 nanosecond intervals == 0.1 microsecond intervals
+
+ my $filetime_low32_1970 = 0xd53e8000;
+ my $filetime_high32_1970 = 0x019db1de;
+
+ #------------------------------------
+ # ALGORITHM
+ #------------------------------------
+ # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970:
+ #
+ # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base
+ # 2. Divide by 10 to get to microseconds (1/millionth second)
+ # 3. Divide by 1000000 (10 ^ 6) to get to seconds
+ #
+ # We can combine Step 2 & 3 into one divide.
+ #
+ # After much trial and error, I came up with the following code which
+ # avoids using Math::BigInt or floating pt, but still gives correct answers
+
+ # If the filetime is before the epoch, return 0
+ if (($high < $filetime_high32_1970) ||
+ (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970)))
+ {
+ return 0;
+ }
+
+ # Can't multiply by 0x100000000, (1 << 32),
+ # without Perl issuing an integer overflow warning
+ #
+ # So use two multiplies by 0x10000 instead of one multiply by 0x100000000
+ #
+ # The result is the same.
+ #
+ my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970;
+ my $time = (($high * 0x10000) * 0x10000) + $low;
+
+ $time -= $date1970;
+ $time /= 10000000;
+
+ return $time;
+}
+
+sub load_cookie
+{
+ my($self, $file) = @_;
+ my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
+ my $cookie_data;
+
+ if (-f $file)
+ {
+ # open the cookie file and get the data
+ $cookie_data = load_cookies_from_file($file);
+
+ foreach my $cookie (@{$cookie_data})
+ {
+ my $secure = ($cookie->{FLAGS} & 1) != 0;
+ my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
+
+ $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE},
+ $cookie->{PATH}, $cookie->{DOMAIN}, undef,
+ 0, $secure, $expires-$now, 0);
+ }
+ }
+}
+
+sub load
+{
+ my($self, $cookie_index) = @_;
+ my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
+ my $cookie_dir = '';
+ my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
+ my $user_name = get_user_name();
+ my $data;
+
+ $cookie_index ||= $self->{'file'} || return;
+ if ($cookie_index =~ /[\\\/][^\\\/]+$/)
+ {
+ $cookie_dir = $` . "\\";
+ }
+
+ local(*INDEX, $_);
+
+ open(INDEX, $cookie_index) || return;
+ binmode(INDEX);
+ if (256 != read(INDEX, $data, 256))
+ {
+ warn "$cookie_index file is not large enough";
+ close(INDEX);
+ return;
+ }
+
+ # Cookies' index.dat file starts with 32 bytes of signature
+ # followed by an offset to the first record, stored as a little-endian DWORD
+ my ($sig, $size) = unpack('a32 V', $data);
+
+ if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0)
+ (0x4000 != $size))
+ {
+ warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
+ close(INDEX);
+ return;
+ }
+
+ if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record
+ {
+ close(INDEX);
+ return;
+ }
+
+ # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
+ # so read in two 0x80 byte sectors and adjust if not a Cookie.
+ while (256 == read(INDEX, $data, 256))
+ {
+ # each record starts with a 4-byte signature
+ # and a count (little-endian DWORD) of 0x80 byte sectors for the record
+ ($sig, $size) = unpack('a4 V', $data);
+
+ # Cookies are found in 'URL ' records
+ if ('URL ' ne $sig)
+ {
+ # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
+ if (($sig eq 'HASH') || ($sig eq 'LEAK'))
+ {
+ # '-2' takes into account the two 0x80 byte sectors we've just read in
+ if (($size > 0) && ($size != 2))
+ {
+ if (0 == seek(INDEX, ($size-2)*0x80, 1))
+ {
+ # Seek failed. Something's wrong. Gonna stop.
+ last;
+ }
+ }
+ }
+ next;
+ }
+
+ #$REMOVE Need to check if URL records in Cookies' index.dat will
+ # ever use more than two 0x80 byte sectors
+ if ($size > 2)
+ {
+ my $more_data = ($size-2)*0x80;
+
+ if ($more_data != read(INDEX, $data, $more_data, 256))
+ {
+ last;
+ }
+ }
+
+ (my $user_name2 = $user_name) =~ s/ /_/g;
+ if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/)
+ {
+ my $cookie_file = $cookie_dir . $2; # form full pathname
+
+ if (!$delay_load)
+ {
+ $self->load_cookie($cookie_file);
+ }
+ else
+ {
+ my $domain = $1;
+
+ # grab only the domain name, drop everything from the first dir sep on
+ if ($domain =~ m{[\\/]})
+ {
+ $domain = $`;
+ }
+
+ # set the delayload cookie for this domain with
+ # the cookie_file as cookie for later-loading info
+ $self->set_cookie(undef, 'cookie', $cookie_file,
+ '//+delayload', $domain, undef,
+ 0, 0, $now+86400, 0);
+ }
+ }
+ }
+
+ close(INDEX);
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Cookies::Microsoft - access to Microsoft cookies files
+
+=head1 SYNOPSIS
+
+ use LWP;
+ use HTTP::Cookies::Microsoft;
+ use Win32::TieRegistry(Delimiter => "/");
+ my $cookies_dir = $Registry->
+ {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
+
+ $cookie_jar = HTTP::Cookies::Microsoft->new(
+ file => "$cookies_dir\\index.dat",
+ 'delayload' => 1,
+ );
+ my $browser = LWP::UserAgent->new;
+ $browser->cookie_jar( $cookie_jar );
+
+=head1 DESCRIPTION
+
+This is a subclass of C<HTTP::Cookies> which
+loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
+cookie files.
+
+See the documentation for L<HTTP::Cookies>.
+
+=head1 METHODS
+
+The following methods are provided:
+
+=over 4
+
+=item $cookie_jar = HTTP::Cookies::Microsoft->new;
+
+The constructor takes hash style parameters. In addition
+to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
+recognizes the following:
+
+ delayload: delay loading of cookie data until a request
+ is actually made. This results in faster
+ runtime unless you use most of the cookies
+ since only the domain's cookie data
+ is loaded on demand.
+
+=back
+
+=head1 CAVEATS
+
+Please note that the code DOESN'T support saving to the MSIE
+cookie file format.
+
+=head1 AUTHOR
+
+Johnny Lee <typo_pl@hotmail.com>
+
+=head1 COPYRIGHT
+
+Copyright 2002 Johnny Lee
+
+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.straw/lib/HTTP/Cookies/Netscape.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Cookies/Netscape.pm
new file mode 100755
index 00000000000..f19c517f946
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Cookies/Netscape.pm
@@ -0,0 +1,114 @@
+package HTTP::Cookies::Netscape;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+$VERSION = "5.832";
+
+require HTTP::Cookies;
+@ISA=qw(HTTP::Cookies);
+
+sub load
+{
+ my($self, $file) = @_;
+ $file ||= $self->{'file'} || return;
+ local(*FILE, $_);
+ local $/ = "\n"; # make sure we got standard record separator
+ my @cookies;
+ open(FILE, $file) || return;
+ my $magic = <FILE>;
+ unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) {
+ warn "$file does not look like a netscape cookies file" if $^W;
+ close(FILE);
+ return;
+ }
+ my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
+ while (<FILE>) {
+ next if /^\s*\#/;
+ next if /^\s*$/;
+ tr/\n\r//d;
+ my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
+ $secure = ($secure eq "TRUE");
+ $self->set_cookie(undef,$key,$val,$path,$domain,undef,
+ 0,$secure,$expires-$now, 0);
+ }
+ close(FILE);
+ 1;
+}
+
+sub save
+{
+ my($self, $file) = @_;
+ $file ||= $self->{'file'} || return;
+ local(*FILE, $_);
+ open(FILE, ">$file") || return;
+
+ # Use old, now broken link to the old cookie spec just in case something
+ # else (not us!) requires the comment block exactly this way.
+ print FILE <<EOT;
+# Netscape HTTP Cookie File
+# http://www.netscape.com/newsref/std/cookie_spec.html
+# This is a generated file! Do not edit.
+
+EOT
+
+ my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
+ $self->scan(sub {
+ my($version,$key,$val,$path,$domain,$port,
+ $path_spec,$secure,$expires,$discard,$rest) = @_;
+ return if $discard && !$self->{ignore_discard};
+ $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
+ return if $now > $expires;
+ $secure = $secure ? "TRUE" : "FALSE";
+ my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
+ print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
+ });
+ close(FILE);
+ 1;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+HTTP::Cookies::Netscape - access to Netscape cookies files
+
+=head1 SYNOPSIS
+
+ use LWP;
+ use HTTP::Cookies::Netscape;
+ $cookie_jar = HTTP::Cookies::Netscape->new(
+ file => "c:/program files/netscape/users/ZombieCharity/cookies.txt",
+ );
+ my $browser = LWP::UserAgent->new;
+ $browser->cookie_jar( $cookie_jar );
+
+=head1 DESCRIPTION
+
+This is a subclass of C<HTTP::Cookies> that reads (and optionally
+writes) Netscape/Mozilla cookie files.
+
+See the documentation for L<HTTP::Cookies>.
+
+=head1 CAVEATS
+
+Please note that the Netscape/Mozilla cookie file format can't store
+all the information available in the Set-Cookie2 headers, so you will
+probably lose some information if you save in this format.
+
+At time of writing, this module seems to work fine with Mozilla
+Phoenix/Firebird.
+
+=head1 SEE ALSO
+
+L<HTTP::Cookies::Microsoft>
+
+=head1 COPYRIGHT
+
+Copyright 2002-2003 Gisle Aas
+
+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.straw/lib/HTTP/Daemon.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Daemon.pm
new file mode 100755
index 00000000000..cf61147d077
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Daemon.pm
@@ -0,0 +1,903 @@
+package HTTP::Daemon;
+
+use strict;
+use vars qw($VERSION @ISA $PROTO $DEBUG);
+
+$VERSION = "5.827";
+
+use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
+@ISA=qw(IO::Socket::INET);
+
+$PROTO = "HTTP/1.1";
+
+
+sub new
+{
+ my($class, %args) = @_;
+ $args{Listen} ||= 5;
+ $args{Proto} ||= 'tcp';
+ return $class->SUPER::new(%args);
+}
+
+
+sub accept
+{
+ my $self = shift;
+ my $pkg = shift || "HTTP::Daemon::ClientConn";
+ my ($sock, $peer) = $self->SUPER::accept($pkg);
+ if ($sock) {
+ ${*$sock}{'httpd_daemon'} = $self;
+ return wantarray ? ($sock, $peer) : $sock;
+ }
+ else {
+ return;
+ }
+}
+
+
+sub url
+{
+ my $self = shift;
+ my $url = $self->_default_scheme . "://";
+ my $addr = $self->sockaddr;
+ if (!$addr || $addr eq INADDR_ANY) {
+ require Sys::Hostname;
+ $url .= lc Sys::Hostname::hostname();
+ }
+ else {
+ $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
+ }
+ my $port = $self->sockport;
+ $url .= ":$port" if $port != $self->_default_port;
+ $url .= "/";
+ $url;
+}
+
+
+sub _default_port {
+ 80;
+}
+
+
+sub _default_scheme {
+ "http";
+}
+
+
+sub product_tokens
+{
+ "libwww-perl-daemon/$HTTP::Daemon::VERSION";
+}
+
+
+
+package HTTP::Daemon::ClientConn;
+
+use vars qw(@ISA $DEBUG);
+use IO::Socket ();
+@ISA=qw(IO::Socket::INET);
+*DEBUG = \$HTTP::Daemon::DEBUG;
+
+use HTTP::Request ();
+use HTTP::Response ();
+use HTTP::Status;
+use HTTP::Date qw(time2str);
+use LWP::MediaTypes qw(guess_media_type);
+use Carp ();
+
+my $CRLF = "\015\012"; # "\r\n" is not portable
+my $HTTP_1_0 = _http_version("HTTP/1.0");
+my $HTTP_1_1 = _http_version("HTTP/1.1");
+
+
+sub get_request
+{
+ my($self, $only_headers) = @_;
+ if (${*$self}{'httpd_nomore'}) {
+ $self->reason("No more requests from this connection");
+ return;
+ }
+
+ $self->reason("");
+ my $buf = ${*$self}{'httpd_rbuf'};
+ $buf = "" unless defined $buf;
+
+ my $timeout = $ {*$self}{'io_socket_timeout'};
+ my $fdset = "";
+ vec($fdset, $self->fileno, 1) = 1;
+ local($_);
+
+ READ_HEADER:
+ while (1) {
+ # loop until we have the whole header in $buf
+ $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
+ if ($buf =~ /\012/) { # potential, has at least one line
+ if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
+ if ($buf =~ /\015?\012\015?\012/) {
+ last READ_HEADER; # we have it
+ }
+ elsif (length($buf) > 16*1024) {
+ $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
+ $self->reason("Very long header");
+ return;
+ }
+ }
+ else {
+ last READ_HEADER; # HTTP/0.9 client
+ }
+ }
+ elsif (length($buf) > 16*1024) {
+ $self->send_error(414); # REQUEST_URI_TOO_LARGE
+ $self->reason("Very long first line");
+ return;
+ }
+ print STDERR "Need more data for complete header\n" if $DEBUG;
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
+ ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
+ $self->send_error(400); # BAD_REQUEST
+ $self->reason("Bad request line: $buf");
+ return;
+ }
+ my $method = $1;
+ my $uri = $2;
+ my $proto = $3 || "HTTP/0.9";
+ $uri = "http://$uri" if $method eq "CONNECT";
+ $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
+ my $r = HTTP::Request->new($method, $uri);
+ $r->protocol($proto);
+ ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
+ ${*$self}{'httpd_head'} = ($method eq "HEAD");
+
+ if ($proto >= $HTTP_1_0) {
+ # we expect to find some headers
+ my($key, $val);
+ HEADER:
+ while ($buf =~ s/^([^\012]*)\012//) {
+ $_ = $1;
+ s/\015$//;
+ if (/^([^:\s]+)\s*:\s*(.*)/) {
+ $r->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ $val .= " $1";
+ }
+ else {
+ last HEADER;
+ }
+ }
+ $r->push_header($key, $val) if $key;
+ }
+
+ my $conn = $r->header('Connection');
+ if ($proto >= $HTTP_1_1) {
+ ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
+ }
+ else {
+ ${*$self}{'httpd_nomore'}++ unless $conn &&
+ lc($conn) =~ /\bkeep-alive\b/;
+ }
+
+ if ($only_headers) {
+ ${*$self}{'httpd_rbuf'} = $buf;
+ return $r;
+ }
+
+ # Find out how much content to read
+ my $te = $r->header('Transfer-Encoding');
+ my $ct = $r->header('Content-Type');
+ my $len = $r->header('Content-Length');
+
+ # Act on the Expect header, if it's there
+ for my $e ( $r->header('Expect') ) {
+ if( lc($e) eq '100-continue' ) {
+ $self->send_status_line(100);
+ $self->send_crlf;
+ }
+ else {
+ $self->send_error(417);
+ $self->reason("Unsupported Expect header value");
+ return;
+ }
+ }
+
+ if ($te && lc($te) eq 'chunked') {
+ # Handle chunked transfer encoding
+ my $body = "";
+ CHUNK:
+ while (1) {
+ print STDERR "Chunked\n" if $DEBUG;
+ if ($buf =~ s/^([^\012]*)\012//) {
+ my $chunk_head = $1;
+ unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
+ $self->send_error(400);
+ $self->reason("Bad chunk header $chunk_head");
+ return;
+ }
+ my $size = hex($1);
+ last CHUNK if $size == 0;
+
+ my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
+ # must read until we have a complete chunk
+ while ($missing > 0) {
+ print STDERR "Need $missing more bytes\n" if $DEBUG;
+ my $n = $self->_need_more($buf, $timeout, $fdset);
+ return unless $n;
+ $missing -= $n;
+ }
+ $body .= substr($buf, 0, $size);
+ substr($buf, 0, $size+2) = '';
+
+ }
+ else {
+ # need more data in order to have a complete chunk header
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ }
+ $r->content($body);
+
+ # pretend it was a normal entity body
+ $r->remove_header('Transfer-Encoding');
+ $r->header('Content-Length', length($body));
+
+ my($key, $val);
+ FOOTER:
+ while (1) {
+ if ($buf !~ /\012/) {
+ # need at least one line to look at
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ else {
+ $buf =~ s/^([^\012]*)\012//;
+ $_ = $1;
+ s/\015$//;
+ if (/^([\w\-]+)\s*:\s*(.*)/) {
+ $r->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ $val .= " $1";
+ }
+ elsif (!length) {
+ last FOOTER;
+ }
+ else {
+ $self->reason("Bad footer syntax");
+ return;
+ }
+ }
+ }
+ $r->push_header($key, $val) if $key;
+
+ }
+ elsif ($te) {
+ $self->send_error(501); # Unknown transfer encoding
+ $self->reason("Unknown transfer encoding '$te'");
+ return;
+
+ }
+ elsif ($len) {
+ # Plain body specified by "Content-Length"
+ my $missing = $len - length($buf);
+ while ($missing > 0) {
+ print "Need $missing more bytes of content\n" if $DEBUG;
+ my $n = $self->_need_more($buf, $timeout, $fdset);
+ return unless $n;
+ $missing -= $n;
+ }
+ if (length($buf) > $len) {
+ $r->content(substr($buf,0,$len));
+ substr($buf, 0, $len) = '';
+ }
+ else {
+ $r->content($buf);
+ $buf='';
+ }
+ }
+ elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
+ # Handle multipart content type
+ my $boundary = "$CRLF--$2--";
+ my $index;
+ while (1) {
+ $index = index($buf, $boundary);
+ last if $index >= 0;
+ # end marker not yet found
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ $index += length($boundary);
+ $r->content(substr($buf, 0, $index));
+ substr($buf, 0, $index) = '';
+
+ }
+ ${*$self}{'httpd_rbuf'} = $buf;
+
+ $r;
+}
+
+
+sub _need_more
+{
+ my $self = shift;
+ #my($buf,$timeout,$fdset) = @_;
+ if ($_[1]) {
+ my($timeout, $fdset) = @_[1,2];
+ print STDERR "select(,,,$timeout)\n" if $DEBUG;
+ my $n = select($fdset,undef,undef,$timeout);
+ unless ($n) {
+ $self->reason(defined($n) ? "Timeout" : "select: $!");
+ return;
+ }
+ }
+ print STDERR "sysread()\n" if $DEBUG;
+ my $n = sysread($self, $_[0], 2048, length($_[0]));
+ $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
+ $n;
+}
+
+
+sub read_buffer
+{
+ my $self = shift;
+ my $old = ${*$self}{'httpd_rbuf'};
+ if (@_) {
+ ${*$self}{'httpd_rbuf'} = shift;
+ }
+ $old;
+}
+
+
+sub reason
+{
+ my $self = shift;
+ my $old = ${*$self}{'httpd_reason'};
+ if (@_) {
+ ${*$self}{'httpd_reason'} = shift;
+ }
+ $old;
+}
+
+
+sub proto_ge
+{
+ my $self = shift;
+ ${*$self}{'httpd_client_proto'} >= _http_version(shift);
+}
+
+
+sub _http_version
+{
+ local($_) = shift;
+ return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
+ $1 * 1000 + $2;
+}
+
+
+sub antique_client
+{
+ my $self = shift;
+ ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
+}
+
+
+sub force_last_request
+{
+ my $self = shift;
+ ${*$self}{'httpd_nomore'}++;
+}
+
+sub head_request
+{
+ my $self = shift;
+ ${*$self}{'httpd_head'};
+}
+
+
+sub send_status_line
+{
+ my($self, $status, $message, $proto) = @_;
+ return if $self->antique_client;
+ $status ||= RC_OK;
+ $message ||= status_message($status) || "";
+ $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
+ print $self "$proto $status $message$CRLF";
+}
+
+
+sub send_crlf
+{
+ my $self = shift;
+ print $self $CRLF;
+}
+
+
+sub send_basic_header
+{
+ my $self = shift;
+ return if $self->antique_client;
+ $self->send_status_line(@_);
+ print $self "Date: ", time2str(time), $CRLF;
+ my $product = $self->daemon->product_tokens;
+ print $self "Server: $product$CRLF" if $product;
+}
+
+
+sub send_header
+{
+ my $self = shift;
+ while (@_) {
+ my($k, $v) = splice(@_, 0, 2);
+ $v = "" unless defined($v);
+ print $self "$k: $v$CRLF";
+ }
+}
+
+
+sub send_response
+{
+ my $self = shift;
+ my $res = shift;
+ if (!ref $res) {
+ $res ||= RC_OK;
+ $res = HTTP::Response->new($res, @_);
+ }
+ my $content = $res->content;
+ my $chunked;
+ unless ($self->antique_client) {
+ my $code = $res->code;
+ $self->send_basic_header($code, $res->message, $res->protocol);
+ if ($code =~ /^(1\d\d|[23]04)$/) {
+ # make sure content is empty
+ $res->remove_header("Content-Length");
+ $content = "";
+ }
+ elsif ($res->request && $res->request->method eq "HEAD") {
+ # probably OK
+ }
+ elsif (ref($content) eq "CODE") {
+ if ($self->proto_ge("HTTP/1.1")) {
+ $res->push_header("Transfer-Encoding" => "chunked");
+ $chunked++;
+ }
+ else {
+ $self->force_last_request;
+ }
+ }
+ elsif (length($content)) {
+ $res->header("Content-Length" => length($content));
+ }
+ else {
+ $self->force_last_request;
+ $res->header('connection','close');
+ }
+ print $self $res->headers_as_string($CRLF);
+ print $self $CRLF; # separates headers and content
+ }
+ if ($self->head_request) {
+ # no content
+ }
+ elsif (ref($content) eq "CODE") {
+ while (1) {
+ my $chunk = &$content();
+ last unless defined($chunk) && length($chunk);
+ if ($chunked) {
+ printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
+ }
+ else {
+ print $self $chunk;
+ }
+ }
+ print $self "0$CRLF$CRLF" if $chunked; # no trailers either
+ }
+ elsif (length $content) {
+ print $self $content;
+ }
+}
+
+
+sub send_redirect
+{
+ my($self, $loc, $status, $content) = @_;
+ $status ||= RC_MOVED_PERMANENTLY;
+ Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
+ $self->send_basic_header($status);
+ my $base = $self->daemon->url;
+ $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
+ $loc = $loc->abs($base);
+ print $self "Location: $loc$CRLF";
+ if ($content) {
+ my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
+ print $self "Content-Type: $ct$CRLF";
+ }
+ print $self $CRLF;
+ print $self $content if $content && !$self->head_request;
+ $self->force_last_request; # no use keeping the connection open
+}
+
+
+sub send_error
+{
+ my($self, $status, $error) = @_;
+ $status ||= RC_BAD_REQUEST;
+ Carp::croak("Status '$status' is not an error") unless is_error($status);
+ my $mess = status_message($status);
+ $error ||= "";
+ $mess = <<EOT;
+<title>$status $mess</title>
+<h1>$status $mess</h1>
+$error
+EOT
+ unless ($self->antique_client) {
+ $self->send_basic_header($status);
+ print $self "Content-Type: text/html$CRLF";
+ print $self "Content-Length: " . length($mess) . $CRLF;
+ print $self $CRLF;
+ }
+ print $self $mess unless $self->head_request;
+ $status;
+}
+
+
+sub send_file_response
+{
+ my($self, $file) = @_;
+ if (-d $file) {
+ $self->send_dir($file);
+ }
+ elsif (-f _) {
+ # plain file
+ local(*F);
+ sysopen(F, $file, 0) or
+ return $self->send_error(RC_FORBIDDEN);
+ binmode(F);
+ my($ct,$ce) = guess_media_type($file);
+ my($size,$mtime) = (stat _)[7,9];
+ unless ($self->antique_client) {
+ $self->send_basic_header;
+ print $self "Content-Type: $ct$CRLF";
+ print $self "Content-Encoding: $ce$CRLF" if $ce;
+ print $self "Content-Length: $size$CRLF" if $size;
+ print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
+ print $self $CRLF;
+ }
+ $self->send_file(\*F) unless $self->head_request;
+ return RC_OK;
+ }
+ else {
+ $self->send_error(RC_NOT_FOUND);
+ }
+}
+
+
+sub send_dir
+{
+ my($self, $dir) = @_;
+ $self->send_error(RC_NOT_FOUND) unless -d $dir;
+ $self->send_error(RC_NOT_IMPLEMENTED);
+}
+
+
+sub send_file
+{
+ my($self, $file) = @_;
+ my $opened = 0;
+ local(*FILE);
+ if (!ref($file)) {
+ open(FILE, $file) || return undef;
+ binmode(FILE);
+ $file = \*FILE;
+ $opened++;
+ }
+ my $cnt = 0;
+ my $buf = "";
+ my $n;
+ while ($n = sysread($file, $buf, 8*1024)) {
+ last if !$n;
+ $cnt += $n;
+ print $self $buf;
+ }
+ close($file) if $opened;
+ $cnt;
+}
+
+
+sub daemon
+{
+ my $self = shift;
+ ${*$self}{'httpd_daemon'};
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Daemon - a simple http server class
+
+=head1 SYNOPSIS
+
+ use HTTP::Daemon;
+ use HTTP::Status;
+
+ my $d = HTTP::Daemon->new || die;
+ print "Please contact me at: <URL:", $d->url, ">\n";
+ while (my $c = $d->accept) {
+ while (my $r = $c->get_request) {
+ if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
+ # remember, this is *not* recommended practice :-)
+ $c->send_file_response("/etc/passwd");
+ }
+ else {
+ $c->send_error(RC_FORBIDDEN)
+ }
+ }
+ $c->close;
+ undef($c);
+ }
+
+=head1 DESCRIPTION
+
+Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
+listen on a socket for incoming requests. The C<HTTP::Daemon> is a
+subclass of C<IO::Socket::INET>, so you can perform socket operations
+directly on it too.
+
+The accept() method will return when a connection from a client is
+available. The returned value will be an C<HTTP::Daemon::ClientConn>
+object which is another C<IO::Socket::INET> subclass. Calling the
+get_request() method on this object will read data from the client and
+return an C<HTTP::Request> object. The ClientConn object also provide
+methods to send back various responses.
+
+This HTTP daemon does not fork(2) for you. Your application, i.e. the
+user of the C<HTTP::Daemon> is responsible for forking if that is
+desirable. Also note that the user is responsible for generating
+responses that conform to the HTTP/1.1 protocol.
+
+The following methods of C<HTTP::Daemon> are new (or enhanced) relative
+to the C<IO::Socket::INET> base class:
+
+=over 4
+
+=item $d = HTTP::Daemon->new
+
+=item $d = HTTP::Daemon->new( %opts )
+
+The constructor method takes the same arguments as the
+C<IO::Socket::INET> constructor, but unlike its base class it can also
+be called without any arguments. The daemon will then set up a listen
+queue of 5 connections and allocate some random port number.
+
+A server that wants to bind to some specific address on the standard
+HTTP port will be constructed like this:
+
+ $d = HTTP::Daemon->new(
+ LocalAddr => 'www.thisplace.com',
+ LocalPort => 80,
+ );
+
+See L<IO::Socket::INET> for a description of other arguments that can
+be used configure the daemon during construction.
+
+=item $c = $d->accept
+
+=item $c = $d->accept( $pkg )
+
+=item ($c, $peer_addr) = $d->accept
+
+This method works the same the one provided by the base class, but it
+returns an C<HTTP::Daemon::ClientConn> reference by default. If a
+package name is provided as argument, then the returned object will be
+blessed into the given class. It is probably a good idea to make that
+class a subclass of C<HTTP::Daemon::ClientConn>.
+
+The accept method will return C<undef> if timeouts have been enabled
+and no connection is made within the given time. The timeout() method
+is described in L<IO::Socket>.
+
+In list context both the client object and the peer address will be
+returned; see the description of the accept method L<IO::Socket> for
+details.
+
+=item $d->url
+
+Returns a URL string that can be used to access the server root.
+
+=item $d->product_tokens
+
+Returns the name that this server will use to identify itself. This
+is the string that is sent with the C<Server> response header. The
+main reason to have this method is that subclasses can override it if
+they want to use another product name.
+
+The default is the string "libwww-perl-daemon/#.##" where "#.##" is
+replaced with the version number of this module.
+
+=back
+
+The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
+subclass. Instances of this class are returned by the accept() method
+of C<HTTP::Daemon>. The following methods are provided:
+
+=over 4
+
+=item $c->get_request
+
+=item $c->get_request( $headers_only )
+
+This method reads data from the client and turns it into an
+C<HTTP::Request> object which is returned. It returns C<undef>
+if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn>
+object ($c) should be discarded, and you should not try call this
+method again on it. The $c->reason method might give you some
+information about why $c->get_request failed.
+
+The get_request() method will normally not return until the whole
+request has been received from the client. This might not be what you
+want if the request is an upload of a large file (and with chunked
+transfer encoding HTTP can even support infinite request messages -
+uploading live audio for instance). If you pass a TRUE value as the
+$headers_only argument, then get_request() will return immediately
+after parsing the request headers and you are responsible for reading
+the rest of the request content. If you are going to call
+$c->get_request again on the same connection you better read the
+correct number of bytes.
+
+=item $c->read_buffer
+
+=item $c->read_buffer( $new_value )
+
+Bytes read by $c->get_request, but not used are placed in the I<read
+buffer>. The next time $c->get_request is called it will consume the
+bytes in this buffer before reading more data from the network
+connection itself. The read buffer is invalid after $c->get_request
+has failed.
+
+If you handle the reading of the request content yourself you need to
+empty this buffer before you read more and you need to place
+unconsumed bytes here. You also need this buffer if you implement
+services like I<101 Switching Protocols>.
+
+This method always returns the old buffer content and can optionally
+replace the buffer content if you pass it an argument.
+
+=item $c->reason
+
+When $c->get_request returns C<undef> you can obtain a short string
+describing why it happened by calling $c->reason.
+
+=item $c->proto_ge( $proto )
+
+Return TRUE if the client announced a protocol with version number
+greater or equal to the given argument. The $proto argument can be a
+string like "HTTP/1.1" or just "1.1".
+
+=item $c->antique_client
+
+Return TRUE if the client speaks the HTTP/0.9 protocol. No status
+code and no headers should be returned to such a client. This should
+be the same as !$c->proto_ge("HTTP/1.0").
+
+=item $c->head_request
+
+Return TRUE if the last request was a C<HEAD> request. No content
+body must be generated for these requests.
+
+=item $c->force_last_request
+
+Make sure that $c->get_request will not try to read more requests off
+this connection. If you generate a response that is not self
+delimiting, then you should signal this fact by calling this method.
+
+This attribute is turned on automatically if the client announces
+protocol HTTP/1.0 or worse and does not include a "Connection:
+Keep-Alive" header. It is also turned on automatically when HTTP/1.1
+or better clients send the "Connection: close" request header.
+
+=item $c->send_status_line
+
+=item $c->send_status_line( $code )
+
+=item $c->send_status_line( $code, $mess )
+
+=item $c->send_status_line( $code, $mess, $proto )
+
+Send the status line back to the client. If $code is omitted 200 is
+assumed. If $mess is omitted, then a message corresponding to $code
+is inserted. If $proto is missing the content of the
+$HTTP::Daemon::PROTO variable is used.
+
+=item $c->send_crlf
+
+Send the CRLF sequence to the client.
+
+=item $c->send_basic_header
+
+=item $c->send_basic_header( $code )
+
+=item $c->send_basic_header( $code, $mess )
+
+=item $c->send_basic_header( $code, $mess, $proto )
+
+Send the status line and the "Date:" and "Server:" headers back to
+the client. This header is assumed to be continued and does not end
+with an empty CRLF line.
+
+See the description of send_status_line() for the description of the
+accepted arguments.
+
+=item $c->send_header( $field, $value )
+
+=item $c->send_header( $field1, $value1, $field2, $value2, ... )
+
+Send one or more header lines.
+
+=item $c->send_response( $res )
+
+Write a C<HTTP::Response> object to the
+client as a response. We try hard to make sure that the response is
+self delimiting so that the connection can stay persistent for further
+request/response exchanges.
+
+The content attribute of the C<HTTP::Response> object can be a normal
+string or a subroutine reference. If it is a subroutine, then
+whatever this callback routine returns is written back to the
+client as the response content. The routine will be called until it
+return an undefined or empty value. If the client is HTTP/1.1 aware
+then we will use chunked transfer encoding for the response.
+
+=item $c->send_redirect( $loc )
+
+=item $c->send_redirect( $loc, $code )
+
+=item $c->send_redirect( $loc, $code, $entity_body )
+
+Send a redirect response back to the client. The location ($loc) can
+be an absolute or relative URL. The $code must be one the redirect
+status codes, and defaults to "301 Moved Permanently"
+
+=item $c->send_error
+
+=item $c->send_error( $code )
+
+=item $c->send_error( $code, $error_message )
+
+Send an error response back to the client. If the $code is missing a
+"Bad Request" error is reported. The $error_message is a string that
+is incorporated in the body of the HTML entity body.
+
+=item $c->send_file_response( $filename )
+
+Send back a response with the specified $filename as content. If the
+file is a directory we try to generate an HTML index of it.
+
+=item $c->send_file( $filename )
+
+=item $c->send_file( $fd )
+
+Copy the file to the client. The file can be a string (which
+will be interpreted as a filename) or a reference to an C<IO::Handle>
+or glob.
+
+=item $c->daemon
+
+Return a reference to the corresponding C<HTTP::Daemon> object.
+
+=back
+
+=head1 SEE ALSO
+
+RFC 2616
+
+L<IO::Socket::INET>, L<IO::Socket>
+
+=head1 COPYRIGHT
+
+Copyright 1996-2003, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Date.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Date.pm
new file mode 100755
index 00000000000..7756214af98
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Date.pm
@@ -0,0 +1,389 @@
+package HTTP::Date;
+
+$VERSION = "5.831";
+
+require 5.004;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(time2str str2time);
+@EXPORT_OK = qw(parse_date time2iso time2isoz);
+
+use strict;
+require Time::Local;
+
+use vars qw(@DoW @MoY %MoY);
+@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
+@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+@MoY{@MoY} = (1..12);
+
+my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1);
+
+
+sub time2str (;$)
+{
+ my $time = shift;
+ $time = time unless defined $time;
+ my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
+ sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
+ $DoW[$wday],
+ $mday, $MoY[$mon], $year+1900,
+ $hour, $min, $sec);
+}
+
+
+sub str2time ($;$)
+{
+ my $str = shift;
+ return undef unless defined $str;
+
+ # fast exit for strictly conforming string
+ if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) {
+ return eval {
+ my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3);
+ $t < 0 ? undef : $t;
+ };
+ }
+
+ my @d = parse_date($str);
+ return undef unless @d;
+ $d[1]--; # month
+
+ my $tz = pop(@d);
+ unless (defined $tz) {
+ unless (defined($tz = shift)) {
+ return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
+ my $t = Time::Local::timelocal(reverse @d) + $frac;
+ $t < 0 ? undef : $t;
+ };
+ }
+ }
+
+ my $offset = 0;
+ if ($GMT_ZONE{uc $tz}) {
+ # offset already zero
+ }
+ elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) {
+ $offset = 3600 * $2;
+ $offset += 60 * $3 if $3;
+ $offset *= -1 if $1 && $1 eq '-';
+ }
+ else {
+ eval { require Time::Zone } || return undef;
+ $offset = Time::Zone::tz_offset($tz);
+ return undef unless defined $offset;
+ }
+
+ return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
+ my $t = Time::Local::timegm(reverse @d) + $frac;
+ $t < 0 ? undef : $t - $offset;
+ };
+}
+
+
+sub parse_date ($)
+{
+ local($_) = shift;
+ return unless defined;
+
+ # More lax parsing below
+ s/^\s+//; # kill leading space
+ s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
+
+ my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm);
+
+ # Then we are able to check for most of the formats with this regexp
+ (($day,$mon,$yr,$hr,$min,$sec,$tz) =
+ /^
+ (\d\d?) # day
+ (?:\s+|[-\/])
+ (\w+) # month
+ (?:\s+|[-\/])
+ (\d+) # year
+ (?:
+ (?:\s+|:) # separator before clock
+ (\d\d?):(\d\d) # hour:min
+ (?::(\d\d))? # optional seconds
+ )? # optional clock
+ \s*
+ ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
+ \s*
+ (?:\(\w+\))? # ASCII representation of timezone in parens.
+ \s*$
+ /x)
+
+ ||
+
+ # Try the ctime and asctime format
+ (($mon, $day, $hr, $min, $sec, $tz, $yr) =
+ /^
+ (\w{1,3}) # month
+ \s+
+ (\d\d?) # day
+ \s+
+ (\d\d?):(\d\d) # hour:min
+ (?::(\d\d))? # optional seconds
+ \s+
+ (?:([A-Za-z]+)\s+)? # optional timezone
+ (\d+) # year
+ \s*$ # allow trailing whitespace
+ /x)
+
+ ||
+
+ # Then the Unix 'ls -l' date format
+ (($mon, $day, $yr, $hr, $min, $sec) =
+ /^
+ (\w{3}) # month
+ \s+
+ (\d\d?) # day
+ \s+
+ (?:
+ (\d\d\d\d) | # year
+ (\d{1,2}):(\d{2}) # hour:min
+ (?::(\d\d))? # optional seconds
+ )
+ \s*$
+ /x)
+
+ ||
+
+ # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
+ (($yr, $mon, $day, $hr, $min, $sec, $tz) =
+ /^
+ (\d{4}) # year
+ [-\/]?
+ (\d\d?) # numerical month
+ [-\/]?
+ (\d\d?) # day
+ (?:
+ (?:\s+|[-:Tt]) # separator before clock
+ (\d\d?):?(\d\d) # hour:min
+ (?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional)
+ )? # optional clock
+ \s*
+ ([-+]?\d\d?:?(:?\d\d)?
+ |Z|z)? # timezone (Z is "zero meridian", i.e. GMT)
+ \s*$
+ /x)
+
+ ||
+
+ # Windows 'dir' 11-12-96 03:52PM
+ (($mon, $day, $yr, $hr, $min, $ampm) =
+ /^
+ (\d{2}) # numerical month
+ -
+ (\d{2}) # day
+ -
+ (\d{2}) # year
+ \s+
+ (\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM
+ \s*$
+ /x)
+
+ ||
+ return; # unrecognized format
+
+ # Translate month name to number
+ $mon = $MoY{$mon} ||
+ $MoY{"\u\L$mon"} ||
+ ($mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon)) ||
+ return;
+
+ # If the year is missing, we assume first date before the current,
+ # because of the formats we support such dates are mostly present
+ # on "ls -l" listings.
+ unless (defined $yr) {
+ my $cur_mon;
+ ($cur_mon, $yr) = (localtime)[4, 5];
+ $yr += 1900;
+ $cur_mon++;
+ $yr-- if $mon > $cur_mon;
+ }
+ elsif (length($yr) < 3) {
+ # Find "obvious" year
+ my $cur_yr = (localtime)[5] + 1900;
+ my $m = $cur_yr % 100;
+ my $tmp = $yr;
+ $yr += $cur_yr - $m;
+ $m -= $tmp;
+ $yr += ($m > 0) ? 100 : -100
+ if abs($m) > 50;
+ }
+
+ # Make sure clock elements are defined
+ $hr = 0 unless defined($hr);
+ $min = 0 unless defined($min);
+ $sec = 0 unless defined($sec);
+
+ # Compensate for AM/PM
+ if ($ampm) {
+ $ampm = uc $ampm;
+ $hr = 0 if $hr == 12 && $ampm eq 'AM';
+ $hr += 12 if $ampm eq 'PM' && $hr != 12;
+ }
+
+ return($yr, $mon, $day, $hr, $min, $sec, $tz)
+ if wantarray;
+
+ if (defined $tz) {
+ $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
+ }
+ else {
+ $tz = "";
+ }
+ return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s",
+ $yr, $mon, $day, $hr, $min, $sec, $tz);
+}
+
+
+sub time2iso (;$)
+{
+ my $time = shift;
+ $time = time unless defined $time;
+ my($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
+ sprintf("%04d-%02d-%02d %02d:%02d:%02d",
+ $year+1900, $mon+1, $mday, $hour, $min, $sec);
+}
+
+
+sub time2isoz (;$)
+{
+ my $time = shift;
+ $time = time unless defined $time;
+ my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time);
+ sprintf("%04d-%02d-%02d %02d:%02d:%02dZ",
+ $year+1900, $mon+1, $mday, $hour, $min, $sec);
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Date - date conversion routines
+
+=head1 SYNOPSIS
+
+ use HTTP::Date;
+
+ $string = time2str($time); # Format as GMT ASCII time
+ $time = str2time($string); # convert ASCII date to machine time
+
+=head1 DESCRIPTION
+
+This module provides functions that deal the date formats used by the
+HTTP protocol (and then some more). Only the first two functions,
+time2str() and str2time(), are exported by default.
+
+=over 4
+
+=item time2str( [$time] )
+
+The time2str() function converts a machine time (seconds since epoch)
+to a string. If the function is called without an argument or with an
+undefined argument, it will use the current time.
+
+The string returned is in the format preferred for the HTTP protocol.
+This is a fixed length subset of the format defined by RFC 1123,
+represented in Universal Time (GMT). An example of a time stamp
+in this format is:
+
+ Sun, 06 Nov 1994 08:49:37 GMT
+
+=item str2time( $str [, $zone] )
+
+The str2time() function converts a string to machine time. It returns
+C<undef> if the format of $str is unrecognized, otherwise whatever the
+C<Time::Local> functions can make out of the parsed time. Dates
+before the system's epoch may not work on all operating systems. The
+time formats recognized are the same as for parse_date().
+
+The function also takes an optional second argument that specifies the
+default time zone to use when converting the date. This parameter is
+ignored if the zone is found in the date string itself. If this
+parameter is missing, and the date string format does not contain any
+zone specification, then the local time zone is assumed.
+
+If the zone is not "C<GMT>" or numerical (like "C<-0800>" or
+"C<+0100>"), then the C<Time::Zone> module must be installed in order
+to get the date recognized.
+
+=item parse_date( $str )
+
+This function will try to parse a date string, and then return it as a
+list of numerical values followed by a (possible undefined) time zone
+specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year
+returned will B<not> have the number 1900 subtracted from it and the
+$month numbers start with 1.
+
+In scalar context the numbers are interpolated in a string of the
+"YYYY-MM-DD hh:mm:ss TZ"-format and returned.
+
+If the date is unrecognized, then the empty list is returned.
+
+The function is able to parse the following formats:
+
+ "Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format
+ "Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format
+ "Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format
+ "Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format
+ "Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format
+
+ "03/Feb/1994:17:03:55 -0700" -- common logfile format
+ "09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday)
+ "08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday)
+ "08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday)
+
+ "1994-02-03 14:15:29 -0100" -- ISO 8601 format
+ "1994-02-03 14:15:29" -- zone is optional
+ "1994-02-03" -- only date
+ "1994-02-03T14:15:29" -- Use T as separator
+ "19940203T141529Z" -- ISO 8601 compact format
+ "19940203" -- only date
+
+ "08-Feb-94" -- old rfc850 HTTP format (no weekday, no time)
+ "08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time)
+ "09 Feb 1994" -- proposed new HTTP format (no weekday, no time)
+ "03/Feb/1994" -- common logfile format (no time, no offset)
+
+ "Feb 3 1994" -- Unix 'ls -l' format
+ "Feb 3 17:03" -- Unix 'ls -l' format
+
+ "11-15-96 03:52PM" -- Windows 'dir' format
+
+The parser ignores leading and trailing whitespace. It also allow the
+seconds to be missing and the month to be numerical in most formats.
+
+If the year is missing, then we assume that the date is the first
+matching date I<before> current month. If the year is given with only
+2 digits, then parse_date() will select the century that makes the
+year closest to the current date.
+
+=item time2iso( [$time] )
+
+Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted
+string representing time in the local time zone.
+
+=item time2isoz( [$time] )
+
+Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted
+string representing Universal Time.
+
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc/time>, L<Time::Zone>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1999, Gisle Aas
+
+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.straw/lib/HTTP/Headers.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers.pm
new file mode 100755
index 00000000000..4a11cbe1f6d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers.pm
@@ -0,0 +1,827 @@
+package HTTP::Headers;
+
+use strict;
+use Carp ();
+
+use vars qw($VERSION $TRANSLATE_UNDERSCORE);
+$VERSION = "5.827";
+
+# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
+# as a replacement for '-' in header field names.
+$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
+
+# "Good Practice" order of HTTP message headers:
+# - General-Headers
+# - Request-Headers
+# - Response-Headers
+# - Entity-Headers
+
+my @general_headers = qw(
+ Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
+ Via Warning
+);
+
+my @request_headers = qw(
+ Accept Accept-Charset Accept-Encoding Accept-Language
+ Authorization Expect From Host
+ If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
+ Max-Forwards Proxy-Authorization Range Referer TE User-Agent
+);
+
+my @response_headers = qw(
+ Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
+ Vary WWW-Authenticate
+);
+
+my @entity_headers = qw(
+ Allow Content-Encoding Content-Language Content-Length Content-Location
+ Content-MD5 Content-Range Content-Type Expires Last-Modified
+);
+
+my %entity_header = map { lc($_) => 1 } @entity_headers;
+
+my @header_order = (
+ @general_headers,
+ @request_headers,
+ @response_headers,
+ @entity_headers,
+);
+
+# Make alternative representations of @header_order. This is used
+# for sorting and case matching.
+my %header_order;
+my %standard_case;
+
+{
+ my $i = 0;
+ for (@header_order) {
+ my $lc = lc $_;
+ $header_order{$lc} = ++$i;
+ $standard_case{$lc} = $_;
+ }
+}
+
+
+
+sub new
+{
+ my($class) = shift;
+ my $self = bless {}, $class;
+ $self->header(@_) if @_; # set up initial headers
+ $self;
+}
+
+
+sub header
+{
+ my $self = shift;
+ Carp::croak('Usage: $h->header($field, ...)') unless @_;
+ my(@old);
+ my %seen;
+ while (@_) {
+ my $field = shift;
+ my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
+ @old = $self->_header($field, shift, $op);
+ }
+ return @old if wantarray;
+ return $old[0] if @old <= 1;
+ join(", ", @old);
+}
+
+sub clear
+{
+ my $self = shift;
+ %$self = ();
+}
+
+
+sub push_header
+{
+ my $self = shift;
+ return $self->_header(@_, 'PUSH_H') if @_ == 2;
+ while (@_) {
+ $self->_header(splice(@_, 0, 2), 'PUSH_H');
+ }
+}
+
+
+sub init_header
+{
+ Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
+ shift->_header(@_, 'INIT');
+}
+
+
+sub remove_header
+{
+ my($self, @fields) = @_;
+ my $field;
+ my @values;
+ foreach $field (@fields) {
+ $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
+ my $v = delete $self->{lc $field};
+ push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
+ }
+ return @values;
+}
+
+sub remove_content_headers
+{
+ my $self = shift;
+ unless (defined(wantarray)) {
+ # fast branch that does not create return object
+ delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
+ return;
+ }
+
+ my $c = ref($self)->new;
+ for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
+ $c->{$f} = delete $self->{$f};
+ }
+ $c;
+}
+
+
+sub _header
+{
+ my($self, $field, $val, $op) = @_;
+
+ unless ($field =~ /^:/) {
+ $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
+ my $old = $field;
+ $field = lc $field;
+ unless(defined $standard_case{$field}) {
+ # generate a %standard_case entry for this field
+ $old =~ s/\b(\w)/\u$1/g;
+ $standard_case{$field} = $old;
+ }
+ }
+
+ $op ||= defined($val) ? 'SET' : 'GET';
+ if ($op eq 'PUSH_H') {
+ # Like PUSH but where we don't care about the return value
+ if (exists $self->{$field}) {
+ my $h = $self->{$field};
+ if (ref($h) eq 'ARRAY') {
+ push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
+ }
+ else {
+ $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
+ }
+ return;
+ }
+ $self->{$field} = $val;
+ return;
+ }
+
+ my $h = $self->{$field};
+ my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
+
+ unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
+ if (defined($val)) {
+ my @new = ($op eq 'PUSH') ? @old : ();
+ if (ref($val) ne 'ARRAY') {
+ push(@new, $val);
+ }
+ else {
+ push(@new, @$val);
+ }
+ $self->{$field} = @new > 1 ? \@new : $new[0];
+ }
+ elsif ($op ne 'PUSH') {
+ delete $self->{$field};
+ }
+ }
+ @old;
+}
+
+
+sub _sorted_field_names
+{
+ my $self = shift;
+ return sort {
+ ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
+ $a cmp $b
+ } keys %$self
+}
+
+
+sub header_field_names {
+ my $self = shift;
+ return map $standard_case{$_} || $_, $self->_sorted_field_names
+ if wantarray;
+ return keys %$self;
+}
+
+
+sub scan
+{
+ my($self, $sub) = @_;
+ my $key;
+ foreach $key ($self->_sorted_field_names) {
+ next if $key =~ /^_/;
+ my $vals = $self->{$key};
+ if (ref($vals) eq 'ARRAY') {
+ my $val;
+ for $val (@$vals) {
+ &$sub($standard_case{$key} || $key, $val);
+ }
+ }
+ else {
+ &$sub($standard_case{$key} || $key, $vals);
+ }
+ }
+}
+
+
+sub as_string
+{
+ my($self, $endl) = @_;
+ $endl = "\n" unless defined $endl;
+
+ my @result = ();
+ $self->scan(sub {
+ my($field, $val) = @_;
+ $field =~ s/^://;
+ if ($val =~ /\n/) {
+ # must handle header values with embedded newlines with care
+ $val =~ s/\s+$//; # trailing newlines and space must go
+ $val =~ s/\n\n+/\n/g; # no empty lines
+ $val =~ s/\n([^\040\t])/\n $1/g; # intial space for continuation
+ $val =~ s/\n/$endl/g; # substitute with requested line ending
+ }
+ push(@result, "$field: $val");
+ });
+
+ join($endl, @result, '');
+}
+
+
+if (eval { require Storable; 1 }) {
+ *clone = \&Storable::dclone;
+} else {
+ *clone = sub {
+ my $self = shift;
+ my $clone = new HTTP::Headers;
+ $self->scan(sub { $clone->push_header(@_);} );
+ $clone;
+ };
+}
+
+
+sub _date_header
+{
+ require HTTP::Date;
+ my($self, $header, $time) = @_;
+ my($old) = $self->_header($header);
+ if (defined $time) {
+ $self->_header($header, HTTP::Date::time2str($time));
+ }
+ $old =~ s/;.*// if defined($old);
+ HTTP::Date::str2time($old);
+}
+
+
+sub date { shift->_date_header('Date', @_); }
+sub expires { shift->_date_header('Expires', @_); }
+sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
+sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
+sub last_modified { shift->_date_header('Last-Modified', @_); }
+
+# This is used as a private LWP extension. The Client-Date header is
+# added as a timestamp to a response when it has been received.
+sub client_date { shift->_date_header('Client-Date', @_); }
+
+# The retry_after field is dual format (can also be a expressed as
+# number of seconds from now), so we don't provide an easy way to
+# access it until we have know how both these interfaces can be
+# addressed. One possibility is to return a negative value for
+# relative seconds and a positive value for epoch based time values.
+#sub retry_after { shift->_date_header('Retry-After', @_); }
+
+sub content_type {
+ my $self = shift;
+ my $ct = $self->{'content-type'};
+ $self->{'content-type'} = shift if @_;
+ $ct = $ct->[0] if ref($ct) eq 'ARRAY';
+ return '' unless defined($ct) && length($ct);
+ my @ct = split(/;\s*/, $ct, 2);
+ for ($ct[0]) {
+ s/\s+//g;
+ $_ = lc($_);
+ }
+ wantarray ? @ct : $ct[0];
+}
+
+sub content_type_charset {
+ my $self = shift;
+ require HTTP::Headers::Util;
+ my $h = $self->{'content-type'};
+ $h = $h->[0] if ref($h);
+ $h = "" unless defined $h;
+ my @v = HTTP::Headers::Util::split_header_words($h);
+ if (@v) {
+ my($ct, undef, %ct_param) = @{$v[0]};
+ my $charset = $ct_param{charset};
+ if ($ct) {
+ $ct = lc($ct);
+ $ct =~ s/\s+//;
+ }
+ if ($charset) {
+ $charset = uc($charset);
+ $charset =~ s/^\s+//; $charset =~ s/\s+\z//;
+ undef($charset) if $charset eq "";
+ }
+ return $ct, $charset if wantarray;
+ return $charset;
+ }
+ return undef, undef if wantarray;
+ return undef;
+}
+
+sub content_is_text {
+ my $self = shift;
+ return $self->content_type =~ m,^text/,;
+}
+
+sub content_is_html {
+ my $self = shift;
+ return $self->content_type eq 'text/html' || $self->content_is_xhtml;
+}
+
+sub content_is_xhtml {
+ my $ct = shift->content_type;
+ return $ct eq "application/xhtml+xml" ||
+ $ct eq "application/vnd.wap.xhtml+xml";
+}
+
+sub content_is_xml {
+ my $ct = shift->content_type;
+ return 1 if $ct eq "text/xml";
+ return 1 if $ct eq "application/xml";
+ return 1 if $ct =~ /\+xml$/;
+ return 0;
+}
+
+sub referer {
+ my $self = shift;
+ if (@_ && $_[0] =~ /#/) {
+ # Strip fragment per RFC 2616, section 14.36.
+ my $uri = shift;
+ if (ref($uri)) {
+ $uri = $uri->clone;
+ $uri->fragment(undef);
+ }
+ else {
+ $uri =~ s/\#.*//;
+ }
+ unshift @_, $uri;
+ }
+ ($self->_header('Referer', @_))[0];
+}
+*referrer = \&referer; # on tchrist's request
+
+sub title { (shift->_header('Title', @_))[0] }
+sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
+sub content_language { (shift->_header('Content-Language', @_))[0] }
+sub content_length { (shift->_header('Content-Length', @_))[0] }
+
+sub user_agent { (shift->_header('User-Agent', @_))[0] }
+sub server { (shift->_header('Server', @_))[0] }
+
+sub from { (shift->_header('From', @_))[0] }
+sub warning { (shift->_header('Warning', @_))[0] }
+
+sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
+sub authorization { (shift->_header('Authorization', @_))[0] }
+
+sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
+sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
+
+sub authorization_basic { shift->_basic_auth("Authorization", @_) }
+sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
+
+sub _basic_auth {
+ require MIME::Base64;
+ my($self, $h, $user, $passwd) = @_;
+ my($old) = $self->_header($h);
+ if (defined $user) {
+ Carp::croak("Basic authorization user name can't contain ':'")
+ if $user =~ /:/;
+ $passwd = '' unless defined $passwd;
+ $self->_header($h => 'Basic ' .
+ MIME::Base64::encode("$user:$passwd", ''));
+ }
+ if (defined $old && $old =~ s/^\s*Basic\s+//) {
+ my $val = MIME::Base64::decode($old);
+ return $val unless wantarray;
+ return split(/:/, $val, 2);
+ }
+ return;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Headers - Class encapsulating HTTP Message headers
+
+=head1 SYNOPSIS
+
+ require HTTP::Headers;
+ $h = HTTP::Headers->new;
+
+ $h->header('Content-Type' => 'text/plain'); # set
+ $ct = $h->header('Content-Type'); # get
+ $h->remove_header('Content-Type'); # delete
+
+=head1 DESCRIPTION
+
+The C<HTTP::Headers> class encapsulates HTTP-style message headers.
+The headers consist of attribute-value pairs also called fields, which
+may be repeated, and which are printed in a particular order. The
+field names are cases insensitive.
+
+Instances of this class are usually created as member variables of the
+C<HTTP::Request> and C<HTTP::Response> classes, internal to the
+library.
+
+The following methods are available:
+
+=over 4
+
+=item $h = HTTP::Headers->new
+
+Constructs a new C<HTTP::Headers> object. You might pass some initial
+attribute-value pairs as parameters to the constructor. I<E.g.>:
+
+ $h = HTTP::Headers->new(
+ Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
+ Content_Type => 'text/html; version=3.2',
+ Content_Base => 'http://www.perl.org/');
+
+The constructor arguments are passed to the C<header> method which is
+described below.
+
+=item $h->clone
+
+Returns a copy of this C<HTTP::Headers> object.
+
+=item $h->header( $field )
+
+=item $h->header( $field => $value )
+
+=item $h->header( $f1 => $v1, $f2 => $v2, ... )
+
+Get or set the value of one or more header fields. The header field
+name ($field) is not case sensitive. To make the life easier for perl
+users who wants to avoid quoting before the => operator, you can use
+'_' as a replacement for '-' in header names.
+
+The header() method accepts multiple ($field => $value) pairs, which
+means that you can update several fields with a single invocation.
+
+The $value argument may be a plain string or a reference to an array
+of strings for a multi-valued field. If the $value is provided as
+C<undef> then the field is removed. If the $value is not given, then
+that header field will remain unchanged.
+
+The old value (or values) of the last of the header fields is returned.
+If no such field exists C<undef> will be returned.
+
+A multi-valued field will be returned as separate values in list
+context and will be concatenated with ", " as separator in scalar
+context. The HTTP spec (RFC 2616) promise that joining multiple
+values in this way will not change the semantic of a header field, but
+in practice there are cases like old-style Netscape cookies (see
+L<HTTP::Cookies>) where "," is used as part of the syntax of a single
+field value.
+
+Examples:
+
+ $header->header(MIME_Version => '1.0',
+ User_Agent => 'My-Web-Client/0.01');
+ $header->header(Accept => "text/html, text/plain, image/*");
+ $header->header(Accept => [qw(text/html text/plain image/*)]);
+ @accepts = $header->header('Accept'); # get multiple values
+ $accepts = $header->header('Accept'); # get values as a single string
+
+=item $h->push_header( $field => $value )
+
+=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
+
+Add a new field value for the specified header field. Previous values
+for the same field are retained.
+
+As for the header() method, the field name ($field) is not case
+sensitive and '_' can be used as a replacement for '-'.
+
+The $value argument may be a scalar or a reference to a list of
+scalars.
+
+ $header->push_header(Accept => 'image/jpeg');
+ $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
+
+=item $h->init_header( $field => $value )
+
+Set the specified header to the given value, but only if no previous
+value for that field is set.
+
+The header field name ($field) is not case sensitive and '_'
+can be used as a replacement for '-'.
+
+The $value argument may be a scalar or a reference to a list of
+scalars.
+
+=item $h->remove_header( $field, ... )
+
+This function removes the header fields with the specified names.
+
+The header field names ($field) are not case sensitive and '_'
+can be used as a replacement for '-'.
+
+The return value is the values of the fields removed. In scalar
+context the number of fields removed is returned.
+
+Note that if you pass in multiple field names then it is generally not
+possible to tell which of the returned values belonged to which field.
+
+=item $h->remove_content_headers
+
+This will remove all the header fields used to describe the content of
+a message. All header field names prefixed with C<Content-> falls
+into this category, as well as C<Allow>, C<Expires> and
+C<Last-Modified>. RFC 2616 denote these fields as I<Entity Header
+Fields>.
+
+The return value is a new C<HTTP::Headers> object that contains the
+removed headers only.
+
+=item $h->clear
+
+This will remove all header fields.
+
+=item $h->header_field_names
+
+Returns the list of distinct names for the fields present in the
+header. The field names have case as suggested by HTTP spec, and the
+names are returned in the recommended "Good Practice" order.
+
+In scalar context return the number of distinct field names.
+
+=item $h->scan( \&process_header_field )
+
+Apply a subroutine to each header field in turn. The callback routine
+is called with two parameters; the name of the field and a single
+value (a string). If a header field is multi-valued, then the
+routine is called once for each value. The field name passed to the
+callback routine has case as suggested by HTTP spec, and the headers
+will be visited in the recommended "Good Practice" order.
+
+Any return values of the callback routine are ignored. The loop can
+be broken by raising an exception (C<die>), but the caller of scan()
+would have to trap the exception itself.
+
+=item $h->as_string
+
+=item $h->as_string( $eol )
+
+Return the header fields as a formatted MIME header. Since it
+internally uses the C<scan> method to build the string, the result
+will use case as suggested by HTTP spec, and it will follow
+recommended "Good Practice" of ordering the header fields. Long header
+values are not folded.
+
+The optional $eol parameter specifies the line ending sequence to
+use. The default is "\n". Embedded "\n" characters in header field
+values will be substituted with this line ending sequence.
+
+=back
+
+=head1 CONVENIENCE METHODS
+
+The most frequently used headers can also be accessed through the
+following convenience Methods. Most of these methods can both be used to read
+and to set the value of a header. The header value is set if you pass
+an argument to the method. The old header value is always returned.
+If the given header did not exist then C<undef> is returned.
+
+Methods that deal with dates/times always convert their value to system
+time (seconds since Jan 1, 1970) and they also expect this kind of
+value when the header value is set.
+
+=over 4
+
+=item $h->date
+
+This header represents the date and time at which the message was
+originated. I<E.g.>:
+
+ $h->date(time); # set current date
+
+=item $h->expires
+
+This header gives the date and time after which the entity should be
+considered stale.
+
+=item $h->if_modified_since
+
+=item $h->if_unmodified_since
+
+These header fields are used to make a request conditional. If the requested
+resource has (or has not) been modified since the time specified in this field,
+then the server will return a C<304 Not Modified> response instead of
+the document itself.
+
+=item $h->last_modified
+
+This header indicates the date and time at which the resource was last
+modified. I<E.g.>:
+
+ # check if document is more than 1 hour old
+ if (my $last_mod = $h->last_modified) {
+ if ($last_mod < time - 60*60) {
+ ...
+ }
+ }
+
+=item $h->content_type
+
+The Content-Type header field indicates the media type of the message
+content. I<E.g.>:
+
+ $h->content_type('text/html');
+
+The value returned will be converted to lower case, and potential
+parameters will be chopped off and returned as a separate value if in
+an array context. If there is no such header field, then the empty
+string is returned. This makes it safe to do the following:
+
+ if ($h->content_type eq 'text/html') {
+ # we enter this place even if the real header value happens to
+ # be 'TEXT/HTML; version=3.0'
+ ...
+ }
+
+=item $h->content_type_charset
+
+Returns the upper-cased charset specified in the Content-Type header. In list
+context return the lower-cased bare content type followed by the upper-cased
+charset. Both values will be C<undef> if not specified in the header.
+
+=item $h->content_is_text
+
+Returns TRUE if the Content-Type header field indicate that the
+content is textual.
+
+=item $h->content_is_html
+
+Returns TRUE if the Content-Type header field indicate that the
+content is some kind of HTML (including XHTML). This method can't be
+used to set Content-Type.
+
+=item $h->content_is_xhtml
+
+Returns TRUE if the Content-Type header field indicate that the
+content is XHTML. This method can't be used to set Content-Type.
+
+=item $h->content_is_xml
+
+Returns TRUE if the Content-Type header field indicate that the
+content is XML. This method can't be used to set Content-Type.
+
+=item $h->content_encoding
+
+The Content-Encoding header field is used as a modifier to the
+media type. When present, its value indicates what additional
+encoding mechanism has been applied to the resource.
+
+=item $h->content_length
+
+A decimal number indicating the size in bytes of the message content.
+
+=item $h->content_language
+
+The natural language(s) of the intended audience for the message
+content. The value is one or more language tags as defined by RFC
+1766. Eg. "no" for some kind of Norwegian and "en-US" for English the
+way it is written in the US.
+
+=item $h->title
+
+The title of the document. In libwww-perl this header will be
+initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
+of HTML documents. I<This header is no longer part of the HTTP
+standard.>
+
+=item $h->user_agent
+
+This header field is used in request messages and contains information
+about the user agent originating the request. I<E.g.>:
+
+ $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
+
+=item $h->server
+
+The server header field contains information about the software being
+used by the originating server program handling the request.
+
+=item $h->from
+
+This header should contain an Internet e-mail address for the human
+user who controls the requesting user agent. The address should be
+machine-usable, as defined by RFC822. E.g.:
+
+ $h->from('King Kong <king@kong.com>');
+
+I<This header is no longer part of the HTTP standard.>
+
+=item $h->referer
+
+Used to specify the address (URI) of the document from which the
+requested resource address was obtained.
+
+The "Free On-line Dictionary of Computing" as this to say about the
+word I<referer>:
+
+ <World-Wide Web> A misspelling of "referrer" which
+ somehow made it into the {HTTP} standard. A given {web
+ page}'s referer (sic) is the {URL} of whatever web page
+ contains the link that the user followed to the current
+ page. Most browsers pass this information as part of a
+ request.
+
+ (1998-10-19)
+
+By popular demand C<referrer> exists as an alias for this method so you
+can avoid this misspelling in your programs and still send the right
+thing on the wire.
+
+When setting the referrer, this method removes the fragment from the
+given URI if it is present, as mandated by RFC2616. Note that
+the removal does I<not> happen automatically if using the header(),
+push_header() or init_header() methods to set the referrer.
+
+=item $h->www_authenticate
+
+This header must be included as part of a C<401 Unauthorized> response.
+The field value consist of a challenge that indicates the
+authentication scheme and parameters applicable to the requested URI.
+
+=item $h->proxy_authenticate
+
+This header must be included in a C<407 Proxy Authentication Required>
+response.
+
+=item $h->authorization
+
+=item $h->proxy_authorization
+
+A user agent that wishes to authenticate itself with a server or a
+proxy, may do so by including these headers.
+
+=item $h->authorization_basic
+
+This method is used to get or set an authorization header that use the
+"Basic Authentication Scheme". In array context it will return two
+values; the user name and the password. In scalar context it will
+return I<"uname:password"> as a single string value.
+
+When used to set the header value, it expects two arguments. I<E.g.>:
+
+ $h->authorization_basic($uname, $password);
+
+The method will croak if the $uname contains a colon ':'.
+
+=item $h->proxy_authorization_basic
+
+Same as authorization_basic() but will set the "Proxy-Authorization"
+header instead.
+
+=back
+
+=head1 NON-CANONICALIZED FIELD NAMES
+
+The header field name spelling is normally canonicalized including the
+'_' to '-' translation. There are some application where this is not
+appropriate. Prefixing field names with ':' allow you to force a
+specific spelling. For example if you really want a header field name
+to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
+this:
+
+ $h->header(":foo_bar" => 1);
+
+These field names are returned with the ':' intact for
+$h->header_field_names and the $h->scan callback, but the colons do
+not show in $h->as_string.
+
+=head1 COPYRIGHT
+
+Copyright 1995-2005 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/Auth.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/Auth.pm
new file mode 100755
index 00000000000..1e416e2dd9a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/Auth.pm
@@ -0,0 +1,98 @@
+package HTTP::Headers::Auth;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "5.817";
+
+use HTTP::Headers;
+
+package HTTP::Headers;
+
+BEGIN {
+ # we provide a new (and better) implementations below
+ undef(&www_authenticate);
+ undef(&proxy_authenticate);
+}
+
+require HTTP::Headers::Util;
+
+sub _parse_authenticate
+{
+ my @ret;
+ for (HTTP::Headers::Util::split_header_words(@_)) {
+ if (!defined($_->[1])) {
+ # this is a new auth scheme
+ push(@ret, shift(@$_) => {});
+ shift @$_;
+ }
+ if (@ret) {
+ # this a new parameter pair for the last auth scheme
+ while (@$_) {
+ my $k = shift @$_;
+ my $v = shift @$_;
+ $ret[-1]{$k} = $v;
+ }
+ }
+ else {
+ # something wrong, parameter pair without any scheme seen
+ # IGNORE
+ }
+ }
+ @ret;
+}
+
+sub _authenticate
+{
+ my $self = shift;
+ my $header = shift;
+ my @old = $self->_header($header);
+ if (@_) {
+ $self->remove_header($header);
+ my @new = @_;
+ while (@new) {
+ my $a_scheme = shift(@new);
+ if ($a_scheme =~ /\s/) {
+ # assume complete valid value, pass it through
+ $self->push_header($header, $a_scheme);
+ }
+ else {
+ my @param;
+ if (@new) {
+ my $p = $new[0];
+ if (ref($p) eq "ARRAY") {
+ @param = @$p;
+ shift(@new);
+ }
+ elsif (ref($p) eq "HASH") {
+ @param = %$p;
+ shift(@new);
+ }
+ }
+ my $val = ucfirst(lc($a_scheme));
+ if (@param) {
+ my $sep = " ";
+ while (@param) {
+ my $k = shift @param;
+ my $v = shift @param;
+ if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
+ # must quote the value
+ $v =~ s,([\\\"]),\\$1,g;
+ $v = qq("$v");
+ }
+ $val .= "$sep$k=$v";
+ $sep = ", ";
+ }
+ }
+ $self->push_header($header, $val);
+ }
+ }
+ }
+ return unless defined wantarray;
+ wantarray ? _parse_authenticate(@old) : join(", ", @old);
+}
+
+
+sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) }
+sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/ETag.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/ETag.pm
new file mode 100755
index 00000000000..743da463de4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/ETag.pm
@@ -0,0 +1,94 @@
+package HTTP::Headers::ETag;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "5.810";
+
+require HTTP::Date;
+
+require HTTP::Headers;
+package HTTP::Headers;
+
+sub _etags
+{
+ my $self = shift;
+ my $header = shift;
+ my @old = _split_etag_list($self->_header($header));
+ if (@_) {
+ $self->_header($header => join(", ", _split_etag_list(@_)));
+ }
+ wantarray ? @old : join(", ", @old);
+}
+
+sub etag { shift->_etags("ETag", @_); }
+sub if_match { shift->_etags("If-Match", @_); }
+sub if_none_match { shift->_etags("If-None-Match", @_); }
+
+sub if_range {
+ # Either a date or an entity-tag
+ my $self = shift;
+ my @old = $self->_header("If-Range");
+ if (@_) {
+ my $new = shift;
+ if (!defined $new) {
+ $self->remove_header("If-Range");
+ }
+ elsif ($new =~ /^\d+$/) {
+ $self->_date_header("If-Range", $new);
+ }
+ else {
+ $self->_etags("If-Range", $new);
+ }
+ }
+ return unless defined(wantarray);
+ for (@old) {
+ my $t = HTTP::Date::str2time($_);
+ $_ = $t if $t;
+ }
+ wantarray ? @old : join(", ", @old);
+}
+
+
+# Split a list of entity tag values. The return value is a list
+# consisting of one element per entity tag. Suitable for parsing
+# headers like C<If-Match>, C<If-None-Match>. You might even want to
+# use it on C<ETag> and C<If-Range> entity tag values, because it will
+# normalize them to the common form.
+#
+# entity-tag = [ weak ] opaque-tag
+# weak = "W/"
+# opaque-tag = quoted-string
+
+
+sub _split_etag_list
+{
+ my(@val) = @_;
+ my @res;
+ for (@val) {
+ while (length) {
+ my $weak = "";
+ $weak = "W/" if s,^\s*[wW]/,,;
+ my $etag = "";
+ if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
+ push(@res, "$weak$1");
+ }
+ elsif (s/^\s*,//) {
+ push(@res, qq(W/"")) if $weak;
+ }
+ elsif (s/^\s*([^,\s]+)//) {
+ $etag = $1;
+ $etag =~ s/([\"\\])/\\$1/g;
+ push(@res, qq($weak"$etag"));
+ }
+ elsif (s/^\s+// || !length) {
+ push(@res, qq(W/"")) if $weak;
+ }
+ else {
+ die "This should not happen: '$_'";
+ }
+ }
+ }
+ @res;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/Util.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/Util.pm
new file mode 100755
index 00000000000..9ae65e7faf5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Headers/Util.pm
@@ -0,0 +1,199 @@
+package HTTP::Headers::Util;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = "5.817";
+
+require Exporter;
+@ISA=qw(Exporter);
+
+@EXPORT_OK=qw(split_header_words _split_header_words join_header_words);
+
+
+
+sub split_header_words {
+ my @res = &_split_header_words;
+ for my $arr (@res) {
+ for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
+ $arr->[$i] = lc($arr->[$i]);
+ }
+ }
+ return @res;
+}
+
+sub _split_header_words
+{
+ my(@val) = @_;
+ my @res;
+ for (@val) {
+ my @cur;
+ while (length) {
+ if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
+ push(@cur, $1);
+ # a quoted value
+ if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
+ my $val = $1;
+ $val =~ s/\\(.)/$1/g;
+ push(@cur, $val);
+ # some unquoted value
+ }
+ elsif (s/^\s*=\s*([^;,\s]*)//) {
+ my $val = $1;
+ $val =~ s/\s+$//;
+ push(@cur, $val);
+ # no value, a lone token
+ }
+ else {
+ push(@cur, undef);
+ }
+ }
+ elsif (s/^\s*,//) {
+ push(@res, [@cur]) if @cur;
+ @cur = ();
+ }
+ elsif (s/^\s*;// || s/^\s+//) {
+ # continue
+ }
+ else {
+ die "This should not happen: '$_'";
+ }
+ }
+ push(@res, \@cur) if @cur;
+ }
+ @res;
+}
+
+
+sub join_header_words
+{
+ @_ = ([@_]) if @_ && !ref($_[0]);
+ my @res;
+ for (@_) {
+ my @cur = @$_;
+ my @attr;
+ while (@cur) {
+ my $k = shift @cur;
+ my $v = shift @cur;
+ if (defined $v) {
+ if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
+ $v =~ s/([\"\\])/\\$1/g; # escape " and \
+ $k .= qq(="$v");
+ }
+ else {
+ # token
+ $k .= "=$v";
+ }
+ }
+ push(@attr, $k);
+ }
+ push(@res, join("; ", @attr)) if @attr;
+ }
+ join(", ", @res);
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Headers::Util - Header value parsing utility functions
+
+=head1 SYNOPSIS
+
+ use HTTP::Headers::Util qw(split_header_words);
+ @values = split_header_words($h->header("Content-Type"));
+
+=head1 DESCRIPTION
+
+This module provides a few functions that helps parsing and
+construction of valid HTTP header values. None of the functions are
+exported by default.
+
+The following functions are available:
+
+=over 4
+
+
+=item split_header_words( @header_values )
+
+This function will parse the header values given as argument into a
+list of anonymous arrays containing key/value pairs. The function
+knows how to deal with ",", ";" and "=" as well as quoted values after
+"=". A list of space separated tokens are parsed as if they were
+separated by ";".
+
+If the @header_values passed as argument contains multiple values,
+then they are treated as if they were a single value separated by
+comma ",".
+
+This means that this function is useful for parsing header fields that
+follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
+the requirement for tokens).
+
+ headers = #header
+ header = (token | parameter) *( [";"] (token | parameter))
+
+ token = 1*<any CHAR except CTLs or separators>
+ separators = "(" | ")" | "<" | ">" | "@"
+ | "," | ";" | ":" | "\" | <">
+ | "/" | "[" | "]" | "?" | "="
+ | "{" | "}" | SP | HT
+
+ quoted-string = ( <"> *(qdtext | quoted-pair ) <"> )
+ qdtext = <any TEXT except <">>
+ quoted-pair = "\" CHAR
+
+ parameter = attribute "=" value
+ attribute = token
+ value = token | quoted-string
+
+Each I<header> is represented by an anonymous array of key/value
+pairs. The keys will be all be forced to lower case.
+The value for a simple token (not part of a parameter) is C<undef>.
+Syntactically incorrect headers will not necessary be parsed as you
+would want.
+
+This is easier to describe with some examples:
+
+ split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
+ split_header_words('text/html; charset="iso-8859-1"');
+ split_header_words('Basic realm="\\"foo\\\\bar\\""');
+
+will return
+
+ [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
+ ['text/html' => undef, charset => 'iso-8859-1']
+ [basic => undef, realm => "\"foo\\bar\""]
+
+If you don't want the function to convert tokens and attribute keys to
+lower case you can call it as C<_split_header_words> instead (with a
+leading underscore).
+
+=item join_header_words( @arrays )
+
+This will do the opposite of the conversion done by split_header_words().
+It takes a list of anonymous arrays as arguments (or a list of
+key/value pairs) and produces a single header value. Attribute values
+are quoted if needed.
+
+Example:
+
+ join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
+ join_header_words("text/plain" => undef, charset => "iso-8859/1");
+
+will both return the string:
+
+ text/plain; charset="iso-8859/1"
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 1997-1998, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Message.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Message.pm
new file mode 100755
index 00000000000..14a150f0a84
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Message.pm
@@ -0,0 +1,1073 @@
+package HTTP::Message;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD);
+$VERSION = "5.834";
+
+require HTTP::Headers;
+require Carp;
+
+my $CRLF = "\015\012"; # "\r\n" is not portable
+$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
+eval "require $HTTP::URI_CLASS"; die $@ if $@;
+
+*_utf8_downgrade = defined(&utf8::downgrade) ?
+ sub {
+ utf8::downgrade($_[0], 1) or
+ Carp::croak("HTTP::Message content must be bytes")
+ }
+ :
+ sub {
+ };
+
+sub new
+{
+ my($class, $header, $content) = @_;
+ if (defined $header) {
+ Carp::croak("Bad header argument") unless ref $header;
+ if (ref($header) eq "ARRAY") {
+ $header = HTTP::Headers->new(@$header);
+ }
+ else {
+ $header = $header->clone;
+ }
+ }
+ else {
+ $header = HTTP::Headers->new;
+ }
+ if (defined $content) {
+ _utf8_downgrade($content);
+ }
+ else {
+ $content = '';
+ }
+
+ bless {
+ '_headers' => $header,
+ '_content' => $content,
+ }, $class;
+}
+
+
+sub parse
+{
+ my($class, $str) = @_;
+
+ my @hdr;
+ while (1) {
+ if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
+ push(@hdr, $1, $2);
+ $hdr[-1] =~ s/\r\z//;
+ }
+ elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
+ $hdr[-1] .= "\n$1";
+ $hdr[-1] =~ s/\r\z//;
+ }
+ else {
+ $str =~ s/^\r?\n//;
+ last;
+ }
+ }
+ local $HTTP::Headers::TRANSLATE_UNDERSCORE;
+ new($class, \@hdr, $str);
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $clone = HTTP::Message->new($self->headers,
+ $self->content);
+ $clone->protocol($self->protocol);
+ $clone;
+}
+
+
+sub clear {
+ my $self = shift;
+ $self->{_headers}->clear;
+ $self->content("");
+ delete $self->{_parts};
+ return;
+}
+
+
+sub protocol {
+ shift->_elem('_protocol', @_);
+}
+
+sub headers {
+ my $self = shift;
+
+ # recalculation of _content might change headers, so we
+ # need to force it now
+ $self->_content unless exists $self->{_content};
+
+ $self->{_headers};
+}
+
+sub headers_as_string {
+ shift->headers->as_string(@_);
+}
+
+
+sub content {
+
+ my $self = $_[0];
+ if (defined(wantarray)) {
+ $self->_content unless exists $self->{_content};
+ my $old = $self->{_content};
+ $old = $$old if ref($old) eq "SCALAR";
+ &_set_content if @_ > 1;
+ return $old;
+ }
+
+ if (@_ > 1) {
+ &_set_content;
+ }
+ else {
+ Carp::carp("Useless content call in void context") if $^W;
+ }
+}
+
+
+sub _set_content {
+ my $self = $_[0];
+ _utf8_downgrade($_[1]);
+ if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
+ ${$self->{_content}} = $_[1];
+ }
+ else {
+ die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
+ $self->{_content} = $_[1];
+ delete $self->{_content_ref};
+ }
+ delete $self->{_parts} unless $_[2];
+}
+
+
+sub add_content
+{
+ my $self = shift;
+ $self->_content unless exists $self->{_content};
+ my $chunkref = \$_[0];
+ $chunkref = $$chunkref if ref($$chunkref); # legacy
+
+ _utf8_downgrade($$chunkref);
+
+ my $ref = ref($self->{_content});
+ if (!$ref) {
+ $self->{_content} .= $$chunkref;
+ }
+ elsif ($ref eq "SCALAR") {
+ ${$self->{_content}} .= $$chunkref;
+ }
+ else {
+ Carp::croak("Can't append to $ref content");
+ }
+ delete $self->{_parts};
+}
+
+sub add_content_utf8 {
+ my($self, $buf) = @_;
+ utf8::upgrade($buf);
+ utf8::encode($buf);
+ $self->add_content($buf);
+}
+
+sub content_ref
+{
+ my $self = shift;
+ $self->_content unless exists $self->{_content};
+ delete $self->{_parts};
+ my $old = \$self->{_content};
+ my $old_cref = $self->{_content_ref};
+ if (@_) {
+ my $new = shift;
+ Carp::croak("Setting content_ref to a non-ref") unless ref($new);
+ delete $self->{_content}; # avoid modifying $$old
+ $self->{_content} = $new;
+ $self->{_content_ref}++;
+ }
+ $old = $$old if $old_cref;
+ return $old;
+}
+
+
+sub content_charset
+{
+ my $self = shift;
+ if (my $charset = $self->content_type_charset) {
+ return $charset;
+ }
+
+ # time to start guessing
+ my $cref = $self->decoded_content(ref => 1, charset => "none");
+
+ # Unicode BOM
+ local $_;
+ for ($$cref) {
+ return "UTF-8" if /^\xEF\xBB\xBF/;
+ return "UTF-32-LE" if /^\xFF\xFE\x00\x00/;
+ return "UTF-32-BE" if /^\x00\x00\xFE\xFF/;
+ return "UTF-16-LE" if /^\xFF\xFE/;
+ return "UTF-16-BE" if /^\xFE\xFF/;
+ }
+
+ if ($self->content_is_xml) {
+ # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
+ # XML entity not accompanied by external encoding information and not
+ # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
+ # in which the first characters must be '<?xml'
+ for ($$cref) {
+ return "UTF-32-BE" if /^\x00\x00\x00</;
+ return "UTF-32-LE" if /^<\x00\x00\x00/;
+ return "UTF-16-BE" if /^(?:\x00\s)*\x00</;
+ return "UTF-16-LE" if /^(?:\s\x00)*<\x00/;
+ if (/^\s*(<\?xml[^\x00]*?\?>)/) {
+ if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
+ my $enc = $2;
+ $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
+ return $enc if $enc;
+ }
+ }
+ }
+ return "UTF-8";
+ }
+ elsif ($self->content_is_html) {
+ # look for <META charset="..."> or <META content="...">
+ # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
+ my $charset;
+ require HTML::Parser;
+ my $p = HTML::Parser->new(
+ start_h => [sub {
+ my($tag, $attr, $self) = @_;
+ $charset = $attr->{charset};
+ unless ($charset) {
+ # look at $attr->{content} ...
+ if (my $c = $attr->{content}) {
+ require HTTP::Headers::Util;
+ my @v = HTTP::Headers::Util::split_header_words($c);
+ return unless @v;
+ my($ct, undef, %ct_param) = @{$v[0]};
+ $charset = $ct_param{charset};
+ }
+ return unless $charset;
+ }
+ if ($charset =~ /^utf-?16/i) {
+ # converted document, assume UTF-8
+ $charset = "UTF-8";
+ }
+ $self->eof;
+ }, "tagname, attr, self"],
+ report_tags => [qw(meta)],
+ utf8_mode => 1,
+ );
+ $p->parse($$cref);
+ return $charset if $charset;
+ }
+ if ($self->content_type =~ /^text\//) {
+ for ($$cref) {
+ if (length) {
+ return "US-ASCII" unless /[\x80-\xFF]/;
+ require Encode;
+ eval {
+ Encode::decode_utf8($_, Encode::FB_CROAK());
+ };
+ return "UTF-8" unless $@;
+ return "ISO-8859-1";
+ }
+ }
+ }
+
+ return undef;
+}
+
+
+sub decoded_content
+{
+ my($self, %opt) = @_;
+ my $content_ref;
+ my $content_ref_iscopy;
+
+ eval {
+ $content_ref = $self->content_ref;
+ die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
+
+ if (my $h = $self->header("Content-Encoding")) {
+ $h =~ s/^\s+//;
+ $h =~ s/\s+$//;
+ for my $ce (reverse split(/\s*,\s*/, lc($h))) {
+ next unless $ce;
+ next if $ce eq "identity";
+ if ($ce eq "gzip" || $ce eq "x-gzip") {
+ require IO::Uncompress::Gunzip;
+ my $output;
+ IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
+ or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
+ $content_ref = \$output;
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "x-bzip2") {
+ require IO::Uncompress::Bunzip2;
+ my $output;
+ IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
+ or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
+ $content_ref = \$output;
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "deflate") {
+ require IO::Uncompress::Inflate;
+ my $output;
+ my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
+ my $error = $IO::Uncompress::Inflate::InflateError;
+ unless ($status) {
+ # "Content-Encoding: deflate" is supposed to mean the
+ # "zlib" format of RFC 1950, but Microsoft got that
+ # wrong, so some servers sends the raw compressed
+ # "deflate" data. This tries to inflate this format.
+ $output = undef;
+ require IO::Uncompress::RawInflate;
+ unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
+ $self->push_header("Client-Warning" =>
+ "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
+ $output = undef;
+ }
+ }
+ die "Can't inflate content: $error" unless defined $output;
+ $content_ref = \$output;
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "compress" || $ce eq "x-compress") {
+ die "Can't uncompress content";
+ }
+ elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
+ require MIME::Base64;
+ $content_ref = \MIME::Base64::decode($$content_ref);
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
+ require MIME::QuotedPrint;
+ $content_ref = \MIME::QuotedPrint::decode($$content_ref);
+ $content_ref_iscopy++;
+ }
+ else {
+ die "Don't know how to decode Content-Encoding '$ce'";
+ }
+ }
+ }
+
+ if ($self->content_is_text || $self->content_is_xml) {
+ my $charset = lc(
+ $opt{charset} ||
+ $self->content_type_charset ||
+ $opt{default_charset} ||
+ $self->content_charset ||
+ "ISO-8859-1"
+ );
+ unless ($charset =~ /^(?:none|us-ascii|iso-8859-1)\z/) {
+ require Encode;
+ if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 &&
+ !$content_ref_iscopy)
+ {
+ # LEAVE_SRC did not work before Encode-2.0901
+ my $copy = $$content_ref;
+ $content_ref = \$copy;
+ $content_ref_iscopy++;
+ }
+ $content_ref = \Encode::decode($charset, $$content_ref,
+ ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
+ die "Encode::decode() returned undef improperly" unless defined $$content_ref;
+ }
+ }
+ };
+ if ($@) {
+ Carp::croak($@) if $opt{raise_error};
+ return undef;
+ }
+
+ return $opt{ref} ? $content_ref : $$content_ref;
+}
+
+
+sub decodable
+{
+ # should match the Content-Encoding values that decoded_content can deal with
+ my $self = shift;
+ my @enc;
+ # XXX preferably we should determine if the modules are available without loading
+ # them here
+ eval {
+ require IO::Uncompress::Gunzip;
+ push(@enc, "gzip", "x-gzip");
+ };
+ eval {
+ require IO::Uncompress::Inflate;
+ require IO::Uncompress::RawInflate;
+ push(@enc, "deflate");
+ };
+ eval {
+ require IO::Uncompress::Bunzip2;
+ push(@enc, "x-bzip2");
+ };
+ # we don't care about announcing the 'identity', 'base64' and
+ # 'quoted-printable' stuff
+ return wantarray ? @enc : join(", ", @enc);
+}
+
+
+sub decode
+{
+ my $self = shift;
+ return 1 unless $self->header("Content-Encoding");
+ if (defined(my $content = $self->decoded_content(charset => "none"))) {
+ $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
+ $self->content($content);
+ return 1;
+ }
+ return 0;
+}
+
+
+sub encode
+{
+ my($self, @enc) = @_;
+
+ Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
+ Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
+
+ return 1 unless @enc; # nothing to do
+
+ my $content = $self->content;
+ for my $encoding (@enc) {
+ if ($encoding eq "identity") {
+ # nothing to do
+ }
+ elsif ($encoding eq "base64") {
+ require MIME::Base64;
+ $content = MIME::Base64::encode($content);
+ }
+ elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
+ require IO::Compress::Gzip;
+ my $output;
+ IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
+ or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
+ $content = $output;
+ }
+ elsif ($encoding eq "deflate") {
+ require IO::Compress::Deflate;
+ my $output;
+ IO::Compress::Deflate::deflate(\$content, \$output)
+ or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
+ $content = $output;
+ }
+ elsif ($encoding eq "x-bzip2") {
+ require IO::Compress::Bzip2;
+ my $output;
+ IO::Compress::Bzip2::bzip2(\$content, \$output)
+ or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
+ $content = $output;
+ }
+ elsif ($encoding eq "rot13") { # for the fun of it
+ $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
+ }
+ else {
+ return 0;
+ }
+ }
+ my $h = $self->header("Content-Encoding");
+ unshift(@enc, $h) if $h;
+ $self->header("Content-Encoding", join(", ", @enc));
+ $self->remove_header("Content-Length", "Content-MD5");
+ $self->content($content);
+ return 1;
+}
+
+
+sub as_string
+{
+ my($self, $eol) = @_;
+ $eol = "\n" unless defined $eol;
+
+ # The calculation of content might update the headers
+ # so we need to do that first.
+ my $content = $self->content;
+
+ return join("", $self->{'_headers'}->as_string($eol),
+ $eol,
+ $content,
+ (@_ == 1 && length($content) &&
+ $content !~ /\n\z/) ? "\n" : "",
+ );
+}
+
+
+sub dump
+{
+ my($self, %opt) = @_;
+ my $content = $self->content;
+ my $chopped = 0;
+ if (!ref($content)) {
+ my $maxlen = $opt{maxlength};
+ $maxlen = 512 unless defined($maxlen);
+ if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
+ $chopped = length($content) - $maxlen;
+ $content = substr($content, 0, $maxlen) . "...";
+ }
+
+ $content =~ s/\\/\\\\/g;
+ $content =~ s/\t/\\t/g;
+ $content =~ s/\r/\\r/g;
+
+ # no need for 3 digits in escape for these
+ $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+
+ $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+ $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
+
+ # remaining whitespace
+ $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
+ $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
+ $content =~ s/\n\z/\\n/;
+
+ my $no_content = "(no content)";
+ if ($content eq $no_content) {
+ # escape our $no_content marker
+ $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
+ }
+ elsif ($content eq "") {
+ $content = "(no content)";
+ }
+ }
+
+ my @dump;
+ push(@dump, $opt{preheader}) if $opt{preheader};
+ push(@dump, $self->{_headers}->as_string, $content);
+ push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
+
+ my $dump = join("\n", @dump, "");
+ $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
+
+ print $dump unless defined wantarray;
+ return $dump;
+}
+
+
+sub parts {
+ my $self = shift;
+ if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
+ $self->_parts;
+ }
+ my $old = $self->{_parts};
+ if (@_) {
+ my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
+ my $ct = $self->content_type || "";
+ if ($ct =~ m,^message/,) {
+ Carp::croak("Only one part allowed for $ct content")
+ if @parts > 1;
+ }
+ elsif ($ct !~ m,^multipart/,) {
+ $self->remove_content_headers;
+ $self->content_type("multipart/mixed");
+ }
+ $self->{_parts} = \@parts;
+ _stale_content($self);
+ }
+ return @$old if wantarray;
+ return $old->[0];
+}
+
+sub add_part {
+ my $self = shift;
+ if (($self->content_type || "") !~ m,^multipart/,) {
+ my $p = HTTP::Message->new($self->remove_content_headers,
+ $self->content(""));
+ $self->content_type("multipart/mixed");
+ $self->{_parts} = [];
+ if ($p->headers->header_field_names || $p->content ne "") {
+ push(@{$self->{_parts}}, $p);
+ }
+ }
+ elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
+ $self->_parts;
+ }
+
+ push(@{$self->{_parts}}, @_);
+ _stale_content($self);
+ return;
+}
+
+sub _stale_content {
+ my $self = shift;
+ if (ref($self->{_content}) eq "SCALAR") {
+ # must recalculate now
+ $self->_content;
+ }
+ else {
+ # just invalidate cache
+ delete $self->{_content};
+ delete $self->{_content_ref};
+ }
+}
+
+
+# delegate all other method calls the the headers object.
+sub AUTOLOAD
+{
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+ # We create the function here so that it will not need to be
+ # autoloaded the next time.
+ no strict 'refs';
+ *$method = sub { shift->headers->$method(@_) };
+ goto &$method;
+}
+
+
+sub DESTROY {} # avoid AUTOLOADing it
+
+
+# Private method to access members in %$self
+sub _elem
+{
+ my $self = shift;
+ my $elem = shift;
+ my $old = $self->{$elem};
+ $self->{$elem} = $_[0] if @_;
+ return $old;
+}
+
+
+# Create private _parts attribute from current _content
+sub _parts {
+ my $self = shift;
+ my $ct = $self->content_type;
+ if ($ct =~ m,^multipart/,) {
+ require HTTP::Headers::Util;
+ my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
+ die "Assert" unless @h;
+ my %h = @{$h[0]};
+ if (defined(my $b = $h{boundary})) {
+ my $str = $self->content;
+ $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s;
+ if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
+ $self->{_parts} = [map HTTP::Message->parse($_),
+ split(/\r?\n--\Q$b\E\r?\n/, $str)]
+ }
+ }
+ }
+ elsif ($ct eq "message/http") {
+ require HTTP::Request;
+ require HTTP::Response;
+ my $content = $self->content;
+ my $class = ($content =~ m,^(HTTP/.*)\n,) ?
+ "HTTP::Response" : "HTTP::Request";
+ $self->{_parts} = [$class->parse($content)];
+ }
+ elsif ($ct =~ m,^message/,) {
+ $self->{_parts} = [ HTTP::Message->parse($self->content) ];
+ }
+
+ $self->{_parts} ||= [];
+}
+
+
+# Create private _content attribute from current _parts
+sub _content {
+ my $self = shift;
+ my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
+ if ($ct =~ m,^\s*message/,i) {
+ _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
+ return;
+ }
+
+ require HTTP::Headers::Util;
+ my @v = HTTP::Headers::Util::split_header_words($ct);
+ Carp::carp("Multiple Content-Type headers") if @v > 1;
+ @v = @{$v[0]};
+
+ my $boundary;
+ my $boundary_index;
+ for (my @tmp = @v; @tmp;) {
+ my($k, $v) = splice(@tmp, 0, 2);
+ if ($k eq "boundary") {
+ $boundary = $v;
+ $boundary_index = @v - @tmp - 1;
+ last;
+ }
+ }
+
+ my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
+
+ my $bno = 0;
+ $boundary = _boundary() unless defined $boundary;
+ CHECK_BOUNDARY:
+ {
+ for (@parts) {
+ if (index($_, $boundary) >= 0) {
+ # must have a better boundary
+ $boundary = _boundary(++$bno);
+ redo CHECK_BOUNDARY;
+ }
+ }
+ }
+
+ if ($boundary_index) {
+ $v[$boundary_index] = $boundary;
+ }
+ else {
+ push(@v, boundary => $boundary);
+ }
+
+ $ct = HTTP::Headers::Util::join_header_words(@v);
+ $self->{_headers}->header("Content-Type", $ct);
+
+ _set_content($self, "--$boundary$CRLF" .
+ join("$CRLF--$boundary$CRLF", @parts) .
+ "$CRLF--$boundary--$CRLF",
+ 1);
+}
+
+
+sub _boundary
+{
+ my $size = shift || return "xYzZY";
+ require MIME::Base64;
+ my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
+ $b =~ s/[\W]/X/g; # ensure alnum only
+ $b;
+}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Message - HTTP style message (base class)
+
+=head1 SYNOPSIS
+
+ use base 'HTTP::Message';
+
+=head1 DESCRIPTION
+
+An C<HTTP::Message> object contains some headers and a content body.
+The following methods are available:
+
+=over 4
+
+=item $mess = HTTP::Message->new
+
+=item $mess = HTTP::Message->new( $headers )
+
+=item $mess = HTTP::Message->new( $headers, $content )
+
+This constructs a new message object. Normally you would want
+construct C<HTTP::Request> or C<HTTP::Response> objects instead.
+
+The optional $header argument should be a reference to an
+C<HTTP::Headers> object or a plain array reference of key/value pairs.
+If an C<HTTP::Headers> object is provided then a copy of it will be
+embedded into the constructed message, i.e. it will not be owned and
+can be modified afterwards without affecting the message.
+
+The optional $content argument should be a string of bytes.
+
+=item $mess = HTTP::Message->parse( $str )
+
+This constructs a new message object by parsing the given string.
+
+=item $mess->headers
+
+Returns the embedded C<HTTP::Headers> object.
+
+=item $mess->headers_as_string
+
+=item $mess->headers_as_string( $eol )
+
+Call the as_string() method for the headers in the
+message. This will be the same as
+
+ $mess->headers->as_string
+
+but it will make your program a whole character shorter :-)
+
+=item $mess->content
+
+=item $mess->content( $bytes )
+
+The content() method sets the raw content if an argument is given. If no
+argument is given the content is not touched. In either case the
+original raw content is returned.
+
+Note that the content should be a string of bytes. Strings in perl
+can contain characters outside the range of a byte. The C<Encode>
+module can be used to turn such strings into a string of bytes.
+
+=item $mess->add_content( $bytes )
+
+The add_content() methods appends more data bytes to the end of the
+current content buffer.
+
+=item $mess->add_content_utf8( $string )
+
+The add_content_utf8() method appends the UTF-8 bytes representing the
+string to the end of the current content buffer.
+
+=item $mess->content_ref
+
+=item $mess->content_ref( \$bytes )
+
+The content_ref() method will return a reference to content buffer string.
+It can be more efficient to access the content this way if the content
+is huge, and it can even be used for direct manipulation of the content,
+for instance:
+
+ ${$res->content_ref} =~ s/\bfoo\b/bar/g;
+
+This example would modify the content buffer in-place.
+
+If an argument is passed it will setup the content to reference some
+external source. The content() and add_content() methods
+will automatically dereference scalar references passed this way. For
+other references content() will return the reference itself and
+add_content() will refuse to do anything.
+
+=item $mess->content_charset
+
+This returns the charset used by the content in the message. The
+charset is either found as the charset attribute of the
+C<Content-Type> header or by guessing.
+
+See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
+for details about how charset is determined.
+
+=item $mess->decoded_content( %options )
+
+Returns the content with any C<Content-Encoding> undone and the raw
+content encoded to perl's Unicode strings. If the C<Content-Encoding>
+or C<charset> of the message is unknown this method will fail by
+returning C<undef>.
+
+The following options can be specified.
+
+=over
+
+=item C<charset>
+
+This override the charset parameter for text content. The value
+C<none> can used to suppress decoding of the charset.
+
+=item C<default_charset>
+
+This override the default charset guessed by content_charset() or
+if that fails "ISO-8859-1".
+
+=item C<charset_strict>
+
+Abort decoding if malformed characters is found in the content. By
+default you get the substitution character ("\x{FFFD}") in place of
+malformed characters.
+
+=item C<raise_error>
+
+If TRUE then raise an exception if not able to decode content. Reason
+might be that the specified C<Content-Encoding> or C<charset> is not
+supported. If this option is FALSE, then decoded_content() will return
+C<undef> on errors, but will still set $@.
+
+=item C<ref>
+
+If TRUE then a reference to decoded content is returned. This might
+be more efficient in cases where the decoded content is identical to
+the raw content as no data copying is required in this case.
+
+=back
+
+=item $mess->decodable
+
+=item HTTP::Message::decodable()
+
+This returns the encoding identifiers that decoded_content() can
+process. In scalar context returns a comma separated string of
+identifiers.
+
+This value is suitable for initializing the C<Accept-Encoding> request
+header field.
+
+=item $mess->decode
+
+This method tries to replace the content of the message with the
+decoded version and removes the C<Content-Encoding> header. Returns
+TRUE if successful and FALSE if not.
+
+If the message does not have a C<Content-Encoding> header this method
+does nothing and returns TRUE.
+
+Note that the content of the message is still bytes after this method
+has been called and you still need to call decoded_content() if you
+want to process its content as a string.
+
+=item $mess->encode( $encoding, ... )
+
+Apply the given encodings to the content of the message. Returns TRUE
+if successful. The "identity" (non-)encoding is always supported; other
+currently supported encodings, subject to availability of required
+additional modules, are "gzip", "deflate", "x-bzip2" and "base64".
+
+A successful call to this function will set the C<Content-Encoding>
+header.
+
+Note that C<multipart/*> or C<message/*> messages can't be encoded and
+this method will croak if you try.
+
+=item $mess->parts
+
+=item $mess->parts( @parts )
+
+=item $mess->parts( \@parts )
+
+Messages can be composite, i.e. contain other messages. The composite
+messages have a content type of C<multipart/*> or C<message/*>. This
+method give access to the contained messages.
+
+The argumentless form will return a list of C<HTTP::Message> objects.
+If the content type of $msg is not C<multipart/*> or C<message/*> then
+this will return the empty list. In scalar context only the first
+object is returned. The returned message parts should be regarded as
+read-only (future versions of this library might make it possible
+to modify the parent by modifying the parts).
+
+If the content type of $msg is C<message/*> then there will only be
+one part returned.
+
+If the content type is C<message/http>, then the return value will be
+either an C<HTTP::Request> or an C<HTTP::Response> object.
+
+If an @parts argument is given, then the content of the message will be
+modified. The array reference form is provided so that an empty list
+can be provided. The @parts array should contain C<HTTP::Message>
+objects. The @parts objects are owned by $mess after this call and
+should not be modified or made part of other messages.
+
+When updating the message with this method and the old content type of
+$mess is not C<multipart/*> or C<message/*>, then the content type is
+set to C<multipart/mixed> and all other content headers are cleared.
+
+This method will croak if the content type is C<message/*> and more
+than one part is provided.
+
+=item $mess->add_part( $part )
+
+This will add a part to a message. The $part argument should be
+another C<HTTP::Message> object. If the previous content type of
+$mess is not C<multipart/*> then the old content (together with all
+content headers) will be made part #1 and the content type made
+C<multipart/mixed> before the new part is added. The $part object is
+owned by $mess after this call and should not be modified or made part
+of other messages.
+
+There is no return value.
+
+=item $mess->clear
+
+Will clear the headers and set the content to the empty string. There
+is no return value
+
+=item $mess->protocol
+
+=item $mess->protocol( $proto )
+
+Sets the HTTP protocol used for the message. The protocol() is a string
+like C<HTTP/1.0> or C<HTTP/1.1>.
+
+=item $mess->clone
+
+Returns a copy of the message object.
+
+=item $mess->as_string
+
+=item $mess->as_string( $eol )
+
+Returns the message formatted as a single string.
+
+The optional $eol parameter specifies the line ending sequence to use.
+The default is "\n". If no $eol is given then as_string will ensure
+that the returned string is newline terminated (even when the message
+content is not). No extra newline is appended if an explicit $eol is
+passed.
+
+=item $mess->dump( %opt )
+
+Returns the message formatted as a string. In void context print the string.
+
+This differs from C<< $mess->as_string >> in that it escapes the bytes
+of the content so that it's safe to print them and it limits how much
+content to print. The escapes syntax used is the same as for Perl's
+double quoted strings. If there is no content the string "(no
+content)" is shown in its place.
+
+Options to influence the output can be passed as key/value pairs. The
+following options are recognized:
+
+=over
+
+=item maxlength => $num
+
+How much of the content to show. The default is 512. Set this to 0
+for unlimited.
+
+If the content is longer then the string is chopped at the limit and
+the string "...\n(### more bytes not shown)" appended.
+
+=item prefix => $str
+
+A string that will be prefixed to each line of the dump.
+
+=back
+
+=back
+
+All methods unknown to C<HTTP::Message> itself are delegated to the
+C<HTTP::Headers> object that is part of every message. This allows
+convenient access to these methods. Refer to L<HTTP::Headers> for
+details of these methods:
+
+ $mess->header( $field => $val )
+ $mess->push_header( $field => $val )
+ $mess->init_header( $field => $val )
+ $mess->remove_header( $field )
+ $mess->remove_content_headers
+ $mess->header_field_names
+ $mess->scan( \&doit )
+
+ $mess->date
+ $mess->expires
+ $mess->if_modified_since
+ $mess->if_unmodified_since
+ $mess->last_modified
+ $mess->content_type
+ $mess->content_encoding
+ $mess->content_length
+ $mess->content_language
+ $mess->title
+ $mess->user_agent
+ $mess->server
+ $mess->from
+ $mess->referer
+ $mess->www_authenticate
+ $mess->authorization
+ $mess->proxy_authorization
+ $mess->authorization_basic
+ $mess->proxy_authorization_basic
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Negotiate.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Negotiate.pm
new file mode 100755
index 00000000000..d3f3bda53c3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Negotiate.pm
@@ -0,0 +1,529 @@
+package HTTP::Negotiate;
+
+$VERSION = "5.813";
+sub Version { $VERSION; }
+
+require 5.002;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(choose);
+
+require HTTP::Headers;
+
+$DEBUG = 0;
+
+sub choose ($;$)
+{
+ my($variants, $request) = @_;
+ my(%accept);
+
+ unless (defined $request) {
+ # Create a request object from the CGI environment variables
+ $request = new HTTP::Headers;
+ $request->header('Accept', $ENV{HTTP_ACCEPT})
+ if $ENV{HTTP_ACCEPT};
+ $request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
+ if $ENV{HTTP_ACCEPT_CHARSET};
+ $request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
+ if $ENV{HTTP_ACCEPT_ENCODING};
+ $request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
+ if $ENV{HTTP_ACCEPT_LANGUAGE};
+ }
+
+ # Get all Accept values from the request. Build a hash initialized
+ # like this:
+ #
+ # %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 },
+ # 'audio/basic' => { q => 1 },
+ # },
+ # language => { 'no' => { q => 1 },
+ # }
+ # );
+
+ $request->scan(sub {
+ my($key, $val) = @_;
+
+ my $type;
+ if ($key =~ s/^Accept-//) {
+ $type = lc($key);
+ }
+ elsif ($key eq "Accept") {
+ $type = "type";
+ }
+ else {
+ return;
+ }
+
+ $val =~ s/\s+//g;
+ my $default_q = 1;
+ for my $name (split(/,/, $val)) {
+ my(%param, $param);
+ if ($name =~ s/;(.*)//) {
+ for $param (split(/;/, $1)) {
+ my ($pk, $pv) = split(/=/, $param, 2);
+ $param{lc $pk} = $pv;
+ }
+ }
+ $name = lc $name;
+ if (defined $param{'q'}) {
+ $param{'q'} = 1 if $param{'q'} > 1;
+ $param{'q'} = 0 if $param{'q'} < 0;
+ }
+ else {
+ $param{'q'} = $default_q;
+
+ # This makes sure that the first ones are slightly better off
+ # and therefore more likely to be chosen.
+ $default_q -= 0.0001;
+ }
+ $accept{$type}{$name} = \%param;
+ }
+ });
+
+ # Check if any of the variants specify a language. We do this
+ # because it influences how we treat those without (they default to
+ # 0.5 instead of 1).
+ my $any_lang = 0;
+ for $var (@$variants) {
+ if ($var->[5]) {
+ $any_lang = 1;
+ last;
+ }
+ }
+
+ if ($DEBUG) {
+ print "Negotiation parameters in the request\n";
+ for $type (keys %accept) {
+ print " $type:\n";
+ for $name (keys %{$accept{$type}}) {
+ print " $name\n";
+ for $pv (keys %{$accept{$type}{$name}}) {
+ print " $pv = $accept{$type}{$name}{$pv}\n";
+ }
+ }
+ }
+ }
+
+ my @Q = (); # This is where we collect the results of the
+ # quality calculations
+
+ # Calculate quality for all the variants that are available.
+ for (@$variants) {
+ my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
+ $qs = 1 unless defined $qs;
+ $ct = '' unless defined $ct;
+ $bs = 0 unless defined $bs;
+ $lang = lc($lang) if $lang; # lg tags are always case-insensitive
+ if ($DEBUG) {
+ print "\nEvaluating $id (ct='$ct')\n";
+ printf " qs = %.3f\n", $qs;
+ print " enc = $enc\n" if $enc && !ref($enc);
+ print " enc = @$enc\n" if $enc && ref($enc);
+ print " cs = $cs\n" if $cs;
+ print " lang = $lang\n" if $lang;
+ print " bs = $bs\n" if $bs;
+ }
+
+ # Calculate encoding quality
+ my $qe = 1;
+ # If the variant has no assigned Content-Encoding, or if no
+ # Accept-Encoding field is present, then the value assigned
+ # is "qe=1". If *all* of the variant's content encodings
+ # are listed in the Accept-Encoding field, then the value
+ # assigned is "qw=1". If *any* of the variant's content
+ # encodings are not listed in the provided Accept-Encoding
+ # field, then the value assigned is "qe=0"
+ if (exists $accept{'encoding'} && $enc) {
+ my @enc = ref($enc) ? @$enc : ($enc);
+ for (@enc) {
+ print "Is encoding $_ accepted? " if $DEBUG;
+ unless(exists $accept{'encoding'}{$_}) {
+ print "no\n" if $DEBUG;
+ $qe = 0;
+ last;
+ }
+ else {
+ print "yes\n" if $DEBUG;
+ }
+ }
+ }
+
+ # Calculate charset quality
+ my $qc = 1;
+ # If the variant's media-type has no charset parameter,
+ # or the variant's charset is US-ASCII, or if no Accept-Charset
+ # field is present, then the value assigned is "qc=1". If the
+ # variant's charset is listed in the Accept-Charset field,
+ # then the value assigned is "qc=1. Otherwise, if the variant's
+ # charset is not listed in the provided Accept-Encoding field,
+ # then the value assigned is "qc=0".
+ if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
+ $qc = 0 unless $accept{'charset'}{$cs};
+ }
+
+ # Calculate language quality
+ my $ql = 1;
+ if ($lang && exists $accept{'language'}) {
+ my @lang = ref($lang) ? @$lang : ($lang);
+ # If any of the variant's content languages are listed
+ # in the Accept-Language field, the the value assigned is
+ # the largest of the "q" parameter values for those language
+ # tags.
+ my $q = undef;
+ for (@lang) {
+ next unless exists $accept{'language'}{$_};
+ my $this_q = $accept{'language'}{$_}{'q'};
+ $q = $this_q unless defined $q;
+ $q = $this_q if $this_q > $q;
+ }
+ if(defined $q) {
+ $DEBUG and print " -- Exact language match at q=$q\n";
+ }
+ else {
+ # If there was no exact match and at least one of
+ # the Accept-Language field values is a complete
+ # subtag prefix of the content language tag(s), then
+ # the "q" parameter value of the largest matching
+ # prefix is used.
+ $DEBUG and print " -- No exact language match\n";
+ my $selected = undef;
+ for $al (keys %{ $accept{'language'} }) {
+ if (index($al, "$lang-") == 0) {
+ # $lang starting with $al isn't enough, or else
+ # Accept-Language: hu (Hungarian) would seem
+ # to accept a document in hup (Hupa)
+ $DEBUG and print " -- $al ISA $lang\n";
+ $selected = $al unless defined $selected;
+ $selected = $al if length($al) > length($selected);
+ }
+ else {
+ $DEBUG and print " -- $lang isn't a $al\n";
+ }
+ }
+ $q = $accept{'language'}{$selected}{'q'} if $selected;
+
+ # If none of the variant's content language tags or
+ # tag prefixes are listed in the provided
+ # Accept-Language field, then the value assigned
+ # is "ql=0.001"
+ $q = 0.001 unless defined $q;
+ }
+ $ql = $q;
+ }
+ else {
+ $ql = 0.5 if $any_lang && exists $accept{'language'};
+ }
+
+ my $q = 1;
+ my $mbx = undef;
+ # If no Accept field is given, then the value assigned is "q=1".
+ # If at least one listed media range matches the variant's media
+ # type, then the "q" parameter value assigned to the most specific
+ # of those matched is used (e.g. "text/html;version=3.0" is more
+ # specific than "text/html", which is more specific than "text/*",
+ # which in turn is more specific than "*/*"). If not media range
+ # in the provided Accept field matches the variant's media type,
+ # then the value assigned is "q=0".
+ if (exists $accept{'type'} && $ct) {
+ # First we clean up our content-type
+ $ct =~ s/\s+//g;
+ my $params = "";
+ $params = $1 if $ct =~ s/;(.*)//;
+ my($type, $subtype) = split("/", $ct, 2);
+ my %param = ();
+ for $param (split(/;/, $params)) {
+ my($pk,$pv) = split(/=/, $param, 2);
+ $param{$pk} = $pv;
+ }
+
+ my $sel_q = undef;
+ my $sel_mbx = undef;
+ my $sel_specificness = 0;
+
+ ACCEPT_TYPE:
+ for $at (keys %{ $accept{'type'} }) {
+ print "Consider $at...\n" if $DEBUG;
+ my($at_type, $at_subtype) = split("/", $at, 2);
+ # Is it a match on the type
+ next if $at_type ne '*' && $at_type ne $type;
+ next if $at_subtype ne '*' && $at_subtype ne $subtype;
+ my $specificness = 0;
+ $specificness++ if $at_type ne '*';
+ $specificness++ if $at_subtype ne '*';
+ # Let's see if content-type parameters also match
+ while (($pk, $pv) = each %param) {
+ print "Check if $pk = $pv is true\n" if $DEBUG;
+ next unless exists $accept{'type'}{$at}{$pk};
+ next ACCEPT_TYPE
+ unless $accept{'type'}{$at}{$pk} eq $pv;
+ print "yes it is!!\n" if $DEBUG;
+ $specificness++;
+ }
+ print "Hurray, type match with specificness = $specificness\n"
+ if $DEBUG;
+
+ if (!defined($sel_q) || $sel_specificness < $specificness) {
+ $sel_q = $accept{'type'}{$at}{'q'};
+ $sel_mbx = $accept{'type'}{$at}{'mbx'};
+ $sel_specificness = $specificness;
+ }
+ }
+ $q = $sel_q || 0;
+ $mbx = $sel_mbx;
+ }
+
+ my $Q;
+ if (!defined($mbx) || $mbx >= $bs) {
+ $Q = $qs * $qe * $qc * $ql * $q;
+ }
+ else {
+ $Q = 0;
+ print "Variant's size is too large ==> Q=0\n" if $DEBUG;
+ }
+
+ if ($DEBUG) {
+ $mbx = "undef" unless defined $mbx;
+ printf "Q=%.4f", $Q;
+ print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
+ }
+
+ push(@Q, [$id, $Q, $bs]);
+ }
+
+
+ @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
+
+ return @Q if wantarray;
+ return undef unless @Q;
+ return undef if $Q[0][1] == 0;
+ $Q[0][0];
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+HTTP::Negotiate - choose a variant to serve
+
+=head1 SYNOPSIS
+
+ use HTTP::Negotiate qw(choose);
+
+ # ID QS Content-Type Encoding Char-Set Lang Size
+ $variants =
+ [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000],
+ ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400],
+ ['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
+ ];
+
+ @preferred = choose($variants, $request_headers);
+ $the_one = choose($variants);
+
+=head1 DESCRIPTION
+
+This module provides a complete implementation of the HTTP content
+negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
+chapter 12. Content negotiation allows for the selection of a
+preferred content representation based upon attributes of the
+negotiable variants and the value of the various Accept* header fields
+in the request.
+
+The variants are ordered by preference by calling the function
+choose().
+
+The first parameter is reference to an array of the variants to
+choose among.
+Each element in this array is an array with the values [$id, $qs,
+$content_type, $content_encoding, $charset, $content_language,
+$content_length] whose meanings are described
+below. The $content_encoding and $content_language can be either a
+single scalar value or an array reference if there are several values.
+
+The second optional parameter is either a HTTP::Headers or a HTTP::Request
+object which is searched for "Accept*" headers. If this
+parameter is missing, then the accept specification is initialized
+from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
+HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
+
+In an array context, choose() returns a list of [variant
+identifier, calculated quality, size] tuples. The values are sorted by
+quality, highest quality first. If the calculated quality is the same
+for two variants, then they are sorted by size (smallest first). I<E.g.>:
+
+ (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
+
+Note that also zero quality variants are included in the return list
+even if these should never be served to the client.
+
+In a scalar context, it returns the identifier of the variant with the
+highest score or C<undef> if none have non-zero quality.
+
+If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
+noise is generated on STDOUT during evaluation of choose().
+
+=head1 VARIANTS
+
+A variant is described by a list of the following values. If the
+attribute does not make sense or is unknown for a variant, then use
+C<undef> instead.
+
+=over 3
+
+=item identifier
+
+This is a string that you use as the name for the variant. This
+identifier for the preferred variants returned by choose().
+
+=item qs
+
+This is a number between 0.000 and 1.000 that describes the "source
+quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this
+value:
+
+Source quality is measured by the content provider as representing the
+amount of degradation from the original source. For example, a
+picture in JPEG form would have a lower qs when translated to the XBM
+format, and much lower qs when translated to an ASCII-art
+representation. Note, however, that this is a function of the source
+- an original piece of ASCII-art may degrade in quality if it is
+captured in JPEG form. The qs values should be assigned to each
+variant by the content provider; if no qs value has been assigned, the
+default is generally "qs=1".
+
+=item content-type
+
+This is the media type of the variant. The media type does not
+include a charset attribute, but might contain other parameters.
+Examples are:
+
+ text/html
+ text/html;version=2.0
+ text/plain
+ image/gif
+ image/jpg
+
+=item content-encoding
+
+This is one or more content encodings that has been applied to the
+variant. The content encoding is generally used as a modifier to the
+content media type. The most common content encodings are:
+
+ gzip
+ compress
+
+=item content-charset
+
+This is the character set used when the variant contains text.
+The charset value should generally be C<undef> or one of these:
+
+ us-ascii
+ iso-8859-1 ... iso-8859-9
+ iso-2022-jp
+ iso-2022-jp-2
+ iso-2022-kr
+ unicode-1-1
+ unicode-1-1-utf-7
+ unicode-1-1-utf-8
+
+=item content-language
+
+This describes one or more languages that are used in the variant.
+Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
+language is in this context a natural language spoken, written, or
+otherwise conveyed by human beings for communication of information to
+other human beings. Computer languages are explicitly excluded.
+
+The language tags are defined by RFC 3066. Examples
+are:
+
+ no Norwegian
+ en International English
+ en-US US English
+ en-cockney
+
+=item content-length
+
+This is the number of bytes used to represent the content.
+
+=back
+
+=head1 ACCEPT HEADERS
+
+The following Accept* headers can be used for describing content
+preferences in a request (This description is an edited extract from
+F<draft-ietf-http-v11-spec-00.ps>):
+
+=over 3
+
+=item Accept
+
+This header can be used to indicate a list of media ranges which are
+acceptable as a response to the request. The "*" character is used to
+group media types into ranges, with "*/*" indicating all media types
+and "type/*" indicating all subtypes of that type.
+
+The parameter q is used to indicate the quality factor, which
+represents the user's preference for that range of media types. The
+parameter mbx gives the maximum acceptable size of the response
+content. The default values are: q=1 and mbx=infinity. If no Accept
+header is present, then the client accepts all media types with q=1.
+
+For example:
+
+ Accept: audio/*;q=0.2;mbx=200000, audio/basic
+
+would mean: "I prefer audio/basic (of any size), but send me any audio
+type if it is the best available after an 80% mark-down in quality and
+its size is less than 200000 bytes"
+
+
+=item Accept-Charset
+
+Used to indicate what character sets are acceptable for the response.
+The "us-ascii" character set is assumed to be acceptable for all user
+agents. If no Accept-Charset field is given, the default is that any
+charset is acceptable. Example:
+
+ Accept-Charset: iso-8859-1, unicode-1-1
+
+
+=item Accept-Encoding
+
+Restricts the Content-Encoding values which are acceptable in the
+response. If no Accept-Encoding field is present, the server may
+assume that the client will accept any content encoding. An empty
+Accept-Encoding means that no content encoding is acceptable. Example:
+
+ Accept-Encoding: compress, gzip
+
+
+=item Accept-Language
+
+This field is similar to Accept, but restricts the set of natural
+languages that are preferred in a response. Each language may be
+given an associated quality value which represents an estimate of the
+user's comprehension of that language. For example:
+
+ Accept-Language: no, en-gb;q=0.8, de;q=0.55
+
+would mean: "I prefer Norwegian, but will accept British English (with
+80% comprehension) or German (with 55% comprehension).
+
+=back
+
+
+=head1 COPYRIGHT
+
+Copyright 1996,2001 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Request.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Request.pm
new file mode 100755
index 00000000000..ac7dc65af43
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Request.pm
@@ -0,0 +1,242 @@
+package HTTP::Request;
+
+require HTTP::Message;
+@ISA = qw(HTTP::Message);
+$VERSION = "5.827";
+
+use strict;
+
+
+
+sub new
+{
+ my($class, $method, $uri, $header, $content) = @_;
+ my $self = $class->SUPER::new($header, $content);
+ $self->method($method);
+ $self->uri($uri);
+ $self;
+}
+
+
+sub parse
+{
+ my($class, $str) = @_;
+ my $request_line;
+ if ($str =~ s/^(.*)\n//) {
+ $request_line = $1;
+ }
+ else {
+ $request_line = $str;
+ $str = "";
+ }
+
+ my $self = $class->SUPER::parse($str);
+ my($method, $uri, $protocol) = split(' ', $request_line);
+ $self->method($method) if defined($method);
+ $self->uri($uri) if defined($uri);
+ $self->protocol($protocol) if $protocol;
+ $self;
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $clone = bless $self->SUPER::clone, ref($self);
+ $clone->method($self->method);
+ $clone->uri($self->uri);
+ $clone;
+}
+
+
+sub method
+{
+ shift->_elem('_method', @_);
+}
+
+
+sub uri
+{
+ my $self = shift;
+ my $old = $self->{'_uri'};
+ if (@_) {
+ my $uri = shift;
+ if (!defined $uri) {
+ # that's ok
+ }
+ elsif (ref $uri) {
+ Carp::croak("A URI can't be a " . ref($uri) . " reference")
+ if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
+ Carp::croak("Can't use a " . ref($uri) . " object as a URI")
+ unless $uri->can('scheme');
+ $uri = $uri->clone;
+ unless ($HTTP::URI_CLASS eq "URI") {
+ # Argh!! Hate this... old LWP legacy!
+ eval { local $SIG{__DIE__}; $uri = $uri->abs; };
+ die $@ if $@ && $@ !~ /Missing base argument/;
+ }
+ }
+ else {
+ $uri = $HTTP::URI_CLASS->new($uri);
+ }
+ $self->{'_uri'} = $uri;
+ delete $self->{'_uri_canonical'};
+ }
+ $old;
+}
+
+*url = \&uri; # legacy
+
+sub uri_canonical
+{
+ my $self = shift;
+ return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical;
+}
+
+
+sub accept_decodable
+{
+ my $self = shift;
+ $self->header("Accept-Encoding", scalar($self->decodable));
+}
+
+sub as_string
+{
+ my $self = shift;
+ my($eol) = @_;
+ $eol = "\n" unless defined $eol;
+
+ my $req_line = $self->method || "-";
+ my $uri = $self->uri;
+ $uri = (defined $uri) ? $uri->as_string : "-";
+ $req_line .= " $uri";
+ my $proto = $self->protocol;
+ $req_line .= " $proto" if $proto;
+
+ return join($eol, $req_line, $self->SUPER::as_string(@_));
+}
+
+sub dump
+{
+ my $self = shift;
+ my @pre = ($self->method || "-", $self->uri || "-");
+ if (my $prot = $self->protocol) {
+ push(@pre, $prot);
+ }
+
+ return $self->SUPER::dump(
+ preheader => join(" ", @pre),
+ @_,
+ );
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Request - HTTP style request message
+
+=head1 SYNOPSIS
+
+ require HTTP::Request;
+ $request = HTTP::Request->new(GET => 'http://www.example.com/');
+
+and usually used like this:
+
+ $ua = LWP::UserAgent->new;
+ $response = $ua->request($request);
+
+=head1 DESCRIPTION
+
+C<HTTP::Request> is a class encapsulating HTTP style requests,
+consisting of a request line, some headers, and a content body. Note
+that the LWP library uses HTTP style requests even for non-HTTP
+protocols. Instances of this class are usually passed to the
+request() method of an C<LWP::UserAgent> object.
+
+C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
+inherits its methods. The following additional methods are available:
+
+=over 4
+
+=item $r = HTTP::Request->new( $method, $uri )
+
+=item $r = HTTP::Request->new( $method, $uri, $header )
+
+=item $r = HTTP::Request->new( $method, $uri, $header, $content )
+
+Constructs a new C<HTTP::Request> object describing a request on the
+object $uri using method $method. The $method argument must be a
+string. The $uri argument can be either a string, or a reference to a
+C<URI> object. The optional $header argument should be a reference to
+an C<HTTP::Headers> object or a plain array reference of key/value
+pairs. The optional $content argument should be a string of bytes.
+
+=item $r = HTTP::Request->parse( $str )
+
+This constructs a new request object by parsing the given string.
+
+=item $r->method
+
+=item $r->method( $val )
+
+This is used to get/set the method attribute. The method should be a
+short string like "GET", "HEAD", "PUT" or "POST".
+
+=item $r->uri
+
+=item $r->uri( $val )
+
+This is used to get/set the uri attribute. The $val can be a
+reference to a URI object or a plain string. If a string is given,
+then it should be parseable as an absolute URI.
+
+=item $r->header( $field )
+
+=item $r->header( $field => $value )
+
+This is used to get/set header values and it is inherited from
+C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
+details and other similar methods that can be used to access the
+headers.
+
+=item $r->accept_decodable
+
+This will set the C<Accept-Encoding> header to the list of encodings
+that decoded_content() can decode.
+
+=item $r->content
+
+=item $r->content( $bytes )
+
+This is used to get/set the content and it is inherited from the
+C<HTTP::Message> base class. See L<HTTP::Message> for details and
+other methods that can be used to access the content.
+
+Note that the content should be a string of bytes. Strings in perl
+can contain characters outside the range of a byte. The C<Encode>
+module can be used to turn such strings into a string of bytes.
+
+=item $r->as_string
+
+=item $r->as_string( $eol )
+
+Method returning a textual representation of the request.
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
+L<HTTP::Response>
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Request/Common.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Request/Common.pm
new file mode 100755
index 00000000000..7e3e03a861b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Request/Common.pm
@@ -0,0 +1,511 @@
+package HTTP::Request::Common;
+
+use strict;
+use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
+
+$DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT =qw(GET HEAD PUT POST);
+@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
+
+require HTTP::Request;
+use Carp();
+
+$VERSION = "5.824";
+
+my $CRLF = "\015\012"; # "\r\n" is not portable
+
+sub GET { _simple_req('GET', @_); }
+sub HEAD { _simple_req('HEAD', @_); }
+sub PUT { _simple_req('PUT' , @_); }
+sub DELETE { _simple_req('DELETE', @_); }
+
+sub POST
+{
+ my $url = shift;
+ my $req = HTTP::Request->new(POST => $url);
+ my $content;
+ $content = shift if @_ and ref $_[0];
+ my($k, $v);
+ while (($k,$v) = splice(@_, 0, 2)) {
+ if (lc($k) eq 'content') {
+ $content = $v;
+ }
+ else {
+ $req->push_header($k, $v);
+ }
+ }
+ my $ct = $req->header('Content-Type');
+ unless ($ct) {
+ $ct = 'application/x-www-form-urlencoded';
+ }
+ elsif ($ct eq 'form-data') {
+ $ct = 'multipart/form-data';
+ }
+
+ if (ref $content) {
+ if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
+ require HTTP::Headers::Util;
+ my @v = HTTP::Headers::Util::split_header_words($ct);
+ Carp::carp("Multiple Content-Type headers") if @v > 1;
+ @v = @{$v[0]};
+
+ my $boundary;
+ my $boundary_index;
+ for (my @tmp = @v; @tmp;) {
+ my($k, $v) = splice(@tmp, 0, 2);
+ if ($k eq "boundary") {
+ $boundary = $v;
+ $boundary_index = @v - @tmp - 1;
+ last;
+ }
+ }
+
+ ($content, $boundary) = form_data($content, $boundary, $req);
+
+ if ($boundary_index) {
+ $v[$boundary_index] = $boundary;
+ }
+ else {
+ push(@v, boundary => $boundary);
+ }
+
+ $ct = HTTP::Headers::Util::join_header_words(@v);
+ }
+ else {
+ # We use a temporary URI object to format
+ # the application/x-www-form-urlencoded content.
+ require URI;
+ my $url = URI->new('http:');
+ $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
+ $content = $url->query;
+ }
+ }
+
+ $req->header('Content-Type' => $ct); # might be redundant
+ if (defined($content)) {
+ $req->header('Content-Length' =>
+ length($content)) unless ref($content);
+ $req->content($content);
+ }
+ else {
+ $req->header('Content-Length' => 0);
+ }
+ $req;
+}
+
+
+sub _simple_req
+{
+ my($method, $url) = splice(@_, 0, 2);
+ my $req = HTTP::Request->new($method => $url);
+ my($k, $v);
+ my $content;
+ while (($k,$v) = splice(@_, 0, 2)) {
+ if (lc($k) eq 'content') {
+ $req->add_content($v);
+ $content++;
+ }
+ else {
+ $req->push_header($k, $v);
+ }
+ }
+ if ($content && !defined($req->header("Content-Length"))) {
+ $req->header("Content-Length", length(${$req->content_ref}));
+ }
+ $req;
+}
+
+
+sub form_data # RFC1867
+{
+ my($data, $boundary, $req) = @_;
+ my @data = ref($data) eq "HASH" ? %$data : @$data; # copy
+ my $fhparts;
+ my @parts;
+ my($k,$v);
+ while (($k,$v) = splice(@data, 0, 2)) {
+ if (!ref($v)) {
+ $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes
+ push(@parts,
+ qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
+ }
+ else {
+ my($file, $usename, @headers) = @$v;
+ unless (defined $usename) {
+ $usename = $file;
+ $usename =~ s,.*/,, if defined($usename);
+ }
+ $k =~ s/([\\\"])/\\$1/g;
+ my $disp = qq(form-data; name="$k");
+ if (defined($usename) and length($usename)) {
+ $usename =~ s/([\\\"])/\\$1/g;
+ $disp .= qq(; filename="$usename");
+ }
+ my $content = "";
+ my $h = HTTP::Headers->new(@headers);
+ if ($file) {
+ open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
+ binmode($fh);
+ if ($DYNAMIC_FILE_UPLOAD) {
+ # will read file later, close it now in order to
+ # not accumulate to many open file handles
+ close($fh);
+ $content = \$file;
+ }
+ else {
+ local($/) = undef; # slurp files
+ $content = <$fh>;
+ close($fh);
+ }
+ unless ($h->header("Content-Type")) {
+ require LWP::MediaTypes;
+ LWP::MediaTypes::guess_media_type($file, $h);
+ }
+ }
+ if ($h->header("Content-Disposition")) {
+ # just to get it sorted first
+ $disp = $h->header("Content-Disposition");
+ $h->remove_header("Content-Disposition");
+ }
+ if ($h->header("Content")) {
+ $content = $h->header("Content");
+ $h->remove_header("Content");
+ }
+ my $head = join($CRLF, "Content-Disposition: $disp",
+ $h->as_string($CRLF),
+ "");
+ if (ref $content) {
+ push(@parts, [$head, $$content]);
+ $fhparts++;
+ }
+ else {
+ push(@parts, $head . $content);
+ }
+ }
+ }
+ return ("", "none") unless @parts;
+
+ my $content;
+ if ($fhparts) {
+ $boundary = boundary(10) # hopefully enough randomness
+ unless $boundary;
+
+ # add the boundaries to the @parts array
+ for (1..@parts-1) {
+ splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
+ }
+ unshift(@parts, "--$boundary$CRLF");
+ push(@parts, "$CRLF--$boundary--$CRLF");
+
+ # See if we can generate Content-Length header
+ my $length = 0;
+ for (@parts) {
+ if (ref $_) {
+ my ($head, $f) = @$_;
+ my $file_size;
+ unless ( -f $f && ($file_size = -s _) ) {
+ # The file is either a dynamic file like /dev/audio
+ # or perhaps a file in the /proc file system where
+ # stat may return a 0 size even though reading it
+ # will produce data. So we cannot make
+ # a Content-Length header.
+ undef $length;
+ last;
+ }
+ $length += $file_size + length $head;
+ }
+ else {
+ $length += length;
+ }
+ }
+ $length && $req->header('Content-Length' => $length);
+
+ # set up a closure that will return content piecemeal
+ $content = sub {
+ for (;;) {
+ unless (@parts) {
+ defined $length && $length != 0 &&
+ Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer.";
+ return;
+ }
+ my $p = shift @parts;
+ unless (ref $p) {
+ $p .= shift @parts while @parts && !ref($parts[0]);
+ defined $length && ($length -= length $p);
+ return $p;
+ }
+ my($buf, $fh) = @$p;
+ unless (ref($fh)) {
+ my $file = $fh;
+ undef($fh);
+ open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
+ binmode($fh);
+ }
+ my $buflength = length $buf;
+ my $n = read($fh, $buf, 2048, $buflength);
+ if ($n) {
+ $buflength += $n;
+ unshift(@parts, ["", $fh]);
+ }
+ else {
+ close($fh);
+ }
+ if ($buflength) {
+ defined $length && ($length -= $buflength);
+ return $buf
+ }
+ }
+ };
+
+ }
+ else {
+ $boundary = boundary() unless $boundary;
+
+ my $bno = 0;
+ CHECK_BOUNDARY:
+ {
+ for (@parts) {
+ if (index($_, $boundary) >= 0) {
+ # must have a better boundary
+ $boundary = boundary(++$bno);
+ redo CHECK_BOUNDARY;
+ }
+ }
+ last;
+ }
+ $content = "--$boundary$CRLF" .
+ join("$CRLF--$boundary$CRLF", @parts) .
+ "$CRLF--$boundary--$CRLF";
+ }
+
+ wantarray ? ($content, $boundary) : $content;
+}
+
+
+sub boundary
+{
+ my $size = shift || return "xYzZY";
+ require MIME::Base64;
+ my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
+ $b =~ s/[\W]/X/g; # ensure alnum only
+ $b;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Request::Common - Construct common HTTP::Request objects
+
+=head1 SYNOPSIS
+
+ use HTTP::Request::Common;
+ $ua = LWP::UserAgent->new;
+ $ua->request(GET 'http://www.sn.no/');
+ $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
+
+=head1 DESCRIPTION
+
+This module provide functions that return newly created C<HTTP::Request>
+objects. These functions are usually more convenient to use than the
+standard C<HTTP::Request> constructor for the most common requests. The
+following functions are provided:
+
+=over 4
+
+=item GET $url
+
+=item GET $url, Header => Value,...
+
+The GET() function returns an C<HTTP::Request> object initialized with
+the "GET" method and the specified URL. It is roughly equivalent to the
+following call
+
+ HTTP::Request->new(
+ GET => $url,
+ HTTP::Headers->new(Header => Value,...),
+ )
+
+but is less cluttered. What is different is that a header named
+C<Content> will initialize the content part of the request instead of
+setting a header field. Note that GET requests should normally not
+have a content, so this hack makes more sense for the PUT() and POST()
+functions described below.
+
+The get(...) method of C<LWP::UserAgent> exists as a shortcut for
+$ua->request(GET ...).
+
+=item HEAD $url
+
+=item HEAD $url, Header => Value,...
+
+Like GET() but the method in the request is "HEAD".
+
+The head(...) method of "LWP::UserAgent" exists as a shortcut for
+$ua->request(HEAD ...).
+
+=item PUT $url
+
+=item PUT $url, Header => Value,...
+
+=item PUT $url, Header => Value,..., Content => $content
+
+Like GET() but the method in the request is "PUT".
+
+The content of the request can be specified using the "Content"
+pseudo-header. This steals a bit of the header field namespace as
+there is no way to directly specify a header that is actually called
+"Content". If you really need this you must update the request
+returned in a separate statement.
+
+=item DELETE $url
+
+=item DELETE $url, Header => Value,...
+
+Like GET() but the method in the request is "DELETE". This function
+is not exported by default.
+
+=item POST $url
+
+=item POST $url, Header => Value,...
+
+=item POST $url, $form_ref, Header => Value,...
+
+=item POST $url, Header => Value,..., Content => $form_ref
+
+=item POST $url, Header => Value,..., Content => $content
+
+This works mostly like PUT() with "POST" as the method, but this
+function also takes a second optional array or hash reference
+parameter $form_ref. As for PUT() the content can also be specified
+directly using the "Content" pseudo-header, and you may also provide
+the $form_ref this way.
+
+The $form_ref argument can be used to pass key/value pairs for the
+form content. By default we will initialize a request using the
+C<application/x-www-form-urlencoded> content type. This means that
+you can emulate a HTML E<lt>form> POSTing like this:
+
+ POST 'http://www.perl.org/survey.cgi',
+ [ name => 'Gisle Aas',
+ email => 'gisle@aas.no',
+ gender => 'M',
+ born => '1964',
+ perc => '3%',
+ ];
+
+This will create a HTTP::Request object that looks like this:
+
+ POST http://www.perl.org/survey.cgi
+ Content-Length: 66
+ Content-Type: application/x-www-form-urlencoded
+
+ name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
+
+Multivalued form fields can be specified by either repeating the field
+name or by passing the value as an array reference.
+
+The POST method also supports the C<multipart/form-data> content used
+for I<Form-based File Upload> as specified in RFC 1867. You trigger
+this content format by specifying a content type of C<'form-data'> as
+one of the request headers. If one of the values in the $form_ref is
+an array reference, then it is treated as a file part specification
+with the following interpretation:
+
+ [ $file, $filename, Header => Value... ]
+ [ undef, $filename, Header => Value,..., Content => $content ]
+
+The first value in the array ($file) is the name of a file to open.
+This file will be read and its content placed in the request. The
+routine will croak if the file can't be opened. Use an C<undef> as
+$file value if you want to specify the content directly with a
+C<Content> header. The $filename is the filename to report in the
+request. If this value is undefined, then the basename of the $file
+will be used. You can specify an empty string as $filename if you
+want to suppress sending the filename when you provide a $file value.
+
+If a $file is provided by no C<Content-Type> header, then C<Content-Type>
+and C<Content-Encoding> will be filled in automatically with the values
+returned by LWP::MediaTypes::guess_media_type()
+
+Sending my F<~/.profile> to the survey used as example above can be
+achieved by this:
+
+ POST 'http://www.perl.org/survey.cgi',
+ Content_Type => 'form-data',
+ Content => [ name => 'Gisle Aas',
+ email => 'gisle@aas.no',
+ gender => 'M',
+ born => '1964',
+ init => ["$ENV{HOME}/.profile"],
+ ]
+
+This will create a HTTP::Request object that almost looks this (the
+boundary and the content of your F<~/.profile> is likely to be
+different):
+
+ POST http://www.perl.org/survey.cgi
+ Content-Length: 388
+ Content-Type: multipart/form-data; boundary="6G+f"
+
+ --6G+f
+ Content-Disposition: form-data; name="name"
+
+ Gisle Aas
+ --6G+f
+ Content-Disposition: form-data; name="email"
+
+ gisle@aas.no
+ --6G+f
+ Content-Disposition: form-data; name="gender"
+
+ M
+ --6G+f
+ Content-Disposition: form-data; name="born"
+
+ 1964
+ --6G+f
+ Content-Disposition: form-data; name="init"; filename=".profile"
+ Content-Type: text/plain
+
+ PATH=/local/perl/bin:$PATH
+ export PATH
+
+ --6G+f--
+
+If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
+value, then you get back a request object with a subroutine closure as
+the content attribute. This subroutine will read the content of any
+files on demand and return it in suitable chunks. This allow you to
+upload arbitrary big files without using lots of memory. You can even
+upload infinite files like F</dev/audio> if you wish; however, if
+the file is not a plain file, there will be no Content-Length header
+defined for the request. Not all servers (or server
+applications) like this. Also, if the file(s) change in size between
+the time the Content-Length is calculated and the time that the last
+chunk is delivered, the subroutine will C<Croak>.
+
+The post(...) method of "LWP::UserAgent" exists as a shortcut for
+$ua->request(POST ...).
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Request>, L<LWP::UserAgent>
+
+
+=head1 COPYRIGHT
+
+Copyright 1997-2004, Gisle Aas
+
+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.straw/lib/HTTP/Response.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Response.pm
new file mode 100755
index 00000000000..37a195143c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Response.pm
@@ -0,0 +1,639 @@
+package HTTP::Response;
+
+require HTTP::Message;
+@ISA = qw(HTTP::Message);
+$VERSION = "5.824";
+
+use strict;
+use HTTP::Status ();
+
+
+
+sub new
+{
+ my($class, $rc, $msg, $header, $content) = @_;
+ my $self = $class->SUPER::new($header, $content);
+ $self->code($rc);
+ $self->message($msg);
+ $self;
+}
+
+
+sub parse
+{
+ my($class, $str) = @_;
+ my $status_line;
+ if ($str =~ s/^(.*)\n//) {
+ $status_line = $1;
+ }
+ else {
+ $status_line = $str;
+ $str = "";
+ }
+
+ my $self = $class->SUPER::parse($str);
+ my($protocol, $code, $message);
+ if ($status_line =~ /^\d{3} /) {
+ # Looks like a response created by HTTP::Response->new
+ ($code, $message) = split(' ', $status_line, 2);
+ } else {
+ ($protocol, $code, $message) = split(' ', $status_line, 3);
+ }
+ $self->protocol($protocol) if $protocol;
+ $self->code($code) if defined($code);
+ $self->message($message) if defined($message);
+ $self;
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $clone = bless $self->SUPER::clone, ref($self);
+ $clone->code($self->code);
+ $clone->message($self->message);
+ $clone->request($self->request->clone) if $self->request;
+ # we don't clone previous
+ $clone;
+}
+
+
+sub code { shift->_elem('_rc', @_); }
+sub message { shift->_elem('_msg', @_); }
+sub previous { shift->_elem('_previous',@_); }
+sub request { shift->_elem('_request', @_); }
+
+
+sub status_line
+{
+ my $self = shift;
+ my $code = $self->{'_rc'} || "000";
+ my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
+ return "$code $mess";
+}
+
+
+sub base
+{
+ my $self = shift;
+ my $base = $self->header('Content-Base') || # used to be HTTP/1.1
+ $self->header('Content-Location') || # HTTP/1.1
+ $self->header('Base'); # HTTP/1.0
+ if ($base && $base =~ /^$URI::scheme_re:/o) {
+ # already absolute
+ return $HTTP::URI_CLASS->new($base);
+ }
+
+ my $req = $self->request;
+ if ($req) {
+ # if $base is undef here, the return value is effectively
+ # just a copy of $self->request->uri.
+ return $HTTP::URI_CLASS->new_abs($base, $req->uri);
+ }
+
+ # can't find an absolute base
+ return undef;
+}
+
+
+sub redirects {
+ my $self = shift;
+ my @r;
+ my $r = $self;
+ while (my $p = $r->previous) {
+ push(@r, $p);
+ $r = $p;
+ }
+ return @r unless wantarray;
+ return reverse @r;
+}
+
+
+sub filename
+{
+ my $self = shift;
+ my $file;
+
+ my $cd = $self->header('Content-Disposition');
+ if ($cd) {
+ require HTTP::Headers::Util;
+ if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
+ my ($disposition, undef, %cd_param) = @{$cd[-1]};
+ $file = $cd_param{filename};
+
+ # RFC 2047 encoded?
+ if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
+ my $charset = $1;
+ my $encoding = uc($2);
+ my $encfile = $3;
+
+ if ($encoding eq 'Q' || $encoding eq 'B') {
+ local($SIG{__DIE__});
+ eval {
+ if ($encoding eq 'Q') {
+ $encfile =~ s/_/ /g;
+ require MIME::QuotedPrint;
+ $encfile = MIME::QuotedPrint::decode($encfile);
+ }
+ else { # $encoding eq 'B'
+ require MIME::Base64;
+ $encfile = MIME::Base64::decode($encfile);
+ }
+
+ require Encode;
+ require encoding;
+ # This is ugly use of non-public API, but is there
+ # a better way to accomplish what we want (locally
+ # as-is usable filename string)?
+ my $locale_charset = encoding::_get_locale_encoding();
+ Encode::from_to($encfile, $charset, $locale_charset);
+ };
+
+ $file = $encfile unless $@;
+ }
+ }
+ }
+ }
+
+ my $uri;
+ unless (defined($file) && length($file)) {
+ if (my $cl = $self->header('Content-Location')) {
+ $uri = URI->new($cl);
+ }
+ elsif (my $request = $self->request) {
+ $uri = $request->uri;
+ }
+
+ if ($uri) {
+ $file = ($uri->path_segments)[-1];
+ }
+ }
+
+ if ($file) {
+ $file =~ s,.*[\\/],,; # basename
+ }
+
+ if ($file && !length($file)) {
+ $file = undef;
+ }
+
+ $file;
+}
+
+
+sub as_string
+{
+ require HTTP::Status;
+ my $self = shift;
+ my($eol) = @_;
+ $eol = "\n" unless defined $eol;
+
+ my $status_line = $self->status_line;
+ my $proto = $self->protocol;
+ $status_line = "$proto $status_line" if $proto;
+
+ return join($eol, $status_line, $self->SUPER::as_string(@_));
+}
+
+
+sub dump
+{
+ my $self = shift;
+
+ my $status_line = $self->status_line;
+ my $proto = $self->protocol;
+ $status_line = "$proto $status_line" if $proto;
+
+ return $self->SUPER::dump(
+ preheader => $status_line,
+ @_,
+ );
+}
+
+
+sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
+sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
+sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
+sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
+
+
+sub error_as_HTML
+{
+ require HTML::Entities;
+ my $self = shift;
+ my $title = 'An Error Occurred';
+ my $body = HTML::Entities::encode($self->status_line);
+ return <<EOM;
+<html>
+<head><title>$title</title></head>
+<body>
+<h1>$title</h1>
+<p>$body</p>
+</body>
+</html>
+EOM
+}
+
+
+sub current_age
+{
+ my $self = shift;
+ my $time = shift;
+
+ # Implementation of RFC 2616 section 13.2.3
+ # (age calculations)
+ my $response_time = $self->client_date;
+ my $date = $self->date;
+
+ my $age = 0;
+ if ($response_time && $date) {
+ $age = $response_time - $date; # apparent_age
+ $age = 0 if $age < 0;
+ }
+
+ my $age_v = $self->header('Age');
+ if ($age_v && $age_v > $age) {
+ $age = $age_v; # corrected_received_age
+ }
+
+ if ($response_time) {
+ my $request = $self->request;
+ if ($request) {
+ my $request_time = $request->date;
+ if ($request_time && $request_time < $response_time) {
+ # Add response_delay to age to get 'corrected_initial_age'
+ $age += $response_time - $request_time;
+ }
+ }
+ $age += ($time || time) - $response_time;
+ }
+ return $age;
+}
+
+
+sub freshness_lifetime
+{
+ my($self, %opt) = @_;
+
+ # First look for the Cache-Control: max-age=n header
+ for my $cc ($self->header('Cache-Control')) {
+ for my $cc_dir (split(/\s*,\s*/, $cc)) {
+ return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
+ }
+ }
+
+ # Next possibility is to look at the "Expires" header
+ my $date = $self->date || $self->client_date || $opt{time} || time;
+ if (my $expires = $self->expires) {
+ return $expires - $date;
+ }
+
+ # Must apply heuristic expiration
+ return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
+
+ # Default heuristic expiration parameters
+ $opt{h_min} ||= 60;
+ $opt{h_max} ||= 24 * 3600;
+ $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
+ $opt{h_default} ||= 3600;
+
+ # Should give a warning if more than 24 hours according to
+ # RFC 2616 section 13.2.4. Here we just make this the default
+ # maximum value.
+
+ if (my $last_modified = $self->last_modified) {
+ my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
+ return $opt{h_min} if $h_exp < $opt{h_min};
+ return $opt{h_max} if $h_exp > $opt{h_max};
+ return $h_exp;
+ }
+
+ # default when all else fails
+ return $opt{h_min} if $opt{h_min} > $opt{h_default};
+ return $opt{h_default};
+}
+
+
+sub is_fresh
+{
+ my($self, %opt) = @_;
+ $opt{time} ||= time;
+ my $f = $self->freshness_lifetime(%opt);
+ return undef unless defined($f);
+ return $f > $self->current_age($opt{time});
+}
+
+
+sub fresh_until
+{
+ my($self, %opt) = @_;
+ $opt{time} ||= time;
+ my $f = $self->freshness_lifetime(%opt);
+ return undef unless defined($f);
+ return $f - $self->current_age($opt{time}) + $opt{time};
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Response - HTTP style response message
+
+=head1 SYNOPSIS
+
+Response objects are returned by the request() method of the C<LWP::UserAgent>:
+
+ # ...
+ $response = $ua->request($request)
+ if ($response->is_success) {
+ print $response->content;
+ }
+ else {
+ print STDERR $response->status_line, "\n";
+ }
+
+=head1 DESCRIPTION
+
+The C<HTTP::Response> class encapsulates HTTP style responses. A
+response consists of a response line, some headers, and a content
+body. Note that the LWP library uses HTTP style responses even for
+non-HTTP protocol schemes. Instances of this class are usually
+created and returned by the request() method of an C<LWP::UserAgent>
+object.
+
+C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
+inherits its methods. The following additional methods are available:
+
+=over 4
+
+=item $r = HTTP::Response->new( $code )
+
+=item $r = HTTP::Response->new( $code, $msg )
+
+=item $r = HTTP::Response->new( $code, $msg, $header )
+
+=item $r = HTTP::Response->new( $code, $msg, $header, $content )
+
+Constructs a new C<HTTP::Response> object describing a response with
+response code $code and optional message $msg. The optional $header
+argument should be a reference to an C<HTTP::Headers> object or a
+plain array reference of key/value pairs. The optional $content
+argument should be a string of bytes. The meaning these arguments are
+described below.
+
+=item $r = HTTP::Response->parse( $str )
+
+This constructs a new response object by parsing the given string.
+
+=item $r->code
+
+=item $r->code( $code )
+
+This is used to get/set the code attribute. The code is a 3 digit
+number that encode the overall outcome of a HTTP response. The
+C<HTTP::Status> module provide constants that provide mnemonic names
+for the code attribute.
+
+=item $r->message
+
+=item $r->message( $message )
+
+This is used to get/set the message attribute. The message is a short
+human readable single line string that explains the response code.
+
+=item $r->header( $field )
+
+=item $r->header( $field => $value )
+
+This is used to get/set header values and it is inherited from
+C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
+details and other similar methods that can be used to access the
+headers.
+
+=item $r->content
+
+=item $r->content( $bytes )
+
+This is used to get/set the raw content and it is inherited from the
+C<HTTP::Message> base class. See L<HTTP::Message> for details and
+other methods that can be used to access the content.
+
+=item $r->decoded_content( %options )
+
+This will return the content after any C<Content-Encoding> and
+charsets have been decoded. See L<HTTP::Message> for details.
+
+=item $r->request
+
+=item $r->request( $request )
+
+This is used to get/set the request attribute. The request attribute
+is a reference to the the request that caused this response. It does
+not have to be the same request passed to the $ua->request() method,
+because there might have been redirects and authorization retries in
+between.
+
+=item $r->previous
+
+=item $r->previous( $response )
+
+This is used to get/set the previous attribute. The previous
+attribute is used to link together chains of responses. You get
+chains of responses if the first response is redirect or unauthorized.
+The value is C<undef> if this is the first response in a chain.
+
+Note that the method $r->redirects is provided as a more convenient
+way to access the response chain.
+
+=item $r->status_line
+
+Returns the string "E<lt>code> E<lt>message>". If the message attribute
+is not set then the official name of E<lt>code> (see L<HTTP::Status>)
+is substituted.
+
+=item $r->base
+
+Returns the base URI for this response. The return value will be a
+reference to a URI object.
+
+The base URI is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+Embedded in the document content, for instance <BASE HREF="...">
+in HTML documents.
+
+=item 2.
+
+A "Content-Base:" or a "Content-Location:" header in the response.
+
+For backwards compatibility with older HTTP implementations we will
+also look for the "Base:" header.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If none of these sources provide an absolute URI, undef is returned.
+
+When the LWP protocol modules produce the HTTP::Response object, then
+any base URI embedded in the document (step 1) will already have
+initialized the "Content-Base:" header. This means that this method
+only performs the last 2 steps (the content is not always available
+either).
+
+=item $r->filename
+
+Returns a filename for this response. Note that doing sanity checks
+on the returned filename (eg. removing characters that cannot be used
+on the target filesystem where the filename would be used, and
+laundering it for security purposes) are the caller's responsibility;
+the only related thing done by this method is that it makes a simple
+attempt to return a plain filename with no preceding path segments.
+
+The filename is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+A "Content-Disposition:" header in the response. Proper decoding of
+RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
+encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
+
+=item 2.
+
+A "Content-Location:" header in the response.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If a filename cannot be derived from any of these sources, undef is
+returned.
+
+=item $r->as_string
+
+=item $r->as_string( $eol )
+
+Returns a textual representation of the response.
+
+=item $r->is_info
+
+=item $r->is_success
+
+=item $r->is_redirect
+
+=item $r->is_error
+
+These methods indicate if the response was informational, successful, a
+redirection, or an error. See L<HTTP::Status> for the meaning of these.
+
+=item $r->error_as_HTML
+
+Returns a string containing a complete HTML document indicating what
+error occurred. This method should only be called when $r->is_error
+is TRUE.
+
+=item $r->redirects
+
+Returns the list of redirect responses that lead up to this response
+by following the $r->previous chain. The list order is oldest first.
+
+In scalar context return the number of redirect responses leading up
+to this one.
+
+=item $r->current_age
+
+Calculates the "current age" of the response as specified by RFC 2616
+section 13.2.3. The age of a response is the time since it was sent
+by the origin server. The returned value is a number representing the
+age in seconds.
+
+=item $r->freshness_lifetime( %opt )
+
+Calculates the "freshness lifetime" of the response as specified by
+RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
+time between the generation of a response and its expiration time.
+The returned value is the number of seconds until expiry.
+
+If the response does not contain an "Expires" or a "Cache-Control"
+header, then this function will apply some simple heuristic based on
+the "Last-Modified" header to determine a suitable lifetime. The
+following options might be passed to control the heuristics:
+
+=over
+
+=item heuristic_expiry => $bool
+
+If passed as a FALSE value, don't apply heuristics and just return
+C<undef> when "Expires" or "Cache-Control" is lacking.
+
+=item h_lastmod_fraction => $num
+
+This number represent the fraction of the difference since the
+"Last-Modified" timestamp to make the expiry time. The default is
+C<0.10>, the suggested typical setting of 10% in RFC 2616.
+
+=item h_min => $sec
+
+This is the lower limit of the heuristic expiry age to use. The
+default is C<60> (1 minute).
+
+=item h_max => $sec
+
+This is the upper limit of the heuristic expiry age to use. The
+default is C<86400> (24 hours).
+
+=item h_default => $sec
+
+This is the expiry age to use when nothing else applies. The default
+is C<3600> (1 hour) or "h_min" if greater.
+
+=back
+
+=item $r->is_fresh( %opt )
+
+Returns TRUE if the response is fresh, based on the values of
+freshness_lifetime() and current_age(). If the response is no longer
+fresh, then it has to be re-fetched or re-validated by the origin
+server.
+
+Options might be passed to control expiry heuristics, see the
+description of freshness_lifetime().
+
+=item $r->fresh_until( %opt )
+
+Returns the time (seconds since epoch) when this entity is no longer fresh.
+
+Options might be passed to control expiry heuristics, see the
+description of freshness_lifetime().
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/HTTP/Status.pm b/Master/tlpkg/tlperl.straw/lib/HTTP/Status.pm
new file mode 100755
index 00000000000..930bd878858
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/HTTP/Status.pm
@@ -0,0 +1,254 @@
+package HTTP::Status;
+
+use strict;
+require 5.002; # because we use prototypes
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(is_info is_success is_redirect is_error status_message);
+@EXPORT_OK = qw(is_client_error is_server_error);
+$VERSION = "5.817";
+
+# Note also addition of mnemonics to @EXPORT below
+
+# Unmarked codes are from RFC 2616
+# See also: http://en.wikipedia.org/wiki/List_of_HTTP_status_codes
+
+my %StatusCode = (
+ 100 => 'Continue',
+ 101 => 'Switching Protocols',
+ 102 => 'Processing', # RFC 2518 (WebDAV)
+ 200 => 'OK',
+ 201 => 'Created',
+ 202 => 'Accepted',
+ 203 => 'Non-Authoritative Information',
+ 204 => 'No Content',
+ 205 => 'Reset Content',
+ 206 => 'Partial Content',
+ 207 => 'Multi-Status', # RFC 2518 (WebDAV)
+ 300 => 'Multiple Choices',
+ 301 => 'Moved Permanently',
+ 302 => 'Found',
+ 303 => 'See Other',
+ 304 => 'Not Modified',
+ 305 => 'Use Proxy',
+ 307 => 'Temporary Redirect',
+ 400 => 'Bad Request',
+ 401 => 'Unauthorized',
+ 402 => 'Payment Required',
+ 403 => 'Forbidden',
+ 404 => 'Not Found',
+ 405 => 'Method Not Allowed',
+ 406 => 'Not Acceptable',
+ 407 => 'Proxy Authentication Required',
+ 408 => 'Request Timeout',
+ 409 => 'Conflict',
+ 410 => 'Gone',
+ 411 => 'Length Required',
+ 412 => 'Precondition Failed',
+ 413 => 'Request Entity Too Large',
+ 414 => 'Request-URI Too Large',
+ 415 => 'Unsupported Media Type',
+ 416 => 'Request Range Not Satisfiable',
+ 417 => 'Expectation Failed',
+ 422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
+ 423 => 'Locked', # RFC 2518 (WebDAV)
+ 424 => 'Failed Dependency', # RFC 2518 (WebDAV)
+ 425 => 'No code', # WebDAV Advanced Collections
+ 426 => 'Upgrade Required', # RFC 2817
+ 449 => 'Retry with', # unofficial Microsoft
+ 500 => 'Internal Server Error',
+ 501 => 'Not Implemented',
+ 502 => 'Bad Gateway',
+ 503 => 'Service Unavailable',
+ 504 => 'Gateway Timeout',
+ 505 => 'HTTP Version Not Supported',
+ 506 => 'Variant Also Negotiates', # RFC 2295
+ 507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
+ 509 => 'Bandwidth Limit Exceeded', # unofficial
+ 510 => 'Not Extended', # RFC 2774
+);
+
+my $mnemonicCode = '';
+my ($code, $message);
+while (($code, $message) = each %StatusCode) {
+ # create mnemonic subroutines
+ $message =~ tr/a-z \-/A-Z__/;
+ $mnemonicCode .= "sub HTTP_$message () { $code }\n";
+ $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy
+ $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
+ $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
+}
+eval $mnemonicCode; # only one eval for speed
+die if $@;
+
+# backwards compatibility
+*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard
+push(@EXPORT, "RC_MOVED_TEMPORARILY");
+
+%EXPORT_TAGS = (
+ constants => [grep /^HTTP_/, @EXPORT_OK],
+ is => [grep /^is_/, @EXPORT, @EXPORT_OK],
+);
+
+
+sub status_message ($) { $StatusCode{$_[0]}; }
+
+sub is_info ($) { $_[0] >= 100 && $_[0] < 200; }
+sub is_success ($) { $_[0] >= 200 && $_[0] < 300; }
+sub is_redirect ($) { $_[0] >= 300 && $_[0] < 400; }
+sub is_error ($) { $_[0] >= 400 && $_[0] < 600; }
+sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; }
+sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; }
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Status - HTTP Status code processing
+
+=head1 SYNOPSIS
+
+ use HTTP::Status qw(:constants :is status_message);
+
+ if ($rc != HTTP_OK) {
+ print status_message($rc), "\n";
+ }
+
+ if (is_success($rc)) { ... }
+ if (is_error($rc)) { ... }
+ if (is_redirect($rc)) { ... }
+
+=head1 DESCRIPTION
+
+I<HTTP::Status> is a library of routines for defining and
+classifying HTTP status codes for libwww-perl. Status codes are
+used to encode the overall outcome of a HTTP response message. Codes
+correspond to those defined in RFC 2616 and RFC 2518.
+
+=head1 CONSTANTS
+
+The following constant functions can be used as mnemonic status code
+names. None of these are exported by default. Use the C<:constants>
+tag to import them all.
+
+ HTTP_CONTINUE (100)
+ HTTP_SWITCHING_PROTOCOLS (101)
+ HTTP_PROCESSING (102)
+
+ HTTP_OK (200)
+ HTTP_CREATED (201)
+ HTTP_ACCEPTED (202)
+ HTTP_NON_AUTHORITATIVE_INFORMATION (203)
+ HTTP_NO_CONTENT (204)
+ HTTP_RESET_CONTENT (205)
+ HTTP_PARTIAL_CONTENT (206)
+ HTTP_MULTI_STATUS (207)
+
+ HTTP_MULTIPLE_CHOICES (300)
+ HTTP_MOVED_PERMANENTLY (301)
+ HTTP_FOUND (302)
+ HTTP_SEE_OTHER (303)
+ HTTP_NOT_MODIFIED (304)
+ HTTP_USE_PROXY (305)
+ HTTP_TEMPORARY_REDIRECT (307)
+
+ HTTP_BAD_REQUEST (400)
+ HTTP_UNAUTHORIZED (401)
+ HTTP_PAYMENT_REQUIRED (402)
+ HTTP_FORBIDDEN (403)
+ HTTP_NOT_FOUND (404)
+ HTTP_METHOD_NOT_ALLOWED (405)
+ HTTP_NOT_ACCEPTABLE (406)
+ HTTP_PROXY_AUTHENTICATION_REQUIRED (407)
+ HTTP_REQUEST_TIMEOUT (408)
+ HTTP_CONFLICT (409)
+ HTTP_GONE (410)
+ HTTP_LENGTH_REQUIRED (411)
+ HTTP_PRECONDITION_FAILED (412)
+ HTTP_REQUEST_ENTITY_TOO_LARGE (413)
+ HTTP_REQUEST_URI_TOO_LARGE (414)
+ HTTP_UNSUPPORTED_MEDIA_TYPE (415)
+ HTTP_REQUEST_RANGE_NOT_SATISFIABLE (416)
+ HTTP_EXPECTATION_FAILED (417)
+ HTTP_UNPROCESSABLE_ENTITY (422)
+ HTTP_LOCKED (423)
+ HTTP_FAILED_DEPENDENCY (424)
+ HTTP_NO_CODE (425)
+ HTTP_UPGRADE_REQUIRED (426)
+ HTTP_RETRY_WITH (449)
+
+ HTTP_INTERNAL_SERVER_ERROR (500)
+ HTTP_NOT_IMPLEMENTED (501)
+ HTTP_BAD_GATEWAY (502)
+ HTTP_SERVICE_UNAVAILABLE (503)
+ HTTP_GATEWAY_TIMEOUT (504)
+ HTTP_HTTP_VERSION_NOT_SUPPORTED (505)
+ HTTP_VARIANT_ALSO_NEGOTIATES (506)
+ HTTP_INSUFFICIENT_STORAGE (507)
+ HTTP_BANDWIDTH_LIMIT_EXCEEDED (509)
+ HTTP_NOT_EXTENDED (510)
+
+=head1 FUNCTIONS
+
+The following additional functions are provided. Most of them are
+exported by default. The C<:is> import tag can be used to import all
+the classification functions.
+
+=over 4
+
+=item status_message( $code )
+
+The status_message() function will translate status codes to human
+readable strings. The string is the same as found in the constant
+names above. If the $code is unknown, then C<undef> is returned.
+
+=item is_info( $code )
+
+Return TRUE if C<$code> is an I<Informational> status code (1xx). This
+class of status code indicates a provisional response which can't have
+any content.
+
+=item is_success( $code )
+
+Return TRUE if C<$code> is a I<Successful> status code (2xx).
+
+=item is_redirect( $code )
+
+Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
+status code indicates that further action needs to be taken by the
+user agent in order to fulfill the request.
+
+=item is_error( $code )
+
+Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function
+return TRUE for both client error or a server error status codes.
+
+=item is_client_error( $code )
+
+Return TRUE if C<$code> is an I<Client Error> status code (4xx). This class
+of status code is intended for cases in which the client seems to have
+erred.
+
+This function is B<not> exported by default.
+
+=item is_server_error( $code )
+
+Return TRUE if C<$code> is an I<Server Error> status code (5xx). This class
+of status codes is intended for cases in which the server is aware
+that it has erred or is incapable of performing the request.
+
+This function is B<not> exported by default.
+
+=back
+
+=head1 BUGS
+
+For legacy reasons all the C<HTTP_> constants are exported by default
+with the prefix C<RC_>. It's recommended to use explict imports and
+the C<:constants> tag instead of relying on this.
diff --git a/Master/tlpkg/tlperl.straw/lib/Hash/Util.pm b/Master/tlpkg/tlperl.straw/lib/Hash/Util.pm
new file mode 100755
index 00000000000..0fa14690243
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Hash/Util.pm
@@ -0,0 +1,520 @@
+package Hash::Util;
+
+require 5.007003;
+use strict;
+use Carp;
+use warnings;
+use warnings::register;
+use Scalar::Util qw(reftype);
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(
+ fieldhash fieldhashes
+
+ all_keys
+ lock_keys unlock_keys
+ lock_value unlock_value
+ lock_hash unlock_hash
+ lock_keys_plus hash_locked
+ hidden_keys legal_keys
+
+ lock_ref_keys unlock_ref_keys
+ lock_ref_value unlock_ref_value
+ lock_hashref unlock_hashref
+ lock_ref_keys_plus hashref_locked
+ hidden_ref_keys legal_ref_keys
+
+ hash_seed hv_store
+
+ );
+our $VERSION = 0.07;
+require DynaLoader;
+local @ISA = qw(DynaLoader);
+bootstrap Hash::Util $VERSION;
+
+sub import {
+ my $class = shift;
+ if ( grep /fieldhash/, @_ ) {
+ require Hash::Util::FieldHash;
+ Hash::Util::FieldHash->import(':all'); # for re-export
+ }
+ unshift @_, $class;
+ goto &Exporter::import;
+}
+
+
+=head1 NAME
+
+Hash::Util - A selection of general-utility hash subroutines
+
+=head1 SYNOPSIS
+
+ # Restricted hashes
+
+ use Hash::Util qw(
+ hash_seed all_keys
+ lock_keys unlock_keys
+ lock_value unlock_value
+ lock_hash unlock_hash
+ lock_keys_plus hash_locked
+ hidden_keys legal_keys
+ );
+
+ %hash = (foo => 42, bar => 23);
+ # Ways to restrict a hash
+ lock_keys(%hash);
+ lock_keys(%hash, @keyset);
+ lock_keys_plus(%hash, @additional_keys);
+
+ # Ways to inspect the properties of a restricted hash
+ my @legal = legal_keys(%hash);
+ my @hidden = hidden_keys(%hash);
+ my $ref = all_keys(%hash,@keys,@hidden);
+ my $is_locked = hash_locked(%hash);
+
+ # Remove restrictions on the hash
+ unlock_keys(%hash);
+
+ # Lock individual values in a hash
+ lock_value (%hash, 'foo');
+ unlock_value(%hash, 'foo');
+
+ # Ways to change the restrictions on both keys and values
+ lock_hash (%hash);
+ unlock_hash(%hash);
+
+ my $hashes_are_randomised = hash_seed() != 0;
+
+=head1 DESCRIPTION
+
+C<Hash::Util> and C<Hash::Util::FieldHash> contain special functions
+for manipulating hashes that don't really warrant a keyword.
+
+C<Hash::Util> contains a set of functions that support
+L<restricted hashes|/"Restricted hashes">. These are described in
+this document. C<Hash::Util::FieldHash> contains an (unrelated)
+set of functions that support the use of hashes in
+I<inside-out classes>, described in L<Hash::Util::FieldHash>.
+
+By default C<Hash::Util> does not export anything.
+
+=head2 Restricted hashes
+
+5.8.0 introduces the ability to restrict a hash to a certain set of
+keys. No keys outside of this set can be added. It also introduces
+the ability to lock an individual key so it cannot be deleted and the
+ability to ensure that an individual value cannot be changed.
+
+This is intended to largely replace the deprecated pseudo-hashes.
+
+=over 4
+
+=item B<lock_keys>
+
+=item B<unlock_keys>
+
+ lock_keys(%hash);
+ lock_keys(%hash, @keys);
+
+Restricts the given %hash's set of keys to @keys. If @keys is not
+given it restricts it to its current keyset. No more keys can be
+added. delete() and exists() will still work, but will not alter
+the set of allowed keys. B<Note>: the current implementation prevents
+the hash from being bless()ed while it is in a locked state. Any attempt
+to do so will raise an exception. Of course you can still bless()
+the hash before you call lock_keys() so this shouldn't be a problem.
+
+ unlock_keys(%hash);
+
+Removes the restriction on the %hash's keyset.
+
+B<Note> that if any of the values of the hash have been locked they will not be unlocked
+after this sub executes.
+
+Both routines return a reference to the hash operated on.
+
+=cut
+
+sub lock_ref_keys {
+ my($hash, @keys) = @_;
+
+ Internals::hv_clear_placeholders %$hash;
+ if( @keys ) {
+ my %keys = map { ($_ => 1) } @keys;
+ my %original_keys = map { ($_ => 1) } keys %$hash;
+ foreach my $k (keys %original_keys) {
+ croak "Hash has key '$k' which is not in the new key set"
+ unless $keys{$k};
+ }
+
+ foreach my $k (@keys) {
+ $hash->{$k} = undef unless exists $hash->{$k};
+ }
+ Internals::SvREADONLY %$hash, 1;
+
+ foreach my $k (@keys) {
+ delete $hash->{$k} unless $original_keys{$k};
+ }
+ }
+ else {
+ Internals::SvREADONLY %$hash, 1;
+ }
+
+ return $hash;
+}
+
+sub unlock_ref_keys {
+ my $hash = shift;
+
+ Internals::SvREADONLY %$hash, 0;
+ return $hash;
+}
+
+sub lock_keys (\%;@) { lock_ref_keys(@_) }
+sub unlock_keys (\%) { unlock_ref_keys(@_) }
+
+=item B<lock_keys_plus>
+
+ lock_keys_plus(%hash,@additional_keys)
+
+Similar to C<lock_keys()>, with the difference being that the optional key list
+specifies keys that may or may not be already in the hash. Essentially this is
+an easier way to say
+
+ lock_keys(%hash,@additional_keys,keys %hash);
+
+Returns a reference to %hash
+
+=cut
+
+
+sub lock_ref_keys_plus {
+ my ($hash,@keys)=@_;
+ my @delete;
+ Internals::hv_clear_placeholders(%$hash);
+ foreach my $key (@keys) {
+ unless (exists($hash->{$key})) {
+ $hash->{$key}=undef;
+ push @delete,$key;
+ }
+ }
+ Internals::SvREADONLY(%$hash,1);
+ delete @{$hash}{@delete};
+ return $hash
+}
+
+sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
+
+
+=item B<lock_value>
+
+=item B<unlock_value>
+
+ lock_value (%hash, $key);
+ unlock_value(%hash, $key);
+
+Locks and unlocks the value for an individual key of a hash. The value of a
+locked key cannot be changed.
+
+Unless %hash has already been locked the key/value could be deleted
+regardless of this setting.
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_ref_value {
+ my($hash, $key) = @_;
+ # I'm doubtful about this warning, as it seems not to be true.
+ # Marking a value in the hash as RO is useful, regardless
+ # of the status of the hash itself.
+ carp "Cannot usefully lock values in an unlocked hash"
+ if !Internals::SvREADONLY(%$hash) && warnings::enabled;
+ Internals::SvREADONLY $hash->{$key}, 1;
+ return $hash
+}
+
+sub unlock_ref_value {
+ my($hash, $key) = @_;
+ Internals::SvREADONLY $hash->{$key}, 0;
+ return $hash
+}
+
+sub lock_value (\%$) { lock_ref_value(@_) }
+sub unlock_value (\%$) { unlock_ref_value(@_) }
+
+
+=item B<lock_hash>
+
+=item B<unlock_hash>
+
+ lock_hash(%hash);
+
+lock_hash() locks an entire hash, making all keys and values read-only.
+No value can be changed, no keys can be added or deleted.
+
+ unlock_hash(%hash);
+
+unlock_hash() does the opposite of lock_hash(). All keys and values
+are made writable. All values can be changed and keys can be added
+and deleted.
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_hashref {
+ my $hash = shift;
+
+ lock_ref_keys($hash);
+
+ foreach my $value (values %$hash) {
+ Internals::SvREADONLY($value,1);
+ }
+
+ return $hash;
+}
+
+sub unlock_hashref {
+ my $hash = shift;
+
+ foreach my $value (values %$hash) {
+ Internals::SvREADONLY($value, 0);
+ }
+
+ unlock_ref_keys($hash);
+
+ return $hash;
+}
+
+sub lock_hash (\%) { lock_hashref(@_) }
+sub unlock_hash (\%) { unlock_hashref(@_) }
+
+=item B<lock_hash_recurse>
+
+=item B<unlock_hash_recurse>
+
+ lock_hash_recurse(%hash);
+
+lock_hash() locks an entire hash and any hashes it references recursively,
+making all keys and values read-only. No value can be changed, no keys can
+be added or deleted.
+
+B<Only> recurses into hashes that are referenced by another hash. Thus a
+Hash of Hashes (HoH) will all be restricted, but a Hash of Arrays of Hashes
+(HoAoH) will only have the top hash restricted.
+
+ unlock_hash_recurse(%hash);
+
+unlock_hash_recurse() does the opposite of lock_hash_recurse(). All keys and
+values are made writable. All values can be changed and keys can be added
+and deleted. Identical recursion restrictions apply as to lock_hash_recurse().
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_hashref_recurse {
+ my $hash = shift;
+
+ lock_ref_keys($hash);
+ foreach my $value (values %$hash) {
+ if (reftype($value) eq 'HASH') {
+ lock_hashref_recurse($value);
+ }
+ Internals::SvREADONLY($value,1);
+ }
+ return $hash
+}
+
+sub unlock_hashref_recurse {
+ my $hash = shift;
+
+ foreach my $value (values %$hash) {
+ if (reftype($value) eq 'HASH') {
+ unlock_hashref_recurse($value);
+ }
+ Internals::SvREADONLY($value,1);
+ }
+ unlock_ref_keys($hash);
+ return $hash;
+}
+
+sub lock_hash_recurse (\%) { lock_hashref_recurse(@_) }
+sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
+
+
+=item B<hash_unlocked>
+
+ hash_unlocked(%hash) and print "Hash is unlocked!\n";
+
+Returns true if the hash and its keys are unlocked.
+
+=cut
+
+sub hashref_unlocked {
+ my $hash=shift;
+ return Internals::SvREADONLY($hash)
+}
+
+sub hash_unlocked(\%) { hashref_unlocked(@_) }
+
+=for demerphqs_editor
+sub legal_ref_keys{}
+sub hidden_ref_keys{}
+sub all_keys{}
+
+=cut
+
+sub legal_keys(\%) { legal_ref_keys(@_) }
+sub hidden_keys(\%){ hidden_ref_keys(@_) }
+
+=item B<legal_keys>
+
+ my @keys = legal_keys(%hash);
+
+Returns the list of the keys that are legal in a restricted hash.
+In the case of an unrestricted hash this is identical to calling
+keys(%hash).
+
+=item B<hidden_keys>
+
+ my @keys = hidden_keys(%hash);
+
+Returns the list of the keys that are legal in a restricted hash but
+do not have a value associated to them. Thus if 'foo' is a
+"hidden" key of the %hash it will return false for both C<defined>
+and C<exists> tests.
+
+In the case of an unrestricted hash this will return an empty list.
+
+B<NOTE> this is an experimental feature that is heavily dependent
+on the current implementation of restricted hashes. Should the
+implementation change, this routine may become meaningless, in which
+case it will return an empty list.
+
+=item B<all_keys>
+
+ all_keys(%hash,@keys,@hidden);
+
+Populates the arrays @keys with the all the keys that would pass
+an C<exists> tests, and populates @hidden with the remaining legal
+keys that have not been utilized.
+
+Returns a reference to the hash.
+
+In the case of an unrestricted hash this will be equivalent to
+
+ $ref = do {
+ @keys = keys %hash;
+ @hidden = ();
+ \%hash
+ };
+
+B<NOTE> this is an experimental feature that is heavily dependent
+on the current implementation of restricted hashes. Should the
+implementation change this routine may become meaningless in which
+case it will behave identically to how it would behave on an
+unrestricted hash.
+
+=item B<hash_seed>
+
+ my $hash_seed = hash_seed();
+
+hash_seed() returns the seed number used to randomise hash ordering.
+Zero means the "traditional" random hash ordering, non-zero means the
+new even more random hash ordering introduced in Perl 5.8.1.
+
+B<Note that the hash seed is sensitive information>: by knowing it one
+can craft a denial-of-service attack against Perl code, even remotely,
+see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
+B<Do not disclose the hash seed> to people who don't need to know it.
+See also L<perlrun/PERL_HASH_SEED_DEBUG>.
+
+=cut
+
+sub hash_seed () {
+ Internals::rehash_seed();
+}
+
+=item B<hv_store>
+
+ my $sv = 0;
+ hv_store(%hash,$key,$sv) or die "Failed to alias!";
+ $hash{$key} = 1;
+ print $sv; # prints 1
+
+Stores an alias to a variable in a hash instead of copying the value.
+
+=back
+
+=head2 Operating on references to hashes.
+
+Most subroutines documented in this module have equivalent versions
+that operate on references to hashes instead of native hashes.
+The following is a list of these subs. They are identical except
+in name and in that instead of taking a %hash they take a $hashref,
+and additionally are not prototyped.
+
+=over 4
+
+=item lock_ref_keys
+
+=item unlock_ref_keys
+
+=item lock_ref_keys_plus
+
+=item lock_ref_value
+
+=item unlock_ref_value
+
+=item lock_hashref
+
+=item unlock_hashref
+
+=item lock_hashref_recurse
+
+=item unlock_hashref_recurse
+
+=item hash_ref_unlocked
+
+=item legal_ref_keys
+
+=item hidden_ref_keys
+
+=back
+
+=head1 CAVEATS
+
+Note that the trapping of the restricted operations is not atomic:
+for example
+
+ eval { %hash = (illegal_key => 1) }
+
+leaves the C<%hash> empty rather than with its original contents.
+
+=head1 BUGS
+
+The interface exposed by this module is very close to the current
+implementation of restricted hashes. Over time it is expected that
+this behavior will be extended and the interface abstracted further.
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com> on top of code by Nick
+Ing-Simmons and Jeffrey Friedl.
+
+hv_store() is from Array::RefElem, Copyright 2000 Gisle Aas.
+
+Additional code by Yves Orton.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util> and L<perlsec/"Algorithmic Complexity Attacks">.
+
+L<Hash::Util::FieldHash>.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Hash/Util/FieldHash.pm b/Master/tlpkg/tlperl.straw/lib/Hash/Util/FieldHash.pm
new file mode 100755
index 00000000000..bca3a6fd7fc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Hash/Util/FieldHash.pm
@@ -0,0 +1,860 @@
+package Hash::Util::FieldHash;
+
+use 5.009004;
+use strict;
+use warnings;
+use Scalar::Util qw( reftype);
+
+our $VERSION = '1.04';
+
+require Exporter;
+our @ISA = qw(Exporter);
+our %EXPORT_TAGS = (
+ 'all' => [ qw(
+ fieldhash
+ fieldhashes
+ idhash
+ idhashes
+ id
+ id_2obj
+ register
+ )],
+);
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+{
+ require XSLoader;
+ my %ob_reg; # private object registry
+ sub _ob_reg { \ %ob_reg }
+ XSLoader::load('Hash::Util::FieldHash', $VERSION);
+}
+
+sub fieldhash (\%) {
+ for ( shift ) {
+ return unless ref() && reftype( $_) eq 'HASH';
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 0);
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 2) == 2;
+ return;
+ }
+}
+
+sub idhash (\%) {
+ for ( shift ) {
+ return unless ref() && reftype( $_) eq 'HASH';
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 0);
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 1) == 1;
+ return;
+ }
+}
+
+sub fieldhashes { map &fieldhash( $_), @_ }
+sub idhashes { map &idhash( $_), @_ }
+
+1;
+__END__
+
+=head1 NAME
+
+Hash::Util::FieldHash - Support for Inside-Out Classes
+
+=head1 SYNOPSIS
+
+ ### Create fieldhashes
+ use Hash::Util qw(fieldhash fieldhashes);
+
+ # Create a single field hash
+ fieldhash my %foo;
+
+ # Create three at once...
+ fieldhashes \ my(%foo, %bar, %baz);
+ # ...or any number
+ fieldhashes @hashrefs;
+
+ ### Create an idhash and register it for garbage collection
+ use Hash::Util::FieldHash qw(idhash register);
+ idhash my %name;
+ my $object = \ do { my $o };
+ # register the idhash for garbage collection with $object
+ register($object, \ %name);
+ # the following entry will be deleted when $object goes out of scope
+ $name{$object} = 'John Doe';
+
+ ### Register an ordinary hash for garbage collection
+ use Hash::Util::FieldHash qw(id register);
+ my %name;
+ my $object = \ do { my $o };
+ # register the hash %name for garbage collection of $object's id
+ register $object, \ %name;
+ # the following entry will be deleted when $object goes out of scope
+ $name{id $object} = 'John Doe';
+
+=head1 FUNCTIONS
+
+C<Hash::Util::FieldHash> offers a number of functions in support of
+L<The Inside-out Technique> of class construction.
+
+=over
+
+=item id
+
+ id($obj)
+
+Returns the reference address of a reference $obj. If $obj is
+not a reference, returns $obj.
+
+This function is a stand-in replacement for
+L<Scalar::Util::refaddr|Scalar::Util/refaddr>, that is, it returns
+the reference address of its argument as a numeric value. The only
+difference is that C<refaddr()> returns C<undef> when given a
+non-reference while C<id()> returns its argument unchanged.
+
+C<id()> also uses a caching technique that makes it faster when
+the id of an object is requested often, but slower if it is needed
+only once or twice.
+
+=item id_2obj
+
+ $obj = id_2obj($id)
+
+If C<$id> is the id of a registered object (see L</register>), returns
+the object, otherwise an undefined value. For registered objects this
+is the inverse function of C<id()>.
+
+=item register
+
+ register($obj)
+ register($obj, @hashrefs)
+
+In the first form, registers an object to work with for the function
+C<id_2obj()>. In the second form, it additionally marks the given
+hashrefs down for garbage collection. This means that when the object
+goes out of scope, any entries in the given hashes under the key of
+C<id($obj)> will be deleted from the hashes.
+
+It is a fatal error to register a non-reference $obj. Any non-hashrefs
+among the following arguments are silently ignored.
+
+It is I<not> an error to register the same object multiple times with
+varying sets of hashrefs. Any hashrefs that are not registered yet
+will be added, others ignored.
+
+Registry also implies thread support. When a new thread is created,
+all references are replaced with new ones, including all objects.
+If a hash uses the reference address of an object as a key, that
+connection would be broken. With a registered object, its id will
+be updated in all hashes registered with it.
+
+=item idhash
+
+ idhash my %hash
+
+Makes an idhash from the argument, which must be a hash.
+
+An I<idhash> works like a normal hash, except that it stringifies a
+I<reference used as a key> differently. A reference is stringified
+as if the C<id()> function had been invoked on it, that is, its
+reference address in decimal is used as the key.
+
+=item idhashes
+
+ idhashes \ my(%hash, %gnash, %trash)
+ idhashes \ @hashrefs
+
+Creates many idhashes from its hashref arguments. Returns those
+arguments that could be converted or their number in scalar context.
+
+=item fieldhash
+
+ fieldhash %hash;
+
+Creates a single fieldhash. The argument must be a hash. Returns
+a reference to the given hash if successful, otherwise nothing.
+
+A I<fieldhash> is, in short, an idhash with auto-registry. When an
+object (or, indeed, any reference) is used as a fieldhash key, the
+fieldhash is automatically registered for garbage collection with
+the object, as if C<register $obj, \ %fieldhash> had been called.
+
+=item fieldhashes
+
+ fieldhashes @hashrefs;
+
+Creates any number of field hashes. Arguments must be hash references.
+Returns the converted hashrefs in list context, their number in scalar
+context.
+
+=back
+
+=head1 DESCRIPTION
+
+A word on terminology: I shall use the term I<field> for a scalar
+piece of data that a class associates with an object. Other terms that
+have been used for this concept are "object variable", "(object) property",
+"(object) attribute" and more. Especially "attribute" has some currency
+among Perl programmer, but that clashes with the C<attributes> pragma. The
+term "field" also has some currency in this sense and doesn't seem
+to conflict with other Perl terminology.
+
+In Perl, an object is a blessed reference. The standard way of associating
+data with an object is to store the data inside the object's body, that is,
+the piece of data pointed to by the reference.
+
+In consequence, if two or more classes want to access an object they
+I<must> agree on the type of reference and also on the organization of
+data within the object body. Failure to agree on the type results in
+immediate death when the wrong method tries to access an object. Failure
+to agree on data organization may lead to one class trampling over the
+data of another.
+
+This object model leads to a tight coupling between subclasses.
+If one class wants to inherit from another (and both classes access
+object data), the classes must agree about implementation details.
+Inheritance can only be used among classes that are maintained together,
+in a single source or not.
+
+In particular, it is not possible to write general-purpose classes
+in this technique, classes that can advertise themselves as "Put me
+on your @ISA list and use my methods". If the other class has different
+ideas about how the object body is used, there is trouble.
+
+For reference L<Name_hash> in L<Example 1> shows the standard implementation of
+a simple class C<Name> in the well-known hash based way. It also demonstrates
+the predictable failure to construct a common subclass C<NamedFile>
+of C<Name> and the class C<IO::File> (whose objects I<must> be globrefs).
+
+Thus, techniques are of interest that store object data I<not> in
+the object body but some other place.
+
+=head2 The Inside-out Technique
+
+With I<inside-out> classes, each class declares a (typically lexical)
+hash for each field it wants to use. The reference address of an
+object is used as the hash key. By definition, the reference address
+is unique to each object so this guarantees a place for each field that
+is private to the class and unique to each object. See L<Name_id> in
+L<Example 1> for a simple example.
+
+In comparison to the standard implementation where the object is a
+hash and the fields correspond to hash keys, here the fields correspond
+to hashes, and the object determines the hash key. Thus the hashes
+appear to be turned I<inside out>.
+
+The body of an object is never examined by an inside-out class, only
+its reference address is used. This allows for the body of an actual
+object to be I<anything at all> while the object methods of the class
+still work as designed. This is a key feature of inside-out classes.
+
+=head2 Problems of Inside-out
+
+Inside-out classes give us freedom of inheritance, but as usual there
+is a price.
+
+Most obviously, there is the necessity of retrieving the reference
+address of an object for each data access. It's a minor inconvenience,
+but it does clutter the code.
+
+More important (and less obvious) is the necessity of garbage
+collection. When a normal object dies, anything stored in the
+object body is garbage-collected by perl. With inside-out objects,
+Perl knows nothing about the data stored in field hashes by a class,
+but these must be deleted when the object goes out of scope. Thus
+the class must provide a C<DESTROY> method to take care of that.
+
+In the presence of multiple classes it can be non-trivial
+to make sure that every relevant destructor is called for
+every object. Perl calls the first one it finds on the
+inheritance tree (if any) and that's it.
+
+A related issue is thread-safety. When a new thread is created,
+the Perl interpreter is cloned, which implies that all reference
+addresses in use will be replaced with new ones. Thus, if a class
+tries to access a field of a cloned object its (cloned) data will
+still be stored under the now invalid reference address of the
+original in the parent thread. A general C<CLONE> method must
+be provided to re-establish the association.
+
+=head2 Solutions
+
+C<Hash::Util::FieldHash> addresses these issues on several
+levels.
+
+The C<id()> function is provided in addition to the
+existing C<Scalar::Util::refaddr()>. Besides its short name
+it can be a little faster under some circumstances (and a
+bit slower under others). Benchmark if it matters. The
+working of C<id()> also allows the use of the class name
+as a I<generic object> as described L<further down|/"The Generic Object">.
+
+The C<id()> function is incorporated in I<id hashes> in the sense
+that it is called automatically on every key that is used with
+the hash. No explicit call is necessary.
+
+The problems of garbage collection and thread safety are both
+addressed by the function C<register()>. It registers an object
+together with any number of hashes. Registry means that when the
+object dies, an entry in any of the hashes under the reference
+address of this object will be deleted. This guarantees garbage
+collection in these hashes. It also means that on thread
+cloning the object's entries in registered hashes will be
+replaced with updated entries whose key is the cloned object's
+reference address. Thus the object-data association becomes
+thread-safe.
+
+Object registry is best done when the object is initialized
+for use with a class. That way, garbage collection and thread
+safety are established for every object and every field that is
+initialized.
+
+Finally, I<field hashes> incorporate all these functions in one
+package. Besides automatically calling the C<id()> function
+on every object used as a key, the object is registered with
+the field hash on first use. Classes based on field hashes
+are fully garbage-collected and thread safe without further
+measures.
+
+=head2 More Problems
+
+Another problem that occurs with inside-out classes is serialization.
+Since the object data is not in its usual place, standard routines
+like C<Storable::freeze()>, C<Storable::thaw()> and
+C<Data::Dumper::Dumper()> can't deal with it on their own. Both
+C<Data::Dumper> and C<Storable> provide the necessary hooks to
+make things work, but the functions or methods used by the hooks
+must be provided by each inside-out class.
+
+A general solution to the serialization problem would require another
+level of registry, one that that associates I<classes> and fields.
+So far, the functions of C<Hash::Util::FieldHash> are unaware of
+any classes, which I consider a feature. Therefore C<Hash::Util::FieldHash>
+doesn't address the serialization problems.
+
+=head2 The Generic Object
+
+Classes based on the C<id()> function (and hence classes based on
+C<idhash()> and C<fieldhash()>) show a peculiar behavior in that
+the class name can be used like an object. Specifically, methods
+that set or read data associated with an object continue to work as
+class methods, just as if the class name were an object, distinct from
+all other objects, with its own data. This object may be called
+the I<generic object> of the class.
+
+This works because field hashes respond to keys that are not references
+like a normal hash would and use the string offered as the hash key.
+Thus, if a method is called as a class method, the field hash is presented
+with the class name instead of an object and blithely uses it as a key.
+Since the keys of real objects are decimal numbers, there is no
+conflict and the slot in the field hash can be used like any other.
+The C<id()> function behaves correspondingly with respect to non-reference
+arguments.
+
+Two possible uses (besides ignoring the property) come to mind.
+A singleton class could be implemented this using the generic object.
+If necessary, an C<init()> method could die or ignore calls with
+actual objects (references), so only the generic object will ever exist.
+
+Another use of the generic object would be as a template. It is
+a convenient place to store class-specific defaults for various
+fields to be used in actual object initialization.
+
+Usually, the feature can be entirely ignored. Calling I<object
+methods> as I<class methods> normally leads to an error and isn't used
+routinely anywhere. It may be a problem that this error isn't
+indicated by a class with a generic object.
+
+=head2 How to use Field Hashes
+
+Traditionally, the definition of an inside-out class contains a bare
+block inside which a number of lexical hashes are declared and the
+basic accessor methods defined, usually through C<Scalar::Util::refaddr>.
+Further methods may be defined outside this block. There has to be
+a DESTROY method and, for thread support, a CLONE method.
+
+When field hashes are used, the basic structure remains the same.
+Each lexical hash will be made a field hash. The call to C<refaddr>
+can be omitted from the accessor methods. DESTROY and CLONE methods
+are not necessary.
+
+If you have an existing inside-out class, simply making all hashes
+field hashes with no other change should make no difference. Through
+the calls to C<refaddr> or equivalent, the field hashes never get to
+see a reference and work like normal hashes. Your DESTROY (and
+CLONE) methods are still needed.
+
+To make the field hashes kick in, it is easiest to redefine C<refaddr>
+as
+
+ sub refaddr { shift }
+
+instead of importing it from C<Scalar::Util>. It should now be possible
+to disable DESTROY and CLONE. Note that while it isn't disabled,
+DESTROY will be called before the garbage collection of field hashes,
+so it will be invoked with a functional object and will continue to
+function.
+
+It is not desirable to import the functions C<fieldhash> and/or
+C<fieldhashes> into every class that is going to use them. They
+are only used once to set up the class. When the class is up and running,
+these functions serve no more purpose.
+
+If there are only a few field hashes to declare, it is simplest to
+
+ use Hash::Util::FieldHash;
+
+early and call the functions qualified:
+
+ Hash::Util::FieldHash::fieldhash my %foo;
+
+Otherwise, import the functions into a convenient package like
+C<HUF> or, more general, C<Aux>
+
+ {
+ package Aux;
+ use Hash::Util::FieldHash ':all';
+ }
+
+and call
+
+ Aux::fieldhash my %foo;
+
+as needed.
+
+=head2 Garbage-Collected Hashes
+
+Garbage collection in a field hash means that entries will "spontaneously"
+disappear when the object that created them disappears. That must be
+borne in mind, especially when looping over a field hash. If anything
+you do inside the loop could cause an object to go out of scope, a
+random key may be deleted from the hash you are looping over. That
+can throw the loop iterator, so it's best to cache a consistent snapshot
+of the keys and/or values and loop over that. You will still have to
+check that a cached entry still exists when you get to it.
+
+Garbage collection can be confusing when keys are created in a field hash
+from normal scalars as well as references. Once a reference is I<used> with
+a field hash, the entry will be collected, even if it was later overwritten
+with a plain scalar key (every positive integer is a candidate). This
+is true even if the original entry was deleted in the meantime. In fact,
+deletion from a field hash, and also a test for existence constitute
+I<use> in this sense and create a liability to delete the entry when
+the reference goes out of scope. If you happen to create an entry
+with an identical key from a string or integer, that will be collected
+instead. Thus, mixed use of references and plain scalars as field hash
+keys is not entirely supported.
+
+=head1 EXAMPLES
+
+The examples show a very simple class that implements a I<name>, consisting
+of a first and last name (no middle initial). The name class has four
+methods:
+
+=over
+
+=item * C<init()>
+
+An object method that initializes the first and last name to its
+two arguments. If called as a class method, C<init()> creates an
+object in the given class and initializes that.
+
+=item * C<first()>
+
+Retrieve the first name
+
+=item * C<last()>
+
+Retrieve the last name
+
+=item * C<name()>
+
+Retrieve the full name, the first and last name joined by a blank.
+
+=back
+
+The examples show this class implemented with different levels of
+support by C<Hash::Util::FieldHash>. All supported combinations
+are shown. The difference between implementations is often quite
+small. The implementations are:
+
+=over
+
+=item * C<Name_hash>
+
+A conventional (not inside-out) implementation where an object is
+a hash that stores the field values, without support by
+C<Hash::Util::FieldHash>. This implementation doesn't allow
+arbitrary inheritance.
+
+=item * C<Name_id>
+
+Inside-out implementation based on the C<id()> function. It needs
+a C<DESTROY> method. For thread support a C<CLONE> method (not shown)
+would also be needed. Instead of C<Hash::Util::FieldHash::id()> the
+function C<Scalar::Util::refaddr> could be used with very little
+functional difference. This is the basic pattern of an inside-out
+class.
+
+=item * C<Name_idhash>
+
+Idhash-based inside-out implementation. Like L<Name_id> it needs
+a C<DESTROY> method and would need C<CLONE> for thread support.
+
+=item * C<Name_id_reg>
+
+Inside-out implementation based on the C<id()> function with explicit
+object registry. No destructor is needed and objects are thread safe.
+
+=item * C<Name_idhash_reg>
+
+Idhash-based inside-out implementation with explicit object registry.
+No destructor is needed and objects are thread safe.
+
+=item * C<Name_fieldhash>
+
+FieldHash-based inside-out implementation. Object registry happens
+automatically. No destructor is needed and objects are thread safe.
+
+=back
+
+These examples are realized in the code below, which could be copied
+to a file F<Example.pm>.
+
+=head2 Example 1
+
+ use strict; use warnings;
+
+ {
+ package Name_hash; # standard implementation: the object is a hash
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless {}, $obj unless ref $obj;
+ $obj->{ first} = $first;
+ $obj->{ last} = $last;
+ $obj;
+ }
+
+ sub first { shift()->{ first} }
+ sub last { shift()->{ last} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+
+ }
+
+ {
+ package Name_id;
+ use Hash::Util::FieldHash qw(id);
+
+ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ $first{ id $obj} = $first;
+ $last{ id $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ id shift()} }
+ sub last { $last{ id shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+
+ sub DESTROY {
+ my $id = id shift;
+ delete $first{ $id};
+ delete $last{ $id};
+ }
+
+ }
+
+ {
+ package Name_idhash;
+ use Hash::Util::FieldHash;
+
+ Hash::Util::FieldHash::idhashes( \ my (%first, %last) );
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ $first{ $obj} = $first;
+ $last{ $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ shift()} }
+ sub last { $last{ shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+
+ sub DESTROY {
+ my $n = shift;
+ delete $first{ $n};
+ delete $last{ $n};
+ }
+
+ }
+
+ {
+ package Name_id_reg;
+ use Hash::Util::FieldHash qw(id register);
+
+ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ register( $obj, \ (%first, %last) );
+ $first{ id $obj} = $first;
+ $last{ id $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ id shift()} }
+ sub last { $last{ id shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+ }
+
+ {
+ package Name_idhash_reg;
+ use Hash::Util::FieldHash qw(register);
+
+ Hash::Util::FieldHash::idhashes \ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ register( $obj, \ (%first, %last) );
+ $first{ $obj} = $first;
+ $last{ $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ shift()} }
+ sub last { $last{ shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+ }
+
+ {
+ package Name_fieldhash;
+ use Hash::Util::FieldHash;
+
+ Hash::Util::FieldHash::fieldhashes \ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ $first{ $obj} = $first;
+ $last{ $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ shift()} }
+ sub last { $last{ shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+ }
+
+ 1;
+
+To exercise the various implementations the script L<below|/"Example 2"> can
+be used.
+
+It sets up a class C<Name> that is a mirror of one of the implementation
+classes C<Name_hash>, C<Name_id>, ..., C<Name_fieldhash>. That determines
+which implementation is run.
+
+The script first verifies the function of the C<Name> class.
+
+In the second step, the free inheritability of the implementation
+(or lack thereof) is demonstrated. For this purpose it constructs
+a class called C<NamedFile> which is a common subclass of C<Name> and
+the standard class C<IO::File>. This puts inheritability to the test
+because objects of C<IO::File> I<must> be globrefs. Objects of C<NamedFile>
+should behave like a file opened for reading and also support the C<name()>
+method. This class juncture works with exception of the C<Name_hash>
+implementation, where object initialization fails because of the
+incompatibility of object bodies.
+
+=head2 Example 2
+
+ use strict; use warnings; $| = 1;
+
+ use Example;
+
+ {
+ package Name;
+ use base 'Name_id'; # define here which implementation to run
+ }
+
+
+ # Verify that the base package works
+ my $n = Name->init(qw(Albert Einstein));
+ print $n->name, "\n";
+ print "\n";
+
+ # Create a named file handle (See definition below)
+ my $nf = NamedFile->init(qw(/tmp/x Filomena File));
+ # use as a file handle...
+ for ( 1 .. 3 ) {
+ my $l = <$nf>;
+ print "line $_: $l";
+ }
+ # ...and as a Name object
+ print "...brought to you by ", $nf->name, "\n";
+ exit;
+
+
+ # Definition of NamedFile
+ package NamedFile;
+ use base 'Name';
+ use base 'IO::File';
+
+ sub init {
+ my $obj = shift;
+ my ($file, $first, $last) = @_;
+ $obj = $obj->IO::File::new() unless ref $obj;
+ $obj->open($file) or die "Can't read '$file': $!";
+ $obj->Name::init($first, $last);
+ }
+ __END__
+
+
+=head1 GUTS
+
+To make C<Hash::Util::FieldHash> work, there were two changes to
+F<perl> itself. C<PERL_MAGIC_uvar> was made avalaible for hashes,
+and weak references now call uvar C<get> magic after a weakref has been
+cleared. The first feature is used to make field hashes intercept
+their keys upon access. The second one triggers garbage collection.
+
+=head2 The C<PERL_MAGIC_uvar> interface for hashes
+
+C<PERL_MAGIC_uvar> I<get> magic is called from C<hv_fetch_common> and
+C<hv_delete_common> through the function C<hv_magic_uvar_xkey>, which
+defines the interface. The call happens for hashes with "uvar" magic
+if the C<ufuncs> structure has equal values in the C<uf_val> and C<uf_set>
+fields. Hashes are unaffected if (and as long as) these fields
+hold different values.
+
+Upon the call, the C<mg_obj> field will hold the hash key to be accessed.
+Upon return, the C<SV*> value in C<mg_obj> will be used in place of the
+original key in the hash access. The integer index value in the first
+parameter will be the C<action> value from C<hv_fetch_common>, or -1
+if the call is from C<hv_delete_common>.
+
+This is a template for a function suitable for the C<uf_val> field in
+a C<ufuncs> structure for this call. The C<uf_set> and C<uf_index>
+fields are irrelevant.
+
+ IV watch_key(pTHX_ IV action, SV* field) {
+ MAGIC* mg = mg_find(field, PERL_MAGIC_uvar);
+ SV* keysv = mg->mg_obj;
+ /* Do whatever you need to. If you decide to
+ supply a different key newkey, return it like this
+ */
+ sv_2mortal(newkey);
+ mg->mg_obj = newkey;
+ return 0;
+ }
+
+=head2 Weakrefs call uvar magic
+
+When a weak reference is stored in an C<SV> that has "uvar" magic, C<set>
+magic is called after the reference has gone stale. This hook can be
+used to trigger further garbage-collection activities associated with
+the referenced object.
+
+=head2 How field hashes work
+
+The three features of key hashes, I<key replacement>, I<thread support>,
+and I<garbage collection> are supported by a data structure called
+the I<object registry>. This is a private hash where every object
+is stored. An "object" in this sense is any reference (blessed or
+unblessed) that has been used as a field hash key.
+
+The object registry keeps track of references that have been used as
+field hash keys. The keys are generated from the reference address
+like in a field hash (though the registry isn't a field hash). Each
+value is a weak copy of the original reference, stored in an C<SV> that
+is itself magical (C<PERL_MAGIC_uvar> again). The magical structure
+holds a list (another hash, really) of field hashes that the reference
+has been used with. When the weakref becomes stale, the magic is
+activated and uses the list to delete the reference from all field
+hashes it has been used with. After that, the entry is removed from
+the object registry itself. Implicitly, that frees the magic structure
+and the storage it has been using.
+
+Whenever a reference is used as a field hash key, the object registry
+is checked and a new entry is made if necessary. The field hash is
+then added to the list of fields this reference has used.
+
+The object registry is also used to repair a field hash after thread
+cloning. Here, the entire object registry is processed. For every
+reference found there, the field hashes it has used are visited and
+the entry is updated.
+
+=head2 Internal function Hash::Util::FieldHash::_fieldhash
+
+ # test if %hash is a field hash
+ my $result = _fieldhash \ %hash, 0;
+
+ # make %hash a field hash
+ my $result = _fieldhash \ %hash, 1;
+
+C<_fieldhash> is the internal function used to create field hashes.
+It takes two arguments, a hashref and a mode. If the mode is boolean
+false, the hash is not changed but tested if it is a field hash. If
+the hash isn't a field hash the return value is boolean false. If it
+is, the return value indicates the mode of field hash. When called with
+a boolean true mode, it turns the given hash into a field hash of this
+mode, returning the mode of the created field hash. C<_fieldhash>
+does not erase the given hash.
+
+Currently there is only one type of field hash, and only the boolean
+value of the mode makes a difference, but that may change.
+
+=head1 AUTHOR
+
+Anno Siegel (ANNO) wrote the xs code and the changes in perl proper
+Jerry Hedden (JDHEDDEN) made it faster
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006-2007 by (Anno Siegel)
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.7 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/I18N/Collate.pm b/Master/tlpkg/tlperl.straw/lib/I18N/Collate.pm
new file mode 100755
index 00000000000..decc86ce3fe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/I18N/Collate.pm
@@ -0,0 +1,196 @@
+package I18N::Collate;
+
+use strict;
+our $VERSION = '1.01';
+
+=head1 NAME
+
+I18N::Collate - compare 8-bit scalar data according to the current locale
+
+=head1 SYNOPSIS
+
+ use I18N::Collate;
+ setlocale(LC_COLLATE, 'locale-of-your-choice');
+ $s1 = I18N::Collate->new("scalar_data_1");
+ $s2 = I18N::Collate->new("scalar_data_2");
+
+=head1 DESCRIPTION
+
+ ***
+
+ WARNING: starting from the Perl version 5.003_06
+ the I18N::Collate interface for comparing 8-bit scalar data
+ according to the current locale
+
+ HAS BEEN DEPRECATED
+
+ That is, please do not use it anymore for any new applications
+ and please migrate the old applications away from it because its
+ functionality was integrated into the Perl core language in the
+ release 5.003_06.
+
+ See the perllocale manual page for further information.
+
+ ***
+
+This module provides you with objects that will collate
+according to your national character set, provided that the
+POSIX setlocale() function is supported on your system.
+
+You can compare $s1 and $s2 above with
+
+ $s1 le $s2
+
+to extract the data itself, you'll need a dereference: $$s1
+
+This module uses POSIX::setlocale(). The basic collation conversion is
+done by strxfrm() which terminates at NUL characters being a decent C
+routine. collate_xfrm() handles embedded NUL characters gracefully.
+
+The available locales depend on your operating system; try whether
+C<locale -a> shows them or man pages for "locale" or "nlsinfo" or the
+direct approach C<ls /usr/lib/nls/loc> or C<ls /usr/lib/nls> or
+C<ls /usr/lib/locale>. Not all the locales that your vendor supports
+are necessarily installed: please consult your operating system's
+documentation and possibly your local system administration. The
+locale names are probably something like C<xx_XX.(ISO)?8859-N> or
+C<xx_XX.(ISO)?8859N>, for example C<fr_CH.ISO8859-1> is the Swiss (CH)
+variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western
+European character set.
+
+=cut
+
+# I18N::Collate.pm
+#
+# Author: Jarkko Hietaniemi <F<jhi@iki.fi>>
+# Helsinki University of Technology, Finland
+#
+# Acks: Guy Decoux <F<decoux@moulon.inra.fr>> understood
+# overloading magic much deeper than I and told
+# how to cut the size of this code by more than half.
+# (my first version did overload all of lt gt eq le ge cmp)
+#
+# Purpose: compare 8-bit scalar data according to the current locale
+#
+# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm()
+#
+# Exports: setlocale 1)
+# collate_xfrm 2)
+#
+# Overloads: cmp # 3)
+#
+# Usage: use I18N::Collate;
+# setlocale(LC_COLLATE, 'locale-of-your-choice'); # 4)
+# $s1 = I18N::Collate->("scalar_data_1");
+# $s2 = I18N::Collate->("scalar_data_2");
+#
+# now you can compare $s1 and $s2: $s1 le $s2
+# to extract the data itself, you need to deref: $$s1
+#
+# Notes:
+# 1) this uses POSIX::setlocale
+# 2) the basic collation conversion is done by strxfrm() which
+# terminates at NUL characters being a decent C routine.
+# collate_xfrm handles embedded NUL characters gracefully.
+# 3) due to cmp and overload magic, lt le eq ge gt work also
+# 4) the available locales depend on your operating system;
+# try whether "locale -a" shows them or man pages for
+# "locale" or "nlsinfo" work or the more direct
+# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls".
+# Not all the locales that your vendor supports
+# are necessarily installed: please consult your
+# operating system's documentation.
+# The locale names are probably something like
+# 'xx_XX.(ISO)?8859-N' or 'xx_XX.(ISO)?8859N',
+# for example 'fr_CH.ISO8859-1' is the Swiss (CH)
+# variant of French (fr), ISO Latin (8859) 1 (-1)
+# which is the Western European character set.
+#
+# Updated: 19961005
+#
+# ---
+
+use POSIX qw(strxfrm LC_COLLATE);
+use warnings::register;
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
+our @EXPORT_OK = qw();
+
+use overload qw(
+fallback 1
+cmp collate_cmp
+);
+
+our($LOCALE, $C);
+
+our $please_use_I18N_Collate_even_if_deprecated = 0;
+sub new {
+ my $new = $_[1];
+
+ if (warnings::enabled() && $] >= 5.003_06) {
+ unless ($please_use_I18N_Collate_even_if_deprecated) {
+ warnings::warn <<___EOD___;
+***
+
+ WARNING: starting from the Perl version 5.003_06
+ the I18N::Collate interface for comparing 8-bit scalar data
+ according to the current locale
+
+ HAS BEEN DEPRECATED
+
+ That is, please do not use it anymore for any new applications
+ and please migrate the old applications away from it because its
+ functionality was integrated into the Perl core language in the
+ release 5.003_06.
+
+ See the perllocale manual page for further information.
+
+***
+___EOD___
+ $please_use_I18N_Collate_even_if_deprecated++;
+ }
+ }
+
+ bless \$new;
+}
+
+sub setlocale {
+ my ($category, $locale) = @_[0,1];
+
+ POSIX::setlocale($category, $locale) if (defined $category);
+ # the current $LOCALE
+ $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || '';
+}
+
+sub C {
+ my $s = ${$_[0]};
+
+ $C->{$LOCALE}->{$s} = collate_xfrm($s)
+ unless (defined $C->{$LOCALE}->{$s}); # cache when met
+
+ $C->{$LOCALE}->{$s};
+}
+
+sub collate_xfrm {
+ my $s = $_[0];
+ my $x = '';
+
+ for (split(/(\000+)/, $s)) {
+ $x .= (/^\000/) ? $_ : strxfrm("$_\000");
+ }
+
+ $x;
+}
+
+sub collate_cmp {
+ &C($_[0]) cmp &C($_[1]);
+}
+
+# init $LOCALE
+
+&I18N::Collate::setlocale();
+
+1; # keep require happy
diff --git a/Master/tlpkg/tlperl.straw/lib/I18N/LangTags.pm b/Master/tlpkg/tlperl.straw/lib/I18N/LangTags.pm
new file mode 100755
index 00000000000..0bdc65fed1e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/I18N/LangTags.pm
@@ -0,0 +1,887 @@
+
+# Time-stamp: "2004-10-06 23:26:33 ADT"
+# Sean M. Burke <sburke@cpan.org>
+
+require 5.000;
+package I18N::LangTags;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %Panic);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw();
+@EXPORT_OK = qw(is_language_tag same_language_tag
+ extract_language_tags super_languages
+ similarity_language_tag is_dialect_of
+ locale2language_tag alternate_language_tags
+ encode_language_tag panic_languages
+ implicate_supers
+ implicate_supers_strictly
+ );
+%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
+
+$VERSION = "0.35";
+
+sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function
+
+
+=head1 NAME
+
+I18N::LangTags - functions for dealing with RFC3066-style language tags
+
+=head1 SYNOPSIS
+
+ use I18N::LangTags();
+
+...or specify whichever of those functions you want to import, like so:
+
+ use I18N::LangTags qw(implicate_supers similarity_language_tag);
+
+All the exportable functions are listed below -- you're free to import
+only some, or none at all. By default, none are imported. If you
+say:
+
+ use I18N::LangTags qw(:ALL)
+
+...then all are exported. (This saves you from having to use
+something less obvious like C<use I18N::LangTags qw(/./)>.)
+
+If you don't import any of these functions, assume a C<&I18N::LangTags::>
+in front of all the function names in the following examples.
+
+=head1 DESCRIPTION
+
+Language tags are a formalism, described in RFC 3066 (obsoleting
+1766), for declaring what language form (language and possibly
+dialect) a given chunk of information is in.
+
+This library provides functions for common tasks involving language
+tags as they are needed in a variety of protocols and applications.
+
+Please see the "See Also" references for a thorough explanation
+of how to correctly use language tags.
+
+=over
+
+=cut
+
+###########################################################################
+
+=item * the function is_language_tag($lang1)
+
+Returns true iff $lang1 is a formally valid language tag.
+
+ is_language_tag("fr") is TRUE
+ is_language_tag("x-jicarilla") is FALSE
+ (Subtags can be 8 chars long at most -- 'jicarilla' is 9)
+
+ is_language_tag("sgn-US") is TRUE
+ (That's American Sign Language)
+
+ is_language_tag("i-Klikitat") is TRUE
+ (True without regard to the fact noone has actually
+ registered Klikitat -- it's a formally valid tag)
+
+ is_language_tag("fr-patois") is TRUE
+ (Formally valid -- altho descriptively weak!)
+
+ is_language_tag("Spanish") is FALSE
+ is_language_tag("french-patois") is FALSE
+ (No good -- first subtag has to match
+ /^([xXiI]|[a-zA-Z]{2,3})$/ -- see RFC3066)
+
+ is_language_tag("x-borg-prot2532") is TRUE
+ (Yes, subtags can contain digits, as of RFC3066)
+
+=cut
+
+sub is_language_tag {
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($tag) = lc($_[0]);
+
+ return 0 if $tag eq "i" or $tag eq "x";
+ # Bad degenerate cases that the following
+ # regexp would erroneously let pass
+
+ return $tag =~
+ /^(?: # First subtag
+ [xi] | [a-z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-z0-9]{1,8} # subtag
+ )*
+ $/xs ? 1 : 0;
+}
+
+###########################################################################
+
+=item * the function extract_language_tags($whatever)
+
+Returns a list of whatever looks like formally valid language tags
+in $whatever. Not very smart, so don't get too creative with
+what you want to feed it.
+
+ extract_language_tags("fr, fr-ca, i-mingo")
+ returns: ('fr', 'fr-ca', 'i-mingo')
+
+ extract_language_tags("It's like this: I'm in fr -- French!")
+ returns: ('It', 'in', 'fr')
+ (So don't just feed it any old thing.)
+
+The output is untainted. If you don't know what tainting is,
+don't worry about it.
+
+=cut
+
+sub extract_language_tags {
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($text) =
+ $_[0] =~ m/(.+)/ # to make for an untainted result
+ ? $1 : ''
+ ;
+
+ return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags
+ $text =~
+ m/
+ \b
+ (?: # First subtag
+ [iIxX] | [a-zA-Z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-zA-Z0-9]{1,8} # subtag
+ )*
+ \b
+ /xsg
+ );
+}
+
+###########################################################################
+
+=item * the function same_language_tag($lang1, $lang2)
+
+Returns true iff $lang1 and $lang2 are acceptable variant tags
+representing the same language-form.
+
+ same_language_tag('x-kadara', 'i-kadara') is TRUE
+ (The x/i- alternation doesn't matter)
+ same_language_tag('X-KADARA', 'i-kadara') is TRUE
+ (...and neither does case)
+ same_language_tag('en', 'en-US') is FALSE
+ (all-English is not the SAME as US English)
+ same_language_tag('x-kadara', 'x-kadar') is FALSE
+ (these are totally unrelated tags)
+ same_language_tag('no-bok', 'nb') is TRUE
+ (no-bok is a legacy tag for nb (Norwegian Bokmal))
+
+C<same_language_tag> works by just seeing whether
+C<encode_language_tag($lang1)> is the same as
+C<encode_language_tag($lang2)>.
+
+(Yes, I know this function is named a bit oddly. Call it historic
+reasons.)
+
+=cut
+
+sub same_language_tag {
+ my $el1 = &encode_language_tag($_[0]);
+ return 0 unless defined $el1;
+ # this avoids the problem of
+ # encode_language_tag($lang1) eq and encode_language_tag($lang2)
+ # being true if $lang1 and $lang2 are both undef
+
+ return $el1 eq &encode_language_tag($_[1]) ? 1 : 0;
+}
+
+###########################################################################
+
+=item * the function similarity_language_tag($lang1, $lang2)
+
+Returns an integer representing the degree of similarity between
+tags $lang1 and $lang2 (the order of which does not matter), where
+similarity is the number of common elements on the left,
+without regard to case and to x/i- alternation.
+
+ similarity_language_tag('fr', 'fr-ca') is 1
+ (one element in common)
+ similarity_language_tag('fr-ca', 'fr-FR') is 1
+ (one element in common)
+
+ similarity_language_tag('fr-CA-joual',
+ 'fr-CA-PEI') is 2
+ similarity_language_tag('fr-CA-joual', 'fr-CA') is 2
+ (two elements in common)
+
+ similarity_language_tag('x-kadara', 'i-kadara') is 1
+ (x/i- doesn't matter)
+
+ similarity_language_tag('en', 'x-kadar') is 0
+ similarity_language_tag('x-kadara', 'x-kadar') is 0
+ (unrelated tags -- no similarity)
+
+ similarity_language_tag('i-cree-syllabic',
+ 'i-cherokee-syllabic') is 0
+ (no B<leftmost> elements in common!)
+
+=cut
+
+sub similarity_language_tag {
+ my $lang1 = &encode_language_tag($_[0]);
+ my $lang2 = &encode_language_tag($_[1]);
+ # And encode_language_tag takes care of the whole
+ # no-nyn==nn, i-hakka==zh-hakka, etc, things
+
+ # NB: (i-sil-...)? (i-sgn-...)?
+
+ return undef if !defined($lang1) and !defined($lang2);
+ return 0 if !defined($lang1) or !defined($lang2);
+
+ my @l1_subtags = split('-', $lang1);
+ my @l2_subtags = split('-', $lang2);
+ my $similarity = 0;
+
+ while(@l1_subtags and @l2_subtags) {
+ if(shift(@l1_subtags) eq shift(@l2_subtags)) {
+ ++$similarity;
+ } else {
+ last;
+ }
+ }
+ return $similarity;
+}
+
+###########################################################################
+
+=item * the function is_dialect_of($lang1, $lang2)
+
+Returns true iff language tag $lang1 represents a subform of
+language tag $lang2.
+
+B<Get the order right! It doesn't work the other way around!>
+
+ is_dialect_of('en-US', 'en') is TRUE
+ (American English IS a dialect of all-English)
+
+ is_dialect_of('fr-CA-joual', 'fr-CA') is TRUE
+ is_dialect_of('fr-CA-joual', 'fr') is TRUE
+ (Joual is a dialect of (a dialect of) French)
+
+ is_dialect_of('en', 'en-US') is FALSE
+ (all-English is a NOT dialect of American English)
+
+ is_dialect_of('fr', 'en-CA') is FALSE
+
+ is_dialect_of('en', 'en' ) is TRUE
+ is_dialect_of('en-US', 'en-US') is TRUE
+ (B<Note:> these are degenerate cases)
+
+ is_dialect_of('i-mingo-tom', 'x-Mingo') is TRUE
+ (the x/i thing doesn't matter, nor does case)
+
+ is_dialect_of('nn', 'no') is TRUE
+ (because 'nn' (New Norse) is aliased to 'no-nyn',
+ as a special legacy case, and 'no-nyn' is a
+ subform of 'no' (Norwegian))
+
+=cut
+
+sub is_dialect_of {
+
+ my $lang1 = &encode_language_tag($_[0]);
+ my $lang2 = &encode_language_tag($_[1]);
+
+ return undef if !defined($lang1) and !defined($lang2);
+ return 0 if !defined($lang1) or !defined($lang2);
+
+ return 1 if $lang1 eq $lang2;
+ return 0 if length($lang1) < length($lang2);
+
+ $lang1 .= '-';
+ $lang2 .= '-';
+ return
+ (substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0;
+}
+
+###########################################################################
+
+=item * the function super_languages($lang1)
+
+Returns a list of language tags that are superordinate tags to $lang1
+-- it gets this by removing subtags from the end of $lang1 until
+nothing (or just "i" or "x") is left.
+
+ super_languages("fr-CA-joual") is ("fr-CA", "fr")
+
+ super_languages("en-AU") is ("en")
+
+ super_languages("en") is empty-list, ()
+
+ super_languages("i-cherokee") is empty-list, ()
+ ...not ("i"), which would be illegal as well as pointless.
+
+If $lang1 is not a valid language tag, returns empty-list in
+a list context, undef in a scalar context.
+
+A notable and rather unavoidable problem with this method:
+"x-mingo-tom" has an "x" because the whole tag isn't an
+IANA-registered tag -- but super_languages('x-mingo-tom') is
+('x-mingo') -- which isn't really right, since 'i-mingo' is
+registered. But this module has no way of knowing that. (But note
+that same_language_tag('x-mingo', 'i-mingo') is TRUE.)
+
+More importantly, you assume I<at your peril> that superordinates of
+$lang1 are mutually intelligible with $lang1. Consider this
+carefully.
+
+=cut
+
+sub super_languages {
+ my $lang1 = $_[0];
+ return() unless defined($lang1) && &is_language_tag($lang1);
+
+ # a hack for those annoying new (2001) tags:
+ $lang1 =~ s/^nb\b/no-bok/i; # yes, backwards
+ $lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards
+ $lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way
+ # i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark
+
+ my @l1_subtags = split('-', $lang1);
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ # NB: (i-sil-...)?
+
+ my @supers = ();
+ foreach my $bit (@l1_subtags) {
+ push @supers,
+ scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
+ }
+ pop @supers if @supers;
+ shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s;
+ return reverse @supers;
+}
+
+###########################################################################
+
+=item * the function locale2language_tag($locale_identifier)
+
+This takes a locale name (like "en", "en_US", or "en_US.ISO8859-1")
+and maps it to a language tag. If it's not mappable (as with,
+notably, "C" and "POSIX"), this returns empty-list in a list context,
+or undef in a scalar context.
+
+ locale2language_tag("en") is "en"
+
+ locale2language_tag("en_US") is "en-US"
+
+ locale2language_tag("en_US.ISO8859-1") is "en-US"
+
+ locale2language_tag("C") is undef or ()
+
+ locale2language_tag("POSIX") is undef or ()
+
+ locale2language_tag("POSIX") is undef or ()
+
+I'm not totally sure that locale names map satisfactorily to language
+tags. Think REAL hard about how you use this. YOU HAVE BEEN WARNED.
+
+The output is untainted. If you don't know what tainting is,
+don't worry about it.
+
+=cut
+
+sub locale2language_tag {
+ my $lang =
+ $_[0] =~ m/(.+)/ # to make for an untainted result
+ ? $1 : ''
+ ;
+
+ return $lang if &is_language_tag($lang); # like "en"
+
+ $lang =~ tr<_><->; # "en_US" -> en-US
+ $lang =~ s<(?:[\.\@][-_a-zA-Z0-9]+)+$><>s; # "en_US.ISO8859-1" -> en-US
+ # it_IT.utf8@euro => it-IT
+
+ return $lang if &is_language_tag($lang);
+
+ return;
+}
+
+###########################################################################
+
+=item * the function encode_language_tag($lang1)
+
+This function, if given a language tag, returns an encoding of it such
+that:
+
+* tags representing different languages never get the same encoding.
+
+* tags representing the same language always get the same encoding.
+
+* an encoding of a formally valid language tag always is a string
+value that is defined, has length, and is true if considered as a
+boolean.
+
+Note that the encoding itself is B<not> a formally valid language tag.
+Note also that you cannot, currently, go from an encoding back to a
+language tag that it's an encoding of.
+
+Note also that you B<must> consider the encoded value as atomic; i.e.,
+you should not consider it as anything but an opaque, unanalysable
+string value. (The internals of the encoding method may change in
+future versions, as the language tagging standard changes over time.)
+
+C<encode_language_tag> returns undef if given anything other than a
+formally valid language tag.
+
+The reason C<encode_language_tag> exists is because different language
+tags may represent the same language; this is normally treatable with
+C<same_language_tag>, but consider this situation:
+
+You have a data file that expresses greetings in different languages.
+Its format is "[language tag]=[how to say 'Hello']", like:
+
+ en-US=Hiho
+ fr=Bonjour
+ i-mingo=Hau'
+
+And suppose you write a program that reads that file and then runs as
+a daemon, answering client requests that specify a language tag and
+then expect the string that says how to greet in that language. So an
+interaction looks like:
+
+ greeting-client asks: fr
+ greeting-server answers: Bonjour
+
+So far so good. But suppose the way you're implementing this is:
+
+ my %greetings;
+ die unless open(IN, "<in.dat");
+ while(<IN>) {
+ chomp;
+ next unless /^([^=]+)=(.+)/s;
+ my($lang, $expr) = ($1, $2);
+ $greetings{$lang} = $expr;
+ }
+ close(IN);
+
+at which point %greetings has the contents:
+
+ "en-US" => "Hiho"
+ "fr" => "Bonjour"
+ "i-mingo" => "Hau'"
+
+And suppose then that you answer client requests for language $wanted
+by just looking up $greetings{$wanted}.
+
+If the client asks for "fr", that will look up successfully in
+%greetings, to the value "Bonjour". And if the client asks for
+"i-mingo", that will look up successfully in %greetings, to the value
+"Hau'".
+
+But if the client asks for "i-Mingo" or "x-mingo", or "Fr", then the
+lookup in %greetings fails. That's the Wrong Thing.
+
+You could instead do lookups on $wanted with:
+
+ use I18N::LangTags qw(same_language_tag);
+ my $response = '';
+ foreach my $l2 (keys %greetings) {
+ if(same_language_tag($wanted, $l2)) {
+ $response = $greetings{$l2};
+ last;
+ }
+ }
+
+But that's rather inefficient. A better way to do it is to start your
+program with:
+
+ use I18N::LangTags qw(encode_language_tag);
+ my %greetings;
+ die unless open(IN, "<in.dat");
+ while(<IN>) {
+ chomp;
+ next unless /^([^=]+)=(.+)/s;
+ my($lang, $expr) = ($1, $2);
+ $greetings{
+ encode_language_tag($lang)
+ } = $expr;
+ }
+ close(IN);
+
+and then just answer client requests for language $wanted by just
+looking up
+
+ $greetings{encode_language_tag($wanted)}
+
+And that does the Right Thing.
+
+=cut
+
+sub encode_language_tag {
+ # Only similarity_language_tag() is allowed to analyse encodings!
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($tag) = $_[0] || return undef;
+ return undef unless &is_language_tag($tag);
+
+ # For the moment, these legacy variances are few enough that
+ # we can just handle them here with regexps.
+ $tag =~ s/^iw\b/he/i; # Hebrew
+ $tag =~ s/^in\b/id/i; # Indonesian
+ $tag =~ s/^cre\b/cr/i; # Cree
+ $tag =~ s/^jw\b/jv/i; # Javanese
+ $tag =~ s/^[ix]-lux\b/lb/i; # Luxemburger
+ $tag =~ s/^[ix]-navajo\b/nv/i; # Navajo
+ $tag =~ s/^ji\b/yi/i; # Yiddish
+ # SMB 2003 -- Hm. There's a bunch of new XXX->YY variances now,
+ # but maybe they're all so obscure I can ignore them. "Obscure"
+ # meaning either that the language is obscure, and/or that the
+ # XXX form was extant so briefly that it's unlikely it was ever
+ # used. I hope.
+ #
+ # These go FROM the simplex to complex form, to get
+ # similarity-comparison right. And that's okay, since
+ # similarity_language_tag is the only thing that
+ # analyzes our output.
+ $tag =~ s/^[ix]-hakka\b/zh-hakka/i; # Hakka
+ $tag =~ s/^nb\b/no-bok/i; # BACKWARDS for Bokmal
+ $tag =~ s/^nn\b/no-nyn/i; # BACKWARDS for Nynorsk
+
+ $tag =~ s/^[xiXI]-//s;
+ # Just lop off any leading "x/i-"
+
+ return "~" . uc($tag);
+}
+
+#--------------------------------------------------------------------------
+
+=item * the function alternate_language_tags($lang1)
+
+This function, if given a language tag, returns all language tags that
+are alternate forms of this language tag. (I.e., tags which refer to
+the same language.) This is meant to handle legacy tags caused by
+the minor changes in language tag standards over the years; and
+the x-/i- alternation is also dealt with.
+
+Note that this function does I<not> try to equate new (and never-used,
+and unusable)
+ISO639-2 three-letter tags to old (and still in use) ISO639-1
+two-letter equivalents -- like "ara" -> "ar" -- because
+"ara" has I<never> been in use as an Internet language tag,
+and RFC 3066 stipulates that it never should be, since a shorter
+tag ("ar") exists.
+
+Examples:
+
+ alternate_language_tags('no-bok') is ('nb')
+ alternate_language_tags('nb') is ('no-bok')
+ alternate_language_tags('he') is ('iw')
+ alternate_language_tags('iw') is ('he')
+ alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka')
+ alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka')
+ alternate_language_tags('en') is ()
+ alternate_language_tags('x-mingo-tom') is ('i-mingo-tom')
+ alternate_language_tags('x-klikitat') is ('i-klikitat')
+ alternate_language_tags('i-klikitat') is ('x-klikitat')
+
+This function returns empty-list if given anything other than a formally
+valid language tag.
+
+=cut
+
+my %alt = qw( i x x i I X X I );
+sub alternate_language_tags {
+ my $tag = $_[0];
+ return() unless &is_language_tag($tag);
+
+ my @em; # push 'em real goood!
+
+ # For the moment, these legacy variances are few enough that
+ # we can just handle them here with regexps.
+
+ if( $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1";
+ } elsif($tag =~ m/^zh-hakka\b(.*)/i) { push @em, "x-hakka$1", "i-hakka$1";
+
+ } elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1";
+ } elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1";
+
+ } elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1";
+ } elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1";
+
+ } elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1";
+ } elsif($tag =~ m/^lb\b(.*)/i) { push @em, "i-lux$1", "x-lux$1";
+
+ } elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1";
+ } elsif($tag =~ m/^nv\b(.*)/i) { push @em, "i-navajo$1", "x-navajo$1";
+
+ } elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1";
+ } elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1";
+
+ } elsif($tag =~ m/^nb\b(.*)/i) { push @em, "no-bok$1";
+ } elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1";
+
+ } elsif($tag =~ m/^nn\b(.*)/i) { push @em, "no-nyn$1";
+ } elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1";
+ }
+
+ push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/;
+ return @em;
+}
+
+###########################################################################
+
+{
+ # Init %Panic...
+
+ my @panic = ( # MUST all be lowercase!
+ # Only large ("national") languages make it in this list.
+ # If you, as a user, are so bizarre that the /only/ language
+ # you claim to accept is Galician, then no, we won't do you
+ # the favor of providing Catalan as a panic-fallback for
+ # you. Because if I start trying to add "little languages" in
+ # here, I'll just go crazy.
+
+ # Scandinavian lgs. All based on opinion and hearsay.
+ 'sv' => [qw(nb no da nn)],
+ 'da' => [qw(nb no sv nn)], # I guess
+ [qw(no nn nb)], [qw(no nn nb sv da)],
+ 'is' => [qw(da sv no nb nn)],
+ 'fo' => [qw(da is no nb nn sv)], # I guess
+
+ # I think this is about the extent of tolerable intelligibility
+ # among large modern Romance languages.
+ 'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French
+ 'ca' => [qw(es pt it fr)],
+ 'es' => [qw(ca it fr pt)],
+ 'it' => [qw(es fr ca pt)],
+ 'fr' => [qw(es it ca pt)],
+
+ # Also assume that speakers of the main Indian languages prefer
+ # to read/hear Hindi over English
+ [qw(
+ as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur
+ )] => 'hi',
+ # Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri,
+ # Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya,
+ # Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu.
+ 'hi' => [qw(bn pa as or)],
+ # I welcome finer data for the other Indian languages.
+ # E.g., what should Oriya's list be, besides just Hindi?
+
+ # And the panic languages for English is, of course, nil!
+
+ # My guesses at Slavic intelligibility:
+ ([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukranian
+ 'sr' => 'hr', 'hr' => 'sr', # Serb + Croat
+ 'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak
+
+ 'ms' => 'id', 'id' => 'ms', # Malay + Indonesian
+
+ 'et' => 'fi', 'fi' => 'et', # Estonian + Finnish
+
+ #?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai
+
+ );
+ my($k,$v);
+ while(@panic) {
+ ($k,$v) = splice(@panic,0,2);
+ foreach my $k (ref($k) ? @$k : $k) {
+ foreach my $v (ref($v) ? @$v : $v) {
+ push @{$Panic{$k} ||= []}, $v unless $k eq $v;
+ }
+ }
+ }
+}
+
+=item * the function @langs = panic_languages(@accept_languages)
+
+This function takes a list of 0 or more language
+tags that constitute a given user's Accept-Language list, and
+returns a list of tags for I<other> (non-super)
+languages that are probably acceptable to the user, to be
+used I<if all else fails>.
+
+For example, if a user accepts only 'ca' (Catalan) and
+'es' (Spanish), and the documents/interfaces you have
+available are just in German, Italian, and Chinese, then
+the user will most likely want the Italian one (and not
+the Chinese or German one!), instead of getting
+nothing. So C<panic_languages('ca', 'es')> returns
+a list containing 'it' (Italian).
+
+English ('en') is I<always> in the return list, but
+whether it's at the very end or not depends
+on the input languages. This function works by consulting
+an internal table that stipulates what common
+languages are "close" to each other.
+
+A useful construct you might consider using is:
+
+ @fallbacks = super_languages(@accept_languages);
+ push @fallbacks, panic_languages(
+ @accept_languages, @fallbacks,
+ );
+
+=cut
+
+sub panic_languages {
+ # When in panic or in doubt, run in circles, scream, and shout!
+ my(@out, %seen);
+ foreach my $t (@_) {
+ next unless $t;
+ next if $seen{$t}++; # so we don't return it or hit it again
+ # push @out, super_languages($t); # nah, keep that separate
+ push @out, @{ $Panic{lc $t} || next };
+ }
+ return grep !$seen{$_}++, @out, 'en';
+}
+
+#---------------------------------------------------------------------------
+#---------------------------------------------------------------------------
+
+=item * the function implicate_supers( ...languages... )
+
+This takes a list of strings (which are presumed to be language-tags;
+strings that aren't, are ignored); and after each one, this function
+inserts super-ordinate forms that don't already appear in the list.
+The original list, plus these insertions, is returned.
+
+In other words, it takes this:
+
+ pt-br de-DE en-US fr pt-br-janeiro
+
+and returns this:
+
+ pt-br pt de-DE de en-US en fr pt-br-janeiro
+
+This function is most useful in the idiom
+
+ implicate_supers( I18N::LangTags::Detect::detect() );
+
+(See L<I18N::LangTags::Detect>.)
+
+
+=item * the function implicate_supers_strictly( ...languages... )
+
+This works like C<implicate_supers> except that the implicated
+forms are added to the end of the return list.
+
+In other words, implicate_supers_strictly takes a list of strings
+(which are presumed to be language-tags; strings that aren't, are
+ignored) and after the whole given list, it inserts the super-ordinate forms
+of all given tags, minus any tags that already appear in the input list.
+
+In other words, it takes this:
+
+ pt-br de-DE en-US fr pt-br-janeiro
+
+and returns this:
+
+ pt-br de-DE en-US fr pt-br-janeiro pt de en
+
+The reason this function has "_strictly" in its name is that when
+you're processing an Accept-Language list according to the RFCs, if
+you interpret the RFCs quite strictly, then you would use
+implicate_supers_strictly, but for normal use (i.e., common-sense use,
+as far as I'm concerned) you'd use implicate_supers.
+
+=cut
+
+sub implicate_supers {
+ my @languages = grep is_language_tag($_), @_;
+ my %seen_encoded;
+ foreach my $lang (@languages) {
+ $seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1
+ }
+
+ my(@output_languages);
+ foreach my $lang (@languages) {
+ push @output_languages, $lang;
+ foreach my $s ( I18N::LangTags::super_languages($lang) ) {
+ # Note that super_languages returns the longest first.
+ last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) };
+ push @output_languages, $s;
+ }
+ }
+ return uniq( @output_languages );
+
+}
+
+sub implicate_supers_strictly {
+ my @tags = grep is_language_tag($_), @_;
+ return uniq( @_, map super_languages($_), @_ );
+}
+
+
+
+###########################################################################
+1;
+__END__
+
+=back
+
+=head1 ABOUT LOWERCASING
+
+I've considered making all the above functions that output language
+tags return all those tags strictly in lowercase. Having all your
+language tags in lowercase does make some things easier. But you
+might as well just lowercase as you like, or call
+C<encode_language_tag($lang1)> where appropriate.
+
+=head1 ABOUT UNICODE PLAINTEXT LANGUAGE TAGS
+
+In some future version of I18N::LangTags, I plan to include support
+for RFC2482-style language tags -- which are basically just normal
+language tags with their ASCII characters shifted into Plane 14.
+
+=head1 SEE ALSO
+
+* L<I18N::LangTags::List|I18N::LangTags::List>
+
+* RFC 3066, C<ftp://ftp.isi.edu/in-notes/rfc3066.txt>, "Tags for the
+Identification of Languages". (Obsoletes RFC 1766)
+
+* RFC 2277, C<ftp://ftp.isi.edu/in-notes/rfc2277.txt>, "IETF Policy on
+Character Sets and Languages".
+
+* RFC 2231, C<ftp://ftp.isi.edu/in-notes/rfc2231.txt>, "MIME Parameter
+Value and Encoded Word Extensions: Character Sets, Languages, and
+Continuations".
+
+* RFC 2482, C<ftp://ftp.isi.edu/in-notes/rfc2482.txt>,
+"Language Tagging in Unicode Plain Text".
+
+* Locale::Codes, in
+C<http://www.perl.com/CPAN/modules/by-module/Locale/>
+
+* ISO 639-2, "Codes for the representation of names of languages",
+including two-letter and three-letter codes,
+C<http://www.loc.gov/standards/iso639-2/langcodes.html>
+
+* The IANA list of registered languages (hopefully up-to-date),
+C<http://www.iana.org/assignments/language-tags>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998+ Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+The programs and documentation in this dist are distributed in
+the hope that they will be useful, but without any warranty; without
+even the implied warranty of merchantability or fitness for a
+particular purpose.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/I18N/LangTags/Detect.pm b/Master/tlpkg/tlperl.straw/lib/I18N/LangTags/Detect.pm
new file mode 100755
index 00000000000..3f1b7c006ac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/I18N/LangTags/Detect.pm
@@ -0,0 +1,237 @@
+
+# Time-stamp: "2004-06-20 21:47:55 ADT"
+
+require 5;
+package I18N::LangTags::Detect;
+use strict;
+
+use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
+ $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
+
+BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
+ # define the constant 'DEBUG' at compile-time
+
+$VERSION = "1.03";
+@ISA = ();
+use I18N::LangTags qw(alternate_language_tags locale2language_tag);
+
+sub _uniq { my %seen; return grep(!($seen{$_}++), @_); }
+sub _normalize {
+ my(@languages) =
+ map lc($_),
+ grep $_,
+ map {; $_, alternate_language_tags($_) } @_;
+ return _uniq(@languages) if wantarray;
+ return $languages[0];
+}
+
+#---------------------------------------------------------------------------
+# The extent of our functional interface:
+
+sub detect () { return __PACKAGE__->ambient_langprefs; }
+
+#===========================================================================
+
+sub ambient_langprefs { # always returns things untainted
+ my $base_class = $_[0];
+
+ return $base_class->http_accept_langs
+ if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
+ # it's off in its own routine because it's complicated
+
+ # Not running as a CGI: try to puzzle out from the environment
+ my @languages;
+
+ foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
+ next unless $ENV{$envname};
+ DEBUG and print "Noting \$$envname: $ENV{$envname}\n";
+ push @languages,
+ map locale2language_tag($_),
+ # if it's a lg tag, fine, pass thru (untainted)
+ # if it's a locale ID, try converting to a lg tag (untainted),
+ # otherwise nix it.
+
+ split m/[,:]/,
+ $ENV{$envname}
+ ;
+ last; # first one wins
+ }
+
+ if($ENV{'IGNORE_WIN32_LOCALE'}) {
+ # no-op
+ } elsif(&_try_use('Win32::Locale')) {
+ # If we have that module installed...
+ push @languages, Win32::Locale::get_language() || ''
+ if defined &Win32::Locale::get_language;
+ }
+ return _normalize @languages;
+}
+
+#---------------------------------------------------------------------------
+
+sub http_accept_langs {
+ # Deal with HTTP "Accept-Language:" stuff. Hassle.
+ # This code is more lenient than RFC 3282, which you must read.
+ # Hm. Should I just move this into I18N::LangTags at some point?
+ no integer;
+
+ my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
+ # (always ends up untainting)
+
+ return() unless defined $in and length $in;
+
+ $in =~ s/\([^\)]*\)//g; # nix just about any comment
+
+ if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
+ # Very common case: just one language tag
+ return _normalize $1;
+ } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
+ # Common case these days: just "foo, bar, baz"
+ return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g );
+ }
+
+ # Else it's complicated...
+
+ $in =~ s/\s+//g; # Yes, we can just do without the WS!
+ my @in = $in =~ m/([^,]+)/g;
+ my %pref;
+
+ my $q;
+ foreach my $tag (@in) {
+ next unless $tag =~
+ m/^([a-zA-Z][-a-zA-Z]+)
+ (?:
+ ;q=
+ (
+ \d* # a bit too broad of a RE, but so what.
+ (?:
+ \.\d+
+ )?
+ )
+ )?
+ $
+ /sx
+ ;
+ $q = (defined $2 and length $2) ? $2 : 1;
+ #print "$1 with q=$q\n";
+ push @{ $pref{$q} }, lc $1;
+ }
+
+ return _normalize(
+ # Read off %pref, in descending key order...
+ map @{$pref{$_}},
+ sort {$b <=> $a}
+ keys %pref
+ );
+}
+
+#===========================================================================
+
+my %tried = ();
+ # memoization of whether we've used this module, or found it unusable.
+
+sub _try_use { # Basically a wrapper around "require Modulename"
+ # "Many men have tried..." "They tried and failed?" "They tried and died."
+ return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
+
+ my $module = $_[0]; # ASSUME sane module name!
+ { no strict 'refs';
+ return($tried{$module} = 1)
+ if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
+ # weird case: we never use'd it, but there it is!
+ }
+
+ print " About to use $module ...\n" if DEBUG;
+ {
+ local $SIG{'__DIE__'};
+ eval "require $module"; # used to be "use $module", but no point in that.
+ }
+ if($@) {
+ print "Error using $module \: $@\n" if DEBUG > 1;
+ return $tried{$module} = 0;
+ } else {
+ print " OK, $module is used\n" if DEBUG;
+ return $tried{$module} = 1;
+ }
+}
+
+#---------------------------------------------------------------------------
+1;
+__END__
+
+
+=head1 NAME
+
+I18N::LangTags::Detect - detect the user's language preferences
+
+=head1 SYNOPSIS
+
+ use I18N::LangTags::Detect;
+ my @user_wants = I18N::LangTags::Detect::detect();
+
+=head1 DESCRIPTION
+
+It is a common problem to want to detect what language(s) the user would
+prefer output in.
+
+=head1 FUNCTIONS
+
+This module defines one public function,
+C<I18N::LangTags::Detect::detect()>. This function is not exported
+(nor is even exportable), and it takes no parameters.
+
+In scalar context, the function returns the most preferred language
+tag (or undef if no preference was seen).
+
+In list context (which is usually what you want),
+the function returns a
+(possibly empty) list of language tags representing (best first) what
+languages the user apparently would accept output in. You will
+probably want to pass the output of this through
+C<I18N::LangTags::implicate_supers_tightly(...)>
+or
+C<I18N::LangTags::implicate_supers(...)>, like so:
+
+ my @languages =
+ I18N::LangTags::implicate_supers_tightly(
+ I18N::LangTags::Detect::detect()
+ );
+
+
+=head1 ENVIRONMENT
+
+This module looks for several environment variables, including
+REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE,
+LANGUAGE, LC_ALL, LC_MESSAGES, and LANG.
+
+It will also use the L<Win32::Locale> module, if it's installed.
+
+
+=head1 SEE ALSO
+
+L<I18N::LangTags>, L<Win32::Locale>, L<Locale::Maketext>.
+
+(This module's core code started out as a routine in Locale::Maketext;
+but I moved it here once I realized it was more generally useful.)
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998-2004 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+The programs and documentation in this dist are distributed in
+the hope that they will be useful, but without any warranty; without
+even the implied warranty of merchantability or fitness for a
+particular purpose.
+
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=cut
+
+# a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty!
diff --git a/Master/tlpkg/tlperl.straw/lib/I18N/LangTags/List.pm b/Master/tlpkg/tlperl.straw/lib/I18N/LangTags/List.pm
new file mode 100755
index 00000000000..5494bea21ed
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/I18N/LangTags/List.pm
@@ -0,0 +1,1779 @@
+
+require 5;
+package I18N::LangTags::List;
+# Time-stamp: "2004-10-06 23:26:21 ADT"
+use strict;
+use vars qw(%Name %Is_Disrec $Debug $VERSION);
+$VERSION = '0.35';
+# POD at the end.
+
+#----------------------------------------------------------------------
+{
+# read the table out of our own POD!
+ my $seeking = 1;
+ my $count = 0;
+ my($disrec,$tag,$name);
+ my $last_name = '';
+ while(<I18N::LangTags::List::DATA>) {
+ if($seeking) {
+ $seeking = 0 if m/=for woohah/;
+ } elsif( ($disrec, $tag, $name) =
+ m/(\[?)\{([-0-9a-zA-Z]+)\}(?:\s*:)?\s*([^\[\]]+)/
+ ) {
+ $name =~ s/\s*[;\.]*\s*$//g;
+ next unless $name;
+ ++$count;
+ print "<$tag> <$name>\n" if $Debug;
+ $last_name = $Name{$tag} = $name;
+ $Is_Disrec{$tag} = 1 if $disrec;
+ } elsif (m/[Ff]ormerly \"([-a-z0-9]+)\"/) {
+ $Name{$1} = "$last_name (old tag)" if $last_name;
+ $Is_Disrec{$1} = 1;
+ }
+ }
+ die "No tags read??" unless $count;
+}
+#----------------------------------------------------------------------
+
+sub name {
+ my $tag = lc($_[0] || return);
+ $tag =~ s/^\s+//s;
+ $tag =~ s/\s+$//s;
+
+ my $alt;
+ if($tag =~ m/^x-(.+)/) {
+ $alt = "i-$1";
+ } elsif($tag =~ m/^i-(.+)/) {
+ $alt = "x-$1";
+ } else {
+ $alt = '';
+ }
+
+ my $subform = '';
+ my $name = '';
+ print "Input: {$tag}\n" if $Debug;
+ while(length $tag) {
+ last if $name = $Name{$tag};
+ last if $name = $Name{$alt};
+ if($tag =~ s/(-[a-z0-9]+)$//s) {
+ print "Shaving off: $1 leaving $tag\n" if $Debug;
+ $subform = "$1$subform";
+ # and loop around again
+
+ $alt =~ s/(-[a-z0-9]+)$//s && $Debug && print " alt -> $alt\n";
+ } else {
+ # we're trying to pull a subform off a primary tag. TILT!
+ print "Aborting on: {$name}{$subform}\n" if $Debug;
+ last;
+ }
+ }
+ print "Output: {$name}{$subform}\n" if $Debug;
+
+ return unless $name; # Failure
+ return $name unless $subform; # Exact match
+ $subform =~ s/^-//s;
+ $subform =~ s/-$//s;
+ return "$name (Subform \"$subform\")";
+}
+
+#--------------------------------------------------------------------------
+
+sub is_decent {
+ my $tag = lc($_[0] || return 0);
+ #require I18N::LangTags;
+
+ return 0 unless
+ $tag =~
+ /^(?: # First subtag
+ [xi] | [a-z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-z0-9]{1,8} # subtag
+ )*
+ $/xs;
+
+ my @supers = ();
+ foreach my $bit (split('-', $tag)) {
+ push @supers,
+ scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
+ }
+ return 0 unless @supers;
+ shift @supers if $supers[0] =~ m<^(i|x|sgn)$>s;
+ return 0 unless @supers;
+
+ foreach my $f ($tag, @supers) {
+ return 0 if $Is_Disrec{$f};
+ return 2 if $Name{$f};
+ # so that decent subforms of indecent tags are decent
+ }
+ return 2 if $Name{$tag}; # not only is it decent, it's known!
+ return 1;
+}
+
+#--------------------------------------------------------------------------
+1;
+
+__DATA__
+
+=head1 NAME
+
+I18N::LangTags::List -- tags and names for human languages
+
+=head1 SYNOPSIS
+
+ use I18N::LangTags::List;
+ print "Parlez-vous... ", join(', ',
+ I18N::LangTags::List::name('elx') || 'unknown_language',
+ I18N::LangTags::List::name('ar-Kw') || 'unknown_language',
+ I18N::LangTags::List::name('en') || 'unknown_language',
+ I18N::LangTags::List::name('en-CA') || 'unknown_language',
+ ), "?\n";
+
+prints:
+
+ Parlez-vous... Elamite, Kuwait Arabic, English, Canadian English?
+
+=head1 DESCRIPTION
+
+This module provides a function
+C<I18N::LangTags::List::name( I<langtag> ) > that takes
+a language tag (see L<I18N::LangTags|I18N::LangTags>)
+and returns the best attempt at an English name for it, or
+undef if it can't make sense of the tag.
+
+The function I18N::LangTags::List::name(...) is not exported.
+
+This module also provides a function
+C<I18N::LangTags::List::is_decent( I<langtag> )> that returns true iff
+the language tag is syntactically valid and is for general use (like
+"fr" or "fr-ca", below). That is, it returns false for tags that are
+syntactically invalid and for tags, like "aus", that are listed in
+brackets below. This function is not exported.
+
+The map of tags-to-names that it uses is accessible as
+%I18N::LangTags::List::Name, and it's the same as the list
+that follows in this documentation, which should be useful
+to you even if you don't use this module.
+
+=head1 ABOUT LANGUAGE TAGS
+
+Internet language tags, as defined in RFC 3066, are a formalism
+for denoting human languages. The two-letter ISO 639-1 language
+codes are well known (as "en" for English), as are their forms
+when qualified by a country code ("en-US"). Less well-known are the
+arbitrary-length non-ISO codes (like "i-mingo"), and the
+recently (in 2001) introduced three-letter ISO-639-2 codes.
+
+Remember these important facts:
+
+=over
+
+=item *
+
+Language tags are not locale IDs. A locale ID is written with a "_"
+instead of a "-", (almost?) always matches C<m/^\w\w_\w\w\b/>, and
+I<means> something different than a language tag. A language tag
+denotes a language. A locale ID denotes a language I<as used in>
+a particular place, in combination with non-linguistic
+location-specific information such as what currency is used
+there. Locales I<also> often denote character set information,
+as in "en_US.ISO8859-1".
+
+=item *
+
+Language tags are not for computer languages.
+
+=item *
+
+"Dialect" is not a useful term, since there is no objective
+criterion for establishing when two language-forms are
+dialects of eachother, or are separate languages.
+
+=item *
+
+Language tags are not case-sensitive. en-US, en-us, En-Us, etc.,
+are all the same tag, and denote the same language.
+
+=item *
+
+Not every language tag really refers to a single language. Some
+language tags refer to conditions: i-default (system-message text
+in English plus maybe other languages), und (undetermined
+language). Others (notably lots of the three-letter codes) are
+bibliographic tags that classify whole groups of languages, as
+with cus "Cushitic (Other)" (i.e., a
+language that has been classed as Cushtic, but which has no more
+specific code) or the even less linguistically coherent
+sai for "South American Indian (Other)". Though useful in
+bibliography, B<SUCH TAGS ARE NOT
+FOR GENERAL USE>. For further guidance, email me.
+
+=item *
+
+Language tags are not country codes. In fact, they are often
+distinct codes, as with language tag ja for Japanese, and
+ISO 3166 country code C<.jp> for Japan.
+
+=back
+
+=head1 LIST OF LANGUAGES
+
+The first part of each item is the language tag, between
+{...}. It
+is followed by an English name for the language or language-group.
+Language tags that I judge to be not for general use, are bracketed.
+
+This list is in alphabetical order by English name of the language.
+
+=for reminder
+ The name in the =item line MUST NOT have E<...>'s in it!!
+
+=for woohah START
+
+=over
+
+=item {ab} : Abkhazian
+
+eq Abkhaz
+
+=item {ace} : Achinese
+
+=item {ach} : Acoli
+
+=item {ada} : Adangme
+
+=item {ady} : Adyghe
+
+eq Adygei
+
+=item {aa} : Afar
+
+=item {afh} : Afrihili
+
+(Artificial)
+
+=item {af} : Afrikaans
+
+=item [{afa} : Afro-Asiatic (Other)]
+
+=item {ak} : Akan
+
+(Formerly "aka".)
+
+=item {akk} : Akkadian
+
+(Historical)
+
+=item {sq} : Albanian
+
+=item {ale} : Aleut
+
+=item [{alg} : Algonquian languages]
+
+NOT Algonquin!
+
+=item [{tut} : Altaic (Other)]
+
+=item {am} : Amharic
+
+NOT Aramaic!
+
+=item {i-ami} : Ami
+
+eq Amis. eq 'Amis. eq Pangca.
+
+=item [{apa} : Apache languages]
+
+=item {ar} : Arabic
+
+Many forms are mutually un-intelligible in spoken media.
+Notable forms:
+{ar-ae} UAE Arabic;
+{ar-bh} Bahrain Arabic;
+{ar-dz} Algerian Arabic;
+{ar-eg} Egyptian Arabic;
+{ar-iq} Iraqi Arabic;
+{ar-jo} Jordanian Arabic;
+{ar-kw} Kuwait Arabic;
+{ar-lb} Lebanese Arabic;
+{ar-ly} Libyan Arabic;
+{ar-ma} Moroccan Arabic;
+{ar-om} Omani Arabic;
+{ar-qa} Qatari Arabic;
+{ar-sa} Sauda Arabic;
+{ar-sy} Syrian Arabic;
+{ar-tn} Tunisian Arabic;
+{ar-ye} Yemen Arabic.
+
+=item {arc} : Aramaic
+
+NOT Amharic! NOT Samaritan Aramaic!
+
+=item {arp} : Arapaho
+
+=item {arn} : Araucanian
+
+=item {arw} : Arawak
+
+=item {hy} : Armenian
+
+=item {an} : Aragonese
+
+=item [{art} : Artificial (Other)]
+
+=item {ast} : Asturian
+
+eq Bable.
+
+=item {as} : Assamese
+
+=item [{ath} : Athapascan languages]
+
+eq Athabaskan. eq Athapaskan. eq Athabascan.
+
+=item [{aus} : Australian languages]
+
+=item [{map} : Austronesian (Other)]
+
+=item {av} : Avaric
+
+(Formerly "ava".)
+
+=item {ae} : Avestan
+
+eq Zend
+
+=item {awa} : Awadhi
+
+=item {ay} : Aymara
+
+=item {az} : Azerbaijani
+
+eq Azeri
+
+Notable forms:
+{az-Arab} Azerbaijani in Arabic script;
+{az-Cyrl} Azerbaijani in Cyrillic script;
+{az-Latn} Azerbaijani in Latin script.
+
+=item {ban} : Balinese
+
+=item [{bat} : Baltic (Other)]
+
+=item {bal} : Baluchi
+
+=item {bm} : Bambara
+
+(Formerly "bam".)
+
+=item [{bai} : Bamileke languages]
+
+=item {bad} : Banda
+
+=item [{bnt} : Bantu (Other)]
+
+=item {bas} : Basa
+
+=item {ba} : Bashkir
+
+=item {eu} : Basque
+
+=item {btk} : Batak (Indonesia)
+
+=item {bej} : Beja
+
+=item {be} : Belarusian
+
+eq Belarussian. eq Byelarussian.
+eq Belorussian. eq Byelorussian.
+eq White Russian. eq White Ruthenian.
+NOT Ruthenian!
+
+=item {bem} : Bemba
+
+=item {bn} : Bengali
+
+eq Bangla.
+
+=item [{ber} : Berber (Other)]
+
+=item {bho} : Bhojpuri
+
+=item {bh} : Bihari
+
+=item {bik} : Bikol
+
+=item {bin} : Bini
+
+=item {bi} : Bislama
+
+eq Bichelamar.
+
+=item {bs} : Bosnian
+
+=item {bra} : Braj
+
+=item {br} : Breton
+
+=item {bug} : Buginese
+
+=item {bg} : Bulgarian
+
+=item {i-bnn} : Bunun
+
+=item {bua} : Buriat
+
+=item {my} : Burmese
+
+=item {cad} : Caddo
+
+=item {car} : Carib
+
+=item {ca} : Catalan
+
+eq CatalE<aacute>n. eq Catalonian.
+
+=item [{cau} : Caucasian (Other)]
+
+=item {ceb} : Cebuano
+
+=item [{cel} : Celtic (Other)]
+
+Notable forms:
+{cel-gaulish} Gaulish (Historical)
+
+=item [{cai} : Central American Indian (Other)]
+
+=item {chg} : Chagatai
+
+(Historical?)
+
+=item [{cmc} : Chamic languages]
+
+=item {ch} : Chamorro
+
+=item {ce} : Chechen
+
+=item {chr} : Cherokee
+
+eq Tsalagi
+
+=item {chy} : Cheyenne
+
+=item {chb} : Chibcha
+
+(Historical) NOT Chibchan (which is a language family).
+
+=item {ny} : Chichewa
+
+eq Nyanja. eq Chinyanja.
+
+=item {zh} : Chinese
+
+Many forms are mutually un-intelligible in spoken media.
+Notable forms:
+{zh-Hans} Chinese, in simplified script;
+{zh-Hant} Chinese, in traditional script;
+{zh-tw} Taiwan Chinese;
+{zh-cn} PRC Chinese;
+{zh-sg} Singapore Chinese;
+{zh-mo} Macau Chinese;
+{zh-hk} Hong Kong Chinese;
+{zh-guoyu} Mandarin [Putonghua/Guoyu];
+{zh-hakka} Hakka [formerly "i-hakka"];
+{zh-min} Hokkien;
+{zh-min-nan} Southern Hokkien;
+{zh-wuu} Shanghaiese;
+{zh-xiang} Hunanese;
+{zh-gan} Gan;
+{zh-yue} Cantonese.
+
+=for etc
+{i-hakka} Hakka (old tag)
+
+=item {chn} : Chinook Jargon
+
+eq Chinook Wawa.
+
+=item {chp} : Chipewyan
+
+=item {cho} : Choctaw
+
+=item {cu} : Church Slavic
+
+eq Old Church Slavonic.
+
+=item {chk} : Chuukese
+
+eq Trukese. eq Chuuk. eq Truk. eq Ruk.
+
+=item {cv} : Chuvash
+
+=item {cop} : Coptic
+
+=item {kw} : Cornish
+
+=item {co} : Corsican
+
+eq Corse.
+
+=item {cr} : Cree
+
+NOT Creek! (Formerly "cre".)
+
+=item {mus} : Creek
+
+NOT Cree!
+
+=item [{cpe} : English-based Creoles and pidgins (Other)]
+
+=item [{cpf} : French-based Creoles and pidgins (Other)]
+
+=item [{cpp} : Portuguese-based Creoles and pidgins (Other)]
+
+=item [{crp} : Creoles and pidgins (Other)]
+
+=item {hr} : Croatian
+
+eq Croat.
+
+=item [{cus} : Cushitic (Other)]
+
+=item {cs} : Czech
+
+=item {dak} : Dakota
+
+eq Nakota. eq Latoka.
+
+=item {da} : Danish
+
+=item {dar} : Dargwa
+
+=item {day} : Dayak
+
+=item {i-default} : Default (Fallthru) Language
+
+Defined in RFC 2277, this is for tagging text
+(which must include English text, and might/should include text
+in other appropriate languages) that is emitted in a context
+where language-negotiation wasn't possible -- in SMTP mail failure
+messages, for example.
+
+=item {del} : Delaware
+
+=item {din} : Dinka
+
+=item {dv} : Divehi
+
+eq Maldivian. (Formerly "div".)
+
+=item {doi} : Dogri
+
+NOT Dogrib!
+
+=item {dgr} : Dogrib
+
+NOT Dogri!
+
+=item [{dra} : Dravidian (Other)]
+
+=item {dua} : Duala
+
+=item {nl} : Dutch
+
+eq Netherlander. Notable forms:
+{nl-nl} Netherlands Dutch;
+{nl-be} Belgian Dutch.
+
+=item {dum} : Middle Dutch (ca.1050-1350)
+
+(Historical)
+
+=item {dyu} : Dyula
+
+=item {dz} : Dzongkha
+
+=item {efi} : Efik
+
+=item {egy} : Ancient Egyptian
+
+(Historical)
+
+=item {eka} : Ekajuk
+
+=item {elx} : Elamite
+
+(Historical)
+
+=item {en} : English
+
+Notable forms:
+{en-au} Australian English;
+{en-bz} Belize English;
+{en-ca} Canadian English;
+{en-gb} UK English;
+{en-ie} Irish English;
+{en-jm} Jamaican English;
+{en-nz} New Zealand English;
+{en-ph} Philippine English;
+{en-tt} Trinidad English;
+{en-us} US English;
+{en-za} South African English;
+{en-zw} Zimbabwe English.
+
+=item {enm} : Old English (1100-1500)
+
+(Historical)
+
+=item {ang} : Old English (ca.450-1100)
+
+eq Anglo-Saxon. (Historical)
+
+=item {i-enochian} : Enochian (Artificial)
+
+=item {myv} : Erzya
+
+=item {eo} : Esperanto
+
+(Artificial)
+
+=item {et} : Estonian
+
+=item {ee} : Ewe
+
+(Formerly "ewe".)
+
+=item {ewo} : Ewondo
+
+=item {fan} : Fang
+
+=item {fat} : Fanti
+
+=item {fo} : Faroese
+
+=item {fj} : Fijian
+
+=item {fi} : Finnish
+
+=item [{fiu} : Finno-Ugrian (Other)]
+
+eq Finno-Ugric. NOT Ugaritic!
+
+=item {fon} : Fon
+
+=item {fr} : French
+
+Notable forms:
+{fr-fr} France French;
+{fr-be} Belgian French;
+{fr-ca} Canadian French;
+{fr-ch} Swiss French;
+{fr-lu} Luxembourg French;
+{fr-mc} Monaco French.
+
+=item {frm} : Middle French (ca.1400-1600)
+
+(Historical)
+
+=item {fro} : Old French (842-ca.1400)
+
+(Historical)
+
+=item {fy} : Frisian
+
+=item {fur} : Friulian
+
+=item {ff} : Fulah
+
+(Formerly "ful".)
+
+=item {gaa} : Ga
+
+=item {gd} : Scots Gaelic
+
+NOT Scots!
+
+=item {gl} : Gallegan
+
+eq Galician
+
+=item {lg} : Ganda
+
+(Formerly "lug".)
+
+=item {gay} : Gayo
+
+=item {gba} : Gbaya
+
+=item {gez} : Geez
+
+eq Ge'ez
+
+=item {ka} : Georgian
+
+=item {de} : German
+
+Notable forms:
+{de-at} Austrian German;
+{de-be} Belgian German;
+{de-ch} Swiss German;
+{de-de} Germany German;
+{de-li} Liechtenstein German;
+{de-lu} Luxembourg German.
+
+=item {gmh} : Middle High German (ca.1050-1500)
+
+(Historical)
+
+=item {goh} : Old High German (ca.750-1050)
+
+(Historical)
+
+=item [{gem} : Germanic (Other)]
+
+=item {gil} : Gilbertese
+
+=item {gon} : Gondi
+
+=item {gor} : Gorontalo
+
+=item {got} : Gothic
+
+(Historical)
+
+=item {grb} : Grebo
+
+=item {grc} : Ancient Greek
+
+(Historical) (Until 15th century or so.)
+
+=item {el} : Modern Greek
+
+(Since 15th century or so.)
+
+=item {gn} : Guarani
+
+GuaranE<iacute>
+
+=item {gu} : Gujarati
+
+=item {gwi} : Gwich'in
+
+eq Gwichin
+
+=item {hai} : Haida
+
+=item {ht} : Haitian
+
+eq Haitian Creole
+
+=item {ha} : Hausa
+
+=item {haw} : Hawaiian
+
+Hawai'ian
+
+=item {he} : Hebrew
+
+(Formerly "iw".)
+
+=for etc
+{iw} Hebrew (old tag)
+
+=item {hz} : Herero
+
+=item {hil} : Hiligaynon
+
+=item {him} : Himachali
+
+=item {hi} : Hindi
+
+=item {ho} : Hiri Motu
+
+=item {hit} : Hittite
+
+(Historical)
+
+=item {hmn} : Hmong
+
+=item {hu} : Hungarian
+
+=item {hup} : Hupa
+
+=item {iba} : Iban
+
+=item {is} : Icelandic
+
+=item {io} : Ido
+
+(Artificial)
+
+=item {ig} : Igbo
+
+(Formerly "ibo".)
+
+=item {ijo} : Ijo
+
+=item {ilo} : Iloko
+
+=item [{inc} : Indic (Other)]
+
+=item [{ine} : Indo-European (Other)]
+
+=item {id} : Indonesian
+
+(Formerly "in".)
+
+=for etc
+{in} Indonesian (old tag)
+
+=item {inh} : Ingush
+
+=item {ia} : Interlingua (International Auxiliary Language Association)
+
+(Artificial) NOT Interlingue!
+
+=item {ie} : Interlingue
+
+(Artificial) NOT Interlingua!
+
+=item {iu} : Inuktitut
+
+A subform of "Eskimo".
+
+=item {ik} : Inupiaq
+
+A subform of "Eskimo".
+
+=item [{ira} : Iranian (Other)]
+
+=item {ga} : Irish
+
+=item {mga} : Middle Irish (900-1200)
+
+(Historical)
+
+=item {sga} : Old Irish (to 900)
+
+(Historical)
+
+=item [{iro} : Iroquoian languages]
+
+=item {it} : Italian
+
+Notable forms:
+{it-it} Italy Italian;
+{it-ch} Swiss Italian.
+
+=item {ja} : Japanese
+
+(NOT "jp"!)
+
+=item {jv} : Javanese
+
+(Formerly "jw" because of a typo.)
+
+=item {jrb} : Judeo-Arabic
+
+=item {jpr} : Judeo-Persian
+
+=item {kbd} : Kabardian
+
+=item {kab} : Kabyle
+
+=item {kac} : Kachin
+
+=item {kl} : Kalaallisut
+
+eq Greenlandic "Eskimo"
+
+=item {xal} : Kalmyk
+
+=item {kam} : Kamba
+
+=item {kn} : Kannada
+
+eq Kanarese. NOT Canadian!
+
+=item {kr} : Kanuri
+
+(Formerly "kau".)
+
+=item {krc} : Karachay-Balkar
+
+=item {kaa} : Kara-Kalpak
+
+=item {kar} : Karen
+
+=item {ks} : Kashmiri
+
+=item {csb} : Kashubian
+
+eq Kashub
+
+=item {kaw} : Kawi
+
+=item {kk} : Kazakh
+
+=item {kha} : Khasi
+
+=item {km} : Khmer
+
+eq Cambodian. eq Kampuchean.
+
+=item [{khi} : Khoisan (Other)]
+
+=item {kho} : Khotanese
+
+=item {ki} : Kikuyu
+
+eq Gikuyu.
+
+=item {kmb} : Kimbundu
+
+=item {rw} : Kinyarwanda
+
+=item {ky} : Kirghiz
+
+=item {i-klingon} : Klingon
+
+=item {kv} : Komi
+
+=item {kg} : Kongo
+
+(Formerly "kon".)
+
+=item {kok} : Konkani
+
+=item {ko} : Korean
+
+=item {kos} : Kosraean
+
+=item {kpe} : Kpelle
+
+=item {kro} : Kru
+
+=item {kj} : Kuanyama
+
+=item {kum} : Kumyk
+
+=item {ku} : Kurdish
+
+=item {kru} : Kurukh
+
+=item {kut} : Kutenai
+
+=item {lad} : Ladino
+
+eq Judeo-Spanish. NOT Ladin (a minority language in Italy).
+
+=item {lah} : Lahnda
+
+NOT Lamba!
+
+=item {lam} : Lamba
+
+NOT Lahnda!
+
+=item {lo} : Lao
+
+eq Laotian.
+
+=item {la} : Latin
+
+(Historical) NOT Ladin! NOT Ladino!
+
+=item {lv} : Latvian
+
+eq Lettish.
+
+=item {lb} : Letzeburgesch
+
+eq Luxemburgian, eq Luxemburger. (Formerly "i-lux".)
+
+=for etc
+{i-lux} Letzeburgesch (old tag)
+
+=item {lez} : Lezghian
+
+=item {li} : Limburgish
+
+eq Limburger, eq Limburgan. NOT Letzeburgesch!
+
+=item {ln} : Lingala
+
+=item {lt} : Lithuanian
+
+=item {nds} : Low German
+
+eq Low Saxon. eq Low German. eq Low Saxon.
+
+=item {art-lojban} : Lojban (Artificial)
+
+=item {loz} : Lozi
+
+=item {lu} : Luba-Katanga
+
+(Formerly "lub".)
+
+=item {lua} : Luba-Lulua
+
+=item {lui} : Luiseno
+
+eq LuiseE<ntilde>o.
+
+=item {lun} : Lunda
+
+=item {luo} : Luo (Kenya and Tanzania)
+
+=item {lus} : Lushai
+
+=item {mk} : Macedonian
+
+eq the modern Slavic language spoken in what was Yugoslavia.
+NOT the form of Greek spoken in Greek Macedonia!
+
+=item {mad} : Madurese
+
+=item {mag} : Magahi
+
+=item {mai} : Maithili
+
+=item {mak} : Makasar
+
+=item {mg} : Malagasy
+
+=item {ms} : Malay
+
+NOT Malayalam!
+
+=item {ml} : Malayalam
+
+NOT Malay!
+
+=item {mt} : Maltese
+
+=item {mnc} : Manchu
+
+=item {mdr} : Mandar
+
+NOT Mandarin!
+
+=item {man} : Mandingo
+
+=item {mni} : Manipuri
+
+eq Meithei.
+
+=item [{mno} : Manobo languages]
+
+=item {gv} : Manx
+
+=item {mi} : Maori
+
+NOT Mari!
+
+=item {mr} : Marathi
+
+=item {chm} : Mari
+
+NOT Maori!
+
+=item {mh} : Marshall
+
+eq Marshallese.
+
+=item {mwr} : Marwari
+
+=item {mas} : Masai
+
+=item [{myn} : Mayan languages]
+
+=item {men} : Mende
+
+=item {mic} : Micmac
+
+=item {min} : Minangkabau
+
+=item {i-mingo} : Mingo
+
+eq the Irquoian language West Virginia Seneca. NOT New York Seneca!
+
+=item [{mis} : Miscellaneous languages]
+
+Don't use this.
+
+=item {moh} : Mohawk
+
+=item {mdf} : Moksha
+
+=item {mo} : Moldavian
+
+eq Moldovan.
+
+=item [{mkh} : Mon-Khmer (Other)]
+
+=item {lol} : Mongo
+
+=item {mn} : Mongolian
+
+eq Mongol.
+
+=item {mos} : Mossi
+
+=item [{mul} : Multiple languages]
+
+Not for normal use.
+
+=item [{mun} : Munda languages]
+
+=item {nah} : Nahuatl
+
+=item {nap} : Neapolitan
+
+=item {na} : Nauru
+
+=item {nv} : Navajo
+
+eq Navaho. (Formerly "i-navajo".)
+
+=for etc
+{i-navajo} Navajo (old tag)
+
+=item {nd} : North Ndebele
+
+=item {nr} : South Ndebele
+
+=item {ng} : Ndonga
+
+=item {ne} : Nepali
+
+eq Nepalese. Notable forms:
+{ne-np} Nepal Nepali;
+{ne-in} India Nepali.
+
+=item {new} : Newari
+
+=item {nia} : Nias
+
+=item [{nic} : Niger-Kordofanian (Other)]
+
+=item [{ssa} : Nilo-Saharan (Other)]
+
+=item {niu} : Niuean
+
+=item {nog} : Nogai
+
+=item {non} : Old Norse
+
+(Historical)
+
+=item [{nai} : North American Indian]
+
+Do not use this.
+
+=item {no} : Norwegian
+
+Note the two following forms:
+
+=item {nb} : Norwegian Bokmal
+
+eq BokmE<aring>l, (A form of Norwegian.) (Formerly "no-bok".)
+
+=for etc
+{no-bok} Norwegian Bokmal (old tag)
+
+=item {nn} : Norwegian Nynorsk
+
+(A form of Norwegian.) (Formerly "no-nyn".)
+
+=for etc
+{no-nyn} Norwegian Nynorsk (old tag)
+
+=item [{nub} : Nubian languages]
+
+=item {nym} : Nyamwezi
+
+=item {nyn} : Nyankole
+
+=item {nyo} : Nyoro
+
+=item {nzi} : Nzima
+
+=item {oc} : Occitan (post 1500)
+
+eq ProvenE<ccedil>al, eq Provencal
+
+=item {oj} : Ojibwa
+
+eq Ojibwe. (Formerly "oji".)
+
+=item {or} : Oriya
+
+=item {om} : Oromo
+
+=item {osa} : Osage
+
+=item {os} : Ossetian; Ossetic
+
+=item [{oto} : Otomian languages]
+
+Group of languages collectively called "OtomE<iacute>".
+
+=item {pal} : Pahlavi
+
+eq Pahlevi
+
+=item {i-pwn} : Paiwan
+
+eq Pariwan
+
+=item {pau} : Palauan
+
+=item {pi} : Pali
+
+(Historical?)
+
+=item {pam} : Pampanga
+
+=item {pag} : Pangasinan
+
+=item {pa} : Panjabi
+
+eq Punjabi
+
+=item {pap} : Papiamento
+
+eq Papiamentu.
+
+=item [{paa} : Papuan (Other)]
+
+=item {fa} : Persian
+
+eq Farsi. eq Iranian.
+
+=item {peo} : Old Persian (ca.600-400 B.C.)
+
+=item [{phi} : Philippine (Other)]
+
+=item {phn} : Phoenician
+
+(Historical)
+
+=item {pon} : Pohnpeian
+
+NOT Pompeiian!
+
+=item {pl} : Polish
+
+=item {pt} : Portuguese
+
+eq Portugese. Notable forms:
+{pt-pt} Portugal Portuguese;
+{pt-br} Brazilian Portuguese.
+
+=item [{pra} : Prakrit languages]
+
+=item {pro} : Old Provencal (to 1500)
+
+eq Old ProvenE<ccedil>al. (Historical.)
+
+=item {ps} : Pushto
+
+eq Pashto. eq Pushtu.
+
+=item {qu} : Quechua
+
+eq Quecha.
+
+=item {rm} : Raeto-Romance
+
+eq Romansh.
+
+=item {raj} : Rajasthani
+
+=item {rap} : Rapanui
+
+=item {rar} : Rarotongan
+
+=item [{qaa - qtz} : Reserved for local use.]
+
+=item [{roa} : Romance (Other)]
+
+NOT Romanian! NOT Romany! NOT Romansh!
+
+=item {ro} : Romanian
+
+eq Rumanian. NOT Romany!
+
+=item {rom} : Romany
+
+eq Rom. NOT Romanian!
+
+=item {rn} : Rundi
+
+=item {ru} : Russian
+
+NOT White Russian! NOT Rusyn!
+
+=item [{sal} : Salishan languages]
+
+Large language group.
+
+=item {sam} : Samaritan Aramaic
+
+NOT Aramaic!
+
+=item {se} : Northern Sami
+
+eq Lappish. eq Lapp. eq (Northern) Saami.
+
+=item {sma} : Southern Sami
+
+=item {smn} : Inari Sami
+
+=item {smj} : Lule Sami
+
+=item {sms} : Skolt Sami
+
+=item [{smi} : Sami languages (Other)]
+
+=item {sm} : Samoan
+
+=item {sad} : Sandawe
+
+=item {sg} : Sango
+
+=item {sa} : Sanskrit
+
+(Historical)
+
+=item {sat} : Santali
+
+=item {sc} : Sardinian
+
+eq Sard.
+
+=item {sas} : Sasak
+
+=item {sco} : Scots
+
+NOT Scots Gaelic!
+
+=item {sel} : Selkup
+
+=item [{sem} : Semitic (Other)]
+
+=item {sr} : Serbian
+
+eq Serb. NOT Sorbian.
+
+Notable forms:
+{sr-Cyrl} : Serbian in Cyrillic script;
+{sr-Latn} : Serbian in Latin script.
+
+=item {srr} : Serer
+
+=item {shn} : Shan
+
+=item {sn} : Shona
+
+=item {sid} : Sidamo
+
+=item {sgn-...} : Sign Languages
+
+Always use with a subtag. Notable forms:
+{sgn-gb} British Sign Language (BSL);
+{sgn-ie} Irish Sign Language (ESL);
+{sgn-ni} Nicaraguan Sign Language (ISN);
+{sgn-us} American Sign Language (ASL).
+
+(And so on with other country codes as the subtag.)
+
+=item {bla} : Siksika
+
+eq Blackfoot. eq Pikanii.
+
+=item {sd} : Sindhi
+
+=item {si} : Sinhalese
+
+eq Sinhala.
+
+=item [{sit} : Sino-Tibetan (Other)]
+
+=item [{sio} : Siouan languages]
+
+=item {den} : Slave (Athapascan)
+
+("Slavey" is a subform.)
+
+=item [{sla} : Slavic (Other)]
+
+=item {sk} : Slovak
+
+eq Slovakian.
+
+=item {sl} : Slovenian
+
+eq Slovene.
+
+=item {sog} : Sogdian
+
+=item {so} : Somali
+
+=item {son} : Songhai
+
+=item {snk} : Soninke
+
+=item {wen} : Sorbian languages
+
+eq Wendish. eq Sorb. eq Lusatian. eq Wend. NOT Venda! NOT Serbian!
+
+=item {nso} : Northern Sotho
+
+=item {st} : Southern Sotho
+
+eq Sutu. eq Sesotho.
+
+=item [{sai} : South American Indian (Other)]
+
+=item {es} : Spanish
+
+Notable forms:
+{es-ar} Argentine Spanish;
+{es-bo} Bolivian Spanish;
+{es-cl} Chilean Spanish;
+{es-co} Colombian Spanish;
+{es-do} Dominican Spanish;
+{es-ec} Ecuadorian Spanish;
+{es-es} Spain Spanish;
+{es-gt} Guatemalan Spanish;
+{es-hn} Honduran Spanish;
+{es-mx} Mexican Spanish;
+{es-pa} Panamanian Spanish;
+{es-pe} Peruvian Spanish;
+{es-pr} Puerto Rican Spanish;
+{es-py} Paraguay Spanish;
+{es-sv} Salvadoran Spanish;
+{es-us} US Spanish;
+{es-uy} Uruguayan Spanish;
+{es-ve} Venezuelan Spanish.
+
+=item {suk} : Sukuma
+
+=item {sux} : Sumerian
+
+(Historical)
+
+=item {su} : Sundanese
+
+=item {sus} : Susu
+
+=item {sw} : Swahili
+
+eq Kiswahili
+
+=item {ss} : Swati
+
+=item {sv} : Swedish
+
+Notable forms:
+{sv-se} Sweden Swedish;
+{sv-fi} Finland Swedish.
+
+=item {syr} : Syriac
+
+=item {tl} : Tagalog
+
+=item {ty} : Tahitian
+
+=item [{tai} : Tai (Other)]
+
+NOT Thai!
+
+=item {tg} : Tajik
+
+=item {tmh} : Tamashek
+
+=item {ta} : Tamil
+
+=item {i-tao} : Tao
+
+eq Yami.
+
+=item {tt} : Tatar
+
+=item {i-tay} : Tayal
+
+eq Atayal. eq Atayan.
+
+=item {te} : Telugu
+
+=item {ter} : Tereno
+
+=item {tet} : Tetum
+
+=item {th} : Thai
+
+NOT Tai!
+
+=item {bo} : Tibetan
+
+=item {tig} : Tigre
+
+=item {ti} : Tigrinya
+
+=item {tem} : Timne
+
+eq Themne. eq Timene.
+
+=item {tiv} : Tiv
+
+=item {tli} : Tlingit
+
+=item {tpi} : Tok Pisin
+
+=item {tkl} : Tokelau
+
+=item {tog} : Tonga (Nyasa)
+
+NOT Tsonga!
+
+=item {to} : Tonga (Tonga Islands)
+
+(Pronounced "Tong-a", not "Tong-ga")
+
+NOT Tsonga!
+
+=item {tsi} : Tsimshian
+
+eq Sm'algyax
+
+=item {ts} : Tsonga
+
+NOT Tonga!
+
+=item {i-tsu} : Tsou
+
+=item {tn} : Tswana
+
+Same as Setswana.
+
+=item {tum} : Tumbuka
+
+=item [{tup} : Tupi languages]
+
+=item {tr} : Turkish
+
+(Typically in Roman script)
+
+=item {ota} : Ottoman Turkish (1500-1928)
+
+(Typically in Arabic script) (Historical)
+
+=item {crh} : Crimean Turkish
+
+eq Crimean Tatar
+
+=item {tk} : Turkmen
+
+eq Turkmeni.
+
+=item {tvl} : Tuvalu
+
+=item {tyv} : Tuvinian
+
+eq Tuvan. eq Tuvin.
+
+=item {tw} : Twi
+
+=item {udm} : Udmurt
+
+=item {uga} : Ugaritic
+
+NOT Ugric!
+
+=item {ug} : Uighur
+
+=item {uk} : Ukrainian
+
+=item {umb} : Umbundu
+
+=item {und} : Undetermined
+
+Not a tag for normal use.
+
+=item {ur} : Urdu
+
+=item {uz} : Uzbek
+
+eq E<Ouml>zbek
+
+Notable forms:
+{uz-Cyrl} Uzbek in Cyrillic script;
+{uz-Latn} Uzbek in Latin script.
+
+=item {vai} : Vai
+
+=item {ve} : Venda
+
+NOT Wendish! NOT Wend! NOT Avestan! (Formerly "ven".)
+
+=item {vi} : Vietnamese
+
+eq Viet.
+
+=item {vo} : Volapuk
+
+eq VolapE<uuml>k. (Artificial)
+
+=item {vot} : Votic
+
+eq Votian. eq Vod.
+
+=item [{wak} : Wakashan languages]
+
+=item {wa} : Walloon
+
+=item {wal} : Walamo
+
+eq Wolaytta.
+
+=item {war} : Waray
+
+Presumably the Philippine language Waray-Waray (SamareE<ntilde>o),
+not the smaller Philippine language Waray Sorsogon, nor the extinct
+Australian language Waray.
+
+=item {was} : Washo
+
+eq Washoe
+
+=item {cy} : Welsh
+
+=item {wo} : Wolof
+
+=item {x-...} : Unregistered (Semi-Private Use)
+
+"x-" is a prefix for language tags that are not registered with ISO
+or IANA. Example, x-double-dutch
+
+=item {xh} : Xhosa
+
+=item {sah} : Yakut
+
+=item {yao} : Yao
+
+(The Yao in Malawi?)
+
+=item {yap} : Yapese
+
+eq Yap
+
+=item {ii} : Sichuan Yi
+
+=item {yi} : Yiddish
+
+Formerly "ji". Usually in Hebrew script.
+
+Notable forms:
+{yi-latn} Yiddish in Latin script
+
+=item {yo} : Yoruba
+
+=item [{ypk} : Yupik languages]
+
+Several "Eskimo" languages.
+
+=item {znd} : Zande
+
+=item [{zap} : Zapotec]
+
+(A group of languages.)
+
+=item {zen} : Zenaga
+
+NOT Zend.
+
+=item {za} : Zhuang
+
+=item {zu} : Zulu
+
+=item {zun} : Zuni
+
+eq ZuE<ntilde>i
+
+=back
+
+=for woohah END
+
+=head1 SEE ALSO
+
+L<I18N::LangTags|I18N::LangTags> and its "See Also" section.
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+Copyright (c) 2001+ Sean M. Burke. All rights reserved.
+
+You can redistribute and/or
+modify this document under the same terms as Perl itself.
+
+This document is provided in the hope that it will be
+useful, but without any warranty;
+without even the implied warranty of accuracy, authoritativeness,
+completeness, merchantability, or fitness for a particular purpose.
+
+Email any corrections or questions to me.
+
+=head1 AUTHOR
+
+Sean M. Burke, sburkeE<64>cpan.org
+
+=cut
+
+
+# To generate a list of just the two and three-letter codes:
+
+#!/usr/local/bin/perl -w
+
+require 5; # Time-stamp: "2001-03-13 21:53:39 MST"
+ # Sean M. Burke, sburke@cpan.org
+ # This program is for generating the language_codes.txt file
+use strict;
+use LWP::Simple;
+use HTML::TreeBuilder 3.10;
+my $root = HTML::TreeBuilder->new();
+my $url = 'http://lcweb.loc.gov/standards/iso639-2/bibcodes.html';
+$root->parse(get($url) || die "Can't get $url");
+$root->eof();
+
+my @codes;
+
+foreach my $tr ($root->find_by_tag_name('tr')) {
+ my @f = map $_->as_text(), $tr->content_list();
+ #print map("<$_> ", @f), "\n";
+ next unless @f == 5;
+ pop @f; # nix the French name
+ next if $f[-1] eq 'Language Name (English)'; # it's a header line
+ my $xx = splice(@f, 2,1); # pull out the two-letter code
+ $f[-1] =~ s/^\s+//;
+ $f[-1] =~ s/\s+$//;
+ if($xx =~ m/[a-zA-Z]/) { # there's a two-letter code for it
+ push @codes, [ lc($f[-1]), "$xx\t$f[-1]\n" ];
+ } else { # print the three-letter codes.
+ if($f[0] eq $f[1]) {
+ push @codes, [ lc($f[-1]), "$f[1]\t$f[2]\n" ];
+ } else { # shouldn't happen
+ push @codes, [ lc($f[-1]), "@f !!!!!!!!!!\n" ];
+ }
+ }
+}
+
+print map $_->[1], sort {; $a->[0] cmp $b->[0] } @codes;
+print "[ based on $url\n at ", scalar(localtime), "]\n",
+ "[Note: doesn't include IANA-registered codes.]\n";
+exit;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/IO.pm b/Master/tlpkg/tlperl.straw/lib/IO.pm
new file mode 100755
index 00000000000..a72e2243d74
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IO.pm
@@ -0,0 +1,68 @@
+#
+
+package IO;
+
+use XSLoader ();
+use Carp;
+use strict;
+use warnings;
+
+our $VERSION = "1.25";
+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.straw/lib/IPC/Cmd.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Cmd.pm
new file mode 100755
index 00000000000..e60c93fda24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Cmd.pm
@@ -0,0 +1,1646 @@
+package IPC::Cmd;
+
+use strict;
+
+BEGIN {
+
+ use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
+ use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
+ use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0;
+ use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut';
+ use constant SPECIAL_CHARS => qw[< > | &];
+ use constant QUOTE => do { IS_WIN32 ? q["] : q['] };
+
+ use Exporter ();
+ use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
+ $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
+ ];
+
+ $VERSION = '0.54';
+ $VERBOSE = 0;
+ $DEBUG = 0;
+ $WARN = 1;
+ $USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
+ $USE_IPC_OPEN3 = not IS_VMS;
+
+ $CAN_USE_RUN_FORKED = 0;
+ eval {
+ require POSIX; POSIX->import();
+ require IPC::Open3; IPC::Open3->import();
+ require IO::Select; IO::Select->import();
+ require IO::Handle; IO::Handle->import();
+ require FileHandle; FileHandle->import();
+ require Socket; Socket->import();
+ require Time::HiRes; Time::HiRes->import();
+ };
+ $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
+
+ @ISA = qw[Exporter];
+ @EXPORT_OK = qw[can_run run run_forked QUOTE];
+}
+
+require Carp;
+use File::Spec;
+use Params::Check qw[check];
+use Text::ParseWords (); # import ONLY if needed!
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Style => 'gettext';
+
+=pod
+
+=head1 NAME
+
+IPC::Cmd - finding and running system commands made easy
+
+=head1 SYNOPSIS
+
+ use IPC::Cmd qw[can_run run run_forked];
+
+ my $full_path = can_run('wget') or warn 'wget is not installed!';
+
+ ### commands can be arrayrefs or strings ###
+ my $cmd = "$full_path -b theregister.co.uk";
+ my $cmd = [$full_path, '-b', 'theregister.co.uk'];
+
+ ### in scalar context ###
+ my $buffer;
+ if( scalar run( command => $cmd,
+ verbose => 0,
+ buffer => \$buffer,
+ timeout => 20 )
+ ) {
+ print "fetched webpage successfully: $buffer\n";
+ }
+
+
+ ### in list context ###
+ my( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
+ run( command => $cmd, verbose => 0 );
+
+ if( $success ) {
+ print "this is what the command printed:\n";
+ print join "", @$full_buf;
+ }
+
+ ### check for features
+ print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
+ print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
+ print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
+
+ ### don't have IPC::Cmd be verbose, ie don't print to stdout or
+ ### stderr when running commands -- default is '0'
+ $IPC::Cmd::VERBOSE = 0;
+
+
+=head1 DESCRIPTION
+
+IPC::Cmd allows you to run commands, interactively if desired,
+platform independent but have them still work.
+
+The C<can_run> function can tell you if a certain binary is installed
+and if so where, whereas the C<run> function can actually execute any
+of the commands you give it and give you a clear return value, as well
+as adhere to your verbosity settings.
+
+=head1 CLASS METHODS
+
+=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
+
+Utility function that tells you if C<IPC::Run> is available.
+If the verbose flag is passed, it will print diagnostic messages
+if C<IPC::Run> can not be found or loaded.
+
+=cut
+
+
+sub can_use_ipc_run {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### ipc::run doesn't run on win98
+ return if IS_WIN98;
+
+ ### if we dont have ipc::run, we obviously can't use it.
+ return unless can_load(
+ modules => { 'IPC::Run' => '0.55' },
+ verbose => ($WARN && $verbose),
+ );
+
+ ### otherwise, we're good to go
+ return $IPC::Run::VERSION;
+}
+
+=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
+
+Utility function that tells you if C<IPC::Open3> is available.
+If the verbose flag is passed, it will print diagnostic messages
+if C<IPC::Open3> can not be found or loaded.
+
+=cut
+
+
+sub can_use_ipc_open3 {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### ipc::open3 is not working on VMS becasue of a lack of fork.
+ ### XXX todo, win32 also does not have fork, so need to do more research.
+ return if IS_VMS;
+
+ ### ipc::open3 works on every non-VMS platform platform, but it can't
+ ### capture buffers on win32 :(
+ return unless can_load(
+ modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
+ verbose => ($WARN && $verbose),
+ );
+
+ return $IPC::Open3::VERSION;
+}
+
+=head2 $bool = IPC::Cmd->can_capture_buffer
+
+Utility function that tells you if C<IPC::Cmd> is capable of
+capturing buffers in it's current configuration.
+
+=cut
+
+sub can_capture_buffer {
+ my $self = shift;
+
+ return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
+ return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3 && !IS_WIN32;
+ return;
+}
+
+=head2 $bool = IPC::Cmd->can_use_run_forked
+
+Utility function that tells you if C<IPC::Cmd> is capable of
+providing C<run_forked> on the current platform.
+
+=head1 FUNCTIONS
+
+=head2 $path = can_run( PROGRAM );
+
+C<can_run> takes but a single argument: the name of a binary you wish
+to locate. C<can_run> works much like the unix binary C<which> or the bash
+command C<type>, which scans through your path, looking for the requested
+binary .
+
+Unlike C<which> and C<type>, this function is platform independent and
+will also work on, for example, Win32.
+
+It will return the full path to the binary you asked for if it was
+found, or C<undef> if it was not.
+
+=cut
+
+sub can_run {
+ my $command = shift;
+
+ # a lot of VMS executables have a symbol defined
+ # check those first
+ if ( $^O eq 'VMS' ) {
+ require VMS::DCLsym;
+ my $syms = VMS::DCLsym->new;
+ return $command if scalar $syms->getsym( uc $command );
+ }
+
+ require Config;
+ require File::Spec;
+ require ExtUtils::MakeMaker;
+
+ if( File::Spec->file_name_is_absolute($command) ) {
+ return MM->maybe_command($command);
+
+ } else {
+ for my $dir (
+ (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
+ File::Spec->curdir
+ ) {
+ my $abs = File::Spec->catfile($dir, $command);
+ return $abs if $abs = MM->maybe_command($abs);
+ }
+ }
+}
+
+=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
+
+C<run> takes 4 arguments:
+
+=over 4
+
+=item command
+
+This is the command to execute. It may be either a string or an array
+reference.
+This is a required argument.
+
+See L<CAVEATS> for remarks on how commands are parsed and their
+limitations.
+
+=item verbose
+
+This controls whether all output of a command should also be printed
+to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
+require C<IPC::Run> to be installed or your system able to work with
+C<IPC::Open3>).
+
+It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
+which by default is 0.
+
+=item buffer
+
+This will hold all the output of a command. It needs to be a reference
+to a scalar.
+Note that this will hold both the STDOUT and STDERR messages, and you
+have no way of telling which is which.
+If you require this distinction, run the C<run> command in list context
+and inspect the individual buffers.
+
+Of course, this requires that the underlying call supports buffers. See
+the note on buffers right above.
+
+=item timeout
+
+Sets the maximum time the command is allowed to run before aborting,
+using the built-in C<alarm()> call. If the timeout is triggered, the
+C<errorcode> in the return value will be set to an object of the
+C<IPC::Cmd::TimeOut> class. See the C<errorcode> section below for
+details.
+
+Defaults to C<0>, meaning no timeout is set.
+
+=back
+
+C<run> will return a simple C<true> or C<false> when called in scalar
+context.
+In list context, you will be returned a list of the following items:
+
+=over 4
+
+=item success
+
+A simple boolean indicating if the command executed without errors or
+not.
+
+=item error message
+
+If the first element of the return value (success) was 0, then some
+error occurred. This second element is the error message the command
+you requested exited with, if available. This is generally a pretty
+printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
+what they can contain.
+If the error was a timeout, the C<error message> will be prefixed with
+the string C<IPC::Cmd::TimeOut>, the timeout class.
+
+=item full_buffer
+
+This is an arrayreference containing all the output the command
+generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=item out_buffer
+
+This is an arrayreference containing all the output sent to STDOUT the
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=item error_buffer
+
+This is an arrayreference containing all the output sent to STDERR the
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=back
+
+See the C<HOW IT WORKS> Section below to see how C<IPC::Cmd> decides
+what modules or function calls to use when issuing a command.
+
+=cut
+
+{ my @acc = qw[ok error _fds];
+
+ ### autogenerate accessors ###
+ for my $key ( @acc ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ $_[0]->{$key} = $_[1] if @_ > 1;
+ return $_[0]->{$key};
+ }
+ }
+}
+
+sub can_use_run_forked {
+ return $CAN_USE_RUN_FORKED eq "1";
+}
+
+# give process a chance sending TERM,
+# waiting for a while (2 seconds)
+# and killing it with KILL
+sub kill_gently {
+ my ($pid) = @_;
+
+ kill(15, $pid);
+
+ my $wait_cycles = 0;
+ my $child_finished = 0;
+
+ while (!$child_finished && $wait_cycles < 8) {
+ my $waitpid = waitpid($pid, WNOHANG);
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ }
+
+ $wait_cycles = $wait_cycles + 1;
+ Time::HiRes::usleep(250000); # half a second
+ }
+}
+
+sub open3_run {
+ my ($cmd, $opts) = @_;
+
+ $opts = {} unless $opts;
+
+ my $child_in = FileHandle->new;
+ my $child_out = FileHandle->new;
+ my $child_err = FileHandle->new;
+ $child_out->autoflush(1);
+ $child_err->autoflush(1);
+
+ my $pid = open3($child_in, $child_out, $child_err, $cmd);
+
+ # push my child's pid to our parent
+ # so in case i am killed parent
+ # could stop my child (search for
+ # child_child_pid in parent code)
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "spawned $pid\n";
+ }
+
+ if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
+
+ # If the child process dies for any reason,
+ # the next write to CHLD_IN is likely to generate
+ # a SIGPIPE in the parent, which is fatal by default.
+ # So you may wish to handle this signal.
+ #
+ # from http://perldoc.perl.org/IPC/Open3.html,
+ # absolutely needed to catch piped commands errors.
+ #
+ local $SIG{'SIG_PIPE'} = sub { 1; };
+
+ print $child_in $opts->{'child_stdin'};
+ }
+ close($child_in);
+
+ my $child_output = {
+ 'out' => $child_out->fileno,
+ 'err' => $child_err->fileno,
+ $child_out->fileno => {
+ 'parent_socket' => $opts->{'parent_stdout'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_out,
+ 'block_size' => ($child_out->stat)[11] || 1024,
+ },
+ $child_err->fileno => {
+ 'parent_socket' => $opts->{'parent_stderr'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_err,
+ 'block_size' => ($child_err->stat)[11] || 1024,
+ },
+ };
+
+ my $select = IO::Select->new();
+ $select->add($child_out, $child_err);
+
+ # pass any signal to the child
+ # effectively creating process
+ # strongly attached to the child:
+ # it will terminate only after child
+ # has terminated (except for SIGKILL,
+ # which is specially handled)
+ foreach my $s (keys %SIG) {
+ my $sig_handler;
+ $sig_handler = sub {
+ kill("$s", $pid);
+ $SIG{$s} = $sig_handler;
+ };
+ $SIG{$s} = $sig_handler;
+ }
+
+ my $child_finished = 0;
+
+ my $got_sig_child = 0;
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
+
+ while(!$child_finished && ($child_out->opened || $child_err->opened)) {
+
+ # parent was killed otherwise we would have got
+ # the same signal as parent and process it same way
+ if (getppid() eq "1") {
+ kill_gently($pid);
+ exit;
+ }
+
+ if ($got_sig_child) {
+ if (time() - $got_sig_child > 10) {
+ print STDERR "select->can_read did not return 0 for 10 seconds after SIG_CHLD, killing [$pid]\n";
+ kill (-9, $pid);
+ $child_finished = 1;
+ }
+ }
+
+ Time::HiRes::usleep(1);
+
+ foreach my $fd ($select->can_read(1/100)) {
+ my $str = $child_output->{$fd->fileno};
+ psSnake::die("child stream not found: $fd") unless $str;
+
+ my $data;
+ my $count = $fd->sysread($data, $str->{'block_size'});
+
+ if ($count) {
+ if ($str->{'parent_socket'}) {
+ my $ph = $str->{'parent_socket'};
+ print $ph $data;
+ }
+ else {
+ $str->{'scalar_buffer'} .= $data;
+ }
+ }
+ elsif ($count eq 0) {
+ $select->remove($fd);
+ $fd->close();
+ }
+ else {
+ psSnake::die("error during sysread: " . $!);
+ }
+ }
+ }
+
+ waitpid($pid, 0);
+
+ # i've successfully reaped my child,
+ # let my parent know this
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "reaped $pid\n";
+ }
+
+ my $real_exit = $?;
+ my $exit_value = $real_exit >> 8;
+ if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
+ return $exit_value;
+ }
+ else {
+ return {
+ 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
+ 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
+ 'exit_code' => $exit_value,
+ };
+ }
+}
+
+=head2 $hashref = run_forked( command => COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
+
+C<run_forked> is used to execute some program,
+optionally feed it with some input, get its return code
+and output (both stdout and stderr into seperate buffers).
+In addition it allows to terminate the program
+which take too long to finish.
+
+The important and distinguishing feature of run_forked
+is execution timeout which at first seems to be
+quite a simple task but if you think
+that the program which you're spawning
+might spawn some children itself (which
+in their turn could do the same and so on)
+it turns out to be not a simple issue.
+
+C<run_forked> is designed to survive and
+successfully terminate almost any long running task,
+even a fork bomb in case your system has the resources
+to survive during given timeout.
+
+This is achieved by creating separate watchdog process
+which spawns the specified program in a separate
+process session and supervises it: optionally
+feeds it with input, stores its exit code,
+stdout and stderr, terminates it in case
+it runs longer than specified.
+
+Invocation requires the command to be executed and optionally a hashref of options:
+
+=over
+
+=item C<timeout>
+
+Specify in seconds how long the command may run for before it is killed with with SIG_KILL (9)
+which effectively terminates it and all of its children (direct or indirect).
+
+=item C<child_stdin>
+
+Specify some text that will be passed into C<STDIN> of the executed program.
+
+=item C<stdout_handler>
+
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stdout from the executing program.
+
+=item C<stderr_handler>
+
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stderr from the executing program.
+
+=back
+
+C<run_forked> will return a HASHREF with the following keys:
+
+=over
+
+=item C<exit_code>
+
+The exit code of the executed program.
+
+=item C<timeout>
+
+The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
+
+=item C<stdout>
+
+Holds the standard output of the executed command
+(or empty string if there were no stdout output; it's always defined!)
+
+=item C<stderr>
+
+Holds the standard error of the executed command
+(or empty string if there were no stderr output; it's always defined!)
+
+=item C<merged>
+
+Holds the standard output and error of the executed command merged into one stream
+(or empty string if there were no output at all; it's always defined!)
+
+=item C<err_msg>
+
+Holds some explanation in the case of an error.
+
+=back
+
+=cut
+
+sub run_forked {
+ ### container to store things in
+ my $self = bless {}, __PACKAGE__;
+
+ if (!can_use_run_forked()) {
+ Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
+ return;
+ }
+
+ my ($cmd, $opts) = @_;
+
+ if (!$cmd) {
+ Carp::carp("run_forked expects command to run");
+ return;
+ }
+
+ $opts = {} unless $opts;
+ $opts->{'timeout'} = 0 unless $opts->{'timeout'};
+
+ # sockets to pass child stdout to parent
+ my $child_stdout_socket;
+ my $parent_stdout_socket;
+
+ # sockets to pass child stderr to parent
+ my $child_stderr_socket;
+ my $parent_stderr_socket;
+
+ # sockets for child -> parent internal communication
+ my $child_info_socket;
+ my $parent_info_socket;
+
+ socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+
+ $child_stdout_socket->autoflush(1);
+ $parent_stdout_socket->autoflush(1);
+ $child_stderr_socket->autoflush(1);
+ $parent_stderr_socket->autoflush(1);
+ $child_info_socket->autoflush(1);
+ $parent_info_socket->autoflush(1);
+
+ my $start_time = time();
+
+ my $pid;
+ if ($pid = fork) {
+
+ # we are a parent
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ my $child_timedout = 0;
+ my $flags;
+
+ # prepare sockets to read from child
+
+ $flags = 0;
+ fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ $flags = 0;
+ fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ $flags = 0;
+ fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ # print "child $pid started\n";
+
+ my $child_finished = 0;
+ my $child_stdout = '';
+ my $child_stderr = '';
+ my $child_merged = '';
+ my $child_exit_code = 0;
+
+ my $got_sig_child = 0;
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
+
+ my $child_child_pid;
+
+ while (!$child_finished) {
+ # user specified timeout
+ if ($opts->{'timeout'}) {
+ if (time() - $start_time > $opts->{'timeout'}) {
+ kill (-9, $pid);
+ $child_timedout = 1;
+ }
+ }
+
+ # give OS 10 seconds for correct return of waitpid,
+ # kill process after that and finish wait loop;
+ # shouldn't ever happen -- remove this code?
+ if ($got_sig_child) {
+ if (time() - $got_sig_child > 10) {
+ print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
+ kill (-9, $pid);
+ $child_finished = 1;
+ }
+ }
+
+ my $waitpid = waitpid($pid, WNOHANG);
+
+ # child finished, catch it's exit status
+ if ($waitpid ne 0 && $waitpid ne -1) {
+ $child_exit_code = $? >> 8;
+ }
+
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ next;
+ }
+
+ # child -> parent simple internal communication protocol
+ while (my $l = <$child_info_socket>) {
+ if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = $1;
+ $l = $2;
+ }
+ if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = undef;
+ $l = $2;
+ }
+ }
+
+ while (my $l = <$child_stdout_socket>) {
+ $child_stdout .= $l;
+ $child_merged .= $l;
+
+ if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
+ $opts->{'stdout_handler'}->($l);
+ }
+ }
+ while (my $l = <$child_stderr_socket>) {
+ $child_stderr .= $l;
+ $child_merged .= $l;
+
+ if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
+ $opts->{'stderr_handler'}->($l);
+ }
+ }
+
+ Time::HiRes::usleep(1);
+ }
+
+ # $child_pid_pid is not defined in two cases:
+ # * when our child was killed before
+ # it had chance to tell us the pid
+ # of the child it spawned. we can do
+ # nothing in this case :(
+ # * our child successfully reaped its child,
+ # we have nothing left to do in this case
+ #
+ # defined $child_pid_pid means child's child
+ # has not died but nobody is waiting for it,
+ # killing it brutaly.
+ #
+ if ($child_child_pid) {
+ kill_gently($child_child_pid);
+ }
+
+ # print "child $pid finished\n";
+
+ close($child_stdout_socket);
+ close($child_stderr_socket);
+ close($child_info_socket);
+
+ my $o = {
+ 'stdout' => $child_stdout,
+ 'stderr' => $child_stderr,
+ 'merged' => $child_merged,
+ 'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
+ 'exit_code' => $child_exit_code,
+ };
+
+ my $err_msg = '';
+ if ($o->{'exit_code'}) {
+ $err_msg .= "exited with code [$o->{'exit_code'}]\n";
+ }
+ if ($o->{'timeout'}) {
+ $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
+ }
+ if ($o->{'stdout'}) {
+ $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
+ }
+ if ($o->{'stderr'}) {
+ $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
+ }
+ $o->{'err_msg'} = $err_msg;
+
+ return $o;
+ }
+ else {
+ die("cannot fork: $!") unless defined($pid);
+
+ # create new process session for open3 call,
+ # so we hopefully can kill all the subprocesses
+ # which might be spawned in it (except for those
+ # which do setsid theirselves -- can't do anything
+ # with those)
+
+ POSIX::setsid() || die("Error running setsid: " . $!);
+
+ close($child_stdout_socket);
+ close($child_stderr_socket);
+ close($child_info_socket);
+
+ my $child_exit_code = open3_run($cmd, {
+ 'parent_info' => $parent_info_socket,
+ 'parent_stdout' => $parent_stdout_socket,
+ 'parent_stderr' => $parent_stderr_socket,
+ 'child_stdin' => $opts->{'child_stdin'},
+ });
+
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ exit $child_exit_code;
+ }
+}
+
+sub run {
+ ### container to store things in
+ my $self = bless {}, __PACKAGE__;
+
+ my %hash = @_;
+
+ ### if the user didn't provide a buffer, we'll store it here.
+ my $def_buf = '';
+
+ my($verbose,$cmd,$buffer,$timeout);
+ my $tmpl = {
+ verbose => { default => $VERBOSE, store => \$verbose },
+ buffer => { default => \$def_buf, store => \$buffer },
+ command => { required => 1, store => \$cmd,
+ allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
+ },
+ timeout => { default => 0, store => \$timeout },
+ };
+
+ unless( check( $tmpl, \%hash, $VERBOSE ) ) {
+ Carp::carp( loc( "Could not validate input: %1",
+ Params::Check->last_error ) );
+ return;
+ };
+
+ $cmd = _quote_args_vms( $cmd ) if IS_VMS;
+
+ ### strip any empty elements from $cmd if present
+ $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
+
+ my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
+ print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
+
+ ### did the user pass us a buffer to fill or not? if so, set this
+ ### flag so we know what is expected of us
+ ### XXX this is now being ignored. in the future, we could add diagnostic
+ ### messages based on this logic
+ #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
+
+ ### buffers that are to be captured
+ my( @buffer, @buff_err, @buff_out );
+
+ ### capture STDOUT
+ my $_out_handler = sub {
+ my $buf = shift;
+ return unless defined $buf;
+
+ print STDOUT $buf if $verbose;
+ push @buffer, $buf;
+ push @buff_out, $buf;
+ };
+
+ ### capture STDERR
+ my $_err_handler = sub {
+ my $buf = shift;
+ return unless defined $buf;
+
+ print STDERR $buf if $verbose;
+ push @buffer, $buf;
+ push @buff_err, $buf;
+ };
+
+
+ ### flag to indicate we have a buffer captured
+ my $have_buffer = $self->can_capture_buffer ? 1 : 0;
+
+ ### flag indicating if the subcall went ok
+ my $ok;
+
+ ### dont look at previous errors:
+ local $?;
+ local $@;
+ local $!;
+
+ ### we might be having a timeout set
+ eval {
+ local $SIG{ALRM} = sub { die bless sub {
+ ALARM_CLASS .
+ qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
+ }, ALARM_CLASS } if $timeout;
+ alarm $timeout || 0;
+
+ ### IPC::Run is first choice if $USE_IPC_RUN is set.
+ if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
+ ### ipc::run handlers needs the command as a string or an array ref
+
+ $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
+ if $DEBUG;
+
+ $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
+
+ ### since IPC::Open3 works on all platforms, and just fails on
+ ### win32 for capturing buffers, do that ideally
+ } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
+
+ $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
+ if $DEBUG;
+
+ ### in case there are pipes in there;
+ ### IPC::Open3 will call exec and exec will do the right thing
+ $ok = $self->_open3_run(
+ $cmd, $_out_handler, $_err_handler, $verbose
+ );
+
+ ### if we are allowed to run verbose, just dispatch the system command
+ } else {
+ $self->_debug( "# Using system(). Have buffer: $have_buffer" )
+ if $DEBUG;
+ $ok = $self->_system_run( $cmd, $verbose );
+ }
+
+ alarm 0;
+ };
+
+ ### restore STDIN after duping, or STDIN will be closed for
+ ### this current perl process!
+ $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
+
+ my $err;
+ unless( $ok ) {
+ ### alarm happened
+ if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
+ $err = $@->(); # the error code is an expired alarm
+
+ ### another error happened, set by the dispatchub
+ } else {
+ $err = $self->error;
+ }
+ }
+
+ ### fill the buffer;
+ $$buffer = join '', @buffer if @buffer;
+
+ ### return a list of flags and buffers (if available) in list
+ ### context, or just a simple 'ok' in scalar
+ return wantarray
+ ? $have_buffer
+ ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
+ : ($ok, $err )
+ : $ok
+
+
+}
+
+sub _open3_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $_out_handler = shift;
+ my $_err_handler = shift;
+ my $verbose = shift || 0;
+
+ ### Following code are adapted from Friar 'abstracts' in the
+ ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
+ ### XXX that code didn't work.
+ ### we now use the following code, thanks to theorbtwo
+
+ ### define them beforehand, so we always have defined FH's
+ ### to read from.
+ use Symbol;
+ my $kidout = Symbol::gensym();
+ my $kiderror = Symbol::gensym();
+
+ ### Dup the filehandle so we can pass 'our' STDIN to the
+ ### child process. This stops us from having to pump input
+ ### from ourselves to the childprocess. However, we will need
+ ### to revive the FH afterwards, as IPC::Open3 closes it.
+ ### We'll do the same for STDOUT and STDERR. It works without
+ ### duping them on non-unix derivatives, but not on win32.
+ my @fds_to_dup = ( IS_WIN32 && !$verbose
+ ? qw[STDIN STDOUT STDERR]
+ : qw[STDIN]
+ );
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
+
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ ### dont stringify @$cmd, so spaces in filenames/paths are
+ ### treated properly
+ my $pid = eval {
+ IPC::Open3::open3(
+ '<&STDIN',
+ (IS_WIN32 ? '>&STDOUT' : $kidout),
+ (IS_WIN32 ? '>&STDERR' : $kiderror),
+ ( ref $cmd ? @$cmd : $cmd ),
+ );
+ };
+
+ ### open3 error occurred
+ if( $@ and $@ =~ /^open3:/ ) {
+ $self->ok( 0 );
+ $self->error( $@ );
+ return;
+ };
+
+ ### use OUR stdin, not $kidin. Somehow,
+ ### we never get the input.. so jump through
+ ### some hoops to do it :(
+ my $selector = IO::Select->new(
+ (IS_WIN32 ? \*STDERR : $kiderror),
+ \*STDIN,
+ (IS_WIN32 ? \*STDOUT : $kidout)
+ );
+
+ STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1);
+ $kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush');
+ $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
+
+ ### add an epxlicit break statement
+ ### code courtesy of theorbtwo from #london.pm
+ my $stdout_done = 0;
+ my $stderr_done = 0;
+ OUTER: while ( my @ready = $selector->can_read ) {
+
+ for my $h ( @ready ) {
+ my $buf;
+
+ ### $len is the amount of bytes read
+ my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
+
+ ### see perldoc -f sysread: it returns undef on error,
+ ### so bail out.
+ if( not defined $len ) {
+ warn(loc("Error reading from process: %1", $!));
+ last OUTER;
+ }
+
+ ### check for $len. it may be 0, at which point we're
+ ### done reading, so don't try to process it.
+ ### if we would print anyway, we'd provide bogus information
+ $_out_handler->( "$buf" ) if $len && $h == $kidout;
+ $_err_handler->( "$buf" ) if $len && $h == $kiderror;
+
+ ### Wait till child process is done printing to both
+ ### stdout and stderr.
+ $stdout_done = 1 if $h == $kidout and $len == 0;
+ $stderr_done = 1 if $h == $kiderror and $len == 0;
+ last OUTER if ($stdout_done && $stderr_done);
+ }
+ }
+
+ waitpid $pid, 0; # wait for it to die
+
+ ### restore STDIN after duping, or STDIN will be closed for
+ ### this current perl process!
+ ### done in the parent call now
+ # $self->__reopen_fds( @fds_to_dup );
+
+ ### some error occurred
+ if( $? ) {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ return;
+ } else {
+ return $self->ok( 1 );
+ }
+}
+
+### text::parsewords::shellwordss() uses unix semantics. that will break
+### on win32
+{ my $parse_sub = IS_WIN32
+ ? __PACKAGE__->can('_split_like_shell_win32')
+ : Text::ParseWords->can('shellwords');
+
+ sub _ipc_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $_out_handler = shift;
+ my $_err_handler = shift;
+
+ STDOUT->autoflush(1); STDERR->autoflush(1);
+
+ ### a command like:
+ # [
+ # '/usr/bin/gzip',
+ # '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
+ # '|',
+ # '/usr/bin/tar',
+ # '-tf -'
+ # ]
+ ### needs to become:
+ # [
+ # ['/usr/bin/gzip', '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
+ # '|',
+ # ['/usr/bin/tar', '-tf -']
+ # ]
+
+
+ my @command;
+ my $special_chars;
+
+ my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
+ if( ref $cmd ) {
+ my $aref = [];
+ for my $item (@$cmd) {
+ if( $item =~ $re ) {
+ push @command, $aref, $item;
+ $aref = [];
+ $special_chars .= $1;
+ } else {
+ push @$aref, $item;
+ }
+ }
+ push @command, $aref;
+ } else {
+ @command = map { if( $_ =~ $re ) {
+ $special_chars .= $1; $_;
+ } else {
+# [ split /\s+/ ]
+ [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
+ }
+ } split( /\s*$re\s*/, $cmd );
+ }
+
+ ### if there's a pipe in the command, *STDIN needs to
+ ### be inserted *BEFORE* the pipe, to work on win32
+ ### this also works on *nix, so we should do it when possible
+ ### this should *also* work on multiple pipes in the command
+ ### if there's no pipe in the command, append STDIN to the back
+ ### of the command instead.
+ ### XXX seems IPC::Run works it out for itself if you just
+ ### dont pass STDIN at all.
+ # if( $special_chars and $special_chars =~ /\|/ ) {
+ # ### only add STDIN the first time..
+ # my $i;
+ # @command = map { ($_ eq '|' && not $i++)
+ # ? ( \*STDIN, $_ )
+ # : $_
+ # } @command;
+ # } else {
+ # push @command, \*STDIN;
+ # }
+
+ # \*STDIN is already included in the @command, see a few lines up
+ my $ok = eval { IPC::Run::run( @command,
+ fileno(STDOUT).'>',
+ $_out_handler,
+ fileno(STDERR).'>',
+ $_err_handler
+ )
+ };
+
+ ### all is well
+ if( $ok ) {
+ return $self->ok( $ok );
+
+ ### some error occurred
+ } else {
+ $self->ok( 0 );
+
+ ### if the eval fails due to an exception, deal with it
+ ### unless it's an alarm
+ if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
+ $self->error( $@ );
+
+ ### if it *is* an alarm, propagate
+ } elsif( $@ ) {
+ die $@;
+
+ ### some error in the sub command
+ } else {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ }
+
+ return;
+ }
+ }
+}
+
+sub _system_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $verbose = shift || 0;
+
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
+
+ ### system returns 'true' on failure -- the exit code of the cmd
+ $self->ok( 1 );
+ system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ };
+
+ ### done in the parent call now
+ #$self->__reopen_fds( @fds_to_dup );
+
+ return unless $self->ok;
+ return $self->ok;
+}
+
+{ my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
+
+
+ sub __fix_cmd_whitespace_and_special_chars {
+ my $self = shift;
+ my $cmd = shift;
+
+ ### command has a special char in it
+ if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
+
+ ### since we have special chars, we have to quote white space
+ ### this *may* conflict with the parsing :(
+ my $fixed;
+ my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
+
+ $self->_debug( "# Quoted $fixed arguments containing whitespace" )
+ if $DEBUG && $fixed;
+
+ ### stringify it, so the special char isn't escaped as argument
+ ### to the program
+ $cmd = join ' ', @cmd;
+ }
+
+ return $cmd;
+ }
+}
+
+### Command-line arguments (but not the command itself) must be quoted
+### to ensure case preservation. Borrowed from Module::Build with adaptations.
+### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
+### quoting for run() on VMS
+sub _quote_args_vms {
+ ### Returns a command string with proper quoting so that the subprocess
+ ### sees this same list of args, or if we get a single arg that is an
+ ### array reference, quote the elements of it (except for the first)
+ ### and return the reference.
+ my @args = @_;
+ my $got_arrayref = (scalar(@args) == 1
+ && UNIVERSAL::isa($args[0], 'ARRAY'))
+ ? 1
+ : 0;
+
+ @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;
+
+ my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
+
+ ### Do not quote qualifiers that begin with '/' or previously quoted args.
+ map { if (/^[^\/\"]/) {
+ $_ =~ s/\"/""/g; # escape C<"> by doubling
+ $_ = q(").$_.q(");
+ }
+ }
+ ($got_arrayref ? @{$args[0]}
+ : @args
+ );
+
+ $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
+
+ return $got_arrayref ? $args[0]
+ : join(' ', @args);
+}
+
+
+### XXX this is cribbed STRAIGHT from M::B 0.30 here:
+### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
+### XXX this *should* be integrated into text::parsewords
+sub _split_like_shell_win32 {
+ # As it turns out, Windows command-parsing is very different from
+ # Unix command-parsing. Double-quotes mean different things,
+ # backslashes don't necessarily mean escapes, and so on. So we
+ # can't use Text::ParseWords::shellwords() to break a command string
+ # into words. The algorithm below was bashed out by Randy and Ken
+ # (mostly Randy), and there are a lot of regression tests, so we
+ # should feel free to adjust if desired.
+
+ local $_ = shift;
+
+ my @argv;
+ return @argv unless defined() && length();
+
+ my $arg = '';
+ my( $i, $quote_mode ) = ( 0, 0 );
+
+ while ( $i < length() ) {
+
+ my $ch = substr( $_, $i , 1 );
+ my $next_ch = substr( $_, $i+1, 1 );
+
+ if ( $ch eq '\\' && $next_ch eq '"' ) {
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
+ $arg .= '\\';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
+ $quote_mode = !$quote_mode;
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
+ ( $i + 2 == length() ||
+ substr( $_, $i + 2, 1 ) eq ' ' )
+ ) { # for cases like: a"" => [ 'a' ]
+ push( @argv, $arg );
+ $arg = '';
+ $i += 2;
+ } elsif ( $ch eq '"' ) {
+ $quote_mode = !$quote_mode;
+ } elsif ( $ch eq ' ' && !$quote_mode ) {
+ push( @argv, $arg ) if $arg;
+ $arg = '';
+ ++$i while substr( $_, $i + 1, 1 ) eq ' ';
+ } else {
+ $arg .= $ch;
+ }
+
+ $i++;
+ }
+
+ push( @argv, $arg ) if defined( $arg ) && length( $arg );
+ return @argv;
+}
+
+
+
+{ use File::Spec;
+ use Symbol;
+
+ my %Map = (
+ STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
+ STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
+ STDIN => [qw|<&|, \*STDIN, Symbol::gensym() ],
+ );
+
+ ### dups FDs and stores them in a cache
+ sub __dup_fds {
+ my $self = shift;
+ my @fds = @_;
+
+ __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
+
+ for my $name ( @fds ) {
+ my($redir, $fh, $glob) = @{$Map{$name}} or (
+ Carp::carp(loc("No such FD: '%1'", $name)), next );
+
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
+ ### see perldoc5.6.2 -f open for details
+ open $glob, $redir . fileno($fh) or (
+ Carp::carp(loc("Could not dup '$name': %1", $!)),
+ return
+ );
+
+ ### we should re-open this filehandle right now, not
+ ### just dup it
+ ### Use 2-arg version of open, as 5.5.x doesn't support
+ ### 3-arg version =/
+ if( $redir eq '>&' ) {
+ open( $fh, '>' . File::Spec->devnull ) or (
+ Carp::carp(loc("Could not reopen '$name': %1", $!)),
+ return
+ );
+ }
+ }
+
+ return 1;
+ }
+
+ ### reopens FDs from the cache
+ sub __reopen_fds {
+ my $self = shift;
+ my @fds = @_;
+
+ __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
+
+ for my $name ( @fds ) {
+ my($redir, $fh, $glob) = @{$Map{$name}} or (
+ Carp::carp(loc("No such FD: '%1'", $name)), next );
+
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
+ ### see perldoc5.6.2 -f open for details
+ open( $fh, $redir . fileno($glob) ) or (
+ Carp::carp(loc("Could not restore '$name': %1", $!)),
+ return
+ );
+
+ ### close this FD, we're not using it anymore
+ close $glob;
+ }
+ return 1;
+
+ }
+}
+
+sub _debug {
+ my $self = shift;
+ my $msg = shift or return;
+ my $level = shift || 0;
+
+ local $Carp::CarpLevel += $level;
+ Carp::carp($msg);
+
+ return 1;
+}
+
+sub _pp_child_error {
+ my $self = shift;
+ my $cmd = shift or return;
+ my $ce = shift or return;
+ my $pp_cmd = ref $cmd ? "@$cmd" : $cmd;
+
+
+ my $str;
+ if( $ce == -1 ) {
+ ### Include $! in the error message, so that the user can
+ ### see 'No such file or directory' versus 'Permission denied'
+ ### versus 'Cannot fork' or whatever the cause was.
+ $str = "Failed to execute '$pp_cmd': $!";
+
+ } elsif ( $ce & 127 ) {
+ ### some signal
+ $str = loc( "'%1' died with signal %d, %s coredump\n",
+ $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
+
+ } else {
+ ### Otherwise, the command run but gave error status.
+ $str = "'$pp_cmd' exited with value " . ($ce >> 8);
+ }
+
+ $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
+
+ return $str;
+}
+
+1;
+
+=head2 $q = QUOTE
+
+Returns the character used for quoting strings on this platform. This is
+usually a C<'> (single quote) on most systems, but some systems use different
+quotes. For example, C<Win32> uses C<"> (double quote).
+
+You can use it as follows:
+
+ use IPC::Cmd qw[run QUOTE];
+ my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
+
+This makes sure that C<foo bar> is treated as a string, rather than two
+seperate arguments to the C<echo> function.
+
+__END__
+
+=head1 HOW IT WORKS
+
+C<run> will try to execute your command using the following logic:
+
+=over 4
+
+=item *
+
+If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
+is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute
+the command. You will have the full output available in buffers, interactive commands are sure to work and you are guaranteed to have your verbosity
+settings honored cleanly.
+
+=item *
+
+Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
+(See the C<GLOBAL VARIABLES> Section), try to execute the command using
+C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
+interactive commands will still execute cleanly, and also your verbosity
+settings will be adhered to nicely;
+
+=item *
+
+Otherwise, if you have the verbose argument set to true, we fall back
+to a simple system() call. We cannot capture any buffers, but
+interactive commands will still work.
+
+=item *
+
+Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
+system() call with your command and then re-open STDERR and STDOUT.
+This is the method of last resort and will still allow you to execute
+your commands cleanly. However, no buffers will be available.
+
+=back
+
+=head1 Global Variables
+
+The behaviour of IPC::Cmd can be altered by changing the following
+global variables:
+
+=head2 $IPC::Cmd::VERBOSE
+
+This controls whether IPC::Cmd will print any output from the
+commands to the screen or not. The default is 0;
+
+=head2 $IPC::Cmd::USE_IPC_RUN
+
+This variable controls whether IPC::Cmd will try to use L<IPC::Run>
+when available and suitable. Defaults to true if you are on C<Win32>.
+
+=head2 $IPC::Cmd::USE_IPC_OPEN3
+
+This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
+when available and suitable. Defaults to true.
+
+=head2 $IPC::Cmd::WARN
+
+This variable controls whether run time warnings should be issued, like
+the failure to load an C<IPC::*> module you explicitly requested.
+
+Defaults to true. Turn this off at your own risk.
+
+=head1 Caveats
+
+=over 4
+
+=item Whitespace and IPC::Open3 / system()
+
+When using C<IPC::Open3> or C<system>, if you provide a string as the
+C<command> argument, it is assumed to be appropriately escaped. You can
+use the C<QUOTE> constant to use as a portable quote character (see above).
+However, if you provide and C<Array Reference>, special rules apply:
+
+If your command contains C<Special Characters> (< > | &), it will
+be internally stringified before executing the command, to avoid that these
+special characters are escaped and passed as arguments instead of retaining
+their special meaning.
+
+However, if the command contained arguments that contained whitespace,
+stringifying the command would loose the significance of the whitespace.
+Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
+command if the command is passed as an arrayref and contains special characters.
+
+=item Whitespace and IPC::Run
+
+When using C<IPC::Run>, if you provide a string as the C<command> argument,
+the string will be split on whitespace to determine the individual elements
+of your command. Although this will usually just Do What You Mean, it may
+break if you have files or commands with whitespace in them.
+
+If you do not wish this to happen, you should provide an array
+reference, where all parts of your command are already separated out.
+Note however, if there's extra or spurious whitespace in these parts,
+the parser or underlying code may not interpret it correctly, and
+cause an error.
+
+Example:
+The following code
+
+ gzip -cdf foo.tar.gz | tar -xf -
+
+should either be passed as
+
+ "gzip -cdf foo.tar.gz | tar -xf -"
+
+or as
+
+ ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
+
+But take care not to pass it as, for example
+
+ ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
+
+Since this will lead to issues as described above.
+
+
+=item IO Redirect
+
+Currently it is too complicated to parse your command for IO
+Redirections. For capturing STDOUT or STDERR there is a work around
+however, since you can just inspect your buffers for the contents.
+
+=item Interleaving STDOUT/STDERR
+
+Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
+bursts of output from a program, ie this sample:
+
+ for ( 1..4 ) {
+ $_ % 2 ? print STDOUT $_ : print STDERR $_;
+ }
+
+IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
+the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
+
+It should have been 1, 2, 3, 4.
+
+This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
+STDOUT and STDERR
+
+=back
+
+=head1 See Also
+
+C<IPC::Run>, C<IPC::Open3>
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to James Mastros and Martijn van der Streek for their
+help in getting IPC::Open3 to behave nicely.
+
+Thanks to Petya Kohts for the C<run_forked> code.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Open2.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Open2.pm
new file mode 100755
index 00000000000..4fc016a821a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Open2.pm
@@ -0,0 +1,121 @@
+package IPC::Open2;
+
+use strict;
+our ($VERSION, @ISA, @EXPORT);
+
+require 5.000;
+require Exporter;
+
+$VERSION = 1.03;
+@ISA = qw(Exporter);
+@EXPORT = qw(open2);
+
+=head1 NAME
+
+IPC::Open2, open2 - open a process for both reading and writing
+
+=head1 SYNOPSIS
+
+ use IPC::Open2;
+
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some cmd and args');
+ # or without using the shell
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some', 'cmd', 'and', 'args');
+
+ # or with handle autovivification
+ my($chld_out, $chld_in);
+ $pid = open2($chld_out, $chld_in, 'some cmd and args');
+ # or without using the shell
+ $pid = open2($chld_out, $chld_in, 'some', 'cmd', 'and', 'args');
+
+ waitpid( $pid, 0 );
+ my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+The open2() function runs the given $cmd and connects $chld_out for
+reading and $chld_in for writing. It's what you think should work
+when you try
+
+ $pid = open(HANDLE, "|cmd args|");
+
+The write filehandle will have autoflush turned on.
+
+If $chld_out is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with C<< >& >>, then the child will send output
+directly to that file handle. If $chld_in is a string that begins with
+C<< <& >>, then $chld_in will be closed in the parent, and the child will
+read from it directly. In both cases, there will be a dup(2) instead of a
+pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+open2() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open2:/>. However,
+C<exec> failures in the child are not detected. You'll have to
+trap SIGPIPE yourself.
+
+open2() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself. This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes. See L<perlfunc/waitpid> for more information.
+
+This whole affair is quite dangerous, as you may block forever. It
+assumes it's going to talk to something like B<bc>, both writing
+to it and reading from it. This is presumably safe because you
+"know" that commands like B<bc> will read a line at a time and
+output a line at a time. Programs like B<sort> that read their
+entire input stream first, however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+The IO::Pty and Expect modules from CPAN can help with this, as they
+provide a real tty (well, a pseudo-tty, actually), which gets you
+back to line buffering in the invoked command again.
+
+=head1 WARNING
+
+The order of arguments differs from that of open3().
+
+=head1 SEE ALSO
+
+See L<IPC::Open3> for an alternative that handles STDERR as well. This
+function is really just a wrapper around open3().
+
+=cut
+
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
+# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing. return pid
+# of child, or 0 on failure.
+#
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+require IPC::Open3;
+
+sub open2 {
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ return IPC::Open3::_open3('open2', scalar caller,
+ $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
+}
+
+1
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Open3.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Open3.pm
new file mode 100755
index 00000000000..815674b5d4f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Open3.pm
@@ -0,0 +1,376 @@
+package IPC::Open3;
+
+use strict;
+no strict 'refs'; # because users pass me bareword filehandles
+our ($VERSION, @ISA, @EXPORT);
+
+require Exporter;
+
+use Carp;
+use Symbol qw(gensym qualify);
+
+$VERSION = 1.04;
+@ISA = qw(Exporter);
+@EXPORT = qw(open3);
+
+=head1 NAME
+
+IPC::Open3, open3 - open a process for reading, writing, and error handling
+
+=head1 SYNOPSIS
+
+ $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR,
+ 'some cmd and args', 'optarg', ...);
+
+ my($wtr, $rdr, $err);
+ use Symbol 'gensym'; $err = gensym;
+ $pid = open3($wtr, $rdr, $err,
+ 'some cmd and args', 'optarg', ...);
+
+ waitpid( $pid, 0 );
+ my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+Extremely similar to open2(), open3() spawns the given $cmd and
+connects CHLD_OUT for reading from the child, CHLD_IN for writing to
+the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the
+same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child
+are on the same filehandle (this means that an autovivified lexical
+cannot be used for the STDERR filehandle, see SYNOPSIS). The CHLD_IN
+will have autoflush turned on.
+
+If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the
+parent, and the child will read from it directly. If CHLD_OUT or
+CHLD_ERR begins with C<< >& >>, then the child will send output
+directly to that filehandle. In both cases, there will be a dup(2)
+instead of a pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+The filehandles may also be integers, in which case they are understood
+as file descriptors.
+
+open3() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open3:/>. However,
+C<exec> failures in the child (such as no such file or permission denied),
+are just reported to CHLD_ERR, as it is not possible to trap them.
+
+If the child process dies for any reason, the next write to CHLD_IN is
+likely to generate a SIGPIPE in the parent, which is fatal by default.
+So you may wish to handle this signal.
+
+Note if you specify C<-> as the command, in an analogous fashion to
+C<open(FOO, "-|")> the child process will just be the forked Perl
+process rather than an external command. This feature isn't yet
+supported on Win32 platforms.
+
+open3() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself. This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes. See L<perlfunc/waitpid> for more information.
+
+If you try to read from the child's stdout writer and their stderr
+writer, you'll have problems with blocking, which means you'll want
+to use select() or the IO::Select, which means you'd best use
+sysread() instead of readline() for normal stuff.
+
+This is very dangerous, as you may block forever. It assumes it's
+going to talk to something like B<bc>, both writing to it and reading
+from it. This is presumably safe because you "know" that commands
+like B<bc> will read a line at a time and output a line at a time.
+Programs like B<sort> that read their entire input stream first,
+however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+=head1 See Also
+
+=over 4
+
+=item L<IPC::Open2>
+
+Like Open3 but without STDERR catpure.
+
+=item L<IPC::Run>
+
+This is a CPAN module that has better error handling and more facilities
+than Open3.
+
+=back
+
+=head1 WARNING
+
+The order of arguments differs from that of open2().
+
+=cut
+
+# &open3: Marc Horowitz <marc@mit.edu>
+# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
+# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
+# fixed for autovivving FHs, tchrist again
+# allow fd numbers to be used, by Frank Tobin
+# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
+#
+# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
+#
+# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
+#
+# spawn the given $cmd and connect rdr for
+# reading, wtr for writing, and err for errors.
+# if err is '', or the same as rdr, then stdout and
+# stderr of the child are on the same fh. returns pid
+# of child (or dies on failure).
+
+
+# if wtr begins with '<&', then wtr will be closed in the parent, and
+# the child will read from it directly. if rdr or err begins with
+# '>&', then the child will send output directly to that fd. In both
+# cases, there will be a dup() instead of a pipe() made.
+
+
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+our $Me = 'open3 (bug)'; # you should never see this, it's always localized
+
+# Fatal.pm needs to be fixed WRT prototypes.
+
+sub xfork {
+ my $pid = fork;
+ defined $pid or croak "$Me: fork failed: $!";
+ return $pid;
+}
+
+sub xpipe {
+ pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
+}
+
+# I tried using a * prototype character for the filehandle but it still
+# disallows a bearword while compiling under strict subs.
+
+sub xopen {
+ open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
+}
+
+sub xclose {
+ close $_[0] or croak "$Me: close($_[0]) failed: $!";
+}
+
+sub fh_is_fd {
+ return $_[0] =~ /\A=?(\d+)\z/;
+}
+
+sub xfileno {
+ return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
+ return fileno $_[0];
+}
+
+my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
+
+sub _open3 {
+ local $Me = shift;
+ my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
+ my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
+
+ if (@cmd > 1 and $cmd[0] eq '-') {
+ croak "Arguments don't make sense when the command is '-'"
+ }
+
+ # simulate autovivification of filehandles because
+ # it's too ugly to use @_ throughout to make perl do it for us
+ # tchrist 5-Mar-00
+
+ unless (eval {
+ $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
+ $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
+ 1; })
+ {
+ # must strip crud for croak to add back, or looks ugly
+ $@ =~ s/(?<=value attempted) at .*//s;
+ croak "$Me: $@";
+ }
+
+ $dad_err ||= $dad_rdr;
+
+ $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
+ $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
+ $dup_err = ($dad_err =~ s/^[<>]&//);
+
+ # force unqualified filehandles into caller's package
+ $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr);
+ $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr);
+ $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err);
+
+ my $kid_rdr = gensym;
+ my $kid_wtr = gensym;
+ my $kid_err = gensym;
+
+ xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
+ xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
+ xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
+
+ $kidpid = $do_spawn ? -1 : xfork;
+ if ($kidpid == 0) { # Kid
+ # A tie in the parent should not be allowed to cause problems.
+ untie *STDIN;
+ untie *STDOUT;
+ # If she wants to dup the kid's stderr onto her stdout I need to
+ # save a copy of her stdout before I put something else there.
+ if ($dad_rdr ne $dad_err && $dup_err
+ && xfileno($dad_err) == fileno(STDOUT)) {
+ my $tmp = gensym;
+ xopen($tmp, ">&$dad_err");
+ $dad_err = $tmp;
+ }
+
+ if ($dup_wtr) {
+ xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
+ } else {
+ xclose $dad_wtr;
+ xopen \*STDIN, "<&=" . fileno $kid_rdr;
+ }
+ if ($dup_rdr) {
+ xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
+ } else {
+ xclose $dad_rdr;
+ xopen \*STDOUT, ">&=" . fileno $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ # I have to use a fileno here because in this one case
+ # I'm doing a dup but the filehandle might be a reference
+ # (from the special case above).
+ xopen \*STDERR, ">&" . xfileno($dad_err)
+ if fileno(STDERR) != xfileno($dad_err);
+ } else {
+ xclose $dad_err;
+ xopen \*STDERR, ">&=" . fileno $kid_err;
+ }
+ } else {
+ xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
+ }
+ return 0 if ($cmd[0] eq '-');
+ local($")=(" ");
+ exec @cmd or do {
+ carp "$Me: exec of @cmd failed";
+ eval { require POSIX; POSIX::_exit(255); };
+ exit 255;
+ };
+ } elsif ($do_spawn) {
+ # All the bookkeeping of coincidence between handles is
+ # handled in spawn_with_handles.
+
+ my @close;
+ if ($dup_wtr) {
+ $kid_rdr = \*{$dad_wtr};
+ push @close, $kid_rdr;
+ } else {
+ push @close, \*{$dad_wtr}, $kid_rdr;
+ }
+ if ($dup_rdr) {
+ $kid_wtr = \*{$dad_rdr};
+ push @close, $kid_wtr;
+ } else {
+ push @close, \*{$dad_rdr}, $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ $kid_err = \*{$dad_err};
+ push @close, $kid_err;
+ } else {
+ push @close, \*{$dad_err}, $kid_err;
+ }
+ } else {
+ $kid_err = $kid_wtr;
+ }
+ require IO::Pipe;
+ $kidpid = eval {
+ spawn_with_handles( [ { mode => 'r',
+ open_as => $kid_rdr,
+ handle => \*STDIN },
+ { mode => 'w',
+ open_as => $kid_wtr,
+ handle => \*STDOUT },
+ { mode => 'w',
+ open_as => $kid_err,
+ handle => \*STDERR },
+ ], \@close, @cmd);
+ };
+ die "$Me: $@" if $@;
+ }
+
+ xclose $kid_rdr if !$dup_wtr;
+ xclose $kid_wtr if !$dup_rdr;
+ xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
+ # If the write handle is a dup give it away entirely, close my copy
+ # of it.
+ xclose $dad_wtr if $dup_wtr;
+
+ select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+ $kidpid;
+}
+
+sub open3 {
+ if (@_ < 4) {
+ local $" = ', ';
+ croak "open3(@_): not enough arguments";
+ }
+ return _open3 'open3', scalar caller, @_
+}
+
+sub spawn_with_handles {
+ my $fds = shift; # Fields: handle, mode, open_as
+ my $close_in_child = shift;
+ my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
+ require Fcntl;
+
+ foreach $fd (@$fds) {
+ $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
+ $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
+ }
+ foreach $fd (@$fds) {
+ bless $fd->{handle}, 'IO::Handle'
+ unless eval { $fd->{handle}->isa('IO::Handle') } ;
+ # If some of handles to redirect-to coincide with handles to
+ # redirect, we need to use saved variants:
+ $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
+ $fd->{mode});
+ }
+ unless ($^O eq 'MSWin32') {
+ # Stderr may be redirected below, so we save the err text:
+ foreach $fd (@$close_in_child) {
+ fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
+ unless $saved{fileno $fd}; # Do not close what we redirect!
+ }
+ }
+
+ unless (@errs) {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
+ }
+
+ foreach $fd (@$fds) {
+ $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
+ $fd->{tmp_copy}->close or croak "Can't close: $!";
+ }
+ croak join "\n", @errs if @errs;
+ return $pid;
+}
+
+1; # so require is happy
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3.pm
new file mode 100755
index 00000000000..008755112a6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3.pm
@@ -0,0 +1,850 @@
+package IPC::Run3;
+BEGIN { require 5.006_000; } # i.e. 5.6.0
+use strict;
+
+=head1 NAME
+
+IPC::Run3 - run a subprocess with input/ouput redirection
+
+=head1 VERSION
+
+version 0.043
+
+=cut
+
+our $VERSION = '0.043';
+
+=head1 SYNOPSIS
+
+ use IPC::Run3; # Exports run3() by default
+
+ run3 \@cmd, \$in, \$out, \$err;
+
+=head1 DESCRIPTION
+
+This module allows you to run a subprocess and redirect stdin, stdout,
+and/or stderr to files and perl data structures. It aims to satisfy 99% of the
+need for using C<system>, C<qx>, and C<open3>
+with a simple, extremely Perlish API.
+
+Speed, simplicity, and portability are paramount. (That's speed of Perl code;
+which is often much slower than the kind of buffered I/O that this module uses
+to spool input to and output from the child command.)
+
+=cut
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw( run3 );
+our %EXPORT_TAGS = ( all => \@EXPORT );
+
+use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
+use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
+use constant is_win32 => 0 <= index $^O, "Win32";
+
+BEGIN {
+ if ( is_win32 ) {
+ eval "use Win32 qw( GetOSName ); 1" or die $@;
+ }
+}
+
+#use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i;
+#use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i;
+
+use Carp qw( croak );
+use File::Temp qw( tempfile );
+use POSIX qw( dup dup2 );
+
+# We cache the handles of our temp files in order to
+# keep from having to incur the (largish) overhead of File::Temp
+my %fh_cache;
+my $fh_cache_pid = $$;
+
+my $profiler;
+
+sub _profiler { $profiler } # test suite access
+
+BEGIN {
+ if ( profiling ) {
+ eval "use Time::HiRes qw( gettimeofday ); 1" or die $@;
+ if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) {
+ require IPC::Run3::ProfPP;
+ IPC::Run3::ProfPP->import;
+ $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE});
+ } else {
+ my ( $dest, undef, $class ) =
+ reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2;
+ $class = "IPC::Run3::ProfLogger"
+ unless defined $class && length $class;
+ if ( not eval "require $class" ) {
+ my $e = $@;
+ $class = "IPC::Run3::$class";
+ eval "require IPC::Run3::$class" or die $e;
+ }
+ $profiler = $class->new( Destination => $dest );
+ }
+ $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() );
+ }
+}
+
+
+END {
+ $profiler->app_exit( scalar gettimeofday() ) if profiling;
+}
+
+sub _binmode {
+ my ( $fh, $mode, $what ) = @_;
+ # if $mode is not given, then default to ":raw", except on Windows,
+ # where we default to ":crlf";
+ # otherwise if a proper layer string was given, use that,
+ # else use ":raw"
+ my $layer = !$mode
+ ? (is_win32 ? ":crlf" : ":raw")
+ : ($mode =~ /^:/ ? $mode : ":raw");
+ warn "binmode $what, $layer\n" if debugging >= 2;
+
+ binmode $fh, ":raw" unless $layer eq ":raw"; # remove all layers first
+ binmode $fh, $layer or croak "binmode $layer failed: $!";
+}
+
+sub _spool_data_to_child {
+ my ( $type, $source, $binmode_it ) = @_;
+
+ # If undef (not \undef) passed, they want the child to inherit
+ # the parent's STDIN.
+ return undef unless defined $source;
+
+ my $fh;
+ if ( ! $type ) {
+ open $fh, "<", $source or croak "$!: $source";
+ _binmode($fh, $binmode_it, "STDIN");
+ warn "run3(): feeding file '$source' to child STDIN\n"
+ if debugging >= 2;
+ } elsif ( $type eq "FH" ) {
+ $fh = $source;
+ warn "run3(): feeding filehandle '$source' to child STDIN\n"
+ if debugging >= 2;
+ } else {
+ $fh = $fh_cache{in} ||= tempfile;
+ truncate $fh, 0;
+ seek $fh, 0, 0;
+ _binmode($fh, $binmode_it, "STDIN");
+ my $seekit;
+ if ( $type eq "SCALAR" ) {
+
+ # When the run3()'s caller asks to feed an empty file
+ # to the child's stdin, we want to pass a live file
+ # descriptor to an empty file (like /dev/null) so that
+ # they don't get surprised by invalid fd errors and get
+ # normal EOF behaviors.
+ return $fh unless defined $$source; # \undef passed
+
+ warn "run3(): feeding SCALAR to child STDIN",
+ debugging >= 3
+ ? ( ": '", $$source, "' (", length $$source, " chars)" )
+ : (),
+ "\n"
+ if debugging >= 2;
+
+ $seekit = length $$source;
+ print $fh $$source or die "$! writing to temp file";
+
+ } elsif ( $type eq "ARRAY" ) {
+ warn "run3(): feeding ARRAY to child STDIN",
+ debugging >= 3 ? ( ": '", @$source, "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ print $fh @$source or die "$! writing to temp file";
+ $seekit = grep length, @$source;
+ } elsif ( $type eq "CODE" ) {
+ warn "run3(): feeding output of CODE ref '$source' to child STDIN\n"
+ if debugging >= 2;
+ my $parms = []; # TODO: get these from $options
+ while (1) {
+ my $data = $source->( @$parms );
+ last unless defined $data;
+ print $fh $data or die "$! writing to temp file";
+ $seekit = length $data;
+ }
+ }
+
+ seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin"
+ if $seekit;
+ }
+
+ croak "run3() can't redirect $type to child stdin"
+ unless defined $fh;
+
+ return $fh;
+}
+
+sub _fh_for_child_output {
+ my ( $what, $type, $dest, $options ) = @_;
+
+ my $fh;
+ if ( $type eq "SCALAR" && $dest == \undef ) {
+ warn "run3(): redirecting child $what to oblivion\n"
+ if debugging >= 2;
+
+ $fh = $fh_cache{nul} ||= do {
+ open $fh, ">", File::Spec->devnull;
+ $fh;
+ };
+ } elsif ( $type eq "FH" ) {
+ $fh = $dest;
+ warn "run3(): redirecting $what to filehandle '$dest'\n"
+ if debugging >= 3;
+ } elsif ( !$type ) {
+ warn "run3(): feeding child $what to file '$dest'\n"
+ if debugging >= 2;
+
+ open $fh, $options->{"append_$what"} ? ">>" : ">", $dest
+ or croak "$!: $dest";
+ } else {
+ warn "run3(): capturing child $what\n"
+ if debugging >= 2;
+
+ $fh = $fh_cache{$what} ||= tempfile;
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ }
+
+ my $binmode_it = $options->{"binmode_$what"};
+ _binmode($fh, $binmode_it, uc $what);
+
+ return $fh;
+}
+
+sub _read_child_output_fh {
+ my ( $what, $type, $dest, $fh, $options ) = @_;
+
+ return if $type eq "SCALAR" && $dest == \undef;
+
+ seek $fh, 0, 0 or croak "$! seeking on temp file for child $what";
+
+ if ( $type eq "SCALAR" ) {
+ warn "run3(): reading child $what to SCALAR\n"
+ if debugging >= 3;
+
+ # two read()s are used instead of 1 so that the first will be
+ # logged even it reads 0 bytes; the second won't.
+ my $count = read $fh, $$dest, 10_000,
+ $options->{"append_$what"} ? length $$dest : 0;
+ while (1) {
+ croak "$! reading child $what from temp file"
+ unless defined $count;
+
+ last unless $count;
+
+ warn "run3(): read $count bytes from child $what",
+ debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ $count = read $fh, $$dest, 10_000, length $$dest;
+ }
+ } elsif ( $type eq "ARRAY" ) {
+ if ($options->{"append_$what"}) {
+ push @$dest, <$fh>;
+ } else {
+ @$dest = <$fh>;
+ }
+ if ( debugging >= 2 ) {
+ my $count = 0;
+ $count += length for @$dest;
+ warn
+ "run3(): read ",
+ scalar @$dest,
+ " records, $count bytes from child $what",
+ debugging >= 3 ? ( ": '", @$dest, "'" ) : (),
+ "\n";
+ }
+ } elsif ( $type eq "CODE" ) {
+ warn "run3(): capturing child $what to CODE ref\n"
+ if debugging >= 3;
+
+ local $_;
+ while ( <$fh> ) {
+ warn
+ "run3(): read ",
+ length,
+ " bytes from child $what",
+ debugging >= 3 ? ( ": '", $_, "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ $dest->( $_ );
+ }
+ } else {
+ croak "run3() can't redirect child $what to a $type";
+ }
+
+}
+
+sub _type {
+ my ( $redir ) = @_;
+ return "FH" if eval { $redir->isa("IO::Handle") };
+ my $type = ref $redir;
+ return $type eq "GLOB" ? "FH" : $type;
+}
+
+sub _max_fd {
+ my $fd = dup(0);
+ POSIX::close $fd;
+ return $fd;
+}
+
+my $run_call_time;
+my $sys_call_time;
+my $sys_exit_time;
+
+sub run3 {
+ $run_call_time = gettimeofday() if profiling;
+
+ my $options = @_ && ref $_[-1] eq "HASH" ? pop : {};
+
+ my ( $cmd, $stdin, $stdout, $stderr ) = @_;
+
+ print STDERR "run3(): running ",
+ join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ),
+ "\n"
+ if debugging;
+
+ if ( ref $cmd ) {
+ croak "run3(): empty command" unless @$cmd;
+ croak "run3(): undefined command" unless defined $cmd->[0];
+ croak "run3(): command name ('')" unless length $cmd->[0];
+ } else {
+ croak "run3(): missing command" unless @_;
+ croak "run3(): undefined command" unless defined $cmd;
+ croak "run3(): command ('')" unless length $cmd;
+ }
+
+ foreach (qw/binmode_stdin binmode_stdout binmode_stderr/) {
+ if (my $mode = $options->{$_}) {
+ croak qq[option $_ must be a number or a proper layer string: "$mode"]
+ unless $mode =~ /^(:|\d+$)/;
+ }
+ }
+
+ my $in_type = _type $stdin;
+ my $out_type = _type $stdout;
+ my $err_type = _type $stderr;
+
+ if ($fh_cache_pid != $$) {
+ # fork detected, close all cached filehandles and clear the cache
+ close $_ foreach values %fh_cache;
+ %fh_cache = ();
+ $fh_cache_pid = $$;
+ }
+
+ # This routine procedes in stages so that a failure in an early
+ # stage prevents later stages from running, and thus from needing
+ # cleanup.
+
+ my $in_fh = _spool_data_to_child $in_type, $stdin,
+ $options->{binmode_stdin} if defined $stdin;
+
+ my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout,
+ $options if defined $stdout;
+
+ my $tie_err_to_out =
+ defined $stderr && defined $stdout && $stderr eq $stdout;
+
+ my $err_fh = $tie_err_to_out
+ ? $out_fh
+ : _fh_for_child_output "stderr", $err_type, $stderr,
+ $options if defined $stderr;
+
+ # this should make perl close these on exceptions
+# local *STDIN_SAVE;
+ local *STDOUT_SAVE;
+ local *STDERR_SAVE;
+
+ my $saved_fd0 = dup( 0 ) if defined $in_fh;
+
+# open STDIN_SAVE, "<&STDIN"# or croak "run3(): $! saving STDIN"
+# if defined $in_fh;
+ open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT"
+ if defined $out_fh;
+ open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR"
+ if defined $err_fh;
+
+ my $errno;
+ my $ok = eval {
+ # The open() call here seems to not force fd 0 in some cases;
+ # I ran in to trouble when using this in VCP, not sure why.
+ # the dup2() seems to work.
+ dup2( fileno $in_fh, 0 )
+# open STDIN, "<&=" . fileno $in_fh
+ or croak "run3(): $! redirecting STDIN"
+ if defined $in_fh;
+
+# close $in_fh or croak "$! closing STDIN temp file"
+# if ref $stdin;
+
+ open STDOUT, ">&" . fileno $out_fh
+ or croak "run3(): $! redirecting STDOUT"
+ if defined $out_fh;
+
+ open STDERR, ">&" . fileno $err_fh
+ or croak "run3(): $! redirecting STDERR"
+ if defined $err_fh;
+
+ $sys_call_time = gettimeofday() if profiling;
+
+ my $r = ref $cmd
+ ? system { $cmd->[0] }
+ is_win32
+ ? map {
+ # Probably need to offer a win32 escaping
+ # option, every command may be different.
+ ( my $s = $_ ) =~ s/"/"""/g;
+ $s = qq{"$s"};
+ $s;
+ } @$cmd
+ : @$cmd
+ : system $cmd;
+
+ $errno = $!; # save $!, because later failures will overwrite it
+ $sys_exit_time = gettimeofday() if profiling;
+ if ( debugging ) {
+ my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
+ if ( defined $r && $r != -1 ) {
+ print $err_fh "run3(): \$? is $?\n";
+ } else {
+ print $err_fh "run3(): \$? is $?, \$! is $errno\n";
+ }
+ }
+
+ die $! if defined $r && $r == -1 && !$options->{return_if_system_error};
+
+ 1;
+ };
+ my $x = $@;
+
+ my @errs;
+
+ if ( defined $saved_fd0 ) {
+ dup2( $saved_fd0, 0 );
+ POSIX::close( $saved_fd0 );
+ }
+
+# open STDIN, "<&STDIN_SAVE"# or push @errs, "run3(): $! restoring STDIN"
+# if defined $in_fh;
+ open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT"
+ if defined $out_fh;
+ open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR"
+ if defined $err_fh;
+
+ croak join ", ", @errs if @errs;
+
+ die $x unless $ok;
+
+ _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options
+ if defined $out_fh && $out_type && $out_type ne "FH";
+ _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options
+ if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out;
+ $profiler->run_exit(
+ $cmd,
+ $run_call_time,
+ $sys_call_time,
+ $sys_exit_time,
+ scalar gettimeofday()
+ ) if profiling;
+
+ $! = $errno; # restore $! from system()
+
+ return 1;
+}
+
+1;
+
+__END__
+
+=head2 C<< run3($cmd, $stdin, $stdout, $stderr, \%options) >>
+
+All parameters after C<$cmd> are optional.
+
+The parameters C<$stdin>, C<$stdout> and C<$stderr> indicate
+how the child's corresponding filehandle
+(C<STDIN>, C<STDOUT> and C<STDERR>, resp.) will be redirected.
+Because the redirects come last, this allows C<STDOUT> and C<STDERR> to default
+to the parent's by just not specifying them -- a common use case.
+
+C<run3> throws an exception if the wrapped C<system> call returned -1
+or anything went wrong with C<run3>'s processing of filehandles.
+Otherwise it returns true.
+It leaves C<$?> intact for inspection of exit and wait status.
+
+Note that a true return value from C<run3> doesn't mean that the command
+had a successful exit code. Hence you should always check C<$?>.
+
+See L</%options> for an option to handle the case of C<system>
+returning -1 yourself.
+
+=head3 C<$cmd>
+
+Usually C<$cmd> will be an ARRAY reference and the child is invoked via
+
+ system @$cmd;
+
+But C<$cmd> may also be a string in which case the child is invoked via
+
+ system $cmd;
+
+(cf. L<perlfunc/system> for the difference and the pitfalls of using
+the latter form).
+
+=head3 C<$stdin>, C<$stdout>, C<$stderr>
+
+The parameters C<$stdin>, C<$stdout> and C<$stderr>
+can take one of the following forms:
+
+=over 4
+
+=item C<undef> (or not specified at all)
+
+The child inherits the corresponding filehandle from the parent.
+
+ run3 \@cmd, $stdin; # child writes to same STDOUT and STDERR as parent
+ run3 \@cmd, undef, $stdout, $stderr; # child reads from same STDIN as parent
+
+=item C<\undef>
+
+The child's filehandle is redirected from or to the
+local equivalent of C</dev/null> (as returned by
+C<< File::Spec->devnull() >>).
+
+ run3 \@cmd, \undef, $stdout, $stderr; # child reads from /dev/null
+
+=item a simple scalar
+
+The parameter is taken to be the name of a file to read from
+or write to. In the latter case, the file will be opened via
+
+ open FH, ">", ...
+
+i.e. it is created if it doesn't exist and truncated otherwise.
+Note that the file is opened by the parent which will L<croak|Carp/croak>
+in case of failure.
+
+ run3 \@cmd, \undef, "out.txt"; # child writes to file "out.txt"
+
+=item a filehandle (either a reference to a GLOB or an C<IO::Handle>)
+
+The filehandle is inherited by the child.
+
+ open my $fh, ">", "out.txt";
+ print $fh "prologue\n";
+ ...
+ run3 \@cmd, \undef, $fh; # child writes to $fh
+ ...
+ print $fh "epilogue\n";
+ close $fh;
+
+=item a SCALAR reference
+
+The referenced scalar is treated as a string to be read from or
+written to. In the latter case, the previous content of the string
+is overwritten.
+
+ my $out;
+ run3 \@cmd, \undef, \$out; # child writes into string
+ run3 \@cmd, \<<EOF; # child reads from string (can use "here" notation)
+ Input
+ to
+ child
+ EOF
+
+=item an ARRAY reference
+
+For C<$stdin>, the elements of C<@$stdin> are simply spooled to the child.
+
+For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
+is read line by line (as determined by the current setting of C<$/>)
+into C<@$stdout> or C<@$stderr>, resp. The previous content of the array
+is overwritten.
+
+ my @lines;
+ run3 \@cmd, \undef, \@lines; # child writes into array
+
+=item a CODE reference
+
+For C<$stdin>, C<&$stdin> will be called repeatedly (with no arguments) and
+the return values are spooled to the child. C<&$stdin> must signal the end of
+input by returning C<undef>.
+
+For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
+is read line by line (as determined by the current setting of C<$/>)
+and C<&$stdout> or C<&$stderr>, resp., is called with the contents of the line.
+Note that there's no end-of-file indication.
+
+ my $i = 0;
+ sub producer {
+ return $i < 10 ? "line".$i++."\n" : undef;
+ }
+
+ run3 \@cmd, \&producer; # child reads 10 lines
+
+Note that this form of redirecting the child's I/O doesn't imply
+any form of concurrency between parent and child - run3()'s method of
+operation is the same no matter which form of redirection you specify.
+
+=back
+
+If the same value is passed for C<$stdout> and C<$stderr>, then the child
+will write both C<STDOUT> and C<STDERR> to the same filehandle.
+In general, this means that
+
+ run3 \@cmd, \undef, "foo.txt", "foo.txt";
+ run3 \@cmd, \undef, \$both, \$both;
+
+will DWIM and pass a single file handle to the child for both C<STDOUT> and
+C<STDERR>, collecting all into file "foo.txt" or C<$both>.
+
+=head3 C<\%options>
+
+The last parameter, C<\%options>, must be a hash reference if present.
+
+Currently the following
+keys are supported:
+
+=over 4
+
+=item C<binmode_stdin>, C<binmode_stdout>, C<binmode_stderr>
+
+The value must a "layer" as described in L<perlfunc/binmode>.
+If specified the corresponding
+parameter C<$stdin>, C<$stdout> or C<$stderr>, resp., operates
+with the given layer.
+
+For backward compatibility, a true value that doesn't start with ":"
+(e.g. a number) is interpreted as ":raw". If the value is false
+or not specified, the default is ":crlf" on Windows and ":raw" otherwise.
+
+Don't expect that values other than the built-in layers ":raw", ":crlf",
+and (on newer Perls) ":bytes", ":utf8", ":encoding(...)" will work.
+
+=item C<append_stdout>, C<append_stderr>
+
+If their value is true then the corresponding
+parameter C<$stdout> or C<$stderr>, resp., will append the child's output
+to the existing "contents" of the redirector. This only makes
+sense if the redirector is a simple scalar (the corresponding file
+is opened in append mode), a SCALAR reference (the output is
+appended to the previous contents of the string)
+or an ARRAY reference (the output is C<push>ed onto the
+previous contents of the array).
+
+=item C<return_if_system_error>
+
+If this is true C<run3> does B<not> throw an exception if C<system>
+returns -1 (cf. L<perlfunc/system> for possible
+failure scenarios.), but returns true instead.
+In this case C<$?> has the value -1 and C<$!>
+contains the errno of the failing C<system> call.
+
+=back
+
+=head1 HOW IT WORKS
+
+=over 4
+
+=item (1)
+
+For each redirector C<$stdin>, C<$stdout>, and C<$stderr>,
+C<run3()> furnishes a filehandle:
+
+=over 4
+
+=item *
+
+if the redirector already specifies a filehandle it just uses that
+
+=item *
+
+if the redirector specifies a filename, C<run3()> opens the file
+in the appropriate mode
+
+=item *
+
+in all other cases, C<run3()> opens a temporary file
+(using L<tempfile|Temp/tempfile>)
+
+=back
+
+=item (2)
+
+If C<run3()> opened a temporary file for C<$stdin> in step (1),
+it writes the data using the specified method (either
+from a string, an array or returnd by a function) to the temporary file and rewinds it.
+
+=item (3)
+
+C<run3()> saves the parent's C<STDIN>, C<STDOUT> and C<STDERR> by duplicating
+them to new filehandles. It duplicates the filehandles from step (1)
+to C<STDIN>, C<STDOUT> and C<STDERR>, resp.
+
+=item (4)
+
+C<run3()> runs the child by invoking L<system|perlfunc/system>
+with C<$cmd> as specified above.
+
+=item (5)
+
+C<run3()> restores the parent's C<STDIN>, C<STDOUT> and C<STDERR> saved in step (3).
+
+=item (6)
+
+If C<run3()> opened a temporary file for C<$stdout> or C<$stderr> in step (1),
+it rewinds it and reads back its contents using the specified method
+(either to a string, an array or by calling a function).
+
+=item (7)
+
+C<run3()> closes all filehandles that it opened explicitly in step (1).
+
+=back
+
+Note that when using temporary files, C<run3()> tries to amortize the overhead
+by reusing them (i.e. it keeps them open and rewinds and truncates them
+before the next operation).
+
+=head1 LIMITATIONS
+
+Often uses intermediate files (determined by File::Temp, and thus by the
+File::Spec defaults and the TMPDIR env. variable) for speed, portability and
+simplicity.
+
+Use extrem caution when using C<run3> in a threaded environment if
+concurrent calls of C<run3> are possible. Most likely, I/O from different
+invocations will get mixed up. The reason is that in most thread
+implementations all threads in a process share the same STDIN/STDOUT/STDERR.
+Known failures are Perl ithreads on Linux and Win32. Note that C<fork>
+on Win32 is emulated via Win32 threads and hence I/O mix up is possible
+between forked children here (C<run3> is "fork safe" on Unix, though).
+
+=head1 DEBUGGING
+
+To enable debugging use the IPCRUN3DEBUG environment variable to
+a non-zero integer value:
+
+ $ IPCRUN3DEBUG=1 myapp
+
+=head1 PROFILING
+
+To enable profiling, set IPCRUN3PROFILE to a number to enable emitting profile
+information to STDERR (1 to get timestamps, 2 to get a summary report at the
+END of the program, 3 to get mini reports after each run) or to a filename to
+emit raw data to a file for later analysis.
+
+=head1 COMPARISON
+
+Here's how it stacks up to existing APIs:
+
+=head2 compared to C<system()>, C<qx''>, C<open "...|">, C<open "|...">
+
+=over
+
+=item +
+
+redirects more than one file descriptor
+
+=item +
+
+returns TRUE on success, FALSE on failure
+
+=item +
+
+throws an error if problems occur in the parent process (or the pre-exec child)
+
+=item +
+
+allows a very perlish interface to Perl data structures and subroutines
+
+=item +
+
+allows 1 word invocations to avoid the shell easily:
+
+ run3 ["foo"]; # does not invoke shell
+
+=item -
+
+does not return the exit code, leaves it in $?
+
+=back
+
+=head2 compared to C<open2()>, C<open3()>
+
+=over
+
+=item +
+
+no lengthy, error prone polling/select loop needed
+
+=item +
+
+hides OS dependancies
+
+=item +
+
+allows SCALAR, ARRAY, and CODE references to source and sink I/O
+
+=item +
+
+I/O parameter order is like C<open3()> (not like C<open2()>).
+
+=item -
+
+does not allow interaction with the subprocess
+
+=back
+
+=head2 compared to L<IPC::Run::run()|IPC::Run/run>
+
+=over
+
+=item +
+
+smaller, lower overhead, simpler, more portable
+
+=item +
+
+no select() loop portability issues
+
+=item +
+
+does not fall prey to Perl closure leaks
+
+=item -
+
+does not allow interaction with the subprocess (which
+IPC::Run::run() allows by redirecting subroutines)
+
+=item -
+
+lacks many features of C<IPC::Run::run()> (filters, pipes,
+redirects, pty support)
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>C<barries@slaysys.com>E<gt>
+
+Ricardo SIGNES E<lt>C<rjbs@cpan.org>E<gt> performed some routine maintenance in
+2005, thanks to help from the following ticket and/or patch submitters: Jody
+Belka, Roderich Schupp, David Morel, and anonymous others.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm
new file mode 100755
index 00000000000..15c58ea0b20
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm
@@ -0,0 +1,86 @@
+package IPC::Run3::ProfArrayBuffer;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfArrayBuffer - Store profile events in RAM in an array
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=over
+
+=item C<< IPC::Run3::ProfArrayBuffer->new() >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+
+ my $self = bless { @_ }, $class;
+
+ $self->{Events} = [];
+
+ return $self;
+}
+
+=item C<< $buffer->app_call(@events) >>
+
+=item C<< $buffer->app_exit(@events) >>
+
+=item C<< $buffer->run_exit(@events) >>
+
+The three above methods push the given events onto the stack of recorded
+events.
+
+=cut
+
+for my $subname ( qw(app_call app_exit run_exit) ) {
+ no strict 'refs';
+ *{$subname} = sub {
+ push @{shift->{Events}}, [ $subname => @_ ];
+ };
+}
+
+=item get_events
+
+Returns a list of all the events. Each event is an ARRAY reference
+like:
+
+ [ "app_call", 1.1, ... ];
+
+=cut
+
+sub get_events {
+ my $self = shift;
+ @{$self->{Events}};
+}
+
+=back
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm
new file mode 100755
index 00000000000..987b3a24f50
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm
@@ -0,0 +1,157 @@
+package IPC::Run3::ProfLogReader;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfLogReader - read and process a ProfLogger file
+
+=head1 SYNOPSIS
+
+ use IPC::Run3::ProfLogReader;
+
+ my $reader = IPC::Run3::ProfLogReader->new; ## use "run3.out"
+ my $reader = IPC::Run3::ProfLogReader->new( Source => $fn );
+
+ my $profiler = IPC::Run3::ProfPP; ## For example
+ my $reader = IPC::Run3::ProfLogReader->new( ..., Handler => $p );
+
+ $reader->read;
+ $eaderr->read_all;
+
+=head1 DESCRIPTION
+
+Reads a log file. Use the filename "-" to read from STDIN.
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfLogReader->new( ... ) >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+
+ $self->{Source} = "run3.out"
+ unless defined $self->{Source} && length $self->{Source};
+
+ my $source = $self->{Source};
+
+ if ( ref $source eq "GLOB" || UNIVERSAL::isa( $source, "IO::Handle" ) ) {
+ $self->{FH} = $source;
+ }
+ elsif ( $source eq "-" ) {
+ $self->{FH} = \*STDIN;
+ }
+ else {
+ open PROFILE, "<$self->{Source}" or die "$!: $self->{Source}\n";
+ $self->{FH} = *PROFILE{IO};
+ }
+ return $self;
+}
+
+
+=head2 C<< $reader->set_handler( $handler ) >>
+
+=cut
+
+sub set_handler { $_[0]->{Handler} = $_[1] }
+
+=head2 C<< $reader->get_handler() >>
+
+=cut
+
+sub get_handler { $_[0]->{Handler} }
+
+=head2 C<< $reader->read() >>
+
+=cut
+
+sub read {
+ my $self = shift;
+
+ my $fh = $self->{FH};
+ my @ln = split / /, <$fh>;
+
+ return 0 unless @ln;
+ return 1 unless $self->{Handler};
+
+ chomp $ln[-1];
+
+ ## Ignore blank and comment lines.
+ return 1 if @ln == 1 && ! length $ln[0] || 0 == index $ln[0], "#";
+
+ if ( $ln[0] eq "\\app_call" ) {
+ shift @ln;
+ my @times = split /,/, pop @ln;
+ $self->{Handler}->app_call(
+ [
+ map {
+ s/\\\\/\\/g;
+ s/\\_/ /g;
+ $_;
+ } @ln
+ ],
+ @times
+ );
+ }
+ elsif ( $ln[0] eq "\\app_exit" ) {
+ shift @ln;
+ $self->{Handler}->app_exit( pop @ln, @ln );
+ }
+ else {
+ my @times = split /,/, pop @ln;
+ $self->{Handler}->run_exit(
+ [
+ map {
+ s/\\\\/\\/g;
+ s/\\_/ /g;
+ $_;
+ } @ln
+ ],
+ @times
+ );
+ }
+
+ return 1;
+}
+
+
+=head2 C<< $reader->read_all() >>
+
+This method reads until there is nothing left to read, and then returns true.
+
+=cut
+
+sub read_all {
+ my $self = shift;
+
+ 1 while $self->read;
+
+ return 1;
+}
+
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm
new file mode 100755
index 00000000000..8bbc06a61b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm
@@ -0,0 +1,139 @@
+package IPC::Run3::ProfLogger;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfLogger - write profiling data to a log file
+
+=head1 SYNOPSIS
+
+ use IPC::Run3::ProfLogger;
+
+ my $logger = IPC::Run3::ProfLogger->new; ## write to "run3.out"
+ my $logger = IPC::Run3::ProfLogger->new( Destination => $fn );
+
+ $logger->app_call( \@cmd, $time );
+
+ $logger->run_exit( \@cmd1, @times1 );
+ $logger->run_exit( \@cmd1, @times1 );
+
+ $logger->app_exit( $time );
+
+=head1 DESCRIPTION
+
+Used by IPC::Run3 to write a profiling log file. Does not
+generate reports or maintain statistics; its meant to have minimal
+overhead.
+
+Its API is compatible with a tiny subset of the other IPC::Run profiling
+classes.
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfLogger->new( ... ) >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+
+ $self->{Destination} = "run3.out"
+ unless defined $self->{Destination} && length $self->{Destination};
+
+ open PROFILE, ">$self->{Destination}"
+ or die "$!: $self->{Destination}\n";
+ binmode PROFILE;
+ $self->{FH} = *PROFILE{IO};
+
+ $self->{times} = [];
+ return $self;
+}
+
+=head2 C<< $logger->run_exit( ... ) >>
+
+=cut
+
+sub run_exit {
+ my $self = shift;
+ my $fh = $self->{FH};
+ print( $fh
+ join(
+ " ",
+ (
+ map {
+ my $s = $_;
+ $s =~ s/\\/\\\\/g;
+ $s =~ s/ /_/g;
+ $s;
+ } @{shift()}
+ ),
+ join(
+ ",",
+ @{$self->{times}},
+ @_,
+ ),
+ ),
+ "\n"
+ );
+}
+
+=head2 C<< $logger->app_exit( $arg ) >>
+
+=cut
+
+sub app_exit {
+ my $self = shift;
+ my $fh = $self->{FH};
+ print $fh "\\app_exit ", shift, "\n";
+}
+
+=head2 C<< $logger->app_call( $t, @args) >>
+
+=cut
+
+sub app_call {
+ my $self = shift;
+ my $fh = $self->{FH};
+ my $t = shift;
+ print( $fh
+ join(
+ " ",
+ "\\app_call",
+ (
+ map {
+ my $s = $_;
+ $s =~ s/\\\\/\\/g;
+ $s =~ s/ /\\_/g;
+ $s;
+ } @_
+ ),
+ $t,
+ ),
+ "\n"
+ );
+}
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm
new file mode 100755
index 00000000000..112c3a2e8d6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm
@@ -0,0 +1,156 @@
+package IPC::Run3::ProfPP;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfPP - Generate reports from IPC::Run3 profiling data
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Used by IPC::Run3 and/or run3profpp to print out profiling reports for
+human readers. Use other classes for extracting data in other ways.
+
+The output methods are plain text, override these (see the source for
+now) to provide other formats.
+
+This class generates reports on each run3_exit() and app_exit() call.
+
+=cut
+
+require IPC::Run3::ProfReporter;
+@ISA = qw( IPC::Run3::ProfReporter );
+
+use strict;
+use POSIX qw( floor );
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfPP->new() >>
+
+Returns a new profile reporting object.
+
+=cut
+
+sub _emit { shift; warn @_ }
+
+sub _t {
+ sprintf "%10.6f secs", @_;
+}
+
+sub _r {
+ my ( $num, $denom ) = @_;
+ return () unless $denom;
+ sprintf "%10.6f", $num / $denom;
+}
+
+sub _pct {
+ my ( $num, $denom ) = @_;
+ return () unless $denom;
+ sprintf " (%3d%%)", floor( 100 * $num / $denom + 0.5 );
+}
+
+=head2 C<< $profpp->handle_app_call() >>
+
+=cut
+
+sub handle_app_call {
+ my $self = shift;
+ $self->_emit("IPC::Run3 parent: ",
+ join( " ", @{$self->get_app_cmd} ),
+ "\n",
+ );
+
+ $self->{NeedNL} = 1;
+}
+
+=head2 C<< $profpp->handle_app_exit() >>
+
+=cut
+
+sub handle_app_exit {
+ my $self = shift;
+
+ $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 1;
+
+ $self->_emit( "IPC::Run3 total elapsed: ",
+ _t( $self->get_app_cumulative_time ),
+ "\n");
+ $self->_emit( "IPC::Run3 calls to run3(): ",
+ sprintf( "%10d", $self->get_run_count ),
+ "\n");
+ $self->_emit( "IPC::Run3 total spent in run3(): ",
+ _t( $self->get_run_cumulative_time ),
+ _pct( $self->get_run_cumulative_time, $self->get_app_cumulative_time ),
+ ", ",
+ _r( $self->get_run_cumulative_time, $self->get_run_count ),
+ " per call",
+ "\n");
+ my $exclusive =
+ $self->get_app_cumulative_time - $self->get_run_cumulative_time;
+ $self->_emit( "IPC::Run3 total spent not in run3(): ",
+ _t( $exclusive ),
+ _pct( $exclusive, $self->get_app_cumulative_time ),
+ "\n");
+ $self->_emit( "IPC::Run3 total spent in children: ",
+ _t( $self->get_sys_cumulative_time ),
+ _pct( $self->get_sys_cumulative_time, $self->get_app_cumulative_time ),
+ ", ",
+ _r( $self->get_sys_cumulative_time, $self->get_run_count ),
+ " per call",
+ "\n");
+ my $overhead =
+ $self->get_run_cumulative_time - $self->get_sys_cumulative_time;
+ $self->_emit( "IPC::Run3 total overhead: ",
+ _t( $overhead ),
+ _pct(
+ $overhead,
+ $self->get_sys_cumulative_time
+ ),
+ ", ",
+ _r( $overhead, $self->get_run_count ),
+ " per call",
+ "\n");
+}
+
+=head2 C<< $profpp->handle_run_exit() >>
+
+=cut
+
+sub handle_run_exit {
+ my $self = shift;
+ my $overhead = $self->get_run_time - $self->get_sys_time;
+
+ $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 2;
+ $self->{NeedNL} = 3;
+
+ $self->_emit( "IPC::Run3 child: ",
+ join( " ", @{$self->get_run_cmd} ),
+ "\n");
+ $self->_emit( "IPC::Run3 run3() : ", _t( $self->get_run_time ), "\n",
+ "IPC::Run3 child : ", _t( $self->get_sys_time ), "\n",
+ "IPC::Run3 overhead: ", _t( $overhead ),
+ _pct( $overhead, $self->get_sys_time ),
+ "\n");
+}
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm
new file mode 100755
index 00000000000..2fa9060e1e4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm
@@ -0,0 +1,256 @@
+package IPC::Run3::ProfReporter;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfReporter - base class for handling profiling data
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+See L<IPC::Run3::ProfPP|IPC::Run3::ProfPP> and for an example subclass.
+
+This class just notes and accumulates times; subclasses use methods like
+"handle_app_call", "handle_run_exit" and "handle_app_exit" to emit reports on
+it. The default methods for these handlers are noops.
+
+If run from the command line, a reporter will be created and run on
+each logfile given as a command line parameter or on run3.out if none
+are given.
+
+This allows reports to be run like:
+
+ perl -MIPC::Run3::ProfPP -e1
+ perl -MIPC::Run3::ProfPP -e1 foo.out bar.out
+
+Use "-" to read from STDIN (the log file format is meant to be moderately
+greppable):
+
+ grep "^cvs " run3.out perl -MIPC::Run3::ProfPP -e1 -
+
+Use --app to show only application level statistics (ie don't emit
+a report section for each command run).
+
+=cut
+
+use strict;
+
+my $loaded_by;
+
+sub import {
+ $loaded_by = shift;
+}
+
+END {
+ my @caller;
+ for ( my $i = 0;; ++$i ) {
+ my @c = caller $i;
+ last unless @c;
+ @caller = @c;
+ }
+
+ if ( $caller[0] eq "main"
+ && $caller[1] eq "-e"
+ ) {
+ require IPC::Run3::ProfLogReader;
+ require Getopt::Long;
+ my ( $app, $run );
+
+ Getopt::Long::GetOptions(
+ "app" => \$app,
+ "run" => \$run,
+ );
+
+ $app = 1, $run = 1 unless $app || $run;
+
+ for ( @ARGV ? @ARGV : "" ) {
+ my $r = IPC::Run3::ProfLogReader->new(
+ Source => $_,
+ Handler => $loaded_by->new(
+ Source => $_,
+ app_report => $app,
+ run_report => $run,
+ ),
+ );
+ $r->read_all;
+ }
+ }
+}
+
+=head1 METHODS
+
+=over
+
+=item C<< IPC::Run3::ProfReporter->new >>
+
+Returns a new profile reporting object.
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+ $self->{app_report} = 1, $self->{run_report} = 1
+ unless $self->{app_report} || $self->{run_report};
+
+ return $self;
+}
+
+=item C<< $reporter->handle_app_call( ... ) >>
+
+=item C<< $reporter->handle_app_exit( ... ) >>
+
+=item C<< $reporter->handle_run_exit( ... ) >>
+
+These methods are called by the handled events (see below).
+
+=cut
+
+sub handle_app_call {}
+sub handle_app_exit {}
+
+sub handle_run_exit {}
+
+=item C<< $reporter->app_call(\@cmd, $time) >>
+
+=item C<< $reporter->app_exit($time) >>
+
+=item C<< $reporter->run_exit(@times) >>
+
+ $self->app_call( $time );
+ my $time = $self->get_app_call_time;
+
+Sets the time (in floating point seconds) when the application, run3(),
+or system() was called or exited. If no time parameter is passed, uses
+IPC::Run3's time routine.
+
+Use get_...() to retrieve these values (and _accum values, too). This
+is a separate method to speed the execution time of the setters just a
+bit.
+
+=cut
+
+sub app_call {
+ my $self = shift;
+ ( $self->{app_cmd}, $self->{app_call_time} ) = @_;
+ $self->handle_app_call if $self->{app_report};
+}
+
+sub app_exit {
+ my $self = shift;
+ $self->{app_exit_time} = shift;
+ $self->handle_app_exit if $self->{app_report};
+}
+
+sub run_exit {
+ my $self = shift;
+ @{$self}{qw(
+ run_cmd run_call_time sys_call_time sys_exit_time run_exit_time
+ )} = @_;
+
+ ++$self->{run_count};
+ $self->{run_cumulative_time} += $self->get_run_time;
+ $self->{sys_cumulative_time} += $self->get_sys_time;
+ $self->handle_run_exit if $self->{run_report};
+}
+
+=item C<< $reporter->get_run_count() >>
+
+=item C<< $reporter->get_app_call_time() >>
+
+=item C<< $reporter->get_app_exit_time() >>
+
+=item C<< $reporter->get_app_cmd() >>
+
+=item C<< $reporter->get_app_time() >>
+
+=cut
+
+sub get_run_count { shift->{run_count} }
+sub get_app_call_time { shift->{app_call_time} }
+sub get_app_exit_time { shift->{app_exit_time} }
+sub get_app_cmd { shift->{app_cmd} }
+sub get_app_time {
+ my $self = shift;
+ $self->get_app_exit_time - $self->get_app_call_time;
+}
+
+=item C<< $reporter->get_app_cumulative_time() >>
+
+=cut
+
+sub get_app_cumulative_time {
+ my $self = shift;
+ $self->get_app_exit_time - $self->get_app_call_time;
+}
+
+=item C<< $reporter->get_run_call_time() >>
+
+=item C<< $reporter->get_run_exit_time() >>
+
+=item C<< $reporter->get_run_time() >>
+
+=cut
+
+sub get_run_call_time { shift->{run_call_time} }
+sub get_run_exit_time { shift->{run_exit_time} }
+sub get_run_time {
+ my $self = shift;
+ $self->get_run_exit_time - $self->get_run_call_time;
+}
+
+=item C<< $reporter->get_run_cumulative_time() >>
+
+=cut
+
+sub get_run_cumulative_time { shift->{run_cumulative_time} }
+
+=item C<< $reporter->get_sys_call_time() >>
+
+=item C<< $reporter->get_sys_exit_time() >>
+
+=item C<< $reporter->get_sys_time() >>
+
+=cut
+
+sub get_sys_call_time { shift->{sys_call_time} }
+sub get_sys_exit_time { shift->{sys_exit_time} }
+sub get_sys_time {
+ my $self = shift;
+ $self->get_sys_exit_time - $self->get_sys_call_time;
+}
+
+=item C<< $reporter->get_sys_cumulative_time() >>
+
+=cut
+
+sub get_sys_cumulative_time { shift->{sys_cumulative_time} }
+
+=item C<< $reporter->get_run_cmd() >>
+
+=cut
+
+sub get_run_cmd { shift->{run_cmd} }
+
+=back
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker <barries@slaysys.com>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm b/Master/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm
new file mode 100755
index 00000000000..73172c5531f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm
@@ -0,0 +1,1076 @@
+package IPC::System::Simple;
+
+use 5.006;
+use strict;
+use warnings;
+use re 'taint';
+use Carp;
+use List::Util qw(first);
+use Scalar::Util qw(tainted);
+use Config;
+use constant WINDOWS => ($^O eq 'MSWin32');
+use constant VMS => ($^O eq 'VMS');
+
+BEGIN {
+
+ # It would be lovely to use the 'if' module here, but it didn't
+ # enter core until 5.6.2, and we want to keep 5.6.0 compatibility.
+
+
+ if (WINDOWS) {
+
+ ## no critic (ProhibitStringyEval)
+
+ eval q{
+ use Win32::Process qw(INFINITE NORMAL_PRIORITY_CLASS);
+ use File::Spec;
+ use Win32;
+
+ # This uses the same rules as the core win32.c/get_shell() call.
+
+ use constant WINDOWS_SHELL => eval { Win32::IsWinNT() }
+ ? [ qw(cmd.exe /x/d/c) ]
+ : [ qw(command.com /c) ];
+
+ # These are used when invoking _win32_capture
+ use constant NO_SHELL => 0;
+ use constant USE_SHELL => 1;
+
+ };
+
+ ## use critic
+
+ # Die nosily if any of the above broke.
+ die $@ if $@;
+ }
+}
+
+# Note that we don't use WIFSTOPPED because perl never uses
+# the WUNTRACED flag, and hence will never return early from
+# system() if the child processes is suspended with a SIGSTOP.
+
+use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
+
+use constant FAIL_START => q{"%s" failed to start: "%s"};
+use constant FAIL_PLUMBING => q{Error in IPC::System::Simple plumbing: "%s" - "%s"};
+use constant FAIL_CMD_BLANK => q{Entirely blank command passed: "%s"};
+use constant FAIL_INTERNAL => q{Internal error in IPC::System::Simple: "%s"};
+use constant FAIL_TAINT => q{%s called with tainted argument "%s"};
+use constant FAIL_TAINT_ENV => q{%s called with tainted environment $ENV{%s}};
+use constant FAIL_SIGNAL => q{"%s" died to signal "%s" (%d)%s};
+use constant FAIL_BADEXIT => q{"%s" unexpectedly returned exit value %d};
+
+use constant FAIL_UNDEF => q{%s called with undefined command};
+
+use constant FAIL_POSIX => q{IPC::System::Simple does not understand the POSIX error '%s'. Please check http://search.cpan.org/perldoc?IPC::System::Simple to see if there is an updated version. If not please report this as a bug to http://rt.cpan.org/Public/Bug/Report.html?Queue=IPC-System-Simple};
+
+# On Perl's older than 5.8.x we can't assume that there'll be a
+# $^{TAINT} for us to check, so we assume that our args may always
+# be tainted.
+use constant ASSUME_TAINTED => ($] < 5.008);
+
+use constant EXIT_ANY_CONST => -1; # Used internally
+use constant EXIT_ANY => [ EXIT_ANY_CONST ]; # Exported
+
+use constant UNDEFINED_POSIX_RE => qr{not (?:defined|a valid) POSIX macro|not implemented on this architecture};
+
+require Exporter;
+our @ISA = qw(Exporter);
+
+our @EXPORT_OK = qw(
+ capture capturex
+ run runx
+ system systemx
+ $EXITVAL EXIT_ANY
+);
+
+our $VERSION = '1.20';
+our $EXITVAL = -1;
+
+my @Signal_from_number = split(' ', $Config{sig_name});
+
+# Environment variables we don't want to see tainted.
+my @Check_tainted_env = qw(PATH IFS CDPATH ENV BASH_ENV);
+if (WINDOWS) {
+ push(@Check_tainted_env, 'PERL5SHELL');
+}
+if (VMS) {
+ push(@Check_tainted_env, 'DCL$PATH');
+}
+
+# Not all systems implment the WIFEXITED calls, but POSIX
+# will always export them (even if they're just stubs that
+# die with an error). Test for the presence of a working
+# WIFEXITED and friends, or define our own.
+
+eval { WIFEXITED(0); };
+
+if ($@ =~ UNDEFINED_POSIX_RE) {
+ no warnings 'redefine'; ## no critic
+ *WIFEXITED = sub { not $_[0] & 0xff };
+ *WEXITSTATUS = sub { $_[0] >> 8 };
+ *WIFSIGNALED = sub { $_[0] & 127 };
+ *WTERMSIG = sub { $_[0] & 127 };
+} elsif ($@) {
+ croak sprintf FAIL_POSIX, $@;
+}
+
+# None of the POSIX modules I've found define WCOREDUMP, although
+# many systems define it. Check the POSIX module in the hope that
+# it may actually be there.
+
+
+# TODO: Ideally, $NATIVE_WCOREDUMP should be a constant.
+
+my $NATIVE_WCOREDUMP;
+
+eval { POSIX::WCOREDUMP(1); };
+
+if ($@ =~ UNDEFINED_POSIX_RE) {
+ *WCOREDUMP = sub { $_[0] & 128 };
+ $NATIVE_WCOREDUMP = 0;
+} elsif ($@) {
+ croak sprintf FAIL_POSIX, $@;
+} else {
+ # POSIX actually has it defined! Huzzah!
+ *WCOREDUMP = \&POSIX::WCOREDUMP;
+ $NATIVE_WCOREDUMP = 1;
+}
+
+sub _native_wcoredump {
+ return $NATIVE_WCOREDUMP;
+}
+
+# system simply calls run
+
+*system = \&run;
+*systemx = \&runx;
+
+# run is our way of running a process with system() semantics
+
+sub run {
+
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ # If we have arguments, we really want to call systemx,
+ # so we do so.
+
+ if (@args) {
+ return systemx($valid_returns, $command, @args);
+ }
+
+ # Without arguments, we're calling system, and checking
+ # the results.
+
+ # We're throwing our own exception on command not found, so
+ # we don't need a warning from Perl.
+
+ no warnings 'exec'; ## no critic
+ CORE::system($command,@args);
+
+ return _process_child_error($?,$command,$valid_returns);
+}
+
+# runx is just like system/run, but *never* invokes the shell.
+
+sub runx {
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ if (WINDOWS) {
+ our $EXITVAL = -1;
+
+ my $pid = _spawn_or_die($command, "$command @args");
+
+ $pid->Wait(INFINITE); # Wait for process exit.
+ $pid->GetExitCode($EXITVAL);
+ return _check_exit($command,$EXITVAL,$valid_returns);
+ }
+
+ # If system() fails, we throw our own exception. We don't
+ # need to have perl complain about it too.
+
+ no warnings; ## no critic
+
+ CORE::system { $command } $command, @args;
+
+ return _process_child_error($?, $command, $valid_returns);
+}
+
+# capture is our way of running a process with backticks/qx semantics
+
+sub capture {
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ if (@args) {
+ return capturex($valid_returns, $command, @args);
+ }
+
+ if (WINDOWS) {
+ # USE_SHELL really means "You may use the shell if you need it."
+ return _win32_capture(USE_SHELL, $valid_returns, $command, @args);
+ }
+
+ our $EXITVAL = -1;
+
+ my $wantarray = wantarray();
+
+ # We'll produce our own warnings on failure to execute.
+ no warnings 'exec'; ## no critic
+
+ if ($wantarray) {
+ my @results = qx($command);
+ _process_child_error($?,$command,$valid_returns);
+ return @results;
+ }
+
+ my $results = qx($command);
+ _process_child_error($?,$command,$valid_returns);
+ return $results;
+}
+
+# _win32_capture implements the capture and capurex commands on Win32.
+# We need to wrap the whole internals of this sub into
+# an if (WINDOWS) block to avoid it being compiled on non-Win32 systems.
+
+sub _win32_capture {
+ if (not WINDOWS) {
+ croak sprintf(FAIL_INTERNAL, "_win32_capture called when not under Win32");
+ } else {
+
+ my ($use_shell, $valid_returns, $command, @args) = @_;
+
+ my $wantarray = wantarray();
+
+ # Perl doesn't support multi-arg open under
+ # Windows. Perl also doesn't provide very good
+ # feedback when normal backtails fail, either;
+ # it returns exit status from the shell
+ # (which is indistinguishable from the command
+ # running and producing the same exit status).
+
+ # As such, we essentially have to write our own
+ # backticks.
+
+ # We start by dup'ing STDOUT.
+
+ open(my $saved_stdout, '>&', \*STDOUT) ## no critic
+ or croak sprintf(FAIL_PLUMBING, "Can't dup STDOUT", $!);
+
+ # We now open up a pipe that will allow us to
+ # communicate with the new process.
+
+ pipe(my ($read_fh, $write_fh))
+ or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);
+
+ # Allow CRLF sequences to become "\n", since
+ # this is what Perl backticks do.
+
+ binmode($read_fh, ':crlf');
+
+ # Now we re-open our STDOUT to $write_fh...
+
+ open(STDOUT, '>&', $write_fh) ## no critic
+ or croak sprintf(FAIL_PLUMBING, "Can't redirect STDOUT", $!);
+
+ # If we have args, or we're told not to use the shell, then
+ # we treat $command as our shell. Otherwise we grub around
+ # in our command to look for a command to run.
+ #
+ # Note that we don't actually *use* the shell (although in
+ # a future version we might). Being told not to use the shell
+ # (capturex) means we treat our command as really being a command,
+ # and not a command line.
+
+ my $exe = @args ? $command :
+ (! $use_shell) ? $command :
+ $command =~ m{^"([^"]+)"}x ? $1 :
+ $command =~ m{(\S+) }x ? $1 :
+ croak sprintf(FAIL_CMD_BLANK, $command);
+
+ # And now we spawn our new process with inherited
+ # filehandles.
+
+ my $pid = _spawn_or_die($exe, "$command @args");
+
+ # Now restore our STDOUT.
+ open(STDOUT, '>&', $saved_stdout) ## no critic
+ or croak sprintf(FAIL_PLUMBING,"Can't restore STDOUT", $!);
+
+ # Clean-up the filehandles we no longer need...
+
+ close($write_fh)
+ or croak sprintf(FAIL_PLUMBING,q{Can't close write end of pipe}, $!);
+ close($saved_stdout)
+ or croak sprintf(FAIL_PLUMBING,q{Can't close saved STDOUT}, $!);
+
+ # Read the data from our child...
+
+ my (@results, $result);
+
+ if ($wantarray) {
+ @results = <$read_fh>;
+ } else {
+ $result = join("",<$read_fh>);
+ }
+
+ # Tidy up our windows process and we're done!
+
+ $pid->Wait(INFINITE); # Wait for process exit.
+ $pid->GetExitCode($EXITVAL);
+
+ _check_exit($command,$EXITVAL,$valid_returns);
+
+ return $wantarray ? @results : $result;
+
+ }
+}
+
+# capturex() is just like backticks/qx, but never invokes the shell.
+
+sub capturex {
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ our $EXITVAL = -1;
+
+ my $wantarray = wantarray();
+
+ if (WINDOWS) {
+ return _win32_capture(NO_SHELL, $valid_returns, $command, @args);
+ }
+
+ # We can't use a multi-arg piped open here, since 5.6.x
+ # doesn't like them. Instead we emulate what 5.8.x does,
+ # which is to create a pipe(), set the close-on-exec flag
+ # on the child, and the fork/exec. If the exec fails, the
+ # child writes to the pipe. If the exec succeeds, then
+ # the pipe closes without data.
+
+ pipe(my ($read_fh, $write_fh))
+ or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);
+
+ # This next line also does an implicit fork.
+ my $pid = open(my $pipe, '-|'); ## no critic
+
+ if (not defined $pid) {
+ croak sprintf(FAIL_START, $command, $!);
+ } elsif (not $pid) {
+ # Child process, execs command.
+
+ close($read_fh);
+
+ # TODO: 'no warnings exec' doesn't get rid
+ # of the 'unlikely to be reached' warnings.
+ # This is a bug in perl / perldiag / perllexwarn / warnings.
+
+ no warnings; ## no critic
+
+ CORE::exec { $command } $command, @args;
+
+ # Oh no, exec fails! Send the reason why to
+ # the parent.
+
+ print {$write_fh} int($!);
+ exit(-1);
+ }
+
+ {
+ # In parent process.
+
+ close($write_fh);
+
+ # Parent process, check for child error.
+ my $error = <$read_fh>;
+
+ # Tidy up our pipes.
+ close($read_fh);
+
+ # Check for error.
+ if ($error) {
+ # Setting $! to our child error number gives
+ # us nice looking strings when printed.
+ local $! = $error;
+ croak sprintf(FAIL_START, $command, $!);
+ }
+ }
+
+ # Parent process, we don't care about our pid, but we
+ # do go and read our pipe.
+
+ if ($wantarray) {
+ my @results = <$pipe>;
+ close($pipe);
+ _process_child_error($?,$command,$valid_returns);
+ return @results;
+ }
+
+ # NB: We don't check the return status on close(), since
+ # on failure it sets $?, which we then inspect for more
+ # useful information.
+
+ my $results = join("",<$pipe>);
+ close($pipe);
+ _process_child_error($?,$command,$valid_returns);
+
+ return $results;
+
+}
+
+# Tries really hard to spawn a process under Windows. Returns
+# the pid on success, or undef on error.
+
+sub _spawn_or_die {
+
+ # We need to wrap practically the entire sub in an
+ # if block to ensure it doesn't get compiled under non-Win32
+ # systems. Compiling on these systems would not only be a
+ # waste of time, but also results in complaints about
+ # the NORMAL_PRIORITY_CLASS constant.
+
+ if (not WINDOWS) {
+ croak sprintf(FAIL_INTERNAL, "_spawn_or_die called when not under Win32");
+ } else {
+ my ($orig_exe, $cmdline) = @_;
+ my $pid;
+
+ my $exe = $orig_exe;
+
+ # If our command doesn't have an extension, add one.
+ $exe .= $Config{_exe} if ($exe !~ m{\.});
+
+ Win32::Process::Create(
+ $pid, $exe, $cmdline, 1, NORMAL_PRIORITY_CLASS, "."
+ ) and return $pid;
+
+ my @path = split(/;/,$ENV{PATH});
+
+ foreach my $dir (@path) {
+ my $fullpath = File::Spec->catfile($dir,$exe);
+
+ # We're using -x here on the assumption that stat()
+ # is faster than spawn, so trying to spawn a process
+ # for each path element will be unacceptably
+ # inefficient.
+
+ if (-x $fullpath) {
+ Win32::Process::Create(
+ $pid, $fullpath, $cmdline, 1,
+ NORMAL_PRIORITY_CLASS, "."
+ ) and return $pid;
+ }
+ }
+
+ croak sprintf(FAIL_START, $orig_exe, $^E);
+ }
+}
+
+# Complain on tainted arguments or environment.
+# ASSUME_TAINTED is true for 5.6.x, since it's missing ${^TAINT}
+
+sub _check_taint {
+ return if not (ASSUME_TAINTED or ${^TAINT});
+ my $caller = (caller(1))[3];
+ foreach my $var (@_) {
+ if (tainted $var) {
+ croak sprintf(FAIL_TAINT, $caller, $var);
+ }
+ }
+ foreach my $var (@Check_tainted_env) {
+ if (tainted $ENV{$var} ) {
+ croak sprintf(FAIL_TAINT_ENV, $caller, $var);
+ }
+ }
+
+ return;
+
+}
+
+# This subroutine performs the difficult task of interpreting
+# $?. It's not intended to be called directly, as it will
+# croak on errors, and its implementation and interface may
+# change in the future.
+
+sub _process_child_error {
+ my ($child_error, $command, $valid_returns) = @_;
+
+ $EXITVAL = -1;
+
+ my $coredump = WCOREDUMP($child_error);
+
+ # There's a bug in perl 5.10.0 where if the system
+ # does not provide a native WCOREDUMP, then $? will
+ # never contain coredump information. This code
+ # checks to see if we have the bug, and works around
+ # it if needed.
+
+ if ($] >= 5.010 and not $NATIVE_WCOREDUMP) {
+ $coredump ||= WCOREDUMP( ${^CHILD_ERROR_NATIVE} );
+ }
+
+ if ($child_error == -1) {
+ croak sprintf(FAIL_START, $command, $!);
+
+ } elsif ( WIFEXITED( $child_error ) ) {
+ $EXITVAL = WEXITSTATUS( $child_error );
+
+ return _check_exit($command,$EXITVAL,$valid_returns);
+
+ } elsif ( WIFSIGNALED( $child_error ) ) {
+ my $signal_no = WTERMSIG( $child_error );
+ my $signal_name = $Signal_from_number[$signal_no] || "UNKNOWN";
+
+ croak sprintf FAIL_SIGNAL, $command, $signal_name, $signal_no, ($coredump ? " and dumped core" : "");
+
+
+ }
+
+ croak sprintf(FAIL_INTERNAL, qq{'$command' ran without exit value or signal});
+
+}
+
+# A simple subroutine for checking exit values. Results in better
+# assurance of consistent error messages, and better forward support
+# for new features in I::S::S.
+
+sub _check_exit {
+ my ($command, $exitval, $valid_returns) = @_;
+
+ # If we have a single-value list consisting of the EXIT_ANY
+ # value, then we're happy with whatever exit value we're given.
+ if (@$valid_returns == 1 and $valid_returns->[0] == EXIT_ANY_CONST) {
+ return $exitval;
+ }
+
+ if (not defined first { $_ == $exitval } @$valid_returns) {
+ croak sprintf FAIL_BADEXIT, $command, $exitval;
+ }
+ return $exitval;
+}
+
+
+# This subroutine simply determines a list of valid returns, the command
+# name, and any arguments that we need to pass to it.
+
+sub _process_args {
+ my $valid_returns = [ 0 ];
+ my $caller = (caller(1))[3];
+
+ if (not @_) {
+ croak "$caller called with no arguments";
+ }
+
+ if (ref $_[0] eq "ARRAY") {
+ $valid_returns = shift(@_);
+ }
+
+ if (not @_) {
+ croak "$caller called with no command";
+ }
+
+ my $command = shift(@_);
+
+ if (not defined $command) {
+ croak sprintf( FAIL_UNDEF, $caller );
+ }
+
+ return ($valid_returns,$command,@_);
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::System::Simple - Run commands simply, with detailed diagnostics
+
+=head1 SYNOPSIS
+
+ use IPC::System::Simple qw(system systemx capture capturex);
+
+ system("some_command"); # Command succeeds or dies!
+
+ system("some_command",@args); # Succeeds or dies, avoids shell if @args
+
+ systemx("some_command",@args); # Succeeds or dies, NEVER uses the shell
+
+
+ # Capture the output of a command (just like backticks). Dies on error.
+ my $output = capture("some_command");
+
+ # Just like backticks in list context. Dies on error.
+ my @output = capture("some_command");
+
+ # As above, but avoids the shell if @args is non-empty
+ my $output = capture("some_command", @args);
+
+ # As above, but NEVER invokes the shell.
+ my $output = capturex("some_command", @args);
+ my @output = capturex("some_command", @args);
+
+=head1 DESCRIPTION
+
+Calling Perl's in-built C<system()> function is easy,
+determining if it was successful is I<hard>. Let's face it,
+C<$?> isn't the nicest variable in the world to play with, and
+even if you I<do> check it, producing a well-formatted error
+string takes a lot of work.
+
+C<IPC::System::Simple> takes the hard work out of calling
+external commands. In fact, if you want to be really lazy,
+you can just write:
+
+ use IPC::System::Simple qw(system);
+
+and all of your C<system> commands will either succeeed (run to
+completion and return a zero exit value), or die with rich diagnostic
+messages.
+
+The C<IPC::System::Simple> module also provides a simple replacement
+to Perl's backticks operator. Simply write:
+
+ use IPC::System::Simple qw(capture);
+
+and then use the L</capture()> command just like you'd use backticks.
+If there's an error, it will die with a detailed description of what
+went wrong. Better still, you can even use C<capturex()> to run the
+equivalent of backticks, but without the shell:
+
+ use IPC::System::Simple qw(capturex);
+
+ my $result = capturex($command, @args);
+
+If you want more power than the basic interface, including the
+ability to specify which exit values are acceptable, trap errors,
+or process diagnostics, then read on!
+
+=head1 ADVANCED SYNOPSIS
+
+ use IPC::System::Simple qw(
+ capture capturex system systemx run runx $EXITVAL EXIT_ANY
+ );
+
+ # Run a command, throwing exception on failure
+
+ run("some_command");
+
+ runx("some_command",@args); # Run a command, avoiding the shell
+
+ # Do the same thing, but with the drop-in system replacement.
+
+ system("some_command");
+
+ systemx("some_command", @args);
+
+ # Run a command which must return 0..5, avoid the shell, and get the
+ # exit value (we could also look at $EXITVAL)
+
+ my $exit_value = runx([0..5], "some_command", @args);
+
+ # The same, but any exit value will do.
+
+ my $exit_value = runx(EXIT_ANY, "some_command", @args);
+
+ # Capture output into $result and throw exception on failure
+
+ my $result = capture("some_command");
+
+ # Check exit value from captured command
+
+ print "some_command exited with status $EXITVAL\n";
+
+ # Captures into @lines, splitting on $/
+ my @lines = capture("some_command");
+
+ # Run a command which must return 0..5, capture the output into
+ # @lines, and avoid the shell.
+
+ my @lines = capturex([0..5], "some_command", @args);
+
+=head1 ADVANCED USAGE
+
+=head2 run() and system()
+
+C<IPC::System::Simple> provides a subroutine called
+C<run>, that executes a command using the same semantics is
+Perl's built-in C<system>:
+
+ use IPC::System::Simple qw(run);
+
+ run("cat *.txt"); # Execute command via the shell
+ run("cat","/etc/motd"); # Execute command without shell
+
+The primary difference between Perl's in-built system and
+the C<run> command is that C<run> will throw an exception on
+failure, and allows a list of acceptable exit values to be set.
+See L</Exit values> for further information.
+
+In fact, you can even have C<IPC::System::Simple> replace the
+default C<system> function for your package so it has the
+same behaviour:
+
+ use IPC::System::Simple qw(system);
+
+ system("cat *.txt"); # system now suceeds or dies!
+
+C<system> and C<run> are aliases to each other.
+
+See also L</runx(), systemx() and capturex()> for variants of
+C<system()> and C<run()> that never invoke the shell, even with
+a single argument.
+
+=head2 capture()
+
+A second subroutine, named C<capture> executes a command with
+the same semantics as Perl's built-in backticks (and C<qx()>):
+
+ use IPC::System::Simple qw(capture);
+
+ # Capture text while invoking the shell.
+ my $file = capture("cat /etc/motd");
+ my @lines = capture("cat /etc/passwd");
+
+However unlike regular backticks, which always use the shell, C<capture>
+will bypass the shell when called with multiple arguments:
+
+ # Capture text while avoiding the shell.
+ my $file = capture("cat", "/etc/motd");
+ my @lines = capture("cat", "/etc/passwd");
+
+See also L</runx(), systemx() and capturex()> for a variant of
+C<capture()> that never invokes the shell, even with a single
+argument.
+
+=head2 runx(), systemx() and capturex()
+
+The C<runx()>, C<systemx()> and C<capturex()> commands are identical
+to the multi-argument forms of C<run()>, C<system()> and C<capture()>
+respectively, but I<never> invoke the shell, even when called with a
+single argument. These forms are particularly useful when a command's
+argument list I<might> be empty, for example:
+
+ systemx($cmd, @args);
+
+The use of C<systemx()> here guarantees that the shell will I<never>
+be invoked, even if C<@args> is empty.
+
+=head2 Exception handling
+
+In the case where the command returns an unexpected status, both C<run> and
+C<capture> will throw an exception, which if not caught will terminate your
+program with an error.
+
+Capturing the exception is easy:
+
+ eval {
+ run("cat *.txt");
+ };
+
+ if ($@) {
+ print "Something went wrong - $@\n";
+ }
+
+See the diagnostics section below for more details.
+
+=head3 Exception cases
+
+C<IPC::System::Simple> considers the following to be unexpected,
+and worthy of exception:
+
+=over 4
+
+=item *
+
+Failing to start entirely (eg, command not found, permission denied).
+
+=item *
+
+Returning an exit value other than zero (but see below).
+
+=item *
+
+Being killed by a signal.
+
+=item *
+
+Being passed tainted data (in taint mode).
+
+=back
+
+=head2 Exit values
+
+Traditionally, system commands return a zero status for success and a
+non-zero status for failure. C<IPC::System::Simple> will default to throwing
+an exception if a non-zero exit value is returned.
+
+You may specify a range of values which are considered acceptable exit
+values by passing an I<array reference> as the first argument. The
+special constant C<EXIT_ANY> can be used to allow I<any> exit value
+to be returned.
+
+ use IPC::System::Simple qw(run system capture EXIT_ANY);
+
+ run( [0..5], "cat *.txt"); # Exit values 0-5 are OK
+
+ system( [0..5], "cat *.txt"); # This works the same way
+
+ my @lines = capture( EXIT_ANY, "cat *.txt"); # Any exit is fine.
+
+The C<run> and replacement C<system> subroutines returns the exit
+value of the process:
+
+ my $exit_value = run( [0..5], "cat *.txt");
+
+ # OR:
+
+ my $exit_value = system( [0..5] "cat *.txt");
+
+ print "Program exited with value $exit_value\n";
+
+=head3 $EXITVAL
+
+The exit value of any command exeucted by C<IPC::System::Simple>
+can always be retrieved from the C<$IPC::System::Simple::EXITVAL>
+variable:
+
+This is particularly useful when inspecting results from C<capture>,
+which returns the captured text from the command.
+
+ use IPC::System::Simple qw(capture $EXITVAL EXIT_ANY);
+
+ my @enemies_defeated = capture(EXIT_ANY, "defeat_evil", "/dev/mordor");
+
+ print "Program exited with value $EXITVAL\n";
+
+C<$EXITVAL> will be set to C<-1> if the command did not exit normally (eg,
+being terminated by a signal) or did not start. In this situation an
+exception will also be thrown.
+
+=head2 WINDOWS-SPECIFIC NOTES
+
+As of C<IPC::System::Simple> v0.06, the C<run> subroutine I<when
+called with multiple arguments> will make available the full 32-bit
+exit value on Win32 systems. This is different from the
+previous versions of C<IPC::System::Simple> and from Perl's
+in-build C<system()> function, which can only handle 8-bit return values.
+
+The C<capture> subroutine always returns the 32-bit exit value under
+Windows. The C<capture> subroutine also never uses the shell,
+even when passed a single argument.
+
+Versions of C<IPC::System::Simple> before v0.09 would not search
+the C<PATH> environment variable when the multi-argument form of
+C<run()> was called. Versions from v0.09 onwards correctly search
+the path provided the command is provided including the extension
+(eg, C<notepad.exe> rather than just C<notepad>, or C<gvim.bat> rather
+than just C<gvim>). If no extension is provided, C<.exe> is
+assumed.
+
+Signals are not supported on Windows systems. Sending a signal
+to a Windows process will usually cause it to exit with the signal
+number used.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item "%s" failed to start: "%s"
+
+The command specified did not even start. It may not exist, or
+you may not have permission to use it. The reason it could not
+start (as determined from C<$!>) will be provided.
+
+=item "%s" unexpectedly returned exit value %d
+
+The command ran successfully, but returned an exit value we did
+not expect. The value returned is reported.
+
+=item "%s" died to signal "%s" (%d) %s
+
+The command was killed by a signal. The name of the signal
+will be reported, or C<UNKNOWN> if it cannot be determined. The
+signal number is always reported. If we detected that the
+process dumped core, then the string C<and dumped core> is
+appeneded.
+
+=item IPC::System::Simple::%s called with no arguments
+
+You attempted to call C<run> or C<capture> but did not provide any
+arguments at all. At the very lease you need to supply a command
+to run.
+
+=item IPC::System::Simple::%s called with no command
+
+You called C<run> or C<capture> with a list of acceptable exit values,
+but no actual command.
+
+=item IPC::System::Simple::%s called with tainted argument "%s"
+
+You called C<run> or C<capture> with tainted (untrusted) arguments, which is
+almost certainly a bad idea. To untaint your arguments you'll need to pass
+your data through a regular expression and use the resulting match variables.
+See L<perlsec/Laundering and Detecting Tainted Data> for more information.
+
+=item IPC::System::Simple::%s called with tainted environment $ENV{%s}
+
+You called C<run> or C<capture> but part of your environment was tainted
+(untrusted). You should either delete the named environment
+variable before calling C<run>, or set it to an untainted value
+(usually one set inside your program). See
+L<perlsec/Cleaning Up Your Path> for more information.
+
+=item Error in IPC::System::Simple plumbing: "%s" - "%s"
+
+Implementing the C<capture> command involves dark and terrible magicks
+involving pipes, and one of them has sprung a leak. This could be due to a
+lack of file descriptors, although there are other possibilities.
+
+If you are able to reproduce this error, you are encouraged
+to submit a bug report according to the L</Reporting bugs> section below.
+
+=item Internal error in IPC::System::Simple: "%s"
+
+You've found a bug in C<IPC::System::Simple>. Please check to
+see if an updated version of C<IPC::System::Simple> is available.
+If not, please file a bug report according to the L</Reporting bugs> section
+below.
+
+=item IPC::System::Simple::%s called with undefined command
+
+You've passed the undefined value as a command to be executed.
+While this is a very Zen-like action, it's not supported by
+Perl's current implementation.
+
+=back
+
+=head1 DEPENDENCIES
+
+This module depends upon L<Win32::Process> when used on Win32
+system. C<Win32::Process> is bundled as a core module in ActivePerl 5.6
+and above.
+
+There are no non-core dependencies on non-Win32 systems.
+
+=head1 COMPARISON TO OTHER APIs
+
+Perl provides a range of in-built functions for handling external
+commands, and CPAN provides even more. The C<IPC::System::Simple>
+differentiates itself from other options by providing:
+
+=over 4
+
+=item Extremely detailed diagnostics
+
+The diagnostics produced by C<IPC::System::Simple> are designed
+to provide as much information as possible. Rather than requiring
+the developer to inspect C<$?>, C<IPC::System::Simple> does the
+hard work for you.
+
+If an odd exit status is provided, you're informed of what it is. If
+a signal kills your process, you are informed of both its name and
+number. If tainted data or environment prevents your command from
+running, you are informed of exactly which datais
+
+=item Exceptions on failure
+
+C<IPC::System::Simple> takes an agressive approach to error handling.
+Rather than allow commands to fail silently, exceptions are thrown
+when unexpected results are seen. This allows for easy development
+using a try/catch style, and avoids the possibility of accidently
+continuing after a failed command.
+
+=item Easy access to exit status
+
+The C<run>, C<system> and C<capture> commands all set C<$EXITVAL>,
+making it easy to determine the exit status of a command.
+Additionally, the C<system> and C<run> interfaces return the exit
+status.
+
+=item Consistent interfaces
+
+When called with multiple arguments, the C<run>, C<system> and
+C<capture> interfaces I<never> invoke the shell. This differs
+from the in-built Perl C<system> command which may invoke the
+shell under Windows when called with multiple arguments. It
+differs from the in-built Perl backticks operator which always
+invokes the shell.
+
+=back
+
+=head1 BUGS
+
+When C<system> is exported, the exotic form C<system { $cmd } @args>
+is not supported. Attemping to use the exotic form is a syntax
+error. This affects the calling package I<only>. Use C<CORE::system>
+if you need it, or consider using the L<autodie> module to replace
+C<system> with lexical scope.
+
+Core dumps are only checked for when a process dies due to a
+signal. It is not believed thare exist any systems where processes
+can dump core without dying to a signal.
+
+C<WIFSTOPPED> status is not checked, as perl never spawns processes
+with the C<WUNTRACED> option.
+
+Signals are not supported under Win32 systems, since they don't
+work at all like Unix signals. Win32 singals cause commands to
+exit with a given exit value, which this modules I<does> capture.
+
+Only 8-bit values are returned when C<run()> or C<system()>
+is called with a single value under Win32. Multi-argument calls
+to C<run()> and C<system()>, as well as the C<runx()> and
+C<systemx()> always return the 32-bit Windows return values.
+
+=head2 Reporting bugs
+
+Before reporting a bug, please check to ensure you are using the
+most recent version of C<IPC::System::Simple>. Your problem may
+have already been fixed in a new release.
+
+You can find the C<IPC::System::Simple> bug-tracker at
+L<http://rt.cpan.org/Public/Dist/Display.html?Name=IPC-System-Simple> .
+Please check to see if your bug has already been reported; if
+in doubt, report yours anyway.
+
+Submitting a patch and/or failing test case will greatly expediate
+the fixing of bugs.
+
+=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=IPC-System-Simple> .
+
+The module author loves to hear how C<IPC::System::Simple> has made
+your life better (or worse). Feedback can be sent to
+E<lt>pjf@perltraining.com.auE<gt>.
+
+=head1 SEE ALSO
+
+L<autodie> uses C<IPC::System::Simple> to provide succeed-or-die
+replacements to C<system> (and other built-ins) with lexical scope.
+
+L<POSIX>, L<IPC::Run::Simple>, L<perlipc>, L<perlport>, L<IPC::Run>,
+L<IPC::Run3>, L<Win32::Process>
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006-2008 by Paul Fenwick
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/JSON.pm b/Master/tlpkg/tlperl.straw/lib/JSON.pm
new file mode 100755
index 00000000000..ba24fff7fbc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON.pm
@@ -0,0 +1,2088 @@
+package JSON;
+
+
+use strict;
+use Carp ();
+use base qw(Exporter);
+@JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);
+
+BEGIN {
+ $JSON::VERSION = '2.17';
+ $JSON::DEBUG = 0 unless (defined $JSON::DEBUG);
+}
+
+my $Module_XS = 'JSON::XS';
+my $Module_PP = 'JSON::PP';
+my $XS_Version = '2.27';
+
+
+# XS and PP common methods
+
+my @PublicMethods = qw/
+ ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
+ allow_blessed convert_blessed filter_json_object filter_json_single_key_object
+ shrink max_depth max_size encode decode decode_prefix allow_unknown
+/;
+
+my @Properties = qw/
+ ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref
+ allow_blessed convert_blessed shrink max_depth max_size allow_unknown
+/;
+
+my @XSOnlyMethods = qw//; # Currently nothing
+
+my @PPOnlyMethods = qw/
+ indent_length sort_by
+ allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed
+/; # JSON::PP specific
+
+
+# used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently)
+my $_INSTALL_DONT_DIE = 1; # When _load_xs fails to load XS, don't die.
+my $_INSTALL_ONLY = 2; # Don't call _set_methods()
+my $_ALLOW_UNSUPPORTED = 0;
+my $_UNIV_CONV_BLESSED = 0;
+
+
+# Check the environment variable to decide worker module.
+
+unless ($JSON::Backend) {
+ $JSON::DEBUG and Carp::carp("Check used worker module...");
+
+ my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1;
+
+ if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) {
+ _load_xs($_INSTALL_DONT_DIE) or _load_pp();
+ }
+ elsif ($backend eq '0' or $backend eq 'JSON::PP') {
+ _load_pp();
+ }
+ elsif ($backend eq '2' or $backend eq 'JSON::XS') {
+ _load_xs();
+ }
+ else {
+ Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
+ }
+}
+
+
+sub import {
+ my $pkg = shift;
+ my @what_to_export;
+ my $no_export;
+
+ for my $tag (@_) {
+ if ($tag eq '-support_by_pp') {
+ if (!$_ALLOW_UNSUPPORTED++) {
+ JSON::Backend::XS
+ ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS);
+ }
+ next;
+ }
+ elsif ($tag eq '-no_export') {
+ $no_export++, next;
+ }
+ elsif ( $tag eq '-convert_blessed_universally' ) {
+ eval q|
+ require B;
+ *UNIVERSAL::TO_JSON = sub {
+ my $b_obj = B::svref_2object( $_[0] );
+ return $b_obj->isa('B::HV') ? { %{ $_[0] } }
+ : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
+ : undef
+ ;
+ }
+ | if ( !$_UNIV_CONV_BLESSED++ );
+ next;
+ }
+ push @what_to_export, $tag;
+ }
+
+ return if ($no_export);
+
+ __PACKAGE__->export_to_level(1, $pkg, @what_to_export);
+}
+
+
+# OBSOLETED
+
+sub jsonToObj {
+ my $alternative = 'from_json';
+ if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
+ shift @_; $alternative = 'decode';
+ }
+ Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead.";
+ return JSON::from_json(@_);
+};
+
+sub objToJson {
+ my $alternative = 'to_json';
+ if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
+ shift @_; $alternative = 'encode';
+ }
+ Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead.";
+ JSON::to_json(@_);
+};
+
+
+# INTERFACES
+
+sub to_json ($@) {
+ my $json = new JSON;
+
+ if (@_ == 2 and ref $_[1] eq 'HASH') {
+ my $opt = $_[1];
+ for my $method (keys %$opt) {
+ $json->$method( $opt->{$method} );
+ }
+ }
+
+ $json->encode($_[0]);
+}
+
+
+sub from_json ($@) {
+ my $json = new JSON;
+
+ if (@_ == 2 and ref $_[1] eq 'HASH') {
+ my $opt = $_[1];
+ for my $method (keys %$opt) {
+ $json->$method( $opt->{$method} );
+ }
+ }
+
+ return $json->decode( $_[0] );
+}
+
+
+sub true { $JSON::true }
+
+sub false { $JSON::false }
+
+sub null { undef; }
+
+
+sub require_xs_version { $XS_Version; }
+
+sub backend {
+ my $proto = shift;
+ $JSON::Backend;
+}
+
+#*module = *backend;
+
+
+sub is_xs {
+ return $_[0]->module eq $Module_XS;
+}
+
+
+sub is_pp {
+ return $_[0]->module eq $Module_PP;
+}
+
+
+sub pureperl_only_methods { @PPOnlyMethods; }
+
+
+sub property {
+ my ($self, $name, $value) = @_;
+
+ if (@_ == 1) {
+ my %props;
+ for $name (@Properties) {
+ my $method = 'get_' . $name;
+ if ($name eq 'max_size') {
+ my $value = $self->$method();
+ $props{$name} = $value == 1 ? 0 : $value;
+ next;
+ }
+ $props{$name} = $self->$method();
+ }
+ return \%props;
+ }
+ elsif (@_ > 3) {
+ Carp::croak('property() can take only the option within 2 arguments.');
+ }
+ elsif (@_ == 2) {
+ if ( my $method = $self->can('get_' . $name) ) {
+ if ($name eq 'max_size') {
+ my $value = $self->$method();
+ return $value == 1 ? 0 : $value;
+ }
+ $self->$method();
+ }
+ }
+ else {
+ $self->$name($value);
+ }
+
+}
+
+
+
+# INTERNAL
+
+sub _load_xs {
+ my $opt = shift;
+
+ $JSON::DEBUG and Carp::carp "Load $Module_XS.";
+
+ # if called after install module, overload is disable.... why?
+ JSON::Boolean::_overrride_overload($Module_XS);
+ JSON::Boolean::_overrride_overload($Module_PP);
+
+ eval qq|
+ use $Module_XS $XS_Version ();
+ |;
+
+ if ($@) {
+ if (defined $opt and $opt & $_INSTALL_DONT_DIE) {
+ $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)";
+ return 0;
+ }
+ Carp::croak $@;
+ }
+
+ unless (defined $opt and $opt & $_INSTALL_ONLY) {
+ _set_module( $JSON::Backend = $Module_XS );
+ my $data = join("", <DATA>); # this code is from Jcode 2.xx.
+ close(DATA);
+ eval $data;
+ JSON::Backend::XS->init;
+ }
+
+ return 1;
+};
+
+
+sub _load_pp {
+ my $opt = shift;
+
+ $JSON::DEBUG and Carp::carp "Load $Module_PP.";
+
+ # if called after install module, overload is disable.... why?
+ JSON::Boolean::_overrride_overload($Module_XS);
+ JSON::Boolean::_overrride_overload($Module_PP);
+
+ eval qq| require $Module_PP |;
+ if ($@) {
+ Carp::croak $@;
+ }
+
+ unless (defined $opt and $opt & $_INSTALL_ONLY) {
+ _set_module( $JSON::Backend = $Module_PP );
+ JSON::Backend::PP->init;
+ }
+};
+
+
+sub _set_module {
+ my $module = shift;
+
+ local $^W;
+ no strict qw(refs);
+
+ $JSON::true = ${"$module\::true"};
+ $JSON::false = ${"$module\::false"};
+
+ push @JSON::ISA, $module;
+ push @{"$module\::Boolean::ISA"}, qw(JSON::Boolean);
+
+ *{"JSON::is_bool"} = \&{"$module\::is_bool"};
+
+ for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) {
+ *{"JSON::$method"} = sub {
+ Carp::carp("$method is not supported in $module.");
+ $_[0];
+ };
+ }
+
+ return 1;
+}
+
+
+
+#
+# JSON Boolean
+#
+
+package JSON::Boolean;
+
+my %Installed;
+
+sub _overrride_overload {
+ return if ($Installed{ $_[0] }++);
+
+ my $boolean = $_[0] . '::Boolean';
+
+ eval sprintf(q|
+ package %s;
+ use overload (
+ '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' },
+ 'eq' => sub {
+ my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]);
+ if ($op eq 'true' or $op eq 'false') {
+ return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op;
+ }
+ else {
+ return $obj ? 1 == $op : 0 == $op;
+ }
+ },
+ );
+ |, $boolean);
+
+ if ($@) { Carp::croak $@; }
+
+ return 1;
+}
+
+
+#
+# Helper classes for Backend Module (PP)
+#
+
+package JSON::Backend::PP;
+
+sub init {
+ local $^W;
+ no strict qw(refs);
+ *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"};
+ *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"};
+ *{"JSON::PP::is_xs"} = sub { 0 };
+ *{"JSON::PP::is_pp"} = sub { 1 };
+ return 1;
+}
+
+#
+# To save memory, the below lines are read only when XS backend is used.
+#
+
+package JSON;
+
+1;
+__DATA__
+
+
+#
+# Helper classes for Backend Module (XS)
+#
+
+package JSON::Backend::XS;
+
+use constant INDENT_LENGTH_FLAG => 15 << 12;
+
+use constant UNSUPPORTED_ENCODE_FLAG => {
+ ESCAPE_SLASH => 0x00000010,
+ ALLOW_BIGNUM => 0x00000020,
+ AS_NONBLESSED => 0x00000040,
+ EXPANDED => 0x10000000, # for developer's
+};
+
+use constant UNSUPPORTED_DECODE_FLAG => {
+ LOOSE => 0x00000001,
+ ALLOW_BIGNUM => 0x00000002,
+ ALLOW_BAREKEY => 0x00000004,
+ ALLOW_SINGLEQUOTE => 0x00000008,
+ EXPANDED => 0x20000000, # for developer's
+};
+
+
+sub init {
+ local $^W;
+ no strict qw(refs);
+ *{"JSON::decode_json"} = \&{"JSON::XS::decode_json"};
+ *{"JSON::encode_json"} = \&{"JSON::XS::encode_json"};
+ *{"JSON::XS::is_xs"} = sub { 1 };
+ *{"JSON::XS::is_pp"} = sub { 0 };
+ return 1;
+}
+
+
+sub support_by_pp {
+ my ($class, @methods) = @_;
+
+ local $^W;
+ no strict qw(refs);
+
+ push @JSON::Backend::XS::Supportable::ISA, 'JSON';
+
+ my $pkg = 'JSON::Backend::XS::Supportable';
+
+ *{JSON::new} = sub {
+ my $proto = new JSON::XS; $$proto = 0;
+ bless $proto, $pkg;
+ };
+
+
+ for my $method (@methods) {
+ my $flag = uc($method);
+ my $type |= (UNSUPPORTED_ENCODE_FLAG->{$flag} || 0);
+ $type |= (UNSUPPORTED_DECODE_FLAG->{$flag} || 0);
+
+ next unless($type);
+
+ $pkg->_make_unsupported_method($method => $type);
+ }
+
+ push @{"JSON::XS::Boolean::ISA"}, qw(JSON::PP::Boolean);
+ push @{"JSON::PP::Boolean::ISA"}, qw(JSON::Boolean);
+
+ $JSON::DEBUG and Carp::carp("set -support_by_pp mode.");
+
+ return 1;
+}
+
+
+
+
+#
+# Helper classes for XS
+#
+
+package JSON::Backend::XS::Supportable;
+
+{
+ my $JSON_XS_encode_orignal = \&JSON::XS::encode;
+ my $JSON_XS_decode_orignal = \&JSON::XS::decode;
+ my $JSON_XS_incr_parse_orignal = \&JSON::XS::incr_parse;
+
+ local $^W;
+ *JSON::XS::decode = \&JSON::Backend::XS::Supportable::_decode;
+ *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode;
+ *JSON::XS::incr_parse = \&JSON::Backend::XS::Supportable::_incr_parse;
+
+ *{JSON::XS::_original_decode} = $JSON_XS_decode_orignal;
+ *{JSON::XS::_original_encode} = $JSON_XS_encode_orignal;
+ *{JSON::XS::_original_incr_parse} = $JSON_XS_incr_parse_orignal;
+}
+
+$Carp::Internal{'JSON::Backend::XS::Supportable'} = 1;
+
+sub _make_unsupported_method {
+ my ($pkg, $method, $type) = @_;
+
+ local $^W;
+ no strict qw(refs);
+
+ *{"$pkg\::$method"} = sub {
+ local $^W;
+ if (defined $_[1] ? $_[1] : 1) {
+ ${$_[0]} |= $type;
+ }
+ else {
+ ${$_[0]} &= ~$type;
+ }
+ $_[0];
+ };
+
+ *{"$pkg\::get_$method"} = sub {
+ ${$_[0]} & $type ? 1 : '';
+ };
+
+}
+
+
+sub _set_for_pp {
+ require JSON::PP;
+ my $type = shift;
+ my $pp = new JSON::PP;
+ my $prop = $_[0]->property;
+
+ for my $name (keys %$prop) {
+ $pp->$name( $prop->{$name} ? $prop->{$name} : 0 );
+ }
+
+ my $unsupported = $type eq 'encode' ? JSON::Backend::XS::UNSUPPORTED_ENCODE_FLAG
+ : JSON::Backend::XS::UNSUPPORTED_DECODE_FLAG;
+ my $flags = ${$_[0]} || 0;
+
+ for my $name (keys %$unsupported) {
+ next if ($name eq 'EXPANDED'); # for developer's
+ my $enable = ($flags & $unsupported->{$name}) ? 1 : 0;
+ my $method = lc $name;
+ $pp->$method($enable);
+ }
+
+ $pp->indent_length( $_[0]->get_indent_length );
+
+ return $pp;
+}
+
+sub _encode { # using with PP encod
+ if (${$_[0]}) {
+ _set_for_pp('encode' => @_)->encode($_[1]);
+ }
+ else {
+ $_[0]->_original_encode( $_[1] );
+ }
+}
+
+
+sub _decode { # if unsupported-flag is set, use PP
+ if (${$_[0]}) {
+ _set_for_pp('decode' => @_)->decode($_[1]);
+ }
+ else {
+ $_[0]->_original_decode( $_[1] );
+ }
+}
+
+
+sub decode_prefix { # if unsupported-flag is set, use PP
+ _set_for_pp('decode' => @_)->decode_prefix($_[1]);
+}
+
+
+sub _incr_parse {
+ if (${$_[0]}) {
+ _set_for_pp('decode' => @_)->incr_parse($_[1]);
+ }
+ else {
+ $_[0]->_original_incr_parse( $_[1] );
+ }
+}
+
+
+sub get_indent_length {
+ ${$_[0]} << 4 >> 16;
+}
+
+
+sub indent_length {
+ my $length = $_[1];
+
+ if (!defined $length or $length > 15 or $length < 0) {
+ Carp::carp "The acceptable range of indent_length() is 0 to 15.";
+ }
+ else {
+ local $^W;
+ $length <<= 12;
+ ${$_[0]} &= ~ JSON::Backend::XS::INDENT_LENGTH_FLAG;
+ ${$_[0]} |= $length;
+ *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode;
+ }
+
+ $_[0];
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+JSON - JSON (JavaScript Object Notation) encoder/decoder
+
+=head1 SYNOPSIS
+
+ use JSON; # imports encode_json, decode_json, to_json and from_json.
+
+ $json_text = to_json($perl_scalar);
+ $perl_scalar = from_json($json_text);
+
+ # option-acceptable
+ $json_text = to_json($perl_scalar, {ascii => 1});
+ $perl_scalar = from_json($json_text, {utf8 => 1});
+
+ # OOP
+ $json = new JSON;
+
+ $json_text = $json->encode($perl_scalar);
+ $perl_scalar = $json->decode($json_text);
+
+ # pretty-printing
+ $json_text = $json->pretty->encode($perl_scalar);
+
+ # simple interface
+ $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
+ $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
+
+
+ # If you want to use PP only support features, call with '-support_by_pp'
+ # When XS unsupported feature is enable, using PP de/encode.
+
+ use JSON -support_by_pp;
+
+
+=head1 VERSION
+
+ 2.17
+
+This version is compatible with JSON::XS B<2.27> and later.
+
+
+=head1 DESCRIPTION
+
+ ************************** CAUTION ********************************
+ * This is 'JSON module version 2' and there are many differences *
+ * to version 1.xx *
+ * Please check your applications useing old version. *
+ * See to 'INCOMPATIBLE CHANGES TO OLD VERSION' *
+ *******************************************************************
+
+JSON (JavaScript Object Notation) is a simple data format.
+See to L<http://www.json.org/> and C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>).
+
+This module converts Perl data structures to JSON and vice versa using either
+L<JSON::XS> or L<JSON::PP>.
+
+JSON::XS is the fastest and most proper JSON module on CPAN which must be
+compiled and installed in your environment.
+JSON::PP is a pure-Perl module which is bundled in this distribution and
+has a strong compatibility to JSON::XS.
+
+This module try to use JSON::XS by default and fail to it, use JSON::PP instead.
+So its features completely depend on JSON::XS or JSON::PP.
+
+See to L<BACKEND MODULE DECISION>.
+
+To distinguish the module name 'JSON' and the format type JSON,
+the former is quoted by CE<lt>E<gt> (its results vary with your using media),
+and the latter is left just as it is.
+
+Module name : C<JSON>
+
+Format type : JSON
+
+=head2 FEATURES
+
+=over
+
+=item * correct unicode handling
+
+This module (i.e. backend modules) knows how to handle Unicode, documents
+how and when it does so, and even documents what "correct" means.
+
+Even though there are limitations, this feature is available since Perl version 5.6.
+
+JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions
+C<JSON> sholud call JSON::PP as the backend which can be used since Perl 5.005.
+
+With Perl 5.8.x JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem,
+JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available.
+See to L<JSON::PP/UNICODE HANDLING ON PERLS> for more information.
+
+See also to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>
+and L<JSON::XS/ENCODING/CODESET_FLAG_NOTES>.
+
+
+=item * round-trip integrity
+
+When you serialise a perl data structure using only data types supported by JSON,
+the deserialised data structure is identical on the Perl level.
+(e.g. the string "2.0" doesn't suddenly become "2" just because it looks
+like a number). There minor I<are> exceptions to this, read the MAPPING
+section below to learn about those.
+
+=item * strict checking of JSON correctness
+
+There is no guessing, no generating of illegal JSON texts by default,
+and only JSON is accepted as input by default (the latter is a security
+feature).
+
+See to L<JSON::XS/FEATURES> and L<JSON::PP/FEATURES>.
+
+=item * fast
+
+This module returns a JSON::XS object itself if avaliable.
+Compared to other JSON modules and other serialisers such as Storable,
+JSON::XS usually compares favourably in terms of speed, too.
+
+If not avaliable, C<JSON> returns a JSON::PP object instead of JSON::XS and
+it is very slow as pure-Perl.
+
+=item * simple to use
+
+This module has both a simple functional interface as well as an
+object oriented interface interface.
+
+=item * reasonably versatile output formats
+
+You can choose between the most compact guaranteed-single-line format possible
+(nice for simple line-based protocols), a pure-ASCII format (for when your transport
+is not 8-bit clean, still supports the whole Unicode range), or a pretty-printed
+format (for when you want to read that stuff). Or you can combine those features
+in whatever way you like.
+
+=back
+
+=head1 FUNCTIONAL INTERFACE
+
+Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
+C<to_json> and C<from_json> are additional functions.
+
+=head2 to_json
+
+ $json_text = to_json($perl_scalar)
+
+Converts the given Perl data structure to a json string.
+
+This function call is functionally identical to:
+
+ $json_text = JSON->new->encode($perl_scalar)
+
+Takes a hash reference as the second.
+
+ $json_text = to_json($perl_scalar, $flag_hashref)
+
+So,
+
+ $json_text = encode_json($perl_scalar, {utf8 => 1, pretty => 1})
+
+equivalent to:
+
+ $json_text = JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
+
+
+=head2 from_json
+
+ $perl_scalar = from_json($json_text)
+
+The opposite of C<to_json>: expects a json string and tries
+to parse it, returning the resulting reference.
+
+This function call is functionally identical to:
+
+ $perl_scalar = JSON->decode($json_text)
+
+Takes a hash reference as the second.
+
+ $perl_scalar = from_json($json_text, $flag_hashref)
+
+So,
+
+ $perl_scalar = from_json($json_text, {utf8 => 1})
+
+equivalent to:
+
+ $perl_scalar = JSON->new->utf8(1)->decode($json_text)
+
+=head2 encode_json
+
+ $json_text = encode_json $perl_scalar
+
+Converts the given Perl data structure to a UTF-8 encoded, binary string.
+
+This function call is functionally identical to:
+
+ $json_text = JSON->new->utf8->encode($perl_scalar)
+
+=head2 decode_json
+
+ $perl_scalar = decode_json $json_text
+
+The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
+to parse that as an UTF-8 encoded JSON text, returning the resulting
+reference.
+
+This function call is functionally identical to:
+
+ $perl_scalar = JSON->new->utf8->decode($json_text)
+
+=head2 JSON::is_bool
+
+ $is_boolean = JSON::is_bool($scalar)
+
+Returns true if the passed scalar represents either JSON::true or
+JSON::false, two constants that act like C<1> and C<0> respectively
+and are also used to represent JSON C<true> and C<false> in Perl strings.
+
+=head2 JSON::true
+
+Returns JSON true value which is blessed object.
+It C<isa> JSON::Boolean object.
+
+=head2 JSON::false
+
+Returns JSON false value which is blessed object.
+It C<isa> JSON::Boolean object.
+
+=head2 JSON::null
+
+Returns C<undef>.
+
+See L<MAPPING>, below, for more information on how JSON values are mapped to
+Perl.
+
+=head1 COMMON OBJECT-ORIENTED INTERFACE
+
+
+=head2 new
+
+ $json = new JSON
+
+Returns a new C<JSON> object inherited from either JSON::XS or JSON::PP
+that can be used to de/encode JSON strings.
+
+All boolean flags described below are by default I<disabled>.
+
+The mutators for flags all return the JSON object again and thus calls can
+be chained:
+
+ my $json = JSON->new->utf8->space_after->encode({a => [1,2]})
+ => {"a": [1, 2]}
+
+=head2 ascii
+
+ $json = $json->ascii([$enable])
+
+ $enabled = $json->get_ascii
+
+If $enable is true (or missing), then the encode method will not generate characters outside
+the code range 0..127. Any Unicode characters outside that range will be escaped using either
+a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
+
+If $enable is false, then the encode method will not escape Unicode characters unless
+required by the JSON syntax or other flags. This results in a faster and more compact format.
+
+This feature depends on the used Perl version and environment.
+
+See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
+
+ JSON->new->ascii(1)->encode([chr 0x10401])
+ => ["\ud801\udc01"]
+
+=head2 latin1
+
+ $json = $json->latin1([$enable])
+
+ $enabled = $json->get_latin1
+
+If $enable is true (or missing), then the encode method will encode the resulting JSON
+text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
+
+If $enable is false, then the encode method will not escape Unicode characters
+unless required by the JSON syntax or other flags.
+
+ JSON->new->latin1->encode (["\x{89}\x{abc}"]
+ => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+
+=head2 utf8
+
+ $json = $json->utf8([$enable])
+
+ $enabled = $json->get_utf8
+
+If $enable is true (or missing), then the encode method will encode the JSON result
+into UTF-8, as required by many protocols, while the decode method expects to be handled
+an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
+characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
+
+In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
+encoding families, as described in RFC4627.
+
+If $enable is false, then the encode method will return the JSON string as a (non-encoded)
+Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
+(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
+
+
+Example, output UTF-16BE-encoded JSON:
+
+ use Encode;
+ $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
+
+Example, decode UTF-32LE-encoded JSON:
+
+ use Encode;
+ $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
+
+See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
+
+
+=head2 pretty
+
+ $json = $json->pretty([$enable])
+
+This enables (or disables) all of the C<indent>, C<space_before> and
+C<space_after> (and in the future possibly more) flags in one call to
+generate the most readable (or most compact) form possible.
+
+Equivalent to:
+
+ $json->indent->space_before->space_after
+
+The indent space length is three and JSON::XS cannot change the indent
+space length.
+
+=head2 indent
+
+ $json = $json->indent([$enable])
+
+ $enabled = $json->get_indent
+
+If C<$enable> is true (or missing), then the C<encode> method will use a multiline
+format as output, putting every array member or object/hash key-value pair
+into its own line, identing them properly.
+
+If C<$enable> is false, no newlines or indenting will be produced, and the
+resulting JSON text is guarenteed not to contain any C<newlines>.
+
+This setting has no effect when decoding JSON texts.
+
+The indent space length is three.
+With JSON::PP, you can also access C<indent_length> to change indent space length.
+
+
+=head2 space_before
+
+ $json = $json->space_before([$enable])
+
+ $enabled = $json->get_space_before
+
+If C<$enable> is true (or missing), then the C<encode> method will add an extra
+optional space before the C<:> separating keys from values in JSON objects.
+
+If C<$enable> is false, then the C<encode> method will not add any extra
+space at those places.
+
+This setting has no effect when decoding JSON texts.
+
+Example, space_before enabled, space_after and indent disabled:
+
+ {"key" :"value"}
+
+
+=head2 space_after
+
+ $json = $json->space_after([$enable])
+
+ $enabled = $json->get_space_after
+
+If C<$enable> is true (or missing), then the C<encode> method will add an extra
+optional space after the C<:> separating keys from values in JSON objects
+and extra whitespace after the C<,> separating key-value pairs and array
+members.
+
+If C<$enable> is false, then the C<encode> method will not add any extra
+space at those places.
+
+This setting has no effect when decoding JSON texts.
+
+Example, space_before and indent disabled, space_after enabled:
+
+ {"key": "value"}
+
+
+=head2 relaxed
+
+ $json = $json->relaxed([$enable])
+
+ $enabled = $json->get_relaxed
+
+If C<$enable> is true (or missing), then C<decode> will accept some
+extensions to normal JSON syntax (see below). C<encode> will not be
+affected in anyway. I<Be aware that this option makes you accept invalid
+JSON texts as if they were valid!>. I suggest only to use this option to
+parse application-specific files written by humans (configuration files,
+resource files etc.)
+
+If C<$enable> is false (the default), then C<decode> will only accept
+valid JSON texts.
+
+Currently accepted extensions are:
+
+=over 4
+
+=item * list items can have an end-comma
+
+JSON I<separates> array elements and key-value pairs with commas. This
+can be annoying if you write JSON texts manually and want to be able to
+quickly append elements, so this extension accepts comma at the end of
+such items not just between them:
+
+ [
+ 1,
+ 2, <- this comma not normally allowed
+ ]
+ {
+ "k1": "v1",
+ "k2": "v2", <- this comma not normally allowed
+ }
+
+=item * shell-style '#'-comments
+
+Whenever JSON allows whitespace, shell-style comments are additionally
+allowed. They are terminated by the first carriage-return or line-feed
+character, after which more white-space and comments are allowed.
+
+ [
+ 1, # this comment not allowed in JSON
+ # neither this one...
+ ]
+
+=back
+
+
+=head2 canonical
+
+ $json = $json->canonical([$enable])
+
+ $enabled = $json->get_canonical
+
+If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
+by sorting their keys. This is adding a comparatively high overhead.
+
+If C<$enable> is false, then the C<encode> method will output key-value
+pairs in the order Perl stores them (which will likely change between runs
+of the same script).
+
+This option is useful if you want the same data structure to be encoded as
+the same JSON text (given the same overall settings). If it is disabled,
+the same hash might be encoded differently even if contains the same data,
+as key-value pairs have no inherent ordering in Perl.
+
+This setting has no effect when decoding JSON texts.
+
+=head2 allow_nonref
+
+ $json = $json->allow_nonref([$enable])
+
+ $enabled = $json->get_allow_nonref
+
+If C<$enable> is true (or missing), then the C<encode> method can convert a
+non-reference into its corresponding string, number or null JSON value,
+which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
+values instead of croaking.
+
+If C<$enable> is false, then the C<encode> method will croak if it isn't
+passed an arrayref or hashref, as JSON texts must either be an object
+or array. Likewise, C<decode> will croak if given something that is not a
+JSON object or array.
+
+ JSON->new->allow_nonref->encode ("Hello, World!")
+ => "Hello, World!"
+
+=head2 allow_unknown
+
+ $json = $json->allow_unknown ([$enable])
+
+ $enabled = $json->get_allow_unknown
+
+If $enable is true (or missing), then "encode" will *not* throw an
+exception when it encounters values it cannot represent in JSON (for
+example, filehandles) but instead will encode a JSON "null" value.
+Note that blessed objects are not included here and are handled
+separately by c<allow_nonref>.
+
+If $enable is false (the default), then "encode" will throw an
+exception when it encounters anything it cannot encode as JSON.
+
+This option does not affect "decode" in any way, and it is
+recommended to leave it off unless you know your communications
+partner.
+
+=head2 allow_blessed
+
+ $json = $json->allow_blessed([$enable])
+
+ $enabled = $json->get_allow_blessed
+
+If C<$enable> is true (or missing), then the C<encode> method will not
+barf when it encounters a blessed reference. Instead, the value of the
+B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
+disabled or no C<TO_JSON> method found) or a representation of the
+object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
+encoded. Has no effect on C<decode>.
+
+If C<$enable> is false (the default), then C<encode> will throw an
+exception when it encounters a blessed object.
+
+
+=head2 convert_blessed
+
+ $json = $json->convert_blessed([$enable])
+
+ $enabled = $json->get_convert_blessed
+
+If C<$enable> is true (or missing), then C<encode>, upon encountering a
+blessed object, will check for the availability of the C<TO_JSON> method
+on the object's class. If found, it will be called in scalar context
+and the resulting scalar will be encoded instead of the object. If no
+C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
+to do.
+
+The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
+returns other blessed objects, those will be handled in the same
+way. C<TO_JSON> must take care of not causing an endless recursion cycle
+(== crash) in this case. The name of C<TO_JSON> was chosen because other
+methods called by the Perl core (== not by the user of the object) are
+usually in upper case letters and to avoid collisions with the C<to_json>
+function or method.
+
+This setting does not yet influence C<decode> in any way.
+
+If C<$enable> is false, then the C<allow_blessed> setting will decide what
+to do when a blessed object is found.
+
+=over
+
+=item convert_blessed_universally mode
+
+If use C<JSON> with C<-convert_blessed_universally>, the C<UNIVERSAL::TO_JSON>
+subroutine is defined as the below code:
+
+ *UNIVERSAL::TO_JSON = sub {
+ my $b_obj = B::svref_2object( $_[0] );
+ return $b_obj->isa('B::HV') ? { %{ $_[0] } }
+ : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
+ : undef
+ ;
+ }
+
+This will cause that C<encode> method converts simple blessed objects into
+JSON objects as non-blessed object.
+
+ JSON -convert_blessed_universally;
+ $json->allow_blessed->convert_blessed->encode( $blessed_object )
+
+This feature is experimental and may be removed in the future.
+
+=back
+
+=head2 filter_json_object
+
+ $json = $json->filter_json_object([$coderef])
+
+When C<$coderef> is specified, it will be called from C<decode> each
+time it decodes a JSON object. The only argument passed to the coderef
+is a reference to the newly-created hash. If the code references returns
+a single scalar (which need not be a reference), this value
+(i.e. a copy of that scalar to avoid aliasing) is inserted into the
+deserialised data structure. If it returns an empty list
+(NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
+hash will be inserted. This setting can slow down decoding considerably.
+
+When C<$coderef> is omitted or undefined, any existing callback will
+be removed and C<decode> will not change the deserialised hash in any
+way.
+
+Example, convert all JSON objects into the integer 5:
+
+ my $js = JSON->new->filter_json_object (sub { 5 });
+ # returns [5]
+ $js->decode ('[{}]'); # the given subroutine takes a hash reference.
+ # throw an exception because allow_nonref is not enabled
+ # so a lone 5 is not allowed.
+ $js->decode ('{"a":1, "b":2}');
+
+
+=head2 filter_json_single_key_object
+
+ $json = $json->filter_json_single_key_object($key [=> $coderef])
+
+Works remotely similar to C<filter_json_object>, but is only called for
+JSON objects having a single key named C<$key>.
+
+This C<$coderef> is called before the one specified via
+C<filter_json_object>, if any. It gets passed the single value in the JSON
+object. If it returns a single value, it will be inserted into the data
+structure. If it returns nothing (not even C<undef> but the empty list),
+the callback from C<filter_json_object> will be called next, as if no
+single-key callback were specified.
+
+If C<$coderef> is omitted or undefined, the corresponding callback will be
+disabled. There can only ever be one callback for a given key.
+
+As this callback gets called less often then the C<filter_json_object>
+one, decoding speed will not usually suffer as much. Therefore, single-key
+objects make excellent targets to serialise Perl objects into, especially
+as single-key JSON objects are as close to the type-tagged value concept
+as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
+support this in any way, so you need to make sure your data never looks
+like a serialised Perl hash.
+
+Typical names for the single object key are C<__class_whatever__>, or
+C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
+things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
+with real hashes.
+
+Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
+into the corresponding C<< $WIDGET{<id>} >> object:
+
+ # return whatever is in $WIDGET{5}:
+ JSON
+ ->new
+ ->filter_json_single_key_object (__widget__ => sub {
+ $WIDGET{ $_[0] }
+ })
+ ->decode ('{"__widget__": 5')
+
+ # this can be used with a TO_JSON method in some "widget" class
+ # for serialisation to json:
+ sub WidgetBase::TO_JSON {
+ my ($self) = @_;
+
+ unless ($self->{id}) {
+ $self->{id} = ..get..some..id..;
+ $WIDGET{$self->{id}} = $self;
+ }
+
+ { __widget__ => $self->{id} }
+ }
+
+
+=head2 shrink
+
+ $json = $json->shrink([$enable])
+
+ $enabled = $json->get_shrink
+
+With JSON::XS, this flag resizes strings generated by either
+C<encode> or C<decode> to their minimum size possible. This can save
+memory when your JSON texts are either very very long or you have many
+short strings. It will also try to downgrade any strings to octet-form
+if possible: perl stores strings internally either in an encoding called
+UTF-X or in octet-form. The latter cannot store everything but uses less
+space in general (and some buggy Perl or C code might even rely on that
+internal representation being used).
+
+With JSON::PP, it is noop about resizing strings but tries
+C<utf8::downgrade> to the returned string by C<encode>. See to L<utf8>.
+
+See to L<JSON::XS/OBJECT-ORIENTED INTERFACE> and L<JSON::PP/METHODS>.
+
+=head2 max_depth
+
+ $json = $json->max_depth([$maximum_nesting_depth])
+
+ $max_depth = $json->get_max_depth
+
+Sets the maximum nesting level (default C<512>) accepted while encoding
+or decoding. If a higher nesting level is detected in JSON text or a Perl
+data structure, then the encoder and decoder will stop and croak at that
+point.
+
+Nesting level is defined by number of hash- or arrayrefs that the encoder
+needs to traverse to reach a given point or the number of C<{> or C<[>
+characters without their matching closing parenthesis crossed to reach a
+given character in a string.
+
+If no argument is given, the highest possible setting will be used, which
+is rarely useful.
+
+Note that nesting is implemented by recursion in C. The default value has
+been chosen to be as large as typical operating systems allow without
+crashing. (JSON::XS)
+
+With JSON::PP as the backend, when a large value (100 or more) was set and
+it de/encodes a deep nested object/text, it may raise a warning
+'Deep recursion on subroutin' at the perl runtime phase.
+
+See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
+
+=head2 max_size
+
+ $json = $json->max_size([$maximum_string_size])
+
+ $max_size = $json->get_max_size
+
+Set the maximum length a JSON text may have (in bytes) where decoding is
+being attempted. The default is C<0>, meaning no limit. When C<decode>
+is called on a string that is longer then this many bytes, it will not
+attempt to decode the string but throw an exception. This setting has no
+effect on C<encode> (yet).
+
+If no argument is given, the limit check will be deactivated (same as when
+C<0> is specified).
+
+See L<JSON::XS/SECURITY CONSIDERATIONS>, below, for more info on why this is useful.
+
+=head2 encode
+
+ $json_text = $json->encode($perl_scalar)
+
+Converts the given Perl data structure (a simple scalar or a reference
+to a hash or array) to its JSON representation. Simple scalars will be
+converted into JSON string or number sequences, while references to arrays
+become JSON arrays and references to hashes become JSON objects. Undefined
+Perl values (e.g. C<undef>) become JSON C<null> values.
+References to the integers C<0> and C<1> are converted into C<true> and C<false>.
+
+=head2 decode
+
+ $perl_scalar = $json->decode($json_text)
+
+The opposite of C<encode>: expects a JSON text and tries to parse it,
+returning the resulting simple scalar or reference. Croaks on error.
+
+JSON numbers and strings become simple Perl scalars. JSON arrays become
+Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
+C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
+C<null> becomes C<undef>.
+
+=head2 decode_prefix
+
+ ($perl_scalar, $characters) = $json->decode_prefix($json_text)
+
+This works like the C<decode> method, but instead of raising an exception
+when there is trailing garbage after the first JSON object, it will
+silently stop parsing there and return the number of characters consumed
+so far.
+
+ JSON->new->decode_prefix ("[1] the tail")
+ => ([], 3)
+
+See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
+
+=head2 property
+
+ $boolean = $json->property($property_name)
+
+Returns a boolean value about above some properties.
+
+The available properties are C<ascii>, C<latin1>, C<utf8>,
+C<indent>,C<space_before>, C<space_after>, C<relaxed>, C<canonical>,
+C<allow_nonref>, C<allow_unknown>, C<allow_blessed>, C<convert_blessed>,
+C<shrink>, C<max_depth> and C<max_size>.
+
+ $boolean = $json->property('utf8');
+ => 0
+ $json->utf8;
+ $boolean = $json->property('utf8');
+ => 1
+
+Sets the propery with a given boolean value.
+
+ $json = $json->property($property_name => $boolean);
+
+With no argumnt, it returns all the above properties as a hash reference.
+
+ $flag_hashref = $json->property();
+
+=head1 INCREMENTAL PARSING
+
+In JSON::XS 2.2, incremental parsing feature of JSON texts was implemented.
+Please check to L<JSON::XS/INCREMENTAL PARSING>.
+
+=over 4
+
+=item [void, scalar or list context] = $json->incr_parse ([$string])
+
+This is the central parsing function. It can both append new text and
+extract objects from the stream accumulated so far (both of these
+functions are optional).
+
+If C<$string> is given, then this string is appended to the already
+existing JSON fragment stored in the C<$json> object.
+
+After that, if the function is called in void context, it will simply
+return without doing anything further. This can be used to add more text
+in as many chunks as you want.
+
+If the method is called in scalar context, then it will try to extract
+exactly I<one> JSON object. If that is successful, it will return this
+object, otherwise it will return C<undef>. If there is a parse error,
+this method will croak just as C<decode> would do (one can then use
+C<incr_skip> to skip the errornous part). This is the most common way of
+using the method.
+
+And finally, in list context, it will try to extract as many objects
+from the stream as it can find and return them, or the empty list
+otherwise. For this to work, there must be no separators between the JSON
+objects or arrays, instead they must be concatenated back-to-back. If
+an error occurs, an exception will be raised as in the scalar context
+case. Note that in this case, any previously-parsed JSON texts will be
+lost.
+
+=item $lvalue_string = $json->incr_text
+
+This method returns the currently stored JSON fragment as an lvalue, that
+is, you can manipulate it. This I<only> works when a preceding call to
+C<incr_parse> in I<scalar context> successfully returned an object. Under
+all other circumstances you must not call this function (I mean it.
+although in simple tests it might actually work, it I<will> fail under
+real world conditions). As a special exception, you can also call this
+method before having parsed anything.
+
+This function is useful in two cases: a) finding the trailing text after a
+JSON object or b) parsing multiple JSON objects separated by non-JSON text
+(such as commas).
+
+In Perl 5.005, C<lvalue> attribute is not available.
+You must write codes like the below:
+
+ $string = $json->incr_text;
+ $string =~ s/\s*,\s*//;
+ $json->incr_text( $string );
+
+=item $json->incr_skip
+
+This will reset the state of the incremental parser and will remove the
+parsed text from the input buffer. This is useful after C<incr_parse>
+died, in which case the input buffer and incremental parser state is left
+unchanged, to skip the text parsed so far and to reset the parse state.
+
+=item $json->incr_reset
+
+This completely resets the incremental parser, that is, after this call,
+it will be as if the parser had never parsed anything.
+
+This is useful if you want ot repeatedly parse JSON objects and want to
+ignore any trailing data, which means you have to reset the parser after
+each successful decode.
+
+=back
+
+=head1 JSON::PP SUPPORT METHODS
+
+The below methods are JSON::PP own methods, so when C<JSON> works
+with JSON::PP (i.e. the created object is a JSON::PP object), available.
+See to L<JSON::PP/JSON::PP OWN METHODS> in detail.
+
+If you use C<JSON> with additonal C<-support_by_pp>, some methods
+are available even with JSON::XS. See to L<USE PP FEATURES EVEN THOUGH XS BACKEND>.
+
+ BEING { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' }
+
+ use JSON -support_by_pp;
+
+ my $json = new JSON;
+ $json->allow_nonref->escape_slash->encode("/");
+
+ # functional interfaces too.
+ print to_json(["/"], {escape_slash => 1});
+ print from_json('["foo"]', {utf8 => 1});
+
+If you do not want to all functions but C<-support_by_pp>,
+use C<-no_export>.
+
+ use JSON -support_by_pp, -no_export;
+ # functional interfaces are not exported.
+
+=head2 allow_singlequote
+
+ $json = $json->allow_singlequote([$enable])
+
+If C<$enable> is true (or missing), then C<decode> will accept
+any JSON strings quoted by single quotations that are invalid JSON
+format.
+
+ $json->allow_singlequote->decode({"foo":'bar'});
+ $json->allow_singlequote->decode({'foo':"bar"});
+ $json->allow_singlequote->decode({'foo':'bar'});
+
+As same as the C<relaxed> option, this option may be used to parse
+application-specific files written by humans.
+
+=head2 allow_barekey
+
+ $json = $json->allow_barekey([$enable])
+
+If C<$enable> is true (or missing), then C<decode> will accept
+bare keys of JSON object that are invalid JSON format.
+
+As same as the C<relaxed> option, this option may be used to parse
+application-specific files written by humans.
+
+ $json->allow_barekey->decode('{foo:"bar"}');
+
+=head2 allow_bignum
+
+ $json = $json->allow_bignum([$enable])
+
+If C<$enable> is true (or missing), then C<decode> will convert
+the big integer Perl cannot handle as integer into a L<Math::BigInt>
+object and convert a floating number (any) into a L<Math::BigFloat>.
+
+On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
+objects into JSON numbers with C<allow_blessed> enable.
+
+ $json->allow_nonref->allow_blessed->allow_bignum;
+ $bigfloat = $json->decode('2.000000000000000000000000001');
+ print $json->encode($bigfloat);
+ # => 2.000000000000000000000000001
+
+See to L<MAPPING> aboout the conversion of JSON number.
+
+=head2 loose
+
+ $json = $json->loose([$enable])
+
+The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
+and the module doesn't allow to C<decode> to these (except for \x2f).
+If C<$enable> is true (or missing), then C<decode> will accept these
+unescaped strings.
+
+ $json->loose->decode(qq|["abc
+ def"]|);
+
+See to L<JSON::PP/JSON::PP OWN METHODS>.
+
+=head2 escape_slash
+
+ $json = $json->escape_slash([$enable])
+
+According to JSON Grammar, I<slash> (U+002F) is escaped. But by default
+JSON backend modules encode strings without escaping slash.
+
+If C<$enable> is true (or missing), then C<encode> will escape slashes.
+
+=head2 indent_length
+
+ $json = $json->indent_length($length)
+
+With JSON::XS, The indent space length is 3 and cannot be changed.
+With JSON::PP, it sets the indent space length with the given $length.
+The default is 3. The acceptable range is 0 to 15.
+
+=head2 sort_by
+
+ $json = $json->sort_by($function_name)
+ $json = $json->sort_by($subroutine_ref)
+
+If $function_name or $subroutine_ref are set, its sort routine are used.
+
+ $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
+ # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
+
+ $js = $pc->sort_by('own_sort')->encode($obj);
+ # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
+
+ sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
+
+As the sorting routine runs in the JSON::PP scope, the given
+subroutine name and the special variables C<$a>, C<$b> will begin
+with 'JSON::PP::'.
+
+If $integer is set, then the effect is same as C<canonical> on.
+
+See to L<JSON::PP/JSON::PP OWN METHODS>.
+
+=head1 MAPPING
+
+This section is copied from JSON::XS and modified to C<JSON>.
+JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
+
+See to L<JSON::XS/MAPPING>.
+
+=head2 JSON -> PERL
+
+=over 4
+
+=item object
+
+A JSON object becomes a reference to a hash in Perl. No ordering of object
+keys is preserved (JSON does not preserver object key ordering itself).
+
+=item array
+
+A JSON array becomes a reference to an array in Perl.
+
+=item string
+
+A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
+are represented by the same codepoints in the Perl string, so no manual
+decoding is necessary.
+
+=item number
+
+A JSON number becomes either an integer, numeric (floating point) or
+string scalar in perl, depending on its range and any fractional parts. On
+the Perl level, there is no difference between those as Perl handles all
+the conversion details, but an integer may take slightly less memory and
+might represent more values exactly than floating point numbers.
+
+If the number consists of digits only, C<JSON> will try to represent
+it as an integer value. If that fails, it will try to represent it as
+a numeric (floating point) value if that is possible without loss of
+precision. Otherwise it will preserve the number as a string value (in
+which case you lose roundtripping ability, as the JSON number will be
+re-encoded toa JSON string).
+
+Numbers containing a fractional or exponential part will always be
+represented as numeric (floating point) values, possibly at a loss of
+precision (in which case you might lose perfect roundtripping ability, but
+the JSON number will still be re-encoded as a JSON number).
+
+If the backend is JSON::PP and C<allow_bignum> is enable, the big integers
+and the numeric can be optionally converted into L<Math::BigInt> and
+L<Math::BigFloat> objects.
+
+=item true, false
+
+These JSON atoms become C<JSON::true> and C<JSON::false>,
+respectively. They are overloaded to act almost exactly like the numbers
+C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
+the C<JSON::is_bool> function.
+
+If C<JSON::true> and C<JSON::false> are used as strings or compared as strings,
+they represent as C<true> and C<false> respectively.
+
+ print JSON::true . "\n";
+ => true
+ print JSON::true + 1;
+ => 1
+
+ ok(JSON::true eq 'true');
+ ok(JSON::true eq '1');
+ ok(JSON::true == 1);
+
+C<JSON> will install these missing overloading features to the backend modules.
+
+
+=item null
+
+A JSON null atom becomes C<undef> in Perl.
+
+C<JSON::null> returns C<unddef>.
+
+=back
+
+
+=head2 PERL -> JSON
+
+The mapping from Perl to JSON is slightly more difficult, as Perl is a
+truly typeless language, so we can only guess which JSON type is meant by
+a Perl value.
+
+=over 4
+
+=item hash references
+
+Perl hash references become JSON objects. As there is no inherent ordering
+in hash keys (or JSON objects), they will usually be encoded in a
+pseudo-random order that can change between runs of the same program but
+stays generally the same within a single run of a program. C<JSON>
+optionally sort the hash keys (determined by the I<canonical> flag), so
+the same datastructure will serialise to the same JSON text (given same
+settings and version of JSON::XS), but this incurs a runtime overhead
+and is only rarely useful, e.g. when you want to compare some JSON text
+against another for equality.
+
+In future, the ordered object feature will be added to JSON::PP using C<tie> mechanism.
+
+
+=item array references
+
+Perl array references become JSON arrays.
+
+=item other references
+
+Other unblessed references are generally not allowed and will cause an
+exception to be thrown, except for references to the integers C<0> and
+C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
+also use C<JSON::false> and C<JSON::true> to improve readability.
+
+ to_json [\0,JSON::true] # yields [false,true]
+
+=item JSON::true, JSON::false, JSON::null
+
+These special values become JSON true and JSON false values,
+respectively. You can also use C<\1> and C<\0> directly if you want.
+
+JSON::null returns C<undef>.
+
+=item blessed objects
+
+Blessed objects are not directly representable in JSON. See the
+C<allow_blessed> and C<convert_blessed> methods on various options on
+how to deal with this: basically, you can choose between throwing an
+exception, encoding the reference as if it weren't blessed, or provide
+your own serialiser method.
+
+With C<convert_blessed_universally> mode, C<encode> converts blessed
+hash references or blessed array references (contains other blessed references)
+into JSON members and arrays.
+
+ use JSON -convert_blessed_universally;
+ JSON->new->allow_blessed->convert_blessed->encode( $blessed_object );
+
+See to L<convert_blessed>.
+
+=item simple scalars
+
+Simple Perl scalars (any scalar that is not a reference) are the most
+difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
+JSON C<null> values, scalars that have last been used in a string context
+before encoding as JSON strings, and anything else as number value:
+
+ # dump as number
+ encode_json [2] # yields [2]
+ encode_json [-3.0e17] # yields [-3e+17]
+ my $value = 5; encode_json [$value] # yields [5]
+
+ # used as string, so dump as string
+ print $value;
+ encode_json [$value] # yields ["5"]
+
+ # undef becomes null
+ encode_json [undef] # yields [null]
+
+You can force the type to be a string by stringifying it:
+
+ my $x = 3.1; # some variable containing a number
+ "$x"; # stringified
+ $x .= ""; # another, more awkward way to stringify
+ print $x; # perl does it for you, too, quite often
+
+You can force the type to be a number by numifying it:
+
+ my $x = "3"; # some variable containing a string
+ $x += 0; # numify it, ensuring it will be dumped as a number
+ $x *= 1; # same thing, the choise is yours.
+
+You can not currently force the type in other, less obscure, ways.
+
+=item Big Number
+
+If the backend is JSON::PP and C<allow_bignum> is enable,
+C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
+objects into JSON numbers.
+
+
+=back
+
+=head1 JSON and ECMAscript
+
+See to L<JSON::XS/JSON and ECMAscript>.
+
+=head1 JSON and YAML
+
+JSON is not a subset of YAML.
+See to L<JSON::XS/JSON and YAML>.
+
+
+=head1 BACKEND MODULE DECISION
+
+When you use C<JSON>, C<JSON> tries to C<use> JSON::XS. If this call failed, it will
+C<uses> JSON::PP. The required JSON::XS version is I<2.2> or later.
+
+The C<JSON> constructor method returns an object inherited from the backend module,
+and JSON::XS object is a blessed scaler reference while JSON::PP is a blessed hash
+reference.
+
+So, your program should not depend on the backend module, especially
+returned objects should not be modified.
+
+ my $json = JSON->new; # XS or PP?
+ $json->{stash} = 'this is xs object'; # this code may raise an error!
+
+To check the backend module, there are some methods - C<backend>, C<is_pp> and C<is_xs>.
+
+ JSON->backend; # 'JSON::XS' or 'JSON::PP'
+
+ JSON->backend->is_pp: # 0 or 1
+
+ JSON->backend->is_xs: # 1 or 0
+
+ $json->is_xs; # 1 or 0
+
+ $json->is_pp; # 0 or 1
+
+
+If you set an enviornment variable C<PERL_JSON_BACKEND>, The calling action will be changed.
+
+=over
+
+=item PERL_JSON_BACKEND = 0 or PERL_JSON_BACKEND = 'JSON::PP'
+
+Always use JSON::PP
+
+=item PERL_JSON_BACKEND == 1 or PERL_JSON_BACKEND = 'JSON::XS,JSON::PP'
+
+(The default) Use compiled JSON::XS if it is properly compiled & installed,
+otherwise use JSON::PP.
+
+=item PERL_JSON_BACKEND == 2 or PERL_JSON_BACKEND = 'JSON::XS'
+
+Always use compiled JSON::XS, die if it isn't properly compiled & installed.
+
+=back
+
+These ideas come from L<DBI::PurePerl> mechanism.
+
+example:
+
+ BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::PP' }
+ use JSON; # always uses JSON::PP
+
+In future, it may be able to specify another module.
+
+=head1 USE PP FEATURES EVEN THOUGH XS BACKEND
+
+Many methods are available with either JSON::XS or JSON::PP and
+when the backend module is JSON::XS, if any JSON::PP specific (i.e. JSON::XS unspported)
+method is called, it will C<warn> and be noop.
+
+But If you C<use> C<JSON> passing the optional string C<-support_by_pp>,
+it makes a part of those unupported methods available.
+This feature is achieved by using JSON::PP in C<de/encode>.
+
+ BEGIN { $ENV{PERL_JSON_BACKEND} = 2 } # with JSON::XS
+ use JSON -support_by_pp;
+ my $json = new JSON;
+ $json->allow_nonref->escape_slash->encode("/");
+
+At this time, the returned object is a C<JSON::Backend::XS::Supportable>
+object (re-blessed XS object), and by checking JSON::XS unsupported flags
+in de/encoding, can support some unsupported methods - C<loose>, C<allow_bignum>,
+C<allow_barekey>, C<allow_singlequote>, C<escape_slash>, C<as_nonblessed>
+and C<indent_length>.
+
+When any unsupported methods are not enable, C<XS de/encode> will be
+used as is. The switch is achieved by changing the symbolic tables.
+
+C<-support_by_pp> is effective only when the backend module is JSON::XS
+and it makes the de/encoding speed down a bit.
+
+See to L<JSON::PP SUPPORT METHODS>.
+
+=head1 INCOMPATIBLE CHANGES TO OLD VERSION
+
+There are big incompatibility between new version (2.00) and old (1.xx).
+If you use old C<JSON> 1.xx in your code, please check it.
+
+See to L<Transition ways from 1.xx to 2.xx.>
+
+=over
+
+=item jsonToObj and objToJson are obsoleted.
+
+Non Perl-style name C<jsonToObj> and C<objToJson> are obsoleted
+(but not yet deleted from the source).
+If you use these functions in your code, please replace them
+with C<from_json> and C<to_json>.
+
+
+=item Global variables are no longer available.
+
+C<JSON> class variables - C<$JSON::AUTOCONVERT>, C<$JSON::BareKey>, etc...
+- are not avaliable any longer.
+Instead, various features can be used through object methods.
+
+
+=item Package JSON::Converter and JSON::Parser are deleted.
+
+Now C<JSON> bundles with JSON::PP which can handle JSON more properly than them.
+
+=item Package JSON::NotString is deleted.
+
+There was C<JSON::NotString> class which represents JSON value C<true>, C<false>, C<null>
+and numbers. It was deleted and replaced by C<JSON::Boolean>.
+
+C<JSON::Boolean> represents C<true> and C<false>.
+
+C<JSON::Boolean> does not represent C<null>.
+
+C<JSON::null> returns C<undef>.
+
+C<JSON> makes L<JSON::XS::Boolean> and L<JSON::PP::Boolean> is-a relation
+to L<JSON::Boolean>.
+
+=item function JSON::Number is obsoleted.
+
+C<JSON::Number> is now needless because JSON::XS and JSON::PP have
+round-trip integrity.
+
+=item JSONRPC modules are deleted.
+
+Perl implementation of JSON-RPC protocol - C<JSONRPC >, C<JSONRPC::Transport::HTTP>
+and C<Apache::JSONRPC > are deleted in this distribution.
+Instead of them, there is L<JSON::RPC> which supports JSON-RPC protocol version 1.1.
+
+=back
+
+=head2 Transition ways from 1.xx to 2.xx.
+
+You should set C<suport_by_pp> mode firstly, because
+it is always successful for the below codes even with JSON::XS.
+
+ use JSON -support_by_pp;
+
+=over
+
+=item Exported jsonToObj (simple)
+
+ from_json($json_text);
+
+=item Exported objToJson (simple)
+
+ to_json($perl_scalar);
+
+=item Exported jsonToObj (advanced)
+
+ $flags = {allow_barekey => 1, allow_singlequote => 1};
+ from_json($json_text, $flags);
+
+equivalent to:
+
+ $JSON::BareKey = 1;
+ $JSON::QuotApos = 1;
+ jsonToObj($json_text);
+
+=item Exported objToJson (advanced)
+
+ $flags = {allow_blessed => 1, allow_barekey => 1};
+ to_json($perl_scalar, $flags);
+
+equivalent to:
+
+ $JSON::BareKey = 1;
+ objToJson($perl_scalar);
+
+=item jsonToObj as object method
+
+ $json->decode($json_text);
+
+=item objToJson as object method
+
+ $json->encode($perl_scalar);
+
+=item new method with parameters
+
+The C<new> method in 2.x takes any parameters no longer.
+You can set parameters instead;
+
+ $json = JSON->new->pretty;
+
+=item $JSON::Pretty, $JSON::Indent, $JSON::Delimiter
+
+If C<indent> is enable, that menas C<$JSON::Pretty> flag set. And
+C<$JSON::Delimiter> was substituted by C<space_before> and C<space_after>.
+In conclusion:
+
+ $json->indent->space_before->space_after;
+
+Equivalent to:
+
+ $json->pretty;
+
+To change indent length, use C<indent_length>.
+
+(Only with JSON::PP, if C<-support_by_pp> is not used.)
+
+ $json->pretty->indent_length(2)->encode($perl_scalar);
+
+=item $JSON::BareKey
+
+(Only with JSON::PP, if C<-support_by_pp> is not used.)
+
+ $json->allow_barekey->decode($json_text)
+
+=item $JSON::ConvBlessed
+
+use C<-convert_blessed_universally>. See to L<convert_blessed>.
+
+=item $JSON::QuotApos
+
+(Only with JSON::PP, if C<-support_by_pp> is not used.)
+
+ $json->allow_singlequote->decode($json_text)
+
+=item $JSON::SingleQuote
+
+Disable. C<JSON> does not make such a invalid JSON string any longer.
+
+=item $JSON::KeySort
+
+ $json->canonical->encode($perl_scalar)
+
+This is the ascii sort.
+
+If you want to use with your own sort routine, check the C<sort_by> method.
+
+(Only with JSON::PP, even if C<-support_by_pp> is used currently.)
+
+ $json->sort_by($sort_routine_ref)->encode($perl_scalar)
+
+ $json->sort_by(sub { $JSON::PP::a <=> $JSON::PP::b })->encode($perl_scalar)
+
+Can't access C<$a> and C<$b> but C<$JSON::PP::a> and C<$JSON::PP::b>.
+
+=item $JSON::SkipInvalid
+
+ $json->allow_unknown
+
+=item $JSON::AUTOCONVERT
+
+Needless. C<JSON> backend modules have the round-trip integrity.
+
+=item $JSON::UTF8
+
+Needless because C<JSON> (JSON::XS/JSON::PP) sets
+the UTF8 flag on properly.
+
+ # With UTF8-flagged strings
+
+ $json->allow_nonref;
+ $str = chr(1000); # UTF8-flagged
+
+ $json_text = $json->utf8(0)->encode($str);
+ utf8::is_utf8($json_text);
+ # true
+ $json_text = $json->utf8(1)->encode($str);
+ utf8::is_utf8($json_text);
+ # false
+
+ $str = '"' . chr(1000) . '"'; # UTF8-flagged
+
+ $perl_scalar = $json->utf8(0)->decode($str);
+ utf8::is_utf8($perl_scalar);
+ # true
+ $perl_scalar = $json->utf8(1)->decode($str);
+ # died because of 'Wide character in subroutine'
+
+See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
+
+=item $JSON::UnMapping
+
+Disable. See to L<MAPPING>.
+
+=item $JSON::SelfConvert
+
+This option was deleted.
+Instead of it, if a givien blessed object has the C<TO_JSON> method,
+C<TO_JSON> will be executed with C<convert_blessed>.
+
+ $json->convert_blessed->encode($bleesed_hashref_or_arrayref)
+ # if need, call allow_blessed
+
+Note that it was C<toJson> in old version, but now not C<toJson> but C<TO_JSON>.
+
+=back
+
+=head1 TODO
+
+=over
+
+=item example programs
+
+=back
+
+=head1 THREADS
+
+No test with JSON::PP. If with JSON::XS, See to L<JSON::XS/THREADS>.
+
+
+=head1 BUGS
+
+Please report bugs relevant to C<JSON> to E<lt>makamaka[at]cpan.orgE<gt>.
+
+
+=head1 SEE ALSO
+
+Most of the document is copied and modified from JSON::XS doc.
+
+L<JSON::XS>, L<JSON::PP>
+
+C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>)
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+JSON::XS was written by Marc Lehmann <schmorp[at]schmorp.de>
+
+The relese of this new version owes to the courtesy of Marc Lehmann.
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2005-2010 by Makamaka Hannyaharamitu
+
+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.straw/lib/JSON/PP.pm b/Master/tlpkg/tlperl.straw/lib/JSON/PP.pm
new file mode 100755
index 00000000000..7d371fbccfc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON/PP.pm
@@ -0,0 +1,2144 @@
+package JSON::PP;
+
+# JSON-2.0
+
+use 5.005;
+use strict;
+use base qw(Exporter);
+use overload;
+
+use Carp ();
+use B ();
+#use Devel::Peek;
+
+$JSON::PP::VERSION = '2.27000';
+
+@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
+
+# instead of hash-access, i tried index-access for speed.
+# but this method is not faster than what i expected. so it will be changed.
+
+use constant P_ASCII => 0;
+use constant P_LATIN1 => 1;
+use constant P_UTF8 => 2;
+use constant P_INDENT => 3;
+use constant P_CANONICAL => 4;
+use constant P_SPACE_BEFORE => 5;
+use constant P_SPACE_AFTER => 6;
+use constant P_ALLOW_NONREF => 7;
+use constant P_SHRINK => 8;
+use constant P_ALLOW_BLESSED => 9;
+use constant P_CONVERT_BLESSED => 10;
+use constant P_RELAXED => 11;
+
+use constant P_LOOSE => 12;
+use constant P_ALLOW_BIGNUM => 13;
+use constant P_ALLOW_BAREKEY => 14;
+use constant P_ALLOW_SINGLEQUOTE => 15;
+use constant P_ESCAPE_SLASH => 16;
+use constant P_AS_NONBLESSED => 17;
+
+use constant P_ALLOW_UNKNOWN => 18;
+
+BEGIN {
+ my @xs_compati_bit_properties = qw(
+ latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
+ allow_blessed convert_blessed relaxed allow_unknown
+ );
+ my @pp_bit_properties = qw(
+ allow_singlequote allow_bignum loose
+ allow_barekey escape_slash as_nonblessed
+ );
+
+ # Perl version check, Unicode handling is enable?
+ # Helper module sets @JSON::PP::_properties.
+
+ my $helper = $] >= 5.008 ? 'JSON::PP58'
+ : $] >= 5.006 ? 'JSON::PP56'
+ : 'JSON::PP5005'
+ ;
+
+ eval qq| require $helper |;
+ if ($@) { Carp::croak $@; }
+
+ for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
+ my $flag_name = 'P_' . uc($name);
+
+ eval qq/
+ sub $name {
+ my \$enable = defined \$_[1] ? \$_[1] : 1;
+
+ if (\$enable) {
+ \$_[0]->{PROPS}->[$flag_name] = 1;
+ }
+ else {
+ \$_[0]->{PROPS}->[$flag_name] = 0;
+ }
+
+ \$_[0];
+ }
+
+ sub get_$name {
+ \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
+ }
+ /;
+ }
+
+}
+
+
+
+# Functions
+
+my %encode_allow_method
+ = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
+ allow_blessed convert_blessed indent indent_length allow_bignum
+ as_nonblessed
+ /;
+my %decode_allow_method
+ = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
+ allow_barekey max_size relaxed/;
+
+
+my $JSON; # cache
+
+sub encode_json ($) { # encode
+ ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
+}
+
+
+sub decode_json { # decode
+ ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
+}
+
+# Obsoleted
+
+sub to_json($) {
+ Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
+}
+
+
+sub from_json($) {
+ Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
+}
+
+
+# Methods
+
+sub new {
+ my $class = shift;
+ my $self = {
+ max_depth => 512,
+ max_size => 0,
+ indent => 0,
+ FLAGS => 0,
+ fallback => sub { encode_error('Invalid value. JSON can only reference.') },
+ indent_length => 3,
+ };
+
+ bless $self, $class;
+}
+
+
+sub encode {
+ return $_[0]->PP_encode_json($_[1]);
+}
+
+
+sub decode {
+ return $_[0]->PP_decode_json($_[1], 0x00000000);
+}
+
+
+sub decode_prefix {
+ return $_[0]->PP_decode_json($_[1], 0x00000001);
+}
+
+
+# accessor
+
+
+# pretty printing
+
+sub pretty {
+ my ($self, $v) = @_;
+ my $enable = defined $v ? $v : 1;
+
+ if ($enable) { # indent_length(3) for JSON::XS compatibility
+ $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
+ }
+ else {
+ $self->indent(0)->space_before(0)->space_after(0);
+ }
+
+ $self;
+}
+
+# etc
+
+sub max_depth {
+ my $max = defined $_[1] ? $_[1] : 0x80000000;
+ $_[0]->{max_depth} = $max;
+ $_[0];
+}
+
+
+sub get_max_depth { $_[0]->{max_depth}; }
+
+
+sub max_size {
+ my $max = defined $_[1] ? $_[1] : 0;
+ $_[0]->{max_size} = $max;
+ $_[0];
+}
+
+
+sub get_max_size { $_[0]->{max_size}; }
+
+
+sub filter_json_object {
+ $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
+ $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
+ $_[0];
+}
+
+sub filter_json_single_key_object {
+ if (@_ > 1) {
+ $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
+ }
+ $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
+ $_[0];
+}
+
+sub indent_length {
+ if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
+ Carp::carp "The acceptable range of indent_length() is 0 to 15.";
+ }
+ else {
+ $_[0]->{indent_length} = $_[1];
+ }
+ $_[0];
+}
+
+sub get_indent_length {
+ $_[0]->{indent_length};
+}
+
+sub sort_by {
+ $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
+ $_[0];
+}
+
+sub allow_bigint {
+ Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
+}
+
+###############################
+
+###
+### Perl => JSON
+###
+
+
+{ # Convert
+
+ my $max_depth;
+ my $indent;
+ my $ascii;
+ my $latin1;
+ my $utf8;
+ my $space_before;
+ my $space_after;
+ my $canonical;
+ my $allow_blessed;
+ my $convert_blessed;
+
+ my $indent_length;
+ my $escape_slash;
+ my $bignum;
+ my $as_nonblessed;
+
+ my $depth;
+ my $indent_count;
+ my $keysort;
+
+
+ sub PP_encode_json {
+ my $self = shift;
+ my $obj = shift;
+
+ $indent_count = 0;
+ $depth = 0;
+
+ my $idx = $self->{PROPS};
+
+ ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
+ $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
+ = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
+ P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
+
+ ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
+
+ $keysort = $canonical ? sub { $a cmp $b } : undef;
+
+ if ($self->{sort_by}) {
+ $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
+ : $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
+ : sub { $a cmp $b };
+ }
+
+ encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
+ if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
+
+ my $str = $self->object_to_json($obj);
+
+ $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
+
+ unless ($ascii or $latin1 or $utf8) {
+ utf8::upgrade($str);
+ }
+
+ if ($idx->[ P_SHRINK ]) {
+ utf8::downgrade($str, 1);
+ }
+
+ return $str;
+ }
+
+
+ sub object_to_json {
+ my ($self, $obj) = @_;
+ my $type = ref($obj);
+
+ if($type eq 'HASH'){
+ return $self->hash_to_json($obj);
+ }
+ elsif($type eq 'ARRAY'){
+ return $self->array_to_json($obj);
+ }
+ elsif ($type) { # blessed object?
+ if (blessed($obj)) {
+
+ return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
+
+ if ( $convert_blessed and $obj->can('TO_JSON') ) {
+ my $result = $obj->TO_JSON();
+ if ( defined $result and $obj eq $result ) {
+ encode_error( sprintf(
+ "%s::TO_JSON method returned same object as was passed instead of a new one",
+ ref $obj
+ ) );
+ }
+ return $self->object_to_json( $result );
+ }
+
+ return "$obj" if ( $bignum and _is_bignum($obj) );
+ return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
+
+ encode_error( sprintf("encountered object '%s', but neither allow_blessed "
+ . "nor convert_blessed settings are enabled", $obj)
+ ) unless ($allow_blessed);
+
+ return 'null';
+ }
+ else {
+ return $self->value_to_json($obj);
+ }
+ }
+ else{
+ return $self->value_to_json($obj);
+ }
+ }
+
+
+ sub hash_to_json {
+ my ($self, $obj) = @_;
+ my ($k,$v);
+ my %res;
+
+ encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
+ if (++$depth > $max_depth);
+
+ my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
+ my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
+
+ if ( my $tie_class = tied %$obj ) {
+ if ( $tie_class->can('TIEHASH') ) {
+ $tie_class =~ s/=.+$//;
+ tie %res, $tie_class;
+ }
+ }
+
+ # In the old Perl verions, tied hashes in bool context didn't work.
+ # So, we can't use such a way (%res ? a : b)
+ my $has;
+
+ for my $k (keys %$obj) {
+ my $v = $obj->{$k};
+ $res{$k} = $self->object_to_json($v) || $self->value_to_json($v);
+ $has = 1 unless ( $has );
+ }
+
+ --$depth;
+ $self->_down_indent() if ($indent);
+
+ return '{' . ( $has ? $pre : '' ) # indent
+ . ( $has ? join(",$pre", map { utf8::decode($_) if ($] < 5.008); # key for Perl 5.6
+ string_to_json($self, $_) . $del . $res{$_} # key : value
+ } _sort( $self, \%res )
+ ) . $post # indent
+ : ''
+ )
+ . '}';
+ }
+
+
+ sub array_to_json {
+ my ($self, $obj) = @_;
+ my @res;
+
+ encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
+ if (++$depth > $max_depth);
+
+ my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
+
+ if (my $tie_class = tied @$obj) {
+ if ( $tie_class->can('TIEARRAY') ) {
+ $tie_class =~ s/=.+$//;
+ tie @res, $tie_class;
+ }
+ }
+
+ for my $v (@$obj){
+ push @res, $self->object_to_json($v) || $self->value_to_json($v);
+ }
+
+ --$depth;
+ $self->_down_indent() if ($indent);
+
+ return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
+ }
+
+
+ sub value_to_json {
+ my ($self, $value) = @_;
+
+ return 'null' if(!defined $value);
+
+ my $b_obj = B::svref_2object(\$value); # for round trip problem
+ my $flags = $b_obj->FLAGS;
+
+ return $value # as is
+ if ( ( $flags & B::SVf_IOK or $flags & B::SVp_IOK
+ or $flags & B::SVf_NOK or $flags & B::SVp_NOK
+ ) and !($flags & B::SVf_POK )
+ ); # SvTYPE is IV or NV?
+
+ my $type = ref($value);
+
+ if(!$type){
+ return string_to_json($self, $value);
+ }
+ elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
+ return $$value == 1 ? 'true' : 'false';
+ }
+ elsif ($type) {
+ if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
+ return $self->value_to_json("$value");
+ }
+
+ if ($type eq 'SCALAR' and defined $$value) {
+ return $$value eq '1' ? 'true'
+ : $$value eq '0' ? 'false'
+ : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
+ : encode_error("cannot encode reference to scalar");
+ }
+
+ if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
+ return 'null';
+ }
+ else {
+ if ( $type eq 'SCALAR' or $type eq 'REF' ) {
+ encode_error("cannot encode reference to scalar");
+ }
+ else {
+ encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
+ }
+ }
+
+ }
+ else {
+ return $self->{fallback}->($value)
+ if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
+ return 'null';
+ }
+
+ }
+
+
+ my %esc = (
+ "\n" => '\n',
+ "\r" => '\r',
+ "\t" => '\t',
+ "\f" => '\f',
+ "\b" => '\b',
+ "\"" => '\"',
+ "\\" => '\\\\',
+ "\'" => '\\\'',
+ );
+
+
+ sub string_to_json {
+ my ($self, $arg) = @_;
+
+ $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
+ $arg =~ s/\//\\\//g if ($escape_slash);
+ $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
+
+ if ($ascii) {
+ $arg = JSON_PP_encode_ascii($arg);
+ }
+
+ if ($latin1) {
+ $arg = JSON_PP_encode_latin1($arg);
+ }
+
+ if ($utf8) {
+ utf8::encode($arg);
+ }
+
+ return '"' . $arg . '"';
+ }
+
+
+ sub blessed_to_json {
+ my $b_obj = B::svref_2object($_[1]);
+ if ($b_obj->isa('B::HV')) {
+ return $_[0]->hash_to_json($_[1]);
+ }
+ elsif ($b_obj->isa('B::AV')) {
+ return $_[0]->array_to_json($_[1]);
+ }
+ else {
+ return 'null';
+ }
+ }
+
+
+ sub encode_error {
+ my $error = shift;
+ Carp::croak "$error";
+ }
+
+
+ sub _sort {
+ my ($self, $res) = @_;
+ defined $keysort ? (sort $keysort (keys %$res)) : keys %$res;
+ }
+
+
+ sub _up_indent {
+ my $self = shift;
+ my $space = ' ' x $indent_length;
+
+ my ($pre,$post) = ('','');
+
+ $post = "\n" . $space x $indent_count;
+
+ $indent_count++;
+
+ $pre = "\n" . $space x $indent_count;
+
+ return ($pre,$post);
+ }
+
+
+ sub _down_indent { $indent_count--; }
+
+
+ sub PP_encode_box {
+ {
+ depth => $depth,
+ indent_count => $indent_count,
+ };
+ }
+
+} # Convert
+
+
+sub _encode_ascii {
+ join('',
+ map {
+ $_ <= 127 ?
+ chr($_) :
+ $_ <= 65535 ?
+ sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
+ } unpack('U*', $_[0])
+ );
+}
+
+
+sub _encode_latin1 {
+ join('',
+ map {
+ $_ <= 255 ?
+ chr($_) :
+ $_ <= 65535 ?
+ sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
+ } unpack('U*', $_[0])
+ );
+}
+
+
+sub _encode_surrogates { # from perlunicode
+ my $uni = $_[0] - 0x10000;
+ return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
+}
+
+
+sub _is_bignum {
+ $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
+}
+
+
+
+#
+# JSON => Perl
+#
+
+my $max_intsize;
+
+BEGIN {
+ my $checkint = 1111;
+ for my $d (5..30) {
+ $checkint .= 1;
+ my $int = eval qq| $checkint |;
+ if ($int =~ /[eE]/) {
+ $max_intsize = $d - 1;
+ last;
+ }
+ }
+}
+
+{ # PARSE
+
+ my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
+ b => "\x8",
+ t => "\x9",
+ n => "\xA",
+ f => "\xC",
+ r => "\xD",
+ '\\' => '\\',
+ '"' => '"',
+ '/' => '/',
+ );
+
+ my $text; # json data
+ my $at; # offset
+ my $ch; # 1chracter
+ my $len; # text length (changed according to UTF8 or NON UTF8)
+ # INTERNAL
+ my $depth; # nest counter
+ my $encoding; # json text encoding
+ my $is_valid_utf8; # temp variable
+ my $utf8_len; # utf8 byte length
+ # FLAGS
+ my $utf8; # must be utf8
+ my $max_depth; # max nest nubmer of objects and arrays
+ my $max_size;
+ my $relaxed;
+ my $cb_object;
+ my $cb_sk_object;
+
+ my $F_HOOK;
+
+ my $allow_bigint; # using Math::BigInt
+ my $singlequote; # loosely quoting
+ my $loose; #
+ my $allow_barekey; # bareKey
+
+ # $opt flag
+ # 0x00000001 .... decode_prefix
+
+ sub PP_decode_json {
+ my ($self, $opt); # $opt is an effective flag during this decode_json.
+
+ ($self, $text, $opt) = @_;
+
+ ($at, $ch, $depth) = (0, '', 0);
+
+ if (!defined $text or ref $text) {
+ decode_error("malformed text data.");
+ }
+
+ my $idx = $self->{PROPS};
+
+ ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
+ = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
+
+ if ( $utf8 ) {
+ utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
+ }
+ else {
+ utf8::upgrade( $text );
+ }
+
+ $len = length $text;
+
+ ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
+ = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
+
+ if ($max_size > 1) {
+ use bytes;
+ my $bytes = length $text;
+ decode_error(
+ sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
+ , $bytes, $max_size), 1
+ ) if ($bytes > $max_size);
+ }
+
+ # Currently no effect
+ # should use regexp
+ my @octets = unpack('C4', $text);
+ $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
+ : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
+ : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
+ : ( $octets[2] ) ? 'UTF-16LE'
+ : (!$octets[2] ) ? 'UTF-32LE'
+ : 'unknown';
+
+# my $result = value();
+
+ my $eof = !( my ( $result ) = value() ); # $eof for incr_parse
+
+ if ( $eof && ( $opt & 0x00000001 ) ) {
+ return undef;
+ }
+
+ if (!$idx->[ P_ALLOW_NONREF ] and !ref $result) {
+ decode_error(
+ 'JSON text must be an object or array (but found number, string, true, false or null,'
+ . ' use allow_nonref to allow this)', 1);
+ }
+
+ if ($len >= $at) {
+ my $consumed = $at - 1;
+ white();
+ if ($ch) {
+ decode_error("garbage after JSON object") unless ($opt & 0x00000001);
+ return ($result, $consumed);
+ }
+ }
+
+ $result;
+ }
+
+
+ sub next_chr {
+ return $ch = undef if($at >= $len);
+ $ch = substr($text, $at++, 1);
+ }
+
+
+ sub value {
+ white();
+ return if(!defined $ch);
+ return object() if($ch eq '{');
+ return array() if($ch eq '[');
+ return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
+ return number() if($ch =~ /[0-9]/ or $ch eq '-');
+ return word();
+ }
+
+ sub string {
+ my ($i, $s, $t, $u);
+ my $utf16;
+ my $is_utf8;
+
+ ($is_valid_utf8, $utf8_len) = ('', 0);
+
+ $s = ''; # basically UTF8 flag on
+
+ if($ch eq '"' or ($singlequote and $ch eq "'")){
+ my $boundChar = $ch if ($singlequote);
+
+ OUTER: while( defined(next_chr()) ){
+
+ if((!$singlequote and $ch eq '"') or ($singlequote and $ch eq $boundChar)){
+ next_chr();
+
+ if ($utf16) {
+ decode_error("missing low surrogate character in surrogate pair");
+ }
+
+ utf8::decode($s) if($is_utf8);
+
+ return $s;
+ }
+ elsif($ch eq '\\'){
+ next_chr();
+ if(exists $escapes{$ch}){
+ $s .= $escapes{$ch};
+ }
+ elsif($ch eq 'u'){ # UNICODE handling
+ my $u = '';
+
+ for(1..4){
+ $ch = next_chr();
+ last OUTER if($ch !~ /[0-9a-fA-F]/);
+ $u .= $ch;
+ }
+
+ # U+D800 - U+DBFF
+ if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
+ $utf16 = $u;
+ }
+ # U+DC00 - U+DFFF
+ elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
+ unless (defined $utf16) {
+ decode_error("missing high surrogate character in surrogate pair");
+ }
+ $is_utf8 = 1;
+ $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
+ $utf16 = undef;
+ }
+ else {
+ if (defined $utf16) {
+ decode_error("surrogate pair expected");
+ }
+
+ if ( ( my $hex = hex( $u ) ) > 127 ) {
+ $is_utf8 = 1;
+ $s .= JSON_PP_decode_unicode($u) || next;
+ }
+ else {
+ $s .= chr $hex;
+ }
+ }
+
+ }
+ else{
+ unless ($loose) {
+ decode_error('illegal backslash escape sequence in string');
+ }
+ $s .= $ch;
+ }
+ }
+ else{
+
+ if ( ord $ch > 127 ) {
+ if ( $utf8 ) {
+ unless( $ch = is_valid_utf8($ch) ) {
+ $at -= 1;
+ decode_error("malformed UTF-8 character in JSON string");
+ }
+ else {
+ $at += $utf8_len - 1;
+ }
+ }
+ else {
+ utf8::encode( $ch );
+ }
+
+ $is_utf8 = 1;
+ }
+
+ if (!$loose) {
+ if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
+ $at--;
+ decode_error('invalid character encountered while parsing JSON string');
+ }
+ }
+
+ $s .= $ch;
+ }
+ }
+ }
+
+ decode_error("unexpected end of string while parsing JSON string");
+ }
+
+
+ sub white {
+ while( defined $ch ){
+ if($ch le ' '){
+ next_chr();
+ }
+ elsif($ch eq '/'){
+ next_chr();
+ if(defined $ch and $ch eq '/'){
+ 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
+ }
+ elsif(defined $ch and $ch eq '*'){
+ next_chr();
+ while(1){
+ if(defined $ch){
+ if($ch eq '*'){
+ if(defined(next_chr()) and $ch eq '/'){
+ next_chr();
+ last;
+ }
+ }
+ else{
+ next_chr();
+ }
+ }
+ else{
+ decode_error("Unterminated comment");
+ }
+ }
+ next;
+ }
+ else{
+ $at--;
+ decode_error("malformed JSON string, neither array, object, number, string or atom");
+ }
+ }
+ else{
+ if ($relaxed and $ch eq '#') { # correctly?
+ pos($text) = $at;
+ $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
+ $at = pos($text);
+ next_chr;
+ next;
+ }
+
+ last;
+ }
+ }
+ }
+
+
+ sub array {
+ my $a = [];
+
+ decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
+ if (++$depth > $max_depth);
+
+ next_chr();
+ white();
+
+ if(defined $ch and $ch eq ']'){
+ --$depth;
+ next_chr();
+ return $a;
+ }
+ else {
+ while(defined($ch)){
+ push @$a, value();
+
+ white();
+
+ if (!defined $ch) {
+ last;
+ }
+
+ if($ch eq ']'){
+ --$depth;
+ next_chr();
+ return $a;
+ }
+
+ if($ch ne ','){
+ last;
+ }
+
+ next_chr();
+ white();
+
+ if ($relaxed and $ch eq ']') {
+ --$depth;
+ next_chr();
+ return $a;
+ }
+
+ }
+ }
+
+ decode_error(", or ] expected while parsing array");
+ }
+
+
+ sub object {
+ my $o = {};
+ my $k;
+
+ decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
+ if (++$depth > $max_depth);
+ next_chr();
+ white();
+
+ if(defined $ch and $ch eq '}'){
+ --$depth;
+ next_chr();
+ if ($F_HOOK) {
+ return _json_object_hook($o);
+ }
+ return $o;
+ }
+ else {
+ while (defined $ch) {
+ $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
+ white();
+
+ if(!defined $ch or $ch ne ':'){
+ $at--;
+ decode_error("':' expected");
+ }
+
+ next_chr();
+ $o->{$k} = value();
+ white();
+
+ last if (!defined $ch);
+
+ if($ch eq '}'){
+ --$depth;
+ next_chr();
+ if ($F_HOOK) {
+ return _json_object_hook($o);
+ }
+ return $o;
+ }
+
+ if($ch ne ','){
+ last;
+ }
+
+ next_chr();
+ white();
+
+ if ($relaxed and $ch eq '}') {
+ --$depth;
+ next_chr();
+ if ($F_HOOK) {
+ return _json_object_hook($o);
+ }
+ return $o;
+ }
+
+ }
+
+ }
+
+ $at--;
+ decode_error(", or } expected while parsing object/hash");
+ }
+
+
+ sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
+ my $key;
+ while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
+ $key .= $ch;
+ next_chr();
+ }
+ return $key;
+ }
+
+
+ sub word {
+ my $word = substr($text,$at-1,4);
+
+ if($word eq 'true'){
+ $at += 3;
+ next_chr;
+ return $JSON::PP::true;
+ }
+ elsif($word eq 'null'){
+ $at += 3;
+ next_chr;
+ return undef;
+ }
+ elsif($word eq 'fals'){
+ $at += 3;
+ if(substr($text,$at,1) eq 'e'){
+ $at++;
+ next_chr;
+ return $JSON::PP::false;
+ }
+ }
+
+ $at--; # for decode_error report
+
+ decode_error("'null' expected") if ($word =~ /^n/);
+ decode_error("'true' expected") if ($word =~ /^t/);
+ decode_error("'false' expected") if ($word =~ /^f/);
+ decode_error("malformed JSON string, neither array, object, number, string or atom");
+ }
+
+
+ sub number {
+ my $n = '';
+ my $v;
+
+ # According to RFC4627, hex or oct digts are invalid.
+ if($ch eq '0'){
+ my $peek = substr($text,$at,1);
+ my $hex = $peek =~ /[xX]/; # 0 or 1
+
+ if($hex){
+ decode_error("malformed number (leading zero must not be followed by another digit)");
+ ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
+ }
+ else{ # oct
+ ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
+ if (defined $n and length $n > 1) {
+ decode_error("malformed number (leading zero must not be followed by another digit)");
+ }
+ }
+
+ if(defined $n and length($n)){
+ if (!$hex and length($n) == 1) {
+ decode_error("malformed number (leading zero must not be followed by another digit)");
+ }
+ $at += length($n) + $hex;
+ next_chr;
+ return $hex ? hex($n) : oct($n);
+ }
+ }
+
+ if($ch eq '-'){
+ $n = '-';
+ next_chr;
+ if (!defined $ch or $ch !~ /\d/) {
+ decode_error("malformed number (no digits after initial minus)");
+ }
+ }
+
+ while(defined $ch and $ch =~ /\d/){
+ $n .= $ch;
+ next_chr;
+ }
+
+ if(defined $ch and $ch eq '.'){
+ $n .= '.';
+
+ next_chr;
+ if (!defined $ch or $ch !~ /\d/) {
+ decode_error("malformed number (no digits after decimal point)");
+ }
+ else {
+ $n .= $ch;
+ }
+
+ while(defined(next_chr) and $ch =~ /\d/){
+ $n .= $ch;
+ }
+ }
+
+ if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
+ $n .= $ch;
+ next_chr;
+
+ if(defined($ch) and ($ch eq '+' or $ch eq '-')){
+ $n .= $ch;
+ next_chr;
+ if (!defined $ch or $ch =~ /\D/) {
+ decode_error("malformed number (no digits after exp sign)");
+ }
+ $n .= $ch;
+ }
+ elsif(defined($ch) and $ch =~ /\d/){
+ $n .= $ch;
+ }
+ else {
+ decode_error("malformed number (no digits after exp sign)");
+ }
+
+ while(defined(next_chr) and $ch =~ /\d/){
+ $n .= $ch;
+ }
+
+ }
+
+ $v .= $n;
+
+ if ($v !~ /[.eE]/ and length $v > $max_intsize) {
+ if ($allow_bigint) { # from Adam Sussman
+ require Math::BigInt;
+ return Math::BigInt->new($v);
+ }
+ else {
+ return "$v";
+ }
+ }
+ elsif ($allow_bigint) {
+ require Math::BigFloat;
+ return Math::BigFloat->new($v);
+ }
+
+ return 0+$v;
+ }
+
+
+ sub is_valid_utf8 {
+
+ $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
+ : $_[0] =~ /[\xC2-\xDF]/ ? 2
+ : $_[0] =~ /[\xE0-\xEF]/ ? 3
+ : $_[0] =~ /[\xF0-\xF4]/ ? 4
+ : 0
+ ;
+
+ return unless $utf8_len;
+
+ my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
+
+ return ( $is_valid_utf8 =~ /^(?:
+ [\x00-\x7F]
+ |[\xC2-\xDF][\x80-\xBF]
+ |[\xE0][\xA0-\xBF][\x80-\xBF]
+ |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
+ |[\xED][\x80-\x9F][\x80-\xBF]
+ |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
+ |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
+ |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
+ |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
+ )$/x ) ? $is_valid_utf8 : '';
+ }
+
+
+ sub decode_error {
+ my $error = shift;
+ my $no_rep = shift;
+ my $str = defined $text ? substr($text, $at) : '';
+ my $mess = '';
+ my $type = $] >= 5.008 ? 'U*'
+ : $] < 5.006 ? 'C*'
+ : utf8::is_utf8( $str ) ? 'U*' # 5.6
+ : 'C*'
+ ;
+
+ for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
+ $mess .= $c == 0x07 ? '\a'
+ : $c == 0x09 ? '\t'
+ : $c == 0x0a ? '\n'
+ : $c == 0x0d ? '\r'
+ : $c == 0x0c ? '\f'
+ : $c < 0x20 ? sprintf('\x{%x}', $c)
+ : $c < 0x80 ? chr($c)
+ : sprintf('\x{%x}', $c)
+ ;
+ if ( length $mess >= 20 ) {
+ $mess .= '...';
+ last;
+ }
+ }
+
+ unless ( length $mess ) {
+ $mess = '(end of string)';
+ }
+
+ Carp::croak (
+ $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
+ );
+
+ }
+
+
+ sub _json_object_hook {
+ my $o = $_[0];
+ my @ks = keys %{$o};
+
+ if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
+ my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
+ if (@val == 1) {
+ return $val[0];
+ }
+ }
+
+ my @val = $cb_object->($o) if ($cb_object);
+ if (@val == 0 or @val > 1) {
+ return $o;
+ }
+ else {
+ return $val[0];
+ }
+ }
+
+
+ sub PP_decode_box {
+ {
+ text => $text,
+ at => $at,
+ ch => $ch,
+ len => $len,
+ depth => $depth,
+ encoding => $encoding,
+ is_valid_utf8 => $is_valid_utf8,
+ };
+ }
+
+} # PARSE
+
+
+sub _decode_surrogates { # from perlunicode
+ my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
+ my $un = pack('U*', $uni);
+ utf8::encode( $un );
+ return $un;
+}
+
+
+sub _decode_unicode {
+ my $un = pack('U', hex shift);
+ utf8::encode( $un );
+ return $un;
+}
+
+
+
+
+
+###############################
+# Utilities
+#
+
+BEGIN {
+ eval 'require Scalar::Util';
+ unless($@){
+ *JSON::PP::blessed = \&Scalar::Util::blessed;
+ }
+ else{ # This code is from Sclar::Util.
+ # warn $@;
+ eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
+ *JSON::PP::blessed = sub {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
+ };
+ }
+}
+
+
+# shamely copied and modified from JSON::XS code.
+
+$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
+$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
+
+sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
+
+sub true { $JSON::PP::true }
+sub false { $JSON::PP::false }
+sub null { undef; }
+
+###############################
+
+package JSON::PP::Boolean;
+
+
+use overload (
+ "0+" => sub { ${$_[0]} },
+ "++" => sub { $_[0] = ${$_[0]} + 1 },
+ "--" => sub { $_[0] = ${$_[0]} - 1 },
+ fallback => 1,
+);
+
+
+###############################
+
+package JSON::PP::IncrParser;
+
+use strict;
+
+use constant INCR_M_WS => 0; # initial whitespace skipping
+use constant INCR_M_STR => 1; # inside string
+use constant INCR_M_BS => 2; # inside backslash
+use constant INCR_M_JSON => 3; # outside anything, count nesting
+use constant INCR_M_C0 => 4;
+use constant INCR_M_C1 => 5;
+
+$JSON::PP::IncrParser::VERSION = '1.01';
+
+my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
+
+sub new {
+ my ( $class ) = @_;
+
+ bless {
+ incr_nest => 0,
+ incr_text => undef,
+ incr_parsing => 0,
+ incr_p => 0,
+ }, $class;
+}
+
+
+sub incr_parse {
+ my ( $self, $coder, $text ) = @_;
+
+ $self->{incr_text} = '' unless ( defined $self->{incr_text} );
+
+ if ( defined $text ) {
+ if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
+ utf8::upgrade( $self->{incr_text} ) ;
+ utf8::decode( $self->{incr_text} ) ;
+ }
+ $self->{incr_text} .= $text;
+ }
+
+
+ my $max_size = $coder->get_max_size;
+
+ if ( defined wantarray ) {
+
+ $self->{incr_mode} = INCR_M_WS;
+
+ if ( wantarray ) {
+ my @ret;
+
+ $self->{incr_parsing} = 1;
+
+ do {
+ push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
+
+ unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
+ $self->{incr_mode} = INCR_M_WS;
+ }
+
+ } until ( !$self->{incr_text} );
+
+ $self->{incr_parsing} = 0;
+
+ return @ret;
+ }
+ else { # in scalar context
+ $self->{incr_parsing} = 1;
+ my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
+ $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
+ return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
+ }
+
+ }
+
+}
+
+
+sub _incr_parse {
+ my ( $self, $coder, $text, $skip ) = @_;
+ my $p = $self->{incr_p};
+ my $restore = $p;
+
+ my @obj;
+ my $len = length $text;
+
+ if ( $self->{incr_mode} == INCR_M_WS ) {
+ while ( $len > $p ) {
+ my $s = substr( $text, $p, 1 );
+ $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
+ $self->{incr_mode} = INCR_M_JSON;
+ last;
+ }
+ }
+
+ while ( $len > $p ) {
+ my $s = substr( $text, $p++, 1 );
+
+ if ( $s eq '"' ) {
+ if ( $self->{incr_mode} != INCR_M_STR ) {
+ $self->{incr_mode} = INCR_M_STR;
+ }
+ else {
+ $self->{incr_mode} = INCR_M_JSON;
+ unless ( $self->{incr_nest} ) {
+ last;
+ }
+ }
+ }
+
+ if ( $self->{incr_mode} == INCR_M_JSON ) {
+
+ if ( $s eq '[' or $s eq '{' ) {
+ if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
+ Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
+ }
+ }
+ elsif ( $s eq ']' or $s eq '}' ) {
+ last if ( --$self->{incr_nest} <= 0 );
+ }
+ elsif ( $s eq '#' ) {
+ while ( $len > $p ) {
+ last if substr( $text, $p++, 1 ) eq "\n";
+ }
+ }
+
+ }
+
+ }
+
+ $self->{incr_p} = $p;
+
+ return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
+
+ return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
+
+ local $Carp::CarpLevel = 2;
+
+ $self->{incr_p} = $restore;
+ $self->{incr_c} = $p;
+
+ my ( $obj, $tail ) = $coder->decode_prefix( substr( $self->{incr_text}, 0, $p ) );
+
+ $self->{incr_text} = substr( $self->{incr_text}, $p );
+ $self->{incr_p} = 0;
+
+ return $obj or '';
+}
+
+
+sub incr_text {
+ if ( $_[0]->{incr_parsing} ) {
+ Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ }
+ $_[0]->{incr_text};
+}
+
+
+sub incr_skip {
+ my $self = shift;
+ $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
+ $self->{incr_p} = 0;
+}
+
+
+sub incr_reset {
+ my $self = shift;
+ $self->{incr_text} = undef;
+ $self->{incr_p} = 0;
+ $self->{incr_mode} = 0;
+ $self->{incr_nest} = 0;
+ $self->{incr_parsing} = 0;
+}
+
+###############################
+
+
+1;
+__END__
+=pod
+
+=head1 NAME
+
+JSON::PP - JSON::XS compatible pure-Perl module.
+
+=head1 SYNOPSIS
+
+ use JSON::PP;
+
+ # exported functions, they croak on error
+ # and expect/generate UTF-8
+
+ $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
+ $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
+
+ # OO-interface
+
+ $coder = JSON::PP->new->ascii->pretty->allow_nonref;
+ $pretty_printed_unencoded = $coder->encode ($perl_scalar);
+ $perl_scalar = $coder->decode ($unicode_json_text);
+
+ # Note that JSON version 2.0 and above will automatically use
+ # JSON::XS or JSON::PP, so you should be able to just:
+
+ use JSON;
+
+=head1 DESCRIPTION
+
+This module is L<JSON::XS> compatible pure Perl module.
+(Perl 5.8 or later is recommended)
+
+JSON::XS is the fastest and most proper JSON module on CPAN.
+It is written by Marc Lehmann in C, so must be compiled and
+installed in the used environment.
+
+JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
+
+
+=head2 FEATURES
+
+=over
+
+=item * correct unicode handling
+
+This module knows how to handle Unicode (depending on Perl version).
+
+See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
+
+
+=item * round-trip integrity
+
+When you serialise a perl data structure using only datatypes supported by JSON,
+the deserialised data structure is identical on the Perl level.
+(e.g. the string "2.0" doesn't suddenly become "2" just because it looks like a number).
+
+=item * strict checking of JSON correctness
+
+There is no guessing, no generating of illegal JSON texts by default,
+and only JSON is accepted as input by default (the latter is a security feature).
+But when some options are set, loose chcking features are available.
+
+=back
+
+=head1 FUNCTIONS
+
+Basically, check to L<JSON> or L<JSON::XS>.
+
+=head2 encode_json
+
+ $json_text = encode_json $perl_scalar
+
+=head2 decode_json
+
+ $perl_scalar = decode_json $json_text
+
+=head2 JSON::PP::true
+
+Returns JSON true value which is blessed object.
+It C<isa> JSON::PP::Boolean object.
+
+=head2 JSON::PP::false
+
+Returns JSON false value which is blessed object.
+It C<isa> JSON::PP::Boolean object.
+
+=head2 JSON::PP::null
+
+Returns C<undef>.
+
+=head1 METHODS
+
+Basically, check to L<JSON> or L<JSON::XS>.
+
+=head2 new
+
+ $json = new JSON::PP
+
+Rturns a new JSON::PP object that can be used to de/encode JSON
+strings.
+
+=head2 ascii
+
+ $json = $json->ascii([$enable])
+
+ $enabled = $json->get_ascii
+
+If $enable is true (or missing), then the encode method will not generate characters outside
+the code range 0..127. Any Unicode characters outside that range will be escaped using either
+a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
+(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
+
+In Perl 5.005, there is no character having high value (more than 255).
+See to L<UNICODE HANDLING ON PERLS>.
+
+If $enable is false, then the encode method will not escape Unicode characters unless
+required by the JSON syntax or other flags. This results in a faster and more compact format.
+
+ JSON::PP->new->ascii(1)->encode([chr 0x10401])
+ => ["\ud801\udc01"]
+
+=head2 latin1
+
+ $json = $json->latin1([$enable])
+
+ $enabled = $json->get_latin1
+
+If $enable is true (or missing), then the encode method will encode the resulting JSON
+text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
+
+If $enable is false, then the encode method will not escape Unicode characters
+unless required by the JSON syntax or other flags.
+
+ JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
+ => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+
+See to L<UNICODE HANDLING ON PERLS>.
+
+=head2 utf8
+
+ $json = $json->utf8([$enable])
+
+ $enabled = $json->get_utf8
+
+If $enable is true (or missing), then the encode method will encode the JSON result
+into UTF-8, as required by many protocols, while the decode method expects to be handled
+an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
+characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
+
+(In Perl 5.005, any character outside the range 0..255 does not exist.
+See to L<UNICODE HANDLING ON PERLS>.)
+
+In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
+encoding families, as described in RFC4627.
+
+If $enable is false, then the encode method will return the JSON string as a (non-encoded)
+Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
+(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
+
+Example, output UTF-16BE-encoded JSON:
+
+ use Encode;
+ $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
+
+Example, decode UTF-32LE-encoded JSON:
+
+ use Encode;
+ $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
+
+
+=head2 pretty
+
+ $json = $json->pretty([$enable])
+
+This enables (or disables) all of the C<indent>, C<space_before> and
+C<space_after> flags in one call to generate the most readable
+(or most compact) form possible.
+
+=head2 indent
+
+ $json = $json->indent([$enable])
+
+ $enabled = $json->get_indent
+
+The default indent space lenght is three.
+You can use C<indent_length> to change the length.
+
+=head2 space_before
+
+ $json = $json->space_before([$enable])
+
+ $enabled = $json->get_space_before
+
+=head2 space_after
+
+ $json = $json->space_after([$enable])
+
+ $enabled = $json->get_space_after
+
+=head2 relaxed
+
+ $json = $json->relaxed([$enable])
+
+ $enabled = $json->get_relaxed
+
+=head2 canonical
+
+ $json = $json->canonical([$enable])
+
+ $enabled = $json->get_canonical
+
+If you want your own sorting routine, you can give a code referece
+or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
+
+=head2 allow_nonref
+
+ $json = $json->allow_nonref([$enable])
+
+ $enabled = $json->get_allow_nonref
+
+=head2 allow_unknown
+
+ $json = $json->allow_unknown ([$enable])
+
+ $enabled = $json->get_allow_unknown
+
+=head2 allow_blessed
+
+ $json = $json->allow_blessed([$enable])
+
+ $enabled = $json->get_allow_blessed
+
+=head2 convert_blessed
+
+ $json = $json->convert_blessed([$enable])
+
+ $enabled = $json->get_convert_blessed
+
+=head2 filter_json_object
+
+ $json = $json->filter_json_object([$coderef])
+
+=head2 filter_json_single_key_object
+
+ $json = $json->filter_json_single_key_object($key [=> $coderef])
+
+=head2 shrink
+
+ $json = $json->shrink([$enable])
+
+ $enabled = $json->get_shrink
+
+In JSON::XS, this flag resizes strings generated by either
+C<encode> or C<decode> to their minimum size possible.
+It will also try to downgrade any strings to octet-form if possible.
+
+In JSON::PP, it is noop about resizing strings but tries
+C<utf8::downgrade> to the returned string by C<encode>.
+See to L<utf8>.
+
+See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
+
+=head2 max_depth
+
+ $json = $json->max_depth([$maximum_nesting_depth])
+
+ $max_depth = $json->get_max_depth
+
+Sets the maximum nesting level (default C<512>) accepted while encoding
+or decoding. If a higher nesting level is detected in JSON text or a Perl
+data structure, then the encoder and decoder will stop and croak at that
+point.
+
+Nesting level is defined by number of hash- or arrayrefs that the encoder
+needs to traverse to reach a given point or the number of C<{> or C<[>
+characters without their matching closing parenthesis crossed to reach a
+given character in a string.
+
+If no argument is given, the highest possible setting will be used, which
+is rarely useful.
+
+See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
+
+When a large value (100 or more) was set and it de/encodes a deep nested object/text,
+it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
+
+=head2 max_size
+
+ $json = $json->max_size([$maximum_string_size])
+
+ $max_size = $json->get_max_size
+
+Set the maximum length a JSON text may have (in bytes) where decoding is
+being attempted. The default is C<0>, meaning no limit. When C<decode>
+is called on a string that is longer then this many bytes, it will not
+attempt to decode the string but throw an exception. This setting has no
+effect on C<encode> (yet).
+
+If no argument is given, the limit check will be deactivated (same as when
+C<0> is specified).
+
+See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
+
+=head2 encode
+
+ $json_text = $json->encode($perl_scalar)
+
+=head2 decode
+
+ $perl_scalar = $json->decode($json_text)
+
+=head2 decode_prefix
+
+ ($perl_scalar, $characters) = $json->decode_prefix($json_text)
+
+
+
+=head1 INCREMENTAL PARSING
+
+In JSON::XS 2.2, incremental parsing feature of JSON
+texts was experimentally implemented.
+Please check to L<JSON::XS/INCREMENTAL PARSING>.
+
+=over 4
+
+=item [void, scalar or list context] = $json->incr_parse ([$string])
+
+This is the central parsing function. It can both append new text and
+extract objects from the stream accumulated so far (both of these
+functions are optional).
+
+If C<$string> is given, then this string is appended to the already
+existing JSON fragment stored in the C<$json> object.
+
+After that, if the function is called in void context, it will simply
+return without doing anything further. This can be used to add more text
+in as many chunks as you want.
+
+If the method is called in scalar context, then it will try to extract
+exactly I<one> JSON object. If that is successful, it will return this
+object, otherwise it will return C<undef>. If there is a parse error,
+this method will croak just as C<decode> would do (one can then use
+C<incr_skip> to skip the errornous part). This is the most common way of
+using the method.
+
+And finally, in list context, it will try to extract as many objects
+from the stream as it can find and return them, or the empty list
+otherwise. For this to work, there must be no separators between the JSON
+objects or arrays, instead they must be concatenated back-to-back. If
+an error occurs, an exception will be raised as in the scalar context
+case. Note that in this case, any previously-parsed JSON texts will be
+lost.
+
+=item $lvalue_string = $json->incr_text
+
+This method returns the currently stored JSON fragment as an lvalue, that
+is, you can manipulate it. This I<only> works when a preceding call to
+C<incr_parse> in I<scalar context> successfully returned an object. Under
+all other circumstances you must not call this function (I mean it.
+although in simple tests it might actually work, it I<will> fail under
+real world conditions). As a special exception, you can also call this
+method before having parsed anything.
+
+This function is useful in two cases: a) finding the trailing text after a
+JSON object or b) parsing multiple JSON objects separated by non-JSON text
+(such as commas).
+
+In Perl 5.005, C<lvalue> attribute is not available.
+You must write codes like the below:
+
+ $string = $json->incr_text;
+ $string =~ s/\s*,\s*//;
+ $json->incr_text( $string );
+
+=item $json->incr_skip
+
+This will reset the state of the incremental parser and will remove the
+parsed text from the input buffer. This is useful after C<incr_parse>
+died, in which case the input buffer and incremental parser state is left
+unchanged, to skip the text parsed so far and to reset the parse state.
+
+=back
+
+
+
+=head1 JSON::PP OWN METHODS
+
+=head2 allow_singlequote
+
+ $json = $json->allow_singlequote([$enable])
+
+If C<$enable> is true (or missing), then C<decode> will accept
+JSON strings quoted by single quotations that are invalid JSON
+format.
+
+ $json->allow_singlequote->decode({"foo":'bar'});
+ $json->allow_singlequote->decode({'foo':"bar"});
+ $json->allow_singlequote->decode({'foo':'bar'});
+
+As same as the C<relaxed> option, this option may be used to parse
+application-specific files written by humans.
+
+
+=head2 allow_barekey
+
+ $json = $json->allow_barekey([$enable])
+
+If C<$enable> is true (or missing), then C<decode> will accept
+bare keys of JSON object that are invalid JSON format.
+
+As same as the C<relaxed> option, this option may be used to parse
+application-specific files written by humans.
+
+ $json->allow_barekey->decode('{foo:"bar"}');
+
+=head2 allow_bignum
+
+ $json = $json->allow_bignum([$enable])
+
+If C<$enable> is true (or missing), then C<decode> will convert
+the big integer Perl cannot handle as integer into a L<Math::BigInt>
+object and convert a floating number (any) into a L<Math::BigFloat>.
+
+On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
+objects into JSON numbers with C<allow_blessed> enable.
+
+ $json->allow_nonref->allow_blessed->allow_bignum;
+ $bigfloat = $json->decode('2.000000000000000000000000001');
+ print $json->encode($bigfloat);
+ # => 2.000000000000000000000000001
+
+See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
+
+=head2 loose
+
+ $json = $json->loose([$enable])
+
+The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
+and the module doesn't allow to C<decode> to these (except for \x2f).
+If C<$enable> is true (or missing), then C<decode> will accept these
+unescaped strings.
+
+ $json->loose->decode(qq|["abc
+ def"]|);
+
+See L<JSON::XS/SSECURITY CONSIDERATIONS>.
+
+=head2 escape_slash
+
+ $json = $json->escape_slash([$enable])
+
+According to JSON Grammar, I<slash> (U+002F) is escaped. But default
+JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
+
+If C<$enable> is true (or missing), then C<encode> will escape slashes.
+
+=head2 (OBSOLETED)as_nonblessed
+
+ $json = $json->as_nonblessed
+
+(OBSOLETED) If C<$enable> is true (or missing), then C<encode> will convert
+a blessed hash reference or a blessed array reference (contains
+other blessed references) into JSON members and arrays.
+
+This feature is effective only when C<allow_blessed> is enable.
+
+=head2 indent_length
+
+ $json = $json->indent_length($length)
+
+JSON::XS indent space length is 3 and cannot be changed.
+JSON::PP set the indent space length with the given $length.
+The default is 3. The acceptable range is 0 to 15.
+
+=head2 sort_by
+
+ $json = $json->sort_by($function_name)
+ $json = $json->sort_by($subroutine_ref)
+
+If $function_name or $subroutine_ref are set, its sort routine are used
+in encoding JSON objects.
+
+ $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
+ # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
+
+ $js = $pc->sort_by('own_sort')->encode($obj);
+ # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
+
+ sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
+
+As the sorting routine runs in the JSON::PP scope, the given
+subroutine name and the special variables C<$a>, C<$b> will begin
+'JSON::PP::'.
+
+If $integer is set, then the effect is same as C<canonical> on.
+
+=head1 INTERNAL
+
+For developers.
+
+=over
+
+=item PP_encode_box
+
+Returns
+
+ {
+ depth => $depth,
+ indent_count => $indent_count,
+ }
+
+
+=item PP_decode_box
+
+Returns
+
+ {
+ text => $text,
+ at => $at,
+ ch => $ch,
+ len => $len,
+ depth => $depth,
+ encoding => $encoding,
+ is_valid_utf8 => $is_valid_utf8,
+ };
+
+=back
+
+=head1 MAPPING
+
+See to L<JSON::XS/MAPPING>.
+
+
+=head1 UNICODE HANDLING ON PERLS
+
+If you do not know about Unicode on Perl well,
+please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
+
+=head2 Perl 5.8 and later
+
+Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
+
+ $json->allow_nonref->encode(chr hex 3042);
+ $json->allow_nonref->encode(chr hex 12345);
+
+Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
+
+ $json->allow_nonref->decode('"\u3042"');
+ $json->allow_nonref->decode('"\ud808\udf45"');
+
+Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
+
+Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
+so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
+
+
+=head2 Perl 5.6
+
+Perl can handle Unicode and the JSON::PP de/encode methods also work.
+
+=head2 Perl 5.005
+
+Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
+That means the unicode handling is not available.
+
+In encoding,
+
+ $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
+ $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
+
+Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
+as C<$value % 256>, so the above codes are equivalent to :
+
+ $json->allow_nonref->encode(chr 66);
+ $json->allow_nonref->encode(chr 69);
+
+In decoding,
+
+ $json->decode('"\u00e3\u0081\u0082"');
+
+The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
+japanese character (C<HIRAGANA LETTER A>).
+And if it is represented in Unicode code point, C<U+3042>.
+
+Next,
+
+ $json->decode('"\u3042"');
+
+We ordinary expect the returned value is a Unicode character C<U+3042>.
+But here is 5.005 world. This is C<0xE3 0x81 0x82>.
+
+ $json->decode('"\ud808\udf45"');
+
+This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
+
+
+=head1 TODO
+
+=over
+
+=item speed
+
+=item memory saving
+
+=back
+
+
+=head1 SEE ALSO
+
+Most of the document are copied and modified from JSON::XS doc.
+
+L<JSON::XS>
+
+RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2010 by Makamaka Hannyaharamitu
+
+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.straw/lib/JSON/PP/Boolean.pm b/Master/tlpkg/tlperl.straw/lib/JSON/PP/Boolean.pm
new file mode 100755
index 00000000000..0b1fb19b2c2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON/PP/Boolean.pm
@@ -0,0 +1,26 @@
+=head1 NAME
+
+JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
+
+=head1 SYNOPSIS
+
+ # do not "use" yourself
+
+=head1 DESCRIPTION
+
+This module exists only to provide overload resolution for Storable and similar modules. See
+L<JSON::PP> for more info about this class.
+
+=cut
+
+use JSON::PP ();
+use strict;
+
+1;
+
+=head1 AUTHOR
+
+This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/JSON/PP5005.pm b/Master/tlpkg/tlperl.straw/lib/JSON/PP5005.pm
new file mode 100755
index 00000000000..9b69e3955c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON/PP5005.pm
@@ -0,0 +1,148 @@
+package JSON::PP5005;
+
+use 5.005;
+use strict;
+
+my @properties;
+
+$JSON::PP5005::VERSION = '1.09';
+
+BEGIN {
+
+ sub utf8::is_utf8 {
+ 0; # It is considered that UTF8 flag off for Perl 5.005.
+ }
+
+ sub utf8::upgrade {
+ }
+
+ sub utf8::downgrade {
+ 1; # must always return true.
+ }
+
+ sub utf8::encode {
+ }
+
+ sub utf8::decode {
+ }
+
+ *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
+ *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
+ *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
+ *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
+
+ # missing in B module.
+ sub B::SVf_IOK () { 0x00010000; }
+ sub B::SVf_NOK () { 0x00020000; }
+ sub B::SVf_POK () { 0x00040000; }
+ sub B::SVp_IOK () { 0x01000000; }
+ sub B::SVp_NOK () { 0x02000000; }
+
+ $INC{'bytes.pm'} = 1; # dummy
+}
+
+
+
+sub _encode_ascii {
+ join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) );
+}
+
+
+sub _encode_latin1 {
+ join('', map { chr($_) } unpack('C*', $_[0]) );
+}
+
+
+sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm
+ my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode
+ my $bit = unpack('B32', pack('N', $uni));
+
+ if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) {
+ my ($w, $x, $y, $z) = ($1, $2, $3, $4);
+ return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z));
+ }
+ else {
+ Carp::croak("Invalid surrogate pair");
+ }
+}
+
+
+sub _decode_unicode {
+ my ($u) = @_;
+ my ($utf8bit);
+
+ if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff
+ return pack( 'H2', $1 );
+ }
+
+ my $bit = unpack("B*", pack("H*", $u));
+
+ if ( $bit =~ /^00000(.....)(......)$/ ) {
+ $utf8bit = sprintf('110%s10%s', $1, $2);
+ }
+ elsif ( $bit =~ /^(....)(......)(......)$/ ) {
+ $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3);
+ }
+ else {
+ Carp::croak("Invalid escaped unicode");
+ }
+
+ return pack('B*', $utf8bit);
+}
+
+
+sub JSON::PP::incr_parse {
+ local $Carp::CarpLevel = 1;
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
+}
+
+
+sub JSON::PP::incr_text {
+ $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
+
+ if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
+ Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ }
+
+ $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 );
+ $_[0]->{_incr_parser}->{incr_text};
+}
+
+
+sub JSON::PP::incr_skip {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
+}
+
+
+sub JSON::PP::incr_reset {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
+}
+
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005
+
+=head1 DESCRIPTION
+
+JSON::PP calls internally.
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2009 by Makamaka Hannyaharamitu
+
+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.straw/lib/JSON/PP56.pm b/Master/tlpkg/tlperl.straw/lib/JSON/PP56.pm
new file mode 100755
index 00000000000..d5d8bfb29aa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON/PP56.pm
@@ -0,0 +1,198 @@
+package JSON::PP56;
+
+use 5.006;
+use strict;
+
+my @properties;
+
+$JSON::PP56::VERSION = '1.08';
+
+BEGIN {
+
+ sub utf8::is_utf8 {
+ my $len = length $_[0]; # char length
+ {
+ use bytes; # byte length;
+ return $len != length $_[0]; # if !=, UTF8-flagged on.
+ }
+ }
+
+
+ sub utf8::upgrade {
+ ; # noop;
+ }
+
+
+ sub utf8::downgrade ($;$) {
+ return 1 unless ( utf8::is_utf8( $_[0] ) );
+
+ if ( _is_valid_utf8( $_[0] ) ) {
+ my $downgrade;
+ for my $c ( unpack( "U*", $_[0] ) ) {
+ if ( $c < 256 ) {
+ $downgrade .= pack("C", $c);
+ }
+ else {
+ $downgrade .= pack("U", $c);
+ }
+ }
+ $_[0] = $downgrade;
+ return 1;
+ }
+ else {
+ Carp::croak("Wide character in subroutine entry") unless ( $_[1] );
+ 0;
+ }
+ }
+
+
+ sub utf8::encode ($) { # UTF8 flag off
+ if ( utf8::is_utf8( $_[0] ) ) {
+ $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
+ }
+ else {
+ $_[0] = pack( "U*", unpack( "C*", $_[0] ) );
+ $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
+ }
+ }
+
+
+ sub utf8::decode ($) { # UTF8 flag on
+ if ( _is_valid_utf8( $_[0] ) ) {
+ utf8::downgrade( $_[0] );
+ $_[0] = pack( "U*", unpack( "U*", $_[0] ) );
+ }
+ }
+
+
+ *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
+ *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
+ *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates;
+ *JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode;
+
+ unless ( defined &B::SVp_NOK ) { # missing in B module.
+ eval q{ sub B::SVp_NOK () { 0x02000000; } };
+ }
+
+}
+
+
+
+sub _encode_ascii {
+ join('',
+ map {
+ $_ <= 127 ?
+ chr($_) :
+ $_ <= 65535 ?
+ sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
+ } _unpack_emu($_[0])
+ );
+}
+
+
+sub _encode_latin1 {
+ join('',
+ map {
+ $_ <= 255 ?
+ chr($_) :
+ $_ <= 65535 ?
+ sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
+ } _unpack_emu($_[0])
+ );
+}
+
+
+sub _unpack_emu { # for Perl 5.6 unpack warnings
+ return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0])
+ : _is_valid_utf8($_[0]) ? unpack('U*', $_[0])
+ : unpack('C*', $_[0]);
+}
+
+
+sub _is_valid_utf8 {
+ my $str = $_[0];
+ my $is_utf8;
+
+ while ($str =~ /(?:
+ (
+ [\x00-\x7F]
+ |[\xC2-\xDF][\x80-\xBF]
+ |[\xE0][\xA0-\xBF][\x80-\xBF]
+ |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
+ |[\xED][\x80-\x9F][\x80-\xBF]
+ |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
+ |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
+ |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
+ |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
+ )
+ | (.)
+ )/xg)
+ {
+ if (defined $1) {
+ $is_utf8 = 1 if (!defined $is_utf8);
+ }
+ else {
+ $is_utf8 = 0 if (!defined $is_utf8);
+ if ($is_utf8) { # eventually, not utf8
+ return;
+ }
+ }
+ }
+
+ return $is_utf8;
+}
+
+
+sub JSON::PP::incr_parse {
+ local $Carp::CarpLevel = 1;
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
+}
+
+
+sub JSON::PP::incr_text : lvalue {
+ $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
+
+ if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
+ Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ }
+ $_[0]->{_incr_parser}->{incr_text};
+}
+
+
+sub JSON::PP::incr_skip {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
+}
+
+
+sub JSON::PP::incr_reset {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
+}
+
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+JSON::PP56 - Helper module in using JSON::PP in Perl 5.6
+
+=head1 DESCRIPTION
+
+JSON::PP calls internally.
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2009 by Makamaka Hannyaharamitu
+
+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.straw/lib/JSON/PP58.pm b/Master/tlpkg/tlperl.straw/lib/JSON/PP58.pm
new file mode 100755
index 00000000000..1174fc4bcbe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON/PP58.pm
@@ -0,0 +1,93 @@
+package JSON::PP58;
+
+use 5.008;
+use strict;
+
+my @properties;
+
+$JSON::PP58::VERSION = '1.03';
+
+
+BEGIN {
+
+ unless ( defined &utf8::is_utf8 ) {
+ require Encode;
+ *utf8::is_utf8 = *Encode::is_utf8;
+ }
+
+ *JSON::PP::JSON_PP_encode_ascii = \&JSON::PP::_encode_ascii;
+ *JSON::PP::JSON_PP_encode_latin1 = \&JSON::PP::_encode_latin1;
+ *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates;
+ *JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode;
+
+ if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
+ package JSON::PP;
+ require subs;
+ subs->import('join');
+ eval q|
+ sub join {
+ return '' if (@_ < 2);
+ my $j = shift;
+ my $str = shift;
+ for (@_) { $str .= $j . $_; }
+ return $str;
+ }
+ |;
+ }
+
+}
+
+
+sub JSON::PP::incr_parse {
+ local $Carp::CarpLevel = 1;
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
+}
+
+
+sub JSON::PP::incr_text : lvalue {
+ $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
+
+ if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
+ Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ }
+ $_[0]->{_incr_parser}->{incr_text};
+}
+
+
+sub JSON::PP::incr_skip {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
+}
+
+
+sub JSON::PP::incr_reset {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
+}
+
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+JSON::PP58 - Helper module in using JSON::PP in Perl 5.8 and lator
+
+=head1 DESCRIPTION
+
+JSON::PP calls internally.
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008-2009 by Makamaka Hannyaharamitu
+
+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.straw/lib/JSON/XS.pm b/Master/tlpkg/tlperl.straw/lib/JSON/XS.pm
new file mode 100755
index 00000000000..b7ab1958ac6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON/XS.pm
@@ -0,0 +1,1478 @@
+=head1 NAME
+
+JSON::XS - JSON serialising/deserialising, done correctly and fast
+
+=encoding utf-8
+
+JSON::XS - æ­£ã—ãã¦é«˜é€Ÿãª JSON シリアライザ/デシリアライザ
+ (http://fleur.hio.jp/perldoc/mix/lib/JSON/XS.html)
+
+=head1 SYNOPSIS
+
+ use JSON::XS;
+
+ # exported functions, they croak on error
+ # and expect/generate UTF-8
+
+ $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
+ $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
+
+ # OO-interface
+
+ $coder = JSON::XS->new->ascii->pretty->allow_nonref;
+ $pretty_printed_unencoded = $coder->encode ($perl_scalar);
+ $perl_scalar = $coder->decode ($unicode_json_text);
+
+ # Note that JSON version 2.0 and above will automatically use JSON::XS
+ # if available, at virtually no speed overhead either, so you should
+ # be able to just:
+
+ use JSON;
+
+ # and do the same things, except that you have a pure-perl fallback now.
+
+=head1 DESCRIPTION
+
+This module converts Perl data structures to JSON and vice versa. Its
+primary goal is to be I<correct> and its secondary goal is to be
+I<fast>. To reach the latter goal it was written in C.
+
+Beginning with version 2.0 of the JSON module, when both JSON and
+JSON::XS are installed, then JSON will fall back on JSON::XS (this can be
+overridden) with no overhead due to emulation (by inheriting constructor
+and methods). If JSON::XS is not available, it will fall back to the
+compatible JSON::PP module as backend, so using JSON instead of JSON::XS
+gives you a portable JSON API that can be fast when you need and doesn't
+require a C compiler when that is a problem.
+
+As this is the n-th-something JSON module on CPAN, what was the reason
+to write yet another JSON module? While it seems there are many JSON
+modules, none of them correctly handle all corner cases, and in most cases
+their maintainers are unresponsive, gone missing, or not listening to bug
+reports for other reasons.
+
+See MAPPING, below, on how JSON::XS maps perl values to JSON values and
+vice versa.
+
+=head2 FEATURES
+
+=over 4
+
+=item * correct Unicode handling
+
+This module knows how to handle Unicode, documents how and when it does
+so, and even documents what "correct" means.
+
+=item * round-trip integrity
+
+When you serialise a perl data structure using only data types supported
+by JSON, the deserialised data structure is identical on the Perl level.
+(e.g. the string "2.0" doesn't suddenly become "2" just because it looks
+like a number). There minor I<are> exceptions to this, read the MAPPING
+section below to learn about those.
+
+=item * strict checking of JSON correctness
+
+There is no guessing, no generating of illegal JSON texts by default,
+and only JSON is accepted as input by default (the latter is a security
+feature).
+
+=item * fast
+
+Compared to other JSON modules and other serialisers such as Storable,
+this module usually compares favourably in terms of speed, too.
+
+=item * simple to use
+
+This module has both a simple functional interface as well as an object
+oriented interface interface.
+
+=item * reasonably versatile output formats
+
+You can choose between the most compact guaranteed-single-line format
+possible (nice for simple line-based protocols), a pure-ASCII format
+(for when your transport is not 8-bit clean, still supports the whole
+Unicode range), or a pretty-printed format (for when you want to read that
+stuff). Or you can combine those features in whatever way you like.
+
+=back
+
+=cut
+
+package JSON::XS;
+
+use common::sense;
+
+our $VERSION = '2.27';
+our @ISA = qw(Exporter);
+
+our @EXPORT = qw(encode_json decode_json to_json from_json);
+
+sub to_json($) {
+ require Carp;
+ Carp::croak ("JSON::XS::to_json has been renamed to encode_json, either downgrade to pre-2.0 versions of JSON::XS or rename the call");
+}
+
+sub from_json($) {
+ require Carp;
+ Carp::croak ("JSON::XS::from_json has been renamed to decode_json, either downgrade to pre-2.0 versions of JSON::XS or rename the call");
+}
+
+use Exporter;
+use XSLoader;
+
+=head1 FUNCTIONAL INTERFACE
+
+The following convenience methods are provided by this module. They are
+exported by default:
+
+=over 4
+
+=item $json_text = encode_json $perl_scalar
+
+Converts the given Perl data structure to a UTF-8 encoded, binary string
+(that is, the string contains octets only). Croaks on error.
+
+This function call is functionally identical to:
+
+ $json_text = JSON::XS->new->utf8->encode ($perl_scalar)
+
+Except being faster.
+
+=item $perl_scalar = decode_json $json_text
+
+The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
+to parse that as an UTF-8 encoded JSON text, returning the resulting
+reference. Croaks on error.
+
+This function call is functionally identical to:
+
+ $perl_scalar = JSON::XS->new->utf8->decode ($json_text)
+
+Except being faster.
+
+=item $is_boolean = JSON::XS::is_bool $scalar
+
+Returns true if the passed scalar represents either JSON::XS::true or
+JSON::XS::false, two constants that act like C<1> and C<0>, respectively
+and are used to represent JSON C<true> and C<false> values in Perl.
+
+See MAPPING, below, for more information on how JSON values are mapped to
+Perl.
+
+=back
+
+
+=head1 A FEW NOTES ON UNICODE AND PERL
+
+Since this often leads to confusion, here are a few very clear words on
+how Unicode works in Perl, modulo bugs.
+
+=over 4
+
+=item 1. Perl strings can store characters with ordinal values > 255.
+
+This enables you to store Unicode characters as single characters in a
+Perl string - very natural.
+
+=item 2. Perl does I<not> associate an encoding with your strings.
+
+... until you force it to, e.g. when matching it against a regex, or
+printing the scalar to a file, in which case Perl either interprets your
+string as locale-encoded text, octets/binary, or as Unicode, depending
+on various settings. In no case is an encoding stored together with your
+data, it is I<use> that decides encoding, not any magical meta data.
+
+=item 3. The internal utf-8 flag has no meaning with regards to the
+encoding of your string.
+
+Just ignore that flag unless you debug a Perl bug, a module written in
+XS or want to dive into the internals of perl. Otherwise it will only
+confuse you, as, despite the name, it says nothing about how your string
+is encoded. You can have Unicode strings with that flag set, with that
+flag clear, and you can have binary data with that flag set and that flag
+clear. Other possibilities exist, too.
+
+If you didn't know about that flag, just the better, pretend it doesn't
+exist.
+
+=item 4. A "Unicode String" is simply a string where each character can be
+validly interpreted as a Unicode code point.
+
+If you have UTF-8 encoded data, it is no longer a Unicode string, but a
+Unicode string encoded in UTF-8, giving you a binary string.
+
+=item 5. A string containing "high" (> 255) character values is I<not> a UTF-8 string.
+
+It's a fact. Learn to live with it.
+
+=back
+
+I hope this helps :)
+
+
+=head1 OBJECT-ORIENTED INTERFACE
+
+The object oriented interface lets you configure your own encoding or
+decoding style, within the limits of supported formats.
+
+=over 4
+
+=item $json = new JSON::XS
+
+Creates a new JSON::XS object that can be used to de/encode JSON
+strings. All boolean flags described below are by default I<disabled>.
+
+The mutators for flags all return the JSON object again and thus calls can
+be chained:
+
+ my $json = JSON::XS->new->utf8->space_after->encode ({a => [1,2]})
+ => {"a": [1, 2]}
+
+=item $json = $json->ascii ([$enable])
+
+=item $enabled = $json->get_ascii
+
+If C<$enable> is true (or missing), then the C<encode> method will not
+generate characters outside the code range C<0..127> (which is ASCII). Any
+Unicode characters outside that range will be escaped using either a
+single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
+as per RFC4627. The resulting encoded JSON text can be treated as a native
+Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
+or any other superset of ASCII.
+
+If C<$enable> is false, then the C<encode> method will not escape Unicode
+characters unless required by the JSON syntax or other flags. This results
+in a faster and more compact format.
+
+See also the section I<ENCODING/CODESET FLAG NOTES> later in this
+document.
+
+The main use for this flag is to produce JSON texts that can be
+transmitted over a 7-bit channel, as the encoded JSON texts will not
+contain any 8 bit characters.
+
+ JSON::XS->new->ascii (1)->encode ([chr 0x10401])
+ => ["\ud801\udc01"]
+
+=item $json = $json->latin1 ([$enable])
+
+=item $enabled = $json->get_latin1
+
+If C<$enable> is true (or missing), then the C<encode> method will encode
+the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
+outside the code range C<0..255>. The resulting string can be treated as a
+latin1-encoded JSON text or a native Unicode string. The C<decode> method
+will not be affected in any way by this flag, as C<decode> by default
+expects Unicode, which is a strict superset of latin1.
+
+If C<$enable> is false, then the C<encode> method will not escape Unicode
+characters unless required by the JSON syntax or other flags.
+
+See also the section I<ENCODING/CODESET FLAG NOTES> later in this
+document.
+
+The main use for this flag is efficiently encoding binary data as JSON
+text, as most octets will not be escaped, resulting in a smaller encoded
+size. The disadvantage is that the resulting JSON text is encoded
+in latin1 (and must correctly be treated as such when storing and
+transferring), a rare encoding for JSON. It is therefore most useful when
+you want to store data structures known to contain binary data efficiently
+in files or databases, not when talking to other JSON encoders/decoders.
+
+ JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
+ => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+
+=item $json = $json->utf8 ([$enable])
+
+=item $enabled = $json->get_utf8
+
+If C<$enable> is true (or missing), then the C<encode> method will encode
+the JSON result into UTF-8, as required by many protocols, while the
+C<decode> method expects to be handled an UTF-8-encoded string. Please
+note that UTF-8-encoded strings do not contain any characters outside the
+range C<0..255>, they are thus useful for bytewise/binary I/O. In future
+versions, enabling this option might enable autodetection of the UTF-16
+and UTF-32 encoding families, as described in RFC4627.
+
+If C<$enable> is false, then the C<encode> method will return the JSON
+string as a (non-encoded) Unicode string, while C<decode> expects thus a
+Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs
+to be done yourself, e.g. using the Encode module.
+
+See also the section I<ENCODING/CODESET FLAG NOTES> later in this
+document.
+
+Example, output UTF-16BE-encoded JSON:
+
+ use Encode;
+ $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
+
+Example, decode UTF-32LE-encoded JSON:
+
+ use Encode;
+ $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
+
+=item $json = $json->pretty ([$enable])
+
+This enables (or disables) all of the C<indent>, C<space_before> and
+C<space_after> (and in the future possibly more) flags in one call to
+generate the most readable (or most compact) form possible.
+
+Example, pretty-print some simple structure:
+
+ my $json = JSON::XS->new->pretty(1)->encode ({a => [1,2]})
+ =>
+ {
+ "a" : [
+ 1,
+ 2
+ ]
+ }
+
+=item $json = $json->indent ([$enable])
+
+=item $enabled = $json->get_indent
+
+If C<$enable> is true (or missing), then the C<encode> method will use a multiline
+format as output, putting every array member or object/hash key-value pair
+into its own line, indenting them properly.
+
+If C<$enable> is false, no newlines or indenting will be produced, and the
+resulting JSON text is guaranteed not to contain any C<newlines>.
+
+This setting has no effect when decoding JSON texts.
+
+=item $json = $json->space_before ([$enable])
+
+=item $enabled = $json->get_space_before
+
+If C<$enable> is true (or missing), then the C<encode> method will add an extra
+optional space before the C<:> separating keys from values in JSON objects.
+
+If C<$enable> is false, then the C<encode> method will not add any extra
+space at those places.
+
+This setting has no effect when decoding JSON texts. You will also
+most likely combine this setting with C<space_after>.
+
+Example, space_before enabled, space_after and indent disabled:
+
+ {"key" :"value"}
+
+=item $json = $json->space_after ([$enable])
+
+=item $enabled = $json->get_space_after
+
+If C<$enable> is true (or missing), then the C<encode> method will add an extra
+optional space after the C<:> separating keys from values in JSON objects
+and extra whitespace after the C<,> separating key-value pairs and array
+members.
+
+If C<$enable> is false, then the C<encode> method will not add any extra
+space at those places.
+
+This setting has no effect when decoding JSON texts.
+
+Example, space_before and indent disabled, space_after enabled:
+
+ {"key": "value"}
+
+=item $json = $json->relaxed ([$enable])
+
+=item $enabled = $json->get_relaxed
+
+If C<$enable> is true (or missing), then C<decode> will accept some
+extensions to normal JSON syntax (see below). C<encode> will not be
+affected in anyway. I<Be aware that this option makes you accept invalid
+JSON texts as if they were valid!>. I suggest only to use this option to
+parse application-specific files written by humans (configuration files,
+resource files etc.)
+
+If C<$enable> is false (the default), then C<decode> will only accept
+valid JSON texts.
+
+Currently accepted extensions are:
+
+=over 4
+
+=item * list items can have an end-comma
+
+JSON I<separates> array elements and key-value pairs with commas. This
+can be annoying if you write JSON texts manually and want to be able to
+quickly append elements, so this extension accepts comma at the end of
+such items not just between them:
+
+ [
+ 1,
+ 2, <- this comma not normally allowed
+ ]
+ {
+ "k1": "v1",
+ "k2": "v2", <- this comma not normally allowed
+ }
+
+=item * shell-style '#'-comments
+
+Whenever JSON allows whitespace, shell-style comments are additionally
+allowed. They are terminated by the first carriage-return or line-feed
+character, after which more white-space and comments are allowed.
+
+ [
+ 1, # this comment not allowed in JSON
+ # neither this one...
+ ]
+
+=back
+
+=item $json = $json->canonical ([$enable])
+
+=item $enabled = $json->get_canonical
+
+If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
+by sorting their keys. This is adding a comparatively high overhead.
+
+If C<$enable> is false, then the C<encode> method will output key-value
+pairs in the order Perl stores them (which will likely change between runs
+of the same script).
+
+This option is useful if you want the same data structure to be encoded as
+the same JSON text (given the same overall settings). If it is disabled,
+the same hash might be encoded differently even if contains the same data,
+as key-value pairs have no inherent ordering in Perl.
+
+This setting has no effect when decoding JSON texts.
+
+This setting has currently no effect on tied hashes.
+
+=item $json = $json->allow_nonref ([$enable])
+
+=item $enabled = $json->get_allow_nonref
+
+If C<$enable> is true (or missing), then the C<encode> method can convert a
+non-reference into its corresponding string, number or null JSON value,
+which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
+values instead of croaking.
+
+If C<$enable> is false, then the C<encode> method will croak if it isn't
+passed an arrayref or hashref, as JSON texts must either be an object
+or array. Likewise, C<decode> will croak if given something that is not a
+JSON object or array.
+
+Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
+resulting in an invalid JSON text:
+
+ JSON::XS->new->allow_nonref->encode ("Hello, World!")
+ => "Hello, World!"
+
+=item $json = $json->allow_unknown ([$enable])
+
+=item $enabled = $json->get_allow_unknown
+
+If C<$enable> is true (or missing), then C<encode> will I<not> throw an
+exception when it encounters values it cannot represent in JSON (for
+example, filehandles) but instead will encode a JSON C<null> value. Note
+that blessed objects are not included here and are handled separately by
+c<allow_nonref>.
+
+If C<$enable> is false (the default), then C<encode> will throw an
+exception when it encounters anything it cannot encode as JSON.
+
+This option does not affect C<decode> in any way, and it is recommended to
+leave it off unless you know your communications partner.
+
+=item $json = $json->allow_blessed ([$enable])
+
+=item $enabled = $json->get_allow_blessed
+
+If C<$enable> is true (or missing), then the C<encode> method will not
+barf when it encounters a blessed reference. Instead, the value of the
+B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
+disabled or no C<TO_JSON> method found) or a representation of the
+object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
+encoded. Has no effect on C<decode>.
+
+If C<$enable> is false (the default), then C<encode> will throw an
+exception when it encounters a blessed object.
+
+=item $json = $json->convert_blessed ([$enable])
+
+=item $enabled = $json->get_convert_blessed
+
+If C<$enable> is true (or missing), then C<encode>, upon encountering a
+blessed object, will check for the availability of the C<TO_JSON> method
+on the object's class. If found, it will be called in scalar context
+and the resulting scalar will be encoded instead of the object. If no
+C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
+to do.
+
+The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
+returns other blessed objects, those will be handled in the same
+way. C<TO_JSON> must take care of not causing an endless recursion cycle
+(== crash) in this case. The name of C<TO_JSON> was chosen because other
+methods called by the Perl core (== not by the user of the object) are
+usually in upper case letters and to avoid collisions with any C<to_json>
+function or method.
+
+This setting does not yet influence C<decode> in any way, but in the
+future, global hooks might get installed that influence C<decode> and are
+enabled by this setting.
+
+If C<$enable> is false, then the C<allow_blessed> setting will decide what
+to do when a blessed object is found.
+
+=item $json = $json->filter_json_object ([$coderef->($hashref)])
+
+When C<$coderef> is specified, it will be called from C<decode> each
+time it decodes a JSON object. The only argument is a reference to the
+newly-created hash. If the code references returns a single scalar (which
+need not be a reference), this value (i.e. a copy of that scalar to avoid
+aliasing) is inserted into the deserialised data structure. If it returns
+an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the
+original deserialised hash will be inserted. This setting can slow down
+decoding considerably.
+
+When C<$coderef> is omitted or undefined, any existing callback will
+be removed and C<decode> will not change the deserialised hash in any
+way.
+
+Example, convert all JSON objects into the integer 5:
+
+ my $js = JSON::XS->new->filter_json_object (sub { 5 });
+ # returns [5]
+ $js->decode ('[{}]')
+ # throw an exception because allow_nonref is not enabled
+ # so a lone 5 is not allowed.
+ $js->decode ('{"a":1, "b":2}');
+
+=item $json = $json->filter_json_single_key_object ($key [=> $coderef->($value)])
+
+Works remotely similar to C<filter_json_object>, but is only called for
+JSON objects having a single key named C<$key>.
+
+This C<$coderef> is called before the one specified via
+C<filter_json_object>, if any. It gets passed the single value in the JSON
+object. If it returns a single value, it will be inserted into the data
+structure. If it returns nothing (not even C<undef> but the empty list),
+the callback from C<filter_json_object> will be called next, as if no
+single-key callback were specified.
+
+If C<$coderef> is omitted or undefined, the corresponding callback will be
+disabled. There can only ever be one callback for a given key.
+
+As this callback gets called less often then the C<filter_json_object>
+one, decoding speed will not usually suffer as much. Therefore, single-key
+objects make excellent targets to serialise Perl objects into, especially
+as single-key JSON objects are as close to the type-tagged value concept
+as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
+support this in any way, so you need to make sure your data never looks
+like a serialised Perl hash.
+
+Typical names for the single object key are C<__class_whatever__>, or
+C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
+things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
+with real hashes.
+
+Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
+into the corresponding C<< $WIDGET{<id>} >> object:
+
+ # return whatever is in $WIDGET{5}:
+ JSON::XS
+ ->new
+ ->filter_json_single_key_object (__widget__ => sub {
+ $WIDGET{ $_[0] }
+ })
+ ->decode ('{"__widget__": 5')
+
+ # this can be used with a TO_JSON method in some "widget" class
+ # for serialisation to json:
+ sub WidgetBase::TO_JSON {
+ my ($self) = @_;
+
+ unless ($self->{id}) {
+ $self->{id} = ..get..some..id..;
+ $WIDGET{$self->{id}} = $self;
+ }
+
+ { __widget__ => $self->{id} }
+ }
+
+=item $json = $json->shrink ([$enable])
+
+=item $enabled = $json->get_shrink
+
+Perl usually over-allocates memory a bit when allocating space for
+strings. This flag optionally resizes strings generated by either
+C<encode> or C<decode> to their minimum size possible. This can save
+memory when your JSON texts are either very very long or you have many
+short strings. It will also try to downgrade any strings to octet-form
+if possible: perl stores strings internally either in an encoding called
+UTF-X or in octet-form. The latter cannot store everything but uses less
+space in general (and some buggy Perl or C code might even rely on that
+internal representation being used).
+
+The actual definition of what shrink does might change in future versions,
+but it will always try to save space at the expense of time.
+
+If C<$enable> is true (or missing), the string returned by C<encode> will
+be shrunk-to-fit, while all strings generated by C<decode> will also be
+shrunk-to-fit.
+
+If C<$enable> is false, then the normal perl allocation algorithms are used.
+If you work with your data, then this is likely to be faster.
+
+In the future, this setting might control other things, such as converting
+strings that look like integers or floats into integers or floats
+internally (there is no difference on the Perl level), saving space.
+
+=item $json = $json->max_depth ([$maximum_nesting_depth])
+
+=item $max_depth = $json->get_max_depth
+
+Sets the maximum nesting level (default C<512>) accepted while encoding
+or decoding. If a higher nesting level is detected in JSON text or a Perl
+data structure, then the encoder and decoder will stop and croak at that
+point.
+
+Nesting level is defined by number of hash- or arrayrefs that the encoder
+needs to traverse to reach a given point or the number of C<{> or C<[>
+characters without their matching closing parenthesis crossed to reach a
+given character in a string.
+
+Setting the maximum depth to one disallows any nesting, so that ensures
+that the object is only a single hash/object or array.
+
+If no argument is given, the highest possible setting will be used, which
+is rarely useful.
+
+Note that nesting is implemented by recursion in C. The default value has
+been chosen to be as large as typical operating systems allow without
+crashing.
+
+See SECURITY CONSIDERATIONS, below, for more info on why this is useful.
+
+=item $json = $json->max_size ([$maximum_string_size])
+
+=item $max_size = $json->get_max_size
+
+Set the maximum length a JSON text may have (in bytes) where decoding is
+being attempted. The default is C<0>, meaning no limit. When C<decode>
+is called on a string that is longer then this many bytes, it will not
+attempt to decode the string but throw an exception. This setting has no
+effect on C<encode> (yet).
+
+If no argument is given, the limit check will be deactivated (same as when
+C<0> is specified).
+
+See SECURITY CONSIDERATIONS, below, for more info on why this is useful.
+
+=item $json_text = $json->encode ($perl_scalar)
+
+Converts the given Perl data structure (a simple scalar or a reference
+to a hash or array) to its JSON representation. Simple scalars will be
+converted into JSON string or number sequences, while references to arrays
+become JSON arrays and references to hashes become JSON objects. Undefined
+Perl values (e.g. C<undef>) become JSON C<null> values. Neither C<true>
+nor C<false> values will be generated.
+
+=item $perl_scalar = $json->decode ($json_text)
+
+The opposite of C<encode>: expects a JSON text and tries to parse it,
+returning the resulting simple scalar or reference. Croaks on error.
+
+JSON numbers and strings become simple Perl scalars. JSON arrays become
+Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
+C<1>, C<false> becomes C<0> and C<null> becomes C<undef>.
+
+=item ($perl_scalar, $characters) = $json->decode_prefix ($json_text)
+
+This works like the C<decode> method, but instead of raising an exception
+when there is trailing garbage after the first JSON object, it will
+silently stop parsing there and return the number of characters consumed
+so far.
+
+This is useful if your JSON texts are not delimited by an outer protocol
+(which is not the brightest thing to do in the first place) and you need
+to know where the JSON text ends.
+
+ JSON::XS->new->decode_prefix ("[1] the tail")
+ => ([], 3)
+
+=back
+
+
+=head1 INCREMENTAL PARSING
+
+In some cases, there is the need for incremental parsing of JSON
+texts. While this module always has to keep both JSON text and resulting
+Perl data structure in memory at one time, it does allow you to parse a
+JSON stream incrementally. It does so by accumulating text until it has
+a full JSON object, which it then can decode. This process is similar to
+using C<decode_prefix> to see if a full JSON object is available, but
+is much more efficient (and can be implemented with a minimum of method
+calls).
+
+JSON::XS will only attempt to parse the JSON text once it is sure it
+has enough text to get a decisive result, using a very simple but
+truly incremental parser. This means that it sometimes won't stop as
+early as the full parser, for example, it doesn't detect parenthese
+mismatches. The only thing it guarantees is that it starts decoding as
+soon as a syntactically valid JSON text has been seen. This means you need
+to set resource limits (e.g. C<max_size>) to ensure the parser will stop
+parsing in the presence if syntax errors.
+
+The following methods implement this incremental parser.
+
+=over 4
+
+=item [void, scalar or list context] = $json->incr_parse ([$string])
+
+This is the central parsing function. It can both append new text and
+extract objects from the stream accumulated so far (both of these
+functions are optional).
+
+If C<$string> is given, then this string is appended to the already
+existing JSON fragment stored in the C<$json> object.
+
+After that, if the function is called in void context, it will simply
+return without doing anything further. This can be used to add more text
+in as many chunks as you want.
+
+If the method is called in scalar context, then it will try to extract
+exactly I<one> JSON object. If that is successful, it will return this
+object, otherwise it will return C<undef>. If there is a parse error,
+this method will croak just as C<decode> would do (one can then use
+C<incr_skip> to skip the errornous part). This is the most common way of
+using the method.
+
+And finally, in list context, it will try to extract as many objects
+from the stream as it can find and return them, or the empty list
+otherwise. For this to work, there must be no separators between the JSON
+objects or arrays, instead they must be concatenated back-to-back. If
+an error occurs, an exception will be raised as in the scalar context
+case. Note that in this case, any previously-parsed JSON texts will be
+lost.
+
+=item $lvalue_string = $json->incr_text
+
+This method returns the currently stored JSON fragment as an lvalue, that
+is, you can manipulate it. This I<only> works when a preceding call to
+C<incr_parse> in I<scalar context> successfully returned an object. Under
+all other circumstances you must not call this function (I mean it.
+although in simple tests it might actually work, it I<will> fail under
+real world conditions). As a special exception, you can also call this
+method before having parsed anything.
+
+This function is useful in two cases: a) finding the trailing text after a
+JSON object or b) parsing multiple JSON objects separated by non-JSON text
+(such as commas).
+
+=item $json->incr_skip
+
+This will reset the state of the incremental parser and will remove
+the parsed text from the input buffer so far. This is useful after
+C<incr_parse> died, in which case the input buffer and incremental parser
+state is left unchanged, to skip the text parsed so far and to reset the
+parse state.
+
+The difference to C<incr_reset> is that only text until the parse error
+occured is removed.
+
+=item $json->incr_reset
+
+This completely resets the incremental parser, that is, after this call,
+it will be as if the parser had never parsed anything.
+
+This is useful if you want to repeatedly parse JSON objects and want to
+ignore any trailing data, which means you have to reset the parser after
+each successful decode.
+
+=back
+
+=head2 LIMITATIONS
+
+All options that affect decoding are supported, except
+C<allow_nonref>. The reason for this is that it cannot be made to
+work sensibly: JSON objects and arrays are self-delimited, i.e. you can concatenate
+them back to back and still decode them perfectly. This does not hold true
+for JSON numbers, however.
+
+For example, is the string C<1> a single JSON number, or is it simply the
+start of C<12>? Or is C<12> a single JSON number, or the concatenation
+of C<1> and C<2>? In neither case you can tell, and this is why JSON::XS
+takes the conservative route and disallows this case.
+
+=head2 EXAMPLES
+
+Some examples will make all this clearer. First, a simple example that
+works similarly to C<decode_prefix>: We want to decode the JSON object at
+the start of a string and identify the portion after the JSON object:
+
+ my $text = "[1,2,3] hello";
+
+ my $json = new JSON::XS;
+
+ my $obj = $json->incr_parse ($text)
+ or die "expected JSON object or array at beginning of string";
+
+ my $tail = $json->incr_text;
+ # $tail now contains " hello"
+
+Easy, isn't it?
+
+Now for a more complicated example: Imagine a hypothetical protocol where
+you read some requests from a TCP stream, and each request is a JSON
+array, without any separation between them (in fact, it is often useful to
+use newlines as "separators", as these get interpreted as whitespace at
+the start of the JSON text, which makes it possible to test said protocol
+with C<telnet>...).
+
+Here is how you'd do it (it is trivial to write this in an event-based
+manner):
+
+ my $json = new JSON::XS;
+
+ # read some data from the socket
+ while (sysread $socket, my $buf, 4096) {
+
+ # split and decode as many requests as possible
+ for my $request ($json->incr_parse ($buf)) {
+ # act on the $request
+ }
+ }
+
+Another complicated example: Assume you have a string with JSON objects
+or arrays, all separated by (optional) comma characters (e.g. C<[1],[2],
+[3]>). To parse them, we have to skip the commas between the JSON texts,
+and here is where the lvalue-ness of C<incr_text> comes in useful:
+
+ my $text = "[1],[2], [3]";
+ my $json = new JSON::XS;
+
+ # void context, so no parsing done
+ $json->incr_parse ($text);
+
+ # now extract as many objects as possible. note the
+ # use of scalar context so incr_text can be called.
+ while (my $obj = $json->incr_parse) {
+ # do something with $obj
+
+ # now skip the optional comma
+ $json->incr_text =~ s/^ \s* , //x;
+ }
+
+Now lets go for a very complex example: Assume that you have a gigantic
+JSON array-of-objects, many gigabytes in size, and you want to parse it,
+but you cannot load it into memory fully (this has actually happened in
+the real world :).
+
+Well, you lost, you have to implement your own JSON parser. But JSON::XS
+can still help you: You implement a (very simple) array parser and let
+JSON decode the array elements, which are all full JSON objects on their
+own (this wouldn't work if the array elements could be JSON numbers, for
+example):
+
+ my $json = new JSON::XS;
+
+ # open the monster
+ open my $fh, "<bigfile.json"
+ or die "bigfile: $!";
+
+ # first parse the initial "["
+ for (;;) {
+ sysread $fh, my $buf, 65536
+ or die "read error: $!";
+ $json->incr_parse ($buf); # void context, so no parsing
+
+ # Exit the loop once we found and removed(!) the initial "[".
+ # In essence, we are (ab-)using the $json object as a simple scalar
+ # we append data to.
+ last if $json->incr_text =~ s/^ \s* \[ //x;
+ }
+
+ # now we have the skipped the initial "[", so continue
+ # parsing all the elements.
+ for (;;) {
+ # in this loop we read data until we got a single JSON object
+ for (;;) {
+ if (my $obj = $json->incr_parse) {
+ # do something with $obj
+ last;
+ }
+
+ # add more data
+ sysread $fh, my $buf, 65536
+ or die "read error: $!";
+ $json->incr_parse ($buf); # void context, so no parsing
+ }
+
+ # in this loop we read data until we either found and parsed the
+ # separating "," between elements, or the final "]"
+ for (;;) {
+ # first skip whitespace
+ $json->incr_text =~ s/^\s*//;
+
+ # if we find "]", we are done
+ if ($json->incr_text =~ s/^\]//) {
+ print "finished.\n";
+ exit;
+ }
+
+ # if we find ",", we can continue with the next element
+ if ($json->incr_text =~ s/^,//) {
+ last;
+ }
+
+ # if we find anything else, we have a parse error!
+ if (length $json->incr_text) {
+ die "parse error near ", $json->incr_text;
+ }
+
+ # else add more data
+ sysread $fh, my $buf, 65536
+ or die "read error: $!";
+ $json->incr_parse ($buf); # void context, so no parsing
+ }
+
+This is a complex example, but most of the complexity comes from the fact
+that we are trying to be correct (bear with me if I am wrong, I never ran
+the above example :).
+
+
+
+=head1 MAPPING
+
+This section describes how JSON::XS maps Perl values to JSON values and
+vice versa. These mappings are designed to "do the right thing" in most
+circumstances automatically, preserving round-tripping characteristics
+(what you put in comes out as something equivalent).
+
+For the more enlightened: note that in the following descriptions,
+lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
+refers to the abstract Perl language itself.
+
+
+=head2 JSON -> PERL
+
+=over 4
+
+=item object
+
+A JSON object becomes a reference to a hash in Perl. No ordering of object
+keys is preserved (JSON does not preserve object key ordering itself).
+
+=item array
+
+A JSON array becomes a reference to an array in Perl.
+
+=item string
+
+A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
+are represented by the same codepoints in the Perl string, so no manual
+decoding is necessary.
+
+=item number
+
+A JSON number becomes either an integer, numeric (floating point) or
+string scalar in perl, depending on its range and any fractional parts. On
+the Perl level, there is no difference between those as Perl handles all
+the conversion details, but an integer may take slightly less memory and
+might represent more values exactly than floating point numbers.
+
+If the number consists of digits only, JSON::XS will try to represent
+it as an integer value. If that fails, it will try to represent it as
+a numeric (floating point) value if that is possible without loss of
+precision. Otherwise it will preserve the number as a string value (in
+which case you lose roundtripping ability, as the JSON number will be
+re-encoded toa JSON string).
+
+Numbers containing a fractional or exponential part will always be
+represented as numeric (floating point) values, possibly at a loss of
+precision (in which case you might lose perfect roundtripping ability, but
+the JSON number will still be re-encoded as a JSON number).
+
+=item true, false
+
+These JSON atoms become C<JSON::XS::true> and C<JSON::XS::false>,
+respectively. They are overloaded to act almost exactly like the numbers
+C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
+the C<JSON::XS::is_bool> function.
+
+=item null
+
+A JSON null atom becomes C<undef> in Perl.
+
+=back
+
+
+=head2 PERL -> JSON
+
+The mapping from Perl to JSON is slightly more difficult, as Perl is a
+truly typeless language, so we can only guess which JSON type is meant by
+a Perl value.
+
+=over 4
+
+=item hash references
+
+Perl hash references become JSON objects. As there is no inherent ordering
+in hash keys (or JSON objects), they will usually be encoded in a
+pseudo-random order that can change between runs of the same program but
+stays generally the same within a single run of a program. JSON::XS can
+optionally sort the hash keys (determined by the I<canonical> flag), so
+the same datastructure will serialise to the same JSON text (given same
+settings and version of JSON::XS), but this incurs a runtime overhead
+and is only rarely useful, e.g. when you want to compare some JSON text
+against another for equality.
+
+=item array references
+
+Perl array references become JSON arrays.
+
+=item other references
+
+Other unblessed references are generally not allowed and will cause an
+exception to be thrown, except for references to the integers C<0> and
+C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
+also use C<JSON::XS::false> and C<JSON::XS::true> to improve readability.
+
+ encode_json [\0, JSON::XS::true] # yields [false,true]
+
+=item JSON::XS::true, JSON::XS::false
+
+These special values become JSON true and JSON false values,
+respectively. You can also use C<\1> and C<\0> directly if you want.
+
+=item blessed objects
+
+Blessed objects are not directly representable in JSON. See the
+C<allow_blessed> and C<convert_blessed> methods on various options on
+how to deal with this: basically, you can choose between throwing an
+exception, encoding the reference as if it weren't blessed, or provide
+your own serialiser method.
+
+=item simple scalars
+
+Simple Perl scalars (any scalar that is not a reference) are the most
+difficult objects to encode: JSON::XS will encode undefined scalars as
+JSON C<null> values, scalars that have last been used in a string context
+before encoding as JSON strings, and anything else as number value:
+
+ # dump as number
+ encode_json [2] # yields [2]
+ encode_json [-3.0e17] # yields [-3e+17]
+ my $value = 5; encode_json [$value] # yields [5]
+
+ # used as string, so dump as string
+ print $value;
+ encode_json [$value] # yields ["5"]
+
+ # undef becomes null
+ encode_json [undef] # yields [null]
+
+You can force the type to be a JSON string by stringifying it:
+
+ my $x = 3.1; # some variable containing a number
+ "$x"; # stringified
+ $x .= ""; # another, more awkward way to stringify
+ print $x; # perl does it for you, too, quite often
+
+You can force the type to be a JSON number by numifying it:
+
+ my $x = "3"; # some variable containing a string
+ $x += 0; # numify it, ensuring it will be dumped as a number
+ $x *= 1; # same thing, the choice is yours.
+
+You can not currently force the type in other, less obscure, ways. Tell me
+if you need this capability (but don't forget to explain why it's needed
+:).
+
+=back
+
+
+=head1 ENCODING/CODESET FLAG NOTES
+
+The interested reader might have seen a number of flags that signify
+encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
+some confusion on what these do, so here is a short comparison:
+
+C<utf8> controls whether the JSON text created by C<encode> (and expected
+by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
+control whether C<encode> escapes character values outside their respective
+codeset range. Neither of these flags conflict with each other, although
+some combinations make less sense than others.
+
+Care has been taken to make all flags symmetrical with respect to
+C<encode> and C<decode>, that is, texts encoded with any combination of
+these flag values will be correctly decoded when the same flags are used
+- in general, if you use different flag settings while encoding vs. when
+decoding you likely have a bug somewhere.
+
+Below comes a verbose discussion of these flags. Note that a "codeset" is
+simply an abstract set of character-codepoint pairs, while an encoding
+takes those codepoint numbers and I<encodes> them, in our case into
+octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
+and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
+the same time, which can be confusing.
+
+=over 4
+
+=item C<utf8> flag disabled
+
+When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
+and expect Unicode strings, that is, characters with high ordinal Unicode
+values (> 255) will be encoded as such characters, and likewise such
+characters are decoded as-is, no canges to them will be done, except
+"(re-)interpreting" them as Unicode codepoints or Unicode characters,
+respectively (to Perl, these are the same thing in strings unless you do
+funny/weird/dumb stuff).
+
+This is useful when you want to do the encoding yourself (e.g. when you
+want to have UTF-16 encoded JSON texts) or when some other layer does
+the encoding for you (for example, when printing to a terminal using a
+filehandle that transparently encodes to UTF-8 you certainly do NOT want
+to UTF-8 encode your data first and have Perl encode it another time).
+
+=item C<utf8> flag enabled
+
+If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
+characters using the corresponding UTF-8 multi-byte sequence, and will
+expect your input strings to be encoded as UTF-8, that is, no "character"
+of the input string must have any value > 255, as UTF-8 does not allow
+that.
+
+The C<utf8> flag therefore switches between two modes: disabled means you
+will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
+octet/binary string in Perl.
+
+=item C<latin1> or C<ascii> flags enabled
+
+With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
+with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
+characters as specified by the C<utf8> flag.
+
+If C<utf8> is disabled, then the result is also correctly encoded in those
+character sets (as both are proper subsets of Unicode, meaning that a
+Unicode string with all character values < 256 is the same thing as a
+ISO-8859-1 string, and a Unicode string with all character values < 128 is
+the same thing as an ASCII string in Perl).
+
+If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
+regardless of these flags, just some more characters will be escaped using
+C<\uXXXX> then before.
+
+Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
+encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
+encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
+a subset of Unicode), while ASCII is.
+
+Surprisingly, C<decode> will ignore these flags and so treat all input
+values as governed by the C<utf8> flag. If it is disabled, this allows you
+to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
+Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
+
+So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
+they only govern when the JSON output engine escapes a character or not.
+
+The main use for C<latin1> is to relatively efficiently store binary data
+as JSON, at the expense of breaking compatibility with most JSON decoders.
+
+The main use for C<ascii> is to force the output to not contain characters
+with values > 127, which means you can interpret the resulting string
+as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
+8-bit-encoding, and still get the same data structure back. This is useful
+when your channel for JSON transfer is not 8-bit clean or the encoding
+might be mangled in between (e.g. in mail), and works because ASCII is a
+proper subset of most 8-bit and multibyte encodings in use in the world.
+
+=back
+
+
+=head2 JSON and ECMAscript
+
+JSON syntax is based on how literals are represented in javascript (the
+not-standardised predecessor of ECMAscript) which is presumably why it is
+called "JavaScript Object Notation".
+
+However, JSON is not a subset (and also not a superset of course) of
+ECMAscript (the standard) or javascript (whatever browsers actually
+implement).
+
+If you want to use javascript's C<eval> function to "parse" JSON, you
+might run into parse errors for valid JSON texts, or the resulting data
+structure might not be queryable:
+
+One of the problems is that U+2028 and U+2029 are valid characters inside
+JSON strings, but are not allowed in ECMAscript string literals, so the
+following Perl fragment will not output something that can be guaranteed
+to be parsable by javascript's C<eval>:
+
+ use JSON::XS;
+
+ print encode_json [chr 0x2028];
+
+The right fix for this is to use a proper JSON parser in your javascript
+programs, and not rely on C<eval> (see for example Douglas Crockford's
+F<json2.js> parser).
+
+If this is not an option, you can, as a stop-gap measure, simply encode to
+ASCII-only JSON:
+
+ use JSON::XS;
+
+ print JSON::XS->new->ascii->encode ([chr 0x2028]);
+
+Note that this will enlarge the resulting JSON text quite a bit if you
+have many non-ASCII characters. You might be tempted to run some regexes
+to only escape U+2028 and U+2029, e.g.:
+
+ # DO NOT USE THIS!
+ my $json = JSON::XS->new->utf8->encode ([chr 0x2028]);
+ $json =~ s/\xe2\x80\xa8/\\u2028/g; # escape U+2028
+ $json =~ s/\xe2\x80\xa9/\\u2029/g; # escape U+2029
+ print $json;
+
+Note that I<this is a bad idea>: the above only works for U+2028 and
+U+2029 and thus only for fully ECMAscript-compliant parsers. Many existing
+javascript implementations, however, have issues with other characters as
+well - using C<eval> naively simply I<will> cause problems.
+
+Another problem is that some javascript implementations reserve
+some property names for their own purposes (which probably makes
+them non-ECMAscript-compliant). For example, Iceweasel reserves the
+C<__proto__> property name for it's own purposes.
+
+If that is a problem, you could parse try to filter the resulting JSON
+output for these property strings, e.g.:
+
+ $json =~ s/"__proto__"\s*:/"__proto__renamed":/g;
+
+This works because C<__proto__> is not valid outside of strings, so every
+occurence of C<"__proto__"\s*:> must be a string used as property name.
+
+If you know of other incompatibilities, please let me know.
+
+
+=head2 JSON and YAML
+
+You often hear that JSON is a subset of YAML. This is, however, a mass
+hysteria(*) and very far from the truth (as of the time of this writing),
+so let me state it clearly: I<in general, there is no way to configure
+JSON::XS to output a data structure as valid YAML> that works in all
+cases.
+
+If you really must use JSON::XS to generate YAML, you should use this
+algorithm (subject to change in future versions):
+
+ my $to_yaml = JSON::XS->new->utf8->space_after (1);
+ my $yaml = $to_yaml->encode ($ref) . "\n";
+
+This will I<usually> generate JSON texts that also parse as valid
+YAML. Please note that YAML has hardcoded limits on (simple) object key
+lengths that JSON doesn't have and also has different and incompatible
+unicode character escape syntax, so you should make sure that your hash
+keys are noticeably shorter than the 1024 "stream characters" YAML allows
+and that you do not have characters with codepoint values outside the
+Unicode BMP (basic multilingual page). YAML also does not allow C<\/>
+sequences in strings (which JSON::XS does not I<currently> generate, but
+other JSON generators might).
+
+There might be other incompatibilities that I am not aware of (or the YAML
+specification has been changed yet again - it does so quite often). In
+general you should not try to generate YAML with a JSON generator or vice
+versa, or try to parse JSON with a YAML parser or vice versa: chances are
+high that you will run into severe interoperability problems when you
+least expect it.
+
+=over 4
+
+=item (*)
+
+I have been pressured multiple times by Brian Ingerson (one of the
+authors of the YAML specification) to remove this paragraph, despite him
+acknowledging that the actual incompatibilities exist. As I was personally
+bitten by this "JSON is YAML" lie, I refused and said I will continue to
+educate people about these issues, so others do not run into the same
+problem again and again. After this, Brian called me a (quote)I<complete
+and worthless idiot>(unquote).
+
+In my opinion, instead of pressuring and insulting people who actually
+clarify issues with YAML and the wrong statements of some of its
+proponents, I would kindly suggest reading the JSON spec (which is not
+that difficult or long) and finally make YAML compatible to it, and
+educating users about the changes, instead of spreading lies about the
+real compatibility for many I<years> and trying to silence people who
+point out that it isn't true.
+
+Addendum/2009: the YAML 1.2 spec is still incomaptible with JSON, even
+though the incompatibilities have been documented (and are known to
+Brian) for many years and the spec makes explicit claims that YAML is a
+superset of JSON. It would be so easy to fix, but apparently, bullying and
+corrupting userdata is so much easier.
+
+=back
+
+
+=head2 SPEED
+
+It seems that JSON::XS is surprisingly fast, as shown in the following
+tables. They have been generated with the help of the C<eg/bench> program
+in the JSON::XS distribution, to make it easy to compare on your own
+system.
+
+First comes a comparison between various modules using
+a very short single-line JSON string (also available at
+L<http://dist.schmorp.de/misc/json/short.json>).
+
+ {"method": "handleMessage", "params": ["user1",
+ "we were just talking"], "id": null, "array":[1,11,234,-5,1e5,1e7,
+ true, false]}
+
+It shows the number of encodes/decodes per second (JSON::XS uses
+the functional interface, while JSON::XS/2 uses the OO interface
+with pretty-printing and hashkey sorting enabled, JSON::XS/3 enables
+shrink). Higher is better:
+
+ module | encode | decode |
+ -----------|------------|------------|
+ JSON 1.x | 4990.842 | 4088.813 |
+ JSON::DWIW | 51653.990 | 71575.154 |
+ JSON::PC | 65948.176 | 74631.744 |
+ JSON::PP | 8931.652 | 3817.168 |
+ JSON::Syck | 24877.248 | 27776.848 |
+ JSON::XS | 388361.481 | 227951.304 |
+ JSON::XS/2 | 227951.304 | 218453.333 |
+ JSON::XS/3 | 338250.323 | 218453.333 |
+ Storable | 16500.016 | 135300.129 |
+ -----------+------------+------------+
+
+That is, JSON::XS is about five times faster than JSON::DWIW on encoding,
+about three times faster on decoding, and over forty times faster
+than JSON, even with pretty-printing and key sorting. It also compares
+favourably to Storable for small amounts of data.
+
+Using a longer test string (roughly 18KB, generated from Yahoo! Locals
+search API (L<http://dist.schmorp.de/misc/json/long.json>).
+
+ module | encode | decode |
+ -----------|------------|------------|
+ JSON 1.x | 55.260 | 34.971 |
+ JSON::DWIW | 825.228 | 1082.513 |
+ JSON::PC | 3571.444 | 2394.829 |
+ JSON::PP | 210.987 | 32.574 |
+ JSON::Syck | 552.551 | 787.544 |
+ JSON::XS | 5780.463 | 4854.519 |
+ JSON::XS/2 | 3869.998 | 4798.975 |
+ JSON::XS/3 | 5862.880 | 4798.975 |
+ Storable | 4445.002 | 5235.027 |
+ -----------+------------+------------+
+
+Again, JSON::XS leads by far (except for Storable which non-surprisingly
+decodes faster).
+
+On large strings containing lots of high Unicode characters, some modules
+(such as JSON::PC) seem to decode faster than JSON::XS, but the result
+will be broken due to missing (or wrong) Unicode handling. Others refuse
+to decode or encode properly, so it was impossible to prepare a fair
+comparison table for that case.
+
+
+=head1 SECURITY CONSIDERATIONS
+
+When you are using JSON in a protocol, talking to untrusted potentially
+hostile creatures requires relatively few measures.
+
+First of all, your JSON decoder should be secure, that is, should not have
+any buffer overflows. Obviously, this module should ensure that and I am
+trying hard on making that true, but you never know.
+
+Second, you need to avoid resource-starving attacks. That means you should
+limit the size of JSON texts you accept, or make sure then when your
+resources run out, that's just fine (e.g. by using a separate process that
+can crash safely). The size of a JSON text in octets or characters is
+usually a good indication of the size of the resources required to decode
+it into a Perl structure. While JSON::XS can check the size of the JSON
+text, it might be too late when you already have it in memory, so you
+might want to check the size before you accept the string.
+
+Third, JSON::XS recurses using the C stack when decoding objects and
+arrays. The C stack is a limited resource: for instance, on my amd64
+machine with 8MB of stack size I can decode around 180k nested arrays but
+only 14k nested JSON objects (due to perl itself recursing deeply on croak
+to free the temporary). If that is exceeded, the program crashes. To be
+conservative, the default nesting limit is set to 512. If your process
+has a smaller stack, you should adjust this setting accordingly with the
+C<max_depth> method.
+
+Something else could bomb you, too, that I forgot to think of. In that
+case, you get to keep the pieces. I am always open for hints, though...
+
+Also keep in mind that JSON::XS might leak contents of your Perl data
+structures in its error messages, so when you serialise sensitive
+information you might want to make sure that exceptions thrown by JSON::XS
+will not end up in front of untrusted eyes.
+
+If you are using JSON::XS to return packets to consumption
+by JavaScript scripts in a browser you should have a look at
+L<http://jpsykes.com/47/practical-csrf-and-json-security> to see whether
+you are vulnerable to some common attack vectors (which really are browser
+design bugs, but it is still you who will have to deal with it, as major
+browser developers care only for features, not about getting security
+right).
+
+
+=head1 THREADS
+
+This module is I<not> guaranteed to be thread safe and there are no
+plans to change this until Perl gets thread support (as opposed to the
+horribly slow so-called "threads" which are simply slow and bloated
+process simulations - use fork, it's I<much> faster, cheaper, better).
+
+(It might actually work, but you have been warned).
+
+
+=head1 BUGS
+
+While the goal of this module is to be correct, that unfortunately does
+not mean it's bug-free, only that I think its design is bug-free. If you
+keep reporting bugs they will be fixed swiftly, though.
+
+Please refrain from using rt.cpan.org or any other bug reporting
+service. I put the contact address into my modules for a reason.
+
+=cut
+
+our $true = do { bless \(my $dummy = 1), "JSON::XS::Boolean" };
+our $false = do { bless \(my $dummy = 0), "JSON::XS::Boolean" };
+
+sub true() { $true }
+sub false() { $false }
+
+sub is_bool($) {
+ UNIVERSAL::isa $_[0], "JSON::XS::Boolean"
+# or UNIVERSAL::isa $_[0], "JSON::Literal"
+}
+
+XSLoader::load "JSON::XS", $VERSION;
+
+package JSON::XS::Boolean;
+
+use overload
+ "0+" => sub { ${$_[0]} },
+ "++" => sub { $_[0] = ${$_[0]} + 1 },
+ "--" => sub { $_[0] = ${$_[0]} - 1 },
+ fallback => 1;
+
+1;
+
+=head1 SEE ALSO
+
+The F<json_xs> command line utility for quick experiments.
+
+=head1 AUTHOR
+
+ Marc Lehmann <schmorp@schmorp.de>
+ http://home.schmorp.de/
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/JSON/XS/Boolean.pm b/Master/tlpkg/tlperl.straw/lib/JSON/XS/Boolean.pm
new file mode 100755
index 00000000000..4f4e26c19e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/JSON/XS/Boolean.pm
@@ -0,0 +1,26 @@
+=head1 NAME
+
+JSON::XS::Boolean - dummy module providing JSON::XS::Boolean
+
+=head1 SYNOPSIS
+
+ # do not "use" yourself
+
+=head1 DESCRIPTION
+
+This module exists only to provide overload resolution for Storable and similar modules. See
+L<JSON::XS> for more info about this class.
+
+=cut
+
+use JSON::XS ();
+
+1;
+
+=head1 AUTHOR
+
+ Marc Lehmann <schmorp@schmorp.de>
+ http://home.schmorp.de/
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/LWP.pm b/Master/tlpkg/tlperl.straw/lib/LWP.pm
new file mode 100755
index 00000000000..e203d955c99
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/LWP.pm
@@ -0,0 +1,654 @@
+package LWP;
+
+$VERSION = "5.834";
+sub Version { $VERSION; }
+
+require 5.005;
+require LWP::UserAgent; # this should load everything you need
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP - The World-Wide Web library for Perl
+
+=head1 SYNOPSIS
+
+ use LWP;
+ print "This is libwww-perl-$LWP::VERSION\n";
+
+
+=head1 DESCRIPTION
+
+The libwww-perl collection is a set of Perl modules which provides a
+simple and consistent application programming interface (API) to the
+World-Wide Web. The main focus of the library is to provide classes
+and functions that allow you to write WWW clients. The library also
+contain modules that are of more general use and even classes that
+help you implement simple HTTP servers.
+
+Most modules in this library provide an object oriented API. The user
+agent, requests sent and responses received from the WWW server are
+all represented by objects. This makes a simple and powerful
+interface to these services. The interface is easy to extend
+and customize for your own needs.
+
+The main features of the library are:
+
+=over 3
+
+=item *
+
+Contains various reusable components (modules) that can be
+used separately or together.
+
+=item *
+
+Provides an object oriented model of HTTP-style communication. Within
+this framework we currently support access to http, https, gopher, ftp, news,
+file, and mailto resources.
+
+=item *
+
+Provides a full object oriented interface or
+a very simple procedural interface.
+
+=item *
+
+Supports the basic and digest authorization schemes.
+
+=item *
+
+Supports transparent redirect handling.
+
+=item *
+
+Supports access through proxy servers.
+
+=item *
+
+Provides parser for F<robots.txt> files and a framework for constructing robots.
+
+=item *
+
+Supports parsing of HTML forms.
+
+=item *
+
+Implements HTTP content negotiation algorithm that can
+be used both in protocol modules and in server scripts (like CGI
+scripts).
+
+=item *
+
+Supports HTTP cookies.
+
+=item *
+
+Some simple command line clients, for instance C<lwp-request> and C<lwp-download>.
+
+=back
+
+
+=head1 HTTP STYLE COMMUNICATION
+
+
+The libwww-perl library is based on HTTP style communication. This
+section tries to describe what that means.
+
+Let us start with this quote from the HTTP specification document
+<URL:http://www.w3.org/pub/WWW/Protocols/>:
+
+=over 3
+
+=item
+
+The HTTP protocol is based on a request/response paradigm. A client
+establishes a connection with a server and sends a request to the
+server in the form of a request method, URI, and protocol version,
+followed by a MIME-like message containing request modifiers, client
+information, and possible body content. The server responds with a
+status line, including the message's protocol version and a success or
+error code, followed by a MIME-like message containing server
+information, entity meta-information, and possible body content.
+
+=back
+
+What this means to libwww-perl is that communication always take place
+through these steps: First a I<request> object is created and
+configured. This object is then passed to a server and we get a
+I<response> object in return that we can examine. A request is always
+independent of any previous requests, i.e. the service is stateless.
+The same simple model is used for any kind of service we want to
+access.
+
+For example, if we want to fetch a document from a remote file server,
+then we send it a request that contains a name for that document and
+the response will contain the document itself. If we access a search
+engine, then the content of the request will contain the query
+parameters and the response will contain the query result. If we want
+to send a mail message to somebody then we send a request object which
+contains our message to the mail server and the response object will
+contain an acknowledgment that tells us that the message has been
+accepted and will be forwarded to the recipient(s).
+
+It is as simple as that!
+
+
+=head2 The Request Object
+
+The libwww-perl request object has the class name C<HTTP::Request>.
+The fact that the class name uses C<HTTP::> as a
+prefix only implies that we use the HTTP model of communication. It
+does not limit the kind of services we can try to pass this I<request>
+to. For instance, we will send C<HTTP::Request>s both to ftp and
+gopher servers, as well as to the local file system.
+
+The main attributes of the request objects are:
+
+=over 3
+
+=item *
+
+The B<method> is a short string that tells what kind of
+request this is. The most common methods are B<GET>, B<PUT>,
+B<POST> and B<HEAD>.
+
+=item *
+
+The B<uri> is a string denoting the protocol, server and
+the name of the "document" we want to access. The B<uri> might
+also encode various other parameters.
+
+=item *
+
+The B<headers> contain additional information about the
+request and can also used to describe the content. The headers
+are a set of keyword/value pairs.
+
+=item *
+
+The B<content> is an arbitrary amount of data.
+
+=back
+
+=head2 The Response Object
+
+The libwww-perl response object has the class name C<HTTP::Response>.
+The main attributes of objects of this class are:
+
+=over 3
+
+=item *
+
+The B<code> is a numerical value that indicates the overall
+outcome of the request.
+
+=item *
+
+The B<message> is a short, human readable string that
+corresponds to the I<code>.
+
+=item *
+
+The B<headers> contain additional information about the
+response and describe the content.
+
+=item *
+
+The B<content> is an arbitrary amount of data.
+
+=back
+
+Since we don't want to handle all possible I<code> values directly in
+our programs, a libwww-perl response object has methods that can be
+used to query what kind of response this is. The most commonly used
+response classification methods are:
+
+=over 3
+
+=item is_success()
+
+The request was was successfully received, understood or accepted.
+
+=item is_error()
+
+The request failed. The server or the resource might not be
+available, access to the resource might be denied or other things might
+have failed for some reason.
+
+=back
+
+=head2 The User Agent
+
+Let us assume that we have created a I<request> object. What do we
+actually do with it in order to receive a I<response>?
+
+The answer is that you pass it to a I<user agent> object and this
+object takes care of all the things that need to be done
+(like low-level communication and error handling) and returns
+a I<response> object. The user agent represents your
+application on the network and provides you with an interface that
+can accept I<requests> and return I<responses>.
+
+The user agent is an interface layer between
+your application code and the network. Through this interface you are
+able to access the various servers on the network.
+
+The class name for the user agent is C<LWP::UserAgent>. Every
+libwww-perl application that wants to communicate should create at
+least one object of this class. The main method provided by this
+object is request(). This method takes an C<HTTP::Request> object as
+argument and (eventually) returns a C<HTTP::Response> object.
+
+The user agent has many other attributes that let you
+configure how it will interact with the network and with your
+application.
+
+=over 3
+
+=item *
+
+The B<timeout> specifies how much time we give remote servers to
+respond before the library disconnects and creates an
+internal I<timeout> response.
+
+=item *
+
+The B<agent> specifies the name that your application should use when it
+presents itself on the network.
+
+=item *
+
+The B<from> attribute can be set to the e-mail address of the person
+responsible for running the application. If this is set, then the
+address will be sent to the servers with every request.
+
+=item *
+
+The B<parse_head> specifies whether we should initialize response
+headers from the E<lt>head> section of HTML documents.
+
+=item *
+
+The B<proxy> and B<no_proxy> attributes specify if and when to go through
+a proxy server. <URL:http://www.w3.org/pub/WWW/Proxies/>
+
+=item *
+
+The B<credentials> provide a way to set up user names and
+passwords needed to access certain services.
+
+=back
+
+Many applications want even more control over how they interact
+with the network and they get this by sub-classing
+C<LWP::UserAgent>. The library includes a
+sub-class, C<LWP::RobotUA>, for robot applications.
+
+=head2 An Example
+
+This example shows how the user agent, a request and a response are
+represented in actual perl code:
+
+ # Create a user agent object
+ use LWP::UserAgent;
+ my $ua = LWP::UserAgent->new;
+ $ua->agent("MyApp/0.1 ");
+
+ # Create a request
+ my $req = HTTP::Request->new(POST => 'http://search.cpan.org/search');
+ $req->content_type('application/x-www-form-urlencoded');
+ $req->content('query=libwww-perl&mode=dist');
+
+ # Pass request to the user agent and get a response back
+ my $res = $ua->request($req);
+
+ # Check the outcome of the response
+ if ($res->is_success) {
+ print $res->content;
+ }
+ else {
+ print $res->status_line, "\n";
+ }
+
+The $ua is created once when the application starts up. New request
+objects should normally created for each request sent.
+
+
+=head1 NETWORK SUPPORT
+
+This section discusses the various protocol schemes and
+the HTTP style methods that headers may be used for each.
+
+For all requests, a "User-Agent" header is added and initialized from
+the $ua->agent attribute before the request is handed to the network
+layer. In the same way, a "From" header is initialized from the
+$ua->from attribute.
+
+For all responses, the library adds a header called "Client-Date".
+This header holds the time when the response was received by
+your application. The format and semantics of the header are the
+same as the server created "Date" header. You may also encounter other
+"Client-XXX" headers. They are all generated by the library
+internally and are not received from the servers.
+
+=head2 HTTP Requests
+
+HTTP requests are just handed off to an HTTP server and it
+decides what happens. Few servers implement methods beside the usual
+"GET", "HEAD", "POST" and "PUT", but CGI-scripts may implement
+any method they like.
+
+If the server is not available then the library will generate an
+internal error response.
+
+The library automatically adds a "Host" and a "Content-Length" header
+to the HTTP request before it is sent over the network.
+
+For a GET request you might want to add a "If-Modified-Since" or
+"If-None-Match" header to make the request conditional.
+
+For a POST request you should add the "Content-Type" header. When you
+try to emulate HTML E<lt>FORM> handling you should usually let the value
+of the "Content-Type" header be "application/x-www-form-urlencoded".
+See L<lwpcook> for examples of this.
+
+The libwww-perl HTTP implementation currently support the HTTP/1.1
+and HTTP/1.0 protocol.
+
+The library allows you to access proxy server through HTTP. This
+means that you can set up the library to forward all types of request
+through the HTTP protocol module. See L<LWP::UserAgent> for
+documentation of this.
+
+
+=head2 HTTPS Requests
+
+HTTPS requests are HTTP requests over an encrypted network connection
+using the SSL protocol developed by Netscape. Everything about HTTP
+requests above also apply to HTTPS requests. In addition the library
+will add the headers "Client-SSL-Cipher", "Client-SSL-Cert-Subject" and
+"Client-SSL-Cert-Issuer" to the response. These headers denote the
+encryption method used and the name of the server owner.
+
+The request can contain the header "If-SSL-Cert-Subject" in order to
+make the request conditional on the content of the server certificate.
+If the certificate subject does not match, no request is sent to the
+server and an internally generated error response is returned. The
+value of the "If-SSL-Cert-Subject" header is interpreted as a Perl
+regular expression.
+
+
+=head2 FTP Requests
+
+The library currently supports GET, HEAD and PUT requests. GET
+retrieves a file or a directory listing from an FTP server. PUT
+stores a file on a ftp server.
+
+You can specify a ftp account for servers that want this in addition
+to user name and password. This is specified by including an "Account"
+header in the request.
+
+User name/password can be specified using basic authorization or be
+encoded in the URL. Failed logins return an UNAUTHORIZED response with
+"WWW-Authenticate: Basic" and can be treated like basic authorization
+for HTTP.
+
+The library supports ftp ASCII transfer mode by specifying the "type=a"
+parameter in the URL. It also supports transfer of ranges for FTP transfers
+using the "Range" header.
+
+Directory listings are by default returned unprocessed (as returned
+from the ftp server) with the content media type reported to be
+"text/ftp-dir-listing". The C<File::Listing> module provides methods
+for parsing of these directory listing.
+
+The ftp module is also able to convert directory listings to HTML and
+this can be requested via the standard HTTP content negotiation
+mechanisms (add an "Accept: text/html" header in the request if you
+want this).
+
+For normal file retrievals, the "Content-Type" is guessed based on the
+file name suffix. See L<LWP::MediaTypes>.
+
+The "If-Modified-Since" request header works for servers that implement
+the MDTM command. It will probably not work for directory listings though.
+
+Example:
+
+ $req = HTTP::Request->new(GET => 'ftp://me:passwd@ftp.some.where.com/');
+ $req->header(Accept => "text/html, */*;q=0.1");
+
+=head2 News Requests
+
+Access to the USENET News system is implemented through the NNTP
+protocol. The name of the news server is obtained from the
+NNTP_SERVER environment variable and defaults to "news". It is not
+possible to specify the hostname of the NNTP server in news: URLs.
+
+The library supports GET and HEAD to retrieve news articles through the
+NNTP protocol. You can also post articles to newsgroups by using
+(surprise!) the POST method.
+
+GET on newsgroups is not implemented yet.
+
+Examples:
+
+ $req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no');
+
+ $req = HTTP::Request->new(POST => 'news:comp.lang.perl.test');
+ $req->header(Subject => 'This is a test',
+ From => 'me@some.where.org');
+ $req->content(<<EOT);
+ This is the content of the message that we are sending to
+ the world.
+ EOT
+
+
+=head2 Gopher Request
+
+The library supports the GET and HEAD methods for gopher requests. All
+request header values are ignored. HEAD cheats and returns a
+response without even talking to server.
+
+Gopher menus are always converted to HTML.
+
+The response "Content-Type" is generated from the document type
+encoded (as the first letter) in the request URL path itself.
+
+Example:
+
+ $req = HTTP::Request->new(GET => 'gopher://gopher.sn.no/');
+
+
+
+=head2 File Request
+
+The library supports GET and HEAD methods for file requests. The
+"If-Modified-Since" header is supported. All other headers are
+ignored. The I<host> component of the file URL must be empty or set
+to "localhost". Any other I<host> value will be treated as an error.
+
+Directories are always converted to an HTML document. For normal
+files, the "Content-Type" and "Content-Encoding" in the response are
+guessed based on the file suffix.
+
+Example:
+
+ $req = HTTP::Request->new(GET => 'file:/etc/passwd');
+
+
+=head2 Mailto Request
+
+You can send (aka "POST") mail messages using the library. All
+headers specified for the request are passed on to the mail system.
+The "To" header is initialized from the mail address in the URL.
+
+Example:
+
+ $req = HTTP::Request->new(POST => 'mailto:libwww@perl.org');
+ $req->header(Subject => "subscribe");
+ $req->content("Please subscribe me to the libwww-perl mailing list!\n");
+
+=head2 CPAN Requests
+
+URLs with scheme C<cpan:> are redirected to the a suitable CPAN
+mirror. If you have your own local mirror of CPAN you might tell LWP
+to use it for C<cpan:> URLs by an assignment like this:
+
+ $LWP::Protocol::cpan::CPAN = "file:/local/CPAN/";
+
+Suitable CPAN mirrors are also picked up from the configuration for
+the CPAN.pm, so if you have used that module a suitable mirror should
+be picked automatically. If neither of these apply, then a redirect
+to the generic CPAN http location is issued.
+
+Example request to download the newest perl:
+
+ $req = HTTP::Request->new(GET => "cpan:src/latest.tar.gz");
+
+
+=head1 OVERVIEW OF CLASSES AND PACKAGES
+
+This table should give you a quick overview of the classes provided by the
+library. Indentation shows class inheritance.
+
+ LWP::MemberMixin -- Access to member variables of Perl5 classes
+ LWP::UserAgent -- WWW user agent class
+ LWP::RobotUA -- When developing a robot applications
+ LWP::Protocol -- Interface to various protocol schemes
+ LWP::Protocol::http -- http:// access
+ LWP::Protocol::file -- file:// access
+ LWP::Protocol::ftp -- ftp:// access
+ ...
+
+ LWP::Authen::Basic -- Handle 401 and 407 responses
+ LWP::Authen::Digest
+
+ HTTP::Headers -- MIME/RFC822 style header (used by HTTP::Message)
+ HTTP::Message -- HTTP style message
+ HTTP::Request -- HTTP request
+ HTTP::Response -- HTTP response
+ HTTP::Daemon -- A HTTP server class
+
+ WWW::RobotRules -- Parse robots.txt files
+ WWW::RobotRules::AnyDBM_File -- Persistent RobotRules
+
+ Net::HTTP -- Low level HTTP client
+
+The following modules provide various functions and definitions.
+
+ LWP -- This file. Library version number and documentation.
+ LWP::MediaTypes -- MIME types configuration (text/html etc.)
+ LWP::Simple -- Simplified procedural interface for common functions
+ HTTP::Status -- HTTP status code (200 OK etc)
+ HTTP::Date -- Date parsing module for HTTP date formats
+ HTTP::Negotiate -- HTTP content negotiation calculation
+ File::Listing -- Parse directory listings
+ HTML::Form -- Processing for <form>s in HTML documents
+
+
+=head1 MORE DOCUMENTATION
+
+All modules contain detailed information on the interfaces they
+provide. The I<lwpcook> manpage is the libwww-perl cookbook that contain
+examples of typical usage of the library. You might want to take a
+look at how the scripts C<lwp-request>, C<lwp-rget> and C<lwp-mirror>
+are implemented.
+
+=head1 ENVIRONMENT
+
+The following environment variables are used by LWP:
+
+=over
+
+=item HOME
+
+The C<LWP::MediaTypes> functions will look for the F<.media.types> and
+F<.mime.types> files relative to you home directory.
+
+=item http_proxy
+
+=item ftp_proxy
+
+=item xxx_proxy
+
+=item no_proxy
+
+These environment variables can be set to enable communication through
+a proxy server. See the description of the C<env_proxy> method in
+L<LWP::UserAgent>.
+
+=item PERL_LWP_USE_HTTP_10
+
+Enable the old HTTP/1.0 protocol driver instead of the new HTTP/1.1
+driver. You might want to set this to a TRUE value if you discover
+that your old LWP applications fails after you installed LWP-5.60 or
+better.
+
+=item PERL_HTTP_URI_CLASS
+
+Used to decide what URI objects to instantiate. The default is C<URI>.
+You might want to set it to C<URI::URL> for compatibility with old times.
+
+=back
+
+=head1 AUTHORS
+
+LWP was made possible by contributions from Adam Newby, Albert
+Dvornik, Alexandre Duret-Lutz, Andreas Gustafsson, Andreas König,
+Andrew Pimlott, Andy Lester, Ben Coleman, Benjamin Low, Ben Low, Ben
+Tilly, Blair Zajac, Bob Dalgleish, BooK, Brad Hughes, Brian
+J. Murrell, Brian McCauley, Charles C. Fu, Charles Lane, Chris Nandor,
+Christian Gilmore, Chris W. Unger, Craig Macdonald, Dale Couch, Dan
+Kubb, Dave Dunkin, Dave W. Smith, David Coppit, David Dick, David
+D. Kilzer, Doug MacEachern, Edward Avis, erik, Gary Shea, Gisle Aas,
+Graham Barr, Gurusamy Sarathy, Hans de Graaff, Harald Joerg, Harry
+Bochner, Hugo, Ilya Zakharevich, INOUE Yoshinari, Ivan Panchenko, Jack
+Shirazi, James Tillman, Jan Dubois, Jared Rhine, Jim Stern, Joao
+Lopes, John Klar, Johnny Lee, Josh Kronengold, Josh Rai, Joshua
+Chamas, Joshua Hoblitt, Kartik Subbarao, Keiichiro Nagano, Ken
+Williams, KONISHI Katsuhiro, Lee T Lindley, Liam Quinn, Marc Hedlund,
+Marc Langheinrich, Mark D. Anderson, Marko Asplund, Mark Stosberg,
+Markus B Krüger, Markus Laker, Martijn Koster, Martin Thurn, Matthew
+Eldridge, Matthew.van.Eerde, Matt Sergeant, Michael A. Chase, Michael
+Quaranta, Michael Thompson, Mike Schilli, Moshe Kaminsky, Nathan
+Torkington, Nicolai Langfeldt, Norton Allen, Olly Betts, Paul
+J. Schinder, peterm, Philip GuentherDaniel Buenzli, Pon Hwa Lin,
+Radoslaw Zielinski, Radu Greab, Randal L. Schwartz, Richard Chen,
+Robin Barker, Roy Fielding, Sander van Zoest, Sean M. Burke,
+shildreth, Slaven Rezic, Steve A Fink, Steve Hay, Steven Butler,
+Steve_Kilbane, Takanori Ugai, Thomas Lotterer, Tim Bunce, Tom Hughes,
+Tony Finch, Ville Skyttä, Ward Vandewege, William York, Yale Huang,
+and Yitzchak Scott-Thoennes.
+
+LWP owes a lot in motivation, design, and code, to the libwww-perl
+library for Perl4 by Roy Fielding, which included work from Alberto
+Accomazzi, James Casey, Brooks Cutter, Martijn Koster, Oscar
+Nierstrasz, Mel Melchner, Gertjan van Oosten, Jared Rhine, Jack
+Shirazi, Gene Spafford, Marc VanHeyningen, Steven E. Brenner, Marion
+Hakanson, Waldemar Kebsch, Tony Sanders, and Larry Wall; see the
+libwww-perl-0.40 library for details.
+
+=head1 COPYRIGHT
+
+ Copyright 1995-2009, Gisle Aas
+ Copyright 1995, Martijn Koster
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AVAILABILITY
+
+The latest version of this library is likely to be available from CPAN
+as well as:
+
+ http://gitorious.org/projects/libwww-perl
+
+The best place to discuss this code is on the <libwww@perl.org>
+mailing list.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Log/Message.pm b/Master/tlpkg/tlperl.straw/lib/Log/Message.pm
new file mode 100755
index 00000000000..3b2f43e57da
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Log/Message.pm
@@ -0,0 +1,600 @@
+package Log::Message;
+
+use strict;
+
+use Params::Check qw[check];
+use Log::Message::Item;
+use Log::Message::Config;
+use Locale::Maketext::Simple Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+BEGIN {
+ use vars qw[$VERSION @ISA $STACK $CONFIG];
+
+ $VERSION = 0.02;
+
+ $STACK = [];
+}
+
+
+=pod
+
+=head1 NAME
+
+Log::Message - A generic message storing mechanism;
+
+=head1 SYNOPSIS
+
+ use Log::Message private => 0, config => '/our/cf_file';
+
+ my $log = Log::Message->new( private => 1,
+ level => 'log',
+ config => '/my/cf_file',
+ );
+
+ $log->store('this is my first message');
+
+ $log->store( message => 'message #2',
+ tag => 'MY_TAG',
+ level => 'carp',
+ extra => ['this is an argument to the handler'],
+ );
+
+ my @last_five_items = $log->retrieve(5);
+
+ my @items = $log->retrieve( tag => qr/my_tag/i,
+ message => qr/\d/,
+ remove => 1,
+ );
+
+ my @items = $log->final( level => qr/carp/, amount => 2 );
+
+ my $first_error = $log->first()
+
+ # croak with the last error on the stack
+ $log->final->croak;
+
+ # empty the stack
+ $log->flush();
+
+
+=head1 DESCRIPTION
+
+Log::Message is a generic message storage mechanism.
+It allows you to store messages on a stack -- either shared or private
+-- and assign meta-data to it.
+Some meta-data will automatically be added for you, like a timestamp
+and a stack trace, but some can be filled in by the user, like a tag
+by which to identify it or group it, and a level at which to handle
+the message (for example, log it, or die with it)
+
+Log::Message also provides a powerful way of searching through items
+by regexes on messages, tags and level.
+
+=head1 Hierarchy
+
+There are 4 modules of interest when dealing with the Log::Message::*
+modules:
+
+=over 4
+
+=item Log::Message
+
+Log::Message provides a few methods to manipulate the stack it keeps.
+It has the option of keeping either a private or a public stack.
+More on this below.
+
+=item Log::Message::Item
+
+These are individual message items, which are objects that contain
+the user message as well as the meta-data described above.
+See the L<Log::Message::Item> manpage to see how to extract this
+meta-data and how to work with the Item objects.
+You should never need to create your own Item objects, but knowing
+about their methods and accessors is important if you want to write
+your own handlers. (See below)
+
+=item Log::Message::Handlers
+
+These are a collection of handlers that will be called for a level
+that is used on a L<Log::Message::Item> object.
+For example, if a message is logged with the 'carp' level, the 'carp'
+handler from L<Log::Message::Handlers> will be called.
+See the L<Log::Message::Handlers> manpage for more explanation about how
+handlers work, which one are available and how to create your own.
+
+=item Log::Message::Config
+
+Per Log::Message object, there is a configuration required that will
+fill in defaults if the user did not specify arguments to override
+them (like for example what tag will be set if none was provided),
+L<Log::Message::Config> handles the creation of these configurations.
+
+Configuration can be specified in 4 ways:
+
+=over 4
+
+=item *
+
+As a configuration file when you C<use Log::Message>
+
+=item *
+
+As arguments when you C<use Log::Message>
+
+=item *
+
+As a configuration file when you create a new L<Log::Message> object.
+(The config will then only apply to that object if you marked it as
+private)
+
+=item *
+
+As arguments when you create a new Log::Message object.
+
+You should never need to use the L<Log::Message::Config> module yourself,
+as this is transparently done by L<Log::Message>, but its manpage does
+provide an explanation of how you can create a config file.
+
+=back
+
+=back
+
+=head1 Options
+
+When using Log::Message, or creating a new Log::Message object, you can
+supply various options to alter its behaviour.
+Of course, there are sensible defaults should you choose to omit these
+options.
+
+Below an explanation of all the options and how they work.
+
+=over 4
+
+=item config
+
+The path to a configuration file to be read.
+See the manpage of L<Log::Message::Config> for the required format
+
+These options will be overridden by any explicit arguments passed.
+
+=item private
+
+Whether to create, by default, private or shared objects.
+If you choose to create shared objects, all Log::Message objects will
+use the same stack.
+
+This means that even though every module may make its own $log object
+they will still be sharing the same error stack on which they are
+putting errors and from which they are retrieving.
+
+This can be useful in big projects.
+
+If you choose to create a private object, then the stack will of
+course be private to this object, but it will still fall back to the
+shared config should no private config or overriding arguments be
+provided.
+
+=item verbose
+
+Log::Message makes use of another module to validate its arguments,
+which is called L<Params::Check>, which is a lightweight, yet
+powerful input checker and parser. (See the L<Params::Check>
+manpage for details).
+
+The verbose setting will control whether this module will
+generate warnings if something improper is passed as input, or merely
+silently returns undef, at which point Log::Message will generate a
+warning.
+
+It's best to just leave this at its default value, which is '1'
+
+=item tag
+
+The tag to add to messages if none was provided. If neither your
+config, nor any specific arguments supply a tag, then Log::Message will
+set it to 'NONE'
+
+Tags are useful for searching on or grouping by. For example, you
+could tag all the messages you want to go to the user as 'USER ERROR'
+and all those that are only debug information with 'DEBUG'.
+
+At the end of your program, you could then print all the ones tagged
+'USER ERROR' to STDOUT, and those marked 'DEBUG' to a log file.
+
+=item level
+
+C<level> describes what action to take when a message is logged. Just
+like C<tag>, Log::Message will provide a default (which is 'log') if
+neither your config file, nor any explicit arguments are given to
+override it.
+
+See the Log::Message::Handlers manpage to see what handlers are
+available by default and what they do, as well as to how to add your
+own handlers.
+
+=item remove
+
+This indicates whether or not to automatically remove the messages
+from the stack when you've retrieved them.
+The default setting provided by Log::Message is '0': do not remove.
+
+=item chrono
+
+This indicates whether messages should always be fetched in
+chronological order or not.
+This simply means that you can choose whether, when retrieving items,
+the item most recently added should be returned first, or the one that
+had been added most long ago.
+
+The default is to return the newest ones first
+
+=back
+
+=cut
+
+
+### subs ###
+sub import {
+ my $pkg = shift;
+ my %hash = @_;
+
+ $CONFIG = new Log::Message::Config( %hash )
+ or die loc(qq[Problem initialising %1], __PACKAGE__);
+
+}
+
+=head1 Methods
+
+=head2 new
+
+This creates a new Log::Message object; The parameters it takes are
+described in the C<Options> section below and let it just be repeated
+that you can use these options like this:
+
+ my $log = Log::Message->new( %options );
+
+as well as during C<use> time, like this:
+
+ use Log::Message option1 => value, option2 => value
+
+There are but 3 rules to keep in mind:
+
+=over 4
+
+=item *
+
+Provided arguments take precedence over a configuration file.
+
+=item *
+
+Arguments to new take precedence over options provided at C<use> time
+
+=item *
+
+An object marked private will always have an empty stack to begin with
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my $conf = new Log::Message::Config( %hash, default => $CONFIG ) or return undef;
+
+ if( $conf->private || $CONFIG->private ) {
+
+ return _new_stack( $class, config => $conf );
+
+ } else {
+ my $obj = _new_stack( $class, config => $conf, stack => $STACK );
+
+ ### if it was an empty stack, this was the first object
+ ### in that case, set the global stack to match it for
+ ### subsequent new, non-private objects
+ $STACK = $obj->{STACK} unless scalar @$STACK;
+
+ return $obj;
+ }
+}
+
+sub _new_stack {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ stack => { default => [] },
+ config => { default => bless( {}, 'Log::Message::Config'),
+ required => 1,
+ strict_type => 1
+ },
+ };
+
+ my $args = check( $tmpl, \%hash, $CONFIG->verbose ) or (
+ warn(loc(q[Could not create a new stack object: %1],
+ Params::Check->last_error)
+ ),
+ return
+ );
+
+
+ my %self = map { uc, $args->{$_} } keys %$args;
+
+ return bless \%self, $class;
+}
+
+sub _get_conf {
+ my $self = shift;
+ my $what = shift;
+
+ return defined $self->{CONFIG}->$what()
+ ? $self->{CONFIG}->$what()
+ : defined $CONFIG->$what()
+ ? $CONFIG->$what()
+ : undef; # should never get here
+}
+
+=head2 store
+
+This will create a new Item object and store it on the stack.
+
+Possible arguments you can give to it are:
+
+=over 4
+
+=item message
+
+This is the only argument that is required. If no other arguments
+are given, you may even leave off the C<message> key. The argument
+will then automatically be assumed to be the message.
+
+=item tag
+
+The tag to add to this message. If not provided, Log::Message will look
+in your configuration for one.
+
+=item level
+
+The level at which this message should be handled. If not provided,
+Log::Message will look in your configuration for one.
+
+=item extra
+
+This is an array ref with arguments passed to the handler for this
+message, when it is called from store();
+
+The handler will receive them as a normal list
+
+=back
+
+store() will return true upon success and undef upon failure, as well
+as issue a warning as to why it failed.
+
+=cut
+
+### should extra be stored in the item object perhaps for later retrieval?
+sub store {
+ my $self = shift;
+ my %hash = ();
+
+ my $tmpl = {
+ message => {
+ default => '',
+ strict_type => 1,
+ required => 1,
+ },
+ tag => { default => $self->_get_conf('tag') },
+ level => { default => $self->_get_conf('level'), },
+ extra => { default => [], strict_type => 1 },
+ };
+
+ ### single arg means just the message
+ ### otherwise, they are named
+ if( @_ == 1 ) {
+ $hash{message} = shift;
+ } else {
+ %hash = @_;
+ }
+
+ my $args = check( $tmpl, \%hash ) or (
+ warn( loc(q[Could not store error: %1], Params::Check->last_error) ),
+ return
+ );
+
+ my $extra = delete $args->{extra};
+ my $item = Log::Message::Item->new( %$args,
+ parent => $self,
+ id => scalar @{$self->{STACK}}
+ )
+ or ( warn( loc(q[Could not create new log item!]) ), return undef );
+
+ push @{$self->{STACK}}, $item;
+
+ { no strict 'refs';
+
+ my $sub = $args->{level};
+
+ $item->$sub( @$extra );
+ }
+
+ return 1;
+}
+
+=head2 retrieve
+
+This will retrieve all message items matching the criteria specified
+from the stack.
+
+Here are the criteria you can discriminate on:
+
+=over 4
+
+=item tag
+
+A regex to which the tag must adhere. For example C<qr/\w/>.
+
+=item level
+
+A regex to which the level must adhere.
+
+=item message
+
+A regex to which the message must adhere.
+
+=item amount
+
+Maximum amount of errors to return
+
+=item chrono
+
+Return in chronological order, or not?
+
+=item remove
+
+Remove items from the stack upon retrieval?
+
+=back
+
+In scalar context it will return the first item matching your criteria
+and in list context, it will return all of them.
+
+If an error occurs while retrieving, a warning will be issued and
+undef will be returned.
+
+=cut
+
+sub retrieve {
+ my $self = shift;
+ my %hash = ();
+
+ my $tmpl = {
+ tag => { default => qr/.*/ },
+ level => { default => qr/.*/ },
+ message => { default => qr/.*/ },
+ amount => { default => '' },
+ remove => { default => $self->_get_conf('remove') },
+ chrono => { default => $self->_get_conf('chrono') },
+ };
+
+ ### single arg means just the amount
+ ### otherwise, they are named
+ if( @_ == 1 ) {
+ $hash{amount} = shift;
+ } else {
+ %hash = @_;
+ }
+
+ my $args = check( $tmpl, \%hash ) or (
+ warn( loc(q[Could not parse input: %1], Params::Check->last_error) ),
+ return
+ );
+
+ my @list =
+ grep { $_->tag =~ /$args->{tag}/ ? 1 : 0 }
+ grep { $_->level =~ /$args->{level}/ ? 1 : 0 }
+ grep { $_->message =~ /$args->{message}/ ? 1 : 0 }
+ grep { defined }
+ $args->{chrono}
+ ? @{$self->{STACK}}
+ : reverse @{$self->{STACK}};
+
+ my $amount = $args->{amount} || scalar @list;
+
+ my @rv = map {
+ $args->{remove} ? $_->remove : $_
+ } scalar @list > $amount
+ ? splice(@list,0,$amount)
+ : @list;
+
+ return wantarray ? @rv : $rv[0];
+}
+
+=head2 first
+
+This is a shortcut for retrieving the first item(s) stored on the
+stack. It will default to only retrieving one if called with no
+arguments, and will always return results in chronological order.
+
+If you only supply one argument, it is assumed to be the amount you
+wish returned.
+
+Furthermore, it can take the same arguments as C<retrieve> can.
+
+=cut
+
+sub first {
+ my $self = shift;
+
+ my $amt = @_ == 1 ? shift : 1;
+ return $self->retrieve( amount => $amt, @_, chrono => 1 );
+}
+
+=head2 last
+
+This is a shortcut for retrieving the last item(s) stored on the
+stack. It will default to only retrieving one if called with no
+arguments, and will always return results in reverse chronological
+order.
+
+If you only supply one argument, it is assumed to be the amount you
+wish returned.
+
+Furthermore, it can take the same arguments as C<retrieve> can.
+
+=cut
+
+sub final {
+ my $self = shift;
+
+ my $amt = @_ == 1 ? shift : 1;
+ return $self->retrieve( amount => $amt, @_, chrono => 0 );
+}
+
+=head2 flush
+
+This removes all items from the stack and returns them to the caller
+
+=cut
+
+sub flush {
+ my $self = shift;
+
+ return splice @{$self->{STACK}};
+}
+
+=head1 SEE ALSO
+
+L<Log::Message::Item>, L<Log::Message::Handlers>, L<Log::Message::Config>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/Log/Message/Config.pm b/Master/tlpkg/tlperl.straw/lib/Log/Message/Config.pm
new file mode 100755
index 00000000000..9769119ed32
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Log/Message/Config.pm
@@ -0,0 +1,197 @@
+package Log::Message::Config;
+use strict;
+
+use Params::Check qw[check];
+use Module::Load;
+use FileHandle;
+use Locale::Maketext::Simple Style => 'gettext';
+
+BEGIN {
+ use vars qw[$VERSION $AUTOLOAD];
+ $VERSION = 0.01;
+}
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ ### find out if the user specified a config file to use
+ ### and/or a default configuration object
+ ### and remove them from the argument hash
+ my %special = map { lc, delete $hash{$_} }
+ grep /^config|default$/i, keys %hash;
+
+ ### allow provided arguments to override the values from the config ###
+ my $tmpl = {
+ private => { default => undef, },
+ verbose => { default => 1 },
+ tag => { default => 'NONE', },
+ level => { default => 'log', },
+ remove => { default => 0 },
+ chrono => { default => 1 },
+ };
+
+ my %lc_hash = map { lc, $hash{$_} } keys %hash;
+
+ my $file_conf;
+ if( $special{config} ) {
+ $file_conf = _read_config_file( $special{config} )
+ or ( warn( loc(q[Could not parse config file!]) ), return );
+ }
+
+ my $def_conf = \%{ $special{default} || {} };
+
+ ### make sure to only include keys that are actually defined --
+ ### the checker will assign even 'undef' if you have provided that
+ ### as a value
+ ### priorities goes as follows:
+ ### 1: arguments passed
+ ### 2: any config file passed
+ ### 3: any default config passed
+ my %to_check = map { @$_ }
+ grep { defined $_->[1] }
+ map { [ $_ =>
+ defined $lc_hash{$_} ? $lc_hash{$_} :
+ defined $file_conf->{$_} ? $file_conf->{$_} :
+ defined $def_conf->{$_} ? $def_conf->{$_} :
+ undef
+ ]
+ } keys %$tmpl;
+
+ my $rv = check( $tmpl, \%to_check, 1 )
+ or ( warn( loc(q[Could not validate arguments!]) ), return );
+
+ return bless $rv, $class;
+}
+
+sub _read_config_file {
+ my $file = shift or return;
+
+ my $conf = {};
+ my $FH = new FileHandle;
+ $FH->open("$file") or (
+ warn(loc(q[Could not open config file '%1': %2],$file,$!)),
+ return {}
+ );
+
+ while(<$FH>) {
+ next if /\s*#/;
+ next unless /\S/;
+
+ chomp; s/^\s*//; s/\s*$//;
+
+ my ($param,$val) = split /\s*=\s*/;
+
+ if( (lc $param) eq 'include' ) {
+ load $val;
+ next;
+ }
+
+ ### add these to the config hash ###
+ $conf->{ lc $param } = $val;
+ }
+ close $FH;
+
+ return $conf;
+}
+
+sub AUTOLOAD {
+ $AUTOLOAD =~ s/.+:://;
+
+ my $self = shift;
+
+ return $self->{ lc $AUTOLOAD } if exists $self->{ lc $AUTOLOAD };
+
+ die loc(q[No such accessor '%1' for class '%2'], $AUTOLOAD, ref $self);
+}
+
+sub DESTROY { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Log::Message::Config - Configuration options for Log::Message
+
+=head1 SYNOPSIS
+
+ # This module is implicitly used by Log::Message to create a config
+ # which it uses to log messages.
+ # For the options you can pass, see the C<Log::Message new()> method.
+
+ # Below is a sample of a config file you could use
+
+ # comments are denoted by a single '#'
+ # use a shared stack, or have a private instance?
+ # if none provided, set to '0',
+ private = 1
+
+ # do not be verbose
+ verbose = 0
+
+ # default tag to set on new items
+ # if none provided, set to 'NONE'
+ tag = SOME TAG
+
+ # default level to handle items
+ # if none provided, set to 'log'
+ level = carp
+
+ # extra files to include
+ # if none provided, no files are auto included
+ include = mylib.pl
+ include = ../my/other/lib.pl
+
+ # automatically delete items
+ # when you retrieve them from the stack?
+ # if none provided, set to '0'
+ remove = 1
+
+ # retrieve errors in chronological order, or not?
+ # if none provided, set to '1'
+ chrono = 0
+
+=head1 DESCRIPTION
+
+Log::Message::Config provides a standardized config object for
+Log::Message objects.
+
+It can either read options as perl arguments, or as a config file.
+See the Log::Message manpage for more information about what arguments
+are valid, and see the Synopsis for an example config file you can use
+
+=head1 SEE ALSO
+
+L<Log::Message>, L<Log::Message::Item>, L<Log::Message::Handlers>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/Log/Message/Handlers.pm b/Master/tlpkg/tlperl.straw/lib/Log/Message/Handlers.pm
new file mode 100755
index 00000000000..c7c35c6e389
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Log/Message/Handlers.pm
@@ -0,0 +1,191 @@
+package Log::Message::Handlers;
+use strict;
+
+=pod
+
+=head1 NAME
+
+Log::Message::Handlers - Message handlers for Log::Message
+
+=head1 SYNOPSIS
+
+ # Implicitly used by Log::Message to serve as handlers for
+ # Log::Message::Item objects
+
+ # Create your own file with a package called
+ # Log::Message::Handlers to add to the existing ones, or to even
+ # overwrite them
+
+ $item->carp;
+
+ $item->trace;
+
+
+=head1 DESCRIPTION
+
+Log::Message::Handlers provides handlers for Log::Message::Item objects.
+The handler corresponding to the level (see Log::Message::Item manpage
+for an explanation about levels) will be called automatically upon
+storing the error.
+
+Handlers may also explicitly be called on an Log::Message::Item object
+if one so desires (see the Log::Message manpage on how to retrieve the
+Item objects).
+
+=head1 Default Handlers
+
+=head2 log
+
+Will simply log the error on the stack, and do nothing special
+
+=cut
+
+sub log { 1 }
+
+=head2 carp
+
+Will carp (see the Carp manpage) with the error, and add the timestamp
+of when it occurred.
+
+=cut
+
+sub carp {
+ my $self = shift;
+ warn join " ", $self->message, $self->shortmess, 'at', $self->when, "\n";
+}
+
+=head2 croak
+
+Will croak (see the Carp manpage) with the error, and add the
+timestamp of when it occurred.
+
+=cut
+
+sub croak {
+ my $self = shift;
+ die join " ", $self->message, $self->shortmess, 'at', $self->when, "\n";
+}
+
+=head2 cluck
+
+Will cluck (see the Carp manpage) with the error, and add the
+timestamp of when it occurred.
+
+=cut
+
+sub cluck {
+ my $self = shift;
+ warn join " ", $self->message, $self->longmess, 'at', $self->when, "\n";
+}
+
+=head2 confess
+
+Will confess (see the Carp manpage) with the error, and add the
+timestamp of when it occurred
+
+=cut
+
+sub confess {
+ my $self = shift;
+ die join " ", $self->message, $self->longmess, 'at', $self->when, "\n";
+}
+
+=head2 die
+
+Will simply die with the error message of the item
+
+=cut
+
+sub die { die shift->message; }
+
+
+=head2 warn
+
+Will simply warn with the error message of the item
+
+=cut
+
+sub warn { warn shift->message; }
+
+
+=head2 trace
+
+Will provide a traceback of this error item back to the first one that
+occurrent, clucking with every item as it comes across it.
+
+=cut
+
+sub trace {
+ my $self = shift;
+
+ for my $item( $self->parent->retrieve( chrono => 0 ) ) {
+ $item->cluck;
+ }
+}
+
+=head1 Custom Handlers
+
+If you wish to provide your own handlers, you can simply do the
+following:
+
+=over 4
+
+=item *
+
+Create a file that holds a package by the name of
+C<Log::Message::Handlers>
+
+=item *
+
+Create subroutines with the same name as the levels you wish to
+handle in the Log::Message module (see the Log::Message manpage for
+explanation on levels)
+
+=item *
+
+Require that file in your program, or add it in your configuration
+(see the Log::Message::Config manpage for explanation on how to use a
+config file)
+
+=back
+
+And that is it, the handler will now be available to handle messages
+for you.
+
+The arguments a handler may receive are those specified by the
+C<extra> key, when storing the message.
+See the Log::Message manpage for details on the arguments.
+
+=head1 SEE ALSO
+
+L<Log::Message>, L<Log::Message::Item>, L<Log::Message::Config>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/Log/Message/Item.pm b/Master/tlpkg/tlperl.straw/lib/Log/Message/Item.pm
new file mode 100755
index 00000000000..85ae6fc6003
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Log/Message/Item.pm
@@ -0,0 +1,192 @@
+package Log::Message::Item;
+
+use strict;
+use Params::Check qw[check];
+use Log::Message::Handlers;
+
+### for the messages to store ###
+use Carp ();
+
+BEGIN {
+ use vars qw[$AUTOLOAD $VERSION];
+
+ $VERSION = $Log::Message::VERSION;
+}
+
+### create a new item.
+### note that only an id (position on the stack), message and a reference
+### to its parent are required. all the other things it can fill in itself
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ when => { no_override => 1, default => scalar localtime },
+ id => { required => 1 },
+ message => { required => 1 },
+ parent => { required => 1 },
+ level => { default => '' }, # default may be conf dependant
+ tag => { default => '' }, # default may be conf dependant
+ longmess => { default => _clean(Carp::longmess()) },
+ shortmess => { default => _clean(Carp::shortmess())},
+ };
+
+ my $args = check($tmpl, \%hash) or return undef;
+
+ return bless $args, $class;
+}
+
+sub _clean { map { s/\s*//; chomp; $_ } shift; }
+
+sub remove {
+ my $item = shift;
+ my $self = $item->parent;
+
+ return splice( @{$self->{STACK}}, $item->id, 1, undef );
+}
+
+sub AUTOLOAD {
+ my $self = $_[0];
+
+ $AUTOLOAD =~ s/.+:://;
+
+ return $self->{$AUTOLOAD} if exists $self->{$AUTOLOAD};
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 3;
+
+ { no strict 'refs';
+ return *{"Log::Message::Handlers::${AUTOLOAD}"}->(@_);
+ }
+}
+
+sub DESTROY { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Log::Message::Item - Message objects for Log::Message
+
+=head1 SYNOPSIS
+
+ # Implicitly used by Log::Message to create Log::Message::Item objects
+
+ print "this is the message's id: ", $item->id;
+
+ print "this is the message stored: ", $item->message;
+
+ print "this is when it happened: ", $item->when;
+
+ print "the message was tagged: ", $item->tag;
+
+ print "this was the severity level: ", $item->level;
+
+ $item->remove; # delete the item from the stack it was on
+
+ # Besides these methods, you can also call the handlers on
+ # the object specificallly.
+ # See the Log::Message::Handlers manpage for documentation on what
+ # handlers are available by default and how to add your own
+
+
+=head1 DESCRIPTION
+
+Log::Message::Item is a class that generates generic Log items.
+These items are stored on a Log::Message stack, so see the Log::Message
+manpage about details how to retrieve them.
+
+You should probably not create new items by yourself, but use the
+storing mechanism provided by Log::Message.
+
+However, the accessors and handlers are of interest if you want to do
+fine tuning of how your messages are handled.
+
+The accessors and methods are described below, the handlers are
+documented in the Log::Message::Handlers manpage.
+
+=head1 Methods and Accessors
+
+=head2 remove
+
+Calling remove will remove the object from the stack it was on, so it
+will not show up any more in subsequent fetches of messages.
+
+You can still call accessors and handlers on it however, to handle it
+as you will.
+
+=head2 id
+
+Returns the internal ID of the item. This may be useful for comparing
+since the ID is incremented each time a new item is created.
+Therefore, an item with ID 4 must have been logged before an item with
+ID 9.
+
+=head2 when
+
+Returns the timestamp of when the message was logged
+
+=head2 message
+
+The actual message that was stored
+
+=head2 level
+
+The severity type of this message, as well as the name of the handler
+that was called upon storing it.
+
+=head2 tag
+
+Returns the identification tag that was put on the message.
+
+=head2 shortmess
+
+Returns the equivalent of a C<Carp::shortmess> for this item.
+See the C<Carp> manpage for details.
+
+=head2 longmess
+
+Returns the equivalent of a C<Carp::longmess> for this item, which
+is essentially a stack trace.
+See the C<Carp> manpage for details.
+
+=head2 parent
+
+Returns a reference to the Log::Message object that stored this item.
+This is useful if you want to have access to the full stack in a
+handler.
+
+=head1 SEE ALSO
+
+L<Log::Message>, L<Log::Message::Handlers>, L<Log::Message::Config>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/Log/Message/Simple.pm b/Master/tlpkg/tlperl.straw/lib/Log/Message/Simple.pm
new file mode 100755
index 00000000000..18790365fdf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Log/Message/Simple.pm
@@ -0,0 +1,293 @@
+package Log::Message::Simple;
+
+use strict;
+use Log::Message private => 0;;
+
+BEGIN {
+ use vars qw[$VERSION];
+ $VERSION = 0.06;
+}
+
+
+=pod
+
+=head1 NAME
+
+Log::Message::Simple - Simplified interface to Log::Message
+
+=head1 SYNOPSIS
+
+ use Log::Message::Simple qw[msg error debug
+ carp croak cluck confess];
+
+ use Log::Message::Simple qw[:STD :CARP];
+
+ ### standard reporting functionality
+ msg( "Connecting to database", $verbose );
+ error( "Database connection failed: $@", $verbose );
+ debug( "Connection arguments were: $args", $debug );
+
+ ### standard carp functionality
+ carp( "Wrong arguments passed: @_" );
+ croak( "Fatal: wrong arguments passed: @_" );
+ cluck( "Wrong arguments passed -- including stacktrace: @_" );
+ confess("Fatal: wrong arguments passed -- including stacktrace: @_" );
+
+ ### retrieve individual message
+ my @stack = Log::Message::Simple->stack;
+ my @stack = Log::Message::Simple->flush;
+
+ ### retrieve the entire stack in printable form
+ my $msgs = Log::Message::Simple->stack_as_string;
+ my $trace = Log::Message::Simple->stack_as_string(1);
+
+ ### redirect output
+ local $Log::Message::Simple::MSG_FH = \*STDERR;
+ local $Log::Message::Simple::ERROR_FH = \*STDERR;
+ local $Log::Message::Simple::DEBUG_FH = \*STDERR;
+
+ ### force a stacktrace on error
+ local $Log::Message::Simple::STACKTRACE_ON_ERROR = 1
+
+=head1 DESCRIPTION
+
+This module provides standardized logging facilities using the
+C<Log::Message> module.
+
+=head1 FUNCTIONS
+
+=head2 msg("message string" [,VERBOSE])
+
+Records a message on the stack, and prints it to C<STDOUT> (or actually
+C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+Exported by default, or using the C<:STD> tag.
+
+=head2 debug("message string" [,VERBOSE])
+
+Records a debug message on the stack, and prints it to C<STDOUT> (or
+actually C<$DEBUG_FH>, see the C<GLOBAL VARIABLES> section below),
+if the C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+Exported by default, or using the C<:STD> tag.
+
+=head2 error("error string" [,VERBOSE])
+
+Records an error on the stack, and prints it to C<STDERR> (or actually
+C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> options defaults to true.
+
+Exported by default, or using the C<:STD> tag.
+
+=cut
+
+{ package Log::Message::Handlers;
+
+ sub msg {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### so you don't want us to print the msg? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $Log::Message::Simple::MSG_FH;
+ print '['. $self->tag (). '] ' . $self->message . "\n";
+ select $old_fh;
+
+ return;
+ }
+
+ sub debug {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### so you don't want us to print the msg? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $Log::Message::Simple::DEBUG_FH;
+ print '['. $self->tag (). '] ' . $self->message . "\n";
+ select $old_fh;
+
+ return;
+ }
+
+ sub error {
+ my $self = shift;
+ my $verbose = shift;
+ $verbose = 1 unless defined $verbose; # default to true
+
+ ### so you don't want us to print the error? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $Log::Message::Simple::ERROR_FH;
+
+ my $msg = '['. $self->tag . '] ' . $self->message;
+
+ print $Log::Message::Simple::STACKTRACE_ON_ERROR
+ ? Carp::shortmess($msg)
+ : $msg . "\n";
+
+ select $old_fh;
+
+ return;
+ }
+}
+
+=head2 carp();
+
+Provides functionality equal to C<Carp::carp()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head2 croak();
+
+Provides functionality equal to C<Carp::croak()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head2 confess();
+
+Provides functionality equal to C<Carp::confess()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head2 cluck();
+
+Provides functionality equal to C<Carp::cluck()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head1 CLASS METHODS
+
+=head2 Log::Message::Simple->stack()
+
+Retrieves all the items on the stack. Since C<Log::Message::Simple> is
+implemented using C<Log::Message>, consult its manpage for the
+function C<retrieve> to see what is returned and how to use the items.
+
+=head2 Log::Message::Simple->stack_as_string([TRACE])
+
+Returns the whole stack as a printable string. If the C<TRACE> option is
+true all items are returned with C<Carp::longmess> output, rather than
+just the message.
+C<TRACE> defaults to false.
+
+=head2 Log::Message::Simple->flush()
+
+Removes all the items from the stack and returns them. Since
+C<Log::Message::Simple> is implemented using C<Log::Message>, consult its
+manpage for the function C<retrieve> to see what is returned and how
+to use the items.
+
+=cut
+
+BEGIN {
+ use Exporter;
+ use Params::Check qw[ check ];
+ use vars qw[ @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA ];;
+
+ @ISA = 'Exporter';
+ @EXPORT = qw[error msg debug];
+ @EXPORT_OK = qw[carp cluck croak confess];
+
+ %EXPORT_TAGS = (
+ STD => \@EXPORT,
+ CARP => \@EXPORT_OK,
+ ALL => [ @EXPORT, @EXPORT_OK ],
+ );
+
+ my $log = new Log::Message;
+
+ for my $func ( @EXPORT, @EXPORT_OK ) {
+ no strict 'refs';
+
+ ### up the carplevel for the carp emulation
+ ### functions
+ *$func = sub { local $Carp::CarpLevel += 2
+ if grep { $_ eq $func } @EXPORT_OK;
+
+ my $msg = shift;
+ $log->store(
+ message => $msg,
+ tag => uc $func,
+ level => $func,
+ extra => [@_]
+ );
+ };
+ }
+
+ sub flush {
+ return reverse $log->flush;
+ }
+
+ sub stack {
+ return $log->retrieve( chrono => 1 );
+ }
+
+ sub stack_as_string {
+ my $class = shift;
+ my $trace = shift() ? 1 : 0;
+
+ return join $/, map {
+ '[' . $_->tag . '] [' . $_->when . '] ' .
+ ($trace ? $_->message . ' ' . $_->longmess
+ : $_->message);
+ } __PACKAGE__->stack;
+ }
+}
+
+=head1 GLOBAL VARIABLES
+
+=over 4
+
+=item $ERROR_FH
+
+This is the filehandle all the messages sent to C<error()> are being
+printed. This defaults to C<*STDERR>.
+
+=item $MSG_FH
+
+This is the filehandle all the messages sent to C<msg()> are being
+printed. This default to C<*STDOUT>.
+
+=item $DEBUG_FH
+
+This is the filehandle all the messages sent to C<debug()> are being
+printed. This default to C<*STDOUT>.
+
+=item $STACKTRACE_ON_ERROR
+
+If this option is set to C<true>, every call to C<error()> will
+generate a stacktrace using C<Carp::shortmess()>.
+Defaults to C<false>
+
+=cut
+
+BEGIN {
+ use vars qw[ $ERROR_FH $MSG_FH $DEBUG_FH $STACKTRACE_ON_ERROR ];
+
+ local $| = 1;
+ $ERROR_FH = \*STDERR;
+ $MSG_FH = \*STDOUT;
+ $DEBUG_FH = \*STDOUT;
+
+ $STACKTRACE_ON_ERROR = 0;
+}
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/MIME/Base64.pm b/Master/tlpkg/tlperl.straw/lib/MIME/Base64.pm
new file mode 100755
index 00000000000..2bcd5857795
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/MIME/Base64.pm
@@ -0,0 +1,175 @@
+package MIME::Base64;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(encode_base64 decode_base64);
+
+$VERSION = '3.09';
+
+require XSLoader;
+XSLoader::load('MIME::Base64', $VERSION);
+
+*encode = \&encode_base64;
+*decode = \&decode_base64;
+
+1;
+
+__END__
+
+=head1 NAME
+
+MIME::Base64 - Encoding and decoding of base64 strings
+
+=head1 SYNOPSIS
+
+ use MIME::Base64;
+
+ $encoded = encode_base64('Aladdin:open sesame');
+ $decoded = decode_base64($encoded);
+
+=head1 DESCRIPTION
+
+This module provides functions to encode and decode strings into and from the
+base64 encoding specified in RFC 2045 - I<MIME (Multipurpose Internet
+Mail Extensions)>. The base64 encoding is designed to represent
+arbitrary sequences of octets in a form that need not be humanly
+readable. A 65-character subset ([A-Za-z0-9+/=]) of US-ASCII is used,
+enabling 6 bits to be represented per printable character.
+
+The following functions are provided:
+
+=over 4
+
+=item encode_base64($str)
+
+=item encode_base64($str, $eol);
+
+Encode data by calling the encode_base64() function. The first
+argument is the string to encode. The second argument is the
+line-ending sequence to use. It is optional and defaults to "\n". The
+returned encoded string is broken into lines of no more than 76
+characters each and it will end with $eol unless it is empty. Pass an
+empty string as second argument if you do not want the encoded string
+to be broken into lines.
+
+=item decode_base64($str)
+
+Decode a base64 string by calling the decode_base64() function. This
+function takes a single argument which is the string to decode and
+returns the decoded data.
+
+Any character not part of the 65-character base64 subset is
+silently ignored. Characters occurring after a '=' padding character
+are never decoded.
+
+If the length of the string to decode, after ignoring
+non-base64 chars, is not a multiple of 4 or if padding occurs too early,
+then a warning is generated if perl is running under C<-w>.
+
+=back
+
+If you prefer not to import these routines into your namespace, you can
+call them as:
+
+ use MIME::Base64 ();
+ $encoded = MIME::Base64::encode($decoded);
+ $decoded = MIME::Base64::decode($encoded);
+
+=head1 DIAGNOSTICS
+
+The following warnings can be generated if perl is invoked with the
+C<-w> switch:
+
+=over 4
+
+=item Premature end of base64 data
+
+The number of characters to decode is not a multiple of 4. Legal
+base64 data should be padded with one or two "=" characters to make
+its length a multiple of 4. The decoded result will be the same
+whether the padding is present or not.
+
+=item Premature padding of base64 data
+
+The '=' padding character occurs as the first or second character
+in a base64 quartet.
+
+=back
+
+The following exception can be raised:
+
+=over 4
+
+=item Wide character in subroutine entry
+
+The string passed to encode_base64() contains characters with code
+above 255. The base64 encoding is only defined for single-byte
+characters. Use the Encode module to select the byte encoding you
+want.
+
+=back
+
+=head1 EXAMPLES
+
+If you want to encode a large file, you should encode it in chunks
+that are a multiple of 57 bytes. This ensures that the base64 lines
+line up and that you do not end up with padding in the middle. 57
+bytes of data fills one complete base64 line (76 == 57*4/3):
+
+ use MIME::Base64 qw(encode_base64);
+
+ open(FILE, "/var/log/wtmp") or die "$!";
+ while (read(FILE, $buf, 60*57)) {
+ print encode_base64($buf);
+ }
+
+or if you know you have enough memory
+
+ use MIME::Base64 qw(encode_base64);
+ local($/) = undef; # slurp
+ print encode_base64(<STDIN>);
+
+The same approach as a command line:
+
+ perl -MMIME::Base64 -0777 -ne 'print encode_base64($_)' <file
+
+Decoding does not need slurp mode if every line contains a multiple
+of four base64 chars:
+
+ perl -MMIME::Base64 -ne 'print decode_base64($_)' <file
+
+Perl v5.8 and better allow extended Unicode characters in strings.
+Such strings cannot be encoded directly, as the base64
+encoding is only defined for single-byte characters. The solution is
+to use the Encode module to select the byte encoding you want. For
+example:
+
+ use MIME::Base64 qw(encode_base64);
+ use Encode qw(encode);
+
+ $encoded = encode_base64(encode("UTF-8", "\x{FFFF}\n"));
+ print $encoded;
+
+=head1 COPYRIGHT
+
+Copyright 1995-1999, 2001-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+Distantly based on LWP::Base64 written by Martijn Koster
+<m.koster@nexor.co.uk> and Joerg Reichelt <j.reichelt@nexor.co.uk> and
+code posted to comp.lang.perl <3pd2lp$6gf@wsinti07.win.tue.nl> by Hans
+Mulder <hansm@wsinti07.win.tue.nl>
+
+The XS implementation uses code from metamail. Copyright 1991 Bell
+Communications Research, Inc. (Bellcore)
+
+=head1 SEE ALSO
+
+L<MIME::QuotedPrint>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/MIME/QuotedPrint.pm b/Master/tlpkg/tlperl.straw/lib/MIME/QuotedPrint.pm
new file mode 100755
index 00000000000..ca3a042edb3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/MIME/QuotedPrint.pm
@@ -0,0 +1,114 @@
+package MIME::QuotedPrint;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(encode_qp decode_qp);
+
+$VERSION = "3.09";
+
+use MIME::Base64; # will load XS version of {en,de}code_qp()
+
+*encode = \&encode_qp;
+*decode = \&decode_qp;
+
+1;
+
+__END__
+
+=head1 NAME
+
+MIME::QuotedPrint - Encoding and decoding of quoted-printable strings
+
+=head1 SYNOPSIS
+
+ use MIME::QuotedPrint;
+
+ $encoded = encode_qp($decoded);
+ $decoded = decode_qp($encoded);
+
+=head1 DESCRIPTION
+
+This module provides functions to encode and decode strings into and from the
+quoted-printable encoding specified in RFC 2045 - I<MIME (Multipurpose
+Internet Mail Extensions)>. The quoted-printable encoding is intended
+to represent data that largely consists of bytes that correspond to
+printable characters in the ASCII character set. Each non-printable
+character (as defined by English Americans) is represented by a
+triplet consisting of the character "=" followed by two hexadecimal
+digits.
+
+The following functions are provided:
+
+=over 4
+
+=item encode_qp($str)
+
+=item encode_qp($str, $eol)
+
+=item encode_qp($str, $eol, $binmode)
+
+This function returns an encoded version of the string ($str) given as
+argument.
+
+The second argument ($eol) is the line-ending sequence to use. It is
+optional and defaults to "\n". Every occurrence of "\n" is replaced
+with this string, and it is also used for additional "soft line
+breaks" to ensure that no line end up longer than 76 characters. Pass
+it as "\015\012" to produce data suitable for external consumption.
+The string "\r\n" produces the same result on many platforms, but not
+all.
+
+The third argument ($binmode) will select binary mode if passed as a
+TRUE value. In binary mode "\n" will be encoded in the same way as
+any other non-printable character. This ensures that a decoder will
+end up with exactly the same string whatever line ending sequence it
+uses. In general it is preferable to use the base64 encoding for
+binary data; see L<MIME::Base64>.
+
+An $eol of "" (the empty string) is special. In this case, no "soft
+line breaks" are introduced and binary mode is effectively enabled so
+that any "\n" in the original data is encoded as well.
+
+=item decode_qp($str);
+
+This function returns the plain text version of the string given
+as argument. The lines of the result are "\n" terminated, even if
+the $str argument contains "\r\n" terminated lines.
+
+=back
+
+
+If you prefer not to import these routines into your namespace, you can
+call them as:
+
+ use MIME::QuotedPrint ();
+ $encoded = MIME::QuotedPrint::encode($decoded);
+ $decoded = MIME::QuotedPrint::decode($encoded);
+
+Perl v5.8 and better allow extended Unicode characters in strings.
+Such strings cannot be encoded directly, as the quoted-printable
+encoding is only defined for single-byte characters. The solution is
+to use the Encode module to select the byte encoding you want. For
+example:
+
+ use MIME::QuotedPrint qw(encode_qp);
+ use Encode qw(encode);
+
+ $encoded = encode_qp(encode("UTF-8", "\x{FFFF}\n"));
+ print $encoded;
+
+=head1 COPYRIGHT
+
+Copyright 1995-1997,2002-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MIME::Base64>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigFloat.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigFloat.pm
new file mode 100755
index 00000000000..27d60b3143c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigFloat.pm
@@ -0,0 +1,4402 @@
+package Math::BigFloat;
+
+#
+# Mike grinned. 'Two down, infinity to go' - Mike Nostrus in 'Before and After'
+#
+
+# The following hash values are internally used:
+# _e : exponent (ref to $CALC object)
+# _m : mantissa (ref to $CALC object)
+# _es : sign of _e
+# sign : +,-,+inf,-inf, or "NaN" if not a number
+# _a : accuracy
+# _p : precision
+
+$VERSION = '1.60';
+require 5.006;
+
+require Exporter;
+@ISA = qw/Math::BigInt/;
+@EXPORT_OK = qw/bpi/;
+
+use strict;
+# $_trap_inf/$_trap_nan are internal and should never be accessed from outside
+use vars qw/$AUTOLOAD $accuracy $precision $div_scale $round_mode $rnd_mode
+ $upgrade $downgrade $_trap_nan $_trap_inf/;
+my $class = "Math::BigFloat";
+
+use overload
+'<=>' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ ref($_[0])->bcmp($_[0],$_[1]);
+ $rc = 1 unless defined $rc;
+ $rc <=> 0;
+ },
+# we need '>=' to get things like "1 >= NaN" right:
+'>=' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ ref($_[0])->bcmp($_[0],$_[1]);
+ # if there was a NaN involved, return false
+ return '' unless defined $rc;
+ $rc >= 0;
+ },
+'int' => sub { $_[0]->as_number() }, # 'trunc' to bigint
+;
+
+##############################################################################
+# global constants, flags and assorted stuff
+
+# the following are public, but their usage is not recommended. Use the
+# accessor methods instead.
+
+# class constants, use Class->constant_name() to access
+# one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
+$round_mode = 'even';
+$accuracy = undef;
+$precision = undef;
+$div_scale = 40;
+
+$upgrade = undef;
+$downgrade = undef;
+# the package we are using for our private parts, defaults to:
+# Math::BigInt->config()->{lib}
+my $MBI = 'Math::BigInt::FastCalc';
+
+# are NaNs ok? (otherwise it dies when encountering an NaN) set w/ config()
+$_trap_nan = 0;
+# the same for infinity
+$_trap_inf = 0;
+
+# constant for easier life
+my $nan = 'NaN';
+
+my $IMPORT = 0; # was import() called yet? used to make require work
+
+# some digits of accuracy for blog(undef,10); which we use in blog() for speed
+my $LOG_10 =
+ '2.3025850929940456840179914546843642076011014886287729760333279009675726097';
+my $LOG_10_A = length($LOG_10)-1;
+# ditto for log(2)
+my $LOG_2 =
+ '0.6931471805599453094172321214581765680755001343602552541206800094933936220';
+my $LOG_2_A = length($LOG_2)-1;
+my $HALF = '0.5'; # made into an object if nec.
+
+##############################################################################
+# the old code had $rnd_mode, so we need to support it, too
+
+sub TIESCALAR { my ($class) = @_; bless \$round_mode, $class; }
+sub FETCH { return $round_mode; }
+sub STORE { $rnd_mode = $_[0]->round_mode($_[1]); }
+
+BEGIN
+ {
+ # when someone sets $rnd_mode, we catch this and check the value to see
+ # whether it is valid or not.
+ $rnd_mode = 'even'; tie $rnd_mode, 'Math::BigFloat';
+
+ # we need both of them in this package:
+ *as_int = \&as_number;
+ }
+
+##############################################################################
+
+{
+ # valid method aliases for AUTOLOAD
+ my %methods = map { $_ => 1 }
+ qw / fadd fsub fmul fdiv fround ffround fsqrt fmod fstr fsstr fpow fnorm
+ fint facmp fcmp fzero fnan finf finc fdec ffac fneg
+ fceil ffloor frsft flsft fone flog froot fexp
+ /;
+ # valid methods that can be handed up (for AUTOLOAD)
+ my %hand_ups = map { $_ => 1 }
+ qw / is_nan is_inf is_negative is_positive is_pos is_neg
+ accuracy precision div_scale round_mode fabs fnot
+ objectify upgrade downgrade
+ bone binf bnan bzero
+ bsub
+ /;
+
+ sub _method_alias { exists $methods{$_[0]||''}; }
+ sub _method_hand_up { exists $hand_ups{$_[0]||''}; }
+}
+
+##############################################################################
+# constructors
+
+sub new
+ {
+ # create a new BigFloat object from a string or another bigfloat object.
+ # _e: exponent
+ # _m: mantissa
+ # sign => sign (+/-), or "NaN"
+
+ my ($class,$wanted,@r) = @_;
+
+ # avoid numify-calls by not using || on $wanted!
+ return $class->bzero() if !defined $wanted; # default to 0
+ return $wanted->copy() if UNIVERSAL::isa($wanted,'Math::BigFloat');
+
+ $class->import() if $IMPORT == 0; # make require work
+
+ my $self = {}; bless $self, $class;
+ # shortcut for bigints and its subclasses
+ if ((ref($wanted)) && UNIVERSAL::can( $wanted, "as_number"))
+ {
+ $self->{_m} = $wanted->as_number()->{value}; # get us a bigint copy
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ $self->{sign} = $wanted->sign();
+ return $self->bnorm();
+ }
+ # else: got a string or something maskerading as number (with overload)
+
+ # handle '+inf', '-inf' first
+ if ($wanted =~ /^[+-]?inf\z/)
+ {
+ return $downgrade->new($wanted) if $downgrade;
+
+ $self->{sign} = $wanted; # set a default sign for bstr()
+ return $self->binf($wanted);
+ }
+
+ # shortcut for simple forms like '12' that neither have trailing nor leading
+ # zeros
+ if ($wanted =~ /^([+-]?)([1-9][0-9]*[1-9])$/)
+ {
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ $self->{sign} = $1 || '+';
+ $self->{_m} = $MBI->_new($2);
+ return $self->round(@r) if !$downgrade;
+ }
+
+ my ($mis,$miv,$mfv,$es,$ev) = Math::BigInt::_split($wanted);
+ if (!ref $mis)
+ {
+ if ($_trap_nan)
+ {
+ require Carp;
+ Carp::croak ("$wanted is not a number initialized to $class");
+ }
+
+ return $downgrade->bnan() if $downgrade;
+
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ $self->{_m} = $MBI->_zero();
+ $self->{sign} = $nan;
+ }
+ else
+ {
+ # make integer from mantissa by adjusting exp, then convert to int
+ $self->{_e} = $MBI->_new($$ev); # exponent
+ $self->{_es} = $$es || '+';
+ my $mantissa = "$$miv$$mfv"; # create mant.
+ $mantissa =~ s/^0+(\d)/$1/; # strip leading zeros
+ $self->{_m} = $MBI->_new($mantissa); # create mant.
+
+ # 3.123E0 = 3123E-3, and 3.123E-2 => 3123E-5
+ if (CORE::length($$mfv) != 0)
+ {
+ my $len = $MBI->_new( CORE::length($$mfv));
+ ($self->{_e}, $self->{_es}) =
+ _e_sub ($self->{_e}, $len, $self->{_es}, '+');
+ }
+ # we can only have trailing zeros on the mantissa if $$mfv eq ''
+ else
+ {
+ # Use a regexp to count the trailing zeros in $$miv instead of _zeros()
+ # because that is faster, especially when _m is not stored in base 10.
+ my $zeros = 0; $zeros = CORE::length($1) if $$miv =~ /[1-9](0*)$/;
+ if ($zeros != 0)
+ {
+ my $z = $MBI->_new($zeros);
+ # turn '120e2' into '12e3'
+ $MBI->_rsft ( $self->{_m}, $z, 10);
+ ($self->{_e}, $self->{_es}) =
+ _e_add ( $self->{_e}, $z, $self->{_es}, '+');
+ }
+ }
+ $self->{sign} = $$mis;
+
+ # for something like 0Ey, set y to 1, and -0 => +0
+ # Check $$miv for being '0' and $$mfv eq '', because otherwise _m could not
+ # have become 0. That's faster than to call $MBI->_is_zero().
+ $self->{sign} = '+', $self->{_e} = $MBI->_one()
+ if $$miv eq '0' and $$mfv eq '';
+
+ return $self->round(@r) if !$downgrade;
+ }
+ # if downgrade, inf, NaN or integers go down
+
+ if ($downgrade && $self->{_es} eq '+')
+ {
+ if ($MBI->_is_zero( $self->{_e} ))
+ {
+ return $downgrade->new($$mis . $MBI->_str( $self->{_m} ));
+ }
+ return $downgrade->new($self->bsstr());
+ }
+ $self->bnorm()->round(@r); # first normalize, then round
+ }
+
+sub copy
+ {
+ # if two arguments, the first one is the class to "swallow" subclasses
+ if (@_ > 1)
+ {
+ my $self = bless {
+ sign => $_[1]->{sign},
+ _es => $_[1]->{_es},
+ _m => $MBI->_copy($_[1]->{_m}),
+ _e => $MBI->_copy($_[1]->{_e}),
+ }, $_[0] if @_ > 1;
+
+ $self->{_a} = $_[1]->{_a} if defined $_[1]->{_a};
+ $self->{_p} = $_[1]->{_p} if defined $_[1]->{_p};
+ return $self;
+ }
+
+ my $self = bless {
+ sign => $_[0]->{sign},
+ _es => $_[0]->{_es},
+ _m => $MBI->_copy($_[0]->{_m}),
+ _e => $MBI->_copy($_[0]->{_e}),
+ }, ref($_[0]);
+
+ $self->{_a} = $_[0]->{_a} if defined $_[0]->{_a};
+ $self->{_p} = $_[0]->{_p} if defined $_[0]->{_p};
+ $self;
+ }
+
+sub _bnan
+ {
+ # used by parent class bone() to initialize number to NaN
+ my $self = shift;
+
+ if ($_trap_nan)
+ {
+ require Carp;
+ my $class = ref($self);
+ Carp::croak ("Tried to set $self to NaN in $class\::_bnan()");
+ }
+
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_zero();
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ }
+
+sub _binf
+ {
+ # used by parent class bone() to initialize number to +-inf
+ my $self = shift;
+
+ if ($_trap_inf)
+ {
+ require Carp;
+ my $class = ref($self);
+ Carp::croak ("Tried to set $self to +-inf in $class\::_binf()");
+ }
+
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_zero();
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ }
+
+sub _bone
+ {
+ # used by parent class bone() to initialize number to 1
+ my $self = shift;
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_one();
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ }
+
+sub _bzero
+ {
+ # used by parent class bone() to initialize number to 0
+ my $self = shift;
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_zero();
+ $self->{_e} = $MBI->_one();
+ $self->{_es} = '+';
+ }
+
+sub isa
+ {
+ my ($self,$class) = @_;
+ return if $class =~ /^Math::BigInt/; # we aren't one of these
+ UNIVERSAL::isa($self,$class);
+ }
+
+sub config
+ {
+ # return (later set?) configuration data as hash ref
+ my $class = shift || 'Math::BigFloat';
+
+ if (@_ == 1 && ref($_[0]) ne 'HASH')
+ {
+ my $cfg = $class->SUPER::config();
+ return $cfg->{$_[0]};
+ }
+
+ my $cfg = $class->SUPER::config(@_);
+
+ # now we need only to override the ones that are different from our parent
+ $cfg->{class} = $class;
+ $cfg->{with} = $MBI;
+ $cfg;
+ }
+
+##############################################################################
+# string conversation
+
+sub bstr
+ {
+ # (ref to BFLOAT or num_str ) return num_str
+ # Convert number from internal format to (non-scientific) string format.
+ # internal format is always normalized (no leading zeros, "-0" => "+0")
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+
+ my $es = '0'; my $len = 1; my $cad = 0; my $dot = '.';
+
+ # $x is zero?
+ my $not_zero = !($x->{sign} eq '+' && $MBI->_is_zero($x->{_m}));
+ if ($not_zero)
+ {
+ $es = $MBI->_str($x->{_m});
+ $len = CORE::length($es);
+ my $e = $MBI->_num($x->{_e});
+ $e = -$e if $x->{_es} eq '-';
+ if ($e < 0)
+ {
+ $dot = '';
+ # if _e is bigger than a scalar, the following will blow your memory
+ if ($e <= -$len)
+ {
+ my $r = abs($e) - $len;
+ $es = '0.'. ('0' x $r) . $es; $cad = -($len+$r);
+ }
+ else
+ {
+ substr($es,$e,0) = '.'; $cad = $MBI->_num($x->{_e});
+ $cad = -$cad if $x->{_es} eq '-';
+ }
+ }
+ elsif ($e > 0)
+ {
+ # expand with zeros
+ $es .= '0' x $e; $len += $e; $cad = 0;
+ }
+ } # if not zero
+
+ $es = '-'.$es if $x->{sign} eq '-';
+ # if set accuracy or precision, pad with zeros on the right side
+ if ((defined $x->{_a}) && ($not_zero))
+ {
+ # 123400 => 6, 0.1234 => 4, 0.001234 => 4
+ my $zeros = $x->{_a} - $cad; # cad == 0 => 12340
+ $zeros = $x->{_a} - $len if $cad != $len;
+ $es .= $dot.'0' x $zeros if $zeros > 0;
+ }
+ elsif ((($x->{_p} || 0) < 0))
+ {
+ # 123400 => 6, 0.1234 => 4, 0.001234 => 6
+ my $zeros = -$x->{_p} + $cad;
+ $es .= $dot.'0' x $zeros if $zeros > 0;
+ }
+ $es;
+ }
+
+sub bsstr
+ {
+ # (ref to BFLOAT or num_str ) return num_str
+ # Convert number from internal format to scientific string format.
+ # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+ my $sep = 'e'.$x->{_es};
+ my $sign = $x->{sign}; $sign = '' if $sign eq '+';
+ $sign . $MBI->_str($x->{_m}) . $sep . $MBI->_str($x->{_e});
+ }
+
+sub numify
+ {
+ # Make a number from a BigFloat object
+ # simple return a string and let Perl's atoi()/atof() handle the rest
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+ $x->bsstr();
+ }
+
+##############################################################################
+# public stuff (usually prefixed with "b")
+
+sub bneg
+ {
+ # (BINT or num_str) return BINT
+ # negate number or make a negated number from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('bneg');
+
+ # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
+ $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $MBI->_is_zero($x->{_m}));
+ $x;
+ }
+
+# tels 2001-08-04
+# XXX TODO this must be overwritten and return NaN for non-integer values
+# band(), bior(), bxor(), too
+#sub bnot
+# {
+# $class->SUPER::bnot($class,@_);
+# }
+
+sub bcmp
+ {
+ # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bcmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if ($x->{sign} eq $y->{sign}) && ($x->{sign} =~ /^[+-]inf$/);
+ return +1 if $x->{sign} eq '+inf';
+ return -1 if $x->{sign} eq '-inf';
+ return -1 if $y->{sign} eq '+inf';
+ return +1;
+ }
+
+ # check sign for speed first
+ return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
+ return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
+
+ # shortcut
+ my $xz = $x->is_zero();
+ my $yz = $y->is_zero();
+ return 0 if $xz && $yz; # 0 <=> 0
+ return -1 if $xz && $y->{sign} eq '+'; # 0 <=> +y
+ return 1 if $yz && $x->{sign} eq '+'; # +x <=> 0
+
+ # adjust so that exponents are equal
+ my $lxm = $MBI->_len($x->{_m});
+ my $lym = $MBI->_len($y->{_m});
+ # the numify somewhat limits our length, but makes it much faster
+ my ($xes,$yes) = (1,1);
+ $xes = -1 if $x->{_es} ne '+';
+ $yes = -1 if $y->{_es} ne '+';
+ my $lx = $lxm + $xes * $MBI->_num($x->{_e});
+ my $ly = $lym + $yes * $MBI->_num($y->{_e});
+ my $l = $lx - $ly; $l = -$l if $x->{sign} eq '-';
+ return $l <=> 0 if $l != 0;
+
+ # lengths (corrected by exponent) are equal
+ # so make mantissa equal length by padding with zero (shift left)
+ my $diff = $lxm - $lym;
+ my $xm = $x->{_m}; # not yet copy it
+ my $ym = $y->{_m};
+ if ($diff > 0)
+ {
+ $ym = $MBI->_copy($y->{_m});
+ $ym = $MBI->_lsft($ym, $MBI->_new($diff), 10);
+ }
+ elsif ($diff < 0)
+ {
+ $xm = $MBI->_copy($x->{_m});
+ $xm = $MBI->_lsft($xm, $MBI->_new(-$diff), 10);
+ }
+ my $rc = $MBI->_acmp($xm,$ym);
+ $rc = -$rc if $x->{sign} eq '-'; # -124 < -123
+ $rc <=> 0;
+ }
+
+sub bacmp
+ {
+ # Compares 2 values, ignoring their signs.
+ # Returns one of undef, <0, =0, >0. (suitable for sort)
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bacmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ # handle +-inf and NaN's
+ if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/)
+ {
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if ($x->is_inf() && $y->is_inf());
+ return 1 if ($x->is_inf() && !$y->is_inf());
+ return -1;
+ }
+
+ # shortcut
+ my $xz = $x->is_zero();
+ my $yz = $y->is_zero();
+ return 0 if $xz && $yz; # 0 <=> 0
+ return -1 if $xz && !$yz; # 0 <=> +y
+ return 1 if $yz && !$xz; # +x <=> 0
+
+ # adjust so that exponents are equal
+ my $lxm = $MBI->_len($x->{_m});
+ my $lym = $MBI->_len($y->{_m});
+ my ($xes,$yes) = (1,1);
+ $xes = -1 if $x->{_es} ne '+';
+ $yes = -1 if $y->{_es} ne '+';
+ # the numify somewhat limits our length, but makes it much faster
+ my $lx = $lxm + $xes * $MBI->_num($x->{_e});
+ my $ly = $lym + $yes * $MBI->_num($y->{_e});
+ my $l = $lx - $ly;
+ return $l <=> 0 if $l != 0;
+
+ # lengths (corrected by exponent) are equal
+ # so make mantissa equal-length by padding with zero (shift left)
+ my $diff = $lxm - $lym;
+ my $xm = $x->{_m}; # not yet copy it
+ my $ym = $y->{_m};
+ if ($diff > 0)
+ {
+ $ym = $MBI->_copy($y->{_m});
+ $ym = $MBI->_lsft($ym, $MBI->_new($diff), 10);
+ }
+ elsif ($diff < 0)
+ {
+ $xm = $MBI->_copy($x->{_m});
+ $xm = $MBI->_lsft($xm, $MBI->_new(-$diff), 10);
+ }
+ $MBI->_acmp($xm,$ym);
+ }
+
+sub badd
+ {
+ # add second arg (BFLOAT or string) to first (BFLOAT) (modifies first)
+ # return result as BFLOAT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('badd');
+
+ # inf and NaN handling
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # NaN first
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ # +inf++inf or -inf+-inf => same, rest is NaN
+ return $x if $x->{sign} eq $y->{sign};
+ return $x->bnan();
+ }
+ # +-inf + something => +inf; something +-inf => +-inf
+ $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
+ return $x;
+ }
+
+ return $upgrade->badd($x,$y,@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ $r[3] = $y; # no push!
+
+ # speed: no add for 0+y or x+0
+ return $x->bround(@r) if $y->is_zero(); # x+0
+ if ($x->is_zero()) # 0+y
+ {
+ # make copy, clobbering up x (modify in place!)
+ $x->{_e} = $MBI->_copy($y->{_e});
+ $x->{_es} = $y->{_es};
+ $x->{_m} = $MBI->_copy($y->{_m});
+ $x->{sign} = $y->{sign} || $nan;
+ return $x->round(@r);
+ }
+
+ # take lower of the two e's and adapt m1 to it to match m2
+ my $e = $y->{_e};
+ $e = $MBI->_zero() if !defined $e; # if no BFLOAT?
+ $e = $MBI->_copy($e); # make copy (didn't do it yet)
+
+ my $es;
+
+ ($e,$es) = _e_sub($e, $x->{_e}, $y->{_es} || '+', $x->{_es});
+
+ my $add = $MBI->_copy($y->{_m});
+
+ if ($es eq '-') # < 0
+ {
+ $MBI->_lsft( $x->{_m}, $e, 10);
+ ($x->{_e},$x->{_es}) = _e_add($x->{_e}, $e, $x->{_es}, $es);
+ }
+ elsif (!$MBI->_is_zero($e)) # > 0
+ {
+ $MBI->_lsft($add, $e, 10);
+ }
+ # else: both e are the same, so just leave them
+
+ if ($x->{sign} eq $y->{sign})
+ {
+ # add
+ $x->{_m} = $MBI->_add($x->{_m}, $add);
+ }
+ else
+ {
+ ($x->{_m}, $x->{sign}) =
+ _e_add($x->{_m}, $add, $x->{sign}, $y->{sign});
+ }
+
+ # delete trailing zeros, then round
+ $x->bnorm()->round(@r);
+ }
+
+# sub bsub is inherited from Math::BigInt!
+
+sub binc
+ {
+ # increment arg by one
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('binc');
+
+ if ($x->{_es} eq '-')
+ {
+ return $x->badd($self->bone(),@r); # digits after dot
+ }
+
+ if (!$MBI->_is_zero($x->{_e})) # _e == 0 for NaN, inf, -inf
+ {
+ # 1e2 => 100, so after the shift below _m has a '0' as last digit
+ $x->{_m} = $MBI->_lsft($x->{_m}, $x->{_e},10); # 1e2 => 100
+ $x->{_e} = $MBI->_zero(); # normalize
+ $x->{_es} = '+';
+ # we know that the last digit of $x will be '1' or '9', depending on the
+ # sign
+ }
+ # now $x->{_e} == 0
+ if ($x->{sign} eq '+')
+ {
+ $MBI->_inc($x->{_m});
+ return $x->bnorm()->bround(@r);
+ }
+ elsif ($x->{sign} eq '-')
+ {
+ $MBI->_dec($x->{_m});
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # -1 +1 => -0 => +0
+ return $x->bnorm()->bround(@r);
+ }
+ # inf, nan handling etc
+ $x->badd($self->bone(),@r); # badd() does round
+ }
+
+sub bdec
+ {
+ # decrement arg by one
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bdec');
+
+ if ($x->{_es} eq '-')
+ {
+ return $x->badd($self->bone('-'),@r); # digits after dot
+ }
+
+ if (!$MBI->_is_zero($x->{_e}))
+ {
+ $x->{_m} = $MBI->_lsft($x->{_m}, $x->{_e},10); # 1e2 => 100
+ $x->{_e} = $MBI->_zero(); # normalize
+ $x->{_es} = '+';
+ }
+ # now $x->{_e} == 0
+ my $zero = $x->is_zero();
+ # <= 0
+ if (($x->{sign} eq '-') || $zero)
+ {
+ $MBI->_inc($x->{_m});
+ $x->{sign} = '-' if $zero; # 0 => 1 => -1
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # -1 +1 => -0 => +0
+ return $x->bnorm()->round(@r);
+ }
+ # > 0
+ elsif ($x->{sign} eq '+')
+ {
+ $MBI->_dec($x->{_m});
+ return $x->bnorm()->round(@r);
+ }
+ # inf, nan handling etc
+ $x->badd($self->bone('-'),@r); # does round
+ }
+
+sub DEBUG () { 0; }
+
+sub blog
+ {
+ my ($self,$x,$base,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('blog');
+
+ # $base > 0, $base != 1; if $base == undef default to $base == e
+ # $x >= 0
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ # also takes care of the "error in _find_round_parameters?" case
+ return $x->bnan() if $x->{sign} ne '+' || $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # P = undef
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ return $x->bzero(@params) if $x->is_one();
+ # base not defined => base == Euler's number e
+ if (defined $base)
+ {
+ # make object, since we don't feed it through objectify() to still get the
+ # case of $base == undef
+ $base = $self->new($base) unless ref($base);
+ # $base > 0; $base != 1
+ return $x->bnan() if $base->is_zero() || $base->is_one() ||
+ $base->{sign} ne '+';
+ # if $x == $base, we know the result must be 1.0
+ if ($x->bcmp($base) == 0)
+ {
+ $x->bone('+',@params);
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ return $x;
+ }
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+ local $Math::BigFloat::downgrade = undef;
+
+ # upgrade $x if $x is not a BigFloat (handle BigInt input)
+ # XXX TODO: rebless!
+ if (!$x->isa('Math::BigFloat'))
+ {
+ $x = Math::BigFloat->new($x);
+ $self = ref($x);
+ }
+
+ my $done = 0;
+
+ # If the base is defined and an integer, try to calculate integer result
+ # first. This is very fast, and in case the real result was found, we can
+ # stop right here.
+ if (defined $base && $base->is_int() && $x->is_int())
+ {
+ my $i = $MBI->_copy( $x->{_m} );
+ $MBI->_lsft( $i, $x->{_e}, 10 ) unless $MBI->_is_zero($x->{_e});
+ my $int = Math::BigInt->bzero();
+ $int->{value} = $i;
+ $int->blog($base->as_number());
+ # if ($exact)
+ if ($base->as_number()->bpow($int) == $x)
+ {
+ # found result, return it
+ $x->{_m} = $int->{value};
+ $x->{_e} = $MBI->_zero();
+ $x->{_es} = '+';
+ $x->bnorm();
+ $done = 1;
+ }
+ }
+
+ if ($done == 0)
+ {
+ # base is undef, so base should be e (Euler's number), so first calculate the
+ # log to base e (using reduction by 10 (and probably 2)):
+ $self->_log_10($x,$scale);
+
+ # and if a different base was requested, convert it
+ if (defined $base)
+ {
+ $base = Math::BigFloat->new($base) unless $base->isa('Math::BigFloat');
+ # not ln, but some other base (don't modify $base)
+ $x->bdiv( $base->copy()->blog(undef,$scale), $scale );
+ }
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+
+ $x;
+ }
+
+sub _len_to_steps
+ {
+ # Given D (digits in decimal), compute N so that N! (N factorial) is
+ # at least D digits long. D should be at least 50.
+ my $d = shift;
+
+ # two constants for the Ramanujan estimate of ln(N!)
+ my $lg2 = log(2 * 3.14159265) / 2;
+ my $lg10 = log(10);
+
+ # D = 50 => N => 42, so L = 40 and R = 50
+ my $l = 40; my $r = $d;
+
+ # Otherwise this does not work under -Mbignum and we do not yet have "no bignum;" :(
+ $l = $l->numify if ref($l);
+ $r = $r->numify if ref($r);
+ $lg2 = $lg2->numify if ref($lg2);
+ $lg10 = $lg10->numify if ref($lg10);
+
+ # binary search for the right value (could this be written as the reverse of lg(n!)?)
+ while ($r - $l > 1)
+ {
+ my $n = int(($r - $l) / 2) + $l;
+ my $ramanujan =
+ int(($n * log($n) - $n + log( $n * (1 + 4*$n*(1+2*$n)) ) / 6 + $lg2) / $lg10);
+ $ramanujan > $d ? $r = $n : $l = $n;
+ }
+ $l;
+ }
+
+sub bnok
+ {
+ # Calculate n over k (binomial coefficient or "choose" function) as integer.
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bnok');
+
+ return $x->bnan() if $x->is_nan() || $y->is_nan();
+ return $x->binf() if $x->is_inf();
+
+ my $u = $x->as_int();
+ $u->bnok($y->as_int());
+
+ $x->{_m} = $u->{value};
+ $x->{_e} = $MBI->_zero();
+ $x->{_es} = '+';
+ $x->{sign} = '+';
+ $x->bnorm(@r);
+ }
+
+sub bexp
+ {
+ # Calculate e ** X (Euler's number to the power of X)
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bexp');
+
+ return $x->binf() if $x->{sign} eq '+inf';
+ return $x->bzero() if $x->{sign} eq '-inf';
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ # also takes care of the "error in _find_round_parameters?" case
+ return $x if $x->{sign} eq 'NaN';
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # P = undef
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it's not enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ return $x->bone(@params) if $x->is_zero();
+
+ if (!$x->isa('Math::BigFloat'))
+ {
+ $x = Math::BigFloat->new($x);
+ $self = ref($x);
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+ local $Math::BigFloat::downgrade = undef;
+
+ my $x_org = $x->copy();
+
+ # We use the following Taylor series:
+
+ # x x^2 x^3 x^4
+ # e = 1 + --- + --- + --- + --- ...
+ # 1! 2! 3! 4!
+
+ # The difference for each term is X and N, which would result in:
+ # 2 copy, 2 mul, 2 add, 1 inc, 1 div operations per term
+
+ # But it is faster to compute exp(1) and then raising it to the
+ # given power, esp. if $x is really big and an integer because:
+
+ # * The numerator is always 1, making the computation faster
+ # * the series converges faster in the case of x == 1
+ # * We can also easily check when we have reached our limit: when the
+ # term to be added is smaller than "1E$scale", we can stop - f.i.
+ # scale == 5, and we have 1/40320, then we stop since 1/40320 < 1E-5.
+ # * we can compute the *exact* result by simulating bigrat math:
+
+ # 1 1 gcd(3,4) = 1 1*24 + 1*6 5
+ # - + - = ---------- = --
+ # 6 24 6*24 24
+
+ # We do not compute the gcd() here, but simple do:
+ # 1 1 1*24 + 1*6 30
+ # - + - = --------- = --
+ # 6 24 6*24 144
+
+ # In general:
+ # a c a*d + c*b and note that c is always 1 and d = (b*f)
+ # - + - = ---------
+ # b d b*d
+
+ # This leads to: which can be reduced by b to:
+ # a 1 a*b*f + b a*f + 1
+ # - + - = --------- = -------
+ # b b*f b*b*f b*f
+
+ # The first terms in the series are:
+
+ # 1 1 1 1 1 1 1 1 13700
+ # -- + -- + -- + -- + -- + --- + --- + ---- = -----
+ # 1 1 2 6 24 120 720 5040 5040
+
+ # Note that we cannot simple reduce 13700/5040 to 685/252, but must keep A and B!
+
+ if ($scale <= 75)
+ {
+ # set $x directly from a cached string form
+ $x->{_m} = $MBI->_new(
+ "27182818284590452353602874713526624977572470936999595749669676277240766303535476");
+ $x->{sign} = '+';
+ $x->{_es} = '-';
+ $x->{_e} = $MBI->_new(79);
+ }
+ else
+ {
+ # compute A and B so that e = A / B.
+
+ # After some terms we end up with this, so we use it as a starting point:
+ my $A = $MBI->_new("90933395208605785401971970164779391644753259799242");
+ my $F = $MBI->_new(42); my $step = 42;
+
+ # Compute how many steps we need to take to get $A and $B sufficiently big
+ my $steps = _len_to_steps($scale - 4);
+# print STDERR "# Doing $steps steps for ", $scale-4, " digits\n";
+ while ($step++ <= $steps)
+ {
+ # calculate $a * $f + 1
+ $A = $MBI->_mul($A, $F);
+ $A = $MBI->_inc($A);
+ # increment f
+ $F = $MBI->_inc($F);
+ }
+ # compute $B as factorial of $steps (this is faster than doing it manually)
+ my $B = $MBI->_fac($MBI->_new($steps));
+
+# print "A ", $MBI->_str($A), "\nB ", $MBI->_str($B), "\n";
+
+ # compute A/B with $scale digits in the result (truncate, not round)
+ $A = $MBI->_lsft( $A, $MBI->_new($scale), 10);
+ $A = $MBI->_div( $A, $B );
+
+ $x->{_m} = $A;
+ $x->{sign} = '+';
+ $x->{_es} = '-';
+ $x->{_e} = $MBI->_new($scale);
+ }
+
+ # $x contains now an estimate of e, with some surplus digits, so we can round
+ if (!$x_org->is_one())
+ {
+ # raise $x to the wanted power and round it in one step:
+ $x->bpow($x_org, @params);
+ }
+ else
+ {
+ # else just round the already computed result
+ delete $x->{_a}; delete $x->{_p};
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+
+ $x; # return modified $x
+ }
+
+sub _log
+ {
+ # internal log function to calculate ln() based on Taylor series.
+ # Modifies $x in place.
+ my ($self,$x,$scale) = @_;
+
+ # in case of $x == 1, result is 0
+ return $x->bzero() if $x->is_one();
+
+ # XXX TODO: rewrite this in a similiar manner to bexp()
+
+ # http://www.efunda.com/math/taylor_series/logarithmic.cfm?search_string=log
+
+ # u = x-1, v = x+1
+ # _ _
+ # Taylor: | u 1 u^3 1 u^5 |
+ # ln (x) = 2 | --- + - * --- + - * --- + ... | x > 0
+ # |_ v 3 v^3 5 v^5 _|
+
+ # This takes much more steps to calculate the result and is thus not used
+ # u = x-1
+ # _ _
+ # Taylor: | u 1 u^2 1 u^3 |
+ # ln (x) = 2 | --- + - * --- + - * --- + ... | x > 1/2
+ # |_ x 2 x^2 3 x^3 _|
+
+ my ($limit,$v,$u,$below,$factor,$two,$next,$over,$f);
+
+ $v = $x->copy(); $v->binc(); # v = x+1
+ $x->bdec(); $u = $x->copy(); # u = x-1; x = x-1
+ $x->bdiv($v,$scale); # first term: u/v
+ $below = $v->copy();
+ $over = $u->copy();
+ $u *= $u; $v *= $v; # u^2, v^2
+ $below->bmul($v); # u^3, v^3
+ $over->bmul($u);
+ $factor = $self->new(3); $f = $self->new(2);
+
+ my $steps = 0 if DEBUG;
+ $limit = $self->new("1E-". ($scale-1));
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop
+
+ # calculating the next term simple from over/below will result in quite
+ # a time hog if the input has many digits, since over and below will
+ # accumulate more and more digits, and the result will also have many
+ # digits, but in the end it is rounded to $scale digits anyway. So if we
+ # round $over and $below first, we save a lot of time for the division
+ # (not with log(1.2345), but try log (123**123) to see what I mean. This
+ # can introduce a rounding error if the division result would be f.i.
+ # 0.1234500000001 and we round it to 5 digits it would become 0.12346, but
+ # if we truncated $over and $below we might get 0.12345. Does this matter
+ # for the end result? So we give $over and $below 4 more digits to be
+ # on the safe side (unscientific error handling as usual... :+D
+
+ $next = $over->copy->bround($scale+4)->bdiv(
+ $below->copy->bmul($factor)->bround($scale+4),
+ $scale);
+
+## old version:
+## $next = $over->copy()->bdiv($below->copy()->bmul($factor),$scale);
+
+ last if $next->bacmp($limit) <= 0;
+
+ delete $next->{_a}; delete $next->{_p};
+ $x->badd($next);
+ # calculate things for the next term
+ $over *= $u; $below *= $v; $factor->badd($f);
+ if (DEBUG)
+ {
+ $steps++; print "step $steps = $x\n" if $steps % 10 == 0;
+ }
+ }
+ print "took $steps steps\n" if DEBUG;
+ $x->bmul($f); # $x *= 2
+ }
+
+sub _log_10
+ {
+ # Internal log function based on reducing input to the range of 0.1 .. 9.99
+ # and then "correcting" the result to the proper one. Modifies $x in place.
+ my ($self,$x,$scale) = @_;
+
+ # Taking blog() from numbers greater than 10 takes a *very long* time, so we
+ # break the computation down into parts based on the observation that:
+ # blog(X*Y) = blog(X) + blog(Y)
+ # We set Y here to multiples of 10 so that $x becomes below 1 - the smaller
+ # $x is the faster it gets. Since 2*$x takes about 10 times as
+ # long, we make it faster by about a factor of 100 by dividing $x by 10.
+
+ # The same observation is valid for numbers smaller than 0.1, e.g. computing
+ # log(1) is fastest, and the further away we get from 1, the longer it takes.
+ # So we also 'break' this down by multiplying $x with 10 and subtract the
+ # log(10) afterwards to get the correct result.
+
+ # To get $x even closer to 1, we also divide by 2 and then use log(2) to
+ # correct for this. For instance if $x is 2.4, we use the formula:
+ # blog(2.4 * 2) == blog (1.2) + blog(2)
+ # and thus calculate only blog(1.2) and blog(2), which is faster in total
+ # than calculating blog(2.4).
+
+ # In addition, the values for blog(2) and blog(10) are cached.
+
+ # Calculate nr of digits before dot:
+ my $dbd = $MBI->_num($x->{_e});
+ $dbd = -$dbd if $x->{_es} eq '-';
+ $dbd += $MBI->_len($x->{_m});
+
+ # more than one digit (e.g. at least 10), but *not* exactly 10 to avoid
+ # infinite recursion
+
+ my $calc = 1; # do some calculation?
+
+ # disable the shortcut for 10, since we need log(10) and this would recurse
+ # infinitely deep
+ if ($x->{_es} eq '+' && $MBI->_is_one($x->{_e}) && $MBI->_is_one($x->{_m}))
+ {
+ $dbd = 0; # disable shortcut
+ # we can use the cached value in these cases
+ if ($scale <= $LOG_10_A)
+ {
+ $x->bzero(); $x->badd($LOG_10); # modify $x in place
+ $calc = 0; # no need to calc, but round
+ }
+ # if we can't use the shortcut, we continue normally
+ }
+ else
+ {
+ # disable the shortcut for 2, since we maybe have it cached
+ if (($MBI->_is_zero($x->{_e}) && $MBI->_is_two($x->{_m})))
+ {
+ $dbd = 0; # disable shortcut
+ # we can use the cached value in these cases
+ if ($scale <= $LOG_2_A)
+ {
+ $x->bzero(); $x->badd($LOG_2); # modify $x in place
+ $calc = 0; # no need to calc, but round
+ }
+ # if we can't use the shortcut, we continue normally
+ }
+ }
+
+ # if $x = 0.1, we know the result must be 0-log(10)
+ if ($calc != 0 && $x->{_es} eq '-' && $MBI->_is_one($x->{_e}) &&
+ $MBI->_is_one($x->{_m}))
+ {
+ $dbd = 0; # disable shortcut
+ # we can use the cached value in these cases
+ if ($scale <= $LOG_10_A)
+ {
+ $x->bzero(); $x->bsub($LOG_10);
+ $calc = 0; # no need to calc, but round
+ }
+ }
+
+ return if $calc == 0; # already have the result
+
+ # default: these correction factors are undef and thus not used
+ my $l_10; # value of ln(10) to A of $scale
+ my $l_2; # value of ln(2) to A of $scale
+
+ my $two = $self->new(2);
+
+ # $x == 2 => 1, $x == 13 => 2, $x == 0.1 => 0, $x == 0.01 => -1
+ # so don't do this shortcut for 1 or 0
+ if (($dbd > 1) || ($dbd < 0))
+ {
+ # convert our cached value to an object if not already (avoid doing this
+ # at import() time, since not everybody needs this)
+ $LOG_10 = $self->new($LOG_10,undef,undef) unless ref $LOG_10;
+
+ #print "x = $x, dbd = $dbd, calc = $calc\n";
+ # got more than one digit before the dot, or more than one zero after the
+ # dot, so do:
+ # log(123) == log(1.23) + log(10) * 2
+ # log(0.0123) == log(1.23) - log(10) * 2
+
+ if ($scale <= $LOG_10_A)
+ {
+ # use cached value
+ $l_10 = $LOG_10->copy(); # copy for mul
+ }
+ else
+ {
+ # else: slower, compute and cache result
+ # also disable downgrade for this code path
+ local $Math::BigFloat::downgrade = undef;
+
+ # shorten the time to calculate log(10) based on the following:
+ # log(1.25 * 8) = log(1.25) + log(8)
+ # = log(1.25) + log(2) + log(2) + log(2)
+
+ # first get $l_2 (and possible compute and cache log(2))
+ $LOG_2 = $self->new($LOG_2,undef,undef) unless ref $LOG_2;
+ if ($scale <= $LOG_2_A)
+ {
+ # use cached value
+ $l_2 = $LOG_2->copy(); # copy() for the mul below
+ }
+ else
+ {
+ # else: slower, compute and cache result
+ $l_2 = $two->copy(); $self->_log($l_2, $scale); # scale+4, actually
+ $LOG_2 = $l_2->copy(); # cache the result for later
+ # the copy() is for mul below
+ $LOG_2_A = $scale;
+ }
+
+ # now calculate log(1.25):
+ $l_10 = $self->new('1.25'); $self->_log($l_10, $scale); # scale+4, actually
+
+ # log(1.25) + log(2) + log(2) + log(2):
+ $l_10->badd($l_2);
+ $l_10->badd($l_2);
+ $l_10->badd($l_2);
+ $LOG_10 = $l_10->copy(); # cache the result for later
+ # the copy() is for mul below
+ $LOG_10_A = $scale;
+ }
+ $dbd-- if ($dbd > 1); # 20 => dbd=2, so make it dbd=1
+ $l_10->bmul( $self->new($dbd)); # log(10) * (digits_before_dot-1)
+ my $dbd_sign = '+';
+ if ($dbd < 0)
+ {
+ $dbd = -$dbd;
+ $dbd_sign = '-';
+ }
+ ($x->{_e}, $x->{_es}) =
+ _e_sub( $x->{_e}, $MBI->_new($dbd), $x->{_es}, $dbd_sign); # 123 => 1.23
+
+ }
+
+ # Now: 0.1 <= $x < 10 (and possible correction in l_10)
+
+ ### Since $x in the range 0.5 .. 1.5 is MUCH faster, we do a repeated div
+ ### or mul by 2 (maximum times 3, since x < 10 and x > 0.1)
+
+ $HALF = $self->new($HALF) unless ref($HALF);
+
+ my $twos = 0; # default: none (0 times)
+ while ($x->bacmp($HALF) <= 0) # X <= 0.5
+ {
+ $twos--; $x->bmul($two);
+ }
+ while ($x->bacmp($two) >= 0) # X >= 2
+ {
+ $twos++; $x->bdiv($two,$scale+4); # keep all digits
+ }
+ # $twos > 0 => did mul 2, < 0 => did div 2 (but we never did both)
+ # So calculate correction factor based on ln(2):
+ if ($twos != 0)
+ {
+ $LOG_2 = $self->new($LOG_2,undef,undef) unless ref $LOG_2;
+ if ($scale <= $LOG_2_A)
+ {
+ # use cached value
+ $l_2 = $LOG_2->copy(); # copy() for the mul below
+ }
+ else
+ {
+ # else: slower, compute and cache result
+ # also disable downgrade for this code path
+ local $Math::BigFloat::downgrade = undef;
+ $l_2 = $two->copy(); $self->_log($l_2, $scale); # scale+4, actually
+ $LOG_2 = $l_2->copy(); # cache the result for later
+ # the copy() is for mul below
+ $LOG_2_A = $scale;
+ }
+ $l_2->bmul($twos); # * -2 => subtract, * 2 => add
+ }
+
+ $self->_log($x,$scale); # need to do the "normal" way
+ $x->badd($l_10) if defined $l_10; # correct it by ln(10)
+ $x->badd($l_2) if defined $l_2; # and maybe by ln(2)
+
+ # all done, $x contains now the result
+ $x;
+ }
+
+sub blcm
+ {
+ # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
+ # does not modify arguments, but returns new object
+ # Lowest Common Multiplicator
+
+ my ($self,@arg) = objectify(0,@_);
+ my $x = $self->new(shift @arg);
+ while (@arg) { $x = Math::BigInt::__lcm($x,shift @arg); }
+ $x;
+ }
+
+sub bgcd
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does not modify arguments, but returns new object
+
+ my $y = shift;
+ $y = __PACKAGE__->new($y) if !ref($y);
+ my $self = ref($y);
+ my $x = $y->copy()->babs(); # keep arguments
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]$/ # x NaN?
+ || !$x->is_int(); # only for integers now
+
+ while (@_)
+ {
+ my $t = shift; $t = $self->new($t) if !ref($t);
+ $y = $t->copy()->babs();
+
+ return $x->bnan() if $y->{sign} !~ /^[+-]$/ # y NaN?
+ || !$y->is_int(); # only for integers now
+
+ # greatest common divisor
+ while (! $y->is_zero())
+ {
+ ($x,$y) = ($y->copy(), $x->copy()->bmod($y));
+ }
+
+ last if $x->is_one();
+ }
+ $x;
+ }
+
+##############################################################################
+
+sub _e_add
+ {
+ # Internal helper sub to take two positive integers and their signs and
+ # then add them. Input ($CALC,$CALC,('+'|'-'),('+'|'-')),
+ # output ($CALC,('+'|'-'))
+ my ($x,$y,$xs,$ys) = @_;
+
+ # if the signs are equal we can add them (-5 + -3 => -(5 + 3) => -8)
+ if ($xs eq $ys)
+ {
+ $x = $MBI->_add ($x, $y ); # a+b
+ # the sign follows $xs
+ return ($x, $xs);
+ }
+
+ my $a = $MBI->_acmp($x,$y);
+ if ($a > 0)
+ {
+ $x = $MBI->_sub ($x , $y); # abs sub
+ }
+ elsif ($a == 0)
+ {
+ $x = $MBI->_zero(); # result is 0
+ $xs = '+';
+ }
+ else # a < 0
+ {
+ $x = $MBI->_sub ( $y, $x, 1 ); # abs sub
+ $xs = $ys;
+ }
+ ($x,$xs);
+ }
+
+sub _e_sub
+ {
+ # Internal helper sub to take two positive integers and their signs and
+ # then subtract them. Input ($CALC,$CALC,('+'|'-'),('+'|'-')),
+ # output ($CALC,('+'|'-'))
+ my ($x,$y,$xs,$ys) = @_;
+
+ # flip sign
+ $ys =~ tr/+-/-+/;
+ _e_add($x,$y,$xs,$ys); # call add (does subtract now)
+ }
+
+###############################################################################
+# is_foo methods (is_negative, is_positive are inherited from BigInt)
+
+sub is_int
+ {
+ # return true if arg (BFLOAT or num_str) is an integer
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ (($x->{sign} =~ /^[+-]$/) && # NaN and +-inf aren't
+ ($x->{_es} eq '+')) ? 1 : 0; # 1e-1 => no integer
+ }
+
+sub is_zero
+ {
+ # return true if arg (BFLOAT or num_str) is zero
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ ($x->{sign} eq '+' && $MBI->_is_zero($x->{_m})) ? 1 : 0;
+ }
+
+sub is_one
+ {
+ # return true if arg (BFLOAT or num_str) is +1 or -1 if signis given
+ my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $sign = '+' if !defined $sign || $sign ne '-';
+
+ ($x->{sign} eq $sign &&
+ $MBI->_is_zero($x->{_e}) &&
+ $MBI->_is_one($x->{_m}) ) ? 1 : 0;
+ }
+
+sub is_odd
+ {
+ # return true if arg (BFLOAT or num_str) is odd or false if even
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't
+ ($MBI->_is_zero($x->{_e})) &&
+ ($MBI->_is_odd($x->{_m}))) ? 1 : 0;
+ }
+
+sub is_even
+ {
+ # return true if arg (BINT or num_str) is even or false if odd
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't
+ ($x->{_es} eq '+') && # 123.45 isn't
+ ($MBI->_is_even($x->{_m}))) ? 1 : 0; # but 1200 is
+ }
+
+sub bmul
+ {
+ # multiply two numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmul');
+
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ return $upgrade->bmul($x,$y,@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ # aEb * cEd = (a*c)E(b+d)
+ $MBI->_mul($x->{_m},$y->{_m});
+ ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+
+ $r[3] = $y; # no push!
+
+ # adjust sign:
+ $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';
+ $x->bnorm->round(@r);
+ }
+
+sub bmuladd
+ {
+ # multiply two numbers and add the third to the result
+
+ # set up parameters
+ my ($self,$x,$y,$z,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$z,@r) = objectify(3,@_);
+ }
+
+ return $x if $x->modify('bmuladd');
+
+ return $x->bnan() if (($x->{sign} eq $nan) ||
+ ($y->{sign} eq $nan) ||
+ ($z->{sign} eq $nan));
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ return $upgrade->bmul($x,$y,@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ # aEb * cEd = (a*c)E(b+d)
+ $MBI->_mul($x->{_m},$y->{_m});
+ ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+
+ $r[3] = $y; # no push!
+
+ # adjust sign:
+ $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';
+
+ # z=inf handling (z=NaN handled above)
+ $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/;
+
+ # take lower of the two e's and adapt m1 to it to match m2
+ my $e = $z->{_e};
+ $e = $MBI->_zero() if !defined $e; # if no BFLOAT?
+ $e = $MBI->_copy($e); # make copy (didn't do it yet)
+
+ my $es;
+
+ ($e,$es) = _e_sub($e, $x->{_e}, $z->{_es} || '+', $x->{_es});
+
+ my $add = $MBI->_copy($z->{_m});
+
+ if ($es eq '-') # < 0
+ {
+ $MBI->_lsft( $x->{_m}, $e, 10);
+ ($x->{_e},$x->{_es}) = _e_add($x->{_e}, $e, $x->{_es}, $es);
+ }
+ elsif (!$MBI->_is_zero($e)) # > 0
+ {
+ $MBI->_lsft($add, $e, 10);
+ }
+ # else: both e are the same, so just leave them
+
+ if ($x->{sign} eq $z->{sign})
+ {
+ # add
+ $x->{_m} = $MBI->_add($x->{_m}, $add);
+ }
+ else
+ {
+ ($x->{_m}, $x->{sign}) =
+ _e_add($x->{_m}, $add, $x->{sign}, $z->{sign});
+ }
+
+ # delete trailing zeros, then round
+ $x->bnorm()->round(@r);
+ }
+
+sub bdiv
+ {
+ # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return
+ # (BFLOAT,BFLOAT) (quo,rem) or BFLOAT (only rem)
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bdiv');
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ # x== 0 # also: or y == 1 or y == -1
+ return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
+
+ # upgrade ?
+ return $upgrade->bdiv($upgrade->new($x),$y,$a,$p,$r) if defined $upgrade;
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my (@params,$scale);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r,$y);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ my $rem; $rem = $self->bzero() if wantarray;
+
+ $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
+ my $lx = $MBI->_len($x->{_m}); my $ly = $MBI->_len($y->{_m});
+ $scale = $lx if $lx > $scale;
+ $scale = $ly if $ly > $scale;
+ my $diff = $ly - $lx;
+ $scale += $diff if $diff > 0; # if lx << ly, but not if ly << lx!
+
+ # already handled inf/NaN/-inf above:
+
+ # check that $y is not 1 nor -1 and cache the result:
+ my $y_not_one = !($MBI->_is_zero($y->{_e}) && $MBI->_is_one($y->{_m}));
+
+ # flipping the sign of $y will also flip the sign of $x for the special
+ # case of $x->bsub($x); so we can catch it below:
+ my $xsign = $x->{sign};
+ $y->{sign} =~ tr/+-/-+/;
+
+ if ($xsign ne $x->{sign})
+ {
+ # special case of $x /= $x results in 1
+ $x->bone(); # "fixes" also sign of $y, since $x is $y
+ }
+ else
+ {
+ # correct $y's sign again
+ $y->{sign} =~ tr/+-/-+/;
+ # continue with normal div code:
+
+ # make copy of $x in case of list context for later reminder calculation
+ if (wantarray && $y_not_one)
+ {
+ $rem = $x->copy();
+ }
+
+ $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+';
+
+ # check for / +-1 ( +/- 1E0)
+ if ($y_not_one)
+ {
+ # promote BigInts and it's subclasses (except when already a BigFloat)
+ $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
+ # calculate the result to $scale digits and then round it
+ # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
+ $MBI->_lsft($x->{_m},$MBI->_new($scale),10);
+ $MBI->_div ($x->{_m},$y->{_m}); # a/c
+
+ # correct exponent of $x
+ ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+ # correct for 10**scale
+ ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $MBI->_new($scale), $x->{_es}, '+');
+ $x->bnorm(); # remove trailing 0's
+ }
+ } # ende else $x != $y
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ delete $x->{_a}; # clear before round
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ delete $x->{_p}; # clear before round
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+
+ if (wantarray)
+ {
+ if ($y_not_one)
+ {
+ $rem->bmod($y,@params); # copy already done
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $rem->{_a}; delete $rem->{_p};
+ }
+ return ($x,$rem);
+ }
+ $x;
+ }
+
+sub bmod
+ {
+ # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return reminder
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmod');
+
+ # handle NaN, inf, -inf
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ my ($d,$re) = $self->SUPER::_div_inf($x,$y);
+ $x->{sign} = $re->{sign};
+ $x->{_e} = $re->{_e};
+ $x->{_m} = $re->{_m};
+ return $x->round($a,$p,$r,$y);
+ }
+ if ($y->is_zero())
+ {
+ return $x->bnan() if $x->is_zero();
+ return $x;
+ }
+
+ return $x->bzero() if $x->is_zero()
+ || ($x->is_int() &&
+ # check that $y == +1 or $y == -1:
+ ($MBI->_is_zero($y->{_e}) && $MBI->_is_one($y->{_m})));
+
+ my $cmp = $x->bacmp($y); # equal or $x < $y?
+ return $x->bzero($a,$p) if $cmp == 0; # $x == $y => result 0
+
+ # only $y of the operands negative?
+ my $neg = 0; $neg = 1 if $x->{sign} ne $y->{sign};
+
+ $x->{sign} = $y->{sign}; # calc sign first
+ return $x->round($a,$p,$r) if $cmp < 0 && $neg == 0; # $x < $y => result $x
+
+ my $ym = $MBI->_copy($y->{_m});
+
+ # 2e1 => 20
+ $MBI->_lsft( $ym, $y->{_e}, 10)
+ if $y->{_es} eq '+' && !$MBI->_is_zero($y->{_e});
+
+ # if $y has digits after dot
+ my $shifty = 0; # correct _e of $x by this
+ if ($y->{_es} eq '-') # has digits after dot
+ {
+ # 123 % 2.5 => 1230 % 25 => 5 => 0.5
+ $shifty = $MBI->_num($y->{_e}); # no more digits after dot
+ $MBI->_lsft($x->{_m}, $y->{_e}, 10);# 123 => 1230, $y->{_m} is already 25
+ }
+ # $ym is now mantissa of $y based on exponent 0
+
+ my $shiftx = 0; # correct _e of $x by this
+ if ($x->{_es} eq '-') # has digits after dot
+ {
+ # 123.4 % 20 => 1234 % 200
+ $shiftx = $MBI->_num($x->{_e}); # no more digits after dot
+ $MBI->_lsft($ym, $x->{_e}, 10); # 123 => 1230
+ }
+ # 123e1 % 20 => 1230 % 20
+ if ($x->{_es} eq '+' && !$MBI->_is_zero($x->{_e}))
+ {
+ $MBI->_lsft( $x->{_m}, $x->{_e},10); # es => '+' here
+ }
+
+ $x->{_e} = $MBI->_new($shiftx);
+ $x->{_es} = '+';
+ $x->{_es} = '-' if $shiftx != 0 || $shifty != 0;
+ $MBI->_add( $x->{_e}, $MBI->_new($shifty)) if $shifty != 0;
+
+ # now mantissas are equalized, exponent of $x is adjusted, so calc result
+
+ $x->{_m} = $MBI->_mod( $x->{_m}, $ym);
+
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # fix sign for -0
+ $x->bnorm();
+
+ if ($neg != 0) # one of them negative => correct in place
+ {
+ my $r = $y - $x;
+ $x->{_m} = $r->{_m};
+ $x->{_e} = $r->{_e};
+ $x->{_es} = $r->{_es};
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # fix sign for -0
+ $x->bnorm();
+ }
+
+ $x->round($a,$p,$r,$y); # round and return
+ }
+
+sub broot
+ {
+ # calculate $y'th root of $x
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('broot');
+
+ # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0
+ return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() ||
+ $y->{sign} !~ /^\+$/;
+
+ return $x if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one();
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my (@params,$scale);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # iound mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef; # should be really parent class vs MBI
+
+ # remember sign and make $x positive, since -4 ** (1/2) => -2
+ my $sign = 0; $sign = 1 if $x->{sign} eq '-'; $x->{sign} = '+';
+
+ my $is_two = 0;
+ if ($y->isa('Math::BigFloat'))
+ {
+ $is_two = ($y->{sign} eq '+' && $MBI->_is_two($y->{_m}) && $MBI->_is_zero($y->{_e}));
+ }
+ else
+ {
+ $is_two = ($y == 2);
+ }
+
+ # normal square root if $y == 2:
+ if ($is_two)
+ {
+ $x->bsqrt($scale+4);
+ }
+ elsif ($y->is_one('-'))
+ {
+ # $x ** -1 => 1/$x
+ my $u = $self->bone()->bdiv($x,$scale);
+ # copy private parts over
+ $x->{_m} = $u->{_m};
+ $x->{_e} = $u->{_e};
+ $x->{_es} = $u->{_es};
+ }
+ else
+ {
+ # calculate the broot() as integer result first, and if it fits, return
+ # it rightaway (but only if $x and $y are integer):
+
+ my $done = 0; # not yet
+ if ($y->is_int() && $x->is_int())
+ {
+ my $i = $MBI->_copy( $x->{_m} );
+ $MBI->_lsft( $i, $x->{_e}, 10 ) unless $MBI->_is_zero($x->{_e});
+ my $int = Math::BigInt->bzero();
+ $int->{value} = $i;
+ $int->broot($y->as_number());
+ # if ($exact)
+ if ($int->copy()->bpow($y) == $x)
+ {
+ # found result, return it
+ $x->{_m} = $int->{value};
+ $x->{_e} = $MBI->_zero();
+ $x->{_es} = '+';
+ $x->bnorm();
+ $done = 1;
+ }
+ }
+ if ($done == 0)
+ {
+ my $u = $self->bone()->bdiv($y,$scale+4);
+ delete $u->{_a}; delete $u->{_p}; # otherwise it conflicts
+ $x->bpow($u,$scale+4); # el cheapo
+ }
+ }
+ $x->bneg() if $sign == 1;
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bsqrt
+ {
+ # calculate square root
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bsqrt');
+
+ return $x->bnan() if $x->{sign} !~ /^[+]/; # NaN, -inf or < 0
+ return $x if $x->{sign} eq '+inf'; # sqrt(inf) == inf
+ return $x->round($a,$p,$r) if $x->is_zero() || $x->is_one();
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my (@params,$scale);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef; # should be really parent class vs MBI
+
+ my $i = $MBI->_copy( $x->{_m} );
+ $MBI->_lsft( $i, $x->{_e}, 10 ) unless $MBI->_is_zero($x->{_e});
+ my $xas = Math::BigInt->bzero();
+ $xas->{value} = $i;
+
+ my $gs = $xas->copy()->bsqrt(); # some guess
+
+ if (($x->{_es} ne '-') # guess can't be accurate if there are
+ # digits after the dot
+ && ($xas->bacmp($gs * $gs) == 0)) # guess hit the nail on the head?
+ {
+ # exact result, copy result over to keep $x
+ $x->{_m} = $gs->{value}; $x->{_e} = $MBI->_zero(); $x->{_es} = '+';
+ $x->bnorm();
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # re-enable A and P, upgrade is taken care of by "local"
+ ${"$self\::accuracy"} = $ab; ${"$self\::precision"} = $pb;
+ return $x;
+ }
+
+ # sqrt(2) = 1.4 because sqrt(2*100) = 1.4*10; so we can increase the accuracy
+ # of the result by multipyling the input by 100 and then divide the integer
+ # result of sqrt(input) by 10. Rounding afterwards returns the real result.
+
+ # The following steps will transform 123.456 (in $x) into 123456 (in $y1)
+ my $y1 = $MBI->_copy($x->{_m});
+
+ my $length = $MBI->_len($y1);
+
+ # Now calculate how many digits the result of sqrt(y1) would have
+ my $digits = int($length / 2);
+
+ # But we need at least $scale digits, so calculate how many are missing
+ my $shift = $scale - $digits;
+
+ # This happens if the input had enough digits
+ # (we take care of integer guesses above)
+ $shift = 0 if $shift < 0;
+
+ # Multiply in steps of 100, by shifting left two times the "missing" digits
+ my $s2 = $shift * 2;
+
+ # We now make sure that $y1 has the same odd or even number of digits than
+ # $x had. So when _e of $x is odd, we must shift $y1 by one digit left,
+ # because we always must multiply by steps of 100 (sqrt(100) is 10) and not
+ # steps of 10. The length of $x does not count, since an even or odd number
+ # of digits before the dot is not changed by adding an even number of digits
+ # after the dot (the result is still odd or even digits long).
+ $s2++ if $MBI->_is_odd($x->{_e});
+
+ $MBI->_lsft( $y1, $MBI->_new($s2), 10);
+
+ # now take the square root and truncate to integer
+ $y1 = $MBI->_sqrt($y1);
+
+ # By "shifting" $y1 right (by creating a negative _e) we calculate the final
+ # result, which is than later rounded to the desired scale.
+
+ # calculate how many zeros $x had after the '.' (or before it, depending
+ # on sign of $dat, the result should have half as many:
+ my $dat = $MBI->_num($x->{_e});
+ $dat = -$dat if $x->{_es} eq '-';
+ $dat += $length;
+
+ if ($dat > 0)
+ {
+ # no zeros after the dot (e.g. 1.23, 0.49 etc)
+ # preserve half as many digits before the dot than the input had
+ # (but round this "up")
+ $dat = int(($dat+1)/2);
+ }
+ else
+ {
+ $dat = int(($dat)/2);
+ }
+ $dat -= $MBI->_len($y1);
+ if ($dat < 0)
+ {
+ $dat = abs($dat);
+ $x->{_e} = $MBI->_new( $dat );
+ $x->{_es} = '-';
+ }
+ else
+ {
+ $x->{_e} = $MBI->_new( $dat );
+ $x->{_es} = '+';
+ }
+ $x->{_m} = $y1;
+ $x->bnorm();
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bfac
+ {
+ # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
+ # compute factorial number, modifies first argument
+
+ # set up parameters
+ my ($self,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ ($self,$x,@r) = objectify(1,@_) if !ref($x);
+
+ # inf => inf
+ return $x if $x->modify('bfac') || $x->{sign} eq '+inf';
+
+ return $x->bnan()
+ if (($x->{sign} ne '+') || # inf, NaN, <0 etc => NaN
+ ($x->{_es} ne '+')); # digits after dot?
+
+ # use BigInt's bfac() for faster calc
+ if (! $MBI->_is_zero($x->{_e}))
+ {
+ $MBI->_lsft($x->{_m}, $x->{_e},10); # change 12e1 to 120e0
+ $x->{_e} = $MBI->_zero(); # normalize
+ $x->{_es} = '+';
+ }
+ $MBI->_fac($x->{_m}); # calculate factorial
+ $x->bnorm()->round(@r); # norm again and round result
+ }
+
+sub _pow
+ {
+ # Calculate a power where $y is a non-integer, like 2 ** 0.3
+ my ($x,$y,@r) = @_;
+ my $self = ref($x);
+
+ # if $y == 0.5, it is sqrt($x)
+ $HALF = $self->new($HALF) unless ref($HALF);
+ return $x->bsqrt(@r,$y) if $y->bcmp($HALF) == 0;
+
+ # Using:
+ # a ** x == e ** (x * ln a)
+
+ # u = y * ln x
+ # _ _
+ # Taylor: | u u^2 u^3 |
+ # x ** y = 1 + | --- + --- + ----- + ... |
+ # |_ 1 1*2 1*2*3 _|
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my ($limit,$v,$u,$below,$factor,$next,$over);
+
+ $u = $x->copy()->blog(undef,$scale)->bmul($y);
+ $v = $self->bone(); # 1
+ $factor = $self->new(2); # 2
+ $x->bone(); # first term: 1
+
+ $below = $v->copy();
+ $over = $u->copy();
+
+ $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+ $x->badd($next);
+ # calculate things for the next term
+ $over *= $u; $below *= $factor; $factor->binc();
+
+ last if $x->{sign} !~ /^[-+]$/;
+
+ #$steps++;
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bpow
+ {
+ # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
+ # compute power of two numbers, second arg is used as integer
+ # modifies first argument
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bpow');
+
+ return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
+ return $x if $x->{sign} =~ /^[+-]inf$/;
+
+ # cache the result of is_zero
+ my $y_is_zero = $y->is_zero();
+ return $x->bone() if $y_is_zero;
+ return $x if $x->is_one() || $y->is_one();
+
+ my $x_is_zero = $x->is_zero();
+ return $x->_pow($y,$a,$p,$r) if !$x_is_zero && !$y->is_int(); # non-integer power
+
+ my $y1 = $y->as_number()->{value}; # make MBI part
+
+ # if ($x == -1)
+ if ($x->{sign} eq '-' && $MBI->_is_one($x->{_m}) && $MBI->_is_zero($x->{_e}))
+ {
+ # if $x == -1 and odd/even y => +1/-1 because +-1 ^ (+-1) => +-1
+ return $MBI->_is_odd($y1) ? $x : $x->babs(1);
+ }
+ if ($x_is_zero)
+ {
+ return $x if $y->{sign} eq '+'; # 0**y => 0 (if not y <= 0)
+ # 0 ** -y => 1 / (0 ** y) => 1 / 0! (1 / 0 => +inf)
+ return $x->binf();
+ }
+
+ my $new_sign = '+';
+ $new_sign = $MBI->_is_odd($y1) ? '-' : '+' if $x->{sign} ne '+';
+
+ # calculate $x->{_m} ** $y and $x->{_e} * $y separately (faster)
+ $x->{_m} = $MBI->_pow( $x->{_m}, $y1);
+ $x->{_e} = $MBI->_mul ($x->{_e}, $y1);
+
+ $x->{sign} = $new_sign;
+ $x->bnorm();
+ if ($y->{sign} eq '-')
+ {
+ # modify $x in place!
+ my $z = $x->copy(); $x->bone();
+ return scalar $x->bdiv($z,$a,$p,$r); # round in one go (might ignore y's A!)
+ }
+ $x->round($a,$p,$r,$y);
+ }
+
+sub bmodpow
+ {
+ # takes a very large number to a very large exponent in a given very
+ # large modulus, quickly, thanks to binary exponentation. Supports
+ # negative exponents.
+ my ($self,$num,$exp,$mod,@r) = objectify(3,@_);
+
+ return $num if $num->modify('bmodpow');
+
+ # check modulus for valid values
+ return $num->bnan() if ($mod->{sign} ne '+' # NaN, - , -inf, +inf
+ || $mod->is_zero());
+
+ # check exponent for valid values
+ if ($exp->{sign} =~ /\w/)
+ {
+ # i.e., if it's NaN, +inf, or -inf...
+ return $num->bnan();
+ }
+
+ $num->bmodinv ($mod) if ($exp->{sign} eq '-');
+
+ # check num for valid values (also NaN if there was no inverse but $exp < 0)
+ return $num->bnan() if $num->{sign} !~ /^[+-]$/;
+
+ # $mod is positive, sign on $exp is ignored, result also positive
+
+ # XXX TODO: speed it up when all three numbers are integers
+ $num->bpow($exp)->bmod($mod);
+ }
+
+###############################################################################
+# trigonometric functions
+
+# helper function for bpi() and batan2(), calculates arcus tanges (1/x)
+
+sub _atan_inv
+ {
+ # return a/b so that a/b approximates atan(1/x) to at least limit digits
+ my ($self, $x, $limit) = @_;
+
+ # Taylor: x^3 x^5 x^7 x^9
+ # atan = x - --- + --- - --- + --- - ...
+ # 3 5 7 9
+
+ # 1 1 1 1
+ # atan 1/x = - - ------- + ------- - ------- + ...
+ # x x^3 * 3 x^5 * 5 x^7 * 7
+
+ # 1 1 1 1
+ # atan 1/x = - - --------- + ---------- - ----------- + ...
+ # 5 3 * 125 5 * 3125 7 * 78125
+
+ # Subtraction/addition of a rational:
+
+ # 5 7 5*3 +- 7*4
+ # - +- - = ----------
+ # 4 3 4*3
+
+ # Term: N N+1
+ #
+ # a 1 a * d * c +- b
+ # ----- +- ------------------ = ----------------
+ # b d * c b * d * c
+
+ # since b1 = b0 * (d-2) * c
+
+ # a 1 a * d +- b / c
+ # ----- +- ------------------ = ----------------
+ # b d * c b * d
+
+ # and d = d + 2
+ # and c = c * x * x
+
+ # u = d * c
+ # stop if length($u) > limit
+ # a = a * u +- b
+ # b = b * u
+ # d = d + 2
+ # c = c * x * x
+ # sign = 1 - sign
+
+ my $a = $MBI->_one();
+ my $b = $MBI->_copy($x);
+
+ my $x2 = $MBI->_mul( $MBI->_copy($x), $b); # x2 = x * x
+ my $d = $MBI->_new( 3 ); # d = 3
+ my $c = $MBI->_mul( $MBI->_copy($x), $x2); # c = x ^ 3
+ my $two = $MBI->_new( 2 );
+
+ # run the first step unconditionally
+ my $u = $MBI->_mul( $MBI->_copy($d), $c);
+ $a = $MBI->_mul($a, $u);
+ $a = $MBI->_sub($a, $b);
+ $b = $MBI->_mul($b, $u);
+ $d = $MBI->_add($d, $two);
+ $c = $MBI->_mul($c, $x2);
+
+ # a is now a * (d-3) * c
+ # b is now b * (d-2) * c
+
+ # run the second step unconditionally
+ $u = $MBI->_mul( $MBI->_copy($d), $c);
+ $a = $MBI->_mul($a, $u);
+ $a = $MBI->_add($a, $b);
+ $b = $MBI->_mul($b, $u);
+ $d = $MBI->_add($d, $two);
+ $c = $MBI->_mul($c, $x2);
+
+ # a is now a * (d-3) * (d-5) * c * c
+ # b is now b * (d-2) * (d-4) * c * c
+
+ # so we can remove c * c from both a and b to shorten the numbers involved:
+ $a = $MBI->_div($a, $x2);
+ $b = $MBI->_div($b, $x2);
+ $a = $MBI->_div($a, $x2);
+ $b = $MBI->_div($b, $x2);
+
+# my $step = 0;
+ my $sign = 0; # 0 => -, 1 => +
+ while (3 < 5)
+ {
+# $step++;
+# if (($i++ % 100) == 0)
+# {
+# print "a=",$MBI->_str($a),"\n";
+# print "b=",$MBI->_str($b),"\n";
+# }
+# print "d=",$MBI->_str($d),"\n";
+# print "x2=",$MBI->_str($x2),"\n";
+# print "c=",$MBI->_str($c),"\n";
+
+ my $u = $MBI->_mul( $MBI->_copy($d), $c);
+ # use _alen() for libs like GMP where _len() would be O(N^2)
+ last if $MBI->_alen($u) > $limit;
+ my ($bc,$r) = $MBI->_div( $MBI->_copy($b), $c);
+ if ($MBI->_is_zero($r))
+ {
+ # b / c is an integer, so we can remove c from all terms
+ # this happens almost every time:
+ $a = $MBI->_mul($a, $d);
+ $a = $MBI->_sub($a, $bc) if $sign == 0;
+ $a = $MBI->_add($a, $bc) if $sign == 1;
+ $b = $MBI->_mul($b, $d);
+ }
+ else
+ {
+ # b / c is not an integer, so we keep c in the terms
+ # this happens very rarely, for instance for x = 5, this happens only
+ # at the following steps:
+ # 1, 5, 14, 32, 72, 157, 340, ...
+ $a = $MBI->_mul($a, $u);
+ $a = $MBI->_sub($a, $b) if $sign == 0;
+ $a = $MBI->_add($a, $b) if $sign == 1;
+ $b = $MBI->_mul($b, $u);
+ }
+ $d = $MBI->_add($d, $two);
+ $c = $MBI->_mul($c, $x2);
+ $sign = 1 - $sign;
+
+ }
+
+# print "Took $step steps for ", $MBI->_str($x),"\n";
+# print "a=",$MBI->_str($a),"\n"; print "b=",$MBI->_str($b),"\n";
+ # return a/b so that a/b approximates atan(1/x)
+ ($a,$b);
+ }
+
+sub bpi
+ {
+ my ($self,$n) = @_;
+ if (@_ == 0)
+ {
+ $self = $class;
+ }
+ if (@_ == 1)
+ {
+ # called like Math::BigFloat::bpi(10);
+ $n = $self; $self = $class;
+ # called like Math::BigFloat->bpi();
+ $n = undef if $n eq 'Math::BigFloat';
+ }
+ $self = ref($self) if ref($self);
+ my $fallback = defined $n ? 0 : 1;
+ $n = 40 if !defined $n || $n < 1;
+
+ # after 黃見利 (Hwang Chien-Lih) (1997)
+ # pi/4 = 183 * atan(1/239) + 32 * atan(1/1023) – 68 * atan(1/5832)
+ # + 12 * atan(1/110443) - 12 * atan(1/4841182) - 100 * atan(1/6826318)
+
+ # a few more to prevent rounding errors
+ $n += 4;
+
+ my ($a,$b) = $self->_atan_inv( $MBI->_new(239),$n);
+ my ($c,$d) = $self->_atan_inv( $MBI->_new(1023),$n);
+ my ($e,$f) = $self->_atan_inv( $MBI->_new(5832),$n);
+ my ($g,$h) = $self->_atan_inv( $MBI->_new(110443),$n);
+ my ($i,$j) = $self->_atan_inv( $MBI->_new(4841182),$n);
+ my ($k,$l) = $self->_atan_inv( $MBI->_new(6826318),$n);
+
+ $MBI->_mul($a, $MBI->_new(732));
+ $MBI->_mul($c, $MBI->_new(128));
+ $MBI->_mul($e, $MBI->_new(272));
+ $MBI->_mul($g, $MBI->_new(48));
+ $MBI->_mul($i, $MBI->_new(48));
+ $MBI->_mul($k, $MBI->_new(400));
+
+ my $x = $self->bone(); $x->{_m} = $a; my $x_d = $self->bone(); $x_d->{_m} = $b;
+ my $y = $self->bone(); $y->{_m} = $c; my $y_d = $self->bone(); $y_d->{_m} = $d;
+ my $z = $self->bone(); $z->{_m} = $e; my $z_d = $self->bone(); $z_d->{_m} = $f;
+ my $u = $self->bone(); $u->{_m} = $g; my $u_d = $self->bone(); $u_d->{_m} = $h;
+ my $v = $self->bone(); $v->{_m} = $i; my $v_d = $self->bone(); $v_d->{_m} = $j;
+ my $w = $self->bone(); $w->{_m} = $k; my $w_d = $self->bone(); $w_d->{_m} = $l;
+ $x->bdiv($x_d, $n);
+ $y->bdiv($y_d, $n);
+ $z->bdiv($z_d, $n);
+ $u->bdiv($u_d, $n);
+ $v->bdiv($v_d, $n);
+ $w->bdiv($w_d, $n);
+
+ delete $x->{_a}; delete $y->{_a}; delete $z->{_a};
+ delete $u->{_a}; delete $v->{_a}; delete $w->{_a};
+ $x->badd($y)->bsub($z)->badd($u)->bsub($v)->bsub($w);
+
+ $x->bround($n-4);
+ delete $x->{_a} if $fallback == 1;
+ $x;
+ }
+
+sub bcos
+ {
+ # Calculate a cosinus of x.
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ # Taylor: x^2 x^4 x^6 x^8
+ # cos = 1 - --- + --- - --- + --- ...
+ # 2! 4! 6! 8!
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # constant object or error in _find_round_parameters?
+ return $x if $x->modify('bcos') || $x->is_nan();
+
+ return $x->bone(@r) if $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my $last = 0;
+ my $over = $x * $x; # X ^ 2
+ my $x2 = $over->copy(); # X ^ 2; difference between terms
+ my $sign = 1; # start with -=
+ my $below = $self->new(2); my $factorial = $self->new(3);
+ $x->bone(); delete $x->{_a}; delete $x->{_p};
+
+ my $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ my $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+
+ if ($sign == 0)
+ {
+ $x->badd($next);
+ }
+ else
+ {
+ $x->bsub($next);
+ }
+ $sign = 1-$sign; # alternate
+ # calculate things for the next term
+ $over->bmul($x2); # $x*$x
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bsin
+ {
+ # Calculate a sinus of x.
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ # taylor: x^3 x^5 x^7 x^9
+ # sin = x - --- + --- - --- + --- ...
+ # 3! 5! 7! 9!
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # constant object or error in _find_round_parameters?
+ return $x if $x->modify('bsin') || $x->is_nan();
+
+ return $x->bzero(@r) if $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my $last = 0;
+ my $over = $x * $x; # X ^ 2
+ my $x2 = $over->copy(); # X ^ 2; difference between terms
+ $over->bmul($x); # X ^ 3 as starting value
+ my $sign = 1; # start with -=
+ my $below = $self->new(6); my $factorial = $self->new(4);
+ delete $x->{_a}; delete $x->{_p};
+
+ my $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ my $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+
+ if ($sign == 0)
+ {
+ $x->badd($next);
+ }
+ else
+ {
+ $x->bsub($next);
+ }
+ $sign = 1-$sign; # alternate
+ # calculate things for the next term
+ $over->bmul($x2); # $x*$x
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub batan2
+ {
+ # calculate arcus tangens of ($y/$x)
+
+ # set up parameters
+ my ($self,$y,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$y,$x,@r) = objectify(2,@_);
+ }
+
+ return $y if $y->modify('batan2');
+
+ return $y->bnan() if ($y->{sign} eq $nan) || ($x->{sign} eq $nan);
+
+ # Y X
+ # 0 0 result is 0
+ # 0 +x result is 0
+ # ? inf result is 0
+ return $y->bzero(@r) if ($x->is_inf('+') && !$y->is_inf()) || ($y->is_zero() && $x->{sign} eq '+');
+
+ # Y X
+ # != 0 -inf result is +- pi
+ if ($x->is_inf() || $y->is_inf())
+ {
+ # calculate PI
+ my $pi = $self->bpi(@r);
+ if ($y->is_inf())
+ {
+ # upgrade to BigRat etc.
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+ if ($x->{sign} eq '-inf')
+ {
+ # calculate 3 pi/4
+ $MBI->_mul($pi->{_m}, $MBI->_new(3));
+ $MBI->_div($pi->{_m}, $MBI->_new(4));
+ }
+ elsif ($x->{sign} eq '+inf')
+ {
+ # calculate pi/4
+ $MBI->_div($pi->{_m}, $MBI->_new(4));
+ }
+ else
+ {
+ # calculate pi/2
+ $MBI->_div($pi->{_m}, $MBI->_new(2));
+ }
+ $y->{sign} = substr($y->{sign},0,1); # keep +/-
+ }
+ # modify $y in place
+ $y->{_m} = $pi->{_m};
+ $y->{_e} = $pi->{_e};
+ $y->{_es} = $pi->{_es};
+ # keep the sign of $y
+ return $y;
+ }
+
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+
+ # Y X
+ # 0 -x result is PI
+ if ($y->is_zero())
+ {
+ # calculate PI
+ my $pi = $self->bpi(@r);
+ # modify $y in place
+ $y->{_m} = $pi->{_m};
+ $y->{_e} = $pi->{_e};
+ $y->{_es} = $pi->{_es};
+ $y->{sign} = '+';
+ return $y;
+ }
+
+ # Y X
+ # +y 0 result is PI/2
+ # -y 0 result is -PI/2
+ if ($x->is_zero())
+ {
+ # calculate PI/2
+ my $pi = $self->bpi(@r);
+ # modify $y in place
+ $y->{_m} = $pi->{_m};
+ $y->{_e} = $pi->{_e};
+ $y->{_es} = $pi->{_es};
+ # -y => -PI/2, +y => PI/2
+ $MBI->_div($y->{_m}, $MBI->_new(2));
+ return $y;
+ }
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($y,@params) = $y->_find_round_parameters(@r);
+
+ # error in _find_round_parameters?
+ return $y if $y->is_nan();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # inlined is_one() && is_one('-')
+ if ($MBI->_is_one($y->{_m}) && $MBI->_is_zero($y->{_e}))
+ {
+ # shortcut: 1 1 result is PI/4
+ # inlined is_one() && is_one('-')
+ if ($MBI->_is_one($x->{_m}) && $MBI->_is_zero($x->{_e}))
+ {
+ # 1,1 => PI/4
+ my $pi_4 = $self->bpi( $scale - 3);
+ # modify $y in place
+ $y->{_m} = $pi_4->{_m};
+ $y->{_e} = $pi_4->{_e};
+ $y->{_es} = $pi_4->{_es};
+ # 1 1 => +
+ # -1 1 => -
+ # 1 -1 => -
+ # -1 -1 => +
+ $y->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
+ $MBI->_div($y->{_m}, $MBI->_new(4));
+ return $y;
+ }
+ # shortcut: 1 int(X) result is _atan_inv(X)
+
+ # is integer
+ if ($x->{_es} eq '+')
+ {
+ my $x1 = $MBI->_copy($x->{_m});
+ $MBI->_lsft($x1, $x->{_e},10) unless $MBI->_is_zero($x->{_e});
+
+ my ($a,$b) = $self->_atan_inv($x1, $scale);
+ my $y_sign = $y->{sign};
+ # calculate A/B
+ $y->bone(); $y->{_m} = $a; my $y_d = $self->bone(); $y_d->{_m} = $b;
+ $y->bdiv($y_d, @r);
+ $y->{sign} = $y_sign;
+ return $y;
+ }
+ }
+
+ # handle all other cases
+ # X Y
+ # +x +y 0 to PI/2
+ # -x +y PI/2 to PI
+ # +x -y 0 to -PI/2
+ # -x -y -PI/2 to -PI
+
+ my $y_sign = $y->{sign};
+
+ # divide $x by $y
+ $y->bdiv($x, $scale) unless $x->is_one();
+ $y->batan(@r);
+
+ # restore sign
+ $y->{sign} = $y_sign;
+
+ $y;
+ }
+
+sub batan
+ {
+ # Calculate a arcus tangens of x.
+ my ($x,@r) = @_;
+ my $self = ref($x);
+
+ # taylor: x^3 x^5 x^7 x^9
+ # atan = x - --- + --- - --- + --- ...
+ # 3 5 7 9
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # constant object or error in _find_round_parameters?
+ return $x if $x->modify('batan') || $x->is_nan();
+
+ if ($x->{sign} =~ /^[+-]inf\z/)
+ {
+ # +inf result is PI/2
+ # -inf result is -PI/2
+ # calculate PI/2
+ my $pi = $self->bpi(@r);
+ # modify $x in place
+ $x->{_m} = $pi->{_m};
+ $x->{_e} = $pi->{_e};
+ $x->{_es} = $pi->{_es};
+ # -y => -PI/2, +y => PI/2
+ $x->{sign} = substr($x->{sign},0,1); # +inf => +
+ $MBI->_div($x->{_m}, $MBI->_new(2));
+ return $x;
+ }
+
+ return $x->bzero(@r) if $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # 1 or -1 => PI/4
+ # inlined is_one() && is_one('-')
+ if ($MBI->_is_one($x->{_m}) && $MBI->_is_zero($x->{_e}))
+ {
+ my $pi = $self->bpi($scale - 3);
+ # modify $x in place
+ $x->{_m} = $pi->{_m};
+ $x->{_e} = $pi->{_e};
+ $x->{_es} = $pi->{_es};
+ # leave the sign of $x alone (+1 => +PI/4, -1 => -PI/4)
+ $MBI->_div($x->{_m}, $MBI->_new(4));
+ return $x;
+ }
+
+ # This series is only valid if -1 < x < 1, so for other x we need to
+ # to calculate PI/2 - atan(1/x):
+ my $one = $MBI->_new(1);
+ my $pi = undef;
+ if ($x->{_es} eq '+' && ($MBI->_acmp($x->{_m},$one) >= 0))
+ {
+ # calculate PI/2
+ $pi = $self->bpi($scale - 3);
+ $MBI->_div($pi->{_m}, $MBI->_new(2));
+ # calculate 1/$x:
+ my $x_copy = $x->copy();
+ # modify $x in place
+ $x->bone(); $x->bdiv($x_copy,$scale);
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my $last = 0;
+ my $over = $x * $x; # X ^ 2
+ my $x2 = $over->copy(); # X ^ 2; difference between terms
+ $over->bmul($x); # X ^ 3 as starting value
+ my $sign = 1; # start with -=
+ my $below = $self->new(3);
+ my $two = $self->new(2);
+ delete $x->{_a}; delete $x->{_p};
+
+ my $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ my $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+
+ if ($sign == 0)
+ {
+ $x->badd($next);
+ }
+ else
+ {
+ $x->bsub($next);
+ }
+ $sign = 1-$sign; # alternate
+ # calculate things for the next term
+ $over->bmul($x2); # $x*$x
+ $below->badd($two); # n += 2
+ }
+
+ if (defined $pi)
+ {
+ my $x_copy = $x->copy();
+ # modify $x in place
+ $x->{_m} = $pi->{_m};
+ $x->{_e} = $pi->{_e};
+ $x->{_es} = $pi->{_es};
+ # PI/2 - $x
+ $x->bsub($x_copy);
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+###############################################################################
+# rounding functions
+
+sub bfround
+ {
+ # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
+ # $n == 0 means round to integer
+ # expects and returns normalized numbers!
+ my $x = shift; my $self = ref($x) || $x; $x = $self->new(shift) if !ref($x);
+
+ my ($scale,$mode) = $x->_scale_p(@_);
+ return $x if !defined $scale || $x->modify('bfround'); # no-op
+
+ # never round a 0, +-inf, NaN
+ if ($x->is_zero())
+ {
+ $x->{_p} = $scale if !defined $x->{_p} || $x->{_p} < $scale; # -3 < -2
+ return $x;
+ }
+ return $x if $x->{sign} !~ /^[+-]$/;
+
+ # don't round if x already has lower precision
+ return $x if (defined $x->{_p} && $x->{_p} < 0 && $scale < $x->{_p});
+
+ $x->{_p} = $scale; # remember round in any case
+ delete $x->{_a}; # and clear A
+ if ($scale < 0)
+ {
+ # round right from the '.'
+
+ return $x if $x->{_es} eq '+'; # e >= 0 => nothing to round
+
+ $scale = -$scale; # positive for simplicity
+ my $len = $MBI->_len($x->{_m}); # length of mantissa
+
+ # the following poses a restriction on _e, but if _e is bigger than a
+ # scalar, you got other problems (memory etc) anyway
+ my $dad = -(0+ ($x->{_es}.$MBI->_num($x->{_e}))); # digits after dot
+ my $zad = 0; # zeros after dot
+ $zad = $dad - $len if (-$dad < -$len); # for 0.00..00xxx style
+
+ # p rint "scale $scale dad $dad zad $zad len $len\n";
+ # number bsstr len zad dad
+ # 0.123 123e-3 3 0 3
+ # 0.0123 123e-4 3 1 4
+ # 0.001 1e-3 1 2 3
+ # 1.23 123e-2 3 0 2
+ # 1.2345 12345e-4 5 0 4
+
+ # do not round after/right of the $dad
+ return $x if $scale > $dad; # 0.123, scale >= 3 => exit
+
+ # round to zero if rounding inside the $zad, but not for last zero like:
+ # 0.0065, scale -2, round last '0' with following '65' (scale == zad case)
+ return $x->bzero() if $scale < $zad;
+ if ($scale == $zad) # for 0.006, scale -3 and trunc
+ {
+ $scale = -$len;
+ }
+ else
+ {
+ # adjust round-point to be inside mantissa
+ if ($zad != 0)
+ {
+ $scale = $scale-$zad;
+ }
+ else
+ {
+ my $dbd = $len - $dad; $dbd = 0 if $dbd < 0; # digits before dot
+ $scale = $dbd+$scale;
+ }
+ }
+ }
+ else
+ {
+ # round left from the '.'
+
+ # 123 => 100 means length(123) = 3 - $scale (2) => 1
+
+ my $dbt = $MBI->_len($x->{_m});
+ # digits before dot
+ my $dbd = $dbt + ($x->{_es} . $MBI->_num($x->{_e}));
+ # should be the same, so treat it as this
+ $scale = 1 if $scale == 0;
+ # shortcut if already integer
+ return $x if $scale == 1 && $dbt <= $dbd;
+ # maximum digits before dot
+ ++$dbd;
+
+ if ($scale > $dbd)
+ {
+ # not enough digits before dot, so round to zero
+ return $x->bzero;
+ }
+ elsif ( $scale == $dbd )
+ {
+ # maximum
+ $scale = -$dbt;
+ }
+ else
+ {
+ $scale = $dbd - $scale;
+ }
+ }
+ # pass sign to bround for rounding modes '+inf' and '-inf'
+ my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt';
+ $m->bround($scale,$mode);
+ $x->{_m} = $m->{value}; # get our mantissa back
+ $x->bnorm();
+ }
+
+sub bround
+ {
+ # accuracy: preserve $N digits, and overwrite the rest with 0's
+ my $x = shift; my $self = ref($x) || $x; $x = $self->new(shift) if !ref($x);
+
+ if (($_[0] || 0) < 0)
+ {
+ require Carp; Carp::croak ('bround() needs positive accuracy');
+ }
+
+ my ($scale,$mode) = $x->_scale_a(@_);
+ return $x if !defined $scale || $x->modify('bround'); # no-op
+
+ # scale is now either $x->{_a}, $accuracy, or the user parameter
+ # test whether $x already has lower accuracy, do nothing in this case
+ # but do round if the accuracy is the same, since a math operation might
+ # want to round a number with A=5 to 5 digits afterwards again
+ return $x if defined $x->{_a} && $x->{_a} < $scale;
+
+ # scale < 0 makes no sense
+ # scale == 0 => keep all digits
+ # never round a +-inf, NaN
+ return $x if ($scale <= 0) || $x->{sign} !~ /^[+-]$/;
+
+ # 1: never round a 0
+ # 2: if we should keep more digits than the mantissa has, do nothing
+ if ($x->is_zero() || $MBI->_len($x->{_m}) <= $scale)
+ {
+ $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale;
+ return $x;
+ }
+
+ # pass sign to bround for '+inf' and '-inf' rounding modes
+ my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt';
+
+ $m->bround($scale,$mode); # round mantissa
+ $x->{_m} = $m->{value}; # get our mantissa back
+ $x->{_a} = $scale; # remember rounding
+ delete $x->{_p}; # and clear P
+ $x->bnorm(); # del trailing zeros gen. by bround()
+ }
+
+sub bfloor
+ {
+ # return integer less or equal then $x
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bfloor');
+
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ # if $x has digits after dot
+ if ($x->{_es} eq '-')
+ {
+ $x->{_m} = $MBI->_rsft($x->{_m},$x->{_e},10); # cut off digits after dot
+ $x->{_e} = $MBI->_zero(); # trunc/norm
+ $x->{_es} = '+'; # abs e
+ $MBI->_inc($x->{_m}) if $x->{sign} eq '-'; # increment if negative
+ }
+ $x->round($a,$p,$r);
+ }
+
+sub bceil
+ {
+ # return integer greater or equal then $x
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bceil');
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ # if $x has digits after dot
+ if ($x->{_es} eq '-')
+ {
+ $x->{_m} = $MBI->_rsft($x->{_m},$x->{_e},10); # cut off digits after dot
+ $x->{_e} = $MBI->_zero(); # trunc/norm
+ $x->{_es} = '+'; # abs e
+ $MBI->_inc($x->{_m}) if $x->{sign} eq '+'; # increment if positive
+ }
+ $x->round($a,$p,$r);
+ }
+
+sub brsft
+ {
+ # shift right by $y (divide by power of $n)
+
+ # set up parameters
+ my ($self,$x,$y,$n,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('brsft');
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ $n = 2 if !defined $n; $n = $self->new($n);
+
+ # negative amount?
+ return $x->blsft($y->copy()->babs(),$n) if $y->{sign} =~ /^-/;
+
+ # the following call to bdiv() will return either quo or (quo,reminder):
+ $x->bdiv($n->bpow($y),$a,$p,$r,$y);
+ }
+
+sub blsft
+ {
+ # shift left by $y (multiply by power of $n)
+
+ # set up parameters
+ my ($self,$x,$y,$n,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('blsft');
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ $n = 2 if !defined $n; $n = $self->new($n);
+
+ # negative amount?
+ return $x->brsft($y->copy()->babs(),$n) if $y->{sign} =~ /^-/;
+
+ $x->bmul($n->bpow($y),$a,$p,$r,$y);
+ }
+
+###############################################################################
+
+sub DESTROY
+ {
+ # going through AUTOLOAD for every DESTROY is costly, avoid it by empty sub
+ }
+
+sub AUTOLOAD
+ {
+ # make fxxx and bxxx both work by selectively mapping fxxx() to MBF::bxxx()
+ # or falling back to MBI::bxxx()
+ my $name = $AUTOLOAD;
+
+ $name =~ s/(.*):://; # split package
+ my $c = $1 || $class;
+ no strict 'refs';
+ $c->import() if $IMPORT == 0;
+ if (!_method_alias($name))
+ {
+ if (!defined $name)
+ {
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("$c: Can't call a method without name");
+ }
+ if (!_method_hand_up($name))
+ {
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call $c\-\>$name, not a valid method");
+ }
+ # try one level up, but subst. bxxx() for fxxx() since MBI only got bxxx()
+ $name =~ s/^f/b/;
+ return &{"Math::BigInt"."::$name"}(@_);
+ }
+ my $bname = $name; $bname =~ s/^f/b/;
+ $c .= "::$name";
+ *{$c} = \&{$bname};
+ &{$c}; # uses @_
+ }
+
+sub exponent
+ {
+ # return a copy of the exponent
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+-]//;
+ return Math::BigInt->new($s); # -inf, +inf => +inf
+ }
+ Math::BigInt->new( $x->{_es} . $MBI->_str($x->{_e}));
+ }
+
+sub mantissa
+ {
+ # return a copy of the mantissa
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+]//;
+ return Math::BigInt->new($s); # -inf, +inf => +inf
+ }
+ my $m = Math::BigInt->new( $MBI->_str($x->{_m}));
+ $m->bneg() if $x->{sign} eq '-';
+
+ $m;
+ }
+
+sub parts
+ {
+ # return a copy of both the exponent and the mantissa
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+]//; my $se = $s; $se =~ s/^[-]//;
+ return ($self->new($s),$self->new($se)); # +inf => inf and -inf,+inf => inf
+ }
+ my $m = Math::BigInt->bzero();
+ $m->{value} = $MBI->_copy($x->{_m});
+ $m->bneg() if $x->{sign} eq '-';
+ ($m, Math::BigInt->new( $x->{_es} . $MBI->_num($x->{_e}) ));
+ }
+
+##############################################################################
+# private stuff (internal use only)
+
+sub import
+ {
+ my $self = shift;
+ my $l = scalar @_;
+ my $lib = ''; my @a;
+ my $lib_kind = 'try';
+ $IMPORT=1;
+ for ( my $i = 0; $i < $l ; $i++)
+ {
+ if ( $_[$i] eq ':constant' )
+ {
+ # This causes overlord er load to step in. 'binary' and 'integer'
+ # are handled by BigInt.
+ overload::constant float => sub { $self->new(shift); };
+ }
+ elsif ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] eq 'downgrade')
+ {
+ # this causes downgrading
+ $downgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] =~ /^(lib|try|only)\z/)
+ {
+ # alternative library
+ $lib = $_[$i+1] || ''; # default Calc
+ $lib_kind = $1; # lib, try or only
+ $i++;
+ }
+ elsif ($_[$i] eq 'with')
+ {
+ # alternative class for our private parts()
+ # XXX: no longer supported
+ # $MBI = $_[$i+1] || 'Math::BigInt';
+ $i++;
+ }
+ else
+ {
+ push @a, $_[$i];
+ }
+ }
+
+ $lib =~ tr/a-zA-Z0-9,://cd; # restrict to sane characters
+ # let use Math::BigInt lib => 'GMP'; use Math::BigFloat; still work
+ my $mbilib = eval { Math::BigInt->config()->{lib} };
+ if ((defined $mbilib) && ($MBI eq 'Math::BigInt::Calc'))
+ {
+ # MBI already loaded
+ Math::BigInt->import( $lib_kind, "$lib,$mbilib", 'objectify');
+ }
+ else
+ {
+ # MBI not loaded, or with ne "Math::BigInt::Calc"
+ $lib .= ",$mbilib" if defined $mbilib;
+ $lib =~ s/^,//; # don't leave empty
+
+ # replacement library can handle lib statement, but also could ignore it
+
+ # Perl < 5.6.0 dies with "out of memory!" when eval() and ':constant' is
+ # used in the same script, or eval inside import(). So we require MBI:
+ require Math::BigInt;
+ Math::BigInt->import( $lib_kind => $lib, 'objectify' );
+ }
+ if ($@)
+ {
+ require Carp; Carp::croak ("Couldn't load $lib: $! $@");
+ }
+ # find out which one was actually loaded
+ $MBI = Math::BigInt->config()->{lib};
+
+ # register us with MBI to get notified of future lib changes
+ Math::BigInt::_register_callback( $self, sub { $MBI = $_[0]; } );
+
+ $self->export_to_level(1,$self,@a); # export wanted functions
+ }
+
+sub bnorm
+ {
+ # adjust m and e so that m is smallest possible
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $zeros = $MBI->_zeros($x->{_m}); # correct for trailing zeros
+ if ($zeros != 0)
+ {
+ my $z = $MBI->_new($zeros);
+ $x->{_m} = $MBI->_rsft ($x->{_m}, $z, 10);
+ if ($x->{_es} eq '-')
+ {
+ if ($MBI->_acmp($x->{_e},$z) >= 0)
+ {
+ $x->{_e} = $MBI->_sub ($x->{_e}, $z);
+ $x->{_es} = '+' if $MBI->_is_zero($x->{_e});
+ }
+ else
+ {
+ $x->{_e} = $MBI->_sub ( $MBI->_copy($z), $x->{_e});
+ $x->{_es} = '+';
+ }
+ }
+ else
+ {
+ $x->{_e} = $MBI->_add ($x->{_e}, $z);
+ }
+ }
+ else
+ {
+ # $x can only be 0Ey if there are no trailing zeros ('0' has 0 trailing
+ # zeros). So, for something like 0Ey, set y to 1, and -0 => +0
+ $x->{sign} = '+', $x->{_es} = '+', $x->{_e} = $MBI->_one()
+ if $MBI->_is_zero($x->{_m});
+ }
+
+ $x; # MBI bnorm is no-op, so dont call it
+ }
+
+##############################################################################
+
+sub as_hex
+ {
+ # return number as hexadecimal string (only for integers defined)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+ return '0x0' if $x->is_zero();
+
+ return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex!?
+
+ my $z = $MBI->_copy($x->{_m});
+ if (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z->as_hex();
+ }
+
+sub as_bin
+ {
+ # return number as binary digit string (only for integers defined)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+ return '0b0' if $x->is_zero();
+
+ return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex!?
+
+ my $z = $MBI->_copy($x->{_m});
+ if (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z->as_bin();
+ }
+
+sub as_oct
+ {
+ # return number as octal digit string (only for integers defined)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+ return '0' if $x->is_zero();
+
+ return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex!?
+
+ my $z = $MBI->_copy($x->{_m});
+ if (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z->as_oct();
+ }
+
+sub as_number
+ {
+ # return copy as a bigint representation of this BigFloat number
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('as_number');
+
+ if (!$x->isa('Math::BigFloat'))
+ {
+ # if the object can as_number(), use it
+ return $x->as_number() if $x->can('as_number');
+ # otherwise, get us a float and then a number
+ $x = $x->can('as_float') ? $x->as_float() : $self->new(0+"$x");
+ }
+
+ my $z = $MBI->_copy($x->{_m});
+ if ($x->{_es} eq '-') # < 0
+ {
+ $MBI->_rsft( $z, $x->{_e},10);
+ }
+ elsif (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z;
+ }
+
+sub length
+ {
+ my $x = shift;
+ my $class = ref($x) || $x;
+ $x = $class->new(shift) unless ref($x);
+
+ return 1 if $MBI->_is_zero($x->{_m});
+
+ my $len = $MBI->_len($x->{_m});
+ $len += $MBI->_num($x->{_e}) if $x->{_es} eq '+';
+ if (wantarray())
+ {
+ my $t = 0;
+ $t = $MBI->_num($x->{_e}) if $x->{_es} eq '-';
+ return ($len, $t);
+ }
+ $len;
+ }
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigFloat - Arbitrary size floating point math package
+
+=head1 SYNOPSIS
+
+ use Math::BigFloat;
+
+ # Number creation
+ my $x = Math::BigFloat->new($str); # defaults to 0
+ my $y = $x->copy(); # make a true copy
+ my $nan = Math::BigFloat->bnan(); # create a NotANumber
+ my $zero = Math::BigFloat->bzero(); # create a +0
+ my $inf = Math::BigFloat->binf(); # create a +inf
+ my $inf = Math::BigFloat->binf('-'); # create a -inf
+ my $one = Math::BigFloat->bone(); # create a +1
+ my $mone = Math::BigFloat->bone('-'); # create a -1
+
+ my $pi = Math::BigFloat->bpi(100); # PI to 100 digits
+
+ # the following examples compute their result to 100 digits accuracy:
+ my $cos = Math::BigFloat->new(1)->bcos(100); # cosinus(1)
+ my $sin = Math::BigFloat->new(1)->bsin(100); # sinus(1)
+ my $atan = Math::BigFloat->new(1)->batan(100); # arcus tangens(1)
+
+ my $atan2 = Math::BigFloat->new( 1 )->batan2( 1 ,100); # batan(1)
+ my $atan2 = Math::BigFloat->new( 1 )->batan2( 8 ,100); # batan(1/8)
+ my $atan2 = Math::BigFloat->new( -2 )->batan2( 1 ,100); # batan(-2)
+
+ # Testing
+ $x->is_zero(); # true if arg is +0
+ $x->is_nan(); # true if arg is NaN
+ $x->is_one(); # true if arg is +1
+ $x->is_one('-'); # true if arg is -1
+ $x->is_odd(); # true if odd, false for even
+ $x->is_even(); # true if even, false for odd
+ $x->is_pos(); # true if >= 0
+ $x->is_neg(); # true if < 0
+ $x->is_inf(sign); # true if +inf, or -inf (default is '+')
+
+ $x->bcmp($y); # compare numbers (undef,<0,=0,>0)
+ $x->bacmp($y); # compare absolutely (undef,<0,=0,>0)
+ $x->sign(); # return the sign, either +,- or NaN
+ $x->digit($n); # return the nth digit, counting from right
+ $x->digit(-$n); # return the nth digit, counting from left
+
+ # The following all modify their first argument. If you want to preserve
+ # $x, use $z = $x->copy()->bXXX($y); See under L<CAVEATS> for why this is
+ # necessary when mixing $a = $b assignments with non-overloaded math.
+
+ # set
+ $x->bzero(); # set $i to 0
+ $x->bnan(); # set $i to NaN
+ $x->bone(); # set $x to +1
+ $x->bone('-'); # set $x to -1
+ $x->binf(); # set $x to inf
+ $x->binf('-'); # set $x to -inf
+
+ $x->bneg(); # negation
+ $x->babs(); # absolute value
+ $x->bnorm(); # normalize (no-op)
+ $x->bnot(); # two's complement (bit wise not)
+ $x->binc(); # increment x by 1
+ $x->bdec(); # decrement x by 1
+
+ $x->badd($y); # addition (add $y to $x)
+ $x->bsub($y); # subtraction (subtract $y from $x)
+ $x->bmul($y); # multiplication (multiply $x by $y)
+ $x->bdiv($y); # divide, set $x to quotient
+ # return (quo,rem) or quo if scalar
+
+ $x->bmod($y); # modulus ($x % $y)
+ $x->bpow($y); # power of arguments ($x ** $y)
+ $x->bmodpow($exp,$mod); # modular exponentation (($num**$exp) % $mod))
+ $x->blsft($y, $n); # left shift by $y places in base $n
+ $x->brsft($y, $n); # right shift by $y places in base $n
+ # returns (quo,rem) or quo if in scalar context
+
+ $x->blog(); # logarithm of $x to base e (Euler's number)
+ $x->blog($base); # logarithm of $x to base $base (f.i. 2)
+ $x->bexp(); # calculate e ** $x where e is Euler's number
+
+ $x->band($y); # bit-wise and
+ $x->bior($y); # bit-wise inclusive or
+ $x->bxor($y); # bit-wise exclusive or
+ $x->bnot(); # bit-wise not (two's complement)
+
+ $x->bsqrt(); # calculate square-root
+ $x->broot($y); # $y'th root of $x (e.g. $y == 3 => cubic root)
+ $x->bfac(); # factorial of $x (1*2*3*4*..$x)
+
+ $x->bround($N); # accuracy: preserve $N digits
+ $x->bfround($N); # precision: round to the $Nth digit
+
+ $x->bfloor(); # return integer less or equal than $x
+ $x->bceil(); # return integer greater or equal than $x
+
+ # The following do not modify their arguments:
+
+ bgcd(@values); # greatest common divisor
+ blcm(@values); # lowest common multiplicator
+
+ $x->bstr(); # return string
+ $x->bsstr(); # return string in scientific notation
+
+ $x->as_int(); # return $x as BigInt
+ $x->exponent(); # return exponent as BigInt
+ $x->mantissa(); # return mantissa as BigInt
+ $x->parts(); # return (mantissa,exponent) as BigInt
+
+ $x->length(); # number of digits (w/o sign and '.')
+ ($l,$f) = $x->length(); # number of digits, and length of fraction
+
+ $x->precision(); # return P of $x (or global, if P of $x undef)
+ $x->precision($n); # set P of $x to $n
+ $x->accuracy(); # return A of $x (or global, if A of $x undef)
+ $x->accuracy($n); # set A $x to $n
+
+ # these get/set the appropriate global value for all BigFloat objects
+ Math::BigFloat->precision(); # Precision
+ Math::BigFloat->accuracy(); # Accuracy
+ Math::BigFloat->round_mode(); # rounding mode
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded if you
+declare your big floating point numbers as
+
+ $i = new Math::BigFloat '12_3.456_789_123_456_789E-2';
+
+Operations with overloaded operators preserve the arguments, which is
+exactly what you expect.
+
+=head2 Canonical notation
+
+Input to these routines are either BigFloat objects, or strings of the
+following four forms:
+
+=over 2
+
+=item *
+
+C</^[+-]\d+$/>
+
+=item *
+
+C</^[+-]\d+\.\d*$/>
+
+=item *
+
+C</^[+-]\d+E[+-]?\d+$/>
+
+=item *
+
+C</^[+-]\d*\.\d+E[+-]?\d+$/>
+
+=back
+
+all with optional leading and trailing zeros and/or spaces. Additionally,
+numbers are allowed to have an underscore between any two digits.
+
+Empty strings as well as other illegal numbers results in 'NaN'.
+
+bnorm() on a BigFloat object is now effectively a no-op, since the numbers
+are always stored in normalized form. On a string, it creates a BigFloat
+object.
+
+=head2 Output
+
+Output values are BigFloat objects (normalized), except for bstr() and bsstr().
+
+The string output will always have leading and trailing zeros stripped and drop
+a plus sign. C<bstr()> will give you always the form with a decimal point,
+while C<bsstr()> (s for scientific) gives you the scientific notation.
+
+ Input bstr() bsstr()
+ '-0' '0' '0E1'
+ ' -123 123 123' '-123123123' '-123123123E0'
+ '00.0123' '0.0123' '123E-4'
+ '123.45E-2' '1.2345' '12345E-4'
+ '10E+3' '10000' '1E4'
+
+Some routines (C<is_odd()>, C<is_even()>, C<is_zero()>, C<is_one()>,
+C<is_nan()>) return true or false, while others (C<bcmp()>, C<bacmp()>)
+return either undef, <0, 0 or >0 and are suited for sort.
+
+Actual math is done by using the class defined with C<with => Class;> (which
+defaults to BigInts) to represent the mantissa and exponent.
+
+The sign C</^[+-]$/> is stored separately. The string 'NaN' is used to
+represent the result when input arguments are not numbers, as well as
+the result of dividing by zero.
+
+=head2 C<mantissa()>, C<exponent()> and C<parts()>
+
+C<mantissa()> and C<exponent()> return the said parts of the BigFloat
+as BigInts such that:
+
+ $m = $x->mantissa();
+ $e = $x->exponent();
+ $y = $m * ( 10 ** $e );
+ print "ok\n" if $x == $y;
+
+C<< ($m,$e) = $x->parts(); >> is just a shortcut giving you both of them.
+
+A zero is represented and returned as C<0E1>, B<not> C<0E0> (after Knuth).
+
+Currently the mantissa is reduced as much as possible, favouring higher
+exponents over lower ones (e.g. returning 1e7 instead of 10e6 or 10000000e0).
+This might change in the future, so do not depend on it.
+
+=head2 Accuracy vs. Precision
+
+See also: L<Rounding|Rounding>.
+
+Math::BigFloat supports both precision (rounding to a certain place before or
+after the dot) and accuracy (rounding to a certain number of digits). For a
+full documentation, examples and tips on these topics please see the large
+section about rounding in L<Math::BigInt>.
+
+Since things like C<sqrt(2)> or C<1 / 3> must presented with a limited
+accuracy lest a operation consumes all resources, each operation produces
+no more than the requested number of digits.
+
+If there is no gloabl precision or accuracy set, B<and> the operation in
+question was not called with a requested precision or accuracy, B<and> the
+input $x has no accuracy or precision set, then a fallback parameter will
+be used. For historical reasons, it is called C<div_scale> and can be accessed
+via:
+
+ $d = Math::BigFloat->div_scale(); # query
+ Math::BigFloat->div_scale($n); # set to $n digits
+
+The default value for C<div_scale> is 40.
+
+In case the result of one operation has more digits than specified,
+it is rounded. The rounding mode taken is either the default mode, or the one
+supplied to the operation after the I<scale>:
+
+ $x = Math::BigFloat->new(2);
+ Math::BigFloat->accuracy(5); # 5 digits max
+ $y = $x->copy()->bdiv(3); # will give 0.66667
+ $y = $x->copy()->bdiv(3,6); # will give 0.666667
+ $y = $x->copy()->bdiv(3,6,undef,'odd'); # will give 0.666667
+ Math::BigFloat->round_mode('zero');
+ $y = $x->copy()->bdiv(3,6); # will also give 0.666667
+
+Note that C<< Math::BigFloat->accuracy() >> and C<< Math::BigFloat->precision() >>
+set the global variables, and thus B<any> newly created number will be subject
+to the global rounding B<immediately>. This means that in the examples above, the
+C<3> as argument to C<bdiv()> will also get an accuracy of B<5>.
+
+It is less confusing to either calculate the result fully, and afterwards
+round it explicitly, or use the additional parameters to the math
+functions like so:
+
+ use Math::BigFloat;
+ $x = Math::BigFloat->new(2);
+ $y = $x->copy()->bdiv(3);
+ print $y->bround(5),"\n"; # will give 0.66667
+
+ or
+
+ use Math::BigFloat;
+ $x = Math::BigFloat->new(2);
+ $y = $x->copy()->bdiv(3,5); # will give 0.66667
+ print "$y\n";
+
+=head2 Rounding
+
+=over 2
+
+=item ffround ( +$scale )
+
+Rounds to the $scale'th place left from the '.', counting from the dot.
+The first digit is numbered 1.
+
+=item ffround ( -$scale )
+
+Rounds to the $scale'th place right from the '.', counting from the dot.
+
+=item ffround ( 0 )
+
+Rounds to an integer.
+
+=item fround ( +$scale )
+
+Preserves accuracy to $scale digits from the left (aka significant digits)
+and pads the rest with zeros. If the number is between 1 and -1, the
+significant digits count from the first non-zero after the '.'
+
+=item fround ( -$scale ) and fround ( 0 )
+
+These are effectively no-ops.
+
+=back
+
+All rounding functions take as a second parameter a rounding mode from one of
+the following: 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'.
+
+The default rounding mode is 'even'. By using
+C<< Math::BigFloat->round_mode($round_mode); >> you can get and set the default
+mode for subsequent rounding. The usage of C<$Math::BigFloat::$round_mode> is
+no longer supported.
+The second parameter to the round functions then overrides the default
+temporarily.
+
+The C<as_number()> function returns a BigInt from a Math::BigFloat. It uses
+'trunc' as rounding mode to make it equivalent to:
+
+ $x = 2.5;
+ $y = int($x) + 2;
+
+You can override this by passing the desired rounding mode as parameter to
+C<as_number()>:
+
+ $x = Math::BigFloat->new(2.5);
+ $y = $x->as_number('odd'); # $y = 3
+
+=head1 METHODS
+
+Math::BigFloat supports all methods that Math::BigInt supports, except it
+calculates non-integer results when possible. Please see L<Math::BigInt>
+for a full description of each method. Below are just the most important
+differences:
+
+=head2 accuracy
+
+ $x->accuracy(5); # local for $x
+ CLASS->accuracy(5); # global for all members of CLASS
+ # Note: This also applies to new()!
+
+ $A = $x->accuracy(); # read out accuracy that affects $x
+ $A = CLASS->accuracy(); # read out global accuracy
+
+Set or get the global or local accuracy, aka how many significant digits the
+results have. If you set a global accuracy, then this also applies to new()!
+
+Warning! The accuracy I<sticks>, e.g. once you created a number under the
+influence of C<< CLASS->accuracy($A) >>, all results from math operations with
+that number will also be rounded.
+
+In most cases, you should probably round the results explicitly using one of
+L<round()>, L<bround()> or L<bfround()> or by passing the desired accuracy
+to the math operation as additional parameter:
+
+ my $x = Math::BigInt->new(30000);
+ my $y = Math::BigInt->new(7);
+ print scalar $x->copy()->bdiv($y, 2); # print 4300
+ print scalar $x->copy()->bdiv($y)->bround(2); # print 4300
+
+=head2 precision()
+
+ $x->precision(-2); # local for $x, round at the second digit right of the dot
+ $x->precision(2); # ditto, round at the second digit left of the dot
+
+ CLASS->precision(5); # Global for all members of CLASS
+ # This also applies to new()!
+ CLASS->precision(-5); # ditto
+
+ $P = CLASS->precision(); # read out global precision
+ $P = $x->precision(); # read out precision that affects $x
+
+Note: You probably want to use L<accuracy()> instead. With L<accuracy> you
+set the number of digits each result should have, with L<precision> you
+set the place where to round!
+
+=head2 bexp()
+
+ $x->bexp($accuracy); # calculate e ** X
+
+Calculates the expression C<e ** $x> where C<e> is Euler's number.
+
+This method was added in v1.82 of Math::BigInt (April 2007).
+
+=head2 bnok()
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+Calculates the binomial coefficient n over k, also called the "choose"
+function. The result is equivalent to:
+
+ ( n ) n!
+ | - | = -------
+ ( k ) k!(n-k)!
+
+This method was added in v1.84 of Math::BigInt (April 2007).
+
+=head2 bpi()
+
+ print Math::BigFloat->bpi(100), "\n";
+
+Calculate PI to N digits (including the 3 before the dot). The result is
+rounded according to the current rounding mode, which defaults to "even".
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bcos()
+
+ my $x = Math::BigFloat->new(1);
+ print $x->bcos(100), "\n";
+
+Calculate the cosinus of $x, modifying $x in place.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bsin()
+
+ my $x = Math::BigFloat->new(1);
+ print $x->bsin(100), "\n";
+
+Calculate the sinus of $x, modifying $x in place.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan2()
+
+ my $y = Math::BigFloat->new(2);
+ my $x = Math::BigFloat->new(3);
+ print $y->batan2($x), "\n";
+
+Calculate the arcus tanges of C<$y> divided by C<$x>, modifying $y in place.
+See also L<batan()>.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan()
+
+ my $x = Math::BigFloat->new(1);
+ print $x->batan(100), "\n";
+
+Calculate the arcus tanges of $x, modifying $x in place. See also L<batan2()>.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bmuladd()
+
+ $x->bmuladd($y,$z);
+
+Multiply $x by $y, and then add $z to the result.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head1 Autocreating constants
+
+After C<use Math::BigFloat ':constant'> all the floating point constants
+in the given scope are converted to C<Math::BigFloat>. This conversion
+happens at compile time.
+
+In particular
+
+ perl -MMath::BigFloat=:constant -e 'print 2E-100,"\n"'
+
+prints the value of C<2E-100>. Note that without conversion of
+constants the expression 2E-100 will be calculated as normal floating point
+number.
+
+Please note that ':constant' does not affect integer constants, nor binary
+nor hexadecimal constants. Use L<bignum> or L<Math::BigInt> to get this to
+work.
+
+=head2 Math library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use Math::BigFloat lib => 'Calc';
+
+You can change this by using:
+
+ use Math::BigFloat lib => 'GMP';
+
+B<Note>: General purpose packages should not be explicit about the library
+to use; let the script author decide which is best.
+
+Note: The keyword 'lib' will warn when the requested library could not be
+loaded. To suppress the warning use 'try' instead:
+
+ use Math::BigFloat try => 'GMP';
+
+If your script works with huge numbers and Calc is too slow for them,
+you can also for the loading of one of these libraries and if none
+of them can be used, the code will die:
+
+ use Math::BigFloat only => 'GMP,Pari';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use Math::BigFloat lib => 'Foo,Math::BigInt::Bar';
+
+See the respective low-level library documentation for further details.
+
+Please note that Math::BigFloat does B<not> use the denoted library itself,
+but it merely passes the lib argument to Math::BigInt. So, instead of the need
+to do:
+
+ use Math::BigInt lib => 'GMP';
+ use Math::BigFloat;
+
+you can roll it all into one line:
+
+ use Math::BigFloat lib => 'GMP';
+
+It is also possible to just require Math::BigFloat:
+
+ require Math::BigFloat;
+
+This will load the necessary things (like BigInt) when they are needed, and
+automatically.
+
+See L<Math::BigInt> for more details than you ever wanted to know about using
+a different low-level library.
+
+=head2 Using Math::BigInt::Lite
+
+For backwards compatibility reasons it is still possible to
+request a different storage class for use with Math::BigFloat:
+
+ use Math::BigFloat with => 'Math::BigInt::Lite';
+
+However, this request is ignored, as the current code now uses the low-level
+math libary for directly storing the number parts.
+
+=head1 EXPORTS
+
+C<Math::BigFloat> exports nothing by default, but can export the C<bpi()> method:
+
+ use Math::BigFloat qw/bpi/;
+
+ print bpi(10), "\n";
+
+=head1 BUGS
+
+Please see the file BUGS in the CPAN distribution Math::BigInt for known bugs.
+
+=head1 CAVEATS
+
+Do not try to be clever to insert some operations in between switching
+libraries:
+
+ require Math::BigFloat;
+ my $matter = Math::BigFloat->bone() + 4; # load BigInt and Calc
+ Math::BigFloat->import( lib => 'Pari' ); # load Pari, too
+ my $anti_matter = Math::BigFloat->bone()+4; # now use Pari
+
+This will create objects with numbers stored in two different backend libraries,
+and B<VERY BAD THINGS> will happen when you use these together:
+
+ my $flash_and_bang = $matter + $anti_matter; # Don't do this!
+
+=over 1
+
+=item stringify, bstr()
+
+Both stringify and bstr() now drop the leading '+'. The old code would return
+'+1.23', the new returns '1.23'. See the documentation in L<Math::BigInt> for
+reasoning and details.
+
+=item bdiv
+
+The following will probably not print what you expect:
+
+ print $c->bdiv(123.456),"\n";
+
+It prints both quotient and reminder since print works in list context. Also,
+bdiv() will modify $c, so be careful. You probably want to use
+
+ print $c / 123.456,"\n";
+ print scalar $c->bdiv(123.456),"\n"; # or if you want to modify $c
+
+instead.
+
+=item brsft
+
+The following will probably not print what you expect:
+
+ my $c = Math::BigFloat->new('3.14159');
+ print $c->brsft(3,10),"\n"; # prints 0.00314153.1415
+
+It prints both quotient and remainder, since print calls C<brsft()> in list
+context. Also, C<< $c->brsft() >> will modify $c, so be careful.
+You probably want to use
+
+ print scalar $c->copy()->brsft(3,10),"\n";
+ # or if you really want to modify $c
+ print scalar $c->brsft(3,10),"\n";
+
+instead.
+
+=item Modifying and =
+
+Beware of:
+
+ $x = Math::BigFloat->new(5);
+ $y = $x;
+
+It will not do what you think, e.g. making a copy of $x. Instead it just makes
+a second reference to the B<same> object and stores it in $y. Thus anything
+that modifies $x will modify $y (except overloaded math operators), and vice
+versa. See L<Math::BigInt> for details and how to avoid that.
+
+=item bpow
+
+C<bpow()> now modifies the first argument, unlike the old code which left
+it alone and only returned the result. This is to be consistent with
+C<badd()> etc. The first will modify $x, the second one won't:
+
+ print bpow($x,$i),"\n"; # modify $x
+ print $x->bpow($i),"\n"; # ditto
+ print $x ** $i,"\n"; # leave $x alone
+
+=item precision() vs. accuracy()
+
+A common pitfall is to use L<precision()> when you want to round a result to
+a certain number of digits:
+
+ use Math::BigFloat;
+
+ Math::BigFloat->precision(4); # does not do what you think it does
+ my $x = Math::BigFloat->new(12345); # rounds $x to "12000"!
+ print "$x\n"; # print "12000"
+ my $y = Math::BigFloat->new(3); # rounds $y to "0"!
+ print "$y\n"; # print "0"
+ $z = $x / $y; # 12000 / 0 => NaN!
+ print "$z\n";
+ print $z->precision(),"\n"; # 4
+
+Replacing L<precision> with L<accuracy> is probably not what you want, either:
+
+ use Math::BigFloat;
+
+ Math::BigFloat->accuracy(4); # enables global rounding:
+ my $x = Math::BigFloat->new(123456); # rounded immediately to "12350"
+ print "$x\n"; # print "123500"
+ my $y = Math::BigFloat->new(3); # rounded to "3
+ print "$y\n"; # print "3"
+ print $z = $x->copy()->bdiv($y),"\n"; # 41170
+ print $z->accuracy(),"\n"; # 4
+
+What you want to use instead is:
+
+ use Math::BigFloat;
+
+ my $x = Math::BigFloat->new(123456); # no rounding
+ print "$x\n"; # print "123456"
+ my $y = Math::BigFloat->new(3); # no rounding
+ print "$y\n"; # print "3"
+ print $z = $x->copy()->bdiv($y,4),"\n"; # 41150
+ print $z->accuracy(),"\n"; # undef
+
+In addition to computing what you expected, the last example also does B<not>
+"taint" the result with an accuracy or precision setting, which would
+influence any further operation.
+
+=back
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well as
+L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+The pragmas L<bignum>, L<bigint> and L<bigrat> might also be of interest
+because they solve the autoupgrading/downgrading issue, at least partly.
+
+The package at L<http://search.cpan.org/~tels/Math-BigInt> contains
+more documentation including a full version history, testcases, empty
+subclass files and benchmarks.
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Mark Biggar, overloaded interface by Ilya Zakharevich.
+Completely rewritten by Tels L<http://bloodgate.com> in 2001 - 2006, and still
+at it in 2007.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigFloat/Trace.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigFloat/Trace.pm
new file mode 100755
index 00000000000..871b2a969e8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigFloat/Trace.pm
@@ -0,0 +1,58 @@
+#!/usr/bin/perl -w
+
+package Math::BigFloat::Trace;
+
+require 5.005_02;
+use strict;
+
+use Exporter;
+use Math::BigFloat;
+use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK
+ $accuracy $precision $round_mode $div_scale);
+
+@ISA = qw(Exporter Math::BigFloat);
+
+$VERSION = 0.01;
+
+use overload; # inherit overload from BigFloat
+
+# Globals
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+
+sub new
+{
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ my $value = shift;
+ my $a = $accuracy; $a = $_[0] if defined $_[0];
+ my $p = $precision; $p = $_[1] if defined $_[1];
+ my $self = Math::BigFloat->new($value,$a,$p,$round_mode);
+
+# remember, downgrading may return a BigInt, so don't meddle with class
+# bless $self,$class;
+
+ print "MBF new '$value' => '$self' (",ref($self),")";
+ return $self;
+}
+
+sub import
+ {
+ print "MBF import ",join(' ',@_);
+ my $self = shift;
+
+ # we catch the constants, the rest goes go BigFloat
+ my @a = ();
+ foreach (@_)
+ {
+ push @a, $_ if $_ ne ':constant';
+ }
+ overload::constant float => sub { $self->new(shift); };
+
+ Math::BigFloat->import(@a); # need it for subclasses
+# $self->export_to_level(1,$self,@_); # need this ?
+ }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigInt.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigInt.pm
new file mode 100755
index 00000000000..b19b3dc92d7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigInt.pm
@@ -0,0 +1,5115 @@
+package Math::BigInt;
+
+#
+# "Mike had an infinite amount to do and a negative amount of time in which
+# to do it." - Before and After
+#
+
+# The following hash values are used:
+# value: unsigned int with actual value (as a Math::BigInt::Calc or similiar)
+# sign : +,-,NaN,+inf,-inf
+# _a : accuracy
+# _p : precision
+# _f : flags, used by MBF to flag parts of a float as untouchable
+
+# Remember not to take shortcuts ala $xs = $x->{value}; $CALC->foo($xs); since
+# underlying lib might change the reference!
+
+my $class = "Math::BigInt";
+use 5.006;
+
+$VERSION = '1.89';
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(objectify bgcd blcm);
+
+# _trap_inf and _trap_nan are internal and should never be accessed from the
+# outside
+use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode
+ $upgrade $downgrade $_trap_nan $_trap_inf/;
+use strict;
+
+# Inside overload, the first arg is always an object. If the original code had
+# it reversed (like $x = 2 * $y), then the third paramater is true.
+# In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes
+# no difference, but in some cases it does.
+
+# For overloaded ops with only one argument we simple use $_[0]->copy() to
+# preserve the argument.
+
+# Thus inheritance of overload operators becomes possible and transparent for
+# our subclasses without the need to repeat the entire overload section there.
+
+use overload
+'=' => sub { $_[0]->copy(); },
+
+# some shortcuts for speed (assumes that reversed order of arguments is routed
+# to normal '+' and we thus can always modify first arg. If this is changed,
+# this breaks and must be adjusted.)
+'+=' => sub { $_[0]->badd($_[1]); },
+'-=' => sub { $_[0]->bsub($_[1]); },
+'*=' => sub { $_[0]->bmul($_[1]); },
+'/=' => sub { scalar $_[0]->bdiv($_[1]); },
+'%=' => sub { $_[0]->bmod($_[1]); },
+'^=' => sub { $_[0]->bxor($_[1]); },
+'&=' => sub { $_[0]->band($_[1]); },
+'|=' => sub { $_[0]->bior($_[1]); },
+
+'**=' => sub { $_[0]->bpow($_[1]); },
+'<<=' => sub { $_[0]->blsft($_[1]); },
+'>>=' => sub { $_[0]->brsft($_[1]); },
+
+# not supported by Perl yet
+'..' => \&_pointpoint,
+
+'<=>' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ $_[0]->bcmp($_[1]);
+ $rc = 1 unless defined $rc;
+ $rc <=> 0;
+ },
+# we need '>=' to get things like "1 >= NaN" right:
+'>=' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ $_[0]->bcmp($_[1]);
+ # if there was a NaN involved, return false
+ return '' unless defined $rc;
+ $rc >= 0;
+ },
+'cmp' => sub {
+ $_[2] ?
+ "$_[1]" cmp $_[0]->bstr() :
+ $_[0]->bstr() cmp "$_[1]" },
+
+'cos' => sub { $_[0]->copy->bcos(); },
+'sin' => sub { $_[0]->copy->bsin(); },
+'atan2' => sub { $_[2] ?
+ ref($_[0])->new($_[1])->batan2($_[0]) :
+ $_[0]->copy()->batan2($_[1]) },
+
+# are not yet overloadable
+#'hex' => sub { print "hex"; $_[0]; },
+#'oct' => sub { print "oct"; $_[0]; },
+
+# log(N) is log(N, e), where e is Euler's number
+'log' => sub { $_[0]->copy()->blog($_[1], undef); },
+'exp' => sub { $_[0]->copy()->bexp($_[1]); },
+'int' => sub { $_[0]->copy(); },
+'neg' => sub { $_[0]->copy()->bneg(); },
+'abs' => sub { $_[0]->copy()->babs(); },
+'sqrt' => sub { $_[0]->copy()->bsqrt(); },
+'~' => sub { $_[0]->copy()->bnot(); },
+
+# for subtract it's a bit tricky to not modify b: b-a => -a+b
+'-' => sub { my $c = $_[0]->copy; $_[2] ?
+ $c->bneg()->badd( $_[1]) :
+ $c->bsub( $_[1]) },
+'+' => sub { $_[0]->copy()->badd($_[1]); },
+'*' => sub { $_[0]->copy()->bmul($_[1]); },
+
+'/' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bdiv($_[0]) : $_[0]->copy->bdiv($_[1]);
+ },
+'%' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bmod($_[0]) : $_[0]->copy->bmod($_[1]);
+ },
+'**' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bpow($_[0]) : $_[0]->copy->bpow($_[1]);
+ },
+'<<' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->blsft($_[0]) : $_[0]->copy->blsft($_[1]);
+ },
+'>>' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->brsft($_[0]) : $_[0]->copy->brsft($_[1]);
+ },
+'&' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->band($_[0]) : $_[0]->copy->band($_[1]);
+ },
+'|' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bior($_[0]) : $_[0]->copy->bior($_[1]);
+ },
+'^' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bxor($_[0]) : $_[0]->copy->bxor($_[1]);
+ },
+
+# can modify arg of ++ and --, so avoid a copy() for speed, but don't
+# use $_[0]->bone(), it would modify $_[0] to be 1!
+'++' => sub { $_[0]->binc() },
+'--' => sub { $_[0]->bdec() },
+
+# if overloaded, O(1) instead of O(N) and twice as fast for small numbers
+'bool' => sub {
+ # this kludge is needed for perl prior 5.6.0 since returning 0 here fails :-/
+ # v5.6.1 dumps on this: return !$_[0]->is_zero() || undef; :-(
+ my $t = undef;
+ $t = 1 if !$_[0]->is_zero();
+ $t;
+ },
+
+# the original qw() does not work with the TIESCALAR below, why?
+# Order of arguments unsignificant
+'""' => sub { $_[0]->bstr(); },
+'0+' => sub { $_[0]->numify(); }
+;
+
+##############################################################################
+# global constants, flags and accessory
+
+# These vars are public, but their direct usage is not recommended, use the
+# accessor methods instead
+
+$round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
+$accuracy = undef;
+$precision = undef;
+$div_scale = 40;
+
+$upgrade = undef; # default is no upgrade
+$downgrade = undef; # default is no downgrade
+
+# These are internally, and not to be used from the outside at all
+
+$_trap_nan = 0; # are NaNs ok? set w/ config()
+$_trap_inf = 0; # are infs ok? set w/ config()
+my $nan = 'NaN'; # constants for easier life
+
+my $CALC = 'Math::BigInt::FastCalc'; # module to do the low level math
+ # default is FastCalc.pm
+my $IMPORT = 0; # was import() called yet?
+ # used to make require work
+my %WARN; # warn only once for low-level libs
+my %CAN; # cache for $CALC->can(...)
+my %CALLBACKS; # callbacks to notify on lib loads
+my $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math
+
+##############################################################################
+# the old code had $rnd_mode, so we need to support it, too
+
+$rnd_mode = 'even';
+sub TIESCALAR { my ($class) = @_; bless \$round_mode, $class; }
+sub FETCH { return $round_mode; }
+sub STORE { $rnd_mode = $_[0]->round_mode($_[1]); }
+
+BEGIN
+ {
+ # tie to enable $rnd_mode to work transparently
+ tie $rnd_mode, 'Math::BigInt';
+
+ # set up some handy alias names
+ *as_int = \&as_number;
+ *is_pos = \&is_positive;
+ *is_neg = \&is_negative;
+ }
+
+##############################################################################
+
+sub round_mode
+ {
+ no strict 'refs';
+ # make Class->round_mode() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ if (defined $_[0])
+ {
+ my $m = shift;
+ if ($m !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
+ {
+ require Carp; Carp::croak ("Unknown round mode '$m'");
+ }
+ return ${"${class}::round_mode"} = $m;
+ }
+ ${"${class}::round_mode"};
+ }
+
+sub upgrade
+ {
+ no strict 'refs';
+ # make Class->upgrade() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ # need to set new value?
+ if (@_ > 0)
+ {
+ return ${"${class}::upgrade"} = $_[0];
+ }
+ ${"${class}::upgrade"};
+ }
+
+sub downgrade
+ {
+ no strict 'refs';
+ # make Class->downgrade() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ # need to set new value?
+ if (@_ > 0)
+ {
+ return ${"${class}::downgrade"} = $_[0];
+ }
+ ${"${class}::downgrade"};
+ }
+
+sub div_scale
+ {
+ no strict 'refs';
+ # make Class->div_scale() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ if (defined $_[0])
+ {
+ if ($_[0] < 0)
+ {
+ require Carp; Carp::croak ('div_scale must be greater than zero');
+ }
+ ${"${class}::div_scale"} = $_[0];
+ }
+ ${"${class}::div_scale"};
+ }
+
+sub accuracy
+ {
+ # $x->accuracy($a); ref($x) $a
+ # $x->accuracy(); ref($x)
+ # Class->accuracy(); class
+ # Class->accuracy($a); class $a
+
+ my $x = shift;
+ my $class = ref($x) || $x || __PACKAGE__;
+
+ no strict 'refs';
+ # need to set new value?
+ if (@_ > 0)
+ {
+ my $a = shift;
+ # convert objects to scalars to avoid deep recursion. If object doesn't
+ # have numify(), then hopefully it will have overloading for int() and
+ # boolean test without wandering into a deep recursion path...
+ $a = $a->numify() if ref($a) && $a->can('numify');
+
+ if (defined $a)
+ {
+ # also croak on non-numerical
+ if (!$a || $a <= 0)
+ {
+ require Carp;
+ Carp::croak ('Argument to accuracy must be greater than zero');
+ }
+ if (int($a) != $a)
+ {
+ require Carp;
+ Carp::croak ('Argument to accuracy must be an integer');
+ }
+ }
+ if (ref($x))
+ {
+ # $object->accuracy() or fallback to global
+ $x->bround($a) if $a; # not for undef, 0
+ $x->{_a} = $a; # set/overwrite, even if not rounded
+ delete $x->{_p}; # clear P
+ $a = ${"${class}::accuracy"} unless defined $a; # proper return value
+ }
+ else
+ {
+ ${"${class}::accuracy"} = $a; # set global A
+ ${"${class}::precision"} = undef; # clear global P
+ }
+ return $a; # shortcut
+ }
+
+ my $a;
+ # $object->accuracy() or fallback to global
+ $a = $x->{_a} if ref($x);
+ # but don't return global undef, when $x's accuracy is 0!
+ $a = ${"${class}::accuracy"} if !defined $a;
+ $a;
+ }
+
+sub precision
+ {
+ # $x->precision($p); ref($x) $p
+ # $x->precision(); ref($x)
+ # Class->precision(); class
+ # Class->precision($p); class $p
+
+ my $x = shift;
+ my $class = ref($x) || $x || __PACKAGE__;
+
+ no strict 'refs';
+ if (@_ > 0)
+ {
+ my $p = shift;
+ # convert objects to scalars to avoid deep recursion. If object doesn't
+ # have numify(), then hopefully it will have overloading for int() and
+ # boolean test without wandering into a deep recursion path...
+ $p = $p->numify() if ref($p) && $p->can('numify');
+ if ((defined $p) && (int($p) != $p))
+ {
+ require Carp; Carp::croak ('Argument to precision must be an integer');
+ }
+ if (ref($x))
+ {
+ # $object->precision() or fallback to global
+ $x->bfround($p) if $p; # not for undef, 0
+ $x->{_p} = $p; # set/overwrite, even if not rounded
+ delete $x->{_a}; # clear A
+ $p = ${"${class}::precision"} unless defined $p; # proper return value
+ }
+ else
+ {
+ ${"${class}::precision"} = $p; # set global P
+ ${"${class}::accuracy"} = undef; # clear global A
+ }
+ return $p; # shortcut
+ }
+
+ my $p;
+ # $object->precision() or fallback to global
+ $p = $x->{_p} if ref($x);
+ # but don't return global undef, when $x's precision is 0!
+ $p = ${"${class}::precision"} if !defined $p;
+ $p;
+ }
+
+sub config
+ {
+ # return (or set) configuration data as hash ref
+ my $class = shift || 'Math::BigInt';
+
+ no strict 'refs';
+ if (@_ > 1 || (@_ == 1 && (ref($_[0]) eq 'HASH')))
+ {
+ # try to set given options as arguments from hash
+
+ my $args = $_[0];
+ if (ref($args) ne 'HASH')
+ {
+ $args = { @_ };
+ }
+ # these values can be "set"
+ my $set_args = {};
+ foreach my $key (
+ qw/trap_inf trap_nan
+ upgrade downgrade precision accuracy round_mode div_scale/
+ )
+ {
+ $set_args->{$key} = $args->{$key} if exists $args->{$key};
+ delete $args->{$key};
+ }
+ if (keys %$args > 0)
+ {
+ require Carp;
+ Carp::croak ("Illegal key(s) '",
+ join("','",keys %$args),"' passed to $class\->config()");
+ }
+ foreach my $key (keys %$set_args)
+ {
+ if ($key =~ /^trap_(inf|nan)\z/)
+ {
+ ${"${class}::_trap_$1"} = ($set_args->{"trap_$1"} ? 1 : 0);
+ next;
+ }
+ # use a call instead of just setting the $variable to check argument
+ $class->$key($set_args->{$key});
+ }
+ }
+
+ # now return actual configuration
+
+ my $cfg = {
+ lib => $CALC,
+ lib_version => ${"${CALC}::VERSION"},
+ class => $class,
+ trap_nan => ${"${class}::_trap_nan"},
+ trap_inf => ${"${class}::_trap_inf"},
+ version => ${"${class}::VERSION"},
+ };
+ foreach my $key (qw/
+ upgrade downgrade precision accuracy round_mode div_scale
+ /)
+ {
+ $cfg->{$key} = ${"${class}::$key"};
+ };
+ if (@_ == 1 && (ref($_[0]) ne 'HASH'))
+ {
+ # calls of the style config('lib') return just this value
+ return $cfg->{$_[0]};
+ }
+ $cfg;
+ }
+
+sub _scale_a
+ {
+ # select accuracy parameter based on precedence,
+ # used by bround() and bfround(), may return undef for scale (means no op)
+ my ($x,$scale,$mode) = @_;
+
+ $scale = $x->{_a} unless defined $scale;
+
+ no strict 'refs';
+ my $class = ref($x);
+
+ $scale = ${ $class . '::accuracy' } unless defined $scale;
+ $mode = ${ $class . '::round_mode' } unless defined $mode;
+
+ if (defined $scale)
+ {
+ $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
+ $scale = int($scale);
+ }
+
+ ($scale,$mode);
+ }
+
+sub _scale_p
+ {
+ # select precision parameter based on precedence,
+ # used by bround() and bfround(), may return undef for scale (means no op)
+ my ($x,$scale,$mode) = @_;
+
+ $scale = $x->{_p} unless defined $scale;
+
+ no strict 'refs';
+ my $class = ref($x);
+
+ $scale = ${ $class . '::precision' } unless defined $scale;
+ $mode = ${ $class . '::round_mode' } unless defined $mode;
+
+ if (defined $scale)
+ {
+ $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
+ $scale = int($scale);
+ }
+
+ ($scale,$mode);
+ }
+
+##############################################################################
+# constructors
+
+sub copy
+ {
+ # if two arguments, the first one is the class to "swallow" subclasses
+ if (@_ > 1)
+ {
+ my $self = bless {
+ sign => $_[1]->{sign},
+ value => $CALC->_copy($_[1]->{value}),
+ }, $_[0] if @_ > 1;
+
+ $self->{_a} = $_[1]->{_a} if defined $_[1]->{_a};
+ $self->{_p} = $_[1]->{_p} if defined $_[1]->{_p};
+ return $self;
+ }
+
+ my $self = bless {
+ sign => $_[0]->{sign},
+ value => $CALC->_copy($_[0]->{value}),
+ }, ref($_[0]);
+
+ $self->{_a} = $_[0]->{_a} if defined $_[0]->{_a};
+ $self->{_p} = $_[0]->{_p} if defined $_[0]->{_p};
+ $self;
+ }
+
+sub new
+ {
+ # create a new BigInt object from a string or another BigInt object.
+ # see hash keys documented at top
+
+ # the argument could be an object, so avoid ||, && etc on it, this would
+ # cause costly overloaded code to be called. The only allowed ops are
+ # ref() and defined.
+
+ my ($class,$wanted,$a,$p,$r) = @_;
+
+ # avoid numify-calls by not using || on $wanted!
+ return $class->bzero($a,$p) if !defined $wanted; # default to 0
+ return $class->copy($wanted,$a,$p,$r)
+ if ref($wanted) && $wanted->isa($class); # MBI or subclass
+
+ $class->import() if $IMPORT == 0; # make require work
+
+ my $self = bless {}, $class;
+
+ # shortcut for "normal" numbers
+ if ((!ref $wanted) && ($wanted =~ /^([+-]?)[1-9][0-9]*\z/))
+ {
+ $self->{sign} = $1 || '+';
+
+ if ($wanted =~ /^[+-]/)
+ {
+ # remove sign without touching wanted to make it work with constants
+ my $t = $wanted; $t =~ s/^[+-]//;
+ $self->{value} = $CALC->_new($t);
+ }
+ else
+ {
+ $self->{value} = $CALC->_new($wanted);
+ }
+ no strict 'refs';
+ if ( (defined $a) || (defined $p)
+ || (defined ${"${class}::precision"})
+ || (defined ${"${class}::accuracy"})
+ )
+ {
+ $self->round($a,$p,$r) unless (@_ == 4 && !defined $a && !defined $p);
+ }
+ return $self;
+ }
+
+ # handle '+inf', '-inf' first
+ if ($wanted =~ /^[+-]?inf\z/)
+ {
+ $self->{sign} = $wanted; # set a default sign for bstr()
+ return $self->binf($wanted);
+ }
+ # split str in m mantissa, e exponent, i integer, f fraction, v value, s sign
+ my ($mis,$miv,$mfv,$es,$ev) = _split($wanted);
+ if (!ref $mis)
+ {
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted is not a number in $class");
+ }
+ $self->{value} = $CALC->_zero();
+ $self->{sign} = $nan;
+ return $self;
+ }
+ if (!ref $miv)
+ {
+ # _from_hex or _from_bin
+ $self->{value} = $mis->{value};
+ $self->{sign} = $mis->{sign};
+ return $self; # throw away $mis
+ }
+ # make integer from mantissa by adjusting exp, then convert to bigint
+ $self->{sign} = $$mis; # store sign
+ $self->{value} = $CALC->_zero(); # for all the NaN cases
+ my $e = int("$$es$$ev"); # exponent (avoid recursion)
+ if ($e > 0)
+ {
+ my $diff = $e - CORE::length($$mfv);
+ if ($diff < 0) # Not integer
+ {
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted not an integer in $class");
+ }
+ #print "NOI 1\n";
+ return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
+ $self->{sign} = $nan;
+ }
+ else # diff >= 0
+ {
+ # adjust fraction and add it to value
+ #print "diff > 0 $$miv\n";
+ $$miv = $$miv . ($$mfv . '0' x $diff);
+ }
+ }
+ else
+ {
+ if ($$mfv ne '') # e <= 0
+ {
+ # fraction and negative/zero E => NOI
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted not an integer in $class");
+ }
+ #print "NOI 2 \$\$mfv '$$mfv'\n";
+ return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
+ $self->{sign} = $nan;
+ }
+ elsif ($e < 0)
+ {
+ # xE-y, and empty mfv
+ #print "xE-y\n";
+ $e = abs($e);
+ if ($$miv !~ s/0{$e}$//) # can strip so many zero's?
+ {
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted not an integer in $class");
+ }
+ #print "NOI 3\n";
+ return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
+ $self->{sign} = $nan;
+ }
+ }
+ }
+ $self->{sign} = '+' if $$miv eq '0'; # normalize -0 => +0
+ $self->{value} = $CALC->_new($$miv) if $self->{sign} =~ /^[+-]$/;
+ # if any of the globals is set, use them to round and store them inside $self
+ # do not round for new($x,undef,undef) since that is used by MBF to signal
+ # no rounding
+ $self->round($a,$p,$r) unless @_ == 4 && !defined $a && !defined $p;
+ $self;
+ }
+
+sub bnan
+ {
+ # create a bigint 'NaN', if given a BigInt, set it to 'NaN'
+ my $self = shift;
+ $self = $class if !defined $self;
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ no strict 'refs';
+ if (${"${class}::_trap_nan"})
+ {
+ require Carp;
+ Carp::croak ("Tried to set $self to NaN in $class\::bnan()");
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('bnan');
+ if ($self->can('_bnan'))
+ {
+ # use subclass to initialize
+ $self->_bnan();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_zero();
+ }
+ $self->{sign} = $nan;
+ delete $self->{_a}; delete $self->{_p}; # rounding NaN is silly
+ $self;
+ }
+
+sub binf
+ {
+ # create a bigint '+-inf', if given a BigInt, set it to '+-inf'
+ # the sign is either '+', or if given, used from there
+ my $self = shift;
+ my $sign = shift; $sign = '+' if !defined $sign || $sign !~ /^-(inf)?$/;
+ $self = $class if !defined $self;
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ no strict 'refs';
+ if (${"${class}::_trap_inf"})
+ {
+ require Carp;
+ Carp::croak ("Tried to set $self to +-inf in $class\::binf()");
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('binf');
+ if ($self->can('_binf'))
+ {
+ # use subclass to initialize
+ $self->_binf();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_zero();
+ }
+ $sign = $sign . 'inf' if $sign !~ /inf$/; # - => -inf
+ $self->{sign} = $sign;
+ ($self->{_a},$self->{_p}) = @_; # take over requested rounding
+ $self;
+ }
+
+sub bzero
+ {
+ # create a bigint '+0', if given a BigInt, set it to 0
+ my $self = shift;
+ $self = __PACKAGE__ if !defined $self;
+
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('bzero');
+
+ if ($self->can('_bzero'))
+ {
+ # use subclass to initialize
+ $self->_bzero();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_zero();
+ }
+ $self->{sign} = '+';
+ if (@_ > 0)
+ {
+ if (@_ > 3)
+ {
+ # call like: $x->bzero($a,$p,$r,$y);
+ ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
+ }
+ else
+ {
+ $self->{_a} = $_[0]
+ if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
+ $self->{_p} = $_[1]
+ if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
+ }
+ }
+ $self;
+ }
+
+sub bone
+ {
+ # create a bigint '+1' (or -1 if given sign '-'),
+ # if given a BigInt, set it to +1 or -1, respectively
+ my $self = shift;
+ my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-';
+ $self = $class if !defined $self;
+
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('bone');
+
+ if ($self->can('_bone'))
+ {
+ # use subclass to initialize
+ $self->_bone();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_one();
+ }
+ $self->{sign} = $sign;
+ if (@_ > 0)
+ {
+ if (@_ > 3)
+ {
+ # call like: $x->bone($sign,$a,$p,$r,$y);
+ ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
+ }
+ else
+ {
+ # call like: $x->bone($sign,$a,$p,$r);
+ $self->{_a} = $_[0]
+ if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
+ $self->{_p} = $_[1]
+ if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
+ }
+ }
+ $self;
+ }
+
+##############################################################################
+# string conversation
+
+sub bsstr
+ {
+ # (ref to BFLOAT or num_str ) return num_str
+ # Convert number from internal format to scientific string format.
+ # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+ my ($m,$e) = $x->parts();
+ #$m->bstr() . 'e+' . $e->bstr(); # e can only be positive in BigInt
+ # 'e+' because E can only be positive in BigInt
+ $m->bstr() . 'e+' . $CALC->_str($e->{value});
+ }
+
+sub bstr
+ {
+ # make a string from bigint object
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+ my $es = ''; $es = $x->{sign} if $x->{sign} eq '-';
+ $es.$CALC->_str($x->{value});
+ }
+
+sub numify
+ {
+ # Make a "normal" scalar from a BigInt object
+ my $x = shift; $x = $class->new($x) unless ref $x;
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/;
+ my $num = $CALC->_num($x->{value});
+ return -$num if $x->{sign} eq '-';
+ $num;
+ }
+
+##############################################################################
+# public stuff (usually prefixed with "b")
+
+sub sign
+ {
+ # return the sign of the number: +/-/-inf/+inf/NaN
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign};
+ }
+
+sub _find_round_parameters
+ {
+ # After any operation or when calling round(), the result is rounded by
+ # regarding the A & P from arguments, local parameters, or globals.
+
+ # !!!!!!! If you change this, remember to change round(), too! !!!!!!!!!!
+
+ # This procedure finds the round parameters, but it is for speed reasons
+ # duplicated in round. Otherwise, it is tested by the testsuite and used
+ # by fdiv().
+
+ # returns ($self) or ($self,$a,$p,$r) - sets $self to NaN of both A and P
+ # were requested/defined (locally or globally or both)
+
+ my ($self,$a,$p,$r,@args) = @_;
+ # $a accuracy, if given by caller
+ # $p precision, if given by caller
+ # $r round_mode, if given by caller
+ # @args all 'other' arguments (0 for unary, 1 for binary ops)
+
+ my $c = ref($self); # find out class of argument(s)
+ no strict 'refs';
+
+ # convert to normal scalar for speed and correctness in inner parts
+ $a = $a->can('numify') ? $a->numify() : "$a" if defined $a && ref($a);
+ $p = $p->can('numify') ? $p->numify() : "$p" if defined $p && ref($p);
+
+ # now pick $a or $p, but only if we have got "arguments"
+ if (!defined $a)
+ {
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is smaller
+ $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
+ }
+ }
+ if (!defined $p)
+ {
+ # even if $a is defined, take $p, to signal error for both defined
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is bigger
+ # -2 > -3, and 3 > 2
+ $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
+ }
+ }
+ # if still none defined, use globals (#2)
+ $a = ${"$c\::accuracy"} unless defined $a;
+ $p = ${"$c\::precision"} unless defined $p;
+
+ # A == 0 is useless, so undef it to signal no rounding
+ $a = undef if defined $a && $a == 0;
+
+ # no rounding today?
+ return ($self) unless defined $a || defined $p; # early out
+
+ # set A and set P is an fatal error
+ return ($self->bnan()) if defined $a && defined $p; # error
+
+ $r = ${"$c\::round_mode"} unless defined $r;
+ if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
+ {
+ require Carp; Carp::croak ("Unknown round mode '$r'");
+ }
+
+ $a = int($a) if defined $a;
+ $p = int($p) if defined $p;
+
+ ($self,$a,$p,$r);
+ }
+
+sub round
+ {
+ # Round $self according to given parameters, or given second argument's
+ # parameters or global defaults
+
+ # for speed reasons, _find_round_parameters is embeded here:
+
+ my ($self,$a,$p,$r,@args) = @_;
+ # $a accuracy, if given by caller
+ # $p precision, if given by caller
+ # $r round_mode, if given by caller
+ # @args all 'other' arguments (0 for unary, 1 for binary ops)
+
+ my $c = ref($self); # find out class of argument(s)
+ no strict 'refs';
+
+ # now pick $a or $p, but only if we have got "arguments"
+ if (!defined $a)
+ {
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is smaller
+ $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
+ }
+ }
+ if (!defined $p)
+ {
+ # even if $a is defined, take $p, to signal error for both defined
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is bigger
+ # -2 > -3, and 3 > 2
+ $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
+ }
+ }
+ # if still none defined, use globals (#2)
+ $a = ${"$c\::accuracy"} unless defined $a;
+ $p = ${"$c\::precision"} unless defined $p;
+
+ # A == 0 is useless, so undef it to signal no rounding
+ $a = undef if defined $a && $a == 0;
+
+ # no rounding today?
+ return $self unless defined $a || defined $p; # early out
+
+ # set A and set P is an fatal error
+ return $self->bnan() if defined $a && defined $p;
+
+ $r = ${"$c\::round_mode"} unless defined $r;
+ if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
+ {
+ require Carp; Carp::croak ("Unknown round mode '$r'");
+ }
+
+ # now round, by calling either fround or ffround:
+ if (defined $a)
+ {
+ $self->bround(int($a),$r) if !defined $self->{_a} || $self->{_a} >= $a;
+ }
+ else # both can't be undefined due to early out
+ {
+ $self->bfround(int($p),$r) if !defined $self->{_p} || $self->{_p} <= $p;
+ }
+ # bround() or bfround() already callled bnorm() if nec.
+ $self;
+ }
+
+sub bnorm
+ {
+ # (numstr or BINT) return BINT
+ # Normalize number -- no-op here
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+ $x;
+ }
+
+sub babs
+ {
+ # (BINT or num_str) return BINT
+ # make number absolute, or return absolute BINT from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('babs');
+ # post-normalized abs for internal use (does nothing for NaN)
+ $x->{sign} =~ s/^-/+/;
+ $x;
+ }
+
+sub bneg
+ {
+ # (BINT or num_str) return BINT
+ # negate number or make a negated number from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('bneg');
+
+ # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
+ $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $CALC->_is_zero($x->{value}));
+ $x;
+ }
+
+sub bcmp
+ {
+ # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+ # (BINT or num_str, BINT or num_str) return cond_code
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bcmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
+ return +1 if $x->{sign} eq '+inf';
+ return -1 if $x->{sign} eq '-inf';
+ return -1 if $y->{sign} eq '+inf';
+ return +1;
+ }
+ # check sign for speed first
+ return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
+ return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
+
+ # have same sign, so compare absolute values. Don't make tests for zero here
+ # because it's actually slower than testin in Calc (especially w/ Pari et al)
+
+ # post-normalized compare for internal use (honors signs)
+ if ($x->{sign} eq '+')
+ {
+ # $x and $y both > 0
+ return $CALC->_acmp($x->{value},$y->{value});
+ }
+
+ # $x && $y both < 0
+ $CALC->_acmp($y->{value},$x->{value}); # swaped acmp (lib returns 0,1,-1)
+ }
+
+sub bacmp
+ {
+ # Compares 2 values, ignoring their signs.
+ # Returns one of undef, <0, =0, >0. (suitable for sort)
+ # (BINT, BINT) return cond_code
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bacmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
+ return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
+ return -1;
+ }
+ $CALC->_acmp($x->{value},$y->{value}); # lib does only 0,1,-1
+ }
+
+sub badd
+ {
+ # add second arg (BINT or string) to first (BINT) (modifies first)
+ # return result as BINT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('badd');
+ return $upgrade->badd($upgrade->new($x),$upgrade->new($y),@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ $r[3] = $y; # no push!
+ # inf and NaN handling
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # NaN first
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ # +inf++inf or -inf+-inf => same, rest is NaN
+ return $x if $x->{sign} eq $y->{sign};
+ return $x->bnan();
+ }
+ # +-inf + something => +inf
+ # something +-inf => +-inf
+ $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
+ return $x;
+ }
+
+ my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs
+
+ if ($sx eq $sy)
+ {
+ $x->{value} = $CALC->_add($x->{value},$y->{value}); # same sign, abs add
+ }
+ else
+ {
+ my $a = $CALC->_acmp ($y->{value},$x->{value}); # absolute compare
+ if ($a > 0)
+ {
+ $x->{value} = $CALC->_sub($y->{value},$x->{value},1); # abs sub w/ swap
+ $x->{sign} = $sy;
+ }
+ elsif ($a == 0)
+ {
+ # speedup, if equal, set result to 0
+ $x->{value} = $CALC->_zero();
+ $x->{sign} = '+';
+ }
+ else # a < 0
+ {
+ $x->{value} = $CALC->_sub($x->{value}, $y->{value}); # abs sub
+ }
+ }
+ $x->round(@r);
+ }
+
+sub bsub
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # subtract second arg from first, modify first
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bsub');
+
+ return $upgrade->new($x)->bsub($upgrade->new($y),@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ return $x->round(@r) if $y->is_zero();
+
+ # To correctly handle the lone special case $x->bsub($x), we note the sign
+ # of $x, then flip the sign from $y, and if the sign of $x did change, too,
+ # then we caught the special case:
+ my $xsign = $x->{sign};
+ $y->{sign} =~ tr/+\-/-+/; # does nothing for NaN
+ if ($xsign ne $x->{sign})
+ {
+ # special case of $x->bsub($x) results in 0
+ return $x->bzero(@r) if $xsign =~ /^[+-]$/;
+ return $x->bnan(); # NaN, -inf, +inf
+ }
+ $x->badd($y,@r); # badd does not leave internal zeros
+ $y->{sign} =~ tr/+\-/-+/; # refix $y (does nothing for NaN)
+ $x; # already rounded by badd() or no round nec.
+ }
+
+sub binc
+ {
+ # increment arg by one
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+ return $x if $x->modify('binc');
+
+ if ($x->{sign} eq '+')
+ {
+ $x->{value} = $CALC->_inc($x->{value});
+ return $x->round($a,$p,$r);
+ }
+ elsif ($x->{sign} eq '-')
+ {
+ $x->{value} = $CALC->_dec($x->{value});
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # -1 +1 => -0 => +0
+ return $x->round($a,$p,$r);
+ }
+ # inf, nan handling etc
+ $x->badd($self->bone(),$a,$p,$r); # badd does round
+ }
+
+sub bdec
+ {
+ # decrement arg by one
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+ return $x if $x->modify('bdec');
+
+ if ($x->{sign} eq '-')
+ {
+ # x already < 0
+ $x->{value} = $CALC->_inc($x->{value});
+ }
+ else
+ {
+ return $x->badd($self->bone('-'),@r) unless $x->{sign} eq '+'; # inf or NaN
+ # >= 0
+ if ($CALC->_is_zero($x->{value}))
+ {
+ # == 0
+ $x->{value} = $CALC->_one(); $x->{sign} = '-'; # 0 => -1
+ }
+ else
+ {
+ # > 0
+ $x->{value} = $CALC->_dec($x->{value});
+ }
+ }
+ $x->round(@r);
+ }
+
+sub blog
+ {
+ # calculate $x = $a ** $base + $b and return $a (e.g. the log() to base
+ # $base of $x)
+
+ # set up parameters
+ my ($self,$x,$base,@r) = (undef,@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$base,@r) = objectify(1,ref($x),@_);
+ }
+
+ return $x if $x->modify('blog');
+
+ $base = $self->new($base) if defined $base && !ref $base;
+
+ # inf, -inf, NaN, <0 => NaN
+ return $x->bnan()
+ if $x->{sign} ne '+' || (defined $base && $base->{sign} ne '+');
+
+ return $upgrade->blog($upgrade->new($x),$base,@r) if
+ defined $upgrade;
+
+ # fix for bug #24969:
+ # the default base is e (Euler's number) which is not an integer
+ if (!defined $base)
+ {
+ require Math::BigFloat;
+ my $u = Math::BigFloat->blog(Math::BigFloat->new($x))->as_int();
+ # modify $x in place
+ $x->{value} = $u->{value};
+ $x->{sign} = $u->{sign};
+ return $x;
+ }
+
+ my ($rc,$exact) = $CALC->_log_int($x->{value},$base->{value});
+ return $x->bnan() unless defined $rc; # not possible to take log?
+ $x->{value} = $rc;
+ $x->round(@r);
+ }
+
+sub bnok
+ {
+ # Calculate n over k (binomial coefficient or "choose" function) as integer.
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bnok');
+ return $x->bnan() if $x->{sign} eq 'NaN' || $y->{sign} eq 'NaN';
+ return $x->binf() if $x->{sign} eq '+inf';
+
+ # k > n or k < 0 => 0
+ my $cmp = $x->bacmp($y);
+ return $x->bzero() if $cmp < 0 || $y->{sign} =~ /^-/;
+ # k == n => 1
+ return $x->bone(@r) if $cmp == 0;
+
+ if ($CALC->can('_nok'))
+ {
+ $x->{value} = $CALC->_nok($x->{value},$y->{value});
+ }
+ else
+ {
+ # ( 7 ) 7! 7*6*5 * 4*3*2*1 7 * 6 * 5
+ # ( - ) = --------- = --------------- = ---------
+ # ( 3 ) 3! (7-3)! 3*2*1 * 4*3*2*1 3 * 2 * 1
+
+ # compute n - k + 2 (so we start with 5 in the example above)
+ my $z = $x - $y;
+ if (!$z->is_one())
+ {
+ $z->binc();
+ my $r = $z->copy(); $z->binc();
+ my $d = $self->new(2);
+ while ($z->bacmp($x) <= 0) # f < x ?
+ {
+ $r->bmul($z); $r->bdiv($d);
+ $z->binc(); $d->binc();
+ }
+ $x->{value} = $r->{value}; $x->{sign} = '+';
+ }
+ else { $x->bone(); }
+ }
+ $x->round(@r);
+ }
+
+sub bexp
+ {
+ # Calculate e ** $x (Euler's number to the power of X), truncated to
+ # an integer value.
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+ return $x if $x->modify('bexp');
+
+ # inf, -inf, NaN, <0 => NaN
+ return $x->bnan() if $x->{sign} eq 'NaN';
+ return $x->bone() if $x->is_zero();
+ return $x if $x->{sign} eq '+inf';
+ return $x->bzero() if $x->{sign} eq '-inf';
+
+ my $u;
+ {
+ # run through Math::BigFloat unless told otherwise
+ require Math::BigFloat unless defined $upgrade;
+ local $upgrade = 'Math::BigFloat' unless defined $upgrade;
+ # calculate result, truncate it to integer
+ $u = $upgrade->bexp($upgrade->new($x),@r);
+ }
+
+ if (!defined $upgrade)
+ {
+ $u = $u->as_int();
+ # modify $x in place
+ $x->{value} = $u->{value};
+ $x->round(@r);
+ }
+ else { $x = $u; }
+ }
+
+sub blcm
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does not modify arguments, but returns new object
+ # Lowest Common Multiplicator
+
+ my $y = shift; my ($x);
+ if (ref($y))
+ {
+ $x = $y->copy();
+ }
+ else
+ {
+ $x = $class->new($y);
+ }
+ my $self = ref($x);
+ while (@_)
+ {
+ my $y = shift; $y = $self->new($y) if !ref ($y);
+ $x = __lcm($x,$y);
+ }
+ $x;
+ }
+
+sub bgcd
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does not modify arguments, but returns new object
+ # GCD -- Euclids algorithm, variant C (Knuth Vol 3, pg 341 ff)
+
+ my $y = shift;
+ $y = $class->new($y) if !ref($y);
+ my $self = ref($y);
+ my $x = $y->copy()->babs(); # keep arguments
+ return $x->bnan() if $x->{sign} !~ /^[+-]$/; # x NaN?
+
+ while (@_)
+ {
+ $y = shift; $y = $self->new($y) if !ref($y);
+ return $x->bnan() if $y->{sign} !~ /^[+-]$/; # y NaN?
+ $x->{value} = $CALC->_gcd($x->{value},$y->{value});
+ last if $CALC->_is_one($x->{value});
+ }
+ $x;
+ }
+
+sub bnot
+ {
+ # (num_str or BINT) return BINT
+ # represent ~x as twos-complement number
+ # we don't need $self, so undef instead of ref($_[0]) make it slightly faster
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bnot');
+ $x->binc()->bneg(); # binc already does round
+ }
+
+##############################################################################
+# is_foo test routines
+# we don't need $self, so undef instead of ref($_[0]) make it slightly faster
+
+sub is_zero
+ {
+ # return true if arg (BINT or num_str) is zero (array '+', '0')
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^\+$/; # -, NaN & +-inf aren't
+ $CALC->_is_zero($x->{value});
+ }
+
+sub is_nan
+ {
+ # return true if arg (BINT or num_str) is NaN
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign} eq $nan ? 1 : 0;
+ }
+
+sub is_inf
+ {
+ # return true if arg (BINT or num_str) is +-inf
+ my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ if (defined $sign)
+ {
+ $sign = '[+-]inf' if $sign eq ''; # +- doesn't matter, only that's inf
+ $sign = "[$1]inf" if $sign =~ /^([+-])(inf)?$/; # extract '+' or '-'
+ return $x->{sign} =~ /^$sign$/ ? 1 : 0;
+ }
+ $x->{sign} =~ /^[+-]inf$/ ? 1 : 0; # only +-inf is infinity
+ }
+
+sub is_one
+ {
+ # return true if arg (BINT or num_str) is +1, or -1 if sign is given
+ my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $sign = '+' if !defined $sign || $sign ne '-';
+
+ return 0 if $x->{sign} ne $sign; # -1 != +1, NaN, +-inf aren't either
+ $CALC->_is_one($x->{value});
+ }
+
+sub is_odd
+ {
+ # return true when arg (BINT or num_str) is odd, false for even
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
+ $CALC->_is_odd($x->{value});
+ }
+
+sub is_even
+ {
+ # return true when arg (BINT or num_str) is even, false for odd
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
+ $CALC->_is_even($x->{value});
+ }
+
+sub is_positive
+ {
+ # return true when arg (BINT or num_str) is positive (>= 0)
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if $x->{sign} eq '+inf'; # +inf is positive
+
+ # 0+ is neither positive nor negative
+ ($x->{sign} eq '+' && !$x->is_zero()) ? 1 : 0;
+ }
+
+sub is_negative
+ {
+ # return true when arg (BINT or num_str) is negative (< 0)
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign} =~ /^-/ ? 1 : 0; # -inf is negative, but NaN is not
+ }
+
+sub is_int
+ {
+ # return true when arg (BINT or num_str) is an integer
+ # always true for BigInt, but different for BigFloats
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign} =~ /^[+-]$/ ? 1 : 0; # inf/-inf/NaN aren't
+ }
+
+###############################################################################
+
+sub bmul
+ {
+ # multiply the first number by the second number
+ # (BINT or num_str, BINT or num_str) return BINT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmul');
+
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ return $upgrade->bmul($x,$upgrade->new($y),@r)
+ if defined $upgrade && !$y->isa($self);
+
+ $r[3] = $y; # no push here
+
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
+
+ $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
+
+ $x->round(@r);
+ }
+
+sub bmuladd
+ {
+ # multiply two numbers and then add the third to the result
+ # (BINT or num_str, BINT or num_str, BINT or num_str) return BINT
+
+ # set up parameters
+ my ($self,$x,$y,$z,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$z,@r) = objectify(3,@_);
+ }
+
+ return $x if $x->modify('bmuladd');
+
+ return $x->bnan() if ($x->{sign} eq $nan) ||
+ ($y->{sign} eq $nan) ||
+ ($z->{sign} eq $nan);
+
+ # inf handling of x and y
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+ # inf handling x*y and z
+ if (($z->{sign} =~ /^[+-]inf$/))
+ {
+ # something +-inf => +-inf
+ $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/;
+ }
+
+ return $upgrade->bmuladd($x,$upgrade->new($y),$upgrade->new($z),@r)
+ if defined $upgrade && (!$y->isa($self) || !$z->isa($self) || !$x->isa($self));
+
+ # TODO: what if $y and $z have A or P set?
+ $r[3] = $z; # no push here
+
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
+
+ $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
+
+ my ($sx, $sz) = ( $x->{sign}, $z->{sign} ); # get signs
+
+ if ($sx eq $sz)
+ {
+ $x->{value} = $CALC->_add($x->{value},$z->{value}); # same sign, abs add
+ }
+ else
+ {
+ my $a = $CALC->_acmp ($z->{value},$x->{value}); # absolute compare
+ if ($a > 0)
+ {
+ $x->{value} = $CALC->_sub($z->{value},$x->{value},1); # abs sub w/ swap
+ $x->{sign} = $sz;
+ }
+ elsif ($a == 0)
+ {
+ # speedup, if equal, set result to 0
+ $x->{value} = $CALC->_zero();
+ $x->{sign} = '+';
+ }
+ else # a < 0
+ {
+ $x->{value} = $CALC->_sub($x->{value}, $z->{value}); # abs sub
+ }
+ }
+ $x->round(@r);
+ }
+
+sub _div_inf
+ {
+ # helper function that handles +-inf cases for bdiv()/bmod() to reuse code
+ my ($self,$x,$y) = @_;
+
+ # NaN if x == NaN or y == NaN or x==y==0
+ return wantarray ? ($x->bnan(),$self->bnan()) : $x->bnan()
+ if (($x->is_nan() || $y->is_nan()) ||
+ ($x->is_zero() && $y->is_zero()));
+
+ # +-inf / +-inf == NaN, reminder also NaN
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return wantarray ? ($x->bnan(),$self->bnan()) : $x->bnan();
+ }
+ # x / +-inf => 0, remainder x (works even if x == 0)
+ if ($y->{sign} =~ /^[+-]inf$/)
+ {
+ my $t = $x->copy(); # bzero clobbers up $x
+ return wantarray ? ($x->bzero(),$t) : $x->bzero()
+ }
+
+ # 5 / 0 => +inf, -6 / 0 => -inf
+ # +inf / 0 = inf, inf, and -inf / 0 => -inf, -inf
+ # exception: -8 / 0 has remainder -8, not 8
+ # exception: -inf / 0 has remainder -inf, not inf
+ if ($y->is_zero())
+ {
+ # +-inf / 0 => special case for -inf
+ return wantarray ? ($x,$x->copy()) : $x if $x->is_inf();
+ if (!$x->is_zero() && !$x->is_inf())
+ {
+ my $t = $x->copy(); # binf clobbers up $x
+ return wantarray ?
+ ($x->binf($x->{sign}),$t) : $x->binf($x->{sign})
+ }
+ }
+
+ # last case: +-inf / ordinary number
+ my $sign = '+inf';
+ $sign = '-inf' if substr($x->{sign},0,1) ne $y->{sign};
+ $x->{sign} = $sign;
+ return wantarray ? ($x,$self->bzero()) : $x;
+ }
+
+sub bdiv
+ {
+ # (dividend: BINT or num_str, divisor: BINT or num_str) return
+ # (BINT,BINT) (quo,rem) or BINT (only rem)
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bdiv');
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ return $upgrade->bdiv($upgrade->new($x),$upgrade->new($y),@r)
+ if defined $upgrade;
+
+ $r[3] = $y; # no push!
+
+ # calc new sign and in case $y == +/- 1, return $x
+ my $xsign = $x->{sign}; # keep
+ $x->{sign} = ($x->{sign} ne $y->{sign} ? '-' : '+');
+
+ if (wantarray)
+ {
+ my $rem = $self->bzero();
+ ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value});
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value});
+ $rem->{_a} = $x->{_a};
+ $rem->{_p} = $x->{_p};
+ $x->round(@r);
+ if (! $CALC->_is_zero($rem->{value}))
+ {
+ $rem->{sign} = $y->{sign};
+ $rem = $y->copy()->bsub($rem) if $xsign ne $y->{sign}; # one of them '-'
+ }
+ else
+ {
+ $rem->{sign} = '+'; # dont leave -0
+ }
+ $rem->round(@r);
+ return ($x,$rem);
+ }
+
+ $x->{value} = $CALC->_div($x->{value},$y->{value});
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value});
+
+ $x->round(@r);
+ }
+
+###############################################################################
+# modulus functions
+
+sub bmod
+ {
+ # modulus (or remainder)
+ # (BINT or num_str, BINT or num_str) return BINT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmod');
+ $r[3] = $y; # no push!
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero())
+ {
+ my ($d,$r) = $self->_div_inf($x,$y);
+ $x->{sign} = $r->{sign};
+ $x->{value} = $r->{value};
+ return $x->round(@r);
+ }
+
+ # calc new sign and in case $y == +/- 1, return $x
+ $x->{value} = $CALC->_mod($x->{value},$y->{value});
+ if (!$CALC->_is_zero($x->{value}))
+ {
+ $x->{value} = $CALC->_sub($y->{value},$x->{value},1) # $y-$x
+ if ($x->{sign} ne $y->{sign});
+ $x->{sign} = $y->{sign};
+ }
+ else
+ {
+ $x->{sign} = '+'; # dont leave -0
+ }
+ $x->round(@r);
+ }
+
+sub bmodinv
+ {
+ # Modular inverse. given a number which is (hopefully) relatively
+ # prime to the modulus, calculate its inverse using Euclid's
+ # alogrithm. If the number is not relatively prime to the modulus
+ # (i.e. their gcd is not one) then NaN is returned.
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (undef,@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmodinv');
+
+ return $x->bnan()
+ if ($y->{sign} ne '+' # -, NaN, +inf, -inf
+ || $x->is_zero() # or num == 0
+ || $x->{sign} !~ /^[+-]$/ # or num NaN, inf, -inf
+ );
+
+ # put least residue into $x if $x was negative, and thus make it positive
+ $x->bmod($y) if $x->{sign} eq '-';
+
+ my $sign;
+ ($x->{value},$sign) = $CALC->_modinv($x->{value},$y->{value});
+ return $x->bnan() if !defined $x->{value}; # in case no GCD found
+ return $x if !defined $sign; # already real result
+ $x->{sign} = $sign; # flip/flop see below
+ $x->bmod($y); # calc real result
+ $x;
+ }
+
+sub bmodpow
+ {
+ # takes a very large number to a very large exponent in a given very
+ # large modulus, quickly, thanks to binary exponentation. Supports
+ # negative exponents.
+ my ($self,$num,$exp,$mod,@r) = objectify(3,@_);
+
+ return $num if $num->modify('bmodpow');
+
+ # check modulus for valid values
+ return $num->bnan() if ($mod->{sign} ne '+' # NaN, - , -inf, +inf
+ || $mod->is_zero());
+
+ # check exponent for valid values
+ if ($exp->{sign} =~ /\w/)
+ {
+ # i.e., if it's NaN, +inf, or -inf...
+ return $num->bnan();
+ }
+
+ $num->bmodinv ($mod) if ($exp->{sign} eq '-');
+
+ # check num for valid values (also NaN if there was no inverse but $exp < 0)
+ return $num->bnan() if $num->{sign} !~ /^[+-]$/;
+
+ # $mod is positive, sign on $exp is ignored, result also positive
+ $num->{value} = $CALC->_modpow($num->{value},$exp->{value},$mod->{value});
+ $num;
+ }
+
+###############################################################################
+
+sub bfac
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute factorial number from $x, modify $x in place
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bfac') || $x->{sign} eq '+inf'; # inf => inf
+ return $x->bnan() if $x->{sign} ne '+'; # NaN, <0 etc => NaN
+
+ $x->{value} = $CALC->_fac($x->{value});
+ $x->round(@r);
+ }
+
+sub bpow
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute power of two numbers -- stolen from Knuth Vol 2 pg 233
+ # modifies first argument
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bpow');
+
+ return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ # +-inf ** +-inf
+ return $x->bnan();
+ }
+ # +-inf ** Y
+ if ($x->{sign} =~ /^[+-]inf/)
+ {
+ # +inf ** 0 => NaN
+ return $x->bnan() if $y->is_zero();
+ # -inf ** -1 => 1/inf => 0
+ return $x->bzero() if $y->is_one('-') && $x->is_negative();
+
+ # +inf ** Y => inf
+ return $x if $x->{sign} eq '+inf';
+
+ # -inf ** Y => -inf if Y is odd
+ return $x if $y->is_odd();
+ return $x->babs();
+ }
+ # X ** +-inf
+
+ # 1 ** +inf => 1
+ return $x if $x->is_one();
+
+ # 0 ** inf => 0
+ return $x if $x->is_zero() && $y->{sign} =~ /^[+]/;
+
+ # 0 ** -inf => inf
+ return $x->binf() if $x->is_zero();
+
+ # -1 ** -inf => NaN
+ return $x->bnan() if $x->is_one('-') && $y->{sign} =~ /^[-]/;
+
+ # -X ** -inf => 0
+ return $x->bzero() if $x->{sign} eq '-' && $y->{sign} =~ /^[-]/;
+
+ # -1 ** inf => NaN
+ return $x->bnan() if $x->{sign} eq '-';
+
+ # X ** inf => inf
+ return $x->binf() if $y->{sign} =~ /^[+]/;
+ # X ** -inf => 0
+ return $x->bzero();
+ }
+
+ return $upgrade->bpow($upgrade->new($x),$y,@r)
+ if defined $upgrade && (!$y->isa($self) || $y->{sign} eq '-');
+
+ $r[3] = $y; # no push!
+
+ # cases 0 ** Y, X ** 0, X ** 1, 1 ** Y are handled by Calc or Emu
+
+ my $new_sign = '+';
+ $new_sign = $y->is_odd() ? '-' : '+' if ($x->{sign} ne '+');
+
+ # 0 ** -7 => ( 1 / (0 ** 7)) => 1 / 0 => +inf
+ return $x->binf()
+ if $y->{sign} eq '-' && $x->{sign} eq '+' && $CALC->_is_zero($x->{value});
+ # 1 ** -y => 1 / (1 ** |y|)
+ # so do test for negative $y after above's clause
+ return $x->bnan() if $y->{sign} eq '-' && !$CALC->_is_one($x->{value});
+
+ $x->{value} = $CALC->_pow($x->{value},$y->{value});
+ $x->{sign} = $new_sign;
+ $x->{sign} = '+' if $CALC->_is_zero($y->{value});
+ $x->round(@r);
+ }
+
+sub blsft
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute x << y, base n, y >= 0
+
+ # set up parameters
+ my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('blsft');
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+ return $x->round(@r) if $y->is_zero();
+
+ $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
+
+ $x->{value} = $CALC->_lsft($x->{value},$y->{value},$n);
+ $x->round(@r);
+ }
+
+sub brsft
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute x >> y, base n, y >= 0
+
+ # set up parameters
+ my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('brsft');
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+ return $x->round(@r) if $y->is_zero();
+ return $x->bzero(@r) if $x->is_zero(); # 0 => 0
+
+ $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
+
+ # this only works for negative numbers when shifting in base 2
+ if (($x->{sign} eq '-') && ($n == 2))
+ {
+ return $x->round(@r) if $x->is_one('-'); # -1 => -1
+ if (!$y->is_one())
+ {
+ # although this is O(N*N) in calc (as_bin!) it is O(N) in Pari et al
+ # but perhaps there is a better emulation for two's complement shift...
+ # if $y != 1, we must simulate it by doing:
+ # convert to bin, flip all bits, shift, and be done
+ $x->binc(); # -3 => -2
+ my $bin = $x->as_bin();
+ $bin =~ s/^-0b//; # strip '-0b' prefix
+ $bin =~ tr/10/01/; # flip bits
+ # now shift
+ if ($y >= CORE::length($bin))
+ {
+ $bin = '0'; # shifting to far right creates -1
+ # 0, because later increment makes
+ # that 1, attached '-' makes it '-1'
+ # because -1 >> x == -1 !
+ }
+ else
+ {
+ $bin =~ s/.{$y}$//; # cut off at the right side
+ $bin = '1' . $bin; # extend left side by one dummy '1'
+ $bin =~ tr/10/01/; # flip bits back
+ }
+ my $res = $self->new('0b'.$bin); # add prefix and convert back
+ $res->binc(); # remember to increment
+ $x->{value} = $res->{value}; # take over value
+ return $x->round(@r); # we are done now, magic, isn't?
+ }
+ # x < 0, n == 2, y == 1
+ $x->bdec(); # n == 2, but $y == 1: this fixes it
+ }
+
+ $x->{value} = $CALC->_rsft($x->{value},$y->{value},$n);
+ $x->round(@r);
+ }
+
+sub band
+ {
+ #(BINT or num_str, BINT or num_str) return BINT
+ # compute x & y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('band');
+
+ $r[3] = $y; # no push!
+
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ my $sx = $x->{sign} eq '+' ? 1 : -1;
+ my $sy = $y->{sign} eq '+' ? 1 : -1;
+
+ if ($sx == 1 && $sy == 1)
+ {
+ $x->{value} = $CALC->_and($x->{value},$y->{value});
+ return $x->round(@r);
+ }
+
+ if ($CAN{signed_and})
+ {
+ $x->{value} = $CALC->_signed_and($x->{value},$y->{value},$sx,$sy);
+ return $x->round(@r);
+ }
+
+ require $EMU_LIB;
+ __emu_band($self,$x,$y,$sx,$sy,@r);
+ }
+
+sub bior
+ {
+ #(BINT or num_str, BINT or num_str) return BINT
+ # compute x | y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bior');
+ $r[3] = $y; # no push!
+
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ my $sx = $x->{sign} eq '+' ? 1 : -1;
+ my $sy = $y->{sign} eq '+' ? 1 : -1;
+
+ # the sign of X follows the sign of X, e.g. sign of Y irrelevant for bior()
+
+ # don't use lib for negative values
+ if ($sx == 1 && $sy == 1)
+ {
+ $x->{value} = $CALC->_or($x->{value},$y->{value});
+ return $x->round(@r);
+ }
+
+ # if lib can do negative values, let it handle this
+ if ($CAN{signed_or})
+ {
+ $x->{value} = $CALC->_signed_or($x->{value},$y->{value},$sx,$sy);
+ return $x->round(@r);
+ }
+
+ require $EMU_LIB;
+ __emu_bior($self,$x,$y,$sx,$sy,@r);
+ }
+
+sub bxor
+ {
+ #(BINT or num_str, BINT or num_str) return BINT
+ # compute x ^ y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bxor');
+ $r[3] = $y; # no push!
+
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ my $sx = $x->{sign} eq '+' ? 1 : -1;
+ my $sy = $y->{sign} eq '+' ? 1 : -1;
+
+ # don't use lib for negative values
+ if ($sx == 1 && $sy == 1)
+ {
+ $x->{value} = $CALC->_xor($x->{value},$y->{value});
+ return $x->round(@r);
+ }
+
+ # if lib can do negative values, let it handle this
+ if ($CAN{signed_xor})
+ {
+ $x->{value} = $CALC->_signed_xor($x->{value},$y->{value},$sx,$sy);
+ return $x->round(@r);
+ }
+
+ require $EMU_LIB;
+ __emu_bxor($self,$x,$y,$sx,$sy,@r);
+ }
+
+sub length
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ my $e = $CALC->_len($x->{value});
+ wantarray ? ($e,0) : $e;
+ }
+
+sub digit
+ {
+ # return the nth decimal digit, negative values count backward, 0 is right
+ my ($self,$x,$n) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $n = $n->numify() if ref($n);
+ $CALC->_digit($x->{value},$n||0);
+ }
+
+sub _trailing_zeros
+ {
+ # return the amount of trailing zeros in $x (as scalar)
+ my $x = shift;
+ $x = $class->new($x) unless ref $x;
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf etc
+
+ $CALC->_zeros($x->{value}); # must handle odd values, 0 etc
+ }
+
+sub bsqrt
+ {
+ # calculate square root of $x
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bsqrt');
+
+ return $x->bnan() if $x->{sign} !~ /^\+/; # -x or -inf or NaN => NaN
+ return $x if $x->{sign} eq '+inf'; # sqrt(+inf) == inf
+
+ return $upgrade->bsqrt($x,@r) if defined $upgrade;
+
+ $x->{value} = $CALC->_sqrt($x->{value});
+ $x->round(@r);
+ }
+
+sub broot
+ {
+ # calculate $y'th root of $x
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ $y = $self->new(2) unless defined $y;
+
+ # objectify is costly, so avoid it
+ if ((!ref($x)) || (ref($x) ne ref($y)))
+ {
+ ($self,$x,$y,@r) = objectify(2,$self || $class,@_);
+ }
+
+ return $x if $x->modify('broot');
+
+ # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0
+ return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() ||
+ $y->{sign} !~ /^\+$/;
+
+ return $x->round(@r)
+ if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one();
+
+ return $upgrade->new($x)->broot($upgrade->new($y),@r) if defined $upgrade;
+
+ $x->{value} = $CALC->_root($x->{value},$y->{value});
+ $x->round(@r);
+ }
+
+sub exponent
+ {
+ # return a copy of the exponent (here always 0, NaN or 1 for $m == 0)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+-]//; # NaN, -inf,+inf => NaN or inf
+ return $self->new($s);
+ }
+ return $self->bone() if $x->is_zero();
+
+ # 12300 => 2 trailing zeros => exponent is 2
+ $self->new( $CALC->_zeros($x->{value}) );
+ }
+
+sub mantissa
+ {
+ # return the mantissa (compatible to Math::BigFloat, e.g. reduced)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ # for NaN, +inf, -inf: keep the sign
+ return $self->new($x->{sign});
+ }
+ my $m = $x->copy(); delete $m->{_p}; delete $m->{_a};
+
+ # that's a bit inefficient:
+ my $zeros = $CALC->_zeros($m->{value});
+ $m->brsft($zeros,10) if $zeros != 0;
+ $m;
+ }
+
+sub parts
+ {
+ # return a copy of both the exponent and the mantissa
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ ($x->mantissa(),$x->exponent());
+ }
+
+##############################################################################
+# rounding functions
+
+sub bfround
+ {
+ # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
+ # $n == 0 || $n == 1 => round to integer
+ my $x = shift; my $self = ref($x) || $x; $x = $self->new($x) unless ref $x;
+
+ my ($scale,$mode) = $x->_scale_p(@_);
+
+ return $x if !defined $scale || $x->modify('bfround'); # no-op
+
+ # no-op for BigInts if $n <= 0
+ $x->bround( $x->length()-$scale, $mode) if $scale > 0;
+
+ delete $x->{_a}; # delete to save memory
+ $x->{_p} = $scale; # store new _p
+ $x;
+ }
+
+sub _scan_for_nonzero
+ {
+ # internal, used by bround() to scan for non-zeros after a '5'
+ my ($x,$pad,$xs,$len) = @_;
+
+ return 0 if $len == 1; # "5" is trailed by invisible zeros
+ my $follow = $pad - 1;
+ return 0 if $follow > $len || $follow < 1;
+
+ # use the string form to check whether only '0's follow or not
+ substr ($xs,-$follow) =~ /[^0]/ ? 1 : 0;
+ }
+
+sub fround
+ {
+ # Exists to make life easier for switch between MBF and MBI (should we
+ # autoload fxxx() like MBF does for bxxx()?)
+ my $x = shift; $x = $class->new($x) unless ref $x;
+ $x->bround(@_);
+ }
+
+sub bround
+ {
+ # accuracy: +$n preserve $n digits from left,
+ # -$n preserve $n digits from right (f.i. for 0.1234 style in MBF)
+ # no-op for $n == 0
+ # and overwrite the rest with 0's, return normalized number
+ # do not return $x->bnorm(), but $x
+
+ my $x = shift; $x = $class->new($x) unless ref $x;
+ my ($scale,$mode) = $x->_scale_a(@_);
+ return $x if !defined $scale || $x->modify('bround'); # no-op
+
+ if ($x->is_zero() || $scale == 0)
+ {
+ $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
+ return $x;
+ }
+ return $x if $x->{sign} !~ /^[+-]$/; # inf, NaN
+
+ # we have fewer digits than we want to scale to
+ my $len = $x->length();
+ # convert $scale to a scalar in case it is an object (put's a limit on the
+ # number length, but this would already limited by memory constraints), makes
+ # it faster
+ $scale = $scale->numify() if ref ($scale);
+
+ # scale < 0, but > -len (not >=!)
+ if (($scale < 0 && $scale < -$len-1) || ($scale >= $len))
+ {
+ $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
+ return $x;
+ }
+
+ # count of 0's to pad, from left (+) or right (-): 9 - +6 => 3, or |-6| => 6
+ my ($pad,$digit_round,$digit_after);
+ $pad = $len - $scale;
+ $pad = abs($scale-1) if $scale < 0;
+
+ # do not use digit(), it is very costly for binary => decimal
+ # getting the entire string is also costly, but we need to do it only once
+ my $xs = $CALC->_str($x->{value});
+ my $pl = -$pad-1;
+
+ # pad: 123: 0 => -1, at 1 => -2, at 2 => -3, at 3 => -4
+ # pad+1: 123: 0 => 0, at 1 => -1, at 2 => -2, at 3 => -3
+ $digit_round = '0'; $digit_round = substr($xs,$pl,1) if $pad <= $len;
+ $pl++; $pl ++ if $pad >= $len;
+ $digit_after = '0'; $digit_after = substr($xs,$pl,1) if $pad > 0;
+
+ # in case of 01234 we round down, for 6789 up, and only in case 5 we look
+ # closer at the remaining digits of the original $x, remember decision
+ my $round_up = 1; # default round up
+ $round_up -- if
+ ($mode eq 'trunc') || # trunc by round down
+ ($digit_after =~ /[01234]/) || # round down anyway,
+ # 6789 => round up
+ ($digit_after eq '5') && # not 5000...0000
+ ($x->_scan_for_nonzero($pad,$xs,$len) == 0) &&
+ (
+ ($mode eq 'even') && ($digit_round =~ /[24680]/) ||
+ ($mode eq 'odd') && ($digit_round =~ /[13579]/) ||
+ ($mode eq '+inf') && ($x->{sign} eq '-') ||
+ ($mode eq '-inf') && ($x->{sign} eq '+') ||
+ ($mode eq 'zero') # round down if zero, sign adjusted below
+ );
+ my $put_back = 0; # not yet modified
+
+ if (($pad > 0) && ($pad <= $len))
+ {
+ substr($xs,-$pad,$pad) = '0' x $pad; # replace with '00...'
+ $put_back = 1; # need to put back
+ }
+ elsif ($pad > $len)
+ {
+ $x->bzero(); # round to '0'
+ }
+
+ if ($round_up) # what gave test above?
+ {
+ $put_back = 1; # need to put back
+ $pad = $len, $xs = '0' x $pad if $scale < 0; # tlr: whack 0.51=>1.0
+
+ # we modify directly the string variant instead of creating a number and
+ # adding it, since that is faster (we already have the string)
+ my $c = 0; $pad ++; # for $pad == $len case
+ while ($pad <= $len)
+ {
+ $c = substr($xs,-$pad,1) + 1; $c = '0' if $c eq '10';
+ substr($xs,-$pad,1) = $c; $pad++;
+ last if $c != 0; # no overflow => early out
+ }
+ $xs = '1'.$xs if $c == 0;
+
+ }
+ $x->{value} = $CALC->_new($xs) if $put_back == 1; # put back, if needed
+
+ $x->{_a} = $scale if $scale >= 0;
+ if ($scale < 0)
+ {
+ $x->{_a} = $len+$scale;
+ $x->{_a} = 0 if $scale < -$len;
+ }
+ $x;
+ }
+
+sub bfloor
+ {
+ # return integer less or equal then number; no-op since it's already integer
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $x->round(@r);
+ }
+
+sub bceil
+ {
+ # return integer greater or equal then number; no-op since it's already int
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $x->round(@r);
+ }
+
+sub as_number
+ {
+ # An object might be asked to return itself as bigint on certain overloaded
+ # operations. This does exactly this, so that sub classes can simple inherit
+ # it or override with their own integer conversion routine.
+ $_[0]->copy();
+ }
+
+sub as_hex
+ {
+ # return as hex string, with prefixed 0x
+ my $x = shift; $x = $class->new($x) if !ref($x);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $s = '';
+ $s = $x->{sign} if $x->{sign} eq '-';
+ $s . $CALC->_as_hex($x->{value});
+ }
+
+sub as_bin
+ {
+ # return as binary string, with prefixed 0b
+ my $x = shift; $x = $class->new($x) if !ref($x);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
+ return $s . $CALC->_as_bin($x->{value});
+ }
+
+sub as_oct
+ {
+ # return as octal string, with prefixed 0
+ my $x = shift; $x = $class->new($x) if !ref($x);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
+ return $s . $CALC->_as_oct($x->{value});
+ }
+
+##############################################################################
+# private stuff (internal use only)
+
+sub objectify
+ {
+ # check for strings, if yes, return objects instead
+
+ # the first argument is number of args objectify() should look at it will
+ # return $count+1 elements, the first will be a classname. This is because
+ # overloaded '""' calls bstr($object,undef,undef) and this would result in
+ # useless objects being created and thrown away. So we cannot simple loop
+ # over @_. If the given count is 0, all arguments will be used.
+
+ # If the second arg is a ref, use it as class.
+ # If not, try to use it as classname, unless undef, then use $class
+ # (aka Math::BigInt). The latter shouldn't happen,though.
+
+ # caller: gives us:
+ # $x->badd(1); => ref x, scalar y
+ # Class->badd(1,2); => classname x (scalar), scalar x, scalar y
+ # Class->badd( Class->(1),2); => classname x (scalar), ref x, scalar y
+ # Math::BigInt::badd(1,2); => scalar x, scalar y
+ # In the last case we check number of arguments to turn it silently into
+ # $class,1,2. (We can not take '1' as class ;o)
+ # badd($class,1) is not supported (it should, eventually, try to add undef)
+ # currently it tries 'Math::BigInt' + 1, which will not work.
+
+ # some shortcut for the common cases
+ # $x->unary_op();
+ return (ref($_[1]),$_[1]) if (@_ == 2) && ($_[0]||0 == 1) && ref($_[1]);
+
+ my $count = abs(shift || 0);
+
+ my (@a,$k,$d); # resulting array, temp, and downgrade
+ if (ref $_[0])
+ {
+ # okay, got object as first
+ $a[0] = ref $_[0];
+ }
+ else
+ {
+ # nope, got 1,2 (Class->xxx(1) => Class,1 and not supported)
+ $a[0] = $class;
+ $a[0] = shift if $_[0] =~ /^[A-Z].*::/; # classname as first?
+ }
+
+ no strict 'refs';
+ # disable downgrading, because Math::BigFLoat->foo('1.0','2.0') needs floats
+ if (defined ${"$a[0]::downgrade"})
+ {
+ $d = ${"$a[0]::downgrade"};
+ ${"$a[0]::downgrade"} = undef;
+ }
+
+ my $up = ${"$a[0]::upgrade"};
+ # print STDERR "# Now in objectify, my class is today $a[0], count = $count\n";
+ if ($count == 0)
+ {
+ while (@_)
+ {
+ $k = shift;
+ if (!ref($k))
+ {
+ $k = $a[0]->new($k);
+ }
+ elsif (!defined $up && ref($k) ne $a[0])
+ {
+ # foreign object, try to convert to integer
+ $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
+ }
+ push @a,$k;
+ }
+ }
+ else
+ {
+ while ($count > 0)
+ {
+ $count--;
+ $k = shift;
+ if (!ref($k))
+ {
+ $k = $a[0]->new($k);
+ }
+ elsif (!defined $up && ref($k) ne $a[0])
+ {
+ # foreign object, try to convert to integer
+ $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
+ }
+ push @a,$k;
+ }
+ push @a,@_; # return other params, too
+ }
+ if (! wantarray)
+ {
+ require Carp; Carp::croak ("$class objectify needs list context");
+ }
+ ${"$a[0]::downgrade"} = $d;
+ @a;
+ }
+
+sub _register_callback
+ {
+ my ($class,$callback) = @_;
+
+ if (ref($callback) ne 'CODE')
+ {
+ require Carp;
+ Carp::croak ("$callback is not a coderef");
+ }
+ $CALLBACKS{$class} = $callback;
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ $IMPORT++; # remember we did import()
+ my @a; my $l = scalar @_;
+ my $warn_or_die = 0; # 0 - no warn, 1 - warn, 2 - die
+ for ( my $i = 0; $i < $l ; $i++ )
+ {
+ if ($_[$i] eq ':constant')
+ {
+ # this causes overlord er load to step in
+ overload::constant
+ integer => sub { $self->new(shift) },
+ binary => sub { $self->new(shift) };
+ }
+ elsif ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] =~ /^(lib|try|only)\z/)
+ {
+ # this causes a different low lib to take care...
+ $CALC = $_[$i+1] || '';
+ # lib => 1 (warn on fallback), try => 0 (no warn), only => 2 (die on fallback)
+ $warn_or_die = 1 if $_[$i] eq 'lib';
+ $warn_or_die = 2 if $_[$i] eq 'only';
+ $i++;
+ }
+ else
+ {
+ push @a, $_[$i];
+ }
+ }
+ # any non :constant stuff is handled by our parent, Exporter
+ if (@a > 0)
+ {
+ require Exporter;
+
+ $self->SUPER::import(@a); # need it for subclasses
+ $self->export_to_level(1,$self,@a); # need it for MBF
+ }
+
+ # try to load core math lib
+ my @c = split /\s*,\s*/,$CALC;
+ foreach (@c)
+ {
+ $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters
+ }
+ push @c, \'FastCalc', \'Calc' # if all fail, try these
+ if $warn_or_die < 2; # but not for "only"
+ $CALC = ''; # signal error
+ foreach my $l (@c)
+ {
+ # fallback libraries are "marked" as \'string', extract string if nec.
+ my $lib = $l; $lib = $$l if ref($l);
+
+ next if ($lib || '') eq '';
+ $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i;
+ $lib =~ s/\.pm$//;
+ if ($] < 5.006)
+ {
+ # Perl < 5.6.0 dies with "out of memory!" when eval("") and ':constant' is
+ # used in the same script, or eval("") inside import().
+ my @parts = split /::/, $lib; # Math::BigInt => Math BigInt
+ my $file = pop @parts; $file .= '.pm'; # BigInt => BigInt.pm
+ require File::Spec;
+ $file = File::Spec->catfile (@parts, $file);
+ eval { require "$file"; $lib->import( @c ); }
+ }
+ else
+ {
+ eval "use $lib qw/@c/;";
+ }
+ if ($@ eq '')
+ {
+ my $ok = 1;
+ # loaded it ok, see if the api_version() is high enough
+ if ($lib->can('api_version') && $lib->api_version() >= 1.0)
+ {
+ $ok = 0;
+ # api_version matches, check if it really provides anything we need
+ for my $method (qw/
+ one two ten
+ str num
+ add mul div sub dec inc
+ acmp len digit is_one is_zero is_even is_odd
+ is_two is_ten
+ zeros new copy check
+ from_hex from_oct from_bin as_hex as_bin as_oct
+ rsft lsft xor and or
+ mod sqrt root fac pow modinv modpow log_int gcd
+ /)
+ {
+ if (!$lib->can("_$method"))
+ {
+ if (($WARN{$lib}||0) < 2)
+ {
+ require Carp;
+ Carp::carp ("$lib is missing method '_$method'");
+ $WARN{$lib} = 1; # still warn about the lib
+ }
+ $ok++; last;
+ }
+ }
+ }
+ if ($ok == 0)
+ {
+ $CALC = $lib;
+ if ($warn_or_die > 0 && ref($l))
+ {
+ require Carp;
+ my $msg = "Math::BigInt: couldn't load specified math lib(s), fallback to $lib";
+ Carp::carp ($msg) if $warn_or_die == 1;
+ Carp::croak ($msg) if $warn_or_die == 2;
+ }
+ last; # found a usable one, break
+ }
+ else
+ {
+ if (($WARN{$lib}||0) < 2)
+ {
+ my $ver = eval "\$$lib\::VERSION" || 'unknown';
+ require Carp;
+ Carp::carp ("Cannot load outdated $lib v$ver, please upgrade");
+ $WARN{$lib} = 2; # never warn again
+ }
+ }
+ }
+ }
+ if ($CALC eq '')
+ {
+ require Carp;
+ if ($warn_or_die == 2)
+ {
+ Carp::croak ("Couldn't load specified math lib(s) and fallback disallowed");
+ }
+ else
+ {
+ Carp::croak ("Couldn't load any math lib(s), not even fallback to Calc.pm");
+ }
+ }
+
+ # notify callbacks
+ foreach my $class (keys %CALLBACKS)
+ {
+ &{$CALLBACKS{$class}}($CALC);
+ }
+
+ # Fill $CAN with the results of $CALC->can(...) for emulating lower math lib
+ # functions
+
+ %CAN = ();
+ for my $method (qw/ signed_and signed_or signed_xor /)
+ {
+ $CAN{$method} = $CALC->can("_$method") ? 1 : 0;
+ }
+
+ # import done
+ }
+
+sub from_hex
+ {
+ # create a bigint from a hexadecimal string
+ my ($self, $hs) = @_;
+
+ my $rc = __from_hex($hs);
+
+ return $self->bnan() unless defined $rc;
+
+ $rc;
+ }
+
+sub from_bin
+ {
+ # create a bigint from a hexadecimal string
+ my ($self, $bs) = @_;
+
+ my $rc = __from_bin($bs);
+
+ return $self->bnan() unless defined $rc;
+
+ $rc;
+ }
+
+sub from_oct
+ {
+ # create a bigint from a hexadecimal string
+ my ($self, $os) = @_;
+
+ my $x = $self->bzero();
+
+ # strip underscores
+ $os =~ s/([0-7])_([0-7])/$1$2/g;
+ $os =~ s/([0-7])_([0-7])/$1$2/g;
+
+ return $x->bnan() if $os !~ /^[\-\+]?0[0-7]+\z/;
+
+ my $sign = '+'; $sign = '-' if $os =~ /^-/;
+
+ $os =~ s/^[+-]//; # strip sign
+ $x->{value} = $CALC->_from_oct($os);
+ $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
+ $x;
+ }
+
+sub __from_hex
+ {
+ # internal
+ # convert a (ref to) big hex string to BigInt, return undef for error
+ my $hs = shift;
+
+ my $x = Math::BigInt->bzero();
+
+ # strip underscores
+ $hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;
+ $hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;
+
+ return $x->bnan() if $hs !~ /^[\-\+]?0x[0-9A-Fa-f]+$/;
+
+ my $sign = '+'; $sign = '-' if $hs =~ /^-/;
+
+ $hs =~ s/^[+-]//; # strip sign
+ $x->{value} = $CALC->_from_hex($hs);
+ $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
+ $x;
+ }
+
+sub __from_bin
+ {
+ # internal
+ # convert a (ref to) big binary string to BigInt, return undef for error
+ my $bs = shift;
+
+ my $x = Math::BigInt->bzero();
+
+ # strip underscores
+ $bs =~ s/([01])_([01])/$1$2/g;
+ $bs =~ s/([01])_([01])/$1$2/g;
+ return $x->bnan() if $bs !~ /^[+-]?0b[01]+$/;
+
+ my $sign = '+'; $sign = '-' if $bs =~ /^\-/;
+ $bs =~ s/^[+-]//; # strip sign
+
+ $x->{value} = $CALC->_from_bin($bs);
+ $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
+ $x;
+ }
+
+sub _split
+ {
+ # input: num_str; output: undef for invalid or
+ # (\$mantissa_sign,\$mantissa_value,\$mantissa_fraction,\$exp_sign,\$exp_value)
+ # Internal, take apart a string and return the pieces.
+ # Strip leading/trailing whitespace, leading zeros, underscore and reject
+ # invalid input.
+ my $x = shift;
+
+ # strip white space at front, also extranous leading zeros
+ $x =~ s/^\s*([-]?)0*([0-9])/$1$2/g; # will not strip ' .2'
+ $x =~ s/^\s+//; # but this will
+ $x =~ s/\s+$//g; # strip white space at end
+
+ # shortcut, if nothing to split, return early
+ if ($x =~ /^[+-]?[0-9]+\z/)
+ {
+ $x =~ s/^([+-])0*([0-9])/$2/; my $sign = $1 || '+';
+ return (\$sign, \$x, \'', \'', \0);
+ }
+
+ # invalid starting char?
+ return if $x !~ /^[+-]?(\.?[0-9]|0b[0-1]|0x[0-9a-fA-F])/;
+
+ return __from_hex($x) if $x =~ /^[\-\+]?0x/; # hex string
+ return __from_bin($x) if $x =~ /^[\-\+]?0b/; # binary string
+
+ # strip underscores between digits
+ $x =~ s/([0-9])_([0-9])/$1$2/g;
+ $x =~ s/([0-9])_([0-9])/$1$2/g; # do twice for 1_2_3
+
+ # some possible inputs:
+ # 2.1234 # 0.12 # 1 # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2
+ # .2 # 1_2_3.4_5_6 # 1.4E1_2_3 # 1e3 # +.2 # 0e999
+
+ my ($m,$e,$last) = split /[Ee]/,$x;
+ return if defined $last; # last defined => 1e2E3 or others
+ $e = '0' if !defined $e || $e eq "";
+
+ # sign,value for exponent,mantint,mantfrac
+ my ($es,$ev,$mis,$miv,$mfv);
+ # valid exponent?
+ if ($e =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
+ {
+ $es = $1; $ev = $2;
+ # valid mantissa?
+ return if $m eq '.' || $m eq '';
+ my ($mi,$mf,$lastf) = split /\./,$m;
+ return if defined $lastf; # lastf defined => 1.2.3 or others
+ $mi = '0' if !defined $mi;
+ $mi .= '0' if $mi =~ /^[\-\+]?$/;
+ $mf = '0' if !defined $mf || $mf eq '';
+ if ($mi =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
+ {
+ $mis = $1||'+'; $miv = $2;
+ return unless ($mf =~ /^([0-9]*?)0*$/); # strip trailing zeros
+ $mfv = $1;
+ # handle the 0e999 case here
+ $ev = 0 if $miv eq '0' && $mfv eq '';
+ return (\$mis,\$miv,\$mfv,\$es,\$ev);
+ }
+ }
+ return; # NaN, not a number
+ }
+
+##############################################################################
+# internal calculation routines (others are in Math::BigInt::Calc etc)
+
+sub __lcm
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does modify first argument
+ # LCM
+
+ my ($x,$ty) = @_;
+ return $x->bnan() if ($x->{sign} eq $nan) || ($ty->{sign} eq $nan);
+ my $method = ref($x) . '::bgcd';
+ no strict 'refs';
+ $x * $ty / &$method($x,$ty);
+ }
+
+###############################################################################
+# trigonometric functions
+
+sub bpi
+ {
+ # Calculate PI to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer, that is, always returns '3'.
+ my ($self,$n) = @_;
+ if (@_ == 1)
+ {
+ # called like Math::BigInt::bpi(10);
+ $n = $self; $self = $class;
+ }
+ $self = ref($self) if ref($self);
+
+ return $upgrade->new($n) if defined $upgrade;
+
+ # hard-wired to "3"
+ $self->new(3);
+ }
+
+sub bcos
+ {
+ # Calculate cosinus(x) to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer.
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bcos');
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
+
+ return $upgrade->new($x)->bcos(@r) if defined $upgrade;
+
+ require Math::BigFloat;
+ # calculate the result and truncate it to integer
+ my $t = Math::BigFloat->new($x)->bcos(@r)->as_int();
+
+ $x->bone() if $t->is_one();
+ $x->bzero() if $t->is_zero();
+ $x->round(@r);
+ }
+
+sub bsin
+ {
+ # Calculate sinus(x) to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer.
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bsin');
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
+
+ return $upgrade->new($x)->bsin(@r) if defined $upgrade;
+
+ require Math::BigFloat;
+ # calculate the result and truncate it to integer
+ my $t = Math::BigFloat->new($x)->bsin(@r)->as_int();
+
+ $x->bone() if $t->is_one();
+ $x->bzero() if $t->is_zero();
+ $x->round(@r);
+ }
+
+sub batan2
+ {
+ # calculate arcus tangens of ($y/$x)
+
+ # set up parameters
+ my ($self,$y,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$y,$x,@r) = objectify(2,@_);
+ }
+
+ return $y if $y->modify('batan2');
+
+ return $y->bnan() if ($y->{sign} eq $nan) || ($x->{sign} eq $nan);
+
+ # Y X
+ # != 0 -inf result is +- pi
+ if ($x->is_inf() || $y->is_inf())
+ {
+ # upgrade to BigFloat etc.
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+ if ($y->is_inf())
+ {
+ if ($x->{sign} eq '-inf')
+ {
+ # calculate 3 pi/4 => 2.3.. => 2
+ $y->bone( substr($y->{sign},0,1) );
+ $y->bmul($self->new(2));
+ }
+ elsif ($x->{sign} eq '+inf')
+ {
+ # calculate pi/4 => 0.7 => 0
+ $y->bzero();
+ }
+ else
+ {
+ # calculate pi/2 => 1.5 => 1
+ $y->bone( substr($y->{sign},0,1) );
+ }
+ }
+ else
+ {
+ if ($x->{sign} eq '+inf')
+ {
+ # calculate pi/4 => 0.7 => 0
+ $y->bzero();
+ }
+ else
+ {
+ # PI => 3.1415.. => 3
+ $y->bone( substr($y->{sign},0,1) );
+ $y->bmul($self->new(3));
+ }
+ }
+ return $y;
+ }
+
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+
+ require Math::BigFloat;
+ my $r = Math::BigFloat->new($y)->batan2(Math::BigFloat->new($x),@r)->as_int();
+
+ $x->{value} = $r->{value};
+ $x->{sign} = $r->{sign};
+
+ $x;
+ }
+
+sub batan
+ {
+ # Calculate arcus tangens of x to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer.
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('batan');
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
+
+ return $upgrade->new($x)->batan(@r) if defined $upgrade;
+
+ # calculate the result and truncate it to integer
+ my $t = Math::BigFloat->new($x)->batan(@r);
+
+ $x->{value} = $CALC->_new( $x->as_int()->bstr() );
+ $x->round(@r);
+ }
+
+###############################################################################
+# this method returns 0 if the object can be modified, or 1 if not.
+# We use a fast constant sub() here, to avoid costly calls. Subclasses
+# may override it with special code (f.i. Math::BigInt::Constant does so)
+
+sub modify () { 0; }
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+Math::BigInt - Arbitrary size integer/float math package
+
+=head1 SYNOPSIS
+
+ use Math::BigInt;
+
+ # or make it faster with huge numbers: install (optional)
+ # Math::BigInt::GMP and always use (it will fall back to
+ # pure Perl if the GMP library is not installed):
+ # (See also the L<MATH LIBRARY> section!)
+
+ # will warn if Math::BigInt::GMP cannot be found
+ use Math::BigInt lib => 'GMP';
+
+ # to supress the warning use this:
+ # use Math::BigInt try => 'GMP';
+
+ # dies if GMP cannot be loaded:
+ # use Math::BigInt only => 'GMP';
+
+ my $str = '1234567890';
+ my @values = (64,74,18);
+ my $n = 1; my $sign = '-';
+
+ # Number creation
+ my $x = Math::BigInt->new($str); # defaults to 0
+ my $y = $x->copy(); # make a true copy
+ my $nan = Math::BigInt->bnan(); # create a NotANumber
+ my $zero = Math::BigInt->bzero(); # create a +0
+ my $inf = Math::BigInt->binf(); # create a +inf
+ my $inf = Math::BigInt->binf('-'); # create a -inf
+ my $one = Math::BigInt->bone(); # create a +1
+ my $mone = Math::BigInt->bone('-'); # create a -1
+
+ my $pi = Math::BigInt->bpi(); # returns '3'
+ # see Math::BigFloat::bpi()
+
+ $h = Math::BigInt->new('0x123'); # from hexadecimal
+ $b = Math::BigInt->new('0b101'); # from binary
+ $o = Math::BigInt->from_oct('0101'); # from octal
+
+ # Testing (don't modify their arguments)
+ # (return true if the condition is met, otherwise false)
+
+ $x->is_zero(); # if $x is +0
+ $x->is_nan(); # if $x is NaN
+ $x->is_one(); # if $x is +1
+ $x->is_one('-'); # if $x is -1
+ $x->is_odd(); # if $x is odd
+ $x->is_even(); # if $x is even
+ $x->is_pos(); # if $x >= 0
+ $x->is_neg(); # if $x < 0
+ $x->is_inf($sign); # if $x is +inf, or -inf (sign is default '+')
+ $x->is_int(); # if $x is an integer (not a float)
+
+ # comparing and digit/sign extraction
+ $x->bcmp($y); # compare numbers (undef,<0,=0,>0)
+ $x->bacmp($y); # compare absolutely (undef,<0,=0,>0)
+ $x->sign(); # return the sign, either +,- or NaN
+ $x->digit($n); # return the nth digit, counting from right
+ $x->digit(-$n); # return the nth digit, counting from left
+
+ # The following all modify their first argument. If you want to preserve
+ # $x, use $z = $x->copy()->bXXX($y); See under L<CAVEATS> for why this is
+ # necessary when mixing $a = $b assignments with non-overloaded math.
+
+ $x->bzero(); # set $x to 0
+ $x->bnan(); # set $x to NaN
+ $x->bone(); # set $x to +1
+ $x->bone('-'); # set $x to -1
+ $x->binf(); # set $x to inf
+ $x->binf('-'); # set $x to -inf
+
+ $x->bneg(); # negation
+ $x->babs(); # absolute value
+ $x->bnorm(); # normalize (no-op in BigInt)
+ $x->bnot(); # two's complement (bit wise not)
+ $x->binc(); # increment $x by 1
+ $x->bdec(); # decrement $x by 1
+
+ $x->badd($y); # addition (add $y to $x)
+ $x->bsub($y); # subtraction (subtract $y from $x)
+ $x->bmul($y); # multiplication (multiply $x by $y)
+ $x->bdiv($y); # divide, set $x to quotient
+ # return (quo,rem) or quo if scalar
+
+ $x->bmuladd($y,$z); # $x = $x * $y + $z
+
+ $x->bmod($y); # modulus (x % y)
+ $x->bmodpow($exp,$mod); # modular exponentation (($num**$exp) % $mod))
+ $x->bmodinv($mod); # the inverse of $x in the given modulus $mod
+
+ $x->bpow($y); # power of arguments (x ** y)
+ $x->blsft($y); # left shift in base 2
+ $x->brsft($y); # right shift in base 2
+ # returns (quo,rem) or quo if in scalar context
+ $x->blsft($y,$n); # left shift by $y places in base $n
+ $x->brsft($y,$n); # right shift by $y places in base $n
+ # returns (quo,rem) or quo if in scalar context
+
+ $x->band($y); # bitwise and
+ $x->bior($y); # bitwise inclusive or
+ $x->bxor($y); # bitwise exclusive or
+ $x->bnot(); # bitwise not (two's complement)
+
+ $x->bsqrt(); # calculate square-root
+ $x->broot($y); # $y'th root of $x (e.g. $y == 3 => cubic root)
+ $x->bfac(); # factorial of $x (1*2*3*4*..$x)
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+ $x->blog(); # logarithm of $x to base e (Euler's number)
+ $x->blog($base); # logarithm of $x to base $base (f.i. 2)
+ $x->bexp(); # calculate e ** $x where e is Euler's number
+
+ $x->round($A,$P,$mode); # round to accuracy or precision using mode $mode
+ $x->bround($n); # accuracy: preserve $n digits
+ $x->bfround($n); # $n > 0: round $nth digits,
+ # $n < 0: round to the $nth digit after the
+ # dot, no-op for BigInts
+
+ # The following do not modify their arguments in BigInt (are no-ops),
+ # but do so in BigFloat:
+
+ $x->bfloor(); # return integer less or equal than $x
+ $x->bceil(); # return integer greater or equal than $x
+
+ # The following do not modify their arguments:
+
+ # greatest common divisor (no OO style)
+ my $gcd = Math::BigInt::bgcd(@values);
+ # lowest common multiplicator (no OO style)
+ my $lcm = Math::BigInt::blcm(@values);
+
+ $x->length(); # return number of digits in number
+ ($xl,$f) = $x->length(); # length of number and length of fraction part,
+ # latter is always 0 digits long for BigInts
+
+ $x->exponent(); # return exponent as BigInt
+ $x->mantissa(); # return (signed) mantissa as BigInt
+ $x->parts(); # return (mantissa,exponent) as BigInt
+ $x->copy(); # make a true copy of $x (unlike $y = $x;)
+ $x->as_int(); # return as BigInt (in BigInt: same as copy())
+ $x->numify(); # return as scalar (might overflow!)
+
+ # conversation to string (do not modify their argument)
+ $x->bstr(); # normalized string (e.g. '3')
+ $x->bsstr(); # norm. string in scientific notation (e.g. '3E0')
+ $x->as_hex(); # as signed hexadecimal string with prefixed 0x
+ $x->as_bin(); # as signed binary string with prefixed 0b
+ $x->as_oct(); # as signed octal string with prefixed 0
+
+
+ # precision and accuracy (see section about rounding for more)
+ $x->precision(); # return P of $x (or global, if P of $x undef)
+ $x->precision($n); # set P of $x to $n
+ $x->accuracy(); # return A of $x (or global, if A of $x undef)
+ $x->accuracy($n); # set A $x to $n
+
+ # Global methods
+ Math::BigInt->precision(); # get/set global P for all BigInt objects
+ Math::BigInt->accuracy(); # get/set global A for all BigInt objects
+ Math::BigInt->round_mode(); # get/set global round mode, one of
+ # 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
+ Math::BigInt->config(); # return hash containing configuration
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded if you
+declare your big integers as
+
+ $i = new Math::BigInt '123_456_789_123_456_789';
+
+Operations with overloaded operators preserve the arguments which is
+exactly what you expect.
+
+=over 2
+
+=item Input
+
+Input values to these routines may be any string, that looks like a number
+and results in an integer, including hexadecimal and binary numbers.
+
+Scalars holding numbers may also be passed, but note that non-integer numbers
+may already have lost precision due to the conversation to float. Quote
+your input if you want BigInt to see all the digits:
+
+ $x = Math::BigInt->new(12345678890123456789); # bad
+ $x = Math::BigInt->new('12345678901234567890'); # good
+
+You can include one underscore between any two digits.
+
+This means integer values like 1.01E2 or even 1000E-2 are also accepted.
+Non-integer values result in NaN.
+
+Hexadecimal (prefixed with "0x") and binary numbers (prefixed with "0b")
+are accepted, too. Please note that octal numbers are not recognized
+by new(), so the following will print "123":
+
+ perl -MMath::BigInt -le 'print Math::BigInt->new("0123")'
+
+To convert an octal number, use from_oct();
+
+ perl -MMath::BigInt -le 'print Math::BigInt->from_oct("0123")'
+
+Currently, Math::BigInt::new() defaults to 0, while Math::BigInt::new('')
+results in 'NaN'. This might change in the future, so use always the following
+explicit forms to get a zero or NaN:
+
+ $zero = Math::BigInt->bzero();
+ $nan = Math::BigInt->bnan();
+
+C<bnorm()> on a BigInt object is now effectively a no-op, since the numbers
+are always stored in normalized form. If passed a string, creates a BigInt
+object from the input.
+
+=item Output
+
+Output values are BigInt objects (normalized), except for the methods which
+return a string (see L<SYNOPSIS>).
+
+Some routines (C<is_odd()>, C<is_even()>, C<is_zero()>, C<is_one()>,
+C<is_nan()>, etc.) return true or false, while others (C<bcmp()>, C<bacmp()>)
+return either undef (if NaN is involved), <0, 0 or >0 and are suited for sort.
+
+=back
+
+=head1 METHODS
+
+Each of the methods below (except config(), accuracy() and precision())
+accepts three additional parameters. These arguments C<$A>, C<$P> and C<$R>
+are C<accuracy>, C<precision> and C<round_mode>. Please see the section about
+L<ACCURACY and PRECISION> for more information.
+
+=head2 config()
+
+ use Data::Dumper;
+
+ print Dumper ( Math::BigInt->config() );
+ print Math::BigInt->config()->{lib},"\n";
+
+Returns a hash containing the configuration, e.g. the version number, lib
+loaded etc. The following hash keys are currently filled in with the
+appropriate information.
+
+ key Description
+ Example
+ ============================================================
+ lib Name of the low-level math library
+ Math::BigInt::Calc
+ lib_version Version of low-level math library (see 'lib')
+ 0.30
+ class The class name of config() you just called
+ Math::BigInt
+ upgrade To which class math operations might be upgraded
+ Math::BigFloat
+ downgrade To which class math operations might be downgraded
+ undef
+ precision Global precision
+ undef
+ accuracy Global accuracy
+ undef
+ round_mode Global round mode
+ even
+ version version number of the class you used
+ 1.61
+ div_scale Fallback accuracy for div
+ 40
+ trap_nan If true, traps creation of NaN via croak()
+ 1
+ trap_inf If true, traps creation of +inf/-inf via croak()
+ 1
+
+The following values can be set by passing C<config()> a reference to a hash:
+
+ trap_inf trap_nan
+ upgrade downgrade precision accuracy round_mode div_scale
+
+Example:
+
+ $new_cfg = Math::BigInt->config( { trap_inf => 1, precision => 5 } );
+
+=head2 accuracy()
+
+ $x->accuracy(5); # local for $x
+ CLASS->accuracy(5); # global for all members of CLASS
+ # Note: This also applies to new()!
+
+ $A = $x->accuracy(); # read out accuracy that affects $x
+ $A = CLASS->accuracy(); # read out global accuracy
+
+Set or get the global or local accuracy, aka how many significant digits the
+results have. If you set a global accuracy, then this also applies to new()!
+
+Warning! The accuracy I<sticks>, e.g. once you created a number under the
+influence of C<< CLASS->accuracy($A) >>, all results from math operations with
+that number will also be rounded.
+
+In most cases, you should probably round the results explicitly using one of
+L<round()>, L<bround()> or L<bfround()> or by passing the desired accuracy
+to the math operation as additional parameter:
+
+ my $x = Math::BigInt->new(30000);
+ my $y = Math::BigInt->new(7);
+ print scalar $x->copy()->bdiv($y, 2); # print 4300
+ print scalar $x->copy()->bdiv($y)->bround(2); # print 4300
+
+Please see the section about L<ACCURACY AND PRECISION> for further details.
+
+Value must be greater than zero. Pass an undef value to disable it:
+
+ $x->accuracy(undef);
+ Math::BigInt->accuracy(undef);
+
+Returns the current accuracy. For C<$x->accuracy()> it will return either the
+local accuracy, or if not defined, the global. This means the return value
+represents the accuracy that will be in effect for $x:
+
+ $y = Math::BigInt->new(1234567); # unrounded
+ print Math::BigInt->accuracy(4),"\n"; # set 4, print 4
+ $x = Math::BigInt->new(123456); # $x will be automatically rounded!
+ print "$x $y\n"; # '123500 1234567'
+ print $x->accuracy(),"\n"; # will be 4
+ print $y->accuracy(),"\n"; # also 4, since global is 4
+ print Math::BigInt->accuracy(5),"\n"; # set to 5, print 5
+ print $x->accuracy(),"\n"; # still 4
+ print $y->accuracy(),"\n"; # 5, since global is 5
+
+Note: Works also for subclasses like Math::BigFloat. Each class has it's own
+globals separated from Math::BigInt, but it is possible to subclass
+Math::BigInt and make the globals of the subclass aliases to the ones from
+Math::BigInt.
+
+=head2 precision()
+
+ $x->precision(-2); # local for $x, round at the second digit right of the dot
+ $x->precision(2); # ditto, round at the second digit left of the dot
+
+ CLASS->precision(5); # Global for all members of CLASS
+ # This also applies to new()!
+ CLASS->precision(-5); # ditto
+
+ $P = CLASS->precision(); # read out global precision
+ $P = $x->precision(); # read out precision that affects $x
+
+Note: You probably want to use L<accuracy()> instead. With L<accuracy> you
+set the number of digits each result should have, with L<precision> you
+set the place where to round!
+
+C<precision()> sets or gets the global or local precision, aka at which digit
+before or after the dot to round all results. A set global precision also
+applies to all newly created numbers!
+
+In Math::BigInt, passing a negative number precision has no effect since no
+numbers have digits after the dot. In L<Math::BigFloat>, it will round all
+results to P digits after the dot.
+
+Please see the section about L<ACCURACY AND PRECISION> for further details.
+
+Pass an undef value to disable it:
+
+ $x->precision(undef);
+ Math::BigInt->precision(undef);
+
+Returns the current precision. For C<$x->precision()> it will return either the
+local precision of $x, or if not defined, the global. This means the return
+value represents the prevision that will be in effect for $x:
+
+ $y = Math::BigInt->new(1234567); # unrounded
+ print Math::BigInt->precision(4),"\n"; # set 4, print 4
+ $x = Math::BigInt->new(123456); # will be automatically rounded
+ print $x; # print "120000"!
+
+Note: Works also for subclasses like L<Math::BigFloat>. Each class has its
+own globals separated from Math::BigInt, but it is possible to subclass
+Math::BigInt and make the globals of the subclass aliases to the ones from
+Math::BigInt.
+
+=head2 brsft()
+
+ $x->brsft($y,$n);
+
+Shifts $x right by $y in base $n. Default is base 2, used are usually 10 and
+2, but others work, too.
+
+Right shifting usually amounts to dividing $x by $n ** $y and truncating the
+result:
+
+
+ $x = Math::BigInt->new(10);
+ $x->brsft(1); # same as $x >> 1: 5
+ $x = Math::BigInt->new(1234);
+ $x->brsft(2,10); # result 12
+
+There is one exception, and that is base 2 with negative $x:
+
+
+ $x = Math::BigInt->new(-5);
+ print $x->brsft(1);
+
+This will print -3, not -2 (as it would if you divide -5 by 2 and truncate the
+result).
+
+=head2 new()
+
+ $x = Math::BigInt->new($str,$A,$P,$R);
+
+Creates a new BigInt object from a scalar or another BigInt object. The
+input is accepted as decimal, hex (with leading '0x') or binary (with leading
+'0b').
+
+See L<Input> for more info on accepted input formats.
+
+=head2 from_oct()
+
+ $x = Math::BigInt->from_oct("0775"); # input is octal
+
+=head2 from_hex()
+
+ $x = Math::BigInt->from_hex("0xcafe"); # input is hexadecimal
+
+=head2 from_bin()
+
+ $x = Math::BigInt->from_oct("0x10011"); # input is binary
+
+=head2 bnan()
+
+ $x = Math::BigInt->bnan();
+
+Creates a new BigInt object representing NaN (Not A Number).
+If used on an object, it will set it to NaN:
+
+ $x->bnan();
+
+=head2 bzero()
+
+ $x = Math::BigInt->bzero();
+
+Creates a new BigInt object representing zero.
+If used on an object, it will set it to zero:
+
+ $x->bzero();
+
+=head2 binf()
+
+ $x = Math::BigInt->binf($sign);
+
+Creates a new BigInt object representing infinity. The optional argument is
+either '-' or '+', indicating whether you want infinity or minus infinity.
+If used on an object, it will set it to infinity:
+
+ $x->binf();
+ $x->binf('-');
+
+=head2 bone()
+
+ $x = Math::BigInt->binf($sign);
+
+Creates a new BigInt object representing one. The optional argument is
+either '-' or '+', indicating whether you want one or minus one.
+If used on an object, it will set it to one:
+
+ $x->bone(); # +1
+ $x->bone('-'); # -1
+
+=head2 is_one()/is_zero()/is_nan()/is_inf()
+
+
+ $x->is_zero(); # true if arg is +0
+ $x->is_nan(); # true if arg is NaN
+ $x->is_one(); # true if arg is +1
+ $x->is_one('-'); # true if arg is -1
+ $x->is_inf(); # true if +inf
+ $x->is_inf('-'); # true if -inf (sign is default '+')
+
+These methods all test the BigInt for being one specific value and return
+true or false depending on the input. These are faster than doing something
+like:
+
+ if ($x == 0)
+
+=head2 is_pos()/is_neg()/is_positive()/is_negative()
+
+ $x->is_pos(); # true if > 0
+ $x->is_neg(); # true if < 0
+
+The methods return true if the argument is positive or negative, respectively.
+C<NaN> is neither positive nor negative, while C<+inf> counts as positive, and
+C<-inf> is negative. A C<zero> is neither positive nor negative.
+
+These methods are only testing the sign, and not the value.
+
+C<is_positive()> and C<is_negative()> are aliases to C<is_pos()> and
+C<is_neg()>, respectively. C<is_positive()> and C<is_negative()> were
+introduced in v1.36, while C<is_pos()> and C<is_neg()> were only introduced
+in v1.68.
+
+=head2 is_odd()/is_even()/is_int()
+
+ $x->is_odd(); # true if odd, false for even
+ $x->is_even(); # true if even, false for odd
+ $x->is_int(); # true if $x is an integer
+
+The return true when the argument satisfies the condition. C<NaN>, C<+inf>,
+C<-inf> are not integers and are neither odd nor even.
+
+In BigInt, all numbers except C<NaN>, C<+inf> and C<-inf> are integers.
+
+=head2 bcmp()
+
+ $x->bcmp($y);
+
+Compares $x with $y and takes the sign into account.
+Returns -1, 0, 1 or undef.
+
+=head2 bacmp()
+
+ $x->bacmp($y);
+
+Compares $x with $y while ignoring their. Returns -1, 0, 1 or undef.
+
+=head2 sign()
+
+ $x->sign();
+
+Return the sign, of $x, meaning either C<+>, C<->, C<-inf>, C<+inf> or NaN.
+
+If you want $x to have a certain sign, use one of the following methods:
+
+ $x->babs(); # '+'
+ $x->babs()->bneg(); # '-'
+ $x->bnan(); # 'NaN'
+ $x->binf(); # '+inf'
+ $x->binf('-'); # '-inf'
+
+=head2 digit()
+
+ $x->digit($n); # return the nth digit, counting from right
+
+If C<$n> is negative, returns the digit counting from left.
+
+=head2 bneg()
+
+ $x->bneg();
+
+Negate the number, e.g. change the sign between '+' and '-', or between '+inf'
+and '-inf', respectively. Does nothing for NaN or zero.
+
+=head2 babs()
+
+ $x->babs();
+
+Set the number to its absolute value, e.g. change the sign from '-' to '+'
+and from '-inf' to '+inf', respectively. Does nothing for NaN or positive
+numbers.
+
+=head2 bnorm()
+
+ $x->bnorm(); # normalize (no-op)
+
+=head2 bnot()
+
+ $x->bnot();
+
+Two's complement (bitwise not). This is equivalent to
+
+ $x->binc()->bneg();
+
+but faster.
+
+=head2 binc()
+
+ $x->binc(); # increment x by 1
+
+=head2 bdec()
+
+ $x->bdec(); # decrement x by 1
+
+=head2 badd()
+
+ $x->badd($y); # addition (add $y to $x)
+
+=head2 bsub()
+
+ $x->bsub($y); # subtraction (subtract $y from $x)
+
+=head2 bmul()
+
+ $x->bmul($y); # multiplication (multiply $x by $y)
+
+=head2 bmuladd()
+
+ $x->bmuladd($y,$z);
+
+Multiply $x by $y, and then add $z to the result,
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bdiv()
+
+ $x->bdiv($y); # divide, set $x to quotient
+ # return (quo,rem) or quo if scalar
+
+=head2 bmod()
+
+ $x->bmod($y); # modulus (x % y)
+
+=head2 bmodinv()
+
+ num->bmodinv($mod); # modular inverse
+
+Returns the inverse of C<$num> in the given modulus C<$mod>. 'C<NaN>' is
+returned unless C<$num> is relatively prime to C<$mod>, i.e. unless
+C<bgcd($num, $mod)==1>.
+
+=head2 bmodpow()
+
+ $num->bmodpow($exp,$mod); # modular exponentation
+ # ($num**$exp % $mod)
+
+Returns the value of C<$num> taken to the power C<$exp> in the modulus
+C<$mod> using binary exponentation. C<bmodpow> is far superior to
+writing
+
+ $num ** $exp % $mod
+
+because it is much faster - it reduces internal variables into
+the modulus whenever possible, so it operates on smaller numbers.
+
+C<bmodpow> also supports negative exponents.
+
+ bmodpow($num, -1, $mod)
+
+is exactly equivalent to
+
+ bmodinv($num, $mod)
+
+=head2 bpow()
+
+ $x->bpow($y); # power of arguments (x ** y)
+
+=head2 blog()
+
+ $x->blog($base, $accuracy); # logarithm of x to the base $base
+
+If C<$base> is not defined, Euler's number (e) is used:
+
+ print $x->blog(undef, 100); # log(x) to 100 digits
+
+=head2 bexp()
+
+ $x->bexp($accuracy); # calculate e ** X
+
+Calculates the expression C<e ** $x> where C<e> is Euler's number.
+
+This method was added in v1.82 of Math::BigInt (April 2007).
+
+See also L<blog()>.
+
+=head2 bnok()
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+Calculates the binomial coefficient n over k, also called the "choose"
+function. The result is equivalent to:
+
+ ( n ) n!
+ | - | = -------
+ ( k ) k!(n-k)!
+
+This method was added in v1.84 of Math::BigInt (April 2007).
+
+=head2 bpi()
+
+ print Math::BigInt->bpi(100), "\n"; # 3
+
+Returns PI truncated to an integer, with the argument being ignored. This means
+under BigInt this always returns C<3>.
+
+If upgrading is in effect, returns PI, rounded to N digits with the
+current rounding mode:
+
+ use Math::BigFloat;
+ use Math::BigInt upgrade => Math::BigFloat;
+ print Math::BigInt->bpi(3), "\n"; # 3.14
+ print Math::BigInt->bpi(100), "\n"; # 3.1415....
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bcos()
+
+ my $x = Math::BigInt->new(1);
+ print $x->bcos(100), "\n";
+
+Calculate the cosinus of $x, modifying $x in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bsin()
+
+ my $x = Math::BigInt->new(1);
+ print $x->bsin(100), "\n";
+
+Calculate the sinus of $x, modifying $x in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan2()
+
+ my $x = Math::BigInt->new(1);
+ my $y = Math::BigInt->new(1);
+ print $y->batan2($x), "\n";
+
+Calculate the arcus tangens of C<$y> divided by C<$x>, modifying $y in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan()
+
+ my $x = Math::BigFloat->new(0.5);
+ print $x->batan(100), "\n";
+
+Calculate the arcus tangens of $x, modifying $x in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 blsft()
+
+ $x->blsft($y); # left shift in base 2
+ $x->blsft($y,$n); # left shift, in base $n (like 10)
+
+=head2 brsft()
+
+ $x->brsft($y); # right shift in base 2
+ $x->brsft($y,$n); # right shift, in base $n (like 10)
+
+=head2 band()
+
+ $x->band($y); # bitwise and
+
+=head2 bior()
+
+ $x->bior($y); # bitwise inclusive or
+
+=head2 bxor()
+
+ $x->bxor($y); # bitwise exclusive or
+
+=head2 bnot()
+
+ $x->bnot(); # bitwise not (two's complement)
+
+=head2 bsqrt()
+
+ $x->bsqrt(); # calculate square-root
+
+=head2 broot()
+
+ $x->broot($N);
+
+Calculates the N'th root of C<$x>.
+
+=head2 bfac()
+
+ $x->bfac(); # factorial of $x (1*2*3*4*..$x)
+
+=head2 round()
+
+ $x->round($A,$P,$round_mode);
+
+Round $x to accuracy C<$A> or precision C<$P> using the round mode
+C<$round_mode>.
+
+=head2 bround()
+
+ $x->bround($N); # accuracy: preserve $N digits
+
+=head2 bfround()
+
+ $x->bfround($N);
+
+If N is > 0, rounds to the Nth digit from the left. If N < 0, rounds to
+the Nth digit after the dot. Since BigInts are integers, the case N < 0
+is a no-op for them.
+
+Examples:
+
+ Input N Result
+ ===================================================
+ 123456.123456 3 123500
+ 123456.123456 2 123450
+ 123456.123456 -2 123456.12
+ 123456.123456 -3 123456.123
+
+=head2 bfloor()
+
+ $x->bfloor();
+
+Set $x to the integer less or equal than $x. This is a no-op in BigInt, but
+does change $x in BigFloat.
+
+=head2 bceil()
+
+ $x->bceil();
+
+Set $x to the integer greater or equal than $x. This is a no-op in BigInt, but
+does change $x in BigFloat.
+
+=head2 bgcd()
+
+ bgcd(@values); # greatest common divisor (no OO style)
+
+=head2 blcm()
+
+ blcm(@values); # lowest common multiplicator (no OO style)
+
+head2 length()
+
+ $x->length();
+ ($xl,$fl) = $x->length();
+
+Returns the number of digits in the decimal representation of the number.
+In list context, returns the length of the integer and fraction part. For
+BigInt's, the length of the fraction part will always be 0.
+
+=head2 exponent()
+
+ $x->exponent();
+
+Return the exponent of $x as BigInt.
+
+=head2 mantissa()
+
+ $x->mantissa();
+
+Return the signed mantissa of $x as BigInt.
+
+=head2 parts()
+
+ $x->parts(); # return (mantissa,exponent) as BigInt
+
+=head2 copy()
+
+ $x->copy(); # make a true copy of $x (unlike $y = $x;)
+
+=head2 as_int()/as_number()
+
+ $x->as_int();
+
+Returns $x as a BigInt (truncated towards zero). In BigInt this is the same as
+C<copy()>.
+
+C<as_number()> is an alias to this method. C<as_number> was introduced in
+v1.22, while C<as_int()> was only introduced in v1.68.
+
+=head2 bstr()
+
+ $x->bstr();
+
+Returns a normalized string representation of C<$x>.
+
+=head2 bsstr()
+
+ $x->bsstr(); # normalized string in scientific notation
+
+=head2 as_hex()
+
+ $x->as_hex(); # as signed hexadecimal string with prefixed 0x
+
+=head2 as_bin()
+
+ $x->as_bin(); # as signed binary string with prefixed 0b
+
+=head2 as_oct()
+
+ $x->as_oct(); # as signed octal string with prefixed 0
+
+=head2 numify()
+
+ print $x->numify();
+
+This returns a normal Perl scalar from $x. It is used automatically
+whenever a scalar is needed, for instance in array index operations.
+
+This loses precision, to avoid this use L<as_int()> instead.
+
+=head2 modify()
+
+ $x->modify('bpowd');
+
+This method returns 0 if the object can be modified with the given
+peration, or 1 if not.
+
+This is used for instance by L<Math::BigInt::Constant>.
+
+=head2 upgrade()/downgrade()
+
+Set/get the class for downgrade/upgrade operations. Thuis is used
+for instance by L<bignum>. The defaults are '', thus the following
+operation will create a BigInt, not a BigFloat:
+
+ my $i = Math::BigInt->new(123);
+ my $f = Math::BigFloat->new('123.1');
+
+ print $i + $f,"\n"; # print 246
+
+=head2 div_scale()
+
+Set/get the number of digits for the default precision in divide
+operations.
+
+=head2 round_mode()
+
+Set/get the current round mode.
+
+=head1 ACCURACY and PRECISION
+
+Since version v1.33, Math::BigInt and Math::BigFloat have full support for
+accuracy and precision based rounding, both automatically after every
+operation, as well as manually.
+
+This section describes the accuracy/precision handling in Math::Big* as it
+used to be and as it is now, complete with an explanation of all terms and
+abbreviations.
+
+Not yet implemented things (but with correct description) are marked with '!',
+things that need to be answered are marked with '?'.
+
+In the next paragraph follows a short description of terms used here (because
+these may differ from terms used by others people or documentation).
+
+During the rest of this document, the shortcuts A (for accuracy), P (for
+precision), F (fallback) and R (rounding mode) will be used.
+
+=head2 Precision P
+
+A fixed number of digits before (positive) or after (negative)
+the decimal point. For example, 123.45 has a precision of -2. 0 means an
+integer like 123 (or 120). A precision of 2 means two digits to the left
+of the decimal point are zero, so 123 with P = 1 becomes 120. Note that
+numbers with zeros before the decimal point may have different precisions,
+because 1200 can have p = 0, 1 or 2 (depending on what the inital value
+was). It could also have p < 0, when the digits after the decimal point
+are zero.
+
+The string output (of floating point numbers) will be padded with zeros:
+
+ Initial value P A Result String
+ ------------------------------------------------------------
+ 1234.01 -3 1000 1000
+ 1234 -2 1200 1200
+ 1234.5 -1 1230 1230
+ 1234.001 1 1234 1234.0
+ 1234.01 0 1234 1234
+ 1234.01 2 1234.01 1234.01
+ 1234.01 5 1234.01 1234.01000
+
+For BigInts, no padding occurs.
+
+=head2 Accuracy A
+
+Number of significant digits. Leading zeros are not counted. A
+number may have an accuracy greater than the non-zero digits
+when there are zeros in it or trailing zeros. For example, 123.456 has
+A of 6, 10203 has 5, 123.0506 has 7, 123.450000 has 8 and 0.000123 has 3.
+
+The string output (of floating point numbers) will be padded with zeros:
+
+ Initial value P A Result String
+ ------------------------------------------------------------
+ 1234.01 3 1230 1230
+ 1234.01 6 1234.01 1234.01
+ 1234.1 8 1234.1 1234.1000
+
+For BigInts, no padding occurs.
+
+=head2 Fallback F
+
+When both A and P are undefined, this is used as a fallback accuracy when
+dividing numbers.
+
+=head2 Rounding mode R
+
+When rounding a number, different 'styles' or 'kinds'
+of rounding are possible. (Note that random rounding, as in
+Math::Round, is not implemented.)
+
+=over 2
+
+=item 'trunc'
+
+truncation invariably removes all digits following the
+rounding place, replacing them with zeros. Thus, 987.65 rounded
+to tens (P=1) becomes 980, and rounded to the fourth sigdig
+becomes 987.6 (A=4). 123.456 rounded to the second place after the
+decimal point (P=-2) becomes 123.46.
+
+All other implemented styles of rounding attempt to round to the
+"nearest digit." If the digit D immediately to the right of the
+rounding place (skipping the decimal point) is greater than 5, the
+number is incremented at the rounding place (possibly causing a
+cascade of incrementation): e.g. when rounding to units, 0.9 rounds
+to 1, and -19.9 rounds to -20. If D < 5, the number is similarly
+truncated at the rounding place: e.g. when rounding to units, 0.4
+rounds to 0, and -19.4 rounds to -19.
+
+However the results of other styles of rounding differ if the
+digit immediately to the right of the rounding place (skipping the
+decimal point) is 5 and if there are no digits, or no digits other
+than 0, after that 5. In such cases:
+
+=item 'even'
+
+rounds the digit at the rounding place to 0, 2, 4, 6, or 8
+if it is not already. E.g., when rounding to the first sigdig, 0.45
+becomes 0.4, -0.55 becomes -0.6, but 0.4501 becomes 0.5.
+
+=item 'odd'
+
+rounds the digit at the rounding place to 1, 3, 5, 7, or 9 if
+it is not already. E.g., when rounding to the first sigdig, 0.45
+becomes 0.5, -0.55 becomes -0.5, but 0.5501 becomes 0.6.
+
+=item '+inf'
+
+round to plus infinity, i.e. always round up. E.g., when
+rounding to the first sigdig, 0.45 becomes 0.5, -0.55 becomes -0.5,
+and 0.4501 also becomes 0.5.
+
+=item '-inf'
+
+round to minus infinity, i.e. always round down. E.g., when
+rounding to the first sigdig, 0.45 becomes 0.4, -0.55 becomes -0.6,
+but 0.4501 becomes 0.5.
+
+=item 'zero'
+
+round to zero, i.e. positive numbers down, negative ones up.
+E.g., when rounding to the first sigdig, 0.45 becomes 0.4, -0.55
+becomes -0.5, but 0.4501 becomes 0.5.
+
+=item 'common'
+
+round up if the digit immediately to the right of the rounding place
+is 5 or greater, otherwise round down. E.g., 0.15 becomes 0.2 and
+0.149 becomes 0.1.
+
+=back
+
+The handling of A & P in MBI/MBF (the old core code shipped with Perl
+versions <= 5.7.2) is like this:
+
+=over 2
+
+=item Precision
+
+ * ffround($p) is able to round to $p number of digits after the decimal
+ point
+ * otherwise P is unused
+
+=item Accuracy (significant digits)
+
+ * fround($a) rounds to $a significant digits
+ * only fdiv() and fsqrt() take A as (optional) paramater
+ + other operations simply create the same number (fneg etc), or more (fmul)
+ of digits
+ + rounding/truncating is only done when explicitly calling one of fround
+ or ffround, and never for BigInt (not implemented)
+ * fsqrt() simply hands its accuracy argument over to fdiv.
+ * the documentation and the comment in the code indicate two different ways
+ on how fdiv() determines the maximum number of digits it should calculate,
+ and the actual code does yet another thing
+ POD:
+ max($Math::BigFloat::div_scale,length(dividend)+length(divisor))
+ Comment:
+ result has at most max(scale, length(dividend), length(divisor)) digits
+ Actual code:
+ scale = max(scale, length(dividend)-1,length(divisor)-1);
+ scale += length(divisor) - length(dividend);
+ So for lx = 3, ly = 9, scale = 10, scale will actually be 16 (10+9-3).
+ Actually, the 'difference' added to the scale is calculated from the
+ number of "significant digits" in dividend and divisor, which is derived
+ by looking at the length of the mantissa. Which is wrong, since it includes
+ the + sign (oops) and actually gets 2 for '+100' and 4 for '+101'. Oops
+ again. Thus 124/3 with div_scale=1 will get you '41.3' based on the strange
+ assumption that 124 has 3 significant digits, while 120/7 will get you
+ '17', not '17.1' since 120 is thought to have 2 significant digits.
+ The rounding after the division then uses the remainder and $y to determine
+ wether it must round up or down.
+ ? I have no idea which is the right way. That's why I used a slightly more
+ ? simple scheme and tweaked the few failing testcases to match it.
+
+=back
+
+This is how it works now:
+
+=over 2
+
+=item Setting/Accessing
+
+ * You can set the A global via C<< Math::BigInt->accuracy() >> or
+ C<< Math::BigFloat->accuracy() >> or whatever class you are using.
+ * You can also set P globally by using C<< Math::SomeClass->precision() >>
+ likewise.
+ * Globals are classwide, and not inherited by subclasses.
+ * to undefine A, use C<< Math::SomeCLass->accuracy(undef); >>
+ * to undefine P, use C<< Math::SomeClass->precision(undef); >>
+ * Setting C<< Math::SomeClass->accuracy() >> clears automatically
+ C<< Math::SomeClass->precision() >>, and vice versa.
+ * To be valid, A must be > 0, P can have any value.
+ * If P is negative, this means round to the P'th place to the right of the
+ decimal point; positive values mean to the left of the decimal point.
+ P of 0 means round to integer.
+ * to find out the current global A, use C<< Math::SomeClass->accuracy() >>
+ * to find out the current global P, use C<< Math::SomeClass->precision() >>
+ * use C<< $x->accuracy() >> respective C<< $x->precision() >> for the local
+ setting of C<< $x >>.
+ * Please note that C<< $x->accuracy() >> respective C<< $x->precision() >>
+ return eventually defined global A or P, when C<< $x >>'s A or P is not
+ set.
+
+=item Creating numbers
+
+ * When you create a number, you can give the desired A or P via:
+ $x = Math::BigInt->new($number,$A,$P);
+ * Only one of A or P can be defined, otherwise the result is NaN
+ * If no A or P is give ($x = Math::BigInt->new($number) form), then the
+ globals (if set) will be used. Thus changing the global defaults later on
+ will not change the A or P of previously created numbers (i.e., A and P of
+ $x will be what was in effect when $x was created)
+ * If given undef for A and P, B<no> rounding will occur, and the globals will
+ B<not> be used. This is used by subclasses to create numbers without
+ suffering rounding in the parent. Thus a subclass is able to have its own
+ globals enforced upon creation of a number by using
+ C<< $x = Math::BigInt->new($number,undef,undef) >>:
+
+ use Math::BigInt::SomeSubclass;
+ use Math::BigInt;
+
+ Math::BigInt->accuracy(2);
+ Math::BigInt::SomeSubClass->accuracy(3);
+ $x = Math::BigInt::SomeSubClass->new(1234);
+
+ $x is now 1230, and not 1200. A subclass might choose to implement
+ this otherwise, e.g. falling back to the parent's A and P.
+
+=item Usage
+
+ * If A or P are enabled/defined, they are used to round the result of each
+ operation according to the rules below
+ * Negative P is ignored in Math::BigInt, since BigInts never have digits
+ after the decimal point
+ * Math::BigFloat uses Math::BigInt internally, but setting A or P inside
+ Math::BigInt as globals does not tamper with the parts of a BigFloat.
+ A flag is used to mark all Math::BigFloat numbers as 'never round'.
+
+=item Precedence
+
+ * It only makes sense that a number has only one of A or P at a time.
+ If you set either A or P on one object, or globally, the other one will
+ be automatically cleared.
+ * If two objects are involved in an operation, and one of them has A in
+ effect, and the other P, this results in an error (NaN).
+ * A takes precedence over P (Hint: A comes before P).
+ If neither of them is defined, nothing is used, i.e. the result will have
+ as many digits as it can (with an exception for fdiv/fsqrt) and will not
+ be rounded.
+ * There is another setting for fdiv() (and thus for fsqrt()). If neither of
+ A or P is defined, fdiv() will use a fallback (F) of $div_scale digits.
+ If either the dividend's or the divisor's mantissa has more digits than
+ the value of F, the higher value will be used instead of F.
+ This is to limit the digits (A) of the result (just consider what would
+ happen with unlimited A and P in the case of 1/3 :-)
+ * fdiv will calculate (at least) 4 more digits than required (determined by
+ A, P or F), and, if F is not used, round the result
+ (this will still fail in the case of a result like 0.12345000000001 with A
+ or P of 5, but this can not be helped - or can it?)
+ * Thus you can have the math done by on Math::Big* class in two modi:
+ + never round (this is the default):
+ This is done by setting A and P to undef. No math operation
+ will round the result, with fdiv() and fsqrt() as exceptions to guard
+ against overflows. You must explicitly call bround(), bfround() or
+ round() (the latter with parameters).
+ Note: Once you have rounded a number, the settings will 'stick' on it
+ and 'infect' all other numbers engaged in math operations with it, since
+ local settings have the highest precedence. So, to get SaferRound[tm],
+ use a copy() before rounding like this:
+
+ $x = Math::BigFloat->new(12.34);
+ $y = Math::BigFloat->new(98.76);
+ $z = $x * $y; # 1218.6984
+ print $x->copy()->fround(3); # 12.3 (but A is now 3!)
+ $z = $x * $y; # still 1218.6984, without
+ # copy would have been 1210!
+
+ + round after each op:
+ After each single operation (except for testing like is_zero()), the
+ method round() is called and the result is rounded appropriately. By
+ setting proper values for A and P, you can have all-the-same-A or
+ all-the-same-P modes. For example, Math::Currency might set A to undef,
+ and P to -2, globally.
+
+ ?Maybe an extra option that forbids local A & P settings would be in order,
+ ?so that intermediate rounding does not 'poison' further math?
+
+=item Overriding globals
+
+ * you will be able to give A, P and R as an argument to all the calculation
+ routines; the second parameter is A, the third one is P, and the fourth is
+ R (shift right by one for binary operations like badd). P is used only if
+ the first parameter (A) is undefined. These three parameters override the
+ globals in the order detailed as follows, i.e. the first defined value
+ wins:
+ (local: per object, global: global default, parameter: argument to sub)
+ + parameter A
+ + parameter P
+ + local A (if defined on both of the operands: smaller one is taken)
+ + local P (if defined on both of the operands: bigger one is taken)
+ + global A
+ + global P
+ + global F
+ * fsqrt() will hand its arguments to fdiv(), as it used to, only now for two
+ arguments (A and P) instead of one
+
+=item Local settings
+
+ * You can set A or P locally by using C<< $x->accuracy() >> or
+ C<< $x->precision() >>
+ and thus force different A and P for different objects/numbers.
+ * Setting A or P this way immediately rounds $x to the new value.
+ * C<< $x->accuracy() >> clears C<< $x->precision() >>, and vice versa.
+
+=item Rounding
+
+ * the rounding routines will use the respective global or local settings.
+ fround()/bround() is for accuracy rounding, while ffround()/bfround()
+ is for precision
+ * the two rounding functions take as the second parameter one of the
+ following rounding modes (R):
+ 'even', 'odd', '+inf', '-inf', 'zero', 'trunc', 'common'
+ * you can set/get the global R by using C<< Math::SomeClass->round_mode() >>
+ or by setting C<< $Math::SomeClass::round_mode >>
+ * after each operation, C<< $result->round() >> is called, and the result may
+ eventually be rounded (that is, if A or P were set either locally,
+ globally or as parameter to the operation)
+ * to manually round a number, call C<< $x->round($A,$P,$round_mode); >>
+ this will round the number by using the appropriate rounding function
+ and then normalize it.
+ * rounding modifies the local settings of the number:
+
+ $x = Math::BigFloat->new(123.456);
+ $x->accuracy(5);
+ $x->bround(4);
+
+ Here 4 takes precedence over 5, so 123.5 is the result and $x->accuracy()
+ will be 4 from now on.
+
+=item Default values
+
+ * R: 'even'
+ * F: 40
+ * A: undef
+ * P: undef
+
+=item Remarks
+
+ * The defaults are set up so that the new code gives the same results as
+ the old code (except in a few cases on fdiv):
+ + Both A and P are undefined and thus will not be used for rounding
+ after each operation.
+ + round() is thus a no-op, unless given extra parameters A and P
+
+=back
+
+=head1 Infinity and Not a Number
+
+While BigInt has extensive handling of inf and NaN, certain quirks remain.
+
+=over 2
+
+=item oct()/hex()
+
+These perl routines currently (as of Perl v.5.8.6) cannot handle passed
+inf.
+
+ te@linux:~> perl -wle 'print 2 ** 3333'
+ inf
+ te@linux:~> perl -wle 'print 2 ** 3333 == 2 ** 3333'
+ 1
+ te@linux:~> perl -wle 'print oct(2 ** 3333)'
+ 0
+ te@linux:~> perl -wle 'print hex(2 ** 3333)'
+ Illegal hexadecimal digit 'i' ignored at -e line 1.
+ 0
+
+The same problems occur if you pass them Math::BigInt->binf() objects. Since
+overloading these routines is not possible, this cannot be fixed from BigInt.
+
+=item ==, !=, <, >, <=, >= with NaNs
+
+BigInt's bcmp() routine currently returns undef to signal that a NaN was
+involved in a comparison. However, the overload code turns that into
+either 1 or '' and thus operations like C<< NaN != NaN >> might return
+wrong values.
+
+=item log(-inf)
+
+C<< log(-inf) >> is highly weird. Since log(-x)=pi*i+log(x), then
+log(-inf)=pi*i+inf. However, since the imaginary part is finite, the real
+infinity "overshadows" it, so the number might as well just be infinity.
+However, the result is a complex number, and since BigInt/BigFloat can only
+have real numbers as results, the result is NaN.
+
+=item exp(), cos(), sin(), atan2()
+
+These all might have problems handling infinity right.
+
+=back
+
+=head1 INTERNALS
+
+The actual numbers are stored as unsigned big integers (with seperate sign).
+
+You should neither care about nor depend on the internal representation; it
+might change without notice. Use B<ONLY> method calls like C<< $x->sign(); >>
+instead relying on the internal representation.
+
+=head2 MATH LIBRARY
+
+Math with the numbers is done (by default) by a module called
+C<Math::BigInt::Calc>. This is equivalent to saying:
+
+ use Math::BigInt try => 'Calc';
+
+You can change this backend library by using:
+
+ use Math::BigInt try => 'GMP';
+
+B<Note>: General purpose packages should not be explicit about the library
+to use; let the script author decide which is best.
+
+If your script works with huge numbers and Calc is too slow for them,
+you can also for the loading of one of these libraries and if none
+of them can be used, the code will die:
+
+ use Math::BigInt only => 'GMP,Pari';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use Math::BigInt try => 'Foo,Math::BigInt::Bar';
+
+The library that is loaded last will be used. Note that this can be
+overwritten at any time by loading a different library, and numbers
+constructed with different libraries cannot be used in math operations
+together.
+
+=head3 What library to use?
+
+B<Note>: General purpose packages should not be explicit about the library
+to use; let the script author decide which is best.
+
+L<Math::BigInt::GMP> and L<Math::BigInt::Pari> are in cases involving big
+numbers much faster than Calc, however it is slower when dealing with very
+small numbers (less than about 20 digits) and when converting very large
+numbers to decimal (for instance for printing, rounding, calculating their
+length in decimal etc).
+
+So please select carefully what libary you want to use.
+
+Different low-level libraries use different formats to store the numbers.
+However, you should B<NOT> depend on the number having a specific format
+internally.
+
+See the respective math library module documentation for further details.
+
+=head2 SIGN
+
+The sign is either '+', '-', 'NaN', '+inf' or '-inf'.
+
+A sign of 'NaN' is used to represent the result when input arguments are not
+numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
+minus infinity. You will get '+inf' when dividing a positive number by 0, and
+'-inf' when dividing any negative number by 0.
+
+=head2 mantissa(), exponent() and parts()
+
+C<mantissa()> and C<exponent()> return the said parts of the BigInt such
+that:
+
+ $m = $x->mantissa();
+ $e = $x->exponent();
+ $y = $m * ( 10 ** $e );
+ print "ok\n" if $x == $y;
+
+C<< ($m,$e) = $x->parts() >> is just a shortcut that gives you both of them
+in one go. Both the returned mantissa and exponent have a sign.
+
+Currently, for BigInts C<$e> is always 0, except +inf and -inf, where it is
+C<+inf>; and for NaN, where it is C<NaN>; and for C<$x == 0>, where it is C<1>
+(to be compatible with Math::BigFloat's internal representation of a zero as
+C<0E1>).
+
+C<$m> is currently just a copy of the original number. The relation between
+C<$e> and C<$m> will stay always the same, though their real values might
+change.
+
+=head1 EXAMPLES
+
+ use Math::BigInt;
+
+ sub bint { Math::BigInt->new(shift); }
+
+ $x = Math::BigInt->bstr("1234") # string "1234"
+ $x = "$x"; # same as bstr()
+ $x = Math::BigInt->bneg("1234"); # BigInt "-1234"
+ $x = Math::BigInt->babs("-12345"); # BigInt "12345"
+ $x = Math::BigInt->bnorm("-0.00"); # BigInt "0"
+ $x = bint(1) + bint(2); # BigInt "3"
+ $x = bint(1) + "2"; # ditto (auto-BigIntify of "2")
+ $x = bint(1); # BigInt "1"
+ $x = $x + 5 / 2; # BigInt "3"
+ $x = $x ** 3; # BigInt "27"
+ $x *= 2; # BigInt "54"
+ $x = Math::BigInt->new(0); # BigInt "0"
+ $x--; # BigInt "-1"
+ $x = Math::BigInt->badd(4,5) # BigInt "9"
+ print $x->bsstr(); # 9e+0
+
+Examples for rounding:
+
+ use Math::BigFloat;
+ use Test;
+
+ $x = Math::BigFloat->new(123.4567);
+ $y = Math::BigFloat->new(123.456789);
+ Math::BigFloat->accuracy(4); # no more A than 4
+
+ ok ($x->copy()->fround(),123.4); # even rounding
+ print $x->copy()->fround(),"\n"; # 123.4
+ Math::BigFloat->round_mode('odd'); # round to odd
+ print $x->copy()->fround(),"\n"; # 123.5
+ Math::BigFloat->accuracy(5); # no more A than 5
+ Math::BigFloat->round_mode('odd'); # round to odd
+ print $x->copy()->fround(),"\n"; # 123.46
+ $y = $x->copy()->fround(4),"\n"; # A = 4: 123.4
+ print "$y, ",$y->accuracy(),"\n"; # 123.4, 4
+
+ Math::BigFloat->accuracy(undef); # A not important now
+ Math::BigFloat->precision(2); # P important
+ print $x->copy()->bnorm(),"\n"; # 123.46
+ print $x->copy()->fround(),"\n"; # 123.46
+
+Examples for converting:
+
+ my $x = Math::BigInt->new('0b1'.'01' x 123);
+ print "bin: ",$x->as_bin()," hex:",$x->as_hex()," dec: ",$x,"\n";
+
+=head1 Autocreating constants
+
+After C<use Math::BigInt ':constant'> all the B<integer> decimal, hexadecimal
+and binary constants in the given scope are converted to C<Math::BigInt>.
+This conversion happens at compile time.
+
+In particular,
+
+ perl -MMath::BigInt=:constant -e 'print 2**100,"\n"'
+
+prints the integer value of C<2**100>. Note that without conversion of
+constants the expression 2**100 will be calculated as perl scalar.
+
+Please note that strings and floating point constants are not affected,
+so that
+
+ use Math::BigInt qw/:constant/;
+
+ $x = 1234567890123456789012345678901234567890
+ + 123456789123456789;
+ $y = '1234567890123456789012345678901234567890'
+ + '123456789123456789';
+
+do not work. You need an explicit Math::BigInt->new() around one of the
+operands. You should also quote large constants to protect loss of precision:
+
+ use Math::BigInt;
+
+ $x = Math::BigInt->new('1234567889123456789123456789123456789');
+
+Without the quotes Perl would convert the large number to a floating point
+constant at compile time and then hand the result to BigInt, which results in
+an truncated result or a NaN.
+
+This also applies to integers that look like floating point constants:
+
+ use Math::BigInt ':constant';
+
+ print ref(123e2),"\n";
+ print ref(123.2e2),"\n";
+
+will print nothing but newlines. Use either L<bignum> or L<Math::BigFloat>
+to get this to work.
+
+=head1 PERFORMANCE
+
+Using the form $x += $y; etc over $x = $x + $y is faster, since a copy of $x
+must be made in the second case. For long numbers, the copy can eat up to 20%
+of the work (in the case of addition/subtraction, less for
+multiplication/division). If $y is very small compared to $x, the form
+$x += $y is MUCH faster than $x = $x + $y since making the copy of $x takes
+more time then the actual addition.
+
+With a technique called copy-on-write, the cost of copying with overload could
+be minimized or even completely avoided. A test implementation of COW did show
+performance gains for overloaded math, but introduced a performance loss due
+to a constant overhead for all other operations. So Math::BigInt does currently
+not COW.
+
+The rewritten version of this module (vs. v0.01) is slower on certain
+operations, like C<new()>, C<bstr()> and C<numify()>. The reason are that it
+does now more work and handles much more cases. The time spent in these
+operations is usually gained in the other math operations so that code on
+the average should get (much) faster. If they don't, please contact the author.
+
+Some operations may be slower for small numbers, but are significantly faster
+for big numbers. Other operations are now constant (O(1), like C<bneg()>,
+C<babs()> etc), instead of O(N) and thus nearly always take much less time.
+These optimizations were done on purpose.
+
+If you find the Calc module to slow, try to install any of the replacement
+modules and see if they help you.
+
+=head2 Alternative math libraries
+
+You can use an alternative library to drive Math::BigInt. See the section
+L<MATH LIBRARY> for more information.
+
+For more benchmark results see L<http://bloodgate.com/perl/benchmarks.html>.
+
+=head2 SUBCLASSING
+
+=head1 Subclassing Math::BigInt
+
+The basic design of Math::BigInt allows simple subclasses with very little
+work, as long as a few simple rules are followed:
+
+=over 2
+
+=item *
+
+The public API must remain consistent, i.e. if a sub-class is overloading
+addition, the sub-class must use the same name, in this case badd(). The
+reason for this is that Math::BigInt is optimized to call the object methods
+directly.
+
+=item *
+
+The private object hash keys like C<$x->{sign}> may not be changed, but
+additional keys can be added, like C<$x->{_custom}>.
+
+=item *
+
+Accessor functions are available for all existing object hash keys and should
+be used instead of directly accessing the internal hash keys. The reason for
+this is that Math::BigInt itself has a pluggable interface which permits it
+to support different storage methods.
+
+=back
+
+More complex sub-classes may have to replicate more of the logic internal of
+Math::BigInt if they need to change more basic behaviors. A subclass that
+needs to merely change the output only needs to overload C<bstr()>.
+
+All other object methods and overloaded functions can be directly inherited
+from the parent class.
+
+At the very minimum, any subclass will need to provide its own C<new()> and can
+store additional hash keys in the object. There are also some package globals
+that must be defined, e.g.:
+
+ # Globals
+ $accuracy = undef;
+ $precision = -2; # round to 2 decimal places
+ $round_mode = 'even';
+ $div_scale = 40;
+
+Additionally, you might want to provide the following two globals to allow
+auto-upgrading and auto-downgrading to work correctly:
+
+ $upgrade = undef;
+ $downgrade = undef;
+
+This allows Math::BigInt to correctly retrieve package globals from the
+subclass, like C<$SubClass::precision>. See t/Math/BigInt/Subclass.pm or
+t/Math/BigFloat/SubClass.pm completely functional subclass examples.
+
+Don't forget to
+
+ use overload;
+
+in your subclass to automatically inherit the overloading from the parent. If
+you like, you can change part of the overloading, look at Math::String for an
+example.
+
+=head1 UPGRADING
+
+When used like this:
+
+ use Math::BigInt upgrade => 'Foo::Bar';
+
+certain operations will 'upgrade' their calculation and thus the result to
+the class Foo::Bar. Usually this is used in conjunction with Math::BigFloat:
+
+ use Math::BigInt upgrade => 'Math::BigFloat';
+
+As a shortcut, you can use the module C<bignum>:
+
+ use bignum;
+
+Also good for oneliners:
+
+ perl -Mbignum -le 'print 2 ** 255'
+
+This makes it possible to mix arguments of different classes (as in 2.5 + 2)
+as well es preserve accuracy (as in sqrt(3)).
+
+Beware: This feature is not fully implemented yet.
+
+=head2 Auto-upgrade
+
+The following methods upgrade themselves unconditionally; that is if upgrade
+is in effect, they will always hand up their work:
+
+=over 2
+
+=item bsqrt()
+
+=item div()
+
+=item blog()
+
+=item bexp()
+
+=back
+
+Beware: This list is not complete.
+
+All other methods upgrade themselves only when one (or all) of their
+arguments are of the class mentioned in $upgrade (This might change in later
+versions to a more sophisticated scheme):
+
+=head1 EXPORTS
+
+C<Math::BigInt> exports nothing by default, but can export the following methods:
+
+ bgcd
+ blcm
+
+=head1 CAVEATS
+
+Some things might not work as you expect them. Below is documented what is
+known to be troublesome:
+
+=over 1
+
+=item bstr(), bsstr() and 'cmp'
+
+Both C<bstr()> and C<bsstr()> as well as automated stringify via overload now
+drop the leading '+'. The old code would return '+3', the new returns '3'.
+This is to be consistent with Perl and to make C<cmp> (especially with
+overloading) to work as you expect. It also solves problems with C<Test.pm>,
+because its C<ok()> uses 'eq' internally.
+
+Mark Biggar said, when asked about to drop the '+' altogether, or make only
+C<cmp> work:
+
+ I agree (with the first alternative), don't add the '+' on positive
+ numbers. It's not as important anymore with the new internal
+ form for numbers. It made doing things like abs and neg easier,
+ but those have to be done differently now anyway.
+
+So, the following examples will now work all as expected:
+
+ use Test;
+ BEGIN { plan tests => 1 }
+ use Math::BigInt;
+
+ my $x = new Math::BigInt 3*3;
+ my $y = new Math::BigInt 3*3;
+
+ ok ($x,3*3);
+ print "$x eq 9" if $x eq $y;
+ print "$x eq 9" if $x eq '9';
+ print "$x eq 9" if $x eq 3*3;
+
+Additionally, the following still works:
+
+ print "$x == 9" if $x == $y;
+ print "$x == 9" if $x == 9;
+ print "$x == 9" if $x == 3*3;
+
+There is now a C<bsstr()> method to get the string in scientific notation aka
+C<1e+2> instead of C<100>. Be advised that overloaded 'eq' always uses bstr()
+for comparison, but Perl will represent some numbers as 100 and others
+as 1e+308. If in doubt, convert both arguments to Math::BigInt before
+comparing them as strings:
+
+ use Test;
+ BEGIN { plan tests => 3 }
+ use Math::BigInt;
+
+ $x = Math::BigInt->new('1e56'); $y = 1e56;
+ ok ($x,$y); # will fail
+ ok ($x->bsstr(),$y); # okay
+ $y = Math::BigInt->new($y);
+ ok ($x,$y); # okay
+
+Alternatively, simple use C<< <=> >> for comparisons, this will get it
+always right. There is not yet a way to get a number automatically represented
+as a string that matches exactly the way Perl represents it.
+
+See also the section about L<Infinity and Not a Number> for problems in
+comparing NaNs.
+
+=item int()
+
+C<int()> will return (at least for Perl v5.7.1 and up) another BigInt, not a
+Perl scalar:
+
+ $x = Math::BigInt->new(123);
+ $y = int($x); # BigInt 123
+ $x = Math::BigFloat->new(123.45);
+ $y = int($x); # BigInt 123
+
+In all Perl versions you can use C<as_number()> or C<as_int> for the same
+effect:
+
+ $x = Math::BigFloat->new(123.45);
+ $y = $x->as_number(); # BigInt 123
+ $y = $x->as_int(); # ditto
+
+This also works for other subclasses, like Math::String.
+
+If you want a real Perl scalar, use C<numify()>:
+
+ $y = $x->numify(); # 123 as scalar
+
+This is seldom necessary, though, because this is done automatically, like
+when you access an array:
+
+ $z = $array[$x]; # does work automatically
+
+=item length
+
+The following will probably not do what you expect:
+
+ $c = Math::BigInt->new(123);
+ print $c->length(),"\n"; # prints 30
+
+It prints both the number of digits in the number and in the fraction part
+since print calls C<length()> in list context. Use something like:
+
+ print scalar $c->length(),"\n"; # prints 3
+
+=item bdiv
+
+The following will probably not do what you expect:
+
+ print $c->bdiv(10000),"\n";
+
+It prints both quotient and remainder since print calls C<bdiv()> in list
+context. Also, C<bdiv()> will modify $c, so be careful. You probably want
+to use
+
+ print $c / 10000,"\n";
+ print scalar $c->bdiv(10000),"\n"; # or if you want to modify $c
+
+instead.
+
+The quotient is always the greatest integer less than or equal to the
+real-valued quotient of the two operands, and the remainder (when it is
+nonzero) always has the same sign as the second operand; so, for
+example,
+
+ 1 / 4 => ( 0, 1)
+ 1 / -4 => (-1,-3)
+ -3 / 4 => (-1, 1)
+ -3 / -4 => ( 0,-3)
+ -11 / 2 => (-5,1)
+ 11 /-2 => (-5,-1)
+
+As a consequence, the behavior of the operator % agrees with the
+behavior of Perl's built-in % operator (as documented in the perlop
+manpage), and the equation
+
+ $x == ($x / $y) * $y + ($x % $y)
+
+holds true for any $x and $y, which justifies calling the two return
+values of bdiv() the quotient and remainder. The only exception to this rule
+are when $y == 0 and $x is negative, then the remainder will also be
+negative. See below under "infinity handling" for the reasoning behind this.
+
+Perl's 'use integer;' changes the behaviour of % and / for scalars, but will
+not change BigInt's way to do things. This is because under 'use integer' Perl
+will do what the underlying C thinks is right and this is different for each
+system. If you need BigInt's behaving exactly like Perl's 'use integer', bug
+the author to implement it ;)
+
+=item infinity handling
+
+Here are some examples that explain the reasons why certain results occur while
+handling infinity:
+
+The following table shows the result of the division and the remainder, so that
+the equation above holds true. Some "ordinary" cases are strewn in to show more
+clearly the reasoning:
+
+ A / B = C, R so that C * B + R = A
+ =========================================================
+ 5 / 8 = 0, 5 0 * 8 + 5 = 5
+ 0 / 8 = 0, 0 0 * 8 + 0 = 0
+ 0 / inf = 0, 0 0 * inf + 0 = 0
+ 0 /-inf = 0, 0 0 * -inf + 0 = 0
+ 5 / inf = 0, 5 0 * inf + 5 = 5
+ 5 /-inf = 0, 5 0 * -inf + 5 = 5
+ -5/ inf = 0, -5 0 * inf + -5 = -5
+ -5/-inf = 0, -5 0 * -inf + -5 = -5
+ inf/ 5 = inf, 0 inf * 5 + 0 = inf
+ -inf/ 5 = -inf, 0 -inf * 5 + 0 = -inf
+ inf/ -5 = -inf, 0 -inf * -5 + 0 = inf
+ -inf/ -5 = inf, 0 inf * -5 + 0 = -inf
+ 5/ 5 = 1, 0 1 * 5 + 0 = 5
+ -5/ -5 = 1, 0 1 * -5 + 0 = -5
+ inf/ inf = 1, 0 1 * inf + 0 = inf
+ -inf/-inf = 1, 0 1 * -inf + 0 = -inf
+ inf/-inf = -1, 0 -1 * -inf + 0 = inf
+ -inf/ inf = -1, 0 1 * -inf + 0 = -inf
+ 8/ 0 = inf, 8 inf * 0 + 8 = 8
+ inf/ 0 = inf, inf inf * 0 + inf = inf
+ 0/ 0 = NaN
+
+These cases below violate the "remainder has the sign of the second of the two
+arguments", since they wouldn't match up otherwise.
+
+ A / B = C, R so that C * B + R = A
+ ========================================================
+ -inf/ 0 = -inf, -inf -inf * 0 + inf = -inf
+ -8/ 0 = -inf, -8 -inf * 0 + 8 = -8
+
+=item Modifying and =
+
+Beware of:
+
+ $x = Math::BigFloat->new(5);
+ $y = $x;
+
+It will not do what you think, e.g. making a copy of $x. Instead it just makes
+a second reference to the B<same> object and stores it in $y. Thus anything
+that modifies $x (except overloaded operators) will modify $y, and vice versa.
+Or in other words, C<=> is only safe if you modify your BigInts only via
+overloaded math. As soon as you use a method call it breaks:
+
+ $x->bmul(2);
+ print "$x, $y\n"; # prints '10, 10'
+
+If you want a true copy of $x, use:
+
+ $y = $x->copy();
+
+You can also chain the calls like this, this will make first a copy and then
+multiply it by 2:
+
+ $y = $x->copy()->bmul(2);
+
+See also the documentation for overload.pm regarding C<=>.
+
+=item bpow
+
+C<bpow()> (and the rounding functions) now modifies the first argument and
+returns it, unlike the old code which left it alone and only returned the
+result. This is to be consistent with C<badd()> etc. The first three will
+modify $x, the last one won't:
+
+ print bpow($x,$i),"\n"; # modify $x
+ print $x->bpow($i),"\n"; # ditto
+ print $x **= $i,"\n"; # the same
+ print $x ** $i,"\n"; # leave $x alone
+
+The form C<$x **= $y> is faster than C<$x = $x ** $y;>, though.
+
+=item Overloading -$x
+
+The following:
+
+ $x = -$x;
+
+is slower than
+
+ $x->bneg();
+
+since overload calls C<sub($x,0,1);> instead of C<neg($x)>. The first variant
+needs to preserve $x since it does not know that it later will get overwritten.
+This makes a copy of $x and takes O(N), but $x->bneg() is O(1).
+
+=item Mixing different object types
+
+In Perl you will get a floating point value if you do one of the following:
+
+ $float = 5.0 + 2;
+ $float = 2 + 5.0;
+ $float = 5 / 2;
+
+With overloaded math, only the first two variants will result in a BigFloat:
+
+ use Math::BigInt;
+ use Math::BigFloat;
+
+ $mbf = Math::BigFloat->new(5);
+ $mbi2 = Math::BigInteger->new(5);
+ $mbi = Math::BigInteger->new(2);
+
+ # what actually gets called:
+ $float = $mbf + $mbi; # $mbf->badd()
+ $float = $mbf / $mbi; # $mbf->bdiv()
+ $integer = $mbi + $mbf; # $mbi->badd()
+ $integer = $mbi2 / $mbi; # $mbi2->bdiv()
+ $integer = $mbi2 / $mbf; # $mbi2->bdiv()
+
+This is because math with overloaded operators follows the first (dominating)
+operand, and the operation of that is called and returns thus the result. So,
+Math::BigInt::bdiv() will always return a Math::BigInt, regardless whether
+the result should be a Math::BigFloat or the second operant is one.
+
+To get a Math::BigFloat you either need to call the operation manually,
+make sure the operands are already of the proper type or casted to that type
+via Math::BigFloat->new():
+
+ $float = Math::BigFloat->new($mbi2) / $mbi; # = 2.5
+
+Beware of simple "casting" the entire expression, this would only convert
+the already computed result:
+
+ $float = Math::BigFloat->new($mbi2 / $mbi); # = 2.0 thus wrong!
+
+Beware also of the order of more complicated expressions like:
+
+ $integer = ($mbi2 + $mbi) / $mbf; # int / float => int
+ $integer = $mbi2 / Math::BigFloat->new($mbi); # ditto
+
+If in doubt, break the expression into simpler terms, or cast all operands
+to the desired resulting type.
+
+Scalar values are a bit different, since:
+
+ $float = 2 + $mbf;
+ $float = $mbf + 2;
+
+will both result in the proper type due to the way the overloaded math works.
+
+This section also applies to other overloaded math packages, like Math::String.
+
+One solution to you problem might be autoupgrading|upgrading. See the
+pragmas L<bignum>, L<bigint> and L<bigrat> for an easy way to do this.
+
+=item bsqrt()
+
+C<bsqrt()> works only good if the result is a big integer, e.g. the square
+root of 144 is 12, but from 12 the square root is 3, regardless of rounding
+mode. The reason is that the result is always truncated to an integer.
+
+If you want a better approximation of the square root, then use:
+
+ $x = Math::BigFloat->new(12);
+ Math::BigFloat->precision(0);
+ Math::BigFloat->round_mode('even');
+ print $x->copy->bsqrt(),"\n"; # 4
+
+ Math::BigFloat->precision(2);
+ print $x->bsqrt(),"\n"; # 3.46
+ print $x->bsqrt(3),"\n"; # 3.464
+
+=item brsft()
+
+For negative numbers in base see also L<brsft|brsft>.
+
+=back
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Math::BigFloat>, L<Math::BigRat> and L<Math::Big> as well as
+L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+The pragmas L<bignum>, L<bigint> and L<bigrat> also might be of interest
+because they solve the autoupgrading/downgrading issue, at least partly.
+
+The package at
+L<http://search.cpan.org/search?mode=module&query=Math%3A%3ABigInt> contains
+more documentation including a full version history, testcases, empty
+subclass files and benchmarks.
+
+=head1 AUTHORS
+
+Original code by Mark Biggar, overloaded interface by Ilya Zakharevich.
+Completely rewritten by Tels http://bloodgate.com in late 2000, 2001 - 2006
+and still at it in 2007.
+
+Many people contributed in one or more ways to the final beast, see the file
+CREDITS for an (incomplete) list. If you miss your name, please drop me a
+mail. Thank you!
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigInt/Calc.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/Calc.pm
new file mode 100755
index 00000000000..52e33d232ae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/Calc.pm
@@ -0,0 +1,2612 @@
+package Math::BigInt::Calc;
+
+use 5.006;
+use strict;
+# use warnings; # dont use warnings for older Perls
+
+our $VERSION = '0.52';
+
+# Package to store unsigned big integers in decimal and do math with them
+
+# Internally the numbers are stored in an array with at least 1 element, no
+# leading zero parts (except the first) and in base 1eX where X is determined
+# automatically at loading time to be the maximum possible value
+
+# todo:
+# - fully remove funky $# stuff in div() (maybe - that code scares me...)
+
+# USE_MUL: due to problems on certain os (os390, posix-bc) "* 1e-5" is used
+# instead of "/ 1e5" at some places, (marked with USE_MUL). Other platforms
+# BS2000, some Crays need USE_DIV instead.
+# The BEGIN block is used to determine which of the two variants gives the
+# correct result.
+
+# Beware of things like:
+# $i = $i * $y + $car; $car = int($i / $BASE); $i = $i % $BASE;
+# This works on x86, but fails on ARM (SA1100, iPAQ) due to whoknows what
+# reasons. So, use this instead (slower, but correct):
+# $i = $i * $y + $car; $car = int($i / $BASE); $i -= $BASE * $car;
+
+##############################################################################
+# global constants, flags and accessory
+
+# announce that we are compatible with MBI v1.83 and up
+sub api_version () { 2; }
+
+# constants for easier life
+my ($BASE,$BASE_LEN,$RBASE,$MAX_VAL);
+my ($AND_BITS,$XOR_BITS,$OR_BITS);
+my ($AND_MASK,$XOR_MASK,$OR_MASK);
+
+sub _base_len
+ {
+ # Set/get the BASE_LEN and assorted other, connected values.
+ # Used only by the testsuite, the set variant is used only by the BEGIN
+ # block below:
+ shift;
+
+ my ($b, $int) = @_;
+ if (defined $b)
+ {
+ # avoid redefinitions
+ undef &_mul;
+ undef &_div;
+
+ if ($] >= 5.008 && $int && $b > 7)
+ {
+ $BASE_LEN = $b;
+ *_mul = \&_mul_use_div_64;
+ *_div = \&_div_use_div_64;
+ $BASE = int("1e".$BASE_LEN);
+ $MAX_VAL = $BASE-1;
+ return $BASE_LEN unless wantarray;
+ return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL, $BASE);
+ }
+
+ # find whether we can use mul or div in mul()/div()
+ $BASE_LEN = $b+1;
+ my $caught = 0;
+ while (--$BASE_LEN > 5)
+ {
+ $BASE = int("1e".$BASE_LEN);
+ $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL
+ $caught = 0;
+ $caught += 1 if (int($BASE * $RBASE) != 1); # should be 1
+ $caught += 2 if (int($BASE / $BASE) != 1); # should be 1
+ last if $caught != 3;
+ }
+ $BASE = int("1e".$BASE_LEN);
+ $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL
+ $MAX_VAL = $BASE-1;
+
+ # ($caught & 1) != 0 => cannot use MUL
+ # ($caught & 2) != 0 => cannot use DIV
+ if ($caught == 2) # 2
+ {
+ # must USE_MUL since we cannot use DIV
+ *_mul = \&_mul_use_mul;
+ *_div = \&_div_use_mul;
+ }
+ else # 0 or 1
+ {
+ # can USE_DIV instead
+ *_mul = \&_mul_use_div;
+ *_div = \&_div_use_div;
+ }
+ }
+ return $BASE_LEN unless wantarray;
+ return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL, $BASE);
+ }
+
+sub _new
+ {
+ # (ref to string) return ref to num_array
+ # Convert a number from string format (without sign) to internal base
+ # 1ex format. Assumes normalized value as input.
+ my $il = length($_[1])-1;
+
+ # < BASE_LEN due len-1 above
+ return [ int($_[1]) ] if $il < $BASE_LEN; # shortcut for short numbers
+
+ # this leaves '00000' instead of int 0 and will be corrected after any op
+ [ reverse(unpack("a" . ($il % $BASE_LEN+1)
+ . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
+ }
+
+BEGIN
+ {
+ # from Daniel Pfeiffer: determine largest group of digits that is precisely
+ # multipliable with itself plus carry
+ # Test now changed to expect the proper pattern, not a result off by 1 or 2
+ my ($e, $num) = 3; # lowest value we will use is 3+1-1 = 3
+ do
+ {
+ $num = ('9' x ++$e) + 0;
+ $num *= $num + 1.0;
+ } while ("$num" =~ /9{$e}0{$e}/); # must be a certain pattern
+ $e--; # last test failed, so retract one step
+ # the limits below brush the problems with the test above under the rug:
+ # the test should be able to find the proper $e automatically
+ $e = 5 if $^O =~ /^uts/; # UTS get's some special treatment
+ $e = 5 if $^O =~ /^unicos/; # unicos is also problematic (6 seems to work
+ # there, but we play safe)
+
+ my $int = 0;
+ if ($e > 7)
+ {
+ use integer;
+ my $e1 = 7;
+ $num = 7;
+ do
+ {
+ $num = ('9' x ++$e1) + 0;
+ $num *= $num + 1;
+ } while ("$num" =~ /9{$e1}0{$e1}/); # must be a certain pattern
+ $e1--; # last test failed, so retract one step
+ if ($e1 > 7)
+ {
+ $int = 1; $e = $e1;
+ }
+ }
+
+ __PACKAGE__->_base_len($e,$int); # set and store
+
+ use integer;
+ # find out how many bits _and, _or and _xor can take (old default = 16)
+ # I don't think anybody has yet 128 bit scalars, so let's play safe.
+ local $^W = 0; # don't warn about 'nonportable number'
+ $AND_BITS = 15; $XOR_BITS = 15; $OR_BITS = 15;
+
+ # find max bits, we will not go higher than numberofbits that fit into $BASE
+ # to make _and etc simpler (and faster for smaller, slower for large numbers)
+ my $max = 16;
+ while (2 ** $max < $BASE) { $max++; }
+ {
+ no integer;
+ $max = 16 if $] < 5.006; # older Perls might not take >16 too well
+ }
+ my ($x,$y,$z);
+ do {
+ $AND_BITS++;
+ $x = CORE::oct('0b' . '1' x $AND_BITS); $y = $x & $x;
+ $z = (2 ** $AND_BITS) - 1;
+ } while ($AND_BITS < $max && $x == $z && $y == $x);
+ $AND_BITS --; # retreat one step
+ do {
+ $XOR_BITS++;
+ $x = CORE::oct('0b' . '1' x $XOR_BITS); $y = $x ^ 0;
+ $z = (2 ** $XOR_BITS) - 1;
+ } while ($XOR_BITS < $max && $x == $z && $y == $x);
+ $XOR_BITS --; # retreat one step
+ do {
+ $OR_BITS++;
+ $x = CORE::oct('0b' . '1' x $OR_BITS); $y = $x | $x;
+ $z = (2 ** $OR_BITS) - 1;
+ } while ($OR_BITS < $max && $x == $z && $y == $x);
+ $OR_BITS --; # retreat one step
+
+ $AND_MASK = __PACKAGE__->_new( ( 2 ** $AND_BITS ));
+ $XOR_MASK = __PACKAGE__->_new( ( 2 ** $XOR_BITS ));
+ $OR_MASK = __PACKAGE__->_new( ( 2 ** $OR_BITS ));
+
+ # We can compute the approximate lenght no faster than the real length:
+ *_alen = \&_len;
+ }
+
+###############################################################################
+
+sub _zero
+ {
+ # create a zero
+ [ 0 ];
+ }
+
+sub _one
+ {
+ # create a one
+ [ 1 ];
+ }
+
+sub _two
+ {
+ # create a two (used internally for shifting)
+ [ 2 ];
+ }
+
+sub _ten
+ {
+ # create a 10 (used internally for shifting)
+ [ 10 ];
+ }
+
+sub _1ex
+ {
+ # create a 1Ex
+ my $rem = $_[1] % $BASE_LEN; # remainder
+ my $parts = $_[1] / $BASE_LEN; # parts
+
+ # 000000, 000000, 100
+ [ (0) x $parts, '1' . ('0' x $rem) ];
+ }
+
+sub _copy
+ {
+ # make a true copy
+ [ @{$_[1]} ];
+ }
+
+# catch and throw away
+sub import { }
+
+##############################################################################
+# convert back to string and number
+
+sub _str
+ {
+ # (ref to BINT) return num_str
+ # Convert number from internal base 100000 format to string format.
+ # internal format is always normalized (no leading zeros, "-0" => "+0")
+ my $ar = $_[1];
+
+ my $l = scalar @$ar; # number of parts
+ if ($l < 1) # should not happen
+ {
+ require Carp;
+ Carp::croak("$_[1] has no elements");
+ }
+
+ my $ret = "";
+ # handle first one different to strip leading zeros from it (there are no
+ # leading zero parts in internal representation)
+ $l --; $ret .= int($ar->[$l]); $l--;
+ # Interestingly, the pre-padd method uses more time
+ # the old grep variant takes longer (14 vs. 10 sec)
+ my $z = '0' x ($BASE_LEN-1);
+ while ($l >= 0)
+ {
+ $ret .= substr($z.$ar->[$l],-$BASE_LEN); # fastest way I could think of
+ $l--;
+ }
+ $ret;
+ }
+
+sub _num
+ {
+ # Make a number (scalar int/float) from a BigInt object
+ my $x = $_[1];
+
+ return 0+$x->[0] if scalar @$x == 1; # below $BASE
+ my $fac = 1;
+ my $num = 0;
+ foreach (@$x)
+ {
+ $num += $fac*$_; $fac *= $BASE;
+ }
+ $num;
+ }
+
+##############################################################################
+# actual math code
+
+sub _add
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # routine to add two base 1eX numbers
+ # stolen from Knuth Vol 2 Algorithm A pg 231
+ # there are separate routines to add and sub as per Knuth pg 233
+ # This routine clobbers up array x, but not y.
+
+ my ($c,$x,$y) = @_;
+
+ return $x if (@$y == 1) && $y->[0] == 0; # $x + 0 => $x
+ if ((@$x == 1) && $x->[0] == 0) # 0 + $y => $y->copy
+ {
+ # twice as slow as $x = [ @$y ], but nec. to retain $x as ref :(
+ @$x = @$y; return $x;
+ }
+
+ # for each in Y, add Y to X and carry. If after that, something is left in
+ # X, foreach in X add carry to X and then return X, carry
+ # Trades one "$j++" for having to shift arrays
+ my $i; my $car = 0; my $j = 0;
+ for $i (@$y)
+ {
+ $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
+ $j++;
+ }
+ while ($car != 0)
+ {
+ $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
+ }
+ $x;
+ }
+
+sub _inc
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # Add 1 to $x, modify $x in place
+ my ($c,$x) = @_;
+
+ for my $i (@$x)
+ {
+ return $x if (($i += 1) < $BASE); # early out
+ $i = 0; # overflow, next
+ }
+ push @$x,1 if (($x->[-1] || 0) == 0); # last overflowed, so extend
+ $x;
+ }
+
+sub _dec
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # Sub 1 from $x, modify $x in place
+ my ($c,$x) = @_;
+
+ my $MAX = $BASE-1; # since MAX_VAL based on BASE
+ for my $i (@$x)
+ {
+ last if (($i -= 1) >= 0); # early out
+ $i = $MAX; # underflow, next
+ }
+ pop @$x if $x->[-1] == 0 && @$x > 1; # last underflowed (but leave 0)
+ $x;
+ }
+
+sub _sub
+ {
+ # (ref to int_num_array, ref to int_num_array, swap)
+ # subtract base 1eX numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+ # subtract Y from X by modifying x in place
+ my ($c,$sx,$sy,$s) = @_;
+
+ my $car = 0; my $i; my $j = 0;
+ if (!$s)
+ {
+ for $i (@$sx)
+ {
+ last unless defined $sy->[$j] || $car;
+ $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++;
+ }
+ # might leave leading zeros, so fix that
+ return __strip_zeros($sx);
+ }
+ for $i (@$sx)
+ {
+ # we can't do an early out if $x is < than $y, since we
+ # need to copy the high chunks from $y. Found by Bob Mathews.
+ #last unless defined $sy->[$j] || $car;
+ $sy->[$j] += $BASE
+ if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0);
+ $j++;
+ }
+ # might leave leading zeros, so fix that
+ __strip_zeros($sy);
+ }
+
+sub _mul_use_mul
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # multiply two numbers in internal representation
+ # modifies first arg, second need not be different from first
+ my ($c,$xv,$yv) = @_;
+
+ if (@$yv == 1)
+ {
+ # shortcut for two very short numbers (improved by Nathan Zook)
+ # works also if xv and yv are the same reference, and handles also $x == 0
+ if (@$xv == 1)
+ {
+ if (($xv->[0] *= $yv->[0]) >= $BASE)
+ {
+ $xv->[0] = $xv->[0] - ($xv->[1] = int($xv->[0] * $RBASE)) * $BASE;
+ };
+ return $xv;
+ }
+ # $x * 0 => 0
+ if ($yv->[0] == 0)
+ {
+ @$xv = (0);
+ return $xv;
+ }
+ # multiply a large number a by a single element one, so speed up
+ my $y = $yv->[0]; my $car = 0;
+ foreach my $i (@$xv)
+ {
+ $i = $i * $y + $car; $car = int($i * $RBASE); $i -= $car * $BASE;
+ }
+ push @$xv, $car if $car != 0;
+ return $xv;
+ }
+ # shortcut for result $x == 0 => result = 0
+ return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
+
+ # since multiplying $x with $x fails, make copy in this case
+ $yv = [@$xv] if $xv == $yv; # same references?
+
+ my @prod = (); my ($prod,$car,$cty,$xi,$yi);
+
+ for $xi (@$xv)
+ {
+ $car = 0; $cty = 0;
+
+ # slow variant
+# for $yi (@$yv)
+# {
+# $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+# $prod[$cty++] =
+# $prod - ($car = int($prod * RBASE)) * $BASE; # see USE_MUL
+# }
+# $prod[$cty] += $car if $car; # need really to check for 0?
+# $xi = shift @prod;
+
+ # faster variant
+ # looping through this if $xi == 0 is silly - so optimize it away!
+ $xi = (shift @prod || 0), next if $xi == 0;
+ for $yi (@$yv)
+ {
+ $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+## this is actually a tad slower
+## $prod = $prod[$cty]; $prod += ($car + $xi * $yi); # no ||0 here
+ $prod[$cty++] =
+ $prod - ($car = int($prod * $RBASE)) * $BASE; # see USE_MUL
+ }
+ $prod[$cty] += $car if $car; # need really to check for 0?
+ $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
+ }
+ push @$xv, @prod;
+ # can't have leading zeros
+# __strip_zeros($xv);
+ $xv;
+ }
+
+sub _mul_use_div_64
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # multiply two numbers in internal representation
+ # modifies first arg, second need not be different from first
+ # works for 64 bit integer with "use integer"
+ my ($c,$xv,$yv) = @_;
+
+ use integer;
+ if (@$yv == 1)
+ {
+ # shortcut for two small numbers, also handles $x == 0
+ if (@$xv == 1)
+ {
+ # shortcut for two very short numbers (improved by Nathan Zook)
+ # works also if xv and yv are the same reference, and handles also $x == 0
+ if (($xv->[0] *= $yv->[0]) >= $BASE)
+ {
+ $xv->[0] =
+ $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE;
+ };
+ return $xv;
+ }
+ # $x * 0 => 0
+ if ($yv->[0] == 0)
+ {
+ @$xv = (0);
+ return $xv;
+ }
+ # multiply a large number a by a single element one, so speed up
+ my $y = $yv->[0]; my $car = 0;
+ foreach my $i (@$xv)
+ {
+ #$i = $i * $y + $car; $car = $i / $BASE; $i -= $car * $BASE;
+ $i = $i * $y + $car; $i -= ($car = $i / $BASE) * $BASE;
+ }
+ push @$xv, $car if $car != 0;
+ return $xv;
+ }
+ # shortcut for result $x == 0 => result = 0
+ return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
+
+ # since multiplying $x with $x fails, make copy in this case
+ $yv = [@$xv] if $xv == $yv; # same references?
+
+ my @prod = (); my ($prod,$car,$cty,$xi,$yi);
+ for $xi (@$xv)
+ {
+ $car = 0; $cty = 0;
+ # looping through this if $xi == 0 is silly - so optimize it away!
+ $xi = (shift @prod || 0), next if $xi == 0;
+ for $yi (@$yv)
+ {
+ $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+ $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE;
+ }
+ $prod[$cty] += $car if $car; # need really to check for 0?
+ $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
+ }
+ push @$xv, @prod;
+ $xv;
+ }
+
+sub _mul_use_div
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # multiply two numbers in internal representation
+ # modifies first arg, second need not be different from first
+ my ($c,$xv,$yv) = @_;
+
+ if (@$yv == 1)
+ {
+ # shortcut for two small numbers, also handles $x == 0
+ if (@$xv == 1)
+ {
+ # shortcut for two very short numbers (improved by Nathan Zook)
+ # works also if xv and yv are the same reference, and handles also $x == 0
+ if (($xv->[0] *= $yv->[0]) >= $BASE)
+ {
+ $xv->[0] =
+ $xv->[0] - ($xv->[1] = int($xv->[0] / $BASE)) * $BASE;
+ };
+ return $xv;
+ }
+ # $x * 0 => 0
+ if ($yv->[0] == 0)
+ {
+ @$xv = (0);
+ return $xv;
+ }
+ # multiply a large number a by a single element one, so speed up
+ my $y = $yv->[0]; my $car = 0;
+ foreach my $i (@$xv)
+ {
+ $i = $i * $y + $car; $car = int($i / $BASE); $i -= $car * $BASE;
+ # This (together with use integer;) does not work on 32-bit Perls
+ #$i = $i * $y + $car; $i -= ($car = $i / $BASE) * $BASE;
+ }
+ push @$xv, $car if $car != 0;
+ return $xv;
+ }
+ # shortcut for result $x == 0 => result = 0
+ return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
+
+ # since multiplying $x with $x fails, make copy in this case
+ $yv = [@$xv] if $xv == $yv; # same references?
+
+ my @prod = (); my ($prod,$car,$cty,$xi,$yi);
+ for $xi (@$xv)
+ {
+ $car = 0; $cty = 0;
+ # looping through this if $xi == 0 is silly - so optimize it away!
+ $xi = (shift @prod || 0), next if $xi == 0;
+ for $yi (@$yv)
+ {
+ $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+ $prod[$cty++] = $prod - ($car = int($prod / $BASE)) * $BASE;
+ }
+ $prod[$cty] += $car if $car; # need really to check for 0?
+ $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
+ }
+ push @$xv, @prod;
+ # can't have leading zeros
+# __strip_zeros($xv);
+ $xv;
+ }
+
+sub _div_use_mul
+ {
+ # ref to array, ref to array, modify first array and return remainder if
+ # in list context
+
+ # see comments in _div_use_div() for more explanations
+
+ my ($c,$x,$yorg) = @_;
+
+ # the general div algorithmn here is about O(N*N) and thus quite slow, so
+ # we first check for some special cases and use shortcuts to handle them.
+
+ # This works, because we store the numbers in a chunked format where each
+ # element contains 5..7 digits (depending on system).
+
+ # if both numbers have only one element:
+ if (@$x == 1 && @$yorg == 1)
+ {
+ # shortcut, $yorg and $x are two small numbers
+ if (wantarray)
+ {
+ my $r = [ $x->[0] % $yorg->[0] ];
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return ($x,$r);
+ }
+ else
+ {
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return $x;
+ }
+ }
+
+ # if x has more than one, but y has only one element:
+ if (@$yorg == 1)
+ {
+ my $rem;
+ $rem = _mod($c,[ @$x ],$yorg) if wantarray;
+
+ # shortcut, $y is < $BASE
+ my $j = scalar @$x; my $r = 0;
+ my $y = $yorg->[0]; my $b;
+ while ($j-- > 0)
+ {
+ $b = $r * $BASE + $x->[$j];
+ $x->[$j] = int($b/$y);
+ $r = $b % $y;
+ }
+ pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+
+ # now x and y have more than one element
+
+ # check whether y has more elements than x, if yet, the result will be 0
+ if (@$yorg > @$x)
+ {
+ my $rem;
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to original array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x; # only x, which is [0] now
+ }
+ # check whether the numbers have the same number of elements, in that case
+ # the result will fit into one element and can be computed efficiently
+ if (@$yorg == @$x)
+ {
+ my $rem;
+ # if $yorg has more digits than $x (it's leading element is longer than
+ # the one from $x), the result will also be 0:
+ if (length(int($yorg->[-1])) > length(int($x->[-1])))
+ {
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to org array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # now calculate $x / $yorg
+ if (length(int($yorg->[-1])) == length(int($x->[-1])))
+ {
+ # same length, so make full compare
+
+ my $a = 0; my $j = scalar @$x - 1;
+ # manual way (abort if unequal, good for early ne)
+ while ($j >= 0)
+ {
+ last if ($a = $x->[$j] - $yorg->[$j]); $j--;
+ }
+ # $a contains the result of the compare between X and Y
+ # a < 0: x < y, a == 0: x == y, a > 0: x > y
+ if ($a <= 0)
+ {
+ $rem = [ 0 ]; # a = 0 => x == y => rem 0
+ $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
+ splice(@$x,1); # keep single element
+ $x->[0] = 0; # if $a < 0
+ $x->[0] = 1 if $a == 0; # $x == $y
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+ # $x >= $y, so proceed normally
+ }
+ }
+
+ # all other cases:
+
+ my $y = [ @$yorg ]; # always make copy to preserve
+
+ my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
+
+ $car = $bar = $prd = 0;
+ if (($dd = int($BASE/($y->[-1]+1))) != 1)
+ {
+ for $xi (@$x)
+ {
+ $xi = $xi * $dd + $car;
+ $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL
+ }
+ push(@$x, $car); $car = 0;
+ for $yi (@$y)
+ {
+ $yi = $yi * $dd + $car;
+ $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL
+ }
+ }
+ else
+ {
+ push(@$x, 0);
+ }
+ @q = (); ($v2,$v1) = @$y[-2,-1];
+ $v2 = 0 unless $v2;
+ while ($#$x > $#$y)
+ {
+ ($u2,$u1,$u0) = @$x[-3..-1];
+ $u2 = 0 unless $u2;
+ #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
+ # if $v1 == 0;
+ $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2);
+ if ($q)
+ {
+ ($car, $bar) = (0,0);
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $prd = $q * $y->[$yi] + $car;
+ $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL
+ $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
+ }
+ if ($x->[-1] < $car + $bar)
+ {
+ $car = 0; --$q;
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $x->[$xi] -= $BASE
+ if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE));
+ }
+ }
+ }
+ pop(@$x);
+ unshift(@q, $q);
+ }
+ if (wantarray)
+ {
+ @d = ();
+ if ($dd != 1)
+ {
+ $car = 0;
+ for $xi (reverse @$x)
+ {
+ $prd = $car * $BASE + $xi;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL
+ unshift(@d, $tmp);
+ }
+ }
+ else
+ {
+ @d = @$x;
+ }
+ @$x = @q;
+ my $d = \@d;
+ __strip_zeros($x);
+ __strip_zeros($d);
+ return ($x,$d);
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ $x;
+ }
+
+sub _div_use_div_64
+ {
+ # ref to array, ref to array, modify first array and return remainder if
+ # in list context
+ # This version works on 64 bit integers
+ my ($c,$x,$yorg) = @_;
+
+ use integer;
+ # the general div algorithmn here is about O(N*N) and thus quite slow, so
+ # we first check for some special cases and use shortcuts to handle them.
+
+ # This works, because we store the numbers in a chunked format where each
+ # element contains 5..7 digits (depending on system).
+
+ # if both numbers have only one element:
+ if (@$x == 1 && @$yorg == 1)
+ {
+ # shortcut, $yorg and $x are two small numbers
+ if (wantarray)
+ {
+ my $r = [ $x->[0] % $yorg->[0] ];
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return ($x,$r);
+ }
+ else
+ {
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return $x;
+ }
+ }
+ # if x has more than one, but y has only one element:
+ if (@$yorg == 1)
+ {
+ my $rem;
+ $rem = _mod($c,[ @$x ],$yorg) if wantarray;
+
+ # shortcut, $y is < $BASE
+ my $j = scalar @$x; my $r = 0;
+ my $y = $yorg->[0]; my $b;
+ while ($j-- > 0)
+ {
+ $b = $r * $BASE + $x->[$j];
+ $x->[$j] = int($b/$y);
+ $r = $b % $y;
+ }
+ pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+ # now x and y have more than one element
+
+ # check whether y has more elements than x, if yet, the result will be 0
+ if (@$yorg > @$x)
+ {
+ my $rem;
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to original array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x; # only x, which is [0] now
+ }
+ # check whether the numbers have the same number of elements, in that case
+ # the result will fit into one element and can be computed efficiently
+ if (@$yorg == @$x)
+ {
+ my $rem;
+ # if $yorg has more digits than $x (it's leading element is longer than
+ # the one from $x), the result will also be 0:
+ if (length(int($yorg->[-1])) > length(int($x->[-1])))
+ {
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to org array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # now calculate $x / $yorg
+
+ if (length(int($yorg->[-1])) == length(int($x->[-1])))
+ {
+ # same length, so make full compare
+
+ my $a = 0; my $j = scalar @$x - 1;
+ # manual way (abort if unequal, good for early ne)
+ while ($j >= 0)
+ {
+ last if ($a = $x->[$j] - $yorg->[$j]); $j--;
+ }
+ # $a contains the result of the compare between X and Y
+ # a < 0: x < y, a == 0: x == y, a > 0: x > y
+ if ($a <= 0)
+ {
+ $rem = [ 0 ]; # a = 0 => x == y => rem 0
+ $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
+ splice(@$x,1); # keep single element
+ $x->[0] = 0; # if $a < 0
+ $x->[0] = 1 if $a == 0; # $x == $y
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # $x >= $y, so proceed normally
+
+ }
+ }
+
+ # all other cases:
+
+ my $y = [ @$yorg ]; # always make copy to preserve
+
+ my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
+
+ $car = $bar = $prd = 0;
+ if (($dd = int($BASE/($y->[-1]+1))) != 1)
+ {
+ for $xi (@$x)
+ {
+ $xi = $xi * $dd + $car;
+ $xi -= ($car = int($xi / $BASE)) * $BASE;
+ }
+ push(@$x, $car); $car = 0;
+ for $yi (@$y)
+ {
+ $yi = $yi * $dd + $car;
+ $yi -= ($car = int($yi / $BASE)) * $BASE;
+ }
+ }
+ else
+ {
+ push(@$x, 0);
+ }
+
+ # @q will accumulate the final result, $q contains the current computed
+ # part of the final result
+
+ @q = (); ($v2,$v1) = @$y[-2,-1];
+ $v2 = 0 unless $v2;
+ while ($#$x > $#$y)
+ {
+ ($u2,$u1,$u0) = @$x[-3..-1];
+ $u2 = 0 unless $u2;
+ #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
+ # if $v1 == 0;
+ $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2);
+ if ($q)
+ {
+ ($car, $bar) = (0,0);
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $prd = $q * $y->[$yi] + $car;
+ $prd -= ($car = int($prd / $BASE)) * $BASE;
+ $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
+ }
+ if ($x->[-1] < $car + $bar)
+ {
+ $car = 0; --$q;
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $x->[$xi] -= $BASE
+ if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE));
+ }
+ }
+ }
+ pop(@$x); unshift(@q, $q);
+ }
+ if (wantarray)
+ {
+ @d = ();
+ if ($dd != 1)
+ {
+ $car = 0;
+ for $xi (reverse @$x)
+ {
+ $prd = $car * $BASE + $xi;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else
+ {
+ @d = @$x;
+ }
+ @$x = @q;
+ my $d = \@d;
+ __strip_zeros($x);
+ __strip_zeros($d);
+ return ($x,$d);
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ $x;
+ }
+
+sub _div_use_div
+ {
+ # ref to array, ref to array, modify first array and return remainder if
+ # in list context
+ my ($c,$x,$yorg) = @_;
+
+ # the general div algorithmn here is about O(N*N) and thus quite slow, so
+ # we first check for some special cases and use shortcuts to handle them.
+
+ # This works, because we store the numbers in a chunked format where each
+ # element contains 5..7 digits (depending on system).
+
+ # if both numbers have only one element:
+ if (@$x == 1 && @$yorg == 1)
+ {
+ # shortcut, $yorg and $x are two small numbers
+ if (wantarray)
+ {
+ my $r = [ $x->[0] % $yorg->[0] ];
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return ($x,$r);
+ }
+ else
+ {
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return $x;
+ }
+ }
+ # if x has more than one, but y has only one element:
+ if (@$yorg == 1)
+ {
+ my $rem;
+ $rem = _mod($c,[ @$x ],$yorg) if wantarray;
+
+ # shortcut, $y is < $BASE
+ my $j = scalar @$x; my $r = 0;
+ my $y = $yorg->[0]; my $b;
+ while ($j-- > 0)
+ {
+ $b = $r * $BASE + $x->[$j];
+ $x->[$j] = int($b/$y);
+ $r = $b % $y;
+ }
+ pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+ # now x and y have more than one element
+
+ # check whether y has more elements than x, if yet, the result will be 0
+ if (@$yorg > @$x)
+ {
+ my $rem;
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to original array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x; # only x, which is [0] now
+ }
+ # check whether the numbers have the same number of elements, in that case
+ # the result will fit into one element and can be computed efficiently
+ if (@$yorg == @$x)
+ {
+ my $rem;
+ # if $yorg has more digits than $x (it's leading element is longer than
+ # the one from $x), the result will also be 0:
+ if (length(int($yorg->[-1])) > length(int($x->[-1])))
+ {
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to org array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # now calculate $x / $yorg
+
+ if (length(int($yorg->[-1])) == length(int($x->[-1])))
+ {
+ # same length, so make full compare
+
+ my $a = 0; my $j = scalar @$x - 1;
+ # manual way (abort if unequal, good for early ne)
+ while ($j >= 0)
+ {
+ last if ($a = $x->[$j] - $yorg->[$j]); $j--;
+ }
+ # $a contains the result of the compare between X and Y
+ # a < 0: x < y, a == 0: x == y, a > 0: x > y
+ if ($a <= 0)
+ {
+ $rem = [ 0 ]; # a = 0 => x == y => rem 0
+ $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
+ splice(@$x,1); # keep single element
+ $x->[0] = 0; # if $a < 0
+ $x->[0] = 1 if $a == 0; # $x == $y
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # $x >= $y, so proceed normally
+
+ }
+ }
+
+ # all other cases:
+
+ my $y = [ @$yorg ]; # always make copy to preserve
+
+ my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
+
+ $car = $bar = $prd = 0;
+ if (($dd = int($BASE/($y->[-1]+1))) != 1)
+ {
+ for $xi (@$x)
+ {
+ $xi = $xi * $dd + $car;
+ $xi -= ($car = int($xi / $BASE)) * $BASE;
+ }
+ push(@$x, $car); $car = 0;
+ for $yi (@$y)
+ {
+ $yi = $yi * $dd + $car;
+ $yi -= ($car = int($yi / $BASE)) * $BASE;
+ }
+ }
+ else
+ {
+ push(@$x, 0);
+ }
+
+ # @q will accumulate the final result, $q contains the current computed
+ # part of the final result
+
+ @q = (); ($v2,$v1) = @$y[-2,-1];
+ $v2 = 0 unless $v2;
+ while ($#$x > $#$y)
+ {
+ ($u2,$u1,$u0) = @$x[-3..-1];
+ $u2 = 0 unless $u2;
+ #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
+ # if $v1 == 0;
+ $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2);
+ if ($q)
+ {
+ ($car, $bar) = (0,0);
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $prd = $q * $y->[$yi] + $car;
+ $prd -= ($car = int($prd / $BASE)) * $BASE;
+ $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
+ }
+ if ($x->[-1] < $car + $bar)
+ {
+ $car = 0; --$q;
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $x->[$xi] -= $BASE
+ if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE));
+ }
+ }
+ }
+ pop(@$x); unshift(@q, $q);
+ }
+ if (wantarray)
+ {
+ @d = ();
+ if ($dd != 1)
+ {
+ $car = 0;
+ for $xi (reverse @$x)
+ {
+ $prd = $car * $BASE + $xi;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else
+ {
+ @d = @$x;
+ }
+ @$x = @q;
+ my $d = \@d;
+ __strip_zeros($x);
+ __strip_zeros($d);
+ return ($x,$d);
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ $x;
+ }
+
+##############################################################################
+# testing
+
+sub _acmp
+ {
+ # internal absolute post-normalized compare (ignore signs)
+ # ref to array, ref to array, return <0, 0, >0
+ # arrays must have at least one entry; this is not checked for
+ my ($c,$cx,$cy) = @_;
+
+ # shortcut for short numbers
+ return (($cx->[0] <=> $cy->[0]) <=> 0)
+ if scalar @$cx == scalar @$cy && scalar @$cx == 1;
+
+ # fast comp based on number of array elements (aka pseudo-length)
+ my $lxy = (scalar @$cx - scalar @$cy)
+ # or length of first element if same number of elements (aka difference 0)
+ ||
+ # need int() here because sometimes the last element is '00018' vs '18'
+ (length(int($cx->[-1])) - length(int($cy->[-1])));
+ return -1 if $lxy < 0; # already differs, ret
+ return 1 if $lxy > 0; # ditto
+
+ # manual way (abort if unequal, good for early ne)
+ my $a; my $j = scalar @$cx;
+ while (--$j >= 0)
+ {
+ last if ($a = $cx->[$j] - $cy->[$j]);
+ }
+ $a <=> 0;
+ }
+
+sub _len
+ {
+ # compute number of digits in base 10
+
+ # int() because add/sub sometimes leaves strings (like '00005') instead of
+ # '5' in this place, thus causing length() to report wrong length
+ my $cx = $_[1];
+
+ (@$cx-1)*$BASE_LEN+length(int($cx->[-1]));
+ }
+
+sub _digit
+ {
+ # return the nth digit, negative values count backward
+ # zero is rightmost, so _digit(123,0) will give 3
+ my ($c,$x,$n) = @_;
+
+ my $len = _len('',$x);
+
+ $n = $len+$n if $n < 0; # -1 last, -2 second-to-last
+ $n = abs($n); # if negative was too big
+ $len--; $n = $len if $n > $len; # n to big?
+
+ my $elem = int($n / $BASE_LEN); # which array element
+ my $digit = $n % $BASE_LEN; # which digit in this element
+ $elem = '0' x $BASE_LEN . @$x[$elem]; # get element padded with 0's
+ substr($elem,-$digit-1,1);
+ }
+
+sub _zeros
+ {
+ # return amount of trailing zeros in decimal
+ # check each array elem in _m for having 0 at end as long as elem == 0
+ # Upon finding a elem != 0, stop
+ my $x = $_[1];
+
+ return 0 if scalar @$x == 1 && $x->[0] == 0;
+
+ my $zeros = 0; my $elem;
+ foreach my $e (@$x)
+ {
+ if ($e != 0)
+ {
+ $elem = "$e"; # preserve x
+ $elem =~ s/.*?(0*$)/$1/; # strip anything not zero
+ $zeros *= $BASE_LEN; # elems * 5
+ $zeros += length($elem); # count trailing zeros
+ last; # early out
+ }
+ $zeros ++; # real else branch: 50% slower!
+ }
+ $zeros;
+ }
+
+##############################################################################
+# _is_* routines
+
+sub _is_zero
+ {
+ # return true if arg is zero
+ (((scalar @{$_[1]} == 1) && ($_[1]->[0] == 0))) <=> 0;
+ }
+
+sub _is_even
+ {
+ # return true if arg is even
+ (!($_[1]->[0] & 1)) <=> 0;
+ }
+
+sub _is_odd
+ {
+ # return true if arg is even
+ (($_[1]->[0] & 1)) <=> 0;
+ }
+
+sub _is_one
+ {
+ # return true if arg is one
+ (scalar @{$_[1]} == 1) && ($_[1]->[0] == 1) <=> 0;
+ }
+
+sub _is_two
+ {
+ # return true if arg is two
+ (scalar @{$_[1]} == 1) && ($_[1]->[0] == 2) <=> 0;
+ }
+
+sub _is_ten
+ {
+ # return true if arg is ten
+ (scalar @{$_[1]} == 1) && ($_[1]->[0] == 10) <=> 0;
+ }
+
+sub __strip_zeros
+ {
+ # internal normalization function that strips leading zeros from the array
+ # args: ref to array
+ my $s = shift;
+
+ my $cnt = scalar @$s; # get count of parts
+ my $i = $cnt-1;
+ push @$s,0 if $i < 0; # div might return empty results, so fix it
+
+ return $s if @$s == 1; # early out
+
+ #print "strip: cnt $cnt i $i\n";
+ # '0', '3', '4', '0', '0',
+ # 0 1 2 3 4
+ # cnt = 5, i = 4
+ # i = 4
+ # i = 3
+ # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
+ # >= 1: skip first part (this can be zero)
+ while ($i > 0) { last if $s->[$i] != 0; $i--; }
+ $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0
+ $s;
+ }
+
+###############################################################################
+# check routine to test internal state for corruptions
+
+sub _check
+ {
+ # used by the test suite
+ my $x = $_[1];
+
+ return "$x is not a reference" if !ref($x);
+
+ # are all parts are valid?
+ my $i = 0; my $j = scalar @$x; my ($e,$try);
+ while ($i < $j)
+ {
+ $e = $x->[$i]; $e = 'undef' unless defined $e;
+ $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)";
+ last if $e !~ /^[+]?[0-9]+$/;
+ $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)";
+ last if "$e" !~ /^[+]?[0-9]+$/;
+ $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)";
+ last if '' . "$e" !~ /^[+]?[0-9]+$/;
+ $try = ' < 0 || >= $BASE; '."($x, $e)";
+ last if $e <0 || $e >= $BASE;
+ # this test is disabled, since new/bnorm and certain ops (like early out
+ # in add/sub) are allowed/expected to leave '00000' in some elements
+ #$try = '=~ /^00+/; '."($x, $e)";
+ #last if $e =~ /^00+/;
+ $i++;
+ }
+ return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j;
+ 0;
+ }
+
+
+###############################################################################
+
+sub _mod
+ {
+ # if possible, use mod shortcut
+ my ($c,$x,$yo) = @_;
+
+ # slow way since $y to big
+ if (scalar @$yo > 1)
+ {
+ my ($xo,$rem) = _div($c,$x,$yo);
+ return $rem;
+ }
+
+ my $y = $yo->[0];
+ # both are single element arrays
+ if (scalar @$x == 1)
+ {
+ $x->[0] %= $y;
+ return $x;
+ }
+
+ # @y is a single element, but @x has more than one element
+ my $b = $BASE % $y;
+ if ($b == 0)
+ {
+ # when BASE % Y == 0 then (B * BASE) % Y == 0
+ # (B * BASE) % $y + A % Y => A % Y
+ # so need to consider only last element: O(1)
+ $x->[0] %= $y;
+ }
+ elsif ($b == 1)
+ {
+ # else need to go through all elements: O(N), but loop is a bit simplified
+ my $r = 0;
+ foreach (@$x)
+ {
+ $r = ($r + $_) % $y; # not much faster, but heh...
+ #$r += $_ % $y; $r %= $y;
+ }
+ $r = 0 if $r == $y;
+ $x->[0] = $r;
+ }
+ else
+ {
+ # else need to go through all elements: O(N)
+ my $r = 0; my $bm = 1;
+ foreach (@$x)
+ {
+ $r = ($_ * $bm + $r) % $y;
+ $bm = ($bm * $b) % $y;
+
+ #$r += ($_ % $y) * $bm;
+ #$bm *= $b;
+ #$bm %= $y;
+ #$r %= $y;
+ }
+ $r = 0 if $r == $y;
+ $x->[0] = $r;
+ }
+ splice (@$x,1); # keep one element of $x
+ $x;
+ }
+
+##############################################################################
+# shifts
+
+sub _rsft
+ {
+ my ($c,$x,$y,$n) = @_;
+
+ if ($n != 10)
+ {
+ $n = _new($c,$n); return _div($c,$x, _pow($c,$n,$y));
+ }
+
+ # shortcut (faster) for shifting by 10)
+ # multiples of $BASE_LEN
+ my $dst = 0; # destination
+ my $src = _num($c,$y); # as normal int
+ my $xlen = (@$x-1)*$BASE_LEN+length(int($x->[-1])); # len of x in digits
+ if ($src >= $xlen or ($src == $xlen and ! defined $x->[1]))
+ {
+ # 12345 67890 shifted right by more than 10 digits => 0
+ splice (@$x,1); # leave only one element
+ $x->[0] = 0; # set to zero
+ return $x;
+ }
+ my $rem = $src % $BASE_LEN; # remainder to shift
+ $src = int($src / $BASE_LEN); # source
+ if ($rem == 0)
+ {
+ splice (@$x,0,$src); # even faster, 38.4 => 39.3
+ }
+ else
+ {
+ my $len = scalar @$x - $src; # elems to go
+ my $vd; my $z = '0'x $BASE_LEN;
+ $x->[scalar @$x] = 0; # avoid || 0 test inside loop
+ while ($dst < $len)
+ {
+ $vd = $z.$x->[$src];
+ $vd = substr($vd,-$BASE_LEN,$BASE_LEN-$rem);
+ $src++;
+ $vd = substr($z.$x->[$src],-$rem,$rem) . $vd;
+ $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
+ $x->[$dst] = int($vd);
+ $dst++;
+ }
+ splice (@$x,$dst) if $dst > 0; # kill left-over array elems
+ pop @$x if $x->[-1] == 0 && @$x > 1; # kill last element if 0
+ } # else rem == 0
+ $x;
+ }
+
+sub _lsft
+ {
+ my ($c,$x,$y,$n) = @_;
+
+ if ($n != 10)
+ {
+ $n = _new($c,$n); return _mul($c,$x, _pow($c,$n,$y));
+ }
+
+ # shortcut (faster) for shifting by 10) since we are in base 10eX
+ # multiples of $BASE_LEN:
+ my $src = scalar @$x; # source
+ my $len = _num($c,$y); # shift-len as normal int
+ my $rem = $len % $BASE_LEN; # remainder to shift
+ my $dst = $src + int($len/$BASE_LEN); # destination
+ my $vd; # further speedup
+ $x->[$src] = 0; # avoid first ||0 for speed
+ my $z = '0' x $BASE_LEN;
+ while ($src >= 0)
+ {
+ $vd = $x->[$src]; $vd = $z.$vd;
+ $vd = substr($vd,-$BASE_LEN+$rem,$BASE_LEN-$rem);
+ $vd .= $src > 0 ? substr($z.$x->[$src-1],-$BASE_LEN,$rem) : '0' x $rem;
+ $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
+ $x->[$dst] = int($vd);
+ $dst--; $src--;
+ }
+ # set lowest parts to 0
+ while ($dst >= 0) { $x->[$dst--] = 0; }
+ # fix spurios last zero element
+ splice @$x,-1 if $x->[-1] == 0;
+ $x;
+ }
+
+sub _pow
+ {
+ # power of $x to $y
+ # ref to array, ref to array, return ref to array
+ my ($c,$cx,$cy) = @_;
+
+ if (scalar @$cy == 1 && $cy->[0] == 0)
+ {
+ splice (@$cx,1); $cx->[0] = 1; # y == 0 => x => 1
+ return $cx;
+ }
+ if ((scalar @$cx == 1 && $cx->[0] == 1) || # x == 1
+ (scalar @$cy == 1 && $cy->[0] == 1)) # or y == 1
+ {
+ return $cx;
+ }
+ if (scalar @$cx == 1 && $cx->[0] == 0)
+ {
+ splice (@$cx,1); $cx->[0] = 0; # 0 ** y => 0 (if not y <= 0)
+ return $cx;
+ }
+
+ my $pow2 = _one();
+
+ my $y_bin = _as_bin($c,$cy); $y_bin =~ s/^0b//;
+ my $len = length($y_bin);
+ while (--$len > 0)
+ {
+ _mul($c,$pow2,$cx) if substr($y_bin,$len,1) eq '1'; # is odd?
+ _mul($c,$cx,$cx);
+ }
+
+ _mul($c,$cx,$pow2);
+ $cx;
+ }
+
+sub _nok
+ {
+ # n over k
+ # ref to array, return ref to array
+ my ($c,$n,$k) = @_;
+
+ # ( 7 ) 7! 7*6*5 * 4*3*2*1 7 * 6 * 5
+ # ( - ) = --------- = --------------- = ---------
+ # ( 3 ) 3! (7-3)! 3*2*1 * 4*3*2*1 3 * 2 * 1
+
+ # compute n - k + 2 (so we start with 5 in the example above)
+ my $x = _copy($c,$n);
+
+ _sub($c,$n,$k);
+ if (!_is_one($c,$n))
+ {
+ _inc($c,$n);
+ my $f = _copy($c,$n); _inc($c,$f); # n = 5, f = 6, d = 2
+ my $d = _two($c);
+ while (_acmp($c,$f,$x) <= 0) # f < n ?
+ {
+ # n = (n * f / d) == 5 * 6 / 2 => n == 3
+ $n = _mul($c,$n,$f); $n = _div($c,$n,$d);
+ # f = 7, d = 3
+ _inc($c,$f); _inc($c,$d);
+ }
+ }
+ else
+ {
+ # keep ref to $n and set it to 1
+ splice (@$n,1); $n->[0] = 1;
+ }
+ $n;
+ }
+
+my @factorials = (
+ 1,
+ 1,
+ 2,
+ 2*3,
+ 2*3*4,
+ 2*3*4*5,
+ 2*3*4*5*6,
+ 2*3*4*5*6*7,
+);
+
+sub _fac
+ {
+ # factorial of $x
+ # ref to array, return ref to array
+ my ($c,$cx) = @_;
+
+ if ((@$cx == 1) && ($cx->[0] <= 7))
+ {
+ $cx->[0] = $factorials[$cx->[0]]; # 0 => 1, 1 => 1, 2 => 2 etc.
+ return $cx;
+ }
+
+ if ((@$cx == 1) && # we do this only if $x >= 12 and $x <= 7000
+ ($cx->[0] >= 12 && $cx->[0] < 7000))
+ {
+
+ # Calculate (k-j) * (k-j+1) ... k .. (k+j-1) * (k + j)
+ # See http://blogten.blogspot.com/2007/01/calculating-n.html
+ # The above series can be expressed as factors:
+ # k * k - (j - i) * 2
+ # We cache k*k, and calculate (j * j) as the sum of the first j odd integers
+
+ # This will not work when N exceeds the storage of a Perl scalar, however,
+ # in this case the algorithm would be way to slow to terminate, anyway.
+
+ # As soon as the last element of $cx is 0, we split it up and remember
+ # how many zeors we got so far. The reason is that n! will accumulate
+ # zeros at the end rather fast.
+ my $zero_elements = 0;
+
+ # If n is even, set n = n -1
+ my $k = _num($c,$cx); my $even = 1;
+ if (($k & 1) == 0)
+ {
+ $even = $k; $k --;
+ }
+ # set k to the center point
+ $k = ($k + 1) / 2;
+# print "k $k even: $even\n";
+ # now calculate k * k
+ my $k2 = $k * $k;
+ my $odd = 1; my $sum = 1;
+ my $i = $k - 1;
+ # keep reference to x
+ my $new_x = _new($c, $k * $even);
+ @$cx = @$new_x;
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+# print STDERR "x = ", _str($c,$cx),"\n";
+ my $BASE2 = int(sqrt($BASE))-1;
+ my $j = 1;
+ while ($j <= $i)
+ {
+ my $m = ($k2 - $sum); $odd += 2; $sum += $odd; $j++;
+ while ($j <= $i && ($m < $BASE2) && (($k2 - $sum) < $BASE2))
+ {
+ $m *= ($k2 - $sum);
+ $odd += 2; $sum += $odd; $j++;
+# print STDERR "\n k2 $k2 m $m sum $sum odd $odd\n"; sleep(1);
+ }
+ if ($m < $BASE)
+ {
+ _mul($c,$cx,[$m]);
+ }
+ else
+ {
+ _mul($c,$cx,$c->_new($m));
+ }
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+# print STDERR "Calculate $k2 - $sum = $m (x = ", _str($c,$cx),")\n";
+ }
+ # multiply in the zeros again
+ unshift @$cx, (0) x $zero_elements;
+ return $cx;
+ }
+
+ # go forward until $base is exceeded
+ # limit is either $x steps (steps == 100 means a result always too high) or
+ # $base.
+ my $steps = 100; $steps = $cx->[0] if @$cx == 1;
+ my $r = 2; my $cf = 3; my $step = 2; my $last = $r;
+ while ($r*$cf < $BASE && $step < $steps)
+ {
+ $last = $r; $r *= $cf++; $step++;
+ }
+ if ((@$cx == 1) && $step == $cx->[0])
+ {
+ # completely done, so keep reference to $x and return
+ $cx->[0] = $r;
+ return $cx;
+ }
+
+ # now we must do the left over steps
+ my $n; # steps still to do
+ if (scalar @$cx == 1)
+ {
+ $n = $cx->[0];
+ }
+ else
+ {
+ $n = _copy($c,$cx);
+ }
+
+ # Set $cx to the last result below $BASE (but keep ref to $x)
+ $cx->[0] = $last; splice (@$cx,1);
+ # As soon as the last element of $cx is 0, we split it up and remember
+ # how many zeors we got so far. The reason is that n! will accumulate
+ # zeros at the end rather fast.
+ my $zero_elements = 0;
+
+ # do left-over steps fit into a scalar?
+ if (ref $n eq 'ARRAY')
+ {
+ # No, so use slower inc() & cmp()
+ # ($n is at least $BASE here)
+ my $base_2 = int(sqrt($BASE)) - 1;
+ #print STDERR "base_2: $base_2\n";
+ while ($step < $base_2)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ my $b = $step * ($step + 1); $step += 2;
+ _mul($c,$cx,[$b]);
+ }
+ $step = [$step];
+ while (_acmp($c,$step,$n) <= 0)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ _mul($c,$cx,$step); _inc($c,$step);
+ }
+ }
+ else
+ {
+ # Yes, so we can speed it up slightly
+
+# print "# left over steps $n\n";
+
+ my $base_4 = int(sqrt(sqrt($BASE))) - 2;
+ #print STDERR "base_4: $base_4\n";
+ my $n4 = $n - 4;
+ while ($step < $n4 && $step < $base_4)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ my $b = $step * ($step + 1); $step += 2; $b *= $step * ($step + 1); $step += 2;
+ _mul($c,$cx,[$b]);
+ }
+ my $base_2 = int(sqrt($BASE)) - 1;
+ my $n2 = $n - 2;
+ #print STDERR "base_2: $base_2\n";
+ while ($step < $n2 && $step < $base_2)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ my $b = $step * ($step + 1); $step += 2;
+ _mul($c,$cx,[$b]);
+ }
+ # do what's left over
+ while ($step <= $n)
+ {
+ _mul($c,$cx,[$step]); $step++;
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ }
+ }
+ # multiply in the zeros again
+ unshift @$cx, (0) x $zero_elements;
+ $cx; # return result
+ }
+
+#############################################################################
+
+sub _log_int
+ {
+ # calculate integer log of $x to base $base
+ # ref to array, ref to array - return ref to array
+ my ($c,$x,$base) = @_;
+
+ # X == 0 => NaN
+ return if (scalar @$x == 1 && $x->[0] == 0);
+ # BASE 0 or 1 => NaN
+ return if (scalar @$base == 1 && $base->[0] < 2);
+ my $cmp = _acmp($c,$x,$base); # X == BASE => 1
+ if ($cmp == 0)
+ {
+ splice (@$x,1); $x->[0] = 1;
+ return ($x,1)
+ }
+ # X < BASE
+ if ($cmp < 0)
+ {
+ splice (@$x,1); $x->[0] = 0;
+ return ($x,undef);
+ }
+
+ my $x_org = _copy($c,$x); # preserve x
+ splice(@$x,1); $x->[0] = 1; # keep ref to $x
+
+ # Compute a guess for the result based on:
+ # $guess = int ( length_in_base_10(X) / ( log(base) / log(10) ) )
+ my $len = _len($c,$x_org);
+ my $log = log($base->[-1]) / log(10);
+
+ # for each additional element in $base, we add $BASE_LEN to the result,
+ # based on the observation that log($BASE,10) is BASE_LEN and
+ # log(x*y) == log(x) + log(y):
+ $log += ((scalar @$base)-1) * $BASE_LEN;
+
+ # calculate now a guess based on the values obtained above:
+ my $res = int($len / $log);
+
+ $x->[0] = $res;
+ my $trial = _pow ($c, _copy($c, $base), $x);
+ my $a = _acmp($c,$trial,$x_org);
+
+# print STDERR "# trial ", _str($c,$x)," was: $a (0 = exact, -1 too small, +1 too big)\n";
+
+ # found an exact result?
+ return ($x,1) if $a == 0;
+
+ if ($a > 0)
+ {
+ # or too big
+ _div($c,$trial,$base); _dec($c, $x);
+ while (($a = _acmp($c,$trial,$x_org)) > 0)
+ {
+# print STDERR "# big _log_int at ", _str($c,$x), "\n";
+ _div($c,$trial,$base); _dec($c, $x);
+ }
+ # result is now exact (a == 0), or too small (a < 0)
+ return ($x, $a == 0 ? 1 : 0);
+ }
+
+ # else: result was to small
+ _mul($c,$trial,$base);
+
+ # did we now get the right result?
+ $a = _acmp($c,$trial,$x_org);
+
+ if ($a == 0) # yes, exactly
+ {
+ _inc($c, $x);
+ return ($x,1);
+ }
+ return ($x,0) if $a > 0;
+
+ # Result still too small (we should come here only if the estimate above
+ # was very off base):
+
+ # Now let the normal trial run obtain the real result
+ # Simple loop that increments $x by 2 in each step, possible overstepping
+ # the real result
+
+ my $base_mul = _mul($c, _copy($c,$base), $base); # $base * $base
+
+ while (($a = _acmp($c,$trial,$x_org)) < 0)
+ {
+# print STDERR "# small _log_int at ", _str($c,$x), "\n";
+ _mul($c,$trial,$base_mul); _add($c, $x, [2]);
+ }
+
+ my $exact = 1;
+ if ($a > 0)
+ {
+ # overstepped the result
+ _dec($c, $x);
+ _div($c,$trial,$base);
+ $a = _acmp($c,$trial,$x_org);
+ if ($a > 0)
+ {
+ _dec($c, $x);
+ }
+ $exact = 0 if $a != 0; # a = -1 => not exact result, a = 0 => exact
+ }
+
+ ($x,$exact); # return result
+ }
+
+# for debugging:
+ use constant DEBUG => 0;
+ my $steps = 0;
+ sub steps { $steps };
+
+sub _sqrt
+ {
+ # square-root of $x in place
+ # Compute a guess of the result (by rule of thumb), then improve it via
+ # Newton's method.
+ my ($c,$x) = @_;
+
+ if (scalar @$x == 1)
+ {
+ # fits into one Perl scalar, so result can be computed directly
+ $x->[0] = int(sqrt($x->[0]));
+ return $x;
+ }
+ my $y = _copy($c,$x);
+ # hopefully _len/2 is < $BASE, the -1 is to always undershot the guess
+ # since our guess will "grow"
+ my $l = int((_len($c,$x)-1) / 2);
+
+ my $lastelem = $x->[-1]; # for guess
+ my $elems = scalar @$x - 1;
+ # not enough digits, but could have more?
+ if ((length($lastelem) <= 3) && ($elems > 1))
+ {
+ # right-align with zero pad
+ my $len = length($lastelem) & 1;
+ print "$lastelem => " if DEBUG;
+ $lastelem .= substr($x->[-2] . '0' x $BASE_LEN,0,$BASE_LEN);
+ # former odd => make odd again, or former even to even again
+ $lastelem = $lastelem / 10 if (length($lastelem) & 1) != $len;
+ print "$lastelem\n" if DEBUG;
+ }
+
+ # construct $x (instead of _lsft($c,$x,$l,10)
+ my $r = $l % $BASE_LEN; # 10000 00000 00000 00000 ($BASE_LEN=5)
+ $l = int($l / $BASE_LEN);
+ print "l = $l " if DEBUG;
+
+ splice @$x,$l; # keep ref($x), but modify it
+
+ # we make the first part of the guess not '1000...0' but int(sqrt($lastelem))
+ # that gives us:
+ # 14400 00000 => sqrt(14400) => guess first digits to be 120
+ # 144000 000000 => sqrt(144000) => guess 379
+
+ print "$lastelem (elems $elems) => " if DEBUG;
+ $lastelem = $lastelem / 10 if ($elems & 1 == 1); # odd or even?
+ my $g = sqrt($lastelem); $g =~ s/\.//; # 2.345 => 2345
+ $r -= 1 if $elems & 1 == 0; # 70 => 7
+
+ # padd with zeros if result is too short
+ $x->[$l--] = int(substr($g . '0' x $r,0,$r+1));
+ print "now ",$x->[-1] if DEBUG;
+ print " would have been ", int('1' . '0' x $r),"\n" if DEBUG;
+
+ # If @$x > 1, we could compute the second elem of the guess, too, to create
+ # an even better guess. Not implemented yet. Does it improve performance?
+ $x->[$l--] = 0 while ($l >= 0); # all other digits of guess are zero
+
+ print "start x= ",_str($c,$x),"\n" if DEBUG;
+ my $two = _two();
+ my $last = _zero();
+ my $lastlast = _zero();
+ $steps = 0 if DEBUG;
+ while (_acmp($c,$last,$x) != 0 && _acmp($c,$lastlast,$x) != 0)
+ {
+ $steps++ if DEBUG;
+ $lastlast = _copy($c,$last);
+ $last = _copy($c,$x);
+ _add($c,$x, _div($c,_copy($c,$y),$x));
+ _div($c,$x, $two );
+ print " x= ",_str($c,$x),"\n" if DEBUG;
+ }
+ print "\nsteps in sqrt: $steps, " if DEBUG;
+ _dec($c,$x) if _acmp($c,$y,_mul($c,_copy($c,$x),$x)) < 0; # overshot?
+ print " final ",$x->[-1],"\n" if DEBUG;
+ $x;
+ }
+
+sub _root
+ {
+ # take n'th root of $x in place (n >= 3)
+ my ($c,$x,$n) = @_;
+
+ if (scalar @$x == 1)
+ {
+ if (scalar @$n > 1)
+ {
+ # result will always be smaller than 2 so trunc to 1 at once
+ $x->[0] = 1;
+ }
+ else
+ {
+ # fits into one Perl scalar, so result can be computed directly
+ # cannot use int() here, because it rounds wrongly (try
+ # (81 ** 3) ** (1/3) to see what I mean)
+ #$x->[0] = int( $x->[0] ** (1 / $n->[0]) );
+ # round to 8 digits, then truncate result to integer
+ $x->[0] = int ( sprintf ("%.8f", $x->[0] ** (1 / $n->[0]) ) );
+ }
+ return $x;
+ }
+
+ # we know now that X is more than one element long
+
+ # if $n is a power of two, we can repeatedly take sqrt($X) and find the
+ # proper result, because sqrt(sqrt($x)) == root($x,4)
+ my $b = _as_bin($c,$n);
+ if ($b =~ /0b1(0+)$/)
+ {
+ my $count = CORE::length($1); # 0b100 => len('00') => 2
+ my $cnt = $count; # counter for loop
+ unshift (@$x, 0); # add one element, together with one
+ # more below in the loop this makes 2
+ while ($cnt-- > 0)
+ {
+ # 'inflate' $X by adding one element, basically computing
+ # $x * $BASE * $BASE. This gives us more $BASE_LEN digits for result
+ # since len(sqrt($X)) approx == len($x) / 2.
+ unshift (@$x, 0);
+ # calculate sqrt($x), $x is now one element to big, again. In the next
+ # round we make that two, again.
+ _sqrt($c,$x);
+ }
+ # $x is now one element to big, so truncate result by removing it
+ splice (@$x,0,1);
+ }
+ else
+ {
+ # trial computation by starting with 2,4,8,16 etc until we overstep
+ my $step;
+ my $trial = _two();
+
+ # while still to do more than X steps
+ do
+ {
+ $step = _two();
+ while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0)
+ {
+ _mul ($c, $step, [2]);
+ _add ($c, $trial, $step);
+ }
+
+ # hit exactly?
+ if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) == 0)
+ {
+ @$x = @$trial; # make copy while preserving ref to $x
+ return $x;
+ }
+ # overstepped, so go back on step
+ _sub($c, $trial, $step);
+ } while (scalar @$step > 1 || $step->[0] > 128);
+
+ # reset step to 2
+ $step = _two();
+ # add two, because $trial cannot be exactly the result (otherwise we would
+ # alrady have found it)
+ _add($c, $trial, $step);
+
+ # and now add more and more (2,4,6,8,10 etc)
+ while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0)
+ {
+ _add ($c, $trial, $step);
+ }
+
+ # hit not exactly? (overstepped)
+ if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0)
+ {
+ _dec($c,$trial);
+ }
+
+ # hit not exactly? (overstepped)
+ # 80 too small, 81 slightly too big, 82 too big
+ if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0)
+ {
+ _dec ($c, $trial);
+ }
+
+ @$x = @$trial; # make copy while preserving ref to $x
+ return $x;
+ }
+ $x;
+ }
+
+##############################################################################
+# binary stuff
+
+sub _and
+ {
+ my ($c,$x,$y) = @_;
+
+ # the shortcut makes equal, large numbers _really_ fast, and makes only a
+ # very small performance drop for small numbers (e.g. something with less
+ # than 32 bit) Since we optimize for large numbers, this is enabled.
+ return $x if _acmp($c,$x,$y) == 0; # shortcut
+
+ my $m = _one(); my ($xr,$yr);
+ my $mask = $AND_MASK;
+
+ my $x1 = $x;
+ my $y1 = _copy($c,$y); # make copy
+ $x = _zero();
+ my ($b,$xrr,$yrr);
+ use integer;
+ while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+ {
+ ($x1, $xr) = _div($c,$x1,$mask);
+ ($y1, $yr) = _div($c,$y1,$mask);
+
+ # make ints() from $xr, $yr
+ # this is when the AND_BITS are greater than $BASE and is slower for
+ # small (<256 bits) numbers, but faster for large numbers. Disabled
+ # due to KISS principle
+
+# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+# _add($c,$x, _mul($c, _new( $c, ($xrr & $yrr) ), $m) );
+
+ # 0+ due to '&' doesn't work in strings
+ _add($c,$x, _mul($c, [ 0+$xr->[0] & 0+$yr->[0] ], $m) );
+ _mul($c,$m,$mask);
+ }
+ $x;
+ }
+
+sub _xor
+ {
+ my ($c,$x,$y) = @_;
+
+ return _zero() if _acmp($c,$x,$y) == 0; # shortcut (see -and)
+
+ my $m = _one(); my ($xr,$yr);
+ my $mask = $XOR_MASK;
+
+ my $x1 = $x;
+ my $y1 = _copy($c,$y); # make copy
+ $x = _zero();
+ my ($b,$xrr,$yrr);
+ use integer;
+ while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+ {
+ ($x1, $xr) = _div($c,$x1,$mask);
+ ($y1, $yr) = _div($c,$y1,$mask);
+ # make ints() from $xr, $yr (see _and())
+ #$b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+ #$b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+ #_add($c,$x, _mul($c, _new( $c, ($xrr ^ $yrr) ), $m) );
+
+ # 0+ due to '^' doesn't work in strings
+ _add($c,$x, _mul($c, [ 0+$xr->[0] ^ 0+$yr->[0] ], $m) );
+ _mul($c,$m,$mask);
+ }
+ # the loop stops when the shorter of the two numbers is exhausted
+ # the remainder of the longer one will survive bit-by-bit, so we simple
+ # multiply-add it in
+ _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
+ _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
+
+ $x;
+ }
+
+sub _or
+ {
+ my ($c,$x,$y) = @_;
+
+ return $x if _acmp($c,$x,$y) == 0; # shortcut (see _and)
+
+ my $m = _one(); my ($xr,$yr);
+ my $mask = $OR_MASK;
+
+ my $x1 = $x;
+ my $y1 = _copy($c,$y); # make copy
+ $x = _zero();
+ my ($b,$xrr,$yrr);
+ use integer;
+ while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+ {
+ ($x1, $xr) = _div($c,$x1,$mask);
+ ($y1, $yr) = _div($c,$y1,$mask);
+ # make ints() from $xr, $yr (see _and())
+# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+# _add($c,$x, _mul($c, _new( $c, ($xrr | $yrr) ), $m) );
+
+ # 0+ due to '|' doesn't work in strings
+ _add($c,$x, _mul($c, [ 0+$xr->[0] | 0+$yr->[0] ], $m) );
+ _mul($c,$m,$mask);
+ }
+ # the loop stops when the shorter of the two numbers is exhausted
+ # the remainder of the longer one will survive bit-by-bit, so we simple
+ # multiply-add it in
+ _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
+ _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
+
+ $x;
+ }
+
+sub _as_hex
+ {
+ # convert a decimal number to hex (ref to array, return ref to string)
+ my ($c,$x) = @_;
+
+ # fits into one element (handle also 0x0 case)
+ return sprintf("0x%x",$x->[0]) if @$x == 1;
+
+ my $x1 = _copy($c,$x);
+
+ my $es = '';
+ my ($xr, $h, $x10000);
+ if ($] >= 5.006)
+ {
+ $x10000 = [ 0x10000 ]; $h = 'h4';
+ }
+ else
+ {
+ $x10000 = [ 0x1000 ]; $h = 'h3';
+ }
+ while (@$x1 != 1 || $x1->[0] != 0) # _is_zero()
+ {
+ ($x1, $xr) = _div($c,$x1,$x10000);
+ $es .= unpack($h,pack('V',$xr->[0]));
+ }
+ $es = reverse $es;
+ $es =~ s/^[0]+//; # strip leading zeros
+ '0x' . $es; # return result prepended with 0x
+ }
+
+sub _as_bin
+ {
+ # convert a decimal number to bin (ref to array, return ref to string)
+ my ($c,$x) = @_;
+
+ # fits into one element (and Perl recent enough), handle also 0b0 case
+ # handle zero case for older Perls
+ if ($] <= 5.005 && @$x == 1 && $x->[0] == 0)
+ {
+ my $t = '0b0'; return $t;
+ }
+ if (@$x == 1 && $] >= 5.006)
+ {
+ my $t = sprintf("0b%b",$x->[0]);
+ return $t;
+ }
+ my $x1 = _copy($c,$x);
+
+ my $es = '';
+ my ($xr, $b, $x10000);
+ if ($] >= 5.006)
+ {
+ $x10000 = [ 0x10000 ]; $b = 'b16';
+ }
+ else
+ {
+ $x10000 = [ 0x1000 ]; $b = 'b12';
+ }
+ while (!(@$x1 == 1 && $x1->[0] == 0)) # _is_zero()
+ {
+ ($x1, $xr) = _div($c,$x1,$x10000);
+ $es .= unpack($b,pack('v',$xr->[0]));
+ }
+ $es = reverse $es;
+ $es =~ s/^[0]+//; # strip leading zeros
+ '0b' . $es; # return result prepended with 0b
+ }
+
+sub _as_oct
+ {
+ # convert a decimal number to octal (ref to array, return ref to string)
+ my ($c,$x) = @_;
+
+ # fits into one element (handle also 0 case)
+ return sprintf("0%o",$x->[0]) if @$x == 1;
+
+ my $x1 = _copy($c,$x);
+
+ my $es = '';
+ my $xr;
+ my $x1000 = [ 0100000 ];
+ while (@$x1 != 1 || $x1->[0] != 0) # _is_zero()
+ {
+ ($x1, $xr) = _div($c,$x1,$x1000);
+ $es .= reverse sprintf("%05o", $xr->[0]);
+ }
+ $es = reverse $es;
+ $es =~ s/^[0]+//; # strip leading zeros
+ '0' . $es; # return result prepended with 0
+ }
+
+sub _from_oct
+ {
+ # convert a octal number to decimal (string, return ref to array)
+ my ($c,$os) = @_;
+
+ # for older Perls, play safe
+ my $m = [ 0100000 ];
+ my $d = 5; # 5 digits at a time
+
+ my $mul = _one();
+ my $x = _zero();
+
+ my $len = int( (length($os)-1)/$d ); # $d digit parts, w/o the '0'
+ my $val; my $i = -$d;
+ while ($len >= 0)
+ {
+ $val = substr($os,$i,$d); # get oct digits
+ $val = CORE::oct($val);
+ $i -= $d; $len --;
+ my $adder = [ $val ];
+ _add ($c, $x, _mul ($c, $adder, $mul ) ) if $val != 0;
+ _mul ($c, $mul, $m ) if $len >= 0; # skip last mul
+ }
+ $x;
+ }
+
+sub _from_hex
+ {
+ # convert a hex number to decimal (string, return ref to array)
+ my ($c,$hs) = @_;
+
+ my $m = _new($c, 0x10000000); # 28 bit at a time (<32 bit!)
+ my $d = 7; # 7 digits at a time
+ if ($] <= 5.006)
+ {
+ # for older Perls, play safe
+ $m = [ 0x10000 ]; # 16 bit at a time (<32 bit!)
+ $d = 4; # 4 digits at a time
+ }
+
+ my $mul = _one();
+ my $x = _zero();
+
+ my $len = int( (length($hs)-2)/$d ); # $d digit parts, w/o the '0x'
+ my $val; my $i = -$d;
+ while ($len >= 0)
+ {
+ $val = substr($hs,$i,$d); # get hex digits
+ $val =~ s/^0x// if $len == 0; # for last part only because
+ $val = CORE::hex($val); # hex does not like wrong chars
+ $i -= $d; $len --;
+ my $adder = [ $val ];
+ # if the resulting number was to big to fit into one element, create a
+ # two-element version (bug found by Mark Lakata - Thanx!)
+ if (CORE::length($val) > $BASE_LEN)
+ {
+ $adder = _new($c,$val);
+ }
+ _add ($c, $x, _mul ($c, $adder, $mul ) ) if $val != 0;
+ _mul ($c, $mul, $m ) if $len >= 0; # skip last mul
+ }
+ $x;
+ }
+
+sub _from_bin
+ {
+ # convert a hex number to decimal (string, return ref to array)
+ my ($c,$bs) = @_;
+
+ # instead of converting X (8) bit at a time, it is faster to "convert" the
+ # number to hex, and then call _from_hex.
+
+ my $hs = $bs;
+ $hs =~ s/^[+-]?0b//; # remove sign and 0b
+ my $l = length($hs); # bits
+ $hs = '0' x (8-($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0
+ my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex
+
+ $c->_from_hex($h);
+ }
+
+##############################################################################
+# special modulus functions
+
+sub _modinv
+ {
+ # modular inverse
+ my ($c,$x,$y) = @_;
+
+ my $u = _zero($c); my $u1 = _one($c);
+ my $a = _copy($c,$y); my $b = _copy($c,$x);
+
+ # Euclid's Algorithm for bgcd(), only that we calc bgcd() ($a) and the
+ # result ($u) at the same time. See comments in BigInt for why this works.
+ my $q;
+ ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1
+ my $sign = 1;
+ while (!_is_zero($c,$b))
+ {
+ my $t = _add($c, # step 2:
+ _mul($c,_copy($c,$u1), $q) , # t = u1 * q
+ $u ); # + u
+ $u = $u1; # u = u1, u1 = t
+ $u1 = $t;
+ $sign = -$sign;
+ ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1
+ }
+
+ # if the gcd is not 1, then return NaN
+ return (undef,undef) unless _is_one($c,$a);
+
+ ($u1, $sign == 1 ? '+' : '-');
+ }
+
+sub _modpow
+ {
+ # modulus of power ($x ** $y) % $z
+ my ($c,$num,$exp,$mod) = @_;
+
+ # in the trivial case,
+ if (_is_one($c,$mod))
+ {
+ splice @$num,0,1; $num->[0] = 0;
+ return $num;
+ }
+ if ((scalar @$num == 1) && (($num->[0] == 0) || ($num->[0] == 1)))
+ {
+ $num->[0] = 1;
+ return $num;
+ }
+
+# $num = _mod($c,$num,$mod); # this does not make it faster
+
+ my $acc = _copy($c,$num); my $t = _one();
+
+ my $expbin = _as_bin($c,$exp); $expbin =~ s/^0b//;
+ my $len = length($expbin);
+ while (--$len >= 0)
+ {
+ if ( substr($expbin,$len,1) eq '1') # is_odd
+ {
+ _mul($c,$t,$acc);
+ $t = _mod($c,$t,$mod);
+ }
+ _mul($c,$acc,$acc);
+ $acc = _mod($c,$acc,$mod);
+ }
+ @$num = @$t;
+ $num;
+ }
+
+sub _gcd
+ {
+ # greatest common divisor
+ my ($c,$x,$y) = @_;
+
+ while ( (scalar @$y != 1) || ($y->[0] != 0) ) # while ($y != 0)
+ {
+ my $t = _copy($c,$y);
+ $y = _mod($c, $x, $y);
+ $x = $t;
+ }
+ $x;
+ }
+
+##############################################################################
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigInt::Calc - Pure Perl module to support Math::BigInt
+
+=head1 SYNOPSIS
+
+Provides support for big integer calculations. Not intended to be used by other
+modules. Other modules which sport the same functions can also be used to support
+Math::BigInt, like Math::BigInt::GMP or Math::BigInt::Pari.
+
+=head1 DESCRIPTION
+
+In order to allow for multiple big integer libraries, Math::BigInt was
+rewritten to use library modules for core math routines. Any module which
+follows the same API as this can be used instead by using the following:
+
+ use Math::BigInt lib => 'libname';
+
+'libname' is either the long name ('Math::BigInt::Pari'), or only the short
+version like 'Pari'.
+
+=head1 STORAGE
+
+=head1 METHODS
+
+The following functions MUST be defined in order to support the use by
+Math::BigInt v1.70 or later:
+
+ api_version() return API version, 1 for v1.70, 2 for v1.83
+ _new(string) return ref to new object from ref to decimal string
+ _zero() return a new object with value 0
+ _one() return a new object with value 1
+ _two() return a new object with value 2
+ _ten() return a new object with value 10
+
+ _str(obj) return ref to a string representing the object
+ _num(obj) returns a Perl integer/floating point number
+ NOTE: because of Perl numeric notation defaults,
+ the _num'ified obj may lose accuracy due to
+ machine-dependent floating point size limitations
+
+ _add(obj,obj) Simple addition of two objects
+ _mul(obj,obj) Multiplication of two objects
+ _div(obj,obj) Division of the 1st object by the 2nd
+ In list context, returns (result,remainder).
+ NOTE: this is integer math, so no
+ fractional part will be returned.
+ The second operand will be not be 0, so no need to
+ check for that.
+ _sub(obj,obj) Simple subtraction of 1 object from another
+ a third, optional parameter indicates that the params
+ are swapped. In this case, the first param needs to
+ be preserved, while you can destroy the second.
+ sub (x,y,1) => return x - y and keep x intact!
+ _dec(obj) decrement object by one (input is guaranteed to be > 0)
+ _inc(obj) increment object by one
+
+
+ _acmp(obj,obj) <=> operator for objects (return -1, 0 or 1)
+
+ _len(obj) returns count of the decimal digits of the object
+ _digit(obj,n) returns the n'th decimal digit of object
+
+ _is_one(obj) return true if argument is 1
+ _is_two(obj) return true if argument is 2
+ _is_ten(obj) return true if argument is 10
+ _is_zero(obj) return true if argument is 0
+ _is_even(obj) return true if argument is even (0,2,4,6..)
+ _is_odd(obj) return true if argument is odd (1,3,5,7..)
+
+ _copy return a ref to a true copy of the object
+
+ _check(obj) check whether internal representation is still intact
+ return 0 for ok, otherwise error message as string
+
+ _from_hex(str) return new object from a hexadecimal string
+ _from_bin(str) return new object from a binary string
+ _from_oct(str) return new object from an octal string
+
+ _as_hex(str) return string containing the value as
+ unsigned hex string, with the '0x' prepended.
+ Leading zeros must be stripped.
+ _as_bin(str) Like as_hex, only as binary string containing only
+ zeros and ones. Leading zeros must be stripped and a
+ '0b' must be prepended.
+
+ _rsft(obj,N,B) shift object in base B by N 'digits' right
+ _lsft(obj,N,B) shift object in base B by N 'digits' left
+
+ _xor(obj1,obj2) XOR (bit-wise) object 1 with object 2
+ Note: XOR, AND and OR pad with zeros if size mismatches
+ _and(obj1,obj2) AND (bit-wise) object 1 with object 2
+ _or(obj1,obj2) OR (bit-wise) object 1 with object 2
+
+ _mod(obj1,obj2) Return remainder of div of the 1st by the 2nd object
+ _sqrt(obj) return the square root of object (truncated to int)
+ _root(obj) return the n'th (n >= 3) root of obj (truncated to int)
+ _fac(obj) return factorial of object 1 (1*2*3*4..)
+ _pow(obj1,obj2) return object 1 to the power of object 2
+ return undef for NaN
+ _zeros(obj) return number of trailing decimal zeros
+ _modinv return inverse modulus
+ _modpow return modulus of power ($x ** $y) % $z
+ _log_int(X,N) calculate integer log() of X in base N
+ X >= 0, N >= 0 (return undef for NaN)
+ returns (RESULT, EXACT) where EXACT is:
+ 1 : result is exactly RESULT
+ 0 : result was truncated to RESULT
+ undef : unknown whether result is exactly RESULT
+ _gcd(obj,obj) return Greatest Common Divisor of two objects
+
+The following functions are REQUIRED for an api_version of 2 or greater:
+
+ _1ex($x) create the number 1Ex where x >= 0
+ _alen(obj) returns approximate count of the decimal digits of the
+ object. This estimate MUST always be greater or equal
+ to what _len() returns.
+ _nok(n,k) calculate n over k (binomial coefficient)
+
+The following functions are optional, and can be defined if the underlying lib
+has a fast way to do them. If undefined, Math::BigInt will use pure Perl (hence
+slow) fallback routines to emulate these:
+
+ _signed_or
+ _signed_and
+ _signed_xor
+
+Input strings come in as unsigned but with prefix (i.e. as '123', '0xabc'
+or '0b1101').
+
+So the library needs only to deal with unsigned big integers. Testing of input
+parameter validity is done by the caller, so you need not worry about
+underflow (f.i. in C<_sub()>, C<_dec()>) nor about division by zero or similar
+cases.
+
+The first parameter can be modified, that includes the possibility that you
+return a reference to a completely different object instead. Although keeping
+the reference and just changing its contents is preferred over creating and
+returning a different reference.
+
+Return values are always references to objects, strings, or true/false for
+comparison routines.
+
+=head1 WRAP YOUR OWN
+
+If you want to port your own favourite c-lib for big numbers to the
+Math::BigInt interface, you can take any of the already existing modules as
+a rough guideline. You should really wrap up the latest BigInt and BigFloat
+testsuites with your module, and replace in them any of the following:
+
+ use Math::BigInt;
+
+by this:
+
+ use Math::BigInt lib => 'yourlib';
+
+This way you ensure that your library really works 100% within Math::BigInt.
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/>
+in late 2000.
+Seperated from BigInt and shaped API with the help of John Peacock.
+
+Fixed, speed-up, streamlined and enhanced by Tels 2001 - 2007.
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigFloat>,
+L<Math::BigInt::GMP>, L<Math::BigInt::FastCalc> and L<Math::BigInt::Pari>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigInt/CalcEmu.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/CalcEmu.pm
new file mode 100755
index 00000000000..79efac67534
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/CalcEmu.pm
@@ -0,0 +1,329 @@
+package Math::BigInt::CalcEmu;
+
+use 5.006002;
+use strict;
+# use warnings; # dont use warnings for older Perls
+use vars qw/$VERSION/;
+
+$VERSION = '0.05';
+
+package Math::BigInt;
+
+# See SYNOPSIS below.
+
+my $CALC_EMU;
+
+BEGIN
+ {
+ $CALC_EMU = Math::BigInt->config()->{'lib'};
+ # register us with MBI to get notified of future lib changes
+ Math::BigInt::_register_callback( __PACKAGE__, sub { $CALC_EMU = $_[0]; } );
+ }
+
+sub __emu_band
+ {
+ my ($self,$x,$y,$sx,$sy,@r) = @_;
+
+ return $x->bzero(@r) if $y->is_zero() || $x->is_zero();
+
+ my $sign = 0; # sign of result
+ $sign = 1 if $sx == -1 && $sy == -1;
+
+ my ($bx,$by);
+
+ if ($sx == -1) # if x is negative
+ {
+ # two's complement: inc and flip all "bits" in $bx
+ $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $bx =~ s/-?0x//;
+ $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $bx = $x->as_hex(); # get binary representation
+ $bx =~ s/-?0x//;
+ $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ if ($sy == -1) # if y is negative
+ {
+ # two's complement: inc and flip all "bits" in $by
+ $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $by =~ s/-?0x//;
+ $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $by = $y->as_hex(); # get binary representation
+ $by =~ s/-?0x//;
+ $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ # now we have bit-strings from X and Y, reverse them for padding
+ $bx = reverse $bx;
+ $by = reverse $by;
+
+ # padd the shorter string
+ my $xx = "\x00"; $xx = "\x0f" if $sx == -1;
+ my $yy = "\x00"; $yy = "\x0f" if $sy == -1;
+ my $diff = CORE::length($bx) - CORE::length($by);
+ if ($diff > 0)
+ {
+ # if $yy eq "\x00", we can cut $bx, otherwise we need to padd $by
+ $by .= $yy x $diff;
+ }
+ elsif ($diff < 0)
+ {
+ # if $xx eq "\x00", we can cut $by, otherwise we need to padd $bx
+ $bx .= $xx x abs($diff);
+ }
+
+ # and the strings together
+ my $r = $bx & $by;
+
+ # and reverse the result again
+ $bx = reverse $r;
+
+ # One of $x or $y was negative, so need to flip bits in the result.
+ # In both cases (one or two of them negative, or both positive) we need
+ # to get the characters back.
+ if ($sign == 1)
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/;
+ }
+ else
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/;
+ }
+
+ # leading zeros will be stripped by _from_hex()
+ $bx = '0x' . $bx;
+ $x->{value} = $CALC_EMU->_from_hex( $bx );
+
+ # calculate sign of result
+ $x->{sign} = '+';
+ $x->{sign} = '-' if $sign == 1 && !$x->is_zero();
+
+ $x->bdec() if $sign == 1;
+
+ $x->round(@r);
+ }
+
+sub __emu_bior
+ {
+ my ($self,$x,$y,$sx,$sy,@r) = @_;
+
+ return $x->round(@r) if $y->is_zero();
+
+ my $sign = 0; # sign of result
+ $sign = 1 if ($sx == -1) || ($sy == -1);
+
+ my ($bx,$by);
+
+ if ($sx == -1) # if x is negative
+ {
+ # two's complement: inc and flip all "bits" in $bx
+ $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $bx =~ s/-?0x//;
+ $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $bx = $x->as_hex(); # get binary representation
+ $bx =~ s/-?0x//;
+ $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ if ($sy == -1) # if y is negative
+ {
+ # two's complement: inc and flip all "bits" in $by
+ $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $by =~ s/-?0x//;
+ $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $by = $y->as_hex(); # get binary representation
+ $by =~ s/-?0x//;
+ $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ # now we have bit-strings from X and Y, reverse them for padding
+ $bx = reverse $bx;
+ $by = reverse $by;
+
+ # padd the shorter string
+ my $xx = "\x00"; $xx = "\x0f" if $sx == -1;
+ my $yy = "\x00"; $yy = "\x0f" if $sy == -1;
+ my $diff = CORE::length($bx) - CORE::length($by);
+ if ($diff > 0)
+ {
+ $by .= $yy x $diff;
+ }
+ elsif ($diff < 0)
+ {
+ $bx .= $xx x abs($diff);
+ }
+
+ # or the strings together
+ my $r = $bx | $by;
+
+ # and reverse the result again
+ $bx = reverse $r;
+
+ # one of $x or $y was negative, so need to flip bits in the result
+ # in both cases (one or two of them negative, or both positive) we need
+ # to get the characters back.
+ if ($sign == 1)
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/;
+ }
+ else
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/;
+ }
+
+ # leading zeros will be stripped by _from_hex()
+ $bx = '0x' . $bx;
+ $x->{value} = $CALC_EMU->_from_hex( $bx );
+
+ # calculate sign of result
+ $x->{sign} = '+';
+ $x->{sign} = '-' if $sign == 1 && !$x->is_zero();
+
+ # if one of X or Y was negative, we need to decrement result
+ $x->bdec() if $sign == 1;
+
+ $x->round(@r);
+ }
+
+sub __emu_bxor
+ {
+ my ($self,$x,$y,$sx,$sy,@r) = @_;
+
+ return $x->round(@r) if $y->is_zero();
+
+ my $sign = 0; # sign of result
+ $sign = 1 if $x->{sign} ne $y->{sign};
+
+ my ($bx,$by);
+
+ if ($sx == -1) # if x is negative
+ {
+ # two's complement: inc and flip all "bits" in $bx
+ $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $bx =~ s/-?0x//;
+ $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $bx = $x->as_hex(); # get binary representation
+ $bx =~ s/-?0x//;
+ $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ if ($sy == -1) # if y is negative
+ {
+ # two's complement: inc and flip all "bits" in $by
+ $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $by =~ s/-?0x//;
+ $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $by = $y->as_hex(); # get binary representation
+ $by =~ s/-?0x//;
+ $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ # now we have bit-strings from X and Y, reverse them for padding
+ $bx = reverse $bx;
+ $by = reverse $by;
+
+ # padd the shorter string
+ my $xx = "\x00"; $xx = "\x0f" if $sx == -1;
+ my $yy = "\x00"; $yy = "\x0f" if $sy == -1;
+ my $diff = CORE::length($bx) - CORE::length($by);
+ if ($diff > 0)
+ {
+ $by .= $yy x $diff;
+ }
+ elsif ($diff < 0)
+ {
+ $bx .= $xx x abs($diff);
+ }
+
+ # xor the strings together
+ my $r = $bx ^ $by;
+
+ # and reverse the result again
+ $bx = reverse $r;
+
+ # one of $x or $y was negative, so need to flip bits in the result
+ # in both cases (one or two of them negative, or both positive) we need
+ # to get the characters back.
+ if ($sign == 1)
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/;
+ }
+ else
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/;
+ }
+
+ # leading zeros will be stripped by _from_hex()
+ $bx = '0x' . $bx;
+ $x->{value} = $CALC_EMU->_from_hex( $bx );
+
+ # calculate sign of result
+ $x->{sign} = '+';
+ $x->{sign} = '-' if $sx != $sy && !$x->is_zero();
+
+ $x->bdec() if $sign == 1;
+
+ $x->round(@r);
+ }
+
+##############################################################################
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigInt::CalcEmu - Emulate low-level math with BigInt code
+
+=head1 SYNOPSIS
+
+ use Math::BigInt::CalcEmu;
+
+=head1 DESCRIPTION
+
+Contains routines that emulate low-level math functions in BigInt, e.g.
+optional routines the low-level math package does not provide on it's own.
+
+Will be loaded on demand and called automatically by BigInt.
+
+Stuff here is really low-priority to optimize, since it is far better to
+implement the operation in the low-level math libary directly, possible even
+using a call to the native lib.
+
+=head1 METHODS
+
+=head2 __emu_bxor
+
+=head2 __emu_band
+
+=head2 __emu_bior
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+(c) Tels http://bloodgate.com 2003, 2004 - based on BigInt code by
+Tels from 2001-2003.
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigFloat>, L<Math::BigInt::BitVect>,
+L<Math::BigInt::GMP> and L<Math::BigInt::Pari>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigInt/FastCalc.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/FastCalc.pm
new file mode 100755
index 00000000000..2b4aea58dc2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/FastCalc.pm
@@ -0,0 +1,125 @@
+package Math::BigInt::FastCalc;
+
+use 5.006;
+use strict;
+# use warnings; # dont use warnings for older Perls
+
+use DynaLoader;
+use Math::BigInt::Calc;
+
+use vars qw/@ISA $VERSION $BASE $BASE_LEN/;
+
+@ISA = qw(DynaLoader);
+
+$VERSION = '0.19';
+
+bootstrap Math::BigInt::FastCalc $VERSION;
+
+##############################################################################
+# global constants, flags and accessory
+
+# announce that we are compatible with MBI v1.70 and up
+sub api_version () { 1; }
+
+BEGIN
+ {
+ # use Calc to override the methods that we do not provide in XS
+
+ for my $method (qw/
+ str
+ add sub mul div
+ rsft lsft
+ mod modpow modinv
+ gcd
+ pow root sqrt log_int fac nok
+ digit check
+ from_hex from_bin from_oct as_hex as_bin as_oct
+ zeros base_len
+ xor or and
+ alen 1ex
+ /)
+ {
+ no strict 'refs';
+ *{'Math::BigInt::FastCalc::_' . $method} = \&{'Math::BigInt::Calc::_' . $method};
+ }
+ my ($AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL);
+
+ # store BASE_LEN and BASE to later pass it to XS code
+ ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL, $BASE) =
+ Math::BigInt::Calc::_base_len();
+
+ }
+
+sub import
+ {
+ _set_XS_BASE($BASE, $BASE_LEN);
+ }
+
+##############################################################################
+##############################################################################
+
+1;
+__END__
+=pod
+
+=head1 NAME
+
+Math::BigInt::FastCalc - Math::BigInt::Calc with some XS for more speed
+
+=head1 SYNOPSIS
+
+Provides support for big integer calculations. Not intended to be used by
+other modules. Other modules which sport the same functions can also be used
+to support Math::BigInt, like L<Math::BigInt::GMP> or L<Math::BigInt::Pari>.
+
+=head1 DESCRIPTION
+
+In order to allow for multiple big integer libraries, Math::BigInt was
+rewritten to use library modules for core math routines. Any module which
+follows the same API as this can be used instead by using the following:
+
+ use Math::BigInt lib => 'libname';
+
+'libname' is either the long name ('Math::BigInt::Pari'), or only the short
+version like 'Pari'. To use this library:
+
+ use Math::BigInt lib => 'FastCalc';
+
+Note that from L<Math::BigInt> v1.76 onwards, FastCalc will be loaded
+automatically, if possible.
+
+=head1 STORAGE
+
+FastCalc works exactly like Calc, in stores the numbers in decimal form,
+chopped into parts.
+
+=head1 METHODS
+
+The following functions are now implemented in FastCalc.xs:
+
+ _is_odd _is_even _is_one _is_zero
+ _is_two _is_ten
+ _zero _one _two _ten
+ _acmp _len _num
+ _inc _dec
+ __strip_zeros _copy
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/>
+in late 2000.
+Seperated from BigInt and shaped API with the help of John Peacock.
+Fixed, sped-up and enhanced by Tels http://bloodgate.com 2001-2003.
+Further streamlining (api_version 1 etc.) by Tels 2004-2007.
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigFloat>,
+L<Math::BigInt::GMP>, L<Math::BigInt::FastCalc> and L<Math::BigInt::Pari>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigInt/GMP.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/GMP.pm
new file mode 100755
index 00000000000..de766fb959f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/GMP.pm
@@ -0,0 +1,157 @@
+###############################################################################
+# core math lib for BigInt, representing big numbers by the GMP library
+
+package Math::BigInt::GMP;
+
+use strict;
+use 5.006002;
+# use warnings; # dont use warnings for older Perls
+
+use vars qw/$VERSION/;
+
+$VERSION = '1.24';
+
+use XSLoader;
+XSLoader::load "Math::BigInt::GMP", $VERSION;
+
+sub import { } # catch and throw away
+sub api_version() { 2; } # we are compatible with MBI v1.83 and up
+
+BEGIN
+ {
+ # both _num and _str just return a string
+ *_str = \&_num;
+ }
+
+##############################################################################
+# Routines not present here are in GMP.xs
+
+sub _digit
+ {
+ # return the nth digit, negative values count backward; this is costly!
+ my ($c,$x,$n) = @_;
+
+ $n++; substr( Math::BigInt::GMP::_num($c,$x), -$n, 1 );
+ }
+
+###############################################################################
+# routine to test internal state for corruptions
+
+sub _check
+ {
+ # no checks yet, pull it out from the test suite
+ my ($x) = $_[1];
+ return "$x is not a reference to Math::BigInt::GMP"
+ if ref($x) ne 'Math::BigInt::GMP';
+ 0;
+ }
+
+sub _log_int
+ {
+ my ($c,$x,$base) = @_;
+
+ # X == 0 => NaN
+ return if _is_zero($c,$x);
+
+ $base = _new($c,2) unless defined $base;
+ $base = _new($c,$base) unless ref $base;
+
+ # BASE 0 or 1 => NaN
+ return if _is_zero($c,$base) || _is_one($c,$base);
+
+ my $cmp = _acmp($c,$x,$base); # X == BASE => 1
+ if ($cmp == 0)
+ {
+ # return one
+ return (_one($c), 1);
+ }
+ # X < BASE
+ if ($cmp < 0)
+ {
+ return (_zero($c),undef);
+ }
+
+ # Compute a guess for the result based on:
+ # $guess = int ( length_in_base_10(X) / ( log(base) / log(10) ) )
+ my $len = _alen($c,$x);
+ my $log = log( _num($c,$base) ) / log(10);
+
+ # calculate now a guess based on the values obtained above:
+ my $x_org = _copy($c,$x);
+
+ # keep the reference to $x, modifying it in place
+ _set($c, $x, int($len / $log) - 1);
+
+ my $trial = _pow ($c, _copy($c, $base), $x);
+ my $a = _acmp($c,$trial,$x_org);
+
+ if ($a == 0)
+ {
+ return ($x,1);
+ }
+ elsif ($a > 0)
+ {
+ # too big, shouldn't happen
+ _div($c,$trial,$base); _dec($c, $x);
+ }
+
+ # find the real result by going forward:
+ my $base_mul = _mul($c, _copy($c,$base), $base);
+ my $two = _two($c);
+
+ while (($a = _acmp($c, $trial, $x_org)) < 0)
+ {
+ _mul($c,$trial,$base_mul); _add($c, $x, $two);
+ }
+
+ my $exact = 1;
+ if ($a > 0)
+ {
+ # overstepped the result
+ _dec($c, $x);
+ _div($c,$trial,$base);
+ $a = _acmp($c,$trial,$x_org);
+ if ($a > 0)
+ {
+ _dec($c, $x);
+ }
+ $exact = 0 if $a != 0;
+ }
+
+ ($x,$exact);
+ }
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+Math::BigInt::GMP - Use the GMP library for Math::BigInt routines
+
+=head1 SYNOPSIS
+
+Provides support for big integer calculations via means of the GMP c-library.
+
+Math::BigInt::GMP now no longer uses Math::GMP, but provides it's own XS layer
+to access the GMP c-library. This cut's out another (perl sub routine) layer
+and also reduces the memory footprint by not loading Math::GMP and Carp at
+all.
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Tels <http://bloodgate.com/> in 2001-2007.
+
+Thanx to Chip Turner for providing Math::GMP, which was inspiring my work.
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigInt::Calc>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigInt/Trace.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/Trace.pm
new file mode 100755
index 00000000000..4733d226343
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigInt/Trace.pm
@@ -0,0 +1,47 @@
+#!/usr/bin/perl -w
+
+package Math::BigInt::Trace;
+
+require 5.005_02;
+use strict;
+
+use Exporter;
+use Math::BigInt;
+use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK
+ $accuracy $precision $round_mode $div_scale);
+
+@ISA = qw(Exporter Math::BigInt);
+
+$VERSION = 0.01;
+
+use overload; # inherit overload from BigInt
+
+# Globals
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+
+sub new
+{
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ my $value = shift;
+ my $a = $accuracy; $a = $_[0] if defined $_[0];
+ my $p = $precision; $p = $_[1] if defined $_[1];
+ my $self = Math::BigInt->new($value,$a,$p,$round_mode);
+ bless $self,$class;
+ print "MBI new '$value' => '$self' (",ref($self),")";
+ return $self;
+}
+
+sub import
+ {
+ print "MBI import ",join(' ',@_);
+ my $self = shift;
+ Math::BigInt::import($self,@_); # need it for subclasses
+# $self->export_to_level(1,$self,@_); # need this ?
+ @_ = ();
+ }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/BigRat.pm b/Master/tlpkg/tlperl.straw/lib/Math/BigRat.pm
new file mode 100755
index 00000000000..2460d1c7d4e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/BigRat.pm
@@ -0,0 +1,2020 @@
+
+#
+# "Tax the rat farms." - Lord Vetinari
+#
+
+# The following hash values are used:
+# sign : +,-,NaN,+inf,-inf
+# _d : denominator
+# _n : numeraotr (value = _n/_d)
+# _a : accuracy
+# _p : precision
+# You should not look at the innards of a BigRat - use the methods for this.
+
+package Math::BigRat;
+
+# anythig older is untested, and unlikely to work
+use 5.006;
+use strict;
+
+use Math::BigFloat;
+use vars qw($VERSION @ISA $upgrade $downgrade
+ $accuracy $precision $round_mode $div_scale $_trap_nan $_trap_inf);
+
+@ISA = qw(Math::BigFloat);
+
+$VERSION = '0.24';
+$VERSION = eval $VERSION;
+
+use overload; # inherit overload from Math::BigFloat
+
+BEGIN
+ {
+ *objectify = \&Math::BigInt::objectify; # inherit this from BigInt
+ *AUTOLOAD = \&Math::BigFloat::AUTOLOAD; # can't inherit AUTOLOAD
+ # we inherit these from BigFloat because currently it is not possible
+ # that MBF has a different $MBI variable than we, because MBF also uses
+ # Math::BigInt::config->('lib'); (there is always only one library loaded)
+ *_e_add = \&Math::BigFloat::_e_add;
+ *_e_sub = \&Math::BigFloat::_e_sub;
+ *as_int = \&as_number;
+ *is_pos = \&is_positive;
+ *is_neg = \&is_negative;
+ }
+
+##############################################################################
+# Global constants and flags. Access these only via the accessor methods!
+
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+$upgrade = undef;
+$downgrade = undef;
+
+# These are internally, and not to be used from the outside at all!
+
+$_trap_nan = 0; # are NaNs ok? set w/ config()
+$_trap_inf = 0; # are infs ok? set w/ config()
+
+# the package we are using for our private parts, defaults to:
+# Math::BigInt->config()->{lib}
+my $MBI = 'Math::BigInt::Calc';
+
+my $nan = 'NaN';
+my $class = 'Math::BigRat';
+
+sub isa
+ {
+ return 0 if $_[1] =~ /^Math::Big(Int|Float)/; # we aren't
+ UNIVERSAL::isa(@_);
+ }
+
+##############################################################################
+
+sub _new_from_float
+ {
+ # turn a single float input into a rational number (like '0.1')
+ my ($self,$f) = @_;
+
+ return $self->bnan() if $f->is_nan();
+ return $self->binf($f->{sign}) if $f->{sign} =~ /^[+-]inf$/;
+
+ $self->{_n} = $MBI->_copy( $f->{_m} ); # mantissa
+ $self->{_d} = $MBI->_one();
+ $self->{sign} = $f->{sign} || '+';
+ if ($f->{_es} eq '-')
+ {
+ # something like Math::BigRat->new('0.1');
+ # 1 / 1 => 1/10
+ $MBI->_lsft ( $self->{_d}, $f->{_e} ,10);
+ }
+ else
+ {
+ # something like Math::BigRat->new('10');
+ # 1 / 1 => 10/1
+ $MBI->_lsft ( $self->{_n}, $f->{_e} ,10) unless
+ $MBI->_is_zero($f->{_e});
+ }
+ $self;
+ }
+
+sub new
+ {
+ # create a Math::BigRat
+ my $class = shift;
+
+ my ($n,$d) = @_;
+
+ my $self = { }; bless $self,$class;
+
+ # input like (BigInt) or (BigFloat):
+ if ((!defined $d) && (ref $n) && (!$n->isa('Math::BigRat')))
+ {
+ if ($n->isa('Math::BigFloat'))
+ {
+ $self->_new_from_float($n);
+ }
+ if ($n->isa('Math::BigInt'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_n} = $MBI->_copy($n->{value}); # "mantissa" = N
+ $self->{_d} = $MBI->_one(); # d => 1
+ $self->{sign} = $n->{sign};
+ }
+ if ($n->isa('Math::BigInt::Lite'))
+ {
+ # TODO: trap NaN, inf
+ $self->{sign} = '+'; $self->{sign} = '-' if $$n < 0;
+ $self->{_n} = $MBI->_new(abs($$n)); # "mantissa" = N
+ $self->{_d} = $MBI->_one(); # d => 1
+ }
+ return $self->bnorm(); # normalize (120/1 => 12/10)
+ }
+
+ # input like (BigInt,BigInt) or (BigLite,BigLite):
+ if (ref($d) && ref($n))
+ {
+ # do N first (for $self->{sign}):
+ if ($n->isa('Math::BigInt'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_n} = $MBI->_copy($n->{value}); # "mantissa" = N
+ $self->{sign} = $n->{sign};
+ }
+ elsif ($n->isa('Math::BigInt::Lite'))
+ {
+ # TODO: trap NaN, inf
+ $self->{sign} = '+'; $self->{sign} = '-' if $$n < 0;
+ $self->{_n} = $MBI->_new(abs($$n)); # "mantissa" = $n
+ }
+ else
+ {
+ require Carp;
+ Carp::croak(ref($n) . " is not a recognized object format for Math::BigRat->new");
+ }
+ # now D:
+ if ($d->isa('Math::BigInt'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_d} = $MBI->_copy($d->{value}); # "mantissa" = D
+ # +/+ or -/- => +, +/- or -/+ => -
+ $self->{sign} = $d->{sign} ne $self->{sign} ? '-' : '+';
+ }
+ elsif ($d->isa('Math::BigInt::Lite'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_d} = $MBI->_new(abs($$d)); # "mantissa" = D
+ my $ds = '+'; $ds = '-' if $$d < 0;
+ # +/+ or -/- => +, +/- or -/+ => -
+ $self->{sign} = $ds ne $self->{sign} ? '-' : '+';
+ }
+ else
+ {
+ require Carp;
+ Carp::croak(ref($d) . " is not a recognized object format for Math::BigRat->new");
+ }
+ return $self->bnorm(); # normalize (120/1 => 12/10)
+ }
+ return $n->copy() if ref $n; # already a BigRat
+
+ if (!defined $n)
+ {
+ $self->{_n} = $MBI->_zero(); # undef => 0
+ $self->{_d} = $MBI->_one();
+ $self->{sign} = '+';
+ return $self;
+ }
+
+ # string input with / delimiter
+ if ($n =~ /\s*\/\s*/)
+ {
+ return $class->bnan() if $n =~ /\/.*\//; # 1/2/3 isn't valid
+ return $class->bnan() if $n =~ /\/\s*$/; # 1/ isn't valid
+ ($n,$d) = split (/\//,$n);
+ # try as BigFloats first
+ if (($n =~ /[\.eE]/) || ($d =~ /[\.eE]/))
+ {
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigFloat::precision = undef;
+
+ # one of them looks like a float
+ my $nf = Math::BigFloat->new($n,undef,undef);
+ $self->{sign} = '+';
+ return $self->bnan() if $nf->is_nan();
+
+ $self->{_n} = $MBI->_copy( $nf->{_m} ); # get mantissa
+
+ # now correct $self->{_n} due to $n
+ my $f = Math::BigFloat->new($d,undef,undef);
+ return $self->bnan() if $f->is_nan();
+ $self->{_d} = $MBI->_copy( $f->{_m} );
+
+ # calculate the difference between nE and dE
+ my $diff_e = $nf->exponent()->bsub( $f->exponent);
+ if ($diff_e->is_negative())
+ {
+ # < 0: mul d with it
+ $MBI->_lsft( $self->{_d}, $MBI->_new( $diff_e->babs()), 10);
+ }
+ elsif (!$diff_e->is_zero())
+ {
+ # > 0: mul n with it
+ $MBI->_lsft( $self->{_n}, $MBI->_new( $diff_e), 10);
+ }
+ }
+ else
+ {
+ # both d and n look like (big)ints
+
+ $self->{sign} = '+'; # no sign => '+'
+ $self->{_n} = undef;
+ $self->{_d} = undef;
+ if ($n =~ /^([+-]?)0*([0-9]+)\z/) # first part ok?
+ {
+ $self->{sign} = $1 || '+'; # no sign => '+'
+ $self->{_n} = $MBI->_new($2 || 0);
+ }
+
+ if ($d =~ /^([+-]?)0*([0-9]+)\z/) # second part ok?
+ {
+ $self->{sign} =~ tr/+-/-+/ if ($1 || '') eq '-'; # negate if second part neg.
+ $self->{_d} = $MBI->_new($2 || 0);
+ }
+
+ if (!defined $self->{_n} || !defined $self->{_d})
+ {
+ $d = Math::BigInt->new($d,undef,undef) unless ref $d;
+ $n = Math::BigInt->new($n,undef,undef) unless ref $n;
+
+ if ($n->{sign} =~ /^[+-]$/ && $d->{sign} =~ /^[+-]$/)
+ {
+ # both parts are ok as integers (wierd things like ' 1e0'
+ $self->{_n} = $MBI->_copy($n->{value});
+ $self->{_d} = $MBI->_copy($d->{value});
+ $self->{sign} = $n->{sign};
+ $self->{sign} =~ tr/+-/-+/ if $d->{sign} eq '-'; # -1/-2 => 1/2
+ return $self->bnorm();
+ }
+
+ $self->{sign} = '+'; # a default sign
+ return $self->bnan() if $n->is_nan() || $d->is_nan();
+
+ # handle inf cases:
+ if ($n->is_inf() || $d->is_inf())
+ {
+ if ($n->is_inf())
+ {
+ return $self->bnan() if $d->is_inf(); # both are inf => NaN
+ my $s = '+'; # '+inf/+123' or '-inf/-123'
+ $s = '-' if substr($n->{sign},0,1) ne $d->{sign};
+ # +-inf/123 => +-inf
+ return $self->binf($s);
+ }
+ # 123/inf => 0
+ return $self->bzero();
+ }
+ }
+ }
+
+ return $self->bnorm();
+ }
+
+ # simple string input
+ if (($n =~ /[\.eE]/) && $n !~ /^0x/)
+ {
+ # looks like a float, quacks like a float, so probably is a float
+ $self->{sign} = 'NaN';
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigFloat::precision = undef;
+ $self->_new_from_float(Math::BigFloat->new($n,undef,undef));
+ }
+ else
+ {
+ # for simple forms, use $MBI directly
+ if ($n =~ /^([+-]?)0*([0-9]+)\z/)
+ {
+ $self->{sign} = $1 || '+';
+ $self->{_n} = $MBI->_new($2 || 0);
+ $self->{_d} = $MBI->_one();
+ }
+ else
+ {
+ my $n = Math::BigInt->new($n,undef,undef);
+ $self->{_n} = $MBI->_copy($n->{value});
+ $self->{_d} = $MBI->_one();
+ $self->{sign} = $n->{sign};
+ return $self->bnan() if $self->{sign} eq 'NaN';
+ return $self->binf($self->{sign}) if $self->{sign} =~ /^[+-]inf$/;
+ }
+ }
+ $self->bnorm();
+ }
+
+sub copy
+ {
+ # if two arguments, the first one is the class to "swallow" subclasses
+ my ($c,$x) = @_;
+
+ if (scalar @_ == 1)
+ {
+ $x = $_[0];
+ $c = ref($x);
+ }
+ return unless ref($x); # only for objects
+
+ my $self = bless {}, $c;
+
+ $self->{sign} = $x->{sign};
+ $self->{_d} = $MBI->_copy($x->{_d});
+ $self->{_n} = $MBI->_copy($x->{_n});
+ $self->{_a} = $x->{_a} if defined $x->{_a};
+ $self->{_p} = $x->{_p} if defined $x->{_p};
+ $self;
+ }
+
+##############################################################################
+
+sub config
+ {
+ # return (later set?) configuration data as hash ref
+ my $class = shift || 'Math::BigRat';
+
+ if (@_ == 1 && ref($_[0]) ne 'HASH')
+ {
+ my $cfg = $class->SUPER::config();
+ return $cfg->{$_[0]};
+ }
+
+ my $cfg = $class->SUPER::config(@_);
+
+ # now we need only to override the ones that are different from our parent
+ $cfg->{class} = $class;
+ $cfg->{with} = $MBI;
+ $cfg;
+ }
+
+##############################################################################
+
+sub bstr
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/) # inf, NaN etc
+ {
+ my $s = $x->{sign}; $s =~ s/^\+//; # +inf => inf
+ return $s;
+ }
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} ne '+'; # '+3/2' => '3/2'
+
+ return $s . $MBI->_str($x->{_n}) if $MBI->_is_one($x->{_d});
+ $s . $MBI->_str($x->{_n}) . '/' . $MBI->_str($x->{_d});
+ }
+
+sub bsstr
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/) # inf, NaN etc
+ {
+ my $s = $x->{sign}; $s =~ s/^\+//; # +inf => inf
+ return $s;
+ }
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} ne '+'; # +3 vs 3
+ $s . $MBI->_str($x->{_n}) . '/' . $MBI->_str($x->{_d});
+ }
+
+sub bnorm
+ {
+ # reduce the number to the shortest form
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ # Both parts must be objects of whatever we are using today.
+ if ( my $c = $MBI->_check($x->{_n}) )
+ {
+ require Carp; Carp::croak ("n did not pass the self-check ($c) in bnorm()");
+ }
+ if ( my $c = $MBI->_check($x->{_d}) )
+ {
+ require Carp; Carp::croak ("d did not pass the self-check ($c) in bnorm()");
+ }
+
+ # no normalize for NaN, inf etc.
+ return $x if $x->{sign} !~ /^[+-]$/;
+
+ # normalize zeros to 0/1
+ if ($MBI->_is_zero($x->{_n}))
+ {
+ $x->{sign} = '+'; # never leave a -0
+ $x->{_d} = $MBI->_one() unless $MBI->_is_one($x->{_d});
+ return $x;
+ }
+
+ return $x if $MBI->_is_one($x->{_d}); # no need to reduce
+
+ # reduce other numbers
+ my $gcd = $MBI->_copy($x->{_n});
+ $gcd = $MBI->_gcd($gcd,$x->{_d});
+
+ if (!$MBI->_is_one($gcd))
+ {
+ $x->{_n} = $MBI->_div($x->{_n},$gcd);
+ $x->{_d} = $MBI->_div($x->{_d},$gcd);
+ }
+ $x;
+ }
+
+##############################################################################
+# sign manipulation
+
+sub bneg
+ {
+ # (BRAT or num_str) return BRAT
+ # negate number or make a negated number from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('bneg');
+
+ # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
+ $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $MBI->_is_zero($x->{_n}));
+ $x;
+ }
+
+##############################################################################
+# special values
+
+sub _bnan
+ {
+ # used by parent class bnan() to initialize number to NaN
+ my $self = shift;
+
+ if ($_trap_nan)
+ {
+ require Carp;
+ my $class = ref($self);
+ # "$self" below will stringify the object, this blows up if $self is a
+ # partial object (happens under trap_nan), so fix it beforehand
+ $self->{_d} = $MBI->_zero() unless defined $self->{_d};
+ $self->{_n} = $MBI->_zero() unless defined $self->{_n};
+ Carp::croak ("Tried to set $self to NaN in $class\::_bnan()");
+ }
+ $self->{_n} = $MBI->_zero();
+ $self->{_d} = $MBI->_zero();
+ }
+
+sub _binf
+ {
+ # used by parent class bone() to initialize number to +inf/-inf
+ my $self = shift;
+
+ if ($_trap_inf)
+ {
+ require Carp;
+ my $class = ref($self);
+ # "$self" below will stringify the object, this blows up if $self is a
+ # partial object (happens under trap_nan), so fix it beforehand
+ $self->{_d} = $MBI->_zero() unless defined $self->{_d};
+ $self->{_n} = $MBI->_zero() unless defined $self->{_n};
+ Carp::croak ("Tried to set $self to inf in $class\::_binf()");
+ }
+ $self->{_n} = $MBI->_zero();
+ $self->{_d} = $MBI->_zero();
+ }
+
+sub _bone
+ {
+ # used by parent class bone() to initialize number to +1/-1
+ my $self = shift;
+ $self->{_n} = $MBI->_one();
+ $self->{_d} = $MBI->_one();
+ }
+
+sub _bzero
+ {
+ # used by parent class bzero() to initialize number to 0
+ my $self = shift;
+ $self->{_n} = $MBI->_zero();
+ $self->{_d} = $MBI->_one();
+ }
+
+##############################################################################
+# mul/add/div etc
+
+sub badd
+ {
+ # add two rational numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ # +inf + +inf => +inf, -inf + -inf => -inf
+ return $x->binf(substr($x->{sign},0,1))
+ if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
+
+ # +inf + -inf or -inf + +inf => NaN
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ # 1 1 gcd(3,4) = 1 1*3 + 1*4 7
+ # - + - = --------- = --
+ # 4 3 4*3 12
+
+ # we do not compute the gcd() here, but simple do:
+ # 5 7 5*3 + 7*4 43
+ # - + - = --------- = --
+ # 4 3 4*3 12
+
+ # and bnorm() will then take care of the rest
+
+ # 5 * 3
+ $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_d});
+
+ # 7 * 4
+ my $m = $MBI->_mul( $MBI->_copy( $y->{_n} ), $x->{_d} );
+
+ # 5 * 3 + 7 * 4
+ ($x->{_n}, $x->{sign}) = _e_add( $x->{_n}, $m, $x->{sign}, $y->{sign});
+
+ # 4 * 3
+ $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_d});
+
+ # normalize result, and possible round
+ $x->bnorm()->round(@r);
+ }
+
+sub bsub
+ {
+ # subtract two rational numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ # flip sign of $x, call badd(), then flip sign of result
+ $x->{sign} =~ tr/+-/-+/
+ unless $x->{sign} eq '+' && $MBI->_is_zero($x->{_n}); # not -0
+ $x->badd($y,@r); # does norm and round
+ $x->{sign} =~ tr/+-/-+/
+ unless $x->{sign} eq '+' && $MBI->_is_zero($x->{_n}); # not -0
+ $x;
+ }
+
+sub bmul
+ {
+ # multiply two rational numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x->bnan() if ($x->{sign} eq 'NaN' || $y->{sign} eq 'NaN');
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ # x== 0 # also: or y == 1 or y == -1
+ return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
+
+ # XXX TODO:
+ # According to Knuth, this can be optimized by doing gcd twice (for d and n)
+ # and reducing in one step. This would save us the bnorm() at the end.
+
+ # 1 2 1 * 2 2 1
+ # - * - = ----- = - = -
+ # 4 3 4 * 3 12 6
+
+ $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_n});
+ $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_d});
+
+ # compute new sign
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
+
+ $x->bnorm()->round(@r);
+ }
+
+sub bdiv
+ {
+ # (dividend: BRAT or num_str, divisor: BRAT or num_str) return
+ # (BRAT,BRAT) (quo,rem) or BRAT (only rem)
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ # x== 0 # also: or y == 1 or y == -1
+ return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
+
+ # XXX TODO: list context, upgrade
+ # According to Knuth, this can be optimized by doing gcd twice (for d and n)
+ # and reducing in one step. This would save us the bnorm() at the end.
+
+ # 1 1 1 3
+ # - / - == - * -
+ # 4 3 4 1
+
+ $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_d});
+ $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_n});
+
+ # compute new sign
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
+
+ $x->bnorm()->round(@r);
+ $x;
+ }
+
+sub bmod
+ {
+ # compute "remainder" (in Perl way) of $x / $y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ return $x if $x->is_zero(); # 0 / 7 = 0, mod 0
+
+ # compute $x - $y * floor($x/$y), keeping the sign of $x
+
+ # copy x to u, make it positive and then do a normal division ($u/$y)
+ my $u = bless { sign => '+' }, $self;
+ $u->{_n} = $MBI->_mul( $MBI->_copy($x->{_n}), $y->{_d} );
+ $u->{_d} = $MBI->_mul( $MBI->_copy($x->{_d}), $y->{_n} );
+
+ # compute floor(u)
+ if (! $MBI->_is_one($u->{_d}))
+ {
+ $u->{_n} = $MBI->_div($u->{_n},$u->{_d}); # 22/7 => 3/1 w/ truncate
+ # no need to set $u->{_d} to 1, since below we set it to $y->{_d} anyway
+ }
+
+ # now compute $y * $u
+ $u->{_d} = $MBI->_copy($y->{_d}); # 1 * $y->{_d}, see floor above
+ $u->{_n} = $MBI->_mul($u->{_n},$y->{_n});
+
+ my $xsign = $x->{sign}; $x->{sign} = '+'; # remember sign and make x positive
+ # compute $x - $u
+ $x->bsub($u);
+ $x->{sign} = $xsign; # put sign back
+
+ $x->bnorm()->round(@r);
+ }
+
+##############################################################################
+# bdec/binc
+
+sub bdec
+ {
+ # decrement value (subtract 1)
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf
+
+ if ($x->{sign} eq '-')
+ {
+ $x->{_n} = $MBI->_add( $x->{_n}, $x->{_d}); # -5/2 => -7/2
+ }
+ else
+ {
+ if ($MBI->_acmp($x->{_n},$x->{_d}) < 0) # n < d?
+ {
+ # 1/3 -- => -2/3
+ $x->{_n} = $MBI->_sub( $MBI->_copy($x->{_d}), $x->{_n});
+ $x->{sign} = '-';
+ }
+ else
+ {
+ $x->{_n} = $MBI->_sub($x->{_n}, $x->{_d}); # 5/2 => 3/2
+ }
+ }
+ $x->bnorm()->round(@r);
+ }
+
+sub binc
+ {
+ # increment value (add 1)
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf
+
+ if ($x->{sign} eq '-')
+ {
+ if ($MBI->_acmp($x->{_n},$x->{_d}) < 0)
+ {
+ # -1/3 ++ => 2/3 (overflow at 0)
+ $x->{_n} = $MBI->_sub( $MBI->_copy($x->{_d}), $x->{_n});
+ $x->{sign} = '+';
+ }
+ else
+ {
+ $x->{_n} = $MBI->_sub($x->{_n}, $x->{_d}); # -5/2 => -3/2
+ }
+ }
+ else
+ {
+ $x->{_n} = $MBI->_add($x->{_n},$x->{_d}); # 5/2 => 7/2
+ }
+ $x->bnorm()->round(@r);
+ }
+
+##############################################################################
+# is_foo methods (the rest is inherited)
+
+sub is_int
+ {
+ # return true if arg (BRAT or num_str) is an integer
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if ($x->{sign} =~ /^[+-]$/) && # NaN and +-inf aren't
+ $MBI->_is_one($x->{_d}); # x/y && y != 1 => no integer
+ 0;
+ }
+
+sub is_zero
+ {
+ # return true if arg (BRAT or num_str) is zero
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if $x->{sign} eq '+' && $MBI->_is_zero($x->{_n});
+ 0;
+ }
+
+sub is_one
+ {
+ # return true if arg (BRAT or num_str) is +1 or -1 if signis given
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ my $sign = $_[2] || ''; $sign = '+' if $sign ne '-';
+ return 1
+ if ($x->{sign} eq $sign && $MBI->_is_one($x->{_n}) && $MBI->_is_one($x->{_d}));
+ 0;
+ }
+
+sub is_odd
+ {
+ # return true if arg (BFLOAT or num_str) is odd or false if even
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if ($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't
+ ($MBI->_is_one($x->{_d}) && $MBI->_is_odd($x->{_n})); # x/2 is not, but 3/1
+ 0;
+ }
+
+sub is_even
+ {
+ # return true if arg (BINT or num_str) is even or false if odd
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
+ return 1 if ($MBI->_is_one($x->{_d}) # x/3 is never
+ && $MBI->_is_even($x->{_n})); # but 4/1 is
+ 0;
+ }
+
+##############################################################################
+# parts() and friends
+
+sub numerator
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ # NaN, inf, -inf
+ return Math::BigInt->new($x->{sign}) if ($x->{sign} !~ /^[+-]$/);
+
+ my $n = Math::BigInt->new($MBI->_str($x->{_n})); $n->{sign} = $x->{sign};
+ $n;
+ }
+
+sub denominator
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ # NaN
+ return Math::BigInt->new($x->{sign}) if $x->{sign} eq 'NaN';
+ # inf, -inf
+ return Math::BigInt->bone() if $x->{sign} !~ /^[+-]$/;
+
+ Math::BigInt->new($MBI->_str($x->{_d}));
+ }
+
+sub parts
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ my $c = 'Math::BigInt';
+
+ return ($c->bnan(),$c->bnan()) if $x->{sign} eq 'NaN';
+ return ($c->binf(),$c->binf()) if $x->{sign} eq '+inf';
+ return ($c->binf('-'),$c->binf()) if $x->{sign} eq '-inf';
+
+ my $n = $c->new( $MBI->_str($x->{_n}));
+ $n->{sign} = $x->{sign};
+ my $d = $c->new( $MBI->_str($x->{_d}));
+ ($n,$d);
+ }
+
+sub length
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $nan unless $x->is_int();
+ $MBI->_len($x->{_n}); # length(-123/1) => length(123)
+ }
+
+sub digit
+ {
+ my ($self,$x,$n) = ref($_[0]) ? (undef,$_[0],$_[1]) : objectify(1,@_);
+
+ return $nan unless $x->is_int();
+ $MBI->_digit($x->{_n},$n || 0); # digit(-123/1,2) => digit(123,2)
+ }
+
+##############################################################################
+# special calc routines
+
+sub bceil
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/ || # not for NaN, inf
+ $MBI->_is_one($x->{_d}); # 22/1 => 22, 0/1 => 0
+
+ $x->{_n} = $MBI->_div($x->{_n},$x->{_d}); # 22/7 => 3/1 w/ truncate
+ $x->{_d} = $MBI->_one(); # d => 1
+ $x->{_n} = $MBI->_inc($x->{_n})
+ if $x->{sign} eq '+'; # +22/7 => 4/1
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_n}); # -0 => 0
+ $x;
+ }
+
+sub bfloor
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/ || # not for NaN, inf
+ $MBI->_is_one($x->{_d}); # 22/1 => 22, 0/1 => 0
+
+ $x->{_n} = $MBI->_div($x->{_n},$x->{_d}); # 22/7 => 3/1 w/ truncate
+ $x->{_d} = $MBI->_one(); # d => 1
+ $x->{_n} = $MBI->_inc($x->{_n})
+ if $x->{sign} eq '-'; # -22/7 => -4/1
+ $x;
+ }
+
+sub bfac
+ {
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ # if $x is not an integer
+ if (($x->{sign} ne '+') || (!$MBI->_is_one($x->{_d})))
+ {
+ return $x->bnan();
+ }
+
+ $x->{_n} = $MBI->_fac($x->{_n});
+ # since _d is 1, we don't need to reduce/norm the result
+ $x->round(@r);
+ }
+
+sub bpow
+ {
+ # power ($x ** $y)
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->{sign} =~ /^[+-]inf$/; # -inf/+inf ** x
+ return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
+ return $x->bone(@r) if $y->is_zero();
+ return $x->round(@r) if $x->is_one() || $y->is_one();
+
+ if ($x->{sign} eq '-' && $MBI->_is_one($x->{_n}) && $MBI->_is_one($x->{_d}))
+ {
+ # if $x == -1 and odd/even y => +1/-1
+ return $y->is_odd() ? $x->round(@r) : $x->babs()->round(@r);
+ # my Casio FX-5500L has a bug here: -1 ** 2 is -1, but -1 * -1 is 1;
+ }
+ # 1 ** -y => 1 / (1 ** |y|)
+ # so do test for negative $y after above's clause
+
+ return $x->round(@r) if $x->is_zero(); # 0**y => 0 (if not y <= 0)
+
+ # shortcut if y == 1/N (is then sqrt() respective broot())
+ if ($MBI->_is_one($y->{_n}))
+ {
+ return $x->bsqrt(@r) if $MBI->_is_two($y->{_d}); # 1/2 => sqrt
+ return $x->broot($MBI->_str($y->{_d}),@r); # 1/N => root(N)
+ }
+
+ # shortcut y/1 (and/or x/1)
+ if ($MBI->_is_one($y->{_d}))
+ {
+ # shortcut for x/1 and y/1
+ if ($MBI->_is_one($x->{_d}))
+ {
+ $x->{_n} = $MBI->_pow($x->{_n},$y->{_n}); # x/1 ** y/1 => (x ** y)/1
+ if ($y->{sign} eq '-')
+ {
+ # 0.2 ** -3 => 1/(0.2 ** 3)
+ ($x->{_n},$x->{_d}) = ($x->{_d},$x->{_n}); # swap
+ }
+ # correct sign; + ** + => +
+ if ($x->{sign} eq '-')
+ {
+ # - * - => +, - * - * - => -
+ $x->{sign} = '+' if $MBI->_is_even($y->{_n});
+ }
+ return $x->round(@r);
+ }
+ # x/z ** y/1
+ $x->{_n} = $MBI->_pow($x->{_n},$y->{_n}); # 5/2 ** y/1 => 5 ** y / 2 ** y
+ $x->{_d} = $MBI->_pow($x->{_d},$y->{_n});
+ if ($y->{sign} eq '-')
+ {
+ # 0.2 ** -3 => 1/(0.2 ** 3)
+ ($x->{_n},$x->{_d}) = ($x->{_d},$x->{_n}); # swap
+ }
+ # correct sign; + ** + => +
+ if ($x->{sign} eq '-')
+ {
+ # - * - => +, - * - * - => -
+ $x->{sign} = '+' if $MBI->_is_even($y->{_n});
+ }
+ return $x->round(@r);
+ }
+
+# print STDERR "# $x $y\n";
+
+ # otherwise:
+
+ # n/d n ______________
+ # a/b = -\/ (a/b) ** d
+
+ # (a/b) ** n == (a ** n) / (b ** n)
+ $MBI->_pow($x->{_n}, $y->{_n} );
+ $MBI->_pow($x->{_d}, $y->{_n} );
+
+ return $x->broot($MBI->_str($y->{_d}),@r); # n/d => root(n)
+ }
+
+sub blog
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,$class,@_);
+ }
+
+ # blog(1,Y) => 0
+ return $x->bzero() if $x->is_one() && $y->{sign} eq '+';
+
+ # $x <= 0 => NaN
+ return $x->bnan() if $x->is_zero() || $x->{sign} ne '+' || $y->{sign} ne '+';
+
+ if ($x->is_int() && $y->is_int())
+ {
+ return $self->new($x->as_number()->blog($y->as_number(),@r));
+ }
+
+ # do it with floats
+ $x->_new_from_float( $x->_as_float()->blog(Math::BigFloat->new("$y"),@r) );
+ }
+
+sub bexp
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,$class,@_);
+ }
+
+ return $x->binf(@r) if $x->{sign} eq '+inf';
+ return $x->bzero(@r) if $x->{sign} eq '-inf';
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # also takes care of the "error in _find_round_parameters?" case
+ return $x if $x->{sign} eq 'NaN';
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # P = undef
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it's not enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ return $x->bone(@params) if $x->is_zero();
+
+ # See the comments in Math::BigFloat on how this algorithm works.
+ # Basically we calculate A and B (where B is faculty(N)) so that A/B = e
+
+ my $x_org = $x->copy();
+ if ($scale <= 75)
+ {
+ # set $x directly from a cached string form
+ $x->{_n} = $MBI->_new("90933395208605785401971970164779391644753259799242");
+ $x->{_d} = $MBI->_new("33452526613163807108170062053440751665152000000000");
+ $x->{sign} = '+';
+ }
+ else
+ {
+ # compute A and B so that e = A / B.
+
+ # After some terms we end up with this, so we use it as a starting point:
+ my $A = $MBI->_new("90933395208605785401971970164779391644753259799242");
+ my $F = $MBI->_new(42); my $step = 42;
+
+ # Compute how many steps we need to take to get $A and $B sufficiently big
+ my $steps = Math::BigFloat::_len_to_steps($scale - 4);
+# print STDERR "# Doing $steps steps for ", $scale-4, " digits\n";
+ while ($step++ <= $steps)
+ {
+ # calculate $a * $f + 1
+ $A = $MBI->_mul($A, $F);
+ $A = $MBI->_inc($A);
+ # increment f
+ $F = $MBI->_inc($F);
+ }
+ # compute $B as factorial of $steps (this is faster than doing it manually)
+ my $B = $MBI->_fac($MBI->_new($steps));
+
+# print "A ", $MBI->_str($A), "\nB ", $MBI->_str($B), "\n";
+
+ $x->{_n} = $A;
+ $x->{_d} = $B;
+ $x->{sign} = '+';
+ }
+
+ # $x contains now an estimate of e, with some surplus digits, so we can round
+ if (!$x_org->is_one())
+ {
+ # raise $x to the wanted power and round it in one step:
+ $x->bpow($x_org, @params);
+ }
+ else
+ {
+ # else just round the already computed result
+ delete $x->{_a}; delete $x->{_p};
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+
+ $x;
+ }
+
+sub bnok
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,$class,@_);
+ }
+
+ # do it with floats
+ $x->_new_from_float( $x->_as_float()->bnok(Math::BigFloat->new("$y"),@r) );
+ }
+
+sub _float_from_part
+ {
+ my $x = shift;
+
+ my $f = Math::BigFloat->bzero();
+ $f->{_m} = $MBI->_copy($x);
+ $f->{_e} = $MBI->_zero();
+
+ $f;
+ }
+
+sub _as_float
+ {
+ my $x = shift;
+
+ local $Math::BigFloat::upgrade = undef;
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigFloat::precision = undef;
+ # 22/7 => 3.142857143..
+
+ my $a = $x->accuracy() || 0;
+ if ($a != 0 || !$MBI->_is_one($x->{_d}))
+ {
+ # n/d
+ return scalar Math::BigFloat->new($x->{sign} . $MBI->_str($x->{_n}))->bdiv( $MBI->_str($x->{_d}), $x->accuracy());
+ }
+ # just n
+ Math::BigFloat->new($x->{sign} . $MBI->_str($x->{_n}));
+ }
+
+sub broot
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ if ($x->is_int() && $y->is_int())
+ {
+ return $self->new($x->as_number()->broot($y->as_number(),@r));
+ }
+
+ # do it with floats
+ $x->_new_from_float( $x->_as_float()->broot($y->_as_float(),@r) )->bnorm()->bround(@r);
+ }
+
+sub bmodpow
+ {
+ # set up parameters
+ my ($self,$x,$y,$m,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$m,@r) = objectify(3,@_);
+ }
+
+ # $x or $y or $m are NaN or +-inf => NaN
+ return $x->bnan()
+ if $x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/ ||
+ $m->{sign} !~ /^[+-]$/;
+
+ if ($x->is_int() && $y->is_int() && $m->is_int())
+ {
+ return $self->new($x->as_number()->bmodpow($y->as_number(),$m,@r));
+ }
+
+ warn ("bmodpow() not fully implemented");
+ $x->bnan();
+ }
+
+sub bmodinv
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ # $x or $y are NaN or +-inf => NaN
+ return $x->bnan()
+ if $x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/;
+
+ if ($x->is_int() && $y->is_int())
+ {
+ return $self->new($x->as_number()->bmodinv($y->as_number(),@r));
+ }
+
+ warn ("bmodinv() not fully implemented");
+ $x->bnan();
+ }
+
+sub bsqrt
+ {
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x->bnan() if $x->{sign} !~ /^[+]/; # NaN, -inf or < 0
+ return $x if $x->{sign} eq '+inf'; # sqrt(inf) == inf
+ return $x->round(@r) if $x->is_zero() || $x->is_one();
+
+ local $Math::BigFloat::upgrade = undef;
+ local $Math::BigFloat::downgrade = undef;
+ local $Math::BigFloat::precision = undef;
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigInt::upgrade = undef;
+ local $Math::BigInt::precision = undef;
+ local $Math::BigInt::accuracy = undef;
+
+ $x->{_n} = _float_from_part( $x->{_n} )->bsqrt();
+ $x->{_d} = _float_from_part( $x->{_d} )->bsqrt();
+
+ # XXX TODO: we probably can optimze this:
+
+ # if sqrt(D) was not integer
+ if ($x->{_d}->{_es} ne '+')
+ {
+ $x->{_n}->blsft($x->{_d}->exponent()->babs(),10); # 7.1/4.51 => 7.1/45.1
+ $x->{_d} = $MBI->_copy( $x->{_d}->{_m} ); # 7.1/45.1 => 71/45.1
+ }
+ # if sqrt(N) was not integer
+ if ($x->{_n}->{_es} ne '+')
+ {
+ $x->{_d}->blsft($x->{_n}->exponent()->babs(),10); # 71/45.1 => 710/45.1
+ $x->{_n} = $MBI->_copy( $x->{_n}->{_m} ); # 710/45.1 => 710/451
+ }
+
+ # convert parts to $MBI again
+ $x->{_n} = $MBI->_lsft( $MBI->_copy( $x->{_n}->{_m} ), $x->{_n}->{_e}, 10)
+ if ref($x->{_n}) ne $MBI && ref($x->{_n}) ne 'ARRAY';
+ $x->{_d} = $MBI->_lsft( $MBI->_copy( $x->{_d}->{_m} ), $x->{_d}->{_e}, 10)
+ if ref($x->{_d}) ne $MBI && ref($x->{_d}) ne 'ARRAY';
+
+ $x->bnorm()->round(@r);
+ }
+
+sub blsft
+ {
+ my ($self,$x,$y,$b,@r) = objectify(3,@_);
+
+ $b = 2 unless defined $b;
+ $b = $self->new($b) unless ref ($b);
+ $x->bmul( $b->copy()->bpow($y), @r);
+ $x;
+ }
+
+sub brsft
+ {
+ my ($self,$x,$y,$b,@r) = objectify(3,@_);
+
+ $b = 2 unless defined $b;
+ $b = $self->new($b) unless ref ($b);
+ $x->bdiv( $b->copy()->bpow($y), @r);
+ $x;
+ }
+
+##############################################################################
+# round
+
+sub round
+ {
+ $_[0];
+ }
+
+sub bround
+ {
+ $_[0];
+ }
+
+sub bfround
+ {
+ $_[0];
+ }
+
+##############################################################################
+# comparing
+
+sub bcmp
+ {
+ # compare two signed numbers
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
+ return +1 if $x->{sign} eq '+inf';
+ return -1 if $x->{sign} eq '-inf';
+ return -1 if $y->{sign} eq '+inf';
+ return +1;
+ }
+ # check sign for speed first
+ return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
+ return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
+
+ # shortcut
+ my $xz = $MBI->_is_zero($x->{_n});
+ my $yz = $MBI->_is_zero($y->{_n});
+ return 0 if $xz && $yz; # 0 <=> 0
+ return -1 if $xz && $y->{sign} eq '+'; # 0 <=> +y
+ return 1 if $yz && $x->{sign} eq '+'; # +x <=> 0
+
+ my $t = $MBI->_mul( $MBI->_copy($x->{_n}), $y->{_d});
+ my $u = $MBI->_mul( $MBI->_copy($y->{_n}), $x->{_d});
+
+ my $cmp = $MBI->_acmp($t,$u); # signs are equal
+ $cmp = -$cmp if $x->{sign} eq '-'; # both are '-' => reverse
+ $cmp;
+ }
+
+sub bacmp
+ {
+ # compare two numbers (as unsigned)
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,$class,@_);
+ }
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
+ return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
+ return -1;
+ }
+
+ my $t = $MBI->_mul( $MBI->_copy($x->{_n}), $y->{_d});
+ my $u = $MBI->_mul( $MBI->_copy($y->{_n}), $x->{_d});
+ $MBI->_acmp($t,$u); # ignore signs
+ }
+
+##############################################################################
+# output conversation
+
+sub numify
+ {
+ # convert 17/8 => float (aka 2.125)
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, NaN, etc
+
+ # N/1 => N
+ my $neg = ''; $neg = '-' if $x->{sign} eq '-';
+ return $neg . $MBI->_num($x->{_n}) if $MBI->_is_one($x->{_d});
+
+ $x->_as_float()->numify() + 0.0;
+ }
+
+sub as_number
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ # NaN, inf etc
+ return Math::BigInt->new($x->{sign}) if $x->{sign} !~ /^[+-]$/;
+
+ my $u = Math::BigInt->bzero();
+ $u->{sign} = $x->{sign};
+ $u->{value} = $MBI->_div( $MBI->_copy($x->{_n}), $x->{_d}); # 22/7 => 3
+ $u;
+ }
+
+sub as_float
+ {
+ # return N/D as Math::BigFloat
+
+ # set up parameters
+ my ($self,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ ($self,$x,@r) = objectify(1,$class,@_) unless ref $_[0];
+
+ # NaN, inf etc
+ return Math::BigFloat->new($x->{sign}) if $x->{sign} !~ /^[+-]$/;
+
+ my $u = Math::BigFloat->bzero();
+ $u->{sign} = $x->{sign};
+ # n
+ $u->{_m} = $MBI->_copy($x->{_n});
+ $u->{_e} = $MBI->_zero();
+ $u->bdiv( $MBI->_str($x->{_d}), @r);
+ # return $u
+ $u;
+ }
+
+sub as_bin
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x unless $x->is_int();
+
+ my $s = $x->{sign}; $s = '' if $s eq '+';
+ $s . $MBI->_as_bin($x->{_n});
+ }
+
+sub as_hex
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x unless $x->is_int();
+
+ my $s = $x->{sign}; $s = '' if $s eq '+';
+ $s . $MBI->_as_hex($x->{_n});
+ }
+
+sub as_oct
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x unless $x->is_int();
+
+ my $s = $x->{sign}; $s = '' if $s eq '+';
+ $s . $MBI->_as_oct($x->{_n});
+ }
+
+##############################################################################
+
+sub from_hex
+ {
+ my $class = shift;
+
+ $class->new(@_);
+ }
+
+sub from_bin
+ {
+ my $class = shift;
+
+ $class->new(@_);
+ }
+
+sub from_oct
+ {
+ my $class = shift;
+
+ my @parts;
+ for my $c (@_)
+ {
+ push @parts, Math::BigInt->from_oct($c);
+ }
+ $class->new ( @parts );
+ }
+
+##############################################################################
+# import
+
+sub import
+ {
+ my $self = shift;
+ my $l = scalar @_;
+ my $lib = ''; my @a;
+ my $try = 'try';
+
+ for ( my $i = 0; $i < $l ; $i++)
+ {
+ if ( $_[$i] eq ':constant' )
+ {
+ # this rest causes overlord er load to step in
+ overload::constant float => sub { $self->new(shift); };
+ }
+# elsif ($_[$i] eq 'upgrade')
+# {
+# # this causes upgrading
+# $upgrade = $_[$i+1]; # or undef to disable
+# $i++;
+# }
+ elsif ($_[$i] eq 'downgrade')
+ {
+ # this causes downgrading
+ $downgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] =~ /^(lib|try|only)\z/)
+ {
+ $lib = $_[$i+1] || ''; # default Calc
+ $try = $1; # lib, try or only
+ $i++;
+ }
+ elsif ($_[$i] eq 'with')
+ {
+ # this argument is no longer used
+ #$MBI = $_[$i+1] || 'Math::BigInt::Calc'; # default Math::BigInt::Calc
+ $i++;
+ }
+ else
+ {
+ push @a, $_[$i];
+ }
+ }
+ require Math::BigInt;
+
+ # let use Math::BigInt lib => 'GMP'; use Math::BigRat; still have GMP
+ if ($lib ne '')
+ {
+ my @c = split /\s*,\s*/, $lib;
+ foreach (@c)
+ {
+ $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters
+ }
+ $lib = join(",", @c);
+ }
+ my @import = ('objectify');
+ push @import, $try => $lib if $lib ne '';
+
+ # MBI already loaded, so feed it our lib arguments
+ Math::BigInt->import( @import );
+
+ $MBI = Math::BigFloat->config()->{lib};
+
+ # register us with MBI to get notified of future lib changes
+ Math::BigInt::_register_callback( $self, sub { $MBI = $_[0]; } );
+
+ # any non :constant stuff is handled by our parent, Exporter (loaded
+ # by Math::BigFloat, even if @_ is empty, to give it a chance
+ $self->SUPER::import(@a); # for subclasses
+ $self->export_to_level(1,$self,@a); # need this, too
+ }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Math::BigRat - Arbitrary big rational numbers
+
+=head1 SYNOPSIS
+
+ use Math::BigRat;
+
+ my $x = Math::BigRat->new('3/7'); $x += '5/9';
+
+ print $x->bstr(),"\n";
+ print $x ** 2,"\n";
+
+ my $y = Math::BigRat->new('inf');
+ print "$y ", ($y->is_inf ? 'is' : 'is not') , " infinity\n";
+
+ my $z = Math::BigRat->new(144); $z->bsqrt();
+
+=head1 DESCRIPTION
+
+Math::BigRat complements Math::BigInt and Math::BigFloat by providing support
+for arbitrary big rational numbers.
+
+=head2 MATH LIBRARY
+
+You can change the underlying module that does the low-level
+math operations by using:
+
+ use Math::BigRat try => 'GMP';
+
+Note: This needs Math::BigInt::GMP installed.
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use Math::BigRat try => 'Foo,Math::BigInt::Bar';
+
+If you want to get warned when the fallback occurs, replace "try" with
+"lib":
+
+ use Math::BigRat lib => 'Foo,Math::BigInt::Bar';
+
+If you want the code to die instead, replace "try" with
+"only":
+
+ use Math::BigRat only => 'Foo,Math::BigInt::Bar';
+
+=head1 METHODS
+
+Any methods not listed here are derived from Math::BigFloat (or
+Math::BigInt), so make sure you check these two modules for further
+information.
+
+=head2 new()
+
+ $x = Math::BigRat->new('1/3');
+
+Create a new Math::BigRat object. Input can come in various forms:
+
+ $x = Math::BigRat->new(123); # scalars
+ $x = Math::BigRat->new('inf'); # infinity
+ $x = Math::BigRat->new('123.3'); # float
+ $x = Math::BigRat->new('1/3'); # simple string
+ $x = Math::BigRat->new('1 / 3'); # spaced
+ $x = Math::BigRat->new('1 / 0.1'); # w/ floats
+ $x = Math::BigRat->new(Math::BigInt->new(3)); # BigInt
+ $x = Math::BigRat->new(Math::BigFloat->new('3.1')); # BigFloat
+ $x = Math::BigRat->new(Math::BigInt::Lite->new('2')); # BigLite
+
+ # You can also give D and N as different objects:
+ $x = Math::BigRat->new(
+ Math::BigInt->new(-123),
+ Math::BigInt->new(7),
+ ); # => -123/7
+
+=head2 numerator()
+
+ $n = $x->numerator();
+
+Returns a copy of the numerator (the part above the line) as signed BigInt.
+
+=head2 denominator()
+
+ $d = $x->denominator();
+
+Returns a copy of the denominator (the part under the line) as positive BigInt.
+
+=head2 parts()
+
+ ($n,$d) = $x->parts();
+
+Return a list consisting of (signed) numerator and (unsigned) denominator as
+BigInts.
+
+=head2 numify()
+
+ my $y = $x->numify();
+
+Returns the object as a scalar. This will lose some data if the object
+cannot be represented by a normal Perl scalar (integer or float), so
+use L<as_int()> or L<as_float()> instead.
+
+This routine is automatically used whenever a scalar is required:
+
+ my $x = Math::BigRat->new('3/1');
+ @array = (0,1,2,3);
+ $y = $array[$x]; # set $y to 3
+
+=head2 as_int()/as_number()
+
+ $x = Math::BigRat->new('13/7');
+ print $x->as_int(),"\n"; # '1'
+
+Returns a copy of the object as BigInt, truncated to an integer.
+
+C<as_number()> is an alias for C<as_int()>.
+
+=head2 as_float()
+
+ $x = Math::BigRat->new('13/7');
+ print $x->as_float(),"\n"; # '1'
+
+ $x = Math::BigRat->new('2/3');
+ print $x->as_float(5),"\n"; # '0.66667'
+
+Returns a copy of the object as BigFloat, preserving the
+accuracy as wanted, or the default of 40 digits.
+
+This method was added in v0.22 of Math::BigRat (April 2008).
+
+=head2 as_hex()
+
+ $x = Math::BigRat->new('13');
+ print $x->as_hex(),"\n"; # '0xd'
+
+Returns the BigRat as hexadecimal string. Works only for integers.
+
+=head2 as_bin()
+
+ $x = Math::BigRat->new('13');
+ print $x->as_bin(),"\n"; # '0x1101'
+
+Returns the BigRat as binary string. Works only for integers.
+
+=head2 as_oct()
+
+ $x = Math::BigRat->new('13');
+ print $x->as_oct(),"\n"; # '015'
+
+Returns the BigRat as octal string. Works only for integers.
+
+=head2 from_hex()/from_bin()/from_oct()
+
+ my $h = Math::BigRat->from_hex('0x10');
+ my $b = Math::BigRat->from_bin('0b10000000');
+ my $o = Math::BigRat->from_oct('020');
+
+Create a BigRat from an hexadecimal, binary or octal number
+in string form.
+
+=head2 length()
+
+ $len = $x->length();
+
+Return the length of $x in digitis for integer values.
+
+=head2 digit()
+
+ print Math::BigRat->new('123/1')->digit(1); # 1
+ print Math::BigRat->new('123/1')->digit(-1); # 3
+
+Return the N'ths digit from X when X is an integer value.
+
+=head2 bnorm()
+
+ $x->bnorm();
+
+Reduce the number to the shortest form. This routine is called
+automatically whenever it is needed.
+
+=head2 bfac()
+
+ $x->bfac();
+
+Calculates the factorial of $x. For instance:
+
+ print Math::BigRat->new('3/1')->bfac(),"\n"; # 1*2*3
+ print Math::BigRat->new('5/1')->bfac(),"\n"; # 1*2*3*4*5
+
+Works currently only for integers.
+
+=head2 bround()/round()/bfround()
+
+Are not yet implemented.
+
+=head2 bmod()
+
+ use Math::BigRat;
+ my $x = Math::BigRat->new('7/4');
+ my $y = Math::BigRat->new('4/3');
+ print $x->bmod($y);
+
+Set $x to the remainder of the division of $x by $y.
+
+=head2 bneg()
+
+ $x->bneg();
+
+Used to negate the object in-place.
+
+=head2 is_one()
+
+ print "$x is 1\n" if $x->is_one();
+
+Return true if $x is exactly one, otherwise false.
+
+=head2 is_zero()
+
+ print "$x is 0\n" if $x->is_zero();
+
+Return true if $x is exactly zero, otherwise false.
+
+=head2 is_pos()/is_positive()
+
+ print "$x is >= 0\n" if $x->is_positive();
+
+Return true if $x is positive (greater than or equal to zero), otherwise
+false. Please note that '+inf' is also positive, while 'NaN' and '-inf' aren't.
+
+C<is_positive()> is an alias for C<is_pos()>.
+
+=head2 is_neg()/is_negative()
+
+ print "$x is < 0\n" if $x->is_negative();
+
+Return true if $x is negative (smaller than zero), otherwise false. Please
+note that '-inf' is also negative, while 'NaN' and '+inf' aren't.
+
+C<is_negative()> is an alias for C<is_neg()>.
+
+=head2 is_int()
+
+ print "$x is an integer\n" if $x->is_int();
+
+Return true if $x has a denominator of 1 (e.g. no fraction parts), otherwise
+false. Please note that '-inf', 'inf' and 'NaN' aren't integer.
+
+=head2 is_odd()
+
+ print "$x is odd\n" if $x->is_odd();
+
+Return true if $x is odd, otherwise false.
+
+=head2 is_even()
+
+ print "$x is even\n" if $x->is_even();
+
+Return true if $x is even, otherwise false.
+
+=head2 bceil()
+
+ $x->bceil();
+
+Set $x to the next bigger integer value (e.g. truncate the number to integer
+and then increment it by one).
+
+=head2 bfloor()
+
+ $x->bfloor();
+
+Truncate $x to an integer value.
+
+=head2 bsqrt()
+
+ $x->bsqrt();
+
+Calculate the square root of $x.
+
+=head2 broot()
+
+ $x->broot($n);
+
+Calculate the N'th root of $x.
+
+=head2 badd()/bmul()/bsub()/bdiv()/bdec()/binc()
+
+Please see the documentation in L<Math::BigInt>.
+
+=head2 copy()
+
+ my $z = $x->copy();
+
+Makes a deep copy of the object.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 bstr()/bsstr()
+
+ my $x = Math::BigInt->new('8/4');
+ print $x->bstr(),"\n"; # prints 1/2
+ print $x->bsstr(),"\n"; # prints 1/2
+
+Return a string representating this object.
+
+=head2 bacmp()/bcmp()
+
+Used to compare numbers.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 blsft()/brsft()
+
+Used to shift numbers left/right.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 bpow()
+
+ $x->bpow($y);
+
+Compute $x ** $y.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 bexp()
+
+ $x->bexp($accuracy); # calculate e ** X
+
+Calculates two integers A and B so that A/B is equal to C<e ** $x>, where C<e> is
+Euler's number.
+
+This method was added in v0.20 of Math::BigRat (May 2007).
+
+See also L<blog()>.
+
+=head2 bnok()
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+Calculates the binomial coefficient n over k, also called the "choose"
+function. The result is equivalent to:
+
+ ( n ) n!
+ | - | = -------
+ ( k ) k!(n-k)!
+
+This method was added in v0.20 of Math::BigRat (May 2007).
+
+=head2 config()
+
+ use Data::Dumper;
+
+ print Dumper ( Math::BigRat->config() );
+ print Math::BigRat->config()->{lib},"\n";
+
+Returns a hash containing the configuration, e.g. the version number, lib
+loaded etc. The following hash keys are currently filled in with the
+appropriate information.
+
+ key RO/RW Description
+ Example
+ ============================================================
+ lib RO Name of the Math library
+ Math::BigInt::Calc
+ lib_version RO Version of 'lib'
+ 0.30
+ class RO The class of config you just called
+ Math::BigRat
+ version RO version number of the class you used
+ 0.10
+ upgrade RW To which class numbers are upgraded
+ undef
+ downgrade RW To which class numbers are downgraded
+ undef
+ precision RW Global precision
+ undef
+ accuracy RW Global accuracy
+ undef
+ round_mode RW Global round mode
+ even
+ div_scale RW Fallback accuracy for div
+ 40
+ trap_nan RW Trap creation of NaN (undef = no)
+ undef
+ trap_inf RW Trap creation of +inf/-inf (undef = no)
+ undef
+
+By passing a reference to a hash you may set the configuration values. This
+works only for values that a marked with a C<RW> above, anything else is
+read-only.
+
+=head2 objectify()
+
+This is an internal routine that turns scalars into objects.
+
+=head1 BUGS
+
+Some things are not yet implemented, or only implemented half-way:
+
+=over 2
+
+=item inf handling (partial)
+
+=item NaN handling (partial)
+
+=item rounding (not implemented except for bceil/bfloor)
+
+=item $x ** $y where $y is not an integer
+
+=item bmod(), blog(), bmodinv() and bmodpow() (partial)
+
+=back
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Math::BigFloat> and L<Math::Big> as well as L<Math::BigInt::BitVect>,
+L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+See L<http://search.cpan.org/search?dist=bignum> for a way to use
+Math::BigRat.
+
+The package at L<http://search.cpan.org/search?dist=Math%3A%3ABigRat>
+may contain more documentation and examples as well as testcases.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> 2001 - 2009.
+
+Currently maintained by Jonathan "Duke" Leto <jonathan@leto.net> L<http://leto.net>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/Complex.pm b/Master/tlpkg/tlperl.straw/lib/Math/Complex.pm
new file mode 100755
index 00000000000..8475a2b5d09
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/Complex.pm
@@ -0,0 +1,2093 @@
+#
+# Complex numbers and associated mathematical functions
+# -- Raphael Manfredi Since Sep 1996
+# -- Jarkko Hietaniemi Since Mar 1997
+# -- Daniel S. Lewart Since Sep 1997
+#
+
+package Math::Complex;
+
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $Inf $ExpInf);
+
+$VERSION = 1.56;
+
+use Config;
+
+BEGIN {
+ my %DBL_MAX =
+ (
+ 4 => '1.70141183460469229e+38',
+ 8 => '1.7976931348623157e+308',
+ # AFAICT the 10, 12, and 16-byte long doubles
+ # all have the same maximum.
+ 10 => '1.1897314953572317650857593266280070162E+4932',
+ 12 => '1.1897314953572317650857593266280070162E+4932',
+ 16 => '1.1897314953572317650857593266280070162E+4932',
+ );
+ my $nvsize = $Config{nvsize} ||
+ ($Config{uselongdouble} && $Config{longdblsize}) ||
+ $Config{doublesize};
+ die "Math::Complex: Could not figure out nvsize\n"
+ unless defined $nvsize;
+ die "Math::Complex: Cannot not figure out max nv (nvsize = $nvsize)\n"
+ unless defined $DBL_MAX{$nvsize};
+ my $DBL_MAX = eval $DBL_MAX{$nvsize};
+ die "Math::Complex: Could not figure out max nv (nvsize = $nvsize)\n"
+ unless defined $DBL_MAX;
+ my $BIGGER_THAN_THIS = 1e30; # Must find something bigger than this.
+ if ($^O eq 'unicosmk') {
+ $Inf = $DBL_MAX;
+ } else {
+ local $SIG{FPE} = { };
+ local $!;
+ # We do want an arithmetic overflow, Inf INF inf Infinity.
+ for my $t (
+ 'exp(99999)', # Enough even with 128-bit long doubles.
+ 'inf',
+ 'Inf',
+ 'INF',
+ 'infinity',
+ 'Infinity',
+ 'INFINITY',
+ '1e99999',
+ ) {
+ local $^W = 0;
+ my $i = eval "$t+1.0";
+ if (defined $i && $i > $BIGGER_THAN_THIS) {
+ $Inf = $i;
+ last;
+ }
+ }
+ $Inf = $DBL_MAX unless defined $Inf; # Oh well, close enough.
+ die "Math::Complex: Could not get Infinity"
+ unless $Inf > $BIGGER_THAN_THIS;
+ $ExpInf = exp(99999);
+ }
+ # print "# On this machine, Inf = '$Inf'\n";
+}
+
+use Scalar::Util qw(set_prototype);
+
+use warnings;
+no warnings 'syntax'; # To avoid the (_) warnings.
+
+BEGIN {
+ # For certain functions that we override, in 5.10 or better
+ # we can set a smarter prototype that will handle the lexical $_
+ # (also a 5.10+ feature).
+ if ($] >= 5.010000) {
+ set_prototype \&abs, '_';
+ set_prototype \&cos, '_';
+ set_prototype \&exp, '_';
+ set_prototype \&log, '_';
+ set_prototype \&sin, '_';
+ set_prototype \&sqrt, '_';
+ }
+}
+
+my $i;
+my %LOGN;
+
+# Regular expression for floating point numbers.
+# These days we could use Scalar::Util::lln(), I guess.
+my $gre = qr'\s*([\+\-]?(?:(?:(?:\d+(?:_\d+)*(?:\.\d*(?:_\d+)*)?|\.\d+(?:_\d+)*)(?:[eE][\+\-]?\d+(?:_\d+)*)?))|inf)'i;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+
+my @trig = qw(
+ pi
+ tan
+ csc cosec sec cot cotan
+ asin acos atan
+ acsc acosec asec acot acotan
+ sinh cosh tanh
+ csch cosech sech coth cotanh
+ asinh acosh atanh
+ acsch acosech asech acoth acotanh
+ );
+
+@EXPORT = (qw(
+ i Re Im rho theta arg
+ sqrt log ln
+ log10 logn cbrt root
+ cplx cplxe
+ atan2
+ ),
+ @trig);
+
+my @pi = qw(pi pi2 pi4 pip2 pip4 Inf);
+
+@EXPORT_OK = @pi;
+
+%EXPORT_TAGS = (
+ 'trig' => [@trig],
+ 'pi' => [@pi],
+);
+
+use overload
+ '+' => \&_plus,
+ '-' => \&_minus,
+ '*' => \&_multiply,
+ '/' => \&_divide,
+ '**' => \&_power,
+ '==' => \&_numeq,
+ '<=>' => \&_spaceship,
+ 'neg' => \&_negate,
+ '~' => \&_conjugate,
+ 'abs' => \&abs,
+ 'sqrt' => \&sqrt,
+ 'exp' => \&exp,
+ 'log' => \&log,
+ 'sin' => \&sin,
+ 'cos' => \&cos,
+ 'tan' => \&tan,
+ 'atan2' => \&atan2,
+ '""' => \&_stringify;
+
+#
+# Package "privates"
+#
+
+my %DISPLAY_FORMAT = ('style' => 'cartesian',
+ 'polar_pretty_print' => 1);
+my $eps = 1e-14; # Epsilon
+
+#
+# Object attributes (internal):
+# cartesian [real, imaginary] -- cartesian form
+# polar [rho, theta] -- polar form
+# c_dirty cartesian form not up-to-date
+# p_dirty polar form not up-to-date
+# display display format (package's global when not set)
+#
+
+# Die on bad *make() arguments.
+
+sub _cannot_make {
+ die "@{[(caller(1))[3]]}: Cannot take $_[0] of '$_[1]'.\n";
+}
+
+sub _make {
+ my $arg = shift;
+ my ($p, $q);
+
+ if ($arg =~ /^$gre$/) {
+ ($p, $q) = ($1, 0);
+ } elsif ($arg =~ /^(?:$gre)?$gre\s*i\s*$/) {
+ ($p, $q) = ($1 || 0, $2);
+ } elsif ($arg =~ /^\s*\(\s*$gre\s*(?:,\s*$gre\s*)?\)\s*$/) {
+ ($p, $q) = ($1, $2 || 0);
+ }
+
+ if (defined $p) {
+ $p =~ s/^\+//;
+ $p =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ $q =~ s/^\+//;
+ $q =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ }
+
+ return ($p, $q);
+}
+
+sub _emake {
+ my $arg = shift;
+ my ($p, $q);
+
+ if ($arg =~ /^\s*\[\s*$gre\s*(?:,\s*$gre\s*)?\]\s*$/) {
+ ($p, $q) = ($1, $2 || 0);
+ } elsif ($arg =~ m!^\s*\[\s*$gre\s*(?:,\s*([-+]?\d*\s*)?pi(?:/\s*(\d+))?\s*)?\]\s*$!) {
+ ($p, $q) = ($1, ($2 eq '-' ? -1 : ($2 || 1)) * pi() / ($3 || 1));
+ } elsif ($arg =~ /^\s*\[\s*$gre\s*\]\s*$/) {
+ ($p, $q) = ($1, 0);
+ } elsif ($arg =~ /^\s*$gre\s*$/) {
+ ($p, $q) = ($1, 0);
+ }
+
+ if (defined $p) {
+ $p =~ s/^\+//;
+ $q =~ s/^\+//;
+ $p =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ $q =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ }
+
+ return ($p, $q);
+}
+
+#
+# ->make
+#
+# Create a new complex number (cartesian form)
+#
+sub make {
+ my $self = bless {}, shift;
+ my ($re, $im);
+ if (@_ == 0) {
+ ($re, $im) = (0, 0);
+ } elsif (@_ == 1) {
+ return (ref $self)->emake($_[0])
+ if ($_[0] =~ /^\s*\[/);
+ ($re, $im) = _make($_[0]);
+ } elsif (@_ == 2) {
+ ($re, $im) = @_;
+ }
+ if (defined $re) {
+ _cannot_make("real part", $re) unless $re =~ /^$gre$/;
+ }
+ $im ||= 0;
+ _cannot_make("imaginary part", $im) unless $im =~ /^$gre$/;
+ $self->_set_cartesian([$re, $im ]);
+ $self->display_format('cartesian');
+
+ return $self;
+}
+
+#
+# ->emake
+#
+# Create a new complex number (exponential form)
+#
+sub emake {
+ my $self = bless {}, shift;
+ my ($rho, $theta);
+ if (@_ == 0) {
+ ($rho, $theta) = (0, 0);
+ } elsif (@_ == 1) {
+ return (ref $self)->make($_[0])
+ if ($_[0] =~ /^\s*\(/ || $_[0] =~ /i\s*$/);
+ ($rho, $theta) = _emake($_[0]);
+ } elsif (@_ == 2) {
+ ($rho, $theta) = @_;
+ }
+ if (defined $rho && defined $theta) {
+ if ($rho < 0) {
+ $rho = -$rho;
+ $theta = ($theta <= 0) ? $theta + pi() : $theta - pi();
+ }
+ }
+ if (defined $rho) {
+ _cannot_make("rho", $rho) unless $rho =~ /^$gre$/;
+ }
+ $theta ||= 0;
+ _cannot_make("theta", $theta) unless $theta =~ /^$gre$/;
+ $self->_set_polar([$rho, $theta]);
+ $self->display_format('polar');
+
+ return $self;
+}
+
+sub new { &make } # For backward compatibility only.
+
+#
+# cplx
+#
+# Creates a complex number from a (re, im) tuple.
+# This avoids the burden of writing Math::Complex->make(re, im).
+#
+sub cplx {
+ return __PACKAGE__->make(@_);
+}
+
+#
+# cplxe
+#
+# Creates a complex number from a (rho, theta) tuple.
+# This avoids the burden of writing Math::Complex->emake(rho, theta).
+#
+sub cplxe {
+ return __PACKAGE__->emake(@_);
+}
+
+#
+# pi
+#
+# The number defined as pi = 180 degrees
+#
+sub pi () { 4 * CORE::atan2(1, 1) }
+
+#
+# pi2
+#
+# The full circle
+#
+sub pi2 () { 2 * pi }
+
+#
+# pi4
+#
+# The full circle twice.
+#
+sub pi4 () { 4 * pi }
+
+#
+# pip2
+#
+# The quarter circle
+#
+sub pip2 () { pi / 2 }
+
+#
+# pip4
+#
+# The eighth circle.
+#
+sub pip4 () { pi / 4 }
+
+#
+# _uplog10
+#
+# Used in log10().
+#
+sub _uplog10 () { 1 / CORE::log(10) }
+
+#
+# i
+#
+# The number defined as i*i = -1;
+#
+sub i () {
+ return $i if ($i);
+ $i = bless {};
+ $i->{'cartesian'} = [0, 1];
+ $i->{'polar'} = [1, pip2];
+ $i->{c_dirty} = 0;
+ $i->{p_dirty} = 0;
+ return $i;
+}
+
+#
+# _ip2
+#
+# Half of i.
+#
+sub _ip2 () { i / 2 }
+
+#
+# Attribute access/set routines
+#
+
+sub _cartesian {$_[0]->{c_dirty} ?
+ $_[0]->_update_cartesian : $_[0]->{'cartesian'}}
+sub _polar {$_[0]->{p_dirty} ?
+ $_[0]->_update_polar : $_[0]->{'polar'}}
+
+sub _set_cartesian { $_[0]->{p_dirty}++; $_[0]->{c_dirty} = 0;
+ $_[0]->{'cartesian'} = $_[1] }
+sub _set_polar { $_[0]->{c_dirty}++; $_[0]->{p_dirty} = 0;
+ $_[0]->{'polar'} = $_[1] }
+
+#
+# ->_update_cartesian
+#
+# Recompute and return the cartesian form, given accurate polar form.
+#
+sub _update_cartesian {
+ my $self = shift;
+ my ($r, $t) = @{$self->{'polar'}};
+ $self->{c_dirty} = 0;
+ return $self->{'cartesian'} = [$r * CORE::cos($t), $r * CORE::sin($t)];
+}
+
+#
+#
+# ->_update_polar
+#
+# Recompute and return the polar form, given accurate cartesian form.
+#
+sub _update_polar {
+ my $self = shift;
+ my ($x, $y) = @{$self->{'cartesian'}};
+ $self->{p_dirty} = 0;
+ return $self->{'polar'} = [0, 0] if $x == 0 && $y == 0;
+ return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y),
+ CORE::atan2($y, $x)];
+}
+
+#
+# (_plus)
+#
+# Computes z1+z2.
+#
+sub _plus {
+ my ($z1, $z2, $regular) = @_;
+ my ($re1, $im1) = @{$z1->_cartesian};
+ $z2 = cplx($z2) unless ref $z2;
+ my ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ unless (defined $regular) {
+ $z1->_set_cartesian([$re1 + $re2, $im1 + $im2]);
+ return $z1;
+ }
+ return (ref $z1)->make($re1 + $re2, $im1 + $im2);
+}
+
+#
+# (_minus)
+#
+# Computes z1-z2.
+#
+sub _minus {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = @{$z1->_cartesian};
+ $z2 = cplx($z2) unless ref $z2;
+ my ($re2, $im2) = @{$z2->_cartesian};
+ unless (defined $inverted) {
+ $z1->_set_cartesian([$re1 - $re2, $im1 - $im2]);
+ return $z1;
+ }
+ return $inverted ?
+ (ref $z1)->make($re2 - $re1, $im2 - $im1) :
+ (ref $z1)->make($re1 - $re2, $im1 - $im2);
+
+}
+
+#
+# (_multiply)
+#
+# Computes z1*z2.
+#
+sub _multiply {
+ my ($z1, $z2, $regular) = @_;
+ if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) {
+ # if both polar better use polar to avoid rounding errors
+ my ($r1, $t1) = @{$z1->_polar};
+ my ($r2, $t2) = @{$z2->_polar};
+ my $t = $t1 + $t2;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ unless (defined $regular) {
+ $z1->_set_polar([$r1 * $r2, $t]);
+ return $z1;
+ }
+ return (ref $z1)->emake($r1 * $r2, $t);
+ } else {
+ my ($x1, $y1) = @{$z1->_cartesian};
+ if (ref $z2) {
+ my ($x2, $y2) = @{$z2->_cartesian};
+ return (ref $z1)->make($x1*$x2-$y1*$y2, $x1*$y2+$y1*$x2);
+ } else {
+ return (ref $z1)->make($x1*$z2, $y1*$z2);
+ }
+ }
+}
+
+#
+# _divbyzero
+#
+# Die on division by zero.
+#
+sub _divbyzero {
+ my $mess = "$_[0]: Division by zero.\n";
+
+ if (defined $_[1]) {
+ $mess .= "(Because in the definition of $_[0], the divisor ";
+ $mess .= "$_[1] " unless ("$_[1]" eq '0');
+ $mess .= "is 0)\n";
+ }
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# (_divide)
+#
+# Computes z1/z2.
+#
+sub _divide {
+ my ($z1, $z2, $inverted) = @_;
+ if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) {
+ # if both polar better use polar to avoid rounding errors
+ my ($r1, $t1) = @{$z1->_polar};
+ my ($r2, $t2) = @{$z2->_polar};
+ my $t;
+ if ($inverted) {
+ _divbyzero "$z2/0" if ($r1 == 0);
+ $t = $t2 - $t1;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ return (ref $z1)->emake($r2 / $r1, $t);
+ } else {
+ _divbyzero "$z1/0" if ($r2 == 0);
+ $t = $t1 - $t2;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ return (ref $z1)->emake($r1 / $r2, $t);
+ }
+ } else {
+ my ($d, $x2, $y2);
+ if ($inverted) {
+ ($x2, $y2) = @{$z1->_cartesian};
+ $d = $x2*$x2 + $y2*$y2;
+ _divbyzero "$z2/0" if $d == 0;
+ return (ref $z1)->make(($x2*$z2)/$d, -($y2*$z2)/$d);
+ } else {
+ my ($x1, $y1) = @{$z1->_cartesian};
+ if (ref $z2) {
+ ($x2, $y2) = @{$z2->_cartesian};
+ $d = $x2*$x2 + $y2*$y2;
+ _divbyzero "$z1/0" if $d == 0;
+ my $u = ($x1*$x2 + $y1*$y2)/$d;
+ my $v = ($y1*$x2 - $x1*$y2)/$d;
+ return (ref $z1)->make($u, $v);
+ } else {
+ _divbyzero "$z1/0" if $z2 == 0;
+ return (ref $z1)->make($x1/$z2, $y1/$z2);
+ }
+ }
+ }
+}
+
+#
+# (_power)
+#
+# Computes z1**z2 = exp(z2 * log z1)).
+#
+sub _power {
+ my ($z1, $z2, $inverted) = @_;
+ if ($inverted) {
+ return 1 if $z1 == 0 || $z2 == 1;
+ return 0 if $z2 == 0 && Re($z1) > 0;
+ } else {
+ return 1 if $z2 == 0 || $z1 == 1;
+ return 0 if $z1 == 0 && Re($z2) > 0;
+ }
+ my $w = $inverted ? &exp($z1 * &log($z2))
+ : &exp($z2 * &log($z1));
+ # If both arguments cartesian, return cartesian, else polar.
+ return $z1->{c_dirty} == 0 &&
+ (not ref $z2 or $z2->{c_dirty} == 0) ?
+ cplx(@{$w->_cartesian}) : $w;
+}
+
+#
+# (_spaceship)
+#
+# Computes z1 <=> z2.
+# Sorts on the real part first, then on the imaginary part. Thus 2-4i < 3+8i.
+#
+sub _spaceship {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ my ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ my $sgn = $inverted ? -1 : 1;
+ return $sgn * ($re1 <=> $re2) if $re1 != $re2;
+ return $sgn * ($im1 <=> $im2);
+}
+
+#
+# (_numeq)
+#
+# Computes z1 == z2.
+#
+# (Required in addition to _spaceship() because of NaNs.)
+sub _numeq {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ my ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ return $re1 == $re2 && $im1 == $im2 ? 1 : 0;
+}
+
+#
+# (_negate)
+#
+# Computes -z.
+#
+sub _negate {
+ my ($z) = @_;
+ if ($z->{c_dirty}) {
+ my ($r, $t) = @{$z->_polar};
+ $t = ($t <= 0) ? $t + pi : $t - pi;
+ return (ref $z)->emake($r, $t);
+ }
+ my ($re, $im) = @{$z->_cartesian};
+ return (ref $z)->make(-$re, -$im);
+}
+
+#
+# (_conjugate)
+#
+# Compute complex's _conjugate.
+#
+sub _conjugate {
+ my ($z) = @_;
+ if ($z->{c_dirty}) {
+ my ($r, $t) = @{$z->_polar};
+ return (ref $z)->emake($r, -$t);
+ }
+ my ($re, $im) = @{$z->_cartesian};
+ return (ref $z)->make($re, -$im);
+}
+
+#
+# (abs)
+#
+# Compute or set complex's norm (rho).
+#
+sub abs {
+ my ($z, $rho) = @_ ? @_ : $_;
+ unless (ref $z) {
+ if (@_ == 2) {
+ $_[0] = $_[1];
+ } else {
+ return CORE::abs($z);
+ }
+ }
+ if (defined $rho) {
+ $z->{'polar'} = [ $rho, ${$z->_polar}[1] ];
+ $z->{p_dirty} = 0;
+ $z->{c_dirty} = 1;
+ return $rho;
+ } else {
+ return ${$z->_polar}[0];
+ }
+}
+
+sub _theta {
+ my $theta = $_[0];
+
+ if ($$theta > pi()) { $$theta -= pi2 }
+ elsif ($$theta <= -pi()) { $$theta += pi2 }
+}
+
+#
+# arg
+#
+# Compute or set complex's argument (theta).
+#
+sub arg {
+ my ($z, $theta) = @_;
+ return $z unless ref $z;
+ if (defined $theta) {
+ _theta(\$theta);
+ $z->{'polar'} = [ ${$z->_polar}[0], $theta ];
+ $z->{p_dirty} = 0;
+ $z->{c_dirty} = 1;
+ } else {
+ $theta = ${$z->_polar}[1];
+ _theta(\$theta);
+ }
+ return $theta;
+}
+
+#
+# (sqrt)
+#
+# Compute sqrt(z).
+#
+# It is quite tempting to use wantarray here so that in list context
+# sqrt() would return the two solutions. This, however, would
+# break things like
+#
+# print "sqrt(z) = ", sqrt($z), "\n";
+#
+# The two values would be printed side by side without no intervening
+# whitespace, quite confusing.
+# Therefore if you want the two solutions use the root().
+#
+sub sqrt {
+ my ($z) = @_ ? $_[0] : $_;
+ my ($re, $im) = ref $z ? @{$z->_cartesian} : ($z, 0);
+ return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re)
+ if $im == 0;
+ my ($r, $t) = @{$z->_polar};
+ return (ref $z)->emake(CORE::sqrt($r), $t/2);
+}
+
+#
+# cbrt
+#
+# Compute cbrt(z) (cubic root).
+#
+# Why are we not returning three values? The same answer as for sqrt().
+#
+sub cbrt {
+ my ($z) = @_;
+ return $z < 0 ?
+ -CORE::exp(CORE::log(-$z)/3) :
+ ($z > 0 ? CORE::exp(CORE::log($z)/3): 0)
+ unless ref $z;
+ my ($r, $t) = @{$z->_polar};
+ return 0 if $r == 0;
+ return (ref $z)->emake(CORE::exp(CORE::log($r)/3), $t/3);
+}
+
+#
+# _rootbad
+#
+# Die on bad root.
+#
+sub _rootbad {
+ my $mess = "Root '$_[0]' illegal, root rank must be positive integer.\n";
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# root
+#
+# Computes all nth root for z, returning an array whose size is n.
+# `n' must be a positive integer.
+#
+# The roots are given by (for k = 0..n-1):
+#
+# z^(1/n) = r^(1/n) (cos ((t+2 k pi)/n) + i sin ((t+2 k pi)/n))
+#
+sub root {
+ my ($z, $n, $k) = @_;
+ _rootbad($n) if ($n < 1 or int($n) != $n);
+ my ($r, $t) = ref $z ?
+ @{$z->_polar} : (CORE::abs($z), $z >= 0 ? 0 : pi);
+ my $theta_inc = pi2 / $n;
+ my $rho = $r ** (1/$n);
+ my $cartesian = ref $z && $z->{c_dirty} == 0;
+ if (@_ == 2) {
+ my @root;
+ for (my $i = 0, my $theta = $t / $n;
+ $i < $n;
+ $i++, $theta += $theta_inc) {
+ my $w = cplxe($rho, $theta);
+ # Yes, $cartesian is loop invariant.
+ push @root, $cartesian ? cplx(@{$w->_cartesian}) : $w;
+ }
+ return @root;
+ } elsif (@_ == 3) {
+ my $w = cplxe($rho, $t / $n + $k * $theta_inc);
+ return $cartesian ? cplx(@{$w->_cartesian}) : $w;
+ }
+}
+
+#
+# Re
+#
+# Return or set Re(z).
+#
+sub Re {
+ my ($z, $Re) = @_;
+ return $z unless ref $z;
+ if (defined $Re) {
+ $z->{'cartesian'} = [ $Re, ${$z->_cartesian}[1] ];
+ $z->{c_dirty} = 0;
+ $z->{p_dirty} = 1;
+ } else {
+ return ${$z->_cartesian}[0];
+ }
+}
+
+#
+# Im
+#
+# Return or set Im(z).
+#
+sub Im {
+ my ($z, $Im) = @_;
+ return 0 unless ref $z;
+ if (defined $Im) {
+ $z->{'cartesian'} = [ ${$z->_cartesian}[0], $Im ];
+ $z->{c_dirty} = 0;
+ $z->{p_dirty} = 1;
+ } else {
+ return ${$z->_cartesian}[1];
+ }
+}
+
+#
+# rho
+#
+# Return or set rho(w).
+#
+sub rho {
+ Math::Complex::abs(@_);
+}
+
+#
+# theta
+#
+# Return or set theta(w).
+#
+sub theta {
+ Math::Complex::arg(@_);
+}
+
+#
+# (exp)
+#
+# Computes exp(z).
+#
+sub exp {
+ my ($z) = @_ ? @_ : $_;
+ return CORE::exp($z) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ return (ref $z)->emake(CORE::exp($x), $y);
+}
+
+#
+# _logofzero
+#
+# Die on logarithm of zero.
+#
+sub _logofzero {
+ my $mess = "$_[0]: Logarithm of zero.\n";
+
+ if (defined $_[1]) {
+ $mess .= "(Because in the definition of $_[0], the argument ";
+ $mess .= "$_[1] " unless ($_[1] eq '0');
+ $mess .= "is 0)\n";
+ }
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# (log)
+#
+# Compute log(z).
+#
+sub log {
+ my ($z) = @_ ? @_ : $_;
+ unless (ref $z) {
+ _logofzero("log") if $z == 0;
+ return $z > 0 ? CORE::log($z) : cplx(CORE::log(-$z), pi);
+ }
+ my ($r, $t) = @{$z->_polar};
+ _logofzero("log") if $r == 0;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ return (ref $z)->make(CORE::log($r), $t);
+}
+
+#
+# ln
+#
+# Alias for log().
+#
+sub ln { Math::Complex::log(@_) }
+
+#
+# log10
+#
+# Compute log10(z).
+#
+
+sub log10 {
+ return Math::Complex::log($_[0]) * _uplog10;
+}
+
+#
+# logn
+#
+# Compute logn(z,n) = log(z) / log(n)
+#
+sub logn {
+ my ($z, $n) = @_;
+ $z = cplx($z, 0) unless ref $z;
+ my $logn = $LOGN{$n};
+ $logn = $LOGN{$n} = CORE::log($n) unless defined $logn; # Cache log(n)
+ return &log($z) / $logn;
+}
+
+#
+# (cos)
+#
+# Compute cos(z) = (exp(iz) + exp(-iz))/2.
+#
+sub cos {
+ my ($z) = @_ ? @_ : $_;
+ return CORE::cos($z) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ my $ey = CORE::exp($y);
+ my $sx = CORE::sin($x);
+ my $cx = CORE::cos($x);
+ my $ey_1 = $ey ? 1 / $ey : Inf();
+ return (ref $z)->make($cx * ($ey + $ey_1)/2,
+ $sx * ($ey_1 - $ey)/2);
+}
+
+#
+# (sin)
+#
+# Compute sin(z) = (exp(iz) - exp(-iz))/2.
+#
+sub sin {
+ my ($z) = @_ ? @_ : $_;
+ return CORE::sin($z) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ my $ey = CORE::exp($y);
+ my $sx = CORE::sin($x);
+ my $cx = CORE::cos($x);
+ my $ey_1 = $ey ? 1 / $ey : Inf();
+ return (ref $z)->make($sx * ($ey + $ey_1)/2,
+ $cx * ($ey - $ey_1)/2);
+}
+
+#
+# tan
+#
+# Compute tan(z) = sin(z) / cos(z).
+#
+sub tan {
+ my ($z) = @_;
+ my $cz = &cos($z);
+ _divbyzero "tan($z)", "cos($z)" if $cz == 0;
+ return &sin($z) / $cz;
+}
+
+#
+# sec
+#
+# Computes the secant sec(z) = 1 / cos(z).
+#
+sub sec {
+ my ($z) = @_;
+ my $cz = &cos($z);
+ _divbyzero "sec($z)", "cos($z)" if ($cz == 0);
+ return 1 / $cz;
+}
+
+#
+# csc
+#
+# Computes the cosecant csc(z) = 1 / sin(z).
+#
+sub csc {
+ my ($z) = @_;
+ my $sz = &sin($z);
+ _divbyzero "csc($z)", "sin($z)" if ($sz == 0);
+ return 1 / $sz;
+}
+
+#
+# cosec
+#
+# Alias for csc().
+#
+sub cosec { Math::Complex::csc(@_) }
+
+#
+# cot
+#
+# Computes cot(z) = cos(z) / sin(z).
+#
+sub cot {
+ my ($z) = @_;
+ my $sz = &sin($z);
+ _divbyzero "cot($z)", "sin($z)" if ($sz == 0);
+ return &cos($z) / $sz;
+}
+
+#
+# cotan
+#
+# Alias for cot().
+#
+sub cotan { Math::Complex::cot(@_) }
+
+#
+# acos
+#
+# Computes the arc cosine acos(z) = -i log(z + sqrt(z*z-1)).
+#
+sub acos {
+ my $z = $_[0];
+ return CORE::atan2(CORE::sqrt(1-$z*$z), $z)
+ if (! ref $z) && CORE::abs($z) <= 1;
+ $z = cplx($z, 0) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ return 0 if $x == 1 && $y == 0;
+ my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y);
+ my $alpha = ($t1 + $t2)/2;
+ my $beta = ($t1 - $t2)/2;
+ $alpha = 1 if $alpha < 1;
+ if ($beta > 1) { $beta = 1 }
+ elsif ($beta < -1) { $beta = -1 }
+ my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta);
+ my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
+ $v = -$v if $y > 0 || ($y == 0 && $x < -1);
+ return (ref $z)->make($u, $v);
+}
+
+#
+# asin
+#
+# Computes the arc sine asin(z) = -i log(iz + sqrt(1-z*z)).
+#
+sub asin {
+ my $z = $_[0];
+ return CORE::atan2($z, CORE::sqrt(1-$z*$z))
+ if (! ref $z) && CORE::abs($z) <= 1;
+ $z = cplx($z, 0) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ return 0 if $x == 0 && $y == 0;
+ my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y);
+ my $alpha = ($t1 + $t2)/2;
+ my $beta = ($t1 - $t2)/2;
+ $alpha = 1 if $alpha < 1;
+ if ($beta > 1) { $beta = 1 }
+ elsif ($beta < -1) { $beta = -1 }
+ my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta));
+ my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
+ $v = -$v if $y > 0 || ($y == 0 && $x < -1);
+ return (ref $z)->make($u, $v);
+}
+
+#
+# atan
+#
+# Computes the arc tangent atan(z) = i/2 log((i+z) / (i-z)).
+#
+sub atan {
+ my ($z) = @_;
+ return CORE::atan2($z, 1) unless ref $z;
+ my ($x, $y) = ref $z ? @{$z->_cartesian} : ($z, 0);
+ return 0 if $x == 0 && $y == 0;
+ _divbyzero "atan(i)" if ( $z == i);
+ _logofzero "atan(-i)" if (-$z == i); # -i is a bad file test...
+ my $log = &log((i + $z) / (i - $z));
+ return _ip2 * $log;
+}
+
+#
+# asec
+#
+# Computes the arc secant asec(z) = acos(1 / z).
+#
+sub asec {
+ my ($z) = @_;
+ _divbyzero "asec($z)", $z if ($z == 0);
+ return acos(1 / $z);
+}
+
+#
+# acsc
+#
+# Computes the arc cosecant acsc(z) = asin(1 / z).
+#
+sub acsc {
+ my ($z) = @_;
+ _divbyzero "acsc($z)", $z if ($z == 0);
+ return asin(1 / $z);
+}
+
+#
+# acosec
+#
+# Alias for acsc().
+#
+sub acosec { Math::Complex::acsc(@_) }
+
+#
+# acot
+#
+# Computes the arc cotangent acot(z) = atan(1 / z)
+#
+sub acot {
+ my ($z) = @_;
+ _divbyzero "acot(0)" if $z == 0;
+ return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z)
+ unless ref $z;
+ _divbyzero "acot(i)" if ($z - i == 0);
+ _logofzero "acot(-i)" if ($z + i == 0);
+ return atan(1 / $z);
+}
+
+#
+# acotan
+#
+# Alias for acot().
+#
+sub acotan { Math::Complex::acot(@_) }
+
+#
+# cosh
+#
+# Computes the hyperbolic cosine cosh(z) = (exp(z) + exp(-z))/2.
+#
+sub cosh {
+ my ($z) = @_;
+ my $ex;
+ unless (ref $z) {
+ $ex = CORE::exp($z);
+ return $ex ? ($ex == $ExpInf ? Inf() : ($ex + 1/$ex)/2) : Inf();
+ }
+ my ($x, $y) = @{$z->_cartesian};
+ $ex = CORE::exp($x);
+ my $ex_1 = $ex ? 1 / $ex : Inf();
+ return (ref $z)->make(CORE::cos($y) * ($ex + $ex_1)/2,
+ CORE::sin($y) * ($ex - $ex_1)/2);
+}
+
+#
+# sinh
+#
+# Computes the hyperbolic sine sinh(z) = (exp(z) - exp(-z))/2.
+#
+sub sinh {
+ my ($z) = @_;
+ my $ex;
+ unless (ref $z) {
+ return 0 if $z == 0;
+ $ex = CORE::exp($z);
+ return $ex ? ($ex == $ExpInf ? Inf() : ($ex - 1/$ex)/2) : -Inf();
+ }
+ my ($x, $y) = @{$z->_cartesian};
+ my $cy = CORE::cos($y);
+ my $sy = CORE::sin($y);
+ $ex = CORE::exp($x);
+ my $ex_1 = $ex ? 1 / $ex : Inf();
+ return (ref $z)->make(CORE::cos($y) * ($ex - $ex_1)/2,
+ CORE::sin($y) * ($ex + $ex_1)/2);
+}
+
+#
+# tanh
+#
+# Computes the hyperbolic tangent tanh(z) = sinh(z) / cosh(z).
+#
+sub tanh {
+ my ($z) = @_;
+ my $cz = cosh($z);
+ _divbyzero "tanh($z)", "cosh($z)" if ($cz == 0);
+ my $sz = sinh($z);
+ return 1 if $cz == $sz;
+ return -1 if $cz == -$sz;
+ return $sz / $cz;
+}
+
+#
+# sech
+#
+# Computes the hyperbolic secant sech(z) = 1 / cosh(z).
+#
+sub sech {
+ my ($z) = @_;
+ my $cz = cosh($z);
+ _divbyzero "sech($z)", "cosh($z)" if ($cz == 0);
+ return 1 / $cz;
+}
+
+#
+# csch
+#
+# Computes the hyperbolic cosecant csch(z) = 1 / sinh(z).
+#
+sub csch {
+ my ($z) = @_;
+ my $sz = sinh($z);
+ _divbyzero "csch($z)", "sinh($z)" if ($sz == 0);
+ return 1 / $sz;
+}
+
+#
+# cosech
+#
+# Alias for csch().
+#
+sub cosech { Math::Complex::csch(@_) }
+
+#
+# coth
+#
+# Computes the hyperbolic cotangent coth(z) = cosh(z) / sinh(z).
+#
+sub coth {
+ my ($z) = @_;
+ my $sz = sinh($z);
+ _divbyzero "coth($z)", "sinh($z)" if $sz == 0;
+ my $cz = cosh($z);
+ return 1 if $cz == $sz;
+ return -1 if $cz == -$sz;
+ return $cz / $sz;
+}
+
+#
+# cotanh
+#
+# Alias for coth().
+#
+sub cotanh { Math::Complex::coth(@_) }
+
+#
+# acosh
+#
+# Computes the area/inverse hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)).
+#
+sub acosh {
+ my ($z) = @_;
+ unless (ref $z) {
+ $z = cplx($z, 0);
+ }
+ my ($re, $im) = @{$z->_cartesian};
+ if ($im == 0) {
+ return CORE::log($re + CORE::sqrt($re*$re - 1))
+ if $re >= 1;
+ return cplx(0, CORE::atan2(CORE::sqrt(1 - $re*$re), $re))
+ if CORE::abs($re) < 1;
+ }
+ my $t = &sqrt($z * $z - 1) + $z;
+ # Try Taylor if looking bad (this usually means that
+ # $z was large negative, therefore the sqrt is really
+ # close to abs(z), summing that with z...)
+ $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7)
+ if $t == 0;
+ my $u = &log($t);
+ $u->Im(-$u->Im) if $re < 0 && $im == 0;
+ return $re < 0 ? -$u : $u;
+}
+
+#
+# asinh
+#
+# Computes the area/inverse hyperbolic sine asinh(z) = log(z + sqrt(z*z+1))
+#
+sub asinh {
+ my ($z) = @_;
+ unless (ref $z) {
+ my $t = $z + CORE::sqrt($z*$z + 1);
+ return CORE::log($t) if $t;
+ }
+ my $t = &sqrt($z * $z + 1) + $z;
+ # Try Taylor if looking bad (this usually means that
+ # $z was large negative, therefore the sqrt is really
+ # close to abs(z), summing that with z...)
+ $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7)
+ if $t == 0;
+ return &log($t);
+}
+
+#
+# atanh
+#
+# Computes the area/inverse hyperbolic tangent atanh(z) = 1/2 log((1+z) / (1-z)).
+#
+sub atanh {
+ my ($z) = @_;
+ unless (ref $z) {
+ return CORE::log((1 + $z)/(1 - $z))/2 if CORE::abs($z) < 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'atanh(1)', "1 - $z" if (1 - $z == 0);
+ _logofzero 'atanh(-1)' if (1 + $z == 0);
+ return 0.5 * &log((1 + $z) / (1 - $z));
+}
+
+#
+# asech
+#
+# Computes the area/inverse hyperbolic secant asech(z) = acosh(1 / z).
+#
+sub asech {
+ my ($z) = @_;
+ _divbyzero 'asech(0)', "$z" if ($z == 0);
+ return acosh(1 / $z);
+}
+
+#
+# acsch
+#
+# Computes the area/inverse hyperbolic cosecant acsch(z) = asinh(1 / z).
+#
+sub acsch {
+ my ($z) = @_;
+ _divbyzero 'acsch(0)', $z if ($z == 0);
+ return asinh(1 / $z);
+}
+
+#
+# acosech
+#
+# Alias for acosh().
+#
+sub acosech { Math::Complex::acsch(@_) }
+
+#
+# acoth
+#
+# Computes the area/inverse hyperbolic cotangent acoth(z) = 1/2 log((1+z) / (z-1)).
+#
+sub acoth {
+ my ($z) = @_;
+ _divbyzero 'acoth(0)' if ($z == 0);
+ unless (ref $z) {
+ return CORE::log(($z + 1)/($z - 1))/2 if CORE::abs($z) > 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'acoth(1)', "$z - 1" if ($z - 1 == 0);
+ _logofzero 'acoth(-1)', "1 + $z" if (1 + $z == 0);
+ return &log((1 + $z) / ($z - 1)) / 2;
+}
+
+#
+# acotanh
+#
+# Alias for acot().
+#
+sub acotanh { Math::Complex::acoth(@_) }
+
+#
+# (atan2)
+#
+# Compute atan(z1/z2), minding the right quadrant.
+#
+sub atan2 {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1, $re2, $im2);
+ if ($inverted) {
+ ($re1, $im1) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ ($re2, $im2) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ } else {
+ ($re1, $im1) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ }
+ if ($im1 || $im2) {
+ # In MATLAB the imaginary parts are ignored.
+ # warn "atan2: Imaginary parts ignored";
+ # http://documents.wolfram.com/mathematica/functions/ArcTan
+ # NOTE: Mathematica ArcTan[x,y] while atan2(y,x)
+ my $s = $z1 * $z1 + $z2 * $z2;
+ _divbyzero("atan2") if $s == 0;
+ my $i = &i;
+ my $r = $z2 + $z1 * $i;
+ return -$i * &log($r / &sqrt( $s ));
+ }
+ return CORE::atan2($re1, $re2);
+}
+
+#
+# display_format
+# ->display_format
+#
+# Set (get if no argument) the display format for all complex numbers that
+# don't happen to have overridden it via ->display_format
+#
+# When called as an object method, this actually sets the display format for
+# the current object.
+#
+# Valid object formats are 'c' and 'p' for cartesian and polar. The first
+# letter is used actually, so the type can be fully spelled out for clarity.
+#
+sub display_format {
+ my $self = shift;
+ my %display_format = %DISPLAY_FORMAT;
+
+ if (ref $self) { # Called as an object method
+ if (exists $self->{display_format}) {
+ my %obj = %{$self->{display_format}};
+ @display_format{keys %obj} = values %obj;
+ }
+ }
+ if (@_ == 1) {
+ $display_format{style} = shift;
+ } else {
+ my %new = @_;
+ @display_format{keys %new} = values %new;
+ }
+
+ if (ref $self) { # Called as an object method
+ $self->{display_format} = { %display_format };
+ return
+ wantarray ?
+ %{$self->{display_format}} :
+ $self->{display_format}->{style};
+ }
+
+ # Called as a class method
+ %DISPLAY_FORMAT = %display_format;
+ return
+ wantarray ?
+ %DISPLAY_FORMAT :
+ $DISPLAY_FORMAT{style};
+}
+
+#
+# (_stringify)
+#
+# Show nicely formatted complex number under its cartesian or polar form,
+# depending on the current display format:
+#
+# . If a specific display format has been recorded for this object, use it.
+# . Otherwise, use the generic current default for all complex numbers,
+# which is a package global variable.
+#
+sub _stringify {
+ my ($z) = shift;
+
+ my $style = $z->display_format;
+
+ $style = $DISPLAY_FORMAT{style} unless defined $style;
+
+ return $z->_stringify_polar if $style =~ /^p/i;
+ return $z->_stringify_cartesian;
+}
+
+#
+# ->_stringify_cartesian
+#
+# Stringify as a cartesian representation 'a+bi'.
+#
+sub _stringify_cartesian {
+ my $z = shift;
+ my ($x, $y) = @{$z->_cartesian};
+ my ($re, $im);
+
+ my %format = $z->display_format;
+ my $format = $format{format};
+
+ if ($x) {
+ if ($x =~ /^NaN[QS]?$/i) {
+ $re = $x;
+ } else {
+ if ($x =~ /^-?\Q$Inf\E$/oi) {
+ $re = $x;
+ } else {
+ $re = defined $format ? sprintf($format, $x) : $x;
+ }
+ }
+ } else {
+ undef $re;
+ }
+
+ if ($y) {
+ if ($y =~ /^(NaN[QS]?)$/i) {
+ $im = $y;
+ } else {
+ if ($y =~ /^-?\Q$Inf\E$/oi) {
+ $im = $y;
+ } else {
+ $im =
+ defined $format ?
+ sprintf($format, $y) :
+ ($y == 1 ? "" : ($y == -1 ? "-" : $y));
+ }
+ }
+ $im .= "i";
+ } else {
+ undef $im;
+ }
+
+ my $str = $re;
+
+ if (defined $im) {
+ if ($y < 0) {
+ $str .= $im;
+ } elsif ($y > 0 || $im =~ /^NaN[QS]?i$/i) {
+ $str .= "+" if defined $re;
+ $str .= $im;
+ }
+ } elsif (!defined $re) {
+ $str = "0";
+ }
+
+ return $str;
+}
+
+
+#
+# ->_stringify_polar
+#
+# Stringify as a polar representation '[r,t]'.
+#
+sub _stringify_polar {
+ my $z = shift;
+ my ($r, $t) = @{$z->_polar};
+ my $theta;
+
+ my %format = $z->display_format;
+ my $format = $format{format};
+
+ if ($t =~ /^NaN[QS]?$/i || $t =~ /^-?\Q$Inf\E$/oi) {
+ $theta = $t;
+ } elsif ($t == pi) {
+ $theta = "pi";
+ } elsif ($r == 0 || $t == 0) {
+ $theta = defined $format ? sprintf($format, $t) : $t;
+ }
+
+ return "[$r,$theta]" if defined $theta;
+
+ #
+ # Try to identify pi/n and friends.
+ #
+
+ $t -= int(CORE::abs($t) / pi2) * pi2;
+
+ if ($format{polar_pretty_print} && $t) {
+ my ($a, $b);
+ for $a (2..9) {
+ $b = $t * $a / pi;
+ if ($b =~ /^-?\d+$/) {
+ $b = $b < 0 ? "-" : "" if CORE::abs($b) == 1;
+ $theta = "${b}pi/$a";
+ last;
+ }
+ }
+ }
+
+ if (defined $format) {
+ $r = sprintf($format, $r);
+ $theta = sprintf($format, $theta) unless defined $theta;
+ } else {
+ $theta = $t unless defined $theta;
+ }
+
+ return "[$r,$theta]";
+}
+
+sub Inf {
+ return $Inf;
+}
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+Math::Complex - complex numbers and associated mathematical functions
+
+=head1 SYNOPSIS
+
+ use Math::Complex;
+
+ $z = Math::Complex->make(5, 6);
+ $t = 4 - 3*i + $z;
+ $j = cplxe(1, 2*pi/3);
+
+=head1 DESCRIPTION
+
+This package lets you create and manipulate complex numbers. By default,
+I<Perl> limits itself to real numbers, but an extra C<use> statement brings
+full complex support, along with a full set of mathematical functions
+typically associated with and/or extended to complex numbers.
+
+If you wonder what complex numbers are, they were invented to be able to solve
+the following equation:
+
+ x*x = -1
+
+and by definition, the solution is noted I<i> (engineers use I<j> instead since
+I<i> usually denotes an intensity, but the name does not matter). The number
+I<i> is a pure I<imaginary> number.
+
+The arithmetics with pure imaginary numbers works just like you would expect
+it with real numbers... you just have to remember that
+
+ i*i = -1
+
+so you have:
+
+ 5i + 7i = i * (5 + 7) = 12i
+ 4i - 3i = i * (4 - 3) = i
+ 4i * 2i = -8
+ 6i / 2i = 3
+ 1 / i = -i
+
+Complex numbers are numbers that have both a real part and an imaginary
+part, and are usually noted:
+
+ a + bi
+
+where C<a> is the I<real> part and C<b> is the I<imaginary> part. The
+arithmetic with complex numbers is straightforward. You have to
+keep track of the real and the imaginary parts, but otherwise the
+rules used for real numbers just apply:
+
+ (4 + 3i) + (5 - 2i) = (4 + 5) + i(3 - 2) = 9 + i
+ (2 + i) * (4 - i) = 2*4 + 4i -2i -i*i = 8 + 2i + 1 = 9 + 2i
+
+A graphical representation of complex numbers is possible in a plane
+(also called the I<complex plane>, but it's really a 2D plane).
+The number
+
+ z = a + bi
+
+is the point whose coordinates are (a, b). Actually, it would
+be the vector originating from (0, 0) to (a, b). It follows that the addition
+of two complex numbers is a vectorial addition.
+
+Since there is a bijection between a point in the 2D plane and a complex
+number (i.e. the mapping is unique and reciprocal), a complex number
+can also be uniquely identified with polar coordinates:
+
+ [rho, theta]
+
+where C<rho> is the distance to the origin, and C<theta> the angle between
+the vector and the I<x> axis. There is a notation for this using the
+exponential form, which is:
+
+ rho * exp(i * theta)
+
+where I<i> is the famous imaginary number introduced above. Conversion
+between this form and the cartesian form C<a + bi> is immediate:
+
+ a = rho * cos(theta)
+ b = rho * sin(theta)
+
+which is also expressed by this formula:
+
+ z = rho * exp(i * theta) = rho * (cos theta + i * sin theta)
+
+In other words, it's the projection of the vector onto the I<x> and I<y>
+axes. Mathematicians call I<rho> the I<norm> or I<modulus> and I<theta>
+the I<argument> of the complex number. The I<norm> of C<z> is
+marked here as C<abs(z)>.
+
+The polar notation (also known as the trigonometric representation) is
+much more handy for performing multiplications and divisions of
+complex numbers, whilst the cartesian notation is better suited for
+additions and subtractions. Real numbers are on the I<x> axis, and
+therefore I<y> or I<theta> is zero or I<pi>.
+
+All the common operations that can be performed on a real number have
+been defined to work on complex numbers as well, and are merely
+I<extensions> of the operations defined on real numbers. This means
+they keep their natural meaning when there is no imaginary part, provided
+the number is within their definition set.
+
+For instance, the C<sqrt> routine which computes the square root of
+its argument is only defined for non-negative real numbers and yields a
+non-negative real number (it is an application from B<R+> to B<R+>).
+If we allow it to return a complex number, then it can be extended to
+negative real numbers to become an application from B<R> to B<C> (the
+set of complex numbers):
+
+ sqrt(x) = x >= 0 ? sqrt(x) : sqrt(-x)*i
+
+It can also be extended to be an application from B<C> to B<C>,
+whilst its restriction to B<R> behaves as defined above by using
+the following definition:
+
+ sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2)
+
+Indeed, a negative real number can be noted C<[x,pi]> (the modulus
+I<x> is always non-negative, so C<[x,pi]> is really C<-x>, a negative
+number) and the above definition states that
+
+ sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i
+
+which is exactly what we had defined for negative real numbers above.
+The C<sqrt> returns only one of the solutions: if you want the both,
+use the C<root> function.
+
+All the common mathematical functions defined on real numbers that
+are extended to complex numbers share that same property of working
+I<as usual> when the imaginary part is zero (otherwise, it would not
+be called an extension, would it?).
+
+A I<new> operation possible on a complex number that is
+the identity for real numbers is called the I<conjugate>, and is noted
+with a horizontal bar above the number, or C<~z> here.
+
+ z = a + bi
+ ~z = a - bi
+
+Simple... Now look:
+
+ z * ~z = (a + bi) * (a - bi) = a*a + b*b
+
+We saw that the norm of C<z> was noted C<abs(z)> and was defined as the
+distance to the origin, also known as:
+
+ rho = abs(z) = sqrt(a*a + b*b)
+
+so
+
+ z * ~z = abs(z) ** 2
+
+If z is a pure real number (i.e. C<b == 0>), then the above yields:
+
+ a * a = abs(a) ** 2
+
+which is true (C<abs> has the regular meaning for real number, i.e. stands
+for the absolute value). This example explains why the norm of C<z> is
+noted C<abs(z)>: it extends the C<abs> function to complex numbers, yet
+is the regular C<abs> we know when the complex number actually has no
+imaginary part... This justifies I<a posteriori> our use of the C<abs>
+notation for the norm.
+
+=head1 OPERATIONS
+
+Given the following notations:
+
+ z1 = a + bi = r1 * exp(i * t1)
+ z2 = c + di = r2 * exp(i * t2)
+ z = <any complex or real number>
+
+the following (overloaded) operations are supported on complex numbers:
+
+ z1 + z2 = (a + c) + i(b + d)
+ z1 - z2 = (a - c) + i(b - d)
+ z1 * z2 = (r1 * r2) * exp(i * (t1 + t2))
+ z1 / z2 = (r1 / r2) * exp(i * (t1 - t2))
+ z1 ** z2 = exp(z2 * log z1)
+ ~z = a - bi
+ abs(z) = r1 = sqrt(a*a + b*b)
+ sqrt(z) = sqrt(r1) * exp(i * t/2)
+ exp(z) = exp(a) * exp(i * b)
+ log(z) = log(r1) + i*t
+ sin(z) = 1/2i (exp(i * z1) - exp(-i * z))
+ cos(z) = 1/2 (exp(i * z1) + exp(-i * z))
+ atan2(y, x) = atan(y / x) # Minding the right quadrant, note the order.
+
+The definition used for complex arguments of atan2() is
+
+ -i log((x + iy)/sqrt(x*x+y*y))
+
+Note that atan2(0, 0) is not well-defined.
+
+The following extra operations are supported on both real and complex
+numbers:
+
+ Re(z) = a
+ Im(z) = b
+ arg(z) = t
+ abs(z) = r
+
+ cbrt(z) = z ** (1/3)
+ log10(z) = log(z) / log(10)
+ logn(z, n) = log(z) / log(n)
+
+ tan(z) = sin(z) / cos(z)
+
+ csc(z) = 1 / sin(z)
+ sec(z) = 1 / cos(z)
+ cot(z) = 1 / tan(z)
+
+ asin(z) = -i * log(i*z + sqrt(1-z*z))
+ acos(z) = -i * log(z + i*sqrt(1-z*z))
+ atan(z) = i/2 * log((i+z) / (i-z))
+
+ acsc(z) = asin(1 / z)
+ asec(z) = acos(1 / z)
+ acot(z) = atan(1 / z) = -i/2 * log((i+z) / (z-i))
+
+ sinh(z) = 1/2 (exp(z) - exp(-z))
+ cosh(z) = 1/2 (exp(z) + exp(-z))
+ tanh(z) = sinh(z) / cosh(z) = (exp(z) - exp(-z)) / (exp(z) + exp(-z))
+
+ csch(z) = 1 / sinh(z)
+ sech(z) = 1 / cosh(z)
+ coth(z) = 1 / tanh(z)
+
+ asinh(z) = log(z + sqrt(z*z+1))
+ acosh(z) = log(z + sqrt(z*z-1))
+ atanh(z) = 1/2 * log((1+z) / (1-z))
+
+ acsch(z) = asinh(1 / z)
+ asech(z) = acosh(1 / z)
+ acoth(z) = atanh(1 / z) = 1/2 * log((1+z) / (z-1))
+
+I<arg>, I<abs>, I<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>,
+I<coth>, I<acosech>, I<acotanh>, have aliases I<rho>, I<theta>, I<ln>,
+I<cosec>, I<cotan>, I<acosec>, I<acotan>, I<cosech>, I<cotanh>,
+I<acosech>, I<acotanh>, respectively. C<Re>, C<Im>, C<arg>, C<abs>,
+C<rho>, and C<theta> can be used also as mutators. The C<cbrt>
+returns only one of the solutions: if you want all three, use the
+C<root> function.
+
+The I<root> function is available to compute all the I<n>
+roots of some complex, where I<n> is a strictly positive integer.
+There are exactly I<n> such roots, returned as a list. Getting the
+number mathematicians call C<j> such that:
+
+ 1 + j + j*j = 0;
+
+is a simple matter of writing:
+
+ $j = ((root(1, 3))[1];
+
+The I<k>th root for C<z = [r,t]> is given by:
+
+ (root(z, n))[k] = r**(1/n) * exp(i * (t + 2*k*pi)/n)
+
+You can return the I<k>th root directly by C<root(z, n, k)>,
+indexing starting from I<zero> and ending at I<n - 1>.
+
+The I<spaceship> numeric comparison operator, E<lt>=E<gt>, is also
+defined. In order to ensure its restriction to real numbers is conform
+to what you would expect, the comparison is run on the real part of
+the complex number first, and imaginary parts are compared only when
+the real parts match.
+
+=head1 CREATION
+
+To create a complex number, use either:
+
+ $z = Math::Complex->make(3, 4);
+ $z = cplx(3, 4);
+
+if you know the cartesian form of the number, or
+
+ $z = 3 + 4*i;
+
+if you like. To create a number using the polar form, use either:
+
+ $z = Math::Complex->emake(5, pi/3);
+ $x = cplxe(5, pi/3);
+
+instead. The first argument is the modulus, the second is the angle
+(in radians, the full circle is 2*pi). (Mnemonic: C<e> is used as a
+notation for complex numbers in the polar form).
+
+It is possible to write:
+
+ $x = cplxe(-3, pi/4);
+
+but that will be silently converted into C<[3,-3pi/4]>, since the
+modulus must be non-negative (it represents the distance to the origin
+in the complex plane).
+
+It is also possible to have a complex number as either argument of the
+C<make>, C<emake>, C<cplx>, and C<cplxe>: the appropriate component of
+the argument will be used.
+
+ $z1 = cplx(-2, 1);
+ $z2 = cplx($z1, 4);
+
+The C<new>, C<make>, C<emake>, C<cplx>, and C<cplxe> will also
+understand a single (string) argument of the forms
+
+ 2-3i
+ -3i
+ [2,3]
+ [2,-3pi/4]
+ [2]
+
+in which case the appropriate cartesian and exponential components
+will be parsed from the string and used to create new complex numbers.
+The imaginary component and the theta, respectively, will default to zero.
+
+The C<new>, C<make>, C<emake>, C<cplx>, and C<cplxe> will also
+understand the case of no arguments: this means plain zero or (0, 0).
+
+=head1 DISPLAYING
+
+When printed, a complex number is usually shown under its cartesian
+style I<a+bi>, but there are legitimate cases where the polar style
+I<[r,t]> is more appropriate. The process of converting the complex
+number into a string that can be displayed is known as I<stringification>.
+
+By calling the class method C<Math::Complex::display_format> and
+supplying either C<"polar"> or C<"cartesian"> as an argument, you
+override the default display style, which is C<"cartesian">. Not
+supplying any argument returns the current settings.
+
+This default can be overridden on a per-number basis by calling the
+C<display_format> method instead. As before, not supplying any argument
+returns the current display style for this number. Otherwise whatever you
+specify will be the new display style for I<this> particular number.
+
+For instance:
+
+ use Math::Complex;
+
+ Math::Complex::display_format('polar');
+ $j = (root(1, 3))[1];
+ print "j = $j\n"; # Prints "j = [1,2pi/3]"
+ $j->display_format('cartesian');
+ print "j = $j\n"; # Prints "j = -0.5+0.866025403784439i"
+
+The polar style attempts to emphasize arguments like I<k*pi/n>
+(where I<n> is a positive integer and I<k> an integer within [-9, +9]),
+this is called I<polar pretty-printing>.
+
+For the reverse of stringifying, see the C<make> and C<emake>.
+
+=head2 CHANGED IN PERL 5.6
+
+The C<display_format> class method and the corresponding
+C<display_format> object method can now be called using
+a parameter hash instead of just a one parameter.
+
+The old display format style, which can have values C<"cartesian"> or
+C<"polar">, can be changed using the C<"style"> parameter.
+
+ $j->display_format(style => "polar");
+
+The one parameter calling convention also still works.
+
+ $j->display_format("polar");
+
+There are two new display parameters.
+
+The first one is C<"format">, which is a sprintf()-style format string
+to be used for both numeric parts of the complex number(s). The is
+somewhat system-dependent but most often it corresponds to C<"%.15g">.
+You can revert to the default by setting the C<format> to C<undef>.
+
+ # the $j from the above example
+
+ $j->display_format('format' => '%.5f');
+ print "j = $j\n"; # Prints "j = -0.50000+0.86603i"
+ $j->display_format('format' => undef);
+ print "j = $j\n"; # Prints "j = -0.5+0.86603i"
+
+Notice that this affects also the return values of the
+C<display_format> methods: in list context the whole parameter hash
+will be returned, as opposed to only the style parameter value.
+This is a potential incompatibility with earlier versions if you
+have been calling the C<display_format> method in list context.
+
+The second new display parameter is C<"polar_pretty_print">, which can
+be set to true or false, the default being true. See the previous
+section for what this means.
+
+=head1 USAGE
+
+Thanks to overloading, the handling of arithmetics with complex numbers
+is simple and almost transparent.
+
+Here are some examples:
+
+ use Math::Complex;
+
+ $j = cplxe(1, 2*pi/3); # $j ** 3 == 1
+ print "j = $j, j**3 = ", $j ** 3, "\n";
+ print "1 + j + j**2 = ", 1 + $j + $j**2, "\n";
+
+ $z = -16 + 0*i; # Force it to be a complex
+ print "sqrt($z) = ", sqrt($z), "\n";
+
+ $k = exp(i * 2*pi/3);
+ print "$j - $k = ", $j - $k, "\n";
+
+ $z->Re(3); # Re, Im, arg, abs,
+ $j->arg(2); # (the last two aka rho, theta)
+ # can be used also as mutators.
+
+=head1 CONSTANTS
+
+=head2 PI
+
+The constant C<pi> and some handy multiples of it (pi2, pi4,
+and pip2 (pi/2) and pip4 (pi/4)) are also available if separately
+exported:
+
+ use Math::Complex ':pi';
+ $third_of_circle = pi2 / 3;
+
+=head2 Inf
+
+The floating point infinity can be exported as a subroutine Inf():
+
+ use Math::Complex qw(Inf sinh);
+ my $AlsoInf = Inf() + 42;
+ my $AnotherInf = sinh(1e42);
+ print "$AlsoInf is $AnotherInf\n" if $AlsoInf == $AnotherInf;
+
+Note that the stringified form of infinity varies between platforms:
+it can be for example any of
+
+ inf
+ infinity
+ INF
+ 1.#INF
+
+or it can be something else.
+
+Also note that in some platforms trying to use the infinity in
+arithmetic operations may result in Perl crashing because using
+an infinity causes SIGFPE or its moral equivalent to be sent.
+The way to ignore this is
+
+ local $SIG{FPE} = sub { };
+
+=head1 ERRORS DUE TO DIVISION BY ZERO OR LOGARITHM OF ZERO
+
+The division (/) and the following functions
+
+ log ln log10 logn
+ tan sec csc cot
+ atan asec acsc acot
+ tanh sech csch coth
+ atanh asech acsch acoth
+
+cannot be computed for all arguments because that would mean dividing
+by zero or taking logarithm of zero. These situations cause fatal
+runtime errors looking like this
+
+ cot(0): Division by zero.
+ (Because in the definition of cot(0), the divisor sin(0) is 0)
+ Died at ...
+
+or
+
+ atanh(-1): Logarithm of zero.
+ Died at...
+
+For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>,
+C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the
+logarithmic functions and the C<atanh>, C<acoth>, the argument cannot
+be C<1> (one). For the C<atanh>, C<acoth>, the argument cannot be
+C<-1> (minus one). For the C<atan>, C<acot>, the argument cannot be
+C<i> (the imaginary unit). For the C<atan>, C<acoth>, the argument
+cannot be C<-i> (the negative imaginary unit). For the C<tan>,
+C<sec>, C<tanh>, the argument cannot be I<pi/2 + k * pi>, where I<k>
+is any integer. atan2(0, 0) is undefined, and if the complex arguments
+are used for atan2(), a division by zero will happen if z1**2+z2**2 == 0.
+
+Note that because we are operating on approximations of real numbers,
+these errors can happen when merely `too close' to the singularities
+listed above.
+
+=head1 ERRORS DUE TO INDIGESTIBLE ARGUMENTS
+
+The C<make> and C<emake> accept both real and complex arguments.
+When they cannot recognize the arguments they will die with error
+messages like the following
+
+ Math::Complex::make: Cannot take real part of ...
+ Math::Complex::make: Cannot take real part of ...
+ Math::Complex::emake: Cannot take rho of ...
+ Math::Complex::emake: Cannot take theta of ...
+
+=head1 BUGS
+
+Saying C<use Math::Complex;> exports many mathematical routines in the
+caller environment and even overrides some (C<sqrt>, C<log>, C<atan2>).
+This is construed as a feature by the Authors, actually... ;-)
+
+All routines expect to be given real or complex numbers. Don't attempt to
+use BigFloat, since Perl has currently no rule to disambiguate a '+'
+operation (for instance) between two overloaded entities.
+
+In Cray UNICOS there is some strange numerical instability that results
+in root(), cos(), sin(), cosh(), sinh(), losing accuracy fast. Beware.
+The bug may be in UNICOS math libs, in UNICOS C compiler, in Math::Complex.
+Whatever it is, it does not manifest itself anywhere else where Perl runs.
+
+=head1 SEE ALSO
+
+L<Math::Trig>
+
+=head1 AUTHORS
+
+Daniel S. Lewart <F<lewart!at!uiuc.edu>>
+Jarkko Hietaniemi <F<jhi!at!iki.fi>>
+Raphael Manfredi <F<Raphael_Manfredi!at!pobox.com>>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
+
+# eof
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/GMP.pm b/Master/tlpkg/tlperl.straw/lib/Math/GMP.pm
new file mode 100755
index 00000000000..abfd6e146f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/GMP.pm
@@ -0,0 +1,411 @@
+package Math::GMP;
+
+# Math::GMP, a Perl module for high-speed arbitrary size integer
+# calculations
+# Copyright (C) 2000-2008 James H. Turner
+# Copyright (C) 2008-2009 Greg Sabino Mullane
+
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the Free
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# You can contact the author at chip@redhat.com, chipt@cpan.org, or by mail:
+
+# Chip Turner
+# Red Hat Inc.
+# 2600 Meridian Park Blvd
+# Durham, NC 27713
+
+use strict;
+use warnings;
+use 5.006;
+use Carp;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+
+use overload
+ '""' => \&stringify,
+ '0+' => \&intify,
+
+ '<=>' => \&op_spaceship,
+ 'cmp' => \&op_cmp,
+
+ '+' => \&op_add,
+ '-' => \&op_sub,
+
+ '&' => \&op_and,
+ '^' => \&op_xor,
+ '|' => \&op_or,
+
+ '%' => \&op_mod,
+ '**' => \&op_pow,
+ '*' => \&op_mul,
+ '/' => \&op_div;
+
+require Exporter;
+require DynaLoader;
+require AutoLoader;
+
+@ISA = qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+our $VERSION = '2.06';
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function. If a constant is not found then control is passed
+ # to the AUTOLOAD in AutoLoader.
+
+ my $constname;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ croak '& not defined' if $constname eq 'constant';
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ } else {
+ croak "Your vendor has not defined Math::GMP macro $constname";
+ }
+ }
+ no strict 'refs'; ## no critic
+ *$AUTOLOAD = sub () { $val };
+ goto &$AUTOLOAD;
+}
+
+bootstrap Math::GMP $VERSION;
+
+use strict;
+sub import {
+ shift;
+ return unless @_;
+ die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+ overload::constant integer => sub { Math::GMP->new(shift) };
+ return;
+}
+
+
+sub new {
+ my $class = shift;
+ my $ival = shift || 0;
+ my $base = shift;
+
+ $ival =~ s/^\+//;
+ $ival =~ s/[ _]//g;
+ my $ret;
+ if ($base) {
+ $ret = Math::GMP::new_from_scalar_with_base($ival, $base);
+ } else {
+ $ival = 0 if $ival =~ /[^\d\-xA-Fa-f]/;
+ $ret = Math::GMP::new_from_scalar($ival);
+ }
+
+ return $ret;
+}
+
+BEGIN
+ {
+ *DESTROY = \&Math::GMP::destroy;
+ }
+
+sub add {
+ croak 'add: not enough arguments, two required' if @_ < 2;
+
+ my $ret = Math::GMP->new(0);
+ add_to_self($ret, shift) while @_;
+
+ return $ret;
+}
+
+sub stringify {
+ return Math::GMP::stringify_gmp($_[0]);
+}
+
+sub intify {
+ return Math::GMP::intify_gmp($_[0]);
+}
+
+sub promote {
+ return $_[0] if ref $_[0] eq 'Math::GMP';
+ return Math::GMP::new_from_scalar($_[0] || 0);
+}
+
+sub gcd {
+ return gcd_two(promote(shift), promote(shift));
+}
+
+sub bgcd {
+ return gcd_two(promote(shift), promote(shift));
+}
+
+sub legendre {
+ return gmp_legendre(promote(shift), promote(shift));
+}
+
+sub jacobi {
+ return gmp_jacobi(promote(shift), promote(shift));
+}
+
+sub probab_prime {
+ my $x = shift;
+ my $reps = shift;
+ return gmp_probab_prime(promote($x), $reps);
+}
+
+sub op_add {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return add_two(promote($n), promote($m));
+}
+
+sub op_sub {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return sub_two(promote($n), promote($m));
+}
+
+sub op_mul {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return mul_two(promote($n), promote($m));
+}
+
+sub op_div {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return div_two(promote($n), promote($m));
+}
+
+sub bdiv {
+ return bdiv_two(promote(shift), promote(shift));
+}
+
+
+sub op_mod {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return mod_two(promote($n), promote($m));
+}
+
+
+
+sub op_cmp {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return cmp_two(stringify(promote($n)), stringify(promote($m)));
+}
+
+sub op_spaceship {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ my $x = cmp_two(promote($n), promote($m));
+ return $x < 0 ? -1 : $x > 0 ? 1 : 0;
+}
+
+sub op_pow {
+ my ($m, $n) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return pow_two(promote($m), int($n));
+}
+
+
+sub op_and {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return and_two(promote($n), promote($m));
+}
+
+sub op_xor {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return xor_two(promote($n), promote($m));
+}
+
+sub op_or {
+ my ($n, $m) = @_;
+ ($n, $m) = ($m, $n) if $_[2];
+ return or_two(promote($n), promote($m));
+}
+
+sub bior {
+ return or_two(promote(shift), promote(shift));
+}
+
+sub band {
+ return and_two(promote(shift), promote(shift));
+}
+
+sub bxor {
+ return xor_two(promote(shift), promote(shift));
+}
+
+sub bfac {
+ return gmp_fac(int(shift));
+}
+
+sub fibonacci {
+ return gmp_fib(int(shift));
+}
+
+__END__
+
+=head1 NAME
+
+Math::GMP - High speed arbitrary size integer math
+
+=head1 SYNOPSIS
+
+ use Math::GMP;
+ my $n = new Math::GMP 2;
+
+ $n = $n ** (256*1024);
+ $n = $n - 1;
+ print "n is now $n\n";
+
+=head1 DESCRIPTION
+
+Math::GMP was designed to be a drop-in replacement both for
+Math::BigInt and for regular integer arithmetic. Unlike BigInt,
+though, Math::GMP uses the GNU gmp library for all of its
+calculations, as opposed to straight Perl functions. This can result
+in speed improvements.
+
+The downside is that this module requires a C compiler to install -- a
+small tradeoff in most cases. Also, this module is not 100% compatible
+to Math::BigInt.
+
+A Math::GMP object can be used just as a normal numeric scalar would
+be -- the module overloads most of the normal arithmetic operators to
+provide as seamless an interface as possible. However, if you need a
+perfect interface, you can do the following:
+
+ use Math::GMP qw(:constant);
+
+ $n = 2 ** (256 * 1024);
+ print "n is $n\n";
+
+This would fail without the ':constant' since Perl would use normal
+doubles to compute the 250,000 bit number, and thereby overflow it
+into meaninglessness (smaller exponents yield less accurate data due
+to floating point rounding).
+
+=head1 METHODS
+
+Although the non-overload interface is not complete, the following
+functions do exist:
+
+=head2 new
+
+ $x = Math::GMP->new(123);
+
+Creates a new Math::GMP object from the passed string or scalar.
+
+ $x = Math::GMP->new('abcd', 36);
+
+Creates a new Math::GMP object from the first parameter which should
+be represented in the base specified by the second parameter.
+
+=head2 bfac
+
+ $x = Math::GMP->new(5);
+ $x->bfac(); # 1*2*3*4*5 = 120
+
+Calculates the factorial of $x and modifies $x to contain the result.
+
+=head2 band
+
+ $x = Math::GMP->new(6);
+ $x->band(3); # 0b110 & 0b11 = 1
+
+Calculates the bit-wise AND of it's two arguments and modifies the first
+argument.
+
+=head2 bxor
+
+ $x = Math::GMP->new(6);
+ $x->bxor(3); # 0b110 & 0b11 = 0b101
+
+Calculates the bit-wise XOR of it's two arguments and modifies the first
+argument.
+
+=head2 bior
+
+ $x = Math::GMP->new(6);
+ $x->bior(3); # 0b110 & 0b11 = 0b111
+
+Calculates the bit-wise OR of it's two arguments and modifies the first
+argument.
+
+=head2 bgcd
+
+ $x = Math::GMP->new(6);
+ $x->bgcd(4); # 6 / 2 = 2, 4 / 2 = 2 => 2
+
+Calculates the Greatest Common Divisior of it's two arguments and returns the result.
+
+=head2 legendre
+
+=head2 jacobi
+
+=head2 fibonacci
+
+ $x = Math::GMP->fibonacci(16);
+
+Calculates the n'th number in the Fibonacci sequence.
+
+=head2 probab_prime
+
+ $x = Math::GMP->new(7);
+ $x->probab_prime(10);
+
+Probabilistically Determines if the number is a prime. Argument is the number
+of checks to perform. Returns 0 if the number is definitely not a prime,
+1 if it may be, and 2 if it is definitely is a prime.
+
+=head1 BUGS
+
+As of version 1.0, Math::GMP is mostly compatible with the old
+Math::BigInt version. It is not a full replacement for the rewritten
+Math::BigInt versions, though. See the L<SEE ALSO section|SEE ALSO>
+on how to achieve to use Math::GMP and retain full compatibility to
+Math::BigInt.
+
+There are some slight incompatibilities, such as output of positive
+numbers not being prefixed by a '+' sign. This is intentional.
+
+There are also some things missing, and not everything might work as
+expected.
+
+=head1 SEE ALSO
+
+Math::BigInt has a new interface to use a different library than the
+default pure Perl implementation. You can use, for instance, Math::GMP
+with it:
+
+ use Math::BigInt lib => 'GMP';
+
+If Math::GMP is not installed, it will fall back to it's own Perl
+implementation.
+
+See L<Math::BigInt> and L<Math::BigInt::GMP> or
+L<Math::BigInt::Pari> or L<Math::BigInt::BitVect>.
+
+=head1 AUTHOR
+
+Chip Turner <chip@redhat.com>, based on the old Math::BigInt by Mark Biggar
+and Ilya Zakharevich. Further extensive work provided by Tels
+<tels@bloodgate.com>.
+
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/Pari.pm b/Master/tlpkg/tlperl.straw/lib/Math/Pari.pm
new file mode 100755
index 00000000000..c199898dde3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/Pari.pm
@@ -0,0 +1,1195 @@
+=head1 NAME
+
+C<Math::Pari> - Perl interface to PARI.
+
+=head1 SYNOPSIS
+
+ use Math::Pari;
+ $a = PARI 2;
+ print $a**10000;
+
+or
+
+ use Math::Pari qw(Mod);
+ $a = Mod(3,5);
+ print $a**10000;
+
+=head1 DESCRIPTION
+
+This package is a Perl interface to famous library PARI for
+numerical/scientific/number-theoretic calculations. It allows use of
+most PARI functions as Perl functions, and (almost) seamless merging
+of PARI and Perl data. In what follows we suppose prior knowledge of
+what PARI is (see L<ftp://megrez.math.u-bordeaux.fr/pub/pari>, or
+L<Math::libPARI>).
+
+=head1 EXPORTed functions
+
+=over 4
+
+=item DEFAULT
+
+By default the package exports functions PARI(), PARIcol(), PARIvar(),
+PARImat() and PARImat_tr() which convert their argument(s) to a
+PARI object. (In fact PARI() is just an alias for C<new Math::Pari>).
+The function PARI() accepts following data as its arguments
+
+=over 17
+
+=item One integer
+
+Is converted to a PARI integer.
+
+=item One float
+
+Is converted to a PARI float.
+
+=item One string
+
+Is executed as a PARI expresion (so should not contain whitespace).
+
+=item PARI object
+
+Is passed unchanged.
+
+=item Reference to a Perl array
+
+Each element is converted using the same rules, PARI vector-row with these
+elements is returned.
+
+=item Several of above
+
+The same as with a reference to array.
+
+=back
+
+=item Conflicts of rules in PARI()
+
+In deciding what rule of the above to apply the preference is given to
+the uppermost choice of those available I<now>. If none matches, then
+the string rule is used. So C<PARI(1)> returns integer, C<PARI(1.)>
+returns float, C<PARI("1")> evaluates C<1> as a PARI expression (well,
+the result is the same as C<PARI(1)>, only slower).
+
+Note that for Perl these data are synonimous, since Perl freely
+converts between integers, float and strings. However, to PARI() only
+what the argument I<is now> is important. If $v is C<1> in the Perl
+world, C<PARI($v)> may convert it to an integer, float, or to the
+result of evaluating the PARI program C<1> (all depending on how $v
+was created and accessed in Perl).
+
+This is a fundamental limitation of creating an interface between two
+systems, both with polymorphic objects, but with subtly different
+semantic of the flavors of these objects. In reality, however, this
+is rarely a problem.
+
+=item PARIcol(), PARImat() and PARImat_tr()
+
+PARIcol() behaves in the same way as PARI() unless given several
+arguments. In the latter case it returns a vector-column instead of
+a vector-row.
+
+PARImat() constructs a matrix out of the given arguments. It will work
+if PARI() will construct a vector of vectors given the same arguments.
+The internal vectors become columns of the matrix. PARImat_tr()
+behaves similarly, but the internal vectors become rows of the matrix.
+
+Since PARI matrices are similar to vector-rows of vector-columns,
+PARImat() is quickier, but PARImat_tr() better corresponds to the PARI
+input and output forms of matrices:
+
+ print PARImat [[1,2], [3,4]]; # prints [1,3;2,4]
+ print PARImat_tr [[1,2], [3,4]]; # prints [1,2;3,4]
+
+=item C<use> with arguments
+
+If arguments are specified in the C<use Math::Pari> directive, the
+PARI functions appearing as arguments are exported in the caller
+context. In this case the function PARI() and friends is not exported,
+so if you need them, you should include them into export list
+explicitely, or include C<:DEFAULT> tag:
+
+ use Math::Pari qw(factorint PARI);
+ use Math::Pari qw(:DEFAULT factorint);
+
+or simply do it in two steps
+
+ use Math::Pari;
+ use Math::Pari 'factorint';
+
+The other tags recognized are C<:PARI>, C<:all>, C<prec=NUMBER>,
+number tags (e.g., C<:4>), overloaded constants tags (C<:int>,
+C<:float>, C<:hex>) and section names tags. The number tags export
+functions from the PARI library from the given class (except for
+C<:PARI>, which exports all of the classes). Tag C<:all> exports all of the
+exportable symbols and C<:PARI>.
+
+Giving C<?> command to C<gp> (B<PARI> calculator) lists the following classes:
+
+ 1: Standard monadic or dyadic OPERATORS
+ 2: CONVERSIONS and similar elementary functions
+ 3: TRANSCENDENTAL functions
+ 4: NUMBER THEORETICAL functions
+ 5: Functions related to ELLIPTIC CURVES
+ 6: Functions related to general NUMBER FIELDS
+ 7: POLYNOMIALS and power series
+ 8: Vectors, matrices, LINEAR ALGEBRA and sets
+ 9: SUMS, products, integrals and similar functions
+ 10: GRAPHIC functions
+ 11: PROGRAMMING under GP
+
+One can use section names instead of number tags. Recognized names are
+
+ :standard :conversions :transcendental :number :elliptic
+ :fields :polynomials :vectors :sums :graphic :programming
+
+One can get the list of all of the functions accessible by C<Math::Pari>,
+or the accessible functions from the given section using listPari() function.
+
+Starting from version 5.005 of Perl, three constant-overload tags are
+supported: C<:int>, C<:float>, C<:hex>. If used, all the
+integer/float/hex-or-octal-or-binary literals in Perl will be automatically
+converted to became PARI objects. For example,
+
+ use Math::Pari ':int';
+ print 2**1000;
+
+is equivalent to
+
+ print PARI(2)**PARI(1000);
+
+(The support for this Perl feature is buggy before the Perl version 5.005_57 -
+unless Perl uses mymalloc options; you can check for this with C<perl
+-V:usemymalloc>.) Note also that (at least with some versions of Perl)
+one should enable C<':float'> for conversion of long integer literals
+(I<Perl> may consider them as floats, since they won't fit into Perl
+integers); note that it is PARI which determines which PARI subtype is
+assigned to each such literal:
+
+ use Math::Pari ':float', 'type_name';
+ print type_name 22222222222222222222222;
+
+prints C<t_INT>.
+
+=back
+
+=head1 Available functions
+
+=head2 Directly accessible from Perl
+
+This package supports I<all> the functions from the PARI library with
+a I<signature> which can be recognized by Math::Pari. This means that
+when you update the PARI library, the newly added functions will we
+available without any change to this package; only a recompile is
+needed. In fact no recompile will be needed if you link libPARI
+dynamically (you need to modify the F<Makefile> manually to do
+this).
+
+You can "reach" unsupported functions via going directly to PARI
+parser using the string flavor of PARI() function, as in
+
+ 3 + PARI('O(x^17)');
+
+For some "unreachable" functions there is a special wrapper functions,
+such as C<O(variable,power)>).
+
+The following functions are specific to GP calculator, thus are not
+available to Math::Pari in any way:
+
+ default error extern input print print1 printp printp1
+ printtex quit read system whatnow write write1 writetex
+
+whatnow() function is useless, since Math::Pari does not support the
+"compatibility" mode (with older PARI library). The functionality of
+print(), write() and variants is available via automatic string
+translation, and pari_print() function and its variants (see L<Printout functions>).
+
+default() is the only important function with functionality not
+supported by the current interface. Note however, that three most
+important default() actions are supported by allocatemem(),
+setprimelimit(), setprecision() and setseriesprecision() functions.
+(When called without arguments, these functions return the current
+values.)
+
+allocatemem($bytes) should not be called from inside Math::Pari
+functions (such as forprimes()).
+
+=head2 Arguments
+
+Arguments to PARI functions are automatically converted to C<long> or
+a PARI object depending on the signature of the actual library function.
+The arguments are I<forced> into the given type, so even if C<gp>
+rejects your code similar to
+
+ func(2.5); # func() takes a long in C
+
+arguing that a particular argument should be of C<type T_INT> (i.e., a
+Pari integer), the corresponding code will work in C<Math::Pari>,
+since 2.5 is silently converted to C<long>, per the function
+signature.
+
+=head2 Return values
+
+PARI functions return a PARI object or a Perl's integer depending on
+what the actual library function returns.
+
+=head2 Additional functions
+
+Some PARI functions are available in C<gp> (i.e., in C<PARI>
+calculator) via infix notation only. In C<Math::Pari> these functions
+are available in functional notations too. Some other convenience
+functions are also made available.
+
+=over 5
+
+=item Infix, prefix and postfix operations
+
+are available under names
+
+ gneg, gadd, gsub, gmul, gdiv, gdivent, gmod, gpui,
+ gle, gge, glt, ggt, geq, gne, gegal, gor, gand,
+ gcmp, gcmp0, gcmp1, gcmp_1.
+
+C<gdivent> means euclidean quotient, C<gpui> is power, C<gegal> checks
+whether two objects are equal, C<gcmp> is applicable to two real
+numbers only, C<gcmp0>, C<gcmp1>, C<gcmp_1> compare with 0, 1 and -1
+correspondingly (see PARI user manual for details, or
+L<Math::libPARI>). Note that all these functions are more readily
+available via operator overloading, so instead of
+
+ gadd(gneg($x), $y)
+
+one can write
+
+ -$x+$y
+
+(as far as overloading may be triggered, see L<overload>, so we assume
+that at least one of $x or $y is a PARI object).
+
+=item Conversion functions
+
+ pari2iv, pari2nv, pari2num, pari2pv, pari2bool
+
+convert a PARI object to an integer, float, integer/float (whatever is
+better), string, and a boolean value correspondingly. Most the time
+you do not need these functions due to automatic conversions.
+
+=item Printout functions
+
+ pari_print, pari_pprint, pari_texprint
+
+perform the same conversions to strings as their PARI counterparts,
+but do not print the result. The difference of pari_print() with
+pari2pv() is the number of significant digits they output, and
+whitespace in the output. pari2pv(), which is intended for
+"computer-readable strings", outputs as many digits as is supported by
+the current precision of the number; while pari_print(), which targets
+human-readable strings, takes into account the currently specified
+output precision too.
+
+=item Constant functions
+
+Some mathematical constants appear as function without arguments in
+PARI. These functions are available in Math::Pari too. If you export
+them as in
+
+ use Math::Pari qw(:DEFAULT Pi I Euler);
+
+they can be used as barewords in your program:
+
+ $x = Pi ** Euler;
+
+=item Low-level functions
+
+For convenience of low-level PARI programmers some low-level functions
+are made available as well (all except type_name() and changevalue()
+are not exportable):
+
+ typ($x)
+ lg($x)
+ lgef($x)
+ lgefint($x)
+ longword($x, $n)
+ type_name($x)
+ changevalue($name,$newvalue)
+
+Here longword($x,$n) returns C<$n>-th word in the memory
+representation of $x (including non-code words). type_name() differs
+from the PARI function type(): type() returns a PARI object, while
+type_name() returns a Perl string. (PARI objects of string type
+behave very non-intuitive w.r.t. string comparison functions; remember
+that they are compared using lex() to I<the results of evaluation> of
+other argument of comparison!)
+
+The function listPari($number) outputs a list of names of PARI
+functions in the section $number. Use listPari(-1) to get the list
+across all of the sections.
+
+=item Uncompatible functions
+
+ O
+
+Since implementing C<O(7**6)> would be very tedious, we provide a
+two-argument form C<O(7,6)> instead (meaning the same as C<O(7^6)> in
+PARI). Note that with polynomials there is no problem like this one,
+both C<O($x,6)> and C<O($x**6)> work.
+
+ ifact(n)
+
+integer factorial functions, available from C<gp> as C<n!>.
+
+=back
+
+=head2 Looping functions
+
+PARI has a big collection of functions which loops over some set.
+Such a function takes two I<special> arguments: loop variable, and the
+code to execute in the loop.
+
+The code can be either a string (which contains PARI code to execute -
+thus should not contain whitespace), or a Perl code reference. The
+loop variable can be a string giving the name of PARI variable (as in
+
+ fordiv(28, 'j', 'a=a+j+j^2');
+
+or
+
+ $j= 'j';
+ fordiv(28, $j, 'a=a+j+j^2');
+
+), a PARI monomial (as in
+
+ $j = PARI 'j';
+ fordiv(28, $j, sub { $a += $j + $j**2 });
+
+), or a "delayed Math::Pari variable" (as in
+
+ $j = PARIvar 'j';
+ fordiv(28, $j, 'a=a+j+j^2');
+
+). If none of these applies, as in
+
+ my $j; # Have this in a separate statement
+ fordiv(28, $j, sub { $a += $j + $j**2 });
+
+then during the execution of the C<sub>, Math::Pari would autogenerate
+a PARI variable, and would put its value in $j; this value of $j is
+temporary only, the old contents of $j is restored when fordiv() returns.
+
+Note that since you have no control over this name, you will not be
+able to use this variable from your PARI code; e.g.,
+
+ $j = 7.8;
+ fordiv(28, $j, 'a=a+j+j^2');
+
+will not make C<j> mirror $j (unless you explicitely set up C<j> to be
+a no-argument PARI function mirroring $j, see L<"Accessing Perl functions from PARI code">).
+
+B<Caveats>. There are 2 flavors of the "code" arguments
+(string/C<sub>), and 4 types of the "variable" arguments
+(string/monomial/C<PARIvar>/other). However, not all 8 combinations
+make sense. As we already explained, an "other" variable cannot work
+with a "string" code.
+
+B<Useless musing alert! Do not read the rest of this section!> Do not
+use "string" variables with C<sub> code, and do not ask I<why>!
+
+Additionally, the following code will not do what you expect
+
+ $x = 0;
+ $j = PARI 'j';
+ fordiv(28, 'j', sub { $x += $j } ); # Use $j as a loop variable!
+
+since the PARI function C<fordiv> I<localizes> the PARI variable C<j>
+inside the loop, but $j will still reference the old value; the old
+value is a monomial, not the index of the loop (which is an integer
+each time C<sub> is called). The simplest workaround is not to use
+the above syntax (i.e., not mixing literal loop variable with Perl
+loop code, just using $j as the second argument to C<fordiv> is
+enough):
+
+ $x = 0;
+ $j = PARI 'j';
+ fordiv(28, $j, sub { $x += $j } );
+
+Alternately, one can make a I<delayed> variable $j which will always
+reference the same thing C<j> references in PARI I<now> by using
+C<PARIvar> constructor
+
+ $x = 0;
+ $j = PARIvar 'j';
+ fordiv(28, 'j', sub { $x += $j } );
+
+(This problem is similar to
+
+ $ref = \$_; # $$ref is going to be old value even after
+ # localizing $_ in Perl's grep/map
+
+not accessing localized values of $_ in the plain Perl.)
+
+Another possible quirk is that
+
+ fordiv(28, my $j, sub { $a += $j + $j**2 });
+
+will not work too - by a different reason. C<my> declarations change
+the I<meaning> of $j only I<after> the end of the current statement;
+thus $j inside C<sub> will access a I<different> variable $j
+(typically a non-lexical, global variable $j) than one you declared on this line.
+
+=head2 Accessing Perl functions from PARI code
+
+Use the same name inside PARI code:
+
+ sub counter { $i += shift; }
+ $i = 145;
+ PARI 'k=5' ;
+ fordiv(28, 'j', 'k=k+counter(j)');
+ print PARI('k'), "\n";
+
+prints
+
+ 984
+
+Due to a difference in the semantic of
+variable-number-of-parameters-functions between PARI and Perl, if the
+Perl subroutine takes a variable number of arguments (via C<@> in the
+prototype or a missing prototype), up to 6 arguments are supported
+when this function is called from PARI. If called from PARI with
+fewer arguments, the rest of arguments will be set to be integers C<PARI 0>.
+
+Note also that no direct import of Perl variables is available yet
+(but you can write a function wrapper for this):
+
+ sub getv () {$v}
+
+There is an unsupported (and undocumented ;-) function for explicitely
+importing Perl functions into PARI, possibly with a different name,
+and possibly with explicitely specifying number of arguments.
+
+=head1 PARI objects
+
+Functions from PARI library may take as arguments and/or return values
+the objects of C type C<GEN>. In Perl these data are encapsulated into
+special kind of Perl variables: PARI objects. You can check for a
+variable C<$obj> to be a PARI object using
+
+ ref $obj and $obj->isa('Math::Pari');
+
+Most the time you do not need this due to automatic conversions and overloading.
+
+=head1 PARI monomials and Perl barewords
+
+If very lazy, one can code in Perl the same way one does it in PARI.
+Variables in PARI are denoted by barewords, as in C<x>, and in the
+default configuration (no warnings, no strict) Perl allows the same -
+up to some extent. Do not do this, since there are many surprising problems.
+
+Some bareletters denote Perl operators, like C<q>, C<x>, C<y>,
+C<s>. This can lead to errors in Perl parsing your expression. E.g.,
+
+ print sin(tan(t))-tan(sin(t))-asin(atan(t))+atan(asin(t));
+
+may parse OK after C<use Math::Pari qw(sin tan asin atan)>. Why?
+
+After importing, the word C<sin> will denote the PARI function sin(),
+not Perl operator sin(). The difference is subtle: the PARI function
+I<implicitly> forces its arguments to be converted PARI objects; it
+gets C<'t'> as the argument, which is a string, thus is converted to
+what C<t> denotes in PARI - a monomial. While the Perl operator sin()
+grants overloading (i.e., it will call PARI function sin() if the
+argument is a PARI object), it does not I<force> its argument; given
+C<'t'> as argument, it converts it to what sin() understands, a float
+(producing C<0.>), so will give C<0.> as the answer.
+
+However
+
+ print sin(tan(y))-tan(sin(y))-asin(atan(y))+atan(asin(y));
+
+would not compile. You should avoid lower-case barewords used as PARI
+variables, e.g., do
+
+ $y = PARI 'y';
+ print sin(tan($y))-tan(sin($y))-asin(atan($y))+atan(asin($y));
+
+to get
+
+ -1/18*y^9+26/4725*y^11-41/1296*y^13+328721/16372125*y^15+O(y^16)
+
+(BTW, it is a very good exercise to get the leading term by hand).
+
+Well, the same advice again: do not use barewords anywhere in your program!
+
+=head1 Overloading and automatic conversion
+
+Whenever an arithmetic operation includes at least one PARI object,
+the other arguments are converted to a PARI object and the corresponding
+PARI library functions is used to implement the operation. Currently
+the following arithmetic operations are overloaded:
+
+ unary -
+ + - * / % ** abs cos sin exp log sqrt
+ << >>
+ <= == => < > != <=>
+ le eq ge lt gt ne cmp
+ | & ^ ~
+
+Numeric comparison operations are converted to C<gcmp> and friends, string
+comparisons compare in lexicographical order using C<lex>.
+
+Additionally, whenever a PARI object appears in a situation that requires integer,
+numeric, boolean or string data, it is converted to the corresponding
+type. Boolean conversion is subject to usual PARI pitfalls related to
+imprecise zeros (see documentation of C<gcmp0> in PARI reference).
+
+For details on overloading, see L<overload>.
+
+Note that a check for equality is subject to same pitfalls as in PARI
+due to imprecise values. PARI may also refuse to compare data of
+different types for equality if it thinks this may lead to
+counterintuitive results.
+
+Note also that in PARI the numeric ordering is not defined for some
+types of PARI objects. For string comparison operations we use
+PARI-lexicographical ordering.
+
+=head1 PREREQUISITES
+
+=head2 Perl
+
+In the versions of perl earlier than 5.003 overloading used a
+different interface, so you may need to convert C<use overload> line
+to C<%OVERLOAD>, or, better, upgrade.
+
+=head2 PARI
+
+Starting from version 2.0, this module comes without a PARI library included.
+
+For the source of PARI library see
+L<ftp://megrez.math.u-bordeaux.fr/pub/pari>.
+
+=head1 Perl vs. PARI: different syntax
+
+Note that the PARI notations should be used in the string arguments to
+PARI() function, while the Perl notations should be used otherwise.
+
+=over 4
+
+=item C<^>
+
+Power is denoted by C<**> in Perl.
+
+=item C<\> and C<\/>
+
+There are no such operators in Perl, use the word forms
+C<gdivent(x,y)> and C<gdivround(x,y)> instead.
+
+=item C<~>
+
+There is no postfix C<~> Perl operator. Use mattranspose() instead.
+
+=item C<'>
+
+There is no postfix C<'> Perl operator. Use deriv() instead.
+
+=item C<!>
+
+There is no postfix C<!> Perl operator. Use factorial()/ifact() instead
+(returning a real or an integer correspondingly).
+
+=item big integers
+
+Perl converts big I<literal> integers to doubles if they could not be
+put into B<C> integers (the particular flavor can be found in the
+output of C<perl -V> in newer version of Perl, look for
+C<ivtype>/C<ivsize>). If you want to input such an integer, use
+
+ while ($x < PARI('12345678901234567890')) ...
+
+instead of
+
+ while ($x < 12345678901234567890) ...
+
+Why? Because conversion to double leads to precision loss (typically
+above 1e15, see L<perlnumber>), and you will get something like
+12345678901234567168 otherwise.
+
+Starting from version 5.005 of Perl, if the tag C<:int> is used on the
+'use Math::Pari' line, all of the integer literals in Perl will be
+automatically converted to became PARI objects. E.g.,
+
+ use Math::Pari ':int';
+ print 2**1000;
+
+is equivalent to
+
+ print PARI(2)**PARI(1000);
+
+Similarly, large integer literals do not lose precision.
+
+This directive is lexically scoped. There is a similar tag C<:hex>
+which affects hexadecimal, octal and binary constants. One may
+also need to use tag C<:float> for auto-conversion of large integer literals
+which Perl considers as floating point literals (see L<C<use> with arguments>
+for details).
+
+=item doubles
+
+Doubles in Perl are typically of precision approximately 15 digits
+(see L<perlnumber>). When you use them as arguments to PARI
+functions, they are converted to PARI real variables, and due to
+intermediate 15-digits-to-binary conversion of Perl variables the
+result may be different than with the PARI many-digits-to-binary
+conversion. E.g., C<PARI(0.01)> and C<PARI('0.01')> differ at 19-th
+place, as
+
+ setprecision(38);
+ print pari_print(0.01), "\n",
+ pari_print('0.01'), "\n";
+
+shows.
+
+Note that setprecision() changes the output format of pari_print() and
+friends, as well as the default internal precision. The generic
+PARI===>string conversion does not take into account the output
+format, thus
+
+ setprecision(38);
+ print PARI(0.01), "\n",
+ PARI('0.01'), "\n",
+ pari_print(0.01), "\n";
+
+will print all the lines with different number of digits after the
+point: the first one with 22, since the double 0.01 was converted to a
+low-precision PARI object, the second one with 41, since internal form
+for precision 38 requires that many digits for representation, and the
+last one with 39 to have 38 significant digits.
+
+Starting from version 5.005 of Perl, if the tag C<:float> is used on
+the C<use Math::Pari> line, all the float literals in Perl will be
+automatically converted to became PARI objects. E.g.,
+
+ use Math::Pari ':float';
+ print atan(1.);
+
+is equivalent to
+
+ print atan(PARI('1.'));
+
+Similarly, large float literals do not lose precision.
+
+This directive is lexically scoped.
+
+=item array base
+
+Arrays are 1-based in PARI, are 0-based in Perl. So while array
+access is possible in Perl, you need to use different indices:
+
+ $nf = PARI 'nf'; # assume that PARI variable nf contains a number field
+ $a = PARI('nf[7]');
+ $b = $nf->[6];
+
+Now $a and $b contain the same value.
+
+=item matrices
+
+Note that C<PARImat([[...],...,[...])> constructor creates a matrix
+with specified columns, while in PARI the command C<[1,2,3;4,5,6]>
+creates a matrix with specified rows. Use a convenience function
+PARImat_tr() which will transpose a matrix created by PARImat() to use
+the same order of elements as in PARI.
+
+=item builtin perl functions
+
+Some PARI functions, like C<length> and C<eval>, are Perl
+(semi-)reserved words. To reach these functions, one should either
+import them:
+
+ use Math::Pari qw(length eval);
+
+or call them with prefix (like C<&length>) or the full name (like
+C<Math::Pari::length>).
+
+=back
+
+=head1 High-resolution graphics
+
+If you have Term::Gnuplot Perl module installed, you may use high-resolution
+graphic primitives of B<PARI>. Before the usage you need to establish
+a link between Math::Pari and Term::Gnuplot by calling link_gnuplot().
+You can change the output filehandle by calling set_plot_fh(), and
+output terminal by calling plotterm(), as in
+
+ use Math::Pari qw(:graphic asin);
+
+ open FH, '>out.tex' or die;
+ link_gnuplot(); # automatically loads Term::Gnuplot
+ set_plot_fh(\*FH);
+ plotterm('emtex');
+ ploth($x, .5, .999, sub {asin $x});
+ close FH or die;
+
+=head1 libPARI documentation
+
+libPARI documentation is included, see L<Math::libPARI>. It is converted
+from Chapter 3 of B<PARI/GP> documentation by the F<gphelp> script of GP/PARI.
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 BUGS
+
+=over 5
+
+=item *
+
+A few of PARI functions are available indirectly only.
+
+=item *
+
+Using overloading constants with the Perl versions below 5.005_57 could lead to
+segfaults (at least without C<-D usemymalloc>), as in:
+
+ use Math::Pari ':int';
+ for ( $i = 0; $i < 10 ; $i++ ) { print "$i\n" }
+
+=item *
+
+It may be possible that conversion of a Perl value which has both the
+integer slot and the floating slot set may create a PARI integer, even
+if the actual value is not an integer.
+
+=item *
+
+problems with refcounting of array elements and Mod().
+
+Workaround: make the modulus live longer than the result of Mod().
+Until Perl version C<5.6.1>, one should exercise a special care so
+that the modulus goes out of scope on a different statement than the
+result:
+
+ { my $modulus = 125;
+ { my $res = Mod(34, $modulus);
+ print $res;
+ }
+ $fake = 1; # A (fake) statement here is required
+ }
+
+Here $res is destructed before the C<$fake = 1> statement, $modulus is
+destructed before the first statement after the provided block.
+However, if you remove the C<$fake = 1> statement, both these
+variables are destructed on the first statement after the provided
+block (and in a wrong order!).
+
+In C<5.6.1> declaring $modulus before $res is all that is needed to
+circumvent the same problem:
+
+ { my $modulus = 125;
+ my $res = Mod(34, $modulus);
+ print $res;
+ } # destruction will happen in a correct order.
+
+Access to array elements may result in similar problems. Hard to fix
+since in PARI the data is not refcounted.
+
+=item *
+
+Legacy implementations of dynalinking require the code of DLL to be
+compiled to be "position independent" code (PIC). This slows down the
+execution, while allowing sharing the loaded copy of the DLL between
+different processes. [On contemeporary architectures the same effect
+is allowed without the position-independent hack.]
+
+Currently, PARI assembler files are not position-independent. When
+compiled for the dynamic linking on legacy systems, this creates a DLL
+which cannot be shared between processes. Some legacy systems are
+reported to recognize this situation, and load the DLL as a non-shared
+module. However, there may be systems (are there?) on which this can
+cause some "problems".
+
+Summary: if the dynaloading on your system requires some kind of C<-fPIC> flag, using "assembler" compiles (anything but C<machine=none>) *may* force you to do a static build (i.e., creation of a custom Perl executable with
+
+ perl Makefile.PL static
+ make perl
+ make test_static
+
+).
+
+=back
+
+=head1 INITIALIZATION
+
+When Math::Pari is loaded, it examines variables $Math::Pari::initmem
+and $Math::Pari::initprimes. They specify up to which number the
+initial list of primes should be precalculated, and how large should
+be the arena for PARI calculations (in bytes). (These values have
+safe defaults.)
+
+Since setting these values before loading requires either a C<BEGIN>
+block, or postponing the loading (C<use> vs. C<require>), it may be
+more convenient to set them via Math::PariInit:
+
+ use Math::PariInit qw( primes=12000000 stack=1e8 );
+
+C<use Math::PariInit> also accepts arbitrary Math::Pari import directives,
+see L<Math::PariInit>.
+
+These values may be changed at runtime too, via allocatemem() and
+setprimelimit(), with performance penalties for recalculation/reallocation.
+
+=head1 AUTHOR
+
+Ilya Zakharevich, I<ilyaz@cpan.org>
+
+=cut
+
+# $Id: Pari.pm,v 1.3 1994/11/25 23:40:52 ilya Exp ilya $
+package Math::Pari::Arr;
+
+#sub TIEARRAY { $_[0] }
+sub STORE { die "Storing into array elements unsupported" }
+
+package Math::Pari;
+
+require Exporter;
+require DynaLoader;
+#use autouse Carp => 'croak';
+
+@ISA = qw(Exporter DynaLoader);
+@Math::Pari::Ep::ISA = qw(Math::Pari);
+
+# Items to export into callers namespace by default
+# (move infrequently used names to @EXPORT_OK below)
+
+@EXPORT = qw(
+PARI PARIcol PARImat PARIvar PARImat_tr
+);
+
+# Other items we are prepared to export if requested (may be extended during
+# ->import. )
+@EXPORT_OK = qw(
+ sv2pari sv2parimat pari2iv pari2nv pari2num pari2pv pari2bool loadPari _bool
+ listPari pari_print pari_pprint pari_texprint O ifact gdivent gdivround
+ changevalue set_plot_fh link_gnuplot setprecision setseriesprecision
+ setprimelimit allocatemem type_name pari2num_
+);
+
+use subs qw(
+ _gneg
+ _gadd
+ _gsub
+ _gmul
+ _gdiv
+ _gmod
+ _gpui
+ _gle
+ _gge
+ _glt
+ _ggt
+ _geq
+ _gne
+ _gcmp
+ _lex
+ _2bool
+ pari2pv
+ pari2num
+ pari2num_
+ _abs
+ _cos
+ _sin
+ _exp
+ _log
+ _sqrt
+ _gbitand
+ _gbitor
+ _gbitxor
+ _gbitneg
+ _to_int
+ _gbitshiftr
+ _gbitshiftl
+); # Otherwise overload->import would complain...
+
+my $two;
+
+sub _shiftl {
+ my ($left,$right) = (shift,shift);
+ ($left,$right) = ($right, $left) if shift;
+ $left * $two**$right;
+}
+
+sub _shiftr {
+ my ($left,$right) = (shift,shift);
+ ($left,$right) = ($right, $left) if shift;
+ floor($left / $two**$right);
+}
+
+$initmem ||= 4000000; # How much memory for the stack
+$initprimes ||= 500000; # Calculate primes up to this number
+
+$VERSION = '2.010801';
+
+my $true = 1;
+# Propagate sv_true, sv_false to SvIOK:
+my $dummy = pack 'ii', $true == 1, $true == 0;
+
+bootstrap Math::Pari;
+
+use overload qw(
+ neg _gneg
+ + _gadd
+ - _gsub
+ * _gmul
+ / _gdiv
+ % _gmod
+ ** _gpui
+ <= _gle
+ >= _gge
+ < _glt
+ > _ggt
+ == _geq
+ != _gne
+ <=> _gcmp
+ cmp _lex
+ bool _2bool
+ "" pari2pv
+ 0+ pari2num_
+ abs _abs
+ cos _cos
+ sin _sin
+ exp _exp
+ log _log
+ sqrt _sqrt
+ int _to_int
+);
+
+if (pari_version_exp() >= 2000018) {
+ 'overload'->import( qw(
+ | _gbitor
+ & _gbitand
+ ^ _gbitxor
+ ~ _gbitneg
+ ) );
+}
+
+if (pari_version_exp() >= 2002001) {
+ 'overload'->import( qw( << _gbitshiftl ) );
+} else {
+ 'overload'->import( qw( << _shiftl ) );
+}
+if (pari_version_exp() >= 2002001 && pari_version_exp() <= 2002007) {
+ 'overload'->import( qw( >> _gbitshiftr ) );
+} else {
+ 'overload'->import( qw( >> _shiftr ) );
+}
+
+sub AUTOLOAD {
+ $AUTOLOAD =~ /^(?:Math::Pari::)?(.*)/;
+ # warn "Autoloading $1...\n";
+ # exit 4 if $1 eq 'loadPari';
+ my $cv = loadPari($1);
+
+# goto &$cv;
+# goto &$AUTOLOAD;
+# &$cv;
+ &$1;
+# &$AUTOLOAD;
+}
+
+# Needed this guy to circumwent autoloading while no XS definition
+
+#### sub DESTROY {}
+
+
+# sub AUTOLOAD {
+# if ((caller(0))[4]) {
+# $AutoLoader::AUTOLOAD = $AUTOLOAD;
+# goto &AutoLoader::AUTOLOAD;
+# }
+# local($constname);
+# ($constname = $AUTOLOAD) =~ s/.*:://;
+# $val = constant($constname, @_ ? $_[0] : 0);
+# if ($! != 0) {
+# if ($! =~ /Invalid/) {
+# $AutoLoader::AUTOLOAD = $AUTOLOAD;
+# goto &AutoLoader::AUTOLOAD;
+# }
+# else {
+# ($pack,$file,$line) = caller;
+# die "Your vendor has not defined Math::Pari macro $constname, used at $file line $line.
+# ";
+# }
+# }
+# eval "sub $AUTOLOAD { $val }";
+# goto &$AUTOLOAD;
+# }
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+sub new {
+ shift;
+ if (@_>1) {my(@t)=@_;return sv2pari(\@t)}
+ return sv2pari(shift);
+}
+
+###sub PARI {new Math::Pari @_}
+
+%names = qw(
+ 1 standard
+ 2 conversions
+ 3 transcendental
+ 4 number
+ 5 elliptic
+ 6 fields
+ 7 polynomials
+ 8 vectors
+ 9 sums
+ 10 graphic
+ 11 programming
+ );
+@sections{values %names} = keys %names;
+
+@converted{split /,\s+/, qq(buchimag, buchreal,
+ buchgen, buchgenforcefu, buchgenfu, buchinit, buchinitforcefu, buchinitfu,
+ plotstring, addhelp, kill)} = (1) x 100;
+
+# Now even tested...
+sub _cvt { PARI(shift) }
+sub _hex_cvt {
+ my $in = shift;
+ my $mult = PARI(1);
+ my $ret = 0;
+ my $shift = 1<<(4*7);
+
+ $in =~ s/^0([xb])?// or die;
+ my $hex = $1;
+ if ($hex and $1 eq 'b') {
+ my $b = '0' x (15 * length($in) % 16) . $in;
+ $hex = '';
+ while ($b) {
+ my $s = substr $b, 0, 16;
+ substr($b, 0, 16) = '';
+ $hex .= unpack 'H4', pack 'B16', $s;
+ }
+ $in = $hex;
+ }
+ $shift = 1<<(3*7) unless $hex;
+ while ($in =~ s/([a-fA-F\d]{1,7})$//) {
+ # In 5.6.0 hex() can return a floating number:
+ my $part = int($hex ? hex $1 : oct $1);
+
+ $ret += $part * $mult;
+ $mult *= $shift;
+ }
+ die "Cannot hex '$in'" if length $in;
+ return $ret;
+}
+%overloaded_const = ( 'int' => \&_cvt, float => \&_cvt, 'hex' => \&_hex_cvt);
+%overloaded_const_word
+ = ( 'int' => 'integer', float => 'float', 'hex' => 'binary');
+
+sub import {
+ my $p=shift;
+ my @consts; # Need to do it outside any block!
+ @_ = map {
+ if (/^:(?!DEFAULT)(.*)/) {
+ my $tag = $1;
+ my $sect = $tag;
+ my @pre;
+ $tag = -1, @pre = (@EXPORT_OK,@EXPORT) if ($tag eq 'all');
+ $tag = -1 if ($tag eq 'PARI');
+ $tag = $sections{$tag} if $tag !~ /^-?\d+$/ and exists $sections{$tag};
+ push @pre, 'link_gnuplot', 'set_plot_fh' if $tag eq 10;
+ if ($tag =~ /^prec=(\d+)$/) {
+ setprecision($1);
+ ();
+ } elsif ($tag =~ /^(int|hex|float)$/) {
+ die "Overloaded constants are not supported in this version of Perl"
+ if $] < 5.004_69;
+ push @const, $overloaded_const_word{$tag} => $overloaded_const{$tag};
+ # print "Constants: $overloaded_const_word{$tag} => $overloaded_const{$tag} \n";
+ ();
+ } elsif (defined $tag and $tag =~ /^-?\d+$/) {
+ (@pre, listPari($tag));
+ } else {
+ die "Unknown section '$sect' specified";
+ }
+ } else {
+ ($_);
+ }
+ } @_;
+
+ overload::constant(splice @const, 0, 2) while @const;
+
+ # print "EXPORT_OK: @EXPORT_OK\n";
+ push @EXPORT_OK,
+ grep( ($_ ne ':DEFAULT'
+ and not $export_ok{$_}++
+ and (eval {loadPari($_), 1} or warn $@), !$@) ,
+ @_);
+ # Invalidate Exporter cache, so that new %EXPORT_OK is noticed:
+ undef %EXPORT;
+ # print "EXPORT_OK: @EXPORT_OK\n";
+ &Exporter::export($p,(caller(0))[0],@_);
+}
+
+sub _can { # Without taking into account inheritance...
+ my ($obj, $meth) = (shift, shift);
+ return \&$meth if defined &$meth;
+ return \&$meth if eval {loadPari($meth), 1};
+ return;
+}
+
+sub can {
+ my ($obj, $meth) = (@_);
+ my $f = $obj->SUPER::can($meth);
+ return $f if defined $f;
+ # There is no "usual" way to get the function; try loadPari()
+ $f = eval { loadPari($meth) };
+ return $f if defined $f;
+ return;
+}
+
+sub O ($;$) {
+ return PARI("O($_[0]^$_[1])") if @_ == 2;
+ return PARI("O($_[0])") if typ($_[0]) == 10; # Poly
+ Carp::croak("O(number**power) not implemented, use O(number,power) instead");
+}
+
+sub PARImat_tr {mattranspose(PARImat(@_))}
+#sub string ($$) {
+# PARI (qq'string($_[0],"$_[1]")');
+#}
+
+sub installPerlFunction {my @a=@_; $a[0] = \&{$a[0]}; installPerlFunctionCV(@a)}
+
+my $name;
+
+for $name (keys %converted) {
+ push @EXPORT_OK, $name;
+ next if defined &$name;
+ # string needs to format numbers to 8.3...
+ if ($name eq 'addhelp' or $name eq 'plotstring') {
+ *$name = sub { PARI ( qq($name($_[0],"$_[1]")) ) }
+ } else {
+ *$name = sub { local $"=','; PARI("$name(@_)") }
+ }
+}
+
+@export_ok{@EXPORT_OK,@EXPORT} = (1) x (@EXPORT_OK + @EXPORT);
+
+sub link_gnuplot {
+ eval 'use Term::Gnuplot 0.56; 1' or die;
+ int_set_term_ftable(Term::Gnuplot::get_term_ftable());
+}
+
+sub set_plot_fh {
+ eval 'use Term::Gnuplot 0.4; 1' or die;
+ Term::Gnuplot::set_gnuplot_fh(@_);
+}
+
+PARI_DEBUG_set($ENV{MATHPARI_DEBUG} || 0);
+$two = PARI(2);
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/PariInit.pm b/Master/tlpkg/tlperl.straw/lib/Math/PariInit.pm
new file mode 100755
index 00000000000..78fb18618cd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/PariInit.pm
@@ -0,0 +1,57 @@
+package Math::Pari;
+
+my %shift = ( k => 10, K => 10, m => 20, M => 20, g => 30, G=> 30);
+
+sub _human2decimal {
+ local $_ = shift;
+ $_ <<= $shift{$1} if s/([kmg])$//i;
+ $_
+}
+
+sub Math::PariInit::import {
+ my $seen;
+ CORE::shift;
+ my @args = map {
+ /^:?(primes|stack)=(\d+((\.\d*)?[eE][-+]?\d+)?)[kKmMgG]?$/
+ ? do { ($1 eq 'primes' ? $initprimes : $initmem) = _human2decimal $2;
+ $seen++;
+ () }
+ : $_
+ } @_;
+ if ($seen && defined &Math::Pari::pari2iv) {
+ require Carp;
+ Carp::croak(
+ "Can't set primelimit and stack size after Math::Pari is loaded")
+ }
+ require Math::Pari;
+ @_ = ('Math::Pari', @args);
+ goto &Math::Pari::import;
+}
+
+1;
+
+=head1 NAME
+
+Math::PariInit - load C<Math::Pari> with specified $primelimit and $initmem.
+
+=head1 SYNOPSIS
+
+ use Math::PariInit qw(:DEFAULT :int primes=1.2e7 stack=1e7 prime)
+ $bigprime = prime(500000);
+
+=head1 DESCRIPTION
+
+C<use Math::PariInit> takes the same arguments as C<use Math::Pari>
+with the addition of C<:primes=I<limit>> and C<:stack=I<bytes>> which
+specify up to which number the initial list of primes should be
+precalculated, and how large should be the arena for PARI calculations.
+
+The arguments C<primes> and C<stack> cannot be specified if
+Math::Pari is already loaded.
+
+=head1 AUTHOR
+
+Ilya Zakharevich L<ilyaz@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/Trig.pm b/Master/tlpkg/tlperl.straw/lib/Math/Trig.pm
new file mode 100755
index 00000000000..b7767bebccb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/Trig.pm
@@ -0,0 +1,768 @@
+#
+# Trigonometric functions, mostly inherited from Math::Complex.
+# -- Jarkko Hietaniemi, since April 1997
+# -- Raphael Manfredi, September 1996 (indirectly: because of Math::Complex)
+#
+
+require Exporter;
+package Math::Trig;
+
+use 5.005;
+use strict;
+
+use Math::Complex 1.56;
+use Math::Complex qw(:trig :pi);
+
+use vars qw($VERSION $PACKAGE @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+@ISA = qw(Exporter);
+
+$VERSION = 1.20;
+
+my @angcnv = qw(rad2deg rad2grad
+ deg2rad deg2grad
+ grad2rad grad2deg);
+
+my @areal = qw(asin_real acos_real);
+
+@EXPORT = (@{$Math::Complex::EXPORT_TAGS{'trig'}},
+ @angcnv, @areal);
+
+my @rdlcnv = qw(cartesian_to_cylindrical
+ cartesian_to_spherical
+ cylindrical_to_cartesian
+ cylindrical_to_spherical
+ spherical_to_cartesian
+ spherical_to_cylindrical);
+
+my @greatcircle = qw(
+ great_circle_distance
+ great_circle_direction
+ great_circle_bearing
+ great_circle_waypoint
+ great_circle_midpoint
+ great_circle_destination
+ );
+
+my @pi = qw(pi pi2 pi4 pip2 pip4);
+
+@EXPORT_OK = (@rdlcnv, @greatcircle, @pi, 'Inf');
+
+# See e.g. the following pages:
+# http://www.movable-type.co.uk/scripts/LatLong.html
+# http://williams.best.vwh.net/avform.htm
+
+%EXPORT_TAGS = ('radial' => [ @rdlcnv ],
+ 'great_circle' => [ @greatcircle ],
+ 'pi' => [ @pi ]);
+
+sub _DR () { pi2/360 }
+sub _RD () { 360/pi2 }
+sub _DG () { 400/360 }
+sub _GD () { 360/400 }
+sub _RG () { 400/pi2 }
+sub _GR () { pi2/400 }
+
+#
+# Truncating remainder.
+#
+
+sub _remt ($$) {
+ # Oh yes, POSIX::fmod() would be faster. Possibly. If it is available.
+ $_[0] - $_[1] * int($_[0] / $_[1]);
+}
+
+#
+# Angle conversions.
+#
+
+sub rad2rad($) { _remt($_[0], pi2) }
+
+sub deg2deg($) { _remt($_[0], 360) }
+
+sub grad2grad($) { _remt($_[0], 400) }
+
+sub rad2deg ($;$) { my $d = _RD * $_[0]; $_[1] ? $d : deg2deg($d) }
+
+sub deg2rad ($;$) { my $d = _DR * $_[0]; $_[1] ? $d : rad2rad($d) }
+
+sub grad2deg ($;$) { my $d = _GD * $_[0]; $_[1] ? $d : deg2deg($d) }
+
+sub deg2grad ($;$) { my $d = _DG * $_[0]; $_[1] ? $d : grad2grad($d) }
+
+sub rad2grad ($;$) { my $d = _RG * $_[0]; $_[1] ? $d : grad2grad($d) }
+
+sub grad2rad ($;$) { my $d = _GR * $_[0]; $_[1] ? $d : rad2rad($d) }
+
+#
+# acos and asin functions which always return a real number
+#
+
+sub acos_real {
+ return 0 if $_[0] >= 1;
+ return pi if $_[0] <= -1;
+ return acos($_[0]);
+}
+
+sub asin_real {
+ return &pip2 if $_[0] >= 1;
+ return -&pip2 if $_[0] <= -1;
+ return asin($_[0]);
+}
+
+sub cartesian_to_spherical {
+ my ( $x, $y, $z ) = @_;
+
+ my $rho = sqrt( $x * $x + $y * $y + $z * $z );
+
+ return ( $rho,
+ atan2( $y, $x ),
+ $rho ? acos_real( $z / $rho ) : 0 );
+}
+
+sub spherical_to_cartesian {
+ my ( $rho, $theta, $phi ) = @_;
+
+ return ( $rho * cos( $theta ) * sin( $phi ),
+ $rho * sin( $theta ) * sin( $phi ),
+ $rho * cos( $phi ) );
+}
+
+sub spherical_to_cylindrical {
+ my ( $x, $y, $z ) = spherical_to_cartesian( @_ );
+
+ return ( sqrt( $x * $x + $y * $y ), $_[1], $z );
+}
+
+sub cartesian_to_cylindrical {
+ my ( $x, $y, $z ) = @_;
+
+ return ( sqrt( $x * $x + $y * $y ), atan2( $y, $x ), $z );
+}
+
+sub cylindrical_to_cartesian {
+ my ( $rho, $theta, $z ) = @_;
+
+ return ( $rho * cos( $theta ), $rho * sin( $theta ), $z );
+}
+
+sub cylindrical_to_spherical {
+ return ( cartesian_to_spherical( cylindrical_to_cartesian( @_ ) ) );
+}
+
+sub great_circle_distance {
+ my ( $theta0, $phi0, $theta1, $phi1, $rho ) = @_;
+
+ $rho = 1 unless defined $rho; # Default to the unit sphere.
+
+ my $lat0 = pip2 - $phi0;
+ my $lat1 = pip2 - $phi1;
+
+ return $rho *
+ acos_real( cos( $lat0 ) * cos( $lat1 ) * cos( $theta0 - $theta1 ) +
+ sin( $lat0 ) * sin( $lat1 ) );
+}
+
+sub great_circle_direction {
+ my ( $theta0, $phi0, $theta1, $phi1 ) = @_;
+
+ my $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1);
+
+ my $lat0 = pip2 - $phi0;
+ my $lat1 = pip2 - $phi1;
+
+ my $direction =
+ acos_real((sin($lat1) - sin($lat0) * cos($distance)) /
+ (cos($lat0) * sin($distance)));
+
+ $direction = pi2 - $direction
+ if sin($theta1 - $theta0) < 0;
+
+ return rad2rad($direction);
+}
+
+*great_circle_bearing = \&great_circle_direction;
+
+sub great_circle_waypoint {
+ my ( $theta0, $phi0, $theta1, $phi1, $point ) = @_;
+
+ $point = 0.5 unless defined $point;
+
+ my $d = great_circle_distance( $theta0, $phi0, $theta1, $phi1 );
+
+ return undef if $d == pi;
+
+ my $sd = sin($d);
+
+ return ($theta0, $phi0) if $sd == 0;
+
+ my $A = sin((1 - $point) * $d) / $sd;
+ my $B = sin( $point * $d) / $sd;
+
+ my $lat0 = pip2 - $phi0;
+ my $lat1 = pip2 - $phi1;
+
+ my $x = $A * cos($lat0) * cos($theta0) + $B * cos($lat1) * cos($theta1);
+ my $y = $A * cos($lat0) * sin($theta0) + $B * cos($lat1) * sin($theta1);
+ my $z = $A * sin($lat0) + $B * sin($lat1);
+
+ my $theta = atan2($y, $x);
+ my $phi = acos_real($z);
+
+ return ($theta, $phi);
+}
+
+sub great_circle_midpoint {
+ great_circle_waypoint(@_[0..3], 0.5);
+}
+
+sub great_circle_destination {
+ my ( $theta0, $phi0, $dir0, $dst ) = @_;
+
+ my $lat0 = pip2 - $phi0;
+
+ my $phi1 = asin_real(sin($lat0)*cos($dst) +
+ cos($lat0)*sin($dst)*cos($dir0));
+
+ my $theta1 = $theta0 + atan2(sin($dir0)*sin($dst)*cos($lat0),
+ cos($dst)-sin($lat0)*sin($phi1));
+
+ my $dir1 = great_circle_bearing($theta1, $phi1, $theta0, $phi0) + pi;
+
+ $dir1 -= pi2 if $dir1 > pi2;
+
+ return ($theta1, $phi1, $dir1);
+}
+
+1;
+
+__END__
+=pod
+
+=head1 NAME
+
+Math::Trig - trigonometric functions
+
+=head1 SYNOPSIS
+
+ use Math::Trig;
+
+ $x = tan(0.9);
+ $y = acos(3.7);
+ $z = asin(2.4);
+
+ $halfpi = pi/2;
+
+ $rad = deg2rad(120);
+
+ # Import constants pi2, pip2, pip4 (2*pi, pi/2, pi/4).
+ use Math::Trig ':pi';
+
+ # Import the conversions between cartesian/spherical/cylindrical.
+ use Math::Trig ':radial';
+
+ # Import the great circle formulas.
+ use Math::Trig ':great_circle';
+
+=head1 DESCRIPTION
+
+C<Math::Trig> defines many trigonometric functions not defined by the
+core Perl which defines only the C<sin()> and C<cos()>. The constant
+B<pi> is also defined as are a few convenience functions for angle
+conversions, and I<great circle formulas> for spherical movement.
+
+=head1 TRIGONOMETRIC FUNCTIONS
+
+The tangent
+
+=over 4
+
+=item B<tan>
+
+=back
+
+The cofunctions of the sine, cosine, and tangent (cosec/csc and cotan/cot
+are aliases)
+
+B<csc>, B<cosec>, B<sec>, B<sec>, B<cot>, B<cotan>
+
+The arcus (also known as the inverse) functions of the sine, cosine,
+and tangent
+
+B<asin>, B<acos>, B<atan>
+
+The principal value of the arc tangent of y/x
+
+B<atan2>(y, x)
+
+The arcus cofunctions of the sine, cosine, and tangent (acosec/acsc
+and acotan/acot are aliases). Note that atan2(0, 0) is not well-defined.
+
+B<acsc>, B<acosec>, B<asec>, B<acot>, B<acotan>
+
+The hyperbolic sine, cosine, and tangent
+
+B<sinh>, B<cosh>, B<tanh>
+
+The cofunctions of the hyperbolic sine, cosine, and tangent (cosech/csch
+and cotanh/coth are aliases)
+
+B<csch>, B<cosech>, B<sech>, B<coth>, B<cotanh>
+
+The area (also known as the inverse) functions of the hyperbolic
+sine, cosine, and tangent
+
+B<asinh>, B<acosh>, B<atanh>
+
+The area cofunctions of the hyperbolic sine, cosine, and tangent
+(acsch/acosech and acoth/acotanh are aliases)
+
+B<acsch>, B<acosech>, B<asech>, B<acoth>, B<acotanh>
+
+The trigonometric constant B<pi> and some of handy multiples
+of it are also defined.
+
+B<pi, pi2, pi4, pip2, pip4>
+
+=head2 ERRORS DUE TO DIVISION BY ZERO
+
+The following functions
+
+ acoth
+ acsc
+ acsch
+ asec
+ asech
+ atanh
+ cot
+ coth
+ csc
+ csch
+ sec
+ sech
+ tan
+ tanh
+
+cannot be computed for all arguments because that would mean dividing
+by zero or taking logarithm of zero. These situations cause fatal
+runtime errors looking like this
+
+ cot(0): Division by zero.
+ (Because in the definition of cot(0), the divisor sin(0) is 0)
+ Died at ...
+
+or
+
+ atanh(-1): Logarithm of zero.
+ Died at...
+
+For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>,
+C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the
+C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the
+C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the
+C<tan>, C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k *
+pi>, where I<k> is any integer.
+
+Note that atan2(0, 0) is not well-defined.
+
+=head2 SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS
+
+Please note that some of the trigonometric functions can break out
+from the B<real axis> into the B<complex plane>. For example
+C<asin(2)> has no definition for plain real numbers but it has
+definition for complex numbers.
+
+In Perl terms this means that supplying the usual Perl numbers (also
+known as scalars, please see L<perldata>) as input for the
+trigonometric functions might produce as output results that no more
+are simple real numbers: instead they are complex numbers.
+
+The C<Math::Trig> handles this by using the C<Math::Complex> package
+which knows how to handle complex numbers, please see L<Math::Complex>
+for more information. In practice you need not to worry about getting
+complex numbers as results because the C<Math::Complex> takes care of
+details like for example how to display complex numbers. For example:
+
+ print asin(2), "\n";
+
+should produce something like this (take or leave few last decimals):
+
+ 1.5707963267949-1.31695789692482i
+
+That is, a complex number with the real part of approximately C<1.571>
+and the imaginary part of approximately C<-1.317>.
+
+=head1 PLANE ANGLE CONVERSIONS
+
+(Plane, 2-dimensional) angles may be converted with the following functions.
+
+=over
+
+=item deg2rad
+
+ $radians = deg2rad($degrees);
+
+=item grad2rad
+
+ $radians = grad2rad($gradians);
+
+=item rad2deg
+
+ $degrees = rad2deg($radians);
+
+=item grad2deg
+
+ $degrees = grad2deg($gradians);
+
+=item deg2grad
+
+ $gradians = deg2grad($degrees);
+
+=item rad2grad
+
+ $gradians = rad2grad($radians);
+
+=back
+
+The full circle is 2 I<pi> radians or I<360> degrees or I<400> gradians.
+The result is by default wrapped to be inside the [0, {2pi,360,400}[ circle.
+If you don't want this, supply a true second argument:
+
+ $zillions_of_radians = deg2rad($zillions_of_degrees, 1);
+ $negative_degrees = rad2deg($negative_radians, 1);
+
+You can also do the wrapping explicitly by rad2rad(), deg2deg(), and
+grad2grad().
+
+=over 4
+
+=item rad2rad
+
+ $radians_wrapped_by_2pi = rad2rad($radians);
+
+=item deg2deg
+
+ $degrees_wrapped_by_360 = deg2deg($degrees);
+
+=item grad2grad
+
+ $gradians_wrapped_by_400 = grad2grad($gradians);
+
+=back
+
+=head1 RADIAL COORDINATE CONVERSIONS
+
+B<Radial coordinate systems> are the B<spherical> and the B<cylindrical>
+systems, explained shortly in more detail.
+
+You can import radial coordinate conversion functions by using the
+C<:radial> tag:
+
+ use Math::Trig ':radial';
+
+ ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z);
+ ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z);
+ ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z);
+ ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z);
+ ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi);
+ ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi);
+
+B<All angles are in radians>.
+
+=head2 COORDINATE SYSTEMS
+
+B<Cartesian> coordinates are the usual rectangular I<(x, y, z)>-coordinates.
+
+Spherical coordinates, I<(rho, theta, pi)>, are three-dimensional
+coordinates which define a point in three-dimensional space. They are
+based on a sphere surface. The radius of the sphere is B<rho>, also
+known as the I<radial> coordinate. The angle in the I<xy>-plane
+(around the I<z>-axis) is B<theta>, also known as the I<azimuthal>
+coordinate. The angle from the I<z>-axis is B<phi>, also known as the
+I<polar> coordinate. The North Pole is therefore I<0, 0, rho>, and
+the Gulf of Guinea (think of the missing big chunk of Africa) I<0,
+pi/2, rho>. In geographical terms I<phi> is latitude (northward
+positive, southward negative) and I<theta> is longitude (eastward
+positive, westward negative).
+
+B<BEWARE>: some texts define I<theta> and I<phi> the other way round,
+some texts define the I<phi> to start from the horizontal plane, some
+texts use I<r> in place of I<rho>.
+
+Cylindrical coordinates, I<(rho, theta, z)>, are three-dimensional
+coordinates which define a point in three-dimensional space. They are
+based on a cylinder surface. The radius of the cylinder is B<rho>,
+also known as the I<radial> coordinate. The angle in the I<xy>-plane
+(around the I<z>-axis) is B<theta>, also known as the I<azimuthal>
+coordinate. The third coordinate is the I<z>, pointing up from the
+B<theta>-plane.
+
+=head2 3-D ANGLE CONVERSIONS
+
+Conversions to and from spherical and cylindrical coordinates are
+available. Please notice that the conversions are not necessarily
+reversible because of the equalities like I<pi> angles being equal to
+I<-pi> angles.
+
+=over 4
+
+=item cartesian_to_cylindrical
+
+ ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z);
+
+=item cartesian_to_spherical
+
+ ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z);
+
+=item cylindrical_to_cartesian
+
+ ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z);
+
+=item cylindrical_to_spherical
+
+ ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z);
+
+Notice that when C<$z> is not 0 C<$rho_s> is not equal to C<$rho_c>.
+
+=item spherical_to_cartesian
+
+ ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi);
+
+=item spherical_to_cylindrical
+
+ ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi);
+
+Notice that when C<$z> is not 0 C<$rho_c> is not equal to C<$rho_s>.
+
+=back
+
+=head1 GREAT CIRCLE DISTANCES AND DIRECTIONS
+
+A great circle is section of a circle that contains the circle
+diameter: the shortest distance between two (non-antipodal) points on
+the spherical surface goes along the great circle connecting those two
+points.
+
+=head2 great_circle_distance
+
+You can compute spherical distances, called B<great circle distances>,
+by importing the great_circle_distance() function:
+
+ use Math::Trig 'great_circle_distance';
+
+ $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1, [, $rho]);
+
+The I<great circle distance> is the shortest distance between two
+points on a sphere. The distance is in C<$rho> units. The C<$rho> is
+optional, it defaults to 1 (the unit sphere), therefore the distance
+defaults to radians.
+
+If you think geographically the I<theta> are longitudes: zero at the
+Greenwhich meridian, eastward positive, westward negative -- and the
+I<phi> are latitudes: zero at the North Pole, northward positive,
+southward negative. B<NOTE>: this formula thinks in mathematics, not
+geographically: the I<phi> zero is at the North Pole, not at the
+Equator on the west coast of Africa (Bay of Guinea). You need to
+subtract your geographical coordinates from I<pi/2> (also known as 90
+degrees).
+
+ $distance = great_circle_distance($lon0, pi/2 - $lat0,
+ $lon1, pi/2 - $lat1, $rho);
+
+=head2 great_circle_direction
+
+The direction you must follow the great circle (also known as I<bearing>)
+can be computed by the great_circle_direction() function:
+
+ use Math::Trig 'great_circle_direction';
+
+ $direction = great_circle_direction($theta0, $phi0, $theta1, $phi1);
+
+=head2 great_circle_bearing
+
+Alias 'great_circle_bearing' for 'great_circle_direction' is also available.
+
+ use Math::Trig 'great_circle_bearing';
+
+ $direction = great_circle_bearing($theta0, $phi0, $theta1, $phi1);
+
+The result of great_circle_direction is in radians, zero indicating
+straight north, pi or -pi straight south, pi/2 straight west, and
+-pi/2 straight east.
+
+=head2 great_circle_destination
+
+You can inversely compute the destination if you know the
+starting point, direction, and distance:
+
+ use Math::Trig 'great_circle_destination';
+
+ # $diro is the original direction,
+ # for example from great_circle_bearing().
+ # $distance is the angular distance in radians,
+ # for example from great_circle_distance().
+ # $thetad and $phid are the destination coordinates,
+ # $dird is the final direction at the destination.
+
+ ($thetad, $phid, $dird) =
+ great_circle_destination($theta, $phi, $diro, $distance);
+
+or the midpoint if you know the end points:
+
+=head2 great_circle_midpoint
+
+ use Math::Trig 'great_circle_midpoint';
+
+ ($thetam, $phim) =
+ great_circle_midpoint($theta0, $phi0, $theta1, $phi1);
+
+The great_circle_midpoint() is just a special case of
+
+=head2 great_circle_waypoint
+
+ use Math::Trig 'great_circle_waypoint';
+
+ ($thetai, $phii) =
+ great_circle_waypoint($theta0, $phi0, $theta1, $phi1, $way);
+
+Where the $way is a value from zero ($theta0, $phi0) to one ($theta1,
+$phi1). Note that antipodal points (where their distance is I<pi>
+radians) do not have waypoints between them (they would have an an
+"equator" between them), and therefore C<undef> is returned for
+antipodal points. If the points are the same and the distance
+therefore zero and all waypoints therefore identical, the first point
+(either point) is returned.
+
+The thetas, phis, direction, and distance in the above are all in radians.
+
+You can import all the great circle formulas by
+
+ use Math::Trig ':great_circle';
+
+Notice that the resulting directions might be somewhat surprising if
+you are looking at a flat worldmap: in such map projections the great
+circles quite often do not look like the shortest routes -- but for
+example the shortest possible routes from Europe or North America to
+Asia do often cross the polar regions. (The common Mercator projection
+does B<not> show great circles as straight lines: straight lines in the
+Mercator projection are lines of constant bearing.)
+
+=head1 EXAMPLES
+
+To calculate the distance between London (51.3N 0.5W) and Tokyo
+(35.7N 139.8E) in kilometers:
+
+ use Math::Trig qw(great_circle_distance deg2rad);
+
+ # Notice the 90 - latitude: phi zero is at the North Pole.
+ sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) }
+ my @L = NESW( -0.5, 51.3);
+ my @T = NESW(139.8, 35.7);
+ my $km = great_circle_distance(@L, @T, 6378); # About 9600 km.
+
+The direction you would have to go from London to Tokyo (in radians,
+straight north being zero, straight east being pi/2).
+
+ use Math::Trig qw(great_circle_direction);
+
+ my $rad = great_circle_direction(@L, @T); # About 0.547 or 0.174 pi.
+
+The midpoint between London and Tokyo being
+
+ use Math::Trig qw(great_circle_midpoint);
+
+ my @M = great_circle_midpoint(@L, @T);
+
+or about 69 N 89 E, in the frozen wastes of Siberia.
+
+B<NOTE>: you B<cannot> get from A to B like this:
+
+ Dist = great_circle_distance(A, B)
+ Dir = great_circle_direction(A, B)
+ C = great_circle_destination(A, Dist, Dir)
+
+and expect C to be B, because the bearing constantly changes when
+going from A to B (except in some special case like the meridians or
+the circles of latitudes) and in great_circle_destination() one gives
+a B<constant> bearing to follow.
+
+=head2 CAVEAT FOR GREAT CIRCLE FORMULAS
+
+The answers may be off by few percentages because of the irregular
+(slightly aspherical) form of the Earth. The errors are at worst
+about 0.55%, but generally below 0.3%.
+
+=head2 Real-valued asin and acos
+
+For small inputs asin() and acos() may return complex numbers even
+when real numbers would be enough and correct, this happens because of
+floating-point inaccuracies. You can see these inaccuracies for
+example by trying theses:
+
+ print cos(1e-6)**2+sin(1e-6)**2 - 1,"\n";
+ printf "%.20f", cos(1e-6)**2+sin(1e-6)**2,"\n";
+
+which will print something like this
+
+ -1.11022302462516e-16
+ 0.99999999999999988898
+
+even though the expected results are of course exactly zero and one.
+The formulas used to compute asin() and acos() are quite sensitive to
+this, and therefore they might accidentally slip into the complex
+plane even when they should not. To counter this there are two
+interfaces that are guaranteed to return a real-valued output.
+
+=over 4
+
+=item asin_real
+
+ use Math::Trig qw(asin_real);
+
+ $real_angle = asin_real($input_sin);
+
+Return a real-valued arcus sine if the input is between [-1, 1],
+B<inclusive> the endpoints. For inputs greater than one, pi/2
+is returned. For inputs less than minus one, -pi/2 is returned.
+
+=item acos_real
+
+ use Math::Trig qw(acos_real);
+
+ $real_angle = acos_real($input_cos);
+
+Return a real-valued arcus cosine if the input is between [-1, 1],
+B<inclusive> the endpoints. For inputs greater than one, zero
+is returned. For inputs less than minus one, pi is returned.
+
+=back
+
+=head1 BUGS
+
+Saying C<use Math::Trig;> exports many mathematical routines in the
+caller environment and even overrides some (C<sin>, C<cos>). This is
+construed as a feature by the Authors, actually... ;-)
+
+The code is not optimized for speed, especially because we use
+C<Math::Complex> and thus go quite near complex numbers while doing
+the computations even when the arguments are not. This, however,
+cannot be completely avoided if we want things like C<asin(2)> to give
+an answer instead of giving a fatal runtime error.
+
+Do not attempt navigation using these formulas.
+
+L<Math::Complex>
+
+=head1 AUTHORS
+
+Jarkko Hietaniemi <F<jhi!at!iki.fi>> and
+Raphael Manfredi <F<Raphael_Manfredi!at!pobox.com>>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+# eof
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/libPARI.dumb.pod b/Master/tlpkg/tlperl.straw/lib/Math/libPARI.dumb.pod
new file mode 100755
index 00000000000..6925a6bc243
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/libPARI.dumb.pod
@@ -0,0 +1,8045 @@
+=head1 NAME
+
+libPARI - Functions and Operations Available in PARI and GP
+
+=head1 DESCRIPTION
+
+X<Label se:functions>
+The functions and operators available in PARI and in the GP/PARI calculator
+are numerous and everexpanding. Here is a description of the ones available
+in version B<2.2.0>. It should be noted that many of these functions accept
+quite different types as arguments, but others are more restricted. The list
+of acceptable types will be given for each function or class of functions.
+Except when stated otherwise, it is understood that a function or operation
+which should make natural sense is legal. In this chapter, we will describe
+the functions according to a rough classification. The general entry looks
+something like:
+
+B<foo>C<(x,{>I<flag>C< = 0})>: short description.
+
+X<foo>The library syntax is B<foo>C<(x,>I<flag>C<)>.
+
+This means that the GP function C<foo> has one mandatory argument C<x>, and
+an optional one, I<flag>, whose default value is 0 (the C<{}> should never be
+typed, it is just a convenient notation we will use throughout to denote
+optional arguments). That is, you can type C<foo(x,2)>, or C<foo(x)>,
+which is then understood to mean C<foo(x,0)>. As well, a comma or closing
+parenthesis, where an optional argument should have been, signals to GP it
+should use the default. Thus, the syntax C<foo(x,)> is also accepted as a
+synonym for our last expression. When a function has more than one optional
+argument, the argument list is filled with user supplied values, in order.
+And when none are left, the defaults are used instead. Thus, assuming that
+C<foo>'s prototype had been
+
+S< >
+B<foo>C<({x = 1},{y = 2},{z = 3}),
+>
+
+typing in C<foo(6,4)> would give
+you C<foo(6,4,3)>. In the rare case when you want to set some far away
+flag, and leave the defaults in between as they stand, you can use the
+``empty arg'' trick alluded to above: C<foo(6,,1)> would yield
+C<foo(6,2,1)>. By the way, C<foo()> by itself yields
+C<foo(1,2,3)> as was to be expected. In this rather special case of a
+function having no mandatory argument, you can even omit the C<()>: a
+standalone C<foo> would be enough (though we don't really recommend it for
+your scripts, for the sake of clarity). In defining GP syntax, we strove
+to put optional arguments at the end of the argument list (of course, since
+they would not make sense otherwise), and in order of decreasing usefulness
+so that, most of the time, you will be able to ignore them.
+
+B<Binary Flags>.X<binary flag> For some of these optional
+flags, we adopted the customary binary notation as a compact way to
+represent many toggles with just one number. Letting C<(p_0,...,p_n)> be a
+list of switches (i.e.S< >of properties which can be assumed to take either
+the value C<0> orS< >C<1>), the number C<2^3 + 2^5 = 40> means that C<p_3> and C<p_5>
+have been set (that is, set to C<1>), and none of the others were (that is,
+they were set to 0). This will usually be announced as ``The binary digits
+of I<flag> mean 1: C<p_0>, 2: C<p_1>, 4: C<p_2>'', and so on, using the
+available consecutive powers ofS< >C<2>.
+
+B<Pointers>.X<pointer> If a parameter in the function
+prototype is prefixed with a & sign, as in
+
+B<foo>C<(x,&e)>
+
+it means that, besides the normal return value, the variable named
+C<e> may be set as a side effect. When passing the argument, the & sign has
+to be typed in explicitly. As of version B<2.2.0>, this X<pointer>C<pointer> argument
+is optional for all documented functions, hence the & will always appear
+between brackets as in C<issquare>C<(x,{&e})>.
+
+B<About library programming>. To finish with our generic
+simple-minded example, the I<library> function C<foo>, as defined
+above, is seen to have two mandatory arguments, C<x> and I<flag> (no PARI
+mathematical function has been implemented so as to accept a variable
+number of arguments). When not mentioned otherwise, the result and
+arguments of a function are assumed implicitly to be of type C<GEN>.
+Most other functions return an object of type C<long> integer in C (see
+ChapterS< >4). The variable or parameter names I<prec> and I<flag> always
+denote C<long> integers.
+
+The X<entree>C<entree> type is used by the library to implement iterators (loops,
+sums, integrals, etc.) when a formal variable has to successively assume a
+number of values in a given set. When programming with the library, it is
+easier and much more efficient to code loops and the like directly. Hence
+this type is not documented, although it does appear in a few library
+function prototypes below. See L<Label se:sums> for more details.
+
+=head1 Standard monadic or dyadic operators
+
+=head2 +C</>-
+
+The expressions C<+>C<x> and C<->C<x> refer
+to monadic operators (the first does nothing, the second negates C<x>).
+
+X<gneg>The library syntax is B<gneg>C<(x)> for C<->C<x>.
+
+=head2 +, C<->
+
+The expression C<x> C<+> C<y> is the X<sum>sum and
+C<x> C<-> C<y> is the X<difference>difference of C<x> and C<y>. Among the prominent
+impossibilities are addition/subtraction between a scalar type and a vector
+or a matrix, between vector/matrices of incompatible sizes and between an
+integermod and a real number.
+
+X<gadd>The library syntax is B<gadd>C<(x,y)> C<x> C<+> C<y>, X<gsub>B<gsub>C<(x,y)> for C<x> C<-> C<y>.
+
+=head2 *
+
+The expression C<x> C<*> C<y> is the X<product>product of C<x>
+and C<y>. Among the prominent impossibilities are multiplication between
+vector/matrices of incompatible sizes, between an integermod and a real
+number. Note that because of vector and matrix operations, C<*> is not
+necessarily commutative. Note also that since multiplication between two
+column or two row vectors is not allowed, to obtain the X<scalar product>scalar product
+of two vectors of the same length, you must multiply a line vector by a
+column vector, if necessary by transposing one of the vectors (using
+the operator C<~> or the function C<mattranspose>, see
+L<Label se:linear_algebra>).
+
+If C<x> and C<y> are binary quadratic forms, compose them. See also
+C<qfbnucomp> and C<qfbnupow>.
+
+X<gmul>The library syntax is B<gmul>C<(x,y)> for C<x> C<*> C<y>. Also available is
+X<gsqr>B<gsqr>C<(x)> for C<x> C<*> C<x> (faster of course!).
+
+=head2 /
+
+The expression C<x> C</> C<y> is the X<quotient>quotient of C<x>
+and C<y>. In addition to the impossibilities for multiplication, note that if
+the divisor is a matrix, it must be an invertible square matrix, and in that
+case the result is C<x*y^{-1}>. Furthermore note that the result is as exact
+as possible: in particular, division of two integers always gives a rational
+number (which may be an integer if the quotient is exact) and I<not> the
+Euclidean quotient (see C<x> C<\> C<y> for that), and similarly the
+quotient of two polynomials is a rational function in general. To obtain the
+approximate real value of the quotient of two integers, add C<0.> to the
+result; to obtain the approximate C<p>-adic value of the quotient of two
+integers, add C<O(p^k)> to the result; finally, to obtain the
+X<Taylor series>Taylor series expansion of the quotient of two polynomials, add
+C<O(X^k)> to the result or use the C<taylor> function
+(see L<Label se:taylor>). X<Label se:gdiv>
+
+X<gdiv>The library syntax is B<gdiv>C<(x,y)> for C<x> C</> C<y>.
+
+=head2 \
+
+The expression C<x> C<\> C<y> is the
+
+X<Euclidean quotient>Euclidean quotient of C<x> and C<y>. The types must be either both
+integer or both polynomials. The result is the Euclidean quotient. In the
+case of integer division, the quotient is such that the corresponding
+remainder is non-negative.
+
+X<gdivent>The library syntax is B<gdivent>C<(x,y)> for C<x> C<\> C<y>.
+
+=head2 \/
+
+The expression C<x> C<\/> C<y> is the Euclidean
+quotient of C<x> and C<y>. The types must be either both integer or both
+polynomials. The result is the rounded Euclidean quotient. In the case of
+integer division, the quotient is such that the corresponding remainder is
+smallest in absolute value and in case of a tie the quotient closest to
+C<+ oo > is chosen.
+
+X<gdivround>The library syntax is B<gdivround>C<(x,y)> for C<x> C<\/> C<y>.
+
+=head2 %
+
+The expression C<x> C<%> C<y> is the
+
+X<Euclidean remainder>Euclidean remainder of C<x> and C<y>. The modulus C<y> must be of type
+integer or polynomial. The result is the remainder, always non-negative in
+the case of integers. Allowed dividend types are scalar exact types when
+the modulus is an integer, and polynomials, polmods and rational functions
+when the modulus is a polynomial.
+
+X<gmod>The library syntax is B<gmod>C<(x,y)> for C<x> C<%> C<y>.
+
+=head2 X<divrem>divremC<(x,y)>
+
+creates a column vector with two components,
+the first being the Euclidean quotient, the second the Euclidean remainder,
+of the division of C<x> by C<y>. This avoids the need to do two divisions if
+one needs both the quotient and the remainder. The arguments must be both
+integers or both polynomials; in the case of integers, the remainder is
+non-negative.
+
+X<gdiventres>The library syntax is B<gdiventres>C<(x,y)>.
+
+=head2 ^
+
+The expression C<x^n> is X<powering>powering.
+If the exponent is an integer, then exact operations are performed using
+binary (left-shift) powering techniques. In particular, in this case C<x>
+cannot be a vector or matrix unless it is a square matrix (and moreover
+invertible if the exponent is negative). If C<x> is a C<p>-adic number, its
+precision will increase if C<v_p(n) E<gt> 0>. PARI is able to rewrite the
+multiplication C<x * x> of two I<identical> objects as C<x^2>, or
+C<sqr(x)> (here, identical means the operands are two different labels
+referencing the same chunk of memory; no equality test is performed). This
+is no longer true when more than two arguments are involved.
+
+If the exponent is not of type integer, this is treated as a transcendental
+function (see L<Label se:trans>), and in particular has the effect of
+componentwise powering on vector or matrices.
+
+As an exception, if the exponent is a rational number C<p/q> and C<x> an
+integer modulo a prime, return a solution C<y> of C<y^q = x^p> if it
+exists. Currently, C<q> must not have large prime factors.
+
+Beware that
+
+ ? Mod(7,19)^(1/2)
+ %1 = Mod(11, 19)/*is any square root*/
+ ? sqrt(Mod(7,19))
+ %2 = Mod(8, 19)/*is the smallest square root*/
+ ? Mod(7,19)^(3/5)
+ %3 = Mod(1, 19)
+ ? %3^(5/3)
+ %4 = Mod(1, 19)/*Mod(7,19) is just another cubic root*/
+
+X<gpow>The library syntax is B<gpow>C<(x,n,>I<prec>C<)> for C<x^n>.
+
+=head2 X<shift>shiftC<(x,n)> or C<x> C<E<lt>E<lt> > C<n> ( = C<x> C<E<gt>E<gt> > C<(-n)>)
+
+shifts
+C<x> componentwise left by C<n> bits if C<n E<gt>= 0> and right by C<|n|> bits if
+C<n E<lt> 0>. A left shift by C<n> corresponds to multiplication by C<2^n>. A right
+shift of an integer C<x> by C<|n|> corresponds to a Euclidean division of
+C<x> by C<2^{|n|}> with a
+remainder of the same sign as C<x>, hence is not the same (in general) as
+C<x \ 2^n>.
+
+X<gshift>The library syntax is B<gshift>C<(x,n)> where C<n> is a C<long>.
+
+=head2 X<shiftmul>shiftmulC<(x,n)>
+
+multiplies C<x> by C<2^n>. The difference with
+C<shift> is that when C<n E<lt> 0>, ordinary division takes place, hence for
+example if C<x> is an integer the result may be a fraction, while for
+C<shift> Euclidean division takes place when C<n E<lt> 0> hence if C<x> is an
+integer the result is still an integer.
+
+X<gmul2n>The library syntax is B<gmul2n>C<(x,n)> where C<n> is a C<long>.
+
+=head2 Comparison and boolean operators
+
+X<boolean operators>
+The six standard X<comparison operators>comparison operators C<E<lt>= >, C<E<lt> >, C<E<gt>= >,
+C<E<gt> >, C< == >, C<! = > are available in GP, and in library mode under
+the names X<gle>B<gle>, X<glt>B<glt>, X<gge>B<gge>, X<ggt>B<ggt>, X<geq>B<geq>, X<gne>B<gne>
+respectively. The library syntax is I<co>C<(x,y)>, where I<co> is the
+comparison operator. The result is 1 (as a C<GEN>) if the comparison is
+true, 0 (as a C<GEN>) if it is false.
+
+The standard boolean functions C<||> (X<inclusive or>inclusive or), C<&&>
+(X<and>and)X<or> and C<!> (X<not>not) are also available, and the
+library syntax is X<gor>B<gor>C<(x,y)>, X<gand>B<gand>C<(x,y)> and X<gnot>B<gnot>C<(x)>
+respectively.
+
+In library mode, it is in fact usually preferable to use the two basic
+functions which are X<gcmp>B<gcmp>C<(x,y)> which gives the sign (1, 0, or -1) of
+C<x-y>, where C<x> and C<y> must be in B<R>, and X<gegal>B<gegal>C<(x,y)> which
+can be applied to any two PARI objects C<x> and C<y> and gives 1 (i.e.S< >true) if
+they are equal (but not necessarily identical), 0 (i.e.S< >false) otherwise.
+Particular cases of X<gegal>B<gegal> which should be used are X<gcmp0>B<gcmp0>C<(x)>
+(C<x == 0> ?), X<gcmp1>B<gcmp1>C<(x)> (C<x == 1> ?), and
+X<gcmp_1>B<gcmp_1>C<(x)> (C<x == -1> ?).
+
+Note that X<gcmp0>B<gcmp0>C<(x)> tests whether C<x> is equal to zero, even if C<x> is
+not an exact object. To test whether C<x> is an exact object which is equal to
+zero, one must use X<isexactzero>B<isexactzero>.
+
+Also note that the C<gcmp> and C<gegal> functions return a C-integer,
+and I<not> a C<GEN> like C<gle> etc.
+
+GP accepts the following synonyms for some of the above functions: since we
+thought it might easily lead to confusion, we don't use the customary C
+operators for bitwise C<and> or bitwise C<or> (use X<bitand>C<bitand> or
+X<bitor>C<bitor>), hence C<|> and C<&> are accepted as
+X<bitwise and>X<bitwise or> synonyms of C<||> and C<&&> respectively.
+Also, C<E<lt> E<gt> > is accepted as a synonym for C<! = >. On the other hand,
+C< = > is definitely I<not> a synonym for C< == > since it is the
+assignment statement.
+
+=head2 X<lex>lexC<(x,y)>
+
+gives the result of a lexicographic comparison
+between C<x> and C<y>. This is to be interpreted in quite a wide sense. For
+example, the vector C<[1,3]> will be considered smaller than the longer
+vector C<[1,3,-1]> (but of course larger than C<[1,2,5]>),
+i.e.S< >C<lex([1,3], [1,3,-1])> will return C<-1>.
+
+X<lexcmp>The library syntax is B<lexcmp>C<(x,y)>.
+
+=head2 X<sign>signC<(x)>
+
+X<sign>sign (C<0>, C<1> or C<-1>) of C<x>, which must be of
+type integer, real or fraction.
+
+X<gsigne>The library syntax is B<gsigne>C<(x)>. The result is a C<long>.
+
+=head2 X<max>maxC<(x,y)> and X<min>B<min>C<(x,y)>
+
+creates the
+maximum and minimum of C<x> and C<y> when they can be compared.
+
+X<gmax>The library syntax is B<gmax>C<(x,y)> and X<gmin>B<gmin>C<(x,y)>.
+
+=head2 X<vecmax>vecmaxC<(x)>
+
+if C<x> is a vector or a matrix, returns the maximum
+of the elements of C<x>, otherwise returns a copy of C<x>. Returns C<- oo >
+in the form of C<-(2^{31}-1)> (or C<-(2^{63}-1)> for 64-bit machines) if C<x> is
+empty.
+
+X<vecmax>The library syntax is B<vecmax>C<(x)>.
+
+=head2 X<vecmin>vecminC<(x)>
+
+if C<x> is a vector or a matrix, returns the minimum
+of the elements of C<x>, otherwise returns a copy of C<x>. Returns C<+ oo >
+in the form of C<2^{31}-1> (or C<2^{63}-1> for 64-bit machines) if C<x> is empty.
+
+X<vecmin>The library syntax is B<vecmin>C<(x)>.
+
+=head1 Conversions and similar elementary functions or commands
+
+X<Label se:conversion>
+Many of the conversion functions are rounding or truncating operations. In
+this case, if the argument is a rational function, the result is the
+Euclidean quotient of the numerator by the denominator, and if the argument
+is a vector or a matrix, the operation is done componentwise. This will not
+be restated for every function.
+
+=head2 X<List>ListC<({x = []})>
+
+transforms a (row or column) vector C<x>
+into a list. The only other way to create a C<t_LIST> is to use the
+function C<listcreate>.
+
+This is useless in library mode.
+
+=head2 X<Mat>MatC<({x = []})>
+
+transforms the object C<x> into a matrix.
+If C<x> is not a vector or a matrix, this creates a C<1 x 1> matrix.
+If C<x> is a row (resp. column) vector, this creates a 1-row (resp.
+1-column) matrix. If C<x> is already a matrix, a copy of C<x> is created.
+
+This function can be useful in connection with the function C<concat>
+(see there).
+
+X<gtomat>The library syntax is B<gtomat>C<(x)>.
+
+=head2 X<Mod>ModC<(x,y,{>I<flag>C< = 0})>
+
+X<Label se:Mod> creates the PARI object
+C<(x mod y)>, i.e.S< >an integermod or a polmod. C<y> must be an integer or a
+polynomial. If C<y> is an integer, C<x> must be an integer, a rational
+number, or a C<p>-adic number compatible with the modulus C<y>. If C<y> is a
+polynomial, C<x> must be a scalar (which is not a polmod), a polynomial, a
+rational function, or a power series.
+
+This function is not the same as C<x> C<%> C<y>, the result of which is an
+integer or a polynomial.
+
+If I<flag> is equal to C<1>, the modulus of the created result is put on the
+heap and not on the stack, and hence becomes a permanent copy which cannot be
+erased later by garbage collecting (see L<Label se:garbage>). Functions
+will operate faster on such objects and memory consumption will be lower.
+On the other hand, care should be taken to avoid creating too many such
+objects.
+
+Under GP, the same effect can be obtained by assigning the object to a GP
+variable (the value of which is a permanent object for the duration of the
+relevant library function call, and is treated as such). This value is
+subject to garbage collection, since it will be deleted when the value
+changes. This is preferable and the above flag is only retained for
+compatibility reasons (it can still be useful in library mode).
+
+X<Mod0>The library syntax is B<Mod0>C<(x,y,>I<flag>C<)>. Also available are
+
+B<*> for I<flag>C< = 1>: X<gmodulo>B<gmodulo>C<(x,y)>.
+
+B<*> for I<flag>C< = 0>: X<gmodulcp>B<gmodulcp>C<(x,y)>.
+
+=head2 X<Pol>PolC<(x,{v = x})>
+
+transforms the object C<x> into a polynomial with
+main variable C<v>. If C<x> is a scalar, this gives a constant polynomial. If
+C<x> is a power series, the effect is identical to C<truncate> (see there),
+i.e.S< >it chops off the C<O(X^k)>. If C<x> is a vector, this function creates
+the polynomial whose coefficients are given in C<x>, with C<x[1]> being the
+leading coefficient (which can be zero).
+
+Warning: this is I<not> a substitution function. It is intended to be
+quick and dirty. So if you try C<Pol(a,y)> on the polynomial C<a = x+y>,
+you will get C<y+y>, which is not a valid PARI object.
+
+X<gtopoly>The library syntax is B<gtopoly>C<(x,v)>, where C<v> is a variable number.
+
+=head2 X<Polrev>PolrevC<(x,{v = x})>
+
+transform the object C<x> into a polynomial
+with main variable C<v>. If C<x> is a scalar, this gives a constant polynomial.
+If C<x> is a power series, the effect is identical to C<truncate> (see
+there), i.e.S< >it chops off the C<O(X^k)>. If C<x> is a vector, this function
+creates the polynomial whose coefficients are given in C<x>, with C<x[1]> being
+the constant term. Note that this is the reverse of C<Pol> if C<x> is a
+vector, otherwise it is identical to C<Pol>.
+
+X<gtopolyrev>The library syntax is B<gtopolyrev>C<(x,v)>, where C<v> is a variable number.
+
+=head2 X<Qfb>QfbC<(a,b,c,{D = 0.})>
+
+creates the binary quadratic form
+C<ax^2+bxy+cy^2>. If C<b^2-4ac E<gt> 0>, initialize X<Shanks>Shanks' distance
+function to C<D>.
+
+X<Qfb0>The library syntax is B<Qfb0>C<(a,b,c,D,>I<prec>C<)>. Also available are
+X<qfi>B<qfi>C<(a,b,c)> (when C<b^2-4ac E<lt> 0>), and
+X<qfr>B<qfr>C<(a,b,c,d)> (when C<b^2-4ac E<gt> 0>).X<binary quadratic form>
+
+=head2 X<Ser>SerC<(x,{v = x})>
+
+transforms the object C<x> into a power series
+with main variable C<v> (C<x> by default). If C<x> is a scalar, this gives a
+constant power series with precision given by the default C<serieslength>
+(corresponding to the C global variable C<precdl>). If C<x> is a
+polynomial, the precision is the greatest of C<precdl> and the degree of
+the polynomial. If C<x> is a vector, the precision is similarly given, and the
+coefficients of the vector are understood to be the coefficients of the power
+series starting from the constant term (i.e.S< >the reverse of the function
+C<Pol>).
+
+The warning given for C<Pol> applies here: this is not a substitution
+function.
+
+X<gtoser>The library syntax is B<gtoser>C<(x,v)>, where C<v> is a variable number (i.e.S< >a C integer).
+
+=head2 X<Set>SetC<({x = []})>
+
+converts C<x> into a set, i.e.S< >into a row vector
+with strictly increasing entries. C<x> can be of any type, but is most useful
+when C<x> is already a vector. The components of C<x> are put in canonical form
+(type C<t_STR>) so as to be easily sorted. To recover an ordinary C<GEN>
+from such an element, you can apply X<eval>C<eval> to it.
+
+X<gtoset>The library syntax is B<gtoset>C<(x)>.
+
+=head2 X<Str>StrC<({x = ""},{>I<flag>C< = 0})>
+
+converts C<x> into a
+character string (type C<t_STR>, the empty string if C<x> is omitted). To
+recover an ordinary C<GEN> from a string, apply C<eval> to it. The
+arguments of C<Str> are evaluated in string context (see
+L<Label se:strings>). If I<flag> is set, treat C<x> as a filename and perform
+X<environment expansion>environment expansion on the string. This feature can be used to read
+X<environment variable>environment variable values.
+
+ ? i = 1; Str("x" i)
+ %1 = "x1"
+ ? eval(%)
+ %2 = x1;
+ ? Str("$HOME", 1)
+ %3 = "/home/pari"
+
+X<strtoGENstr>The library syntax is B<strtoGENstr>C<(x,>I<flag>C<)>. This function is mostly useless in library mode. Use
+the pair X<strtoGEN>C<strtoGEN>/X<GENtostr>C<GENtostr> to convert between C<char*> and
+C<GEN>.
+
+=head2 X<Vec>VecC<({x = []})>
+
+transforms the object C<x> into a row vector. The
+vector will be with one component only, except when C<x> is a vector/matrix or
+a quadratic form (in which case the resulting vector is simply the initial
+object considered as a row vector), but more importantly when C<x> is a
+polynomial or a power series. In the case of a polynomial, the coefficients
+of the vector start with the leading coefficient of the polynomial, while
+for power series only the significant coefficients are taken into account,
+but this time by increasing order of degree.
+
+X<gtovec>The library syntax is B<gtovec>C<(x)>.
+
+=head2 X<binary>binaryC<(x)>
+
+outputs the vector of the binary digits of C<|x|>.
+Here C<x> can be an integer, a real number (in which case the result has two
+components, one for the integer part, one for the fractional part) or a
+vector/matrix.
+
+X<binaire>The library syntax is B<binaire>C<(x)>.
+
+=head2 X<bitand>bitandC<(x,y)>
+
+bitwise X<and>C<and>X<bitwise and> of two
+integers C<x> and C<y>, that is the integer
+
+S< >F<sum>C< (x_iS< >andS< >y_i) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitand>The library syntax is B<gbitand>C<(x,y)>.
+
+=head2 X<bitneg>bitnegC<(x,{n = -1})>
+
+X<bitwise negation>bitwise negation of an integer C<x>,
+truncated to C<n> bits, that is the integer
+
+S< >F<sum>C<_{i = 0}^n not(x_i) 2^i>
+
+The special case C<n = -1> means no truncation: an infinite sequence of
+leading C<1> is then represented as a negative number.
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitneg>The library syntax is B<gbitneg>C<(x)>.
+
+=head2 X<bitnegimply>bitnegimplyC<(x,y)>
+
+bitwise negated imply of two integers C<x>
+and C<y> (or C<not> C<(x ==E<gt> y)>), that is the integer
+
+S< >F<sum>C< (x_iS< >and not(y_i)) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitnegimply>The library syntax is B<gbitnegimply>C<(x,y)>.
+
+=head2 X<bitor>bitorC<(x,y)>
+
+bitwise (inclusive) X<or>C<or>
+X<bitwise inclusive or> of two integers C<x> and C<y>, that is the integer
+
+S< >F<sum>C< (x_iS< >orS< >y_i) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitor>The library syntax is B<gbitor>C<(x,y)>.
+
+=head2 X<bittest>bittestC<(x,n)>
+
+outputs the C<n^{th}> bit of C<|x|> starting
+from the right (i.e.S< >the coefficient of C<2^n> in the binary expansion of C<x>).
+The result is 0 or 1. To extract several bits at once as a vector, pass a
+vector for C<n>.
+
+X<bittest>The library syntax is B<bittest>C<(x,n)>, where C<n> and the result are C<long>s.
+
+=head2 X<bitxor>bitxorC<(x,y)>
+
+bitwise (exclusive) X<or>C<or>
+X<bitwise exclusive or> of two integers C<x> and C<y>, that is the integer
+
+S< >F<sum>C< (x_iS< >xorS< >y_i) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitxor>The library syntax is B<gbitxor>C<(x,y)>.
+
+=head2 X<ceil>ceilC<(x)>
+
+ceiling of C<x>. When C<x> is in B<R>,
+the result is the smallest integer greater than or equal to C<x>. Applied to a
+rational function, C<ceil(x)> returns the euclidian quotient of the
+numerator by the denominator.
+
+X<gceil>The library syntax is B<gceil>C<(x)>.
+
+=head2 X<centerlift>centerliftC<(x,{v})>
+
+lifts an element C<x = a mod n> of B<Z>C</n>B<Z>
+to C<a> in B<Z>, and similarly lifts a polmod to a polynomial. This is the
+same as C<lift> except that in the particular case of elements of
+B<Z>C</n>B<Z>, the lift C<y> is such that C<-n/2 E<lt> y E<lt>= n/2>. If C<x> is of type
+fraction, complex, quadratic, polynomial, power series, rational function,
+vector or matrix, the lift is done for each coefficient. Real and C<p>-adics
+are forbidden.
+
+X<centerlift0>The library syntax is B<centerlift0>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded
+as C<-1>. Also available is X<centerlift>B<centerlift>C<(x)> = C<centerlift0(x,-1)>.
+
+=head2 X<changevar>changevarC<(x,y)>
+
+creates a copy of the object C<x> where its
+variables are modified according to the permutation specified by the vector
+C<y>. For example, assume that the variables have been introduced in the
+order C<x>, C<a>, C<b>, C<c>. Then, if C<y> is the vector
+C<[x,c,a,b]>, the variable C<a> will be replaced by C<c>, C<b> by
+C<a>, and C<c> by C<b>, C<x> being unchanged. Note that the
+permutation must be completely specified, e.g.S< >C<[c,a,b]> would not work,
+since this would replace C<x> by C<c>, and leave C<a> and C<b>
+unchanged (as well as C<c> which is the fourth variable of the initial
+list). In particular, the new variable names must be distinct.
+
+X<changevar>The library syntax is B<changevar>C<(x,y)>.
+
+=head2 components of a PARI object
+
+There are essentially three ways to extract the X<components>components from a PARI
+object.
+
+The first and most general, is the function X<component>B<component>C<(x,n)> which
+extracts the C<n^{th}>-component of C<x>. This is to be understood as
+follows: every PARI type has one or two initial X<code words>code words. The
+components are counted, starting at 1, after these code words. In particular
+if C<x> is a vector, this is indeed the C<n^{th}>-component of C<x>, if
+C<x> is a matrix, the C<n^{th}> column, if C<x> is a polynomial, the
+C<n^{th}> coefficient (i.e.S< >of degree C<n-1>), and for power series, the
+C<n^{th}> significant coefficient. The use of the function
+C<component> implies the knowledge of the structure of the different PARI
+types, which can be recalled by typing C<\t> under GP.
+
+X<compo>The library syntax is B<compo>C<(x,n)>, where C<n> is a C<long>.
+
+The two other methods are more natural but more restricted. The function
+ B<polcoeff>C<(x,n)>X<polcoeff> gives the coefficient of degree C<n> of the polynomial
+or power series C<x>, with respect to the main variable of C<x> (to check
+variable ordering, or to change it, use the function X<reorder>C<reorder>, see
+L<Label se:reorder>). In particular if C<n> is less than the valuation of
+C<x> or in the case of a polynomial, greater than the degree, the result is
+zero (contrary to C<compo> which would send an error message). If C<x> is
+a power series and C<n> is greater than the largest significant degree, then
+an error message is issued.
+
+For greater flexibility, vector or matrix types are also accepted for C<x>,
+and the meaning is then identical with that of C<compo>.
+
+Finally note that a scalar type is considered by C<polcoeff> as a
+polynomial of degree zero.
+
+X<truecoeff>The library syntax is B<truecoeff>C<(x,n)>.
+
+The third method is specific to vectors or matrices under GP. If C<x> is a
+(row or column) vector, then X<x[n]>C<x[n]> represents the C<n^{th}>
+component of C<x>, i.e.S< >C<compo(x,n)>. It is more natural and shorter to
+write. If C<x> is a matrix, X<x[m,n]>C<x[m,n]> represents the coefficient of
+row C<m> and column C<n> of the matrix, X<x[m,]>C<x[m,]> represents
+the C<m^{th}> I<row> of C<x>, and X<x[,n]>C<x[,n]> represents
+the C<n^{th}> I<column> of C<x>.
+
+Finally note that in library mode, the macros X<coeff>B<coeff> and X<mael>B<mael>
+are available to deal with the non-recursivity of the C<GEN> type from the
+compiler's point of view. See the discussion on typecasts in Chapter 4.
+
+=head2 X<conj>conjC<(x)>
+
+conjugate of C<x>. The meaning of this
+is clear, except that for real quadratic numbers, it means conjugation in the
+real quadratic field. This function has no effect on integers, reals,
+integermods, fractions or C<p>-adics. The only forbidden type is polmod
+(see C<conjvec> for this).
+
+X<gconj>The library syntax is B<gconj>C<(x)>.
+
+=head2 X<conjvec>conjvecC<(x)>
+
+conjugate vector representation of C<x>. If C<x> is a
+polmod, equal to C<Mod>C<(a,q)>, this gives a vector of length
+C<degree(q)> containing the complex embeddings of the polmod if C<q> has
+integral or rational coefficients, and the conjugates of the polmod if C<q>
+has some integermod coefficients. The order is the same as that of the
+C<polroots> functions. If C<x> is an integer or a rational number, the
+result isS< >C<x>. If C<x> is a (row or column) vector, the result is a matrix
+whose columns are the conjugate vectors of the individual elements of C<x>.
+
+X<conjvec>The library syntax is B<conjvec>C<(x,>I<prec>C<)>.
+
+=head2 X<denominator>denominatorC<(x)>
+
+lowest denominator of C<x>. The meaning of this
+is clear when C<x> is a rational number or function. When C<x> is an integer
+or a polynomial, the result is equal to C<1>. When C<x> is a vector or a matrix,
+the lowest common denominator of the components of C<x> is computed. All other
+types are forbidden.
+
+X<denom>The library syntax is B<denom>C<(x)>.
+
+=head2 X<floor>floorC<(x)>
+
+floor of C<x>. When C<x> is in B<R>, the result is the
+largest integer smaller than or equal to C<x>. Applied to a rational function,
+C<floor(x)> returns the euclidian quotient of the numerator by the
+denominator.
+
+X<gfloor>The library syntax is B<gfloor>C<(x)>.
+
+=head2 X<frac>fracC<(x)>
+
+fractional part of C<x>. Identical to
+C<x-floor(x)>. If C<x> is real, the result is in C<[0,1[>.
+
+X<gfrac>The library syntax is B<gfrac>C<(x)>.
+
+=head2 X<imag>imagC<(x)>
+
+imaginary part of C<x>. When
+C<x> is a quadratic number, this is the coefficient of F<omega> in
+the ``canonical'' integral basis C<(1,>F<omega>C<)>.
+
+X<gimag>The library syntax is B<gimag>C<(x)>.
+
+=head2 X<length>lengthC<(x)>
+
+number of non-code words in C<x> really used (i.e.S< >the
+effective length minus 2 for integers and polynomials). In particular,
+the degree of a polynomial is equal to its length minus 1. If C<x> has type
+C<t_STR>, output number of letters.
+
+X<glength>The library syntax is B<glength>C<(x)> and the result is a C long.
+
+=head2 X<lift>liftC<(x,{v})>
+
+lifts an element C<x = a mod n> of B<Z>C</n>B<Z> to
+C<a> in B<Z>, and similarly lifts a polmod to a polynomial if C<v> is omitted.
+Otherwise, lifts only polmods with main variable C<v> (if C<v> does not occur
+in C<x>, lifts only intmods). If C<x> is of type fraction, complex, quadratic,
+polynomial, power series, rational function, vector or matrix, the lift is
+done for each coefficient. Forbidden types for C<x> are reals and C<p>-adics.
+
+X<lift0>The library syntax is B<lift0>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded as
+C<-1>. Also available is X<lift>B<lift>C<(x)> = C<lift0(x,-1)>.
+
+=head2 X<norm>normC<(x)>
+
+algebraic norm of C<x>, i.e.S< >the product of C<x> with
+its conjugate (no square roots are taken), or conjugates for polmods. For
+vectors and matrices, the norm is taken componentwise and hence is not the
+C<L^2>-norm (see C<norml2>). Note that the norm of an element of
+B<R> is its square, so as to be compatible with the complex norm.
+
+X<gnorm>The library syntax is B<gnorm>C<(x)>.
+
+=head2 X<norml2>norml2C<(x)>
+
+square of the C<L^2>-norm of C<x>. C<x> must
+be a (row or column) vector.
+
+X<gnorml2>The library syntax is B<gnorml2>C<(x)>.
+
+=head2 X<numerator>numeratorC<(x)>
+
+numerator of C<x>. When C<x> is a rational number
+or function, the meaning is clear. When C<x> is an integer or a polynomial,
+the result is C<x> itself. When C<x> is a vector or a matrix, then
+C<numerator(x)> is defined to be C<denominator(x)*x>. All other types
+are forbidden.
+
+X<numer>The library syntax is B<numer>C<(x)>.
+
+=head2 X<numtoperm>numtopermC<(n,k)>
+
+generates the C<k>-th permutation (as a
+row vector of length C<n>) of the numbers C<1> to C<n>. The number C<k> is taken
+modulo C<n!>, i.e.S< >inverse function of X<permtonum>C<permtonum>.
+
+X<permute>The library syntax is B<permute>C<(n,k)>, where C<n> is a C<long>.
+
+=head2 X<padicprec>padicprecC<(x,p)>
+
+absolute C<p>-adic precision of the object C<x>.
+This is the minimum precision of the components of C<x>. The result is
+C<VERYBIGINT> (C<2^{31}-1> for 32-bit machines or C<2^{63}-1> for 64-bit
+machines) if C<x> is an exact object.
+
+X<padicprec>The library syntax is B<padicprec>C<(x,p)> and the result is a C<long>
+integer.
+
+=head2 X<permtonum>permtonumC<(x)>
+
+given a permutation C<x> on C<n> elements,
+gives the number C<k> such that C<x = numtoperm(n,k)>, i.e.S< >inverse
+function of X<numtoperm>C<numtoperm>.
+
+X<permuteInv>The library syntax is B<permuteInv>C<(x)>.
+
+=head2 X<precision>precisionC<(x,{n})>
+
+gives the precision in decimal digits of the
+PARI object C<x>. If C<x> is an exact object, the largest single precision
+integer is returned. If C<n> is not omitted, creates a new object equal to C<x>
+with a new precision C<n>. This is to be understood as follows:
+
+For exact types, no change. For C<x> a vector or a matrix, the operation
+is done componentwise.
+
+For real C<x>, C<n> is the number of desired significant I<decimal> digits.
+If C<n> is smaller than the precision of C<x>, C<x> is truncated, otherwise C<x>
+is extended with zeros.
+
+For C<x> a C<p>-adic or a power series, C<n> is the desired number of
+significant C<p>-adic or C<X>-adic digits, where C<X> is the main variable of
+C<x>.
+
+Note that the function C<precision> never changes the type of the result.
+In particular it is not possible to use it to obtain a polynomial from a
+power series. For that, see C<truncate>.
+
+X<precision0>The library syntax is B<precision0>C<(x,n)>, where C<n> is a C<long>. Also available are
+X<ggprecision>B<ggprecision>C<(x)> (result is a C<GEN>) and X<gprec>B<gprec>C<(x,n)>, where
+C<n> is a C<long>.
+
+=head2 X<random>randomC<({N = 2^{31}})>
+
+gives a random integer between 0 and
+C<N-1>. C<N> can be arbitrary large. This is an internal PARI function and does
+not depend on the system's random number generator. Note that the resulting
+integer is obtained by means of linear congruences and will not be well
+distributed in arithmetic progressions.
+
+X<genrand>The library syntax is B<genrand>C<(N)>.
+
+=head2 X<real>realC<(x)>
+
+real part of C<x>. In the case where C<x> is a quadratic
+number, this is the coefficient of C<1> in the ``canonical'' integral basis
+C<(1,>F<omega>C<)>.
+
+X<greal>The library syntax is B<greal>C<(x)>.
+
+=head2 X<round>roundC<(x,{&e})>
+
+If C<x> is in B<R>, rounds C<x> to the nearest
+integer and sets C<e> to the number of error bits, that is the binary exponent
+of the difference between the original and the rounded value (the
+``fractional part''). If the exponent of C<x> is too large compared to its
+precision (i.e.S< >C<e E<gt> 0>), the result is undefined and an error occurs if C<e>
+was not given.
+
+B<Important remark:> note that, contrary to the other truncation
+functions, this function operates on every coefficient at every level of a
+PARI object. For example
+
+S< >C<truncate((2.4*X^2-1.7)/(X)) = 2.4*X,>
+
+whereas
+
+S< >C<round((2.4*X^2-1.7)/(X)) = (2*X^2-2)/(X).>
+
+An important use of C<round> is to get exact results after a long
+approximate computation, when theory tells you that the coefficients
+must be integers.
+
+X<grndtoi>The library syntax is B<grndtoi>C<(x,&e)>, where C<e> is a C<long> integer. Also available is
+X<ground>B<ground>C<(x)>.
+
+=head2 X<simplify>simplifyC<(x)>
+
+this function tries to simplify the object C<x> as
+much as it can. The simplifications do not concern rational functions (which
+PARI automatically tries to simplify), but type changes. Specifically, a
+complex or quadratic number whose imaginary part is exactly equal to 0
+(i.e.S< >not a real zero) is converted to its real part, and a polynomial of
+degree zero is converted to its constant term. For all types, this of course
+occurs recursively. This function is useful in any case, but in particular
+before the use of arithmetic functions which expect integer arguments, and
+not for example a complex number of 0 imaginary part and integer real part
+(which is however printed as an integer).
+
+X<simplify>The library syntax is B<simplify>C<(x)>.
+
+=head2 X<sizebyte>sizebyteC<(x)>
+
+outputs the total number of bytes occupied by the
+tree representing the PARI object C<x>.
+
+X<taille2>The library syntax is B<taille2>C<(x)> which returns a C<long>. The
+function X<taille>B<taille> returns the number of I<words> instead.
+
+=head2 X<sizedigit>sizedigitC<(x)>
+
+outputs a quick bound for the number of decimal
+digits of (the components of) C<x>, off by at most C<1>. If you want the
+exact value, you can use C<length(Str(x))>, which is much slower.
+
+X<sizedigit>The library syntax is B<sizedigit>C<(x)> which returns a C<long>.
+
+=head2 X<truncate>truncateC<(x,{&e})>
+
+truncates C<x> and sets C<e> to the number of
+error bits. When C<x> is in B<R>, this means that the part after the decimal
+point is chopped away, C<e> is the binary exponent of the difference between
+the original and the truncated value (the ``fractional part''). If the
+exponent of C<x> is too large compared to its precision (i.e.S< >C<e E<gt> 0>), the
+result is undefined and an error occurs if C<e> was not given. The function
+applies componentwise on rational functions and vector / matrices; C<e> is
+then the maximal number of error bits.
+
+Note a very special use of C<truncate>: when applied to a power series, it
+transforms it into a polynomial or a rational function with denominator
+a power of C<X>, by chopping away the C<O(X^k)>. Similarly, when applied to
+a C<p>-adic number, it transforms it into an integer or a rational number
+by chopping away the C<O(p^k)>.
+
+X<gcvtoi>The library syntax is B<gcvtoi>C<(x,&e)>, where C<e> is a C<long> integer. Also available is
+X<gtrunc>B<gtrunc>C<(x)>.
+
+=head2 X<valuation>valuationC<(x,p)>
+
+X<Label se:valuation> computes the highest
+exponent of C<p> dividing C<x>. If C<p> is of type integer, C<x> must be an
+integer, an integermod whose modulus is divisible by C<p>, a fraction, a
+C<q>-adic number with C<q = p>, or a polynomial or power series in which case the
+valuation is the minimum of the valuation of the coefficients.
+
+If C<p> is of type polynomial, C<x> must be of type polynomial or rational
+function, and also a power series if C<x> is a monomial. Finally, the
+valuation of a vector, complex or quadratic number is the minimum of the
+component valuations.
+
+If C<x = 0>, the result is C<VERYBIGINT> (C<2^{31}-1> for 32-bit machines or
+C<2^{63}-1> for 64-bit machines) if C<x> is an exact object. If C<x> is a
+C<p>-adic numbers or power series, the result is the exponent of the zero.
+Any other type combinations gives an error.
+
+X<ggval>The library syntax is B<ggval>C<(x,p)>, and the result is a C<long>.
+
+=head2 X<variable>variableC<(x)>
+
+gives the main variable of the object C<x>, and
+C<p> if C<x> is a C<p>-adic number. Gives an error if C<x> has no variable
+associated to it. Note that this function is useful only in GP, since in
+library mode the function C<gvar> is more appropriate.
+
+X<gpolvar>The library syntax is B<gpolvar>C<(x)>. However, in library mode, this function should not be used.
+Instead, test whether C<x> is a C<p>-adic (type C<t_PADIC>), in which case C<p>
+is in C<x[2]>, or call the function B<gvar>C<(x)> which returns the variable
+I<number> of C<x> if it exists, C<BIGINT> otherwise.
+
+=head1 Transcendental functions
+
+X<Label se:trans>
+As a general rule, which of course in some cases may have exceptions,
+transcendental functions operate in the following way:
+
+B<*> If the argument is either an integer, a real, a rational, a complex
+or a quadratic number, it is, if necessary, first converted to a real (or
+complex) number using the current X<precision>precision held in the default
+C<realprecision>. Note that only exact arguments are converted, while
+inexact arguments such as reals are not.
+
+Under GP this is transparent to the user, but when programming in library
+mode, care must be taken to supply a meaningful parameter I<prec> as the
+last argument of the function if the first argument is an exact object.
+This parameter is ignored if the argument is inexact.
+
+Note that in library mode the precision argument I<prec> is a word
+count including codewords, i.e.S< >represents the length in words of a real
+number, while under GP the precision (which is changed by the metacommand
+C<\p> or using C<default(realprecision,...)>) is the number of significant
+decimal digits.
+
+Note that some accuracies attainable on 32-bit machines cannot be attained
+on 64-bit machines for parity reasons. For example the default GP accuracy
+is 28 decimal digits on 32-bit machines, corresponding to I<prec> having
+the value 5, but this cannot be attained on 64-bit machines.
+
+After possible conversion, the function is computed. Note that even if the
+argument is real, the result may be complex (e.g.S< >C<acos(2.0)> or
+C<acosh(0.0)>). Note also that the principal branch is always chosen.
+
+B<*> If the argument is an integermod or a C<p>-adic, at present only a
+few functions like C<sqrt> (square root), C<sqr> (square), C<log>,
+C<exp>, powering, C<teichmuller> (TeichmE<uuml>ller character) and
+C<agm> (arithmetic-geometric mean) are implemented.
+
+Note that in the case of a C<2>-adic number, C<sqr(x)> may not be
+identical to C<x*x>: for example if C<x = 1+O(2^5)> and C<y = 1+O(2^5)> then
+C<x*y = 1+O(2^5)> while C<sqr(x) = 1+O(2^6)>. Here, C<x * x> yields the
+same result as C<sqr(x)> since the two operands are known to be I<
+identical>. The same statement holds true for C<p>-adics raised to the power
+C<n>, where C<v_p(n) E<gt> 0>.
+
+B<Remark:> note that if we wanted to be strictly consistent with
+the PARI philosophy, we should have C<x*y = (4 mod 8)> and C<sqr(x) =
+(4 mod 32)> when both C<x> and C<y> are congruent to C<2> modulo C<4>.
+However, since integermod is an exact object, PARI assumes that the modulus
+must not change, and the result is hence C<(0 mod 4)> in both cases. On
+the other hand, C<p>-adics are not exact objects, hence are treated
+differently.
+
+B<*> If the argument is a polynomial, power series or rational function,
+it is, if necessary, first converted to a power series using the current
+precision held in the variable X<precdl>C<precdl>. Under GP this again is
+transparent to the user. When programming in library mode, however, the
+global variable C<precdl> must be set before calling the function if the
+argument has an exact type (i.e.S< >not a power series). Here C<precdl> is
+not an argument of the function, but a global variable.
+
+Then the Taylor series expansion of the function around C<X = 0> (where C<X> is
+the main variable) is computed to a number of terms depending on the number
+of terms of the argument and the function being computed.
+
+B<*> If the argument is a vector or a matrix, the result is the
+componentwise evaluation of the function. In particular, transcendental
+functions on square matrices, which are not implemented in the present
+version B<2.2.0> (see AppendixS< >B however), will have a slightly different name
+if they are implemented some day.
+
+=head2 ^
+
+If C<y> is not of type integer, C<x^y> has the same
+effect as C<exp(y*ln(x))>. It can be applied to C<p>-adic numbers as
+well as to the more usual types.X<powering>
+
+X<gpow>The library syntax is B<gpow>C<(x,y,>I<prec>C<)>.
+
+=head2 Euler
+
+Euler's constant C<0.57721...>. Note that C<Euler>
+is one of the few special reserved names which cannot be used for variables
+(the others are C<I> and C<Pi>, as well as all function names).
+X<Label se:euler>
+
+X<mpeuler>The library syntax is B<mpeuler>C<(>I<prec>C<)> where I<prec> I<must> be given. Note that
+this creates F<gamma> on the PARI stack, but a copy is also created on the
+heap for quicker computations next time the function is called.
+
+=head2 I
+
+the complex number F<sqrt> C<{-1}>.
+
+The library syntax is the global variable C<gi> (of type C<GEN>).
+
+=head2 Pi
+
+the constant F<Pi> (C<3.14159...>).X<Label se:pi>
+
+X<mppi>The library syntax is B<mppi>C<(>I<prec>C<)> where I<prec> I<must> be given. Note that this
+creates F<Pi> on the PARI stack, but a copy is also created on the heap for
+quicker computations next time the function is called.
+
+=head2 X<abs>absC<(x)>
+
+absolute value of C<x> (modulus if C<x> is complex).
+Power series and rational functions are not allowed. Contrary to most
+transcendental functions, an exact argument is I<not> converted to a real
+number before applying C<abs> and an exact result is returned if possible.
+
+ ? abs(-1)
+ %1 = 1
+ ? abs(3/7 + 4/7*I)
+ %2 = 5/7
+ ? abs(1 + I)
+ %3 = 1.414213562373095048801688724
+
+If C<x> is a polynomial, returns C<-x> if the leading coefficient is
+real and negative else returns C<x>. For a power series, the constant
+coefficient is considered instead.
+
+X<gabs>The library syntax is B<gabs>C<(x,>I<prec>C<)>.
+
+=head2 X<acos>acosC<(x)>
+
+principal branch of C<cos^{-1}(x)>,
+i.e.S< >such that C<Re(acos(x)) belongs to [0,>F<Pi>C<]>. If
+C<x belongs to >B<R> and C<|x| E<gt> 1>, then C<acos(x)> is complex.
+
+X<gacos>The library syntax is B<gacos>C<(x,>I<prec>C<)>.
+
+=head2 X<acosh>acoshC<(x)>
+
+principal branch of C<cosh^{-1}(x)>,
+i.e.S< >such that C<Im(acosh(x)) belongs to [0,>F<Pi>C<]>. If
+C<x belongs to >B<R> and C<x E<lt> 1>, then C<acosh(x)> is complex.
+
+X<gach>The library syntax is B<gach>C<(x,>I<prec>C<)>.
+
+=head2 X<agm>agmC<(x,y)>
+
+arithmetic-geometric mean of C<x> and C<y>. In the
+case of complex or negative numbers, the principal square root is always
+chosen. C<p>-adic or power series arguments are also allowed. Note that
+a C<p>-adic agm exists only if C<x/y> is congruent to 1 modulo C<p> (modulo
+16 for C<p = 2>). C<x> and C<y> cannot both be vectors or matrices.
+
+X<agm>The library syntax is B<agm>C<(x,y,>I<prec>C<)>.
+
+=head2 X<arg>argC<(x)>
+
+argument of the complex number C<x>, such that
+C<->F<Pi>C< E<lt> arg(x) E<lt>= >F<Pi>.
+
+X<garg>The library syntax is B<garg>C<(x,>I<prec>C<)>.
+
+=head2 X<asin>asinC<(x)>
+
+principal branch of C<sin^{-1}(x)>, i.e.S< >such
+that C<Re(asin(x)) belongs to [->F<Pi>C</2,>F<Pi>C</2]>. If C<x belongs to >B<R> and C<|x| E<gt> 1> then
+C<asin(x)> is complex.
+
+X<gasin>The library syntax is B<gasin>C<(x,>I<prec>C<)>.
+
+=head2 X<asinh>asinhC<(x)>
+
+principal branch of C<sinh^{-1}(x)>, i.e.S< >such
+that C<Im(asinh(x)) belongs to [->F<Pi>C</2,>F<Pi>C</2]>.
+
+X<gash>The library syntax is B<gash>C<(x,>I<prec>C<)>.
+
+=head2 X<atan>atanC<(x)>
+
+principal branch of C<tan^{-1}(x)>, i.e.S< >such
+that C<Re(atan(x)) belongs to ]->F<Pi>C</2,>F<Pi>C</2[>.
+
+X<gatan>The library syntax is B<gatan>C<(x,>I<prec>C<)>.
+
+=head2 X<atanh>atanhC<(x)>
+
+principal branch of C<tanh^{-1}(x)>, i.e.S< >such
+that C<Im(atanh(x)) belongs to ]->F<Pi>C</2,>F<Pi>C</2]>. If C<x belongs to >B<R> and C<|x| E<gt> 1> then
+C<atanh(x)> is complex.
+
+X<gath>The library syntax is B<gath>C<(x,>I<prec>C<)>.
+
+=head2 X<bernfrac>bernfracC<(x)>
+
+Bernoulli numberX<Bernoulli numbers> C<B_x>,
+where C<B_0 = 1>, C<B_1 = -1/2>, C<B_2 = 1/6>,..., expressed as a rational number.
+The argument C<x> should be of type integer.
+
+X<bernfrac>The library syntax is B<bernfrac>C<(x)>.
+
+=head2 X<bernreal>bernrealC<(x)>
+
+Bernoulli numberX<Bernoulli numbers>
+C<B_x>, as C<bernfrac>, but C<B_x> is returned as a real number
+(with the current precision).
+
+X<bernreal>The library syntax is B<bernreal>C<(x,>I<prec>C<)>.
+
+=head2 X<bernvec>bernvecC<(x)>
+
+creates a vector containing, as rational numbers,
+the X<Bernoulli numbers>Bernoulli numbers C<B_0>, C<B_2>,..., C<B_{2x}>. These Bernoulli
+numbers can then be used as follows. Assume that this vector has been put
+into a variable, say C<bernint>. Then you can define under GP:
+
+ bern(x) =
+ {
+ if (x == 1, return(-1/2));
+ if (x < 0 || x % 2, return(0));
+ bernint[x/2+1]
+ }
+
+and then C<bern(k)> gives the Bernoulli number of index C<k> as a
+rational number, exactly as C<bernreal(k)> gives it as a real number. If
+you need only a few values, calling C<bernfrac(k)> each time will be much
+more efficient than computing the huge vector above.
+
+X<bernvec>The library syntax is B<bernvec>C<(x)>.
+
+=head2 X<besseljh>besseljhC<(n,x)>
+
+C<J>-Bessel function of half integral index.
+More precisely, C<besseljh(n,x)> computes C<J_{n+1/2}(x)> where C<n>
+must be of type integer, and C<x> is any element of B<C>. In the
+present version B<2.2.0>, this function is not very accurate when C<x> is
+small.
+
+X<jbesselh>The library syntax is B<jbesselh>C<(n,x,>I<prec>C<)>.
+
+=head2 X<besselk>besselkC<(>I<nu>C<,x,{>I<flag>C< = 0})>
+
+C<K>-Bessel function of index
+I<nu> (which can be complex) and argument C<x>. Only real and positive
+arguments
+C<x> are allowed in the present version B<2.2.0>. If I<flag> is equal to 1,
+uses another implementation of this function which is often faster.
+
+X<kbessel>The library syntax is B<kbessel>C<(>I<nu>C<,x,>I<prec>C<)> and
+X<kbessel2>B<kbessel2>C<(>I<nu>C<,x,>I<prec>C<)> respectively.
+
+=head2 X<cos>cosC<(x)>
+
+cosine of C<x>.
+
+X<gcos>The library syntax is B<gcos>C<(x,>I<prec>C<)>.
+
+=head2 X<cosh>coshC<(x)>
+
+hyperbolic cosine of C<x>.
+
+X<gch>The library syntax is B<gch>C<(x,>I<prec>C<)>.
+
+=head2 X<cotan>cotanC<(x)>
+
+cotangent of C<x>.
+
+X<gcotan>The library syntax is B<gcotan>C<(x,>I<prec>C<)>.
+
+=head2 X<dilog>dilogC<(x)>
+
+principal branch of the dilogarithm of C<x>,
+i.e.S< >analytic continuation of the power series F<log> C<_2(x) = >F<sum>C<_{n E<gt>= 1}x^n/n^2>.
+
+X<dilog>The library syntax is B<dilog>C<(x,>I<prec>C<)>.
+
+=head2 X<eint1>eint1C<(x,{n})>
+
+exponential integral
+F<int>C<_x^ oo (e^{-t})/(t)dt> (C<x belongs to >B<R>)
+
+If C<n> is present, outputs the C<n>-dimensional vector
+C<[eint1(x),...,eint1(nx)]> (C<x E<gt>= 0>). This is faster than
+repeatedly calling C<eint1(i * x)>.
+
+X<veceint1>The library syntax is B<veceint1>C<(x,n,>I<prec>C<)>. Also available is
+X<eint1>B<eint1>C<(x,>I<prec>C<)>.
+
+=head2 X<erfc>erfcC<(x)>
+
+complementary error function
+C<(2/> F<sqrt> F<Pi>C<)>F<int>C<_x^ oo e^{-t^2}dt>.
+
+X<erfc>The library syntax is B<erfc>C<(x,>I<prec>C<)>.
+
+=head2 X<eta>etaC<(x,{>I<flag>C< = 0})>
+
+X<Dedekind>Dedekind's F<eta> function, without the
+C<q^{1/24}>. This means the following: if C<x> is a complex number with positive
+imaginary part, the result is F<prod>C<_{n = 1}^ oo (1-q^n)>, where
+C<q = e^{2i>F<Pi>C< x}>. If C<x> is a power series (or can be converted to a power
+series) with positive valuation, the result is F<prod>C<_{n = 1}^ oo (1-x^n)>.
+
+If I<flag>C< = 1> and C<x> can be converted to a complex number (i.e.S< >is not a power
+series), computes the true F<eta> function, including the leading C<q^{1/24}>.
+
+X<eta>The library syntax is B<eta>C<(x,>I<prec>C<)>.
+
+=head2 X<exp>expC<(x)>
+
+exponential of C<x>.
+C<p>-adic arguments with positive valuation are accepted.
+
+X<gexp>The library syntax is B<gexp>C<(x,>I<prec>C<)>.
+
+=head2 X<gammah>gammahC<(x)>
+
+gamma function evaluated at the argument
+C<x+1/2>. When C<x> is an integer, this is much faster than using
+C<gamma(x+1/2)>.
+
+X<ggamd>The library syntax is B<ggamd>C<(x,>I<prec>C<)>.
+
+=head2 X<gamma>gammaC<(x)>
+
+gamma function of C<x>. In the present version
+B<2.2.0> the C<p>-adic gamma function is not implemented.
+
+X<ggamma>The library syntax is B<ggamma>C<(x,>I<prec>C<)>.
+
+=head2 X<hyperu>hyperuC<(a,b,x)>
+
+C<U>-confluent hypergeometric function with
+parameters C<a> and C<b>. The parameters C<a> and C<b> can be complex but
+the present implementation requires C<x> to be positive.
+
+X<hyperu>The library syntax is B<hyperu>C<(a,b,x,>I<prec>C<)>.
+
+=head2 X<incgam>incgamC<(s,x,{y})>
+
+incomplete gamma function.
+
+C<x> must be positive and C<s> real. The result returned is F<int>C<_x^ oo
+e^{-t}t^{s-1}dt>. When C<y> is given, assume (of course without checking!)
+that C<y = >F<Gamma>C<(s)>. For small C<x>, this will tremendously speed up the
+computation.
+
+X<incgam>The library syntax is B<incgam>C<(s,x,>I<prec>C<)> and X<incgam4>B<incgam4>C<(s,x,y,>I<prec>C<)>,
+respectively. There exist also the functions X<incgam1>B<incgam1> and
+X<incgam2>B<incgam2> which are used for internal purposes.
+
+=head2 X<incgamc>incgamcC<(s,x)>
+
+complementary incomplete gamma function.
+
+The arguments C<s> and C<x> must be positive. The result returned is
+F<int>C<_0^x e^{-t}t^{s-1}dt>, when C<x> is not too large.
+
+X<incgam3>The library syntax is B<incgam3>C<(s,x,>I<prec>C<)>.
+
+=head2 X<log>logC<(x,{>I<flag>C< = 0})>
+
+principal branch of the natural logarithm of
+C<x>, i.e.S< >such that C<Im(ln(x)) belongs to ]->F<Pi>C<,>F<Pi>C<]>. The result is complex
+(with imaginary part equal to F<Pi>) if C<x belongs to >B<R> and C<x E<lt> 0>.
+
+C<p>-adic arguments are also accepted for C<x>, with the convention that
+ F<ln> C<(p) = 0>. Hence in particular F<exp> C<(> F<ln> C<(x))/x> will not in general be
+equal to 1 but to a C<(p-1)>-th root of unity (or C<F<+->1> if C<p = 2>)
+times a power of C<p>.
+
+If I<flag> is equal to 1, use an agm formula suggested by Mestre, when C<x> is
+real, otherwise identical to C<log>.
+
+X<glog>The library syntax is B<glog>C<(x,>I<prec>C<)> or X<glogagm>B<glogagm>C<(x,>I<prec>C<)>.
+
+=head2 X<lngamma>lngammaC<(x)>
+
+principal branch of the logarithm of the gamma
+function of C<x>. Can have much larger arguments than C<gamma> itself.
+In the present version B<2.2.0>, the C<p>-adic C<lngamma> function is not
+implemented.
+
+X<glngamma>The library syntax is B<glngamma>C<(x,>I<prec>C<)>.
+
+=head2 X<polylog>polylogC<(m,x,{>I<flag>C< = 0})>
+
+one of the different polylogarithms,
+depending on I<flag>:
+
+If I<flag>C< = 0> or is omitted: C<m^th> polylogarithm of C<x>, i.e.S< >analytic
+continuation of the power series C<Li_m(x) = >F<sum>C<_{n E<gt>= 1}x^n/n^m>. The
+program uses the power series when C<|x|^2 E<lt>= 1/2>, and the power series
+expansion in F<log> C<(x)> otherwise. It is valid in a large domain (at least
+C<|x| E<lt> 230>), but should not be used too far away from the unit circle since it
+is then better to use the functional equation linking the value at C<x> to the
+value at C<1/x>, which takes a trivial form for the variant below. Power
+series, polynomial, rational and vector/matrix arguments are allowed.
+
+For the variants to follow we need a notation: let F<Re> C<_m>
+denotes F<Re> or F<Im> depending whether C<m> is odd or even.
+
+If I<flag>C< = 1>: modified C<m^th> polylogarithm of C<x>, called
+C<~ D_m(x)> in Zagier, defined for C<|x| E<lt>= 1> by
+
+S< > F<Re> C<_m(>F<sum>C<_{k = 0}^{m-1} ((-> F<log> C<|x|)^k)/(k!)Li_{m-k}(x)
++((-> F<log> C<|x|)^{m-1})/(m!)> F<log> C<|1-x|).>
+
+If I<flag>C< = 2>: modified C<m^th> polylogarithm of C<x>,
+called C<D_m(x)> in Zagier, defined for C<|x| E<lt>= 1> by
+
+S< > F<Re> C<_m(>F<sum>C<_{k = 0}^{m-1}((-> F<log> C<|x|)^k)/(k!)Li_{m-k}(x)
+-(1)/(2)((-> F<log> C<|x|)^m)/(m!)).>
+
+If I<flag>C< = 3>: another modified C<m^th>
+polylogarithm of C<x>, called C<P_m(x)> in Zagier, defined for C<|x| E<lt>= 1> by
+
+S< > F<Re> C<_m(>F<sum>C<_{k = 0}^{m-1}(2^kB_k)/(k!)(> F<log> C<|x|)^kLi_{m-k}(x)
+-(2^{m-1}B_m)/(m!)(> F<log> C<|x|)^m).>
+
+These three functions satisfy the functional equation
+C<f_m(1/x) = (-1)^{m-1}f_m(x)>.
+
+X<polylog0>The library syntax is B<polylog0>C<(m,x,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<psi>psiC<(x)>
+
+the F<psi>-function of C<x>, i.e.S< >the
+logarithmic derivative F<Gamma>C<'(x)/>F<Gamma>C<(x)>.
+
+X<gpsi>The library syntax is B<gpsi>C<(x,>I<prec>C<)>.
+
+=head2 X<sin>sinC<(x)>
+
+sine of C<x>.
+
+X<gsin>The library syntax is B<gsin>C<(x,>I<prec>C<)>.
+
+=head2 X<sinh>sinhC<(x)>
+
+hyperbolic sine of C<x>.
+
+X<gsh>The library syntax is B<gsh>C<(x,>I<prec>C<)>.
+
+=head2 X<sqr>sqrC<(x)>
+
+square of C<x>. This operation is not completely
+straightforward, i.e.S< >identical to C<x * x>, since it can usually be
+computed more efficiently (roughly one-half of the elementary
+multiplications can be saved). Also, squaring a C<2>-adic number increases
+its precision. For example,
+
+ ? (1 + O(2^4))^2
+ %1 = 1 + O(2^5)
+ ? (1 + O(2^4)) * (1 + O(2^4))
+ %2 = 1 + O(2^4)
+
+Note that this function is also called whenever one multiplies two objects
+which are known to be I<identical>, e.g.S< >they are the value of the same
+variable, or we are computing a power.
+
+ ? x = (1 + O(2^4)); x * x
+ %3 = 1 + O(2^5)
+ ? (1 + O(2^4))^4
+ %4 = 1 + O(2^6)
+
+(note the difference between C<%2> and C<%3> above).
+
+X<gsqr>The library syntax is B<gsqr>C<(x)>.
+
+=head2 X<sqrt>sqrtC<(x)>
+
+principal branch of the square root of C<x>,
+i.e.S< >such that C<Arg(sqrt(x)) belongs to ]->F<Pi>C</2, >F<Pi>C</2]>, or in other
+words such that F<Re> C<(sqrt(x)) E<gt> 0> or F<Re> C<(sqrt(x)) = 0> and
+ F<Im> C<(sqrt(x)) E<gt>= 0>. If C<x belongs to >B<R> and C<x E<lt> 0>, then the result is
+complex with positive imaginary part.
+
+Integermod a prime and C<p>-adics are allowed as arguments. In that case,
+the square root (if it exists) which is returned is the one whose
+first C<p>-adic digit (or its unique C<p>-adic digit in the case of
+integermods) is in the interval C<[0,p/2]>. When the argument is an
+integermod a non-prime (or a non-prime-adic), the result is undefined.
+
+X<gsqrt>The library syntax is B<gsqrt>C<(x,>I<prec>C<)>.
+
+=head2 X<sqrtn>sqrtnC<(x,n,{&z})>
+
+principal branch of the C<n>th root of C<x>,
+i.e.S< >such that C<Arg(sqrt(x)) belongs to ]->F<Pi>C</n, >F<Pi>C</n]>.
+
+Integermod a prime and C<p>-adics are allowed as arguments.
+
+If C<z> is present, it is set to a suitable root of unity allowing to
+recover all the other roots. If it was not possible, z is
+set to zero.
+
+The following script computes all roots in all possible cases:
+
+ sqrtnall(x,n)=
+ {
+ local(V,r,z,r2);
+ r = sqrtn(x,n, &z);
+ if (!z, error("Impossible case in sqrtn"));
+ if (type(x) == "t_INTMOD" || type(x)=="t_PADIC" ,
+ r2 = r*z; n = 1;
+ while (r2!=r, r2*=z;n++));
+ V = vector(n); V[1] = r;
+ for(i=2, n, V[i] = V[i-1]*z);
+ V
+ }
+ addhelp(sqrtnall,"sqrtnall(x,n):compute the vector of nth-roots of x");
+
+X<gsqrtn>The library syntax is B<gsqrtn>C<(x,n,&z,>I<prec>C<)>.
+
+=head2 X<tan>tanC<(x)>
+
+tangent of C<x>.
+
+X<gtan>The library syntax is B<gtan>C<(x,>I<prec>C<)>.
+
+=head2 X<tanh>tanhC<(x)>
+
+hyperbolic tangent of C<x>.
+
+X<gth>The library syntax is B<gth>C<(x,>I<prec>C<)>.
+
+=head2 X<teichmuller>teichmullerC<(x)>
+
+TeichmE<uuml>ller character of the C<p>-adic number
+C<x>.
+
+X<teich>The library syntax is B<teich>C<(x)>.
+
+=head2 X<theta>thetaC<(q,z)>
+
+Jacobi sine theta-function.
+
+X<theta>The library syntax is B<theta>C<(q,z,>I<prec>C<)>.
+
+=head2 X<thetanullk>thetanullkC<(q,k)>
+
+C<k>-th derivative at C<z = 0> of
+C<theta(q,z)>.
+
+X<thetanullk>The library syntax is B<thetanullk>C<(q,k,>I<prec>C<)>, where C<k> is a C<long>.
+
+=head2 X<weber>weberC<(x,{>I<flag>C< = 0})>
+
+one of Weber's three C<f> functions.
+If I<flag>C< = 0>, returns
+
+S< >C<f(x) = > F<exp> C<(-i>F<Pi>C</24).>F<eta>C<((x+1)/2)/>F<eta>C<(x) such that j = (f^{24}-16)^3/f^{24},>
+
+where C<j> is the elliptic C<j>-invariant (see the function C<ellj>).
+If I<flag>C< = 1>, returns
+
+S< >C<f_1(x) = >F<eta>C<(x/2)/>F<eta>C<(x) such that j = (f_1^{24}+16)^3/f_1^{24}.>
+
+Finally, if I<flag>C< = 2>, returns
+
+S< >C<f_2(x) = > F<sqrt> C<{2}>F<eta>C<(2x)/>F<eta>C<(x) such that j = (f_2^{24}+16)^3/f_2^{24}.>
+
+Note the identities C<f^8 = f_1^8+f_2^8> and C<ff_1f_2 = > F<sqrt> C<2>.
+
+X<weber0>The library syntax is B<weber0>C<(x,>I<flag>C<,>I<prec>C<)>, or
+X<wf>B<wf>C<(x,>I<prec>C<)>, X<wf1>B<wf1>C<(x,>I<prec>C<)> or
+X<wf2>B<wf2>C<(x,>I<prec>C<)>.
+
+=head2 X<zeta>zetaC<(s)>
+
+Riemann's zeta functionX<Riemann zeta-function>
+F<zeta>C<(s) = >F<sum>C<_{n E<gt>= 1}n^{-s}>, computed using the X<Euler-Maclaurin>Euler-Maclaurin
+summation formula, except when C<s> is of type integer, in which case it
+is computed using Bernoulli numbersX<Bernoulli numbers> for
+C<s E<lt>= 0> or C<s E<gt> 0> and even, and using modular forms for C<s E<gt> 0> and odd.
+
+X<gzeta>The library syntax is B<gzeta>C<(s,>I<prec>C<)>.
+
+=head1 Arithmetic functions
+
+X<Label se:arithmetic>
+These functions are by definition functions whose natural domain of
+definition is either B<Z> (or B<Z>C<_{ E<gt> 0}>), or sometimes polynomials
+over a base ring. Functions which concern polynomials exclusively will be
+explained in the next section. The way these functions are used is
+completely different from transcendental functions: in general only the types
+integer and polynomial are accepted as arguments. If a vector or matrix type
+is given, the function will be applied on each coefficient independently.
+
+In the present version B<2.2.0>, all arithmetic functions in the narrow sense
+of the wordS< >--- Euler's totientX<Euler totient function> function, the
+X<Moebius>Moebius function, the sums over divisors or powers of divisors
+etc.--- call, after trial division by small primes, the same versatile
+factoring machinery described under C<factorint>. It includes
+X<Shanks SQUFOF>Shanks SQUFOF, X<Pollard Rho>Pollard Rho, X<ECM>ECM and X<MPQS>MPQS stages, and
+has an early exit option for the functions X<moebius>B<moebius> and (the integer
+function underlying) X<issquarefree>B<issquarefree>. Note that it relies on a (fairly
+strong) probabilistic primality test: numbers found to be strong
+pseudo-primes after 10 successful trials of the X<Rabin-Miller>Rabin-Miller test are
+declared primes.
+
+=head2 X<addprimes>addprimesC<({x = []})>
+
+adds the primes contained in the vector
+C<x> (or the single integer C<x>) to the table computed upon GP initialization
+(by C<pari_init> in library mode), and returns a row vector whose first
+entries contain all primes added by the user and whose last entries have been
+filled up with 1's. In total the returned row vector has 100 components.
+Whenever C<factor> or C<smallfact> is subsequently called, first the
+primes in the table computed by C<pari_init> will be checked, and then
+the additional primes in this table. If C<x> is empty or omitted, just returns
+the current list of extra primes.
+
+The entries in C<x> are not checked for primality. They need only be positive
+integers not divisible by any of the pre-computed primes. It's in fact a nice
+trick to add composite numbers, which for example the function
+C<factor(x,0)> was not able to factor. In case the message ``impossible
+inverse modulo C<E<lt>>I<some integermod>C<E<gt>>'' shows up afterwards,
+you have just stumbled over a non-trivial factor. Note that the arithmetic
+functions in the narrow sense, like X<eulerphi>B<eulerphi>, do I<not> use this
+extra table.
+
+The present PARI version B<2.2.0> allows up to 100 user-specified
+primes to be appended to the table. This limit may be changed
+by altering C<NUMPRTBELT> in file C<init.c>. To remove primes from the
+list use C<removeprimes>.
+
+X<addprimes>The library syntax is B<addprimes>C<(x)>.
+
+=head2 X<bestappr>bestapprC<(x,k)>
+
+if C<x belongs to >B<R>, finds the best rational
+approximation to C<x> with denominator at most equal to C<k> using continued
+fractions.
+
+X<bestappr>The library syntax is B<bestappr>C<(x,k)>.
+
+=head2 X<bezout>bezoutC<(x,y)>
+
+finds C<u> and C<v> minimal in a
+natural sense such that C<x*u+y*v = gcd(x,y)>. The arguments
+must be both integers or both polynomials, and the result is a
+row vector with three components C<u>, C<v>, and C<gcd(x,y)>.
+
+X<vecbezout>The library syntax is B<vecbezout>C<(x,y)> to get the vector, or X<gbezout>B<gbezout>C<(x,y, &u, &v)>
+which gives as result the address of the created gcd, and puts
+the addresses of the corresponding created objects into C<u> and C<v>.
+
+=head2 X<bezoutres>bezoutresC<(x,y)>
+
+as C<bezout>, with the resultant of C<x> and
+C<y> replacing the gcd.
+
+X<vecbezoutres>The library syntax is B<vecbezoutres>C<(x,y)> to get the vector, or X<subresext>B<subresext>C<(x,y, &u,
+&v)> which gives as result the address of the created gcd, and puts the
+addresses of the corresponding created objects into C<u> and C<v>.
+
+=head2 X<bigomega>bigomegaC<(x)>
+
+number of prime divisors of C<|x|> counted with
+multiplicity. C<x> must be an integer.
+
+X<bigomega>The library syntax is B<bigomega>C<(x)>, the result is a C<long>.
+
+=head2 X<binomial>binomialC<(x,y)>
+
+X<binomial coefficient>binomial coefficient C<\binom x y>.
+Here C<y> must be an integer, but C<x> can be any PARI object.
+
+X<binome>The library syntax is B<binome>C<(x,y)>, where C<y> must be a C<long>.
+
+=head2 X<chinese>chineseC<(x,y)>
+
+if C<x> and C<y> are both integermods or both
+polmods, creates (with the same type) a C<z> in the same residue class
+as C<x> and in the same residue class as C<y>, if it is possible.
+
+This function also allows vector and matrix arguments, in which case the
+operation is recursively applied to each component of the vector or matrix.
+For polynomial arguments, it is applied to each coefficient. Finally
+C<chinese(x,x) = x> regardless of the type of C<x>; this allows vector
+arguments to contain other data, so long as they are identical in both
+vectors.
+
+X<chinois>The library syntax is B<chinois>C<(x,y)>.
+
+=head2 X<content>contentC<(x)>
+
+computes the gcd of all the coefficients of C<x>,
+when this gcd makes sense. If C<x> is a scalar, this simply returns C<x>. If C<x>
+is a polynomial (and by extension a power series), it gives the usual content
+of C<x>. If C<x> is a rational function, it gives the ratio of the contents of
+the numerator and the denominator. Finally, if C<x> is a vector or a matrix,
+it gives the gcd of all the entries.
+
+X<content>The library syntax is B<content>C<(x)>.
+
+=head2 X<contfrac>contfracC<(x,{b},{lmax})>
+
+creates the row vector whose
+components are the partial quotients of the X<continued fraction>continued fraction
+expansion of C<x>, the number of partial quotients being limited to C<lmax>.
+If C<x> is a real number, the expansion stops at the last significant partial
+quotient if C<lmax> is omitted. C<x> can also be a rational function or a power
+series.
+
+If a vector C<b> is supplied, the numerators will be equal to the coefficients
+of C<b>. The length of the result is then equal to the length of C<b>, unless a
+partial remainder is encountered which is equal to zero. In which case the
+expansion stops. In the case of real numbers, the stopping criterion is thus
+different from the one mentioned above since, if C<b> is too long, some partial
+quotients may not be significant.
+
+If C<b> is an integer, the command is understood as C<contfrac(x,lmax)>.
+
+X<contfrac0>The library syntax is B<contfrac0>C<(x,b,lmax)>. Also available are
+X<gboundcf>B<gboundcf>C<(x,lmax)>, X<gcf>B<gcf>C<(x)>, or X<gcf2>B<gcf2>C<(b,x)>, where C<lmax>
+is a C integer.
+
+=head2 X<contfracpnqn>contfracpnqnC<(x)>
+
+when C<x> is a vector or a one-row matrix, C<x>
+is considered as the list of partial quotients C<[a_0,a_1,...,a_n]> of a
+rational number, and the result is the 2 by 2 matrix
+C<[p_n,p_{n-1};q_n,q_{n-1}]> in the standard notation of continued fractions,
+so C<p_n/q_n = a_0+1/(a_1+...+1/a_n)...)>. If C<x> is a matrix with two rows
+C<[b_0,b_1,...,b_n]> and C<[a_0,a_1,...,a_n]>, this is then considered as a
+generalized continued fraction and we have similarly
+C<p_n/q_n = 1/b_0(a_0+b_1/(a_1+...+b_n/a_n)...)>. Note that in this case one
+usually has C<b_0 = 1>.
+
+X<pnqn>The library syntax is B<pnqn>C<(x)>.
+
+=head2 X<core>coreC<(n,{>I<flag>C< = 0})>
+
+if C<n> is a non-zero integer written as
+C<n = df^2> with C<d> squarefree, returns C<d>. If I<flag> is non-zero,
+returns the two-element row vector C<[d,f]>.
+
+X<core0>The library syntax is B<core0>C<(n,>I<flag>C<)>.
+Also available are
+X<core>B<core>C<(n)> ( = X<core>B<core>C<(n,0)>) and
+X<core2>B<core2>C<(n)> ( = X<core>B<core>C<(n,1)>).
+
+=head2 X<coredisc>corediscC<(n,{>I<flag>C<})>
+
+if C<n> is a non-zero integer written as
+C<n = df^2> with C<d> fundamental discriminant (including 1), returns C<d>. If
+I<flag> is non-zero, returns the two-element row vector C<[d,f]>. Note that if
+C<n> is not congruent to 0 or 1 modulo 4, C<f> will be a half integer and not
+an integer.
+
+X<coredisc0>The library syntax is B<coredisc0>C<(n,>I<flag>C<)>.
+Also available are
+X<coredisc>B<coredisc>C<(n)> ( = X<coredisc>B<coredisc>C<(n,0)>) and
+X<coredisc2>B<coredisc2>C<(n)> ( = X<coredisc>B<coredisc>C<(n,1)>).
+
+=head2 X<dirdiv>dirdivC<(x,y)>
+
+C<x> and C<y> being vectors of perhaps different
+lengths but with C<y[1] ! = 0> considered as X<Dirichlet series>Dirichlet series, computes
+the quotient of C<x> by C<y>, again as a vector.
+
+X<dirdiv>The library syntax is B<dirdiv>C<(x,y)>.
+
+=head2 X<direuler>direulerC<(p = a,b,>I<expr>C<,{c})>
+
+computes the
+X<Dirichlet series>Dirichlet series to C<b> terms of the X<Euler product>Euler product of
+expression I<expr> as C<p> ranges through the primes from C<a> to C<b>.
+I<expr> must be a polynomial or rational function in another variable
+than C<p> (say C<X>) and I<expr>C<(X)> is understood as the Dirichlet
+series (or more precisely the local factor) I<expr>C<(p^{-s})>. If C<c> is
+present, output only the first C<c> coefficients in the series.
+
+X<direuler>The library syntax is B<direuler>C<(entree *ep, GEN a, GEN b, char *expr)>
+
+=head2 X<dirmul>dirmulC<(x,y)>
+
+C<x> and C<y> being vectors of perhaps different
+lengths considered as X<Dirichlet series>Dirichlet series, computes the product of
+C<x> by C<y>, again as a vector.
+
+X<dirmul>The library syntax is B<dirmul>C<(x,y)>.
+
+=head2 X<divisors>divisorsC<(x)>
+
+creates a row vector whose components are the
+positive divisors of the integer C<x> in increasing order. The factorization
+of C<x> (as output by X<factor>C<factor>) can be used instead.
+
+X<divisors>The library syntax is B<divisors>C<(x)>.
+
+=head2 X<eulerphi>eulerphiC<(x)>
+
+Euler's F<phi>
+(totient)X<Euler totient function> function of C<|x|>, in other words
+C<|(>B<Z>C</x>B<Z>C<)^*|>. C<x> must be of type integer.
+
+X<phi>The library syntax is B<phi>C<(x)>.
+
+=head2 X<factor>factorC<(x,{>I<lim>C< = -1})>
+
+general factorization function.
+If C<x> is of type integer, rational, polynomial or rational function, the
+result is a two-column matrix, the first column being the irreducibles
+dividing C<x> (prime numbers or polynomials), and the second the exponents.
+If C<x> is a vector or a matrix, the factoring is done componentwise (hence
+the result is a vector or matrix of two-column matrices). By definition,
+C<0> is factored as C<0^1>.
+
+If C<x> is of type integer or rational, an argument I<lim> can be
+added, meaning that we look only for factors up to I<lim>, or to
+C<primelimit>, whichever is lowest (except when I<lim>C< = 0> where the
+effect is identical to setting I<lim>C< = primelimit>). Hence in this
+case, the remaining part is not necessarily prime. See X<factorint>B<factorint> for
+more information about the algorithms used.
+
+The polynomials or rational functions to be factored must have scalar
+coefficients. In particular PARI does I<not> know how to factor
+multivariate polynomials.
+
+Note that PARI tries to guess in a sensible way over which ring you want
+to factor. Note also that factorization of polynomials is done up to
+multiplication by a constant. In particular, the factors of rational
+polynomials will have integer coefficients, and the content of a polynomial
+or rational function is discarded and not included in the factorization. If
+you need it, you can always ask for the content explicitly:
+
+ ? factor(t^2 + 5/2*t + 1)
+ %1 =
+ [2*t + 1 1]
+
+ [t + 2 1]
+
+ ? content(t^2 + 5/2*t + 1)
+ %2 = 1/2
+
+See also X<factornf>B<factornf>.
+
+X<factor0>The library syntax is B<factor0>C<(x,>I<lim>C<)>, where I<lim> is a C integer.
+Also available are
+X<factor>B<factor>C<(x)> ( = X<factor0>B<factor0>C<(x,-1)>),
+X<smallfact>B<smallfact>C<(x)> ( = X<factor0>B<factor0>C<(x,0)>).
+
+=head2 X<factorback>factorbackC<(f,{nf})>
+
+C<f> being any factorization, gives back
+the factored object. If a second argument I<nf> is supplied, C<f> is
+assumed to be a prime ideal factorization in the number field I<nf>.
+The resulting ideal is given in HNFX<Hermite normal form> form.
+
+X<factorback>The library syntax is B<factorback>C<(f,>I<nf>C<)>, where an omitted
+I<nf> is entered as C<NULL>.
+
+=head2 X<factorcantor>factorcantorC<(x,p)>
+
+factors the polynomial C<x> modulo the
+prime C<p>, using distinct degree plus
+X<Cantor-Zassenhaus>Cantor-ZassenhausX<Zassenhaus>. The coefficients of C<x> must be
+operation-compatible with B<Z>C</p>B<Z>. The result is a two-column matrix, the
+first column being the irreducible polynomials dividing C<x>, and the second
+the exponents. If you want only the I<degrees> of the irreducible
+polynomials (for example for computing an C<L>-function), use
+C<factormod(x,p,1)>. Note that the C<factormod> algorithm is
+usually faster than C<factorcantor>.
+
+X<factcantor>The library syntax is B<factcantor>C<(x,p)>.
+
+=head2 X<factorff>factorffC<(x,p,a)>
+
+factors the polynomial C<x> in the field
+B<F>C<_q> defined by the irreducible polynomial C<a> over B<F>C<_p>. The
+coefficients of C<x> must be operation-compatible with B<Z>C</p>B<Z>. The result
+is a two-column matrix, the first column being the irreducible polynomials
+dividing C<x>, and the second the exponents. It is recommended to use for
+the variable of C<a> (which will be used as variable of a polmod) a name
+distinct from the other variables used, so that a C<lift()> of the
+result will be legible. If all the coefficients of C<x> are in B<F>C<_p>, a much faster algorithm is applied, using the computation of isomorphisms between finite fields.
+
+X<factmod9>The library syntax is B<factmod9>C<(x,p,a)>.
+
+=head2 X<factorial>factorialC<(x)> or C<x!>
+
+factorial of C<x>. The expression C<x!>
+gives a result which is an integer, while C<factorial(x)> gives a real
+number.
+
+X<mpfact>The library syntax is B<mpfact>C<(x)> for C<x!> and
+X<mpfactr>B<mpfactr>C<(x,>I<prec>C<)> for C<factorial(x)>. C<x> must be a C<long>
+integer and not a PARI integer.
+
+=head2 X<factorint>factorintC<(n,{>I<flag>C< = 0})>
+
+factors the integer n using a
+combination of the X<Shanks SQUFOF>Shanks SQUFOF and X<Pollard Rho>Pollard Rho method (with
+modifications due to Brent), X<Lenstra>Lenstra's X<ECM>ECM (with modifications by
+Montgomery), and X<MPQS>MPQS (the latter adapted from the X<LiDIA>LiDIA code
+with the kind permission of the LiDIA maintainers), as well as a search for
+pure powers with exponentsC< E<lt>= 10>. The output is a two-column matrix as for
+C<factor>.
+
+This gives direct access to the integer factoring engine called by most
+arithmetical functions. I<flag> is optional; its binary digits mean 1: avoid
+MPQS, 2: skip first stage ECM (we may still fall back to it later), 4: avoid
+Rho and SQUFOF, 8: don't run final ECM (as a result, a huge composite may be
+declared to be prime). Note that a (strong) probabilistic primality test is
+used; thus composites might (very rarely) not be detected.
+
+The machinery underlying this function is still in a somewhat experimental
+state, but should be much faster on average than pure ECM as used by all
+PARI versions up to 2.0.8, at the expense of heavier memory use. You are
+invited to play with the flag settings and watch the internals at work by
+using GP's X<debuglevel>C<debuglevel> default parameter (level 3 shows just the
+outline, 4 turns on time keeping, 5 and above show an increasing amount
+of internal details). If you see anything funny happening, please let
+us know.
+
+X<factorint>The library syntax is B<factorint>C<(n,>I<flag>C<)>.
+
+=head2 X<factormod>factormodC<(x,p,{>I<flag>C< = 0})>
+
+factors the polynomial C<x> modulo
+the prime integer C<p>, using X<Berlekamp>Berlekamp. The coefficients of C<x> must be
+operation-compatible with B<Z>C</p>B<Z>. The result is a two-column matrix, the
+first column being the irreducible polynomials dividing C<x>, and the second
+the exponents. If I<flag> is non-zero, outputs only the I<degrees> of the
+irreducible polynomials (for example, for computing an C<L>-function). A
+different algorithm for computing the mod C<p> factorization is
+C<factorcantor> which is sometimes faster.
+
+X<factormod>The library syntax is B<factormod>C<(x,p,>I<flag>C<)>. Also available are
+X<factmod>B<factmod>C<(x,p)> (which is equivalent to X<factormod>B<factormod>C<(x,p,0)>) and
+X<simplefactmod>B<simplefactmod>C<(x,p)> ( = X<factormod>B<factormod>C<(x,p,1)>).
+
+=head2 X<fibonacci>fibonacciC<(x)>
+
+C<x^{th}> Fibonacci number.
+
+X<fibo>The library syntax is B<fibo>C<(x)>. C<x> must be a C<long>.
+
+=head2 X<ffinit>ffinitC<(p,n,{v = x})>
+
+computes a monic polynomial of degree
+C<n> which is irreducible over B<F>C<_p>. For instance if
+C<P = ffinit(3,2,y)>, you can represent elements in B<F>C<_{3^2}> as polmods
+modulo C<P>.
+
+X<ffinit>The library syntax is B<ffinit>C<(p,n,v)>, where C<v> is a variable number.
+
+=head2 X<gcd>gcdC<(x,y,{>I<flag>C< = 0})>
+
+creates the greatest common divisor of C<x>
+and C<y>. C<x> and C<y> can be of quite general types, for instance both
+rational numbers. Vector/matrix types are also accepted, in which case
+the GCD is taken recursively on each component. Note that for these
+types, C<gcd> is not commutative.
+
+If I<flag>C< = 0>, use X<Euclid>Euclid's algorithm.
+
+If I<flag>C< = 1>, use the modular gcd algorithm (C<x> and C<y> have to be
+polynomials, with integer coefficients).
+
+If I<flag>C< = 2>, use the X<subresultant algorithm>subresultant algorithm.
+
+X<gcd0>The library syntax is B<gcd0>C<(x,y,>I<flag>C<)>. Also available are
+X<ggcd>B<ggcd>C<(x,y)>, X<modulargcd>B<modulargcd>C<(x,y)>, and X<srgcd>B<srgcd>C<(x,y)>
+corresponding to I<flag>C< = 0>, C<1> and C<2> respectively.
+
+=head2 X<hilbert>hilbertC<(x,y,{p})>
+
+X<Hilbert symbol>Hilbert symbol of C<x> and C<y> modulo
+C<p>. If C<x> and C<y> are of type integer or fraction, an explicit third
+parameter C<p> must be supplied, C<p = 0> meaning the place at infinity.
+Otherwise, C<p> needs not be given, and C<x> and C<y> can be of compatible types
+integer, fraction, real, integermod a prime (result is undefined if the
+modulus is not prime), or C<p>-adic.
+
+X<hil>The library syntax is B<hil>C<(x,y,p)>.
+
+=head2 X<isfundamental>isfundamentalC<(x)>
+
+true (1) if C<x> is equal to 1 or to the
+discriminant of a quadratic field, false (0) otherwise.
+
+X<gisfundamental>The library syntax is B<gisfundamental>C<(x)>, but the
+simpler function X<isfundamental>B<isfundamental>C<(x)> which returns a C<long>
+should be used if C<x> is known to be of type integer.
+
+=head2 X<isprime>isprimeC<(x,{>I<flag>C< = 0})>
+
+if I<flag>C< = 0> (default), true (1) if C<x> is a strong pseudo-prime
+for 10 randomly chosen bases, false (0) otherwise.
+
+If I<flag>C< = 1>, use Pocklington-Lehmer ``P-1'' test. true (1) if C<x> is
+prime, false (0) otherwise.
+
+If I<flag>C< = 2>, use Pocklington-Lehmer ``P-1'' test and output a primality
+certificate as follows: return 0 if C<x> is composite, 1 if C<x> is a
+small prime (currently strictly less than C<341 550 071 728 321>), and
+a matrix if C<x> is a large prime. The matrix has three columns. The
+first contains the prime factors C<p>, the second the corresponding
+elements C<a_p> as in PropositionS< >8.3.1 in GTMS< >138, and the third the
+output of isprime(p,2).
+
+In the two last cases, the algorithm fails if one of the (strong
+pseudo-)prime factors is not prime, but it should be exceedingly rare.
+
+X<gisprime>The library syntax is B<gisprime>C<(x,>I<flag>C<)>, but the simpler function X<isprime>B<isprime>C<(x)>
+which returns a C<long> should be used if C<x> is known to be of
+type integer. Also available is X<plisprime>B<plisprime>C<(N,>I<flag>C<)>,
+corresponding to X<gisprime>B<gisprime>C<(x,>I<flag>C<+1)> if C<x> is known to be of
+type integer.
+
+=head2 X<ispseudoprime>ispseudoprimeC<(x)>
+
+true (1) if C<x> is a strong
+pseudo-prime for a randomly chosen base, false (0) otherwise.
+
+X<gispsp>The library syntax is B<gispsp>C<(x)>, but the
+simpler function X<ispsp>B<ispsp>C<(x)> which returns a C<long>
+should be used if C<x> is known to be of type integer.
+
+=head2 X<issquare>issquareC<(x,{&n})>
+
+true (1) if C<x> is square, false (0) if
+not. C<x> can be of any type. If C<n> is given and an exact square root had to
+be computed in the checking process, puts that square root in C<n>. This is in
+particular the case when C<x> is an integer or a polynomial. This is I<not>
+the case for intmods (use quadratic reciprocity) or series (only check the
+leading coefficient).
+
+X<gcarrecomplet>The library syntax is B<gcarrecomplet>C<(x,&n)>. Also available is X<gcarreparfait>B<gcarreparfait>C<(x)>.
+
+=head2 X<issquarefree>issquarefreeC<(x)>
+
+true (1) if C<x> is squarefree, false (0) if not.
+Here C<x> can be an integer or a polynomial.
+
+X<gissquarefree>The library syntax is B<gissquarefree>C<(x)>, but the simpler function X<issquarefree>B<issquarefree>C<(x)>
+which returns a C<long> should be used if C<x> is known to be of type
+integer. This X<issquarefree>B<issquarefree> is just the square of the
+X<Moebius>Moebius function, and is computed as a multiplicative
+arithmetic function much like the latter.
+
+=head2 X<kronecker>kroneckerC<(x,y)>
+
+KroneckerX<Kronecker symbol>X<Legendre symbol>
+(i.e.S< >generalized Legendre) symbol C<((x)/(y))>. C<x> and C<y>
+must be of type integer.
+
+X<kronecker>The library syntax is B<kronecker>C<(x,y)>, the result (C<0> or C<F<+-> 1>) is a C<long>.
+
+=head2 X<lcm>lcmC<(x,y)>
+
+least common multiple of C<x> and C<y>, i.e.S< >such
+that C<lcm(x,y)*gcd(x,y) = abs(x*y)>.
+
+X<glcm>The library syntax is B<glcm>C<(x,y)>.
+
+=head2 X<moebius>moebiusC<(x)>
+
+X<Moebius>Moebius F<mu>-function of C<|x|>. C<x> must
+be of type integer.
+
+X<mu>The library syntax is B<mu>C<(x)>, the result (C<0> or C<F<+-> 1>) is a C<long>.
+
+=head2 X<nextprime>nextprimeC<(x)>
+
+finds the smallest prime greater than or
+equal to C<x>. C<x> can be of any real type. Note that if C<x> is a prime,
+this function returns C<x> and not the smallest prime strictly larger than C<x>.
+
+X<nextprime>The library syntax is B<nextprime>C<(x)>.
+
+=head2 X<numdiv>numdivC<(x)>
+
+number of divisors of C<|x|>. C<x> must be of type
+integer, and the result is a C<long>.
+
+X<numbdiv>The library syntax is B<numbdiv>C<(x)>.
+
+=head2 X<omega>omegaC<(x)>
+
+number of distinct prime divisors of C<|x|>. C<x>
+must be of type integer.
+
+X<omega>The library syntax is B<omega>C<(x)>, the result is a C<long>.
+
+=head2 X<precprime>precprimeC<(x)>
+
+finds the largest prime less than or equal to
+C<x>. C<x> can be of any real type. Returns 0 if C<x E<lt>= 1>.
+Note that if C<x> is a prime, this function returns C<x> and not the largest
+prime strictly smaller than C<x>.
+
+X<precprime>The library syntax is B<precprime>C<(x)>.
+
+=head2 X<prime>primeC<(x)>
+
+the C<x^{th}> prime number, which must be among
+the precalculated primes.
+
+X<prime>The library syntax is B<prime>C<(x)>. C<x> must be a C<long>.
+
+=head2 X<primes>primesC<(x)>
+
+creates a row vector whose components
+are the first C<x> prime numbers, which must be among the precalculated primes.
+
+X<primes>The library syntax is B<primes>C<(x)>. C<x> must be a C<long>.
+
+=head2 X<qfbclassno>qfbclassnoC<(x,{>I<flag>C< = 0})>
+
+class number of the quadratic field
+of discriminant C<x>. In the present version B<2.2.0>, a simple algorithm is used
+for C<x E<gt> 0>, so C<x> should not be too large (say C<x E<lt> 10^7>) for the time to be
+reasonable. On the other hand, for C<x E<lt> 0> one can reasonably compute
+classno(C<x>) for C<|x| E<lt> 10^{25}>, since the method used is X<Shanks>Shanks' method
+which is in C<O(|x|^{1/4})>. For larger values of C<|D|>, see
+C<quadclassunit>.
+
+If I<flag>C< = 1>, compute the class number using X<Euler product>Euler products and the
+functional equation. However, it is in C<O(|x|^{1/2})>.
+
+B<Important warning.> For C<D E<lt> 0>, this function often gives
+incorrect results when the class group is non-cyclic, because the authors
+were too lazy to implement X<Shanks>Shanks' method completely. It is therefore
+strongly recommended to use either the version with I<flag>C< = 1>, the function
+C<qfbhclassno(-x)> if C<x> is known to be a fundamental discriminant, or
+the function C<quadclassunit>.
+
+X<qfbclassno0>The library syntax is B<qfbclassno0>C<(x,>I<flag>C<)>. Also available are
+X<classno>B<classno>C<(x)> ( = X<qfbclassno>B<qfbclassno>C<(x)>),
+X<classno2>B<classno2>C<(x)> ( = X<qfbclassno>B<qfbclassno>C<(x,1)>), and finally
+there exists the function X<hclassno>B<hclassno>C<(x)> which computes the class
+number of an imaginary quadratic field by counting reduced forms, an C<O(|x|)>
+algorithm. See also C<qfbhclassno>.
+
+=head2 X<qfbcompraw>qfbcomprawC<(x,y)>
+
+X<composition>composition of the binary quadratic forms
+C<x> and C<y>, without X<reduction>reduction of the result. This is useful e.g.S< >to
+compute a generating element of an ideal.
+
+X<compraw>The library syntax is B<compraw>C<(x,y)>.
+
+=head2 X<qfbhclassno>qfbhclassnoC<(x)>
+
+X<Hurwitz class number>Hurwitz class number of C<x>, where C<x> is
+non-negative and congruent to 0 or 3 modulo 4. See also C<qfbclassno>.
+
+X<hclassno>The library syntax is B<hclassno>C<(x)>.
+
+=head2 X<qfbnucomp>qfbnucompC<(x,y,l)>
+
+X<composition>composition of the primitive positive
+definite binary quadratic forms C<x> and C<y> using the NUCOMP and NUDUPL
+algorithms of X<Shanks>Shanks (E<agrave> la Atkin). C<l> is any positive constant,
+but for optimal speed, one should take C<l = |D|^{1/4}>, where C<D> is the common
+discriminant of C<x> and C<y>. When C<x> and C<y> do not have the same
+discriminant, the result is undefined.
+
+X<nucomp>The library syntax is B<nucomp>C<(x,y,l)>. The auxiliary function
+X<nudupl>B<nudupl>C<(x,l)> should be used instead for speed when C<x = y>.
+
+=head2 X<qfbnupow>qfbnupowC<(x,n)>
+
+C<n>-th power of the primitive positive definite
+binary quadratic form C<x> using the NUCOMP and NUDUPL algorithms (see
+C<qfbnucomp>).
+
+X<nupow>The library syntax is B<nupow>C<(x,n)>.
+
+=head2 X<qfbpowraw>qfbpowrawC<(x,n)>
+
+C<n>-th power of the binary quadratic form
+C<x>, computed without doing any X<reduction>reduction (i.e.S< >using C<qfbcompraw>).
+Here C<n> must be non-negative and C<n E<lt> 2^{31}>.
+
+X<powraw>The library syntax is B<powraw>C<(x,n)> where C<n> must be a C<long>
+integer.
+
+=head2 X<qfbprimeform>qfbprimeformC<(x,p)>
+
+prime binary quadratic form of discriminant
+C<x> whose first coefficient is the prime number C<p>. By abuse of notation,
+C<p = 1> is a valid special case which returns the unit form. Returns an
+error if C<x> is not a quadratic residue mod C<p>. In the case where C<x E<gt> 0>,
+the ``distance'' component of the form is set equal to zero according to
+the current precision.
+
+X<primeform>The library syntax is B<primeform>C<(x,p,>I<prec>C<)>, where the third variable I<prec> is a
+C<long>, but is only taken into account when C<x E<gt> 0>.
+
+=head2 X<qfbred>qfbredC<(x,{>I<flag>C< = 0},{D},{>I<isqrtD>C<},{>I<sqrtD>C<})>
+
+reduces the binary quadratic form C<x> (updating Shanks's distance function
+if C<x> is indefinite). The binary digits of I<flag> are toggles meaning
+
+S< >S< >1: perform a single X<reduction>reduction step
+
+S< >S< >2: don't update X<Shanks>Shanks's distance
+
+C<D>, I<isqrtD>, I<sqrtD>, if present, supply the values of the
+discriminant, C<\lfloor > F<sqrt> C<{D}\rfloor>, and F<sqrt> C<{D}> respectively
+(no checking is done of these facts). If C<D E<lt> 0> these values are useless,
+and all references to Shanks's distance are irrelevant.
+
+X<qfbred0>The library syntax is B<qfbred0>C<(x,>I<flag>C<,D,>I<isqrtD>C<,>I<sqrtD>C<)>. Use C<NULL>
+to omit any of C<D>, I<isqrtD>, I<sqrtD>.
+
+Also available are
+
+X<redimag>B<redimag>C<(x)> ( = X<qfbred>B<qfbred>C<(x)> where C<x> is definite),
+
+and for indefinite forms:
+
+X<redreal>B<redreal>C<(x)> ( = X<qfbred>B<qfbred>C<(x)>),
+
+X<rhoreal>B<rhoreal>C<(x)> ( = X<qfbred>B<qfbred>C<(x,1)>),
+
+X<redrealnod>B<redrealnod>C<(x,sq)> ( = X<qfbred>B<qfbred>C<(x,2,,isqrtD)>),
+
+X<rhorealnod>B<rhorealnod>C<(x,sq)> ( = X<qfbred>B<qfbred>C<(x,3,,isqrtD)>).
+
+=head2 X<quadclassunit>quadclassunitC<(D,{>I<flag>C< = 0},{>I<tech>C< = []})>
+
+X<Buchmann-McCurley>Buchmann-McCurley's sub-exponential algorithm for computing the class
+group of a quadratic field of discriminant C<D>. If C<D> is not fundamental,
+the function may or may not be defined, but usually is, and often gives the
+right answer (a warning is issued). The more general function X<bnrinit>C<bnrinit>
+should be used to compute the class group of an order.
+
+This function should be used instead of C<qfbclassno> or C<quadregula>
+when C<D E<lt> -10^{25}>, C<D E<gt> 10^{10}>, or when the I<structure> is wanted.
+
+If I<flag> is non-zero I<and> C<D E<gt> 0>, computes the narrow class group and
+regulator, instead of the ordinary (or wide) ones. In the current version
+B<2.2.0>, this doesn't work at allS< >: use the general function X<bnfnarrow>C<bnfnarrow>.
+
+Optional parameter I<tech> is a row vector of the form
+C<[c_1,c_2]>, where C<c_1> and C<c_2> are positive real numbers which
+control the execution time and the stack size. To get maximum speed,
+set C<c_2 = c>. To get a rigorous result (under X<GRH>GRH) you must take
+C<c_2 = 6>. Reasonable values for C<c> are between C<0.1> and C<2>.
+
+The result of this function is a vector C<v> with 4 components if C<D E<lt> 0>, and
+C<5> otherwise. The correspond respectively to
+
+B<*> C<v[1]>S< >: the class number
+
+B<*> C<v[2]>S< >: a vector giving the structure of the class group as a
+product of cyclic groups;
+
+B<*> C<v[3]>S< >: a vector giving generators of those cyclic groups (as
+binary quadratic forms).
+
+B<*> C<v[4]>S< >: (omitted if C<D E<lt> 0>) the regulator, computed to an
+accuracy which is the maximum of an internal accuracy determined by the
+program and the current default (note that once the regulator is known to a
+small accuracy it is trivial to compute it to very high accuracy, see the
+tutorial).
+
+B<*> C<v[5]>S< >: a measure of the correctness of the result. If it is
+close to 1, the result is correct (under X<GRH>GRH). If it is close to a
+larger integer, this shows that the class number is off by a factor equal
+to this integer, and you must start again with a larger value for C<c_1> or
+a different random seed. In this case, a warning message is printed.
+
+X<quadclassunit0>The library syntax is B<quadclassunit0>C<(D,>I<flag>C<,tech)>. Also available are
+X<buchimag>B<buchimag>C<(D,c_1,c_2)> and X<buchreal>B<buchreal>C<(D,>I<flag>C<,c_1,c_2)>.
+
+=head2 X<quaddisc>quaddiscC<(x)>
+
+discriminant of the quadratic field
+B<Q>C<(> F<sqrt> C<{x})>, where C<x belongs to >B<Q>.
+
+X<quaddisc>The library syntax is B<quaddisc>C<(x)>.
+
+=head2 X<quadhilbert>quadhilbertC<(D,{>I<flag>C< = 0})>
+
+relative equation defining the
+X<Hilbert class field>Hilbert class field of the quadratic field of discriminant C<D>.
+If I<flag> is non-zero
+and C<D E<lt> 0>, outputs C<[>I<form>C<,>I<root>C<(>I<form>C<)]> (to be used for
+constructing subfields). If I<flag> is non-zero and C<D E<gt> 0>, try hard to
+get the best modulus.
+Uses complex multiplication in the imaginary case and X<Stark units>Stark units
+in the real case.
+
+X<quadhilbert>The library syntax is B<quadhilbert>C<(D,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<quadgen>quadgenC<(x)>
+
+creates the quadratic numberX<omega>
+F<omega>C< = (a+> F<sqrt> C<{x})/2> where C<a = 0> if C<x = 0 mod 4>,
+C<a = 1> if C<x = 1 mod 4>, so that C<(1,>F<omega>C<)> is an integral basis for
+the quadratic order of discriminant C<x>. C<x> must be an integer congruent to
+0 or 1 modulo 4.
+
+X<quadgen>The library syntax is B<quadgen>C<(x)>.
+
+=head2 X<quadpoly>quadpolyC<(D,{v = x})>
+
+creates the ``canonical'' quadratic
+polynomial (in the variable C<v>) corresponding to the discriminant C<D>,
+i.e.S< >the minimal polynomial of C<quadgen(x)>. C<D> must be an integer
+congruent to 0 or 1 modulo 4.
+
+X<quadpoly0>The library syntax is B<quadpoly0>C<(x,v)>.
+
+=head2 X<quadray>quadrayC<(D,f,{>I<flag>C< = 0})>
+
+relative equation for the ray class
+field of conductor C<f> for the quadratic field of discriminant C<D> (which
+can also be a C<bnf>), using analytic methods.
+
+For C<D E<lt> 0>, uses the F<sigma> function. I<flag> has the following meaning: if
+it's an odd integer, outputs instead the vector of C<[>I<ideal>C<,
+>I<corresponding root>C<]>. It can also be a two-component vector
+C<[>F<lambda>C<,>I<flag>C<]>, where I<flag> is as above and F<lambda> is the technical
+element of C<bnf> necessary for Schertz's method. In that case, returns
+0 if F<lambda> is not suitable.
+
+For C<D E<gt> 0>, uses Stark's conjecture. If I<flag> is non-zero, try hard to
+get the best modulus. The function may fail with the following message
+
+ "Cannot find a suitable modulus in FindModulus"
+
+See X<bnrstark>C<bnrstark> for more details about the real case.
+
+X<quadray>The library syntax is B<quadray>C<(D,f,>I<flag>C<)>.
+
+=head2 X<quadregulator>quadregulatorC<(x)>
+
+regulator of the quadratic field of
+positive discriminant C<x>. Returns an error if C<x> is not a discriminant
+(fundamental or not) or if C<x> is a square. See also C<quadclassunit> if
+C<x> is large.
+
+X<regula>The library syntax is B<regula>C<(x,>I<prec>C<)>.
+
+=head2 X<quadunit>quadunitC<(x)>
+
+fundamental unitX<fundamental units> of the
+real quadratic field B<Q>C<(> F<sqrt> C< x)> where C<x> is the positive discriminant
+of the field. If C<x> is not a fundamental discriminant, this probably gives
+the fundamental unit of the corresponding order. C<x> must be of type
+integer, and the result is a quadratic number.
+
+X<fundunit>The library syntax is B<fundunit>C<(x)>.
+
+=head2 X<removeprimes>removeprimesC<({x = []})>
+
+removes the primes listed in C<x> from
+the prime number table. In particular C<removeprimes(addprimes)> empties
+the extra prime table. C<x> can also be a single integer. List the current
+extra primes if C<x> is omitted.
+
+X<removeprimes>The library syntax is B<removeprimes>C<(x)>.
+
+=head2 X<sigma>sigmaC<(x,{k = 1})>
+
+sum of the C<k^{th}> powers of the
+positive divisors of C<|x|>. C<x> must be of type integer.
+
+X<sumdiv>The library syntax is B<sumdiv>C<(x)> ( = X<sigma>B<sigma>C<(x)>) or X<gsumdivk>B<gsumdivk>C<(x,k)> ( =
+X<sigma>B<sigma>C<(x,k)>), where C<k> is a C long integer.
+
+=head2 X<sqrtint>sqrtintC<(x)>
+
+integer square root of C<x>, which must be of PARI
+type integer. The result is non-negative and rounded towards zero. A
+negative C<x> is allowed, and the result in that case is C<I*sqrtint(-x)>.
+
+X<racine>The library syntax is B<racine>C<(x)>.
+
+=head2 X<znlog>znlogC<(x,g)>
+
+C<g> must be a primitive root mod a prime C<p>, and
+the result is the discrete log of C<x> in the multiplicative group
+C<(>B<Z>C</p>B<Z>C<)^*>. This function using a simple-minded baby-step/giant-step
+approach and requires C<O(> F<sqrt> C<{p})> storage, hence it cannot be used for
+C<p> greater than about C<10^{13}>.
+
+X<znlog>The library syntax is B<znlog>C<(x,g)>.
+
+=head2 X<znorder>znorderC<(x)>
+
+C<x> must be an integer mod C<n>, and the result is the
+order of C<x> in the multiplicative group C<(>B<Z>C</n>B<Z>C<)^*>. Returns an error if C<x>
+is not invertible.
+
+X<order>The library syntax is B<order>C<(x)>.
+
+=head2 X<znprimroot>znprimrootC<(x)>
+
+returns a primitive root of C<x>, where C<x>
+is a prime power.
+
+X<gener>The library syntax is B<gener>C<(x)>.
+
+=head2 X<znstar>znstarC<(n)>
+
+gives the structure of the multiplicative group
+C<(>B<Z>C</n>B<Z>C<)^*> as a 3-component row vector C<v>, where C<v[1] = >F<phi>C<(n)> is the
+order of that group, C<v[2]> is a C<k>-component row-vector C<d> of integers
+C<d[i]> such that C<d[i] E<gt> 1> and C<d[i] | d[i-1]> for C<i E<gt>= 2> and
+C<(>B<Z>C</n>B<Z>C<)^* ~ >F<prod>C<_{i = 1}^k(>B<Z>C</d[i]>B<Z>C<)>, and C<v[3]> is a C<k>-component row
+vector giving generators of the image of the cyclic groups B<Z>C</d[i]>B<Z>.
+
+X<znstar>The library syntax is B<znstar>C<(n)>.
+
+=head1 Functions related to elliptic curves
+
+We have implemented a number of functions which are useful for number
+theorists working on elliptic curves. We always use X<Tate>Tate's notations.
+The functions assume that the curve is given by a general Weierstrass
+modelX<Weierstrass equation>
+
+S< >C<
+y^2+a_1xy+a_3y = x^3+a_2x^2+a_4x+a_6,
+>
+
+where a priori the C<a_i> can be of any scalar type. This curve can be
+considered as a five-component vector C<E = [a1,a2,a3,a4,a6]>. Points on
+C<E> are represented as two-component vectors C<[x,y]>, except for the
+point at infinity, i.e.S< >the identity element of the group law, represented by
+the one-component vector C<[0]>.
+
+It is useful to have at one's disposal more information. This is given by
+the function X<ellinit>C<ellinit> (see there), which usually gives a 19 component
+vector (which we will call a long vector in this section). If a specific flag
+is added, a vector with only 13 component will be output (which we will call
+a medium vector). A medium vector just gives the first 13 components of the
+long vector corresponding to the same curve, but is of course faster to
+compute. The following X<member functions>member functions are available to deal with the
+output of C<ellinit>:
+
+S< > C<a1>--C<a6>, C<b2>--C<b8>, C<c4>--C<c6> :
+coefficients of the elliptic curve.
+
+S< > X<area>C<area> : volume of the complex lattice defining C<E>.
+
+S< > X<disc>C<disc> : discriminant of the curve.
+
+S< > X<j>C<j> : C<j>-invariant of the curve.
+
+S< > X<omega>C<omega> : C<[>F<omega>C<_1,>F<omega>C<_2]>, periods forming a basis of
+the complex lattice defining C<E> (F<omega>C<_1> is the
+
+S< > real period, and F<omega>C<_2/>F<omega>C<_1> belongs to
+PoincarE<eacute>'s half-plane).
+
+S< > X<eta>C<eta> : quasi-periods C<[>F<eta>C<_1, >F<eta>C<_2]>, such that
+F<eta>C<_1>F<omega>C<_2->F<eta>C<_2>F<omega>C<_1 = i>F<Pi>.
+
+S< > X<roots>C<roots> : roots of the associated Weierstrass equation.
+
+S< > X<tate>C<tate> : C<[u^2,u,v]> in the notation of Tate.
+
+S< > X<w>C<w> : Mestre's C<w> (this is technical).
+
+Their use is best described by an example: assume that C<E> was output by
+C<ellinit>, then typing C<E.disc> will retrieve the curve's
+discriminant. The member functions C<area>, C<eta> and C<omega> are
+only available for curves over B<Q>. Conversely, C<tate> and C<w> are
+only available for curves defined over B<Q>C<_p>.
+
+Some functions, in particular those relative to height computations (see
+C<ellheight>) require also that the curve be in minimal Weierstrass
+form. This is achieved by the function C<ellglobalred>.
+
+All functions related to elliptic curves share the prefix C<ell>, and the
+precise curve we are interested in is always the first argument, in either
+one of the three formats discussed above, unless otherwise specified. For
+instance, in functions which do not use the extra information given by long
+vectors, the curve can be given either as a five-component vector, or by one
+of the longer vectors computed by C<ellinit>.
+
+=head2 X<elladd>elladdC<(E,z1,z2)>
+
+sum of the points C<z1> and C<z2> on the
+elliptic curve corresponding to the vector C<E>.
+
+X<addell>The library syntax is B<addell>C<(E,z1,z2)>.
+
+=head2 X<ellak>ellakC<(E,n)>
+
+computes the coefficient C<a_n> of the
+C<L>-function of the elliptic curve C<E>, i.e.S< >in principle coefficients of a
+newform of weight 2 assuming X<Taniyama-Weil conjecture>Taniyama-Weil conjecture (which is now
+known to hold in full generality thanks to the work of X<Breuil>Breuil,
+X<Conrad>Conrad, X<Diamond>Diamond, X<Taylor>Taylor and X<Wiles>Wiles). C<E> must be a
+medium or long vector of the type given by C<ellinit>. For this function
+to work for every C<n> and not just those prime to the conductor, C<E> must
+be a minimal Weierstrass equation. If this is not the case, use the
+function C<ellglobalred> first before using C<ellak>.
+
+X<akell>The library syntax is B<akell>C<(E,n)>.
+
+=head2 X<ellan>ellanC<(E,n)>
+
+computes the vector of the first C<n> C<a_k>
+corresponding to the elliptic curve C<E>. All comments in C<ellak>
+description remain valid.
+
+X<anell>The library syntax is B<anell>C<(E,n)>, where C<n> is a C integer.
+
+=head2 X<ellap>ellapC<(E,p,{>I<flag>C< = 0})>
+
+computes the C<a_p> corresponding to the
+elliptic curve C<E> and the prime number C<p>. These are defined by the
+equation C<#E(>B<F>C<_p) = p+1 - a_p>, where C<#E(>B<F>C<_p)> stands for the number
+of points of the curve C<E> over the finite field B<F>C<_p>. When I<flag> is C<0>,
+this uses the baby-step giant-step method and a trick due to Mestre. This
+runs in time C<O(p^{1/4})> and requires C<O(p^{1/4})> storage, hence becomes
+unreasonable when C<p> has about 30 digits.
+
+If I<flag> is C<1>, computes the C<a_p> as a sum of Legendre symbols. This is
+slower than the previous method as soon as C<p> is greater than 100, say.
+
+No checking is done that C<p> is indeed prime. C<E> must be a medium or long
+vector of the type given by C<ellinit>, defined over B<Q>, B<F>C<_p> or
+B<Q>C<_p>. C<E> must be given by a Weierstrass equation minimal at C<p>.
+
+X<ellap0>The library syntax is B<ellap0>C<(E,p,>I<flag>C<)>. Also available are X<apell>B<apell>C<(E,p)>, corresponding
+to I<flag>C< = 0>, and X<apell2>B<apell2>C<(E,p)> (I<flag>C< = 1>).
+
+=head2 X<ellbil>ellbilC<(E,z1,z2)>
+
+if C<z1> and C<z2> are points on the elliptic
+curve C<E>, this function computes the value of the canonical bilinear form on
+C<z1>, C<z2>:
+
+S< >C<
+ellheight(E,z1+z2) - ellheight(E,z1) - ellheight(E,z2)
+>
+
+where C<+> denotes of course addition on C<E>. In addition, C<z1> or C<z2>
+(but not both) can be vectors or matrices. Note that this is equal to twice
+some normalizations. C<E> is assumed to be integral, given by a minimal model.
+
+X<bilhell>The library syntax is B<bilhell>C<(E,z1,z2,>I<prec>C<)>.
+
+=head2 X<ellchangecurve>ellchangecurveC<(E,v)>
+
+changes the data for the elliptic curve C<E>
+by changing the coordinates using the vector C<v = [u,r,s,t]>, i.e.S< >if C<x'>
+and C<y'> are the new coordinates, then C<x = u^2x'+r>, C<y = u^3y'+su^2x'+t>.
+The vector C<E> must be a medium or long vector of the type given by
+C<ellinit>.
+
+X<coordch>The library syntax is B<coordch>C<(E,v)>.
+
+=head2 X<ellchangepoint>ellchangepointC<(x,v)>
+
+changes the coordinates of the point or
+vector of points C<x> using the vector C<v = [u,r,s,t]>, i.e.S< >if C<x'> and
+C<y'> are the new coordinates, then C<x = u^2x'+r>, C<y = u^3y'+su^2x'+t> (see also
+C<ellchangecurve>).
+
+X<pointch>The library syntax is B<pointch>C<(x,v)>.
+
+=head2 X<elleisnum>elleisnumC<(E,k,{>I<flag>C< = 0})>
+
+C<E> being an elliptic curve as
+output by C<ellinit> (or, alternatively, given by a 2-component vector
+C<[>F<omega>C<_1,>F<omega>C<_2]>), and C<k> being an even positive integer, computes
+the numerical value of the Eisenstein series of weight C<k> at C<E>. When
+I<flag> is non-zero and C<k = 4> or 6, returns C<g_2> or C<g_3> with the correct
+normalization.
+
+X<elleisnum>The library syntax is B<elleisnum>C<(E,k,>I<flag>C<)>.
+
+=head2 X<elleta>elletaC<(om)>
+
+returns the two-component row vector
+C<[>F<eta>C<_1,>F<eta>C<_2]> of quasi-periods associated to C<om = [>F<omega>C<_1,
+>F<omega>C<_2]>
+
+X<elleta>The library syntax is B<elleta>C<(om, >I<prec>C<)>
+
+=head2 X<ellglobalred>ellglobalredC<(E)>
+
+calculates the arithmetic conductor, the global
+minimal model of C<E> and the global X<Tamagawa number>Tamagawa number C<c>. Here C<E> is an
+elliptic curve given by a medium or long vector of the type given by
+C<ellinit>, I<and is supposed to have all its coefficients >C<a_i>I< in>
+B<Q>. The result is a 3 component vector C<[N,v,c]>. C<N> is the arithmetic
+conductor of the curve, C<v> is itself a vector C<[u,r,s,t]> with rational
+components. It gives a coordinate change for C<E> over B<Q> such that the
+resulting model has integral coefficients, is everywhere minimal, C<a_1> is 0
+or 1, C<a_2> is 0, 1 or C<-1> and C<a_3> is 0 or 1. Such a model is unique, and
+the vector C<v> is unique if we specify that C<u> is positive. To get the new
+model, simply type C<ellchangecurve(E,v)>. Finally C<c> is the product of
+the local Tamagawa numbers C<c_p>, a quantity which enters in the
+X<Birch and Swinnerton-Dyer conjecture>Birch and Swinnerton-Dyer conjecture.
+
+X<globalreduction>The library syntax is B<globalreduction>C<(E)>.
+
+=head2 X<ellheight>ellheightC<(E,z,{>I<flag>C< = 0})>
+
+global X<NE<eacute>ron-Tate height>NE<eacute>ron-Tate height of
+the point C<z> on the elliptic curve C<E>. The vector C<E> must be a long vector
+of the type given by C<ellinit>, with I<flag>C< = 1>. If I<flag>C< = 0>, this
+computation is done using sigma and theta-functions and a trick due to J.
+Silverman. If I<flag>C< = 1>, use Tate's C<4^n> algorithm, which is much slower.
+C<E> is assumed to be integral, given by a minimal model.
+
+X<ellheight0>The library syntax is B<ellheight0>C<(E,z,>I<flag>C<,>I<prec>C<)>. The Archimedean
+contribution alone is given by the library function
+X<hell>B<hell>C<(E,z,>I<prec>C<)>.
+Also available are X<ghell>B<ghell>C<(E,z,>I<prec>C<)> (I<flag>C< = 0>) and
+X<ghell2>B<ghell2>C<(E,z,>I<prec>C<)> (I<flag>C< = 1>).
+
+=head2 X<ellheightmatrix>ellheightmatrixC<(E,x)>
+
+C<x> being a vector of points, this
+function outputs the Gram matrix of C<x> with respect to the NE<eacute>ron-Tate
+height, in other words, the C<(i,j)> component of the matrix is equal to
+C<ellbil(E,x[i],x[j])>. The rank of this matrix, at least in some
+approximate sense, gives the rank of the set of points, and if C<x> is a
+basis of the X<Mordell-Weil group>Mordell-Weil group of C<E>, its determinant is equal to
+the regulator of C<E>. Note that this matrix should be divided by 2 to be in
+accordance with certain normalizations. C<E> is assumed to be integral,
+given by a minimal model.
+
+X<mathell>The library syntax is B<mathell>C<(E,x,>I<prec>C<)>.
+
+=head2 X<ellinit>ellinitC<(E,{>I<flag>C< = 0})>
+
+computes some fixed data concerning the
+elliptic curve given by the five-component vector C<E>, which will be
+essential for most further computations on the curve. The result is a
+19-component vector E (called a long vector in this section), shortened
+to 13 components (medium vector) if I<flag>C< = 1>. Both contain the
+following information in the first 13 components:
+
+S< >C< a_1,a_2,a_3,a_4,a_6,b_2,b_4,b_6,b_8,c_4,c_6,>F<Delta>C<,j.>
+
+In particular, the discriminant is C<E[12]> (or C<E.disc>), and the
+C<j>-invariant is C<E[13]> (or C<E.j>).
+
+The other six components are only present if I<flag> is C<0> (or omitted!).
+Their content depends on whether the curve is defined over B<R> or not:
+
+B<*> When C<E> is defined over B<R>, C<E[14]> (C<E.roots>) is a
+vector whose three components contain the roots of the associated Weierstrass
+equation. If the roots are all real, then they are ordered by decreasing
+value. If only one is real, it is the first component of C<E[14]>.
+
+C<E[15]> (C<E.omega[1]>) is the real period of C<E> (integral of
+C<dx/(2y+a_1x+a_3)> over the connected component of the identity element of
+the real points of the curve), and C<E[16]> (C<E.omega[2]>) is a complex
+period. In other words, F<omega>C<_1 = E[15]> and F<omega>C<_2 = E[16]> form a basis of
+the complex lattice defining C<E> (C<E.omega>), with
+F<tau>C< = (>F<omega>C<_2)/(>F<omega>C<_1)> having positive imaginary part.
+
+C<E[17]> and C<E[18]> are the corresponding values F<eta>C<_1> and F<eta>C<_2> such
+that F<eta>C<_1>F<omega>C<_2->F<eta>C<_2>F<omega>C<_1 = i>F<Pi>, and both can be retrieved by
+typing C<E.eta> (as a row vector whose components are the F<eta>C<_i>).
+
+Finally, C<E[19]> (C<E.area>) is the volume of the complex lattice defining
+C<E>.
+
+B<*> When C<E> is defined over B<Q>C<_p>, the C<p>-adic valuation of C<j>
+must be negative. Then C<E[14]> (C<E.roots>) is the vector with a single
+component equal to the C<p>-adic root of the associated Weierstrass equation
+corresponding to C<-1> under the Tate parametrization.
+
+C<E[15]> is equal to the square of the C<u>-value, in the notation of Tate.
+
+C<E[16]> is the C<u>-value itself, if it belongs to B<Q>C<_p>, otherwise zero.
+
+C<E[17]> is the value of Tate's C<q> for the curve C<E>.
+
+C<E.tate> will yield the three-component vector C<[u^2,u,q]>.
+
+C<E[18]> (C<E.w>) is the value of Mestre's C<w> (this is technical), and
+C<E[19]> is arbitrarily set equal to zero.
+
+For all other base fields or rings, the last six components are arbitrarily
+set equal to zero (see also the description of member functions related to
+elliptic curves at the beginning of this section).
+
+X<ellinit0>The library syntax is B<ellinit0>C<(E,>I<flag>C<,>I<prec>C<)>. Also available are
+X<initell>B<initell>C<(E,>I<prec>C<)> (I<flag>C< = 0>) and
+X<smallinitell>B<smallinitell>C<(E,>I<prec>C<)> (I<flag>C< = 1>).
+
+=head2 X<ellisoncurve>ellisoncurveC<(E,z)>
+
+gives 1 (i.e.S< >true) if the point C<z> is on
+the elliptic curve C<E>, 0 otherwise. If C<E> or C<z> have imprecise coefficients,
+an attempt is made to take this into account, i.e.S< >an imprecise equality is
+checked, not a precise one.
+
+X<oncurve>The library syntax is B<oncurve>C<(E,z)>, and the result is a C<long>.
+
+=head2 X<ellj>elljC<(x)>
+
+elliptic C<j>-invariant. C<x> must be a complex number
+with positive imaginary part, or convertible into a power series or a
+C<p>-adic number with positive valuation.
+
+X<jell>The library syntax is B<jell>C<(x,>I<prec>C<)>.
+
+=head2 X<elllocalred>elllocalredC<(E,p)>
+
+calculates the X<Kodaira>Kodaira type of the
+local fiber of the elliptic curve C<E> at the prime C<p>.
+C<E> must be given by a medium or
+long vector of the type given by C<ellinit>, and is assumed to have all
+its coefficients C<a_i> in B<Z>. The result is a 4-component vector
+C<[f,kod,v,c]>. Here C<f> is the exponent of C<p> in the arithmetic conductor of
+C<E>, and C<kod> is the Kodaira type which is coded as follows:
+
+1 means good reduction (type IC<_0>), 2, 3 and 4 mean types II, III and IV
+respectively, C<4+>F<nu> with F<nu>C< E<gt> 0> means type IC<_>F<nu>;
+finally the opposite values C<-1>, C<-2>, etc.S< >refer to the starred types
+IC<_0^*>, IIC<^*>, etc. The third component C<v> is itself a vector C<[u,r,s,t]>
+giving the coordinate changes done during the local reduction. Normally, this
+has no use if C<u> is 1, that is, if the given equation was already minimal.
+Finally, the last component C<c> is the local X<Tamagawa number>Tamagawa number C<c_p>.
+
+X<localreduction>The library syntax is B<localreduction>C<(E,p)>.
+
+=head2 X<elllseries>elllseriesC<(E,s,{A = 1})>
+
+C<E> being a medium or long vector
+given by C<ellinit>, this computes the value of the L-series of C<E> at
+C<s>. It is assumed that C<E> is a minimal model over B<Z> and that the curve
+is a modular elliptic curve. The optional parameter C<A> is a cutoff point for
+the integral, which must be chosen close to 1 for best speed. The result
+must be independent of C<A>, so this allows some internal checking of the
+function.
+
+Note that if the conductor of the curve is large, say greater than C<10^{12}>,
+this function will take an unreasonable amount of time since it uses an
+C<O(N^{1/2})> algorithm.
+
+X<lseriesell>The library syntax is B<lseriesell>C<(E,s,A,>I<prec>C<)> where I<prec> is a C<long> and an
+omitted C<A> is coded as C<NULL>.
+
+=head2 X<ellorder>ellorderC<(E,z)>
+
+gives the order of the point C<z> on the elliptic
+curve C<E> if it is a torsion point, zero otherwise. In the present version
+B<2.2.0>, this is implemented only for elliptic curves defined over B<Q>.
+
+X<orderell>The library syntax is B<orderell>C<(E,z)>.
+
+=head2 X<ellordinate>ellordinateC<(E,x)>
+
+gives a 0, 1 or 2-component vector containing
+the C<y>-coordinates of the points of the curve C<E> having C<x> as
+C<x>-coordinate.
+
+X<ordell>The library syntax is B<ordell>C<(E,x)>.
+
+=head2 X<ellpointtoz>ellpointtozC<(E,z)>
+
+if C<E> is an elliptic curve with coefficients
+in B<R>, this computes a complex number C<t> (modulo the lattice defining
+C<E>) corresponding to the point C<z>, i.e.S< >such that, in the standard
+Weierstrass model, F<wp> C<(t) = z[1],> F<wp> C<'(t) = z[2]>. In other words, this is the
+inverse function of C<ellztopoint>.
+
+If C<E> has coefficients in B<Q>C<_p>, then either Tate's C<u> is in B<Q>C<_p>, in
+which case the output is a C<p>-adic number C<t> corresponding to the point C<z>
+under the Tate parametrization, or only its square is, in which case the
+output is C<t+1/t>. C<E> must be a long vector output by C<ellinit>.
+
+X<zell>The library syntax is B<zell>C<(E,z,>I<prec>C<)>.
+
+=head2 X<ellpow>ellpowC<(E,z,n)>
+
+computes C<n> times the point C<z> for the
+group law on the elliptic curve C<E>. Here, C<n> can be in B<Z>, or C<n>
+can be a complex quadratic integer if the curve C<E> has complex multiplication
+by C<n> (if not, an error message is issued).
+
+X<powell>The library syntax is B<powell>C<(E,z,n)>.
+
+=head2 X<ellrootno>ellrootnoC<(E,{p = 1})>
+
+C<E> being a medium or long vector given
+by C<ellinit>, this computes the local (if C<p ! = 1>) or global (if C<p = 1>)
+root number of the L-series of the elliptic curve C<E>. Note that the global
+root number is the sign of the functional equation and conjecturally is the
+parity of the rank of the X<Mordell-Weil group>Mordell-Weil group.
+The equation for C<E> must have
+coefficients in B<Q> but need I<not> be minimal.
+
+X<ellrootno>The library syntax is B<ellrootno>C<(E,p)> and the result (equal to C<F<+->1>) is a C<long>.
+
+=head2 X<ellsigma>ellsigmaC<(E,z,{>I<flag>C< = 0})>
+
+value of the Weierstrass F<sigma>
+function of the lattice associated to C<E> as given by C<ellinit>
+(alternatively, C<E> can be given as a lattice C<[>F<omega>C<_1,>F<omega>C<_2]>).
+
+If I<flag>C< = 1>, computes an (arbitrary) determination of F<log> C<(>F<sigma>C<(z))>.
+
+If I<flag>C< = 2,3>, same using the product expansion instead of theta series.
+X<ellsigma>The library syntax is B<ellsigma>C<(E,z,>I<flag>C<)>
+
+=head2 X<ellsub>ellsubC<(E,z1,z2)>
+
+difference of the points C<z1> and C<z2> on the
+elliptic curve corresponding to the vector C<E>.
+
+X<subell>The library syntax is B<subell>C<(E,z1,z2)>.
+
+=head2 X<elltaniyama>elltaniyamaC<(E)>
+
+computes the modular parametrization of the
+elliptic curve C<E>, where C<E> is given in the (long or medium) format output
+by C<ellinit>, in the form of a two-component vector C<[u,v]> of power
+series, given to the current default series precision. This vector is
+characterized by the following two properties. First the point C<(x,y) = (u,v)>
+satisfies the equation of the elliptic curve. Second, the differential
+C<du/(2v+a_1u+a_3)> is equal to C<f(z)dz>, a differential form on
+C<H/>F<Gamma>C<_0(N)> where C<N> is the conductor of the curve. The variable used in
+the power series for C<u> and C<v> is C<x>, which is implicitly understood to be
+equal to F<exp> C<(2i>F<Pi>C< z)>. It is assumed that the curve is a I<strong>
+X<Weil curve>Weil curve, and the Manin constant is equal to 1. The equation of
+the curve C<E> must be minimal (use C<ellglobalred> to get a minimal
+equation).
+
+X<taniyama>The library syntax is B<taniyama>C<(E)>, and the precision of the result is determined by the
+global variable C<precdl>.
+
+=head2 X<elltors>elltorsC<(E,{>I<flag>C< = 0})>
+
+if C<E> is an elliptic curve I<defined
+over >B<Q>, outputs the torsion subgroup of C<E> as a 3-component vector
+C<[t,v1,v2]>, where C<t> is the order of the torsion group, C<v1>
+gives the structure of the torsion group as a product of cyclic groups
+(sorted by decreasing order), and C<v2> gives generators for these cyclic
+groups. C<E> must be a long vector as output by C<ellinit>.
+
+ ? E = ellinit([0,0,0,-1,0]);
+ ? elltors(E)
+ %1 = [4, [2, 2], [[0, 0], [1, 0]]]
+
+Here, the torsion subgroup is isomorphic to B<Z>C</2>B<Z>C< x >B<Z>C</2>B<Z>, with
+generators C<[0,0]> and C<[1,0]>.
+
+If I<flag>C< = 0>, use Doud's algorithmS< >: bound torsion by computing C<#E(>B<F>C<_p)>
+for small primes of good reduction, then look for torsion points using
+Weierstrass parametrization (and Mazur's classification).
+
+If I<flag>C< = 1>, use Lutz--Nagell (I<much> slower), C<E> is allowed to be a
+medium vector.
+
+X<elltors0>The library syntax is B<elltors0>C<(E,flag)>.
+
+=head2 X<ellwp>ellwpC<(E,{z = x},{>I<flag>C< = 0})>
+
+Computes the value at C<z> of the Weierstrass F<wp> function attached to the
+elliptic curve C<E> as given by C<ellinit> (alternatively, C<E> can be
+given as a lattice C<[>F<omega>C<_1,>F<omega>C<_2]>).
+
+If C<z> is omitted or is a simple variable, computes the I<power series>
+expansion in C<z> (starting C<z^{-2}+O(z^2)>). The number of terms to an
+I<even> power in the expansion is the default serieslength in GP, and the
+second argument (C long integer) in library mode.
+
+Optional I<flag> is (for now) only taken into account when C<z> is numeric, and
+means 0: compute only F<wp> C<(z)>, 1: compute C<[> F<wp> C<(z),> F<wp> C<'(z)]>.
+
+X<ellwp0>The library syntax is B<ellwp0>C<(E,z,>I<flag>C<,>I<prec>C<,>I<precdl>C<)>. Also available is
+X<weipell>B<weipell>C<(E,>I<precdl>C<)> for the power series (in
+C<x = polx[0]>).
+
+=head2 X<ellzeta>ellzetaC<(E,z)>
+
+value of the Weierstrass F<zeta> function of the
+lattice associated to C<E> as given by C<ellinit> (alternatively, C<E> can
+be given as a lattice C<[>F<omega>C<_1,>F<omega>C<_2]>).
+
+X<ellzeta>The library syntax is B<ellzeta>C<(E,z)>.
+
+=head2 X<ellztopoint>ellztopointC<(E,z)>
+
+C<E> being a long vector, computes the
+coordinates C<[x,y]> on the curve C<E> corresponding to the complex number C<z>.
+Hence this is the inverse function of C<ellpointtoz>. In other words, if
+the curve is put in Weierstrass form, C<[x,y]> represents the
+X<Weierstrass > F<wp> X<-function>Weierstrass F<wp> -function and its derivative.
+If C<z> is in the lattice defining C<E> over
+B<C>, the result is the point at infinity C<[0]>.
+
+X<pointell>The library syntax is B<pointell>C<(E,z,>I<prec>C<)>.
+
+=head1 Functions related to general number fields
+
+In this section can be found functions which are used almost exclusively for
+working in general number fields. Other less specific functions can be found
+in the next section on polynomials. Functions related to quadratic number
+fields can be found in the section L<Label se:arithmetic> (Arithmetic
+functions).
+
+We shall use the following conventions:
+
+B<*> X<nf>I<nf> denotes a number field, i.e.S< >a 9-component vector
+in the format output by X<nfinit>C<nfinit>. This contains the basic arithmetic data
+associated to the number field: signature, maximal order, discriminant, etc.
+
+B<*> X<bnf>I<bnf> denotes a big number field, i.e.S< >a 10-component
+vector in the format output by X<bnfinit>C<bnfinit>. This contains I<nf> and
+the deeper invariants of the field: units, class groups, as well as a lot of
+technical data necessary for some complex fonctions like C<bnfisprincipal>.
+
+B<*> X<bnr>I<bnr> denotes a big ``ray number field'', i.e.S< >some data
+structure output by C<bnrinit>, even more complicated than I<bnf>,
+corresponding to the ray class group structure of the field, for some
+modulus.
+
+B<*> X<rnf>I<rnf> denotes a relative number field (see below).
+
+B<*> X<ideal>I<ideal> can mean any of the following:
+
+S< >S< >-- a B<Z>-basis, in X<Hermite normal form>Hermite normal form
+(HNF) or not. In this case C<x> is a square matrix.
+
+S< >S< >-- an X<idele>I<idele>, i.e.S< >a 2-component vector, the first being an
+ideal given as a B<Z>--basis, the second being a C<r_1+r_2>-component row
+vector giving the complex logarithmic Archimedean information.
+
+S< >S< >-- a B<Z>C<_K>-generating system for an ideal.
+
+S< >S< >-- a I<column> vector C<x> expressing an element of the number field
+on the integral basis, in which case the ideal is treated as being the
+principal idele (or ideal) generated by C<x>.
+
+S< >S< >-- a prime ideal, i.e.S< >a 5-component vector in the format output by
+C<idealprimedec>.
+
+S< >S< >-- a polmod C<x>, i.e.S< >an algebraic integer, in which case the ideal
+is treated as being the principal idele generated by C<x>.
+
+S< >S< >-- an integer or a rational number, also treated as a principal idele.
+
+B<*> a I<{character>} on the Abelian group
+C<\bigoplus (>B<Z>C</N_i>B<Z>C<) g_i>
+is given by a row vector F<chi>C< = [a_1,...,a_n]> such that
+F<chi>C<(>F<prod>C< g_i^{n_i}) = exp(2i>F<Pi>F<sum>C< a_i n_i / N_i)>.
+
+B<Warnings:>
+
+1) An element in I<nf> can be expressed either as a polmod or as a
+vector of components on the integral basis I<nf>C<.zk>. It is absolutely
+essential that all such vectors be I<column> vectors.
+
+2) When giving an ideal by a B<Z>C<_K> generating system to a function expecting
+an ideal, it must be ensured that the function understands that it is a
+B<Z>C<_K>-generating system and not a B<Z>-generating system. When the number of
+generators is strictly less than the degree of the field, there is no
+ambiguity and the program assumes that one is giving a B<Z>C<_K>-generating set.
+When the number of generators is greater than or equal to the degree of the
+field, however, the program assumes on the contrary that you are giving a
+B<Z>-generating set. If this is not the case, you I<must> absolutely
+change it into a B<Z>-generating set, the simplest manner being to use
+C<idealhnf(>I<nf>C<,x)>.
+
+Concerning relative extensions, some additional definitions are necessary.
+
+B<*> A I<{relative matrix>} will be a matrix whose entries are
+elements of a (given) number field I<nf>, always expressed as column
+vectors on the integral basis I<nf>C<.zk>. Hence it is a matrix of
+vectors.
+
+B<*> An X<ideal list>I<ideal list> will be a row vector of (fractional)
+ideals of the number field I<nf>.
+
+B<*> A X<pseudo-matrix>I<pseudo-matrix> will be a pair C<(A,I)> where C<A> is a
+relative matrix and C<I> an ideal list whose length is the same as the number
+of columns of C<A>. This pair will be represented by a 2-component row vector.
+
+B<*> The X<module>I<module> generated by a pseudo-matrix C<(A,I)> is
+the sum F<sum>C<_i{>B<a>C<}_jA_j> where the C<{>B<a>C<}_j> are the ideals of C<I>
+and C<A_j> is the C<j>-th column of C<A>.
+
+B<*> A pseudo-matrix C<(A,I)> is a X<pseudo-basis>I<pseudo-basis> of the module
+it generates if C<A> is a square matrix with non-zero determinant and all the
+ideals of C<I> are non-zero. We say that it is in Hermite Normal
+FormX<Hermite normal form> (HNF) if it is upper triangular and all the
+elements of the diagonal are equal to 1.
+
+B<*> The I<determinant> of a pseudo-basis C<(A,I)> is the ideal
+equal to the product of the determinant of C<A> by all the ideals of C<I>. The
+determinant of a pseudo-matrix is the determinant of any pseudo-basis of the
+module it generates.
+
+Finally, when defining a relative extension, the base field should be
+defined by a variable having a lower priority (i.e.S< >a higher number)
+than the variable defining the extension. For example, under GP you can
+use the variable name C<y> (or C<t>) to define the base field, and the
+variable name C<x> to define the relative extension.
+
+Now a last set of definitions concerning the way big ray number fields
+(or I<bnr>) are input, using class field theory.
+These are defined by a triple
+C<a1>, C<a2>, C<a3>, where the defining set C<[a1,a2,a3]> can have any of the
+following forms: C<[>I<bnr>C<]>, C<[>I<bnr>C<,>I<subgroup>C<]>,
+C<[>I<bnf>C<,>I<module>C<]>, C<[>I<bnf>C<,>I<module>C<,>I<subgroup>C<]>, where:
+
+B<*> I<bnf> is as output by C<bnfclassunit> or C<bnfinit>,
+where units are mandatory unless the ideal is trivial; I<bnr> by
+C<bnrclass> (with I<flag>C< E<gt> 0>) or C<bnrinit>. This is the ground field.
+
+B<*> I<module> is either an ideal in any form (see above) or a
+two-component row vector containing an ideal and an C<r_1>-component row
+vector of flags indicating which real Archimedean embeddings to take in the
+module.
+
+B<*> I<subgroup> is the HNF matrix of a subgroup of the ray class group
+of the ground field for the modulus I<module>. This is input as a square
+matrix expressing generators of a subgroup of the ray class group
+I<bnr>C<.clgp> on the given generators.
+
+The corresponding I<bnr> is then the subfield of the ray class field of the
+ground field for the given modulus, associated to the given subgroup.
+
+All the functions which are specific to relative extensions, number fields,
+big number fields, big number rays, share the prefix C<rnf>, C<nf>,
+C<bnf>, C<bnr> respectively. They are meant to take as first argument a
+number field of that precise type, respectively output by C<rnfinit>,
+C<nfinit>, C<bnfinit>, and C<bnrinit>.
+
+However, and even though it may not be specified in the descriptions of the
+functions below, it is permissible, if the function expects a I<nf>, to
+use a I<bnf> instead (which contains much more information). The program
+will make the effort of converting to what it needs. On the other hand, if
+the program requires a big number field, the program will I<not> launch
+C<bnfinit> for you, which can be a costly operation. Instead, it will give
+you a specific error message.
+
+The data types corresponding to the structures described above are rather
+complicated. Thus, as we already have seen it with elliptic curves, GP
+provides you with some ``member functions'' to retrieve the data you need
+from these structures (once they have been initialized of course). The
+relevant types of number fields are indicated between parentheses:
+
+X<member functions>
+S< >X<bnf>C<bnf> (I<bnr>, I<bnf> ) : big number field.
+
+S< >X<clgp>C<clgp> (I<bnr>, I<bnf> ) : classgroup. This one admits the
+following three subclasses:
+
+S< > X<cyc>C<cyc> : cyclic decomposition
+(SNF)X<Smith normal form>.
+
+S< > C<gen>X<gen (member function)> :
+generators.
+
+S< > X<no>C<no> : number of elements.
+
+S< >X<diff>C<diff> (I<bnr>, I<bnf>, I<nf> ) : the different ideal.
+
+S< >X<codiff>C<codiff> (I<bnr>, I<bnf>, I<nf> ) : the codifferent
+(inverse of the different in the ideal group).
+
+S< >X<disc>C<disc> (I<bnr>, I<bnf>, I<nf> ) : discriminant.
+
+S< >X<fu>C<fu> (I<bnr>, I<bnf>, I<nf> ) :
+X<fundamental units>fundamental units.
+
+S< >X<futu>C<futu> (I<bnr>, I<bnf> ) : C<[u,w]>, C<u> is a vector of
+fundamental units, C<w> generates the torsion.
+
+S< >X<nf>C<nf> (I<bnr>, I<bnf>, I<nf> ) : number field.
+
+S< >X<reg>C<reg> (I<bnr>, I<bnf>, ) : regulator.
+
+S< >X<roots>C<roots> (I<bnr>, I<bnf>, I<nf> ) : roots of the
+polnomial generating the field.
+
+S< >X<sign>C<sign> (I<bnr>, I<bnf>, I<nf> ) : C<[r_1,r_2]> the
+signature of the field. This means that the field has C<r_1> real
+S< > embeddings, C<2r_2> complex ones.
+
+S< >X<t2>C<t2> (I<bnr>, I<bnf>, I<nf> ) : the T2 matrix (see
+C<nfinit>).
+
+S< >X<tu>C<tu> (I<bnr>, I<bnf>, ) : a generator for the torsion
+units.
+
+S< >X<tufu>C<tufu> (I<bnr>, I<bnf>, ) : as C<futu>, but outputs
+C<[w,u]>.
+
+S< >X<zk>C<zk> (I<bnr>, I<bnf>, I<nf> ) : integral basis, i.e.S< >a
+B<Z>-basis of the maximal order.
+
+S< >X<zkst>C<zkst> (I<bnr> ) : structure of C<(>B<Z>C<_K/m)^*> (can be
+extracted also from an I<idealstar>).
+
+For instance, assume that I<bnf>C< = bnfinit(>I<pol>C<)>, for some
+polynomial. Then I<bnf>C<.clgp> retrieves the class group, and
+I<bnf>C<.clgp.no> the class number. If we had set I<bnf>C< =
+nfinit(>I<pol>C<)>, both would have output an error message. All these
+functions are completely recursive, thus for instance
+I<bnr>C<.bnf.nf.zk> will yield the maximal order of I<bnr> (which
+you could get directly with a simple I<bnr>C<.zk> of course).
+
+The following functions, starting with C<buch> in library mode, and with
+C<bnf> under GP, are implementations of the sub-exponential algorithms for
+finding class and unit groups under X<GRH>GRH, due to Hafner-McCurley,
+X<Buchmann>Buchmann and Cohen-Diaz-Olivier.
+
+The general call to the functions concerning class groups of general number
+fields (i.e.S< >excluding C<quadclassunit>) involves a polynomial C<P> and a
+technical vector
+
+S< >I<tech>C< = [c,c2,>I<nrel>C<,>I<borne>C<,>I<nrpid>C<,>I<minsfb>C<],>
+
+where the parameters are to be understood as follows:
+
+C<P> is the defining polynomial for the number field, which must be in
+B<Z>C<[X]>, irreducible and, preferably, monic. In fact, if you supply a
+non-monic polynomial at this point, GP will issue a warning, then
+I<transform your polynomial> so that it becomes monic. Instead of the
+normal result, say C<res>, you then get a vector C<[res,Mod(a,Q)]>,
+where C<Mod(a,Q) = Mod(X,P)> gives the change of variables.
+
+The numbers C<c> and C<c2> are positive real numbers which control the
+execution time and the stack size. To get maximum speed, set C<c2 = c>. To get a
+rigorous result (under X<GRH>GRH) you must take C<c2 = 12> (or C<c2 = 6> in the
+quadratic case, but then you should use the much faster function
+C<quadclassunit>). Reasonable values for C<c> are between C<0.1> and
+C<2>. (The defaults are C<c = c2 = 0.3>).
+
+I<nrel> is the number of initial extra relations requested in
+computing the
+relation matrix. Reasonable values are between 5 and 20. (The default is 5).
+
+I<borne> is a multiplicative coefficient of the Minkowski bound which
+controls
+the search for small norm relations. If this parameter is set equal to 0, the
+program does not search for small norm relations. Otherwise reasonable values
+are between C<0.5> and C<2.0>. (The default is C<1.0>).
+
+I<nrpid> is the maximal number of small norm relations associated to each
+ideal in the factor base. Irrelevant when I<borne>C< = 0>. Otherwise,
+reasonable values are between 4 and 20. (The default is 4).
+
+I<minsfb> is the minimal number of elements in the ``sub-factorbase''.
+If the
+program does not seem to succeed in finding a full rank matrix (which you can
+see in GP by typing C<\g 2>), increase this number. Reasonable values
+are between 2 and 5. (The default is 3).
+
+B<Remarks.>
+
+Apart from the polynomial C<P>, you don't need to supply any of the technical
+parameters (under the library you still need to send at least an empty
+vector, C<cgetg(1,t_VEC)>). However, should you choose to set some of
+them, they I<must> be given in the requested order. For example, if you
+want to specify a given value of C<nrel>, you must give some values as well
+for C<c> and C<c2>, and provide a vector C<[c,c2,nrel]>.
+
+Note also that you can use an I<nf> instead of C<P>, which avoids
+recomputing the integral basis and analogous quantities.
+
+=head2 X<bnfcertify>bnfcertifyC<(>I<bnf>C<)>
+
+I<bnf> being a big number field
+as output by C<bnfinit> or C<bnfclassunit>, checks whether the result
+is correct, i.e.S< >whether it is possible to remove the assumption of the
+Generalized Riemann HypothesisX<GRH>. If it is correct, the answer is 1.
+If not, the program may output some error message, but more probably will loop
+indefinitely. In I<no> occasion can the program give a wrong answer
+(barring bugs of course): if the program answers 1, the answer is certified.
+
+X<certifybuchall>The library syntax is B<certifybuchall>C<(>I<bnf>C<)>, and the result is a C long.
+
+=head2 X<bnfclassunit>bnfclassunitC<(P,{>I<flag>C< = 0},{>I<tech>C< = []})>
+
+X<Buchmann>Buchmann's
+sub-exponential algorithm for computing the class group, the regulator and a
+system of X<fundamental units>fundamental units of the general algebraic number field C<K>
+defined by the irreducible polynomial C<P> with integer coefficients.
+
+The result of this function is a vector C<v> with 10 components (it is
+I<not> a I<bnf>, you need C<bnfinit> for that), which for ease of
+presentation is in fact output as a one column matrix. First we describe the
+default behaviour (I<flag>C< = 0>):
+
+C<v[1]> is equal to the polynomial C<P>. Note that for optimum performance,
+C<P> should have gone through C<polred> or C<nfinit(x,2)>.
+
+C<v[2]> is the 2-component vector C<[r1,r2]>, where C<r1> and C<r2> are as usual
+the number of real and half the number of complex embeddings of the number
+field C<K>.
+
+C<v[3]> is the 2-component vector containing the field discriminant and the
+index.
+
+C<v[4]> is an integral basis in Hermite normal form.
+
+C<v[5]> (C<v.clgp>) is a 3-component vector containing the class number
+(C<v.clgp.no>), the structure of the class group as a product of cyclic
+groups of order C<n_i> (C<v.clgp.cyc>), and the corresponding generators
+of the class group of respective orders C<n_i> (C<v.clgp.gen>).
+
+C<v[6]> (C<v.reg>) is the regulator computed to an accuracy which is the
+maximum of an internally determined accuracy and of the default.
+
+C<v[7]> is a measure of the correctness of the result. If it is close to 1,
+the results are correct (under X<GRH>GRH). If it is close to a larger integer,
+this shows that the product of the class number by the regulator is off by a
+factor equal to this integer, and you must start again with a larger value
+for C<c> or a different random seed, i.e.S< >use the function C<setrand>.
+(Since the computation involves a random process, starting again with exactly
+the same parameters may give the correct result.) In this case a warning
+message is printed.
+
+C<v[8]> (C<v.tu>) a vector with 2 components, the first being the number
+C<w> of roots of unity in C<K> and the second a primitive C<w>-th root of unity
+expressed as a polynomial.
+
+C<v[9]> (C<v.fu>) is a system of fundamental units also expressed as
+polynomials.
+
+C<v[10]> gives a measure of the correctness of the computations of the
+fundamental units (not of the regulator), expressed as a number of bits. If
+this number is greater than C<20>, say, everything is OK. If C<v[10] E<lt>= 0>,
+then we have lost all accuracy in computing the units (usually an error
+message will be printed and the units not given). In the intermediate cases,
+one must proceed with caution (for example by increasing the current
+precision).
+
+If I<flag>C< = 1>, and the precision happens to be insufficient for obtaining the
+fundamental units exactly, the internal precision is doubled and the
+computation redone, until the exact results are obtained. The user should be
+warned that this can take a very long time when the coefficients of the
+fundamental units on the integral basis are very large, for example in the
+case of large real quadratic fields. In that case, there are alternate
+methods for representing algebraic numbers which are not implemented in PARI.
+
+If I<flag>C< = 2>, the fundamental units and roots of unity are not computed.
+Hence the result has only 7 components, the first seven ones.
+
+I<tech> is a technical vector (empty by default) containing C<c>, C<c2>,
+I<nrel>, I<borne>, I<nbpid>, I<minsfb>, in this order (see
+the beginning of the section or the keyword C<bnf>).
+You can supply any number of these I<provided you give an actual value to
+each of them> (the ``empty arg'' trick won't work here). Careful use of these
+parameters may speed up your computations considerably.
+
+X<bnfclassunit0>The library syntax is B<bnfclassunit0>C<(P,>I<flag>C<,>I<tech>C<,>I<prec>C<)>.
+
+=head2 X<bnfclgp>bnfclgpC<(P,{>I<tech>C< = []})>
+
+as C<bnfclassunit>, but only
+outputs C<v[5]>, i.e.S< >the class group.
+
+X<bnfclassgrouponly>The library syntax is B<bnfclassgrouponly>C<(P,>I<tech>C<,>I<prec>C<)>, where I<tech>
+is as described under C<bnfclassunit>.
+
+=head2 X<bnfdecodemodule>bnfdecodemoduleC<(>I<nf>C<,m)>
+
+if C<m> is a module as output in the
+first component of an extension given by C<bnrdisclist>, outputs the
+true module.
+
+X<decodemodule>The library syntax is B<decodemodule>C<(>I<nf>C<,m)>.
+
+=head2 X<bnfinit>bnfinitC<(P,{>I<flag>C< = 0},{>I<tech>C< = []})>
+
+essentially identical
+to C<bnfclassunit> except that the output contains a lot of technical data,
+and should not be printed out explicitly in general. The result of
+C<bnfinit> is used in programs such as C<bnfisprincipal>,
+C<bnfisunit> or C<bnfnarrow>. The result is a 10-component vector
+I<bnf>.
+
+B<*> The first 6 and last 2 components are technical and in
+principle are not used by the casual user. However, for the sake of
+completeness, their description is as follows. We use the notations explained
+in the book by H. Cohen, I<A Course in Computational Algebraic Number
+Theory>, Graduate Texts in Maths B<138>, Springer-Verlag, 1993, Section
+6.5, and subsection 6.5.5 in particular.
+
+I<bnf>C<[1]> contains the matrix C<W>, i.e.S< >the matrix in Hermite normal
+form giving relations for the class group on prime ideal generators
+C<(>B<p>C<_i)_{1 E<lt>= i E<lt>= r}>.
+
+I<bnf>C<[2]> contains the matrix C<B>, i.e.S< >the matrix containing the
+expressions of the prime ideal factorbase in terms of the B<p>C<_i>. It is an
+C<r x c> matrix.
+
+I<bnf>C<[3]> contains the complex logarithmic embeddings of the system of
+fundamental units which has been found. It is an C<(r_1+r_2) x (r_1+r_2-1)>
+matrix.
+
+I<bnf>C<[4]> contains the matrix C<M''_C> of Archimedean components of the
+relations of the matrix C<(W|B)>.
+
+I<bnf>C<[5]> contains the prime factor base, i.e.S< >the list of prime
+ideals used in finding the relations.
+
+I<bnf>C<[6]> contains the permutation of the prime factor base which was
+necessary to reduce the relation matrix to the form explained in subsection
+6.5.5 of GTMS< >138 (i.e.S< >with a big C<c x c> identity matrix on the lower
+right). Note that in the above mentioned book, the need to permute the rows
+of the relation matrices which occur was not emphasized.
+
+I<bnf>C<[9]> is a 3-element row vector used in X<bnfisprincipal>C<bnfisprincipal> only
+and obtained as follows. Let C<D = U W V> obtained by applying the
+X<Smith normal form>Smith normal form algorithm to the matrix C<W> ( = I<bnf>C<[1]>) and
+let C<U_r> be the reduction of C<U> modulo C<D>. The first elements of the
+factorbase are given (in terms of C<bnf.gen>) by the columns of C<U_r>,
+with archimedian component C<g_a>; let also C<GD_a> be the archimedian
+components of the generators of the (principal) ideals defined by the
+C<bnf.gen[i]^bnf.cyc[i]>. Then I<bnf>C<[9] = [U_r, g_a, GD_a]>.
+
+Finally, I<bnf>C<[10]> is by default unused and set equal to 0. This
+field is used to store further information about the field as it becomes
+available (which is rarely needed, hence would be too expensive to compute
+during the initial C<bnfinit> call). For instance, the generators of the
+principal ideals C<bnf.gen[i]^bnf.cyc[i]> (during a call to
+X<bnrisprincipal>C<bnrisprincipal>), or those corresponding to the relations in C<W> and
+C<B> (when the C<bnf> internal precision needs to be increased).
+
+B<*> The less technical components are as follows:
+
+I<bnf>C<[7]> or I<bnf>C<.nf> is equal to the number field data
+I<nf> as would be given by C<nfinit>.
+
+I<bnf>C<[8]> is a vector containing the last 6 components of
+C<bnfclassunit[,1]>, i.e.S< >the classgroup I<bnf>C<.clgp>, the
+regulator I<bnf>C<.reg>, the general ``check'' number which should be
+close to 1, the number of roots of unity and a generator I<bnf>C<.tu>,
+the fundamental units I<bnf>C<.fu>, and finally the check on their
+computation. If the precision becomes insufficient, GP outputs a warning
+(C<fundamental units too large, not given>) and does not strive to
+compute the units by default (I<flag>C< = 0>).
+
+When I<flag>C< = 1>, GP insists on finding the fundamental units exactly, the
+internal precision being doubled and the computation redone, until the exact
+results are obtained. The user should be warned that this can take a very
+long time when the coefficients of the fundamental units on the integral
+basis are very large.
+
+When I<flag>C< = 2>, on the contrary, it is initially agreed that GP
+will not compute units.
+
+When I<flag>C< = 3>, computes a very small version of C<bnfinit>, a ``small big
+number field'' (or I<sbnf> for short) which contains enough information
+to recover the full I<bnf> vector very rapidly, but which is much
+smaller and hence easy to store and print. It is supposed to be used in
+conjunction with C<bnfmake>. The output is a 12 component vector C<v>, as
+follows. Let I<bnf> be the result of a full C<bnfinit>, complete with
+units. Then C<v[1]> is the polynomial C<P>, C<v[2]> is the number of real
+embeddings C<r_1>, C<v[3]> is the field discriminant, C<v[4]> is the integral
+basis, C<v[5]> is the list of roots as in the sixth component of C<nfinit>,
+C<v[6]> is the matrix C<MD> of C<nfinit> giving a B<Z>-basis of the
+different, C<v[7]> is the matrix C<W = >I<bnf>C<[1]>, C<v[8]> is the
+matrix C<matalpha = >I<bnf>C<[2]>, C<v[9]> is the prime ideal factor base
+I<bnf>C<[5]> coded in a compact way, and ordered according to the
+permutation I<bnf>C<[6]>, C<v[10]> is the 2-component vector giving the
+number of roots of unity and a generator, expressed on the integral basis,
+C<v[11]> is the list of fundamental units, expressed on the integral basis,
+C<v[12]> is a vector containing the algebraic numbers alpha corresponding to
+the columns of the matrix C<matalpha>, expressed on the integral basis.
+
+Note that all the components are exact (integral or rational), except for
+the roots in C<v[5]>. In practice, this is the only component which a user
+is allowed to modify, by recomputing the roots to a higher accuracy if
+desired. Note also that the member functions will I<not> work on
+I<sbnf>, you have to use C<bnfmake> explicitly first.
+
+X<bnfinit0>The library syntax is B<bnfinit0>C<(P,>I<flag>C<,>I<tech>C<,>I<prec>C<)>.
+
+=head2 X<bnfisintnorm>bnfisintnormC<(>I<bnf>C<,x)>
+
+computes a complete system of
+solutions (modulo units of positive norm) of the absolute norm equation
+C<Norm(a) = x>,
+where C<a> is an integer in I<bnf>. If I<bnf> has not been certified,
+the correctness of the result depends on the validity of X<GRH>GRH.
+
+X<bnfisintnorm>The library syntax is B<bnfisintnorm>C<(>I<bnf>C<,x)>.
+
+=head2 X<bnfisnorm>bnfisnormC<(>I<bnf>C<,x,{>I<flag>C< = 1})>
+
+tries to tell whether the
+rational number C<x> is the norm of some element y in I<bnf>. Returns a
+vector C<[a,b]> where C<x = Norm(a)*b>. Looks for a solution which is an C<S>-unit,
+with C<S> a certain set of prime ideals containing (among others) all primes
+dividing C<x>. If I<bnf> is known to be X<Galois>Galois, set I<flag>C< = 0> (in
+this case,
+C<x> is a norm iff C<b = 1>). If I<flag> is non zero the program adds to C<S> the
+following prime ideals, depending on the sign of I<flag>. If I<flag>C< E<gt> 0>, the
+ideals of norm less than I<flag>. And if I<flag>C< E<lt> 0> the ideals dividing I<flag>.
+
+If you are willing to assume X<GRH>GRH, the answer is guaranteed
+(i.e.S< >C<x> is a norm iff C<b = 1>), if C<S> contains all primes less than
+C<12> F<log> C<(>I<disc>C<(>I<Bnf>C<))^2>,
+where I<Bnf> is the Galois closure of I<bnf>.
+
+X<bnfisnorm>The library syntax is B<bnfisnorm>C<(>I<bnf>C<,x,>I<flag>C<,>I<prec>C<)>, where I<flag> and
+I<prec> are C<long>s.
+
+=head2 X<bnfissunit>bnfissunitC<(>I<bnf>C<,>I<sfu>C<,x)>
+
+I<bnf> being output by
+C<bnfinit>, I<sfu> by C<bnfsunit>, gives the column vector of
+exponents of C<x> on the fundamental C<S>-units and the roots of unity.
+If C<x> is not a unit, outputs an empty vector.
+
+X<bnfissunit>The library syntax is B<bnfissunit>C<(>I<bnf>C<,>I<sfu>C<,x)>.
+
+=head2 X<bnfisprincipal>bnfisprincipalC<(>I<bnf>C<,x,{>I<flag>C< = 1})>
+
+I<bnf> being the
+number field data output by C<bnfinit>, and C<x> being either a B<Z>-basis
+of an ideal in the number field (not necessarily in HNF) or a prime ideal in
+the format output by the function C<idealprimedec>, this function tests
+whether the ideal is principal or not. The result is more complete than a
+simple true/false answer: it gives a row vector C<[v_1,v_2,check]>, where
+
+C<v_1> is the vector of components C<c_i> of the class of the ideal C<x> in the
+class group, expressed on the generators C<g_i> given by C<bnfinit>
+(specifically I<bnf>C<.clgp.gen> which is the same as
+I<bnf>C<[8][1][3]>). The C<c_i> are chosen so that C<0 E<lt>= c_i E<lt> n_i>
+where C<n_i> is the order of C<g_i> (the vector of C<n_i> being
+I<bnf>C<.clgp.cyc>, that is I<bnf>C<[8][1][2]>).
+
+C<v_2> gives on the integral basis the components of F<alpha> such that
+C<x = >F<alpha>F<prod>C<_ig_i^{c_i}>. In particular, C<x> is principal if and only if
+C<v_1> is equal to the zero vector, and if this the case C<x = >F<alpha>B<Z>C<_K> where
+F<alpha> is given by C<v_2>. Note that if F<alpha> is too large to be given, a
+warning message will be printed and C<v_2> will be set equal to the empty
+vector.
+
+Finally the third component I<check> is analogous to the last component of
+C<bnfclassunit>: it gives a check on the accuracy of the result, in bits.
+I<check> should be at least C<10>, and preferably much more. In any case, the
+result is checked for correctness.
+
+If I<flag>C< = 0>, outputs only C<v_1>, which is much easier to compute.
+
+If I<flag>C< = 2>, does as if I<flag> were C<0>, but doubles the precision until a
+result is obtained.
+
+If I<flag>C< = 3>, as in the default behaviour (I<flag>C< = 1>), but doubles the precision
+until a result is obtained.
+
+The user is warned that these two last setting may induce I<very> lengthy
+computations.
+
+X<isprincipalall>The library syntax is B<isprincipalall>C<(>I<bnf>C<,x,>I<flag>C<)>.
+
+=head2 X<bnfisunit>bnfisunitC<(>I<bnf>C<,x)>
+
+I<bnf> being the number field data
+output by
+C<bnfinit> and C<x> being an algebraic number (type integer, rational or
+polmod), this outputs the decomposition of C<x> on the fundamental units and
+the roots of unity if C<x> is a unit, the empty vector otherwise. More
+precisely, if C<u_1>,...,C<u_r> are the fundamental units, and F<zeta> is
+the generator of the group of roots of unity (found by C<bnfclassunit> or
+C<bnfinit>), the output is a vector C<[x_1,...,x_r,x_{r+1}]> such that
+C<x = u_1^{x_1}...u_r^{x_r}.>F<zeta>C<^{x_{r+1}}>. The C<x_i> are integers for
+C<i E<lt>= r> and is an integer modulo the order of F<zeta> for C<i = r+1>.
+
+X<isunit>The library syntax is B<isunit>C<(>I<bnf>C<,x)>.
+
+=head2 X<bnfmake>bnfmakeC<(>I<sbnf>C<)>
+
+I<sbnf> being a ``small I<bnf>''
+as output by C<bnfinit>C<(x,3)>, computes the complete C<bnfinit>
+information. The result is I<not> identical to what C<bnfinit> would
+yield, but is functionally identical. The execution time is very small
+compared to a complete C<bnfinit>. Note that if the default precision in
+GP (or I<prec> in library mode) is greater than the precision of the
+roots I<sbnf>C<[5]>, these are recomputed so as to get a result with
+greater accuracy.
+
+Note that the member functions are I<not> available for I<sbnf>, you
+have to use C<bnfmake> explicitly first.
+
+X<makebigbnf>The library syntax is B<makebigbnf>C<(>I<sbnf>C<,>I<prec>C<)>, where I<prec> is a
+C long integer.
+
+=head2 X<bnfnarrow>bnfnarrowC<(>I<bnf>C<)>
+
+I<bnf> being a big number field as
+output by C<bnfinit>, computes the narrow class group of I<bnf>. The
+output is a 3-component row vector C<v> analogous to the corresponding
+class group component I<bnf>C<.clgp> (I<bnf>C<[8][1]>): the
+first component is the narrow class number C<v.no>, the second component
+is a vector containing the SNFX<Smith normal form> cyclic components
+C<v.cyc> of the narrow
+class group, and the third is a vector giving the generators of the
+corresponding C<v.gen> cyclic groups. Note that this function is a
+special case of C<bnrclass>.
+
+X<buchnarrow>The library syntax is B<buchnarrow>C<(>I<bnf>C<)>.
+
+=head2 X<bnfsignunit>bnfsignunitC<(>I<bnf>C<)>
+
+I<bnf> being a big number field
+output by C<bnfinit>, this computes an C<r_1 x (r_1+r_2-1)> matrix
+having C<F<+->1> components, giving the signs of the real embeddings of the
+fundamental units.
+
+X<signunits>The library syntax is B<signunits>C<(>I<bnf>C<)>.
+
+=head2 X<bnfreg>bnfregC<(>I<bnf>C<)>
+
+I<bnf> being a big number field
+output by C<bnfinit>, computes its regulator.
+
+X<regulator>The library syntax is B<regulator>C<(>I<bnf>C<,>I<tech>C<,>I<prec>C<)>, where I<tech> is as in
+C<bnfclassunit>.
+
+=head2 X<bnfsunit>bnfsunitC<(>I<bnf>C<,S)>
+
+computes the fundamental C<S>-units of the
+number field I<bnf> (output by C<bnfinit>), where C<S> is a list of
+prime ideals (output by C<idealprimedec>). The output is a vector C<v> with
+6 components.
+
+C<v[1]> gives a minimal system of (integral) generators of the C<S>-unit group
+modulo the unit group.
+
+C<v[2]> contains technical data needed by C<bnfissunit>.
+
+C<v[3]> is an empty vector (used to give the logarithmic embeddings of the
+generators in C<v[1]> in version 2.0.16).
+
+C<v[4]> is the C<S>-regulator (this is the product of the regulator, the
+determinant of C<v[2]> and the natural logarithms of the norms of the ideals
+in C<S>).
+
+C<v[5]> gives the C<S>-class group structure, in the usual format
+(a row vector whose three components give in order the C<S>-class number,
+the cyclic components and the generators).
+
+C<v[6]> is a copy of C<S>.
+
+X<bnfsunit>The library syntax is B<bnfsunit>C<(>I<bnf>C<,S,>I<prec>C<)>.
+
+=head2 X<bnfunit>bnfunitC<(>I<bnf>C<)>
+
+I<bnf> being a big number field as
+output by
+C<bnfinit>, outputs a two-component row vector giving in the first
+component the vector of fundamental units of the number field, and in the
+second component the number of bit of accuracy which remained in the
+computation (which is always correct, otherwise an error message is printed).
+This function is mainly for people who used the wrong flag in C<bnfinit>
+and would like to skip part of a lengthy C<bnfinit> computation.
+
+X<buchfu>The library syntax is B<buchfu>C<(>I<bnf>C<)>.
+
+=head2 X<bnrL1>bnrL1C<(>I<bnr>C<,>I<subgroup>C<,{>I<flag>C< = 0})>
+
+I<bnr> being the number field data which is output by
+C<bnrinit(,,1)> and I<subgroup> being a square matrix defining a
+congruence subgroup of the ray class group corresponding to I<bnr>
+(or C<0> for the trivial congruence subgroup), returns for each
+X<character>character F<chi> of the ray class group which is trivial on this
+subgroup, the value at C<s = 1> (or C<s = 0>) of the abelian
+C<L>-function associated to F<chi>. For the value at C<s = 0>, the
+function returns in fact for each character F<chi> a vector C<[r_>F<chi>C< ,
+c_>F<chi>C<]> where C<r_>F<chi> is the order of C<L(s, >F<chi>C<)> at C<s = 0> and
+C<c_>F<chi> the first non-zero term in the expansion of C<L(s,
+>F<chi>C<)> at C<s = 0>; in other words
+
+S< >C<L(s, >F<chi>C<) = c_>F<chi>C<.s^{r_>F<chi>C<} + O(s^{r_>F<chi>C< + 1})>
+
+near C<0>. I<flag> is optional, default value is 0; its binary digits
+mean 1: compute at C<s = 1> if set to 1 or C<s = 0> if set to 0, 2: compute
+the primitive C<L>-functions associated to F<chi> if set to 0 or the
+C<L>-function with Euler factors at prime ideals dividing the modulus of
+I<bnr> removed if set to 1 (this is the so-called C<L_S(s, >F<chi>C<)>
+function where C<S> is the set of infinite places of the number field
+together with the finite prime ideals dividing the modulus of I<bnr>,
+see the example below), 3: returns also the character.
+
+Example:
+
+ bnf = bnfinit(x^2 - 229);
+ bnr = bnrinit(bnf,1,1);
+ bnrL1(bnr, 0)
+
+returns the order and the first non-zero term of the abelian
+C<L>-functions C<L(s, >F<chi>C<)> at C<s = 0> where F<chi> runs through the
+characters of the class group of B<Q>C<(> F<sqrt> C<{229})>. Then
+
+ bnr2 = bnrinit(bnf,2,1);
+ bnrL1(bnr2,0,2)
+
+returns the order and the first non-zero terms of the abelian
+C<L>-functions C<L_S(s, >F<chi>C<)> at C<s = 0> where F<chi> runs through the
+characters of the class group of B<Q>C<(> F<sqrt> C<{229})> and C<S> is the set
+of infinite places of B<Q>C<(> F<sqrt> C<{229})> together with the finite prime
+C<2> (note that the ray class group modulo C<2> is in fact the class
+group, so C<bnrL1(bnr2,0)> returns exactly the same answer as
+C<bnrL1(bnr,0)>!).
+
+X<bnrL1>The library syntax is B<bnrL1>C<(>I<bnr>C<,>I<subgroup>C<,>I<flag>C<,>I<prec>C<)>
+
+=head2 X<bnrclass>bnrclassC<(>I<bnf>C<,>I<ideal>C<,{>I<flag>C< = 0})>
+
+I<bnf> being a big number field
+as output by C<bnfinit> (the units are mandatory unless the ideal is
+trivial), and I<ideal> being either an ideal in any form or a two-component
+row vector containing an ideal and an C<r_1>-component row vector of flags
+indicating which real Archimedean embeddings to take in the module, computes
+the ray class group of the number field for the module I<ideal>, as a
+3-component vector as all other finite Abelian groups (cardinality, vector of
+cyclic components, corresponding generators).
+
+If I<flag>C< = 2>, the output is different. It is a 6-component vector C<w>. C<w[1]>
+is I<bnf>. C<w[2]> is the result of applying
+C<idealstar(>I<bnf>C<,I,2)>. C<w[3]>, C<w[4]> and C<w[6]> are technical
+components used only by the function C<bnrisprincipal>. C<w[5]> is the
+structure of the ray class group as would have been output with I<flag>C< = 0>.
+
+If I<flag>C< = 1>, as above, except that the generators of the ray class group are
+not computed, which saves time.
+
+X<bnrclass0>The library syntax is B<bnrclass0>C<(>I<bnf>C<,>I<ideal>C<,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<bnrclassno>bnrclassnoC<(>I<bnf>C<,I)>
+
+I<bnf> being a big number field
+as output
+by C<bnfinit> (units are mandatory unless the ideal is trivial), and C<I>
+being either an ideal in any form or a two-component row vector containing an
+ideal and an C<r_1>-component row vector of flags indicating which real
+Archimedean embeddings to take in the modulus, computes the ray class number
+of the number field for the modulus C<I>. This is faster than C<bnrclass>
+and should be used if only the ray class number is desired.
+
+X<rayclassno>The library syntax is B<rayclassno>C<(>I<bnf>C<,I)>.
+
+=head2 X<bnrclassnolist>bnrclassnolistC<(>I<bnf>C<,>I<list>C<)>
+
+I<bnf> being a
+big number field as output by C<bnfinit> (units are mandatory unless
+the ideal is trivial), and I<list> being a list of modules as output
+by C<ideallist> of C<ideallistarch>,
+outputs the list of the class numbers of the corresponding ray class groups.
+
+X<rayclassnolist>The library syntax is B<rayclassnolist>C<(>I<bnf>C<,>I<list>C<)>.
+
+=head2 X<bnrconductor>bnrconductorC<(a_1,{a_2},{a_3}, {>I<flag>C< = 0})>
+
+conductor of the
+subfield of a ray class field as defined by C<[a_1,a_2,a_3]> (see C<bnr>
+at the beginning of this section).
+
+X<bnrconductor>The library syntax is B<bnrconductor>C<(a_1,a_2,a_3,>I<flag>C<,>I<prec>C<)>, where an omitted argument
+among the C<a_i> is input as C<gzero>, and I<flag> is a C long.
+
+=head2 X<bnrconductorofchar>bnrconductorofcharC<(>I<bnr>C<,>I<chi>C<)>
+
+I<bnr> being a
+big ray number field
+as output by C<bnrclass>, and I<chi> being a row vector representing a
+X<character>character as expressed on the generators of the ray class group, gives
+the conductor of this character as a modulus.
+
+X<bnrconductorofchar>The library syntax is B<bnrconductorofchar>C<(>I<bnr>C<,>I<chi>C<,>I<prec>C<)> where I<prec>
+is a C<long>.
+
+=head2 X<bnrdisc>bnrdiscC<(a1,{a2},{a3},{>I<flag>C< = 0})>
+
+C<a1>, C<a2>, C<a3>
+defining a big ray number field C<L> over a groud field C<K> (see C<bnr>
+at the beginning of this section for the
+meaning of C<a1>, C<a2>, C<a3>), outputs a 3-component row vector C<[N,R_1,D]>,
+where C<N> is the (absolute) degree of C<L>, C<R_1> the number of real places of
+C<L>, and C<D> the discriminant of C<L/>B<Q>, including sign (if I<flag>C< = 0>).
+
+If I<flag>C< = 1>, as above but outputs relative data. C<N> is now the degree of
+C<L/K>, C<R_1> is the number of real places of C<K> unramified in C<L> (so that
+the number of real places of C<L> is equal to C<R_1> times the relative degree
+C<N>), and C<D> is the relative discriminant ideal of C<L/K>.
+
+If I<flag>C< = 2>, does as in case 0, except that if the modulus is not the exact
+conductor corresponding to the C<L>, no data is computed and the result is C<0>
+(C<gzero>).
+
+If I<flag>C< = 3>, as case 2, outputting relative data.
+
+X<bnrdisc0>The library syntax is B<bnrdisc0>C<(a1,a2,a3,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<bnrdisclist>bnrdisclistC<(>I<bnf>C<,>I<bound>C<,{>I<arch>C<},{>I<flag>C< = 0})>
+
+I<bnf> being a big
+number field as output by C<bnfinit> (the units are mandatory), computes a
+list of discriminants of Abelian extensions of the number field by increasing
+modulus norm up to bound I<bound>, where the ramified Archimedean places are
+given by I<arch> (unramified at infinity if I<arch> is void or
+omitted). If
+I<flag> is non-zero, give I<arch> all the possible values. (See C<bnr>
+at the beginning of this section for the meaning of C<a1>, C<a2>, C<a3>.)
+
+The alternative syntax C<bnrdisclist(>I<bnf>C<,>I<list>C<)>
+is supported, where I<list> is as output by C<ideallist> or
+C<ideallistarch> (with units).
+
+The output format is as follows. The output C<v> is a row vector of row
+vectors, allowing the bound to be greater than C<2^{16}> for 32-bit machines,
+and C<v[i][j]> is understood to be in fact C<V[2^{15}(i-1)+j]> of a unique big
+vector C<V> (note that C<2^{15}> is hardwired and can be increased in the
+source code only on 64-bit machines and higher).
+
+Such a component C<V[k]> is itself a vector C<W> (maybe of length 0) whose
+components correspond to each possible ideal of norm C<k>. Each component
+C<W[i]> corresponds to an Abelian extension C<L> of I<bnf> whose modulus is
+an ideal of norm C<k> and no Archimedean components (hence the extension is
+unramified at infinity). The extension C<W[i]> is represented by a 4-component
+row vector C<[m,d,r,D]> with the following meaning. C<m> is the prime ideal
+factorization of the modulus, C<d = [L:>B<Q>C<]> is the absolute degree of C<L>,
+C<r> is the number of real places of C<L>, and C<D> is the factorization of the
+absolute discriminant. Each prime ideal C<pr = [p,>F<alpha>C<,e,f,>F<beta>C<]> in the
+prime factorization C<m> is coded as C<p.n^2+(f-1).n+(j-1)>, where
+C<n> is the degree of the base field and C<j> is such that
+
+C<pr = idealprimedec(>I<nf>C<,p)[j]>.
+
+C<m> can be decoded using C<bnfdecodemodule>.
+
+X<bnrdisclist0>The library syntax is B<bnrdisclist0>C<(a1,a2,a3,>I<bound>C<,>I<arch>C<,>I<flag>C<)>.
+
+=head2 X<bnrinit>bnrinitC<(>I<bnf>C<,>I<ideal>C<,{>I<flag>C< = 0})>
+
+I<bnf> is as
+output by C<bnfinit>, I<ideal> is a valid ideal (or a module),
+initializes data linked
+to the ray class group structure corresponding to this module. This is the
+same as C<bnrclass(>I<bnf>C<,>I<ideal>C<,>I<flag>C<+1)>.
+
+X<bnrinit0>The library syntax is B<bnrinit0>C<(>I<bnf>C<,>I<ideal>C<,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<bnrisconductor>bnrisconductorC<(a1,{a2},{a3})>
+
+C<a1>, C<a2>, C<a3> represent
+an extension of the base field, given by class field theory for some modulus
+encoded in the parameters. Outputs 1 if this modulus is the conductor, and 0
+otherwise. This is slightly faster than C<bnrconductor>.
+
+X<bnrisconductor>The library syntax is B<bnrisconductor>C<(a1,a2,a3)> and the result is a C<long>.
+
+=head2 X<bnrisprincipal>bnrisprincipalC<(>I<bnr>C<,x,{>I<flag>C< = 1})>
+
+I<bnr> being the
+number field data which is output by C<bnrinit>C<(,,1)> and C<x> being an
+ideal in any form, outputs the components of C<x> on the ray class group
+generators in a way similar to C<bnfisprincipal>. That is a 3-component
+vector C<v> where C<v[1]> is the vector of components of C<x> on the ray class
+group generators, C<v[2]> gives on the integral basis an element F<alpha> such
+that C<x = >F<alpha>F<prod>C<_ig_i^{x_i}>. Finally C<v[3]> indicates the number of bits
+of accuracy left in the result. In any case the result is checked for
+correctness, but C<v[3]> is included to see if it is necessary to increase the
+accuracy in other computations.
+
+If I<flag>C< = 0>, outputs only C<v_1>. In that case, I<bnr> need not contain the
+ray class group generators, i.e.S< >it may be created with C<bnrinit>C<(,,0)>
+
+X<isprincipalrayall>The library syntax is B<isprincipalrayall>C<(>I<bnr>C<,x,>I<flag>C<)>.
+
+=head2 X<bnrrootnumber>bnrrootnumberC<(>I<bnr>C<,>I<chi>C<,{>I<flag>C< = 0})>
+
+if F<chi>C< = >I<chi> is a (not necessarily primitive)
+X<character>character over I<bnr>, let
+C<L(s,>F<chi>C<) = >F<sum>C<_{id} >F<chi>C<(id) N(id)^{-s}> be the associated
+X<Artin L-function>Artin L-function. Returns the so-called X<Artin root number>Artin root number, i.e.S< >the
+complex number C<W(>F<chi>C<)> of modulus 1 such that
+
+S< >F<Lambda>C<(1-s,>F<chi>C<) = W(>F<chi>C<) >F<Lambda>C<(s,\overline{>F<chi>C<})>
+
+where F<Lambda>C<(s,>F<chi>C<) = A(>F<chi>C<)^{s/2}>F<gamma>C<_>F<chi>C<(s) L(s,>F<chi>C<)> is
+the enlarged L-function associated to C<L>.
+
+The generators of the ray class group are needed, and you can set I<flag>C< = 1> if
+the character is known to be primitive. Example:
+
+ bnf = bnfinit(x^2 - 145);
+ bnr = bnrinit(bnf,7,1);
+ bnrrootnumber(bnr, [5])
+
+returns the root number of the character F<chi> of C<Cl_7(>B<Q>C<(> F<sqrt> C<{145}))>
+such that F<chi>C<(g) = >F<zeta>C<^5>, where C<g> is the generator of the ray-class
+field and F<zeta>C< = e^{2i>F<Pi>C</N}> where C<N> is the order of C<g> (C<N = 12> as
+C<bnr.cyc> readily tells us).
+
+X<bnrrootnumber>The library syntax is B<bnrrootnumber>C<(>I<bnf>C<,>I<chi>C<,>I<flag>C<)>
+
+=head2 bnrstarkC<{(>I<bnr>C<,>I<subgroup>C<,{>I<flag>C< = 0})}>
+
+I<bnr>
+being as output by C<bnrinit(,,1)>, finds a relative equation for the
+class field corresponding to the modulus in I<bnr> and the given
+congruence subgroup using X<Stark units>Stark units (set I<subgroup>C< = 0> if you
+want the whole ray class group). The main variable of I<bnr> must not be
+C<x>, and the ground field and the class field must be totally real and not
+isomorphic to B<Q> (over the rationnals, use X<polsubcyclo>C<polsubcyclo> or
+X<galoissubcyclo>C<galoissubcyclo>). I<flag> is optional and may be set to 0 to obtain a
+reduced relative polynomial, 1 to be satisfied with any relative
+polynomial, 2 to obtain an absolute polynomial and 3 to obtain the
+irreducible relative polynomial of the Stark unit, 0 being default.
+Example:
+
+ bnf = bnfinit(y^2 - 3);
+ bnr = bnrinit(bnf, 5, 1);
+ bnrstark(bnr, 0)
+
+returns the ray class field of B<Q>C<(> F<sqrt> C<{3})> modulo C<5>.
+
+B<Remark.> The result of the computation depends on the choice of
+a modulus verifying special conditions. By default the function will try
+few moduli, choosing the one giving the smallest result. In some cases
+where the result is however very large, you can tell the function to
+try more moduli by adding C<4> to the value of flag. Whether this flag is
+set or not, the function may fail in some extreme cases, returning the
+error message
+
+C<"Cannot find a suitable modulus in FindModule">.
+
+In this case, the corresponding congruence group is a product of cyclic
+groups and, for the time being, the class field has to be obtained by
+splitting this group into its cyclic components.
+
+X<bnrstark>The library syntax is B<bnrstark>C<(>I<bnr>C<,>I<subgroup>C<,>I<flag>C<)>.
+
+=head2 X<dirzetak>dirzetakC<(>I<nf>C<,b)>
+
+gives as a vector the first C<b>
+coefficients of the X<Dedekind>Dedekind zeta function of the number field I<nf>
+considered as a X<Dirichlet series>Dirichlet series.
+
+X<dirzetak>The library syntax is B<dirzetak>C<(>I<nf>C<,b)>.
+
+=head2 X<factornf>factornfC<(x,t)>
+
+factorization of the univariate polynomial C<x>
+over the number field defined by the (univariate) polynomial C<t>. C<x> may
+have coefficients in B<Q> or in the number field. The main variable of
+C<t> must be of I<lower> priority than that of C<x> (in other words the
+variable number of C<t> must be I<greater> than that of C<x>). However if
+the coefficients of the number field occur explicitly (as polmods) as
+coefficients of C<x>, the variable of these polmods I<must> be the same as
+the main variable of C<t>. For example
+
+ ? factornf(x^2 + Mod(y, y^2+1), y^2+1);
+ ? factornf(x^2 + 1, y^2+1); \\ these two are OK
+ ? factornf(x^2 + Mod(z,z^2+1), y^2+1)
+ *** incorrect type in gmulsg
+
+X<polfnf>The library syntax is B<polfnf>C<(x,t)>.
+
+=head2 X<galoisfixedfield>galoisfixedfieldC<(>I<gal>C<,>I<perm>C<,{fl = 0},{v = y}))>
+
+I<gal> being be a Galois field as output by X<galoisinit>C<galoisinit> and
+I<perm> an element of I<gal>C<.group> or a vector of such elements,
+computes the fixed field of I<gal> by the automorphism defined by the
+permutations I<perm> of the roots I<gal>C<.roots>. C<P> is guaranteed to
+be squarefree modulo I<gal>C<.p>.
+
+If no flags or I<flag>C< = 0>, output format is the same as for X<nfsubfield>C<nfsubfield>,
+returning C<[P,x]> such that C<P> is a polynomial defining the fixed field, and
+C<x> is a root of C<P> expressed as a polmod in I<gal>C<.pol>.
+
+If I<flag>C< = 1> return only the polynomial C<P>.
+
+If I<flag>C< = 2> return C<[P,x,F]> where C<P> and C<x> are as above and C<F> is the
+factorization of I<gal>C<.pol> over the field defined by C<P>, where
+variable C<v> (C<y> by default) stands for a root of C<P>. The priority of C<v>
+must be less than the priority of the variable of I<gal>C<.pol>.
+
+Example:
+
+ G = galoisinit(x^4+1);
+ galoisfixedfield(G,G.group[2],2)
+ [x^2 + 2, Mod(x^3 + x, x^4 + 1), [x^2 - y*x - 1, x^2 + y*x - 1]]
+
+computes the factorization C<x^4+1 = (x^2-> F<sqrt> C<{-2}x-1)(x^2+> F<sqrt> C<{-2}x-1)>
+
+X<galoisfixedfield>The library syntax is B<galoisfixedfield>C<(>I<gal>C<,>I<perm>C<,p)>.
+
+=head2 X<galoisinit>galoisinitC<(>I<pol>C<,{den})>
+
+computes the Galois group
+and all neccessary information for computing the fixed fields of the
+Galois extension C<K/>B<Q> where C<K> is the number field defined by
+I<pol> (monic irreducible polynomial in B<Z>C<[X]> or
+a number field as output by X<nfinit>C<nfinit>). The extension C<K/>B<Q> must be
+Galois with Galois group ``weakly'' super-solvable (see X<nfgaloisconj>C<nfgaloisconj>)
+
+B<Warning:> The interface of this function is experimental,
+so the described output can be subject to important changes in the
+near future. However the function itself should work as described. For any
+remarks about this interface, please mail C<allomber@math.u-bordeaux.fr>.
+
+The output is an 8-component vector I<gal>.
+
+I<gal>C<[1]> contains the polynomial I<pol>
+(I<gal>C<.pol>).
+
+I<gal>C<[2]> is a three--components vector C<[p,e,q]> where C<p> is a
+prime number (I<gal>C<.p>) such that I<pol> totally split
+modulo C<p> , C<e> is an integer and C<q = p^e> (I<gal>C<.mod>) is the
+modulus of the roots in I<gal>C<.roots>.
+
+I<gal>C<[3]> is a vector C<L> containing the C<p>-adic roots of
+I<pol> as integers implicitly modulo I<gal>C<.mod>.
+(I<gal>C<.roots>).
+
+I<gal>C<[4]> is the inverse of the Van der Monde matrix of the
+C<p>-adic roots of I<pol>, multiplied by I<gal>C<[5]>.
+
+I<gal>C<[5]> is a multiple of the least common denominator of the
+automorphisms expressed as polynomial in a root of I<pol>.
+
+I<gal>C<[6]> is the Galois group C<G> expressed as a vector of
+permutations of C<L> (I<gal>C<.group>).
+
+I<gal>C<[7]> is a generating subset C<S = [s_1,...,s_g]> of C<G>
+expressed as a vector of permutations of C<L> (I<gal>C<.gen>).
+
+I<gal>C<[8]> contains the relative orders C<[o_1,...,o_g]> of
+the generators of C<S> (I<gal>C<.orders>).
+
+Let C<H> be the maximal normal supersolvable subgroup of C<G>, we have the
+following properties:
+
+S< >S< >B<*> if C<G/H ~ A_4> then C<[o_1,...,o_g]> ends by
+C<[2,2,3]>.
+
+S< >S< >B<*> if C<G/H ~ S_4> then C<[o_1,...,o_g]> ends by
+C<[2,2,3,2]>.
+
+S< >S< >B<*> else C<G> is super-solvable.
+
+S< >S< >B<*> for C<1 E<lt>= i E<lt>= g> the subgroup of C<G> generated by
+C<[s_1,...,s_g]> is normal, with the exception of C<i = g-2> in the
+second case and of C<i = g-3> in the third.
+
+S< >S< >B<*> the relative order C<o_i> of C<s_i> is its order in the
+quotient group C<G/E<lt>s_1,...,s_{i-1}E<gt>>, with the same
+exceptions.
+
+S< >S< >B<*> for any C<x belongs to G> there exists a unique family
+C<[e_1,...,e_g]> such that (no exceptions):
+
+-- for C<1 E<lt>= i E<lt>= g> we have C<0 E<lt>= e_i E<lt> o_i>
+
+-- C<x = g_1^{e_1}g_2^{e_2}...g_n^{e_n}>
+
+If present C<den> must be a suitable value for I<gal>C<[5]>.
+
+X<galoisinit>The library syntax is B<galoisinit>C<(>I<gal>C<,>I<den>C<)>.
+
+=head2 X<galoispermtopol>galoispermtopolC<(>I<gal>C<,>I<perm>C<)>
+
+I<gal> being a
+galois field as output by C<galoisinit> and I<perm> a element of
+I<gal>C<.group>, return the polynomial defining the Galois
+automorphism, as output by C<nfgaloisconj>, associated with the
+permutation I<perm> of the roots I<gal>C<.roots>. I<perm> can
+also be a vector or matrix, in this case, C<galoispermtopol> is
+applied to all components recursively.
+
+Note that
+
+ G = galoisinit(pol);
+ galoispermtopol(G, G[6])~
+
+is equivalent to C<nfgaloisconj(pol)>, if degree of I<pol>
+is greater or equal to C<2>.
+
+X<galoispermtopol>The library syntax is B<galoispermtopol>C<(>I<gal>C<,>I<perm>C<)>.
+
+=head2 X<galoissubcyclo>galoissubcycloC<(n,H,{Z},{v})>
+
+compute a polynomial
+defining the subfield of B<Q>C<(>F<zeta>C<_n)> fixed by the subgroup I<H> of
+B<Z>C</n>B<Z>. The subgroup I<H> can be given by a generator, a set of
+generators given by a vector or a HNF matrix. If present C<Z> must be
+C<znstar(n)>, and is currently only used when I<H> is a HNF matrix. If
+I<v> is given, the polynomial is given in the variable I<v>.
+
+The following function can be used to compute all subfields of
+B<Q>C<(>F<zeta>C<_n)> (of order less than C<d>, if C<d> is set):
+
+ subcyclo(n, d = -1)=
+ {
+ local(Z,G,S);
+ if (d < 0, d = n);
+ Z = znstar(n);
+ G = matdiagonal(Z[2]);
+ S = [];
+ forsubgroup(H = G, d,
+ S = concat(S, galoissubcyclo(n, mathnf(concat(G,H)),Z));
+ );
+ S
+ }
+
+X<galoissubcyclo>The library syntax is B<galoissubcyclo>C<(n,H,Z,v)> where n is a C long integer.
+
+=head2 X<idealadd>idealaddC<(>I<nf>C<,x,y)>
+
+sum of the two ideals C<x> and C<y> in the
+number field I<nf>. When C<x> and C<y> are given by B<Z>-bases, this does
+not depend on I<nf> and can be used to compute the sum of any two
+B<Z>-modules. The result is given in HNF.
+
+X<idealadd>The library syntax is B<idealadd>C<(>I<nf>C<,x,y)>.
+
+=head2 X<idealaddtoone>idealaddtooneC<(>I<nf>C<,x,{y})>
+
+C<x> and C<y> being two co-prime
+integral ideals (given in any form), this gives a two-component row vector
+C<[a,b]> such that C<a belongs to x>, C<b belongs to y> and C<a+b = 1>.
+
+The alternative syntax C<idealaddtoone(>I<nf>C<,v)>, is supported, where
+C<v> is a C<k>-component vector of ideals (given in any form) which sum to
+B<Z>C<_K>. This outputs a C<k>-component vector C<e> such that C<e[i] belongs to x[i]> for
+C<1 E<lt>= i E<lt>= k> and F<sum>C<_{1 E<lt>= i E<lt>= k}e[i] = 1>.
+
+X<idealaddtoone0>The library syntax is B<idealaddtoone0>C<(>I<nf>C<,x,y)>, where an omitted C<y> is coded as
+C<NULL>.
+
+=head2 X<idealappr>idealapprC<(>I<nf>C<,x,{>I<flag>C< = 0})>
+
+if C<x> is a fractional ideal
+(given in any form), gives an element F<alpha> in I<nf> such that for
+all prime ideals B<p> such that the valuation of C<x> at B<p> is non-zero, we
+have C<v_{>B<p>C<}(>F<alpha>C<) = v_{>B<p>C<}(x)>, and. C<v_{>B<p>C<}(>F<alpha>C<) E<gt>= 0> for all other
+C<{>B<p>C<}>.
+
+If I<flag> is non-zero, C<x> must be given as a prime ideal factorization, as
+output by C<idealfactor>, but possibly with zero or negative exponents.
+This yields an element F<alpha> such that for all prime ideals B<p> occurring
+in C<x>, C<v_{>B<p>C<}(>F<alpha>C<)> is equal to the exponent of B<p> in C<x>, and for all
+other prime ideals, C<v_{>B<p>C<}(>F<alpha>C<) E<gt>= 0>. This generalizes
+C<idealappr(>I<nf>C<,x,0)> since zero exponents are allowed. Note that
+the algorithm used is slightly different, so that
+C<idealapp(>I<nf>C<,idealfactor(>I<nf>C<,x))> may not be the same as
+C<idealappr(>I<nf>C<,x,1)>.
+
+X<idealappr0>The library syntax is B<idealappr0>C<(>I<nf>C<,x,>I<flag>C<)>.
+
+=head2 X<idealchinese>idealchineseC<(>I<nf>C<,x,y)>
+
+C<x> being a prime ideal factorization
+(i.e.S< >a 2 by 2 matrix whose first column contain prime ideals, and the second
+column integral exponents), C<y> a vector of elements in I<nf> indexed by
+the ideals in C<x>, computes an element C<b> such that
+
+C<v_>B<p>C<(b - y_>B<p>C<) E<gt>= v_>B<p>C<(x)> for all prime ideals in C<x> and C<v_>B<p>C<(b) E<gt>= 0>
+for all other B<p>.
+
+X<idealchinese>The library syntax is B<idealchinese>C<(>I<nf>C<,x,y)>.
+
+=head2 X<idealcoprime>idealcoprimeC<(>I<nf>C<,x,y)>
+
+given two integral ideals C<x> and C<y>
+in the number field I<nf>, finds a F<beta> in the field, expressed on the
+integral basis I<nf>C<[7]>, such that F<beta>C<.y> is an integral ideal
+coprime to C<x>.
+
+X<idealcoprime>The library syntax is B<idealcoprime>C<(>I<nf>C<,x)>.
+
+=head2 X<idealdiv>idealdivC<(>I<nf>C<,x,y,{>I<flag>C< = 0})>
+
+quotient C<x.y^{-1}> of the
+two ideals C<x> and C<y> in the number field I<nf>. The result is given in
+HNF.
+
+If I<flag> is non-zero, the quotient C<x.y^{-1}> is assumed to be an
+integral ideal. This can be much faster when the norm of the quotient is
+small even though the norms of C<x> and C<y> are large.
+
+X<idealdiv0>The library syntax is B<idealdiv0>C<(>I<nf>C<,x,y,>I<flag>C<)>. Also available
+are X<idealdiv>B<idealdiv>C<(>I<nf>C<,x,y)> (I<flag>C< = 0>) and
+X<idealdivexact>B<idealdivexact>C<(>I<nf>C<,x,y)> (I<flag>C< = 1>).
+
+=head2 X<idealfactor>idealfactorC<(>I<nf>C<,x)>
+
+factors into prime ideal powers the
+ideal C<x> in the number field I<nf>. The output format is similar to the
+C<factor> function, and the prime ideals are represented in the form
+output by the C<idealprimedec> function, i.e.S< >as 5-element vectors.
+
+X<idealfactor>The library syntax is B<idealfactor>C<(>I<nf>C<,x)>.
+
+=head2 X<idealhnf>idealhnfC<(>I<nf>C<,a,{b})>
+
+gives the X<Hermite normal form>Hermite normal form
+matrix of the ideal C<a>. The ideal can be given in any form whatsoever
+(typically by an algebraic number if it is principal, by a B<Z>C<_K>-system of
+generators, as a prime ideal as given by C<idealprimedec>, or by a
+B<Z>-basis).
+
+If C<b> is not omitted, assume the ideal given was C<a>B<Z>C<_K+b>B<Z>C<_K>, where C<a>
+and C<b> are elements of C<K> given either as vectors on the integral basis
+I<nf>C<[7]> or as algebraic numbers.
+
+X<idealhnf0>The library syntax is B<idealhnf0>C<(>I<nf>C<,a,b)> where an omitted C<b> is coded as C<NULL>.
+Also available is X<idealhermite>B<idealhermite>C<(>I<nf>C<,a)> (C<b> omitted).
+
+=head2 X<idealintersect>idealintersectC<(>I<nf>C<,x,y)>
+
+intersection of the two ideals
+C<x> and C<y> in the number field I<nf>. When C<x> and C<y> are given by
+B<Z>-bases, this does not depend on I<nf> and can be used to compute the
+intersection of any two B<Z>-modules. The result is given in HNF.
+
+X<idealintersect>The library syntax is B<idealintersect>C<(>I<nf>C<,x,y)>.
+
+=head2 X<idealinv>idealinvC<(>I<nf>C<,x)>
+
+inverse of the ideal C<x> in the
+number field I<nf>. The result is the Hermite normal form of the inverse
+of the ideal, together with the opposite of the Archimedean information if it
+is given.
+
+X<idealinv>The library syntax is B<idealinv>C<(>I<nf>C<,x)>.
+
+=head2 X<ideallist>ideallistC<(>I<nf>C<,>I<bound>C<,{>I<flag>C< = 4})>
+
+computes the list
+of all ideals of norm less or equal to I<bound> in the number field
+I<nf>. The result is a row vector with exactly I<bound> components.
+Each component is itself a row vector containing the information about
+ideals of a given norm, in no specific order. This information can be
+either the HNF of the ideal or the C<idealstar> with possibly some
+additional information.
+
+If I<flag> is present, its binary digits are toggles meaning
+
+S< >S< >1: give also the generators in the C<idealstar>.
+
+S< >S< >2: output C<[L,U]>, where C<L> is as before and C<U> is a vector of
+C<zinternallog>s of the units.
+
+S< >S< >4: give only the ideals and not the C<idealstar> or the C<ideallog>
+of the units.
+
+X<ideallist0>The library syntax is B<ideallist0>C<(>I<nf>C<,>I<bound>C<,>I<flag>C<)>, where I<bound> must
+be a C long integer. Also available is X<ideallist>B<ideallist>C<(>I<nf>C<,>I<bound>C<)>,
+corresponding to the case I<flag>C< = 0>.
+
+=head2 X<ideallistarch>ideallistarchC<(>I<nf>C<,>I<list>C<,{>I<arch>C< = []},{>I<flag>C< = 0})>
+
+vector of vectors of all C<idealstarinit> (see C<idealstar>) of all
+modules in I<list>, with Archimedean part I<arch> added (void if
+omitted). I<list> is a vector of big ideals, as output by
+C<ideallist>C<(..., >I<flag>C<)> for instance. I<flag> is optional; its binary
+digits are toggles meaning: 1: give generators as well, 2: list format is
+C<[L,U]> (see C<ideallist>).
+
+X<ideallistarch0>The library syntax is B<ideallistarch0>C<(>I<nf>C<,>I<list>C<,>I<arch>C<,>I<flag>C<)>, where an omitted
+I<arch> is coded as C<NULL>.
+
+=head2 X<ideallog>ideallogC<(>I<nf>C<,x,>I<bid>C<)>
+
+I<nf> being a number field,
+I<bid> being a ``big ideal'' as output by C<idealstar> and C<x> being a
+non-necessarily integral element of I<nf> which must have valuation
+equal to 0 at all prime ideals dividing C<I = >I<bid>C<[1]>, computes the
+``discrete logarithm'' of C<x> on the generators given in I<bid>C<[2]>.
+In other words, if C<g_i> are these generators, of orders C<d_i> respectively,
+the result is a column vector of integers C<(x_i)> such that C<0 E<lt>= x_i E<lt> d_i> and
+
+S< >C<x = >F<prod>C<_ig_i^{x_i} (mod ^*I) .>
+
+Note that when C<I> is a module, this implies also sign conditions on the
+embeddings.
+
+X<zideallog>The library syntax is B<zideallog>C<(>I<nf>C<,x,>I<bid>C<)>.
+
+=head2 X<idealmin>idealminC<(>I<nf>C<,x,{>I<vdir>C<})>
+
+computes a minimum of
+the ideal C<x> in the direction I<vdir> in the number field I<nf>.
+
+X<minideal>The library syntax is B<minideal>C<(>I<nf>C<,x,>I<vdir>C<,>I<prec>C<)>, where an omitted
+I<vdir> is coded as C<NULL>.
+
+=head2 X<idealmul>idealmulC<(>I<nf>C<,x,y,{>I<flag>C< = 0})>
+
+ideal multiplication of the
+ideals C<x> and C<y> in the number field I<nf>. The result is a generating
+set for the ideal product with at most C<n> elements, and is in Hermite normal
+form if either C<x> or C<y> is in HNF or is a prime ideal as output by
+C<idealprimedec>, and this is given together with the sum of the
+Archimedean information in C<x> and C<y> if both are given.
+
+If I<flag> is non-zero, reduce the result using C<idealred>.
+
+X<idealmul>The library syntax is B<idealmul>C<(>I<nf>C<,x,y)> (I<flag>C< = 0>) or
+X<idealmulred>B<idealmulred>C<(>I<nf>C<,x,y,>I<prec>C<)> (I<flag>C< ! = 0>), where as usual,
+I<prec> is a C long integer representing the precision.
+
+=head2 X<idealnorm>idealnormC<(>I<nf>C<,x)>
+
+computes the norm of the idealS< >C<x>
+in the number fieldS< >I<nf>.
+
+X<idealnorm>The library syntax is B<idealnorm>C<(>I<nf>C<, x)>.
+
+=head2 X<idealpow>idealpowC<(>I<nf>C<,x,k,{>I<flag>C< = 0})>
+
+computes the C<k>-th power of
+the ideal C<x> in the number field I<nf>. C<k> can be positive, negative
+or zero. The result is NOT reduced, it is really the C<k>-th ideal power, and
+is given in HNF.
+
+If I<flag> is non-zero, reduce the result using C<idealred>. Note however
+that this is NOT the same as as C<idealpow(>I<nf>C<,x,k)> followed by
+reduction, since the reduction is performed throughout the powering process.
+
+The library syntax corresponding to I<flag>C< = 0> is
+X<idealpow>B<idealpow>C<(>I<nf>C<,x,k)>. If C<k> is a C<long>, you can use
+X<idealpows>B<idealpows>C<(>I<nf>C<,x,k)>. Corresponding to I<flag>C< = 1> is
+X<idealpowred>B<idealpowred>C<(>I<nf>C<,vp,k,>I<prec>C<)>, where I<prec> is a
+C<long>.
+
+=head2 X<idealprimedec>idealprimedecC<(>I<nf>C<,p)>
+
+computes the prime ideal
+decomposition of the prime number C<p> in the number field I<nf>. C<p>
+must be a (positive) prime number. Note that the fact that C<p> is prime is
+not checked, so if a non-prime number C<p> is given it may lead to
+unpredictable results.
+
+The result is a vector of 5-component vectors, each representing one of the
+prime ideals above C<p> in the number field I<nf>. The representation
+C<vp = [p,a,e,f,b]> of a prime ideal means the following. The prime ideal is
+equal to C<p>B<Z>C<_K+>F<alpha>B<Z>C<_K> where B<Z>C<_K> is the ring of integers of the field
+and F<alpha>C< = >F<sum>C<_i a_i>F<omega>C<_i> where the F<omega>C<_i> form the integral basis
+I<nf>C<.zk>, C<e> is the ramification index, C<f> is the residual index,
+and C<b> is an C<n>-component column vector representing a F<beta>C< belongs to >B<Z>C<_K> such
+that C<vp^{-1} = >B<Z>C<_K+>F<beta>C</p>B<Z>C<_K> which will be useful for computing
+valuations, but which the user can ignore. The number F<alpha> is guaranteed
+to have a valuation equal to 1 at the prime ideal (this is automatic if
+C<e E<gt> 1>).
+
+X<idealprimedec>The library syntax is B<idealprimedec>C<(>I<nf>C<,p)>.
+
+=head2 X<idealprincipal>idealprincipalC<(>I<nf>C<,x)>
+
+creates the principal ideal
+generated by the algebraic number C<x> (which must be of type integer,
+rational or polmod) in the number field I<nf>. The result is a
+one-column matrix.
+
+X<principalideal>The library syntax is B<principalideal>C<(>I<nf>C<,x)>.
+
+=head2 X<idealred>idealredC<(>I<nf>C<,I,{>I<vdir>C< = 0})>
+
+X<LLL>LLL reduction of
+the ideal C<I> in the number field I<nf>, along the direction I<vdir>.
+If I<vdir> is present, it must be an C<r1+r2>-component vector (C<r1> and
+C<r2> number of real and complex places of I<nf> as usual).
+
+This function finds a ``small'' C<a> in C<I> (it is an LLL pseudo-minimum
+along direction I<vdir>). The result is the X<Hermite normal form>Hermite normal form of
+the LLL-reduced ideal C<r I/a>, where C<r> is a rational number such that the
+resulting ideal is integral and primitive. This is often, but not always, a
+reduced ideal in the sense of X<Buchmann>Buchmann. If C<I> is an idele, the
+logarithmic embeddings of C<a> are subtracted to the Archimedean part.
+
+More often than not, a X<principal ideal>principal ideal will yield the identity
+matrix. This is a quick and dirty way to check if ideals are principal
+without computing a full C<bnf> structure, but it's not a necessary
+condition; hence, a non-trivial result doesn't prove the ideal is
+non-trivial in the class group.
+
+Note that this is I<not> the same as the LLL reduction of the lattice
+C<I> since ideal operations are involved.
+
+X<ideallllred>The library syntax is B<ideallllred>C<(>I<nf>C<,x,>I<vdir>C<,>I<prec>C<)>, where an omitted
+I<vdir> is coded as C<NULL>.
+
+=head2 X<idealstar>idealstarC<(>I<nf>C<,I,{>I<flag>C< = 1})>
+
+I<nf> being a number
+field, and C<I>
+either and ideal in any form, or a row vector whose first component is an
+ideal and whose second component is a row vector of C<r_1> 0 or 1, outputs
+necessary data for computing in the group C<(>B<Z>C<_K/I)^*>.
+
+If I<flag>C< = 2>, the result is a 5-component vector C<w>. C<w[1]> is the ideal
+or module C<I> itself. C<w[2]> is the structure of the group. The other
+components are difficult to describe and are used only in conjunction with
+the function C<ideallog>.
+
+If I<flag>C< = 1> (default), as I<flag>C< = 2>, but do not compute explicit generators
+for the cyclic components, which saves time.
+
+If I<flag>C< = 0>, computes the structure of C<(>B<Z>C<_K/I)^*> as a 3-component vector
+C<v>. C<v[1]> is the order, C<v[2]> is the vector of SNFX<Smith normal form>
+cyclic components and
+C<v[3]> the corresponding generators. When the row vector is explicitly
+included, the
+non-zero elements of this vector are considered as real embeddings of
+I<nf> in the order given by C<polroots>, i.e.S< >in I<nf>[6]
+(I<nf>C<.roots>), and then C<I> is a module with components at infinity.
+
+To solve discrete logarithms (using C<ideallog>), you have to choose
+I<flag>C< = 2>.
+
+X<idealstar0>The library syntax is B<idealstar0>C<(>I<nf>C<,I,>I<flag>C<)>.
+
+=head2 X<idealtwoelt>idealtwoeltC<(>I<nf>C<,x,{a})>
+
+computes a two-element
+representation of the ideal C<x> in the number field I<nf>, using a
+straightforward (exponential time) search. C<x> can be an ideal in any form,
+(including perhaps an Archimedean part, which is ignored) and the result is a
+row vector C<[a,>F<alpha>C<]> with two components such that C<x = a>B<Z>C<_K+>F<alpha>B<Z>C<_K>
+and C<a belongs to >B<Z>, where C<a> is the one passed as argument if any. If C<x> is given
+by at least two generators, C<a> is chosen to be the positive generator of
+C<x> F<cap> B<Z>.
+
+Note that when an explicit C<a> is given, we use an asymptotically faster
+method, however in practice it is usually slower.
+
+X<ideal_two_elt0>The library syntax is B<ideal_two_elt0>C<(>I<nf>C<,x,a)>, where an omitted C<a> is entered as
+C<NULL>.
+
+=head2 X<idealval>idealvalC<(>I<nf>C<,x,>I<vp>C<)>
+
+gives the valuation of the
+ideal C<x> at the prime ideal I<vp> in the number field I<nf>,
+where I<vp> must be a
+5-component vector as given by C<idealprimedec>.
+
+X<idealval>The library syntax is B<idealval>C<(>I<nf>C<,x,>I<vp>C<)>, and the result is a C<long>
+integer.
+
+=head2 X<ideleprincipal>ideleprincipalC<(>I<nf>C<,x)>
+
+creates the principal idele
+generated by the algebraic number C<x> (which must be of type integer,
+rational or polmod) in the number field I<nf>. The result is a
+two-component vector, the first being a one-column matrix representing the
+corresponding principal ideal, and the second being the vector with C<r_1+r_2>
+components giving the complex logarithmic embedding of C<x>.
+
+X<principalidele>The library syntax is B<principalidele>C<(>I<nf>C<,x)>.
+
+=head2 X<matalgtobasis>matalgtobasisC<(>I<nf>C<,x)>
+
+I<nf> being a number field in
+C<nfinit> format, and C<x> a matrix whose coefficients are expressed as
+polmods in I<nf>, transforms this matrix into a matrix whose
+coefficients are expressed on the integral basis of I<nf>. This is the
+same as applying C<nfalgtobasis> to each entry, but it would be dangerous
+to use the same name.
+
+X<matalgtobasis>The library syntax is B<matalgtobasis>C<(>I<nf>C<,x)>.
+
+=head2 X<matbasistoalg>matbasistoalgC<(>I<nf>C<,x)>
+
+I<nf> being a number field in
+C<nfinit> format, and C<x> a matrix whose coefficients are expressed as
+column vectors on the integral basis of I<nf>, transforms this matrix
+into a matrix whose coefficients are algebraic numbers expressed as
+polmods. This is the same as applying C<nfbasistoalg> to each entry, but
+it would be dangerous to use the same name.
+
+X<matbasistoalg>The library syntax is B<matbasistoalg>C<(>I<nf>C<,x)>.
+
+=head2 X<modreverse>modreverseC<(a)>
+
+C<a> being a polmod C<A(X)> modulo C<T(X)>, finds
+the ``reverse polmod'' C<B(X)> modulo C<Q(X)>, where C<Q> is the minimal
+polynomial of C<a>, which must be equal to the degree of C<T>, and such that if
+F<theta> is a root of C<T> then F<theta>C< = B(>F<alpha>C<)> for a certain root F<alpha>
+of C<Q>.
+
+This is very useful when one changes the generating element in algebraic
+extensions.
+
+X<polmodrecip>The library syntax is B<polmodrecip>C<(x)>.
+
+=head2 X<newtonpoly>newtonpolyC<(x,p)>
+
+gives the vector of the slopes of the Newton
+polygon of the polynomial C<x> with respect to the prime number C<p>. The C<n>
+components of the vector are in decreasing order, where C<n> is equal to the
+degree of C<x>. Vertical slopes occur iff the constant coefficient of C<x> is
+zero and are denoted by C<VERYBIGINT>, the biggest single precision
+integer representable on the machine (C<2^{31}-1> (resp.S< >C<2^{63}-1>) on 32-bit
+(resp.S< >64-bit) machines), see L<Label se:valuation>.
+
+X<newtonpoly>The library syntax is B<newtonpoly>C<(x,p)>.
+
+=head2 X<nfalgtobasis>nfalgtobasisC<(>I<nf>C<,x)>
+
+this is the inverse function of
+C<nfbasistoalg>. Given an object C<x> whose entries are expressed as
+algebraic numbers in the number field I<nf>, transforms it so that the
+entries are expressed as a column vector on the integral basis
+I<nf>C<.zk>.
+
+X<algtobasis>The library syntax is B<algtobasis>C<(>I<nf>C<,x)>.
+
+=head2 X<nfbasis>nfbasisC<(x,{>I<flag>C< = 0},{p})>
+
+X<integral basis>integral basis of the number
+field defined by the irreducible, preferably monic, polynomial C<x>,
+using a modified version of the X<round 4>round 4 algorithm by
+default. The binary digits of I<flag> have the following meaning:
+
+1: assume that no square of a prime greater than the default C<primelimit>
+divides the discriminant of C<x>, i.e.S< >that the index of C<x> has only small
+prime divisors.
+
+2: use X<round 2>round 2 algorithm. For small degrees and coefficient size, this is
+sometimes a little faster. (This program is the translation into C of a program
+written by David X<Ford>Ford in Algeb.)
+
+Thus for instance, if I<flag>C< = 3>, this uses the round 2 algorithm and outputs
+an order which will be maximal at all the small primes.
+
+If C<p> is present, we assume (without checking!) that it is the two-column
+matrix of the factorization of the discriminant of the polynomial C<x>. Note
+that it does I<not> have to be a complete factorization. This is
+especially useful if only a local integral basis for some small set of places
+is desired: only factors with exponents greater or equal to 2 will be
+considered.
+
+X<nfbasis0>The library syntax is B<nfbasis0>C<(x,>I<flag>C<,p)>. An extended version
+is X<nfbasis>B<nfbasis>C<(x,&d,>I<flag>C<,p)>, where C<d> will receive the discriminant of
+the number field (I<not> of the polynomial C<x>), and an omitted C<p> should
+be input as C<gzero>. Also available are X<base>B<base>C<(x,&d)> (I<flag>C< = 0>),
+X<base2>B<base2>C<(x,&d)> (I<flag>C< = 2>) and X<factoredbase>B<factoredbase>C<(x,p,&d)>.
+
+=head2 X<nfbasistoalg>nfbasistoalgC<(>I<nf>C<,x)>
+
+this is the inverse function of
+C<nfalgtobasis>. Given an object C<x> whose entries are expressed on the
+integral basis I<nf>C<.zk>, transforms it into an object whose entries
+are algebraic numbers (i.e.S< >polmods).
+
+X<basistoalg>The library syntax is B<basistoalg>C<(>I<nf>C<,x)>.
+
+=head2 X<nfdetint>nfdetintC<(>I<nf>C<,x)>
+
+given a pseudo-matrix C<x>, computes a
+non-zero ideal contained in (i.e.S< >multiple of) the determinant of C<x>. This
+is particularly useful in conjunction with C<nfhnfmod>.
+
+X<nfdetint>The library syntax is B<nfdetint>C<(>I<nf>C<,x)>.
+
+=head2 X<nfdisc>nfdiscC<(x,{>I<flag>C< = 0},{p})>
+
+X<field discriminant>field discriminant of the
+number field defined by the integral, preferably monic, irreducible
+polynomial C<x>. I<flag> and C<p> are exactly as in C<nfbasis>. That is, C<p>
+provides the matrix of a partial factorization of the discriminant of C<x>,
+and binary digits of I<flag> are as follows:
+
+1: assume that no square of a prime greater than C<primelimit>
+divides the discriminant.
+
+2: use the round 2 algorithm, instead of the default X<round 4>round 4.
+This should be
+slower except maybe for polynomials of small degree and coefficients.
+
+X<nfdiscf0>The library syntax is B<nfdiscf0>C<(x,>I<flag>C<,p)> where, to omit C<p>, you should input C<gzero>. You
+can also use X<discf>B<discf>C<(x)> (I<flag>C< = 0>).
+
+=head2 X<nfeltdiv>nfeltdivC<(>I<nf>C<,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes their quotient C<x/y> in the number field I<nf>.
+
+X<element_div>The library syntax is B<element_div>C<(>I<nf>C<,x,y)>.
+
+=head2 X<nfeltdiveuc>nfeltdiveucC<(>I<nf>C<,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes an algebraic integer C<q> in the number field I<nf>
+such that the components of C<x-qy> are reasonably small. In fact, this is
+functionally identical to C<round(nfeltdiv(>I<nf>C<,x,y))>.
+
+X<nfdiveuc>The library syntax is B<nfdiveuc>C<(>I<nf>C<,x,y)>.
+
+=head2 X<nfeltdivmodpr>nfeltdivmodprC<(>I<nf>C<,x,y,>I<pr>C<)>
+
+given two elements C<x>
+and C<y> in I<nf> and I<pr> a prime ideal in C<modpr> format (see
+X<nfmodprinit>C<nfmodprinit>), computes their quotient C<x / y> modulo the prime ideal
+I<pr>.
+
+X<element_divmodpr>The library syntax is B<element_divmodpr>C<(>I<nf>C<,x,y,>I<pr>C<)>.
+
+=head2 X<nfeltdivrem>nfeltdivremC<(>I<nf>C<,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, gives a two-element row vector C<[q,r]> such that C<x = qy+r>, C<q> is
+an algebraic integer in I<nf>, and the components of C<r> are
+reasonably small.
+
+X<nfdivres>The library syntax is B<nfdivres>C<(>I<nf>C<,x,y)>.
+
+=head2 X<nfeltmod>nfeltmodC<(>I<nf>C<,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes an element C<r> of I<nf> of the form C<r = x-qy> with
+C<q> and algebraic integer, and such that C<r> is small. This is functionally
+identical to
+
+S< >C<x - nfeltmul(>I<nf>C<,round(nfeltdiv(>I<nf>C<,x,y)),y).>
+
+X<nfmod>The library syntax is B<nfmod>C<(>I<nf>C<,x,y)>.
+
+=head2 X<nfeltmul>nfeltmulC<(>I<nf>C<,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes their product C<x*y> in the number field I<nf>.
+
+X<element_mul>The library syntax is B<element_mul>C<(>I<nf>C<,x,y)>.
+
+=head2 X<nfeltmulmodpr>nfeltmulmodprC<(>I<nf>C<,x,y,>I<pr>C<)>
+
+given two elements C<x> and
+C<y> in I<nf> and I<pr> a prime ideal in C<modpr> format (see
+X<nfmodprinit>C<nfmodprinit>), computes their product C<x*y> modulo the prime ideal
+I<pr>.
+
+X<element_mulmodpr>The library syntax is B<element_mulmodpr>C<(>I<nf>C<,x,y,>I<pr>C<)>.
+
+=head2 X<nfeltpow>nfeltpowC<(>I<nf>C<,x,k)>
+
+given an element C<x> in I<nf>,
+and a positive or negative integer C<k>, computes C<x^k> in the number field
+I<nf>.
+
+X<element_pow>The library syntax is B<element_pow>C<(>I<nf>C<,x,k)>.
+
+=head2 X<nfeltpowmodpr>nfeltpowmodprC<(>I<nf>C<,x,k,>I<pr>C<)>
+
+given an element C<x> in
+I<nf>, an integer C<k> and a prime ideal I<pr> in C<modpr> format
+(see X<nfmodprinit>C<nfmodprinit>), computes C<x^k> modulo the prime ideal I<pr>.
+
+X<element_powmodpr>The library syntax is B<element_powmodpr>C<(>I<nf>C<,x,k,>I<pr>C<)>.
+
+=head2 X<nfeltreduce>nfeltreduceC<(>I<nf>C<,x,>I<ideal>C<)>
+
+given an ideal in
+Hermite normal form and an element C<x> of the number field I<nf>,
+finds an element C<r> in I<nf> such that C<x-r> belongs to the ideal
+and C<r> is small.
+
+X<element_reduce>The library syntax is B<element_reduce>C<(>I<nf>C<,x,>I<ideal>C<)>.
+
+=head2 X<nfeltreducemodpr>nfeltreducemodprC<(>I<nf>C<,x,>I<pr>C<)>
+
+given
+an element C<x> of the number field I<nf> and a prime ideal I<pr> in
+C<modpr> format compute a canonical representative for the class of C<x>
+modulo I<pr>.
+
+X<nfreducemodpr2>The library syntax is B<nfreducemodpr2>C<(>I<nf>C<,x,>I<pr>C<)>.
+
+=head2 X<nfeltval>nfeltvalC<(>I<nf>C<,x,>I<pr>C<)>
+
+given an element C<x> in
+I<nf> and a prime ideal I<pr> in the format output by
+C<idealprimedec>, computes their the valuation at I<pr> of the
+element C<x>. The same result could be obtained using
+C<idealval(>I<nf>C<,x,>I<pr>C<)> (since C<x> would then be converted to a
+principal ideal), but it would be less efficient.
+
+X<element_val>The library syntax is B<element_val>C<(>I<nf>C<,x,>I<pr>C<)>, and the result is a C<long>.
+
+=head2 X<nffactor>nffactorC<(>I<nf>C<,x)>
+
+factorization of the univariate
+polynomial C<x> over the number field I<nf> given by C<nfinit>. C<x>
+has coefficients in I<nf> (i.e.S< >either scalar, polmod, polynomial or
+column vector). The main variable of I<nf> must be of I<lower>
+priority than that of C<x> (in other words, the variable number of I<nf>
+must be I<greater> than that of C<x>). However if the polynomial defining
+the number field occurs explicitly in the coefficients of C<x> (as modulus of
+a C<t_POLMOD>), its main variable must be I<the same> as the main
+variable of C<x>. For example,
+
+ ? nf = nfinit(y^2 + 1);
+ ? nffactor(nf, x^2 + y); \\ OK
+ ? nffactor(nf, x^2 + Mod(y, y^2+1)); \\ OK
+ ? nffactor(nf, x^2 + Mod(z, z^2+1)); \\ WRONG
+
+X<nffactor>The library syntax is B<nffactor>C<(>I<nf>C<,x)>.
+
+=head2 X<nffactormod>nffactormodC<(>I<nf>C<,x,>I<pr>C<)>
+
+factorization of the
+univariate polynomial C<x> modulo the prime ideal I<pr> in the number
+field I<nf>. C<x> can have coefficients in the number field (scalar,
+polmod, polynomial, column vector) or modulo the prime ideal (integermod
+modulo the rational prime under I<pr>, polmod or polynomial with
+integermod coefficients, column vector of integermod). The prime ideal
+I<pr> I<must> be in the format output by C<idealprimedec>. The
+main variable of I<nf> must be of lower priority than that of C<x> (in
+other words the variable number of I<nf> must be greater than that of
+C<x>). However if the coefficients of the number field occur explicitly (as
+polmods) as coefficients of C<x>, the variable of these polmods I<must>
+be the same as the main variable of C<t> (see C<nffactor>).
+
+X<nffactormod>The library syntax is B<nffactormod>C<(>I<nf>C<,x,>I<pr>C<)>.
+
+=head2 X<nfgaloisapply>nfgaloisapplyC<(>I<nf>C<,>I<aut>C<,x)>
+
+I<nf> being a
+number field as output by C<nfinit>, and I<aut> being a X<Galois>Galois
+automorphism of I<nf> expressed either as a polynomial or a polmod
+(such automorphisms being found using for example one of the variants of
+C<nfgaloisconj>), computes the action of the automorphism I<aut> on
+the object C<x> in the number field. C<x> can be an element (scalar, polmod,
+polynomial or column vector) of the number field, an ideal (either given by
+B<Z>C<_K>-generators or by a B<Z>-basis), a prime ideal (given as a 5-element
+row vector) or an idele (given as a 2-element row vector). Because of
+possible confusion with elements and ideals, other vector or matrix
+arguments are forbidden.
+
+X<galoisapply>The library syntax is B<galoisapply>C<(>I<nf>C<,>I<aut>C<,x)>.
+
+=head2 X<nfgaloisconj>nfgaloisconjC<(>I<nf>C<,{>I<flag>C< = 0},{d})>
+
+I<nf> being a
+number field as output by C<nfinit>, computes the conjugates of a root
+C<r> of the non-constant polynomial C<x = >I<nf>C<[1]> expressed as
+polynomials in C<r>. This can be used even if the number field I<nf> is
+not X<Galois>Galois since some conjugates may lie in the field. As a note to
+old-timers of PARI, starting with version 2.0.17 this function works much
+better than in earlier versions.
+
+I<nf> can simply be a polynomial if I<flag>C< ! = 1>.
+
+If no flags or I<flag>C< = 0>, if I<nf> is a number field use a
+combination of flag C<4> and C<1> and the result is always complete,
+else use a combination of flag C<4> and C<2> and the result is subject
+to the restriction of I<flag>C< = 2>, but a warning is issued when it is not
+proven complete.
+
+If I<flag>C< = 1>, use C<nfroots> (require a number field).
+
+If I<flag>C< = 2>, use complex approximations to the roots and an integral
+X<LLL>LLL. The result is not guaranteed to be complete: some
+conjugates may be missing (no warning issued), especially so if the
+corresponding polynomial has a huge index. In that case, increasing
+the default precision may help.
+
+If I<flag>C< = 4>, use Allombert's algorithm and permutation testing. If the
+field is Galois with ``weakly'' super solvable Galois group, return
+the complete list of automorphisms, else only the identity element. If
+present, C<d> is assumed to be a multiple of the least common
+denominator of the conjugates expressed as polynomial in a root of
+I<pol>.
+
+A group G is ``weakly'' super solvable if it contains a super solvable
+normal subgroup C<H> such that C<G = H> , or C<G/H ~ A_4> , or C<G/H ~
+S_4>. Abelian and nilpotent groups are ``weakly'' super solvable. In
+practice, almost all groups of small order are ``weakly'' super solvable, the
+exceptions having order 36(1 exception), 48(2), 56(1), 60(1), 72(5), 75(1),
+80(1), 96(10) and C< E<gt>= 108>.
+
+Hence I<flag>C< = 4> permits to quickly check whether a polynomial of order
+strictly less than C<36> is Galois or not. This method is much faster than
+C<nfroots> and can be applied to polynomials of degree larger than C<50>.
+
+X<galoisconj0>The library syntax is B<galoisconj0>C<(>I<nf>C<,>I<flag>C<,d,>I<prec>C<)>. Also available are
+X<galoisconj>B<galoisconj>C<(>I<nf>C<)> for I<flag>C< = 0>,
+X<galoisconj2>B<galoisconj2>C<(>I<nf>C<,n,>I<prec>C<)> for I<flag>C< = 2> where C<n> is a bound
+on the number of conjugates, and X<galoisconj4>B<galoisconj4>C<(>I<nf>C<,d)>
+corresponding to I<flag>C< = 4>.
+
+=head2 X<nfhilbert>nfhilbertC<(>I<nf>C<,a,b,{>I<pr>C<})>
+
+if I<pr> is omitted,
+compute the global X<Hilbert symbol>Hilbert symbol C<(a,b)> in I<nf>, that is C<1>
+if C<x^2 - a y^2 - b z^2> has a non trivial solution C<(x,y,z)> in I<nf>,
+and C<-1> otherwise. Otherwise compute the local symbol modulo the prime ideal
+I<pr> (as output by C<idealprimedec>).
+
+X<nfhilbert>The library syntax is B<nfhilbert>C<(>I<nf>C<,a,b,>I<pr>C<)>, where an omitted I<pr> is coded
+as C<NULL>.
+
+=head2 X<nfhnf>nfhnfC<(>I<nf>C<,x)>
+
+given a pseudo-matrix C<(A,I)>, finds a
+pseudo-basis in X<Hermite normal form>Hermite normal form of the module it generates.
+
+X<nfhermite>The library syntax is B<nfhermite>C<(>I<nf>C<,x)>.
+
+=head2 X<nfhnfmod>nfhnfmodC<(>I<nf>C<,x,>I<detx>C<)>
+
+given a pseudo-matrix C<(A,I)>
+and an ideal I<detx> which is contained in (read integral multiple of) the
+determinant of C<(A,I)>, finds a pseudo-basis in X<Hermite normal form>Hermite normal form
+of the module generated by C<(A,I)>. This avoids coefficient explosion.
+I<detx> can be computed using the function C<nfdetint>.
+
+X<nfhermitemod>The library syntax is B<nfhermitemod>C<(>I<nf>C<,x,>I<detx>C<)>.
+
+=head2 X<nfinit>nfinitC<(>I<pol>C<,{>I<flag>C< = 0})>
+
+I<pol> being a non-constant,
+preferably monic, irreducible polynomial in B<Z>C<[X]>, initializes a
+I<number field> structure (C<nf>) associated to the field C<K> defined
+by I<pol>. As such, it's a technical object passed as the first argument
+to most C<nf>I<xxx> functions, but it contains some information which
+may be directly useful. Access to this information via I<member
+functions> is prefered since the specific data organization specified below
+may change in the future. Currently, C<nf> is a row vector with 9
+components:
+
+I<nf>C<[1]> contains the polynomial I<pol> (I<nf>C<.pol>).
+
+I<nf>C<[2]> contains C<[r1,r2]> (I<nf>C<.sign>), the number of real
+and complex places of C<K>.
+
+I<nf>C<[3]> contains the discriminant C<d(K)> (I<nf>C<.disc>) of C<K>.
+
+I<nf>C<[4]> contains the index of I<nf>C<[1]>,
+i.e.S< >C<[>B<Z>C<_K : >B<Z>C<[>F<theta>C<]]>, where F<theta> is any root of I<nf>C<[1]>.
+
+I<nf>C<[5]> is a vector containing 7 matrices C<M>, C<MC>, C<T2>, C<T>,
+C<MD>, C<TI>, C<MDI> useful for certain computations in the number field C<K>.
+
+S< >S< >B<*> C<M> is the C<(r1+r2) x n> matrix whose columns represent
+the numerical values of the conjugates of the elements of the integral
+basis.
+
+S< >S< >B<*> C<MC> is essentially the conjugate of the transpose of C<M>,
+except that the last C<r2> columns are also multiplied by 2.
+
+S< >S< >B<*> C<T2> is an C<n x n> matrix equal to the real part of the
+product C<MC.M> (which is a real positive definite symmetric matrix), the
+so-called C<T_2>-matrix (I<nf>C<.t2>).
+
+S< >S< >B<*> C<T> is the C<n x n> matrix whose coefficients are
+C<Tr(>F<omega>C<_i>F<omega>C<_j)> where the F<omega>C<_i> are the elements of the
+integral basis. Note that C<T = \overline{MC}.M> and in particular that
+C<T = T_2> if the field is totally real (in practice C<T_2> will have real
+approximate entries and C<T> will have integer entries). Note also that
+ F<det> C<(T)> is equal to the discriminant of the field C<K>.
+
+S< >S< >B<*> The columns of C<MD> (I<nf>C<.diff>) express a B<Z>-basis
+of the different of C<K> on the integral basis.
+
+S< >S< >B<*> C<TI> is equal to C<d(K)T^{-1}>, which has integral
+coefficients. Note that, understood as as ideal, the matrix C<T^{-1}>
+generates the codifferent ideal.
+
+S< >S< >B<*> Finally, C<MDI> is a two-element representation (for faster
+ideal product) of C<d(K)> times the codifferent ideal
+(I<nf>C<.disc*>I<nf>C<.codiff>, which is an integral ideal). C<MDI>
+is only used in X<idealinv>C<idealinv>.
+
+I<nf>C<[6]> is the vector containing the C<r1+r2> roots
+(I<nf>C<.roots>) of I<nf>C<[1]> corresponding to the C<r1+r2>
+embeddings of the number field into B<C> (the first C<r1> components are real,
+the next C<r2> have positive imaginary part).
+
+I<nf>C<[7]> is an integral basis in Hermite normal form for B<Z>C<_K>
+(I<nf>C<.zk>) expressed on the powers ofS< >F<theta>.
+
+I<nf>C<[8]> is the C<n x n> integral matrix expressing the power
+basis in terms of the integral basis, and finally
+
+I<nf>C<[9]> is the C<n x n^2> matrix giving the multiplication table
+of the integral basis.
+
+If a non monic polynomial is input, C<nfinit> will transform it into a
+monic one, then reduce it (see I<flag>C< = 3>). It is allowed, though not very
+useful given the existence of X<nfnewprec>B<nfnewprec>, to input a C<nf> or a
+C<bnf> instead of a polynomial.
+
+The special input format C<[x,B]> is also accepted where C<x> is a polynomial
+as above and C<B> is the integer basis, as computed by X<nfbasis>C<nfbasis>. This can
+be useful since C<nfinit> uses the round 4 algorithm by default, which can
+be very slow in pathological cases where round 2 (C<nfbasis(x,2)>) would
+succeed very quickly.
+
+If I<flag>C< = 2>: I<pol> is changed into another polynomial C<P> defining the same
+number field, which is as simple as can easily be found using the
+C<polred> algorithm, and all the subsequent computations are done using
+this new polynomial. In particular, the first component of the result is the
+modified polynomial.
+
+If I<flag>C< = 3>, does a C<polred> as in case 2, but outputs
+C<[>I<nf>C<,Mod(a,P)]>, where I<nf> is as before and
+C<Mod(a,P) = Mod(x,>I<pol>C<)> gives the change of
+variables. This is implicit when I<pol> is not monic: first a linear change
+of variables is performed, to get a monic polynomial, then a C<polred>
+reduction.
+
+If I<flag>C< = 4>, as C<2> but uses a partial C<polred>.
+
+If I<flag>C< = 5>, as C<3> using a partial C<polred>.
+
+X<nfinit0>The library syntax is B<nfinit0>C<(x,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<nfisideal>nfisidealC<(>I<nf>C<,x)>
+
+returns 1 if C<x> is an ideal in
+the number field I<nf>, 0 otherwise.
+
+X<isideal>The library syntax is B<isideal>C<(x)>.
+
+=head2 X<nfisincl>nfisinclC<(x,y)>
+
+tests whether the number field C<K> defined
+by the polynomial C<x> is conjugate to a subfield of the field C<L> defined
+by C<y> (where C<x> and C<y> must be in B<Q>C<[X]>). If they are not, the output
+is the number 0. If they are, the output is a vector of polynomials, each
+polynomial C<a> representing an embedding of C<K> into C<L>, i.e.S< >being such
+that C<y | x o a>.
+
+If C<y> is a number field (I<nf>), a much faster algorithm is used
+(factoring C<x> over C<y> using X<nffactor>C<nffactor>). Before version 2.0.14, this
+wasn't guaranteed to return all the embeddings, hence was triggered by a
+special flag. This is no more the case.
+
+X<nfisincl>The library syntax is B<nfisincl>C<(x,y,>I<flag>C<)>.
+
+=head2 X<nfisisom>nfisisomC<(x,y)>
+
+as X<nfisincl>C<nfisincl>, but tests
+for isomorphism. If either C<x> or C<y> is a number field, a much faster
+algorithm will be used.
+
+X<nfisisom>The library syntax is B<nfisisom>C<(x,y,>I<flag>C<)>.
+
+=head2 X<nfnewprec>nfnewprecC<(>I<nf>C<)>
+
+transforms the number field I<nf>
+into the corresponding data using current (usually larger) precision. This
+function works as expected if I<nf> is in fact a I<bnf> (update
+I<bnf> to current precision) but may be quite slow (many generators of
+principal ideals have to be computed).
+
+X<nfnewprec>The library syntax is B<nfnewprec>C<(>I<nf>C<,>I<prec>C<)>.
+
+=head2 X<nfkermodpr>nfkermodprC<(>I<nf>C<,a,>I<pr>C<)>
+
+kernel of the matrix C<a> in
+B<Z>C<_K/>I<pr>, where I<pr> is in B<modpr> format
+(see C<nfmodprinit>).
+
+X<nfkermodpr>The library syntax is B<nfkermodpr>C<(>I<nf>C<,a,>I<pr>C<)>.
+
+=head2 X<nfmodprinit>nfmodprinitC<(>I<nf>C<,>I<pr>C<)>
+
+transforms the prime ideal
+I<pr> into X<modpr>C<modpr> format necessary for all operations modulo
+I<pr> in the number field I<nf>. Returns a two-component vector
+C<[P,a]>, where C<P> is the X<Hermite normal form>Hermite normal form of I<pr>, and C<a> is
+an integral element congruent to C<1> modulo I<pr>, and congruent to C<0>
+modulo C<p / pr^e>. Here C<p = >B<Z> F<cap> I<pr> and C<e>
+is the absolute ramification index.X<Label se:nfmodprinit>
+
+X<nfmodprinit>The library syntax is B<nfmodprinit>C<(>I<nf>C<,>I<pr>C<)>.
+
+=head2 X<nfsubfields>nfsubfieldsC<(>I<nf>C<,{d = 0})>
+
+finds all subfields of degree C<d>
+of the number field I<nf> (all subfields if C<d> is null or omitted).
+The result is a vector of subfields, each being given by C<[g,h]>, where C<g> is an
+absolute equation and C<h> expresses one of the roots of C<g> in terms of the
+root C<x> of the polynomial defining I<nf>. This is a crude
+implementation by M.S< >Olivier of an algorithm due to J.S< >KlE<uuml>ners.
+
+X<subfields>The library syntax is B<subfields>C<(>I<nf>C<,d)>.
+
+=head2 X<nfroots>nfrootsC<(>I<nf>C<,x)>
+
+roots of the polynomial C<x> in the number
+field I<nf> given by C<nfinit> without multiplicity. C<x> has
+coefficients in the number field (scalar, polmod, polynomial, column
+vector). The main variable of I<nf> must be of lower priority than that
+of C<x> (in other words the variable number of I<nf> must be greater than
+that of C<x>). However if the coefficients of the number field occur
+explicitly (as polmods) as coefficients of C<x>, the variable of these
+polmods I<must> be the same as the main variable of C<t> (see
+C<nffactor>).
+
+X<nfroots>The library syntax is B<nfroots>C<(>I<nf>C<,x)>.
+
+=head2 X<nfrootsof1>nfrootsof1C<(>I<nf>C<)>
+
+computes the number of roots of unity
+C<w> and a primitive C<w>-th root of unity (expressed on the integral basis)
+belonging to the number field I<nf>. The result is a two-component
+vector C<[w,z]> where C<z> is a column vector expressing a primitive C<w>-th
+root of unity on the integral basis I<nf>C<.zk>.
+
+X<rootsof1>The library syntax is B<rootsof1>C<(>I<nf>C<)>.
+
+=head2 X<nfsnf>nfsnfC<(>I<nf>C<,x)>
+
+given a torsion module C<x> as a 3-component
+row
+vector C<[A,I,J]> where C<A> is a square invertible C<n x n> matrix, C<I> and
+C<J> are two ideal lists, outputs an ideal list C<d_1,...,d_n> which is the
+X<Smith normal form>Smith normal form of C<x>. In other words, C<x> is isomorphic to
+B<Z>C<_K/d_1> F<oplus> C<...> F<oplus> B<Z>C<_K/d_n> and C<d_i> divides C<d_{i-1}> for C<i E<gt>= 2>.
+The link between C<x> and C<[A,I,J]> is as follows: if C<e_i> is the canonical
+basis of C<K^n>, C<I = [b_1,...,b_n]> and C<J = [a_1,...,a_n]>, then C<x> is
+isomorphic to
+
+S< >C< (b_1e_1> F<oplus> C<...> F<oplus> C< b_ne_n) / (a_1A_1> F<oplus> C<...> F<oplus> C< a_nA_n)
+ , >
+
+where the C<A_j> are the columns of the matrix C<A>. Note that every finitely
+generated torsion module can be given in this way, and even with C<b_i = Z_K>
+for all C<i>.
+
+X<nfsmith>The library syntax is B<nfsmith>C<(>I<nf>C<,x)>.
+
+=head2 X<nfsolvemodpr>nfsolvemodprC<(>I<nf>C<,a,b,>I<pr>C<)>
+
+solution of C<a.x = b>
+in B<Z>C<_K/>I<pr>, where C<a> is a matrix and C<b> a column vector, and where
+I<pr> is in B<modpr> format (see C<nfmodprinit>).
+
+X<nfsolvemodpr>The library syntax is B<nfsolvemodpr>C<(>I<nf>C<,a,b,>I<pr>C<)>.
+
+=head2 X<polcompositum>polcompositumC<(x,y,{>I<flag>C< = 0})>
+
+C<x> and C<y> being polynomials
+in B<Z>C<[X]> in the same variable, outputs a vector giving the list of all
+possible composita of the number fields defined by C<x> and C<y>, if C<x> and
+C<y> are irreducible, or of the corresponding E<eacute>tale algebras, if they are
+only squarefree. Returns an error if one of the polynomials is not
+squarefree. When one of the polynomials is irreducible (say C<x>), it is
+often I<much> faster to use C<nffactor(nfinit(x), y)> then
+X<rnfequation>C<rnfequation>.
+
+If I<flag>C< = 1>, outputs a vector of 4-component vectors C<[z,a,b,k]>, where C<z>
+ranges through the list of all possible compositums as above, and C<a>
+(resp. C<b>) expresses the root of C<x> (resp. C<y>) as a polmod in a root of
+C<z>, and C<k> is a small integer k such that C<a+kb> is the chosen root of
+C<z>.
+
+The compositum will quite often be defined by a complicated polynomial,
+which it is advisable to reduce before further work. Here is a simple
+example involving the field B<Q>C<(>F<zeta>C<_5, 5^{1/5})>:
+
+ ? z = polcompositum(x^5 - 5, polcyclo(5), 1)[1];
+ ? pol = z[1] \\ pol defines the compositum
+ %2 = x^20 + 5*x^19 + 15*x^18 + 35*x^17 + 70*x^16 + 141*x^15 + 260*x^14 \
+ + 355*x^13 + 95*x^12 - 1460*x^11 - 3279*x^10 - 3660*x^9 - 2005*x^8 \
+ + 705*x^7 + 9210*x^6 + 13506*x^5 + 7145*x^4 - 2740*x^3 + 1040*x^2 \
+ - 320*x + 256
+ ? a = z[2]; a^5 - 5 \\ a is a fifth root of 5
+ %3 = 0
+ ? z = polredabs(pol, 1); \\ look for a simpler polynomial
+ ? pol = z[1]
+ %5 = x^20 + 25*x^10 + 5
+ ? a = subst(a.pol, x, z[2]) \\ a in the new coordinates
+ %6 = Mod(-5/22*x^19 + 1/22*x^14 - 123/22*x^9 + 9/11*x^4, x^20 + 25*x^10 + 5)
+
+X<polcompositum0>The library syntax is B<polcompositum0>C<(x,y,>I<flag>C<)>.
+
+=head2 X<polgalois>polgaloisC<(x)>
+
+X<Galois>Galois group of the non-constant polynomial
+C<x belongs to >B<Q>C<[X]>. In the present version B<2.2.0>, C<x> must be irreducible and
+the degree of C<x> must be less than or equal to 7. On certain versions for
+which the data file of Galois resolvents has been installed (available
+in the Unix distribution as a separate package), degrees 8, 9, 10 and 11
+are also implemented.
+
+The output is a 3-component vector C<[n,s,k]> with the following meaning: C<n>
+is the cardinality of the group, C<s> is its signature (C<s = 1> if the group is
+a subgroup of the alternating group C<A_n>, C<s = -1> otherwise), and C<k> is the
+number of the group corresponding to a given pair C<(n,s)> (C<k = 1> except in 2
+cases). Specifically, the groups are coded as follows, using standard
+notations (see GTM 138, quoted at the beginning of this section; see also
+``The transitive groups of degree up to eleven'', by G.S< >Butler and J.S< >McKay
+in Communications in Algebra, vol.S< >11, 1983, pp.S< >863--911):
+
+In degree 1: C<S_1 = [1,-1,1]>.
+
+In degree 2: C<S_2 = [2,-1,1]>.
+
+In degree 3: C<A_3 = C_3 = [3,1,1]>, C<S_3 = [6,-1,1]>.
+
+In degree 4: C<C_4 = [4,-1,1]>, C<V_4 = [4,1,1]>, C<D_4 = [8,-1,1]>, C<A_4 = [12,1,1]>,
+C<S_4 = [24,-1,1]>.
+
+In degree 5: C<C_5 = [5,1,1]>, C<D_5 = [10,1,1]>, C<M_{20} = [20,-1,1]>,
+C<A_5 = [60,1,1]>, C<S_5 = [120,-1,1]>.
+
+In degree 6: C<C_6 = [6,-1,1]>, C<S_3 = [6,-1,2]>, C<D_6 = [12,-1,1]>, C<A_4 = [12,1,1]>,
+C<G_{18} = [18,-1,1]>, C<S_4^ -= [24,-1,1]>, C<A_4 x C_2 = [24,-1,2]>,
+C<S_4^ += [24,1,1]>, C<G_{36}^ -= [36,-1,1]>, C<G_{36}^ += [36,1,1]>,
+C<S_4 x C_2 = [48,-1,1]>, C<A_5 = PSL_2(5) = [60,1,1]>, C<G_{72} = [72,-1,1]>,
+C<S_5 = PGL_2(5) = [120,-1,1]>, C<A_6 = [360,1,1]>, C<S_6 = [720,-1,1]>.
+
+In degree 7: C<C_7 = [7,1,1]>, C<D_7 = [14,-1,1]>, C<M_{21} = [21,1,1]>,
+C<M_{42} = [42,-1,1]>, C<PSL_2(7) = PSL_3(2) = [168,1,1]>, C<A_7 = [2520,1,1]>,
+C<S_7 = [5040,-1,1]>.
+
+The method used is that of resolvent polynomials and is sensitive to the
+current precision. The precision is updated internally but, in very rare
+cases, a wrong result may be returned if the initial precision was not
+sufficient.
+
+X<galois>The library syntax is B<galois>C<(x,>I<prec>C<)>.
+
+=head2 X<polred>polredC<(x,{>I<flag>C< = 0},{p})>
+
+finds polynomials with reasonably
+small coefficients defining subfields of the number field defined by C<x>.
+One of the polynomials always defines B<Q> (hence is equal to C<x-1>),
+and another always defines the same number field as C<x> if C<x> is irreducible.
+All C<x> accepted by X<nfinit>C<nfinit> are also allowed here (e.g. non-monic
+polynomials, C<nf>, C<bnf>, C<[x,Z_K_basis]>).
+
+The following binary digits of I<flag> are significant:
+
+1: does a partial reduction only. This means that only a suborder of the
+maximal order may be used.
+
+2: gives also elements. The result is a two-column matrix, the first column
+giving the elements defining these subfields, the second giving the
+corresponding minimal polynomials.
+
+If C<p> is given, it is assumed that it is the two-column matrix of the
+factorization of the discriminant of the polynomial C<x>.
+
+X<polred0>The library syntax is B<polred0>C<(x,>I<flag>C<,p,>I<prec>C<)>, where an omitted C<p> is
+coded by C<gzero>. Also available are X<polred>B<polred>C<(x,>I<prec>C<)> and
+X<factoredpolred>B<factoredpolred>C<(x,p,>I<prec>C<)>, both corresponding to I<flag>C< = 0>.
+
+=head2 X<polredabs>polredabsC<(x,{>I<flag>C< = 0})>
+
+finds one of the polynomial defining
+the same number field as the one defined by C<x>, and such that the sum of the
+squares of the modulus of the roots (i.e.S< >the C<T_2>-norm) is minimal.
+All C<x> accepted by X<nfinit>C<nfinit> are also allowed here (e.g. non-monic
+polynomials, C<nf>, C<bnf>, C<[x,Z_K_basis]>).
+
+The binary digits of I<flag> mean
+
+1: outputs a two-component row vector C<[P,a]>, where C<P> is the default
+output and C<a> is an element expressed on a root of the polynomial C<P>,
+whose minimal polynomial is equal to C<x>.
+
+4: gives I<all> polynomials of minimal C<T_2> norm (of the two polynomials
+C<P(x)> and C<P(-x)>, only one is given).
+
+X<polredabs0>The library syntax is B<polredabs0>C<(x,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<polredord>polredordC<(x)>
+
+finds polynomials with reasonably small
+coefficients and of the same degree as that of C<x> defining suborders of the
+order defined by C<x>. One of the polynomials always defines B<Q> (hence
+is equal to C<(x-1)^n>, where C<n> is the degree), and another always defines
+the same order as C<x> if C<x> is irreducible.
+
+X<ordred>The library syntax is B<ordred>C<(x)>.
+
+=head2 X<poltschirnhaus>poltschirnhausC<(x)>
+
+applies a random Tschirnhausen
+transformation to the polynomial C<x>, which is assumed to be non-constant
+and separable, so as to obtain a new equation for the E<eacute>tale algebra
+defined by C<x>. This is for instance useful when computing resolvents,
+hence is used by the C<polgalois> function.
+
+X<tschirnhaus>The library syntax is B<tschirnhaus>C<(x)>.
+
+=head2 X<rnfalgtobasis>rnfalgtobasisC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<L> expressed as a polynomial or polmod with polmod coefficients, expresses
+C<x> on the relative integral basis.
+
+X<rnfalgtobasis>The library syntax is B<rnfalgtobasis>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfbasis>rnfbasisC<(>I<bnf>C<,x)>
+
+given a big number field I<bnf> as
+output by C<bnfinit>, and either a polynomial C<x> with coefficients in
+I<bnf> defining a relative extension C<L> of I<bnf>, or a
+pseudo-basis C<x> of such an extension, gives either a true I<bnf>-basis
+of C<L> if it exists, or an C<n+1>-element generating set of C<L> if not, where
+C<n> is the rank of C<L> over I<bnf>.
+
+X<rnfbasis>The library syntax is B<rnfbasis>C<(>I<bnf>C<,x)>.
+
+=head2 X<rnfbasistoalg>rnfbasistoalgC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<L> expressed on the relative integral basis, computes the representation of
+C<x> as a polmod with polmods coefficients.
+
+X<rnfbasistoalg>The library syntax is B<rnfbasistoalg>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfcharpoly>rnfcharpolyC<(>I<nf>C<,T,a,{v = x})>
+
+characteristic polynomial of
+C<a> over I<nf>, where C<a> belongs to the algebra defined by C<T> over
+I<nf>, i.e.S< >I<nf>C<[X]/(T)>. Returns a polynomial in variable C<v>
+(C<x> by default).
+
+X<rnfcharpoly>The library syntax is B<rnfcharpoly>C<(>I<nf>C<,T,a,v)>, where C<v> is a variable number.
+
+=head2 X<rnfconductor>rnfconductorC<(>I<bnf>C<,>I<pol>C<)>
+
+I<bnf> being a big number
+field as output by C<bnfinit>, and I<pol> a relative polynomial defining
+an X<Abelian extension>Abelian extension, computes the class field theory conductor of this
+Abelian extension. The result is a 3-component vector
+C<[>I<conductor>C<,>I<rayclgp>C<,>I<subgroup>C<]>, where I<conductor> is
+the conductor of the extension given as a 2-component row vector
+C<[f_0,f_ oo ]>, I<rayclgp> is the full ray class group corresponding to
+the conductor given as a 3-component vector [h,cyc,gen] as usual for a group,
+and I<subgroup> is a matrix in HNF defining the subgroup of the ray class
+group on the given generators gen.
+
+X<rnfconductor>The library syntax is B<rnfconductor>C<(>I<rnf>C<,>I<pol>C<,>I<prec>C<)>.
+
+=head2 X<rnfdedekind>rnfdedekindC<(>I<nf>C<,>I<pol>C<,>I<pr>C<)>
+
+given a number field
+I<nf> as output by C<nfinit> and a polynomial I<pol> with
+coefficients in I<nf> defining a relative extension C<L> of I<nf>,
+evaluates the relative X<Dedekind>Dedekind criterion over the order defined by a
+root of I<pol> for the prime ideal I<pr> and outputs a 3-component
+vector as the result. The first component is a flag equal to 1 if the
+enlarged order could be proven to be I<pr>-maximal and to 0 otherwise (it
+may be maximal in the latter case if I<pr> is ramified in C<L>), the second
+component is a pseudo-basis of the enlarged order and the third component is
+the valuation at I<pr> of the order discriminant.
+
+X<rnfdedekind>The library syntax is B<rnfdedekind>C<(>I<nf>C<,>I<pol>C<,>I<pr>C<)>.
+
+=head2 X<rnfdet>rnfdetC<(>I<nf>C<,M)>
+
+given a pseudomatrix C<M> over the maximal
+order of I<nf>, computes its pseudodeterminant.
+
+X<rnfdet>The library syntax is B<rnfdet>C<(>I<nf>C<,M)>.
+
+=head2 X<rnfdisc>rnfdiscC<(>I<nf>C<,>I<pol>C<)>
+
+given a number field I<nf> as
+output by C<nfinit> and a polynomial I<pol> with coefficients in
+I<nf> defining a relative extension C<L> of I<nf>, computes
+the relative
+discriminant of C<L>. This is a two-element row vector C<[D,d]>, where C<D> is
+the relative ideal discriminant and C<d> is the relative discriminant
+considered as an element of I<nf>C<^*/{>I<nf>C<^*}^2>. The main variable of
+I<nf> I<must> be of lower priority than that of I<pol>.
+
+Note: As usual, I<nf> can be a I<bnf> as output by C<nfinit>.
+
+X<rnfdiscf>The library syntax is B<rnfdiscf>C<(>I<bnf>C<,>I<pol>C<)>.
+
+=head2 X<rnfeltabstorel>rnfeltabstorelC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being an element of C<L>
+expressed as a polynomial modulo the absolute equation I<rnf>C<[11][1]>,
+computes C<x> as an element of the relative extension C<L/K> as a polmod with
+polmod coefficients.
+
+X<rnfelementabstorel>The library syntax is B<rnfelementabstorel>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfeltdown>rnfeltdownC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<L> expressed as a polynomial or polmod with polmod coefficients, computes
+C<x> as an element of C<K> as a polmod, assuming C<x> is in C<K> (otherwise an
+error will occur). If C<x> is given on the relative integral basis, apply
+C<rnfbasistoalg> first, otherwise PARI will believe you are dealing with a
+vector.
+
+X<rnfelementdown>The library syntax is B<rnfelementdown>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfeltreltoabs>rnfeltreltoabsC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative
+number field extension C<L/K> as output by C<rnfinit> and C<x> being an
+element of C<L> expressed as a polynomial or polmod with polmod
+coefficients, computes C<x> as an element of the absolute extension C<L/>B<Q> as
+a polynomial modulo the absolute equation I<rnf>C<[11][1]>. If C<x> is
+given on the relative integral basis, apply C<rnfbasistoalg> first,
+otherwise PARI will believe you are dealing with a vector.
+
+X<rnfelementreltoabs>The library syntax is B<rnfelementreltoabs>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfeltup>rnfeltupC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<K> expressed as a polynomial or polmod, computes C<x> as an element of the
+absolute extension C<L/>B<Q> as a polynomial modulo the absolute equation
+I<rnf>C<[11][1]>. Note that it is unnecessary to compute C<x> as an
+element of the relative extension C<L/K> (its expression would be identical to
+itself). If C<x> is given on the integral basis of C<K>, apply
+C<nfbasistoalg> first, otherwise PARI will believe you are dealing with a
+vector.
+
+X<rnfelementup>The library syntax is B<rnfelementup>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfequation>rnfequationC<(>I<nf>C<,>I<pol>C<,{>I<flag>C< = 0})>
+
+given a number field
+I<nf> as output by C<nfinit> (or simply a polynomial) and a
+polynomial I<pol> with coefficients in I<nf> defining a relative
+extension C<L> of I<nf>, computes the absolute equation of C<L> over
+B<Q>.
+
+If I<flag> is non-zero, outputs a 3-component row vector C<[z,a,k]>, where
+C<z> is the absolute equation of C<L> over B<Q>, as in the default behaviour,
+C<a> expresses as an element of C<L> a root F<alpha> of the polynomial
+defining the base field I<nf>, and C<k> is a small integer such that
+F<theta>C< = >F<beta>C<+k>F<alpha> where F<theta> is a root of C<z> and F<beta> a root
+of I<pol>.
+
+The main variable of I<nf> I<must> be of lower priority than that
+of I<pol>. Note that for efficiency, this does not check whether the
+relative equation is irreducible over I<nf>, but only if it is
+squarefree. If it is reducible but squarefree, the result will be the
+absolute equation of the E<eacute>tale algebra defined by I<pol>. If I<pol>
+is not squarefree, an error message will be issued.
+
+X<rnfequation0>The library syntax is B<rnfequation0>C<(>I<nf>C<,>I<pol>C<,>I<flag>C<)>.
+
+=head2 X<rnfhnfbasis>rnfhnfbasisC<(>I<bnf>C<,x)>
+
+given a big number field I<bnf>
+as output by C<bnfinit>, and either a polynomial C<x> with coefficients in
+I<bnf> defining a relative extension C<L> of I<bnf>, or a
+pseudo-basis C<x> of such an extension, gives either a true I<bnf>-basis
+of C<L> in upper triangular Hermite normal form, if it exists,
+zero otherwise.
+
+X<rnfhermitebasis>The library syntax is B<rnfhermitebasis>C<(>I<nf>C<,x)>.
+
+=head2 X<rnfidealabstorel>rnfidealabstorelC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative
+number field extension C<L/K> as output by C<rnfinit> and C<x> being an
+ideal of the absolute extension C<L/>B<Q> given in HNFX<Hermite normal form>
+(if it is not, apply C<idealhnf> first), computes the relative pseudomatrix
+in HNF giving the ideal C<x> considered as an ideal of the relative extension
+C<L/K>.
+
+X<rnfidealabstorel>The library syntax is B<rnfidealabstorel>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfidealdown>rnfidealdownC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an ideal of
+the absolute extension C<L/>B<Q> given in HNF (if it is not, apply
+C<idealhnf> first), gives the ideal of C<K> below C<x>, i.e.S< >the
+intersection of C<x> with C<K>. Note that, if C<x> is given as a relative ideal
+(i.e.S< >a pseudomatrix in HNF), then it is not necessary to use this function
+since the result is simply the first ideal of the ideal list of the
+pseudomatrix.
+
+X<rnfidealdown>The library syntax is B<rnfidealdown>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfidealhnf>rnfidealhnfC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being a relative
+ideal (which can be, as in the absolute case, of many different types,
+including of course elements), computes as a 2-component row vector the
+relative Hermite normal form of C<x>, the first component being the HNF matrix
+(with entries on the integral basis), and the second component the ideals.
+
+X<rnfidealhermite>The library syntax is B<rnfidealhermite>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfidealmul>rnfidealmulC<(>I<rnf>C<,x,y)>
+
+I<rnf> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> and C<y> being ideals
+of the relative extension C<L/K> given by pseudo-matrices, outputs the ideal
+product, again as a relative ideal.
+
+X<rnfidealmul>The library syntax is B<rnfidealmul>C<(>I<rnf>C<,x,y)>.
+
+=head2 X<rnfidealnormabs>rnfidealnormabsC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative
+number field extension C<L/K> as output by C<rnfinit> and C<x> being a
+relative ideal (which can be, as in the absolute case, of many different
+types, including of course elements), computes the norm of the ideal C<x>
+considered as an ideal of the absolute extension C<L/>B<Q>. This is identical to
+C<idealnorm(rnfidealnormrel(>I<rnf>C<,x))>, only faster.
+
+X<rnfidealnormabs>The library syntax is B<rnfidealnormabs>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfidealnormrel>rnfidealnormrelC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being a relative ideal
+(which can be, as in the absolute case, of many different types, including
+of course elements), computes the relative norm of C<x> as a ideal of C<K>
+in HNF.
+
+X<rnfidealnormrel>The library syntax is B<rnfidealnormrel>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfidealreltoabs>rnfidealreltoabsC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being a relative ideal
+(which can be, as in the absolute case, of many different types, including
+of course elements), computes the HNF matrix of the ideal C<x> considered
+as an ideal of the absolute extension C<L/>B<Q>.
+
+X<rnfidealreltoabs>The library syntax is B<rnfidealreltoabs>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfidealtwoelt>rnfidealtwoeltC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being an ideal of the
+relative extension C<L/K> given by a pseudo-matrix, gives a vector of
+two generators of C<x> over B<Z>C<_L> expressed as polmods with polmod
+coefficients.
+
+X<rnfidealtwoelement>The library syntax is B<rnfidealtwoelement>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfidealup>rnfidealupC<(>I<rnf>C<,x)>
+
+I<rnf> being a relative number
+field
+extension C<L/K> as output by C<rnfinit> and C<x> being an ideal of
+C<K>, gives the ideal C<x>B<Z>C<_L> as an absolute ideal of C<L/>B<Q> (the relative
+ideal representation is trivial: the matrix is the identity matrix, and
+the ideal list starts with C<x>, all the other ideals being B<Z>C<_K>).
+
+X<rnfidealup>The library syntax is B<rnfidealup>C<(>I<rnf>C<,x)>.
+
+=head2 X<rnfinit>rnfinitC<(>I<nf>C<,>I<pol>C<)>
+
+I<nf> being a number field in
+C<nfinit>
+format considered as base field, and I<pol> a polynomial defining a relative
+extension over I<nf>, this computes all the necessary data to work in the
+relative extension. The main variable of I<pol> must be of higher priority
+(i.e.S< >lower number) than that of I<nf>, and the coefficients of I<pol>
+must be in I<nf>.
+
+The result is an 11-component row vector as follows (most of the components
+are technical), the numbering being very close to that of C<nfinit>. In
+the following description, we let C<K> be the base field defined by
+I<nf>, C<m> the degree of the base field, C<n> the relative degree, C<L>
+the large field (of relative degree C<n> or absolute degree C<nm>), C<r_1> and
+C<r_2> the number of real and complex places of C<K>.
+
+I<rnf>C<[1]> contains the relative polynomial I<pol>.
+
+I<rnf>C<[2]> is a row vector with C<r_1+r_2> entries, entry C<j> being
+a 2-component row vector C<[r_{j,1},r_{j,2}]> where C<r_{j,1}> and C<r_{j,2}>
+are the number of real and complex places of C<L> above the C<j>-th place of
+C<K> so that C<r_{j,1} = 0> and C<r_{j,2} = n> if C<j> is a complex place, while if
+C<j> is a real place we have C<r_{j,1}+2r_{j,2} = n>.
+
+I<rnf>C<[3]> is a two-component row vector C<[>B<d>C<(L/K),s]> where B<d>C<(L/K)>
+is the relative ideal discriminant of C<L/K> and C<s> is the discriminant of
+C<L/K> viewed as an element of C<K^*/(K^*)^2>, in other words it is the output
+of C<rnfdisc>.
+
+I<rnf>C<[4]> is the ideal index B<f>, i.e.S< >such that
+C<d(pol)>B<Z>C<_K = >B<f>C<^2>B<d>C<(L/K)>.
+
+I<rnf>C<[5]> is a vector I<vm> with 7 entries useful for certain
+computations in the relative extension C<L/K>. I<vm>C<[1]> is a vector of
+C<r_1+r_2> matrices, the C<j>-th matrix being an C<(r_{1,j}+r_{2,j}) x n>
+matrix C<M_j> representing the numerical values of the conjugates of the
+C<j>-th embedding of the elements of the integral basis, where C<r_{i,j}> is as
+in I<rnf>C<[2]>. I<vm>C<[2]> is a vector of C<r_1+r_2> matrices, the
+C<j>-th matrix C<MC_j> being essentially the conjugate of the matrix C<M_j>
+except that the last C<r_{2,j}> columns are also multiplied by 2.
+I<vm>C<[3]> is a vector of C<r_1+r_2> matrices C<T2_j>, where C<T2_j> is
+an C<n x n> matrix equal to the real part of the product C<MC_j.M_j>
+(which is a real positive definite matrix). I<vm>C<[4]> is the C<n x n>
+matrix C<T> whose entries are the relative traces of F<omega>C<_i>F<omega>C<_j>
+expressed as polmods in I<nf>, where the F<omega>C<_i> are the elements
+of the relative integral basis. Note that the C<j>-th embedding of C<T> is
+equal to C<\overline{MC_j}.M_j>, and in particular will be equal to
+C<T2_j> if C<r_{2,j} = 0>. Note also that the relative ideal discriminant of
+C<L/K> is equal to F<det> C<(T)> times the square of the product of the ideals
+in the relative pseudo-basis (in I<rnf>C<[7][2]>). The last 3 entries
+I<vm>C<[5]>, I<vm>C<[6]> and I<vm>C<[7]> are linked to the different
+as in C<nfinit>, but have not yet been implemented.
+
+I<rnf>C<[6]> is a row vector with C<r_1+r_2> entries, the C<j>-th entry
+being the
+row vector with C<r_{1,j}+r_{2,j}> entries of the roots of the C<j>-th embedding
+of the relative polynomial I<pol>.
+
+I<rnf>C<[7]> is a two-component row vector, where the first component is
+the relative integral pseudo basis expressed as polynomials (in the variable of
+C<pol>) with polmod coefficients in I<nf>, and the second component is the
+ideal list of the pseudobasis in HNF.
+
+I<rnf>C<[8]> is the inverse matrix of the integral basis matrix, with
+coefficients polmods in I<nf>.
+
+I<rnf>C<[9]> may be the multiplication table of the integral basis, but
+is not implemented at present.
+
+I<rnf>C<[10]> is I<nf>.
+
+I<rnf>C<[11]> is a vector I<vabs> with 5 entries describing the
+I<absolute> extension C<L/>B<Q>. I<vabs>C<[1]> is an absolute equation.
+I<vabs>C<[2]> expresses the generator F<alpha> of the number field
+I<nf> as a polynomial modulo the absolute equation I<vabs>C<[1]>.
+I<vabs>C<[3]> is a small integer C<k> such that, if F<beta> is an abstract
+root of I<pol> and F<alpha> the generator of I<nf>, the generator
+whose root is I<vabs> will be F<beta>C< + k >F<alpha>. Note that one must
+be very careful if C<k ! = 0> when dealing simultaneously with absolute and
+relative quantities since the generator chosen for the absolute extension
+is not the same as for the relative one. If this happens, one can of course
+go on working, but we strongly advise to change the relative polynomial so
+that its root will be F<beta>C< + k >F<alpha>. Typically, the GP instruction would
+be
+
+C<pol = subst(pol, x, x - k*Mod(y,>I<nf>C<.pol))>
+
+Finally, I<vabs>C<[4]> is the absolute integral basis of C<L> expressed in HNF
+(hence as would be output by C<nfinit(vabs[1])>), and I<vabs>C<[5]> the
+inverse matrix of the integral basis, allowing to go from polmod to integral
+basis representation.
+
+X<rnfinitalg>The library syntax is B<rnfinitalg>C<(>I<nf>C<,>I<pol>C<,>I<prec>C<)>.
+
+=head2 X<rnfisfree>rnfisfreeC<(>I<bnf>C<,x)>
+
+given a big number field I<bnf> as
+output by C<bnfinit>, and either a polynomial C<x> with coefficients in
+I<bnf> defining a relative extension C<L> of I<bnf>, or a
+pseudo-basis C<x> of such an extension, returns true (1) if C<L/>I<bnf> is
+free, false (0) if not.
+
+X<rnfisfree>The library syntax is B<rnfisfree>C<(>I<bnf>C<,x)>, and the result is a C<long>.
+
+=head2 X<rnfisnorm>rnfisnormC<(>I<bnf>C<,>I<ext>C<,>I<el>C<,{>I<flag>C< = 1})>
+
+similar to
+C<bnfisnorm> but in the relative case. This tries to decide whether the
+element I<el> in I<bnf> is the norm of some C<y> in I<ext>.
+I<bnf> is as output by C<bnfinit>.
+
+I<ext> is a relative extension which has to be a row vector whose
+components are:
+
+I<ext>C<[1]>: a relative equation of the number field I<ext> over
+I<bnf>. As usual, the priority of the variable of the polynomial
+defining the ground field I<bnf> (say C<y>) must be lower than the
+main variable of I<ext>C<[1]>, say C<x>.
+
+I<ext>C<[2]>: the generator C<y> of the base field as a polynomial in C<x> (as
+given by C<rnfequation> with I<flag>C< = 1>).
+
+I<ext>C<[3]>: is the C<bnfinit> of the absolute extension I<ext>C</>B<Q>.
+
+This returns a vector C<[a,b]>, where I<el>C< = >I<Norm>C<(a)*b>. It looks for a
+solution which is an C<S>-integer, with C<S> a list of places (of I<bnf>)
+containing the ramified primes, the generators of the class group of
+I<ext>, as well as those primes dividing I<el>. If I<ext>C</>I<bnf>
+is known to be X<Galois>Galois, set I<flag>C< = 0> (here I<el> is a norm iff C<b = 1>).
+If I<flag> is non zero add to C<S> all the places above the primes which: divide
+I<flag> if I<flag>C< E<lt> 0>, or are less than I<flag> if I<flag>C< E<gt> 0>. The answer is guaranteed
+(i.e.S< >I<el> is a norm iff C<b = 1>) under X<GRH>GRH, if C<S> contains all
+primes less than C<12> F<log> C<^2|disc(>I<Ext>C<)|>, where
+I<Ext> is the normal closure of I<ext>C< / >I<bnf>. Example:
+
+ bnf = bnfinit(y^3 + y^2 - 2*y - 1);
+ p = x^2 + Mod(y^2 + 2*y + 1, bnf.pol);
+ rnf = rnfequation(bnf,p,1);
+ ext = [p, rnf[2], bnfinit(rnf[1])];
+ rnfisnorm(bnf,ext,17, 1)
+
+checks whether C<17> is a norm in the Galois extension B<Q>C<(>F<beta>C<) /
+>B<Q>C<(>F<alpha>C<)>, where F<alpha>C<^3 + >F<alpha>C<^2 - 2>F<alpha>C< - 1 = 0> and F<beta>C<^2 +
+>F<alpha>C<^2 + 2*>F<alpha>C< + 1 = 0> (it is).
+
+X<rnfisnorm>The library syntax is B<rnfisnorm>C<(>I<bnf>C<,ext,x,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<rnfkummer>rnfkummerC<(>I<bnr>C<,>I<subgroup>C<,{deg = 0})>
+
+I<bnr>
+being as output by C<bnrinit>, finds a relative equation for the
+class field corresponding to the module in I<bnr> and the given
+congruence subgroup. If I<deg> is positive, outputs the list of all
+relative equations of degree I<deg> contained in the ray class field
+defined by I<bnr>.
+
+(THIS PROGRAM IS STILL IN DEVELOPMENT STAGE)
+
+X<rnfkummer>The library syntax is B<rnfkummer>C<(>I<bnr>C<,>I<subgroup>C<,>I<deg>C<,>I<prec>C<)>,
+where I<deg> is a C<long>.
+
+=head2 X<rnflllgram>rnflllgramC<(>I<nf>C<,>I<pol>C<,>I<order>C<)>
+
+given a polynomial
+I<pol> with coefficients in I<nf> and an order I<order> as output
+by C<rnfpseudobasis> or similar, gives C<[[>I<neworder>C<],U]>, where
+I<neworder> is a reduced order and C<U> is the unimodular transformation
+matrix.
+
+X<rnflllgram>The library syntax is B<rnflllgram>C<(>I<nf>C<,>I<pol>C<,>I<order>C<,>I<prec>C<)>.
+
+=head2 X<rnfnormgroup>rnfnormgroupC<(>I<bnr>C<,>I<pol>C<)>
+
+I<bnr> being a big ray
+class field as output by C<bnrinit> and I<pol> a relative polynomial
+defining an X<Abelian extension>Abelian extension, computes the norm group (alias Artin
+or Takagi group) corresponding to the Abelian extension of I<bnf>C< = bnr[1]>
+defined by I<pol>, where the module corresponding to I<bnr> is assumed
+to be a multiple of the conductor (i.e.S< >polrel defines a subextension of
+bnr). The result is the HNF defining the norm group on the given generators
+of I<bnr>C<[5][3]>. Note that neither the fact that I<pol> defines an
+Abelian extension nor the fact that the module is a multiple of the conductor
+is checked. The result is undefined if the assumption is not correct.
+
+X<rnfnormgroup>The library syntax is B<rnfnormgroup>C<(>I<bnr>C<,>I<pol>C<)>.
+
+=head2 X<rnfpolred>rnfpolredC<(>I<nf>C<,>I<pol>C<)>
+
+relative version of C<polred>.
+Given a monic polynomial I<pol> with coefficients in I<nf>, finds a
+list of relative polynomials defining some subfields, hopefully simpler and
+containing the original field. In the present version B<2.2.0>, this is slower
+than C<rnfpolredabs>.
+
+X<rnfpolred>The library syntax is B<rnfpolred>C<(>I<nf>C<,>I<pol>C<,>I<prec>C<)>.
+
+=head2 X<rnfpolredabs>rnfpolredabsC<(>I<nf>C<,>I<pol>C<,{>I<flag>C< = 0})>
+
+relative version of
+C<polredabs>. Given a monic polynomial I<pol> with coefficients in
+I<nf>, finds a simpler relative polynomial defining the same field. If
+I<flag>C< = 1>, returns C<[P,a]> where C<P> is the default output and C<a> is an
+element expressed on a root of C<P> whose characteristic polynomial is
+I<pol>, if I<flag>C< = 2>, returns an absolute polynomial (same as
+
+C<rnfequation(>I<nf>C<,rnfpolredabs(>I<nf>C<,>I<pol>C<))>
+
+but faster).
+
+B<Remark.> In the present implementation, this is both faster and
+much more efficient than C<rnfpolred>, the difference being more
+dramatic than in the absolute case. This is because the implementation of
+C<rnfpolred> is based on (a partial implementation of) an incomplete
+reduction theory of lattices over number fields (i.e.S< >the function
+C<rnflllgram>) which deserves to be improved.
+
+X<rnfpolredabs>The library syntax is B<rnfpolredabs>C<(>I<nf>C<,>I<pol>C<,>I<flag>C<,>I<prec>C<)>.
+
+=head2 X<rnfpseudobasis>rnfpseudobasisC<(>I<nf>C<,>I<pol>C<)>
+
+given a number field
+I<nf> as output by C<nfinit> and a polynomial I<pol> with
+coefficients in I<nf> defining a relative extension C<L> of I<nf>,
+computes a pseudo-basis C<(A,I)> and the relative discriminant of C<L>.
+This is output as
+a four-element row vector C<[A,I,D,d]>, where C<D> is the relative ideal
+discriminant and C<d> is the relative discriminant considered as an element of
+I<nf>C<^*/{>I<nf>C<^*}^2>.
+
+Note: As usual, I<nf> can be a I<bnf> as output by C<bnfinit>.
+
+X<rnfpseudobasis>The library syntax is B<rnfpseudobasis>C<(>I<nf>C<,>I<pol>C<)>.
+
+=head2 X<rnfsteinitz>rnfsteinitzC<(>I<nf>C<,x)>
+
+given a number field I<nf> as
+output by C<nfinit> and either a polynomial C<x> with coefficients in
+I<nf> defining a relative extension C<L> of I<nf>, or a pseudo-basis
+C<x> of such an extension as output for example by C<rnfpseudobasis>,
+computes another pseudo-basis C<(A,I)> (not in HNF in general) such that all
+the ideals of C<I> except perhaps the last one are equal to the ring of
+integers of I<nf>, and outputs the four-component row vector C<[A,I,D,d]>
+as in C<rnfpseudobasis>. The name of this function comes from the fact
+that the ideal class of the last ideal of C<I> (which is well defined) is
+called the X<Steinitz class>I<Steinitz class> of the module B<Z>C<_L>.
+
+Note: I<nf> can be a I<bnf> as output by C<bnfinit>.
+
+X<rnfsteinitz>The library syntax is B<rnfsteinitz>C<(>I<nf>C<,x)>.
+
+=head2 X<subgrouplist>subgrouplistC<(>I<bnr>C<,{>I<bound>C<},{>I<flag>C< = 0})>
+
+I<bnr> being as output by C<bnrinit> or a list of cyclic components
+of a finite Abelian group C<G>, outputs the list of subgroups of C<G>
+(of index bounded by I<bound>, if not omitted). Subgroups are given
+as HNFX<Hermite normal form> left divisors of the
+SNFX<Smith normal form> matrix corresponding to C<G>. If I<flag>C< = 0>
+(default) and I<bnr> is as output by
+C<bnrinit>, gives only the subgroups whose modulus is the conductor.
+
+X<subgrouplist0>The library syntax is B<subgrouplist0>C<(>I<bnr>C<,>I<bound>C<,>I<flag>C<,>I<prec>C<)>, where
+I<bound>, I<flag> and I<prec> are long integers.
+
+=head2 X<zetak>zetakC<(>I<znf>C<,x,{>I<flag>C< = 0})>
+
+I<znf> being a number
+field initialized by C<zetakinit> (I<not> by C<nfinit>),
+computes the value of the X<Dedekind>Dedekind zeta function of the number
+field at the complex number C<x>. If I<flag>C< = 1> computes Dedekind F<Lambda>
+function instead (i.e.S< >the product of the
+Dedekind zeta function by its gamma and exponential factors).
+
+The accuracy of the result depends in an essential way on the accuracy of
+both the C<zetakinit> program and the current accuracy, but even so the
+result may be off by up to 5 or 10 decimal digits.
+
+X<glambdak>The library syntax is B<glambdak>C<(>I<znf>C<,x,>I<prec>C<)> or
+X<gzetak>B<gzetak>C<(>I<znf>C<,x,>I<prec>C<)>.
+
+=head2 X<zetakinit>zetakinitC<(x)>
+
+computes a number of initialization data
+concerning the number field defined by the polynomial C<x> so as to be able
+to compute the X<Dedekind>Dedekind zeta and lambda functions (respectively
+C<zetak(x)> and C<zetak(x,1)>). This function calls in particular
+the C<bnfinit> program. The result is a 9-component vector C<v> whose
+components are very technical and cannot really be used by the user except
+through the C<zetak> function. The only component which can be used if
+it has not been computed already is C<v[1][4]> which is the result of the
+C<bnfinit> call.
+
+This function is very inefficient and should be rewritten. It needs to
+computes millions of coefficients of the corresponding Dirichlet series if
+the precision is big. Unless the discriminant is small it will not be able
+to handle more than 9 digits of relative precision
+(e.gS< >C<zetakinit(x^8 - 2)> needs 440MB of memory at default
+precision).
+
+X<initzeta>The library syntax is B<initzeta>C<(x)>.
+
+=head1 Polynomials and power series
+
+We group here all functions which are specific to polynomials or power
+series. Many other functions which can be applied on these objects are
+described in the other sections. Also, some of the functions described here
+can be applied to other types.
+
+=head2 X<O>OC<(a>C<^>C<b)>
+
+C<p>-adic (if C<a> is an integer greater or
+equal to 2) or power series zero (in all other cases), with precision given
+by C<b>.
+
+X<ggrandocp>The library syntax is B<ggrandocp>C<(a,b)>, where C<b> is a C<long>.
+
+=head2 X<deriv>derivC<(x,{v})>
+
+derivative of C<x> with respect to the main
+variable if C<v> is omitted, and with respect to C<v> otherwise. C<x> can be any
+type except polmod. The derivative of a scalar type is zero, and the
+derivative of a vector or matrix is done componentwise. One can use C<x'> as a
+shortcut if the derivative is with respect to the main variable of C<x>.
+
+X<deriv>The library syntax is B<deriv>C<(x,v)>, where C<v> is a C<long>, and an omitted C<v> is coded as
+C<-1>.
+
+=head2 X<eval>evalC<(x)>
+
+replaces in C<x> the formal variables by the values that
+have been assigned to them after the creation of C<x>. This is mainly useful
+in GP, and not in library mode. Do not confuse this with substitution (see
+C<subst>). Applying this function to a character string yields the
+output from the corresponding GP command, as if directly input from the
+keyboard (see L<Label se:strings>).X<Label se:eval>
+
+X<geval>The library syntax is B<geval>C<(x)>. The more basic functions X<poleval>B<poleval>C<(q,x)>,
+X<qfeval>B<qfeval>C<(q,x)>, and X<hqfeval>B<hqfeval>C<(q,x)> evaluate C<q> at C<x>, where C<q>
+is respectively assumed to be a polynomial, a quadratic form (a symmetric
+matrix), or an Hermitian form (an Hermitian complex matrix).
+
+=head2 X<factorpadic>factorpadicC<(>I<pol>C<,p,r,{>I<flag>C< = 0})>
+
+C<p>-adic factorization
+of the polynomial I<pol> to precision C<r>, the result being a
+two-column matrix as in C<factor>. The factors are normalized so that
+their leading coefficient is a power of C<p>. C<r> must be strictly larger than
+the C<p>-adic valuation of the discriminant of I<pol> for the result to
+make any sense. The method used is a modified version of the X<round 4>round 4
+algorithm of X<Zassenhaus>Zassenhaus.
+
+If I<flag>C< = 1>, use an algorithm due to X<Buchmann>Buchmann and X<Lenstra>Lenstra, which is
+usually less efficient.
+
+X<factorpadic4>The library syntax is B<factorpadic4>C<(>I<pol>C<,p,r)>, where C<r> is a C<long> integer.
+
+=head2 X<intformal>intformalC<(x,{v})>
+
+X<formal integration>formal integration of C<x> with
+respect to the main variable if C<v> is omitted, with respect to the variable
+C<v> otherwise. Since PARI does not know about ``abstract'' logarithms (they
+are immediately evaluated, if only to a power series), logarithmic terms in
+the result will yield an error. C<x> can be of any type. When C<x> is a
+rational function, it is assumed that the base ring is an integral domain of
+characteristic zero.
+
+X<integ>The library syntax is B<integ>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded
+as C<-1>.
+
+=head2 X<padicappr>padicapprC<(>I<pol>C<,a)>
+
+vector of C<p>-adic roots of the
+polynomial
+C<pol> congruent to the C<p>-adic number C<a> modulo C<p> (or modulo 4 if C<p = 2>),
+and with the same C<p>-adic precision as C<a>. The number C<a> can be an
+ordinary C<p>-adic number (type C<t_PADIC>, i.e.S< >an element of B<Q>C<_p>) or
+can be an element of a finite extension of B<Q>C<_p>, in which case it is of
+type C<t_POLMOD>, where at least one of the coefficients of the polmod is a
+C<p>-adic number. In this case, the result is the vector of roots belonging to
+the same extension of B<Q>C<_p> as C<a>.
+
+X<apprgen9>The library syntax is B<apprgen9>C<(>I<pol>C<,a)>, but if C<a> is known to be simply a C<p>-adic number
+(type C<t_PADIC>), the syntax X<apprgen>B<apprgen>C<(>I<pol>C<,a)> can be used.
+
+=head2 X<polcoeff>polcoeffC<(x,s,{v})>
+
+coefficient of degree C<s> of the
+polynomial C<x>, with respect to the main variable if C<v> is omitted, with
+respect to C<v> otherwise.
+
+X<polcoeff0>The library syntax is B<polcoeff0>C<(x,s,v)>, where C<v> is a C<long> and an omitted C<v> is coded
+as C<-1>. Also available is X<truecoeff>B<truecoeff>C<(x,v)>.
+
+=head2 X<poldegree>poldegreeC<(x,{v})>
+
+degree of the polynomial C<x> in the main
+variable if C<v> is omitted, in the variable C<v> otherwise. This is to be
+understood as follows. When C<x> is a polynomial or a rational function, it
+gives the degree of C<x>, the degree of C<0> being C<-1> by convention. When C<x>
+is a non-zero scalar, it gives 0, and when C<x> is a zero scalar, it gives
+C<-1>. Return an error otherwise.
+
+X<poldegree>The library syntax is B<poldegree>C<(x,v)>, where C<v> and the result are C<long>s (and an
+omitted C<v> is coded as C<-1>). Also available is X<degree>B<degree>C<(x)>, which is
+equivalent to C<poldegree(x,-1)>.
+
+=head2 X<polcyclo>polcycloC<(n,{v = x})>
+
+C<n>-th cyclotomic polynomial, in variable
+C<v> (C<x> by default). The integer C<n> must be positive.
+
+X<cyclo>The library syntax is B<cyclo>C<(n,v)>, where C<n> and C<v> are C<long>
+integers (C<v> is a variable number, usually obtained through C<varn>).
+
+=head2 X<poldisc>poldiscC<(>I<pol>C<,{v})>
+
+discriminant of the polynomial
+I<pol> in the main variable is C<v> is omitted, in C<v> otherwise. The
+algorithm used is the X<subresultant algorithm>subresultant algorithm.
+
+X<poldisc0>The library syntax is B<poldisc0>C<(x,v)>. Also available is X<discsr>B<discsr>C<(x)>, equivalent
+to C<poldisc0(x,-1)>.
+
+=head2 X<poldiscreduced>poldiscreducedC<(f)>
+
+reduced discriminant vector of the
+(integral, monic) polynomial C<f>. This is the vector of elementary divisors
+of B<Z>C<[>F<alpha>C<]/f'(>F<alpha>C<)>B<Z>C<[>F<alpha>C<]>, where F<alpha> is a root of the
+polynomial C<f>. The components of the result are all positive, and their
+product is equal to the absolute value of the discriminant ofS< >C<f>.
+
+X<reduceddiscsmith>The library syntax is B<reduceddiscsmith>C<(x)>.
+
+=head2 X<polhensellift>polhenselliftC<(x, y, p, e)>
+
+given a vector C<y> of
+polynomials that are pairwise relatively prime modulo the prime C<p>,
+and whose product is congruent to C<x> modulo C<p>, lift the elements of
+C<y> to polynomials whose product is congruent to C<x> modulo C<p^e>.
+
+X<polhensellift>The library syntax is B<polhensellift>C<(x,y,p,e)> where C<e> must be a C<long>.
+
+=head2 X<polinterpolate>polinterpolateC<(xa,{ya},{v = x},{&e})>
+
+given the data vectors
+C<xa> and C<ya> of the same length C<n> (C<xa> containing the C<x>-coordinates,
+and C<ya> the corresponding C<y>-coordinates), this function finds the
+X<interpolating polynomial>interpolating polynomial passing through these points and evaluates it
+atS< >C<v>. If C<ya> is omitted, return the polynomial interpolating the
+C<(i,xa[i])>. If present, C<e> will contain an error estimate on the returned
+value.
+
+X<polint>The library syntax is B<polint>C<(xa,ya,v,&e)>, where C<e> will contain an error estimate on the
+returned value.
+
+=head2 X<polisirreducible>polisirreducibleC<(>I<pol>C<)>
+
+I<pol> being a polynomial
+(univariate in the present version B<2.2.0>), returns 1 if I<pol> is
+non-constant and irreducible, 0 otherwise. Irreducibility is checked over
+the smallest base field over which I<pol> seems to be defined.
+
+X<gisirreducible>The library syntax is B<gisirreducible>C<(>I<pol>C<)>.
+
+=head2 X<pollead>polleadC<(x,{v})>
+
+leading coefficient of the polynomial or
+power series C<x>. This is computed with respect to the main variable of C<x>
+if C<v> is omitted, with respect to the variable C<v> otherwise.
+
+X<pollead>The library syntax is B<pollead>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded as
+C<-1>. Also available is X<leadingcoeff>B<leadingcoeff>C<(x)>.
+
+=head2 X<pollegendre>pollegendreC<(n,{v = x})>
+
+creates the C<n^{th}>
+X<Legendre polynomial>Legendre polynomial, in variable C<v>.
+
+X<legendre>The library syntax is B<legendre>C<(n)>, where C<x> is a C<long>.
+
+=head2 X<polrecip>polrecipC<(>I<pol>C<)>
+
+reciprocal polynomial of I<pol>,
+i.e.S< >the coefficients are in reverse order. I<pol> must be a polynomial.
+
+X<polrecip>The library syntax is B<polrecip>C<(x)>.
+
+=head2 X<polresultant>polresultantC<(x,y,{v},{>I<flag>C< = 0})>
+
+resultant of the two
+polynomials C<x> and C<y> with exact entries, with respect to the main
+variables of C<x> and C<y> if C<v> is omitted, with respect to the variable C<v>
+otherwise. The algorithm used is the X<subresultant algorithm>subresultant algorithm by default.
+
+If I<flag>C< = 1>, uses the determinant of Sylvester's matrix instead (here C<x> and
+C<y> may have non-exact coefficients).
+
+If I<flag>C< = 2>, uses Ducos's modified subresultant algorithm. It should be much
+faster than the default if the coefficient ring is complicated (e.g
+multivariate polynomials or huge coefficients), and slightly slower
+otherwise.
+
+X<polresultant0>The library syntax is B<polresultant0>C<(x,y,v,>I<flag>C<)>, where C<v> is a C<long> and an omitted C<v>
+is coded as C<-1>. Also available are X<subres>B<subres>C<(x,y)> (I<flag>C< = 0>) and
+X<resultant2>B<resultant2>C<(x,y)> (I<flag>C< = 1>).
+
+=head2 X<polroots>polrootsC<(>I<pol>C<,{>I<flag>C< = 0})>
+
+complex roots of the polynomial
+I<pol>, given as a column vector where each root is repeated according to
+its multiplicity. The precision is given as for transcendental functions: under
+GP it is kept in the variable C<realprecision> and is transparent to the
+user, but it must be explicitly given as a second argument in library mode.
+
+The algorithm used is a modification of A.S< >X<SchE<ouml>nhage>SchE<ouml>nhage's remarkable
+root-finding algorithm, due to and implemented by X.S< >Gourdon. Barring bugs,
+it is guaranteed to converge and to give the roots to the required accuracy.
+
+If I<flag>C< = 1>, use a variant of the Newton-Raphson method, which is I<not>
+guaranteed to converge, but is rather fast. If you get the messages ``too
+many iterations in roots'' or ``INTERNAL ERROR: incorrect result in roots'',
+use the default function (i.e.S< >no flag or I<flag>C< = 0>). This used to be the
+default root-finding function in PARI until version 1.39.06.
+
+X<roots>The library syntax is B<roots>C<(>I<pol>C<,>I<prec>C<)> or X<rootsold>B<rootsold>C<(>I<pol>C<,>I<prec>C<)>.
+
+=head2 X<polrootsmod>polrootsmodC<(>I<pol>C<,p,{>I<flag>C< = 0})>
+
+row vector of roots modulo
+C<p> of the polynomial I<pol>. The particular non-prime value C<p = 4> is
+accepted, mainly for C<2>-adic computations. Multiple roots are I<not>
+repeated.
+
+If C<p E<lt> 100>, you may try setting I<flag>C< = 1>, which uses a naive search. In this
+case, multiple roots I<are> repeated with their order of multiplicity.
+
+X<rootmod>The library syntax is B<rootmod>C<(>I<pol>C<,p)> (I<flag>C< = 0>) or
+X<rootmod2>B<rootmod2>C<(>I<pol>C<,p)> (I<flag>C< = 1>).
+
+=head2 X<polrootspadic>polrootspadicC<(>I<pol>C<,p,r)>
+
+row vector of C<p>-adic roots of the
+polynomial I<pol> with C<p>-adic precision equal to C<r>. Multiple roots are
+I<not> repeated. C<p> is assumed to be a prime.
+
+X<rootpadic>The library syntax is B<rootpadic>C<(>I<pol>C<,p,r)>, where C<r> is a C<long>.
+
+=head2 X<polsturm>polsturmC<(>I<pol>C<,{a},{b})>
+
+number of real roots of the real
+polynomial I<pol> in the interval C<]a,b]>, using Sturm's algorithm. C<a>
+(resp.S< >C<b>) is taken to be C<- oo > (resp.S< >C<+ oo >) if omitted.
+
+X<sturmpart>The library syntax is B<sturmpart>C<(>I<pol>C<,a,b)>. Use C<NULL> to omit an argument.
+X<sturm>B<sturm>C<(>I<pol>C<)> is equivalent to
+B<sturmpart>C<(>I<pol>C<,NULL,NULL)>. The result is a C<long>.
+
+=head2 X<polsubcyclo>polsubcycloC<(n,d,{v = x})>
+
+gives a polynomial (in variable
+C<v>) defining the sub-Abelian extension of degree C<d> of the cyclotomic
+field B<Q>C<(>F<zeta>C<_n)>, where C<d | >F<phi>C<(n)>. C<(>B<Z>C</n>B<Z>C<)^*> has to be cyclic
+(i.e.S< >C<n = 2>, C<4>, C<p^k> or C<2p^k> for an odd prime C<p>). The function
+X<galoissubcyclo>C<galoissubcyclo> covers the general case.
+
+X<subcyclo>The library syntax is B<subcyclo>C<(n,d,v)>, where C<v> is a variable number.
+
+=head2 X<polsylvestermatrix>polsylvestermatrixC<(x,y)>
+
+forms the Sylvester matrix
+corresponding to the two polynomials C<x> and C<y>, where the coefficients of
+the polynomials are put in the columns of the matrix (which is the natural
+direction for solving equations afterwards). The use of this matrix can be
+essential when dealing with polynomials with inexact entries, since
+polynomial Euclidean division doesn't make much sense in this case.
+
+X<sylvestermatrix>The library syntax is B<sylvestermatrix>C<(x,y)>.
+
+=head2 X<polsym>polsymC<(x,n)>
+
+creates the vector of the X<symmetric powers>symmetric powers
+of the roots of the polynomial C<x> up to power C<n>, using Newton's
+formula.
+
+X<polsym>The library syntax is B<polsym>C<(x)>.
+
+=head2 X<poltchebi>poltchebiC<(n,{v = x})>
+
+creates the C<n^{th}>
+X<Chebyshev>Chebyshev polynomial, in variable C<v>.
+
+X<tchebi>The library syntax is B<tchebi>C<(n,v)>, where C<n> and C<v> are C<long>
+integers (C<v> is a variable number).
+
+=head2 X<polzagier>polzagierC<(n,m)>
+
+creates Zagier's polynomial C<P_{n,m}> used in
+the functions C<sumalt> and C<sumpos> (with I<flag>C< = 1>). The exact
+definition can be found in a forthcoming paper. One must have C<m E<lt>= n>.
+
+X<polzagreel>The library syntax is B<polzagreel>C<(n,m,>I<prec>C<)> if the result is only wanted as a polynomial
+with real coefficients to the precision I<prec>, or X<polzag>B<polzag>C<(n,m)>
+if the result is wanted exactly, where C<n> and C<m> are C<long>s.
+
+=head2 X<serconvol>serconvolC<(x,y)>
+
+convolution (or X<Hadamard product>Hadamard product) of the
+two power series C<x> and C<y>; in other words if C<x = >F<sum>C< a_k*X^k> and C<y = >F<sum>C<
+b_k*X^k> then C<serconvol(x,y) = >F<sum>C< a_k*b_k*X^k>.
+
+X<convol>The library syntax is B<convol>C<(x,y)>.
+
+=head2 X<serlaplace>serlaplaceC<(x)>
+
+C<x> must be a power series with only
+non-negative exponents. If C<x = >F<sum>C< (a_k/k!)*X^k> then the result is F<sum>C<
+a_k*X^k>.
+
+X<laplace>The library syntax is B<laplace>C<(x)>.
+
+=head2 X<serreverse>serreverseC<(x)>
+
+reverse power series (i.e.S< >C<x^{-1}>, not C<1/x>)
+of C<x>. C<x> must be a power series whose valuation is exactly equal to one.
+
+X<recip>The library syntax is B<recip>C<(x)>.
+
+=head2 X<subst>substC<(x,y,z)>
+
+replace the simple variable C<y> by the argument C<z> in the ``polynomial''
+expression C<x>. Every type is allowed for C<x>, but if it is not a genuine
+polynomial (or power series, or rational function), the substitution will be
+done as if the scalar components were polynomials of degree one. In
+particular, beware that:
+
+ ? subst(1, x, [1,2; 3,4])
+ %1 =
+ [1 0]
+
+ [0 1]
+
+ ? subst(1, x, Mat([0,1]))
+ *** forbidden substitution by a non square matrix
+
+If C<x> is a power series, C<z> must be either a polynomial, a power series, or
+a rational function. C<y> must be a simple variable name.
+
+X<gsubst>The library syntax is B<gsubst>C<(x,v,z)>, where C<v> is the number of
+the variable C<y>.
+
+=head2 X<taylor>taylorC<(x,y)>
+
+Taylor expansion around C<0> of C<x> with respect
+toX<Label se:taylor>
+the simple variable C<y>. C<x> can be of any reasonable type, for example a
+rational function. The number of terms of the expansion is transparent to the
+user under GP, but must be given as a second argument in library mode.
+
+X<tayl>The library syntax is B<tayl>C<(x,y,n)>, where the C<long> integer C<n> is the desired number of
+terms in the expansion.
+
+=head2 X<thue>thueC<(>I<tnf>C<,a,{>I<sol>C<})>
+
+solves the equation
+C<P(x,y) = a> in integers C<x> and C<y>, where I<tnf> was created with
+C<thueinit(P)>. I<sol>, if present, contains the solutions of
+C<Norm(x) = a> modulo units of positive norm in the number field
+defined by C<P> (as computed by C<bnfisintnorm>). If I<tnf> was
+computed without assuming X<GRH>GRH (I<flag>C< = 1> in C<thueinit>), the
+result is unconditional. For instance, here's how to solve the Thue
+equation C<x^{13} - 5y^{13} = - 4>:
+
+ ? tnf = thueinit(x^13 - 5);
+ ? thue(tnf, -4)
+ %1 = [[1, 1]]
+
+Hence, assuming GRH, the only solution is C<x = 1>, C<y = 1>.
+
+X<thue>The library syntax is B<thue>C<(>I<tnf>C<,a,>I<sol>C<)>, where an omitted I<sol> is coded
+as C<NULL>.
+
+=head2 X<thueinit>thueinitC<(P,{>I<flag>C< = 0})>
+
+initializes the I<tnf>
+corresponding to C<P>. It is meant to be used in conjunction with X<thue>C<thue>
+to solve Thue equations C<P(x,y) = a>, where C<a> is an integer. If I<flag> is
+non-zero, certify the result unconditionnaly, Otherwise, assume X<GRH>GRH,
+this being much faster of course.
+
+X<thueinit>The library syntax is B<thueinit>C<(P,>I<flag>C<,>I<prec>C<)>.
+
+=head1 Vectors, matrices, linear algebra and sets
+
+X<Label se:linear_algebra>
+Note that most linear algebra functions operating on subspaces defined by
+generating sets (such as X<mathnf>C<mathnf>, X<qflll>C<qflll>, etc.) take matrices as
+arguments. As usual, the generating vectors are taken to be the
+I<columns> of the given matrix.
+
+=head2 X<algdep>algdepC<(x,k,{>I<flag>C< = 0})>
+
+X<algebraic dependence>C<x> being
+real, complex, or C<p>-adic, finds a polynomial of degree at most C<k> with
+integer coefficients having C<x> as approximate root. Note that the polynomial
+which is obtained is not necessarily the ``correct'' one (it's not even
+guaranteed to be irreducible!). One can check the closeness either by a
+polynomial evaluation or substitution, or by computing the roots of the
+polynomial given by algdep.
+
+If C<x> is padic, I<flag> is meaningless and the algorithm LLL-reduces the
+``dual lattice'' corresponding to the powers of C<x>.
+
+Otherwise, if I<flag> is zero, the algorithm used is a variant of the X<LLL>LLL
+algorithm due to Hastad, Lagarias and Schnorr (STACS 1986). If the precision
+is too low, the routine may enter an infinite loop.
+
+If I<flag> is non-zero, use a standard LLL. I<flag> then indicates a precision,
+which should be between C<0.5> and C<1.0> times the number of decimal digits
+to which C<x> was computed.
+
+X<algdep0>The library syntax is B<algdep0>C<(x,k,>I<flag>C<,>I<prec>C<)>, where C<k> and I<flag> are C<long>s.
+Also available is X<algdep>B<algdep>C<(x,k,>I<prec>C<)> (I<flag>C< = 0>).
+
+=head2 X<charpoly>charpolyC<(A,{v = x},{>I<flag>C< = 0})>
+
+X<characteristic polynomial>characteristic polynomial
+of C<A> with respect to the variable C<v>, i.e.S< >determinant of C<v*I-A> if C<A>
+is a square matrix, determinant of the map ``multiplication by C<A>'' if C<A>
+is a scalar, in particular a polmod (e.g.S< >C<charpoly(I,x) = x^2+1>).
+Note that in the latter case, the X<minimal polynomial>minimal polynomial can be obtained
+as
+
+ minpoly(A)=
+ {
+ local(y);
+ y = charpoly(A);
+ y / gcd(y,y')
+ }
+
+The value of I<flag> is only significant for matrices.
+
+If I<flag>C< = 0>, the method used is essentially the same as for computing the
+adjoint matrix, i.e.S< >computing the traces of the powers of C<A>.
+
+If I<flag>C< = 1>, uses Lagrange interpolation which is almost always slower.
+
+If I<flag>C< = 2>, uses the Hessenberg form. This is faster than the default when
+the coefficients are integermod a prime or real numbers, but is usually
+slower in other base rings.
+
+X<charpoly0>The library syntax is B<charpoly0>C<(A,v,>I<flag>C<)>, where C<v> is the variable number. Also available
+are the functions X<caract>B<caract>C<(A,v)> (I<flag>C< = 1>), X<carhess>B<carhess>C<(A,v)>
+(I<flag>C< = 2>), and X<caradj>B<caradj>C<(A,v,>I<pt>C<)> where, in this last case,
+I<pt> is a C<GEN*> which, if not equal to C<NULL>, will receive
+the address of the adjoint matrix of C<A> (see C<matadjoint>), so both
+can be obtained at once.
+
+=head2 X<concat>concatC<(x,{y})>
+
+concatenation of C<x> and C<y>. If C<x> or C<y> is
+not a vector or matrix, it is considered as a one-dimensional vector. All
+types are allowed for C<x> and C<y>, but the sizes must be compatible. Note
+that matrices are concatenated horizontally, i.e.S< >the number of rows stays
+the same. Using transpositions, it is easy to concatenate them vertically.
+
+To concatenate vectors sideways (i.e.S< >to obtain a two-row or two-column
+matrix), first transform the vector into a one-row or one-column matrix using
+the function X<Mat>C<Mat>. Concatenating a row vector to a matrix having the
+same number of columns will add the row to the matrix (top row if the vector
+is C<x>, i.e.S< >comes first, and bottom row otherwise).
+
+The empty matrix C<[;]> is considered to have a number of rows compatible
+with any operation, in particular concatenation. (Note that this is
+definitely I<not> the case for empty vectors C<[S< >]> or C<[S< >]~>.)
+
+If C<y> is omitted, C<x> has to be a row vector or a list, in which case its
+elements are concatenated, from left to right, using the above rules.
+
+ ? concat([1,2], [3,4])
+ %1 = [1, 2, 3, 4]
+ ? a = [[1,2]~, [3,4]~]; concat(a)
+ %2 = [1, 2, 3, 4]~
+ ? a[1] = Mat(a[1]); concat(a)
+ %3 =
+ [1 3]
+
+ [2 4]
+
+ ? concat([1,2; 3,4], [5,6]~)
+ %4 =
+ [1 2 5]
+
+ [3 4 6]
+ ? concat([%, [7,8]~, [1,2,3,4]])
+ %5 =
+ [1 2 5 7]
+
+ [3 4 6 8]
+
+ [1 2 3 4]
+
+X<concat>The library syntax is B<concat>C<(x,y)>.
+
+=head2 X<lindep>lindepC<(x,{>I<flag>C< = 0})>
+
+X<linear dependence>C<x> being a
+vector with real or complex coefficients, finds a small integral linear
+combination among these coefficients.
+
+If I<flag>C< = 0>, uses a variant of the X<LLL>LLL algorithm due to Hastad, Lagarias
+and Schnorr (STACS 1986).
+
+If I<flag>C< E<gt> 0>, uses the LLL algorithm. I<flag> is a parameter which should be
+between one half the number of decimal digits of precision and that number
+(see C<algdep>).
+
+If I<flag>C< E<lt> 0>, returns as soon as one relation has been found.
+
+X<lindep0>The library syntax is B<lindep0>C<(x,>I<flag>C<,>I<prec>C<)>. Also available is
+X<lindep>B<lindep>C<(x,>I<prec>C<)> (I<flag>C< = 0>).
+
+=head2 X<listcreate>listcreateC<(n)>
+
+creates an empty list of maximal length C<n>.
+
+This function is useless in library mode.
+
+=head2 X<listinsert>listinsertC<(>I<list>C<,x,n)>
+
+inserts the object C<x> at
+position C<n> in I<list> (which must be of type C<t_LIST>). All the
+remaining elements of I<list> (from position C<n+1> onwards) are shifted
+to the right. This and C<listput> are the only commands which enable
+you to increase a list's effective length (as long as it remains under
+the maximal length specified at the time of the C<listcreate>).
+
+This function is useless in library mode.
+
+=head2 X<listkill>listkillC<(>I<list>C<)>
+
+kill I<list>. This deletes all
+elements from I<list> and sets its effective length to C<0>. The maximal
+length is not affected.
+
+This function is useless in library mode.
+
+=head2 X<listput>listputC<(>I<list>C<,x,{n})>
+
+sets the C<n>-th element of the list
+I<list> (which must be of type C<t_LIST>) equal to C<x>. If C<n> is omitted,
+or greater than the list current effective length, just appends C<x>. This and
+C<listinsert> are the only commands which enable you to increase a list's
+effective length (as long as it remains under the maximal length specified at
+the time of the C<listcreate>).
+
+If you want to put an element into an occupied cell, i.e.S< >if you don't want to
+change the effective length, you can consider the list as a vector and use
+the usual C<list[n] = x> construct.
+
+This function is useless in library mode.
+
+=head2 X<listsort>listsortC<(>I<list>C<,{>I<flag>C< = 0})>
+
+sorts I<list> (which must
+be of type C<t_LIST>) in place. If I<flag> is non-zero, suppresses all repeated
+coefficients. This is much faster than the C<vecsort> command since no
+copy has to be made.
+
+This function is useless in library mode.
+
+=head2 X<matadjoint>matadjointC<(x)>
+
+X<adjoint matrix>adjoint matrix of C<x>, i.e.S< >the matrix C<y>
+of cofactors of C<x>, satisfying C<x*y = > F<det> C<(x)*Id>. C<x> must be a
+(non-necessarily invertible) square matrix.
+
+X<adj>The library syntax is B<adj>C<(x)>.
+
+=head2 X<matcompanion>matcompanionC<(x)>
+
+the left companion matrix to the polynomial C<x>.
+
+X<assmat>The library syntax is B<assmat>C<(x)>.
+
+=head2 X<matdet>matdetC<(x,{>I<flag>C< = 0})>
+
+determinant of C<x>. C<x> must be a
+square matrix.
+
+If I<flag>C< = 0>, uses Gauss-Bareiss.
+
+If I<flag>C< = 1>, uses classical Gaussian elimination, which is better when the
+entries of the matrix are reals or integers for example, but usually much
+worse for more complicated entries like multivariate polynomials.
+
+X<det>The library syntax is B<det>C<(x)> (I<flag>C< = 0>) and X<det2>B<det2>C<(x)>
+(I<flag>C< = 1>).
+
+=head2 X<matdetint>matdetintC<(x)>
+
+C<x> being an C<m x n> matrix with integer
+coefficients, this function computes a multiple of the determinant of the
+lattice generated by the columns of C<x> if it is of rank C<m>, and returns
+zero otherwise. This function can be useful in conjunction with the function
+C<mathnfmod> which needs to know such a multiple. Other ways to obtain
+this determinant (assuming the rank is maximal) is
+C<matdet(qflll(x,4)[2]*x)> or more simply C<matdet(mathnf(x))>.
+Experiment to see which is faster for your applications.
+
+X<detint>The library syntax is B<detint>C<(x)>.
+
+=head2 X<matdiagonal>matdiagonalC<(x)>
+
+C<x> being a vector, creates the diagonal matrix
+whose diagonal entries are those of C<x>.
+
+X<diagonal>The library syntax is B<diagonal>C<(x)>.
+
+=head2 X<mateigen>mateigenC<(x)>
+
+gives the eigenvectors of C<x> as columns of a
+matrix.
+
+X<eigen>The library syntax is B<eigen>C<(x)>.
+
+=head2 X<mathess>mathessC<(x)>
+
+Hessenberg form of the square matrix C<x>.
+
+X<hess>The library syntax is B<hess>C<(x)>.
+
+=head2 X<mathilbert>mathilbertC<(x)>
+
+C<x> being a C<long>, creates the
+X<Hilbert matrix>Hilbert
+matrix of order C<x>, i.e.S< >the matrix whose coefficient (C<i>,C<j>) is C<1/
+(i+j-1)>.
+
+X<mathilbert>The library syntax is B<mathilbert>C<(x)>.
+
+=head2 X<mathnf>mathnfC<(x,{>I<flag>C< = 0})>
+
+if C<x> is a (not necessarily square)
+matrix of maximal rank, finds the I<upper triangular>
+X<Hermite normal form>Hermite normal form of C<x>. If the rank of C<x> is equal to its number
+of rows, the result is a square matrix. In general, the columns of the
+result form a basis of the lattice spanned by the columns of C<x>.
+
+If I<flag>C< = 0>, uses the naive algorithm. If the B<Z>-module generated by the
+columns is a lattice, it is recommanded to use
+C<mathnfmod(x, matdetint(x))> instead (much faster).
+
+If I<flag>C< = 1>, uses Batut's algorithm. Outputs a two-component row vector
+C<[H,U]>, where C<H> is the I<upper triangular> Hermite normal form
+of C<x> (i.e.S< >the default result) and C<U> is the unimodular transformation
+matrix such that C<xU = [0|H]>. If the rank of C<x> is equal to its number of
+rows, C<H> is a square matrix. In general, the columns of C<H> form a basis
+of the lattice spanned by the columns of C<x>.
+
+If I<flag>C< = 2>, uses Havas's algorithm. Outputs C<[H,U,P]>, such that
+C<H> and C<U> are as before and C<P> is a permutation of the rows such that C<P>
+applied to C<xU> gives C<H>. This does not work very well in present version
+B<2.2.0>.
+
+If I<flag>C< = 3>, uses Batut's algorithm, and outputs C<[H,U,P]> as in the previous
+case.
+
+If I<flag>C< = 4>, as in case 1 above, but uses X<LLL>LLL reduction along the way.
+
+X<mathnf0>The library syntax is B<mathnf0>C<(x,>I<flag>C<)>. Also available are X<hnf>B<hnf>C<(x)> (I<flag>C< = 0>) and
+X<hnfall>B<hnfall>C<(x)> (I<flag>C< = 1>). To reduce I<huge> (say C<400 x 400> and
+more) relation matrices (sparse with small entries), you can use the pair
+C<hnfspec> / C<hnfadd>. Since this is rather technical and the
+calling interface may change, they are not documented yet. Look at the code
+in C<basemath/alglin1.c>.
+
+=head2 X<mathnfmod>mathnfmodC<(x,d)>
+
+if C<x> is a (not necessarily square) matrix of
+maximal rank with integer entries, and C<d> is a multiple of the (non-zero)
+determinant of the lattice spanned by the columns of C<x>, finds the
+I<upper triangular> X<Hermite normal form>Hermite normal form of C<x>.
+
+If the rank of C<x> is equal to its number of rows, the result is a square
+matrix. In general, the columns of the result form a basis of the lattice
+spanned by the columns of C<x>. This is much faster than C<mathnf> when C<d>
+is known.
+
+X<hnfmod>The library syntax is B<hnfmod>C<(x,d)>.
+
+=head2 X<mathnfmodid>mathnfmodidC<(x,d)>
+
+outputs the (upper triangular)
+X<Hermite normal form>Hermite normal form of C<x> concatenated with C<d> times
+the identity matrix.
+
+X<hnfmodid>The library syntax is B<hnfmodid>C<(x,d)>.
+
+=head2 X<matid>matidC<(n)>
+
+creates the C<n x n> identity matrix.
+
+X<idmat>The library syntax is B<idmat>C<(n)> where C<n> is a C<long>.
+
+Related functions are X<gscalmat>B<gscalmat>C<(x,n)>, which creates C<x> times the
+identity matrix (C<x> being a C<GEN> and C<n> a C<long>), and
+X<gscalsmat>B<gscalsmat>C<(x,n)> which is the same when C<x> is a C<long>.
+
+=head2 X<matimage>matimageC<(x,{>I<flag>C< = 0})>
+
+gives a basis for the image of the
+matrix C<x> as columns of a matrix. A priori the matrix can have entries of
+any type. If I<flag>C< = 0>, use standard Gauss pivot. If I<flag>C< = 1>, use
+C<matsupplement>.
+
+X<matimage0>The library syntax is B<matimage0>C<(x,>I<flag>C<)>. Also available is X<image>B<image>C<(x)> (I<flag>C< = 0>).
+
+=head2 X<matimagecompl>matimagecomplC<(x)>
+
+gives the vector of the column indices which
+are not extracted by the function C<matimage>. Hence the number of
+components of C<matimagecompl(x)> plus the number of columns of
+C<matimage(x)> is equal to the number of columns of the matrix C<x>.
+
+X<imagecompl>The library syntax is B<imagecompl>C<(x)>.
+
+=head2 X<matindexrank>matindexrankC<(x)>
+
+C<x> being a matrix of rank C<r>, gives two
+vectors C<y> and C<z> of length C<r> giving a list of rows and columns
+respectively (starting from 1) such that the extracted matrix obtained from
+these two vectors using X<vecextract>C<vecextract(x,y,z)> is invertible.
+
+X<indexrank>The library syntax is B<indexrank>C<(x)>.
+
+=head2 X<matintersect>matintersectC<(x,y)>
+
+C<x> and C<y> being two matrices with the same
+number of rows each of whose columns are independent, finds a basis of the
+B<Q>-vector space equal to the intersection of the spaces spanned by the
+columns of C<x> and C<y> respectively. See also the function
+X<idealintersect>C<idealintersect>, which does the same for free B<Z>-modules.
+
+X<intersect>The library syntax is B<intersect>C<(x,y)>.
+
+=head2 X<matinverseimage>matinverseimageC<(x,y)>
+
+gives a column vector belonging to the
+inverse image of the column vector C<y> by the matrix C<x> if one exists, the
+empty vector otherwise. To get the complete inverse image, it suffices to add
+to the result any element of the kernel of C<x> obtained for example by
+C<matker>.
+
+X<inverseimage>The library syntax is B<inverseimage>C<(x,y)>.
+
+=head2 X<matisdiagonal>matisdiagonalC<(x)>
+
+returns true (1) if C<x> is a diagonal matrix,
+false (0) if not.
+
+X<isdiagonal>The library syntax is B<isdiagonal>C<(x)>, and this returns a C<long>
+integer.
+
+=head2 X<matker>matkerC<(x,{>I<flag>C< = 0})>
+
+gives a basis for the kernel of the
+matrix C<x> as columns of a matrix. A priori the matrix can have entries of
+any type.
+
+If C<x> is known to have integral entries, set I<flag>C< = 1>.
+
+Note: The library function X<ker_mod_p>C<ker_mod_p(x, p)>, where C<x> has
+integer entries and C<p> is prime, which is equivalent to but many orders of
+magnitude faster than C<matker(x*Mod(1,p))> and needs much less stack
+space. To use it under GP, type C<install(ker_mod_p, GG)> first.
+
+X<matker0>The library syntax is B<matker0>C<(x,>I<flag>C<)>. Also available are X<ker>B<ker>C<(x)> (I<flag>C< = 0>),
+X<keri>B<keri>C<(x)> (I<flag>C< = 1>) and C<ker_mod_p(x,p)>.
+
+=head2 X<matkerint>matkerintC<(x,{>I<flag>C< = 0})>
+
+gives an X<LLL>LLL-reduced B<Z>-basis
+for the lattice equal to the kernel of the matrix C<x> as columns of the
+matrix C<x> with integer entries (rational entries are not permitted).
+
+If I<flag>C< = 0>, uses a modified integer LLL algorithm.
+
+If I<flag>C< = 1>, uses C<matrixqz(x,-2)>. If LLL reduction of the final result
+is not desired, you can save time using C<matrixqz(matker(x),-2)> instead.
+
+If I<flag>C< = 2>, uses another modified LLL. In the present version B<2.2.0>, only
+independent rows are allowed in this case.
+
+X<matkerint0>The library syntax is B<matkerint0>C<(x,>I<flag>C<)>. Also available is
+X<kerint>B<kerint>C<(x)> (I<flag>C< = 0>).
+
+=head2 X<matmuldiagonal>matmuldiagonalC<(x,d)>
+
+product of the matrix C<x> by the diagonal
+matrix whose diagonal entries are those of the vector C<d>. Equivalent to,
+but much faster than C<x*matdiagonal(d)>.
+
+X<matmuldiagonal>The library syntax is B<matmuldiagonal>C<(x,d)>.
+
+=head2 X<matmultodiagonal>matmultodiagonalC<(x,y)>
+
+product of the matrices C<x> and C<y>
+knowing that the result is a diagonal matrix. Much faster than C<x*y> in
+that case.
+
+X<matmultodiagonal>The library syntax is B<matmultodiagonal>C<(x,y)>.
+
+=head2 X<matpascal>matpascalC<(x,{q})>
+
+creates as a matrix the lower triangular
+X<Pascal triangle>Pascal triangle of order C<x+1> (i.e.S< >with binomial coefficients
+up to C<x>). If C<q> is given, compute the C<q>-Pascal triangle (i.e.S< >using
+C<q>-binomial coefficients).
+
+X<matqpascal>The library syntax is B<matqpascal>C<(x,q)>, where C<x> is a C<long> and C<q = NULL> is used
+to omit C<q>. Also available is X<matpascal>B<matpascal>{x}.
+
+=head2 X<matrank>matrankC<(x)>
+
+rank of the matrix C<x>.
+
+X<rank>The library syntax is B<rank>C<(x)>, and the result is a C<long>.
+
+=head2 X<matrix>matrixC<(m,n,{X},{Y},{>I<expr>C< = 0})>
+
+creation of the
+C<m x n> matrix whose coefficients are given by the expression
+I<expr>. There are two formal parameters in I<expr>, the first one
+(C<X>) corresponding to the rows, the second (C<Y>) to the columns, and C<X>
+goes from 1 to C<m>, C<Y> goes from 1 to C<n>. If one of the last 3 parameters
+is omitted, fill the matrix with zeroes.
+
+X<matrice>The library syntax is B<matrice>C<(GEN nlig,GEN ncol,entree *e1,entree *e2,char *expr)>.
+
+=head2 X<matrixqz>matrixqzC<(x,p)>
+
+C<x> being an C<m x n> matrix with C<m E<gt>= n>
+with rational or integer entries, this function has varying behaviour
+depending on the sign of C<p>:
+
+If C<p E<gt>= 0>, C<x> is assumed to be of maximal rank. This function returns a
+matrix having only integral entries, having the same image as C<x>, such that
+the GCD of all its C<n x n> subdeterminants is equal to 1 when C<p> is
+equal to 0, or not divisible by C<p> otherwise. Here C<p> must be a prime
+number (when it is non-zero). However, if the function is used when C<p> has
+no small prime factors, it will either work or give the message ``impossible
+inverse modulo'' and a non-trivial divisor of C<p>.
+
+If C<p = -1>, this function returns a matrix whose columns form a basis of the
+lattice equal to B<Z>C<^n> intersected with the lattice generated by the
+columns of C<x>.
+
+If C<p = -2>, returns a matrix whose columns form a basis of the lattice equal
+to B<Z>C<^n> intersected with the B<Q>-vector space generated by the
+columns of C<x>.
+
+X<matrixqz0>The library syntax is B<matrixqz0>C<(x,p)>.
+
+=head2 X<matsize>matsizeC<(x)>
+
+C<x> being a vector or matrix, returns a row vector
+with two components, the first being the number of rows (1 for a row vector),
+the second the number of columns (1 for a column vector).
+
+X<matsize>The library syntax is B<matsize>C<(x)>.
+
+=head2 X<matsnf>matsnfC<(X,{>I<flag>C< = 0})>
+
+if C<X> is a (singular or non-singular)
+square matrix outputs the vector of elementary divisors of C<X> (i.e.S< >the
+diagonal of the X<Smith normal form>Smith normal form of C<X>).
+
+The binary digits of I<flag> mean:
+
+1 (complete output): if set, outputs C<[U,V,D]>, where C<U> and C<V> are two
+unimodular matrices such that C<UXV> is the diagonal matrix C<D>. Otherwise
+output only the diagonal of C<D>.
+
+2 (generic input): if set, allows polynomial entries. Otherwise, assume
+that C<X> has integer coefficients.
+
+4 (cleanup): if set, cleans up the output. This means that elementary
+divisors equal to C<1> will be deleted, i.e.S< >outputs a shortened vector C<D'>
+instead of C<D>. If complete output was required, returns C<[U',V',D']> so
+that C<U'XV' = D'> holds. If this flag is set, C<X> is allowed to be of the
+form C<D> or C<[U,V,D]> as would normally be output with the cleanup flag
+unset.
+
+X<matsnf0>The library syntax is B<matsnf0>C<(X,>I<flag>C<)>. Also available is X<smith>B<smith>C<(X)> (I<flag>C< = 0>).
+
+=head2 X<matsolve>matsolveC<(x,y)>
+
+C<x> being an invertible matrix and C<y> a column
+vector, finds the solution C<u> of C<x*u = y>, using Gaussian elimination. This
+has the same effect as, but is a bit faster, than C<x^{-1}*y>.
+
+X<gauss>The library syntax is B<gauss>C<(x,y)>.
+
+=head2 X<matsolvemod>matsolvemodC<(m,d,y,{>I<flag>C< = 0})>
+
+C<m> being any integral matrix,
+C<d> a vector of positive integer moduli, and C<y> an integral
+column vector, gives a small integer solution to the system of congruences
+F<sum>C<_i m_{i,j}x_j = y_i (mod d_i)> if one exists, otherwise returns
+zero. Shorthand notation: C<y> (resp.S< >C<d>) can be given as a single integer,
+in which case all the C<y_i> (resp.S< >C<d_i>) above are taken to be equal to C<y>
+(resp.S< >C<d>).
+
+If I<flag>C< = 1>, all solutions are returned in the form of a two-component row
+vector C<[x,u]>, where C<x> is a small integer solution to the system of
+congruences and C<u> is a matrix whose columns give a basis of the homogeneous
+system (so that all solutions can be obtained by adding C<x> to any linear
+combination of columns of C<u>). If no solution exists, returns zero.
+
+X<matsolvemod0>The library syntax is B<matsolvemod0>C<(m,d,y,>I<flag>C<)>. Also available
+are X<gaussmodulo>B<gaussmodulo>C<(m,d,y)> (I<flag>C< = 0>)
+and X<gaussmodulo2>B<gaussmodulo2>C<(m,d,y)> (I<flag>C< = 1>).
+
+=head2 X<matsupplement>matsupplementC<(x)>
+
+assuming that the columns of the matrix C<x>
+are linearly independent (if they are not, an error message is issued), finds
+a square invertible matrix whose first columns are the columns of C<x>,
+i.e.S< >supplement the columns of C<x> to a basis of the whole space.
+
+X<suppl>The library syntax is B<suppl>C<(x)>.
+
+=head2 X<mattranspose>mattransposeC<(x)> or C<x~>
+
+transpose of C<x>.
+This has an effect only on vectors and matrices.
+
+X<gtrans>The library syntax is B<gtrans>C<(x)>.
+
+=head2 X<qfgaussred>qfgaussredC<(q)>
+
+X<decomposition into squares>decomposition into squares of the
+quadratic form represented by the symmetric matrix C<q>. The result is a
+matrix whose diagonal entries are the coefficients of the squares, and the
+non-diagonal entries represent the bilinear forms. More precisely, if
+C<(a_{ij})> denotes the output, one has
+
+S< >C< q(x) = >F<sum>C<_i a_{ii} (x_i + >F<sum>C<_{j E<gt> i} a_{ij} x_j)^2 >
+
+X<sqred>The library syntax is B<sqred>C<(x)>.
+
+=head2 X<qfjacobi>qfjacobiC<(x)>
+
+C<x> being a real symmetric matrix, this gives a
+vector having two components: the first one is the vector of eigenvalues of
+C<x>, the second is the corresponding orthogonal matrix of eigenvectors of
+C<x>. The method used is Jacobi's method for symmetric matrices.
+
+X<jacobi>The library syntax is B<jacobi>C<(x)>.
+
+=head2 X<qflll>qflllC<(x,{>I<flag>C< = 0})>
+
+X<LLL>LLL algorithm applied to the
+I<columns> of the (not necessarily square) matrix C<x>. The columns of C<x>
+must however be linearly independent, unless specified otherwise below. The
+result is a transformation matrix C<T> such that C<x.T> is an LLL-reduced
+basis of the lattice generated by the column vectors of C<x>.
+
+If I<flag>C< = 0> (default), the computations are done with real numbers (i.e.S< >not
+with rational numbers) hence are fast but as presently programmed (version
+B<2.2.0>) are numerically unstable.
+
+If I<flag>C< = 1>, it is assumed that the corresponding Gram matrix is integral.
+The computation is done entirely with integers and the algorithm is both
+accurate and quite fast. In this case, C<x> needs not be of maximal rank, but
+if it is not, C<T> will not be square.
+
+If I<flag>C< = 2>, similar to case 1, except C<x> should be an integer matrix whose
+columns are linearly independent. The lattice generated by the columns of
+C<x> is first partially reduced before applying the LLL algorithm. [A basis
+is said to be I<partially reduced> if C<|v_i F<+-> v_j| E<gt>= |v_i|> for any
+two distinct basis vectors C<v_i, v_j>.]
+
+This can be significantly faster than I<flag>C< = 1> when one row is huge compared
+to the other rows.
+
+If I<flag>C< = 3>, all computations are done in rational numbers. This does not
+incur numerical instability, but is extremely slow. This function is
+essentially superseded by case 1, so will soon disappear.
+
+If I<flag>C< = 4>, C<x> is assumed to have integral entries, but needs not be of
+maximal rank. The result is a two-component vector of matricesS< >: the
+columns of the first matrix represent a basis of the integer kernel of C<x>
+(not necessarily LLL-reduced) and the second matrix is the transformation
+matrix C<T> such that C<x.T> is an LLL-reduced B<Z>-basis of the image
+of the matrix C<x>.
+
+If I<flag>C< = 5>, case as case C<4>, but C<x> may have polynomial coefficients.
+
+If I<flag>C< = 7>, uses an older version of case C<0> above.
+
+If I<flag>C< = 8>, same as case C<0>, where C<x> may have polynomial coefficients.
+
+If I<flag>C< = 9>, variation on case C<1>, using content.
+
+X<qflll0>The library syntax is B<qflll0>C<(x,>I<flag>C<,>I<prec>C<)>. Also available are
+X<lll>B<lll>C<(x,>I<prec>C<)> (I<flag>C< = 0>), X<lllint>B<lllint>C<(x)> (I<flag>C< = 1>), and
+X<lllkerim>B<lllkerim>C<(x)> (I<flag>C< = 4>).
+
+=head2 X<qflllgram>qflllgramC<(x,{>I<flag>C< = 0})>
+
+same as C<qflll> except that the
+matrix C<x> which must now be a square symmetric real matrix is the Gram
+matrix of the lattice vectors, and not the coordinates of the vectors
+themselves. The result is again the transformation matrix C<T> which gives (as
+columns) the coefficients with respect to the initial basis vectors. The
+flags have more or less the same meaning, but some are missing. In brief:
+
+I<flag>C< = 0>: numerically unstable in the present version B<2.2.0>.
+
+I<flag>C< = 1>: C<x> has integer entries, the computations are all done in integers.
+
+I<flag>C< = 4>: C<x> has integer entries, gives the kernel and reduced image.
+
+I<flag>C< = 5>: same as C<4> for generic C<x>.
+
+I<flag>C< = 7>: an older version of case C<0>.
+
+X<qflllgram0>The library syntax is B<qflllgram0>C<(x,>I<flag>C<,>I<prec>C<)>. Also available are
+X<lllgram>B<lllgram>C<(x,>I<prec>C<)> (I<flag>C< = 0>), X<lllgramint>B<lllgramint>C<(x)> (I<flag>C< = 1>), and
+X<lllgramkerim>B<lllgramkerim>C<(x)> (I<flag>C< = 4>).
+
+=head2 X<qfminim>qfminimC<(x,b,m,{>I<flag>C< = 0})>
+
+C<x> being a square and symmetric
+matrix representing a positive definite quadratic form, this function
+deals with the minimal vectors of C<x>, depending on I<flag>.
+
+If I<flag>C< = 0> (default), seeks vectors of square norm less than or equal to C<b>
+(for the norm defined by C<x>), and at most C<2m> of these vectors. The result
+is a three-component vector, the first component being the number of vectors,
+the second being the maximum norm found, and the last vector is a matrix
+whose columns are the vectors found, only one being given for each
+pair C<F<+-> v> (at most C<m> such pairs).
+
+If I<flag>C< = 1>, ignores C<m> and returns the first vector whose norm is less than
+C<b>.
+
+In both these cases, C<x> I<is assumed to have integral entries>, and the
+function searches for the minimal non-zero vectors whenever C<b = 0>.
+
+If I<flag>C< = 2>, C<x> can have non integral real entries, but C<b = 0> is now
+meaningless (uses Fincke-Pohst algorithm).
+
+X<qfminim0>The library syntax is B<qfminim0>C<(x,b,m,>I<flag>C<,>I<prec>C<)>, also available are B<minim>C<(x,b,m)>X<minim>
+(I<flag>C< = 0>), B<minim2>C<(x,b,m)>X<minim2> (I<flag>C< = 1>), and finally
+ B<fincke_pohst>C<(x,b,m,>I<prec>C<)>X<fincke_pohst> (I<flag>C< = 2>).
+
+=head2 X<qfperfection>qfperfectionC<(x)>
+
+C<x> being a square and symmetric matrix with
+integer entries representing a positive definite quadratic form, outputs the
+perfection rank of the form. That is, gives the rank of the family of the C<s>
+symmetric matrices C<v_iv_i^t>, where C<s> is half the number of minimal
+vectors and the C<v_i> (C<1 E<lt>= i E<lt>= s>) are the minimal vectors.
+
+As a side note to old-timers, this used to fail bluntly when C<x> had more
+than C<5000> minimal vectors. Beware that the computations can now be very
+lengthy when C<x> has many minimal vectors.
+
+X<perf>The library syntax is B<perf>C<(x)>.
+
+=head2 X<qfsign>qfsignC<(x)>
+
+signature of the quadratic form represented by the
+symmetric matrix C<x>. The result is a two-component vector.
+
+X<signat>The library syntax is B<signat>C<(x)>.
+
+=head2 X<setintersect>setintersectC<(x,y)>
+
+intersection of the two sets C<x> and C<y>.
+
+X<setintersect>The library syntax is B<setintersect>C<(x,y)>.
+
+=head2 X<setisset>setissetC<(x)>
+
+returns true (1) if C<x> is a set, false (0) if
+not. In PARI, a set is simply a row vector whose entries are strictly
+increasing. To convert any vector (and other objects) into a set, use the
+function C<Set>.
+
+X<setisset>The library syntax is B<setisset>C<(x)>, and this returns a C<long>.
+
+=head2 X<setminus>setminusC<(x,y)>
+
+difference of the two sets C<x> and C<y>,
+i.e.S< >set of elements of C<x> which do not belong to C<y>.
+
+X<setminus>The library syntax is B<setminus>C<(x,y)>.
+
+=head2 X<setsearch>setsearchC<(x,y,{>I<flag>C< = 0})>
+
+searches if C<y> belongs to the set
+C<x>. If it does and I<flag> is zero or omitted, returns the index C<j> such that
+C<x[j] = y>, otherwise returns 0. If I<flag> is non-zero returns the index C<j>
+where C<y> should be inserted, and C<0> if it already belongs to C<x> (this is
+meant to be used in conjunction with C<listinsert>).
+
+This function works also if C<x> is a I<sorted> list (see C<listsort>).
+
+X<setsearch>The library syntax is B<setsearch>C<(x,y,>I<flag>C<)> which returns a C<long>
+integer.
+
+=head2 X<setunion>setunionC<(x,y)>
+
+union of the two sets C<x> and C<y>.
+
+X<setunion>The library syntax is B<setunion>C<(x,y)>.
+
+=head2 X<trace>traceC<(x)>
+
+this applies to quite general C<x>. If C<x> is not a
+matrix, it is equal to the sum of C<x> and its conjugate, except for polmods
+where it is the trace as an algebraic number.
+
+For C<x> a square matrix, it is the ordinary trace. If C<x> is a
+non-square matrix (but not a vector), an error occurs.
+
+X<gtrace>The library syntax is B<gtrace>C<(x)>.
+
+=head2 X<vecextract>vecextractC<(x,y,{z})>
+
+extraction of components of the
+vector or matrix C<x> according to C<y>. In case C<x> is a matrix, its
+components are as usual the I<columns> of C<x>. The parameter C<y> is a
+component specifier, which is either an integer, a string describing a
+range, or a vector.
+
+If C<y> is an integer, it is considered as a mask: the binary bits of C<y> are
+read from right to left, but correspond to taking the components from left to
+right. For example, if C<y = 13 = (1101)_2> then the components 1,3 and 4 are
+extracted.
+
+If C<y> is a vector, which must have integer entries, these entries correspond
+to the component numbers to be extracted, in the order specified.
+
+If C<y> is a string, it can be
+
+B<*> a single (non-zero) index giving a component number (a negative
+index means we start counting from the end).
+
+B<*> a range of the form C<"a..b">, where C<a> and C<b> are
+indexes as above. Any of C<a> and C<b> can be omitted; in this case, we take
+as default values C<a = 1> and C<b = -1>, i.e.S< >the first and last components
+respectively. We then extract all components in the interval C<[a,b]>, in
+reverse order if C<b E<lt> a>.
+
+In addition, if the first character in the string is C<^>, the
+complement of the given set of indices is taken.
+
+If C<z> is not omitted, C<x> must be a matrix. C<y> is then the I<line>
+specifier, and C<z> the I<column> specifier, where the component specifier
+is as explained above.
+
+ ? v = [a, b, c, d, e];
+ ? vecextract(v, 5) \\ mask
+ %1 = [a, c]
+ ? vecextract(v, [4, 2, 1]) \\ component list
+ %2 = [d, b, a]
+ ? vecextract(v, "2..4") \\ interval
+ %3 = [b, c, d]
+ ? vecextract(v, "-1..-3") \\ interval + reverse order
+ %4 = [e, d, c]
+ ? vecextract([1,2,3], "^2") \\ complement
+ %5 = [1, 3]
+ ? vecextract(matid(3), "2..", "..")
+ %6 =
+ [0 1 0]
+
+ [0 0 1]
+
+X<extract>The library syntax is B<extract>C<(x,y)> or X<matextract>B<matextract>C<(x,y,z)>.
+
+=head2 X<vecsort>vecsortC<(x,{k},{>I<flag>C< = 0})>
+
+sorts the vector C<x> in ascending
+order, using the heapsort method. C<x> must be a vector, and its components
+integers, reals, or fractions.
+
+If C<k> is present and is an integer, sorts according to the value of the
+C<k>-th subcomponents of the components ofS< >C<x>. C<k> can also be a vector,
+in which case the
+sorting is done lexicographically according to the components listed in the
+vector C<k>. For example, if C<k = [2,1,3]>, sorting will be done with respect
+to the second component, and when these are equal, with respect to the
+first, and when these are equal, with respect to the third.
+
+The binary digits of I<flag> mean:
+
+B<*> 1: indirect sorting of the vector C<x>, i.e.S< >if C<x> is an
+C<n>-component vector, returns a permutation of C<[1,2,...,n]> which
+applied to the components of C<x> sorts C<x> in increasing order.
+For example, C<vecextract(x, vecsort(x,,1))> is equivalent to
+C<vecsort(x)>.
+
+B<*> 2: sorts C<x> by ascending lexicographic order (as per the
+C<lex> comparison function).
+
+B<*> 4: use decreasing instead of ascending order.
+
+X<vecsort0>The library syntax is B<vecsort0>C<(x,k,flag)>. To omit C<k>, use C<NULL> instead. You can also
+use the simpler functions
+
+X<sort>B<sort>C<(x)> ( = C<vecsort0(x,NULL,0)>).
+
+X<indexsort>B<indexsort>C<(x)> ( = C<vecsort0(x,NULL,1)>).
+
+X<lexsort>B<lexsort>C<(x)> ( = C<vecsort0(x,NULL,2)>).
+
+Also available are X<sindexsort>B<sindexsort> and X<sindexlexsort>B<sindexlexsort> which return a
+vector of C-long integers (private type C<t_VECSMALL>) C<v>, where
+C<v[1]...v[n]> contain the indices. Note that the resulting C<v> is
+I<not> a generic PARI object, but is in general easier to use in C
+programs!
+
+=head2 X<vector>vectorC<(n,{X},{>I<expr>C< = 0})>
+
+creates a row vector (type
+C<t_VEC>) with C<n> components whose components are the expression
+I<expr> evaluated at the integer points between 1 and C<n>. If one of the
+last two arguments is omitted, fill the vector with zeroes.
+
+X<vecteur>The library syntax is B<vecteur>C<(GEN nmax, entree *ep, char *expr)>.
+
+=head2 X<vectorv>vectorvC<(n,X,>I<expr>C<)>
+
+as X<vector>B<vector>, but returns a
+column vector (type C<t_COL>).
+
+X<vvecteur>The library syntax is B<vvecteur>C<(GEN nmax, entree *ep, char *expr)>.
+
+=head1 Sums, products, integrals and similar functions
+
+X<Label se:sums>
+Although the GP calculator is programmable, it is useful to have
+preprogrammed a number of loops, including sums, products, and a certain
+number of recursions. Also, a number of functions from numerical analysis
+like numerical integration and summation of series will be described here.
+
+One of the parameters in these loops must be the control variable, hence a
+simple variable name. The last parameter can be any legal PARI expression,
+including of course expressions using loops. Since it is much easier to
+program directly the loops in library mode, these functions are mainly
+useful for GP programming. The use of these functions in library mode is a
+little tricky and its explanation will be mostly omitted, although the
+reader can try and figure it out by himself by checking the example given
+for the X<sum>C<sum> function. In this section we only give the library
+syntax, with no semantic explanation.
+
+The letter C<X> will always denote any simple variable name, and represents
+the formal parameter used in the function.
+
+B<(numerical) integration>:X<numerical integration> A number
+of Romberg-like integration methods are implemented (see C<intnum> as
+opposed to C<intformal> which we already described). The user should not
+require too much accuracy: 18 or 28 decimal digits is OK, but not much more.
+In addition, analytical cleanup of the integral must have been done: there
+must be no singularities in the interval or at the boundaries. In practice
+this can be accomplished with a simple change of variable. Furthermore, for
+improper integrals, where one or both of the limits of integration are plus
+or minus infinity, the function must decrease sufficiently rapidly at
+infinity. This can often be accomplished through integration by parts.
+Finally, the function to be integrated should not be very small
+(compared to the current precision) on the entire interval. This can
+of course be accomplished by just multiplying by an appropriate
+constant.
+
+Note that X<infinity>infinity can be represented with essentially no loss of
+accuracy by 1e4000. However beware of real underflow when dealing with
+rapidly decreasing functions. For example, if one wants to compute the
+F<int>C<_0^ oo e^{-x^2}dx> to 28 decimal digits, then one should set
+infinity equal to 10 for example, and certainly not to 1e4000.
+
+The integrand may have values belonging to a vector space over the real
+numbers; in particular, it can be complex-valued or vector-valued.
+
+See also the discrete summation methods below (sharing the prefix C<sum>).
+
+=head2 X<intnum>intnumC<(X = a,b,>I<expr>C<,{>I<flag>C< = 0})>
+
+numerical integration of
+I<expr> (smooth in C<]a,b[>), with respect to C<X>.
+
+Set I<flag>C< = 0> (or omit it altogether) when C<a> and C<b> are not too large, the
+function is smooth, and can be evaluated exactly everywhere on the interval
+C<[a,b]>.
+
+If I<flag>C< = 1>, uses a general driver routine for doing numerical integration,
+making no particular assumption (slow).
+
+I<flag>C< = 2> is tailored for being used when C<a> or C<b> are infinite. One
+I<must> have C<ab E<gt> 0>, and in fact if for example C<b = + oo >, then it is
+preferable to have C<a> as large as possible, at least C<a E<gt>= 1>.
+
+If I<flag>C< = 3>, the function is allowed to be undefined (but continuous) at C<a>
+or C<b>, for example the function F<sin> C<(x)/x> at C<x = 0>.
+
+X<intnum0>The library syntax is B<intnum0>C<(entree*e,GEN a,GEN b,char*expr,long >I<flag>C<,long prec)>.
+
+=head2 X<prod>prodC<(X = a,b,>I<expr>C<,{x = 1})>
+
+product of expression I<expr>,
+initialized at C<x>, the formal parameter C<X> going from C<a> to C<b>. As for
+C<sum>, the main purpose of the initialization parameter C<x> is to force
+the type of the operations being performed. For example if it is set equal to
+the integer 1, operations will start being done exactly. If it is set equal
+to the real C<1.>, they will be done using real numbers having the default
+precision. If it is set equal to the power series C<1+O(X^k)> for a certain
+C<k>, they will be done using power series of precision at most C<k>. These
+are the three most common initializations.
+
+As an extreme example, compare
+
+ ? prod(i=1, 100, 1 - X^i); \\ this has degree 5050 !!
+ time = 3,335 ms.
+ ? prod(i=1, 100, 1 - X^i, 1 + O(X^101))
+ time = 43 ms.
+ %2 = 1 - X - X^2 + X^5 + X^7 - X^12 - X^15 + X^22 + X^26 - X^35 - X^40 + \
+ X^51 + X^57 - X^70 - X^77 + X^92 + X^100 + O(X^101)
+
+X<produit>The library syntax is B<produit>C<(entree *ep, GEN a, GEN b, char *expr, GEN x)>.
+
+=head2 X<prodeuler>prodeulerC<(X = a,b,>I<expr>C<)>
+
+product of expression I<expr>,
+initialized at 1. (i.e.S< >to a I<real> number equal to 1 to the current
+C<realprecision>), the formal parameter C<X> ranging over the prime numbers
+between C<a> and C<b>.X<Euler product>
+
+X<prodeuler>The library syntax is B<prodeuler>C<(entree *ep, GEN a, GEN b, char *expr, long prec)>.
+
+=head2 X<prodinf>prodinfC<(X = a,>I<expr>C<,{>I<flag>C< = 0})>
+
+X<infinite product>infinite product of
+expression I<expr>, the formal parameter C<X> starting at C<a>. The evaluation
+stops when the relative error of the expression minus 1 is less than the
+default precision. The expressions must always evaluate to an element of
+B<C>.
+
+If I<flag>C< = 1>, do the product of the (C<1+>I<expr>) instead.
+
+X<prodinf>The library syntax is B<prodinf>C<(entree *ep, GEN a, char *expr, long prec)> (I<flag>C< = 0>), or
+X<prodinf1>B<prodinf1> with the same arguments (I<flag>C< = 1>).
+
+=head2 X<solve>solveC<(X = a,b,>I<expr>C<)>
+
+find a real root of expression
+I<expr> between C<a> and C<b>, under the condition
+I<expr>C<(X = a) * >I<expr>C<(X = b) E<lt>= 0>.
+This routine uses Brent's method and can fail miserably if I<expr> is
+not defined in the whole of C<[a,b]> (try C<solve(x = 1, 2, tan(x)>).
+
+X<zbrent>The library syntax is B<zbrent>C<(entree *ep, GEN a, GEN b, char *expr, long prec)>.
+
+=head2 X<sum>sumC<(X = a,b,>I<expr>C<,{x = 0})>
+
+sum of expression I<expr>,
+initialized at C<x>, the formal parameter going from C<a> to C<b>. As for
+C<prod>, the initialization parameter C<x> may be given to force the type
+of the operations being performed.
+
+As an extreme example, compare
+
+ ? sum(i=1, 5000, 1/i); \\ rational number: denominator has 2166 digits.
+ time = 1,241 ms.
+ ? sum(i=1, 5000, 1/i, 0.)
+ time = 158 ms.
+ %2 = 9.094508852984436967261245533
+
+X<somme>The library syntax is B<somme>C<(entree *ep, GEN a, GEN b, char *expr, GEN x)>. This is to be
+used as follows: C<ep> represents the dummy variable used in the
+expression C<expr>
+
+ /* compute a^2 + ... + b^2 */
+ {
+ /* define the dummy variable "i" */
+ entree *ep = is_entry("i");
+ /* sum for a <= i <= b */
+ return somme(ep, a, b, "i^2", gzero);
+ }
+
+=head2 X<sumalt>sumaltC<(X = a,>I<expr>C<,{>I<flag>C< = 0})>
+
+numerical summation of the
+series I<expr>, which should be an X<alternating series>alternating series, the formal
+variable C<X> starting at C<a>.
+
+If I<flag>C< = 0>, use an algorithm of F.S< >Villegas as modified by D.S< >Zagier. This
+is much better than X<Euler>Euler-Van Wijngaarden's method which was used
+formerly.
+Beware that the stopping criterion is that the term gets small enough, hence
+terms which are equal to 0 will create problems and should be removed.
+
+If I<flag>C< = 1>, use a variant with slightly different polynomials. Sometimes
+faster.
+
+Divergent alternating series can sometimes be summed by this method, as well
+as series which are not exactly alternating (see for example
+L<Label se:user_defined>).
+
+B<Important hint:> a significant speed gain can be obtained by
+writing the C<(-1)^X> which may occur in the expression as
+C<(1.S< >- X%2*2)>.
+
+X<sumalt>The library syntax is B<sumalt>C<(entree *ep, GEN a, char *expr, long >I<flag>C<, long prec)>.
+
+=head2 X<sumdiv>sumdivC<(n,X,>I<expr>C<)>
+
+sum of expression I<expr> over
+the positive divisors of C<n>.
+
+Arithmetic functions like X<sigma>B<sigma> use the multiplicativity of the
+underlying expression to speed up the computation. In the present version
+B<2.2.0>, there is no way to indicate that I<expr> is multiplicative in
+C<n>, hence specialized functions should be prefered whenever possible.
+
+X<divsum>The library syntax is B<divsum>C<(entree *ep, GEN num, char *expr)>.
+
+=head2 X<suminf>suminfC<(X = a,>I<expr>C<)>
+
+X<infinite sum>infinite sum of expression
+I<expr>, the formal parameter C<X> starting at C<a>. The evaluation stops
+when the relative error of the expression is less than the default precision.
+The expressions must always evaluate to a complex number.
+
+X<suminf>The library syntax is B<suminf>C<(entree *ep, GEN a, char *expr, long prec)>.
+
+=head2 X<sumpos>sumposC<(X = a,>I<expr>C<,{>I<flag>C< = 0})>
+
+numerical summation of the
+series I<expr>, which must be a series of terms having the same sign,
+the formal
+variable C<X> starting at C<a>. The algorithm used is Van Wijngaarden's trick
+for converting such a series into an alternating one, and is quite slow.
+Beware that the stopping criterion is that the term gets small enough, hence
+terms which are equal to 0 will create problems and should be removed.
+
+If I<flag>C< = 1>, use slightly different polynomials. Sometimes faster.
+
+X<sumpos>The library syntax is B<sumpos>C<(entree *ep, GEN a, char *expr, long >I<flag>C<, long prec)>.
+
+=head1 Plotting functions
+
+Although plotting is not even a side purpose of PARI, a number of plotting
+functions are provided. Moreover, a lot of people felt like suggesting
+ideas or submitting huge patches for this section of the code. Among these,
+special thanks go to Klaus-Peter Nischke who suggested the recursive plotting
+and the forking/resizing stuff under X11, and Ilya Zakharevich who
+undertook a complete rewrite of the graphic code, so that most of it is now
+platform-independent and should be relatively easy to port or expand.
+
+These graphic functions are either
+
+B<*> high-level plotting functions (all the functions starting with
+C<ploth>) in which the user has little to do but explain what type of plot
+he wants, and whose syntax is similar to the one used in the preceding
+section (with somewhat more complicated flags).
+
+B<*> low-level plotting functions, where every drawing primitive (point,
+line, box, etc.) must be specified by the user. These low-level functions
+(called I<rectplot> functions, sharing the prefix C<plot>) work as
+follows. You have at your disposal 16 virtual windows which are filled
+independently, and can then be physically ORed on a single window at
+user-defined positions. These windows are numbered from 0 to 15, and must be
+initialized before being used by the function C<plotinit>, which specifies
+the height and width of the virtual window (called a I<rectwindow> in the
+sequel). At all times, a virtual cursor (initialized at C<[0,0]>) is
+associated to the window, and its current value can be obtained using the
+function C<plotcursor>.
+
+A number of primitive graphic objects (called I<rect> objects) can then
+be drawn in these windows, using a default color associated to that window
+(which can be changed under X11, using the C<plotcolor> function, black
+otherwise) and only the part of the object which is inside the window will be
+drawn, with the exception of polygons and strings which are drawn entirely
+(but the virtual cursor can move outside of the window). The ones sharing the
+prefix C<plotr> draw relatively to the current position of the virtual
+cursor, the others use absolute coordinates. Those having the prefix
+C<plotrecth> put in the rectwindow a large batch of rect objects
+corresponding to the output of the related C<ploth> function.
+
+Finally, the actual physical drawing is done using the function
+C<plotdraw>. Note that the windows are preserved so that further drawings
+using the same windows at different positions or different windows can be
+done without extra work. If you want to erase a window (and free the
+corresponding memory), use the function C<plotkill>. It is not possible to
+partially erase a window. Erase it completely, initialize it again and then
+fill it with the graphic objects that you want to keep.
+
+In addition to initializing the window, you may want to have a scaled
+window to avoid unnecessary conversions. For this, use the function
+C<plotscale> below. As long as this function is not called, the scaling is
+simply the number of pixels, the origin being at the upper left and the
+C<y>-coordinates going downwards.
+
+Note that in the present version B<2.2.0> all these plotting functions
+(both low and high level) have been written for the X11-window system
+(hence also for GUI's based on X11 such as Openwindows and Motif) only,
+though very little code remains which is actually platform-dependent. A
+Suntools/Sunview, Macintosh, and an Atari/Gem port were provided for
+previous versions. These I<may> be adapted in future releases.
+
+Under X11/Suntools, the physical window (opened by C<plotdraw> or any
+of the C<ploth*> functions) is completely separated from GP (technically,
+a C<fork> is done, and the non-graphical memory is immediately freed in
+the child process), which means you can go on working in the current GP
+session, without having to kill the window first. Under X11, this window can
+be closed, enlarged or reduced using the standard window manager functions.
+No zooming procedure is implemented though (yet).
+
+B<*> Finally, note that in the same way that C<printtex> allows you
+to have a TeX output corresponding to printed results, the functions
+starting with C<ps> allow you to have X<PostScript>C<PostScript> output of the
+plots. This will not be absolutely identical with the screen output, but will
+be sufficiently close. Note that you can use PostScript output even if you do
+not have the plotting routines enabled. The PostScript output is written in a
+file whose name is derived from the X<psfile>C<psfile> default (C<./pari.ps> if
+you did not tamper with it). Each time a new PostScript output is asked for,
+the PostScript output is appended to that file. Hence the user must remove
+this file, or change the value of C<psfile>, first if he does not want
+unnecessary drawings from preceding sessions to appear. On the other hand, in
+this manner as many plots as desired can be kept in a single file.
+
+I<None of the graphic functions are available within the PARI library, you
+must be under GP to use them>. The reason for that is that you really should
+not use PARI for heavy-duty graphical work, there are much better specialized
+alternatives around. This whole set of routines was only meant as a
+convenient, but simple-minded, visual aid. If you really insist on using
+these in your program (we warned you), the source (C<plot*.c>) should be
+readable enough for you to achieve something.
+
+=head2 X<plot>plotC<(X = a,b,>I<expr>C<,{>I<Ymin>C<},{>I<Ymax>C<})>
+
+crude
+(ASCII) plot of the function represented by expression I<expr> from
+C<a> to C<b>, with I<Y> ranging from I<Ymin> to I<Ymax>. If
+I<Ymin> (resp. I<Ymax>) is not given, the minima (resp. the
+maxima) of the computed values of the expression is used instead.
+
+=head2 X<plotbox>plotboxC<(w,x2,y2)>
+
+let C<(x1,y1)> be the current position of the
+virtual cursor. Draw in the rectwindow C<w> the outline of the rectangle which
+is such that the points C<(x1,y1)> and C<(x2,y2)> are opposite corners. Only
+the part of the rectangle which is in C<w> is drawn. The virtual cursor does
+I<not> move.
+
+=head2 X<plotclip>plotclipC<(w)>
+
+`clips' the content of rectwindow C<w>, i.e
+remove all parts of the drawing that would not be visible on the screen.
+Together with X<plotcopy>C<plotcopy> this function enables you to draw on a
+scratchpad before commiting the part you're interested in to the final
+picture.
+
+=head2 X<plotcolor>plotcolorC<(w,c)>
+
+set default color to C<c> in rectwindow C<w>.
+In present version B<2.2.0>, this is only implemented for X11 window system,
+and you only have the following palette to choose from:
+
+1 = black, 2 = blue, 3 = sienna, 4 = red, 5 = cornsilk, 6 = grey, 7 = gainsborough.
+
+Note that it should be fairly easy for you to hardwire some more colors by
+tweaking the files C<rect.h> and C<plotX.c>. User-defined
+colormaps would be nice, and I<may> be available in future versions.
+
+=head2 X<plotcopy>plotcopyC<(w1,w2,dx,dy)>
+
+copy the contents of rectwindow
+C<w1> to rectwindow C<w2>, with offset C<(dx,dy)>.
+
+=head2 X<plotcursor>plotcursorC<(w)>
+
+give as a 2-component vector the current
+(scaled) position of the virtual cursor corresponding to the rectwindow C<w>.
+
+=head2 X<plotdraw>plotdrawC<(list)>
+
+physically draw the rectwindows given in C<list>
+which must be a vector whose number of components is divisible by 3. If
+C<list = [w1,x1,y1,w2,x2,y2,...]>, the windows C<w1>, C<w2>, etc.S< >are
+physically placed with their upper left corner at physical position
+C<(x1,y1)>, C<(x2,y2)>,...respectively, and are then drawn together.
+Overlapping regions will thus be drawn twice, and the windows are considered
+transparent. Then display the whole drawing in a special window on your
+screen.
+
+=head2 X<plotfile>plotfileC<(s)>
+
+set the output file for plotting output. Special
+filename C<-> redirects to the same place as PARI output.
+
+=head2 X<ploth>plothC<(X = a,b,>I<expr>C<,{>I<flag>C< = 0},{n = 0})>
+
+high precision
+plot of the function C<y = f(x)> represented by the expression I<expr>, C<x>
+going from C<a> to C<b>. This opens a specific window (which is killed
+whenever you click on it), and returns a four-component vector giving the
+coordinates of the bounding box in the form
+C<[>I<xmin>C<,>I<xmax>C<,>I<ymin>C<,>I<ymax>C<]>.
+
+B<Important note>: Since this may involve a lot of function calls,
+it is advised to keep the current precision to a minimum (e.g.S< >9) before
+calling this function.
+
+C<n> specifies the number of reference point on the graph (0 means use the
+hardwired default values, that is: 1000 for general plot, 1500 for
+parametric plot, and 15 for recursive plot).
+
+If no I<flag> is given, I<expr> is either a scalar expression C<f(X)>, in which
+case the plane curve C<y = f(X)> will be drawn, or a vector
+C<[f_1(X),...,f_k(X)]>, and then all the curves C<y = f_i(X)> will be drawn in
+the same window.
+
+The binary digits of I<flag> mean:
+
+B<*> 1: X<parametric plot>I<parametric plot>. Here I<expr> must be a vector with
+an even number of components. Successive pairs are then understood as the
+parametric coordinates of a plane curve. Each of these are then drawn.
+
+For instance:
+
+C<ploth(X = 0,2*Pi,[sin(X),cos(X)],1)> will draw a circle.
+
+C<ploth(X = 0,2*Pi,[sin(X),cos(X)])> will draw two entwined sinusoidal
+curves.
+
+C<ploth(X = 0,2*Pi,[X,X,sin(X),cos(X)],1)> will draw a circle and the line
+C<y = x>.
+
+B<*> 2: X<recursive plot>I<recursive plot>. If this flag is set, only I<one>
+curve can be drawn at time, i.e.S< >I<expr> must be either a two-component
+vector (for a single parametric curve, and the parametric flag I<has> to
+be set), or a scalar function. The idea is to choose pairs of successive
+reference points, and if their middle point is not too far away from the
+segment joining them, draw this as a local approximation to the curve.
+Otherwise, add the middle point to the reference points. This is very fast,
+and usually more precise than usual plot. Compare the results of
+
+S< >C<ploth(X = -1,1,sin(1/X),2) and ploth(X = -1,1,sin(1/X))>
+
+for instance. But beware that if you are extremely unlucky, or choose too few
+reference points, you may draw some nice polygon bearing little resemblance
+to the original curve. For instance you should I<never> plot recursively
+an odd function in a symmetric interval around 0. Try
+
+ ploth(x = -20, 20, sin(x), 2)
+
+to see why. Hence, it's usually a good idea to try and plot the same
+curve with slightly different parameters.
+
+The other values toggle various display options:
+
+B<*> 4: do not rescale plot according to the computed extrema. This is
+meant to be used when graphing multiple functions on a rectwindow (as a
+X<plotrecth>C<plotrecth> call), in conjuction with X<plotscale>C<plotscale>.
+
+B<*> 8: do not print the C<x>-axis.
+
+B<*> 16: do not print the C<y>-axis.
+
+B<*> 32: do not print frame.
+
+B<*> 64: only plot reference points, do not join them.
+
+B<*> 256: use splines to interpolate the points.
+
+B<*> 512: plot no C<x>-ticks.
+
+B<*> 1024: plot no C<y>-ticks.
+
+B<*> 2048: plot all ticks with the same length.
+
+=head2 X<plothraw>plothrawC<(>I<listx>C<,>I<listy>C<,{>I<flag>C< = 0})>
+
+given
+I<listx> and I<listy> two vectors of equal length, plots (in high
+precision) the points whose C<(x,y)>-coordinates are given in I<listx>
+and I<listy>. Automatic positioning and scaling is done, but with the
+same scaling factor on C<x> and C<y>. If I<flag> is 1, join points, other non-0
+flags toggle display options and should be combinations of bits C<2^k>, C<k
+ E<gt>= 3> as in C<ploth>.
+
+=head2 X<plothsizes>plothsizesC<()>
+
+return data corresponding to the output window
+in the form of a 6-component vector: window width and height, sizes for ticks
+in horizontal and vertical directions (this is intended for the C<gnuplot>
+interface and is currently not significant), width and height of characters.
+
+=head2 X<plotinit>plotinitC<(w,x,y)>
+
+initialize the rectwindow C<w> to width C<x> and
+height C<y>, and position the virtual cursor at C<(0,0)>. This destroys any rect
+objects you may have already drawn in C<w>.
+
+The plotting device imposes an upper bound for C<x> and C<y>, for instance the
+number of pixels for screen output. These bounds are available through the
+X<plothsizes>C<plothsizes> function. The following sequence initializes in a portable way
+(i.e independant of the output device) a window of maximal size, accessed through
+coordinates in the C<[0,1000] x [0,1000]> rangeS< >:
+
+ s = plothsizes();
+ plotinit(0, s[1]-1, s[2]-1);
+ plotscale(0, 0,1000, 0,1000);
+
+=head2 X<plotkill>plotkillC<(w)>
+
+erase rectwindow C<w> and free the corresponding
+memory. Note that if you want to use the rectwindow C<w> again, you have to
+use C<initrect> first to specify the new size. So it's better in this case
+to use C<initrect> directly as this throws away any previous work in the
+given rectwindow.
+
+=head2 X<plotlines>plotlinesC<(w,X,Y,{>I<flag>C< = 0})>
+
+draw on the rectwindow C<w>
+the polygon such that the (x,y)-coordinates of the vertices are in the
+vectors of equal length C<X> and C<Y>. For simplicity, the whole
+polygon is drawn, not only the part of the polygon which is inside the
+rectwindow. If I<flag> is non-zero, close the polygon. In any case, the
+virtual cursor does not move.
+
+C<X> and C<Y> are allowed to be scalars (in this case, both have to).
+There, a single segment will be drawn, between the virtual cursor current
+position and the point C<(X,Y)>. And only the part thereof which
+actually lies within the boundary of C<w>. Then I<move> the virtual cursor
+to C<(X,Y)>, even if it is outside the window. If you want to draw a
+line from C<(x1,y1)> to C<(x2,y2)> where C<(x1,y1)> is not necessarily the
+position of the virtual cursor, use C<plotmove(w,x1,y1)> before using this
+function.
+
+=head2 X<plotlinetype>plotlinetypeC<(w,>I<type>C<)>
+
+change the type of lines
+subsequently plotted in rectwindow C<w>. I<type> C<-2> corresponds to
+frames, C<-1> to axes, larger values may correspond to something else. C<w =
+-1> changes highlevel plotting. This is only taken into account by the
+C<gnuplot> interface.
+
+=head2 X<plotmove>plotmoveC<(w,x,y)>
+
+move the virtual cursor of the rectwindow C<w>
+to position C<(x,y)>.
+
+=head2 X<plotpoints>plotpointsC<(w,X,Y)>
+
+draw on the rectwindow C<w> the
+points whose C<(x,y)>-coordinates are in the vectors of equal length C<X> and
+C<Y> and which are inside C<w>. The virtual cursor does I<not> move. This
+is basically the same function as C<plothraw>, but either with no scaling
+factor or with a scale chosen using the function C<plotscale>.
+
+As was the case with the C<plotlines> function, C<X> and C<Y> are allowed to
+be (simultaneously) scalar. In this case, draw the single point C<(X,Y)> on
+the rectwindow C<w> (if it is actually inside C<w>), and in any case
+I<move> the virtual cursor to position C<(x,y)>.
+
+=head2 X<plotpointsize>plotpointsizeC<(w,size)>
+
+changes the ``size'' of following
+points in rectwindow C<w>. If C<w = -1>, change it in all rectwindows.
+This only works in the C<gnuplot> interface.
+
+=head2 X<plotpointtype>plotpointtypeC<(w,>I<type>C<)>
+
+change the type of
+points subsequently plotted in rectwindow C<w>. I<type>C< = -1>
+corresponds to a dot, larger values may correspond to something else. C<w = -1>
+changes highlevel plotting. This is only taken into account by the
+C<gnuplot> interface.
+
+=head2 X<plotrbox>plotrboxC<(w,dx,dy)>
+
+draw in the rectwindow C<w> the outline of
+the rectangle which is such that the points C<(x1,y1)> and C<(x1+dx,y1+dy)> are
+opposite corners, where C<(x1,y1)> is the current position of the cursor.
+Only the part of the rectangle which is in C<w> is drawn. The virtual cursor
+does I<not> move.
+
+=head2 X<plotrecth>plotrecthC<(w,X = a,b,>I<expr>C<,{>I<flag>C< = 0},{n = 0})>
+
+writes to
+rectwindow C<w> the curve output of C<ploth>C<(w,X = a,b,>I<expr>C<,>I<flag>C<,n)>.
+
+=head2 X<plotrecthraw>plotrecthrawC<(w,>I<data>C<,{>I<flag>C< = 0})>
+
+plot graph(s) for
+I<data> in rectwindow C<w>. I<flag> has the same significance here as in
+C<ploth>, though recursive plot is no more significant.
+
+I<data> is a vector of vectors, each corresponding to a list a coordinates.
+If parametric plot is set, there must be an even number of vectors, each
+successive pair corresponding to a curve. Otherwise, the first one containe
+the C<x> coordinates, and the other ones contain the C<y>-coordinates
+of curves to plot.
+
+=head2 X<plotrline>plotrlineC<(w,dx,dy)>
+
+draw in the rectwindow C<w> the part of the
+segment C<(x1,y1)-(x1+dx,y1+dy)> which is inside C<w>, where C<(x1,y1)> is the
+current position of the virtual cursor, and move the virtual cursor to
+C<(x1+dx,y1+dy)> (even if it is outside the window).
+
+=head2 X<plotrmove>plotrmoveC<(w,dx,dy)>
+
+move the virtual cursor of the rectwindow
+C<w> to position C<(x1+dx,y1+dy)>, where C<(x1,y1)> is the initial position of
+the cursor (i.e.S< >to position C<(dx,dy)> relative to the initial cursor).
+
+=head2 X<plotrpoint>plotrpointC<(w,dx,dy)>
+
+draw the point C<(x1+dx,y1+dy)> on the
+rectwindow C<w> (if it is inside C<w>), where C<(x1,y1)> is the current position
+of the cursor, and in any case move the virtual cursor to position
+C<(x1+dx,y1+dy)>.
+
+=head2 X<plotscale>plotscaleC<(w,x1,x2,y1,y2)>
+
+scale the local coordinates of the
+rectwindow C<w> so that C<x> goes from C<x1> to C<x2> and C<y> goes from C<y1> to
+C<y2> (C<x2 E<lt> x1> and C<y2 E<lt> y1> being allowed). Initially, after the initialization
+of the rectwindow C<w> using the function C<plotinit>, the default scaling
+is the graphic pixel count, and in particular the C<y> axis is oriented
+downwards since the origin is at the upper left. The function C<plotscale>
+allows to change all these defaults and should be used whenever functions are
+graphed.
+
+=head2 X<plotstring>plotstringC<(w,x,{>I<flag>C< = 0})>
+
+draw on the rectwindow C<w> the
+String C<x> (see L<Label se:strings>), at the current position of the cursor.
+
+I<flag> is used for justification: bits 1 and 2 regulate horizontal alignment:
+left if 0, right if 2, center if 1. Bits 4 and 8 regulate vertical
+alignment: bottom if 0, top if 8, v-center if 4. Can insert additional
+small gap between point and string: horizontal if bit 16 is set, vertical
+if bit 32 is set (see the tutorial for an example).
+
+=head2 X<plotterm>plottermC<(>I<term>C<)>
+
+sets terminal where high resolution
+plots go (this is currently only taken into account by the C<gnuplot>
+graphical driver). Using the C<gnuplot> driver, possible terminals are
+the same as in gnuplot. If I<term> is "?", lists possible values.
+
+Terminal options can be appended to the terminal name and space; terminal
+size can be put immediately after the name, as in C<"gif = 300,200">.
+Positive return value means success.
+
+=head2 X<psdraw>psdrawC<(>I<list>C<)>
+
+same as C<plotdraw>, except that the
+output is a PostScript program appended to the C<psfile>.
+
+=head2 X<psploth>psplothC<(X = a,b,>I<expr>C<)>
+
+same as C<ploth>, except that the
+output is a PostScript program appended to the C<psfile>.
+
+=head2 X<psplothraw>psplothrawC<(>I<listx>C<,>I<listy>C<)>
+
+same as C<plothraw>,
+except that the output is a PostScript program appended to the C<psfile>.
+
+=head1 Programming under GP
+
+X<programming>X<Label se:programming>
+=head2 Control statements.
+
+A number of control statements are available under GP. They are simpler and
+have a syntax slightly different from their C counterparts, but are quite
+powerful enough to write any kind of program. Some of them are specific to
+GP, since they are made for number theorists. As usual, C<X> will denote any
+simple variable name, and I<seq> will always denote a sequence of
+expressions, including the empty sequence.
+
+=item X<break>breakC<({n = 1})>
+
+interrupts execution of current I<seq>, and
+immediately exits from the C<n> innermost enclosing loops, within the
+current function call (or the top level loop). C<n> must be bigger than 1.
+If C<n> is greater than the number of enclosing loops, all enclosing loops
+are exited.
+
+=item X<for>forC<(X = a,b,>I<seq>C<)>
+
+the formal variable C<X> going from
+C<a> to C<b>, the I<seq> is evaluated. Nothing is done if C<a E<gt> b>.
+C<a> and C<b> must be in B<R>.
+
+=item X<fordiv>fordivC<(n,X,>I<seq>C<)>
+
+the formal variable C<X> ranging
+through the positive divisors of C<n>, the sequence I<seq> is evaluated.
+C<n> must be of type integer.
+
+=item X<forprime>forprimeC<(X = a,b,>I<seq>C<)>
+
+the formal variable C<X>
+ranging over the prime numbers between C<a> to C<b> (including C<a> and C<b>
+if they are prime), the I<seq> is evaluated. More precisely, the value
+of C<X> is incremented to the smallest prime strictly larger than C<X> at the
+end of each iteration. Nothing is done if C<a E<gt> b>. Note that C<a> and C<b> must
+be in B<R>.
+
+ ? { forprime(p = 2, 12,
+ print(p);
+ if (p == 3, p = 6);
+ )
+ }
+ 2
+ 3
+ 7
+ 11
+
+=item X<forstep>forstepC<(X = a,b,s,>I<seq>C<)>
+
+the formal variable C<X>
+going from C<a> to C<b>, in increments of C<s>, the I<seq> is evaluated.
+Nothing is done if C<s E<gt> 0> and C<a E<gt> b> or if C<s E<lt> 0> and C<a E<lt> b>. C<s> must be in
+B<R>C<^*> or a vector of steps C<[s_1,...,s_n]>. In the latter case, the
+successive steps are used in the order they appear in C<s>.
+
+ ? forstep(x=5, 20, [2,4], print(x))
+ 5
+ 7
+ 11
+ 13
+ 17
+ 19
+
+=item X<forsubgroup>forsubgroupC<(H = G,{B},>I<seq>C<)>
+
+executes I<seq> for
+each subgroup C<H> of the I<abelian> group C<G> (given in
+SNFX<Smith normal form> form or as a vector of elementary divisors),
+whose index is bounded by bound. The subgroups are not ordered in any
+obvious way, unless C<G> is a C<p>-group in which case Birkhoff's algorithm
+produces them by decreasing index. A X<subgroup>subgroup is given as a matrix
+whose columns give its generators on the implicit generators of C<G>. For
+example, the following prints all subgroups of index less than 2 in C<G =
+>B<Z>C</2>B<Z>C< g_1 x >B<Z>C</2>B<Z>C< g_2>S< >:
+
+ ? G = [2,2]; forsubgroup(H=G, 2, print(H))
+ [1; 1]
+ [1; 2]
+ [2; 1]
+ [1, 0; 1, 1]
+
+The last one, for instance is generated by C<(g_1, g_1 + g_2)>. This
+routine is intended to treat huge groups, when X<subgrouplist>B<subgrouplist> is not an
+option due to the sheer size of the output.
+
+For maximal speed the subgroups have been left as produced by the algorithm.
+To print them in canonical form (as left divisors of C<G> in
+HNFX<Hermite normal form> form), one can for instance use
+
+ ? G = matdiagonal([2,2]); forsubgroup(H=G, 2, print(mathnf(concat(G,H))))
+ [2, 1; 0, 1]
+ [1, 0; 0, 2]
+ [2, 0; 0, 1]
+ [1, 0; 0, 1]
+
+Note that in this last representation, the index C<[G:H]> is given by the
+determinant.
+
+=item X<forvec>forvecC<(X = v,>I<seq>C<,{>I<flag>C< = 0})>
+
+C<v> being an C<n>-component
+vector (where C<n> is arbitrary) of two-component vectors C<[a_i,b_i]>
+for C<1 E<lt>= i E<lt>= n>, the I<seq> is evaluated with the formal variable
+C<X[1]> going from C<a_1> to C<b_1>,...,C<X[n]> going from C<a_n> to C<b_n>.
+The formal variable with the highest index moves the fastest. If I<flag>C< = 1>,
+generate only nondecreasing vectors C<X>, and if I<flag>C< = 2>, generate only
+strictly increasing vectors C<X>.
+
+=item X<if>ifC<(a,{>I<seq1>C<},{>I<seq2>C<})>
+
+if C<a> is non-zero,
+the expression sequence I<seq1> is evaluated, otherwise the expression
+I<seq2> is evaluated. Of course, I<seq1> or I<seq2> may be empty,
+so C<if (a,>I<seq>C<)> evaluates I<seq> if C<a> is not equal to zero
+(you don't have to write the second comma), and does nothing otherwise,
+whereas C<if (a,,>I<seq>C<)> evaluates I<seq> if C<a> is equal to
+zero, and does nothing otherwise. You could get the same result using
+the C<!> (C<not>) operator: C<if (!a,>I<seq>C<)>.
+
+Note that the boolean operators C<&&> and C<||> are evaluated
+according to operator precedence as explained in L<Label se:operators>, but
+that, contrary to other operators, the evaluation of the arguments is
+stopped as soon as the final truth value has been determined. For instance
+
+ if (reallydoit && longcomplicatedfunction(), ...)%
+
+is a perfectly safe statement.
+
+Recall that functions such as C<break> and C<next> operate on
+I<loops> (such as C<forxxx>, C<while>, C<until>). The C<if>
+statement is I<not> a loop (obviously!).
+
+=item X<next>nextC<({n = 1})>
+
+interrupts execution of current C<seq>,
+resume the next iteration of the innermost enclosing loop, within the
+current fonction call (or top level loop). If C<n> is specified, resume at
+the C<n>-th enclosing loop. If C<n> is bigger than the number of enclosing
+loops, all enclosing loops are exited.
+
+=item X<return>returnC<({x = 0})>
+
+returns from current subroutine, with
+result C<x>.
+
+=item X<until>untilC<(a,>I<seq>C<)>
+
+evaluates expression sequence I<seq>
+until C<a> is not equal to 0 (i.e.S< >until C<a> is true). If C<a> is initially
+not equal to 0, I<seq> is evaluated once (more generally, the condition
+on C<a> is tested I<after> execution of the I<seq>, not before as in
+C<while>).
+
+=item X<while>whileC<(a,>I<seq>C<)>
+
+while C<a> is non-zero evaluate the
+expression sequence I<seq>. The test is made I<before> evaluating
+the C<seq>, hence in particular if C<a> is initially equal to zero the
+I<seq> will not be evaluated at all.
+
+=head2 Specific functions used in GP programming
+
+X<Label se:gp_program>
+In addition to the general PARI functions, it is necessary to have some
+functions which will be of use specifically for GP, though a few of these can
+be accessed under library mode. Before we start describing these, we recall
+the difference between I<strings> and I<keywords> (see
+L<Label se:strings>): the latter don't get expanded at all, and you can type
+them without any enclosing quotes. The former are dynamic objects, where
+everything outside quotes gets immediately expanded.
+
+We need an additional notation for this chapter. An argument between braces,
+followed by a star, like C<{>I<str>C<}*>, means that any number of such
+arguments (possibly none) can be given.
+
+=item X<addhelp>addhelpC<(S,>I<str>C<)>
+
+X<Label se:addhelp> changes the help
+message for the symbol C<S>. The string I<str> is expanded on the spot
+and stored as the online help for C<S>. If C<S> is a function I<you> have
+defined, its definition will still be printed before the message I<str>.
+It is recommended that you document global variables and user functions in
+this way. Of course GP won't protest if you don't do it.
+
+There's nothing to prevent you from modifying the help of built-in PARI
+functions (but if you do, we'd like to hear why you needed to do it!).
+
+=item X<alias>aliasC<(>I<newkey>C<,>I<key>C<)>
+
+defines the keyword
+I<newkey> as an alias for keyword I<key>. I<key> must correspond
+to an existing I<function> name. This is different from the general user
+macros in that alias expansion takes place immediately upon execution,
+without having to look up any function code, and is thus much faster. A
+sample alias file C<misc/gpalias> is provided with the standard
+distribution. Alias commands are meant to be read upon startup from the
+C<.gprc> file, to cope with function names you are dissatisfied with, and
+should be useless in interactive usage.
+
+=item X<allocatemem>allocatememC<({x = 0})>
+
+this is a very special operation which
+allows the user to change the stack size I<after> initialization. C<x>
+must be a non-negative integer. If C<x! = 0>, a new stack of size C<16*\lceil
+x/16\rceil> bytes will be allocated, all the PARI data on the old stack will
+be moved to the new one, and the old stack will be discarded. If C<x = 0>, the
+size of the new stack will be twice the size of the old one.
+
+Although it is a function, this must be the I<last> instruction in any GP
+sequence. The technical reason is that this routine usually moves the stack,
+so objects from the current sequence might not be correct anymore. Hence, to
+prevent such problems, this routine terminates by a C<longjmp> (just as an
+error would) and not by a return.
+
+X<allocatemoremem>The library syntax is B<allocatemoremem>C<(x)>, where C<x> is an unsigned long, and the return type
+is void. GP uses a variant which ends by a C<longjmp>.
+
+=item X<default>defaultC<({>I<key>C<},{>I<val>C<},{>I<flag>C<})>
+
+sets the default
+corresponding to keyword I<key> to value I<val>. I<val> is a string
+(which of course accepts numeric arguments without adverse effects, due to the
+expansion mechanism). See L<Label se:defaults> for a list of available
+defaults, and L<Label se:meta> for some shortcut alternatives. Typing
+C<default()> (or C<\d>) yields the complete default list as well as
+their current values.X<Label se:default>
+
+If I<val> is omitted, prints the current value of default I<key>.
+If I<flag> is set, returns the result instead of printing it.
+
+=item X<error>errorC<({>I<str>C<}*)>
+
+outputs its argument list (each of
+them interpreted as a string), then interrupts the running GP program,
+returning to the input prompt.
+
+Example: C<error("n = ", n, " is not squarefree !")>.
+
+Note that, due to the automatic concatenation of strings, you could in fact
+use only one argument, just by suppressing the commas.
+
+=item X<extern>externC<(>I<str>C<)>
+
+the string I<str> is the name
+of an external command (i.e.S< >one you would type from your UNIX shell prompt).
+This command is immediately run and its input fed into GP, just as if read
+from a file.
+
+=item X<getheap>getheapC<()>
+
+returns a two-component row vector giving the
+number of objects on the heap and the amount of memory they occupy in long
+words. Useful mainly for debugging purposes.
+
+X<getheap>The library syntax is B<getheap>C<()>.
+
+=item X<getrand>getrandC<()>
+
+returns the current value of the random number
+seed. Useful mainly for debugging purposes.
+
+X<getrand>The library syntax is B<getrand>C<()>, returns a C long.
+
+=item X<getstack>getstackC<()>
+
+returns the current value of
+C<top-avma>,
+i.e.S< >the number of bytes used up to now on the stack. Should be equal to 0
+in between commands. Useful mainly for debugging purposes.
+
+X<getstack>The library syntax is B<getstack>C<()>, returns a C long.
+
+=item X<gettime>gettimeC<()>
+
+returns the time (in milliseconds) elapsed since
+either the last call to C<gettime>, or to the beginning of the containing
+GP instruction (if inside GP), whichever came last.
+
+X<gettime>The library syntax is B<gettime>C<()>, returns a C long.
+
+=item X<global>globalC<({>I<list of variables>C<})>
+
+X<Label se:global>
+declares the corresponding variables to be global. From now on, you will be
+forbidden to use them as formal parameters for function definitions or as
+loop indexes. This is especially useful when patching together various
+scripts, possibly written with different naming conventions. For instance the
+following situation is dangerous:
+
+ p = 3 \\ fix characteristic
+ ...
+ forprime(p = 2, N, ...)
+ f(p) = ...
+
+since within the loop or within the function's body (even worse: in the
+subroutines called in that scope), the true global value of C<p> will be
+hidden. If the statement C<global(p = 3)> appears at the beginning of
+the script, then both expressions will trigger syntax errors.
+
+Calling C<global> without arguments prints the list of global variables in
+use. In particular, C<eval(global)> will output the values of all local
+variables.
+
+=item X<input>inputC<()>
+
+reads a string, interpreted as a GP expression,
+from the input file, usually standard input (i.e.S< >the keyboard). If a
+sequence of expressions is given, the result is the result of the last
+expression of the sequence. When using this instruction, it is useful to
+prompt for the string by using the C<print1> function. Note that in the
+present version 2.19 of C<pari.el>, when using GP under GNU Emacs (see
+L<Label se:emacs>) one I<must> prompt for the string, with a string
+which ends with the same prompt as any of the previous ones (a C<"? ">
+will do for instance).
+
+=item X<install>installC<(>I<name>C<,>I<code>C<,{>I<gpname>C<},{>I<lib>C<})>
+
+loads from dynamic library I<lib> the function I<name>. Assigns to it
+the name I<gpname> in this GP session, with argument code I<code> (see
+L<Label se:gp.interface> for an explanation of those). If I<lib> is
+omitted, uses C<libpari.so>. If I<gpname> is omitted, uses
+I<name>.X<Label se:install>
+
+This function is useful for adding custom functions to the GP interpreter,
+or picking useful functions from unrelated libraries. For instance, it
+makes the function X<system>C<system> obsolete:
+
+ ? install(system, vs, sys, "libc.so")
+ ? sys("ls gp*")
+ gp.c gp.h gp_rl.c
+
+But it also gives you access to all (non static) functions defined in the
+PARI library. For instance, the function C<GEN addii(GEN x, GEN y)> adds
+two PARI integers, and is not directly accessible under GP (it's eventually
+called by the C<+> operator of course):
+
+ ? install("addii", "GG")
+ ? addii(1, 2)
+ %1 = 3
+
+B<Caution:> This function may not work on all systems, especially
+when GP has been compiled statically. In that case, the first use of an
+installed function will provoke a Segmentation Fault, i.e.S< >a major internal
+blunder (this should never happen with a dynamically linked executable).
+Hence, if you intend to use this function, please check first on some
+harmless example such as the ones above that it works properly on your
+machine.
+
+=item X<kill>killC<(s)>
+
+X<Label se:kill> kills the present value of the
+variable, alias or user-defined function C<s>. The corresponding identifier
+can now be used to name any GP object (variable or function). This is the
+only way to replace a variable by a function having the same name (or the
+other way round), as in the following example:
+
+ ? f = 1
+ %1 = 1
+ ? f(x) = 0
+ *** unused characters: f(x)=0
+ ^----
+ ? kill(f)
+ ? f(x) = 0
+ ? f()
+ %2 = 0
+
+When you kill a variable, all objects that used it become invalid. You
+can still display them, even though the killed variable will be printed in a
+funny way (following the same convention as used by the library function
+C<fetch_var>, seeS< >L<Label se:vars>). For example:
+
+ ? a^2 + 1
+ %1 = a^2 + 1
+ ? kill(a)
+ ? %1
+ %2 = #<1>^2 + 1
+
+If you simply want to restore a variable to its ``undefined'' value
+(monomial of degree one), use the X<quote>quote operator: C<a = 'a>.
+Predefined symbols (C<x> and GP function names) cannot be killed.
+
+=item X<print>printC<({>I<str>C<}*)>
+
+outputs its (string) arguments in raw
+format, ending with a newline.
+
+=item X<print1>print1C<({>I<str>C<}*)>
+
+outputs its (string) arguments in raw
+format, without ending with a newline (note that you can still embed newlines
+within your strings, using the C<\n> notationS< >!).
+
+=item X<printp>printpC<({>I<str>C<}*)>
+
+outputs its (string) arguments in
+prettyprint (beautified) format, ending with a newline.
+
+=item X<printp1>printp1C<({>I<str>C<}*)>
+
+outputs its (string) arguments in
+prettyprint (beautified) format, without ending with a newline.
+
+=item X<printtex>printtexC<({>I<str>C<}*)>
+
+outputs its (string) arguments in
+TeX format. This output can then be used in a TeX manuscript.
+The printing is done on the standard output. If you want to print it to a
+file you should use C<writetex> (see there).
+
+Another possibility is to enable the X<log>C<log> default
+(seeS< >L<Label se:defaults>).
+You could for instance do:X<logfile>
+
+ default(logfile, "new.tex");
+ default(log, 1);
+ printtex(result);
+
+(You can use the automatic string expansion/concatenation process to have
+dynamic file names if you wish).
+
+=item X<quit>quitC<()>
+
+exits GP.X<Label se:quit>
+
+=item X<read>readC<({>I<str>C<})>
+
+reads in the file whose name results
+from the expansion of the string I<str>. If I<str> is omitted,
+re-reads the last file that was fed into GP. The return value is the result of
+the last expression evaluated.X<Label se:read>
+
+=item X<reorder>reorderC<({x = []})>
+
+C<x> must be a vector. If C<x> is the
+empty vector, this gives the vector whose components are the existing
+variables in increasing order (i.e.S< >in decreasing importance). Killed
+variables (see C<kill>) will be shown as C<0>. If C<x> is
+non-empty, it must be a permutation of variable names, and this permutation
+gives a new order of importance of the variables, I<for output only>. For
+example, if the existing order is C<[x,y,z]>, then after
+C<reorder([z,x])> the order of importance of the variables, with respect
+to output, will be C<[z,y,x]>. The internal representation is unaffected.
+X<Label se:reorder>
+
+=item X<setrand>setrandC<(n)>
+
+reseeds the random number generator to the value
+C<n>. The initial seed is C<n = 1>.
+
+X<setrand>The library syntax is B<setrand>C<(n)>, where C<n> is a C<long>. Returns C<n>.
+
+=item X<system>systemC<(>I<str>C<)>
+
+I<str> is a string representing
+a system command. This command is executed, its output written to the
+standard output (this won't get into your logfile), and control returns
+to the PARI system. This simply calls the C C<system> command.
+
+=item X<trap>trapC<({e}, {>I<rec>C<}, {>I<seq>C<})>
+
+tries to
+execute I<seq>, trapping error C<e>, that is effectively preventing it
+from aborting computations in the usual way; the recovery sequence
+I<rec> is executed if the error occurs and the evaluation of I<rec>
+becomes the result of the command. If C<e> is omitted, all exceptions are
+trapped. Note in particular that hitting C<^C> (Control-C) raises an
+exception.
+
+ ? \\ trap division by 0
+ ? inv(x) = trap (gdiver2, INFINITY, 1/x)
+ ? inv(2)
+ %1 = 1/2
+ ? inv(0)
+ %2 = INFINITY
+
+If I<seq> is omitted, defines I<rec> as a default action when
+encountering exception C<e>. The error message is printed, as well as the
+result of the evaluation of I<rec>, and the control is given back to the
+GP prompt. In particular, current computation is then lost.
+
+The following error handler prints the list of all user variables, then
+stores in a file their name and their values:
+
+ ? { trap( ,
+ print(reorder);
+ write("crash", reorder);
+ write("crash", eval(reorder))) }
+
+If no recovery code is given (I<rec> is omitted) a so-called
+X<break loop>I<break loop> will be started. During a break loop, all commands are
+read and evaluated as during the main GP loop (except that no history of
+results is kept).
+
+To get out of the break loop, you can use X<next>C<next>, X<break>C<break> or
+X<return>C<return>; reading in a file by C<\r> will also terminate the loop once
+the file has been read (C<read> will remain in the break loop). If the
+error is not fatal (C<^C> is the only non-fatal error), C<next>
+will continue the computation as if nothing had happened (except of course,
+you may have changed GP state during the break loop); otherwise control
+will come back to the GP prompt. After a user interrupt (C<^C>),
+entering an empty input line (i.e hitting the return key) has the same
+effect as C<next>.
+
+Break loops are useful as a debugging tool to inspect the values of GP
+variables to understand why a problem occurred, or to change GP behaviour
+(increase debugging level, start storing results in a logfile, modify
+parameters...) in the middle of a long computation (hit C<^C>, type
+in your modifications, then type C<next>).
+
+If I<rec> is the empty string C<""> the last default handler is popped
+out, and replaced by the previous one for that error.
+
+B<Note:> The interface is currently not adequate for trapping
+individual exceptions. In the current version B<2.2.0>, the following keywords
+are recognized, but the name list will be expanded and changed in the
+future (all library mode errors can be trapped: it's a matter of defining
+the keywords to GP, and there are currently far too many useless ones):
+
+C<accurer>: accuracy problem
+
+C<gdiver2>: division by 0
+
+C<archer>: not available on this architecture or operating system
+
+C<typeer>: wrong type
+
+C<errpile>: the PARI stack overflows
+
+=item X<type>typeC<(x,{t})>
+
+this is useful only under GP. If C<t> is
+not present, returns the internal type number of the PARI object C<x>.
+Otherwise, makes a copy of C<x> and sets its type equal to type C<t>, which
+can be either a number or, preferably since internal codes may eventually
+change, a symbolic name such as C<t_FRACN> (you can skip the C<t_>
+part here, so that C<FRACN> by itself would also be all right). Check out
+existing type names with the metacommand C<\t>.X<Label se:gptype>
+
+GP won't let you create meaningless objects in this way where the internal
+structure doesn't match the type. This function can be useful to create
+reducible rationals (type C<t_FRACN>) or rational functions (type
+C<t_RFRACN>). In fact it's the only way to do so in GP. In this case, the
+created object, as well as the objects created from it, will not be reduced
+automatically, making some operations a bit faster.
+
+There is no equivalent library syntax, since the internal functions C<typ>
+and C<settyp> are available. Note that C<settyp> does I<not>
+create a copy of C<x>, contrary to most PARI functions. It also doesn't
+check for consistency. C<settyp> just changes the type in place and
+returns nothing. C<typ> returns a C long integer. Note also the different
+spellings of the internal functions (C<set>)C<typ> and of the GP
+function C<type>, which is due to the fact that C<type> is a reserved
+identifier for some C compilers.
+
+=item X<whatnow>whatnowC<(>I<key>C<)>
+
+if keyword I<key> is the name
+of a function that was present in GP version 1.39.15 or lower, outputs
+the new function name and syntax, if it changed at all (C<387> out of C<560>
+did).X<Label se:whatnow>
+
+=item X<write>writeC<(>I<filename>C<,{>I<str>C<*})>
+
+writes (appends)
+to I<filename> the remaining arguments, and appends a newline (same output
+as C<print>).X<Label se:write>
+
+=item X<write1>write1C<(>I<filename>C<,{>I<str>C<*})>
+
+writes (appends) to
+I<filename> the remaining arguments without a trailing newline
+(same output as C<print1>).
+
+=item X<writetex>writetexC<(>I<filename>C<,{>I<str>C<*})>
+
+as C<write>,
+in TeX format.X<Label se:writetex>
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Math/libPARI.pod b/Master/tlpkg/tlperl.straw/lib/Math/libPARI.pod
new file mode 100755
index 00000000000..723da009df9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Math/libPARI.pod
@@ -0,0 +1,8045 @@
+=head1 NAME
+
+libPARI - Functions and Operations Available in PARI and GP
+
+=head1 DESCRIPTION
+
+X<Label se:functions>
+The functions and operators available in PARI and in the GP/PARI calculator
+are numerous and everexpanding. Here is a description of the ones available
+in version B<2.2.0>. It should be noted that many of these functions accept
+quite different types as arguments, but others are more restricted. The list
+of acceptable types will be given for each function or class of functions.
+Except when stated otherwise, it is understood that a function or operation
+which should make natural sense is legal. In this chapter, we will describe
+the functions according to a rough classification. The general entry looks
+something like:
+
+B<foo>C<(x,{I<flag> = 0})>: short description.
+
+X<foo>The library syntax is B<foo>C<(x,I<flag>)>.
+
+This means that the GP function C<foo> has one mandatory argument C<x>, and
+an optional one, C<I<flag>>, whose default value is 0 (the C<{}> should never be
+typed, it is just a convenient notation we will use throughout to denote
+optional arguments). That is, you can type C<foo(x,2)>, or C<foo(x)>,
+which is then understood to mean C<foo(x,0)>. As well, a comma or closing
+parenthesis, where an optional argument should have been, signals to GP it
+should use the default. Thus, the syntax C<foo(x,)> is also accepted as a
+synonym for our last expression. When a function has more than one optional
+argument, the argument list is filled with user supplied values, in order.
+And when none are left, the defaults are used instead. Thus, assuming that
+C<foo>'s prototype had been
+
+S< >C<
+B<foo>({x = 1},{y = 2},{z = 3}),
+>
+
+typing in C<foo(6,4)> would give
+you C<foo(6,4,3)>. In the rare case when you want to set some far away
+flag, and leave the defaults in between as they stand, you can use the
+``empty arg'' trick alluded to above: C<foo(6,,1)> would yield
+C<foo(6,2,1)>. By the way, C<foo()> by itself yields
+C<foo(1,2,3)> as was to be expected. In this rather special case of a
+function having no mandatory argument, you can even omit the C<()>: a
+standalone C<foo> would be enough (though we don't really recommend it for
+your scripts, for the sake of clarity). In defining GP syntax, we strove
+to put optional arguments at the end of the argument list (of course, since
+they would not make sense otherwise), and in order of decreasing usefulness
+so that, most of the time, you will be able to ignore them.
+
+B<Binary Flags>.X<binary flag> For some of these optional
+flags, we adopted the customary binary notation as a compact way to
+represent many toggles with just one number. Letting C<(p_0,...,p_n)> be a
+list of switches (i.e.S< >of properties which can be assumed to take either
+the value C<0> orS< >C<1>), the number C<2^3 + 2^5 = 40> means that C<p_3> and C<p_5>
+have been set (that is, set to C<1>), and none of the others were (that is,
+they were set to 0). This will usually be announced as ``The binary digits
+of C<I<flag>> mean 1: C<p_0>, 2: C<p_1>, 4: C<p_2>'', and so on, using the
+available consecutive powers ofS< >C<2>.
+
+B<Pointers>.X<pointer> If a parameter in the function
+prototype is prefixed with a & sign, as in
+
+B<foo>C<(x,&e)>
+
+it means that, besides the normal return value, the variable named
+C<e> may be set as a side effect. When passing the argument, the & sign has
+to be typed in explicitly. As of version B<2.2.0>, this X<pointer>C<pointer> argument
+is optional for all documented functions, hence the & will always appear
+between brackets as in C<issquare>C<(x,{&e})>.
+
+B<About library programming>. To finish with our generic
+simple-minded example, the I<library> function C<foo>, as defined
+above, is seen to have two mandatory arguments, C<x> and I<flag> (no PARI
+mathematical function has been implemented so as to accept a variable
+number of arguments). When not mentioned otherwise, the result and
+arguments of a function are assumed implicitly to be of type C<GEN>.
+Most other functions return an object of type C<long> integer in C (see
+ChapterS< >4). The variable or parameter names I<prec> and I<flag> always
+denote C<long> integers.
+
+The X<entree>C<entree> type is used by the library to implement iterators (loops,
+sums, integrals, etc.) when a formal variable has to successively assume a
+number of values in a given set. When programming with the library, it is
+easier and much more efficient to code loops and the like directly. Hence
+this type is not documented, although it does appear in a few library
+function prototypes below. See L<Label se:sums> for more details.
+
+=head1 Standard monadic or dyadic operators
+
+=head2 +C</>-
+
+The expressions C<+>C<x> and C<->C<x> refer
+to monadic operators (the first does nothing, the second negates C<x>).
+
+X<gneg>The library syntax is B<gneg>C<(x)> for C<->C<x>.
+
+=head2 +, C<->
+
+The expression C<x> C<+> C<y> is the X<sum>sum and
+C<x> C<-> C<y> is the X<difference>difference of C<x> and C<y>. Among the prominent
+impossibilities are addition/subtraction between a scalar type and a vector
+or a matrix, between vector/matrices of incompatible sizes and between an
+integermod and a real number.
+
+X<gadd>The library syntax is B<gadd>C<(x,y)> C<x> C<+> C<y>, C<X<gsub>B<gsub>(x,y)> for C<x> C<-> C<y>.
+
+=head2 *
+
+The expression C<x> C<*> C<y> is the X<product>product of C<x>
+and C<y>. Among the prominent impossibilities are multiplication between
+vector/matrices of incompatible sizes, between an integermod and a real
+number. Note that because of vector and matrix operations, C<*> is not
+necessarily commutative. Note also that since multiplication between two
+column or two row vectors is not allowed, to obtain the X<scalar product>scalar product
+of two vectors of the same length, you must multiply a line vector by a
+column vector, if necessary by transposing one of the vectors (using
+the operator C<~> or the function C<mattranspose>, see
+L<Label se:linear_algebra>).
+
+If C<x> and C<y> are binary quadratic forms, compose them. See also
+C<qfbnucomp> and C<qfbnupow>.
+
+X<gmul>The library syntax is B<gmul>C<(x,y)> for C<x> C<*> C<y>. Also available is
+C<X<gsqr>B<gsqr>(x)> for C<x> C<*> C<x> (faster of course!).
+
+=head2 /
+
+The expression C<x> C</> C<y> is the X<quotient>quotient of C<x>
+and C<y>. In addition to the impossibilities for multiplication, note that if
+the divisor is a matrix, it must be an invertible square matrix, and in that
+case the result is C<x*y^{-1}>. Furthermore note that the result is as exact
+as possible: in particular, division of two integers always gives a rational
+number (which may be an integer if the quotient is exact) and I<not> the
+Euclidean quotient (see C<x> C<\> C<y> for that), and similarly the
+quotient of two polynomials is a rational function in general. To obtain the
+approximate real value of the quotient of two integers, add C<0.> to the
+result; to obtain the approximate C<p>-adic value of the quotient of two
+integers, add C<O(p^k)> to the result; finally, to obtain the
+X<Taylor series>Taylor series expansion of the quotient of two polynomials, add
+C<O(X^k)> to the result or use the C<taylor> function
+(see L<Label se:taylor>). X<Label se:gdiv>
+
+X<gdiv>The library syntax is B<gdiv>C<(x,y)> for C<x> C</> C<y>.
+
+=head2 \
+
+The expression C<x> C<\> C<y> is the
+
+X<Euclidean quotient>Euclidean quotient of C<x> and C<y>. The types must be either both
+integer or both polynomials. The result is the Euclidean quotient. In the
+case of integer division, the quotient is such that the corresponding
+remainder is non-negative.
+
+X<gdivent>The library syntax is B<gdivent>C<(x,y)> for C<x> C<\> C<y>.
+
+=head2 \/
+
+The expression C<x> C<\/> C<y> is the Euclidean
+quotient of C<x> and C<y>. The types must be either both integer or both
+polynomials. The result is the rounded Euclidean quotient. In the case of
+integer division, the quotient is such that the corresponding remainder is
+smallest in absolute value and in case of a tie the quotient closest to
+C<+ oo > is chosen.
+
+X<gdivround>The library syntax is B<gdivround>C<(x,y)> for C<x> C<\/> C<y>.
+
+=head2 %
+
+The expression C<x> C<%> C<y> is the
+
+X<Euclidean remainder>Euclidean remainder of C<x> and C<y>. The modulus C<y> must be of type
+integer or polynomial. The result is the remainder, always non-negative in
+the case of integers. Allowed dividend types are scalar exact types when
+the modulus is an integer, and polynomials, polmods and rational functions
+when the modulus is a polynomial.
+
+X<gmod>The library syntax is B<gmod>C<(x,y)> for C<x> C<%> C<y>.
+
+=head2 X<divrem>divremC<(x,y)>
+
+creates a column vector with two components,
+the first being the Euclidean quotient, the second the Euclidean remainder,
+of the division of C<x> by C<y>. This avoids the need to do two divisions if
+one needs both the quotient and the remainder. The arguments must be both
+integers or both polynomials; in the case of integers, the remainder is
+non-negative.
+
+X<gdiventres>The library syntax is B<gdiventres>C<(x,y)>.
+
+=head2 ^
+
+The expression C<x^n> is X<powering>powering.
+If the exponent is an integer, then exact operations are performed using
+binary (left-shift) powering techniques. In particular, in this case C<x>
+cannot be a vector or matrix unless it is a square matrix (and moreover
+invertible if the exponent is negative). If C<x> is a C<p>-adic number, its
+precision will increase if C<v_p(n) E<gt> 0>. PARI is able to rewrite the
+multiplication C<x * x> of two I<identical> objects as C<x^2>, or
+C<sqr(x)> (here, identical means the operands are two different labels
+referencing the same chunk of memory; no equality test is performed). This
+is no longer true when more than two arguments are involved.
+
+If the exponent is not of type integer, this is treated as a transcendental
+function (see L<Label se:trans>), and in particular has the effect of
+componentwise powering on vector or matrices.
+
+As an exception, if the exponent is a rational number C<p/q> and C<x> an
+integer modulo a prime, return a solution C<y> of C<y^q = x^p> if it
+exists. Currently, C<q> must not have large prime factors.
+
+Beware that
+
+ ? Mod(7,19)^(1/2)
+ %1 = Mod(11, 19)/*is any square root*/
+ ? sqrt(Mod(7,19))
+ %2 = Mod(8, 19)/*is the smallest square root*/
+ ? Mod(7,19)^(3/5)
+ %3 = Mod(1, 19)
+ ? %3^(5/3)
+ %4 = Mod(1, 19)/*Mod(7,19) is just another cubic root*/
+
+X<gpow>The library syntax is B<gpow>C<(x,n,I<prec>)> for C<x^n>.
+
+=head2 X<shift>shiftC<(x,n)> or C<x> C<E<lt>E<lt> > C<n> ( = C<x> C<E<gt>E<gt> > C<(-n)>)
+
+shifts
+C<x> componentwise left by C<n> bits if C<n E<gt>= 0> and right by C<|n|> bits if
+C<n E<lt> 0>. A left shift by C<n> corresponds to multiplication by C<2^n>. A right
+shift of an integer C<x> by C<|n|> corresponds to a Euclidean division of
+C<x> by C<2^{|n|}> with a
+remainder of the same sign as C<x>, hence is not the same (in general) as
+C<x \ 2^n>.
+
+X<gshift>The library syntax is B<gshift>C<(x,n)> where C<n> is a C<long>.
+
+=head2 X<shiftmul>shiftmulC<(x,n)>
+
+multiplies C<x> by C<2^n>. The difference with
+C<shift> is that when C<n E<lt> 0>, ordinary division takes place, hence for
+example if C<x> is an integer the result may be a fraction, while for
+C<shift> Euclidean division takes place when C<n E<lt> 0> hence if C<x> is an
+integer the result is still an integer.
+
+X<gmul2n>The library syntax is B<gmul2n>C<(x,n)> where C<n> is a C<long>.
+
+=head2 Comparison and boolean operators
+
+X<boolean operators>
+The six standard X<comparison operators>comparison operators C<E<lt>= >, C<E<lt> >, C<E<gt>= >,
+C<E<gt> >, C< == >, C<! = > are available in GP, and in library mode under
+the names X<gle>B<gle>, X<glt>B<glt>, X<gge>B<gge>, X<ggt>B<ggt>, X<geq>B<geq>, X<gne>B<gne>
+respectively. The library syntax is C<I<co>(x,y)>, where I<co> is the
+comparison operator. The result is 1 (as a C<GEN>) if the comparison is
+true, 0 (as a C<GEN>) if it is false.
+
+The standard boolean functions C<||> (X<inclusive or>inclusive or), C<&&>
+(X<and>and)X<or> and C<!> (X<not>not) are also available, and the
+library syntax is C<X<gor>B<gor>(x,y)>, C<X<gand>B<gand>(x,y)> and C<X<gnot>B<gnot>(x)>
+respectively.
+
+In library mode, it is in fact usually preferable to use the two basic
+functions which are C<X<gcmp>B<gcmp>(x,y)> which gives the sign (1, 0, or -1) of
+C<x-y>, where C<x> and C<y> must be in B<I<R>>, and C<X<gegal>B<gegal>(x,y)> which
+can be applied to any two PARI objects C<x> and C<y> and gives 1 (i.e.S< >true) if
+they are equal (but not necessarily identical), 0 (i.e.S< >false) otherwise.
+Particular cases of X<gegal>B<gegal> which should be used are C<X<gcmp0>B<gcmp0>(x)>
+(C<x == 0> ?), C<X<gcmp1>B<gcmp1>(x)> (C<x == 1> ?), and
+C<X<gcmp_1>B<gcmp_1>(x)> (C<x == -1> ?).
+
+Note that C<X<gcmp0>B<gcmp0>(x)> tests whether C<x> is equal to zero, even if C<x> is
+not an exact object. To test whether C<x> is an exact object which is equal to
+zero, one must use C<X<isexactzero>B<isexactzero>>.
+
+Also note that the C<gcmp> and C<gegal> functions return a C-integer,
+and I<not> a C<GEN> like C<gle> etc.
+
+GP accepts the following synonyms for some of the above functions: since we
+thought it might easily lead to confusion, we don't use the customary C
+operators for bitwise C<and> or bitwise C<or> (use X<bitand>C<bitand> or
+X<bitor>C<bitor>), hence C<|> and C<&> are accepted asX<bitwise
+and>X<bitwise or> synonyms of C<||> and C<&&> respectively.
+Also, C<E<lt> E<gt> > is accepted as a synonym for C<! = >. On the other hand,
+C< = > is definitely I<not> a synonym for C< == > since it is the
+assignment statement.
+
+=head2 X<lex>lexC<(x,y)>
+
+gives the result of a lexicographic comparison
+between C<x> and C<y>. This is to be interpreted in quite a wide sense. For
+example, the vector C<[1,3]> will be considered smaller than the longer
+vector C<[1,3,-1]> (but of course larger than C<[1,2,5]>),
+i.e.S< >C<lex([1,3], [1,3,-1])> will return C<-1>.
+
+X<lexcmp>The library syntax is B<lexcmp>C<(x,y)>.
+
+=head2 X<sign>signC<(x)>
+
+X<sign>sign (C<0>, C<1> or C<-1>) of C<x>, which must be of
+type integer, real or fraction.
+
+X<gsigne>The library syntax is B<gsigne>C<(x)>. The result is a C<long>.
+
+=head2 X<max>maxC<(x,y)> and X<min>B<min>C<(x,y)>
+
+creates the
+maximum and minimum of C<x> and C<y> when they can be compared.
+
+X<gmax>The library syntax is B<gmax>C<(x,y)> and C<X<gmin>B<gmin>(x,y)>.
+
+=head2 X<vecmax>vecmaxC<(x)>
+
+if C<x> is a vector or a matrix, returns the maximum
+of the elements of C<x>, otherwise returns a copy of C<x>. Returns C<- oo >
+in the form of C<-(2^{31}-1)> (or C<-(2^{63}-1)> for 64-bit machines) if C<x> is
+empty.
+
+X<vecmax>The library syntax is B<vecmax>C<(x)>.
+
+=head2 X<vecmin>vecminC<(x)>
+
+if C<x> is a vector or a matrix, returns the minimum
+of the elements of C<x>, otherwise returns a copy of C<x>. Returns C<+ oo >
+in the form of C<2^{31}-1> (or C<2^{63}-1> for 64-bit machines) if C<x> is empty.
+
+X<vecmin>The library syntax is B<vecmin>C<(x)>.
+
+=head1 Conversions and similar elementary functions or commands
+
+X<Label se:conversion>
+Many of the conversion functions are rounding or truncating operations. In
+this case, if the argument is a rational function, the result is the
+Euclidean quotient of the numerator by the denominator, and if the argument
+is a vector or a matrix, the operation is done componentwise. This will not
+be restated for every function.
+
+=head2 X<List>ListC<({x = []})>
+
+transforms a (row or column) vector C<x>
+into a list. The only other way to create a C<t_LIST> is to use the
+function C<listcreate>.
+
+This is useless in library mode.
+
+=head2 X<Mat>MatC<({x = []})>
+
+transforms the object C<x> into a matrix.
+If C<x> is not a vector or a matrix, this creates a C<1 x 1> matrix.
+If C<x> is a row (resp. column) vector, this creates a 1-row (resp.
+1-column) matrix. If C<x> is already a matrix, a copy of C<x> is created.
+
+This function can be useful in connection with the function C<concat>
+(see there).
+
+X<gtomat>The library syntax is B<gtomat>C<(x)>.
+
+=head2 X<Mod>ModC<(x,y,{I<flag> = 0})>
+
+X<Label se:Mod> creates the PARI object
+C<(x mod y)>, i.e.S< >an integermod or a polmod. C<y> must be an integer or a
+polynomial. If C<y> is an integer, C<x> must be an integer, a rational
+number, or a C<p>-adic number compatible with the modulus C<y>. If C<y> is a
+polynomial, C<x> must be a scalar (which is not a polmod), a polynomial, a
+rational function, or a power series.
+
+This function is not the same as C<x> C<%> C<y>, the result of which is an
+integer or a polynomial.
+
+If C<I<flag>> is equal to C<1>, the modulus of the created result is put on the
+heap and not on the stack, and hence becomes a permanent copy which cannot be
+erased later by garbage collecting (see L<Label se:garbage>). Functions
+will operate faster on such objects and memory consumption will be lower.
+On the other hand, care should be taken to avoid creating too many such
+objects.
+
+Under GP, the same effect can be obtained by assigning the object to a GP
+variable (the value of which is a permanent object for the duration of the
+relevant library function call, and is treated as such). This value is
+subject to garbage collection, since it will be deleted when the value
+changes. This is preferable and the above flag is only retained for
+compatibility reasons (it can still be useful in library mode).
+
+X<Mod0>The library syntax is B<Mod0>C<(x,y,I<flag>)>. Also available are
+
+C<B<*>> for C<I<flag> = 1>: C<X<gmodulo>B<gmodulo>(x,y)>.
+
+C<B<*>> for C<I<flag> = 0>: C<X<gmodulcp>B<gmodulcp>(x,y)>.
+
+=head2 X<Pol>PolC<(x,{v = x})>
+
+transforms the object C<x> into a polynomial with
+main variable C<v>. If C<x> is a scalar, this gives a constant polynomial. If
+C<x> is a power series, the effect is identical to C<truncate> (see there),
+i.e.S< >it chops off the C<O(X^k)>. If C<x> is a vector, this function creates
+the polynomial whose coefficients are given in C<x>, with C<x[1]> being the
+leading coefficient (which can be zero).
+
+Warning: this is I<not> a substitution function. It is intended to be
+quick and dirty. So if you try C<Pol(a,y)> on the polynomial C<a = x+y>,
+you will get C<y+y>, which is not a valid PARI object.
+
+X<gtopoly>The library syntax is B<gtopoly>C<(x,v)>, where C<v> is a variable number.
+
+=head2 X<Polrev>PolrevC<(x,{v = x})>
+
+transform the object C<x> into a polynomial
+with main variable C<v>. If C<x> is a scalar, this gives a constant polynomial.
+If C<x> is a power series, the effect is identical to C<truncate> (see
+there), i.e.S< >it chops off the C<O(X^k)>. If C<x> is a vector, this function
+creates the polynomial whose coefficients are given in C<x>, with C<x[1]> being
+the constant term. Note that this is the reverse of C<Pol> if C<x> is a
+vector, otherwise it is identical to C<Pol>.
+
+X<gtopolyrev>The library syntax is B<gtopolyrev>C<(x,v)>, where C<v> is a variable number.
+
+=head2 X<Qfb>QfbC<(a,b,c,{D = 0.})>
+
+creates the binary quadratic form
+C<ax^2+bxy+cy^2>. If C<b^2-4ac E<gt> 0>, initialize X<Shanks>Shanks' distance
+function to C<D>.
+
+X<Qfb0>The library syntax is B<Qfb0>C<(a,b,c,D,I<prec>)>. Also available are
+C<X<qfi>B<qfi>(a,b,c)> (when C<b^2-4ac E<lt> 0>), and
+C<X<qfr>B<qfr>(a,b,c,d)> (when C<b^2-4ac E<gt> 0>).X<binary quadratic form>
+
+=head2 X<Ser>SerC<(x,{v = x})>
+
+transforms the object C<x> into a power series
+with main variable C<v> (C<x> by default). If C<x> is a scalar, this gives a
+constant power series with precision given by the default C<serieslength>
+(corresponding to the C global variable C<precdl>). If C<x> is a
+polynomial, the precision is the greatest of C<precdl> and the degree of
+the polynomial. If C<x> is a vector, the precision is similarly given, and the
+coefficients of the vector are understood to be the coefficients of the power
+series starting from the constant term (i.e.S< >the reverse of the function
+C<Pol>).
+
+The warning given for C<Pol> applies here: this is not a substitution
+function.
+
+X<gtoser>The library syntax is B<gtoser>C<(x,v)>, where C<v> is a variable number (i.e.S< >a C integer).
+
+=head2 X<Set>SetC<({x = []})>
+
+converts C<x> into a set, i.e.S< >into a row vector
+with strictly increasing entries. C<x> can be of any type, but is most useful
+when C<x> is already a vector. The components of C<x> are put in canonical form
+(type C<t_STR>) so as to be easily sorted. To recover an ordinary C<GEN>
+from such an element, you can apply X<eval>C<eval> to it.
+
+X<gtoset>The library syntax is B<gtoset>C<(x)>.
+
+=head2 X<Str>StrC<({x = ""},{I<flag> = 0})>
+
+converts C<x> into a
+character string (type C<t_STR>, the empty string if C<x> is omitted). To
+recover an ordinary C<GEN> from a string, apply C<eval> to it. The
+arguments of C<Str> are evaluated in string context (see
+L<Label se:strings>). If I<flag> is set, treat C<x> as a filename and perform
+X<environment expansion>environment expansion on the string. This feature can be used to read
+X<environment variable>environment variable values.
+
+ ? i = 1; Str("x" i)
+ %1 = "x1"
+ ? eval(%)
+ %2 = x1;
+ ? Str("$HOME", 1)
+ %3 = "/home/pari"
+
+X<strtoGENstr>The library syntax is B<strtoGENstr>C<(x,I<flag>)>. This function is mostly useless in library mode. Use
+the pair X<strtoGEN>C<strtoGEN>/X<GENtostr>C<GENtostr> to convert between C<char*> and
+C<GEN>.
+
+=head2 X<Vec>VecC<({x = []})>
+
+transforms the object C<x> into a row vector. The
+vector will be with one component only, except when C<x> is a vector/matrix or
+a quadratic form (in which case the resulting vector is simply the initial
+object considered as a row vector), but more importantly when C<x> is a
+polynomial or a power series. In the case of a polynomial, the coefficients
+of the vector start with the leading coefficient of the polynomial, while
+for power series only the significant coefficients are taken into account,
+but this time by increasing order of degree.
+
+X<gtovec>The library syntax is B<gtovec>C<(x)>.
+
+=head2 X<binary>binaryC<(x)>
+
+outputs the vector of the binary digits of C<|x|>.
+Here C<x> can be an integer, a real number (in which case the result has two
+components, one for the integer part, one for the fractional part) or a
+vector/matrix.
+
+X<binaire>The library syntax is B<binaire>C<(x)>.
+
+=head2 X<bitand>bitandC<(x,y)>
+
+bitwise X<and>C<and>X<bitwise and> of two
+integers C<x> and C<y>, that is the integer
+
+S< >C<F<sum> (x_iS< >andS< >y_i) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitand>The library syntax is B<gbitand>C<(x,y)>.
+
+=head2 X<bitneg>bitnegC<(x,{n = -1})>
+
+X<bitwise negation>bitwise negation of an integer C<x>,
+truncated to C<n> bits, that is the integer
+
+S< >C<F<sum>_{i = 0}^n not(x_i) 2^i>
+
+The special case C<n = -1> means no truncation: an infinite sequence of
+leading C<1> is then represented as a negative number.
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitneg>The library syntax is B<gbitneg>C<(x)>.
+
+=head2 X<bitnegimply>bitnegimplyC<(x,y)>
+
+bitwise negated imply of two integers C<x>
+and C<y> (or C<not> C<(x ==E<gt> y)>), that is the integer
+
+S< >C<F<sum> (x_iS< >and not(y_i)) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitnegimply>The library syntax is B<gbitnegimply>C<(x,y)>.
+
+=head2 X<bitor>bitorC<(x,y)>
+
+bitwise (inclusive) X<or>C<or>X<bitwise
+inclusive or> of two integers C<x> and C<y>, that is the integer
+
+S< >C<F<sum> (x_iS< >orS< >y_i) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitor>The library syntax is B<gbitor>C<(x,y)>.
+
+=head2 X<bittest>bittestC<(x,n)>
+
+outputs the C<n^{th}> bit of C<|x|> starting
+from the right (i.e.S< >the coefficient of C<2^n> in the binary expansion of C<x>).
+The result is 0 or 1. To extract several bits at once as a vector, pass a
+vector for C<n>.
+
+X<bittest>The library syntax is B<bittest>C<(x,n)>, where C<n> and the result are C<long>s.
+
+=head2 X<bitxor>bitxorC<(x,y)>
+
+bitwise (exclusive) X<or>C<or>X<bitwise
+exclusive or> of two integers C<x> and C<y>, that is the integer
+
+S< >C<F<sum> (x_iS< >xorS< >y_i) 2^i>
+
+Negative numbers behave as if modulo a huge power of C<2>.
+
+X<gbitxor>The library syntax is B<gbitxor>C<(x,y)>.
+
+=head2 X<ceil>ceilC<(x)>
+
+ceiling of C<x>. When C<x> is in B<I<R>>,
+the result is the smallest integer greater than or equal to C<x>. Applied to a
+rational function, C<ceil(x)> returns the euclidian quotient of the
+numerator by the denominator.
+
+X<gceil>The library syntax is B<gceil>C<(x)>.
+
+=head2 X<centerlift>centerliftC<(x,{v})>
+
+lifts an element C<x = a mod n> of C<B<I<Z>>/nB<I<Z>>>
+to C<a> in B<I<Z>>, and similarly lifts a polmod to a polynomial. This is the
+same as C<lift> except that in the particular case of elements of
+C<B<I<Z>>/nB<I<Z>>>, the lift C<y> is such that C<-n/2 E<lt> y E<lt>= n/2>. If C<x> is of type
+fraction, complex, quadratic, polynomial, power series, rational function,
+vector or matrix, the lift is done for each coefficient. Real and C<p>-adics
+are forbidden.
+
+X<centerlift0>The library syntax is B<centerlift0>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded
+as C<-1>. Also available is X<centerlift>B<centerlift>C<(x)> = C<centerlift0(x,-1)>.
+
+=head2 X<changevar>changevarC<(x,y)>
+
+creates a copy of the object C<x> where its
+variables are modified according to the permutation specified by the vector
+C<y>. For example, assume that the variables have been introduced in the
+order C<x>, C<a>, C<b>, C<c>. Then, if C<y> is the vector
+C<[x,c,a,b]>, the variable C<a> will be replaced by C<c>, C<b> by
+C<a>, and C<c> by C<b>, C<x> being unchanged. Note that the
+permutation must be completely specified, e.g.S< >C<[c,a,b]> would not work,
+since this would replace C<x> by C<c>, and leave C<a> and C<b>
+unchanged (as well as C<c> which is the fourth variable of the initial
+list). In particular, the new variable names must be distinct.
+
+X<changevar>The library syntax is B<changevar>C<(x,y)>.
+
+=head2 components of a PARI object
+
+There are essentially three ways to extract the X<components>components from a PARI
+object.
+
+The first and most general, is the function C<X<component>B<component>(x,n)> which
+extracts the C<n^{th}>-component of C<x>. This is to be understood as
+follows: every PARI type has one or two initial X<code words>code words. The
+components are counted, starting at 1, after these code words. In particular
+if C<x> is a vector, this is indeed the C<n^{th}>-component of C<x>, if
+C<x> is a matrix, the C<n^{th}> column, if C<x> is a polynomial, the
+C<n^{th}> coefficient (i.e.S< >of degree C<n-1>), and for power series, the
+C<n^{th}> significant coefficient. The use of the function
+C<component> implies the knowledge of the structure of the different PARI
+types, which can be recalled by typing C<\t> under GP.
+
+X<compo>The library syntax is B<compo>C<(x,n)>, where C<n> is a C<long>.
+
+The two other methods are more natural but more restricted. The function
+C< B<polcoeff>(x,n)>X<polcoeff> gives the coefficient of degree C<n> of the polynomial
+or power series C<x>, with respect to the main variable of C<x> (to check
+variable ordering, or to change it, use the function X<reorder>C<reorder>, see
+L<Label se:reorder>). In particular if C<n> is less than the valuation of
+C<x> or in the case of a polynomial, greater than the degree, the result is
+zero (contrary to C<compo> which would send an error message). If C<x> is
+a power series and C<n> is greater than the largest significant degree, then
+an error message is issued.
+
+For greater flexibility, vector or matrix types are also accepted for C<x>,
+and the meaning is then identical with that of C<compo>.
+
+Finally note that a scalar type is considered by C<polcoeff> as a
+polynomial of degree zero.
+
+X<truecoeff>The library syntax is B<truecoeff>C<(x,n)>.
+
+The third method is specific to vectors or matrices under GP. If C<x> is a
+(row or column) vector, then X<x[n]>C<x[n]> represents the C<n^{th}>
+component of C<x>, i.e.S< >C<compo(x,n)>. It is more natural and shorter to
+write. If C<x> is a matrix, X<x[m,n]>C<x[m,n]> represents the coefficient of
+row C<m> and column C<n> of the matrix, X<x[m,]>C<x[m,]> represents
+the C<m^{th}> I<row> of C<x>, and X<x[,n]>C<x[,n]> represents
+the C<n^{th}> I<column> of C<x>.
+
+Finally note that in library mode, the macros X<coeff>B<coeff> and X<mael>B<mael>
+are available to deal with the non-recursivity of the C<GEN> type from the
+compiler's point of view. See the discussion on typecasts in Chapter 4.
+
+=head2 X<conj>conjC<(x)>
+
+conjugate of C<x>. The meaning of this
+is clear, except that for real quadratic numbers, it means conjugation in the
+real quadratic field. This function has no effect on integers, reals,
+integermods, fractions or C<p>-adics. The only forbidden type is polmod
+(see C<conjvec> for this).
+
+X<gconj>The library syntax is B<gconj>C<(x)>.
+
+=head2 X<conjvec>conjvecC<(x)>
+
+conjugate vector representation of C<x>. If C<x> is a
+polmod, equal to C<Mod>C<(a,q)>, this gives a vector of length
+C<degree(q)> containing the complex embeddings of the polmod if C<q> has
+integral or rational coefficients, and the conjugates of the polmod if C<q>
+has some integermod coefficients. The order is the same as that of the
+C<polroots> functions. If C<x> is an integer or a rational number, the
+result isS< >C<x>. If C<x> is a (row or column) vector, the result is a matrix
+whose columns are the conjugate vectors of the individual elements of C<x>.
+
+X<conjvec>The library syntax is B<conjvec>C<(x,I<prec>)>.
+
+=head2 X<denominator>denominatorC<(x)>
+
+lowest denominator of C<x>. The meaning of this
+is clear when C<x> is a rational number or function. When C<x> is an integer
+or a polynomial, the result is equal to C<1>. When C<x> is a vector or a matrix,
+the lowest common denominator of the components of C<x> is computed. All other
+types are forbidden.
+
+X<denom>The library syntax is B<denom>C<(x)>.
+
+=head2 X<floor>floorC<(x)>
+
+floor of C<x>. When C<x> is in B<I<R>>, the result is the
+largest integer smaller than or equal to C<x>. Applied to a rational function,
+C<floor(x)> returns the euclidian quotient of the numerator by the
+denominator.
+
+X<gfloor>The library syntax is B<gfloor>C<(x)>.
+
+=head2 X<frac>fracC<(x)>
+
+fractional part of C<x>. Identical to
+C<x-floor(x)>. If C<x> is real, the result is in C<[0,1[>.
+
+X<gfrac>The library syntax is B<gfrac>C<(x)>.
+
+=head2 X<imag>imagC<(x)>
+
+imaginary part of C<x>. When
+C<x> is a quadratic number, this is the coefficient of C<F<omega>> in
+the ``canonical'' integral basis C<(1,F<omega>)>.
+
+X<gimag>The library syntax is B<gimag>C<(x)>.
+
+=head2 X<length>lengthC<(x)>
+
+number of non-code words in C<x> really used (i.e.S< >the
+effective length minus 2 for integers and polynomials). In particular,
+the degree of a polynomial is equal to its length minus 1. If C<x> has type
+C<t_STR>, output number of letters.
+
+X<glength>The library syntax is B<glength>C<(x)> and the result is a C long.
+
+=head2 X<lift>liftC<(x,{v})>
+
+lifts an element C<x = a mod n> of C<B<I<Z>>/nB<I<Z>>> to
+C<a> in B<I<Z>>, and similarly lifts a polmod to a polynomial if C<v> is omitted.
+Otherwise, lifts only polmods with main variable C<v> (if C<v> does not occur
+in C<x>, lifts only intmods). If C<x> is of type fraction, complex, quadratic,
+polynomial, power series, rational function, vector or matrix, the lift is
+done for each coefficient. Forbidden types for C<x> are reals and C<p>-adics.
+
+X<lift0>The library syntax is B<lift0>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded as
+C<-1>. Also available is X<lift>B<lift>C<(x)> = C<lift0(x,-1)>.
+
+=head2 X<norm>normC<(x)>
+
+algebraic norm of C<x>, i.e.S< >the product of C<x> with
+its conjugate (no square roots are taken), or conjugates for polmods. For
+vectors and matrices, the norm is taken componentwise and hence is not the
+C<L^2>-norm (see C<norml2>). Note that the norm of an element of
+B<I<R>> is its square, so as to be compatible with the complex norm.
+
+X<gnorm>The library syntax is B<gnorm>C<(x)>.
+
+=head2 X<norml2>norml2C<(x)>
+
+square of the C<L^2>-norm of C<x>. C<x> must
+be a (row or column) vector.
+
+X<gnorml2>The library syntax is B<gnorml2>C<(x)>.
+
+=head2 X<numerator>numeratorC<(x)>
+
+numerator of C<x>. When C<x> is a rational number
+or function, the meaning is clear. When C<x> is an integer or a polynomial,
+the result is C<x> itself. When C<x> is a vector or a matrix, then
+C<numerator(x)> is defined to be C<denominator(x)*x>. All other types
+are forbidden.
+
+X<numer>The library syntax is B<numer>C<(x)>.
+
+=head2 X<numtoperm>numtopermC<(n,k)>
+
+generates the C<k>-th permutation (as a
+row vector of length C<n>) of the numbers C<1> to C<n>. The number C<k> is taken
+modulo C<n!>, i.e.S< >inverse function of X<permtonum>C<permtonum>.
+
+X<permute>The library syntax is B<permute>C<(n,k)>, where C<n> is a C<long>.
+
+=head2 X<padicprec>padicprecC<(x,p)>
+
+absolute C<p>-adic precision of the object C<x>.
+This is the minimum precision of the components of C<x>. The result is
+C<VERYBIGINT> (C<2^{31}-1> for 32-bit machines or C<2^{63}-1> for 64-bit
+machines) if C<x> is an exact object.
+
+X<padicprec>The library syntax is B<padicprec>C<(x,p)> and the result is a C<long>
+integer.
+
+=head2 X<permtonum>permtonumC<(x)>
+
+given a permutation C<x> on C<n> elements,
+gives the number C<k> such that C<x = numtoperm(n,k)>, i.e.S< >inverse
+function of X<numtoperm>C<numtoperm>.
+
+X<permuteInv>The library syntax is B<permuteInv>C<(x)>.
+
+=head2 X<precision>precisionC<(x,{n})>
+
+gives the precision in decimal digits of the
+PARI object C<x>. If C<x> is an exact object, the largest single precision
+integer is returned. If C<n> is not omitted, creates a new object equal to C<x>
+with a new precision C<n>. This is to be understood as follows:
+
+For exact types, no change. For C<x> a vector or a matrix, the operation
+is done componentwise.
+
+For real C<x>, C<n> is the number of desired significant I<decimal> digits.
+If C<n> is smaller than the precision of C<x>, C<x> is truncated, otherwise C<x>
+is extended with zeros.
+
+For C<x> a C<p>-adic or a power series, C<n> is the desired number of
+significant C<p>-adic or C<X>-adic digits, where C<X> is the main variable of
+C<x>.
+
+Note that the function C<precision> never changes the type of the result.
+In particular it is not possible to use it to obtain a polynomial from a
+power series. For that, see C<truncate>.
+
+X<precision0>The library syntax is B<precision0>C<(x,n)>, where C<n> is a C<long>. Also available are
+C<X<ggprecision>B<ggprecision>(x)> (result is a C<GEN>) and C<X<gprec>B<gprec>(x,n)>, where
+C<n> is a C<long>.
+
+=head2 X<random>randomC<({N = 2^{31}})>
+
+gives a random integer between 0 and
+C<N-1>. C<N> can be arbitrary large. This is an internal PARI function and does
+not depend on the system's random number generator. Note that the resulting
+integer is obtained by means of linear congruences and will not be well
+distributed in arithmetic progressions.
+
+X<genrand>The library syntax is B<genrand>C<(N)>.
+
+=head2 X<real>realC<(x)>
+
+real part of C<x>. In the case where C<x> is a quadratic
+number, this is the coefficient of C<1> in the ``canonical'' integral basis
+C<(1,F<omega>)>.
+
+X<greal>The library syntax is B<greal>C<(x)>.
+
+=head2 X<round>roundC<(x,{&e})>
+
+If C<x> is in B<I<R>>, rounds C<x> to the nearest
+integer and sets C<e> to the number of error bits, that is the binary exponent
+of the difference between the original and the rounded value (the
+``fractional part''). If the exponent of C<x> is too large compared to its
+precision (i.e.S< >C<e E<gt> 0>), the result is undefined and an error occurs if C<e>
+was not given.
+
+B<Important remark:> note that, contrary to the other truncation
+functions, this function operates on every coefficient at every level of a
+PARI object. For example
+
+S< >C<truncate((2.4*X^2-1.7)/(X)) = 2.4*X,>
+
+whereas
+
+S< >C<round((2.4*X^2-1.7)/(X)) = (2*X^2-2)/(X).>
+
+An important use of C<round> is to get exact results after a long
+approximate computation, when theory tells you that the coefficients
+must be integers.
+
+X<grndtoi>The library syntax is B<grndtoi>C<(x,&e)>, where C<e> is a C<long> integer. Also available is
+C<X<ground>B<ground>(x)>.
+
+=head2 X<simplify>simplifyC<(x)>
+
+this function tries to simplify the object C<x> as
+much as it can. The simplifications do not concern rational functions (which
+PARI automatically tries to simplify), but type changes. Specifically, a
+complex or quadratic number whose imaginary part is exactly equal to 0
+(i.e.S< >not a real zero) is converted to its real part, and a polynomial of
+degree zero is converted to its constant term. For all types, this of course
+occurs recursively. This function is useful in any case, but in particular
+before the use of arithmetic functions which expect integer arguments, and
+not for example a complex number of 0 imaginary part and integer real part
+(which is however printed as an integer).
+
+X<simplify>The library syntax is B<simplify>C<(x)>.
+
+=head2 X<sizebyte>sizebyteC<(x)>
+
+outputs the total number of bytes occupied by the
+tree representing the PARI object C<x>.
+
+X<taille2>The library syntax is B<taille2>C<(x)> which returns a C<long>. The
+function X<taille>B<taille> returns the number of I<words> instead.
+
+=head2 X<sizedigit>sizedigitC<(x)>
+
+outputs a quick bound for the number of decimal
+digits of (the components of) C<x>, off by at most C<1>. If you want the
+exact value, you can use C<length(Str(x))>, which is much slower.
+
+X<sizedigit>The library syntax is B<sizedigit>C<(x)> which returns a C<long>.
+
+=head2 X<truncate>truncateC<(x,{&e})>
+
+truncates C<x> and sets C<e> to the number of
+error bits. When C<x> is in B<I<R>>, this means that the part after the decimal
+point is chopped away, C<e> is the binary exponent of the difference between
+the original and the truncated value (the ``fractional part''). If the
+exponent of C<x> is too large compared to its precision (i.e.S< >C<e E<gt> 0>), the
+result is undefined and an error occurs if C<e> was not given. The function
+applies componentwise on rational functions and vector / matrices; C<e> is
+then the maximal number of error bits.
+
+Note a very special use of C<truncate>: when applied to a power series, it
+transforms it into a polynomial or a rational function with denominator
+a power of C<X>, by chopping away the C<O(X^k)>. Similarly, when applied to
+a C<p>-adic number, it transforms it into an integer or a rational number
+by chopping away the C<O(p^k)>.
+
+X<gcvtoi>The library syntax is B<gcvtoi>C<(x,&e)>, where C<e> is a C<long> integer. Also available is
+X<gtrunc>B<gtrunc>C<(x)>.
+
+=head2 X<valuation>valuationC<(x,p)>
+
+X<Label se:valuation> computes the highest
+exponent of C<p> dividing C<x>. If C<p> is of type integer, C<x> must be an
+integer, an integermod whose modulus is divisible by C<p>, a fraction, a
+C<q>-adic number with C<q = p>, or a polynomial or power series in which case the
+valuation is the minimum of the valuation of the coefficients.
+
+If C<p> is of type polynomial, C<x> must be of type polynomial or rational
+function, and also a power series if C<x> is a monomial. Finally, the
+valuation of a vector, complex or quadratic number is the minimum of the
+component valuations.
+
+If C<x = 0>, the result is C<VERYBIGINT> (C<2^{31}-1> for 32-bit machines or
+C<2^{63}-1> for 64-bit machines) if C<x> is an exact object. If C<x> is a
+C<p>-adic numbers or power series, the result is the exponent of the zero.
+Any other type combinations gives an error.
+
+X<ggval>The library syntax is B<ggval>C<(x,p)>, and the result is a C<long>.
+
+=head2 X<variable>variableC<(x)>
+
+gives the main variable of the object C<x>, and
+C<p> if C<x> is a C<p>-adic number. Gives an error if C<x> has no variable
+associated to it. Note that this function is useful only in GP, since in
+library mode the function C<gvar> is more appropriate.
+
+X<gpolvar>The library syntax is B<gpolvar>C<(x)>. However, in library mode, this function should not be used.
+Instead, test whether C<x> is a C<p>-adic (type C<t_PADIC>), in which case C<p>
+is in C<x[2]>, or call the function C<B<gvar>(x)> which returns the variable
+I<number> of C<x> if it exists, C<BIGINT> otherwise.
+
+=head1 Transcendental functions
+
+X<Label se:trans>
+As a general rule, which of course in some cases may have exceptions,
+transcendental functions operate in the following way:
+
+C<B<*>> If the argument is either an integer, a real, a rational, a complex
+or a quadratic number, it is, if necessary, first converted to a real (or
+complex) number using the current X<precision>precision held in the default
+C<realprecision>. Note that only exact arguments are converted, while
+inexact arguments such as reals are not.
+
+Under GP this is transparent to the user, but when programming in library
+mode, care must be taken to supply a meaningful parameter I<prec> as the
+last argument of the function if the first argument is an exact object.
+This parameter is ignored if the argument is inexact.
+
+Note that in library mode the precision argument I<prec> is a word
+count including codewords, i.e.S< >represents the length in words of a real
+number, while under GP the precision (which is changed by the metacommand
+C<\p> or using C<default(realprecision,...)>) is the number of significant
+decimal digits.
+
+Note that some accuracies attainable on 32-bit machines cannot be attained
+on 64-bit machines for parity reasons. For example the default GP accuracy
+is 28 decimal digits on 32-bit machines, corresponding to I<prec> having
+the value 5, but this cannot be attained on 64-bit machines.
+
+After possible conversion, the function is computed. Note that even if the
+argument is real, the result may be complex (e.g.S< >C<acos(2.0)> or
+C<acosh(0.0)>). Note also that the principal branch is always chosen.
+
+C<B<*>> If the argument is an integermod or a C<p>-adic, at present only a
+few functions like C<sqrt> (square root), C<sqr> (square), C<log>,
+C<exp>, powering, C<teichmuller> (TeichmE<uuml>ller character) and
+C<agm> (arithmetic-geometric mean) are implemented.
+
+Note that in the case of a C<2>-adic number, C<sqr(x)> may not be
+identical to C<x*x>: for example if C<x = 1+O(2^5)> and C<y = 1+O(2^5)> then
+C<x*y = 1+O(2^5)> while C<sqr(x) = 1+O(2^6)>. Here, C<x * x> yields the
+same result as C<sqr(x)> since the two operands are known to be I<
+identical>. The same statement holds true for C<p>-adics raised to the power
+C<n>, where C<v_p(n) E<gt> 0>.
+
+B<Remark:> note that if we wanted to be strictly consistent with
+the PARI philosophy, we should have C<x*y = (4 mod 8)> and C<sqr(x) =
+(4 mod 32)> when both C<x> and C<y> are congruent to C<2> modulo C<4>.
+However, since integermod is an exact object, PARI assumes that the modulus
+must not change, and the result is hence C<(0 mod 4)> in both cases. On
+the other hand, C<p>-adics are not exact objects, hence are treated
+differently.
+
+C<B<*>> If the argument is a polynomial, power series or rational function,
+it is, if necessary, first converted to a power series using the current
+precision held in the variable X<precdl>C<precdl>. Under GP this again is
+transparent to the user. When programming in library mode, however, the
+global variable C<precdl> must be set before calling the function if the
+argument has an exact type (i.e.S< >not a power series). Here C<precdl> is
+not an argument of the function, but a global variable.
+
+Then the Taylor series expansion of the function around C<X = 0> (where C<X> is
+the main variable) is computed to a number of terms depending on the number
+of terms of the argument and the function being computed.
+
+C<B<*>> If the argument is a vector or a matrix, the result is the
+componentwise evaluation of the function. In particular, transcendental
+functions on square matrices, which are not implemented in the present
+version B<2.2.0> (see AppendixS< >B however), will have a slightly different name
+if they are implemented some day.
+
+=head2 ^
+
+If C<y> is not of type integer, C<x^y> has the same
+effect as C<exp(y*ln(x))>. It can be applied to C<p>-adic numbers as
+well as to the more usual types.X<powering>
+
+X<gpow>The library syntax is B<gpow>C<(x,y,I<prec>)>.
+
+=head2 Euler
+
+Euler's constant C<0.57721...>. Note that C<Euler>
+is one of the few special reserved names which cannot be used for variables
+(the others are C<I> and C<Pi>, as well as all function names).
+X<Label se:euler>
+
+X<mpeuler>The library syntax is B<mpeuler>C<(I<prec>)> where C<I<prec>> I<must> be given. Note that
+this creates C<F<gamma>> on the PARI stack, but a copy is also created on the
+heap for quicker computations next time the function is called.
+
+=head2 I
+
+the complex number C< F<sqrt> {-1}>.
+
+The library syntax is the global variable C<gi> (of type C<GEN>).
+
+=head2 Pi
+
+the constant C<F<Pi>> (C<3.14159...>).X<Label se:pi>
+
+X<mppi>The library syntax is B<mppi>C<(I<prec>)> where C<I<prec>> I<must> be given. Note that this
+creates C<F<Pi>> on the PARI stack, but a copy is also created on the heap for
+quicker computations next time the function is called.
+
+=head2 X<abs>absC<(x)>
+
+absolute value of C<x> (modulus if C<x> is complex).
+Power series and rational functions are not allowed. Contrary to most
+transcendental functions, an exact argument is I<not> converted to a real
+number before applying C<abs> and an exact result is returned if possible.
+
+ ? abs(-1)
+ %1 = 1
+ ? abs(3/7 + 4/7*I)
+ %2 = 5/7
+ ? abs(1 + I)
+ %3 = 1.414213562373095048801688724
+
+If C<x> is a polynomial, returns C<-x> if the leading coefficient is
+real and negative else returns C<x>. For a power series, the constant
+coefficient is considered instead.
+
+X<gabs>The library syntax is B<gabs>C<(x,I<prec>)>.
+
+=head2 X<acos>acosC<(x)>
+
+principal branch of C<cos^{-1}(x)>,
+i.e.S< >such that C<Re(acos(x)) belongs to [0,F<Pi>]>. If
+C<x belongs to B<I<R>>> and C<|x| E<gt> 1>, then C<acos(x)> is complex.
+
+X<gacos>The library syntax is B<gacos>C<(x,I<prec>)>.
+
+=head2 X<acosh>acoshC<(x)>
+
+principal branch of C<cosh^{-1}(x)>,
+i.e.S< >such that C<Im(acosh(x)) belongs to [0,F<Pi>]>. If
+C<x belongs to B<I<R>>> and C<x E<lt> 1>, then C<acosh(x)> is complex.
+
+X<gach>The library syntax is B<gach>C<(x,I<prec>)>.
+
+=head2 X<agm>agmC<(x,y)>
+
+arithmetic-geometric mean of C<x> and C<y>. In the
+case of complex or negative numbers, the principal square root is always
+chosen. C<p>-adic or power series arguments are also allowed. Note that
+a C<p>-adic agm exists only if C<x/y> is congruent to 1 modulo C<p> (modulo
+16 for C<p = 2>). C<x> and C<y> cannot both be vectors or matrices.
+
+X<agm>The library syntax is B<agm>C<(x,y,I<prec>)>.
+
+=head2 X<arg>argC<(x)>
+
+argument of the complex number C<x>, such that
+C<-F<Pi> E<lt> arg(x) E<lt>= F<Pi>>.
+
+X<garg>The library syntax is B<garg>C<(x,I<prec>)>.
+
+=head2 X<asin>asinC<(x)>
+
+principal branch of C<sin^{-1}(x)>, i.e.S< >such
+that C<Re(asin(x)) belongs to [-F<Pi>/2,F<Pi>/2]>. If C<x belongs to B<I<R>>> and C<|x| E<gt> 1> then
+C<asin(x)> is complex.
+
+X<gasin>The library syntax is B<gasin>C<(x,I<prec>)>.
+
+=head2 X<asinh>asinhC<(x)>
+
+principal branch of C<sinh^{-1}(x)>, i.e.S< >such
+that C<Im(asinh(x)) belongs to [-F<Pi>/2,F<Pi>/2]>.
+
+X<gash>The library syntax is B<gash>C<(x,I<prec>)>.
+
+=head2 X<atan>atanC<(x)>
+
+principal branch of C<tan^{-1}(x)>, i.e.S< >such
+that C<Re(atan(x)) belongs to ]-F<Pi>/2,F<Pi>/2[>.
+
+X<gatan>The library syntax is B<gatan>C<(x,I<prec>)>.
+
+=head2 X<atanh>atanhC<(x)>
+
+principal branch of C<tanh^{-1}(x)>, i.e.S< >such
+that C<Im(atanh(x)) belongs to ]-F<Pi>/2,F<Pi>/2]>. If C<x belongs to B<I<R>>> and C<|x| E<gt> 1> then
+C<atanh(x)> is complex.
+
+X<gath>The library syntax is B<gath>C<(x,I<prec>)>.
+
+=head2 X<bernfrac>bernfracC<(x)>
+
+Bernoulli numberX<Bernoulli numbers> C<B_x>,
+where C<B_0 = 1>, C<B_1 = -1/2>, C<B_2 = 1/6>,..., expressed as a rational number.
+The argument C<x> should be of type integer.
+
+X<bernfrac>The library syntax is B<bernfrac>C<(x)>.
+
+=head2 X<bernreal>bernrealC<(x)>
+
+Bernoulli numberX<Bernoulli numbers>
+C<B_x>, as C<bernfrac>, but C<B_x> is returned as a real number
+(with the current precision).
+
+X<bernreal>The library syntax is B<bernreal>C<(x,I<prec>)>.
+
+=head2 X<bernvec>bernvecC<(x)>
+
+creates a vector containing, as rational numbers,
+the X<Bernoulli numbers>Bernoulli numbers C<B_0>, C<B_2>,..., C<B_{2x}>. These Bernoulli
+numbers can then be used as follows. Assume that this vector has been put
+into a variable, say C<bernint>. Then you can define under GP:
+
+ bern(x) =
+ {
+ if (x == 1, return(-1/2));
+ if (x < 0 || x % 2, return(0));
+ bernint[x/2+1]
+ }
+
+and then C<bern(k)> gives the Bernoulli number of index C<k> as a
+rational number, exactly as C<bernreal(k)> gives it as a real number. If
+you need only a few values, calling C<bernfrac(k)> each time will be much
+more efficient than computing the huge vector above.
+
+X<bernvec>The library syntax is B<bernvec>C<(x)>.
+
+=head2 X<besseljh>besseljhC<(n,x)>
+
+C<J>-Bessel function of half integral index.
+More precisely, C<besseljh(n,x)> computes C<J_{n+1/2}(x)> where C<n>
+must be of type integer, and C<x> is any element of B<I<C>>. In the
+present version B<2.2.0>, this function is not very accurate when C<x> is
+small.
+
+X<jbesselh>The library syntax is B<jbesselh>C<(n,x,I<prec>)>.
+
+=head2 X<besselk>besselkC<(I<nu>,x,{I<flag> = 0})>
+
+C<K>-Bessel function of index
+I<nu> (which can be complex) and argument C<x>. Only real and positive
+arguments
+C<x> are allowed in the present version B<2.2.0>. If C<I<flag>> is equal to 1,
+uses another implementation of this function which is often faster.
+
+X<kbessel>The library syntax is B<kbessel>C<(I<nu>,x,I<prec>)> and
+C<X<kbessel2>B<kbessel2>(I<nu>,x,I<prec>)> respectively.
+
+=head2 X<cos>cosC<(x)>
+
+cosine of C<x>.
+
+X<gcos>The library syntax is B<gcos>C<(x,I<prec>)>.
+
+=head2 X<cosh>coshC<(x)>
+
+hyperbolic cosine of C<x>.
+
+X<gch>The library syntax is B<gch>C<(x,I<prec>)>.
+
+=head2 X<cotan>cotanC<(x)>
+
+cotangent of C<x>.
+
+X<gcotan>The library syntax is B<gcotan>C<(x,I<prec>)>.
+
+=head2 X<dilog>dilogC<(x)>
+
+principal branch of the dilogarithm of C<x>,
+i.e.S< >analytic continuation of the power series C< F<log> _2(x) = F<sum>_{n E<gt>= 1}x^n/n^2>.
+
+X<dilog>The library syntax is B<dilog>C<(x,I<prec>)>.
+
+=head2 X<eint1>eint1C<(x,{n})>
+
+exponential integral
+C<F<int>_x^ oo (e^{-t})/(t)dt> (C<x belongs to B<I<R>>>)
+
+If C<n> is present, outputs the C<n>-dimensional vector
+C<[eint1(x),...,eint1(nx)]> (C<x E<gt>= 0>). This is faster than
+repeatedly calling C<eint1(i * x)>.
+
+X<veceint1>The library syntax is B<veceint1>C<(x,n,I<prec>)>. Also available is
+C<X<eint1>B<eint1>(x,I<prec>)>.
+
+=head2 X<erfc>erfcC<(x)>
+
+complementary error function
+C<(2/ F<sqrt> F<Pi>)F<int>_x^ oo e^{-t^2}dt>.
+
+X<erfc>The library syntax is B<erfc>C<(x,I<prec>)>.
+
+=head2 X<eta>etaC<(x,{I<flag> = 0})>
+
+X<Dedekind>Dedekind's C<F<eta>> function, without the
+C<q^{1/24}>. This means the following: if C<x> is a complex number with positive
+imaginary part, the result is C<F<prod>_{n = 1}^ oo (1-q^n)>, where
+C<q = e^{2iF<Pi> x}>. If C<x> is a power series (or can be converted to a power
+series) with positive valuation, the result is C<F<prod>_{n = 1}^ oo (1-x^n)>.
+
+If C<I<flag> = 1> and C<x> can be converted to a complex number (i.e.S< >is not a power
+series), computes the true C<F<eta>> function, including the leading C<q^{1/24}>.
+
+X<eta>The library syntax is B<eta>C<(x,I<prec>)>.
+
+=head2 X<exp>expC<(x)>
+
+exponential of C<x>.
+C<p>-adic arguments with positive valuation are accepted.
+
+X<gexp>The library syntax is B<gexp>C<(x,I<prec>)>.
+
+=head2 X<gammah>gammahC<(x)>
+
+gamma function evaluated at the argument
+C<x+1/2>. When C<x> is an integer, this is much faster than using
+C<gamma(x+1/2)>.
+
+X<ggamd>The library syntax is B<ggamd>C<(x,I<prec>)>.
+
+=head2 X<gamma>gammaC<(x)>
+
+gamma function of C<x>. In the present version
+B<2.2.0> the C<p>-adic gamma function is not implemented.
+
+X<ggamma>The library syntax is B<ggamma>C<(x,I<prec>)>.
+
+=head2 X<hyperu>hyperuC<(a,b,x)>
+
+C<U>-confluent hypergeometric function with
+parameters C<a> and C<b>. The parameters C<a> and C<b> can be complex but
+the present implementation requires C<x> to be positive.
+
+X<hyperu>The library syntax is B<hyperu>C<(a,b,x,I<prec>)>.
+
+=head2 X<incgam>incgamC<(s,x,{y})>
+
+incomplete gamma function.
+
+C<x> must be positive and C<s> real. The result returned is C<F<int>_x^ oo
+e^{-t}t^{s-1}dt>. When C<y> is given, assume (of course without checking!)
+that C<y = F<Gamma>(s)>. For small C<x>, this will tremendously speed up the
+computation.
+
+X<incgam>The library syntax is B<incgam>C<(s,x,I<prec>)> and C<X<incgam4>B<incgam4>(s,x,y,I<prec>)>,
+respectively. There exist also the functions X<incgam1>B<incgam1> and
+X<incgam2>B<incgam2> which are used for internal purposes.
+
+=head2 X<incgamc>incgamcC<(s,x)>
+
+complementary incomplete gamma function.
+
+The arguments C<s> and C<x> must be positive. The result returned is
+C<F<int>_0^x e^{-t}t^{s-1}dt>, when C<x> is not too large.
+
+X<incgam3>The library syntax is B<incgam3>C<(s,x,I<prec>)>.
+
+=head2 X<log>logC<(x,{I<flag> = 0})>
+
+principal branch of the natural logarithm of
+C<x>, i.e.S< >such that C<Im(ln(x)) belongs to ]-F<Pi>,F<Pi>]>. The result is complex
+(with imaginary part equal to C<F<Pi>>) if C<x belongs to B<I<R>>> and C<x E<lt> 0>.
+
+C<p>-adic arguments are also accepted for C<x>, with the convention that
+C< F<ln> (p) = 0>. Hence in particular C< F<exp> ( F<ln> (x))/x> will not in general be
+equal to 1 but to a C<(p-1)>-th root of unity (or C<F<+->1> if C<p = 2>)
+times a power of C<p>.
+
+If C<I<flag>> is equal to 1, use an agm formula suggested by Mestre, when C<x> is
+real, otherwise identical to C<log>.
+
+X<glog>The library syntax is B<glog>C<(x,I<prec>)> or C<X<glogagm>B<glogagm>(x,I<prec>)>.
+
+=head2 X<lngamma>lngammaC<(x)>
+
+principal branch of the logarithm of the gamma
+function of C<x>. Can have much larger arguments than C<gamma> itself.
+In the present version B<2.2.0>, the C<p>-adic C<lngamma> function is not
+implemented.
+
+X<glngamma>The library syntax is B<glngamma>C<(x,I<prec>)>.
+
+=head2 X<polylog>polylogC<(m,x,{I<flag> = 0})>
+
+one of the different polylogarithms,
+depending on I<flag>:
+
+If C<I<flag> = 0> or is omitted: C<m^th> polylogarithm of C<x>, i.e.S< >analytic
+continuation of the power series C<Li_m(x) = F<sum>_{n E<gt>= 1}x^n/n^m>. The
+program uses the power series when C<|x|^2 E<lt>= 1/2>, and the power series
+expansion in C< F<log> (x)> otherwise. It is valid in a large domain (at least
+C<|x| E<lt> 230>), but should not be used too far away from the unit circle since it
+is then better to use the functional equation linking the value at C<x> to the
+value at C<1/x>, which takes a trivial form for the variant below. Power
+series, polynomial, rational and vector/matrix arguments are allowed.
+
+For the variants to follow we need a notation: let C< F<Re> _m>
+denotes C< F<Re> > or C< F<Im> > depending whether C<m> is odd or even.
+
+If C<I<flag> = 1>: modified C<m^th> polylogarithm of C<x>, called
+C<~ D_m(x)> in Zagier, defined for C<|x| E<lt>= 1> by
+
+S< >C< F<Re> _m(F<sum>_{k = 0}^{m-1} ((- F<log> |x|)^k)/(k!)Li_{m-k}(x)
++((- F<log> |x|)^{m-1})/(m!) F<log> |1-x|).>
+
+If C<I<flag> = 2>: modified C<m^th> polylogarithm of C<x>,
+called C<D_m(x)> in Zagier, defined for C<|x| E<lt>= 1> by
+
+S< >C< F<Re> _m(F<sum>_{k = 0}^{m-1}((- F<log> |x|)^k)/(k!)Li_{m-k}(x)
+-(1)/(2)((- F<log> |x|)^m)/(m!)).>
+
+If C<I<flag> = 3>: another modified C<m^th>
+polylogarithm of C<x>, called C<P_m(x)> in Zagier, defined for C<|x| E<lt>= 1> by
+
+S< >C< F<Re> _m(F<sum>_{k = 0}^{m-1}(2^kB_k)/(k!)( F<log> |x|)^kLi_{m-k}(x)
+-(2^{m-1}B_m)/(m!)( F<log> |x|)^m).>
+
+These three functions satisfy the functional equation
+C<f_m(1/x) = (-1)^{m-1}f_m(x)>.
+
+X<polylog0>The library syntax is B<polylog0>C<(m,x,I<flag>,I<prec>)>.
+
+=head2 X<psi>psiC<(x)>
+
+the C<F<psi>>-function of C<x>, i.e.S< >the
+logarithmic derivative C<F<Gamma>'(x)/F<Gamma>(x)>.
+
+X<gpsi>The library syntax is B<gpsi>C<(x,I<prec>)>.
+
+=head2 X<sin>sinC<(x)>
+
+sine of C<x>.
+
+X<gsin>The library syntax is B<gsin>C<(x,I<prec>)>.
+
+=head2 X<sinh>sinhC<(x)>
+
+hyperbolic sine of C<x>.
+
+X<gsh>The library syntax is B<gsh>C<(x,I<prec>)>.
+
+=head2 X<sqr>sqrC<(x)>
+
+square of C<x>. This operation is not completely
+straightforward, i.e.S< >identical to C<x * x>, since it can usually be
+computed more efficiently (roughly one-half of the elementary
+multiplications can be saved). Also, squaring a C<2>-adic number increases
+its precision. For example,
+
+ ? (1 + O(2^4))^2
+ %1 = 1 + O(2^5)
+ ? (1 + O(2^4)) * (1 + O(2^4))
+ %2 = 1 + O(2^4)
+
+Note that this function is also called whenever one multiplies two objects
+which are known to be I<identical>, e.g.S< >they are the value of the same
+variable, or we are computing a power.
+
+ ? x = (1 + O(2^4)); x * x
+ %3 = 1 + O(2^5)
+ ? (1 + O(2^4))^4
+ %4 = 1 + O(2^6)
+
+(note the difference between C<%2> and C<%3> above).
+
+X<gsqr>The library syntax is B<gsqr>C<(x)>.
+
+=head2 X<sqrt>sqrtC<(x)>
+
+principal branch of the square root of C<x>,
+i.e.S< >such that C<Arg(sqrt(x)) belongs to ]-F<Pi>/2, F<Pi>/2]>, or in other
+words such that C< F<Re> (sqrt(x)) E<gt> 0> or C< F<Re> (sqrt(x)) = 0> and
+C< F<Im> (sqrt(x)) E<gt>= 0>. If C<x belongs to B<I<R>>> and C<x E<lt> 0>, then the result is
+complex with positive imaginary part.
+
+Integermod a prime and C<p>-adics are allowed as arguments. In that case,
+the square root (if it exists) which is returned is the one whose
+first C<p>-adic digit (or its unique C<p>-adic digit in the case of
+integermods) is in the interval C<[0,p/2]>. When the argument is an
+integermod a non-prime (or a non-prime-adic), the result is undefined.
+
+X<gsqrt>The library syntax is B<gsqrt>C<(x,I<prec>)>.
+
+=head2 X<sqrtn>sqrtnC<(x,n,{&z})>
+
+principal branch of the C<n>th root of C<x>,
+i.e.S< >such that C<Arg(sqrt(x)) belongs to ]-F<Pi>/n, F<Pi>/n]>.
+
+Integermod a prime and C<p>-adics are allowed as arguments.
+
+If C<z> is present, it is set to a suitable root of unity allowing to
+recover all the other roots. If it was not possible, z is
+set to zero.
+
+The following script computes all roots in all possible cases:
+
+ sqrtnall(x,n)=
+ {
+ local(V,r,z,r2);
+ r = sqrtn(x,n, &z);
+ if (!z, error("Impossible case in sqrtn"));
+ if (type(x) == "t_INTMOD" || type(x)=="t_PADIC" ,
+ r2 = r*z; n = 1;
+ while (r2!=r, r2*=z;n++));
+ V = vector(n); V[1] = r;
+ for(i=2, n, V[i] = V[i-1]*z);
+ V
+ }
+ addhelp(sqrtnall,"sqrtnall(x,n):compute the vector of nth-roots of x");
+
+X<gsqrtn>The library syntax is B<gsqrtn>C<(x,n,&z,I<prec>)>.
+
+=head2 X<tan>tanC<(x)>
+
+tangent of C<x>.
+
+X<gtan>The library syntax is B<gtan>C<(x,I<prec>)>.
+
+=head2 X<tanh>tanhC<(x)>
+
+hyperbolic tangent of C<x>.
+
+X<gth>The library syntax is B<gth>C<(x,I<prec>)>.
+
+=head2 X<teichmuller>teichmullerC<(x)>
+
+TeichmE<uuml>ller character of the C<p>-adic number
+C<x>.
+
+X<teich>The library syntax is B<teich>C<(x)>.
+
+=head2 X<theta>thetaC<(q,z)>
+
+Jacobi sine theta-function.
+
+X<theta>The library syntax is B<theta>C<(q,z,I<prec>)>.
+
+=head2 X<thetanullk>thetanullkC<(q,k)>
+
+C<k>-th derivative at C<z = 0> of
+C<theta(q,z)>.
+
+X<thetanullk>The library syntax is B<thetanullk>C<(q,k,I<prec>)>, where C<k> is a C<long>.
+
+=head2 X<weber>weberC<(x,{I<flag> = 0})>
+
+one of Weber's three C<f> functions.
+If C<I<flag> = 0>, returns
+
+S< >C<f(x) = F<exp> (-iF<Pi>/24).F<eta>((x+1)/2)/F<eta>(x) such that j = (f^{24}-16)^3/f^{24},>
+
+where C<j> is the elliptic C<j>-invariant (see the function C<ellj>).
+If C<I<flag> = 1>, returns
+
+S< >C<f_1(x) = F<eta>(x/2)/F<eta>(x) such that j = (f_1^{24}+16)^3/f_1^{24}.>
+
+Finally, if C<I<flag> = 2>, returns
+
+S< >C<f_2(x) = F<sqrt> {2}F<eta>(2x)/F<eta>(x) such that j = (f_2^{24}+16)^3/f_2^{24}.>
+
+Note the identities C<f^8 = f_1^8+f_2^8> and C<ff_1f_2 = F<sqrt> 2>.
+
+X<weber0>The library syntax is B<weber0>C<(x,I<flag>,I<prec>)>, or
+C<X<wf>B<wf>(x,I<prec>)>, C<X<wf1>B<wf1>(x,I<prec>)> or
+C<X<wf2>B<wf2>(x,I<prec>)>.
+
+=head2 X<zeta>zetaC<(s)>
+
+Riemann's zeta functionX<Riemann zeta-function>
+C<F<zeta>(s) = F<sum>_{n E<gt>= 1}n^{-s}>, computed using the X<Euler-Maclaurin>Euler-Maclaurin
+summation formula, except when C<s> is of type integer, in which case it
+is computed using Bernoulli numbersX<Bernoulli numbers> for
+C<s E<lt>= 0> or C<s E<gt> 0> and even, and using modular forms for C<s E<gt> 0> and odd.
+
+X<gzeta>The library syntax is B<gzeta>C<(s,I<prec>)>.
+
+=head1 Arithmetic functions
+
+X<Label se:arithmetic>
+These functions are by definition functions whose natural domain of
+definition is either B<I<Z>> (or C<B<I<Z>>_{ E<gt> 0}>), or sometimes polynomials
+over a base ring. Functions which concern polynomials exclusively will be
+explained in the next section. The way these functions are used is
+completely different from transcendental functions: in general only the types
+integer and polynomial are accepted as arguments. If a vector or matrix type
+is given, the function will be applied on each coefficient independently.
+
+In the present version B<2.2.0>, all arithmetic functions in the narrow sense
+of the wordS< >--- Euler's totientX<Euler totient function> function, the
+X<Moebius>Moebius function, the sums over divisors or powers of divisors
+etc.--- call, after trial division by small primes, the same versatile
+factoring machinery described under C<factorint>. It includes
+X<Shanks SQUFOF>Shanks SQUFOF, X<Pollard Rho>Pollard Rho, X<ECM>ECM and X<MPQS>MPQS stages, and
+has an early exit option for the functions X<moebius>B<moebius> and (the integer
+function underlying) X<issquarefree>B<issquarefree>. Note that it relies on a (fairly
+strong) probabilistic primality test: numbers found to be strong
+pseudo-primes after 10 successful trials of the X<Rabin-Miller>Rabin-Miller test are
+declared primes.
+
+=head2 X<addprimes>addprimesC<({x = []})>
+
+adds the primes contained in the vector
+C<x> (or the single integer C<x>) to the table computed upon GP initialization
+(by C<pari_init> in library mode), and returns a row vector whose first
+entries contain all primes added by the user and whose last entries have been
+filled up with 1's. In total the returned row vector has 100 components.
+Whenever C<factor> or C<smallfact> is subsequently called, first the
+primes in the table computed by C<pari_init> will be checked, and then
+the additional primes in this table. If C<x> is empty or omitted, just returns
+the current list of extra primes.
+
+The entries in C<x> are not checked for primality. They need only be positive
+integers not divisible by any of the pre-computed primes. It's in fact a nice
+trick to add composite numbers, which for example the function
+C<factor(x,0)> was not able to factor. In case the message ``impossible
+inverse modulo C<E<lt>>I<some integermod>C<E<gt>>'' shows up afterwards,
+you have just stumbled over a non-trivial factor. Note that the arithmetic
+functions in the narrow sense, like X<eulerphi>B<eulerphi>, do I<not> use this
+extra table.
+
+The present PARI version B<2.2.0> allows up to 100 user-specified
+primes to be appended to the table. This limit may be changed
+by altering C<NUMPRTBELT> in file C<init.c>. To remove primes from the
+list use C<removeprimes>.
+
+X<addprimes>The library syntax is B<addprimes>C<(x)>.
+
+=head2 X<bestappr>bestapprC<(x,k)>
+
+if C<x belongs to B<I<R>>>, finds the best rational
+approximation to C<x> with denominator at most equal to C<k> using continued
+fractions.
+
+X<bestappr>The library syntax is B<bestappr>C<(x,k)>.
+
+=head2 X<bezout>bezoutC<(x,y)>
+
+finds C<u> and C<v> minimal in a
+natural sense such that C<x*u+y*v = gcd(x,y)>. The arguments
+must be both integers or both polynomials, and the result is a
+row vector with three components C<u>, C<v>, and C<gcd(x,y)>.
+
+X<vecbezout>The library syntax is B<vecbezout>C<(x,y)> to get the vector, or C<X<gbezout>B<gbezout>(x,y, &u, &v)>
+which gives as result the address of the created gcd, and puts
+the addresses of the corresponding created objects into C<u> and C<v>.
+
+=head2 X<bezoutres>bezoutresC<(x,y)>
+
+as C<bezout>, with the resultant of C<x> and
+C<y> replacing the gcd.
+
+X<vecbezoutres>The library syntax is B<vecbezoutres>C<(x,y)> to get the vector, or C<X<subresext>B<subresext>(x,y, &u,
+&v)> which gives as result the address of the created gcd, and puts the
+addresses of the corresponding created objects into C<u> and C<v>.
+
+=head2 X<bigomega>bigomegaC<(x)>
+
+number of prime divisors of C<|x|> counted with
+multiplicity. C<x> must be an integer.
+
+X<bigomega>The library syntax is B<bigomega>C<(x)>, the result is a C<long>.
+
+=head2 X<binomial>binomialC<(x,y)>
+
+X<binomial coefficient>binomial coefficient C<\binom x y>.
+Here C<y> must be an integer, but C<x> can be any PARI object.
+
+X<binome>The library syntax is B<binome>C<(x,y)>, where C<y> must be a C<long>.
+
+=head2 X<chinese>chineseC<(x,y)>
+
+if C<x> and C<y> are both integermods or both
+polmods, creates (with the same type) a C<z> in the same residue class
+as C<x> and in the same residue class as C<y>, if it is possible.
+
+This function also allows vector and matrix arguments, in which case the
+operation is recursively applied to each component of the vector or matrix.
+For polynomial arguments, it is applied to each coefficient. Finally
+C<chinese(x,x) = x> regardless of the type of C<x>; this allows vector
+arguments to contain other data, so long as they are identical in both
+vectors.
+
+X<chinois>The library syntax is B<chinois>C<(x,y)>.
+
+=head2 X<content>contentC<(x)>
+
+computes the gcd of all the coefficients of C<x>,
+when this gcd makes sense. If C<x> is a scalar, this simply returns C<x>. If C<x>
+is a polynomial (and by extension a power series), it gives the usual content
+of C<x>. If C<x> is a rational function, it gives the ratio of the contents of
+the numerator and the denominator. Finally, if C<x> is a vector or a matrix,
+it gives the gcd of all the entries.
+
+X<content>The library syntax is B<content>C<(x)>.
+
+=head2 X<contfrac>contfracC<(x,{b},{lmax})>
+
+creates the row vector whose
+components are the partial quotients of the X<continued fraction>continued fraction
+expansion of C<x>, the number of partial quotients being limited to C<lmax>.
+If C<x> is a real number, the expansion stops at the last significant partial
+quotient if C<lmax> is omitted. C<x> can also be a rational function or a power
+series.
+
+If a vector C<b> is supplied, the numerators will be equal to the coefficients
+of C<b>. The length of the result is then equal to the length of C<b>, unless a
+partial remainder is encountered which is equal to zero. In which case the
+expansion stops. In the case of real numbers, the stopping criterion is thus
+different from the one mentioned above since, if C<b> is too long, some partial
+quotients may not be significant.
+
+If C<b> is an integer, the command is understood as C<contfrac(x,lmax)>.
+
+X<contfrac0>The library syntax is B<contfrac0>C<(x,b,lmax)>. Also available are
+C<X<gboundcf>B<gboundcf>(x,lmax)>, C<X<gcf>B<gcf>(x)>, or C<X<gcf2>B<gcf2>(b,x)>, where C<lmax>
+is a C integer.
+
+=head2 X<contfracpnqn>contfracpnqnC<(x)>
+
+when C<x> is a vector or a one-row matrix, C<x>
+is considered as the list of partial quotients C<[a_0,a_1,...,a_n]> of a
+rational number, and the result is the 2 by 2 matrix
+C<[p_n,p_{n-1};q_n,q_{n-1}]> in the standard notation of continued fractions,
+so C<p_n/q_n = a_0+1/(a_1+...+1/a_n)...)>. If C<x> is a matrix with two rows
+C<[b_0,b_1,...,b_n]> and C<[a_0,a_1,...,a_n]>, this is then considered as a
+generalized continued fraction and we have similarly
+C<p_n/q_n = 1/b_0(a_0+b_1/(a_1+...+b_n/a_n)...)>. Note that in this case one
+usually has C<b_0 = 1>.
+
+X<pnqn>The library syntax is B<pnqn>C<(x)>.
+
+=head2 X<core>coreC<(n,{I<flag> = 0})>
+
+if C<n> is a non-zero integer written as
+C<n = df^2> with C<d> squarefree, returns C<d>. If C<I<flag>> is non-zero,
+returns the two-element row vector C<[d,f]>.
+
+X<core0>The library syntax is B<core0>C<(n,I<flag>)>.
+Also available are
+C<X<core>B<core>(n)> ( = X<core>B<core>C<(n,0)>) and
+C<X<core2>B<core2>(n)> ( = X<core>B<core>C<(n,1)>).
+
+=head2 X<coredisc>corediscC<(n,{I<flag>})>
+
+if C<n> is a non-zero integer written as
+C<n = df^2> with C<d> fundamental discriminant (including 1), returns C<d>. If
+C<I<flag>> is non-zero, returns the two-element row vector C<[d,f]>. Note that if
+C<n> is not congruent to 0 or 1 modulo 4, C<f> will be a half integer and not
+an integer.
+
+X<coredisc0>The library syntax is B<coredisc0>C<(n,I<flag>)>.
+Also available are
+C<X<coredisc>B<coredisc>(n)> ( = X<coredisc>B<coredisc>C<(n,0)>) and
+C<X<coredisc2>B<coredisc2>(n)> ( = X<coredisc>B<coredisc>C<(n,1)>).
+
+=head2 X<dirdiv>dirdivC<(x,y)>
+
+C<x> and C<y> being vectors of perhaps different
+lengths but with C<y[1] ! = 0> considered as X<Dirichlet series>Dirichlet series, computes
+the quotient of C<x> by C<y>, again as a vector.
+
+X<dirdiv>The library syntax is B<dirdiv>C<(x,y)>.
+
+=head2 X<direuler>direulerC<(p = a,b,I<expr>,{c})>
+
+computes the
+X<Dirichlet series>Dirichlet series to C<b> terms of the X<Euler product>Euler product of
+expression I<expr> as C<p> ranges through the primes from C<a> to C<b>.
+I<expr> must be a polynomial or rational function in another variable
+than C<p> (say C<X>) and C<I<expr>(X)> is understood as the Dirichlet
+series (or more precisely the local factor) C<I<expr>(p^{-s})>. If C<c> is
+present, output only the first C<c> coefficients in the series.
+
+X<direuler>The library syntax is B<direuler>C<(entree *ep, GEN a, GEN b, char *expr)>
+
+=head2 X<dirmul>dirmulC<(x,y)>
+
+C<x> and C<y> being vectors of perhaps different
+lengths considered as X<Dirichlet series>Dirichlet series, computes the product of
+C<x> by C<y>, again as a vector.
+
+X<dirmul>The library syntax is B<dirmul>C<(x,y)>.
+
+=head2 X<divisors>divisorsC<(x)>
+
+creates a row vector whose components are the
+positive divisors of the integer C<x> in increasing order. The factorization
+of C<x> (as output by X<factor>C<factor>) can be used instead.
+
+X<divisors>The library syntax is B<divisors>C<(x)>.
+
+=head2 X<eulerphi>eulerphiC<(x)>
+
+Euler's C<F<phi>>
+(totient)X<Euler totient function> function of C<|x|>, in other words
+C<|(B<I<Z>>/xB<I<Z>>)^*|>. C<x> must be of type integer.
+
+X<phi>The library syntax is B<phi>C<(x)>.
+
+=head2 X<factor>factorC<(x,{I<lim> = -1})>
+
+general factorization function.
+If C<x> is of type integer, rational, polynomial or rational function, the
+result is a two-column matrix, the first column being the irreducibles
+dividing C<x> (prime numbers or polynomials), and the second the exponents.
+If C<x> is a vector or a matrix, the factoring is done componentwise (hence
+the result is a vector or matrix of two-column matrices). By definition,
+C<0> is factored as C<0^1>.
+
+If C<x> is of type integer or rational, an argument I<lim> can be
+added, meaning that we look only for factors up to I<lim>, or to
+C<primelimit>, whichever is lowest (except when C<I<lim> = 0> where the
+effect is identical to setting C<I<lim> = primelimit>). Hence in this
+case, the remaining part is not necessarily prime. See X<factorint>B<factorint> for
+more information about the algorithms used.
+
+The polynomials or rational functions to be factored must have scalar
+coefficients. In particular PARI does I<not> know how to factor
+multivariate polynomials.
+
+Note that PARI tries to guess in a sensible way over which ring you want
+to factor. Note also that factorization of polynomials is done up to
+multiplication by a constant. In particular, the factors of rational
+polynomials will have integer coefficients, and the content of a polynomial
+or rational function is discarded and not included in the factorization. If
+you need it, you can always ask for the content explicitly:
+
+ ? factor(t^2 + 5/2*t + 1)
+ %1 =
+ [2*t + 1 1]
+
+ [t + 2 1]
+
+ ? content(t^2 + 5/2*t + 1)
+ %2 = 1/2
+
+See also X<factornf>B<factornf>.
+
+X<factor0>The library syntax is B<factor0>C<(x,I<lim>)>, where I<lim> is a C integer.
+Also available are
+C<X<factor>B<factor>(x)> ( = C<X<factor0>B<factor0>(x,-1)>),
+C<X<smallfact>B<smallfact>(x)> ( = C<X<factor0>B<factor0>(x,0)>).
+
+=head2 X<factorback>factorbackC<(f,{nf})>
+
+C<f> being any factorization, gives back
+the factored object. If a second argument C<I<nf>> is supplied, C<f> is
+assumed to be a prime ideal factorization in the number field C<I<nf>>.
+The resulting ideal is given in HNFX<Hermite normal form> form.
+
+X<factorback>The library syntax is B<factorback>C<(f,I<nf>)>, where an omitted
+C<I<nf>> is entered as C<NULL>.
+
+=head2 X<factorcantor>factorcantorC<(x,p)>
+
+factors the polynomial C<x> modulo the
+prime C<p>, using distinct degree plus
+X<Cantor-Zassenhaus>Cantor-ZassenhausX<Zassenhaus>. The coefficients of C<x> must be
+operation-compatible with C<B<I<Z>>/pB<I<Z>>>. The result is a two-column matrix, the
+first column being the irreducible polynomials dividing C<x>, and the second
+the exponents. If you want only the I<degrees> of the irreducible
+polynomials (for example for computing an C<L>-function), use
+C<factormod(x,p,1)>. Note that the C<factormod> algorithm is
+usually faster than C<factorcantor>.
+
+X<factcantor>The library syntax is B<factcantor>C<(x,p)>.
+
+=head2 X<factorff>factorffC<(x,p,a)>
+
+factors the polynomial C<x> in the field
+C<B<I<F>>_q> defined by the irreducible polynomial C<a> over C<B<I<F>>_p>. The
+coefficients of C<x> must be operation-compatible with C<B<I<Z>>/pB<I<Z>>>. The result
+is a two-column matrix, the first column being the irreducible polynomials
+dividing C<x>, and the second the exponents. It is recommended to use for
+the variable of C<a> (which will be used as variable of a polmod) a name
+distinct from the other variables used, so that a C<lift()> of the
+result will be legible. If all the coefficients of C<x> are in C<B<I<F>>_p>, a much faster algorithm is applied, using the computation of isomorphisms between finite fields.
+
+X<factmod9>The library syntax is B<factmod9>C<(x,p,a)>.
+
+=head2 X<factorial>factorialC<(x)> or C<x!>
+
+factorial of C<x>. The expression C<x!>
+gives a result which is an integer, while C<factorial(x)> gives a real
+number.
+
+X<mpfact>The library syntax is B<mpfact>C<(x)> for C<x!> and
+C<X<mpfactr>B<mpfactr>(x,I<prec>)> for C<factorial(x)>. C<x> must be a C<long>
+integer and not a PARI integer.
+
+=head2 X<factorint>factorintC<(n,{I<flag> = 0})>
+
+factors the integer n using a
+combination of the X<Shanks SQUFOF>Shanks SQUFOF and X<Pollard Rho>Pollard Rho method (with
+modifications due to Brent), X<Lenstra>Lenstra's X<ECM>ECM (with modifications by
+Montgomery), and X<MPQS>MPQS (the latter adapted from the X<LiDIA>LiDIA code
+with the kind permission of the LiDIA maintainers), as well as a search for
+pure powers with exponentsC< E<lt>= 10>. The output is a two-column matrix as for
+C<factor>.
+
+This gives direct access to the integer factoring engine called by most
+arithmetical functions. I<flag> is optional; its binary digits mean 1: avoid
+MPQS, 2: skip first stage ECM (we may still fall back to it later), 4: avoid
+Rho and SQUFOF, 8: don't run final ECM (as a result, a huge composite may be
+declared to be prime). Note that a (strong) probabilistic primality test is
+used; thus composites might (very rarely) not be detected.
+
+The machinery underlying this function is still in a somewhat experimental
+state, but should be much faster on average than pure ECM as used by all
+PARI versions up to 2.0.8, at the expense of heavier memory use. You are
+invited to play with the flag settings and watch the internals at work by
+using GP's X<debuglevel>C<debuglevel> default parameter (level 3 shows just the
+outline, 4 turns on time keeping, 5 and above show an increasing amount
+of internal details). If you see anything funny happening, please let
+us know.
+
+X<factorint>The library syntax is B<factorint>C<(n,I<flag>)>.
+
+=head2 X<factormod>factormodC<(x,p,{I<flag> = 0})>
+
+factors the polynomial C<x> modulo
+the prime integer C<p>, using X<Berlekamp>Berlekamp. The coefficients of C<x> must be
+operation-compatible with C<B<I<Z>>/pB<I<Z>>>. The result is a two-column matrix, the
+first column being the irreducible polynomials dividing C<x>, and the second
+the exponents. If C<I<flag>> is non-zero, outputs only the I<degrees> of the
+irreducible polynomials (for example, for computing an C<L>-function). A
+different algorithm for computing the mod C<p> factorization is
+C<factorcantor> which is sometimes faster.
+
+X<factormod>The library syntax is B<factormod>C<(x,p,I<flag>)>. Also available are
+C<X<factmod>B<factmod>(x,p)> (which is equivalent to C<X<factormod>B<factormod>(x,p,0)>) and
+C<X<simplefactmod>B<simplefactmod>(x,p)> ( = C<X<factormod>B<factormod>(x,p,1)>).
+
+=head2 X<fibonacci>fibonacciC<(x)>
+
+C<x^{th}> Fibonacci number.
+
+X<fibo>The library syntax is B<fibo>C<(x)>. C<x> must be a C<long>.
+
+=head2 X<ffinit>ffinitC<(p,n,{v = x})>
+
+computes a monic polynomial of degree
+C<n> which is irreducible over C<B<I<F>>_p>. For instance if
+C<P = ffinit(3,2,y)>, you can represent elements in C<B<I<F>>_{3^2}> as polmods
+modulo C<P>.
+
+X<ffinit>The library syntax is B<ffinit>C<(p,n,v)>, where C<v> is a variable number.
+
+=head2 X<gcd>gcdC<(x,y,{I<flag> = 0})>
+
+creates the greatest common divisor of C<x>
+and C<y>. C<x> and C<y> can be of quite general types, for instance both
+rational numbers. Vector/matrix types are also accepted, in which case
+the GCD is taken recursively on each component. Note that for these
+types, C<gcd> is not commutative.
+
+If C<I<flag> = 0>, use X<Euclid>Euclid's algorithm.
+
+If C<I<flag> = 1>, use the modular gcd algorithm (C<x> and C<y> have to be
+polynomials, with integer coefficients).
+
+If C<I<flag> = 2>, use the X<subresultant algorithm>subresultant algorithm.
+
+X<gcd0>The library syntax is B<gcd0>C<(x,y,I<flag>)>. Also available are
+C<X<ggcd>B<ggcd>(x,y)>, C<X<modulargcd>B<modulargcd>(x,y)>, and C<X<srgcd>B<srgcd>(x,y)>
+corresponding to C<I<flag> = 0>, C<1> and C<2> respectively.
+
+=head2 X<hilbert>hilbertC<(x,y,{p})>
+
+X<Hilbert symbol>Hilbert symbol of C<x> and C<y> modulo
+C<p>. If C<x> and C<y> are of type integer or fraction, an explicit third
+parameter C<p> must be supplied, C<p = 0> meaning the place at infinity.
+Otherwise, C<p> needs not be given, and C<x> and C<y> can be of compatible types
+integer, fraction, real, integermod a prime (result is undefined if the
+modulus is not prime), or C<p>-adic.
+
+X<hil>The library syntax is B<hil>C<(x,y,p)>.
+
+=head2 X<isfundamental>isfundamentalC<(x)>
+
+true (1) if C<x> is equal to 1 or to the
+discriminant of a quadratic field, false (0) otherwise.
+
+X<gisfundamental>The library syntax is B<gisfundamental>C<(x)>, but the
+simpler function C<X<isfundamental>B<isfundamental>(x)> which returns a C<long>
+should be used if C<x> is known to be of type integer.
+
+=head2 X<isprime>isprimeC<(x,{I<flag> = 0})>
+
+if C<I<flag> = 0> (default), true (1) if C<x> is a strong pseudo-prime
+for 10 randomly chosen bases, false (0) otherwise.
+
+If C<I<flag> = 1>, use Pocklington-Lehmer ``P-1'' test. true (1) if C<x> is
+prime, false (0) otherwise.
+
+If C<I<flag> = 2>, use Pocklington-Lehmer ``P-1'' test and output a primality
+certificate as follows: return 0 if C<x> is composite, 1 if C<x> is a
+small prime (currently strictly less than C<341 550 071 728 321>), and
+a matrix if C<x> is a large prime. The matrix has three columns. The
+first contains the prime factors C<p>, the second the corresponding
+elements C<a_p> as in PropositionS< >8.3.1 in GTMS< >138, and the third the
+output of isprime(p,2).
+
+In the two last cases, the algorithm fails if one of the (strong
+pseudo-)prime factors is not prime, but it should be exceedingly rare.
+
+X<gisprime>The library syntax is B<gisprime>C<(x,I<flag>)>, but the simpler function C<X<isprime>B<isprime>(x)>
+which returns a C<long> should be used if C<x> is known to be of
+type integer. Also available is C<X<plisprime>B<plisprime>(N,I<flag>)>,
+corresponding to C<X<gisprime>B<gisprime>(x,I<flag>+1)> if C<x> is known to be of
+type integer.
+
+=head2 X<ispseudoprime>ispseudoprimeC<(x)>
+
+true (1) if C<x> is a strong
+pseudo-prime for a randomly chosen base, false (0) otherwise.
+
+X<gispsp>The library syntax is B<gispsp>C<(x)>, but the
+simpler function C<X<ispsp>B<ispsp>(x)> which returns a C<long>
+should be used if C<x> is known to be of type integer.
+
+=head2 X<issquare>issquareC<(x,{&n})>
+
+true (1) if C<x> is square, false (0) if
+not. C<x> can be of any type. If C<n> is given and an exact square root had to
+be computed in the checking process, puts that square root in C<n>. This is in
+particular the case when C<x> is an integer or a polynomial. This is I<not>
+the case for intmods (use quadratic reciprocity) or series (only check the
+leading coefficient).
+
+X<gcarrecomplet>The library syntax is B<gcarrecomplet>C<(x,&n)>. Also available is C<X<gcarreparfait>B<gcarreparfait>(x)>.
+
+=head2 X<issquarefree>issquarefreeC<(x)>
+
+true (1) if C<x> is squarefree, false (0) if not.
+Here C<x> can be an integer or a polynomial.
+
+X<gissquarefree>The library syntax is B<gissquarefree>C<(x)>, but the simpler function C<X<issquarefree>B<issquarefree>(x)>
+which returns a C<long> should be used if C<x> is known to be of type
+integer. This X<issquarefree>B<issquarefree> is just the square of the
+X<Moebius>Moebius function, and is computed as a multiplicative
+arithmetic function much like the latter.
+
+=head2 X<kronecker>kroneckerC<(x,y)>
+
+KroneckerX<Kronecker symbol>X<Legendre symbol>
+(i.e.S< >generalized Legendre) symbol C<((x)/(y))>. C<x> and C<y>
+must be of type integer.
+
+X<kronecker>The library syntax is B<kronecker>C<(x,y)>, the result (C<0> or C<F<+-> 1>) is a C<long>.
+
+=head2 X<lcm>lcmC<(x,y)>
+
+least common multiple of C<x> and C<y>, i.e.S< >such
+that C<lcm(x,y)*gcd(x,y) = abs(x*y)>.
+
+X<glcm>The library syntax is B<glcm>C<(x,y)>.
+
+=head2 X<moebius>moebiusC<(x)>
+
+X<Moebius>Moebius C<F<mu>>-function of C<|x|>. C<x> must
+be of type integer.
+
+X<mu>The library syntax is B<mu>C<(x)>, the result (C<0> or C<F<+-> 1>) is a C<long>.
+
+=head2 X<nextprime>nextprimeC<(x)>
+
+finds the smallest prime greater than or
+equal to C<x>. C<x> can be of any real type. Note that if C<x> is a prime,
+this function returns C<x> and not the smallest prime strictly larger than C<x>.
+
+X<nextprime>The library syntax is B<nextprime>C<(x)>.
+
+=head2 X<numdiv>numdivC<(x)>
+
+number of divisors of C<|x|>. C<x> must be of type
+integer, and the result is a C<long>.
+
+X<numbdiv>The library syntax is B<numbdiv>C<(x)>.
+
+=head2 X<omega>omegaC<(x)>
+
+number of distinct prime divisors of C<|x|>. C<x>
+must be of type integer.
+
+X<omega>The library syntax is B<omega>C<(x)>, the result is a C<long>.
+
+=head2 X<precprime>precprimeC<(x)>
+
+finds the largest prime less than or equal to
+C<x>. C<x> can be of any real type. Returns 0 if C<x E<lt>= 1>.
+Note that if C<x> is a prime, this function returns C<x> and not the largest
+prime strictly smaller than C<x>.
+
+X<precprime>The library syntax is B<precprime>C<(x)>.
+
+=head2 X<prime>primeC<(x)>
+
+the C<x^{th}> prime number, which must be among
+the precalculated primes.
+
+X<prime>The library syntax is B<prime>C<(x)>. C<x> must be a C<long>.
+
+=head2 X<primes>primesC<(x)>
+
+creates a row vector whose components
+are the first C<x> prime numbers, which must be among the precalculated primes.
+
+X<primes>The library syntax is B<primes>C<(x)>. C<x> must be a C<long>.
+
+=head2 X<qfbclassno>qfbclassnoC<(x,{I<flag> = 0})>
+
+class number of the quadratic field
+of discriminant C<x>. In the present version B<2.2.0>, a simple algorithm is used
+for C<x E<gt> 0>, so C<x> should not be too large (say C<x E<lt> 10^7>) for the time to be
+reasonable. On the other hand, for C<x E<lt> 0> one can reasonably compute
+classno(C<x>) for C<|x| E<lt> 10^{25}>, since the method used is X<Shanks>Shanks' method
+which is in C<O(|x|^{1/4})>. For larger values of C<|D|>, see
+C<quadclassunit>.
+
+If C<I<flag> = 1>, compute the class number using X<Euler product>Euler products and the
+functional equation. However, it is in C<O(|x|^{1/2})>.
+
+B<Important warning.> For C<D E<lt> 0>, this function often gives
+incorrect results when the class group is non-cyclic, because the authors
+were too lazy to implement X<Shanks>Shanks' method completely. It is therefore
+strongly recommended to use either the version with C<I<flag> = 1>, the function
+C<qfbhclassno(-x)> if C<x> is known to be a fundamental discriminant, or
+the function C<quadclassunit>.
+
+X<qfbclassno0>The library syntax is B<qfbclassno0>C<(x,I<flag>)>. Also available are
+C<X<classno>B<classno>(x)> ( = C<X<qfbclassno>B<qfbclassno>(x)>),
+C<X<classno2>B<classno2>(x)> ( = C<X<qfbclassno>B<qfbclassno>(x,1)>), and finally
+there exists the function C<X<hclassno>B<hclassno>(x)> which computes the class
+number of an imaginary quadratic field by counting reduced forms, an C<O(|x|)>
+algorithm. See also C<qfbhclassno>.
+
+=head2 X<qfbcompraw>qfbcomprawC<(x,y)>
+
+X<composition>composition of the binary quadratic forms
+C<x> and C<y>, without X<reduction>reduction of the result. This is useful e.g.S< >to
+compute a generating element of an ideal.
+
+X<compraw>The library syntax is B<compraw>C<(x,y)>.
+
+=head2 X<qfbhclassno>qfbhclassnoC<(x)>
+
+X<Hurwitz class number>Hurwitz class number of C<x>, where C<x> is
+non-negative and congruent to 0 or 3 modulo 4. See also C<qfbclassno>.
+
+X<hclassno>The library syntax is B<hclassno>C<(x)>.
+
+=head2 X<qfbnucomp>qfbnucompC<(x,y,l)>
+
+X<composition>composition of the primitive positive
+definite binary quadratic forms C<x> and C<y> using the NUCOMP and NUDUPL
+algorithms of X<Shanks>Shanks (E<agrave> la Atkin). C<l> is any positive constant,
+but for optimal speed, one should take C<l = |D|^{1/4}>, where C<D> is the common
+discriminant of C<x> and C<y>. When C<x> and C<y> do not have the same
+discriminant, the result is undefined.
+
+X<nucomp>The library syntax is B<nucomp>C<(x,y,l)>. The auxiliary function
+C<X<nudupl>B<nudupl>(x,l)> should be used instead for speed when C<x = y>.
+
+=head2 X<qfbnupow>qfbnupowC<(x,n)>
+
+C<n>-th power of the primitive positive definite
+binary quadratic form C<x> using the NUCOMP and NUDUPL algorithms (see
+C<qfbnucomp>).
+
+X<nupow>The library syntax is B<nupow>C<(x,n)>.
+
+=head2 X<qfbpowraw>qfbpowrawC<(x,n)>
+
+C<n>-th power of the binary quadratic form
+C<x>, computed without doing any X<reduction>reduction (i.e.S< >using C<qfbcompraw>).
+Here C<n> must be non-negative and C<n E<lt> 2^{31}>.
+
+X<powraw>The library syntax is B<powraw>C<(x,n)> where C<n> must be a C<long>
+integer.
+
+=head2 X<qfbprimeform>qfbprimeformC<(x,p)>
+
+prime binary quadratic form of discriminant
+C<x> whose first coefficient is the prime number C<p>. By abuse of notation,
+C<p = 1> is a valid special case which returns the unit form. Returns an
+error if C<x> is not a quadratic residue mod C<p>. In the case where C<x E<gt> 0>,
+the ``distance'' component of the form is set equal to zero according to
+the current precision.
+
+X<primeform>The library syntax is B<primeform>C<(x,p,I<prec>)>, where the third variable C<I<prec>> is a
+C<long>, but is only taken into account when C<x E<gt> 0>.
+
+=head2 X<qfbred>qfbredC<(x,{I<flag> = 0},{D},{I<isqrtD>},{I<sqrtD>})>
+
+reduces the binary quadratic form C<x> (updating Shanks's distance function
+if C<x> is indefinite). The binary digits of C<I<flag>> are toggles meaning
+
+S< >S< >1: perform a single X<reduction>reduction step
+
+S< >S< >2: don't update X<Shanks>Shanks's distance
+
+C<D>, I<isqrtD>, I<sqrtD>, if present, supply the values of the
+discriminant, C<\lfloor F<sqrt> {D}\rfloor>, and C< F<sqrt> {D}> respectively
+(no checking is done of these facts). If C<D E<lt> 0> these values are useless,
+and all references to Shanks's distance are irrelevant.
+
+X<qfbred0>The library syntax is B<qfbred0>C<(x,I<flag>,D,I<isqrtD>,I<sqrtD>)>. Use C<NULL>
+to omit any of C<D>, I<isqrtD>, I<sqrtD>.
+
+Also available are
+
+C<X<redimag>B<redimag>(x)> ( = C<X<qfbred>B<qfbred>(x)> where C<x> is definite),
+
+and for indefinite forms:
+
+C<X<redreal>B<redreal>(x)> ( = C<X<qfbred>B<qfbred>(x)>),
+
+C<X<rhoreal>B<rhoreal>(x)> ( = C<X<qfbred>B<qfbred>(x,1)>),
+
+C<X<redrealnod>B<redrealnod>(x,sq)> ( = C<X<qfbred>B<qfbred>(x,2,,isqrtD)>),
+
+C<X<rhorealnod>B<rhorealnod>(x,sq)> ( = C<X<qfbred>B<qfbred>(x,3,,isqrtD)>).
+
+=head2 X<quadclassunit>quadclassunitC<(D,{I<flag> = 0},{I<tech> = []})>
+
+X<Buchmann-McCurley>Buchmann-McCurley's sub-exponential algorithm for computing the class
+group of a quadratic field of discriminant C<D>. If C<D> is not fundamental,
+the function may or may not be defined, but usually is, and often gives the
+right answer (a warning is issued). The more general function X<bnrinit>C<bnrinit>
+should be used to compute the class group of an order.
+
+This function should be used instead of C<qfbclassno> or C<quadregula>
+when C<D E<lt> -10^{25}>, C<D E<gt> 10^{10}>, or when the I<structure> is wanted.
+
+If C<I<flag>> is non-zero I<and> C<D E<gt> 0>, computes the narrow class group and
+regulator, instead of the ordinary (or wide) ones. In the current version
+B<2.2.0>, this doesn't work at allS< >: use the general function X<bnfnarrow>C<bnfnarrow>.
+
+Optional parameter I<tech> is a row vector of the form
+C<[c_1,c_2]>, where C<c_1> and C<c_2> are positive real numbers which
+control the execution time and the stack size. To get maximum speed,
+set C<c_2 = c>. To get a rigorous result (under X<GRH>GRH) you must take
+C<c_2 = 6>. Reasonable values for C<c> are between C<0.1> and C<2>.
+
+The result of this function is a vector C<v> with 4 components if C<D E<lt> 0>, and
+C<5> otherwise. The correspond respectively to
+
+C<B<*>> C<v[1]>S< >: the class number
+
+C<B<*>> C<v[2]>S< >: a vector giving the structure of the class group as a
+product of cyclic groups;
+
+C<B<*>> C<v[3]>S< >: a vector giving generators of those cyclic groups (as
+binary quadratic forms).
+
+C<B<*>> C<v[4]>S< >: (omitted if C<D E<lt> 0>) the regulator, computed to an
+accuracy which is the maximum of an internal accuracy determined by the
+program and the current default (note that once the regulator is known to a
+small accuracy it is trivial to compute it to very high accuracy, see the
+tutorial).
+
+C<B<*>> C<v[5]>S< >: a measure of the correctness of the result. If it is
+close to 1, the result is correct (under X<GRH>GRH). If it is close to a
+larger integer, this shows that the class number is off by a factor equal
+to this integer, and you must start again with a larger value for C<c_1> or
+a different random seed. In this case, a warning message is printed.
+
+X<quadclassunit0>The library syntax is B<quadclassunit0>C<(D,I<flag>,tech)>. Also available are
+C<X<buchimag>B<buchimag>(D,c_1,c_2)> and C<X<buchreal>B<buchreal>(D,I<flag>,c_1,c_2)>.
+
+=head2 X<quaddisc>quaddiscC<(x)>
+
+discriminant of the quadratic field
+C<B<I<Q>>( F<sqrt> {x})>, where C<x belongs to B<I<Q>>>.
+
+X<quaddisc>The library syntax is B<quaddisc>C<(x)>.
+
+=head2 X<quadhilbert>quadhilbertC<(D,{I<flag> = 0})>
+
+relative equation defining the
+X<Hilbert class field>Hilbert class field of the quadratic field of discriminant C<D>.
+If C<I<flag>> is non-zero
+and C<D E<lt> 0>, outputs C<[I<form>,I<root>(I<form>)]> (to be used for
+constructing subfields). If C<I<flag>> is non-zero and C<D E<gt> 0>, try hard to
+get the best modulus.
+Uses complex multiplication in the imaginary case and X<Stark units>Stark units
+in the real case.
+
+X<quadhilbert>The library syntax is B<quadhilbert>C<(D,I<flag>,I<prec>)>.
+
+=head2 X<quadgen>quadgenC<(x)>
+
+creates the quadratic numberX<omega>
+C<F<omega> = (a+ F<sqrt> {x})/2> where C<a = 0> if C<x = 0 mod 4>,
+C<a = 1> if C<x = 1 mod 4>, so that C<(1,F<omega>)> is an integral basis for
+the quadratic order of discriminant C<x>. C<x> must be an integer congruent to
+0 or 1 modulo 4.
+
+X<quadgen>The library syntax is B<quadgen>C<(x)>.
+
+=head2 X<quadpoly>quadpolyC<(D,{v = x})>
+
+creates the ``canonical'' quadratic
+polynomial (in the variable C<v>) corresponding to the discriminant C<D>,
+i.e.S< >the minimal polynomial of C<quadgen(x)>. C<D> must be an integer
+congruent to 0 or 1 modulo 4.
+
+X<quadpoly0>The library syntax is B<quadpoly0>C<(x,v)>.
+
+=head2 X<quadray>quadrayC<(D,f,{I<flag> = 0})>
+
+relative equation for the ray class
+field of conductor C<f> for the quadratic field of discriminant C<D> (which
+can also be a C<bnf>), using analytic methods.
+
+For C<D E<lt> 0>, uses the C<F<sigma>> function. C<I<flag>> has the following meaning: if
+it's an odd integer, outputs instead the vector of C<[I<ideal>,
+I<corresponding root>]>. It can also be a two-component vector
+C<[F<lambda>,I<flag>]>, where I<flag> is as above and C<F<lambda>> is the technical
+element of C<bnf> necessary for Schertz's method. In that case, returns
+0 if C<F<lambda>> is not suitable.
+
+For C<D E<gt> 0>, uses Stark's conjecture. If C<I<flag>> is non-zero, try hard to
+get the best modulus. The function may fail with the following message
+
+ "Cannot find a suitable modulus in FindModulus"
+
+See X<bnrstark>C<bnrstark> for more details about the real case.
+
+X<quadray>The library syntax is B<quadray>C<(D,f,I<flag>)>.
+
+=head2 X<quadregulator>quadregulatorC<(x)>
+
+regulator of the quadratic field of
+positive discriminant C<x>. Returns an error if C<x> is not a discriminant
+(fundamental or not) or if C<x> is a square. See also C<quadclassunit> if
+C<x> is large.
+
+X<regula>The library syntax is B<regula>C<(x,I<prec>)>.
+
+=head2 X<quadunit>quadunitC<(x)>
+
+fundamental unitX<fundamental units> of the
+real quadratic field C<B<I<Q>>( F<sqrt> x)> where C<x> is the positive discriminant
+of the field. If C<x> is not a fundamental discriminant, this probably gives
+the fundamental unit of the corresponding order. C<x> must be of type
+integer, and the result is a quadratic number.
+
+X<fundunit>The library syntax is B<fundunit>C<(x)>.
+
+=head2 X<removeprimes>removeprimesC<({x = []})>
+
+removes the primes listed in C<x> from
+the prime number table. In particular C<removeprimes(addprimes)> empties
+the extra prime table. C<x> can also be a single integer. List the current
+extra primes if C<x> is omitted.
+
+X<removeprimes>The library syntax is B<removeprimes>C<(x)>.
+
+=head2 X<sigma>sigmaC<(x,{k = 1})>
+
+sum of the C<k^{th}> powers of the
+positive divisors of C<|x|>. C<x> must be of type integer.
+
+X<sumdiv>The library syntax is B<sumdiv>C<(x)> ( = C<X<sigma>B<sigma>(x)>) or C<X<gsumdivk>B<gsumdivk>(x,k)> ( =
+C<X<sigma>B<sigma>(x,k)>), where C<k> is a C long integer.
+
+=head2 X<sqrtint>sqrtintC<(x)>
+
+integer square root of C<x>, which must be of PARI
+type integer. The result is non-negative and rounded towards zero. A
+negative C<x> is allowed, and the result in that case is C<I*sqrtint(-x)>.
+
+X<racine>The library syntax is B<racine>C<(x)>.
+
+=head2 X<znlog>znlogC<(x,g)>
+
+C<g> must be a primitive root mod a prime C<p>, and
+the result is the discrete log of C<x> in the multiplicative group
+C<(B<I<Z>>/pB<I<Z>>)^*>. This function using a simple-minded baby-step/giant-step
+approach and requires C<O( F<sqrt> {p})> storage, hence it cannot be used for
+C<p> greater than about C<10^{13}>.
+
+X<znlog>The library syntax is B<znlog>C<(x,g)>.
+
+=head2 X<znorder>znorderC<(x)>
+
+C<x> must be an integer mod C<n>, and the result is the
+order of C<x> in the multiplicative group C<(B<I<Z>>/nB<I<Z>>)^*>. Returns an error if C<x>
+is not invertible.
+
+X<order>The library syntax is B<order>C<(x)>.
+
+=head2 X<znprimroot>znprimrootC<(x)>
+
+returns a primitive root of C<x>, where C<x>
+is a prime power.
+
+X<gener>The library syntax is B<gener>C<(x)>.
+
+=head2 X<znstar>znstarC<(n)>
+
+gives the structure of the multiplicative group
+C<(B<I<Z>>/nB<I<Z>>)^*> as a 3-component row vector C<v>, where C<v[1] = F<phi>(n)> is the
+order of that group, C<v[2]> is a C<k>-component row-vector C<d> of integers
+C<d[i]> such that C<d[i] E<gt> 1> and C<d[i] | d[i-1]> for C<i E<gt>= 2> and
+C<(B<I<Z>>/nB<I<Z>>)^* ~ F<prod>_{i = 1}^k(B<I<Z>>/d[i]B<I<Z>>)>, and C<v[3]> is a C<k>-component row
+vector giving generators of the image of the cyclic groups C<B<I<Z>>/d[i]B<I<Z>>>.
+
+X<znstar>The library syntax is B<znstar>C<(n)>.
+
+=head1 Functions related to elliptic curves
+
+We have implemented a number of functions which are useful for number
+theorists working on elliptic curves. We always use X<Tate>Tate's notations.
+The functions assume that the curve is given by a general Weierstrass
+modelX<Weierstrass equation>
+
+S< >C<
+y^2+a_1xy+a_3y = x^3+a_2x^2+a_4x+a_6,
+>
+
+where a priori the C<a_i> can be of any scalar type. This curve can be
+considered as a five-component vector C<E = [a1,a2,a3,a4,a6]>. Points on
+C<E> are represented as two-component vectors C<[x,y]>, except for the
+point at infinity, i.e.S< >the identity element of the group law, represented by
+the one-component vector C<[0]>.
+
+It is useful to have at one's disposal more information. This is given by
+the function X<ellinit>C<ellinit> (see there), which usually gives a 19 component
+vector (which we will call a long vector in this section). If a specific flag
+is added, a vector with only 13 component will be output (which we will call
+a medium vector). A medium vector just gives the first 13 components of the
+long vector corresponding to the same curve, but is of course faster to
+compute. The following X<member functions>member functions are available to deal with the
+output of C<ellinit>:
+
+S< > C<a1>--C<a6>, C<b2>--C<b8>, C<c4>--C<c6> :
+coefficients of the elliptic curve.
+
+S< > X<area>C<area> : volume of the complex lattice defining C<E>.
+
+S< > X<disc>C<disc> : discriminant of the curve.
+
+S< > X<j>C<j> : C<j>-invariant of the curve.
+
+S< > X<omega>C<omega> : C<[F<omega>_1,F<omega>_2]>, periods forming a basis of
+the complex lattice defining C<E> (C<F<omega>_1> is the
+
+S< > real period, and C<F<omega>_2/F<omega>_1> belongs to
+PoincarE<eacute>'s half-plane).
+
+S< > X<eta>C<eta> : quasi-periods C<[F<eta>_1, F<eta>_2]>, such that
+C<F<eta>_1F<omega>_2-F<eta>_2F<omega>_1 = iF<Pi>>.
+
+S< > X<roots>C<roots> : roots of the associated Weierstrass equation.
+
+S< > X<tate>C<tate> : C<[u^2,u,v]> in the notation of Tate.
+
+S< > X<w>C<w> : Mestre's C<w> (this is technical).
+
+Their use is best described by an example: assume that C<E> was output by
+C<ellinit>, then typing C<E.disc> will retrieve the curve's
+discriminant. The member functions C<area>, C<eta> and C<omega> are
+only available for curves over B<I<Q>>. Conversely, C<tate> and C<w> are
+only available for curves defined over C<B<I<Q>>_p>.
+
+Some functions, in particular those relative to height computations (see
+C<ellheight>) require also that the curve be in minimal Weierstrass
+form. This is achieved by the function C<ellglobalred>.
+
+All functions related to elliptic curves share the prefix C<ell>, and the
+precise curve we are interested in is always the first argument, in either
+one of the three formats discussed above, unless otherwise specified. For
+instance, in functions which do not use the extra information given by long
+vectors, the curve can be given either as a five-component vector, or by one
+of the longer vectors computed by C<ellinit>.
+
+=head2 X<elladd>elladdC<(E,z1,z2)>
+
+sum of the points C<z1> and C<z2> on the
+elliptic curve corresponding to the vector C<E>.
+
+X<addell>The library syntax is B<addell>C<(E,z1,z2)>.
+
+=head2 X<ellak>ellakC<(E,n)>
+
+computes the coefficient C<a_n> of the
+C<L>-function of the elliptic curve C<E>, i.e.S< >in principle coefficients of a
+newform of weight 2 assuming X<Taniyama-Weil conjecture>Taniyama-Weil conjecture (which is now
+known to hold in full generality thanks to the work of X<Breuil>Breuil,
+X<Conrad>Conrad, X<Diamond>Diamond, X<Taylor>Taylor and X<Wiles>Wiles). C<E> must be a
+medium or long vector of the type given by C<ellinit>. For this function
+to work for every C<n> and not just those prime to the conductor, C<E> must
+be a minimal Weierstrass equation. If this is not the case, use the
+function C<ellglobalred> first before using C<ellak>.
+
+X<akell>The library syntax is B<akell>C<(E,n)>.
+
+=head2 X<ellan>ellanC<(E,n)>
+
+computes the vector of the first C<n> C<a_k>
+corresponding to the elliptic curve C<E>. All comments in C<ellak>
+description remain valid.
+
+X<anell>The library syntax is B<anell>C<(E,n)>, where C<n> is a C integer.
+
+=head2 X<ellap>ellapC<(E,p,{I<flag> = 0})>
+
+computes the C<a_p> corresponding to the
+elliptic curve C<E> and the prime number C<p>. These are defined by the
+equation C<#E(B<I<F>>_p) = p+1 - a_p>, where C<#E(B<I<F>>_p)> stands for the number
+of points of the curve C<E> over the finite field C<B<I<F>>_p>. When C<I<flag>> is C<0>,
+this uses the baby-step giant-step method and a trick due to Mestre. This
+runs in time C<O(p^{1/4})> and requires C<O(p^{1/4})> storage, hence becomes
+unreasonable when C<p> has about 30 digits.
+
+If C<I<flag>> is C<1>, computes the C<a_p> as a sum of Legendre symbols. This is
+slower than the previous method as soon as C<p> is greater than 100, say.
+
+No checking is done that C<p> is indeed prime. C<E> must be a medium or long
+vector of the type given by C<ellinit>, defined over B<I<Q>>, C<B<I<F>>_p> or
+C<B<I<Q>>_p>. C<E> must be given by a Weierstrass equation minimal at C<p>.
+
+X<ellap0>The library syntax is B<ellap0>C<(E,p,I<flag>)>. Also available are C<X<apell>B<apell>(E,p)>, corresponding
+to C<I<flag> = 0>, and C<X<apell2>B<apell2>(E,p)> (C<I<flag> = 1>).
+
+=head2 X<ellbil>ellbilC<(E,z1,z2)>
+
+if C<z1> and C<z2> are points on the elliptic
+curve C<E>, this function computes the value of the canonical bilinear form on
+C<z1>, C<z2>:
+
+S< >C<
+ellheight(E,z1+z2) - ellheight(E,z1) - ellheight(E,z2)
+>
+
+where C<+> denotes of course addition on C<E>. In addition, C<z1> or C<z2>
+(but not both) can be vectors or matrices. Note that this is equal to twice
+some normalizations. C<E> is assumed to be integral, given by a minimal model.
+
+X<bilhell>The library syntax is B<bilhell>C<(E,z1,z2,I<prec>)>.
+
+=head2 X<ellchangecurve>ellchangecurveC<(E,v)>
+
+changes the data for the elliptic curve C<E>
+by changing the coordinates using the vector C<v = [u,r,s,t]>, i.e.S< >if C<x'>
+and C<y'> are the new coordinates, then C<x = u^2x'+r>, C<y = u^3y'+su^2x'+t>.
+The vector C<E> must be a medium or long vector of the type given by
+C<ellinit>.
+
+X<coordch>The library syntax is B<coordch>C<(E,v)>.
+
+=head2 X<ellchangepoint>ellchangepointC<(x,v)>
+
+changes the coordinates of the point or
+vector of points C<x> using the vector C<v = [u,r,s,t]>, i.e.S< >if C<x'> and
+C<y'> are the new coordinates, then C<x = u^2x'+r>, C<y = u^3y'+su^2x'+t> (see also
+C<ellchangecurve>).
+
+X<pointch>The library syntax is B<pointch>C<(x,v)>.
+
+=head2 X<elleisnum>elleisnumC<(E,k,{I<flag> = 0})>
+
+C<E> being an elliptic curve as
+output by C<ellinit> (or, alternatively, given by a 2-component vector
+C<[F<omega>_1,F<omega>_2]>), and C<k> being an even positive integer, computes
+the numerical value of the Eisenstein series of weight C<k> at C<E>. When
+I<flag> is non-zero and C<k = 4> or 6, returns C<g_2> or C<g_3> with the correct
+normalization.
+
+X<elleisnum>The library syntax is B<elleisnum>C<(E,k,I<flag>)>.
+
+=head2 X<elleta>elletaC<(om)>
+
+returns the two-component row vector
+C<[F<eta>_1,F<eta>_2]> of quasi-periods associated to C<om = [F<omega>_1,
+F<omega>_2]>
+
+X<elleta>The library syntax is B<elleta>C<(om, I<prec>)>
+
+=head2 X<ellglobalred>ellglobalredC<(E)>
+
+calculates the arithmetic conductor, the global
+minimal model of C<E> and the global X<Tamagawa number>Tamagawa number C<c>. Here C<E> is an
+elliptic curve given by a medium or long vector of the type given by
+C<ellinit>, I<and is supposed to have all its coefficients C<a_i> in>
+B<I<Q>>. The result is a 3 component vector C<[N,v,c]>. C<N> is the arithmetic
+conductor of the curve, C<v> is itself a vector C<[u,r,s,t]> with rational
+components. It gives a coordinate change for C<E> over B<I<Q>> such that the
+resulting model has integral coefficients, is everywhere minimal, C<a_1> is 0
+or 1, C<a_2> is 0, 1 or C<-1> and C<a_3> is 0 or 1. Such a model is unique, and
+the vector C<v> is unique if we specify that C<u> is positive. To get the new
+model, simply type C<ellchangecurve(E,v)>. Finally C<c> is the product of
+the local Tamagawa numbers C<c_p>, a quantity which enters in the
+X<Birch and Swinnerton-Dyer conjecture>Birch and Swinnerton-Dyer conjecture.
+
+X<globalreduction>The library syntax is B<globalreduction>C<(E)>.
+
+=head2 X<ellheight>ellheightC<(E,z,{I<flag> = 0})>
+
+global X<NE<eacute>ron-Tate height>NE<eacute>ron-Tate height of
+the point C<z> on the elliptic curve C<E>. The vector C<E> must be a long vector
+of the type given by C<ellinit>, with C<I<flag> = 1>. If C<I<flag> = 0>, this
+computation is done using sigma and theta-functions and a trick due to J.
+Silverman. If C<I<flag> = 1>, use Tate's C<4^n> algorithm, which is much slower.
+C<E> is assumed to be integral, given by a minimal model.
+
+X<ellheight0>The library syntax is B<ellheight0>C<(E,z,I<flag>,I<prec>)>. The Archimedean
+contribution alone is given by the library function
+C<X<hell>B<hell>(E,z,I<prec>)>.
+Also available are C<X<ghell>B<ghell>(E,z,I<prec>)> (C<I<flag> = 0>) and
+C<X<ghell2>B<ghell2>(E,z,I<prec>)> (C<I<flag> = 1>).
+
+=head2 X<ellheightmatrix>ellheightmatrixC<(E,x)>
+
+C<x> being a vector of points, this
+function outputs the Gram matrix of C<x> with respect to the NE<eacute>ron-Tate
+height, in other words, the C<(i,j)> component of the matrix is equal to
+C<ellbil(E,x[i],x[j])>. The rank of this matrix, at least in some
+approximate sense, gives the rank of the set of points, and if C<x> is a
+basis of the X<Mordell-Weil group>Mordell-Weil group of C<E>, its determinant is equal to
+the regulator of C<E>. Note that this matrix should be divided by 2 to be in
+accordance with certain normalizations. C<E> is assumed to be integral,
+given by a minimal model.
+
+X<mathell>The library syntax is B<mathell>C<(E,x,I<prec>)>.
+
+=head2 X<ellinit>ellinitC<(E,{I<flag> = 0})>
+
+computes some fixed data concerning the
+elliptic curve given by the five-component vector C<E>, which will be
+essential for most further computations on the curve. The result is a
+19-component vector E (called a long vector in this section), shortened
+to 13 components (medium vector) if C<I<flag> = 1>. Both contain the
+following information in the first 13 components:
+
+S< >C< a_1,a_2,a_3,a_4,a_6,b_2,b_4,b_6,b_8,c_4,c_6,F<Delta>,j.>
+
+In particular, the discriminant is C<E[12]> (or C<E.disc>), and the
+C<j>-invariant is C<E[13]> (or C<E.j>).
+
+The other six components are only present if C<I<flag>> is C<0> (or omitted!).
+Their content depends on whether the curve is defined over B<I<R>> or not:
+
+C<B<*>> When C<E> is defined over B<I<R>>, C<E[14]> (C<E.roots>) is a
+vector whose three components contain the roots of the associated Weierstrass
+equation. If the roots are all real, then they are ordered by decreasing
+value. If only one is real, it is the first component of C<E[14]>.
+
+C<E[15]> (C<E.omega[1]>) is the real period of C<E> (integral of
+C<dx/(2y+a_1x+a_3)> over the connected component of the identity element of
+the real points of the curve), and C<E[16]> (C<E.omega[2]>) is a complex
+period. In other words, C<F<omega>_1 = E[15]> and C<F<omega>_2 = E[16]> form a basis of
+the complex lattice defining C<E> (C<E.omega>), with
+C<F<tau> = (F<omega>_2)/(F<omega>_1)> having positive imaginary part.
+
+C<E[17]> and C<E[18]> are the corresponding values C<F<eta>_1> and C<F<eta>_2> such
+that C<F<eta>_1F<omega>_2-F<eta>_2F<omega>_1 = iF<Pi>>, and both can be retrieved by
+typing C<E.eta> (as a row vector whose components are the C<F<eta>_i>).
+
+Finally, C<E[19]> (C<E.area>) is the volume of the complex lattice defining
+C<E>.
+
+C<B<*>> When C<E> is defined over C<B<I<Q>>_p>, the C<p>-adic valuation of C<j>
+must be negative. Then C<E[14]> (C<E.roots>) is the vector with a single
+component equal to the C<p>-adic root of the associated Weierstrass equation
+corresponding to C<-1> under the Tate parametrization.
+
+C<E[15]> is equal to the square of the C<u>-value, in the notation of Tate.
+
+C<E[16]> is the C<u>-value itself, if it belongs to C<B<I<Q>>_p>, otherwise zero.
+
+C<E[17]> is the value of Tate's C<q> for the curve C<E>.
+
+C<E.tate> will yield the three-component vector C<[u^2,u,q]>.
+
+C<E[18]> (C<E.w>) is the value of Mestre's C<w> (this is technical), and
+C<E[19]> is arbitrarily set equal to zero.
+
+For all other base fields or rings, the last six components are arbitrarily
+set equal to zero (see also the description of member functions related to
+elliptic curves at the beginning of this section).
+
+X<ellinit0>The library syntax is B<ellinit0>C<(E,I<flag>,I<prec>)>. Also available are
+C<X<initell>B<initell>(E,I<prec>)> (C<I<flag> = 0>) and
+C<X<smallinitell>B<smallinitell>(E,I<prec>)> (C<I<flag> = 1>).
+
+=head2 X<ellisoncurve>ellisoncurveC<(E,z)>
+
+gives 1 (i.e.S< >true) if the point C<z> is on
+the elliptic curve C<E>, 0 otherwise. If C<E> or C<z> have imprecise coefficients,
+an attempt is made to take this into account, i.e.S< >an imprecise equality is
+checked, not a precise one.
+
+X<oncurve>The library syntax is B<oncurve>C<(E,z)>, and the result is a C<long>.
+
+=head2 X<ellj>elljC<(x)>
+
+elliptic C<j>-invariant. C<x> must be a complex number
+with positive imaginary part, or convertible into a power series or a
+C<p>-adic number with positive valuation.
+
+X<jell>The library syntax is B<jell>C<(x,I<prec>)>.
+
+=head2 X<elllocalred>elllocalredC<(E,p)>
+
+calculates the X<Kodaira>Kodaira type of the
+local fiber of the elliptic curve C<E> at the prime C<p>.
+C<E> must be given by a medium or
+long vector of the type given by C<ellinit>, and is assumed to have all
+its coefficients C<a_i> in B<I<Z>>. The result is a 4-component vector
+C<[f,kod,v,c]>. Here C<f> is the exponent of C<p> in the arithmetic conductor of
+C<E>, and C<kod> is the Kodaira type which is coded as follows:
+
+1 means good reduction (type IC<_0>), 2, 3 and 4 mean types II, III and IV
+respectively, C<4+F<nu>> with C<F<nu> E<gt> 0> means type IC<_F<nu>>;
+finally the opposite values C<-1>, C<-2>, etc.S< >refer to the starred types
+IC<_0^*>, IIC<^*>, etc. The third component C<v> is itself a vector C<[u,r,s,t]>
+giving the coordinate changes done during the local reduction. Normally, this
+has no use if C<u> is 1, that is, if the given equation was already minimal.
+Finally, the last component C<c> is the local X<Tamagawa number>Tamagawa number C<c_p>.
+
+X<localreduction>The library syntax is B<localreduction>C<(E,p)>.
+
+=head2 X<elllseries>elllseriesC<(E,s,{A = 1})>
+
+C<E> being a medium or long vector
+given by C<ellinit>, this computes the value of the L-series of C<E> at
+C<s>. It is assumed that C<E> is a minimal model over B<I<Z>> and that the curve
+is a modular elliptic curve. The optional parameter C<A> is a cutoff point for
+the integral, which must be chosen close to 1 for best speed. The result
+must be independent of C<A>, so this allows some internal checking of the
+function.
+
+Note that if the conductor of the curve is large, say greater than C<10^{12}>,
+this function will take an unreasonable amount of time since it uses an
+C<O(N^{1/2})> algorithm.
+
+X<lseriesell>The library syntax is B<lseriesell>C<(E,s,A,I<prec>)> where C<I<prec>> is a C<long> and an
+omitted C<A> is coded as C<NULL>.
+
+=head2 X<ellorder>ellorderC<(E,z)>
+
+gives the order of the point C<z> on the elliptic
+curve C<E> if it is a torsion point, zero otherwise. In the present version
+B<2.2.0>, this is implemented only for elliptic curves defined over B<I<Q>>.
+
+X<orderell>The library syntax is B<orderell>C<(E,z)>.
+
+=head2 X<ellordinate>ellordinateC<(E,x)>
+
+gives a 0, 1 or 2-component vector containing
+the C<y>-coordinates of the points of the curve C<E> having C<x> as
+C<x>-coordinate.
+
+X<ordell>The library syntax is B<ordell>C<(E,x)>.
+
+=head2 X<ellpointtoz>ellpointtozC<(E,z)>
+
+if C<E> is an elliptic curve with coefficients
+in B<I<R>>, this computes a complex number C<t> (modulo the lattice defining
+C<E>) corresponding to the point C<z>, i.e.S< >such that, in the standard
+Weierstrass model, C< F<wp> (t) = z[1], F<wp> '(t) = z[2]>. In other words, this is the
+inverse function of C<ellztopoint>.
+
+If C<E> has coefficients in C<B<I<Q>>_p>, then either Tate's C<u> is in C<B<I<Q>>_p>, in
+which case the output is a C<p>-adic number C<t> corresponding to the point C<z>
+under the Tate parametrization, or only its square is, in which case the
+output is C<t+1/t>. C<E> must be a long vector output by C<ellinit>.
+
+X<zell>The library syntax is B<zell>C<(E,z,I<prec>)>.
+
+=head2 X<ellpow>ellpowC<(E,z,n)>
+
+computes C<n> times the point C<z> for the
+group law on the elliptic curve C<E>. Here, C<n> can be in B<I<Z>>, or C<n>
+can be a complex quadratic integer if the curve C<E> has complex multiplication
+by C<n> (if not, an error message is issued).
+
+X<powell>The library syntax is B<powell>C<(E,z,n)>.
+
+=head2 X<ellrootno>ellrootnoC<(E,{p = 1})>
+
+C<E> being a medium or long vector given
+by C<ellinit>, this computes the local (if C<p ! = 1>) or global (if C<p = 1>)
+root number of the L-series of the elliptic curve C<E>. Note that the global
+root number is the sign of the functional equation and conjecturally is the
+parity of the rank of the X<Mordell-Weil group>Mordell-Weil group.
+The equation for C<E> must have
+coefficients in B<I<Q>> but need I<not> be minimal.
+
+X<ellrootno>The library syntax is B<ellrootno>C<(E,p)> and the result (equal to C<F<+->1>) is a C<long>.
+
+=head2 X<ellsigma>ellsigmaC<(E,z,{I<flag> = 0})>
+
+value of the Weierstrass C<F<sigma>>
+function of the lattice associated to C<E> as given by C<ellinit>
+(alternatively, C<E> can be given as a lattice C<[F<omega>_1,F<omega>_2]>).
+
+If C<I<flag> = 1>, computes an (arbitrary) determination of C< F<log> (F<sigma>(z))>.
+
+If C<I<flag> = 2,3>, same using the product expansion instead of theta series.
+X<ellsigma>The library syntax is B<ellsigma>C<(E,z,I<flag>)>
+
+=head2 X<ellsub>ellsubC<(E,z1,z2)>
+
+difference of the points C<z1> and C<z2> on the
+elliptic curve corresponding to the vector C<E>.
+
+X<subell>The library syntax is B<subell>C<(E,z1,z2)>.
+
+=head2 X<elltaniyama>elltaniyamaC<(E)>
+
+computes the modular parametrization of the
+elliptic curve C<E>, where C<E> is given in the (long or medium) format output
+by C<ellinit>, in the form of a two-component vector C<[u,v]> of power
+series, given to the current default series precision. This vector is
+characterized by the following two properties. First the point C<(x,y) = (u,v)>
+satisfies the equation of the elliptic curve. Second, the differential
+C<du/(2v+a_1u+a_3)> is equal to C<f(z)dz>, a differential form on
+C<H/F<Gamma>_0(N)> where C<N> is the conductor of the curve. The variable used in
+the power series for C<u> and C<v> is C<x>, which is implicitly understood to be
+equal to C< F<exp> (2iF<Pi> z)>. It is assumed that the curve is a I<strong>
+X<Weil curve>Weil curve, and the Manin constant is equal to 1. The equation of
+the curve C<E> must be minimal (use C<ellglobalred> to get a minimal
+equation).
+
+X<taniyama>The library syntax is B<taniyama>C<(E)>, and the precision of the result is determined by the
+global variable C<precdl>.
+
+=head2 X<elltors>elltorsC<(E,{I<flag> = 0})>
+
+if C<E> is an elliptic curve I<defined
+over B<I<Q>>>, outputs the torsion subgroup of C<E> as a 3-component vector
+C<[t,v1,v2]>, where C<t> is the order of the torsion group, C<v1>
+gives the structure of the torsion group as a product of cyclic groups
+(sorted by decreasing order), and C<v2> gives generators for these cyclic
+groups. C<E> must be a long vector as output by C<ellinit>.
+
+ ? E = ellinit([0,0,0,-1,0]);
+ ? elltors(E)
+ %1 = [4, [2, 2], [[0, 0], [1, 0]]]
+
+Here, the torsion subgroup is isomorphic to C<B<I<Z>>/2B<I<Z>> x B<I<Z>>/2B<I<Z>>>, with
+generators C<[0,0]> and C<[1,0]>.
+
+If C<I<flag> = 0>, use Doud's algorithmS< >: bound torsion by computing C<#E(B<I<F>>_p)>
+for small primes of good reduction, then look for torsion points using
+Weierstrass parametrization (and Mazur's classification).
+
+If C<I<flag> = 1>, use Lutz--Nagell (I<much> slower), C<E> is allowed to be a
+medium vector.
+
+X<elltors0>The library syntax is B<elltors0>C<(E,flag)>.
+
+=head2 X<ellwp>ellwpC<(E,{z = x},{I<flag> = 0})>
+
+Computes the value at C<z> of the Weierstrass C< F<wp> > function attached to the
+elliptic curve C<E> as given by C<ellinit> (alternatively, C<E> can be
+given as a lattice C<[F<omega>_1,F<omega>_2]>).
+
+If C<z> is omitted or is a simple variable, computes the I<power series>
+expansion in C<z> (starting C<z^{-2}+O(z^2)>). The number of terms to an
+I<even> power in the expansion is the default serieslength in GP, and the
+second argument (C long integer) in library mode.
+
+Optional I<flag> is (for now) only taken into account when C<z> is numeric, and
+means 0: compute only C< F<wp> (z)>, 1: compute C<[ F<wp> (z), F<wp> '(z)]>.
+
+X<ellwp0>The library syntax is B<ellwp0>C<(E,z,I<flag>,I<prec>,I<precdl>)>. Also available is
+X<weipell>B<weipell>C<(E,I<precdl>)> for the power series (in
+C<x = polx[0]>).
+
+=head2 X<ellzeta>ellzetaC<(E,z)>
+
+value of the Weierstrass C<F<zeta>> function of the
+lattice associated to C<E> as given by C<ellinit> (alternatively, C<E> can
+be given as a lattice C<[F<omega>_1,F<omega>_2]>).
+
+X<ellzeta>The library syntax is B<ellzeta>C<(E,z)>.
+
+=head2 X<ellztopoint>ellztopointC<(E,z)>
+
+C<E> being a long vector, computes the
+coordinates C<[x,y]> on the curve C<E> corresponding to the complex number C<z>.
+Hence this is the inverse function of C<ellpointtoz>. In other words, if
+the curve is put in Weierstrass form, C<[x,y]> represents the
+X<Weierstrass F<wp> -function>Weierstrass C< F<wp> >-function and its derivative.
+If C<z> is in the lattice defining C<E> over
+B<I<C>>, the result is the point at infinity C<[0]>.
+
+X<pointell>The library syntax is B<pointell>C<(E,z,I<prec>)>.
+
+=head1 Functions related to general number fields
+
+In this section can be found functions which are used almost exclusively for
+working in general number fields. Other less specific functions can be found
+in the next section on polynomials. Functions related to quadratic number
+fields can be found in the section L<Label se:arithmetic> (Arithmetic
+functions).
+
+We shall use the following conventions:
+
+C<B<*>> C<X<nf>I<nf>> denotes a number field, i.e.S< >a 9-component vector
+in the format output by X<nfinit>C<nfinit>. This contains the basic arithmetic data
+associated to the number field: signature, maximal order, discriminant, etc.
+
+C<B<*>> C<X<bnf>I<bnf>> denotes a big number field, i.e.S< >a 10-component
+vector in the format output by X<bnfinit>C<bnfinit>. This contains C<I<nf>> and
+the deeper invariants of the field: units, class groups, as well as a lot of
+technical data necessary for some complex fonctions like C<bnfisprincipal>.
+
+C<B<*>> C<X<bnr>I<bnr>> denotes a big ``ray number field'', i.e.S< >some data
+structure output by C<bnrinit>, even more complicated than C<I<bnf>>,
+corresponding to the ray class group structure of the field, for some
+modulus.
+
+C<B<*>> C<X<rnf>I<rnf>> denotes a relative number field (see below).
+
+C<B<*>> C<X<ideal>I<ideal>> can mean any of the following:
+
+S< >S< >-- a B<I<Z>>-basis, in X<Hermite normal form>Hermite normal form
+(HNF) or not. In this case C<x> is a square matrix.
+
+S< >S< >-- an X<idele>I<idele>, i.e.S< >a 2-component vector, the first being an
+ideal given as a B<I<Z>>--basis, the second being a C<r_1+r_2>-component row
+vector giving the complex logarithmic Archimedean information.
+
+S< >S< >-- a C<B<I<Z>>_K>-generating system for an ideal.
+
+S< >S< >-- a I<column> vector C<x> expressing an element of the number field
+on the integral basis, in which case the ideal is treated as being the
+principal idele (or ideal) generated by C<x>.
+
+S< >S< >-- a prime ideal, i.e.S< >a 5-component vector in the format output by
+C<idealprimedec>.
+
+S< >S< >-- a polmod C<x>, i.e.S< >an algebraic integer, in which case the ideal
+is treated as being the principal idele generated by C<x>.
+
+S< >S< >-- an integer or a rational number, also treated as a principal idele.
+
+C<B<*>> a I<{character>} on the Abelian group
+C<\bigoplus (B<I<Z>>/N_iB<I<Z>>) g_i>
+is given by a row vector C<F<chi> = [a_1,...,a_n]> such that
+C<F<chi>(F<prod> g_i^{n_i}) = exp(2iF<Pi>F<sum> a_i n_i / N_i)>.
+
+B<Warnings:>
+
+1) An element in C<I<nf>> can be expressed either as a polmod or as a
+vector of components on the integral basis C<I<nf>.zk>. It is absolutely
+essential that all such vectors be I<column> vectors.
+
+2) When giving an ideal by a C<B<I<Z>>_K> generating system to a function expecting
+an ideal, it must be ensured that the function understands that it is a
+C<B<I<Z>>_K>-generating system and not a B<I<Z>>-generating system. When the number of
+generators is strictly less than the degree of the field, there is no
+ambiguity and the program assumes that one is giving a C<B<I<Z>>_K>-generating set.
+When the number of generators is greater than or equal to the degree of the
+field, however, the program assumes on the contrary that you are giving a
+B<I<Z>>-generating set. If this is not the case, you I<must> absolutely
+change it into a B<I<Z>>-generating set, the simplest manner being to use
+C<idealhnf(I<nf>,x)>.
+
+Concerning relative extensions, some additional definitions are necessary.
+
+C<B<*>> A I<{relative matrix>} will be a matrix whose entries are
+elements of a (given) number field C<I<nf>>, always expressed as column
+vectors on the integral basis C<I<nf>.zk>. Hence it is a matrix of
+vectors.
+
+C<B<*>> An X<ideal list>I<ideal list> will be a row vector of (fractional)
+ideals of the number field C<I<nf>>.
+
+C<B<*>> A X<pseudo-matrix>I<pseudo-matrix> will be a pair C<(A,I)> where C<A> is a
+relative matrix and C<I> an ideal list whose length is the same as the number
+of columns of C<A>. This pair will be represented by a 2-component row vector.
+
+C<B<*>> The X<module>I<module> generated by a pseudo-matrix C<(A,I)> is
+the sum C<F<sum>_i{B<I<a>>}_jA_j> where the C<{B<I<a>>}_j> are the ideals of C<I>
+and C<A_j> is the C<j>-th column of C<A>.
+
+C<B<*>> A pseudo-matrix C<(A,I)> is a X<pseudo-basis>I<pseudo-basis> of the module
+it generates if C<A> is a square matrix with non-zero determinant and all the
+ideals of C<I> are non-zero. We say that it is in Hermite Normal
+FormX<Hermite normal form> (HNF) if it is upper triangular and all the
+elements of the diagonal are equal to 1.
+
+C<B<*>> The I<determinant> of a pseudo-basis C<(A,I)> is the ideal
+equal to the product of the determinant of C<A> by all the ideals of C<I>. The
+determinant of a pseudo-matrix is the determinant of any pseudo-basis of the
+module it generates.
+
+Finally, when defining a relative extension, the base field should be
+defined by a variable having a lower priority (i.e.S< >a higher number)
+than the variable defining the extension. For example, under GP you can
+use the variable name C<y> (or C<t>) to define the base field, and the
+variable name C<x> to define the relative extension.
+
+Now a last set of definitions concerning the way big ray number fields
+(or I<bnr>) are input, using class field theory.
+These are defined by a triple
+C<a1>, C<a2>, C<a3>, where the defining set C<[a1,a2,a3]> can have any of the
+following forms: C<[I<bnr>]>, C<[I<bnr>,I<subgroup>]>,
+C<[I<bnf>,I<module>]>, C<[I<bnf>,I<module>,I<subgroup>]>, where:
+
+C<B<*>> C<I<bnf>> is as output by C<bnfclassunit> or C<bnfinit>,
+where units are mandatory unless the ideal is trivial; I<bnr> by
+C<bnrclass> (with C<I<flag> E<gt> 0>) or C<bnrinit>. This is the ground field.
+
+C<B<*>> I<module> is either an ideal in any form (see above) or a
+two-component row vector containing an ideal and an C<r_1>-component row
+vector of flags indicating which real Archimedean embeddings to take in the
+module.
+
+C<B<*>> I<subgroup> is the HNF matrix of a subgroup of the ray class group
+of the ground field for the modulus I<module>. This is input as a square
+matrix expressing generators of a subgroup of the ray class group
+C<I<bnr>.clgp> on the given generators.
+
+The corresponding I<bnr> is then the subfield of the ray class field of the
+ground field for the given modulus, associated to the given subgroup.
+
+All the functions which are specific to relative extensions, number fields,
+big number fields, big number rays, share the prefix C<rnf>, C<nf>,
+C<bnf>, C<bnr> respectively. They are meant to take as first argument a
+number field of that precise type, respectively output by C<rnfinit>,
+C<nfinit>, C<bnfinit>, and C<bnrinit>.
+
+However, and even though it may not be specified in the descriptions of the
+functions below, it is permissible, if the function expects a C<I<nf>>, to
+use a C<I<bnf>> instead (which contains much more information). The program
+will make the effort of converting to what it needs. On the other hand, if
+the program requires a big number field, the program will I<not> launch
+C<bnfinit> for you, which can be a costly operation. Instead, it will give
+you a specific error message.
+
+The data types corresponding to the structures described above are rather
+complicated. Thus, as we already have seen it with elliptic curves, GP
+provides you with some ``member functions'' to retrieve the data you need
+from these structures (once they have been initialized of course). The
+relevant types of number fields are indicated between parentheses:
+
+X<member functions>
+S< >X<bnf>C<bnf> (I<bnr>, I<bnf> ) : big number field.
+
+S< >X<clgp>C<clgp> (I<bnr>, I<bnf> ) : classgroup. This one admits the
+following three subclasses:
+
+S< > X<cyc>C<cyc> : cyclic decomposition
+(SNF)X<Smith normal form>.
+
+S< > C<gen>X<gen (member function)> :
+generators.
+
+S< > X<no>C<no> : number of elements.
+
+S< >X<diff>C<diff> (I<bnr>, I<bnf>, I<nf> ) : the different ideal.
+
+S< >X<codiff>C<codiff> (I<bnr>, I<bnf>, I<nf> ) : the codifferent
+(inverse of the different in the ideal group).
+
+S< >X<disc>C<disc> (I<bnr>, I<bnf>, I<nf> ) : discriminant.
+
+S< >X<fu>C<fu> (I<bnr>, I<bnf>, I<nf> ) :
+X<fundamental units>fundamental units.
+
+S< >X<futu>C<futu> (I<bnr>, I<bnf> ) : C<[u,w]>, C<u> is a vector of
+fundamental units, C<w> generates the torsion.
+
+S< >X<nf>C<nf> (I<bnr>, I<bnf>, I<nf> ) : number field.
+
+S< >X<reg>C<reg> (I<bnr>, I<bnf>, ) : regulator.
+
+S< >X<roots>C<roots> (I<bnr>, I<bnf>, I<nf> ) : roots of the
+polnomial generating the field.
+
+S< >X<sign>C<sign> (I<bnr>, I<bnf>, I<nf> ) : C<[r_1,r_2]> the
+signature of the field. This means that the field has C<r_1> real
+S< > embeddings, C<2r_2> complex ones.
+
+S< >X<t2>C<t2> (I<bnr>, I<bnf>, I<nf> ) : the T2 matrix (see
+C<nfinit>).
+
+S< >X<tu>C<tu> (I<bnr>, I<bnf>, ) : a generator for the torsion
+units.
+
+S< >X<tufu>C<tufu> (I<bnr>, I<bnf>, ) : as C<futu>, but outputs
+C<[w,u]>.
+
+S< >X<zk>C<zk> (I<bnr>, I<bnf>, I<nf> ) : integral basis, i.e.S< >a
+B<I<Z>>-basis of the maximal order.
+
+S< >X<zkst>C<zkst> (I<bnr> ) : structure of C<(B<I<Z>>_K/m)^*> (can be
+extracted also from an I<idealstar>).
+
+For instance, assume that C<I<bnf> = bnfinit(I<pol>)>, for some
+polynomial. Then C<I<bnf>.clgp> retrieves the class group, and
+C<I<bnf>.clgp.no> the class number. If we had set C<I<bnf> =
+nfinit(I<pol>)>, both would have output an error message. All these
+functions are completely recursive, thus for instance
+C<I<bnr>.bnf.nf.zk> will yield the maximal order of I<bnr> (which
+you could get directly with a simple C<I<bnr>.zk> of course).
+
+The following functions, starting with C<buch> in library mode, and with
+C<bnf> under GP, are implementations of the sub-exponential algorithms for
+finding class and unit groups under X<GRH>GRH, due to Hafner-McCurley,
+X<Buchmann>Buchmann and Cohen-Diaz-Olivier.
+
+The general call to the functions concerning class groups of general number
+fields (i.e.S< >excluding C<quadclassunit>) involves a polynomial C<P> and a
+technical vector
+
+S< >C<I<tech> = [c,c2,I<nrel>,I<borne>,I<nrpid>,I<minsfb>],>
+
+where the parameters are to be understood as follows:
+
+C<P> is the defining polynomial for the number field, which must be in
+C<B<I<Z>>[X]>, irreducible and, preferably, monic. In fact, if you supply a
+non-monic polynomial at this point, GP will issue a warning, then
+I<transform your polynomial> so that it becomes monic. Instead of the
+normal result, say C<res>, you then get a vector C<[res,Mod(a,Q)]>,
+where C<Mod(a,Q) = Mod(X,P)> gives the change of variables.
+
+The numbers C<c> and C<c2> are positive real numbers which control the
+execution time and the stack size. To get maximum speed, set C<c2 = c>. To get a
+rigorous result (under X<GRH>GRH) you must take C<c2 = 12> (or C<c2 = 6> in the
+quadratic case, but then you should use the much faster function
+C<quadclassunit>). Reasonable values for C<c> are between C<0.1> and
+C<2>. (The defaults are C<c = c2 = 0.3>).
+
+C<I<nrel>> is the number of initial extra relations requested in
+computing the
+relation matrix. Reasonable values are between 5 and 20. (The default is 5).
+
+C<I<borne>> is a multiplicative coefficient of the Minkowski bound which
+controls
+the search for small norm relations. If this parameter is set equal to 0, the
+program does not search for small norm relations. Otherwise reasonable values
+are between C<0.5> and C<2.0>. (The default is C<1.0>).
+
+C<I<nrpid>> is the maximal number of small norm relations associated to each
+ideal in the factor base. Irrelevant when C<I<borne> = 0>. Otherwise,
+reasonable values are between 4 and 20. (The default is 4).
+
+C<I<minsfb>> is the minimal number of elements in the ``sub-factorbase''.
+If the
+program does not seem to succeed in finding a full rank matrix (which you can
+see in GP by typing C<\g 2>), increase this number. Reasonable values
+are between 2 and 5. (The default is 3).
+
+B<Remarks.>
+
+Apart from the polynomial C<P>, you don't need to supply any of the technical
+parameters (under the library you still need to send at least an empty
+vector, C<cgetg(1,t_VEC)>). However, should you choose to set some of
+them, they I<must> be given in the requested order. For example, if you
+want to specify a given value of C<nrel>, you must give some values as well
+for C<c> and C<c2>, and provide a vector C<[c,c2,nrel]>.
+
+Note also that you can use an C<I<nf>> instead of C<P>, which avoids
+recomputing the integral basis and analogous quantities.
+
+=head2 X<bnfcertify>bnfcertifyC<(I<bnf>)>
+
+C<I<bnf>> being a big number field
+as output by C<bnfinit> or C<bnfclassunit>, checks whether the result
+is correct, i.e.S< >whether it is possible to remove the assumption of the
+Generalized Riemann HypothesisX<GRH>. If it is correct, the answer is 1.
+If not, the program may output some error message, but more probably will loop
+indefinitely. In I<no> occasion can the program give a wrong answer
+(barring bugs of course): if the program answers 1, the answer is certified.
+
+X<certifybuchall>The library syntax is B<certifybuchall>C<(I<bnf>)>, and the result is a C long.
+
+=head2 X<bnfclassunit>bnfclassunitC<(P,{I<flag> = 0},{I<tech> = []})>
+
+X<Buchmann>Buchmann's
+sub-exponential algorithm for computing the class group, the regulator and a
+system of X<fundamental units>fundamental units of the general algebraic number field C<K>
+defined by the irreducible polynomial C<P> with integer coefficients.
+
+The result of this function is a vector C<v> with 10 components (it is
+I<not> a C<I<bnf>>, you need C<bnfinit> for that), which for ease of
+presentation is in fact output as a one column matrix. First we describe the
+default behaviour (C<I<flag> = 0>):
+
+C<v[1]> is equal to the polynomial C<P>. Note that for optimum performance,
+C<P> should have gone through C<polred> or C<nfinit(x,2)>.
+
+C<v[2]> is the 2-component vector C<[r1,r2]>, where C<r1> and C<r2> are as usual
+the number of real and half the number of complex embeddings of the number
+field C<K>.
+
+C<v[3]> is the 2-component vector containing the field discriminant and the
+index.
+
+C<v[4]> is an integral basis in Hermite normal form.
+
+C<v[5]> (C<v.clgp>) is a 3-component vector containing the class number
+(C<v.clgp.no>), the structure of the class group as a product of cyclic
+groups of order C<n_i> (C<v.clgp.cyc>), and the corresponding generators
+of the class group of respective orders C<n_i> (C<v.clgp.gen>).
+
+C<v[6]> (C<v.reg>) is the regulator computed to an accuracy which is the
+maximum of an internally determined accuracy and of the default.
+
+C<v[7]> is a measure of the correctness of the result. If it is close to 1,
+the results are correct (under X<GRH>GRH). If it is close to a larger integer,
+this shows that the product of the class number by the regulator is off by a
+factor equal to this integer, and you must start again with a larger value
+for C<c> or a different random seed, i.e.S< >use the function C<setrand>.
+(Since the computation involves a random process, starting again with exactly
+the same parameters may give the correct result.) In this case a warning
+message is printed.
+
+C<v[8]> (C<v.tu>) a vector with 2 components, the first being the number
+C<w> of roots of unity in C<K> and the second a primitive C<w>-th root of unity
+expressed as a polynomial.
+
+C<v[9]> (C<v.fu>) is a system of fundamental units also expressed as
+polynomials.
+
+C<v[10]> gives a measure of the correctness of the computations of the
+fundamental units (not of the regulator), expressed as a number of bits. If
+this number is greater than C<20>, say, everything is OK. If C<v[10] E<lt>= 0>,
+then we have lost all accuracy in computing the units (usually an error
+message will be printed and the units not given). In the intermediate cases,
+one must proceed with caution (for example by increasing the current
+precision).
+
+If C<I<flag> = 1>, and the precision happens to be insufficient for obtaining the
+fundamental units exactly, the internal precision is doubled and the
+computation redone, until the exact results are obtained. The user should be
+warned that this can take a very long time when the coefficients of the
+fundamental units on the integral basis are very large, for example in the
+case of large real quadratic fields. In that case, there are alternate
+methods for representing algebraic numbers which are not implemented in PARI.
+
+If C<I<flag> = 2>, the fundamental units and roots of unity are not computed.
+Hence the result has only 7 components, the first seven ones.
+
+C<I<tech>> is a technical vector (empty by default) containing C<c>, C<c2>,
+I<nrel>, I<borne>, I<nbpid>, I<minsfb>, in this order (see
+the beginning of the section or the keyword C<bnf>).
+You can supply any number of these I<provided you give an actual value to
+each of them> (the ``empty arg'' trick won't work here). Careful use of these
+parameters may speed up your computations considerably.
+
+X<bnfclassunit0>The library syntax is B<bnfclassunit0>C<(P,I<flag>,I<tech>,I<prec>)>.
+
+=head2 X<bnfclgp>bnfclgpC<(P,{I<tech> = []})>
+
+as C<bnfclassunit>, but only
+outputs C<v[5]>, i.e.S< >the class group.
+
+X<bnfclassgrouponly>The library syntax is B<bnfclassgrouponly>C<(P,I<tech>,I<prec>)>, where I<tech>
+is as described under C<bnfclassunit>.
+
+=head2 X<bnfdecodemodule>bnfdecodemoduleC<(I<nf>,m)>
+
+if C<m> is a module as output in the
+first component of an extension given by C<bnrdisclist>, outputs the
+true module.
+
+X<decodemodule>The library syntax is B<decodemodule>C<(I<nf>,m)>.
+
+=head2 X<bnfinit>bnfinitC<(P,{I<flag> = 0},{I<tech> = []})>
+
+essentially identical
+to C<bnfclassunit> except that the output contains a lot of technical data,
+and should not be printed out explicitly in general. The result of
+C<bnfinit> is used in programs such as C<bnfisprincipal>,
+C<bnfisunit> or C<bnfnarrow>. The result is a 10-component vector
+C<I<bnf>>.
+
+C<B<*>> The first 6 and last 2 components are technical and in
+principle are not used by the casual user. However, for the sake of
+completeness, their description is as follows. We use the notations explained
+in the book by H. Cohen, I<A Course in Computational Algebraic Number
+Theory>, Graduate Texts in Maths B<138>, Springer-Verlag, 1993, Section
+6.5, and subsection 6.5.5 in particular.
+
+C<I<bnf>[1]> contains the matrix C<W>, i.e.S< >the matrix in Hermite normal
+form giving relations for the class group on prime ideal generators
+C<(B<I<p>>_i)_{1 E<lt>= i E<lt>= r}>.
+
+C<I<bnf>[2]> contains the matrix C<B>, i.e.S< >the matrix containing the
+expressions of the prime ideal factorbase in terms of the C<B<I<p>>_i>. It is an
+C<r x c> matrix.
+
+C<I<bnf>[3]> contains the complex logarithmic embeddings of the system of
+fundamental units which has been found. It is an C<(r_1+r_2) x (r_1+r_2-1)>
+matrix.
+
+C<I<bnf>[4]> contains the matrix C<M''_C> of Archimedean components of the
+relations of the matrix C<(W|B)>.
+
+C<I<bnf>[5]> contains the prime factor base, i.e.S< >the list of prime
+ideals used in finding the relations.
+
+C<I<bnf>[6]> contains the permutation of the prime factor base which was
+necessary to reduce the relation matrix to the form explained in subsection
+6.5.5 of GTMS< >138 (i.e.S< >with a big C<c x c> identity matrix on the lower
+right). Note that in the above mentioned book, the need to permute the rows
+of the relation matrices which occur was not emphasized.
+
+C<I<bnf>[9]> is a 3-element row vector used in X<bnfisprincipal>C<bnfisprincipal> only
+and obtained as follows. Let C<D = U W V> obtained by applying the
+X<Smith normal form>Smith normal form algorithm to the matrix C<W> ( = C<I<bnf>[1]>) and
+let C<U_r> be the reduction of C<U> modulo C<D>. The first elements of the
+factorbase are given (in terms of C<bnf.gen>) by the columns of C<U_r>,
+with archimedian component C<g_a>; let also C<GD_a> be the archimedian
+components of the generators of the (principal) ideals defined by the
+C<bnf.gen[i]^bnf.cyc[i]>. Then C<I<bnf>[9] = [U_r, g_a, GD_a]>.
+
+Finally, C<I<bnf>[10]> is by default unused and set equal to 0. This
+field is used to store further information about the field as it becomes
+available (which is rarely needed, hence would be too expensive to compute
+during the initial C<bnfinit> call). For instance, the generators of the
+principal ideals C<bnf.gen[i]^bnf.cyc[i]> (during a call to
+X<bnrisprincipal>C<bnrisprincipal>), or those corresponding to the relations in C<W> and
+C<B> (when the C<bnf> internal precision needs to be increased).
+
+C<B<*>> The less technical components are as follows:
+
+C<I<bnf>[7]> or C<I<bnf>.nf> is equal to the number field data
+C<I<nf>> as would be given by C<nfinit>.
+
+C<I<bnf>[8]> is a vector containing the last 6 components of
+C<bnfclassunit[,1]>, i.e.S< >the classgroup C<I<bnf>.clgp>, the
+regulator C<I<bnf>.reg>, the general ``check'' number which should be
+close to 1, the number of roots of unity and a generator C<I<bnf>.tu>,
+the fundamental units C<I<bnf>.fu>, and finally the check on their
+computation. If the precision becomes insufficient, GP outputs a warning
+(C<fundamental units too large, not given>) and does not strive to
+compute the units by default (C<I<flag> = 0>).
+
+When C<I<flag> = 1>, GP insists on finding the fundamental units exactly, the
+internal precision being doubled and the computation redone, until the exact
+results are obtained. The user should be warned that this can take a very
+long time when the coefficients of the fundamental units on the integral
+basis are very large.
+
+When C<I<flag> = 2>, on the contrary, it is initially agreed that GP
+will not compute units.
+
+When C<I<flag> = 3>, computes a very small version of C<bnfinit>, a ``small big
+number field'' (or I<sbnf> for short) which contains enough information
+to recover the full C<I<bnf>> vector very rapidly, but which is much
+smaller and hence easy to store and print. It is supposed to be used in
+conjunction with C<bnfmake>. The output is a 12 component vector C<v>, as
+follows. Let C<I<bnf>> be the result of a full C<bnfinit>, complete with
+units. Then C<v[1]> is the polynomial C<P>, C<v[2]> is the number of real
+embeddings C<r_1>, C<v[3]> is the field discriminant, C<v[4]> is the integral
+basis, C<v[5]> is the list of roots as in the sixth component of C<nfinit>,
+C<v[6]> is the matrix C<MD> of C<nfinit> giving a B<I<Z>>-basis of the
+different, C<v[7]> is the matrix C<W = I<bnf>[1]>, C<v[8]> is the
+matrix C<matalpha = I<bnf>[2]>, C<v[9]> is the prime ideal factor base
+C<I<bnf>[5]> coded in a compact way, and ordered according to the
+permutation C<I<bnf>[6]>, C<v[10]> is the 2-component vector giving the
+number of roots of unity and a generator, expressed on the integral basis,
+C<v[11]> is the list of fundamental units, expressed on the integral basis,
+C<v[12]> is a vector containing the algebraic numbers alpha corresponding to
+the columns of the matrix C<matalpha>, expressed on the integral basis.
+
+Note that all the components are exact (integral or rational), except for
+the roots in C<v[5]>. In practice, this is the only component which a user
+is allowed to modify, by recomputing the roots to a higher accuracy if
+desired. Note also that the member functions will I<not> work on
+I<sbnf>, you have to use C<bnfmake> explicitly first.
+
+X<bnfinit0>The library syntax is B<bnfinit0>C<(P,I<flag>,I<tech>,I<prec>)>.
+
+=head2 X<bnfisintnorm>bnfisintnormC<(I<bnf>,x)>
+
+computes a complete system of
+solutions (modulo units of positive norm) of the absolute norm equation
+C<Norm(a) = x>,
+where C<a> is an integer in C<I<bnf>>. If C<I<bnf>> has not been certified,
+the correctness of the result depends on the validity of X<GRH>GRH.
+
+X<bnfisintnorm>The library syntax is B<bnfisintnorm>C<(I<bnf>,x)>.
+
+=head2 X<bnfisnorm>bnfisnormC<(I<bnf>,x,{I<flag> = 1})>
+
+tries to tell whether the
+rational number C<x> is the norm of some element y in C<I<bnf>>. Returns a
+vector C<[a,b]> where C<x = Norm(a)*b>. Looks for a solution which is an C<S>-unit,
+with C<S> a certain set of prime ideals containing (among others) all primes
+dividing C<x>. If C<I<bnf>> is known to be X<Galois>Galois, set C<I<flag> = 0> (in
+this case,
+C<x> is a norm iff C<b = 1>). If C<I<flag>> is non zero the program adds to C<S> the
+following prime ideals, depending on the sign of C<I<flag>>. If C<I<flag> E<gt> 0>, the
+ideals of norm less than C<I<flag>>. And if C<I<flag> E<lt> 0> the ideals dividing C<I<flag>>.
+
+If you are willing to assume X<GRH>GRH, the answer is guaranteed
+(i.e.S< >C<x> is a norm iff C<b = 1>), if C<S> contains all primes less than
+C<12 F<log> (I<disc>(I<Bnf>))^2>,
+where C<I<Bnf>> is the Galois closure of C<I<bnf>>.
+
+X<bnfisnorm>The library syntax is B<bnfisnorm>C<(I<bnf>,x,I<flag>,I<prec>)>, where C<I<flag>> and
+C<I<prec>> are C<long>s.
+
+=head2 X<bnfissunit>bnfissunitC<(I<bnf>,I<sfu>,x)>
+
+C<I<bnf>> being output by
+C<bnfinit>, I<sfu> by C<bnfsunit>, gives the column vector of
+exponents of C<x> on the fundamental C<S>-units and the roots of unity.
+If C<x> is not a unit, outputs an empty vector.
+
+X<bnfissunit>The library syntax is B<bnfissunit>C<(I<bnf>,I<sfu>,x)>.
+
+=head2 X<bnfisprincipal>bnfisprincipalC<(I<bnf>,x,{I<flag> = 1})>
+
+C<I<bnf>> being the
+number field data output by C<bnfinit>, and C<x> being either a B<I<Z>>-basis
+of an ideal in the number field (not necessarily in HNF) or a prime ideal in
+the format output by the function C<idealprimedec>, this function tests
+whether the ideal is principal or not. The result is more complete than a
+simple true/false answer: it gives a row vector C<[v_1,v_2,check]>, where
+
+C<v_1> is the vector of components C<c_i> of the class of the ideal C<x> in the
+class group, expressed on the generators C<g_i> given by C<bnfinit>
+(specifically C<I<bnf>.clgp.gen> which is the same as
+C<I<bnf>[8][1][3]>). The C<c_i> are chosen so that C<0 E<lt>= c_i E<lt> n_i>
+where C<n_i> is the order of C<g_i> (the vector of C<n_i> being
+C<I<bnf>.clgp.cyc>, that is C<I<bnf>[8][1][2]>).
+
+C<v_2> gives on the integral basis the components of C<F<alpha>> such that
+C<x = F<alpha>F<prod>_ig_i^{c_i}>. In particular, C<x> is principal if and only if
+C<v_1> is equal to the zero vector, and if this the case C<x = F<alpha>B<I<Z>>_K> where
+C<F<alpha>> is given by C<v_2>. Note that if C<F<alpha>> is too large to be given, a
+warning message will be printed and C<v_2> will be set equal to the empty
+vector.
+
+Finally the third component I<check> is analogous to the last component of
+C<bnfclassunit>: it gives a check on the accuracy of the result, in bits.
+I<check> should be at least C<10>, and preferably much more. In any case, the
+result is checked for correctness.
+
+If C<I<flag> = 0>, outputs only C<v_1>, which is much easier to compute.
+
+If C<I<flag> = 2>, does as if C<I<flag>> were C<0>, but doubles the precision until a
+result is obtained.
+
+If C<I<flag> = 3>, as in the default behaviour (C<I<flag> = 1>), but doubles the precision
+until a result is obtained.
+
+The user is warned that these two last setting may induce I<very> lengthy
+computations.
+
+X<isprincipalall>The library syntax is B<isprincipalall>C<(I<bnf>,x,I<flag>)>.
+
+=head2 X<bnfisunit>bnfisunitC<(I<bnf>,x)>
+
+C<I<bnf>> being the number field data
+output by
+C<bnfinit> and C<x> being an algebraic number (type integer, rational or
+polmod), this outputs the decomposition of C<x> on the fundamental units and
+the roots of unity if C<x> is a unit, the empty vector otherwise. More
+precisely, if C<u_1>,...,C<u_r> are the fundamental units, and C<F<zeta>> is
+the generator of the group of roots of unity (found by C<bnfclassunit> or
+C<bnfinit>), the output is a vector C<[x_1,...,x_r,x_{r+1}]> such that
+C<x = u_1^{x_1}...u_r^{x_r}.F<zeta>^{x_{r+1}}>. The C<x_i> are integers for
+C<i E<lt>= r> and is an integer modulo the order of C<F<zeta>> for C<i = r+1>.
+
+X<isunit>The library syntax is B<isunit>C<(I<bnf>,x)>.
+
+=head2 X<bnfmake>bnfmakeC<(I<sbnf>)>
+
+I<sbnf> being a ``small C<I<bnf>>''
+as output by C<bnfinit>C<(x,3)>, computes the complete C<bnfinit>
+information. The result is I<not> identical to what C<bnfinit> would
+yield, but is functionally identical. The execution time is very small
+compared to a complete C<bnfinit>. Note that if the default precision in
+GP (or C<I<prec>> in library mode) is greater than the precision of the
+roots C<I<sbnf>[5]>, these are recomputed so as to get a result with
+greater accuracy.
+
+Note that the member functions are I<not> available for I<sbnf>, you
+have to use C<bnfmake> explicitly first.
+
+X<makebigbnf>The library syntax is B<makebigbnf>C<(I<sbnf>,I<prec>)>, where C<I<prec>> is a
+C long integer.
+
+=head2 X<bnfnarrow>bnfnarrowC<(I<bnf>)>
+
+C<I<bnf>> being a big number field as
+output by C<bnfinit>, computes the narrow class group of C<I<bnf>>. The
+output is a 3-component row vector C<v> analogous to the corresponding
+class group component C<I<bnf>.clgp> (C<I<bnf>[8][1]>): the
+first component is the narrow class number C<v.no>, the second component
+is a vector containing the SNFX<Smith normal form> cyclic components
+C<v.cyc> of the narrow
+class group, and the third is a vector giving the generators of the
+corresponding C<v.gen> cyclic groups. Note that this function is a
+special case of C<bnrclass>.
+
+X<buchnarrow>The library syntax is B<buchnarrow>C<(I<bnf>)>.
+
+=head2 X<bnfsignunit>bnfsignunitC<(I<bnf>)>
+
+C<I<bnf>> being a big number field
+output by C<bnfinit>, this computes an C<r_1 x (r_1+r_2-1)> matrix
+having C<F<+->1> components, giving the signs of the real embeddings of the
+fundamental units.
+
+X<signunits>The library syntax is B<signunits>C<(I<bnf>)>.
+
+=head2 X<bnfreg>bnfregC<(I<bnf>)>
+
+C<I<bnf>> being a big number field
+output by C<bnfinit>, computes its regulator.
+
+X<regulator>The library syntax is B<regulator>C<(I<bnf>,I<tech>,I<prec>)>, where I<tech> is as in
+C<bnfclassunit>.
+
+=head2 X<bnfsunit>bnfsunitC<(I<bnf>,S)>
+
+computes the fundamental C<S>-units of the
+number field C<I<bnf>> (output by C<bnfinit>), where C<S> is a list of
+prime ideals (output by C<idealprimedec>). The output is a vector C<v> with
+6 components.
+
+C<v[1]> gives a minimal system of (integral) generators of the C<S>-unit group
+modulo the unit group.
+
+C<v[2]> contains technical data needed by C<bnfissunit>.
+
+C<v[3]> is an empty vector (used to give the logarithmic embeddings of the
+generators in C<v[1]> in version 2.0.16).
+
+C<v[4]> is the C<S>-regulator (this is the product of the regulator, the
+determinant of C<v[2]> and the natural logarithms of the norms of the ideals
+in C<S>).
+
+C<v[5]> gives the C<S>-class group structure, in the usual format
+(a row vector whose three components give in order the C<S>-class number,
+the cyclic components and the generators).
+
+C<v[6]> is a copy of C<S>.
+
+X<bnfsunit>The library syntax is B<bnfsunit>C<(I<bnf>,S,I<prec>)>.
+
+=head2 X<bnfunit>bnfunitC<(I<bnf>)>
+
+C<I<bnf>> being a big number field as
+output by
+C<bnfinit>, outputs a two-component row vector giving in the first
+component the vector of fundamental units of the number field, and in the
+second component the number of bit of accuracy which remained in the
+computation (which is always correct, otherwise an error message is printed).
+This function is mainly for people who used the wrong flag in C<bnfinit>
+and would like to skip part of a lengthy C<bnfinit> computation.
+
+X<buchfu>The library syntax is B<buchfu>C<(I<bnf>)>.
+
+=head2 X<bnrL1>bnrL1C<(I<bnr>,I<subgroup>,{I<flag> = 0})>
+
+I<bnr> being the number field data which is output by
+C<bnrinit(,,1)> and I<subgroup> being a square matrix defining a
+congruence subgroup of the ray class group corresponding to I<bnr>
+(or C<0> for the trivial congruence subgroup), returns for each
+X<character>character C<F<chi>> of the ray class group which is trivial on this
+subgroup, the value at C<s = 1> (or C<s = 0>) of the abelian
+C<L>-function associated to C<F<chi>>. For the value at C<s = 0>, the
+function returns in fact for each character C<F<chi>> a vector C<[r_F<chi> ,
+c_F<chi>]> where C<r_F<chi>> is the order of C<L(s, F<chi>)> at C<s = 0> and
+C<c_F<chi>> the first non-zero term in the expansion of C<L(s,
+F<chi>)> at C<s = 0>; in other words
+
+S< >C<L(s, F<chi>) = c_F<chi>.s^{r_F<chi>} + O(s^{r_F<chi> + 1})>
+
+near C<0>. I<flag> is optional, default value is 0; its binary digits
+mean 1: compute at C<s = 1> if set to 1 or C<s = 0> if set to 0, 2: compute
+the primitive C<L>-functions associated to C<F<chi>> if set to 0 or the
+C<L>-function with Euler factors at prime ideals dividing the modulus of
+I<bnr> removed if set to 1 (this is the so-called C<L_S(s, F<chi>)>
+function where C<S> is the set of infinite places of the number field
+together with the finite prime ideals dividing the modulus of I<bnr>,
+see the example below), 3: returns also the character.
+
+Example:
+
+ bnf = bnfinit(x^2 - 229);
+ bnr = bnrinit(bnf,1,1);
+ bnrL1(bnr, 0)
+
+returns the order and the first non-zero term of the abelian
+C<L>-functions C<L(s, F<chi>)> at C<s = 0> where C<F<chi>> runs through the
+characters of the class group of C<B<I<Q>>( F<sqrt> {229})>. Then
+
+ bnr2 = bnrinit(bnf,2,1);
+ bnrL1(bnr2,0,2)
+
+returns the order and the first non-zero terms of the abelian
+C<L>-functions C<L_S(s, F<chi>)> at C<s = 0> where C<F<chi>> runs through the
+characters of the class group of C<B<I<Q>>( F<sqrt> {229})> and C<S> is the set
+of infinite places of C<B<I<Q>>( F<sqrt> {229})> together with the finite prime
+C<2> (note that the ray class group modulo C<2> is in fact the class
+group, so C<bnrL1(bnr2,0)> returns exactly the same answer as
+C<bnrL1(bnr,0)>!).
+
+X<bnrL1>The library syntax is B<bnrL1>C<(I<bnr>,I<subgroup>,I<flag>,I<prec>)>
+
+=head2 X<bnrclass>bnrclassC<(I<bnf>,I<ideal>,{I<flag> = 0})>
+
+C<I<bnf>> being a big number field
+as output by C<bnfinit> (the units are mandatory unless the ideal is
+trivial), and I<ideal> being either an ideal in any form or a two-component
+row vector containing an ideal and an C<r_1>-component row vector of flags
+indicating which real Archimedean embeddings to take in the module, computes
+the ray class group of the number field for the module I<ideal>, as a
+3-component vector as all other finite Abelian groups (cardinality, vector of
+cyclic components, corresponding generators).
+
+If C<I<flag> = 2>, the output is different. It is a 6-component vector C<w>. C<w[1]>
+is C<I<bnf>>. C<w[2]> is the result of applying
+C<idealstar(I<bnf>,I,2)>. C<w[3]>, C<w[4]> and C<w[6]> are technical
+components used only by the function C<bnrisprincipal>. C<w[5]> is the
+structure of the ray class group as would have been output with C<I<flag> = 0>.
+
+If C<I<flag> = 1>, as above, except that the generators of the ray class group are
+not computed, which saves time.
+
+X<bnrclass0>The library syntax is B<bnrclass0>C<(I<bnf>,I<ideal>,I<flag>,I<prec>)>.
+
+=head2 X<bnrclassno>bnrclassnoC<(I<bnf>,I)>
+
+C<I<bnf>> being a big number field
+as output
+by C<bnfinit> (units are mandatory unless the ideal is trivial), and C<I>
+being either an ideal in any form or a two-component row vector containing an
+ideal and an C<r_1>-component row vector of flags indicating which real
+Archimedean embeddings to take in the modulus, computes the ray class number
+of the number field for the modulus C<I>. This is faster than C<bnrclass>
+and should be used if only the ray class number is desired.
+
+X<rayclassno>The library syntax is B<rayclassno>C<(I<bnf>,I)>.
+
+=head2 X<bnrclassnolist>bnrclassnolistC<(I<bnf>,I<list>)>
+
+C<I<bnf>> being a
+big number field as output by C<bnfinit> (units are mandatory unless
+the ideal is trivial), and I<list> being a list of modules as output
+by C<ideallist> of C<ideallistarch>,
+outputs the list of the class numbers of the corresponding ray class groups.
+
+X<rayclassnolist>The library syntax is B<rayclassnolist>C<(I<bnf>,I<list>)>.
+
+=head2 X<bnrconductor>bnrconductorC<(a_1,{a_2},{a_3}, {I<flag> = 0})>
+
+conductor of the
+subfield of a ray class field as defined by C<[a_1,a_2,a_3]> (see C<bnr>
+at the beginning of this section).
+
+X<bnrconductor>The library syntax is B<bnrconductor>C<(a_1,a_2,a_3,I<flag>,I<prec>)>, where an omitted argument
+among the C<a_i> is input as C<gzero>, and C<I<flag>> is a C long.
+
+=head2 X<bnrconductorofchar>bnrconductorofcharC<(I<bnr>,I<chi>)>
+
+I<bnr> being a
+big ray number field
+as output by C<bnrclass>, and I<chi> being a row vector representing a
+X<character>character as expressed on the generators of the ray class group, gives
+the conductor of this character as a modulus.
+
+X<bnrconductorofchar>The library syntax is B<bnrconductorofchar>C<(I<bnr>,I<chi>,I<prec>)> where C<I<prec>>
+is a C<long>.
+
+=head2 X<bnrdisc>bnrdiscC<(a1,{a2},{a3},{I<flag> = 0})>
+
+C<a1>, C<a2>, C<a3>
+defining a big ray number field C<L> over a groud field C<K> (see C<bnr>
+at the beginning of this section for the
+meaning of C<a1>, C<a2>, C<a3>), outputs a 3-component row vector C<[N,R_1,D]>,
+where C<N> is the (absolute) degree of C<L>, C<R_1> the number of real places of
+C<L>, and C<D> the discriminant of C<L/B<I<Q>>>, including sign (if C<I<flag> = 0>).
+
+If C<I<flag> = 1>, as above but outputs relative data. C<N> is now the degree of
+C<L/K>, C<R_1> is the number of real places of C<K> unramified in C<L> (so that
+the number of real places of C<L> is equal to C<R_1> times the relative degree
+C<N>), and C<D> is the relative discriminant ideal of C<L/K>.
+
+If C<I<flag> = 2>, does as in case 0, except that if the modulus is not the exact
+conductor corresponding to the C<L>, no data is computed and the result is C<0>
+(C<gzero>).
+
+If C<I<flag> = 3>, as case 2, outputting relative data.
+
+X<bnrdisc0>The library syntax is B<bnrdisc0>C<(a1,a2,a3,I<flag>,I<prec>)>.
+
+=head2 X<bnrdisclist>bnrdisclistC<(I<bnf>,I<bound>,{I<arch>},{I<flag> = 0})>
+
+C<I<bnf>> being a big
+number field as output by C<bnfinit> (the units are mandatory), computes a
+list of discriminants of Abelian extensions of the number field by increasing
+modulus norm up to bound I<bound>, where the ramified Archimedean places are
+given by I<arch> (unramified at infinity if I<arch> is void or
+omitted). If
+I<flag> is non-zero, give I<arch> all the possible values. (See C<bnr>
+at the beginning of this section for the meaning of C<a1>, C<a2>, C<a3>.)
+
+The alternative syntax C<bnrdisclist(I<bnf>,I<list>)>
+is supported, where I<list> is as output by C<ideallist> or
+C<ideallistarch> (with units).
+
+The output format is as follows. The output C<v> is a row vector of row
+vectors, allowing the bound to be greater than C<2^{16}> for 32-bit machines,
+and C<v[i][j]> is understood to be in fact C<V[2^{15}(i-1)+j]> of a unique big
+vector C<V> (note that C<2^{15}> is hardwired and can be increased in the
+source code only on 64-bit machines and higher).
+
+Such a component C<V[k]> is itself a vector C<W> (maybe of length 0) whose
+components correspond to each possible ideal of norm C<k>. Each component
+C<W[i]> corresponds to an Abelian extension C<L> of C<I<bnf>> whose modulus is
+an ideal of norm C<k> and no Archimedean components (hence the extension is
+unramified at infinity). The extension C<W[i]> is represented by a 4-component
+row vector C<[m,d,r,D]> with the following meaning. C<m> is the prime ideal
+factorization of the modulus, C<d = [L:B<I<Q>>]> is the absolute degree of C<L>,
+C<r> is the number of real places of C<L>, and C<D> is the factorization of the
+absolute discriminant. Each prime ideal C<pr = [p,F<alpha>,e,f,F<beta>]> in the
+prime factorization C<m> is coded as C<p.n^2+(f-1).n+(j-1)>, where
+C<n> is the degree of the base field and C<j> is such that
+
+C<pr = idealprimedec(I<nf>,p)[j]>.
+
+C<m> can be decoded using C<bnfdecodemodule>.
+
+X<bnrdisclist0>The library syntax is B<bnrdisclist0>C<(a1,a2,a3,I<bound>,I<arch>,I<flag>)>.
+
+=head2 X<bnrinit>bnrinitC<(I<bnf>,I<ideal>,{I<flag> = 0})>
+
+C<I<bnf>> is as
+output by C<bnfinit>, I<ideal> is a valid ideal (or a module),
+initializes data linked
+to the ray class group structure corresponding to this module. This is the
+same as C<bnrclass(I<bnf>,I<ideal>,I<flag>+1)>.
+
+X<bnrinit0>The library syntax is B<bnrinit0>C<(I<bnf>,I<ideal>,I<flag>,I<prec>)>.
+
+=head2 X<bnrisconductor>bnrisconductorC<(a1,{a2},{a3})>
+
+C<a1>, C<a2>, C<a3> represent
+an extension of the base field, given by class field theory for some modulus
+encoded in the parameters. Outputs 1 if this modulus is the conductor, and 0
+otherwise. This is slightly faster than C<bnrconductor>.
+
+X<bnrisconductor>The library syntax is B<bnrisconductor>C<(a1,a2,a3)> and the result is a C<long>.
+
+=head2 X<bnrisprincipal>bnrisprincipalC<(I<bnr>,x,{I<flag> = 1})>
+
+I<bnr> being the
+number field data which is output by C<bnrinit>C<(,,1)> and C<x> being an
+ideal in any form, outputs the components of C<x> on the ray class group
+generators in a way similar to C<bnfisprincipal>. That is a 3-component
+vector C<v> where C<v[1]> is the vector of components of C<x> on the ray class
+group generators, C<v[2]> gives on the integral basis an element C<F<alpha>> such
+that C<x = F<alpha>F<prod>_ig_i^{x_i}>. Finally C<v[3]> indicates the number of bits
+of accuracy left in the result. In any case the result is checked for
+correctness, but C<v[3]> is included to see if it is necessary to increase the
+accuracy in other computations.
+
+If C<I<flag> = 0>, outputs only C<v_1>. In that case, I<bnr> need not contain the
+ray class group generators, i.e.S< >it may be created with C<bnrinit>C<(,,0)>
+
+X<isprincipalrayall>The library syntax is B<isprincipalrayall>C<(I<bnr>,x,I<flag>)>.
+
+=head2 X<bnrrootnumber>bnrrootnumberC<(I<bnr>,I<chi>,{I<flag> = 0})>
+
+if C<F<chi> = I<chi>> is a (not necessarily primitive)
+X<character>character over I<bnr>, let
+C<L(s,F<chi>) = F<sum>_{id} F<chi>(id) N(id)^{-s}> be the associated
+X<Artin L-function>Artin L-function. Returns the so-called X<Artin root number>Artin root number, i.e.S< >the
+complex number C<W(F<chi>)> of modulus 1 such that
+
+S< >C<F<Lambda>(1-s,F<chi>) = W(F<chi>) F<Lambda>(s,\overline{F<chi>})>
+
+where C<F<Lambda>(s,F<chi>) = A(F<chi>)^{s/2}F<gamma>_F<chi>(s) L(s,F<chi>)> is
+the enlarged L-function associated to C<L>.
+
+The generators of the ray class group are needed, and you can set C<I<flag> = 1> if
+the character is known to be primitive. Example:
+
+ bnf = bnfinit(x^2 - 145);
+ bnr = bnrinit(bnf,7,1);
+ bnrrootnumber(bnr, [5])
+
+returns the root number of the character C<F<chi>> of C<Cl_7(B<I<Q>>( F<sqrt> {145}))>
+such that C<F<chi>(g) = F<zeta>^5>, where C<g> is the generator of the ray-class
+field and C<F<zeta> = e^{2iF<Pi>/N}> where C<N> is the order of C<g> (C<N = 12> as
+C<bnr.cyc> readily tells us).
+
+X<bnrrootnumber>The library syntax is B<bnrrootnumber>C<(I<bnf>,I<chi>,I<flag>)>
+
+=head2 bnrstarkC<{(I<bnr>,I<subgroup>,{I<flag> = 0})}>
+
+I<bnr>
+being as output by C<bnrinit(,,1)>, finds a relative equation for the
+class field corresponding to the modulus in I<bnr> and the given
+congruence subgroup using X<Stark units>Stark units (set C<I<subgroup> = 0> if you
+want the whole ray class group). The main variable of I<bnr> must not be
+C<x>, and the ground field and the class field must be totally real and not
+isomorphic to B<I<Q>> (over the rationnals, use X<polsubcyclo>C<polsubcyclo> or
+X<galoissubcyclo>C<galoissubcyclo>). I<flag> is optional and may be set to 0 to obtain a
+reduced relative polynomial, 1 to be satisfied with any relative
+polynomial, 2 to obtain an absolute polynomial and 3 to obtain the
+irreducible relative polynomial of the Stark unit, 0 being default.
+Example:
+
+ bnf = bnfinit(y^2 - 3);
+ bnr = bnrinit(bnf, 5, 1);
+ bnrstark(bnr, 0)
+
+returns the ray class field of C<B<I<Q>>( F<sqrt> {3})> modulo C<5>.
+
+B<Remark.> The result of the computation depends on the choice of
+a modulus verifying special conditions. By default the function will try
+few moduli, choosing the one giving the smallest result. In some cases
+where the result is however very large, you can tell the function to
+try more moduli by adding C<4> to the value of flag. Whether this flag is
+set or not, the function may fail in some extreme cases, returning the
+error message
+
+C<"Cannot find a suitable modulus in FindModule">.
+
+In this case, the corresponding congruence group is a product of cyclic
+groups and, for the time being, the class field has to be obtained by
+splitting this group into its cyclic components.
+
+X<bnrstark>The library syntax is B<bnrstark>C<(I<bnr>,I<subgroup>,I<flag>)>.
+
+=head2 X<dirzetak>dirzetakC<(I<nf>,b)>
+
+gives as a vector the first C<b>
+coefficients of the X<Dedekind>Dedekind zeta function of the number field C<I<nf>>
+considered as a X<Dirichlet series>Dirichlet series.
+
+X<dirzetak>The library syntax is B<dirzetak>C<(I<nf>,b)>.
+
+=head2 X<factornf>factornfC<(x,t)>
+
+factorization of the univariate polynomial C<x>
+over the number field defined by the (univariate) polynomial C<t>. C<x> may
+have coefficients in B<I<Q>> or in the number field. The main variable of
+C<t> must be of I<lower> priority than that of C<x> (in other words the
+variable number of C<t> must be I<greater> than that of C<x>). However if
+the coefficients of the number field occur explicitly (as polmods) as
+coefficients of C<x>, the variable of these polmods I<must> be the same as
+the main variable of C<t>. For example
+
+ ? factornf(x^2 + Mod(y, y^2+1), y^2+1);
+ ? factornf(x^2 + 1, y^2+1); \\ these two are OK
+ ? factornf(x^2 + Mod(z,z^2+1), y^2+1)
+ *** incorrect type in gmulsg
+
+X<polfnf>The library syntax is B<polfnf>C<(x,t)>.
+
+=head2 X<galoisfixedfield>galoisfixedfieldC<(I<gal>,I<perm>,{fl = 0},{v = y}))>
+
+I<gal> being be a Galois field as output by X<galoisinit>C<galoisinit> and
+I<perm> an element of C<I<gal>.group> or a vector of such elements,
+computes the fixed field of I<gal> by the automorphism defined by the
+permutations I<perm> of the roots C<I<gal>.roots>. C<P> is guaranteed to
+be squarefree modulo C<I<gal>.p>.
+
+If no flags or C<I<flag> = 0>, output format is the same as for X<nfsubfield>C<nfsubfield>,
+returning C<[P,x]> such that C<P> is a polynomial defining the fixed field, and
+C<x> is a root of C<P> expressed as a polmod in C<I<gal>.pol>.
+
+If C<I<flag> = 1> return only the polynomial C<P>.
+
+If C<I<flag> = 2> return C<[P,x,F]> where C<P> and C<x> are as above and C<F> is the
+factorization of C<I<gal>.pol> over the field defined by C<P>, where
+variable C<v> (C<y> by default) stands for a root of C<P>. The priority of C<v>
+must be less than the priority of the variable of C<I<gal>.pol>.
+
+Example:
+
+ G = galoisinit(x^4+1);
+ galoisfixedfield(G,G.group[2],2)
+ [x^2 + 2, Mod(x^3 + x, x^4 + 1), [x^2 - y*x - 1, x^2 + y*x - 1]]
+
+computes the factorization C<x^4+1 = (x^2- F<sqrt> {-2}x-1)(x^2+ F<sqrt> {-2}x-1)>
+
+X<galoisfixedfield>The library syntax is B<galoisfixedfield>C<(I<gal>,I<perm>,p)>.
+
+=head2 X<galoisinit>galoisinitC<(I<pol>,{den})>
+
+computes the Galois group
+and all neccessary information for computing the fixed fields of the
+Galois extension C<K/B<I<Q>>> where C<K> is the number field defined by
+C<I<pol>> (monic irreducible polynomial in C<B<I<Z>>[X]> or
+a number field as output by X<nfinit>C<nfinit>). The extension C<K/B<I<Q>>> must be
+Galois with Galois group ``weakly'' super-solvable (see X<nfgaloisconj>C<nfgaloisconj>)
+
+B<Warning:> The interface of this function is experimental,
+so the described output can be subject to important changes in the
+near future. However the function itself should work as described. For any
+remarks about this interface, please mail C<allomber@math.u-bordeaux.fr>.
+
+The output is an 8-component vector I<gal>.
+
+C<I<gal>[1]> contains the polynomial I<pol>
+(C<I<gal>.pol>).
+
+C<I<gal>[2]> is a three--components vector C<[p,e,q]> where C<p> is a
+prime number (C<I<gal>.p>) such that I<pol> totally split
+modulo C<p> , C<e> is an integer and C<q = p^e> (C<I<gal>.mod>) is the
+modulus of the roots in C<I<gal>.roots>.
+
+C<I<gal>[3]> is a vector C<L> containing the C<p>-adic roots of
+I<pol> as integers implicitly modulo C<I<gal>.mod>.
+(C<I<gal>.roots>).
+
+C<I<gal>[4]> is the inverse of the Van der Monde matrix of the
+C<p>-adic roots of I<pol>, multiplied by C<I<gal>[5]>.
+
+C<I<gal>[5]> is a multiple of the least common denominator of the
+automorphisms expressed as polynomial in a root of I<pol>.
+
+C<I<gal>[6]> is the Galois group C<G> expressed as a vector of
+permutations of C<L> (C<I<gal>.group>).
+
+C<I<gal>[7]> is a generating subset C<S = [s_1,...,s_g]> of C<G>
+expressed as a vector of permutations of C<L> (C<I<gal>.gen>).
+
+C<I<gal>[8]> contains the relative orders C<[o_1,...,o_g]> of
+the generators of C<S> (C<I<gal>.orders>).
+
+Let C<H> be the maximal normal supersolvable subgroup of C<G>, we have the
+following properties:
+
+S< >S< >C<B<*>> if C<G/H ~ A_4> then C<[o_1,...,o_g]> ends by
+C<[2,2,3]>.
+
+S< >S< >C<B<*>> if C<G/H ~ S_4> then C<[o_1,...,o_g]> ends by
+C<[2,2,3,2]>.
+
+S< >S< >C<B<*>> else C<G> is super-solvable.
+
+S< >S< >C<B<*>> for C<1 E<lt>= i E<lt>= g> the subgroup of C<G> generated by
+C<[s_1,...,s_g]> is normal, with the exception of C<i = g-2> in the
+second case and of C<i = g-3> in the third.
+
+S< >S< >C<B<*>> the relative order C<o_i> of C<s_i> is its order in the
+quotient group C<G/E<lt>s_1,...,s_{i-1}E<gt>>, with the same
+exceptions.
+
+S< >S< >C<B<*>> for any C<x belongs to G> there exists a unique family
+C<[e_1,...,e_g]> such that (no exceptions):
+
+-- for C<1 E<lt>= i E<lt>= g> we have C<0 E<lt>= e_i E<lt> o_i>
+
+-- C<x = g_1^{e_1}g_2^{e_2}...g_n^{e_n}>
+
+If present C<den> must be a suitable value for C<I<gal>[5]>.
+
+X<galoisinit>The library syntax is B<galoisinit>C<(I<gal>,I<den>)>.
+
+=head2 X<galoispermtopol>galoispermtopolC<(I<gal>,I<perm>)>
+
+I<gal> being a
+galois field as output by C<galoisinit> and I<perm> a element of
+C<I<gal>.group>, return the polynomial defining the Galois
+automorphism, as output by C<nfgaloisconj>, associated with the
+permutation I<perm> of the roots C<I<gal>.roots>. I<perm> can
+also be a vector or matrix, in this case, C<galoispermtopol> is
+applied to all components recursively.
+
+Note that
+
+ G = galoisinit(pol);
+ galoispermtopol(G, G[6])~
+
+is equivalent to C<nfgaloisconj(pol)>, if degree of I<pol>
+is greater or equal to C<2>.
+
+X<galoispermtopol>The library syntax is B<galoispermtopol>C<(I<gal>,I<perm>)>.
+
+=head2 X<galoissubcyclo>galoissubcycloC<(n,H,{Z},{v})>
+
+compute a polynomial
+defining the subfield of C<B<I<Q>>(F<zeta>_n)> fixed by the subgroup I<H> of
+C<B<I<Z>>/nB<I<Z>>>. The subgroup I<H> can be given by a generator, a set of
+generators given by a vector or a HNF matrix. If present C<Z> must be
+C<znstar(n)>, and is currently only used when I<H> is a HNF matrix. If
+I<v> is given, the polynomial is given in the variable I<v>.
+
+The following function can be used to compute all subfields of
+C<B<I<Q>>(F<zeta>_n)> (of order less than C<d>, if C<d> is set):
+
+ subcyclo(n, d = -1)=
+ {
+ local(Z,G,S);
+ if (d < 0, d = n);
+ Z = znstar(n);
+ G = matdiagonal(Z[2]);
+ S = [];
+ forsubgroup(H = G, d,
+ S = concat(S, galoissubcyclo(n, mathnf(concat(G,H)),Z));
+ );
+ S
+ }
+
+X<galoissubcyclo>The library syntax is B<galoissubcyclo>C<(n,H,Z,v)> where n is a C long integer.
+
+=head2 X<idealadd>idealaddC<(I<nf>,x,y)>
+
+sum of the two ideals C<x> and C<y> in the
+number field C<I<nf>>. When C<x> and C<y> are given by B<I<Z>>-bases, this does
+not depend on C<I<nf>> and can be used to compute the sum of any two
+B<I<Z>>-modules. The result is given in HNF.
+
+X<idealadd>The library syntax is B<idealadd>C<(I<nf>,x,y)>.
+
+=head2 X<idealaddtoone>idealaddtooneC<(I<nf>,x,{y})>
+
+C<x> and C<y> being two co-prime
+integral ideals (given in any form), this gives a two-component row vector
+C<[a,b]> such that C<a belongs to x>, C<b belongs to y> and C<a+b = 1>.
+
+The alternative syntax C<idealaddtoone(I<nf>,v)>, is supported, where
+C<v> is a C<k>-component vector of ideals (given in any form) which sum to
+C<B<I<Z>>_K>. This outputs a C<k>-component vector C<e> such that C<e[i] belongs to x[i]> for
+C<1 E<lt>= i E<lt>= k> and C<F<sum>_{1 E<lt>= i E<lt>= k}e[i] = 1>.
+
+X<idealaddtoone0>The library syntax is B<idealaddtoone0>C<(I<nf>,x,y)>, where an omitted C<y> is coded as
+C<NULL>.
+
+=head2 X<idealappr>idealapprC<(I<nf>,x,{I<flag> = 0})>
+
+if C<x> is a fractional ideal
+(given in any form), gives an element C<F<alpha>> in C<I<nf>> such that for
+all prime ideals C<B<I<p>>> such that the valuation of C<x> at C<B<I<p>>> is non-zero, we
+have C<v_{B<I<p>>}(F<alpha>) = v_{B<I<p>>}(x)>, and. C<v_{B<I<p>>}(F<alpha>) E<gt>= 0> for all other
+C<{B<I<p>>}>.
+
+If C<I<flag>> is non-zero, C<x> must be given as a prime ideal factorization, as
+output by C<idealfactor>, but possibly with zero or negative exponents.
+This yields an element C<F<alpha>> such that for all prime ideals C<B<I<p>>> occurring
+in C<x>, C<v_{B<I<p>>}(F<alpha>)> is equal to the exponent of C<B<I<p>>> in C<x>, and for all
+other prime ideals, C<v_{B<I<p>>}(F<alpha>) E<gt>= 0>. This generalizes
+C<idealappr(I<nf>,x,0)> since zero exponents are allowed. Note that
+the algorithm used is slightly different, so that
+C<idealapp(I<nf>,idealfactor(I<nf>,x))> may not be the same as
+C<idealappr(I<nf>,x,1)>.
+
+X<idealappr0>The library syntax is B<idealappr0>C<(I<nf>,x,I<flag>)>.
+
+=head2 X<idealchinese>idealchineseC<(I<nf>,x,y)>
+
+C<x> being a prime ideal factorization
+(i.e.S< >a 2 by 2 matrix whose first column contain prime ideals, and the second
+column integral exponents), C<y> a vector of elements in C<I<nf>> indexed by
+the ideals in C<x>, computes an element C<b> such that
+
+C<v_B<I<p>>(b - y_B<I<p>>) E<gt>= v_B<I<p>>(x)> for all prime ideals in C<x> and C<v_B<I<p>>(b) E<gt>= 0>
+for all other C<B<I<p>>>.
+
+X<idealchinese>The library syntax is B<idealchinese>C<(I<nf>,x,y)>.
+
+=head2 X<idealcoprime>idealcoprimeC<(I<nf>,x,y)>
+
+given two integral ideals C<x> and C<y>
+in the number field C<I<nf>>, finds a C<F<beta>> in the field, expressed on the
+integral basis C<I<nf>[7]>, such that C<F<beta>.y> is an integral ideal
+coprime to C<x>.
+
+X<idealcoprime>The library syntax is B<idealcoprime>C<(I<nf>,x)>.
+
+=head2 X<idealdiv>idealdivC<(I<nf>,x,y,{I<flag> = 0})>
+
+quotient C<x.y^{-1}> of the
+two ideals C<x> and C<y> in the number field C<I<nf>>. The result is given in
+HNF.
+
+If C<I<flag>> is non-zero, the quotient C<x.y^{-1}> is assumed to be an
+integral ideal. This can be much faster when the norm of the quotient is
+small even though the norms of C<x> and C<y> are large.
+
+X<idealdiv0>The library syntax is B<idealdiv0>C<(I<nf>,x,y,I<flag>)>. Also available
+are C<X<idealdiv>B<idealdiv>(I<nf>,x,y)> (C<I<flag> = 0>) and
+C<X<idealdivexact>B<idealdivexact>(I<nf>,x,y)> (C<I<flag> = 1>).
+
+=head2 X<idealfactor>idealfactorC<(I<nf>,x)>
+
+factors into prime ideal powers the
+ideal C<x> in the number field C<I<nf>>. The output format is similar to the
+C<factor> function, and the prime ideals are represented in the form
+output by the C<idealprimedec> function, i.e.S< >as 5-element vectors.
+
+X<idealfactor>The library syntax is B<idealfactor>C<(I<nf>,x)>.
+
+=head2 X<idealhnf>idealhnfC<(I<nf>,a,{b})>
+
+gives the X<Hermite normal form>Hermite normal form
+matrix of the ideal C<a>. The ideal can be given in any form whatsoever
+(typically by an algebraic number if it is principal, by a C<B<I<Z>>_K>-system of
+generators, as a prime ideal as given by C<idealprimedec>, or by a
+B<I<Z>>-basis).
+
+If C<b> is not omitted, assume the ideal given was C<aB<I<Z>>_K+bB<I<Z>>_K>, where C<a>
+and C<b> are elements of C<K> given either as vectors on the integral basis
+C<I<nf>[7]> or as algebraic numbers.
+
+X<idealhnf0>The library syntax is B<idealhnf0>C<(I<nf>,a,b)> where an omitted C<b> is coded as C<NULL>.
+Also available is C<X<idealhermite>B<idealhermite>(I<nf>,a)> (C<b> omitted).
+
+=head2 X<idealintersect>idealintersectC<(I<nf>,x,y)>
+
+intersection of the two ideals
+C<x> and C<y> in the number field C<I<nf>>. When C<x> and C<y> are given by
+B<I<Z>>-bases, this does not depend on C<I<nf>> and can be used to compute the
+intersection of any two B<I<Z>>-modules. The result is given in HNF.
+
+X<idealintersect>The library syntax is B<idealintersect>C<(I<nf>,x,y)>.
+
+=head2 X<idealinv>idealinvC<(I<nf>,x)>
+
+inverse of the ideal C<x> in the
+number field C<I<nf>>. The result is the Hermite normal form of the inverse
+of the ideal, together with the opposite of the Archimedean information if it
+is given.
+
+X<idealinv>The library syntax is B<idealinv>C<(I<nf>,x)>.
+
+=head2 X<ideallist>ideallistC<(I<nf>,I<bound>,{I<flag> = 4})>
+
+computes the list
+of all ideals of norm less or equal to I<bound> in the number field
+I<nf>. The result is a row vector with exactly I<bound> components.
+Each component is itself a row vector containing the information about
+ideals of a given norm, in no specific order. This information can be
+either the HNF of the ideal or the C<idealstar> with possibly some
+additional information.
+
+If C<I<flag>> is present, its binary digits are toggles meaning
+
+S< >S< >1: give also the generators in the C<idealstar>.
+
+S< >S< >2: output C<[L,U]>, where C<L> is as before and C<U> is a vector of
+C<zinternallog>s of the units.
+
+S< >S< >4: give only the ideals and not the C<idealstar> or the C<ideallog>
+of the units.
+
+X<ideallist0>The library syntax is B<ideallist0>C<(I<nf>,I<bound>,I<flag>)>, where I<bound> must
+be a C long integer. Also available is C<X<ideallist>B<ideallist>(I<nf>,I<bound>)>,
+corresponding to the case C<I<flag> = 0>.
+
+=head2 X<ideallistarch>ideallistarchC<(I<nf>,I<list>,{I<arch> = []},{I<flag> = 0})>
+
+vector of vectors of all C<idealstarinit> (see C<idealstar>) of all
+modules in I<list>, with Archimedean part I<arch> added (void if
+omitted). I<list> is a vector of big ideals, as output by
+C<ideallist>C<(..., I<flag>)> for instance. C<I<flag>> is optional; its binary
+digits are toggles meaning: 1: give generators as well, 2: list format is
+C<[L,U]> (see C<ideallist>).
+
+X<ideallistarch0>The library syntax is B<ideallistarch0>C<(I<nf>,I<list>,I<arch>,I<flag>)>, where an omitted
+I<arch> is coded as C<NULL>.
+
+=head2 X<ideallog>ideallogC<(I<nf>,x,I<bid>)>
+
+C<I<nf>> being a number field,
+I<bid> being a ``big ideal'' as output by C<idealstar> and C<x> being a
+non-necessarily integral element of I<nf> which must have valuation
+equal to 0 at all prime ideals dividing C<I = I<bid>[1]>, computes the
+``discrete logarithm'' of C<x> on the generators given in C<I<bid>[2]>.
+In other words, if C<g_i> are these generators, of orders C<d_i> respectively,
+the result is a column vector of integers C<(x_i)> such that C<0 E<lt>= x_i E<lt> d_i> and
+
+S< >C<x = F<prod>_ig_i^{x_i} (mod ^*I) .>
+
+Note that when C<I> is a module, this implies also sign conditions on the
+embeddings.
+
+X<zideallog>The library syntax is B<zideallog>C<(I<nf>,x,I<bid>)>.
+
+=head2 X<idealmin>idealminC<(I<nf>,x,{I<vdir>})>
+
+computes a minimum of
+the ideal C<x> in the direction I<vdir> in the number field I<nf>.
+
+X<minideal>The library syntax is B<minideal>C<(I<nf>,x,I<vdir>,I<prec>)>, where an omitted
+I<vdir> is coded as C<NULL>.
+
+=head2 X<idealmul>idealmulC<(I<nf>,x,y,{I<flag> = 0})>
+
+ideal multiplication of the
+ideals C<x> and C<y> in the number field I<nf>. The result is a generating
+set for the ideal product with at most C<n> elements, and is in Hermite normal
+form if either C<x> or C<y> is in HNF or is a prime ideal as output by
+C<idealprimedec>, and this is given together with the sum of the
+Archimedean information in C<x> and C<y> if both are given.
+
+If C<I<flag>> is non-zero, reduce the result using C<idealred>.
+
+X<idealmul>The library syntax is B<idealmul>C<(I<nf>,x,y)> (C<I<flag> = 0>) or
+C<X<idealmulred>B<idealmulred>(I<nf>,x,y,I<prec>)> (C<I<flag> ! = 0>), where as usual,
+C<I<prec>> is a C long integer representing the precision.
+
+=head2 X<idealnorm>idealnormC<(I<nf>,x)>
+
+computes the norm of the idealS< >C<x>
+in the number fieldS< >C<I<nf>>.
+
+X<idealnorm>The library syntax is B<idealnorm>C<(I<nf>, x)>.
+
+=head2 X<idealpow>idealpowC<(I<nf>,x,k,{I<flag> = 0})>
+
+computes the C<k>-th power of
+the ideal C<x> in the number field C<I<nf>>. C<k> can be positive, negative
+or zero. The result is NOT reduced, it is really the C<k>-th ideal power, and
+is given in HNF.
+
+If C<I<flag>> is non-zero, reduce the result using C<idealred>. Note however
+that this is NOT the same as as C<idealpow(I<nf>,x,k)> followed by
+reduction, since the reduction is performed throughout the powering process.
+
+The library syntax corresponding to C<I<flag> = 0> is
+C<X<idealpow>B<idealpow>(I<nf>,x,k)>. If C<k> is a C<long>, you can use
+C<X<idealpows>B<idealpows>(I<nf>,x,k)>. Corresponding to C<I<flag> = 1> is
+C<X<idealpowred>B<idealpowred>(I<nf>,vp,k,I<prec>)>, where C<I<prec>> is a
+C<long>.
+
+=head2 X<idealprimedec>idealprimedecC<(I<nf>,p)>
+
+computes the prime ideal
+decomposition of the prime number C<p> in the number field C<I<nf>>. C<p>
+must be a (positive) prime number. Note that the fact that C<p> is prime is
+not checked, so if a non-prime number C<p> is given it may lead to
+unpredictable results.
+
+The result is a vector of 5-component vectors, each representing one of the
+prime ideals above C<p> in the number field C<I<nf>>. The representation
+C<vp = [p,a,e,f,b]> of a prime ideal means the following. The prime ideal is
+equal to C<pB<I<Z>>_K+F<alpha>B<I<Z>>_K> where C<B<I<Z>>_K> is the ring of integers of the field
+and C<F<alpha> = F<sum>_i a_iF<omega>_i> where the C<F<omega>_i> form the integral basis
+C<I<nf>.zk>, C<e> is the ramification index, C<f> is the residual index,
+and C<b> is an C<n>-component column vector representing a C<F<beta> belongs to B<I<Z>>_K> such
+that C<vp^{-1} = B<I<Z>>_K+F<beta>/pB<I<Z>>_K> which will be useful for computing
+valuations, but which the user can ignore. The number C<F<alpha>> is guaranteed
+to have a valuation equal to 1 at the prime ideal (this is automatic if
+C<e E<gt> 1>).
+
+X<idealprimedec>The library syntax is B<idealprimedec>C<(I<nf>,p)>.
+
+=head2 X<idealprincipal>idealprincipalC<(I<nf>,x)>
+
+creates the principal ideal
+generated by the algebraic number C<x> (which must be of type integer,
+rational or polmod) in the number field C<I<nf>>. The result is a
+one-column matrix.
+
+X<principalideal>The library syntax is B<principalideal>C<(I<nf>,x)>.
+
+=head2 X<idealred>idealredC<(I<nf>,I,{I<vdir> = 0})>
+
+X<LLL>LLL reduction of
+the ideal C<I> in the number field I<nf>, along the direction I<vdir>.
+If I<vdir> is present, it must be an C<r1+r2>-component vector (C<r1> and
+C<r2> number of real and complex places of I<nf> as usual).
+
+This function finds a ``small'' C<a> in C<I> (it is an LLL pseudo-minimum
+along direction I<vdir>). The result is the X<Hermite normal form>Hermite normal form of
+the LLL-reduced ideal C<r I/a>, where C<r> is a rational number such that the
+resulting ideal is integral and primitive. This is often, but not always, a
+reduced ideal in the sense of X<Buchmann>Buchmann. If C<I> is an idele, the
+logarithmic embeddings of C<a> are subtracted to the Archimedean part.
+
+More often than not, a X<principal ideal>principal ideal will yield the identity
+matrix. This is a quick and dirty way to check if ideals are principal
+without computing a full C<bnf> structure, but it's not a necessary
+condition; hence, a non-trivial result doesn't prove the ideal is
+non-trivial in the class group.
+
+Note that this is I<not> the same as the LLL reduction of the lattice
+C<I> since ideal operations are involved.
+
+X<ideallllred>The library syntax is B<ideallllred>C<(I<nf>,x,I<vdir>,I<prec>)>, where an omitted
+I<vdir> is coded as C<NULL>.
+
+=head2 X<idealstar>idealstarC<(I<nf>,I,{I<flag> = 1})>
+
+I<nf> being a number
+field, and C<I>
+either and ideal in any form, or a row vector whose first component is an
+ideal and whose second component is a row vector of C<r_1> 0 or 1, outputs
+necessary data for computing in the group C<(B<I<Z>>_K/I)^*>.
+
+If C<I<flag> = 2>, the result is a 5-component vector C<w>. C<w[1]> is the ideal
+or module C<I> itself. C<w[2]> is the structure of the group. The other
+components are difficult to describe and are used only in conjunction with
+the function C<ideallog>.
+
+If C<I<flag> = 1> (default), as C<I<flag> = 2>, but do not compute explicit generators
+for the cyclic components, which saves time.
+
+If C<I<flag> = 0>, computes the structure of C<(B<I<Z>>_K/I)^*> as a 3-component vector
+C<v>. C<v[1]> is the order, C<v[2]> is the vector of SNFX<Smith normal form>
+cyclic components and
+C<v[3]> the corresponding generators. When the row vector is explicitly
+included, the
+non-zero elements of this vector are considered as real embeddings of
+I<nf> in the order given by C<polroots>, i.e.S< >in I<nf>[6]
+(C<I<nf>.roots>), and then C<I> is a module with components at infinity.
+
+To solve discrete logarithms (using C<ideallog>), you have to choose
+C<I<flag> = 2>.
+
+X<idealstar0>The library syntax is B<idealstar0>C<(I<nf>,I,I<flag>)>.
+
+=head2 X<idealtwoelt>idealtwoeltC<(I<nf>,x,{a})>
+
+computes a two-element
+representation of the ideal C<x> in the number field C<I<nf>>, using a
+straightforward (exponential time) search. C<x> can be an ideal in any form,
+(including perhaps an Archimedean part, which is ignored) and the result is a
+row vector C<[a,F<alpha>]> with two components such that C<x = aB<I<Z>>_K+F<alpha>B<I<Z>>_K>
+and C<a belongs to B<I<Z>>>, where C<a> is the one passed as argument if any. If C<x> is given
+by at least two generators, C<a> is chosen to be the positive generator of
+C<x F<cap> B<I<Z>>>.
+
+Note that when an explicit C<a> is given, we use an asymptotically faster
+method, however in practice it is usually slower.
+
+X<ideal_two_elt0>The library syntax is B<ideal_two_elt0>C<(I<nf>,x,a)>, where an omitted C<a> is entered as
+C<NULL>.
+
+=head2 X<idealval>idealvalC<(I<nf>,x,I<vp>)>
+
+gives the valuation of the
+ideal C<x> at the prime ideal I<vp> in the number field C<I<nf>>,
+where I<vp> must be a
+5-component vector as given by C<idealprimedec>.
+
+X<idealval>The library syntax is B<idealval>C<(I<nf>,x,I<vp>)>, and the result is a C<long>
+integer.
+
+=head2 X<ideleprincipal>ideleprincipalC<(I<nf>,x)>
+
+creates the principal idele
+generated by the algebraic number C<x> (which must be of type integer,
+rational or polmod) in the number field C<I<nf>>. The result is a
+two-component vector, the first being a one-column matrix representing the
+corresponding principal ideal, and the second being the vector with C<r_1+r_2>
+components giving the complex logarithmic embedding of C<x>.
+
+X<principalidele>The library syntax is B<principalidele>C<(I<nf>,x)>.
+
+=head2 X<matalgtobasis>matalgtobasisC<(I<nf>,x)>
+
+C<I<nf>> being a number field in
+C<nfinit> format, and C<x> a matrix whose coefficients are expressed as
+polmods in C<I<nf>>, transforms this matrix into a matrix whose
+coefficients are expressed on the integral basis of C<I<nf>>. This is the
+same as applying C<nfalgtobasis> to each entry, but it would be dangerous
+to use the same name.
+
+X<matalgtobasis>The library syntax is B<matalgtobasis>C<(I<nf>,x)>.
+
+=head2 X<matbasistoalg>matbasistoalgC<(I<nf>,x)>
+
+C<I<nf>> being a number field in
+C<nfinit> format, and C<x> a matrix whose coefficients are expressed as
+column vectors on the integral basis of C<I<nf>>, transforms this matrix
+into a matrix whose coefficients are algebraic numbers expressed as
+polmods. This is the same as applying C<nfbasistoalg> to each entry, but
+it would be dangerous to use the same name.
+
+X<matbasistoalg>The library syntax is B<matbasistoalg>C<(I<nf>,x)>.
+
+=head2 X<modreverse>modreverseC<(a)>
+
+C<a> being a polmod C<A(X)> modulo C<T(X)>, finds
+the ``reverse polmod'' C<B(X)> modulo C<Q(X)>, where C<Q> is the minimal
+polynomial of C<a>, which must be equal to the degree of C<T>, and such that if
+C<F<theta>> is a root of C<T> then C<F<theta> = B(F<alpha>)> for a certain root C<F<alpha>>
+of C<Q>.
+
+This is very useful when one changes the generating element in algebraic
+extensions.
+
+X<polmodrecip>The library syntax is B<polmodrecip>C<(x)>.
+
+=head2 X<newtonpoly>newtonpolyC<(x,p)>
+
+gives the vector of the slopes of the Newton
+polygon of the polynomial C<x> with respect to the prime number C<p>. The C<n>
+components of the vector are in decreasing order, where C<n> is equal to the
+degree of C<x>. Vertical slopes occur iff the constant coefficient of C<x> is
+zero and are denoted by C<VERYBIGINT>, the biggest single precision
+integer representable on the machine (C<2^{31}-1> (resp.S< >C<2^{63}-1>) on 32-bit
+(resp.S< >64-bit) machines), see L<Label se:valuation>.
+
+X<newtonpoly>The library syntax is B<newtonpoly>C<(x,p)>.
+
+=head2 X<nfalgtobasis>nfalgtobasisC<(I<nf>,x)>
+
+this is the inverse function of
+C<nfbasistoalg>. Given an object C<x> whose entries are expressed as
+algebraic numbers in the number field C<I<nf>>, transforms it so that the
+entries are expressed as a column vector on the integral basis
+C<I<nf>.zk>.
+
+X<algtobasis>The library syntax is B<algtobasis>C<(I<nf>,x)>.
+
+=head2 X<nfbasis>nfbasisC<(x,{I<flag> = 0},{p})>
+
+X<integral basis>integral basis of the number
+field defined by the irreducible, preferably monic, polynomial C<x>,
+using a modified version of the X<round 4>round 4 algorithm by
+default. The binary digits of C<I<flag>> have the following meaning:
+
+1: assume that no square of a prime greater than the default C<primelimit>
+divides the discriminant of C<x>, i.e.S< >that the index of C<x> has only small
+prime divisors.
+
+2: use X<round 2>round 2 algorithm. For small degrees and coefficient size, this is
+sometimes a little faster. (This program is the translation into C of a program
+written by David X<Ford>Ford in Algeb.)
+
+Thus for instance, if C<I<flag> = 3>, this uses the round 2 algorithm and outputs
+an order which will be maximal at all the small primes.
+
+If C<p> is present, we assume (without checking!) that it is the two-column
+matrix of the factorization of the discriminant of the polynomial C<x>. Note
+that it does I<not> have to be a complete factorization. This is
+especially useful if only a local integral basis for some small set of places
+is desired: only factors with exponents greater or equal to 2 will be
+considered.
+
+X<nfbasis0>The library syntax is B<nfbasis0>C<(x,I<flag>,p)>. An extended version
+is C<X<nfbasis>B<nfbasis>(x,&d,I<flag>,p)>, where C<d> will receive the discriminant of
+the number field (I<not> of the polynomial C<x>), and an omitted C<p> should
+be input as C<gzero>. Also available are C<X<base>B<base>(x,&d)> (C<I<flag> = 0>),
+C<X<base2>B<base2>(x,&d)> (C<I<flag> = 2>) and C<X<factoredbase>B<factoredbase>(x,p,&d)>.
+
+=head2 X<nfbasistoalg>nfbasistoalgC<(I<nf>,x)>
+
+this is the inverse function of
+C<nfalgtobasis>. Given an object C<x> whose entries are expressed on the
+integral basis C<I<nf>.zk>, transforms it into an object whose entries
+are algebraic numbers (i.e.S< >polmods).
+
+X<basistoalg>The library syntax is B<basistoalg>C<(I<nf>,x)>.
+
+=head2 X<nfdetint>nfdetintC<(I<nf>,x)>
+
+given a pseudo-matrix C<x>, computes a
+non-zero ideal contained in (i.e.S< >multiple of) the determinant of C<x>. This
+is particularly useful in conjunction with C<nfhnfmod>.
+
+X<nfdetint>The library syntax is B<nfdetint>C<(I<nf>,x)>.
+
+=head2 X<nfdisc>nfdiscC<(x,{I<flag> = 0},{p})>
+
+X<field discriminant>field discriminant of the
+number field defined by the integral, preferably monic, irreducible
+polynomial C<x>. C<I<flag>> and C<p> are exactly as in C<nfbasis>. That is, C<p>
+provides the matrix of a partial factorization of the discriminant of C<x>,
+and binary digits of C<I<flag>> are as follows:
+
+1: assume that no square of a prime greater than C<primelimit>
+divides the discriminant.
+
+2: use the round 2 algorithm, instead of the default X<round 4>round 4.
+This should be
+slower except maybe for polynomials of small degree and coefficients.
+
+X<nfdiscf0>The library syntax is B<nfdiscf0>C<(x,I<flag>,p)> where, to omit C<p>, you should input C<gzero>. You
+can also use C<X<discf>B<discf>(x)> (C<I<flag> = 0>).
+
+=head2 X<nfeltdiv>nfeltdivC<(I<nf>,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes their quotient C<x/y> in the number field C<I<nf>>.
+
+X<element_div>The library syntax is B<element_div>C<(I<nf>,x,y)>.
+
+=head2 X<nfeltdiveuc>nfeltdiveucC<(I<nf>,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes an algebraic integer C<q> in the number field C<I<nf>>
+such that the components of C<x-qy> are reasonably small. In fact, this is
+functionally identical to C<round(nfeltdiv(I<nf>,x,y))>.
+
+X<nfdiveuc>The library syntax is B<nfdiveuc>C<(I<nf>,x,y)>.
+
+=head2 X<nfeltdivmodpr>nfeltdivmodprC<(I<nf>,x,y,I<pr>)>
+
+given two elements C<x>
+and C<y> in I<nf> and I<pr> a prime ideal in C<modpr> format (see
+X<nfmodprinit>C<nfmodprinit>), computes their quotient C<x / y> modulo the prime ideal
+I<pr>.
+
+X<element_divmodpr>The library syntax is B<element_divmodpr>C<(I<nf>,x,y,I<pr>)>.
+
+=head2 X<nfeltdivrem>nfeltdivremC<(I<nf>,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, gives a two-element row vector C<[q,r]> such that C<x = qy+r>, C<q> is
+an algebraic integer in C<I<nf>>, and the components of C<r> are
+reasonably small.
+
+X<nfdivres>The library syntax is B<nfdivres>C<(I<nf>,x,y)>.
+
+=head2 X<nfeltmod>nfeltmodC<(I<nf>,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes an element C<r> of C<I<nf>> of the form C<r = x-qy> with
+C<q> and algebraic integer, and such that C<r> is small. This is functionally
+identical to
+
+S< >C<x - nfeltmul(I<nf>,round(nfeltdiv(I<nf>,x,y)),y).>
+
+X<nfmod>The library syntax is B<nfmod>C<(I<nf>,x,y)>.
+
+=head2 X<nfeltmul>nfeltmulC<(I<nf>,x,y)>
+
+given two elements C<x> and C<y> in
+I<nf>, computes their product C<x*y> in the number field C<I<nf>>.
+
+X<element_mul>The library syntax is B<element_mul>C<(I<nf>,x,y)>.
+
+=head2 X<nfeltmulmodpr>nfeltmulmodprC<(I<nf>,x,y,I<pr>)>
+
+given two elements C<x> and
+C<y> in I<nf> and I<pr> a prime ideal in C<modpr> format (see
+X<nfmodprinit>C<nfmodprinit>), computes their product C<x*y> modulo the prime ideal
+I<pr>.
+
+X<element_mulmodpr>The library syntax is B<element_mulmodpr>C<(I<nf>,x,y,I<pr>)>.
+
+=head2 X<nfeltpow>nfeltpowC<(I<nf>,x,k)>
+
+given an element C<x> in I<nf>,
+and a positive or negative integer C<k>, computes C<x^k> in the number field
+C<I<nf>>.
+
+X<element_pow>The library syntax is B<element_pow>C<(I<nf>,x,k)>.
+
+=head2 X<nfeltpowmodpr>nfeltpowmodprC<(I<nf>,x,k,I<pr>)>
+
+given an element C<x> in
+I<nf>, an integer C<k> and a prime ideal I<pr> in C<modpr> format
+(see X<nfmodprinit>C<nfmodprinit>), computes C<x^k> modulo the prime ideal I<pr>.
+
+X<element_powmodpr>The library syntax is B<element_powmodpr>C<(I<nf>,x,k,I<pr>)>.
+
+=head2 X<nfeltreduce>nfeltreduceC<(I<nf>,x,I<ideal>)>
+
+given an ideal in
+Hermite normal form and an element C<x> of the number field C<I<nf>>,
+finds an element C<r> in C<I<nf>> such that C<x-r> belongs to the ideal
+and C<r> is small.
+
+X<element_reduce>The library syntax is B<element_reduce>C<(I<nf>,x,I<ideal>)>.
+
+=head2 X<nfeltreducemodpr>nfeltreducemodprC<(I<nf>,x,I<pr>)>
+
+given
+an element C<x> of the number field C<I<nf>> and a prime ideal I<pr> in
+C<modpr> format compute a canonical representative for the class of C<x>
+modulo I<pr>.
+
+X<nfreducemodpr2>The library syntax is B<nfreducemodpr2>C<(I<nf>,x,I<pr>)>.
+
+=head2 X<nfeltval>nfeltvalC<(I<nf>,x,I<pr>)>
+
+given an element C<x> in
+I<nf> and a prime ideal I<pr> in the format output by
+C<idealprimedec>, computes their the valuation at I<pr> of the
+element C<x>. The same result could be obtained using
+C<idealval(I<nf>,x,I<pr>)> (since C<x> would then be converted to a
+principal ideal), but it would be less efficient.
+
+X<element_val>The library syntax is B<element_val>C<(I<nf>,x,I<pr>)>, and the result is a C<long>.
+
+=head2 X<nffactor>nffactorC<(I<nf>,x)>
+
+factorization of the univariate
+polynomial C<x> over the number field C<I<nf>> given by C<nfinit>. C<x>
+has coefficients in C<I<nf>> (i.e.S< >either scalar, polmod, polynomial or
+column vector). The main variable of C<I<nf>> must be of I<lower>
+priority than that of C<x> (in other words, the variable number of C<I<nf>>
+must be I<greater> than that of C<x>). However if the polynomial defining
+the number field occurs explicitly in the coefficients of C<x> (as modulus of
+a C<t_POLMOD>), its main variable must be I<the same> as the main
+variable of C<x>. For example,
+
+ ? nf = nfinit(y^2 + 1);
+ ? nffactor(nf, x^2 + y); \\ OK
+ ? nffactor(nf, x^2 + Mod(y, y^2+1)); \\ OK
+ ? nffactor(nf, x^2 + Mod(z, z^2+1)); \\ WRONG
+
+X<nffactor>The library syntax is B<nffactor>C<(I<nf>,x)>.
+
+=head2 X<nffactormod>nffactormodC<(I<nf>,x,I<pr>)>
+
+factorization of the
+univariate polynomial C<x> modulo the prime ideal I<pr> in the number
+field C<I<nf>>. C<x> can have coefficients in the number field (scalar,
+polmod, polynomial, column vector) or modulo the prime ideal (integermod
+modulo the rational prime under I<pr>, polmod or polynomial with
+integermod coefficients, column vector of integermod). The prime ideal
+I<pr> I<must> be in the format output by C<idealprimedec>. The
+main variable of C<I<nf>> must be of lower priority than that of C<x> (in
+other words the variable number of C<I<nf>> must be greater than that of
+C<x>). However if the coefficients of the number field occur explicitly (as
+polmods) as coefficients of C<x>, the variable of these polmods I<must>
+be the same as the main variable of C<t> (see C<nffactor>).
+
+X<nffactormod>The library syntax is B<nffactormod>C<(I<nf>,x,I<pr>)>.
+
+=head2 X<nfgaloisapply>nfgaloisapplyC<(I<nf>,I<aut>,x)>
+
+C<I<nf>> being a
+number field as output by C<nfinit>, and I<aut> being a X<Galois>Galois
+automorphism of C<I<nf>> expressed either as a polynomial or a polmod
+(such automorphisms being found using for example one of the variants of
+C<nfgaloisconj>), computes the action of the automorphism I<aut> on
+the object C<x> in the number field. C<x> can be an element (scalar, polmod,
+polynomial or column vector) of the number field, an ideal (either given by
+C<B<I<Z>>_K>-generators or by a B<I<Z>>-basis), a prime ideal (given as a 5-element
+row vector) or an idele (given as a 2-element row vector). Because of
+possible confusion with elements and ideals, other vector or matrix
+arguments are forbidden.
+
+X<galoisapply>The library syntax is B<galoisapply>C<(I<nf>,I<aut>,x)>.
+
+=head2 X<nfgaloisconj>nfgaloisconjC<(I<nf>,{I<flag> = 0},{d})>
+
+C<I<nf>> being a
+number field as output by C<nfinit>, computes the conjugates of a root
+C<r> of the non-constant polynomial C<x = I<nf>[1]> expressed as
+polynomials in C<r>. This can be used even if the number field C<I<nf>> is
+not X<Galois>Galois since some conjugates may lie in the field. As a note to
+old-timers of PARI, starting with version 2.0.17 this function works much
+better than in earlier versions.
+
+C<I<nf>> can simply be a polynomial if C<I<flag> ! = 1>.
+
+If no flags or C<I<flag> = 0>, if C<I<nf>> is a number field use a
+combination of flag C<4> and C<1> and the result is always complete,
+else use a combination of flag C<4> and C<2> and the result is subject
+to the restriction of C<I<flag> = 2>, but a warning is issued when it is not
+proven complete.
+
+If C<I<flag> = 1>, use C<nfroots> (require a number field).
+
+If C<I<flag> = 2>, use complex approximations to the roots and an integral
+X<LLL>LLL. The result is not guaranteed to be complete: some
+conjugates may be missing (no warning issued), especially so if the
+corresponding polynomial has a huge index. In that case, increasing
+the default precision may help.
+
+If C<I<flag> = 4>, use Allombert's algorithm and permutation testing. If the
+field is Galois with ``weakly'' super solvable Galois group, return
+the complete list of automorphisms, else only the identity element. If
+present, C<d> is assumed to be a multiple of the least common
+denominator of the conjugates expressed as polynomial in a root of
+I<pol>.
+
+A group G is ``weakly'' super solvable if it contains a super solvable
+normal subgroup C<H> such that C<G = H> , or C<G/H ~ A_4> , or C<G/H ~
+S_4>. Abelian and nilpotent groups are ``weakly'' super solvable. In
+practice, almost all groups of small order are ``weakly'' super solvable, the
+exceptions having order 36(1 exception), 48(2), 56(1), 60(1), 72(5), 75(1),
+80(1), 96(10) and C< E<gt>= 108>.
+
+Hence C<I<flag> = 4> permits to quickly check whether a polynomial of order
+strictly less than C<36> is Galois or not. This method is much faster than
+C<nfroots> and can be applied to polynomials of degree larger than C<50>.
+
+X<galoisconj0>The library syntax is B<galoisconj0>C<(I<nf>,I<flag>,d,I<prec>)>. Also available are
+C<X<galoisconj>B<galoisconj>(I<nf>)> for C<I<flag> = 0>,
+C<X<galoisconj2>B<galoisconj2>(I<nf>,n,I<prec>)> for C<I<flag> = 2> where C<n> is a bound
+on the number of conjugates, and C<X<galoisconj4>B<galoisconj4>(I<nf>,d)>
+corresponding to C<I<flag> = 4>.
+
+=head2 X<nfhilbert>nfhilbertC<(I<nf>,a,b,{I<pr>})>
+
+if I<pr> is omitted,
+compute the global X<Hilbert symbol>Hilbert symbol C<(a,b)> in C<I<nf>>, that is C<1>
+if C<x^2 - a y^2 - b z^2> has a non trivial solution C<(x,y,z)> in C<I<nf>>,
+and C<-1> otherwise. Otherwise compute the local symbol modulo the prime ideal
+I<pr> (as output by C<idealprimedec>).
+
+X<nfhilbert>The library syntax is B<nfhilbert>C<(I<nf>,a,b,I<pr>)>, where an omitted I<pr> is coded
+as C<NULL>.
+
+=head2 X<nfhnf>nfhnfC<(I<nf>,x)>
+
+given a pseudo-matrix C<(A,I)>, finds a
+pseudo-basis in X<Hermite normal form>Hermite normal form of the module it generates.
+
+X<nfhermite>The library syntax is B<nfhermite>C<(I<nf>,x)>.
+
+=head2 X<nfhnfmod>nfhnfmodC<(I<nf>,x,I<detx>)>
+
+given a pseudo-matrix C<(A,I)>
+and an ideal I<detx> which is contained in (read integral multiple of) the
+determinant of C<(A,I)>, finds a pseudo-basis in X<Hermite normal form>Hermite normal form
+of the module generated by C<(A,I)>. This avoids coefficient explosion.
+I<detx> can be computed using the function C<nfdetint>.
+
+X<nfhermitemod>The library syntax is B<nfhermitemod>C<(I<nf>,x,I<detx>)>.
+
+=head2 X<nfinit>nfinitC<(I<pol>,{I<flag> = 0})>
+
+I<pol> being a non-constant,
+preferably monic, irreducible polynomial in C<B<I<Z>>[X]>, initializes a
+I<number field> structure (C<nf>) associated to the field C<K> defined
+by I<pol>. As such, it's a technical object passed as the first argument
+to most C<nf>I<xxx> functions, but it contains some information which
+may be directly useful. Access to this information via I<member
+functions> is prefered since the specific data organization specified below
+may change in the future. Currently, C<nf> is a row vector with 9
+components:
+
+C<I<nf>[1]> contains the polynomial I<pol> (C<I<nf>.pol>).
+
+C<I<nf>[2]> contains C<[r1,r2]> (C<I<nf>.sign>), the number of real
+and complex places of C<K>.
+
+C<I<nf>[3]> contains the discriminant C<d(K)> (C<I<nf>.disc>) of C<K>.
+
+C<I<nf>[4]> contains the index of C<I<nf>[1]>,
+i.e.S< >C<[B<I<Z>>_K : B<I<Z>>[F<theta>]]>, where C<F<theta>> is any root of C<I<nf>[1]>.
+
+C<I<nf>[5]> is a vector containing 7 matrices C<M>, C<MC>, C<T2>, C<T>,
+C<MD>, C<TI>, C<MDI> useful for certain computations in the number field C<K>.
+
+S< >S< >C<B<*>> C<M> is the C<(r1+r2) x n> matrix whose columns represent
+the numerical values of the conjugates of the elements of the integral
+basis.
+
+S< >S< >C<B<*>> C<MC> is essentially the conjugate of the transpose of C<M>,
+except that the last C<r2> columns are also multiplied by 2.
+
+S< >S< >C<B<*>> C<T2> is an C<n x n> matrix equal to the real part of the
+product C<MC.M> (which is a real positive definite symmetric matrix), the
+so-called C<T_2>-matrix (C<I<nf>.t2>).
+
+S< >S< >C<B<*>> C<T> is the C<n x n> matrix whose coefficients are
+C<Tr(F<omega>_iF<omega>_j)> where the C<F<omega>_i> are the elements of the
+integral basis. Note that C<T = \overline{MC}.M> and in particular that
+C<T = T_2> if the field is totally real (in practice C<T_2> will have real
+approximate entries and C<T> will have integer entries). Note also that
+C< F<det> (T)> is equal to the discriminant of the field C<K>.
+
+S< >S< >C<B<*>> The columns of C<MD> (C<I<nf>.diff>) express a B<I<Z>>-basis
+of the different of C<K> on the integral basis.
+
+S< >S< >C<B<*>> C<TI> is equal to C<d(K)T^{-1}>, which has integral
+coefficients. Note that, understood as as ideal, the matrix C<T^{-1}>
+generates the codifferent ideal.
+
+S< >S< >C<B<*>> Finally, C<MDI> is a two-element representation (for faster
+ideal product) of C<d(K)> times the codifferent ideal
+(C<I<nf>.disc*I<nf>.codiff>, which is an integral ideal). C<MDI>
+is only used in X<idealinv>C<idealinv>.
+
+C<I<nf>[6]> is the vector containing the C<r1+r2> roots
+(C<I<nf>.roots>) of C<I<nf>[1]> corresponding to the C<r1+r2>
+embeddings of the number field into B<I<C>> (the first C<r1> components are real,
+the next C<r2> have positive imaginary part).
+
+C<I<nf>[7]> is an integral basis in Hermite normal form for C<B<I<Z>>_K>
+(C<I<nf>.zk>) expressed on the powers ofS< >C<F<theta>>.
+
+C<I<nf>[8]> is the C<n x n> integral matrix expressing the power
+basis in terms of the integral basis, and finally
+
+C<I<nf>[9]> is the C<n x n^2> matrix giving the multiplication table
+of the integral basis.
+
+If a non monic polynomial is input, C<nfinit> will transform it into a
+monic one, then reduce it (see C<I<flag> = 3>). It is allowed, though not very
+useful given the existence of X<nfnewprec>B<nfnewprec>, to input a C<nf> or a
+C<bnf> instead of a polynomial.
+
+The special input format C<[x,B]> is also accepted where C<x> is a polynomial
+as above and C<B> is the integer basis, as computed by X<nfbasis>C<nfbasis>. This can
+be useful since C<nfinit> uses the round 4 algorithm by default, which can
+be very slow in pathological cases where round 2 (C<nfbasis(x,2)>) would
+succeed very quickly.
+
+If C<I<flag> = 2>: I<pol> is changed into another polynomial C<P> defining the same
+number field, which is as simple as can easily be found using the
+C<polred> algorithm, and all the subsequent computations are done using
+this new polynomial. In particular, the first component of the result is the
+modified polynomial.
+
+If C<I<flag> = 3>, does a C<polred> as in case 2, but outputs
+C<[I<nf>,Mod(a,P)]>, where C<I<nf>> is as before and
+C<Mod(a,P) = Mod(x,I<pol>)> gives the change of
+variables. This is implicit when I<pol> is not monic: first a linear change
+of variables is performed, to get a monic polynomial, then a C<polred>
+reduction.
+
+If C<I<flag> = 4>, as C<2> but uses a partial C<polred>.
+
+If C<I<flag> = 5>, as C<3> using a partial C<polred>.
+
+X<nfinit0>The library syntax is B<nfinit0>C<(x,I<flag>,I<prec>)>.
+
+=head2 X<nfisideal>nfisidealC<(I<nf>,x)>
+
+returns 1 if C<x> is an ideal in
+the number field C<I<nf>>, 0 otherwise.
+
+X<isideal>The library syntax is B<isideal>C<(x)>.
+
+=head2 X<nfisincl>nfisinclC<(x,y)>
+
+tests whether the number field C<K> defined
+by the polynomial C<x> is conjugate to a subfield of the field C<L> defined
+by C<y> (where C<x> and C<y> must be in C<B<I<Q>>[X]>). If they are not, the output
+is the number 0. If they are, the output is a vector of polynomials, each
+polynomial C<a> representing an embedding of C<K> into C<L>, i.e.S< >being such
+that C<y | x o a>.
+
+If C<y> is a number field (I<nf>), a much faster algorithm is used
+(factoring C<x> over C<y> using X<nffactor>C<nffactor>). Before version 2.0.14, this
+wasn't guaranteed to return all the embeddings, hence was triggered by a
+special flag. This is no more the case.
+
+X<nfisincl>The library syntax is B<nfisincl>C<(x,y,I<flag>)>.
+
+=head2 X<nfisisom>nfisisomC<(x,y)>
+
+as X<nfisincl>C<nfisincl>, but tests
+for isomorphism. If either C<x> or C<y> is a number field, a much faster
+algorithm will be used.
+
+X<nfisisom>The library syntax is B<nfisisom>C<(x,y,I<flag>)>.
+
+=head2 X<nfnewprec>nfnewprecC<(I<nf>)>
+
+transforms the number field C<I<nf>>
+into the corresponding data using current (usually larger) precision. This
+function works as expected if C<I<nf>> is in fact a C<I<bnf>> (update
+C<I<bnf>> to current precision) but may be quite slow (many generators of
+principal ideals have to be computed).
+
+X<nfnewprec>The library syntax is B<nfnewprec>C<(I<nf>,I<prec>)>.
+
+=head2 X<nfkermodpr>nfkermodprC<(I<nf>,a,I<pr>)>
+
+kernel of the matrix C<a> in
+C<B<I<Z>>_K/I<pr>>, where I<pr> is in B<modpr> format
+(see C<nfmodprinit>).
+
+X<nfkermodpr>The library syntax is B<nfkermodpr>C<(I<nf>,a,I<pr>)>.
+
+=head2 X<nfmodprinit>nfmodprinitC<(I<nf>,I<pr>)>
+
+transforms the prime ideal
+I<pr> into X<modpr>C<modpr> format necessary for all operations modulo
+I<pr> in the number field I<nf>. Returns a two-component vector
+C<[P,a]>, where C<P> is the X<Hermite normal form>Hermite normal form of I<pr>, and C<a> is
+an integral element congruent to C<1> modulo I<pr>, and congruent to C<0>
+modulo C<p / pr^e>. Here C<p = B<I<Z>> F<cap> I<pr>> and C<e>
+is the absolute ramification index.X<Label se:nfmodprinit>
+
+X<nfmodprinit>The library syntax is B<nfmodprinit>C<(I<nf>,I<pr>)>.
+
+=head2 X<nfsubfields>nfsubfieldsC<(I<nf>,{d = 0})>
+
+finds all subfields of degree C<d>
+of the number field C<I<nf>> (all subfields if C<d> is null or omitted).
+The result is a vector of subfields, each being given by C<[g,h]>, where C<g> is an
+absolute equation and C<h> expresses one of the roots of C<g> in terms of the
+root C<x> of the polynomial defining C<I<nf>>. This is a crude
+implementation by M.S< >Olivier of an algorithm due to J.S< >KlE<uuml>ners.
+
+X<subfields>The library syntax is B<subfields>C<(I<nf>,d)>.
+
+=head2 X<nfroots>nfrootsC<(I<nf>,x)>
+
+roots of the polynomial C<x> in the number
+field C<I<nf>> given by C<nfinit> without multiplicity. C<x> has
+coefficients in the number field (scalar, polmod, polynomial, column
+vector). The main variable of C<I<nf>> must be of lower priority than that
+of C<x> (in other words the variable number of C<I<nf>> must be greater than
+that of C<x>). However if the coefficients of the number field occur
+explicitly (as polmods) as coefficients of C<x>, the variable of these
+polmods I<must> be the same as the main variable of C<t> (see
+C<nffactor>).
+
+X<nfroots>The library syntax is B<nfroots>C<(I<nf>,x)>.
+
+=head2 X<nfrootsof1>nfrootsof1C<(I<nf>)>
+
+computes the number of roots of unity
+C<w> and a primitive C<w>-th root of unity (expressed on the integral basis)
+belonging to the number field C<I<nf>>. The result is a two-component
+vector C<[w,z]> where C<z> is a column vector expressing a primitive C<w>-th
+root of unity on the integral basis C<I<nf>.zk>.
+
+X<rootsof1>The library syntax is B<rootsof1>C<(I<nf>)>.
+
+=head2 X<nfsnf>nfsnfC<(I<nf>,x)>
+
+given a torsion module C<x> as a 3-component
+row
+vector C<[A,I,J]> where C<A> is a square invertible C<n x n> matrix, C<I> and
+C<J> are two ideal lists, outputs an ideal list C<d_1,...,d_n> which is the
+X<Smith normal form>Smith normal form of C<x>. In other words, C<x> is isomorphic to
+C<B<I<Z>>_K/d_1 F<oplus> ... F<oplus> B<I<Z>>_K/d_n> and C<d_i> divides C<d_{i-1}> for C<i E<gt>= 2>.
+The link between C<x> and C<[A,I,J]> is as follows: if C<e_i> is the canonical
+basis of C<K^n>, C<I = [b_1,...,b_n]> and C<J = [a_1,...,a_n]>, then C<x> is
+isomorphic to
+
+S< >C< (b_1e_1 F<oplus> ... F<oplus> b_ne_n) / (a_1A_1 F<oplus> ... F<oplus> a_nA_n)
+ , >
+
+where the C<A_j> are the columns of the matrix C<A>. Note that every finitely
+generated torsion module can be given in this way, and even with C<b_i = Z_K>
+for all C<i>.
+
+X<nfsmith>The library syntax is B<nfsmith>C<(I<nf>,x)>.
+
+=head2 X<nfsolvemodpr>nfsolvemodprC<(I<nf>,a,b,I<pr>)>
+
+solution of C<a.x = b>
+in C<B<I<Z>>_K/I<pr>>, where C<a> is a matrix and C<b> a column vector, and where
+I<pr> is in B<modpr> format (see C<nfmodprinit>).
+
+X<nfsolvemodpr>The library syntax is B<nfsolvemodpr>C<(I<nf>,a,b,I<pr>)>.
+
+=head2 X<polcompositum>polcompositumC<(x,y,{I<flag> = 0})>
+
+C<x> and C<y> being polynomials
+in C<B<I<Z>>[X]> in the same variable, outputs a vector giving the list of all
+possible composita of the number fields defined by C<x> and C<y>, if C<x> and
+C<y> are irreducible, or of the corresponding E<eacute>tale algebras, if they are
+only squarefree. Returns an error if one of the polynomials is not
+squarefree. When one of the polynomials is irreducible (say C<x>), it is
+often I<much> faster to use C<nffactor(nfinit(x), y)> then
+X<rnfequation>C<rnfequation>.
+
+If C<I<flag> = 1>, outputs a vector of 4-component vectors C<[z,a,b,k]>, where C<z>
+ranges through the list of all possible compositums as above, and C<a>
+(resp. C<b>) expresses the root of C<x> (resp. C<y>) as a polmod in a root of
+C<z>, and C<k> is a small integer k such that C<a+kb> is the chosen root of
+C<z>.
+
+The compositum will quite often be defined by a complicated polynomial,
+which it is advisable to reduce before further work. Here is a simple
+example involving the field C<B<I<Q>>(F<zeta>_5, 5^{1/5})>:
+
+ ? z = polcompositum(x^5 - 5, polcyclo(5), 1)[1];
+ ? pol = z[1] \\ pol defines the compositum
+ %2 = x^20 + 5*x^19 + 15*x^18 + 35*x^17 + 70*x^16 + 141*x^15 + 260*x^14 \
+ + 355*x^13 + 95*x^12 - 1460*x^11 - 3279*x^10 - 3660*x^9 - 2005*x^8 \
+ + 705*x^7 + 9210*x^6 + 13506*x^5 + 7145*x^4 - 2740*x^3 + 1040*x^2 \
+ - 320*x + 256
+ ? a = z[2]; a^5 - 5 \\ a is a fifth root of 5
+ %3 = 0
+ ? z = polredabs(pol, 1); \\ look for a simpler polynomial
+ ? pol = z[1]
+ %5 = x^20 + 25*x^10 + 5
+ ? a = subst(a.pol, x, z[2]) \\ a in the new coordinates
+ %6 = Mod(-5/22*x^19 + 1/22*x^14 - 123/22*x^9 + 9/11*x^4, x^20 + 25*x^10 + 5)
+
+X<polcompositum0>The library syntax is B<polcompositum0>C<(x,y,I<flag>)>.
+
+=head2 X<polgalois>polgaloisC<(x)>
+
+X<Galois>Galois group of the non-constant polynomial
+C<x belongs to B<I<Q>>[X]>. In the present version B<2.2.0>, C<x> must be irreducible and
+the degree of C<x> must be less than or equal to 7. On certain versions for
+which the data file of Galois resolvents has been installed (available
+in the Unix distribution as a separate package), degrees 8, 9, 10 and 11
+are also implemented.
+
+The output is a 3-component vector C<[n,s,k]> with the following meaning: C<n>
+is the cardinality of the group, C<s> is its signature (C<s = 1> if the group is
+a subgroup of the alternating group C<A_n>, C<s = -1> otherwise), and C<k> is the
+number of the group corresponding to a given pair C<(n,s)> (C<k = 1> except in 2
+cases). Specifically, the groups are coded as follows, using standard
+notations (see GTM 138, quoted at the beginning of this section; see also
+``The transitive groups of degree up to eleven'', by G.S< >Butler and J.S< >McKay
+in Communications in Algebra, vol.S< >11, 1983, pp.S< >863--911):
+
+In degree 1: C<S_1 = [1,-1,1]>.
+
+In degree 2: C<S_2 = [2,-1,1]>.
+
+In degree 3: C<A_3 = C_3 = [3,1,1]>, C<S_3 = [6,-1,1]>.
+
+In degree 4: C<C_4 = [4,-1,1]>, C<V_4 = [4,1,1]>, C<D_4 = [8,-1,1]>, C<A_4 = [12,1,1]>,
+C<S_4 = [24,-1,1]>.
+
+In degree 5: C<C_5 = [5,1,1]>, C<D_5 = [10,1,1]>, C<M_{20} = [20,-1,1]>,
+C<A_5 = [60,1,1]>, C<S_5 = [120,-1,1]>.
+
+In degree 6: C<C_6 = [6,-1,1]>, C<S_3 = [6,-1,2]>, C<D_6 = [12,-1,1]>, C<A_4 = [12,1,1]>,
+C<G_{18} = [18,-1,1]>, C<S_4^ -= [24,-1,1]>, C<A_4 x C_2 = [24,-1,2]>,
+C<S_4^ += [24,1,1]>, C<G_{36}^ -= [36,-1,1]>, C<G_{36}^ += [36,1,1]>,
+C<S_4 x C_2 = [48,-1,1]>, C<A_5 = PSL_2(5) = [60,1,1]>, C<G_{72} = [72,-1,1]>,
+C<S_5 = PGL_2(5) = [120,-1,1]>, C<A_6 = [360,1,1]>, C<S_6 = [720,-1,1]>.
+
+In degree 7: C<C_7 = [7,1,1]>, C<D_7 = [14,-1,1]>, C<M_{21} = [21,1,1]>,
+C<M_{42} = [42,-1,1]>, C<PSL_2(7) = PSL_3(2) = [168,1,1]>, C<A_7 = [2520,1,1]>,
+C<S_7 = [5040,-1,1]>.
+
+The method used is that of resolvent polynomials and is sensitive to the
+current precision. The precision is updated internally but, in very rare
+cases, a wrong result may be returned if the initial precision was not
+sufficient.
+
+X<galois>The library syntax is B<galois>C<(x,I<prec>)>.
+
+=head2 X<polred>polredC<(x,{I<flag> = 0},{p})>
+
+finds polynomials with reasonably
+small coefficients defining subfields of the number field defined by C<x>.
+One of the polynomials always defines B<I<Q>> (hence is equal to C<x-1>),
+and another always defines the same number field as C<x> if C<x> is irreducible.
+All C<x> accepted by X<nfinit>C<nfinit> are also allowed here (e.g. non-monic
+polynomials, C<nf>, C<bnf>, C<[x,Z_K_basis]>).
+
+The following binary digits of C<I<flag>> are significant:
+
+1: does a partial reduction only. This means that only a suborder of the
+maximal order may be used.
+
+2: gives also elements. The result is a two-column matrix, the first column
+giving the elements defining these subfields, the second giving the
+corresponding minimal polynomials.
+
+If C<p> is given, it is assumed that it is the two-column matrix of the
+factorization of the discriminant of the polynomial C<x>.
+
+X<polred0>The library syntax is B<polred0>C<(x,I<flag>,p,I<prec>)>, where an omitted C<p> is
+coded by C<gzero>. Also available are C<X<polred>B<polred>(x,I<prec>)> and
+C<X<factoredpolred>B<factoredpolred>(x,p,I<prec>)>, both corresponding to C<I<flag> = 0>.
+
+=head2 X<polredabs>polredabsC<(x,{I<flag> = 0})>
+
+finds one of the polynomial defining
+the same number field as the one defined by C<x>, and such that the sum of the
+squares of the modulus of the roots (i.e.S< >the C<T_2>-norm) is minimal.
+All C<x> accepted by X<nfinit>C<nfinit> are also allowed here (e.g. non-monic
+polynomials, C<nf>, C<bnf>, C<[x,Z_K_basis]>).
+
+The binary digits of C<I<flag>> mean
+
+1: outputs a two-component row vector C<[P,a]>, where C<P> is the default
+output and C<a> is an element expressed on a root of the polynomial C<P>,
+whose minimal polynomial is equal to C<x>.
+
+4: gives I<all> polynomials of minimal C<T_2> norm (of the two polynomials
+C<P(x)> and C<P(-x)>, only one is given).
+
+X<polredabs0>The library syntax is B<polredabs0>C<(x,I<flag>,I<prec>)>.
+
+=head2 X<polredord>polredordC<(x)>
+
+finds polynomials with reasonably small
+coefficients and of the same degree as that of C<x> defining suborders of the
+order defined by C<x>. One of the polynomials always defines B<I<Q>> (hence
+is equal to C<(x-1)^n>, where C<n> is the degree), and another always defines
+the same order as C<x> if C<x> is irreducible.
+
+X<ordred>The library syntax is B<ordred>C<(x)>.
+
+=head2 X<poltschirnhaus>poltschirnhausC<(x)>
+
+applies a random Tschirnhausen
+transformation to the polynomial C<x>, which is assumed to be non-constant
+and separable, so as to obtain a new equation for the E<eacute>tale algebra
+defined by C<x>. This is for instance useful when computing resolvents,
+hence is used by the C<polgalois> function.
+
+X<tschirnhaus>The library syntax is B<tschirnhaus>C<(x)>.
+
+=head2 X<rnfalgtobasis>rnfalgtobasisC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<L> expressed as a polynomial or polmod with polmod coefficients, expresses
+C<x> on the relative integral basis.
+
+X<rnfalgtobasis>The library syntax is B<rnfalgtobasis>C<(I<rnf>,x)>.
+
+=head2 X<rnfbasis>rnfbasisC<(I<bnf>,x)>
+
+given a big number field C<I<bnf>> as
+output by C<bnfinit>, and either a polynomial C<x> with coefficients in
+C<I<bnf>> defining a relative extension C<L> of C<I<bnf>>, or a
+pseudo-basis C<x> of such an extension, gives either a true C<I<bnf>>-basis
+of C<L> if it exists, or an C<n+1>-element generating set of C<L> if not, where
+C<n> is the rank of C<L> over C<I<bnf>>.
+
+X<rnfbasis>The library syntax is B<rnfbasis>C<(I<bnf>,x)>.
+
+=head2 X<rnfbasistoalg>rnfbasistoalgC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<L> expressed on the relative integral basis, computes the representation of
+C<x> as a polmod with polmods coefficients.
+
+X<rnfbasistoalg>The library syntax is B<rnfbasistoalg>C<(I<rnf>,x)>.
+
+=head2 X<rnfcharpoly>rnfcharpolyC<(I<nf>,T,a,{v = x})>
+
+characteristic polynomial of
+C<a> over C<I<nf>>, where C<a> belongs to the algebra defined by C<T> over
+C<I<nf>>, i.e.S< >C<I<nf>[X]/(T)>. Returns a polynomial in variable C<v>
+(C<x> by default).
+
+X<rnfcharpoly>The library syntax is B<rnfcharpoly>C<(I<nf>,T,a,v)>, where C<v> is a variable number.
+
+=head2 X<rnfconductor>rnfconductorC<(I<bnf>,I<pol>)>
+
+C<I<bnf>> being a big number
+field as output by C<bnfinit>, and I<pol> a relative polynomial defining
+an X<Abelian extension>Abelian extension, computes the class field theory conductor of this
+Abelian extension. The result is a 3-component vector
+C<[I<conductor>,I<rayclgp>,I<subgroup>]>, where I<conductor> is
+the conductor of the extension given as a 2-component row vector
+C<[f_0,f_ oo ]>, I<rayclgp> is the full ray class group corresponding to
+the conductor given as a 3-component vector [h,cyc,gen] as usual for a group,
+and I<subgroup> is a matrix in HNF defining the subgroup of the ray class
+group on the given generators gen.
+
+X<rnfconductor>The library syntax is B<rnfconductor>C<(I<rnf>,I<pol>,I<prec>)>.
+
+=head2 X<rnfdedekind>rnfdedekindC<(I<nf>,I<pol>,I<pr>)>
+
+given a number field
+C<I<nf>> as output by C<nfinit> and a polynomial I<pol> with
+coefficients in C<I<nf>> defining a relative extension C<L> of C<I<nf>>,
+evaluates the relative X<Dedekind>Dedekind criterion over the order defined by a
+root of I<pol> for the prime ideal I<pr> and outputs a 3-component
+vector as the result. The first component is a flag equal to 1 if the
+enlarged order could be proven to be I<pr>-maximal and to 0 otherwise (it
+may be maximal in the latter case if I<pr> is ramified in C<L>), the second
+component is a pseudo-basis of the enlarged order and the third component is
+the valuation at I<pr> of the order discriminant.
+
+X<rnfdedekind>The library syntax is B<rnfdedekind>C<(I<nf>,I<pol>,I<pr>)>.
+
+=head2 X<rnfdet>rnfdetC<(I<nf>,M)>
+
+given a pseudomatrix C<M> over the maximal
+order of C<I<nf>>, computes its pseudodeterminant.
+
+X<rnfdet>The library syntax is B<rnfdet>C<(I<nf>,M)>.
+
+=head2 X<rnfdisc>rnfdiscC<(I<nf>,I<pol>)>
+
+given a number field C<I<nf>> as
+output by C<nfinit> and a polynomial I<pol> with coefficients in
+C<I<nf>> defining a relative extension C<L> of C<I<nf>>, computes
+the relative
+discriminant of C<L>. This is a two-element row vector C<[D,d]>, where C<D> is
+the relative ideal discriminant and C<d> is the relative discriminant
+considered as an element of C<I<nf>^*/{I<nf>^*}^2>. The main variable of
+C<I<nf>> I<must> be of lower priority than that of I<pol>.
+
+Note: As usual, C<I<nf>> can be a C<I<bnf>> as output by C<nfinit>.
+
+X<rnfdiscf>The library syntax is B<rnfdiscf>C<(I<bnf>,I<pol>)>.
+
+=head2 X<rnfeltabstorel>rnfeltabstorelC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being an element of C<L>
+expressed as a polynomial modulo the absolute equation C<I<rnf>[11][1]>,
+computes C<x> as an element of the relative extension C<L/K> as a polmod with
+polmod coefficients.
+
+X<rnfelementabstorel>The library syntax is B<rnfelementabstorel>C<(I<rnf>,x)>.
+
+=head2 X<rnfeltdown>rnfeltdownC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<L> expressed as a polynomial or polmod with polmod coefficients, computes
+C<x> as an element of C<K> as a polmod, assuming C<x> is in C<K> (otherwise an
+error will occur). If C<x> is given on the relative integral basis, apply
+C<rnfbasistoalg> first, otherwise PARI will believe you are dealing with a
+vector.
+
+X<rnfelementdown>The library syntax is B<rnfelementdown>C<(I<rnf>,x)>.
+
+=head2 X<rnfeltreltoabs>rnfeltreltoabsC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative
+number field extension C<L/K> as output by C<rnfinit> and C<x> being an
+element of C<L> expressed as a polynomial or polmod with polmod
+coefficients, computes C<x> as an element of the absolute extension C<L/B<I<Q>>> as
+a polynomial modulo the absolute equation C<I<rnf>[11][1]>. If C<x> is
+given on the relative integral basis, apply C<rnfbasistoalg> first,
+otherwise PARI will believe you are dealing with a vector.
+
+X<rnfelementreltoabs>The library syntax is B<rnfelementreltoabs>C<(I<rnf>,x)>.
+
+=head2 X<rnfeltup>rnfeltupC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an element of
+C<K> expressed as a polynomial or polmod, computes C<x> as an element of the
+absolute extension C<L/B<I<Q>>> as a polynomial modulo the absolute equation
+C<I<rnf>[11][1]>. Note that it is unnecessary to compute C<x> as an
+element of the relative extension C<L/K> (its expression would be identical to
+itself). If C<x> is given on the integral basis of C<K>, apply
+C<nfbasistoalg> first, otherwise PARI will believe you are dealing with a
+vector.
+
+X<rnfelementup>The library syntax is B<rnfelementup>C<(I<rnf>,x)>.
+
+=head2 X<rnfequation>rnfequationC<(I<nf>,I<pol>,{I<flag> = 0})>
+
+given a number field
+C<I<nf>> as output by C<nfinit> (or simply a polynomial) and a
+polynomial I<pol> with coefficients in C<I<nf>> defining a relative
+extension C<L> of C<I<nf>>, computes the absolute equation of C<L> over
+B<I<Q>>.
+
+If C<I<flag>> is non-zero, outputs a 3-component row vector C<[z,a,k]>, where
+C<z> is the absolute equation of C<L> over B<I<Q>>, as in the default behaviour,
+C<a> expresses as an element of C<L> a root C<F<alpha>> of the polynomial
+defining the base field C<I<nf>>, and C<k> is a small integer such that
+C<F<theta> = F<beta>+kF<alpha>> where C<F<theta>> is a root of C<z> and C<F<beta>> a root
+of C<I<pol>>.
+
+The main variable of C<I<nf>> I<must> be of lower priority than that
+of I<pol>. Note that for efficiency, this does not check whether the
+relative equation is irreducible over C<I<nf>>, but only if it is
+squarefree. If it is reducible but squarefree, the result will be the
+absolute equation of the E<eacute>tale algebra defined by I<pol>. If I<pol>
+is not squarefree, an error message will be issued.
+
+X<rnfequation0>The library syntax is B<rnfequation0>C<(I<nf>,I<pol>,I<flag>)>.
+
+=head2 X<rnfhnfbasis>rnfhnfbasisC<(I<bnf>,x)>
+
+given a big number field C<I<bnf>>
+as output by C<bnfinit>, and either a polynomial C<x> with coefficients in
+C<I<bnf>> defining a relative extension C<L> of C<I<bnf>>, or a
+pseudo-basis C<x> of such an extension, gives either a true C<I<bnf>>-basis
+of C<L> in upper triangular Hermite normal form, if it exists,
+zero otherwise.
+
+X<rnfhermitebasis>The library syntax is B<rnfhermitebasis>C<(I<nf>,x)>.
+
+=head2 X<rnfidealabstorel>rnfidealabstorelC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative
+number field extension C<L/K> as output by C<rnfinit> and C<x> being an
+ideal of the absolute extension C<L/B<I<Q>>> given in HNFX<Hermite normal form>
+(if it is not, apply C<idealhnf> first), computes the relative pseudomatrix
+in HNF giving the ideal C<x> considered as an ideal of the relative extension
+C<L/K>.
+
+X<rnfidealabstorel>The library syntax is B<rnfidealabstorel>C<(I<rnf>,x)>.
+
+=head2 X<rnfidealdown>rnfidealdownC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being an ideal of
+the absolute extension C<L/B<I<Q>>> given in HNF (if it is not, apply
+C<idealhnf> first), gives the ideal of C<K> below C<x>, i.e.S< >the
+intersection of C<x> with C<K>. Note that, if C<x> is given as a relative ideal
+(i.e.S< >a pseudomatrix in HNF), then it is not necessary to use this function
+since the result is simply the first ideal of the ideal list of the
+pseudomatrix.
+
+X<rnfidealdown>The library syntax is B<rnfidealdown>C<(I<rnf>,x)>.
+
+=head2 X<rnfidealhnf>rnfidealhnfC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> being a relative
+ideal (which can be, as in the absolute case, of many different types,
+including of course elements), computes as a 2-component row vector the
+relative Hermite normal form of C<x>, the first component being the HNF matrix
+(with entries on the integral basis), and the second component the ideals.
+
+X<rnfidealhermite>The library syntax is B<rnfidealhermite>C<(I<rnf>,x)>.
+
+=head2 X<rnfidealmul>rnfidealmulC<(I<rnf>,x,y)>
+
+C<I<rnf>> being a relative number
+field extension C<L/K> as output by C<rnfinit> and C<x> and C<y> being ideals
+of the relative extension C<L/K> given by pseudo-matrices, outputs the ideal
+product, again as a relative ideal.
+
+X<rnfidealmul>The library syntax is B<rnfidealmul>C<(I<rnf>,x,y)>.
+
+=head2 X<rnfidealnormabs>rnfidealnormabsC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative
+number field extension C<L/K> as output by C<rnfinit> and C<x> being a
+relative ideal (which can be, as in the absolute case, of many different
+types, including of course elements), computes the norm of the ideal C<x>
+considered as an ideal of the absolute extension C<L/B<I<Q>>>. This is identical to
+C<idealnorm(rnfidealnormrel(I<rnf>,x))>, only faster.
+
+X<rnfidealnormabs>The library syntax is B<rnfidealnormabs>C<(I<rnf>,x)>.
+
+=head2 X<rnfidealnormrel>rnfidealnormrelC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being a relative ideal
+(which can be, as in the absolute case, of many different types, including
+of course elements), computes the relative norm of C<x> as a ideal of C<K>
+in HNF.
+
+X<rnfidealnormrel>The library syntax is B<rnfidealnormrel>C<(I<rnf>,x)>.
+
+=head2 X<rnfidealreltoabs>rnfidealreltoabsC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being a relative ideal
+(which can be, as in the absolute case, of many different types, including
+of course elements), computes the HNF matrix of the ideal C<x> considered
+as an ideal of the absolute extension C<L/B<I<Q>>>.
+
+X<rnfidealreltoabs>The library syntax is B<rnfidealreltoabs>C<(I<rnf>,x)>.
+
+=head2 X<rnfidealtwoelt>rnfidealtwoeltC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative
+number field
+extension C<L/K> as output by C<rnfinit> and C<x> being an ideal of the
+relative extension C<L/K> given by a pseudo-matrix, gives a vector of
+two generators of C<x> over C<B<I<Z>>_L> expressed as polmods with polmod
+coefficients.
+
+X<rnfidealtwoelement>The library syntax is B<rnfidealtwoelement>C<(I<rnf>,x)>.
+
+=head2 X<rnfidealup>rnfidealupC<(I<rnf>,x)>
+
+C<I<rnf>> being a relative number
+field
+extension C<L/K> as output by C<rnfinit> and C<x> being an ideal of
+C<K>, gives the ideal C<xB<I<Z>>_L> as an absolute ideal of C<L/B<I<Q>>> (the relative
+ideal representation is trivial: the matrix is the identity matrix, and
+the ideal list starts with C<x>, all the other ideals being C<B<I<Z>>_K>).
+
+X<rnfidealup>The library syntax is B<rnfidealup>C<(I<rnf>,x)>.
+
+=head2 X<rnfinit>rnfinitC<(I<nf>,I<pol>)>
+
+C<I<nf>> being a number field in
+C<nfinit>
+format considered as base field, and I<pol> a polynomial defining a relative
+extension over C<I<nf>>, this computes all the necessary data to work in the
+relative extension. The main variable of I<pol> must be of higher priority
+(i.e.S< >lower number) than that of C<I<nf>>, and the coefficients of I<pol>
+must be in C<I<nf>>.
+
+The result is an 11-component row vector as follows (most of the components
+are technical), the numbering being very close to that of C<nfinit>. In
+the following description, we let C<K> be the base field defined by
+C<I<nf>>, C<m> the degree of the base field, C<n> the relative degree, C<L>
+the large field (of relative degree C<n> or absolute degree C<nm>), C<r_1> and
+C<r_2> the number of real and complex places of C<K>.
+
+C<I<rnf>[1]> contains the relative polynomial I<pol>.
+
+C<I<rnf>[2]> is a row vector with C<r_1+r_2> entries, entry C<j> being
+a 2-component row vector C<[r_{j,1},r_{j,2}]> where C<r_{j,1}> and C<r_{j,2}>
+are the number of real and complex places of C<L> above the C<j>-th place of
+C<K> so that C<r_{j,1} = 0> and C<r_{j,2} = n> if C<j> is a complex place, while if
+C<j> is a real place we have C<r_{j,1}+2r_{j,2} = n>.
+
+C<I<rnf>[3]> is a two-component row vector C<[B<I<d>>(L/K),s]> where C<B<I<d>>(L/K)>
+is the relative ideal discriminant of C<L/K> and C<s> is the discriminant of
+C<L/K> viewed as an element of C<K^*/(K^*)^2>, in other words it is the output
+of C<rnfdisc>.
+
+C<I<rnf>[4]> is the ideal index C<B<I<f>>>, i.e.S< >such that
+C<d(pol)B<I<Z>>_K = B<I<f>>^2B<I<d>>(L/K)>.
+
+C<I<rnf>[5]> is a vector I<vm> with 7 entries useful for certain
+computations in the relative extension C<L/K>. C<I<vm>[1]> is a vector of
+C<r_1+r_2> matrices, the C<j>-th matrix being an C<(r_{1,j}+r_{2,j}) x n>
+matrix C<M_j> representing the numerical values of the conjugates of the
+C<j>-th embedding of the elements of the integral basis, where C<r_{i,j}> is as
+in C<I<rnf>[2]>. C<I<vm>[2]> is a vector of C<r_1+r_2> matrices, the
+C<j>-th matrix C<MC_j> being essentially the conjugate of the matrix C<M_j>
+except that the last C<r_{2,j}> columns are also multiplied by 2.
+C<I<vm>[3]> is a vector of C<r_1+r_2> matrices C<T2_j>, where C<T2_j> is
+an C<n x n> matrix equal to the real part of the product C<MC_j.M_j>
+(which is a real positive definite matrix). C<I<vm>[4]> is the C<n x n>
+matrix C<T> whose entries are the relative traces of C<F<omega>_iF<omega>_j>
+expressed as polmods in C<I<nf>>, where the C<F<omega>_i> are the elements
+of the relative integral basis. Note that the C<j>-th embedding of C<T> is
+equal to C<\overline{MC_j}.M_j>, and in particular will be equal to
+C<T2_j> if C<r_{2,j} = 0>. Note also that the relative ideal discriminant of
+C<L/K> is equal to C< F<det> (T)> times the square of the product of the ideals
+in the relative pseudo-basis (in C<I<rnf>[7][2]>). The last 3 entries
+C<I<vm>[5]>, C<I<vm>[6]> and C<I<vm>[7]> are linked to the different
+as in C<nfinit>, but have not yet been implemented.
+
+C<I<rnf>[6]> is a row vector with C<r_1+r_2> entries, the C<j>-th entry
+being the
+row vector with C<r_{1,j}+r_{2,j}> entries of the roots of the C<j>-th embedding
+of the relative polynomial I<pol>.
+
+C<I<rnf>[7]> is a two-component row vector, where the first component is
+the relative integral pseudo basis expressed as polynomials (in the variable of
+C<pol>) with polmod coefficients in C<I<nf>>, and the second component is the
+ideal list of the pseudobasis in HNF.
+
+C<I<rnf>[8]> is the inverse matrix of the integral basis matrix, with
+coefficients polmods in C<I<nf>>.
+
+C<I<rnf>[9]> may be the multiplication table of the integral basis, but
+is not implemented at present.
+
+C<I<rnf>[10]> is C<I<nf>>.
+
+C<I<rnf>[11]> is a vector I<vabs> with 5 entries describing the
+I<absolute> extension C<L/B<I<Q>>>. C<I<vabs>[1]> is an absolute equation.
+C<I<vabs>[2]> expresses the generator C<F<alpha>> of the number field
+C<I<nf>> as a polynomial modulo the absolute equation C<I<vabs>[1]>.
+C<I<vabs>[3]> is a small integer C<k> such that, if C<F<beta>> is an abstract
+root of I<pol> and C<F<alpha>> the generator of C<I<nf>>, the generator
+whose root is I<vabs> will be C<F<beta> + k F<alpha>>. Note that one must
+be very careful if C<k ! = 0> when dealing simultaneously with absolute and
+relative quantities since the generator chosen for the absolute extension
+is not the same as for the relative one. If this happens, one can of course
+go on working, but we strongly advise to change the relative polynomial so
+that its root will be C<F<beta> + k F<alpha>>. Typically, the GP instruction would
+be
+
+C<pol = subst(pol, x, x - k*Mod(y,I<nf>.pol))>
+
+Finally, C<I<vabs>[4]> is the absolute integral basis of C<L> expressed in HNF
+(hence as would be output by C<nfinit(vabs[1])>), and C<I<vabs>[5]> the
+inverse matrix of the integral basis, allowing to go from polmod to integral
+basis representation.
+
+X<rnfinitalg>The library syntax is B<rnfinitalg>C<(I<nf>,I<pol>,I<prec>)>.
+
+=head2 X<rnfisfree>rnfisfreeC<(I<bnf>,x)>
+
+given a big number field C<I<bnf>> as
+output by C<bnfinit>, and either a polynomial C<x> with coefficients in
+C<I<bnf>> defining a relative extension C<L> of C<I<bnf>>, or a
+pseudo-basis C<x> of such an extension, returns true (1) if C<L/I<bnf>> is
+free, false (0) if not.
+
+X<rnfisfree>The library syntax is B<rnfisfree>C<(I<bnf>,x)>, and the result is a C<long>.
+
+=head2 X<rnfisnorm>rnfisnormC<(I<bnf>,I<ext>,I<el>,{I<flag> = 1})>
+
+similar to
+C<bnfisnorm> but in the relative case. This tries to decide whether the
+element I<el> in I<bnf> is the norm of some C<y> in I<ext>.
+C<I<bnf>> is as output by C<bnfinit>.
+
+C<I<ext>> is a relative extension which has to be a row vector whose
+components are:
+
+C<I<ext>[1]>: a relative equation of the number field I<ext> over
+I<bnf>. As usual, the priority of the variable of the polynomial
+defining the ground field I<bnf> (say C<y>) must be lower than the
+main variable of C<I<ext>[1]>, say C<x>.
+
+C<I<ext>[2]>: the generator C<y> of the base field as a polynomial in C<x> (as
+given by C<rnfequation> with C<I<flag> = 1>).
+
+C<I<ext>[3]>: is the C<bnfinit> of the absolute extension C<I<ext>/B<I<Q>>>.
+
+This returns a vector C<[a,b]>, where C<I<el> = I<Norm>(a)*b>. It looks for a
+solution which is an C<S>-integer, with C<S> a list of places (of I<bnf>)
+containing the ramified primes, the generators of the class group of
+I<ext>, as well as those primes dividing I<el>. If C<I<ext>/I<bnf>>
+is known to be X<Galois>Galois, set C<I<flag> = 0> (here I<el> is a norm iff C<b = 1>).
+If C<I<flag>> is non zero add to C<S> all the places above the primes which: divide
+C<I<flag>> if C<I<flag> E<lt> 0>, or are less than C<I<flag>> if C<I<flag> E<gt> 0>. The answer is guaranteed
+(i.e.S< >I<el> is a norm iff C<b = 1>) under X<GRH>GRH, if C<S> contains all
+primes less than C<12 F<log> ^2|disc(I<Ext>)|>, where
+I<Ext> is the normal closure of C<I<ext> / I<bnf>>. Example:
+
+ bnf = bnfinit(y^3 + y^2 - 2*y - 1);
+ p = x^2 + Mod(y^2 + 2*y + 1, bnf.pol);
+ rnf = rnfequation(bnf,p,1);
+ ext = [p, rnf[2], bnfinit(rnf[1])];
+ rnfisnorm(bnf,ext,17, 1)
+
+checks whether C<17> is a norm in the Galois extension C<B<I<Q>>(F<beta>) /
+B<I<Q>>(F<alpha>)>, where C<F<alpha>^3 + F<alpha>^2 - 2F<alpha> - 1 = 0> and C<F<beta>^2 +
+F<alpha>^2 + 2*F<alpha> + 1 = 0> (it is).
+
+X<rnfisnorm>The library syntax is B<rnfisnorm>C<(I<bnf>,ext,x,I<flag>,I<prec>)>.
+
+=head2 X<rnfkummer>rnfkummerC<(I<bnr>,I<subgroup>,{deg = 0})>
+
+I<bnr>
+being as output by C<bnrinit>, finds a relative equation for the
+class field corresponding to the module in I<bnr> and the given
+congruence subgroup. If I<deg> is positive, outputs the list of all
+relative equations of degree I<deg> contained in the ray class field
+defined by I<bnr>.
+
+(THIS PROGRAM IS STILL IN DEVELOPMENT STAGE)
+
+X<rnfkummer>The library syntax is B<rnfkummer>C<(I<bnr>,I<subgroup>,I<deg>,I<prec>)>,
+where I<deg> is a C<long>.
+
+=head2 X<rnflllgram>rnflllgramC<(I<nf>,I<pol>,I<order>)>
+
+given a polynomial
+I<pol> with coefficients in I<nf> and an order I<order> as output
+by C<rnfpseudobasis> or similar, gives C<[[I<neworder>],U]>, where
+I<neworder> is a reduced order and C<U> is the unimodular transformation
+matrix.
+
+X<rnflllgram>The library syntax is B<rnflllgram>C<(I<nf>,I<pol>,I<order>,I<prec>)>.
+
+=head2 X<rnfnormgroup>rnfnormgroupC<(I<bnr>,I<pol>)>
+
+I<bnr> being a big ray
+class field as output by C<bnrinit> and I<pol> a relative polynomial
+defining an X<Abelian extension>Abelian extension, computes the norm group (alias Artin
+or Takagi group) corresponding to the Abelian extension of C<I<bnf> = bnr[1]>
+defined by I<pol>, where the module corresponding to I<bnr> is assumed
+to be a multiple of the conductor (i.e.S< >polrel defines a subextension of
+bnr). The result is the HNF defining the norm group on the given generators
+of C<I<bnr>[5][3]>. Note that neither the fact that I<pol> defines an
+Abelian extension nor the fact that the module is a multiple of the conductor
+is checked. The result is undefined if the assumption is not correct.
+
+X<rnfnormgroup>The library syntax is B<rnfnormgroup>C<(I<bnr>,I<pol>)>.
+
+=head2 X<rnfpolred>rnfpolredC<(I<nf>,I<pol>)>
+
+relative version of C<polred>.
+Given a monic polynomial I<pol> with coefficients in C<I<nf>>, finds a
+list of relative polynomials defining some subfields, hopefully simpler and
+containing the original field. In the present version B<2.2.0>, this is slower
+than C<rnfpolredabs>.
+
+X<rnfpolred>The library syntax is B<rnfpolred>C<(I<nf>,I<pol>,I<prec>)>.
+
+=head2 X<rnfpolredabs>rnfpolredabsC<(I<nf>,I<pol>,{I<flag> = 0})>
+
+relative version of
+C<polredabs>. Given a monic polynomial I<pol> with coefficients in
+C<I<nf>>, finds a simpler relative polynomial defining the same field. If
+C<I<flag> = 1>, returns C<[P,a]> where C<P> is the default output and C<a> is an
+element expressed on a root of C<P> whose characteristic polynomial is
+I<pol>, if C<I<flag> = 2>, returns an absolute polynomial (same as
+
+C<rnfequation(I<nf>,rnfpolredabs(I<nf>,I<pol>))>
+
+but faster).
+
+B<Remark.> In the present implementation, this is both faster and
+much more efficient than C<rnfpolred>, the difference being more
+dramatic than in the absolute case. This is because the implementation of
+C<rnfpolred> is based on (a partial implementation of) an incomplete
+reduction theory of lattices over number fields (i.e.S< >the function
+C<rnflllgram>) which deserves to be improved.
+
+X<rnfpolredabs>The library syntax is B<rnfpolredabs>C<(I<nf>,I<pol>,I<flag>,I<prec>)>.
+
+=head2 X<rnfpseudobasis>rnfpseudobasisC<(I<nf>,I<pol>)>
+
+given a number field
+C<I<nf>> as output by C<nfinit> and a polynomial I<pol> with
+coefficients in C<I<nf>> defining a relative extension C<L> of C<I<nf>>,
+computes a pseudo-basis C<(A,I)> and the relative discriminant of C<L>.
+This is output as
+a four-element row vector C<[A,I,D,d]>, where C<D> is the relative ideal
+discriminant and C<d> is the relative discriminant considered as an element of
+C<I<nf>^*/{I<nf>^*}^2>.
+
+Note: As usual, C<I<nf>> can be a C<I<bnf>> as output by C<bnfinit>.
+
+X<rnfpseudobasis>The library syntax is B<rnfpseudobasis>C<(I<nf>,I<pol>)>.
+
+=head2 X<rnfsteinitz>rnfsteinitzC<(I<nf>,x)>
+
+given a number field C<I<nf>> as
+output by C<nfinit> and either a polynomial C<x> with coefficients in
+C<I<nf>> defining a relative extension C<L> of C<I<nf>>, or a pseudo-basis
+C<x> of such an extension as output for example by C<rnfpseudobasis>,
+computes another pseudo-basis C<(A,I)> (not in HNF in general) such that all
+the ideals of C<I> except perhaps the last one are equal to the ring of
+integers of C<I<nf>>, and outputs the four-component row vector C<[A,I,D,d]>
+as in C<rnfpseudobasis>. The name of this function comes from the fact
+that the ideal class of the last ideal of C<I> (which is well defined) is
+called the X<Steinitz class>I<Steinitz class> of the module C<B<I<Z>>_L>.
+
+Note: C<I<nf>> can be a C<I<bnf>> as output by C<bnfinit>.
+
+X<rnfsteinitz>The library syntax is B<rnfsteinitz>C<(I<nf>,x)>.
+
+=head2 X<subgrouplist>subgrouplistC<(I<bnr>,{I<bound>},{I<flag> = 0})>
+
+I<bnr> being as output by C<bnrinit> or a list of cyclic components
+of a finite Abelian group C<G>, outputs the list of subgroups of C<G>
+(of index bounded by I<bound>, if not omitted). Subgroups are given
+as HNFX<Hermite normal form> left divisors of the
+SNFX<Smith normal form> matrix corresponding to C<G>. If C<I<flag> = 0>
+(default) and I<bnr> is as output by
+C<bnrinit>, gives only the subgroups whose modulus is the conductor.
+
+X<subgrouplist0>The library syntax is B<subgrouplist0>C<(I<bnr>,I<bound>,I<flag>,I<prec>)>, where
+I<bound>, C<I<flag>> and C<I<prec>> are long integers.
+
+=head2 X<zetak>zetakC<(I<znf>,x,{I<flag> = 0})>
+
+I<znf> being a number
+field initialized by C<zetakinit> (I<not> by C<nfinit>),
+computes the value of the X<Dedekind>Dedekind zeta function of the number
+field at the complex number C<x>. If C<I<flag> = 1> computes Dedekind C<F<Lambda>>
+function instead (i.e.S< >the product of the
+Dedekind zeta function by its gamma and exponential factors).
+
+The accuracy of the result depends in an essential way on the accuracy of
+both the C<zetakinit> program and the current accuracy, but even so the
+result may be off by up to 5 or 10 decimal digits.
+
+X<glambdak>The library syntax is B<glambdak>C<(I<znf>,x,I<prec>)> or
+C<X<gzetak>B<gzetak>(I<znf>,x,I<prec>)>.
+
+=head2 X<zetakinit>zetakinitC<(x)>
+
+computes a number of initialization data
+concerning the number field defined by the polynomial C<x> so as to be able
+to compute the X<Dedekind>Dedekind zeta and lambda functions (respectively
+C<zetak(x)> and C<zetak(x,1)>). This function calls in particular
+the C<bnfinit> program. The result is a 9-component vector C<v> whose
+components are very technical and cannot really be used by the user except
+through the C<zetak> function. The only component which can be used if
+it has not been computed already is C<v[1][4]> which is the result of the
+C<bnfinit> call.
+
+This function is very inefficient and should be rewritten. It needs to
+computes millions of coefficients of the corresponding Dirichlet series if
+the precision is big. Unless the discriminant is small it will not be able
+to handle more than 9 digits of relative precision
+(e.gS< >C<zetakinit(x^8 - 2)> needs 440MB of memory at default
+precision).
+
+X<initzeta>The library syntax is B<initzeta>C<(x)>.
+
+=head1 Polynomials and power series
+
+We group here all functions which are specific to polynomials or power
+series. Many other functions which can be applied on these objects are
+described in the other sections. Also, some of the functions described here
+can be applied to other types.
+
+=head2 X<O>OC<(a>C<^>C<b)>
+
+C<p>-adic (if C<a> is an integer greater or
+equal to 2) or power series zero (in all other cases), with precision given
+by C<b>.
+
+X<ggrandocp>The library syntax is B<ggrandocp>C<(a,b)>, where C<b> is a C<long>.
+
+=head2 X<deriv>derivC<(x,{v})>
+
+derivative of C<x> with respect to the main
+variable if C<v> is omitted, and with respect to C<v> otherwise. C<x> can be any
+type except polmod. The derivative of a scalar type is zero, and the
+derivative of a vector or matrix is done componentwise. One can use C<x'> as a
+shortcut if the derivative is with respect to the main variable of C<x>.
+
+X<deriv>The library syntax is B<deriv>C<(x,v)>, where C<v> is a C<long>, and an omitted C<v> is coded as
+C<-1>.
+
+=head2 X<eval>evalC<(x)>
+
+replaces in C<x> the formal variables by the values that
+have been assigned to them after the creation of C<x>. This is mainly useful
+in GP, and not in library mode. Do not confuse this with substitution (see
+C<subst>). Applying this function to a character string yields the
+output from the corresponding GP command, as if directly input from the
+keyboard (see L<Label se:strings>).X<Label se:eval>
+
+X<geval>The library syntax is B<geval>C<(x)>. The more basic functions C<X<poleval>B<poleval>(q,x)>,
+C<X<qfeval>B<qfeval>(q,x)>, and C<X<hqfeval>B<hqfeval>(q,x)> evaluate C<q> at C<x>, where C<q>
+is respectively assumed to be a polynomial, a quadratic form (a symmetric
+matrix), or an Hermitian form (an Hermitian complex matrix).
+
+=head2 X<factorpadic>factorpadicC<(I<pol>,p,r,{I<flag> = 0})>
+
+C<p>-adic factorization
+of the polynomial I<pol> to precision C<r>, the result being a
+two-column matrix as in C<factor>. The factors are normalized so that
+their leading coefficient is a power of C<p>. C<r> must be strictly larger than
+the C<p>-adic valuation of the discriminant of I<pol> for the result to
+make any sense. The method used is a modified version of the X<round 4>round 4
+algorithm of X<Zassenhaus>Zassenhaus.
+
+If C<I<flag> = 1>, use an algorithm due to X<Buchmann>Buchmann and X<Lenstra>Lenstra, which is
+usually less efficient.
+
+X<factorpadic4>The library syntax is B<factorpadic4>C<(I<pol>,p,r)>, where C<r> is a C<long> integer.
+
+=head2 X<intformal>intformalC<(x,{v})>
+
+X<formal integration>formal integration of C<x> with
+respect to the main variable if C<v> is omitted, with respect to the variable
+C<v> otherwise. Since PARI does not know about ``abstract'' logarithms (they
+are immediately evaluated, if only to a power series), logarithmic terms in
+the result will yield an error. C<x> can be of any type. When C<x> is a
+rational function, it is assumed that the base ring is an integral domain of
+characteristic zero.
+
+X<integ>The library syntax is B<integ>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded
+as C<-1>.
+
+=head2 X<padicappr>padicapprC<(I<pol>,a)>
+
+vector of C<p>-adic roots of the
+polynomial
+C<pol> congruent to the C<p>-adic number C<a> modulo C<p> (or modulo 4 if C<p = 2>),
+and with the same C<p>-adic precision as C<a>. The number C<a> can be an
+ordinary C<p>-adic number (type C<t_PADIC>, i.e.S< >an element of C<B<I<Q>>_p>) or
+can be an element of a finite extension of C<B<I<Q>>_p>, in which case it is of
+type C<t_POLMOD>, where at least one of the coefficients of the polmod is a
+C<p>-adic number. In this case, the result is the vector of roots belonging to
+the same extension of C<B<I<Q>>_p> as C<a>.
+
+X<apprgen9>The library syntax is B<apprgen9>C<(I<pol>,a)>, but if C<a> is known to be simply a C<p>-adic number
+(type C<t_PADIC>), the syntax C<X<apprgen>B<apprgen>(I<pol>,a)> can be used.
+
+=head2 X<polcoeff>polcoeffC<(x,s,{v})>
+
+coefficient of degree C<s> of the
+polynomial C<x>, with respect to the main variable if C<v> is omitted, with
+respect to C<v> otherwise.
+
+X<polcoeff0>The library syntax is B<polcoeff0>C<(x,s,v)>, where C<v> is a C<long> and an omitted C<v> is coded
+as C<-1>. Also available is X<truecoeff>B<truecoeff>C<(x,v)>.
+
+=head2 X<poldegree>poldegreeC<(x,{v})>
+
+degree of the polynomial C<x> in the main
+variable if C<v> is omitted, in the variable C<v> otherwise. This is to be
+understood as follows. When C<x> is a polynomial or a rational function, it
+gives the degree of C<x>, the degree of C<0> being C<-1> by convention. When C<x>
+is a non-zero scalar, it gives 0, and when C<x> is a zero scalar, it gives
+C<-1>. Return an error otherwise.
+
+X<poldegree>The library syntax is B<poldegree>C<(x,v)>, where C<v> and the result are C<long>s (and an
+omitted C<v> is coded as C<-1>). Also available is X<degree>B<degree>C<(x)>, which is
+equivalent to C<poldegree(x,-1)>.
+
+=head2 X<polcyclo>polcycloC<(n,{v = x})>
+
+C<n>-th cyclotomic polynomial, in variable
+C<v> (C<x> by default). The integer C<n> must be positive.
+
+X<cyclo>The library syntax is B<cyclo>C<(n,v)>, where C<n> and C<v> are C<long>
+integers (C<v> is a variable number, usually obtained through C<varn>).
+
+=head2 X<poldisc>poldiscC<(I<pol>,{v})>
+
+discriminant of the polynomial
+I<pol> in the main variable is C<v> is omitted, in C<v> otherwise. The
+algorithm used is the X<subresultant algorithm>subresultant algorithm.
+
+X<poldisc0>The library syntax is B<poldisc0>C<(x,v)>. Also available is X<discsr>B<discsr>C<(x)>, equivalent
+to C<poldisc0(x,-1)>.
+
+=head2 X<poldiscreduced>poldiscreducedC<(f)>
+
+reduced discriminant vector of the
+(integral, monic) polynomial C<f>. This is the vector of elementary divisors
+of C<B<I<Z>>[F<alpha>]/f'(F<alpha>)B<I<Z>>[F<alpha>]>, where C<F<alpha>> is a root of the
+polynomial C<f>. The components of the result are all positive, and their
+product is equal to the absolute value of the discriminant ofS< >C<f>.
+
+X<reduceddiscsmith>The library syntax is B<reduceddiscsmith>C<(x)>.
+
+=head2 X<polhensellift>polhenselliftC<(x, y, p, e)>
+
+given a vector C<y> of
+polynomials that are pairwise relatively prime modulo the prime C<p>,
+and whose product is congruent to C<x> modulo C<p>, lift the elements of
+C<y> to polynomials whose product is congruent to C<x> modulo C<p^e>.
+
+X<polhensellift>The library syntax is B<polhensellift>C<(x,y,p,e)> where C<e> must be a C<long>.
+
+=head2 X<polinterpolate>polinterpolateC<(xa,{ya},{v = x},{&e})>
+
+given the data vectors
+C<xa> and C<ya> of the same length C<n> (C<xa> containing the C<x>-coordinates,
+and C<ya> the corresponding C<y>-coordinates), this function finds the
+X<interpolating polynomial>interpolating polynomial passing through these points and evaluates it
+atS< >C<v>. If C<ya> is omitted, return the polynomial interpolating the
+C<(i,xa[i])>. If present, C<e> will contain an error estimate on the returned
+value.
+
+X<polint>The library syntax is B<polint>C<(xa,ya,v,&e)>, where C<e> will contain an error estimate on the
+returned value.
+
+=head2 X<polisirreducible>polisirreducibleC<(I<pol>)>
+
+I<pol> being a polynomial
+(univariate in the present version B<2.2.0>), returns 1 if I<pol> is
+non-constant and irreducible, 0 otherwise. Irreducibility is checked over
+the smallest base field over which I<pol> seems to be defined.
+
+X<gisirreducible>The library syntax is B<gisirreducible>C<(I<pol>)>.
+
+=head2 X<pollead>polleadC<(x,{v})>
+
+leading coefficient of the polynomial or
+power series C<x>. This is computed with respect to the main variable of C<x>
+if C<v> is omitted, with respect to the variable C<v> otherwise.
+
+X<pollead>The library syntax is B<pollead>C<(x,v)>, where C<v> is a C<long> and an omitted C<v> is coded as
+C<-1>. Also available is X<leadingcoeff>B<leadingcoeff>C<(x)>.
+
+=head2 X<pollegendre>pollegendreC<(n,{v = x})>
+
+creates the C<n^{th}>
+X<Legendre polynomial>Legendre polynomial, in variable C<v>.
+
+X<legendre>The library syntax is B<legendre>C<(n)>, where C<x> is a C<long>.
+
+=head2 X<polrecip>polrecipC<(I<pol>)>
+
+reciprocal polynomial of I<pol>,
+i.e.S< >the coefficients are in reverse order. I<pol> must be a polynomial.
+
+X<polrecip>The library syntax is B<polrecip>C<(x)>.
+
+=head2 X<polresultant>polresultantC<(x,y,{v},{I<flag> = 0})>
+
+resultant of the two
+polynomials C<x> and C<y> with exact entries, with respect to the main
+variables of C<x> and C<y> if C<v> is omitted, with respect to the variable C<v>
+otherwise. The algorithm used is the X<subresultant algorithm>subresultant algorithm by default.
+
+If C<I<flag> = 1>, uses the determinant of Sylvester's matrix instead (here C<x> and
+C<y> may have non-exact coefficients).
+
+If C<I<flag> = 2>, uses Ducos's modified subresultant algorithm. It should be much
+faster than the default if the coefficient ring is complicated (e.g
+multivariate polynomials or huge coefficients), and slightly slower
+otherwise.
+
+X<polresultant0>The library syntax is B<polresultant0>C<(x,y,v,I<flag>)>, where C<v> is a C<long> and an omitted C<v>
+is coded as C<-1>. Also available are C<X<subres>B<subres>(x,y)> (C<I<flag> = 0>) and
+C<X<resultant2>B<resultant2>(x,y)> (C<I<flag> = 1>).
+
+=head2 X<polroots>polrootsC<(I<pol>,{I<flag> = 0})>
+
+complex roots of the polynomial
+I<pol>, given as a column vector where each root is repeated according to
+its multiplicity. The precision is given as for transcendental functions: under
+GP it is kept in the variable C<realprecision> and is transparent to the
+user, but it must be explicitly given as a second argument in library mode.
+
+The algorithm used is a modification of A.S< >X<SchE<ouml>nhage>SchE<ouml>nhage's remarkable
+root-finding algorithm, due to and implemented by X.S< >Gourdon. Barring bugs,
+it is guaranteed to converge and to give the roots to the required accuracy.
+
+If C<I<flag> = 1>, use a variant of the Newton-Raphson method, which is I<not>
+guaranteed to converge, but is rather fast. If you get the messages ``too
+many iterations in roots'' or ``INTERNAL ERROR: incorrect result in roots'',
+use the default function (i.e.S< >no flag or C<I<flag> = 0>). This used to be the
+default root-finding function in PARI until version 1.39.06.
+
+X<roots>The library syntax is B<roots>C<(I<pol>,I<prec>)> or C<X<rootsold>B<rootsold>(I<pol>,I<prec>)>.
+
+=head2 X<polrootsmod>polrootsmodC<(I<pol>,p,{I<flag> = 0})>
+
+row vector of roots modulo
+C<p> of the polynomial I<pol>. The particular non-prime value C<p = 4> is
+accepted, mainly for C<2>-adic computations. Multiple roots are I<not>
+repeated.
+
+If C<p E<lt> 100>, you may try setting C<I<flag> = 1>, which uses a naive search. In this
+case, multiple roots I<are> repeated with their order of multiplicity.
+
+X<rootmod>The library syntax is B<rootmod>C<(I<pol>,p)> (C<I<flag> = 0>) or
+C<X<rootmod2>B<rootmod2>(I<pol>,p)> (C<I<flag> = 1>).
+
+=head2 X<polrootspadic>polrootspadicC<(I<pol>,p,r)>
+
+row vector of C<p>-adic roots of the
+polynomial I<pol> with C<p>-adic precision equal to C<r>. Multiple roots are
+I<not> repeated. C<p> is assumed to be a prime.
+
+X<rootpadic>The library syntax is B<rootpadic>C<(I<pol>,p,r)>, where C<r> is a C<long>.
+
+=head2 X<polsturm>polsturmC<(I<pol>,{a},{b})>
+
+number of real roots of the real
+polynomial I<pol> in the interval C<]a,b]>, using Sturm's algorithm. C<a>
+(resp.S< >C<b>) is taken to be C<- oo > (resp.S< >C<+ oo >) if omitted.
+
+X<sturmpart>The library syntax is B<sturmpart>C<(I<pol>,a,b)>. Use C<NULL> to omit an argument.
+X<sturm>B<sturm>C<(I<pol>)> is equivalent to
+B<sturmpart>C<(I<pol>,NULL,NULL)>. The result is a C<long>.
+
+=head2 X<polsubcyclo>polsubcycloC<(n,d,{v = x})>
+
+gives a polynomial (in variable
+C<v>) defining the sub-Abelian extension of degree C<d> of the cyclotomic
+field C<B<I<Q>>(F<zeta>_n)>, where C<d | F<phi>(n)>. C<(B<I<Z>>/nB<I<Z>>)^*> has to be cyclic
+(i.e.S< >C<n = 2>, C<4>, C<p^k> or C<2p^k> for an odd prime C<p>). The function
+X<galoissubcyclo>C<galoissubcyclo> covers the general case.
+
+X<subcyclo>The library syntax is B<subcyclo>C<(n,d,v)>, where C<v> is a variable number.
+
+=head2 X<polsylvestermatrix>polsylvestermatrixC<(x,y)>
+
+forms the Sylvester matrix
+corresponding to the two polynomials C<x> and C<y>, where the coefficients of
+the polynomials are put in the columns of the matrix (which is the natural
+direction for solving equations afterwards). The use of this matrix can be
+essential when dealing with polynomials with inexact entries, since
+polynomial Euclidean division doesn't make much sense in this case.
+
+X<sylvestermatrix>The library syntax is B<sylvestermatrix>C<(x,y)>.
+
+=head2 X<polsym>polsymC<(x,n)>
+
+creates the vector of the X<symmetric powers>symmetric powers
+of the roots of the polynomial C<x> up to power C<n>, using Newton's
+formula.
+
+X<polsym>The library syntax is B<polsym>C<(x)>.
+
+=head2 X<poltchebi>poltchebiC<(n,{v = x})>
+
+creates the C<n^{th}>
+X<Chebyshev>Chebyshev polynomial, in variable C<v>.
+
+X<tchebi>The library syntax is B<tchebi>C<(n,v)>, where C<n> and C<v> are C<long>
+integers (C<v> is a variable number).
+
+=head2 X<polzagier>polzagierC<(n,m)>
+
+creates Zagier's polynomial C<P_{n,m}> used in
+the functions C<sumalt> and C<sumpos> (with C<I<flag> = 1>). The exact
+definition can be found in a forthcoming paper. One must have C<m E<lt>= n>.
+
+X<polzagreel>The library syntax is B<polzagreel>C<(n,m,I<prec>)> if the result is only wanted as a polynomial
+with real coefficients to the precision C<I<prec>>, or C<X<polzag>B<polzag>(n,m)>
+if the result is wanted exactly, where C<n> and C<m> are C<long>s.
+
+=head2 X<serconvol>serconvolC<(x,y)>
+
+convolution (or X<Hadamard product>Hadamard product) of the
+two power series C<x> and C<y>; in other words if C<x = F<sum> a_k*X^k> and C<y = F<sum>
+b_k*X^k> then C<serconvol(x,y) = F<sum> a_k*b_k*X^k>.
+
+X<convol>The library syntax is B<convol>C<(x,y)>.
+
+=head2 X<serlaplace>serlaplaceC<(x)>
+
+C<x> must be a power series with only
+non-negative exponents. If C<x = F<sum> (a_k/k!)*X^k> then the result is C<F<sum>
+a_k*X^k>.
+
+X<laplace>The library syntax is B<laplace>C<(x)>.
+
+=head2 X<serreverse>serreverseC<(x)>
+
+reverse power series (i.e.S< >C<x^{-1}>, not C<1/x>)
+of C<x>. C<x> must be a power series whose valuation is exactly equal to one.
+
+X<recip>The library syntax is B<recip>C<(x)>.
+
+=head2 X<subst>substC<(x,y,z)>
+
+replace the simple variable C<y> by the argument C<z> in the ``polynomial''
+expression C<x>. Every type is allowed for C<x>, but if it is not a genuine
+polynomial (or power series, or rational function), the substitution will be
+done as if the scalar components were polynomials of degree one. In
+particular, beware that:
+
+ ? subst(1, x, [1,2; 3,4])
+ %1 =
+ [1 0]
+
+ [0 1]
+
+ ? subst(1, x, Mat([0,1]))
+ *** forbidden substitution by a non square matrix
+
+If C<x> is a power series, C<z> must be either a polynomial, a power series, or
+a rational function. C<y> must be a simple variable name.
+
+X<gsubst>The library syntax is B<gsubst>C<(x,v,z)>, where C<v> is the number of
+the variable C<y>.
+
+=head2 X<taylor>taylorC<(x,y)>
+
+Taylor expansion around C<0> of C<x> with respect
+toX<Label se:taylor>
+the simple variable C<y>. C<x> can be of any reasonable type, for example a
+rational function. The number of terms of the expansion is transparent to the
+user under GP, but must be given as a second argument in library mode.
+
+X<tayl>The library syntax is B<tayl>C<(x,y,n)>, where the C<long> integer C<n> is the desired number of
+terms in the expansion.
+
+=head2 X<thue>thueC<(I<tnf>,a,{I<sol>})>
+
+solves the equation
+C<P(x,y) = a> in integers C<x> and C<y>, where I<tnf> was created with
+C<thueinit(P)>. I<sol>, if present, contains the solutions of
+C<Norm(x) = a> modulo units of positive norm in the number field
+defined by C<P> (as computed by C<bnfisintnorm>). If I<tnf> was
+computed without assuming X<GRH>GRH (C<I<flag> = 1> in C<thueinit>), the
+result is unconditional. For instance, here's how to solve the Thue
+equation C<x^{13} - 5y^{13} = - 4>:
+
+ ? tnf = thueinit(x^13 - 5);
+ ? thue(tnf, -4)
+ %1 = [[1, 1]]
+
+Hence, assuming GRH, the only solution is C<x = 1>, C<y = 1>.
+
+X<thue>The library syntax is B<thue>C<(I<tnf>,a,I<sol>)>, where an omitted I<sol> is coded
+as C<NULL>.
+
+=head2 X<thueinit>thueinitC<(P,{I<flag> = 0})>
+
+initializes the I<tnf>
+corresponding to C<P>. It is meant to be used in conjunction with X<thue>C<thue>
+to solve Thue equations C<P(x,y) = a>, where C<a> is an integer. If C<I<flag>> is
+non-zero, certify the result unconditionnaly, Otherwise, assume X<GRH>GRH,
+this being much faster of course.
+
+X<thueinit>The library syntax is B<thueinit>C<(P,I<flag>,I<prec>)>.
+
+=head1 Vectors, matrices, linear algebra and sets
+
+X<Label se:linear_algebra>
+Note that most linear algebra functions operating on subspaces defined by
+generating sets (such as X<mathnf>C<mathnf>, X<qflll>C<qflll>, etc.) take matrices as
+arguments. As usual, the generating vectors are taken to be the
+I<columns> of the given matrix.
+
+=head2 X<algdep>algdepC<(x,k,{I<flag> = 0})>
+
+X<algebraic dependence>C<x> being
+real, complex, or C<p>-adic, finds a polynomial of degree at most C<k> with
+integer coefficients having C<x> as approximate root. Note that the polynomial
+which is obtained is not necessarily the ``correct'' one (it's not even
+guaranteed to be irreducible!). One can check the closeness either by a
+polynomial evaluation or substitution, or by computing the roots of the
+polynomial given by algdep.
+
+If C<x> is padic, C<I<flag>> is meaningless and the algorithm LLL-reduces the
+``dual lattice'' corresponding to the powers of C<x>.
+
+Otherwise, if C<I<flag>> is zero, the algorithm used is a variant of the X<LLL>LLL
+algorithm due to Hastad, Lagarias and Schnorr (STACS 1986). If the precision
+is too low, the routine may enter an infinite loop.
+
+If C<I<flag>> is non-zero, use a standard LLL. C<I<flag>> then indicates a precision,
+which should be between C<0.5> and C<1.0> times the number of decimal digits
+to which C<x> was computed.
+
+X<algdep0>The library syntax is B<algdep0>C<(x,k,I<flag>,I<prec>)>, where C<k> and C<I<flag>> are C<long>s.
+Also available is C<X<algdep>B<algdep>(x,k,I<prec>)> (C<I<flag> = 0>).
+
+=head2 X<charpoly>charpolyC<(A,{v = x},{I<flag> = 0})>
+
+X<characteristic polynomial>characteristic polynomial
+of C<A> with respect to the variable C<v>, i.e.S< >determinant of C<v*I-A> if C<A>
+is a square matrix, determinant of the map ``multiplication by C<A>'' if C<A>
+is a scalar, in particular a polmod (e.g.S< >C<charpoly(I,x) = x^2+1>).
+Note that in the latter case, the X<minimal polynomial>minimal polynomial can be obtained
+as
+
+ minpoly(A)=
+ {
+ local(y);
+ y = charpoly(A);
+ y / gcd(y,y')
+ }
+
+The value of C<I<flag>> is only significant for matrices.
+
+If C<I<flag> = 0>, the method used is essentially the same as for computing the
+adjoint matrix, i.e.S< >computing the traces of the powers of C<A>.
+
+If C<I<flag> = 1>, uses Lagrange interpolation which is almost always slower.
+
+If C<I<flag> = 2>, uses the Hessenberg form. This is faster than the default when
+the coefficients are integermod a prime or real numbers, but is usually
+slower in other base rings.
+
+X<charpoly0>The library syntax is B<charpoly0>C<(A,v,I<flag>)>, where C<v> is the variable number. Also available
+are the functions C<X<caract>B<caract>(A,v)> (C<I<flag> = 1>), C<X<carhess>B<carhess>(A,v)>
+(C<I<flag> = 2>), and C<X<caradj>B<caradj>(A,v,I<pt>)> where, in this last case,
+I<pt> is a C<GEN*> which, if not equal to C<NULL>, will receive
+the address of the adjoint matrix of C<A> (see C<matadjoint>), so both
+can be obtained at once.
+
+=head2 X<concat>concatC<(x,{y})>
+
+concatenation of C<x> and C<y>. If C<x> or C<y> is
+not a vector or matrix, it is considered as a one-dimensional vector. All
+types are allowed for C<x> and C<y>, but the sizes must be compatible. Note
+that matrices are concatenated horizontally, i.e.S< >the number of rows stays
+the same. Using transpositions, it is easy to concatenate them vertically.
+
+To concatenate vectors sideways (i.e.S< >to obtain a two-row or two-column
+matrix), first transform the vector into a one-row or one-column matrix using
+the function X<Mat>C<Mat>. Concatenating a row vector to a matrix having the
+same number of columns will add the row to the matrix (top row if the vector
+is C<x>, i.e.S< >comes first, and bottom row otherwise).
+
+The empty matrix C<[;]> is considered to have a number of rows compatible
+with any operation, in particular concatenation. (Note that this is
+definitely I<not> the case for empty vectors C<[S< >]> or C<[S< >]~>.)
+
+If C<y> is omitted, C<x> has to be a row vector or a list, in which case its
+elements are concatenated, from left to right, using the above rules.
+
+ ? concat([1,2], [3,4])
+ %1 = [1, 2, 3, 4]
+ ? a = [[1,2]~, [3,4]~]; concat(a)
+ %2 = [1, 2, 3, 4]~
+ ? a[1] = Mat(a[1]); concat(a)
+ %3 =
+ [1 3]
+
+ [2 4]
+
+ ? concat([1,2; 3,4], [5,6]~)
+ %4 =
+ [1 2 5]
+
+ [3 4 6]
+ ? concat([%, [7,8]~, [1,2,3,4]])
+ %5 =
+ [1 2 5 7]
+
+ [3 4 6 8]
+
+ [1 2 3 4]
+
+X<concat>The library syntax is B<concat>C<(x,y)>.
+
+=head2 X<lindep>lindepC<(x,{I<flag> = 0})>
+
+X<linear dependence>C<x> being a
+vector with real or complex coefficients, finds a small integral linear
+combination among these coefficients.
+
+If C<I<flag> = 0>, uses a variant of the X<LLL>LLL algorithm due to Hastad, Lagarias
+and Schnorr (STACS 1986).
+
+If C<I<flag> E<gt> 0>, uses the LLL algorithm. C<I<flag>> is a parameter which should be
+between one half the number of decimal digits of precision and that number
+(see C<algdep>).
+
+If C<I<flag> E<lt> 0>, returns as soon as one relation has been found.
+
+X<lindep0>The library syntax is B<lindep0>C<(x,I<flag>,I<prec>)>. Also available is
+C<X<lindep>B<lindep>(x,I<prec>)> (C<I<flag> = 0>).
+
+=head2 X<listcreate>listcreateC<(n)>
+
+creates an empty list of maximal length C<n>.
+
+This function is useless in library mode.
+
+=head2 X<listinsert>listinsertC<(I<list>,x,n)>
+
+inserts the object C<x> at
+position C<n> in I<list> (which must be of type C<t_LIST>). All the
+remaining elements of I<list> (from position C<n+1> onwards) are shifted
+to the right. This and C<listput> are the only commands which enable
+you to increase a list's effective length (as long as it remains under
+the maximal length specified at the time of the C<listcreate>).
+
+This function is useless in library mode.
+
+=head2 X<listkill>listkillC<(I<list>)>
+
+kill I<list>. This deletes all
+elements from I<list> and sets its effective length to C<0>. The maximal
+length is not affected.
+
+This function is useless in library mode.
+
+=head2 X<listput>listputC<(I<list>,x,{n})>
+
+sets the C<n>-th element of the list
+I<list> (which must be of type C<t_LIST>) equal to C<x>. If C<n> is omitted,
+or greater than the list current effective length, just appends C<x>. This and
+C<listinsert> are the only commands which enable you to increase a list's
+effective length (as long as it remains under the maximal length specified at
+the time of the C<listcreate>).
+
+If you want to put an element into an occupied cell, i.e.S< >if you don't want to
+change the effective length, you can consider the list as a vector and use
+the usual C<list[n] = x> construct.
+
+This function is useless in library mode.
+
+=head2 X<listsort>listsortC<(I<list>,{I<flag> = 0})>
+
+sorts I<list> (which must
+be of type C<t_LIST>) in place. If C<I<flag>> is non-zero, suppresses all repeated
+coefficients. This is much faster than the C<vecsort> command since no
+copy has to be made.
+
+This function is useless in library mode.
+
+=head2 X<matadjoint>matadjointC<(x)>
+
+X<adjoint matrix>adjoint matrix of C<x>, i.e.S< >the matrix C<y>
+of cofactors of C<x>, satisfying C<x*y = F<det> (x)*Id>. C<x> must be a
+(non-necessarily invertible) square matrix.
+
+X<adj>The library syntax is B<adj>C<(x)>.
+
+=head2 X<matcompanion>matcompanionC<(x)>
+
+the left companion matrix to the polynomial C<x>.
+
+X<assmat>The library syntax is B<assmat>C<(x)>.
+
+=head2 X<matdet>matdetC<(x,{I<flag> = 0})>
+
+determinant of C<x>. C<x> must be a
+square matrix.
+
+If C<I<flag> = 0>, uses Gauss-Bareiss.
+
+If C<I<flag> = 1>, uses classical Gaussian elimination, which is better when the
+entries of the matrix are reals or integers for example, but usually much
+worse for more complicated entries like multivariate polynomials.
+
+X<det>The library syntax is B<det>C<(x)> (C<I<flag> = 0>) and C<X<det2>B<det2>(x)>
+(C<I<flag> = 1>).
+
+=head2 X<matdetint>matdetintC<(x)>
+
+C<x> being an C<m x n> matrix with integer
+coefficients, this function computes a multiple of the determinant of the
+lattice generated by the columns of C<x> if it is of rank C<m>, and returns
+zero otherwise. This function can be useful in conjunction with the function
+C<mathnfmod> which needs to know such a multiple. Other ways to obtain
+this determinant (assuming the rank is maximal) is
+C<matdet(qflll(x,4)[2]*x)> or more simply C<matdet(mathnf(x))>.
+Experiment to see which is faster for your applications.
+
+X<detint>The library syntax is B<detint>C<(x)>.
+
+=head2 X<matdiagonal>matdiagonalC<(x)>
+
+C<x> being a vector, creates the diagonal matrix
+whose diagonal entries are those of C<x>.
+
+X<diagonal>The library syntax is B<diagonal>C<(x)>.
+
+=head2 X<mateigen>mateigenC<(x)>
+
+gives the eigenvectors of C<x> as columns of a
+matrix.
+
+X<eigen>The library syntax is B<eigen>C<(x)>.
+
+=head2 X<mathess>mathessC<(x)>
+
+Hessenberg form of the square matrix C<x>.
+
+X<hess>The library syntax is B<hess>C<(x)>.
+
+=head2 X<mathilbert>mathilbertC<(x)>
+
+C<x> being a C<long>, creates the X<Hilbert
+matrix>Hilbert
+matrix of order C<x>, i.e.S< >the matrix whose coefficient (C<i>,C<j>) is C<1/
+(i+j-1)>.
+
+X<mathilbert>The library syntax is B<mathilbert>C<(x)>.
+
+=head2 X<mathnf>mathnfC<(x,{I<flag> = 0})>
+
+if C<x> is a (not necessarily square)
+matrix of maximal rank, finds the I<upper triangular>
+X<Hermite normal form>Hermite normal form of C<x>. If the rank of C<x> is equal to its number
+of rows, the result is a square matrix. In general, the columns of the
+result form a basis of the lattice spanned by the columns of C<x>.
+
+If C<I<flag> = 0>, uses the naive algorithm. If the B<I<Z>>-module generated by the
+columns is a lattice, it is recommanded to use
+C<mathnfmod(x, matdetint(x))> instead (much faster).
+
+If C<I<flag> = 1>, uses Batut's algorithm. Outputs a two-component row vector
+C<[H,U]>, where C<H> is the I<upper triangular> Hermite normal form
+of C<x> (i.e.S< >the default result) and C<U> is the unimodular transformation
+matrix such that C<xU = [0|H]>. If the rank of C<x> is equal to its number of
+rows, C<H> is a square matrix. In general, the columns of C<H> form a basis
+of the lattice spanned by the columns of C<x>.
+
+If C<I<flag> = 2>, uses Havas's algorithm. Outputs C<[H,U,P]>, such that
+C<H> and C<U> are as before and C<P> is a permutation of the rows such that C<P>
+applied to C<xU> gives C<H>. This does not work very well in present version
+B<2.2.0>.
+
+If C<I<flag> = 3>, uses Batut's algorithm, and outputs C<[H,U,P]> as in the previous
+case.
+
+If C<I<flag> = 4>, as in case 1 above, but uses X<LLL>LLL reduction along the way.
+
+X<mathnf0>The library syntax is B<mathnf0>C<(x,I<flag>)>. Also available are C<X<hnf>B<hnf>(x)> (C<I<flag> = 0>) and
+C<X<hnfall>B<hnfall>(x)> (C<I<flag> = 1>). To reduce I<huge> (say C<400 x 400> and
+more) relation matrices (sparse with small entries), you can use the pair
+C<hnfspec> / C<hnfadd>. Since this is rather technical and the
+calling interface may change, they are not documented yet. Look at the code
+in C<basemath/alglin1.c>.
+
+=head2 X<mathnfmod>mathnfmodC<(x,d)>
+
+if C<x> is a (not necessarily square) matrix of
+maximal rank with integer entries, and C<d> is a multiple of the (non-zero)
+determinant of the lattice spanned by the columns of C<x>, finds the
+I<upper triangular> X<Hermite normal form>Hermite normal form of C<x>.
+
+If the rank of C<x> is equal to its number of rows, the result is a square
+matrix. In general, the columns of the result form a basis of the lattice
+spanned by the columns of C<x>. This is much faster than C<mathnf> when C<d>
+is known.
+
+X<hnfmod>The library syntax is B<hnfmod>C<(x,d)>.
+
+=head2 X<mathnfmodid>mathnfmodidC<(x,d)>
+
+outputs the (upper triangular)
+X<Hermite normal form>Hermite normal form of C<x> concatenated with C<d> times
+the identity matrix.
+
+X<hnfmodid>The library syntax is B<hnfmodid>C<(x,d)>.
+
+=head2 X<matid>matidC<(n)>
+
+creates the C<n x n> identity matrix.
+
+X<idmat>The library syntax is B<idmat>C<(n)> where C<n> is a C<long>.
+
+Related functions are C<X<gscalmat>B<gscalmat>(x,n)>, which creates C<x> times the
+identity matrix (C<x> being a C<GEN> and C<n> a C<long>), and
+C<X<gscalsmat>B<gscalsmat>(x,n)> which is the same when C<x> is a C<long>.
+
+=head2 X<matimage>matimageC<(x,{I<flag> = 0})>
+
+gives a basis for the image of the
+matrix C<x> as columns of a matrix. A priori the matrix can have entries of
+any type. If C<I<flag> = 0>, use standard Gauss pivot. If C<I<flag> = 1>, use
+C<matsupplement>.
+
+X<matimage0>The library syntax is B<matimage0>C<(x,I<flag>)>. Also available is C<X<image>B<image>(x)> (C<I<flag> = 0>).
+
+=head2 X<matimagecompl>matimagecomplC<(x)>
+
+gives the vector of the column indices which
+are not extracted by the function C<matimage>. Hence the number of
+components of C<matimagecompl(x)> plus the number of columns of
+C<matimage(x)> is equal to the number of columns of the matrix C<x>.
+
+X<imagecompl>The library syntax is B<imagecompl>C<(x)>.
+
+=head2 X<matindexrank>matindexrankC<(x)>
+
+C<x> being a matrix of rank C<r>, gives two
+vectors C<y> and C<z> of length C<r> giving a list of rows and columns
+respectively (starting from 1) such that the extracted matrix obtained from
+these two vectors using C<X<vecextract>vecextract(x,y,z)> is invertible.
+
+X<indexrank>The library syntax is B<indexrank>C<(x)>.
+
+=head2 X<matintersect>matintersectC<(x,y)>
+
+C<x> and C<y> being two matrices with the same
+number of rows each of whose columns are independent, finds a basis of the
+B<I<Q>>-vector space equal to the intersection of the spaces spanned by the
+columns of C<x> and C<y> respectively. See also the function
+X<idealintersect>C<idealintersect>, which does the same for free B<I<Z>>-modules.
+
+X<intersect>The library syntax is B<intersect>C<(x,y)>.
+
+=head2 X<matinverseimage>matinverseimageC<(x,y)>
+
+gives a column vector belonging to the
+inverse image of the column vector C<y> by the matrix C<x> if one exists, the
+empty vector otherwise. To get the complete inverse image, it suffices to add
+to the result any element of the kernel of C<x> obtained for example by
+C<matker>.
+
+X<inverseimage>The library syntax is B<inverseimage>C<(x,y)>.
+
+=head2 X<matisdiagonal>matisdiagonalC<(x)>
+
+returns true (1) if C<x> is a diagonal matrix,
+false (0) if not.
+
+X<isdiagonal>The library syntax is B<isdiagonal>C<(x)>, and this returns a C<long>
+integer.
+
+=head2 X<matker>matkerC<(x,{I<flag> = 0})>
+
+gives a basis for the kernel of the
+matrix C<x> as columns of a matrix. A priori the matrix can have entries of
+any type.
+
+If C<x> is known to have integral entries, set C<I<flag> = 1>.
+
+Note: The library function C<X<ker_mod_p>ker_mod_p(x, p)>, where C<x> has
+integer entries and C<p> is prime, which is equivalent to but many orders of
+magnitude faster than C<matker(x*Mod(1,p))> and needs much less stack
+space. To use it under GP, type C<install(ker_mod_p, GG)> first.
+
+X<matker0>The library syntax is B<matker0>C<(x,I<flag>)>. Also available are C<X<ker>B<ker>(x)> (C<I<flag> = 0>),
+C<X<keri>B<keri>(x)> (C<I<flag> = 1>) and C<ker_mod_p(x,p)>.
+
+=head2 X<matkerint>matkerintC<(x,{I<flag> = 0})>
+
+gives an X<LLL>LLL-reduced B<I<Z>>-basis
+for the lattice equal to the kernel of the matrix C<x> as columns of the
+matrix C<x> with integer entries (rational entries are not permitted).
+
+If C<I<flag> = 0>, uses a modified integer LLL algorithm.
+
+If C<I<flag> = 1>, uses C<matrixqz(x,-2)>. If LLL reduction of the final result
+is not desired, you can save time using C<matrixqz(matker(x),-2)> instead.
+
+If C<I<flag> = 2>, uses another modified LLL. In the present version B<2.2.0>, only
+independent rows are allowed in this case.
+
+X<matkerint0>The library syntax is B<matkerint0>C<(x,I<flag>)>. Also available is
+C<X<kerint>B<kerint>(x)> (C<I<flag> = 0>).
+
+=head2 X<matmuldiagonal>matmuldiagonalC<(x,d)>
+
+product of the matrix C<x> by the diagonal
+matrix whose diagonal entries are those of the vector C<d>. Equivalent to,
+but much faster than C<x*matdiagonal(d)>.
+
+X<matmuldiagonal>The library syntax is B<matmuldiagonal>C<(x,d)>.
+
+=head2 X<matmultodiagonal>matmultodiagonalC<(x,y)>
+
+product of the matrices C<x> and C<y>
+knowing that the result is a diagonal matrix. Much faster than C<x*y> in
+that case.
+
+X<matmultodiagonal>The library syntax is B<matmultodiagonal>C<(x,y)>.
+
+=head2 X<matpascal>matpascalC<(x,{q})>
+
+creates as a matrix the lower triangular
+X<Pascal triangle>Pascal triangle of order C<x+1> (i.e.S< >with binomial coefficients
+up to C<x>). If C<q> is given, compute the C<q>-Pascal triangle (i.e.S< >using
+C<q>-binomial coefficients).
+
+X<matqpascal>The library syntax is B<matqpascal>C<(x,q)>, where C<x> is a C<long> and C<q = NULL> is used
+to omit C<q>. Also available is X<matpascal>B<matpascal>{x}.
+
+=head2 X<matrank>matrankC<(x)>
+
+rank of the matrix C<x>.
+
+X<rank>The library syntax is B<rank>C<(x)>, and the result is a C<long>.
+
+=head2 X<matrix>matrixC<(m,n,{X},{Y},{I<expr> = 0})>
+
+creation of the
+C<m x n> matrix whose coefficients are given by the expression
+I<expr>. There are two formal parameters in I<expr>, the first one
+(C<X>) corresponding to the rows, the second (C<Y>) to the columns, and C<X>
+goes from 1 to C<m>, C<Y> goes from 1 to C<n>. If one of the last 3 parameters
+is omitted, fill the matrix with zeroes.
+
+X<matrice>The library syntax is B<matrice>C<(GEN nlig,GEN ncol,entree *e1,entree *e2,char *expr)>.
+
+=head2 X<matrixqz>matrixqzC<(x,p)>
+
+C<x> being an C<m x n> matrix with C<m E<gt>= n>
+with rational or integer entries, this function has varying behaviour
+depending on the sign of C<p>:
+
+If C<p E<gt>= 0>, C<x> is assumed to be of maximal rank. This function returns a
+matrix having only integral entries, having the same image as C<x>, such that
+the GCD of all its C<n x n> subdeterminants is equal to 1 when C<p> is
+equal to 0, or not divisible by C<p> otherwise. Here C<p> must be a prime
+number (when it is non-zero). However, if the function is used when C<p> has
+no small prime factors, it will either work or give the message ``impossible
+inverse modulo'' and a non-trivial divisor of C<p>.
+
+If C<p = -1>, this function returns a matrix whose columns form a basis of the
+lattice equal to C<B<I<Z>>^n> intersected with the lattice generated by the
+columns of C<x>.
+
+If C<p = -2>, returns a matrix whose columns form a basis of the lattice equal
+to C<B<I<Z>>^n> intersected with the B<I<Q>>-vector space generated by the
+columns of C<x>.
+
+X<matrixqz0>The library syntax is B<matrixqz0>C<(x,p)>.
+
+=head2 X<matsize>matsizeC<(x)>
+
+C<x> being a vector or matrix, returns a row vector
+with two components, the first being the number of rows (1 for a row vector),
+the second the number of columns (1 for a column vector).
+
+X<matsize>The library syntax is B<matsize>C<(x)>.
+
+=head2 X<matsnf>matsnfC<(X,{I<flag> = 0})>
+
+if C<X> is a (singular or non-singular)
+square matrix outputs the vector of elementary divisors of C<X> (i.e.S< >the
+diagonal of the X<Smith normal form>Smith normal form of C<X>).
+
+The binary digits of I<flag> mean:
+
+1 (complete output): if set, outputs C<[U,V,D]>, where C<U> and C<V> are two
+unimodular matrices such that C<UXV> is the diagonal matrix C<D>. Otherwise
+output only the diagonal of C<D>.
+
+2 (generic input): if set, allows polynomial entries. Otherwise, assume
+that C<X> has integer coefficients.
+
+4 (cleanup): if set, cleans up the output. This means that elementary
+divisors equal to C<1> will be deleted, i.e.S< >outputs a shortened vector C<D'>
+instead of C<D>. If complete output was required, returns C<[U',V',D']> so
+that C<U'XV' = D'> holds. If this flag is set, C<X> is allowed to be of the
+form C<D> or C<[U,V,D]> as would normally be output with the cleanup flag
+unset.
+
+X<matsnf0>The library syntax is B<matsnf0>C<(X,I<flag>)>. Also available is C<X<smith>B<smith>(X)> (C<I<flag> = 0>).
+
+=head2 X<matsolve>matsolveC<(x,y)>
+
+C<x> being an invertible matrix and C<y> a column
+vector, finds the solution C<u> of C<x*u = y>, using Gaussian elimination. This
+has the same effect as, but is a bit faster, than C<x^{-1}*y>.
+
+X<gauss>The library syntax is B<gauss>C<(x,y)>.
+
+=head2 X<matsolvemod>matsolvemodC<(m,d,y,{I<flag> = 0})>
+
+C<m> being any integral matrix,
+C<d> a vector of positive integer moduli, and C<y> an integral
+column vector, gives a small integer solution to the system of congruences
+C<F<sum>_i m_{i,j}x_j = y_i (mod d_i)> if one exists, otherwise returns
+zero. Shorthand notation: C<y> (resp.S< >C<d>) can be given as a single integer,
+in which case all the C<y_i> (resp.S< >C<d_i>) above are taken to be equal to C<y>
+(resp.S< >C<d>).
+
+If C<I<flag> = 1>, all solutions are returned in the form of a two-component row
+vector C<[x,u]>, where C<x> is a small integer solution to the system of
+congruences and C<u> is a matrix whose columns give a basis of the homogeneous
+system (so that all solutions can be obtained by adding C<x> to any linear
+combination of columns of C<u>). If no solution exists, returns zero.
+
+X<matsolvemod0>The library syntax is B<matsolvemod0>C<(m,d,y,I<flag>)>. Also available
+are C<X<gaussmodulo>B<gaussmodulo>(m,d,y)> (C<I<flag> = 0>)
+and C<X<gaussmodulo2>B<gaussmodulo2>(m,d,y)> (C<I<flag> = 1>).
+
+=head2 X<matsupplement>matsupplementC<(x)>
+
+assuming that the columns of the matrix C<x>
+are linearly independent (if they are not, an error message is issued), finds
+a square invertible matrix whose first columns are the columns of C<x>,
+i.e.S< >supplement the columns of C<x> to a basis of the whole space.
+
+X<suppl>The library syntax is B<suppl>C<(x)>.
+
+=head2 X<mattranspose>mattransposeC<(x)> or C<x~>
+
+transpose of C<x>.
+This has an effect only on vectors and matrices.
+
+X<gtrans>The library syntax is B<gtrans>C<(x)>.
+
+=head2 X<qfgaussred>qfgaussredC<(q)>
+
+X<decomposition into squares>decomposition into squares of the
+quadratic form represented by the symmetric matrix C<q>. The result is a
+matrix whose diagonal entries are the coefficients of the squares, and the
+non-diagonal entries represent the bilinear forms. More precisely, if
+C<(a_{ij})> denotes the output, one has
+
+S< >C< q(x) = F<sum>_i a_{ii} (x_i + F<sum>_{j E<gt> i} a_{ij} x_j)^2 >
+
+X<sqred>The library syntax is B<sqred>C<(x)>.
+
+=head2 X<qfjacobi>qfjacobiC<(x)>
+
+C<x> being a real symmetric matrix, this gives a
+vector having two components: the first one is the vector of eigenvalues of
+C<x>, the second is the corresponding orthogonal matrix of eigenvectors of
+C<x>. The method used is Jacobi's method for symmetric matrices.
+
+X<jacobi>The library syntax is B<jacobi>C<(x)>.
+
+=head2 X<qflll>qflllC<(x,{I<flag> = 0})>
+
+X<LLL>LLL algorithm applied to the
+I<columns> of the (not necessarily square) matrix C<x>. The columns of C<x>
+must however be linearly independent, unless specified otherwise below. The
+result is a transformation matrix C<T> such that C<x.T> is an LLL-reduced
+basis of the lattice generated by the column vectors of C<x>.
+
+If C<I<flag> = 0> (default), the computations are done with real numbers (i.e.S< >not
+with rational numbers) hence are fast but as presently programmed (version
+B<2.2.0>) are numerically unstable.
+
+If C<I<flag> = 1>, it is assumed that the corresponding Gram matrix is integral.
+The computation is done entirely with integers and the algorithm is both
+accurate and quite fast. In this case, C<x> needs not be of maximal rank, but
+if it is not, C<T> will not be square.
+
+If C<I<flag> = 2>, similar to case 1, except C<x> should be an integer matrix whose
+columns are linearly independent. The lattice generated by the columns of
+C<x> is first partially reduced before applying the LLL algorithm. [A basis
+is said to be I<partially reduced> if C<|v_i F<+-> v_j| E<gt>= |v_i|> for any
+two distinct basis vectors C<v_i, v_j>.]
+
+This can be significantly faster than C<I<flag> = 1> when one row is huge compared
+to the other rows.
+
+If C<I<flag> = 3>, all computations are done in rational numbers. This does not
+incur numerical instability, but is extremely slow. This function is
+essentially superseded by case 1, so will soon disappear.
+
+If C<I<flag> = 4>, C<x> is assumed to have integral entries, but needs not be of
+maximal rank. The result is a two-component vector of matricesS< >: the
+columns of the first matrix represent a basis of the integer kernel of C<x>
+(not necessarily LLL-reduced) and the second matrix is the transformation
+matrix C<T> such that C<x.T> is an LLL-reduced B<I<Z>>-basis of the image
+of the matrix C<x>.
+
+If C<I<flag> = 5>, case as case C<4>, but C<x> may have polynomial coefficients.
+
+If C<I<flag> = 7>, uses an older version of case C<0> above.
+
+If C<I<flag> = 8>, same as case C<0>, where C<x> may have polynomial coefficients.
+
+If C<I<flag> = 9>, variation on case C<1>, using content.
+
+X<qflll0>The library syntax is B<qflll0>C<(x,I<flag>,I<prec>)>. Also available are
+C<X<lll>B<lll>(x,I<prec>)> (C<I<flag> = 0>), C<X<lllint>B<lllint>(x)> (C<I<flag> = 1>), and
+C<X<lllkerim>B<lllkerim>(x)> (C<I<flag> = 4>).
+
+=head2 X<qflllgram>qflllgramC<(x,{I<flag> = 0})>
+
+same as C<qflll> except that the
+matrix C<x> which must now be a square symmetric real matrix is the Gram
+matrix of the lattice vectors, and not the coordinates of the vectors
+themselves. The result is again the transformation matrix C<T> which gives (as
+columns) the coefficients with respect to the initial basis vectors. The
+flags have more or less the same meaning, but some are missing. In brief:
+
+C<I<flag> = 0>: numerically unstable in the present version B<2.2.0>.
+
+C<I<flag> = 1>: C<x> has integer entries, the computations are all done in integers.
+
+C<I<flag> = 4>: C<x> has integer entries, gives the kernel and reduced image.
+
+C<I<flag> = 5>: same as C<4> for generic C<x>.
+
+C<I<flag> = 7>: an older version of case C<0>.
+
+X<qflllgram0>The library syntax is B<qflllgram0>C<(x,I<flag>,I<prec>)>. Also available are
+C<X<lllgram>B<lllgram>(x,I<prec>)> (C<I<flag> = 0>), C<X<lllgramint>B<lllgramint>(x)> (C<I<flag> = 1>), and
+C<X<lllgramkerim>B<lllgramkerim>(x)> (C<I<flag> = 4>).
+
+=head2 X<qfminim>qfminimC<(x,b,m,{I<flag> = 0})>
+
+C<x> being a square and symmetric
+matrix representing a positive definite quadratic form, this function
+deals with the minimal vectors of C<x>, depending on C<I<flag>>.
+
+If C<I<flag> = 0> (default), seeks vectors of square norm less than or equal to C<b>
+(for the norm defined by C<x>), and at most C<2m> of these vectors. The result
+is a three-component vector, the first component being the number of vectors,
+the second being the maximum norm found, and the last vector is a matrix
+whose columns are the vectors found, only one being given for each
+pair C<F<+-> v> (at most C<m> such pairs).
+
+If C<I<flag> = 1>, ignores C<m> and returns the first vector whose norm is less than
+C<b>.
+
+In both these cases, C<x> I<is assumed to have integral entries>, and the
+function searches for the minimal non-zero vectors whenever C<b = 0>.
+
+If C<I<flag> = 2>, C<x> can have non integral real entries, but C<b = 0> is now
+meaningless (uses Fincke-Pohst algorithm).
+
+X<qfminim0>The library syntax is B<qfminim0>C<(x,b,m,I<flag>,I<prec>)>, also available are C< B<minim>(x,b,m)>X<minim>
+(C<I<flag> = 0>), C< B<minim2>(x,b,m)>X<minim2> (C<I<flag> = 1>), and finally
+C< B<fincke_pohst>(x,b,m,I<prec>)>X<fincke_pohst> (C<I<flag> = 2>).
+
+=head2 X<qfperfection>qfperfectionC<(x)>
+
+C<x> being a square and symmetric matrix with
+integer entries representing a positive definite quadratic form, outputs the
+perfection rank of the form. That is, gives the rank of the family of the C<s>
+symmetric matrices C<v_iv_i^t>, where C<s> is half the number of minimal
+vectors and the C<v_i> (C<1 E<lt>= i E<lt>= s>) are the minimal vectors.
+
+As a side note to old-timers, this used to fail bluntly when C<x> had more
+than C<5000> minimal vectors. Beware that the computations can now be very
+lengthy when C<x> has many minimal vectors.
+
+X<perf>The library syntax is B<perf>C<(x)>.
+
+=head2 X<qfsign>qfsignC<(x)>
+
+signature of the quadratic form represented by the
+symmetric matrix C<x>. The result is a two-component vector.
+
+X<signat>The library syntax is B<signat>C<(x)>.
+
+=head2 X<setintersect>setintersectC<(x,y)>
+
+intersection of the two sets C<x> and C<y>.
+
+X<setintersect>The library syntax is B<setintersect>C<(x,y)>.
+
+=head2 X<setisset>setissetC<(x)>
+
+returns true (1) if C<x> is a set, false (0) if
+not. In PARI, a set is simply a row vector whose entries are strictly
+increasing. To convert any vector (and other objects) into a set, use the
+function C<Set>.
+
+X<setisset>The library syntax is B<setisset>C<(x)>, and this returns a C<long>.
+
+=head2 X<setminus>setminusC<(x,y)>
+
+difference of the two sets C<x> and C<y>,
+i.e.S< >set of elements of C<x> which do not belong to C<y>.
+
+X<setminus>The library syntax is B<setminus>C<(x,y)>.
+
+=head2 X<setsearch>setsearchC<(x,y,{I<flag> = 0})>
+
+searches if C<y> belongs to the set
+C<x>. If it does and C<I<flag>> is zero or omitted, returns the index C<j> such that
+C<x[j] = y>, otherwise returns 0. If C<I<flag>> is non-zero returns the index C<j>
+where C<y> should be inserted, and C<0> if it already belongs to C<x> (this is
+meant to be used in conjunction with C<listinsert>).
+
+This function works also if C<x> is a I<sorted> list (see C<listsort>).
+
+X<setsearch>The library syntax is B<setsearch>C<(x,y,I<flag>)> which returns a C<long>
+integer.
+
+=head2 X<setunion>setunionC<(x,y)>
+
+union of the two sets C<x> and C<y>.
+
+X<setunion>The library syntax is B<setunion>C<(x,y)>.
+
+=head2 X<trace>traceC<(x)>
+
+this applies to quite general C<x>. If C<x> is not a
+matrix, it is equal to the sum of C<x> and its conjugate, except for polmods
+where it is the trace as an algebraic number.
+
+For C<x> a square matrix, it is the ordinary trace. If C<x> is a
+non-square matrix (but not a vector), an error occurs.
+
+X<gtrace>The library syntax is B<gtrace>C<(x)>.
+
+=head2 X<vecextract>vecextractC<(x,y,{z})>
+
+extraction of components of the
+vector or matrix C<x> according to C<y>. In case C<x> is a matrix, its
+components are as usual the I<columns> of C<x>. The parameter C<y> is a
+component specifier, which is either an integer, a string describing a
+range, or a vector.
+
+If C<y> is an integer, it is considered as a mask: the binary bits of C<y> are
+read from right to left, but correspond to taking the components from left to
+right. For example, if C<y = 13 = (1101)_2> then the components 1,3 and 4 are
+extracted.
+
+If C<y> is a vector, which must have integer entries, these entries correspond
+to the component numbers to be extracted, in the order specified.
+
+If C<y> is a string, it can be
+
+C<B<*>> a single (non-zero) index giving a component number (a negative
+index means we start counting from the end).
+
+C<B<*>> a range of the form C<"a..b">, where C<a> and C<b> are
+indexes as above. Any of C<a> and C<b> can be omitted; in this case, we take
+as default values C<a = 1> and C<b = -1>, i.e.S< >the first and last components
+respectively. We then extract all components in the interval C<[a,b]>, in
+reverse order if C<b E<lt> a>.
+
+In addition, if the first character in the string is C<^>, the
+complement of the given set of indices is taken.
+
+If C<z> is not omitted, C<x> must be a matrix. C<y> is then the I<line>
+specifier, and C<z> the I<column> specifier, where the component specifier
+is as explained above.
+
+ ? v = [a, b, c, d, e];
+ ? vecextract(v, 5) \\ mask
+ %1 = [a, c]
+ ? vecextract(v, [4, 2, 1]) \\ component list
+ %2 = [d, b, a]
+ ? vecextract(v, "2..4") \\ interval
+ %3 = [b, c, d]
+ ? vecextract(v, "-1..-3") \\ interval + reverse order
+ %4 = [e, d, c]
+ ? vecextract([1,2,3], "^2") \\ complement
+ %5 = [1, 3]
+ ? vecextract(matid(3), "2..", "..")
+ %6 =
+ [0 1 0]
+
+ [0 0 1]
+
+X<extract>The library syntax is B<extract>C<(x,y)> or C<X<matextract>B<matextract>(x,y,z)>.
+
+=head2 X<vecsort>vecsortC<(x,{k},{I<flag> = 0})>
+
+sorts the vector C<x> in ascending
+order, using the heapsort method. C<x> must be a vector, and its components
+integers, reals, or fractions.
+
+If C<k> is present and is an integer, sorts according to the value of the
+C<k>-th subcomponents of the components ofS< >C<x>. C<k> can also be a vector,
+in which case the
+sorting is done lexicographically according to the components listed in the
+vector C<k>. For example, if C<k = [2,1,3]>, sorting will be done with respect
+to the second component, and when these are equal, with respect to the
+first, and when these are equal, with respect to the third.
+
+The binary digits of I<flag> mean:
+
+C<B<*>> 1: indirect sorting of the vector C<x>, i.e.S< >if C<x> is an
+C<n>-component vector, returns a permutation of C<[1,2,...,n]> which
+applied to the components of C<x> sorts C<x> in increasing order.
+For example, C<vecextract(x, vecsort(x,,1))> is equivalent to
+C<vecsort(x)>.
+
+C<B<*>> 2: sorts C<x> by ascending lexicographic order (as per the
+C<lex> comparison function).
+
+C<B<*>> 4: use decreasing instead of ascending order.
+
+X<vecsort0>The library syntax is B<vecsort0>C<(x,k,flag)>. To omit C<k>, use C<NULL> instead. You can also
+use the simpler functions
+
+C<X<sort>B<sort>(x)> ( = C<vecsort0(x,NULL,0)>).
+
+C<X<indexsort>B<indexsort>(x)> ( = C<vecsort0(x,NULL,1)>).
+
+C<X<lexsort>B<lexsort>(x)> ( = C<vecsort0(x,NULL,2)>).
+
+Also available are X<sindexsort>B<sindexsort> and X<sindexlexsort>B<sindexlexsort> which return a
+vector of C-long integers (private type C<t_VECSMALL>) C<v>, where
+C<v[1]...v[n]> contain the indices. Note that the resulting C<v> is
+I<not> a generic PARI object, but is in general easier to use in C
+programs!
+
+=head2 X<vector>vectorC<(n,{X},{I<expr> = 0})>
+
+creates a row vector (type
+C<t_VEC>) with C<n> components whose components are the expression
+I<expr> evaluated at the integer points between 1 and C<n>. If one of the
+last two arguments is omitted, fill the vector with zeroes.
+
+X<vecteur>The library syntax is B<vecteur>C<(GEN nmax, entree *ep, char *expr)>.
+
+=head2 X<vectorv>vectorvC<(n,X,I<expr>)>
+
+as X<vector>B<vector>, but returns a
+column vector (type C<t_COL>).
+
+X<vvecteur>The library syntax is B<vvecteur>C<(GEN nmax, entree *ep, char *expr)>.
+
+=head1 Sums, products, integrals and similar functions
+
+X<Label se:sums>
+Although the GP calculator is programmable, it is useful to have
+preprogrammed a number of loops, including sums, products, and a certain
+number of recursions. Also, a number of functions from numerical analysis
+like numerical integration and summation of series will be described here.
+
+One of the parameters in these loops must be the control variable, hence a
+simple variable name. The last parameter can be any legal PARI expression,
+including of course expressions using loops. Since it is much easier to
+program directly the loops in library mode, these functions are mainly
+useful for GP programming. The use of these functions in library mode is a
+little tricky and its explanation will be mostly omitted, although the
+reader can try and figure it out by himself by checking the example given
+for the X<sum>C<sum> function. In this section we only give the library
+syntax, with no semantic explanation.
+
+The letter C<X> will always denote any simple variable name, and represents
+the formal parameter used in the function.
+
+B<(numerical) integration>:X<numerical integration> A number
+of Romberg-like integration methods are implemented (see C<intnum> as
+opposed to C<intformal> which we already described). The user should not
+require too much accuracy: 18 or 28 decimal digits is OK, but not much more.
+In addition, analytical cleanup of the integral must have been done: there
+must be no singularities in the interval or at the boundaries. In practice
+this can be accomplished with a simple change of variable. Furthermore, for
+improper integrals, where one or both of the limits of integration are plus
+or minus infinity, the function must decrease sufficiently rapidly at
+infinity. This can often be accomplished through integration by parts.
+Finally, the function to be integrated should not be very small
+(compared to the current precision) on the entire interval. This can
+of course be accomplished by just multiplying by an appropriate
+constant.
+
+Note that X<infinity>infinity can be represented with essentially no loss of
+accuracy by 1e4000. However beware of real underflow when dealing with
+rapidly decreasing functions. For example, if one wants to compute the
+C<F<int>_0^ oo e^{-x^2}dx> to 28 decimal digits, then one should set
+infinity equal to 10 for example, and certainly not to 1e4000.
+
+The integrand may have values belonging to a vector space over the real
+numbers; in particular, it can be complex-valued or vector-valued.
+
+See also the discrete summation methods below (sharing the prefix C<sum>).
+
+=head2 X<intnum>intnumC<(X = a,b,I<expr>,{I<flag> = 0})>
+
+numerical integration of
+I<expr> (smooth in C<]a,b[>), with respect to C<X>.
+
+Set C<I<flag> = 0> (or omit it altogether) when C<a> and C<b> are not too large, the
+function is smooth, and can be evaluated exactly everywhere on the interval
+C<[a,b]>.
+
+If C<I<flag> = 1>, uses a general driver routine for doing numerical integration,
+making no particular assumption (slow).
+
+C<I<flag> = 2> is tailored for being used when C<a> or C<b> are infinite. One
+I<must> have C<ab E<gt> 0>, and in fact if for example C<b = + oo >, then it is
+preferable to have C<a> as large as possible, at least C<a E<gt>= 1>.
+
+If C<I<flag> = 3>, the function is allowed to be undefined (but continuous) at C<a>
+or C<b>, for example the function C< F<sin> (x)/x> at C<x = 0>.
+
+X<intnum0>The library syntax is B<intnum0>C<(entree*e,GEN a,GEN b,char*expr,long I<flag>,long prec)>.
+
+=head2 X<prod>prodC<(X = a,b,I<expr>,{x = 1})>
+
+product of expression I<expr>,
+initialized at C<x>, the formal parameter C<X> going from C<a> to C<b>. As for
+C<sum>, the main purpose of the initialization parameter C<x> is to force
+the type of the operations being performed. For example if it is set equal to
+the integer 1, operations will start being done exactly. If it is set equal
+to the real C<1.>, they will be done using real numbers having the default
+precision. If it is set equal to the power series C<1+O(X^k)> for a certain
+C<k>, they will be done using power series of precision at most C<k>. These
+are the three most common initializations.
+
+As an extreme example, compare
+
+ ? prod(i=1, 100, 1 - X^i); \\ this has degree 5050 !!
+ time = 3,335 ms.
+ ? prod(i=1, 100, 1 - X^i, 1 + O(X^101))
+ time = 43 ms.
+ %2 = 1 - X - X^2 + X^5 + X^7 - X^12 - X^15 + X^22 + X^26 - X^35 - X^40 + \
+ X^51 + X^57 - X^70 - X^77 + X^92 + X^100 + O(X^101)
+
+X<produit>The library syntax is B<produit>C<(entree *ep, GEN a, GEN b, char *expr, GEN x)>.
+
+=head2 X<prodeuler>prodeulerC<(X = a,b,I<expr>)>
+
+product of expression I<expr>,
+initialized at 1. (i.e.S< >to a I<real> number equal to 1 to the current
+C<realprecision>), the formal parameter C<X> ranging over the prime numbers
+between C<a> and C<b>.X<Euler product>
+
+X<prodeuler>The library syntax is B<prodeuler>C<(entree *ep, GEN a, GEN b, char *expr, long prec)>.
+
+=head2 X<prodinf>prodinfC<(X = a,I<expr>,{I<flag> = 0})>
+
+X<infinite product>infinite product of
+expression I<expr>, the formal parameter C<X> starting at C<a>. The evaluation
+stops when the relative error of the expression minus 1 is less than the
+default precision. The expressions must always evaluate to an element of
+B<I<C>>.
+
+If C<I<flag> = 1>, do the product of the (C<1+I<expr>>) instead.
+
+X<prodinf>The library syntax is B<prodinf>C<(entree *ep, GEN a, char *expr, long prec)> (C<I<flag> = 0>), or
+X<prodinf1>B<prodinf1> with the same arguments (C<I<flag> = 1>).
+
+=head2 X<solve>solveC<(X = a,b,I<expr>)>
+
+find a real root of expression
+I<expr> between C<a> and C<b>, under the condition
+C<I<expr>(X = a) * I<expr>(X = b) E<lt>= 0>.
+This routine uses Brent's method and can fail miserably if I<expr> is
+not defined in the whole of C<[a,b]> (try C<solve(x = 1, 2, tan(x)>).
+
+X<zbrent>The library syntax is B<zbrent>C<(entree *ep, GEN a, GEN b, char *expr, long prec)>.
+
+=head2 X<sum>sumC<(X = a,b,I<expr>,{x = 0})>
+
+sum of expression I<expr>,
+initialized at C<x>, the formal parameter going from C<a> to C<b>. As for
+C<prod>, the initialization parameter C<x> may be given to force the type
+of the operations being performed.
+
+As an extreme example, compare
+
+ ? sum(i=1, 5000, 1/i); \\ rational number: denominator has 2166 digits.
+ time = 1,241 ms.
+ ? sum(i=1, 5000, 1/i, 0.)
+ time = 158 ms.
+ %2 = 9.094508852984436967261245533
+
+X<somme>The library syntax is B<somme>C<(entree *ep, GEN a, GEN b, char *expr, GEN x)>. This is to be
+used as follows: C<ep> represents the dummy variable used in the
+expression C<expr>
+
+ /* compute a^2 + ... + b^2 */
+ {
+ /* define the dummy variable "i" */
+ entree *ep = is_entry("i");
+ /* sum for a <= i <= b */
+ return somme(ep, a, b, "i^2", gzero);
+ }
+
+=head2 X<sumalt>sumaltC<(X = a,I<expr>,{I<flag> = 0})>
+
+numerical summation of the
+series I<expr>, which should be an X<alternating series>alternating series, the formal
+variable C<X> starting at C<a>.
+
+If C<I<flag> = 0>, use an algorithm of F.S< >Villegas as modified by D.S< >Zagier. This
+is much better than X<Euler>Euler-Van Wijngaarden's method which was used
+formerly.
+Beware that the stopping criterion is that the term gets small enough, hence
+terms which are equal to 0 will create problems and should be removed.
+
+If C<I<flag> = 1>, use a variant with slightly different polynomials. Sometimes
+faster.
+
+Divergent alternating series can sometimes be summed by this method, as well
+as series which are not exactly alternating (see for example
+L<Label se:user_defined>).
+
+B<Important hint:> a significant speed gain can be obtained by
+writing the C<(-1)^X> which may occur in the expression as
+C<(1.S< >- X%2*2)>.
+
+X<sumalt>The library syntax is B<sumalt>C<(entree *ep, GEN a, char *expr, long I<flag>, long prec)>.
+
+=head2 X<sumdiv>sumdivC<(n,X,I<expr>)>
+
+sum of expression I<expr> over
+the positive divisors of C<n>.
+
+Arithmetic functions like X<sigma>B<sigma> use the multiplicativity of the
+underlying expression to speed up the computation. In the present version
+B<2.2.0>, there is no way to indicate that I<expr> is multiplicative in
+C<n>, hence specialized functions should be prefered whenever possible.
+
+X<divsum>The library syntax is B<divsum>C<(entree *ep, GEN num, char *expr)>.
+
+=head2 X<suminf>suminfC<(X = a,I<expr>)>
+
+X<infinite sum>infinite sum of expression
+I<expr>, the formal parameter C<X> starting at C<a>. The evaluation stops
+when the relative error of the expression is less than the default precision.
+The expressions must always evaluate to a complex number.
+
+X<suminf>The library syntax is B<suminf>C<(entree *ep, GEN a, char *expr, long prec)>.
+
+=head2 X<sumpos>sumposC<(X = a,I<expr>,{I<flag> = 0})>
+
+numerical summation of the
+series I<expr>, which must be a series of terms having the same sign,
+the formal
+variable C<X> starting at C<a>. The algorithm used is Van Wijngaarden's trick
+for converting such a series into an alternating one, and is quite slow.
+Beware that the stopping criterion is that the term gets small enough, hence
+terms which are equal to 0 will create problems and should be removed.
+
+If C<I<flag> = 1>, use slightly different polynomials. Sometimes faster.
+
+X<sumpos>The library syntax is B<sumpos>C<(entree *ep, GEN a, char *expr, long I<flag>, long prec)>.
+
+=head1 Plotting functions
+
+Although plotting is not even a side purpose of PARI, a number of plotting
+functions are provided. Moreover, a lot of people felt like suggesting
+ideas or submitting huge patches for this section of the code. Among these,
+special thanks go to Klaus-Peter Nischke who suggested the recursive plotting
+and the forking/resizing stuff under X11, and Ilya Zakharevich who
+undertook a complete rewrite of the graphic code, so that most of it is now
+platform-independent and should be relatively easy to port or expand.
+
+These graphic functions are either
+
+C<B<*>> high-level plotting functions (all the functions starting with
+C<ploth>) in which the user has little to do but explain what type of plot
+he wants, and whose syntax is similar to the one used in the preceding
+section (with somewhat more complicated flags).
+
+C<B<*>> low-level plotting functions, where every drawing primitive (point,
+line, box, etc.) must be specified by the user. These low-level functions
+(called I<rectplot> functions, sharing the prefix C<plot>) work as
+follows. You have at your disposal 16 virtual windows which are filled
+independently, and can then be physically ORed on a single window at
+user-defined positions. These windows are numbered from 0 to 15, and must be
+initialized before being used by the function C<plotinit>, which specifies
+the height and width of the virtual window (called a I<rectwindow> in the
+sequel). At all times, a virtual cursor (initialized at C<[0,0]>) is
+associated to the window, and its current value can be obtained using the
+function C<plotcursor>.
+
+A number of primitive graphic objects (called I<rect> objects) can then
+be drawn in these windows, using a default color associated to that window
+(which can be changed under X11, using the C<plotcolor> function, black
+otherwise) and only the part of the object which is inside the window will be
+drawn, with the exception of polygons and strings which are drawn entirely
+(but the virtual cursor can move outside of the window). The ones sharing the
+prefix C<plotr> draw relatively to the current position of the virtual
+cursor, the others use absolute coordinates. Those having the prefix
+C<plotrecth> put in the rectwindow a large batch of rect objects
+corresponding to the output of the related C<ploth> function.
+
+Finally, the actual physical drawing is done using the function
+C<plotdraw>. Note that the windows are preserved so that further drawings
+using the same windows at different positions or different windows can be
+done without extra work. If you want to erase a window (and free the
+corresponding memory), use the function C<plotkill>. It is not possible to
+partially erase a window. Erase it completely, initialize it again and then
+fill it with the graphic objects that you want to keep.
+
+In addition to initializing the window, you may want to have a scaled
+window to avoid unnecessary conversions. For this, use the function
+C<plotscale> below. As long as this function is not called, the scaling is
+simply the number of pixels, the origin being at the upper left and the
+C<y>-coordinates going downwards.
+
+Note that in the present version B<2.2.0> all these plotting functions
+(both low and high level) have been written for the X11-window system
+(hence also for GUI's based on X11 such as Openwindows and Motif) only,
+though very little code remains which is actually platform-dependent. A
+Suntools/Sunview, Macintosh, and an Atari/Gem port were provided for
+previous versions. These I<may> be adapted in future releases.
+
+Under X11/Suntools, the physical window (opened by C<plotdraw> or any
+of the C<ploth*> functions) is completely separated from GP (technically,
+a C<fork> is done, and the non-graphical memory is immediately freed in
+the child process), which means you can go on working in the current GP
+session, without having to kill the window first. Under X11, this window can
+be closed, enlarged or reduced using the standard window manager functions.
+No zooming procedure is implemented though (yet).
+
+C<B<*>> Finally, note that in the same way that C<printtex> allows you
+to have a TeX output corresponding to printed results, the functions
+starting with C<ps> allow you to have X<PostScript>C<PostScript> output of the
+plots. This will not be absolutely identical with the screen output, but will
+be sufficiently close. Note that you can use PostScript output even if you do
+not have the plotting routines enabled. The PostScript output is written in a
+file whose name is derived from the X<psfile>C<psfile> default (C<./pari.ps> if
+you did not tamper with it). Each time a new PostScript output is asked for,
+the PostScript output is appended to that file. Hence the user must remove
+this file, or change the value of C<psfile>, first if he does not want
+unnecessary drawings from preceding sessions to appear. On the other hand, in
+this manner as many plots as desired can be kept in a single file.
+
+I<None of the graphic functions are available within the PARI library, you
+must be under GP to use them>. The reason for that is that you really should
+not use PARI for heavy-duty graphical work, there are much better specialized
+alternatives around. This whole set of routines was only meant as a
+convenient, but simple-minded, visual aid. If you really insist on using
+these in your program (we warned you), the source (C<plot*.c>) should be
+readable enough for you to achieve something.
+
+=head2 X<plot>plotC<(X = a,b,I<expr>,{I<Ymin>},{I<Ymax>})>
+
+crude
+(ASCII) plot of the function represented by expression I<expr> from
+C<a> to C<b>, with I<Y> ranging from I<Ymin> to I<Ymax>. If
+I<Ymin> (resp. I<Ymax>) is not given, the minima (resp. the
+maxima) of the computed values of the expression is used instead.
+
+=head2 X<plotbox>plotboxC<(w,x2,y2)>
+
+let C<(x1,y1)> be the current position of the
+virtual cursor. Draw in the rectwindow C<w> the outline of the rectangle which
+is such that the points C<(x1,y1)> and C<(x2,y2)> are opposite corners. Only
+the part of the rectangle which is in C<w> is drawn. The virtual cursor does
+I<not> move.
+
+=head2 X<plotclip>plotclipC<(w)>
+
+`clips' the content of rectwindow C<w>, i.e
+remove all parts of the drawing that would not be visible on the screen.
+Together with X<plotcopy>C<plotcopy> this function enables you to draw on a
+scratchpad before commiting the part you're interested in to the final
+picture.
+
+=head2 X<plotcolor>plotcolorC<(w,c)>
+
+set default color to C<c> in rectwindow C<w>.
+In present version B<2.2.0>, this is only implemented for X11 window system,
+and you only have the following palette to choose from:
+
+1 = black, 2 = blue, 3 = sienna, 4 = red, 5 = cornsilk, 6 = grey, 7 = gainsborough.
+
+Note that it should be fairly easy for you to hardwire some more colors by
+tweaking the files C<rect.h> and C<plotX.c>. User-defined
+colormaps would be nice, and I<may> be available in future versions.
+
+=head2 X<plotcopy>plotcopyC<(w1,w2,dx,dy)>
+
+copy the contents of rectwindow
+C<w1> to rectwindow C<w2>, with offset C<(dx,dy)>.
+
+=head2 X<plotcursor>plotcursorC<(w)>
+
+give as a 2-component vector the current
+(scaled) position of the virtual cursor corresponding to the rectwindow C<w>.
+
+=head2 X<plotdraw>plotdrawC<(list)>
+
+physically draw the rectwindows given in C<list>
+which must be a vector whose number of components is divisible by 3. If
+C<list = [w1,x1,y1,w2,x2,y2,...]>, the windows C<w1>, C<w2>, etc.S< >are
+physically placed with their upper left corner at physical position
+C<(x1,y1)>, C<(x2,y2)>,...respectively, and are then drawn together.
+Overlapping regions will thus be drawn twice, and the windows are considered
+transparent. Then display the whole drawing in a special window on your
+screen.
+
+=head2 X<plotfile>plotfileC<(s)>
+
+set the output file for plotting output. Special
+filename C<-> redirects to the same place as PARI output.
+
+=head2 X<ploth>plothC<(X = a,b,I<expr>,{I<flag> = 0},{n = 0})>
+
+high precision
+plot of the function C<y = f(x)> represented by the expression I<expr>, C<x>
+going from C<a> to C<b>. This opens a specific window (which is killed
+whenever you click on it), and returns a four-component vector giving the
+coordinates of the bounding box in the form
+C<[I<xmin>,I<xmax>,I<ymin>,I<ymax>]>.
+
+B<Important note>: Since this may involve a lot of function calls,
+it is advised to keep the current precision to a minimum (e.g.S< >9) before
+calling this function.
+
+C<n> specifies the number of reference point on the graph (0 means use the
+hardwired default values, that is: 1000 for general plot, 1500 for
+parametric plot, and 15 for recursive plot).
+
+If no C<I<flag>> is given, I<expr> is either a scalar expression C<f(X)>, in which
+case the plane curve C<y = f(X)> will be drawn, or a vector
+C<[f_1(X),...,f_k(X)]>, and then all the curves C<y = f_i(X)> will be drawn in
+the same window.
+
+The binary digits of C<I<flag>> mean:
+
+C<B<*>> 1: X<parametric plot>I<parametric plot>. Here I<expr> must be a vector with
+an even number of components. Successive pairs are then understood as the
+parametric coordinates of a plane curve. Each of these are then drawn.
+
+For instance:
+
+C<ploth(X = 0,2*Pi,[sin(X),cos(X)],1)> will draw a circle.
+
+C<ploth(X = 0,2*Pi,[sin(X),cos(X)])> will draw two entwined sinusoidal
+curves.
+
+C<ploth(X = 0,2*Pi,[X,X,sin(X),cos(X)],1)> will draw a circle and the line
+C<y = x>.
+
+C<B<*>> 2: X<recursive plot>I<recursive plot>. If this flag is set, only I<one>
+curve can be drawn at time, i.e.S< >I<expr> must be either a two-component
+vector (for a single parametric curve, and the parametric flag I<has> to
+be set), or a scalar function. The idea is to choose pairs of successive
+reference points, and if their middle point is not too far away from the
+segment joining them, draw this as a local approximation to the curve.
+Otherwise, add the middle point to the reference points. This is very fast,
+and usually more precise than usual plot. Compare the results of
+
+S< >C<ploth(X = -1,1,sin(1/X),2) and ploth(X = -1,1,sin(1/X))>
+
+for instance. But beware that if you are extremely unlucky, or choose too few
+reference points, you may draw some nice polygon bearing little resemblance
+to the original curve. For instance you should I<never> plot recursively
+an odd function in a symmetric interval around 0. Try
+
+ ploth(x = -20, 20, sin(x), 2)
+
+to see why. Hence, it's usually a good idea to try and plot the same
+curve with slightly different parameters.
+
+The other values toggle various display options:
+
+C<B<*>> 4: do not rescale plot according to the computed extrema. This is
+meant to be used when graphing multiple functions on a rectwindow (as a
+X<plotrecth>C<plotrecth> call), in conjuction with X<plotscale>C<plotscale>.
+
+C<B<*>> 8: do not print the C<x>-axis.
+
+C<B<*>> 16: do not print the C<y>-axis.
+
+C<B<*>> 32: do not print frame.
+
+C<B<*>> 64: only plot reference points, do not join them.
+
+C<B<*>> 256: use splines to interpolate the points.
+
+C<B<*>> 512: plot no C<x>-ticks.
+
+C<B<*>> 1024: plot no C<y>-ticks.
+
+C<B<*>> 2048: plot all ticks with the same length.
+
+=head2 X<plothraw>plothrawC<(I<listx>,I<listy>,{I<flag> = 0})>
+
+given
+I<listx> and I<listy> two vectors of equal length, plots (in high
+precision) the points whose C<(x,y)>-coordinates are given in I<listx>
+and I<listy>. Automatic positioning and scaling is done, but with the
+same scaling factor on C<x> and C<y>. If C<I<flag>> is 1, join points, other non-0
+flags toggle display options and should be combinations of bits C<2^k>, C<k
+ E<gt>= 3> as in C<ploth>.
+
+=head2 X<plothsizes>plothsizesC<()>
+
+return data corresponding to the output window
+in the form of a 6-component vector: window width and height, sizes for ticks
+in horizontal and vertical directions (this is intended for the C<gnuplot>
+interface and is currently not significant), width and height of characters.
+
+=head2 X<plotinit>plotinitC<(w,x,y)>
+
+initialize the rectwindow C<w> to width C<x> and
+height C<y>, and position the virtual cursor at C<(0,0)>. This destroys any rect
+objects you may have already drawn in C<w>.
+
+The plotting device imposes an upper bound for C<x> and C<y>, for instance the
+number of pixels for screen output. These bounds are available through the
+X<plothsizes>C<plothsizes> function. The following sequence initializes in a portable way
+(i.e independant of the output device) a window of maximal size, accessed through
+coordinates in the C<[0,1000] x [0,1000]> rangeS< >:
+
+ s = plothsizes();
+ plotinit(0, s[1]-1, s[2]-1);
+ plotscale(0, 0,1000, 0,1000);
+
+=head2 X<plotkill>plotkillC<(w)>
+
+erase rectwindow C<w> and free the corresponding
+memory. Note that if you want to use the rectwindow C<w> again, you have to
+use C<initrect> first to specify the new size. So it's better in this case
+to use C<initrect> directly as this throws away any previous work in the
+given rectwindow.
+
+=head2 X<plotlines>plotlinesC<(w,X,Y,{I<flag> = 0})>
+
+draw on the rectwindow C<w>
+the polygon such that the (x,y)-coordinates of the vertices are in the
+vectors of equal length C<X> and C<Y>. For simplicity, the whole
+polygon is drawn, not only the part of the polygon which is inside the
+rectwindow. If C<I<flag>> is non-zero, close the polygon. In any case, the
+virtual cursor does not move.
+
+C<X> and C<Y> are allowed to be scalars (in this case, both have to).
+There, a single segment will be drawn, between the virtual cursor current
+position and the point C<(X,Y)>. And only the part thereof which
+actually lies within the boundary of C<w>. Then I<move> the virtual cursor
+to C<(X,Y)>, even if it is outside the window. If you want to draw a
+line from C<(x1,y1)> to C<(x2,y2)> where C<(x1,y1)> is not necessarily the
+position of the virtual cursor, use C<plotmove(w,x1,y1)> before using this
+function.
+
+=head2 X<plotlinetype>plotlinetypeC<(w,I<type>)>
+
+change the type of lines
+subsequently plotted in rectwindow C<w>. I<type> C<-2> corresponds to
+frames, C<-1> to axes, larger values may correspond to something else. C<w =
+-1> changes highlevel plotting. This is only taken into account by the
+C<gnuplot> interface.
+
+=head2 X<plotmove>plotmoveC<(w,x,y)>
+
+move the virtual cursor of the rectwindow C<w>
+to position C<(x,y)>.
+
+=head2 X<plotpoints>plotpointsC<(w,X,Y)>
+
+draw on the rectwindow C<w> the
+points whose C<(x,y)>-coordinates are in the vectors of equal length C<X> and
+C<Y> and which are inside C<w>. The virtual cursor does I<not> move. This
+is basically the same function as C<plothraw>, but either with no scaling
+factor or with a scale chosen using the function C<plotscale>.
+
+As was the case with the C<plotlines> function, C<X> and C<Y> are allowed to
+be (simultaneously) scalar. In this case, draw the single point C<(X,Y)> on
+the rectwindow C<w> (if it is actually inside C<w>), and in any case
+I<move> the virtual cursor to position C<(x,y)>.
+
+=head2 X<plotpointsize>plotpointsizeC<(w,size)>
+
+changes the ``size'' of following
+points in rectwindow C<w>. If C<w = -1>, change it in all rectwindows.
+This only works in the C<gnuplot> interface.
+
+=head2 X<plotpointtype>plotpointtypeC<(w,I<type>)>
+
+change the type of
+points subsequently plotted in rectwindow C<w>. C<I<type> = -1>
+corresponds to a dot, larger values may correspond to something else. C<w = -1>
+changes highlevel plotting. This is only taken into account by the
+C<gnuplot> interface.
+
+=head2 X<plotrbox>plotrboxC<(w,dx,dy)>
+
+draw in the rectwindow C<w> the outline of
+the rectangle which is such that the points C<(x1,y1)> and C<(x1+dx,y1+dy)> are
+opposite corners, where C<(x1,y1)> is the current position of the cursor.
+Only the part of the rectangle which is in C<w> is drawn. The virtual cursor
+does I<not> move.
+
+=head2 X<plotrecth>plotrecthC<(w,X = a,b,I<expr>,{I<flag> = 0},{n = 0})>
+
+writes to
+rectwindow C<w> the curve output of C<ploth>C<(w,X = a,b,I<expr>,I<flag>,n)>.
+
+=head2 X<plotrecthraw>plotrecthrawC<(w,I<data>,{I<flag> = 0})>
+
+plot graph(s) for
+I<data> in rectwindow C<w>. C<I<flag>> has the same significance here as in
+C<ploth>, though recursive plot is no more significant.
+
+I<data> is a vector of vectors, each corresponding to a list a coordinates.
+If parametric plot is set, there must be an even number of vectors, each
+successive pair corresponding to a curve. Otherwise, the first one containe
+the C<x> coordinates, and the other ones contain the C<y>-coordinates
+of curves to plot.
+
+=head2 X<plotrline>plotrlineC<(w,dx,dy)>
+
+draw in the rectwindow C<w> the part of the
+segment C<(x1,y1)-(x1+dx,y1+dy)> which is inside C<w>, where C<(x1,y1)> is the
+current position of the virtual cursor, and move the virtual cursor to
+C<(x1+dx,y1+dy)> (even if it is outside the window).
+
+=head2 X<plotrmove>plotrmoveC<(w,dx,dy)>
+
+move the virtual cursor of the rectwindow
+C<w> to position C<(x1+dx,y1+dy)>, where C<(x1,y1)> is the initial position of
+the cursor (i.e.S< >to position C<(dx,dy)> relative to the initial cursor).
+
+=head2 X<plotrpoint>plotrpointC<(w,dx,dy)>
+
+draw the point C<(x1+dx,y1+dy)> on the
+rectwindow C<w> (if it is inside C<w>), where C<(x1,y1)> is the current position
+of the cursor, and in any case move the virtual cursor to position
+C<(x1+dx,y1+dy)>.
+
+=head2 X<plotscale>plotscaleC<(w,x1,x2,y1,y2)>
+
+scale the local coordinates of the
+rectwindow C<w> so that C<x> goes from C<x1> to C<x2> and C<y> goes from C<y1> to
+C<y2> (C<x2 E<lt> x1> and C<y2 E<lt> y1> being allowed). Initially, after the initialization
+of the rectwindow C<w> using the function C<plotinit>, the default scaling
+is the graphic pixel count, and in particular the C<y> axis is oriented
+downwards since the origin is at the upper left. The function C<plotscale>
+allows to change all these defaults and should be used whenever functions are
+graphed.
+
+=head2 X<plotstring>plotstringC<(w,x,{I<flag> = 0})>
+
+draw on the rectwindow C<w> the
+String C<x> (see L<Label se:strings>), at the current position of the cursor.
+
+I<flag> is used for justification: bits 1 and 2 regulate horizontal alignment:
+left if 0, right if 2, center if 1. Bits 4 and 8 regulate vertical
+alignment: bottom if 0, top if 8, v-center if 4. Can insert additional
+small gap between point and string: horizontal if bit 16 is set, vertical
+if bit 32 is set (see the tutorial for an example).
+
+=head2 X<plotterm>plottermC<(I<term>)>
+
+sets terminal where high resolution
+plots go (this is currently only taken into account by the C<gnuplot>
+graphical driver). Using the C<gnuplot> driver, possible terminals are
+the same as in gnuplot. If I<term> is "?", lists possible values.
+
+Terminal options can be appended to the terminal name and space; terminal
+size can be put immediately after the name, as in C<"gif = 300,200">.
+Positive return value means success.
+
+=head2 X<psdraw>psdrawC<(I<list>)>
+
+same as C<plotdraw>, except that the
+output is a PostScript program appended to the C<psfile>.
+
+=head2 X<psploth>psplothC<(X = a,b,I<expr>)>
+
+same as C<ploth>, except that the
+output is a PostScript program appended to the C<psfile>.
+
+=head2 X<psplothraw>psplothrawC<(I<listx>,I<listy>)>
+
+same as C<plothraw>,
+except that the output is a PostScript program appended to the C<psfile>.
+
+=head1 Programming under GP
+
+X<programming>X<Label se:programming>
+=head2 Control statements.
+
+A number of control statements are available under GP. They are simpler and
+have a syntax slightly different from their C counterparts, but are quite
+powerful enough to write any kind of program. Some of them are specific to
+GP, since they are made for number theorists. As usual, C<X> will denote any
+simple variable name, and I<seq> will always denote a sequence of
+expressions, including the empty sequence.
+
+=item X<break>breakC<({n = 1})>
+
+interrupts execution of current I<seq>, and
+immediately exits from the C<n> innermost enclosing loops, within the
+current function call (or the top level loop). C<n> must be bigger than 1.
+If C<n> is greater than the number of enclosing loops, all enclosing loops
+are exited.
+
+=item X<for>forC<(X = a,b,I<seq>)>
+
+the formal variable C<X> going from
+C<a> to C<b>, the I<seq> is evaluated. Nothing is done if C<a E<gt> b>.
+C<a> and C<b> must be in B<I<R>>.
+
+=item X<fordiv>fordivC<(n,X,I<seq>)>
+
+the formal variable C<X> ranging
+through the positive divisors of C<n>, the sequence I<seq> is evaluated.
+C<n> must be of type integer.
+
+=item X<forprime>forprimeC<(X = a,b,I<seq>)>
+
+the formal variable C<X>
+ranging over the prime numbers between C<a> to C<b> (including C<a> and C<b>
+if they are prime), the I<seq> is evaluated. More precisely, the value
+of C<X> is incremented to the smallest prime strictly larger than C<X> at the
+end of each iteration. Nothing is done if C<a E<gt> b>. Note that C<a> and C<b> must
+be in B<I<R>>.
+
+ ? { forprime(p = 2, 12,
+ print(p);
+ if (p == 3, p = 6);
+ )
+ }
+ 2
+ 3
+ 7
+ 11
+
+=item X<forstep>forstepC<(X = a,b,s,I<seq>)>
+
+the formal variable C<X>
+going from C<a> to C<b>, in increments of C<s>, the I<seq> is evaluated.
+Nothing is done if C<s E<gt> 0> and C<a E<gt> b> or if C<s E<lt> 0> and C<a E<lt> b>. C<s> must be in
+C<B<I<R>>^*> or a vector of steps C<[s_1,...,s_n]>. In the latter case, the
+successive steps are used in the order they appear in C<s>.
+
+ ? forstep(x=5, 20, [2,4], print(x))
+ 5
+ 7
+ 11
+ 13
+ 17
+ 19
+
+=item X<forsubgroup>forsubgroupC<(H = G,{B},I<seq>)>
+
+executes I<seq> for
+each subgroup C<H> of the I<abelian> group C<G> (given in
+SNFX<Smith normal form> form or as a vector of elementary divisors),
+whose index is bounded by bound. The subgroups are not ordered in any
+obvious way, unless C<G> is a C<p>-group in which case Birkhoff's algorithm
+produces them by decreasing index. A X<subgroup>subgroup is given as a matrix
+whose columns give its generators on the implicit generators of C<G>. For
+example, the following prints all subgroups of index less than 2 in C<G =
+B<I<Z>>/2B<I<Z>> g_1 x B<I<Z>>/2B<I<Z>> g_2>S< >:
+
+ ? G = [2,2]; forsubgroup(H=G, 2, print(H))
+ [1; 1]
+ [1; 2]
+ [2; 1]
+ [1, 0; 1, 1]
+
+The last one, for instance is generated by C<(g_1, g_1 + g_2)>. This
+routine is intended to treat huge groups, when X<subgrouplist>B<subgrouplist> is not an
+option due to the sheer size of the output.
+
+For maximal speed the subgroups have been left as produced by the algorithm.
+To print them in canonical form (as left divisors of C<G> in
+HNFX<Hermite normal form> form), one can for instance use
+
+ ? G = matdiagonal([2,2]); forsubgroup(H=G, 2, print(mathnf(concat(G,H))))
+ [2, 1; 0, 1]
+ [1, 0; 0, 2]
+ [2, 0; 0, 1]
+ [1, 0; 0, 1]
+
+Note that in this last representation, the index C<[G:H]> is given by the
+determinant.
+
+=item X<forvec>forvecC<(X = v,I<seq>,{I<flag> = 0})>
+
+C<v> being an C<n>-component
+vector (where C<n> is arbitrary) of two-component vectors C<[a_i,b_i]>
+for C<1 E<lt>= i E<lt>= n>, the I<seq> is evaluated with the formal variable
+C<X[1]> going from C<a_1> to C<b_1>,...,C<X[n]> going from C<a_n> to C<b_n>.
+The formal variable with the highest index moves the fastest. If C<I<flag> = 1>,
+generate only nondecreasing vectors C<X>, and if C<I<flag> = 2>, generate only
+strictly increasing vectors C<X>.
+
+=item X<if>ifC<(a,{I<seq1>},{I<seq2>})>
+
+if C<a> is non-zero,
+the expression sequence I<seq1> is evaluated, otherwise the expression
+I<seq2> is evaluated. Of course, I<seq1> or I<seq2> may be empty,
+so C<if (a,I<seq>)> evaluates I<seq> if C<a> is not equal to zero
+(you don't have to write the second comma), and does nothing otherwise,
+whereas C<if (a,,I<seq>)> evaluates I<seq> if C<a> is equal to
+zero, and does nothing otherwise. You could get the same result using
+the C<!> (C<not>) operator: C<if (!a,I<seq>)>.
+
+Note that the boolean operators C<&&> and C<||> are evaluated
+according to operator precedence as explained in L<Label se:operators>, but
+that, contrary to other operators, the evaluation of the arguments is
+stopped as soon as the final truth value has been determined. For instance
+
+ if (reallydoit && longcomplicatedfunction(), ...)%
+
+is a perfectly safe statement.
+
+Recall that functions such as C<break> and C<next> operate on
+I<loops> (such as C<forxxx>, C<while>, C<until>). The C<if>
+statement is I<not> a loop (obviously!).
+
+=item X<next>nextC<({n = 1})>
+
+interrupts execution of current C<seq>,
+resume the next iteration of the innermost enclosing loop, within the
+current fonction call (or top level loop). If C<n> is specified, resume at
+the C<n>-th enclosing loop. If C<n> is bigger than the number of enclosing
+loops, all enclosing loops are exited.
+
+=item X<return>returnC<({x = 0})>
+
+returns from current subroutine, with
+result C<x>.
+
+=item X<until>untilC<(a,I<seq>)>
+
+evaluates expression sequence I<seq>
+until C<a> is not equal to 0 (i.e.S< >until C<a> is true). If C<a> is initially
+not equal to 0, I<seq> is evaluated once (more generally, the condition
+on C<a> is tested I<after> execution of the I<seq>, not before as in
+C<while>).
+
+=item X<while>whileC<(a,I<seq>)>
+
+while C<a> is non-zero evaluate the
+expression sequence I<seq>. The test is made I<before> evaluating
+the C<seq>, hence in particular if C<a> is initially equal to zero the
+I<seq> will not be evaluated at all.
+
+=head2 Specific functions used in GP programming
+
+X<Label se:gp_program>
+In addition to the general PARI functions, it is necessary to have some
+functions which will be of use specifically for GP, though a few of these can
+be accessed under library mode. Before we start describing these, we recall
+the difference between I<strings> and I<keywords> (see
+L<Label se:strings>): the latter don't get expanded at all, and you can type
+them without any enclosing quotes. The former are dynamic objects, where
+everything outside quotes gets immediately expanded.
+
+We need an additional notation for this chapter. An argument between braces,
+followed by a star, like C<{I<str>}*>, means that any number of such
+arguments (possibly none) can be given.
+
+=item X<addhelp>addhelpC<(S,I<str>)>
+
+X<Label se:addhelp> changes the help
+message for the symbol C<S>. The string I<str> is expanded on the spot
+and stored as the online help for C<S>. If C<S> is a function I<you> have
+defined, its definition will still be printed before the message I<str>.
+It is recommended that you document global variables and user functions in
+this way. Of course GP won't protest if you don't do it.
+
+There's nothing to prevent you from modifying the help of built-in PARI
+functions (but if you do, we'd like to hear why you needed to do it!).
+
+=item X<alias>aliasC<(I<newkey>,I<key>)>
+
+defines the keyword
+I<newkey> as an alias for keyword I<key>. I<key> must correspond
+to an existing I<function> name. This is different from the general user
+macros in that alias expansion takes place immediately upon execution,
+without having to look up any function code, and is thus much faster. A
+sample alias file C<misc/gpalias> is provided with the standard
+distribution. Alias commands are meant to be read upon startup from the
+C<.gprc> file, to cope with function names you are dissatisfied with, and
+should be useless in interactive usage.
+
+=item X<allocatemem>allocatememC<({x = 0})>
+
+this is a very special operation which
+allows the user to change the stack size I<after> initialization. C<x>
+must be a non-negative integer. If C<x! = 0>, a new stack of size C<16*\lceil
+x/16\rceil> bytes will be allocated, all the PARI data on the old stack will
+be moved to the new one, and the old stack will be discarded. If C<x = 0>, the
+size of the new stack will be twice the size of the old one.
+
+Although it is a function, this must be the I<last> instruction in any GP
+sequence. The technical reason is that this routine usually moves the stack,
+so objects from the current sequence might not be correct anymore. Hence, to
+prevent such problems, this routine terminates by a C<longjmp> (just as an
+error would) and not by a return.
+
+X<allocatemoremem>The library syntax is B<allocatemoremem>C<(x)>, where C<x> is an unsigned long, and the return type
+is void. GP uses a variant which ends by a C<longjmp>.
+
+=item X<default>defaultC<({I<key>},{I<val>},{I<flag>})>
+
+sets the default
+corresponding to keyword I<key> to value I<val>. I<val> is a string
+(which of course accepts numeric arguments without adverse effects, due to the
+expansion mechanism). See L<Label se:defaults> for a list of available
+defaults, and L<Label se:meta> for some shortcut alternatives. Typing
+C<default()> (or C<\d>) yields the complete default list as well as
+their current values.X<Label se:default>
+
+If I<val> is omitted, prints the current value of default I<key>.
+If C<I<flag>> is set, returns the result instead of printing it.
+
+=item X<error>errorC<({I<str>}*)>
+
+outputs its argument list (each of
+them interpreted as a string), then interrupts the running GP program,
+returning to the input prompt.
+
+Example: C<error("n = ", n, " is not squarefree !")>.
+
+Note that, due to the automatic concatenation of strings, you could in fact
+use only one argument, just by suppressing the commas.
+
+=item X<extern>externC<(I<str>)>
+
+the string I<str> is the name
+of an external command (i.e.S< >one you would type from your UNIX shell prompt).
+This command is immediately run and its input fed into GP, just as if read
+from a file.
+
+=item X<getheap>getheapC<()>
+
+returns a two-component row vector giving the
+number of objects on the heap and the amount of memory they occupy in long
+words. Useful mainly for debugging purposes.
+
+X<getheap>The library syntax is B<getheap>C<()>.
+
+=item X<getrand>getrandC<()>
+
+returns the current value of the random number
+seed. Useful mainly for debugging purposes.
+
+X<getrand>The library syntax is B<getrand>C<()>, returns a C long.
+
+=item X<getstack>getstackC<()>
+
+returns the current value of
+C<top-avma>,
+i.e.S< >the number of bytes used up to now on the stack. Should be equal to 0
+in between commands. Useful mainly for debugging purposes.
+
+X<getstack>The library syntax is B<getstack>C<()>, returns a C long.
+
+=item X<gettime>gettimeC<()>
+
+returns the time (in milliseconds) elapsed since
+either the last call to C<gettime>, or to the beginning of the containing
+GP instruction (if inside GP), whichever came last.
+
+X<gettime>The library syntax is B<gettime>C<()>, returns a C long.
+
+=item X<global>globalC<({I<list of variables>})>
+
+X<Label se:global>
+declares the corresponding variables to be global. From now on, you will be
+forbidden to use them as formal parameters for function definitions or as
+loop indexes. This is especially useful when patching together various
+scripts, possibly written with different naming conventions. For instance the
+following situation is dangerous:
+
+ p = 3 \\ fix characteristic
+ ...
+ forprime(p = 2, N, ...)
+ f(p) = ...
+
+since within the loop or within the function's body (even worse: in the
+subroutines called in that scope), the true global value of C<p> will be
+hidden. If the statement C<global(p = 3)> appears at the beginning of
+the script, then both expressions will trigger syntax errors.
+
+Calling C<global> without arguments prints the list of global variables in
+use. In particular, C<eval(global)> will output the values of all local
+variables.
+
+=item X<input>inputC<()>
+
+reads a string, interpreted as a GP expression,
+from the input file, usually standard input (i.e.S< >the keyboard). If a
+sequence of expressions is given, the result is the result of the last
+expression of the sequence. When using this instruction, it is useful to
+prompt for the string by using the C<print1> function. Note that in the
+present version 2.19 of C<pari.el>, when using GP under GNU Emacs (see
+L<Label se:emacs>) one I<must> prompt for the string, with a string
+which ends with the same prompt as any of the previous ones (a C<"? ">
+will do for instance).
+
+=item X<install>installC<(I<name>,I<code>,{I<gpname>},{I<lib>})>
+
+loads from dynamic library I<lib> the function I<name>. Assigns to it
+the name I<gpname> in this GP session, with argument code I<code> (see
+L<Label se:gp.interface> for an explanation of those). If I<lib> is
+omitted, uses C<libpari.so>. If I<gpname> is omitted, uses
+I<name>.X<Label se:install>
+
+This function is useful for adding custom functions to the GP interpreter,
+or picking useful functions from unrelated libraries. For instance, it
+makes the function X<system>C<system> obsolete:
+
+ ? install(system, vs, sys, "libc.so")
+ ? sys("ls gp*")
+ gp.c gp.h gp_rl.c
+
+But it also gives you access to all (non static) functions defined in the
+PARI library. For instance, the function C<GEN addii(GEN x, GEN y)> adds
+two PARI integers, and is not directly accessible under GP (it's eventually
+called by the C<+> operator of course):
+
+ ? install("addii", "GG")
+ ? addii(1, 2)
+ %1 = 3
+
+B<Caution:> This function may not work on all systems, especially
+when GP has been compiled statically. In that case, the first use of an
+installed function will provoke a Segmentation Fault, i.e.S< >a major internal
+blunder (this should never happen with a dynamically linked executable).
+Hence, if you intend to use this function, please check first on some
+harmless example such as the ones above that it works properly on your
+machine.
+
+=item X<kill>killC<(s)>
+
+X<Label se:kill> kills the present value of the
+variable, alias or user-defined function C<s>. The corresponding identifier
+can now be used to name any GP object (variable or function). This is the
+only way to replace a variable by a function having the same name (or the
+other way round), as in the following example:
+
+ ? f = 1
+ %1 = 1
+ ? f(x) = 0
+ *** unused characters: f(x)=0
+ ^----
+ ? kill(f)
+ ? f(x) = 0
+ ? f()
+ %2 = 0
+
+When you kill a variable, all objects that used it become invalid. You
+can still display them, even though the killed variable will be printed in a
+funny way (following the same convention as used by the library function
+C<fetch_var>, seeS< >L<Label se:vars>). For example:
+
+ ? a^2 + 1
+ %1 = a^2 + 1
+ ? kill(a)
+ ? %1
+ %2 = #<1>^2 + 1
+
+If you simply want to restore a variable to its ``undefined'' value
+(monomial of degree one), use the X<quote>quote operator: C<a = 'a>.
+Predefined symbols (C<x> and GP function names) cannot be killed.
+
+=item X<print>printC<({I<str>}*)>
+
+outputs its (string) arguments in raw
+format, ending with a newline.
+
+=item X<print1>print1C<({I<str>}*)>
+
+outputs its (string) arguments in raw
+format, without ending with a newline (note that you can still embed newlines
+within your strings, using the C<\n> notationS< >!).
+
+=item X<printp>printpC<({I<str>}*)>
+
+outputs its (string) arguments in
+prettyprint (beautified) format, ending with a newline.
+
+=item X<printp1>printp1C<({I<str>}*)>
+
+outputs its (string) arguments in
+prettyprint (beautified) format, without ending with a newline.
+
+=item X<printtex>printtexC<({I<str>}*)>
+
+outputs its (string) arguments in
+TeX format. This output can then be used in a TeX manuscript.
+The printing is done on the standard output. If you want to print it to a
+file you should use C<writetex> (see there).
+
+Another possibility is to enable the X<log>C<log> default
+(seeS< >L<Label se:defaults>).
+You could for instance do:X<logfile>
+
+ default(logfile, "new.tex");
+ default(log, 1);
+ printtex(result);
+
+(You can use the automatic string expansion/concatenation process to have
+dynamic file names if you wish).
+
+=item X<quit>quitC<()>
+
+exits GP.X<Label se:quit>
+
+=item X<read>readC<({I<str>})>
+
+reads in the file whose name results
+from the expansion of the string I<str>. If I<str> is omitted,
+re-reads the last file that was fed into GP. The return value is the result of
+the last expression evaluated.X<Label se:read>
+
+=item X<reorder>reorderC<({x = []})>
+
+C<x> must be a vector. If C<x> is the
+empty vector, this gives the vector whose components are the existing
+variables in increasing order (i.e.S< >in decreasing importance). Killed
+variables (see C<kill>) will be shown as C<0>. If C<x> is
+non-empty, it must be a permutation of variable names, and this permutation
+gives a new order of importance of the variables, I<for output only>. For
+example, if the existing order is C<[x,y,z]>, then after
+C<reorder([z,x])> the order of importance of the variables, with respect
+to output, will be C<[z,y,x]>. The internal representation is unaffected.
+X<Label se:reorder>
+
+=item X<setrand>setrandC<(n)>
+
+reseeds the random number generator to the value
+C<n>. The initial seed is C<n = 1>.
+
+X<setrand>The library syntax is B<setrand>C<(n)>, where C<n> is a C<long>. Returns C<n>.
+
+=item X<system>systemC<(I<str>)>
+
+I<str> is a string representing
+a system command. This command is executed, its output written to the
+standard output (this won't get into your logfile), and control returns
+to the PARI system. This simply calls the C C<system> command.
+
+=item X<trap>trapC<({e}, {I<rec>}, {I<seq>})>
+
+tries to
+execute I<seq>, trapping error C<e>, that is effectively preventing it
+from aborting computations in the usual way; the recovery sequence
+I<rec> is executed if the error occurs and the evaluation of I<rec>
+becomes the result of the command. If C<e> is omitted, all exceptions are
+trapped. Note in particular that hitting C<^C> (Control-C) raises an
+exception.
+
+ ? \\ trap division by 0
+ ? inv(x) = trap (gdiver2, INFINITY, 1/x)
+ ? inv(2)
+ %1 = 1/2
+ ? inv(0)
+ %2 = INFINITY
+
+If I<seq> is omitted, defines I<rec> as a default action when
+encountering exception C<e>. The error message is printed, as well as the
+result of the evaluation of I<rec>, and the control is given back to the
+GP prompt. In particular, current computation is then lost.
+
+The following error handler prints the list of all user variables, then
+stores in a file their name and their values:
+
+ ? { trap( ,
+ print(reorder);
+ write("crash", reorder);
+ write("crash", eval(reorder))) }
+
+If no recovery code is given (I<rec> is omitted) a so-called
+I<X<break loop>break loop> will be started. During a break loop, all commands are
+read and evaluated as during the main GP loop (except that no history of
+results is kept).
+
+To get out of the break loop, you can use X<next>C<next>, X<break>C<break> or
+X<return>C<return>; reading in a file by C<\r> will also terminate the loop once
+the file has been read (C<read> will remain in the break loop). If the
+error is not fatal (C<^C> is the only non-fatal error), C<next>
+will continue the computation as if nothing had happened (except of course,
+you may have changed GP state during the break loop); otherwise control
+will come back to the GP prompt. After a user interrupt (C<^C>),
+entering an empty input line (i.e hitting the return key) has the same
+effect as C<next>.
+
+Break loops are useful as a debugging tool to inspect the values of GP
+variables to understand why a problem occurred, or to change GP behaviour
+(increase debugging level, start storing results in a logfile, modify
+parameters...) in the middle of a long computation (hit C<^C>, type
+in your modifications, then type C<next>).
+
+If I<rec> is the empty string C<""> the last default handler is popped
+out, and replaced by the previous one for that error.
+
+B<Note:> The interface is currently not adequate for trapping
+individual exceptions. In the current version B<2.2.0>, the following keywords
+are recognized, but the name list will be expanded and changed in the
+future (all library mode errors can be trapped: it's a matter of defining
+the keywords to GP, and there are currently far too many useless ones):
+
+C<accurer>: accuracy problem
+
+C<gdiver2>: division by 0
+
+C<archer>: not available on this architecture or operating system
+
+C<typeer>: wrong type
+
+C<errpile>: the PARI stack overflows
+
+=item X<type>typeC<(x,{t})>
+
+this is useful only under GP. If C<t> is
+not present, returns the internal type number of the PARI object C<x>.
+Otherwise, makes a copy of C<x> and sets its type equal to type C<t>, which
+can be either a number or, preferably since internal codes may eventually
+change, a symbolic name such as C<t_FRACN> (you can skip the C<t_>
+part here, so that C<FRACN> by itself would also be all right). Check out
+existing type names with the metacommand C<\t>.X<Label se:gptype>
+
+GP won't let you create meaningless objects in this way where the internal
+structure doesn't match the type. This function can be useful to create
+reducible rationals (type C<t_FRACN>) or rational functions (type
+C<t_RFRACN>). In fact it's the only way to do so in GP. In this case, the
+created object, as well as the objects created from it, will not be reduced
+automatically, making some operations a bit faster.
+
+There is no equivalent library syntax, since the internal functions C<typ>
+and C<settyp> are available. Note that C<settyp> does I<not>
+create a copy of C<x>, contrary to most PARI functions. It also doesn't
+check for consistency. C<settyp> just changes the type in place and
+returns nothing. C<typ> returns a C long integer. Note also the different
+spellings of the internal functions (C<set>)C<typ> and of the GP
+function C<type>, which is due to the fact that C<type> is a reserved
+identifier for some C compilers.
+
+=item X<whatnow>whatnowC<(I<key>)>
+
+if keyword I<key> is the name
+of a function that was present in GP version 1.39.15 or lower, outputs
+the new function name and syntax, if it changed at all (C<387> out of C<560>
+did).X<Label se:whatnow>
+
+=item X<write>writeC<(I<filename>,{I<str>*})>
+
+writes (appends)
+to I<filename> the remaining arguments, and appends a newline (same output
+as C<print>).X<Label se:write>
+
+=item X<write1>write1C<(I<filename>,{I<str>*})>
+
+writes (appends) to
+I<filename> the remaining arguments without a trailing newline
+(same output as C<print1>).
+
+=item X<writetex>writetexC<(I<filename>,{I<str>*})>
+
+as C<write>,
+in TeX format.X<Label se:writetex>
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Memoize/AnyDBM_File.pm b/Master/tlpkg/tlperl.straw/lib/Memoize/AnyDBM_File.pm
new file mode 100755
index 00000000000..91f960962f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Memoize/AnyDBM_File.pm
@@ -0,0 +1,31 @@
+package Memoize::AnyDBM_File;
+
+=head1 NAME
+
+Memoize::AnyDBM_File - glue to provide EXISTS for AnyDBM_File for Storable use
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use vars qw(@ISA $VERSION);
+$VERSION = 0.65;
+@ISA = qw(DB_File GDBM_File Memoize::NDBM_File Memoize::SDBM_File ODBM_File) unless @ISA;
+
+my $verbose = 1;
+
+my $mod;
+for $mod (@ISA) {
+# (my $truemod = $mod) =~ s/^Memoize:://;
+# my $file = "$mod.pm";
+# $file =~ s{::}{/}g;
+ if (eval "require $mod") {
+ print STDERR "AnyDBM_File => Selected $mod.\n" if $Verbose;
+ @ISA = ($mod); # if we leave @ISA alone, warnings abound
+ return 1;
+ }
+}
+
+die "No DBM package was successfully found or installed";
diff --git a/Master/tlpkg/tlperl.straw/lib/Memoize/Expire.pm b/Master/tlpkg/tlperl.straw/lib/Memoize/Expire.pm
new file mode 100755
index 00000000000..97e1aa44208
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Memoize/Expire.pm
@@ -0,0 +1,365 @@
+
+package Memoize::Expire;
+# require 5.00556;
+use Carp;
+$DEBUG = 0;
+$VERSION = '1.00';
+
+# This package will implement expiration by prepending a fixed-length header
+# to the font of the cached data. The format of the header will be:
+# (4-byte number of last-access-time) (For LRU when I implement it)
+# (4-byte expiration time: unsigned seconds-since-unix-epoch)
+# (2-byte number-of-uses-before-expire)
+
+sub _header_fmt () { "N N n" }
+sub _header_size () { length(_header_fmt) }
+
+# Usage: memoize func
+# TIE => [Memoize::Expire, LIFETIME => sec, NUM_USES => n,
+# TIE => [...] ]
+
+BEGIN {
+ eval {require Time::HiRes};
+ unless ($@) {
+ Time::HiRes->import('time');
+ }
+}
+
+sub TIEHASH {
+ my ($package, %args) = @_;
+ my %cache;
+ if ($args{TIE}) {
+ my ($module, @opts) = @{$args{TIE}};
+ my $modulefile = $module . '.pm';
+ $modulefile =~ s{::}{/}g;
+ eval { require $modulefile };
+ if ($@) {
+ croak "Memoize::Expire: Couldn't load hash tie module `$module': $@; aborting";
+ }
+ my $rc = (tie %cache => $module, @opts);
+ unless ($rc) {
+ croak "Memoize::Expire: Couldn't tie hash to `$module': $@; aborting";
+ }
+ }
+ $args{LIFETIME} ||= 0;
+ $args{NUM_USES} ||= 0;
+ $args{C} = \%cache;
+ bless \%args => $package;
+}
+
+sub STORE {
+ $DEBUG and print STDERR " >> Store $_[1] $_[2]\n";
+ my ($self, $key, $value) = @_;
+ my $expire_time = $self->{LIFETIME} > 0 ? $self->{LIFETIME} + time : 0;
+ # The call that results in a value to store into the cache is the
+ # first of the NUM_USES allowed calls.
+ my $header = _make_header(time, $expire_time, $self->{NUM_USES}-1);
+ $self->{C}{$key} = $header . $value;
+ $value;
+}
+
+sub FETCH {
+ $DEBUG and print STDERR " >> Fetch cached value for $_[1]\n";
+ my ($data, $last_access, $expire_time, $num_uses_left) = _get_item($_[0]{C}{$_[1]});
+ $DEBUG and print STDERR " >> (ttl: ", ($expire_time-time()), ", nuses: $num_uses_left)\n";
+ $num_uses_left--;
+ $last_access = time;
+ _set_header(@_, $data, $last_access, $expire_time, $num_uses_left);
+ $data;
+}
+
+sub EXISTS {
+ $DEBUG and print STDERR " >> Exists $_[1]\n";
+ unless (exists $_[0]{C}{$_[1]}) {
+ $DEBUG and print STDERR " Not in underlying hash at all.\n";
+ return 0;
+ }
+ my $item = $_[0]{C}{$_[1]};
+ my ($last_access, $expire_time, $num_uses_left) = _get_header($item);
+ my $ttl = $expire_time - time;
+ if ($DEBUG) {
+ $_[0]{LIFETIME} and print STDERR " Time to live for this item: $ttl\n";
+ $_[0]{NUM_USES} and print STDERR " Uses remaining: $num_uses_left\n";
+ }
+ if ( (! $_[0]{LIFETIME} || $expire_time > time)
+ && (! $_[0]{NUM_USES} || $num_uses_left > 0 )) {
+ $DEBUG and print STDERR " (Still good)\n";
+ return 1;
+ } else {
+ $DEBUG and print STDERR " (Expired)\n";
+ return 0;
+ }
+}
+
+# Arguments: last access time, expire time, number of uses remaining
+sub _make_header {
+ pack "N N n", @_;
+}
+
+sub _strip_header {
+ substr($_[0], 10);
+}
+
+# Arguments: last access time, expire time, number of uses remaining
+sub _set_header {
+ my ($self, $key, $data, @header) = @_;
+ $self->{C}{$key} = _make_header(@header) . $data;
+}
+
+sub _get_item {
+ my $data = substr($_[0], 10);
+ my @header = unpack "N N n", substr($_[0], 0, 10);
+# print STDERR " >> _get_item: $data => $data @header\n";
+ ($data, @header);
+}
+
+# Return last access time, expire time, number of uses remaining
+sub _get_header {
+ unpack "N N n", substr($_[0], 0, 10);
+}
+
+1;
+
+=head1 NAME
+
+Memoize::Expire - Plug-in module for automatic expiration of memoized values
+
+=head1 SYNOPSIS
+
+ use Memoize;
+ use Memoize::Expire;
+ tie my %cache => 'Memoize::Expire',
+ LIFETIME => $lifetime, # In seconds
+ NUM_USES => $n_uses;
+
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache ];
+
+=head1 DESCRIPTION
+
+Memoize::Expire is a plug-in module for Memoize. It allows the cached
+values for memoized functions to expire automatically. This manual
+assumes you are already familiar with the Memoize module. If not, you
+should study that manual carefully first, paying particular attention
+to the HASH feature.
+
+Memoize::Expire is a layer of software that you can insert in between
+Memoize itself and whatever underlying package implements the cache.
+The layer presents a hash variable whose values expire whenever they
+get too old, have been used too often, or both. You tell C<Memoize> to
+use this forgetful hash as its cache instead of the default, which is
+an ordinary hash.
+
+To specify a real-time timeout, supply the C<LIFETIME> option with a
+numeric value. Cached data will expire after this many seconds, and
+will be looked up afresh when it expires. When a data item is looked
+up afresh, its lifetime is reset.
+
+If you specify C<NUM_USES> with an argument of I<n>, then each cached
+data item will be discarded and looked up afresh after the I<n>th time
+you access it. When a data item is looked up afresh, its number of
+uses is reset.
+
+If you specify both arguments, data will be discarded from the cache
+when either expiration condition holds.
+
+Memoize::Expire uses a real hash internally to store the cached data.
+You can use the C<HASH> option to Memoize::Expire to supply a tied
+hash in place of the ordinary hash that Memoize::Expire will normally
+use. You can use this feature to add Memoize::Expire as a layer in
+between a persistent disk hash and Memoize. If you do this, you get a
+persistent disk cache whose entries expire automatically. For
+example:
+
+ # Memoize
+ # |
+ # Memoize::Expire enforces data expiration policy
+ # |
+ # DB_File implements persistence of data in a disk file
+ # |
+ # Disk file
+
+ use Memoize;
+ use Memoize::Expire;
+ use DB_File;
+
+ # Set up persistence
+ tie my %disk_cache => 'DB_File', $filename, O_CREAT|O_RDWR, 0666];
+
+ # Set up expiration policy, supplying persistent hash as a target
+ tie my %cache => 'Memoize::Expire',
+ LIFETIME => $lifetime, # In seconds
+ NUM_USES => $n_uses,
+ HASH => \%disk_cache;
+
+ # Set up memoization, supplying expiring persistent hash for cache
+ memoize 'function', SCALAR_CACHE => [ HASH => \%cache ];
+
+=head1 INTERFACE
+
+There is nothing special about Memoize::Expire. It is just an
+example. If you don't like the policy that it implements, you are
+free to write your own expiration policy module that implements
+whatever policy you desire. Here is how to do that. Let us suppose
+that your module will be named MyExpirePolicy.
+
+Short summary: You need to create a package that defines four methods:
+
+=over 4
+
+=item
+TIEHASH
+
+Construct and return cache object.
+
+=item
+EXISTS
+
+Given a function argument, is the corresponding function value in the
+cache, and if so, is it fresh enough to use?
+
+=item
+FETCH
+
+Given a function argument, look up the corresponding function value in
+the cache and return it.
+
+=item
+STORE
+
+Given a function argument and the corresponding function value, store
+them into the cache.
+
+=item
+CLEAR
+
+(Optional.) Flush the cache completely.
+
+=back
+
+The user who wants the memoization cache to be expired according to
+your policy will say so by writing
+
+ tie my %cache => 'MyExpirePolicy', args...;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+This will invoke C<< MyExpirePolicy->TIEHASH(args) >>.
+MyExpirePolicy::TIEHASH should do whatever is appropriate to set up
+the cache, and it should return the cache object to the caller.
+
+For example, MyExpirePolicy::TIEHASH might create an object that
+contains a regular Perl hash (which it will to store the cached
+values) and some extra information about the arguments and how old the
+data is and things like that. Let us call this object `C'.
+
+When Memoize needs to check to see if an entry is in the cache
+already, it will invoke C<< C->EXISTS(key) >>. C<key> is the normalized
+function argument. MyExpirePolicy::EXISTS should return 0 if the key
+is not in the cache, or if it has expired, and 1 if an unexpired value
+is in the cache. It should I<not> return C<undef>, because there is a
+bug in some versions of Perl that will cause a spurious FETCH if the
+EXISTS method returns C<undef>.
+
+If your EXISTS function returns true, Memoize will try to fetch the
+cached value by invoking C<< C->FETCH(key) >>. MyExpirePolicy::FETCH should
+return the cached value. Otherwise, Memoize will call the memoized
+function to compute the appropriate value, and will store it into the
+cache by calling C<< C->STORE(key, value) >>.
+
+Here is a very brief example of a policy module that expires each
+cache item after ten seconds.
+
+ package Memoize::TenSecondExpire;
+
+ sub TIEHASH {
+ my ($package, %args) = @_;
+ my $cache = $args{HASH} || {};
+ bless $cache => $package;
+ }
+
+ sub EXISTS {
+ my ($cache, $key) = @_;
+ if (exists $cache->{$key} &&
+ $cache->{$key}{EXPIRE_TIME} > time) {
+ return 1
+ } else {
+ return 0; # Do NOT return `undef' here.
+ }
+ }
+
+ sub FETCH {
+ my ($cache, $key) = @_;
+ return $cache->{$key}{VALUE};
+ }
+
+ sub STORE {
+ my ($cache, $key, $newvalue) = @_;
+ $cache->{$key}{VALUE} = $newvalue;
+ $cache->{$key}{EXPIRE_TIME} = time + 10;
+ }
+
+To use this expiration policy, the user would say
+
+ use Memoize;
+ tie my %cache10sec => 'Memoize::TenSecondExpire';
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache10sec];
+
+Memoize would then call C<function> whenever a cached value was
+entirely absent or was older than ten seconds.
+
+You should always support a C<HASH> argument to C<TIEHASH> that ties
+the underlying cache so that the user can specify that the cache is
+also persistent or that it has some other interesting semantics. The
+example above demonstrates how to do this, as does C<Memoize::Expire>.
+
+=head1 ALTERNATIVES
+
+Brent Powers has a C<Memoize::ExpireLRU> module that was designed to
+work with Memoize and provides expiration of least-recently-used data.
+The cache is held at a fixed number of entries, and when new data
+comes in, the least-recently used data is expired. See
+L<http://search.cpan.org/search?mode=module&query=ExpireLRU>.
+
+Joshua Chamas's Tie::Cache module may be useful as an expiration
+manager. (If you try this, let me know how it works out.)
+
+If you develop any useful expiration managers that you think should be
+distributed with Memoize, please let me know.
+
+=head1 CAVEATS
+
+This module is experimental, and may contain bugs. Please report bugs
+to the address below.
+
+Number-of-uses is stored as a 16-bit unsigned integer, so can't exceed
+65535.
+
+Because of clock granularity, expiration times may occur up to one
+second sooner than you expect. For example, suppose you store a value
+with a lifetime of ten seconds, and you store it at 12:00:00.998 on a
+certain day. Memoize will look at the clock and see 12:00:00. Then
+9.01 seconds later, at 12:00:10.008 you try to read it back. Memoize
+will look at the clock and see 12:00:10 and conclude that the value
+has expired. This will probably not occur if you have
+C<Time::HiRes> installed.
+
+=head1 AUTHOR
+
+Mark-Jason Dominus (mjd-perl-memoize+@plover.com)
+
+Mike Cariaso provided valuable insight into the best way to solve this
+problem.
+
+=head1 SEE ALSO
+
+perl(1)
+
+The Memoize man page.
+
+http://www.plover.com/~mjd/perl/Memoize/ (for news and updates)
+
+I maintain a mailing list on which I occasionally announce new
+versions of Memoize. The list is for announcements only, not
+discussion. To join, send an empty message to
+mjd-perl-memoize-request@Plover.com.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Memoize/ExpireFile.pm b/Master/tlpkg/tlperl.straw/lib/Memoize/ExpireFile.pm
new file mode 100755
index 00000000000..e52c09a3bf3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Memoize/ExpireFile.pm
@@ -0,0 +1,52 @@
+package Memoize::ExpireFile;
+
+=head1 NAME
+
+Memoize::ExpireFile - test for Memoize expiration semantics
+
+=head1 DESCRIPTION
+
+See L<Memoize::Expire>.
+
+=cut
+
+$VERSION = 1.01;
+use Carp;
+
+my $Zero = pack("N", 0);
+
+sub TIEHASH {
+ my ($package, %args) = @_;
+ my $cache = $args{HASH} || {};
+ bless {ARGS => \%args, C => $cache} => $package;
+}
+
+
+sub STORE {
+# print "Expiry manager STORE handler\n";
+ my ($self, $key, $data) = @_;
+ my $cache = $self->{C};
+ my $cur_date = pack("N", (stat($key))[9]);
+ $cache->{"C$key"} = $data;
+ $cache->{"T$key"} = $cur_date;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ $self->{C}{"C$key"};
+}
+
+sub EXISTS {
+# print "Expiry manager EXISTS handler\n";
+ my ($self, $key) = @_;
+ my $cache_date = $self->{C}{"T$key"} || $Zero;
+ my $file_date = pack("N", (stat($key))[9]);#
+# if ($self->{ARGS}{CHECK_DATE} && $old_date gt $cur_date) {
+# return $self->{ARGS}{CHECK_DATE}->($key, $old_date, $cur_date);
+# }
+ my $res = $cache_date ge $file_date;
+# print $res ? "... still good\n" : "... expired\n";
+ $res;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Memoize/ExpireTest.pm b/Master/tlpkg/tlperl.straw/lib/Memoize/ExpireTest.pm
new file mode 100755
index 00000000000..729f6b98506
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Memoize/ExpireTest.pm
@@ -0,0 +1,49 @@
+package Memoize::ExpireTest;
+
+=head1 NAME
+
+Memoize::ExpireTest - test for Memoize expiration semantics
+
+=head1 DESCRIPTION
+
+This module is just for testing expiration semantics. It's not a very
+good example of how to write an expiration module.
+
+If you are looking for an example, I recommend that you look at the
+simple example in the Memoize::Expire documentation, or at the code
+for Memoize::Expire itself.
+
+If you have questions, I will be happy to answer them if you send them
+to mjd-perl-memoize+@plover.com.
+
+=cut
+
+$VERSION = 0.65;
+my %cache;
+
+sub TIEHASH {
+ my ($pack) = @_;
+ bless \%cache => $pack;
+}
+
+sub EXISTS {
+ my ($cache, $key) = @_;
+ exists $cache->{$key} ? 1 : 0;
+}
+
+sub FETCH {
+ my ($cache, $key) = @_;
+ $cache->{$key};
+}
+
+sub STORE {
+ my ($cache, $key, $val) = @_;
+ $cache->{$key} = $val;
+}
+
+sub expire {
+ my ($key) = @_;
+ delete $cache{$key};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Memoize/NDBM_File.pm b/Master/tlpkg/tlperl.straw/lib/Memoize/NDBM_File.pm
new file mode 100755
index 00000000000..96eabfbb7c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Memoize/NDBM_File.pm
@@ -0,0 +1,77 @@
+package Memoize::NDBM_File;
+
+=head1 NAME
+
+Memoize::NDBM_File - glue to provide EXISTS for NDBM_File for Storable use
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use NDBM_File;
+@ISA = qw(NDBM_File);
+$VERSION = 0.65;
+
+$Verbose = 0;
+
+sub AUTOLOAD {
+ warn "Nonexistent function $AUTOLOAD invoked in Memoize::NDBM_File\n";
+}
+
+sub import {
+ warn "Importing Memoize::NDBM_File\n" if $Verbose;
+}
+
+
+my %keylist;
+
+# This is so ridiculous...
+sub _backhash {
+ my $self = shift;
+ my %fakehash;
+ my $k;
+ for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
+ $fakehash{$k} = undef;
+ }
+ $keylist{$self} = \%fakehash;
+}
+
+sub EXISTS {
+ warn "Memoize::NDBM_File EXISTS (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ my $r = exists $keylist{$self}{$_[0]};
+ warn "Memoize::NDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
+ $r;
+}
+
+sub DEFINED {
+ warn "Memoize::NDBM_File DEFINED (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ defined $keylist{$self}{$_[0]};
+}
+
+sub DESTROY {
+ warn "Memoize::NDBM_File DESTROY (@_)\n" if $Verbose;
+ my $self = shift;
+ delete $keylist{$self}; # So much for reference counting...
+ $self->SUPER::DESTROY(@_);
+}
+
+# Maybe establish the keylist at TIEHASH time instead?
+
+sub STORE {
+ warn "Memoize::NDBM_File STORE (@_)\n" if $VERBOSE;
+ my $self = shift;
+ $keylist{$self}{$_[0]} = undef;
+ $self->SUPER::STORE(@_);
+}
+
+
+
+# Inherit FETCH and TIEHASH
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Memoize/SDBM_File.pm b/Master/tlpkg/tlperl.straw/lib/Memoize/SDBM_File.pm
new file mode 100755
index 00000000000..f66273f2747
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Memoize/SDBM_File.pm
@@ -0,0 +1,75 @@
+package Memoize::SDBM_File;
+
+=head1 NAME
+
+Memoize::SDBM_File - glue to provide EXISTS for SDBM_File for Storable use
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use SDBM_File;
+@ISA = qw(SDBM_File);
+$VERSION = 0.65;
+
+$Verbose = 0;
+
+sub AUTOLOAD {
+ warn "Nonexistent function $AUTOLOAD invoked in Memoize::SDBM_File\n";
+}
+
+sub import {
+ warn "Importing Memoize::SDBM_File\n" if $Verbose;
+}
+
+
+my %keylist;
+
+# This is so ridiculous...
+sub _backhash {
+ my $self = shift;
+ my %fakehash;
+ my $k;
+ for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
+ $fakehash{$k} = undef;
+ }
+ $keylist{$self} = \%fakehash;
+}
+
+sub EXISTS {
+ warn "Memoize::SDBM_File EXISTS (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ my $r = exists $keylist{$self}{$_[0]};
+ warn "Memoize::SDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
+ $r;
+}
+
+sub DEFINED {
+ warn "Memoize::SDBM_File DEFINED (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ defined $keylist{$self}{$_[0]};
+}
+
+sub DESTROY {
+ warn "Memoize::SDBM_File DESTROY (@_)\n" if $Verbose;
+ my $self = shift;
+ delete $keylist{$self}; # So much for reference counting...
+ $self->SUPER::DESTROY(@_);
+}
+
+# Maybe establish the keylist at TIEHASH time instead?
+
+sub STORE {
+ warn "Memoize::SDBM_File STORE (@_)\n" if $VERBOSE;
+ my $self = shift;
+ $keylist{$self}{$_[0]} = undef;
+ $self->SUPER::STORE(@_);
+}
+
+# Inherit FETCH and TIEHASH
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Memoize/Storable.pm b/Master/tlpkg/tlperl.straw/lib/Memoize/Storable.pm
new file mode 100755
index 00000000000..4c29dd7eb8f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Memoize/Storable.pm
@@ -0,0 +1,72 @@
+package Memoize::Storable;
+
+=head1 NAME
+
+Memoize::Storable - store Memoized data in Storable database
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use Storable ();
+$VERSION = 0.65;
+$Verbose = 0;
+
+sub TIEHASH {
+ require Carp if $Verbose;
+ my $package = shift;
+ my $filename = shift;
+ my $truehash = (-e $filename) ? Storable::retrieve($filename) : {};
+ my %options;
+ print STDERR "Memoize::Storable::TIEHASH($filename, @_)\n" if $Verbose;
+ @options{@_} = ();
+ my $self =
+ {FILENAME => $filename,
+ H => $truehash,
+ OPTIONS => \%options
+ };
+ bless $self => $package;
+}
+
+sub STORE {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::STORE(@_)\n" if $Verbose;
+ $self->{H}{$_[0]} = $_[1];
+}
+
+sub FETCH {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::FETCH(@_)\n" if $Verbose;
+ $self->{H}{$_[0]};
+}
+
+sub EXISTS {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::EXISTS(@_)\n" if $Verbose;
+ exists $self->{H}{$_[0]};
+}
+
+sub DESTROY {
+ require Carp if $Verbose;
+ my $self= shift;
+ print STDERR "Memoize::Storable::DESTROY(@_)\n" if $Verbose;
+ if ($self->{OPTIONS}{'nstore'}) {
+ Storable::nstore($self->{H}, $self->{FILENAME});
+ } else {
+ Storable::store($self->{H}, $self->{FILENAME});
+ }
+}
+
+sub FIRSTKEY {
+ 'Fake hash from Memoize::Storable';
+}
+
+sub NEXTKEY {
+ undef;
+}
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Opcode.pm b/Master/tlpkg/tlperl.straw/lib/Opcode.pm
new file mode 100755
index 00000000000..e0078e5d382
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Opcode.pm
@@ -0,0 +1,590 @@
+package Opcode;
+
+use 5.006_001;
+
+use strict;
+
+our($VERSION, @ISA, @EXPORT_OK);
+
+$VERSION = "1.11";
+
+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
+
+ 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 setstate
+
+ 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
+
+ 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.straw/lib/PAR.pm b/Master/tlpkg/tlperl.straw/lib/PAR.pm
new file mode 100755
index 00000000000..3b82f5ed26a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PAR.pm
@@ -0,0 +1,1244 @@
+package PAR;
+$PAR::VERSION = '0.994';
+
+use 5.006;
+use strict;
+use warnings;
+use Config '%Config';
+use Carp qw/croak/;
+
+# If the 'prefork' module is available, we
+# register various run-time loaded modules with it.
+# That way, there is more shared memory in a forking
+# environment.
+BEGIN {
+ if (eval 'require prefork') {
+ prefork->import($_) for qw/
+ Archive::Zip
+ File::Glob
+ File::Spec
+ File::Temp
+ LWP::Simple
+ PAR::Heavy
+ /;
+ # not including Archive::Unzip::Burst which only makes sense
+ # in the context of a PAR::Packer'ed executable anyway.
+ }
+}
+
+use PAR::SetupProgname;
+use PAR::SetupTemp;
+
+=head1 NAME
+
+PAR - Perl Archive Toolkit
+
+=head1 SYNOPSIS
+
+(If you want to make an executable that contains all module, scripts and
+data files, please consult the L<pp> utility instead. L<pp> used to be
+part of the PAR distribution but is now shipped as part of the L<PAR::Packer>
+distribution instead.)
+
+Following examples assume a F<foo.par> file in Zip format.
+
+To use F<Hello.pm> from F<./foo.par>:
+
+ % perl -MPAR=./foo.par -MHello
+ % perl -MPAR=./foo -MHello # the .par part is optional
+
+Same thing, but search F<foo.par> in the C<@INC>;
+
+ % perl -MPAR -Ifoo.par -MHello
+ % perl -MPAR -Ifoo -MHello # ditto
+
+Following paths inside the PAR file are searched:
+
+ /lib/
+ /arch/
+ /i386-freebsd/ # i.e. $Config{archname}
+ /5.8.0/ # i.e. $Config{version}
+ /5.8.0/i386-freebsd/ # both of the above
+ /
+
+PAR files may also (recursively) contain other PAR files.
+All files under following paths will be considered as PAR
+files and searched as well:
+
+ /par/i386-freebsd/ # i.e. $Config{archname}
+ /par/5.8.0/ # i.e. $Config{version}
+ /par/5.8.0/i386-freebsd/ # both of the above
+ /par/
+
+Run F<script/test.pl> or F<test.pl> from F<foo.par>:
+
+ % perl -MPAR foo.par test.pl # only when $0 ends in '.par'
+
+However, if the F<.par> archive contains either F<script/main.pl> or
+F<main.pl>, then it is used instead:
+
+ % perl -MPAR foo.par test.pl # runs main.pl; @ARGV is 'test.pl'
+
+Use in a program:
+
+ use PAR 'foo.par';
+ use Hello; # reads within foo.par
+
+ # PAR::read_file() returns a file inside any loaded PARs
+ my $conf = PAR::read_file('data/MyConfig.yaml');
+
+ # PAR::par_handle() returns an Archive::Zip handle
+ my $zip = PAR::par_handle('foo.par')
+ my $src = $zip->memberNamed('lib/Hello.pm')->contents;
+
+You can also use wildcard characters:
+
+ use PAR '/home/foo/*.par'; # loads all PAR files in that directory
+
+Since version 0.950, you can also use a different syntax for loading
+F<.par> archives:
+
+ use PAR { file => 'foo.par' }, { file => 'otherfile.par' };
+
+Why? Because you can also do this:
+
+ use PAR { file => 'foo.par, fallback => 1 };
+ use Foo::Bar;
+
+Foo::Bar will be searched in the system libs first and loaded from F<foo.par>
+if it wasn't found!
+
+ use PAR { file => 'foo.par', run => 'myscript' };
+
+This will load F<foo.par> as usual and then execute the F<script/myscript>
+file from the archive. Note that your program will not regain control. When
+F<script/myscript> exits, so does your main program. To make this more useful,
+you can defer this to runtime: (otherwise equivalent)
+
+ require PAR;
+ PAR->import( { file => 'foo.par', run => 'myscript' } );
+
+If you have L<PAR::Repository::Client> installed, you can do this:
+
+ use PAR { repository => 'http://foo/bar/' };
+ use Module; # not locally installed!
+
+And PAR will fetch any modules you don't have from the specified PAR
+repository. For details on how this works, have a look at the SEE ALSO
+section below. Instead of an URL or local path, you can construct an
+L<PAR::Repository::Client> object manually and pass that to PAR.
+If you specify the C<install =E<gt> 1> option in the C<use PAR>
+line above, the distribution containing C<Module> will be permanently
+installed on your system. (C<use PAR { repository =E<gt> 'http://foo/bar', install =E<gt> 1 };>)
+
+Furthermore, there is an C<upgrade =E<gt> 1> option that checks for upgrades
+in the repository in addition to installing. Please note that an upgraded
+version of a module is only loaded on the next run of your application.
+
+Adding the C<dependencies =E<gt> 1> option will enable PAR::Repository::Client's
+static dependency resolution (PAR::Repository::Client 0.23 and up).
+
+Finally, you can combine the C<run> and C<repository>
+options to run an application directly from a repository! (And you can add
+the C<install> option, too.)
+
+ use PAR { repository => 'http://foo/bar/', run => 'my_app' };
+ # Will not reach this point as we executed my_app,
+
+=head1 DESCRIPTION
+
+This module lets you use special zip files, called B<P>erl B<Ar>chives, as
+libraries from which Perl modules can be loaded.
+
+It supports loading XS modules by overriding B<DynaLoader> bootstrapping
+methods; it writes shared object file to a temporary file at the time it
+is needed.
+
+A F<.par> file is mostly a zip of the F<blib/> directory after the build
+process of a CPAN distribution. To generate a F<.par> file yourself, all
+you have to do is compress the modules under F<arch/> and F<lib/>, e.g.:
+
+ % perl Makefile.PL
+ % make
+ % cd blib
+ % zip -r mymodule.par arch/ lib/
+
+Afterward, you can just use F<mymodule.par> anywhere in your C<@INC>,
+use B<PAR>, and it will Just Work. Support for generating F<.par> files
+is going to be in the next (beyond 0.2805) release of Module::Build.
+
+For convenience, you can set the C<PERL5OPT> environment variable to
+C<-MPAR> to enable C<PAR> processing globally (the overhead is small
+if not used); setting it to C<-MPAR=/path/to/mylib.par> will load a
+specific PAR file. Alternatively, consider using the F<par.pl> utility
+bundled with the L<PAR::Packer> distribution, or using the
+self-contained F<parl> utility which is also distributed with L<PAR::Packer>
+on machines without PAR.pm installed.
+
+Note that self-containing scripts and executables created with F<par.pl>
+and F<pp> may also be used as F<.par> archives:
+
+ % pp -o packed.exe source.pl # generate packed.exe (see PAR::Packer)
+ % perl -MPAR=packed.exe other.pl # this also works
+ % perl -MPAR -Ipacked.exe other.pl # ditto
+
+Please see L</SYNOPSIS> for most typical use cases.
+
+=head1 NOTES
+
+Settings in F<META.yml> packed inside the PAR file may affect PAR's
+operation. For example, F<pp> provides the C<-C> (C<--clean>) option
+to control the default behavior of temporary file creation.
+
+Currently, F<pp>-generated PAR files may attach four PAR-specific
+attributes in F<META.yml>:
+
+ par:
+ clean: 0 # default value of PAR_CLEAN
+ signature: '' # key ID of the SIGNATURE file
+ verbatim: 0 # was packed prerequisite's PODs preserved?
+ version: x.xx # PAR.pm version that generated this PAR
+
+User-defined environment variables, like I<PAR_GLOBAL_CLEAN>, always
+overrides the ones set in F<META.yml>. The algorithm for generating
+caching/temporary directory is as follows:
+
+=over 4
+
+=item *
+
+If I<PAR_GLOBAL_TEMP> is specified, use it as the cache directory for
+extracted libraries, and do not clean it up after execution.
+
+=item *
+
+If I<PAR_GLOBAL_TEMP> is not set, but I<PAR_CLEAN> is specified, set
+I<PAR_GLOBAL_TEMP> to C<I<TEMP>/par-I<USER>/temp-I<PID>/>, cleaning it
+after execution.
+
+=item *
+
+If both are not set, use C<I<TEMP>/par-I<USER>/cache-I<HASH>/> as the
+I<PAR_GLOBAL_TEMP>, reusing any existing files inside.
+
+=back
+
+Here is a description of the variables the previous paths.
+
+=over 4
+
+=item *
+
+I<TEMP> is a temporary directory, which can be set via
+C<$ENV{PAR_GLOBAL_TMPDIR}>,
+C<$ENV{TMPDIR}>, C<$ENV{TEMPDIR}>, C<$ENV{TEMP}>
+or C<$ENV{TMP}>, in that order of priority.
+If none of those are set, I<C:\TEMP>, I</tmp> are checked. If neither
+of them exists, I<.> is used.
+
+=item *
+
+I<USER> is the user name, or SYSTEM if none can be found. On Win32,
+this is C<$Win32::LoginName>. On Unix, this is C<$ENV{USERNAME}> or
+C<$ENV{USER}>.
+
+=item *
+
+I<PID> is the process ID. Forked children use the parent's PID.
+
+=item *
+
+I<HASH> is a crypto-hash of the entire par file or executable,
+calculated at creation time. This value can be overloaded with C<pp>'s
+--tempdir parameter.
+
+=back
+
+By default, PAR strips POD sections from bundled modules. In case
+that causes trouble, you can turn this off by setting the
+environment variable C<PAR_VERBATIM> to C<1>.
+
+=head2 import options
+
+When you "use PAR {...}" or call PAR->import({...}), the following
+options are available.
+
+ PAR->import({ file => 'foo.par' });
+ # or
+ PAR->import({ repository => 'http://foo/bar/' });
+
+=over
+
+=item file
+
+The par filename.
+
+You must pass I<one> option of either 'file' or 'repository'.
+
+=item repository
+
+A par repository (exclusive of file)
+
+=item fallback
+
+Search the system C<@INC> before the par.
+
+Off by default for loading F<.par> files via C<file => ...>.
+On by default for PAR repositories.
+
+To prefer loading modules from a repository over the locally
+installed modules, you can load the repository as follows:
+
+ use PAR { repository => 'http://foo/bar/', fallback => 0 };
+
+=item run
+
+The name of a script to run in the par. Exits when done.
+
+=item no_shlib_unpack
+
+Skip unpacking bundled dynamic libraries from shlib/$archname. The
+client may have them installed, or you may wish to cache them yourself.
+In either case, they must end up in the standard install location (such
+as /usr/local/lib/) or in $ENV{PAR_TEMP} I<before> you require the
+module which needs them. If they are not accessible before you require
+the dependent module, perl will die with a message such as "cannot open
+shared object file..."
+
+=back
+
+=cut
+
+use vars qw(@PAR_INC); # explicitly stated PAR library files (preferred)
+use vars qw(@PAR_INC_LAST); # explicitly stated PAR library files (fallback)
+use vars qw(%PAR_INC); # sets {$par}{$file} for require'd modules
+use vars qw(@LibCache %LibCache); # I really miss pseudohash.
+use vars qw($LastAccessedPAR $LastTempFile);
+use vars qw(@RepositoryObjects); # If we have PAR::Repository::Client support, we
+ # put the ::Client objects in here.
+use vars qw(@PriorityRepositoryObjects); # repositories which are preferred over local stuff
+use vars qw(@UpgradeRepositoryObjects); # If we have PAR::Repository::Client's in upgrade mode
+ # put the ::Client objects in here *as well*.
+use vars qw(%FileCache); # The Zip-file file-name-cache
+ # Layout:
+ # $FileCache{$ZipObj}{$FileName} = $Member
+use vars qw(%ArchivesExtracted); # Associates archive-zip-object => full extraction path
+
+my $ver = $Config{version};
+my $arch = $Config{archname};
+my $progname = $ENV{PAR_PROGNAME} || $0;
+my $is_insensitive_fs = (
+ -s $progname
+ and (-s lc($progname) || -1) == (-s uc($progname) || -1)
+ and (-s lc($progname) || -1) == -s $progname
+);
+
+# lexical for import(), and _import_foo() functions to control unpar()
+my %unpar_options;
+
+# called on "use PAR"
+sub import {
+ my $class = shift;
+
+ PAR::SetupProgname::set_progname();
+ PAR::SetupTemp::set_par_temp_env();
+
+ $progname = $ENV{PAR_PROGNAME} ||= $0;
+ $is_insensitive_fs = (-s $progname and (-s lc($progname) || -1) == (-s uc($progname) || -1));
+
+ my @args = @_;
+
+ # Insert PAR hook in @INC.
+ unshift @INC, \&find_par unless grep { $_ eq \&find_par } @INC;
+ push @INC, \&find_par_last unless grep { $_ eq \&find_par_last } @INC;
+
+ # process args to use PAR 'foo.par', { opts }, ...;
+ foreach my $par (@args) {
+ if (ref($par) eq 'HASH') {
+ # we have been passed a hash reference
+ _import_hash_ref($par);
+ }
+ elsif ($par =~ /[?*{}\[\]]/) {
+ # implement globbing for PAR archives
+ require File::Glob;
+ foreach my $matched (File::Glob::glob($par)) {
+ push @PAR_INC, unpar($matched, undef, undef, 1);
+ }
+ }
+ else {
+ # ordinary string argument => file
+ push @PAR_INC, unpar($par, undef, undef, 1);
+ }
+ }
+
+ return if $PAR::__import;
+ local $PAR::__import = 1;
+
+ require PAR::Heavy;
+ PAR::Heavy::_init_dynaloader();
+
+ # The following code is executed for the case where the
+ # running program is itself a PAR archive.
+ # ==> run script/main.pl
+ if (unpar($progname)) {
+ # XXX - handle META.yml here!
+ push @PAR_INC, unpar($progname, undef, undef, 1);
+
+ _extract_inc($progname) unless $ENV{PAR_CLEAN};
+ if ($LibCache{$progname}) {
+ # XXX bad: this us just a good guess
+ require File::Spec;
+ $ArchivesExtracted{$progname} = File::Spec->catdir($ENV{PAR_TEMP}, 'inc');
+ }
+
+ my $zip = $LibCache{$progname};
+ my $member = _first_member( $zip,
+ "script/main.pl",
+ "main.pl",
+ );
+
+ if ($progname and !$member) {
+ require File::Spec;
+ my @path = File::Spec->splitdir($progname);
+ my $filename = pop @path;
+ $member = _first_member( $zip,
+ "script/".$filename,
+ "script/".$filename.".pl",
+ $filename,
+ $filename.".pl",
+ )
+ }
+
+ # finally take $ARGV[0] as the hint for file to run
+ if (defined $ARGV[0] and !$member) {
+ $member = _first_member( $zip,
+ "script/$ARGV[0]",
+ "script/$ARGV[0].pl",
+ $ARGV[0],
+ "$ARGV[0].pl",
+ ) or die qq(PAR.pm: Can't open perl script "$ARGV[0]": No such file or directory);
+ shift @ARGV;
+ }
+
+
+ if (!$member) {
+ die "Usage: $0 script_file_name.\n";
+ }
+
+ _run_member($member);
+ }
+}
+
+
+# import() helper for the "use PAR {...};" syntax.
+sub _import_hash_ref {
+ my $opt = shift;
+
+ # hash slice assignment -- pass all of the options into unpar
+ local @unpar_options{keys(%$opt)} = values(%$opt);
+
+ # check for incompatible options:
+ if ( exists $opt->{repository} and exists $opt->{file} ) {
+ croak("Invalid PAR loading options. Cannot have a 'repository' and 'file' option at the same time.");
+ }
+ elsif (
+ exists $opt->{file}
+ and (exists $opt->{install} or exists $opt->{upgrade})
+ ) {
+ my $e = exists($opt->{install}) ? 'install' : 'upgrade';
+ croak("Invalid PAR loading options. Cannot combine 'file' and '$e' options.");
+ }
+ elsif ( not exists $opt->{repository} and not exists $opt->{file} ) {
+ croak("Invalid PAR loading options. Need at least one of 'file' or 'repository' options.");
+ }
+
+ # load from file
+ if (exists $opt->{file}) {
+ croak("Cannot load undefined PAR archive")
+ if not defined $opt->{file};
+
+ # for files, we default to loading from PAR archive first
+ my $fallback = $opt->{fallback};
+ $fallback = 0 if not defined $fallback;
+
+ if (not $fallback) {
+ # load from this PAR arch preferably
+ push @PAR_INC, unpar($opt->{file}, undef, undef, 1);
+ }
+ else {
+ # load from this PAR arch as fallback
+ push @PAR_INC_LAST, unpar($opt->{file}, undef, undef, 1);
+ }
+
+ }
+ else {
+ # Deal with repositories elsewhere
+ my $client = _import_repository($opt);
+ return() if not $client;
+
+ if (defined $opt->{run}) {
+ # run was specified
+ # run the specified script from the repository
+ $client->run_script( $opt->{run} );
+ return 1;
+ }
+
+ return 1;
+ }
+
+ # run was specified
+ # run the specified script from inside the PAR file.
+ if (defined $opt->{run}) {
+ my $script = $opt->{run};
+ require PAR::Heavy;
+ PAR::Heavy::_init_dynaloader();
+
+ # XXX - handle META.yml here!
+ _extract_inc($opt->{file}) unless $ENV{PAR_CLEAN};
+
+ my $zip = $LibCache{$opt->{file}};
+ my $member = _first_member( $zip,
+ (($script !~ /^script\//) ? ("script/$script", "script/$script.pl") : ()),
+ $script,
+ "$script.pl",
+ );
+
+ if (not defined $member) {
+ croak("Cannot run script '$script' from PAR file '$opt->{file}'. Script couldn't be found in PAR file.");
+ }
+
+ _run_member_from_par($member);
+ }
+
+ return();
+}
+
+
+# This sub is invoked by _import_hash_ref if a {repository}
+# option is found
+# Returns the repository client object on success.
+sub _import_repository {
+ my $opt = shift;
+ my $url = $opt->{repository};
+
+ eval "require PAR::Repository::Client; 1;";
+ if ($@ or not eval PAR::Repository::Client->VERSION >= 0.04) {
+ croak "In order to use the 'use PAR { repository => 'url' };' syntax, you need to install the PAR::Repository::Client module (version 0.04 or later) from CPAN. This module does not seem to be installed as indicated by the following error message: $@";
+ }
+
+ if ($opt->{upgrade} and not eval PAR::Repository::Client->VERSION >= 0.22) {
+ croak "In order to use the 'upgrade' option, you need to install the PAR::Repository::Client module (version 0.22 or later) from CPAN";
+ }
+
+ if ($opt->{dependencies} and not eval PAR::Repository::Client->VERSION >= 0.23) {
+ croak "In order to use the 'dependencies' option, you need to install the PAR::Repository::Client module (version 0.23 or later) from CPAN";
+ }
+
+ my $obj;
+
+ # Support existing clients passed in as objects.
+ if (ref($url) and UNIVERSAL::isa($obj, 'PAR::Repository::Client')) {
+ $obj = $url;
+ }
+ else {
+ $obj = PAR::Repository::Client->new(
+ uri => $url,
+ auto_install => $opt->{install},
+ auto_upgrade => $opt->{upgrade},
+ static_dependencies => $opt->{dependencies},
+ );
+ }
+
+ if (exists($opt->{fallback}) and not $opt->{fallback}) {
+ push @PriorityRepositoryObjects, $obj; # repository beats local stuff
+ } else {
+ push @RepositoryObjects, $obj; # local stuff beats repository
+ }
+ # these are tracked separately so we can check for upgrades early
+ push @UpgradeRepositoryObjects, $obj if $opt->{upgrade};
+
+ return $obj;
+}
+
+# Given an Archive::Zip obj and a list of files/paths,
+# this function returns the Archive::Zip::Member for the
+# first of the files found in the ZIP. If none is found,
+# returns the empty list.
+sub _first_member {
+ my $zip = shift;
+ foreach my $name (@_) {
+ my $member = _cached_member_named($zip, $name);
+ return $member if $member;
+ }
+ return;
+}
+
+# Given an Archive::Zip object, this finds the first
+# Archive::Zip member whose file name matches the
+# regular expression
+sub _first_member_matching {
+ my $zip = shift;
+ my $regex = shift;
+
+ my $cache = $FileCache{$zip};
+ $cache = $FileCache{$zip} = _make_file_cache($zip) if not $cache;
+
+ foreach my $name (keys %$cache) {
+ if ($name =~ $regex) {
+ return $cache->{$name};
+ }
+ }
+
+ return();
+}
+
+
+sub _run_member_from_par {
+ my $member = shift;
+ my $clear_stack = shift;
+ my ($fh, $is_new, $filename) = _tempfile($member->crc32String . ".pl");
+
+ if ($is_new) {
+ my $file = $member->fileName;
+ print $fh "package main;\n";
+ print $fh "#line 1 \"$file\"\n";
+ $member->extractToFileHandle($fh);
+ seek ($fh, 0, 0);
+ }
+
+ $ENV{PAR_0} = $filename; # for Pod::Usage
+ { do $filename;
+ CORE::exit($1) if ($@ =~/^_TK_EXIT_\((\d+)\)/);
+ die $@ if $@;
+ exit;
+ }
+}
+
+sub _run_member {
+ my $member = shift;
+ my $clear_stack = shift;
+ my ($fh, $is_new, $filename) = _tempfile($member->crc32String . ".pl");
+
+ if ($is_new) {
+ my $file = $member->fileName;
+ print $fh "package main; shift \@INC;\n";
+ if (defined &Internals::PAR::CLEARSTACK and $clear_stack) {
+ print $fh "Internals::PAR::CLEARSTACK();\n";
+ }
+ print $fh "#line 1 \"$file\"\n";
+ $member->extractToFileHandle($fh);
+ seek ($fh, 0, 0);
+ }
+
+ unshift @INC, sub { $fh };
+
+ $ENV{PAR_0} = $filename; # for Pod::Usage
+ { do 'main';
+ CORE::exit($1) if ($@ =~/^_TK_EXIT_\((\d+)\)/);
+ die $@ if $@;
+ exit;
+ }
+}
+
+sub _run_external_file {
+ my $filename = shift;
+ my $clear_stack = shift;
+ require 5.008;
+ open my $ffh, '<', $filename
+ or die "Can't open perl script \"$filename\": $!";
+
+ my $clearstack = '';
+ if (defined &Internals::PAR::CLEARSTACK and $clear_stack) {
+ $clear_stack = "Internals::PAR::CLEARSTACK();\n";
+ }
+ my $string = "package main; shift \@INC;\n$clearstack#line 1 \"$filename\"\n"
+ . do { local $/ = undef; <$ffh> };
+ close $ffh;
+
+ open my $fh, '<', \$string
+ or die "Can't open file handle to string: $!";
+
+ unshift @INC, sub { $fh };
+
+ $ENV{PAR_0} = $filename; # for Pod::Usage
+ { do 'main';
+ CORE::exit($1) if ($@ =~/^_TK_EXIT_\((\d+)\)/);
+ die $@ if $@;
+ exit;
+ }
+}
+
+# extract the contents of a .par (or .exe) or any
+# Archive::Zip handle to the PAR_TEMP/inc directory.
+# returns that directory.
+sub _extract_inc {
+ my $file_or_azip_handle = shift;
+ my $force_extract = shift;
+ my $inc = "$PAR::SetupTemp::PARTemp/inc";
+ my $dlext = defined($Config{dlext}) ? $Config::Config{dlext} : '';
+ my $inc_exists = -d $inc;
+ my $is_handle = ref($file_or_azip_handle) && $file_or_azip_handle->isa('Archive::Zip::Archive');
+
+ require File::Spec;
+
+ if (!$inc_exists or $force_extract) {
+ for (1 .. 10) { mkdir("$inc.lock", 0755) and last; sleep 1 }
+
+ undef $@;
+ if (!$is_handle) {
+ # First try to unzip the *fast* way.
+ eval {
+ require Archive::Unzip::Burst;
+ Archive::Unzip::Burst::unzip($file_or_azip_handle, $inc)
+ and die "Could not unzip '$file_or_azip_handle' into '$inc'. Error: $!";
+ die;
+ };
+
+ # This means the fast module is there, but didn't work.
+ if ($@ =~ /^Could not unzip/) {
+ die $@;
+ }
+ }
+
+ # either failed to load Archive::Unzip::Burst or got an A::Zip handle
+ # fallback to slow way.
+ if ($is_handle || $@) {
+ my $zip;
+ if (!$is_handle) {
+ open my $fh, '<', $file_or_azip_handle
+ or die "Cannot find '$file_or_azip_handle': $!";
+ binmode($fh);
+ bless($fh, 'IO::File');
+
+ $zip = Archive::Zip->new;
+ ( $zip->readFromFileHandle($fh, $file_or_azip_handle) == Archive::Zip::AZ_OK() )
+ or die "Read '$file_or_azip_handle' error: $!";
+ }
+ else {
+ $zip = $file_or_azip_handle;
+ }
+
+ mkdir($inc) if not -d $inc;
+
+ for ( $zip->memberNames() ) {
+ next if m{\.\Q$dlext\E[^/]*$};
+ s{^/}{};
+ my $outfile = File::Spec->catfile($inc, $_);
+ next if -e $outfile and not -w _;
+ $zip->extractMember($_, "$inc/" . $_);
+ }
+ }
+
+ rmdir("$inc.lock");
+
+ $ArchivesExtracted{$is_handle ? $file_or_azip_handle->fileName() : $file_or_azip_handle} = $inc;
+ }
+
+ # add the freshly extracted directories to @INC,
+ # but make sure there's no duplicates
+ my %inc_exists = map { ($_, 1) } @INC;
+ unshift @INC, grep !exists($inc_exists{$_}),
+ grep -d,
+ map File::Spec->catdir($inc, @$_),
+ [ 'lib' ], [ 'arch' ], [ $arch ],
+ [ $ver ], [ $ver, $arch ], [];
+
+ return $inc;
+}
+
+
+# This is the hook placed in @INC for loading PAR's
+# before any other stuff in @INC
+sub find_par {
+ my @args = @_;
+
+ # if there are repositories in upgrade mode, check them
+ # first. If so, this is expensive, of course!
+ if (@UpgradeRepositoryObjects) {
+ my $module = $args[1];
+ $module =~ s/\.pm$//;
+ $module =~ s/\//::/g;
+ foreach my $client (@UpgradeRepositoryObjects) {
+ my $local_file = $client->upgrade_module($module);
+
+ # break the require if upgrade_module has been required already
+ # to avoid infinite recursion
+ if (exists $INC{$args[1]}) {
+ # Oh dear. Check for the possible return values of the INC sub hooks in
+ # perldoc -f require before trying to understand this.
+ # Then, realize that if you pass undef for the file handle, perl (5.8.9)
+ # does NOT use the subroutine. Thus the hacky GLOB ref.
+ my $line = 1;
+ no warnings;
+ return (\*I_AM_NOT_HERE, sub {$line ? ($_="1;",$line=0,return(1)) : ($_="",return(0))});
+ }
+
+ # Note: This is likely not necessary as the module has been installed
+ # into the system by upgrade_module if it was available at all.
+ # If it was already loaded, this will not be reached (see return right above).
+ # If it could not be loaded from the system and neither found in the repository,
+ # we simply want to have the normal error message, too!
+ #
+ #if ($local_file) {
+ # # XXX load with fallback - is that right?
+ # return _find_par_internals([$PAR_INC_LAST[-1]], @args);
+ #}
+ }
+ }
+ my $rv = _find_par_internals(\@PAR_INC, @args);
+
+ return $rv if defined $rv or not @PriorityRepositoryObjects;
+
+ # the repositories that are prefered over locally installed modules
+ my $module = $args[1];
+ $module =~ s/\.pm$//;
+ $module =~ s/\//::/g;
+ foreach my $client (@PriorityRepositoryObjects) {
+ my $local_file = $client->get_module($module, 0); # 1 == fallback
+ if ($local_file) {
+ # Not loaded as fallback (cf. PRIORITY) thus look at PAR_INC
+ # instead of PAR_INC_LAST
+ return _find_par_internals([$PAR_INC[-1]], @args);
+ }
+ }
+ return();
+}
+
+# This is the hook placed in @INC for loading PAR's
+# AFTER any other stuff in @INC
+# It also deals with loading from repositories as a
+# fallback-fallback ;)
+sub find_par_last {
+ my @args = @_;
+ # Try the local PAR files first
+ my $rv = _find_par_internals(\@PAR_INC_LAST, @args);
+ return $rv if defined $rv;
+
+ # No repositories => return
+ return $rv if not @RepositoryObjects;
+
+ my $module = $args[1];
+ $module =~ s/\.pm$//;
+ $module =~ s/\//::/g;
+ foreach my $client (@RepositoryObjects) {
+ my $local_file = $client->get_module($module, 1); # 1 == fallback
+ if ($local_file) {
+ # Loaded as fallback thus look at PAR_INC_LAST
+ return _find_par_internals([$PAR_INC_LAST[-1]], @args);
+ }
+ }
+ return $rv;
+}
+
+
+# This routine implements loading modules from PARs
+# both for loading PARs preferably or as fallback.
+# To distinguish the cases, the first parameter should
+# be a reference to the corresponding @PAR_INC* array.
+sub _find_par_internals {
+ my ($INC_ARY, $self, $file, $member_only) = @_;
+
+ my $scheme;
+ foreach (@$INC_ARY ? @$INC_ARY : @INC) {
+ my $path = $_;
+ if ($] < 5.008001) {
+ # reassemble from "perl -Ischeme://path" autosplitting
+ $path = "$scheme:$path" if !@$INC_ARY
+ and $path and $path =~ m!//!
+ and $scheme and $scheme =~ /^\w+$/;
+ $scheme = $path;
+ }
+ my $rv = unpar($path, $file, $member_only, 1) or next;
+ $PAR_INC{$path}{$file} = 1;
+ $INC{$file} = $LastTempFile if (lc($file) =~ /^(?!tk).*\.pm$/);
+ return $rv;
+ }
+
+ return;
+}
+
+sub reload_libs {
+ my @par_files = @_;
+ @par_files = sort keys %LibCache unless @par_files;
+
+ foreach my $par (@par_files) {
+ my $inc_ref = $PAR_INC{$par} or next;
+ delete $LibCache{$par};
+ delete $FileCache{$par};
+ foreach my $file (sort keys %$inc_ref) {
+ delete $INC{$file};
+ require $file;
+ }
+ }
+}
+
+#sub find_zip_member {
+# my $file = pop;
+#
+# foreach my $zip (@LibCache) {
+# my $member = _first_member($zip, $file) or next;
+# return $member;
+# }
+#
+# return;
+#}
+
+sub read_file {
+ my $file = pop;
+
+ foreach my $zip (@LibCache) {
+ my $member = _first_member($zip, $file) or next;
+ return scalar $member->contents;
+ }
+
+ return;
+}
+
+sub par_handle {
+ my $par = pop;
+ return $LibCache{$par};
+}
+
+my %escapes;
+sub unpar {
+ my ($par, $file, $member_only, $allow_other_ext) = @_;
+ return if not defined $par;
+ my $zip = $LibCache{$par};
+ my @rv = $par;
+
+ # a guard against (currently unimplemented) recursion
+ return if $PAR::__unpar;
+ local $PAR::__unpar = 1;
+
+ unless ($zip) {
+ # URL use case ==> download
+ if ($par =~ m!^\w+://!) {
+ require File::Spec;
+ require LWP::Simple;
+
+ # reflector support
+ $par .= "pm=$file" if $par =~ /[?&;]/;
+
+ # prepare cache directory
+ $ENV{PAR_CACHE} ||= '_par';
+ mkdir $ENV{PAR_CACHE}, 0777;
+ if (!-d $ENV{PAR_CACHE}) {
+ $ENV{PAR_CACHE} = File::Spec->catdir(File::Spec->tmpdir, 'par');
+ mkdir $ENV{PAR_CACHE}, 0777;
+ return unless -d $ENV{PAR_CACHE};
+ }
+
+ # Munge URL into local file name
+ # FIXME: This might result in unbelievably long file names!
+ # I have run into the file/path length limitations of linux
+ # with similar code in PAR::Repository::Client.
+ # I suspect this is even worse on Win32.
+ # -- Steffen
+ my $file = $par;
+ if (!%escapes) {
+ $escapes{chr($_)} = sprintf("%%%02X", $_) for 0..255;
+ }
+ {
+ use bytes;
+ $file =~ s/([^\w\.])/$escapes{$1}/g;
+ }
+
+ $file = File::Spec->catfile( $ENV{PAR_CACHE}, $file);
+ LWP::Simple::mirror( $par, $file );
+ return unless -e $file and -f _;
+ $par = $file;
+ }
+ # Got the .par as a string. (reference to scalar, of course)
+ elsif (ref($par) eq 'SCALAR') {
+ my ($fh) = _tempfile();
+ print $fh $$par;
+ $par = $fh;
+ }
+ # If the par is not a valid .par file name and we're being strict
+ # about this, then also check whether "$par.par" exists
+ elsif (!(($allow_other_ext or $par =~ /\.par\z/i) and -f $par)) {
+ $par .= ".par";
+ return unless -f $par;
+ }
+
+ require Archive::Zip;
+ $zip = Archive::Zip->new;
+
+ my @file;
+ if (!ref $par) {
+ @file = $par;
+
+ open my $fh, '<', $par;
+ binmode($fh);
+
+ $par = $fh;
+ bless($par, 'IO::File');
+ }
+
+ Archive::Zip::setErrorHandler(sub {});
+ my $rv = $zip->readFromFileHandle($par, @file);
+ Archive::Zip::setErrorHandler(undef);
+ return unless $rv == Archive::Zip::AZ_OK();
+
+ push @LibCache, $zip;
+ $LibCache{$_[0]} = $zip;
+ $FileCache{$_[0]} = _make_file_cache($zip);
+
+ # only recursive case -- appears to be unused and unimplemented
+ foreach my $member ( _cached_members_matching($zip,
+ "^par/(?:$Config{version}/)?(?:$Config{archname}/)?"
+ ) ) {
+ next if $member->isDirectory;
+ my $content = $member->contents();
+ next unless $content =~ /^PK\003\004/;
+ push @rv, unpar(\$content, undef, undef, 1);
+ }
+
+ # extract all shlib dlls from the .par to $ENV{PAR_TEMP}
+ # Intended to fix problem with Alien::wxWidgets/Wx...
+ # NOTE auto/foo/foo.so|dll will get handled by the dynaloader
+ # hook, so no need to pull it out here.
+ # Allow this to be disabled so caller can do their own caching
+ # via import({no_shlib_unpack => 1, file => foo.par})
+ if(not $unpar_options{no_shlib_unpack} and defined $ENV{PAR_TEMP}) {
+ my @members = _cached_members_matching( $zip,
+ qr#^shlib/$Config{archname}/.*\.\Q$Config{dlext}\E(?:\.|$)#
+ );
+ foreach my $member (@members) {
+ next if $member->isDirectory;
+ my $member_name = $member->fileName;
+ next unless $member_name =~ m{
+ \/([^/]+)$
+ }x
+ or $member_name =~ m{
+ ^([^/]+)$
+ };
+ my $extract_name = $1;
+ my $dest_name =
+ File::Spec->catfile($ENV{PAR_TEMP}, $extract_name);
+ # but don't extract it if we've already got one
+ $member->extractToFileNamed($dest_name)
+ unless(-e $dest_name);
+ }
+ }
+
+ # Now push this path into usual library search paths
+ my $separator = $Config{path_sep};
+ my $tempdir = $ENV{PAR_TEMP};
+ foreach my $key (qw(
+ LD_LIBRARY_PATH
+ LIB_PATH
+ LIBRARY_PATH
+ PATH
+ DYLD_LIBRARY_PATH
+ )) {
+ if (defined $ENV{$key} and $ENV{$key} ne '') {
+ # Check whether it's already in the path. If so, don't
+ # append the PAR temp dir in order not to overflow the
+ # maximum length for ENV vars.
+ $ENV{$key} .= $separator . $tempdir
+ unless grep { $_ eq $tempdir } split $separator, $ENV{$key};
+ }
+ else {
+ $ENV{$key} = $tempdir;
+ }
+ }
+
+ }
+
+ $LastAccessedPAR = $zip;
+
+ return @rv unless defined $file;
+
+ my $member = _first_member($zip,
+ "lib/$file",
+ "arch/$file",
+ "$arch/$file",
+ "$ver/$file",
+ "$ver/$arch/$file",
+ $file,
+ ) or return;
+
+ return $member if $member_only;
+
+ my ($fh, $is_new);
+ ($fh, $is_new, $LastTempFile) = _tempfile($member->crc32String . ".pm");
+ die "Bad Things Happened..." unless $fh;
+
+ if ($is_new) {
+ $member->extractToFileHandle($fh);
+ seek ($fh, 0, 0);
+ }
+
+ return $fh;
+}
+
+sub _tempfile {
+ my ($fh, $filename);
+ if ($ENV{PAR_CLEAN} or !@_) {
+ require File::Temp;
+
+ if (defined &File::Temp::tempfile) {
+ # under Win32, the file is created with O_TEMPORARY,
+ # and will be deleted by the C runtime; having File::Temp
+ # delete it has the only effect of giving ugly warnings
+ ($fh, $filename) = File::Temp::tempfile(
+ DIR => $PAR::SetupTemp::PARTemp,
+ UNLINK => ($^O ne 'MSWin32' and $^O !~ /hpux/),
+ ) or die "Cannot create temporary file: $!";
+ binmode($fh);
+ return ($fh, 1, $filename);
+ }
+ }
+
+ require File::Spec;
+
+ # untainting tempfile path
+ local $_ = File::Spec->catfile( $PAR::SetupTemp::PARTemp, $_[0] );
+ /^(.+)$/ and $filename = $1;
+
+ if (-r $filename) {
+ open $fh, '<', $filename or die $!;
+ binmode($fh);
+ return ($fh, 0, $filename);
+ }
+
+ open $fh, '+>', $filename or die $!;
+ binmode($fh);
+ return ($fh, 1, $filename);
+}
+
+# Given an Archive::Zip object, this generates a hash of
+# file_name_in_zip => file object
+# and returns a reference to that.
+# If we broke the encapsulation of A::Zip::Member and
+# accessed $member->{fileName} directly, that would be
+# *significantly* faster.
+sub _make_file_cache {
+ my $zip = shift;
+ if (not ref($zip)) {
+ croak("_make_file_cache needs an Archive::Zip object as argument.");
+ }
+ my $cache = {};
+ foreach my $member ($zip->members) {
+ $cache->{$member->fileName()} = $member;
+ }
+ return $cache;
+}
+
+# given an Archive::Zip object, this finds the cached hash
+# of Archive::Zip member names => members,
+# and returns all member objects whose file names match
+# a regexp
+# Without file caching, it just uses $zip->membersMatching
+sub _cached_members_matching {
+ my $zip = shift;
+ my $regex = shift;
+
+ my $cache = $FileCache{$zip};
+ $cache = $FileCache{$zip} = _make_file_cache($zip) if not $cache;
+
+ return map {$cache->{$_}}
+ grep { $_ =~ $regex }
+ keys %$cache;
+}
+
+# access named zip file member through cache. Fall
+# back to using Archive::Zip (slow)
+sub _cached_member_named {
+ my $zip = shift;
+ my $name = shift;
+
+ my $cache = $FileCache{$zip};
+ $cache = $FileCache{$zip} = _make_file_cache($zip) if not $cache;
+ return $cache->{$name};
+}
+
+
+# Attempt to clean up the temporary directory if
+# --> We're running in clean mode
+# --> It's defined
+# --> It's an existing directory
+# --> It's empty
+END {
+ if (exists $ENV{PAR_CLEAN} and $ENV{PAR_CLEAN}
+ and exists $ENV{PAR_TEMP} and defined $ENV{PAR_TEMP} and -d $ENV{PAR_TEMP}
+ ) {
+ local($!); # paranoid: ignore potential errors without clobbering a global variable!
+ rmdir($ENV{PAR_TEMP});
+ }
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+The PAR homepage at L<http://par.perl.org>.
+
+L<PAR::Tutorial>, L<PAR::FAQ> (For a more
+current FAQ, refer to the homepage.)
+
+The L<PAR::Packer> distribution which contains the packaging utilities:
+L<par.pl>, L<parl>, L<pp>.
+
+L<PAR::Dist> for details on PAR distributions.
+
+L<PAR::Repository::Client> for details on accessing PAR repositories.
+L<PAR::Repository> for details on how to set up such a repository.
+
+L<Archive::Zip>, L<perlfunc/require>
+
+L<ex::lib::zip>, L<Acme::use::strict::with::pride>
+
+Steffen Mueller has detailed slides on using PAR for application
+deployment at L<http://steffen-mueller.net/talks/appdeployment/>.
+
+PAR supports the L<prefork> module. It declares various run-time
+dependencies so you can use the L<prefork> module to get streamlined
+processes in a forking environment.
+
+=head1 ACKNOWLEDGMENTS
+
+Nicholas Clark for pointing out the mad source filter hook within the
+(also mad) coderef C<@INC> hook, as well as (even madder) tricks one
+can play with PerlIO to avoid source filtering.
+
+Ton Hospel for convincing me to ditch the C<Filter::Simple>
+implementation.
+
+Uri Guttman for suggesting C<read_file> and C<par_handle> interfaces.
+
+Antti Lankila for making me implement the self-contained executable
+options via C<par.pl -O>.
+
+See the F<AUTHORS> file in the distribution for a list of people who
+have sent helpful patches, ideas or comments.
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+Steffen Mueller E<lt>smueller@cpan.orgE<gt>
+
+L<http://par.perl.org/> is the official PAR website. You can write
+to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty mail to
+E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
+
+Please submit bug reports to E<lt>bug-par@rt.cpan.orgE<gt>. If you need
+support, however, joining the E<lt>par@perl.orgE<gt> mailing list is
+preferred.
+
+=head1 COPYRIGHT
+
+Copyright 2002-2009 by Audrey Tang
+E<lt>cpan@audreyt.orgE<gt>.
+Copyright 2005-2009 by Steffen Mueller E<lt>smueller@cpan.orgE<gt>
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/POSIX.pm b/Master/tlpkg/tlperl.straw/lib/POSIX.pm
new file mode 100755
index 00000000000..120769c6232
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.17";
+
+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.straw/lib/POSIX.pod b/Master/tlpkg/tlperl.straw/lib/POSIX.pod
new file mode 100755
index 00000000000..7263d0a62a0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/POSIX.pod
@@ -0,0 +1,2210 @@
+=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 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_ALL, "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.straw/lib/PPM/RelocPerl.pm b/Master/tlpkg/tlperl.straw/lib/PPM/RelocPerl.pm
new file mode 100755
index 00000000000..dc512e500c0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PPM/RelocPerl.pm
@@ -0,0 +1,85 @@
+#
+# Search for our Unix signature in text and binary files
+# and replace it with the real prefix ($Config{prefix} by default).
+#
+package PPM::RelocPerl;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(RelocPerl);
+
+use File::Find;
+use Config;
+use strict;
+use vars qw( $VERSION );
+$VERSION = '0.01_01';
+
+# We have to build up this variable, otherwise
+# PPM will mash it when it upgrades itself.
+my $frompath_default
+ = '/tmp' . '/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl'
+;
+my ($topath, $frompath);
+
+sub wanted {
+ if (-l) {
+ return; # do nothing for symlinks
+ }
+ elsif (-B) {
+ check_for_frompath($_, 1); # binary file edit
+ }
+ elsif (-e && -s && -f) {
+ check_for_frompath($_, 0); # text file edit
+ }
+}
+
+sub check_for_frompath {
+ my ($file, $binmode) = @_;
+ local(*F, $_);
+ open(F, "<$file") or die "Can't open `$file': $!";
+ binmode F if $binmode;
+ while (<F>) {
+ if (/\Q$frompath\E/o) {
+ close F;
+ edit_it($file, $binmode);
+ last;
+ }
+ }
+ # implicit close of F;
+}
+
+sub edit_it
+{
+ my ($file, $binmode) = @_;
+ my $nullpad = length($frompath) - length($topath);
+ $nullpad = "\0" x $nullpad;
+
+ local $/;
+ # Force the file to be writable
+ my $mode = (stat($file))[2] & 07777;
+ chmod $mode | 0222, $file;
+ open(F, "+<$file") or die "Couldn't open $file: $!";
+ binmode(F) if $binmode;
+ my $dat = <F>;
+ if ($binmode) {
+ $dat =~ s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|gs;
+ } else {
+ $dat =~ s|\Q$frompath\E|$topath|gs;
+ }
+ seek(F, 0, 0) or die "Couldn't seek on $file: $!";
+ print F $dat;
+ close(F);
+ # Restore the permissions
+ chmod $mode, $file;
+}
+
+sub RelocPerl
+{
+ my ($dir, $opt_topath, $opt_frompath) = @_;
+ $topath = defined $opt_topath ? $opt_topath : $Config{'prefix'};
+ $frompath = defined $opt_frompath ? $opt_frompath : $frompath_default;
+
+ find(\&wanted, $dir);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/PPM/XML/Element.pm b/Master/tlpkg/tlperl.straw/lib/PPM/XML/Element.pm
new file mode 100755
index 00000000000..055d9b15b82
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PPM/XML/Element.pm
@@ -0,0 +1,238 @@
+package PPM::XML::Element;
+use vars qw( $VERSION );
+$VERSION = '0.01_01';
+
+#
+# PPM::XML::Element
+#
+# Base class for XML Elements. Provides the ability to output the XML document
+# once it's been parsed using the XML::Parser module.
+#
+###############################################################################
+
+###############################################################################
+# Required inclusions.
+###############################################################################
+use HTML::Entities; # Needed for escaping char entities
+
+###############################################################################
+# Allow for creation via 'new'.
+###############################################################################
+sub new
+{
+ my ($class, %args) = @_;
+ bless \%args, $class;
+}
+
+###############################################################################
+# Subroutine: output
+###############################################################################
+# Outputs the entire XML document on the currently selected filehandle.
+###############################################################################
+sub output
+{
+ my $self = shift;
+ print $self->as_text();
+}
+
+###############################################################################
+# Subroutine: content
+###############################################################################
+# Returns a string containing all of the content of this element.
+###############################################################################
+sub content
+{
+ my $self = shift;
+ my $kids = $self->{'Kids'};
+ return unless (defined $kids and ref($kids) eq 'ARRAY');
+ my @kids = @{ $kids };
+ my $text;
+
+ if (@kids > 0)
+ {
+ foreach (@kids)
+ {
+ # Allow for outputting of char data
+ if ((ref $_) =~ /::Characters$/o)
+ { $text .= encode_entities( $_->{'Text'} ); }
+ else
+ { $text .= $_->as_text(); }
+ }
+ }
+
+ return $text;
+}
+
+###############################################################################
+# Subroutine: add_child ($elemref)
+###############################################################################
+# Adds a new child element to ourselves.
+###############################################################################
+sub add_child (\$)
+{
+ my $self = shift;
+ my $elemref = shift;
+ push( @{$self->{'Kids'}}, $elemref );
+}
+
+###############################################################################
+# Subroutine: remove_child ($elemref)
+###############################################################################
+# Removes a child element from ourselves. Returns non-zero if it was able to
+# remove the child element, and zero if it was unable to do so.
+###############################################################################
+sub remove_child
+{
+ my $self = shift;
+ my $elemref = shift;
+
+ foreach my $idx (0 .. @{$self->{'Kids'}})
+ {
+ if ($self->{'Kids'}[$idx] == $elemref)
+ {
+ splice( @{$self->{'Kids'}}, $idx, 1 );
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+###############################################################################
+# Subroutine: add_text ($text)
+###############################################################################
+# Adds character data to the given element. Returns undef if unable to add the
+# text to this element, and returns a reference to the character data element
+# if successful.
+###############################################################################
+sub add_text
+{
+ my $self = shift;
+ my $text = shift;
+
+ return if (!defined $text);
+
+ my $type = ref $self; # Do package name magic
+ $type =~ s/::[^:]+?$/::Characters/o;
+
+ my $elem = new $type;
+ $elem->{'Text'} = $text;
+ $self->add_child( $elem );
+ return $elem;
+}
+
+###############################################################################
+# Subroutine: as_text
+###############################################################################
+# Returns a string containing the entire XML document.
+###############################################################################
+sub as_text
+{
+ my $self = shift;
+ my $text;
+
+ my $type = ref $self;
+ $type =~ s/.*:://;
+
+ $text = "\n<" . $type;
+ foreach (sort keys %{$self})
+ {
+ if ($_ !~ /Text|Kids/) {
+ if (defined $self->{$_} ) {
+ $text .= " $_=\"" . $self->{$_} . '"'; }
+ }
+ }
+
+ my $cont = $self->content();
+ if (defined $cont)
+ { $text .= '>' . $cont . '</' . $type . '>'; }
+ else
+ { $text .= ' />'; }
+
+ $text =~ s/\n\n/\n/g;
+ return $text;
+}
+
+__END__
+
+###############################################################################
+# PPD Documentation
+###############################################################################
+
+=head1 NAME
+
+PPM::XML::Element - Base element class for XML elements
+
+=head1 SYNOPSIS
+
+ use PPM::XML::Element;
+ @ISA = qw( PPM::XML::Element );
+
+=head1 DESCRIPTION
+
+Base element class for XML elements. To be derived from to create your own
+elements for use with the XML::Parser module. Supports output of empty
+elements using <.... />.
+
+It is recommended that you use a version of the XML::Parser module which
+includes support for Styles; by deriving your own elements from
+PPM::XML::Element and using the 'Objects' style it becomes B<much> easier
+to create your own parser.
+
+=head1 METHODS
+
+=over 4
+
+=item add_text ($text)
+
+Adds character data to the end of the element. The element created is placed
+within the same package space as the element it was created under (e.g. adding
+text to a XML::Foobar::Stuff element would put the character data into an
+XML::Foobar::Characters element). If successful, this method returns a
+reference to the newly created element.
+
+=item as_text
+
+Returns a string value containing the entire XML document from this element on
+down.
+
+=item content
+
+Returns a string value containing the entire content of this XML element. Note
+that this is quite similar to the C<as_text()> method except that it does not
+include any information about this element in particular.
+
+=item output
+
+Recursively outputs the structure of the XML document from this element on
+down.
+
+=item add_child ($elemref)
+
+Adds the child element to the list of children for this element. Note that
+the element given must be a reference to an object derived from
+C<PPM::XML::Element>.
+
+=item remove_child ($elemref)
+
+Removes the given child element from the list of children for this element.
+This method returns non-zero if it is able to locate and remove the child
+element, returning zero if it is unable to do so.
+
+=back
+
+=head1 LIMITATIONS
+
+The C<PPM::XML::Element> module has no provisions for outputting processor
+directives or external entities. It only outputs child elements and any
+character data which the elements may contain.
+
+=head1 AUTHORS
+
+Graham TerMarsch <gtermars@activestate.com>
+
+=head1 SEE ALSO
+
+L<XML::Parser>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/PPM/XML/PPD.pm b/Master/tlpkg/tlperl.straw/lib/PPM/XML/PPD.pm
new file mode 100755
index 00000000000..044124fad8c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PPM/XML/PPD.pm
@@ -0,0 +1,622 @@
+#
+# PPM::XML::PPD
+#
+# Definition of the PPD file format.
+#
+###############################################################################
+
+use PPM::XML::ValidatingElement;
+use Exporter;
+
+###############################################################################
+# Set up PPM::XML::PPD to export its sub-packages so that we can use them in
+# other XML documents without too much effort.
+###############################################################################
+package PPM::XML::PPD;
+use vars qw( $VERSION );
+$VERSION = '0.01_01';
+@ISA = qw( Exporter );
+%EXPORT_TAGS = ( 'elements' =>
+ [ '%SOFTPKG::', '%IMPLEMENTATION::', '%DEPENDENCY::',
+ '%TITLE::', '%ABSTRACT::', '%AUTHOR::',
+ '%LANGUAGE::', '%LICENSE::', '%OS::',
+ '%OSVERSION::', '%PERLCORE::', '%PROCESSOR::',
+ '%CODEBASE::', '%INSTALL::', '%UNINSTALL::',
+ '%ARCHITECTURE::', '%PROVIDE::', '%REQUIRE::',
+ ] );
+Exporter::export_ok_tags( 'elements' );
+
+###############################################################################
+# PPD Element: SOFTPKG
+###############################################################################
+package PPM::XML::PPD::SOFTPKG;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( VERSION );
+@rattrs = qw( NAME );
+@okids = qw( ABSTRACT AUTHOR IMPLEMENTATION LICENSE
+ TITLE INSTALL UNINSTALL PROVIDE REQUIRE);
+
+###############################################################################
+# PPD Element: TITLE
+###############################################################################
+package PPM::XML::PPD::TITLE;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPD Element: ABSTRACT
+###############################################################################
+package PPM::XML::PPD::ABSTRACT;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPD Element: AUTHOR
+###############################################################################
+package PPM::XML::PPD::AUTHOR;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPD Element: PROVIDE
+###############################################################################
+package PPM::XML::PPD::PROVIDE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( VERSION );
+@rattrs = qw( NAME );
+
+###############################################################################
+# PPD Element: REQUIRE
+###############################################################################
+package PPM::XML::PPD::REQUIRE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( VERSION );
+@rattrs = qw( NAME );
+
+###############################################################################
+# PPD Element: LICENSE
+###############################################################################
+package PPM::XML::PPD::LICENSE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( HREF );
+
+###############################################################################
+# PPD Element: IMPLEMENTATION
+###############################################################################
+package PPM::XML::PPD::IMPLEMENTATION;
+@ISA = qw( PPM::XML::ValidatingElement );
+@okids = qw( DEPENDENCY INSTALL LANGUAGE OS OSVERSION PERLCORE PROCESSOR
+ UNINSTALL ARCHITECTURE PROVIDE REQUIRE);
+@rkids = qw( CODEBASE );
+
+###############################################################################
+# PPD Element: OS
+###############################################################################
+package PPM::XML::PPD::OS;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( VALUE );
+sub validate_possible_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_possible_attrs( @_ );
+}
+
+sub validate_required_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_required_attrs( @_ );
+}
+
+sub compatibility_check
+{
+ my $self = shift;
+ if (exists $self->{NAME})
+ {
+ $self->{VALUE} = $self->{NAME};
+ delete $self->{NAME};
+ }
+}
+
+###############################################################################
+# PPD Element: OSVERSION
+###############################################################################
+package PPM::XML::PPD::OSVERSION;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( VALUE );
+sub validate_possible_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_possible_attrs( @_ );
+}
+
+sub validate_required_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_required_attrs( @_ );
+}
+
+sub compatibility_check
+{
+ my $self = shift;
+ if (exists $self->{NAME})
+ {
+ $self->{VALUE} = $self->{NAME};
+ delete $self->{NAME};
+ }
+}
+
+###############################################################################
+# PPD Element: PROCESSOR
+###############################################################################
+package PPM::XML::PPD::PROCESSOR;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( VALUE );
+sub validate_possible_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_possible_attrs( @_ );
+}
+
+sub validate_required_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_required_attrs( @_ );
+}
+
+sub compatibility_check
+{
+ my $self = shift;
+ if (exists $self->{NAME})
+ {
+ $self->{VALUE} = $self->{NAME};
+ delete $self->{NAME};
+ }
+}
+
+###############################################################################
+# PPD Element: ARCHITECTURE
+###############################################################################
+package PPM::XML::PPD::ARCHITECTURE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( VALUE );
+sub validate_possible_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_possible_attrs( @_ );
+}
+
+sub validate_required_attrs
+{
+ my $self = shift;
+ $self->compatibility_check();
+ $self->SUPER::validate_required_attrs( @_ );
+}
+
+sub compatibility_check
+{
+ my $self = shift;
+ if (exists $self->{NAME})
+ {
+ $self->{VALUE} = $self->{NAME};
+ delete $self->{NAME};
+ }
+}
+
+###############################################################################
+# PPD Element: CODEBASE
+###############################################################################
+package PPM::XML::PPD::CODEBASE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( FILENAME );
+@rattrs = qw( HREF );
+
+###############################################################################
+# PPD Element: DEPENDENCY
+###############################################################################
+package PPM::XML::PPD::DEPENDENCY;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( NAME );
+@oattrs = qw( VERSION );
+
+###############################################################################
+# PPD Element: LANGUAGE
+###############################################################################
+package PPM::XML::PPD::LANGUAGE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( VALUE );
+
+###############################################################################
+# PPD Element: PERLCORE
+###############################################################################
+package PPM::XML::PPD::PERLCORE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( VERSION );
+
+###############################################################################
+# PPD Element: INSTALL
+###############################################################################
+package PPM::XML::PPD::INSTALL;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( HREF EXEC );
+
+###############################################################################
+# PPD Element: UNINSTALL
+###############################################################################
+package PPM::XML::PPD::UNINSTALL;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( HREF EXEC );
+
+__END__
+
+###############################################################################
+# POD
+###############################################################################
+
+=head1 NAME
+
+PPM::XML::PPD - PPD file format and XML parsing elements
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+ use PPM::XML::PPD;
+
+ $p = new PPM::XML::Parser( Style => 'Objects', Pkg => 'PPM::XML::PPD' );
+ ...
+
+=head1 DESCRIPTION
+
+This module provides a set of classes for parsing PPD files using the
+C<XML::Parser> module. Each of the classes is derived from
+C<PPM::XML::ValidatingElement>, with optional/required attributes/children
+enforced.
+
+=head1 MAJOR ELEMENTS
+
+=head2 SOFTPKG
+
+Defines a Perl Package. The root of a PPD document is B<always> a SOFTPKG
+element. The SOFTPKG element allows for the following attributes:
+
+=over 4
+
+=item NAME
+
+Required attribute. Name of the package (e.g. "Foobar").
+
+=item VERSION
+
+Version number of the package, in comma-delimited format (e.g. "1,0,0,0").
+
+=back
+
+=head2 IMPLEMENTATION
+
+Child of SOFTPKG, used to describe a particular implementation of the Perl
+Package. Multiple instances are valid, and should be used to describe
+different implementations/ports for different operating systems or
+architectures.
+
+=head2 DEPENDENCY
+
+Child of SOFTPKG or IMPLEMENTATION, used to indicate a dependency this Perl
+Package has on another Perl Package. Multiple instances are valid. The
+DEPENDENCY element allows for the following attributes:
+
+=over 4
+
+=item NAME
+
+Name of the package that this implementation is dependant upon.
+
+=item VERSION
+
+Version number of the dependency, in comma-delimited format (e.g. "1,0,0,0").
+
+=back
+
+=head1 MINOR ELEMENTS
+
+=head2 TITLE
+
+Child of SOFTPKG, used to state the title of the Perl Package. Only one
+instance should be present.
+
+=head2 ABSTRACT
+
+Child of SOFTPKG, used to provide a short description outlining the nature and
+purpose of the Perl Package. Only one instance should be present.
+
+=head2 AUTHOR
+
+Child of SOFTPKG, used to provide information about the author(s) of the Perl
+Package. Multiple instances are valid.
+
+=head2 LANGUAGE
+
+Child of IMPLEMENTATION, used to specify the language used within the given
+implementation of the Perl Package. Only one instance should be present.
+
+=head2 LICENSE
+
+Child of SOFTPKG, indicating the location of the appropriate license agreement
+or copyright notice for the Perl Package. Only one instance should be
+present. The LICENSE element allows for the following attributes:
+
+=over 4
+
+=item HREF
+
+Required attribute. A reference to the location of the license agreement or
+copyright notice for this package.
+
+=back
+
+=head2 OS
+
+Child of IMPLEMENTATION, used to outline the operating system required for this
+implementation of the Perl Package. Multiple instances are valid. Valid
+values can be taken from the OSD Specification and it's OS element. The OS
+element allows for the following attributes:
+
+=over 4
+
+=item VALUE
+
+The name of the operating system required for this implementation of the Perl
+Package. This value should be obtained from Config.pm as 'osname'.
+
+=back
+
+Note that previous versions of the PPD format used a 'NAME' attribute. It's
+use has been deprecated in preference of the 'VALUE' attribute. Also note that
+during validation, this element will automatically convert any existing 'NAME'
+attribute to be a 'VALUE' attribute.
+
+=head2 OSVERSION
+
+Child of IMPLEMENTATION, used to outline the required version of the operating
+system required for this implementation of the Perl Package. Only one instance
+should be present. The OSVERSION element allows for the following attributes:
+
+=over 4
+
+=item VALUE
+
+The version of the operating system required for installation of this
+implementation of the package, in a comma-delimited format (e.g. "3,1,0,0").
+
+=back
+
+Note that previous versions of the PPD format used a 'NAME' attribute. It's
+use has been deprecated in preference of the 'VALUE' attribute. Also note that
+during validation, this element will automatically convert any existing 'NAME'
+attribute to be a 'VALUE' attribute.
+
+=head2 PERLCORE
+
+Child of IMPLEMENTATION, used to specify the minimum version of the Perl core
+distribution that this Perl Package is to be used with. Only one instance
+should be present. The PERLCORE element allows for the following attributes:
+
+=over 4
+
+=item VERSION
+
+Version of the Perl core that is required for this implementation of the Perl
+Package.
+
+=back
+
+=head2 PROCESSOR
+
+Child of IMPLEMENTATION, outlining the cpu required for this implementation
+of the Perl Package. Only one instance should be present. The PROCESSOR
+element allows for the following attributes:
+
+=over 4
+
+=item VALUE
+
+CPU required for the installation of this implementation of the Perl Package.
+The following values are all valid according to the OSD Specification:
+
+ x86 alpha mips sparc 680x0
+
+=back
+
+Note that previous versions of the PPD format used a 'NAME' attribute. It's
+use has been deprecated in preference of the 'VALUE' attribute. Also note that
+during validation, this element will automatically convert any existing 'NAME'
+attribute to be a 'VALUE' attribute.
+
+=head2 CODEBASE
+
+Child of IMPLEMENTATION, indicating a location where an archive of the Perl
+Package can be retrieved. Multiple instances are valid, and can be used to
+indicate multiple possible locations where the same version of the Perl Package
+can be retrieved. The CODEBASE element allows for the following attributes:
+
+=over 4
+
+=item FILENAME
+
+???
+
+=item HREF
+
+Required attribute. A reference to the location of the Perl Package
+distribution.
+
+=back
+
+=head2 INSTALL
+
+Child of IMPLEMENTATION, used to provide either a reference to an
+installation script or a series of commands which can be used to install
+the Perl Package once it has been retrieved. If the EXEC attribute is not
+specified, the value is assumed to be one or more commands, separated by
+`;;'. Each such command will be executed by the Perl `system()' function.
+Only one instance should be present. The INSTALL element allows for
+the following attributes:
+
+=over 4
+
+=item HREF
+
+Reference to an external script which should be retrieved and run as part
+of the installation process. Both filenames and URLs should be considered
+valid.
+
+=item EXEC
+
+Name of interpreter/shell used to execute the installation script.
+If the value of EXEC is `PPM_PERL', the copy of Perl that is executing
+PPM itself ($^X) is used to execute the install script.
+
+=back
+
+=head2 UNINSTALL
+
+Child of IMPLEMENTATION, used to provide either a reference to an
+uninstallation script or a raw Perl script which can be used to uninstall the
+Perl Package at a later point. Only one instance should be present. The
+UNINSTALL element allows for the following attributs:
+
+=over 4
+
+=item HREF
+
+Reference to an external script which should be retrieved and run as part of
+the removal process. Both filenames and URLs should be considered valid.
+
+=item EXEC
+
+Name of interpreter/shell used to execute the uninstallation script.
+If the value of EXEC is `PPM_PERL', the copy of Perl that is executing
+PPM itself ($^X) is used to execute the install script.
+
+=back
+
+=head1 DOCUMENT TYPE DEFINITION
+
+The DTD for PPD documents is available from the ActiveState website and the
+latest version can be found at http://www.ActiveState.com/PPM/DTD/ppd.dtd
+
+This revision of the C<PPM::XML::PPD> module implements the following DTD:
+
+ <!ELEMENT SOFTPKG (ABSTRACT | AUTHOR | IMPLEMENTATION | LICENSE | TITLE)*>
+ <!ATTLIST SOFTPKG NAME CDATA #REQUIRED
+ VERSION CDATA #IMPLIED>
+
+ <!ELEMENT TITLE (#PCDATA)>
+
+ <!ELEMENT ABSTRACT (#PCDATA)>
+
+ <!ELEMENT AUTHOR (#PCDATA)>
+
+ <!ELEMENT LICENSE EMPTY>
+ <!ATTLIST LICENSE HREF CDATA #REQUIRED>
+
+ <!ELEMENT IMPLEMENTATION (CODEBASE | DEPENDENCY | LANGUAGE | OS |
+ OSVERSION | PERLCORE | PROCESSOR | INSTALL |
+ UNINSTALL) *>
+
+ <!ELEMENT CODEBASE EMPTY>
+ <!ATTLIST CODEBASE FILENAME CDATA #IMPLIED
+ HREF CDATA #REQUIRED>
+
+ <!ELEMENT DEPENDENCY EMPTY>
+ <!ATTLIST DEPENDENCY VERSION CDATA #IMPLIED
+ NAME CDATA #REQUIRED>
+
+ <!ELEMENT LANGUAGE EMPTY>
+ <!ATTLIST LANGUAGE VALUE CDATA #REQUIRED>
+
+ <!ELEMENT OS EMPTY>
+ <!ATTLIST OS VALUE CDATA #REQUIRED>
+
+ <!ELEMENT OSVERSION EMPTY>
+ <!ATTLIST OSVERSION VALUE CDATA #REQUIRED>
+
+ <!ELEMENT PERLCORE EMPTY>
+ <!ATTLIST PERLCORE VERSION CDATA #REQUIRED>
+
+ <!ELEMENT PROCESSOR EMPTY>
+ <!ATTLIST PROCESSOR VALUE CDATA #REQUIRED>
+
+ <!ELEMENT INSTALL (#PCDATA)>
+ <!ATTLIST INSTALL HREF CDATA #IMPLIED
+ EXEC CDATA #IMPLIED>
+
+ <!ELEMENT UNINSTALL (#PCDATA)>
+ <!ATTLIST UNINSTALL HREF CDATA #IMPLIED
+ EXEC CDATA #IMPLIED>
+
+=head1 SAMPLE PPD FILE
+
+The following is a sample PPD file describing the C<Math-MatrixBool> module.
+Note that this may B<not> be a current/proper description of this module and is
+for sample purposes only.
+
+ <SOFTPKG NAME="Math-MatrixBool" VERSION="4,2,0,0">
+ <TITLE>Math-MatrixBool</TITLE>
+ <ABSTRACT>Easy manipulation of matrices of booleans (Boolean Algebra)</ABSTRACT>
+ <AUTHOR>Steffen Beyer (sb@sdm.de)</AUTHOR>
+ <LICENSE HREF="http://www.ActiveState.com/packages/Math-MatrixBool/license.html" />
+ <IMPLEMENTATION>
+ <OS VALUE="WinNT" />
+ <OS VALUE="Win95" />
+ <PROCESSOR VALUE="x86" />
+ <CODEBASE HREF="http://www.ActiveState.com/packages/Math-MatrixBool/Math-MatrixBool-4.2-bin-1-Win32.tar.gz" />
+ <DEPENDENCY NAME="Bit-Vector" />
+ <INSTALL>
+ </INSTALL>
+ <UNINSTALL>
+ </UNINSTALL>
+ </IMPLEMENTATION>
+
+ <IMPLEMENTATION>
+ <DEPENDENCY NAME="Bit-Vector" />
+ <CODEBASE HREF="&CPAN;/CPAN/modules/by-module/Math/Math-MatrixBool-4.2.tar.gz" />
+ <INSTALL>
+ system("make"); ;;
+ system("make test"); ;;
+ system("make install"); ;;
+ </INSTALL>
+ </IMPLEMENTATION>
+ </SOFTPKG>
+
+=head1 KNOWN BUGS/ISSUES
+
+Elements which are required to be empty (e.g. LICENSE) are not enforced as
+such.
+
+Notations above about elements for which "only one instance" or "multiple
+instances" are valid are not enforced; this primarily a guideline for
+generating your own PPD files.
+
+=head1 AUTHORS
+
+Graham TerMarsch <grahamt@ActiveState.com>
+
+Murray Nesbitt <murrayn@ActiveState.com>
+
+Dick Hardt <dick_hardt@ActiveState.com>
+
+=head1 HISTORY
+
+v0.1 - Initial release
+
+=head1 SEE ALSO
+
+L<PPM::XML::ValidatingElement>,
+L<PPM::XML::Element>,
+L<XML::Parser>,
+OSD Specification (http://www.microsoft.com/standards/osd/)
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/PPM/XML/PPMConfig.pm b/Master/tlpkg/tlperl.straw/lib/PPM/XML/PPMConfig.pm
new file mode 100755
index 00000000000..66ac7167b61
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PPM/XML/PPMConfig.pm
@@ -0,0 +1,425 @@
+#
+# PPM::XML::PPMConfig
+#
+# Definition of the PPMConfig file format; configuration options for the Perl
+# Package Manager.
+#
+###############################################################################
+
+###############################################################################
+# Import everything from PPM::XML::PPD into our own namespace.
+###############################################################################
+package PPM::XML::PPMConfig;
+use vars qw( $VERSION );
+$VERSION = '0.01_01';
+
+use PPM::XML::PPD ':elements';
+
+###############################################################################
+# PPMConfig Element: Characters
+###############################################################################
+package PPM::XML::PPMConfig::Characters;
+@ISA = qw( PPM::XML::Element );
+
+###############################################################################
+# PPMConfig Element: PPMCONFIG
+###############################################################################
+package PPM::XML::PPMConfig::PPMCONFIG;
+@ISA = qw( PPM::XML::ValidatingElement );
+@okids = qw( PPMVER PLATFORM REPOSITORY OPTIONS PPMPRECIOUS PACKAGE );
+
+###############################################################################
+# PPMConfig Element: PPMVER
+###############################################################################
+package PPM::XML::PPMConfig::PPMVER;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPMConfig Element: PLATFORM
+###############################################################################
+package PPM::XML::PPMConfig::PLATFORM;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( LANGUAGE );
+@rattrs = qw( OSVALUE OSVERSION CPU );
+
+###############################################################################
+# PPMConfig Element: REPOSITORY
+###############################################################################
+package PPM::XML::PPMConfig::REPOSITORY;
+@ISA = qw( PPM::XML::ValidatingElement );
+@oattrs = qw( USERNAME PASSWORD SUMMARYFILE);
+@rattrs = qw( NAME LOCATION );
+
+###############################################################################
+# PPMConfig Element: OPTIONS
+###############################################################################
+package PPM::XML::PPMConfig::OPTIONS;
+@ISA = qw( PPM::XML::ValidatingElement );
+@rattrs = qw( IGNORECASE CLEAN CONFIRM FORCEINSTALL ROOT BUILDDIR MORE );
+@oattrs = qw( TRACE TRACEFILE VERBOSE DOWNLOADSTATUS );
+
+###############################################################################
+# PPMConfig Element: PPMPRECIOUS
+###############################################################################
+package PPM::XML::PPMConfig::PPMPRECIOUS;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPMConfig Element: PACKAGE
+###############################################################################
+package PPM::XML::PPMConfig::PACKAGE;
+@ISA = qw( PPM::XML::ValidatingElement );
+@okids = qw( LOCATION INSTDATE INSTROOT INSTPACKLIST INSTPPD );
+@rattrs = qw( NAME );
+
+###############################################################################
+# PPMConfig Element: LOCATION
+###############################################################################
+package PPM::XML::PPMConfig::LOCATION;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPMConfig Element: INSTDATE
+###############################################################################
+package PPM::XML::PPMConfig::INSTDATE;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPMConfig Element: INSTROOT
+###############################################################################
+package PPM::XML::PPMConfig::INSTROOT;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPMConfig Element: INSTPACKLIST
+###############################################################################
+package PPM::XML::PPMConfig::INSTPACKLIST;
+@ISA = qw( PPM::XML::ValidatingElement );
+
+###############################################################################
+# PPMConfig Element: INSTPPD
+###############################################################################
+package PPM::XML::PPMConfig::INSTPPD;
+@ISA = qw( PPM::XML::ValidatingElement );
+@okids = qw( SOFTPKG ); # Allow for an PPM::XML::PPD::SOFTPKG
+
+__END__
+
+###############################################################################
+# POD
+###############################################################################
+
+=head1 NAME
+
+PPM::XML::PPMConfig - PPMConfig file format and XML parsing elements
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+ use PPM::XML::PPMConfig;
+
+ $p = new PPM::XML::Parser( Style => 'Objects', Pkg => 'PPM::XML::PPMConfig' );
+ ...
+
+=head1 DESCRIPTION
+
+This module provides a set of classes for parsing PPM configuration files
+using the C<XML::Parser> module. All of the elements unique to a PPM
+configuration file are derived from C<PPM::XML::ValidatingElement>.
+There are also several classes rebuilt here which are derived from
+elements in C<PPM::XML::PPD> as we can include a PPD file within our own
+INSTPPD element.
+
+=head1 MAJOR ELEMENTS
+
+=head2 PPMCONFIG
+
+Defines a PPM configuration file. The root of a PPMConfig document is
+B<always> a PPMCONFIG element.
+
+=head2 PACKAGE
+
+Child of PPMCONFIG, used to describe a Perl Package which has already been
+installed. Multiple instances are valid. The PACKAGE element allows for the
+following attributes:
+
+=over 4
+
+=item NAME
+
+Name of the package as given in it's PPD
+
+=back
+
+=head1 MINOR ELEMENTS
+
+
+=head2 PPMVER
+
+Child of PPMCONFIG, used to state the version of PPM for which this
+configuration file is valid. A single instance should be present.
+
+=head2 PLATFORM
+
+Child of PPMCONFIG, used to specify the platform of the target machine. A
+single instance should be present. The PLATFORM element allows for the
+following attributes:
+
+=over 4
+
+=item OSVALUE
+
+Description of the local operating system as defined in the Config.pm file
+under 'osname'.
+
+=item OSVERSION
+
+Version of the local operating system.
+
+=item CPU
+
+Description of the CPU in the local system. The following list of possible
+values was taken from the OSD Specification:
+
+ x86 mips alpha ppc sparc 680x0
+
+=item LANGUAGE
+
+Description of the language used on the local system as specified by the
+language codes in ISO 639.
+
+=back
+
+=head2 REPOSITORY
+
+Child of PPMCONFIG, used to specify a repository where Perl Packages can be
+found. Multiple instances are valid. The REPOSITORY element allows for the
+following attributes:
+
+=over 4
+
+=item NAME
+
+Name by which the repository will be known (e.g. "ActiveState").
+
+=item LOCATION
+
+An URL or directory where the repository can be found.
+
+=item USERNAME
+
+Optional username for a repository requiring authenticated connection.
+
+=item PASSWORD
+
+Optional password for a repository requiring authenticated connection.
+
+=item SUMMARYFILE
+
+Optional package summary filename.
+
+If this file exists on the repository, its contents can be retrieved
+using PPM::RepositorySummary(). The contents are not strictly enforced
+by PPM.pm, however ppm.pl expects this to be a file with the following
+format (for display with the 'summary' command):
+
+Agent [2.91]: supplies agentspace methods for perl5.
+Apache-OutputChain [0.06]: chain stacked Perl handlers
+[etc.]
+
+=back
+
+=head2 OPTIONS
+
+Child of PPMCONFIG, used to specify the current configuration options for PPM.
+A single instance should be present. The OPTIONS element allows for the
+following attributes:
+
+=over 4
+
+=item IGNORECASE
+
+Sets case-sensitive searching. Can be either '1' or '0'.
+
+=item CLEAN
+
+Sets removal of temporarily files. Can be either '1' or '0'.
+
+=item CONFIRM
+
+Sets confirmation of all installs/removals/upgrades. Can be either '1' or
+'0'.
+
+=item BUILDDIR
+
+Directory in which packages will be unpacked before their installation.
+
+=item ROOT
+
+Directory under which packages should be installed on the local system.
+
+=item TRACE
+
+Level of tracing (0 is no tracing, 4 is max tracing).
+
+=item TRACEFILE
+
+File to which trace information will be written.
+
+=item VERBOSE
+
+Controls whether query and search results are verbose (1 == verbose, 0 == no).
+
+=back
+
+=head2 PPMPRECIOUS
+
+Child of PPMCONFIG, used to specify the modules which PPM itself is dependant
+upon. A single instance should be present.
+
+=head2 LOCATION
+
+Child of PACKAGE, used to specify locations at which to search for updated
+versions of the PPD file for this package. Its value can be either a
+directory or an Internet address. A single instance should be present.
+
+=head2 INSTDATE
+
+Child of PACKAGE, used to specify the date on which the Perl Package was
+installed. A single instance should be present.
+
+=head2 INSTROOT
+
+Child of PACKAGE, used to specify the root directory that the Perl Package was
+installed into. A single instance should be present.
+
+=head2 INSTPACKLIST
+
+Child of PACKAGE, used to specify a reference to the packlist for this Perl
+Package; a file containing a list of all of the files which were installed. A
+single instance should be present.
+
+=head2 INSTPPD
+
+Child of PACKAGE, used to hold a copy of the PPD from which Perl Packages
+were installed. Multiple instances are valid.
+
+=head1 DOCUMENT TYPE DEFINITION
+
+The DTD for PPMConfig documents is available from the ActiveState website and
+the latest version can be found at:
+ http://www.ActiveState.com/PPM/DTD/ppmconfig.dtd
+
+This revision of the C<PPM::XML::PPMConfig> module implements the following DTD:
+
+ <!ELEMENT PPMCONFIG (PPMVER | PLATFORM | REPOSITORY | OPTIONS |
+ PPMPRECIOUS | PACKAGE)*>
+
+ <!ELEMENT PPMVER (#PCDATA)>
+
+ <!ELEMENT PLATFORM EMPTY>
+ <!ATTLIST PLATFORM OSVALUE CDATA #REQUIRED
+ OSVERSION CDATA #REQUIRED
+ CPU CDATA #REQUIRED
+ LANGUAGE CDATA #IMPLIED>
+
+ <!ELEMENT REPOSITORY EMPTY>
+ <!ATTLIST REPOSITORY NAME CDATA #REQUIRED
+ LOCATION CDATA #REQUIRED
+ USERNAME CDATA #IMPLIED
+ PASSWORD CDATA #IMPLIED
+ SUMMARYFILE CDATA #IMPLIED>
+
+ <!ELEMENT OPTIONS EMPTY>
+ <!ATTLIST OPTIONS IGNORECASE CDATA #REQUIRED
+ CLEAN CDATA #REQUIRED
+ CONFIRM CDATA #REQUIRED
+ FORCEINSTALL CDATA #REQUIRED
+ ROOT CDATA #REQUIRED
+ BUILDDIR CDATA #REQUIRED
+ MORE CDATA #REQUIRED
+ DOWNLOADSTATUS CDATA #IMPLIED
+ TRACE CDATA #IMPLIED
+ TRACEFILE CDATA #IMPLIED>
+
+ <!ELEMENT PPMPRECIOUS (#PCDATA)>
+
+ <!ELEMENT PACKAGE (LOCATION | INSTDATE | INSTROOT | INSTPACKLIST |
+ INSTPPD)*>
+ <!ATTLIST PACKAGE NAME CDATA #REQUIRED>
+
+ <!ELEMENT LOCATION (#PCDATA)>
+
+ <!ELEMENT INSTDATE (#PCDATA)>
+
+ <!ELEMENT INSTROOT (#PCDATA)>
+
+ <!ELEMENT INSTPACKLIST (#PCDATA)>
+
+ <!ELEMENT INSTPPD (#PCDATA)>
+
+=head1 SAMPLE PPMConfig FILE
+
+The following is a sample PPMConfig file. Note that this may B<not> be a
+current description of this module and is for sample purposes only.
+
+ <PPMCONFIG>
+ <PPMVER>1,0,0,0</PPMVER>
+ <PLATFORM CPU="x86" OSVALUE="MSWin32" OSVERSION="4,0,0,0" />
+ <OPTIONS BUILDDIR="/tmp" CLEAN="1" CONFIRM="1" FORCEINSTALL="1"
+ IGNORECASE="0" MORE="0" ROOT="/usr/local" TRACE="0" TRACEFILE="" DOWNLOADSTATUS="16384" />
+ <REPOSITORY LOCATION="http://www.ActiveState.com/packages"
+ NAME="ActiveState Package Repository" SUMMARYFILE="package.lst" />
+ <PPMPRECIOUS>PPM;libnet;Archive-Tar;Compress-Zlib;libwww-perl</PPMPRECIOUS>
+ <PACKAGE NAME="AtExit">
+ <LOCATION>g:/packages</LOCATION>
+ <INSTPACKLIST>c:/perllib/lib/site/MSWin32-x86/auto/AtExit/.packlist</INSTPACKLIST>
+ <INSTROOT>c:/perllib</INSTROOT>
+ <INSTDATE>Sun Mar 8 02:56:31 1998</INSTDATE>
+ <INSTPPD>
+ <SOFTPKG NAME="AtExit" VERSION="1,02,0,0">
+ <TITLE>AtExit</TITLE>
+ <ABSTRACT>Register a subroutine to be invoked at program -exit time.</ABSTRACT>
+ <AUTHOR>Brad Appleton (Brad_Appleton-GBDA001@email.mot.com)</AUTHOR>
+ <IMPLEMENTATION>
+ <CODEBASE HREF="x86/AtExit.tar.gz" />
+ </IMPLEMENTATION>
+ </SOFTPKG>
+ </INSTPPD>
+ </PACKAGE>
+ </PPMCONFIG>
+
+=head1 KNOWN BUGS/ISSUES
+
+Elements which are required to be empty (e.g. REPOSITORY) are not enforced as
+such.
+
+Notations above about elements for which "only one instance" or "multiple
+instances" are valid are not enforced; this primarily a guideline for
+generating your own PPD files.
+
+Currently, this module creates new classes within it's own namespace for all of
+the PPD elements which can be contained within the INSTPPD element. A suitable
+method for importing the entire PPM::XML::PPD:: namespace should be found
+in order to make this cleaner.
+
+=head1 AUTHORS
+
+Graham TerMarsch <grahamt@ActiveState.com>
+
+Murray Nesbitt <murrayn@ActiveState.com>
+
+Dick Hardt <dick_hardt@ActiveState.com>
+
+=head1 HISTORY
+
+v0.1 - Initial release
+
+=head1 SEE ALSO
+
+L<PPM::XML::ValidatingElement>,
+L<XML::Parser>,
+L<PPM::XML::PPD>
+.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/PPM/XML/RepositorySummary.pm b/Master/tlpkg/tlperl.straw/lib/PPM/XML/RepositorySummary.pm
new file mode 100755
index 00000000000..e2c4f2f4094
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PPM/XML/RepositorySummary.pm
@@ -0,0 +1,31 @@
+#
+# PPM::XML::PPMConfig
+#
+# Definition of the PPMConfig file format; configuration options for the Perl
+# Package Manager.
+#
+###############################################################################
+
+###############################################################################
+# Import everything from PPM::XML::PPD into our own namespace.
+###############################################################################
+package PPM::XML::RepositorySummary;
+use vars qw( $VERSION );
+$VERSION = '0.01_01';
+
+use PPM::XML::PPD ':elements';
+
+###############################################################################
+# RepositorySummary Element: Characters
+###############################################################################
+package PPM::XML::RepositorySummary::Characters;
+@ISA = qw( PPM::XML::Element );
+
+###############################################################################
+# RepositorySummary Element: REPOSITORYSUMMARY
+###############################################################################
+package PPM::XML::RepositorySummary::REPOSITORYSUMMARY;
+@ISA = qw( PPM::XML::ValidatingElement );
+@okids = qw( SOFTPKG );
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/PPM/XML/ValidatingElement.pm b/Master/tlpkg/tlperl.straw/lib/PPM/XML/ValidatingElement.pm
new file mode 100755
index 00000000000..b9808a2d2b2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PPM/XML/ValidatingElement.pm
@@ -0,0 +1,330 @@
+package PPM::XML::ValidatingElement;
+use PPM::XML::Element;
+use vars qw( $VERSION @ISA );
+$VERSION = '0.01_01';
+
+###############################################################################
+#
+# PPM::XML::ValidatingElement
+#
+# Base class for validating elements. Allows for applying DTD type
+# restrictions to elements parsed using the XML::Parser module.
+#
+###############################################################################
+
+###############################################################################
+# Define the validating element class.
+###############################################################################
+@ISA = qw( PPM::XML::Element );
+
+###############################################################################
+# Recursively validate myself and all child elements with all four types of
+# validation. Returns non-zero on success and zero on any errors.
+###############################################################################
+sub rvalidate
+{
+ my $self = shift;
+ my $func = shift;
+ my $success = 1;
+
+ $success &= $self->validate_possible_attrs( $func );
+ $success &= $self->validate_required_attrs( $func );
+ $success &= $self->validate_possible_kids( $func );
+ $success &= $self->validate_required_kids( $func );
+
+ foreach (@{$self->{Kids}})
+ {
+ if ((ref $_) !~ /::Characters$/o)
+ { $success &= $_->rvalidate( $func ); }
+ }
+
+ return $success;
+}
+
+###############################################################################
+# Validate the element with all four types of validation. Returns non-zero on
+# success any zero if any errors occurred.
+###############################################################################
+sub validate
+{
+ my $self = shift;
+ my $func = shift;
+ my $success = 1;
+
+ $success &= $self->validate_possible_attrs( $func );
+ $success &= $self->validate_required_attrs( $func );
+ $success &= $self->validate_possible_kids( $func );
+ $success &= $self->validate_required_kids( $func );
+
+ return $success;
+}
+
+###############################################################################
+# Validate possible attributes. Returns non-zero on sucess, and zero if any
+# errors occurred.
+###############################################################################
+sub validate_possible_attrs
+{
+ my $self = shift;
+ my $func = shift;
+ my $attr;
+ my $type = ref $self;
+ my $success = 1;
+
+ my $elem = $type;
+ $elem =~ s/.*:://;
+
+ my @allattrs;
+ push( @allattrs, @{"$type\::oattrs"}, @{"$type\::rattrs"} );
+
+ # Check our list of attributes against the list of possible attributes we
+ # can have.
+ foreach $attr (keys %{$self})
+ {
+ if ( ($attr ne 'Kids') and ($attr ne 'Text') )
+ {
+ if (!grep( /^$attr$/, @allattrs ))
+ {
+ &$func( "Element '$elem' doesn't allow the '$attr' attribute." );
+ $success = 0;
+ }
+ }
+ }
+
+ return $success;
+}
+
+###############################################################################
+# Validate required attributes. Returns non-zero on success and zero if any
+# errors occurred.
+###############################################################################
+sub validate_required_attrs
+{
+ my $self = shift;
+ my $func = shift;
+ my $attr;
+ my $type = ref $self;
+ my $success = 1;
+
+ my $elem = $type;
+ $elem =~ s/.*:://;
+
+ # Check the list of required attributes against the list of attributes
+ # which were parsed.
+ foreach $attr (@{"$type\::rattrs"})
+ {
+ if (!grep( /^$attr$/, (keys %{$self}) ))
+ {
+ &$func( "Element '$elem' must have a '$attr' attribute." );
+ $success = 0;
+ }
+ }
+
+ return $success;
+}
+
+###############################################################################
+# Validate possible child elements. Returns non-zero on success and zero if
+# any errors occurred.
+###############################################################################
+sub validate_possible_kids
+{
+ my $self = shift;
+ my $func = shift;
+ my $kid;
+ my $type = ref $self;
+ my $success = 1;
+
+ my $elem = $type;
+ $elem =~ s/.*:://;
+
+ my $base = $type;
+ $base =~ s/::[^:]*?$//;
+
+ my @allkids;
+ push( @allkids, @{"$type\::okids"}, @{"$type\::rkids"} );
+
+ foreach $kid (@{ $self->{Kids} })
+ {
+ my $kid_type = ref $kid;
+ $kid_type =~ s/.*:://;
+ next if ($kid_type eq 'Characters'); # Don't validate character data
+
+ if (!grep( /^$kid_type$/, @allkids ))
+ {
+ &$func( "Element '$elem' cannot contain a child element '$kid_type'" );
+ $success = 0;
+ }
+ }
+
+ return $success;
+}
+
+###############################################################################
+# Validate required child elements. Returns non-zero on success and zero if
+# any errors occurred.
+###############################################################################
+sub validate_required_kids
+{
+ my $self = shift;
+ my $func = shift;
+ my $kid;
+ my $type = ref $self;
+ my $success = 1;
+
+ my $elem = $type;
+ $elem =~ s/.*:://;
+
+ my $base = $type;
+ $base =~ s/::[^:]*?$//;
+
+ foreach $kid (@{"$type\::rkids"})
+ {
+ my @kidlist = map( ref, @{$self->{Kids}} );
+
+ if (!grep( /^$base\::$kid$/, @kidlist ))
+ {
+ &$func( "Element '$elem' must contain a '$kid' element." );
+ $success = 0;
+ }
+ }
+
+ return $success;
+}
+
+__END__
+
+###############################################################################
+# POD
+###############################################################################
+
+=head1 NAME
+
+PPM::XML::ValidatingElement - XML Element with DTD-like validation rules
+
+=head1 SYNOPSIS
+
+ use PPM::XML::ValidatingElement;
+
+ package PPM::XML::MyElement;
+ @ISA = qw( PPM::XML::ValidatingElement );
+ @oattrs = qw( BAR ); # Allow for both FOO and BAR attributes
+ @rattrs = qw( FOO );
+ @okids = qw( BLEARGH ); # Allow for both BLEARGH and FOOBAR children
+ @rkids = qw( FOOBAR );
+
+=head1 DESCRIPTION
+
+PPM::XML::ValidatingElement inherits from PPM::XML::Element. It extends
+this class to support methods for validation to allow for DTD-like
+restrictions to be places on documents read in with the XML::Parser module.
+
+=head1 VALIDATION RULES
+
+In order to set up rules for validation of elements, each element should
+define four list values in it's own package namespace. When validating, this
+module will check to ensure that any parsed attributes or child elements are
+actually ones that are possible for this element, as well as checking to see
+that any required attributes/child elements are present.
+
+Note that an attribute/child element only has to be present in either the
+optional or required list; when checking for possible attributes/children,
+these lists will be combined.
+
+Validation lists:
+
+=over 4
+
+=item @oattrs
+
+List of optional attributes.
+
+=item @rattrs
+
+List of required attributes.
+
+=item @opkids
+
+List of optional child elements.
+
+=item @rkids
+
+List of required child elements.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item validate( err_handler )
+
+Validates the current element. This method calls four other methods to
+validate all of requirements for the element. Returns non-zero on success and
+zero if any errors occurred.
+
+=item rvalidate( err_handler )
+
+Validates the current element, and recursively validates all child elements.
+This method calls four other methods to validate all of the requirements for
+the element. Returns non-zero on success and zero if any errors occurred.
+
+=item validate_possible_attrs( err_handler )
+
+Checks against the list of attributes possible for this element (taken from
+@oattr and @rattr) to ensure that all of the parsed attributes are valid. If
+any parsed attributes are not in the list of possible attributes for this
+element, err_handler will be called with a message stating the error. Returns
+non-zero on success and zero if any errors occurred.
+
+=item validate_required_attrs( err_handler )
+
+Checks against the list of required attributes (taken from @rattr) to ensure
+that all of the required attributes are present and have been parsed. If any
+required attributes are missing, err_handler will be called with a message
+stating the error. Returns non-zero on success and zero if any errors
+occurred.
+
+=item validate_possible_kids( err_handler )
+
+Checks against the list of child elements this element can contain (taken from
+@okids and @rkids) to ensure that any child elements that have been read in are
+valid. If any child elements have been parsed which are not in the list of
+possible children, err_handler will be called with a message stating the
+error. Returns non-zero on success and zero if any errors occurred.
+
+=item validate_required_kids( err_handler )
+
+Checks against the lsit of required child elements (taken from @rkids) to
+ensure that all of the required child elements are present and have been
+parsed. If any of the required child elements are missing, err_handler will be
+called with a message stating the error. Returns non-zero on success and zero
+if any errors occurred.
+
+=back
+
+=head1 LIMITATIONS
+
+The PPM::XML::ValidatingElement module only provides checks for determining
+whether or not the possible/required attributes/children are present. This
+module currently has no support for determining whether or not the values
+provided are actually valid (although I imagine it wouldn't be too hard to
+add this in somewhere). This also includes elements which have been declared
+in a DTD as being 'EMPTY' elements.
+
+=head1 AUTHORS
+
+Graham TerMarsch <grahamt@activestate.com>
+
+=head1 HISTORY
+
+v0.2 - Added failure return values to each of the methods.
+
+v0.1 - Initial version
+
+=head1 SEE ALSO
+
+L<PPM::XML::Element>,
+L<XML::Parser>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Package/Constants.pm b/Master/tlpkg/tlperl.straw/lib/Package/Constants.pm
new file mode 100755
index 00000000000..9ad6c62df47
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Package/Constants.pm
@@ -0,0 +1,106 @@
+package Package::Constants;
+
+use strict;
+use vars qw[$VERSION $DEBUG];
+
+$VERSION = '0.02';
+$DEBUG = 0;
+
+=head1 NAME
+
+Package::Constants - List all constants declared in a package
+
+=head1 SYNOPSIS
+
+ use Package::Constants;
+
+ ### list the names of all constants in a given package;
+ @const = Package::Constants->list( __PACKAGE__ );
+ @const = Package::Constants->list( 'main' );
+
+ ### enable debugging output
+ $Package::Constants::DEBUG = 1;
+
+=head1 DESCRIPTION
+
+C<Package::Constants> lists all the constants defined in a certain
+package. This can be useful for, among others, setting up an
+autogenerated C<@EXPORT/@EXPORT_OK> for a Constants.pm file.
+
+=head1 CLASS METHODS
+
+=head2 @const = Package::Constants->list( PACKAGE_NAME );
+
+Lists the names of all the constants defined in the provided package.
+
+=cut
+
+sub list {
+ my $class = shift;
+ my $pkg = shift;
+ return unless defined $pkg; # some joker might use '0' as a pkg...
+
+ _debug("Inspecting package '$pkg'");
+
+ my @rv;
+ { no strict 'refs';
+ my $stash = $pkg . '::';
+
+ for my $name (sort keys %$stash ) {
+
+ _debug( " Checking stash entry '$name'" );
+
+ ### is it a subentry?
+ my $sub = $pkg->can( $name );
+ next unless defined $sub;
+
+ _debug( " '$name' is a coderef" );
+
+ next unless defined prototype($sub) and
+ not length prototype($sub);
+
+ _debug( " '$name' is a constant" );
+ push @rv, $name;
+ }
+ }
+
+ return sort @rv;
+}
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Package::Constants::DEBUG
+
+When set to true, prints out debug information to STDERR about the
+package it is inspecting. Helps to identify issues when the results
+are not as you expect.
+
+Defaults to false.
+
+=cut
+
+sub _debug { warn "@_\n" if $DEBUG; }
+
+1;
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-package-constants@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/Params/Check.pm b/Master/tlpkg/tlperl.straw/lib/Params/Check.pm
new file mode 100755
index 00000000000..7348cbc0d7f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Params/Check.pm
@@ -0,0 +1,712 @@
+package Params::Check;
+
+use strict;
+
+use Carp qw[carp croak];
+use Locale::Maketext::Simple Style => 'gettext';
+
+use Data::Dumper;
+
+BEGIN {
+ use Exporter ();
+ use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
+ $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
+ $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
+ $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
+ ];
+
+ @ISA = qw[ Exporter ];
+ @EXPORT_OK = qw[check allow last_error];
+
+ $VERSION = '0.26';
+ $VERBOSE = $^W ? 1 : 0;
+ $NO_DUPLICATES = 0;
+ $STRIP_LEADING_DASHES = 0;
+ $STRICT_TYPE = 0;
+ $ALLOW_UNKNOWN = 0;
+ $PRESERVE_CASE = 0;
+ $ONLY_ALLOW_DEFINED = 0;
+ $SANITY_CHECK_TEMPLATE = 1;
+ $WARNINGS_FATAL = 0;
+ $CALLER_DEPTH = 0;
+}
+
+my %known_keys = map { $_ => 1 }
+ qw| required allow default strict_type no_override
+ store defined |;
+
+=pod
+
+=head1 NAME
+
+Params::Check - A generic input parsing/checking mechanism.
+
+=head1 SYNOPSIS
+
+ use Params::Check qw[check allow last_error];
+
+ sub fill_personal_info {
+ my %hash = @_;
+ my $x;
+
+ my $tmpl = {
+ firstname => { required => 1, defined => 1 },
+ lastname => { required => 1, store => \$x },
+ gender => { required => 1,
+ allow => [qr/M/i, qr/F/i],
+ },
+ married => { allow => [0,1] },
+ age => { default => 21,
+ allow => qr/^\d+$/,
+ },
+
+ phone => { allow => [ sub { return 1 if /$valid_re/ },
+ '1-800-PERL' ]
+ },
+ id_list => { default => [],
+ strict_type => 1
+ },
+ employer => { default => 'NSA', no_override => 1 },
+ };
+
+ ### check() returns a hashref of parsed args on success ###
+ my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
+ or die qw[Could not parse arguments!];
+
+ ... other code here ...
+ }
+
+ my $ok = allow( $colour, [qw|blue green yellow|] );
+
+ my $error = Params::Check::last_error();
+
+
+=head1 DESCRIPTION
+
+Params::Check is a generic input parsing/checking mechanism.
+
+It allows you to validate input via a template. The only requirement
+is that the arguments must be named.
+
+Params::Check can do the following things for you:
+
+=over 4
+
+=item *
+
+Convert all keys to lowercase
+
+=item *
+
+Check if all required arguments have been provided
+
+=item *
+
+Set arguments that have not been provided to the default
+
+=item *
+
+Weed out arguments that are not supported and warn about them to the
+user
+
+=item *
+
+Validate the arguments given by the user based on strings, regexes,
+lists or even subroutines
+
+=item *
+
+Enforce type integrity if required
+
+=back
+
+Most of Params::Check's power comes from its template, which we'll
+discuss below:
+
+=head1 Template
+
+As you can see in the synopsis, based on your template, the arguments
+provided will be validated.
+
+The template can take a different set of rules per key that is used.
+
+The following rules are available:
+
+=over 4
+
+=item default
+
+This is the default value if none was provided by the user.
+This is also the type C<strict_type> will look at when checking type
+integrity (see below).
+
+=item required
+
+A boolean flag that indicates if this argument was a required
+argument. If marked as required and not provided, check() will fail.
+
+=item strict_type
+
+This does a C<ref()> check on the argument provided. The C<ref> of the
+argument must be the same as the C<ref> of the default value for this
+check to pass.
+
+This is very useful if you insist on taking an array reference as
+argument for example.
+
+=item defined
+
+If this template key is true, enforces that if this key is provided by
+user input, its value is C<defined>. This just means that the user is
+not allowed to pass C<undef> as a value for this key and is equivalent
+to:
+ allow => sub { defined $_[0] && OTHER TESTS }
+
+=item no_override
+
+This allows you to specify C<constants> in your template. ie, they
+keys that are not allowed to be altered by the user. It pretty much
+allows you to keep all your C<configurable> data in one place; the
+C<Params::Check> template.
+
+=item store
+
+This allows you to pass a reference to a scalar, in which the data
+will be stored:
+
+ my $x;
+ my $args = check(foo => { default => 1, store => \$x }, $input);
+
+This is basically shorthand for saying:
+
+ my $args = check( { foo => { default => 1 }, $input );
+ my $x = $args->{foo};
+
+You can alter the global variable $Params::Check::NO_DUPLICATES to
+control whether the C<store>'d key will still be present in your
+result set. See the L<Global Variables> section below.
+
+=item allow
+
+A set of criteria used to validate a particular piece of data if it
+has to adhere to particular rules.
+
+See the C<allow()> function for details.
+
+=back
+
+=head1 Functions
+
+=head2 check( \%tmpl, \%args, [$verbose] );
+
+This function is not exported by default, so you'll have to ask for it
+via:
+
+ use Params::Check qw[check];
+
+or use its fully qualified name instead.
+
+C<check> takes a list of arguments, as follows:
+
+=over 4
+
+=item Template
+
+This is a hashreference which contains a template as explained in the
+C<SYNOPSIS> and C<Template> section.
+
+=item Arguments
+
+This is a reference to a hash of named arguments which need checking.
+
+=item Verbose
+
+A boolean to indicate whether C<check> should be verbose and warn
+about what went wrong in a check or not.
+
+You can enable this program wide by setting the package variable
+C<$Params::Check::VERBOSE> to a true value. For details, see the
+section on C<Global Variables> below.
+
+=back
+
+C<check> will return when it fails, or a hashref with lowercase
+keys of parsed arguments when it succeeds.
+
+So a typical call to check would look like this:
+
+ my $parsed = check( \%template, \%arguments, $VERBOSE )
+ or warn q[Arguments could not be parsed!];
+
+A lot of the behaviour of C<check()> can be altered by setting
+package variables. See the section on C<Global Variables> for details
+on this.
+
+=cut
+
+sub check {
+ my ($utmpl, $href, $verbose) = @_;
+
+ ### did we get the arguments we need? ###
+ return if !$utmpl or !$href;
+
+ ### sensible defaults ###
+ $verbose ||= $VERBOSE || 0;
+
+ ### clear the current error string ###
+ _clear_error();
+
+ ### XXX what type of template is it? ###
+ ### { key => { } } ?
+ #if (ref $args eq 'HASH') {
+ # 1;
+ #}
+
+ ### clean up the template ###
+ my $args = _clean_up_args( $href ) or return;
+
+ ### sanity check + defaults + required keys set? ###
+ my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
+ or return;
+
+ ### deref only once ###
+ my %utmpl = %$utmpl;
+ my %args = %$args;
+ my %defs = %$defs;
+
+ ### flag to see if anything went wrong ###
+ my $wrong;
+
+ ### flag to see if we warned for anything, needed for warnings_fatal
+ my $warned;
+
+ for my $key (keys %args) {
+
+ ### you gave us this key, but it's not in the template ###
+ unless( $utmpl{$key} ) {
+
+ ### but we'll allow it anyway ###
+ if( $ALLOW_UNKNOWN ) {
+ $defs{$key} = $args{$key};
+
+ ### warn about the error ###
+ } else {
+ _store_error(
+ loc("Key '%1' is not a valid key for %2 provided by %3",
+ $key, _who_was_it(), _who_was_it(1)), $verbose);
+ $warned ||= 1;
+ }
+ next;
+ }
+
+ ### check if you're even allowed to override this key ###
+ if( $utmpl{$key}->{'no_override'} ) {
+ _store_error(
+ loc(q[You are not allowed to override key '%1'].
+ q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
+ $verbose
+ );
+ $warned ||= 1;
+ next;
+ }
+
+ ### copy of this keys template instructions, to save derefs ###
+ my %tmpl = %{$utmpl{$key}};
+
+ ### check if you were supposed to provide defined() values ###
+ if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
+ not defined $args{$key}
+ ) {
+ _store_error(loc(q|Key '%1' must be defined when passed|, $key),
+ $verbose );
+ $wrong ||= 1;
+ next;
+ }
+
+ ### check if they should be of a strict type, and if it is ###
+ if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
+ (ref $args{$key} ne ref $tmpl{'default'})
+ ) {
+ _store_error(loc(q|Key '%1' needs to be of type '%2'|,
+ $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
+ $wrong ||= 1;
+ next;
+ }
+
+ ### check if we have an allow handler, to validate against ###
+ ### allow() will report its own errors ###
+ if( exists $tmpl{'allow'} and not do {
+ local $_ERROR_STRING;
+ allow( $args{$key}, $tmpl{'allow'} )
+ }
+ ) {
+ ### stringify the value in the error report -- we don't want dumps
+ ### of objects, but we do want to see *roughly* what we passed
+ _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
+ q|provided by %4|,
+ $key, "$args{$key}", _who_was_it(),
+ _who_was_it(1)), $verbose);
+ $wrong ||= 1;
+ next;
+ }
+
+ ### we got here, then all must be OK ###
+ $defs{$key} = $args{$key};
+
+ }
+
+ ### croak with the collected errors if there were errors and
+ ### we have the fatal flag toggled.
+ croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
+
+ ### done with our loop... if $wrong is set, somethign went wrong
+ ### and the user is already informed, just return...
+ return if $wrong;
+
+ ### check if we need to store any of the keys ###
+ ### can't do it before, because something may go wrong later,
+ ### leaving the user with a few set variables
+ for my $key (keys %defs) {
+ if( my $ref = $utmpl{$key}->{'store'} ) {
+ $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
+ }
+ }
+
+ return \%defs;
+}
+
+=head2 allow( $test_me, \@criteria );
+
+The function that handles the C<allow> key in the template is also
+available for independent use.
+
+The function takes as first argument a key to test against, and
+as second argument any form of criteria that are also allowed by
+the C<allow> key in the template.
+
+You can use the following types of values for allow:
+
+=over 4
+
+=item string
+
+The provided argument MUST be equal to the string for the validation
+to pass.
+
+=item regexp
+
+The provided argument MUST match the regular expression for the
+validation to pass.
+
+=item subroutine
+
+The provided subroutine MUST return true in order for the validation
+to pass and the argument accepted.
+
+(This is particularly useful for more complicated data).
+
+=item array ref
+
+The provided argument MUST equal one of the elements of the array
+ref for the validation to pass. An array ref can hold all the above
+values.
+
+=back
+
+It returns true if the key matched the criteria, or false otherwise.
+
+=cut
+
+sub allow {
+ ### use $_[0] and $_[1] since this is hot code... ###
+ #my ($val, $ref) = @_;
+
+ ### it's a regexp ###
+ if( ref $_[1] eq 'Regexp' ) {
+ local $^W; # silence warnings if $val is undef #
+ return if $_[0] !~ /$_[1]/;
+
+ ### it's a sub ###
+ } elsif ( ref $_[1] eq 'CODE' ) {
+ return unless $_[1]->( $_[0] );
+
+ ### it's an array ###
+ } elsif ( ref $_[1] eq 'ARRAY' ) {
+
+ ### loop over the elements, see if one of them says the
+ ### value is OK
+ ### also, short-cicruit when possible
+ for ( @{$_[1]} ) {
+ return 1 if allow( $_[0], $_ );
+ }
+
+ return;
+
+ ### fall back to a simple, but safe 'eq' ###
+ } else {
+ return unless _safe_eq( $_[0], $_[1] );
+ }
+
+ ### we got here, no failures ###
+ return 1;
+}
+
+### helper functions ###
+
+### clean up the template ###
+sub _clean_up_args {
+ ### don't even bother to loop, if there's nothing to clean up ###
+ return $_[0] if $PRESERVE_CASE and !$STRIP_LEADING_DASHES;
+
+ my %args = %{$_[0]};
+
+ ### keys are note aliased ###
+ for my $key (keys %args) {
+ my $org = $key;
+ $key = lc $key unless $PRESERVE_CASE;
+ $key =~ s/^-// if $STRIP_LEADING_DASHES;
+ $args{$key} = delete $args{$org} if $key ne $org;
+ }
+
+ ### return references so we always return 'true', even on empty
+ ### arguments
+ return \%args;
+}
+
+sub _sanity_check_and_defaults {
+ my %utmpl = %{$_[0]};
+ my %args = %{$_[1]};
+ my $verbose = $_[2];
+
+ my %defs; my $fail;
+ for my $key (keys %utmpl) {
+
+ ### check if required keys are provided
+ ### keys are now lower cased, unless preserve case was enabled
+ ### at which point, the utmpl keys must match, but that's the users
+ ### problem.
+ if( $utmpl{$key}->{'required'} and not exists $args{$key} ) {
+ _store_error(
+ loc(q|Required option '%1' is not provided for %2 by %3|,
+ $key, _who_was_it(1), _who_was_it(2)), $verbose );
+
+ ### mark the error ###
+ $fail++;
+ next;
+ }
+
+ ### next, set the default, make sure the key exists in %defs ###
+ $defs{$key} = $utmpl{$key}->{'default'}
+ if exists $utmpl{$key}->{'default'};
+
+ if( $SANITY_CHECK_TEMPLATE ) {
+ ### last, check if they provided any weird template keys
+ ### -- do this last so we don't always execute this code.
+ ### just a small optimization.
+ map { _store_error(
+ loc(q|Template type '%1' not supported [at key '%2']|,
+ $_, $key), 1, 1 );
+ } grep {
+ not $known_keys{$_}
+ } keys %{$utmpl{$key}};
+
+ ### make sure you passed a ref, otherwise, complain about it!
+ if ( exists $utmpl{$key}->{'store'} ) {
+ _store_error( loc(
+ q|Store variable for '%1' is not a reference!|, $key
+ ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
+ }
+ }
+ }
+
+ ### errors found ###
+ return if $fail;
+
+ ### return references so we always return 'true', even on empty
+ ### defaults
+ return \%defs;
+}
+
+sub _safe_eq {
+ ### only do a straight 'eq' if they're both defined ###
+ return defined($_[0]) && defined($_[1])
+ ? $_[0] eq $_[1]
+ : defined($_[0]) eq defined($_[1]);
+}
+
+sub _who_was_it {
+ my $level = $_[0] || 0;
+
+ return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
+}
+
+=head2 last_error()
+
+Returns a string containing all warnings and errors reported during
+the last time C<check> was called.
+
+This is useful if you want to report then some other way than
+C<carp>'ing when the verbose flag is on.
+
+It is exported upon request.
+
+=cut
+
+{ $_ERROR_STRING = '';
+
+ sub _store_error {
+ my($err, $verbose, $offset) = @_[0..2];
+ $verbose ||= 0;
+ $offset ||= 0;
+ my $level = 1 + $offset;
+
+ local $Carp::CarpLevel = $level;
+
+ carp $err if $verbose;
+
+ $_ERROR_STRING .= $err . "\n";
+ }
+
+ sub _clear_error {
+ $_ERROR_STRING = '';
+ }
+
+ sub last_error { $_ERROR_STRING }
+}
+
+1;
+
+=head1 Global Variables
+
+The behaviour of Params::Check can be altered by changing the
+following global variables:
+
+=head2 $Params::Check::VERBOSE
+
+This controls whether Params::Check will issue warnings and
+explanations as to why certain things may have failed.
+If you set it to 0, Params::Check will not output any warnings.
+
+The default is 1 when L<warnings> are enabled, 0 otherwise;
+
+=head2 $Params::Check::STRICT_TYPE
+
+This works like the C<strict_type> option you can pass to C<check>,
+which will turn on C<strict_type> globally for all calls to C<check>.
+
+The default is 0;
+
+=head2 $Params::Check::ALLOW_UNKNOWN
+
+If you set this flag, unknown options will still be present in the
+return value, rather than filtered out. This is useful if your
+subroutine is only interested in a few arguments, and wants to pass
+the rest on blindly to perhaps another subroutine.
+
+The default is 0;
+
+=head2 $Params::Check::STRIP_LEADING_DASHES
+
+If you set this flag, all keys passed in the following manner:
+
+ function( -key => 'val' );
+
+will have their leading dashes stripped.
+
+=head2 $Params::Check::NO_DUPLICATES
+
+If set to true, all keys in the template that are marked as to be
+stored in a scalar, will also be removed from the result set.
+
+Default is false, meaning that when you use C<store> as a template
+key, C<check> will put it both in the scalar you supplied, as well as
+in the hashref it returns.
+
+=head2 $Params::Check::PRESERVE_CASE
+
+If set to true, L<Params::Check> will no longer convert all keys from
+the user input to lowercase, but instead expect them to be in the
+case the template provided. This is useful when you want to use
+similar keys with different casing in your templates.
+
+Understand that this removes the case-insensitivy feature of this
+module.
+
+Default is 0;
+
+=head2 $Params::Check::ONLY_ALLOW_DEFINED
+
+If set to true, L<Params::Check> will require all values passed to be
+C<defined>. If you wish to enable this on a 'per key' basis, use the
+template option C<defined> instead.
+
+Default is 0;
+
+=head2 $Params::Check::SANITY_CHECK_TEMPLATE
+
+If set to true, L<Params::Check> will sanity check templates, validating
+for errors and unknown keys. Although very useful for debugging, this
+can be somewhat slow in hot-code and large loops.
+
+To disable this check, set this variable to C<false>.
+
+Default is 1;
+
+=head2 $Params::Check::WARNINGS_FATAL
+
+If set to true, L<Params::Check> will C<croak> when an error during
+template validation occurs, rather than return C<false>.
+
+Default is 0;
+
+=head2 $Params::Check::CALLER_DEPTH
+
+This global modifies the argument given to C<caller()> by
+C<Params::Check::check()> and is useful if you have a custom wrapper
+function around C<Params::Check::check()>. The value must be an
+integer, indicating the number of wrapper functions inserted between
+the real function call and C<Params::Check::check()>.
+
+Example wrapper function, using a custom stacktrace:
+
+ sub check {
+ my ($template, $args_in) = @_;
+
+ local $Params::Check::WARNINGS_FATAL = 1;
+ local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
+ my $args_out = Params::Check::check($template, $args_in);
+
+ my_stacktrace(Params::Check::last_error) unless $args_out;
+
+ return $args_out;
+ }
+
+Default is 0;
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Richard Soderberg for his performance improvements.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2003,2004 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/Params/Util.pm b/Master/tlpkg/tlperl.straw/lib/Params/Util.pm
new file mode 100755
index 00000000000..b67e1c0aba3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Params/Util.pm
@@ -0,0 +1,812 @@
+package Params::Util;
+
+=pod
+
+=head1 NAME
+
+Params::Util - Simple, compact and correct param-checking functions
+
+=head1 SYNOPSIS
+
+ # Import some functions
+ use Params::Util qw{_SCALAR _HASH _INSTANCE};
+
+ # If you are lazy, or need a lot of them...
+ use Params::Util ':ALL';
+
+ sub foo {
+ my $object = _INSTANCE(shift, 'Foo') or return undef;
+ my $image = _SCALAR(shift) or return undef;
+ my $options = _HASH(shift) or return undef;
+ # etc...
+ }
+
+=head1 DESCRIPTION
+
+C<Params::Util> provides a basic set of importable functions that makes
+checking parameters a hell of a lot easier
+
+While they can be (and are) used in other contexts, the main point
+behind this module is that the functions B<both> Do What You Mean,
+and Do The Right Thing, so they are most useful when you are getting
+params passed into your code from someone and/or somewhere else
+and you can't really trust the quality.
+
+Thus, C<Params::Util> is of most use at the edges of your API, where
+params and data are coming in from outside your code.
+
+The functions provided by C<Params::Util> check in the most strictly
+correct manner known, are documented as thoroughly as possible so their
+exact behaviour is clear, and heavily tested so make sure they are not
+fooled by weird data and Really Bad Things.
+
+To use, simply load the module providing the functions you want to use
+as arguments (as shown in the SYNOPSIS).
+
+To aid in maintainability, C<Params::Util> will B<never> export by
+default.
+
+You must explicitly name the functions you want to export, or use the
+C<:ALL> param to just have it export everything (although this is not
+recommended if you have any _FOO functions yourself with which future
+additions to C<Params::Util> may clash)
+
+=head1 FUNCTIONS
+
+=cut
+
+use 5.00503;
+use strict;
+require overload;
+require Exporter;
+require Scalar::Util;
+require DynaLoader;
+
+use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS};
+
+$VERSION = '1.00';
+@ISA = qw{
+ Exporter
+ DynaLoader
+};
+@EXPORT_OK = qw{
+ _STRING _IDENTIFIER
+ _CLASS _CLASSISA _SUBCLASS _DRIVER
+ _NUMBER _POSINT _NONNEGINT
+ _SCALAR _SCALAR0
+ _ARRAY _ARRAY0 _ARRAYLIKE
+ _HASH _HASH0 _HASHLIKE
+ _CODE _CODELIKE
+ _INVOCANT _REGEX _INSTANCE
+ _SET _SET0
+ _HANDLE
+};
+%EXPORT_TAGS = ( ALL => \@EXPORT_OK );
+
+eval {
+ local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
+ bootstrap Params::Util $VERSION;
+ 1;
+} unless $ENV{PERL_PARAMS_UTIL_PP};
+
+
+
+
+
+#####################################################################
+# Param Checking Functions
+
+=pod
+
+=head2 _STRING $string
+
+The C<_STRING> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a normal non-false string of non-zero length.
+
+Note that this will NOT do anything magic to deal with the special
+C<'0'> false negative case, but will return it.
+
+ # '0' not considered valid data
+ my $name = _STRING(shift) or die "Bad name";
+
+ # '0' is considered valid data
+ my $string = _STRING($_[0]) ? shift : die "Bad string";
+
+Please also note that this function expects a normal string. It does
+not support overloading or other magic techniques to get a string.
+
+Returns the string as a conveince if it is a valid string, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_STRING;
+sub _STRING ($) {
+ (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _IDENTIFIER $string
+
+The C<_IDENTIFIER> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a valid Perl identifier.
+
+Returns the string as a convenience if it is a valid identifier, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_IDENTIFIER;
+sub _IDENTIFIER ($) {
+ (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*\z/s) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CLASS $string
+
+The C<_CLASS> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a valid Perl class.
+
+This function only checks that the format is valid, not that the
+class is actually loaded. It also assumes "normalised" form, and does
+not accept class names such as C<::Foo> or C<D'Oh>.
+
+Returns the string as a convenience if it is a valid class name, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CLASS;
+sub _CLASS ($) {
+ (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CLASSISA $string, $class
+
+The C<_CLASSISA> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a particularly class, or a subclass of it.
+
+This function checks that the format is valid and calls the -E<gt>isa
+method on the class name. It does not check that the class is actually
+loaded.
+
+It also assumes "normalised" form, and does
+not accept class names such as C<::Foo> or C<D'Oh>.
+
+Returns the string as a convenience if it is a valid class name, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CLASSISA;
+sub _CLASSISA ($$) {
+ (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SUBCLASS $string, $class
+
+The C<_SUBCLASS> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a subclass of a specified class.
+
+This function checks that the format is valid and calls the -E<gt>isa
+method on the class name. It does not check that the class is actually
+loaded.
+
+It also assumes "normalised" form, and does
+not accept class names such as C<::Foo> or C<D'Oh>.
+
+Returns the string as a convenience if it is a valid class name, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SUBCLASS;
+sub _SUBCLASS ($$) {
+ (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _NUMBER $scalar
+
+The C<_NUMBER> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a number. That is, it is defined and perl thinks it's a number.
+
+This function is basically a Params::Util-style wrapper around the
+L<Scalar::Util> C<looks_like_number> function.
+
+Returns the value as a convience, or C<undef> if the value is not a
+number.
+
+=cut
+
+eval <<'END_PERL' unless defined &_NUMBER;
+sub _NUMBER ($) {
+ ( defined $_[0] and ! ref $_[0] and Scalar::Util::looks_like_number($_[0]) )
+ ? $_[0]
+ : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _POSINT $integer
+
+The C<_POSINT> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a positive integer (of any length).
+
+Returns the value as a convience, or C<undef> if the value is not a
+positive integer.
+
+The name itself is derived from the XML schema constraint of the same
+name.
+
+=cut
+
+eval <<'END_PERL' unless defined &_POSINT;
+sub _POSINT ($) {
+ (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[1-9]\d*$/) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _NONNEGINT $integer
+
+The C<_NONNEGINT> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a non-negative integer (of any length). That is, a positive integer,
+or zero.
+
+Returns the value as a convience, or C<undef> if the value is not a
+non-negative integer.
+
+As with other tests that may return false values, care should be taken
+to test via "defined" in boolean validy contexts.
+
+ unless ( defined _NONNEGINT($value) ) {
+ die "Invalid value";
+ }
+
+The name itself is derived from the XML schema constraint of the same
+name.
+
+=cut
+
+eval <<'END_PERL' unless defined &_NONNEGINT;
+sub _NONNEGINT ($) {
+ (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^(?:0|[1-9]\d*)$/) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SCALAR \$scalar
+
+The C<_SCALAR> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<SCALAR> reference, with content of non-zero length.
+
+For a version that allows zero length C<SCALAR> references, see
+the C<_SCALAR0> function.
+
+Returns the C<SCALAR> reference itself as a convenience, or C<undef>
+if the value provided is not a C<SCALAR> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SCALAR;
+sub _SCALAR ($) {
+ (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SCALAR0 \$scalar
+
+The C<_SCALAR0> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<SCALAR0> reference, allowing content of zero-length.
+
+For a simpler "give me some content" version that requires non-zero
+length, C<_SCALAR> function.
+
+Returns the C<SCALAR> reference itself as a convenience, or C<undef>
+if the value provided is not a C<SCALAR> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SCALAR0;
+sub _SCALAR0 ($) {
+ ref $_[0] eq 'SCALAR' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _ARRAY $value
+
+The C<_ARRAY> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<ARRAY> reference containing B<at least> one element of any kind.
+
+For a more basic form that allows zero length ARRAY references, see
+the C<_ARRAY0> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef>
+if the value provided is not an C<ARRAY> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_ARRAY;
+sub _ARRAY ($) {
+ (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _ARRAY0 $value
+
+The C<_ARRAY0> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<ARRAY> reference, allowing C<ARRAY> references that contain no
+elements.
+
+For a more basic "An array of something" form that also requires at
+least one element, see the C<_ARRAY> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef>
+if the value provided is not an C<ARRAY> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_ARRAY0;
+sub _ARRAY0 ($) {
+ ref $_[0] eq 'ARRAY' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _ARRAYLIKE $value
+
+The C<_ARRAYLIKE> function tests whether a given scalar value can respond to
+array dereferencing. If it can, the value is returned. If it cannot,
+C<_ARRAYLIKE> returns C<undef>.
+
+=cut
+
+eval <<'END_PERL' unless defined &_ARRAYLIKE;
+sub _ARRAYLIKE {
+ (defined $_[0] and ref $_[0] and (
+ (Scalar::Util::reftype($_[0]) eq 'ARRAY')
+ or
+ overload::Method($_[0], '@{}')
+ )) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _HASH $value
+
+The C<_HASH> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<HASH> reference with at least one entry.
+
+For a version of this function that allows the C<HASH> to be empty,
+see the C<_HASH0> function.
+
+Returns the C<HASH> reference itself as a convenience, or C<undef>
+if the value provided is not an C<HASH> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_HASH;
+sub _HASH ($) {
+ (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _HASH0 $value
+
+The C<_HASH0> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<HASH> reference, regardless of the C<HASH> content.
+
+For a simpler "A hash of something" version that requires at least one
+element, see the C<_HASH> function.
+
+Returns the C<HASH> reference itself as a convenience, or C<undef>
+if the value provided is not an C<HASH> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_HASH0;
+sub _HASH0 ($) {
+ ref $_[0] eq 'HASH' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _HASHLIKE $value
+
+The C<_HASHLIKE> function tests whether a given scalar value can respond to
+hash dereferencing. If it can, the value is returned. If it cannot,
+C<_HASHLIKE> returns C<undef>.
+
+=cut
+
+eval <<'END_PERL' unless defined &_HASHLIKE;
+sub _HASHLIKE {
+ (defined $_[0] and ref $_[0] and (
+ (Scalar::Util::reftype($_[0]) eq 'HASH')
+ or
+ overload::Method($_[0], '%{}')
+ )) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CODE $value
+
+The C<_CODE> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<CODE> reference.
+
+Returns the C<CODE> reference itself as a convenience, or C<undef>
+if the value provided is not an C<CODE> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CODE;
+sub _CODE ($) {
+ ref $_[0] eq 'CODE' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CODELIKE $value
+
+The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>,
+which checks for an explicit C<CODE> reference, the C<_CODELIKE> function
+also includes things that act like them, such as blessed objects that
+overload C<'&{}'>.
+
+Please note that in the case of objects overloaded with '&{}', you will
+almost always end up also testing it in 'bool' context at some stage.
+
+For example:
+
+ sub foo {
+ my $code1 = _CODELIKE(shift) or die "No code param provided";
+ my $code2 = _CODELIKE(shift);
+ if ( $code2 ) {
+ print "Got optional second code param";
+ }
+ }
+
+As such, you will most likely always want to make sure your class has
+at least the following to allow it to evaluate to true in boolean
+context.
+
+ # Always evaluate to true in boolean context
+ use overload 'bool' => sub () { 1 };
+
+Returns the callable value as a convenience, or C<undef> if the
+value provided is not callable.
+
+Note - This function was formerly known as _CALLABLE but has been renamed
+for greater symmetry with the other _XXXXLIKE functions.
+
+The use of _CALLABLE has been deprecated. It will continue to work, but
+with a warning, until end-2006, then will be removed.
+
+I apologise for any inconvenience caused.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CODELIKE;
+sub _CODELIKE($) {
+ (
+ (Scalar::Util::reftype($_[0])||'') eq 'CODE'
+ or
+ Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}')
+ )
+ ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _INVOCANT $value
+
+This routine tests whether the given value is a valid method invocant.
+This can be either an instance of an object, or a class name.
+
+If so, the value itself is returned. Otherwise, C<_INVOCANT>
+returns C<undef>.
+
+=cut
+
+eval <<'END_PERL' unless defined &_INVOCANT;
+sub _INVOCANT($) {
+ (defined $_[0] and
+ (defined Scalar::Util::blessed($_[0])
+ or
+ # We used to check for stash definedness, but any class-like name is a
+ # valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02
+ Params::Util::_CLASS($_[0]))
+ ) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _INSTANCE $object, $class
+
+The C<_INSTANCE> function is intended to be imported into your package,
+and provides a convenient way to test for an object of a particular class
+in a strictly correct manner.
+
+Returns the object itself as a convenience, or C<undef> if the value
+provided is not an object of that type.
+
+=cut
+
+eval <<'END_PERL' unless defined &_INSTANCE;
+sub _INSTANCE ($$) {
+ (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _REGEX $value
+
+The C<_REGEX> function is intended to be imported into your package,
+and provides a convenient way to test for a regular expression.
+
+Returns the value itself as a convenience, or C<undef> if the value
+provided is not a regular expression.
+
+=cut
+
+eval <<'END_PERL' unless defined &_REGEX;
+sub _REGEX ($) {
+ (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SET \@array, $class
+
+The C<_SET> function is intended to be imported into your package,
+and provides a convenient way to test for set of at least one object of
+a particular class in a strictly correct manner.
+
+The set is provided as a reference to an C<ARRAY> of objects of the
+class provided.
+
+For an alternative function that allows zero-length sets, see the
+C<_SET0> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
+the value provided is not a set of that class.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SET;
+sub _SET ($$) {
+ my $set = shift;
+ _ARRAY($set) or return undef;
+ foreach my $item ( @$set ) {
+ _INSTANCE($item,$_[0]) or return undef;
+ }
+ $set;
+}
+END_PERL
+
+=pod
+
+=head2 _SET0 \@array, $class
+
+The C<_SET0> function is intended to be imported into your package,
+and provides a convenient way to test for a set of objects of a
+particular class in a strictly correct manner, allowing for zero objects.
+
+The set is provided as a reference to an C<ARRAY> of objects of the
+class provided.
+
+For an alternative function that requires at least one object, see the
+C<_SET> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
+the value provided is not a set of that class.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SET0;
+sub _SET0 ($$) {
+ my $set = shift;
+ _ARRAY0($set) or return undef;
+ foreach my $item ( @$set ) {
+ _INSTANCE($item,$_[0]) or return undef;
+ }
+ $set;
+}
+END_PERL
+
+=pod
+
+=head2 _HANDLE
+
+The C<_HANDLE> function is intended to be imported into your package,
+and provides a convenient way to test whether or not a single scalar
+value is a file handle.
+
+Unfortunately, in Perl the definition of a file handle can be a little
+bit fuzzy, so this function is likely to be somewhat imperfect (at first
+anyway).
+
+That said, it is implement as well or better than the other file handle
+detectors in existance (and we stole from the best of them).
+
+=cut
+
+# We're doing this longhand for now. Once everything is perfect,
+# we'll compress this into something that compiles more efficiently.
+# Further, testing file handles is not something that is generally
+# done millions of times, so doing it slowly is not a big speed hit.
+eval <<'END_PERL' unless defined &_HANDLE;
+sub _HANDLE {
+ my $it = shift;
+
+ # It has to be defined, of course
+ unless ( defined $it ) {
+ return undef;
+ }
+
+ # Normal globs are considered to be file handles
+ if ( ref $it eq 'GLOB' ) {
+ return $it;
+ }
+
+ # Check for a normal tied filehandle
+ # Side Note: 5.5.4's tied() and can() doesn't like getting undef
+ if ( tied($it) and tied($it)->can('TIEHANDLE') ) {
+ return $it;
+ }
+
+ # There are no other non-object handles that we support
+ unless ( Scalar::Util::blessed($it) ) {
+ return undef;
+ }
+
+ # Check for a common base classes for conventional IO::Handle object
+ if ( $it->isa('IO::Handle') ) {
+ return $it;
+ }
+
+
+ # Check for tied file handles using Tie::Handle
+ if ( $it->isa('Tie::Handle') ) {
+ return $it;
+ }
+
+ # IO::Scalar is not a proper seekable, but it is valid is a
+ # regular file handle
+ if ( $it->isa('IO::Scalar') ) {
+ return $it;
+ }
+
+ # Yet another special case for IO::String, which refuses (for now
+ # anyway) to become a subclass of IO::Handle.
+ if ( $it->isa('IO::String') ) {
+ return $it;
+ }
+
+ # This is not any sort of object we know about
+ return undef;
+}
+END_PERL
+
+=pod
+
+=head2 _DRIVER $string
+
+ sub foo {
+ my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver";
+ ...
+ }
+
+The C<_DRIVER> function is intended to be imported into your
+package, and provides a convenient way to load and validate
+a driver class.
+
+The most common pattern when taking a driver class as a parameter
+is to check that the name is a class (i.e. check against _CLASS)
+and then to load the class (if it exists) and then ensure that
+the class returns true for the isa method on some base driver name.
+
+Return the value as a convenience, or C<undef> if the value is not
+a class name, the module does not exist, the module does not load,
+or the class fails the isa test.
+
+=cut
+
+eval <<'END_PERL' unless defined &_DRIVER;
+sub _DRIVER ($$) {
+ (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
+}
+END_PERL
+
+1;
+
+=pod
+
+=head1 TO DO
+
+- Add _CAN to help resolve the UNIVERSAL::can debacle
+
+- Would be even nicer if someone would demonstrate how the hell to
+build a Module::Install dist of the ::Util dual Perl/XS type. :/
+
+- Implement an assertion-like version of this module, that dies on
+error.
+
+- Implement a Test:: version of this module, for use in testing
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util>
+
+For other issues, contact the author.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<Params::Validate>
+
+=head1 COPYRIGHT
+
+Copyright 2005 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Parse/Binary.pm b/Master/tlpkg/tlperl.straw/lib/Parse/Binary.pm
new file mode 100755
index 00000000000..3c1c675915f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Parse/Binary.pm
@@ -0,0 +1,960 @@
+package Parse::Binary;
+$Parse::Binary::VERSION = '0.11';
+
+use 5.005;
+use bytes;
+use strict;
+use integer;
+use Parse::Binary::FixedFormat;
+
+=head1 NAME
+
+Parse::Binary - Unpack binary data structures into object hierarchies
+
+=head1 VERSION
+
+This document describes version 0.11 of Parse::Binary, released
+January 25, 2009.
+
+=head1 SYNOPSIS
+
+# This class represents a Win32 F<.ico> file:
+
+ package IconFile;
+ use base 'Parse::Binary';
+ use constant FORMAT => (
+ Magic => 'a2',
+ Type => 'v',
+ Count => 'v',
+ 'Icon' => [ 'a16', '{$Count}', 1 ],
+ Data => 'a*',
+ );
+
+# An individual icon resource:
+
+ package Icon;
+ use base 'Parse::Binary';
+ use constant FORMAT => (
+ Width => 'C',
+ Height => 'C',
+ ColorCount => 'C',
+ Reserved => 'C',
+ Planes => 'v',
+ BitCount => 'v',
+ ImageSize => 'V',
+ ImageOffset => 'v',
+ );
+ sub Data {
+ my ($self) = @_;
+ return $self->parent->substr($self->ImageOffset, $self->ImageSize);
+ }
+
+# Simple F<.ico> file dumper that uses them:
+
+ use IconFile;
+ my $icon_file = IconFile->new('input.ico');
+ foreach my $icon ($icon_file->members) {
+ print "Dimension: ", $icon->Width, "x", $icon->Height, $/;
+ print "Colors: ", 2 ** $icon->BitCount, $/;
+ print "Image Size: ", $icon->ImageSize, " bytes", $/;
+ print "Actual Size: ", length($icon->Data), " bytes", $/, $/;
+ }
+ $icon_file->write('output.ico'); # save as another .ico file
+
+=head1 DESCRIPTION
+
+This module makes parsing binary data structures much easier, by serving
+as a base class for classes that represents the binary data, which may
+contain objects of other classes to represent parts of itself.
+
+Documentation is unfortunately a bit lacking at this moment. Please read
+the tests and source code of L<Parse::AFP> and L<Win32::Exe> for examples
+of using this module.
+
+=cut
+
+use constant PROPERTIES => qw(
+ %struct $filename $size $parent @siblings %children
+ $output $lazy $iterator $iterated
+);
+use constant ENCODED_FIELDS => ( 'Data' );
+use constant FORMAT => ( Data => 'a*' );
+use constant SUBFORMAT => ();
+use constant DEFAULT_ARGS => ();
+use constant DELEGATE_SUBS => ();
+use constant DISPATCH_TABLE => ();
+
+use constant DISPATCH_FIELD => undef;
+use constant BASE_CLASS => undef;
+use constant ENCODING => undef;
+use constant PADDING => undef;
+
+unless (eval { require Scalar::Util; 1 }) {
+ *Scalar::Util::weaken = sub { 1 };
+ *Scalar::Util::blessed = sub { UNIVERSAL::can($_[0], 'can') };
+}
+
+### Constructors ###
+
+sub new {
+ my ($self, $input, $attr) = @_;
+
+ no strict 'refs';
+ my $class = $self->class;
+ $class->init unless ${"$class\::init_done"};
+
+ $attr ||= {};
+ $attr->{filename} ||= $input unless ref $input;
+
+ my $obj = $class->spawn;
+ %$obj = (%$obj, %$attr);
+
+ my $data = $obj->read_data($input);
+ $obj->load($data, $attr);
+
+ if ($obj->{lazy}) {
+ $obj->{lazy} = $obj;
+ }
+ elsif (!$obj->{iterator}) {
+ $obj->make_members;
+ }
+
+ return $obj;
+}
+
+sub dispatch_field {
+ return undef;
+}
+
+use vars qw(%HasMembers %DefaultArgs);
+use vars qw(%Fields %MemberFields %MemberClass %Packer %Parser %FieldPackFormat);
+use vars qw(%DispatchField %DispatchTable);
+
+sub init {
+ no strict 'refs';
+ return if ${"$_[0]\::init_done"};
+
+ my $class = shift;
+
+ *{"$class\::class"} = sub { ref($_[0]) || $_[0] };
+ *{"$class\::is_type"} = \&is_type;
+
+ foreach my $item ($class->PROPERTIES) {
+ no strict 'refs';
+ my ($sigil, $name) = split(//, $item, 2);
+ *{"$class\::$name"} =
+ ($sigil eq '$') ? sub { $_[0]{$name} } :
+ ($sigil eq '@') ? sub { wantarray ? @{$_[0]{$name}||=[]} : ($_[0]{$name}||=[]) } :
+ ($sigil eq '%') ? sub { $_[0]{$name}||={} } :
+ die "Unknown sigil: $sigil";
+ *{"$class\::set_$name"} =
+ ($sigil eq '$') ? sub { $_[0]->{$name} = $_[1] } :
+ ($sigil eq '@') ? sub { @{$_[0]->{$name}||=$_[1]||[]} = @{$_[1]||[]} } :
+ ($sigil eq '%') ? sub { %{$_[0]->{$name}||=$_[1]||{}} = %{$_[1]||{}} } :
+ die "Unknown sigil: $sigil";
+ }
+
+ my @args = $class->default_args;
+ *{"$class\::default_args"} = \@args;
+ *{"$class\::default_args"} = sub { @args };
+ my $delegate_subs = $class->delegate_subs;
+ if (defined(&{"$class\::DELEGATE_SUBS"})) {
+ $delegate_subs = { $class->DELEGATE_SUBS };
+ }
+ *{"$class\::delegate_subs"} = sub { $delegate_subs };
+ while (my ($subclass, $methods) = each %$delegate_subs) {
+ $methods = [ $methods ] unless ref $methods;
+ foreach my $method (grep length, @$methods) {
+ *{"$class\::$method"} = sub {
+ goto &{$_[0]->require_class($subclass)->can($method)};
+ };
+ }
+ }
+ my $dispatch_table = $class->dispatch_table;
+ if (defined(&{"$class\::DISPATCH_TABLE"})) {
+ $dispatch_table = { $class->DISPATCH_TABLE };
+ }
+ $DispatchTable{$class} = $dispatch_table;
+ *{"$class\::dispatch_table"} = sub { $dispatch_table };
+
+ my $dispatch_field = undef;
+ if (defined(&{"$class\::DISPATCH_FIELD"})) {
+ $dispatch_field = $class->DISPATCH_FIELD;
+ }
+ $DispatchField{$class} = $dispatch_field;
+ *{"$class\::dispatch_field"} = sub { $dispatch_field };
+
+ my @format = $class->format_list;
+ if (my @subformat = $class->subformat_list) {
+ my @new_format;
+ while (my ($field, $format) = splice(@format, 0, 2)) {
+ if ($field eq 'Data') {
+ push @new_format, @subformat;
+ }
+ else {
+ push @new_format, ($field => $format);
+ }
+ }
+ @format = @new_format;
+ }
+ my @format_list = @format;
+ *{"$class\::format_list"} = sub { @format_list };
+
+ my (@fields, @formats, @pack_formats, $underscore_count);
+ my (%field_format, %field_pack_format);
+ my (%field_parser, %field_packer, %field_length);
+ my (@member_fields, %member_class);
+ while (my ($field, $format) = splice(@format, 0, 2)) {
+ if ($field eq '_') {
+ # "we don't care" fields
+ $underscore_count++;
+ $field = "_${underscore_count}_$class";
+ $field =~ s/:/_/g;
+ }
+
+ if (ref $format) {
+ $member_class{$field} = $class->classname($field);
+ $field =~ s/:/_/g;
+ $member_class{$field} = $class->classname($field);
+ $class->require($member_class{$field});
+ push @member_fields, $field;
+ }
+ else {
+ $format = [ $format ];
+ }
+
+ push @fields, $field;
+
+ my $string = join(':', $field, @$format);
+ $field_format{$field} = [ @$format ];
+ if (!grep /\{/, @$format) {
+ $field_length{$field} = length(pack($format->[0], 0));
+ $field_parser{$field} = Parse::Binary::FixedFormat->new( [ $string ] );
+ }
+ push @formats, $string;
+
+ s/\s*X\s*//g for @$format;
+ my $pack_string = join(':', $field, @$format);
+ $field_pack_format{$field} = [ @$format ];
+ $field_packer{$field} = Parse::Binary::FixedFormat->new( [ $pack_string ] );
+ push @pack_formats, $pack_string;
+ }
+
+ my $parser = $class->make_formatter(@formats);
+ my $packer = $class->make_formatter(@pack_formats);
+
+ $Packer{$class} = $packer;
+ $Parser{$class} = $parser;
+ $Fields{$class} = \@fields;
+ $HasMembers{$class} = @member_fields ? 1 : 0;
+ $DefaultArgs{$class} = \@args;
+ $MemberClass{$class} = \%member_class;
+ $MemberFields{$class} = \@member_fields;
+ $FieldPackFormat{$class} = { map { ref($_) ? $_->[0] : $_ } %field_pack_format };
+
+ *{"$class\::fields"} = \@fields;
+ *{"$class\::member_fields"} = \@member_fields;
+ *{"$class\::has_members"} = @member_fields ? sub { 1 } : sub { 0 };
+ *{"$class\::fields"} = sub { @fields };
+ *{"$class\::formats"} = sub { @formats };
+ *{"$class\::member_fields"} = sub { @member_fields };
+ *{"$class\::member_class"} = sub { $member_class{$_[1]} };
+ *{"$class\::pack_formats"} = sub { @pack_formats };
+ *{"$class\::field_format"} = sub { $field_format{$_[1]}[0] };
+ *{"$class\::field_pack_format"} = sub { $field_pack_format{$_[1]}[0] };
+ *{"$class\::field_length"} = sub { $field_length{$_[1]} };
+
+ *{"$class\::parser"} = sub { $parser };
+ *{"$class\::packer"} = sub { $packer };
+ *{"$class\::field_parser"} = sub {
+ my ($self, $field) = @_;
+ $field_parser{$field} || do {
+ Parse::Binary::FixedFormat->new( [
+ $self->eval_format(
+ $self->{struct},
+ join(':', $field, @{$field_format{$field}}),
+ ),
+ ] );
+ };
+ };
+
+ *{"$class\::field_packer"} = sub { $field_packer{$_[1]} };
+ *{"$class\::has_field"} = sub { $field_packer{$_[1]} };
+
+ my %enc_fields = map { ($_ => 1) } $class->ENCODED_FIELDS;
+
+ foreach my $field (@fields) {
+ next if defined &{"$class\::$field"};
+
+ if ($enc_fields{$field} and my $encoding = $class->ENCODING) {
+ require Encode;
+
+ *{"$class\::$field"} = sub {
+ my ($self) = @_;
+ return Encode::decode($encoding => $self->{struct}{$field});
+ };
+
+ *{"$class\::Set$field"} = sub {
+ my ($self, $data) = @_;
+ $self->{struct}{$field} = Encode::encode($encoding => $data);
+ };
+ next;
+ }
+
+ *{"$class\::$field"} = sub { $_[0]->{struct}{$field} };
+ *{"$class\::Set$field"} = sub { $_[0]->{struct}{$field} = $_[1] };
+ }
+
+ ${"$class\::init_done"} = 1;
+}
+
+sub initialize {
+ return 1;
+}
+
+### Miscellanous ###
+
+sub field {
+ my ($self, $field) = @_;
+ return $self->{struct}{$field};
+}
+
+sub set_field {
+ my ($self, $field, $data) = @_;
+ $self->{struct}{$field} = $data;
+}
+
+sub classname {
+ my ($self, $class) = @_;
+ return undef unless $class;
+
+ $class =~ s/__/::/g;
+
+ my $base_class = $self->BASE_CLASS or return $class;
+ return $base_class if $class eq '::BASE::';
+
+ return "$base_class\::$class";
+}
+
+sub member_fields {
+ return ();
+}
+
+sub dispatch_class {
+ my ($self, $field) = @_;
+ my $table = $DispatchTable{ref $self};
+ my $class = exists($table->{$field}) ? $table->{$field} : $table->{'*'};
+
+ $class = &$class($self, $field) if UNIVERSAL::isa($class, 'CODE');
+ defined $class or return;
+
+ if (my $members = $self->{parent}{callback_members}) {
+ return unless $members->{$class};
+ }
+ my $subclass = $self->classname($class) or return;
+ return if $subclass eq $class;
+ return $subclass;
+}
+
+sub require {
+ my ($class, $module) = @_;
+ return unless defined $module;
+
+ my $file = "$module.pm";
+ $file =~ s{::}{/}g;
+
+ return $module if (eval { require $file; 1 });
+ die $@ unless $@ =~ /^Can't locate /;
+ return;
+}
+
+sub require_class {
+ my ($class, $subclass) = @_;
+ return $class->require($class->classname($subclass));
+}
+
+sub format_list {
+ my ($self) = @_;
+ return $self->FORMAT;
+}
+
+sub subformat_list {
+ my ($self) = @_;
+ $self->SUBFORMAT ? $self->SUBFORMAT : ();
+}
+
+sub default_args {
+ my ($self) = @_;
+ $self->DEFAULT_ARGS ? $self->DEFAULT_ARGS : ();
+}
+
+sub dispatch_table {
+ my ($self) = @_;
+ $self->DISPATCH_TABLE ? { $self->DISPATCH_TABLE } : {};
+}
+
+sub delegate_subs {
+ my ($self) = @_;
+ $self->DELEGATE_SUBS ? { $self->DELEGATE_SUBS } : {};
+}
+
+sub class {
+ my ($self) = @_;
+ return(ref($self) || $self);
+}
+
+sub make_formatter {
+ my ($self, @formats) = @_;
+ return Parse::Binary::FixedFormat->new( $self->make_format(@formats) );
+}
+
+sub make_format {
+ my ($self, @formats) = @_;
+ return \@formats unless grep /\{/, @formats;
+
+ my @prefix;
+ foreach my $format (@formats) {
+ last if $format =~ /\{/;
+ push @prefix, $format;
+ }
+ return {
+ Chooser => sub { $self->chooser(@_) },
+ Formats => [ \@prefix, \@formats ],
+ };
+}
+
+sub chooser {
+ my ($self, $rec, $obj, $mode) = @_;
+ my $idx = @{$obj->{Layouts}};
+ my @format = $self->eval_format($rec, @{$obj->{Formats}[1]});
+ $obj->{Layouts}[$idx] = $self->make_formatter(@format);
+ return $idx;
+}
+
+sub eval_format {
+ my ($self, $rec, @format) = @_;
+ foreach my $key (sort keys %$rec) {
+ s/\$$key\b/$rec->{$key}/ for @format;
+ }
+ !/\$/ and s/\{(.*?)\}/$1/eeg for @format;
+ die $@ if $@;
+ return @format;
+}
+
+sub padding {
+ return '';
+}
+
+sub load_struct {
+ my ($self, $data) = @_;
+ $self->{struct} = $Parser{ref $self}->unformat($$data . $self->padding, $self->{lazy}, $self);
+}
+
+sub load_size {
+ my ($self, $data) = @_;
+ $self->{size} = length($$data);
+ return 1;
+}
+
+sub lazy_load {
+ my ($self) = @_;
+ ref(my $sub = $self->{lazy}) or return;
+ $self->{lazy} = 1;
+ $self->make_members unless $self->{iterator};
+}
+
+my %DispatchClass;
+sub load {
+ my ($self, $data, $attr) = @_;
+ return $self unless defined $data;
+
+ no strict 'refs';
+ my $class = ref($self) || $self;
+ $class->init unless ${"$class\::init_done"};
+
+ $self->load_struct($data);
+ $self->load_size($data);
+
+ if (my $field = $DispatchField{$class}) {
+ if (
+ my $subclass = $DispatchClass{$class}{ $self->{struct}{$field} }
+ ||= $self->dispatch_class( $self->{struct}{$field})
+ ) {
+ $self->require($subclass);
+ bless($self, $subclass);
+ $self->load($data, $attr);
+ }
+ }
+
+ return $self;
+}
+
+my (%classname, %fill_cache);
+sub spawn {
+ my ($self, %args) = @_;
+ my $class = ref($self) || $self;
+
+ no strict 'refs';
+
+ if (my $subclass = delete($args{Class})) {
+ $class = $classname{$subclass} ||= do {
+ my $name = $self->classname($subclass);
+ $self->require($name);
+ $name->init;
+ $name;
+ };
+ }
+
+ bless({
+ struct => {
+ %args,
+ @{ $DefaultArgs{$class} },
+ %{ $fill_cache{$class} ||= $class->fill_in },
+ },
+ }, $class);
+}
+
+sub fill_in {
+ my $class = shift;
+ my $entries = {};
+
+ foreach my $super_class ($class->superclasses) {
+ my $field = $DispatchField{$super_class} or next;
+ my $table = $DispatchTable{$super_class} or next;
+ foreach my $code (reverse sort keys %$table) {
+ $class->is_type($table->{$code}) or next;
+ $entries->{$field} = $code;
+ last;
+ }
+ }
+
+ return $entries;
+}
+
+sub spawn_sibling {
+ my ($self, %args) = @_;
+ my $parent = $self->{parent} or die "$self has no parent";
+
+ my $obj = $self->spawn(%args);
+ @{$obj}{qw( lazy parent output siblings )} =
+ @{$self}{qw( lazy parent output siblings )};
+ $obj->{size} = length($obj->dump);
+ $obj->refresh_parent;
+ $obj->initialize;
+
+ return $obj;
+}
+
+sub sibling_index {
+ my ($self, $obj) = @_;
+ $obj ||= $self;
+
+ my @siblings = @{$self->{siblings}};
+ foreach my $index (($obj->{index}||0) .. $#siblings) {
+ return $index if $obj == $siblings[$index];
+ }
+
+ return undef;
+}
+
+sub gone {
+ my ($self, $obj) = @_;
+ $self->{parent}{struct}{Data} .= ($obj || $self)->dump;
+}
+
+sub prepend_obj {
+ my ($self, %args) = @_;
+ if ($self->{lazy}) {
+ my $obj = $self->spawn(%args);
+ $self->gone($obj);
+ return;
+ }
+ my $obj = $self->spawn_sibling(%args);
+ my $siblings = $self->{siblings};
+ my $index = $self->{index} ? $self->{index}++ : $self->sibling_index;
+ $obj->{index} = $index;
+
+ splice(@$siblings, $index, 0, $obj);
+ return $obj;
+}
+
+sub append_obj {
+ my ($self, %args) = @_;
+ my $obj = $self->spawn_sibling(%args);
+
+ @{$self->{siblings}} = (
+ map { $_, (($_ == $self) ? $obj : ()) } @{$self->{siblings}}
+ );
+ return $obj;
+}
+
+sub remove {
+ my ($self, %args) = @_;
+ my $siblings = $self->{siblings};
+ splice(@$siblings, $self->sibling_index, 1, undef);
+
+ Scalar::Util::weaken($self->{parent});
+ Scalar::Util::weaken($self);
+}
+
+sub read_data {
+ my ($self, $data) = @_;
+ return undef unless defined $data;
+ return \($data->dump) if UNIVERSAL::can($data, 'dump');
+ return $data if UNIVERSAL::isa($data, 'SCALAR');
+ return \($self->read_file($data));
+}
+
+sub read_file {
+ my ($self, $file) = @_;
+
+ local *FH; local $/;
+ open FH, "< $file" or die "Cannot open $file for reading: $!";
+ binmode(FH);
+
+ return scalar <FH>;
+}
+
+sub make_members {
+ my ($self) = @_;
+
+ $HasMembers{ref $self} or return;
+ %{$self->{children}} = ();
+
+ foreach my $field (@{$MemberFields{ref $self}}) {
+ my ($format) = $self->eval_format(
+ $self->{struct},
+ $FieldPackFormat{ref $self}{$field},
+ );
+
+ my $members = [ map {
+ $self->new_member( $field, \pack($format, @$_) )
+ } $self->validate_memberdata($field) ];
+ $self->set_field_children( $field, $members );
+ }
+}
+
+sub set_members {
+ my ($self, $field, $members) = @_;
+ $field =~ s/:/_/g;
+ $self->set_field_children(
+ $field,
+ [ map { $self->new_member( $field, $_ ) } @$members ],
+ );
+}
+
+sub set_field_children {
+ my ($self, $field, $data) = @_;
+ my $children = $self->field_children($field);
+ @$children = @$data;
+ return $children;
+}
+
+sub field_children {
+ my ($self, $field) = @_;
+ my $children = ($self->{children}{$field} ||= []);
+ # $_->lazy_load for @$children;
+ return(wantarray ? @$children : $children);
+}
+
+sub validate_memberdata {
+ my ($self, $field) = @_;
+ return @{$self->{struct}{$field}||[]};
+}
+
+sub first_member {
+ my ($self, $type) = @_;
+ $self->lazy_load;
+
+ return undef unless $HasMembers{ref $self};
+
+ no strict 'refs';
+ foreach my $field (@{$MemberFields{ref $self}}) {
+ foreach my $member ($self->field_children($field)) {
+ return $member if $member->is_type($type);
+ }
+ }
+ return undef;
+}
+
+sub next_member {
+ my ($self, $type) = @_;
+ return undef unless $HasMembers{ref $self};
+
+ if ($self->{lazy} and !$self->{iterated}) {
+ if (ref($self->{lazy})) {
+ %{$self->{children}} = ();
+ $self->{iterator} = $self->make_next_member;
+ $self->lazy_load;
+ }
+
+ while (my $member = &{$self->{iterator}}) {
+ return $member if $member->is_type($type);
+ }
+ $self->{iterated} = 1;
+ return;
+ }
+
+ $self->{_next_member}{$type} ||= $self->members($type);
+
+ shift(@{$self->{_next_member}{$type}})
+ || undef($self->{_next_member}{$type});
+}
+
+sub make_next_member {
+ my $self = shift;
+ my $class = ref($self);
+ my ($field_idx, $item_idx, $format) = (0, 0, undef);
+ my @fields = @{$MemberFields{$class}};
+ my $struct = $self->{struct};
+ my $formats = $FieldPackFormat{$class};
+
+ sub { LOOP: {
+ my $field = $fields[$field_idx] or return;
+
+ my $items = $struct->{$field};
+ if ($item_idx > $#$items) {
+ $field_idx++;
+ $item_idx = 0;
+ undef $format;
+ redo;
+ }
+
+ $format ||= ($self->eval_format( $struct, $formats->{$field} ))[0];
+
+ my $item = $items->[$item_idx++];
+ $item = $item->($self, $items) if UNIVERSAL::isa($item, 'CODE');
+ $self->valid_memberdata($item) or redo;
+
+ my $member = $self->new_member( $field, \pack($format, @$item) );
+ $member->{index} = (push @{$self->{children}{$field}}, $member) - 1;
+ return $member;
+ } };
+}
+
+sub members {
+ my ($self, $type) = @_;
+ $self->lazy_load;
+
+ no strict 'refs';
+ my @members = map {
+ grep { $type ? $_->is_type($type) : 1 } $self->field_children($_)
+ } @{$MemberFields{ref $self}};
+ wantarray ? @members : \@members;
+}
+
+sub members_recursive {
+ my ($self, $type) = @_;
+ my @members = (
+ ( $self->is_type($type) ? $self : () ),
+ map { $_->members_recursive($type) } $self->members
+ );
+ wantarray ? @members : \@members;
+}
+
+sub new_member {
+ my ($self, $field, $data) = @_;
+ my $obj = $MemberClass{ref $self}{$field}->new(
+ $data, { lazy => $self->{lazy}, parent => $self }
+ );
+
+ $obj->{output} = $self->{output};
+ $obj->{siblings} = $self->{children}{$field}||=[];
+ $obj->initialize;
+
+ return $obj;
+}
+
+sub valid_memberdata {
+ length($_[-1][0])
+}
+
+sub dump_members {
+ my ($self) = @_;
+ return $Packer{ref $self}->format($self->{struct});
+}
+
+sub dump {
+ my ($self) = @_;
+ return $self->dump_members if $HasMembers{ref $self};
+ return $Packer{ref $self}->format($self->{struct});
+}
+
+sub write {
+ my ($self, $file) = @_;
+
+ if (ref($file)) {
+ $$file = $self->dump;
+ }
+ elsif (!defined($file) and my $fh = $self->{output}) {
+ print $fh $self->dump;
+ }
+ else {
+ $file = $self->{filename} unless defined $file;
+ $self->write_file($file, $self->dump) if defined $file;
+ }
+}
+
+sub write_file {
+ my ($self, $file, $data) = @_;
+ local *FH;
+ open FH, "> $file" or die "Cannot open $file for writing: $!";
+ binmode(FH);
+ print FH $data;
+};
+
+sub superclasses {
+ my ($self) = @_;
+ my $class = $self->class;
+
+ no strict 'refs';
+ return @{"$class\::ISA"};
+}
+
+my %type_cache;
+sub is_type {
+ my ($self, $type) = @_;
+ return 1 unless defined $type;
+
+ my $class = ref($self) || $self;
+
+ if (exists $type_cache{$class}{$type}) {
+ return $type_cache{$class}{$type};
+ }
+
+ $type_cache{$class}{$type} = 1;
+
+
+ $type =~ s/__/::/g;
+ $type =~ s/[^\w:]//g;
+ return 1 if ($class =~ /::$type$/);
+
+ no strict 'refs';
+ foreach my $super_class ($class->superclasses) {
+ return 1 if $super_class->is_type($type);
+ };
+
+ $type_cache{$class}{$type} = 0;
+}
+
+sub refresh {
+ my ($self) = @_;
+
+ foreach my $field (@{$MemberFields{ref $self}}) {
+ my $parser = $self->field_parser($field);
+ my $padding = $self->padding;
+
+ local $SIG{__WARN__} = sub {};
+ @{$self->{struct}{$field}} = map {
+ $parser->unformat( $_->dump . $padding, 0, $self)->{$field}[0]
+ } grep defined, @{$self->{children}{$field}||[]};
+
+ $self->validate_memberdata;
+ }
+
+ $self->refresh_parent;
+}
+
+sub refresh_parent {
+ my ($self) = @_;
+ my $parent = $self->{parent} or return;
+ $parent->refresh unless !Scalar::Util::blessed($parent) or $parent->{lazy};
+}
+
+sub first_parent {
+ my ($self, $type) = @_;
+ return $self if $self->is_type($type);
+ my $parent = $self->{parent} or return;
+ return $parent->first_parent($type);
+}
+
+sub substr {
+ my $self = shift;
+ my $data = $self->Data;
+ my $offset = shift(@_) - ($self->{size} - length($data));
+ my $length = @_ ? shift(@_) : (length($data) - $offset);
+ my $replace = shift;
+
+ # XXX - Check for "substr outside string"
+ return if $offset > length($data);
+
+ # Fetch a range
+ return substr($data, $offset, $length) if !defined $replace;
+
+ # Substitute a range
+ substr($data, $offset, $length, $replace);
+ $self->{struct}{Data} = $data;
+}
+
+sub set_output_file {
+ my ($self, $file) = @_;
+
+ open my $fh, '>', $file or die $!;
+ binmode($fh);
+ $self->{output} = $fh;
+}
+
+my %callback_map;
+sub callback {
+ my $self = shift;
+ my $pkg = shift || caller;
+ my $types = shift or return;
+
+ my $map = $callback_map{"@$types"} ||= $self->callback_map($pkg, $types);
+ my $sub = $map->{ref $self} || $map->{'*'} or return;
+ unshift @_, $self;
+ goto &$sub;
+}
+
+sub callback_map {
+ my ($self, $pkg, $types) = @_;
+ my %map;
+ my $base = $self->BASE_CLASS;
+ foreach my $type (map "$_", @$types) {
+ no strict 'refs';
+ my $method = $type;
+ $method =~ s/::/_/g;
+ $method =~ s/\*/__/g;
+
+ defined &{"$pkg\::$method"} or next;
+
+ $type = "$base\::$type" unless $type eq '*';
+ $map{$type} = \&{"$pkg\::$method"};
+ }
+ return \%map;
+}
+
+sub callback_members {
+ my $self = shift;
+ $self->{callback_members} = { map { ($_ => 1) } @{$_[0]} };
+
+ while (my $member = $self->next_member) {
+ $member->callback(scalar caller, @_);
+ }
+}
+
+sub done {
+ my $self = shift;
+ return unless $self->{lazy};
+ $self->write;
+ $self->remove;
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm b/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm
new file mode 100755
index 00000000000..a06715bbd9c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm
@@ -0,0 +1,319 @@
+package Parse::Binary::FixedFormat;
+
+use bytes;
+use strict;
+use integer;
+our $VERSION = '0.05';
+
+sub new {
+ my ($class, $layout) = @_;
+ my $self;
+ if (UNIVERSAL::isa($layout, 'HASH')) {
+ require Parse::Binary::FixedFormat::Variants;
+ $self = Parse::Binary::FixedFormat::Variants->new($layout);
+ } else {
+ $self = { Names=>[], Count=>[], Format=>"" };
+ bless $self, $class;
+ $self->parse_fields($layout) if $layout;
+ }
+ return $self;
+}
+
+sub parse_fields {
+ my ($self,$fmt) = @_;
+ foreach my $fld (@$fmt) {
+ my ($name, $format, $count, $group) = split /\s*:\s*/,$fld;
+ push @{$self->{Names}}, $name;
+ push @{$self->{Count}}, $count;
+ push @{$self->{Group}}, $group;
+ if (defined $count) {
+ push @{$self->{Format}||=[]}, "($format)$count";
+ }
+ else {
+ push @{$self->{Format}||=[]}, $format;
+ }
+ }
+}
+
+my %_format_cache;
+sub _format {
+ my ($self, $lazy) = @_;
+ $self->{_format} ||= do {
+ my $format = join('', @{$self->{Format}});
+ $_format_cache{$format} ||= do {
+ $format =~ s/\((.*?)\)\*$/a*/ if $lazy; # tail iteration
+ $format =~ s/\((.*?)\)(?:(\d+)|(\*))/$1 x ($3 ? 1 : $2)/eg if ($] < 5.008);
+ $format;
+ };
+ };
+}
+
+my %_parent_format;
+sub unformat {
+ my $self = shift;
+ my @flds = shift;
+ my $lazy = shift;
+ my $parent = shift;
+
+ my $format = $self->_format($lazy);
+ @flds = unpack($format, $flds[0]) unless $format eq 'a*';
+
+ my $rec = {};
+ foreach my $i (0 .. $#{$self->{Names}}) {
+ my $name = $self->{Names}[$i];
+ if (defined(my $count = $self->{Count}[$i])) {
+ next unless $count;
+
+ my $group = $self->{Group}[$i];
+ if ($count eq '*') {
+ $count = @flds;
+ $group ||= 1;
+ }
+
+ if ($group) {
+ my $pad = 0;
+ $pad = length($1) if $self->{Format}[$i] =~ /(X+)/;
+
+ if ($lazy and $i == $#{$self->{Names}}) {
+ my $format = $self->{Format}[$i] or die "No format found";
+ $format =~ s/^\((.*?)\)\*$/$1/ or die "Not a count=* field";
+
+ my $record = ($rec->{$name} ||= []);
+ push @$record, $self->lazy_unformat(
+ $parent, $record, $pad, $format, \($flds[0])
+ ) if @flds and length($flds[0]);
+
+ next;
+ }
+
+ my $count_idx = 0;
+ while (my @content = splice(@flds, 0, $group)) {
+ substr($content[-1], -$pad, $pad, '') if $pad;
+ push @{$rec->{$name}}, \@content;
+ $count_idx += $group;
+ last if $count_idx >= $count;
+ }
+ }
+ else {
+ @{$rec->{$name}} = splice @flds, 0, $count;
+ }
+ } else {
+ $rec->{$name} = shift @flds;
+ }
+ }
+ return $rec;
+}
+
+sub lazy_unformat {
+ my ($self, $parent, $record, $pad, $format, $data) = @_;
+
+ # for each request of a member data, we:
+ my $valid_sub = ($parent->can('valid_unformat') ? 1 : 0);
+ return sub { {
+ # grab one chunk of data
+ my @content = unpack($format, $$data);
+ my $length = length(pack($format, @content));
+
+ # eliminate it from the source string
+ my $chunk = substr($$data, 0, $length, '');
+ my $done = (length($$data) <= $pad);
+
+ if ($valid_sub and !$done and !$_[0]->valid_unformat(\@content, \$chunk, $done)) {
+ # weed out invalid data immediately
+ redo;
+ }
+
+ # remove extra padding
+ substr($content[-1], -$pad, $pad, '') if $pad;
+
+ # and prepend (or replace if there are no more data) with it
+ splice(@{$_[1]}, -1, $done, \@content);
+ return \@content;
+ } };
+}
+
+sub format {
+ my ($self,$rec) = @_;
+ my @flds;
+ my $i = 0;
+ foreach my $name (@{$self->{Names}}) {
+ if ($self->{Count}[$i]) {
+ push @flds,map {ref($_) ? @$_ : $_} @{$rec->{$name}};
+ } else {
+ if (ref($rec->{$name}) eq "ARRAY") {
+ if (@{$rec->{$name}}) {
+ push @flds,$rec->{$name};
+ }
+ } else {
+ push @flds,$rec->{$name};
+ }
+ }
+ $i++;
+ }
+ no warnings 'uninitialized';
+ return pack($self->_format, @flds);
+}
+
+sub blank {
+ my $self = shift;
+ my $rec = $self->unformat(pack($self->_format,
+ unpack($self->_format,
+ '')));
+ return $rec;
+}
+
+1;
+
+=head1 NAME
+
+Parse::Binary::FixedFormat - Convert between fixed-length fields and hashes
+
+=head1 SYNOPSIS
+
+ use Parse::Binary::FixedFormat;
+
+ my $tarhdr =
+ new Parse::Binary::FixedFormat [ qw(name:a100 mode:a8 uid:a8 gid:a8 size:a12
+ mtime:a12 chksum:a8 typeflag:a1 linkname:a100
+ magic:a6 version:a2 uname:a32 gname:a32
+ devmajor:a8 devminor:a8 prefix:a155) ];
+ my $buf;
+ read TARFILE, $buf, 512;
+
+ # create a hash from the buffer read from the file
+ my $hdr = $tarhdr->unformat($buf); # $hdr gets a hash ref
+
+ # create a flat record from a hash reference
+ my $buf = $tarhdr->format($hdr); # $hdr is a hash ref
+
+ # create a hash for a new record
+ my $newrec = $tarhdr->blank();
+
+=head1 DESCRIPTION
+
+B<Parse::Binary::FixedFormat> can be used to convert between a buffer with
+fixed-length field definitions and a hash with named entries for each
+field. The perl C<pack> and C<unpack> functions are used to perform
+the conversions. B<Parse::Binary::FixedFormat> builds the format string by
+concatenating the field descriptions and converts between the lists
+used by C<pack> and C<unpack> and a hash that can be reference by
+field name.
+
+=head1 METHODS
+
+B<Parse::Binary::FixedFormat> provides the following methods.
+
+=head2 new
+
+To create a converter, invoke the B<new> method with a reference to a
+list of field specifications.
+
+ my $cvt =
+ new Parse::Binary::FixedFormat [ 'field-name:descriptor:count', ... ];
+
+Field specifications contain the following information.
+
+=over 4
+
+=item field-name
+
+This is the name of the field and will be used as the hash index.
+
+=item descriptor
+
+This describes the content and size of the field. All of the
+descriptors get strung together and passed to B<pack> and B<unpack> as
+part of the template argument. See B<perldoc -f pack> for information
+on what can be specified here.
+
+Don't use repeat counts in the descriptor except for string types
+("a", "A", "h, "H", and "Z"). If you want to get an array out of the
+buffer, use the C<count> argument.
+
+=item count
+
+This specifies a repeat count for the field. If specified as a
+non-zero value, this field's entry in the resultant hash will be an
+array reference instead of a scalar.
+
+=back
+
+=head2 unformat
+
+To convert a buffer of data into a hash, pass the buffer to the
+B<unformat> method.
+
+ $hashref = $cvt->unformat($buf);
+
+Parse::Binary::FixedFormat applies the constructed format to the buffer with
+C<unpack> and maps the returned list of elements to hash entries.
+Fields can now be accessed by name though the hash:
+
+ print $hashref->{field-name};
+ print $hashref->{array-field}[3];
+
+=head2 format
+
+To convert the hash back into a fixed-format buffer, pass the hash
+reference to the B<format> method.
+
+ $buf = $cvt->format($hashref);
+
+=head2 blank
+
+
+To get a hash that can be used to create a new record, call the
+B<blank> method.
+
+ $newrec = $cvt->blank();
+
+=head1 ATTRIBUTES
+
+Each Parse::Binary::FixedFormat instance contains the following attributes.
+
+=over 4
+
+=item Names
+
+Names contains a list of the field names for this variant.
+
+=item Count
+
+Count contains a list of occurrence counts. This is used to indicate
+which fields contain arrays.
+
+=item Format
+
+Format contains the template string for the Perl B<pack> and B<unpack>
+functions.
+
+=back
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+Based on Data::FixedFormat, written by Thomas Pfau <pfau@nbpfaus.net>
+http://nbpfaus.net/~pfau/.
+
+=head1 COPYRIGHT
+
+Copyright 2004-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+Copyright (C) 2000,2002 Thomas Pfau. All rights reserved.
+
+This module is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2 of the License, or (at your
+option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat/Variants.pm b/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat/Variants.pm
new file mode 100755
index 00000000000..66ca74fa11e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat/Variants.pm
@@ -0,0 +1,149 @@
+package Parse::Binary::FixedFormat::Variants;
+
+use strict;
+our $VERSION = "0.03";
+
+sub new {
+ my ($class,$recfmt) = @_;
+ my $self;
+ $self = { Layouts=>[], Chooser=>$recfmt->{Chooser}, Formats => $recfmt->{Formats} };
+ bless $self, $class;
+ foreach my $fmt (@{$recfmt->{Formats}}) {
+ push @{$self->{Layouts}},new Parse::Binary::FixedFormat $fmt;
+ }
+ return $self;
+}
+
+sub unformat {
+ my ($self,$frec) = @_;
+ my $rec = $self->{Layouts}[0]->unformat($frec);
+ if ($self->{Chooser}) {
+ my $w = &{$self->{Chooser}}($rec, $self, 'unformat');
+ $rec = $self->{Layouts}[$w]->unformat($frec) if $w;
+ }
+ return $rec;
+}
+
+sub format {
+ my ($self,$rec) = @_;
+ my $w = 0;
+ if ($self->{Chooser}) {
+ $w = &{$self->{Chooser}}($rec, $self, 'format');
+ }
+ my $frec = $self->{Layouts}[$w]->format($rec);
+ return $frec;
+}
+
+sub blank {
+ my ($self,$w) = @_;
+ $w = 0 unless $w;
+ my $rec = $self->{Layouts}[$w]->blank();
+ return $rec;
+}
+
+1;
+
+=head1 NAME
+
+Parse::Binary::FixedFormat::Variants - Convert between variant records and hashes
+
+=head1 DESCRIPTION
+
+B<Parse::Binary::FixedFormat> supports variant record formats. To describe a
+variant structure, pass a hash reference containing the following
+elements to B<new>. The object returned to handle variant records
+will be a B<Parse::Binary::FixedFormat::Variants>.
+
+=over 4
+
+=item Chooser
+
+When converting a buffer to a hash, this subroutine is invoked after
+applying the first format to the buffer. The generated hash reference
+is passed to this routine. Any field names specified in the first
+format are available to be used in making a decision on which format
+to use to decipher the buffer. This routine should return the index
+of the proper format specification.
+
+When converting a hash to a buffer, this subroutine is invoked first
+to choose a packing format. Since the same function is used for both
+conversions, this function should restrict itself to field names that
+exist in format 0 and those fields should exist in the same place in
+all formats.
+
+=item Formats
+
+This is a reference to a list of formats. Each format contains a list
+of field specifications.
+
+=back
+
+For example:
+
+ my $cvt = new Parse::Binary::FixedFormat {
+ Chooser => sub { my $rec=shift;
+ $rec->{RecordType} eq '0' ? 1 : 2
+ },
+ Formats => [ [ 'RecordType:A1' ],
+ [ 'RecordType:A1', 'FieldA:A6', 'FieldB:A4:4' ],
+ [ 'RecordType:A1', 'FieldC:A4', 'FieldD:A18' ] ]
+ };
+ my $rec0 = $cvt->unformat("0FieldAB[0]B[1]B[2]B[3]");
+ my $rec1 = $cvt->unformat("1FldC<-----FieldD----->");
+
+In the above example, the C<Chooser> function looks at the contents of
+the C<RecordType> field. If it contains a '0', format 1 is used.
+Otherwise, format 2 is used.
+
+B<Parse::Binary::FixedFormat::Variants> can be used is if it were a
+B<Parse::Binary::FixedFormat>. The C<format> and C<unformat> methods will
+determine which variant to use automatically. The C<blank> method
+requires an argument that specifies the variant number.
+
+=head1 ATTRIBUTES
+
+Each Parse::Binary::FixedFormat::Variants instance contains the following
+attributes.
+
+=over 4
+
+=item Layouts
+
+Contains an array of Parse::Binary::FixedFormat objects. Each of these objects
+is responsible for converting a single record format variant.
+
+=item Chooser
+
+This attribute contains the function that chooses which variant to
+apply to the record.
+
+=back
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+Based on Data::FixedFormat::Variants, written by Thomas Pfau <pfau@nbpfaus.net>
+http://nbpfaus.net/~pfau/.
+
+=head1 COPYRIGHT
+
+Copyright 2004-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+Copyright (C) 2000,2002 Thomas Pfau. All rights reserved.
+
+This module is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2 of the License, or (at your
+option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Parse/CPAN/Meta.pm b/Master/tlpkg/tlperl.straw/lib/Parse/CPAN/Meta.pm
new file mode 100755
index 00000000000..e7d585170b1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Parse/CPAN/Meta.pm
@@ -0,0 +1,437 @@
+package Parse::CPAN::Meta;
+
+use strict;
+use Carp 'croak';
+
+# UTF Support?
+sub HAVE_UTF8 () { $] >= 5.007003 }
+BEGIN {
+ if ( HAVE_UTF8 ) {
+ # The string eval helps hide this from Test::MinimumVersion
+ eval "require utf8;";
+ die "Failed to load UTF-8 support" if $@;
+ }
+
+ # Class structure
+ require 5.004;
+ require Exporter;
+ $Parse::CPAN::Meta::VERSION = '1.40';
+ @Parse::CPAN::Meta::ISA = qw{ Exporter };
+ @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
+}
+
+# Prototypes
+sub LoadFile ($);
+sub Load ($);
+sub _scalar ($$$);
+sub _array ($$$);
+sub _hash ($$$);
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+
+
+
+
+#####################################################################
+# Implementation
+
+# Create an object from a file
+sub LoadFile ($) {
+ # Check the file
+ my $file = shift;
+ croak('You did not specify a file name') unless $file;
+ croak( "File '$file' does not exist" ) unless -e $file;
+ croak( "'$file' is a directory, not a file" ) unless -f _;
+ croak( "Insufficient permissions to read '$file'" ) unless -r _;
+
+ # Slurp in the file
+ local $/ = undef;
+ local *CFG;
+ unless ( open( CFG, $file ) ) {
+ croak("Failed to open file '$file': $!");
+ }
+ my $yaml = <CFG>;
+ unless ( close(CFG) ) {
+ croak("Failed to close file '$file': $!");
+ }
+
+ # Hand off to the actual parser
+ Load( $yaml );
+}
+
+# Parse a document from a string.
+# Doing checks on $_[0] prevents us having to do a string copy.
+sub Load ($) {
+ my $string = $_[0];
+ unless ( defined $string ) {
+ croak("Did not provide a string to load");
+ }
+
+ # Byte order marks
+ if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
+ croak("Stream has a non UTF-8 Unicode Byte Order Mark");
+ } else {
+ # Strip UTF-8 bom if found, we'll just ignore it
+ $string =~ s/^\357\273\277//;
+ }
+
+ # Try to decode as utf8
+ utf8::decode($string) if HAVE_UTF8;
+
+ # Check for some special cases
+ return () unless length $string;
+ unless ( $string =~ /[\012\015]+\z/ ) {
+ croak("Stream does not end with newline character");
+ }
+
+ # Split the file into lines
+ my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
+ split /(?:\015{1,2}\012|\015|\012)/, $string;
+
+ # Strip the initial YAML header
+ @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
+
+ # A nibbling parser
+ my @documents = ();
+ while ( @lines ) {
+ # Do we have a document header?
+ if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
+ # Handle scalar documents
+ shift @lines;
+ if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
+ push @documents, _scalar( "$1", [ undef ], \@lines );
+ next;
+ }
+ }
+
+ if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
+ # A naked document
+ push @documents, undef;
+ while ( @lines and $lines[0] !~ /^---/ ) {
+ shift @lines;
+ }
+
+ } elsif ( $lines[0] =~ /^\s*\-/ ) {
+ # An array at the root
+ my $document = [ ];
+ push @documents, $document;
+ _array( $document, [ 0 ], \@lines );
+
+ } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
+ # A hash at the root
+ my $document = { };
+ push @documents, $document;
+ _hash( $document, [ length($1) ], \@lines );
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines[0]'");
+ }
+ }
+
+ if ( wantarray ) {
+ return @documents;
+ } else {
+ return $documents[-1];
+ }
+}
+
+# Deparse a scalar string to the actual scalar
+sub _scalar ($$$) {
+ my ($string, $indent, $lines) = @_;
+
+ # Trim trailing whitespace
+ $string =~ s/\s*\z//;
+
+ # Explitic null/undef
+ return undef if $string eq '~';
+
+ # Quotes
+ if ( $string =~ /^\'(.*?)\'\z/ ) {
+ return '' unless defined $1;
+ $string = $1;
+ $string =~ s/\'\'/\'/g;
+ return $string;
+ }
+ if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
+ # Reusing the variable is a little ugly,
+ # but avoids a new variable and a string copy.
+ $string = $1;
+ $string =~ s/\\"/"/g;
+ $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
+ return $string;
+ }
+
+ # Special cases
+ if ( $string =~ /^[\'\"!&]/ ) {
+ croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
+ }
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ # Regular unquoted string
+ return $string unless $string =~ /^[>|]/;
+
+ # Error
+ croak("Parse::CPAN::Meta failed to find multi-line scalar content") unless @$lines;
+
+ # Check the indent depth
+ $lines->[0] =~ /^(\s*)/;
+ $indent->[-1] = length("$1");
+ if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ # Pull the lines
+ my @multiline = ();
+ while ( @$lines ) {
+ $lines->[0] =~ /^(\s*)/;
+ last unless length($1) >= $indent->[-1];
+ push @multiline, substr(shift(@$lines), length($1));
+ }
+
+ my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
+ my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
+ return join( $j, @multiline ) . $t;
+}
+
+# Parse an array
+sub _array ($$$) {
+ my ($array, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
+ # Inline nested hash
+ my $indent2 = length("$1");
+ $lines->[0] =~ s/-/ /;
+ push @$array, { };
+ _hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, _scalar( "$2", [ @$indent, undef ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
+ shift @$lines;
+ unless ( @$lines ) {
+ push @$array, undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)\-/ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] == $indent2 ) {
+ # Null array entry
+ push @$array, undef;
+ } else {
+ # Naked indenter
+ push @$array, [ ];
+ _array( $array->[-1], [ @$indent, $indent2 ], $lines );
+ }
+
+ } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
+ push @$array, { };
+ _hash( $array->[-1], [ @$indent, length("$1") ], $lines );
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+
+ } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
+ # This is probably a structure like the following...
+ # ---
+ # foo:
+ # - list
+ # bar: value
+ #
+ # ... so lets return and let the hash parser handle it
+ return 1;
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+ }
+
+ return 1;
+}
+
+# Parse an array
+sub _hash ($$$) {
+ my ($hash, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ # Get the key
+ unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
+ if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
+ croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
+ }
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+ my $key = $1;
+
+ # Do we have a value?
+ if ( length $lines->[0] ) {
+ # Yes
+ $hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines );
+ } else {
+ # An indent
+ shift @$lines;
+ unless ( @$lines ) {
+ $hash->{$key} = undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)-/ ) {
+ $hash->{$key} = [];
+ _array( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ } elsif ( $lines->[0] =~ /^(\s*)./ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] >= $indent2 ) {
+ # Null hash entry
+ $hash->{$key} = undef;
+ } else {
+ $hash->{$key} = {};
+ _hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ }
+ }
+ }
+ }
+
+ return 1;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Parse::CPAN::Meta - Parse META.yml and other similar CPAN metadata files
+
+=head1 SYNOPSIS
+
+ #############################################
+ # In your file
+
+ ---
+ rootproperty: blah
+ section:
+ one: two
+ three: four
+ Foo: Bar
+ empty: ~
+
+
+
+ #############################################
+ # In your program
+
+ use Parse::CPAN::Meta;
+
+ # Create a YAML file
+ my @yaml = Parse::CPAN::Meta::LoadFile( 'Meta.yml' );
+
+ # Reading properties
+ my $root = $yaml[0]->{rootproperty};
+ my $one = $yaml[0]->{section}->{one};
+ my $Foo = $yaml[0]->{section}->{Foo};
+
+=head1 DESCRIPTION
+
+B<Parse::CPAN::Meta> is a parser for F<META.yml> files, based on the
+parser half of L<YAML::Tiny>.
+
+It supports a basic subset of the full YAML specification, enough to
+implement parsing of typical F<META.yml> files, and other similarly simple
+YAML files.
+
+If you need something with more power, move up to a full YAML parser such
+as L<YAML>, L<YAML::Syck> or L<YAML::LibYAML>.
+
+B<Parse::CPAN::Meta> provides a very simply API of only two functions,
+based on the YAML functions of the same name. Wherever possible,
+identical calling semantics are used.
+
+All error reporting is done with exceptions (die'ing).
+
+=head1 FUNCTIONS
+
+For maintenance clarity, no functions are exported.
+
+=head2 Load
+
+ my @yaml = Load( $string );
+
+Parses a string containing a valid YAML stream into a list of Perl data
+structures.
+
+=head2 LoadFile
+
+ my @yaml = LoadFile( 'META.yml' );
+
+Reads the YAML stream from a file instead of a string.
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Parse-CPAN-Meta>
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>, L<http://ali.as/>
+
+=head1 COPYRIGHT
+
+Copyright 2006 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/PerlIO.pm b/Master/tlpkg/tlperl.straw/lib/PerlIO.pm
new file mode 100755
index 00000000000..f4a01974b65
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/PerlIO/encoding.pm b/Master/tlpkg/tlperl.straw/lib/PerlIO/encoding.pm
new file mode 100755
index 00000000000..f50c9c7b6f6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PerlIO/encoding.pm
@@ -0,0 +1,53 @@
+package PerlIO::encoding;
+
+use strict;
+our $VERSION = '0.11';
+our $DEBUG = 0;
+$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
+
+#
+# Equivalent of this is done in encoding.xs - do not uncomment.
+#
+# use Encode ();
+
+use XSLoader ();
+XSLoader::load(__PACKAGE__, $VERSION);
+
+our $fallback =
+ Encode::PERLQQ()|Encode::WARN_ON_ERR()|Encode::STOP_AT_PARTIAL();
+
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::encoding - encoding layer
+
+=head1 SYNOPSIS
+
+ use PerlIO::encoding;
+
+ open($f, "<:encoding(foo)", "infoo");
+ open($f, ">:encoding(bar)", "outbar");
+
+ use Encode qw(:fallbacks);
+ $PerlIO::encoding::fallback = FB_PERLQQ;
+
+=head1 DESCRIPTION
+
+This PerlIO layer opens a filehandle with a transparent encoding filter.
+
+On input, it converts the bytes expected to be in the specified
+character set and encoding to Perl string data (Unicode and
+Perl's internal Unicode encoding, UTF-8). On output, it converts
+Perl string data into the specified character set and encoding.
+
+When the layer is pushed, the current value of C<$PerlIO::encoding::fallback>
+is saved and used as the CHECK argument when calling the Encode methods
+encode() and decode().
+
+=head1 SEE ALSO
+
+L<open>, L<Encode>, L<perlfunc/binmode>, L<perluniintro>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/PerlIO/scalar.pm b/Master/tlpkg/tlperl.straw/lib/PerlIO/scalar.pm
new file mode 100755
index 00000000000..5188ddbc3c9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PerlIO/scalar.pm
@@ -0,0 +1,41 @@
+package PerlIO::scalar;
+our $VERSION = '0.07';
+use XSLoader ();
+XSLoader::load 'PerlIO::scalar';
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::scalar - in-memory IO, scalar IO
+
+=head1 SYNOPSIS
+
+ my $scalar = '';
+ ...
+ open my $fh, "<", \$scalar or die;
+ open my $fh, ">", \$scalar or die;
+ open my $fh, ">>", \$scalar or die;
+
+or
+
+ my $scalar = '';
+ ...
+ open my $fh, "<:scalar", \$scalar or die;
+ open my $fh, ">:scalar", \$scalar or die;
+ open my $fh, ">>:scalar", \$scalar or die;
+
+=head1 DESCRIPTION
+
+A filehandle is opened but the file operations are performed "in-memory"
+on a scalar variable. All the normal file operations can be performed
+on the handle. The scalar is considered a stream of bytes. Currently
+fileno($fh) returns -1.
+
+=head1 IMPLEMENTATION NOTE
+
+C<PerlIO::scalar> only exists to use XSLoader to load C code that
+provides support for treating a scalar as an "in memory" file.
+One does not need to explicitly C<use PerlIO::scalar>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/PerlIO/via.pm b/Master/tlpkg/tlperl.straw/lib/PerlIO/via.pm
new file mode 100755
index 00000000000..66aa974043e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PerlIO/via.pm
@@ -0,0 +1,243 @@
+package PerlIO::via;
+our $VERSION = '0.07';
+use XSLoader ();
+XSLoader::load 'PerlIO::via';
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::via - Helper class for PerlIO layers implemented in perl
+
+=head1 SYNOPSIS
+
+ use PerlIO::via::Layer;
+ open($fh,"<:via(Layer)",...);
+
+ use Some::Other::Package;
+ open($fh,">:via(Some::Other::Package)",...);
+
+=head1 DESCRIPTION
+
+The PerlIO::via module allows you to develop PerlIO layers in Perl, without
+having to go into the nitty gritty of programming C with XS as the interface
+to Perl.
+
+One example module, L<PerlIO::via::QuotedPrint>, is included with Perl
+5.8.0, and more example modules are available from CPAN, such as
+L<PerlIO::via::StripHTML> and L<PerlIO::via::Base64>. The
+PerlIO::via::StripHTML module for instance, allows you to say:
+
+ use PerlIO::via::StripHTML;
+ open( my $fh, "<:via(StripHTML)", "index.html" );
+ my @line = <$fh>;
+
+to obtain the text of an HTML-file in an array with all the HTML-tags
+automagically removed.
+
+Please note that if the layer is created in the PerlIO::via:: namespace, it
+does B<not> have to be fully qualified. The PerlIO::via module will prefix
+the PerlIO::via:: namespace if the specified modulename does not exist as a
+fully qualified module name.
+
+=head1 EXPECTED METHODS
+
+To create a Perl module that implements a PerlIO layer in Perl (as opposed to
+in C using XS as the interface to Perl), you need to supply some of the
+following subroutines. It is recommended to create these Perl modules in the
+PerlIO::via:: namespace, so that they can easily be located on CPAN and use
+the default namespace feature of the PerlIO::via module itself.
+
+Please note that this is an area of recent development in Perl and that the
+interface described here is therefore still subject to change (and hopefully
+will have better documentation and more examples).
+
+In the method descriptions below I<$fh> will be
+a reference to a glob which can be treated as a perl file handle.
+It refers to the layer below. I<$fh> is not passed if the layer
+is at the bottom of the stack, for this reason and to maintain
+some level of "compatibility" with TIEHANDLE classes it is passed last.
+
+=over 4
+
+=item $class->PUSHED([$mode,[$fh]])
+
+Should return an object or the class, or -1 on failure. (Compare
+TIEHANDLE.) The arguments are an optional mode string ("r", "w",
+"w+", ...) and a filehandle for the PerlIO layer below. Mandatory.
+
+When the layer is pushed as part of an C<open> call, C<PUSHED> will be called
+I<before> the actual open occurs, whether that be via C<OPEN>, C<SYSOPEN>,
+C<FDOPEN> or by letting a lower layer do the open.
+
+=item $obj->POPPED([$fh])
+
+Optional - called when the layer is about to be removed.
+
+=item $obj->UTF8($bellowFlag,[$fh])
+
+Optional - if present it will be called immediately after PUSHED has
+returned. It should return a true value if the layer expects data to be
+UTF-8 encoded. If it returns true, the result is as if the caller had done
+
+ ":via(YourClass):utf8"
+
+If not present or if it returns false, then the stream is left with
+the UTF-8 flag clear.
+The I<$bellowFlag> argument will be true if there is a layer below
+and that layer was expecting UTF-8.
+
+=item $obj->OPEN($path,$mode,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called for normal opens after the layer is pushed.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->BINMODE([$fh])
+
+Optional - if not present the layer is popped on binmode($fh) or when C<:raw>
+is pushed. If present it should return 0 on success, -1 on error, or undef
+to pop the layer.
+
+=item $obj->FDOPEN($fd,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called after the layer is pushed for opens which pass
+a numeric file descriptor.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->SYSOPEN($path,$imode,$perm,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called after the layer is pushed for sysopen style opens
+which pass a numeric mode and permissions.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->FILENO($fh)
+
+Returns a numeric value for a Unix-like file descriptor. Returns -1 if
+there isn't one. Optional. Default is fileno($fh).
+
+=item $obj->READ($buffer,$len,$fh)
+
+Returns the number of octets placed in $buffer (must be less than or
+equal to $len). Optional. Default is to use FILL instead.
+
+=item $obj->WRITE($buffer,$fh)
+
+Returns the number of octets from $buffer that have been successfully written.
+
+=item $obj->FILL($fh)
+
+Should return a string to be placed in the buffer. Optional. If not
+provided, must provide READ or reject handles open for reading in
+PUSHED.
+
+=item $obj->CLOSE($fh)
+
+Should return 0 on success, -1 on error.
+Optional.
+
+=item $obj->SEEK($posn,$whence,$fh)
+
+Should return 0 on success, -1 on error.
+Optional. Default is to fail, but that is likely to be changed
+in future.
+
+=item $obj->TELL($fh)
+
+Returns file position.
+Optional. Default to be determined.
+
+=item $obj->UNREAD($buffer,$fh)
+
+Returns the number of octets from $buffer that have been successfully
+saved to be returned on future FILL/READ calls. Optional. Default is
+to push data into a temporary layer above this one.
+
+=item $obj->FLUSH($fh)
+
+Flush any buffered write data. May possibly be called on readable
+handles too. Should return 0 on success, -1 on error.
+
+=item $obj->SETLINEBUF($fh)
+
+Optional. No return.
+
+=item $obj->CLEARERR($fh)
+
+Optional. No return.
+
+=item $obj->ERROR($fh)
+
+Optional. Returns error state. Default is no error until a mechanism
+to signal error (die?) is worked out.
+
+=item $obj->EOF($fh)
+
+Optional. Returns end-of-file state. Default is a function of the return
+value of FILL or READ.
+
+=back
+
+=head1 EXAMPLES
+
+Check the PerlIO::via:: namespace on CPAN for examples of PerlIO layers
+implemented in Perl. To give you an idea how simple the implementation of
+a PerlIO layer can look, a simple example is included here.
+
+=head2 Example - a Hexadecimal Handle
+
+Given the following module, PerlIO::via::Hex :
+
+ package PerlIO::via::Hex;
+
+ sub PUSHED
+ {
+ my ($class,$mode,$fh) = @_;
+ # When writing we buffer the data
+ my $buf = '';
+ return bless \$buf,$class;
+ }
+
+ sub FILL
+ {
+ my ($obj,$fh) = @_;
+ my $line = <$fh>;
+ return (defined $line) ? pack("H*", $line) : undef;
+ }
+
+ sub WRITE
+ {
+ my ($obj,$buf,$fh) = @_;
+ $$obj .= unpack("H*", $buf);
+ return length($buf);
+ }
+
+ sub FLUSH
+ {
+ my ($obj,$fh) = @_;
+ print $fh $$obj or return -1;
+ $$obj = '';
+ return 0;
+ }
+
+ 1;
+
+The following code opens up an output handle that will convert any
+output to a hexadecimal dump of the output bytes: for example "A" will
+be converted to "41" (on ASCII-based machines, on EBCDIC platforms
+the "A" will become "c1")
+
+ use PerlIO::via::Hex;
+ open(my $fh, ">:via(Hex)", "foo.hex");
+
+and the following code will read the hexdump in and convert it
+on the fly back into bytes:
+
+ open(my $fh, "<:via(Hex)", "foo.hex");
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/PerlIO/via/QuotedPrint.pm b/Master/tlpkg/tlperl.straw/lib/PerlIO/via/QuotedPrint.pm
new file mode 100755
index 00000000000..2434191f091
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/PerlIO/via/QuotedPrint.pm
@@ -0,0 +1,94 @@
+package PerlIO::via::QuotedPrint;
+
+# Set the version info
+# Make sure we do things by the book from now on
+
+$VERSION = '0.06';
+use strict;
+
+# Make sure the encoding/decoding stuff is available
+
+use MIME::QuotedPrint (); # no need to pollute this namespace
+
+# Satisfy -require-
+
+1;
+
+#-----------------------------------------------------------------------
+# IN: 1 class to bless with
+# 2 mode string (ignored)
+# 3 file handle of PerlIO layer below (ignored)
+# OUT: 1 blessed object
+
+sub PUSHED { bless \*PUSHED,$_[0] } #PUSHED
+
+#-----------------------------------------------------------------------
+# IN: 1 instantiated object (ignored)
+# 2 handle to read from
+# OUT: 1 decoded string
+
+sub FILL {
+
+# Read the line from the handle
+# Decode if there is something decode and return result or signal eof
+
+ my $line = readline( $_[1] );
+ (defined $line) ? MIME::QuotedPrint::decode_qp( $line ) : undef;
+} #FILL
+
+#-----------------------------------------------------------------------
+# IN: 1 instantiated object (ignored)
+# 2 buffer to be written
+# 3 handle to write to
+# OUT: 1 number of bytes written
+
+sub WRITE {
+
+# Encode whatever needs to be encoded and write to handle: indicate result
+
+ (print {$_[2]} MIME::QuotedPrint::encode_qp($_[1])) ? length($_[1]) : -1;
+} #WRITE
+
+__END__
+
+=head1 NAME
+
+PerlIO::via::QuotedPrint - PerlIO layer for quoted-printable strings
+
+=head1 SYNOPSIS
+
+ use PerlIO::via::QuotedPrint;
+
+ open( my $in,'<:via(QuotedPrint)','file.qp' )
+ or die "Can't open file.qp for reading: $!\n";
+
+ open( my $out,'>:via(QuotedPrint)','file.qp' )
+ or die "Can't open file.qp for writing: $!\n";
+
+=head1 DESCRIPTION
+
+This module implements a PerlIO layer that works on files encoded in the
+quoted-printable format. It will decode from quoted-printable while reading
+from a handle, and it will encode as quoted-printable while writing to a handle.
+
+=head1 REQUIRED MODULES
+
+ MIME::QuotedPrint (any)
+
+=head1 SEE ALSO
+
+L<PerlIO::via>, L<MIME::QuotedPrint>, L<PerlIO::via::Base64>,
+L<PerlIO::via::MD5>, L<PerlIO::via::StripHTML>, L<PerlIO::via::Rotate>.
+
+=head1 ACKNOWLEDGEMENTS
+
+Based on example that was initially added to MIME::QuotedPrint.pm for the
+5.8.0 distribution of Perl.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2003 Elizabeth Mattijsen. All rights reserved. This
+library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Checker.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Checker.pm
new file mode 100755
index 00000000000..a2305423b23
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Checker.pm
@@ -0,0 +1,1268 @@
+#############################################################################
+# Pod/Checker.pm -- check pod documents for syntax errors
+#
+# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Checker;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES);
+$VERSION = '1.45'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+use Pod::ParseUtils; ## for hyperlinks and lists
+
+=head1 NAME
+
+Pod::Checker, podchecker() - check pod documents for syntax errors
+
+=head1 SYNOPSIS
+
+ use Pod::Checker;
+
+ $syntax_okay = podchecker($filepath, $outputpath, %options);
+
+ my $checker = new Pod::Checker %options;
+ $checker->parse_from_file($filepath, \*STDERR);
+
+=head1 OPTIONS/ARGUMENTS
+
+C<$filepath> is the input POD to read and C<$outputpath> is
+where to write POD syntax error messages. Either argument may be a scalar
+indicating a file-path, or else a reference to an open filehandle.
+If unspecified, the input-file it defaults to C<\*STDIN>, and
+the output-file defaults to C<\*STDERR>.
+
+=head2 podchecker()
+
+This function can take a hash of options:
+
+=over 4
+
+=item B<-warnings> =E<gt> I<val>
+
+Turn warnings on/off. I<val> is usually 1 for on, but higher values
+trigger additional warnings. See L<"Warnings">.
+
+=back
+
+=head1 DESCRIPTION
+
+B<podchecker> will perform syntax checking of Perl5 POD format documentation.
+
+Curious/ambitious users are welcome to propose additional features they wish
+to see in B<Pod::Checker> and B<podchecker> and verify that the checks are
+consistent with L<perlpod>.
+
+The following checks are currently performed:
+
+=over 4
+
+=item *
+
+Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
+and unterminated interior sequences.
+
+=item *
+
+Check for proper balancing of C<=begin> and C<=end>. The contents of such
+a block are generally ignored, i.e. no syntax checks are performed.
+
+=item *
+
+Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.
+
+=item *
+
+Check for same nested interior-sequences (e.g.
+C<LE<lt>...LE<lt>...E<gt>...E<gt>>).
+
+=item *
+
+Check for malformed or non-existing entities C<EE<lt>...E<gt>>.
+
+=item *
+
+Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
+for details.
+
+=item *
+
+Check for unresolved document-internal links. This check may also reveal
+misspelled links that seem to be internal links but should be links
+to something else.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=head2 Errors
+
+=over 4
+
+=item * empty =headn
+
+A heading (C<=head1> or C<=head2>) without any text? That ain't no
+heading!
+
+=item * =over on line I<N> without closing =back
+
+The C<=over> command does not have a corresponding C<=back> before the
+next heading (C<=head1> or C<=head2>) or the end of the file.
+
+=item * =item without previous =over
+
+=item * =back without previous =over
+
+An C<=item> or C<=back> command has been found outside a
+C<=over>/C<=back> block.
+
+=item * No argument for =begin
+
+A C<=begin> command was found that is not followed by the formatter
+specification.
+
+=item * =end without =begin
+
+A standalone C<=end> command was found.
+
+=item * Nested =begin's
+
+There were at least two consecutive C<=begin> commands without
+the corresponding C<=end>. Only one C<=begin> may be active at
+a time.
+
+=item * =for without formatter specification
+
+There is no specification of the formatter after the C<=for> command.
+
+=item * unresolved internal link I<NAME>
+
+The given link to I<NAME> does not have a matching node in the current
+POD. This also happened when a single word node name is not enclosed in
+C<"">.
+
+=item * Unknown command "I<CMD>"
+
+An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
+C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
+C<=for>, C<=pod>, C<=cut>
+
+=item * Unknown interior-sequence "I<SEQ>"
+
+An invalid markup command has been encountered. Valid are:
+C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,
+C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,
+C<ZE<lt>E<gt>>
+
+=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
+
+Two nested identical markup commands have been found. Generally this
+does not make sense.
+
+=item * garbled entity I<STRING>
+
+The I<STRING> found cannot be interpreted as a character entity.
+
+=item * Entity number out of range
+
+An entity specified by number (dec, hex, oct) is out of range (1-255).
+
+=item * malformed link LE<lt>E<gt>
+
+The link found cannot be parsed because it does not conform to the
+syntax described in L<perlpod>.
+
+=item * nonempty ZE<lt>E<gt>
+
+The C<ZE<lt>E<gt>> sequence is supposed to be empty.
+
+=item * empty XE<lt>E<gt>
+
+The index entry specified contains nothing but whitespace.
+
+=item * Spurious text after =pod / =cut
+
+The commands C<=pod> and C<=cut> do not take any arguments.
+
+=item * Spurious character(s) after =back
+
+The C<=back> command does not take any arguments.
+
+=back
+
+=head2 Warnings
+
+These may not necessarily cause trouble, but indicate mediocre style.
+
+=over 4
+
+=item * multiple occurrence of link target I<name>
+
+The POD file has some C<=item> and/or C<=head> commands that have
+the same text. Potential hyperlinks to such a text cannot be unique then.
+This warning is printed only with warning level greater than one.
+
+=item * line containing nothing but whitespace in paragraph
+
+There is some whitespace on a seemingly empty line. POD is very sensitive
+to such things, so this is flagged. B<vi> users switch on the B<list>
+option to avoid this problem.
+
+=begin _disabled_
+
+=item * file does not start with =head
+
+The file starts with a different POD directive than head.
+This is most probably something you do not want.
+
+=end _disabled_
+
+=item * previous =item has no contents
+
+There is a list C<=item> right above the flagged line that has no
+text contents. You probably want to delete empty items.
+
+=item * preceding non-item paragraph(s)
+
+A list introduced by C<=over> starts with a text or verbatim paragraph,
+but continues with C<=item>s. Move the non-item paragraph out of the
+C<=over>/C<=back> block.
+
+=item * =item type mismatch (I<one> vs. I<two>)
+
+A list started with e.g. a bullet-like C<=item> and continued with a
+numbered one. This is obviously inconsistent. For most translators the
+type of the I<first> C<=item> determines the type of the list.
+
+=item * I<N> unescaped C<E<lt>E<gt>> in paragraph
+
+Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>>
+can potentially cause errors as they could be misinterpreted as
+markup commands. This is only printed when the -warnings level is
+greater than 1.
+
+=item * Unknown entity
+
+A character entity was found that does not belong to the standard
+ISO set or the POD specials C<verbar> and C<sol>.
+
+=item * No items in =over
+
+The list opened with C<=over> does not contain any items.
+
+=item * No argument for =item
+
+C<=item> without any parameters is deprecated. It should either be followed
+by C<*> to indicate an unordered list, by a number (optionally followed
+by a dot) to indicate an ordered (numbered) list or simple text for a
+definition list.
+
+=item * empty section in previous paragraph
+
+The previous section (introduced by a C<=head> command) does not contain
+any text. This usually indicates that something is missing. Note: A
+C<=head1> followed immediately by C<=head2> does not trigger this warning.
+
+=item * Verbatim paragraph in NAME section
+
+The NAME section (C<=head1 NAME>) should consist of a single paragraph
+with the script/module name, followed by a dash `-' and a very short
+description of what the thing is good for.
+
+=item * =headI<n> without preceding higher level
+
+For example if there is a C<=head2> in the POD file prior to a
+C<=head1>.
+
+=back
+
+=head2 Hyperlinks
+
+There are some warnings with respect to malformed hyperlinks:
+
+=over 4
+
+=item * ignoring leading/trailing whitespace in link
+
+There is whitespace at the beginning or the end of the contents of
+LE<lt>...E<gt>.
+
+=item * (section) in '$page' deprecated
+
+There is a section detected in the page name of LE<lt>...E<gt>, e.g.
+C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only.
+Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able
+to expand this to appropriate code. For links to (builtin) functions,
+please say C<LE<lt>perlfunc/mkdirE<gt>>, without ().
+
+=item * alternative text/node '%s' contains non-escaped | or /
+
+The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
+Although the hyperlink parser does its best to determine which "/" is
+text and which is a delimiter in case of doubt, one ought to escape
+these literal characters like this:
+
+ / E<sol>
+ | E<verbar>
+
+=back
+
+=head1 RETURN VALUE
+
+B<podchecker> returns the number of POD syntax errors found or -1 if
+there were no POD commands at all found in the file.
+
+=head1 EXAMPLES
+
+See L</SYNOPSIS>
+
+=head1 INTERFACE
+
+While checking, this module collects document properties, e.g. the nodes
+for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
+POD translators can use this feature to syntax-check and get the nodes in
+a first pass before actually starting to convert. This is expensive in terms
+of execution time, but allows for very robust conversions.
+
+Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror>
+method to print errors and warnings. The summary output (e.g.
+"Pod syntax OK") has been dropped from the module and has been included in
+B<podchecker> (the script). This allows users of B<Pod::Checker> to
+control completely the output behavior. Users of B<podchecker> (the script)
+get the well-known behavior.
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Carp qw(croak);
+use Exporter;
+use Pod::Parser;
+
+@ISA = qw(Pod::Parser);
+@EXPORT = qw(&podchecker);
+
+my %VALID_COMMANDS = (
+ 'pod' => 1,
+ 'cut' => 1,
+ 'head1' => 1,
+ 'head2' => 1,
+ 'head3' => 1,
+ 'head4' => 1,
+ 'over' => 1,
+ 'back' => 1,
+ 'item' => 1,
+ 'for' => 1,
+ 'begin' => 1,
+ 'end' => 1,
+ 'encoding' => 1,
+);
+
+my %VALID_SEQUENCES = (
+ 'I' => 1,
+ 'B' => 1,
+ 'S' => 1,
+ 'C' => 1,
+ 'L' => 1,
+ 'F' => 1,
+ 'X' => 1,
+ 'Z' => 1,
+ 'E' => 1,
+);
+
+# stolen from HTML::Entities
+my %ENTITIES = (
+ # Some normal chars that have special meaning in SGML context
+ amp => '&', # ampersand
+'gt' => '>', # greater than
+'lt' => '<', # less than
+ quot => '"', # double quote
+
+ # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML
+ AElig => 'Æ', # capital AE diphthong (ligature)
+ Aacute => 'Á', # capital A, acute accent
+ Acirc => 'Â', # capital A, circumflex accent
+ Agrave => 'À', # capital A, grave accent
+ Aring => 'Å', # capital A, ring
+ Atilde => 'Ã', # capital A, tilde
+ Auml => 'Ä', # capital A, dieresis or umlaut mark
+ Ccedil => 'Ç', # capital C, cedilla
+ ETH => 'Ð', # capital Eth, Icelandic
+ Eacute => 'É', # capital E, acute accent
+ Ecirc => 'Ê', # capital E, circumflex accent
+ Egrave => 'È', # capital E, grave accent
+ Euml => 'Ë', # capital E, dieresis or umlaut mark
+ Iacute => 'Í', # capital I, acute accent
+ Icirc => 'Î', # capital I, circumflex accent
+ Igrave => 'Ì', # capital I, grave accent
+ Iuml => 'Ï', # capital I, dieresis or umlaut mark
+ Ntilde => 'Ñ', # capital N, tilde
+ Oacute => 'Ó', # capital O, acute accent
+ Ocirc => 'Ô', # capital O, circumflex accent
+ Ograve => 'Ò', # capital O, grave accent
+ Oslash => 'Ø', # capital O, slash
+ Otilde => 'Õ', # capital O, tilde
+ Ouml => 'Ö', # capital O, dieresis or umlaut mark
+ THORN => 'Þ', # capital THORN, Icelandic
+ Uacute => 'Ú', # capital U, acute accent
+ Ucirc => 'Û', # capital U, circumflex accent
+ Ugrave => 'Ù', # capital U, grave accent
+ Uuml => 'Ü', # capital U, dieresis or umlaut mark
+ Yacute => 'Ý', # capital Y, acute accent
+ aacute => 'á', # small a, acute accent
+ acirc => 'â', # small a, circumflex accent
+ aelig => 'æ', # small ae diphthong (ligature)
+ agrave => 'à', # small a, grave accent
+ aring => 'å', # small a, ring
+ atilde => 'ã', # small a, tilde
+ auml => 'ä', # small a, dieresis or umlaut mark
+ ccedil => 'ç', # small c, cedilla
+ eacute => 'é', # small e, acute accent
+ ecirc => 'ê', # small e, circumflex accent
+ egrave => 'è', # small e, grave accent
+ eth => 'ð', # small eth, Icelandic
+ euml => 'ë', # small e, dieresis or umlaut mark
+ iacute => 'í', # small i, acute accent
+ icirc => 'î', # small i, circumflex accent
+ igrave => 'ì', # small i, grave accent
+ iuml => 'ï', # small i, dieresis or umlaut mark
+ ntilde => 'ñ', # small n, tilde
+ oacute => 'ó', # small o, acute accent
+ ocirc => 'ô', # small o, circumflex accent
+ ograve => 'ò', # small o, grave accent
+ oslash => 'ø', # small o, slash
+ otilde => 'õ', # small o, tilde
+ ouml => 'ö', # small o, dieresis or umlaut mark
+ szlig => 'ß', # small sharp s, German (sz ligature)
+ thorn => 'þ', # small thorn, Icelandic
+ uacute => 'ú', # small u, acute accent
+ ucirc => 'û', # small u, circumflex accent
+ ugrave => 'ù', # small u, grave accent
+ uuml => 'ü', # small u, dieresis or umlaut mark
+ yacute => 'ý', # small y, acute accent
+ yuml => 'ÿ', # small y, dieresis or umlaut mark
+
+ # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)
+ copy => '©', # copyright sign
+ reg => '®', # registered sign
+ nbsp => "\240", # non breaking space
+
+ # Additional ISO-8859/1 entities listed in rfc1866 (section 14)
+ iexcl => '¡',
+ cent => '¢',
+ pound => '£',
+ curren => '¤',
+ yen => '¥',
+ brvbar => '¦',
+ sect => '§',
+ uml => '¨',
+ ordf => 'ª',
+ laquo => '«',
+'not' => '¬', # not is a keyword in perl
+ shy => '­',
+ macr => '¯',
+ deg => '°',
+ plusmn => '±',
+ sup1 => '¹',
+ sup2 => '²',
+ sup3 => '³',
+ acute => '´',
+ micro => 'µ',
+ para => '¶',
+ middot => '·',
+ cedil => '¸',
+ ordm => 'º',
+ raquo => '»',
+ frac14 => '¼',
+ frac12 => '½',
+ frac34 => '¾',
+ iquest => '¿',
+'times' => '×', # times is a keyword in perl
+ divide => '÷',
+
+# some POD special entities
+ verbar => '|',
+ sol => '/'
+);
+
+##---------------------------------------------------------------------------
+
+##---------------------------------
+## Function definitions begin here
+##---------------------------------
+
+sub podchecker {
+ my ($infile, $outfile, %options) = @_;
+ local $_;
+
+ ## Set defaults
+ $infile ||= \*STDIN;
+ $outfile ||= \*STDERR;
+
+ ## Now create a pod checker
+ my $checker = new Pod::Checker(%options);
+
+ ## Now check the pod document for errors
+ $checker->parse_from_file($infile, $outfile);
+
+ ## Return the number of errors found
+ return $checker->num_errors();
+}
+
+##---------------------------------------------------------------------------
+
+##-------------------------------
+## Method definitions begin here
+##-------------------------------
+
+##################################
+
+=over 4
+
+=item C<Pod::Checker-E<gt>new( %options )>
+
+Return a reference to a new Pod::Checker object that inherits from
+Pod::Parser and is used for calling the required methods later. The
+following options are recognized:
+
+C<-warnings =E<gt> num>
+ Print warnings if C<num> is true. The higher the value of C<num>,
+the more warnings are printed. Currently there are only levels 1 and 2.
+
+C<-quiet =E<gt> num>
+ If C<num> is true, do not print any errors/warnings. This is useful
+when Pod::Checker is used to munge POD code into plain text from within
+POD formatters.
+
+=cut
+
+## sub new {
+## my $this = shift;
+## my $class = ref($this) || $this;
+## my %params = @_;
+## my $self = {%params};
+## bless $self, $class;
+## $self->initialize();
+## return $self;
+## }
+
+sub initialize {
+ my $self = shift;
+ ## Initialize number of errors, and setup an error function to
+ ## increment this number and then print to the designated output.
+ $self->{_NUM_ERRORS} = 0;
+ $self->{_NUM_WARNINGS} = 0;
+ $self->{-quiet} ||= 0;
+ # set the error handling subroutine
+ $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror');
+ $self->{_commands} = 0; # total number of POD commands encountered
+ $self->{_list_stack} = []; # stack for nested lists
+ $self->{_have_begin} = ''; # stores =begin
+ $self->{_links} = []; # stack for internal hyperlinks
+ $self->{_nodes} = []; # stack for =head/=item nodes
+ $self->{_index} = []; # text in X<>
+ # print warnings?
+ $self->{-warnings} = 1 unless(defined $self->{-warnings});
+ $self->{_current_head1} = ''; # the current =head1 block
+ $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings});
+}
+
+##################################
+
+=item C<$checker-E<gt>poderror( @args )>
+
+=item C<$checker-E<gt>poderror( {%opts}, @args )>
+
+Internal method for printing errors and warnings. If no options are
+given, simply prints "@_". The following options are recognized and used
+to form the output:
+
+ -msg
+
+A message to print prior to C<@args>.
+
+ -line
+
+The line number the error occurred in.
+
+ -file
+
+The file (name) the error occurred in.
+
+ -severity
+
+The error level, should be 'WARNING' or 'ERROR'.
+
+=cut
+
+# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
+sub poderror {
+ my $self = shift;
+ my %opts = (ref $_[0]) ? %{shift()} : ();
+
+ ## Retrieve options
+ chomp( my $msg = ($opts{-msg} || '')."@_" );
+ my $line = (exists $opts{-line}) ? " at line $opts{-line}" : '';
+ my $file = (exists $opts{-file}) ? " in file $opts{-file}" : '';
+ unless (exists $opts{-severity}) {
+ ## See if can find severity in message prefix
+ $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
+ }
+ my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : '';
+
+ ## Increment error count and print message "
+ ++($self->{_NUM_ERRORS})
+ if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR'));
+ ++($self->{_NUM_WARNINGS})
+ if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING'));
+ unless($self->{-quiet}) {
+ my $out_fh = $self->output_handle() || \*STDERR;
+ print $out_fh ($severity, $msg, $line, $file, "\n")
+ if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING');
+ }
+}
+
+##################################
+
+=item C<$checker-E<gt>num_errors()>
+
+Set (if argument specified) and retrieve the number of errors found.
+
+=cut
+
+sub num_errors {
+ return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS};
+}
+
+##################################
+
+=item C<$checker-E<gt>num_warnings()>
+
+Set (if argument specified) and retrieve the number of warnings found.
+
+=cut
+
+sub num_warnings {
+ return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS};
+}
+
+##################################
+
+=item C<$checker-E<gt>name()>
+
+Set (if argument specified) and retrieve the canonical name of POD as
+found in the C<=head1 NAME> section.
+
+=cut
+
+sub name {
+ return (@_ > 1 && $_[1]) ?
+ ($_[0]->{-name} = $_[1]) : $_[0]->{-name};
+}
+
+##################################
+
+=item C<$checker-E<gt>node()>
+
+Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
+and C<=item>) of the current POD. The nodes are returned in the order of
+their occurrence. They consist of plain text, each piece of whitespace is
+collapsed to a single blank.
+
+=cut
+
+sub node {
+ my ($self,$text) = @_;
+ if(defined $text) {
+ $text =~ s/\s+$//s; # strip trailing whitespace
+ $text =~ s/\s+/ /gs; # collapse whitespace
+ # add node, order important!
+ push(@{$self->{_nodes}}, $text);
+ # keep also a uniqueness counter
+ $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
+ return $text;
+ }
+ @{$self->{_nodes}};
+}
+
+##################################
+
+=item C<$checker-E<gt>idx()>
+
+Add (if argument specified) and retrieve the index entries (as defined by
+C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
+of whitespace is collapsed to a single blank.
+
+=cut
+
+# set/return index entries of current POD
+sub idx {
+ my ($self,$text) = @_;
+ if(defined $text) {
+ $text =~ s/\s+$//s; # strip trailing whitespace
+ $text =~ s/\s+/ /gs; # collapse whitespace
+ # add node, order important!
+ push(@{$self->{_index}}, $text);
+ # keep also a uniqueness counter
+ $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
+ return $text;
+ }
+ @{$self->{_index}};
+}
+
+##################################
+
+=item C<$checker-E<gt>hyperlink()>
+
+Add (if argument specified) and retrieve the hyperlinks (as defined by
+C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line
+number and C<Pod::Hyperlink> object.
+
+=back
+
+=cut
+
+# set/return hyperlinks of the current POD
+sub hyperlink {
+ my $self = shift;
+ if($_[0]) {
+ push(@{$self->{_links}}, $_[0]);
+ return $_[0];
+ }
+ @{$self->{_links}};
+}
+
+## overrides for Pod::Parser
+
+sub end_pod {
+ ## Do some final checks and
+ ## print the number of errors found
+ my $self = shift;
+ my $infile = $self->input_file();
+
+ if(@{$self->{_list_stack}}) {
+ my $list;
+ while(($list = $self->_close_list('EOF',$infile)) &&
+ $list->indent() ne 'auto') {
+ $self->poderror({ -line => 'EOF', -file => $infile,
+ -severity => 'ERROR', -msg => '=over on line ' .
+ $list->start() . ' without closing =back' });
+ }
+ }
+
+ # check validity of document internal hyperlinks
+ # first build the node names from the paragraph text
+ my %nodes;
+ foreach($self->node()) {
+ $nodes{$_} = 1;
+ if(/^(\S+)\s+\S/) {
+ # we have more than one word. Use the first as a node, too.
+ # This is used heavily in perlfunc.pod
+ $nodes{$1} ||= 2; # derived node
+ }
+ }
+ foreach($self->idx()) {
+ $nodes{$_} = 3; # index node
+ }
+ foreach($self->hyperlink()) {
+ my ($line,$link) = @$_;
+ # _TODO_ what if there is a link to the page itself by the name,
+ # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION">
+ if($link->node() && !$link->page() && $link->type() ne 'hyperlink') {
+ my $node = $self->_check_ptree($self->parse_text($link->node(),
+ $line), $line, $infile, 'L');
+ if($node && !$nodes{$node}) {
+ $self->poderror({ -line => $line || '', -file => $infile,
+ -severity => 'ERROR',
+ -msg => "unresolved internal link '$node'"});
+ }
+ }
+ }
+
+ # check the internal nodes for uniqueness. This pertains to
+ # =headX, =item and X<...>
+ if($self->{-warnings} && $self->{-warnings}>1) {
+ foreach(grep($self->{_unique_nodes}->{$_} > 1,
+ keys %{$self->{_unique_nodes}})) {
+ $self->poderror({ -line => '-', -file => $infile,
+ -severity => 'WARNING',
+ -msg => "multiple occurrence of link target '$_'"});
+ }
+ }
+
+ # no POD found here
+ $self->num_errors(-1) if($self->{_commands} == 0);
+}
+
+# check a POD command directive
+sub command {
+ my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
+ my ($file, $line) = $pod_para->file_line;
+ ## Check the command syntax
+ my $arg; # this will hold the command argument
+ if (! $VALID_COMMANDS{$cmd}) {
+ $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',
+ -msg => "Unknown command '$cmd'" });
+ }
+ else { # found a valid command
+ $self->{_commands}++; # delete this line if below is enabled again
+
+ ##### following check disabled due to strong request
+ #if(!$self->{_commands}++ && $cmd !~ /^head/) {
+ # $self->poderror({ -line => $line, -file => $file,
+ # -severity => 'WARNING',
+ # -msg => "file does not start with =head" });
+ #}
+
+ # check syntax of particular command
+ if($cmd eq 'over') {
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ my $indent = 4; # default
+ if($arg && $arg =~ /^\s*(\d+)\s*$/) {
+ $indent = $1;
+ }
+ # start a new list
+ $self->_open_list($indent,$line,$file);
+ }
+ elsif($cmd eq 'item') {
+ # are we in a list?
+ unless(@{$self->{_list_stack}}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=item without previous =over' });
+ # auto-open in case we encounter many more
+ $self->_open_list('auto',$line,$file);
+ }
+ my $list = $self->{_list_stack}->[0];
+ # check whether the previous item had some contents
+ if(defined $self->{_list_item_contents} &&
+ $self->{_list_item_contents} == 0) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'previous =item has no contents' });
+ }
+ if($list->{_has_par}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'preceding non-item paragraph(s)' });
+ delete $list->{_has_par};
+ }
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line, $file);
+ if($arg && $arg =~ /(\S+)/) {
+ $arg =~ s/[\s\n]+$//;
+ my $type;
+ if($arg =~ /^[*]\s*(\S*.*)/) {
+ $type = 'bullet';
+ $self->{_list_item_contents} = $1 ? 1 : 0;
+ $arg = $1;
+ }
+ elsif($arg =~ /^\d+\.?\s+(\S*)/) {
+ $type = 'number';
+ $self->{_list_item_contents} = $1 ? 1 : 0;
+ $arg = $1;
+ }
+ else {
+ $type = 'definition';
+ $self->{_list_item_contents} = 1;
+ }
+ my $first = $list->type();
+ if($first && $first ne $type) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "=item type mismatch ('$first' vs. '$type')"});
+ }
+ else { # first item
+ $list->type($type);
+ }
+ }
+ else {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'No argument for =item' });
+ $arg = ' '; # empty
+ $self->{_list_item_contents} = 0;
+ }
+ # add this item
+ $list->item($arg);
+ # remember this node
+ $self->node($arg);
+ }
+ elsif($cmd eq 'back') {
+ # check if we have an open list
+ unless(@{$self->{_list_stack}}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=back without previous =over' });
+ }
+ else {
+ # check for spurious characters
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ if($arg && $arg =~ /\S/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Spurious character(s) after =back' });
+ }
+ # close list
+ my $list = $self->_close_list($line,$file);
+ # check for empty lists
+ if(!$list->item() && $self->{-warnings}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'No items in =over (at line ' .
+ $list->start() . ') / =back list'});
+ }
+ }
+ }
+ elsif($cmd =~ /^head(\d+)/) {
+ my $hnum = $1;
+ $self->{"_have_head_$hnum"}++; # count head types
+ if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "=head$hnum without preceding higher level"});
+ }
+ # check whether the previous =head section had some contents
+ if(defined $self->{_commands_in_head} &&
+ $self->{_commands_in_head} == 0 &&
+ defined $self->{_last_head} &&
+ $self->{_last_head} >= $hnum) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'empty section in previous paragraph'});
+ }
+ $self->{_commands_in_head} = -1;
+ $self->{_last_head} = $hnum;
+ # check if there is an open list
+ if(@{$self->{_list_stack}}) {
+ my $list;
+ while(($list = $self->_close_list($line,$file)) &&
+ $list->indent() ne 'auto') {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=over on line '. $list->start() .
+ " without closing =back (at $cmd)" });
+ }
+ }
+ # remember this node
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ $arg =~ s/[\s\n]+$//s;
+ $self->node($arg);
+ unless(length($arg)) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => "empty =$cmd"});
+ }
+ if($cmd eq 'head1') {
+ $self->{_current_head1} = $arg;
+ } else {
+ $self->{_current_head1} = '';
+ }
+ }
+ elsif($cmd eq 'begin') {
+ if($self->{_have_begin}) {
+ # already have a begin
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => q{Nested =begin's (first at line } .
+ $self->{_have_begin} . ')'});
+ }
+ else {
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ unless($arg && $arg =~ /(\S+)/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'No argument for =begin'});
+ }
+ # remember the =begin
+ $self->{_have_begin} = "$line:$1";
+ }
+ }
+ elsif($cmd eq 'end') {
+ if($self->{_have_begin}) {
+ # close the existing =begin
+ $self->{_have_begin} = '';
+ # check for spurious characters
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ # the closing argument is optional
+ #if($arg && $arg =~ /\S/) {
+ # $self->poderror({ -line => $line, -file => $file,
+ # -severity => 'WARNING',
+ # -msg => "Spurious character(s) after =end" });
+ #}
+ }
+ else {
+ # don't have a matching =begin
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=end without =begin' });
+ }
+ }
+ elsif($cmd eq 'for') {
+ unless($paragraph =~ /\s*(\S+)\s*/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => '=for without formatter specification' });
+ }
+ $arg = ''; # do not expand paragraph below
+ }
+ elsif($cmd =~ /^(pod|cut)$/) {
+ # check for argument
+ $arg = $self->interpolate_and_check($paragraph, $line,$file);
+ if($arg && $arg =~ /(\S+)/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => "Spurious text after =$cmd"});
+ }
+ }
+ $self->{_commands_in_head}++;
+ ## Check the interior sequences in the command-text
+ $self->interpolate_and_check($paragraph, $line,$file)
+ unless(defined $arg);
+ }
+}
+
+sub _open_list
+{
+ my ($self,$indent,$line,$file) = @_;
+ my $list = Pod::List->new(
+ -indent => $indent,
+ -start => $line,
+ -file => $file);
+ unshift(@{$self->{_list_stack}}, $list);
+ undef $self->{_list_item_contents};
+ $list;
+}
+
+sub _close_list
+{
+ my ($self,$line,$file) = @_;
+ my $list = shift(@{$self->{_list_stack}});
+ if(defined $self->{_list_item_contents} &&
+ $self->{_list_item_contents} == 0) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'previous =item has no contents' });
+ }
+ undef $self->{_list_item_contents};
+ $list;
+}
+
+# process a block of some text
+sub interpolate_and_check {
+ my ($self, $paragraph, $line, $file) = @_;
+ ## Check the interior sequences in the command-text
+ # and return the text
+ $self->_check_ptree(
+ $self->parse_text($paragraph,$line), $line, $file, '');
+}
+
+sub _check_ptree {
+ my ($self,$ptree,$line,$file,$nestlist) = @_;
+ local($_);
+ my $text = '';
+ # process each node in the parse tree
+ foreach(@$ptree) {
+ # regular text chunk
+ unless(ref) {
+ # count the unescaped angle brackets
+ # complain only when warning level is greater than 1
+ if($self->{-warnings} && $self->{-warnings}>1) {
+ my $count;
+ if($count = tr/<>/<>/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "$count unescaped <> in paragraph" });
+ }
+ }
+ $text .= $_;
+ next;
+ }
+ # have an interior sequence
+ my $cmd = $_->cmd_name();
+ my $contents = $_->parse_tree();
+ ($file,$line) = $_->file_line();
+ # check for valid tag
+ if (! $VALID_SEQUENCES{$cmd}) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => qq(Unknown interior-sequence '$cmd')});
+ # expand it anyway
+ $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
+ next;
+ }
+ if($nestlist =~ /$cmd/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => "nested commands $cmd<...$cmd<...>...>"});
+ # _TODO_ should we add the contents anyway?
+ # expand it anyway, see below
+ }
+ if($cmd eq 'E') {
+ # preserve entities
+ if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'garbled entity ' . $_->raw_text()});
+ next;
+ }
+ my $ent = $$contents[0];
+ my $val;
+ if($ent =~ /^0x[0-9a-f]+$/i) {
+ # hexadec entity
+ $val = hex($ent);
+ }
+ elsif($ent =~ /^0\d+$/) {
+ # octal
+ $val = oct($ent);
+ }
+ elsif($ent =~ /^\d+$/) {
+ # numeric entity
+ $val = $ent;
+ }
+ if(defined $val) {
+ if($val>0 && $val<256) {
+ $text .= chr($val);
+ }
+ else {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Entity number out of range ' . $_->raw_text()});
+ }
+ }
+ elsif($ENTITIES{$ent}) {
+ # known ISO entity
+ $text .= $ENTITIES{$ent};
+ }
+ else {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'Unknown entity ' . $_->raw_text()});
+ $text .= "E<$ent>";
+ }
+ }
+ elsif($cmd eq 'L') {
+ # try to parse the hyperlink
+ my $link = Pod::Hyperlink->new($contents->raw_text());
+ unless(defined $link) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'malformed link ' . $_->raw_text() ." : $@"});
+ next;
+ }
+ $link->line($line); # remember line
+ if($self->{-warnings}) {
+ foreach my $w ($link->warning()) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => $w });
+ }
+ }
+ # check the link text
+ $text .= $self->_check_ptree($self->parse_text($link->text(),
+ $line), $line, $file, "$nestlist$cmd");
+ # remember link
+ $self->hyperlink([$line,$link]);
+ }
+ elsif($cmd =~ /[BCFIS]/) {
+ # add the guts
+ $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
+ }
+ elsif($cmd eq 'Z') {
+ if(length($contents->raw_text())) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Nonempty Z<>'});
+ }
+ }
+ elsif($cmd eq 'X') {
+ my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
+ if($idx =~ /^\s*$/s) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => 'Empty X<>'});
+ }
+ else {
+ # remember this node
+ $self->idx($idx);
+ }
+ }
+ else {
+ # not reached
+ croak 'internal error';
+ }
+ }
+ $text;
+}
+
+# process a block of verbatim text
+sub verbatim {
+ ## Nothing particular to check
+ my ($self, $paragraph, $line_num, $pod_para) = @_;
+
+ $self->_preproc_par($paragraph);
+
+ if($self->{_current_head1} eq 'NAME') {
+ my ($file, $line) = $pod_para->file_line;
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'WARNING',
+ -msg => 'Verbatim paragraph in NAME section' });
+ }
+}
+
+# process a block of regular text
+sub textblock {
+ my ($self, $paragraph, $line_num, $pod_para) = @_;
+ my ($file, $line) = $pod_para->file_line;
+
+ $self->_preproc_par($paragraph);
+
+ # skip this paragraph if in a =begin block
+ unless($self->{_have_begin}) {
+ my $block = $self->interpolate_and_check($paragraph, $line,$file);
+ if($self->{_current_head1} eq 'NAME') {
+ if($block =~ /^\s*(\S+?)\s*[,-]/) {
+ # this is the canonical name
+ $self->{-name} = $1 unless(defined $self->{-name});
+ }
+ }
+ }
+}
+
+sub _preproc_par
+{
+ my $self = shift;
+ $_[0] =~ s/[\s\n]+$//;
+ if($_[0]) {
+ $self->{_commands_in_head}++;
+ $self->{_list_item_contents}++ if(defined $self->{_list_item_contents});
+ if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) {
+ $self->{_list_stack}->[0]->{_has_par} = 1;
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version),
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>
+
+Based on code for B<Pod::Text::pod2text()> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Escapes.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Escapes.pm
new file mode 100755
index 00000000000..de4d75a7b83
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Escapes.pm
@@ -0,0 +1,721 @@
+
+require 5;
+# The documentation is at the end.
+# Time-stamp: "2004-05-07 15:31:25 ADT"
+package Pod::Escapes;
+require Exporter;
+@ISA = ('Exporter');
+$VERSION = '1.04';
+@EXPORT_OK = qw(
+ %Code2USASCII
+ %Name2character
+ %Name2character_number
+ %Latin1Code_to_fallback
+ %Latin1Char_to_fallback
+ e2char
+ e2charnum
+);
+%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
+
+#==========================================================================
+
+use strict;
+use vars qw(
+ %Code2USASCII
+ %Name2character
+ %Name2character_number
+ %Latin1Code_to_fallback
+ %Latin1Char_to_fallback
+ $FAR_CHAR
+ $FAR_CHAR_NUMBER
+ $NOT_ASCII
+);
+
+$FAR_CHAR = "?" unless defined $FAR_CHAR;
+$FAR_CHAR_NUMBER = ord($FAR_CHAR) unless defined $FAR_CHAR_NUMBER;
+
+$NOT_ASCII = 'A' ne chr(65) unless defined $NOT_ASCII;
+
+#--------------------------------------------------------------------------
+sub e2char {
+ my $in = $_[0];
+ return undef unless defined $in and length $in;
+
+ # Convert to decimal:
+ if($in =~ m/^(0[0-7]*)$/s ) {
+ $in = oct $in;
+ } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
+ $in = hex $1;
+ } # else it's decimal, or named
+
+ if($NOT_ASCII) {
+ # We're in bizarro world of not-ASCII!
+ # Cope with US-ASCII codes, use fallbacks for Latin-1, or use FAR_CHAR.
+ unless($in =~ m/^\d+$/s) {
+ # It's a named character reference. Get its numeric Unicode value.
+ $in = $Name2character{$in};
+ return undef unless defined $in; # (if there's no such name)
+ $in = ord $in; # (All ents must be one character long.)
+ # ...So $in holds the char's US-ASCII numeric value, which we'll
+ # now go get the local equivalent for.
+ }
+
+ # It's numeric, whether by origin or by mutation from a known name
+ return $Code2USASCII{$in} # so "65" => "A" everywhere
+ || $Latin1Code_to_fallback{$in} # Fallback.
+ || $FAR_CHAR; # Fall further back
+ }
+
+ # Normal handling:
+ if($in =~ m/^\d+$/s) {
+ if($] < 5.007 and $in > 255) { # can't be trusted with Unicode
+ return $FAR_CHAR;
+ } else {
+ return chr($in);
+ }
+ } else {
+ return $Name2character{$in}; # returns undef if unknown
+ }
+}
+
+#--------------------------------------------------------------------------
+sub e2charnum {
+ my $in = $_[0];
+ return undef unless defined $in and length $in;
+
+ # Convert to decimal:
+ if($in =~ m/^(0[0-7]*)$/s ) {
+ $in = oct $in;
+ } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
+ $in = hex $1;
+ } # else it's decimal, or named
+
+ if($in =~ m/^\d+$/s) {
+ return 0 + $in;
+ } else {
+ return $Name2character_number{$in}; # returns undef if unknown
+ }
+}
+
+#--------------------------------------------------------------------------
+
+%Name2character_number = (
+ # General XML/XHTML:
+ 'lt' => 60,
+ 'gt' => 62,
+ 'quot' => 34,
+ 'amp' => 38,
+ 'apos' => 39,
+
+ # POD-specific:
+ 'sol' => 47,
+ 'verbar' => 124,
+
+ 'lchevron' => 171, # legacy for laquo
+ 'rchevron' => 187, # legacy for raquo
+
+ # Remember, grave looks like \ (as in virtu\)
+ # acute looks like / (as in re/sume/)
+ # circumflex looks like ^ (as in papier ma^che/)
+ # umlaut/dieresis looks like " (as in nai"ve, Chloe")
+
+ # From the XHTML 1 .ent files:
+ 'nbsp' , 160,
+ 'iexcl' , 161,
+ 'cent' , 162,
+ 'pound' , 163,
+ 'curren' , 164,
+ 'yen' , 165,
+ 'brvbar' , 166,
+ 'sect' , 167,
+ 'uml' , 168,
+ 'copy' , 169,
+ 'ordf' , 170,
+ 'laquo' , 171,
+ 'not' , 172,
+ 'shy' , 173,
+ 'reg' , 174,
+ 'macr' , 175,
+ 'deg' , 176,
+ 'plusmn' , 177,
+ 'sup2' , 178,
+ 'sup3' , 179,
+ 'acute' , 180,
+ 'micro' , 181,
+ 'para' , 182,
+ 'middot' , 183,
+ 'cedil' , 184,
+ 'sup1' , 185,
+ 'ordm' , 186,
+ 'raquo' , 187,
+ 'frac14' , 188,
+ 'frac12' , 189,
+ 'frac34' , 190,
+ 'iquest' , 191,
+ 'Agrave' , 192,
+ 'Aacute' , 193,
+ 'Acirc' , 194,
+ 'Atilde' , 195,
+ 'Auml' , 196,
+ 'Aring' , 197,
+ 'AElig' , 198,
+ 'Ccedil' , 199,
+ 'Egrave' , 200,
+ 'Eacute' , 201,
+ 'Ecirc' , 202,
+ 'Euml' , 203,
+ 'Igrave' , 204,
+ 'Iacute' , 205,
+ 'Icirc' , 206,
+ 'Iuml' , 207,
+ 'ETH' , 208,
+ 'Ntilde' , 209,
+ 'Ograve' , 210,
+ 'Oacute' , 211,
+ 'Ocirc' , 212,
+ 'Otilde' , 213,
+ 'Ouml' , 214,
+ 'times' , 215,
+ 'Oslash' , 216,
+ 'Ugrave' , 217,
+ 'Uacute' , 218,
+ 'Ucirc' , 219,
+ 'Uuml' , 220,
+ 'Yacute' , 221,
+ 'THORN' , 222,
+ 'szlig' , 223,
+ 'agrave' , 224,
+ 'aacute' , 225,
+ 'acirc' , 226,
+ 'atilde' , 227,
+ 'auml' , 228,
+ 'aring' , 229,
+ 'aelig' , 230,
+ 'ccedil' , 231,
+ 'egrave' , 232,
+ 'eacute' , 233,
+ 'ecirc' , 234,
+ 'euml' , 235,
+ 'igrave' , 236,
+ 'iacute' , 237,
+ 'icirc' , 238,
+ 'iuml' , 239,
+ 'eth' , 240,
+ 'ntilde' , 241,
+ 'ograve' , 242,
+ 'oacute' , 243,
+ 'ocirc' , 244,
+ 'otilde' , 245,
+ 'ouml' , 246,
+ 'divide' , 247,
+ 'oslash' , 248,
+ 'ugrave' , 249,
+ 'uacute' , 250,
+ 'ucirc' , 251,
+ 'uuml' , 252,
+ 'yacute' , 253,
+ 'thorn' , 254,
+ 'yuml' , 255,
+
+ 'fnof' , 402,
+ 'Alpha' , 913,
+ 'Beta' , 914,
+ 'Gamma' , 915,
+ 'Delta' , 916,
+ 'Epsilon' , 917,
+ 'Zeta' , 918,
+ 'Eta' , 919,
+ 'Theta' , 920,
+ 'Iota' , 921,
+ 'Kappa' , 922,
+ 'Lambda' , 923,
+ 'Mu' , 924,
+ 'Nu' , 925,
+ 'Xi' , 926,
+ 'Omicron' , 927,
+ 'Pi' , 928,
+ 'Rho' , 929,
+ 'Sigma' , 931,
+ 'Tau' , 932,
+ 'Upsilon' , 933,
+ 'Phi' , 934,
+ 'Chi' , 935,
+ 'Psi' , 936,
+ 'Omega' , 937,
+ 'alpha' , 945,
+ 'beta' , 946,
+ 'gamma' , 947,
+ 'delta' , 948,
+ 'epsilon' , 949,
+ 'zeta' , 950,
+ 'eta' , 951,
+ 'theta' , 952,
+ 'iota' , 953,
+ 'kappa' , 954,
+ 'lambda' , 955,
+ 'mu' , 956,
+ 'nu' , 957,
+ 'xi' , 958,
+ 'omicron' , 959,
+ 'pi' , 960,
+ 'rho' , 961,
+ 'sigmaf' , 962,
+ 'sigma' , 963,
+ 'tau' , 964,
+ 'upsilon' , 965,
+ 'phi' , 966,
+ 'chi' , 967,
+ 'psi' , 968,
+ 'omega' , 969,
+ 'thetasym' , 977,
+ 'upsih' , 978,
+ 'piv' , 982,
+ 'bull' , 8226,
+ 'hellip' , 8230,
+ 'prime' , 8242,
+ 'Prime' , 8243,
+ 'oline' , 8254,
+ 'frasl' , 8260,
+ 'weierp' , 8472,
+ 'image' , 8465,
+ 'real' , 8476,
+ 'trade' , 8482,
+ 'alefsym' , 8501,
+ 'larr' , 8592,
+ 'uarr' , 8593,
+ 'rarr' , 8594,
+ 'darr' , 8595,
+ 'harr' , 8596,
+ 'crarr' , 8629,
+ 'lArr' , 8656,
+ 'uArr' , 8657,
+ 'rArr' , 8658,
+ 'dArr' , 8659,
+ 'hArr' , 8660,
+ 'forall' , 8704,
+ 'part' , 8706,
+ 'exist' , 8707,
+ 'empty' , 8709,
+ 'nabla' , 8711,
+ 'isin' , 8712,
+ 'notin' , 8713,
+ 'ni' , 8715,
+ 'prod' , 8719,
+ 'sum' , 8721,
+ 'minus' , 8722,
+ 'lowast' , 8727,
+ 'radic' , 8730,
+ 'prop' , 8733,
+ 'infin' , 8734,
+ 'ang' , 8736,
+ 'and' , 8743,
+ 'or' , 8744,
+ 'cap' , 8745,
+ 'cup' , 8746,
+ 'int' , 8747,
+ 'there4' , 8756,
+ 'sim' , 8764,
+ 'cong' , 8773,
+ 'asymp' , 8776,
+ 'ne' , 8800,
+ 'equiv' , 8801,
+ 'le' , 8804,
+ 'ge' , 8805,
+ 'sub' , 8834,
+ 'sup' , 8835,
+ 'nsub' , 8836,
+ 'sube' , 8838,
+ 'supe' , 8839,
+ 'oplus' , 8853,
+ 'otimes' , 8855,
+ 'perp' , 8869,
+ 'sdot' , 8901,
+ 'lceil' , 8968,
+ 'rceil' , 8969,
+ 'lfloor' , 8970,
+ 'rfloor' , 8971,
+ 'lang' , 9001,
+ 'rang' , 9002,
+ 'loz' , 9674,
+ 'spades' , 9824,
+ 'clubs' , 9827,
+ 'hearts' , 9829,
+ 'diams' , 9830,
+ 'OElig' , 338,
+ 'oelig' , 339,
+ 'Scaron' , 352,
+ 'scaron' , 353,
+ 'Yuml' , 376,
+ 'circ' , 710,
+ 'tilde' , 732,
+ 'ensp' , 8194,
+ 'emsp' , 8195,
+ 'thinsp' , 8201,
+ 'zwnj' , 8204,
+ 'zwj' , 8205,
+ 'lrm' , 8206,
+ 'rlm' , 8207,
+ 'ndash' , 8211,
+ 'mdash' , 8212,
+ 'lsquo' , 8216,
+ 'rsquo' , 8217,
+ 'sbquo' , 8218,
+ 'ldquo' , 8220,
+ 'rdquo' , 8221,
+ 'bdquo' , 8222,
+ 'dagger' , 8224,
+ 'Dagger' , 8225,
+ 'permil' , 8240,
+ 'lsaquo' , 8249,
+ 'rsaquo' , 8250,
+ 'euro' , 8364,
+);
+
+
+# Fill out %Name2character...
+{
+ %Name2character = ();
+ my($name, $number);
+ while( ($name, $number) = each %Name2character_number) {
+ if($] < 5.007 and $number > 255) {
+ $Name2character{$name} = $FAR_CHAR;
+ # substitute for Unicode characters, for perls
+ # that can't reliable handle them
+ } else {
+ $Name2character{$name} = chr $number;
+ # normal case
+ }
+ }
+ # So they resolve 'right' even in EBCDIC-land
+ $Name2character{'lt' } = '<';
+ $Name2character{'gt' } = '>';
+ $Name2character{'quot'} = '"';
+ $Name2character{'amp' } = '&';
+ $Name2character{'apos'} = "'";
+ $Name2character{'sol' } = '/';
+ $Name2character{'verbar'} = '|';
+}
+
+#--------------------------------------------------------------------------
+
+%Code2USASCII = (
+# mostly generated by
+# perl -e "printf qq{ \x25 3s, '\x25s',\n}, $_, chr($_) foreach (32 .. 126)"
+ 32, ' ',
+ 33, '!',
+ 34, '"',
+ 35, '#',
+ 36, '$',
+ 37, '%',
+ 38, '&',
+ 39, "'", #!
+ 40, '(',
+ 41, ')',
+ 42, '*',
+ 43, '+',
+ 44, ',',
+ 45, '-',
+ 46, '.',
+ 47, '/',
+ 48, '0',
+ 49, '1',
+ 50, '2',
+ 51, '3',
+ 52, '4',
+ 53, '5',
+ 54, '6',
+ 55, '7',
+ 56, '8',
+ 57, '9',
+ 58, ':',
+ 59, ';',
+ 60, '<',
+ 61, '=',
+ 62, '>',
+ 63, '?',
+ 64, '@',
+ 65, 'A',
+ 66, 'B',
+ 67, 'C',
+ 68, 'D',
+ 69, 'E',
+ 70, 'F',
+ 71, 'G',
+ 72, 'H',
+ 73, 'I',
+ 74, 'J',
+ 75, 'K',
+ 76, 'L',
+ 77, 'M',
+ 78, 'N',
+ 79, 'O',
+ 80, 'P',
+ 81, 'Q',
+ 82, 'R',
+ 83, 'S',
+ 84, 'T',
+ 85, 'U',
+ 86, 'V',
+ 87, 'W',
+ 88, 'X',
+ 89, 'Y',
+ 90, 'Z',
+ 91, '[',
+ 92, "\\", #!
+ 93, ']',
+ 94, '^',
+ 95, '_',
+ 96, '`',
+ 97, 'a',
+ 98, 'b',
+ 99, 'c',
+ 100, 'd',
+ 101, 'e',
+ 102, 'f',
+ 103, 'g',
+ 104, 'h',
+ 105, 'i',
+ 106, 'j',
+ 107, 'k',
+ 108, 'l',
+ 109, 'm',
+ 110, 'n',
+ 111, 'o',
+ 112, 'p',
+ 113, 'q',
+ 114, 'r',
+ 115, 's',
+ 116, 't',
+ 117, 'u',
+ 118, 'v',
+ 119, 'w',
+ 120, 'x',
+ 121, 'y',
+ 122, 'z',
+ 123, '{',
+ 124, '|',
+ 125, '}',
+ 126, '~',
+);
+
+#--------------------------------------------------------------------------
+
+%Latin1Code_to_fallback = ();
+@Latin1Code_to_fallback{0xA0 .. 0xFF} = (
+# Copied from Text/Unidecode/x00.pm:
+
+' ', qq{!}, qq{C/}, 'PS', qq{\$?}, qq{Y=}, qq{|}, 'SS', qq{"}, qq{(c)}, 'a', qq{<<}, qq{!}, "", qq{(r)}, qq{-},
+'deg', qq{+-}, '2', '3', qq{'}, 'u', 'P', qq{*}, qq{,}, '1', 'o', qq{>>}, qq{1/4}, qq{1/2}, qq{3/4}, qq{?},
+'A', 'A', 'A', 'A', 'A', 'A', 'AE', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I',
+'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'U', 'Th', 'ss',
+'a', 'a', 'a', 'a', 'a', 'a', 'ae', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i',
+'d', 'n', 'o', 'o', 'o', 'o', 'o', qq{/}, 'o', 'u', 'u', 'u', 'u', 'y', 'th', 'y',
+
+);
+
+{
+ # Now stuff %Latin1Char_to_fallback:
+ %Latin1Char_to_fallback = ();
+ my($k,$v);
+ while( ($k,$v) = each %Latin1Code_to_fallback) {
+ $Latin1Char_to_fallback{chr $k} = $v;
+ #print chr($k), ' => ', $v, "\n";
+ }
+}
+
+#--------------------------------------------------------------------------
+1;
+__END__
+
+=head1 NAME
+
+Pod::Escapes -- for resolving Pod EE<lt>...E<gt> sequences
+
+=head1 SYNOPSIS
+
+ use Pod::Escapes qw(e2char);
+ ...la la la, parsing POD, la la la...
+ $text = e2char($e_node->label);
+ unless(defined $text) {
+ print "Unknown E sequence \"", $e_node->label, "\"!";
+ }
+ ...else print/interpolate $text...
+
+=head1 DESCRIPTION
+
+This module provides things that are useful in decoding
+Pod EE<lt>...E<gt> sequences. Presumably, it should be used
+only by Pod parsers and/or formatters.
+
+By default, Pod::Escapes exports none of its symbols. But
+you can request any of them to be exported.
+Either request them individually, as with
+C<use Pod::Escapes qw(symbolname symbolname2...);>,
+or you can do C<use Pod::Escapes qw(:ALL);> to get all
+exportable symbols.
+
+=head1 GOODIES
+
+=over
+
+=item e2char($e_content)
+
+Given a name or number that could appear in a
+C<EE<lt>name_or_numE<gt>> sequence, this returns the string that
+it stands for. For example, C<e2char('sol')>, C<e2char('47')>,
+C<e2char('0x2F')>, and C<e2char('057')> all return "/",
+because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
+and C<EE<lt>057E<gt>>, all mean "/". If
+the name has no known value (as with a name of "qacute") or is
+syntactally invalid (as with a name of "1/4"), this returns undef.
+
+=item e2charnum($e_content)
+
+Given a name or number that could appear in a
+C<EE<lt>name_or_numE<gt>> sequence, this returns the number of
+the Unicode character that this stands for. For example,
+C<e2char('sol')>, C<e2char('47')>,
+C<e2char('0x2F')>, and C<e2char('057')> all return 47,
+because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
+and C<EE<lt>057E<gt>>, all mean "/", whose Unicode number is 47. If
+the name has no known value (as with a name of "qacute") or is
+syntactally invalid (as with a name of "1/4"), this returns undef.
+
+=item $Name2character{I<name>}
+
+Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
+to the string that each stands for. Note that this does not
+include numerics (like "64" or "x981c"). Under old Perl versions
+(before 5.7) you get a "?" in place of characters whose Unicode
+value is over 255.
+
+=item $Name2character_number{I<name>}
+
+Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
+to the Unicode value that each stands for. For example,
+C<$Name2character_number{'eacute'}> is 201, and
+C<$Name2character_number{'eacute'}> is 8364. You get the correct
+Unicode value, regardless of the version of Perl you're using --
+which differs from C<%Name2character>'s behavior under pre-5.7 Perls.
+
+Note that this hash does not
+include numerics (like "64" or "x981c").
+
+=item $Latin1Code_to_fallback{I<integer>}
+
+For numbers in the range 160 (0x00A0) to 255 (0x00FF), this maps
+from the character code for a Latin-1 character (like 233 for
+lowercase e-acute) to the US-ASCII character that best aproximates
+it (like "e"). You may find this useful if you are rendering
+POD in a format that you think deals well only with US-ASCII
+characters.
+
+=item $Latin1Char_to_fallback{I<character>}
+
+Just as above, but maps from characters (like "\xE9",
+lowercase e-acute) to characters (like "e").
+
+=item $Code2USASCII{I<integer>}
+
+This maps from US-ASCII codes (like 32) to the corresponding
+character (like space, for 32). Only characters 32 to 126 are
+defined. This is meant for use by C<e2char($x)> when it senses
+that it's running on a non-ASCII platform (where chr(32) doesn't
+get you a space -- but $Code2USASCII{32} will). It's
+documented here just in case you might find it useful.
+
+=back
+
+=head1 CAVEATS
+
+On Perl versions before 5.7, Unicode characters with a value
+over 255 (like lambda or emdash) can't be conveyed. This
+module does work under such early Perl versions, but in the
+place of each such character, you get a "?". Latin-1
+characters (characters 160-255) are unaffected.
+
+Under EBCDIC platforms, C<e2char($n)> may not always be the
+same as C<chr(e2charnum($n))>, and ditto for
+C<$Name2character{$name}> and
+C<chr($Name2character_number{$name})>.
+
+=head1 SEE ALSO
+
+L<perlpod|perlpod>
+
+L<perlpodspec|perlpodspec>
+
+L<Text::Unidecode|Text::Unidecode>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2001-2004 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+Portions of the data tables in this module are derived from the
+entity declarations in the W3C XHTML specification.
+
+Currently (October 2001), that's these three:
+
+ http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent
+ http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent
+ http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=cut
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# What I used for reading the XHTML .ent files:
+
+use strict;
+my(@norms, @good, @bad);
+my $dir = 'c:/sgml/docbook/';
+my %escapes;
+foreach my $file (qw(
+ xhtml-symbol.ent
+ xhtml-lat1.ent
+ xhtml-special.ent
+)) {
+ open(IN, "<$dir$file") or die "can't read-open $dir$file: $!";
+ print "Reading $file...\n";
+ while(<IN>) {
+ if(m/<!ENTITY\s+(\S+)\s+"&#([^;]+);">/) {
+ my($name, $value) = ($1,$2);
+ next if $name eq 'quot' or $name eq 'apos' or $name eq 'gt';
+
+ $value = hex $1 if $value =~ m/^x([a-fA-F0-9]+)$/s;
+ print "ILLEGAL VALUE $value" unless $value =~ m/^\d+$/s;
+ if($value > 255) {
+ push @good , sprintf " %-10s , chr(%s),\n", "'$name'", $value;
+ push @bad , sprintf " %-10s , \$bad,\n", "'$name'", $value;
+ } else {
+ push @norms, sprintf " %-10s , chr(%s),\n", "'$name'", $value;
+ }
+ } elsif(m/<!ENT/) {
+ print "# Skipping $_";
+ }
+
+ }
+ close(IN);
+}
+
+print @norms;
+print "\n ( \$] .= 5.006001 ? (\n";
+print @good;
+print " ) : (\n";
+print @bad;
+print " )\n);\n";
+
+__END__
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Find.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Find.pm
new file mode 100755
index 00000000000..8d1103b6a1f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Find.pm
@@ -0,0 +1,535 @@
+#############################################################################
+# Pod/Find.pm -- finds files containing POD documentation
+#
+# Author: Marek Rouchal <marekr@cpan.org>
+#
+# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
+# from Nick Ing-Simmon's PodToHtml). All rights reserved.
+# This file is part of "PodParser". Pod::Find is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Find;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '1.35'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+use Carp;
+
+BEGIN {
+ if ($] < 5.006) {
+ require Symbol;
+ import Symbol;
+ }
+}
+
+#############################################################################
+
+=head1 NAME
+
+Pod::Find - find POD documents in directory trees
+
+=head1 SYNOPSIS
+
+ use Pod::Find qw(pod_find simplify_name);
+ my %pods = pod_find({ -verbose => 1, -inc => 1 });
+ foreach(keys %pods) {
+ print "found library POD `$pods{$_}' in $_\n";
+ }
+
+ print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";
+
+ $location = pod_where( { -inc => 1 }, "Pod::Find" );
+
+=head1 DESCRIPTION
+
+B<Pod::Find> provides a set of functions to locate POD files. Note that
+no function is exported by default to avoid pollution of your namespace,
+so be sure to specify them in the B<use> statement if you need them:
+
+ use Pod::Find qw(pod_find);
+
+From this version on the typical SCM (software configuration management)
+files/directories like RCS, CVS, SCCS, .svn are ignored.
+
+=cut
+
+#use diagnostics;
+use Exporter;
+use File::Spec;
+use File::Find;
+use Cwd;
+
+use vars qw(@ISA @EXPORT_OK $VERSION);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod);
+
+# package global variables
+my $SIMPLIFY_RX;
+
+=head2 C<pod_find( { %opts } , @directories )>
+
+The function B<pod_find> searches for POD documents in a given set of
+files and/or directories. It returns a hash with the file names as keys
+and the POD name as value. The POD name is derived from the file name
+and its position in the directory tree.
+
+E.g. when searching in F<$HOME/perl5lib>, the file
+F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
+whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
+I<Myclass::Subclass>. The name information can be used for POD
+translators.
+
+Only text files containing at least one valid POD command are found.
+
+A warning is printed if more than one POD file with the same POD name
+is found, e.g. F<CPAN.pm> in different directories. This usually
+indicates duplicate occurrences of modules in the I<@INC> search path.
+
+B<OPTIONS> The first argument for B<pod_find> may be a hash reference
+with options. The rest are either directories that are searched
+recursively or files. The POD names of files are the plain basenames
+with any Perl-like extension (.pm, .pl, .pod) stripped.
+
+=over 4
+
+=item C<-verbose =E<gt> 1>
+
+Print progress information while scanning.
+
+=item C<-perl =E<gt> 1>
+
+Apply Perl-specific heuristics to find the correct PODs. This includes
+stripping Perl-like extensions, omitting subdirectories that are numeric
+but do I<not> match the current Perl interpreter's version id, suppressing
+F<site_perl> as a module hierarchy name etc.
+
+=item C<-script =E<gt> 1>
+
+Search for PODs in the current Perl interpreter's installation
+B<scriptdir>. This is taken from the local L<Config|Config> module.
+
+=item C<-inc =E<gt> 1>
+
+Search for PODs in the current Perl interpreter's I<@INC> paths. This
+automatically considers paths specified in the C<PERL5LIB> environment
+as this is included in I<@INC> by the Perl interpreter itself.
+
+=back
+
+=cut
+
+# return a hash of the POD files found
+# first argument may be a hashref (options),
+# rest is a list of directories to search recursively
+sub pod_find
+{
+ my %opts;
+ if(ref $_[0]) {
+ %opts = %{shift()};
+ }
+
+ $opts{-verbose} ||= 0;
+ $opts{-perl} ||= 0;
+
+ my (@search) = @_;
+
+ if($opts{-script}) {
+ require Config;
+ push(@search, $Config::Config{scriptdir})
+ if -d $Config::Config{scriptdir};
+ $opts{-perl} = 1;
+ }
+
+ if($opts{-inc}) {
+ if ($^O eq 'MacOS') {
+ # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
+ my @new_INC = @INC;
+ for (@new_INC) {
+ if ( $_ eq '.' ) {
+ $_ = ':';
+ } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
+ $_ = ':'. $_;
+ } else {
+ $_ =~ s{^\./}{:};
+ }
+ }
+ push(@search, grep($_ ne File::Spec->curdir, @new_INC));
+ } else {
+ push(@search, grep($_ ne File::Spec->curdir, @INC));
+ }
+
+ $opts{-perl} = 1;
+ }
+
+ if($opts{-perl}) {
+ require Config;
+ # this code simplifies the POD name for Perl modules:
+ # * remove "site_perl"
+ # * remove e.g. "i586-linux" (from 'archname')
+ # * remove e.g. 5.00503
+ # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)
+
+ # Mac OS:
+ # * remove ":?site_perl:"
+ # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod)
+
+ if ($^O eq 'MacOS') {
+ $SIMPLIFY_RX =
+ qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!;
+ } else {
+ $SIMPLIFY_RX =
+ qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!;
+ }
+ }
+
+ my %dirs_visited;
+ my %pods;
+ my %names;
+ my $pwd = cwd();
+
+ foreach my $try (@search) {
+ unless(File::Spec->file_name_is_absolute($try)) {
+ # make path absolute
+ $try = File::Spec->catfile($pwd,$try);
+ }
+ # simplify path
+ # on VMS canonpath will vmsify:[the.path], but File::Find::find
+ # wants /unixy/paths
+ $try = File::Spec->canonpath($try) if ($^O ne 'VMS');
+ $try = VMS::Filespec::unixify($try) if ($^O eq 'VMS');
+ my $name;
+ if(-f $try) {
+ if($name = _check_and_extract_name($try, $opts{-verbose})) {
+ _check_for_duplicates($try, $name, \%names, \%pods);
+ }
+ next;
+ }
+ my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
+ File::Find::find( sub {
+ my $item = $File::Find::name;
+ if(-d) {
+ if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) {
+ $File::Find::prune = 1;
+ return;
+ }
+ elsif($dirs_visited{$item}) {
+ warn "Directory '$item' already seen, skipping.\n"
+ if($opts{-verbose});
+ $File::Find::prune = 1;
+ return;
+ }
+ else {
+ $dirs_visited{$item} = 1;
+ }
+ if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
+ $File::Find::prune = 1;
+ warn "Perl $] version mismatch on $_, skipping.\n"
+ if($opts{-verbose});
+ }
+ return;
+ }
+ if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
+ _check_for_duplicates($item, $name, \%names, \%pods);
+ }
+ }, $try); # end of File::Find::find
+ }
+ chdir $pwd;
+ return %pods;
+}
+
+sub _check_for_duplicates {
+ my ($file, $name, $names_ref, $pods_ref) = @_;
+ if($$names_ref{$name}) {
+ warn "Duplicate POD found (shadowing?): $name ($file)\n";
+ warn ' Already seen in ',
+ join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
+ }
+ else {
+ $$names_ref{$name} = 1;
+ }
+ return $$pods_ref{$file} = $name;
+}
+
+sub _check_and_extract_name {
+ my ($file, $verbose, $root_rx) = @_;
+
+ # check extension or executable flag
+ # this involves testing the .bat extension on Win32!
+ unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) {
+ return;
+ }
+
+ return unless contains_pod($file,$verbose);
+
+ # strip non-significant path components
+ # TODO what happens on e.g. Win32?
+ my $name = $file;
+ if(defined $root_rx) {
+ $name =~ s/$root_rx//s;
+ $name =~ s/$SIMPLIFY_RX//s if(defined $SIMPLIFY_RX);
+ }
+ else {
+ if ($^O eq 'MacOS') {
+ $name =~ s/^.*://s;
+ } else {
+ $name =~ s{^.*/}{}s;
+ }
+ }
+ _simplify($name);
+ $name =~ s{/+}{::}g;
+ if ($^O eq 'MacOS') {
+ $name =~ s{:+}{::}g; # : -> ::
+ } else {
+ $name =~ s{/+}{::}g; # / -> ::
+ }
+ return $name;
+}
+
+=head2 C<simplify_name( $str )>
+
+The function B<simplify_name> is equivalent to B<basename>, but also
+strips Perl-like extensions (.pm, .pl, .pod) and extensions like
+F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
+
+=cut
+
+# basic simplification of the POD name:
+# basename & strip extension
+sub simplify_name {
+ my ($str) = @_;
+ # remove all path components
+ if ($^O eq 'MacOS') {
+ $str =~ s/^.*://s;
+ } else {
+ $str =~ s{^.*/}{}s;
+ }
+ _simplify($str);
+ return $str;
+}
+
+# internal sub only
+sub _simplify {
+ # strip Perl's own extensions
+ $_[0] =~ s/\.(pod|pm|plx?)\z//i;
+ # strip meaningless extensions on Win32 and OS/2
+ $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i);
+ # strip meaningless extensions on VMS
+ $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS');
+}
+
+# contribution from Tim Jenness <t.jenness@jach.hawaii.edu>
+
+=head2 C<pod_where( { %opts }, $pod )>
+
+Returns the location of a pod document given a search directory
+and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name.
+
+Options:
+
+=over 4
+
+=item C<-inc =E<gt> 1>
+
+Search @INC for the pod and also the C<scriptdir> defined in the
+L<Config|Config> module.
+
+=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]>
+
+Reference to an array of search directories. These are searched in order
+before looking in C<@INC> (if B<-inc>). Current directory is used if
+none are specified.
+
+=item C<-verbose =E<gt> 1>
+
+List directories as they are searched
+
+=back
+
+Returns the full path of the first occurrence to the file.
+Package names (eg 'A::B') are automatically converted to directory
+names in the selected directory. (eg on unix 'A::B' is converted to
+'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the
+search automatically if required.
+
+A subdirectory F<pod/> is also checked if it exists in any of the given
+search directories. This ensures that e.g. L<perlfunc|perlfunc> is
+found.
+
+It is assumed that if a module name is supplied, that that name
+matches the file name. Pods are not opened to check for the 'NAME'
+entry.
+
+A check is made to make sure that the file that is found does
+contain some pod documentation.
+
+=cut
+
+sub pod_where {
+
+ # default options
+ my %options = (
+ '-inc' => 0,
+ '-verbose' => 0,
+ '-dirs' => [ File::Spec->curdir ],
+ );
+
+ # Check for an options hash as first argument
+ if (defined $_[0] && ref($_[0]) eq 'HASH') {
+ my $opt = shift;
+
+ # Merge default options with supplied options
+ %options = (%options, %$opt);
+ }
+
+ # Check usage
+ carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_));
+
+ # Read argument
+ my $pod = shift;
+
+ # Split on :: and then join the name together using File::Spec
+ my @parts = split (/::/, $pod);
+
+ # Get full directory list
+ my @search_dirs = @{ $options{'-dirs'} };
+
+ if ($options{'-inc'}) {
+
+ require Config;
+
+ # Add @INC
+ if ($^O eq 'MacOS' && $options{'-inc'}) {
+ # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
+ my @new_INC = @INC;
+ for (@new_INC) {
+ if ( $_ eq '.' ) {
+ $_ = ':';
+ } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
+ $_ = ':'. $_;
+ } else {
+ $_ =~ s{^\./}{:};
+ }
+ }
+ push (@search_dirs, @new_INC);
+ } elsif ($options{'-inc'}) {
+ push (@search_dirs, @INC);
+ }
+
+ # Add location of pod documentation for perl man pages (eg perlfunc)
+ # This is a pod directory in the private install tree
+ #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
+ # 'pod');
+ #push (@search_dirs, $perlpoddir)
+ # if -d $perlpoddir;
+
+ # Add location of binaries such as pod2text
+ push (@search_dirs, $Config::Config{'scriptdir'})
+ if -d $Config::Config{'scriptdir'};
+ }
+
+ warn 'Search path is: '.join(' ', @search_dirs)."\n"
+ if $options{'-verbose'};
+
+ # Loop over directories
+ Dir: foreach my $dir ( @search_dirs ) {
+
+ # Don't bother if can't find the directory
+ if (-d $dir) {
+ warn "Looking in directory $dir\n"
+ if $options{'-verbose'};
+
+ # Now concatenate this directory with the pod we are searching for
+ my $fullname = File::Spec->catfile($dir, @parts);
+ warn "Filename is now $fullname\n"
+ if $options{'-verbose'};
+
+ # Loop over possible extensions
+ foreach my $ext ('', '.pod', '.pm', '.pl') {
+ my $fullext = $fullname . $ext;
+ if (-f $fullext &&
+ contains_pod($fullext, $options{'-verbose'}) ) {
+ warn "FOUND: $fullext\n" if $options{'-verbose'};
+ return $fullext;
+ }
+ }
+ } else {
+ warn "Directory $dir does not exist\n"
+ if $options{'-verbose'};
+ next Dir;
+ }
+ # for some strange reason the path on MacOS/darwin/cygwin is
+ # 'pods' not 'pod'
+ # this could be the case also for other systems that
+ # have a case-tolerant file system, but File::Spec
+ # does not recognize 'darwin' yet. And cygwin also has "pods",
+ # but is not case tolerant. Oh well...
+ if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i)
+ && -d File::Spec->catdir($dir,'pods')) {
+ $dir = File::Spec->catdir($dir,'pods');
+ redo Dir;
+ }
+ if(-d File::Spec->catdir($dir,'pod')) {
+ $dir = File::Spec->catdir($dir,'pod');
+ redo Dir;
+ }
+ }
+ # No match;
+ return;
+}
+
+=head2 C<contains_pod( $file , $verbose )>
+
+Returns true if the supplied filename (not POD module) contains some pod
+information.
+
+=cut
+
+sub contains_pod {
+ my $file = shift;
+ my $verbose = 0;
+ $verbose = shift if @_;
+
+ # check for one line of POD
+ my $podfh;
+ if ($] < 5.006) {
+ $podfh = gensym();
+ }
+
+ unless(open($podfh,"<$file")) {
+ warn "Error: $file is unreadable: $!\n";
+ return;
+ }
+
+ local $/ = undef;
+ my $pod = <$podfh>;
+ close($podfh) || die "Error closing $file: $!\n";
+ unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) {
+ warn "No POD in $file, skipping.\n"
+ if($verbose);
+ return 0;
+ }
+
+ return 1;
+}
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
+heavily borrowing code from Nick Ing-Simmons' PodToHtml.
+
+Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided
+C<pod_where> and C<contains_pod>.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>, L<Pod::Checker>, L<perldoc>
+
+=cut
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Functions.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Functions.pm
new file mode 100755
index 00000000000..0e250cf0b50
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Functions.pm
@@ -0,0 +1,376 @@
+package Pod::Functions;
+use strict;
+
+=head1 NAME
+
+Pod::Functions - Group Perl's functions a la perlfunc.pod
+
+=head1 SYNOPSIS
+
+ use Pod::Functions;
+
+ my @misc_ops = @{ $Kinds{ 'Misc' } };
+ my $misc_dsc = $Type_Description{ 'Misc' };
+
+or
+
+ perl /path/to/lib/Pod/Functions.pm
+
+This will print a grouped list of Perl's functions, like the
+L<perlfunc/"Perl Functions by Category"> section.
+
+=head1 DESCRIPTION
+
+It exports the following variables:
+
+=over 4
+
+=item %Kinds
+
+This holds a hash-of-lists. Each list contains the functions in the category
+the key denotes.
+
+=item %Type
+
+In this hash each key represents a function and the value is the category.
+The category can be a comma separated list.
+
+=item %Flavor
+
+In this hash each key represents a function and the value is a short
+description of that function.
+
+=item %Type_Description
+
+In this hash each key represents a category of functions and the value is
+a short description of that category.
+
+=item @Type_Order
+
+This list of categories is used to produce the same order as the
+L<perlfunc/"Perl Functions by Category"> section.
+
+=back
+
+=head1 CHANGES
+
+1.02 20020813 <abe@ztreet.demon.nl>
+ de-typo in the SYNOPSIS section (thanks Mike Castle for noticing)
+
+1.01 20011229 <abe@ztreet.demon.nl>
+ fixed some bugs that slipped in after 5.6.1
+ added the pod
+ finished making it strict safe
+
+1.00 ??
+ first numbered version
+
+=cut
+
+our $VERSION = '1.03';
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
+
+our(%Kinds, %Type, %Flavor);
+
+our %Type_Description = (
+ 'ARRAY' => 'Functions for real @ARRAYs',
+ 'Binary' => 'Functions for fixed length data or records',
+ 'File' => 'Functions for filehandles, files, or directories',
+ 'Flow' => 'Keywords related to control flow of your perl program',
+ 'HASH' => 'Functions for real %HASHes',
+ 'I/O' => 'Input and output functions',
+ 'LIST' => 'Functions for list data',
+ 'Math' => 'Numeric functions',
+ 'Misc' => 'Miscellaneous functions',
+ 'Modules' => 'Keywords related to perl modules',
+ 'Network' => 'Fetching network info',
+ 'Objects' => 'Keywords related to classes and object-orientedness',
+ 'Process' => 'Functions for processes and process groups',
+ 'Regexp' => 'Regular expressions and pattern matching',
+ 'Socket' => 'Low-level socket functions',
+ 'String' => 'Functions for SCALARs or strings',
+ 'SysV' => 'System V interprocess communication functions',
+ 'Time' => 'Time-related functions',
+ 'User' => 'Fetching user and group info',
+ 'Namespace' => 'Keywords altering or affecting scoping of identifiers',
+);
+
+our @Type_Order = qw{
+ String
+ Regexp
+ Math
+ ARRAY
+ LIST
+ HASH
+ I/O
+ Binary
+ File
+ Flow
+ Namespace
+ Misc
+ Process
+ Modules
+ Objects
+ Socket
+ SysV
+ User
+ Network
+ Time
+};
+
+while (<DATA>) {
+ chomp;
+ s/#.*//;
+ next unless $_;
+ my($name, $type, $text) = split " ", $_, 3;
+ $Type{$name} = $type;
+ $Flavor{$name} = $text;
+ for my $t ( split /[,\s]+/, $type ) {
+ push @{$Kinds{$t}}, $name;
+ }
+}
+
+close DATA;
+
+my( $typedesc, $list );
+unless (caller) {
+ foreach my $type ( @Type_Order ) {
+ $list = join(", ", sort @{$Kinds{$type}});
+ $typedesc = $Type_Description{$type} . ":";
+ write;
+ }
+}
+
+format =
+
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $typedesc
+~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $typedesc
+ ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $list
+.
+
+1;
+
+__DATA__
+-X File a file test (-r, -x, etc)
+abs Math absolute value function
+accept Socket accept an incoming socket connect
+alarm Process schedule a SIGALRM
+atan2 Math arctangent of Y/X in the range -PI to PI
+bind Socket binds an address to a socket
+binmode I/O prepare binary files for I/O
+bless Objects create an object
+caller Flow,Namespace get context of the current subroutine call
+chdir File change your current working directory
+chmod File changes the permissions on a list of files
+chomp String remove a trailing record separator from a string
+chop String remove the last character from a string
+chown File change the owership on a list of files
+chr String get character this number represents
+chroot File make directory new root for path lookups
+close I/O close file (or pipe or socket) handle
+closedir I/O close directory handle
+connect Socket connect to a remote socket
+continue Flow optional trailing block in a while or foreach
+cos Math cosine function
+crypt String one-way passwd-style encryption
+dbmclose Objects,I/O breaks binding on a tied dbm file
+dbmopen Objects,I/O create binding on a tied dbm file
+defined Misc test whether a value, variable, or function is defined
+delete HASH deletes a value from a hash
+die I/O,Flow raise an exception or bail out
+do Flow,Modules turn a BLOCK into a TERM
+dump Misc,Flow create an immediate core dump
+each HASH retrieve the next key/value pair from a hash
+endgrent User be done using group file
+endhostent User be done using hosts file
+endnetent User be done using networks file
+endprotoent Network be done using protocols file
+endpwent User be done using passwd file
+endservent Network be done using services file
+eof I/O test a filehandle for its end
+eval Flow,Misc catch exceptions or compile and run code
+exec Process abandon this program to run another
+exists HASH test whether a hash key is present
+exit Flow terminate this program
+exp Math raise I<e> to a power
+fcntl File file control system call
+fileno I/O return file descriptor from filehandle
+flock I/O lock an entire file with an advisory lock
+fork Process create a new process just like this one
+format I/O declare a picture format with use by the write() function
+formline Misc internal function used for formats
+getc I/O get the next character from the filehandle
+getgrent User get next group record
+getgrgid User get group record given group user ID
+getgrnam User get group record given group name
+gethostbyaddr Network get host record given its address
+gethostbyname Network get host record given name
+gethostent Network get next hosts record
+getlogin User return who logged in at this tty
+getnetbyaddr Network get network record given its address
+getnetbyname Network get networks record given name
+getnetent Network get next networks record
+getpeername Socket find the other end of a socket connection
+getpgrp Process get process group
+getppid Process get parent process ID
+getpriority Process get current nice value
+getprotobyname Network get protocol record given name
+getprotobynumber Network get protocol record numeric protocol
+getprotoent Network get next protocols record
+getpwent User get next passwd record
+getpwnam User get passwd record given user login name
+getpwuid User get passwd record given user ID
+getservbyname Network get services record given its name
+getservbyport Network get services record given numeric port
+getservent Network get next services record
+getsockname Socket retrieve the sockaddr for a given socket
+getsockopt Socket get socket options on a given socket
+glob File expand filenames using wildcards
+gmtime Time convert UNIX time into record or string using Greenwich time
+goto Flow create spaghetti code
+grep LIST locate elements in a list test true against a given criterion
+hex Math,String convert a string to a hexadecimal number
+import Modules,Namespace patch a module's namespace into your own
+index String find a substring within a string
+int Math get the integer portion of a number
+ioctl File system-dependent device control system call
+join LIST join a list into a string using a separator
+keys HASH retrieve list of indices from a hash
+kill Process send a signal to a process or process group
+last Flow exit a block prematurely
+lc String return lower-case version of a string
+lcfirst String return a string with just the next letter in lower case
+length String return the number of bytes in a string
+link File create a hard link in the filesytem
+listen Socket register your socket as a server
+local Misc,Namespace create a temporary value for a global variable (dynamic scoping)
+localtime Time convert UNIX time into record or string using local time
+lock Threads get a thread lock on a variable, subroutine, or method
+log Math retrieve the natural logarithm for a number
+lstat File stat a symbolic link
+m// Regexp match a string with a regular expression pattern
+map LIST apply a change to a list to get back a new list with the changes
+mkdir File create a directory
+msgctl SysV SysV IPC message control operations
+msgget SysV get SysV IPC message queue
+msgrcv SysV receive a SysV IPC message from a message queue
+msgsnd SysV send a SysV IPC message to a message queue
+my Misc,Namespace declare and assign a local variable (lexical scoping)
+next Flow iterate a block prematurely
+no Modules unimport some module symbols or semantics at compile time
+package Modules,Objects,Namespace declare a separate global namespace
+prototype Flow,Misc get the prototype (if any) of a subroutine
+oct String,Math convert a string to an octal number
+open File open a file, pipe, or descriptor
+opendir File open a directory
+ord String find a character's numeric representation
+our Misc,Namespace declare and assign a package variable (lexical scoping)
+pack Binary,String convert a list into a binary representation
+pipe Process open a pair of connected filehandles
+pop ARRAY remove the last element from an array and return it
+pos Regexp find or set the offset for the last/next m//g search
+print I/O output a list to a filehandle
+printf I/O output a formatted list to a filehandle
+push ARRAY append one or more elements to an array
+q/STRING/ String singly quote a string
+qq/STRING/ String doubly quote a string
+quotemeta Regexp quote regular expression magic characters
+qw/STRING/ LIST quote a list of words
+qx/STRING/ Process backquote quote a string
+qr/STRING/ Regexp Compile pattern
+rand Math retrieve the next pseudorandom number
+read I/O,Binary fixed-length buffered input from a filehandle
+readdir I/O get a directory from a directory handle
+readline I/O fetch a record from a file
+readlink File determine where a symbolic link is pointing
+readpipe Process execute a system command and collect standard output
+recv Socket receive a message over a Socket
+redo Flow start this loop iteration over again
+ref Objects find out the type of thing being referenced
+rename File change a filename
+require Modules load in external functions from a library at runtime
+reset Misc clear all variables of a given name
+return Flow get out of a function early
+reverse String,LIST flip a string or a list
+rewinddir I/O reset directory handle
+rindex String right-to-left substring search
+rmdir File remove a directory
+s/// Regexp replace a pattern with a string
+scalar Misc force a scalar context
+seek I/O reposition file pointer for random-access I/O
+seekdir I/O reposition directory pointer
+select I/O reset default output or do I/O multiplexing
+semctl SysV SysV semaphore control operations
+semget SysV get set of SysV semaphores
+semop SysV SysV semaphore operations
+send Socket send a message over a socket
+setgrent User prepare group file for use
+sethostent Network prepare hosts file for use
+setnetent Network prepare networks file for use
+setpgrp Process set the process group of a process
+setpriority Process set a process's nice value
+setprotoent Network prepare protocols file for use
+setpwent User prepare passwd file for use
+setservent Network prepare services file for use
+setsockopt Socket set some socket options
+shift ARRAY remove the first element of an array, and return it
+shmctl SysV SysV shared memory operations
+shmget SysV get SysV shared memory segment identifier
+shmread SysV read SysV shared memory
+shmwrite SysV write SysV shared memory
+shutdown Socket close down just half of a socket connection
+sin Math return the sine of a number
+sleep Process block for some number of seconds
+socket Socket create a socket
+socketpair Socket create a pair of sockets
+sort LIST sort a list of values
+splice ARRAY add or remove elements anywhere in an array
+split Regexp split up a string using a regexp delimiter
+sprintf String formatted print into a string
+sqrt Math square root function
+srand Math seed the random number generator
+stat File get a file's status information
+study Regexp optimize input data for repeated searches
+sub Flow declare a subroutine, possibly anonymously
+substr String get or alter a portion of a stirng
+symlink File create a symbolic link to a file
+syscall I/O,Binary execute an arbitrary system call
+sysopen File open a file, pipe, or descriptor
+sysread I/O,Binary fixed-length unbuffered input from a filehandle
+sysseek I/O,Binary position I/O pointer on handle used with sysread and syswrite
+system Process run a separate program
+syswrite I/O,Binary fixed-length unbuffered output to a filehandle
+tell I/O get current seekpointer on a filehandle
+telldir I/O get current seekpointer on a directory handle
+tie Objects bind a variable to an object class
+tied Objects get a reference to the object underlying a tied variable
+time Time return number of seconds since 1970
+times Process,Time return elapsed time for self and child processes
+tr/// String transliterate a string
+truncate I/O shorten a file
+uc String return upper-case version of a string
+ucfirst String return a string with just the next letter in upper case
+umask File set file creation mode mask
+undef Misc remove a variable or function definition
+unlink File remove one link to a file
+unpack Binary,LIST convert binary structure into normal perl variables
+unshift ARRAY prepend more elements to the beginning of a list
+untie Objects break a tie binding to a variable
+use Modules,Namespace load a module and import its namespace
+use Objects load in a module at compile time
+utime File set a file's last access and modify times
+values HASH return a list of the values in a hash
+vec Binary test or set particular bits in a string
+wait Process wait for any child process to die
+waitpid Process wait for a particular child process to die
+wantarray Misc,Flow get void vs scalar vs list context of current subroutine call
+warn I/O print debugging info
+write I/O print a picture record
+y/// String transliterate a string
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Html.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Html.pm
new file mode 100755
index 00000000000..99f95a92108
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Html.pm
@@ -0,0 +1,2233 @@
+package Pod::Html;
+use strict;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+$VERSION = 1.09;
+@ISA = qw(Exporter);
+@EXPORT = qw(pod2html htmlify);
+@EXPORT_OK = qw(anchorify);
+
+use Carp;
+use Config;
+use Cwd;
+use File::Spec;
+use File::Spec::Unix;
+use Getopt::Long;
+
+use locale; # make \w work right in non-ASCII lands
+
+=head1 NAME
+
+Pod::Html - module to convert pod files to HTML
+
+=head1 SYNOPSIS
+
+ use Pod::Html;
+ pod2html([options]);
+
+=head1 DESCRIPTION
+
+Converts files from pod format (see L<perlpod>) to HTML format. It
+can automatically generate indexes and cross-references, and it keeps
+a cache of things it knows how to cross-reference.
+
+=head1 FUNCTIONS
+
+=head2 pod2html
+
+ pod2html("pod2html",
+ "--podpath=lib:ext:pod:vms",
+ "--podroot=/usr/src/perl",
+ "--htmlroot=/perl/nmanual",
+ "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
+ "--recurse",
+ "--infile=foo.pod",
+ "--outfile=/perl/nmanual/foo.html");
+
+pod2html takes the following arguments:
+
+=over 4
+
+=item backlink
+
+ --backlink="Back to Top"
+
+Adds "Back to Top" links in front of every C<head1> heading (except for
+the first). By default, no backlinks are generated.
+
+=item cachedir
+
+ --cachedir=name
+
+Creates the item and directory caches in the given directory.
+
+=item css
+
+ --css=stylesheet
+
+Specify the URL of a cascading style sheet. Also disables all HTML/CSS
+C<style> attributes that are output by default (to avoid conflicts).
+
+=item flush
+
+ --flush
+
+Flushes the item and directory caches.
+
+=item header
+
+ --header
+ --noheader
+
+Creates header and footer blocks containing the text of the C<NAME>
+section. By default, no headers are generated.
+
+=item help
+
+ --help
+
+Displays the usage message.
+
+=item hiddendirs
+
+ --hiddendirs
+ --nohiddendirs
+
+Include hidden directories in the search for POD's in podpath if recurse
+is set.
+The default is not to traverse any directory whose name begins with C<.>.
+See L</"podpath"> and L</"recurse">.
+
+[This option is for backward compatibility only.
+It's hard to imagine that one would usefully create a module with a
+name component beginning with C<.>.]
+
+=item htmldir
+
+ --htmldir=name
+
+Sets the directory in which the resulting HTML file is placed. This
+is used to generate relative links to other files. Not passing this
+causes all links to be absolute, since this is the value that tells
+Pod::Html the root of the documentation tree.
+
+=item htmlroot
+
+ --htmlroot=name
+
+Sets the base URL for the HTML files. When cross-references are made,
+the HTML root is prepended to the URL.
+
+=item index
+
+ --index
+ --noindex
+
+Generate an index at the top of the HTML file. This is the default
+behaviour.
+
+=item infile
+
+ --infile=name
+
+Specify the pod file to convert. Input is taken from STDIN if no
+infile is specified.
+
+=item libpods
+
+ --libpods=name:...:name
+
+List of page names (eg, "perlfunc") which contain linkable C<=item>s.
+
+=item netscape
+
+ --netscape
+ --nonetscape
+
+B<Deprecated>, has no effect. For backwards compatibility only.
+
+=item outfile
+
+ --outfile=name
+
+Specify the HTML file to create. Output goes to STDOUT if no outfile
+is specified.
+
+=item podpath
+
+ --podpath=name:...:name
+
+Specify which subdirectories of the podroot contain pod files whose
+HTML converted forms can be linked to in cross references.
+
+=item podroot
+
+ --podroot=name
+
+Specify the base directory for finding library pods.
+
+=item quiet
+
+ --quiet
+ --noquiet
+
+Don't display I<mostly harmless> warning messages. These messages
+will be displayed by default. But this is not the same as C<verbose>
+mode.
+
+=item recurse
+
+ --recurse
+ --norecurse
+
+Recurse into subdirectories specified in podpath (default behaviour).
+
+=item title
+
+ --title=title
+
+Specify the title of the resulting HTML file.
+
+=item verbose
+
+ --verbose
+ --noverbose
+
+Display progress messages. By default, they won't be displayed.
+
+=back
+
+=head2 htmlify
+
+ htmlify($heading);
+
+Converts a pod section specification to a suitable section specification
+for HTML. Note that we keep spaces and special characters except
+C<", ?> (Netscape problem) and the hyphen (writer's problem...).
+
+=head2 anchorify
+
+ anchorify(@heading);
+
+Similar to C<htmlify()>, but turns non-alphanumerics into underscores. Note
+that C<anchorify()> is not exported by default.
+
+=head1 ENVIRONMENT
+
+Uses C<$Config{pod2html}> to setup default options.
+
+=head1 AUTHOR
+
+Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
+
+=head1 SEE ALSO
+
+L<perlpod>
+
+=head1 COPYRIGHT
+
+This program is distributed under the Artistic License.
+
+=cut
+
+my($Cachedir);
+my($Dircache, $Itemcache);
+my @Begin_Stack;
+my @Libpods;
+my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
+my($Podfile, @Podpath, $Podroot);
+my $Css;
+
+my $Recurse;
+my $Quiet;
+my $HiddenDirs;
+my $Verbose;
+my $Doindex;
+
+my $Backlink;
+my($Listlevel, @Listtype);
+my $ListNewTerm;
+use vars qw($Ignore); # need to localize it later.
+
+my(%Items_Named, @Items_Seen);
+my($Title, $Header);
+
+my $Top;
+my $Paragraph;
+
+my %Sections;
+
+# Caches
+my %Pages = (); # associative array used to find the location
+ # of pages referenced by L<> links.
+my %Items = (); # associative array used to find the location
+ # of =item directives referenced by C<> links
+
+my %Local_Items;
+my $Is83;
+
+my $Curdir = File::Spec->curdir;
+
+init_globals();
+
+sub init_globals {
+ $Cachedir = "."; # The directory to which item and directory
+ # caches will be written.
+
+ $Dircache = "pod2htmd.tmp";
+ $Itemcache = "pod2htmi.tmp";
+
+ @Begin_Stack = (); # begin/end stack
+
+ @Libpods = (); # files to search for links from C<> directives
+ $Htmlroot = "/"; # http-server base directory from which all
+ # relative paths in $podpath stem.
+ $Htmldir = ""; # The directory to which the html pages
+ # will (eventually) be written.
+ $Htmlfile = ""; # write to stdout by default
+ $Htmlfileurl = ""; # The url that other files would use to
+ # refer to this file. This is only used
+ # to make relative urls that point to
+ # other files.
+
+ $Podfile = ""; # read from stdin by default
+ @Podpath = (); # list of directories containing library pods.
+ $Podroot = $Curdir; # filesystem base directory from which all
+ # relative paths in $podpath stem.
+ $Css = ''; # Cascading style sheet
+ $Recurse = 1; # recurse on subdirectories in $podpath.
+ $Quiet = 0; # not quiet by default
+ $Verbose = 0; # not verbose by default
+ $Doindex = 1; # non-zero if we should generate an index
+ $Backlink = ''; # text for "back to top" links
+ $Listlevel = 0; # current list depth
+ @Listtype = (); # list types for open lists
+ $ListNewTerm = 0; # indicates new term in definition list; used
+ # to correctly open/close <dd> tags
+ $Ignore = 1; # whether or not to format text. we don't
+ # format text until we hit our first pod
+ # directive.
+
+ @Items_Seen = (); # for multiples of the same item in perlfunc
+ %Items_Named = ();
+ $Header = 0; # produce block header/footer
+ $Title = ''; # title to give the pod(s)
+ $Top = 1; # true if we are at the top of the doc. used
+ # to prevent the first <hr /> directive.
+ $Paragraph = ''; # which paragraph we're processing (used
+ # for error messages)
+ %Sections = (); # sections within this page
+
+ %Local_Items = ();
+ $Is83 = $^O eq 'dos'; # Is it an 8.3 filesystem?
+}
+
+#
+# clean_data: global clean-up of pod data
+#
+sub clean_data($){
+ my( $dataref ) = @_;
+ for my $i ( 0..$#{$dataref} ) {
+ ${$dataref}[$i] =~ s/\s+\Z//;
+
+ # have a look for all-space lines
+ if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
+ my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
+ splice( @$dataref, $i, 1, @chunks );
+ }
+ }
+}
+
+
+sub pod2html {
+ local(@ARGV) = @_;
+ local($/);
+ local $_;
+
+ init_globals();
+
+ $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
+
+ # cache of %Pages and %Items from last time we ran pod2html
+
+ #undef $opt_help if defined $opt_help;
+
+ # parse the command-line parameters
+ parse_command_line();
+
+ # escape the backlink argument (same goes for title but is done later...)
+ $Backlink = html_escape($Backlink) if defined $Backlink;
+
+ # set some variables to their default values if necessary
+ local *POD;
+ unless (@ARGV && $ARGV[0]) {
+ $Podfile = "-" unless $Podfile; # stdin
+ open(POD, "<$Podfile")
+ || die "$0: cannot open $Podfile file for input: $!\n";
+ } else {
+ $Podfile = $ARGV[0]; # XXX: might be more filenames
+ *POD = *ARGV;
+ }
+ $Htmlfile = "-" unless $Htmlfile; # stdout
+ $Htmlroot = "" if $Htmlroot eq "/"; # so we don't get a //
+ $Htmldir =~ s#/\z## ; # so we don't get a //
+ if ( $Htmlroot eq ''
+ && defined( $Htmldir )
+ && $Htmldir ne ''
+ && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
+ )
+ {
+ # Set the 'base' url for this file, so that we can use it
+ # as the location from which to calculate relative links
+ # to other files. If this is '', then absolute links will
+ # be used throughout.
+ $Htmlfileurl= "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
+ }
+
+ # read the pod a paragraph at a time
+ warn "Scanning for sections in input file(s)\n" if $Verbose;
+ $/ = "";
+ my @poddata = <POD>;
+ close(POD);
+
+ # be eol agnostic
+ for (@poddata) {
+ if (/\r/) {
+ if (/\r\n/) {
+ @poddata = map { s/\r\n/\n/g;
+ /\n\n/ ?
+ map { "$_\n\n" } split /\n\n/ :
+ $_ } @poddata;
+ } else {
+ @poddata = map { s/\r/\n/g;
+ /\n\n/ ?
+ map { "$_\n\n" } split /\n\n/ :
+ $_ } @poddata;
+ }
+ last;
+ }
+ }
+
+ clean_data( \@poddata );
+
+ # scan the pod for =head[1-6] directives and build an index
+ my $index = scan_headings(\%Sections, @poddata);
+
+ unless($index) {
+ warn "No headings in $Podfile\n" if $Verbose;
+ }
+
+ # open the output file
+ open(HTML, ">$Htmlfile")
+ || die "$0: cannot open $Htmlfile file for output: $!\n";
+
+ # put a title in the HTML file if one wasn't specified
+ if ($Title eq '') {
+ TITLE_SEARCH: {
+ for (my $i = 0; $i < @poddata; $i++) {
+ if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
+ for my $para ( @poddata[$i, $i+1] ) {
+ last TITLE_SEARCH
+ if ($Title) = $para =~ /(\S+\s+-+.*\S)/s;
+ }
+ }
+
+ }
+ }
+ }
+ if (!$Title and $Podfile =~ /\.pod\z/) {
+ # probably a split pod so take first =head[12] as title
+ for (my $i = 0; $i < @poddata; $i++) {
+ last if ($Title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
+ }
+ warn "adopted '$Title' as title for $Podfile\n"
+ if $Verbose and $Title;
+ }
+ if ($Title) {
+ $Title =~ s/\s*\(.*\)//;
+ } else {
+ warn "$0: no title for $Podfile.\n" unless $Quiet;
+ $Podfile =~ /^(.*)(\.[^.\/]+)?\z/s;
+ $Title = ($Podfile eq "-" ? 'No Title' : $1);
+ warn "using $Title" if $Verbose;
+ }
+ $Title = html_escape($Title);
+
+ my $csslink = '';
+ my $bodystyle = ' style="background-color: white"';
+ my $tdstyle = ' style="background-color: #cccccc"';
+
+ if ($Css) {
+ $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
+ $csslink =~ s,\\,/,g;
+ $csslink =~ s,(/.):,$1|,;
+ $bodystyle = '';
+ $tdstyle = '';
+ }
+
+ my $block = $Header ? <<END_OF_BLOCK : '';
+<table border="0" width="100%" cellspacing="0" cellpadding="3">
+<tr><td class="block"$tdstyle valign="middle">
+<big><strong><span class="block">&nbsp;$Title</span></strong></big>
+</td></tr>
+</table>
+END_OF_BLOCK
+
+ print HTML <<END_OF_HEAD;
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>$Title</title>$csslink
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:$Config{perladmin}" />
+</head>
+
+<body$bodystyle>
+$block
+END_OF_HEAD
+
+ # load/reload/validate/cache %Pages and %Items
+ get_cache($Dircache, $Itemcache, \@Podpath, $Podroot, $Recurse);
+
+ # scan the pod for =item directives
+ scan_items( \%Local_Items, "", @poddata);
+
+ # put an index at the top of the file. note, if $Doindex is 0 we
+ # still generate an index, but surround it with an html comment.
+ # that way some other program can extract it if desired.
+ $index =~ s/--+/-/g;
+
+ my $hr = ($Doindex and $index) ? qq(<hr name="index" />) : "";
+
+ unless ($Doindex)
+ {
+ $index = qq(<!--\n$index\n-->\n);
+ }
+
+ print HTML << "END_OF_INDEX";
+
+<!-- INDEX BEGIN -->
+<div name="index">
+<p><a name=\"__index__\"></a></p>
+$index
+$hr
+</div>
+<!-- INDEX END -->
+
+END_OF_INDEX
+
+ # now convert this file
+ my $after_item; # set to true after an =item
+ warn "Converting input file $Podfile\n" if $Verbose;
+ foreach my $i (0..$#poddata){
+ $_ = $poddata[$i];
+ $Paragraph = $i+1;
+ if (/^(=.*)/s) { # is it a pod directive?
+ $Ignore = 0;
+ $after_item = 0;
+ $_ = $1;
+ if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
+ process_begin($1, $2);
+ } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
+ process_end($1, $2);
+ } elsif (/^=cut/) { # =cut
+ process_cut();
+ } elsif (/^=pod/) { # =pod
+ process_pod();
+ } else {
+ next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
+
+ if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
+ process_head( $1, $2, $Doindex && $index );
+ } elsif (/^=item\s*(.*\S)?/sm) { # =item text
+ process_item( $1 );
+ $after_item = 1;
+ } elsif (/^=over\s*(.*)/) { # =over N
+ process_over();
+ } elsif (/^=back/) { # =back
+ process_back();
+ } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for
+ process_for($1,$2);
+ } else {
+ /^=(\S*)\s*/;
+ warn "$0: $Podfile: unknown pod directive '$1' in "
+ . "paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ }
+ }
+ $Top = 0;
+ }
+ else {
+ next if $Ignore;
+ next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
+ print HTML and next if @Begin_Stack && $Begin_Stack[-1] eq 'html';
+ my $text = $_;
+
+ # Open tag for definition list as we have something to put in it
+ if( $ListNewTerm ){
+ print HTML "<dd>\n";
+ $ListNewTerm = 0;
+ }
+
+ if( $text =~ /\A\s+/ ){
+ process_pre( \$text );
+ print HTML "<pre>\n$text</pre>\n";
+
+ } else {
+ process_text( \$text );
+
+ # experimental: check for a paragraph where all lines
+ # have some ...\t...\t...\n pattern
+ if( $text =~ /\t/ ){
+ my @lines = split( "\n", $text );
+ if( @lines > 1 ){
+ my $all = 2;
+ foreach my $line ( @lines ){
+ if( $line =~ /\S/ && $line !~ /\t/ ){
+ $all--;
+ last if $all == 0;
+ }
+ }
+ if( $all > 0 ){
+ $text =~ s/\t+/<td>/g;
+ $text =~ s/^/<tr><td>/gm;
+ $text = '<table cellspacing="0" cellpadding="0">' .
+ $text . '</table>';
+ }
+ }
+ }
+ ## end of experimental
+
+ print HTML "<p>$text</p>\n";
+ }
+ $after_item = 0;
+ }
+ }
+
+ # finish off any pending directives
+ finish_list();
+
+ # link to page index
+ print HTML "<p><a href=\"#__index__\"><small>$Backlink</small></a></p>\n"
+ if $Doindex and $index and $Backlink;
+
+ print HTML <<END_OF_TAIL;
+$block
+</body>
+
+</html>
+END_OF_TAIL
+
+ # close the html file
+ close(HTML);
+
+ warn "Finished\n" if $Verbose;
+}
+
+##############################################################################
+
+sub usage {
+ my $podfile = shift;
+ warn "$0: $podfile: @_\n" if @_;
+ die <<END_OF_USAGE;
+Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
+ --podpath=<name>:...:<name> --podroot=<name>
+ --libpods=<name>:...:<name> --recurse --verbose --index
+ --netscape --norecurse --noindex --cachedir=<name>
+
+ --backlink - set text for "back to top" links (default: none).
+ --cachedir - directory for the item and directory cache files.
+ --css - stylesheet URL
+ --flush - flushes the item and directory caches.
+ --[no]header - produce block header/footer (default is no headers).
+ --help - prints this message.
+ --hiddendirs - search hidden directories in podpath
+ --htmldir - directory for resulting HTML files.
+ --htmlroot - http-server base directory from which all relative paths
+ in podpath stem (default is /).
+ --[no]index - generate an index at the top of the resulting html
+ (default behaviour).
+ --infile - filename for the pod to convert (input taken from stdin
+ by default).
+ --libpods - colon-separated list of pages to search for =item pod
+ directives in as targets of C<> and implicit links (empty
+ by default). note, these are not filenames, but rather
+ page names like those that appear in L<> links.
+ --outfile - filename for the resulting html file (output sent to
+ stdout by default).
+ --podpath - colon-separated list of directories containing library
+ pods (empty by default).
+ --podroot - filesystem base directory from which all relative paths
+ in podpath stem (default is .).
+ --[no]quiet - suppress some benign warning messages (default is off).
+ --[no]recurse - recurse on those subdirectories listed in podpath
+ (default behaviour).
+ --title - title that will appear in resulting html file.
+ --[no]verbose - self-explanatory (off by default).
+ --[no]netscape - deprecated, has no effect. for backwards compatibility only.
+
+END_OF_USAGE
+
+}
+
+sub parse_command_line {
+ my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
+ $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
+ $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
+ $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs);
+
+ unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
+ my $result = GetOptions(
+ 'backlink=s' => \$opt_backlink,
+ 'cachedir=s' => \$opt_cachedir,
+ 'css=s' => \$opt_css,
+ 'flush' => \$opt_flush,
+ 'header!' => \$opt_header,
+ 'help' => \$opt_help,
+ 'hiddendirs!'=> \$opt_hiddendirs,
+ 'htmldir=s' => \$opt_htmldir,
+ 'htmlroot=s' => \$opt_htmlroot,
+ 'index!' => \$opt_index,
+ 'infile=s' => \$opt_infile,
+ 'libpods=s' => \$opt_libpods,
+ 'netscape!' => \$opt_netscape,
+ 'outfile=s' => \$opt_outfile,
+ 'podpath=s' => \$opt_podpath,
+ 'podroot=s' => \$opt_podroot,
+ 'quiet!' => \$opt_quiet,
+ 'recurse!' => \$opt_recurse,
+ 'title=s' => \$opt_title,
+ 'verbose!' => \$opt_verbose,
+ );
+ usage("-", "invalid parameters") if not $result;
+
+ usage("-") if defined $opt_help; # see if the user asked for help
+ $opt_help = ""; # just to make -w shut-up.
+
+ @Podpath = split(":", $opt_podpath) if defined $opt_podpath;
+ @Libpods = split(":", $opt_libpods) if defined $opt_libpods;
+
+ $Backlink = $opt_backlink if defined $opt_backlink;
+ $Cachedir = $opt_cachedir if defined $opt_cachedir;
+ $Css = $opt_css if defined $opt_css;
+ $Header = $opt_header if defined $opt_header;
+ $Htmldir = $opt_htmldir if defined $opt_htmldir;
+ $Htmlroot = $opt_htmlroot if defined $opt_htmlroot;
+ $Doindex = $opt_index if defined $opt_index;
+ $Podfile = $opt_infile if defined $opt_infile;
+ $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs;
+ $Htmlfile = $opt_outfile if defined $opt_outfile;
+ $Podroot = $opt_podroot if defined $opt_podroot;
+ $Quiet = $opt_quiet if defined $opt_quiet;
+ $Recurse = $opt_recurse if defined $opt_recurse;
+ $Title = $opt_title if defined $opt_title;
+ $Verbose = $opt_verbose if defined $opt_verbose;
+
+ warn "Flushing item and directory caches\n"
+ if $opt_verbose && defined $opt_flush;
+ $Dircache = "$Cachedir/pod2htmd.tmp";
+ $Itemcache = "$Cachedir/pod2htmi.tmp";
+ if (defined $opt_flush) {
+ 1 while unlink($Dircache, $Itemcache);
+ }
+}
+
+
+my $Saved_Cache_Key;
+
+sub get_cache {
+ my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
+ my @cache_key_args = @_;
+
+ # A first-level cache:
+ # Don't bother reading the cache files if they still apply
+ # and haven't changed since we last read them.
+
+ my $this_cache_key = cache_key(@cache_key_args);
+
+ return if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
+
+ # load the cache of %Pages and %Items if possible. $tests will be
+ # non-zero if successful.
+ my $tests = 0;
+ if (-f $dircache && -f $itemcache) {
+ warn "scanning for item cache\n" if $Verbose;
+ $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
+ }
+
+ # if we didn't succeed in loading the cache then we must (re)build
+ # %Pages and %Items.
+ if (!$tests) {
+ warn "scanning directories in pod-path\n" if $Verbose;
+ scan_podpath($podroot, $recurse, 0);
+ }
+ $Saved_Cache_Key = cache_key(@cache_key_args);
+}
+
+sub cache_key {
+ my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
+ return join('!', $dircache, $itemcache, $recurse,
+ @$podpath, $podroot, stat($dircache), stat($itemcache));
+}
+
+#
+# load_cache - tries to find if the caches stored in $dircache and $itemcache
+# are valid caches of %Pages and %Items. if they are valid then it loads
+# them and returns a non-zero value.
+#
+sub load_cache {
+ my($dircache, $itemcache, $podpath, $podroot) = @_;
+ my($tests);
+ local $_;
+
+ $tests = 0;
+
+ open(CACHE, "<$itemcache") ||
+ die "$0: error opening $itemcache for reading: $!\n";
+ $/ = "\n";
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @$podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+ return 0;
+ }
+
+ warn "loading item cache\n" if $Verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $Items{$1} = $2;
+ }
+ close(CACHE);
+
+ warn "scanning for directory cache\n" if $Verbose;
+ open(CACHE, "<$dircache") ||
+ die "$0: error opening $dircache for reading: $!\n";
+ $/ = "\n";
+ $tests = 0;
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @$podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+ return 0;
+ }
+
+ warn "loading directory cache\n" if $Verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $Pages{$1} = $2;
+ }
+
+ close(CACHE);
+
+ return 1;
+}
+
+#
+# scan_podpath - scans the directories specified in @podpath for directories,
+# .pod files, and .pm files. it also scans the pod files specified in
+# @Libpods for =item directives.
+#
+sub scan_podpath {
+ my($podroot, $recurse, $append) = @_;
+ my($pwd, $dir);
+ my($libpod, $dirname, $pod, @files, @poddata);
+
+ unless($append) {
+ %Items = ();
+ %Pages = ();
+ }
+
+ # scan each directory listed in @Podpath
+ $pwd = getcwd();
+ chdir($podroot)
+ || die "$0: error changing to directory $podroot: $!\n";
+ foreach $dir (@Podpath) {
+ scan_dir($dir, $recurse);
+ }
+
+ # scan the pods listed in @Libpods for =item directives
+ foreach $libpod (@Libpods) {
+ # if the page isn't defined then we won't know where to find it
+ # on the system.
+ next unless defined $Pages{$libpod} && $Pages{$libpod};
+
+ # if there is a directory then use the .pod and .pm files within it.
+ # NOTE: Only finds the first so-named directory in the tree.
+# if ($Pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ if ($Pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
+ # find all the .pod and .pm files within the directory
+ $dirname = $1;
+ opendir(DIR, $dirname) ||
+ die "$0: error opening directory $dirname: $!\n";
+ @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
+ closedir(DIR);
+
+ # scan each .pod and .pm file for =item directives
+ foreach $pod (@files) {
+ open(POD, "<$dirname/$pod") ||
+ die "$0: error opening $dirname/$pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+ clean_data( \@poddata );
+
+ scan_items( \%Items, "$dirname/$pod", @poddata);
+ }
+
+ # use the names of files as =item directives too.
+### Don't think this should be done this way - confuses issues.(WL)
+### foreach $pod (@files) {
+### $pod =~ /^(.*)(\.pod|\.pm)$/;
+### $Items{$1} = "$dirname/$1.html" if $1;
+### }
+ } elsif ($Pages{$libpod} =~ /([^:]*\.pod):/ ||
+ $Pages{$libpod} =~ /([^:]*\.pm):/) {
+ # scan the .pod or .pm file for =item directives
+ $pod = $1;
+ open(POD, "<$pod") ||
+ die "$0: error opening $pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+ clean_data( \@poddata );
+
+ scan_items( \%Items, "$pod", @poddata);
+ } else {
+ warn "$0: shouldn't be here (line ".__LINE__."\n" unless $Quiet;
+ }
+ }
+ @poddata = (); # clean-up a bit
+
+ chdir($pwd)
+ || die "$0: error changing to directory $pwd: $!\n";
+
+ # cache the item list for later use
+ warn "caching items for later use\n" if $Verbose;
+ open(CACHE, ">$Itemcache") ||
+ die "$0: error open $Itemcache for writing: $!\n";
+
+ print CACHE join(":", @Podpath) . "\n$podroot\n";
+ foreach my $key (keys %Items) {
+ print CACHE "$key $Items{$key}\n";
+ }
+
+ close(CACHE);
+
+ # cache the directory list for later use
+ warn "caching directories for later use\n" if $Verbose;
+ open(CACHE, ">$Dircache") ||
+ die "$0: error open $Dircache for writing: $!\n";
+
+ print CACHE join(":", @Podpath) . "\n$podroot\n";
+ foreach my $key (keys %Pages) {
+ print CACHE "$key $Pages{$key}\n";
+ }
+
+ close(CACHE);
+}
+
+#
+# scan_dir - scans the directory specified in $dir for subdirectories, .pod
+# files, and .pm files. notes those that it finds. this information will
+# be used later in order to figure out where the pages specified in L<>
+# links are on the filesystem.
+#
+sub scan_dir {
+ my($dir, $recurse) = @_;
+ my($t, @subdirs, @pods, $pod, $dirname, @dirs);
+ local $_;
+
+ @subdirs = ();
+ @pods = ();
+
+ opendir(DIR, $dir) ||
+ die "$0: error opening directory $dir: $!\n";
+ while (defined($_ = readdir(DIR))) {
+ if (-d "$dir/$_" && $_ ne "." && $_ ne ".."
+ && ($HiddenDirs || !/^\./)
+ ) { # directory
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_:";
+ push(@subdirs, $_);
+ } elsif (/\.pod\z/) { # .pod
+ s/\.pod\z//;
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pod:";
+ push(@pods, "$dir/$_.pod");
+ } elsif (/\.html\z/) { # .html
+ s/\.html\z//;
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pod:";
+ } elsif (/\.pm\z/) { # .pm
+ s/\.pm\z//;
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pm:";
+ push(@pods, "$dir/$_.pm");
+ } elsif (-T "$dir/$_") { # script(?)
+ local *F;
+ if (open(F, "$dir/$_")) {
+ my $line;
+ while (defined($line = <F>)) {
+ if ($line =~ /^=(?:pod|head1)/) {
+ $Pages{$_} = "" unless defined $Pages{$_};
+ $Pages{$_} .= "$dir/$_.pod:";
+ last;
+ }
+ }
+ close(F);
+ }
+ }
+ }
+ closedir(DIR);
+
+ # recurse on the subdirectories if necessary
+ if ($recurse) {
+ foreach my $subdir (@subdirs) {
+ scan_dir("$dir/$subdir", $recurse);
+ }
+ }
+}
+
+#
+# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
+# build an index.
+#
+sub scan_headings {
+ my($sections, @data) = @_;
+ my($tag, $which_head, $otitle, $listdepth, $index);
+
+ local $Ignore = 0;
+
+ $listdepth = 0;
+ $index = "";
+
+ # scan for =head directives, note their name, and build an index
+ # pointing to each of them.
+ foreach my $line (@data) {
+ if ($line =~ /^=(head)([1-6])\s+(.*)/) {
+ ($tag, $which_head, $otitle) = ($1,$2,$3);
+
+ my $title = depod( $otitle );
+ my $name = anchorify( $title );
+ $$sections{$name} = 1;
+ $title = process_text( \$otitle );
+
+ while ($which_head != $listdepth) {
+ if ($which_head > $listdepth) {
+ $index .= "\n" . ("\t" x $listdepth) . "<ul>\n";
+ $listdepth++;
+ } elsif ($which_head < $listdepth) {
+ $listdepth--;
+ $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
+ }
+ }
+
+ $index .= "\n" . ("\t" x $listdepth) . "<li>" .
+ "<a href=\"#" . $name . "\">" .
+ $title . "</a></li>";
+ }
+ }
+
+ # finish off the lists
+ while ($listdepth--) {
+ $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
+ }
+
+ # get rid of bogus lists
+ $index =~ s,\t*<ul>\s*</ul>\n,,g;
+
+ return $index;
+}
+
+#
+# scan_items - scans the pod specified by $pod for =item directives. we
+# will use this information later on in resolving C<> links.
+#
+sub scan_items {
+ my( $itemref, $pod, @poddata ) = @_;
+ my($i, $item);
+ local $_;
+
+ $pod =~ s/\.pod\z//;
+ $pod .= ".html" if $pod;
+
+ foreach $i (0..$#poddata) {
+ my $txt = depod( $poddata[$i] );
+
+ # figure out what kind of item it is.
+ # Build string for referencing this item.
+ if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bulleted list
+ next unless $1;
+ $item = $1;
+ } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
+ $item = $1;
+ } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # definition list
+ $item = $1;
+ } else {
+ next;
+ }
+ my $fid = fragment_id( $item );
+ $$itemref{$fid} = "$pod" if $fid;
+ }
+}
+
+#
+# process_head - convert a pod head[1-6] tag and convert it to HTML format.
+#
+sub process_head {
+ my($tag, $heading, $hasindex) = @_;
+
+ # figure out the level of the =head
+ $tag =~ /head([1-6])/;
+ my $level = $1;
+
+ finish_list();
+
+ print HTML "<p>\n";
+ if( $level == 1 && ! $Top ){
+ print HTML "<a href=\"#__index__\"><small>$Backlink</small></a>\n"
+ if $hasindex and $Backlink;
+ print HTML "</p>\n<hr />\n"
+ } else {
+ print HTML "</p>\n";
+ }
+
+ my $name = anchorify( depod( $heading ) );
+ my $convert = process_text( \$heading );
+ print HTML "<h$level><a name=\"$name\">$convert</a></h$level>\n";
+}
+
+
+#
+# emit_item_tag - print an =item's text
+# Note: The global $EmittedItem is used for inhibiting self-references.
+#
+my $EmittedItem;
+
+sub emit_item_tag($$$){
+ my( $otext, $text, $compact ) = @_;
+ my $item = fragment_id( depod($text) , -generate);
+ Carp::confess("Undefined fragment '$text' (".depod($text).") from fragment_id() in emit_item_tag() in $Podfile")
+ if !defined $item;
+ $EmittedItem = $item;
+ ### print STDERR "emit_item_tag=$item ($text)\n";
+
+ print HTML '<strong>';
+ if ($Items_Named{$item}++) {
+ print HTML process_text( \$otext );
+ } else {
+ my $name = $item;
+ $name = anchorify($name);
+ print HTML qq{<a name="$name" class="item">}, process_text( \$otext ), '</a>';
+ }
+ print HTML "</strong>";
+ undef( $EmittedItem );
+}
+
+sub new_listitem {
+ my( $tag ) = @_;
+ # Open tag for definition list as we have something to put in it
+ if( ($tag ne 'dl') && ($ListNewTerm) ){
+ print HTML "<dd>\n";
+ $ListNewTerm = 0;
+ }
+
+ if( $Items_Seen[$Listlevel]++ == 0 ){
+ # start of new list
+ push( @Listtype, "$tag" );
+ print HTML "<$tag>\n";
+ } else {
+ # if this is not the first item, close the previous one
+ if ( $tag eq 'dl' ){
+ print HTML "</dd>\n" unless $ListNewTerm;
+ } else {
+ print HTML "</li>\n";
+ }
+ }
+ my $opentag = $tag eq 'dl' ? 'dt' : 'li';
+ print HTML "<$opentag>";
+}
+
+#
+# process_item - convert a pod item tag and convert it to HTML format.
+#
+sub process_item {
+ my( $otext ) = @_;
+
+ # lots of documents start a list without doing an =over. this is
+ # bad! but, the proper thing to do seems to be to just assume
+ # they did do an =over. so warn them once and then continue.
+ if( $Listlevel == 0 ){
+ warn "$0: $Podfile: unexpected =item directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ process_over();
+ }
+
+ # remove formatting instructions from the text
+ my $text = depod( $otext );
+
+ # all the list variants:
+ if( $text =~ /\A\*/ ){ # bullet
+ new_listitem( 'ul' );
+ if ($text =~ /\A\*\s+(\S.*)\Z/s ) { # with additional text
+ my $tag = $1;
+ $otext =~ s/\A\*\s+//;
+ emit_item_tag( $otext, $tag, 1 );
+ print HTML "\n";
+ }
+
+ } elsif( $text =~ /\A\d+/ ){ # numbered list
+ new_listitem( 'ol' );
+ if ($text =~ /\A(?>\d+\.?)\s*(\S.*)\Z/s ) { # with additional text
+ my $tag = $1;
+ $otext =~ s/\A\d+\.?\s*//;
+ emit_item_tag( $otext, $tag, 1 );
+ print HTML "\n";
+ }
+
+ } else { # definition list
+ # new_listitem takes care of opening the <dt> tag
+ new_listitem( 'dl' );
+ if ($text =~ /\A(.+)\Z/s ){ # should have text
+ emit_item_tag( $otext, $text, 1 );
+ # write the definition term and close <dt> tag
+ print HTML "</dt>\n";
+ }
+ # trigger opening a <dd> tag for the actual definition; will not
+ # happen if next paragraph is also a definition term (=item)
+ $ListNewTerm = 1;
+ }
+ print HTML "\n";
+}
+
+#
+# process_over - process a pod over tag and start a corresponding HTML list.
+#
+sub process_over {
+ # start a new list
+ $Listlevel++;
+ push( @Items_Seen, 0 );
+}
+
+#
+# process_back - process a pod back tag and convert it to HTML format.
+#
+sub process_back {
+ if( $Listlevel == 0 ){
+ warn "$0: $Podfile: unexpected =back directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ return;
+ }
+
+ # close off the list. note, I check to see if $Listtype[$Listlevel] is
+ # defined because an =item directive may have never appeared and thus
+ # $Listtype[$Listlevel] may have never been initialized.
+ $Listlevel--;
+ if( defined $Listtype[$Listlevel] ){
+ if ( $Listtype[$Listlevel] eq 'dl' ){
+ print HTML "</dd>\n" unless $ListNewTerm;
+ } else {
+ print HTML "</li>\n";
+ }
+ print HTML "</$Listtype[$Listlevel]>\n";
+ pop( @Listtype );
+ $ListNewTerm = 0;
+ }
+
+ # clean up item count
+ pop( @Items_Seen );
+}
+
+#
+# process_cut - process a pod cut tag, thus start ignoring pod directives.
+#
+sub process_cut {
+ $Ignore = 1;
+}
+
+#
+# process_pod - process a pod tag, thus stop ignoring pod directives
+# until we see a corresponding cut.
+#
+sub process_pod {
+ # no need to set $Ignore to 0 cause the main loop did it
+}
+
+#
+# process_for - process a =for pod tag. if it's for html, spit
+# it out verbatim, if illustration, center it, otherwise ignore it.
+#
+sub process_for {
+ my($whom, $text) = @_;
+ if ( $whom =~ /^(pod2)?html$/i) {
+ print HTML $text;
+ } elsif ($whom =~ /^illustration$/i) {
+ 1 while chomp $text;
+ for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
+ $text .= $ext, last if -r "$text$ext";
+ }
+ print HTML qq{<p align="center"><img src="$text" alt="$text illustration" /></p>};
+ }
+}
+
+#
+# process_begin - process a =begin pod tag. this pushes
+# whom we're beginning on the begin stack. if there's a
+# begin stack, we only print if it us.
+#
+sub process_begin {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ push (@Begin_Stack, $whom);
+ if ( $whom =~ /^(pod2)?html$/) {
+ print HTML $text if $text;
+ }
+}
+
+#
+# process_end - process a =end pod tag. pop the
+# begin stack. die if we're mismatched.
+#
+sub process_end {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ if (!defined $Begin_Stack[-1] or $Begin_Stack[-1] ne $whom ) {
+ Carp::confess("Unmatched begin/end at chunk $Paragraph in pod $Podfile\n")
+ }
+ pop( @Begin_Stack );
+}
+
+#
+# process_pre - indented paragraph, made into <pre></pre>
+#
+sub process_pre {
+ my( $text ) = @_;
+ my( $rest );
+ return if $Ignore;
+
+ $rest = $$text;
+
+ # insert spaces in place of tabs
+ $rest =~ s#(.+)#
+ my $line = $1;
+ 1 while $line =~ s/(\t+)/' ' x ((length($1) * 8) - $-[0] % 8)/e;
+ $line;
+ #eg;
+
+ # convert some special chars to HTML escapes
+ $rest = html_escape($rest);
+
+ # try and create links for all occurrences of perl.* within
+ # the preformatted text.
+ $rest =~ s{
+ (\s*)(perl\w+)
+ }{
+ if ( defined $Pages{$2} ){ # is a link
+ qq($1<a href="$Htmlroot/$Pages{$2}">$2</a>);
+ } elsif (defined $Pages{dosify($2)}) { # is a link
+ qq($1<a href="$Htmlroot/$Pages{dosify($2)}">$2</a>);
+ } else {
+ "$1$2";
+ }
+ }xeg;
+ $rest =~ s{
+ (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
+ }{
+ my $url ;
+ if ( $Htmlfileurl ne '' ){
+ # Here, we take advantage of the knowledge
+ # that $Htmlfileurl ne '' implies $Htmlroot eq ''.
+ # Since $Htmlroot eq '', we need to prepend $Htmldir
+ # on the fron of the link to get the absolute path
+ # of the link's target. We check for a leading '/'
+ # to avoid corrupting links that are #, file:, etc.
+ my $old_url = $3 ;
+ $old_url = "$Htmldir$old_url" if $old_url =~ m{^\/};
+ $url = relativize_url( "$old_url.html", $Htmlfileurl );
+ } else {
+ $url = "$3.html" ;
+ }
+ "$1$url" ;
+ }xeg;
+
+ # Look for embedded URLs and make them into links. We don't
+ # relativize them since they are best left as the author intended.
+
+ my $urls = '(' . join ('|', qw{
+ http
+ telnet
+ mailto
+ news
+ gopher
+ file
+ wais
+ ftp
+ } )
+ . ')';
+
+ my $ltrs = '\w';
+ my $gunk = '/#~:.?+=&%@!\-';
+ my $punc = '.:!?\-;';
+ my $any = "${ltrs}${gunk}${punc}";
+
+ $rest =~ s{
+ \b # start at word boundary
+ ( # begin $1 {
+ $urls : # need resource and a colon
+ (?!:) # Ignore File::, among others.
+ [$any] +? # followed by one or more of any valid
+ # character, but be conservative and
+ # take only what you need to....
+ ) # end $1 }
+ (?=
+ &quot; &gt; # maybe pre-quoted '<a href="...">'
+ | # or:
+ [$punc]* # 0 or more punctuation
+ (?: # followed
+ [^$any] # by a non-url char
+ | # or
+ $ # end of the string
+ ) #
+ | # or else
+ $ # then end of the string
+ )
+ }{<a href="$1">$1</a>}igox;
+
+ # text should be as it is (verbatim)
+ $$text = $rest;
+}
+
+
+#
+# pure text processing
+#
+# pure_text/inIS_text: differ with respect to automatic C<> recognition.
+# we don't want this to happen within IS
+#
+sub pure_text($){
+ my $text = shift();
+ process_puretext( $text, 1 );
+}
+
+sub inIS_text($){
+ my $text = shift();
+ process_puretext( $text, 0 );
+}
+
+#
+# process_puretext - process pure text (without pod-escapes) converting
+# double-quotes and handling implicit C<> links.
+#
+sub process_puretext {
+ my($text, $notinIS) = @_;
+
+ ## Guessing at func() or [\$\@%&]*var references in plain text is destined
+ ## to produce some strange looking ref's. uncomment to disable:
+ ## $notinIS = 0;
+
+ my(@words, $lead, $trail);
+
+ # keep track of leading and trailing white-space
+ $lead = ($text =~ s/\A(\s+)//s ? $1 : "");
+ $trail = ($text =~ s/(\s+)\Z//s ? $1 : "");
+
+ # split at space/non-space boundaries
+ @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text );
+
+ # process each word individually
+ foreach my $word (@words) {
+ # skip space runs
+ next if $word =~ /^\s*$/;
+ # see if we can infer a link or a function call
+ #
+ # NOTE: This is a word based search, it won't automatically
+ # mark "substr($var, 1, 2)" because the 1st word would be "substr($var"
+ # User has to enclose those with proper C<>
+
+ if( $notinIS && $word =~
+ m/
+ ^([a-z_]{2,}) # The function name
+ \(
+ ([0-9][a-z]* # Manual page(1) or page(1M)
+ |[^)]*[\$\@\%][^)]+ # ($foo), (1, @foo), (%hash)
+ | # ()
+ )
+ \)
+ ([.,;]?)$ # a possible punctuation follows
+ /xi
+ ) {
+ # has parenthesis so should have been a C<> ref
+ ## try for a pagename (perlXXX(1))?
+ my( $func, $args, $rest ) = ( $1, $2, $3 || '' );
+ if( $args =~ /^\d+$/ ){
+ my $url = page_sect( $word, '' );
+ if( defined $url ){
+ $word = qq(<a href="$url" class="man">the $word manpage</a>$rest);
+ next;
+ }
+ }
+ ## try function name for a link, append tt'ed argument list
+ $word = emit_C( $func, '', "($args)") . $rest;
+
+#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing.
+## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) {
+## # perl variables, should be a C<> ref
+## $word = emit_C( $word );
+
+ } elsif ($word =~ m,^\w+://\w,) {
+ # looks like a URL
+ # Don't relativize it: leave it as the author intended
+ $word = qq(<a href="$word">$word</a>);
+ } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
+ # looks like an e-mail address
+ my ($w1, $w2, $w3) = ("", $word, "");
+ ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
+ ($w1, $w2, $w3) = ("&lt;", $1, "&gt;$2") if $word =~ /^<(.*?)>(,?)/;
+ $word = qq($w1<a href="mailto:$w2">$w2</a>$w3);
+ } else {
+ $word = html_escape($word) if $word =~ /["&<>]/;
+ }
+ }
+
+ # put everything back together
+ return $lead . join( '', @words ) . $trail;
+}
+
+
+#
+# process_text - handles plaintext that appears in the input pod file.
+# there may be pod commands embedded within the text so those must be
+# converted to html commands.
+#
+
+sub process_text1($$;$$);
+sub pattern ($) { $_[0] ? '\s+'.('>' x ($_[0] + 1)) : '>' }
+sub closing ($) { local($_) = shift; (defined && s/\s+\z//) ? length : 0 }
+
+sub process_text {
+ return if $Ignore;
+ my( $tref ) = @_;
+ my $res = process_text1( 0, $tref );
+ $res =~ s/\s+$//s;
+ $$tref = $res;
+}
+
+sub process_text_rfc_links {
+ my $text = shift;
+
+ # For every "RFCnnnn" or "RFC nnn", link it to the authoritative
+ # ource. Do not use the /i modifier here. Require "RFC" to be written in
+ # in capital letters.
+
+ $text =~ s{
+ (?<=[^<>[:alpha:]]) # Make sure this is not an URL already
+ (RFC\s*([0-9]{1,5}))(?![0-9]) # max 5 digits
+ }
+ {<a href="http://www.ietf.org/rfc/rfc$2.txt" class="rfc">$1</a>}gx;
+
+ $text;
+}
+
+sub process_text1($$;$$){
+ my( $lev, $rstr, $func, $closing ) = @_;
+ my $res = '';
+
+ unless (defined $func) {
+ $func = '';
+ $lev++;
+ }
+
+ if( $func eq 'B' ){
+ # B<text> - boldface
+ $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>';
+
+ } elsif( $func eq 'C' ){
+ # C<code> - can be a ref or <code></code>
+ # need to extract text
+ my $par = go_ahead( $rstr, 'C', $closing );
+
+ ## clean-up of the link target
+ my $text = depod( $par );
+
+ ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ;
+ ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n";
+
+ $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
+
+ } elsif( $func eq 'E' ){
+ # E<x> - convert to character
+ $$rstr =~ s/^([^>]*)>//;
+ my $escape = $1;
+ $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i;
+ $res = "&$escape;";
+
+ } elsif( $func eq 'F' ){
+ # F<filename> - italicize
+ $res = '<em class="file">' . process_text1( $lev, $rstr ) . '</em>';
+
+ } elsif( $func eq 'I' ){
+ # I<text> - italicize
+ $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
+
+ } elsif( $func eq 'L' ){
+ # L<link> - link
+ ## L<text|cross-ref> => produce text, use cross-ref for linking
+ ## L<cross-ref> => make text from cross-ref
+ ## need to extract text
+ my $par = go_ahead( $rstr, 'L', $closing );
+
+ # some L<>'s that shouldn't be:
+ # a) full-blown URL's are emitted as-is
+ if( $par =~ m{^\w+://}s ){
+ return make_URL_href( $par );
+ }
+ # b) C<...> is stripped and treated as C<>
+ if( $par =~ /^C<(.*)>$/ ){
+ my $text = depod( $1 );
+ return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
+ }
+
+ # analyze the contents
+ $par =~ s/\n/ /g; # undo word-wrapped tags
+ my $opar = $par;
+ my $linktext;
+ if( $par =~ s{^([^|]+)\|}{} ){
+ $linktext = $1;
+ }
+
+ # make sure sections start with a /
+ $par =~ s{^"}{/"};
+
+ my( $page, $section, $ident );
+
+ # check for link patterns
+ if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident
+ # we've got a name/ident (no quotes)
+ if (length $2) {
+ ( $page, $ident ) = ( $1, $2 );
+ } else {
+ ( $page, $section ) = ( $1, $2 );
+ }
+ ### print STDERR "--> L<$par> to page $page, ident $ident\n";
+
+ } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section"
+ # even though this should be a "section", we go for ident first
+ ( $page, $ident ) = ( $1, $2 );
+ ### print STDERR "--> L<$par> to page $page, section $section\n";
+
+ } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes
+ ( $page, $section ) = ( '', $par );
+ ### print STDERR "--> L<$par> to void page, section $section\n";
+
+ } else {
+ ( $page, $section ) = ( $par, '' );
+ ### print STDERR "--> L<$par> to page $par, void section\n";
+ }
+
+ # now, either $section or $ident is defined. the convoluted logic
+ # below tries to resolve L<> according to what the user specified.
+ # failing this, we try to find the next best thing...
+ my( $url, $ltext, $fid );
+
+ RESOLVE: {
+ if( defined $ident ){
+ ## try to resolve $ident as an item
+ ( $url, $fid ) = coderef( $page, $ident );
+ if( $url ){
+ if( ! defined( $linktext ) ){
+ $linktext = $ident;
+ $linktext .= " in " if $ident && $page;
+ $linktext .= "the $page manpage" if $page;
+ }
+ ### print STDERR "got coderef url=$url\n";
+ last RESOLVE;
+ }
+ ## no luck: go for a section (auto-quoting!)
+ $section = $ident;
+ }
+ ## now go for a section
+ my $htmlsection = htmlify( $section );
+ $url = page_sect( $page, $htmlsection );
+ if( $url ){
+ if( ! defined( $linktext ) ){
+ $linktext = $section;
+ $linktext .= " in " if $section && $page;
+ $linktext .= "the $page manpage" if $page;
+ }
+ ### print STDERR "got page/section url=$url\n";
+ last RESOLVE;
+ }
+ ## no luck: go for an ident
+ if( $section ){
+ $ident = $section;
+ } else {
+ $ident = $page;
+ $page = undef();
+ }
+ ( $url, $fid ) = coderef( $page, $ident );
+ if( $url ){
+ if( ! defined( $linktext ) ){
+ $linktext = $ident;
+ $linktext .= " in " if $ident && $page;
+ $linktext .= "the $page manpage" if $page;
+ }
+ ### print STDERR "got section=>coderef url=$url\n";
+ last RESOLVE;
+ }
+
+ # warning; show some text.
+ $linktext = $opar unless defined $linktext;
+ warn "$0: $Podfile: cannot resolve L<$opar> in paragraph $Paragraph.\n" unless $Quiet;
+ }
+
+ # now we have a URL or just plain code
+ $$rstr = $linktext . '>' . $$rstr;
+ if( defined( $url ) ){
+ $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>';
+ } else {
+ $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
+ }
+
+ } elsif( $func eq 'S' ){
+ # S<text> - non-breaking spaces
+ $res = process_text1( $lev, $rstr );
+ $res =~ s/ /&nbsp;/g;
+
+ } elsif( $func eq 'X' ){
+ # X<> - ignore
+ warn "$0: $Podfile: invalid X<> in paragraph $Paragraph.\n"
+ unless $$rstr =~ s/^[^>]*>// or $Quiet;
+ } elsif( $func eq 'Z' ){
+ # Z<> - empty
+ warn "$0: $Podfile: invalid Z<> in paragraph $Paragraph.\n"
+ unless $$rstr =~ s/^>// or $Quiet;
+
+ } else {
+ my $term = pattern $closing;
+ while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
+ # all others: either recurse into new function or
+ # terminate at closing angle bracket(s)
+ my $pt = $1;
+ $pt .= $2 if !$3 && $lev == 1;
+ $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
+ return $res if !$3 && $lev > 1;
+ if( $3 ){
+ $res .= process_text1( $lev, $rstr, $3, closing $4 );
+ }
+ }
+ if( $lev == 1 ){
+ $res .= pure_text( $$rstr );
+ } elsif( ! $Quiet ) {
+ my $snippet = substr($$rstr,0,60);
+ warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph: '$snippet'.\n"
+
+ }
+ $res = process_text_rfc_links($res);
+ }
+ return $res;
+}
+
+#
+# go_ahead: extract text of an IS (can be nested)
+#
+sub go_ahead($$$){
+ my( $rstr, $func, $closing ) = @_;
+ my $res = '';
+ my @closing = ($closing);
+ while( $$rstr =~
+ s/\A(.*?)(([BCEFILSXZ])<(<+\s+)?|@{[pattern $closing[0]]})//s ){
+ $res .= $1;
+ unless( $3 ){
+ shift @closing;
+ return $res unless @closing;
+ } else {
+ unshift @closing, closing $4;
+ }
+ $res .= $2;
+ }
+ unless ($Quiet) {
+ my $snippet = substr($$rstr,0,60);
+ warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph (go_ahead): '$snippet'.\n"
+ }
+ return $res;
+}
+
+#
+# emit_C - output result of C<text>
+# $text is the depod-ed text
+#
+sub emit_C($;$$){
+ my( $text, $nocode, $args ) = @_;
+ $args = '' unless defined $args;
+ my $res;
+ my( $url, $fid ) = coderef( undef(), $text );
+
+ # need HTML-safe text
+ my $linktext = html_escape( "$text$args" );
+
+ if( defined( $url ) &&
+ (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){
+ $res = "<a href=\"$url\"><code>$linktext</code></a>";
+ } elsif( 0 && $nocode ){
+ $res = $linktext;
+ } else {
+ $res = "<code>$linktext</code>";
+ }
+ return $res;
+}
+
+#
+# html_escape: make text safe for HTML
+#
+sub html_escape {
+ my $rest = $_[0];
+ $rest =~ s/&/&amp;/g;
+ $rest =~ s/</&lt;/g;
+ $rest =~ s/>/&gt;/g;
+ $rest =~ s/"/&quot;/g;
+ # &apos; is only in XHTML, not HTML4. Be conservative
+ #$rest =~ s/'/&apos;/g;
+ return $rest;
+}
+
+
+#
+# dosify - convert filenames to 8.3
+#
+sub dosify {
+ my($str) = @_;
+ return lc($str) if $^O eq 'VMS'; # VMS just needs casing
+ if ($Is83) {
+ $str = lc $str;
+ $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
+ $str =~ s/(\w+)/substr ($1,0,8)/ge;
+ }
+ return $str;
+}
+
+#
+# page_sect - make a URL from the text of a L<>
+#
+sub page_sect($$) {
+ my( $page, $section ) = @_;
+ my( $linktext, $page83, $link); # work strings
+
+ # check if we know that this is a section in this page
+ if (!defined $Pages{$page} && defined $Sections{$page}) {
+ $section = $page;
+ $page = "";
+ ### print STDERR "reset page='', section=$section\n";
+ }
+
+ $page83=dosify($page);
+ $page=$page83 if (defined $Pages{$page83});
+ if ($page eq "") {
+ $link = "#" . anchorify( $section );
+ } elsif ( $page =~ /::/ ) {
+ $page =~ s,::,/,g;
+ # Search page cache for an entry keyed under the html page name,
+ # then look to see what directory that page might be in. NOTE:
+ # this will only find one page. A better solution might be to produce
+ # an intermediate page that is an index to all such pages.
+ my $page_name = $page ;
+ $page_name =~ s,^.*/,,s ;
+ if ( defined( $Pages{ $page_name } ) &&
+ $Pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
+ ) {
+ $page = $1 ;
+ }
+ else {
+ # NOTE: This branch assumes that all A::B pages are located in
+ # $Htmlroot/A/B.html . This is often incorrect, since they are
+ # often in $Htmlroot/lib/A/B.html or such like. Perhaps we could
+ # analyze the contents of %Pages and figure out where any
+ # cousins of A::B are, then assume that. So, if A::B isn't found,
+ # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
+ # lib/A/B.pm. This is also limited, but it's an improvement.
+ # Maybe a hints file so that the links point to the correct places
+ # nonetheless?
+
+ }
+ $link = "$Htmlroot/$page.html";
+ $link .= "#" . anchorify( $section ) if ($section);
+ } elsif (!defined $Pages{$page}) {
+ $link = "";
+ } else {
+ $section = anchorify( $section ) if $section ne "";
+ ### print STDERR "...section=$section\n";
+
+ # if there is a directory by the name of the page, then assume that an
+ # appropriate section will exist in the subdirectory
+# if ($section ne "" && $Pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ if ($section ne "" && $Pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
+ $link = "$Htmlroot/$1/$section.html";
+ ### print STDERR "...link=$link\n";
+
+ # since there is no directory by the name of the page, the section will
+ # have to exist within a .html of the same name. thus, make sure there
+ # is a .pod or .pm that might become that .html
+ } else {
+ $section = "#$section" if $section;
+ ### print STDERR "...section=$section\n";
+
+ # check if there is a .pod with the page name.
+ # for L<Foo>, Foo.(pod|pm) is preferred to A/Foo.(pod|pm)
+ if ($Pages{$page} =~ /([^:]*)\.(?:pod|pm):/) {
+ $link = "$Htmlroot/$1.html$section";
+ } else {
+ $link = "";
+ }
+ }
+ }
+
+ if ($link) {
+ # Here, we take advantage of the knowledge that $Htmlfileurl ne ''
+ # implies $Htmlroot eq ''. This means that the link in question
+ # needs a prefix of $Htmldir if it begins with '/'. The test for
+ # the initial '/' is done to avoid '#'-only links, and to allow
+ # for other kinds of links, like file:, ftp:, etc.
+ my $url ;
+ if ( $Htmlfileurl ne '' ) {
+ $link = "$Htmldir$link" if $link =~ m{^/}s;
+ $url = relativize_url( $link, $Htmlfileurl );
+# print( " b: [$link,$Htmlfileurl,$url]\n" );
+ }
+ else {
+ $url = $link ;
+ }
+ return $url;
+
+ } else {
+ return undef();
+ }
+}
+
+#
+# relativize_url - convert an absolute URL to one relative to a base URL.
+# Assumes both end in a filename.
+#
+sub relativize_url {
+ my ($dest,$source) = @_ ;
+
+ my ($dest_volume,$dest_directory,$dest_file) =
+ File::Spec::Unix->splitpath( $dest ) ;
+ $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
+
+ my ($source_volume,$source_directory,$source_file) =
+ File::Spec::Unix->splitpath( $source ) ;
+ $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
+
+ my $rel_path = '' ;
+ if ( $dest ne '' ) {
+ $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
+ }
+
+ if ( $rel_path ne '' &&
+ substr( $rel_path, -1 ) ne '/' &&
+ substr( $dest_file, 0, 1 ) ne '#'
+ ) {
+ $rel_path .= "/$dest_file" ;
+ }
+ else {
+ $rel_path .= "$dest_file" ;
+ }
+
+ return $rel_path ;
+}
+
+
+#
+# coderef - make URL from the text of a C<>
+#
+sub coderef($$){
+ my( $page, $item ) = @_;
+ my( $url );
+
+ my $fid = fragment_id( $item );
+
+ if( defined( $page ) && $page ne "" ){
+ # we have been given a $page...
+ $page =~ s{::}{/}g;
+
+ Carp::confess("Undefined fragment '$item' from fragment_id() in coderef() in $Podfile")
+ if !defined $fid;
+ # Do we take it? Item could be a section!
+ my $base = $Items{$fid} || "";
+ $base =~ s{[^/]*/}{};
+ if( $base ne "$page.html" ){
+ ### print STDERR "coderef( $page, $item ): items{$fid} = $Items{$fid} = $base => discard page!\n";
+ $page = undef();
+ }
+
+ } else {
+ # no page - local items precede cached items
+ if( defined( $fid ) ){
+ if( exists $Local_Items{$fid} ){
+ $page = $Local_Items{$fid};
+ } else {
+ $page = $Items{$fid};
+ }
+ }
+ }
+
+ # if there was a pod file that we found earlier with an appropriate
+ # =item directive, then create a link to that page.
+ if( defined $page ){
+ if( $page ){
+ if( exists $Pages{$page} and $Pages{$page} =~ /([^:.]*)\.[^:]*:/){
+ $page = $1 . '.html';
+ }
+ my $link = "$Htmlroot/$page#" . anchorify($fid);
+
+ # Here, we take advantage of the knowledge that $Htmlfileurl
+ # ne '' implies $Htmlroot eq ''.
+ if ( $Htmlfileurl ne '' ) {
+ $link = "$Htmldir$link" ;
+ $url = relativize_url( $link, $Htmlfileurl ) ;
+ } else {
+ $url = $link ;
+ }
+ } else {
+ $url = "#" . anchorify($fid);
+ }
+
+ confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/;
+ }
+ return( $url, $fid );
+}
+
+
+
+#
+# Adapted from Nick Ing-Simmons' PodToHtml package.
+sub relative_url {
+ my $source_file = shift ;
+ my $destination_file = shift;
+
+ my $source = URI::file->new_abs($source_file);
+ my $uo = URI::file->new($destination_file,$source)->abs;
+ return $uo->rel->as_string;
+}
+
+
+#
+# finish_list - finish off any pending HTML lists. this should be called
+# after the entire pod file has been read and converted.
+#
+sub finish_list {
+ if( $Listlevel ){
+ warn "$0: $Podfile: unterminated list(s) at =head in paragraph $Paragraph. ignoring.\n" unless $Quiet;
+ while( $Listlevel ){
+ process_back();
+ }
+ }
+}
+
+#
+# htmlify - converts a pod section specification to a suitable section
+# specification for HTML. Note that we keep spaces and special characters
+# except ", ? (Netscape problem) and the hyphen (writer's problem...).
+#
+sub htmlify {
+ my( $heading) = @_;
+ $heading =~ s/(\s+)/ /g;
+ $heading =~ s/\s+\Z//;
+ $heading =~ s/\A\s+//;
+ # The hyphen is a disgrace to the English language.
+ # $heading =~ s/[-"?]//g;
+ $heading =~ s/["?]//g;
+ $heading = lc( $heading );
+ return $heading;
+}
+
+#
+# similar to htmlify, but turns non-alphanumerics into underscores
+#
+sub anchorify {
+ my ($anchor) = @_;
+ $anchor = htmlify($anchor);
+ $anchor =~ s/\W/_/g;
+ return $anchor;
+}
+
+#
+# depod - convert text by eliminating all interior sequences
+# Note: can be called with copy or modify semantics
+#
+my %E2c;
+$E2c{lt} = '<';
+$E2c{gt} = '>';
+$E2c{sol} = '/';
+$E2c{verbar} = '|';
+$E2c{amp} = '&'; # in Tk's pods
+
+sub depod1($;$$);
+
+sub depod($){
+ my $string;
+ if( ref( $_[0] ) ){
+ $string = ${$_[0]};
+ ${$_[0]} = depod1( \$string );
+ } else {
+ $string = $_[0];
+ depod1( \$string );
+ }
+}
+
+sub depod1($;$$){
+ my( $rstr, $func, $closing ) = @_;
+ my $res = '';
+ return $res unless defined $$rstr;
+ if( ! defined( $func ) ){
+ # skip to next begin of an interior sequence
+ while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?//s ){
+ # recurse into its text
+ $res .= $1 . depod1( $rstr, $2, closing $3);
+ }
+ $res .= $$rstr;
+ } elsif( $func eq 'E' ){
+ # E<x> - convert to character
+ $$rstr =~ s/^([^>]*)>//;
+ $res .= $E2c{$1} || "";
+ } elsif( $func eq 'X' ){
+ # X<> - ignore
+ $$rstr =~ s/^[^>]*>//;
+ } elsif( $func eq 'Z' ){
+ # Z<> - empty
+ $$rstr =~ s/^>//;
+ } else {
+ # all others: either recurse into new function or
+ # terminate at closing angle bracket
+ my $term = pattern $closing;
+ while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
+ $res .= $1;
+ last unless $3;
+ $res .= depod1( $rstr, $3, closing $4 );
+ }
+ ## If we're here and $2 ne '>': undelimited interior sequence.
+ ## Ignored, as this is called without proper indication of where we are.
+ ## Rely on process_text to produce diagnostics.
+ }
+ return $res;
+}
+
+{
+ my %seen; # static fragment record hash
+
+sub fragment_id_readable {
+ my $text = shift;
+ my $generate = shift; # optional flag
+
+ my $orig = $text;
+
+ # leave the words for the fragment identifier,
+ # change everything else to underbars.
+ $text =~ s/[^A-Za-z0-9_]+/_/g; # do not use \W to avoid locale dependency.
+ $text =~ s/_{2,}/_/g;
+ $text =~ s/\A_//;
+ $text =~ s/_\Z//;
+
+ unless ($text)
+ {
+ # Nothing left after removing punctuation, so leave it as is
+ # E.g. if option is named: "=item -#"
+
+ $text = $orig;
+ }
+
+ if ($generate) {
+ if ( exists $seen{$text} ) {
+ # This already exists, make it unique
+ $seen{$text}++;
+ $text = $text . $seen{$text};
+ } else {
+ $seen{$text} = 1; # first time seen this fragment
+ }
+ }
+
+ $text;
+}}
+
+my @HC;
+sub fragment_id_obfuscated { # This was the old "_2d_2d__"
+ my $text = shift;
+ my $generate = shift; # optional flag
+
+ # text? Normalize by obfuscating the fragment id to make it unique
+ $text =~ s/\s+/_/sg;
+
+ $text =~ s{(\W)}{
+ defined( $HC[ord($1)] ) ? $HC[ord($1)]
+ : ( $HC[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe;
+ $text = substr( $text, 0, 50 );
+
+ $text;
+}
+
+#
+# fragment_id - construct a fragment identifier from:
+# a) =item text
+# b) contents of C<...>
+#
+
+sub fragment_id {
+ my $text = shift;
+ my $generate = shift; # optional flag
+
+ $text =~ s/\s+\Z//s;
+ if( $text ){
+ # a method or function?
+ return $1 if $text =~ /(\w+)\s*\(/;
+ return $1 if $text =~ /->\s*(\w+)\s*\(?/;
+
+ # a variable name?
+ return $1 if $text =~ /^([\$\@%*]\S+)/;
+
+ # some pattern matching operator?
+ return $1 if $text =~ m|^(\w+/).*/\w*$|;
+
+ # fancy stuff... like "do { }"
+ return $1 if $text =~ m|^(\w+)\s*{.*}$|;
+
+ # honour the perlfunc manpage: func [PAR[,[ ]PAR]...]
+ # and some funnies with ... Module ...
+ return $1 if $text =~ m{^([a-z\d_]+)(\s+[A-Z,/& ][A-Z\d,/& ]*)?$};
+ return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
+
+ return fragment_id_readable($text, $generate);
+ } else {
+ return;
+ }
+}
+
+#
+# make_URL_href - generate HTML href from URL
+# Special treatment for CGI queries.
+#
+sub make_URL_href($){
+ my( $url ) = @_;
+ if( $url !~
+ s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){
+ $url = "<a href=\"$url\">$url</a>";
+ }
+ return $url;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/InputObjects.pm b/Master/tlpkg/tlperl.straw/lib/Pod/InputObjects.pm
new file mode 100755
index 00000000000..13a86188bcb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/InputObjects.pm
@@ -0,0 +1,936 @@
+#############################################################################
+# Pod/InputObjects.pm -- package which defines objects for input streams
+# and paragraphs and commands when parsing POD docs.
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::InputObjects;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '1.31'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+#############################################################################
+
+=head1 NAME
+
+Pod::InputObjects - objects representing POD input paragraphs, commands, etc.
+
+=head1 SYNOPSIS
+
+ use Pod::InputObjects;
+
+=head1 REQUIRES
+
+perl5.004, Carp
+
+=head1 EXPORTS
+
+Nothing.
+
+=head1 DESCRIPTION
+
+This module defines some basic input objects used by B<Pod::Parser> when
+reading and parsing POD text from an input source. The following objects
+are defined:
+
+=over 4
+
+=begin __PRIVATE__
+
+=item package B<Pod::InputSource>
+
+An object corresponding to a source of POD input text. It is mostly a
+wrapper around a filehandle or C<IO::Handle>-type object (or anything
+that implements the C<getline()> method) which keeps track of some
+additional information relevant to the parsing of PODs.
+
+=end __PRIVATE__
+
+=item package B<Pod::Paragraph>
+
+An object corresponding to a paragraph of POD input text. It may be a
+plain paragraph, a verbatim paragraph, or a command paragraph (see
+L<perlpod>).
+
+=item package B<Pod::InteriorSequence>
+
+An object corresponding to an interior sequence command from the POD
+input text (see L<perlpod>).
+
+=item package B<Pod::ParseTree>
+
+An object corresponding to a tree of parsed POD text. Each "node" in
+a parse-tree (or I<ptree>) is either a text-string or a reference to
+a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree
+in the order in which they were parsed from left-to-right.
+
+=back
+
+Each of these input objects are described in further detail in the
+sections which follow.
+
+=cut
+
+#############################################################################
+
+package Pod::InputSource;
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<Pod::InputSource>
+
+This object corresponds to an input source or stream of POD
+documentation. When parsing PODs, it is necessary to associate and store
+certain context information with each input source. All of this
+information is kept together with the stream itself in one of these
+C<Pod::InputSource> objects. Each such object is merely a wrapper around
+an C<IO::Handle> object of some kind (or at least something that
+implements the C<getline()> method). They have the following
+methods/attributes:
+
+=end __PRIVATE__
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<new()>
+
+ my $pod_input1 = Pod::InputSource->new(-handle => $filehandle);
+ my $pod_input2 = new Pod::InputSource(-handle => $filehandle,
+ -name => $name);
+ my $pod_input3 = new Pod::InputSource(-handle => \*STDIN);
+ my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN,
+ -name => "(STDIN)");
+
+This is a class method that constructs a C<Pod::InputSource> object and
+returns a reference to the new input source object. It takes one or more
+keyword arguments in the form of a hash. The keyword C<-handle> is
+required and designates the corresponding input handle. The keyword
+C<-name> is optional and specifies the name associated with the input
+handle (typically a file name).
+
+=end __PRIVATE__
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object. Note that we default
+ ## certain values by specifying them *before* the arguments passed.
+ ## If they are in the argument list, they will override the defaults.
+ my $self = { -name => '(unknown)',
+ -handle => undef,
+ -was_cutting => 0,
+ @_ };
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<name()>
+
+ my $filename = $pod_input->name();
+ $pod_input->name($new_filename_to_use);
+
+This method gets/sets the name of the input source (usually a filename).
+If no argument is given, it returns a string containing the name of
+the input source; otherwise it sets the name of the input source to the
+contents of the given argument.
+
+=end __PRIVATE__
+
+=cut
+
+sub name {
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];
+ return $_[0]->{'-name'};
+}
+
+## allow 'filename' as an alias for 'name'
+*filename = \&name;
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<handle()>
+
+ my $handle = $pod_input->handle();
+
+Returns a reference to the handle object from which input is read (the
+one used to contructed this input source object).
+
+=end __PRIVATE__
+
+=cut
+
+sub handle {
+ return $_[0]->{'-handle'};
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head2 B<was_cutting()>
+
+ print "Yes.\n" if ($pod_input->was_cutting());
+
+The value of the C<cutting> state (that the B<cutting()> method would
+have returned) immediately before any input was read from this input
+stream. After all input from this stream has been read, the C<cutting>
+state is restored to this value.
+
+=end __PRIVATE__
+
+=cut
+
+sub was_cutting {
+ (@_ > 1) and $_[0]->{-was_cutting} = $_[1];
+ return $_[0]->{-was_cutting};
+}
+
+##---------------------------------------------------------------------------
+
+#############################################################################
+
+package Pod::Paragraph;
+
+##---------------------------------------------------------------------------
+
+=head1 B<Pod::Paragraph>
+
+An object representing a paragraph of POD input text.
+It has the following methods/attributes:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::Paragraph-E<gt>B<new()>
+
+ my $pod_para1 = Pod::Paragraph->new(-text => $text);
+ my $pod_para2 = Pod::Paragraph->new(-name => $cmd,
+ -text => $text);
+ my $pod_para3 = new Pod::Paragraph(-text => $text);
+ my $pod_para4 = new Pod::Paragraph(-name => $cmd,
+ -text => $text);
+ my $pod_para5 = Pod::Paragraph->new(-name => $cmd,
+ -text => $text,
+ -file => $filename,
+ -line => $line_number);
+
+This is a class method that constructs a C<Pod::Paragraph> object and
+returns a reference to the new paragraph object. It may be given one or
+two keyword arguments. The C<-text> keyword indicates the corresponding
+text of the POD paragraph. The C<-name> keyword indicates the name of
+the corresponding POD command, such as C<head1> or C<item> (it should
+I<not> contain the C<=> prefix); this is needed only if the POD
+paragraph corresponds to a command paragraph. The C<-file> and C<-line>
+keywords indicate the filename and line number corresponding to the
+beginning of the paragraph
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object. Note that we default
+ ## certain values by specifying them *before* the arguments passed.
+ ## If they are in the argument list, they will override the defaults.
+ my $self = {
+ -name => undef,
+ -text => (@_ == 1) ? shift : undef,
+ -file => '<unknown-file>',
+ -line => 0,
+ -prefix => '=',
+ -separator => ' ',
+ -ptree => [],
+ @_
+ };
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<cmd_name()>
+
+ my $para_cmd = $pod_para->cmd_name();
+
+If this paragraph is a command paragraph, then this method will return
+the name of the command (I<without> any leading C<=> prefix).
+
+=cut
+
+sub cmd_name {
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];
+ return $_[0]->{'-name'};
+}
+
+## let name() be an alias for cmd_name()
+*name = \&cmd_name;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<text()>
+
+ my $para_text = $pod_para->text();
+
+This method will return the corresponding text of the paragraph.
+
+=cut
+
+sub text {
+ (@_ > 1) and $_[0]->{'-text'} = $_[1];
+ return $_[0]->{'-text'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<raw_text()>
+
+ my $raw_pod_para = $pod_para->raw_text();
+
+This method will return the I<raw> text of the POD paragraph, exactly
+as it appeared in the input.
+
+=cut
+
+sub raw_text {
+ return $_[0]->{'-text'} unless (defined $_[0]->{'-name'});
+ return $_[0]->{'-prefix'} . $_[0]->{'-name'} .
+ $_[0]->{'-separator'} . $_[0]->{'-text'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<cmd_prefix()>
+
+ my $prefix = $pod_para->cmd_prefix();
+
+If this paragraph is a command paragraph, then this method will return
+the prefix used to denote the command (which should be the string "="
+or "==").
+
+=cut
+
+sub cmd_prefix {
+ return $_[0]->{'-prefix'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<cmd_separator()>
+
+ my $separator = $pod_para->cmd_separator();
+
+If this paragraph is a command paragraph, then this method will return
+the text used to separate the command name from the rest of the
+paragraph (if any).
+
+=cut
+
+sub cmd_separator {
+ return $_[0]->{'-separator'};
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<parse_tree()>
+
+ my $ptree = $pod_parser->parse_text( $pod_para->text() );
+ $pod_para->parse_tree( $ptree );
+ $ptree = $pod_para->parse_tree();
+
+This method will get/set the corresponding parse-tree of the paragraph's text.
+
+=cut
+
+sub parse_tree {
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
+ return $_[0]->{'-ptree'};
+}
+
+## let ptree() be an alias for parse_tree()
+*ptree = \&parse_tree;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_para-E<gt>B<file_line()>
+
+ my ($filename, $line_number) = $pod_para->file_line();
+ my $position = $pod_para->file_line();
+
+Returns the current filename and line number for the paragraph
+object. If called in a list context, it returns a list of two
+elements: first the filename, then the line number. If called in
+a scalar context, it returns a string containing the filename, followed
+by a colon (':'), followed by the line number.
+
+=cut
+
+sub file_line {
+ my @loc = ($_[0]->{'-file'} || '<unknown-file>',
+ $_[0]->{'-line'} || 0);
+ return (wantarray) ? @loc : join(':', @loc);
+}
+
+##---------------------------------------------------------------------------
+
+#############################################################################
+
+package Pod::InteriorSequence;
+
+##---------------------------------------------------------------------------
+
+=head1 B<Pod::InteriorSequence>
+
+An object representing a POD interior sequence command.
+It has the following methods/attributes:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::InteriorSequence-E<gt>B<new()>
+
+ my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd
+ -ldelim => $delimiter);
+ my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd,
+ -ldelim => $delimiter);
+ my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd,
+ -ldelim => $delimiter,
+ -file => $filename,
+ -line => $line_number);
+
+ my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree);
+ my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree);
+
+This is a class method that constructs a C<Pod::InteriorSequence> object
+and returns a reference to the new interior sequence object. It should
+be given two keyword arguments. The C<-ldelim> keyword indicates the
+corresponding left-delimiter of the interior sequence (e.g. 'E<lt>').
+The C<-name> keyword indicates the name of the corresponding interior
+sequence command, such as C<I> or C<B> or C<C>. The C<-file> and
+C<-line> keywords indicate the filename and line number corresponding
+to the beginning of the interior sequence. If the C<$ptree> argument is
+given, it must be the last argument, and it must be either string, or
+else an array-ref suitable for passing to B<Pod::ParseTree::new> (or
+it may be a reference to a Pod::ParseTree object).
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ ## See if first argument has no keyword
+ if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) {
+ ## Yup - need an implicit '-name' before first parameter
+ unshift @_, '-name';
+ }
+
+ ## See if odd number of args
+ if ((@_ % 2) != 0) {
+ ## Yup - need an implicit '-ptree' before the last parameter
+ splice @_, $#_, 0, '-ptree';
+ }
+
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object. Note that we default
+ ## certain values by specifying them *before* the arguments passed.
+ ## If they are in the argument list, they will override the defaults.
+ my $self = {
+ -name => (@_ == 1) ? $_[0] : undef,
+ -file => '<unknown-file>',
+ -line => 0,
+ -ldelim => '<',
+ -rdelim => '>',
+ @_
+ };
+
+ ## Initialize contents if they havent been already
+ my $ptree = $self->{'-ptree'} || new Pod::ParseTree();
+ if ( ref $ptree =~ /^(ARRAY)?$/ ) {
+ ## We have an array-ref, or a normal scalar. Pass it as an
+ ## an argument to the ptree-constructor
+ $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree);
+ }
+ $self->{'-ptree'} = $ptree;
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<cmd_name()>
+
+ my $seq_cmd = $pod_seq->cmd_name();
+
+The name of the interior sequence command.
+
+=cut
+
+sub cmd_name {
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];
+ return $_[0]->{'-name'};
+}
+
+## let name() be an alias for cmd_name()
+*name = \&cmd_name;
+
+##---------------------------------------------------------------------------
+
+## Private subroutine to set the parent pointer of all the given
+## children that are interior-sequences to be $self
+
+sub _set_child2parent_links {
+ my ($self, @children) = @_;
+ ## Make sure any sequences know who their parent is
+ for (@children) {
+ next unless (length and ref and ref ne 'SCALAR');
+ if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or
+ UNIVERSAL::can($_, 'nested'))
+ {
+ $_->nested($self);
+ }
+ }
+}
+
+## Private subroutine to unset child->parent links
+
+sub _unset_child2parent_links {
+ my $self = shift;
+ $self->{'-parent_sequence'} = undef;
+ my $ptree = $self->{'-ptree'};
+ for (@$ptree) {
+ next unless (length and ref and ref ne 'SCALAR');
+ $_->_unset_child2parent_links()
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<prepend()>
+
+ $pod_seq->prepend($text);
+ $pod_seq1->prepend($pod_seq2);
+
+Prepends the given string or parse-tree or sequence object to the parse-tree
+of this interior sequence.
+
+=cut
+
+sub prepend {
+ my $self = shift;
+ $self->{'-ptree'}->prepend(@_);
+ _set_child2parent_links($self, @_);
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<append()>
+
+ $pod_seq->append($text);
+ $pod_seq1->append($pod_seq2);
+
+Appends the given string or parse-tree or sequence object to the parse-tree
+of this interior sequence.
+
+=cut
+
+sub append {
+ my $self = shift;
+ $self->{'-ptree'}->append(@_);
+ _set_child2parent_links($self, @_);
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<nested()>
+
+ $outer_seq = $pod_seq->nested || print "not nested";
+
+If this interior sequence is nested inside of another interior
+sequence, then the outer/parent sequence that contains it is
+returned. Otherwise C<undef> is returned.
+
+=cut
+
+sub nested {
+ my $self = shift;
+ (@_ == 1) and $self->{'-parent_sequence'} = shift;
+ return $self->{'-parent_sequence'} || undef;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<raw_text()>
+
+ my $seq_raw_text = $pod_seq->raw_text();
+
+This method will return the I<raw> text of the POD interior sequence,
+exactly as it appeared in the input.
+
+=cut
+
+sub raw_text {
+ my $self = shift;
+ my $text = $self->{'-name'} . $self->{'-ldelim'};
+ for ( $self->{'-ptree'}->children ) {
+ $text .= (ref $_) ? $_->raw_text : $_;
+ }
+ $text .= $self->{'-rdelim'};
+ return $text;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<left_delimiter()>
+
+ my $ldelim = $pod_seq->left_delimiter();
+
+The leftmost delimiter beginning the argument text to the interior
+sequence (should be "<").
+
+=cut
+
+sub left_delimiter {
+ (@_ > 1) and $_[0]->{'-ldelim'} = $_[1];
+ return $_[0]->{'-ldelim'};
+}
+
+## let ldelim() be an alias for left_delimiter()
+*ldelim = \&left_delimiter;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<right_delimiter()>
+
+The rightmost delimiter beginning the argument text to the interior
+sequence (should be ">").
+
+=cut
+
+sub right_delimiter {
+ (@_ > 1) and $_[0]->{'-rdelim'} = $_[1];
+ return $_[0]->{'-rdelim'};
+}
+
+## let rdelim() be an alias for right_delimiter()
+*rdelim = \&right_delimiter;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<parse_tree()>
+
+ my $ptree = $pod_parser->parse_text($paragraph_text);
+ $pod_seq->parse_tree( $ptree );
+ $ptree = $pod_seq->parse_tree();
+
+This method will get/set the corresponding parse-tree of the interior
+sequence's text.
+
+=cut
+
+sub parse_tree {
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
+ return $_[0]->{'-ptree'};
+}
+
+## let ptree() be an alias for parse_tree()
+*ptree = \&parse_tree;
+
+##---------------------------------------------------------------------------
+
+=head2 $pod_seq-E<gt>B<file_line()>
+
+ my ($filename, $line_number) = $pod_seq->file_line();
+ my $position = $pod_seq->file_line();
+
+Returns the current filename and line number for the interior sequence
+object. If called in a list context, it returns a list of two
+elements: first the filename, then the line number. If called in
+a scalar context, it returns a string containing the filename, followed
+by a colon (':'), followed by the line number.
+
+=cut
+
+sub file_line {
+ my @loc = ($_[0]->{'-file'} || '<unknown-file>',
+ $_[0]->{'-line'} || 0);
+ return (wantarray) ? @loc : join(':', @loc);
+}
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::InteriorSequence::B<DESTROY()>
+
+This method performs any necessary cleanup for the interior-sequence.
+If you override this method then it is B<imperative> that you invoke
+the parent method from within your own method, otherwise
+I<interior-sequence storage will not be reclaimed upon destruction!>
+
+=cut
+
+sub DESTROY {
+ ## We need to get rid of all child->parent pointers throughout the
+ ## tree so their reference counts will go to zero and they can be
+ ## garbage-collected
+ _unset_child2parent_links(@_);
+}
+
+##---------------------------------------------------------------------------
+
+#############################################################################
+
+package Pod::ParseTree;
+
+##---------------------------------------------------------------------------
+
+=head1 B<Pod::ParseTree>
+
+This object corresponds to a tree of parsed POD text. As POD text is
+scanned from left to right, it is parsed into an ordered list of
+text-strings and B<Pod::InteriorSequence> objects (in order of
+appearance). A B<Pod::ParseTree> object corresponds to this list of
+strings and sequences. Each interior sequence in the parse-tree may
+itself contain a parse-tree (since interior sequences may be nested).
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head2 Pod::ParseTree-E<gt>B<new()>
+
+ my $ptree1 = Pod::ParseTree->new;
+ my $ptree2 = new Pod::ParseTree;
+ my $ptree4 = Pod::ParseTree->new($array_ref);
+ my $ptree3 = new Pod::ParseTree($array_ref);
+
+This is a class method that constructs a C<Pod::Parse_tree> object and
+returns a reference to the new parse-tree. If a single-argument is given,
+it must be a reference to an array, and is used to initialize the root
+(top) of the parse tree.
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my $this = shift;
+ my $class = ref($this) || $this;
+
+ my $self = (@_ == 1 and ref $_[0]) ? $_[0] : [];
+
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<top()>
+
+ my $top_node = $ptree->top();
+ $ptree->top( $top_node );
+ $ptree->top( @children );
+
+This method gets/sets the top node of the parse-tree. If no arguments are
+given, it returns the topmost node in the tree (the root), which is also
+a B<Pod::ParseTree>. If it is given a single argument that is a reference,
+then the reference is assumed to a parse-tree and becomes the new top node.
+Otherwise, if arguments are given, they are treated as the new list of
+children for the top node.
+
+=cut
+
+sub top {
+ my $self = shift;
+ if (@_ > 0) {
+ @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
+ }
+ return $self;
+}
+
+## let parse_tree() & ptree() be aliases for the 'top' method
+*parse_tree = *ptree = \&top;
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<children()>
+
+This method gets/sets the children of the top node in the parse-tree.
+If no arguments are given, it returns the list (array) of children
+(each of which should be either a string or a B<Pod::InteriorSequence>.
+Otherwise, if arguments are given, they are treated as the new list of
+children for the top node.
+
+=cut
+
+sub children {
+ my $self = shift;
+ if (@_ > 0) {
+ @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
+ }
+ return @{ $self };
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<prepend()>
+
+This method prepends the given text or parse-tree to the current parse-tree.
+If the first item on the parse-tree is text and the argument is also text,
+then the text is prepended to the first item (not added as a separate string).
+Otherwise the argument is added as a new string or parse-tree I<before>
+the current one.
+
+=cut
+
+use vars qw(@ptree); ## an alias used for performance reasons
+
+sub prepend {
+ my $self = shift;
+ local *ptree = $self;
+ for (@_) {
+ next unless length;
+ if (@ptree && !(ref $ptree[0]) && !(ref $_)) {
+ $ptree[0] = $_ . $ptree[0];
+ }
+ else {
+ unshift @ptree, $_;
+ }
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head2 $ptree-E<gt>B<append()>
+
+This method appends the given text or parse-tree to the current parse-tree.
+If the last item on the parse-tree is text and the argument is also text,
+then the text is appended to the last item (not added as a separate string).
+Otherwise the argument is added as a new string or parse-tree I<after>
+the current one.
+
+=cut
+
+sub append {
+ my $self = shift;
+ local *ptree = $self;
+ my $can_append = @ptree && !(ref $ptree[-1]);
+ for (@_) {
+ if (ref) {
+ push @ptree, $_;
+ }
+ elsif(!length) {
+ next;
+ }
+ elsif ($can_append) {
+ $ptree[-1] .= $_;
+ }
+ else {
+ push @ptree, $_;
+ }
+ }
+}
+
+=head2 $ptree-E<gt>B<raw_text()>
+
+ my $ptree_raw_text = $ptree->raw_text();
+
+This method will return the I<raw> text of the POD parse-tree
+exactly as it appeared in the input.
+
+=cut
+
+sub raw_text {
+ my $self = shift;
+ my $text = '';
+ for ( @$self ) {
+ $text .= (ref $_) ? $_->raw_text : $_;
+ }
+ return $text;
+}
+
+##---------------------------------------------------------------------------
+
+## Private routines to set/unset child->parent links
+
+sub _unset_child2parent_links {
+ my $self = shift;
+ local *ptree = $self;
+ for (@ptree) {
+ next unless (defined and length and ref and ref ne 'SCALAR');
+ $_->_unset_child2parent_links()
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
+ }
+}
+
+sub _set_child2parent_links {
+ ## nothing to do, Pod::ParseTrees cant have parent pointers
+}
+
+=head2 Pod::ParseTree::B<DESTROY()>
+
+This method performs any necessary cleanup for the parse-tree.
+If you override this method then it is B<imperative>
+that you invoke the parent method from within your own method,
+otherwise I<parse-tree storage will not be reclaimed upon destruction!>
+
+=cut
+
+sub DESTROY {
+ ## We need to get rid of all child->parent pointers throughout the
+ ## tree so their reference counts will go to zero and they can be
+ ## garbage-collected
+ _unset_child2parent_links(@_);
+}
+
+#############################################################################
+
+=head1 SEE ALSO
+
+See L<Pod::Parser>, L<Pod::Select>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/LaTeX.pm b/Master/tlpkg/tlperl.straw/lib/Pod/LaTeX.pm
new file mode 100755
index 00000000000..9d3a905258f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/LaTeX.pm
@@ -0,0 +1,1876 @@
+package Pod::LaTeX;
+
+=head1 NAME
+
+Pod::LaTeX - Convert Pod data to formatted Latex
+
+=head1 SYNOPSIS
+
+ use Pod::LaTeX;
+ my $parser = Pod::LaTeX->new ( );
+
+ $parser->parse_from_filehandle;
+
+ $parser->parse_from_file ('file.pod', 'file.tex');
+
+=head1 DESCRIPTION
+
+C<Pod::LaTeX> is a module to convert documentation in the Pod format
+into Latex. The L<B<pod2latex>|pod2latex> X<pod2latex> command uses
+this module for translation.
+
+C<Pod::LaTeX> is a derived class from L<Pod::Select|Pod::Select>.
+
+=cut
+
+
+use strict;
+require Pod::ParseUtils;
+use base qw/ Pod::Select /;
+
+# use Data::Dumper; # for debugging
+use Carp;
+
+use vars qw/ $VERSION %HTML_Escapes @LatexSections /;
+
+$VERSION = '0.58';
+
+# Definitions of =headN -> latex mapping
+@LatexSections = (qw/
+ chapter
+ section
+ subsection
+ subsubsection
+ paragraph
+ subparagraph
+ /);
+
+# Standard escape sequences converted to Latex.
+# The Unicode name of each character is given in the comments.
+# Complete LaTeX set added by Peter Acklam.
+
+%HTML_Escapes = (
+ 'sol' => '\textfractionsolidus{}', # xxx - or should it be just '/'
+ 'verbar' => '|',
+
+ # The stuff below is based on the information available at
+ # http://www.w3.org/TR/html401/sgml/entities.html
+
+ # All characters in the range 0xA0-0xFF of the ISO 8859-1 character set.
+ # Several of these characters require the `textcomp' LaTeX package.
+ 'nbsp' => q|~|, # 0xA0 - no-break space = non-breaking space
+ 'iexcl' => q|\textexclamdown{}|, # 0xA1 - inverted exclamation mark
+ 'cent' => q|\textcent{}|, # 0xA2 - cent sign
+ 'pound' => q|\textsterling{}|, # 0xA3 - pound sign
+ 'curren' => q|\textcurrency{}|, # 0xA4 - currency sign
+ 'yen' => q|\textyen{}|, # 0xA5 - yen sign = yuan sign
+ 'brvbar' => q|\textbrokenbar{}|, # 0xA6 - broken bar = broken vertical bar
+ 'sect' => q|\textsection{}|, # 0xA7 - section sign
+ 'uml' => q|\textasciidieresis{}|, # 0xA8 - diaeresis = spacing diaeresis
+ 'copy' => q|\textcopyright{}|, # 0xA9 - copyright sign
+ 'ordf' => q|\textordfeminine{}|, # 0xAA - feminine ordinal indicator
+ 'laquo' => q|\guillemotleft{}|, # 0xAB - left-pointing double angle quotation mark = left pointing guillemet
+ 'not' => q|\textlnot{}|, # 0xAC - not sign
+ 'shy' => q|\-|, # 0xAD - soft hyphen = discretionary hyphen
+ 'reg' => q|\textregistered{}|, # 0xAE - registered sign = registered trade mark sign
+ 'macr' => q|\textasciimacron{}|, # 0xAF - macron = spacing macron = overline = APL overbar
+ 'deg' => q|\textdegree{}|, # 0xB0 - degree sign
+ 'plusmn' => q|\textpm{}|, # 0xB1 - plus-minus sign = plus-or-minus sign
+ 'sup2' => q|\texttwosuperior{}|, # 0xB2 - superscript two = superscript digit two = squared
+ 'sup3' => q|\textthreesuperior{}|, # 0xB3 - superscript three = superscript digit three = cubed
+ 'acute' => q|\textasciiacute{}|, # 0xB4 - acute accent = spacing acute
+ 'micro' => q|\textmu{}|, # 0xB5 - micro sign
+ 'para' => q|\textparagraph{}|, # 0xB6 - pilcrow sign = paragraph sign
+ 'middot' => q|\textperiodcentered{}|, # 0xB7 - middle dot = Georgian comma = Greek middle dot
+ 'cedil' => q|\c{}|, # 0xB8 - cedilla = spacing cedilla
+ 'sup1' => q|\textonesuperior{}|, # 0xB9 - superscript one = superscript digit one
+ 'ordm' => q|\textordmasculine{}|, # 0xBA - masculine ordinal indicator
+ 'raquo' => q|\guillemotright{}|, # 0xBB - right-pointing double angle quotation mark = right pointing guillemet
+ 'frac14' => q|\textonequarter{}|, # 0xBC - vulgar fraction one quarter = fraction one quarter
+ 'frac12' => q|\textonehalf{}|, # 0xBD - vulgar fraction one half = fraction one half
+ 'frac34' => q|\textthreequarters{}|, # 0xBE - vulgar fraction three quarters = fraction three quarters
+ 'iquest' => q|\textquestiondown{}|, # 0xBF - inverted question mark = turned question mark
+ 'Agrave' => q|\`A|, # 0xC0 - latin capital letter A with grave = latin capital letter A grave
+ 'Aacute' => q|\'A|, # 0xC1 - latin capital letter A with acute
+ 'Acirc' => q|\^A|, # 0xC2 - latin capital letter A with circumflex
+ 'Atilde' => q|\~A|, # 0xC3 - latin capital letter A with tilde
+ 'Auml' => q|\"A|, # 0xC4 - latin capital letter A with diaeresis
+ 'Aring' => q|\AA{}|, # 0xC5 - latin capital letter A with ring above = latin capital letter A ring
+ 'AElig' => q|\AE{}|, # 0xC6 - latin capital letter AE = latin capital ligature AE
+ 'Ccedil' => q|\c{C}|, # 0xC7 - latin capital letter C with cedilla
+ 'Egrave' => q|\`E|, # 0xC8 - latin capital letter E with grave
+ 'Eacute' => q|\'E|, # 0xC9 - latin capital letter E with acute
+ 'Ecirc' => q|\^E|, # 0xCA - latin capital letter E with circumflex
+ 'Euml' => q|\"E|, # 0xCB - latin capital letter E with diaeresis
+ 'Igrave' => q|\`I|, # 0xCC - latin capital letter I with grave
+ 'Iacute' => q|\'I|, # 0xCD - latin capital letter I with acute
+ 'Icirc' => q|\^I|, # 0xCE - latin capital letter I with circumflex
+ 'Iuml' => q|\"I|, # 0xCF - latin capital letter I with diaeresis
+ 'ETH' => q|\DH{}|, # 0xD0 - latin capital letter ETH
+ 'Ntilde' => q|\~N|, # 0xD1 - latin capital letter N with tilde
+ 'Ograve' => q|\`O|, # 0xD2 - latin capital letter O with grave
+ 'Oacute' => q|\'O|, # 0xD3 - latin capital letter O with acute
+ 'Ocirc' => q|\^O|, # 0xD4 - latin capital letter O with circumflex
+ 'Otilde' => q|\~O|, # 0xD5 - latin capital letter O with tilde
+ 'Ouml' => q|\"O|, # 0xD6 - latin capital letter O with diaeresis
+ 'times' => q|\texttimes{}|, # 0xD7 - multiplication sign
+ 'Oslash' => q|\O{}|, # 0xD8 - latin capital letter O with stroke = latin capital letter O slash
+ 'Ugrave' => q|\`U|, # 0xD9 - latin capital letter U with grave
+ 'Uacute' => q|\'U|, # 0xDA - latin capital letter U with acute
+ 'Ucirc' => q|\^U|, # 0xDB - latin capital letter U with circumflex
+ 'Uuml' => q|\"U|, # 0xDC - latin capital letter U with diaeresis
+ 'Yacute' => q|\'Y|, # 0xDD - latin capital letter Y with acute
+ 'THORN' => q|\TH{}|, # 0xDE - latin capital letter THORN
+ 'szlig' => q|\ss{}|, # 0xDF - latin small letter sharp s = ess-zed
+ 'agrave' => q|\`a|, # 0xE0 - latin small letter a with grave = latin small letter a grave
+ 'aacute' => q|\'a|, # 0xE1 - latin small letter a with acute
+ 'acirc' => q|\^a|, # 0xE2 - latin small letter a with circumflex
+ 'atilde' => q|\~a|, # 0xE3 - latin small letter a with tilde
+ 'auml' => q|\"a|, # 0xE4 - latin small letter a with diaeresis
+ 'aring' => q|\aa{}|, # 0xE5 - latin small letter a with ring above = latin small letter a ring
+ 'aelig' => q|\ae{}|, # 0xE6 - latin small letter ae = latin small ligature ae
+ 'ccedil' => q|\c{c}|, # 0xE7 - latin small letter c with cedilla
+ 'egrave' => q|\`e|, # 0xE8 - latin small letter e with grave
+ 'eacute' => q|\'e|, # 0xE9 - latin small letter e with acute
+ 'ecirc' => q|\^e|, # 0xEA - latin small letter e with circumflex
+ 'euml' => q|\"e|, # 0xEB - latin small letter e with diaeresis
+ 'igrave' => q|\`i|, # 0xEC - latin small letter i with grave
+ 'iacute' => q|\'i|, # 0xED - latin small letter i with acute
+ 'icirc' => q|\^i|, # 0xEE - latin small letter i with circumflex
+ 'iuml' => q|\"i|, # 0xEF - latin small letter i with diaeresis
+ 'eth' => q|\dh{}|, # 0xF0 - latin small letter eth
+ 'ntilde' => q|\~n|, # 0xF1 - latin small letter n with tilde
+ 'ograve' => q|\`o|, # 0xF2 - latin small letter o with grave
+ 'oacute' => q|\'o|, # 0xF3 - latin small letter o with acute
+ 'ocirc' => q|\^o|, # 0xF4 - latin small letter o with circumflex
+ 'otilde' => q|\~o|, # 0xF5 - latin small letter o with tilde
+ 'ouml' => q|\"o|, # 0xF6 - latin small letter o with diaeresis
+ 'divide' => q|\textdiv{}|, # 0xF7 - division sign
+ 'oslash' => q|\o{}|, # 0xF8 - latin small letter o with stroke, = latin small letter o slash
+ 'ugrave' => q|\`u|, # 0xF9 - latin small letter u with grave
+ 'uacute' => q|\'u|, # 0xFA - latin small letter u with acute
+ 'ucirc' => q|\^u|, # 0xFB - latin small letter u with circumflex
+ 'uuml' => q|\"u|, # 0xFC - latin small letter u with diaeresis
+ 'yacute' => q|\'y|, # 0xFD - latin small letter y with acute
+ 'thorn' => q|\th{}|, # 0xFE - latin small letter thorn
+ 'yuml' => q|\"y|, # 0xFF - latin small letter y with diaeresis
+
+ # Latin Extended-B
+ 'fnof' => q|\textflorin{}|, # latin small f with hook = function = florin
+
+ # Greek
+ 'Alpha' => q|$\mathrm{A}$|, # greek capital letter alpha
+ 'Beta' => q|$\mathrm{B}$|, # greek capital letter beta
+ 'Gamma' => q|$\Gamma$|, # greek capital letter gamma
+ 'Delta' => q|$\Delta$|, # greek capital letter delta
+ 'Epsilon' => q|$\mathrm{E}$|, # greek capital letter epsilon
+ 'Zeta' => q|$\mathrm{Z}$|, # greek capital letter zeta
+ 'Eta' => q|$\mathrm{H}$|, # greek capital letter eta
+ 'Theta' => q|$\Theta$|, # greek capital letter theta
+ 'Iota' => q|$\mathrm{I}$|, # greek capital letter iota
+ 'Kappa' => q|$\mathrm{K}$|, # greek capital letter kappa
+ 'Lambda' => q|$\Lambda$|, # greek capital letter lambda
+ 'Mu' => q|$\mathrm{M}$|, # greek capital letter mu
+ 'Nu' => q|$\mathrm{N}$|, # greek capital letter nu
+ 'Xi' => q|$\Xi$|, # greek capital letter xi
+ 'Omicron' => q|$\mathrm{O}$|, # greek capital letter omicron
+ 'Pi' => q|$\Pi$|, # greek capital letter pi
+ 'Rho' => q|$\mathrm{R}$|, # greek capital letter rho
+ 'Sigma' => q|$\Sigma$|, # greek capital letter sigma
+ 'Tau' => q|$\mathrm{T}$|, # greek capital letter tau
+ 'Upsilon' => q|$\Upsilon$|, # greek capital letter upsilon
+ 'Phi' => q|$\Phi$|, # greek capital letter phi
+ 'Chi' => q|$\mathrm{X}$|, # greek capital letter chi
+ 'Psi' => q|$\Psi$|, # greek capital letter psi
+ 'Omega' => q|$\Omega$|, # greek capital letter omega
+
+ 'alpha' => q|$\alpha$|, # greek small letter alpha
+ 'beta' => q|$\beta$|, # greek small letter beta
+ 'gamma' => q|$\gamma$|, # greek small letter gamma
+ 'delta' => q|$\delta$|, # greek small letter delta
+ 'epsilon' => q|$\epsilon$|, # greek small letter epsilon
+ 'zeta' => q|$\zeta$|, # greek small letter zeta
+ 'eta' => q|$\eta$|, # greek small letter eta
+ 'theta' => q|$\theta$|, # greek small letter theta
+ 'iota' => q|$\iota$|, # greek small letter iota
+ 'kappa' => q|$\kappa$|, # greek small letter kappa
+ 'lambda' => q|$\lambda$|, # greek small letter lambda
+ 'mu' => q|$\mu$|, # greek small letter mu
+ 'nu' => q|$\nu$|, # greek small letter nu
+ 'xi' => q|$\xi$|, # greek small letter xi
+ 'omicron' => q|$o$|, # greek small letter omicron
+ 'pi' => q|$\pi$|, # greek small letter pi
+ 'rho' => q|$\rho$|, # greek small letter rho
+# 'sigmaf' => q||, # greek small letter final sigma
+ 'sigma' => q|$\sigma$|, # greek small letter sigma
+ 'tau' => q|$\tau$|, # greek small letter tau
+ 'upsilon' => q|$\upsilon$|, # greek small letter upsilon
+ 'phi' => q|$\phi$|, # greek small letter phi
+ 'chi' => q|$\chi$|, # greek small letter chi
+ 'psi' => q|$\psi$|, # greek small letter psi
+ 'omega' => q|$\omega$|, # greek small letter omega
+# 'thetasym' => q||, # greek small letter theta symbol
+# 'upsih' => q||, # greek upsilon with hook symbol
+# 'piv' => q||, # greek pi symbol
+
+ # General Punctuation
+ 'bull' => q|\textbullet{}|, # bullet = black small circle
+ # bullet is NOT the same as bullet operator
+ 'hellip' => q|\textellipsis{}|, # horizontal ellipsis = three dot leader
+ 'prime' => q|\textquotesingle{}|, # prime = minutes = feet
+ 'Prime' => q|\textquotedbl{}|, # double prime = seconds = inches
+ 'oline' => q|\textasciimacron{}|, # overline = spacing overscore
+ 'frasl' => q|\textfractionsolidus{}|, # fraction slash
+
+ # Letterlike Symbols
+ 'weierp' => q|$\wp$|, # script capital P = power set = Weierstrass p
+ 'image' => q|$\Re$|, # blackletter capital I = imaginary part
+ 'real' => q|$\Im$|, # blackletter capital R = real part symbol
+ 'trade' => q|\texttrademark{}|, # trade mark sign
+# 'alefsym' => q||, # alef symbol = first transfinite cardinal
+ # alef symbol is NOT the same as hebrew letter alef, although the same
+ # glyph could be used to depict both characters
+
+ # Arrows
+ 'larr' => q|\textleftarrow{}|, # leftwards arrow
+ 'uarr' => q|\textuparrow{}|, # upwards arrow
+ 'rarr' => q|\textrightarrow{}|, # rightwards arrow
+ 'darr' => q|\textdownarrow{}|, # downwards arrow
+ 'harr' => q|$\leftrightarrow$|, # left right arrow
+# 'crarr' => q||, # downwards arrow with corner leftwards = carriage return
+ 'lArr' => q|$\Leftarrow$|, # leftwards double arrow
+ # ISO 10646 does not say that lArr is the same as the 'is implied by'
+ # arrow but also does not have any other character for that function. So
+ # lArr can be used for 'is implied by' as ISOtech suggests
+ 'uArr' => q|$\Uparrow$|, # upwards double arrow
+ 'rArr' => q|$\Rightarrow$|, # rightwards double arrow
+ # ISO 10646 does not say this is the 'implies' character but does not
+ # have another character with this function so ? rArr can be used for
+ # 'implies' as ISOtech suggests
+ 'dArr' => q|$\Downarrow$|, # downwards double arrow
+ 'hArr' => q|$\Leftrightarrow$|, # left right double arrow
+
+ # Mathematical Operators.
+ # Some of these require the `amssymb' package.
+ 'forall' => q|$\forall$|, # for all
+ 'part' => q|$\partial$|, # partial differential
+ 'exist' => q|$\exists$|, # there exists
+ 'empty' => q|$\emptyset$|, # empty set = null set = diameter
+ 'nabla' => q|$\nabla$|, # nabla = backward difference
+ 'isin' => q|$\in$|, # element of
+ 'notin' => q|$\notin$|, # not an element of
+ 'ni' => q|$\ni$|, # contains as member
+ 'prod' => q|$\prod$|, # n-ary product = product sign
+ # prod is NOT the same character as 'greek capital letter pi' though the
+ # same glyph might be used for both
+ 'sum' => q|$\sum$|, # n-ary sumation
+ # sum is NOT the same character as 'greek capital letter sigma' though
+ # the same glyph might be used for both
+ 'minus' => q|$-$|, # minus sign
+ 'lowast' => q|$\ast$|, # asterisk operator
+ 'radic' => q|$\surd$|, # square root = radical sign
+ 'prop' => q|$\propto$|, # proportional to
+ 'infin' => q|$\infty$|, # infinity
+ 'ang' => q|$\angle$|, # angle
+ 'and' => q|$\wedge$|, # logical and = wedge
+ 'or' => q|$\vee$|, # logical or = vee
+ 'cap' => q|$\cap$|, # intersection = cap
+ 'cup' => q|$\cup$|, # union = cup
+ 'int' => q|$\int$|, # integral
+ 'there4' => q|$\therefore$|, # therefore
+ 'sim' => q|$\sim$|, # tilde operator = varies with = similar to
+ # tilde operator is NOT the same character as the tilde
+ 'cong' => q|$\cong$|, # approximately equal to
+ 'asymp' => q|$\asymp$|, # almost equal to = asymptotic to
+ 'ne' => q|$\neq$|, # not equal to
+ 'equiv' => q|$\equiv$|, # identical to
+ 'le' => q|$\leq$|, # less-than or equal to
+ 'ge' => q|$\geq$|, # greater-than or equal to
+ 'sub' => q|$\subset$|, # subset of
+ 'sup' => q|$\supset$|, # superset of
+ # note that nsup, 'not a superset of' is not covered by the Symbol font
+ # encoding and is not included.
+ 'nsub' => q|$\not\subset$|, # not a subset of
+ 'sube' => q|$\subseteq$|, # subset of or equal to
+ 'supe' => q|$\supseteq$|, # superset of or equal to
+ 'oplus' => q|$\oplus$|, # circled plus = direct sum
+ 'otimes' => q|$\otimes$|, # circled times = vector product
+ 'perp' => q|$\perp$|, # up tack = orthogonal to = perpendicular
+ 'sdot' => q|$\cdot$|, # dot operator
+ # dot operator is NOT the same character as middle dot
+
+ # Miscellaneous Technical
+ 'lceil' => q|$\lceil$|, # left ceiling = apl upstile
+ 'rceil' => q|$\rceil$|, # right ceiling
+ 'lfloor' => q|$\lfloor$|, # left floor = apl downstile
+ 'rfloor' => q|$\rfloor$|, # right floor
+ 'lang' => q|$\langle$|, # left-pointing angle bracket = bra
+ # lang is NOT the same character as 'less than' or 'single left-pointing
+ # angle quotation mark'
+ 'rang' => q|$\rangle$|, # right-pointing angle bracket = ket
+ # rang is NOT the same character as 'greater than' or 'single
+ # right-pointing angle quotation mark'
+
+ # Geometric Shapes
+ 'loz' => q|$\lozenge$|, # lozenge
+
+ # Miscellaneous Symbols
+ 'spades' => q|$\spadesuit$|, # black spade suit
+ 'clubs' => q|$\clubsuit$|, # black club suit = shamrock
+ 'hearts' => q|$\heartsuit$|, # black heart suit = valentine
+ 'diams' => q|$\diamondsuit$|, # black diamond suit
+
+ # C0 Controls and Basic Latin
+ 'quot' => q|"|, # quotation mark = APL quote ["]
+ 'amp' => q|\&|, # ampersand
+ 'lt' => q|<|, # less-than sign
+ 'gt' => q|>|, # greater-than sign
+ 'OElig' => q|\OE{}|, # latin capital ligature OE
+ 'oelig' => q|\oe{}|, # latin small ligature oe
+ 'Scaron' => q|\v{S}|, # latin capital letter S with caron
+ 'scaron' => q|\v{s}|, # latin small letter s with caron
+ 'Yuml' => q|\"Y|, # latin capital letter Y with diaeresis
+ 'circ' => q|\textasciicircum{}|, # modifier letter circumflex accent
+ 'tilde' => q|\textasciitilde{}|, # small tilde
+ 'ensp' => q|\phantom{n}|, # en space
+ 'emsp' => q|\hspace{1em}|, # em space
+ 'thinsp' => q|\,|, # thin space
+ 'zwnj' => q|{}|, # zero width non-joiner
+# 'zwj' => q||, # zero width joiner
+# 'lrm' => q||, # left-to-right mark
+# 'rlm' => q||, # right-to-left mark
+ 'ndash' => q|--|, # en dash
+ 'mdash' => q|---|, # em dash
+ 'lsquo' => q|\textquoteleft{}|, # left single quotation mark
+ 'rsquo' => q|\textquoteright{}|, # right single quotation mark
+ 'sbquo' => q|\quotesinglbase{}|, # single low-9 quotation mark
+ 'ldquo' => q|\textquotedblleft{}|, # left double quotation mark
+ 'rdquo' => q|\textquotedblright{}|, # right double quotation mark
+ 'bdquo' => q|\quotedblbase{}|, # double low-9 quotation mark
+ 'dagger' => q|\textdagger{}|, # dagger
+ 'Dagger' => q|\textdaggerdbl{}|, # double dagger
+ 'permil' => q|\textperthousand{}|, # per mille sign
+ 'lsaquo' => q|\guilsinglleft{}|, # single left-pointing angle quotation mark
+ 'rsaquo' => q|\guilsinglright{}|, # single right-pointing angle quotation mark
+ 'euro' => q|\texteuro{}|, # euro sign
+);
+
+=head1 OBJECT METHODS
+
+The following methods are provided in this module. Methods inherited
+from C<Pod::Select> are not described in the public interface.
+
+=over 4
+
+=begin __PRIVATE__
+
+=item C<initialize>
+
+Initialise the object. This method is subclassed from C<Pod::Parser>.
+The base class method is invoked. This method defines the default
+behaviour of the object unless overridden by supplying arguments to
+the constructor.
+
+Internal settings are defaulted as well as the public instance data.
+Internal hash values are accessed directly (rather than through
+a method) and start with an underscore.
+
+This method should not be invoked by the user directly.
+
+=end __PRIVATE__
+
+=cut
+
+
+
+# - An array for nested lists
+
+# Arguments have already been read by this point
+
+sub initialize {
+ my $self = shift;
+
+ # print Dumper($self);
+
+ # Internals
+ $self->{_Lists} = []; # For nested lists
+ $self->{_suppress_all_para} = 0; # For =begin blocks
+ $self->{_dont_modify_any_para}=0; # For =begin blocks
+ $self->{_CURRENT_HEAD1} = ''; # Name of current HEAD1 section
+
+ # Options - only initialise if not already set
+
+ # Cause the '=head1 NAME' field to be treated specially
+ # The contents of the NAME paragraph will be converted
+ # to a section title. All subsequent =head1 will be converted
+ # to =head2 and down. Will not affect =head1's prior to NAME
+ # Assumes: 'Module - purpose' format
+ # Also creates a purpose field
+ # The name is used for Labeling of the subsequent subsections
+ $self->{ReplaceNAMEwithSection} = 0
+ unless exists $self->{ReplaceNAMEwithSection};
+ $self->{AddPreamble} = 1 # make full latex document
+ unless exists $self->{AddPreamble};
+ $self->{StartWithNewPage} = 0 # Start new page for pod section
+ unless exists $self->{StartWithNewPage};
+ $self->{TableOfContents} = 0 # Add table of contents
+ unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1
+ $self->{AddPostamble} = 1 # Add closing latex code at end
+ unless exists $self->{AddPostamble}; # effectively end{document} and index
+ $self->{MakeIndex} = 1 # Add index (only relevant AddPostamble
+ unless exists $self->{MakeIndex}; # and AddPreamble)
+
+ $self->{UniqueLabels} = 1 # Use label unique for each pod
+ unless exists $self->{UniqueLabels}; # either based on the filename
+ # or supplied
+
+ # Control the level of =head1. default is \section
+ #
+ $self->{Head1Level} = 1 # Offset in latex sections
+ unless exists $self->{Head1Level}; # 0 is chapter, 2 is subsection
+
+ # Control at which level numbering of sections is turned off
+ # ie subsection becomes subsection*
+ # The numbering is relative to the latex sectioning commands
+ # and is independent of Pod heading level
+ # default is to number \section but not \subsection
+ $self->{LevelNoNum} = 2
+ unless exists $self->{LevelNoNum};
+
+ # Label to be used as prefix to all internal section names
+ # If not defined will attempt to derive it from the filename
+ # This can not happen when running parse_from_filehandle though
+ # hence the ability to set the label externally
+ # The label could then be Pod::Parser_DESCRIPTION or somesuch
+
+ $self->{Label} = undef # label to be used as prefix
+ unless exists $self->{Label}; # to all internal section names
+
+ # These allow the caller to add arbritrary latex code to
+ # start and end of document. AddPreamble and AddPostamble are ignored
+ # if these are set.
+ # Also MakeIndex and TableOfContents are also ignored.
+ $self->{UserPreamble} = undef # User supplied start (AddPreamble =1)
+ unless exists $self->{Label};
+ $self->{UserPostamble} = undef # Use supplied end (AddPostamble=1)
+ unless exists $self->{Label};
+
+ # Run base initialize
+ $self->SUPER::initialize;
+
+}
+
+=back
+
+=head2 Data Accessors
+
+The following methods are provided for accessing instance data. These
+methods should be used for accessing configuration parameters rather
+than assuming the object is a hash.
+
+Default values can be supplied by using these names as keys to a hash
+of arguments when using the C<new()> constructor.
+
+=over 4
+
+=item B<AddPreamble>
+
+Logical to control whether a C<latex> preamble is to be written.
+If true, a valid C<latex> preamble is written before the pod data is written.
+This is similar to:
+
+ \documentclass{article}
+ \usepackage[T1]{fontenc}
+ \usepackage{textcomp}
+ \begin{document}
+
+but will be more complicated if table of contents and indexing are required.
+Can be used to set or retrieve the current value.
+
+ $add = $parser->AddPreamble();
+ $parser->AddPreamble(1);
+
+If used in conjunction with C<AddPostamble> a full latex document will
+be written that could be immediately processed by C<latex>.
+
+For some pod escapes it may be necessary to include the amsmath
+package. This is not yet added to the preamble automaatically.
+
+=cut
+
+sub AddPreamble {
+ my $self = shift;
+ if (@_) {
+ $self->{AddPreamble} = shift;
+ }
+ return $self->{AddPreamble};
+}
+
+=item B<AddPostamble>
+
+Logical to control whether a standard C<latex> ending is written to the output
+file after the document has been processed.
+In its simplest form this is simply:
+
+ \end{document}
+
+but can be more complicated if a index is required.
+Can be used to set or retrieve the current value.
+
+ $add = $parser->AddPostamble();
+ $parser->AddPostamble(1);
+
+If used in conjunction with C<AddPreaamble> a full latex document will
+be written that could be immediately processed by C<latex>.
+
+=cut
+
+sub AddPostamble {
+ my $self = shift;
+ if (@_) {
+ $self->{AddPostamble} = shift;
+ }
+ return $self->{AddPostamble};
+}
+
+=item B<Head1Level>
+
+The C<latex> sectioning level that should be used to correspond to
+a pod C<=head1> directive. This can be used, for example, to turn
+a C<=head1> into a C<latex> C<subsection>. This should hold a number
+corresponding to the required position in an array containing the
+following elements:
+
+ [0] chapter
+ [1] section
+ [2] subsection
+ [3] subsubsection
+ [4] paragraph
+ [5] subparagraph
+
+Can be used to set or retrieve the current value:
+
+ $parser->Head1Level(2);
+ $sect = $parser->Head1Level;
+
+Setting this number too high can result in sections that may not be reproducible
+in the expected way. For example, setting this to 4 would imply that C<=head3>
+do not have a corresponding C<latex> section (C<=head1> would correspond to
+a C<paragraph>).
+
+A check is made to ensure that the supplied value is an integer in the
+range 0 to 5.
+
+Default is for a value of 1 (i.e. a C<section>).
+
+=cut
+
+sub Head1Level {
+ my $self = shift;
+ if (@_) {
+ my $arg = shift;
+ if ($arg =~ /^\d$/ && $arg <= $#LatexSections) {
+ $self->{Head1Level} = $arg;
+ } else {
+ carp "Head1Level supplied ($arg) must be integer in range 0 to ".$#LatexSections . "- Ignoring\n";
+ }
+ }
+ return $self->{Head1Level};
+}
+
+=item B<Label>
+
+This is the label that is prefixed to all C<latex> label and index
+entries to make them unique. In general, pods have similarly titled
+sections (NAME, DESCRIPTION etc) and a C<latex> label will be multiply
+defined if more than one pod document is to be included in a single
+C<latex> file. To overcome this, this label is prefixed to a label
+whenever a label is required (joined with an underscore) or to an
+index entry (joined by an exclamation mark which is the normal index
+separator). For example, C<\label{text}> becomes C<\label{Label_text}>.
+
+Can be used to set or retrieve the current value:
+
+ $label = $parser->Label;
+ $parser->Label($label);
+
+This label is only used if C<UniqueLabels> is true.
+Its value is set automatically from the C<NAME> field
+if C<ReplaceNAMEwithSection> is true. If this is not the case
+it must be set manually before starting the parse.
+
+Default value is C<undef>.
+
+=cut
+
+sub Label {
+ my $self = shift;
+ if (@_) {
+ $self->{Label} = shift;
+ }
+ return $self->{Label};
+}
+
+=item B<LevelNoNum>
+
+Control the point at which C<latex> section numbering is turned off.
+For example, this can be used to make sure that C<latex> sections
+are numbered but subsections are not.
+
+Can be used to set or retrieve the current value:
+
+ $lev = $parser->LevelNoNum;
+ $parser->LevelNoNum(2);
+
+The argument must be an integer between 0 and 5 and is the same as the
+number described in C<Head1Level> method description. The number has
+nothing to do with the pod heading number, only the C<latex> sectioning.
+
+Default is 2. (i.e. C<latex> subsections are written as C<subsection*>
+but sections are numbered).
+
+=cut
+
+sub LevelNoNum {
+ my $self = shift;
+ if (@_) {
+ $self->{LevelNoNum} = shift;
+ }
+ return $self->{LevelNoNum};
+}
+
+=item B<MakeIndex>
+
+Controls whether C<latex> commands for creating an index are to be inserted
+into the preamble and postamble
+
+ $makeindex = $parser->MakeIndex;
+ $parser->MakeIndex(0);
+
+Irrelevant if both C<AddPreamble> and C<AddPostamble> are false (or equivalently,
+C<UserPreamble> and C<UserPostamble> are set).
+
+Default is for an index to be created.
+
+=cut
+
+sub MakeIndex {
+ my $self = shift;
+ if (@_) {
+ $self->{MakeIndex} = shift;
+ }
+ return $self->{MakeIndex};
+}
+
+=item B<ReplaceNAMEwithSection>
+
+This controls whether the C<NAME> section in the pod is to be translated
+literally or converted to a slightly modified output where the section
+name is the pod name rather than "NAME".
+
+If true, the pod segment
+
+ =head1 NAME
+
+ pod::name - purpose
+
+ =head1 SYNOPSIS
+
+is converted to the C<latex>
+
+ \section{pod::name\label{pod_name}\index{pod::name}}
+
+ Purpose
+
+ \subsection*{SYNOPSIS\label{pod_name_SYNOPSIS}%
+ \index{pod::name!SYNOPSIS}}
+
+(dependent on the value of C<Head1Level> and C<LevelNoNum>). Note that
+subsequent C<head1> directives translate to subsections rather than
+sections and that the labels and index now include the pod name (dependent
+on the value of C<UniqueLabels>).
+
+The C<Label> is set from the pod name regardless of any current value
+of C<Label>.
+
+ $mod = $parser->ReplaceNAMEwithSection;
+ $parser->ReplaceNAMEwithSection(0);
+
+Default is to translate the pod literally.
+
+=cut
+
+sub ReplaceNAMEwithSection {
+ my $self = shift;
+ if (@_) {
+ $self->{ReplaceNAMEwithSection} = shift;
+ }
+ return $self->{ReplaceNAMEwithSection};
+}
+
+=item B<StartWithNewPage>
+
+If true, each pod translation will begin with a C<latex>
+C<\clearpage>.
+
+ $parser->StartWithNewPage(1);
+ $newpage = $parser->StartWithNewPage;
+
+Default is false.
+
+=cut
+
+sub StartWithNewPage {
+ my $self = shift;
+ if (@_) {
+ $self->{StartWithNewPage} = shift;
+ }
+ return $self->{StartWithNewPage};
+}
+
+=item B<TableOfContents>
+
+If true, a table of contents will be created.
+Irrelevant if C<AddPreamble> is false or C<UserPreamble>
+is set.
+
+ $toc = $parser->TableOfContents;
+ $parser->TableOfContents(1);
+
+Default is false.
+
+=cut
+
+sub TableOfContents {
+ my $self = shift;
+ if (@_) {
+ $self->{TableOfContents} = shift;
+ }
+ return $self->{TableOfContents};
+}
+
+=item B<UniqueLabels>
+
+If true, the translator will attempt to make sure that
+each C<latex> label or index entry will be uniquely identified
+by prefixing the contents of C<Label>. This allows
+multiple documents to be combined without clashing
+common labels such as C<DESCRIPTION> and C<SYNOPSIS>
+
+ $parser->UniqueLabels(1);
+ $unq = $parser->UniqueLabels;
+
+Default is true.
+
+=cut
+
+sub UniqueLabels {
+ my $self = shift;
+ if (@_) {
+ $self->{UniqueLabels} = shift;
+ }
+ return $self->{UniqueLabels};
+}
+
+=item B<UserPreamble>
+
+User supplied C<latex> preamble. Added before the pod translation
+data.
+
+If set, the contents will be prepended to the output file before the translated
+data regardless of the value of C<AddPreamble>.
+C<MakeIndex> and C<TableOfContents> will also be ignored.
+
+=cut
+
+sub UserPreamble {
+ my $self = shift;
+ if (@_) {
+ $self->{UserPreamble} = shift;
+ }
+ return $self->{UserPreamble};
+}
+
+=item B<UserPostamble>
+
+User supplied C<latex> postamble. Added after the pod translation
+data.
+
+If set, the contents will be prepended to the output file after the translated
+data regardless of the value of C<AddPostamble>.
+C<MakeIndex> will also be ignored.
+
+=cut
+
+sub UserPostamble {
+ my $self = shift;
+ if (@_) {
+ $self->{UserPostamble} = shift;
+ }
+ return $self->{UserPostamble};
+}
+
+=begin __PRIVATE__
+
+=item B<Lists>
+
+Contains details of the currently active lists.
+ The array contains C<Pod::List> objects. A new C<Pod::List>
+object is created each time a list is encountered and it is
+pushed onto this stack. When the list context ends, it
+is popped from the stack. The array will be empty if no
+lists are active.
+
+Returns array of list information in list context
+Returns array ref in scalar context
+
+=cut
+
+
+
+sub lists {
+ my $self = shift;
+ return @{ $self->{_Lists} } if wantarray();
+ return $self->{_Lists};
+}
+
+=end __PRIVATE__
+
+=back
+
+=begin __PRIVATE__
+
+=head2 Subclassed methods
+
+The following methods override methods provided in the C<Pod::Select>
+base class. See C<Pod::Parser> and C<Pod::Select> for more information
+on what these methods require.
+
+=over 4
+
+=cut
+
+######### END ACCESSORS ###################
+
+# Opening pod
+
+=item B<begin_pod>
+
+Writes the C<latex> preamble if requested. Only writes something
+if AddPreamble is true. Writes a standard header unless a UserPreamble
+is defined.
+
+=cut
+
+sub begin_pod {
+ my $self = shift;
+
+ # Get the pod identification
+ # This should really come from the '=head1 NAME' paragraph
+
+ my $infile = $self->input_file;
+ my $class = ref($self);
+ my $date = gmtime(time);
+
+ # Comment message to say where this came from
+ my $comment = << "__TEX_COMMENT__";
+%% Latex generated from POD in document $infile
+%% Using the perl module $class
+%% Converted on $date
+__TEX_COMMENT__
+
+ # Write the preamble
+ # If the caller has supplied one then we just use that
+
+ my $preamble = '';
+
+ if ($self->AddPreamble) {
+
+ if (defined $self->UserPreamble) {
+
+ $preamble = $self->UserPreamble;
+
+ # Add the description of where this came from
+ $preamble .= "\n$comment\n%% Preamble supplied by user.\n\n";
+
+ } else {
+
+ # Write our own preamble
+
+ # Code to initialise index making
+ # Use an array so that we can prepend comment if required
+ my @makeidx = (
+ '\usepackage{makeidx}',
+ '\makeindex',
+ );
+
+ unless ($self->MakeIndex) {
+ foreach (@makeidx) {
+ $_ = '%% ' . $_;
+ }
+ }
+ my $makeindex = join("\n",@makeidx) . "\n";
+
+ # Table of contents
+ my $tableofcontents = '\tableofcontents';
+
+ $tableofcontents = '%% ' . $tableofcontents
+ unless $self->TableOfContents;
+
+ # Roll our own
+ $preamble = << "__TEX_HEADER__";
+\\documentclass{article}
+\\usepackage[T1]{fontenc}
+\\usepackage{textcomp}
+
+$comment
+
+$makeindex
+
+\\begin{document}
+
+$tableofcontents
+
+__TEX_HEADER__
+
+ }
+ }
+
+ # Write the header (blank if none)
+ $self->_output($preamble);
+
+ # Start on new page if requested
+ $self->_output("\\clearpage\n") if $self->StartWithNewPage;
+
+}
+
+
+=item B<end_pod>
+
+Write the closing C<latex> code. Only writes something if AddPostamble
+is true. Writes a standard header unless a UserPostamble is defined.
+
+=cut
+
+sub end_pod {
+ my $self = shift;
+
+ # End string
+ my $end = '';
+
+ # Use the user version of the postamble if defined
+ if ($self->AddPostamble) {
+
+ if (defined $self->UserPostamble) {
+ $end = $self->UserPostamble;
+
+ } else {
+
+ # Check for index
+ my $makeindex = '\printindex';
+
+ $makeindex = '%% '. $makeindex unless $self->MakeIndex;
+
+ $end = "$makeindex\n\n\\end{document}\n";
+ }
+ }
+
+ $self->_output($end);
+
+}
+
+=item B<command>
+
+Process basic pod commands.
+
+=cut
+
+sub command {
+ my $self = shift;
+ my ($command, $paragraph, $line_num, $parobj) = @_;
+
+ # return if we dont care
+ return if $command eq 'pod';
+
+ # Store a copy of the raw text in case we are in a =for
+ # block and need to preserve the existing latex
+ my $rawpara = $paragraph;
+
+ # Do the latex escapes
+ $paragraph = $self->_replace_special_chars($paragraph);
+
+ # Interpolate pod sequences in paragraph
+ $paragraph = $self->interpolate($paragraph, $line_num);
+ $paragraph =~ s/\s+$//;
+
+ # Replace characters that can only be done after
+ # interpolation of interior sequences
+ $paragraph = $self->_replace_special_chars_late($paragraph);
+
+ # Now run the command
+ if ($command eq 'over') {
+
+ $self->begin_list($paragraph, $line_num);
+
+ } elsif ($command eq 'item') {
+
+ $self->add_item($paragraph, $line_num);
+
+ } elsif ($command eq 'back') {
+
+ $self->end_list($line_num);
+
+ } elsif ($command eq 'head1') {
+
+ # Store the name of the section
+ $self->{_CURRENT_HEAD1} = $paragraph;
+
+ # Print it
+ $self->head(1, $paragraph, $parobj);
+
+ } elsif ($command eq 'head2') {
+
+ $self->head(2, $paragraph, $parobj);
+
+ } elsif ($command eq 'head3') {
+
+ $self->head(3, $paragraph, $parobj);
+
+ } elsif ($command eq 'head4') {
+
+ $self->head(4, $paragraph, $parobj);
+
+ } elsif ($command eq 'head5') {
+
+ $self->head(5, $paragraph, $parobj);
+
+ } elsif ($command eq 'head6') {
+
+ $self->head(6, $paragraph, $parobj);
+
+ } elsif ($command eq 'begin') {
+
+ # pass through if latex
+ if ($paragraph =~ /^latex/i) {
+ # Make sure that subsequent paragraphs are not modfied before printing
+ $self->{_dont_modify_any_para} = 1;
+
+ } else {
+ # Suppress all subsequent paragraphs unless
+ # it is explcitly intended for latex
+ $self->{_suppress_all_para} = 1;
+ }
+
+ } elsif ($command eq 'for') {
+
+ # =for latex
+ # some latex
+
+ # With =for we will get the text for the full paragraph
+ # as well as the format name.
+ # We do not get an additional paragraph later on. The next
+ # paragraph is not governed by the =for
+
+ # The first line contains the format and the rest is the
+ # raw code.
+ my ($format, $chunk) = split(/\n/, $rawpara, 2);
+
+ # If we have got some latex code print it out immediately
+ # unmodified. Else do nothing.
+ if ($format =~ /^latex/i) {
+ # Make sure that next paragraph is not modfied before printing
+ $self->_output( $chunk );
+
+ }
+
+ } elsif ($command eq 'end') {
+
+ # Reset suppression
+ $self->{_suppress_all_para} = 0;
+ $self->{_dont_modify_any_para} = 0;
+
+ } elsif ($command eq 'pod') {
+
+ # Do nothing
+
+ } else {
+ carp "Command $command not recognised at line $line_num\n";
+ }
+
+}
+
+=item B<verbatim>
+
+Verbatim text
+
+=cut
+
+sub verbatim {
+ my $self = shift;
+ my ($paragraph, $line_num, $parobj) = @_;
+
+ # Expand paragraph unless in =begin block
+ if ($self->{_dont_modify_any_para}) {
+ # Just print as is
+ $self->_output($paragraph);
+
+ } else {
+
+ return if $paragraph =~ /^\s+$/;
+
+ # Clean trailing space
+ $paragraph =~ s/\s+$//;
+
+ # Clean tabs. Routine taken from Tabs.pm
+ # by David Muir Sharnoff muir@idiom.com,
+ # slightly modified by hsmyers@sdragons.com 10/22/01
+ my @l = split("\n",$paragraph);
+ foreach (@l) {
+ 1 while s/(^|\n)([^\t\n]*)(\t+)/
+ $1. $2 . (" " x
+ (8 * length($3)
+ - (length($2) % 8)))
+ /sex;
+ }
+ $paragraph = join("\n",@l);
+ # End of change.
+
+
+
+ $self->_output('\begin{verbatim}' . "\n$paragraph\n". '\end{verbatim}'."\n");
+ }
+}
+
+=item B<textblock>
+
+Plain text paragraph.
+
+=cut
+
+sub textblock {
+ my $self = shift;
+ my ($paragraph, $line_num, $parobj) = @_;
+
+ # print Dumper($self);
+
+ # Expand paragraph unless in =begin block
+ if ($self->{_dont_modify_any_para}) {
+ # Just print as is
+ $self->_output($paragraph);
+
+ return;
+ }
+
+
+ # Escape latex special characters
+ $paragraph = $self->_replace_special_chars($paragraph);
+
+ # Interpolate interior sequences
+ my $expansion = $self->interpolate($paragraph, $line_num);
+ $expansion =~ s/\s+$//;
+
+ # Escape special characters that can not be done earlier
+ $expansion = $self->_replace_special_chars_late($expansion);
+
+ # If we are replacing 'head1 NAME' with a section
+ # we need to look in the paragraph and rewrite things
+ # Need to make sure this is called only on the first paragraph
+ # following 'head1 NAME' and not on subsequent paragraphs that may be
+ # present.
+ if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection()) {
+
+ # Strip white space from start and end
+ $paragraph =~ s/^\s+//;
+ $paragraph =~ s/\s$//;
+
+ # Split the string into 2 parts
+ my ($name, $purpose) = split(/\s+-\s+/, $expansion,2);
+
+ # Now prevent this from triggering until a new head1 NAME is set
+ $self->{_CURRENT_HEAD1} = '_NAME';
+
+ # Might want to clear the Label() before doing this (CHECK)
+
+ # Print the heading
+ $self->head(1, $name, $parobj);
+
+ # Set the labeling in case we want unique names later
+ $self->Label( $self->_create_label( $name, 1 ) );
+
+ # Raise the Head1Level by one so that subsequent =head1 appear
+ # as subsections of the main name section unless we are already
+ # at maximum [Head1Level() could check this itself - CHECK]
+ $self->Head1Level( $self->Head1Level() + 1)
+ unless $self->Head1Level == $#LatexSections;
+
+ # Now write out the new latex paragraph
+ $purpose = ucfirst($purpose);
+ $self->_output("\n\n$purpose\n\n");
+
+ } else {
+ # Just write the output
+ $self->_output("\n\n$expansion\n\n");
+ }
+
+}
+
+=item B<interior_sequence>
+
+Interior sequence expansion
+
+=cut
+
+sub interior_sequence {
+ my $self = shift;
+
+ my ($seq_command, $seq_argument, $pod_seq) = @_;
+
+ if ($seq_command eq 'B') {
+ return "\\textbf{$seq_argument}";
+
+ } elsif ($seq_command eq 'I') {
+ return "\\textit{$seq_argument}";
+
+ } elsif ($seq_command eq 'E') {
+
+ # If it is simply a number
+ if ($seq_argument =~ /^\d+$/) {
+ return chr($seq_argument);
+ # Look up escape in hash table
+ } elsif (exists $HTML_Escapes{$seq_argument}) {
+ return $HTML_Escapes{$seq_argument};
+
+ } else {
+ my ($file, $line) = $pod_seq->file_line();
+ warn "Escape sequence $seq_argument not recognised at line $line of file $file\n";
+ return;
+ }
+
+ } elsif ($seq_command eq 'Z') {
+
+ # Zero width space
+ return '{}';
+
+ } elsif ($seq_command eq 'C') {
+ return "\\texttt{$seq_argument}";
+
+ } elsif ($seq_command eq 'F') {
+ return "\\emph{$seq_argument}";
+
+ } elsif ($seq_command eq 'S') {
+ # non breakable spaces
+ my $nbsp = '~';
+
+ $seq_argument =~ s/\s/$nbsp/g;
+ return $seq_argument;
+
+ } elsif ($seq_command eq 'L') {
+ my $link = new Pod::Hyperlink($seq_argument);
+
+ # undef on failure
+ unless (defined $link) {
+ carp $@;
+ return;
+ }
+
+ # Handle internal links differently
+ my $type = $link->type;
+ my $page = $link->page;
+
+ if ($type eq 'section' && $page eq '') {
+ # Use internal latex reference
+ my $node = $link->node;
+
+ # Convert to a label
+ $node = $self->_create_label($node);
+
+ return "\\S\\ref{$node}";
+
+ } else {
+ # Use default markup for external references
+ # (although Starlink would use \xlabel)
+ my $markup = $link->markup;
+ my ($file, $line) = $pod_seq->file_line();
+
+ return $self->interpolate($link->markup, $line);
+ }
+
+
+
+ } elsif ($seq_command eq 'P') {
+ # Special markup for Pod::Hyperlink
+ # Replace :: with / - but not sure if I want to do this
+ # any more.
+ my $link = $seq_argument;
+ $link =~ s|::|/|g;
+
+ my $ref = "\\emph{$seq_argument}";
+ return $ref;
+
+ } elsif ($seq_command eq 'Q') {
+ # Special markup for Pod::Hyperlink
+ return "\\textsf{$seq_argument}";
+
+ } elsif ($seq_command eq 'X') {
+ # Index entries
+
+ # use \index command
+ # I will let '!' go through for now
+ # not sure how sub categories are handled in X<>
+ my $index = $self->_create_index($seq_argument);
+ return "\\index{$index}\n";
+
+ } else {
+ carp "Unknown sequence $seq_command<$seq_argument>";
+ }
+
+}
+
+=back
+
+=head2 List Methods
+
+Methods used to handle lists.
+
+=over 4
+
+=item B<begin_list>
+
+Called when a new list is found (via the C<over> directive).
+Creates a new C<Pod::List> object and stores it on the
+list stack.
+
+ $parser->begin_list($indent, $line_num);
+
+=cut
+
+sub begin_list {
+ my $self = shift;
+ my $indent = shift;
+ my $line_num = shift;
+
+ # Indicate that a list should be started for the next item
+ # need to do this to work out the type of list
+ push ( @{$self->lists}, new Pod::List(-indent => $indent,
+ -start => $line_num,
+ -file => $self->input_file,
+ )
+ );
+
+}
+
+=item B<end_list>
+
+Called when the end of a list is found (the C<back> directive).
+Pops the C<Pod::List> object off the stack of lists and writes
+the C<latex> code required to close a list.
+
+ $parser->end_list($line_num);
+
+=cut
+
+sub end_list {
+ my $self = shift;
+ my $line_num = shift;
+
+ unless (defined $self->lists->[-1]) {
+ my $file = $self->input_file;
+ warn "No list is active at line $line_num (file=$file). Missing =over?\n";
+ return;
+ }
+
+ # What to write depends on list type
+ my $type = $self->lists->[-1]->type;
+
+ # Dont write anything if the list type is not set
+ # iomplying that a list was created but no entries were
+ # placed in it (eg because of a =begin/=end combination)
+ $self->_output("\\end{$type}\n")
+ if (defined $type && length($type) > 0);
+
+ # Clear list
+ pop(@{ $self->lists});
+
+}
+
+=item B<add_item>
+
+Add items to the list. The first time an item is encountered
+(determined from the state of the current C<Pod::List> object)
+the type of list is determined (ordered, unnumbered or description)
+and the relevant latex code issued.
+
+ $parser->add_item($paragraph, $line_num);
+
+=cut
+
+sub add_item {
+ my $self = shift;
+ my $paragraph = shift;
+ my $line_num = shift;
+
+ unless (defined $self->lists->[-1]) {
+ my $file = $self->input_file;
+ warn "List has already ended by line $line_num of file $file. Missing =over?\n";
+ # Replace special chars
+# $paragraph = $self->_replace_special_chars($paragraph);
+ $self->_output("$paragraph\n\n");
+ return;
+ }
+
+ # If paragraphs printing is turned off via =begin/=end or whatver
+ # simply return immediately
+ return if $self->{_suppress_all_para};
+
+ # Check to see whether we are starting a new lists
+ if (scalar($self->lists->[-1]->item) == 0) {
+
+ # Examine the paragraph to determine what type of list
+ # we have
+ $paragraph =~ s/\s+$//;
+ $paragraph =~ s/^\s+//;
+
+ my $type;
+ if (substr($paragraph, 0,1) eq '*') {
+ $type = 'itemize';
+ } elsif ($paragraph =~ /^\d/) {
+ $type = 'enumerate';
+ } else {
+ $type = 'description';
+ }
+ $self->lists->[-1]->type($type);
+
+ $self->_output("\\begin{$type}\n");
+
+ }
+
+ my $type = $self->lists->[-1]->type;
+
+ if ($type eq 'description') {
+ # Handle long items - long items do not wrap
+ # If the string is longer than 40 characters we split
+ # it into a real item header and some bold text.
+ my $maxlen = 40;
+ my ($hunk1, $hunk2) = $self->_split_delimited( $paragraph, $maxlen );
+
+ # Print the first hunk
+ $self->_output("\n\\item[{$hunk1}] ");
+
+ # and the second hunk if it is defined
+ if ($hunk2) {
+ $self->_output("\\textbf{$hunk2}");
+ } else {
+ # Not there so make sure we have a new line
+ $self->_output("\\mbox{}");
+ }
+
+ } else {
+ # If the item was '* Something' or '\d+ something' we still need to write
+ # out the something. Also allow 1) and 1.
+ my $extra_info = $paragraph;
+ $extra_info =~ s/^(\*|\d+[\.\)]?)\s*//;
+ $self->_output("\n\\item $extra_info");
+ }
+
+ # Store the item name in the object. Required so that
+ # we can tell if the list is new or not
+ $self->lists->[-1]->item($paragraph);
+
+}
+
+=back
+
+=head2 Methods for headings
+
+=over 4
+
+=item B<head>
+
+Print a heading of the required level.
+
+ $parser->head($level, $paragraph, $parobj);
+
+The first argument is the pod heading level. The second argument
+is the contents of the heading. The 3rd argument is a Pod::Paragraph
+object so that the line number can be extracted.
+
+=cut
+
+sub head {
+ my $self = shift;
+ my $num = shift;
+ my $paragraph = shift;
+ my $parobj = shift;
+
+ # If we are replace 'head1 NAME' with a section
+ # we return immediately if we get it
+ return
+ if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection());
+
+ # Create a label
+ my $label = $self->_create_label($paragraph);
+
+ # Create an index entry
+ my $index = $self->_create_index($paragraph);
+
+ # Work out position in the above array taking into account
+ # that =head1 is equivalent to $self->Head1Level
+
+ my $level = $self->Head1Level() - 1 + $num;
+
+ # Warn if heading to large
+ if ($num > $#LatexSections) {
+ my $line = $parobj->file_line;
+ my $file = $self->input_file;
+ warn "Heading level too large ($level) for LaTeX at line $line of file $file\n";
+ $level = $#LatexSections;
+ }
+
+ # Check to see whether section should be unnumbered
+ my $star = ($level >= $self->LevelNoNum ? '*' : '');
+
+ # Section
+ $self->_output("\\" .$LatexSections[$level] .$star ."{$paragraph\\label{".$label ."}\\index{".$index."}}\n");
+
+}
+
+
+=back
+
+=end __PRIVATE__
+
+=begin __PRIVATE__
+
+=head2 Internal methods
+
+Internal routines are described in this section. They do not form part of the
+public interface. All private methods start with an underscore.
+
+=over 4
+
+=item B<_output>
+
+Output text to the output filehandle. This method must be always be called
+to output parsed text.
+
+ $parser->_output($text);
+
+Does not write anything if a =begin is active that should be
+ignored.
+
+=cut
+
+sub _output {
+ my $self = shift;
+ my $text = shift;
+
+ print { $self->output_handle } $text
+ unless $self->{_suppress_all_para};
+
+}
+
+
+=item B<_replace_special_chars>
+
+Subroutine to replace characters that are special in C<latex>
+with the escaped forms
+
+ $escaped = $parser->_replace_special_chars($paragraph);
+
+Need to call this routine before interior_sequences are munged but not
+if verbatim. It must be called before interpolation of interior
+sequences so that curly brackets and special latex characters inserted
+during interpolation are not themselves escaped. This means that < and
+> can not be modified here since the text still contains interior
+sequences.
+
+Special characters and the C<latex> equivalents are:
+
+ } \}
+ { \{
+ _ \_
+ $ \$
+ % \%
+ & \&
+ \ $\backslash$
+ ^ \^{}
+ ~ \~{}
+ # \#
+
+=cut
+
+sub _replace_special_chars {
+ my $self = shift;
+ my $paragraph = shift;
+
+ # Replace a \ with $\backslash$
+ # This is made more complicated because the dollars will be escaped
+ # by the subsequent replacement. Easiest to add \backslash
+ # now and then add the dollars
+ $paragraph =~ s/\\/\\backslash/g;
+
+ # Must be done after escape of \ since this command adds latex escapes
+ # Replace characters that can be escaped
+ $paragraph =~ s/([\$\#&%_{}])/\\$1/g;
+
+ # Replace ^ characters with \^{} so that $^F works okay
+ $paragraph =~ s/(\^)/\\$1\{\}/g;
+
+ # Replace tilde (~) with \texttt{\~{}}
+ $paragraph =~ s/~/\\texttt\{\\~\{\}\}/g;
+
+ # Now add the dollars around each \backslash
+ $paragraph =~ s/(\\backslash)/\$$1\$/g;
+ return $paragraph;
+}
+
+=item B<_replace_special_chars_late>
+
+Replace special characters that can not be replaced before interior
+sequence interpolation. See C<_replace_special_chars> for a routine
+to replace special characters prior to interpolation of interior
+sequences.
+
+Does the following transformation:
+
+ < $<$
+ > $>$
+ | $|$
+
+
+=cut
+
+sub _replace_special_chars_late {
+ my $self = shift;
+ my $paragraph = shift;
+
+ # < and >
+ $paragraph =~ s/(<|>)/\$$1\$/g;
+
+ # Replace | with $|$
+ $paragraph =~ s'\|'$|$'g;
+
+
+ return $paragraph;
+}
+
+
+=item B<_create_label>
+
+Return a string that can be used as an internal reference
+in a C<latex> document (i.e. accepted by the C<\label> command)
+
+ $label = $parser->_create_label($string)
+
+If UniqueLabels is true returns a label prefixed by Label()
+This can be suppressed with an optional second argument.
+
+ $label = $parser->_create_label($string, $suppress);
+
+If a second argument is supplied (of any value including undef)
+the Label() is never prefixed. This means that this routine can
+be called to create a Label() without prefixing a previous setting.
+
+=cut
+
+sub _create_label {
+ my $self = shift;
+ my $paragraph = shift;
+ my $suppress = (@_ ? 1 : 0 );
+
+ # Remove latex commands
+ $paragraph = $self->_clean_latex_commands($paragraph);
+
+ # Remove non alphanumerics from the label and replace with underscores
+ # want to protect '-' though so use negated character classes
+ $paragraph =~ s/[^-:\w]/_/g;
+
+ # Multiple underscores will look unsightly so remove repeats
+ # This will also have the advantage of tidying up the end and
+ # start of string
+ $paragraph =~ s/_+/_/g;
+
+ # If required need to make sure that the label is unique
+ # since it is possible to have multiple pods in a single
+ # document
+ if (!$suppress && $self->UniqueLabels() && defined $self->Label) {
+ $paragraph = $self->Label() .'_'. $paragraph;
+ }
+
+ return $paragraph;
+}
+
+
+=item B<_create_index>
+
+Similar to C<_create_label> except an index entry is created.
+If C<UniqueLabels> is true, the index entry is prefixed by
+the current C<Label> and an exclamation mark.
+
+ $ind = $parser->_create_index($paragraph);
+
+An exclamation mark is used by C<makeindex> to generate
+sub-entries in an index.
+
+=cut
+
+sub _create_index {
+ my $self = shift;
+ my $paragraph = shift;
+ my $suppress = (@_ ? 1 : 0 );
+
+ # Remove latex commands
+ $paragraph = $self->_clean_latex_commands($paragraph);
+
+ # If required need to make sure that the index entry is unique
+ # since it is possible to have multiple pods in a single
+ # document
+ if (!$suppress && $self->UniqueLabels() && defined $self->Label) {
+ $paragraph = $self->Label() .'!'. $paragraph;
+ }
+
+ # Need to replace _ with space
+ $paragraph =~ s/_/ /g;
+
+ return $paragraph;
+
+}
+
+=item B<_clean_latex_commands>
+
+Removes latex commands from text. The latex command is assumed to be of the
+form C<\command{ text }>. "C<text>" is retained
+
+ $clean = $parser->_clean_latex_commands($text);
+
+=cut
+
+sub _clean_latex_commands {
+ my $self = shift;
+ my $paragraph = shift;
+
+ # Remove latex commands of the form \text{ }
+ # and replace with the contents of the { }
+ # need to make this non-greedy so that it can handle
+ # "\text{a} and \text2{b}"
+ # without converting it to
+ # "a} and \text2{b"
+ # This match will still get into trouble if \} is present
+ # This is not vital since the subsequent replacement of non-alphanumeric
+ # characters will tidy it up anyway
+ $paragraph =~ s/\\\w+{(.*?)}/$1/g;
+
+ return $paragraph
+}
+
+=item B<_split_delimited>
+
+Split the supplied string into two parts at approximately the
+specified word boundary. Special care is made to make sure that it
+does not split in the middle of some curly brackets.
+
+e.g. "this text is \textbf{very bold}" would not be split into
+"this text is \textbf{very" and " bold".
+
+ ($hunk1, $hunk2) = $self->_split_delimited( $para, $length);
+
+The length indicates the maximum length of hunk1.
+
+=cut
+
+# initially Supplied by hsmyers@sdragons.com
+# 10/25/01, utility to split \hbox
+# busting lines. Reformatted by TimJ to match module style.
+sub _split_delimited {
+ my $self = shift;
+ my $input = shift;
+ my $limit = shift;
+
+ # Return immediately if already small
+ return ($input, '') if length($input) < $limit;
+
+ my @output;
+ my $s = '';
+ my $t = '';
+ my $depth = 0;
+ my $token;
+
+ $input =~ s/\n/ /gm;
+ $input .= ' ';
+ foreach ( split ( //, $input ) ) {
+ $token .= $_;
+ if (/\{/) {
+ $depth++;
+ } elsif ( /}/ ) {
+ $depth--;
+ } elsif ( / / and $depth == 0) {
+ push @output, $token if ( $token and $token ne ' ' );
+ $token = '';
+ }
+ }
+
+ foreach (@output) {
+ if (length($s) < $limit) {
+ $s .= $_;
+ } else {
+ $t .= $_;
+ }
+ }
+
+ # Tidy up
+ $s =~ s/\s+$//;
+ $t =~ s/\s+$//;
+ return ($s,$t);
+}
+
+=back
+
+=end __PRIVATE__
+
+=head1 NOTES
+
+Compatible with C<latex2e> only. Can not be used with C<latex> v2.09
+or earlier.
+
+A subclass of C<Pod::Select> so that specific pod sections can be
+converted to C<latex> by using the C<select> method.
+
+Some HTML escapes are missing and many have not been tested.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>, L<Pod::Select>, L<pod2latex>
+
+=head1 AUTHORS
+
+Tim Jenness E<lt>tjenness@cpan.orgE<gt>
+
+Bug fixes and improvements have been received from: Simon Cozens
+E<lt>simon@cozens.netE<gt>, Mark A. Hershberger
+E<lt>mah@everybody.orgE<gt>, Marcel Grunauer
+E<lt>marcel@codewerk.comE<gt>, Hugh S Myers
+E<lt>hsmyers@sdragons.comE<gt>, Peter J Acklam
+E<lt>jacklam@math.uio.noE<gt>, Sudhi Herle E<lt>sudhi@herle.netE<gt>,
+Ariel Scolnicov E<lt>ariels@compugen.co.ilE<gt>,
+Adriano Rodrigues Ferreira E<lt>ferreira@triang.com.brE<gt> and
+R. de Vries E<lt>r.de.vries@dutchspace.nlE<gt>.
+
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000-2004 Tim Jenness. All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=begin __PRIVATE__
+
+=head1 REVISION
+
+$Id: LaTeX.pm,v 1.19 2004/12/30 01:40:44 timj Exp $
+
+=end __PRIVATE__
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Man.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Man.pm
new file mode 100755
index 00000000000..9339f835bbc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Man.pm
@@ -0,0 +1,1764 @@
+# Pod::Man -- Convert POD data to formatted *roff input.
+#
+# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+# Russ Allbery <rra@stanford.edu>
+# Substantial contributions by Sean Burke <sburke@cpan.org>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module translates POD documentation into *roff markup using the man
+# macro set, and is intended for converting POD documents written as Unix
+# manual pages to manual pages that can be read by the man(1) command. It is
+# a replacement for the pod2man command distributed with versions of Perl
+# prior to 5.6.
+#
+# Perl core hackers, please note that this module is also separately
+# maintained outside of the Perl core as part of the podlators. Please send
+# me any patches at the address above in addition to sending them to the
+# standard Perl mailing lists.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::Man;
+
+require 5.005;
+
+use strict;
+use subs qw(makespace);
+use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
+
+use Carp qw(croak);
+use Pod::Simple ();
+
+@ISA = qw(Pod::Simple);
+
+$VERSION = '2.23';
+
+# Set the debugging level. If someone has inserted a debug function into this
+# class already, use that. Otherwise, use any Pod::Simple debug function
+# that's defined, and failing that, define a debug level of 10.
+BEGIN {
+ my $parent = defined (&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG : undef;
+ unless (defined &DEBUG) {
+ *DEBUG = $parent || sub () { 10 };
+ }
+}
+
+# Import the ASCII constant from Pod::Simple. This is true iff we're in an
+# ASCII-based universe (including such things as ISO 8859-1 and UTF-8), and is
+# generally only false for EBCDIC.
+BEGIN { *ASCII = \&Pod::Simple::ASCII }
+
+# Pretty-print a data structure. Only used for debugging.
+BEGIN { *pretty = \&Pod::Simple::pretty }
+
+##############################################################################
+# Object initialization
+##############################################################################
+
+# Initialize the object and set various Pod::Simple options that we need.
+# Here, we also process any additional options passed to the constructor or
+# set up defaults if none were given. Note that all internal object keys are
+# in all-caps, reserving all lower-case object keys for Pod::Simple and user
+# arguments.
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+
+ # Tell Pod::Simple not to handle S<> by automatically inserting &nbsp;.
+ $self->nbsp_for_S (1);
+
+ # Tell Pod::Simple to keep whitespace whenever possible.
+ if ($self->can ('preserve_whitespace')) {
+ $self->preserve_whitespace (1);
+ } else {
+ $self->fullstop_space_harden (1);
+ }
+
+ # The =for and =begin targets that we accept.
+ $self->accept_targets (qw/man MAN roff ROFF/);
+
+ # Ensure that contiguous blocks of code are merged together. Otherwise,
+ # some of the guesswork heuristics don't work right.
+ $self->merge_text (1);
+
+ # Pod::Simple doesn't do anything useful with our arguments, but we want
+ # to put them in our object as hash keys and values. This could cause
+ # problems if we ever clash with Pod::Simple's own internal class
+ # variables.
+ %$self = (%$self, @_);
+
+ # Send errors to stderr if requested.
+ if ($$self{stderr}) {
+ $self->no_errata_section (1);
+ $self->complain_stderr (1);
+ delete $$self{stderr};
+ }
+
+ # Initialize various other internal constants based on our arguments.
+ $self->init_fonts;
+ $self->init_quotes;
+ $self->init_page;
+
+ # For right now, default to turning on all of the magic.
+ $$self{MAGIC_CPP} = 1;
+ $$self{MAGIC_EMDASH} = 1;
+ $$self{MAGIC_FUNC} = 1;
+ $$self{MAGIC_MANREF} = 1;
+ $$self{MAGIC_SMALLCAPS} = 1;
+ $$self{MAGIC_VARS} = 1;
+
+ return $self;
+}
+
+# Translate a font string into an escape.
+sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
+
+# Determine which fonts the user wishes to use and store them in the object.
+# Regular, italic, bold, and bold-italic are constants, but the fixed width
+# fonts may be set by the user. Sets the internal hash key FONTS which is
+# used to map our internal font escapes to actual *roff sequences later.
+sub init_fonts {
+ my ($self) = @_;
+
+ # Figure out the fixed-width font. If user-supplied, make sure that they
+ # are the right length.
+ for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
+ my $font = $$self{$_};
+ if (defined ($font) && (length ($font) < 1 || length ($font) > 2)) {
+ croak qq(roff font should be 1 or 2 chars, not "$font");
+ }
+ }
+
+ # Set the default fonts. We can't be sure portably across different
+ # implementations what fixed bold-italic may be called (if it's even
+ # available), so default to just bold.
+ $$self{fixed} ||= 'CW';
+ $$self{fixedbold} ||= 'CB';
+ $$self{fixeditalic} ||= 'CI';
+ $$self{fixedbolditalic} ||= 'CB';
+
+ # Set up a table of font escapes. First number is fixed-width, second is
+ # bold, third is italic.
+ $$self{FONTS} = { '000' => '\fR', '001' => '\fI',
+ '010' => '\fB', '011' => '\f(BI',
+ '100' => toescape ($$self{fixed}),
+ '101' => toescape ($$self{fixeditalic}),
+ '110' => toescape ($$self{fixedbold}),
+ '111' => toescape ($$self{fixedbolditalic}) };
+}
+
+# Initialize the quotes that we'll be using for C<> text. This requires some
+# special handling, both to parse the user parameter if given and to make sure
+# that the quotes will be safe against *roff. Sets the internal hash keys
+# LQUOTE and RQUOTE.
+sub init_quotes {
+ my ($self) = (@_);
+
+ $$self{quotes} ||= '"';
+ if ($$self{quotes} eq 'none') {
+ $$self{LQUOTE} = $$self{RQUOTE} = '';
+ } elsif (length ($$self{quotes}) == 1) {
+ $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes};
+ } elsif ($$self{quotes} =~ /^(.)(.)$/
+ || $$self{quotes} =~ /^(..)(..)$/) {
+ $$self{LQUOTE} = $1;
+ $$self{RQUOTE} = $2;
+ } else {
+ croak(qq(Invalid quote specification "$$self{quotes}"))
+ }
+
+ # Double the first quote; note that this should not be s///g as two double
+ # quotes is represented in *roff as three double quotes, not four. Weird,
+ # I know.
+ $$self{LQUOTE} =~ s/\"/\"\"/;
+ $$self{RQUOTE} =~ s/\"/\"\"/;
+}
+
+# Initialize the page title information and indentation from our arguments.
+sub init_page {
+ my ($self) = @_;
+
+ # We used to try first to get the version number from a local binary, but
+ # we shouldn't need that any more. Get the version from the running Perl.
+ # Work a little magic to handle subversions correctly under both the
+ # pre-5.6 and the post-5.6 version numbering schemes.
+ my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
+ $version[2] ||= 0;
+ $version[2] *= 10 ** (3 - length $version[2]);
+ for (@version) { $_ += 0 }
+ my $version = join ('.', @version);
+
+ # Set the defaults for page titles and indentation if the user didn't
+ # override anything.
+ $$self{center} = 'User Contributed Perl Documentation'
+ unless defined $$self{center};
+ $$self{release} = 'perl v' . $version
+ unless defined $$self{release};
+ $$self{indent} = 4
+ unless defined $$self{indent};
+
+ # Double quotes in things that will be quoted.
+ for (qw/center release/) {
+ $$self{$_} =~ s/\"/\"\"/g if $$self{$_};
+ }
+}
+
+##############################################################################
+# Core parsing
+##############################################################################
+
+# This is the glue that connects the code below with Pod::Simple itself. The
+# goal is to convert the event stream coming from the POD parser into method
+# calls to handlers once the complete content of a tag has been seen. Each
+# paragraph or POD command will have textual content associated with it, and
+# as soon as all of a paragraph or POD command has been seen, that content
+# will be passed in to the corresponding method for handling that type of
+# object. The exceptions are handlers for lists, which have opening tag
+# handlers and closing tag handlers that will be called right away.
+#
+# The internal hash key PENDING is used to store the contents of a tag until
+# all of it has been seen. It holds a stack of open tags, each one
+# represented by a tuple of the attributes hash for the tag, formatting
+# options for the tag (which are inherited), and the contents of the tag.
+
+# Add a block of text to the contents of the current node, formatting it
+# according to the current formatting instructions as we do.
+sub _handle_text {
+ my ($self, $text) = @_;
+ DEBUG > 3 and print "== $text\n";
+ my $tag = $$self{PENDING}[-1];
+ $$tag[2] .= $self->format_text ($$tag[1], $text);
+}
+
+# Given an element name, get the corresponding method name.
+sub method_for_element {
+ my ($self, $element) = @_;
+ $element =~ tr/-/_/;
+ $element =~ tr/A-Z/a-z/;
+ $element =~ tr/_a-z0-9//cd;
+ return $element;
+}
+
+# Handle the start of a new element. If cmd_element is defined, assume that
+# we need to collect the entire tree for this element before passing it to the
+# element method, and create a new tree into which we'll collect blocks of
+# text and nested elements. Otherwise, if start_element is defined, call it.
+sub _handle_element_start {
+ my ($self, $element, $attrs) = @_;
+ DEBUG > 3 and print "++ $element (<", join ('> <', %$attrs), ">)\n";
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, we need to accumulate the contents of the
+ # tag before calling it. Turn off IN_NAME for any command other than
+ # <Para> and the formatting codes so that IN_NAME isn't still set for the
+ # first heading after the NAME heading.
+ if ($self->can ("cmd_$method")) {
+ DEBUG > 2 and print "<$element> starts saving a tag\n";
+ $$self{IN_NAME} = 0 if ($element ne 'Para' && length ($element) > 1);
+
+ # How we're going to format embedded text blocks depends on the tag
+ # and also depends on our parent tags. Thankfully, inside tags that
+ # turn off guesswork and reformatting, nothing else can turn it back
+ # on, so this can be strictly inherited.
+ my $formatting = $$self{PENDING}[-1][1];
+ $formatting = $self->formatting ($formatting, $element);
+ push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]);
+ DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
+ } elsif ($self->can ("start_$method")) {
+ my $method = 'start_' . $method;
+ $self->$method ($attrs, '');
+ } else {
+ DEBUG > 2 and print "No $method start method, skipping\n";
+ }
+}
+
+# Handle the end of an element. If we had a cmd_ method for this element,
+# this is where we pass along the tree that we built. Otherwise, if we have
+# an end_ method for the element, call that.
+sub _handle_element_end {
+ my ($self, $element) = @_;
+ DEBUG > 3 and print "-- $element\n";
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, pull off the pending text and pass it to
+ # the handler along with the saved attribute hash.
+ if ($self->can ("cmd_$method")) {
+ DEBUG > 2 and print "</$element> stops saving a tag\n";
+ my $tag = pop @{ $$self{PENDING} };
+ DEBUG > 4 and print "Popped: [", pretty ($tag), "]\n";
+ DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
+ my $method = 'cmd_' . $method;
+ my $text = $self->$method ($$tag[0], $$tag[2]);
+ if (defined $text) {
+ if (@{ $$self{PENDING} } > 1) {
+ $$self{PENDING}[-1][2] .= $text;
+ } else {
+ $self->output ($text);
+ }
+ }
+ } elsif ($self->can ("end_$method")) {
+ my $method = 'end_' . $method;
+ $self->$method ();
+ } else {
+ DEBUG > 2 and print "No $method end method, skipping\n";
+ }
+}
+
+##############################################################################
+# General formatting
+##############################################################################
+
+# Return formatting instructions for a new block. Takes the current
+# formatting and the new element. Formatting inherits negatively, in the
+# sense that if the parent has turned off guesswork, all child elements should
+# leave it off. We therefore return a copy of the same formatting
+# instructions but possibly with more things turned off depending on the
+# element.
+sub formatting {
+ my ($self, $current, $element) = @_;
+ my %options;
+ if ($current) {
+ %options = %$current;
+ } else {
+ %options = (guesswork => 1, cleanup => 1, convert => 1);
+ }
+ if ($element eq 'Data') {
+ $options{guesswork} = 0;
+ $options{cleanup} = 0;
+ $options{convert} = 0;
+ } elsif ($element eq 'X') {
+ $options{guesswork} = 0;
+ $options{cleanup} = 0;
+ } elsif ($element eq 'Verbatim' || $element eq 'C') {
+ $options{guesswork} = 0;
+ $options{literal} = 1;
+ }
+ return \%options;
+}
+
+# Format a text block. Takes a hash of formatting options and the text to
+# format. Currently, the only formatting options are guesswork, cleanup, and
+# convert, all of which are boolean.
+sub format_text {
+ my ($self, $options, $text) = @_;
+ my $guesswork = $$options{guesswork} && !$$self{IN_NAME};
+ my $cleanup = $$options{cleanup};
+ my $convert = $$options{convert};
+ my $literal = $$options{literal};
+
+ # Cleanup just tidies up a few things, telling *roff that the hyphens are
+ # hard, putting a bit of space between consecutive underscores, and
+ # escaping backslashes. Be careful not to mangle our character
+ # translations by doing this before processing character translation.
+ if ($cleanup) {
+ $text =~ s/\\/\\e/g;
+ $text =~ s/-/\\-/g;
+ $text =~ s/_(?=_)/_\\|/g;
+ }
+
+ # Normally we do character translation, but we won't even do that in
+ # <Data> blocks or if UTF-8 output is desired.
+ if ($convert && !$$self{utf8} && ASCII) {
+ $text =~ s/([^\x00-\x7F])/$ESCAPES{ord ($1)} || "X"/eg;
+ }
+
+ # Ensure that *roff doesn't convert literal quotes to UTF-8 single quotes,
+ # but don't mess up our accept escapes.
+ if ($literal) {
+ $text =~ s/(?<!\\\*)\'/\\*\(Aq/g;
+ $text =~ s/(?<!\\\*)\`/\\\`/g;
+ }
+
+ # If guesswork is asked for, do that. This involves more substantial
+ # formatting based on various heuristics that may only be appropriate for
+ # particular documents.
+ if ($guesswork) {
+ $text = $self->guesswork ($text);
+ }
+
+ return $text;
+}
+
+# Handles C<> text, deciding whether to put \*C` around it or not. This is a
+# whole bunch of messy heuristics to try to avoid overquoting, originally from
+# Barrie Slaymaker. This largely duplicates similar code in Pod::Text.
+sub quote_literal {
+ my $self = shift;
+ local $_ = shift;
+
+ # A regex that matches the portion of a variable reference that's the
+ # array or hash index, separated out just because we want to use it in
+ # several places in the following regex.
+ my $index = '(?: \[.*\] | \{.*\} )?';
+
+ # If in NAME section, just return an ASCII quoted string to avoid
+ # confusing tools like whatis.
+ return qq{"$_"} if $$self{IN_NAME};
+
+ # Check for things that we don't want to quote, and if we find any of
+ # them, return the string with just a font change and no quoting.
+ m{
+ ^\s*
+ (?:
+ ( [\'\`\"] ) .* \1 # already quoted
+ | \\\*\(Aq .* \\\*\(Aq # quoted and escaped
+ | \\?\` .* ( \' | \\\*\(Aq ) # `quoted'
+ | \$+ [\#^]? \S $index # special ($^Foo, $")
+ | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
+ | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
+ | [-+]? ( \d[\d.]* | \.\d+ ) (?: [eE][-+]?\d+ )? # a number
+ | 0x [a-fA-F\d]+ # a hex constant
+ )
+ \s*\z
+ }xso and return '\f(FS' . $_ . '\f(FE';
+
+ # If we didn't return, go ahead and quote the text.
+ return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE";
+}
+
+# Takes a text block to perform guesswork on. Returns the text block with
+# formatting codes added. This is the code that marks up various Perl
+# constructs and things commonly used in man pages without requiring the user
+# to add any explicit markup, and is applied to all non-literal text. We're
+# guaranteed that the text we're applying guesswork to does not contain any
+# *roff formatting codes. Note that the inserted font sequences must be
+# treated later with mapfonts or textmapfonts.
+#
+# This method is very fragile, both in the regular expressions it uses and in
+# the ordering of those modifications. Care and testing is required when
+# modifying it.
+sub guesswork {
+ my $self = shift;
+ local $_ = shift;
+ DEBUG > 5 and print " Guesswork called on [$_]\n";
+
+ # By the time we reach this point, all hypens will be escaped by adding a
+ # backslash. We want to undo that escaping if they're part of regular
+ # words and there's only a single dash, since that's a real hyphen that
+ # *roff gets to consider a possible break point. Make sure that a dash
+ # after the first character of a word stays non-breaking, however.
+ #
+ # Note that this is not user-controllable; we pretty much have to do this
+ # transformation or *roff will mangle the output in unacceptable ways.
+ s{
+ ( (?:\G|^|\s) [\(\"]* [a-zA-Z] ) ( \\- )?
+ ( (?: [a-zA-Z\']+ \\-)+ )
+ ( [a-zA-Z\']+ ) (?= [\)\".?!,;:]* (?:\s|\Z|\\\ ) )
+ \b
+ } {
+ my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4);
+ $hyphen ||= '';
+ $main =~ s/\\-/-/g;
+ $prefix . $hyphen . $main . $suffix;
+ }egx;
+
+ # Translate "--" into a real em-dash if it's used like one. This means
+ # that it's either surrounded by whitespace, it follows a regular word, or
+ # it occurs between two regular words.
+ if ($$self{MAGIC_EMDASH}) {
+ s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx;
+ s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx;
+ }
+
+ # Make words in all-caps a little bit smaller; they look better that way.
+ # However, we don't want to change Perl code (like @ARGV), nor do we want
+ # to fix the MIME in MIME-Version since it looks weird with the
+ # full-height V.
+ #
+ # We change only a string of all caps (2) either at the beginning of the
+ # line or following regular punctuation (like quotes) or whitespace (1),
+ # and followed by either similar punctuation, an em-dash, or the end of
+ # the line (3).
+ if ($$self{MAGIC_SMALLCAPS}) {
+ s{
+ ( ^ | [\s\(\"\'\`\[\{<>] | \\\ ) # (1)
+ ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- )* ) # (2)
+ (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\\ | $ ) # (3)
+ } {
+ $1 . '\s-1' . $2 . '\s0'
+ }egx;
+ }
+
+ # Note that from this point forward, we have to adjust for \s-1 and \s-0
+ # strings inserted around things that we've made small-caps if later
+ # transforms should work on those strings.
+
+ # Italize functions in the form func(), including functions that are in
+ # all capitals, but don't italize if there's anything between the parens.
+ # The function must start with an alphabetic character or underscore and
+ # then consist of word characters or colons.
+ if ($$self{MAGIC_FUNC}) {
+ s{
+ ( \b | \\s-1 )
+ ( [A-Za-z_] ([:\w] | \\s-?[01])+ \(\) )
+ } {
+ $1 . '\f(IS' . $2 . '\f(IE'
+ }egx;
+ }
+
+ # Change references to manual pages to put the page name in italics but
+ # the number in the regular font, with a thin space between the name and
+ # the number. Only recognize func(n) where func starts with an alphabetic
+ # character or underscore and contains only word characters, periods (for
+ # configuration file man pages), or colons, and n is a single digit,
+ # optionally followed by some number of lowercase letters. Note that this
+ # does not recognize man page references like perl(l) or socket(3SOCKET).
+ if ($$self{MAGIC_MANREF}) {
+ s{
+ ( \b | \\s-1 )
+ ( [A-Za-z_] (?:[.:\w] | \\- | \\s-?[01])+ )
+ ( \( \d [a-z]* \) )
+ } {
+ $1 . '\f(IS' . $2 . '\f(IE\|' . $3
+ }egx;
+ }
+
+ # Convert simple Perl variable references to a fixed-width font. Be
+ # careful not to convert functions, though; there are too many subtleties
+ # with them to want to perform this transformation.
+ if ($$self{MAGIC_VARS}) {
+ s{
+ ( ^ | \s+ )
+ ( [\$\@%] [\w:]+ )
+ (?! \( )
+ } {
+ $1 . '\f(FS' . $2 . '\f(FE'
+ }egx;
+ }
+
+ # Fix up double quotes. Unfortunately, we miss this transformation if the
+ # quoted text contains any code with formatting codes and there's not much
+ # we can effectively do about that, which makes it somewhat unclear if
+ # this is really a good idea.
+ s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx;
+
+ # Make C++ into \*(C+, which is a squinched version.
+ if ($$self{MAGIC_CPP}) {
+ s{ \b C\+\+ } {\\*\(C+}gx;
+ }
+
+ # Done.
+ DEBUG > 5 and print " Guesswork returning [$_]\n";
+ return $_;
+}
+
+##############################################################################
+# Output
+##############################################################################
+
+# When building up the *roff code, we don't use real *roff fonts. Instead, we
+# embed font codes of the form \f(<font>[SE] where <font> is one of B, I, or
+# F, S stands for start, and E stands for end. This method turns these into
+# the right start and end codes.
+#
+# We add this level of complexity because the old pod2man didn't get code like
+# B<someI<thing> else> right; after I<> it switched back to normal text rather
+# than bold. We take care of this by using variables that state whether bold,
+# italic, or fixed are turned on as a combined pointer to our current font
+# sequence, and set each to the number of current nestings of start tags for
+# that font.
+#
+# \fP changes to the previous font, but only one previous font is kept. We
+# don't know what the outside level font is; normally it's R, but if we're
+# inside a heading it could be something else. So arrange things so that the
+# outside font is always the "previous" font and end with \fP instead of \fR.
+# Idea from Zack Weinberg.
+sub mapfonts {
+ my ($self, $text) = @_;
+ my ($fixed, $bold, $italic) = (0, 0, 0);
+ my %magic = (F => \$fixed, B => \$bold, I => \$italic);
+ my $last = '\fR';
+ $text =~ s<
+ \\f\((.)(.)
+ > <
+ my $sequence = '';
+ my $f;
+ if ($last ne '\fR') { $sequence = '\fP' }
+ ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
+ $f = $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
+ if ($f eq $last) {
+ '';
+ } else {
+ if ($f ne '\fR') { $sequence .= $f }
+ $last = $f;
+ $sequence;
+ }
+ >gxe;
+ return $text;
+}
+
+# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
+# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
+# than R, presumably because \f(CW doesn't actually do a font change. To work
+# around this, use a separate textmapfonts for text blocks where the default
+# font is always R and only use the smart mapfonts for headings.
+sub textmapfonts {
+ my ($self, $text) = @_;
+ my ($fixed, $bold, $italic) = (0, 0, 0);
+ my %magic = (F => \$fixed, B => \$bold, I => \$italic);
+ $text =~ s<
+ \\f\((.)(.)
+ > <
+ ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
+ $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
+ >gxe;
+ return $text;
+}
+
+# Given a command and a single argument that may or may not contain double
+# quotes, handle double-quote formatting for it. If there are no double
+# quotes, just return the command followed by the argument in double quotes.
+# If there are double quotes, use an if statement to test for nroff, and for
+# nroff output the command followed by the argument in double quotes with
+# embedded double quotes doubled. For other formatters, remap paired double
+# quotes to LQUOTE and RQUOTE.
+sub switchquotes {
+ my ($self, $command, $text, $extra) = @_;
+ $text =~ s/\\\*\([LR]\"/\"/g;
+
+ # We also have to deal with \*C` and \*C', which are used to add the
+ # quotes around C<> text, since they may expand to " and if they do this
+ # confuses the .SH macros and the like no end. Expand them ourselves.
+ # Also separate troff from nroff if there are any fixed-width fonts in use
+ # to work around problems with Solaris nroff.
+ my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
+ my $fixedpat = join '|', @{ $$self{FONTS} }{'100', '101', '110', '111'};
+ $fixedpat =~ s/\\/\\\\/g;
+ $fixedpat =~ s/\(/\\\(/g;
+ if ($text =~ m/\"/ || $text =~ m/$fixedpat/) {
+ $text =~ s/\"/\"\"/g;
+ my $nroff = $text;
+ my $troff = $text;
+ $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
+ if ($c_is_quote and $text =~ m/\\\*\(C[\'\`]/) {
+ $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g;
+ $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g;
+ $troff =~ s/\\\*\(C[\'\`]//g;
+ }
+ $nroff = qq("$nroff") . ($extra ? " $extra" : '');
+ $troff = qq("$troff") . ($extra ? " $extra" : '');
+
+ # Work around the Solaris nroff bug where \f(CW\fP leaves the font set
+ # to Roman rather than the actual previous font when used in headings.
+ # troff output may still be broken, but at least we can fix nroff by
+ # just switching the font changes to the non-fixed versions.
+ $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f[PR]/$1/g;
+ $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)\\f([PR])/\\fI$1\\f$2/g;
+ $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)\\f([PR])/\\fB$1\\f$2/g;
+ $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)\\f([PR])/\\f\(BI$1\\f$2/g;
+
+ # Now finally output the command. Bother with .ie only if the nroff
+ # and troff output aren't the same.
+ if ($nroff ne $troff) {
+ return ".ie n $command $nroff\n.el $command $troff\n";
+ } else {
+ return "$command $nroff\n";
+ }
+ } else {
+ $text = qq("$text") . ($extra ? " $extra" : '');
+ return "$command $text\n";
+ }
+}
+
+# Protect leading quotes and periods against interpretation as commands. Also
+# protect anything starting with a backslash, since it could expand or hide
+# something that *roff would interpret as a command. This is overkill, but
+# it's much simpler than trying to parse *roff here.
+sub protect {
+ my ($self, $text) = @_;
+ $text =~ s/^([.\'\\])/\\&$1/mg;
+ return $text;
+}
+
+# Make vertical whitespace if NEEDSPACE is set, appropriate to the indentation
+# level the situation. This function is needed since in *roff one has to
+# create vertical whitespace after paragraphs and between some things, but
+# other macros create their own whitespace. Also close out a sequence of
+# repeated =items, since calling makespace means we're about to begin the item
+# body.
+sub makespace {
+ my ($self) = @_;
+ $self->output (".PD\n") if $$self{ITEMS} > 1;
+ $$self{ITEMS} = 0;
+ $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n")
+ if $$self{NEEDSPACE};
+}
+
+# Output any pending index entries, and optionally an index entry given as an
+# argument. Support multiple index entries in X<> separated by slashes, and
+# strip special escapes from index entries.
+sub outindex {
+ my ($self, $section, $index) = @_;
+ my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
+ return unless ($section || @entries);
+
+ # We're about to output all pending entries, so clear our pending queue.
+ $$self{INDEX} = [];
+
+ # Build the output. Regular index entries are marked Xref, and headings
+ # pass in their own section. Undo some *roff formatting on headings.
+ my @output;
+ if (@entries) {
+ push @output, [ 'Xref', join (' ', @entries) ];
+ }
+ if ($section) {
+ $index =~ s/\\-/-/g;
+ $index =~ s/\\(?:s-?\d|.\(..|.)//g;
+ push @output, [ $section, $index ];
+ }
+
+ # Print out the .IX commands.
+ for (@output) {
+ my ($type, $entry) = @$_;
+ $entry =~ s/\"/\"\"/g;
+ $entry =~ s/\\/\\\\/g;
+ $self->output (".IX $type " . '"' . $entry . '"' . "\n");
+ }
+}
+
+# Output some text, without any additional changes.
+sub output {
+ my ($self, @text) = @_;
+ print { $$self{output_fh} } @text;
+}
+
+##############################################################################
+# Document initialization
+##############################################################################
+
+# Handle the start of the document. Here we handle empty documents, as well
+# as setting up our basic macros in a preamble and building the page title.
+sub start_document {
+ my ($self, $attrs) = @_;
+ if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
+ DEBUG and print "Document is contentless\n";
+ $$self{CONTENTLESS} = 1;
+ return;
+ }
+
+ # If we were given the utf8 option, set an output encoding on our file
+ # handle. Wrap in an eval in case we're using a version of Perl too old
+ # to understand this.
+ #
+ # This is evil because it changes the global state of a file handle that
+ # we may not own. However, we can't just blindly encode all output, since
+ # there may be a pre-applied output encoding (such as from PERL_UNICODE)
+ # and then we would double-encode. This seems to be the least bad
+ # approach.
+ if ($$self{utf8}) {
+ eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') };
+ }
+
+ # Determine information for the preamble and then output it.
+ my ($name, $section);
+ if (defined $$self{name}) {
+ $name = $$self{name};
+ $section = $$self{section} || 1;
+ } else {
+ ($name, $section) = $self->devise_title;
+ }
+ my $date = $$self{date} || $self->devise_date;
+ $self->preamble ($name, $section, $date)
+ unless $self->bare_output or DEBUG > 9;
+
+ # Initialize a few per-document variables.
+ $$self{INDENT} = 0; # Current indentation level.
+ $$self{INDENTS} = []; # Stack of indentations.
+ $$self{INDEX} = []; # Index keys waiting to be printed.
+ $$self{IN_NAME} = 0; # Whether processing the NAME section.
+ $$self{ITEMS} = 0; # The number of consecutive =items.
+ $$self{ITEMTYPES} = []; # Stack of =item types, one per list.
+ $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting.
+ $$self{SHIFTS} = []; # Stack of .RS shifts.
+ $$self{PENDING} = [[]]; # Pending output.
+}
+
+# Handle the end of the document. This does nothing but print out a final
+# comment at the end of the document under debugging.
+sub end_document {
+ my ($self) = @_;
+ return if $self->bare_output;
+ return if ($$self{CONTENTLESS} && !$$self{ALWAYS_EMIT_SOMETHING});
+ $self->output (q(.\" [End document]) . "\n") if DEBUG;
+}
+
+# Try to figure out the name and section from the file name and return them as
+# a list, returning an empty name and section 1 if we can't find any better
+# information. Uses File::Basename and File::Spec as necessary.
+sub devise_title {
+ my ($self) = @_;
+ my $name = $self->source_filename || '';
+ my $section = $$self{section} || 1;
+ $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i);
+ $name =~ s/\.p(od|[lm])\z//i;
+
+ # If the section isn't 3, then the name defaults to just the basename of
+ # the file. Otherwise, assume we're dealing with a module. We want to
+ # figure out the full module name from the path to the file, but we don't
+ # want to include too much of the path into the module name. Lose
+ # anything up to the first off:
+ #
+ # */lib/*perl*/ standard or site_perl module
+ # */*perl*/lib/ from -Dprefix=/opt/perl
+ # */*perl*/ random module hierarchy
+ #
+ # which works. Also strip off a leading site, site_perl, or vendor_perl
+ # component, any OS-specific component, and any version number component,
+ # and strip off an initial component of "lib" or "blib/lib" since that's
+ # what ExtUtils::MakeMaker creates. splitdir requires at least File::Spec
+ # 0.8.
+ if ($section !~ /^3/) {
+ require File::Basename;
+ $name = uc File::Basename::basename ($name);
+ } else {
+ require File::Spec;
+ my ($volume, $dirs, $file) = File::Spec->splitpath ($name);
+ my @dirs = File::Spec->splitdir ($dirs);
+ my $cut = 0;
+ my $i;
+ for ($i = 0; $i < @dirs; $i++) {
+ if ($dirs[$i] =~ /perl/) {
+ $cut = $i + 1;
+ $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib');
+ last;
+ }
+ }
+ if ($cut > 0) {
+ splice (@dirs, 0, $cut);
+ shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/);
+ shift @dirs if ($dirs[0] =~ /^[\d.]+$/);
+ shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/);
+ }
+ shift @dirs if $dirs[0] eq 'lib';
+ splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib');
+
+ # Remove empty directories when building the module name; they
+ # occur too easily on Unix by doubling slashes.
+ $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file);
+ }
+ return ($name, $section);
+}
+
+# Determine the modification date and return that, properly formatted in ISO
+# format. If we can't get the modification date of the input, instead use the
+# current time. Pod::Simple returns a completely unuseful stringified file
+# handle as the source_filename for input from a file handle, so we have to
+# deal with that as well.
+sub devise_date {
+ my ($self) = @_;
+ my $input = $self->source_filename;
+ my $time;
+ if ($input) {
+ $time = (stat $input)[9] || time;
+ } else {
+ $time = time;
+ }
+
+ # Can't use POSIX::strftime(), which uses Fcntl, because MakeMaker
+ # uses this and it has to work in the core which can't load dynamic
+ # libraries.
+ my ($year, $month, $day) = (localtime $time)[5,4,3];
+ return sprintf ("%04d-%02d-%02d", $year + 1900, $month + 1, $day);
+}
+
+# Print out the preamble and the title. The meaning of the arguments to .TH
+# unfortunately vary by system; some systems consider the fourth argument to
+# be a "source" and others use it as a version number. Generally it's just
+# presented as the left-side footer, though, so it doesn't matter too much if
+# a particular system gives it another interpretation.
+#
+# The order of date and release used to be reversed in older versions of this
+# module, but this order is correct for both Solaris and Linux.
+sub preamble {
+ my ($self, $name, $section, $date) = @_;
+ my $preamble = $self->preamble_template (!$$self{utf8});
+
+ # Build the index line and make sure that it will be syntactically valid.
+ my $index = "$name $section";
+ $index =~ s/\"/\"\"/g;
+
+ # If name or section contain spaces, quote them (section really never
+ # should, but we may as well be cautious).
+ for ($name, $section) {
+ if (/\s/) {
+ s/\"/\"\"/g;
+ $_ = '"' . $_ . '"';
+ }
+ }
+
+ # Double quotes in date, since it will be quoted.
+ $date =~ s/\"/\"\"/g;
+
+ # Substitute into the preamble the configuration options.
+ $preamble =~ s/\@CFONT\@/$$self{fixed}/;
+ $preamble =~ s/\@LQUOTE\@/$$self{LQUOTE}/;
+ $preamble =~ s/\@RQUOTE\@/$$self{RQUOTE}/;
+ chomp $preamble;
+
+ # Get the version information.
+ my $version = $self->version_report;
+
+ # Finally output everything.
+ $self->output (<<"----END OF HEADER----");
+.\\" Automatically generated by $version
+.\\"
+.\\" Standard preamble:
+.\\" ========================================================================
+$preamble
+.\\" ========================================================================
+.\\"
+.IX Title "$index"
+.TH $name $section "$date" "$$self{release}" "$$self{center}"
+.\\" For nroff, turn off justification. Always turn off hyphenation; it makes
+.\\" way too many mistakes in technical documents.
+.if n .ad l
+.nh
+----END OF HEADER----
+ $self->output (".\\\" [End of preamble]\n") if DEBUG;
+}
+
+##############################################################################
+# Text blocks
+##############################################################################
+
+# Handle a basic block of text. The only tricky part of this is if this is
+# the first paragraph of text after an =over, in which case we have to change
+# indentations for *roff.
+sub cmd_para {
+ my ($self, $attrs, $text) = @_;
+ my $line = $$attrs{start_line};
+
+ # Output the paragraph. We also have to handle =over without =item. If
+ # there's an =over without =item, SHIFTWAIT will be set, and we need to
+ # handle creation of the indent here. Add the shift to SHIFTS so that it
+ # will be cleaned up on =back.
+ $self->makespace;
+ if ($$self{SHIFTWAIT}) {
+ $self->output (".RS $$self{INDENT}\n");
+ push (@{ $$self{SHIFTS} }, $$self{INDENT});
+ $$self{SHIFTWAIT} = 0;
+ }
+
+ # Add the line number for debugging, but not in the NAME section just in
+ # case the comment would confuse apropos.
+ $self->output (".\\\" [At source line $line]\n")
+ if defined ($line) && DEBUG && !$$self{IN_NAME};
+
+ # Force exactly one newline at the end and strip unwanted trailing
+ # whitespace at the end.
+ $text =~ s/\s*$/\n/;
+
+ # Output the paragraph.
+ $self->output ($self->protect ($self->textmapfonts ($text)));
+ $self->outindex;
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+# Handle a verbatim paragraph. Put a null token at the beginning of each line
+# to protect against commands and wrap in .Vb/.Ve (which we define in our
+# prelude).
+sub cmd_verbatim {
+ my ($self, $attrs, $text) = @_;
+
+ # Ignore an empty verbatim paragraph.
+ return unless $text =~ /\S/;
+
+ # Force exactly one newline at the end and strip unwanted trailing
+ # whitespace at the end.
+ $text =~ s/\s*$/\n/;
+
+ # Get a count of the number of lines before the first blank line, which
+ # we'll pass to .Vb as its parameter. This tells *roff to keep that many
+ # lines together. We don't want to tell *roff to keep huge blocks
+ # together.
+ my @lines = split (/\n/, $text);
+ my $unbroken = 0;
+ for (@lines) {
+ last if /^\s*$/;
+ $unbroken++;
+ }
+ $unbroken = 10 if ($unbroken > 12 && !$$self{MAGIC_VNOPAGEBREAK_LIMIT});
+
+ # Prepend a null token to each line.
+ $text =~ s/^/\\&/gm;
+
+ # Output the results.
+ $self->makespace;
+ $self->output (".Vb $unbroken\n$text.Ve\n");
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+# Handle literal text (produced by =for and similar constructs). Just output
+# it with the minimum of changes.
+sub cmd_data {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/^\n+//;
+ $text =~ s/\n{0,2}$/\n/;
+ $self->output ($text);
+ return '';
+}
+
+##############################################################################
+# Headings
+##############################################################################
+
+# Common code for all headings. This is called before the actual heading is
+# output. It returns the cleaned up heading text (putting the heading all on
+# one line) and may do other things, like closing bad =item blocks.
+sub heading_common {
+ my ($self, $text, $line) = @_;
+ $text =~ s/\s+$//;
+ $text =~ s/\s*\n\s*/ /g;
+
+ # This should never happen; it means that we have a heading after =item
+ # without an intervening =back. But just in case, handle it anyway.
+ if ($$self{ITEMS} > 1) {
+ $$self{ITEMS} = 0;
+ $self->output (".PD\n");
+ }
+
+ # Output the current source line.
+ $self->output ( ".\\\" [At source line $line]\n" )
+ if defined ($line) && DEBUG;
+ return $text;
+}
+
+# First level heading. We can't output .IX in the NAME section due to a bug
+# in some versions of catman, so don't output a .IX for that section. .SH
+# already uses small caps, so remove \s0 and \s-1. Maintain IN_NAME as
+# appropriate.
+sub cmd_head1 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\\s-?\d//g;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ my $isname = ($text eq 'NAME' || $text =~ /\(NAME\)/);
+ $self->output ($self->switchquotes ('.SH', $self->mapfonts ($text)));
+ $self->outindex ('Header', $text) unless $isname;
+ $$self{NEEDSPACE} = 0;
+ $$self{IN_NAME} = $isname;
+ return '';
+}
+
+# Second level heading.
+sub cmd_head2 {
+ my ($self, $attrs, $text) = @_;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ $self->output ($self->switchquotes ('.SS', $self->mapfonts ($text)));
+ $self->outindex ('Subsection', $text);
+ $$self{NEEDSPACE} = 0;
+ return '';
+}
+
+# Third level heading. *roff doesn't have this concept, so just put the
+# heading in italics as a normal paragraph.
+sub cmd_head3 {
+ my ($self, $attrs, $text) = @_;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ $self->makespace;
+ $self->output ($self->textmapfonts ('\f(IS' . $text . '\f(IE') . "\n");
+ $self->outindex ('Subsection', $text);
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+# Fourth level heading. *roff doesn't have this concept, so just put the
+# heading as a normal paragraph.
+sub cmd_head4 {
+ my ($self, $attrs, $text) = @_;
+ $text = $self->heading_common ($text, $$attrs{start_line});
+ $self->makespace;
+ $self->output ($self->textmapfonts ($text) . "\n");
+ $self->outindex ('Subsection', $text);
+ $$self{NEEDSPACE} = 1;
+ return '';
+}
+
+##############################################################################
+# Formatting codes
+##############################################################################
+
+# All of the formatting codes that aren't handled internally by the parser,
+# other than L<> and X<>.
+sub cmd_b { return $_[0]->{IN_NAME} ? $_[2] : '\f(BS' . $_[2] . '\f(BE' }
+sub cmd_i { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' }
+sub cmd_f { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' }
+sub cmd_c { return $_[0]->quote_literal ($_[2]) }
+
+# Index entries are just added to the pending entries.
+sub cmd_x {
+ my ($self, $attrs, $text) = @_;
+ push (@{ $$self{INDEX} }, $text);
+ return '';
+}
+
+# Links reduce to the text that we're given, wrapped in angle brackets if it's
+# a URL.
+sub cmd_l {
+ my ($self, $attrs, $text) = @_;
+ if ($$attrs{type} eq 'url') {
+ if (not defined($$attrs{to}) or $$attrs{to} eq $text) {
+ return "<$text>";
+ } else {
+ return "$text <$$attrs{to}>";
+ }
+ } else {
+ return $text;
+ }
+}
+
+##############################################################################
+# List handling
+##############################################################################
+
+# Handle the beginning of an =over block. Takes the type of the block as the
+# first argument, and then the attr hash. This is called by the handlers for
+# the four different types of lists (bullet, number, text, and block).
+sub over_common_start {
+ my ($self, $type, $attrs) = @_;
+ my $line = $$attrs{start_line};
+ my $indent = $$attrs{indent};
+ DEBUG > 3 and print " Starting =over $type (line $line, indent ",
+ ($indent || '?'), "\n";
+
+ # Find the indentation level.
+ unless (defined ($indent) && $indent =~ /^[-+]?\d{1,4}\s*$/) {
+ $indent = $$self{indent};
+ }
+
+ # If we've gotten multiple indentations in a row, we need to emit the
+ # pending indentation for the last level that we saw and haven't acted on
+ # yet. SHIFTS is the stack of indentations that we've actually emitted
+ # code for.
+ if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) {
+ $self->output (".RS $$self{INDENT}\n");
+ push (@{ $$self{SHIFTS} }, $$self{INDENT});
+ }
+
+ # Now, do record-keeping. INDENTS is a stack of indentations that we've
+ # seen so far, and INDENT is the current level of indentation. ITEMTYPES
+ # is a stack of list types that we've seen.
+ push (@{ $$self{INDENTS} }, $$self{INDENT});
+ push (@{ $$self{ITEMTYPES} }, $type);
+ $$self{INDENT} = $indent + 0;
+ $$self{SHIFTWAIT} = 1;
+}
+
+# End an =over block. Takes no options other than the class pointer.
+# Normally, once we close a block and therefore remove something from INDENTS,
+# INDENTS will now be longer than SHIFTS, indicating that we also need to emit
+# *roff code to close the indent. This isn't *always* true, depending on the
+# circumstance. If we're still inside an indentation, we need to emit another
+# .RE and then a new .RS to unconfuse *roff.
+sub over_common_end {
+ my ($self) = @_;
+ DEBUG > 3 and print " Ending =over\n";
+ $$self{INDENT} = pop @{ $$self{INDENTS} };
+ pop @{ $$self{ITEMTYPES} };
+
+ # If we emitted code for that indentation, end it.
+ if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) {
+ $self->output (".RE\n");
+ pop @{ $$self{SHIFTS} };
+ }
+
+ # If we're still in an indentation, *roff will have now lost track of the
+ # right depth of that indentation, so fix that.
+ if (@{ $$self{INDENTS} } > 0) {
+ $self->output (".RE\n");
+ $self->output (".RS $$self{INDENT}\n");
+ }
+ $$self{NEEDSPACE} = 1;
+ $$self{SHIFTWAIT} = 0;
+}
+
+# Dispatch the start and end calls as appropriate.
+sub start_over_bullet { my $s = shift; $s->over_common_start ('bullet', @_) }
+sub start_over_number { my $s = shift; $s->over_common_start ('number', @_) }
+sub start_over_text { my $s = shift; $s->over_common_start ('text', @_) }
+sub start_over_block { my $s = shift; $s->over_common_start ('block', @_) }
+sub end_over_bullet { $_[0]->over_common_end }
+sub end_over_number { $_[0]->over_common_end }
+sub end_over_text { $_[0]->over_common_end }
+sub end_over_block { $_[0]->over_common_end }
+
+# The common handler for all item commands. Takes the type of the item, the
+# attributes, and then the text of the item.
+#
+# Emit an index entry for anything that's interesting, but don't emit index
+# entries for things like bullets and numbers. Newlines in an item title are
+# turned into spaces since *roff can't handle them embedded.
+sub item_common {
+ my ($self, $type, $attrs, $text) = @_;
+ my $line = $$attrs{start_line};
+ DEBUG > 3 and print " $type item (line $line): $text\n";
+
+ # Clean up the text. We want to end up with two variables, one ($text)
+ # which contains any body text after taking out the item portion, and
+ # another ($item) which contains the actual item text.
+ $text =~ s/\s+$//;
+ my ($item, $index);
+ if ($type eq 'bullet') {
+ $item = "\\\(bu";
+ $text =~ s/\n*$/\n/;
+ } elsif ($type eq 'number') {
+ $item = $$attrs{number} . '.';
+ } else {
+ $item = $text;
+ $item =~ s/\s*\n\s*/ /g;
+ $text = '';
+ $index = $item if ($item =~ /\w/);
+ }
+
+ # Take care of the indentation. If shifts and indents are equal, close
+ # the top shift, since we're about to create an indentation with .IP.
+ # Also output .PD 0 to turn off spacing between items if this item is
+ # directly following another one. We only have to do that once for a
+ # whole chain of items so do it for the second item in the change. Note
+ # that makespace is what undoes this.
+ if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) {
+ $self->output (".RE\n");
+ pop @{ $$self{SHIFTS} };
+ }
+ $self->output (".PD 0\n") if ($$self{ITEMS} == 1);
+
+ # Now, output the item tag itself.
+ $item = $self->textmapfonts ($item);
+ $self->output ($self->switchquotes ('.IP', $item, $$self{INDENT}));
+ $$self{NEEDSPACE} = 0;
+ $$self{ITEMS}++;
+ $$self{SHIFTWAIT} = 0;
+
+ # If body text for this item was included, go ahead and output that now.
+ if ($text) {
+ $text =~ s/\s*$/\n/;
+ $self->makespace;
+ $self->output ($self->protect ($self->textmapfonts ($text)));
+ $$self{NEEDSPACE} = 1;
+ }
+ $self->outindex ($index ? ('Item', $index) : ());
+}
+
+# Dispatch the item commands to the appropriate place.
+sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
+sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
+sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
+sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
+
+##############################################################################
+# Backward compatibility
+##############################################################################
+
+# Reset the underlying Pod::Simple object between calls to parse_from_file so
+# that the same object can be reused to convert multiple pages.
+sub parse_from_file {
+ my $self = shift;
+ $self->reinit;
+
+ # Fake the old cutting option to Pod::Parser. This fiddings with internal
+ # Pod::Simple state and is quite ugly; we need a better approach.
+ if (ref ($_[0]) eq 'HASH') {
+ my $opts = shift @_;
+ if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
+ $$self{in_pod} = 1;
+ $$self{last_was_blank} = 1;
+ }
+ }
+
+ # Do the work.
+ my $retval = $self->SUPER::parse_from_file (@_);
+
+ # Flush output, since Pod::Simple doesn't do this. Ideally we should also
+ # close the file descriptor if we had to open one, but we can't easily
+ # figure this out.
+ my $fh = $self->output_fh ();
+ my $oldfh = select $fh;
+ my $oldflush = $|;
+ $| = 1;
+ print $fh '';
+ $| = $oldflush;
+ select $oldfh;
+ return $retval;
+}
+
+# Pod::Simple failed to provide this backward compatibility function, so
+# implement it ourselves. File handles are one of the inputs that
+# parse_from_file supports.
+sub parse_from_filehandle {
+ my $self = shift;
+ $self->parse_from_file (@_);
+}
+
+##############################################################################
+# Translation tables
+##############################################################################
+
+# The following table is adapted from Tom Christiansen's pod2man. It assumes
+# that the standard preamble has already been printed, since that's what
+# defines all of the accent marks. We really want to do something better than
+# this when *roff actually supports other character sets itself, since these
+# results are pretty poor.
+#
+# This only works in an ASCII world. What to do in a non-ASCII world is very
+# unclear -- hopefully we can assume UTF-8 and just leave well enough alone.
+@ESCAPES{0xA0 .. 0xFF} = (
+ "\\ ", undef, undef, undef, undef, undef, undef, undef,
+ undef, undef, undef, undef, undef, "\\%", undef, undef,
+
+ undef, undef, undef, undef, undef, undef, undef, undef,
+ undef, undef, undef, undef, undef, undef, undef, undef,
+
+ "A\\*`", "A\\*'", "A\\*^", "A\\*~", "A\\*:", "A\\*o", "\\*(AE", "C\\*,",
+ "E\\*`", "E\\*'", "E\\*^", "E\\*:", "I\\*`", "I\\*'", "I\\*^", "I\\*:",
+
+ "\\*(D-", "N\\*~", "O\\*`", "O\\*'", "O\\*^", "O\\*~", "O\\*:", undef,
+ "O\\*/", "U\\*`", "U\\*'", "U\\*^", "U\\*:", "Y\\*'", "\\*(Th", "\\*8",
+
+ "a\\*`", "a\\*'", "a\\*^", "a\\*~", "a\\*:", "a\\*o", "\\*(ae", "c\\*,",
+ "e\\*`", "e\\*'", "e\\*^", "e\\*:", "i\\*`", "i\\*'", "i\\*^", "i\\*:",
+
+ "\\*(d-", "n\\*~", "o\\*`", "o\\*'", "o\\*^", "o\\*~", "o\\*:", undef,
+ "o\\*/" , "u\\*`", "u\\*'", "u\\*^", "u\\*:", "y\\*'", "\\*(th", "y\\*:",
+) if ASCII;
+
+##############################################################################
+# Premable
+##############################################################################
+
+# The following is the static preamble which starts all *roff output we
+# generate. Most is static except for the font to use as a fixed-width font,
+# which is designed by @CFONT@, and the left and right quotes to use for C<>
+# text, designated by @LQOUTE@ and @RQUOTE@. However, the second part, which
+# defines the accent marks, is only used if $escapes is set to true.
+sub preamble_template {
+ my ($self, $accents) = @_;
+ my $preamble = <<'----END OF PREAMBLE----';
+.de Sp \" Vertical space (when we can't use .PP)
+.if t .sp .5v
+.if n .sp
+..
+.de Vb \" Begin verbatim text
+.ft @CFONT@
+.nf
+.ne \\$1
+..
+.de Ve \" End verbatim text
+.ft R
+.fi
+..
+.\" Set up some character translations and predefined strings. \*(-- will
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
+.\" double quote, and \*(R" will give a right double quote. \*(C+ will
+.\" give a nicer C++. Capital omega is used to do unbreakable dashes and
+.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff,
+.\" nothing in troff, for use with C<>.
+.tr \(*W-
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
+.ie n \{\
+. ds -- \(*W-
+. ds PI pi
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+. ds L" ""
+. ds R" ""
+. ds C` @LQUOTE@
+. ds C' @RQUOTE@
+'br\}
+.el\{\
+. ds -- \|\(em\|
+. ds PI \(*p
+. ds L" ``
+. ds R" ''
+'br\}
+.\"
+.\" Escape single quotes in literal strings from groff's Unicode transform.
+.ie \n(.g .ds Aq \(aq
+.el .ds Aq '
+.\"
+.\" If the F register is turned on, we'll generate index entries on stderr for
+.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index
+.\" entries marked with X<> in POD. Of course, you'll have to process the
+.\" output yourself in some meaningful fashion.
+.ie \nF \{\
+. de IX
+. tm Index:\\$1\t\\n%\t"\\$2"
+..
+. nr % 0
+. rr F
+.\}
+.el \{\
+. de IX
+..
+.\}
+----END OF PREAMBLE----
+
+ if ($accents) {
+ $preamble .= <<'----END OF PREAMBLE----'
+.\"
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
+.\" Fear. Run. Save yourself. No user-serviceable parts.
+. \" fudge factors for nroff and troff
+.if n \{\
+. ds #H 0
+. ds #V .8m
+. ds #F .3m
+. ds #[ \f1
+. ds #] \fP
+.\}
+.if t \{\
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
+. ds #V .6m
+. ds #F 0
+. ds #[ \&
+. ds #] \&
+.\}
+. \" simple accents for nroff and troff
+.if n \{\
+. ds ' \&
+. ds ` \&
+. ds ^ \&
+. ds , \&
+. ds ~ ~
+. ds /
+.\}
+.if t \{\
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
+.\}
+. \" troff and (daisy-wheel) nroff accents
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
+.ds ae a\h'-(\w'a'u*4/10)'e
+.ds Ae A\h'-(\w'A'u*4/10)'E
+. \" corrections for vroff
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
+. \" for low resolution devices (crt and lpr)
+.if \n(.H>23 .if \n(.V>19 \
+\{\
+. ds : e
+. ds 8 ss
+. ds o a
+. ds d- d\h'-1'\(ga
+. ds D- D\h'-1'\(hy
+. ds th \o'bp'
+. ds Th \o'LP'
+. ds ae ae
+. ds Ae AE
+.\}
+.rm #[ #] #H #V #F C
+----END OF PREAMBLE----
+#`# for cperl-mode
+ }
+ return $preamble;
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Man - Convert POD data to formatted *roff input
+
+=for stopwords
+en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8
+UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased
+Christiansen
+
+=head1 SYNOPSIS
+
+ use Pod::Man;
+ my $parser = Pod::Man->new (release => $VERSION, section => 8);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_file (\*STDIN);
+
+ # Read POD from file.pod and write to file.1.
+ $parser->parse_from_file ('file.pod', 'file.1');
+
+=head1 DESCRIPTION
+
+Pod::Man is a module to convert documentation in the POD format (the
+preferred language for documenting Perl) into *roff input using the man
+macro set. The resulting *roff code is suitable for display on a terminal
+using L<nroff(1)>, normally via L<man(1)>, or printing using L<troff(1)>.
+It is conventionally invoked using the driver script B<pod2man>, but it can
+also be used directly.
+
+As a derived class from Pod::Simple, Pod::Man supports the same methods and
+interfaces. See L<Pod::Simple> for all the details.
+
+new() can take options, in the form of key/value pairs that control the
+behavior of the parser. See below for details.
+
+If no options are given, Pod::Man uses the name of the input file with any
+trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to
+section 1 unless the file ended in C<.pm> in which case it defaults to
+section 3, to a centered title of "User Contributed Perl Documentation", to
+a centered footer of the Perl version it is run with, and to a left-hand
+footer of the modification date of its input (or the current date if given
+C<STDIN> for input).
+
+Pod::Man assumes that your *roff formatters have a fixed-width font named
+C<CW>. If yours is called something else (like C<CR>), use the C<fixed>
+option to specify it. This generally only matters for troff output for
+printing. Similarly, you can set the fonts used for bold, italic, and
+bold italic fixed-width output.
+
+Besides the obvious pod conversions, Pod::Man also takes care of
+formatting func(), func(3), and simple variable references like $foo or
+@bar so you don't have to use code escapes for them; complex expressions
+like C<$fred{'stuff'}> will still need to be escaped, though. It also
+translates dashes that aren't used as hyphens into en dashes, makes long
+dashes--like this--into proper em dashes, fixes "paired quotes," makes C++
+look right, puts a little space between double underscores, makes ALLCAPS
+a teeny bit smaller in B<troff>, and escapes stuff that *roff treats as
+special so that you don't have to.
+
+The recognized options to new() are as follows. All options take a single
+argument.
+
+=over 4
+
+=item center
+
+Sets the centered page header to use instead of "User Contributed Perl
+Documentation".
+
+=item date
+
+Sets the left-hand footer. By default, the modification date of the input
+file will be used, or the current date if stat() can't find that file (the
+case if the input is from C<STDIN>), and the date will be formatted as
+C<YYYY-MM-DD>.
+
+=item fixed
+
+The fixed-width font to use for verbatim text and code. Defaults to
+C<CW>. Some systems may want C<CR> instead. Only matters for B<troff>
+output.
+
+=item fixedbold
+
+Bold version of the fixed-width font. Defaults to C<CB>. Only matters
+for B<troff> output.
+
+=item fixeditalic
+
+Italic version of the fixed-width font (actually, something of a misnomer,
+since most fixed-width fonts only have an oblique version, not an italic
+version). Defaults to C<CI>. Only matters for B<troff> output.
+
+=item fixedbolditalic
+
+Bold italic (probably actually oblique) version of the fixed-width font.
+Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
+systems (such as Solaris) have this font available as C<CX>. Only matters
+for B<troff> output.
+
+=item name
+
+Set the name of the manual page. Without this option, the manual name is
+set to the uppercased base name of the file being converted unless the
+manual section is 3, in which case the path is parsed to see if it is a Perl
+module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted into
+a name like C<Pod::Man>. This option, if given, overrides any automatic
+determination of the name.
+
+=item quotes
+
+Sets the quote marks used to surround CE<lt>> text. If the value is a
+single character, it is used as both the left and right quote; if it is two
+characters, the first character is used as the left quote and the second as
+the right quoted; and if it is four characters, the first two are used as
+the left quote and the second two as the right quote.
+
+This may also be set to the special value C<none>, in which case no quote
+marks are added around CE<lt>> text (but the font is still changed for troff
+output).
+
+=item release
+
+Set the centered footer. By default, this is the version of Perl you run
+Pod::Man under. Note that some system an macro sets assume that the
+centered footer will be a modification date and will prepend something like
+"Last modified: "; if this is the case, you may want to set C<release> to
+the last modified date and C<date> to the version number.
+
+=item section
+
+Set the section for the C<.TH> macro. The standard section numbering
+convention is to use 1 for user commands, 2 for system calls, 3 for
+functions, 4 for devices, 5 for file formats, 6 for games, 7 for
+miscellaneous information, and 8 for administrator commands. There is a lot
+of variation here, however; some systems (like Solaris) use 4 for file
+formats, 5 for miscellaneous information, and 7 for devices. Still others
+use 1m instead of 8, or some mix of both. About the only section numbers
+that are reliably consistent are 1, 2, and 3.
+
+By default, section 1 will be used unless the file ends in C<.pm> in which
+case section 3 will be selected.
+
+=item stderr
+
+Send error messages about invalid POD to standard error instead of
+appending a POD ERRORS section to the generated *roff output.
+
+=item utf8
+
+By default, Pod::Man produces the most conservative possible *roff output
+to try to ensure that it will work with as many different *roff
+implementations as possible. Many *roff implementations cannot handle
+non-ASCII characters, so this means all non-ASCII characters are converted
+either to a *roff escape sequence that tries to create a properly accented
+character (at least for troff output) or to C<X>.
+
+If this option is set, Pod::Man will instead output UTF-8. If your *roff
+implementation can handle it, this is the best output format to use and
+avoids corruption of documents containing non-ASCII characters. However,
+be warned that *roff source with literal UTF-8 characters is not supported
+by many implementations and may even result in segfaults and other bad
+behavior.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=back
+
+The standard Pod::Simple method parse_file() takes one argument naming the
+POD file to read from. By default, the output is sent to C<STDOUT>, but
+this can be changed with the output_fd() method.
+
+The standard Pod::Simple method parse_from_file() takes up to two
+arguments, the first being the input file to read POD from and the second
+being the file to write the formatted output to.
+
+You can also call parse_lines() to parse an array of lines or
+parse_string_document() to parse a document already in memory. To put the
+output into a string instead of a file handle, call the output_string()
+method. See L<Pod::Simple> for the specific details.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item roff font should be 1 or 2 chars, not "%s"
+
+(F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that
+wasn't either one or two characters. Pod::Man doesn't support *roff fonts
+longer than two characters, although some *roff extensions do (the canonical
+versions of B<nroff> and B<troff> don't either).
+
+=item Invalid quote specification "%s"
+
+(F) The quote specification given (the quotes option to the constructor) was
+invalid. A quote specification must be one, two, or four characters long.
+
+=back
+
+=head1 BUGS
+
+Encoding handling assumes that PerlIO is available and does not work
+properly if it isn't. The C<utf8> option is therefore not supported
+unless Perl is built with PerlIO support.
+
+There is currently no way to turn off the guesswork that tries to format
+unmarked text appropriately, and sometimes it isn't wanted (particularly
+when using POD to document something other than Perl). Most of the work
+toward fixing this has now been done, however, and all that's still needed
+is a user interface.
+
+The NAME section should be recognized specially and index entries emitted
+for everything in that section. This would have to be deferred until the
+next section, since extraneous things in NAME tends to confuse various man
+page processors. Currently, no index entries are emitted for anything in
+NAME.
+
+Pod::Man doesn't handle font names longer than two characters. Neither do
+most B<troff> implementations, but GNU troff does as an extension. It would
+be nice to support as an option for those who want to use it.
+
+The preamble added to each output file is rather verbose, and most of it
+is only necessary in the presence of non-ASCII characters. It would
+ideally be nice if all of those definitions were only output if needed,
+perhaps on the fly as the characters are used.
+
+Pod::Man is excessively slow.
+
+=head1 CAVEATS
+
+If Pod::Man is given the C<utf8> option, the encoding of its output file
+handle will be forced to UTF-8 if possible, overriding any existing
+encoding. This will be done even if the file handle is not created by
+Pod::Man and was passed in from outside. This maintains consistency
+regardless of PERL_UNICODE and other settings.
+
+The handling of hyphens and em dashes is somewhat fragile, and one may get
+the wrong one under some circumstances. This should only matter for
+B<troff> output.
+
+When and whether to use small caps is somewhat tricky, and Pod::Man doesn't
+necessarily get it right.
+
+Converting neutral double quotes to properly matched double quotes doesn't
+work unless there are no formatting codes between the quote marks. This
+only matters for troff output.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
+B<pod2man> by Tom Christiansen <tchrist@mox.perl.com>. The modifications to
+work with Pod::Simple instead of Pod::Parser were originally contributed by
+Sean Burke (but I've since hacked them beyond recognition and all bugs are
+mine).
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+Russ Allbery <rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<perlpod(1)>, L<pod2man(1)>, L<nroff(1)>, L<troff(1)>,
+L<man(1)>, L<man(7)>
+
+Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual,"
+Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is
+the best documentation of standard B<nroff> and B<troff>. At the time of
+this writing, it's available at
+L<http://www.cs.bell-labs.com/cm/cs/cstr.html>.
+
+The man page documenting the man macro set may be L<man(5)> instead of
+L<man(7)> on your system. Also, please see L<pod2man(1)> for extensive
+documentation on writing manual pages if you've not done it before and
+aren't familiar with the conventions.
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/ParseLink.pm b/Master/tlpkg/tlperl.straw/lib/Pod/ParseLink.pm
new file mode 100755
index 00000000000..750fdfb88dc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/ParseLink.pm
@@ -0,0 +1,192 @@
+# Pod::ParseLink -- Parse an L<> formatting code in POD text.
+#
+# Copyright 2001, 2008, 2009 by Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module implements parsing of the text of an L<> formatting code as
+# defined in perlpodspec. It should be suitable for any POD formatter. It
+# exports only one function, parselink(), which returns the five-item parse
+# defined in perlpodspec.
+#
+# Perl core hackers, please note that this module is also separately
+# maintained outside of the Perl core as part of the podlators. Please send
+# me any patches at the address above in addition to sending them to the
+# standard Perl mailing lists.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::ParseLink;
+
+require 5.004;
+
+use strict;
+use vars qw(@EXPORT @ISA $VERSION);
+
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(parselink);
+
+$VERSION = '1.10';
+
+##############################################################################
+# Implementation
+##############################################################################
+
+# Parse the name and section portion of a link into a name and section.
+sub _parse_section {
+ my ($link) = @_;
+ $link =~ s/^\s+//;
+ $link =~ s/\s+$//;
+
+ # If the whole link is enclosed in quotes, interpret it all as a section
+ # even if it contains a slash.
+ return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/);
+
+ # Split into page and section on slash, and then clean up quoting in the
+ # section. If there is no section and the name contains spaces, also
+ # guess that it's an old section link.
+ my ($page, $section) = split (/\s*\/\s*/, $link, 2);
+ $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section;
+ if ($page && $page =~ / / && !defined ($section)) {
+ $section = $page;
+ $page = undef;
+ } else {
+ $page = undef unless $page;
+ $section = undef unless $section;
+ }
+ return ($page, $section);
+}
+
+# Infer link text from the page and section.
+sub _infer_text {
+ my ($page, $section) = @_;
+ my $inferred;
+ if ($page && !$section) {
+ $inferred = $page;
+ } elsif (!$page && $section) {
+ $inferred = '"' . $section . '"';
+ } elsif ($page && $section) {
+ $inferred = '"' . $section . '" in ' . $page;
+ }
+ return $inferred;
+}
+
+# Given the contents of an L<> formatting code, parse it into the link text,
+# the possibly inferred link text, the name or URL, the section, and the type
+# of link (pod, man, or url).
+sub parselink {
+ my ($link) = @_;
+ $link =~ s/\s+/ /g;
+ my $text;
+ if ($link =~ /\|/) {
+ ($text, $link) = split (/\|/, $link, 2);
+ }
+ if ($link =~ /\A\w+:[^:\s]\S*\Z/) {
+ my $inferred;
+ if (defined ($text) && length ($text) > 0) {
+ return ($text, $text, $link, undef, 'url');
+ } else {
+ return ($text, $link, $link, undef, 'url');
+ }
+ } else {
+ my ($name, $section) = _parse_section ($link);
+ my $inferred;
+ if (defined ($text) && length ($text) > 0) {
+ $inferred = $text;
+ } else {
+ $inferred = _infer_text ($name, $section);
+ }
+ my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod';
+ return ($text, $inferred, $name, $section, $type);
+ }
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+# Ensure we evaluate to true.
+1;
+__END__
+
+=head1 NAME
+
+Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text
+
+=for stopwords
+markup Allbery URL
+
+=head1 SYNOPSIS
+
+ use Pod::ParseLink;
+ my ($text, $inferred, $name, $section, $type) = parselink ($link);
+
+=head1 DESCRIPTION
+
+This module only provides a single function, parselink(), which takes the
+text of an LE<lt>E<gt> formatting code and parses it. It returns the
+anchor text for the link (if any was given), the anchor text possibly
+inferred from the name and section, the name or URL, the section if any,
+and the type of link. The type will be one of C<url>, C<pod>, or C<man>,
+indicating a URL, a link to a POD page, or a link to a Unix manual page.
+
+Parsing is implemented per L<perlpodspec>. For backward compatibility,
+links where there is no section and name contains spaces, or links where the
+entirety of the link (except for the anchor text if given) is enclosed in
+double-quotes are interpreted as links to a section (LE<lt>/sectionE<gt>).
+
+The inferred anchor text is implemented per L<perlpodspec>:
+
+ L<name> => L<name|name>
+ L</section> => L<"section"|/section>
+ L<name/section> => L<"section" in name|name/section>
+
+The name may contain embedded EE<lt>E<gt> and ZE<lt>E<gt> formatting codes,
+and the section, anchor text, and inferred anchor text may contain any
+formatting codes. Any double quotes around the section are removed as part
+of the parsing, as is any leading or trailing whitespace.
+
+If the text of the LE<lt>E<gt> escape is entirely enclosed in double
+quotes, it's interpreted as a link to a section for backward
+compatibility.
+
+No attempt is made to resolve formatting codes. This must be done after
+calling parselink() (since EE<lt>E<gt> formatting codes can be used to
+escape characters that would otherwise be significant to the parser and
+resolving them before parsing would result in an incorrect parse of a
+formatting code like:
+
+ L<verticalE<verbar>barE<sol>slash>
+
+which should be interpreted as a link to the C<vertical|bar/slash> POD page
+and not as a link to the C<slash> section of the C<bar> POD page with an
+anchor text of C<vertical>. Note that not only the anchor text will need to
+have formatting codes expanded, but so will the target of the link (to deal
+with EE<lt>E<gt> and ZE<lt>E<gt> formatting codes), and special handling of
+the section may be necessary depending on whether the translator wants to
+consider markup in sections to be significant when resolving links. See
+L<perlpodspec> for more information.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2001, 2008, 2009 Russ Allbery <rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/ParseUtils.pm b/Master/tlpkg/tlperl.straw/lib/Pod/ParseUtils.pm
new file mode 100755
index 00000000000..f3c7ef46779
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/ParseUtils.pm
@@ -0,0 +1,855 @@
+#############################################################################
+# Pod/ParseUtils.pm -- helpers for POD parsing and conversion
+#
+# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::ParseUtils;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '1.36'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+=head1 NAME
+
+Pod::ParseUtils - helpers for POD parsing and conversion
+
+=head1 SYNOPSIS
+
+ use Pod::ParseUtils;
+
+ my $list = new Pod::List;
+ my $link = Pod::Hyperlink->new('Pod::Parser');
+
+=head1 DESCRIPTION
+
+B<Pod::ParseUtils> contains a few object-oriented helper packages for
+POD parsing and processing (i.e. in POD formatters and translators).
+
+=cut
+
+#-----------------------------------------------------------------------------
+# Pod::List
+#
+# class to hold POD list info (=over, =item, =back)
+#-----------------------------------------------------------------------------
+
+package Pod::List;
+
+use Carp;
+
+=head2 Pod::List
+
+B<Pod::List> can be used to hold information about POD lists
+(written as =over ... =item ... =back) for further processing.
+The following methods are available:
+
+=over 4
+
+=item Pod::List-E<gt>new()
+
+Create a new list object. Properties may be specified through a hash
+reference like this:
+
+ my $list = Pod::List->new({ -start => $., -indent => 4 });
+
+See the individual methods/properties for details.
+
+=cut
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my %params = @_;
+ my $self = {%params};
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+}
+
+sub initialize {
+ my $self = shift;
+ $self->{-file} ||= 'unknown';
+ $self->{-start} ||= 'unknown';
+ $self->{-indent} ||= 4; # perlpod: "should be the default"
+ $self->{_items} = [];
+ $self->{-type} ||= '';
+}
+
+=item $list-E<gt>file()
+
+Without argument, retrieves the file name the list is in. This must
+have been set before by either specifying B<-file> in the B<new()>
+method or by calling the B<file()> method with a scalar argument.
+
+=cut
+
+# The POD file name the list appears in
+sub file {
+ return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
+}
+
+=item $list-E<gt>start()
+
+Without argument, retrieves the line number where the list started.
+This must have been set before by either specifying B<-start> in the
+B<new()> method or by calling the B<start()> method with a scalar
+argument.
+
+=cut
+
+# The line in the file the node appears
+sub start {
+ return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start};
+}
+
+=item $list-E<gt>indent()
+
+Without argument, retrieves the indent level of the list as specified
+in C<=over n>. This must have been set before by either specifying
+B<-indent> in the B<new()> method or by calling the B<indent()> method
+with a scalar argument.
+
+=cut
+
+# indent level
+sub indent {
+ return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent};
+}
+
+=item $list-E<gt>type()
+
+Without argument, retrieves the list type, which can be an arbitrary value,
+e.g. C<OL>, C<UL>, ... when thinking the HTML way.
+This must have been set before by either specifying
+B<-type> in the B<new()> method or by calling the B<type()> method
+with a scalar argument.
+
+=cut
+
+# The type of the list (UL, OL, ...)
+sub type {
+ return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
+}
+
+=item $list-E<gt>rx()
+
+Without argument, retrieves a regular expression for simplifying the
+individual item strings once the list type has been determined. Usage:
+E.g. when converting to HTML, one might strip the leading number in
+an ordered list as C<E<lt>OLE<gt>> already prints numbers itself.
+This must have been set before by either specifying
+B<-rx> in the B<new()> method or by calling the B<rx()> method
+with a scalar argument.
+
+=cut
+
+# The regular expression to simplify the items
+sub rx {
+ return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx};
+}
+
+=item $list-E<gt>item()
+
+Without argument, retrieves the array of the items in this list.
+The items may be represented by any scalar.
+If an argument has been given, it is pushed on the list of items.
+
+=cut
+
+# The individual =items of this list
+sub item {
+ my ($self,$item) = @_;
+ if(defined $item) {
+ push(@{$self->{_items}}, $item);
+ return $item;
+ }
+ else {
+ return @{$self->{_items}};
+ }
+}
+
+=item $list-E<gt>parent()
+
+Without argument, retrieves information about the parent holding this
+list, which is represented as an arbitrary scalar.
+This must have been set before by either specifying
+B<-parent> in the B<new()> method or by calling the B<parent()> method
+with a scalar argument.
+
+=cut
+
+# possibility for parsers/translators to store information about the
+# lists's parent object
+sub parent {
+ return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent};
+}
+
+=item $list-E<gt>tag()
+
+Without argument, retrieves information about the list tag, which can be
+any scalar.
+This must have been set before by either specifying
+B<-tag> in the B<new()> method or by calling the B<tag()> method
+with a scalar argument.
+
+=back
+
+=cut
+
+# possibility for parsers/translators to store information about the
+# list's object
+sub tag {
+ return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag};
+}
+
+#-----------------------------------------------------------------------------
+# Pod::Hyperlink
+#
+# class to manipulate POD hyperlinks (L<>)
+#-----------------------------------------------------------------------------
+
+package Pod::Hyperlink;
+
+=head2 Pod::Hyperlink
+
+B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage:
+
+ my $link = Pod::Hyperlink->new('alternative text|page/"section in page"');
+
+The B<Pod::Hyperlink> class is mainly designed to parse the contents of the
+C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the
+different parts of a POD hyperlink for further processing. It can also be
+used to construct hyperlinks.
+
+=over 4
+
+=item Pod::Hyperlink-E<gt>new()
+
+The B<new()> method can either be passed a set of key/value pairs or a single
+scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object
+of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a
+failure, the error message is stored in C<$@>.
+
+=cut
+
+use Carp;
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = +{};
+ bless $self, $class;
+ $self->initialize();
+ if(defined $_[0]) {
+ if(ref($_[0])) {
+ # called with a list of parameters
+ %$self = %{$_[0]};
+ $self->_construct_text();
+ }
+ else {
+ # called with L<> contents
+ return unless($self->parse($_[0]));
+ }
+ }
+ return $self;
+}
+
+sub initialize {
+ my $self = shift;
+ $self->{-line} ||= 'undef';
+ $self->{-file} ||= 'undef';
+ $self->{-page} ||= '';
+ $self->{-node} ||= '';
+ $self->{-alttext} ||= '';
+ $self->{-type} ||= 'undef';
+ $self->{_warnings} = [];
+}
+
+=item $link-E<gt>parse($string)
+
+This method can be used to (re)parse a (new) hyperlink, i.e. the contents
+of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object.
+Warnings are stored in the B<warnings> property.
+E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point
+to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage
+section can simply be dropped.
+
+=cut
+
+sub parse {
+ my $self = shift;
+ local($_) = $_[0];
+ # syntax check the link and extract destination
+ my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0);
+
+ $self->{_warnings} = [];
+
+ # collapse newlines with whitespace
+ s/\s*\n+\s*/ /g;
+
+ # strip leading/trailing whitespace
+ if(s/^[\s\n]+//) {
+ $self->warning('ignoring leading whitespace in link');
+ }
+ if(s/[\s\n]+$//) {
+ $self->warning('ignoring trailing whitespace in link');
+ }
+ unless(length($_)) {
+ _invalid_link('empty link');
+ return;
+ }
+
+ ## Check for different possibilities. This is tedious and error-prone
+ # we match all possibilities (alttext, page, section/item)
+ #warn "DEBUG: link=$_\n";
+
+ # only page
+ # problem: a lot of people use (), or (1) or the like to indicate
+ # man page sections. But this collides with L<func()> that is supposed
+ # to point to an internal funtion...
+ my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)';
+ # page name only
+ if(/^($page_rx)$/o) {
+ $page = $1;
+ $type = 'page';
+ }
+ # alttext, page and "section"
+ elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) {
+ ($alttext, $page, $node) = ($1, $2, $3);
+ $type = 'section';
+ $quoted = 1; #... therefore | and / are allowed
+ }
+ # alttext and page
+ elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) {
+ ($alttext, $page) = ($1, $2);
+ $type = 'page';
+ }
+ # alttext and "section"
+ elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) {
+ ($alttext, $node) = ($1,$2);
+ $type = 'section';
+ $quoted = 1;
+ }
+ # page and "section"
+ elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) {
+ ($page, $node) = ($1, $2);
+ $type = 'section';
+ $quoted = 1;
+ }
+ # page and item
+ elsif(m{^($page_rx)\s*/\s*(.+)$}o) {
+ ($page, $node) = ($1, $2);
+ $type = 'item';
+ }
+ # only "section"
+ elsif(m{^/?"(.+)"$}) {
+ $node = $1;
+ $type = 'section';
+ $quoted = 1;
+ }
+ # only item
+ elsif(m{^\s*/(.+)$}) {
+ $node = $1;
+ $type = 'item';
+ }
+
+ # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should?
+ elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) {
+ ($alttext,$node) = ($1,$2);
+ $type = 'hyperlink';
+ }
+
+ # non-standard: Hyperlink
+ elsif(/^(\w+:[^:\s]\S*)$/i) {
+ $node = $1;
+ $type = 'hyperlink';
+ }
+ # alttext, page and item
+ elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) {
+ ($alttext, $page, $node) = ($1, $2, $3);
+ $type = 'item';
+ }
+ # alttext and item
+ elsif(m{^(.*?)\s*[|]\s*/(.+)$}) {
+ ($alttext, $node) = ($1,$2);
+ }
+ # must be an item or a "malformed" section (without "")
+ else {
+ $node = $_;
+ $type = 'item';
+ }
+ # collapse whitespace in nodes
+ $node =~ s/\s+/ /gs;
+
+ # empty alternative text expands to node name
+ if(defined $alttext) {
+ if(!length($alttext)) {
+ $alttext = $node || $page;
+ }
+ }
+ else {
+ $alttext = '';
+ }
+
+ if($page =~ /[(]\w*[)]$/) {
+ $self->warning("(section) in '$page' deprecated");
+ }
+ if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') {
+ $self->warning("node '$node' contains non-escaped | or /");
+ }
+ if($alttext =~ m{[|/]}) {
+ $self->warning("alternative text '$node' contains non-escaped | or /");
+ }
+ $self->{-page} = $page;
+ $self->{-node} = $node;
+ $self->{-alttext} = $alttext;
+ #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n";
+ $self->{-type} = $type;
+ $self->_construct_text();
+ 1;
+}
+
+sub _construct_text {
+ my $self = shift;
+ my $alttext = $self->alttext();
+ my $type = $self->type();
+ my $section = $self->node();
+ my $page = $self->page();
+ my $page_ext = '';
+ $page =~ s/([(]\w*[)])$// && ($page_ext = $1);
+ if($alttext) {
+ $self->{_text} = $alttext;
+ }
+ elsif($type eq 'hyperlink') {
+ $self->{_text} = $section;
+ }
+ else {
+ $self->{_text} = ($section || '') .
+ (($page && $section) ? ' in ' : '') .
+ "$page$page_ext";
+ }
+ # for being marked up later
+ # use the non-standard markers P<> and Q<>, so that the resulting
+ # text can be parsed by the translators. It's their job to put
+ # the correct hypertext around the linktext
+ if($alttext) {
+ $self->{_markup} = "Q<$alttext>";
+ }
+ elsif($type eq 'hyperlink') {
+ $self->{_markup} = "Q<$section>";
+ }
+ else {
+ $self->{_markup} = (!$section ? '' : "Q<$section>") .
+ ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : '');
+ }
+}
+
+=item $link-E<gt>markup($string)
+
+Set/retrieve the textual value of the link. This string contains special
+markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the
+translator's interior sequence expansion engine to the
+formatter-specific code to highlight/activate the hyperlink. The details
+have to be implemented in the translator.
+
+=cut
+
+#' retrieve/set markuped text
+sub markup {
+ return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup};
+}
+
+=item $link-E<gt>text()
+
+This method returns the textual representation of the hyperlink as above,
+but without markers (read only). Depending on the link type this is one of
+the following alternatives (the + and * denote the portions of the text
+that are marked up):
+
+ +perl+ L<perl>
+ *$|* in +perlvar+ L<perlvar/$|>
+ *OPTIONS* in +perldoc+ L<perldoc/"OPTIONS">
+ *DESCRIPTION* L<"DESCRIPTION">
+
+=cut
+
+# The complete link's text
+sub text {
+ return $_[0]->{_text};
+}
+
+=item $link-E<gt>warning()
+
+After parsing, this method returns any warnings encountered during the
+parsing process.
+
+=cut
+
+# Set/retrieve warnings
+sub warning {
+ my $self = shift;
+ if(@_) {
+ push(@{$self->{_warnings}}, @_);
+ return @_;
+ }
+ return @{$self->{_warnings}};
+}
+
+=item $link-E<gt>file()
+
+=item $link-E<gt>line()
+
+Just simple slots for storing information about the line and the file
+the link was encountered in. Has to be filled in manually.
+
+=cut
+
+# The line in the file the link appears
+sub line {
+ return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line};
+}
+
+# The POD file name the link appears in
+sub file {
+ return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
+}
+
+=item $link-E<gt>page()
+
+This method sets or returns the POD page this link points to.
+
+=cut
+
+# The POD page the link appears on
+sub page {
+ if (@_ > 1) {
+ $_[0]->{-page} = $_[1];
+ $_[0]->_construct_text();
+ }
+ return $_[0]->{-page};
+}
+
+=item $link-E<gt>node()
+
+As above, but the destination node text of the link.
+
+=cut
+
+# The link destination
+sub node {
+ if (@_ > 1) {
+ $_[0]->{-node} = $_[1];
+ $_[0]->_construct_text();
+ }
+ return $_[0]->{-node};
+}
+
+=item $link-E<gt>alttext()
+
+Sets or returns an alternative text specified in the link.
+
+=cut
+
+# Potential alternative text
+sub alttext {
+ if (@_ > 1) {
+ $_[0]->{-alttext} = $_[1];
+ $_[0]->_construct_text();
+ }
+ return $_[0]->{-alttext};
+}
+
+=item $link-E<gt>type()
+
+The node type, either C<section> or C<item>. As an unofficial type,
+there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>>
+
+=cut
+
+# The type: item or headn
+sub type {
+ return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
+}
+
+=item $link-E<gt>link()
+
+Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>.
+
+=back
+
+=cut
+
+# The link itself
+sub link {
+ my $self = shift;
+ my $link = $self->page() || '';
+ if($self->node()) {
+ my $node = $self->node();
+ $node =~ s/\|/E<verbar>/g;
+ $node =~ s{/}{E<sol>}g;
+ if($self->type() eq 'section') {
+ $link .= ($link ? '/' : '') . '"' . $node . '"';
+ }
+ elsif($self->type() eq 'hyperlink') {
+ $link = $self->node();
+ }
+ else { # item
+ $link .= '/' . $node;
+ }
+ }
+ if($self->alttext()) {
+ my $text = $self->alttext();
+ $text =~ s/\|/E<verbar>/g;
+ $text =~ s{/}{E<sol>}g;
+ $link = "$text|$link";
+ }
+ return $link;
+}
+
+sub _invalid_link {
+ my ($msg) = @_;
+ # this sets @_
+ #eval { die "$msg\n" };
+ #chomp $@;
+ $@ = $msg; # this seems to work, too!
+ return;
+}
+
+#-----------------------------------------------------------------------------
+# Pod::Cache
+#
+# class to hold POD page details
+#-----------------------------------------------------------------------------
+
+package Pod::Cache;
+
+=head2 Pod::Cache
+
+B<Pod::Cache> holds information about a set of POD documents,
+especially the nodes for hyperlinks.
+The following methods are available:
+
+=over 4
+
+=item Pod::Cache-E<gt>new()
+
+Create a new cache object. This object can hold an arbitrary number of
+POD documents of class Pod::Cache::Item.
+
+=cut
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = [];
+ bless $self, $class;
+ return $self;
+}
+
+=item $cache-E<gt>item()
+
+Add a new item to the cache. Without arguments, this method returns a
+list of all cache elements.
+
+=cut
+
+sub item {
+ my ($self,%param) = @_;
+ if(%param) {
+ my $item = Pod::Cache::Item->new(%param);
+ push(@$self, $item);
+ return $item;
+ }
+ else {
+ return @{$self};
+ }
+}
+
+=item $cache-E<gt>find_page($name)
+
+Look for a POD document named C<$name> in the cache. Returns the
+reference to the corresponding Pod::Cache::Item object or undef if
+not found.
+
+=back
+
+=cut
+
+sub find_page {
+ my ($self,$page) = @_;
+ foreach(@$self) {
+ if($_->page() eq $page) {
+ return $_;
+ }
+ }
+ return;
+}
+
+package Pod::Cache::Item;
+
+=head2 Pod::Cache::Item
+
+B<Pod::Cache::Item> holds information about individual POD documents,
+that can be grouped in a Pod::Cache object.
+It is intended to hold information about the hyperlink nodes of POD
+documents.
+The following methods are available:
+
+=over 4
+
+=item Pod::Cache::Item-E<gt>new()
+
+Create a new object.
+
+=cut
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my %params = @_;
+ my $self = {%params};
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+}
+
+sub initialize {
+ my $self = shift;
+ $self->{-nodes} = [] unless(defined $self->{-nodes});
+}
+
+=item $cacheitem-E<gt>page()
+
+Set/retrieve the POD document name (e.g. "Pod::Parser").
+
+=cut
+
+# The POD page
+sub page {
+ return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page};
+}
+
+=item $cacheitem-E<gt>description()
+
+Set/retrieve the POD short description as found in the C<=head1 NAME>
+section.
+
+=cut
+
+# The POD description, taken out of NAME if present
+sub description {
+ return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description};
+}
+
+=item $cacheitem-E<gt>path()
+
+Set/retrieve the POD file storage path.
+
+=cut
+
+# The file path
+sub path {
+ return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path};
+}
+
+=item $cacheitem-E<gt>file()
+
+Set/retrieve the POD file name.
+
+=cut
+
+# The POD file name
+sub file {
+ return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
+}
+
+=item $cacheitem-E<gt>nodes()
+
+Add a node (or a list of nodes) to the document's node list. Note that
+the order is kept, i.e. start with the first node and end with the last.
+If no argument is given, the current list of nodes is returned in the
+same order the nodes have been added.
+A node can be any scalar, but usually is a pair of node string and
+unique id for the C<find_node> method to work correctly.
+
+=cut
+
+# The POD nodes
+sub nodes {
+ my ($self,@nodes) = @_;
+ if(@nodes) {
+ push(@{$self->{-nodes}}, @nodes);
+ return @nodes;
+ }
+ else {
+ return @{$self->{-nodes}};
+ }
+}
+
+=item $cacheitem-E<gt>find_node($name)
+
+Look for a node or index entry named C<$name> in the object.
+Returns the unique id of the node (i.e. the second element of the array
+stored in the node array) or undef if not found.
+
+=cut
+
+sub find_node {
+ my ($self,$node) = @_;
+ my @search;
+ push(@search, @{$self->{-nodes}}) if($self->{-nodes});
+ push(@search, @{$self->{-idx}}) if($self->{-idx});
+ foreach(@search) {
+ if($_->[0] eq $node) {
+ return $_->[1]; # id
+ }
+ }
+ return;
+}
+
+=item $cacheitem-E<gt>idx()
+
+Add an index entry (or a list of them) to the document's index list. Note that
+the order is kept, i.e. start with the first node and end with the last.
+If no argument is given, the current list of index entries is returned in the
+same order the entries have been added.
+An index entry can be any scalar, but usually is a pair of string and
+unique id.
+
+=back
+
+=cut
+
+# The POD index entries
+sub idx {
+ my ($self,@idx) = @_;
+ if(@idx) {
+ push(@{$self->{-idx}}, @idx);
+ return @idx;
+ }
+ else {
+ return @{$self->{-idx}};
+ }
+}
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>, borrowing
+a lot of things from L<pod2man> and L<pod2roff> as well as other POD
+processing tools by Tom Christiansen, Brad Appleton and Russ Allbery.
+
+=head1 SEE ALSO
+
+L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>,
+L<pod2html>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Parser.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Parser.pm
new file mode 100755
index 00000000000..c807f3fbade
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Parser.pm
@@ -0,0 +1,1829 @@
+#############################################################################
+# Pod/Parser.pm -- package which defines a base class for parsing POD docs.
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Parser;
+use strict;
+
+## These "variables" are used as local "glob aliases" for performance
+use vars qw($VERSION @ISA %myData %myOpts @input_stack);
+$VERSION = '1.37'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+#############################################################################
+
+=head1 NAME
+
+Pod::Parser - base class for creating POD filters and translators
+
+=head1 SYNOPSIS
+
+ use Pod::Parser;
+
+ package MyParser;
+ @ISA = qw(Pod::Parser);
+
+ sub command {
+ my ($parser, $command, $paragraph, $line_num) = @_;
+ ## Interpret the command and its text; sample actions might be:
+ if ($command eq 'head1') { ... }
+ elsif ($command eq 'head2') { ... }
+ ## ... other commands and their actions
+ my $out_fh = $parser->output_handle();
+ my $expansion = $parser->interpolate($paragraph, $line_num);
+ print $out_fh $expansion;
+ }
+
+ sub verbatim {
+ my ($parser, $paragraph, $line_num) = @_;
+ ## Format verbatim paragraph; sample actions might be:
+ my $out_fh = $parser->output_handle();
+ print $out_fh $paragraph;
+ }
+
+ sub textblock {
+ my ($parser, $paragraph, $line_num) = @_;
+ ## Translate/Format this block of text; sample actions might be:
+ my $out_fh = $parser->output_handle();
+ my $expansion = $parser->interpolate($paragraph, $line_num);
+ print $out_fh $expansion;
+ }
+
+ sub interior_sequence {
+ my ($parser, $seq_command, $seq_argument) = @_;
+ ## Expand an interior sequence; sample actions might be:
+ return "*$seq_argument*" if ($seq_command eq 'B');
+ return "`$seq_argument'" if ($seq_command eq 'C');
+ return "_${seq_argument}_'" if ($seq_command eq 'I');
+ ## ... other sequence commands and their resulting text
+ }
+
+ package main;
+
+ ## Create a parser object and have it parse file whose name was
+ ## given on the command-line (use STDIN if no files were given).
+ $parser = new MyParser();
+ $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0);
+ for (@ARGV) { $parser->parse_from_file($_); }
+
+=head1 REQUIRES
+
+perl5.005, Pod::InputObjects, Exporter, Symbol, Carp
+
+=head1 EXPORTS
+
+Nothing.
+
+=head1 DESCRIPTION
+
+B<Pod::Parser> is a base class for creating POD filters and translators.
+It handles most of the effort involved with parsing the POD sections
+from an input stream, leaving subclasses free to be concerned only with
+performing the actual translation of text.
+
+B<Pod::Parser> parses PODs, and makes method calls to handle the various
+components of the POD. Subclasses of B<Pod::Parser> override these methods
+to translate the POD into whatever output format they desire.
+
+=head1 QUICK OVERVIEW
+
+To create a POD filter for translating POD documentation into some other
+format, you create a subclass of B<Pod::Parser> which typically overrides
+just the base class implementation for the following methods:
+
+=over 2
+
+=item *
+
+B<command()>
+
+=item *
+
+B<verbatim()>
+
+=item *
+
+B<textblock()>
+
+=item *
+
+B<interior_sequence()>
+
+=back
+
+You may also want to override the B<begin_input()> and B<end_input()>
+methods for your subclass (to perform any needed per-file and/or
+per-document initialization or cleanup).
+
+If you need to perform any preprocessing of input before it is parsed
+you may want to override one or more of B<preprocess_line()> and/or
+B<preprocess_paragraph()>.
+
+Sometimes it may be necessary to make more than one pass over the input
+files. If this is the case you have several options. You can make the
+first pass using B<Pod::Parser> and override your methods to store the
+intermediate results in memory somewhere for the B<end_pod()> method to
+process. You could use B<Pod::Parser> for several passes with an
+appropriate state variable to control the operation for each pass. If
+your input source can't be reset to start at the beginning, you can
+store it in some other structure as a string or an array and have that
+structure implement a B<getline()> method (which is all that
+B<parse_from_filehandle()> uses to read input).
+
+Feel free to add any member data fields you need to keep track of things
+like current font, indentation, horizontal or vertical position, or
+whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA">
+to avoid name collisions.
+
+For the most part, the B<Pod::Parser> base class should be able to
+do most of the input parsing for you and leave you free to worry about
+how to interpret the commands and translate the result.
+
+Note that all we have described here in this quick overview is the
+simplest most straightforward use of B<Pod::Parser> to do stream-based
+parsing. It is also possible to use the B<Pod::Parser::parse_text> function
+to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">.
+
+=head1 PARSING OPTIONS
+
+A I<parse-option> is simply a named option of B<Pod::Parser> with a
+value that corresponds to a certain specified behavior. These various
+behaviors of B<Pod::Parser> may be enabled/disabled by setting
+or unsetting one or more I<parse-options> using the B<parseopts()> method.
+The set of currently accepted parse-options is as follows:
+
+=over 3
+
+=item B<-want_nonPODs> (default: unset)
+
+Normally (by default) B<Pod::Parser> will only provide access to
+the POD sections of the input. Input paragraphs that are not part
+of the POD-format documentation are not made available to the caller
+(not even using B<preprocess_paragraph()>). Setting this option to a
+non-empty, non-zero value will allow B<preprocess_paragraph()> to see
+non-POD sections of the input as well as POD sections. The B<cutting()>
+method can be used to determine if the corresponding paragraph is a POD
+paragraph, or some other input paragraph.
+
+=item B<-process_cut_cmd> (default: unset)
+
+Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive
+by itself and does not pass it on to the caller for processing. Setting
+this option to a non-empty, non-zero value will cause B<Pod::Parser> to
+pass the C<=cut> directive to the caller just like any other POD command
+(and hence it may be processed by the B<command()> method).
+
+B<Pod::Parser> will still interpret the C<=cut> directive to mean that
+"cutting mode" has been (re)entered, but the caller will get a chance
+to capture the actual C<=cut> paragraph itself for whatever purpose
+it desires.
+
+=item B<-warnings> (default: unset)
+
+Normally (by default) B<Pod::Parser> recognizes a bare minimum of
+pod syntax errors and warnings and issues diagnostic messages
+for errors, but not for warnings. (Use B<Pod::Checker> to do more
+thorough checking of POD syntax.) Setting this option to a non-empty,
+non-zero value will cause B<Pod::Parser> to issue diagnostics for
+the few warnings it recognizes as well as the errors.
+
+=back
+
+Please see L<"parseopts()"> for a complete description of the interface
+for the setting and unsetting of parse-options.
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Pod::InputObjects;
+use Carp;
+use Exporter;
+BEGIN {
+ if ($] < 5.006) {
+ require Symbol;
+ import Symbol;
+ }
+}
+@ISA = qw(Exporter);
+
+#############################################################################
+
+=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES
+
+B<Pod::Parser> provides several methods which most subclasses will probably
+want to override. These methods are as follows:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<command()>
+
+ $parser->command($cmd,$text,$line_num,$pod_para);
+
+This method should be overridden by subclasses to take the appropriate
+action when a POD command paragraph (denoted by a line beginning with
+"=") is encountered. When such a POD directive is seen in the input,
+this method is called and is passed:
+
+=over 3
+
+=item C<$cmd>
+
+the name of the command for this POD paragraph
+
+=item C<$text>
+
+the paragraph text for the given POD paragraph command.
+
+=item C<$line_num>
+
+the line-number of the beginning of the paragraph
+
+=item C<$pod_para>
+
+a reference to a C<Pod::Paragraph> object which contains further
+information about the paragraph command (see L<Pod::InputObjects>
+for details).
+
+=back
+
+B<Note> that this method I<is> called for C<=pod> paragraphs.
+
+The base class implementation of this method simply treats the raw POD
+command as normal block of paragraph text (invoking the B<textblock()>
+method with the command paragraph).
+
+=cut
+
+sub command {
+ my ($self, $cmd, $text, $line_num, $pod_para) = @_;
+ ## Just treat this like a textblock
+ $self->textblock($pod_para->raw_text(), $line_num, $pod_para);
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<verbatim()>
+
+ $parser->verbatim($text,$line_num,$pod_para);
+
+This method may be overridden by subclasses to take the appropriate
+action when a block of verbatim text is encountered. It is passed the
+following parameters:
+
+=over 3
+
+=item C<$text>
+
+the block of text for the verbatim paragraph
+
+=item C<$line_num>
+
+the line-number of the beginning of the paragraph
+
+=item C<$pod_para>
+
+a reference to a C<Pod::Paragraph> object which contains further
+information about the paragraph (see L<Pod::InputObjects>
+for details).
+
+=back
+
+The base class implementation of this method simply prints the textblock
+(unmodified) to the output filehandle.
+
+=cut
+
+sub verbatim {
+ my ($self, $text, $line_num, $pod_para) = @_;
+ my $out_fh = $self->{_OUTPUT};
+ print $out_fh $text;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<textblock()>
+
+ $parser->textblock($text,$line_num,$pod_para);
+
+This method may be overridden by subclasses to take the appropriate
+action when a normal block of POD text is encountered (although the base
+class method will usually do what you want). It is passed the following
+parameters:
+
+=over 3
+
+=item C<$text>
+
+the block of text for the a POD paragraph
+
+=item C<$line_num>
+
+the line-number of the beginning of the paragraph
+
+=item C<$pod_para>
+
+a reference to a C<Pod::Paragraph> object which contains further
+information about the paragraph (see L<Pod::InputObjects>
+for details).
+
+=back
+
+In order to process interior sequences, subclasses implementations of
+this method will probably want to invoke either B<interpolate()> or
+B<parse_text()>, passing it the text block C<$text>, and the corresponding
+line number in C<$line_num>, and then perform any desired processing upon
+the returned result.
+
+The base class implementation of this method simply prints the text block
+as it occurred in the input stream).
+
+=cut
+
+sub textblock {
+ my ($self, $text, $line_num, $pod_para) = @_;
+ my $out_fh = $self->{_OUTPUT};
+ print $out_fh $self->interpolate($text, $line_num);
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<interior_sequence()>
+
+ $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq);
+
+This method should be overridden by subclasses to take the appropriate
+action when an interior sequence is encountered. An interior sequence is
+an embedded command within a block of text which appears as a command
+name (usually a single uppercase character) followed immediately by a
+string of text which is enclosed in angle brackets. This method is
+passed the sequence command C<$seq_cmd> and the corresponding text
+C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior
+sequence that occurs in the string that it is passed. It should return
+the desired text string to be used in place of the interior sequence.
+The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence>
+object which contains further information about the interior sequence.
+Please see L<Pod::InputObjects> for details if you need to access this
+additional information.
+
+Subclass implementations of this method may wish to invoke the
+B<nested()> method of C<$pod_seq> to see if it is nested inside
+some other interior-sequence (and if so, which kind).
+
+The base class implementation of the B<interior_sequence()> method
+simply returns the raw text of the interior sequence (as it occurred
+in the input) to the caller.
+
+=cut
+
+sub interior_sequence {
+ my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_;
+ ## Just return the raw text of the interior sequence
+ return $pod_seq->raw_text();
+}
+
+#############################################################################
+
+=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES
+
+B<Pod::Parser> provides several methods which subclasses may want to override
+to perform any special pre/post-processing. These methods do I<not> have to
+be overridden, but it may be useful for subclasses to take advantage of them.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<new()>
+
+ my $parser = Pod::Parser->new();
+
+This is the constructor for B<Pod::Parser> and its subclasses. You
+I<do not> need to override this method! It is capable of constructing
+subclass objects as well as base class objects, provided you use
+any of the following constructor invocation styles:
+
+ my $parser1 = MyParser->new();
+ my $parser2 = new MyParser();
+ my $parser3 = $parser2->new();
+
+where C<MyParser> is some subclass of B<Pod::Parser>.
+
+Using the syntax C<MyParser::new()> to invoke the constructor is I<not>
+recommended, but if you insist on being able to do this, then the
+subclass I<will> need to override the B<new()> constructor method. If
+you do override the constructor, you I<must> be sure to invoke the
+B<initialize()> method of the newly blessed object.
+
+Using any of the above invocations, the first argument to the
+constructor is always the corresponding package name (or object
+reference). No other arguments are required, but if desired, an
+associative array (or hash-table) my be passed to the B<new()>
+constructor, as in:
+
+ my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 );
+ my $parser2 = new MyParser( -myflag => 1 );
+
+All arguments passed to the B<new()> constructor will be treated as
+key/value pairs in a hash-table. The newly constructed object will be
+initialized by copying the contents of the given hash-table (which may
+have been empty). The B<new()> constructor for this class and all of its
+subclasses returns a blessed reference to the initialized object (hash-table).
+
+=cut
+
+sub new {
+ ## Determine if we were called via an object-ref or a classname
+ my ($this,%params) = @_;
+ my $class = ref($this) || $this;
+ ## Any remaining arguments are treated as initial values for the
+ ## hash that is used to represent this object.
+ my $self = { %params };
+ ## Bless ourselves into the desired class and perform any initialization
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<initialize()>
+
+ $parser->initialize();
+
+This method performs any necessary object initialization. It takes no
+arguments (other than the object instance of course, which is typically
+copied to a local variable named C<$self>). If subclasses override this
+method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>.
+
+=cut
+
+sub initialize {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<begin_pod()>
+
+ $parser->begin_pod();
+
+This method is invoked at the beginning of processing for each POD
+document that is encountered in the input. Subclasses should override
+this method to perform any per-document initialization.
+
+=cut
+
+sub begin_pod {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<begin_input()>
+
+ $parser->begin_input();
+
+This method is invoked by B<parse_from_filehandle()> immediately I<before>
+processing input from a filehandle. The base class implementation does
+nothing, however, subclasses may override it to perform any per-file
+initializations.
+
+Note that if multiple files are parsed for a single POD document
+(perhaps the result of some future C<=include> directive) this method
+is invoked for every file that is parsed. If you wish to perform certain
+initializations once per document, then you should use B<begin_pod()>.
+
+=cut
+
+sub begin_input {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<end_input()>
+
+ $parser->end_input();
+
+This method is invoked by B<parse_from_filehandle()> immediately I<after>
+processing input from a filehandle. The base class implementation does
+nothing, however, subclasses may override it to perform any per-file
+cleanup actions.
+
+Please note that if multiple files are parsed for a single POD document
+(perhaps the result of some kind of C<=include> directive) this method
+is invoked for every file that is parsed. If you wish to perform certain
+cleanup actions once per document, then you should use B<end_pod()>.
+
+=cut
+
+sub end_input {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<end_pod()>
+
+ $parser->end_pod();
+
+This method is invoked at the end of processing for each POD document
+that is encountered in the input. Subclasses should override this method
+to perform any per-document finalization.
+
+=cut
+
+sub end_pod {
+ #my $self = shift;
+ #return;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<preprocess_line()>
+
+ $textline = $parser->preprocess_line($text, $line_num);
+
+This method should be overridden by subclasses that wish to perform
+any kind of preprocessing for each I<line> of input (I<before> it has
+been determined whether or not it is part of a POD paragraph). The
+parameter C<$text> is the input line; and the parameter C<$line_num> is
+the line number of the corresponding text line.
+
+The value returned should correspond to the new text to use in its
+place. If the empty string or an undefined value is returned then no
+further processing will be performed for this line.
+
+Please note that the B<preprocess_line()> method is invoked I<before>
+the B<preprocess_paragraph()> method. After all (possibly preprocessed)
+lines in a paragraph have been assembled together and it has been
+determined that the paragraph is part of the POD documentation from one
+of the selected sections, then B<preprocess_paragraph()> is invoked.
+
+The base class implementation of this method returns the given text.
+
+=cut
+
+sub preprocess_line {
+ my ($self, $text, $line_num) = @_;
+ return $text;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<preprocess_paragraph()>
+
+ $textblock = $parser->preprocess_paragraph($text, $line_num);
+
+This method should be overridden by subclasses that wish to perform any
+kind of preprocessing for each block (paragraph) of POD documentation
+that appears in the input stream. The parameter C<$text> is the POD
+paragraph from the input file; and the parameter C<$line_num> is the
+line number for the beginning of the corresponding paragraph.
+
+The value returned should correspond to the new text to use in its
+place If the empty string is returned or an undefined value is
+returned, then the given C<$text> is ignored (not processed).
+
+This method is invoked after gathering up all the lines in a paragraph
+and after determining the cutting state of the paragraph,
+but before trying to further parse or interpret them. After
+B<preprocess_paragraph()> returns, the current cutting state (which
+is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates
+to true then input text (including the given C<$text>) is cut (not
+processed) until the next POD directive is encountered.
+
+Please note that the B<preprocess_line()> method is invoked I<before>
+the B<preprocess_paragraph()> method. After all (possibly preprocessed)
+lines in a paragraph have been assembled together and either it has been
+determined that the paragraph is part of the POD documentation from one
+of the selected sections or the C<-want_nonPODs> option is true,
+then B<preprocess_paragraph()> is invoked.
+
+The base class implementation of this method returns the given text.
+
+=cut
+
+sub preprocess_paragraph {
+ my ($self, $text, $line_num) = @_;
+ return $text;
+}
+
+#############################################################################
+
+=head1 METHODS FOR PARSING AND PROCESSING
+
+B<Pod::Parser> provides several methods to process input text. These
+methods typically won't need to be overridden (and in some cases they
+can't be overridden), but subclasses may want to invoke them to exploit
+their functionality.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<parse_text()>
+
+ $ptree1 = $parser->parse_text($text, $line_num);
+ $ptree2 = $parser->parse_text({%opts}, $text, $line_num);
+ $ptree3 = $parser->parse_text(\%opts, $text, $line_num);
+
+This method is useful if you need to perform your own interpolation
+of interior sequences and can't rely upon B<interpolate> to expand
+them in simple bottom-up order.
+
+The parameter C<$text> is a string or block of text to be parsed
+for interior sequences; and the parameter C<$line_num> is the
+line number corresponding to the beginning of C<$text>.
+
+B<parse_text()> will parse the given text into a parse-tree of "nodes."
+and interior-sequences. Each "node" in the parse tree is either a
+text-string, or a B<Pod::InteriorSequence>. The result returned is a
+parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects>
+for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>.
+
+If desired, an optional hash-ref may be specified as the first argument
+to customize certain aspects of the parse-tree that is created and
+returned. The set of recognized option keywords are:
+
+=over 3
+
+=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name>
+
+Normally, the parse-tree returned by B<parse_text()> will contain an
+unexpanded C<Pod::InteriorSequence> object for each interior-sequence
+encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand"
+every interior-sequence it sees by invoking the referenced function
+(or named method of the parser object) and using the return value as the
+expanded result.
+
+If a subroutine reference was given, it is invoked as:
+
+ &$code_ref( $parser, $sequence )
+
+and if a method-name was given, it is invoked as:
+
+ $parser->method_name( $sequence )
+
+where C<$parser> is a reference to the parser object, and C<$sequence>
+is a reference to the interior-sequence object.
+[I<NOTE>: If the B<interior_sequence()> method is specified, then it is
+invoked according to the interface specified in L<"interior_sequence()">].
+
+=item B<-expand_text> =E<gt> I<code-ref>|I<method-name>
+
+Normally, the parse-tree returned by B<parse_text()> will contain a
+text-string for each contiguous sequence of characters outside of an
+interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to
+"preprocess" every such text-string it sees by invoking the referenced
+function (or named method of the parser object) and using the return value
+as the preprocessed (or "expanded") result. [Note that if the result is
+an interior-sequence, then it will I<not> be expanded as specified by the
+B<-expand_seq> option; Any such recursive expansion needs to be handled by
+the specified callback routine.]
+
+If a subroutine reference was given, it is invoked as:
+
+ &$code_ref( $parser, $text, $ptree_node )
+
+and if a method-name was given, it is invoked as:
+
+ $parser->method_name( $text, $ptree_node )
+
+where C<$parser> is a reference to the parser object, C<$text> is the
+text-string encountered, and C<$ptree_node> is a reference to the current
+node in the parse-tree (usually an interior-sequence object or else the
+top-level node of the parse-tree).
+
+=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name>
+
+Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an
+argument to the referenced subroutine (or named method of the parser
+object) and return the result instead of the parse-tree object.
+
+If a subroutine reference was given, it is invoked as:
+
+ &$code_ref( $parser, $ptree )
+
+and if a method-name was given, it is invoked as:
+
+ $parser->method_name( $ptree )
+
+where C<$parser> is a reference to the parser object, and C<$ptree>
+is a reference to the parse-tree object.
+
+=back
+
+=cut
+
+sub parse_text {
+ my $self = shift;
+ local $_ = '';
+
+ ## Get options and set any defaults
+ my %opts = (ref $_[0]) ? %{ shift() } : ();
+ my $expand_seq = $opts{'-expand_seq'} || undef;
+ my $expand_text = $opts{'-expand_text'} || undef;
+ my $expand_ptree = $opts{'-expand_ptree'} || undef;
+
+ my $text = shift;
+ my $line = shift;
+ my $file = $self->input_file();
+ my $cmd = "";
+
+ ## Convert method calls into closures, for our convenience
+ my $xseq_sub = $expand_seq;
+ my $xtext_sub = $expand_text;
+ my $xptree_sub = $expand_ptree;
+ if (defined $expand_seq and $expand_seq eq 'interior_sequence') {
+ ## If 'interior_sequence' is the method to use, we have to pass
+ ## more than just the sequence object, we also need to pass the
+ ## sequence name and text.
+ $xseq_sub = sub {
+ my ($sself, $iseq) = @_;
+ my $args = join('', $iseq->parse_tree->children);
+ return $sself->interior_sequence($iseq->name, $args, $iseq);
+ };
+ }
+ ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) };
+ ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) };
+ ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) };
+
+ ## Keep track of the "current" interior sequence, and maintain a stack
+ ## of "in progress" sequences.
+ ##
+ ## NOTE that we push our own "accumulator" at the very beginning of the
+ ## stack. It's really a parse-tree, not a sequence; but it implements
+ ## the methods we need so we can use it to gather-up all the sequences
+ ## and strings we parse. Thus, by the end of our parsing, it should be
+ ## the only thing left on our stack and all we have to do is return it!
+ ##
+ my $seq = Pod::ParseTree->new();
+ my @seq_stack = ($seq);
+ my ($ldelim, $rdelim) = ('', '');
+
+ ## Iterate over all sequence starts text (NOTE: split with
+ ## capturing parens keeps the delimiters)
+ $_ = $text;
+ my @tokens = split /([A-Z]<(?:<+\s)?)/;
+ while ( @tokens ) {
+ $_ = shift @tokens;
+ ## Look for the beginning of a sequence
+ if ( /^([A-Z])(<(?:<+\s)?)$/ ) {
+ ## Push a new sequence onto the stack of those "in-progress"
+ my $ldelim_orig;
+ ($cmd, $ldelim_orig) = ($1, $2);
+ ($ldelim = $ldelim_orig) =~ s/\s+$//;
+ ($rdelim = $ldelim) =~ tr/</>/;
+ $seq = Pod::InteriorSequence->new(
+ -name => $cmd,
+ -ldelim => $ldelim_orig, -rdelim => $rdelim,
+ -file => $file, -line => $line
+ );
+ (@seq_stack > 1) and $seq->nested($seq_stack[-1]);
+ push @seq_stack, $seq;
+ }
+ ## Look for sequence ending
+ elsif ( @seq_stack > 1 ) {
+ ## Make sure we match the right kind of closing delimiter
+ my ($seq_end, $post_seq) = ('', '');
+ if ( ($ldelim eq '<' and /\A(.*?)(>)/s)
+ or /\A(.*?)(\s+$rdelim)/s )
+ {
+ ## Found end-of-sequence, capture the interior and the
+ ## closing the delimiter, and put the rest back on the
+ ## token-list
+ $post_seq = substr($_, length($1) + length($2));
+ ($_, $seq_end) = ($1, $2);
+ (length $post_seq) and unshift @tokens, $post_seq;
+ }
+ if (length) {
+ ## In the middle of a sequence, append this text to it, and
+ ## dont forget to "expand" it if that's what the caller wanted
+ $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
+ $_ .= $seq_end;
+ }
+ if (length $seq_end) {
+ ## End of current sequence, record terminating delimiter
+ $seq->rdelim($seq_end);
+ ## Pop it off the stack of "in progress" sequences
+ pop @seq_stack;
+ ## Append result to its parent in current parse tree
+ $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq)
+ : $seq);
+ ## Remember the current cmd-name and left-delimiter
+ if(@seq_stack > 1) {
+ $cmd = $seq_stack[-1]->name;
+ $ldelim = $seq_stack[-1]->ldelim;
+ $rdelim = $seq_stack[-1]->rdelim;
+ } else {
+ $cmd = $ldelim = $rdelim = '';
+ }
+ }
+ }
+ elsif (length) {
+ ## In the middle of a sequence, append this text to it, and
+ ## dont forget to "expand" it if that's what the caller wanted
+ $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
+ }
+ ## Keep track of line count
+ $line += s/\r*\n//;
+ ## Remember the "current" sequence
+ $seq = $seq_stack[-1];
+ }
+
+ ## Handle unterminated sequences
+ my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef;
+ while (@seq_stack > 1) {
+ ($cmd, $file, $line) = ($seq->name, $seq->file_line);
+ $ldelim = $seq->ldelim;
+ ($rdelim = $ldelim) =~ tr/</>/;
+ $rdelim =~ s/^(\S+)(\s*)$/$2$1/;
+ pop @seq_stack;
+ my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}".
+ " at line $line in file $file\n";
+ (ref $errorsub) and &{$errorsub}($errmsg)
+ or (defined $errorsub) and $self->$errorsub($errmsg)
+ or carp($errmsg);
+ $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq);
+ $seq = $seq_stack[-1];
+ }
+
+ ## Return the resulting parse-tree
+ my $ptree = (pop @seq_stack)->parse_tree;
+ return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<interpolate()>
+
+ $textblock = $parser->interpolate($text, $line_num);
+
+This method translates all text (including any embedded interior sequences)
+in the given text string C<$text> and returns the interpolated result. The
+parameter C<$line_num> is the line number corresponding to the beginning
+of C<$text>.
+
+B<interpolate()> merely invokes a private method to recursively expand
+nested interior sequences in bottom-up order (innermost sequences are
+expanded first). If there is a need to expand nested sequences in
+some alternate order, use B<parse_text> instead.
+
+=cut
+
+sub interpolate {
+ my($self, $text, $line_num) = @_;
+ my %parse_opts = ( -expand_seq => 'interior_sequence' );
+ my $ptree = $self->parse_text( \%parse_opts, $text, $line_num );
+ return join '', $ptree->children();
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<parse_paragraph()>
+
+ $parser->parse_paragraph($text, $line_num);
+
+This method takes the text of a POD paragraph to be processed, along
+with its corresponding line number, and invokes the appropriate method
+(one of B<command()>, B<verbatim()>, or B<textblock()>).
+
+For performance reasons, this method is invoked directly without any
+dynamic lookup; Hence subclasses may I<not> override it!
+
+=end __PRIVATE__
+
+=cut
+
+sub parse_paragraph {
+ my ($self, $text, $line_num) = @_;
+ local *myData = $self; ## alias to avoid deref-ing overhead
+ local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
+ local $_;
+
+ ## See if we want to preprocess nonPOD paragraphs as well as POD ones.
+ my $wantNonPods = $myOpts{'-want_nonPODs'};
+
+ ## Update cutting status
+ $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/;
+
+ ## Perform any desired preprocessing if we wanted it this early
+ $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num);
+
+ ## Ignore up until next POD directive if we are cutting
+ return if $myData{_CUTTING};
+
+ ## Now we know this is block of text in a POD section!
+
+ ##-----------------------------------------------------------------
+ ## This is a hook (hack ;-) for Pod::Select to do its thing without
+ ## having to override methods, but also without Pod::Parser assuming
+ ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS
+ ## field exists then we assume there is an is_selected() method for
+ ## us to invoke (calling $self->can('is_selected') could verify this
+ ## but that is more overhead than I want to incur)
+ ##-----------------------------------------------------------------
+
+ ## Ignore this block if it isnt in one of the selected sections
+ if (exists $myData{_SELECTED_SECTIONS}) {
+ $self->is_selected($text) or return ($myData{_CUTTING} = 1);
+ }
+
+ ## If we havent already, perform any desired preprocessing and
+ ## then re-check the "cutting" state
+ unless ($wantNonPods) {
+ $text = $self->preprocess_paragraph($text, $line_num);
+ return 1 unless ((defined $text) and (length $text));
+ return 1 if ($myData{_CUTTING});
+ }
+
+ ## Look for one of the three types of paragraphs
+ my ($pfx, $cmd, $arg, $sep) = ('', '', '', '');
+ my $pod_para = undef;
+ if ($text =~ /^(={1,2})(?=\S)/) {
+ ## Looks like a command paragraph. Capture the command prefix used
+ ## ("=" or "=="), as well as the command-name, its paragraph text,
+ ## and whatever sequence of characters was used to separate them
+ $pfx = $1;
+ $_ = substr($text, length $pfx);
+ ($cmd, $sep, $text) = split /(\s+)/, $_, 2;
+ ## If this is a "cut" directive then we dont need to do anything
+ ## except return to "cutting" mode.
+ if ($cmd eq 'cut') {
+ $myData{_CUTTING} = 1;
+ return unless $myOpts{'-process_cut_cmd'};
+ }
+ }
+ ## Save the attributes indicating how the command was specified.
+ $pod_para = new Pod::Paragraph(
+ -name => $cmd,
+ -text => $text,
+ -prefix => $pfx,
+ -separator => $sep,
+ -file => $myData{_INFILE},
+ -line => $line_num
+ );
+ # ## Invoke appropriate callbacks
+ # if (exists $myData{_CALLBACKS}) {
+ # ## Look through the callback list, invoke callbacks,
+ # ## then see if we need to do the default actions
+ # ## (invoke_callbacks will return true if we do).
+ # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para);
+ # }
+
+ # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp
+ if ($myData{_WHITESPACE} and $myOpts{'-warnings'}
+ and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) {
+ my $errorsub = $self->errorsub();
+ my $line = $line_num - 1;
+ my $errmsg = "*** WARNING: line containing nothing but whitespace".
+ " in paragraph at line $line in file $myData{_INFILE}\n";
+ (ref $errorsub) and &{$errorsub}($errmsg)
+ or (defined $errorsub) and $self->$errorsub($errmsg)
+ or carp($errmsg);
+ }
+
+ if (length $cmd) {
+ ## A command paragraph
+ $self->command($cmd, $text, $line_num, $pod_para);
+ $myData{_PREVIOUS} = $cmd;
+ }
+ elsif ($text =~ /^\s+/) {
+ ## Indented text - must be a verbatim paragraph
+ $self->verbatim($text, $line_num, $pod_para);
+ $myData{_PREVIOUS} = "verbatim";
+ }
+ else {
+ ## Looks like an ordinary block of text
+ $self->textblock($text, $line_num, $pod_para);
+ $myData{_PREVIOUS} = "textblock";
+ }
+
+ # Update the whitespace for the next time around
+ $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;
+
+ return 1;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<parse_from_filehandle()>
+
+ $parser->parse_from_filehandle($in_fh,$out_fh);
+
+This method takes an input filehandle (which is assumed to already be
+opened for reading) and reads the entire input stream looking for blocks
+(paragraphs) of POD documentation to be processed. If no first argument
+is given the default input filehandle C<STDIN> is used.
+
+The C<$in_fh> parameter may be any object that provides a B<getline()>
+method to retrieve a single line of input text (hence, an appropriate
+wrapper object could be used to parse PODs from a single string or an
+array of strings).
+
+Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled
+into paragraphs or "blocks" (which are separated by lines containing
+nothing but whitespace). For each block of POD documentation
+encountered it will invoke a method to parse the given paragraph.
+
+If a second argument is given then it should correspond to a filehandle where
+output should be sent (otherwise the default output filehandle is
+C<STDOUT> if no output filehandle is currently in use).
+
+B<NOTE:> For performance reasons, this method caches the input stream at
+the top of the stack in a local variable. Any attempts by clients to
+change the stack contents during processing when in the midst executing
+of this method I<will not affect> the input stream used by the current
+invocation of this method.
+
+This method does I<not> usually need to be overridden by subclasses.
+
+=cut
+
+sub parse_from_filehandle {
+ my $self = shift;
+ my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
+ my ($in_fh, $out_fh) = @_;
+ $in_fh = \*STDIN unless ($in_fh);
+ local *myData = $self; ## alias to avoid deref-ing overhead
+ local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
+ local $_;
+
+ ## Put this stream at the top of the stack and do beginning-of-input
+ ## processing. NOTE that $in_fh might be reset during this process.
+ my $topstream = $self->_push_input_stream($in_fh, $out_fh);
+ (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} );
+
+ ## Initialize line/paragraph
+ my ($textline, $paragraph) = ('', '');
+ my ($nlines, $plines) = (0, 0);
+
+ ## Use <$fh> instead of $fh->getline where possible (for speed)
+ $_ = ref $in_fh;
+ my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh);
+
+ ## Read paragraphs line-by-line
+ while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) {
+ $textline = $self->preprocess_line($textline, ++$nlines);
+ next unless ((defined $textline) && (length $textline));
+
+ if ((! length $paragraph) && ($textline =~ /^==/)) {
+ ## '==' denotes a one-line command paragraph
+ $paragraph = $textline;
+ $plines = 1;
+ $textline = '';
+ } else {
+ ## Append this line to the current paragraph
+ $paragraph .= $textline;
+ ++$plines;
+ }
+
+ ## See if this line is blank and ends the current paragraph.
+ ## If it isnt, then keep iterating until it is.
+ next unless (($textline =~ /^([^\S\r\n]*)[\r\n]*$/)
+ && (length $paragraph));
+
+ ## Now process the paragraph
+ parse_paragraph($self, $paragraph, ($nlines - $plines) + 1);
+ $paragraph = '';
+ $plines = 0;
+ }
+ ## Dont forget about the last paragraph in the file
+ if (length $paragraph) {
+ parse_paragraph($self, $paragraph, ($nlines - $plines) + 1)
+ }
+
+ ## Now pop the input stream off the top of the input stack.
+ $self->_pop_input_stream();
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<parse_from_file()>
+
+ $parser->parse_from_file($filename,$outfile);
+
+This method takes a filename and does the following:
+
+=over 2
+
+=item *
+
+opens the input and output files for reading
+(creating the appropriate filehandles)
+
+=item *
+
+invokes the B<parse_from_filehandle()> method passing it the
+corresponding input and output filehandles.
+
+=item *
+
+closes the input and output files.
+
+=back
+
+If the special input filename "-" or "<&STDIN" is given then the STDIN
+filehandle is used for input (and no open or close is performed). If no
+input filename is specified then "-" is implied. Filehandle references,
+or objects that support the regular IO operations (like C<E<lt>$fhE<gt>>
+or C<$fh-<Egt>getline>) are also accepted; the handles must already be
+opened.
+
+If a second argument is given then it should be the name of the desired
+output file. If the special output filename "-" or ">&STDOUT" is given
+then the STDOUT filehandle is used for output (and no open or close is
+performed). If the special output filename ">&STDERR" is given then the
+STDERR filehandle is used for output (and no open or close is
+performed). If no output filehandle is currently in use and no output
+filename is specified, then "-" is implied.
+Alternatively, filehandle references or objects that support the regular
+IO operations (like C<print>, e.g. L<IO::String>) are also accepted;
+the object must already be opened.
+
+This method does I<not> usually need to be overridden by subclasses.
+
+=cut
+
+sub parse_from_file {
+ my $self = shift;
+ my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
+ my ($infile, $outfile) = @_;
+ my ($in_fh, $out_fh);
+ if ($] < 5.006) {
+ ($in_fh, $out_fh) = (gensym(), gensym());
+ }
+ my ($close_input, $close_output) = (0, 0);
+ local *myData = $self;
+ local *_;
+
+ ## Is $infile a filename or a (possibly implied) filehandle
+ if (defined $infile && ref $infile) {
+ if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {
+ croak "Input from $1 reference not supported!\n";
+ }
+ ## Must be a filehandle-ref (or else assume its a ref to an object
+ ## that supports the common IO read operations).
+ $myData{_INFILE} = ${$infile};
+ $in_fh = $infile;
+ }
+ elsif (!defined($infile) || !length($infile) || ($infile eq '-')
+ || ($infile =~ /^<&(?:STDIN|0)$/i))
+ {
+ ## Not a filename, just a string implying STDIN
+ $infile ||= '-';
+ $myData{_INFILE} = '<standard input>';
+ $in_fh = \*STDIN;
+ }
+ else {
+ ## We have a filename, open it for reading
+ $myData{_INFILE} = $infile;
+ open($in_fh, "< $infile") or
+ croak "Can't open $infile for reading: $!\n";
+ $close_input = 1;
+ }
+
+ ## NOTE: we need to be *very* careful when "defaulting" the output
+ ## file. We only want to use a default if this is the beginning of
+ ## the entire document (but *not* if this is an included file). We
+ ## determine this by seeing if the input stream stack has been set-up
+ ## already
+
+ ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref?
+ if (ref $outfile) {
+ ## we need to check for ref() first, as other checks involve reading
+ if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) {
+ croak "Output to $1 reference not supported!\n";
+ }
+ elsif (ref($outfile) eq 'SCALAR') {
+# # NOTE: IO::String isn't a part of the perl distribution,
+# # so probably we shouldn't support this case...
+# require IO::String;
+# $myData{_OUTFILE} = "$outfile";
+# $out_fh = IO::String->new($outfile);
+ croak "Output to SCALAR reference not supported!\n";
+ }
+ else {
+ ## Must be a filehandle-ref (or else assume its a ref to an
+ ## object that supports the common IO write operations).
+ $myData{_OUTFILE} = ${$outfile};
+ $out_fh = $outfile;
+ }
+ }
+ elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-')
+ || ($outfile =~ /^>&?(?:STDOUT|1)$/i))
+ {
+ if (defined $myData{_TOP_STREAM}) {
+ $out_fh = $myData{_OUTPUT};
+ }
+ else {
+ ## Not a filename, just a string implying STDOUT
+ $outfile ||= '-';
+ $myData{_OUTFILE} = '<standard output>';
+ $out_fh = \*STDOUT;
+ }
+ }
+ elsif ($outfile =~ /^>&(STDERR|2)$/i) {
+ ## Not a filename, just a string implying STDERR
+ $myData{_OUTFILE} = '<standard error>';
+ $out_fh = \*STDERR;
+ }
+ else {
+ ## We have a filename, open it for writing
+ $myData{_OUTFILE} = $outfile;
+ (-d $outfile) and croak "$outfile is a directory, not POD input!\n";
+ open($out_fh, "> $outfile") or
+ croak "Can't open $outfile for writing: $!\n";
+ $close_output = 1;
+ }
+
+ ## Whew! That was a lot of work to set up reasonably/robust behavior
+ ## in the case of a non-filename for reading and writing. Now we just
+ ## have to parse the input and close the handles when we're finished.
+ $self->parse_from_filehandle(\%opts, $in_fh, $out_fh);
+
+ $close_input and
+ close($in_fh) || croak "Can't close $infile after reading: $!\n";
+ $close_output and
+ close($out_fh) || croak "Can't close $outfile after writing: $!\n";
+}
+
+#############################################################################
+
+=head1 ACCESSOR METHODS
+
+Clients of B<Pod::Parser> should use the following methods to access
+instance data fields:
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<errorsub()>
+
+ $parser->errorsub("method_name");
+ $parser->errorsub(\&warn_user);
+ $parser->errorsub(sub { print STDERR, @_ });
+
+Specifies the method or subroutine to use when printing error messages
+about POD syntax. The supplied method/subroutine I<must> return TRUE upon
+successful printing of the message. If C<undef> is given, then the B<carp>
+builtin is used to issue error messages (this is the default behavior).
+
+ my $errorsub = $parser->errorsub()
+ my $errmsg = "This is an error message!\n"
+ (ref $errorsub) and &{$errorsub}($errmsg)
+ or (defined $errorsub) and $parser->$errorsub($errmsg)
+ or carp($errmsg);
+
+Returns a method name, or else a reference to the user-supplied subroutine
+used to print error messages. Returns C<undef> if the B<carp> builtin
+is used to issue error messages (this is the default behavior).
+
+=cut
+
+sub errorsub {
+ return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<cutting()>
+
+ $boolean = $parser->cutting();
+
+Returns the current C<cutting> state: a boolean-valued scalar which
+evaluates to true if text from the input file is currently being "cut"
+(meaning it is I<not> considered part of the POD document).
+
+ $parser->cutting($boolean);
+
+Sets the current C<cutting> state to the given value and returns the
+result.
+
+=cut
+
+sub cutting {
+ return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING};
+}
+
+##---------------------------------------------------------------------------
+
+##---------------------------------------------------------------------------
+
+=head1 B<parseopts()>
+
+When invoked with no additional arguments, B<parseopts> returns a hashtable
+of all the current parsing options.
+
+ ## See if we are parsing non-POD sections as well as POD ones
+ my %opts = $parser->parseopts();
+ $opts{'-want_nonPODs}' and print "-want_nonPODs\n";
+
+When invoked using a single string, B<parseopts> treats the string as the
+name of a parse-option and returns its corresponding value if it exists
+(returns C<undef> if it doesn't).
+
+ ## Did we ask to see '=cut' paragraphs?
+ my $want_cut = $parser->parseopts('-process_cut_cmd');
+ $want_cut and print "-process_cut_cmd\n";
+
+When invoked with multiple arguments, B<parseopts> treats them as
+key/value pairs and the specified parse-option names are set to the
+given values. Any unspecified parse-options are unaffected.
+
+ ## Set them back to the default
+ $parser->parseopts(-warnings => 0);
+
+When passed a single hash-ref, B<parseopts> uses that hash to completely
+reset the existing parse-options, all previous parse-option values
+are lost.
+
+ ## Reset all options to default
+ $parser->parseopts( { } );
+
+See L<"PARSING OPTIONS"> for more information on the name and meaning of each
+parse-option currently recognized.
+
+=cut
+
+sub parseopts {
+ local *myData = shift;
+ local *myOpts = ($myData{_PARSEOPTS} ||= {});
+ return %myOpts if (@_ == 0);
+ if (@_ == 1) {
+ local $_ = shift;
+ return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_};
+ }
+ my @newOpts = (%myOpts, @_);
+ $myData{_PARSEOPTS} = { @newOpts };
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<output_file()>
+
+ $fname = $parser->output_file();
+
+Returns the name of the output file being written.
+
+=cut
+
+sub output_file {
+ return $_[0]->{_OUTFILE};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<output_handle()>
+
+ $fhandle = $parser->output_handle();
+
+Returns the output filehandle object.
+
+=cut
+
+sub output_handle {
+ return $_[0]->{_OUTPUT};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<input_file()>
+
+ $fname = $parser->input_file();
+
+Returns the name of the input file being read.
+
+=cut
+
+sub input_file {
+ return $_[0]->{_INFILE};
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<input_handle()>
+
+ $fhandle = $parser->input_handle();
+
+Returns the current input filehandle object.
+
+=cut
+
+sub input_handle {
+ return $_[0]->{_INPUT};
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<input_streams()>
+
+ $listref = $parser->input_streams();
+
+Returns a reference to an array which corresponds to the stack of all
+the input streams that are currently in the middle of being parsed.
+
+While parsing an input stream, it is possible to invoke
+B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input
+stream and then return to parsing the previous input stream. Each input
+stream to be parsed is pushed onto the end of this input stack
+before any of its input is read. The input stream that is currently
+being parsed is always at the end (or top) of the input stack. When an
+input stream has been exhausted, it is popped off the end of the
+input stack.
+
+Each element on this input stack is a reference to C<Pod::InputSource>
+object. Please see L<Pod::InputObjects> for more details.
+
+This method might be invoked when printing diagnostic messages, for example,
+to obtain the name and line number of the all input files that are currently
+being processed.
+
+=end __PRIVATE__
+
+=cut
+
+sub input_streams {
+ return $_[0]->{_INPUT_STREAMS};
+}
+
+##---------------------------------------------------------------------------
+
+=begin __PRIVATE__
+
+=head1 B<top_stream()>
+
+ $hashref = $parser->top_stream();
+
+Returns a reference to the hash-table that represents the element
+that is currently at the top (end) of the input stream stack
+(see L<"input_streams()">). The return value will be the C<undef>
+if the input stack is empty.
+
+This method might be used when printing diagnostic messages, for example,
+to obtain the name and line number of the current input file.
+
+=end __PRIVATE__
+
+=cut
+
+sub top_stream {
+ return $_[0]->{_TOP_STREAM} || undef;
+}
+
+#############################################################################
+
+=head1 PRIVATE METHODS AND DATA
+
+B<Pod::Parser> makes use of several internal methods and data fields
+which clients should not need to see or use. For the sake of avoiding
+name collisions for client data and methods, these methods and fields
+are briefly discussed here. Determined hackers may obtain further
+information about them by reading the B<Pod::Parser> source code.
+
+Private data fields are stored in the hash-object whose reference is
+returned by the B<new()> constructor for this class. The names of all
+private methods and data-fields used by B<Pod::Parser> begin with a
+prefix of "_" and match the regular expression C</^_\w+$/>.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head1 B<_push_input_stream()>
+
+ $hashref = $parser->_push_input_stream($in_fh,$out_fh);
+
+This method will push the given input stream on the input stack and
+perform any necessary beginning-of-document or beginning-of-file
+processing. The argument C<$in_fh> is the input stream filehandle to
+push, and C<$out_fh> is the corresponding output filehandle to use (if
+it is not given or is undefined, then the current output stream is used,
+which defaults to standard output if it doesnt exist yet).
+
+The value returned will be reference to the hash-table that represents
+the new top of the input stream stack. I<Please Note> that it is
+possible for this method to use default values for the input and output
+file handles. If this happens, you will need to look at the C<INPUT>
+and C<OUTPUT> instance data members to determine their new values.
+
+=end _PRIVATE_
+
+=cut
+
+sub _push_input_stream {
+ my ($self, $in_fh, $out_fh) = @_;
+ local *myData = $self;
+
+ ## Initialize stuff for the entire document if this is *not*
+ ## an included file.
+ ##
+ ## NOTE: we need to be *very* careful when "defaulting" the output
+ ## filehandle. We only want to use a default value if this is the
+ ## beginning of the entire document (but *not* if this is an included
+ ## file).
+ unless (defined $myData{_TOP_STREAM}) {
+ $out_fh = \*STDOUT unless (defined $out_fh);
+ $myData{_CUTTING} = 1; ## current "cutting" state
+ $myData{_INPUT_STREAMS} = []; ## stack of all input streams
+ }
+
+ ## Initialize input indicators
+ $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE});
+ $myData{_OUTPUT} = $out_fh if (defined $out_fh);
+ $in_fh = \*STDIN unless (defined $in_fh);
+ $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE});
+ $myData{_INPUT} = $in_fh;
+ my $input_top = $myData{_TOP_STREAM}
+ = new Pod::InputSource(
+ -name => $myData{_INFILE},
+ -handle => $in_fh,
+ -was_cutting => $myData{_CUTTING}
+ );
+ local *input_stack = $myData{_INPUT_STREAMS};
+ push(@input_stack, $input_top);
+
+ ## Perform beginning-of-document and/or beginning-of-input processing
+ $self->begin_pod() if (@input_stack == 1);
+ $self->begin_input();
+
+ return $input_top;
+}
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head1 B<_pop_input_stream()>
+
+ $hashref = $parser->_pop_input_stream();
+
+This takes no arguments. It will perform any necessary end-of-file or
+end-of-document processing and then pop the current input stream from
+the top of the input stack.
+
+The value returned will be reference to the hash-table that represents
+the new top of the input stream stack.
+
+=end _PRIVATE_
+
+=cut
+
+sub _pop_input_stream {
+ my ($self) = @_;
+ local *myData = $self;
+ local *input_stack = $myData{_INPUT_STREAMS};
+
+ ## Perform end-of-input and/or end-of-document processing
+ $self->end_input() if (@input_stack > 0);
+ $self->end_pod() if (@input_stack == 1);
+
+ ## Restore cutting state to whatever it was before we started
+ ## parsing this file.
+ my $old_top = pop(@input_stack);
+ $myData{_CUTTING} = $old_top->was_cutting();
+
+ ## Dont forget to reset the input indicators
+ my $input_top = undef;
+ if (@input_stack > 0) {
+ $input_top = $myData{_TOP_STREAM} = $input_stack[-1];
+ $myData{_INFILE} = $input_top->name();
+ $myData{_INPUT} = $input_top->handle();
+ } else {
+ delete $myData{_TOP_STREAM};
+ delete $myData{_INPUT_STREAMS};
+ }
+
+ return $input_top;
+}
+
+#############################################################################
+
+=head1 TREE-BASED PARSING
+
+If straightforward stream-based parsing wont meet your needs (as is
+likely the case for tasks such as translating PODs into structured
+markup languages like HTML and XML) then you may need to take the
+tree-based approach. Rather than doing everything in one pass and
+calling the B<interpolate()> method to expand sequences into text, it
+may be desirable to instead create a parse-tree using the B<parse_text()>
+method to return a tree-like structure which may contain an ordered
+list of children (each of which may be a text-string, or a similar
+tree-like structure).
+
+Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and
+to the objects described in L<Pod::InputObjects>. The former describes
+the gory details and parameters for how to customize and extend the
+parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides
+several objects that may all be used interchangeably as parse-trees. The
+most obvious one is the B<Pod::ParseTree> object. It defines the basic
+interface and functionality that all things trying to be a POD parse-tree
+should do. A B<Pod::ParseTree> is defined such that each "node" may be a
+text-string, or a reference to another parse-tree. Each B<Pod::Paragraph>
+object and each B<Pod::InteriorSequence> object also supports the basic
+parse-tree interface.
+
+The B<parse_text()> method takes a given paragraph of text, and
+returns a parse-tree that contains one or more children, each of which
+may be a text-string, or an InteriorSequence object. There are also
+callback-options that may be passed to B<parse_text()> to customize
+the way it expands or transforms interior-sequences, as well as the
+returned result. These callbacks can be used to create a parse-tree
+with custom-made objects (which may or may not support the parse-tree
+interface, depending on how you choose to do it).
+
+If you wish to turn an entire POD document into a parse-tree, that process
+is fairly straightforward. The B<parse_text()> method is the key to doing
+this successfully. Every paragraph-callback (i.e. the polymorphic methods
+for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes
+a B<Pod::Paragraph> object as an argument. Each paragraph object has a
+B<parse_tree()> method that can be used to get or set a corresponding
+parse-tree. So for each of those paragraph-callback methods, simply call
+B<parse_text()> with the options you desire, and then use the returned
+parse-tree to assign to the given paragraph object.
+
+That gives you a parse-tree for each paragraph - so now all you need is
+an ordered list of paragraphs. You can maintain that yourself as a data
+element in the object/hash. The most straightforward way would be simply
+to use an array-ref, with the desired set of custom "options" for each
+invocation of B<parse_text>. Let's assume the desired option-set is
+given by the hash C<%options>. Then we might do something like the
+following:
+
+ package MyPodParserTree;
+
+ @ISA = qw( Pod::Parser );
+
+ ...
+
+ sub begin_pod {
+ my $self = shift;
+ $self->{'-paragraphs'} = []; ## initialize paragraph list
+ }
+
+ sub command {
+ my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({%options}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ push @{ $self->{'-paragraphs'} }, $pod_para;
+ }
+
+ sub verbatim {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ push @{ $self->{'-paragraphs'} }, $pod_para;
+ }
+
+ sub textblock {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({%options}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ push @{ $self->{'-paragraphs'} }, $pod_para;
+ }
+
+ ...
+
+ package main;
+ ...
+ my $parser = new MyPodParserTree(...);
+ $parser->parse_from_file(...);
+ my $paragraphs_ref = $parser->{'-paragraphs'};
+
+Of course, in this module-author's humble opinion, I'd be more inclined to
+use the existing B<Pod::ParseTree> object than a simple array. That way
+everything in it, paragraphs and sequences, all respond to the same core
+interface for all parse-tree nodes. The result would look something like:
+
+ package MyPodParserTree2;
+
+ ...
+
+ sub begin_pod {
+ my $self = shift;
+ $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree
+ }
+
+ sub parse_tree {
+ ## convenience method to get/set the parse-tree for the entire POD
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
+ return $_[0]->{'-ptree'};
+ }
+
+ sub command {
+ my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ $parser->parse_tree()->append( $pod_para );
+ }
+
+ sub verbatim {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ $parser->parse_tree()->append( $pod_para );
+ }
+
+ sub textblock {
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;
+ my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
+ $pod_para->parse_tree( $ptree );
+ $parser->parse_tree()->append( $pod_para );
+ }
+
+ ...
+
+ package main;
+ ...
+ my $parser = new MyPodParserTree2(...);
+ $parser->parse_from_file(...);
+ my $ptree = $parser->parse_tree;
+ ...
+
+Now you have the entire POD document as one great big parse-tree. You
+can even use the B<-expand_seq> option to B<parse_text> to insert
+whole different kinds of objects. Just don't expect B<Pod::Parser>
+to know what to do with them after that. That will need to be in your
+code. Or, alternatively, you can insert any object you like so long as
+it conforms to the B<Pod::ParseTree> interface.
+
+One could use this to create subclasses of B<Pod::Paragraphs> and
+B<Pod::InteriorSequences> for specific commands (or to create your own
+custom node-types in the parse-tree) and add some kind of B<emit()>
+method to each custom node/subclass object in the tree. Then all you'd
+need to do is recursively walk the tree in the desired order, processing
+the children (most likely from left to right) by formatting them if
+they are text-strings, or by calling their B<emit()> method if they
+are objects/references.
+
+=head1 CAVEATS
+
+Please note that POD has the notion of "paragraphs": this is something
+starting I<after> a blank (read: empty) line, with the single exception
+of the file start, which is also starting a paragraph. That means that
+especially a command (e.g. C<=head1>) I<must> be preceded with a blank
+line; C<__END__> is I<not> a blank line.
+
+=head1 SEE ALSO
+
+L<Pod::InputObjects>, L<Pod::Select>
+
+B<Pod::InputObjects> defines POD input objects corresponding to
+command paragraphs, parse-trees, and interior-sequences.
+
+B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability
+to selectively include and/or exclude sections of a POD document from being
+translated based upon the current heading, subheading, subsubheading, etc.
+
+=for __PRIVATE__
+B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users
+the ability the employ I<callback functions> instead of, or in addition
+to, overriding methods of the base class.
+
+=for __PRIVATE__
+B<Pod::Select> and B<Pod::Callbacks> do not override any
+methods nor do they define any new methods with the same name. Because
+of this, they may I<both> be used (in combination) as a base class of
+the same subclass in order to combine their functionality without
+causing any namespace clashes due to multiple inheritance.
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+Based on code for B<Pod::Text> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=head1 LICENSE
+
+Pod-Parser is free software; you can redistribute it and/or modify it
+under the terms of the Artistic License distributed with Perl version
+5.000 or (at your option) any later version. Please refer to the
+Artistic License that came with your Perl distribution for more
+details. If your version of Perl was not distributed under the
+terms of the Artistic License, than you may distribute PodParser
+under the same terms as Perl itself.
+
+=cut
+
+1;
+# vim: ts=4 sw=4 et
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc.pm
new file mode 100755
index 00000000000..ef54796ad8c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc.pm
@@ -0,0 +1,1952 @@
+
+require 5;
+use 5.006; # we use some open(X, "<", $y) syntax
+package Pod::Perldoc;
+use strict;
+use warnings;
+use Config '%Config';
+
+use Fcntl; # for sysopen
+use File::Spec::Functions qw(catfile catdir splitdir);
+
+use vars qw($VERSION @Pagers $Bindir $Pod2man
+ $Temp_Files_Created $Temp_File_Lifetime
+);
+$VERSION = '3.15';
+#..........................................................................
+
+BEGIN { # Make a DEBUG constant very first thing...
+ unless(defined &DEBUG) {
+ if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
+ eval("sub DEBUG () {$1}");
+ die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
+ } else {
+ *DEBUG = sub () {0};
+ }
+ }
+}
+
+use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
+
+#..........................................................................
+
+sub TRUE () {1}
+sub FALSE () {return}
+sub BE_LENIENT () {1}
+
+BEGIN {
+ *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
+ *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
+ *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
+ *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
+ *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
+ *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;
+ *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;
+}
+
+$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
+ # If it's older than five days, it's quite unlikely
+ # that anyone's still looking at it!!
+ # (Currently used only by the MSWin cleanup routine)
+
+
+#..........................................................................
+{ my $pager = $Config{'pager'};
+ push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
+}
+$Bindir = $Config{'scriptdirexp'};
+$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
+
+# End of class-init stuff
+#
+###########################################################################
+#
+# Option accessors...
+
+foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULv}) {
+ no strict 'refs';
+ *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
+}
+
+# And these are so that GetOptsOO knows they take options:
+sub opt_f_with { shift->_elem('opt_f', @_) }
+sub opt_q_with { shift->_elem('opt_q', @_) }
+sub opt_d_with { shift->_elem('opt_d', @_) }
+sub opt_L_with { shift->_elem('opt_L', @_) }
+sub opt_v_with { shift->_elem('opt_v', @_) }
+
+sub opt_w_with { # Specify an option for the formatter subclass
+ my($self, $value) = @_;
+ if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
+ my $option = $1;
+ my $option_value = defined($2) ? $2 : "TRUE";
+ $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
+ $self->add_formatter_option( $option, $option_value );
+ } else {
+ warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
+ }
+ return;
+}
+
+sub opt_M_with { # specify formatter class name(s)
+ my($self, $classes) = @_;
+ return unless defined $classes and length $classes;
+ DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
+ my @classes_to_add;
+ foreach my $classname (split m/[,;]+/s, $classes) {
+ next unless $classname =~ m/\S/;
+ if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
+ # A mildly restrictive concept of what modulenames are valid.
+ push @classes_to_add, $1; # untaint
+ } else {
+ warn "\"$classname\" isn't a valid classname. Ignoring.\n";
+ }
+ }
+
+ unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
+
+ DEBUG > 3 and print(
+ "Adding @classes_to_add to the list of formatter classes, "
+ . "making them @{ $self->{'formatter_classes'} }.\n"
+ );
+
+ return;
+}
+
+sub opt_V { # report version and exit
+ print join '',
+ "Perldoc v$VERSION, under perl v$] for $^O",
+
+ (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
+ ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
+
+ (chr(65) eq 'A') ? () : " (non-ASCII)",
+
+ "\n",
+ ;
+ exit;
+}
+
+sub opt_t { # choose plaintext as output format
+ my $self = shift;
+ $self->opt_o_with('text') if @_ and $_[0];
+ return $self->_elem('opt_t', @_);
+}
+
+sub opt_u { # choose raw pod as output format
+ my $self = shift;
+ $self->opt_o_with('pod') if @_ and $_[0];
+ return $self->_elem('opt_u', @_);
+}
+
+sub opt_n_with {
+ # choose man as the output format, and specify the proggy to run
+ my $self = shift;
+ $self->opt_o_with('man') if @_ and $_[0];
+ $self->_elem('opt_n', @_);
+}
+
+sub opt_o_with { # "o" for output format
+ my($self, $rest) = @_;
+ return unless defined $rest and length $rest;
+ if($rest =~ m/^(\w+)$/s) {
+ $rest = $1; #untaint
+ } else {
+ warn "\"$rest\" isn't a valid output format. Skipping.\n";
+ return;
+ }
+
+ $self->aside("Noting \"$rest\" as desired output format...\n");
+
+ # Figure out what class(es) that could actually mean...
+
+ my @classes;
+ foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
+ # Messy but smart:
+ foreach my $stem (
+ $rest, # Yes, try it first with the given capitalization
+ "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
+
+ ) {
+ push @classes, $prefix . $stem;
+ #print "Considering $prefix$stem\n";
+ }
+
+ # Tidier, but misses too much:
+ #push @classes, $prefix . ucfirst(lc($rest));
+ }
+ $self->opt_M_with( join ";", @classes );
+ return;
+}
+
+###########################################################################
+# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
+
+sub run { # to be called by the "perldoc" executable
+ my $class = shift;
+ if(DEBUG > 3) {
+ print "Parameters to $class\->run:\n";
+ my @x = @_;
+ while(@x) {
+ $x[1] = '<undef>' unless defined $x[1];
+ $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
+ print " [$x[0]] => [$x[1]]\n";
+ splice @x,0,2;
+ }
+ print "\n";
+ }
+ return $class -> new(@_) -> process() || 0;
+}
+
+# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
+###########################################################################
+
+sub new { # yeah, nothing fancy
+ my $class = shift;
+ my $new = bless {@_}, (ref($class) || $class);
+ DEBUG > 1 and print "New $class object $new\n";
+ $new->init();
+ $new;
+}
+
+#..........................................................................
+
+sub aside { # If we're in -D or DEBUG mode, say this.
+ my $self = shift;
+ if( DEBUG or $self->opt_D ) {
+ my $out = join( '',
+ DEBUG ? do {
+ my $callsub = (caller(1))[3];
+ my $package = quotemeta(__PACKAGE__ . '::');
+ $callsub =~ s/^$package/'/os;
+ # the o is justified, as $package really won't change.
+ $callsub . ": ";
+ } : '',
+ @_,
+ );
+ if(DEBUG) { print $out } else { print STDERR $out }
+ }
+ return;
+}
+
+#..........................................................................
+
+sub usage {
+ my $self = shift;
+ warn "@_\n" if @_;
+
+ # Erase evidence of previous errors (if any), so exit status is simple.
+ $! = 0;
+
+ die <<EOF;
+perldoc [options] PageName|ModuleName|ProgramName...
+perldoc [options] -f BuiltinFunction
+perldoc [options] -q FAQRegex
+perldoc [options] -v PerlVariable
+
+Options:
+ -h Display this help message
+ -V report version
+ -r Recursive search (slow)
+ -i Ignore case
+ -t Display pod using pod2text instead of pod2man and nroff
+ (-t is the default on win32 unless -n is specified)
+ -u Display unformatted pod text
+ -m Display module's file in its entirety
+ -n Specify replacement for nroff
+ -l Display the module's file name
+ -F Arguments are file names, not modules
+ -D Verbosely describe what's going on
+ -T Send output to STDOUT without any pager
+ -d output_filename_to_send_to
+ -o output_format_name
+ -M FormatterModuleNameToUse
+ -w formatter_option:option_value
+ -L translation_code Choose doc translation (if any)
+ -X use index if present (looks for pod.idx at $Config{archlib})
+ -q Search the text of questions (not answers) in perlfaq[1-9]
+ -f Search Perl built-in functions
+ -v Search predefined Perl variables
+
+PageName|ModuleName...
+ is the name of a piece of documentation that you want to look at. You
+ may either give a descriptive name of the page (as in the case of
+ `perlfunc') the name of a module, either like `Term::Info' or like
+ `Term/Info', or the name of a program, like `perldoc'.
+
+BuiltinFunction
+ is the name of a perl function. Will extract documentation from
+ `perlfunc'.
+
+FAQRegex
+ is a regex. Will search perlfaq[1-9] for and extract any
+ questions that match.
+
+Any switches in the PERLDOC environment variable will be used before the
+command line arguments. The optional pod index file contains a list of
+filenames, one per line.
+ [Perldoc v$VERSION]
+EOF
+
+}
+
+#..........................................................................
+
+sub usage_brief {
+ my $me = $0; # Editing $0 is unportable
+
+ $me =~ s,.*[/\\],,; # get basename
+
+ die <<"EOUSAGE";
+Usage: $me [-h] [-V] [-r] [-i] [-D] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
+ $me -f PerlFunc
+ $me -q FAQKeywords
+ $me -A PerlVar
+
+The -h option prints more help. Also try "perldoc perldoc" to get
+acquainted with the system. [Perldoc v$VERSION]
+EOUSAGE
+
+}
+
+#..........................................................................
+
+sub pagers { @{ shift->{'pagers'} } }
+
+#..........................................................................
+
+sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
+ if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
+ else { return $_[0]{ $_[1] } }
+}
+#..........................................................................
+###########################################################################
+#
+# Init formatter switches, and start it off with __bindir and all that
+# other stuff that ToMan.pm needs.
+#
+
+sub init {
+ my $self = shift;
+
+ # Make sure creat()s are neither too much nor too little
+ eval { umask(0077) }; # doubtless someone has no mask
+
+ $self->{'args'} ||= \@ARGV;
+ $self->{'found'} ||= [];
+ $self->{'temp_file_list'} ||= [];
+
+
+ $self->{'target'} = undef;
+
+ $self->init_formatter_class_list;
+
+ $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
+ $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
+ $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
+
+ push @{ $self->{'formatter_switches'} = [] }, (
+ # Yeah, we could use a hashref, but maybe there's some class where options
+ # have to be ordered; so we'll use an arrayref.
+
+ [ '__bindir' => $self->{'bindir' } ],
+ [ '__pod2man' => $self->{'pod2man'} ],
+ );
+
+ DEBUG > 3 and printf "Formatter switches now: [%s]\n",
+ join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
+
+ $self->{'translators'} = [];
+ $self->{'extra_search_dirs'} = [];
+
+ return;
+}
+
+#..........................................................................
+
+sub init_formatter_class_list {
+ my $self = shift;
+ $self->{'formatter_classes'} ||= [];
+
+ # Remember, no switches have been read yet, when
+ # we've started this routine.
+
+ $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
+ $self->opt_o_with('text');
+ $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
+ || !($ENV{TERM} && (
+ ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
+ ));
+
+ return;
+}
+
+#..........................................................................
+
+sub process {
+ # if this ever returns, its retval will be used for exit(RETVAL)
+
+ my $self = shift;
+ DEBUG > 1 and print " Beginning process.\n";
+ DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
+ if(DEBUG > 3) {
+ print "Object contents:\n";
+ my @x = %$self;
+ while(@x) {
+ $x[1] = '<undef>' unless defined $x[1];
+ $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
+ print " [$x[0]] => [$x[1]]\n";
+ splice @x,0,2;
+ }
+ print "\n";
+ }
+
+ # TODO: make it deal with being invoked as various different things
+ # such as perlfaq".
+
+ return $self->usage_brief unless @{ $self->{'args'} };
+ $self->pagers_guessing;
+ $self->options_reading;
+ $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
+ $self->drop_privs_maybe;
+ $self->options_processing;
+
+ # Hm, we have @pages and @found, but we only really act on one
+ # file per call, with the exception of the opt_q hack, and with
+ # -l things
+
+ $self->aside("\n");
+
+ my @pages;
+ $self->{'pages'} = \@pages;
+ if( $self->opt_f) { @pages = ("perlfunc") }
+ elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
+ elsif( $self->opt_v) { @pages = ("perlvar") }
+ else { @pages = @{$self->{'args'}};
+ # @pages = __FILE__
+ # if @pages == 1 and $pages[0] eq 'perldoc';
+ }
+
+ return $self->usage_brief unless @pages;
+
+ $self->find_good_formatter_class();
+ $self->formatter_sanity_check();
+
+ $self->maybe_diddle_INC();
+ # for when we're apparently in a module or extension directory
+
+ my @found = $self->grand_search_init(\@pages);
+ exit (IS_VMS ? 98962 : 1) unless @found;
+
+ if ($self->opt_l) {
+ DEBUG and print "We're in -l mode, so byebye after this:\n";
+ print join("\n", @found), "\n";
+ return;
+ }
+
+ $self->tweak_found_pathnames(\@found);
+ $self->assert_closing_stdout;
+ return $self->page_module_file(@found) if $self->opt_m;
+ DEBUG > 2 and print "Found: [@found]\n";
+
+ return $self->render_and_page(\@found);
+}
+
+#..........................................................................
+{
+
+my( %class_seen, %class_loaded );
+sub find_good_formatter_class {
+ my $self = $_[0];
+ my @class_list = @{ $self->{'formatter_classes'} || [] };
+ die "WHAT? Nothing in the formatter class list!?" unless @class_list;
+
+ my $good_class_found;
+ foreach my $c (@class_list) {
+ DEBUG > 4 and print "Trying to load $c...\n";
+ if($class_loaded{$c}) {
+ DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
+ $good_class_found = $c;
+ last;
+ }
+
+ if($class_seen{$c}) {
+ DEBUG > 4 and print
+ "I've tried $c before, and it's no good. Skipping.\n";
+ next;
+ }
+
+ $class_seen{$c} = 1;
+
+ if( $c->can('parse_from_file') ) {
+ DEBUG > 4 and print
+ "Interesting, the formatter class $c is already loaded!\n";
+
+ } elsif(
+ (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
+ # the alway case-insensitive fs's
+ and $class_seen{lc("~$c")}++
+ ) {
+ DEBUG > 4 and print
+ "We already used something quite like \"\L$c\E\", so no point using $c\n";
+ # This avoids redefining the package.
+ } else {
+ DEBUG > 4 and print "Trying to eval 'require $c'...\n";
+
+ local $^W = $^W;
+ if(DEBUG() or $self->opt_D) {
+ # feh, let 'em see it
+ } else {
+ $^W = 0;
+ # The average user just has no reason to be seeing
+ # $^W-suppressable warnings from the the require!
+ }
+
+ eval "require $c";
+ if($@) {
+ DEBUG > 4 and print "Couldn't load $c: $!\n";
+ next;
+ }
+ }
+
+ if( $c->can('parse_from_file') ) {
+ DEBUG > 4 and print "Settling on $c\n";
+ my $v = $c->VERSION;
+ $v = ( defined $v and length $v ) ? " version $v" : '';
+ $self->aside("Formatter class $c$v successfully loaded!\n");
+ $good_class_found = $c;
+ last;
+ } else {
+ DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
+ }
+ }
+
+ die "Can't find any loadable formatter class in @class_list?!\nAborting"
+ unless $good_class_found;
+
+ $self->{'formatter_class'} = $good_class_found;
+ $self->aside("Will format with the class $good_class_found\n");
+
+ return;
+}
+
+}
+#..........................................................................
+
+sub formatter_sanity_check {
+ my $self = shift;
+ my $formatter_class = $self->{'formatter_class'}
+ || die "NO FORMATTER CLASS YET!?";
+
+ if(!$self->opt_T # so -T can FORCE sending to STDOUT
+ and $formatter_class->can('is_pageable')
+ and !$formatter_class->is_pageable
+ and !$formatter_class->can('page_for_perldoc')
+ ) {
+ my $ext =
+ ($formatter_class->can('output_extension')
+ && $formatter_class->output_extension
+ ) || '';
+ $ext = ".$ext" if length $ext;
+
+ die
+ "When using Perldoc to format with $formatter_class, you have to\n"
+ . "specify -T or -dsomefile$ext\n"
+ . "See `perldoc perldoc' for more information on those switches.\n"
+ ;
+ }
+}
+
+#..........................................................................
+
+sub render_and_page {
+ my($self, $found_list) = @_;
+
+ $self->maybe_generate_dynamic_pod($found_list);
+
+ my($out, $formatter) = $self->render_findings($found_list);
+
+ if($self->opt_d) {
+ printf "Perldoc (%s) output saved to %s\n",
+ $self->{'formatter_class'} || ref($self),
+ $out;
+ print "But notice that it's 0 bytes long!\n" unless -s $out;
+
+
+ } elsif( # Allow the formatter to "page" itself, if it wants.
+ $formatter->can('page_for_perldoc')
+ and do {
+ $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
+ if( $formatter->page_for_perldoc($out, $self) ) {
+ $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
+ 1;
+ } else {
+ $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
+ '';
+ }
+ }
+ ) {
+ # Do nothing, since the formatter has "paged" it for itself.
+
+ } else {
+ # Page it normally (internally)
+
+ if( -s $out ) { # Usual case:
+ $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
+
+ } else {
+ # Odd case:
+ $self->aside("Skipping $out (from $$found_list[0] "
+ . "via $$self{'formatter_class'}) as it is 0-length.\n");
+
+ push @{ $self->{'temp_file_list'} }, $out;
+ $self->unlink_if_temp_file($out);
+ }
+ }
+
+ $self->after_rendering(); # any extra cleanup or whatever
+
+ return;
+}
+
+#..........................................................................
+
+sub options_reading {
+ my $self = shift;
+
+ if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
+ require Text::ParseWords;
+ $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
+ # Yes, appends to the beginning
+ unshift @{ $self->{'args'} },
+ Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
+ ;
+ DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
+ } else {
+ DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
+ }
+
+ DEBUG > 1
+ and print " Args right before switch processing: @{$self->{'args'}}\n";
+
+ Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
+ or return $self->usage;
+
+ DEBUG > 1
+ and print " Args after switch processing: @{$self->{'args'}}\n";
+
+ return $self->usage if $self->opt_h;
+
+ return;
+}
+
+#..........................................................................
+
+sub options_processing {
+ my $self = shift;
+
+ if ($self->opt_X) {
+ my $podidx = "$Config{'archlib'}/pod.idx";
+ $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
+ $self->{'podidx'} = $podidx;
+ }
+
+ $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
+
+ $self->options_sanity;
+
+ $self->opt_n("nroff") unless $self->opt_n;
+ $self->add_formatter_option( '__nroffer' => $self->opt_n );
+
+ # Adjust for using translation packages
+ $self->add_translator($self->opt_L) if $self->opt_L;
+
+ return;
+}
+
+#..........................................................................
+
+sub options_sanity {
+ my $self = shift;
+
+ # The opts-counting stuff interacts quite badly with
+ # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
+ # set to -t, and I specify -u on the command line, I don't want
+ # to be hectored at that -u and -t don't make sense together.
+
+ #my $opts = grep $_ && 1, # yes, the count of the set ones
+ # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
+ #;
+ #
+ #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
+
+
+ # Any sanity-checking need doing here?
+
+ # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
+ if( $self->opt_f or $self->opt_q ) {
+ $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
+ warn
+ "Perldoc is only really meant for reading one word at a time.\n",
+ "So these parameters are being ignored: ",
+ join(' ', @{$self->{'args'}}),
+ "\n"
+ if @{$self->{'args'}}
+ }
+ return;
+}
+
+#..........................................................................
+
+sub grand_search_init {
+ my($self, $pages, @found) = @_;
+
+ foreach (@$pages) {
+ if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
+ my $searchfor = catfile split '::', $_;
+ $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
+ local $_;
+ while (<PODIDX>) {
+ chomp;
+ push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
+ }
+ close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
+ next;
+ }
+
+ $self->aside( "Searching for $_\n" );
+
+ if ($self->opt_F) {
+ next unless -r;
+ push @found, $_ if $self->opt_m or $self->containspod($_);
+ next;
+ }
+
+ my @searchdirs;
+
+ # prepend extra search directories (including language specific)
+ push @searchdirs, @{ $self->{'extra_search_dirs'} };
+
+ # We must look both in @INC for library modules and in $bindir
+ # for executables, like h2xs or perldoc itself.
+ push @searchdirs, ($self->{'bindir'}, @INC);
+ unless ($self->opt_m) {
+ if (IS_VMS) {
+ my($i,$trn);
+ for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
+ push(@searchdirs,$trn);
+ }
+ push(@searchdirs,'perl_root:[lib.pod]') # installed pods
+ }
+ else {
+ push(@searchdirs, grep(-d, split($Config{path_sep},
+ $ENV{'PATH'})));
+ }
+ }
+ my @files = $self->searchfor(0,$_,@searchdirs);
+ if (@files) {
+ $self->aside( "Found as @files\n" );
+ }
+ # add "perl" prefix, so "perldoc foo" may find perlfoo.pod
+ elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) {
+ $self->aside( "Loosely found as @files\n" );
+ }
+ else {
+ # no match, try recursive search
+ @searchdirs = grep(!/^\.\z/s,@INC);
+ @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
+ if (@files) {
+ $self->aside( "Loosely found as @files\n" );
+ }
+ else {
+ print STDERR "No " .
+ ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
+ if ( @{ $self->{'found'} } ) {
+ print STDERR "However, try\n";
+ for my $dir (@{ $self->{'found'} }) {
+ opendir(DIR, $dir) or die "opendir $dir: $!";
+ while (my $file = readdir(DIR)) {
+ next if ($file =~ /^\./s);
+ $file =~ s/\.(pm|pod)\z//; # XXX: badfs
+ print STDERR "\tperldoc $_\::$file\n";
+ }
+ closedir(DIR) or die "closedir $dir: $!";
+ }
+ }
+ }
+ }
+ push(@found,@files);
+ }
+ return @found;
+}
+
+#..........................................................................
+
+sub maybe_generate_dynamic_pod {
+ my($self, $found_things) = @_;
+ my @dynamic_pod;
+
+ $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
+
+ $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v;
+
+ $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
+
+ if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) {
+ DEBUG > 4 and print "That's a non-dynamic pod search.\n";
+ } elsif ( @dynamic_pod ) {
+ $self->aside("Hm, I found some Pod from that search!\n");
+ my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
+
+ push @{ $self->{'temp_file_list'} }, $buffer;
+ # I.e., it MIGHT be deleted at the end.
+
+ my $in_list = $self->opt_f || $self->opt_v;
+
+ print $buffd "=over 8\n\n" if $in_list;
+ print $buffd @dynamic_pod or die "Can't print $buffer: $!";
+ print $buffd "=back\n" if $in_list;
+
+ close $buffd or die "Can't close $buffer: $!";
+
+ @$found_things = $buffer;
+ # Yes, so found_things never has more than one thing in
+ # it, by time we leave here
+
+ $self->add_formatter_option('__filter_nroff' => 1);
+
+ } else {
+ @$found_things = ();
+ $self->aside("I found no Pod from that search!\n");
+ }
+
+ return;
+}
+
+#..........................................................................
+
+sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
+ my $self = shift;
+ push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
+
+ DEBUG > 3 and printf "Formatter switches now: [%s]\n",
+ join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
+
+ return;
+}
+
+#.........................................................................
+
+sub new_translator { # $tr = $self->new_translator($lang);
+ my $self = shift;
+ my $lang = shift;
+
+ my $pack = 'POD2::' . uc($lang);
+ eval "require $pack";
+ if ( !$@ && $pack->can('new') ) {
+ return $pack->new();
+ }
+
+ eval { require POD2::Base };
+ return if $@;
+
+ return POD2::Base->new({ lang => $lang });
+}
+
+#.........................................................................
+
+sub add_translator { # $self->add_translator($lang);
+ my $self = shift;
+ for my $lang (@_) {
+ my $tr = $self->new_translator($lang);
+ if ( defined $tr ) {
+ push @{ $self->{'translators'} }, $tr;
+ push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
+
+ $self->aside( "translator for '$lang' loaded\n" );
+ } else {
+ # non-installed or bad translator package
+ warn "Perldoc cannot load translator package for '$lang': ignored\n";
+ }
+
+ }
+ return;
+}
+
+#..........................................................................
+
+sub search_perlvar {
+ my($self, $found_things, $pod) = @_;
+
+ my $opt = $self->opt_v;
+
+ if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
+ die "'$opt' does not look like a Perl variable\n";
+ }
+
+ DEBUG > 2 and print "Search: @$found_things\n";
+
+ my $perlvar = shift @$found_things;
+ open(PVAR, "<", $perlvar) # "Funk is its own reward"
+ or die("Can't open $perlvar: $!");
+
+ if ( $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9
+ $opt = '$<I<digits>>';
+ }
+ my $search_re = quotemeta($opt);
+
+ DEBUG > 2 and
+ print "Going to perlvar-scan for $search_re in $perlvar\n";
+
+ # Skip introduction
+ local $_;
+ while (<PVAR>) {
+ last if /^=over 8/;
+ }
+
+ # Look for our variable
+ my $found = 0;
+ my $inheader = 1;
+ my $inlist = 0;
+ while (<PVAR>) { # "The Mothership Connection is here!"
+ last if /^=head2 Error Indicators/;
+ # \b at the end of $` and friends borks things!
+ if ( m/^=item\s+$search_re\s/ ) {
+ $found = 1;
+ }
+ elsif (/^=item/) {
+ last if $found && !$inheader && !$inlist;
+ }
+ elsif (!/^\s+$/) { # not a blank line
+ if ( $found ) {
+ $inheader = 0; # don't accept more =item (unless inlist)
+ }
+ else {
+ @$pod = (); # reset
+ $inheader = 1; # start over
+ next;
+ }
+ }
+
+ if (/^=over/) {
+ ++$inlist;
+ }
+ elsif (/^=back/) {
+ --$inlist;
+ }
+ push @$pod, $_;
+# ++$found if /^\w/; # found descriptive text
+ }
+ @$pod = () unless $found;
+ if (!@$pod) {
+ die "No documentation for perl variable '$opt' found\n";
+ }
+ close PVAR or die "Can't open $perlvar: $!";
+
+ return;
+}
+
+#..........................................................................
+
+sub search_perlfunc {
+ my($self, $found_things, $pod) = @_;
+
+ DEBUG > 2 and print "Search: @$found_things\n";
+
+ my $perlfunc = shift @$found_things;
+ open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
+ or die("Can't open $perlfunc: $!");
+
+ # Functions like -r, -e, etc. are listed under `-X'.
+ my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
+ ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
+
+ DEBUG > 2 and
+ print "Going to perlfunc-scan for $search_re in $perlfunc\n";
+
+ my $re = 'Alphabetical Listing of Perl Functions';
+ if ( $self->opt_L ) {
+ my $tr = $self->{'translators'}->[0];
+ $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
+ }
+
+ # Skip introduction
+ local $_;
+ while (<PFUNC>) {
+ last if /^=head2 $re/;
+ }
+
+ # Look for our function
+ my $found = 0;
+ my $inlist = 0;
+ while (<PFUNC>) { # "The Mothership Connection is here!"
+ if ( m/^=item\s+$search_re\b/ ) {
+ $found = 1;
+ }
+ elsif (/^=item/) {
+ last if $found > 1 and not $inlist;
+ }
+ next unless $found;
+ if (/^=over/) {
+ ++$inlist;
+ }
+ elsif (/^=back/) {
+ --$inlist;
+ }
+ push @$pod, $_;
+ ++$found if /^\w/; # found descriptive text
+ }
+ if (!@$pod) {
+ die sprintf
+ "No documentation for perl function `%s' found\n",
+ $self->opt_f
+ ;
+ }
+ close PFUNC or die "Can't open $perlfunc: $!";
+
+ return;
+}
+
+#..........................................................................
+
+sub search_perlfaqs {
+ my( $self, $found_things, $pod) = @_;
+
+ my $found = 0;
+ my %found_in;
+ my $search_key = $self->opt_q;
+
+ my $rx = eval { qr/$search_key/ }
+ or die <<EOD;
+Invalid regular expression '$search_key' given as -q pattern:
+$@
+Did you mean \\Q$search_key ?
+
+EOD
+
+ local $_;
+ foreach my $file (@$found_things) {
+ die "invalid file spec: $!" if $file =~ /[<>|]/;
+ open(INFAQ, "<", $file) # XXX 5.6ism
+ or die "Can't read-open $file: $!\nAborting";
+ while (<INFAQ>) {
+ if ( m/^=head2\s+.*(?:$search_key)/i ) {
+ $found = 1;
+ push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
+ }
+ elsif (/^=head[12]/) {
+ $found = 0;
+ }
+ next unless $found;
+ push @$pod, $_;
+ }
+ close(INFAQ);
+ }
+ die("No documentation for perl FAQ keyword `$search_key' found\n")
+ unless @$pod;
+
+ return;
+}
+
+
+#..........................................................................
+
+sub render_findings {
+ # Return the filename to open
+
+ my($self, $found_things) = @_;
+
+ my $formatter_class = $self->{'formatter_class'}
+ || die "No formatter class set!?";
+ my $formatter = $formatter_class->can('new')
+ ? $formatter_class->new
+ : $formatter_class
+ ;
+
+ if(! @$found_things) {
+ die "Nothing found?!";
+ # should have been caught before here
+ } elsif(@$found_things > 1) {
+ warn
+ "Perldoc is only really meant for reading one document at a time.\n",
+ "So these parameters are being ignored: ",
+ join(' ', @$found_things[1 .. $#$found_things] ),
+ "\n"
+ }
+
+ my $file = $found_things->[0];
+
+ DEBUG > 3 and printf "Formatter switches now: [%s]\n",
+ join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
+
+ # Set formatter options:
+ if( ref $formatter ) {
+ foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
+ my($switch, $value, $silent_fail) = @$f;
+ if( $formatter->can($switch) ) {
+ eval { $formatter->$switch( defined($value) ? $value : () ) };
+ warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
+ if $@;
+ } else {
+ if( $silent_fail or $switch =~ m/^__/s ) {
+ DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
+ } else {
+ warn "$formatter_class doesn't recognize the $switch switch.\n";
+ }
+ }
+ }
+ }
+
+ $self->{'output_is_binary'} =
+ $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
+
+ my ($out_fh, $out) = $self->new_output_file(
+ ( $formatter->can('output_extension') && $formatter->output_extension )
+ || undef,
+ $self->useful_filename_bit,
+ );
+
+ # Now, finally, do the formatting!
+ {
+ local $^W = $^W;
+ if(DEBUG() or $self->opt_D) {
+ # feh, let 'em see it
+ } else {
+ $^W = 0;
+ # The average user just has no reason to be seeing
+ # $^W-suppressable warnings from the formatting!
+ }
+
+ eval { $formatter->parse_from_file( $file, $out_fh ) };
+ }
+
+ warn "Error while formatting with $formatter_class:\n $@\n" if $@;
+ DEBUG > 2 and print "Back from formatting with $formatter_class\n";
+
+ close $out_fh
+ or warn "Can't close $out: $!\n(Did $formatter already close it?)";
+ sleep 0; sleep 0; sleep 0;
+ # Give the system a few timeslices to meditate on the fact
+ # that the output file does in fact exist and is closed.
+
+ $self->unlink_if_temp_file($file);
+
+ unless( -s $out ) {
+ if( $formatter->can( 'if_zero_length' ) ) {
+ # Basically this is just a hook for Pod::Simple::Checker; since
+ # what other class could /happily/ format an input file with Pod
+ # as a 0-length output file?
+ $formatter->if_zero_length( $file, $out, $out_fh );
+ } else {
+ warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
+ }
+ }
+
+ DEBUG and print "Finished writing to $out.\n";
+ return($out, $formatter) if wantarray;
+ return $out;
+}
+
+#..........................................................................
+
+sub unlink_if_temp_file {
+ # Unlink the specified file IFF it's in the list of temp files.
+ # Really only used in the case of -f / -q things when we can
+ # throw away the dynamically generated source pod file once
+ # we've formatted it.
+ #
+ my($self, $file) = @_;
+ return unless defined $file and length $file;
+
+ my $temp_file_list = $self->{'temp_file_list'} || return;
+ if(grep $_ eq $file, @$temp_file_list) {
+ $self->aside("Unlinking $file\n");
+ unlink($file) or warn "Odd, couldn't unlink $file: $!";
+ } else {
+ DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
+ }
+ return;
+}
+
+#..........................................................................
+
+sub MSWin_temp_cleanup {
+
+ # Nothing particularly MSWin-specific in here, but I don't know if any
+ # other OS needs its temp dir policed like MSWin does!
+
+ my $self = shift;
+
+ my $tempdir = $ENV{'TEMP'};
+ return unless defined $tempdir and length $tempdir
+ and -e $tempdir and -d _ and -w _;
+
+ $self->aside(
+ "Considering whether any old files of mine in $tempdir need unlinking.\n"
+ );
+
+ opendir(TMPDIR, $tempdir) || return;
+ my @to_unlink;
+
+ my $limit = time() - $Temp_File_Lifetime;
+
+ DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
+ ($limit) x 2;
+
+ my $filespec;
+
+ while(defined($filespec = readdir(TMPDIR))) {
+ if(
+ $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
+ ) {
+ if( hex($1) < $limit ) {
+ push @to_unlink, "$tempdir/$filespec";
+ $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
+ } else {
+ DEBUG > 5 and
+ printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
+ }
+ } else {
+ DEBUG > 5 and
+ print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
+ }
+ }
+ closedir(TMPDIR);
+ $self->aside(sprintf "Unlinked %s items of mine in %s\n",
+ scalar(unlink(@to_unlink)),
+ $tempdir
+ );
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub MSWin_perldoc_tempfile {
+ my($self, $suffix, $infix) = @_;
+
+ my $tempdir = $ENV{'TEMP'};
+ return unless defined $tempdir and length $tempdir
+ and -e $tempdir and -d _ and -w _;
+
+ my $spec;
+
+ do {
+ $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
+ # Yes, we embed the create-time in the filename!
+ $tempdir,
+ $infix || 'x',
+ time(),
+ $$,
+ defined( &Win32::GetTickCount )
+ ? (Win32::GetTickCount() & 0xff)
+ : int(rand 256)
+ # Under MSWin, $$ values get reused quickly! So if we ran
+ # perldoc foo and then perldoc bar before there was time for
+ # time() to increment time."_$$" would likely be the same
+ # for each process! So we tack on the tick count's lower
+ # bits (or, in a pinch, rand)
+ ,
+ $suffix || 'txt';
+ ;
+ } while( -e $spec );
+
+ my $counter = 0;
+
+ while($counter < 50) {
+ my $fh;
+ # If we are running before perl5.6.0, we can't autovivify
+ if ($] < 5.006) {
+ require Symbol;
+ $fh = Symbol::gensym();
+ }
+ DEBUG > 3 and print "About to try making temp file $spec\n";
+ return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
+ $self->aside("Can't create temp file $spec: $!\n");
+ }
+
+ $self->aside("Giving up on making a temp file!\n");
+ die "Can't make a tempfile!?";
+}
+
+#..........................................................................
+
+
+sub after_rendering {
+ my $self = $_[0];
+ $self->after_rendering_VMS if IS_VMS;
+ $self->after_rendering_MSWin32 if IS_MSWin32;
+ $self->after_rendering_Dos if IS_Dos;
+ $self->after_rendering_OS2 if IS_OS2;
+ return;
+}
+
+sub after_rendering_VMS { return }
+sub after_rendering_Dos { return }
+sub after_rendering_OS2 { return }
+
+sub after_rendering_MSWin32 {
+ shift->MSWin_temp_cleanup() if $Temp_Files_Created;
+}
+
+#..........................................................................
+# : : : : : : : : :
+#..........................................................................
+
+
+sub minus_f_nocase { # i.e., do like -f, but without regard to case
+
+ my($self, $dir, $file) = @_;
+ my $path = catfile($dir,$file);
+ return $path if -f $path and -r _;
+
+ if(!$self->opt_i
+ or IS_VMS or IS_MSWin32
+ or IS_Dos or IS_OS2
+ ) {
+ # On a case-forgiving file system, or if case is important,
+ # that is it, all we can do.
+ warn "Ignored $path: unreadable\n" if -f _;
+ return '';
+ }
+
+ local *DIR;
+ my @p = ($dir);
+ my($p,$cip);
+ foreach $p (splitdir $file){
+ my $try = catfile @p, $p;
+ $self->aside("Scrutinizing $try...\n");
+ stat $try;
+ if (-d _) {
+ push @p, $p;
+ if ( $p eq $self->{'target'} ) {
+ my $tmp_path = catfile @p;
+ my $path_f = 0;
+ for (@{ $self->{'found'} }) {
+ $path_f = 1 if $_ eq $tmp_path;
+ }
+ push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
+ $self->aside( "Found as $tmp_path but directory\n" );
+ }
+ }
+ elsif (-f _ && -r _) {
+ return $try;
+ }
+ elsif (-f _) {
+ warn "Ignored $try: unreadable\n";
+ }
+ elsif (-d catdir(@p)) { # at least we see the containing directory!
+ my $found = 0;
+ my $lcp = lc $p;
+ my $p_dirspec = catdir(@p);
+ opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
+ while(defined( $cip = readdir(DIR) )) {
+ if (lc $cip eq $lcp){
+ $found++;
+ last; # XXX stop at the first? what if there's others?
+ }
+ }
+ closedir DIR or die "closedir $p_dirspec: $!";
+ return "" unless $found;
+
+ push @p, $cip;
+ my $p_filespec = catfile(@p);
+ return $p_filespec if -f $p_filespec and -r _;
+ warn "Ignored $p_filespec: unreadable\n" if -f _;
+ }
+ }
+ return "";
+}
+
+#..........................................................................
+
+sub pagers_guessing {
+ my $self = shift;
+
+ my @pagers;
+ push @pagers, $self->pagers;
+ $self->{'pagers'} = \@pagers;
+
+ if (IS_MSWin32) {
+ push @pagers, qw( more< less notepad );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ }
+ elsif (IS_VMS) {
+ push @pagers, qw( most more less type/page );
+ }
+ elsif (IS_Dos) {
+ push @pagers, qw( less.exe more.com< );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ }
+ else {
+ if (IS_OS2) {
+ unshift @pagers, 'less', 'cmd /c more <';
+ }
+ push @pagers, qw( more less pg view cat );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ }
+
+ if (IS_Cygwin) {
+ if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
+ unshift @pagers, '/usr/bin/less -isrR';
+ }
+ }
+
+ unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
+
+ return;
+}
+
+#..........................................................................
+
+sub page_module_file {
+ my($self, @found) = @_;
+
+ # Security note:
+ # Don't ever just pass this off to anything like MSWin's "start.exe",
+ # since we might be calling on a .pl file, and we wouldn't want that
+ # to actually /execute/ the file that we just want to page thru!
+ # Also a consideration if one were to use a web browser as a pager;
+ # doing so could trigger the browser's MIME mapping for whatever
+ # it thinks .pm/.pl/whatever is. Probably just a (useless and
+ # annoying) "Save as..." dialog, but potentially executing the file
+ # in question -- particularly in the case of MSIE and it's, ahem,
+ # occasionally hazy distinction between OS-local extension
+ # associations, and browser-specific MIME mappings.
+
+ if ($self->{'output_to_stdout'}) {
+ $self->aside("Sending unpaged output to STDOUT.\n");
+ local $_;
+ my $any_error = 0;
+ foreach my $output (@found) {
+ unless( open(TMP, "<", $output) ) { # XXX 5.6ism
+ warn("Can't open $output: $!");
+ $any_error = 1;
+ next;
+ }
+ while (<TMP>) {
+ print or die "Can't print to stdout: $!";
+ }
+ close TMP or die "Can't close while $output: $!";
+ $self->unlink_if_temp_file($output);
+ }
+ return $any_error; # successful
+ }
+
+ foreach my $pager ( $self->pagers ) {
+ $self->aside("About to try calling $pager @found\n");
+ if (system($pager, @found) == 0) {
+ $self->aside("Yay, it worked.\n");
+ return 0;
+ }
+ $self->aside("That didn't work.\n");
+
+ # Odd -- when it fails, under Win32, this seems to neither
+ # return with a fail nor return with a success!!
+ # That's discouraging!
+ }
+
+ $self->aside(
+ sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
+ join(' ', @found),
+ join(' ', $self->pagers),
+ );
+
+ if (IS_VMS) {
+ DEBUG > 1 and print "Bailing out in a VMSish way.\n";
+ eval q{
+ use vmsish qw(status exit);
+ exit $?;
+ 1;
+ } or die;
+ }
+
+ return 1;
+ # i.e., an UNSUCCESSFUL return value!
+}
+
+#..........................................................................
+
+sub check_file {
+ my($self, $dir, $file) = @_;
+
+ unless( ref $self ) {
+ # Should never get called:
+ $Carp::Verbose = 1;
+ require Carp;
+ Carp::croak( join '',
+ "Crazy ", __PACKAGE__, " error:\n",
+ "check_file must be an object_method!\n",
+ "Aborting"
+ );
+ }
+
+ if(length $dir and not -d $dir) {
+ DEBUG > 3 and print " No dir $dir -- skipping.\n";
+ return "";
+ }
+
+ if ($self->opt_m) {
+ return $self->minus_f_nocase($dir,$file);
+ }
+
+ else {
+ my $path = $self->minus_f_nocase($dir,$file);
+ if( length $path and $self->containspod($path) ) {
+ DEBUG > 3 and print
+ " The file $path indeed looks promising!\n";
+ return $path;
+ }
+ }
+ DEBUG > 3 and print " No good: $file in $dir\n";
+
+ return "";
+}
+
+#..........................................................................
+
+sub containspod {
+ my($self, $file, $readit) = @_;
+ return 1 if !$readit && $file =~ /\.pod\z/i;
+
+
+ # Under cygwin the /usr/bin/perl is legal executable, but
+ # you cannot open a file with that name. It must be spelled
+ # out as "/usr/bin/perl.exe".
+ #
+ # The following if-case under cygwin prevents error
+ #
+ # $ perldoc perl
+ # Cannot open /usr/bin/perl: no such file or directory
+ #
+ # This would work though
+ #
+ # $ perldoc perl.pod
+
+ if ( IS_Cygwin and -x $file and -f "$file.exe" )
+ {
+ warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_D;
+ return 0;
+ }
+
+ local($_);
+ open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
+ while (<TEST>) {
+ if (/^=head/) {
+ close(TEST) or die "Can't close $file: $!";
+ return 1;
+ }
+ }
+ close(TEST) or die "Can't close $file: $!";
+ return 0;
+}
+
+#..........................................................................
+
+sub maybe_diddle_INC {
+ my $self = shift;
+
+ # Does this look like a module or extension directory?
+
+ if (-f "Makefile.PL" || -f "Build.PL") {
+
+ # Add "." and "lib" to @INC (if they exist)
+ eval q{ use lib qw(. lib); 1; } or die;
+
+ # don't add if superuser
+ if ($< && $> && -d "blib") { # don't be looking too hard now!
+ eval q{ use blib; 1 };
+ warn $@ if $@ && $self->opt_D;
+ }
+ }
+
+ return;
+}
+
+#..........................................................................
+
+sub new_output_file {
+ my $self = shift;
+ my $outspec = $self->opt_d; # Yes, -d overrides all else!
+ # So don't call this twice per format-job!
+
+ return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
+
+ # Otherwise open a write-handle on opt_d!f
+
+ my $fh;
+ # If we are running before perl5.6.0, we can't autovivify
+ if ($] < 5.006) {
+ require Symbol;
+ $fh = Symbol::gensym();
+ }
+ DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
+ die "Can't write-open $outspec: $!"
+ unless open($fh, ">", $outspec); # XXX 5.6ism
+
+ DEBUG > 3 and print "Successfully opened $outspec\n";
+ binmode($fh) if $self->{'output_is_binary'};
+ return($fh, $outspec);
+}
+
+#..........................................................................
+
+sub useful_filename_bit {
+ # This tries to provide a meaningful bit of text to do with the query,
+ # such as can be used in naming the file -- since if we're going to be
+ # opening windows on temp files (as a "pager" may well do!) then it's
+ # better if the temp file's name (which may well be used as the window
+ # title) isn't ALL just random garbage!
+ # In other words "perldoc_LWPSimple_2371981429" is a better temp file
+ # name than "perldoc_2371981429". So this routine is what tries to
+ # provide the "LWPSimple" bit.
+ #
+ my $self = shift;
+ my $pages = $self->{'pages'} || return undef;
+ return undef unless @$pages;
+
+ my $chunk = $pages->[0];
+ return undef unless defined $chunk;
+ $chunk =~ s/:://g;
+ $chunk =~ s/\.\w+$//g; # strip any extension
+ if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
+ $chunk = $1;
+ } else {
+ return undef;
+ }
+ $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
+ $chunk = substr($chunk, -10) if length($chunk) > 10;
+ return $chunk;
+}
+
+#..........................................................................
+
+sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
+ my $self = shift;
+
+ ++$Temp_Files_Created;
+
+ if( IS_MSWin32 ) {
+ my @out = $self->MSWin_perldoc_tempfile(@_);
+ return @out if @out;
+ # otherwise fall thru to the normal stuff below...
+ }
+
+ require File::Temp;
+ return File::Temp::tempfile(UNLINK => 1);
+}
+
+#..........................................................................
+
+sub page { # apply a pager to the output file
+ my ($self, $output, $output_to_stdout, @pagers) = @_;
+ if ($output_to_stdout) {
+ $self->aside("Sending unpaged output to STDOUT.\n");
+ open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
+ local $_;
+ while (<TMP>) {
+ print or die "Can't print to stdout: $!";
+ }
+ close TMP or die "Can't close while $output: $!";
+ $self->unlink_if_temp_file($output);
+ } else {
+ # On VMS, quoting prevents logical expansion, and temp files with no
+ # extension get the wrong default extension (such as .LIS for TYPE)
+
+ $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
+
+ $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
+ # Altho "/" under MSWin is in theory good as a pathsep,
+ # many many corners of the OS don't like it. So we
+ # have to force it to be "\" to make everyone happy.
+
+ foreach my $pager (@pagers) {
+ $self->aside("About to try calling $pager $output\n");
+ if (IS_VMS) {
+ last if system("$pager $output") == 0;
+ } else {
+ last if system("$pager \"$output\"") == 0;
+ }
+ }
+ }
+ return;
+}
+
+#..........................................................................
+
+sub searchfor {
+ my($self, $recurse,$s,@dirs) = @_;
+ $s =~ s!::!/!g;
+ $s = VMS::Filespec::unixify($s) if IS_VMS;
+ return $s if -f $s && $self->containspod($s);
+ $self->aside( "Looking for $s in @dirs\n" );
+ my $ret;
+ my $i;
+ my $dir;
+ $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
+ for ($i=0; $i<@dirs; $i++) {
+ $dir = $dirs[$i];
+ next unless -d $dir;
+ ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
+ if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
+ or ( $ret = $self->check_file($dir,"$s.pm"))
+ or ( $ret = $self->check_file($dir,$s))
+ or ( IS_VMS and
+ $ret = $self->check_file($dir,"$s.com"))
+ or ( IS_OS2 and
+ $ret = $self->check_file($dir,"$s.cmd"))
+ or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
+ $ret = $self->check_file($dir,"$s.bat"))
+ or ( $ret = $self->check_file("$dir/pod","$s.pod"))
+ or ( $ret = $self->check_file("$dir/pod",$s))
+ or ( $ret = $self->check_file("$dir/pods","$s.pod"))
+ or ( $ret = $self->check_file("$dir/pods",$s))
+ ) {
+ DEBUG > 1 and print " Found $ret\n";
+ return $ret;
+ }
+
+ if ($recurse) {
+ opendir(D,$dir) or die "Can't opendir $dir: $!";
+ my @newdirs = map catfile($dir, $_), grep {
+ not /^\.\.?\z/s and
+ not /^auto\z/s and # save time! don't search auto dirs
+ -d catfile($dir, $_)
+ } readdir D;
+ closedir(D) or die "Can't closedir $dir: $!";
+ next unless @newdirs;
+ # what a wicked map!
+ @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
+ $self->aside( "Also looking in @newdirs\n" );
+ push(@dirs,@newdirs);
+ }
+ }
+ return ();
+}
+
+#..........................................................................
+{
+ my $already_asserted;
+ sub assert_closing_stdout {
+ my $self = shift;
+
+ return if $already_asserted;
+
+ eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
+ # What for? to let the pager know that nothing more will come?
+
+ die $@ if $@;
+ $already_asserted = 1;
+ return;
+ }
+}
+
+#..........................................................................
+
+sub tweak_found_pathnames {
+ my($self, $found) = @_;
+ if (IS_MSWin32) {
+ foreach (@$found) { s,/,\\,g }
+ }
+ return;
+}
+
+#..........................................................................
+# : : : : : : : : :
+#..........................................................................
+
+sub am_taint_checking {
+ my $self = shift;
+ die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
+ my($k,$v) = each %ENV;
+ return is_tainted($v);
+}
+
+#..........................................................................
+
+sub is_tainted { # just a function
+ my $arg = shift;
+ my $nada = substr($arg, 0, 0); # zero-length!
+ local $@; # preserve the caller's version of $@
+ eval { eval "# $nada" };
+ return length($@) != 0;
+}
+
+#..........................................................................
+
+sub drop_privs_maybe {
+ my $self = shift;
+
+ # Attempt to drop privs if we should be tainting and aren't
+ if (!(IS_VMS || IS_MSWin32 || IS_Dos
+ || IS_OS2
+ )
+ && ($> == 0 || $< == 0)
+ && !$self->am_taint_checking()
+ ) {
+ my $id = eval { getpwnam("nobody") };
+ $id = eval { getpwnam("nouser") } unless defined $id;
+ $id = -2 unless defined $id;
+ #
+ # According to Stevens' APUE and various
+ # (BSD, Solaris, HP-UX) man pages, setting
+ # the real uid first and effective uid second
+ # is the way to go if one wants to drop privileges,
+ # because if one changes into an effective uid of
+ # non-zero, one cannot change the real uid any more.
+ #
+ # Actually, it gets even messier. There is
+ # a third uid, called the saved uid, and as
+ # long as that is zero, one can get back to
+ # uid of zero. Setting the real-effective *twice*
+ # helps in *most* systems (FreeBSD and Solaris)
+ # but apparently in HP-UX even this doesn't help:
+ # the saved uid stays zero (apparently the only way
+ # in HP-UX to change saved uid is to call setuid()
+ # when the effective uid is zero).
+ #
+ eval {
+ $< = $id; # real uid
+ $> = $id; # effective uid
+ $< = $id; # real uid
+ $> = $id; # effective uid
+ };
+ if( !$@ && $< && $> ) {
+ DEBUG and print "OK, I dropped privileges.\n";
+ } elsif( $self->opt_U ) {
+ DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
+ } else {
+ DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
+ # We used to die here; but that seemed pointless.
+ }
+ }
+ return;
+}
+
+#..........................................................................
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Perldoc - Look up Perl documentation in Pod format.
+
+=head1 SYNOPSIS
+
+ use Pod::Perldoc ();
+
+ Pod::Perldoc->run();
+
+=head1 DESCRIPTION
+
+The guts of L<perldoc> utility.
+
+=head1 SEE ALSO
+
+L<perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002-2007 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
+
+#
+#
+# Perldoc -- look up a piece of documentation in .pod format that
+# is embedded in the perl installation tree.
+#
+#~~~~~~
+#
+# See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
+#
+# Version 3.01: Sun Nov 10 21:38:09 MST 2002
+# Sean M. Burke <sburke@cpan.org>
+# Massive refactoring and code-tidying.
+# Now it's a module(-family)!
+# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
+# Added -T, -d, -o, -M, -w.
+# Added some improved MSWin funk.
+#
+#~~~~~~
+#
+# Version 2.05: Sat Oct 12 16:09:00 CEST 2002
+# Hugo van der Sanden <hv@crypt.org>
+# Made -U the default, based on patch from Simon Cozens
+# Version 2.04: Sun Aug 18 13:27:12 BST 2002
+# Randy W. Sims <RandyS@ThePierianSpring.org>
+# allow -n to enable nroff under Win32
+# Version 2.03: Sun Apr 23 16:56:34 BST 2000
+# Hugo van der Sanden <hv@crypt.org>
+# don't die when 'use blib' fails
+# Version 2.02: Mon Mar 13 18:03:04 MST 2000
+# Tom Christiansen <tchrist@perl.com>
+# Added -U insecurity option
+# Version 2.01: Sat Mar 11 15:22:33 MST 2000
+# Tom Christiansen <tchrist@perl.com>, querulously.
+# Security and correctness patches.
+# What a twisted bit of distasteful spaghetti code.
+# Version 2.0: ????
+#
+#~~~~~~
+#
+# Version 1.15: Tue Aug 24 01:50:20 EST 1999
+# Charles Wilson <cwilson@ece.gatech.edu>
+# changed /pod/ directory to /pods/ for cygwin
+# to support cygwin/win32
+# Version 1.14: Wed Jul 15 01:50:20 EST 1998
+# Robin Barker <rmb1@cise.npl.co.uk>
+# -strict, -w cleanups
+# Version 1.13: Fri Feb 27 16:20:50 EST 1997
+# Gurusamy Sarathy <gsar@activestate.com>
+# -doc tweaks for -F and -X options
+# Version 1.12: Sat Apr 12 22:41:09 EST 1997
+# Gurusamy Sarathy <gsar@activestate.com>
+# -various fixes for win32
+# Version 1.11: Tue Dec 26 09:54:33 EST 1995
+# Kenneth Albanowski <kjahds@kjahds.com>
+# -added Charles Bailey's further VMS patches, and -u switch
+# -added -t switch, with pod2text support
+#
+# Version 1.10: Thu Nov 9 07:23:47 EST 1995
+# Kenneth Albanowski <kjahds@kjahds.com>
+# -added VMS support
+# -added better error recognition (on no found pages, just exit. On
+# missing nroff/pod2man, just display raw pod.)
+# -added recursive/case-insensitive matching (thanks, Andreas). This
+# slows things down a bit, unfortunately. Give a precise name, and
+# it'll run faster.
+#
+# Version 1.01: Tue May 30 14:47:34 EDT 1995
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# -added pod documentation.
+# -added PATH searching.
+# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
+# and friends.
+#
+#~~~~~~~
+#
+# TODO:
+#
+# Cache the directories read during sloppy match
+# (To disk, or just in-memory?)
+#
+# Backport this to perl 5.005?
+#
+# Implement at least part of the "perlman" interface described
+# in Programming Perl 3e?
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/BaseTo.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/BaseTo.pm
new file mode 100755
index 00000000000..29a3b7d108e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/BaseTo.pm
@@ -0,0 +1,81 @@
+
+require 5;
+package Pod::Perldoc::BaseTo;
+use strict;
+use warnings;
+
+sub is_pageable { '' }
+sub write_with_binmode { 1 }
+
+sub output_extension { 'txt' } # override in subclass!
+
+# sub new { my $self = shift; ... }
+# sub parse_from_file( my($class, $in, $out) = ...; ... }
+
+#sub new { return bless {}, ref($_[0]) || $_[0] }
+
+sub _perldoc_elem {
+ my($self, $name) = splice @_,0,2;
+ if(@_) {
+ $self->{$name} = $_[0];
+ } else {
+ $self->{$name};
+ }
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::BaseTo - Base for Pod::Perldoc formatters
+
+=head1 SYNOPSIS
+
+ package Pod::Perldoc::ToMyFormat;
+
+ use base qw( Pod::Perldoc::BaseTo );
+ ...
+
+=head1 DESCRIPTION
+
+This package is meant as a base of Pod::Perldoc formatters,
+like L<Pod::Perldoc::ToText>, L<Pod::Perldoc::ToMan>, etc.
+
+It provides default implementations for the methods
+
+ is_pageable
+ write_with_binmode
+ output_extension
+ _perldoc_elem
+
+The concrete formatter must implement
+
+ new
+ parse_from_file
+
+=head1 SEE ALSO
+
+L<perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002-2007 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/GetOptsOO.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/GetOptsOO.pm
new file mode 100755
index 00000000000..fa83fb74ccf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/GetOptsOO.pm
@@ -0,0 +1,148 @@
+
+require 5;
+package Pod::Perldoc::GetOptsOO;
+use strict;
+
+# Rather like Getopt::Std's getopts
+# Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth)
+# Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT )
+# (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo")
+# Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth)
+# (Truth defaults to 1)
+# Otherwise we try calling $object->handle_unknown_option('n')
+# (and we increment the error count by the return value of it)
+# If there's no handle_unknown_option, then we just warn, and then increment
+# the error counter
+#
+# The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors,
+# otherwise it's false.
+#
+## sburke@cpan.org 2002-10-31
+
+BEGIN { # Make a DEBUG constant ASAP
+ *DEBUG = defined( &Pod::Perldoc::DEBUG )
+ ? \&Pod::Perldoc::DEBUG
+ : sub(){10};
+}
+
+
+sub getopts {
+ my($target, $args, $truth) = @_;
+
+ $args ||= \@ARGV;
+
+ $target->aside(
+ "Starting switch processing. Scanning arguments [@$args]\n"
+ ) if $target->can('aside');
+
+ return unless @$args;
+
+ $truth = 1 unless @_ > 2;
+
+ DEBUG > 3 and print " Truth is $truth\n";
+
+
+ my $error_count = 0;
+
+ while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) {
+ my($first,$rest) = ($1,$2);
+ if ($_ eq '--') { # early exit if "--"
+ shift @$args;
+ last;
+ }
+ my $method = "opt_${first}_with";
+ if( $target->can($method) ) { # it's argumental
+ if($rest eq '') { # like -f bar
+ shift @$args;
+ warn "Option $first needs a following argument!\n" unless @$args;
+ $rest = shift @$args;
+ } else { # like -fbar (== -f bar)
+ shift @$args;
+ }
+
+ DEBUG > 3 and print " $method => $rest\n";
+ $target->$method( $rest );
+
+ # Otherwise, it's not argumental...
+ } else {
+
+ if( $target->can( $method = "opt_$first" ) ) {
+ DEBUG > 3 and print " $method is true ($truth)\n";
+ $target->$method( $truth );
+
+ # Otherwise it's an unknown option...
+
+ } elsif( $target->can('handle_unknown_option') ) {
+ DEBUG > 3
+ and print " calling handle_unknown_option('$first')\n";
+
+ $error_count += (
+ $target->handle_unknown_option( $first ) || 0
+ );
+
+ } else {
+ ++$error_count;
+ warn "Unknown option: $first\n";
+ }
+
+ if($rest eq '') { # like -f
+ shift @$args
+ } else { # like -fbar (== -f -bar )
+ DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n";
+ $args->[0] = "-$rest";
+ }
+ }
+ }
+
+
+ $target->aside(
+ "Ending switch processing. Args are [@$args] with $error_count errors.\n"
+ ) if $target->can('aside');
+
+ $error_count == 0;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc
+
+=head1 SYNOPSIS
+
+ use Pod::Perldoc::GetOptsOO ();
+
+ Pod::Perldoc::GetOptsOO::getopts( $obj, \@args, $truth )
+ or die "wrong usage";
+
+
+=head1 DESCRIPTION
+
+Implements a customized option parser used for
+L<Pod::Perldoc>.
+
+=head1 SEE ALSO
+
+ Pod::Perldoc
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002-2007 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToChecker.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToChecker.pm
new file mode 100755
index 00000000000..10870109e60
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToChecker.pm
@@ -0,0 +1,75 @@
+
+require 5;
+package Pod::Perldoc::ToChecker;
+use strict;
+use warnings;
+use vars qw(@ISA);
+
+# Pick our superclass...
+#
+eval 'require Pod::Simple::Checker';
+if($@) {
+ require Pod::Checker;
+ @ISA = ('Pod::Checker');
+} else {
+ @ISA = ('Pod::Simple::Checker');
+}
+
+sub is_pageable { 1 }
+sub write_with_binmode { 0 }
+sub output_extension { 'txt' }
+
+sub if_zero_length {
+ my( $self, $file, $tmp, $tmpfd ) = @_;
+ print "No Pod errors in $file\n";
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::ToChecker - let Perldoc check Pod for errors
+
+=head1 SYNOPSIS
+
+ % perldoc -o checker SomeFile.pod
+ No Pod errors in SomeFile.pod
+ (or an error report)
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Simple::Checker as a "formatter" class (or if that is
+not available, then Pod::Checker), to check for errors in a given
+Pod file.
+
+This is actually a Pod::Simple::Checker (or Pod::Checker) subclass, and
+inherits all its options.
+
+=head1 SEE ALSO
+
+L<Pod::Simple::Checker>, L<Pod::Simple>, L<Pod::Checker>, L<Pod::Perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToMan.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToMan.pm
new file mode 100755
index 00000000000..09b0e817377
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToMan.pm
@@ -0,0 +1,190 @@
+
+require 5;
+package Pod::Perldoc::ToMan;
+use strict;
+use warnings;
+
+# This class is unlike ToText.pm et al, because we're NOT paging thru
+# the output in our particular format -- we make the output and
+# then we run nroff (or whatever) on it, and then page thru the
+# (plaintext) output of THAT!
+
+use base qw(Pod::Perldoc::BaseTo);
+sub is_pageable { 1 }
+sub write_with_binmode { 0 }
+sub output_extension { 'txt' }
+
+sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) }
+sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) }
+sub __bindir { shift->_perldoc_elem('__bindir' , @_) }
+sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) }
+sub __output_file { shift->_perldoc_elem('__output_file' , @_) }
+
+sub center { shift->_perldoc_elem('center' , @_) }
+sub date { shift->_perldoc_elem('date' , @_) }
+sub fixed { shift->_perldoc_elem('fixed' , @_) }
+sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) }
+sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) }
+sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) }
+sub quotes { shift->_perldoc_elem('quotes' , @_) }
+sub release { shift->_perldoc_elem('release' , @_) }
+sub section { shift->_perldoc_elem('section' , @_) }
+
+sub new { return bless {}, ref($_[0]) || $_[0] }
+
+use File::Spec::Functions qw(catfile);
+
+sub parse_from_file {
+ my $self = shift;
+ my($file, $outfh) = @_;
+
+ my $render = $self->{'__nroffer'} || die "no nroffer set!?";
+
+ # turn the switches into CLIs
+ my $switches = join ' ',
+ map qq{"--$_=$self->{$_}"},
+ grep !m/^_/s,
+ keys %$self
+ ;
+
+ my $pod2man =
+ catfile(
+ ($self->{'__bindir'} || die "no bindir set?!" ),
+ ($self->{'__pod2man'} || die "no pod2man set?!" ),
+ )
+ ;
+ unless(-e $pod2man) {
+ # This is rarely needed, I think.
+ $pod2man = $self->{'__pod2man'} || die "no pod2man set?!";
+ die "Can't find a pod2man?! (". $self->{'__pod2man'} .")\nAborting"
+ unless -e $pod2man;
+ }
+
+ my $command = "$pod2man $switches --lax $file | $render -man";
+ # no temp file, just a pipe!
+
+ # Thanks to Brendan O'Dea for contributing the following block
+ if(Pod::Perldoc::IS_Linux and -t STDOUT
+ and my ($cols) = `stty -a` =~ m/\bcolumns\s+(\d+)/
+ ) {
+ my $c = $cols * 39 / 40;
+ $cols = $c > $cols - 2 ? $c : $cols -2;
+ $command .= ' -rLL=' . (int $c) . 'n' if $cols > 80;
+ }
+
+ if(Pod::Perldoc::IS_Cygwin) {
+ $command .= ' -c';
+ }
+
+ # I hear persistent reports that adding a -c switch to $render
+ # solves many people's problems. But I also hear that some mans
+ # don't have a -c switch, so that unconditionally adding it here
+ # would presumably be a Bad Thing -- sburke@cpan.org
+
+ $command .= " | col -x" if Pod::Perldoc::IS_HPUX;
+
+ defined(&Pod::Perldoc::DEBUG)
+ and Pod::Perldoc::DEBUG()
+ and print "About to run $command\n";
+ ;
+
+ my $rslt = `$command`;
+
+ my $err;
+
+ if( $self->{'__filter_nroff'} ) {
+ defined(&Pod::Perldoc::DEBUG)
+ and &Pod::Perldoc::DEBUG()
+ and print "filter_nroff is set, so filtering...\n";
+ $rslt = $self->___Do_filter_nroff($rslt);
+ } else {
+ defined(&Pod::Perldoc::DEBUG)
+ and Pod::Perldoc::DEBUG()
+ and print "filter_nroff isn't set, so not filtering.\n";
+ }
+
+ if (($err = $?)) {
+ defined(&Pod::Perldoc::DEBUG)
+ and Pod::Perldoc::DEBUG()
+ and print "Nonzero exit ($?) while running $command.\n",
+ "Falling back to Pod::Perldoc::ToPod\n ",
+ ;
+ # A desperate fallthru:
+ require Pod::Perldoc::ToPod;
+ return Pod::Perldoc::ToPod->new->parse_from_file(@_);
+
+ } else {
+ print $outfh $rslt
+ or die "Can't print to $$self{__output_file}: $!";
+ }
+
+ return;
+}
+
+
+sub ___Do_filter_nroff {
+ my $self = shift;
+ my @data = split /\n{2,}/, shift;
+
+ shift @data while @data and $data[0] !~ /\S/; # Go to header
+ shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
+ pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
+ # 28/Jan/99 perl 5.005, patch 53 1
+ join "\n\n", @data;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::ToMan - let Perldoc render Pod as man pages
+
+=head1 SYNOPSIS
+
+ perldoc -o man Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Man and C<nroff> for reading Pod pages.
+
+The following options are supported: center, date, fixed, fixedbold,
+fixeditalic, fixedbolditalic, quotes, release, section
+
+(Those options are explained in L<Pod::Man>.)
+
+For example:
+
+ perldoc -o man -w center:Pod Some::Modulename
+
+=head1 CAVEAT
+
+This module may change to use a different pod-to-nroff formatter class
+in the future, and this may change what options are supported.
+
+=head1 SEE ALSO
+
+L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToNroff.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToNroff.pm
new file mode 100755
index 00000000000..991c1e3269c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToNroff.pm
@@ -0,0 +1,103 @@
+
+require 5;
+package Pod::Perldoc::ToNroff;
+use strict;
+use warnings;
+
+# This is unlike ToMan.pm in that it emits the raw nroff source!
+
+use base qw(Pod::Perldoc::BaseTo);
+
+sub is_pageable { 1 } # well, if you ask for it...
+sub write_with_binmode { 0 }
+sub output_extension { 'man' }
+
+use Pod::Man ();
+
+sub center { shift->_perldoc_elem('center' , @_) }
+sub date { shift->_perldoc_elem('date' , @_) }
+sub fixed { shift->_perldoc_elem('fixed' , @_) }
+sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) }
+sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) }
+sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) }
+sub quotes { shift->_perldoc_elem('quotes' , @_) }
+sub release { shift->_perldoc_elem('release' , @_) }
+sub section { shift->_perldoc_elem('section' , @_) }
+
+sub new { return bless {}, ref($_[0]) || $_[0] }
+
+sub parse_from_file {
+ my $self = shift;
+ my $file = $_[0];
+
+ my @options =
+ map {; $_, $self->{$_} }
+ grep !m/^_/s,
+ keys %$self
+ ;
+
+ defined(&Pod::Perldoc::DEBUG)
+ and Pod::Perldoc::DEBUG()
+ and print "About to call new Pod::Man ",
+ $Pod::Man::VERSION ? "(v$Pod::Man::VERSION) " : '',
+ "with options: ",
+ @options ? "[@options]" : "(nil)", "\n";
+ ;
+
+ Pod::Man->new(@options)->parse_from_file(@_);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::ToNroff - let Perldoc convert Pod to nroff
+
+=head1 SYNOPSIS
+
+ perldoc -o nroff -d something.3 Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Man as a formatter class.
+
+The following options are supported: center, date, fixed, fixedbold,
+fixeditalic, fixedbolditalic, quotes, release, section
+
+Those options are explained in L<Pod::Man>.
+
+For example:
+
+ perldoc -o nroff -w center:Pod -d something.3 Some::Modulename
+
+=head1 CAVEAT
+
+This module may change to use a different pod-to-nroff formatter class
+in the future, and this may change what options are supported.
+
+=head1 SEE ALSO
+
+L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToMan>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToPod.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToPod.pm
new file mode 100755
index 00000000000..c3173d43702
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToPod.pm
@@ -0,0 +1,93 @@
+
+# This class is just a hack to act as a "formatter" for
+# actually unformatted Pod.
+#
+# Note that this isn't the same as just passing thru whatever
+# we're given -- we pass thru only the pod source, and suppress
+# the Perl code (or whatever non-pod stuff is in the source file).
+
+
+require 5;
+package Pod::Perldoc::ToPod;
+use strict;
+use warnings;
+
+use base qw(Pod::Perldoc::BaseTo);
+sub is_pageable { 1 }
+sub write_with_binmode { 0 }
+sub output_extension { 'pod' }
+
+sub new { return bless {}, ref($_[0]) || $_[0] }
+
+sub parse_from_file {
+ my( $self, $in, $outfh ) = @_;
+
+ open(IN, "<", $in) or die "Can't read-open $in: $!\nAborting";
+
+ my $cut_mode = 1;
+
+ # A hack for finding things between =foo and =cut, inclusive
+ local $_;
+ while (<IN>) {
+ if( m/^=(\w+)/s ) {
+ if($cut_mode = ($1 eq 'cut')) {
+ print $outfh "\n=cut\n\n";
+ # Pass thru the =cut line with some harmless
+ # (and occasionally helpful) padding
+ }
+ }
+ next if $cut_mode;
+ print $outfh $_ or die "Can't print to $outfh: $!";
+ }
+
+ close IN or die "Can't close $in: $!";
+ return;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::ToPod - let Perldoc render Pod as ... Pod!
+
+=head1 SYNOPSIS
+
+ perldoc -opod Some::Modulename
+
+(That's currently the same as the following:)
+
+ perldoc -u Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to display Pod source as
+itself! Pretty Zen, huh?
+
+Currently this class works by just filtering out the non-Pod stuff from
+a given input file.
+
+=head1 SEE ALSO
+
+L<Pod::Perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToRtf.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToRtf.pm
new file mode 100755
index 00000000000..14d419fc313
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToRtf.pm
@@ -0,0 +1,88 @@
+
+require 5;
+package Pod::Perldoc::ToRtf;
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+use base qw( Pod::Simple::RTF );
+
+$VERSION # so that ->VERSION is happy
+# stop CPAN from seeing this
+ =
+$Pod::Simple::RTF::VERSION;
+
+
+sub is_pageable { 0 }
+sub write_with_binmode { 0 }
+sub output_extension { 'rtf' }
+
+sub page_for_perldoc {
+ my($self, $tempfile, $perldoc) = @_;
+ return unless $perldoc->IS_MSWin32;
+
+ my $rtf_pager = $ENV{'RTFREADER'} || 'write.exe';
+
+ $perldoc->aside( "About to launch <\"$rtf_pager\" \"$tempfile\">\n" );
+
+ return 1 if system( qq{"$rtf_pager"}, qq{"$tempfile"} ) == 0;
+ return 0;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::ToRtf - let Perldoc render Pod as RTF
+
+=head1 SYNOPSIS
+
+ perldoc -o rtf Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Simple::RTF as a formatter class.
+
+This is actually a Pod::Simple::RTF subclass, and inherits
+all its options.
+
+You have to have Pod::Simple::RTF installed (from the Pod::Simple dist),
+or this module won't work.
+
+If Perldoc is running under MSWin and uses this class as a formatter,
+the output will be opened with F<write.exe> or whatever program is
+specified in the environment variable C<RTFREADER>. For example, to
+specify that RTF files should be opened the same as they are when you
+double-click them, you would do C<set RTFREADER=start.exe> in your
+F<autoexec.bat>.
+
+Handy tip: put C<set PERLDOC=-ortf> in your F<autoexec.bat>
+and that will set this class as the default formatter to run when
+you do C<perldoc whatever>.
+
+=head1 SEE ALSO
+
+L<Pod::Simple::RTF>, L<Pod::Simple>, L<Pod::Perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToText.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToText.pm
new file mode 100755
index 00000000000..7d1784cd59a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToText.pm
@@ -0,0 +1,95 @@
+
+require 5;
+package Pod::Perldoc::ToText;
+use strict;
+use warnings;
+
+use base qw(Pod::Perldoc::BaseTo);
+
+sub is_pageable { 1 }
+sub write_with_binmode { 0 }
+sub output_extension { 'txt' }
+
+use Pod::Text ();
+
+sub alt { shift->_perldoc_elem('alt' , @_) }
+sub indent { shift->_perldoc_elem('indent' , @_) }
+sub loose { shift->_perldoc_elem('loose' , @_) }
+sub quotes { shift->_perldoc_elem('quotes' , @_) }
+sub sentence { shift->_perldoc_elem('sentence', @_) }
+sub width { shift->_perldoc_elem('width' , @_) }
+
+sub new { return bless {}, ref($_[0]) || $_[0] }
+
+sub parse_from_file {
+ my $self = shift;
+
+ my @options =
+ map {; $_, $self->{$_} }
+ grep !m/^_/s,
+ keys %$self
+ ;
+
+ defined(&Pod::Perldoc::DEBUG)
+ and Pod::Perldoc::DEBUG()
+ and print "About to call new Pod::Text ",
+ $Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '',
+ "with options: ",
+ @options ? "[@options]" : "(nil)", "\n";
+ ;
+
+ Pod::Text->new(@options)->parse_from_file(@_);
+}
+
+1;
+
+=head1 NAME
+
+Pod::Perldoc::ToText - let Perldoc render Pod as plaintext
+
+=head1 SYNOPSIS
+
+ perldoc -o text Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Text as a formatter class.
+
+It supports the following options, which are explained in
+L<Pod::Text>: alt, indent, loose, quotes, sentence, width
+
+For example:
+
+ perldoc -o text -w indent:5 Some::Modulename
+
+=head1 CAVEAT
+
+This module may change to use a different text formatter class in the
+future, and this may change what options are supported.
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToTk.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToTk.pm
new file mode 100755
index 00000000000..1562ec8bb3f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToTk.pm
@@ -0,0 +1,132 @@
+
+require 5;
+package Pod::Perldoc::ToTk;
+use strict;
+use warnings;
+
+use base qw(Pod::Perldoc::BaseTo);
+
+sub is_pageable { 1 }
+sub write_with_binmode { 0 }
+sub output_extension { 'txt' } # doesn't matter
+sub if_zero_length { } # because it will be 0-length!
+sub new { return bless {}, ref($_[0]) || $_[0] }
+
+# TODO: document these and their meanings...
+sub tree { shift->_perldoc_elem('tree' , @_) }
+sub tk_opt { shift->_perldoc_elem('tk_opt' , @_) }
+sub forky { shift->_perldoc_elem('forky' , @_) }
+
+use Pod::Perldoc ();
+use File::Spec::Functions qw(catfile);
+
+use Tk;
+die join '', __PACKAGE__, " doesn't work nice with Tk.pm verison $Tk::VERSION"
+ if $Tk::VERSION eq '800.003';
+
+BEGIN { eval { require Tk::FcyEntry; }; };
+use Tk::Pod;
+
+# The following was adapted from "tkpod" in the Tk-Pod dist.
+
+sub parse_from_file {
+
+ my($self, $Input_File) = @_;
+ if($self->{'forky'}) {
+ return if fork; # i.e., parent process returns
+ }
+
+ $Input_File =~ s{\\}{/}g
+ if Pod::Perldoc::IS_MSWin32 or Pod::Perldoc::IS_Dos
+ # and maybe OS/2
+ ;
+
+ my($tk_opt, $tree);
+ $tree = $self->{'tree' };
+ $tk_opt = $self->{'tk_opt'};
+
+ #require Tk::ErrorDialog;
+
+ # Add 'Tk' subdirectories to search path so, e.g.,
+ # 'Scrolled' will find doc in 'Tk/Scrolled'
+
+ if( $tk_opt ) {
+ push @INC, grep -d $_, map catfile($_,'Tk'), @INC;
+ }
+
+ my $mw = MainWindow->new();
+ #eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug';
+ $mw->withdraw;
+
+ # CDE use Font Settings if available
+ my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width
+ my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional
+ if (defined($ufont) and defined($sfont)) {
+ foreach ($ufont, $sfont) { s/:$//; };
+ $mw->optionAdd('*Font', $sfont);
+ $mw->optionAdd('*Entry.Font', $ufont);
+ $mw->optionAdd('*Text.Font', $ufont);
+ }
+
+ $mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0);
+
+ $mw->Pod(
+ '-file' => $Input_File,
+ (($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ())
+ )->focusNext;
+
+ # xxx dirty but it works. A simple $mw->destroy if $mw->children
+ # does not work because Tk::ErrorDialogs could be created.
+ # (they are withdrawn after Ok instead of destory'ed I guess)
+
+ if ($mw->children) {
+ $mw->repeat(1000, sub {
+ # ErrorDialog is withdrawn not deleted :-(
+ foreach ($mw->children) {
+ return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod')
+ }
+ $mw->destroy;
+ });
+ } else {
+ $mw->destroy;
+ }
+ #$mw->WidgetDump;
+ MainLoop();
+
+ exit if $self->{'forky'}; # we were the child! so exit now!
+ return;
+}
+
+1;
+__END__
+
+
+=head1 NAME
+
+Pod::Perldoc::ToTk - let Perldoc use Tk::Pod to render Pod
+
+=head1 SYNOPSIS
+
+ perldoc -o tk Some::Modulename &
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Tk::Pod as a formatter class.
+
+You have to have installed Tk::Pod first, or this class won't load.
+
+=head1 SEE ALSO
+
+L<Tk::Pod>, L<Pod::Perldoc>
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke C<sburke@cpan.org>, with significant portions copied from
+F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToXml.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToXml.pm
new file mode 100755
index 00000000000..439e736c20e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Perldoc/ToXml.pm
@@ -0,0 +1,66 @@
+
+require 5;
+package Pod::Perldoc::ToXml;
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+use base qw( Pod::Simple::XMLOutStream );
+
+$VERSION # so that ->VERSION is happy
+# stop CPAN from seeing this
+ =
+$Pod::Simple::XMLOutStream::VERSION;
+
+
+sub is_pageable { 0 }
+sub write_with_binmode { 0 }
+sub output_extension { 'xml' }
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Perldoc::ToXml - let Perldoc render Pod as XML
+
+=head1 SYNOPSIS
+
+ perldoc -o xml -d out.xml Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Simple::XMLOutStream as a formatter class.
+
+This is actually a Pod::Simple::XMLOutStream subclass, and inherits
+all its options.
+
+You have to have installed Pod::Simple::XMLOutStream (from the Pod::Simple
+dist), or this class won't work.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple::XMLOutStream>, L<Pod::Simple>, L<Pod::Perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributions from:
+Sean M. Burke <sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/PlainText.pm b/Master/tlpkg/tlperl.straw/lib/Pod/PlainText.pm
new file mode 100755
index 00000000000..0dce1799b2b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/PlainText.pm
@@ -0,0 +1,738 @@
+# Pod::PlainText -- Convert POD data to formatted ASCII text.
+# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $
+#
+# Copyright 1999-2000 by Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module is intended to be a replacement for Pod::Text, and attempts to
+# match its output except for some specific circumstances where other
+# decisions seemed to produce better output. It uses Pod::Parser and is
+# designed to be very easy to subclass.
+
+############################################################################
+# Modules and declarations
+############################################################################
+
+package Pod::PlainText;
+use strict;
+
+require 5.005;
+
+use Carp qw(carp croak);
+use Pod::Select ();
+
+use vars qw(@ISA %ESCAPES $VERSION);
+
+# We inherit from Pod::Select instead of Pod::Parser so that we can be used
+# by Pod::Usage.
+@ISA = qw(Pod::Select);
+
+$VERSION = '2.04';
+
+BEGIN {
+ if ($] < 5.006) {
+ require Symbol;
+ import Symbol;
+ }
+}
+
+############################################################################
+# Table of supported E<> escapes
+############################################################################
+
+# This table is taken near verbatim from Pod::PlainText in Pod::Parser,
+# which got it near verbatim from the original Pod::Text. It is therefore
+# credited to Tom Christiansen, and I'm glad I didn't have to write it. :)
+%ESCAPES = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\xC1", # capital A, acute accent
+ "aacute" => "\xE1", # small a, acute accent
+ "Acirc" => "\xC2", # capital A, circumflex accent
+ "acirc" => "\xE2", # small a, circumflex accent
+ "AElig" => "\xC6", # capital AE diphthong (ligature)
+ "aelig" => "\xE6", # small ae diphthong (ligature)
+ "Agrave" => "\xC0", # capital A, grave accent
+ "agrave" => "\xE0", # small a, grave accent
+ "Aring" => "\xC5", # capital A, ring
+ "aring" => "\xE5", # small a, ring
+ "Atilde" => "\xC3", # capital A, tilde
+ "atilde" => "\xE3", # small a, tilde
+ "Auml" => "\xC4", # capital A, dieresis or umlaut mark
+ "auml" => "\xE4", # small a, dieresis or umlaut mark
+ "Ccedil" => "\xC7", # capital C, cedilla
+ "ccedil" => "\xE7", # small c, cedilla
+ "Eacute" => "\xC9", # capital E, acute accent
+ "eacute" => "\xE9", # small e, acute accent
+ "Ecirc" => "\xCA", # capital E, circumflex accent
+ "ecirc" => "\xEA", # small e, circumflex accent
+ "Egrave" => "\xC8", # capital E, grave accent
+ "egrave" => "\xE8", # small e, grave accent
+ "ETH" => "\xD0", # capital Eth, Icelandic
+ "eth" => "\xF0", # small eth, Icelandic
+ "Euml" => "\xCB", # capital E, dieresis or umlaut mark
+ "euml" => "\xEB", # small e, dieresis or umlaut mark
+ "Iacute" => "\xCD", # capital I, acute accent
+ "iacute" => "\xED", # small i, acute accent
+ "Icirc" => "\xCE", # capital I, circumflex accent
+ "icirc" => "\xEE", # small i, circumflex accent
+ "Igrave" => "\xCD", # capital I, grave accent
+ "igrave" => "\xED", # small i, grave accent
+ "Iuml" => "\xCF", # capital I, dieresis or umlaut mark
+ "iuml" => "\xEF", # small i, dieresis or umlaut mark
+ "Ntilde" => "\xD1", # capital N, tilde
+ "ntilde" => "\xF1", # small n, tilde
+ "Oacute" => "\xD3", # capital O, acute accent
+ "oacute" => "\xF3", # small o, acute accent
+ "Ocirc" => "\xD4", # capital O, circumflex accent
+ "ocirc" => "\xF4", # small o, circumflex accent
+ "Ograve" => "\xD2", # capital O, grave accent
+ "ograve" => "\xF2", # small o, grave accent
+ "Oslash" => "\xD8", # capital O, slash
+ "oslash" => "\xF8", # small o, slash
+ "Otilde" => "\xD5", # capital O, tilde
+ "otilde" => "\xF5", # small o, tilde
+ "Ouml" => "\xD6", # capital O, dieresis or umlaut mark
+ "ouml" => "\xF6", # small o, dieresis or umlaut mark
+ "szlig" => "\xDF", # small sharp s, German (sz ligature)
+ "THORN" => "\xDE", # capital THORN, Icelandic
+ "thorn" => "\xFE", # small thorn, Icelandic
+ "Uacute" => "\xDA", # capital U, acute accent
+ "uacute" => "\xFA", # small u, acute accent
+ "Ucirc" => "\xDB", # capital U, circumflex accent
+ "ucirc" => "\xFB", # small u, circumflex accent
+ "Ugrave" => "\xD9", # capital U, grave accent
+ "ugrave" => "\xF9", # small u, grave accent
+ "Uuml" => "\xDC", # capital U, dieresis or umlaut mark
+ "uuml" => "\xFC", # small u, dieresis or umlaut mark
+ "Yacute" => "\xDD", # capital Y, acute accent
+ "yacute" => "\xFD", # small y, acute accent
+ "yuml" => "\xFF", # small y, dieresis or umlaut mark
+
+ "lchevron" => "\xAB", # left chevron (double less than)
+ "rchevron" => "\xBB", # right chevron (double greater than)
+);
+
+
+############################################################################
+# Initialization
+############################################################################
+
+# Initialize the object. Must be sure to call our parent initializer.
+sub initialize {
+ my $self = shift;
+
+ $$self{alt} = 0 unless defined $$self{alt};
+ $$self{indent} = 4 unless defined $$self{indent};
+ $$self{loose} = 0 unless defined $$self{loose};
+ $$self{sentence} = 0 unless defined $$self{sentence};
+ $$self{width} = 76 unless defined $$self{width};
+
+ $$self{INDENTS} = []; # Stack of indentations.
+ $$self{MARGIN} = $$self{indent}; # Current left margin in spaces.
+
+ return $self->SUPER::initialize;
+}
+
+
+############################################################################
+# Core overrides
+############################################################################
+
+# Called for each command paragraph. Gets the command, the associated
+# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
+# the command to a method named the same as the command. =cut is handled
+# internally by Pod::Parser.
+sub command {
+ my $self = shift;
+ my $command = shift;
+ return if $command eq 'pod';
+ return if ($$self{EXCLUDE} && $command ne 'end');
+ if (defined $$self{ITEM}) {
+ $self->item ("\n");
+ local $_ = "\n";
+ $self->output($_) if($command eq 'back');
+ }
+ $command = 'cmd_' . $command;
+ return $self->$command (@_);
+}
+
+# Called for a verbatim paragraph. Gets the paragraph, the line number, and
+# a Pod::Paragraph object. Just output it verbatim, but with tabs converted
+# to spaces.
+sub verbatim {
+ my $self = shift;
+ return if $$self{EXCLUDE};
+ $self->item if defined $$self{ITEM};
+ local $_ = shift;
+ return if /^\s*$/;
+ s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme;
+ return $self->output($_);
+}
+
+# Called for a regular text block. Gets the paragraph, the line number, and
+# a Pod::Paragraph object. Perform interpolation and output the results.
+sub textblock {
+ my $self = shift;
+ return if $$self{EXCLUDE};
+ if($$self{VERBATIM}) {
+ $self->output($_[0]);
+ return;
+ }
+ local $_ = shift;
+ my $line = shift;
+
+ # Perform a little magic to collapse multiple L<> references. This is
+ # here mostly for backwards-compatibility. We'll just rewrite the whole
+ # thing into actual text at this part, bypassing the whole internal
+ # sequence parsing thing.
+ s{
+ (
+ L< # A link of the form L</something>.
+ /
+ (
+ [:\w]+ # The item has to be a simple word...
+ (\(\))? # ...or simple function.
+ )
+ >
+ (
+ ,?\s+(and\s+)? # Allow lots of them, conjuncted.
+ L<
+ /
+ (
+ [:\w]+
+ (\(\))?
+ )
+ >
+ )+
+ )
+ } {
+ local $_ = $1;
+ s%L</([^>]+)>%$1%g;
+ my @items = split /(?:,?\s+(?:and\s+)?)/;
+ my $string = "the ";
+ my $i;
+ for ($i = 0; $i < @items; $i++) {
+ $string .= $items[$i];
+ $string .= ", " if @items > 2 && $i != $#items;
+ $string .= " and " if ($i == $#items - 1);
+ }
+ $string .= " entries elsewhere in this document";
+ $string;
+ }gex;
+
+ # Now actually interpolate and output the paragraph.
+ $_ = $self->interpolate ($_, $line);
+ s/\s*$/\n/s;
+ if (defined $$self{ITEM}) {
+ $self->item ($_ . "\n");
+ } else {
+ $self->output ($self->reformat ($_ . "\n"));
+ }
+}
+
+# Called for an interior sequence. Gets the command, argument, and a
+# Pod::InteriorSequence object and is expected to return the resulting text.
+# Calls code, bold, italic, file, and link to handle those types of
+# sequences, and handles S<>, E<>, X<>, and Z<> directly.
+sub interior_sequence {
+ my $self = shift;
+ my $command = shift;
+ local $_ = shift;
+ return '' if ($command eq 'X' || $command eq 'Z');
+
+ # Expand escapes into the actual character now, carping if invalid.
+ if ($command eq 'E') {
+ return $ESCAPES{$_} if defined $ESCAPES{$_};
+ carp "Unknown escape: E<$_>";
+ return "E<$_>";
+ }
+
+ # For all the other sequences, empty content produces no output.
+ return if $_ eq '';
+
+ # For S<>, compress all internal whitespace and then map spaces to \01.
+ # When we output the text, we'll map this back.
+ if ($command eq 'S') {
+ s/\s{2,}/ /g;
+ tr/ /\01/;
+ return $_;
+ }
+
+ # Anything else needs to get dispatched to another method.
+ if ($command eq 'B') { return $self->seq_b ($_) }
+ elsif ($command eq 'C') { return $self->seq_c ($_) }
+ elsif ($command eq 'F') { return $self->seq_f ($_) }
+ elsif ($command eq 'I') { return $self->seq_i ($_) }
+ elsif ($command eq 'L') { return $self->seq_l ($_) }
+ else { carp "Unknown sequence $command<$_>" }
+}
+
+# Called for each paragraph that's actually part of the POD. We take
+# advantage of this opportunity to untabify the input.
+sub preprocess_paragraph {
+ my $self = shift;
+ local $_ = shift;
+ 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
+ return $_;
+}
+
+
+############################################################################
+# Command paragraphs
+############################################################################
+
+# All command paragraphs take the paragraph and the line number.
+
+# First level heading.
+sub cmd_head1 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//s;
+ $_ = $self->interpolate ($_, shift);
+ if ($$self{alt}) {
+ $self->output ("\n==== $_ ====\n\n");
+ } else {
+ $_ .= "\n" if $$self{loose};
+ $self->output ($_ . "\n");
+ }
+}
+
+# Second level heading.
+sub cmd_head2 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//s;
+ $_ = $self->interpolate ($_, shift);
+ if ($$self{alt}) {
+ $self->output ("\n== $_ ==\n\n");
+ } else {
+ $_ .= "\n" if $$self{loose};
+ $self->output (' ' x ($$self{indent} / 2) . $_ . "\n");
+ }
+}
+
+# third level heading - not strictly perlpodspec compliant
+sub cmd_head3 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//s;
+ $_ = $self->interpolate ($_, shift);
+ if ($$self{alt}) {
+ $self->output ("\n= $_ =\n");
+ } else {
+ $_ .= "\n" if $$self{loose};
+ $self->output (' ' x ($$self{indent}) . $_ . "\n");
+ }
+}
+
+# fourth level heading - not strictly perlpodspec compliant
+# just like head3
+*cmd_head4 = \&cmd_head3;
+
+# Start a list.
+sub cmd_over {
+ my $self = shift;
+ local $_ = shift;
+ unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
+ push (@{ $$self{INDENTS} }, $$self{MARGIN});
+ $$self{MARGIN} += ($_ + 0);
+}
+
+# End a list.
+sub cmd_back {
+ my $self = shift;
+ $$self{MARGIN} = pop @{ $$self{INDENTS} };
+ unless (defined $$self{MARGIN}) {
+ carp 'Unmatched =back';
+ $$self{MARGIN} = $$self{indent};
+ }
+}
+
+# An individual list item.
+sub cmd_item {
+ my $self = shift;
+ if (defined $$self{ITEM}) { $self->item }
+ local $_ = shift;
+ s/\s+$//s;
+ $$self{ITEM} = $self->interpolate ($_);
+}
+
+# Begin a block for a particular translator. Setting VERBATIM triggers
+# special handling in textblock().
+sub cmd_begin {
+ my $self = shift;
+ local $_ = shift;
+ my ($kind) = /^(\S+)/ or return;
+ if ($kind eq 'text') {
+ $$self{VERBATIM} = 1;
+ } else {
+ $$self{EXCLUDE} = 1;
+ }
+}
+
+# End a block for a particular translator. We assume that all =begin/=end
+# pairs are properly closed.
+sub cmd_end {
+ my $self = shift;
+ $$self{EXCLUDE} = 0;
+ $$self{VERBATIM} = 0;
+}
+
+# One paragraph for a particular translator. Ignore it unless it's intended
+# for text, in which case we treat it as a verbatim text block.
+sub cmd_for {
+ my $self = shift;
+ local $_ = shift;
+ my $line = shift;
+ return unless s/^text\b[ \t]*\n?//;
+ $self->verbatim ($_, $line);
+}
+
+
+############################################################################
+# Interior sequences
+############################################################################
+
+# The simple formatting ones. These are here mostly so that subclasses can
+# override them and do more complicated things.
+sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }
+sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" }
+sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
+sub seq_i { return '*' . $_[1] . '*' }
+
+# The complicated one. Handle links. Since this is plain text, we can't
+# actually make any real links, so this is all to figure out what text we
+# print out.
+sub seq_l {
+ my $self = shift;
+ local $_ = shift;
+
+ # Smash whitespace in case we were split across multiple lines.
+ s/\s+/ /g;
+
+ # If we were given any explicit text, just output it.
+ if (/^([^|]+)\|/) { return $1 }
+
+ # Okay, leading and trailing whitespace isn't important; get rid of it.
+ s/^\s+//;
+ s/\s+$//;
+
+ # Default to using the whole content of the link entry as a section
+ # name. Note that L<manpage/> forces a manpage interpretation, as does
+ # something looking like L<manpage(section)>. The latter is an
+ # enhancement over the original Pod::Text.
+ my ($manpage, $section) = ('', $_);
+ if (/^(?:https?|ftp|news):/) {
+ # a URL
+ return $_;
+ } elsif (/^"\s*(.*?)\s*"$/) {
+ $section = '"' . $1 . '"';
+ } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) {
+ ($manpage, $section) = ($_, '');
+ } elsif (m{/}) {
+ ($manpage, $section) = split (/\s*\/\s*/, $_, 2);
+ }
+
+ my $text = '';
+ # Now build the actual output text.
+ if (!length $section) {
+ $text = "the $manpage manpage" if length $manpage;
+ } elsif ($section =~ /^[:\w]+(?:\(\))?/) {
+ $text .= 'the ' . $section . ' entry';
+ $text .= (length $manpage) ? " in the $manpage manpage"
+ : ' elsewhere in this document';
+ } else {
+ $section =~ s/^\"\s*//;
+ $section =~ s/\s*\"$//;
+ $text .= 'the section on "' . $section . '"';
+ $text .= " in the $manpage manpage" if length $manpage;
+ }
+ return $text;
+}
+
+
+############################################################################
+# List handling
+############################################################################
+
+# This method is called whenever an =item command is complete (in other
+# words, we've seen its associated paragraph or know for certain that it
+# doesn't have one). It gets the paragraph associated with the item as an
+# argument. If that argument is empty, just output the item tag; if it
+# contains a newline, output the item tag followed by the newline.
+# Otherwise, see if there's enough room for us to output the item tag in the
+# margin of the text or if we have to put it on a separate line.
+sub item {
+ my $self = shift;
+ local $_ = shift;
+ my $tag = $$self{ITEM};
+ unless (defined $tag) {
+ carp 'item called without tag';
+ return;
+ }
+ undef $$self{ITEM};
+ my $indent = $$self{INDENTS}[-1];
+ unless (defined $indent) { $indent = $$self{indent} }
+ my $space = ' ' x $indent;
+ $space =~ s/^ /:/ if $$self{alt};
+ if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) {
+ my $margin = $$self{MARGIN};
+ $$self{MARGIN} = $indent;
+ my $output = $self->reformat ($tag);
+ $output =~ s/\n*$/\n/;
+ $self->output ($output);
+ $$self{MARGIN} = $margin;
+ $self->output ($self->reformat ($_)) if /\S/;
+ } else {
+ $_ = $self->reformat ($_);
+ s/^ /:/ if ($$self{alt} && $indent > 0);
+ my $tagspace = ' ' x length $tag;
+ s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item';
+ $self->output ($_);
+ }
+}
+
+
+############################################################################
+# Output formatting
+############################################################################
+
+# Wrap a line, indenting by the current left margin. We can't use
+# Text::Wrap because it plays games with tabs. We can't use formline, even
+# though we'd really like to, because it screws up non-printing characters.
+# So we have to do the wrapping ourselves.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{width} - $$self{MARGIN};
+ while (length > $width) {
+ if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ return $output;
+}
+
+# Reformat a paragraph of text for the current margin. Takes the text to
+# reformat and returns the formatted text.
+sub reformat {
+ my $self = shift;
+ local $_ = shift;
+
+ # If we're trying to preserve two spaces after sentences, do some
+ # munging to support that. Otherwise, smash all repeated whitespace.
+ if ($$self{sentence}) {
+ s/ +$//mg;
+ s/\.\n/. \n/g;
+ s/\n/ /g;
+ s/ +/ /g;
+ } else {
+ s/\s+/ /g;
+ }
+ return $self->wrap($_);
+}
+
+# Output text to the output device.
+sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
+
+
+############################################################################
+# Backwards compatibility
+############################################################################
+
+# The old Pod::Text module did everything in a pod2text() function. This
+# tries to provide the same interface for legacy applications.
+sub pod2text {
+ my @args;
+
+ # This is really ugly; I hate doing option parsing in the middle of a
+ # module. But the old Pod::Text module supported passing flags to its
+ # entry function, so handle -a and -<number>.
+ while ($_[0] =~ /^-/) {
+ my $flag = shift;
+ if ($flag eq '-a') { push (@args, alt => 1) }
+ elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
+ else {
+ unshift (@_, $flag);
+ last;
+ }
+ }
+
+ # Now that we know what arguments we're using, create the parser.
+ my $parser = Pod::PlainText->new (@args);
+
+ # If two arguments were given, the second argument is going to be a file
+ # handle. That means we want to call parse_from_filehandle(), which
+ # means we need to turn the first argument into a file handle. Magic
+ # open will handle the <&STDIN case automagically.
+ if (defined $_[1]) {
+ my $infh;
+ if ($] < 5.006) {
+ $infh = gensym();
+ }
+ unless (open ($infh, $_[0])) {
+ croak ("Can't open $_[0] for reading: $!\n");
+ }
+ $_[0] = $infh;
+ return $parser->parse_from_filehandle (@_);
+ } else {
+ return $parser->parse_from_file (@_);
+ }
+}
+
+
+############################################################################
+# Module return value and documentation
+############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::PlainText - Convert POD data to formatted ASCII text
+
+=head1 SYNOPSIS
+
+ use Pod::PlainText;
+ my $parser = Pod::PlainText->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::PlainText is a module that can convert documentation in the POD format (the
+preferred language for documenting Perl) into formatted ASCII. It uses no
+special formatting controls or codes whatsoever, and its output is therefore
+suitable for nearly any device.
+
+As a derived class from Pod::Parser, Pod::PlainText supports the same methods and
+interfaces. See L<Pod::Parser> for all the details; briefly, one creates a
+new parser with C<Pod::PlainText-E<gt>new()> and then calls either
+parse_from_filehandle() or parse_from_file().
+
+new() can take options, in the form of key/value pairs, that control the
+behavior of the parser. The currently recognized options are:
+
+=over 4
+
+=item alt
+
+If set to a true value, selects an alternate output format that, among other
+things, uses a different heading style and marks C<=item> entries with a
+colon in the left margin. Defaults to false.
+
+=item indent
+
+The number of spaces to indent regular text, and the default indentation for
+C<=over> blocks. Defaults to 4.
+
+=item loose
+
+If set to a true value, a blank line is printed after a C<=headN> headings.
+If set to false (the default), no blank line is printed after C<=headN>.
+This is the default because it's the expected formatting for manual pages;
+if you're formatting arbitrary text documents, setting this to true may
+result in more pleasing output.
+
+=item sentence
+
+If set to a true value, Pod::PlainText will assume that each sentence ends in two
+spaces, and will try to preserve that spacing. If set to false, all
+consecutive whitespace in non-verbatim paragraphs is compressed into a
+single space. Defaults to true.
+
+=item width
+
+The column at which to wrap text on the right-hand side. Defaults to 76.
+
+=back
+
+The standard Pod::Parser method parse_from_filehandle() takes up to two
+arguments, the first being the file handle to read POD from and the second
+being the file handle to write the formatted output to. The first defaults
+to STDIN if not given, and the second defaults to STDOUT. The method
+parse_from_file() is almost identical, except that its two arguments are the
+input and output disk files instead. See L<Pod::Parser> for the specific
+details.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bizarre space in item
+
+(W) Something has gone wrong in internal C<=item> processing. This message
+indicates a bug in Pod::PlainText; you should never see it.
+
+=item Can't open %s for reading: %s
+
+(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface
+and the input file it was given could not be opened.
+
+=item Unknown escape: %s
+
+(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't
+know about.
+
+=item Unknown sequence: %s
+
+(W) The POD source contained a non-standard internal sequence (something of
+the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about.
+
+=item Unmatched =back
+
+(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an
+C<=over> command.
+
+=back
+
+=head1 RESTRICTIONS
+
+Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on
+output, due to an internal implementation detail.
+
+=head1 NOTES
+
+This is a replacement for an earlier Pod::Text module written by Tom
+Christiansen. It has a revamped interface, since it now uses Pod::Parser,
+but an interface roughly compatible with the old Pod::Text::pod2text()
+function is still available. Please change to the new calling convention,
+though.
+
+The original Pod::Text contained code to do formatting via termcap
+sequences, although it wasn't turned on by default and it was problematic to
+get it to work at all. This rewrite doesn't even try to do that, but a
+subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>.
+
+=head1 SEE ALSO
+
+L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>,
+pod2text(1)
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the
+original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and
+its conversion to Pod::Parser by Brad Appleton
+E<lt>bradapp@enteract.comE<gt>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Plainer.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Plainer.pm
new file mode 100755
index 00000000000..d274cbd2dfd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Plainer.pm
@@ -0,0 +1,100 @@
+package Pod::Plainer;
+use 5.006;
+use strict;
+use warnings;
+use if $] >= 5.011, 'deprecate';
+use Pod::Parser;
+our @ISA = qw(Pod::Parser);
+our $VERSION = '1.01';
+
+our %E = qw( < lt > gt );
+
+sub escape_ltgt {
+ (undef, my $text) = @_;
+ $text =~ s/([<>])/E<$E{$1}>/g;
+ $text
+}
+
+sub simple_delimiters {
+ (undef, my $seq) = @_;
+ $seq -> left_delimiter( '<' );
+ $seq -> right_delimiter( '>' );
+ $seq;
+}
+
+sub textblock {
+ my($parser,$text,$line) = @_;
+ print {$parser->output_handle()}
+ $parser->parse_text(
+ { -expand_text => q(escape_ltgt),
+ -expand_seq => q(simple_delimiters) },
+ $text, $line ) -> raw_text();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Plainer - Perl extension for converting Pod to old-style Pod.
+
+=head1 SYNOPSIS
+
+ use Pod::Plainer;
+
+ my $parser = Pod::Plainer -> new ();
+ $parser -> parse_from_filehandle(\*STDIN);
+
+=head1 DESCRIPTION
+
+Pod::Plainer uses Pod::Parser which takes Pod with the (new)
+'CE<lt>E<lt> .. E<gt>E<gt>' constructs
+and returns the old(er) style with just 'CE<lt>E<gt>';
+'<' and '>' are replaced by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'.
+
+This can be used to pre-process Pod before using tools which do not
+recognise the new style Pods.
+
+=head2 METHODS
+
+=over
+
+=item escape_ltgt
+
+Replace '<' and '>' by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'.
+
+=item simple_delimiters
+
+Replace delimiters by 'E<lt>' and 'E<gt>'.
+
+=item textblock
+
+Redefine C<textblock> from L<Pod::Parser> to use C<escape_ltgt>
+and C<simple_delimiters>.
+
+=back
+
+=head2 EXPORT
+
+None by default.
+
+=head1 AUTHOR
+
+Robin Barker, rmb1@npl.co.uk
+
+=head1 SEE ALSO
+
+See L<Pod::Parser>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009 by Robin Barker
+
+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.1 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+$Id: Plainer.pm 250 2009-09-20 18:02:00Z rmb1 $
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Select.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Select.pm
new file mode 100755
index 00000000000..4724cb79cf9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Select.pm
@@ -0,0 +1,746 @@
+#############################################################################
+# Pod/Select.pm -- function to select portions of POD docs
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Select;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections);
+$VERSION = '1.36'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+#############################################################################
+
+=head1 NAME
+
+Pod::Select, podselect() - extract selected sections of POD from input
+
+=head1 SYNOPSIS
+
+ use Pod::Select;
+
+ ## Select all the POD sections for each file in @filelist
+ ## and print the result on standard output.
+ podselect(@filelist);
+
+ ## Same as above, but write to tmp.out
+ podselect({-output => "tmp.out"}, @filelist):
+
+ ## Select from the given filelist, only those POD sections that are
+ ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
+ podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist):
+
+ ## Select the "DESCRIPTION" section of the PODs from STDIN and write
+ ## the result to STDERR.
+ podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN);
+
+or
+
+ use Pod::Select;
+
+ ## Create a parser object for selecting POD sections from the input
+ $parser = new Pod::Select();
+
+ ## Select all the POD sections for each file in @filelist
+ ## and print the result to tmp.out.
+ $parser->parse_from_file("<&STDIN", "tmp.out");
+
+ ## Select from the given filelist, only those POD sections that are
+ ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
+ $parser->select("NAME|SYNOPSIS", "OPTIONS");
+ for (@filelist) { $parser->parse_from_file($_); }
+
+ ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from
+ ## STDIN and write the result to STDERR.
+ $parser->select("DESCRIPTION");
+ $parser->add_selection("SEE ALSO");
+ $parser->parse_from_filehandle(\*STDIN, \*STDERR);
+
+=head1 REQUIRES
+
+perl5.005, Pod::Parser, Exporter, Carp
+
+=head1 EXPORTS
+
+podselect()
+
+=head1 DESCRIPTION
+
+B<podselect()> is a function which will extract specified sections of
+pod documentation from an input stream. This ability is provided by the
+B<Pod::Select> module which is a subclass of B<Pod::Parser>.
+B<Pod::Select> provides a method named B<select()> to specify the set of
+POD sections to select for processing/printing. B<podselect()> merely
+creates a B<Pod::Select> object and then invokes the B<podselect()>
+followed by B<parse_from_file()>.
+
+=head1 SECTION SPECIFICATIONS
+
+B<podselect()> and B<Pod::Select::select()> may be given one or more
+"section specifications" to restrict the text processed to only the
+desired set of sections and their corresponding subsections. A section
+specification is a string containing one or more Perl-style regular
+expressions separated by forward slashes ("/"). If you need to use a
+forward slash literally within a section title you can escape it with a
+backslash ("\/").
+
+The formal syntax of a section specification is:
+
+=over 4
+
+=item *
+
+I<head1-title-regex>/I<head2-title-regex>/...
+
+=back
+
+Any omitted or empty regular expressions will default to ".*".
+Please note that each regular expression given is implicitly
+anchored by adding "^" and "$" to the beginning and end. Also, if a
+given regular expression starts with a "!" character, then the
+expression is I<negated> (so C<!foo> would match anything I<except>
+C<foo>).
+
+Some example section specifications follow.
+
+=over 4
+
+=item *
+
+Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections:
+
+C<NAME|SYNOPSIS>
+
+=item *
+
+Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION>
+section:
+
+C<DESCRIPTION/Question|Answer>
+
+=item *
+
+Match the C<Comments> subsection of I<all> sections:
+
+C</Comments>
+
+=item *
+
+Match all subsections of C<DESCRIPTION> I<except> for C<Comments>:
+
+C<DESCRIPTION/!Comments>
+
+=item *
+
+Match the C<DESCRIPTION> section but do I<not> match any of its subsections:
+
+C<DESCRIPTION/!.+>
+
+=item *
+
+Match all top level sections but none of their subsections:
+
+C</!.+>
+
+=back
+
+=begin _NOT_IMPLEMENTED_
+
+=head1 RANGE SPECIFICATIONS
+
+B<podselect()> and B<Pod::Select::select()> may be given one or more
+"range specifications" to restrict the text processed to only the
+desired ranges of paragraphs in the desired set of sections. A range
+specification is a string containing a single Perl-style regular
+expression (a regex), or else two Perl-style regular expressions
+(regexs) separated by a ".." (Perl's "range" operator is "..").
+The regexs in a range specification are delimited by forward slashes
+("/"). If you need to use a forward slash literally within a regex you
+can escape it with a backslash ("\/").
+
+The formal syntax of a range specification is:
+
+=over 4
+
+=item *
+
+/I<start-range-regex>/[../I<end-range-regex>/]
+
+=back
+
+Where each the item inside square brackets (the ".." followed by the
+end-range-regex) is optional. Each "range-regex" is of the form:
+
+ =cmd-expr text-expr
+
+Where I<cmd-expr> is intended to match the name of one or more POD
+commands, and I<text-expr> is intended to match the paragraph text for
+the command. If a range-regex is supposed to match a POD command, then
+the first character of the regex (the one after the initial '/')
+absolutely I<must> be a single '=' character; it may not be anything
+else (not even a regex meta-character) if it is supposed to match
+against the name of a POD command.
+
+If no I<=cmd-expr> is given then the text-expr will be matched against
+plain textblocks unless it is preceded by a space, in which case it is
+matched against verbatim text-blocks. If no I<text-expr> is given then
+only the command-portion of the paragraph is matched against.
+
+Note that these two expressions are each implicitly anchored. This
+means that when matching against the command-name, there will be an
+implicit '^' and '$' around the given I<=cmd-expr>; and when matching
+against the paragraph text there will be an implicit '\A' and '\Z'
+around the given I<text-expr>.
+
+Unlike with section-specs, the '!' character does I<not> have any special
+meaning (negation or otherwise) at the beginning of a range-spec!
+
+Some example range specifications follow.
+
+=over 4
+
+=item
+Match all C<=for html> paragraphs:
+
+C</=for html/>
+
+=item
+Match all paragraphs between C<=begin html> and C<=end html>
+(note that this will I<not> work correctly if such sections
+are nested):
+
+C</=begin html/../=end html/>
+
+=item
+Match all paragraphs between the given C<=item> name until the end of the
+current section:
+
+C</=item mine/../=head\d/>
+
+=item
+Match all paragraphs between the given C<=item> until the next item, or
+until the end of the itemized list (note that this will I<not> work as
+desired if the item contains an itemized list nested within it):
+
+C</=item mine/../=(item|back)/>
+
+=back
+
+=end _NOT_IMPLEMENTED_
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Carp;
+use Pod::Parser 1.04;
+
+@ISA = qw(Pod::Parser);
+@EXPORT = qw(&podselect);
+
+## Maximum number of heading levels supported for '=headN' directives
+*MAX_HEADING_LEVEL = \3;
+
+#############################################################################
+
+=head1 OBJECT METHODS
+
+The following methods are provided in this module. Each one takes a
+reference to the object itself as an implicit first parameter.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+## =begin _PRIVATE_
+##
+## =head1 B<_init_headings()>
+##
+## Initialize the current set of active section headings.
+##
+## =cut
+##
+## =end _PRIVATE_
+
+sub _init_headings {
+ my $self = shift;
+ local *myData = $self;
+
+ ## Initialize current section heading titles if necessary
+ unless (defined $myData{_SECTION_HEADINGS}) {
+ local *section_headings = $myData{_SECTION_HEADINGS} = [];
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ $section_headings[$i] = '';
+ }
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<curr_headings()>
+
+ ($head1, $head2, $head3, ...) = $parser->curr_headings();
+ $head1 = $parser->curr_headings(1);
+
+This method returns a list of the currently active section headings and
+subheadings in the document being parsed. The list of headings returned
+corresponds to the most recently parsed paragraph of the input.
+
+If an argument is given, it must correspond to the desired section
+heading number, in which case only the specified section heading is
+returned. If there is no current section heading at the specified
+level, then C<undef> is returned.
+
+=cut
+
+sub curr_headings {
+ my $self = shift;
+ $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS});
+ my @headings = @{ $self->{_SECTION_HEADINGS} };
+ return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings;
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<select()>
+
+ $parser->select($section_spec1,$section_spec2,...);
+
+This method is used to select the particular sections and subsections of
+POD documentation that are to be printed and/or processed. The existing
+set of selected sections is I<replaced> with the given set of sections.
+See B<add_selection()> for adding to the current set of selected
+sections.
+
+Each of the C<$section_spec> arguments should be a section specification
+as described in L<"SECTION SPECIFICATIONS">. The section specifications
+are parsed by this method and the resulting regular expressions are
+stored in the invoking object.
+
+If no C<$section_spec> arguments are given, then the existing set of
+selected sections is cleared out (which means C<all> sections will be
+processed).
+
+This method should I<not> normally be overridden by subclasses.
+
+=cut
+
+sub select {
+ my ($self, @sections) = @_;
+ local *myData = $self;
+ local $_;
+
+### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?)
+
+ ##---------------------------------------------------------------------
+ ## The following is a blatant hack for backward compatibility, and for
+ ## implementing add_selection(). If the *first* *argument* is the
+ ## string "+", then the remaining section specifications are *added*
+ ## to the current set of selections; otherwise the given section
+ ## specifications will *replace* the current set of selections.
+ ##
+ ## This should probably be fixed someday, but for the present time,
+ ## it seems incredibly unlikely that "+" would ever correspond to
+ ## a legitimate section heading
+ ##---------------------------------------------------------------------
+ my $add = ($sections[0] eq '+') ? shift(@sections) : '';
+
+ ## Reset the set of sections to use
+ unless (@sections) {
+ delete $myData{_SELECTED_SECTIONS} unless ($add);
+ return;
+ }
+ $myData{_SELECTED_SECTIONS} = []
+ unless ($add && exists $myData{_SELECTED_SECTIONS});
+ local *selected_sections = $myData{_SELECTED_SECTIONS};
+
+ ## Compile each spec
+ for my $spec (@sections) {
+ if ( defined($_ = _compile_section_spec($spec)) ) {
+ ## Store them in our sections array
+ push(@selected_sections, $_);
+ }
+ else {
+ carp qq{Ignoring section spec "$spec"!\n};
+ }
+ }
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<add_selection()>
+
+ $parser->add_selection($section_spec1,$section_spec2,...);
+
+This method is used to add to the currently selected sections and
+subsections of POD documentation that are to be printed and/or
+processed. See <select()> for replacing the currently selected sections.
+
+Each of the C<$section_spec> arguments should be a section specification
+as described in L<"SECTION SPECIFICATIONS">. The section specifications
+are parsed by this method and the resulting regular expressions are
+stored in the invoking object.
+
+This method should I<not> normally be overridden by subclasses.
+
+=cut
+
+sub add_selection {
+ my $self = shift;
+ return $self->select('+', @_);
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<clear_selections()>
+
+ $parser->clear_selections();
+
+This method takes no arguments, it has the exact same effect as invoking
+<select()> with no arguments.
+
+=cut
+
+sub clear_selections {
+ my $self = shift;
+ return $self->select();
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<match_section()>
+
+ $boolean = $parser->match_section($heading1,$heading2,...);
+
+Returns a value of true if the given section and subsection heading
+titles match any of the currently selected section specifications in
+effect from prior calls to B<select()> and B<add_selection()> (or if
+there are no explicitly selected/deselected sections).
+
+The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of
+the corresponding sections, subsections, etc. to try and match. If
+C<$headingN> is omitted then it defaults to the current corresponding
+section heading title in the input.
+
+This method should I<not> normally be overridden by subclasses.
+
+=cut
+
+sub match_section {
+ my $self = shift;
+ my (@headings) = @_;
+ local *myData = $self;
+
+ ## Return true if no restrictions were explicitly specified
+ my $selections = (exists $myData{_SELECTED_SECTIONS})
+ ? $myData{_SELECTED_SECTIONS} : undef;
+ return 1 unless ((defined $selections) && @{$selections});
+
+ ## Default any unspecified sections to the current one
+ my @current_headings = $self->curr_headings();
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ (defined $headings[$i]) or $headings[$i] = $current_headings[$i];
+ }
+
+ ## Look for a match against the specified section expressions
+ for my $section_spec ( @{$selections} ) {
+ ##------------------------------------------------------
+ ## Each portion of this spec must match in order for
+ ## the spec to be matched. So we will start with a
+ ## match-value of 'true' and logically 'and' it with
+ ## the results of matching a given element of the spec.
+ ##------------------------------------------------------
+ my $match = 1;
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ my $regex = $section_spec->[$i];
+ my $negated = ($regex =~ s/^\!//);
+ $match &= ($negated ? ($headings[$i] !~ /${regex}/)
+ : ($headings[$i] =~ /${regex}/));
+ last unless ($match);
+ }
+ return 1 if ($match);
+ }
+ return 0; ## no match
+}
+
+##---------------------------------------------------------------------------
+
+=head1 B<is_selected()>
+
+ $boolean = $parser->is_selected($paragraph);
+
+This method is used to determine if the block of text given in
+C<$paragraph> falls within the currently selected set of POD sections
+and subsections to be printed or processed. This method is also
+responsible for keeping track of the current input section and
+subsections. It is assumed that C<$paragraph> is the most recently read
+(but not yet processed) input paragraph.
+
+The value returned will be true if the C<$paragraph> and the rest of the
+text in the same section as C<$paragraph> should be selected (included)
+for processing; otherwise a false value is returned.
+
+=cut
+
+sub is_selected {
+ my ($self, $paragraph) = @_;
+ local $_;
+ local *myData = $self;
+
+ $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS});
+
+ ## Keep track of current sections levels and headings
+ $_ = $paragraph;
+ if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/)
+ {
+ ## This is a section heading command
+ my ($level, $heading) = ($2, $3);
+ $level = 1 + (length($1) / 3) if ((! length $level) || (length $1));
+ ## Reset the current section heading at this level
+ $myData{_SECTION_HEADINGS}->[$level - 1] = $heading;
+ ## Reset subsection headings of this one to empty
+ for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) {
+ $myData{_SECTION_HEADINGS}->[$i] = '';
+ }
+ }
+
+ return $self->match_section();
+}
+
+#############################################################################
+
+=head1 EXPORTED FUNCTIONS
+
+The following functions are exported by this module. Please note that
+these are functions (not methods) and therefore C<do not> take an
+implicit first argument.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=head1 B<podselect()>
+
+ podselect(\%options,@filelist);
+
+B<podselect> will print the raw (untranslated) POD paragraphs of all
+POD sections in the given input files specified by C<@filelist>
+according to the given options.
+
+If any argument to B<podselect> is a reference to a hash
+(associative array) then the values with the following keys are
+processed as follows:
+
+=over 4
+
+=item B<-output>
+
+A string corresponding to the desired output file (or ">&STDOUT"
+or ">&STDERR"). The default is to use standard output.
+
+=item B<-sections>
+
+A reference to an array of sections specifications (as described in
+L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD
+sections and subsections to be selected from input. If no section
+specifications are given, then all sections of the PODs are used.
+
+=begin _NOT_IMPLEMENTED_
+
+=item B<-ranges>
+
+A reference to an array of range specifications (as described in
+L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD
+paragraphs to be selected from the desired input sections. If no range
+specifications are given, then all paragraphs of the desired sections
+are used.
+
+=end _NOT_IMPLEMENTED_
+
+=back
+
+All other arguments should correspond to the names of input files
+containing POD sections. A file name of "-" or "<&STDIN" will
+be interpreted to mean standard input (which is the default if no
+filenames are given).
+
+=cut
+
+sub podselect {
+ my(@argv) = @_;
+ my %defaults = ();
+ my $pod_parser = new Pod::Select(%defaults);
+ my $num_inputs = 0;
+ my $output = '>&STDOUT';
+ my %opts;
+ local $_;
+ for (@argv) {
+ if (ref($_)) {
+ next unless (ref($_) eq 'HASH');
+ %opts = (%defaults, %{$_});
+
+ ##-------------------------------------------------------------
+ ## Need this for backward compatibility since we formerly used
+ ## options that were all uppercase words rather than ones that
+ ## looked like Unix command-line options.
+ ## to be uppercase keywords)
+ ##-------------------------------------------------------------
+ %opts = map {
+ my ($key, $val) = (lc $_, $opts{$_});
+ $key =~ s/^(?=\w)/-/;
+ $key =~ /^-se[cl]/ and $key = '-sections';
+ #! $key eq '-range' and $key .= 's';
+ ($key => $val);
+ } (keys %opts);
+
+ ## Process the options
+ (exists $opts{'-output'}) and $output = $opts{'-output'};
+
+ ## Select the desired sections
+ $pod_parser->select(@{ $opts{'-sections'} })
+ if ( (defined $opts{'-sections'})
+ && ((ref $opts{'-sections'}) eq 'ARRAY') );
+
+ #! ## Select the desired paragraph ranges
+ #! $pod_parser->select(@{ $opts{'-ranges'} })
+ #! if ( (defined $opts{'-ranges'})
+ #! && ((ref $opts{'-ranges'}) eq 'ARRAY') );
+ }
+ else {
+ $pod_parser->parse_from_file($_, $output);
+ ++$num_inputs;
+ }
+ }
+ $pod_parser->parse_from_file('-') unless ($num_inputs > 0);
+}
+
+#############################################################################
+
+=head1 PRIVATE METHODS AND DATA
+
+B<Pod::Select> makes uses a number of internal methods and data fields
+which clients should not need to see or use. For the sake of avoiding
+name collisions with client data and methods, these methods and fields
+are briefly discussed here. Determined hackers may obtain further
+information about them by reading the B<Pod::Select> source code.
+
+Private data fields are stored in the hash-object whose reference is
+returned by the B<new()> constructor for this class. The names of all
+private methods and data-fields used by B<Pod::Select> begin with a
+prefix of "_" and match the regular expression C</^_\w+$/>.
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head1 B<_compile_section_spec()>
+
+ $listref = $parser->_compile_section_spec($section_spec);
+
+This function (note it is a function and I<not> a method) takes a
+section specification (as described in L<"SECTION SPECIFICATIONS">)
+given in C<$section_sepc>, and compiles it into a list of regular
+expressions. If C<$section_spec> has no syntax errors, then a reference
+to the list (array) of corresponding regular expressions is returned;
+otherwise C<undef> is returned and an error message is printed (using
+B<carp>) for each invalid regex.
+
+=end _PRIVATE_
+
+=cut
+
+sub _compile_section_spec {
+ my ($section_spec) = @_;
+ my (@regexs, $negated);
+
+ ## Compile the spec into a list of regexs
+ local $_ = $section_spec;
+ s{\\\\}{\001}g; ## handle escaped backward slashes
+ s{\\/}{\002}g; ## handle escaped forward slashes
+
+ ## Parse the regexs for the heading titles
+ @regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
+
+ ## Set default regex for ommitted levels
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
+ $regexs[$i] = '.*' unless ((defined $regexs[$i])
+ && (length $regexs[$i]));
+ }
+ ## Modify the regexs as needed and validate their syntax
+ my $bad_regexs = 0;
+ for (@regexs) {
+ $_ .= '.+' if ($_ eq '!');
+ s{\001}{\\\\}g; ## restore escaped backward slashes
+ s{\002}{\\/}g; ## restore escaped forward slashes
+ $negated = s/^\!//; ## check for negation
+ eval "m{$_}"; ## check regex syntax
+ if ($@) {
+ ++$bad_regexs;
+ carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
+ }
+ else {
+ ## Add the forward and rear anchors (and put the negator back)
+ $_ = '^' . $_ unless (/^\^/);
+ $_ = $_ . '$' unless (/\$$/);
+ $_ = '!' . $_ if ($negated);
+ }
+ }
+ return (! $bad_regexs) ? [ @regexs ] : undef;
+}
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head2 $self->{_SECTION_HEADINGS}
+
+A reference to an array of the current section heading titles for each
+heading level (note that the first heading level title is at index 0).
+
+=end _PRIVATE_
+
+=cut
+
+##---------------------------------------------------------------------------
+
+=begin _PRIVATE_
+
+=head2 $self->{_SELECTED_SECTIONS}
+
+A reference to an array of references to arrays. Each subarray is a list
+of anchored regular expressions (preceded by a "!" if the expression is to
+be negated). The index of the expression in the subarray should correspond
+to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}>
+that it is to be matched against.
+
+=end _PRIVATE_
+
+=cut
+
+#############################################################################
+
+=head1 SEE ALSO
+
+L<Pod::Parser>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+Based on code for B<pod2text> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+1;
+# vim: ts=4 sw=4 et
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple.pm
new file mode 100755
index 00000000000..97b5911446c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple.pm
@@ -0,0 +1,1535 @@
+
+require 5;
+package Pod::Simple;
+use strict;
+use Carp ();
+BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
+use integer;
+use Pod::Escapes 1.04 ();
+use Pod::Simple::LinkSection ();
+use Pod::Simple::BlackBox ();
+#use utf8;
+
+use vars qw(
+ $VERSION @ISA
+ @Known_formatting_codes @Known_directives
+ %Known_formatting_codes %Known_directives
+ $NL
+);
+
+@ISA = ('Pod::Simple::BlackBox');
+$VERSION = '3.13';
+
+@Known_formatting_codes = qw(I B C L E F S X Z);
+%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
+@Known_directives = qw(head1 head2 head3 head4 item over back);
+%Known_directives = map(($_=>'Plain'), @Known_directives);
+$NL = $/ unless defined $NL;
+
+#-----------------------------------------------------------------------------
+# Set up some constants:
+
+BEGIN {
+ if(defined &ASCII) { }
+ elsif(chr(65) eq 'A') { *ASCII = sub () {1} }
+ else { *ASCII = sub () {''} }
+
+ unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
+ DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n";
+ unless(MANY_LINES() >= 1) {
+ die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
+ }
+ if(defined &UNICODE) { }
+ elsif($] >= 5.008) { *UNICODE = sub() {1} }
+ else { *UNICODE = sub() {''} }
+}
+if(DEBUG > 2) {
+ print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
+ print "# We are under a Unicode-safe Perl.\n";
+}
+
+# Design note:
+# This is a parser for Pod. It is not a parser for the set of Pod-like
+# languages which happens to contain Pod -- it is just for Pod, plus possibly
+# some extensions.
+
+# @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
+#@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+__PACKAGE__->_accessorize(
+ 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters
+ 'source_filename', # Filename of the source, for use in warnings
+ 'source_dead', # Whether to consider this parser's source dead
+
+ 'output_fh', # The filehandle we're writing to, if applicable.
+ # Used only in some derived classes.
+
+ 'hide_line_numbers', # For some dumping subclasses: whether to pointedly
+ # suppress the start_line attribute
+
+ 'line_count', # the current line number
+ 'pod_para_count', # count of pod paragraphs seen so far
+
+ 'no_whining', # whether to suppress whining
+ 'no_errata_section', # whether to suppress the errata section
+ 'complain_stderr', # whether to complain to stderr
+
+ 'doc_has_started', # whether we've fired the open-Document event yet
+
+ 'bare_output', # For some subclasses: whether to prepend
+ # header-code and postpend footer-code
+
+ 'nix_X_codes', # whether to ignore X<...> codes
+ 'merge_text', # whether to avoid breaking a single piece of
+ # text up into several events
+
+ 'preserve_whitespace', # whether to try to keep whitespace as-is
+ 'strip_verbatim_indent', # What indent to strip from verbatim
+
+ 'content_seen', # whether we've seen any real Pod content
+ 'errors_seen', # TODO: document. whether we've seen any errors (fatal or not)
+
+ 'codes_in_verbatim', # for PseudoPod extensions
+
+ 'code_handler', # coderef to call when a code (non-pod) line is seen
+ 'cut_handler', # coderef to call when a =cut line is seen
+ #Called like:
+ # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
+ # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
+
+);
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub any_errata_seen { # good for using as an exit() value...
+ return shift->{'errors_seen'} || 0;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+# Pull in some functions that, for some reason, I expect to see here too:
+BEGIN {
+ *pretty = \&Pod::Simple::BlackBox::pretty;
+ *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub version_report {
+ my $class = ref($_[0]) || $_[0];
+ if($class eq __PACKAGE__) {
+ return "$class $VERSION";
+ } else {
+ my $v = $class->VERSION;
+ return "$class $v (" . __PACKAGE__ . " $VERSION)";
+ }
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+#sub curr_open { # read-only list accessor
+# return @{ $_[0]{'curr_open'} || return() };
+#}
+#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }
+
+
+sub output_string {
+ # Works by faking out output_fh. Simplifies our code.
+ #
+ my $this = shift;
+ return $this->{'output_string'} unless @_; # GET.
+
+ require Pod::Simple::TiedOutFH;
+ my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
+ $$x = '' unless defined $$x;
+ DEBUG > 4 and print "# Output string set to $x ($$x)\n";
+ $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
+ return
+ $this->{'output_string'} = $_[0];
+ #${ ${ $this->{'output_fh'} } };
+}
+
+sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
+sub abandon_output_fh { $_[0]->output_fh(undef) }
+# These don't delete the string or close the FH -- they just delete our
+# references to it/them.
+# TODO: document these
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub new {
+ # takes no parameters
+ my $class = ref($_[0]) || $_[0];
+ #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
+ # . __PACKAGE__ );
+ return bless {
+ 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) },
+ 'accept_directives' => { %Known_directives },
+ 'accept_targets' => {},
+ }, $class;
+}
+
+
+
+# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_element_start { # OVERRIDE IN DERIVED CLASS
+ my($self, $element_name, $attr_hash_r) = @_;
+ return;
+}
+
+sub _handle_element_end { # OVERRIDE IN DERIVED CLASS
+ my($self, $element_name) = @_;
+ return;
+}
+
+sub _handle_text { # OVERRIDE IN DERIVED CLASS
+ my($self, $text) = @_;
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And now directives (not targets)
+
+sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) }
+sub accept_directive_as_data { shift->_accept_directives('Data', @_) }
+sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) }
+
+sub _accept_directives {
+ my($this, $type) = splice @_,0,2;
+ foreach my $d (@_) {
+ next unless defined $d and length $d;
+ Carp::croak "\"$d\" isn't a valid directive name"
+ unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
+ Carp::croak "\"$d\" is already a reserved Pod directive name"
+ if exists $Known_directives{$d};
+ $this->{'accept_directives'}{$d} = $type;
+ DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n";
+ }
+ DEBUG > 6 and print "$this\'s accept_directives : ",
+ pretty($this->{'accept_directives'}), "\n";
+
+ return sort keys %{ $this->{'accept_directives'} } if wantarray;
+ return;
+}
+
+#--------------------------------------------------------------------------
+# TODO: document these:
+
+sub unaccept_directive { shift->unaccept_directives(@_) };
+
+sub unaccept_directives {
+ my $this = shift;
+ foreach my $d (@_) {
+ next unless defined $d and length $d;
+ Carp::croak "\"$d\" isn't a valid directive name"
+ unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
+ Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
+ if exists $Known_directives{$d};
+ delete $this->{'accept_directives'}{$d};
+ DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n";
+ }
+ return sort keys %{ $this->{'accept_directives'} } if wantarray;
+ return
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And now targets (not directives)
+
+sub accept_target { shift->accept_targets(@_) } # alias
+sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias
+
+
+sub accept_targets { shift->_accept_targets('1', @_) }
+
+sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
+ # forces them to be processed, even when there's no ":".
+
+sub _accept_targets {
+ my($this, $type) = splice @_,0,2;
+ foreach my $t (@_) {
+ next unless defined $t and length $t;
+ # TODO: enforce some limitations on what a target name can be?
+ $this->{'accept_targets'}{$t} = $type;
+ DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n";
+ }
+ return sort keys %{ $this->{'accept_targets'} } if wantarray;
+ return;
+}
+
+#--------------------------------------------------------------------------
+sub unaccept_target { shift->unaccept_targets(@_) }
+
+sub unaccept_targets {
+ my $this = shift;
+ foreach my $t (@_) {
+ next unless defined $t and length $t;
+ # TODO: enforce some limitations on what a target name can be?
+ delete $this->{'accept_targets'}{$t};
+ DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n";
+ }
+ return sort keys %{ $this->{'accept_targets'} } if wantarray;
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And now codes (not targets or directives)
+
+sub accept_code { shift->accept_codes(@_) } # alias
+
+sub accept_codes { # Add some codes
+ my $this = shift;
+
+ foreach my $new_code (@_) {
+ next unless defined $new_code and length $new_code;
+ if(ASCII) {
+ # A good-enough check that it's good as an XML Name symbol:
+ Carp::croak "\"$new_code\" isn't a valid element name"
+ if $new_code =~
+ m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
+ # Characters under 0x80 that aren't legal in an XML Name.
+ or $new_code =~ m/^[-\.0-9]/s
+ or $new_code =~ m/:[-\.0-9]/s;
+ # The legal under-0x80 Name characters that
+ # an XML Name still can't start with.
+ }
+
+ $this->{'accept_codes'}{$new_code} = $new_code;
+
+ # Yes, map to itself -- just so that when we
+ # see "=extend W [whatever] thatelementname", we say that W maps
+ # to whatever $this->{accept_codes}{thatelementname} is,
+ # i.e., "thatelementname". Then when we go re-mapping,
+ # a "W" in the treelet turns into "thatelementname". We only
+ # remap once.
+ # If we say we accept "W", then a "W" in the treelet simply turns
+ # into "W".
+ }
+
+ return;
+}
+
+#--------------------------------------------------------------------------
+sub unaccept_code { shift->unaccept_codes(@_) }
+
+sub unaccept_codes { # remove some codes
+ my $this = shift;
+
+ foreach my $new_code (@_) {
+ next unless defined $new_code and length $new_code;
+ if(ASCII) {
+ # A good-enough check that it's good as an XML Name symbol:
+ Carp::croak "\"$new_code\" isn't a valid element name"
+ if $new_code =~
+ m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
+ # Characters under 0x80 that aren't legal in an XML Name.
+ or $new_code =~ m/^[-\.0-9]/s
+ or $new_code =~ m/:[-\.0-9]/s;
+ # The legal under-0x80 Name characters that
+ # an XML Name still can't start with.
+ }
+
+ Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
+ if grep $new_code eq $_, @Known_formatting_codes;
+
+ delete $this->{'accept_codes'}{$new_code};
+
+ DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n";
+ }
+
+ return;
+}
+
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub parse_string_document {
+ my $self = shift;
+ my @lines;
+ foreach my $line_group (@_) {
+ next unless defined $line_group and length $line_group;
+ pos($line_group) = 0;
+ while($line_group =~
+ m/([^\n\r]*)((?:\r?\n)?)/g
+ ) {
+ #print(">> $1\n"),
+ $self->parse_lines($1)
+ if length($1) or length($2)
+ or pos($line_group) != length($line_group);
+ # I.e., unless it's a zero-length "empty line" at the very
+ # end of "foo\nbar\n" (i.e., between the \n and the EOS).
+ }
+ }
+ $self->parse_lines(undef); # to signal EOF
+ return $self;
+}
+
+sub _init_fh_source {
+ my($self, $source) = @_;
+
+ #DEBUG > 1 and print "Declaring $source as :raw for starters\n";
+ #$self->_apply_binmode($source, ':raw');
+ #binmode($source, ":raw");
+
+ return;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+#
+
+sub parse_file {
+ my($self, $source) = (@_);
+
+ if(!defined $source) {
+ Carp::croak("Can't use empty-string as a source for parse_file");
+ } elsif(ref(\$source) eq 'GLOB') {
+ $self->{'source_filename'} = '' . ($source);
+ } elsif(ref $source) {
+ $self->{'source_filename'} = '' . ($source);
+ } elsif(!length $source) {
+ Carp::croak("Can't use empty-string as a source for parse_file");
+ } else {
+ {
+ local *PODSOURCE;
+ open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
+ $self->{'source_filename'} = $source;
+ $source = *PODSOURCE{IO};
+ }
+ $self->_init_fh_source($source);
+ }
+ # By here, $source is a FH.
+
+ $self->{'source_fh'} = $source;
+
+ my($i, @lines);
+ until( $self->{'source_dead'} ) {
+ splice @lines;
+ for($i = MANY_LINES; $i--;) { # read those many lines at a time
+ local $/ = $NL;
+ push @lines, scalar(<$source>); # readline
+ last unless defined $lines[-1];
+ # but pass thru the undef, which will set source_dead to true
+ }
+ $self->parse_lines(@lines);
+ }
+ delete($self->{'source_fh'}); # so it can be GC'd
+ return $self;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub parse_from_file {
+ # An emulation of Pod::Parser's interface, for the sake of Perldoc.
+ # Basically just a wrapper around parse_file.
+
+ my($self, $source, $to) = @_;
+ $self = $self->new unless ref($self); # so we tolerate being a class method
+
+ if(!defined $source) { $source = *STDIN{IO}
+ } elsif(ref(\$source) eq 'GLOB') { # stet
+ } elsif(ref($source) ) { # stet
+ } elsif(!length $source
+ or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i
+ ) {
+ $source = *STDIN{IO};
+ }
+
+ if(!defined $to) { $self->output_fh( *STDOUT{IO} );
+ } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
+ } elsif(ref($to)) { $self->output_fh( $to );
+ } elsif(!length $to
+ or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
+ ) {
+ $self->output_fh( *STDOUT{IO} );
+ } else {
+ require Symbol;
+ my $out_fh = Symbol::gensym();
+ DEBUG and print "Write-opening to $to\n";
+ open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!";
+ binmode($out_fh)
+ if $self->can('write_with_binmode') and $self->write_with_binmode;
+ $self->output_fh($out_fh);
+ }
+
+ return $self->parse_file($source);
+}
+
+#-----------------------------------------------------------------------------
+
+sub whine {
+ #my($self,$line,$complaint) = @_;
+ my $self = shift(@_);
+ ++$self->{'errors_seen'};
+ if($self->{'no_whining'}) {
+ DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
+ return;
+ }
+ return $self->_complain_warn(@_) if $self->{'complain_stderr'};
+ return $self->_complain_errata(@_);
+}
+
+sub scream { # like whine, but not suppressable
+ #my($self,$line,$complaint) = @_;
+ my $self = shift(@_);
+ ++$self->{'errors_seen'};
+ return $self->_complain_warn(@_) if $self->{'complain_stderr'};
+ return $self->_complain_errata(@_);
+}
+
+sub _complain_warn {
+ my($self,$line,$complaint) = @_;
+ return printf STDERR "%s around line %s: %s\n",
+ $self->{'source_filename'} || 'Pod input', $line, $complaint;
+}
+
+sub _complain_errata {
+ my($self,$line,$complaint) = @_;
+ if( $self->{'no_errata_section'} ) {
+ DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
+ } else {
+ DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n";
+ push @{$self->{'errata'}{$line}}, $complaint
+ # for a report to be generated later!
+ }
+ return 1;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _get_initial_item_type {
+ # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
+ my($self, $para) = @_;
+ return $para->[1]{'~type'} if $para->[1]{'~type'};
+
+ return $para->[1]{'~type'} = 'text'
+ if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
+ # Else fall thru to the general case:
+ return $self->_get_item_type($para);
+}
+
+
+
+sub _get_item_type { # mutates the item!!
+ my($self, $para) = @_;
+ return $para->[1]{'~type'} if $para->[1]{'~type'};
+
+
+ # Otherwise we haven't yet been to this node. Maybe alter it...
+
+ my $content = join "\n", @{$para}[2 .. $#$para];
+
+ if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
+ # Like: "=item *", "=item * ", "=item"
+ splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
+ $para->[1]{'~orig_content'} = $content;
+ return $para->[1]{'~type'} = 'bullet';
+
+ } elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance
+
+ # Like: "=item * Foo bar baz";
+ $para->[1]{'~orig_content'} = $content;
+ $para->[1]{'~_freaky_para_hack'} = $1;
+ DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n";
+ splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
+ return $para->[1]{'~type'} = 'bullet';
+
+ } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
+ # Like: "=item 1.", "=item 123412"
+
+ $para->[1]{'~orig_content'} = $content;
+ $para->[1]{'number'} = $1; # Yes, stores the number there!
+
+ splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
+ return $para->[1]{'~type'} = 'number';
+
+ } else {
+ # It's anything else.
+ return $para->[1]{'~type'} = 'text';
+
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+sub _make_treelet {
+ my $self = shift; # and ($para, $start_line)
+ my $treelet;
+ if(!@_) {
+ return [''];
+ } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
+ # Hack so we can pass in fake-o pre-cooked paragraphs:
+ # just have the first line be a reference to a ['~Top', {}, ...]
+ # We use this feechure in gen_errata and stuff.
+
+ DEBUG and print "Applying precooked treelet hack to $_[0][0]\n";
+ $treelet = $_[0][0];
+ splice @$treelet, 0, 2; # lop the top off
+ return $treelet;
+ } else {
+ $treelet = $self->_treelet_from_formatting_codes(@_);
+ }
+
+ if( $self->_remap_sequences($treelet) ) {
+ $self->_treat_Zs($treelet); # Might as well nix these first
+ $self->_treat_Ls($treelet); # L has to precede E and S
+ $self->_treat_Es($treelet);
+ $self->_treat_Ss($treelet); # S has to come after E
+
+ $self->_wrap_up($treelet); # Nix X's and merge texties
+
+ } else {
+ DEBUG and print "Formatless treelet gets fast-tracked.\n";
+ # Very common case!
+ }
+
+ splice @$treelet, 0, 2; # lop the top off
+
+ return $treelet;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub _wrap_up {
+ my($self, @stack) = @_;
+ my $nixx = $self->{'nix_X_codes'};
+ my $merge = $self->{'merge_text' };
+ return unless $nixx or $merge;
+
+ DEBUG > 2 and print "\nStarting _wrap_up traversal.\n",
+ $merge ? (" Merge mode on\n") : (),
+ $nixx ? (" Nix-X mode on\n") : (),
+ ;
+
+
+ my($i, $treelet);
+ while($treelet = shift @stack) {
+ DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
+ for($i = 2; $i < @$treelet; ++$i) { # iterate over children
+ DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n";
+ if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
+ DEBUG > 3 and print " Nixing X node at $i\n";
+ splice(@$treelet, $i, 1); # just nix this node (and its descendants)
+ # no need to back-update the counter just yet
+ redo;
+
+ } elsif($merge and $i != 2 and # non-initial
+ !ref $treelet->[$i] and !ref $treelet->[$i - 1]
+ ) {
+ DEBUG > 3 and print " Merging ", $i-1,
+ ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
+ $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
+ DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n";
+ --$i;
+ next;
+ # since we just pulled the possibly last node out from under
+ # ourselves, we can't just redo()
+
+ } elsif( ref $treelet->[$i] ) {
+ DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
+ push @stack, $treelet->[$i];
+
+ if($treelet->[$i][0] eq 'L') {
+ my $thing;
+ foreach my $attrname ('section', 'to') {
+ if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
+ unshift @stack, $thing;
+ DEBUG > 4 and print " +Enqueuing ",
+ pretty( $treelet->[$i][1]{$attrname} ),
+ " as an attribute value to tweak.\n";
+ }
+ }
+ }
+ }
+ }
+ }
+ DEBUG > 2 and print "End of _wrap_up traversal.\n\n";
+
+ return;
+}
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub _remap_sequences {
+ my($self,@stack) = @_;
+
+ if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
+ # VERY common case: abort it.
+ DEBUG and print "Skipping _remap_sequences: formatless treelet.\n";
+ return 0;
+ }
+
+ my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");
+
+ my $start_line = $stack[0][1]{'start_line'};
+ DEBUG > 2 and printf
+ "\nAbout to start _remap_sequences on treelet from line %s.\n",
+ $start_line || '[?]'
+ ;
+ DEBUG > 3 and print " Map: ",
+ join('; ', map "$_=" . (
+ ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
+ ),
+ sort keys %$map ),
+ ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
+ ? " (all normal)\n" : "\n"
+ ;
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+ my($is, $was, $i, $treelet); # scratch
+ while($treelet = shift @stack) {
+ DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
+ for($i = 2; $i < @$treelet; ++$i) { # iterate over children
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+
+ DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n";
+
+ $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
+ if( DEBUG > 3 ) {
+ if(!defined $is) {
+ print " Code $was<> is UNKNOWN!\n";
+ } elsif($is eq $was) {
+ DEBUG > 4 and print " Code $was<> stays the same.\n";
+ } else {
+ print " Code $was<> maps to ",
+ ref($is)
+ ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
+ : "tag $is<...>.\n";
+ }
+ }
+
+ if(!defined $is) {
+ $self->whine($start_line, "Deleting unknown formatting code $was<>");
+ $is = $treelet->[$i][0] = '1'; # But saving the children!
+ # I could also insert a leading "$was<" and tailing ">" as
+ # children of this node, but something about that seems icky.
+ }
+ if(ref $is) {
+ my @dynasty = @$is;
+ DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n";
+ $treelet->[$i][0] = pop @dynasty;
+ my $nugget;
+ while(@dynasty) {
+ DEBUG > 4 and printf
+ " Grafting a new %s node between %s and %s\n",
+ $dynasty[-1], $treelet->[0], $treelet->[$i][0],
+ ;
+
+ #$nugget = ;
+ splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
+ # relace node with a new parent
+ }
+ } elsif($is eq '0') {
+ splice(@$treelet, $i, 1); # just nix this node (and its descendants)
+ --$i; # back-update the counter
+ } elsif($is eq '1') {
+ splice(@$treelet, $i, 1 # replace this node with its children!
+ => splice @{ $treelet->[$i] },2
+ # (not catching its first two (non-child) items)
+ );
+ --$i; # back up for new stuff
+ } else {
+ # otherwise it's unremarkable
+ unshift @stack, $treelet->[$i]; # just recurse
+ }
+ }
+ }
+
+ DEBUG > 2 and print "End of _remap_sequences traversal.\n\n";
+
+ if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
+ DEBUG and print "Noting that the treelet is now formatless.\n";
+ return 0;
+ }
+ return 1;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _ponder_extend {
+
+ # "Go to an extreme, move back to a more comfortable place"
+ # -- /Oblique Strategies/, Brian Eno and Peter Schmidt
+
+ my($self, $para) = @_;
+ my $content = join ' ', splice @$para, 2;
+ $content =~ s/^\s+//s;
+ $content =~ s/\s+$//s;
+
+ DEBUG > 2 and print "Ogling extensor: =extend $content\n";
+
+ if($content =~
+ m/^
+ (\S+) # 1 : new item
+ \s+
+ (\S+) # 2 : fallback(s)
+ (?:\s+(\S+))? # 3 : element name(s)
+ \s*
+ $
+ /xs
+ ) {
+ my $new_letter = $1;
+ my $fallbacks_one = $2;
+ my $elements_one;
+ $elements_one = defined($3) ? $3 : $1;
+
+ DEBUG > 2 and print "Extensor has good syntax.\n";
+
+ unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
+ DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You can extend only formatting codes A-Z, not like \"$new_letter\""
+ );
+ return;
+ }
+
+ if(grep $new_letter eq $_, @Known_formatting_codes) {
+ DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You can't extend an established code like \"$new_letter\""
+ );
+
+ #TODO: or allow if last bit is same?
+
+ return;
+ }
+
+ unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc.
+ or $fallbacks_one eq '0' or $fallbacks_one eq '1'
+ ) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Format for second =extend parameter must be like"
+ . " M or 1 or 0 or M,N or M,N,O but you have it like "
+ . $fallbacks_one
+ );
+ return;
+ }
+
+ unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
+ . $elements_one
+ );
+ return;
+ }
+
+ my @fallbacks = split ',', $fallbacks_one, -1;
+ my @elements = split ',', $elements_one, -1;
+
+ foreach my $f (@fallbacks) {
+ next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
+ DEBUG > 2 and print " Can't fall back on unknown code $f\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
+ );
+ return;
+ }
+
+ DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n",
+ @fallbacks, @elements;
+
+ my $canonical_form;
+ foreach my $e (@elements) {
+ if(exists $self->{'accept_codes'}{$e}) {
+ DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n";
+ $canonical_form = $e;
+ last; # first acceptable elementname wins!
+ } else {
+ DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n";
+ }
+ }
+
+
+ if( defined $canonical_form ) {
+ # We found a good N => elementname mapping
+ $self->{'accept_codes'}{$new_letter} = $canonical_form;
+ DEBUG > 2 and print
+ "Extensor maps $new_letter => known element $canonical_form.\n";
+ } else {
+ # We have to use the fallback(s), which might be '0', or '1'.
+ $self->{'accept_codes'}{$new_letter}
+ = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
+ DEBUG > 2 and print
+ "Extensor maps $new_letter => fallbacks @fallbacks.\n";
+ }
+
+ } else {
+ DEBUG > 2 and print "Extensor has bad syntax.\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Unknown =extend syntax: $content"
+ )
+ }
+ return;
+}
+
+
+#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
+
+sub _treat_Zs { # Nix Z<...>'s
+ my($self,@stack) = @_;
+
+ my($i, $treelet);
+ my $start_line = $stack[0][1]{'start_line'};
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+ while($treelet = shift @stack) {
+ for($i = 2; $i < @$treelet; ++$i) { # iterate over children
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+ unless($treelet->[$i][0] eq 'Z') {
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ }
+
+ DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n";
+
+ # bitch UNLESS it's empty
+ unless( @{$treelet->[$i]} == 2
+ or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
+ ) {
+ $self->whine( $start_line, "A non-empty Z<>" );
+ } # but kill it anyway
+
+ splice(@$treelet, $i, 1); # thereby just nix this node.
+ --$i;
+
+ }
+ }
+
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+# Quoting perlpodspec:
+
+# In parsing an L<...> code, Pod parsers must distinguish at least four
+# attributes:
+
+############# Not used. Expressed via the element children plus
+############# the value of the "content-implicit" flag.
+# First:
+# The link-text. If there is none, this must be undef. (E.g., in "L<Perl
+# Functions|perlfunc>", the link-text is "Perl Functions". In
+# "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
+# that link text may contain formatting.)
+#
+
+############# The element children
+# Second:
+# The possibly inferred link-text -- i.e., if there was no real link text,
+# then this is the text that we'll infer in its place. (E.g., for
+# "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
+#
+
+############# The "to" attribute (which might be text, or a treelet)
+# Third:
+# The name or URL, or undef if none. (E.g., in "L<Perl
+# Functions|perlfunc>", the name -- also sometimes called the page -- is
+# "perlfunc". In "L</CAVEATS>", the name is undef.)
+#
+
+############# The "section" attribute (which might be next, or a treelet)
+# Fourth:
+# The section (AKA "item" in older perlpods), or undef if none. E.g., in
+# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
+# is not the same as a manpage section like the "5" in "man 5 crontab".
+# "Section Foo" in the Pod sense means the part of the text that's
+# introduced by the heading or item whose text is "Foo".)
+#
+# Pod parsers may also note additional attributes including:
+#
+
+############# The "type" attribute.
+# Fifth:
+# A flag for whether item 3 (if present) is a URL (like
+# "http://lists.perl.org" is), in which case there should be no section
+# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
+# possibly a man page name (like "crontab(5)" is).
+#
+
+############# Not implemented, I guess.
+# Sixth:
+# The raw original L<...> content, before text is split on "|", "/", etc,
+# and before E<...> codes are expanded.
+
+
+# For L<...> codes without a "name|" part, only E<...> and Z<> codes may
+# occur -- no other formatting codes. That is, authors should not use
+# "L<B<Foo::Bar>>".
+#
+# Note, however, that formatting codes and Z<>'s can occur in any and all
+# parts of an L<...> (i.e., in name, section, text, and url).
+
+sub _treat_Ls { # Process our dear dear friends, the L<...> sequences
+
+ # L<name>
+ # L<name/"sec"> or L<name/sec>
+ # L</"sec"> or L</sec> or L<"sec">
+ # L<text|name>
+ # L<text|name/"sec"> or L<text|name/sec>
+ # L<text|/"sec"> or L<text|/sec> or L<text|"sec">
+ # L<scheme:...>
+ # L<text|scheme:...>
+
+ my($self,@stack) = @_;
+
+ my($i, $treelet);
+ my $start_line = $stack[0][1]{'start_line'};
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+ while($treelet = shift @stack) {
+ for(my $i = 2; $i < @$treelet; ++$i) {
+ # iterate over children of current tree node
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+ unless($treelet->[$i][0] eq 'L') {
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ }
+
+
+ # By here, $treelet->[$i] is definitely an L node
+ my $ell = $treelet->[$i];
+ DEBUG > 1 and print "Ogling L node $ell\n";
+
+ # bitch if it's empty
+ if( @{$ell} == 2
+ or (@{$ell} == 3 and $ell->[2] eq '')
+ ) {
+ $self->whine( $start_line, "An empty L<>" );
+ $treelet->[$i] = 'L<>'; # just make it a text node
+ next; # and move on
+ }
+
+ # Catch URLs:
+
+ # there are a number of possible cases:
+ # 1) text node containing url: http://foo.com
+ # -> [ 'http://foo.com' ]
+ # 2) text node containing url and text: foo|http://foo.com
+ # -> [ 'foo|http://foo.com' ]
+ # 3) text node containing url start: mailto:xE<at>foo.com
+ # -> [ 'mailto:x', [ E ... ], 'foo.com' ]
+ # 4) text node containing url start and text: foo|mailto:xE<at>foo.com
+ # -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ]
+ # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com
+ # -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ]
+ # ... etc.
+
+ # anything before the url is part of the text.
+ # anything after it is part of the url.
+ # the url text node itself may contain parts of both.
+
+ if (my ($url_index, $text_part, $url_part) =
+ # grep is no good here; we want to bail out immediately so that we can
+ # use $1, $2, etc. without having to do the match twice.
+ sub {
+ for (2..$#$ell) {
+ next if ref $ell->[$_];
+ next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s;
+ return ($_, $1, $2);
+ }
+ return;
+ }->()
+ ) {
+ $ell->[1]{'type'} = 'url';
+
+ my @text = @{$ell}[2..$url_index-1];
+ push @text, $text_part if defined $text_part;
+
+ my @url = @{$ell}[$url_index+1..$#$ell];
+ unshift @url, $url_part;
+
+ unless (@text) {
+ $ell->[1]{'content-implicit'} = 'yes';
+ @text = @url;
+ }
+
+ $ell->[1]{to} = Pod::Simple::LinkSection->new(
+ @url == 1
+ ? $url[0]
+ : [ '', {}, @url ],
+ );
+
+ splice @$ell, 2, $#$ell, @text;
+
+ next;
+ }
+
+ # Catch some very simple and/or common cases
+ if(@{$ell} == 3 and ! ref $ell->[2]) {
+ my $it = $ell->[2];
+ if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections
+ # Hopefully neither too broad nor too restrictive a RE
+ DEBUG > 1 and print "Catching \"$it\" as manpage link.\n";
+ $ell->[1]{'type'} = 'man';
+ # This's the only place where man links can get made.
+ $ell->[1]{'content-implicit'} = 'yes';
+ $ell->[1]{'to' } =
+ Pod::Simple::LinkSection->new( $it ); # treelet!
+
+ next;
+ }
+ if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
+ # Extremely forgiving idea of what constitutes a bare
+ # modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
+ DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n";
+ $ell->[1]{'type'} = 'pod';
+ $ell->[1]{'content-implicit'} = 'yes';
+ $ell->[1]{'to' } =
+ Pod::Simple::LinkSection->new( $it ); # treelet!
+ next;
+ }
+ # else fall thru...
+ }
+
+
+
+ # ...Uhoh, here's the real L<...> parsing stuff...
+ # "With the ill behavior, with the ill behavior, with the ill behavior..."
+
+ DEBUG > 1 and print "Running a real parse on this non-trivial L\n";
+
+
+ my $link_text; # set to an arrayref if found
+ my @ell_content = @$ell;
+ splice @ell_content,0,2; # Knock off the 'L' and {} bits
+
+ DEBUG > 3 and print " Ell content to start: ",
+ pretty(@ell_content), "\n";
+
+
+ # Look for the "|" -- only in CHILDREN (not all underlings!)
+ # Like L<I like the strictness|strict>
+ DEBUG > 3 and
+ print " Peering at L content for a '|' ...\n";
+ for(my $j = 0; $j < @ell_content; ++$j) {
+ next if ref $ell_content[$j];
+ DEBUG > 3 and
+ print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";
+
+ if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
+ my @link_text = ($1); # might be 0-length
+ $ell_content[$j] = $2; # might be 0-length
+
+ DEBUG > 3 and
+ print " FOUND a '|' in it. Splitting into [$1] + [$2]\n";
+
+ unshift @link_text, splice @ell_content, 0, $j;
+ # leaving only things at J and after
+ @ell_content = grep ref($_)||length($_), @ell_content ;
+ $link_text = [grep ref($_)||length($_), @link_text ];
+ DEBUG > 3 and printf
+ " So link text is %s\n and remaining ell content is %s\n",
+ pretty($link_text), pretty(@ell_content);
+ last;
+ }
+ }
+
+
+ # Now look for the "/" -- only in CHILDREN (not all underlings!)
+ # And afterward, anything left in @ell_content will be the raw name
+ # Like L<Foo::Bar/Object Methods>
+ my $section_name; # set to arrayref if found
+ DEBUG > 3 and print " Peering at L-content for a '/' ...\n";
+ for(my $j = 0; $j < @ell_content; ++$j) {
+ next if ref $ell_content[$j];
+ DEBUG > 3 and
+ print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";
+
+ if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
+ my @section_name = ($2); # might be 0-length
+ $ell_content[$j] = $1; # might be 0-length
+
+ DEBUG > 3 and
+ print " FOUND a '/' in it.",
+ " Splitting to page [...$1] + section [$2...]\n";
+
+ push @section_name, splice @ell_content, 1+$j;
+ # leaving only things before and including J
+
+ @ell_content = grep ref($_)||length($_), @ell_content ;
+ @section_name = grep ref($_)||length($_), @section_name ;
+
+ # Turn L<.../"foo"> into L<.../foo>
+ if(@section_name
+ and !ref($section_name[0]) and !ref($section_name[-1])
+ and $section_name[ 0] =~ m/^\"/s
+ and $section_name[-1] =~ m/\"$/s
+ and !( # catch weird degenerate case of L<"> !
+ @section_name == 1 and $section_name[0] eq '"'
+ )
+ ) {
+ $section_name[ 0] =~ s/^\"//s;
+ $section_name[-1] =~ s/\"$//s;
+ DEBUG > 3 and
+ print " Quotes removed: ", pretty(@section_name), "\n";
+ } else {
+ DEBUG > 3 and
+ print " No need to remove quotes in ", pretty(@section_name), "\n";
+ }
+
+ $section_name = \@section_name;
+ last;
+ }
+ }
+
+ # Turn L<"Foo Bar"> into L</Foo Bar>
+ if(!$section_name and @ell_content
+ and !ref($ell_content[0]) and !ref($ell_content[-1])
+ and $ell_content[ 0] =~ m/^\"/s
+ and $ell_content[-1] =~ m/\"$/s
+ and !( # catch weird degenerate case of L<"> !
+ @ell_content == 1 and $ell_content[0] eq '"'
+ )
+ ) {
+ $section_name = [splice @ell_content];
+ $section_name->[ 0] =~ s/^\"//s;
+ $section_name->[-1] =~ s/\"$//s;
+ }
+
+ # Turn L<Foo Bar> into L</Foo Bar>.
+ if(!$section_name and !$link_text and @ell_content
+ and grep !ref($_) && m/ /s, @ell_content
+ ) {
+ $section_name = [splice @ell_content];
+ # That's support for the now-deprecated syntax.
+ # (Maybe generate a warning eventually?)
+ # Note that it deliberately won't work on L<...|Foo Bar>
+ }
+
+
+ # Now make up the link_text
+ # L<Foo> -> L<Foo|Foo>
+ # L</Bar> -> L<"Bar"|Bar>
+ # L<Foo/Bar> -> L<"Bar" in Foo/Foo>
+ unless($link_text) {
+ $ell->[1]{'content-implicit'} = 'yes';
+ $link_text = [];
+ push @$link_text, '"', @$section_name, '"' if $section_name;
+
+ if(@ell_content) {
+ $link_text->[-1] .= ' in ' if $section_name;
+ push @$link_text, @ell_content;
+ }
+ }
+
+
+ # And the E resolver will have to deal with all our treeletty things:
+
+ if(@ell_content == 1 and !ref($ell_content[0])
+ and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s
+ ) {
+ $ell->[1]{'type'} = 'man';
+ DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n";
+ } else {
+ $ell->[1]{'type'} = 'pod';
+ DEBUG > 3 and print "Considering this a pod link (not man or url).\n";
+ }
+
+ if( defined $section_name ) {
+ $ell->[1]{'section'} = Pod::Simple::LinkSection->new(
+ ['', {}, @$section_name]
+ );
+ DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n";
+ }
+
+ if( @ell_content ) {
+ $ell->[1]{'to'} = Pod::Simple::LinkSection->new(
+ ['', {}, @ell_content]
+ );
+ DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n";
+ }
+
+ # And update children to be the link-text:
+ @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
+
+ DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n";
+
+ unshift @stack, $treelet->[$i]; # might as well recurse
+ }
+ }
+
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _treat_Es {
+ my($self,@stack) = @_;
+
+ my($i, $treelet, $content, $replacer, $charnum);
+ my $start_line = $stack[0][1]{'start_line'};
+
+ # A recursive algorithm implemented iteratively! Whee!
+
+
+ # Has frightening side effects on L nodes' attributes.
+
+ #my @ells_to_tweak;
+
+ while($treelet = shift @stack) {
+ for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
+ next unless ref $treelet->[$i]; # text nodes are uninteresting
+ if($treelet->[$i][0] eq 'L') {
+ # SPECIAL STUFF for semi-processed L<>'s
+
+ my $thing;
+ foreach my $attrname ('section', 'to') {
+ if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
+ unshift @stack, $thing;
+ DEBUG > 2 and print " Enqueuing ",
+ pretty( $treelet->[$i][1]{$attrname} ),
+ " as an attribute value to tweak.\n";
+ }
+ }
+
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ } elsif($treelet->[$i][0] ne 'E') {
+ unshift @stack, $treelet->[$i]; # recurse
+ next;
+ }
+
+ DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n";
+
+ # bitch if it's empty
+ if( @{$treelet->[$i]} == 2
+ or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
+ ) {
+ $self->whine( $start_line, "An empty E<>" );
+ $treelet->[$i] = 'E<>'; # splice in a literal
+ next;
+ }
+
+ # bitch if content is weird
+ unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
+ $self->whine( $start_line, "An E<...> surrounding strange content" );
+ $replacer = $treelet->[$i]; # scratch
+ splice(@$treelet, $i, 1, # fake out a literal
+ 'E<',
+ splice(@$replacer,2), # promote its content
+ '>'
+ );
+ # Don't need to do --$i, as the 'E<' we just added isn't interesting.
+ next;
+ }
+
+ DEBUG > 1 and print "Ogling E<$content>\n";
+
+ $charnum = Pod::Escapes::e2charnum($content);
+ DEBUG > 1 and print " Considering E<$content> with char ",
+ defined($charnum) ? $charnum : "undef", ".\n";
+
+ if(!defined( $charnum )) {
+ DEBUG > 1 and print "I don't know how to deal with E<$content>.\n";
+ $self->whine( $start_line, "Unknown E content in E<$content>" );
+ $replacer = "E<$content>"; # better than nothing
+ } elsif($charnum >= 255 and !UNICODE) {
+ $replacer = ASCII ? "\xA4" : "?";
+ DEBUG > 1 and print "This Perl version can't handle ",
+ "E<$content> (chr $charnum), so replacing with $replacer\n";
+ } else {
+ $replacer = Pod::Escapes::e2char($content);
+ DEBUG > 1 and print " Replacing E<$content> with $replacer\n";
+ }
+
+ splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
+ }
+ }
+
+ return;
+}
+
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _treat_Ss {
+ my($self,$treelet) = @_;
+
+ _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};
+
+ # TODO: or a change_nbsp_to_S
+ # Normalizing nbsp's to S is harder: for each text node, make S content
+ # out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/
+
+
+ return;
+}
+
+
+sub _change_S_to_nbsp { # a recursive function
+ # Sanely assumes that the top node in the excursion won't be an S node.
+ my($treelet, $in_s) = @_;
+
+ my $is_s = ('S' eq $treelet->[0]);
+ $in_s ||= $is_s; # So in_s is on either by this being an S element,
+ # or by an ancestor being an S element.
+
+ for(my $i = 2; $i < @$treelet; ++$i) {
+ if(ref $treelet->[$i]) {
+ if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
+ my $to_pull_up = $treelet->[$i];
+ splice @$to_pull_up,0,2; # ...leaving just its content
+ splice @$treelet, $i, 1, @$to_pull_up; # Pull up content
+ $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff
+ }
+ } else {
+ $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s;
+ # (If not in ASCIIland, we can't assume that \xA0 == nbsp.)
+
+ # Note that if you apply nbsp_for_S to text, and so turn
+ # "foo S<bar baz> quux" into "foo bar&#160;faz quux", you
+ # end up with something that fails to say "and don't hyphenate
+ # any part of 'bar baz'". However, hyphenation is such a vexing
+ # problem anyway, that most Pod renderers just don't render it
+ # at all. But if you do want to implement hyphenation, I guess
+ # that you'd better have nbsp_for_S off.
+ }
+ }
+
+ return $is_s;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _accessorize { # A simple-minded method-maker
+ no strict 'refs';
+ foreach my $attrname (@_) {
+ next if $attrname =~ m/::/; # a hack
+ *{caller() . '::' . $attrname} = sub {
+ use strict;
+ $Carp::CarpLevel = 1, Carp::croak(
+ "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
+ ) unless (@_ == 1 or @_ == 2) and ref $_[0];
+ (@_ == 1) ? $_[0]->{$attrname}
+ : ($_[0]->{$attrname} = $_[1]);
+ };
+ }
+ # Ya know, they say accessories make the ensemble!
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+#=============================================================================
+
+sub filter {
+ my($class, $source) = @_;
+ my $new = $class->new;
+ $new->output_fh(*STDOUT{IO});
+
+ if(ref($source || '') eq 'SCALAR') {
+ $new->parse_string_document( $$source );
+ } elsif(ref($source)) { # it's a file handle
+ $new->parse_file($source);
+ } else { # it's a filename
+ $new->parse_file($source);
+ }
+
+ return $new;
+}
+
+
+#-----------------------------------------------------------------------------
+
+sub _out {
+ # For use in testing: Class->_out($source)
+ # returns the transformation of $source
+
+ my $class = shift(@_);
+
+ my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
+
+ DEBUG and print "\n\n", '#' x 76,
+ "\nAbout to parse source: {{\n$_[0]\n}}\n\n";
+
+
+ my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new;
+ $parser->hide_line_numbers(1);
+
+ my $out = '';
+ $parser->output_string( \$out );
+ DEBUG and print " _out to ", \$out, "\n";
+
+ $mutor->($parser) if $mutor;
+
+ $parser->parse_string_document( $_[0] );
+ # use Data::Dumper; print Dumper($parser), "\n";
+ return $out;
+}
+
+
+sub _duo {
+ # For use in testing: Class->_duo($source1, $source2)
+ # returns the parse trees of $source1 and $source2.
+ # Good in things like: &ok( Class->duo(... , ...) );
+
+ my $class = shift(@_);
+
+ Carp::croak "But $class->_duo is useful only in list context!"
+ unless wantarray;
+
+ my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
+
+ Carp::croak "But $class->_duo takes two parameters, not: @_"
+ unless @_ == 2;
+
+ my(@out);
+
+ while( @_ ) {
+ my $parser = $class->new;
+
+ push @out, '';
+ $parser->output_string( \( $out[-1] ) );
+
+ DEBUG and print " _duo out to ", $parser->output_string(),
+ " = $parser->{'output_string'}\n";
+
+ $parser->hide_line_numbers(1);
+ $mutor->($parser) if $mutor;
+ $parser->parse_string_document( shift( @_ ) );
+ # use Data::Dumper; print Dumper($parser), "\n";
+ }
+
+ return @out;
+}
+
+
+
+#-----------------------------------------------------------------------------
+1;
+__END__
+
+TODO:
+A start_formatting_code and end_formatting_code methods, which in the
+base class call start_L, end_L, start_C, end_C, etc., if they are
+defined.
+
+have the POD FORMATTING ERRORS section note the localtime, and the
+version of Pod::Simple.
+
+option to delete all E<shy>s?
+option to scream if under-0x20 literals are found in the input, or
+under-E<32> E codes are found in the tree. And ditto \x7f-\x9f
+
+Option to turn highbit characters into their compromised form? (applies
+to E parsing too)
+
+TODO: BOM/encoding things.
+
+TODO: ascii-compat things in the XML classes?
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple.pod b/Master/tlpkg/tlperl.straw/lib/Pod/Simple.pod
new file mode 100755
index 00000000000..d3f168d7e0a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple.pod
@@ -0,0 +1,274 @@
+
+=head1 NAME
+
+Pod::Simple - framework for parsing Pod
+
+=head1 SYNOPSIS
+
+ TODO
+
+=head1 DESCRIPTION
+
+Pod::Simple is a Perl library for parsing text in the Pod ("plain old
+documentation") markup language that is typically used for writing
+documentation for Perl and for Perl modules. The Pod format is explained
+L<perlpod>; the most common formatter is called C<perldoc>.
+
+Pod formatters can use Pod::Simple to parse Pod documents and render them into
+plain text, HTML, or any number of other formats. Typically, such formatters
+will be subclasses of Pod::Simple, and so they will inherit its methods, like
+C<parse_file>.
+
+If you're reading this document just because you have a Pod-processing
+subclass that you want to use, this document (plus the documentation for the
+subclass) is probably all you need to read.
+
+If you're reading this document because you want to write a formatter
+subclass, continue reading it and then read L<Pod::Simple::Subclassing>, and
+then possibly even read L<perlpodspec> (some of which is for parser-writers,
+but much of which is notes to formatter-writers).
+
+=head1 MAIN METHODS
+
+=over
+
+=item C<< $parser = I<SomeClass>->new(); >>
+
+This returns a new parser object, where I<C<SomeClass>> is a subclass
+of Pod::Simple.
+
+=item C<< $parser->output_fh( *OUT ); >>
+
+This sets the filehandle that C<$parser>'s output will be written to.
+You can pass C<*STDOUT>, otherwise you should probably do something
+like this:
+
+ my $outfile = "output.txt";
+ open TXTOUT, ">$outfile" or die "Can't write to $outfile: $!";
+ $parser->output_fh(*TXTOUT);
+
+...before you call one of the C<< $parser->parse_I<whatever> >> methods.
+
+=item C<< $parser->output_string( \$somestring ); >>
+
+This sets the string that C<$parser>'s output will be sent to,
+instead of any filehandle.
+
+
+=item C<< $parser->parse_file( I<$some_filename> ); >>
+
+=item C<< $parser->parse_file( *INPUT_FH ); >>
+
+This reads the Pod content of the file (or filehandle) that you specify,
+and processes it with that C<$parser> object, according to however
+C<$parser>'s class works, and according to whatever parser options you
+have set up for this C<$parser> object.
+
+=item C<< $parser->parse_string_document( I<$all_content> ); >>
+
+This works just like C<parse_file> except that it reads the Pod
+content not from a file, but from a string that you have already
+in memory.
+
+=item C<< $parser->parse_lines( I<...@lines...>, undef ); >>
+
+This processes the lines in C<@lines> (where each list item must be a
+defined value, and must contain exactly one line of content -- so no
+items like C<"foo\nbar"> are allowed). The final C<undef> is used to
+indicate the end of document being parsed.
+
+The other C<parser_I<whatever>> methods are meant to be called only once
+per C<$parser> object; but C<parse_lines> can be called as many times per
+C<$parser> object as you want, as long as the last call (and only
+the last call) ends with an C<undef> value.
+
+
+=item C<< $parser->content_seen >>
+
+This returns true only if there has been any real content seen
+for this document.
+
+
+=item C<< I<SomeClass>->filter( I<$filename> ); >>
+
+=item C<< I<SomeClass>->filter( I<*INPUT_FH> ); >>
+
+=item C<< I<SomeClass>->filter( I<\$document_content> ); >>
+
+This is a shortcut method for creating a new parser object, setting the
+output handle to STDOUT, and then processing the specified file (or
+filehandle, or in-memory document). This is handy for one-liners like
+this:
+
+ perl -MPod::Simple::Text -e "Pod::Simple::Text->filter('thingy.pod')"
+
+=back
+
+
+
+=head1 SECONDARY METHODS
+
+Some of these methods might be of interest to general users, as
+well as of interest to formatter-writers.
+
+Note that the general pattern here is that the accessor-methods
+read the attribute's value with C<< $value = $parser->I<attribute> >>
+and set the attribute's value with
+C<< $parser->I<attribute>(I<newvalue>) >>. For each accessor, I typically
+only mention one syntax or another, based on which I think you are actually
+most likely to use.
+
+
+=over
+
+=item C<< $parser->no_whining( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, you will suppress the
+parser's complaints about irregularities in the Pod coding. By default,
+this attribute's value is false, meaning that irregularities will
+be reported.
+
+Note that turning this attribute to true won't suppress one or two kinds
+of complaints about rarely occurring unrecoverable errors.
+
+
+=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, you will stop the parser from
+generating a "POD ERRORS" section at the end of the document. By
+default, this attribute's value is false, meaning that an errata section
+will be generated, as necessary.
+
+
+=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, it will send reports of
+parsing errors to STDERR. By default, this attribute's value is false,
+meaning that no output is sent to STDERR.
+
+Setting C<complain_stderr> also sets C<no_errata_section>.
+
+
+=item C<< $parser->source_filename >>
+
+This returns the filename that this parser object was set to read from.
+
+
+=item C<< $parser->doc_has_started >>
+
+This returns true if C<$parser> has read from a source, and has seen
+Pod content in it.
+
+
+=item C<< $parser->source_dead >>
+
+This returns true if C<$parser> has read from a source, and come to the
+end of that source.
+
+=item C<< $parser->strip_verbatim_indent( I<SOMEVALUE> ) >>
+
+The perlpod spec for a Verbatim paragraph is "It should be reproduced
+exactly...", which means that the whitespace you've used to indent your
+verbatim blocks will be preserved in the output. This can be annoying for
+outputs such as HTML, where that whitespace will remain in front of every
+line. It's an unfortunate case where syntax is turned into semantics.
+
+If the POD your parsing adheres to a consistent indentation policy, you can
+have such indentation stripped from the beginning of every line of your
+verbatim blocks. This method tells Pod::Simple what to strip. For two-space
+indents, you'd use:
+
+ $parser->strip_verbatim_indent(' ');
+
+For tab indents, you'd use a tab character:
+
+ $parser->strip_verbatim_indent("\t");
+
+If the POD is inconsistent about the indentation of verbatim blocks, but you
+have figured out a heuristic to determine how much a particular verbatim block
+is indented, you can pass a code reference instead. The code reference will be
+executed with one argument, an array reference of all the lines in the
+verbatim block, and should return the value to be stripped from each line. For
+example, if you decide that you're fine to use the first line of the verbatim
+block to set the standard for indentation of the rest of the block, you can
+look at the first line and return the appropriate value, like so:
+
+ $new->strip_verbatim_indent(sub {
+ my $lines = shift;
+ (my $indent = $lines->[0]) =~ s/\S.*//;
+ return $indent;
+ });
+
+If you'd rather treat each line individually, you can do that, too, by just
+transforming them in-place in the code reference and returning C<undef>. Say
+that you don't want I<any> lines indented. You can do something like this:
+
+ $new->strip_verbatim_indent(sub {
+ my $lines = shift;
+ sub { s/^\s+// for @{ $lines },
+ return undef;
+ });
+
+=back
+
+=head1 CAVEATS
+
+This is just a beta release -- there are a good number of things still
+left to do. Notably, support for EBCDIC platforms is still half-done,
+an untested.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple::Subclassing>
+
+L<perlpod|perlpod>
+
+L<perlpodspec|perlpodspec>
+
+L<Pod::Escapes|Pod::Escapes>
+
+L<perldoc>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/BlackBox.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/BlackBox.pm
new file mode 100755
index 00000000000..c227d4cf460
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/BlackBox.pm
@@ -0,0 +1,1946 @@
+
+package Pod::Simple::BlackBox;
+#
+# "What's in the box?" "Pain."
+#
+###########################################################################
+#
+# This is where all the scary things happen: parsing lines into
+# paragraphs; and then into directives, verbatims, and then also
+# turning formatting sequences into treelets.
+#
+# Are you really sure you want to read this code?
+#
+#-----------------------------------------------------------------------------
+#
+# The basic work of this module Pod::Simple::BlackBox is doing the dirty work
+# of parsing Pod into treelets (generally one per non-verbatim paragraph), and
+# to call the proper callbacks on the treelets.
+#
+# Every node in a treelet is a ['name', {attrhash}, ...children...]
+
+use integer; # vroom!
+use strict;
+use Carp ();
+use vars qw($VERSION );
+$VERSION = '3.13';
+#use constant DEBUG => 7;
+BEGIN {
+ require Pod::Simple;
+ *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub parse_line { shift->parse_lines(@_) } # alias
+
+# - - - Turn back now! Run away! - - -
+
+sub parse_lines { # Usage: $parser->parse_lines(@lines)
+ # an undef means end-of-stream
+ my $self = shift;
+
+ my $code_handler = $self->{'code_handler'};
+ my $cut_handler = $self->{'cut_handler'};
+ $self->{'line_count'} ||= 0;
+
+ my $scratch;
+
+ DEBUG > 4 and
+ print "# Parsing starting at line ", $self->{'line_count'}, ".\n";
+
+ DEBUG > 5 and
+ print "# About to parse lines: ",
+ join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n";
+
+ my $paras = ($self->{'paras'} ||= []);
+ # paragraph buffer. Because we need to defer processing of =over
+ # directives and verbatim paragraphs. We call _ponder_paragraph_buffer
+ # to process this.
+
+ $self->{'pod_para_count'} ||= 0;
+
+ my $line;
+ foreach my $source_line (@_) {
+ if( $self->{'source_dead'} ) {
+ DEBUG > 4 and print "# Source is dead.\n";
+ last;
+ }
+
+ unless( defined $source_line ) {
+ DEBUG > 4 and print "# Undef-line seen.\n";
+
+ push @$paras, ['~end', {'start_line' => $self->{'line_count'}}];
+ push @$paras, $paras->[-1], $paras->[-1];
+ # So that it definitely fills the buffer.
+ $self->{'source_dead'} = 1;
+ $self->_ponder_paragraph_buffer;
+ next;
+ }
+
+
+ if( $self->{'line_count'}++ ) {
+ ($line = $source_line) =~ tr/\n\r//d;
+ # If we don't have two vars, we'll end up with that there
+ # tr/// modding the (potentially read-only) original source line!
+
+ } else {
+ DEBUG > 2 and print "First line: [$source_line]\n";
+
+ if( ($line = $source_line) =~ s/^\xEF\xBB\xBF//s ) {
+ DEBUG and print "UTF-8 BOM seen. Faking a '=encode utf8'.\n";
+ $self->_handle_encoding_line( "=encode utf8" );
+ $line =~ tr/\n\r//d;
+
+ } elsif( $line =~ s/^\xFE\xFF//s ) {
+ DEBUG and print "Big-endian UTF-16 BOM seen. Aborting parsing.\n";
+ $self->scream(
+ $self->{'line_count'},
+ "UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
+ );
+ splice @_;
+ push @_, undef;
+ next;
+
+ # TODO: implement somehow?
+
+ } elsif( $line =~ s/^\xFF\xFE//s ) {
+ DEBUG and print "Little-endian UTF-16 BOM seen. Aborting parsing.\n";
+ $self->scream(
+ $self->{'line_count'},
+ "UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
+ );
+ splice @_;
+ push @_, undef;
+ next;
+
+ # TODO: implement somehow?
+
+ } else {
+ DEBUG > 2 and print "First line is BOM-less.\n";
+ ($line = $source_line) =~ tr/\n\r//d;
+ }
+ }
+
+
+ DEBUG > 5 and print "# Parsing line: [$line]\n";
+
+ if(!$self->{'in_pod'}) {
+ if($line =~ m/^=([a-zA-Z]+)/s) {
+ if($1 eq 'cut') {
+ $self->scream(
+ $self->{'line_count'},
+ "=cut found outside a pod block. Skipping to next block."
+ );
+
+ ## Before there were errata sections in the world, it was
+ ## least-pessimal to abort processing the file. But now we can
+ ## just barrel on thru (but still not start a pod block).
+ #splice @_;
+ #push @_, undef;
+
+ next;
+ } else {
+ $self->{'in_pod'} = $self->{'start_of_pod_block'}
+ = $self->{'last_was_blank'} = 1;
+ # And fall thru to the pod-mode block further down
+ }
+ } else {
+ DEBUG > 5 and print "# It's a code-line.\n";
+ $code_handler->(map $_, $line, $self->{'line_count'}, $self)
+ if $code_handler;
+ # Note: this may cause code to be processed out of order relative
+ # to pods, but in order relative to cuts.
+
+ # Note also that we haven't yet applied the transcoding to $line
+ # by time we call $code_handler!
+
+ if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) {
+ # That RE is from perlsyn, section "Plain Old Comments (Not!)",
+ #$fname = $2 if defined $2;
+ #DEBUG > 1 and defined $2 and print "# Setting fname to \"$fname\"\n";
+ DEBUG > 1 and print "# Setting nextline to $1\n";
+ $self->{'line_count'} = $1 - 1;
+ }
+
+ next;
+ }
+ }
+
+ # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+ # Else we're in pod mode:
+
+ # Apply any necessary transcoding:
+ $self->{'_transcoder'} && $self->{'_transcoder'}->($line);
+
+ # HERE WE CATCH =encoding EARLY!
+ if( $line =~ m/^=encoding\s+\S+\s*$/s ) {
+ $line = $self->_handle_encoding_line( $line );
+ }
+
+ if($line =~ m/^=cut/s) {
+ # here ends the pod block, and therefore the previous pod para
+ DEBUG > 1 and print "Noting =cut at line ${$self}{'line_count'}\n";
+ $self->{'in_pod'} = 0;
+ # ++$self->{'pod_para_count'};
+ $self->_ponder_paragraph_buffer();
+ # by now it's safe to consider the previous paragraph as done.
+ $cut_handler->(map $_, $line, $self->{'line_count'}, $self)
+ if $cut_handler;
+
+ # TODO: add to docs: Note: this may cause cuts to be processed out
+ # of order relative to pods, but in order relative to code.
+
+ } elsif($line =~ m/^\s*$/s) { # it's a blank line
+ if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
+ DEBUG > 1 and print "Saving blank line at line ${$self}{'line_count'}\n";
+ push @{$paras->[-1]}, $line;
+ } # otherwise it's not interesting
+
+ if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) {
+ DEBUG > 1 and print "Noting para ends with blank line at ${$self}{'line_count'}\n";
+ }
+
+ $self->{'last_was_blank'} = 1;
+
+ } elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para...
+
+ if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) {
+ # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS
+ my $new = [$1, {'start_line' => $self->{'line_count'}}, $2];
+ # Note that in "=head1 foo", the WS is lost.
+ # Example: ['=head1', {'start_line' => 123}, ' foo']
+
+ ++$self->{'pod_para_count'};
+
+ $self->_ponder_paragraph_buffer();
+ # by now it's safe to consider the previous paragraph as done.
+
+ push @$paras, $new; # the new incipient paragraph
+ DEBUG > 1 and print "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n";
+
+ } elsif($line =~ m/^\s/s) {
+
+ if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
+ DEBUG > 1 and print "Resuming verbatim para at line ${$self}{'line_count'}\n";
+ push @{$paras->[-1]}, $line;
+ } else {
+ ++$self->{'pod_para_count'};
+ $self->_ponder_paragraph_buffer();
+ # by now it's safe to consider the previous paragraph as done.
+ DEBUG > 1 and print "Starting verbatim para at line ${$self}{'line_count'}\n";
+ push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line];
+ }
+ } else {
+ ++$self->{'pod_para_count'};
+ $self->_ponder_paragraph_buffer();
+ # by now it's safe to consider the previous paragraph as done.
+ push @$paras, ['~Para', {'start_line' => $self->{'line_count'}}, $line];
+ DEBUG > 1 and print "Starting plain para at line ${$self}{'line_count'}\n";
+ }
+ $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
+
+ } else {
+ # It's a non-blank line /continuing/ the current para
+ if(@$paras) {
+ DEBUG > 2 and print "Line ${$self}{'line_count'} continues current paragraph\n";
+ push @{$paras->[-1]}, $line;
+ } else {
+ # Unexpected case!
+ die "Continuing a paragraph but \@\$paras is empty?";
+ }
+ $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
+ }
+
+ } # ends the big while loop
+
+ DEBUG > 1 and print(pretty(@$paras), "\n");
+ return $self;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_encoding_line {
+ my($self, $line) = @_;
+
+ # The point of this routine is to set $self->{'_transcoder'} as indicated.
+
+ return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s;
+ DEBUG > 1 and print "Found an encoding line \"=encoding $1\"\n";
+
+ my $e = $1;
+ my $orig = $e;
+ push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig";
+
+ my $enc_error;
+
+ # Cf. perldoc Encode and perldoc Encode::Supported
+
+ require Pod::Simple::Transcode;
+
+ if( $self->{'encoding'} ) {
+ my $norm_current = $self->{'encoding'};
+ my $norm_e = $e;
+ foreach my $that ($norm_current, $norm_e) {
+ $that = lc($that);
+ $that =~ s/[-_]//g;
+ }
+ if($norm_current eq $norm_e) {
+ DEBUG > 1 and print "The '=encoding $orig' line is ",
+ "redundant. ($norm_current eq $norm_e). Ignoring.\n";
+ $enc_error = '';
+ # But that doesn't necessarily mean that the earlier one went okay
+ } else {
+ $enc_error = "Encoding is already set to " . $self->{'encoding'};
+ DEBUG > 1 and print $enc_error;
+ }
+ } elsif (
+ # OK, let's turn on the encoding
+ do {
+ DEBUG > 1 and print " Setting encoding to $e\n";
+ $self->{'encoding'} = $e;
+ 1;
+ }
+ and $e eq 'HACKRAW'
+ ) {
+ DEBUG and print " Putting in HACKRAW (no-op) encoding mode.\n";
+
+ } elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) {
+
+ die($enc_error = "WHAT? _transcoder is already set?!")
+ if $self->{'_transcoder'}; # should never happen
+ require Pod::Simple::Transcode;
+ $self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e);
+ eval {
+ my @x = ('', "abc", "123");
+ $self->{'_transcoder'}->(@x);
+ };
+ $@ && die( $enc_error =
+ "Really unexpected error setting up encoding $e: $@\nAborting"
+ );
+
+ } else {
+ my @supported = Pod::Simple::Transcode::->all_encodings;
+
+ # Note unsupported, and complain
+ DEBUG and print " Encoding [$e] is unsupported.",
+ "\nSupporteds: @supported\n";
+ my $suggestion = '';
+
+ # Look for a near match:
+ my $norm = lc($e);
+ $norm =~ tr[-_][]d;
+ my $n;
+ foreach my $enc (@supported) {
+ $n = lc($enc);
+ $n =~ tr[-_][]d;
+ next unless $n eq $norm;
+ $suggestion = " (Maybe \"$e\" should be \"$enc\"?)";
+ last;
+ }
+ my $encmodver = Pod::Simple::Transcode::->encmodver;
+ $enc_error = join '' =>
+ "This document probably does not appear as it should, because its ",
+ "\"=encoding $e\" line calls for an unsupported encoding.",
+ $suggestion, " [$encmodver\'s supported encodings are: @supported]"
+ ;
+
+ $self->scream( $self->{'line_count'}, $enc_error );
+ }
+ push @{ $self->{'encoding_command_statuses'} }, $enc_error;
+
+ return '=encoding ALREADYDONE';
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _handle_encoding_second_level {
+ # By time this is called, the encoding (if well formed) will already
+ # have been acted one.
+ my($self, $para) = @_;
+ my @x = @$para;
+ my $content = join ' ', splice @x, 2;
+ $content =~ s/^\s+//s;
+ $content =~ s/\s+$//s;
+
+ DEBUG > 2 and print "Ogling encoding directive: =encoding $content\n";
+
+ if($content eq 'ALREADYDONE') {
+ # It's already been handled. Check for errors.
+ if(! $self->{'encoding_command_statuses'} ) {
+ DEBUG > 2 and print " CRAZY ERROR: It wasn't really handled?!\n";
+ } elsif( $self->{'encoding_command_statuses'}[-1] ) {
+ $self->whine( $para->[1]{'start_line'},
+ sprintf "Couldn't do %s: %s",
+ $self->{'encoding_command_reqs' }[-1],
+ $self->{'encoding_command_statuses'}[-1],
+ );
+ } else {
+ DEBUG > 2 and print " (Yup, it was successfully handled already.)\n";
+ }
+
+ } else {
+ # Otherwise it's a syntax error
+ $self->whine( $para->[1]{'start_line'},
+ "Invalid =encoding syntax: $content"
+ );
+ }
+
+ return;
+}
+
+#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`
+
+{
+my $m = -321; # magic line number
+
+sub _gen_errata {
+ my $self = $_[0];
+ # Return 0 or more fake-o paragraphs explaining the accumulated
+ # errors on this document.
+
+ return() unless $self->{'errata'} and keys %{$self->{'errata'}};
+
+ my @out;
+
+ foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) {
+ push @out,
+ ['=item', {'start_line' => $m}, "Around line $line:"],
+ map( ['~Para', {'start_line' => $m, '~cooked' => 1},
+ #['~Top', {'start_line' => $m},
+ $_
+ #]
+ ],
+ @{$self->{'errata'}{$line}}
+ )
+ ;
+ }
+
+ # TODO: report of unknown entities? unrenderable characters?
+
+ unshift @out,
+ ['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'],
+ ['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1},
+ "Hey! ",
+ ['B', {},
+ 'The above document had some coding errors, which are explained below:'
+ ]
+ ],
+ ['=over', {'start_line' => $m, 'errata' => 1}, ''],
+ ;
+
+ push @out,
+ ['=back', {'start_line' => $m, 'errata' => 1}, ''],
+ ;
+
+ DEBUG and print "\n<<\n", pretty(\@out), "\n>>\n\n";
+
+ return @out;
+}
+
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+##############################################################################
+##
+## stop reading now stop reading now stop reading now stop reading now stop
+##
+## HERE IT BECOMES REALLY SCARY
+##
+## stop reading now stop reading now stop reading now stop reading now stop
+##
+##############################################################################
+
+sub _ponder_paragraph_buffer {
+
+ # Para-token types as found in the buffer.
+ # ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end,
+ # =over, =back, =item
+ # and the null =pod (to be complained about if over one line)
+ #
+ # "~data" paragraphs are something we generate at this level, depending on
+ # a currently open =over region
+
+ # Events fired: Begin and end for:
+ # directivename (like head1 .. head4), item, extend,
+ # for (from =begin...=end, =for),
+ # over-bullet, over-number, over-text, over-block,
+ # item-bullet, item-number, item-text,
+ # Document,
+ # Data, Para, Verbatim
+ # B, C, longdirname (TODO -- wha?), etc. for all directives
+ #
+
+ my $self = $_[0];
+ my $paras;
+ return unless @{$paras = $self->{'paras'}};
+ my $curr_open = ($self->{'curr_open'} ||= []);
+
+ my $scratch;
+
+ DEBUG > 10 and print "# Paragraph buffer: <<", pretty($paras), ">>\n";
+
+ # We have something in our buffer. So apparently the document has started.
+ unless($self->{'doc_has_started'}) {
+ $self->{'doc_has_started'} = 1;
+
+ my $starting_contentless;
+ $starting_contentless =
+ (
+ !@$curr_open
+ and @$paras and ! grep $_->[0] ne '~end', @$paras
+ # i.e., if the paras is all ~ends
+ )
+ ;
+ DEBUG and print "# Starting ",
+ $starting_contentless ? 'contentless' : 'contentful',
+ " document\n"
+ ;
+
+ $self->_handle_element_start(
+ ($scratch = 'Document'),
+ {
+ 'start_line' => $paras->[0][1]{'start_line'},
+ $starting_contentless ? ( 'contentless' => 1 ) : (),
+ },
+ );
+ }
+
+ my($para, $para_type);
+ while(@$paras) {
+ last if @$paras == 1 and
+ ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim'
+ or $paras->[0][0] eq '=item' )
+ ;
+ # Those're the three kinds of paragraphs that require lookahead.
+ # Actually, an "=item Foo" inside an <over type=text> region
+ # and any =item inside an <over type=block> region (rare)
+ # don't require any lookahead, but all others (bullets
+ # and numbers) do.
+
+# TODO: winge about many kinds of directives in non-resolving =for regions?
+# TODO: many? like what? =head1 etc?
+
+ $para = shift @$paras;
+ $para_type = $para->[0];
+
+ DEBUG > 1 and print "Pondering a $para_type paragraph, given the stack: (",
+ $self->_dump_curr_open(), ")\n";
+
+ if($para_type eq '=for') {
+ next if $self->_ponder_for($para,$curr_open,$paras);
+
+ } elsif($para_type eq '=begin') {
+ next if $self->_ponder_begin($para,$curr_open,$paras);
+
+ } elsif($para_type eq '=end') {
+ next if $self->_ponder_end($para,$curr_open,$paras);
+
+ } elsif($para_type eq '~end') { # The virtual end-document signal
+ next if $self->_ponder_doc_end($para,$curr_open,$paras);
+ }
+
+
+ # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+ #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+ if(grep $_->[1]{'~ignore'}, @$curr_open) {
+ DEBUG > 1 and
+ print "Skipping $para_type paragraph because in ignore mode.\n";
+ next;
+ }
+ #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+ # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+
+ if($para_type eq '=pod') {
+ $self->_ponder_pod($para,$curr_open,$paras);
+
+ } elsif($para_type eq '=over') {
+ next if $self->_ponder_over($para,$curr_open,$paras);
+
+ } elsif($para_type eq '=back') {
+ next if $self->_ponder_back($para,$curr_open,$paras);
+
+ } else {
+
+ # All non-magical codes!!!
+
+ # Here we start using $para_type for our own twisted purposes, to
+ # mean how it should get treated, not as what the element name
+ # should be.
+
+ DEBUG > 1 and print "Pondering non-magical $para_type\n";
+
+ my $i;
+
+ # Enforce some =headN discipline
+ if($para_type =~ m/^=head\d$/s
+ and ! $self->{'accept_heads_anywhere'}
+ and @$curr_open
+ and $curr_open->[-1][0] eq '=over'
+ ) {
+ DEBUG > 2 and print "'=$para_type' inside an '=over'!\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You forgot a '=back' before '$para_type'"
+ );
+ unshift @$paras, ['=back', {}, ''], $para; # close the =over
+ next;
+ }
+
+
+ if($para_type eq '=item') {
+
+ my $over;
+ unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "'=item' outside of any '=over'"
+ );
+ unshift @$paras,
+ ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
+ $para
+ ;
+ next;
+ }
+
+
+ my $over_type = $over->[1]{'~type'};
+
+ if(!$over_type) {
+ # Shouldn't happen1
+ die "Typeless over in stack, starting at line "
+ . $over->[1]{'start_line'};
+
+ } elsif($over_type eq 'block') {
+ unless($curr_open->[-1][1]{'~bitched_about'}) {
+ $curr_open->[-1][1]{'~bitched_about'} = 1;
+ $self->whine(
+ $curr_open->[-1][1]{'start_line'},
+ "You can't have =items (as at line "
+ . $para->[1]{'start_line'}
+ . ") unless the first thing after the =over is an =item"
+ );
+ }
+ # Just turn it into a paragraph and reconsider it
+ $para->[0] = '~Para';
+ unshift @$paras, $para;
+ next;
+
+ } elsif($over_type eq 'text') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'text') {
+ # Nothing special needs doing for 'text'
+ } elsif($item_type eq 'number' or $item_type eq 'bullet') {
+ die "Unknown item type $item_type"
+ unless $item_type eq 'number' or $item_type eq 'bullet';
+ # Undo our clobbering:
+ push @$para, $para->[1]{'~orig_content'};
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ # =item-text thingies don't need any assimilation, it seems.
+
+ } elsif($over_type eq 'number') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
+
+ if($item_type eq 'bullet') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # restore the bullet, blocking the assimilation of next para
+
+ } elsif($item_type eq 'text') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ # Text content will still be there and will block next ~Para
+
+ } elsif($item_type ne 'number') {
+ die "Unknown item type $item_type"; # should never happen
+
+ } elsif($expected_value == $para->[1]{'number'}) {
+ DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
+
+ } else {
+ DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
+ " instead of the expected value of $expected_value\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You have '=item " . $para->[1]{'number'} .
+ "' instead of the expected '=item $expected_value'"
+ );
+ $para->[1]{'number'} = $expected_value; # correcting!!
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+
+ } elsif($over_type eq 'bullet') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'bullet') {
+ # as expected!
+
+ if( $para->[1]{'~_freaky_para_hack'} ) {
+ DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
+ push @$para, delete $para->[1]{'~_freaky_para_hack'};
+ }
+
+ } elsif($item_type eq 'number') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # and block assimilation of the next paragraph
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } elsif($item_type eq 'text') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ # But doesn't need processing. But it'll block assimilation
+ # of the next para.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+ } else {
+ die "Unhandled =over type \"$over_type\"?";
+ # Shouldn't happen!
+ }
+
+ $para_type = 'Plain';
+ $para->[0] .= '-' . $over_type;
+ # Whew. Now fall thru and process it.
+
+
+ } elsif($para_type eq '=extend') {
+ # Well, might as well implement it here.
+ $self->_ponder_extend($para);
+ next; # and skip
+ } elsif($para_type eq '=encoding') {
+ # Not actually acted on here, but we catch errors here.
+ $self->_handle_encoding_second_level($para);
+
+ next; # and skip
+ } elsif($para_type eq '~Verbatim') {
+ $para->[0] = 'Verbatim';
+ $para_type = '?Verbatim';
+ } elsif($para_type eq '~Para') {
+ $para->[0] = 'Para';
+ $para_type = '?Plain';
+ } elsif($para_type eq 'Data') {
+ $para->[0] = 'Data';
+ $para_type = '?Data';
+ } elsif( $para_type =~ s/^=//s
+ and defined( $para_type = $self->{'accept_directives'}{$para_type} )
+ ) {
+ DEBUG > 1 and print " Pondering known directive ${$para}[0] as $para_type\n";
+ } else {
+ # An unknown directive!
+ DEBUG > 1 and printf "Unhandled directive %s (Handled: %s)\n",
+ $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} )
+ ;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Unknown directive: $para->[0]"
+ );
+
+ # And maybe treat it as text instead of just letting it go?
+ next;
+ }
+
+ if($para_type =~ s/^\?//s) {
+ if(! @$curr_open) { # usual case
+ DEBUG and print "Treating $para_type paragraph as such because stack is empty.\n";
+ } else {
+ my @fors = grep $_->[0] eq '=for', @$curr_open;
+ DEBUG > 1 and print "Containing fors: ",
+ join(',', map $_->[1]{'target'}, @fors), "\n";
+
+ if(! @fors) {
+ DEBUG and print "Treating $para_type paragraph as such because stack has no =for's\n";
+
+ #} elsif(grep $_->[1]{'~resolve'}, @fors) {
+ #} elsif(not grep !$_->[1]{'~resolve'}, @fors) {
+ } elsif( $fors[-1][1]{'~resolve'} ) {
+ # Look to the immediately containing for
+
+ if($para_type eq 'Data') {
+ DEBUG and print "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
+ $para->[0] = 'Para';
+ $para_type = 'Plain';
+ } else {
+ DEBUG and print "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
+ }
+ } else {
+ DEBUG and print "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n";
+ $para->[0] = $para_type = 'Data';
+ }
+ }
+ }
+
+ #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if($para_type eq 'Plain') {
+ $self->_ponder_Plain($para);
+ } elsif($para_type eq 'Verbatim') {
+ $self->_ponder_Verbatim($para);
+ } elsif($para_type eq 'Data') {
+ $self->_ponder_Data($para);
+ } else {
+ die "\$para type is $para_type -- how did that happen?";
+ # Shouldn't happen.
+ }
+
+ #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ $para->[0] =~ s/^[~=]//s;
+
+ DEBUG and print "\n", pretty($para), "\n";
+
+ # traverse the treelet (which might well be just one string scalar)
+ $self->{'content_seen'} ||= 1;
+ $self->_traverse_treelet_bit(@$para);
+ }
+ }
+
+ return;
+}
+
+###########################################################################
+# The sub-ponderers...
+
+
+
+sub _ponder_for {
+ my ($self,$para,$curr_open,$paras) = @_;
+
+ # Fake it out as a begin/end
+ my $target;
+
+ if(grep $_->[1]{'~ignore'}, @$curr_open) {
+ DEBUG > 1 and print "Ignoring ignorable =for\n";
+ return 1;
+ }
+
+ for(my $i = 2; $i < @$para; ++$i) {
+ if($para->[$i] =~ s/^\s*(\S+)\s*//s) {
+ $target = $1;
+ last;
+ }
+ }
+ unless(defined $target) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=for without a target?"
+ );
+ return 1;
+ }
+ DEBUG > 1 and
+ print "Faking out a =for $target as a =begin $target / =end $target\n";
+
+ $para->[0] = 'Data';
+
+ unshift @$paras,
+ ['=begin',
+ {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
+ $target,
+ ],
+ $para,
+ ['=end',
+ {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
+ $target,
+ ],
+ ;
+
+ return 1;
+}
+
+sub _ponder_begin {
+ my ($self,$para,$curr_open,$paras) = @_;
+ my $content = join ' ', splice @$para, 2;
+ $content =~ s/^\s+//s;
+ $content =~ s/\s+$//s;
+ unless(length($content)) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=begin without a target?"
+ );
+ DEBUG and print "Ignoring targetless =begin\n";
+ return 1;
+ }
+
+ my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/;
+ $para->[1]{'title'} = $title if ($title);
+ $para->[1]{'target'} = $target; # without any ':'
+ $content = $target; # strip off the title
+
+ $content =~ s/^:!/!:/s;
+ my $neg; # whether this is a negation-match
+ $neg = 1 if $content =~ s/^!//s;
+ my $to_resolve; # whether to process formatting codes
+ $to_resolve = 1 if $content =~ s/^://s;
+
+ my $dont_ignore; # whether this target matches us
+
+ foreach my $target_name (
+ split(',', $content, -1),
+ $neg ? () : '*'
+ ) {
+ DEBUG > 2 and
+ print " Considering whether =begin $content matches $target_name\n";
+ next unless $self->{'accept_targets'}{$target_name};
+
+ DEBUG > 2 and
+ print " It DOES match the acceptable target $target_name!\n";
+ $to_resolve = 1
+ if $self->{'accept_targets'}{$target_name} eq 'force_resolve';
+ $dont_ignore = 1;
+ $para->[1]{'target_matching'} = $target_name;
+ last; # stop looking at other target names
+ }
+
+ if($neg) {
+ if( $dont_ignore ) {
+ $dont_ignore = '';
+ delete $para->[1]{'target_matching'};
+ DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n";
+ } else {
+ $dont_ignore = 1;
+ $para->[1]{'target_matching'} = '!';
+ DEBUG > 2 and print " But the leading ! means that this IS a match!\n";
+ }
+ }
+
+ $para->[0] = '=for'; # Just what we happen to call these, internally
+ $para->[1]{'~really'} ||= '=begin';
+ $para->[1]{'~ignore'} = (! $dont_ignore) || 0;
+ $para->[1]{'~resolve'} = $to_resolve || 0;
+
+ DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '',
+ "ignore contents of this region\n";
+ DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ",
+ ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n";
+ DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n";
+
+ push @$curr_open, $para;
+ if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) {
+ DEBUG > 1 and print "Ignoring ignorable =begin\n";
+ } else {
+ $self->{'content_seen'} ||= 1;
+ $self->_handle_element_start((my $scratch='for'), $para->[1]);
+ }
+
+ return 1;
+}
+
+sub _ponder_end {
+ my ($self,$para,$curr_open,$paras) = @_;
+ my $content = join ' ', splice @$para, 2;
+ $content =~ s/^\s+//s;
+ $content =~ s/\s+$//s;
+ DEBUG and print "Ogling '=end $content' directive\n";
+
+ unless(length($content)) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "'=end' without a target?" . (
+ ( @$curr_open and $curr_open->[-1][0] eq '=for' )
+ ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' )
+ : ''
+ )
+ );
+ DEBUG and print "Ignoring targetless =end\n";
+ return 1;
+ }
+
+ unless($content =~ m/^\S+$/) { # i.e., unless it's one word
+ $self->whine(
+ $para->[1]{'start_line'},
+ "'=end $content' is invalid. (Stack: "
+ . $self->_dump_curr_open() . ')'
+ );
+ DEBUG and print "Ignoring mistargetted =end $content\n";
+ return 1;
+ }
+
+ unless(@$curr_open and $curr_open->[-1][0] eq '=for') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=end $content without matching =begin. (Stack: "
+ . $self->_dump_curr_open() . ')'
+ );
+ DEBUG and print "Ignoring mistargetted =end $content\n";
+ return 1;
+ }
+
+ unless($content eq $curr_open->[-1][1]{'target'}) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=end $content doesn't match =begin "
+ . $curr_open->[-1][1]{'target'}
+ . ". (Stack: "
+ . $self->_dump_curr_open() . ')'
+ );
+ DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n";
+ return 1;
+ }
+
+ # Else it's okay to close...
+ if(grep $_->[1]{'~ignore'}, @$curr_open) {
+ DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n";
+ # And that may be because of this to-be-closed =for region, or some
+ # other one, but it doesn't matter.
+ } else {
+ $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'};
+ # what's that for?
+
+ $self->{'content_seen'} ||= 1;
+ $self->_handle_element_end( my $scratch = 'for' );
+ }
+ DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n";
+ pop @$curr_open;
+
+ return 1;
+}
+
+sub _ponder_doc_end {
+ my ($self,$para,$curr_open,$paras) = @_;
+ if(@$curr_open) { # Deal with things left open
+ DEBUG and print "Stack is nonempty at end-document: (",
+ $self->_dump_curr_open(), ")\n";
+
+ DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n";
+ unshift @$paras, $self->_closers_for_all_curr_open;
+ # Make sure there is exactly one ~end in the parastack, at the end:
+ @$paras = grep $_->[0] ne '~end', @$paras;
+ push @$paras, $para, $para;
+ # We need two -- once for the next cycle where we
+ # generate errata, and then another to be at the end
+ # when that loop back around to process the errata.
+ return 1;
+
+ } else {
+ DEBUG and print "Okay, stack is empty now.\n";
+ }
+
+ # Try generating errata section, if applicable
+ unless($self->{'~tried_gen_errata'}) {
+ $self->{'~tried_gen_errata'} = 1;
+ my @extras = $self->_gen_errata();
+ if(@extras) {
+ unshift @$paras, @extras;
+ DEBUG and print "Generated errata... relooping...\n";
+ return 1; # I.e., loop around again to process these fake-o paragraphs
+ }
+ }
+
+ splice @$paras; # Well, that's that for this paragraph buffer.
+ DEBUG and print "Throwing end-document event.\n";
+
+ $self->_handle_element_end( my $scratch = 'Document' );
+ return 1; # Hasta la byebye
+}
+
+sub _ponder_pod {
+ my ($self,$para,$curr_open,$paras) = @_;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=pod directives shouldn't be over one line long! Ignoring all "
+ . (@$para - 2) . " lines of content"
+ ) if @$para > 3;
+ # Content is always ignored.
+ return;
+}
+
+sub _ponder_over {
+ my ($self,$para,$curr_open,$paras) = @_;
+ return 1 unless @$paras;
+ my $list_type;
+
+ if($paras->[0][0] eq '=item') { # most common case
+ $list_type = $self->_get_initial_item_type($paras->[0]);
+
+ } elsif($paras->[0][0] eq '=back') {
+ # Ignore empty lists. TODO: make this an option?
+ shift @$paras;
+ return 1;
+
+ } elsif($paras->[0][0] eq '~end') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=over is the last thing in the document?!"
+ );
+ return 1; # But feh, ignore it.
+ } else {
+ $list_type = 'block';
+ }
+ $para->[1]{'~type'} = $list_type;
+ push @$curr_open, $para;
+ # yes, we reuse the paragraph as a stack item
+
+ my $content = join ' ', splice @$para, 2;
+ my $overness;
+ if($content =~ m/^\s*$/s) {
+ $para->[1]{'indent'} = 4;
+ } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) {
+ no integer;
+ $para->[1]{'indent'} = $1;
+ if($1 == 0) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Can't have a 0 in =over $content"
+ );
+ $para->[1]{'indent'} = 4;
+ }
+ } else {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=over should be: '=over' or '=over positive_number'"
+ );
+ $para->[1]{'indent'} = 4;
+ }
+ DEBUG > 1 and print "=over found of type $list_type\n";
+
+ $self->{'content_seen'} ||= 1;
+ $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]);
+
+ return;
+}
+
+sub _ponder_back {
+ my ($self,$para,$curr_open,$paras) = @_;
+ # TODO: fire off </item-number> or </item-bullet> or </item-text> ??
+
+ my $content = join ' ', splice @$para, 2;
+ if($content =~ m/\S/) {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "=back doesn't take any parameters, but you said =back $content"
+ );
+ }
+
+ if(@$curr_open and $curr_open->[-1][0] eq '=over') {
+ DEBUG > 1 and print "=back happily closes matching =over\n";
+ # Expected case: we're closing the most recently opened thing
+ #my $over = pop @$curr_open;
+ $self->{'content_seen'} ||= 1;
+ $self->_handle_element_end( my $scratch =
+ 'over-' . ( (pop @$curr_open)->[1]{'~type'} )
+ );
+ } else {
+ DEBUG > 1 and print "=back found without a matching =over. Stack: (",
+ join(', ', map $_->[0], @$curr_open), ").\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ '=back without =over'
+ );
+ return 1; # and ignore it
+ }
+}
+
+sub _ponder_item {
+ my ($self,$para,$curr_open,$paras) = @_;
+ my $over;
+ unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "'=item' outside of any '=over'"
+ );
+ unshift @$paras,
+ ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
+ $para
+ ;
+ return 1;
+ }
+
+
+ my $over_type = $over->[1]{'~type'};
+
+ if(!$over_type) {
+ # Shouldn't happen1
+ die "Typeless over in stack, starting at line "
+ . $over->[1]{'start_line'};
+
+ } elsif($over_type eq 'block') {
+ unless($curr_open->[-1][1]{'~bitched_about'}) {
+ $curr_open->[-1][1]{'~bitched_about'} = 1;
+ $self->whine(
+ $curr_open->[-1][1]{'start_line'},
+ "You can't have =items (as at line "
+ . $para->[1]{'start_line'}
+ . ") unless the first thing after the =over is an =item"
+ );
+ }
+ # Just turn it into a paragraph and reconsider it
+ $para->[0] = '~Para';
+ unshift @$paras, $para;
+ return 1;
+
+ } elsif($over_type eq 'text') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'text') {
+ # Nothing special needs doing for 'text'
+ } elsif($item_type eq 'number' or $item_type eq 'bullet') {
+ die "Unknown item type $item_type"
+ unless $item_type eq 'number' or $item_type eq 'bullet';
+ # Undo our clobbering:
+ push @$para, $para->[1]{'~orig_content'};
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ # =item-text thingies don't need any assimilation, it seems.
+
+ } elsif($over_type eq 'number') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
+
+ if($item_type eq 'bullet') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # restore the bullet, blocking the assimilation of next para
+
+ } elsif($item_type eq 'text') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ # Text content will still be there and will block next ~Para
+
+ } elsif($item_type ne 'number') {
+ die "Unknown item type $item_type"; # should never happen
+
+ } elsif($expected_value == $para->[1]{'number'}) {
+ DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
+
+ } else {
+ DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
+ " instead of the expected value of $expected_value\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You have '=item " . $para->[1]{'number'} .
+ "' instead of the expected '=item $expected_value'"
+ );
+ $para->[1]{'number'} = $expected_value; # correcting!!
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+
+ } elsif($over_type eq 'bullet') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'bullet') {
+ # as expected!
+
+ if( $para->[1]{'~_freaky_para_hack'} ) {
+ DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
+ push @$para, delete $para->[1]{'~_freaky_para_hack'};
+ }
+
+ } elsif($item_type eq 'number') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # and block assimilation of the next paragraph
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } elsif($item_type eq 'text') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ # But doesn't need processing. But it'll block assimilation
+ # of the next para.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+ } else {
+ die "Unhandled =over type \"$over_type\"?";
+ # Shouldn't happen!
+ }
+ $para->[0] .= '-' . $over_type;
+
+ return;
+}
+
+sub _ponder_Plain {
+ my ($self,$para) = @_;
+ DEBUG and print " giving plain treatment...\n";
+ unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' )
+ or $para->[1]{'~cooked'}
+ ) {
+ push @$para,
+ @{$self->_make_treelet(
+ join("\n", splice(@$para, 2)),
+ $para->[1]{'start_line'}
+ )};
+ }
+ # Empty paragraphs don't need a treelet for any reason I can see.
+ # And precooked paragraphs already have a treelet.
+ return;
+}
+
+sub _ponder_Verbatim {
+ my ($self,$para) = @_;
+ DEBUG and print " giving verbatim treatment...\n";
+
+ $para->[1]{'xml:space'} = 'preserve';
+
+ my $indent = $self->strip_verbatim_indent;
+ if ($indent && ref $indent eq 'CODE') {
+ my @shifted = (shift @{$para}, shift @{$para});
+ $indent = $indent->($para);
+ unshift @{$para}, @shifted;
+ }
+
+ for(my $i = 2; $i < @$para; $i++) {
+ foreach my $line ($para->[$i]) { # just for aliasing
+ # Strip indentation.
+ $line =~ s/^\E$indent// if $indent
+ && !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted});
+ while( $line =~
+ # Sort of adapted from Text::Tabs -- yes, it's hardwired in that
+ # tabs are at every EIGHTH column. For portability, it has to be
+ # one setting everywhere, and 8th wins.
+ s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
+ ) {}
+
+ # TODO: whinge about (or otherwise treat) unindented or overlong lines
+
+ }
+ }
+
+ # Now the VerbatimFormatted hoodoo...
+ if( $self->{'accept_codes'} and
+ $self->{'accept_codes'}{'VerbatimFormatted'}
+ ) {
+ while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para }
+ # Kill any number of terminal newlines
+ $self->_verbatim_format($para);
+ } elsif ($self->{'codes_in_verbatim'}) {
+ push @$para,
+ @{$self->_make_treelet(
+ join("\n", splice(@$para, 2)),
+ $para->[1]{'start_line'}, $para->[1]{'xml:space'}
+ )};
+ $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
+ } else {
+ push @$para, join "\n", splice(@$para, 2) if @$para > 3;
+ $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
+ }
+ return;
+}
+
+sub _ponder_Data {
+ my ($self,$para) = @_;
+ DEBUG and print " giving data treatment...\n";
+ $para->[1]{'xml:space'} = 'preserve';
+ push @$para, join "\n", splice(@$para, 2) if @$para > 3;
+ return;
+}
+
+
+
+
+###########################################################################
+
+sub _traverse_treelet_bit { # for use only by the routine above
+ my($self, $name) = splice @_,0,2;
+
+ my $scratch;
+ $self->_handle_element_start(($scratch=$name), shift @_);
+
+ foreach my $x (@_) {
+ if(ref($x)) {
+ &_traverse_treelet_bit($self, @$x);
+ } else {
+ $self->_handle_text($x);
+ }
+ }
+
+ $self->_handle_element_end($scratch=$name);
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _closers_for_all_curr_open {
+ my $self = $_[0];
+ my @closers;
+ foreach my $still_open (@{ $self->{'curr_open'} || return }) {
+ my @copy = @$still_open;
+ $copy[1] = {%{ $copy[1] }};
+ #$copy[1]{'start_line'} = -1;
+ if($copy[0] eq '=for') {
+ $copy[0] = '=end';
+ } elsif($copy[0] eq '=over') {
+ $copy[0] = '=back';
+ } else {
+ die "I don't know how to auto-close an open $copy[0] region";
+ }
+
+ unless( @copy > 2 ) {
+ push @copy, $copy[1]{'target'};
+ $copy[-1] = '' unless defined $copy[-1];
+ # since =over's don't have targets
+ }
+
+ DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n";
+ unshift @closers, \@copy;
+ }
+ return @closers;
+}
+
+#--------------------------------------------------------------------------
+
+sub _verbatim_format {
+ my($it, $p) = @_;
+
+ my $formatting;
+
+ for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines
+ DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n";
+ $p->[$i] .= "\n";
+ # Unlike with simple Verbatim blocks, we don't end up just doing
+ # a join("\n", ...) on the contents, so we have to append a
+ # newline to ever line, and then nix the last one later.
+ }
+
+ if( DEBUG > 4 ) {
+ print "<<\n";
+ for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
+ print "_verbatim_format $i: $p->[$i]";
+ }
+ print ">>\n";
+ }
+
+ for(my $i = $#$p; $i > 2; $i--) {
+ # work backwards over the lines, except the first (#2)
+
+ #next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s
+ # and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s;
+ # look at a formatty line preceding a nonformatty one
+ DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n";
+ if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) {
+ DEBUG > 5 and print " It's a formatty line. ",
+ "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n";
+
+ if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) {
+ DEBUG > 5 and print " Previous line is formatty! Skipping this one.\n";
+ next;
+ } else {
+ DEBUG > 5 and print " Previous line is non-formatty! Yay!\n";
+ }
+ } else {
+ DEBUG > 5 and print " It's not a formatty line. Ignoring\n";
+ next;
+ }
+
+ # A formatty line has to have #: in the first two columns, and uses
+ # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic.
+ # Example:
+ # What do you want? i like pie. [or whatever]
+ # #:^^^^^^^^^^^^^^^^^ /////////////
+
+
+ DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n";
+
+ $formatting = ' ' . $1;
+ $formatting =~ s/\s+$//s; # nix trailing whitespace
+ unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op
+ splice @$p,$i,1; # remove this line
+ $i--; # don't consider next line
+ next;
+ }
+
+ if( length($formatting) >= length($p->[$i-1]) ) {
+ $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' ';
+ } else {
+ $formatting .= ' ' x (length($p->[$i-1]) - length($formatting));
+ }
+ # Make $formatting and the previous line be exactly the same length,
+ # with $formatting having a " " as the last character.
+
+ DEBUG > 4 and print "Formatting <$formatting> on <", $p->[$i-1], ">\n";
+
+
+ my @new_line;
+ while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) {
+ #print "Format matches $1\n";
+
+ if($2) {
+ #print "SKIPPING <$2>\n";
+ push @new_line,
+ substr($p->[$i-1], pos($formatting)-length($1), length($1));
+ } else {
+ #print "SNARING $+\n";
+ push @new_line, [
+ (
+ $3 ? 'VerbatimB' :
+ $4 ? 'VerbatimI' :
+ $5 ? 'VerbatimBI' : die("Should never get called")
+ ), {},
+ substr($p->[$i-1], pos($formatting)-length($1), length($1))
+ ];
+ #print "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n";
+ }
+ }
+ my @nixed =
+ splice @$p, $i-1, 2, @new_line; # replace myself and the next line
+ DEBUG > 10 and print "Nixed count: ", scalar(@nixed), "\n";
+
+ DEBUG > 6 and print "New version of the above line is these tokens (",
+ scalar(@new_line), "):",
+ map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n";
+ $i--; # So the next line we scrutinize is the line before the one
+ # that we just went and formatted
+ }
+
+ $p->[0] = 'VerbatimFormatted';
+
+ # Collapse adjacent text nodes, just for kicks.
+ for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last
+ if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) {
+ DEBUG > 5 and print "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n";
+ $p->[$i] .= splice @$p, $i+1, 1; # merge
+ --$i; # and back up
+ }
+ }
+
+ # Now look for the last text token, and remove the terminal newline
+ for( my $i = $#$p; $i >= 2; $i-- ) {
+ # work backwards over the tokens, even the first
+ if( !ref($p->[$i]) ) {
+ if($p->[$i] =~ s/\n$//s) {
+ DEBUG > 5 and print "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n";
+ } else {
+ DEBUG > 5 and print
+ "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n";
+ }
+ last; # we only want the next one
+ }
+ }
+
+ return;
+}
+
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+
+sub _treelet_from_formatting_codes {
+ # Given a paragraph, returns a treelet. Full of scary tokenizing code.
+ # Like [ '~Top', {'start_line' => $start_line},
+ # "I like ",
+ # [ 'B', {}, "pie" ],
+ # "!"
+ # ]
+
+ my($self, $para, $start_line, $preserve_space) = @_;
+
+ my $treelet = ['~Top', {'start_line' => $start_line},];
+
+ unless ($preserve_space || $self->{'preserve_whitespace'}) {
+ $para =~ s/\s+/ /g; # collapse and trim all whitespace first.
+ $para =~ s/ $//;
+ $para =~ s/^ //;
+ }
+
+ # Only apparent problem the above code is that N<< >> turns into
+ # N<< >>. But then, word wrapping does that too! So don't do that!
+
+ my @stack;
+ my @lineage = ($treelet);
+
+ DEBUG > 4 and print "Paragraph:\n$para\n\n";
+
+ # Here begins our frightening tokenizer RE. The following regex matches
+ # text in four main parts:
+ #
+ # * Start-codes. The first alternative matches C< or C<<, the latter
+ # followed by some whitespace. $1 will hold the entire start code
+ # (including any space following a multiple-angle-bracket delimiter),
+ # and $2 will hold only the additional brackets past the first in a
+ # multiple-bracket delimiter. length($2) + 1 will be the number of
+ # closing brackets we have to find.
+ #
+ # * Closing brackets. Match some amount of whitespace followed by
+ # multiple close brackets. The logic to see if this closes anything
+ # is down below. Note that in order to parse C<< >> correctly, we
+ # have to use look-behind (?<=\s\s), since the match of the starting
+ # code will have consumed the whitespace.
+ #
+ # * A single closing bracket, to close a simple code like C<>.
+ #
+ # * Something that isn't a start or end code. We have to be careful
+ # about accepting whitespace, since perlpodspec says that any whitespace
+ # before a multiple-bracket closing delimiter should be ignored.
+ #
+ while($para =~
+ m/\G
+ (?:
+ # Match starting codes, including the whitespace following a
+ # multiple-delimiter start code. $1 gets the whole start code and
+ # $2 gets all but one of the <s in the multiple-bracket case.
+ ([A-Z]<(?:(<+)\s+)?)
+ |
+ # Match multiple-bracket end codes. $3 gets the whitespace that
+ # should be discarded before an end bracket but kept in other cases
+ # and $4 gets the end brackets themselves.
+ (\s+|(?<=\s\s))(>{2,})
+ |
+ (\s?>) # $5: simple end-codes
+ |
+ ( # $6: stuff containing no start-codes or end-codes
+ (?:
+ [^A-Z\s>]
+ |
+ (?:
+ [A-Z](?!<)
+ )
+ |
+ # whitespace is ok, but we don't want to eat the whitespace before
+ # a multiple-bracket end code.
+ # NOTE: we may still have problems with e.g. S<< >>
+ (?:
+ \s(?!\s*>{2,})
+ )
+ )+
+ )
+ )
+ /xgo
+ ) {
+ DEBUG > 4 and print "\nParagraphic tokenstack = (@stack)\n";
+ if(defined $1) {
+ if(defined $2) {
+ DEBUG > 3 and print "Found complex start-text code \"$1\"\n";
+ # signal that we're looking for simple unless we're in complex.
+ if ($stack[-1]) {
+ # We're in complex already. It's just stuff.
+ DEBUG > 4 and print " It's just stuff.\n";
+ push @{ $lineage[-1] }, $1;
+ } else {
+ # length of the necessary complex end-code string
+ push @stack, length($2) + 1;
+ push @lineage, [ substr($1,0,1), {}, ]; # new node object
+ push @{ $lineage[-2] }, $lineage[-1];
+ }
+ } else {
+ DEBUG > 3 and print "Found simple start-text code \"$1\"\n";
+ if ($stack[-1]) {
+ # We're in complex already. It's just stuff.
+ DEBUG > 4 and print " It's just stuff.\n";
+ push @{ $lineage[-1] }, $1;
+ } else {
+ # signal that we're looking for simple.
+ push @stack, 0;
+ push @lineage, [ substr($1,0,1), {}, ]; # new node object
+ push @{ $lineage[-2] }, $lineage[-1];
+ }
+ }
+ } elsif(defined $4) {
+ DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n";
+ # This is where it gets messy...
+ if(! @stack) {
+ # We saw " >>>>" but needed nothing. This is ALL just stuff then.
+ DEBUG > 4 and print " But it's really just stuff.\n";
+ push @{ $lineage[-1] }, $3, $4;
+ next;
+ } elsif(!$stack[-1]) {
+ # We saw " >>>>" but needed only ">". Back pos up.
+ DEBUG > 4 and print " And that's more than we needed to close simple.\n";
+ push @{ $lineage[-1] }, $3; # That was a for-real space, too.
+ pos($para) = pos($para) - length($4) + 1;
+ } elsif($stack[-1] == length($4)) {
+ # We found " >>>>", and it was exactly what we needed. Commonest case.
+ DEBUG > 4 and print " And that's exactly what we needed to close complex.\n";
+ } elsif($stack[-1] < length($4)) {
+ # We saw " >>>>" but needed only " >>". Back pos up.
+ DEBUG > 4 and print " And that's more than we needed to close complex.\n";
+ pos($para) = pos($para) - length($4) + $stack[-1];
+ } else {
+ # We saw " >>>>" but needed " >>>>>>". So this is all just stuff!
+ DEBUG > 4 and print " But it's really just stuff, because we needed more.\n";
+ push @{ $lineage[-1] }, $3, $4;
+ next;
+ }
+ #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n";
+
+ push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
+ # Keep the element from being childless
+
+ pop @stack;
+ pop @lineage;
+
+ } elsif(defined $5) {
+ DEBUG > 3 and print "Found apparent simple end-text code \"$5\"\n";
+
+ if(@stack and ! $stack[-1]) {
+ # We're indeed expecting a simple end-code
+ DEBUG > 4 and print " It's indeed an end-code.\n";
+
+ if(length($5) == 2) { # There was a space there: " >"
+ push @{ $lineage[-1] }, ' ';
+ } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element
+ push @{ $lineage[-1] }, ''; # keep it from being really childless
+ }
+
+ pop @stack;
+ pop @lineage;
+ } else {
+ DEBUG > 4 and print " It's just stuff.\n";
+ push @{ $lineage[-1] }, $5;
+ }
+
+ } elsif(defined $6) {
+ DEBUG > 3 and print "Found stuff \"$6\"\n";
+ push @{ $lineage[-1] }, $6;
+
+ } else {
+ # should never ever ever ever happen
+ DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n";
+ die "SPORK 512512!";
+ }
+ }
+
+ if(@stack) { # Uhoh, some sequences weren't closed.
+ my $x= "...";
+ while(@stack) {
+ push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
+ # Hmmmmm!
+
+ my $code = (pop @lineage)->[0];
+ my $ender_length = pop @stack;
+ if($ender_length) {
+ --$ender_length;
+ $x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length);
+ } else {
+ $x = $code . "<$x>";
+ }
+ }
+ DEBUG > 1 and print "Unterminated $x sequence\n";
+ $self->whine($start_line,
+ "Unterminated $x sequence",
+ );
+ }
+
+ return $treelet;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub text_content_of_treelet { # method: $parser->text_content_of_treelet($lol)
+ return stringify_lol($_[1]);
+}
+
+sub stringify_lol { # function: stringify_lol($lol)
+ my $string_form = '';
+ _stringify_lol( $_[0] => \$string_form );
+ return $string_form;
+}
+
+sub _stringify_lol { # the real recursor
+ my($lol, $to) = @_;
+ use UNIVERSAL ();
+ for(my $i = 2; $i < @$lol; ++$i) {
+ if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) {
+ _stringify_lol( $lol->[$i], $to); # recurse!
+ } else {
+ $$to .= $lol->[$i];
+ }
+ }
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _dump_curr_open { # return a string representation of the stack
+ my $curr_open = $_[0]{'curr_open'};
+
+ return '[empty]' unless @$curr_open;
+ return join '; ',
+ map {;
+ ($_->[0] eq '=for')
+ ? ( ($_->[1]{'~really'} || '=over')
+ . ' ' . $_->[1]{'target'})
+ : $_->[0]
+ }
+ @$curr_open
+ ;
+}
+
+###########################################################################
+my %pretty_form = (
+ "\a" => '\a', # ding!
+ "\b" => '\b', # BS
+ "\e" => '\e', # ESC
+ "\f" => '\f', # FF
+ "\t" => '\t', # tab
+ "\cm" => '\cm',
+ "\cj" => '\cj',
+ "\n" => '\n', # probably overrides one of either \cm or \cj
+ '"' => '\"',
+ '\\' => '\\\\',
+ '$' => '\\$',
+ '@' => '\\@',
+ '%' => '\\%',
+ '#' => '\\#',
+);
+
+sub pretty { # adopted from Class::Classless
+ # Not the most brilliant routine, but passable.
+ # Don't give it a cyclic data structure!
+ my @stuff = @_; # copy
+ my $x;
+ my $out =
+ # join ",\n" .
+ join ", ",
+ map {;
+ if(!defined($_)) {
+ "undef";
+ } elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') {
+ $x = "[ " . pretty(@$_) . " ]" ;
+ $x;
+ } elsif(ref($_) eq 'SCALAR') {
+ $x = "\\" . pretty($$_) ;
+ $x;
+ } elsif(ref($_) eq 'HASH') {
+ my $hr = $_;
+ $x = "{" . join(", ",
+ map(pretty($_) . '=>' . pretty($hr->{$_}),
+ sort keys %$hr ) ) . "}" ;
+ $x;
+ } elsif(!length($_)) { q{''} # empty string
+ } elsif(
+ $_ eq '0' # very common case
+ or(
+ m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s
+ and $_ ne '-0' # the strange case that that RE lets thru
+ )
+ ) { $_;
+ } else {
+ if( chr(65) eq 'A' ) {
+ s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
+ #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
+ <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
+ } else {
+ # We're in some crazy non-ASCII world!
+ s<([^abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])>
+ #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
+ <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
+ }
+ qq{"$_"};
+ }
+ } @stuff;
+ # $out =~ s/\n */ /g if length($out) < 75;
+ return $out;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+# A rather unsubtle method of blowing away all the state information
+# from a parser object so it can be reused. Provided as a utility for
+# backward compatibilty in Pod::Man, etc. but not recommended for
+# general use.
+
+sub reinit {
+ my $self = shift;
+ foreach (qw(source_dead source_filename doc_has_started
+start_of_pod_block content_seen last_was_blank paras curr_open
+line_count pod_para_count in_pod ~tried_gen_errata errata errors_seen
+Title)) {
+
+ delete $self->{$_};
+ }
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Checker.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Checker.pm
new file mode 100755
index 00000000000..136e851bafe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Checker.pm
@@ -0,0 +1,196 @@
+
+# A quite dimwitted pod2plaintext that need only know how to format whatever
+# text comes out of Pod::BlackBox's _gen_errata
+
+require 5;
+package Pod::Simple::Checker;
+use strict;
+use Carp ();
+use Pod::Simple::Methody ();
+use Pod::Simple ();
+use vars qw( @ISA $VERSION );
+$VERSION = '3.13';
+@ISA = ('Pod::Simple::Methody');
+BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
+ ? \&Pod::Simple::DEBUG
+ : sub() {0}
+ }
+
+use Text::Wrap 98.112902 (); # was 2001.0131, but I don't think we need that
+$Text::Wrap::wrap = 'overflow';
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub any_errata_seen { # read-only accessor
+ return $_[1]->{'Errata_seen'};
+}
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->{'Thispara'} = '';
+ $new->{'Indent'} = 0;
+ $new->{'Indentstring'} = ' ';
+ $new->{'Errata_seen'} = 0;
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub handle_text { $_[0]{'Errata_seen'} and $_[0]{'Thispara'} .= $_[1] }
+
+sub start_Para { $_[0]{'Thispara'} = '' }
+
+sub start_head1 {
+ if($_[0]{'Errata_seen'}) {
+ $_[0]{'Thispara'} = '';
+ } else {
+ if($_[1]{'errata'}) { # start of errata!
+ $_[0]{'Errata_seen'} = 1;
+ $_[0]{'Thispara'} = $_[0]{'source_filename'} ?
+ "$_[0]{'source_filename'} -- " : ''
+ }
+ }
+}
+sub start_head2 { $_[0]{'Thispara'} = '' }
+sub start_head3 { $_[0]{'Thispara'} = '' }
+sub start_head4 { $_[0]{'Thispara'} = '' }
+
+sub start_Verbatim { $_[0]{'Thispara'} = '' }
+sub start_item_bullet { $_[0]{'Thispara'} = '* ' }
+sub start_item_number { $_[0]{'Thispara'} = "$_[1]{'number'}. " }
+sub start_item_text { $_[0]{'Thispara'} = '' }
+
+sub start_over_bullet { ++$_[0]{'Indent'} }
+sub start_over_number { ++$_[0]{'Indent'} }
+sub start_over_text { ++$_[0]{'Indent'} }
+sub start_over_block { ++$_[0]{'Indent'} }
+
+sub end_over_bullet { --$_[0]{'Indent'} }
+sub end_over_number { --$_[0]{'Indent'} }
+sub end_over_text { --$_[0]{'Indent'} }
+sub end_over_block { --$_[0]{'Indent'} }
+
+
+# . . . . . Now the actual formatters:
+
+sub end_head1 { $_[0]->emit_par(-4) }
+sub end_head2 { $_[0]->emit_par(-3) }
+sub end_head3 { $_[0]->emit_par(-2) }
+sub end_head4 { $_[0]->emit_par(-1) }
+sub end_Para { $_[0]->emit_par( 0) }
+sub end_item_bullet { $_[0]->emit_par( 0) }
+sub end_item_number { $_[0]->emit_par( 0) }
+sub end_item_text { $_[0]->emit_par(-2) }
+
+sub emit_par {
+ return unless $_[0]{'Errata_seen'};
+ my($self, $tweak_indent) = splice(@_,0,2);
+ my $indent = ' ' x ( 2 * $self->{'Indent'} + ($tweak_indent||0) );
+ # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
+
+ $self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII;
+ my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
+ $out =~ tr{\xA0}{ } if Pod::Simple::ASCII;
+ print {$self->{'output_fh'}} $out,
+ #"\n"
+ ;
+ $self->{'Thispara'} = '';
+
+ return;
+}
+
+# . . . . . . . . . . And then off by its lonesome:
+
+sub end_Verbatim {
+ return unless $_[0]{'Errata_seen'};
+ my $self = shift;
+ if(Pod::Simple::ASCII) {
+ $self->{'Thispara'} =~ tr{\xA0}{ };
+ $self->{'Thispara'} =~ tr{\xAD}{}d;
+ }
+
+ my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
+
+ $self->{'Thispara'} =~ s/^/$i/mg;
+
+ print { $self->{'output_fh'} } '',
+ $self->{'Thispara'},
+ "\n\n"
+ ;
+ $self->{'Thispara'} = '';
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Checker -- check the Pod syntax of a document
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::Checker -e \
+ "exit Pod::Simple::Checker->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is for checking the syntactic validity of Pod.
+It works by basically acting like a simple-minded version of
+L<Pod::Simple::Text> that formats only the "Pod Errors" section
+(if Pod::Simple even generates one for the given document).
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Checker>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Debug.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Debug.pm
new file mode 100755
index 00000000000..c2332fa73be
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Debug.pm
@@ -0,0 +1,178 @@
+
+require 5;
+package Pod::Simple::Debug;
+use strict;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+sub import {
+ my($value,$variable);
+
+ if(@_ == 2) {
+ $value = $_[1];
+ } elsif(@_ == 3) {
+ ($variable, $value) = @_[1,2];
+
+ ($variable, $value) = ($value, $variable)
+ if defined $value and ref($value) eq 'SCALAR'
+ and not(defined $variable and ref($variable) eq 'SCALAR')
+ ; # tolerate getting it backwards
+
+ unless( defined $variable and ref($variable) eq 'SCALAR') {
+ require Carp;
+ Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
+ . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
+ }
+ } else {
+ require Carp;
+ Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
+ . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
+ }
+
+ if( defined &Pod::Simple::DEBUG ) {
+ require Carp;
+ Carp::croak("It's too late to call Pod::Simple::Debug -- "
+ . "Pod::Simple has already loaded\nAborting");
+ }
+
+ $value = 0 unless defined $value;
+
+ unless($value =~ m/^-?\d+$/) {
+ require Carp;
+ Carp::croak( "$value isn't a numeric value."
+ . "\nUsage:\n use Pod::Simple::Debug (NUMVAL)\nor"
+ . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
+ }
+
+ if( defined $variable ) {
+ # make a not-really-constant
+ *Pod::Simple::DEBUG = sub () { $$variable } ;
+ $$variable = $value;
+ print "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n";
+ } else {
+ *Pod::Simple::DEBUG = eval " sub () { $value } ";
+ print "# Starting Pod::Simple::DEBUG = $value\n";
+ }
+
+ require Pod::Simple;
+ return;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Debug -- put Pod::Simple into trace/debug mode
+
+=head1 SYNOPSIS
+
+ use Pod::Simple::Debug (5); # or some integer
+
+Or:
+
+ my $debuglevel;
+ use Pod::Simple::Debug (\$debuglevel, 0);
+ ...some stuff that uses Pod::Simple to do stuff, but which
+ you don't want debug output from...
+
+ $debug_level = 4;
+ ...some stuff that uses Pod::Simple to do stuff, but which
+ you DO want debug output from...
+
+ $debug_level = 0;
+
+=head1 DESCRIPTION
+
+This is an internal module for controlling the debug level (a.k.a. trace
+level) of Pod::Simple. This is of interest only to Pod::Simple
+developers.
+
+
+=head1 CAVEATS
+
+Note that you should load this module I<before> loading Pod::Simple (or
+any Pod::Simple-based class). If you try loading Pod::Simple::Debug
+after &Pod::Simple::DEBUG is already defined, Pod::Simple::Debug will
+throw a fatal error to the effect that
+"it's s too late to call Pod::Simple::Debug".
+
+Note that the C<use Pod::Simple::Debug (\$x, I<somenum>)> mode will make
+Pod::Simple (et al) run rather slower, since &Pod::Simple::DEBUG won't
+be a constant sub anymore, and so Pod::Simple (et al) won't compile with
+constant-folding.
+
+
+=head1 GUTS
+
+Doing this:
+
+ use Pod::Simple::Debug (5); # or some integer
+
+is basically equivalent to:
+
+ BEGIN { sub Pod::Simple::DEBUG () {5} } # or some integer
+ use Pod::Simple ();
+
+And this:
+
+ use Pod::Simple::Debug (\$debug_level,0); # or some integer
+
+is basically equivalent to this:
+
+ my $debug_level;
+ BEGIN { $debug_level = 0 }
+ BEGIN { sub Pod::Simple::DEBUG () { $debug_level }
+ use Pod::Simple ();
+
+=head1 SEE ALSO
+
+L<Pod::Simple>
+
+The article "Constants in Perl", in I<The Perl Journal> issue
+21. See L<http://interglacial.com/tpj/21/>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsText.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsText.pm
new file mode 100755
index 00000000000..0f756463666
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsText.pm
@@ -0,0 +1,155 @@
+
+require 5;
+package Pod::Simple::DumpAsText;
+$VERSION = '3.13';
+use Pod::Simple ();
+BEGIN {@ISA = ('Pod::Simple')}
+
+use strict;
+
+use Carp ();
+
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->accept_codes('VerbatimFormatted');
+ return $new;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_element_start {
+ # ($self, $element_name, $attr_hash_r)
+ my $fh = $_[0]{'output_fh'};
+ my($key, $value);
+ DEBUG and print "++ $_[1]\n";
+
+ print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n";
+ $_[0]{'indent'}++;
+ while(($key,$value) = each %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _perly_escape($key);
+ _perly_escape($value);
+ printf $fh qq{%s \\ "%s" => "%s"\n},
+ ' ' x ($_[0]{'indent'} || 0), $key, $value;
+ }
+ }
+ return;
+}
+
+sub _handle_text {
+ DEBUG and print "== \"$_[1]\"\n";
+
+ if(length $_[1]) {
+ my $indent = ' ' x $_[0]{'indent'};
+ my $text = $_[1];
+ _perly_escape($text);
+ $text =~ # A not-totally-brilliant wrapping algorithm:
+ s/(
+ [^\n]{55} # Snare some characters from a line
+ [^\n\ ]{0,50} # and finish any current word
+ )
+ \x20{1,10}(?!\n) # capture some spaces not at line-end
+ /$1"\n$indent . "/gx # => line-break here
+ ;
+
+ print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n";
+ }
+ return;
+}
+
+sub _handle_element_end {
+ DEBUG and print "-- $_[1]\n";
+ print {$_[0]{'output_fh'}}
+ ' ' x --$_[0]{'indent'}, "--", $_[1], "\n";
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _perly_escape {
+ foreach my $x (@_) {
+ $x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg;
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg;
+ }
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::DumpAsText -- dump Pod-parsing events as text
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::DumpAsText -e \
+ "exit Pod::Simple::DumpAsText->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is for dumping, as text, the events gotten from parsing a Pod
+document. This class is of interest to people writing Pod formatters
+based on Pod::Simple. It is useful for seeing exactly what events you
+get out of some Pod that you feed in.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple::DumpAsXML>
+
+L<Pod::Simple>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsXML.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsXML.pm
new file mode 100755
index 00000000000..9e4b77ffbd8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/DumpAsXML.pm
@@ -0,0 +1,170 @@
+
+require 5;
+package Pod::Simple::DumpAsXML;
+$VERSION = '3.13';
+use Pod::Simple ();
+BEGIN {@ISA = ('Pod::Simple')}
+
+use strict;
+
+use Carp ();
+
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->accept_codes('VerbatimFormatted');
+ return $new;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_element_start {
+ # ($self, $element_name, $attr_hash_r)
+ my $fh = $_[0]{'output_fh'};
+ my($key, $value);
+ DEBUG and print "++ $_[1]\n";
+
+ print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1];
+
+ foreach my $key (sort keys %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _xml_escape($value = $_[2]{$key});
+ print $fh ' ', $key, '="', $value, '"';
+ }
+ }
+
+
+ print $fh ">\n";
+ $_[0]{'indent'}++;
+ return;
+}
+
+sub _handle_text {
+ DEBUG and print "== \"$_[1]\"\n";
+ if(length $_[1]) {
+ my $indent = ' ' x $_[0]{'indent'};
+ my $text = $_[1];
+ _xml_escape($text);
+ $text =~ # A not-totally-brilliant wrapping algorithm:
+ s/(
+ [^\n]{55} # Snare some characters from a line
+ [^\n\ ]{0,50} # and finish any current word
+ )
+ \x20{1,10}(?!\n) # capture some spaces not at line-end
+ /$1\n$indent/gx # => line-break here
+ ;
+
+ print {$_[0]{'output_fh'}} $indent, $text, "\n";
+ }
+ return;
+}
+
+sub _handle_element_end {
+ DEBUG and print "-- $_[1]\n";
+ print {$_[0]{'output_fh'}}
+ ' ' x --$_[0]{'indent'}, "</", $_[1], ">\n";
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _xml_escape {
+ foreach my $x (@_) {
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done about that.
+ }
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::DumpAsXML -- turn Pod into XML
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::DumpAsXML -e \
+ "exit Pod::Simple::DumpAsXML->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+Pod::Simple::DumpAsXML is a subclass of L<Pod::Simple> that parses Pod
+and turns it into indented and wrapped XML. This class is of
+interest to people writing Pod formatters based on Pod::Simple.
+
+Pod::Simple::DumpAsXML inherits methods from
+L<Pod::Simple>.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple::XMLOutStream> is rather like this class.
+Pod::Simple::XMLOutStream's output is space-padded in a way
+that's better for sending to an XML processor (that is, it has
+no ignoreable whitespace). But
+Pod::Simple::DumpAsXML's output is much more human-readable, being
+(more-or-less) one token per line, with line-wrapping.
+
+L<Pod::Simple::DumpAsText> is rather like this class,
+except that it doesn't dump with XML syntax. Try them and see
+which one you like best!
+
+L<Pod::Simple>, L<Pod::Simple::DumpAsXML>
+
+The older libraries L<Pod::PXML>, L<Pod::XML>, L<Pod::SAX>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTML.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTML.pm
new file mode 100755
index 00000000000..663a5e438c6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTML.pm
@@ -0,0 +1,979 @@
+
+require 5;
+package Pod::Simple::HTML;
+use strict;
+use Pod::Simple::PullParser ();
+use vars qw(
+ @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION
+ $Perldoc_URL_Prefix $Perldoc_URL_Postfix $Man_URL_Prefix $Man_URL_Postfix
+ $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex
+ $Doctype_decl $Content_decl
+);
+@ISA = ('Pod::Simple::PullParser');
+$VERSION = '3.13';
+
+use UNIVERSAL ();
+BEGIN {
+ if(defined &DEBUG) { } # no-op
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
+ else { *DEBUG = sub () {0}; }
+}
+
+$Doctype_decl ||= ''; # No. Just No. Don't even ask me for it.
+ # qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ # "http://www.w3.org/TR/html4/loose.dtd">\n};
+
+$Content_decl ||=
+ q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >};
+
+$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION;
+$Computerese = "" unless defined $Computerese;
+$LamePad = '' unless defined $LamePad;
+
+$Linearization_Limit = 120 unless defined $Linearization_Limit;
+ # headings/items longer than that won't get an <a name="...">
+$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?'
+ unless defined $Perldoc_URL_Prefix;
+$Perldoc_URL_Postfix = ''
+ unless defined $Perldoc_URL_Postfix;
+
+
+$Man_URL_Prefix = 'http://man.he.net/man';
+$Man_URL_Postfix = '';
+
+$Title_Prefix = '' unless defined $Title_Prefix;
+$Title_Postfix = '' unless defined $Title_Postfix;
+%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text
+ # 'item-text' stuff in the index doesn't quite work, and may
+ # not be a good idea anyhow.
+
+
+__PACKAGE__->_accessorize(
+ 'perldoc_url_prefix',
+ # In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
+ # to put before the "Foo%3a%3aBar".
+ # (for singleton mode only?)
+ 'perldoc_url_postfix',
+ # what to put after "Foo%3a%3aBar" in the URL. Normally "".
+
+ 'man_url_prefix',
+ # In turning L<crontab(5)> into http://whatever/man/1/crontab, what
+ # to put before the "1/crontab".
+ 'man_url_postfix',
+ # what to put after the "1/crontab" in the URL. Normally "".
+
+ 'batch_mode', # whether we're in batch mode
+ 'batch_mode_current_level',
+ # When in batch mode, how deep the current module is: 1 for "LWP",
+ # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
+
+ 'title_prefix', 'title_postfix',
+ # What to put before and after the title in the head.
+ # Should already be &-escaped
+
+ 'html_h_level',
+
+ 'html_header_before_title',
+ 'html_header_after_title',
+ 'html_footer',
+
+ 'index', # whether to add an index at the top of each page
+ # (actually it's a table-of-contents, but we'll call it an index,
+ # out of apparently longstanding habit)
+
+ 'html_css', # URL of CSS file to point to
+ 'html_javascript', # URL of CSS file to point to
+
+ 'force_title', # should already be &-escaped
+ 'default_title', # should already be &-escaped
+);
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+my @_to_accept;
+
+%Tagmap = (
+ 'Verbatim' => "\n<pre$Computerese>",
+ '/Verbatim' => "</pre>\n",
+ 'VerbatimFormatted' => "\n<pre$Computerese>",
+ '/VerbatimFormatted' => "</pre>\n",
+ 'VerbatimB' => "<b>",
+ '/VerbatimB' => "</b>",
+ 'VerbatimI' => "<i>",
+ '/VerbatimI' => "</i>",
+ 'VerbatimBI' => "<b><i>",
+ '/VerbatimBI' => "</i></b>",
+
+
+ 'Data' => "\n",
+ '/Data' => "\n",
+
+ 'head1' => "\n<h1>", # And also stick in an <a name="...">
+ 'head2' => "\n<h2>", # ''
+ 'head3' => "\n<h3>", # ''
+ 'head4' => "\n<h4>", # ''
+ '/head1' => "</a></h1>\n",
+ '/head2' => "</a></h2>\n",
+ '/head3' => "</a></h3>\n",
+ '/head4' => "</a></h4>\n",
+
+ 'X' => "<!--\n\tINDEX: ",
+ '/X' => "\n-->",
+
+ changes(qw(
+ Para=p
+ B=b I=i
+ over-bullet=ul
+ over-number=ol
+ over-text=dl
+ over-block=blockquote
+ item-bullet=li
+ item-number=li
+ item-text=dt
+ )),
+ changes2(
+ map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
+ qw[
+ sample=samp
+ definition=dfn
+ kbd=keyboard
+ variable=var
+ citation=cite
+ abbreviation=abbr
+ acronym=acronym
+ subscript=sub
+ superscript=sup
+ big=big
+ small=small
+ underline=u
+ strikethrough=s
+ ] # no point in providing a way to get <q>...</q>, I think
+ ),
+
+ '/item-bullet' => "</li>$LamePad\n",
+ '/item-number' => "</li>$LamePad\n",
+ '/item-text' => "</a></dt>$LamePad\n",
+ 'item-body' => "\n<dd>",
+ '/item-body' => "</dd>\n",
+
+
+ 'B' => "<b>", '/B' => "</b>",
+ 'I' => "<i>", '/I' => "</i>",
+ 'F' => "<em$Computerese>", '/F' => "</em>",
+ 'C' => "<code$Computerese>", '/C' => "</code>",
+ 'L' => "<a href='YOU_SHOULD_NEVER_SEE_THIS'>", # ideally never used!
+ '/L' => "</a>",
+);
+
+sub changes {
+ return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
+ ? ( $1, => "\n<$2>", "/$1", => "</$2>\n" ) : die "Funky $_"
+ } @_;
+}
+sub changes2 {
+ return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
+ ? ( $1, => "<$2>", "/$1", => "</$2>" ) : die "Funky $_"
+ } @_;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 }
+ # Just so we can run from the command line. No options.
+ # For that, use perldoc!
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub new {
+ my $new = shift->SUPER::new(@_);
+ #$new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->accept_targets( 'html', 'HTML' );
+ $new->accept_codes('VerbatimFormatted');
+ $new->accept_codes(@_to_accept);
+ DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
+
+ $new->perldoc_url_prefix( $Perldoc_URL_Prefix );
+ $new->perldoc_url_postfix( $Perldoc_URL_Postfix );
+ $new->man_url_prefix( $Man_URL_Prefix );
+ $new->man_url_postfix( $Man_URL_Postfix );
+ $new->title_prefix( $Title_Prefix );
+ $new->title_postfix( $Title_Postfix );
+
+ $new->html_header_before_title(
+ qq[$Doctype_decl<html><head><title>]
+ );
+ $new->html_header_after_title( join "\n" =>
+ "</title>",
+ $Content_decl,
+ "</head>\n<body class='pod'>",
+ $new->version_tag_comment,
+ "<!-- start doc -->\n",
+ );
+ $new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
+
+ $new->{'Tagmap'} = {%Tagmap};
+
+ return $new;
+}
+
+sub __adjust_html_h_levels {
+ my ($self) = @_;
+ my $Tagmap = $self->{'Tagmap'};
+
+ my $add = $self->html_h_level;
+ return unless defined $add;
+ return if ($self->{'Adjusted_html_h_levels'}||0) == $add;
+
+ $add -= 1;
+ for (1 .. 4) {
+ $Tagmap->{"head$_"} =~ s/$_/$_ + $add/e;
+ $Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e;
+ }
+}
+
+sub batch_mode_page_object_init {
+ my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
+ DEBUG and print "Initting $self\n for $module\n",
+ " in $infile\n out $outfile\n depth $depth\n";
+ $self->batch_mode(1);
+ $self->batch_mode_current_level($depth);
+ return $self;
+}
+
+sub run {
+ my $self = $_[0];
+ return $self->do_middle if $self->bare_output;
+ return
+ $self->do_beginning && $self->do_middle && $self->do_end;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub do_beginning {
+ my $self = $_[0];
+
+ my $title;
+
+ if(defined $self->force_title) {
+ $title = $self->force_title;
+ DEBUG and print "Forcing title to be $title\n";
+ } else {
+ # Actually try looking for the title in the document:
+ $title = $self->get_short_title();
+ unless($self->content_seen) {
+ DEBUG and print "No content seen in search for title.\n";
+ return;
+ }
+ $self->{'Title'} = $title;
+
+ if(defined $title and $title =~ m/\S/) {
+ $title = $self->title_prefix . esc($title) . $self->title_postfix;
+ } else {
+ $title = $self->default_title;
+ $title = '' unless defined $title;
+ DEBUG and print "Title defaults to $title\n";
+ }
+ }
+
+
+ my $after = $self->html_header_after_title || '';
+ if($self->html_css) {
+ my $link =
+ $self->html_css =~ m/</
+ ? $self->html_css # It's a big blob of markup, let's drop it in
+ : sprintf( # It's just a URL, so let's wrap it up
+ qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n],
+ $self->html_css,
+ );
+ $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
+ }
+ $self->_add_top_anchor(\$after);
+
+ if($self->html_javascript) {
+ my $link =
+ $self->html_javascript =~ m/</
+ ? $self->html_javascript # It's a big blob of markup, let's drop it in
+ : sprintf( # It's just a URL, so let's wrap it up
+ qq[<script type="text/javascript" src="%s"></script>\n],
+ $self->html_javascript,
+ );
+ $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
+ }
+
+ print {$self->{'output_fh'}}
+ $self->html_header_before_title || '',
+ $title, # already escaped
+ $after,
+ ;
+
+ DEBUG and print "Returning from do_beginning...\n";
+ return 1;
+}
+
+sub _add_top_anchor {
+ my($self, $text_r) = @_;
+ unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack
+ $$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n";
+ }
+ return;
+}
+
+sub version_tag_comment {
+ my $self = shift;
+ return sprintf
+ "<!--\n generated by %s v%s,\n using %s v%s,\n under Perl v%s at %s GMT.\n\n %s\n\n-->\n",
+ esc(
+ ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(),
+ $], scalar(gmtime),
+ ), $self->_modnote(),
+ ;
+}
+
+sub _modnote {
+ my $class = ref($_[0]) || $_[0];
+ return join "\n " => grep m/\S/, split "\n",
+
+qq{
+If you want to change this HTML document, you probably shouldn't do that
+by changing it directly. Instead, see about changing the calling options
+to $class, and/or subclassing $class,
+then reconverting this document from the Pod source.
+When in doubt, email the author of $class for advice.
+See 'perldoc $class' for more info.
+};
+
+}
+
+sub do_end {
+ my $self = $_[0];
+ print {$self->{'output_fh'}} $self->html_footer || '';
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Normally this would just be a call to _do_middle_main_loop -- but we
+# have to do some elaborate things to emit all the content and then
+# summarize it and output it /before/ the content that it's a summary of.
+
+sub do_middle {
+ my $self = $_[0];
+ return $self->_do_middle_main_loop unless $self->index;
+
+ if( $self->output_string ) {
+ # An efficiency hack
+ my $out = $self->output_string; #it's a reference to it
+ my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n";
+ $$out .= $sneakytag;
+ $self->_do_middle_main_loop;
+ $sneakytag = quotemeta($sneakytag);
+ my $index = $self->index_as_html();
+ if( $$out =~ s/$sneakytag/$index/s ) {
+ # Expected case
+ DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n";
+ } else {
+ DEBUG and print "Odd, couldn't find where to insert the index in the output!\n";
+ # I don't think this should ever happen.
+ }
+ return 1;
+ }
+
+ unless( $self->output_fh ) {
+ require Carp;
+ Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that.");
+ }
+
+ # If we get here, we're outputting to a FH. So we need to do some magic.
+ # Namely, divert all content to a string, which we output after the index.
+ my $fh = $self->output_fh;
+ my $content = '';
+ {
+ # Our horrible bait and switch:
+ $self->output_string( \$content );
+ $self->_do_middle_main_loop;
+ $self->abandon_output_string();
+ $self->output_fh($fh);
+ }
+ print $fh $self->index_as_html();
+ print $fh $content;
+
+ return 1;
+}
+
+###########################################################################
+
+sub index_as_html {
+ my $self = $_[0];
+ # This is meant to be called AFTER the input document has been parsed!
+
+ my $points = $self->{'PSHTML_index_points'} || [];
+
+ @$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n];
+ # There's no point in having a 0-item or 1-item index, I dare say.
+
+ my(@out) = qq{\n<div class='indexgroup'>};
+ my $level = 0;
+
+ my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent);
+ foreach my $p (@$points, ['head0', '(end)']) {
+ ($tagname, $text) = @$p;
+ $anchorname = $self->section_escape($text);
+ if( $tagname =~ m{^head(\d+)$} ) {
+ $target_level = 0 + $1;
+ } else { # must be some kinda list item
+ if($previous_tagname =~ m{^head\d+$} ) {
+ $target_level = $level + 1;
+ } else {
+ $target_level = $level; # no change needed
+ }
+ }
+
+ # Get to target_level by opening or closing ULs
+ while($level > $target_level)
+ { --$level; push @out, (" " x $level) . "</ul>"; }
+ while($level < $target_level)
+ { ++$level; push @out, (" " x ($level-1))
+ . "<ul class='indexList indexList$level'>"; }
+
+ $previous_tagname = $tagname;
+ next unless $level;
+
+ $indent = ' ' x $level;
+ push @out, sprintf
+ "%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>",
+ $indent, $level, esc($anchorname), esc($text)
+ ;
+ }
+ push @out, "</div>\n";
+ return join "\n", @out;
+}
+
+###########################################################################
+
+sub _do_middle_main_loop {
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+ my $tagmap = $self->{'Tagmap'};
+
+ $self->__adjust_html_h_levels;
+
+ my($token, $type, $tagname, $linkto, $linktype);
+ my @stack;
+ my $dont_wrap = 0;
+
+ while($token = $self->get_token) {
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if( ($type = $token->type) eq 'start' ) {
+ if(($tagname = $token->tagname) eq 'L') {
+ $linktype = $token->attr('type') || 'insane';
+
+ $linkto = $self->do_link($token);
+
+ if(defined $linkto and length $linkto) {
+ esc($linkto);
+ # (Yes, SGML-escaping applies on top of %-escaping!
+ # But it's rarely noticeable in practice.)
+ print $fh qq{<a href="$linkto" class="podlink$linktype"\n>};
+ } else {
+ print $fh "<a>"; # Yes, an 'a' element with no attributes!
+ }
+
+ } elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) {
+ print $fh $tagmap->{$tagname} || next;
+
+ my @to_unget;
+ while(1) {
+ push @to_unget, $self->get_token;
+ last if $to_unget[-1]->is_end
+ and $to_unget[-1]->tagname eq $tagname;
+
+ # TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens)
+ }
+
+ my $name = $self->linearize_tokens(@to_unget);
+ $name = $self->do_section($name, $token) if defined $name;
+
+ print $fh "<a ";
+ print $fh "class='u' href='#___top' title='click to go to top of document'\n"
+ if $tagname =~ m/^head\d$/s;
+
+ if(defined $name) {
+ my $esc = esc( $self->section_name_tidy( $name ) );
+ print $fh qq[name="$esc"];
+ DEBUG and print "Linearized ", scalar(@to_unget),
+ " tokens as \"$name\".\n";
+ push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name]
+ if $ToIndex{ $tagname };
+ # Obviously, this discards all formatting codes (saving
+ # just their content), but ahwell.
+
+ } else { # ludicrously long, so nevermind
+ DEBUG and print "Linearized ", scalar(@to_unget),
+ " tokens, but it was too long, so nevermind.\n";
+ }
+ print $fh "\n>";
+ $self->unget_token(@to_unget);
+
+ } elsif ($tagname eq 'Data') {
+ my $next = $self->get_token;
+ next unless defined $next;
+ unless( $next->type eq 'text' ) {
+ $self->unget_token($next);
+ next;
+ }
+ DEBUG and print " raw text ", $next->text, "\n";
+ print $fh "\n" . $next->text . "\n";
+ next;
+
+ } else {
+ if( $tagname =~ m/^over-/s ) {
+ push @stack, '';
+ } elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) {
+ print $fh $stack[-1];
+ $stack[-1] = '';
+ }
+ print $fh $tagmap->{$tagname} || next;
+ ++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted"
+ or $tagname eq 'X';
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ } elsif( $type eq 'end' ) {
+ if( ($tagname = $token->tagname) =~ m/^over-/s ) {
+ if( my $end = pop @stack ) {
+ print $fh $end;
+ }
+ } elsif( $tagname =~ m/^item-/s and @stack) {
+ $stack[-1] = $tagmap->{"/$tagname"};
+ if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) {
+ $self->unget_token($next);
+ if( $next->type eq 'start' ) {
+ print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"};
+ $stack[-1] = $tagmap->{"/item-body"};
+ }
+ }
+ next;
+ }
+ print $fh $tagmap->{"/$tagname"} || next;
+ --$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X';
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ } elsif( $type eq 'text' ) {
+ esc($type = $token->text); # reuse $type, why not
+ $type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap;
+ print $fh $type;
+ }
+
+ }
+ return 1;
+}
+
+###########################################################################
+#
+
+sub do_section {
+ my($self, $name, $token) = @_;
+ return $name;
+}
+
+sub do_link {
+ my($self, $token) = @_;
+ my $type = $token->attr('type');
+ if(!defined $type) {
+ $self->whine("Typeless L!?", $token->attr('start_line'));
+ } elsif( $type eq 'pod') { return $self->do_pod_link($token);
+ } elsif( $type eq 'url') { return $self->do_url_link($token);
+ } elsif( $type eq 'man') { return $self->do_man_link($token);
+ } else {
+ $self->whine("L of unknown type $type!?", $token->attr('start_line'));
+ }
+ return 'FNORG'; # should never get called
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub do_url_link { return $_[1]->attr('to') }
+
+sub do_man_link {
+ my ($self, $link) = @_;
+ my $to = $link->attr('to');
+ my $frag = $link->attr('section');
+
+ return undef unless defined $to and length $to; # should never happen
+
+ $frag = $self->section_escape($frag)
+ if defined $frag and length($frag .= ''); # (stringify)
+
+ DEBUG and print "Resolving \"$to/$frag\"\n\n";
+
+ return $self->resolve_man_page_link($to, $frag);
+}
+
+
+sub do_pod_link {
+ # And now things get really messy...
+ my($self, $link) = @_;
+ my $to = $link->attr('to');
+ my $section = $link->attr('section');
+ return undef unless( # should never happen
+ (defined $to and length $to) or
+ (defined $section and length $section)
+ );
+
+ $section = $self->section_escape($section)
+ if defined $section and length($section .= ''); # (stringify)
+
+ DEBUG and printf "Resolving \"%s\" \"%s\"...\n",
+ $to || "(nil)", $section || "(nil)";
+
+ {
+ # An early hack:
+ my $complete_url = $self->resolve_pod_link_by_table($to, $section);
+ if( $complete_url ) {
+ DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ",
+ $complete_url, "\n (Returning that.)\n";
+ return $complete_url;
+ } else {
+ DEBUG > 4 and print " resolve_pod_link_by_table(T,S)",
+ " didn't return anything interesting.\n";
+ }
+ }
+
+ if(defined $to and length $to) {
+ # Give this routine first hack again
+ my $there = $self->resolve_pod_link_by_table($to);
+ if(defined $there and length $there) {
+ DEBUG > 1
+ and print "resolve_pod_link_by_table(T) gives $there\n";
+ } else {
+ $there =
+ $self->resolve_pod_page_link($to, $section);
+ # (I pass it the section value, but I don't see a
+ # particular reason it'd use it.)
+ DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n";
+ unless( defined $there and length $there ) {
+ DEBUG and print "Can't resolve $to\n";
+ return undef;
+ }
+ # resolve_pod_page_link returning undef is how it
+ # can signal that it gives up on making a link
+ }
+ $to = $there;
+ }
+
+ #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n";
+
+ my $out = (defined $to and length $to) ? $to : '';
+ $out .= "#" . $section if defined $section and length $section;
+
+ unless(length $out) { # sanity check
+ DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n",
+ $to || "(nil)", $section || "(nil)";
+ return undef;
+ }
+
+ DEBUG and print "Resolved to $out\n";
+ return $out;
+}
+
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub section_escape {
+ my($self, $section) = @_;
+ return $self->section_url_escape(
+ $self->section_name_tidy($section)
+ );
+}
+
+sub section_name_tidy {
+ my($self, $section) = @_;
+ $section =~ tr/ /_/;
+ $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters
+ $section = $self->unicode_escape_url($section);
+ $section = '_' unless length $section;
+ return $section;
+}
+
+sub section_url_escape { shift->general_url_escape(@_) }
+sub pagepath_url_escape { shift->general_url_escape(@_) }
+sub manpage_url_escape { shift->general_url_escape(@_) }
+
+sub general_url_escape {
+ my($self, $string) = @_;
+
+ $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
+ # express Unicode things as urlencode(utf(orig)).
+
+ # A pretty conservative escaping, behoovey even for query components
+ # of a URL (see RFC 2396)
+
+ $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done
+ # about that, I guess?
+
+ return $string;
+}
+
+#--------------------------------------------------------------------------
+#
+# Oh look, a yawning portal to Hell! Let's play touch football right by it!
+#
+
+sub resolve_pod_page_link {
+ # resolve_pod_page_link must return a properly escaped URL
+ my $self = shift;
+ return $self->batch_mode()
+ ? $self->resolve_pod_page_link_batch_mode(@_)
+ : $self->resolve_pod_page_link_singleton_mode(@_)
+ ;
+}
+
+sub resolve_pod_page_link_singleton_mode {
+ my($self, $it) = @_;
+ return undef unless defined $it and length $it;
+ my $url = $self->pagepath_url_escape($it);
+
+ $url =~ s{::$}{}s; # probably never comes up anyway
+ $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM?
+
+ return undef unless length $url;
+ return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix;
+}
+
+sub resolve_pod_page_link_batch_mode {
+ my($self, $to) = @_;
+ DEBUG > 1 and print " During batch mode, resolving $to ...\n";
+ my @path = grep length($_), split m/::/s, $to, -1;
+ unless( @path ) { # sanity
+ DEBUG and print "Very odd! Splitting $to gives (nil)!\n";
+ return undef;
+ }
+ $self->batch_mode_rectify_path(\@path);
+ my $out = join('/', map $self->pagepath_url_escape($_), @path)
+ . $HTML_EXTENSION;
+ DEBUG > 1 and print " => $out\n";
+ return $out;
+}
+
+sub batch_mode_rectify_path {
+ my($self, $pathbits) = @_;
+ my $level = $self->batch_mode_current_level;
+ $level--; # how many levels up to go to get to the root
+ if($level < 1) {
+ unshift @$pathbits, '.'; # just to be pretty
+ } else {
+ unshift @$pathbits, ('..') x $level;
+ }
+ return;
+}
+
+sub resolve_man_page_link {
+ my ($self, $to, $frag) = @_;
+ my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
+
+ return undef unless defined $page and length $page;
+ $section ||= 1;
+
+ return $self->man_url_prefix . "$section/"
+ . $self->manpage_url_escape($page)
+ . $self->man_url_postfix;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub resolve_pod_link_by_table {
+ # A crazy hack to allow specifying custom L<foo> => URL mappings
+
+ return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut
+
+ my($self, $to, $section) = @_;
+
+ # TODO: add a method that actually populates podhtml_LOT from a file?
+
+ if(defined $section) {
+ $to = '' unless defined $to and length $to;
+ return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef!
+ } else {
+ return $self->{'podhtml_LOT'}{$to}; # quite possibly undef!
+ }
+ return;
+}
+
+###########################################################################
+
+sub linearize_tokens { # self, tokens
+ my $self = shift;
+ my $out = '';
+
+ my $t;
+ while($t = shift @_) {
+ if(!ref $t or !UNIVERSAL::can($t, 'is_text')) {
+ $out .= $t; # a string, or some insane thing
+ } elsif($t->is_text) {
+ $out .= $t->text;
+ } elsif($t->is_start and $t->tag eq 'X') {
+ # Ignore until the end of this X<...> sequence:
+ my $x_open = 1;
+ while($x_open) {
+ next if( ($t = shift @_)->is_text );
+ if( $t->is_start and $t->tag eq 'X') { ++$x_open }
+ elsif($t->is_end and $t->tag eq 'X') { --$x_open }
+ }
+ }
+ }
+ return undef if length $out > $Linearization_Limit;
+ return $out;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub unicode_escape_url {
+ my($self, $string) = @_;
+ $string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg;
+ # Turn char 1234 into "(1234)"
+ return $string;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub esc { # a function.
+ if(defined wantarray) {
+ if(wantarray) {
+ @_ = splice @_; # break aliasing
+ } else {
+ my $x = shift;
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ return $x;
+ }
+ }
+ foreach my $x (@_) {
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
+ if defined $x;
+ # Leave out "- so that "--" won't make it thru in X-generated comments
+ # with text in them.
+
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done about that.
+ }
+ return @_;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Simple::HTML - convert Pod to HTML
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod
+
+
+=head1 DESCRIPTION
+
+This class is for making an HTML rendering of a Pod document.
+
+This is a subclass of L<Pod::Simple::PullParser> and inherits all its
+methods (and options).
+
+Note that if you want to do a batch conversion of a lot of Pod
+documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>.
+
+
+
+=head1 CALLING FROM THE COMMAND LINE
+
+TODO
+
+ perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html
+
+
+
+=head1 CALLING FROM PERL
+
+TODO make a new object, set any options, and use parse_from_file
+
+
+=head1 METHODS
+
+TODO
+all (most?) accessorized methods
+
+
+=head1 SUBCLASSING
+
+TODO
+
+ can just set any of: html_css html_javascript title_prefix
+ 'html_header_before_title',
+ 'html_header_after_title',
+ 'html_footer',
+
+maybe override do_pod_link
+
+maybe override do_beginning do_end
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::HTMLBatch>
+
+TODO: a corpus of sample Pod input and HTML output? Or common
+idioms?
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002-2004 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to L<Hurricane Electrict|http://he.net/> for permission to use its
+L<Linux man pages online|http://man.he.net/> site for man page links.
+
+Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
+site for Perl module links.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLBatch.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLBatch.pm
new file mode 100755
index 00000000000..736ff53bcc1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLBatch.pm
@@ -0,0 +1,1372 @@
+
+require 5;
+package Pod::Simple::HTMLBatch;
+use strict;
+use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION
+ $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA
+);
+$VERSION = '3.13';
+@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML!
+
+# TODO: nocontents stylesheets. Strike some of the color variations?
+
+use Pod::Simple::HTML ();
+BEGIN {*esc = \&Pod::Simple::HTML::esc }
+use File::Spec ();
+use UNIVERSAL ();
+ # "Isn't the Universe an amazing place? I wouldn't live anywhere else!"
+
+use Pod::Simple::Search;
+$SEARCH_CLASS ||= 'Pod::Simple::Search';
+
+BEGIN {
+ if(defined &DEBUG) { } # no-op
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
+ else { *DEBUG = sub () {0}; }
+}
+
+$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
+# flag to occasionally sleep for $SLEEPY - 1 seconds.
+
+$HTML_RENDER_CLASS ||= "Pod::Simple::HTML";
+
+#
+# Methods beginning with "_" are particularly internal and possibly ugly.
+#
+
+Pod::Simple::_accessorize( __PACKAGE__,
+ 'verbose', # how verbose to be during batch conversion
+ 'html_render_class', # what class to use to render
+ 'search_class', # what to use to search for POD documents
+ 'contents_file', # If set, should be the name of a file (in current directory)
+ # to write the list of all modules to
+ 'index', # will set $htmlpage->index(...) to this (true or false)
+ 'progress', # progress object
+ 'contents_page_start', 'contents_page_end',
+
+ 'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad',
+ 'no_contents_links', # set to true to suppress automatic adding of << links.
+ '_contents',
+);
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Just so we can run from the command line more easily
+sub go {
+ @ARGV == 2 or die sprintf(
+ "Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n",
+ __PACKAGE__, __PACKAGE__,
+ );
+
+ if(defined($ARGV[1]) and length($ARGV[1])) {
+ my $d = $ARGV[1];
+ -e $d or die "I see no output directory named \"$d\"\nAborting";
+ -d $d or die "But \"$d\" isn't a directory!\nAborting";
+ -w $d or die "Directory \"$d\" isn't writeable!\nAborting";
+ }
+
+ __PACKAGE__->batch_convert(@ARGV);
+}
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+sub new {
+ my $new = bless {}, ref($_[0]) || $_[0];
+ $new->html_render_class($HTML_RENDER_CLASS);
+ $new->search_class($SEARCH_CLASS);
+ $new->verbose(1 + DEBUG);
+ $new->_contents([]);
+
+ $new->index(1);
+
+ $new-> _css_wad([]); $new->css_flurry(1);
+ $new->_javascript_wad([]); $new->javascript_flurry(1);
+
+ $new->contents_file(
+ 'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION)
+ );
+
+ $new->contents_page_start( join "\n", grep $_,
+ $Pod::Simple::HTML::Doctype_decl,
+ "<html><head>",
+ "<title>Perl Documentation</title>",
+ $Pod::Simple::HTML::Content_decl,
+ "</head>",
+ "\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n"
+ ); # override if you need a different title
+
+
+ $new->contents_page_end( sprintf(
+ "\n\n<p class='contentsfooty'>Generated by %s v%s under Perl v%s\n<br >At %s GMT, which is %s local time.</p>\n\n</body></html>\n",
+ esc(
+ ref($new),
+ eval {$new->VERSION} || $VERSION,
+ $], scalar(gmtime), scalar(localtime),
+ )));
+
+ return $new;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub muse {
+ my $self = shift;
+ if($self->verbose) {
+ print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n";
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub batch_convert {
+ my($self, $dirs, $outdir) = @_;
+ $self ||= __PACKAGE__; # tolerate being called as an optionless function
+ $self = $self->new unless ref $self; # tolerate being used as a class method
+
+ if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) {
+ $dirs = '';
+ } elsif(ref $dirs) {
+ # OK, it's an explicit set of dirs to scan, specified as an arrayref.
+ } else {
+ # OK, it's an explicit set of dirs to scan, specified as a
+ # string like "/thing:/also:/whatever/perl" (":"-delim, as usual)
+ # or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!)
+ require Config;
+ my $ps = quotemeta( $Config::Config{'path_sep'} || ":" );
+ $dirs = [ grep length($_), split qr/$ps/, $dirs ];
+ }
+
+ $outdir = $self->filespecsys->curdir
+ unless defined $outdir and length $outdir;
+
+ $self->_batch_convert_main($dirs, $outdir);
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _batch_convert_main {
+ my($self, $dirs, $outdir) = @_;
+ # $dirs is either false, or an arrayref.
+ # $outdir is a pathspec.
+
+ $self->{'_batch_start_time'} ||= time();
+
+ $self->muse( "= ", scalar(localtime) );
+ $self->muse( "Starting batch conversion to \"$outdir\"" );
+
+ my $progress = $self->progress;
+ if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) {
+ require Pod::Simple::Progress;
+ $progress = Pod::Simple::Progress->new(
+ ($self->verbose < 2) ? () # Default omission-delay
+ : ($self->verbose == 2) ? 1 # Reduce the omission-delay
+ : 0 # Eliminate the omission-delay
+ );
+ $self->progress($progress);
+ }
+
+ if($dirs) {
+ $self->muse(scalar(@$dirs), " dirs to scan: @$dirs");
+ } else {
+ $self->muse("Scanning \@INC. This could take a minute or two.");
+ }
+ my $mod2path = $self->find_all_pods($dirs ? $dirs : ());
+ $self->muse("Done scanning.");
+
+ my $total = keys %$mod2path;
+ unless($total) {
+ $self->muse("No pod found. Aborting batch conversion.\n");
+ return $self;
+ }
+
+ $progress and $progress->goal($total);
+ $self->muse("Now converting pod files to HTML.",
+ ($total > 25) ? " This will take a while more." : ()
+ );
+
+ $self->_spray_css( $outdir );
+ $self->_spray_javascript( $outdir );
+
+ $self->_do_all_batch_conversions($mod2path, $outdir);
+
+ $progress and $progress->done(sprintf (
+ "Done converting %d files.", $self->{"__batch_conv_page_count"}
+ ));
+ return $self->_batch_convert_finish($outdir);
+ return $self;
+}
+
+
+sub _do_all_batch_conversions {
+ my($self, $mod2path, $outdir) = @_;
+ $self->{"__batch_conv_page_count"} = 0;
+
+ foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) {
+ $self->_do_one_batch_conversion($module, $mod2path, $outdir);
+ sleep($SLEEPY - 1) if $SLEEPY;
+ }
+
+ return;
+}
+
+sub _batch_convert_finish {
+ my($self, $outdir) = @_;
+ $self->write_contents_file($outdir);
+ $self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done.");
+ $self->muse( "= ", scalar(localtime) );
+ $self->progress and $self->progress->done("All done!");
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _do_one_batch_conversion {
+ my($self, $module, $mod2path, $outdir, $outfile) = @_;
+
+ my $retval;
+ my $total = scalar keys %$mod2path;
+ my $infile = $mod2path->{$module};
+ my @namelets = grep m/\S/, split "::", $module;
+ # this can stick around in the contents LoL
+ my $depth = scalar @namelets;
+ die "Contentless thingie?! $module $infile" unless @namelets; #sanity
+
+ $outfile ||= do {
+ my @n = @namelets;
+ $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION;
+ $self->filespecsys->catfile( $outdir, @n );
+ };
+
+ my $progress = $self->progress;
+
+ my $page = $self->html_render_class->new;
+ if(DEBUG > 5) {
+ $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ",
+ ref($page), " render ($depth) $module => $outfile");
+ } elsif(DEBUG > 2) {
+ $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile")
+ }
+
+ # Give each class a chance to init the converter:
+ $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
+ if $page->can('batch_mode_page_object_init');
+ # Init for the index (TOC), too.
+ $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
+ if $self->can('batch_mode_page_object_init');
+
+ # Now get busy...
+ $self->makepath($outdir => \@namelets);
+
+ $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module");
+
+ if( $retval = $page->parse_from_file($infile, $outfile) ) {
+ ++ $self->{"__batch_conv_page_count"} ;
+ $self->note_for_contents_file( \@namelets, $infile, $outfile );
+ } else {
+ $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false.");
+ }
+
+ $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth)
+ if $page->can('batch_mode_page_object_kill');
+ # The following isn't a typo. Note that it switches $self and $page.
+ $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth)
+ if $self->can('batch_mode_page_object_kill');
+
+ DEBUG > 4 and printf "%s %sb < $infile %s %sb\n",
+ $outfile, -s $outfile, $infile, -s $infile
+ ;
+
+ undef($page);
+ return $retval;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' }
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub note_for_contents_file {
+ my($self, $namelets, $infile, $outfile) = @_;
+
+ # I think the infile and outfile parts are never used. -- SMB
+ # But it's handy to have them around for debugging.
+
+ if( $self->contents_file ) {
+ my $c = $self->_contents();
+ push @$c,
+ [ join("::", @$namelets), $infile, $outfile, $namelets ]
+ # 0 1 2 3
+ ;
+ DEBUG > 3 and print "Noting @$c[-1]\n";
+ }
+ return;
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub write_contents_file {
+ my($self, $outdir) = @_;
+ my $outfile = $self->_contents_filespec($outdir) || return;
+
+ $self->muse("Preparing list of modules for ToC");
+
+ my($toplevel, # maps toplevelbit => [all submodules]
+ $toplevel_form_freq, # ends up being 'foo' => 'Foo'
+ ) = $self->_prep_contents_breakdown;
+
+ my $Contents = eval { $self->_wopen($outfile) };
+ if( $Contents ) {
+ $self->muse( "Writing contents file $outfile" );
+ } else {
+ warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all";
+ return;
+ }
+
+ $self->_write_contents_start( $Contents, $outfile, );
+ $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq );
+ $self->_write_contents_end( $Contents, $outfile, );
+ return $outfile;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_start {
+ my($self, $Contents, $outfile) = @_;
+ my $starter = $self->contents_page_start || '';
+
+ {
+ my $css_wad = $self->_css_wad_to_markup(1);
+ if( $css_wad ) {
+ $starter =~ s{(</head>)}{\n$css_wad\n$1}i; # otherwise nevermind
+ }
+
+ my $javascript_wad = $self->_javascript_wad_to_markup(1);
+ if( $javascript_wad ) {
+ $starter =~ s{(</head>)}{\n$javascript_wad\n$1}i; # otherwise nevermind
+ }
+ }
+
+ unless(print $Contents $starter, "<dl class='superindex'>\n" ) {
+ warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Contents);
+ return 0;
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_middle {
+ my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_;
+
+ foreach my $t (sort keys %$toplevel2submodules) {
+ my @downlines = sort {$a->[-1] cmp $b->[-1]}
+ @{ $toplevel2submodules->{$t} };
+
+ printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n],
+ esc( $t, $toplevel_form_freq->{$t} )
+ ;
+
+ my($path, $name);
+ foreach my $e (@downlines) {
+ $name = $e->[0];
+ $path = join( "/", '.', esc( @{$e->[3]} ) )
+ . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION);
+ print $Contents qq{ <a href="$path">}, esc($name), "</a>&nbsp;&nbsp;\n";
+ }
+ print $Contents "</dd>\n\n";
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_end {
+ my($self, $Contents, $outfile) = @_;
+ unless(
+ print $Contents "</dl>\n",
+ $self->contents_page_end || '',
+ ) {
+ warn "Couldn't write to $outfile: $!";
+ }
+ close($Contents) or warn "Couldn't close $outfile: $!";
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _prep_contents_breakdown {
+ my($self) = @_;
+ my $contents = $self->_contents;
+ my %toplevel; # maps lctoplevelbit => [all submodules]
+ my %toplevel_form_freq; # ends up being 'foo' => 'Foo'
+ # (mapping anycase forms to most freq form)
+
+ foreach my $entry (@$contents) {
+ my $toplevel =
+ $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs'
+ # group all the perlwhatever docs together
+ : $entry->[3][0] # normal case
+ ;
+ ++$toplevel_form_freq{ lc $toplevel }{ $toplevel };
+ push @{ $toplevel{ lc $toplevel } }, $entry;
+ push @$entry, lc($entry->[0]); # add a sort-order key to the end
+ }
+
+ foreach my $toplevel (sort keys %toplevel) {
+ my $fgroup = $toplevel_form_freq{$toplevel};
+ $toplevel_form_freq{$toplevel} =
+ (
+ sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b }
+ keys %$fgroup
+ # This hash is extremely unlikely to have more than 4 members, so this
+ # sort isn't so very wasteful
+ )[0];
+ }
+
+ return(\%toplevel, \%toplevel_form_freq) if wantarray;
+ return \%toplevel;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _contents_filespec {
+ my($self, $outdir) = @_;
+ my $outfile = $self->contents_file;
+ return unless $outfile;
+ return $self->filespecsys->catfile( $outdir, $outfile );
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub makepath {
+ my($self, $outdir, $namelets) = @_;
+ return unless @$namelets > 1;
+ for my $i (0 .. ($#$namelets - 1)) {
+ my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] );
+ if(-e $dir) {
+ die "$dir exists but not as a directory!?" unless -d $dir;
+ next;
+ }
+ DEBUG > 3 and print " Making $dir\n";
+ mkdir $dir, 0777
+ or die "Can't mkdir $dir: $!\nAborting"
+ ;
+ }
+ return;
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub batch_mode_page_object_init {
+ my $self = shift;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+
+ # TODO: any further options to percolate onto this new object here?
+
+ $page->default_title($module);
+ $page->index( $self->index );
+
+ $page->html_css( $self-> _css_wad_to_markup($depth) );
+ $page->html_javascript( $self->_javascript_wad_to_markup($depth) );
+
+ $self->add_header_backlink($page, $module, $infile, $outfile, $depth);
+ $self->add_footer_backlink($page, $module, $infile, $outfile, $depth);
+
+
+ return $self;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub add_header_backlink {
+ my $self = shift;
+ return if $self->no_contents_links;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+ $page->html_header_after_title( join '',
+ $page->html_header_after_title || '',
+
+ qq[<p class="backlinktop"><b><a name="___top" href="],
+ $self->url_up_to_contents($depth),
+ qq[" accesskey="1" title="All Documents">&lt;&lt;</a></b></p>\n],
+ )
+ if $self->contents_file
+ ;
+ return;
+}
+
+sub add_footer_backlink {
+ my $self = shift;
+ return if $self->no_contents_links;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+ $page->html_footer( join '',
+ qq[<p class="backlinkbottom"><b><a name="___bottom" href="],
+ $self->url_up_to_contents($depth),
+ qq[" title="All Documents">&lt;&lt;</a></b></p>\n],
+
+ $page->html_footer || '',
+ )
+ if $self->contents_file
+ ;
+ return;
+}
+
+sub url_up_to_contents {
+ my($self, $depth) = @_;
+ --$depth;
+ return join '/', ('..') x $depth, esc($self->contents_file);
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub find_all_pods {
+ my($self, $dirs) = @_;
+ # You can override find_all_pods in a subclass if you want to
+ # do extra filtering or whatnot. But for the moment, we just
+ # pass to modnames2paths:
+ return $self->modnames2paths($dirs);
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub modnames2paths { # return a hashref mapping modulenames => paths
+ my($self, $dirs) = @_;
+
+ my $m2p;
+ {
+ my $search = $self->search_class->new;
+ DEBUG and print "Searching via $search\n";
+ $search->verbose(1) if DEBUG > 10;
+ $search->progress( $self->progress->copy->goal(0) ) if $self->progress;
+ $search->shadows(0); # don't bother noting shadowed files
+ $search->inc( $dirs ? 0 : 1 );
+ $search->survey( $dirs ? @$dirs : () );
+ $m2p = $search->name2path;
+ die "What, no name2path?!" unless $m2p;
+ }
+
+ $self->muse("That's odd... no modules found!") unless keys %$m2p;
+ if( DEBUG > 4 ) {
+ print "Modules found (name => path):\n";
+ foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) {
+ print " $m $$m2p{$m}\n";
+ }
+ print "(total ", scalar(keys %$m2p), ")\n\n";
+ } elsif( DEBUG ) {
+ print "Found ", scalar(keys %$m2p), " modules.\n";
+ }
+ $self->muse( "Found ", scalar(keys %$m2p), " modules." );
+
+ # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref
+ return $m2p;
+}
+
+#===========================================================================
+
+sub _wopen {
+ # this is abstracted out so that the daemon class can override it
+ my($self, $outpath) = @_;
+ require Symbol;
+ my $out_fh = Symbol::gensym();
+ DEBUG > 5 and print "Write-opening to $outpath\n";
+ return $out_fh if open($out_fh, "> $outpath");
+ require Carp;
+ Carp::croak("Can't write-open $outpath: $!");
+}
+
+#==========================================================================
+
+sub add_css {
+ my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_;
+ return unless $url;
+ unless($name) {
+ # cook up a reasonable name based on the URL
+ $name = $url;
+ if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) {
+ $name = $1;
+ $name =~ s/\.css//i;
+ }
+ }
+ $media ||= 'all';
+ $content_type ||= 'text/css';
+
+ my $bunch = [$url, $name, $content_type, $media, $_code];
+ if($is_default) { unshift @{ $self->_css_wad }, $bunch }
+ else { push @{ $self->_css_wad }, $bunch }
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _spray_css {
+ my($self, $outdir) = @_;
+
+ return unless $self->css_flurry();
+ $self->_gen_css_wad();
+
+ my $lol = $self->_css_wad;
+ foreach my $chunk (@$lol) {
+ my $url = $chunk->[0];
+ my $outfile;
+ if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) {
+ $outfile = $self->filespecsys->catfile( $outdir, "$1" );
+ DEBUG > 5 and print "Noting $$chunk[0] as a file I'll create.\n";
+ } else {
+ DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n";
+ # Requires no further attention.
+ next;
+ }
+
+ #$self->muse( "Writing autogenerated CSS file $outfile" );
+ my $Cssout = $self->_wopen($outfile);
+ print $Cssout ${$chunk->[-1]}
+ or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Cssout);
+ DEBUG > 5 and print "Wrote $outfile\n";
+ }
+
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _css_wad_to_markup {
+ my($self, $depth) = @_;
+
+ my @css = @{ $self->_css_wad || return '' };
+ return '' unless @css;
+
+ my $rel = 'stylesheet';
+ my $out = '';
+
+ --$depth;
+ my $uplink = $depth ? ('../' x $depth) : '';
+
+ foreach my $chunk (@css) {
+ next unless $chunk and @$chunk;
+
+ my( $url1, $url2, $title, $type, $media) = (
+ $self->_maybe_uplink( $chunk->[0], $uplink ),
+ esc(grep !ref($_), @$chunk)
+ );
+
+ $out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n};
+
+ $rel = 'alternate stylesheet'; # alternates = all non-first iterations
+ }
+ return $out;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub _maybe_uplink {
+ # if the given URL looks relative, return the given uplink string --
+ # otherwise return emptystring
+ my($self, $url, $uplink) = @_;
+ ($url =~ m{^\./} or $url !~ m{[/\:]} )
+ ? $uplink
+ : ''
+ # qualify it, if/as needed
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub _gen_css_wad {
+ my $self = $_[0];
+ my $css_template = $self->_css_template;
+ foreach my $variation (
+
+ # Commented out for sake of concision:
+ #
+ # 011n=black_with_red_on_white
+ # 001n=black_with_yellow_on_white
+ # 101n=black_with_green_on_white
+ # 110=white_with_yellow_on_black
+ # 010=white_with_green_on_black
+ # 011=white_with_blue_on_black
+ # 100=white_with_red_on_black
+ '110n=blkbluw', # black_with_blue_on_white
+ '010n=blkmagw', # black_with_magenta_on_white
+ '100n=blkcynw', # black_with_cyan_on_white
+ '101=whtprpk', # white_with_purple_on_black
+ '001=whtnavk', # white_with_navy_blue_on_black
+ '010a=grygrnk', # grey_with_green_on_black
+ '010b=whtgrng', # white_with_green_on_grey
+ '101an=blkgrng', # black_with_green_on_grey
+ '101bn=grygrnw', # grey_with_green_on_white
+ ) {
+
+ my $outname = $variation;
+ my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3)
+ if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s;
+ @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op!
+
+ my $this_css =
+ "/* This file is autogenerated. Do not edit. $variation */\n\n"
+ . $css_template;
+
+ # Only look at three-digitty colors, for now at least.
+ if( $flipmode =~ m/n/ ) {
+ $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg;
+ $this_css =~ s/\bthin\b/medium/g;
+ }
+ $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b>
+ < join '', '#', ($1,$2,$3)[@swap] >eg if @swap;
+
+ if( $flipmode =~ m/a/)
+ { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey
+ elsif($flipmode =~ m/b/)
+ { $this_css =~ s/#000\b/#666/gi } # white -> light grey
+
+ my $name = $outname;
+ $name =~ tr/-_/ /;
+ $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
+ }
+
+ # Now a few indexless variations:
+ foreach my $variation (
+ 'blkbluw', # black_with_blue_on_white
+ 'whtpurk', # white_with_purple_on_black
+ 'whtgrng', # white_with_green_on_grey
+ 'grygrnw', # grey_with_green_on_white
+ ) {
+ my $outname = "$variation\_";
+ my $this_css = join "\n",
+ "/* This file is autogenerated. Do not edit. $outname */\n",
+ "\@import url(\"./_$variation.css\");",
+ ".indexgroup { display: none; }",
+ "\n",
+ ;
+ my $name = $outname;
+ $name =~ tr/-_/ /;
+ $self->add_css( "$outname.css", 0, $name, 0, 0, \$this_css);
+ }
+
+ return;
+}
+
+sub _color_negate {
+ my $x = lc $_[0];
+ $x =~ tr[0123456789abcdef]
+ [fedcba9876543210];
+ return $x;
+}
+
+#===========================================================================
+
+sub add_javascript {
+ my($self, $url, $content_type, $_code) = @_;
+ return unless $url;
+ push @{ $self->_javascript_wad }, [
+ $url, $content_type || 'text/javascript', $_code
+ ];
+ return;
+}
+
+sub _spray_javascript {
+ my($self, $outdir) = @_;
+ return unless $self->javascript_flurry();
+ $self->_gen_javascript_wad();
+
+ my $lol = $self->_javascript_wad;
+ foreach my $script (@$lol) {
+ my $url = $script->[0];
+ my $outfile;
+
+ if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) {
+ $outfile = $self->filespecsys->catfile( $outdir, "$1" );
+ DEBUG > 5 and print "Noting $$script[0] as a file I'll create.\n";
+ } else {
+ DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n";
+ next;
+ }
+
+ #$self->muse( "Writing JavaScript file $outfile" );
+ my $Jsout = $self->_wopen($outfile);
+
+ print $Jsout ${$script->[-1]}
+ or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Jsout);
+ DEBUG > 5 and print "Wrote $outfile\n";
+ }
+
+ return;
+}
+
+sub _gen_javascript_wad {
+ my $self = $_[0];
+ my $js_code = $self->_javascript || return;
+ $self->add_javascript( "_podly.js", 0, \$js_code);
+ return;
+}
+
+sub _javascript_wad_to_markup {
+ my($self, $depth) = @_;
+
+ my @scripts = @{ $self->_javascript_wad || return '' };
+ return '' unless @scripts;
+
+ my $out = '';
+
+ --$depth;
+ my $uplink = $depth ? ('../' x $depth) : '';
+
+ foreach my $s (@scripts) {
+ next unless $s and @$s;
+
+ my( $url1, $url2, $type, $media) = (
+ $self->_maybe_uplink( $s->[0], $uplink ),
+ esc(grep !ref($_), @$s)
+ );
+
+ $out .= qq{<script type="$type" src="$url1$url2"></script>\n};
+ }
+ return $out;
+}
+
+#===========================================================================
+
+sub _css_template { return $CSS }
+sub _javascript { return $JAVASCRIPT }
+
+$CSS = <<'EOCSS';
+/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */
+
+@media all { .hide { display: none; } }
+
+@media print {
+ .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none }
+
+ * {
+ border-color: black !important;
+ color: black !important;
+ background-color: transparent !important;
+ background-image: none !important;
+ }
+
+ dl.superindex > dd {
+ word-spacing: .6em;
+ }
+}
+
+@media aural, braille, embossed {
+ div.indexgroup { display: none; } /* Too noisy, don't you think? */
+ dl.superindex > dt:before { content: "Group "; }
+ dl.superindex > dt:after { content: " contains:"; }
+ .backlinktop a:before { content: "Back to contents"; }
+ .backlinkbottom a:before { content: "Back to contents"; }
+}
+
+@media aural {
+ dl.superindex > dt { pause-before: 600ms; }
+}
+
+@media screen, tty, tv, projection {
+ .noscreen { display: none; }
+
+ a:link { color: #7070ff; text-decoration: underline; }
+ a:visited { color: #e030ff; text-decoration: underline; }
+ a:active { color: #800000; text-decoration: underline; }
+ body.contentspage a { text-decoration: none; }
+ a.u { color: #fff !important; text-decoration: none; }
+
+ body.pod {
+ margin: 0 5px;
+ color: #fff;
+ background-color: #000;
+ }
+
+ body.pod h1, body.pod h2, body.pod h3, body.pod h4 {
+ font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
+ font-weight: normal;
+ margin-top: 1.2em;
+ margin-bottom: .1em;
+ border-top: thin solid transparent;
+ /* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */
+ }
+
+ body.pod h1 { border-top-color: #0a0; }
+ body.pod h2 { border-top-color: #080; }
+ body.pod h3 { border-top-color: #040; }
+ body.pod h4 { border-top-color: #010; }
+
+ p.backlinktop + h1 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h2 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h3 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h4 { border-top: none; margin-top: 0em; }
+
+ body.pod dt {
+ font-size: 105%; /* just a wee bit more than normal */
+ }
+
+ .indexgroup { font-size: 80%; }
+
+ .backlinktop, .backlinkbottom {
+ margin-left: -5px;
+ margin-right: -5px;
+ background-color: #040;
+ border-top: thin solid #050;
+ border-bottom: thin solid #050;
+ }
+
+ .backlinktop a, .backlinkbottom a {
+ text-decoration: none;
+ color: #080;
+ background-color: #000;
+ border: thin solid #0d0;
+ }
+ .backlinkbottom { margin-bottom: 0; padding-bottom: 0; }
+ .backlinktop { margin-top: 0; padding-top: 0; }
+
+ body.contentspage {
+ color: #fff;
+ background-color: #000;
+ }
+
+ body.contentspage h1 {
+ color: #0d0;
+ margin-left: 1em;
+ margin-right: 1em;
+ text-indent: -.9em;
+ font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
+ font-weight: normal;
+ border-top: thin solid #fff;
+ border-bottom: thin solid #fff;
+ text-align: center;
+ }
+
+ dl.superindex > dt {
+ font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
+ font-weight: normal;
+ font-size: 90%;
+ margin-top: .45em;
+ /* margin-bottom: -.15em; */
+ }
+ dl.superindex > dd {
+ word-spacing: .6em; /* most important rule here! */
+ }
+ dl.superindex > a:link {
+ text-decoration: none;
+ color: #fff;
+ }
+
+ .contentsfooty {
+ border-top: thin solid #999;
+ font-size: 90%;
+ }
+
+}
+
+/* The End */
+
+EOCSS
+
+#==========================================================================
+
+$JAVASCRIPT = <<'EOJAVASCRIPT';
+
+// From http://www.alistapart.com/articles/alternate/
+
+function setActiveStyleSheet(title) {
+ var i, a, main;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) {
+ a.disabled = true;
+ if(a.getAttribute("title") == title) a.disabled = false;
+ }
+ }
+}
+
+function getActiveStyleSheet() {
+ var i, a;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if( a.getAttribute("rel").indexOf("style") != -1
+ && a.getAttribute("title")
+ && !a.disabled
+ ) return a.getAttribute("title");
+ }
+ return null;
+}
+
+function getPreferredStyleSheet() {
+ var i, a;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if( a.getAttribute("rel").indexOf("style") != -1
+ && a.getAttribute("rel").indexOf("alt") == -1
+ && a.getAttribute("title")
+ ) return a.getAttribute("title");
+ }
+ return null;
+}
+
+function createCookie(name,value,days) {
+ if (days) {
+ var date = new Date();
+ date.setTime(date.getTime()+(days*24*60*60*1000));
+ var expires = "; expires="+date.toGMTString();
+ }
+ else expires = "";
+ document.cookie = name+"="+value+expires+"; path=/";
+}
+
+function readCookie(name) {
+ var nameEQ = name + "=";
+ var ca = document.cookie.split(';');
+ for(var i=0 ; i < ca.length ; i++) {
+ var c = ca[i];
+ while (c.charAt(0)==' ') c = c.substring(1,c.length);
+ if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
+ }
+ return null;
+}
+
+window.onload = function(e) {
+ var cookie = readCookie("style");
+ var title = cookie ? cookie : getPreferredStyleSheet();
+ setActiveStyleSheet(title);
+}
+
+window.onunload = function(e) {
+ var title = getActiveStyleSheet();
+ createCookie("style", title, 365);
+}
+
+var cookie = readCookie("style");
+var title = cookie ? cookie : getPreferredStyleSheet();
+setActiveStyleSheet(title);
+
+// The End
+
+EOJAVASCRIPT
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+1;
+__END__
+
+
+=head1 NAME
+
+Pod::Simple::HTMLBatch - convert several Pod files to several HTML files
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out
+
+
+=head1 DESCRIPTION
+
+This module is used for running batch-conversions of a lot of HTML
+documents
+
+This class is NOT a subclass of Pod::Simple::HTML
+(nor of bad old Pod::Html) -- although it uses
+Pod::Simple::HTML for doing the conversion of each document.
+
+The normal use of this class is like so:
+
+ use Pod::Simple::HTMLBatch;
+ my $batchconv = Pod::Simple::HTMLBatch->new;
+ $batchconv->some_option( some_value );
+ $batchconv->some_other_option( some_other_value );
+ $batchconv->batch_convert( \@search_dirs, $output_dir );
+
+=head2 FROM THE COMMAND LINE
+
+Note that this class also provides
+(but does not export) the function Pod::Simple::HTMLBatch::go.
+This is basically just a shortcut for C<<
+Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>.
+It's meant to be handy for calling from the command line.
+
+However, the shortcut requires that you specify exactly two command-line
+arguments, C<indirs> and C<outdir>.
+
+Example:
+
+ % mkdir out_html
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html
+ (to convert the pod from Perl's @INC
+ files under the directory ../htmlversion)
+
+(Note that the command line there contains a literal atsign-I-N-C. This
+is handled as a special case by batch_convert, in order to save you having
+to enter the odd-looking "" as the first command-line parameter when you
+mean "just use whatever's in @INC".)
+
+Example:
+
+ % mkdir ../seekrut
+ % chmod og-rx ../seekrut
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../htmlversion
+ (to convert the pod under the current dir into HTML
+ files under the directory ../htmlversion)
+
+Example:
+
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs .
+ (to convert all pod from happydocs into the current directory)
+
+
+
+=head1 MAIN METHODS
+
+=over
+
+=item $batchconv = Pod::Simple::HTMLBatch->new;
+
+This TODO
+
+
+=item $batchconv->batch_convert( I<indirs>, I<outdir> );
+
+this TODO
+
+=item $batchconv->batch_convert( undef , ...);
+
+=item $batchconv->batch_convert( q{@INC}, ...);
+
+These two values for I<indirs> specify that the normal Perl @INC
+
+=item $batchconv->batch_convert( \@dirs , ...);
+
+This specifies that the input directories are the items in
+the arrayref C<\@dirs>.
+
+=item $batchconv->batch_convert( "somedir" , ...);
+
+This specifies that the director "somedir" is the input.
+(This can be an absolute or relative path, it doesn't matter.)
+
+A common value you might want would be just "." for the current
+directory:
+
+ $batchconv->batch_convert( "." , ...);
+
+
+=item $batchconv->batch_convert( 'somedir:someother:also' , ...);
+
+This specifies that you want the dirs "somedir", "somother", and "also"
+scanned, just as if you'd passed the arrayref
+C<[qw( somedir someother also)]>. Note that a ":"-separator is normal
+under Unix, but Under MSWin, you'll need C<'somedir;someother;also'>
+instead, since the pathsep on MSWin is ";" instead of ":". (And
+I<that> is because ":" often comes up in paths, like
+C<"c:/perl/lib">.)
+
+(Exactly what separator character should be used, is gotten from
+C<$Config::Config{'path_sep'}>, via the L<Config> module.)
+
+=item $batchconv->batch_convert( ... , undef );
+
+This specifies that you want the HTML output to go into the current
+directory.
+
+(Note that a missing or undefined value means a different thing in
+the first slot than in the second. That's so that C<batch_convert()>
+with no arguments (or undef arguments) means "go from @INC, into
+the current directory.)
+
+=item $batchconv->batch_convert( ... , 'somedir' );
+
+This specifies that you want the HTML output to go into the
+directory 'somedir'.
+(This can be an absolute or relative path, it doesn't matter.)
+
+=back
+
+
+Note that you can also call C<batch_convert> as a class method,
+like so:
+
+ Pod::Simple::HTMLBatch->batch_convert( ... );
+
+That is just short for this:
+
+ Pod::Simple::HTMLBatch-> new-> batch_convert(...);
+
+That is, it runs a conversion with default options, for
+whatever inputdirs and output dir you specify.
+
+
+=head2 ACCESSOR METHODS
+
+The following are all accessor methods -- that is, they don't do anything
+on their own, but just alter the contents of the conversion object,
+which comprises the options for this particular batch conversion.
+
+We show the "put" form of the accessors below (i.e., the syntax you use
+for setting the accessor to a specific value). But you can also
+call each method with no parameters to get its current value. For
+example, C<< $self->contents_file() >> returns the current value of
+the contents_file attribute.
+
+=over
+
+
+=item $batchconv->verbose( I<nonnegative_integer> );
+
+This controls how verbose to be during batch conversion, as far as
+notes to STDOUT (or whatever is C<select>'d) about how the conversion
+is going. If 0, no progress information is printed.
+If 1 (the default value), some progress information is printed.
+Higher values print more information.
+
+
+=item $batchconv->index( I<true-or-false> );
+
+This controls whether or not each HTML page is liable to have a little
+table of contents at the top (which we call an "index" for historical
+reasons). This is true by default.
+
+
+=item $batchconv->contents_file( I<filename> );
+
+If set, should be the name of a file (in the output directory)
+to write the HTML index to. The default value is "index.html".
+If you set this to a false value, no contents file will be written.
+
+=item $batchconv->contents_page_start( I<HTML_string> );
+
+This specifies what string should be put at the beginning of
+the contents page.
+The default is a string more or less like this:
+
+ <html>
+ <head><title>Perl Documentation</title></head>
+ <body class='contentspage'>
+ <h1>Perl Documentation</h1>
+
+=item $batchconv->contents_page_end( I<HTML_string> );
+
+This specifies what string should be put at the end of the contents page.
+The default is a string more or less like this:
+
+ <p class='contentsfooty'>Generated by
+ Pod::Simple::HTMLBatch v3.01 under Perl v5.008
+ <br >At Fri May 14 22:26:42 2004 GMT,
+ which is Fri May 14 14:26:42 2004 local time.</p>
+
+
+
+=item $batchconv->add_css( $url );
+
+TODO
+
+=item $batchconv->add_javascript( $url );
+
+TODO
+
+=item $batchconv->css_flurry( I<true-or-false> );
+
+If true (the default value), we autogenerate some CSS files in the
+output directory, and set our HTML files to use those.
+TODO: continue
+
+=item $batchconv->javascript_flurry( I<true-or-false> );
+
+If true (the default value), we autogenerate a JavaScript in the
+output directory, and set our HTML files to use it. Currently,
+the JavaScript is used only to get the browser to remember what
+stylesheet it prefers.
+TODO: continue
+
+=item $batchconv->no_contents_links( I<true-or-false> );
+
+TODO
+
+=item $batchconv->html_render_class( I<classname> );
+
+This sets what class is used for rendering the files.
+The default is "Pod::Simple::HTML". If you set it to something else,
+it should probably be a subclass of Pod::Simple::HTML, and you should
+C<require> or C<use> that class so that's it's loaded before
+Pod::Simple::HTMLBatch tries loading it.
+
+=item $batchconv->search_class( I<classname> );
+
+This sets what class is used for searching for the files.
+The default is "Pod::Simple::Search". If you set it to something else,
+it should probably be a subclass of Pod::Simple::Search, and you should
+C<require> or C<use> that class so that's it's loaded before
+Pod::Simple::HTMLBatch tries loading it.
+
+=back
+
+
+
+
+=head1 NOTES ON CUSTOMIZATION
+
+TODO
+
+ call add_css($someurl) to add stylesheet as alternate
+ call add_css($someurl,1) to add as primary stylesheet
+
+ call add_javascript
+
+ subclass Pod::Simple::HTML and set $batchconv->html_render_class to
+ that classname
+ and maybe override
+ $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
+ or maybe override
+ $batchconv->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
+ subclass Pod::Simple::Search and set $batchconv->search_class to
+ that classname
+
+
+
+=head1 ASK ME!
+
+If you want to do some kind of big pod-to-HTML version with some
+particular kind of option that you don't see how to achieve using this
+module, email me (C<sburke@cpan.org>) and I'll probably have a good idea
+how to do it. For reasons of concision and energetic laziness, some
+methods and options in this module (and the dozen modules it depends on)
+are undocumented; but one of those undocumented bits might be just what
+you're looking for.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::HTMLBatch>, L<perlpod>, L<perlpodspec>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLLegacy.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLLegacy.pm
new file mode 100755
index 00000000000..f78de90144f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/HTMLLegacy.pm
@@ -0,0 +1,104 @@
+
+require 5;
+package Pod::Simple::HTMLLegacy;
+use strict;
+
+use vars qw($VERSION);
+use Getopt::Long;
+
+$VERSION = "5.01";
+
+#--------------------------------------------------------------------------
+#
+# This class is meant to thinly emulate bad old Pod::Html
+#
+# TODO: some basic docs
+
+sub pod2html {
+ my @args = (@_);
+
+ my( $verbose, $infile, $outfile, $title );
+ my $index = 1;
+
+ {
+ my($help);
+
+ my($netscape); # dummy
+ local @ARGV = @args;
+ GetOptions(
+ "help" => \$help,
+ "verbose!" => \$verbose,
+ "infile=s" => \$infile,
+ "outfile=s" => \$outfile,
+ "title=s" => \$title,
+ "index!" => \$index,
+
+ "netscape!" => \$netscape,
+ ) or return bad_opts(@args);
+ bad_opts(@args) if @ARGV; # it should be all switches!
+ return help_message() if $help;
+ }
+
+ for($infile, $outfile) { $_ = undef unless defined and length }
+
+ if($verbose) {
+ warn sprintf "%s version %s\n", __PACKAGE__, $VERSION;
+ warn "OK, processed args [@args] ...\n";
+ warn sprintf
+ " Verbose: %s\n Index: %s\n Infile: %s\n Outfile: %s\n Title: %s\n",
+ map defined($_) ? $_ : "(nil)",
+ $verbose, $index, $infile, $outfile, $title,
+ ;
+ *Pod::Simple::HTML::DEBUG = sub(){1};
+ }
+ require Pod::Simple::HTML;
+ Pod::Simple::HTML->VERSION(3);
+
+ die "No such input file as $infile\n"
+ if defined $infile and ! -e $infile;
+
+
+ my $pod = Pod::Simple::HTML->new;
+ $pod->force_title($title) if defined $title;
+ $pod->index($index);
+ return $pod->parse_from_file($infile, $outfile);
+}
+
+#--------------------------------------------------------------------------
+
+sub bad_opts { die _help_message(); }
+sub help_message { print STDOUT _help_message() }
+
+#--------------------------------------------------------------------------
+
+sub _help_message {
+
+ join '',
+
+"[", __PACKAGE__, " version ", $VERSION, qq~]
+Usage: pod2html --help --infile=<name> --outfile=<name>
+ --verbose --index --noindex
+
+Options:
+ --help - prints this message.
+ --[no]index - generate an index at the top of the resulting html
+ (default behavior).
+ --infile - filename for the pod to convert (input taken from stdin
+ by default).
+ --outfile - filename for the resulting html file (output sent to
+ stdout by default).
+ --title - title that will appear in resulting html file.
+ --[no]verbose - self-explanatory (off by default).
+
+Note that pod2html is DEPRECATED, and this version implements only
+ some of the options known to older versions.
+For more information, see 'perldoc pod2html'.
+~;
+
+}
+
+1;
+__END__
+
+OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!!
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/LinkSection.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/LinkSection.pm
new file mode 100755
index 00000000000..c219ebd2611
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/LinkSection.pm
@@ -0,0 +1,174 @@
+
+require 5;
+package Pod::Simple::LinkSection;
+ # Based somewhat dimly on Array::Autojoin
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+use strict;
+use Pod::Simple::BlackBox;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+use overload( # So it'll stringify nice
+ '""' => \&Pod::Simple::BlackBox::stringify_lol,
+ 'bool' => \&Pod::Simple::BlackBox::stringify_lol,
+ # '.=' => \&tack_on, # grudgingly support
+
+ 'fallback' => 1, # turn on cleverness
+);
+
+sub tack_on {
+ $_[0] = ['', {}, "$_[0]" ];
+ return $_[0][2] .= $_[1];
+}
+
+sub as_string {
+ goto &Pod::Simple::BlackBox::stringify_lol;
+}
+sub stringify {
+ goto &Pod::Simple::BlackBox::stringify_lol;
+}
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $new;
+ if(@_ == 1) {
+ if (!ref($_[0] || '')) { # most common case: one bare string
+ return bless ['', {}, $_[0] ], $class;
+ } elsif( ref($_[0] || '') eq 'ARRAY') {
+ $new = [ @{ $_[0] } ];
+ } else {
+ Carp::croak( "$class new() doesn't know to clone $new" );
+ }
+ } else { # misc stuff
+ $new = [ '', {}, @_ ];
+ }
+
+ # By now it's a treelet: [ 'foo', {}, ... ]
+ foreach my $x (@$new) {
+ if(ref($x || '') eq 'ARRAY') {
+ $x = $class->new($x); # recurse
+ } elsif(ref($x || '') eq 'HASH') {
+ $x = { %$x };
+ }
+ # otherwise leave it.
+ }
+
+ return bless $new, $class;
+}
+
+# Not much in this class is likely to be link-section specific --
+# but it just so happens that link-sections are about the only treelets
+# that are exposed to the user.
+
+1;
+
+__END__
+
+# TODO: let it be an option whether a given subclass even wants little treelets?
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::LinkSection -- represent "section" attributes of L codes
+
+=head1 SYNOPSIS
+
+ # a long story
+
+=head1 DESCRIPTION
+
+This class is not of interest to general users.
+
+Pod::Simple uses this class for representing the value of the
+"section" attribute of "L" start-element events. Most applications
+can just use the normal stringification of objects of this class;
+they stringify to just the text content of the section,
+such as "foo" for
+C<< LZ<><Stuff/foo> >>, and "bar" for
+C<< LZ<><Stuff/bIZ<><ar>> >>.
+
+However, anyone particularly interested in getting the full value of
+the treelet, can just traverse the content of the treeleet
+@$treelet_object. To wit:
+
+
+ % perl -MData::Dumper -e
+ "use base qw(Pod::Simple::Methody);
+ sub start_L { print Dumper($_[1]{'section'} ) }
+ __PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
+ "
+Output:
+ $VAR1 = bless( [
+ '',
+ {},
+ 'b',
+ bless( [
+ 'I',
+ {},
+ 'ar'
+ ], 'Pod::Simple::LinkSection' ),
+ 'baz'
+ ], 'Pod::Simple::LinkSection' );
+
+But stringify it and you get just the text content:
+
+ % perl -MData::Dumper -e
+ "use base qw(Pod::Simple::Methody);
+ sub start_L { print Dumper( '' . $_[1]{'section'} ) }
+ __PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
+ "
+Output:
+ $VAR1 = 'barbaz';
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2004 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Methody.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Methody.pm
new file mode 100755
index 00000000000..15c63efb780
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Methody.pm
@@ -0,0 +1,152 @@
+
+require 5;
+package Pod::Simple::Methody;
+use strict;
+use Pod::Simple ();
+use vars qw(@ISA $VERSION);
+$VERSION = '3.13';
+@ISA = ('Pod::Simple');
+
+# Yes, we could use named variables, but I want this to be impose
+# as little an additional performance hit as possible.
+
+sub _handle_element_start {
+ $_[1] =~ tr/-:./__/;
+ ( $_[0]->can( 'start_' . $_[1] )
+ || return
+ )->(
+ $_[0], $_[2]
+ );
+}
+
+sub _handle_text {
+ ( $_[0]->can( 'handle_text' )
+ || return
+ )->(
+ @_
+ );
+}
+
+sub _handle_element_end {
+ $_[1] =~ tr/-:./__/;
+ ( $_[0]->can( 'end_' . $_[1] )
+ || return
+ )->(
+ $_[0]
+ );
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Methody -- turn Pod::Simple events into method calls
+
+=head1 SYNOPSIS
+
+ require 5;
+ use strict;
+ package SomePodFormatter;
+ use base qw(Pod::Simple::Methody);
+
+ sub handle_text {
+ my($self, $text) = @_;
+ ...
+ }
+
+ sub start_head1 {
+ my($self, $attrs) = @_;
+ ...
+ }
+ sub end_head1 {
+ my($self) = @_;
+ ...
+ }
+
+...and start_/end_ methods for whatever other events you want to catch.
+
+=head1 DESCRIPTION
+
+This class is of
+interest to people writing Pod formatters based on Pod::Simple.
+
+This class (which is very small -- read the source) overrides
+Pod::Simple's _handle_element_start, _handle_text, and
+_handle_element_end methods so that parser events are turned into method
+calls. (Otherwise, this is a subclass of L<Pod::Simple> and inherits all
+its methods.)
+
+You can use this class as the base class for a Pod formatter/processor.
+
+=head1 METHOD CALLING
+
+When Pod::Simple sees a "=head1 Hi there", for example, it basically does
+this:
+
+ $parser->_handle_element_start( "head1", \%attributes );
+ $parser->_handle_text( "Hi there" );
+ $parser->_handle_element_end( "head1" );
+
+But if you subclass Pod::Simple::Methody, it will instead do this
+when it sees a "=head1 Hi there":
+
+ $parser->start_head1( \%attributes ) if $parser->can('start_head1');
+ $parser->handle_text( "Hi there" ) if $parser->can('handle_text');
+ $parser->end_head1() if $parser->can('end_head1');
+
+If Pod::Simple sends an event where the element name has a dash,
+period, or colon, the corresponding method name will have a underscore
+in its place. For example, "foo.bar:baz" becomes start_foo_bar_baz
+and end_foo_bar_baz.
+
+See the source for Pod::Simple::Text for an example of using this class.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Progress.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Progress.pm
new file mode 100755
index 00000000000..06b643f3cb9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Progress.pm
@@ -0,0 +1,93 @@
+
+require 5;
+package Pod::Simple::Progress;
+$VERSION = '3.13';
+use strict;
+
+# Objects of this class are used for noting progress of an
+# operation every so often. Messages delivered more often than that
+# are suppressed.
+#
+# There's actually nothing in here that's specific to Pod processing;
+# but it's ad-hoc enough that I'm not willing to give it a name that
+# implies that it's generally useful, like "IO::Progress" or something.
+#
+# -- sburke
+#
+#--------------------------------------------------------------------------
+
+sub new {
+ my($class,$delay) = @_;
+ my $self = bless {'quiet_until' => 1}, ref($class) || $class;
+ $self->to(*STDOUT{IO});
+ $self->delay(defined($delay) ? $delay : 5);
+ return $self;
+}
+
+sub copy {
+ my $orig = shift;
+ bless {%$orig, 'quiet_until' => 1}, ref($orig);
+}
+#--------------------------------------------------------------------------
+
+sub reach {
+ my($self, $point, $note) = @_;
+ if( (my $now = time) >= $self->{'quiet_until'}) {
+ my $goal;
+ my $to = $self->{'to'};
+ print $to join('',
+ ($self->{'quiet_until'} == 1) ? () : '... ',
+ (defined $point) ? (
+ '#',
+ ($goal = $self->{'goal'}) ? (
+ ' ' x (length($goal) - length($point)),
+ $point, '/', $goal,
+ ) : $point,
+ $note ? ': ' : (),
+ ) : (),
+ $note || '',
+ "\n"
+ );
+ $self->{'quiet_until'} = $now + $self->{'delay'};
+ }
+ return $self;
+}
+
+#--------------------------------------------------------------------------
+
+sub done {
+ my($self, $note) = @_;
+ $self->{'quiet_until'} = 1;
+ return $self->reach( undef, $note );
+}
+
+#--------------------------------------------------------------------------
+# Simple accessors:
+
+sub delay {
+ return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] }
+sub goal {
+ return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] }
+sub to {
+ return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] }
+
+#--------------------------------------------------------------------------
+
+unless(caller) { # Simple self-test:
+ my $p = __PACKAGE__->new->goal(5);
+ $p->reach(1, "Primus!");
+ sleep 1;
+ $p->reach(2, "Secundus!");
+ sleep 3;
+ $p->reach(3, "Tertius!");
+ sleep 5;
+ $p->reach(4);
+ $p->reach(5, "Quintus!");
+ sleep 1;
+ $p->done("All done");
+}
+
+#--------------------------------------------------------------------------
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParser.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParser.pm
new file mode 100755
index 00000000000..eaef116e646
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParser.pm
@@ -0,0 +1,844 @@
+
+require 5;
+package Pod::Simple::PullParser;
+$VERSION = '3.13';
+use Pod::Simple ();
+BEGIN {@ISA = ('Pod::Simple')}
+
+use strict;
+use Carp ();
+
+use Pod::Simple::PullParserStartToken;
+use Pod::Simple::PullParserEndToken;
+use Pod::Simple::PullParserTextToken;
+
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+__PACKAGE__->_accessorize(
+ 'source_fh', # the filehandle we're reading from
+ 'source_scalar_ref', # the scalarref we're reading from
+ 'source_arrayref', # the arrayref we're reading from
+);
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And here is how we implement a pull-parser on top of a push-parser...
+
+sub filter {
+ my($self, $source) = @_;
+ $self = $self->new unless ref $self;
+
+ $source = *STDIN{IO} unless defined $source;
+ $self->set_source($source);
+ $self->output_fh(*STDOUT{IO});
+
+ $self->run; # define run() in a subclass if you want to use filter()!
+ return $self;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub parse_string_document {
+ my $this = shift;
+ $this->set_source(\ $_[0]);
+ $this->run;
+}
+
+sub parse_file {
+ my($this, $filename) = @_;
+ $this->set_source($filename);
+ $this->run;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# In case anyone tries to use them:
+
+sub run {
+ use Carp ();
+ if( __PACKAGE__ eq ref($_[0]) || $_[0]) { # I'm not being subclassed!
+ Carp::croak "You can call run() only on subclasses of "
+ . __PACKAGE__;
+ } else {
+ Carp::croak join '',
+ "You can't call run() because ",
+ ref($_[0]) || $_[0], " didn't define a run() method";
+ }
+}
+
+sub parse_lines {
+ use Carp ();
+ Carp::croak "Use set_source with ", __PACKAGE__,
+ " and subclasses, not parse_lines";
+}
+
+sub parse_line {
+ use Carp ();
+ Carp::croak "Use set_source with ", __PACKAGE__,
+ " and subclasses, not parse_line";
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ die "Couldn't construct for $class" unless $self;
+
+ $self->{'token_buffer'} ||= [];
+ $self->{'start_token_class'} ||= 'Pod::Simple::PullParserStartToken';
+ $self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken';
+ $self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken';
+
+ DEBUG > 1 and print "New pullparser object: $self\n";
+
+ return $self;
+}
+
+# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+
+sub get_token {
+ my $self = shift;
+ DEBUG > 1 and print "\nget_token starting up on $self.\n";
+ DEBUG > 2 and print " Items in token-buffer (",
+ scalar( @{ $self->{'token_buffer'} } ) ,
+ ") :\n", map(
+ " " . $_->dump . "\n", @{ $self->{'token_buffer'} }
+ ),
+ @{ $self->{'token_buffer'} } ? '' : ' (no tokens)',
+ "\n"
+ ;
+
+ until( @{ $self->{'token_buffer'} } ) {
+ DEBUG > 3 and print "I need to get something into my empty token buffer...\n";
+ if($self->{'source_dead'}) {
+ DEBUG and print "$self 's source is dead.\n";
+ push @{ $self->{'token_buffer'} }, undef;
+ } elsif(exists $self->{'source_fh'}) {
+ my @lines;
+ my $fh = $self->{'source_fh'}
+ || Carp::croak('You have to call set_source before you can call get_token');
+
+ DEBUG and print "$self 's source is filehandle $fh.\n";
+ # Read those many lines at a time
+ for(my $i = Pod::Simple::MANY_LINES; $i--;) {
+ DEBUG > 3 and print " Fetching a line from source filehandle $fh...\n";
+ local $/ = $Pod::Simple::NL;
+ push @lines, scalar(<$fh>); # readline
+ DEBUG > 3 and print " Line is: ",
+ defined($lines[-1]) ? $lines[-1] : "<undef>\n";
+ unless( defined $lines[-1] ) {
+ DEBUG and print "That's it for that source fh! Killing.\n";
+ delete $self->{'source_fh'}; # so it can be GC'd
+ last;
+ }
+ # but pass thru the undef, which will set source_dead to true
+
+ # TODO: look to see if $lines[-1] is =encoding, and if so,
+ # do horribly magic things
+
+ }
+
+ if(DEBUG > 8) {
+ print "* I've gotten ", scalar(@lines), " lines:\n";
+ foreach my $l (@lines) {
+ if(defined $l) {
+ print " line {$l}\n";
+ } else {
+ print " line undef\n";
+ }
+ }
+ print "* end of ", scalar(@lines), " lines\n";
+ }
+
+ $self->SUPER::parse_lines(@lines);
+
+ } elsif(exists $self->{'source_arrayref'}) {
+ DEBUG and print "$self 's source is arrayref $self->{'source_arrayref'}, with ",
+ scalar(@{$self->{'source_arrayref'}}), " items left in it.\n";
+
+ DEBUG > 3 and print " Fetching ", Pod::Simple::MANY_LINES, " lines.\n";
+ $self->SUPER::parse_lines(
+ splice @{ $self->{'source_arrayref'} },
+ 0,
+ Pod::Simple::MANY_LINES
+ );
+ unless( @{ $self->{'source_arrayref'} } ) {
+ DEBUG and print "That's it for that source arrayref! Killing.\n";
+ $self->SUPER::parse_lines(undef);
+ delete $self->{'source_arrayref'}; # so it can be GC'd
+ }
+ # to make sure that an undef is always sent to signal end-of-stream
+
+ } elsif(exists $self->{'source_scalar_ref'}) {
+
+ DEBUG and print "$self 's source is scalarref $self->{'source_scalar_ref'}, with ",
+ length(${ $self->{'source_scalar_ref'} }) -
+ (pos(${ $self->{'source_scalar_ref'} }) || 0),
+ " characters left to parse.\n";
+
+ DEBUG > 3 and print " Fetching a line from source-string...\n";
+ if( ${ $self->{'source_scalar_ref'} } =~
+ m/([^\n\r]*)((?:\r?\n)?)/g
+ ) {
+ #print(">> $1\n"),
+ $self->SUPER::parse_lines($1)
+ if length($1) or length($2)
+ or pos( ${ $self->{'source_scalar_ref'} })
+ != length( ${ $self->{'source_scalar_ref'} });
+ # I.e., unless it's a zero-length "empty line" at the very
+ # end of "foo\nbar\n" (i.e., between the \n and the EOS).
+ } else { # that's the end. Byebye
+ $self->SUPER::parse_lines(undef);
+ delete $self->{'source_scalar_ref'};
+ DEBUG and print "That's it for that source scalarref! Killing.\n";
+ }
+
+
+ } else {
+ die "What source??";
+ }
+ }
+ DEBUG and print "get_token about to return ",
+ Pod::Simple::pretty( @{$self->{'token_buffer'}}
+ ? $self->{'token_buffer'}[-1] : undef
+ ), "\n";
+ return shift @{$self->{'token_buffer'}}; # that's an undef if empty
+}
+
+use UNIVERSAL ();
+sub unget_token {
+ my $self = shift;
+ DEBUG and print "Ungetting ", scalar(@_), " tokens: ",
+ @_ ? "@_\n" : "().\n";
+ foreach my $t (@_) {
+ Carp::croak "Can't unget that, because it's not a token -- it's undef!"
+ unless defined $t;
+ Carp::croak "Can't unget $t, because it's not a token -- it's a string!"
+ unless ref $t;
+ Carp::croak "Can't unget $t, because it's not a token object!"
+ unless UNIVERSAL::can($t, 'type');
+ }
+
+ unshift @{$self->{'token_buffer'}}, @_;
+ DEBUG > 1 and print "Token buffer now has ",
+ scalar(@{$self->{'token_buffer'}}), " items in it.\n";
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+# $self->{'source_filename'} = $source;
+
+sub set_source {
+ my $self = shift @_;
+ return $self->{'source_fh'} unless @_;
+ my $handle;
+ if(!defined $_[0]) {
+ Carp::croak("Can't use empty-string as a source for set_source");
+ } elsif(ref(\( $_[0] )) eq 'GLOB') {
+ $self->{'source_filename'} = '' . ($handle = $_[0]);
+ DEBUG and print "$self 's source is glob $_[0]\n";
+ # and fall thru
+ } elsif(ref( $_[0] ) eq 'SCALAR') {
+ $self->{'source_scalar_ref'} = $_[0];
+ DEBUG and print "$self 's source is scalar ref $_[0]\n";
+ return;
+ } elsif(ref( $_[0] ) eq 'ARRAY') {
+ $self->{'source_arrayref'} = $_[0];
+ DEBUG and print "$self 's source is array ref $_[0]\n";
+ return;
+ } elsif(ref $_[0]) {
+ $self->{'source_filename'} = '' . ($handle = $_[0]);
+ DEBUG and print "$self 's source is fh-obj $_[0]\n";
+ } elsif(!length $_[0]) {
+ Carp::croak("Can't use empty-string as a source for set_source");
+ } else { # It's a filename!
+ DEBUG and print "$self 's source is filename $_[0]\n";
+ {
+ local *PODSOURCE;
+ open(PODSOURCE, "<$_[0]") || Carp::croak "Can't open $_[0]: $!";
+ $handle = *PODSOURCE{IO};
+ }
+ $self->{'source_filename'} = $_[0];
+ DEBUG and print " Its name is $_[0].\n";
+
+ # TODO: file-discipline things here!
+ }
+
+ $self->{'source_fh'} = $handle;
+ DEBUG and print " Its handle is $handle\n";
+ return 1;
+}
+
+# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+
+sub get_title_short { shift->get_short_title(@_) } # alias
+
+sub get_short_title {
+ my $title = shift->get_title(@_);
+ $title = $1 if $title =~ m/^(\S{1,60})\s+--?\s+./s;
+ # turn "Foo::Bar -- bars for your foo" into "Foo::Bar"
+ return $title;
+}
+
+sub get_title { shift->_get_titled_section(
+ 'NAME', max_token => 50, desperate => 1, @_)
+}
+sub get_version { shift->_get_titled_section(
+ 'VERSION',
+ max_token => 400,
+ accept_verbatim => 1,
+ max_content_length => 3_000,
+ @_,
+ );
+}
+sub get_description { shift->_get_titled_section(
+ 'DESCRIPTION',
+ max_token => 400,
+ max_content_length => 3_000,
+ @_,
+) }
+
+sub get_authors { shift->get_author(@_) } # a harmless alias
+
+sub get_author {
+ my $this = shift;
+ # Max_token is so high because these are
+ # typically at the end of the document:
+ $this->_get_titled_section('AUTHOR' , max_token => 10_000, @_) ||
+ $this->_get_titled_section('AUTHORS', max_token => 10_000, @_);
+}
+
+#--------------------------------------------------------------------------
+
+sub _get_titled_section {
+ # Based on a get_title originally contributed by Graham Barr
+ my($self, $titlename, %options) = (@_);
+
+ my $max_token = delete $options{'max_token'};
+ my $desperate_for_title = delete $options{'desperate'};
+ my $accept_verbatim = delete $options{'accept_verbatim'};
+ my $max_content_length = delete $options{'max_content_length'};
+ my $nocase = delete $options{'nocase'};
+ $max_content_length = 120 unless defined $max_content_length;
+
+ Carp::croak( "Unknown " . ((1 == keys %options) ? "option: " : "options: ")
+ . join " ", map "[$_]", sort keys %options
+ )
+ if keys %options;
+
+ my %content_containers;
+ $content_containers{'Para'} = 1;
+ if($accept_verbatim) {
+ $content_containers{'Verbatim'} = 1;
+ $content_containers{'VerbatimFormatted'} = 1;
+ }
+
+ my $token_count = 0;
+ my $title;
+ my @to_unget;
+ my $state = 0;
+ my $depth = 0;
+
+ Carp::croak "What kind of titlename is \"$titlename\"?!" unless
+ defined $titlename and $titlename =~ m/^[A-Z ]{1,60}$/s; #sanity
+ my $titlename_re = quotemeta($titlename);
+
+ my $head1_text_content;
+ my $para_text_content;
+
+ while(
+ ++$token_count <= ($max_token || 1_000_000)
+ and defined(my $token = $self->get_token)
+ ) {
+ push @to_unget, $token;
+
+ if ($state == 0) { # seeking =head1
+ if( $token->is_start and $token->tagname eq 'head1' ) {
+ DEBUG and print " Found head1. Seeking content...\n";
+ ++$state;
+ $head1_text_content = '';
+ }
+ }
+
+ elsif($state == 1) { # accumulating text until end of head1
+ if( $token->is_text ) {
+ DEBUG and print " Adding \"", $token->text, "\" to head1-content.\n";
+ $head1_text_content .= $token->text;
+ } elsif( $token->is_end and $token->tagname eq 'head1' ) {
+ DEBUG and print " Found end of head1. Considering content...\n";
+ $head1_text_content = uc $head1_text_content if $nocase;
+ if($head1_text_content eq $titlename
+ or $head1_text_content =~ m/\($titlename_re\)/s
+ # We accept "=head1 Nomen Modularis (NAME)" for sake of i18n
+ ) {
+ DEBUG and print " Yup, it was $titlename. Seeking next para-content...\n";
+ ++$state;
+ } elsif(
+ $desperate_for_title
+ # if we're so desperate we'll take the first
+ # =head1's content as a title
+ and $head1_text_content =~ m/\S/
+ and $head1_text_content !~ m/^[ A-Z]+$/s
+ and $head1_text_content !~
+ m/\((?:
+ NAME | TITLE | VERSION | AUTHORS? | DESCRIPTION | SYNOPSIS
+ | COPYRIGHT | LICENSE | NOTES? | FUNCTIONS? | METHODS?
+ | CAVEATS? | BUGS? | SEE\ ALSO | SWITCHES | ENVIRONMENT
+ )\)/sx
+ # avoid accepting things like =head1 Thingy Thongy (DESCRIPTION)
+ and ($max_content_length
+ ? (length($head1_text_content) <= $max_content_length) # sanity
+ : 1)
+ ) {
+ DEBUG and print " It looks titular: \"$head1_text_content\".\n",
+ "\n Using that.\n";
+ $title = $head1_text_content;
+ last;
+ } else {
+ --$state;
+ DEBUG and print " Didn't look titular ($head1_text_content).\n",
+ "\n Dropping back to seeking-head1-content mode...\n";
+ }
+ }
+ }
+
+ elsif($state == 2) {
+ # seeking start of para (which must immediately follow)
+ if($token->is_start and $content_containers{ $token->tagname }) {
+ DEBUG and print " Found start of Para. Accumulating content...\n";
+ $para_text_content = '';
+ ++$state;
+ } else {
+ DEBUG and print
+ " Didn't see an immediately subsequent start-Para. Reseeking H1\n";
+ $state = 0;
+ }
+ }
+
+ elsif($state == 3) {
+ # accumulating text until end of Para
+ if( $token->is_text ) {
+ DEBUG and print " Adding \"", $token->text, "\" to para-content.\n";
+ $para_text_content .= $token->text;
+ # and keep looking
+
+ } elsif( $token->is_end and $content_containers{ $token->tagname } ) {
+ DEBUG and print " Found end of Para. Considering content: ",
+ $para_text_content, "\n";
+
+ if( $para_text_content =~ m/\S/
+ and ($max_content_length
+ ? (length($para_text_content) <= $max_content_length)
+ : 1)
+ ) {
+ # Some minimal sanity constraints, I think.
+ DEBUG and print " It looks contentworthy, I guess. Using it.\n";
+ $title = $para_text_content;
+ last;
+ } else {
+ DEBUG and print " Doesn't look at all contentworthy!\n Giving up.\n";
+ undef $title;
+ last;
+ }
+ }
+ }
+
+ else {
+ die "IMPOSSIBLE STATE $state!\n"; # should never happen
+ }
+
+ }
+
+ # Put it all back!
+ $self->unget_token(@to_unget);
+
+ if(DEBUG) {
+ if(defined $title) { print " Returing title <$title>\n" }
+ else { print "Returning title <>\n" }
+ }
+
+ return '' unless defined $title;
+ $title =~ s/^\s+//;
+ return $title;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# Methods that actually do work at parse-time:
+
+sub _handle_element_start {
+ my $self = shift; # leaving ($element_name, $attr_hash_r)
+ DEBUG > 2 and print "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n";
+
+ push @{ $self->{'token_buffer'} },
+ $self->{'start_token_class'}->new(@_);
+ return;
+}
+
+sub _handle_text {
+ my $self = shift; # leaving ($text)
+ DEBUG > 2 and print "== $_[0]\n";
+ push @{ $self->{'token_buffer'} },
+ $self->{'text_token_class'}->new(@_);
+ return;
+}
+
+sub _handle_element_end {
+ my $self = shift; # leaving ($element_name);
+ DEBUG > 2 and print "-- $_[0]\n";
+ push @{ $self->{'token_buffer'} },
+ $self->{'end_token_class'}->new(@_);
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParser -- a pull-parser interface to parsing Pod
+
+=head1 SYNOPSIS
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( "whatever.pod" );
+ $parser->run;
+
+Or:
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( $some_filehandle_object );
+ $parser->run;
+
+Or:
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( \$document_source );
+ $parser->run;
+
+Or:
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( \@document_lines );
+ $parser->run;
+
+And elsewhere:
+
+ require 5;
+ package SomePodProcessor;
+ use strict;
+ use base qw(Pod::Simple::PullParser);
+
+ sub run {
+ my $self = shift;
+ Token:
+ while(my $token = $self->get_token) {
+ ...process each token...
+ }
+ }
+
+=head1 DESCRIPTION
+
+This class is for using Pod::Simple to build a Pod processor -- but
+one that uses an interface based on a stream of token objects,
+instead of based on events.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+A subclass of Pod::Simple::PullParser should define a C<run> method
+that calls C<< $token = $parser->get_token >> to pull tokens.
+
+See the source for Pod::Simple::RTF for an example of a formatter
+that uses Pod::Simple::PullParser.
+
+=head1 METHODS
+
+=over
+
+=item my $token = $parser->get_token
+
+This returns the next token object (which will be of a subclass of
+L<Pod::Simple::PullParserToken>), or undef if the parser-stream has hit
+the end of the document.
+
+=item $parser->unget_token( $token )
+
+=item $parser->unget_token( $token1, $token2, ... )
+
+This restores the token object(s) to the front of the parser stream.
+
+=back
+
+The source has to be set before you can parse anything. The lowest-level
+way is to call C<set_source>:
+
+=over
+
+=item $parser->set_source( $filename )
+
+=item $parser->set_source( $filehandle_object )
+
+=item $parser->set_source( \$document_source )
+
+=item $parser->set_source( \@document_lines )
+
+=back
+
+Or you can call these methods, which Pod::Simple::PullParser has defined
+to work just like Pod::Simple's same-named methods:
+
+=over
+
+=item $parser->parse_file(...)
+
+=item $parser->parse_string_document(...)
+
+=item $parser->filter(...)
+
+=item $parser->parse_from_file(...)
+
+=back
+
+For those to work, the Pod-processing subclass of
+Pod::Simple::PullParser has to have defined a $parser->run method --
+so it is advised that all Pod::Simple::PullParser subclasses do so.
+See the Synopsis above, or the source for Pod::Simple::RTF.
+
+Authors of formatter subclasses might find these methods useful to
+call on a parser object that you haven't started pulling tokens
+from yet:
+
+=over
+
+=item my $title_string = $parser->get_title
+
+This tries to get the title string out of $parser, by getting some tokens,
+and scanning them for the title, and then ungetting them so that you can
+process the token-stream from the beginning.
+
+For example, suppose you have a document that starts out:
+
+ =head1 NAME
+
+ Hoo::Boy::Wowza -- Stuff B<wow> yeah!
+
+$parser->get_title on that document will return "Hoo::Boy::Wowza --
+Stuff wow yeah!". If the document starts with:
+
+ =head1 Name
+
+ Hoo::Boy::W00t -- Stuff B<w00t> yeah!
+
+Then you'll need to pass the C<nocase> option in order to recognize "Name":
+
+ $parser->get_title(nocase => 1);
+
+In cases where get_title can't find the title, it will return empty-string
+("").
+
+=item my $title_string = $parser->get_short_title
+
+This is just like get_title, except that it returns just the modulename, if
+the title seems to be of the form "SomeModuleName -- description".
+
+For example, suppose you have a document that starts out:
+
+ =head1 NAME
+
+ Hoo::Boy::Wowza -- Stuff B<wow> yeah!
+
+then $parser->get_short_title on that document will return
+"Hoo::Boy::Wowza".
+
+But if the document starts out:
+
+ =head1 NAME
+
+ Hooboy, stuff B<wow> yeah!
+
+then $parser->get_short_title on that document will return "Hooboy,
+stuff wow yeah!". If the document starts with:
+
+ =head1 Name
+
+ Hoo::Boy::W00t -- Stuff B<w00t> yeah!
+
+Then you'll need to pass the C<nocase> option in order to recognize "Name":
+
+ $parser->get_short_title(nocase => 1);
+
+If the title can't be found, then get_short_title returns empty-string
+("").
+
+=item $author_name = $parser->get_author
+
+This works like get_title except that it returns the contents of the
+"=head1 AUTHOR\n\nParagraph...\n" section, assuming that that section
+isn't terribly long. To recognize a "=head1 Author\n\nParagraph\n"
+section, pass the C<nocase> otpion:
+
+ $parser->get_author(nocase => 1);
+
+(This method tolerates "AUTHORS" instead of "AUTHOR" too.)
+
+=item $description_name = $parser->get_description
+
+This works like get_title except that it returns the contents of the
+"=head1 DESCRIPTION\n\nParagraph...\n" section, assuming that that section
+isn't terribly long. To recognize a "=head1 Description\n\nParagraph\n"
+section, pass the C<nocase> otpion:
+
+ $parser->get_description(nocase => 1);
+
+=item $version_block = $parser->get_version
+
+This works like get_title except that it returns the contents of
+the "=head1 VERSION\n\n[BIG BLOCK]\n" block. Note that this does NOT
+return the module's C<$VERSION>!! To recognize a
+"=head1 Version\n\n[BIG BLOCK]\n" section, pass the C<nocase> otpion:
+
+ $parser->get_version(nocase => 1);
+
+=back
+
+=head1 NOTE
+
+You don't actually I<have> to define a C<run> method. If you're
+writing a Pod-formatter class, you should define a C<run> just so
+that users can call C<parse_file> etc, but you don't I<have> to.
+
+And if you're not writing a formatter class, but are instead just
+writing a program that does something simple with a Pod::PullParser
+object (and not an object of a subclass), then there's no reason to
+bother subclassing to add a C<run> method.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>
+
+L<Pod::Simple::PullParserToken> -- and its subclasses
+L<Pod::Simple::PullParserStartToken>,
+L<Pod::Simple::PullParserTextToken>, and
+L<Pod::Simple::PullParserEndToken>.
+
+L<HTML::TokeParser>, which inspired this.
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
+JUNK:
+
+sub _old_get_title { # some witchery in here
+ my $self = $_[0];
+ my $title;
+ my @to_unget;
+
+ while(1) {
+ push @to_unget, $self->get_token;
+ unless(defined $to_unget[-1]) { # whoops, short doc!
+ pop @to_unget;
+ last;
+ }
+
+ DEBUG and print "-Got token ", $to_unget[-1]->dump, "\n";
+
+ (DEBUG and print "Too much in the buffer.\n"),
+ last if @to_unget > 25; # sanity
+
+ my $pattern = '';
+ if( #$to_unget[-1]->type eq 'end'
+ #and $to_unget[-1]->tagname eq 'Para'
+ #and
+ ($pattern = join('',
+ map {;
+ ($_->type eq 'start') ? ("<" . $_->tagname .">")
+ : ($_->type eq 'end' ) ? ("</". $_->tagname .">")
+ : ($_->type eq 'text' ) ? ($_->text =~ m<^([A-Z]+)$>s ? $1 : 'X')
+ : "BLORP"
+ } @to_unget
+ )) =~ m{<head1>NAME</head1><Para>(X|</?[BCIFLS]>)+</Para>$}s
+ ) {
+ # Whee, it fits the pattern
+ DEBUG and print "Seems to match =head1 NAME pattern.\n";
+ $title = '';
+ foreach my $t (reverse @to_unget) {
+ last if $t->type eq 'start' and $t->tagname eq 'Para';
+ $title = $t->text . $title if $t->type eq 'text';
+ }
+ undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
+ last;
+
+ } elsif ($pattern =~ m{<head(\d)>(.+)</head\d>$}
+ and !( $1 eq '1' and $2 eq 'NAME' )
+ ) {
+ # Well, it fits a fallback pattern
+ DEBUG and print "Seems to match NAMEless pattern.\n";
+ $title = '';
+ foreach my $t (reverse @to_unget) {
+ last if $t->type eq 'start' and $t->tagname =~ m/^head\d$/s;
+ $title = $t->text . $title if $t->type eq 'text';
+ }
+ undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
+ last;
+
+ } else {
+ DEBUG and $pattern and print "Leading pattern: $pattern\n";
+ }
+ }
+
+ # Put it all back:
+ $self->unget_token(@to_unget);
+
+ if(DEBUG) {
+ if(defined $title) { print " Returing title <$title>\n" }
+ else { print "Returning title <>\n" }
+ }
+
+ return '' unless defined $title;
+ return $title;
+}
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserEndToken.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserEndToken.pm
new file mode 100755
index 00000000000..2c32bd805b8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserEndToken.pm
@@ -0,0 +1,120 @@
+
+require 5;
+package Pod::Simple::PullParserEndToken;
+use Pod::Simple::PullParserToken ();
+use strict;
+use vars qw(@ISA $VERSION);
+@ISA = ('Pod::Simple::PullParserToken');
+$VERSION = '3.13';
+
+sub new { # Class->new(tagname);
+ my $class = shift;
+ return bless ['end', @_], ref($class) || $class;
+}
+
+# Purely accessors:
+
+sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
+sub tag { shift->tagname(@_) }
+
+# shortcut:
+sub is_tagname { $_[0][1] eq $_[1] }
+sub is_tag { shift->is_tagname(@_) }
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserEndToken -- end-tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+(See L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
+get an object of this class.
+
+This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
+and adds these methods:
+
+=over
+
+=item $token->tagname
+
+This returns the tagname for this end-token object.
+For example, parsing a "=head1 ..." line will give you
+a start-token with the tagname of "head1", token(s) for its
+content, and then an end-token with the tagname of "head1".
+
+=item $token->tagname(I<somestring>)
+
+This changes the tagname for this end-token object.
+You probably won't need to do this.
+
+=item $token->tag(...)
+
+A shortcut for $token->tagname(...)
+
+=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
+
+These are shortcuts for C<< $token->tag() eq I<somestring> >>
+
+=back
+
+You're unlikely to ever need to construct an object of this class for
+yourself, but if you want to, call
+C<<
+Pod::Simple::PullParserEndToken->new( I<tagname> )
+>>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserStartToken.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserStartToken.pm
new file mode 100755
index 00000000000..39802641896
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserStartToken.pm
@@ -0,0 +1,161 @@
+
+require 5;
+package Pod::Simple::PullParserStartToken;
+use Pod::Simple::PullParserToken ();
+use strict;
+use vars qw(@ISA $VERSION);
+@ISA = ('Pod::Simple::PullParserToken');
+$VERSION = '3.13';
+
+sub new { # Class->new(tagname, optional_attrhash);
+ my $class = shift;
+ return bless ['start', @_], ref($class) || $class;
+}
+
+# Purely accessors:
+
+sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
+sub tag { shift->tagname(@_) }
+
+sub is_tagname { $_[0][1] eq $_[1] }
+sub is_tag { shift->is_tagname(@_) }
+
+
+sub attr_hash { $_[0][2] ||= {} }
+
+sub attr {
+ if(@_ == 2) { # Reading: $token->attr('attrname')
+ ${$_[0][2] || return undef}{ $_[1] };
+ } elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval')
+ ${$_[0][2] ||= {}}{ $_[1] } = $_[2];
+ } else {
+ require Carp;
+ Carp::croak(
+ 'usage: $object->attr("val") or $object->attr("key", "newval")');
+ return undef;
+ }
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserStartToken -- start-tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+(See L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser> object, you might
+get an object of this class.
+
+This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
+and adds these methods:
+
+=over
+
+=item $token->tagname
+
+This returns the tagname for this start-token object.
+For example, parsing a "=head1 ..." line will give you
+a start-token with the tagname of "head1", token(s) for its
+content, and then an end-token with the tagname of "head1".
+
+=item $token->tagname(I<somestring>)
+
+This changes the tagname for this start-token object.
+You probably won't need
+to do this.
+
+=item $token->tag(...)
+
+A shortcut for $token->tagname(...)
+
+=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
+
+These are shortcuts for C<< $token->tag() eq I<somestring> >>
+
+=item $token->attr(I<attrname>)
+
+This returns the value of the I<attrname> attribute for this start-token
+object, or undef.
+
+For example, parsing a LZ<><Foo/"Bar"> link will produce a start-token
+with a "to" attribute with the value "Foo", a "type" attribute with the
+value "pod", and a "section" attribute with the value "Bar".
+
+=item $token->attr(I<attrname>, I<newvalue>)
+
+This sets the I<attrname> attribute for this start-token object to
+I<newvalue>. You probably won't need to do this.
+
+=item $token->attr_hash
+
+This returns the hashref that is the attribute set for this start-token.
+This is useful if (for example) you want to ask what all the attributes
+are -- you can just do C<< keys %{$token->attr_hash} >>
+
+=back
+
+
+You're unlikely to ever need to construct an object of this class for
+yourself, but if you want to, call
+C<<
+Pod::Simple::PullParserStartToken->new( I<tagname>, I<attrhash> )
+>>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserTextToken.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserTextToken.pm
new file mode 100755
index 00000000000..f33fc6e9438
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserTextToken.pm
@@ -0,0 +1,128 @@
+
+require 5;
+package Pod::Simple::PullParserTextToken;
+use Pod::Simple::PullParserToken ();
+use strict;
+use vars qw(@ISA $VERSION);
+@ISA = ('Pod::Simple::PullParserToken');
+$VERSION = '3.13';
+
+sub new { # Class->new(text);
+ my $class = shift;
+ return bless ['text', @_], ref($class) || $class;
+}
+
+# Purely accessors:
+
+sub text { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
+
+sub text_r { \ $_[0][1] }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserTextToken -- text-tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+(See L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
+get an object of this class.
+
+This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
+and adds these methods:
+
+=over
+
+=item $token->text
+
+This returns the text that this token holds. For example, parsing
+CZ<><foo> will return a C start-token, a text-token, and a C end-token. And
+if you want to get the "foo" out of the text-token, call C<< $token->text >>
+
+=item $token->text(I<somestring>)
+
+This changes the string that this token holds. You probably won't need
+to do this.
+
+=item $token->text_r()
+
+This returns a scalar reference to the string that this token holds.
+This can be useful if you don't want to memory-copy the potentially
+large text value (well, as large as a paragraph or a verbatim block)
+as calling $token->text would do.
+
+Or, if you want to alter the value, you can even do things like this:
+
+ for ( ${ $token->text_r } ) { # Aliases it with $_ !!
+
+ s/ The / the /g; # just for example
+
+ if( 'A' eq chr(65) ) { # (if in an ASCII world)
+ tr/\xA0/ /;
+ tr/\xAD//d;
+ }
+
+ ...or however you want to alter the value...
+ }
+
+=back
+
+You're unlikely to ever need to construct an object of this class for
+yourself, but if you want to, call
+C<<
+Pod::Simple::PullParserTextToken->new( I<text> )
+>>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserToken.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserToken.pm
new file mode 100755
index 00000000000..3a156b442bd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/PullParserToken.pm
@@ -0,0 +1,163 @@
+
+require 5;
+package Pod::Simple::PullParserToken;
+ # Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token
+@ISA = ();
+$VERSION = '3.13';
+use strict;
+
+sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway
+ my $class = shift;
+ return bless [@_], ref($class) || $class;
+}
+
+sub type { $_[0][0] } # Can't change the type of an object
+sub dump { Pod::Simple::pretty( [ @{ $_[0] } ] ) }
+
+sub is_start { $_[0][0] eq 'start' }
+sub is_end { $_[0][0] eq 'end' }
+sub is_text { $_[0][0] eq 'text' }
+
+1;
+__END__
+
+sub dump { '[' . _esc( @{ $_[0] } ) . ']' }
+
+# JUNK:
+
+sub _esc {
+ return '' unless @_;
+ my @out;
+ foreach my $in (@_) {
+ push @out, '"' . $in . '"';
+ $out[-1] =~ s/([^- \:\:\.\,\'\>\<\"\/\=\?\+\|\[\]\{\}\_a-zA-Z0-9_\`\~\!\#\%\^\&\*\(\)])/
+ sprintf( (ord($1) < 256) ? "\\x%02X" : "\\x{%X}", ord($1))
+ /eg;
+ }
+ return join ', ', @out;
+}
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserToken -- tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+Given a $parser that's an object of class Pod::Simple::PullParser
+(or a subclass)...
+
+ while(my $token = $parser->get_token) {
+ $DEBUG and print "Token: ", $token->dump, "\n";
+ if($token->is_start) {
+ ...access $token->tagname, $token->attr, etc...
+
+ } elsif($token->is_text) {
+ ...access $token->text, $token->text_r, etc...
+
+ } elsif($token->is_end) {
+ ...access $token->tagname...
+
+ }
+ }
+
+(Also see L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser>, you should
+get an object of a subclass of Pod::Simple::PullParserToken.
+
+Subclasses will add methods, and will also inherit these methods:
+
+=over
+
+=item $token->type
+
+This returns the type of the token. This will be either the string
+"start", the string "text", or the string "end".
+
+Once you know what the type of an object is, you then know what
+subclass it belongs to, and therefore what methods it supports.
+
+Yes, you could probably do the same thing with code like
+$token->isa('Pod::Simple::PullParserEndToken'), but that's not so
+pretty as using just $token->type, or even the following shortcuts:
+
+=item $token->is_start
+
+This is a shortcut for C<< $token->type() eq "start" >>
+
+=item $token->is_text
+
+This is a shortcut for C<< $token->type() eq "text" >>
+
+=item $token->is_end
+
+This is a shortcut for C<< $token->type() eq "end" >>
+
+=item $token->dump
+
+This returns a handy stringified value of this object. This
+is useful for debugging, as in:
+
+ while(my $token = $parser->get_token) {
+ $DEBUG and print "Token: ", $token->dump, "\n";
+ ...
+ }
+
+=back
+
+=head1 SEE ALSO
+
+My subclasses:
+L<Pod::Simple::PullParserStartToken>,
+L<Pod::Simple::PullParserTextToken>, and
+L<Pod::Simple::PullParserEndToken>.
+
+L<Pod::Simple::PullParser> and L<Pod::Simple>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/RTF.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/RTF.pm
new file mode 100755
index 00000000000..b89eac047a4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/RTF.pm
@@ -0,0 +1,699 @@
+
+require 5;
+package Pod::Simple::RTF;
+
+#sub DEBUG () {4};
+#sub Pod::Simple::DEBUG () {4};
+#sub Pod::Simple::PullParser::DEBUG () {4};
+
+use strict;
+use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
+$VERSION = '3.13';
+use Pod::Simple::PullParser ();
+BEGIN {@ISA = ('Pod::Simple::PullParser')}
+
+use Carp ();
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+$WRAP = 1 unless defined $WRAP;
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _openclose {
+ return map {;
+ m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
+ ( $1, "{\\$2\n", "/$1", "}" );
+ } @_;
+}
+
+my @_to_accept;
+
+%Tagmap = (
+ # 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}')
+ _openclose(
+ 'B=cs18\b',
+ 'I=cs16\i',
+ 'C=cs19\f1\lang1024\noproof',
+ 'F=cs17\i\lang1024\noproof',
+
+ 'VerbatimI=cs26\i',
+ 'VerbatimB=cs27\b',
+ 'VerbatimBI=cs28\b\i',
+
+ map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
+ qw[
+ underline=ul smallcaps=scaps shadow=shad
+ superscript=super subscript=sub strikethrough=strike
+ outline=outl emboss=embo engrave=impr
+ dotted-underline=uld dash-underline=uldash
+ dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd
+ double-underline=uldb thick-underline=ulth
+ word-underline=ulw wave-underline=ulwave
+ ]
+ # But no double-strikethrough, because MSWord can't agree with the
+ # RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!)
+ ),
+
+ # Bit of a hack here:
+ 'L=pod' => '{\cs22\i'."\n",
+ 'L=url' => '{\cs23\i'."\n",
+ 'L=man' => '{\cs24\i'."\n",
+ '/L' => '}',
+
+ 'Data' => "\n",
+ '/Data' => "\n",
+
+ 'Verbatim' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
+ '/Verbatim' => "\n\\par}\n",
+ 'VerbatimFormatted' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
+ '/VerbatimFormatted' => "\n\\par}\n",
+ 'Para' => "\n{\\pard\\li#rtfindent#\\sa180\n",
+ '/Para' => "\n\\par}\n",
+ 'head1' => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n",
+ '/head1' => "\n}\\par}\n",
+ 'head2' => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n",
+ '/head2' => "\n}\\par}\n",
+ 'head3' => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n",
+ '/head3' => "\n}\\par}\n",
+ 'head4' => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n",
+ '/head4' => "\n}\\par}\n",
+ # wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2
+
+ 'item-bullet' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
+ '/item-bullet' => "\n\\par}\n",
+ 'item-number' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
+ '/item-number' => "\n\\par}\n",
+ 'item-text' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
+ '/item-text' => "\n\\par}\n",
+
+ # we don't need any styles for over-* and /over-*
+);
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub new {
+ my $new = shift->SUPER::new(@_);
+ $new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->accept_targets( 'rtf', 'RTF' );
+
+ $new->{'Tagmap'} = {%Tagmap};
+
+ $new->accept_codes(@_to_accept);
+ $new->accept_codes('VerbatimFormatted');
+ DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
+ $new->doc_lang(
+ ( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
+ : ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
+ # yes, tolerate hex!
+ : ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
+ # yes, tolerate even more hex!
+ : '1033'
+ );
+
+ $new->head1_halfpoint_size(32);
+ $new->head2_halfpoint_size(28);
+ $new->head3_halfpoint_size(25);
+ $new->head4_halfpoint_size(22);
+ $new->codeblock_halfpoint_size(18);
+ $new->header_halfpoint_size(17);
+ $new->normal_halfpoint_size(25);
+
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+__PACKAGE__->_accessorize(
+ 'doc_lang',
+ 'head1_halfpoint_size',
+ 'head2_halfpoint_size',
+ 'head3_halfpoint_size',
+ 'head4_halfpoint_size',
+ 'codeblock_halfpoint_size',
+ 'header_halfpoint_size',
+ 'normal_halfpoint_size',
+ 'no_proofing_exemptions',
+);
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub run {
+ my $self = $_[0];
+ return $self->do_middle if $self->bare_output;
+ return
+ $self->do_beginning && $self->do_middle && $self->do_end;
+}
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub do_middle { # the main work
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+
+ my($token, $type, $tagname, $scratch);
+ my @stack;
+ my @indent_stack;
+ $self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
+
+ while($token = $self->get_token) {
+
+ if( ($type = $token->type) eq 'text' ) {
+ if( $self->{'rtfverbatim'} ) {
+ DEBUG > 1 and print " $type " , $token->text, " in verbatim!\n";
+ rtf_esc_codely($scratch = $token->text);
+ print $fh $scratch;
+ next;
+ }
+
+ DEBUG > 1 and print " $type " , $token->text, "\n";
+
+ $scratch = $token->text;
+ $scratch =~ tr/\t\cb\cc/ /d;
+
+ $self->{'no_proofing_exemptions'} or $scratch =~
+ s/(?:
+ ^
+ |
+ (?<=[\cm\cj\t "\[\<\(])
+ ) # start on whitespace, sequence-start, or quote
+ ( # something looking like a Perl token:
+ (?:
+ [\$\@\:\<\*\\_]\S+ # either starting with a sigil, etc.
+ )
+ |
+ # or starting alpha, but containing anything strange:
+ (?:
+ [a-zA-Z'\x80-\xFF]+[\$\@\:_<>\(\\\*]\S+
+ )
+ )
+ /\cb$1\cc/xsg
+ ;
+
+ rtf_esc($scratch);
+ $scratch =~
+ s/(
+ [^\cm\cj\n]{65} # Snare 65 characters from a line
+ [^\cm\cj\n\x20]{0,50} # and finish any current word
+ )
+ (\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end
+ /$1$2\n/gx # and put a NL before those spaces
+ if $WRAP;
+ # This may wrap at well past the 65th column, but not past the 120th.
+
+ print $fh $scratch;
+
+ } elsif( $type eq 'start' ) {
+ DEBUG > 1 and print " +$type ",$token->tagname,
+ " (", map("<$_> ", %{$token->attr_hash}), ")\n";
+
+ if( ($tagname = $token->tagname) eq 'Verbatim'
+ or $tagname eq 'VerbatimFormatted'
+ ) {
+ ++$self->{'rtfverbatim'};
+ my $next = $self->get_token;
+ next unless defined $next;
+ my $line_count = 1;
+ if($next->type eq 'text') {
+ my $t = $next->text_r;
+ while( $$t =~ m/$/mg ) {
+ last if ++$line_count > 15; # no point in counting further
+ }
+ DEBUG > 3 and print " verbatim line count: $line_count\n";
+ }
+ $self->unget_token($next);
+ $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;
+
+ } elsif( $tagname =~ m/^item-/s ) {
+ my @to_unget;
+ my $text_count_here = 0;
+ $self->{'rtfitemkeepn'} = '';
+ # Some heuristics to stop item-*'s functioning as subheadings
+ # from getting split from the things they're subheadings for.
+ #
+ # It's not terribly pretty, but it really does make things pretty.
+ #
+ while(1) {
+ push @to_unget, $self->get_token;
+ pop(@to_unget), last unless defined $to_unget[-1];
+ # Erroneously used to be "unshift" instead of pop! Adds instead
+ # of removes, and operates on the beginning instead of the end!
+
+ if($to_unget[-1]->type eq 'text') {
+ if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
+ DEBUG > 1 and print " item-* is too long to be keepn'd.\n";
+ last;
+ }
+ } elsif (@to_unget > 1 and
+ $to_unget[-2]->type eq 'end' and
+ $to_unget[-2]->tagname =~ m/^item-/s
+ ) {
+ # Bail out here, after setting rtfitemkeepn yea or nay.
+ $self->{'rtfitemkeepn'} = '\keepn' if
+ $to_unget[-1]->type eq 'start' and
+ $to_unget[-1]->tagname eq 'Para';
+
+ DEBUG > 1 and printf " item-* before %s(%s) %s keepn'd.\n",
+ $to_unget[-1]->type,
+ $to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
+ $self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
+ last;
+ } elsif (@to_unget > 40) {
+ DEBUG > 1 and print " item-* now has too many tokens (",
+ scalar(@to_unget),
+ (DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
+ ") to be keepn'd.\n";
+ last; # give up
+ }
+ # else keep while'ing along
+ }
+ # Now put it aaaaall back...
+ $self->unget_token(@to_unget);
+
+ } elsif( $tagname =~ m/^over-/s ) {
+ push @stack, $1;
+ push @indent_stack,
+ int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
+ DEBUG and print "Indenting over $indent_stack[-1] twips.\n";
+ $self->{'rtfindent'} += $indent_stack[-1];
+
+ } elsif ($tagname eq 'L') {
+ $tagname .= '=' . ($token->attr('type') || 'pod');
+
+ } elsif ($tagname eq 'Data') {
+ my $next = $self->get_token;
+ next unless defined $next;
+ unless( $next->type eq 'text' ) {
+ $self->unget_token($next);
+ next;
+ }
+ DEBUG and print " raw text ", $next->text, "\n";
+ printf $fh "\n" . $next->text . "\n";
+ next;
+ }
+
+ defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
+ $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
+ print $fh $scratch;
+
+ if ($tagname eq 'item-number') {
+ print $fh $token->attr('number'), ". \n";
+ } elsif ($tagname eq 'item-bullet') {
+ print $fh "\\'95 \n";
+ #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}");
+ }
+
+ } elsif( $type eq 'end' ) {
+ DEBUG > 1 and print " -$type ",$token->tagname,"\n";
+ if( ($tagname = $token->tagname) =~ m/^over-/s ) {
+ DEBUG and print "Indenting back $indent_stack[-1] twips.\n";
+ $self->{'rtfindent'} -= pop @indent_stack;
+ pop @stack;
+ } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
+ --$self->{'rtfverbatim'};
+ }
+ defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
+ $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
+ print $fh $scratch;
+ }
+ }
+ return 1;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub do_beginning {
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+ return print $fh join '',
+ $self->doc_init,
+ $self->font_table,
+ $self->stylesheet,
+ $self->color_table,
+ $self->doc_info,
+ $self->doc_start,
+ "\n"
+ ;
+}
+
+sub do_end {
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+ return print $fh '}'; # that should do it
+}
+
+###########################################################################
+
+sub stylesheet {
+ return sprintf <<'END',
+{\stylesheet
+{\snext0 Normal;}
+{\*\cs10 \additive Default Paragraph Font;}
+{\*\cs16 \additive \i \sbasedon10 pod-I;}
+{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
+{\*\cs18 \additive \b \sbasedon10 pod-B;}
+{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
+{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
+{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
+{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
+{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
+{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
+
+{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
+{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
+{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
+{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
+
+{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
+{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
+{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
+{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
+}
+
+END
+
+ $_[0]->codeblock_halfpoint_size(),
+ $_[0]->head1_halfpoint_size(),
+ $_[0]->head2_halfpoint_size(),
+ $_[0]->head3_halfpoint_size(),
+ $_[0]->head4_halfpoint_size(),
+ ;
+}
+
+###########################################################################
+# Override these as necessary for further customization
+
+sub font_table {
+ return <<'END'; # text font, code font, heading font
+{\fonttbl
+{\f0\froman Times New Roman;}
+{\f1\fmodern Courier New;}
+{\f2\fswiss Arial;}
+}
+
+END
+}
+
+sub doc_init {
+ return <<'END';
+{\rtf1\ansi\deff0
+
+END
+}
+
+sub color_table {
+ return <<'END';
+{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
+END
+}
+
+
+sub doc_info {
+ my $self = $_[0];
+
+ my $class = ref($self) || $self;
+
+ my $tag = __PACKAGE__ . ' ' . $VERSION;
+
+ unless($class eq __PACKAGE__) {
+ $tag = " ($tag)";
+ $tag = " v" . $self->VERSION . $tag if defined $self->VERSION;
+ $tag = $class . $tag;
+ }
+
+ return sprintf <<'END',
+{\info{\doccomm
+%s
+ using %s v%s
+ under Perl v%s at %s GMT}
+{\author [see doc]}{\company [see doc]}{\operator [see doc]}
+}
+
+END
+
+ # None of the following things should need escaping, I dare say!
+ $tag,
+ $ISA[0], $ISA[0]->VERSION(),
+ $], scalar(gmtime),
+ ;
+}
+
+sub doc_start {
+ my $self = $_[0];
+ my $title = $self->get_short_title();
+ DEBUG and print "Short Title: <$title>\n";
+ $title .= ' ' if length $title;
+
+ $title =~ s/ *$/ /s;
+ $title =~ s/^ //s;
+ $title =~ s/ $/, /s;
+ # make sure it ends in a comma and a space, unless it's 0-length
+
+ my $is_obviously_module_name;
+ $is_obviously_module_name = 1
+ if $title =~ m/^\S+$/s and $title =~ m/::/s;
+ # catches the most common case, at least
+
+ DEBUG and print "Title0: <$title>\n";
+ $title = rtf_esc($title);
+ DEBUG and print "Title1: <$title>\n";
+ $title = '\lang1024\noproof ' . $title
+ if $is_obviously_module_name;
+
+ return sprintf <<'END',
+\deflang%s\plain\lang%s\widowctrl
+{\header\pard\qr\plain\f2\fs%s
+%s
+p.\chpgn\par}
+\fs%s
+
+END
+ ($self->doc_lang) x 2,
+ $self->header_halfpoint_size,
+ $title,
+ $self->normal_halfpoint_size,
+ ;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#-------------------------------------------------------------------------
+
+use integer;
+sub rtf_esc {
+ my $x; # scratch
+ if(!defined wantarray) { # void context: alter in-place!
+ for(@_) {
+ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ }
+ return;
+ } elsif(wantarray) { # return an array
+ return map {; ($x = $_) =~
+ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ $x;
+ } @_;
+ } else { # return a single scalar
+ ($x = ((@_ == 1) ? $_[0] : join '', @_)
+ ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ # Escape \, {, }, -, control chars, and 7f-ff.
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ return $x;
+ }
+}
+
+sub rtf_esc_codely {
+ # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts.
+ # We don't want to change the "-" to hard-hyphen, because we want to
+ # be able to paste this into a file and run it without there being
+ # dire screaming about the mysterious hard-hyphen character (which
+ # looks just like a normal dash character).
+
+ my $x; # scratch
+ if(!defined wantarray) { # void context: alter in-place!
+ for(@_) {
+ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ }
+ return;
+ } elsif(wantarray) { # return an array
+ return map {; ($x = $_) =~
+ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ $x;
+ } @_;
+ } else { # return a single scalar
+ ($x = ((@_ == 1) ? $_[0] : join '', @_)
+ ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ # Escape \, {, }, -, control chars, and 7f-ff.
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ return $x;
+ }
+}
+
+%Escape = (
+ map( (chr($_),chr($_)), # things not apparently needing escaping
+ 0x20 .. 0x7E ),
+ map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things
+ 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46),
+
+ # We get to escape out 'F' so that we can send RTF files thru the mail
+ # without the slightest worry that paragraphs beginning with "From"
+ # will get munged.
+
+ # And some refinements:
+ "\cm" => "\n",
+ "\cj" => "\n",
+ "\n" => "\n\\line ",
+
+ "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay)
+ "\f" => "\n\\page\n", # Formfeed
+ "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen
+ "\xA0" => "\\~", # Latin-1 non-breaking space
+ "\xAD" => "\\-", # Latin-1 soft (optional) hyphen
+
+ # CRAZY HACKS:
+ "\n" => "\\line\n",
+ "\r" => "\n",
+ "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1
+ "\cc" => "}",
+);
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::RTF -- format Pod as RTF
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::RTF -e \
+ "exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \
+ thingy.pod > thingy.rtf
+
+=head1 DESCRIPTION
+
+This class is a formatter that takes Pod and renders it as RTF, good for
+viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 FORMAT CONTROL ATTRIBUTES
+
+You can set these attributes on the parser object before you
+call C<parse_file> (or a similar method) on it:
+
+=over
+
+=item $parser->head1_halfpoint_size( I<halfpoint_integer> );
+
+=item $parser->head2_halfpoint_size( I<halfpoint_integer> );
+
+=item $parser->head3_halfpoint_size( I<halfpoint_integer> );
+
+=item $parser->head4_halfpoint_size( I<halfpoint_integer> );
+
+These methods set the size (in half-points, like 52 for 26-point)
+that these heading levels will appear as.
+
+=item $parser->codeblock_halfpoint_size( I<halfpoint_integer> );
+
+This method sets the size (in half-points, like 21 for 10.5-point)
+that codeblocks ("verbatim sections") will appear as.
+
+=item $parser->header_halfpoint_size( I<halfpoint_integer> );
+
+This method sets the size (in half-points, like 15 for 7.5-point)
+that the header on each page will appear in. The header
+is usually just "I<modulename> p. I<pagenumber>".
+
+=item $parser->normal_halfpoint_size( I<halfpoint_integer> );
+
+This method sets the size (in half-points, like 26 for 13-point)
+that normal paragraphic text will appear in.
+
+=item $parser->no_proofing_exemptions( I<true_or_false> );
+
+Set this value to true if you don't want the formatter to try
+putting a hidden code on all Perl symbols (as best as it can
+notice them) that labels them as being not in English, and
+so not worth spellchecking.
+
+=item $parser->doc_lang( I<microsoft_decimal_language_code> )
+
+This sets the language code to tag this document as being in. By
+default, it is currently the value of the environment variable
+C<RTFDEFLANG>, or if that's not set, then the value
+1033 (for US English).
+
+Setting this appropriately is useful if you want to use the RTF
+to spellcheck, and/or if you want it to hyphenate right.
+
+Here are some notable values:
+
+ 1033 US English
+ 2057 UK English
+ 3081 Australia English
+ 4105 Canada English
+ 1034 Spain Spanish
+ 2058 Mexico Spanish
+ 1031 Germany German
+ 1036 France French
+ 3084 Canada French
+ 1035 Finnish
+ 1044 Norwegian (Bokmal)
+ 2068 Norwegian (Nynorsk)
+
+=back
+
+If you are particularly interested in customizing this module's output
+even more, see the source and/or write to me.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>,
+L<RTF::Generator>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Search.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Search.pm
new file mode 100755
index 00000000000..37cd2e8319f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Search.pm
@@ -0,0 +1,1043 @@
+
+require 5.005;
+package Pod::Simple::Search;
+use strict;
+
+use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
+$VERSION = '3.13'; ## Current version of this package
+
+BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
+use Carp ();
+
+$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
+ # flag to occasionally sleep for $SLEEPY - 1 seconds.
+
+$MAX_VERSION_WITHIN ||= 60;
+
+#############################################################################
+
+#use diagnostics;
+use File::Spec ();
+use File::Basename qw( basename );
+use Config ();
+use Cwd qw( cwd );
+
+#==========================================================================
+__PACKAGE__->_accessorize( # Make my dumb accessor methods
+ 'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob',
+ 'limit_re', 'shadows', 'verbose', 'name2path', 'path2name',
+);
+#==========================================================================
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, ref($class) || $class;
+ $self->init;
+ return $self;
+}
+
+sub init {
+ my $self = shift;
+ $self->inc(1);
+ $self->verbose(DEBUG);
+ return $self;
+}
+
+#--------------------------------------------------------------------------
+
+sub survey {
+ my($self, @search_dirs) = @_;
+ $self = $self->new unless ref $self; # tolerate being a class method
+
+ $self->_expand_inc( \@search_dirs );
+
+
+ $self->{'_scan_count'} = 0;
+ $self->{'_dirs_visited'} = {};
+ $self->path2name( {} );
+ $self->name2path( {} );
+ $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'};
+ my $cwd = cwd();
+ my $verbose = $self->verbose;
+ local $_; # don't clobber the caller's $_ !
+
+ foreach my $try (@search_dirs) {
+ unless( File::Spec->file_name_is_absolute($try) ) {
+ # make path absolute
+ $try = File::Spec->catfile( $cwd ,$try);
+ }
+ # simplify path
+ $try = File::Spec->canonpath($try);
+
+ my $start_in;
+ my $modname_prefix;
+ if($self->{'dir_prefix'}) {
+ $start_in = File::Spec->catdir(
+ $try,
+ grep length($_), split '[\\/:]+', $self->{'dir_prefix'}
+ );
+ $modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}];
+ $verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ",
+ "giving $start_in (= @$modname_prefix)\n";
+ } else {
+ $start_in = $try;
+ }
+
+ if( $self->{'_dirs_visited'}{$start_in} ) {
+ $verbose and print "Directory '$start_in' already seen, skipping.\n";
+ next;
+ } else {
+ $self->{'_dirs_visited'}{$start_in} = 1;
+ }
+
+ unless(-e $start_in) {
+ $verbose and print "Skipping non-existent $start_in\n";
+ next;
+ }
+
+ my $closure = $self->_make_search_callback;
+
+ if(-d $start_in) {
+ # Normal case:
+ $verbose and print "Beginning excursion under $start_in\n";
+ $self->_recurse_dir( $start_in, $closure, $modname_prefix );
+ $verbose and print "Back from excursion under $start_in\n\n";
+
+ } elsif(-f _) {
+ # A excursion consisting of just one file!
+ $_ = basename($start_in);
+ $verbose and print "Pondering $start_in ($_)\n";
+ $closure->($start_in, $_, 0, []);
+
+ } else {
+ $verbose and print "Skipping mysterious $start_in\n";
+ }
+ }
+ $self->progress and $self->progress->done(
+ "Noted $$self{'_scan_count'} Pod files total");
+
+ return unless defined wantarray; # void
+ return $self->name2path unless wantarray; # scalar
+ return $self->name2path, $self->path2name; # list
+}
+
+
+#==========================================================================
+sub _make_search_callback {
+ my $self = $_[0];
+
+ # Put the options in variables, for easy access
+ my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,$path2name,$name2path) =
+ map scalar($self->$_()),
+ qw(laborious verbose shadows limit_re callback progress path2name name2path);
+
+ my($file, $shortname, $isdir, $modname_bits);
+ return sub {
+ ($file, $shortname, $isdir, $modname_bits) = @_;
+
+ if($isdir) { # this never gets called on the startdir itself, just subdirs
+
+ if( $self->{'_dirs_visited'}{$file} ) {
+ $verbose and print "Directory '$file' already seen, skipping.\n";
+ return 'PRUNE';
+ }
+
+ print "Looking in dir $file\n" if $verbose;
+
+ unless ($laborious) { # $laborious overrides pruning
+ if( m/^(\d+\.[\d_]{3,})\z/s
+ and do { my $x = $1; $x =~ tr/_//d; $x != $] }
+ ) {
+ $verbose and print "Perl $] version mismatch on $_, skipping.\n";
+ return 'PRUNE';
+ }
+
+ if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) {
+ $verbose and print "$_ is a well-named module subdir. Looking....\n";
+ } else {
+ $verbose and print "$_ is a fishy directory name. Skipping.\n";
+ return 'PRUNE';
+ }
+ } # end unless $laborious
+
+ $self->{'_dirs_visited'}{$file} = 1;
+ return; # (not pruning);
+ }
+
+
+ # Make sure it's a file even worth even considering
+ if($laborious) {
+ unless(
+ m/\.(pod|pm|plx?)\z/i || -x _ and -T _
+ # Note that the cheapest operation (the RE) is run first.
+ ) {
+ $verbose > 1 and print " Brushing off uninteresting $file\n";
+ return;
+ }
+ } else {
+ unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) {
+ $verbose > 1 and print " Brushing off oddly-named $file\n";
+ return;
+ }
+ }
+
+ $verbose and print "Considering item $file\n";
+ my $name = $self->_path2modname( $file, $shortname, $modname_bits );
+ $verbose > 0.01 and print " Nominating $file as $name\n";
+
+ if($limit_re and $name !~ m/$limit_re/i) {
+ $verbose and print "Shunning $name as not matching $limit_re\n";
+ return;
+ }
+
+ if( !$shadows and $name2path->{$name} ) {
+ $verbose and print "Not worth considering $file ",
+ "-- already saw $name as ",
+ join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n";
+ return;
+ }
+
+ # Put off until as late as possible the expense of
+ # actually reading the file:
+ if( m/\.pod\z/is ) {
+ # just assume it has pod, okay?
+ } else {
+ $progress and $progress->reach($self->{'_scan_count'}, "Scanning $file");
+ return unless $self->contains_pod( $file );
+ }
+ ++ $self->{'_scan_count'};
+
+ # Or finally take note of it:
+ if( $name2path->{$name} ) {
+ $verbose and print
+ "Duplicate POD found (shadowing?): $name ($file)\n",
+ " Already seen in ",
+ join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n";
+ } else {
+ $name2path->{$name} = $file; # Noting just the first occurrence
+ }
+ $verbose and print " Noting $name = $file\n";
+ if( $callback ) {
+ local $_ = $_; # insulate from changes, just in case
+ $callback->($file, $name);
+ }
+ $path2name->{$file} = $name;
+ return;
+ }
+}
+
+#==========================================================================
+
+sub _path2modname {
+ my($self, $file, $shortname, $modname_bits) = @_;
+
+ # this code simplifies the POD name for Perl modules:
+ # * remove "site_perl"
+ # * remove e.g. "i586-linux" (from 'archname')
+ # * remove e.g. 5.00503
+ # * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod)
+ # * dig into the file for case-preserved name if not already mixed case
+
+ my @m = @$modname_bits;
+ my $x;
+ my $verbose = $self->verbose;
+
+ # Shaving off leading naughty-bits
+ while(@m
+ and defined($x = lc( $m[0] ))
+ and( $x eq 'site_perl'
+ or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s )
+ or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum
+ or $x eq lc( $Config::Config{'archname'} )
+ )) { shift @m }
+
+ my $name = join '::', @m, $shortname;
+ $self->_simplify_base($name);
+
+ # On VMS, case-preserved document names can't be constructed from
+ # filenames, so try to extract them from the "=head1 NAME" tag in the
+ # file instead.
+ if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) {
+ open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
+ my $in_pod = 0;
+ my $in_name = 0;
+ my $line;
+ while ($line = <PODFILE>) {
+ chomp $line;
+ $in_pod = 1 if ($line =~ m/^=\w/);
+ $in_pod = 0 if ($line =~ m/^=cut/);
+ next unless $in_pod; # skip non-pod text
+ next if ($line =~ m/^\s*\z/); # and blank lines
+ next if ($in_pod && ($line =~ m/^X</)); # and commands
+ if ($in_name) {
+ if ($line =~ m/(\w+::)?(\w+)/) {
+ # substitute case-preserved version of name
+ my $podname = $2;
+ my $prefix = $1 || '';
+ $verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n";
+ unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
+ $verbose and print "Attempting case restore of '$name' from '$podname'\n";
+ $name =~ s/$podname/$podname/i;
+ }
+ last;
+ }
+ }
+ $in_name = 1 if ($line =~ m/^=head1 NAME/);
+ }
+ close PODFILE;
+ }
+
+ return $name;
+}
+
+#==========================================================================
+
+sub _recurse_dir {
+ my($self, $startdir, $callback, $modname_bits) = @_;
+
+ my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10;
+ my $verbose = $self->verbose;
+
+ my $here_string = File::Spec->curdir;
+ my $up_string = File::Spec->updir;
+ $modname_bits ||= [];
+
+ my $recursor;
+ $recursor = sub {
+ my($dir_long, $dir_bare) = @_;
+ if( @$modname_bits >= 10 ) {
+ $verbose and print "Too deep! [@$modname_bits]\n";
+ return;
+ }
+
+ unless(-d $dir_long) {
+ $verbose > 2 and print "But it's not a dir! $dir_long\n";
+ return;
+ }
+ unless( opendir(INDIR, $dir_long) ) {
+ $verbose > 2 and print "Can't opendir $dir_long : $!\n";
+ closedir(INDIR);
+ return
+ }
+ my @items = sort readdir(INDIR);
+ closedir(INDIR);
+
+ push @$modname_bits, $dir_bare unless $dir_bare eq '';
+
+ my $i_full;
+ foreach my $i (@items) {
+ next if $i eq $here_string or $i eq $up_string or $i eq '';
+ $i_full = File::Spec->catfile( $dir_long, $i );
+
+ if(!-r $i_full) {
+ $verbose and print "Skipping unreadable $i_full\n";
+
+ } elsif(-f $i_full) {
+ $_ = $i;
+ $callback->( $i_full, $i, 0, $modname_bits );
+
+ } elsif(-d _) {
+ $i =~ s/\.DIR\z//i if $^O eq 'VMS';
+ $_ = $i;
+ my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
+
+ if($rv eq 'PRUNE') {
+ $verbose > 1 and print "OK, pruning";
+ } else {
+ # Otherwise, recurse into it
+ $recursor->( File::Spec->catdir($dir_long, $i) , $i);
+ }
+ } else {
+ $verbose > 1 and print "Skipping oddity $i_full\n";
+ }
+ }
+ pop @$modname_bits;
+ return;
+ };;
+
+ local $_;
+ $recursor->($startdir, '');
+
+ undef $recursor; # allow it to be GC'd
+
+ return;
+}
+
+
+#==========================================================================
+
+sub run {
+ # A function, useful in one-liners
+
+ my $self = __PACKAGE__->new;
+ $self->limit_glob($ARGV[0]) if @ARGV;
+ $self->callback( sub {
+ my($file, $name) = @_;
+ my $version = '';
+
+ # Yes, I know we won't catch the version in like a File/Thing.pm
+ # if we see File/Thing.pod first. That's just the way the
+ # cookie crumbles. -- SMB
+
+ if($file =~ m/\.pod$/i) {
+ # Don't bother looking for $VERSION in .pod files
+ DEBUG and print "Not looking for \$VERSION in .pod $file\n";
+ } elsif( !open(INPOD, $file) ) {
+ DEBUG and print "Couldn't open $file: $!\n";
+ close(INPOD);
+ } else {
+ # Sane case: file is readable
+ my $lines = 0;
+ while(<INPOD>) {
+ last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
+ if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
+ DEBUG and print "Found version line (#$lines): $_";
+ s/\s*\#.*//s;
+ s/\;\s*$//s;
+ s/\s+$//s;
+ s/\t+/ /s; # nix tabs
+ # Optimize the most common cases:
+ $_ = "v$1"
+ if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s
+ # like in $VERSION = "3.14159";
+ or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s
+ # like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/);
+ ;
+
+ # Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/)
+ $_ = sprintf("v%d.%s",
+ map {s/_//g; $_}
+ $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
+ if m{\$Name:\s*([^\$]+)\$}s
+ ;
+ $version = $_;
+ DEBUG and print "Noting $version as version\n";
+ last;
+ }
+ }
+ close(INPOD);
+ }
+ print "$name\t$version\t$file\n";
+ return;
+ # End of callback!
+ });
+
+ $self->survey;
+}
+
+#==========================================================================
+
+sub simplify_name {
+ my($self, $str) = @_;
+
+ # Remove all path components
+ # XXX Why not just use basename()? -- SMB
+
+ if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
+ else { $str =~ s{^.*/+}{}s }
+
+ $self->_simplify_base($str);
+ return $str;
+}
+
+#==========================================================================
+
+sub _simplify_base { # Internal method only
+
+ # strip Perl's own extensions
+ $_[1] =~ s/\.(pod|pm|plx?)\z//i;
+
+ # strip meaningless extensions on Win32 and OS/2
+ $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;
+
+ # strip meaningless extensions on VMS
+ $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';
+
+ return;
+}
+
+#==========================================================================
+
+sub _expand_inc {
+ my($self, $search_dirs) = @_;
+
+ return unless $self->{'inc'};
+
+ if ($^O eq 'MacOS') {
+ push @$search_dirs,
+ grep $_ ne File::Spec->curdir, $self->_mac_whammy(@INC);
+ # Any other OSs need custom handling here?
+ } else {
+ push @$search_dirs, grep $_ ne File::Spec->curdir, @INC;
+ }
+
+ $self->{'laborious'} = 0; # Since inc said to use INC
+ return;
+}
+
+#==========================================================================
+
+sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
+ my @them;
+ (undef,@them) = @_;
+ for $_ (@them) {
+ if ( $_ eq '.' ) {
+ $_ = ':';
+ } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
+ $_ = ':'. $_;
+ } else {
+ $_ =~ s|^\./|:|;
+ }
+ }
+ return @them;
+}
+
+#==========================================================================
+
+sub _limit_glob_to_limit_re {
+ my $self = $_[0];
+ my $limit_glob = $self->{'limit_glob'} || return;
+
+ my $limit_re = '^' . quotemeta($limit_glob) . '$';
+ $limit_re =~ s/\\\?/./g; # glob "?" => "."
+ $limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?"
+ $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""
+
+ $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";
+
+ # A common optimization:
+ if(!exists($self->{'dir_prefix'})
+ and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*"
+ # Optimize for sane and common cases (but not things like "*::File")
+ ) {
+ $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
+ $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
+ }
+
+ return $limit_re;
+}
+
+#==========================================================================
+
+# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu>
+
+sub find {
+ my($self, $pod, @search_dirs) = @_;
+ $self = $self->new unless ref $self; # tolerate being a class method
+
+ # Check usage
+ Carp::carp 'Usage: \$self->find($podname, ...)'
+ unless defined $pod and length $pod;
+
+ my $verbose = $self->verbose;
+
+ # Split on :: and then join the name together using File::Spec
+ my @parts = split /::/, $pod;
+ $verbose and print "Chomping {$pod} => {@parts}\n";
+
+ #@search_dirs = File::Spec->curdir unless @search_dirs;
+
+ if( $self->inc ) {
+ if( $^O eq 'MacOS' ) {
+ push @search_dirs, $self->_mac_whammy(@INC);
+ } else {
+ push @search_dirs, @INC;
+ }
+
+ # Add location of pod documentation for perl man pages (eg perlfunc)
+ # This is a pod directory in the private install tree
+ #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
+ # 'pod');
+ #push (@search_dirs, $perlpoddir)
+ # if -d $perlpoddir;
+
+ # Add location of binaries such as pod2text:
+ push @search_dirs, $Config::Config{'scriptdir'};
+ # and if that's undef or q{} or nonexistent, we just ignore it later
+ }
+
+ my %seen_dir;
+ Dir:
+ foreach my $dir ( @search_dirs ) {
+ next unless defined $dir and length $dir;
+ next if $seen_dir{$dir};
+ $seen_dir{$dir} = 1;
+ unless(-d $dir) {
+ print "Directory $dir does not exist\n" if $verbose;
+ next Dir;
+ }
+
+ print "Looking in directory $dir\n" if $verbose;
+ my $fullname = File::Spec->catfile( $dir, @parts );
+ print "Filename is now $fullname\n" if $verbose;
+
+ foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions
+ my $fullext = $fullname . $ext;
+ if( -f $fullext and $self->contains_pod( $fullext ) ){
+ print "FOUND: $fullext\n" if $verbose;
+ return $fullext;
+ }
+ }
+ my $subdir = File::Spec->catdir($dir,'pod');
+ if(-d $subdir) { # slip in the ./pod dir too
+ $verbose and print "Noticing $subdir and stopping there...\n";
+ $dir = $subdir;
+ redo Dir;
+ }
+ }
+
+ return undef;
+}
+
+#==========================================================================
+
+sub contains_pod {
+ my($self, $file) = @_;
+ my $verbose = $self->{'verbose'};
+
+ # check for one line of POD
+ $verbose > 1 and print " Scanning $file for pod...\n";
+ unless( open(MAYBEPOD,"<$file") ) {
+ print "Error: $file is unreadable: $!\n";
+ return undef;
+ }
+
+ sleep($SLEEPY - 1) if $SLEEPY;
+ # avoid totally hogging the processor on OSs with poor process control
+
+ local $_;
+ while( <MAYBEPOD> ) {
+ if(m/^=(head\d|pod|over|item)\b/s) {
+ close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
+ chomp;
+ $verbose > 1 and print " Found some pod ($_) in $file\n";
+ return 1;
+ }
+ }
+ close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
+ $verbose > 1 and print " No POD in $file, skipping.\n";
+ return 0;
+}
+
+#==========================================================================
+
+sub _accessorize { # A simple-minded method-maker
+ shift;
+ no strict 'refs';
+ foreach my $attrname (@_) {
+ *{caller() . '::' . $attrname} = sub {
+ use strict;
+ $Carp::CarpLevel = 1, Carp::croak(
+ "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
+ ) unless (@_ == 1 or @_ == 2) and ref $_[0];
+
+ # Read access:
+ return $_[0]->{$attrname} if @_ == 1;
+
+ # Write access:
+ $_[0]->{$attrname} = $_[1];
+ return $_[0]; # RETURNS MYSELF!
+ };
+ }
+ # Ya know, they say accessories make the ensemble!
+ return;
+}
+
+#==========================================================================
+sub _state_as_string {
+ my $self = $_[0];
+ return '' unless ref $self;
+ my @out = "{\n # State of $self ...\n";
+ foreach my $k (sort keys %$self) {
+ push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n";
+ }
+ push @out, "}\n";
+ my $x = join '', @out;
+ $x =~ s/^/#/mg;
+ return $x;
+}
+
+sub _esc {
+ my $in = $_[0];
+ return 'undef' unless defined $in;
+ $in =~
+ s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
+ <'\\x'.(unpack("H2",$1))>eg;
+ return qq{"$in"};
+}
+
+#==========================================================================
+
+run() unless caller; # run if "perl whatever/Search.pm"
+
+1;
+
+#==========================================================================
+
+__END__
+
+
+=head1 NAME
+
+Pod::Simple::Search - find POD documents in directory trees
+
+=head1 SYNOPSIS
+
+ use Pod::Simple::Search;
+ my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey;
+ print "Looky see what I found: ",
+ join(' ', sort keys %$name2path), "\n";
+
+ print "LWPUA docs = ",
+ Pod::Simple::Search->new->find('LWP::UserAgent') || "?",
+ "\n";
+
+=head1 DESCRIPTION
+
+B<Pod::Simple::Search> is a class that you use for running searches
+for Pod files. An object of this class has several attributes
+(mostly options for controlling search options), and some methods
+for searching based on those attributes.
+
+The way to use this class is to make a new object of this class,
+set any options, and then call one of the search options
+(probably C<survey> or C<find>). The sections below discuss the
+syntaxes for doing all that.
+
+
+=head1 CONSTRUCTOR
+
+This class provides the one constructor, called C<new>.
+It takes no parameters:
+
+ use Pod::Simple::Search;
+ my $search = Pod::Simple::Search->new;
+
+=head1 ACCESSORS
+
+This class defines several methods for setting (and, occasionally,
+reading) the contents of an object. With two exceptions (discussed at
+the end of this section), these attributes are just for controlling the
+way searches are carried out.
+
+Note that each of these return C<$self> when you call them as
+C<< $self->I<whatever(value)> >>. That's so that you can chain
+together set-attribute calls like this:
+
+ my $name2path =
+ Pod::Simple::Search->new
+ -> inc(0) -> verbose(1) -> callback(\&blab)
+ ->survey(@there);
+
+...which works exactly as if you'd done this:
+
+ my $search = Pod::Simple::Search->new;
+ $search->inc(0);
+ $search->verbose(1);
+ $search->callback(\&blab);
+ my $name2path = $search->survey(@there);
+
+=over
+
+=item $search->inc( I<true-or-false> );
+
+This attribute, if set to a true value, means that searches should
+implicitly add perl's I<@INC> paths. This
+automatically considers paths specified in the C<PERL5LIB> environment
+as this is prepended to I<@INC> by the Perl interpreter itself.
+This attribute's default value is B<TRUE>. If you want to search
+only specific directories, set $self->inc(0) before calling
+$inc->survey or $inc->find.
+
+
+=item $search->verbose( I<nonnegative-number> );
+
+This attribute, if set to a nonzero positive value, will make searches output
+(via C<warn>) notes about what they're doing as they do it.
+This option may be useful for debugging a pod-related module.
+This attribute's default value is zero, meaning that no C<warn> messages
+are produced. (Setting verbose to 1 turns on some messages, and setting
+it to 2 turns on even more messages, i.e., makes the following search(es)
+even more verbose than 1 would make them.)
+
+
+=item $search->limit_glob( I<some-glob-string> );
+
+This option means that you want to limit the results just to items whose
+podnames match the given glob/wildcard expression. For example, you
+might limit your search to just "LWP::*", to search only for modules
+starting with "LWP::*" (but not including the module "LWP" itself); or
+you might limit your search to "LW*" to see only modules whose (full)
+names begin with "LW"; or you might search for "*Find*" to search for
+all modules with "Find" somewhere in their full name. (You can also use
+"?" in a glob expression; so "DB?" will match "DBI" and "DBD".)
+
+
+=item $search->callback( I<\&some_routine> );
+
+This attribute means that every time this search sees a matching
+Pod file, it should call this callback routine. The routine is called
+with two parameters: the current file's filespec, and its pod name.
+(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would
+be in C<@_>.)
+
+The callback routine's return value is not used for anything.
+
+This attribute's default value is false, meaning that no callback
+is called.
+
+=item $search->laborious( I<true-or-false> );
+
+Unless you set this attribute to a true value, Pod::Search will
+apply Perl-specific heuristics to find the correct module PODs quickly.
+This attribute's default value is false. You won't normally need
+to set this to true.
+
+Specifically: Turning on this option will disable the heuristics for
+seeing only files with Perl-like extensions, omitting subdirectories
+that are numeric but do I<not> match the current Perl interpreter's
+version ID, suppressing F<site_perl> as a module hierarchy name, etc.
+
+
+=item $search->shadows( I<true-or-false> );
+
+Unless you set this attribute to a true value, Pod::Simple::Search will
+consider only the first file of a given modulename as it looks thru the
+specified directories; that is, with this option off, if
+Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this
+search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm>
+later on in that search, because that file is merely a "shadow". But if
+you turn on C<< $self->shadows(1) >>, then these "shadow" files are
+inspected too, and are noted in the pathname2podname return hash.
+
+This attribute's default value is false; and normally you won't
+need to turn it on.
+
+
+=item $search->limit_re( I<some-regxp> );
+
+Setting this attribute (to a value that's a regexp) means that you want
+to limit the results just to items whose podnames match the given
+regexp. Normally this option is not needed, and the more efficient
+C<limit_glob> attribute is used instead.
+
+
+=item $search->dir_prefix( I<some-string-value> );
+
+Setting this attribute to a string value means that the searches should
+begin in the specified subdirectory name (like "Pod" or "File::Find",
+also expressable as "File/Find"). For example, the search option
+C<< $search->limit_glob("File::Find::R*") >>
+is the same as the combination of the search options
+C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>.
+
+Normally you don't need to know about the C<dir_prefix> option, but I
+include it in case it might prove useful for someone somewhere.
+
+(Implementationally, searching with limit_glob ends up setting limit_re
+and usually dir_prefix.)
+
+
+=item $search->progress( I<some-progress-object> );
+
+If you set a value for this attribute, the value is expected
+to be an object (probably of a class that you define) that has a
+C<reach> method and a C<done> method. This is meant for reporting
+progress during the search, if you don't want to use a simple
+callback.
+
+Normally you don't need to know about the C<progress> option, but I
+include it in case it might prove useful for someone somewhere.
+
+While a search is in progress, the progress object's C<reach> and
+C<done> methods are called like this:
+
+ # Every time a file is being scanned for pod:
+ $progress->reach($count, "Scanning $file"); ++$count;
+
+ # And then at the end of the search:
+ $progress->done("Noted $count Pod files total");
+
+Internally, we often set this to an object of class
+Pod::Simple::Progress. That class is probably undocumented,
+but you may wish to look at its source.
+
+
+=item $name2path = $self->name2path;
+
+This attribute is not a search parameter, but is used to report the
+result of C<survey> method, as discussed in the next section.
+
+=item $path2name = $self->path2name;
+
+This attribute is not a search parameter, but is used to report the
+result of C<survey> method, as discussed in the next section.
+
+=back
+
+=head1 MAIN SEARCH METHODS
+
+Once you've actually set any options you want (if any), you can go
+ahead and use the following methods to search for Pod files
+in particular ways.
+
+
+=head2 C<< $search->survey( @directories ) >>
+
+The method C<survey> searches for POD documents in a given set of
+files and/or directories. This runs the search according to the various
+options set by the accessors above. (For example, if the C<inc> attribute
+is on, as it is by default, then the perl @INC directories are implicitly
+added to the list of directories (if any) that you specify.)
+
+The return value of C<survey> is two hashes:
+
+=over
+
+=item C<name2path>
+
+A hash that maps from each pod-name to the filespec (like
+"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm")
+
+=item C<path2name>
+
+A hash that maps from each Pod filespec to its pod-name (like
+"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing")
+
+=back
+
+Besides saving these hashes as the hashref attributes
+C<name2path> and C<path2name>, calling this function also returns
+these hashrefs. In list context, the return value of
+C<< $search->survey >> is the list C<(\%name2path, \%path2name)>.
+In scalar context, the return value is C<\%name2path>.
+Or you can just call this in void context.
+
+Regardless of calling context, calling C<survey> saves
+its results in its C<name2path> and C<path2name> attributes.
+
+E.g., when searching in F<$HOME/perl5lib>, the file
+F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
+whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
+I<Myclass::Subclass>. The name information can be used for POD
+translators.
+
+Only text files containing at least one valid POD command are found.
+
+In verbose mode, a warning is printed if shadows are found (i.e., more
+than one POD file with the same POD name is found, e.g. F<CPAN.pm> in
+different directories). This usually indicates duplicate occurrences of
+modules in the I<@INC> search path, which is occasionally inadvertent
+(but is often simply a case of a user's path dir having a more recent
+version than the system's general path dirs in general.)
+
+The options to this argument is a list of either directories that are
+searched recursively, or files. (Usually you wouldn't specify files,
+but just dirs.) Or you can just specify an empty-list, as in
+$name2path; with the
+C<inc> option on, as it is by default, teh
+
+The POD names of files are the plain basenames with any Perl-like
+extension (.pm, .pl, .pod) stripped, and path separators replaced by
+C<::>'s.
+
+Calling Pod::Simple::Search->search(...) is short for
+Pod::Simple::Search->new->search(...). That is, a throwaway object
+with default attribute values is used.
+
+
+=head2 C<< $search->simplify_name( $str ) >>
+
+The method B<simplify_name> is equivalent to B<basename>, but also
+strips Perl-like extensions (.pm, .pl, .pod) and extensions like
+F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
+
+
+=head2 C<< $search->find( $pod ) >>
+
+=head2 C<< $search->find( $pod, @search_dirs ) >>
+
+Returns the location of a Pod file, given a Pod/module/script name
+(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of
+what files/directories to look in.
+It searches according to the various options set by the accessors above.
+(For example, if the C<inc> attribute is on, as it is by default, then
+the perl @INC directories are implicitly added to the list of
+directories (if any) that you specify.)
+
+This returns the full path of the first occurrence to the file.
+Package names (eg 'A::B') are automatically converted to directory
+names in the selected directory. Additionally, '.pm', '.pl' and '.pod'
+are automatically appended to the search as required.
+(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm",
+"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.)
+
+If no such Pod file is found, this method returns undef.
+
+If any of the given search directories contains a F<pod/> subdirectory,
+then it is searched. (That's how we manage to find F<perlfunc>,
+for example, which is usually in F<pod/perlfunc> in most Perl dists.)
+
+The C<verbose> and C<inc> attributes influence the behavior of this
+search; notably, C<inc>, if true, adds @INC I<and also
+$Config::Config{'scriptdir'}> to the list of directories to search.
+
+It is common to simply say C<< $filename = Pod::Simple::Search-> new
+->find("perlvar") >> so that just the @INC (well, and scriptdir)
+directories are searched. (This happens because the C<inc>
+attribute is true by default.)
+
+Calling Pod::Simple::Search->find(...) is short for
+Pod::Simple::Search->new->find(...). That is, a throwaway object
+with default attribute values is used.
+
+
+=head2 C<< $self->contains_pod( $file ) >>
+
+Returns true if the supplied filename (not POD module) contains some Pod
+documentation.
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org> with code borrowed
+from Marek Rouchal's L<Pod::Find>, which in turn heavily borrowed code from
+Nick Ing-Simmons' C<PodToHtml>.
+
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/SimpleTree.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/SimpleTree.pm
new file mode 100755
index 00000000000..7f39680103d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/SimpleTree.pm
@@ -0,0 +1,180 @@
+
+
+require 5;
+package Pod::Simple::SimpleTree;
+use strict;
+use Carp ();
+use Pod::Simple ();
+use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
+$VERSION = '3.13';
+BEGIN {
+ @ISA = ('Pod::Simple');
+ *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
+}
+
+__PACKAGE__->_accessorize(
+ 'root', # root of the tree
+);
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _handle_element_start { # self, tagname, attrhash
+ DEBUG > 2 and print "Handling $_[1] start-event\n";
+ my $x = [$_[1], $_[2]];
+ if($_[0]{'_currpos'}) {
+ push @{ $_[0]{'_currpos'}[0] }, $x; # insert in parent's child-list
+ unshift @{ $_[0]{'_currpos'} }, $x; # prefix to stack
+ } else {
+ DEBUG and print " And oo, it gets to be root!\n";
+ $_[0]{'_currpos'} = [ $_[0]{'root'} = $x ];
+ # first event! set to stack, and set as root.
+ }
+ DEBUG > 3 and print "Stack is now: ",
+ join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
+ return;
+}
+
+sub _handle_element_end { # self, tagname
+ DEBUG > 2 and print "Handling $_[1] end-event\n";
+ shift @{$_[0]{'_currpos'}};
+ DEBUG > 3 and print "Stack is now: ",
+ join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
+ return;
+}
+
+sub _handle_text { # self, text
+ DEBUG > 2 and print "Handling $_[1] text-event\n";
+ push @{ $_[0]{'_currpos'}[0] }, $_[1];
+ return;
+}
+
+
+# A bit of evil from the black box... please avert your eyes, kind souls.
+sub _traverse_treelet_bit {
+ DEBUG > 2 and print "Handling $_[1] paragraph event\n";
+ my $self = shift;
+ push @{ $self->{'_currpos'}[0] }, [@_];
+ return;
+}
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1;
+__END__
+
+=head1 NAME
+
+Pod::Simple::SimpleTree -- parse Pod into a simple parse tree
+
+=head1 SYNOPSIS
+
+ % cat ptest.pod
+
+ =head1 PIE
+
+ I like B<pie>!
+
+ % perl -MPod::Simple::SimpleTree -MData::Dumper -e \
+ "print Dumper(Pod::Simple::SimpleTree->new->parse_file(shift)->root)" \
+ ptest.pod
+
+ $VAR1 = [
+ 'Document',
+ { 'start_line' => 1 },
+ [
+ 'head1',
+ { 'start_line' => 1 },
+ 'PIE'
+ ],
+ [
+ 'Para',
+ { 'start_line' => 3 },
+ 'I like ',
+ [
+ 'B',
+ {},
+ 'pie'
+ ],
+ '!'
+ ]
+ ];
+
+=head1 DESCRIPTION
+
+This class is of interest to people writing a Pod processor/formatter.
+
+This class takes Pod and parses it, returning a parse tree made just
+of arrayrefs, and hashrefs, and strings.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+This class is inspired by XML::Parser's "Tree" parsing-style, although
+it doesn't use exactly the same LoL format.
+
+=head1 METHODS
+
+At the end of the parse, call C<< $parser->root >> to get the
+tree's top node.
+
+=head1 Tree Contents
+
+Every element node in the parse tree is represented by an arrayref of
+the form: C<[ I<elementname>, \%attributes, I<...subnodes...> ]>.
+See the example tree dump in the Synopsis, above.
+
+Every text node in the tree is represented by a simple (non-ref)
+string scalar. So you can test C<ref($node)> to see whather you have
+an element node or just a text node.
+
+The top node in the tree is C<[ 'Document', \%attributes,
+I<...subnodes...> ]>
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple>
+
+L<perllol>
+
+L<The "Tree" subsubsection in XML::Parser|XML::Parser/"Tree">
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Subclassing.pod b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Subclassing.pod
new file mode 100755
index 00000000000..f2011d5a5ce
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Subclassing.pod
@@ -0,0 +1,946 @@
+
+=head1 NAME
+
+Pod::Simple::Subclassing -- write a formatter as a Pod::Simple subclass
+
+=head1 SYNOPSIS
+
+ package Pod::SomeFormatter;
+ use Pod::Simple;
+ @ISA = qw(Pod::Simple);
+ $VERSION = '1.01';
+ use strict;
+
+ sub _handle_element_start {
+ my($parser, $element_name, $attr_hash_r) = @_;
+ ...
+ }
+
+ sub _handle_element_end {
+ my($parser, $element_name) = @_;
+ ...
+ }
+
+ sub _handle_text {
+ my($parser, $text) = @_;
+ ...
+ }
+ 1;
+
+=head1 DESCRIPTION
+
+This document is about using Pod::Simple to write a Pod processor,
+generally a Pod formatter. If you just want to know about using an
+existing Pod formatter, instead see its documentation and see also the
+docs in L<Pod::Simple>.
+
+The zeroeth step in writing a Pod formatter is to make sure that there
+isn't already a decent one in CPAN. See L<http://search.cpan.org/>, and
+run a search on the name of the format you want to render to. Also
+consider joining the Pod People list
+L<http://lists.perl.org/showlist.cgi?name=pod-people> and asking whether
+anyone has a formatter for that format -- maybe someone cobbled one
+together but just hasn't released it.
+
+The first step in writing a Pod processor is to read L<perlpodspec>,
+which contains notes information on writing a Pod parser (which has been
+largely taken care of by Pod::Simple), but also a lot of requirements
+and recommendations for writing a formatter.
+
+The second step is to actually learn the format you're planning to
+format to -- or at least as much as you need to know to represent Pod,
+which probably isn't much.
+
+The third step is to pick which of Pod::Simple's interfaces you want to
+use -- the basic interface via Pod::Simple or L<Pod::Simple::Methody> is
+event-based, sort of like L<HTML::Parser>'s interface, or sort of like
+L<XML::Parser>'s "Handlers" interface), but L<Pod::Simple::PullParser>
+provides a token-stream interface, sort of like L<HTML::TokeParser>'s
+interface; L<Pod::Simple::SimpleTree> provides a simple tree interface,
+rather like XML::Parser's "Tree" interface. Users familiar with
+XML-handling will find one of these styles relatively familiar; but if
+you would be even more at home with XML, there are classes that produce
+an XML representation of the Pod stream, notably
+L<Pod::Simple::XMLOutStream>; you can feed the output of such a class to
+whatever XML parsing system you are most at home with.
+
+The last step is to write your code based on how the events (or tokens,
+or tree-nodes, or the XML, or however you're parsing) will map to
+constructs in the output format. Also sure to consider how to escape
+text nodes containing arbitrary text, and also what to do with text
+nodes that represent preformatted text (from verbatim sections).
+
+
+
+=head1 Events
+
+TODO intro... mention that events are supplied for implicits, like for
+missing >'s
+
+
+In the following section, we use XML to represent the event structure
+associated with a particular construct. That is, TODO
+
+=over
+
+=item C<< $parser->_handle_element_start( I<element_name>, I<attr_hashref> ) >>
+
+=item C<< $parser->_handle_element_end( I<element_name> ) >>
+
+=item C<< $parser->_handle_text( I<text_string> ) >>
+
+=back
+
+TODO describe
+
+
+=over
+
+=item events with an element_name of Document
+
+Parsing a document produces this event structure:
+
+ <Document start_line="543">
+ ...all events...
+ </Document>
+
+The value of the I<start_line> attribute will be the line number of the first
+Pod directive in the document.
+
+If there is no Pod in the given document, then the
+event structure will be this:
+
+ <Document contentless="1" start_line="543">
+ </Document>
+
+In that case, the value of the I<start_line> attribute will not be meaningful;
+under current implementations, it will probably be the line number of the
+last line in the file.
+
+=item events with an element_name of Para
+
+Parsing a plain (non-verbatim, non-directive, non-data) paragraph in
+a Pod document produces this event structure:
+
+ <Para start_line="543">
+ ...all events in this paragraph...
+ </Para>
+
+The value of the I<start_line> attribute will be the line number of the start
+of the paragraph.
+
+For example, parsing this paragraph of Pod:
+
+ The value of the I<start_line> attribute will be the
+ line number of the start of the paragraph.
+
+produces this event structure:
+
+ <Para start_line="129">
+ The value of the
+ <I>
+ start_line
+ </I>
+ attribute will be the line number of the first Pod directive
+ in the document.
+ </Para>
+
+=item events with an element_name of B, C, F, or I.
+
+Parsing a BE<lt>...E<gt> formatting code (or of course any of its
+semantically identical syntactic variants
+S<BE<lt>E<lt> ... E<gt>E<gt>>,
+or S<BE<lt>E<lt>E<lt>E<lt> ... E<gt>E<gt>E<gt>E<gt>>, etc.)
+produces this event structure:
+
+ <B>
+ ...stuff...
+ </B>
+
+Currently, there are no attributes conveyed.
+
+Parsing C, F, or I codes produce the same structure, with only a
+different element name.
+
+If your parser object has been set to accept other formatting codes,
+then they will be presented like these B/C/F/I codes -- i.e., without
+any attributes.
+
+=item events with an element_name of S
+
+Normally, parsing an SE<lt>...E<gt> sequence produces this event
+structure, just as if it were a B/C/F/I code:
+
+ <S>
+ ...stuff...
+ </S>
+
+However, Pod::Simple (and presumably all derived parsers) offers the
+C<nbsp_for_S> option which, if enabled, will suppress all S events, and
+instead change all spaces in the content to non-breaking spaces. This is
+intended for formatters that output to a format that has no code that
+means the same as SE<lt>...E<gt>, but which has a code/character that
+means non-breaking space.
+
+=item events with an element_name of X
+
+Normally, parsing an XE<lt>...E<gt> sequence produces this event
+structure, just as if it were a B/C/F/I code:
+
+ <X>
+ ...stuff...
+ </X>
+
+However, Pod::Simple (and presumably all derived parsers) offers the
+C<nix_X_codes> option which, if enabled, will suppress all X events
+and ignore their content. For formatters/processors that don't use
+X events, this is presumably quite useful.
+
+
+=item events with an element_name of L
+
+Because the LE<lt>...E<gt> is the most complex construct in the
+language, it should not surprise you that the events it generates are
+the most complex in the language. Most of complexity is hidden away in
+the attribute values, so for those of you writing a Pod formatter that
+produces a non-hypertextual format, you can just ignore the attributes
+and treat an L event structure like a formatting element that
+(presumably) doesn't actually produce a change in formatting. That is,
+the content of the L event structure (as opposed to its
+attributes) is always what text should be displayed.
+
+There are, at first glance, three kinds of L links: URL, man, and pod.
+
+When a LE<lt>I<some_url>E<gt> code is parsed, it produces this event
+structure:
+
+ <L content-implicit="yes" to="that_url" type="url">
+ that_url
+ </L>
+
+The C<type="url"> attribute is always specified for this type of
+L code.
+
+For example, this Pod source:
+
+ L<http://www.perl.com/CPAN/authors/>
+
+produces this event structure:
+
+ <L content-implicit="yes" to="http://www.perl.com/CPAN/authors/" type="url">
+ http://www.perl.com/CPAN/authors/
+ </L>
+
+When a LE<lt>I<manpage(section)>E<gt> code is parsed (and these are
+fairly rare and not terribly useful), it produces this event structure:
+
+ <L content-implicit="yes" to="manpage(section)" type="man">
+ manpage(section)
+ </L>
+
+The C<type="man"> attribute is always specified for this type of
+L code.
+
+For example, this Pod source:
+
+ L<crontab(5)>
+
+produces this event structure:
+
+ <L content-implicit="yes" to="crontab(5)" type="man">
+ crontab(5)
+ </L>
+
+In the rare cases where a man page link has a specified, that text appears
+in a I<section> attribute. For example, this Pod source:
+
+ L<crontab(5)/"ENVIRONMENT">
+
+will produce this event structure:
+
+ <L content-implicit="yes" section="ENVIRONMENT" to="crontab(5)" type="man">
+ "ENVIRONMENT" in crontab(5)
+ </L>
+
+In the rare case where the Pod document has code like
+LE<lt>I<sometext>|I<manpage(section)>E<gt>, then the I<sometext> will appear
+as the content of the element, the I<manpage(section)> text will appear
+only as the value of the I<to> attribute, and there will be no
+C<content-implicit="yes"> attribute (whose presence means that the Pod parser
+had to infer what text should appear as the link text -- as opposed to
+cases where that attribute is absent, which means that the Pod parser did
+I<not> have to infer the link text, because that L code explicitly specified
+some link text.)
+
+For example, this Pod source:
+
+ L<hell itself!|crontab(5)>
+
+will produce this event structure:
+
+ <L to="crontab(5)" type="man">
+ hell itself!
+ </L>
+
+The last type of L structure is for links to/within Pod documents. It is
+the most complex because it can have a I<to> attribute, I<or> a
+I<section> attribute, or both. The C<type="pod"> attribute is always
+specified for this type of L code.
+
+In the most common case, the simple case of a LE<lt>podpageE<gt> code
+produces this event structure:
+
+ <L content-implicit="yes" to="Net::Ping" type="pod">
+ podpage
+ </L>
+
+For example, this Pod source:
+
+ L<Net::Ping>
+
+produces this event structure:
+
+ <L content-implicit="yes" to="Net::Ping" type="pod">
+ Net::Ping
+ </L>
+
+In cases where there is link-text explicitly specified, it
+is to be found in the content of the element (and not the
+attributes), just as with the LE<lt>I<sometext>|I<manpage(section)>E<gt>
+case discussed above. For example, this Pod source:
+
+ L<Perl Error Messages|perldiag>
+
+produces this event structure:
+
+ <L to="perldiag" type="pod">
+ Perl Error Messages
+ </L>
+
+In cases of links to a section in the current Pod document,
+there is a I<section> attribute instead of a I<to> attribute.
+For example, this Pod source:
+
+ L</"Member Data">
+
+produces this event structure:
+
+ <L content-implicit="yes" section="Member Data" type="pod">
+ "Member Data"
+ </L>
+
+As another example, this Pod source:
+
+ L<the various attributes|/"Member Data">
+
+produces this event structure:
+
+ <L section="Member Data" type="pod">
+ the various attributes
+ </L>
+
+In cases of links to a section in a different Pod document,
+there are both a I<section> attribute and a L<to> attribute.
+For example, this Pod source:
+
+ L<perlsyn/"Basic BLOCKs and Switch Statements">
+
+produces this event structure:
+
+ <L content-implicit="yes" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
+ "Basic BLOCKs and Switch Statements" in perlsyn
+ </L>
+
+As another example, this Pod source:
+
+ L<SWITCH statements|perlsyn/"Basic BLOCKs and Switch Statements">
+
+produces this event structure:
+
+ <L section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
+ SWITCH statements
+ </L>
+
+Incidentally, note that we do not distinguish between these syntaxes:
+
+ L</"Member Data">
+ L<"Member Data">
+ L</Member Data>
+ L<Member Data> [deprecated syntax]
+
+That is, they all produce the same event structure, namely:
+
+ <L content-implicit="yes" section="Member Data" type="pod">
+ &#34;Member Data&#34;
+ </L>
+
+=item events with an element_name of E or Z
+
+While there are Pod codes EE<lt>...E<gt> and ZE<lt>E<gt>, these
+I<do not> produce any E or Z events -- that is, there are no such
+events as E or Z.
+
+=item events with an element_name of Verbatim
+
+When a Pod verbatim paragraph (AKA "codeblock") is parsed, it
+produces this event structure:
+
+ <Verbatim start_line="543" xml:space="preserve">
+ ...text...
+ </Verbatim>
+
+The value of the I<start_line> attribute will be the line number of the
+first line of this verbatim block. The I<xml:space> attribute is always
+present, and always has the value "preserve".
+
+The text content will have tabs already expanded.
+
+
+=item events with an element_name of head1 .. head4
+
+When a "=head1 ..." directive is parsed, it produces this event
+structure:
+
+ <head1>
+ ...stuff...
+ </head1>
+
+For example, a directive consisting of this:
+
+ =head1 Options to C<new> et al.
+
+will produce this event structure:
+
+ <head1 start_line="543">
+ Options to
+ <C>
+ new
+ </C>
+ et al.
+ </head1>
+
+"=head2" thru "=head4" directives are the same, except for the element
+names in the event structure.
+
+=item events with an element_name of over-bullet
+
+When an "=over ... Z<>=back" block is parsed where the items are
+a bulletted list, it will produce this event structure:
+
+ <over-bullet indent="4" start_line="543">
+ <item-bullet start_line="545">
+ ...Stuff...
+ </item-bullet>
+ ...more item-bullets...
+ </over-bullet>
+
+The value of the I<indent> attribute is whatever value is after the
+"=over" directive, as in "=over 8". If no such value is specified
+in the directive, then the I<indent> attribute has the value "4".
+
+For example, this Pod source:
+
+ =over
+
+ =item *
+
+ Stuff
+
+ =item *
+
+ Bar I<baz>!
+
+ =back
+
+produces this event structure:
+
+ <over-bullet indent="4" start_line="10">
+ <item-bullet start_line="12">
+ Stuff
+ </item-bullet>
+ <item-bullet start_line="14">
+ Bar <I>baz</I>!
+ </item-bullet>
+ </over-bullet>
+
+=item events with an element_name of over-number
+
+When an "=over ... Z<>=back" block is parsed where the items are
+a numbered list, it will produce this event structure:
+
+ <over-number indent="4" start_line="543">
+ <item-number number="1" start_line="545">
+ ...Stuff...
+ </item-number>
+ ...more item-number...
+ </over-bullet>
+
+This is like the "over-bullet" event structure; but note that the contents
+are "item-number" instead of "item-bullet", and note that they will have
+a "number" attribute, which some formatters/processors may ignore
+(since, for example, there's no need for it in HTML when producing
+an "<UL><LI>...</LI>...</UL>" structure), but which any processor may use.
+
+Note that the values for the I<number> attributes of "item-number"
+elements in a given "over-number" area I<will> start at 1 and go up by
+one each time. If the Pod source doesn't follow that order (even though
+it really should should!), whatever numbers it has will be ignored (with
+the correct values being put in the I<number> attributes), and an error
+message might be issued to the user.
+
+=item events with an element_name of over-text
+
+These events are are somewhat unlike the other over-*
+structures, as far as what their contents are. When
+an "=over ... Z<>=back" block is parsed where the items are
+a list of text "subheadings", it will produce this event structure:
+
+ <over-text indent="4" start_line="543">
+ <item-text>
+ ...stuff...
+ </item-text>
+ ...stuff (generally Para or Verbatim elements)...
+ <item-text>
+ ...more item-text and/or stuff...
+ </over-text>
+
+The I<indent> attribute is as with the other over-* events.
+
+For example, this Pod source:
+
+ =over
+
+ =item Foo
+
+ Stuff
+
+ =item Bar I<baz>!
+
+ Quux
+
+ =back
+
+produces this event structure:
+
+ <over-text indent="4" start_line="20">
+ <item-text start_line="22">
+ Foo
+ </item-text>
+ <Para start_line="24">
+ Stuff
+ </Para>
+ <item-text start_line="26">
+ Bar
+ <I>
+ baz
+ </I>
+ !
+ </item-text>
+ <Para start_line="28">
+ Quux
+ </Para>
+ </over-text>
+
+
+
+=item events with an element_name of over-block
+
+These events are are somewhat unlike the other over-*
+structures, as far as what their contents are. When
+an "=over ... Z<>=back" block is parsed where there are no items,
+it will produce this event structure:
+
+ <over-block indent="4" start_line="543">
+ ...stuff (generally Para or Verbatim elements)...
+ </over-block>
+
+The I<indent> attribute is as with the other over-* events.
+
+For example, this Pod source:
+
+ =over
+
+ For cutting off our trade with all parts of the world
+
+ For transporting us beyond seas to be tried for pretended offenses
+
+ He is at this time transporting large armies of foreign mercenaries to
+ complete the works of death, desolation and tyranny, already begun with
+ circumstances of cruelty and perfidy scarcely paralleled in the most
+ barbarous ages, and totally unworthy the head of a civilized nation.
+
+ =cut
+
+will produce this event structure:
+
+ <over-block indent="4" start_line="2">
+ <Para start_line="4">
+ For cutting off our trade with all parts of the world
+ </Para>
+ <Para start_line="6">
+ For transporting us beyond seas to be tried for pretended offenses
+ </Para>
+ <Para start_line="8">
+ He is at this time transporting large armies of [...more text...]
+ </Para>
+ </over-block>
+
+=item events with an element_name of item-bullet
+
+See L</"events with an element_name of over-bullet">, above.
+
+=item events with an element_name of item-number
+
+See L</"events with an element_name of over-number">, above.
+
+=item events with an element_name of item-text
+
+See L</"events with an element_name of over-text">, above.
+
+=item events with an element_name of for
+
+TODO...
+
+=item events with an element_name of Data
+
+TODO...
+
+=back
+
+
+
+=head1 More Pod::Simple Methods
+
+Pod::Simple provides a lot of methods that aren't generally interesting
+to the end user of an existing Pod formatter, but some of which you
+might find useful in writing a Pod formatter. They are listed below. The
+first several methods (the accept_* methods) are for declaring the
+capabilites of your parser, notably what C<=for I<targetname>> sections
+it's interested in, what extra NE<lt>...E<gt> codes it accepts beyond
+the ones described in the I<perlpod>.
+
+=over
+
+=item C<< $parser->accept_targets( I<SOMEVALUE> ) >>
+
+As the parser sees sections like:
+
+ =for html <img src="fig1.jpg">
+
+or
+
+ =begin html
+
+ <img src="fig1.jpg">
+
+ =end html
+
+...the parser will ignore these sections unless your subclass has
+specified that it wants to see sections targetted to "html" (or whatever
+the formatter name is).
+
+If you want to process all sections, even if they're not targetted for you,
+call this before you start parsing:
+
+ $parser->accept_targets('*');
+
+=item C<< $parser->accept_targets_as_text( I<SOMEVALUE> ) >>
+
+This is like accept_targets, except that it specifies also that the
+content of sections for this target should be treated as Pod text even
+if the target name in "=for I<targetname>" doesn't start with a ":".
+
+At time of writing, I don't think you'll need to use this.
+
+
+=item C<< $parser->accept_codes( I<Codename>, I<Codename>... ) >>
+
+This tells the parser that you accept additional formatting codes,
+beyond just the standard ones (I B C L F S X, plus the two weird ones
+you don't actually see in the parse tree, Z and E). For example, to also
+accept codes "N", "R", and "W":
+
+ $parser->accept_codes( qw( N R W ) );
+
+B<TODO: document how this interacts with =extend, and long element names>
+
+
+=item C<< $parser->accept_directive_as_data( I<directive_name> ) >>
+
+=item C<< $parser->accept_directive_as_verbatim( I<directive_name> ) >>
+
+=item C<< $parser->accept_directive_as_processed( I<directive_name> ) >>
+
+In the unlikely situation that you need to tell the parser that you will
+accept additional directives ("=foo" things), you need to first set the
+parset to treat its content as data (i.e., not really processed at
+all), or as verbatim (mostly just expanding tabs), or as processed text
+(parsing formatting codes like BE<lt>...E<gt>).
+
+For example, to accept a new directive "=method", you'd presumably
+use:
+
+ $parser->accept_directive_as_processed("method");
+
+so that you could have Pod lines like:
+
+ =method I<$whatever> thing B<um>
+
+Making up your own directives breaks compatibility with other Pod
+formatters, in a way that using "=for I<target> ..." lines doesn't;
+however, you may find this useful if you're making a Pod superset
+format where you don't need to worry about compatibility.
+
+
+=item C<< $parser->nbsp_for_S( I<BOOLEAN> ); >>
+
+Setting this attribute to a true value (and by default it is false) will
+turn "SE<lt>...E<gt>" sequences into sequences of words separated by
+C<\xA0> (non-breaking space) characters. For example, it will take this:
+
+ I like S<Dutch apple pie>, don't you?
+
+and treat it as if it were:
+
+ I like DutchE<nbsp>appleE<nbsp>pie, don't you?
+
+This is handy for output formats that don't have anything quite like an
+"SE<lt>...E<gt>" code, but which do have a code for non-breaking space.
+
+There is currently no method for going the other way; but I can
+probably provide one upon request.
+
+
+=item C<< $parser->version_report() >>
+
+This returns a string reporting the $VERSION value from your module (and
+its classname) as well as the $VERSION value of Pod::Simple. Note that
+L<perlpodspec> requires output formats (wherever possible) to note
+this detail in a comment in the output format. For example, for
+some kind of SGML output format:
+
+ print OUT "<!-- \n", $parser->version_report, "\n -->";
+
+
+=item C<< $parser->pod_para_count() >>
+
+This returns the count of Pod paragraphs seen so far.
+
+
+=item C<< $parser->line_count() >>
+
+This is the current line number being parsed. But you might find the
+"line_number" event attribute more accurate, when it is present.
+
+
+=item C<< $parser->nix_X_codes( I<SOMEVALUE> ) >>
+
+This attribute, when set to a true value (and it is false by default)
+ignores any "XE<lt>...E<gt>" sequences in the document being parsed.
+Many formats don't actually use the content of these codes, so have
+no reason to process them.
+
+
+=item C<< $parser->merge_text( I<SOMEVALUE> ) >>
+
+This attribute, when set to a true value (and it is false by default)
+makes sure that only one event (or token, or node) will be created
+for any single contiguous sequence of text. For example, consider
+this somewhat contrived example:
+
+ I just LOVE Z<>hotE<32>apple pie!
+
+When that is parsed and events are about to be called on it, it may
+actually seem to be four different text events, one right after another:
+one event for "I just LOVE ", one for "hot", one for " ", and one for
+"apple pie!". But if you have merge_text on, then you're guaranteed
+that it will be fired as one text event: "I just LOVE hot apple pie!".
+
+
+=item C<< $parser->code_handler( I<CODE_REF> ) >>
+
+This specifies code that should be called when a code line is seen
+(i.e., a line outside of the Pod). Normally this is undef, meaning
+that no code should be called. If you provide a routine, it should
+start out like this:
+
+ sub get_code_line { # or whatever you'll call it
+ my($line, $line_number, $parser) = @_;
+ ...
+ }
+
+Note, however, that sometimes the Pod events aren't processed in exactly
+the same order as the code lines are -- i.e., if you have a file with
+Pod, then code, then more Pod, sometimes the code will be processed (via
+whatever you have code_handler call) before the all of the preceding Pod
+has been processed.
+
+
+=item C<< $parser->cut_handler( I<CODE_REF> ) >>
+
+This is just like the code_handler attribute, except that it's for
+"=cut" lines, not code lines. The same caveats apply. "=cut" lines are
+unlikely to be interesting, but this is included for completeness.
+
+
+=item C<< $parser->whine( I<linenumber>, I<complaint string> ) >>
+
+This notes a problem in the Pod, which will be reported to in the "Pod
+Errors" section of the document and/or send to STDERR, depending on the
+values of the attributes C<no_whining>, C<no_errata_section>, and
+C<complain_stderr>.
+
+=item C<< $parser->scream( I<linenumber>, I<complaint string> ) >>
+
+This notes an error like C<whine> does, except that it is not
+suppressable with C<no_whining>. This should be used only for very
+serious errors.
+
+
+=item C<< $parser->source_dead(1) >>
+
+This aborts parsing of the current document, by switching on the flag
+that indicates that EOF has been seen. In particularly drastic cases,
+you might want to do this. It's rather nicer than just calling
+C<die>!
+
+=item C<< $parser->hide_line_numbers( I<SOMEVALUE> ) >>
+
+Some subclasses that indescriminately dump event attributes (well,
+except for ones beginning with "~") can use this object attribute for
+refraining to dump the "start_line" attribute.
+
+=item C<< $parser->no_whining( I<SOMEVALUE> ) >>
+
+This attribute, if set to true, will suppress reports of non-fatal
+error messages. The default value is false, meaning that complaints
+I<are> reported. How they get reported depends on the values of
+the attributes C<no_errata_section> and C<complain_stderr>.
+
+=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >>
+
+This attribute, if set to true, will suppress generation of an errata
+section. The default value is false -- i.e., an errata section will be
+generated.
+
+=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >>
+
+This attribute, if set to true will send complaints to STDERR. The
+default value is false -- i.e., complaints do not go to STDERR.
+
+=item C<< $parser->bare_output( I<SOMEVALUE> ) >>
+
+Some formatter subclasses use this as a flag for whether output should
+have prologue and epilogue code omitted. For example, setting this to
+true for an HTML formatter class should omit the
+"<html><head><title>...</title><body>..." prologue and the
+"</body></html>" epilogue.
+
+If you want to set this to true, you should probably also set
+C<no_whining> or at least C<no_errata_section> to true.
+
+=item C<< $parser->preserve_whitespace( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, the parser will try to
+preserve whitespace in the output. This means that such formatting
+conventions as two spaces after periods will be preserved by the parser.
+This is primarily useful for output formats that treat whitespace as
+significant (such as text or *roff, but not HTML).
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple> -- event-based Pod-parsing framework
+
+L<Pod::Simple::Methody> -- like Pod::Simple, but each sort of event
+calls its own method (like C<start_head3>)
+
+L<Pod::Simple::PullParser> -- a Pod-parsing framework like Pod::Simple,
+but with a token-stream interface
+
+L<Pod::Simple::SimpleTree> -- a Pod-parsing framework like Pod::Simple,
+but with a tree interface
+
+L<Pod::Simple::Checker> -- a simple Pod::Simple subclass that reads
+documents, and then makes a plaintext report of any errors found in the
+document
+
+L<Pod::Simple::DumpAsXML> -- for dumping Pod documents as tidily
+indented XML, showing each event on its own line
+
+L<Pod::Simple::XMLOutStream> -- dumps a Pod document as XML (without
+introducing extra whitespace as Pod::Simple::DumpAsXML does).
+
+L<Pod::Simple::DumpAsText> -- for dumping Pod documents as tidily
+indented text, showing each event on its own line
+
+L<Pod::Simple::LinkSection> -- class for objects representing the values
+of the TODO and TODO attributes of LE<lt>...E<gt> elements
+
+L<Pod::Escapes> -- the module the Pod::Simple uses for evaluating
+EE<lt>...E<gt> content
+
+L<Pod::Simple::Text> -- a simple plaintext formatter for Pod
+
+L<Pod::Simple::TextContent> -- like Pod::Simple::Text, but
+makes no effort for indent or wrap the text being formatted
+
+L<perlpod|perlpod>
+
+L<perlpodspec|perlpodspec>
+
+L<perldoc>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=for notes
+Hm, my old podchecker version (1.2) says:
+ *** WARNING: node 'http://search.cpan.org/' contains non-escaped | or / at line 38 in file Subclassing.pod
+ *** WARNING: node 'http://lists.perl.org/showlist.cgi?name=pod-people' contains non-escaped | or / at line 41 in file Subclassing.pod
+Yes, L<...> is hard.
+
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Text.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Text.pm
new file mode 100755
index 00000000000..fe89806eaba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Text.pm
@@ -0,0 +1,185 @@
+
+require 5;
+package Pod::Simple::Text;
+use strict;
+use Carp ();
+use Pod::Simple::Methody ();
+use Pod::Simple ();
+use vars qw( @ISA $VERSION $FREAKYMODE);
+$VERSION = '3.13';
+@ISA = ('Pod::Simple::Methody');
+BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
+ ? \&Pod::Simple::DEBUG
+ : sub() {0}
+ }
+
+use Text::Wrap 98.112902 ();
+$Text::Wrap::wrap = 'overflow';
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->accept_target_as_text(qw( text plaintext plain ));
+ $new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->{'Thispara'} = '';
+ $new->{'Indent'} = 0;
+ $new->{'Indentstring'} = ' ';
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub handle_text { $_[0]{'Thispara'} .= $_[1] }
+
+sub start_Para { $_[0]{'Thispara'} = '' }
+sub start_head1 { $_[0]{'Thispara'} = '' }
+sub start_head2 { $_[0]{'Thispara'} = '' }
+sub start_head3 { $_[0]{'Thispara'} = '' }
+sub start_head4 { $_[0]{'Thispara'} = '' }
+
+sub start_Verbatim { $_[0]{'Thispara'} = '' }
+sub start_item_bullet { $_[0]{'Thispara'} = $FREAKYMODE ? '' : '* ' }
+sub start_item_number { $_[0]{'Thispara'} = $FREAKYMODE ? '' : "$_[1]{'number'}. " }
+sub start_item_text { $_[0]{'Thispara'} = '' }
+
+sub start_over_bullet { ++$_[0]{'Indent'} }
+sub start_over_number { ++$_[0]{'Indent'} }
+sub start_over_text { ++$_[0]{'Indent'} }
+sub start_over_block { ++$_[0]{'Indent'} }
+
+sub end_over_bullet { --$_[0]{'Indent'} }
+sub end_over_number { --$_[0]{'Indent'} }
+sub end_over_text { --$_[0]{'Indent'} }
+sub end_over_block { --$_[0]{'Indent'} }
+
+
+# . . . . . Now the actual formatters:
+
+sub end_head1 { $_[0]->emit_par(-4) }
+sub end_head2 { $_[0]->emit_par(-3) }
+sub end_head3 { $_[0]->emit_par(-2) }
+sub end_head4 { $_[0]->emit_par(-1) }
+sub end_Para { $_[0]->emit_par( 0) }
+sub end_item_bullet { $_[0]->emit_par( 0) }
+sub end_item_number { $_[0]->emit_par( 0) }
+sub end_item_text { $_[0]->emit_par(-2) }
+sub start_L { $_[0]{'Link'} = $_[1] if $_[1]->{type} eq 'url' }
+sub end_L {
+ if (my $link = delete $_[0]{'Link'}) {
+ # Append the URL to the output unless it's already present.
+ $_[0]{'Thispara'} .= " <$link->{to}>"
+ unless $_[0]{'Thispara'} =~ /\b\E$link->{to}/;
+ }
+}
+
+sub emit_par {
+ my($self, $tweak_indent) = splice(@_,0,2);
+ my $indent = ' ' x ( 2 * $self->{'Indent'} + 4 + ($tweak_indent||0) );
+ # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
+
+ $self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII;
+ my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
+ $out =~ tr{\xA0}{ } if Pod::Simple::ASCII;
+ print {$self->{'output_fh'}} $out, "\n";
+ $self->{'Thispara'} = '';
+
+ return;
+}
+
+# . . . . . . . . . . And then off by its lonesome:
+
+sub end_Verbatim {
+ my $self = shift;
+ if(Pod::Simple::ASCII) {
+ $self->{'Thispara'} =~ tr{\xA0}{ };
+ $self->{'Thispara'} =~ tr{\xAD}{}d;
+ }
+
+ my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
+ #my $i = ' ' x (4 + $self->{'Indent'});
+
+ $self->{'Thispara'} =~ s/^/$i/mg;
+
+ print { $self->{'output_fh'} } '',
+ $self->{'Thispara'},
+ "\n\n"
+ ;
+ $self->{'Thispara'} = '';
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Text -- format Pod as plaintext
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::Text -e \
+ "exit Pod::Simple::Text->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is a formatter that takes Pod and renders it as
+wrapped plaintext.
+
+Its wrapping is done by L<Text::Wrap>, so you can change
+C<$Text::Wrap::columns> as you like.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::TextContent>, L<Pod::Text>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TextContent.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TextContent.pm
new file mode 100755
index 00000000000..badce4ddcad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TextContent.pm
@@ -0,0 +1,112 @@
+
+
+require 5;
+package Pod::Simple::TextContent;
+use strict;
+use Carp ();
+use Pod::Simple ();
+use vars qw( @ISA $VERSION );
+$VERSION = '3.13';
+@ISA = ('Pod::Simple');
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->nix_X_codes(1);
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _handle_element_start {
+ print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
+ return;
+}
+
+sub _handle_text {
+ if( chr(65) eq 'A' ) { # in ASCIIworld
+ $_[1] =~ tr/\xAD//d;
+ $_[1] =~ tr/\xA0/ /;
+ }
+ print {$_[0]{'output_fh'}} $_[1];
+ return;
+}
+
+sub _handle_element_end {
+ print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::TextContent -- get the text content of Pod
+
+=head1 SYNOPSIS
+
+ TODO
+
+ perl -MPod::Simple::TextContent -e \
+ "exit Pod::Simple::TextContent->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is that parses Pod and dumps just the text content. It is
+mainly meant for use by the Pod::Simple test suite, but you may find
+some other use for it.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TiedOutFH.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TiedOutFH.pm
new file mode 100755
index 00000000000..2899c0dbc82
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TiedOutFH.pm
@@ -0,0 +1,105 @@
+
+use strict;
+package Pod::Simple::TiedOutFH;
+use Symbol ('gensym');
+use Carp ();
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub handle_on { # some horrible frightening things are encapsulated in here
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ Carp::croak "Usage: ${class}->handle_on(\$somescalar)" unless @_;
+
+ my $x = (defined($_[0]) and ref($_[0]))
+ ? $_[0]
+ : ( \( $_[0] ) )[0]
+ ;
+ $$x = '' unless defined $$x;
+
+ #Pod::Simple::DEBUG and print "New $class handle on $x = \"$$x\"\n";
+
+ my $new = gensym();
+ tie *$new, $class, $x;
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub TIEHANDLE { # Ties to just a scalar ref
+ my($class, $scalar_ref) = @_;
+ $$scalar_ref = '' unless defined $$scalar_ref;
+ return bless \$scalar_ref, ref($class) || $class;
+}
+
+sub PRINT {
+ my $it = shift;
+ foreach my $x (@_) { $$$it .= $x }
+
+ #Pod::Simple::DEBUG > 10 and print " appended to $$it = \"$$$it\"\n";
+
+ return 1;
+}
+
+sub FETCH {
+ return ${$_[0]};
+}
+
+sub PRINTF {
+ my $it = shift;
+ my $format = shift;
+ $$$it .= sprintf $format, @_;
+ return 1;
+}
+
+sub FILENO { ${ $_[0] } + 100 } # just to produce SOME number
+
+sub CLOSE { 1 }
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1;
+__END__
+
+Chole
+
+ * 1 large red onion
+ * 2 tomatillos
+ * 4 or 5 roma tomatoes (optionally with the pulp discarded)
+ * 1 tablespoons chopped ginger root (or more, to taste)
+ * 2 tablespoons canola oil (or vegetable oil)
+
+ * 1 tablespoon garam masala
+ * 1/2 teaspoon red chili powder, or to taste
+ * Salt, to taste (probably quite a bit)
+ * 2 (15-ounce) cans chick peas or garbanzo beans, drained and rinsed
+ * juice of one smallish lime
+ * a dash of balsamic vinegar (to taste)
+ * cooked rice, preferably long-grain white rice (whether plain,
+ basmati rice, jasmine rice, or even a mild pilaf)
+
+In a blender or food processor, puree the onions, tomatoes, tomatillos,
+and ginger root. You can even do it with a Braun hand "mixer", if you
+chop things finer to start with, and work at it.
+
+In a saucepan set over moderate heat, warm the oil until hot.
+
+Add the puree and the balsamic vinegar, and cook, stirring occasionally,
+for 20 to 40 minutes. (Cooking it longer will make it sweeter.)
+
+Add the Garam Masala, chili powder, and cook, stirring occasionally, for
+5 minutes.
+
+Add the salt and chick peas and cook, stirring, until heated through.
+
+Stir in the lime juice, and optionally one or two teaspoons of tahini.
+You can let it simmer longer, depending on how much softer you want the
+garbanzos to get.
+
+Serve over rice, like a curry.
+
+Yields 5 to 7 servings.
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Transcode.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Transcode.pm
new file mode 100755
index 00000000000..80f9f1c1be6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/Transcode.pm
@@ -0,0 +1,35 @@
+
+require 5;
+package Pod::Simple::Transcode;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+BEGIN {
+ if(defined &DEBUG) {;} # Okay
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG; }
+ else { *DEBUG = sub () {0}; }
+}
+
+foreach my $class (
+ 'Pod::Simple::TranscodeSmart',
+ 'Pod::Simple::TranscodeDumb',
+ '',
+) {
+ $class or die "Couldn't load any encoding classes";
+ DEBUG and print "About to try loading $class...\n";
+ eval "require $class;";
+ if($@) {
+ DEBUG and print "Couldn't load $class: $@\n";
+ } else {
+ DEBUG and print "OK, loaded $class.\n";
+ @ISA = ($class);
+ last;
+ }
+}
+
+sub _blorp { return; } # just to avoid any "empty class" warning
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeDumb.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeDumb.pm
new file mode 100755
index 00000000000..afdc0c43a0d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeDumb.pm
@@ -0,0 +1,63 @@
+
+require 5;
+## This module is to be use()'d only by Pod::Simple::Transcode
+
+package Pod::Simple::TranscodeDumb;
+use strict;
+use vars qw($VERSION %Supported);
+$VERSION = '3.13';
+# This module basically pretends it knows how to transcode, except
+# only for null-transcodings! We use this when Encode isn't
+# available.
+
+%Supported = (
+ 'ascii' => 1,
+ 'ascii-ctrl' => 1,
+ 'iso-8859-1' => 1,
+ 'null' => 1,
+ 'latin1' => 1,
+ 'latin-1' => 1,
+ %Supported,
+);
+
+sub is_dumb {1}
+sub is_smart {0}
+
+sub all_encodings {
+ return sort keys %Supported;
+}
+
+sub encoding_is_available {
+ return exists $Supported{lc $_[1]};
+}
+
+sub encmodver {
+ return __PACKAGE__ . " v" .($VERSION || '?');
+}
+
+sub make_transcoder {
+ my($e) = $_[1];
+ die "WHAT ENCODING!?!?" unless $e;
+ my $x;
+ return sub {;
+ #foreach $x (@_) {
+ # if(Pod::Simple::ASCII and !Pod::Simple::UNICODE and $] > 5.005) {
+ # # We're in horrible gimp territory, so we need to knock out
+ # # all the highbit things
+ # $x =
+ # pack 'C*',
+ # map {; ($_ < 128) ? $_ : 0x7e }
+ # unpack "C*",
+ # $x
+ # ;
+ # }
+ #}
+ #
+ #return;
+ };
+}
+
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeSmart.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeSmart.pm
new file mode 100755
index 00000000000..d6dc62cbe82
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/TranscodeSmart.pm
@@ -0,0 +1,44 @@
+
+require 5;
+use 5.008;
+## Anything before 5.8.0 is GIMPY!
+## This module is to be use()'d only by Pod::Simple::Transcode
+
+package Pod::Simple::TranscodeSmart;
+use strict;
+use Pod::Simple;
+require Encode;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+sub is_dumb {0}
+sub is_smart {1}
+
+sub all_encodings {
+ return Encode::->encodings(':all');
+}
+
+sub encoding_is_available {
+ return Encode::resolve_alias($_[1]);
+}
+
+sub encmodver {
+ return "Encode.pm v" .($Encode::VERSION || '?');
+}
+
+sub make_transcoder {
+ my($e) = $_[1];
+ die "WHAT ENCODING!?!?" unless $e;
+ my $x;
+ return sub {
+ foreach $x (@_) {
+ $x = Encode::decode($e, $x);
+ }
+ return;
+ };
+}
+
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/XHTML.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/XHTML.pm
new file mode 100755
index 00000000000..fd4c9d6f7f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/XHTML.pm
@@ -0,0 +1,717 @@
+=pod
+
+=head1 NAME
+
+Pod::Simple::XHTML -- format Pod as validating XHTML
+
+=head1 SYNOPSIS
+
+ use Pod::Simple::XHTML;
+
+ my $parser = Pod::Simple::XHTML->new();
+
+ ...
+
+ $parser->parse_file('path/to/file.pod');
+
+=head1 DESCRIPTION
+
+This class is a formatter that takes Pod and renders it as XHTML
+validating HTML.
+
+This is a subclass of L<Pod::Simple::Methody> and inherits all its
+methods. The implementation is entirely different than
+L<Pod::Simple::HTML>, but it largely preserves the same interface.
+
+=cut
+
+package Pod::Simple::XHTML;
+use strict;
+use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
+$VERSION = '3.13';
+use Carp ();
+use Pod::Simple::Methody ();
+@ISA = ('Pod::Simple::Methody');
+
+BEGIN {
+ $HAS_HTML_ENTITIES = eval "require HTML::Entities; 1";
+}
+
+my %entities = (
+ q{>} => 'gt',
+ q{<} => 'lt',
+ q{'} => '#39',
+ q{"} => 'quot',
+ q{&} => 'amp',
+);
+
+sub encode_entities {
+ return HTML::Entities::encode_entities( $_[0] ) if $HAS_HTML_ENTITIES;
+ my $str = $_[0];
+ my $ents = join '', keys %entities;
+ $str =~ s/([$ents])/'&' . $entities{$1} . ';'/ge;
+ return $str;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+=head1 METHODS
+
+Pod::Simple::XHTML offers a number of methods that modify the format of
+the HTML output. Call these after creating the parser object, but before
+the call to C<parse_file>:
+
+ my $parser = Pod::PseudoPod::HTML->new();
+ $parser->set_optional_param("value");
+ $parser->parse_file($file);
+
+=head2 perldoc_url_prefix
+
+In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
+to put before the "Foo%3a%3aBar". The default value is
+"http://search.cpan.org/perldoc?".
+
+=head2 perldoc_url_postfix
+
+What to put after "Foo%3a%3aBar" in the URL. This option is not set by
+default.
+
+=head2 man_url_prefix
+
+In turning C<< L<crontab(5)> >> into http://whatever/man/1/crontab, what
+to put before the "1/crontab". The default value is
+"http://man.he.net/man".
+
+=head2 man_url_postfix
+
+What to put after "1/crontab" in the URL. This option is not set by default.
+
+=head2 title_prefix, title_postfix
+
+What to put before and after the title in the head. The values should
+already be &-escaped.
+
+=head2 html_css
+
+ $parser->html_css('path/to/style.css');
+
+The URL or relative path of a CSS file to include. This option is not
+set by default.
+
+=head2 html_javascript
+
+The URL or relative path of a JavaScript file to pull in. This option is
+not set by default.
+
+=head2 html_doctype
+
+A document type tag for the file. This option is not set by default.
+
+=head2 html_header_tags
+
+Additional arbitrary HTML tags for the header of the document. The
+default value is just a content type header tag:
+
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+
+Add additional meta tags here, or blocks of inline CSS or JavaScript
+(wrapped in the appropriate tags).
+
+=head2 html_h_level
+
+This is the level of HTML "Hn" element to which a Pod "head1" corresponds. For
+example, if C<html_h_level> is set to 2, a head1 will produce an H2, a head2
+will produce an H3, and so on.
+
+=head2 default_title
+
+Set a default title for the page if no title can be determined from the
+content. The value of this string should already be &-escaped.
+
+=head2 force_title
+
+Force a title for the page (don't try to determine it from the content).
+The value of this string should already be &-escaped.
+
+=head2 html_header, html_footer
+
+Set the HTML output at the beginning and end of each file. The default
+header includes a title, a doctype tag (if C<html_doctype> is set), a
+content tag (customized by C<html_header_tags>), a tag for a CSS file
+(if C<html_css> is set), and a tag for a Javascript file (if
+C<html_javascript> is set). The default footer simply closes the C<html>
+and C<body> tags.
+
+The options listed above customize parts of the default header, but
+setting C<html_header> or C<html_footer> completely overrides the
+built-in header or footer. These may be useful if you want to use
+template tags instead of literal HTML headers and footers or are
+integrating converted POD pages in a larger website.
+
+If you want no headers or footers output in the HTML, set these options
+to the empty string.
+
+=head2 index
+
+Whether to add a table-of-contents at the top of each page (called an
+index for the sake of tradition).
+
+
+=cut
+
+__PACKAGE__->_accessorize(
+ 'perldoc_url_prefix',
+ 'perldoc_url_postfix',
+ 'man_url_prefix',
+ 'man_url_postfix',
+ 'title_prefix', 'title_postfix',
+ 'html_css',
+ 'html_javascript',
+ 'html_doctype',
+ 'html_header_tags',
+ 'html_h_level',
+ 'title', # Used internally for the title extracted from the content
+ 'default_title',
+ 'force_title',
+ 'html_header',
+ 'html_footer',
+ 'index',
+ 'batch_mode', # whether we're in batch mode
+ 'batch_mode_current_level',
+ # When in batch mode, how deep the current module is: 1 for "LWP",
+ # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
+);
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+=head1 SUBCLASSING
+
+If the standard options aren't enough, you may want to subclass
+Pod::Simple::XHMTL. These are the most likely candidates for methods
+you'll want to override when subclassing.
+
+=cut
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->perldoc_url_prefix('http://search.cpan.org/perldoc?');
+ $new->man_url_prefix('http://man.he.net/man');
+ $new->html_header_tags('<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />');
+ $new->nix_X_codes(1);
+ $new->codes_in_verbatim(1);
+ $new->{'scratch'} = '';
+ $new->{'to_index'} = [];
+ $new->{'output'} = [];
+ $new->{'saved'} = [];
+ $new->{'ids'} = {};
+
+ $new->{'__region_targets'} = [];
+ $new->{'__literal_targets'} = {};
+ $new->accept_targets_as_html( 'html', 'HTML' );
+
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+=head2 handle_text
+
+This method handles the body of text within any element: it's the body
+of a paragraph, or everything between a "=begin" tag and the
+corresponding "=end" tag, or the text within an L entity, etc. You would
+want to override this if you are adding a custom element type that does
+more than just display formatted text. Perhaps adding a way to generate
+HTML tables from an extended version of POD.
+
+So, let's say you want add a custom element called 'foo'. In your
+subclass's C<new> method, after calling C<SUPER::new> you'd call:
+
+ $new->accept_targets_as_text( 'foo' );
+
+Then override the C<start_for> method in the subclass to check for when
+"$flags->{'target'}" is equal to 'foo' and set a flag that marks that
+you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the
+C<handle_text> method to check for the flag, and pass $text to your
+custom subroutine to construct the HTML output for 'foo' elements,
+something like:
+
+ sub handle_text {
+ my ($self, $text) = @_;
+ if ($self->{'in_foo'}) {
+ $self->{'scratch'} .= build_foo_html($text);
+ } else {
+ $self->{'scratch'} .= $text;
+ }
+ }
+
+=head2 accept_targets_as_html
+
+This method behaves like C<accept_targets_as_text>, but also marks the region
+as one whose content should be emitted literally, without HTML entity escaping
+or wrapping in a C<div> element.
+
+=cut
+
+sub __in_literal_xhtml_region {
+ return unless @{ $_[0]{__region_targets} };
+ my $target = $_[0]{__region_targets}[-1];
+ return $_[0]{__literal_targets}{ $target };
+}
+
+sub accept_targets_as_html {
+ my ($self, @targets) = @_;
+ $self->accept_targets(@targets);
+ $self->{__literal_targets}{$_} = 1 for @targets;
+}
+
+sub handle_text {
+ # escape special characters in HTML (<, >, &, etc)
+ $_[0]{'scratch'} .= $_[0]->__in_literal_xhtml_region
+ ? $_[1]
+ : encode_entities( $_[1] );
+}
+
+sub start_Para { $_[0]{'scratch'} = '<p>' }
+sub start_Verbatim { $_[0]{'scratch'} = '<pre><code>' }
+
+sub start_head1 { $_[0]{'in_head'} = 1 }
+sub start_head2 { $_[0]{'in_head'} = 2 }
+sub start_head3 { $_[0]{'in_head'} = 3 }
+sub start_head4 { $_[0]{'in_head'} = 4 }
+
+sub start_item_number {
+ $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '<li><p>';
+ $_[0]{'in_li'} = 1
+}
+
+sub start_item_bullet {
+ $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '<li><p>';
+ $_[0]{'in_li'} = 1
+}
+
+sub start_item_text {
+ if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
+ $_[0]{'scratch'} = "</dd>\n";
+ $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
+ }
+ $_[0]{'scratch'} .= '<dt>';
+}
+
+sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
+sub start_over_block { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
+sub start_over_number { $_[0]{'scratch'} = '<ol>'; $_[0]->emit }
+sub start_over_text {
+ $_[0]{'scratch'} = '<dl>';
+ $_[0]{'dl_level'}++;
+ $_[0]{'in_dd'} ||= [];
+ $_[0]->emit
+}
+
+sub end_over_block { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit }
+
+sub end_over_number {
+ $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '</ol>';
+ $_[0]->emit;
+}
+
+sub end_over_bullet {
+ $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '</ul>';
+ $_[0]->emit;
+}
+
+sub end_over_text {
+ if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
+ $_[0]{'scratch'} = "</dd>\n";
+ $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
+ }
+ $_[0]{'scratch'} .= '</dl>';
+ $_[0]{'dl_level'}--;
+ $_[0]->emit;
+}
+
+# . . . . . Now the actual formatters:
+
+sub end_Para { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
+sub end_Verbatim {
+ $_[0]{'scratch'} .= '</code></pre>';
+ $_[0]->emit;
+}
+
+sub _end_head {
+ my $h = delete $_[0]{in_head};
+
+ my $add = $_[0]->html_h_level;
+ $add = 1 unless defined $add;
+ $h += $add - 1;
+
+ my $id = $_[0]->idify($_[0]{scratch});
+ my $text = $_[0]{scratch};
+ $_[0]{'scratch'} = qq{<h$h id="$id">$text</h$h>};
+ $_[0]->emit;
+ push @{ $_[0]{'to_index'} }, [$h, $id, $text];
+}
+
+sub end_head1 { shift->_end_head(@_); }
+sub end_head2 { shift->_end_head(@_); }
+sub end_head3 { shift->_end_head(@_); }
+sub end_head4 { shift->_end_head(@_); }
+
+sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
+sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
+
+sub end_item_text {
+ $_[0]{'scratch'} .= "</dt>\n<dd>";
+ $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
+ $_[0]->emit;
+}
+
+# This handles =begin and =for blocks of all kinds.
+sub start_for {
+ my ($self, $flags) = @_;
+
+ push @{ $self->{__region_targets} }, $flags->{target_matching};
+
+ unless ($self->__in_literal_xhtml_region) {
+ $self->{scratch} .= '<div';
+ $self->{scratch} .= qq( class="$flags->{target}") if $flags->{target};
+ $self->{scratch} .= '>';
+ }
+
+ $self->emit;
+
+}
+sub end_for {
+ my ($self) = @_;
+
+ $self->{'scratch'} .= '</div>' unless $self->__in_literal_xhtml_region;
+
+ pop @{ $self->{__region_targets} };
+ $self->emit;
+}
+
+sub start_Document {
+ my ($self) = @_;
+ if (defined $self->html_header) {
+ $self->{'scratch'} .= $self->html_header;
+ $self->emit unless $self->html_header eq "";
+ } else {
+ my ($doctype, $title, $metatags);
+ $doctype = $self->html_doctype || '';
+ $title = $self->force_title || $self->title || $self->default_title || '';
+ $metatags = $self->html_header_tags || '';
+ if ($self->html_css) {
+ $metatags .= "\n<link rel='stylesheet' href='" .
+ $self->html_css . "' type='text/css'>";
+ }
+ if ($self->html_javascript) {
+ $metatags .= "\n<script type='text/javascript' src='" .
+ $self->html_javascript . "'></script>";
+ }
+ $self->{'scratch'} .= <<"HTML";
+$doctype
+<html>
+<head>
+<title>$title</title>
+$metatags
+</head>
+<body>
+HTML
+ $self->emit;
+ }
+}
+
+sub end_Document {
+ my ($self) = @_;
+ my $to_index = $self->{'to_index'};
+ if ($self->index && @{ $to_index } ) {
+ my @out;
+ my $level = 0;
+ my $indent = -1;
+ my $space = '';
+ my $id = ' id="index"';
+
+ for my $h (@{ $to_index }, [0]) {
+ my $target_level = $h->[0];
+ # Get to target_level by opening or closing ULs
+ if ($level == $target_level) {
+ $out[-1] .= '</li>';
+ } elsif ($level > $target_level) {
+ $out[-1] .= '</li>' if $out[-1] =~ /^\s+<li>/;
+ while ($level > $target_level) {
+ --$level;
+ push @out, (' ' x --$indent) . '</li>' if @out && $out[-1] =~ m{^\s+<\/ul};
+ push @out, (' ' x --$indent) . '</ul>';
+ }
+ push @out, (' ' x --$indent) . '</li>' if $level;
+ } else {
+ while ($level < $target_level) {
+ ++$level;
+ push @out, (' ' x ++$indent) . '<li>' if @out && $out[-1]=~ /^\s*<ul/;
+ push @out, (' ' x ++$indent) . "<ul$id>";
+ $id = '';
+ }
+ ++$indent;
+ }
+
+ next unless $level;
+ $space = ' ' x $indent;
+ push @out, sprintf '%s<li><a href="#%s">%s</a>',
+ $space, $h->[1], $h->[2];
+ }
+ # Splice the index in between the HTML headers and the first element.
+ my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
+ splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
+ }
+
+ if (defined $self->html_footer) {
+ $self->{'scratch'} .= $self->html_footer;
+ $self->emit unless $self->html_footer eq "";
+ } else {
+ $self->{'scratch'} .= "</body>\n</html>";
+ $self->emit;
+ }
+
+ if ($self->index) {
+ print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
+ @{$self->{'output'}} = ();
+ }
+
+}
+
+# Handling code tags
+sub start_B { $_[0]{'scratch'} .= '<b>' }
+sub end_B { $_[0]{'scratch'} .= '</b>' }
+
+sub start_C { $_[0]{'scratch'} .= '<code>' }
+sub end_C { $_[0]{'scratch'} .= '</code>' }
+
+sub start_F { $_[0]{'scratch'} .= '<i>' }
+sub end_F { $_[0]{'scratch'} .= '</i>' }
+
+sub start_I { $_[0]{'scratch'} .= '<i>' }
+sub end_I { $_[0]{'scratch'} .= '</i>' }
+
+sub start_L {
+ my ($self, $flags) = @_;
+ my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
+ my $url = $type eq 'url' ? $to
+ : $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
+ : $type eq 'man' ? $self->resolve_man_page_link($to, $section)
+ : undef;
+
+ # If it's an unknown type, use an attribute-less <a> like HTML.pm.
+ $self->{'scratch'} .= '<a' . ($url ? ' href="'. $url . '">' : '>');
+}
+
+sub end_L { $_[0]{'scratch'} .= '</a>' }
+
+sub start_S { $_[0]{'scratch'} .= '<nobr>' }
+sub end_S { $_[0]{'scratch'} .= '</nobr>' }
+
+sub emit {
+ my($self) = @_;
+ if ($self->index) {
+ push @{ $self->{'output'} }, $self->{'scratch'};
+ } else {
+ print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
+ }
+ $self->{'scratch'} = '';
+ return;
+}
+
+=head2 resolve_pod_page_link
+
+ my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
+ my $url = $pod->resolve_pod_page_link('perlpodspec');
+ my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
+
+Resolves a POD link target (typically a module or POD file name) and section
+name to a URL. The resulting link will be returned for the above examples as:
+
+ http://search.cpan.org/perldoc?Net::Ping#INSTALL
+ http://search.cpan.org/perldoc?perlpodspec
+ #SYNOPSIS
+
+Note that when there is only a section argument the URL will simply be a link
+to a section in the current document.
+
+=cut
+
+sub resolve_pod_page_link {
+ my ($self, $to, $section) = @_;
+ return undef unless defined $to || defined $section;
+ if (defined $section) {
+ $section = '#' . $self->idify($section, 1);
+ return $section unless defined $to;
+ } else {
+ $section = ''
+ }
+
+ return ($self->perldoc_url_prefix || '')
+ . encode_entities($to) . $section
+ . ($self->perldoc_url_postfix || '');
+}
+
+=head2 resolve_man_page_link
+
+ my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
+ my $url = $pod->resolve_man_page_link('crontab');
+
+Resolves a man page link target and numeric section to a URL. The resulting
+link will be returned for the above examples as:
+
+ http://man.he.net/man5/crontab
+ http://man.he.net/man1/crontab
+
+Note that the first argument is required. The section number will be parsed
+from it, and if it's missing will default to 1. The second argument is
+currently ignored, as L<man.he.net|http://man.he.net> does not currently
+include linkable IDs or anchor names in its pages. Subclass to link to a
+different man page HTTP server.
+
+=cut
+
+sub resolve_man_page_link {
+ my ($self, $to, $section) = @_;
+ return undef unless defined $to;
+ my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
+ return undef unless $page;
+ return ($self->man_url_prefix || '')
+ . ($part || 1) . "/" . encode_entities($page)
+ . ($self->man_url_postfix || '');
+
+}
+
+=head2 idify
+
+ my $id = $pod->idify($text);
+ my $hash = $pod->idify($text, 1);
+
+This method turns an arbitrary string into a valid XHTML ID attribute value.
+The rules enforced, following
+L<http://webdesign.about.com/od/htmltags/a/aa031707.htm>, are:
+
+=over
+
+=item *
+
+The id must start with a letter (a-z or A-Z)
+
+=item *
+
+All subsequent characters can be letters, numbers (0-9), hyphens (-),
+underscores (_), colons (:), and periods (.).
+
+=item *
+
+Each id must be unique within the document.
+
+=back
+
+In addition, the returned value will be unique within the context of the
+Pod::Simple::XHTML object unless a second argument is passed a true value. ID
+attributes should always be unique within a single XHTML document, but pass
+the true value if you are creating not an ID but a URL hash to point to
+an ID (i.e., if you need to put the "#foo" in C<< <a href="#foo">foo</a> >>.
+
+=cut
+
+sub idify {
+ my ($self, $t, $not_unique) = @_;
+ for ($t) {
+ s/<[^>]+>//g; # Strip HTML.
+ s/&[^;]+;//g; # Strip entities.
+ s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
+ s/^[^a-zA-Z]+//; # First char must be a letter.
+ s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
+ }
+ return $t if $not_unique;
+ my $i = '';
+ $i++ while $self->{ids}{"$t$i"}++;
+ return "$t$i";
+}
+
+=head2 batch_mode_page_object_init
+
+ $pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
+
+Called by L<Pod::Simple::HTMLBatch> so that the class has a chance to
+initialize the converter. Internally it sets the C<batch_mode> property to
+true and sets C<batch_mode_current_level()>, but Pod::Simple::XHTML does not
+currently use those features. Subclasses might, though.
+
+=cut
+
+sub batch_mode_page_object_init {
+ my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
+ $self->batch_mode(1);
+ $self->batch_mode_current_level($depth);
+ return $self;
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2003-2005 Allison Randal.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to L<Hurricane Electrict|http://he.net/> for permission to use its
+L<Linux man pages online|http://man.he.net/> site for man page links.
+
+Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
+site for Perl module links.
+
+=head1 AUTHOR
+
+Pod::Simpele::XHTML was created by Allison Randal <allison@perl.org>.
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Simple/XMLOutStream.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/XMLOutStream.pm
new file mode 100755
index 00000000000..afe30cec2b7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Simple/XMLOutStream.pm
@@ -0,0 +1,185 @@
+
+require 5;
+package Pod::Simple::XMLOutStream;
+use strict;
+use Carp ();
+use Pod::Simple ();
+use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
+$VERSION = '3.13';
+BEGIN {
+ @ISA = ('Pod::Simple');
+ *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
+}
+
+$ATTR_PAD = "\n" unless defined $ATTR_PAD;
+ # Don't mess with this unless you know what you're doing.
+
+$SORT_ATTRS = 0 unless defined $SORT_ATTRS;
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ #$new->accept_codes('VerbatimFormatted');
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _handle_element_start {
+ # ($self, $element_name, $attr_hash_r)
+ my $fh = $_[0]{'output_fh'};
+ my($key, $value);
+ DEBUG and print "++ $_[1]\n";
+ print $fh "<", $_[1];
+ if($SORT_ATTRS) {
+ foreach my $key (sort keys %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _xml_escape($value = $_[2]{$key});
+ print $fh $ATTR_PAD, $key, '="', $value, '"';
+ }
+ }
+ } else { # faster
+ while(($key,$value) = each %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _xml_escape($value);
+ print $fh $ATTR_PAD, $key, '="', $value, '"';
+ }
+ }
+ }
+ print $fh ">";
+ return;
+}
+
+sub _handle_text {
+ DEBUG and print "== \"$_[1]\"\n";
+ if(length $_[1]) {
+ my $text = $_[1];
+ _xml_escape($text);
+ print {$_[0]{'output_fh'}} $text;
+ }
+ return;
+}
+
+sub _handle_element_end {
+ DEBUG and print "-- $_[1]\n";
+ print {$_[0]{'output_fh'}} "</", $_[1], ">";
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _xml_escape {
+ foreach my $x (@_) {
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done about that.
+ }
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::XMLOutStream -- turn Pod into XML
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::XMLOutStream -e \
+ "exit Pod::Simple::XMLOutStream->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+Pod::Simple::XMLOutStream is a subclass of L<Pod::Simple> that parses
+Pod and turns it into XML.
+
+Pod::Simple::XMLOutStream inherits methods from
+L<Pod::Simple>.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple::DumpAsXML> is rather like this class; see its
+documentation for a discussion of the differences.
+
+L<Pod::Simple>, L<Pod::Simple::DumpAsXML>, L<Pod::SAX>
+
+L<Pod::Simple::Subclassing>
+
+The older (and possibly obsolete) libraries L<Pod::PXML>, L<Pod::XML>
+
+
+=head1 ABOUT EXTENDING POD
+
+TODO: An example or two of =extend, then point to Pod::Simple::Subclassing
+
+
+=head1 ASK ME!
+
+If you actually want to use Pod as a format that you want to render to
+XML (particularly if to an XML instance with more elements than normal
+Pod has), please email me (C<sburke@cpan.org>) and I'll probably have
+some recommendations.
+
+For reasons of concision and energetic laziness, some methods and
+options in this module (and the dozen modules it depends on) are
+undocumented; but one of those undocumented bits might be just what
+you're looking for.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
+
+=head1 SUPPORT
+
+Questions or discussion about POD and Pod::Simple should be sent to the
+pod-people@perl.org mail list. Send an empty email to
+pod-people-subscribe@perl.org to subscribe.
+
+This module is managed in an open GitHub repository,
+L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/pod-simple.git> and send patches!
+
+Patches against Pod::Simple are welcome. Please send bug reports to
+<bug-pod-simple@rt.cpan.org>.
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2002-2004 Sean M. Burke.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
+But don't bother him, he's retired.
+
+Pod::Simple is maintained by:
+
+=over
+
+=item * Allison Randal C<allison@perl.org>
+
+=item * Hans Dieter Pearcey C<hdp@cpan.org>
+
+=item * David E. Wheeler C<dwheeler@cpan.org>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Text.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Text.pm
new file mode 100755
index 00000000000..c68313c3898
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Text.pm
@@ -0,0 +1,878 @@
+# Pod::Text -- Convert POD data to formatted ASCII text.
+#
+# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009
+# Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This module converts POD to formatted text. It replaces the old Pod::Text
+# module that came with versions of Perl prior to 5.6.0 and attempts to match
+# its output except for some specific circumstances where other decisions
+# seemed to produce better output. It uses Pod::Parser and is designed to be
+# very easy to subclass.
+#
+# Perl core hackers, please note that this module is also separately
+# maintained outside of the Perl core as part of the podlators. Please send
+# me any patches at the address above in addition to sending them to the
+# standard Perl mailing lists.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::Text;
+
+require 5.004;
+
+use strict;
+use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
+
+use Carp qw(carp croak);
+use Exporter ();
+use Pod::Simple ();
+
+@ISA = qw(Pod::Simple Exporter);
+
+# We have to export pod2text for backward compatibility.
+@EXPORT = qw(pod2text);
+
+$VERSION = '3.14';
+
+##############################################################################
+# Initialization
+##############################################################################
+
+# This function handles code blocks. It's registered as a callback to
+# Pod::Simple and therefore doesn't work as a regular method call, but all it
+# does is call output_code with the line.
+sub handle_code {
+ my ($line, $number, $parser) = @_;
+ $parser->output_code ($line . "\n");
+}
+
+# Initialize the object and set various Pod::Simple options that we need.
+# Here, we also process any additional options passed to the constructor or
+# set up defaults if none were given. Note that all internal object keys are
+# in all-caps, reserving all lower-case object keys for Pod::Simple and user
+# arguments.
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+
+ # Tell Pod::Simple to handle S<> by automatically inserting &nbsp;.
+ $self->nbsp_for_S (1);
+
+ # Tell Pod::Simple to keep whitespace whenever possible.
+ if ($self->can ('preserve_whitespace')) {
+ $self->preserve_whitespace (1);
+ } else {
+ $self->fullstop_space_harden (1);
+ }
+
+ # The =for and =begin targets that we accept.
+ $self->accept_targets (qw/text TEXT/);
+
+ # Ensure that contiguous blocks of code are merged together. Otherwise,
+ # some of the guesswork heuristics don't work right.
+ $self->merge_text (1);
+
+ # Pod::Simple doesn't do anything useful with our arguments, but we want
+ # to put them in our object as hash keys and values. This could cause
+ # problems if we ever clash with Pod::Simple's own internal class
+ # variables.
+ my %opts = @_;
+ my @opts = map { ("opt_$_", $opts{$_}) } keys %opts;
+ %$self = (%$self, @opts);
+
+ # Send errors to stderr if requested.
+ if ($$self{opt_stderr}) {
+ $self->no_errata_section (1);
+ $self->complain_stderr (1);
+ delete $$self{opt_stderr};
+ }
+
+ # Initialize various things from our parameters.
+ $$self{opt_alt} = 0 unless defined $$self{opt_alt};
+ $$self{opt_indent} = 4 unless defined $$self{opt_indent};
+ $$self{opt_margin} = 0 unless defined $$self{opt_margin};
+ $$self{opt_loose} = 0 unless defined $$self{opt_loose};
+ $$self{opt_sentence} = 0 unless defined $$self{opt_sentence};
+ $$self{opt_width} = 76 unless defined $$self{opt_width};
+
+ # Figure out what quotes we'll be using for C<> text.
+ $$self{opt_quotes} ||= '"';
+ if ($$self{opt_quotes} eq 'none') {
+ $$self{LQUOTE} = $$self{RQUOTE} = '';
+ } elsif (length ($$self{opt_quotes}) == 1) {
+ $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes};
+ } elsif ($$self{opt_quotes} =~ /^(.)(.)$/
+ || $$self{opt_quotes} =~ /^(..)(..)$/) {
+ $$self{LQUOTE} = $1;
+ $$self{RQUOTE} = $2;
+ } else {
+ croak qq(Invalid quote specification "$$self{opt_quotes}");
+ }
+
+ # If requested, do something with the non-POD text.
+ $self->code_handler (\&handle_code) if $$self{opt_code};
+
+ # Return the created object.
+ return $self;
+}
+
+##############################################################################
+# Core parsing
+##############################################################################
+
+# This is the glue that connects the code below with Pod::Simple itself. The
+# goal is to convert the event stream coming from the POD parser into method
+# calls to handlers once the complete content of a tag has been seen. Each
+# paragraph or POD command will have textual content associated with it, and
+# as soon as all of a paragraph or POD command has been seen, that content
+# will be passed in to the corresponding method for handling that type of
+# object. The exceptions are handlers for lists, which have opening tag
+# handlers and closing tag handlers that will be called right away.
+#
+# The internal hash key PENDING is used to store the contents of a tag until
+# all of it has been seen. It holds a stack of open tags, each one
+# represented by a tuple of the attributes hash for the tag and the contents
+# of the tag.
+
+# Add a block of text to the contents of the current node, formatting it
+# according to the current formatting instructions as we do.
+sub _handle_text {
+ my ($self, $text) = @_;
+ my $tag = $$self{PENDING}[-1];
+ $$tag[1] .= $text;
+}
+
+# Given an element name, get the corresponding method name.
+sub method_for_element {
+ my ($self, $element) = @_;
+ $element =~ tr/-/_/;
+ $element =~ tr/A-Z/a-z/;
+ $element =~ tr/_a-z0-9//cd;
+ return $element;
+}
+
+# Handle the start of a new element. If cmd_element is defined, assume that
+# we need to collect the entire tree for this element before passing it to the
+# element method, and create a new tree into which we'll collect blocks of
+# text and nested elements. Otherwise, if start_element is defined, call it.
+sub _handle_element_start {
+ my ($self, $element, $attrs) = @_;
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, we need to accumulate the contents of the
+ # tag before calling it.
+ if ($self->can ("cmd_$method")) {
+ push (@{ $$self{PENDING} }, [ $attrs, '' ]);
+ } elsif ($self->can ("start_$method")) {
+ my $method = 'start_' . $method;
+ $self->$method ($attrs, '');
+ }
+}
+
+# Handle the end of an element. If we had a cmd_ method for this element,
+# this is where we pass along the text that we've accumulated. Otherwise, if
+# we have an end_ method for the element, call that.
+sub _handle_element_end {
+ my ($self, $element) = @_;
+ my $method = $self->method_for_element ($element);
+
+ # If we have a command handler, pull off the pending text and pass it to
+ # the handler along with the saved attribute hash.
+ if ($self->can ("cmd_$method")) {
+ my $tag = pop @{ $$self{PENDING} };
+ my $method = 'cmd_' . $method;
+ my $text = $self->$method (@$tag);
+ if (defined $text) {
+ if (@{ $$self{PENDING} } > 1) {
+ $$self{PENDING}[-1][1] .= $text;
+ } else {
+ $self->output ($text);
+ }
+ }
+ } elsif ($self->can ("end_$method")) {
+ my $method = 'end_' . $method;
+ $self->$method ();
+ }
+}
+
+##############################################################################
+# Output formatting
+##############################################################################
+
+# Wrap a line, indenting by the current left margin. We can't use Text::Wrap
+# because it plays games with tabs. We can't use formline, even though we'd
+# really like to, because it screws up non-printing characters. So we have to
+# do the wrapping ourselves.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{opt_width} - $$self{MARGIN};
+ while (length > $width) {
+ if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ return $output;
+}
+
+# Reformat a paragraph of text for the current margin. Takes the text to
+# reformat and returns the formatted text.
+sub reformat {
+ my $self = shift;
+ local $_ = shift;
+
+ # If we're trying to preserve two spaces after sentences, do some munging
+ # to support that. Otherwise, smash all repeated whitespace.
+ if ($$self{opt_sentence}) {
+ s/ +$//mg;
+ s/\.\n/. \n/g;
+ s/\n/ /g;
+ s/ +/ /g;
+ } else {
+ s/\s+/ /g;
+ }
+ return $self->wrap ($_);
+}
+
+# Output text to the output device. Replace non-breaking spaces with spaces
+# and soft hyphens with nothing, and then try to fix the output encoding if
+# necessary to match the input encoding unless UTF-8 output is forced. This
+# preserves the traditional pass-through behavior of Pod::Text.
+sub output {
+ my ($self, $text) = @_;
+ $text =~ tr/\240\255/ /d;
+ unless ($$self{opt_utf8} || $$self{CHECKED_ENCODING}) {
+ my $encoding = $$self{encoding} || '';
+ if ($encoding) {
+ eval { binmode ($$self{output_fh}, ":encoding($encoding)") };
+ }
+ $$self{CHECKED_ENCODING} = 1;
+ }
+ print { $$self{output_fh} } $text;
+}
+
+# Output a block of code (something that isn't part of the POD text). Called
+# by preprocess_paragraph only if we were given the code option. Exists here
+# only so that it can be overridden by subclasses.
+sub output_code { $_[0]->output ($_[1]) }
+
+##############################################################################
+# Document initialization
+##############################################################################
+
+# Set up various things that have to be initialized on a per-document basis.
+sub start_document {
+ my $self = shift;
+ my $margin = $$self{opt_indent} + $$self{opt_margin};
+
+ # Initialize a few per-document variables.
+ $$self{INDENTS} = []; # Stack of indentations.
+ $$self{MARGIN} = $margin; # Default left margin.
+ $$self{PENDING} = [[]]; # Pending output.
+
+ # We have to redo encoding handling for each document.
+ delete $$self{CHECKED_ENCODING};
+
+ # If we were given the utf8 option, set an output encoding on our file
+ # handle. Wrap in an eval in case we're using a version of Perl too old
+ # to understand this.
+ #
+ # This is evil because it changes the global state of a file handle that
+ # we may not own. However, we can't just blindly encode all output, since
+ # there may be a pre-applied output encoding (such as from PERL_UNICODE)
+ # and then we would double-encode. This seems to be the least bad
+ # approach.
+ if ($$self{opt_utf8}) {
+ eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') };
+ }
+
+ return '';
+}
+
+##############################################################################
+# Text blocks
+##############################################################################
+
+# Intended for subclasses to override, this method returns text with any
+# non-printing formatting codes stripped out so that length() correctly
+# returns the length of the text. For basic Pod::Text, it does nothing.
+sub strip_format {
+ my ($self, $string) = @_;
+ return $string;
+}
+
+# This method is called whenever an =item command is complete (in other words,
+# we've seen its associated paragraph or know for certain that it doesn't have
+# one). It gets the paragraph associated with the item as an argument. If
+# that argument is empty, just output the item tag; if it contains a newline,
+# output the item tag followed by the newline. Otherwise, see if there's
+# enough room for us to output the item tag in the margin of the text or if we
+# have to put it on a separate line.
+sub item {
+ my ($self, $text) = @_;
+ my $tag = $$self{ITEM};
+ unless (defined $tag) {
+ carp "Item called without tag";
+ return;
+ }
+ undef $$self{ITEM};
+
+ # Calculate the indentation and margin. $fits is set to true if the tag
+ # will fit into the margin of the paragraph given our indentation level.
+ my $indent = $$self{INDENTS}[-1];
+ $indent = $$self{opt_indent} unless defined $indent;
+ my $margin = ' ' x $$self{opt_margin};
+ my $tag_length = length ($self->strip_format ($tag));
+ my $fits = ($$self{MARGIN} - $indent >= $tag_length + 1);
+
+ # If the tag doesn't fit, or if we have no associated text, print out the
+ # tag separately. Otherwise, put the tag in the margin of the paragraph.
+ if (!$text || $text =~ /^\s+$/ || !$fits) {
+ my $realindent = $$self{MARGIN};
+ $$self{MARGIN} = $indent;
+ my $output = $self->reformat ($tag);
+ $output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
+ $output =~ s/\n*$/\n/;
+
+ # If the text is just whitespace, we have an empty item paragraph;
+ # this can result from =over/=item/=back without any intermixed
+ # paragraphs. Insert some whitespace to keep the =item from merging
+ # into the next paragraph.
+ $output .= "\n" if $text && $text =~ /^\s*$/;
+
+ $self->output ($output);
+ $$self{MARGIN} = $realindent;
+ $self->output ($self->reformat ($text)) if ($text && $text =~ /\S/);
+ } else {
+ my $space = ' ' x $indent;
+ $space =~ s/^$margin /$margin:/ if $$self{opt_alt};
+ $text = $self->reformat ($text);
+ $text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
+ my $tagspace = ' ' x $tag_length;
+ $text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item";
+ $self->output ($text);
+ }
+}
+
+# Handle a basic block of text. The only tricky thing here is that if there
+# is a pending item tag, we need to format this as an item paragraph.
+sub cmd_para {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$/\n/;
+ if (defined $$self{ITEM}) {
+ $self->item ($text . "\n");
+ } else {
+ $self->output ($self->reformat ($text . "\n"));
+ }
+ return '';
+}
+
+# Handle a verbatim paragraph. Just print it out, but indent it according to
+# our margin.
+sub cmd_verbatim {
+ my ($self, $attrs, $text) = @_;
+ $self->item if defined $$self{ITEM};
+ return if $text =~ /^\s*$/;
+ $text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme;
+ $text =~ s/\s*$/\n\n/;
+ $self->output ($text);
+ return '';
+}
+
+# Handle literal text (produced by =for and similar constructs). Just output
+# it with the minimum of changes.
+sub cmd_data {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/^\n+//;
+ $text =~ s/\n{0,2}$/\n/;
+ $self->output ($text);
+ return '';
+}
+
+##############################################################################
+# Headings
+##############################################################################
+
+# The common code for handling all headers. Takes the header text, the
+# indentation, and the surrounding marker for the alt formatting method.
+sub heading {
+ my ($self, $text, $indent, $marker) = @_;
+ $self->item ("\n\n") if defined $$self{ITEM};
+ $text =~ s/\s+$//;
+ if ($$self{opt_alt}) {
+ my $closemark = reverse (split (//, $marker));
+ my $margin = ' ' x $$self{opt_margin};
+ $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n");
+ } else {
+ $text .= "\n" if $$self{opt_loose};
+ my $margin = ' ' x ($$self{opt_margin} + $indent);
+ $self->output ($margin . $text . "\n");
+ }
+ return '';
+}
+
+# First level heading.
+sub cmd_head1 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, 0, '====');
+}
+
+# Second level heading.
+sub cmd_head2 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, $$self{opt_indent} / 2, '== ');
+}
+
+# Third level heading.
+sub cmd_head3 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '= ');
+}
+
+# Fourth level heading.
+sub cmd_head4 {
+ my ($self, $attrs, $text) = @_;
+ $self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '- ');
+}
+
+##############################################################################
+# List handling
+##############################################################################
+
+# Handle the beginning of an =over block. Takes the type of the block as the
+# first argument, and then the attr hash. This is called by the handlers for
+# the four different types of lists (bullet, number, text, and block).
+sub over_common_start {
+ my ($self, $attrs) = @_;
+ $self->item ("\n\n") if defined $$self{ITEM};
+
+ # Find the indentation level.
+ my $indent = $$attrs{indent};
+ unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) {
+ $indent = $$self{opt_indent};
+ }
+
+ # Add this to our stack of indents and increase our current margin.
+ push (@{ $$self{INDENTS} }, $$self{MARGIN});
+ $$self{MARGIN} += ($indent + 0);
+ return '';
+}
+
+# End an =over block. Takes no options other than the class pointer. Output
+# any pending items and then pop one level of indentation.
+sub over_common_end {
+ my ($self) = @_;
+ $self->item ("\n\n") if defined $$self{ITEM};
+ $$self{MARGIN} = pop @{ $$self{INDENTS} };
+ return '';
+}
+
+# Dispatch the start and end calls as appropriate.
+sub start_over_bullet { $_[0]->over_common_start ($_[1]) }
+sub start_over_number { $_[0]->over_common_start ($_[1]) }
+sub start_over_text { $_[0]->over_common_start ($_[1]) }
+sub start_over_block { $_[0]->over_common_start ($_[1]) }
+sub end_over_bullet { $_[0]->over_common_end }
+sub end_over_number { $_[0]->over_common_end }
+sub end_over_text { $_[0]->over_common_end }
+sub end_over_block { $_[0]->over_common_end }
+
+# The common handler for all item commands. Takes the type of the item, the
+# attributes, and then the text of the item.
+sub item_common {
+ my ($self, $type, $attrs, $text) = @_;
+ $self->item if defined $$self{ITEM};
+
+ # Clean up the text. We want to end up with two variables, one ($text)
+ # which contains any body text after taking out the item portion, and
+ # another ($item) which contains the actual item text. Note the use of
+ # the internal Pod::Simple attribute here; that's a potential land mine.
+ $text =~ s/\s+$//;
+ my ($item, $index);
+ if ($type eq 'bullet') {
+ $item = '*';
+ } elsif ($type eq 'number') {
+ $item = $$attrs{'~orig_content'};
+ } else {
+ $item = $text;
+ $item =~ s/\s*\n\s*/ /g;
+ $text = '';
+ }
+ $$self{ITEM} = $item;
+
+ # If body text for this item was included, go ahead and output that now.
+ if ($text) {
+ $text =~ s/\s*$/\n/;
+ $self->item ($text);
+ }
+ return '';
+}
+
+# Dispatch the item commands to the appropriate place.
+sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
+sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
+sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
+sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
+
+##############################################################################
+# Formatting codes
+##############################################################################
+
+# The simple ones.
+sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] }
+sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] }
+sub cmd_i { return '*' . $_[2] . '*' }
+sub cmd_x { return '' }
+
+# Apply a whole bunch of messy heuristics to not quote things that don't
+# benefit from being quoted. These originally come from Barrie Slaymaker and
+# largely duplicate code in Pod::Man.
+sub cmd_c {
+ my ($self, $attrs, $text) = @_;
+
+ # A regex that matches the portion of a variable reference that's the
+ # array or hash index, separated out just because we want to use it in
+ # several places in the following regex.
+ my $index = '(?: \[.*\] | \{.*\} )?';
+
+ # Check for things that we don't want to quote, and if we find any of
+ # them, return the string with just a font change and no quoting.
+ $text =~ m{
+ ^\s*
+ (?:
+ ( [\'\`\"] ) .* \1 # already quoted
+ | \` .* \' # `quoted'
+ | \$+ [\#^]? \S $index # special ($^Foo, $")
+ | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
+ | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
+ | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number
+ | 0x [a-fA-F\d]+ # a hex constant
+ )
+ \s*\z
+ }xo && return $text;
+
+ # If we didn't return, go ahead and quote the text.
+ return $$self{opt_alt}
+ ? "``$text''"
+ : "$$self{LQUOTE}$text$$self{RQUOTE}";
+}
+
+# Links reduce to the text that we're given, wrapped in angle brackets if it's
+# a URL.
+sub cmd_l {
+ my ($self, $attrs, $text) = @_;
+ if ($$attrs{type} eq 'url') {
+ if (not defined($$attrs{to}) or $$attrs{to} eq $text) {
+ return "<$text>";
+ } else {
+ return "$text <$$attrs{to}>";
+ }
+ } else {
+ return $text;
+ }
+}
+
+##############################################################################
+# Backwards compatibility
+##############################################################################
+
+# The old Pod::Text module did everything in a pod2text() function. This
+# tries to provide the same interface for legacy applications.
+sub pod2text {
+ my @args;
+
+ # This is really ugly; I hate doing option parsing in the middle of a
+ # module. But the old Pod::Text module supported passing flags to its
+ # entry function, so handle -a and -<number>.
+ while ($_[0] =~ /^-/) {
+ my $flag = shift;
+ if ($flag eq '-a') { push (@args, alt => 1) }
+ elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
+ else {
+ unshift (@_, $flag);
+ last;
+ }
+ }
+
+ # Now that we know what arguments we're using, create the parser.
+ my $parser = Pod::Text->new (@args);
+
+ # If two arguments were given, the second argument is going to be a file
+ # handle. That means we want to call parse_from_filehandle(), which means
+ # we need to turn the first argument into a file handle. Magic open will
+ # handle the <&STDIN case automagically.
+ if (defined $_[1]) {
+ my @fhs = @_;
+ local *IN;
+ unless (open (IN, $fhs[0])) {
+ croak ("Can't open $fhs[0] for reading: $!\n");
+ return;
+ }
+ $fhs[0] = \*IN;
+ $parser->output_fh ($fhs[1]);
+ my $retval = $parser->parse_file ($fhs[0]);
+ my $fh = $parser->output_fh ();
+ close $fh;
+ return $retval;
+ } else {
+ $parser->output_fh (\*STDOUT);
+ return $parser->parse_file (@_);
+ }
+}
+
+# Reset the underlying Pod::Simple object between calls to parse_from_file so
+# that the same object can be reused to convert multiple pages.
+sub parse_from_file {
+ my $self = shift;
+ $self->reinit;
+
+ # Fake the old cutting option to Pod::Parser. This fiddings with internal
+ # Pod::Simple state and is quite ugly; we need a better approach.
+ if (ref ($_[0]) eq 'HASH') {
+ my $opts = shift @_;
+ if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
+ $$self{in_pod} = 1;
+ $$self{last_was_blank} = 1;
+ }
+ }
+
+ # Do the work.
+ my $retval = $self->Pod::Simple::parse_from_file (@_);
+
+ # Flush output, since Pod::Simple doesn't do this. Ideally we should also
+ # close the file descriptor if we had to open one, but we can't easily
+ # figure this out.
+ my $fh = $self->output_fh ();
+ my $oldfh = select $fh;
+ my $oldflush = $|;
+ $| = 1;
+ print $fh '';
+ $| = $oldflush;
+ select $oldfh;
+ return $retval;
+}
+
+# Pod::Simple failed to provide this backward compatibility function, so
+# implement it ourselves. File handles are one of the inputs that
+# parse_from_file supports.
+sub parse_from_filehandle {
+ my $self = shift;
+ $self->parse_from_file (@_);
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Text - Convert POD data to formatted ASCII text
+
+=for stopwords
+alt stderr Allbery Sean Burke's Christiansen UTF-8 pre-Unicode utf8
+
+=head1 SYNOPSIS
+
+ use Pod::Text;
+ my $parser = Pod::Text->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::Text is a module that can convert documentation in the POD format (the
+preferred language for documenting Perl) into formatted ASCII. It uses no
+special formatting controls or codes whatsoever, and its output is therefore
+suitable for nearly any device.
+
+As a derived class from Pod::Simple, Pod::Text supports the same methods and
+interfaces. See L<Pod::Simple> for all the details; briefly, one creates a
+new parser with C<< Pod::Text->new() >> and then normally calls parse_file().
+
+new() can take options, in the form of key/value pairs, that control the
+behavior of the parser. The currently recognized options are:
+
+=over 4
+
+=item alt
+
+If set to a true value, selects an alternate output format that, among other
+things, uses a different heading style and marks C<=item> entries with a
+colon in the left margin. Defaults to false.
+
+=item code
+
+If set to a true value, the non-POD parts of the input file will be included
+in the output. Useful for viewing code documented with POD blocks with the
+POD rendered and the code left intact.
+
+=item indent
+
+The number of spaces to indent regular text, and the default indentation for
+C<=over> blocks. Defaults to 4.
+
+=item loose
+
+If set to a true value, a blank line is printed after a C<=head1> heading.
+If set to false (the default), no blank line is printed after C<=head1>,
+although one is still printed after C<=head2>. This is the default because
+it's the expected formatting for manual pages; if you're formatting
+arbitrary text documents, setting this to true may result in more pleasing
+output.
+
+=item margin
+
+The width of the left margin in spaces. Defaults to 0. This is the margin
+for all text, including headings, not the amount by which regular text is
+indented; for the latter, see the I<indent> option. To set the right
+margin, see the I<width> option.
+
+=item quotes
+
+Sets the quote marks used to surround CE<lt>> text. If the value is a
+single character, it is used as both the left and right quote; if it is two
+characters, the first character is used as the left quote and the second as
+the right quoted; and if it is four characters, the first two are used as
+the left quote and the second two as the right quote.
+
+This may also be set to the special value C<none>, in which case no quote
+marks are added around CE<lt>> text.
+
+=item sentence
+
+If set to a true value, Pod::Text will assume that each sentence ends in two
+spaces, and will try to preserve that spacing. If set to false, all
+consecutive whitespace in non-verbatim paragraphs is compressed into a
+single space. Defaults to true.
+
+=item stderr
+
+Send error messages about invalid POD to standard error instead of
+appending a POD ERRORS section to the generated output.
+
+=item utf8
+
+By default, Pod::Text uses the same output encoding as the input encoding
+of the POD source (provided that Perl was built with PerlIO; otherwise, it
+doesn't encode its output). If this option is given, the output encoding
+is forced to UTF-8.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item width
+
+The column at which to wrap text on the right-hand side. Defaults to 76.
+
+=back
+
+The standard Pod::Simple method parse_file() takes one argument, the file or
+file handle to read from, and writes output to standard output unless that
+has been changed with the output_fh() method. See L<Pod::Simple> for the
+specific details and for other alternative interfaces.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bizarre space in item
+
+=item Item called without tag
+
+(W) Something has gone wrong in internal C<=item> processing. These
+messages indicate a bug in Pod::Text; you should never see them.
+
+=item Can't open %s for reading: %s
+
+(F) Pod::Text was invoked via the compatibility mode pod2text() interface
+and the input file it was given could not be opened.
+
+=item Invalid quote specification "%s"
+
+(F) The quote specification given (the quotes option to the constructor) was
+invalid. A quote specification must be one, two, or four characters long.
+
+=back
+
+=head1 BUGS
+
+Encoding handling assumes that PerlIO is available and does not work
+properly if it isn't. The C<utf8> option is therefore not supported
+unless Perl is built with PerlIO support.
+
+=head1 CAVEATS
+
+If Pod::Text is given the C<utf8> option, the encoding of its output file
+handle will be forced to UTF-8 if possible, overriding any existing
+encoding. This will be done even if the file handle is not created by
+Pod::Text and was passed in from outside. This maintains consistency
+regardless of PERL_UNICODE and other settings.
+
+If the C<utf8> option is not given, the encoding of its output file handle
+will be forced to the detected encoding of the input POD, which preserves
+whatever the input text is. This ensures backward compatibility with
+earlier, pre-Unicode versions of this module, without large numbers of
+Perl warnings.
+
+This is not ideal, but it seems to be the best compromise. If it doesn't
+work for you, please let me know the details of how it broke.
+
+=head1 NOTES
+
+This is a replacement for an earlier Pod::Text module written by Tom
+Christiansen. It has a revamped interface, since it now uses Pod::Simple,
+but an interface roughly compatible with the old Pod::Text::pod2text()
+function is still available. Please change to the new calling convention,
+though.
+
+The original Pod::Text contained code to do formatting via termcap
+sequences, although it wasn't turned on by default and it was problematic to
+get it to work at all. This rewrite doesn't even try to do that, but a
+subclass of it does. Look for L<Pod::Text::Termcap>.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Text::Termcap>, L<perlpod(1)>, L<pod2text(1)>
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
+Pod::Text by Tom Christiansen <tchrist@mox.perl.com> and its conversion to
+Pod::Parser by Brad Appleton <bradapp@enteract.com>. Sean Burke's initial
+conversion of Pod::Man to use Pod::Simple provided much-needed guidance on
+how to use Pod::Simple.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009 Russ Allbery
+<rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Text/Color.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Text/Color.pm
new file mode 100755
index 00000000000..1c81a7b4c84
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Text/Color.pm
@@ -0,0 +1,155 @@
+# Pod::Text::Color -- Convert POD data to formatted color ASCII text
+#
+# Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This is just a basic proof of concept. It should later be modified to make
+# better use of color, take options changing what colors are used for what
+# text, and the like.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::Text::Color;
+
+require 5.004;
+
+use Pod::Text ();
+use Term::ANSIColor qw(colored);
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+@ISA = qw(Pod::Text);
+
+$VERSION = '2.05';
+
+##############################################################################
+# Overrides
+##############################################################################
+
+# Make level one headings bold.
+sub cmd_head1 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $self->SUPER::cmd_head1 ($attrs, colored ($text, 'bold'));
+}
+
+# Make level two headings bold.
+sub cmd_head2 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $self->SUPER::cmd_head2 ($attrs, colored ($text, 'bold'));
+}
+
+# Fix the various formatting codes.
+sub cmd_b { return colored ($_[2], 'bold') }
+sub cmd_f { return colored ($_[2], 'cyan') }
+sub cmd_i { return colored ($_[2], 'yellow') }
+
+# Output any included code in green.
+sub output_code {
+ my ($self, $code) = @_;
+ $code = colored ($code, 'green');
+ $self->output ($code);
+}
+
+# Strip all of the formatting from a provided string, returning the stripped
+# version. We will eventually want to use colorstrip() from Term::ANSIColor,
+# but it's fairly new so avoid the tight dependency.
+sub strip_format {
+ my ($self, $text) = @_;
+ $text =~ s/\e\[[\d;]*m//g;
+ return $text;
+}
+
+# We unfortunately have to override the wrapping code here, since the normal
+# wrapping code gets really confused by all the escape sequences.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{opt_width} - $$self{MARGIN};
+
+ # We have to do $shortchar and $longchar in variables because the
+ # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x.
+ my $char = '(?:(?:\e\[[\d;]+m)*[^\n])';
+ my $shortchar = $char . "{0,$width}";
+ my $longchar = $char . "{$width}";
+ while (length > $width) {
+ if (s/^($shortchar)\s+// || s/^($longchar)//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ $output;
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Text::Color - Convert POD data to formatted color ASCII text
+
+=for stopwords
+Allbery
+
+=head1 SYNOPSIS
+
+ use Pod::Text::Color;
+ my $parser = Pod::Text::Color->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::Text::Color is a simple subclass of Pod::Text that highlights output
+text using ANSI color escape sequences. Apart from the color, it in all
+ways functions like Pod::Text. See L<Pod::Text> for details and available
+options.
+
+Term::ANSIColor is used to get colors and therefore must be installed to use
+this module.
+
+=head1 BUGS
+
+This is just a basic proof of concept. It should be seriously expanded to
+support configurable coloration via options passed to the constructor, and
+B<pod2text> should be taught about those.
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Simple>
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Text/Overstrike.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Text/Overstrike.pm
new file mode 100755
index 00000000000..7578f0f8f58
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Text/Overstrike.pm
@@ -0,0 +1,208 @@
+# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
+#
+# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
+# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>)
+# Copyright 2000 Joe Smith <Joe.Smith@inwap.com>.
+# Copyright 2001, 2004, 2008 Russ Allbery <rra@stanford.edu>.
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This was written because the output from:
+#
+# pod2text Text.pm > plain.txt; less plain.txt
+#
+# is not as rich as the output from
+#
+# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt
+#
+# and because both Pod::Text::Color and Pod::Text::Termcap are not device
+# independent.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::Text::Overstrike;
+
+require 5.004;
+
+use Pod::Text ();
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+@ISA = qw(Pod::Text);
+
+$VERSION = '2.04';
+
+##############################################################################
+# Overrides
+##############################################################################
+
+# Make level one headings bold, overridding any existing formatting.
+sub cmd_head1 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $text = $self->strip_format ($text);
+ $text =~ s/(.)/$1\b$1/g;
+ return $self->SUPER::cmd_head1 ($attrs, $text);
+}
+
+# Make level two headings bold, overriding any existing formatting.
+sub cmd_head2 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $text = $self->strip_format ($text);
+ $text =~ s/(.)/$1\b$1/g;
+ return $self->SUPER::cmd_head2 ($attrs, $text);
+}
+
+# Make level three headings underscored, overriding any existing formatting.
+sub cmd_head3 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $text = $self->strip_format ($text);
+ $text =~ s/(.)/_\b$1/g;
+ return $self->SUPER::cmd_head3 ($attrs, $text);
+}
+
+# Level four headings look like level three headings.
+sub cmd_head4 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $text = $self->strip_format ($text);
+ $text =~ s/(.)/_\b$1/g;
+ return $self->SUPER::cmd_head4 ($attrs, $text);
+}
+
+# The common code for handling all headers. We have to override to avoid
+# interpolating twice and because we don't want to honor alt.
+sub heading {
+ my ($self, $text, $indent, $marker) = @_;
+ $self->item ("\n\n") if defined $$self{ITEM};
+ $text .= "\n" if $$self{opt_loose};
+ my $margin = ' ' x ($$self{opt_margin} + $indent);
+ $self->output ($margin . $text . "\n");
+ return '';
+}
+
+# Fix the various formatting codes.
+sub cmd_b { local $_ = $_[0]->strip_format ($_[2]); s/(.)/$1\b$1/g; $_ }
+sub cmd_f { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }
+sub cmd_i { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }
+
+# Output any included code in bold.
+sub output_code {
+ my ($self, $code) = @_;
+ $code =~ s/(.)/$1\b$1/g;
+ $self->output ($code);
+}
+
+# Strip all of the formatting from a provided string, returning the stripped
+# version.
+sub strip_format {
+ my ($self, $text) = @_;
+ $text =~ s/(.)[\b]\1/$1/g;
+ $text =~ s/_[\b]//g;
+ return $text;
+}
+
+# We unfortunately have to override the wrapping code here, since the normal
+# wrapping code gets really confused by all the backspaces.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{opt_width} - $$self{MARGIN};
+ while (length > $width) {
+ # This regex represents a single character, that's possibly underlined
+ # or in bold (in which case, it's three characters; the character, a
+ # backspace, and a character). Use [^\n] rather than . to protect
+ # against odd settings of $*.
+ my $char = '(?:[^\n][\b])?[^\n]';
+ if (s/^((?>$char){0,$width})(?:\Z|\s+)//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ return $output;
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+=for stopwords
+overstrike
+
+Pod::Text::Overstrike - Convert POD data to formatted overstrike text
+
+=for stopwords
+overstruck Overstruck Allbery terminal's
+
+=head1 SYNOPSIS
+
+ use Pod::Text::Overstrike;
+ my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights
+output text using overstrike sequences, in a manner similar to nroff.
+Characters in bold text are overstruck (character, backspace, character)
+and characters in underlined text are converted to overstruck underscores
+(underscore, backspace, character). This format was originally designed
+for hard-copy terminals and/or line printers, yet is readable on soft-copy
+(CRT) terminals.
+
+Overstruck text is best viewed by page-at-a-time programs that take
+advantage of the terminal's B<stand-out> and I<underline> capabilities, such
+as the less program on Unix.
+
+Apart from the overstrike, it in all ways functions like Pod::Text. See
+L<Pod::Text> for details and available options.
+
+=head1 BUGS
+
+Currently, the outermost formatting instruction wins, so for example
+underlined text inside a region of bold text is displayed as simply bold.
+There may be some better approach possible.
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Simple>
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Joe Smith <Joe.Smith@inwap.com>, using the framework created by Russ Allbery
+<rra@stanford.edu>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>.
+Copyright 2001, 2004, 2008 by Russ Allbery <rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Text/Termcap.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Text/Termcap.pm
new file mode 100755
index 00000000000..708f1e80812
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Text/Termcap.pm
@@ -0,0 +1,195 @@
+# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes.
+#
+# Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009
+# Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This is a simple subclass of Pod::Text that overrides a few key methods to
+# output the right termcap escape sequences for formatted text on the current
+# terminal type.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Pod::Text::Termcap;
+
+require 5.004;
+
+use Pod::Text ();
+use POSIX ();
+use Term::Cap;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+@ISA = qw(Pod::Text);
+
+$VERSION = '2.05';
+
+##############################################################################
+# Overrides
+##############################################################################
+
+# In the initialization method, grab our terminal characteristics as well as
+# do all the stuff we normally do.
+sub new {
+ my ($self, @args) = @_;
+ my ($ospeed, $term, $termios);
+ $self = $self->SUPER::new (@args);
+
+ # $ENV{HOME} is usually not set on Windows. The default Term::Cap path
+ # may not work on Solaris.
+ my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : '';
+ $ENV{TERMPATH} = $home . '/etc/termcap:/usr/share/misc/termcap'
+ . ':/usr/share/lib/termcap';
+
+ # Fall back on a hard-coded terminal speed if POSIX::Termios isn't
+ # available (such as on VMS).
+ eval { $termios = POSIX::Termios->new };
+ if ($@) {
+ $ospeed = 9600;
+ } else {
+ $termios->getattr;
+ $ospeed = $termios->getospeed || 9600;
+ }
+
+ # Fall back on the ANSI escape sequences if Term::Cap doesn't work.
+ eval { $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed } };
+ $$self{BOLD} = $$term{_md} || "\e[1m";
+ $$self{UNDL} = $$term{_us} || "\e[4m";
+ $$self{NORM} = $$term{_me} || "\e[m";
+
+ unless (defined $$self{width}) {
+ $$self{opt_width} = $ENV{COLUMNS} || $$term{_co} || 80;
+ $$self{opt_width} -= 2;
+ }
+
+ return $self;
+}
+
+# Make level one headings bold.
+sub cmd_head1 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $self->SUPER::cmd_head1 ($attrs, "$$self{BOLD}$text$$self{NORM}");
+}
+
+# Make level two headings bold.
+sub cmd_head2 {
+ my ($self, $attrs, $text) = @_;
+ $text =~ s/\s+$//;
+ $self->SUPER::cmd_head2 ($attrs, "$$self{BOLD}$text$$self{NORM}");
+}
+
+# Fix up B<> and I<>. Note that we intentionally don't do F<>.
+sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" }
+sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" }
+
+# Output any included code in bold.
+sub output_code {
+ my ($self, $code) = @_;
+ $self->output ($$self{BOLD} . $code . $$self{NORM});
+}
+
+# Strip all of the formatting from a provided string, returning the stripped
+# version.
+sub strip_format {
+ my ($self, $text) = @_;
+ $text =~ s/\Q$$self{BOLD}//g;
+ $text =~ s/\Q$$self{UNDL}//g;
+ $text =~ s/\Q$$self{NORM}//g;
+ return $text;
+}
+
+# Override the wrapping code to igore the special sequences.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{opt_width} - $$self{MARGIN};
+
+ # $codes matches a single special sequence. $char matches any number of
+ # special sequences preceeding a single character other than a newline.
+ # We have to do $shortchar and $longchar in variables because the
+ # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x.
+ my $codes = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)";
+ my $char = "(?:$codes*[^\\n])";
+ my $shortchar = $char . "{0,$width}";
+ my $longchar = $char . "{$width}";
+ while (length > $width) {
+ if (s/^($shortchar)\s+// || s/^($longchar)//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ return $output;
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Text::Termcap - Convert POD data to ASCII text with format escapes
+
+=for stopwords
+ECMA-48 VT100 Allbery
+
+=head1 SYNOPSIS
+
+ use Pod::Text::Termcap;
+ my $parser = Pod::Text::Termcap->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::Text::Termcap is a simple subclass of Pod::Text that highlights output
+text using the correct termcap escape sequences for the current terminal.
+Apart from the format codes, it in all ways functions like Pod::Text. See
+L<Pod::Text> for details and available options.
+
+=head1 NOTES
+
+This module uses Term::Cap to retrieve the formatting escape sequences for
+the current terminal, and falls back on the ECMA-48 (the same in this
+regard as ANSI X3.64 and ISO 6429, the escape codes also used by DEC VT100
+terminals) if the bold, underline, and reset codes aren't set in the
+termcap information.
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Simple>, L<Term::Cap>
+
+The current version of this module is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009 Russ Allbery
+<rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Pod/Usage.pm b/Master/tlpkg/tlperl.straw/lib/Pod/Usage.pm
new file mode 100755
index 00000000000..f463fb9c468
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Pod/Usage.pm
@@ -0,0 +1,730 @@
+#############################################################################
+# Pod/Usage.pm -- print usage messages for the running script.
+#
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
+# This file is part of "PodParser". PodParser is free software;
+# you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+#############################################################################
+
+package Pod::Usage;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '1.36'; ## Current version of this package
+require 5.005; ## requires this Perl version or later
+
+=head1 NAME
+
+Pod::Usage, pod2usage() - print a usage message from embedded pod documentation
+
+=head1 SYNOPSIS
+
+ use Pod::Usage
+
+ my $message_text = "This text precedes the usage message.";
+ my $exit_status = 2; ## The exit status to use
+ my $verbose_level = 0; ## The verbose level to use
+ my $filehandle = \*STDERR; ## The filehandle to write to
+
+ pod2usage($message_text);
+
+ pod2usage($exit_status);
+
+ pod2usage( { -message => $message_text ,
+ -exitval => $exit_status ,
+ -verbose => $verbose_level,
+ -output => $filehandle } );
+
+ pod2usage( -msg => $message_text ,
+ -exitval => $exit_status ,
+ -verbose => $verbose_level,
+ -output => $filehandle );
+
+ pod2usage( -verbose => 2,
+ -noperldoc => 1 )
+
+=head1 ARGUMENTS
+
+B<pod2usage> should be given either a single argument, or a list of
+arguments corresponding to an associative array (a "hash"). When a single
+argument is given, it should correspond to exactly one of the following:
+
+=over 4
+
+=item *
+
+A string containing the text of a message to print I<before> printing
+the usage message
+
+=item *
+
+A numeric value corresponding to the desired exit status
+
+=item *
+
+A reference to a hash
+
+=back
+
+If more than one argument is given then the entire argument list is
+assumed to be a hash. If a hash is supplied (either as a reference or
+as a list) it should contain one or more elements with the following
+keys:
+
+=over 4
+
+=item C<-message>
+
+=item C<-msg>
+
+The text of a message to print immediately prior to printing the
+program's usage message.
+
+=item C<-exitval>
+
+The desired exit status to pass to the B<exit()> function.
+This should be an integer, or else the string "NOEXIT" to
+indicate that control should simply be returned without
+terminating the invoking process.
+
+=item C<-verbose>
+
+The desired level of "verboseness" to use when printing the usage
+message. If the corresponding value is 0, then only the "SYNOPSIS"
+section of the pod documentation is printed. If the corresponding value
+is 1, then the "SYNOPSIS" section, along with any section entitled
+"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the
+corresponding value is 2 or more then the entire manpage is printed.
+
+The special verbosity level 99 requires to also specify the -sections
+parameter; then these sections are extracted (see L<Pod::Select>)
+and printed.
+
+=item C<-sections>
+
+A string representing a selection list for sections to be printed
+when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">.
+
+Alternatively, an array reference of section specifications can be used:
+
+ pod2usage(-verbose => 99,
+ -sections => [ qw(fred fred/subsection) ] );
+
+=item C<-output>
+
+A reference to a filehandle, or the pathname of a file to which the
+usage message should be written. The default is C<\*STDERR> unless the
+exit value is less than 2 (in which case the default is C<\*STDOUT>).
+
+=item C<-input>
+
+A reference to a filehandle, or the pathname of a file from which the
+invoking script's pod documentation should be read. It defaults to the
+file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>).
+
+If you are calling B<pod2usage()> from a module and want to display
+that module's POD, you can use this:
+
+ use Pod::Find qw(pod_where);
+ pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) );
+
+=item C<-pathlist>
+
+A list of directory paths. If the input file does not exist, then it
+will be searched for in the given directory list (in the order the
+directories appear in the list). It defaults to the list of directories
+implied by C<$ENV{PATH}>. The list may be specified either by a reference
+to an array, or by a string of directory paths which use the same path
+separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for
+MSWin32 and DOS).
+
+=item C<-noperldoc>
+
+By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
+specified. This does not work well e.g. if the script was packed
+with L<PAR>. The -noperldoc option suppresses the external call to
+L<perldoc> and uses the simple text formatter (L<Pod::Text>) to
+output the POD.
+
+=back
+
+=head1 DESCRIPTION
+
+B<pod2usage> will print a usage message for the invoking script (using
+its embedded pod documentation) and then exit the script with the
+desired exit status. The usage message printed may have any one of three
+levels of "verboseness": If the verbose level is 0, then only a synopsis
+is printed. If the verbose level is 1, then the synopsis is printed
+along with a description (if present) of the command line options and
+arguments. If the verbose level is 2, then the entire manual page is
+printed.
+
+Unless they are explicitly specified, the default values for the exit
+status, verbose level, and output stream to use are determined as
+follows:
+
+=over 4
+
+=item *
+
+If neither the exit status nor the verbose level is specified, then the
+default is to use an exit status of 2 with a verbose level of 0.
+
+=item *
+
+If an exit status I<is> specified but the verbose level is I<not>, then the
+verbose level will default to 1 if the exit status is less than 2 and
+will default to 0 otherwise.
+
+=item *
+
+If an exit status is I<not> specified but verbose level I<is> given, then
+the exit status will default to 2 if the verbose level is 0 and will
+default to 1 otherwise.
+
+=item *
+
+If the exit status used is less than 2, then output is printed on
+C<STDOUT>. Otherwise output is printed on C<STDERR>.
+
+=back
+
+Although the above may seem a bit confusing at first, it generally does
+"the right thing" in most situations. This determination of the default
+values to use is based upon the following typical Unix conventions:
+
+=over 4
+
+=item *
+
+An exit status of 0 implies "success". For example, B<diff(1)> exits
+with a status of 0 if the two files have the same contents.
+
+=item *
+
+An exit status of 1 implies possibly abnormal, but non-defective, program
+termination. For example, B<grep(1)> exits with a status of 1 if
+it did I<not> find a matching line for the given regular expression.
+
+=item *
+
+An exit status of 2 or more implies a fatal error. For example, B<ls(1)>
+exits with a status of 2 if you specify an illegal (unknown) option on
+the command line.
+
+=item *
+
+Usage messages issued as a result of bad command-line syntax should go
+to C<STDERR>. However, usage messages issued due to an explicit request
+to print usage (like specifying B<-help> on the command line) should go
+to C<STDOUT>, just in case the user wants to pipe the output to a pager
+(such as B<more(1)>).
+
+=item *
+
+If program usage has been explicitly requested by the user, it is often
+desirable to exit with a status of 1 (as opposed to 0) after issuing
+the user-requested usage message. It is also desirable to give a
+more verbose description of program usage in this case.
+
+=back
+
+B<pod2usage> doesn't force the above conventions upon you, but it will
+use them by default if you don't expressly tell it to do otherwise. The
+ability of B<pod2usage()> to accept a single number or a string makes it
+convenient to use as an innocent looking error message handling function:
+
+ use Pod::Usage;
+ use Getopt::Long;
+
+ ## Parse options
+ GetOptions("help", "man", "flag1") || pod2usage(2);
+ pod2usage(1) if ($opt_help);
+ pod2usage(-verbose => 2) if ($opt_man);
+
+ ## Check for too many filenames
+ pod2usage("$0: Too many files given.\n") if (@ARGV > 1);
+
+Some user's however may feel that the above "economy of expression" is
+not particularly readable nor consistent and may instead choose to do
+something more like the following:
+
+ use Pod::Usage;
+ use Getopt::Long;
+
+ ## Parse options
+ GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0);
+ pod2usage(-verbose => 1) if ($opt_help);
+ pod2usage(-verbose => 2) if ($opt_man);
+
+ ## Check for too many filenames
+ pod2usage(-verbose => 2, -message => "$0: Too many files given.\n")
+ if (@ARGV > 1);
+
+As with all things in Perl, I<there's more than one way to do it>, and
+B<pod2usage()> adheres to this philosophy. If you are interested in
+seeing a number of different ways to invoke B<pod2usage> (although by no
+means exhaustive), please refer to L<"EXAMPLES">.
+
+=head1 EXAMPLES
+
+Each of the following invocations of C<pod2usage()> will print just the
+"SYNOPSIS" section to C<STDERR> and will exit with a status of 2:
+
+ pod2usage();
+
+ pod2usage(2);
+
+ pod2usage(-verbose => 0);
+
+ pod2usage(-exitval => 2);
+
+ pod2usage({-exitval => 2, -output => \*STDERR});
+
+ pod2usage({-verbose => 0, -output => \*STDERR});
+
+ pod2usage(-exitval => 2, -verbose => 0);
+
+ pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR);
+
+Each of the following invocations of C<pod2usage()> will print a message
+of "Syntax error." (followed by a newline) to C<STDERR>, immediately
+followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and
+will exit with a status of 2:
+
+ pod2usage("Syntax error.");
+
+ pod2usage(-message => "Syntax error.", -verbose => 0);
+
+ pod2usage(-msg => "Syntax error.", -exitval => 2);
+
+ pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR});
+
+ pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR});
+
+ pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0);
+
+ pod2usage(-message => "Syntax error.",
+ -exitval => 2,
+ -verbose => 0,
+ -output => \*STDERR);
+
+Each of the following invocations of C<pod2usage()> will print the
+"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to
+C<STDOUT> and will exit with a status of 1:
+
+ pod2usage(1);
+
+ pod2usage(-verbose => 1);
+
+ pod2usage(-exitval => 1);
+
+ pod2usage({-exitval => 1, -output => \*STDOUT});
+
+ pod2usage({-verbose => 1, -output => \*STDOUT});
+
+ pod2usage(-exitval => 1, -verbose => 1);
+
+ pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT});
+
+Each of the following invocations of C<pod2usage()> will print the
+entire manual page to C<STDOUT> and will exit with a status of 1:
+
+ pod2usage(-verbose => 2);
+
+ pod2usage({-verbose => 2, -output => \*STDOUT});
+
+ pod2usage(-exitval => 1, -verbose => 2);
+
+ pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT});
+
+=head2 Recommended Use
+
+Most scripts should print some type of usage message to C<STDERR> when a
+command line syntax error is detected. They should also provide an
+option (usually C<-H> or C<-help>) to print a (possibly more verbose)
+usage message to C<STDOUT>. Some scripts may even wish to go so far as to
+provide a means of printing their complete documentation to C<STDOUT>
+(perhaps by allowing a C<-man> option). The following complete example
+uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these
+things:
+
+ use Getopt::Long;
+ use Pod::Usage;
+
+ my $man = 0;
+ my $help = 0;
+ ## Parse options and print usage if there is a syntax error,
+ ## or if usage was explicitly requested.
+ GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
+ pod2usage(1) if $help;
+ pod2usage(-verbose => 2) if $man;
+
+ ## If no arguments were given, then allow STDIN to be used only
+ ## if it's not connected to a terminal (otherwise print usage)
+ pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN));
+ __END__
+
+ =head1 NAME
+
+ sample - Using GetOpt::Long and Pod::Usage
+
+ =head1 SYNOPSIS
+
+ sample [options] [file ...]
+
+ Options:
+ -help brief help message
+ -man full documentation
+
+ =head1 OPTIONS
+
+ =over 8
+
+ =item B<-help>
+
+ Print a brief help message and exits.
+
+ =item B<-man>
+
+ Prints the manual page and exits.
+
+ =back
+
+ =head1 DESCRIPTION
+
+ B<This program> will read the given input file(s) and do something
+ useful with the contents thereof.
+
+ =cut
+
+=head1 CAVEATS
+
+By default, B<pod2usage()> will use C<$0> as the path to the pod input
+file. Unfortunately, not all systems on which Perl runs will set C<$0>
+properly (although if C<$0> isn't found, B<pod2usage()> will search
+C<$ENV{PATH}> or else the list specified by the C<-pathlist> option).
+If this is the case for your system, you may need to explicitly specify
+the path to the pod docs for the invoking script using something
+similar to the following:
+
+ pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs");
+
+In the pathological case that a script is called via a relative path
+I<and> the script itself changes the current working directory
+(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will
+fail even on robust platforms. Don't do that.
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+Based on code for B<Pod::Text::pod2text()> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=head1 ACKNOWLEDGMENTS
+
+Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience
+with re-writing this manpage.
+
+=head1 SEE ALSO
+
+L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find>
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Carp;
+use Config;
+use Exporter;
+use File::Spec;
+
+@EXPORT = qw(&pod2usage);
+BEGIN {
+ if ( $] >= 5.005_58 ) {
+ require Pod::Text;
+ @ISA = qw( Pod::Text );
+ }
+ else {
+ require Pod::PlainText;
+ @ISA = qw( Pod::PlainText );
+ }
+}
+
+require Pod::Select;
+
+##---------------------------------------------------------------------------
+
+##---------------------------------
+## Function definitions begin here
+##---------------------------------
+
+sub pod2usage {
+ local($_) = shift;
+ my %opts;
+ ## Collect arguments
+ if (@_ > 0) {
+ ## Too many arguments - assume that this is a hash and
+ ## the user forgot to pass a reference to it.
+ %opts = ($_, @_);
+ }
+ elsif (!defined $_) {
+ $_ = '';
+ }
+ elsif (ref $_) {
+ ## User passed a ref to a hash
+ %opts = %{$_} if (ref($_) eq 'HASH');
+ }
+ elsif (/^[-+]?\d+$/) {
+ ## User passed in the exit value to use
+ $opts{'-exitval'} = $_;
+ }
+ else {
+ ## User passed in a message to print before issuing usage.
+ $_ and $opts{'-message'} = $_;
+ }
+
+ ## Need this for backward compatibility since we formerly used
+ ## options that were all uppercase words rather than ones that
+ ## looked like Unix command-line options.
+ ## to be uppercase keywords)
+ %opts = map {
+ my ($key, $val) = ($_, $opts{$_});
+ $key =~ s/^(?=\w)/-/;
+ $key =~ /^-msg/i and $key = '-message';
+ $key =~ /^-exit/i and $key = '-exitval';
+ lc($key) => $val;
+ } (keys %opts);
+
+ ## Now determine default -exitval and -verbose values to use
+ if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) {
+ $opts{'-exitval'} = 2;
+ $opts{'-verbose'} = 0;
+ }
+ elsif (! defined $opts{'-exitval'}) {
+ $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2;
+ }
+ elsif (! defined $opts{'-verbose'}) {
+ $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' ||
+ $opts{'-exitval'} < 2);
+ }
+
+ ## Default the output file
+ $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' ||
+ $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR
+ unless (defined $opts{'-output'});
+ ## Default the input file
+ $opts{'-input'} = $0 unless (defined $opts{'-input'});
+
+ ## Look up input file in path if it doesnt exist.
+ unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) {
+ my $basename = $opts{'-input'};
+ my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';'
+ : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':');
+ my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB};
+
+ my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
+ for my $dirname (@paths) {
+ $_ = File::Spec->catfile($dirname, $basename) if length;
+ last if (-e $_) && ($opts{'-input'} = $_);
+ }
+ }
+
+ ## Now create a pod reader and constrain it to the desired sections.
+ my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
+ if ($opts{'-verbose'} == 0) {
+ $parser->select('(?:SYNOPSIS|USAGE)\s*');
+ }
+ elsif ($opts{'-verbose'} == 1) {
+ my $opt_re = '(?i)' .
+ '(?:OPTIONS|ARGUMENTS)' .
+ '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
+ $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
+ }
+ elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
+ $parser->select('.*');
+ }
+ elsif ($opts{'-verbose'} == 99) {
+ my $sections = $opts{'-sections'};
+ $parser->select( (ref $sections) ? @$sections : $sections );
+ $opts{'-verbose'} = 1;
+ }
+
+ ## Now translate the pod document and then exit with the desired status
+ if ( !$opts{'-noperldoc'}
+ and $opts{'-verbose'} >= 2
+ and !ref($opts{'-input'})
+ and $opts{'-output'} == \*STDOUT )
+ {
+ ## spit out the entire PODs. Might as well invoke perldoc
+ my $progpath = File::Spec->catfile($Config{scriptdir}, 'perldoc');
+ print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
+ if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
+ # the perldocs back to 5.005 should all have -F
+ # without -F there are warnings in -T scripts
+ system($progpath, '-F', $1);
+ if($?) {
+ # RT16091: fall back to more if perldoc failed
+ system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
+ }
+ } else {
+ croak "Unspecified input file or insecure argument.\n";
+ }
+ }
+ else {
+ $parser->parse_from_file($opts{'-input'}, $opts{'-output'});
+ }
+
+ exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit');
+}
+
+##---------------------------------------------------------------------------
+
+##-------------------------------
+## Method definitions begin here
+##-------------------------------
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my %params = @_;
+ my $self = {%params};
+ bless $self, $class;
+ if ($self->can('initialize')) {
+ $self->initialize();
+ } else {
+ $self = $self->SUPER::new();
+ %$self = (%$self, %params);
+ }
+ return $self;
+}
+
+sub select {
+ my ($self, @sections) = @_;
+ if ($ISA[0]->can('select')) {
+ $self->SUPER::select(@sections);
+ } else {
+ # we're using Pod::Simple - need to mimic the behavior of Pod::Select
+ my $add = ($sections[0] eq '+') ? shift(@sections) : '';
+ ## Reset the set of sections to use
+ unless (@sections) {
+ delete $self->{USAGE_SELECT} unless ($add);
+ return;
+ }
+ $self->{USAGE_SELECT} = []
+ unless ($add && $self->{USAGE_SELECT});
+ my $sref = $self->{USAGE_SELECT};
+ ## Compile each spec
+ for my $spec (@sections) {
+ my $cs = Pod::Select::_compile_section_spec($spec);
+ if ( defined $cs ) {
+ ## Store them in our sections array
+ push(@$sref, $cs);
+ } else {
+ carp qq{Ignoring section spec "$spec"!\n};
+ }
+ }
+ }
+}
+
+# Override Pod::Text->seq_i to return just "arg", not "*arg*".
+sub seq_i { return $_[1] }
+
+# This overrides the Pod::Text method to do something very akin to what
+# Pod::Select did as well as the work done below by preprocess_paragraph.
+# Note that the below is very, very specific to Pod::Text.
+sub _handle_element_end {
+ my ($self, $element) = @_;
+ if ($element eq 'head1') {
+ $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
+ if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
+ $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
+ }
+ } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
+ my $idx = $1 - 1;
+ $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
+ $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
+ }
+ if ($element =~ /^head\d+$/) {
+ $$self{USAGE_SKIPPING} = 1;
+ if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
+ $$self{USAGE_SKIPPING} = 0;
+ } else {
+ my @headings = @{$$self{USAGE_HEADINGS}};
+ for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
+ my $match = 1;
+ for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) {
+ $headings[$i] = '' unless defined $headings[$i];
+ my $regex = $section_spec->[$i];
+ my $negated = ($regex =~ s/^\!//);
+ $match &= ($negated ? ($headings[$i] !~ /${regex}/)
+ : ($headings[$i] =~ /${regex}/));
+ last unless ($match);
+ } # end heading levels
+ if ($match) {
+ $$self{USAGE_SKIPPING} = 0;
+ last;
+ }
+ } # end sections
+ }
+
+ # Try to do some lowercasing instead of all-caps in headings, and use
+ # a colon to end all headings.
+ if($self->{USAGE_OPTIONS}->{-verbose} < 2) {
+ local $_ = $$self{PENDING}[-1][1];
+ s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
+ s/\s*$/:/ unless (/:\s*$/);
+ $_ .= "\n";
+ $$self{PENDING}[-1][1] = $_;
+ }
+ }
+ if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) {
+ pop @{ $$self{PENDING} };
+ } else {
+ $self->SUPER::_handle_element_end($element);
+ }
+}
+
+# required for Pod::Simple API
+sub start_document {
+ my $self = shift;
+ $self->SUPER::start_document();
+ my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
+ my $out_fh = $self->output_fh();
+ print $out_fh "$msg\n";
+}
+
+# required for old Pod::Parser API
+sub begin_pod {
+ my $self = shift;
+ $self->SUPER::begin_pod(); ## Have to call superclass
+ my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
+ my $out_fh = $self->output_handle();
+ print $out_fh "$msg\n";
+}
+
+sub preprocess_paragraph {
+ my $self = shift;
+ local $_ = shift;
+ my $line = shift;
+ ## See if this is a heading and we arent printing the entire manpage.
+ if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) {
+ ## Change the title of the SYNOPSIS section to USAGE
+ s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/;
+ ## Try to do some lowercasing instead of all-caps in headings
+ s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
+ ## Use a colon to end all headings
+ s/\s*$/:/ unless (/:\s*$/);
+ $_ .= "\n";
+ }
+ return $self->SUPER::preprocess_paragraph($_);
+}
+
+1; # keep require happy
diff --git a/Master/tlpkg/tlperl.straw/lib/Probe/Perl.pm b/Master/tlpkg/tlperl.straw/lib/Probe/Perl.pm
new file mode 100755
index 00000000000..c2b5e194185
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Probe/Perl.pm
@@ -0,0 +1,272 @@
+package Probe::Perl;
+
+use vars qw( $VERSION );
+$VERSION = '0.01';
+
+use strict;
+
+# TODO: cache values derived from launching an external perl process
+# TODO: docs refer to Config.pm and $self->{config}
+
+
+use Config;
+use File::Spec;
+
+sub new {
+ my $class = shift;
+ my $data = shift || {};
+ return bless( $data, $class );
+}
+
+sub config {
+ my ($self, $key) = (shift, shift);
+ if (@_) {
+ unless (ref $self) {
+ die "Can't set config values via $self->config(). Use $self->new() to create a local view";
+ }
+ $self->{$key} = shift;
+ }
+ return ref($self) && exists $self->{$key} ? $self->{$key} : $Config{$key};
+}
+
+sub config_revert {
+ my $self = shift;
+ die "Can't use config_revert() as a class method" unless ref($self);
+
+ delete $self->{$_} foreach @_;
+}
+
+sub perl_version {
+ my $self = shift;
+ # Check the current perl interpreter
+ # It's much more convenient to use $] here than $^V, but 'man
+ # perlvar' says I'm not supposed to. Bloody tyrant.
+ return $^V ? $self->perl_version_to_float(sprintf( "%vd", $^V )) : $];
+}
+
+sub perl_version_to_float {
+ my ($self, $version) = @_;
+ $version =~ s/\./../; # Double up the first dot so the output has one dot remaining
+ $version =~ s/\.(\d+)/sprintf( '%03d', $1 )/eg;
+ return $version;
+}
+
+sub perl_is_same {
+ my ($self, $perl) = @_;
+ return `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig;
+}
+
+sub find_perl_interpreter {
+ my $self = shift;
+
+ return $^X if File::Spec->file_name_is_absolute($^X);
+
+ my $exe = $self->config('exe_ext');
+
+ my $thisperl = $^X;
+ if ($self->os_type eq 'VMS') {
+ # VMS might have a file version at the end
+ $thisperl .= $exe unless $thisperl =~ m/$exe(;\d+)?$/i;
+ } elsif (defined $exe) {
+ $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
+ }
+
+ foreach my $perl ( $self->config('perlpath'),
+ map( File::Spec->catfile($_, $thisperl),
+ File::Spec->path() )
+ ) {
+ return $perl if -f $perl and $self->perl_is_same($perl);
+ }
+ return;
+}
+
+# Determine the default @INC for this Perl
+sub perl_inc {
+ my $self = shift;
+
+ local $ENV{PERL5LIB}; # this is not considered part of the default.
+
+ my $perl = $self->find_perl_interpreter();
+
+ my @inc = `$perl -l -e print -e for -e \@INC`;
+ chomp @inc;
+
+ return @inc;
+}
+
+
+{
+ my %OSTYPES = qw(
+ aix Unix
+ bsdos Unix
+ dgux Unix
+ dynixptx Unix
+ freebsd Unix
+ linux Unix
+ hpux Unix
+ irix Unix
+ darwin Unix
+ machten Unix
+ next Unix
+ openbsd Unix
+ netbsd Unix
+ dec_osf Unix
+ svr4 Unix
+ svr5 Unix
+ sco_sv Unix
+ unicos Unix
+ unicosmk Unix
+ solaris Unix
+ sunos Unix
+ cygwin Unix
+ os2 Unix
+
+ dos Windows
+ MSWin32 Windows
+
+ os390 EBCDIC
+ os400 EBCDIC
+ posix-bc EBCDIC
+ vmesa EBCDIC
+
+ MacOS MacOS
+ VMS VMS
+ VOS VOS
+ riscos RiscOS
+ amigaos Amiga
+ mpeix MPEiX
+ );
+
+
+ sub os_type {
+ my $class = shift;
+ return $OSTYPES{shift || $^O};
+ }
+}
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Probe::Perl - Information about the currently running perl
+
+=head1 SYNOPSIS
+
+ use Probe::Perl;
+ $p = Probe::Perl->new();
+
+ # Version of this perl as a floating point number
+ $ver = $p->perl_version();
+ $ver = Probe::Perl->perl_version();
+
+ # Convert a multi-dotted string to a floating point number
+ $ver = $p->perl_version_to_float($ver);
+ $ver = Probe::Perl->perl_version_to_float($ver);
+
+ # Check if the given perl is the same as the one currently running
+ $bool = $p->perl_is_same($perl_path);
+ $bool = Probe::Perl->perl_is_same($perl_path);
+
+ # Find a path to the currently-running perl
+ $path = $p->find_perl_interpreter();
+ $path = Probe::Perl->find_perl_interpreter();
+
+ # Get @INC before run-time additions
+ @paths = $p->perl_inc();
+ @paths = Probe::Perl->perl_inc();
+
+ # Get the general type of operating system
+ $type = $p->os_type();
+ $type = Probe::Perl->os_type();
+
+ # Access Config.pm values
+ $val = $p->config('foo');
+ $val = Probe::Perl->config('foo');
+ $p->config('foo' => 'bar'); # Set locally
+ $p->config_revert('foo'); # Revert
+
+=head1 DESCRIPTION
+
+This module provides methods for obtaining information about the
+currently running perl interpreter. It originally began life as code
+in the C<Module::Build> project, but has been externalized here for
+general use.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new Probe::Perl object and returns it. Most methods in
+the Probe::Perl packages are available as class methods, so you
+don't always need to create a new object. But if you want to create a
+mutable view of the C<Config.pm> data, it's necessary to create an
+object to store the values in.
+
+=item config( $key [, $value] )
+
+Returns the C<Config.pm> value associated with C<$key>. If C<$value>
+is also specified, then the value is set to C<$value> for this view of
+the data. In this case, C<config()> must be called as an object
+method, not a class method.
+
+=item config_revert( $key )
+
+Removes any user-assigned value in this view of the C<Config.pm> data.
+
+=item find_perl_interpreter( )
+
+Returns the absolute path of this perl interpreter. This is actually
+sort of a tricky thing to discover sometimes - in these cases we use
+C<perl_is_same()> to verify.
+
+=item perl_version( )
+
+Returns the version of this perl interpreter as a perl-styled version
+number using C<perl_version_to_float()>. Uses C<$^V> if your perl is
+recent enough, otherwise uses C<$]>.
+
+=item perl_version_to_float( $version )
+
+Formats C<$version> as a perl-styled version number like C<5.008001>.
+
+=item perl_is_same( $perl )
+
+Given the name of a perl interpreter, this method determines if it has
+the same configuration as the one represented by the current perl
+instance. Usually this means it's exactly the same
+
+=item perl_inc( )
+
+Returns a list of directories in this perl's C<@INC> path, I<before>
+any entries from C<use lib>, C<$ENV{PERL5LIB}>, or C<-I> switches are
+added.
+
+=item os_type( [$osname] )
+
+Returns a generic OS type (e.g. "Unix", "Windows", "MacOS") for the
+given OS name. If no OS name is given it uses the value in $^O, which
+is the same as $Config{osname}.
+
+=back
+
+=head1 AUTHOR
+
+Randy W. Sims <randys@thepierianspring.org>
+
+Based partly on code from the Module::Build project, by Ken Williams
+<kwilliams@cpan.org> and others.
+
+=head1 COPYRIGHT
+
+Copyright 2005 Ken Williams and Randy Sims. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/SDBM_File.pm b/Master/tlpkg/tlperl.straw/lib/SDBM_File.pm
new file mode 100755
index 00000000000..d1209e0158b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Safe.pm b/Master/tlpkg/tlperl.straw/lib/Safe.pm
new file mode 100755
index 00000000000..fd628deda84
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Safe.pm
@@ -0,0 +1,663 @@
+package Safe;
+
+use 5.003_11;
+use strict;
+use Scalar::Util qw(reftype);
+use Config qw(%Config);
+use constant is_usethreads => $Config{usethreads};
+
+$Safe::VERSION = "2.21";
+
+# *** 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 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
+
+
+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
+ $version::VERSION
+ $version::CLASS
+ $version::STRICT
+ $version::LAX
+ @version::ISA
+], ($] >= 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
+]), ($] >= 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 reval {
+ my ($obj, $expr, $strict) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = lexless_anon_sub($root, $strict, $expr);
+ my @ret = (wantarray)
+ ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
+ : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+
+ # RT#60374: Safe.pm sort {} bug with -Dusethreads
+ # If the Safe eval returns a code ref in a perl compiled with usethreads
+ # then wrap code ref with _safe_call_sv so that, when called, the
+ # execution will happen with the compartment fully 'in effect'.
+ # Needed to fix sort blocks that reference $a & $b and
+ # possibly other subtle issues.
+ if (is_usethreads()) {
+ for my $ret (@ret) { # edit (via alias) any CODE refs
+ next unless (reftype($ret)||'') eq 'CODE';
+ my $sub = $ret; # avoid closure problems
+ $ret = sub {
+ my @args = @_; # lexical to close over
+ my $sub_with_args = sub { $sub->(@args) };
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $sub_with_args)
+ };
+ }
+ }
+
+ return (wantarray) ? @ret : $ret[0];
+}
+
+sub rdo {
+ my ($obj, $file) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = eval
+ sprintf('package %s; sub { @_ = (); do $file }', $root);
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+
+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>.
+
+
+=head2 RECENT CHANGES
+
+The interface to the Safe module has changed quite dramatically since
+version 1 (as supplied with Perl5.002). Study these pages carefully if
+you have code written to use Safe version 1 because you will need to
+makes changes.
+
+
+=head2 Methods in class Safe
+
+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.
+
+
+=over 8
+
+=item 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">.
+
+=item permit_only (OP, ...)
+
+Permit I<only> the listed operators to be used when compiling code in
+the compartment (I<no> other operators are permitted).
+
+=item deny (OP, ...)
+
+Deny the listed operators from being used when compiling code in the
+compartment (other operators may still be permitted).
+
+=item 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).
+
+=item trap (OP, ...)
+
+=item untrap (OP, ...)
+
+The trap and untrap methods are synonyms for deny and permit
+respectfully.
+
+=item 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 share uses).
+
+=item 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' ]);
+
+
+=item 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 = new Safe 'Root';
+ $Root::foo = "Hello world";
+ # Equivalent version which doesn't need to know $cpt's package name:
+ ${$cpt->varglob('foo')} = "Hello world";
+
+
+=item 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.
+
+This behaviour differs from the beta distribution of the Safe extension
+where earlier versions of perl made it hard to mimic the return
+behaviour of the eval() command and the context was always scalar.
+
+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.
+
+
+
+=item rdo (FILENAME)
+
+This evaluates the contents of file FILENAME inside the compartment.
+See above documentation on the B<reval> method for further details.
+
+=item 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.
+
+=item 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).
+
+=back
+
+
+=head2 Some Safety Issues
+
+This section is currently 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
+
+=head2 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.straw/lib/SelfLoader.pm b/Master/tlpkg/tlperl.straw/lib/SelfLoader.pm
new file mode 100755
index 00000000000..047f7768e89
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Shell.pm b/Master/tlpkg/tlperl.straw/lib/Shell.pm
new file mode 100755
index 00000000000..72c7ec21376
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Sort/Versions.pm b/Master/tlpkg/tlperl.straw/lib/Sort/Versions.pm
new file mode 100755
index 00000000000..56a1ed10c37
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Sort/Versions.pm
@@ -0,0 +1,151 @@
+#!/usr/bin/perl
+
+# $Id: Versions.pm,v 1.9 2003/08/24 22:58:14 ed Exp $
+
+# Copyright (c) 1996, Kenneth J. Albanowski. All rights reserved. This
+# program is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself.
+
+package Sort::Versions;
+use vars '$VERSION';
+$VERSION = '1.5';
+
+require Exporter;
+@ISA=qw(Exporter);
+
+@EXPORT=qw(&versions &versioncmp);
+@EXPORT_OK=qw();
+
+sub versioncmp( $$ ) {
+ my @A = ($_[0] =~ /([-.]|\d+|[^-.\d]+)/g);
+ my @B = ($_[1] =~ /([-.]|\d+|[^-.\d]+)/g);
+
+ my ($A, $B);
+ while (@A and @B) {
+ $A = shift @A;
+ $B = shift @B;
+ if ($A eq '-' and $B eq '-') {
+ next;
+ } elsif ( $A eq '-' ) {
+ return -1;
+ } elsif ( $B eq '-') {
+ return 1;
+ } elsif ($A eq '.' and $B eq '.') {
+ next;
+ } elsif ( $A eq '.' ) {
+ return -1;
+ } elsif ( $B eq '.' ) {
+ return 1;
+ } elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/) {
+ if ($A =~ /^0/ || $B =~ /^0/) {
+ return $A cmp $B if $A cmp $B;
+ } else {
+ return $A <=> $B if $A <=> $B;
+ }
+ } else {
+ $A = uc $A;
+ $B = uc $B;
+ return $A cmp $B if $A cmp $B;
+ }
+ }
+ @A <=> @B;
+}
+
+sub versions() {
+ my $callerpkg = (caller)[0];
+ my $caller_a = "${callerpkg}::a";
+ my $caller_b = "${callerpkg}::b";
+ no strict 'refs';
+ return versioncmp($$caller_a, $$caller_b);
+}
+
+=head1 NAME
+
+Sort::Versions - a perl 5 module for sorting of revision-like numbers
+
+=head1 SYNOPSIS
+
+ use Sort::Versions;
+ @l = sort { versioncmp($a, $b) } qw( 1.2 1.2.0 1.2a.0 1.2.a 1.a 02.a );
+
+ ...
+
+ use Sort::Versions;
+ print 'lower' if versioncmp('1.2', '1.2a') == -1;
+
+ ...
+
+ use Sort::Versions;
+ %h = (1 => 'd', 2 => 'c', 3 => 'b', 4 => 'a');
+ @h = sort { versioncmp($h{$a}, $h{$b}) } keys %h;
+
+=head1 DESCRIPTION
+
+Sort::Versions allows easy sorting of mixed non-numeric and numeric strings,
+like the 'version numbers' that many shared library systems and revision
+control packages use. This is quite useful if you are trying to deal with
+shared libraries. It can also be applied to applications that intersperse
+variable-width numeric fields within text. Other applications can
+undoubtedly be found.
+
+For an explanation of the algorithm, itE<39>s simplest to look at these examples:
+
+ 1.1 < 1.2
+ 1.1a < 1.2
+ 1.1 < 1.1.1
+ 1.1 < 1.1a
+ 1.1.a < 1.1a
+ 1 < a
+ a < b
+ 1 < 2
+ 1.1-3 < 1.1-4
+ 1.1-5 < 1.1.6
+
+More precisely (but less comprehensibly), the two strings are treated
+as subunits delimited by periods or hyphens. Each subunit can contain
+any number of groups of digits or non-digits. If digit groups are
+being compared on both sides, a numeric comparison is used, otherwise
+a ASCII ordering is used. A group or subgroup with more units will win
+if all comparisons are equal. A period binds digit groups together
+more tightly than a hyphen.
+
+Some packages use a different style of version numbering: a simple
+real number written as a decimal. Sort::Versions has limited support
+for this style: when comparing two subunits which are both digit
+groups, if either subunit has a leading zero, then both are treated
+like digits after a decimal point. So for example:
+
+ 0002 < 1
+ 1.06 < 1.5
+
+This wonE<39>t always work, because there wonE<39>t always be a leading zero
+in real-number style version numbers. There is no way for
+Sort::Versions to know which style was intended. But a lot of the time
+it will do the right thing. If you are making up version numbers, the
+style with (possibly) more than one dot is the style to use.
+
+=head1 USAGE
+
+The function C<versioncmp()> takes two arguments and compares them like C<cmp>.
+With perl 5.6 or later, you can also use this function directly in sorting:
+
+ @l = sort versioncmp qw(1.1 1.2 1.0.3);
+
+The function C<versions()> can be used directly as a sort function even on
+perl 5.005 and earlier, but its use is deprecated.
+
+=head1 AUTHOR
+
+Ed Avis <ed@membled.com> and Matt Johnson <mwj99@doc.ic.ac.uk> for
+recent releases; the original author is Kenneth J. Albanowski
+<kjahds@kjahds.com>. Thanks to Hack Kampbjørn and Slaven Rezic for
+patches and bug reports.
+
+Copyright (c) 1996, Kenneth J. Albanowski. All rights reserved. This
+program is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+=cut
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Storable.pm b/Master/tlpkg/tlperl.straw/lib/Storable.pm
new file mode 100755
index 00000000000..2b1acb4ea92
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.21';
+*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, 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.straw/lib/Sys/Hostname.pm b/Master/tlpkg/tlperl.straw/lib/Sys/Hostname.pm
new file mode 100755
index 00000000000..415f9517fa4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Sys/Hostname.pm
@@ -0,0 +1,165 @@
+package Sys::Hostname;
+
+use strict;
+
+use Carp;
+
+require Exporter;
+require AutoLoader;
+
+our @ISA = qw/ Exporter AutoLoader /;
+our @EXPORT = qw/ hostname /;
+
+our $VERSION;
+
+our $host;
+
+BEGIN {
+ $VERSION = '1.11';
+ {
+ local $SIG{__DIE__};
+ eval {
+ require XSLoader;
+ XSLoader::load('Sys::Hostname', $VERSION);
+ };
+ warn $@ if $@;
+ }
+}
+
+
+sub hostname {
+
+ # method 1 - we already know it
+ return $host if defined $host;
+
+ # method 1' - try to ask the system
+ $host = ghname() if defined &ghname;
+ return $host if defined $host;
+
+ if ($^O eq 'VMS') {
+
+ # method 2 - no sockets ==> return DECnet node name
+ eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] };
+ if ($@) { return $host = $ENV{'SYS$NODE'}; }
+
+ # method 3 - has someone else done the job already? It's common for the
+ # TCP/IP stack to advertise the hostname via a logical name. (Are
+ # there any other logicals which TCP/IP stacks use for the host name?)
+ $host = $ENV{'ARPANET_HOST_NAME'} || $ENV{'INTERNET_HOST_NAME'} ||
+ $ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'} ||
+ $ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'};
+ return $host if $host;
+
+ # method 4 - does hostname happen to work?
+ my($rslt) = `hostname`;
+ if ($rslt !~ /IVVERB/) { ($host) = $rslt =~ /^(\S+)/; }
+ return $host if $host;
+
+ # rats!
+ $host = '';
+ croak "Cannot get host name of local machine";
+
+ }
+ elsif ($^O eq 'MSWin32') {
+ ($host) = gethostbyname('localhost');
+ chomp($host = `hostname 2> NUL`) unless defined $host;
+ return $host;
+ }
+ elsif ($^O eq 'epoc') {
+ $host = 'localhost';
+ return $host;
+ }
+ else { # Unix
+ # is anyone going to make it here?
+
+ local $ENV{PATH} = '/usr/bin:/bin:/usr/sbin:/sbin'; # Paranoia.
+
+ # method 2 - syscall is preferred since it avoids tainting problems
+ # XXX: is it such a good idea to return hostname untainted?
+ eval {
+ local $SIG{__DIE__};
+ require "syscall.ph";
+ $host = "\0" x 65; ## preload scalar
+ syscall(&SYS_gethostname, $host, 65) == 0;
+ }
+
+ # method 2a - syscall using systeminfo instead of gethostname
+ # -- needed on systems like Solaris
+ || eval {
+ local $SIG{__DIE__};
+ require "sys/syscall.ph";
+ require "sys/systeminfo.ph";
+ $host = "\0" x 65; ## preload scalar
+ syscall(&SYS_systeminfo, &SI_HOSTNAME, $host, 65) != -1;
+ }
+
+ # method 3 - trusty old hostname command
+ || eval {
+ local $SIG{__DIE__};
+ local $SIG{CHLD};
+ $host = `(hostname) 2>/dev/null`; # bsdish
+ }
+
+ # method 4 - use POSIX::uname(), which strictly can't be expected to be
+ # correct
+ || eval {
+ local $SIG{__DIE__};
+ require POSIX;
+ $host = (POSIX::uname())[1];
+ }
+
+ # method 5 - sysV uname command (may truncate)
+ || eval {
+ local $SIG{__DIE__};
+ $host = `uname -n 2>/dev/null`; ## sysVish
+ }
+
+ # method 6 - Apollo pre-SR10
+ || eval {
+ local $SIG{__DIE__};
+ my($a,$b,$c,$d);
+ ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6);
+ }
+
+ # bummer
+ || croak "Cannot get host name of local machine";
+
+ # remove garbage
+ $host =~ tr/\0\r\n//d;
+ $host;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Sys::Hostname - Try every conceivable way to get hostname
+
+=head1 SYNOPSIS
+
+ use Sys::Hostname;
+ $host = hostname;
+
+=head1 DESCRIPTION
+
+Attempts several methods of getting the system hostname and
+then caches the result. It tries the first available of the C
+library's gethostname(), C<`$Config{aphostname}`>, uname(2),
+C<syscall(SYS_gethostname)>, C<`hostname`>, C<`uname -n`>,
+and the file F</com/host>. If all that fails it C<croak>s.
+
+All NULs, returns, and newlines are removed from the result.
+
+=head1 AUTHOR
+
+David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt>
+
+Texas Instruments
+
+XS code added by Greg Bacon E<lt>F<gbacon@cs.uah.edu>E<gt>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Base.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Base.pm
new file mode 100755
index 00000000000..62a2c372118
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Base.pm
@@ -0,0 +1,129 @@
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser>
+and L<TAP::Harness>
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+use constant GOT_TIME_HIRES => do {
+ eval 'use Time::HiRes qw(time);';
+ $@ ? 0 : 1;
+};
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
+
+ # ... later ...
+
+ my $thing = TAP::Whatever->new();
+
+ $thing->callback( event => sub {
+ # do something interesting
+ } );
+
+=head1 DESCRIPTION
+
+C<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for, $ok_callback ) = @_;
+
+ my %ok_map = map { $_ => 1 } @$ok_callback;
+
+ $self->{ok_callbacks} = \%ok_map;
+
+ if ( my $cb = delete $arg_for->{callbacks} ) {
+ while ( my ( $event, $callback ) = each %$cb ) {
+ $self->callback( $event, $callback );
+ }
+ }
+
+ return $self;
+}
+
+=head3 C<callback>
+
+Install a callback for a named event.
+
+=cut
+
+sub callback {
+ my ( $self, $event, $callback ) = @_;
+
+ my %ok_map = %{ $self->{ok_callbacks} };
+
+ $self->_croak('No callbacks may be installed')
+ unless %ok_map;
+
+ $self->_croak( "Callback $event is not supported. Valid callbacks are "
+ . join( ', ', sort keys %ok_map ) )
+ unless exists $ok_map{$event};
+
+ push @{ $self->{code_for}{$event} }, $callback;
+
+ return;
+}
+
+sub _has_callbacks {
+ my $self = shift;
+ return keys %{ $self->{code_for} } != 0;
+}
+
+sub _callback_for {
+ my ( $self, $event ) = @_;
+ return $self->{code_for}{$event};
+}
+
+sub _make_callback {
+ my $self = shift;
+ my $event = shift;
+
+ my $cb = $self->_callback_for($event);
+ return unless defined $cb;
+ return map { $_->(@_) } @$cb;
+}
+
+=head3 C<get_time>
+
+Return the current time using Time::HiRes if available.
+
+=cut
+
+sub get_time { return time() }
+
+=head3 C<time_is_hires>
+
+Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
+
+=cut
+
+sub time_is_hires { return GOT_TIME_HIRES }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Base.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Base.pm
new file mode 100755
index 00000000000..43ac59621e9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Base.pm
@@ -0,0 +1,449 @@
+package TAP::Formatter::Base;
+
+use strict;
+use TAP::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+my $MAX_ERRORS = 5;
+my %VALIDATION_FOR;
+
+BEGIN {
+ @ISA = qw(TAP::Base);
+
+ %VALIDATION_FOR = (
+ directives => sub { shift; shift },
+ verbosity => sub { shift; shift },
+ normalize => sub { shift; shift },
+ timer => sub { shift; shift },
+ failures => sub { shift; shift },
+ comments => sub { shift; shift },
+ errors => sub { shift; shift },
+ color => sub { shift; shift },
+ jobs => sub { shift; shift },
+ show_count => sub { shift; shift },
+ stdout => sub {
+ my ( $self, $ref ) = @_;
+ $self->_croak("option 'stdout' needs a filehandle")
+ unless ( ref $ref || '' ) eq 'GLOB'
+ or eval { $ref->can('print') };
+ return $ref;
+ },
+ );
+
+ my @getter_setters = qw(
+ _longest
+ _printed_summary_header
+ _colorizer
+ );
+
+ __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
+}
+
+=head1 NAME
+
+TAP::Formatter::Base - Base class for harness output delegates
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ $self->verbosity(0);
+
+ for my $name ( keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+ $self->$name( $self->$validate($property) );
+ }
+ }
+
+ if ( my @props = keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ $self->stdout( \*STDOUT ) unless $self->stdout;
+
+ if ( $self->color ) {
+ require TAP::Formatter::Color;
+ $self->_colorizer( TAP::Formatter::Color->new );
+ }
+
+ return $self;
+}
+
+sub verbose { shift->verbosity >= 1 }
+sub quiet { shift->verbosity <= -1 }
+sub really_quiet { shift->verbosity <= -2 }
+sub silent { shift->verbosity <= -3 }
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbose => 1,
+ )
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console> object. If
+a L<TAP::Harness> is created with no C<formatter> a
+C<TAP::Formatter::Console> is automatically created. If any of the
+following options were given to TAP::Harness->new they well be passed to
+this constructor which accepts an optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level.
+
+=item * C<verbose>
+
+Printing individual test results to STDOUT.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (this is a no-op if C<verbose> is selected).
+
+=item * C<quiet>
+
+Suppressing some test output (mostly failures while tests are running).
+
+=item * C<really_quiet>
+
+Suppressing everything but the tests summary.
+
+=item * C<silent>
+
+Suppressing all output.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be made
+in the summary report. To see all of the parse errors, set this argument to
+true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose>, C<failures>, or C<comments>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> is not
+defined it will default to color output if color support is available on
+the current platform and output is not being redirected.
+
+=item * C<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+Called by Test::Harness before any test output is generated.
+
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ for my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ }
+
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";
+
+ if ( $self->timer ) {
+ my $stamp = $self->_format_now();
+ return "$stamp $name$periods";
+ }
+ else {
+ return "$name$periods";
+ }
+
+}
+
+=head3 C<open_test>
+
+Called to create a new test session. A test session looks like this:
+
+ my $session = $formatter->open_test( $test, $parser );
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+ $session->close_test;
+
+=cut
+
+sub open_test {
+ die "Unimplemented.";
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_output($msg);
+}
+
+=head3 C<summary>
+
+ $harness->summary( $aggregate );
+
+C<summary> prints the summary report after all tests are run. The argument is
+an aggregate.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+
+ return if $self->silent;
+
+ my @t = $aggregate->descriptions;
+ my $tests = \@t;
+
+ my $runtime = $aggregate->elapsed_timestr;
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+
+ if ( $self->timer ) {
+ $self->_output( $self->_format_now(), "\n" );
+ }
+
+ # TODO: Check this condition still works when all subtests pass but
+ # the exit status is nonzero
+
+ if ( $aggregate->all_passed ) {
+ $self->_output_success("All tests successful.\n");
+ }
+
+ # ~TODO option where $aggregate->skipped generates reports
+ if ( $total != $passed or $aggregate->has_problems ) {
+ $self->_output("\nTest Summary Report");
+ $self->_output("\n-------------------\n");
+ for my $test (@$tests) {
+ $self->_printed_summary_header(0);
+ my ($parser) = $aggregate->parsers($test);
+ $self->_output_summary_failure(
+ 'failed',
+ [ ' Failed test: ', ' Failed tests: ' ],
+ $test, $parser
+ );
+ $self->_output_summary_failure(
+ 'todo_passed',
+ " TODO passed: ", $test, $parser
+ );
+
+ # ~TODO this cannot be the default
+ #$self->_output_summary_failure( 'skipped', " Tests skipped: " );
+
+ if ( my $exit = $parser->exit ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero exit status: $exit\n");
+ }
+ elsif ( my $wait = $parser->wait ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero wait status: $wait\n");
+ }
+
+ if ( my @errors = $parser->parse_errors ) {
+ my $explain;
+ if ( @errors > $MAX_ERRORS && !$self->errors ) {
+ $explain
+ = "Displayed the first $MAX_ERRORS of "
+ . scalar(@errors)
+ . " TAP syntax errors.\n"
+ . "Re-run prove with the -p option to see them all.\n";
+ splice @errors, $MAX_ERRORS;
+ }
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(
+ sprintf " Parse errors: %s\n",
+ shift @errors
+ );
+ for my $error (@errors) {
+ my $spaces = ' ' x 16;
+ $self->_failure_output("$spaces$error\n");
+ }
+ $self->_failure_output($explain) if $explain;
+ }
+ }
+ }
+ my $files = @$tests;
+ $self->_output("Files=$files, Tests=$total, $runtime\n");
+ my $status = $aggregate->get_status;
+ $self->_output("Result: $status\n");
+}
+
+sub _output_summary_failure {
+ my ( $self, $method, $name, $test, $parser ) = @_;
+
+ # ugly hack. Must rethink this :(
+ my $output = $method eq 'failed' ? '_failure_output' : '_output';
+
+ if ( my @r = $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ my ( $singular, $plural )
+ = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
+ $self->$output( @r == 1 ? $singular : $plural );
+ my @results = $self->_balanced_range( 40, @r );
+ $self->$output( sprintf "%s\n" => shift @results );
+ my $spaces = ' ' x 16;
+ while (@results) {
+ $self->$output( sprintf "$spaces%s\n" => shift @results );
+ }
+ }
+}
+
+sub _summary_test_header {
+ my ( $self, $test, $parser ) = @_;
+ return if $self->_printed_summary_header;
+ my $spaces = ' ' x ( $self->_longest - length $test );
+ $spaces = ' ' unless $spaces;
+ my $output = $self->_get_output_method($parser);
+ $self->$output(
+ sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
+ $parser->wait, $parser->tests_run, scalar $parser->failed
+ );
+ $self->_printed_summary_header(1);
+}
+
+sub _output {
+ my $self = shift;
+
+ print { $self->stdout } @_;
+}
+
+sub _failure_output {
+ my $self = shift;
+
+ $self->_output(@_);
+}
+
+sub _balanced_range {
+ my ( $self, $limit, @range ) = @_;
+ @range = $self->_range(@range);
+ my $line = "";
+ my @lines;
+ my $curr = 0;
+ while (@range) {
+ if ( $curr < $limit ) {
+ my $range = ( shift @range ) . ", ";
+ $line .= $range;
+ $curr += length $range;
+ }
+ elsif (@range) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ $line = '';
+ $curr = 0;
+ }
+ }
+ if ($line) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ }
+ return @lines;
+}
+
+sub _range {
+ my ( $self, @numbers ) = @_;
+
+ # shouldn't be needed, but subclasses might call this
+ @numbers = sort { $a <=> $b } @numbers;
+ my ( $min, @range );
+
+ for my $i ( 0 .. $#numbers ) {
+ my $num = $numbers[$i];
+ my $next = $numbers[ $i + 1 ];
+ if ( defined $next && $next == $num + 1 ) {
+ if ( !defined $min ) {
+ $min = $num;
+ }
+ }
+ elsif ( defined $min ) {
+ push @range => "$min-$num";
+ undef $min;
+ }
+ else {
+ push @range => $num;
+ }
+ }
+ return @range;
+}
+
+sub _get_output_method {
+ my ( $self, $parser ) = @_;
+ return $parser->has_problems ? '_failure_output' : '_output';
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Color.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Color.pm
new file mode 100755
index 00000000000..75fcb8c73e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Color.pm
@@ -0,0 +1,148 @@
+package TAP::Formatter::Color;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+
+@ISA = qw(TAP::Object);
+
+my $NO_COLOR;
+
+BEGIN {
+ $NO_COLOR = 0;
+
+ if (IS_WIN32) {
+ eval 'use Win32::Console';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
+
+ # eval here because we might not know about these variables
+ my $fg = eval '$FG_LIGHTGRAY';
+ my $bg = eval '$BG_BLACK';
+
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+
+ my $var;
+ if ( $color eq 'reset' ) {
+ $fg = eval '$FG_LIGHTGRAY';
+ $bg = eval '$BG_BLACK';
+ }
+ elsif ( $color =~ /^on_(.+)$/ ) {
+ $bg = eval '$BG_' . uc($1);
+ }
+ else {
+ $fg = eval '$FG_' . uc($color);
+ }
+
+ # In case of colors that aren't defined
+ $self->set_color('reset')
+ unless defined $bg && defined $fg;
+
+ $console->Attr( $bg | $fg );
+ };
+ }
+ }
+ else {
+ eval 'use Term::ANSIColor';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+ $output->( color($color) );
+ };
+ }
+ }
+
+ if ($NO_COLOR) {
+ *set_color = sub { };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Color - Run Perl test scripts with color
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+Note that this harness is I<experimental>. You may not like the colors I've
+chosen and I haven't yet provided an easy way to override them.
+
+This test harness is the same as L<TAP::Harness>, but test results are output
+in color. Passing tests are printed in green. Failing tests are in red.
+Skipped tests are blue on a white background and TODO tests are printed in
+white.
+
+If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running
+under Windows) tests will be run without color.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Color;
+ my $harness = TAP::Formatter::Color->new( \%args );
+ $harness->runtests(@tests);
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor returns a new C<TAP::Formatter::Color> object. If
+L<Term::ANSIColor> is not installed, returns undef.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+
+ if ($NO_COLOR) {
+
+ # shorten that message a bit
+ ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
+ warn "Note: Cannot run tests in color: $error\n";
+ return; # abort object construction
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<can_color>
+
+ Test::Formatter::Color->can_color()
+
+Returns a boolean indicating whether or not this module can actually
+generate colored output. This will be false if it could not load the
+modules needed for the current platform.
+
+=cut
+
+sub can_color {
+ return !$NO_COLOR;
+}
+
+=head3 C<set_color>
+
+Set the output color.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console.pm
new file mode 100755
index 00000000000..ff6587ef8ac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console.pm
@@ -0,0 +1,91 @@
+package TAP::Formatter::Console;
+
+use strict;
+use TAP::Formatter::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::Base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $class
+ = $self->jobs > 1
+ ? 'TAP::Formatter::Console::ParallelSession'
+ : 'TAP::Formatter::Console::Session';
+
+ eval "require $class";
+ $self->_croak($@) if $@;
+
+ my $session = $class->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ show_count => $self->show_count,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+# Use _colorizer delegate to set output color. NOP if we have no delegate
+sub _set_colors {
+ my ( $self, @colors ) = @_;
+ if ( my $colorizer = $self->_colorizer ) {
+ my $output_func = $self->{_output_func} ||= sub {
+ $self->_output(@_);
+ };
+ $colorizer->set_color( $output_func, $_ ) for @colors;
+ }
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_set_colors('green');
+ $self->_output($msg);
+ $self->_set_colors('reset');
+}
+
+sub _failure_output {
+ my $self = shift;
+ $self->_set_colors('red');
+ my $out = join '', @_;
+ my $has_newline = chomp $out;
+ $self->_output($out);
+ $self->_set_colors('reset');
+ $self->_output($/)
+ if $has_newline;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/ParallelSession.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/ParallelSession.pm
new file mode 100755
index 00000000000..a85a82cc4d9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/ParallelSession.pm
@@ -0,0 +1,202 @@
+package TAP::Formatter::Console::ParallelSession;
+
+use strict;
+use File::Spec;
+use File::Path;
+use TAP::Formatter::Console::Session;
+use Carp;
+
+use constant WIDTH => 72; # Because Eric says
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Console::Session);
+
+my %shared;
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ $self->SUPER::_initialize($arg_for);
+ my $formatter = $self->formatter;
+
+ # Horrid bodge. This creates our shared context per harness. Maybe
+ # TAP::Harness should give us this?
+ my $context = $shared{$formatter} ||= $self->_create_shared_context;
+ push @{ $context->{active} }, $self;
+
+ return $self;
+}
+
+sub _create_shared_context {
+ my $self = shift;
+ return {
+ active => [],
+ tests => 0,
+ fails => 0,
+ };
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for L<TAP::Harness>
+when run with multiple L<TAP::Harness/jobs>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+Output test preamble
+
+=cut
+
+sub header {
+}
+
+sub _clear_ruler {
+ my $self = shift;
+ $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
+}
+
+my $now = 0;
+my $start;
+
+my $trailer = '... )===';
+my $chop_length = WIDTH - length $trailer;
+
+sub _output_ruler {
+ my ( $self, $refresh ) = @_;
+ my $new_now = time;
+ return if $new_now == $now and !$refresh;
+ $now = $new_now;
+ $start ||= $now;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $context = $shared{$formatter};
+
+ my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start;
+
+ for my $active ( @{ $context->{active} } ) {
+ my $parser = $active->parser;
+ my $tests = $parser->tests_run;
+ my $planned = $parser->tests_planned || '?';
+
+ $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests;
+ }
+ chop $ruler; # Remove a trailing space
+ $ruler .= ')===';
+
+ if ( length $ruler > WIDTH ) {
+ $ruler =~ s/(.{$chop_length}).*/$1$trailer/o;
+ }
+ else {
+ $ruler .= '=' x ( WIDTH - length($ruler) );
+ }
+ $formatter->_output("\r$ruler");
+}
+
+=head3 C<result>
+
+ Called by the harness for each line of TAP it receives .
+
+=cut
+
+sub result {
+ my ( $self, $result ) = @_;
+ my $formatter = $self->formatter;
+
+ # my $really_quiet = $formatter->really_quiet;
+ # my $show_count = $self->_should_show_count;
+
+ if ( $result->is_test ) {
+ my $context = $shared{$formatter};
+ $context->{tests}++;
+
+ my $active = $context->{active};
+ if ( @$active == 1 ) {
+
+ # There is only one test, so use the serial output format.
+ return $self->SUPER::result($result);
+ }
+
+ $self->_output_ruler( $self->parser->tests_run == 1 );
+ }
+ elsif ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+}
+
+=head3 C<clear_for_close>
+
+=cut
+
+sub clear_for_close {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+ my $context = $shared{$formatter};
+ if ( @{ $context->{active} } == 1 ) {
+ $self->SUPER::clear_for_close;
+ }
+ else {
+ $self->_clear_ruler;
+ }
+}
+
+=head3 C<close_test>
+
+=cut
+
+sub close_test {
+ my $self = shift;
+ my $name = $self->name;
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ $self->SUPER::close_test;
+
+ my $active = $context->{active};
+
+ my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
+
+ die "Can't find myself" unless @pos;
+ splice @$active, $pos[0], 1;
+
+ if ( @$active > 1 ) {
+ $self->_output_ruler(1);
+ }
+ elsif ( @$active == 1 ) {
+
+ # Print out "test/name.t ...."
+ $active->[0]->SUPER::header;
+ }
+ else {
+
+ # $self->formatter->_output("\n");
+ delete $shared{$formatter};
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/Session.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/Session.pm
new file mode 100755
index 00000000000..d125e3d14d4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Console/Session.pm
@@ -0,0 +1,219 @@
+package TAP::Formatter::Console::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+my @ACCESSOR;
+
+BEGIN {
+ my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
+
+ for my $method (@CLOSURE_BINDING) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return ( $self->{_closures} ||= $self->_closures )->{$method}
+ ->(@_);
+ };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::Session - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=cut
+
+sub _get_output_result {
+ my $self = shift;
+
+ my @color_map = (
+ { test => sub { $_->is_test && !$_->is_ok },
+ colors => ['red'],
+ },
+ { test => sub { $_->is_test && $_->has_skip },
+ colors => [
+ 'white',
+ 'on_blue'
+ ],
+ },
+ { test => sub { $_->is_test && $_->has_todo },
+ colors => ['yellow'],
+ },
+ );
+
+ my $formatter = $self->formatter;
+ my $parser = $self->parser;
+
+ return $formatter->_colorizer
+ ? sub {
+ my $result = shift;
+ for my $col (@color_map) {
+ local $_ = $result;
+ if ( $col->{test}->() ) {
+ $formatter->_set_colors( @{ $col->{colors} } );
+ last;
+ }
+ }
+ $formatter->_output( $self->_format_for_output($result) );
+ $formatter->_set_colors('reset');
+ }
+ : sub {
+ $formatter->_output( $self->_format_for_output(shift) );
+ };
+}
+
+sub _closures {
+ my $self = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+ my $show_count = $self->show_count;
+
+ my $really_quiet = $formatter->really_quiet;
+ my $quiet = $formatter->quiet;
+ my $verbose = $formatter->verbose;
+ my $directives = $formatter->directives;
+ my $failures = $formatter->failures;
+ my $comments = $formatter->comments;
+
+ my $output_result = $self->_get_output_result;
+
+ my $output = '_output';
+ my $plan = '';
+ my $newline_printed = 0;
+
+ my $last_status_printed = 0;
+
+ return {
+ header => sub {
+ $formatter->_output($pretty)
+ unless $really_quiet;
+ },
+
+ result => sub {
+ my $result = shift;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ return if $really_quiet;
+
+ my $is_test = $result->is_test;
+
+ # These are used in close_test - but only if $really_quiet
+ # is false - so it's safe to only set them here unless that
+ # relationship changes.
+
+ if ( !$plan ) {
+ my $planned = $parser->tests_planned || '?';
+ $plan = "/$planned ";
+ }
+ $output = $formatter->_get_output_method($parser);
+
+ if ( $show_count and $is_test ) {
+ my $number = $result->number;
+ my $now = CORE::time;
+
+ # Print status roughly once per second.
+ # We will always get the first number as a side effect of
+ # $last_status_printed starting with the value 0, which $now
+ # will never be. (Unless someone sets their clock to 1970)
+ if ( $last_status_printed != $now ) {
+ $formatter->$output("\r$pretty$number$plan");
+ $last_status_printed = $now;
+ }
+ }
+
+ if (!$quiet
+ && ( $verbose
+ || ( $is_test && $failures && !$result->is_ok )
+ || ( $comments && $result->is_comment )
+ || ( $directives && $result->has_directive ) )
+ )
+ {
+ unless ($newline_printed) {
+ $formatter->_output("\n");
+ $newline_printed = 1;
+ }
+ $output_result->($result);
+ $formatter->_output("\n");
+ }
+ },
+
+ clear_for_close => sub {
+ my $spaces
+ = ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
+ $formatter->$output("\r$spaces");
+ },
+
+ close_test => sub {
+ if ( $show_count && !$really_quiet ) {
+ $self->clear_for_close;
+ $formatter->$output("\r$pretty");
+ }
+
+ # Avoid circular references
+ $self->parser(undef);
+ $self->{_closures} = {};
+
+ return if $really_quiet;
+
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output("skipped: $skip_all\n");
+ }
+ elsif ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output("ok$time_report\n");
+ }
+ },
+ };
+}
+
+=head2 C<< clear_for_close >>
+
+=head2 C<< close_test >>
+
+=head2 C<< header >>
+
+=head2 C<< result >>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/File.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/File.pm
new file mode 100755
index 00000000000..6cca9f2f56d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/File.pm
@@ -0,0 +1,58 @@
+package TAP::Formatter::File;
+
+use strict;
+use TAP::Formatter::Base ();
+use TAP::Formatter::File::Session;
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::File - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::File;
+ my $harness = TAP::Formatter::File->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $session = TAP::Formatter::File::Session->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+sub _should_show_count {
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/File/Session.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/File/Session.pm
new file mode 100755
index 00000000000..93a1aaed269
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/File/Session.pm
@@ -0,0 +1,110 @@
+package TAP::Formatter::File::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+=head1 NAME
+
+TAP::Formatter::File::Session - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for L<TAP::Harness>.
+It is particularly important when running with parallel tests, as it
+ensures that test results are not interleaved, even when run
+verbosely.
+
+=cut
+
+=head1 METHODS
+
+=head2 result
+
+Stores results for later output, all together.
+
+=cut
+
+sub result {
+ my $self = shift;
+ my $result = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ return;
+ }
+
+ if (!$formatter->quiet
+ && ( $formatter->verbose
+ || ( $result->is_test && $formatter->failures && !$result->is_ok )
+ || ( $formatter->comments && $result->is_comment )
+ || ( $result->has_directive && $formatter->directives ) )
+ )
+ {
+ $self->{results} .= $self->_format_for_output($result) . "\n";
+ }
+}
+
+=head2 close_test
+
+When the test file finishes, outputs the summary, together.
+
+=cut
+
+sub close_test {
+ my $self = shift;
+
+ # Avoid circular references
+ $self->parser(undef);
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+
+ return if $formatter->really_quiet;
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output( $pretty . "skipped: $skip_all\n" );
+ }
+ elsif ( $parser->has_problems ) {
+ $formatter->_output(
+ $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) );
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output( $pretty
+ . ( $self->{results} ? "\n" . $self->{results} : "" )
+ . "ok$time_report\n" );
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Session.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Session.pm
new file mode 100755
index 00000000000..4bff7111522
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Formatter/Session.pm
@@ -0,0 +1,183 @@
+package TAP::Formatter::Session;
+
+use strict;
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+my @ACCESSOR;
+
+BEGIN {
+
+ @ACCESSOR = qw( name formatter parser show_count );
+
+ for my $method (@ACCESSOR) {
+ no strict 'refs';
+ *$method = sub { shift->{$method} };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Session - Abstract base class for harness output delegate
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=item * C<show_count>
+
+=back
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name (@ACCESSOR) {
+ $self->{$name} = delete $arg_for{$name};
+ }
+
+ if ( !defined $self->show_count ) {
+ $self->{show_count} = 1; # defaults to true
+ }
+ if ( $self->show_count ) { # but may be a damned lie!
+ $self->{show_count} = $self->_should_show_count;
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ return $self;
+}
+
+=head3 C<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+Called to close a test session.
+
+=head3 C<clear_for_close>
+
+Called by C<close_test> to clear the line showing test progress, or the parallel
+test ruler, prior to printing the final test result.
+
+=cut
+
+sub header { }
+
+sub result { }
+
+sub close_test { }
+
+sub clear_for_close { }
+
+sub _should_show_count {
+ my $self = shift;
+ return
+ !$self->formatter->verbose
+ && -t $self->formatter->stdout
+ && !$ENV{HARNESS_NOTTY};
+}
+
+sub _format_for_output {
+ my ( $self, $result ) = @_;
+ return $self->formatter->normalize ? $result->as_string : $result->raw;
+}
+
+sub _output_test_failure {
+ my ( $self, $parser ) = @_;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $tests_run = $parser->tests_run;
+ my $tests_planned = $parser->tests_planned;
+
+ my $total
+ = defined $tests_planned
+ ? $tests_planned
+ : $tests_run;
+
+ my $passed = $parser->passed;
+
+ # The total number of fails includes any tests that were planned but
+ # didn't run
+ my $failed = $parser->failed + $total - $tests_run;
+ my $exit = $parser->exit;
+
+ if ( my $exit = $parser->exit ) {
+ my $wstat = $parser->wait;
+ my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
+ $formatter->_failure_output("Dubious, test returned $status\n");
+ }
+
+ if ( $failed == 0 ) {
+ $formatter->_failure_output(
+ $total
+ ? "All $total subtests passed "
+ : 'No subtests run '
+ );
+ }
+ else {
+ $formatter->_failure_output("Failed $failed/$total subtests ");
+ if ( !$total ) {
+ $formatter->_failure_output("\nNo tests run!");
+ }
+ }
+
+ if ( my $skipped = $parser->skipped ) {
+ $passed -= $skipped;
+ my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
+ $formatter->_output(
+ "\n\t(less $skipped skipped $test: $passed okay)");
+ }
+
+ if ( my $failed = $parser->todo_passed ) {
+ my $test = $failed > 1 ? 'tests' : 'test';
+ $formatter->_output(
+ "\n\t($failed TODO $test unexpectedly succeeded)");
+ }
+
+ $formatter->_output("\n");
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Harness.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Harness.pm
new file mode 100755
index 00000000000..4a8dffd7370
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Harness.pm
@@ -0,0 +1,948 @@
+package TAP::Harness;
+
+use strict;
+use Carp;
+
+use File::Spec;
+use File::Path;
+use IO::Handle;
+
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run test scripts with statistics
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+=head1 DESCRIPTION
+
+This is a simple test harness which allows tests to be run and results
+automatically aggregated and output to STDOUT.
+
+=head1 SYNOPSIS
+
+ use TAP::Harness;
+ my $harness = TAP::Harness->new( \%args );
+ $harness->runtests(@tests);
+
+=cut
+
+my %VALIDATION_FOR;
+my @FORMATTER_ARGS;
+
+sub _error {
+ my $self = shift;
+ return $self->{error} unless @_;
+ $self->{error} = shift;
+}
+
+BEGIN {
+
+ @FORMATTER_ARGS = qw(
+ directives verbosity timer failures comments errors stdout color
+ show_count normalize
+ );
+
+ %VALIDATION_FOR = (
+ lib => sub {
+ my ( $self, $libs ) = @_;
+ $libs = [$libs] unless 'ARRAY' eq ref $libs;
+
+ return [ map {"-I$_"} @$libs ];
+ },
+ switches => sub { shift; shift },
+ exec => sub { shift; shift },
+ merge => sub { shift; shift },
+ aggregator_class => sub { shift; shift },
+ formatter_class => sub { shift; shift },
+ multiplexer_class => sub { shift; shift },
+ parser_class => sub { shift; shift },
+ scheduler_class => sub { shift; shift },
+ formatter => sub { shift; shift },
+ jobs => sub { shift; shift },
+ test_args => sub { shift; shift },
+ ignore_exit => sub { shift; shift },
+ rules => sub { shift; shift },
+ sources => sub { shift; shift },
+ );
+
+ for my $method ( sort keys %VALIDATION_FOR ) {
+ no strict 'refs';
+ if ( $method eq 'lib' || $method eq 'switches' ) {
+ *{$method} = sub {
+ my $self = shift;
+ unless (@_) {
+ $self->{$method} ||= [];
+ return wantarray
+ ? @{ $self->{$method} }
+ : $self->{$method};
+ }
+ $self->_croak("Too many arguments to method '$method'")
+ if @_ > 1;
+ my $args = shift;
+ $args = [$args] unless ref $args;
+ $self->{$method} = $args;
+ return $self;
+ };
+ }
+ else {
+ *{$method} = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+
+ for my $method (@FORMATTER_ARGS) {
+ no strict 'refs';
+ *{$method} = sub {
+ my $self = shift;
+ return $self->formatter->$method(@_);
+ };
+ }
+}
+
+##############################################################################
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbosity => 1,
+ lib => [ 'lib', 'blib/lib', 'blib/arch' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an
+optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level:
+
+ 1 verbose Print individual test results to STDOUT.
+ 0 normal
+ -1 quiet Suppress some test output (mostly failures
+ while tests are running).
+ -2 really quiet Suppress everything but the tests summary.
+ -3 silent Suppress everything.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if
+available.
+
+=item * C<failures>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (this is a no-op if C<verbose> is selected).
+
+=item * C<show_count>
+
+Update the running test count during testing.
+
+=item * C<normalize>
+
+Set to a true value to normalize the TAP that is emitted in verbose modes.
+
+=item * C<lib>
+
+Accepts a scalar value or array ref of scalar values indicating which
+paths to allowed libraries should be included if Perl tests are
+executed. Naturally, this only makes sense in the context of tests
+written in Perl.
+
+=item * C<switches>
+
+Accepts a scalar value or array ref of scalar values indicating which
+switches should be included if Perl tests are executed. Naturally, this
+only makes sense in the context of tests written in Perl.
+
+=item * C<test_args>
+
+A reference to an C<@INC> style array of arguments to be passed to each
+test program.
+
+ test_args => ['foo', 'bar'],
+
+if you want to pass different arguments to each test then you should
+pass a hash of arrays, keyed by the alias for each test:
+
+ test_args => {
+ my_test => ['foo', 'bar'],
+ other_test => ['baz'],
+ }
+
+=item * C<color>
+
+Attempt to produce color output.
+
+=item * C<exec>
+
+Typically, Perl tests are run through this. However, anything which
+spits out TAP is fine. You can use this argument to specify the name of
+the program (and optional switches) to run your tests with:
+
+ exec => ['/usr/bin/ruby', '-w']
+
+You can also pass a subroutine reference in order to determine and
+return the proper program to run based on a given test script. The
+subroutine reference should expect the TAP::Harness object itself as the
+first argument, and the file name as the second argument. It should
+return an array reference containing the command to be run and including
+the test file name. It can also simply return C<undef>, in which case
+TAP::Harness will fall back on executing the test script in Perl:
+
+ exec => sub {
+ my ( $harness, $test_file ) = @_;
+
+ # Let Perl tests run.
+ return undef if $test_file =~ /[.]t$/;
+ return [ qw( /usr/bin/ruby -w ), $test_file ]
+ if $test_file =~ /[.]rb$/;
+ }
+
+If the subroutine returns a scalar with a newline or a filehandle, it
+will be interpreted as raw TAP or as a TAP stream, respectively.
+
+=item * C<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<sources>
+
+I<NEW to 3.18>.
+
+If set, C<sources> must be a hashref containing the names of the
+L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a
+hash of configuration that will be accessible to to the source handlers via
+L<TAP::Parser::Source/config_for>.
+
+For example:
+
+ sources => {
+ Perl => { exec => '/path/to/custom/perl' },
+ File => { extensions => [ '.tap', '.txt' ] },
+ MyCustom => { some => 'config' },
+ }
+
+The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters
+are handled.
+
+For more details, see the C<sources> parameter in L<TAP::Parser/new>,
+L<TAP::Parser::Source>, and L<TAP::Parser::IteratorFactory>.
+
+=item * C<aggregator_class>
+
+The name of the class to use to aggregate test results. The default is
+L<TAP::Parser::Aggregator>.
+
+=item * C<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
+isn't a TTY.
+
+=item * C<multiplexer_class>
+
+The name of the class to use to multiplex tests during parallel testing.
+The default is L<TAP::Parser::Multiplexer>.
+
+=item * C<parser_class>
+
+The name of the class to use to parse TAP. The default is
+L<TAP::Parser>.
+
+=item * C<scheduler_class>
+
+The name of the class to use to schedule test execution. The default is
+L<TAP::Parser::Scheduler>.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting the
+TAP output. See L<TAP::Formatter::Console> for an example.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be
+made in the summary report. To see all of the parse errors, set this
+argument to true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be
+displayed. This overrides other settings such as C<verbose> or
+C<failures>.
+
+=item * C<ignore_exit>
+
+If set to a true value instruct C<TAP::Parser> to ignore exit and wait
+status from test scripts.
+
+=item * C<jobs>
+
+The maximum number of parallel tests to run at any time. Which tests
+can be run in parallel is controlled by C<rules>. The default is to
+run only one test at a time.
+
+=item * C<rules>
+
+A reference to a hash of rules that control which tests may be
+executed in parallel. This is an experimental feature and the
+interface may change.
+
+ $harness->rules(
+ { par => [
+ { seq => '../ext/DB_File/t/*' },
+ { seq => '../ext/IO_Compress_Zlib/t/*' },
+ { seq => '../lib/CPANPLUS/*' },
+ { seq => '../lib/ExtUtils/t/*' },
+ '*'
+ ]
+ }
+ );
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+{
+ my @legal_callback = qw(
+ parser_args
+ made_parser
+ before_runtests
+ after_runtests
+ after_test
+ );
+
+ my %default_class = (
+ aggregator_class => 'TAP::Parser::Aggregator',
+ formatter_class => 'TAP::Formatter::Console',
+ multiplexer_class => 'TAP::Parser::Multiplexer',
+ parser_class => 'TAP::Parser',
+ scheduler_class => 'TAP::Parser::Scheduler',
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name ( sort keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+
+ my $value = $self->$validate($property);
+ if ( $self->_error ) {
+ $self->_croak;
+ }
+ $self->$name($value);
+ }
+ }
+
+ $self->jobs(1) unless defined $self->jobs;
+
+ local $default_class{formatter_class} = 'TAP::Formatter::File'
+ unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY};
+
+ while ( my ( $attr, $class ) = each %default_class ) {
+ $self->$attr( $self->$attr() || $class );
+ }
+
+ unless ( $self->formatter ) {
+
+ # This is a little bodge to preserve legacy behaviour. It's
+ # pretty horrible that we know which args are destined for
+ # the formatter.
+ my %formatter_args = ( jobs => $self->jobs );
+ for my $name (@FORMATTER_ARGS) {
+ if ( defined( my $property = delete $arg_for{$name} ) ) {
+ $formatter_args{$name} = $property;
+ }
+ }
+
+ $self->formatter(
+ $self->_construct( $self->formatter_class, \%formatter_args )
+ );
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+
+ return $self;
+ }
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<runtests>
+
+ $harness->runtests(@tests);
+
+Accepts an array of C<@tests> to be run. This should generally be the
+names of test files, but this is not required. Each element in C<@tests>
+will be passed to C<TAP::Parser::new()> as a C<source>. See
+L<TAP::Parser> for more information.
+
+It is possible to provide aliases that will be displayed in place of the
+test name by supplying the test as a reference to an array containing
+C<< [ $test, $alias ] >>:
+
+ $harness->runtests( [ 't/foo.t', 'Foo Once' ],
+ [ 't/foo.t', 'Foo Twice' ] );
+
+Normally it is an error to attempt to run the same test twice. Aliases
+allow you to overcome this limitation by giving each run of the test a
+unique name.
+
+Tests will be run in the order found.
+
+If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
+should name a directory into which a copy of the raw TAP for each test
+will be written. TAP is written to files named for each test.
+Subdirectories will be created as needed.
+
+Returns a L<TAP::Parser::Aggregator> containing the test results.
+
+=cut
+
+sub runtests {
+ my ( $self, @tests ) = @_;
+
+ my $aggregate = $self->_construct( $self->aggregator_class );
+
+ $self->_make_callback( 'before_runtests', $aggregate );
+ $aggregate->start;
+ $self->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop;
+ $self->summary($aggregate);
+ $self->_make_callback( 'after_runtests', $aggregate );
+
+ return $aggregate;
+}
+
+=head3 C<summary>
+
+ $harness->summary( $aggregator );
+
+Output the summary for a L<TAP::Parser::Aggregator>.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+ $self->formatter->summary($aggregate);
+}
+
+sub _after_test {
+ my ( $self, $aggregate, $job, $parser ) = @_;
+
+ $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
+ $aggregate->add( $job->description, $parser );
+}
+
+sub _bailout {
+ my ( $self, $result ) = @_;
+ my $explanation = $result->explanation;
+ die "FAILED--Further testing stopped"
+ . ( $explanation ? ": $explanation\n" : ".\n" );
+}
+
+sub _aggregate_parallel {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ my $jobs = $self->jobs;
+ my $mux = $self->_construct( $self->multiplexer_class );
+
+ RESULT: {
+
+ # Keep multiplexer topped up
+ FILL:
+ while ( $mux->parsers < $jobs ) {
+ my $job = $scheduler->get_job;
+
+ # If we hit a spinner stop filling and start running.
+ last FILL if !defined $job || $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+ $mux->add( $parser, [ $session, $job ] );
+ }
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ my ( $session, $job ) = @$stash;
+ if ( defined $result ) {
+ $session->result($result);
+ $self->_bailout($result) if $result->is_bailout;
+ }
+ else {
+
+ # End of parser. Automatically removed from the mux.
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+ redo RESULT;
+ }
+ }
+
+ return;
+}
+
+sub _aggregate_single {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ JOB:
+ while ( my $job = $scheduler->get_job ) {
+ next JOB if $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ if ( $result->is_bailout ) {
+
+ # Keep reading until input is exhausted in the hope
+ # of allowing any pending diagnostics to show up.
+ 1 while $parser->next;
+ $self->_bailout($result);
+ }
+ }
+
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+
+ return;
+}
+
+=head3 C<aggregate_tests>
+
+ $harness->aggregate_tests( $aggregate, @tests );
+
+Run the named tests and display a summary of result. Tests will be run
+in the order found.
+
+Test results will be added to the supplied L<TAP::Parser::Aggregator>.
+C<aggregate_tests> may be called multiple times to run several sets of
+tests. Multiple C<Test::Harness> instances may be used to pass results
+to a single aggregator so that different parts of a complex test suite
+may be run using different C<TAP::Harness> settings. This is useful, for
+example, in the case where some tests should run in parallel but others
+are unsuitable for parallel execution.
+
+ my $formatter = TAP::Formatter::Console->new;
+ my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
+ my $par_harness = TAP::Harness->new(
+ { formatter => $formatter,
+ jobs => 9
+ }
+ );
+ my $aggregator = TAP::Parser::Aggregator->new;
+
+ $aggregator->start();
+ $ser_harness->aggregate_tests( $aggregator, @ser_tests );
+ $par_harness->aggregate_tests( $aggregator, @par_tests );
+ $aggregator->stop();
+ $formatter->summary($aggregator);
+
+Note that for simpler testing requirements it will often be possible to
+replace the above code with a single call to C<runtests>.
+
+Each element of the C<@tests> array is either:
+
+=over
+
+=item * the source name of a test to run
+
+=item * a reference to a [ source name, display name ] array
+
+=back
+
+In the case of a perl test suite, typically I<source names> are simply the file
+names of the test scripts to run.
+
+When you supply a separate display name it becomes possible to run a
+test more than once; the display name is effectively the alias by which
+the test is known inside the harness. The harness doesn't care if it
+runs the same test more than once when each invocation uses a
+different name.
+
+=cut
+
+sub aggregate_tests {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $jobs = $self->jobs;
+ my $scheduler = $self->make_scheduler(@tests);
+
+ # #12458
+ local $ENV{HARNESS_IS_VERBOSE} = 1
+ if $self->formatter->verbosity > 0;
+
+ # Formatter gets only names.
+ $self->formatter->prepare( map { $_->description } $scheduler->get_all );
+
+ if ( $self->jobs > 1 ) {
+ $self->_aggregate_parallel( $aggregate, $scheduler );
+ }
+ else {
+ $self->_aggregate_single( $aggregate, $scheduler );
+ }
+
+ return;
+}
+
+sub _add_descriptions {
+ my $self = shift;
+
+ # Turn unwrapped scalars into anonymous arrays and copy the name as
+ # the description for tests that have only a name.
+ return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ }
+ map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
+}
+
+=head3 C<make_scheduler>
+
+Called by the harness when it needs to create a
+L<TAP::Parser::Scheduler>. Override in a subclass to provide an
+alternative scheduler. C<make_scheduler> is passed the list of tests
+that was passed to C<aggregate_tests>.
+
+=cut
+
+sub make_scheduler {
+ my ( $self, @tests ) = @_;
+ return $self->_construct(
+ $self->scheduler_class,
+ tests => [ $self->_add_descriptions(@tests) ],
+ rules => $self->rules
+ );
+}
+
+=head3 C<jobs>
+
+Gets or sets the number of concurrent test runs the harness is
+handling. By default, this value is 1 -- for parallel testing, this
+should be set higher.
+
+=cut
+
+##############################################################################
+
+sub _get_parser_args {
+ my ( $self, $job ) = @_;
+ my $test_prog = $job->filename;
+ my %args = ();
+
+ $args{sources} = $self->sources if $self->sources;
+
+ my @switches;
+ @switches = $self->lib if $self->lib;
+ push @switches => $self->switches if $self->switches;
+ $args{switches} = \@switches;
+ $args{spool} = $self->_open_spool($test_prog);
+ $args{merge} = $self->merge;
+ $args{ignore_exit} = $self->ignore_exit;
+
+ if ( my $exec = $self->exec ) {
+ $args{exec}
+ = ref $exec eq 'CODE'
+ ? $exec->( $self, $test_prog )
+ : [ @$exec, $test_prog ];
+ if ( not defined $args{exec} ) {
+ $args{source} = $test_prog;
+ }
+ elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) {
+ $args{source} = delete $args{exec};
+ }
+ }
+ else {
+ $args{source} = $test_prog;
+ }
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+
+ if ( ref($test_args) eq 'HASH' ) {
+
+ # different args for each test
+ if ( exists( $test_args->{ $job->description } ) ) {
+ $test_args = $test_args->{ $job->description };
+ }
+ else {
+ $self->_croak( "TAP::Harness Can't find test_args for "
+ . $job->description );
+ }
+ }
+
+ $args{test_args} = $test_args;
+ }
+
+ return \%args;
+}
+
+=head3 C<make_parser>
+
+Make a new parser and display formatter session. Typically used and/or
+overridden in subclasses.
+
+ my ( $parser, $session ) = $harness->make_parser;
+
+=cut
+
+sub make_parser {
+ my ( $self, $job ) = @_;
+
+ my $args = $self->_get_parser_args($job);
+ $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
+ my $parser = $self->_construct( $self->parser_class, $args );
+
+ $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
+ my $session = $self->formatter->open_test( $job->description, $parser );
+
+ return ( $parser, $session );
+}
+
+=head3 C<finish_parser>
+
+Terminate use of a parser. Typically used and/or overridden in
+subclasses. The parser isn't destroyed as a result of this.
+
+=cut
+
+sub finish_parser {
+ my ( $self, $parser, $session ) = @_;
+
+ $session->close_test;
+ $self->_close_spool($parser);
+
+ return $parser;
+}
+
+sub _open_spool {
+ my $self = shift;
+ my $test = shift;
+
+ if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
+
+ my $spool = File::Spec->catfile( $spool_dir, $test );
+
+ # Make the directory
+ my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
+ my $path = File::Spec->catpath( $vol, $dir, '' );
+ eval { mkpath($path) };
+ $self->_croak($@) if $@;
+
+ my $spool_handle = IO::Handle->new;
+ open( $spool_handle, ">$spool" )
+ or $self->_croak(" Can't write $spool ( $! ) ");
+
+ return $spool_handle;
+ }
+
+ return;
+}
+
+sub _close_spool {
+ my $self = shift;
+ my ($parser) = @_;
+
+ if ( my $spool_handle = $parser->delete_spool ) {
+ close($spool_handle)
+ or $self->_croak(" Error closing TAP spool file( $! ) \n ");
+ }
+
+ return;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ unless ($message) {
+ $message = $self->_error;
+ }
+ $self->SUPER::_croak($message);
+
+ return;
+}
+
+1;
+
+__END__
+
+##############################################################################
+
+=head1 CONFIGURING
+
+C<TAP::Harness> is designed to be easy to configure.
+
+=head2 Plugins
+
+C<TAP::Parser> plugins let you change the way TAP is I<input> to and I<output>
+from the parser.
+
+L<TAP::Parser::SourceHandler>s handle TAP I<input>. You can configure them
+and load custom handlers using the C<sources> parameter to L</new>.
+
+L<TAP::Formatter>s handle TAP I<output>. You can load custom formatters by
+using the C<formatter_class> parameter to L</new>. To configure a formatter,
+you currently need to instantiate it outside of L<TAP::Harness> and pass it in
+with the C<formatter> parameter to L</new>. This I<may> be addressed by adding
+a I<formatters> parameter to L</new> in the future.
+
+=head2 C<Module::Build>
+
+L<Module::Build> version C<0.30> supports C<TAP::Harness>.
+
+To load C<TAP::Harness> plugins, you'll need to use the C<tap_harness_args>
+parameter to C<new>, typically from your C<Build.PL>. For example:
+
+ Module::Build->new(
+ module_name => 'MyApp',
+ test_file_exts => [qw(.t .tap .txt)],
+ use_tap_harness => 1,
+ tap_harness_args => {
+ sources => {
+ MyCustom => {},
+ File => {
+ extensions => ['.tap', '.txt'],
+ },
+ },
+ formatter => 'TAP::Formatter::HTML',
+ },
+ build_requires => {
+ 'Module::Build' => '0.30',
+ 'TAP::Harness' => '3.18',
+ },
+ )->create_build_script;
+
+See L</new>
+
+=head2 C<ExtUtils::MakeMaker>
+
+L<ExtUtils::MakeMaker> does not support L<TAP::Harness> out-of-the-box.
+
+=head2 C<prove>
+
+L<prove> supports C<TAP::Harness> plugins, and has a plugin system of its
+own. See L<prove/FORMATTERS>, L<prove/SOURCE HANDLERS> and L<App::Prove>
+for more details.
+
+=head1 WRITING PLUGINS
+
+If you can't configure C<TAP::Harness> to do what you want, and you can't find
+an existing plugin, consider writing one.
+
+The two primary use cases supported by L<TAP::Harness> for plugins are I<input>
+and I<output>:
+
+=over 2
+
+=item Customize how TAP gets into the parser
+
+To do this, you can either extend an existing L<TAP::Parser::SourceHandler>,
+or write your own. It's a pretty simple API, and they can be loaded and
+configured using the C<sources> parameter to L</new>.
+
+=item Customize how TAP results are output from the parser
+
+To do this, you can either extend an existing L<TAP::Formatter>, or write your
+own. Writing formatters are a bit more involved than writing a
+I<SourceHandler>, as you'll need to understand the L<TAP::Parser> API. A
+good place to start is by understanding how L</aggregate_tests> works.
+
+Custom formatters can be loaded configured using the C<formatter_class>
+parameter to L</new>.
+
+=back
+
+=head1 SUBCLASSING
+
+If you can't configure C<TAP::Harness> to do exactly what you want, and writing
+a plugin isn't an option, consider extending it. It is designed to be (mostly)
+easy to subclass, though the cases when sub-classing is necessary should be few
+and far between.
+
+=head2 Methods
+
+The following methods are ones you may wish to override if you want to
+subclass C<TAP::Harness>.
+
+=over 4
+
+=item L</new>
+
+=item L</runtests>
+
+=item L</summary>
+
+=back
+
+=cut
+
+=head1 REPLACING
+
+If you like the C<prove> utility and L<TAP::Parser> but you want your
+own harness, all you need to do is write one and provide C<new> and
+C<runtests> methods. Then you can use the C<prove> utility like so:
+
+ prove --harness My::Test::Harness
+
+Note that while C<prove> accepts a list of tests (or things to be
+tested), C<new> has a fairly rich set of arguments. You'll probably want
+to read over this code carefully to see how all of them are being used.
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+# vim:ts=4:sw=4:et:sta
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Harness/Beyond.pod b/Master/tlpkg/tlperl.straw/lib/TAP/Harness/Beyond.pod
new file mode 100755
index 00000000000..8704f52b280
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Harness/Beyond.pod
@@ -0,0 +1,416 @@
+=head1 Beyond make test
+
+Test::Harness is responsible for running test scripts, analysing
+their output and reporting success or failure. When I type
+F<make test> (or F<./Build test>) for a module, Test::Harness is usually
+used to run the tests (not all modules use Test::Harness but the
+majority do).
+
+To start exploring some of the features of Test::Harness I need to
+switch from F<make test> to the F<prove> command (which ships with
+Test::Harness). For the following examples I'll also need a recent
+version of Test::Harness installed; 3.14 is current as I write.
+
+For the examples I'm going to assume that we're working with a
+'normal' Perl module distribution. Specifically I'll assume that
+typing F<make> or F<./Build> causes the built, ready-to-install module
+code to be available below ./blib/lib and ./blib/arch and that
+there's a directory called 't' that contains our tests. Test::Harness
+isn't hardwired to that configuration but it saves me from explaining
+which files live where for each example.
+
+Back to F<prove>; like F<make test> it runs a test suite - but it
+provides far more control over which tests are executed, in what
+order and how their results are reported. Typically F<make test>
+runs all the test scripts below the 't' directory. To do the same
+thing with prove I type:
+
+ prove -rb t
+
+The switches here are -r to recurse into any directories below 't'
+and -b which adds ./blib/lib and ./blib/arch to Perl's include path
+so that the tests can find the code they will be testing. If I'm
+testing a module of which an earlier version is already installed
+I need to be careful about the include path to make sure I'm not
+running my tests against the installed version rather than the new
+one that I'm working on.
+
+Unlike F<make test>, typing F<prove> doesn't automatically rebuild
+my module. If I forget to make before prove I will be testing against
+older versions of those files - which inevitably leads to confusion.
+I either get into the habit of typing
+
+ make && prove -rb t
+
+or - if I have no XS code that needs to be built I use the modules
+below F<lib> instead
+
+ prove -Ilib -r t
+
+So far I've shown you nothing that F<make test> doesn't do. Let's
+fix that.
+
+=head2 Saved State
+
+If I have failing tests in a test suite that consists of more than
+a handful of scripts and takes more than a few seconds to run it
+rapidly becomes tedious to run the whole test suite repeatedly as
+I track down the problems.
+
+I can tell prove just to run the tests that are failing like this:
+
+ prove -b t/this_fails.t t/so_does_this.t
+
+That speeds things up but I have to make a note of which tests are
+failing and make sure that I run those tests. Instead I can use
+prove's --state switch and have it keep track of failing tests for
+me. First I do a complete run of the test suite and tell prove to
+save the results:
+
+ prove -rb --state=save t
+
+That stores a machine readable summary of the test run in a file
+called '.prove' in the current directory. If I have failures I can
+then run just the failing scripts like this:
+
+ prove -b --state=failed
+
+I can also tell prove to save the results again so that it updates
+its idea of which tests failed:
+
+ prove -b --state=failed,save
+
+As soon as one of my failing tests passes it will be removed from
+the list of failed tests. Eventually I fix them all and prove can
+find no failing tests to run:
+
+ Files=0, Tests=0, 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU)
+ Result: NOTESTS
+
+As I work on a particular part of my module it's most likely that
+the tests that cover that code will fail. I'd like to run the whole
+test suite but have it prioritize these 'hot' tests. I can tell
+prove to do this:
+
+ prove -rb --state=hot,save t
+
+All the tests will run but those that failed most recently will be
+run first. If no tests have failed since I started saving state all
+tests will run in their normal order. This combines full test
+coverage with early notification of failures.
+
+The --state switch supports a number of options; for example to run
+failed tests first followed by all remaining tests ordered by the
+timestamps of the test scripts - and save the results - I can use
+
+ prove -rb --state=failed,new,save t
+
+See the prove documentation (type prove --man) for the full list
+of state options.
+
+When I tell prove to save state it writes a file called '.prove'
+('_prove' on Windows) in the current directory. It's a YAML document
+so it's quite easy to write tools of your own that work on the saved
+test state - but the format isn't officially documented so it might
+change without (much) warning in the future.
+
+=head2 Parallel Testing
+
+If my tests take too long to run I may be able to speed them up by
+running multiple test scripts in parallel. This is particularly
+effective if the tests are I/O bound or if I have multiple CPU
+cores. I tell prove to run my tests in parallel like this:
+
+ prove -rb -j 9 t
+
+The -j switch enables parallel testing; the number that follows it
+is the maximum number of tests to run in parallel. Sometimes tests
+that pass when run sequentially will fail when run in parallel. For
+example if two different test scripts use the same temporary file
+or attempt to listen on the same socket I'll have problems running
+them in parallel. If I see unexpected failures I need to check my
+tests to work out which of them are trampling on the same resource
+and rename temporary files or add locks as appropriate.
+
+To get the most performance benefit I want to have the test scripts
+that take the longest to run start first - otherwise I'll be waiting
+for the one test that takes nearly a minute to complete after all
+the others are done. I can use the --state switch to run the tests
+in slowest to fastest order:
+
+ prove -rb -j 9 --state=slow,save t
+
+=head2 Non-Perl Tests
+
+The Test Anything Protocol (http://testanything.org/) isn't just
+for Perl. Just about any language can be used to write tests that
+output TAP. There are TAP based testing libraries for C, C++, PHP,
+Python and many others. If I can't find a TAP library for my language
+of choice it's easy to generate valid TAP. It looks like this:
+
+ 1..3
+ ok 1 - init OK
+ ok 2 - opened file
+ not ok 3 - appended to file
+
+The first line is the plan - it specifies the number of tests I'm
+going to run so that it's easy to check that the test script didn't
+exit before running all the expected tests. The following lines are
+the test results - 'ok' for pass, 'not ok' for fail. Each test has
+a number and, optionally, a description. And that's it. Any language
+that can produce output like that on STDOUT can be used to write
+tests.
+
+Recently I've been rekindling a two-decades-old interest in Forth.
+Evidently I have a masochistic streak that even Perl can't satisfy.
+I want to write tests in Forth and run them using prove (you can
+find my gforth TAP experiments at
+https://svn.hexten.net/andy/Forth/Testing/). I can use the --exec
+switch to tell prove to run the tests using gforth like this:
+
+ prove -r --exec gforth t
+
+Alternately, if the language used to write my tests allows a shebang
+line I can use that to specify the interpreter. Here's a test written
+in PHP:
+
+ #!/usr/bin/php
+ <?php
+ print "1..2\n";
+ print "ok 1\n";
+ print "not ok 2\n";
+ ?>
+
+If I save that as t/phptest.t the shebang line will ensure that it
+runs correctly along with all my other tests.
+
+=head2 Mixing it up
+
+Subtle interdependencies between test programs can mask problems -
+for example an earlier test may neglect to remove a temporary file
+that affects the behaviour of a later test. To find this kind of
+problem I use the --shuffle and --reverse options to run my tests
+in random or reversed order.
+
+=head2 Rolling My Own
+
+If I need a feature that prove doesn't provide I can easily write my own.
+
+Typically you'll want to change how TAP gets I<input> into and I<output>
+from the parser. L<App::Prove> supports arbitrary plugins, and L<TAP::Harness>
+supports custom I<formatters> and I<source handlers> that you can load using
+either L<prove> or L<Module::Build>; there are many examples to base mine on.
+For more details see L<App::Prove>, L<TAP::Parser::SourceHandler>, and
+L<TAP::Formatter::Base>.
+
+If writing a plugin is not enough, you can write your own test harness; one of
+the motives for the 3.00 rewrite of Test::Harness was to make it easier to
+subclass and extend.
+
+The Test::Harness module is a compatibility wrapper around TAP::Harness.
+For new applications I should use TAP::Harness directly. As we'll
+see, prove uses TAP::Harness.
+
+When I run prove it processes its arguments, figures out which test
+scripts to run and then passes control to TAP::Harness to run the
+tests, parse, analyse and present the results. By subclassing
+TAP::Harness I can customise many aspects of the test run.
+
+I want to log my test results in a database so I can track them
+over time. To do this I override the summary method in TAP::Harness.
+I start with a simple prototype that dumps the results as a YAML
+document:
+
+ package My::TAP::Harness;
+
+ use base qw( TAP::Harness ); use YAML;
+
+ sub summary {
+ my ( $self, $aggregate ) = @_; print Dump( $aggregate );
+ $self->SUPER::summary( $aggregate );
+ }
+
+ 1;
+
+I need to tell prove to use my My::TAP::Harness. If My::TAP::Harness
+is on Perl's @INC include path I can
+
+ prove --harness=My::TAP::Harness -rb t
+
+If I don't have My::TAP::Harness installed on @INC I need to provide
+the correct path to perl when I run prove:
+
+ perl -Ilib `which prove` --harness=My::TAP::Harness -rb t
+
+I can incorporate these options into my own version of prove. It's
+pretty simple. Most of the work of prove is handled by App::Prove.
+The important code in prove is just:
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ exit( $app->run ? 0 : 1 );
+
+If I write a subclass of App::Prove I can customise any aspect of
+the test runner while inheriting all of prove's behaviour. Here's
+myprove:
+
+ #!/usr/bin/env perl use lib qw( lib ); # Add ./lib to @INC
+ use App::Prove;
+
+ my $app = App::Prove->new;
+
+ # Use custom TAP::Harness subclass $app->harness( 'My::TAP::Harness'
+ );
+
+ $app->process_args( @ARGV ); exit( $app->run ? 0 : 1 );
+
+Now I can run my tests like this
+
+ ./myprove -rb t
+
+=head2 Deeper Customisation
+
+Now that I know how to subclass and replace TAP::Harness I can
+replace any other part of the harness. To do that I need to know
+which classes are responsible for which functionality. Here's a
+brief guided tour; the default class for each component is shown
+in parentheses. Normally any replacements I write will be subclasses
+of these default classes.
+
+When I run my tests TAP::Harness creates a scheduler
+(TAP::Parser::Scheduler) to work out the running order for the
+tests, an aggregator (TAP::Parser::Aggregator) to collect and analyse
+the test results and a formatter (TAP::Formatter::Console) to display
+those results.
+
+If I'm running my tests in parallel there may also be a multiplexer
+(TAP::Parser::Multiplexer) - the component that allows multiple
+tests to run simultaneously.
+
+Once it has created those helpers TAP::Harness starts running the
+tests. For each test it creates a new parser (TAP::Parser) which
+is responsible for running the test script and parsing its output.
+
+To replace any of these components I call one of these harness
+methods with the name of the replacement class:
+
+ aggregator_class
+ formatter_class
+ multiplexer_class
+ parser_class
+ scheduler_class
+
+For example, to replace the aggregator I would
+
+ $harness->aggregator_class( 'My::Aggregator' );
+
+Alternately I can supply the names of my substitute classes to the
+TAP::Harness constructor:
+
+ my $harness = TAP::Harness->new(
+ { aggregator_class => 'My::Aggregator' }
+ );
+
+If I need to reach even deeper into the internals of the harness I
+can replace the classes that TAP::Parser uses to execute test scripts
+and tokenise their output. Before running a test script TAP::Parser
+creates a grammar (TAP::Parser::Grammar) to decode the raw TAP into
+tokens, a result factory (TAP::Parser::ResultFactory) to turn the
+decoded TAP results into objects and, depending on whether it's
+running a test script or reading TAP from a file, scalar or array
+a source or an iterator (TAP::Parser::IteratorFactory).
+
+Each of these objects may be replaced by calling one of these parser
+methods:
+
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+
+=head2 Callbacks
+
+As an alternative to subclassing the components I need to change I
+can attach callbacks to the default classes. TAP::Harness exposes
+these callbacks:
+
+ parser_args Tweak the parameters used to create the parser
+ made_parser Just made a new parser
+ before_runtests About to run tests
+ after_runtests Have run all tests
+ after_test Have run an individual test script
+
+TAP::Parser also supports callbacks; bailout, comment, plan, test,
+unknown, version and yaml are called for the corresponding TAP
+result types, ALL is called for all results, ELSE is called for all
+results for which a named callback is not installed and EOF is
+called once at the end of each TAP stream.
+
+To install a callback I pass the name of the callback and a subroutine
+reference to TAP::Harness or TAP::Parser's callback method:
+
+ $harness->callback( after_test => sub {
+ my ( $script, $desc, $parser ) = @_;
+ } );
+
+I can also pass callbacks to the constructor:
+
+ my $harness = TAP::Harness->new({
+ callbacks => {
+ after_test => sub {
+ my ( $script, $desc, $parser ) = @_;
+ # Do something interesting here
+ }
+ }
+ });
+
+When it comes to altering the behaviour of the test harness there's
+more than one way to do it. Which way is best depends on my
+requirements. In general if I only want to observe test execution
+without changing the harness' behaviour (for example to log test
+results to a database) I choose callbacks. If I want to make the
+harness behave differently subclassing gives me more control.
+
+=head2 Parsing TAP
+
+Perhaps I don't need a complete test harness. If I already have a
+TAP test log that I need to parse all I need is TAP::Parser and the
+various classes it depends upon. Here's the code I need to run a
+test and parse its TAP output
+
+ use TAP::Parser;
+
+ my $parser = TAP::Parser->new( { source => 't/simple.t' } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+Alternately I can pass an open filehandle as source and have the
+parser read from that rather than attempting to run a test script:
+
+ open my $tap, '<', 'tests.tap'
+ or die "Can't read TAP transcript ($!)\n";
+ my $parser = TAP::Parser->new( { source => $tap } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This approach is useful if I need to convert my TAP based test
+results into some other representation. See TAP::Convert::TET
+(http://search.cpan.org/dist/TAP-Convert-TET/) for an example of
+this approach.
+
+=head2 Getting Support
+
+The Test::Harness developers hang out on the tapx-dev mailing
+list[1]. For discussion of general, language independent TAP issues
+there's the tap-l[2] list. Finally there's a wiki dedicated to the
+Test Anything Protocol[3]. Contributions to the wiki, patches and
+suggestions are all welcome.
+
+[1] L<http://www.hexten.net/mailman/listinfo/tapx-dev>
+[2] L<http://testanything.org/mailman/listinfo/tap-l>
+[3] L<http://testanything.org/>
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Object.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Object.pm
new file mode 100755
index 00000000000..aa65082d0af
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Object.pm
@@ -0,0 +1,158 @@
+package TAP::Object;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Object - Base class that provides common functionality to all C<TAP::*> modules
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use strict;
+ use vars qw(@ISA);
+
+ use TAP::Object;
+
+ @ISA = qw(TAP::Object);
+
+ # new() implementation by TAP::Object
+ sub _initialize {
+ my ( $self, @args) = @_;
+ # initialize your object
+ return $self;
+ }
+
+ # ... later ...
+ my $obj = TAP::Whatever->new(@args);
+
+=head1 DESCRIPTION
+
+C<TAP::Object> provides a default constructor and exception model for all
+C<TAP::*> classes. Exceptions are raised using L<Carp>.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new object. Any arguments passed to C<new> will be passed on to the
+L</_initialize> method. Returns a new object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->_initialize(@_);
+}
+
+=head2 Instance Methods
+
+=head3 C<_initialize>
+
+Initializes a new object. This method is a stub by default, you should override
+it as appropriate.
+
+I<Note:> L</new> expects you to return C<$self> or raise an exception. See
+L</_croak>, and L<Carp>.
+
+=cut
+
+sub _initialize {
+ return $_[0];
+}
+
+=head3 C<_croak>
+
+Raise an exception using C<croak> from L<Carp>, eg:
+
+ $self->_croak( 'why me?', 'aaarrgh!' );
+
+May also be called as a I<class> method.
+
+ $class->_croak( 'this works too' );
+
+=cut
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+ return;
+}
+
+=head3 C<_confess>
+
+Raise an exception using C<confess> from L<Carp>, eg:
+
+ $self->_confess( 'why me?', 'aaarrgh!' );
+
+May also be called as a I<class> method.
+
+ $class->_confess( 'this works too' );
+
+=cut
+
+sub _confess {
+ my $proto = shift;
+ require Carp;
+ Carp::confess(@_);
+ return;
+}
+
+=head3 C<_construct>
+
+Create a new instance of the specified class.
+
+=cut
+
+sub _construct {
+ my ( $self, $class, @args ) = @_;
+
+ $self->_croak("Bad module name $class")
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ unless ( $class->can('new') ) {
+ local $@;
+ eval "require $class";
+ $self->_croak("Can't load $class") if $@;
+ }
+
+ return $class->new(@args);
+}
+
+=head3 C<mk_methods>
+
+Create simple getter/setters.
+
+ __PACKAGE__->mk_methods(@method_names);
+
+=cut
+
+sub mk_methods {
+ my ( $class, @methods ) = @_;
+ for my $method_name (@methods) {
+ my $method = "${class}::$method_name";
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method_name} = shift if @_;
+ return $self->{$method_name};
+ };
+ }
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser.pm
new file mode 100755
index 00000000000..f8baa39f312
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser.pm
@@ -0,0 +1,1894 @@
+package TAP::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Base ();
+use TAP::Parser::Grammar ();
+use TAP::Parser::Result ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::Source ();
+use TAP::Parser::Iterator ();
+use TAP::Parser::IteratorFactory ();
+use TAP::Parser::SourceHandler::Executable ();
+use TAP::Parser::SourceHandler::Perl ();
+use TAP::Parser::SourceHandler::File ();
+use TAP::Parser::SourceHandler::RawTAP ();
+use TAP::Parser::SourceHandler::Handle ();
+
+use Carp qw( confess );
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+my $DEFAULT_TAP_VERSION = 12;
+my $MAX_TAP_VERSION = 13;
+
+$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{TAP_VERSION};
+}
+
+BEGIN { # making accessors
+ @ISA = qw(TAP::Base);
+
+ __PACKAGE__->mk_methods(
+ qw(
+ _iterator
+ _spool
+ exec
+ exit
+ is_good_plan
+ plan
+ tests_planned
+ tests_run
+ wait
+ version
+ in_todo
+ start_time
+ end_time
+ skip_all
+ grammar_class
+ result_factory_class
+ iterator_factory_class
+ )
+ );
+
+ sub _stream { # deprecated
+ my $self = shift;
+ $self->_iterator(@_);
+ }
+} # done making accessors
+
+=head1 SYNOPSIS
+
+ use TAP::Parser;
+
+ my $parser = TAP::Parser->new( { source => $source } );
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser> is designed to produce a proper parse of TAP output. For
+an example of how to run tests through this module, see the simple
+harnesses C<examples/>.
+
+There's a wiki dedicated to the Test Anything Protocol:
+
+L<http://testanything.org>
+
+It includes the TAP::Parser Cookbook:
+
+L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $parser = TAP::Parser->new(\%args);
+
+Returns a new C<TAP::Parser> object.
+
+The arguments should be a hashref with I<one> of the following keys:
+
+=over 4
+
+=item * C<source>
+
+I<CHANGED in 3.18>
+
+This is the preferred method of passing input to the constructor.
+
+The C<source> is used to create a L<TAP::Parser::Source> that is passed to the
+L</iterator_factory_class> which in turn figures out how to handle the source and
+creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to
+read in the TAP stream.
+
+To configure the I<IteratorFactory> use the C<sources> parameter below.
+
+Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
+
+=item * C<tap>
+
+I<CHANGED in 3.18>
+
+The value should be the complete TAP output.
+
+The I<tap> is used to create a L<TAP::Parser::Source> that is passed to the
+L</iterator_factory_class> which in turn figures out how to handle the source and
+creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to
+read in the TAP stream.
+
+To configure the I<IteratorFactory> use the C<sources> parameter below.
+
+Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
+
+=item * C<exec>
+
+Must be passed an array reference.
+
+The I<exec> array ref is used to create a L<TAP::Parser::Source> that is passed
+to the L</iterator_factory_class> which in turn figures out how to handle the
+source and creates a <TAP::Parser::Iterator> for it. The iterator is used by
+the parser to read in the TAP stream.
+
+By default the L<TAP::Parser::SourceHandler::Executable> class will create a
+L<TAP::Parser::Iterator::Process> object to handle the source. This passes the
+array reference strings as command arguments to L<IPC::Open3::open3|IPC::Open3>:
+
+ exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
+
+If any C<test_args> are given they will be appended to the end of the command
+argument list.
+
+To configure the I<IteratorFactory> use the C<sources> parameter below.
+
+Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
+
+=back
+
+The following keys are optional.
+
+=over 4
+
+=item * C<sources>
+
+I<NEW to 3.18>.
+
+If set, C<sources> must be a hashref containing the names of the
+L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a
+hash of configuration that will be accessible to to the source handlers via
+L<TAP::Parser::Source/config_for>.
+
+For example:
+
+ sources => {
+ Perl => { exec => '/path/to/custom/perl' },
+ File => { extensions => [ '.tap', '.txt' ] },
+ MyCustom => { some => 'config' },
+ }
+
+This will cause C<TAP::Parser> to pass custom configuration to two of the built-
+in source handlers - L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File> - and attempt to load the C<MyCustom>
+class. See L<TAP::Parser::IteratorFactory/load_handlers> for more detail.
+
+The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters
+are handled.
+
+See L<TAP::Parser::IteratorFactory>, L<TAP::Parser::SourceHandler> and subclasses for
+more details.
+
+=item * C<callback>
+
+If present, each callback corresponding to a given result type will be called
+with the result as the argument if the C<run> method is used:
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ for my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+=item * C<switches>
+
+If using a Perl file as a source, optional switches may be passed which will
+be used when invoking the perl executable.
+
+ my $parser = TAP::Parser->new( {
+ source => $test_file,
+ switches => [ '-Ilib' ],
+ } );
+
+=item * C<test_args>
+
+Used in conjunction with the C<source> and C<exec> option to supply a reference
+to an C<@ARGV> style array of arguments to pass to the test program.
+
+=item * C<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+If false, STDERR is not captured (though it is 'relayed' to keep it
+somewhat synchronized with STDOUT.)
+
+If true, STDERR and STDOUT are the same filehandle. This may cause
+breakage if STDERR contains anything resembling TAP format, but does
+allow exact synchronization.
+
+Subtleties of this behavior may be platform-dependent and may change in
+the future.
+
+=item * C<grammar_class>
+
+This option was introduced to let you easily customize which I<grammar> class
+the parser should use. It defaults to L<TAP::Parser::Grammar>.
+
+See also L</make_grammar>.
+
+=item * C<result_factory_class>
+
+This option was introduced to let you easily customize which I<result>
+factory class the parser should use. It defaults to
+L<TAP::Parser::ResultFactory>.
+
+See also L</make_result>.
+
+=item * C<iterator_factory_class>
+
+I<CHANGED in 3.18>
+
+This option was introduced to let you easily customize which I<iterator>
+factory class the parser should use. It defaults to
+L<TAP::Parser::IteratorFactory>.
+
+=back
+
+=cut
+
+# new() implementation supplied by TAP::Base
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub _default_grammar_class {'TAP::Parser::Grammar'}
+sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
+sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ my $parser = TAP::Parser->new( { source => $file } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This method returns the results of the parsing, one result at a time. Note
+that it is destructive. You can't rewind and examine previous results.
+
+If callbacks are used, they will be issued before this call returns.
+
+Each result returned is a subclass of L<TAP::Parser::Result>. See that
+module and related classes for more information on how to use them.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+##############################################################################
+
+=head3 C<run>
+
+ $parser->run;
+
+This method merely runs the parser and parses all of the TAP.
+
+=cut
+
+sub run {
+ my $self = shift;
+ while ( defined( my $result = $self->next ) ) {
+
+ # do nothing
+ }
+}
+
+##############################################################################
+
+=head3 C<make_grammar>
+
+Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
+arguments given.
+
+The C<grammar_class> can be customized, as described in L</new>.
+
+=head3 C<make_result>
+
+Make a new L<TAP::Parser::Result> object using the parser's
+L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments
+given.
+
+The C<result_factory_class> can be customized, as described in L</new>.
+
+=head3 C<make_iterator_factory>
+
+I<NEW to 3.18>.
+
+Make a new L<TAP::Parser::IteratorFactory> object and return it. Passes through
+any arguments given.
+
+C<iterator_factory_class> can be customized, as described in L</new>.
+
+=cut
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub make_iterator_factory { shift->iterator_factory_class->new(@_); }
+sub make_grammar { shift->grammar_class->new(@_); }
+sub make_result { shift->result_factory_class->make_result(@_); }
+
+{
+
+ # of the following, anything beginning with an underscore is strictly
+ # internal and should not be exposed.
+ my %initialize = (
+ version => $DEFAULT_TAP_VERSION,
+ plan => '', # the test plan (e.g., 1..3)
+ tap => '', # the TAP
+ tests_run => 0, # actual current test numbers
+ results => [], # TAP parser results
+ skipped => [], #
+ todo => [], #
+ passed => [], #
+ failed => [], #
+ actual_failed => [], # how many tests really failed
+ actual_passed => [], # how many tests really passed
+ todo_passed => [], # tests which unexpectedly succeed
+ parse_errors => [], # perfect TAP should have none
+ );
+
+ # We seem to have this list hanging around all over the place. We could
+ # probably get it from somewhere else to avoid the repetition.
+ my @legal_callback = qw(
+ test
+ version
+ plan
+ comment
+ bailout
+ unknown
+ yaml
+ ALL
+ ELSE
+ EOF
+ );
+
+ my @class_overrides = qw(
+ grammar_class
+ result_factory_class
+ iterator_factory_class
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ # everything here is basically designed to convert any TAP source to a
+ # TAP::Parser::Iterator.
+
+ # Shallow copy
+ my %args = %{ $arg_for || {} };
+
+ $self->SUPER::_initialize( \%args, \@legal_callback );
+
+ # get any class overrides out first:
+ for my $key (@class_overrides) {
+ my $default_method = "_default_$key";
+ my $val = delete $args{$key} || $self->$default_method();
+ $self->$key($val);
+ }
+
+ my $iterator = delete $args{iterator};
+ $iterator ||= delete $args{stream}; # deprecated
+ my $tap = delete $args{tap};
+ my $raw_source = delete $args{source};
+ my $sources = delete $args{sources};
+ my $exec = delete $args{exec};
+ my $merge = delete $args{merge};
+ my $spool = delete $args{spool};
+ my $switches = delete $args{switches};
+ my $ignore_exit = delete $args{ignore_exit};
+ my $test_args = delete $args{test_args} || [];
+
+ if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) {
+ $self->_croak(
+ "You may only choose one of 'exec', 'tap', 'source' or 'iterator'"
+ );
+ }
+
+ if ( my @excess = sort keys %args ) {
+ $self->_croak("Unknown options: @excess");
+ }
+
+ # convert $tap & $exec to $raw_source equiv.
+ my $type = '';
+ my $source = TAP::Parser::Source->new;
+ if ($tap) {
+ $type = 'raw TAP';
+ $source->raw( \$tap );
+ }
+ elsif ($exec) {
+ $type = 'exec ' . $exec->[0];
+ $source->raw( { exec => [ @$exec, @$test_args ] } );
+ }
+ elsif ($raw_source) {
+ $type = 'source ' . ref($raw_source) || $raw_source;
+ $source->raw( ref($raw_source) ? $raw_source : \$raw_source );
+ }
+ elsif ($iterator) {
+ $type = 'iterator ' . ref($iterator);
+ }
+
+ if ( $source->raw ) {
+ my $src_factory = $self->make_iterator_factory($sources);
+ $source->merge($merge)->switches($switches)
+ ->test_args($test_args);
+ $iterator = $src_factory->make_iterator($source);
+ }
+
+ unless ($iterator) {
+ $self->_croak(
+ "PANIC: could not determine iterator for input $type");
+ }
+
+ while ( my ( $k, $v ) = each %initialize ) {
+ $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
+ }
+
+ $self->_iterator($iterator);
+ $self->_spool($spool);
+ $self->ignore_exit($ignore_exit);
+
+ return $self;
+ }
+}
+
+=head1 INDIVIDUAL RESULTS
+
+If you've read this far in the docs, you've seen this:
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+Each result returned is a L<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=head2 Result types
+
+Basically, you fetch individual results from the TAP. The six types, with
+examples of each, are as follows:
+
+=over 4
+
+=item * Version
+
+ TAP version 12
+
+=item * Plan
+
+ 1..42
+
+=item * Pragma
+
+ pragma +strict
+
+=item * Test
+
+ ok 3 - We should start with some foobar!
+
+=item * Comment
+
+ # Hope we don't use up the foobar.
+
+=item * Bailout
+
+ Bail out! We ran out of foobar!
+
+=item * Unknown
+
+ ... yo, this ain't TAP! ...
+
+=back
+
+Each result fetched is a result object of a different type. There are common
+methods to each result object and different types may have methods unique to
+their type. Sometimes a type method may be overridden in a subclass, but its
+use is guaranteed to be identical.
+
+=head2 Common type methods
+
+=head3 C<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+Indicates whether or not this is a comment. Comments will generally only
+appear in the TAP stream if STDERR is merged to STDOUT. See the
+C<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut
+which allows you to do this:
+
+ my $parser = TAP::Parser->new( { source => $source } );
+ while ( my $result = $parser->next ) {
+ # only print failing results
+ print $result->as_string unless $result->is_ok;
+ }
+
+=head2 C<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<pragma> methods
+
+ if ( $result->is_pragma ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<pragmas>
+
+Returns a list of pragmas each of which is a + or - followed by the
+pragma name.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=head2 C<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+B<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ if ( $parser->in_todo ) { ... }
+
+True while the most recent result was a TODO. Becomes true before the
+TODO result is returned and stays true until just before the next non-
+TODO test is returned.
+
+=head1 TOTAL RESULTS
+
+After parsing the TAP, there are many methods available to let you dig through
+the results and determine what is meaningful to you.
+
+=head2 Individual Results
+
+These results refer to individual tests which are run.
+
+=head3 C<passed>
+
+ my @passed = $parser->passed; # the test numbers which passed
+ my $passed = $parser->passed; # the number of tests which passed
+
+This method lets you know which (or how many) tests passed. If a test failed
+but had a TODO directive, it will be counted as a passed test.
+
+=cut
+
+sub passed { @{ shift->{passed} } }
+
+=head3 C<failed>
+
+ my @failed = $parser->failed; # the test numbers which failed
+ my $failed = $parser->failed; # the number of tests which failed
+
+This method lets you know which (or how many) tests failed. If a test passed
+but had a TODO directive, it will B<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # the test numbers which actually passed
+ my @actual_passed = $parser->actual_passed;
+
+ # the number of tests which actually passed
+ my $actual_passed = $parser->actual_passed;
+
+This method lets you know which (or how many) tests actually passed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_passed { @{ shift->{actual_passed} } }
+*actual_ok = \&actual_passed;
+
+=head3 C<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # the test numbers which actually failed
+ my @actual_failed = $parser->actual_failed;
+
+ # the number of tests which actually failed
+ my $actual_failed = $parser->actual_failed;
+
+This method lets you know which (or how many) tests actually failed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_failed { @{ shift->{actual_failed} } }
+
+##############################################################################
+
+=head3 C<todo>
+
+ my @todo = $parser->todo; # the test numbers with todo directives
+ my $todo = $parser->todo; # the number of tests with todo directives
+
+This method lets you know which (or how many) tests had TODO directives.
+
+=cut
+
+sub todo { @{ shift->{todo} } }
+
+=head3 C<todo_passed>
+
+ # the test numbers which unexpectedly succeeded
+ my @todo_passed = $parser->todo_passed;
+
+ # the number of tests which unexpectedly succeeded
+ my $todo_passed = $parser->todo_passed;
+
+This method lets you know which (or how many) tests actually passed but were
+declared as "TODO" tests.
+
+=cut
+
+sub todo_passed { @{ shift->{todo_passed} } }
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ my @skipped = $parser->skipped; # the test numbers with SKIP directives
+ my $skipped = $parser->skipped; # the number of tests with SKIP directives
+
+This method lets you know which (or how many) tests had SKIP directives.
+
+=cut
+
+sub skipped { @{ shift->{skipped} } }
+
+=head2 Pragmas
+
+=head3 C<pragma>
+
+Get or set a pragma. To get the state of a pragma:
+
+ if ( $p->pragma('strict') ) {
+ # be strict
+ }
+
+To set the state of a pragma:
+
+ $p->pragma('strict', 1); # enable strict mode
+
+=cut
+
+sub pragma {
+ my ( $self, $pragma ) = splice @_, 0, 2;
+
+ return $self->{pragma}->{$pragma} unless @_;
+
+ if ( my $state = shift ) {
+ $self->{pragma}->{$pragma} = 1;
+ }
+ else {
+ delete $self->{pragma}->{$pragma};
+ }
+
+ return;
+}
+
+=head3 C<pragmas>
+
+Get a list of all the currently enabled pragmas:
+
+ my @pragmas_enabled = $p->pragmas;
+
+=cut
+
+sub pragmas { sort keys %{ shift->{pragma} || {} } }
+
+=head2 Summary Results
+
+These results are "meta" information about the total results of an individual
+test program.
+
+=head3 C<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ if ( $parser->is_good_plan ) { ... }
+
+Returns a boolean value indicating whether or not the number of tests planned
+matches the number of tests run.
+
+B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ print $parser->tests_planned;
+
+Returns the number of tests planned, according to the plan. For example, a
+plan of '1..17' will mean that 17 tests were planned.
+
+=head3 C<tests_run>
+
+ print $parser->tests_run;
+
+Returns the number of tests which actually were run. Hopefully this will
+match the number of C<< $parser->tests_planned >>.
+
+=head3 C<skip_all>
+
+Returns a true value (actually the reason for skipping) if all tests
+were skipped.
+
+=head3 C<start_time>
+
+Returns the time when the Parser was created.
+
+=head3 C<end_time>
+
+Returns the time when the end of TAP input was seen.
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+This is a 'catch-all' method which returns true if any tests have currently
+failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
+}
+
+=head3 C<version>
+
+ $parser->version;
+
+Once the parser is done, this will return the version number for the
+parsed TAP. Version numbers were introduced with TAP version 13 so if no
+version number is found version 12 is assumed.
+
+=head3 C<exit>
+
+ $parser->exit;
+
+Once the parser is done, this will return the exit status. If the parser ran
+an executable, it returns the exit status of the executable.
+
+=head3 C<wait>
+
+ $parser->wait;
+
+Once the parser is done, this will return the wait status. If the parser ran
+an executable, it returns the wait status of the executable. Otherwise, this
+mererely returns the C<exit> status.
+
+=head2 C<ignore_exit>
+
+ $parser->ignore_exit(1);
+
+Tell the parser to ignore the exit status from the test when determining
+whether the test passed. Normally tests with non-zero exit status are
+considered to have failed even if all individual tests passed. In cases
+where it is not possible to control the exit value of the test script
+use this option to ignore it.
+
+=cut
+
+sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
+
+=head3 C<parse_errors>
+
+ my @errors = $parser->parse_errors; # the parser errors
+ my $errors = $parser->parse_errors; # the number of parser_errors
+
+Fortunately, all TAP output is perfect. In the event that it is not, this
+method will return parser errors. Note that a junk line which the parser does
+not recognize is C<not> an error. This allows this parser to handle future
+versions of TAP. The following are all TAP errors reported by the parser:
+
+=over 4
+
+=item * Misplaced plan
+
+The plan (for example, '1..5'), must only come at the beginning or end of the
+TAP output.
+
+=item * No plan
+
+Gotta have a plan!
+
+=item * More than one plan
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+ 1..3
+
+Right. Very funny. Don't do that.
+
+=item * Test numbers out of sequence
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+That last test line above should have the number '3' instead of '2'.
+
+Note that it's perfectly acceptable for some lines to have test numbers and
+others to not have them. However, when a test number is found, it must be in
+sequence. The following is also an error:
+
+ 1..3
+ ok 1 - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+But this is not:
+
+ 1..3
+ ok - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+
+=back
+
+=cut
+
+sub parse_errors { @{ shift->{parse_errors} } }
+
+sub _add_error {
+ my ( $self, $error ) = @_;
+ push @{ $self->{parse_errors} } => $error;
+ return $self;
+}
+
+sub _make_state_table {
+ my $self = shift;
+ my %states;
+ my %planned_todo = ();
+
+ # These transitions are defaults for all states
+ my %state_globals = (
+ comment => {},
+ bailout => {},
+ yaml => {},
+ version => {
+ act => sub {
+ $self->_add_error(
+ 'If TAP version is present it must be the first line of output'
+ );
+ },
+ },
+ unknown => {
+ act => sub {
+ my $unk = shift;
+ if ( $self->pragma('strict') ) {
+ $self->_add_error(
+ 'Unknown TAP token: "' . $unk->raw . '"' );
+ }
+ },
+ },
+ pragma => {
+ act => sub {
+ my ($pragma) = @_;
+ for my $pr ( $pragma->pragmas ) {
+ if ( $pr =~ /^ ([-+])(\w+) $/x ) {
+ $self->pragma( $2, $1 eq '+' );
+ }
+ }
+ },
+ },
+ );
+
+ # Provides default elements for transitions
+ my %state_defaults = (
+ plan => {
+ act => sub {
+ my ($plan) = @_;
+ $self->tests_planned( $plan->tests_planned );
+ $self->plan( $plan->plan );
+ if ( $plan->has_skip ) {
+ $self->skip_all( $plan->explanation
+ || '(no reason given)' );
+ }
+
+ $planned_todo{$_}++ for @{ $plan->todo_list };
+ },
+ },
+ test => {
+ act => sub {
+ my ($test) = @_;
+
+ my ( $number, $tests_run )
+ = ( $test->number, ++$self->{tests_run} );
+
+ # Fake TODO state
+ if ( defined $number && delete $planned_todo{$number} ) {
+ $test->set_directive('TODO');
+ }
+
+ my $has_todo = $test->has_todo;
+
+ $self->in_todo($has_todo);
+ if ( defined( my $tests_planned = $self->tests_planned ) ) {
+ if ( $tests_run > $tests_planned ) {
+ $test->is_unplanned(1);
+ }
+ }
+
+ if ( defined $number ) {
+ if ( $number != $tests_run ) {
+ my $count = $tests_run;
+ $self->_add_error( "Tests out of sequence. Found "
+ . "($number) but expected ($count)" );
+ }
+ }
+ else {
+ $test->_number( $number = $tests_run );
+ }
+
+ push @{ $self->{todo} } => $number if $has_todo;
+ push @{ $self->{todo_passed} } => $number
+ if $test->todo_passed;
+ push @{ $self->{skipped} } => $number
+ if $test->has_skip;
+
+ push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
+ $number;
+ push @{
+ $self->{
+ $test->is_actual_ok
+ ? 'actual_passed'
+ : 'actual_failed'
+ }
+ } => $number;
+ },
+ },
+ yaml => { act => sub { }, },
+ );
+
+ # Each state contains a hash the keys of which match a token type. For
+ # each token
+ # type there may be:
+ # act A coderef to run
+ # goto The new state to move to. Stay in this state if
+ # missing
+ # continue Goto the new state and run the new state for the
+ # current token
+ %states = (
+ INIT => {
+ version => {
+ act => sub {
+ my ($version) = @_;
+ my $ver_num = $version->version;
+ if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
+ my $ver_min = $DEFAULT_TAP_VERSION + 1;
+ $self->_add_error(
+ "Explicit TAP version must be at least "
+ . "$ver_min. Got version $ver_num" );
+ $ver_num = $DEFAULT_TAP_VERSION;
+ }
+ if ( $ver_num > $MAX_TAP_VERSION ) {
+ $self->_add_error(
+ "TAP specified version $ver_num but "
+ . "we don't know about versions later "
+ . "than $MAX_TAP_VERSION" );
+ $ver_num = $MAX_TAP_VERSION;
+ }
+ $self->version($ver_num);
+ $self->_grammar->set_version($ver_num);
+ },
+ goto => 'PLAN'
+ },
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLAN => {
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLANNED => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => {
+ act => sub {
+ my ($version) = @_;
+ $self->_add_error(
+ 'More than one plan found in TAP output');
+ },
+ },
+ },
+ PLANNED_AFTER_TEST => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => { act => sub { }, continue => 'PLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ GOT_PLAN => {
+ test => {
+ act => sub {
+ my ($plan) = @_;
+ my $line = $self->plan;
+ $self->_add_error(
+ "Plan ($line) must be at the beginning "
+ . "or end of the TAP output" );
+ $self->is_good_plan(0);
+ },
+ continue => 'PLANNED'
+ },
+ plan => { continue => 'PLANNED' },
+ },
+ UNPLANNED => {
+ test => { goto => 'UNPLANNED_AFTER_TEST' },
+ plan => { goto => 'GOT_PLAN' },
+ },
+ UNPLANNED_AFTER_TEST => {
+ test => { act => sub { }, continue => 'UNPLANNED' },
+ plan => { act => sub { }, continue => 'UNPLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ );
+
+ # Apply globals and defaults to state table
+ for my $name ( keys %states ) {
+
+ # Merge with globals
+ my $st = { %state_globals, %{ $states{$name} } };
+
+ # Add defaults
+ for my $next ( sort keys %{$st} ) {
+ if ( my $default = $state_defaults{$next} ) {
+ for my $def ( sort keys %{$default} ) {
+ $st->{$next}->{$def} ||= $default->{$def};
+ }
+ }
+ }
+
+ # Stuff back in table
+ $states{$name} = $st;
+ }
+
+ return \%states;
+}
+
+=head3 C<get_select_handles>
+
+Get an a list of file handles which can be passed to C<select> to
+determine the readiness of this parser.
+
+=cut
+
+sub get_select_handles { shift->_iterator->get_select_handles }
+
+sub _grammar {
+ my $self = shift;
+ return $self->{_grammar} = shift if @_;
+
+ return $self->{_grammar} ||= $self->make_grammar(
+ { iterator => $self->_iterator,
+ parser => $self,
+ version => $self->version
+ }
+ );
+}
+
+sub _iter {
+ my $self = shift;
+ my $iterator = $self->_iterator;
+ my $grammar = $self->_grammar;
+ my $spool = $self->_spool;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ $self->start_time( $self->get_time );
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ TRANS: {
+ my $state_spec = $state_table->{$state}
+ or die "Illegal state: $state";
+
+ if ( my $next = $state_spec->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $act->($token);
+ }
+ if ( my $cont = $next->{continue} ) {
+ $state = $cont;
+ redo TRANS;
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $state = $goto;
+ }
+ }
+ else {
+ confess("Unhandled token type: $type\n");
+ }
+ }
+ return $token;
+ };
+
+ # Handle end of stream - which means either pop a block or finish
+ my $end_handler = sub {
+ $self->exit( $iterator->exit );
+ $self->wait( $iterator->wait );
+ $self->_finish;
+ return;
+ };
+
+ # Finally make the closure that we return. For performance reasons
+ # there are two versions of the returned function: one that handles
+ # callbacks and one that does not.
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $_->($result) for @{$code};
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ $self->_make_callback( 'EOF', $self )
+ unless defined $result;
+ }
+
+ return $result;
+ };
+ } # _has_callbacks
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ }
+
+ return $result;
+ };
+ } # no callbacks
+}
+
+sub _finish {
+ my $self = shift;
+
+ $self->end_time( $self->get_time );
+
+ # Avoid leaks
+ $self->_iterator(undef);
+ $self->_grammar(undef);
+
+ # If we just delete the iter we won't get a fault if it's recreated.
+ # Instead we set it to a sub that returns an infinite
+ # stream of undef. This segfaults on 5.5.4, presumably because
+ # we're still executing the closure that gets replaced and it hasn't
+ # been protected with a refcount.
+ $self->{_iter} = sub {return}
+ if $] >= 5.006;
+
+ # sanity checks
+ if ( !$self->plan ) {
+ $self->_add_error('No plan found in TAP output');
+ }
+ else {
+ $self->is_good_plan(1) unless defined $self->is_good_plan;
+ }
+ if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
+ $self->is_good_plan(0);
+ if ( defined( my $planned = $self->tests_planned ) ) {
+ my $ran = $self->tests_run;
+ $self->_add_error(
+ "Bad plan. You planned $planned tests but ran $ran.");
+ }
+ }
+ if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
+
+ # this should never happen
+ my $actual = $self->tests_run;
+ my $passed = $self->passed;
+ my $failed = $self->failed;
+ $self->_croak( "Panic: planned test count ($actual) did not equal "
+ . "sum of passed ($passed) and failed ($failed) tests!" );
+ }
+
+ $self->is_good_plan(0) unless defined $self->is_good_plan;
+ return $self;
+}
+
+=head3 C<delete_spool>
+
+Delete and return the spool.
+
+ my $fh = $parser->delete_spool;
+
+=cut
+
+sub delete_spool {
+ my $self = shift;
+
+ return delete $self->{_spool};
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ for my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will
+be invoked. Thus, if all of the previous result types are specified as
+callbacks, this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is no
+accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO
+lists in the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was
+listed as a TODO test on the plan line. However, we are not aware of
+anyone actually using this feature and hard-coding test numbers is
+discouraged because it's very easy to add a test and break the test
+number sequence. This makes test suites very fragile. Instead, the
+following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter
+'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've
+never run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 SUBCLASSING
+
+If you find you need to provide custom functionality (as you would have using
+L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
+designed to be easily plugged-into and/or subclassed.
+
+Before you start, it's important to know a few things:
+
+=over 2
+
+=item 1
+
+All C<TAP::*> objects inherit from L<TAP::Object>.
+
+=item 2
+
+Many C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
+
+=item 3
+
+Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
+responsible for creating most new objects in the C<TAP::Parser::*> namespace.
+
+This makes it possible for you to have a single point of configuring what
+subclasses should be used, which in turn means that in many cases you'll find
+you only need to sub-class one of the parser's components.
+
+The exception to this rule are I<SourceHandlers> & I<Iterators>, but those are
+both created with customizeable I<IteratorFactory>.
+
+=item 4
+
+By subclassing, you may end up overriding undocumented methods. That's not
+a bad thing per se, but be forewarned that undocumented methods may change
+without warning from one release to the next - we cannot guarantee backwards
+compatability. If any I<documented> method needs changing, it will be
+deprecated first, and changed in a later release.
+
+=back
+
+=head2 Parser Components
+
+=head3 Sources
+
+A TAP parser consumes input from a single I<raw source> of TAP, which could come
+from anywhere (a file, an executable, a database, an io handle, a uri, etc..).
+The source gets bundled up in a L<TAP::Parser::Source> object which gathers some
+meta data about it. The parser then uses a L<TAP::Parser::IteratorFactory> to
+determine which L<TAP::Parser::SourceHandler> to use to turn the raw source
+into a stream of TAP by way of L</Iterators>.
+
+If you simply want C<TAP::Parser> to handle a new source of TAP you probably
+don't need to subclass C<TAP::Parser> itself. Rather, you'll need to create a
+new L<TAP::Parser::SourceHandler> class, and just plug it into the parser using
+the I<sources> param to L</new>. Before you start writing one, read through
+L<TAP::Parser::IteratorFactory> to get a feel for how the system works first.
+
+If you find you really need to use your own iterator factory you can still do
+so without sub-classing C<TAP::Parser> by setting L</iterator_factory_class>.
+
+If you just need to customize the objects on creation, subclass L<TAP::Parser>
+and override L</make_iterator_factory>.
+
+Note that L</make_source> & L</make_perl_source> have been I<DEPRECATED> and
+are now removed.
+
+=head3 Iterators
+
+A TAP parser uses I<iterators> to loop through the I<stream> of TAP read in
+from the I<source> it was given. There are a few types of Iterators available
+by default, all sub-classes of L<TAP::Parser::Iterator>. Choosing which
+iterator to use is the responsibility of the I<siterator factory>, though it
+simply delegates to the I<Source Handler> it uses.
+
+If you're writing your own L<TAP::Parser::SourceHandler>, you may need to
+create your own iterators too. If so you'll need to subclass
+L<TAP::Parser::Iterator>.
+
+Note that L</make_iterator> has been I<DEPRECATED> and is now removed.
+
+=head3 Results
+
+A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
+input I<stream>. There are quite a few result types available; choosing
+which class to use is the responsibility of the I<result factory>.
+
+To create your own result types you have two options:
+
+=over 2
+
+=item option 1
+
+Subclass L<TAP::Parser::Result> and register your new result type/class with
+the default L<TAP::Parser::ResultFactory>.
+
+=item option 2
+
+Subclass L<TAP::Parser::ResultFactory> itself and implement your own
+L<TAP::Parser::Result> creation logic. Then you'll need to customize the
+class used by your parser by setting the C<result_factory_class> parameter.
+See L</new> for more details.
+
+=back
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_result>.
+
+=head3 Grammar
+
+L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
+input I<stream> and produces results. If you need to customize its behaviour
+you should probably familiarize yourself with the source first. Enough
+lecturing.
+
+Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
+C<grammar_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_grammar>
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral
+support, or just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=item * David Wheeler
+
+=item * Alex Vandiver
+
+=item * Cosimo Streppone
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid@cpan.org>
+
+Andy Armstong <andy@hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+Michael Peters <mpeters at plusthree dot com>
+
+Leif Eriksen <leif dot eriksen at bigpond dot com>
+
+Steve Purkis <spurkis@cpan.org>
+
+Nicholas Clark <nick@ccl4.org>
+
+Lee Johnson <notfadeaway at btinternet dot com>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
+We will be notified, and then you'll automatically be notified of
+progress on your bug as we make changes.
+
+Obviously, bugs which include patches are best. If you prefer, you can
+patch against bleed by via anonymous checkout of the latest version:
+
+ git clone git://github.com/AndyA/Test-Harness.git
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Aggregator.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Aggregator.pm
new file mode 100755
index 00000000000..4df2ac34cc4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Aggregator.pm
@@ -0,0 +1,416 @@
+package TAP::Parser::Aggregator;
+
+use strict;
+use Benchmark;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Aggregator;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+ $aggregate->add( 't/00-load.t', $load_parser );
+ $aggregate->add( 't/10-lex.t', $lex_parser );
+
+ my $summary = <<'END_SUMMARY';
+ Passed: %s
+ Failed: %s
+ Unexpectedly succeeded: %s
+ END_SUMMARY
+ printf $summary,
+ scalar $aggregate->passed,
+ scalar $aggregate->failed,
+ scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN { # install summary methods
+ %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+ failed
+ parse_errors
+ passed
+ skipped
+ todo
+ todo_passed
+ total
+ wait
+ exit
+ );
+ $SUMMARY_METHOD_FOR{total} = 'tests_run';
+ $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
+
+ for my $method ( keys %SUMMARY_METHOD_FOR ) {
+ next if 'total' eq $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return wantarray
+ ? @{ $self->{"descriptions_for_$method"} }
+ : $self->{$method};
+ };
+ }
+} # end install summary methods
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ for my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.) It is used as a unique identifier (see e.g.
+L<"parsers">.) Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak( "You already have a parser for ($description)."
+ . " Perhaps you have run the same test twice." );
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+
+ # Slightly nasty. Instead we should maybe have 'cooked' accessors
+ # for results that may be masked by the parser.
+ next
+ if ( $method eq 'exit' || $method eq 'wait' )
+ && $parser->ignore_exit;
+
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method. Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->_get_parsers(@_) if @_;
+ my $descriptions = $self->{parse_order};
+ my @parsers = @{ $self->{parser_for} }{@$descriptions};
+
+ # Note: Because of the way context works, we must assign the parsers to
+ # the @parsers array or else this method does not work as documented.
+ return @parsers;
+}
+
+sub _get_parsers {
+ my ( $self, @descriptions ) = @_;
+ my @parsers;
+ for my $description (@descriptions) {
+ $self->_croak("A parser for ($description) could not be found")
+ unless exists $self->{parser_for}{$description};
+ push @parsers => $self->{parser_for}{$description};
+ }
+ return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to
+the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+ my $self = shift;
+ $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+ my $self = shift;
+ $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+ my $self = shift;
+
+ require Carp;
+ Carp::croak
+ q{Can't call elapsed without first calling start and then stop}
+ unless defined $self->{start_time} && defined $self->{end_time};
+ return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>. This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+ my $self = shift;
+
+ my $elapsed = $self->elapsed;
+
+ return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+ my $self = shift;
+ return
+ $self->total
+ && $self->total == $self->passed
+ && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+ my $self = shift;
+
+ my $total = $self->total;
+ my $passed = $self->passed;
+
+ return
+ ( $self->has_errors || $total != $passed ) ? 'FAIL'
+ : $total ? 'PASS'
+ : 'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * planned
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded. This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->todo_passed
+ || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+ if ( $parser->has_errors ) {
+ ...
+ }
+
+Returns true if I<any> of the parsers failed. This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse errors
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Grammar.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Grammar.pm
new file mode 100755
index 00000000000..81f4d3478ef
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Grammar.pm
@@ -0,0 +1,582 @@
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::YAMLish::Reader ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Grammar;
+ my $grammar = $self->make_grammar({
+ iterator => $tap_parser_iterator,
+ parser => $tap_parser,
+ version => 12,
+ });
+
+ my $result = $grammar->tokenize;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a L<TAP::Parser::Iterator> and
+constructs L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $grammar = TAP::Parser::Grammar->new({
+ iterator => $iterator,
+ parser => $parser,
+ version => $version,
+ });
+
+Returns L<TAP::Parser> grammar object that will parse the TAP stream from the
+specified iterator. Both C<iterator> and C<parser> are required arguments.
+If C<version> is not set it defaults to C<12> (see L</set_version> for more
+details).
+
+=cut
+
+# new() implementation supplied by TAP::Object
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{iterator} = $args->{iterator}; # TODO: accessor
+ $self->{iterator} ||= $args->{stream}; # deprecated
+ $self->{parser} = $args->{parser}; # TODO: accessor
+ $self->set_version( $args->{version} || 12 );
+ return $self;
+}
+
+my %language_for;
+
+{
+
+ # XXX the 'not' and 'ok' might be on separate lines in VMS ...
+ my $ok = qr/(?:not )?ok\b/;
+ my $num = qr/\d+/;
+
+ my %v12 = (
+ version => {
+ syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $version = $1;
+ return $self->_make_version_token( $line, $version, );
+ },
+ },
+ plan => {
+ syntax => qr/^1\.\.(\d+)\s*(.*)\z/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $tail ) = ( $1, $2 );
+ my $explanation = undef;
+ my $skip = '';
+
+ if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
+ my @todo = split /\s+/, _trim($1);
+ return $self->_make_plan_token(
+ $line, $tests_planned, 'TODO',
+ '', \@todo
+ );
+ }
+ elsif ( 0 == $tests_planned ) {
+ $skip = 'SKIP';
+
+ # If we can't match # SKIP the directive should be undef.
+ ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i;
+ }
+ elsif ( $tail !~ /^\s*$/ ) {
+ return $self->_make_unknown_token($line);
+ }
+
+ $explanation = '' unless defined $explanation;
+
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+
+ },
+ },
+
+ # An optimization to handle the most common test lines without
+ # directives.
+ simple_test => {
+ syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+
+ return $self->_make_test_token(
+ $line, $ok, $num,
+ $desc
+ );
+ },
+ },
+ test => {
+ syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+ my ( $dir, $explanation ) = ( '', '' );
+ if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
+ \# \s* (SKIP|TODO) \b \s* (.*) $/ix
+ )
+ {
+ ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
+ }
+ return $self->_make_test_token(
+ $line, $ok, $num, $desc,
+ $dir, $explanation
+ );
+ },
+ },
+ comment => {
+ syntax => qr/^#(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $comment = $1;
+ return $self->_make_comment_token( $line, $comment );
+ },
+ },
+ bailout => {
+ syntax => qr/^Bail out!\s*(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $explanation = $1;
+ return $self->_make_bailout_token(
+ $line,
+ $explanation
+ );
+ },
+ },
+ );
+
+ my %v13 = (
+ %v12,
+ plan => {
+ syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $explanation ) = ( $1, $2 );
+ my $skip
+ = ( 0 == $tests_planned || defined $explanation )
+ ? 'SKIP'
+ : '';
+ $explanation = '' unless defined $explanation;
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+ },
+ },
+ yaml => {
+ syntax => qr/^ (\s+) (---.*) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $pad, $marker ) = ( $1, $2 );
+ return $self->_make_yaml_token( $pad, $marker );
+ },
+ },
+ pragma => {
+ syntax =>
+ qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $pragmas = $1;
+ return $self->_make_pragma_token( $line, $pragmas );
+ },
+ },
+ );
+
+ %language_for = (
+ '12' => {
+ tokens => \%v12,
+ },
+ '13' => {
+ tokens => \%v13,
+ setup => sub {
+ shift->{iterator}->handle_unicode;
+ },
+ },
+ );
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<set_version>
+
+ $grammar->set_version(13);
+
+Tell the grammar which TAP syntax version to support. The lowest
+supported version is 12. Although 'TAP version' isn't valid version 12
+syntax it is accepted so that higher version numbers may be parsed.
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ my $version = shift;
+
+ if ( my $language = $language_for{$version} ) {
+ $self->{version} = $version;
+ $self->{tokens} = $language->{tokens};
+
+ if ( my $setup = $language->{setup} ) {
+ $self->$setup();
+ }
+
+ $self->_order_tokens;
+ }
+ else {
+ require Carp;
+ Carp::croak("Unsupported syntax version: $version");
+ }
+}
+
+# Optimization to put the most frequent tokens first.
+sub _order_tokens {
+ my $self = shift;
+
+ my %copy = %{ $self->{tokens} };
+ my @ordered_tokens = grep {defined}
+ map { delete $copy{$_} } qw( simple_test test comment plan );
+ push @ordered_tokens, values %copy;
+
+ $self->{ordered_tokens} = \@ordered_tokens;
+}
+
+##############################################################################
+
+=head3 C<tokenize>
+
+ my $token = $grammar->tokenize;
+
+This method will return a L<TAP::Parser::Result> object representing the
+current line of TAP.
+
+=cut
+
+sub tokenize {
+ my $self = shift;
+
+ my $line = $self->{iterator}->next;
+ unless ( defined $line ) {
+ delete $self->{parser}; # break circular ref
+ return;
+ }
+
+ my $token;
+
+ for my $token_data ( @{ $self->{ordered_tokens} } ) {
+ if ( $line =~ $token_data->{syntax} ) {
+ my $handler = $token_data->{handler};
+ $token = $self->$handler($line);
+ last;
+ }
+ }
+
+ $token = $self->_make_unknown_token($line) unless $token;
+
+ return $self->{parser}->make_result($token);
+}
+
+##############################################################################
+
+=head3 C<token_types>
+
+ my @types = $grammar->token_types;
+
+Returns the different types of tokens which this grammar can parse.
+
+=cut
+
+sub token_types {
+ my $self = shift;
+ return keys %{ $self->{tokens} };
+}
+
+##############################################################################
+
+=head3 C<syntax_for>
+
+ my $syntax = $grammar->syntax_for($token_type);
+
+Returns a pre-compiled regular expression which will match a chunk of TAP
+corresponding to the token type. For example (not that you should really pay
+attention to this, C<< $grammar->syntax_for('comment') >> will return
+C<< qr/^#(.*)/ >>.
+
+=cut
+
+sub syntax_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{syntax};
+}
+
+##############################################################################
+
+=head3 C<handler_for>
+
+ my $handler = $grammar->handler_for($token_type);
+
+Returns a code reference which, when passed an appropriate line of TAP,
+returns the lexed token corresponding to that line. As a result, the basic
+TAP parsing loop looks similar to the following:
+
+ my @tokens;
+ my $grammar = TAP::Grammar->new;
+ LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
+ for my $type ( $grammar->token_types ) {
+ my $syntax = $grammar->syntax_for($type);
+ if ( $line =~ $syntax ) {
+ my $handler = $grammar->handler_for($type);
+ push @tokens => $grammar->$handler($line);
+ next LINE;
+ }
+ }
+ push @tokens => $grammar->_make_unknown_token($line);
+ }
+
+=cut
+
+sub handler_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{handler};
+}
+
+sub _make_version_token {
+ my ( $self, $line, $version ) = @_;
+ return {
+ type => 'version',
+ raw => $line,
+ version => $version,
+ };
+}
+
+sub _make_plan_token {
+ my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
+
+ if ( $directive eq 'SKIP'
+ && 0 != $tests_planned
+ && $self->{version} < 13 )
+ {
+ warn
+ "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+ }
+
+ return {
+ type => 'plan',
+ raw => $line,
+ tests_planned => $tests_planned,
+ directive => $directive,
+ explanation => _trim($explanation),
+ todo_list => $todo,
+ };
+}
+
+sub _make_test_token {
+ my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+ return {
+ ok => $ok,
+ test_num => $num,
+ description => _trim($desc),
+ directive => ( defined $dir ? uc $dir : '' ),
+ explanation => _trim($explanation),
+ raw => $line,
+ type => 'test',
+ };
+}
+
+sub _make_unknown_token {
+ my ( $self, $line ) = @_;
+ return {
+ raw => $line,
+ type => 'unknown',
+ };
+}
+
+sub _make_comment_token {
+ my ( $self, $line, $comment ) = @_;
+ return {
+ type => 'comment',
+ raw => $line,
+ comment => _trim($comment)
+ };
+}
+
+sub _make_bailout_token {
+ my ( $self, $line, $explanation ) = @_;
+ return {
+ type => 'bailout',
+ raw => $line,
+ bailout => _trim($explanation)
+ };
+}
+
+sub _make_yaml_token {
+ my ( $self, $pad, $marker ) = @_;
+
+ my $yaml = TAP::Parser::YAMLish::Reader->new;
+
+ my $iterator = $self->{iterator};
+
+ # Construct a reader that reads from our input stripping leading
+ # spaces from each line.
+ my $leader = length($pad);
+ my $strip = qr{ ^ (\s{$leader}) (.*) $ }x;
+ my @extra = ($marker);
+ my $reader = sub {
+ return shift @extra if @extra;
+ my $line = $iterator->next;
+ return $2 if $line =~ $strip;
+ return;
+ };
+
+ my $data = $yaml->read($reader);
+
+ # Reconstitute input. This is convoluted. Maybe we should just
+ # record it on the way in...
+ chomp( my $raw = $yaml->get_raw );
+ $raw =~ s/^/$pad/mg;
+
+ return {
+ type => 'yaml',
+ raw => $raw,
+ data => $data
+ };
+}
+
+sub _make_pragma_token {
+ my ( $self, $line, $pragmas ) = @_;
+ return {
+ type => 'pragma',
+ raw => $line,
+ pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
+ };
+}
+
+sub _trim {
+ my $data = shift;
+
+ return '' unless defined $data;
+
+ $data =~ s/^\s+//;
+ $data =~ s/\s+$//;
+ return $data;
+}
+
+1;
+
+=head1 TAP GRAMMAR
+
+B<NOTE:> This grammar is slightly out of date. There's still some discussion
+about it and a new one will be provided when we have things better defined.
+
+The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
+stream-based protocol. In fact, it's quite legal to have an infinite stream.
+For the same reason that we don't apply regexes to streams, we're not using a
+formal grammar here. Instead, we parse the TAP in lines.
+
+For purposes for forward compatability, any result which does not match the
+following grammar is currently referred to as
+L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
+
+A formal grammar would look similar to the following:
+
+ (*
+ For the time being, I'm cheating on the EBNF by allowing
+ certain terms to be defined by POSIX character classes by
+ using the following syntax:
+
+ digit ::= [:digit:]
+
+ As far as I am aware, that's not valid EBNF. Sue me. I
+ didn't know how to write "char" otherwise (Unicode issues).
+ Suggestions welcome.
+ *)
+
+ tap ::= version? { comment | unknown } leading_plan lines
+ |
+ lines trailing_plan {comment}
+
+ version ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
+
+ leading_plan ::= plan skip_directive? "\n"
+
+ trailing_plan ::= plan "\n"
+
+ plan ::= '1..' nonNegativeInteger
+
+ lines ::= line {line}
+
+ line ::= (comment | test | unknown | bailout ) "\n"
+
+ test ::= status positiveInteger? description? directive?
+
+ status ::= 'not '? 'ok '
+
+ description ::= (character - (digit | '#')) {character - '#'}
+
+ directive ::= todo_directive | skip_directive
+
+ todo_directive ::= hash_mark 'TODO' ' ' {character}
+
+ skip_directive ::= hash_mark 'SKIP' ' ' {character}
+
+ comment ::= hash_mark {character}
+
+ hash_mark ::= '#' {' '}
+
+ bailout ::= 'Bail out!' {character}
+
+ unknown ::= { (character - "\n") }
+
+ (* POSIX character classes and other terminals *)
+
+ digit ::= [:digit:]
+ character ::= ([:print:] - "\n")
+ positiveInteger ::= ( digit - '0' ) {digit}
+ nonNegativeInteger ::= digit {digit}
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
+do is read through the code. There's no easy way of summarizing it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Result>,
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator.pm
new file mode 100755
index 00000000000..34c0729727c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator.pm
@@ -0,0 +1,165 @@
+package TAP::Parser::Iterator;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Iterator - Base class for TAP source iterators
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ # to subclass:
+ use vars qw(@ISA);
+ use TAP::Parser::Iterator ();
+ @ISA = qw(TAP::Parser::Iterator);
+ sub _initialize {
+ # see TAP::Object...
+ }
+
+ sub next_raw { ... }
+ sub wait { ... }
+ sub exit { ... }
+
+=head1 DESCRIPTION
+
+This is a simple iterator base class that defines L<TAP::Parser>'s iterator
+API. Iterators are typically created from L<TAP::Parser::SourceHandler>s.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Provided by L<TAP::Object>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+B<Note:> this method is abstract and should be overridden.
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub next {
+ my $self = shift;
+ my $line = $self->next_raw;
+
+ # vms nit: When encountering 'not ok', vms often has the 'not' on a line
+ # by itself:
+ # not
+ # ok 1 - 'I hate VMS'
+ if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
+ $line .= ( $self->next_raw || '' );
+ }
+
+ return $line;
+}
+
+sub next_raw {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+=head3 C<handle_unicode>
+
+If necessary switch the input stream to handle unicode. This only has
+any effect for I/O handle based streams.
+
+The default implementation does nothing.
+
+=cut
+
+sub handle_unicode { }
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle-based should return an empty list.
+
+The default implementation does nothing.
+
+=cut
+
+sub get_select_handles {
+ return;
+}
+
+=head3 C<wait>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->wait;
+
+Return the C<wait> status for this iterator.
+
+=head3 C<exit>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->exit;
+
+Return the C<exit> status for this iterator.
+
+=cut
+
+sub wait {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+sub exit {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+You must override the abstract methods as noted above.
+
+=head2 Example
+
+L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
+There's not much point repeating it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Array.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Array.pm
new file mode 100755
index 00000000000..9bb813ee017
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Array.pm
@@ -0,0 +1,102 @@
+package TAP::Parser::Iterator::Array;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Array - Iterator for array-based TAP sources
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator::Array;
+ my @data = ('foo', 'bar', baz');
+ my $it = TAP::Parser::Iterator::Array->new(\@data);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for arrays of scalar content, used by
+L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Takes one argument: an C<$array_ref>
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. For an array iterator this will always
+be zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. For an array iterator this will always
+be zero.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ chomp @$thing;
+ $self->{idx} = 0;
+ $self->{array} = $thing;
+ $self->{exit} = undef;
+ return $self;
+}
+
+sub wait { shift->exit }
+
+sub exit {
+ my $self = shift;
+ return 0 if $self->{idx} >= @{ $self->{array} };
+ return;
+}
+
+sub next_raw {
+ my $self = shift;
+ return $self->{array}->[ $self->{idx}++ ];
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Process.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Process.pm
new file mode 100755
index 00000000000..c2b92461a89
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Process.pm
@@ -0,0 +1,381 @@
+package TAP::Parser::Iterator::Process;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+use Config;
+use IO::Handle;
+
+@ISA = 'TAP::Parser::Iterator';
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Iterator for proccess-based TAP sources
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator::Process;
+ my %args = (
+ command => ['python', 'setup.py', 'test'],
+ merge => 1,
+ setup => sub { ... },
+ teardown => sub { ... },
+ );
+ my $it = TAP::Parser::Iterator::Process->new(\%args);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for executing external processes, used by
+L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a hashref of the form:
+
+ command => \@command_to_execute
+ merge => $attempt_merge_stderr_and_stdout?
+ setup => $callback_to_setup_command
+ teardown => $callback_to_teardown_command
+
+Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
+process if they are available. Falls back onto C<open()>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through the process output, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator's process.
+
+=head3 C<exit>
+
+Get the exit status for this iterator's process.
+
+=cut
+
+{
+
+ local $^W; # no warnings
+ # get around a catch22 in the test suite that causes failures on Win32:
+ local $SIG{__DIE__} = undef;
+ eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+ if ($@) {
+ *_wait2exit = sub { $_[1] >> 8 };
+ }
+ else {
+ *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
+ }
+}
+
+sub _use_open3 {
+ my $self = shift;
+ return unless $Config{d_fork} || $IS_WIN32;
+ for my $module (qw( IPC::Open3 IO::Select )) {
+ eval "use $module";
+ return if $@;
+ }
+ return 1;
+}
+
+{
+ my $got_unicode;
+
+ sub _get_unicode {
+ return $got_unicode if defined $got_unicode;
+ eval 'use Encode qw(decode_utf8);';
+ $got_unicode = $@ ? 0 : 1;
+
+ }
+}
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+
+ my @command = @{ delete $args->{command} || [] }
+ or die "Must supply a command to execute";
+
+ $self->{command} = [@command];
+
+ # Private. Used to frig with chunk size during testing.
+ my $chunk_size = delete $args->{_chunk_size} || 65536;
+
+ my $merge = delete $args->{merge};
+ my ( $pid, $err, $sel );
+
+ if ( my $setup = delete $args->{setup} ) {
+ $setup->(@command);
+ }
+
+ my $out = IO::Handle->new;
+
+ if ( $self->_use_open3 ) {
+
+ # HOTPATCH {{{
+ my $xclose = \&IPC::Open3::xclose;
+ local $^W; # no warnings
+ local *IPC::Open3::xclose = sub {
+ my $fh = shift;
+ no strict 'refs';
+ return if ( fileno($fh) == fileno(STDIN) );
+ $xclose->($fh);
+ };
+
+ # }}}
+
+ if ($IS_WIN32) {
+ $err = $merge ? '' : '>&STDERR';
+ eval {
+ $pid = open3(
+ '<&STDIN', $out, $merge ? '' : $err,
+ @command
+ );
+ };
+ die "Could not execute (@command): $@" if $@;
+ if ( $] >= 5.006 ) {
+
+ # Kludge to avoid warning under 5.5
+ eval 'binmode($out, ":crlf")';
+ }
+ }
+ else {
+ $err = $merge ? '' : IO::Handle->new;
+ eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
+ die "Could not execute (@command): $@" if $@;
+ $sel = $merge ? undef : IO::Select->new( $out, $err );
+ }
+ }
+ else {
+ $err = '';
+ my $command
+ = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
+ open( $out, "$command|" )
+ or die "Could not execute ($command): $!";
+ }
+
+ $self->{out} = $out;
+ $self->{err} = $err;
+ $self->{sel} = $sel;
+ $self->{pid} = $pid;
+ $self->{exit} = undef;
+ $self->{chunk_size} = $chunk_size;
+
+ if ( my $teardown = delete $args->{teardown} ) {
+ $self->{teardown} = sub {
+ $teardown->(@command);
+ };
+ }
+
+ return $self;
+}
+
+=head3 C<handle_unicode>
+
+Upgrade the input stream to handle UTF8.
+
+=cut
+
+sub handle_unicode {
+ my $self = shift;
+
+ if ( $self->{sel} ) {
+ if ( _get_unicode() ) {
+
+ # Make sure our iterator has been constructed and...
+ my $next = $self->{_next} ||= $self->_next;
+
+ # ...wrap it to do UTF8 casting
+ $self->{_next} = sub {
+ my $line = $next->();
+ return decode_utf8($line) if defined $line;
+ return;
+ };
+ }
+ }
+ else {
+ if ( $] >= 5.008 ) {
+ eval 'binmode($self->{out}, ":utf8")';
+ }
+ }
+
+}
+
+##############################################################################
+
+sub wait { shift->{wait} }
+sub exit { shift->{exit} }
+
+sub _next {
+ my $self = shift;
+
+ if ( my $out = $self->{out} ) {
+ if ( my $sel = $self->{sel} ) {
+ my $err = $self->{err};
+ my @buf = ();
+ my $partial = ''; # Partial line
+ my $chunk_size = $self->{chunk_size};
+ return sub {
+ return shift @buf if @buf;
+
+ READ:
+ while ( my @ready = $sel->can_read ) {
+ for my $fh (@ready) {
+ my $got = sysread $fh, my ($chunk), $chunk_size;
+
+ if ( $got == 0 ) {
+ $sel->remove($fh);
+ }
+ elsif ( $fh == $err ) {
+ print STDERR $chunk; # echo STDERR
+ }
+ else {
+ $chunk = $partial . $chunk;
+ $partial = '';
+
+ # Make sure we have a complete line
+ unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
+ my $nl = rindex $chunk, "\n";
+ if ( $nl == -1 ) {
+ $partial = $chunk;
+ redo READ;
+ }
+ else {
+ $partial = substr( $chunk, $nl + 1 );
+ $chunk = substr( $chunk, 0, $nl );
+ }
+ }
+
+ push @buf, split /\n/, $chunk;
+ return shift @buf if @buf;
+ }
+ }
+ }
+
+ # Return partial last line
+ if ( length $partial ) {
+ my $last = $partial;
+ $partial = '';
+ return $last;
+ }
+
+ $self->_finish;
+ return;
+ };
+ }
+ else {
+ return sub {
+ if ( defined( my $line = <$out> ) ) {
+ chomp $line;
+ return $line;
+ }
+ $self->_finish;
+ return;
+ };
+ }
+ }
+ else {
+ return sub {
+ $self->_finish;
+ return;
+ };
+ }
+}
+
+sub next_raw {
+ my $self = shift;
+ return ( $self->{_next} ||= $self->_next )->();
+}
+
+sub _finish {
+ my $self = shift;
+
+ my $status = $?;
+
+ # Avoid circular refs
+ $self->{_next} = sub {return}
+ if $] >= 5.006;
+
+ # If we have a subprocess we need to wait for it to terminate
+ if ( defined $self->{pid} ) {
+ if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+ $status = $?;
+ }
+ }
+
+ ( delete $self->{out} )->close if $self->{out};
+
+ # If we have an IO::Select we also have an error handle to close.
+ if ( $self->{sel} ) {
+ ( delete $self->{err} )->close;
+ delete $self->{sel};
+ }
+ else {
+ $status = $?;
+ }
+
+ # Sometimes we get -1 on Windows. Presumably that means status not
+ # available.
+ $status = 0 if $IS_WIN32 && $status == -1;
+
+ $self->{wait} = $status;
+ $self->{exit} = $self->_wait2exit($status);
+
+ if ( my $teardown = $self->{teardown} ) {
+ $teardown->();
+ }
+
+ return $self;
+}
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {
+ my $self = shift;
+ return grep $_, ( $self->{out}, $self->{err} );
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Stream.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Stream.pm
new file mode 100755
index 00000000000..32c05508e66
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Iterator/Stream.pm
@@ -0,0 +1,108 @@
+package TAP::Parser::Iterator::Stream;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator::Stream;
+ open( TEST, 'test.tap' );
+ my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for reading from filehandles, used by
+L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a filehandle.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ $self->{fh} = $thing;
+ return $self;
+}
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. Always returns zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. Always returns zero.
+
+=cut
+
+sub wait { shift->exit }
+sub exit { shift->{fh} ? () : 0 }
+
+sub next_raw {
+ my $self = shift;
+ my $fh = $self->{fh};
+
+ if ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ return $line;
+ }
+ else {
+ $self->_finish;
+ return;
+ }
+}
+
+sub _finish {
+ my $self = shift;
+ close delete $self->{fh};
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/IteratorFactory.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/IteratorFactory.pm
new file mode 100755
index 00000000000..3a46a50ec55
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/IteratorFactory.pm
@@ -0,0 +1,342 @@
+package TAP::Parser::IteratorFactory;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+use Carp qw( confess );
+use File::Basename qw( fileparse );
+
+@ISA = qw(TAP::Object);
+
+use constant handlers => [];
+
+=head1 NAME
+
+TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::IteratorFactory;
+ my $factory = TAP::Parser::IteratorFactory->new({ %config });
+ my $iterator = $factory->make_iterator( $filename );
+
+=head1 DESCRIPTION
+
+This is a factory class that takes a L<TAP::Parser::Source> and runs it through all the
+registered L<TAP::Parser::SourceHandler>s to see which one should handle the source.
+
+If you're a plugin author, you'll be interested in how to L</register_handler>s,
+how L</detect_source> works.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class:
+
+ my $sf = TAP::Parser::IteratorFactory->new( $config );
+
+C<$config> is optional. If given, sets L</config> and calls L</load_handlers>.
+
+=cut
+
+sub _initialize {
+ my ( $self, $config ) = @_;
+ $self->config( $config || {} )->load_handlers;
+ return $self;
+}
+
+=head3 C<register_handler>
+
+Registers a new L<TAP::Parser::SourceHandler> with this factory.
+
+ __PACKAGE__->register_handler( $handler_class );
+
+=head3 C<handlers>
+
+List of handlers that have been registered.
+
+=cut
+
+sub register_handler {
+ my ( $class, $dclass ) = @_;
+
+ confess("$dclass must implement can_handle & make_iterator methods!")
+ unless UNIVERSAL::can( $dclass, 'can_handle' )
+ && UNIVERSAL::can( $dclass, 'make_iterator' );
+
+ my $handlers = $class->handlers;
+ push @{$handlers}, $dclass
+ unless grep { $_ eq $dclass } @{$handlers};
+
+ return $class;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<config>
+
+ my $cfg = $sf->config;
+ $sf->config({ Perl => { %config } });
+
+Chaining getter/setter for the configuration of the available source handlers.
+This is a hashref keyed on handler class whose values contain config to be passed
+onto the handlers during detection & creation. Class names may be fully qualified
+or abbreviated, eg:
+
+ # these are equivalent
+ $sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } });
+ $sf->config({ 'Perl' => { %config } });
+
+=cut
+
+sub config {
+ my $self = shift;
+ return $self->{config} unless @_;
+ unless ( 'HASH' eq ref $_[0] ) {
+ $self->_croak('Argument to &config must be a hash reference');
+ }
+ $self->{config} = shift;
+ return $self;
+}
+
+sub _last_handler {
+ my $self = shift;
+ return $self->{last_handler} unless @_;
+ $self->{last_handler} = shift;
+ return $self;
+}
+
+sub _testing {
+ my $self = shift;
+ return $self->{testing} unless @_;
+ $self->{testing} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<load_handlers>
+
+ $sf->load_handlers;
+
+Loads the handler classes defined in L</config>. For example, given a config:
+
+ $sf->config({
+ MySourceHandler => { some => 'config' },
+ });
+
+C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in
+C<@INC> for it in this order:
+
+ TAP::Parser::SourceHandler::MySourceHandler
+ MySourceHandler
+
+C<croak>s on error.
+
+=cut
+
+sub load_handlers {
+ my ($self) = @_;
+ for my $handler ( keys %{ $self->config } ) {
+ my $sclass = $self->_load_handler($handler);
+
+ # TODO: store which class we loaded anywhere?
+ }
+ return $self;
+}
+
+sub _load_handler {
+ my ( $self, $handler ) = @_;
+
+ my @errors;
+ for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) {
+ return $dclass
+ if UNIVERSAL::can( $dclass, 'can_handle' )
+ && UNIVERSAL::can( $dclass, 'make_iterator' );
+
+ eval "use $dclass";
+ if ( my $e = $@ ) {
+ push @errors, $e;
+ next;
+ }
+
+ return $dclass
+ if UNIVERSAL::can( $dclass, 'can_handle' )
+ && UNIVERSAL::can( $dclass, 'make_iterator' );
+ push @errors,
+ "handler '$dclass' does not implement can_handle & make_iterator";
+ }
+
+ $self->_croak(
+ "Cannot load handler '$handler': " . join( "\n", @errors ) );
+}
+
+##############################################################################
+
+=head3 C<make_iterator>
+
+ my $iterator = $src_factory->make_iterator( $source );
+
+Given a L<TAP::Parser::Source>, finds the most suitable L<TAP::Parser::SourceHandler>
+to use to create a L<TAP::Parser::Iterator> (see L</detect_source>). Dies on error.
+
+=cut
+
+sub make_iterator {
+ my ( $self, $source ) = @_;
+
+ $self->_croak('no raw source defined!') unless defined $source->raw;
+
+ $source->config( $self->config )->assemble_meta;
+
+ # is the raw source already an object?
+ return $source->raw
+ if ( $source->meta->{is_object}
+ && UNIVERSAL::isa( $source->raw, 'TAP::Parser::SourceHandler' ) );
+
+ # figure out what kind of source it is
+ my $sd_class = $self->detect_source($source);
+ $self->_last_handler($sd_class);
+
+ return if $self->_testing;
+
+ # create it
+ my $iterator = $sd_class->make_iterator($source);
+
+ return $iterator;
+}
+
+=head3 C<detect_source>
+
+Given a L<TAP::Parser::Source>, detects what kind of source it is and
+returns I<one> L<TAP::Parser::SourceHandler> (the most confident one). Dies
+on error.
+
+The detection algorithm works something like this:
+
+ for (@registered_handlers) {
+ # ask them how confident they are about handling this source
+ $confidence{$handler} = $handler->can_handle( $source )
+ }
+ # choose the most confident handler
+
+Ties are handled by choosing the first handler.
+
+=cut
+
+sub detect_source {
+ my ( $self, $source ) = @_;
+
+ confess('no raw source ref defined!') unless defined $source->raw;
+
+ # find a list of handlers that can handle this source:
+ my %handlers;
+ for my $dclass ( @{ $self->handlers } ) {
+ my $confidence = $dclass->can_handle($source);
+
+ # warn "handler: $dclass: $confidence\n";
+ $handlers{$dclass} = $confidence if $confidence;
+ }
+
+ if ( !%handlers ) {
+
+ # use Data::Dump qw( pp );
+ # warn pp( $meta );
+
+ # error: can't detect source
+ my $raw_source_short = substr( ${ $source->raw }, 0, 50 );
+ confess("Cannot detect source of '$raw_source_short'!");
+ return;
+ }
+
+ # if multiple handlers can handle it, choose the most confident one
+ my @handlers = (
+ map {$_}
+ sort { $handlers{$a} cmp $handlers{$b} }
+ keys %handlers
+ );
+
+ # this is really useful for debugging handlers:
+ if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) {
+ warn(
+ "votes: ",
+ join( ', ', map {"$_: $handlers{$_}"} @handlers ),
+ "\n"
+ );
+ }
+
+ # return 1st
+ return pop @handlers;
+}
+
+1;
+
+__END__
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+If we've done things right, you'll probably want to write a new source,
+rather than sub-classing this (see L<TAP::Parser::SourceHandler> for that).
+
+But in case you find the need to...
+
+ package MyIteratorFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use TAP::Parser::IteratorFactory;
+
+ @ISA = qw( TAP::Parser::IteratorFactory );
+
+ # override source detection algorithm
+ sub detect_source {
+ my ($self, $raw_source_ref, $meta) = @_;
+ # do detective work, using $meta and whatever else...
+ }
+
+ 1;
+
+=head1 AUTHORS
+
+Steve Purkis
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+Moved out of L<TAP::Parser> & converted to a factory class to support
+extensible TAP source detective work by Steve Purkis.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::RawTAP>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::Executable>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Multiplexer.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Multiplexer.pm
new file mode 100755
index 00000000000..306bbb975ad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Multiplexer.pm
@@ -0,0 +1,195 @@
+package TAP::Parser::Multiplexer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use IO::Select;
+use TAP::Object ();
+
+use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
+use constant IS_VMS => $^O eq 'VMS';
+use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+
+@ISA = 'TAP::Object';
+
+=head1 NAME
+
+TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Multiplexer;
+
+ my $mux = TAP::Parser::Multiplexer->new;
+ $mux->add( $parser1, $stash1 );
+ $mux->add( $parser2, $stash2 );
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+ # do stuff
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
+Internally it calls select on the input file handles for those parsers
+to wait for one or more of them to have input available.
+
+See L<TAP::Harness> for an example of its use.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $mux = TAP::Parser::Multiplexer->new;
+
+Returns a new C<TAP::Parser::Multiplexer> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ $self->{select} = IO::Select->new;
+ $self->{avid} = []; # Parsers that can't select
+ $self->{count} = 0;
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $mux->add( $parser, $stash );
+
+Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
+reference that will be returned from C<next> along with the parser and
+the next result.
+
+=cut
+
+sub add {
+ my ( $self, $parser, $stash ) = @_;
+
+ if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
+ my $sel = $self->{select};
+
+ # We have to turn handles into file numbers here because by
+ # the time we want to remove them from our IO::Select they
+ # will already have been closed by the iterator.
+ my @filenos = map { fileno $_ } @handles;
+ for my $h (@handles) {
+ $sel->add( [ $h, $parser, $stash, @filenos ] );
+ }
+
+ $self->{count}++;
+ }
+ else {
+ push @{ $self->{avid} }, [ $parser, $stash ];
+ }
+}
+
+=head3 C<parsers>
+
+ my $count = $mux->parsers;
+
+Returns the number of parsers. Parsers are removed from the multiplexer
+when their input is exhausted.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->{count} + scalar @{ $self->{avid} };
+}
+
+sub _iter {
+ my $self = shift;
+
+ my $sel = $self->{select};
+ my $avid = $self->{avid};
+ my @ready = ();
+
+ return sub {
+
+ # Drain all the non-selectable parsers first
+ if (@$avid) {
+ my ( $parser, $stash ) = @{ $avid->[0] };
+ my $result = $parser->next;
+ shift @$avid unless defined $result;
+ return ( $parser, $stash, $result );
+ }
+
+ unless (@ready) {
+ return unless $sel->count;
+ @ready = $sel->can_read;
+ }
+
+ my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
+ my $result = $parser->next;
+
+ unless ( defined $result ) {
+ $sel->remove(@handles);
+ $self->{count}--;
+
+ # Force another can_read - we may now have removed a handle
+ # thought to have been ready.
+ @ready = ();
+ }
+
+ return ( $parser, $stash, $result );
+ };
+}
+
+=head3 C<next>
+
+Return a result from the next available parser. Returns a list
+containing the parser from which the result came, the stash that
+corresponds with that parser and the result.
+
+ my ( $parser, $stash, $result ) = $mux->next;
+
+If C<$result> is undefined the corresponding parser has reached the end
+of its input (and will automatically be removed from the multiplexer).
+
+When all parsers are exhausted an empty list will be returned.
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ if ( ! defined $result ) {
+ # End of this parser
+ }
+ else {
+ # Process result
+ }
+ }
+ else {
+ # All parsers finished
+ }
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result.pm
new file mode 100755
index 00000000000..2f1e8201df0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result.pm
@@ -0,0 +1,300 @@
+package TAP::Parser::Result;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+
+BEGIN {
+
+ # make is_* methods
+ my @attrs = qw( plan pragma test comment bailout version unknown yaml );
+ no strict 'refs';
+ for my $token (@attrs) {
+ my $method = "is_$token";
+ *$method = sub { return $token eq shift->type };
+ }
+}
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::Result - Base class for TAP::Parser output objects
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ # abstract class - not meany to be used directly
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # directly:
+ use TAP::Parser::Result;
+ my $token = {...};
+ my $result = TAP::Parser::Result->new( $token );
+
+=head2 DESCRIPTION
+
+This is a simple base class used by L<TAP::Parser> to store objects that
+represent the current bit of test output data from TAP (usually a single
+line). Unless you're subclassing, you probably won't need to use this module
+directly.
+
+=head2 METHODS
+
+=head3 C<new>
+
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # to use directly:
+ my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+# new() implementation provided by TAP::Object
+
+sub _initialize {
+ my ( $self, $token ) = @_;
+ if ($token) {
+
+ # assign to a hash slice to make a shallow copy of the token.
+ # I guess we could assign to the hash as (by default) there are not
+ # contents, but that seems less helpful if someone wants to subclass us
+ @{$self}{ keys %$token } = values %$token;
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Boolean methods
+
+The following methods all return a boolean value and are to be overridden in
+the appropriate subclass.
+
+=over 4
+
+=item * C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+ 1..3
+
+=item * C<is_pragma>
+
+Indicates whether or not this is a pragma line.
+
+ pragma +strict
+
+=item * C<is_test>
+
+Indicates whether or not this is a test line.
+
+ ok 1 Is OK!
+
+=item * C<is_comment>
+
+Indicates whether or not this is a comment.
+
+ # this is a comment
+
+=item * C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+ Bail out! We're out of dilithium crystals.
+
+=item * C<is_version>
+
+Indicates whether or not this is a TAP version line.
+
+ TAP version 4
+
+=item * C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+ ... this line is junk ...
+
+=item * C<is_yaml>
+
+Indicates whether or not this is a YAML chunk.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head3 C<raw>
+
+ print $result->raw;
+
+Returns the original line of text which was parsed.
+
+=cut
+
+sub raw { shift->{raw} }
+
+##############################################################################
+
+=head3 C<type>
+
+ my $type = $result->type;
+
+Returns the "type" of a token, such as C<comment> or C<test>.
+
+=cut
+
+sub type { shift->{type} }
+
+##############################################################################
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=cut
+
+sub as_string { shift->{raw} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut.
+
+=cut
+
+sub is_ok {1}
+
+##############################################################################
+
+=head3 C<passed>
+
+Deprecated. Please use C<is_ok> instead.
+
+=cut
+
+sub passed {
+ warn 'passed() is deprecated. Please use "is_ok()"';
+ shift->is_ok;
+}
+
+##############################################################################
+
+=head3 C<has_directive>
+
+ if ( $result->has_directive ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO or SKIP directive.
+
+=cut
+
+sub has_directive {
+ my $self = shift;
+ return ( $self->has_todo || $self->has_skip );
+}
+
+##############################################################################
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO directive.
+
+=cut
+
+sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) {
+ ...
+ }
+
+Indicates whether or not the given result has a SKIP directive.
+
+=cut
+
+sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
+
+=head3 C<set_directive>
+
+Set the directive associated with this token. Used internally to fake
+TODO tests.
+
+=cut
+
+sub set_directive {
+ my ( $self, $dir ) = @_;
+ $self->{directive} = $dir;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+Remember: if you want your subclass to be automatically used by the parser,
+you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
+
+If you're creating a completely new result I<type>, you'll probably need to
+subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
+
+=head2 Example
+
+ package MyResult;
+
+ use strict;
+ use vars '@ISA';
+
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ sub as_string { 'My results all look the same' }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::ResultFactory>,
+L<TAP::Parser::Result::Bailout>,
+L<TAP::Parser::Result::Comment>,
+L<TAP::Parser::Result::Plan>,
+L<TAP::Parser::Result::Pragma>,
+L<TAP::Parser::Result::Test>,
+L<TAP::Parser::Result::Unknown>,
+L<TAP::Parser::Result::Version>,
+L<TAP::Parser::Result::YAML>,
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Bailout.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Bailout.pm
new file mode 100755
index 00000000000..383b37b695d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Bailout.pm
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Bailout;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Bailout - Bailout result token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a bail out line is encountered.
+
+ 1..5
+ ok 1 - woo hooo!
+ Bail out! Well, so much for "woo hooo!"
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=cut
+
+sub explanation { shift->{bailout} }
+sub as_string { shift->{bailout} }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Comment.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Comment.pm
new file mode 100755
index 00000000000..f3b8ced10ce
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Comment.pm
@@ -0,0 +1,61 @@
+package TAP::Parser::Result::Comment;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Comment - Comment result token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a comment line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+ # this is a comment
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+Note that this method merely returns the comment preceded by a '# '.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=cut
+
+sub comment { shift->{comment} }
+sub as_string { shift->{raw} }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Plan.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Plan.pm
new file mode 100755
index 00000000000..d43275d204f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Plan.pm
@@ -0,0 +1,120 @@
+package TAP::Parser::Result::Plan;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Plan - Plan result token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a plan line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub plan { '1..' . shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<tests_planned>
+
+ my $planned = $result->tests_planned;
+
+Returns the number of tests planned. For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=cut
+
+sub tests_planned { shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $plan->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<explanation>
+
+ my $explanation = $plan->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+=head3 C<todo_list>
+
+ my $todo = $result->todo_list;
+ for ( @$todo ) {
+ ...
+ }
+
+=cut
+
+sub todo_list { shift->{todo_list} }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Pragma.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Pragma.pm
new file mode 100755
index 00000000000..40feca71336
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Pragma.pm
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Pragma;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Pragma - TAP pragma token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a pragma is encountered.
+
+ TAP version 13
+ pragma +strict, -foo
+
+Pragmas are only supported from TAP version 13 onwards.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<pragmas>
+
+if ( $result->is_pragma ) {
+ @pragmas = $result->pragmas;
+}
+
+=cut
+
+sub pragmas {
+ my @pragmas = @{ shift->{pragmas} };
+ return wantarray ? @pragmas : \@pragmas;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Test.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Test.pm
new file mode 100755
index 00000000000..953aae3463f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Test.pm
@@ -0,0 +1,274 @@
+package TAP::Parser::Result::Test;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system. Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+ my ( $self, $number ) = @_;
+ $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false. See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+ my $self = shift;
+
+ return if $self->is_unplanned;
+
+ # TODO directives reverse the sense of a test.
+ return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+ my $self = shift;
+ return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated. Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+ warn 'actual_passed() is deprecated. Please use "is_actual_ok()"';
+ goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+ if ( $test->todo_passed ) {
+ # test unexpectedly succeeded
+ }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+ my $self = shift;
+ return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn 'todo_failed() is deprecated. Please use "todo_passed()"';
+ goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+This method prints the test as a string. It will probably be similar, but
+not necessarily identical, to the original test line. Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line. If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ my $string = $self->ok . " " . $self->number;
+ if ( my $description = $self->description ) {
+ $string .= " $description";
+ }
+ if ( my $directive = $self->directive ) {
+ my $explanation = $self->explanation;
+ $string .= " # $directive $explanation";
+ }
+ return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+ $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+ print <<'END';
+ ok 1
+ ok 2
+ 1..1
+ END
+
+=cut
+
+sub is_unplanned {
+ my $self = shift;
+ return ( $self->{unplanned} || '' ) unless @_;
+ $self->{unplanned} = !!shift;
+ return $self;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Unknown.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Unknown.pm
new file mode 100755
index 00000000000..f225ca19eae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Unknown.pm
@@ -0,0 +1,51 @@
+package TAP::Parser::Result::Unknown;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Unknown - Unknown result token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if the parser does not recognize the token line. For example:
+
+ 1..5
+ VERSION 7
+ ok 1 - woo hooo!
+ ... woo hooo! is cool!
+
+In the above "TAP", the second and fourth lines will generate "Unknown"
+tokens.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Version.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Version.pm
new file mode 100755
index 00000000000..bfb78e5e8e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/Version.pm
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Version;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Version - TAP syntax version token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a version line is encountered.
+
+ TAP version 13
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 13.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<version>
+
+ if ( $result->is_version ) {
+ print $result->version;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub version { shift->{version} }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/YAML.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/YAML.pm
new file mode 100755
index 00000000000..8b3c20ea305
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Result/YAML.pm
@@ -0,0 +1,62 @@
+package TAP::Parser::Result::YAML;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::YAML - YAML result token.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a YAML block is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<data>
+
+ if ( $result->is_yaml ) {
+ print $result->data;
+ }
+
+Return the parsed YAML data for this result
+
+=cut
+
+sub data { shift->{data} }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/ResultFactory.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/ResultFactory.pm
new file mode 100755
index 00000000000..99bbeeeb038
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/ResultFactory.pm
@@ -0,0 +1,189 @@
+package TAP::Parser::ResultFactory;
+
+use strict;
+use vars qw($VERSION @ISA %CLASS_FOR);
+
+use TAP::Object ();
+use TAP::Parser::Result::Bailout ();
+use TAP::Parser::Result::Comment ();
+use TAP::Parser::Result::Plan ();
+use TAP::Parser::Result::Pragma ();
+use TAP::Parser::Result::Test ();
+use TAP::Parser::Result::Unknown ();
+use TAP::Parser::Result::Version ();
+use TAP::Parser::Result::YAML ();
+
+@ISA = 'TAP::Object';
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::ResultFactory;
+ my $token = {...};
+ my $factory = TAP::Parser::ResultFactory->new;
+ my $result = $factory->make_result( $token );
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head2 DESCRIPTION
+
+This is a simple factory class which returns a L<TAP::Parser::Result> subclass
+representing the current bit of test data from TAP (usually a single line).
+It is used primarily by L<TAP::Parser::Grammar>. Unless you're subclassing,
+you probably won't need to use this module directly.
+
+=head2 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_result>
+
+Returns an instance the appropriate class for the test token passed in.
+
+ my $result = TAP::Parser::ResultFactory->make_result($token);
+
+Can also be called as an instance method.
+
+=cut
+
+sub make_result {
+ my ( $proto, $token ) = @_;
+ my $type = $token->{type};
+ return $proto->class_for($type)->new($token);
+}
+
+=head3 C<class_for>
+
+Takes one argument: C<$type>. Returns the class for this $type, or C<croak>s
+with an error.
+
+=head3 C<register_type>
+
+Takes two arguments: C<$type>, C<$class>
+
+This lets you override an existing type with your own custom type, or register
+a completely new type, eg:
+
+ # create a custom result type:
+ package MyResult;
+ use strict;
+ use vars qw(@ISA);
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ # use it:
+ my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
+
+Your custom type should then be picked up automatically by the L<TAP::Parser>.
+
+=cut
+
+BEGIN {
+ %CLASS_FOR = (
+ plan => 'TAP::Parser::Result::Plan',
+ pragma => 'TAP::Parser::Result::Pragma',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+ );
+}
+
+sub class_for {
+ my ( $class, $type ) = @_;
+
+ # return target class:
+ return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
+
+ # or complain:
+ require Carp;
+ Carp::croak("Could not determine class for result type '$type'");
+}
+
+sub register_type {
+ my ( $class, $type, $rclass ) = @_;
+
+ # register it blindly, assume they know what they're doing
+ $CLASS_FOR{$type} = $rclass;
+ return $class;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=item 2
+
+C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
+This I<will> change in a future version!
+
+=item 3
+
+L<TAP::Parser::Result> subclasses will register themselves with
+L<TAP::Parser::ResultFactory> directly:
+
+ package MyFooResult;
+ TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
+
+Of course, it's up to you to decide whether or not to ignore them.
+
+=back
+
+=head2 Example
+
+ package MyResultFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyResult;
+ use TAP::Parser::ResultFactory;
+
+ @ISA = qw( TAP::Parser::ResultFactory );
+
+ # force all results to be 'MyResult'
+ sub class_for {
+ return 'MyResult';
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<TAP::Parser>,
+L<TAP::Parser::Result>,
+L<TAP::Parser::Grammar>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler.pm
new file mode 100755
index 00000000000..031c5993c8e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler.pm
@@ -0,0 +1,312 @@
+package TAP::Parser::Scheduler;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use TAP::Parser::Scheduler::Job;
+use TAP::Parser::Scheduler::Spinner;
+
+=head1 NAME
+
+TAP::Parser::Scheduler - Schedule tests during parallel testing
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $sched = TAP::Parser::Scheduler->new;
+
+Returns a new C<TAP::Parser::Scheduler> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ croak "Need a number of key, value pairs" if @_ % 2;
+
+ my %args = @_;
+ my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+ my $rules = delete $args{rules} || { par => '**' };
+
+ croak "Unknown arg(s): ", join ', ', sort keys %args
+ if keys %args;
+
+ # Turn any simple names into a name, description pair. TODO: Maybe
+ # construct jobs here?
+ my $self = bless {}, $class;
+
+ $self->_set_rules( $rules, $tests );
+
+ return $self;
+}
+
+# Build the scheduler data structure.
+#
+# SCHEDULER-DATA ::= JOB
+# || ARRAY OF ARRAY OF SCHEDULER-DATA
+#
+# The nested arrays are the key to scheduling. The outer array contains
+# a list of things that may be executed in parallel. Whenever an
+# eligible job is sought any element of the outer array that is ready to
+# execute can be selected. The inner arrays represent sequential
+# execution. They can only proceed when the first job is ready to run.
+
+sub _set_rules {
+ my ( $self, $rules, $tests ) = @_;
+ my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
+ map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+ my $schedule = $self->_rule_clause( $rules, \@tests );
+
+ # If any tests are left add them as a sequential block at the end of
+ # the run.
+ $schedule = [ [ $schedule, @tests ] ] if @tests;
+
+ $self->{schedule} = $schedule;
+}
+
+sub _rule_clause {
+ my ( $self, $rule, $tests ) = @_;
+ croak 'Rule clause must be a hash'
+ unless 'HASH' eq ref $rule;
+
+ my @type = keys %$rule;
+ croak 'Rule clause must have exactly one key'
+ unless @type == 1;
+
+ my %handlers = (
+ par => sub {
+ [ map { [$_] } @_ ];
+ },
+ seq => sub { [ [@_] ] },
+ );
+
+ my $handler = $handlers{ $type[0] }
+ || croak 'Unknown scheduler type: ', $type[0];
+ my $val = $rule->{ $type[0] };
+
+ return $handler->(
+ map {
+ 'HASH' eq ref $_
+ ? $self->_rule_clause( $_, $tests )
+ : $self->_expand( $_, $tests )
+ } 'ARRAY' eq ref $val ? @$val : $val
+ );
+}
+
+sub _glob_to_regexp {
+ my ( $self, $glob ) = @_;
+ my $nesting;
+ my $pattern;
+
+ while (1) {
+ if ( $glob =~ /\G\*\*/gc ) {
+
+ # ** is any number of characters, including /, within a pathname
+ $pattern .= '.*?';
+ }
+ elsif ( $glob =~ /\G\*/gc ) {
+
+ # * is zero or more characters within a filename/directory name
+ $pattern .= '[^/]*';
+ }
+ elsif ( $glob =~ /\G\?/gc ) {
+
+ # ? is exactly one character within a filename/directory name
+ $pattern .= '[^/]';
+ }
+ elsif ( $glob =~ /\G\{/gc ) {
+
+ # {foo,bar,baz} is any of foo, bar or baz.
+ $pattern .= '(?:';
+ ++$nesting;
+ }
+ elsif ( $nesting and $glob =~ /\G,/gc ) {
+
+ # , is only special inside {}
+ $pattern .= '|';
+ }
+ elsif ( $nesting and $glob =~ /\G\}/gc ) {
+
+ # } that matches { is special. But unbalanced } are not.
+ $pattern .= ')';
+ --$nesting;
+ }
+ elsif ( $glob =~ /\G(\\.)/gc ) {
+
+ # A quoted literal
+ $pattern .= $1;
+ }
+ elsif ( $glob =~ /\G([\},])/gc ) {
+
+ # Sometimes meta characters
+ $pattern .= '\\' . $1;
+ }
+ else {
+
+ # Eat everything that is not a meta character.
+ $glob =~ /\G([^{?*\\\},]*)/gc;
+ $pattern .= quotemeta $1;
+ }
+ return $pattern if pos $glob == length $glob;
+ }
+}
+
+sub _expand {
+ my ( $self, $name, $tests ) = @_;
+
+ my $pattern = $self->_glob_to_regexp($name);
+ $pattern = qr/^ $pattern $/x;
+ my @match = ();
+
+ for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+ if ( $tests->[$ti]->filename =~ $pattern ) {
+ push @match, splice @$tests, $ti, 1;
+ $ti--;
+ }
+ }
+
+ return @match;
+}
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+ my $self = shift;
+ my @all = $self->_gather( $self->{schedule} );
+ $self->{count} = @all;
+ @all;
+}
+
+sub _gather {
+ my ( $self, $rule ) = @_;
+ return unless defined $rule;
+ return $rule unless 'ARRAY' eq ref $rule;
+ return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job or C<undef> if none are available. Returns
+a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
+jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+ my $self = shift;
+ $self->{count} ||= $self->get_all;
+ my @jobs = $self->_find_next_job( $self->{schedule} );
+ if (@jobs) {
+ --$self->{count};
+ return $jobs[0];
+ }
+
+ return TAP::Parser::Scheduler::Spinner->new
+ if $self->{count};
+
+ return;
+}
+
+sub _not_empty {
+ my $ar = shift;
+ return 1 unless 'ARRAY' eq ref $ar;
+ for (@$ar) {
+ return 1 if _not_empty($_);
+ }
+ return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+ my ( $self, $rule ) = @_;
+
+ my @queue = ();
+ my $index = 0;
+ while ( $index < @$rule ) {
+ my $seq = $rule->[$index];
+
+ # Prune any exhausted items.
+ shift @$seq while @$seq && _is_empty( $seq->[0] );
+ if (@$seq) {
+ if ( defined $seq->[0] ) {
+ if ( 'ARRAY' eq ref $seq->[0] ) {
+ push @queue, $seq;
+ }
+ else {
+ my $job = splice @$seq, 0, 1, undef;
+ $job->on_finish( sub { shift @$seq } );
+ return $job;
+ }
+ }
+ ++$index;
+ }
+ else {
+
+ # Remove the empty sub-array from the array
+ splice @$rule, $index, 1;
+ }
+ }
+
+ for my $seq (@queue) {
+ if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
+ return @jobs;
+ }
+ }
+
+ return;
+}
+
+=head3 C<as_string>
+
+Return a human readable representation of the scheduling tree.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ return $self->_as_string( $self->{schedule} );
+}
+
+sub _as_string {
+ my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
+ my $pad = ' ' x 2;
+ my $indent = $pad x $depth;
+ if ( !defined $rule ) {
+ return "$indent(undef)\n";
+ }
+ elsif ( 'ARRAY' eq ref $rule ) {
+ return unless @$rule;
+ my $type = ( 'par', 'seq' )[ $depth % 2 ];
+ return join(
+ '', "$indent$type:\n",
+ map { $self->_as_string( $_, $depth + 1 ) } @$rule
+ );
+ }
+ else {
+ return "$indent'" . $rule->filename . "'\n";
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Job.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Job.pm
new file mode 100755
index 00000000000..db04a077ef9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Job.pm
@@ -0,0 +1,107 @@
+package TAP::Parser::Scheduler::Job;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Job - A single testing job.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Job;
+
+=head1 DESCRIPTION
+
+Represents a single test 'job'.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Job->new(
+ $name, $desc
+ );
+
+Returns a new C<TAP::Parser::Scheduler::Job> object.
+
+=cut
+
+sub new {
+ my ( $class, $name, $desc, @ctx ) = @_;
+ return bless {
+ filename => $name,
+ description => $desc,
+ @ctx ? ( context => \@ctx ) : (),
+ }, $class;
+}
+
+=head3 C<on_finish>
+
+Register a closure to be called when this job is destroyed.
+
+=cut
+
+sub on_finish {
+ my ( $self, $cb ) = @_;
+ $self->{on_finish} = $cb;
+}
+
+=head3 C<finish>
+
+Called when a job is complete to unlock it.
+
+=cut
+
+sub finish {
+ my $self = shift;
+ if ( my $cb = $self->{on_finish} ) {
+ $cb->($self);
+ }
+}
+
+=head3 C<filename>
+
+=head3 C<description>
+
+=head3 C<context>
+
+=cut
+
+sub filename { shift->{filename} }
+sub description { shift->{description} }
+sub context { @{ shift->{context} || [] } }
+
+=head3 C<as_array_ref>
+
+For backwards compatibility in callbacks.
+
+=cut
+
+sub as_array_ref {
+ my $self = shift;
+ return [ $self->filename, $self->description, $self->{context} ||= [] ];
+}
+
+=head3 C<is_spinner>
+
+Returns false indicating that this is a real job rather than a
+'spinner'. Spinners are returned when the scheduler still has pending
+jobs but can't (because of locking) return one right now.
+
+=cut
+
+sub is_spinner {0}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Spinner.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Spinner.pm
new file mode 100755
index 00000000000..04884ff5aa9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Scheduler/Spinner.pm
@@ -0,0 +1,53 @@
+package TAP::Parser::Scheduler::Spinner;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Spinner - A no-op job.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Spinner;
+
+=head1 DESCRIPTION
+
+A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
+the harness to spin (keep executing tests) while the scheduler can't
+return a real job.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Spinner->new;
+
+Returns a new C<TAP::Parser::Scheduler::Spinner> object.
+
+=cut
+
+sub new { bless {}, shift }
+
+=head3 C<is_spinner>
+
+Returns true indicating that is a 'spinner' job. Spinners are returned
+when the scheduler still has pending jobs but can't (because of locking)
+return one right now.
+
+=cut
+
+sub is_spinner {1}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Source.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Source.pm
new file mode 100755
index 00000000000..1dd77c0351b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Source.pm
@@ -0,0 +1,385 @@
+package TAP::Parser::Source;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use File::Basename qw( fileparse );
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Source - a TAP source & meta data about it
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new;
+ $source->raw( \'reference to raw TAP source' )
+ ->config( \%config )
+ ->merge( $boolean )
+ ->switches( \@switches )
+ ->test_args( \@args )
+ ->assemble_meta;
+
+ do { ... } if $source->meta->{is_file};
+ # see assemble_meta for a full list of data available
+
+=head1 DESCRIPTION
+
+A TAP I<source> is something that produces a stream of TAP for the parser to
+consume, such as an executable file, a text file, an archive, an IO handle, a
+database, etc. C<TAP::Parser::Source>s encapsulate these I<raw> sources, and
+provide some useful meta data about them. They are used by
+L<TAP::Parser::SourceHandler>s, which do whatever is required to produce &
+capture a stream of TAP from the I<raw> source, and package it up in a
+L<TAP::Parser::Iterator> for the parser to consume.
+
+Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or
+subclassing L<TAP::Parser>, you probably won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ($self) = @_;
+ $self->meta( {} );
+ $self->config( {} );
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<raw>
+
+ my $raw = $source->raw;
+ $source->raw( $some_value );
+
+Chaining getter/setter for the raw TAP source. This is a reference, as it may
+contain large amounts of data (eg: raw TAP).
+
+=head3 C<meta>
+
+ my $meta = $source->meta;
+ $source->meta({ %some_value });
+
+Chaining getter/setter for meta data about the source. This defaults to an
+empty hashref. See L</assemble_meta> for more info.
+
+=head3 C<has_meta>
+
+True if the source has meta data.
+
+=head3 C<config>
+
+ my $config = $source->config;
+ $source->config({ %some_value });
+
+Chaining getter/setter for the source's configuration, if any has been provided
+by the user. How it's used is up to you. This defaults to an empty hashref.
+See L</config_for> for more info.
+
+=head3 C<merge>
+
+ my $merge = $source->merge;
+ $source->config( $bool );
+
+Chaining getter/setter for the flag that dictates whether STDOUT and STDERR
+should be merged (where appropriate). Defaults to undef.
+
+=head3 C<switches>
+
+ my $switches = $source->switches;
+ $source->config([ @switches ]);
+
+Chaining getter/setter for the list of command-line switches that should be
+passed to the source (where appropriate). Defaults to undef.
+
+=head3 C<test_args>
+
+ my $test_args = $source->test_args;
+ $source->config([ @test_args ]);
+
+Chaining getter/setter for the list of command-line arguments that should be
+passed to the source (where appropriate). Defaults to undef.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ return $self->{raw} unless @_;
+ $self->{raw} = shift;
+ return $self;
+}
+
+sub meta {
+ my $self = shift;
+ return $self->{meta} unless @_;
+ $self->{meta} = shift;
+ return $self;
+}
+
+sub has_meta {
+ return scalar %{ shift->meta } ? 1 : 0;
+}
+
+sub config {
+ my $self = shift;
+ return $self->{config} unless @_;
+ $self->{config} = shift;
+ return $self;
+}
+
+sub merge {
+ my $self = shift;
+ return $self->{merge} unless @_;
+ $self->{merge} = shift;
+ return $self;
+}
+
+sub switches {
+ my $self = shift;
+ return $self->{switches} unless @_;
+ $self->{switches} = shift;
+ return $self;
+}
+
+sub test_args {
+ my $self = shift;
+ return $self->{test_args} unless @_;
+ $self->{test_args} = shift;
+ return $self;
+}
+
+=head3 C<assemble_meta>
+
+ my $meta = $source->assemble_meta;
+
+Gathers meta data about the L</raw> source, stashes it in L</meta> and returns
+it as a hashref. This is done so that the L<TAP::Parser::SourceHandler>s don't
+have to repeat common checks. Currently this includes:
+
+ is_scalar => $bool,
+ is_hash => $bool,
+ is_array => $bool,
+
+ # for scalars:
+ length => $n
+ has_newlines => $bool
+
+ # only done if the scalar looks like a filename
+ is_file => $bool,
+ is_dir => $bool,
+ is_symlink => $bool,
+ file => {
+ # only done if the scalar looks like a filename
+ basename => $string, # including ext
+ dir => $string,
+ ext => $string,
+ lc_ext => $string,
+ # system checks
+ exists => $bool,
+ stat => [ ... ], # perldoc -f stat
+ empty => $bool,
+ size => $n,
+ text => $bool,
+ binary => $bool,
+ read => $bool,
+ write => $bool,
+ execute => $bool,
+ setuid => $bool,
+ setgid => $bool,
+ sticky => $bool,
+ is_file => $bool,
+ is_dir => $bool,
+ is_symlink => $bool,
+ # only done if the file's a symlink
+ lstat => [ ... ], # perldoc -f lstat
+ # only done if the file's a readable text file
+ shebang => $first_line,
+ }
+
+ # for arrays:
+ size => $n,
+
+=cut
+
+sub assemble_meta {
+ my ($self) = @_;
+
+ return $self->meta if $self->has_meta;
+
+ my $meta = $self->meta;
+ my $raw = $self->raw;
+
+ # rudimentary is object test - if it's blessed it'll
+ # inherit from UNIVERSAL
+ $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0;
+
+ if ( $meta->{is_object} ) {
+ $meta->{class} = ref($raw);
+ }
+ else {
+ my $ref = lc( ref($raw) );
+ $meta->{"is_$ref"} = 1;
+ }
+
+ if ( $meta->{is_scalar} ) {
+ my $source = $$raw;
+ $meta->{length} = length($$raw);
+ $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0;
+
+ # only do file checks if it looks like a filename
+ if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) {
+ my $file = {};
+ $file->{exists} = -e $source ? 1 : 0;
+ if ( $file->{exists} ) {
+ $meta->{file} = $file;
+
+ # avoid extra system calls (see `perldoc -f -X`)
+ $file->{stat} = [ stat(_) ];
+ $file->{empty} = -z _ ? 1 : 0;
+ $file->{size} = -s _;
+ $file->{text} = -T _ ? 1 : 0;
+ $file->{binary} = -B _ ? 1 : 0;
+ $file->{read} = -r _ ? 1 : 0;
+ $file->{write} = -w _ ? 1 : 0;
+ $file->{execute} = -x _ ? 1 : 0;
+ $file->{setuid} = -u _ ? 1 : 0;
+ $file->{setgid} = -g _ ? 1 : 0;
+ $file->{sticky} = -k _ ? 1 : 0;
+
+ $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0;
+ $meta->{is_dir} = $file->{is_dir} = -d _ ? 1 : 0;
+
+ # symlink check requires another system call
+ $meta->{is_symlink} = $file->{is_symlink}
+ = -l $source ? 1 : 0;
+ if ( $file->{is_symlink} ) {
+ $file->{lstat} = [ lstat(_) ];
+ }
+
+ # put together some common info about the file
+ ( $file->{basename}, $file->{dir}, $file->{ext} )
+ = map { defined $_ ? $_ : '' }
+ fileparse( $source, qr/\.[^.]*/ );
+ $file->{lc_ext} = lc( $file->{ext} );
+ $file->{basename} .= $file->{ext} if $file->{ext};
+
+ if ( $file->{text} and $file->{read} ) {
+ eval { $file->{shebang} = $self->_read_shebang($$raw); };
+ if ( my $e = $@ ) {
+ warn $e;
+ }
+ }
+ }
+ }
+ }
+ elsif ( $meta->{is_array} ) {
+ $meta->{size} = $#$raw + 1;
+ }
+ elsif ( $meta->{is_hash} ) {
+ ; # do nothing
+ }
+
+ return $meta;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my ( $self, $file ) = @_;
+ my $shebang;
+ local *TEST;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ chomp $shebang;
+ close(TEST) or die "Can't close $file. $!\n";
+ }
+ else {
+ die "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ $shebang_for{$file} = $class->_read_shebang($file)
+ unless exists $shebang_for{$file};
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<config_for>
+
+ my $config = $source->config_for( $class );
+
+Returns L</config> for the $class given. Class names may be fully qualified
+or abbreviated, eg:
+
+ # these are equivalent
+ $source->config_for( 'Perl' );
+ $source->config_for( 'TAP::Parser::SourceHandler::Perl' );
+
+If a fully qualified $class is given, its abbreviated version is checked first.
+
+=cut
+
+sub config_for {
+ my ( $self, $class ) = @_;
+ my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ );
+ my $config = $self->config->{$abbrv_class} || $self->config->{$class};
+ return $config;
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Steve Purkis.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Source/Perl.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Source/Perl.pm
new file mode 100755
index 00000000000..1f4f2e1428c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Source/Perl.pm
@@ -0,0 +1,326 @@
+package TAP::Parser::Source::Perl;
+
+use strict;
+use Config;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::Source;
+use TAP::Parser::Utils qw( split_shell );
+
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new;
+ my $stream = $perl->source( [ $filename, @args ] )->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a filename and hopefully returns a stream from it. The filename should
+be the name of a Perl program.
+
+Note that this is a subclass of L<TAP::Parser::Source>. See that module for
+more methods.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+Returns a new C<TAP::Parser::Source::Perl> object.
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+Getter/setter the name of the test program and any arguments it requires.
+
+ my ($filename, @args) = @{ $perl->source };
+ $perl->source( [ $filename, @args ] );
+
+C<croak>s if C<$filename> could not be found.
+
+=cut
+
+sub source {
+ my $self = shift;
+ $self->_croak("Cannot find ($_[0][0])")
+ if @_ && !-f $_[0][0];
+ return $self->SUPER::source(@_);
+}
+
+=head3 C<switches>
+
+ my $switches = $perl->switches;
+ my @switches = $perl->switches;
+ $perl->switches( \@switches );
+
+Getter/setter for the additional switches to pass to the perl executable. One
+common switch would be to set an include directory:
+
+ $perl->switches( ['-Ilib'] );
+
+=cut
+
+sub switches {
+ my $self = shift;
+ unless (@_) {
+ return wantarray ? @{ $self->{switches} } : $self->{switches};
+ }
+ my $switches = shift;
+ $self->{switches} = [@$switches]; # force a copy
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream($parser);
+
+Returns a stream of the output generated by executing C<source>. Must be
+passed an object that implements a C<make_iterator> method. Typically
+this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+
+ my @switches = $self->_switches;
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+
+ # Filter out any -I switches to be handled as libs later.
+ #
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ #
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ my @filtered_switches;
+ for (@switches) {
+ if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+ push @libs, $1;
+ }
+ else {
+ push @filtered_switches, $_;
+ }
+ }
+ @switches = @filtered_switches;
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB}
+ = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $previous = $ENV{PERL5LIB};
+ my $teardown = sub {
+ if ( defined $previous ) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ # Taint mode ignores environment variables so we must retranslate
+ # PERL5LIB as -I switches and place PERL5OPT on the command line
+ # in order that it be seen.
+ if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
+ push @switches, $self->_libs2switches(@libs);
+ push @switches, split_shell( $ENV{PERL5OPT} );
+ }
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my $self = shift;
+ my @switches = @_;
+ my ( $file, @args ) = @{ $self->source };
+ my $command = $self->_get_perl;
+
+# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
+#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file, @args );
+ return @command;
+}
+
+sub _get_command {
+ my $self = shift;
+ return $self->_get_command_for_switches( $self->_switches );
+}
+
+sub _libs2switches {
+ my $self = shift;
+ return map {"-I$_"} grep {$_} @_;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my $file = shift;
+ local *TEST;
+ my $shebang;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ close(TEST) or print "Can't close $file. $!\n";
+ }
+ else {
+ print "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ unless ( exists $shebang_for{$file} ) {
+ $shebang_for{$file} = _read_shebang($file);
+ }
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
+sub _switches {
+ my $self = shift;
+ my ( $file, @args ) = @{ $self->source };
+ my @switches = (
+ $self->switches,
+ );
+
+ my $shebang = $self->shebang($file);
+ return unless defined $shebang;
+
+ my $taint = $self->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
+
+ # Quote the argument if we're VMS, since VMS will downcase anything
+ # not quoted.
+ if (IS_VMS) {
+ for (@switches) {
+ $_ = qq["$_"];
+ }
+ }
+
+ return @switches;
+}
+
+sub _get_perl {
+ my $self = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyPerlSource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source::Perl;
+
+ @ISA = qw( TAP::Parser::Source::Perl );
+
+ sub source {
+ my ($self, $args) = @_;
+ if ($args) {
+ $self->{file} = $args->[0];
+ return $self->SUPER::source($args);
+ }
+ return $self->SUPER::source;
+ }
+
+ # use the version of perl from the shebang line in the test file
+ sub _get_perl {
+ my $self = shift;
+ if (my $shebang = $self->shebang( $self->{file} )) {
+ $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+ return $1 if $1;
+ }
+ return $self->SUPER::_get_perl(@_);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler.pm
new file mode 100755
index 00000000000..c7eb160f001
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler.pm
@@ -0,0 +1,194 @@
+package TAP::Parser::SourceHandler;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::Iterator ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler - Base class for different TAP source handlers
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ # abstract class - don't use directly!
+ # see TAP::Parser::IteratorFactory for general usage
+
+ # must be sub-classed for use
+ package MySourceHandler;
+ use base qw( TAP::Parser::SourceHandler );
+ sub can_handle { return $confidence_level }
+ sub make_iterator { return $iterator }
+
+ # see example below for more details
+
+=head1 DESCRIPTION
+
+This is an abstract base class for L<TAP::Parser::Source> handlers / handlers.
+
+A C<TAP::Parser::SourceHandler> does whatever is necessary to produce & capture
+a stream of TAP from the I<raw> source, and package it up in a
+L<TAP::Parser::Iterator> for the parser to consume.
+
+C<SourceHandlers> must implement the I<source detection & handling> interface
+used by L<TAP::Parser::IteratorFactory>. At 2 methods, the interface is pretty
+simple: L</can_handle> and L</make_source>.
+
+Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin, or
+subclassing L<TAP::Parser>, you probably won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+I<Abstract method>.
+
+ my $vote = $class->can_handle( $source );
+
+C<$source> is a L<TAP::Parser::Source>.
+
+Returns a number between C<0> & C<1> reflecting how confidently the raw source
+can be handled. For example, C<0> means the source cannot handle it, C<0.5>
+means it may be able to, and C<1> means it definitely can. See
+L<TAP::Parser::IteratorFactory/detect_source> for details on how this is used.
+
+=cut
+
+sub can_handle {
+ my ( $class, $args ) = @_;
+ $class->_croak(
+ "Abstract method 'can_handle' not implemented for $class!");
+ return;
+}
+
+=head3 C<make_iterator>
+
+I<Abstract method>.
+
+ my $iterator = $class->make_iterator( $source );
+
+C<$source> is a L<TAP::Parser::Source>.
+
+Returns a new L<TAP::Parser::Iterator> object for use by the L<TAP::Parser>.
+C<croak>s on error.
+
+=cut
+
+sub make_iterator {
+ my ( $class, $args ) = @_;
+ $class->_croak(
+ "Abstract method 'make_iterator' not implemented for $class!");
+ return;
+}
+1;
+
+__END__
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview, and any
+of the subclasses that ship with this module as an example. What follows is
+a quick overview.
+
+Start by familiarizing yourself with L<TAP::Parser::Source> and
+L<TAP::Parser::IteratorFactory>. L<TAP::Parser::SourceHandler::RawTAP> is
+the easiest sub-class to use an an example.
+
+It's important to point out that if you want your subclass to be automatically
+used by L<TAP::Parser> you'll have to and make sure it gets loaded somehow.
+If you're using L<prove> you can write an L<App::Prove> plugin. If you're
+using L<TAP::Parser> or L<TAP::Harness> directly (eg. through a custom script,
+L<ExtUtils::MakeMaker>, or L<Module::Build>) you can use the C<config> option
+which will cause L<TAP::Parser::IteratorFactory/load_sources> to load your
+subclass).
+
+Don't forget to register your class with
+L<TAP::Parser::IteratorFactory/register_handler>.
+
+=head2 Example
+
+ package MySourceHandler;
+
+ use strict;
+ use vars '@ISA'; # compat with older perls
+
+ use MySourceHandler; # see TAP::Parser::SourceHandler
+ use TAP::Parser::IteratorFactory;
+
+ @ISA = qw( TAP::Parser::SourceHandler );
+
+ TAP::Parser::IteratorFactory->register_handler( __PACKAGE__ );
+
+ sub can_handle {
+ my ( $class, $src ) = @_;
+ my $meta = $src->meta;
+ my $config = $src->config_for( $class );
+
+ if ($config->{accept_all}) {
+ return 1.0;
+ } elsif (my $file = $meta->{file}) {
+ return 0.0 unless $file->{exists};
+ return 1.0 if $file->{lc_ext} eq '.tap';
+ return 0.9 if $file->{shebang} && $file->{shebang} =~ /^#!.+tap/;
+ return 0.5 if $file->{text};
+ return 0.1 if $file->{binary};
+ } elsif ($meta->{scalar}) {
+ return 0.8 if $$raw_source_ref =~ /\d\.\.\d/;
+ return 0.6 if $meta->{has_newlines};
+ } elsif ($meta->{array}) {
+ return 0.8 if $meta->{size} < 5;
+ return 0.6 if $raw_source_ref->[0] =~ /foo/;
+ return 0.5;
+ } elsif ($meta->{hash}) {
+ return 0.6 if $raw_source_ref->{foo};
+ return 0.2;
+ }
+
+ return 0;
+ }
+
+ sub make_iterator {
+ my ($class, $source) = @_;
+ # this is where you manipulate the source and
+ # capture the stream of TAP in an iterator
+ # either pick a TAP::Parser::Iterator::* or write your own...
+ my $iterator = TAP::Parser::Iterator::Array->new([ 'foo', 'bar' ]);
+ return $iterator;
+ }
+
+ 1;
+
+=head1 AUTHORS
+
+TAPx Developers.
+
+Source detection stuff added by Steve Purkis
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Executable.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Executable.pm
new file mode 100755
index 00000000000..5337abac543
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Executable.pm
@@ -0,0 +1,185 @@
+package TAP::Parser::SourceHandler::Executable;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::SourceHandler ();
+use TAP::Parser::IteratorFactory ();
+use TAP::Parser::Iterator::Process ();
+
+@ISA = qw(TAP::Parser::SourceHandler);
+
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP source
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ use TAP::Parser::SourceHandler::Executable;
+
+ my $source = TAP::Parser::Source->new->raw(['/usr/bin/ruby', 'mytest.rb']);
+ $source->assemble_meta;
+
+ my $class = 'TAP::Parser::SourceHandler::Executable';
+ my $vote = $class->can_handle( $source );
+ my $iter = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is an I<executable> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is an executable command
+(L</can_handle>).
+
+2. Creates an iterator for executable commands (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+ my $vote = $class->can_handle( $source );
+
+Only votes if $source looks like an executable file. Casts the following votes:
+
+ 0.9 if it's a hash with an 'exec' key
+ 0.8 if it's a .sh file
+ 0.8 if it's a .bat file
+ 0.75 if it's got an execute bit set
+
+=cut
+
+sub can_handle {
+ my ( $class, $src ) = @_;
+ my $meta = $src->meta;
+
+ if ( $meta->{is_file} ) {
+ my $file = $meta->{file};
+
+ # Note: we go in low so we can be out-voted
+ return 0.8 if $file->{lc_ext} eq '.sh';
+ return 0.8 if $file->{lc_ext} eq '.bat';
+ return 0.7 if $file->{execute};
+ }
+ elsif ( $meta->{is_hash} ) {
+ return 0.9 if $src->raw->{exec};
+ }
+
+ return 0;
+}
+
+=head3 C<make_iterator>
+
+ my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Process> for the source.
+C<$source-E<gt>raw> must be in one of the following forms:
+
+ { exec => [ @exec ] }
+
+ [ @exec ]
+
+ $file
+
+C<croak>s on error.
+
+=cut
+
+sub make_iterator {
+ my ( $class, $source ) = @_;
+ my $meta = $source->meta;
+
+ my @command;
+ if ( $meta->{is_hash} ) {
+ @command = @{ $source->raw->{exec} || [] };
+ }
+ elsif ( $meta->{is_scalar} ) {
+ @command = ${ $source->raw };
+ }
+ elsif ( $meta->{is_array} ) {
+ @command = @{ $source->raw };
+ }
+
+ $class->_croak('No command found in $source->raw!') unless @command;
+
+ $class->_autoflush( \*STDOUT );
+ $class->_autoflush( \*STDERR );
+
+ return $class->iterator_class->new(
+ { command => \@command,
+ merge => $source->merge
+ }
+ );
+}
+
+=head3 C<iterator_class>
+
+The class of iterator to use, override if you're sub-classing. Defaults
+to L<TAP::Parser::Iterator::Process>.
+
+=cut
+
+use constant iterator_class => 'TAP::Parser::Iterator::Process';
+
+# Turns on autoflush for the handle passed
+sub _autoflush {
+ my ( $class, $flushed ) = @_;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyRubySourceHandler;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::SourceHandler::Executable;
+
+ @ISA = qw( TAP::Parser::SourceHandler::Executable );
+
+ # expect $handler->(['mytest.rb', 'cmdline', 'args']);
+ sub make_iterator {
+ my ($self, $source) = @_;
+ my @test_args = @{ $source->test_args };
+ my $rb_file = $test_args[0];
+ croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+ return $self->SUPER::raw_source(['/usr/bin/ruby', @test_args]);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/File.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/File.pm
new file mode 100755
index 00000000000..d44ace11483
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/File.pm
@@ -0,0 +1,136 @@
+package TAP::Parser::SourceHandler::File;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::SourceHandler ();
+use TAP::Parser::IteratorFactory ();
+use TAP::Parser::Iterator::Stream ();
+
+@ISA = qw(TAP::Parser::SourceHandler);
+
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::File - Stream TAP from a text file.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ use TAP::Parser::SourceHandler::File;
+
+ my $source = TAP::Parser::Source->new->raw( \'file.tap' );
+ $source->assemble_meta;
+
+ my $class = 'TAP::Parser::SourceHandler::File';
+ my $vote = $class->can_handle( $source );
+ my $iter = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<raw TAP stored in a file> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the I<raw> source it's given is a file containing raw TAP
+output. See L<TAP::Parser::IteratorFactory> for more details.
+
+2. Takes raw TAP from the text file given, and converts into an iterator.
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+ my $vote = $class->can_handle( $source );
+
+Only votes if $source looks like a regular file. Casts the following votes:
+
+ 0.9 if it's a .tap file
+ 0.9 if it has an extension matching any given in user config.
+
+=cut
+
+sub can_handle {
+ my ( $class, $src ) = @_;
+ my $meta = $src->meta;
+ my $config = $src->config_for($class);
+
+ return 0 unless $meta->{is_file};
+ my $file = $meta->{file};
+ return 0.9 if $file->{lc_ext} eq '.tap';
+
+ if ( my $exts = $config->{extensions} ) {
+ return 0.9 if grep { lc($_) eq $file->{lc_ext} } @$exts;
+ }
+
+ return 0;
+}
+
+=head3 C<make_iterator>
+
+ my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Stream> for the source. C<croak>s
+on error.
+
+=cut
+
+sub make_iterator {
+ my ( $class, $source ) = @_;
+
+ $class->_croak('$source->raw must be a scalar ref')
+ unless $source->meta->{is_scalar};
+
+ my $file = ${ $source->raw };
+ my $fh;
+ open( $fh, '<', $file )
+ or $class->_croak("error opening TAP source file '$file': $!");
+ return $class->iterator_class->new($fh);
+}
+
+=head3 C<iterator_class>
+
+The class of iterator to use, override if you're sub-classing. Defaults
+to L<TAP::Parser::Iterator::Stream>.
+
+=cut
+
+use constant iterator_class => 'TAP::Parser::Iterator::Stream';
+
+1;
+
+__END__
+
+=head1 CONFIGURATION
+
+ {
+ extensions => [ @case_insensitive_exts_to_match ]
+ }
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Handle.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Handle.pm
new file mode 100755
index 00000000000..30594fa1e75
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Handle.pm
@@ -0,0 +1,125 @@
+package TAP::Parser::SourceHandler::Handle;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::SourceHandler ();
+use TAP::Parser::IteratorFactory ();
+use TAP::Parser::Iterator::Stream ();
+
+@ISA = qw(TAP::Parser::SourceHandler);
+
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ use TAP::Parser::SourceHandler::Executable;
+
+ my $source = TAP::Parser::Source->new->raw( \*TAP_FILE );
+ $source->assemble_meta;
+
+ my $class = 'TAP::Parser::SourceHandler::Handle';
+ my $vote = $class->can_handle( $source );
+ my $iter = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<raw TAP stored in an IO Handle> L<TAP::Parser::SourceHandler> class. It
+has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is an L<IO::Handle> or
+GLOB containing raw TAP output (L</can_handle>).
+
+2. Creates an iterator for IO::Handle's & globs (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+ my $vote = $class->can_handle( $source );
+
+Casts the following votes:
+
+ 0.9 if $source is an IO::Handle
+ 0.8 if $source is a glob
+
+=cut
+
+sub can_handle {
+ my ( $class, $src ) = @_;
+ my $meta = $src->meta;
+
+ return 0.9
+ if $meta->{is_object}
+ && UNIVERSAL::isa( $src->raw, 'IO::Handle' );
+
+ return 0.8 if $meta->{is_glob};
+
+ return 0;
+}
+
+=head3 C<make_iterator>
+
+ my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Stream> for the source.
+
+=cut
+
+sub make_iterator {
+ my ( $class, $source ) = @_;
+
+ $class->_croak('$source->raw must be a glob ref or an IO::Handle')
+ unless $source->meta->{is_glob}
+ || UNIVERSAL::isa( $source->raw, 'IO::Handle' );
+
+ return $class->iterator_class->new( $source->raw );
+}
+
+=head3 C<iterator_class>
+
+The class of iterator to use, override if you're sub-classing. Defaults
+to L<TAP::Parser::Iterator::Stream>.
+
+=cut
+
+use constant iterator_class => 'TAP::Parser::Iterator::Stream';
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Perl.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Perl.pm
new file mode 100755
index 00000000000..f6513fd3156
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/Perl.pm
@@ -0,0 +1,310 @@
+package TAP::Parser::SourceHandler::Perl;
+
+use strict;
+use Config;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::SourceHandler::Executable ();
+use TAP::Parser::IteratorFactory ();
+use TAP::Parser::Iterator::Process ();
+use TAP::Parser::Utils qw( split_shell );
+
+@ISA = 'TAP::Parser::SourceHandler::Executable';
+
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ use TAP::Parser::SourceHandler::Perl;
+
+ my $source = TAP::Parser::Source->new->raw( \'script.pl' );
+ $source->assemble_meta;
+
+ my $class = 'TAP::Parser::SourceHandler::Perl';
+ my $vote = $class->can_handle( $source );
+ my $iter = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<Perl> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is actually a Perl
+script (L</can_handle>).
+
+2. Creates an iterator for Perl sources (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+ my $vote = $class->can_handle( $source );
+
+Only votes if $source looks like a file. Casts the following votes:
+
+ 0.9 if it has a shebang ala "#!...perl"
+ 0.8 if it's a .t file
+ 0.9 if it's a .pl file
+ 0.75 if it's in a 't' directory
+ 0.25 by default (backwards compat)
+
+=cut
+
+sub can_handle {
+ my ( $class, $source ) = @_;
+ my $meta = $source->meta;
+
+ return 0 unless $meta->{is_file};
+ my $file = $meta->{file};
+
+ if ( my $shebang = $file->{shebang} ) {
+ return 0.9 if $shebang =~ /^#!.*\bperl/;
+ }
+
+ return 0.8 if $file->{lc_ext} eq '.t'; # vote higher than Executable
+ return 0.9 if $file->{lc_ext} eq '.pl';
+
+ return 0.75 if $file->{dir} =~ /^t\b/; # vote higher than Executable
+
+ # backwards compat, always vote:
+ return 0.25;
+}
+
+=head3 C<make_iterator>
+
+ my $iterator = $class->make_iterator( $source );
+
+Constructs & returns a new L<TAP::Parser::Iterator::Process> for the source.
+Assumes C<$source-E<gt>raw> contains a reference to the perl script. C<croak>s
+if the file could not be found.
+
+The command to run is built as follows:
+
+ $perl @switches $perl_script @test_args
+
+The perl command to use is determined by L</get_perl>. The command generated
+is guaranteed to preserve:
+
+ PERL5LIB
+ PERL5OPT
+ Taint Mode, if set in the script's shebang
+
+I<Note:> the command generated will I<not> respect any shebang line defined in
+your Perl script. This is only a problem if you have compiled a custom version
+of Perl or if you want to use a specific version of Perl for one test and a
+different version for another, for example:
+
+ #!/path/to/a/custom_perl --some --args
+ #!/usr/local/perl-5.6/bin/perl -w
+
+Currently you need to write a plugin to get around this.
+
+=cut
+
+sub make_iterator {
+ my ( $class, $source ) = @_;
+ my $meta = $source->meta;
+ my $perl_script = ${ $source->raw };
+
+ $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file};
+
+ # TODO: does this really need to be done here?
+ $class->_autoflush( \*STDOUT );
+ $class->_autoflush( \*STDERR );
+
+ my @switches = $class->_switches($source);
+ my $path_sep = $Config{path_sep};
+ my $path_re = qr{$path_sep};
+
+ # Filter out any -I switches to be handled as libs later.
+ #
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ #
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ my @filtered_switches;
+ for (@switches) {
+ if ( !/$path_re/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+ push @libs, $1;
+ }
+ else {
+ push @filtered_switches, $_;
+ }
+ }
+ @switches = @filtered_switches;
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB}
+ = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $previous = $ENV{PERL5LIB};
+ my $teardown = sub {
+ if ( defined $previous ) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ # Taint mode ignores environment variables so we must retranslate
+ # PERL5LIB as -I switches and place PERL5OPT on the command line
+ # in order that it be seen.
+ if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
+ push @switches, $class->_libs2switches(@libs);
+ push @switches, split_shell( $ENV{PERL5OPT} );
+ }
+
+ my @command = $class->_get_command_for_switches( $source, @switches )
+ or $class->_croak("No command found!");
+
+ return TAP::Parser::Iterator::Process->new(
+ { command => \@command,
+ merge => $source->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my ( $class, $source, @switches ) = @_;
+ my $file = ${ $source->raw };
+ my @args = @{ $source->test_args || [] };
+ my $command = $class->get_perl;
+
+ # XXX don't need to quote if we treat the parts as atoms (except maybe vms)
+ #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file, @args );
+ return @command;
+}
+
+sub _libs2switches {
+ my $class = shift;
+ return map {"-I$_"} grep {$_} @_;
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
+sub _switches {
+ my ( $class, $source ) = @_;
+ my $file = ${ $source->raw };
+ my @args = @{ $source->test_args || [] };
+ my @switches = @{ $source->switches || [] };
+ my $shebang = $source->meta->{file}->{shebang};
+ return unless defined $shebang;
+
+ my $taint = $class->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
+
+ # Quote the argument if we're VMS, since VMS will downcase anything
+ # not quoted.
+ if (IS_VMS) {
+ for (@switches) {
+ $_ = qq["$_"];
+ }
+ }
+
+ return @switches;
+}
+
+=head3 C<get_perl>
+
+Gets the version of Perl currently running the test suite.
+
+=cut
+
+sub get_perl {
+ my $class = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
+
+__END__
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyPerlSourceHandler;
+
+ use strict;
+ use vars '@ISA';
+
+ use TAP::Parser::SourceHandler::Perl;
+
+ @ISA = qw( TAP::Parser::SourceHandler::Perl );
+
+ # use the version of perl from the shebang line in the test file
+ sub get_perl {
+ my $self = shift;
+ if (my $shebang = $self->shebang( $self->{file} )) {
+ $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+ return $1 if $1;
+ }
+ return $self->SUPER::get_perl(@_);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/RawTAP.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/RawTAP.pm
new file mode 100755
index 00000000000..c7048be98de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/RawTAP.pm
@@ -0,0 +1,131 @@
+package TAP::Parser::SourceHandler::RawTAP;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::SourceHandler ();
+use TAP::Parser::IteratorFactory ();
+use TAP::Parser::Iterator::Array ();
+
+@ISA = qw(TAP::Parser::SourceHandler);
+
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/array ref.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ use TAP::Parser::SourceHandler::RawTAP;
+
+ my $source = TAP::Parser::Source->new->raw( \"1..1\nok 1\n" );
+ $source->assemble_meta;
+
+ my $class = 'TAP::Parser::SourceHandler::RawTAP';
+ my $vote = $class->can_handle( $source );
+ my $iter = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<raw TAP output> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is raw TAP output
+(L</can_handle>).
+
+2. Creates an iterator for raw TAP output (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+ my $vote = $class->can_handle( $source );
+
+Only votes if $source is an array, or a scalar with newlines. Casts the
+following votes:
+
+ 0.9 if it's a scalar with '..' in it
+ 0.7 if it's a scalar with 'ok' in it
+ 0.3 if it's just a scalar with newlines
+ 0.5 if it's an array
+
+=cut
+
+sub can_handle {
+ my ( $class, $src ) = @_;
+ my $meta = $src->meta;
+
+ return 0 if $meta->{file};
+ if ( $meta->{is_scalar} ) {
+ return 0 unless $meta->{has_newlines};
+ return 0.9 if ${ $src->raw } =~ /\d\.\.\d/;
+ return 0.7 if ${ $src->raw } =~ /ok/;
+ return 0.3;
+ }
+ elsif ( $meta->{is_array} ) {
+ return 0.5;
+ }
+ return 0;
+}
+
+=head3 C<make_iterator>
+
+ my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Array> for the source.
+C<$source-E<gt>raw> must be an array ref, or a scalar ref.
+
+C<croak>s on error.
+
+=cut
+
+sub make_iterator {
+ my ( $class, $src ) = @_;
+ my $meta = $src->meta;
+
+ my $tap_array;
+ if ( $meta->{is_scalar} ) {
+ $tap_array = [ split "\n" => ${ $src->raw } ];
+ }
+ elsif ( $meta->{is_array} ) {
+ $tap_array = $src->raw;
+ }
+
+ $class->_croak('No raw TAP found in $source->raw')
+ unless scalar $tap_array;
+
+ return TAP::Parser::Iterator::Array->new($tap_array);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/pgTAP.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/pgTAP.pm
new file mode 100755
index 00000000000..aeaf5365ff5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/SourceHandler/pgTAP.pm
@@ -0,0 +1,253 @@
+package TAP::Parser::SourceHandler::pgTAP;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::IteratorFactory ();
+use TAP::Parser::Iterator::Process ();
+
+@ISA = qw(TAP::Parser::SourceHandler);
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::pgTAP - Stream TAP from pgTAP test scripts
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+In F<Build.PL> for your application with pgTAP tests in F<t/*.pg>:
+
+ Module::Build->new(
+ module_name => 'MyApp',
+ test_file_exts => [qw(.t .pg)],
+ use_tap_harness => 1,
+ tap_harness_args => {
+ sources => {
+ Perl => undef,
+ pgTAP => {
+ dbname => 'try',
+ username => 'postgres',
+ suffix => '.pg',
+ },
+ }
+ },
+ build_requires => {
+ 'Module::Build' => '0.30',
+ 'TAP::Parser::SourceHandler::pgTAP' => '3.19',
+ },
+ )->create_build_script;
+
+If you're using L<C<prove>|prove>:
+
+ prove --source Perl \
+ --source pgTAP --pgtap-option dbname=try \
+ --pgtap-option username=postgres \
+ --pgtap-option suffix=.pg
+
+Direct use:
+
+ use TAP::Parser::Source;
+ use TAP::Parser::SourceHandler::pgTAP;
+
+ my $source = TAP::Parser::Source->new->raw(\'mytest.pg');
+ $source->config({ pgTAP => {
+ dbname => 'testing',
+ username => 'postgres',
+ suffix => '.pg',
+ });
+ $source->assemble_meta;
+
+ my $class = 'TAP::Parser::SourceHandler::pgTAP';
+ my $vote = $class->can_handle( $source );
+ my $iter = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This source handler executes pgTAP tests. It does two things:
+
+=over
+
+=item 1.
+
+Looks at the L<TAP::Parser::Source> passed to it to determine whether or not
+the source in question is in fact a pgTAP test (L</can_handle>).
+
+=item 2.
+
+Creates an iterator that will call C<psql> to run the pgTAP tests
+(L</make_iterator>).
+
+=back
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+ my $vote = $class->can_handle( $source );
+
+Looks at the source to determine whether or not it's a pgTAP test file and
+returns a score for how likely it is in fact a pgTAP test file. The scores are
+as follows:
+
+ 1 if it has a suffix equal to that in the "suffix" config
+ 1 if its suffix is ".pg"
+ 0.8 if its suffix is ".sql"
+ 0.75 if its suffix is ".s"
+
+The latter two scores are subject to change, so try to name your pgTAP tests
+ending in ".pg" or specify a suffix in the configuration to be sure.
+
+=cut
+
+sub can_handle {
+ my ( $class, $source ) = @_;
+ my $meta = $source->meta;
+
+ return 0 unless $meta->{is_file};
+
+ my $suf = $meta->{file}{lc_ext};
+
+ # If the config specifies a suffix, it's required.
+ if ( my $config = $source->config_for('pgTAP') ) {
+ if ( defined $config->{suffix} ) {
+ return $suf eq $config->{suffix} ? 1 : 0;
+ }
+ }
+
+ # Otherwise, return a score for our supported suffixes.
+ my %score_for = (
+ '.pg' => 0.9,
+ '.sql' => 0.8,
+ '.s' => 0.75,
+ );
+ return $score_for{$suf} || 0;
+}
+
+=head3 C<make_iterator>
+
+ my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Process> for the source. C<<
+$source->raw >> must be either a file name or a scalar reference to the file
+name.
+
+The pgTAP tests are run by executing C<psql>, the PostgreSQL command-line
+utility. A number of arguments are passed to it, many of which you can effect
+by setting up the source source configuration. The configuration must be a
+hash reference, and supports the following keys:
+
+=over
+
+=item C<psql>
+
+The path to the C<psql> command. Defaults to simply "psql", which should work
+well enough if it's in your path.
+
+=item C<dbname>
+
+The database to which to connect to run the tests. Defaults to the value of
+the C<$PGDATABASE> environment variable or, if not set, to the system
+username.
+
+=item C<username>
+
+The PostgreSQL username to use to connect to PostgreSQL. If not specified, no
+username will be used, in which case C<psql> will fall back on either the
+C<$PGUSER> environment variable or, if not set, the system username.
+
+=item C<host>
+
+Specifies the host name of the machine to which to connect to the PostgreSQL
+server. If the value begins with a slash, it is used as the directory for the
+Unix-domain socket. Defaults to the value of the C<$PGDATABASE> environment
+variable or, if not set, the local host.
+
+=item C<port>
+
+Specifies the TCP port or the local Unix-domain socket file extension on which
+the server is listening for connections. Defaults to the value of the
+C<$PGPORT> environment variable or, if not set, to the port specified at the
+time C<psql> was compiled, usually 5432.
+
+=begin comment
+
+=item C<search_path>
+
+The schema search path to use during the execution of the tests. Useful for
+overriding the default search path and you have pgTAP installed in a schema
+not included in that search path.
+
+=end comment
+
+=back
+
+=cut
+
+sub make_iterator {
+ my ( $class, $source ) = @_;
+ my $config = $source->config_for('pgTAP');
+
+ my @command = ( $config->{psql} || 'psql' );
+ push @command, qw(
+ --no-psqlrc
+ --no-align
+ --quiet
+ --pset pager=
+ --pset tuples_only=true
+ --set ON_ERROR_ROLLBACK=1
+ --set ON_ERROR_STOP=1
+ );
+
+ for (qw(username host port dbname)) {
+ push @command, "--$_" => $config->{$_} if defined $config->{$_};
+ }
+
+ my $fn = ref $source->raw ? ${ $source->raw } : $source->raw;
+ $class->_croak(
+ 'No such file or directory: ' . ( defined $fn ? $fn : '' ) )
+ unless $fn && -e $fn;
+
+ push @command, '--file', $fn;
+
+ # XXX I'd like a way to be able to specify environment variables to set when
+ # the iterator executes the command...
+ # local $ENV{PGOPTIONS} = "--search_path=$config->{search_path}"
+ # if $config->{search_path};
+
+ return TAP::Parser::Iterator::Process->new(
+ { command => \@command,
+ merge => $source->merge
+ }
+ );
+}
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=head1 AUTHOR
+
+David E. Wheeler <dwheeler@cpan.org>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Utils.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Utils.pm
new file mode 100755
index 00000000000..21769b1a3f0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/Utils.pm
@@ -0,0 +1,72 @@
+package TAP::Parser::Utils;
+
+use strict;
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( split_shell );
+
+=head1 NAME
+
+TAP::Parser::Utils - Internal TAP::Parser utilities
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Utils qw( split_shell )
+ my @switches = split_shell( $arg );
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+=head2 INTERFACE
+
+=head3 C<split_shell>
+
+Shell style argument parsing. Handles backslash escaping, single and
+double quoted strings but not shell substitutions.
+
+Pass one or more strings containing shell escaped arguments. The return
+value is an array of arguments parsed from the input strings according
+to (approximate) shell parsing rules. It's legal to pass C<undef> in
+which case an empty array will be returned. That makes it possible to
+
+ my @args = split_shell( $ENV{SOME_ENV_VAR} );
+
+without worrying about whether the environment variable exists.
+
+This is used to split HARNESS_PERL_ARGS into individual switches.
+
+=cut
+
+sub split_shell {
+ my @parts = ();
+
+ for my $switch ( grep defined && length, @_ ) {
+ push @parts, $1 while $switch =~ /
+ (
+ (?: [^\\"'\s]+
+ | \\.
+ | " (?: \\. | [^"] )* "
+ | ' (?: \\. | [^'] )* '
+ )+
+ ) /xg;
+ }
+
+ for (@parts) {
+ s/ \\(.) | ['"] /defined $1 ? $1 : ''/exg;
+ }
+
+ return @parts;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Reader.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Reader.pm
new file mode 100755
index 00000000000..04ea4d10bd6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Reader.pm
@@ -0,0 +1,333 @@
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.20';
+
+# TODO:
+# Handle blessed object syntax
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
+my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
+my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
+my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
+my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
+
+# new() implementation supplied by TAP::Object
+
+sub read {
+ my $self = shift;
+ my $obj = shift;
+
+ die "Must have a code reference to read input from"
+ unless ref $obj eq 'CODE';
+
+ $self->{reader} = $obj;
+ $self->{capture} = [];
+
+ # Prime the reader
+ $self->_next;
+ return unless $self->{next};
+
+ my $doc = $self->_read;
+
+ # The terminator is mandatory otherwise we'd consume a line from the
+ # iterator that doesn't belong to us. If we want to remove this
+ # restriction we'll have to implement look-ahead in the iterators.
+ # Which might not be a bad idea.
+ my $dots = $self->_peek;
+ die "Missing '...' at end of YAMLish"
+ unless defined $dots
+ and $dots =~ $IS_END_YAML;
+
+ delete $self->{reader};
+ delete $self->{next};
+
+ return $doc;
+}
+
+sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
+
+sub _peek {
+ my $self = shift;
+ return $self->{next} unless wantarray;
+ my $line = $self->{next};
+ $line =~ /^ (\s*) (.*) $ /x;
+ return ( $2, length $1 );
+}
+
+sub _next {
+ my $self = shift;
+ die "_next called with no reader"
+ unless $self->{reader};
+ my $line = $self->{reader}->();
+ $self->{next} = $line;
+ push @{ $self->{capture} }, $line;
+}
+
+sub _read {
+ my $self = shift;
+
+ my $line = $self->_peek;
+
+ # Do we have a document header?
+ if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) {
+ $self->_next;
+
+ return $self->_read_scalar($1) if defined $1; # Inline?
+
+ my ( $next, $indent ) = $self->_peek;
+
+ if ( $next =~ /^ - /x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $next =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $next, $indent );
+ }
+ elsif ( $next =~ $IS_END_YAML ) {
+ die "Premature end of YAMLish";
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$next'";
+ }
+ }
+ else {
+ die "YAMLish document header not found";
+ }
+}
+
+# Parse a double quoted string
+sub _read_qq {
+ my $self = shift;
+ my $str = shift;
+
+ unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
+ die "Internal: not a quoted string";
+ }
+
+ $str =~ s/\\"/"/gx;
+ $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
+ / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
+ return $str;
+}
+
+# Parse a scalar string to the actual scalar
+sub _read_scalar {
+ my $self = shift;
+ my $string = shift;
+
+ return undef if $string eq '~';
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ if ( $string eq '>' || $string eq '|' ) {
+
+ my ( $line, $indent ) = $self->_peek;
+ die "Multi-line scalar content missing" unless defined $line;
+
+ my @multiline = ($line);
+
+ while (1) {
+ $self->_next;
+ my ( $next, $ind ) = $self->_peek;
+ last if $ind < $indent;
+
+ my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
+ push @multiline, $pad . $next;
+ }
+
+ return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
+ }
+
+ if ( $string =~ /^ ' (.*) ' $/x ) {
+ ( my $rv = $1 ) =~ s/''/'/g;
+ return $rv;
+ }
+
+ if ( $string =~ $IS_QQ_STRING ) {
+ return $self->_read_qq($string);
+ }
+
+ if ( $string =~ /^['"]/ ) {
+
+ # A quote with folding... we don't support that
+ die __PACKAGE__ . " does not support multi-line quoted scalars";
+ }
+
+ # Regular unquoted string
+ return $string;
+}
+
+sub _read_nested {
+ my $self = shift;
+
+ my ( $line, $indent ) = $self->_peek;
+
+ if ( $line =~ /^ -/x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $line, $indent );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+}
+
+# Parse an array
+sub _read_array {
+ my ( $self, $limit ) = @_;
+
+ my $ar = [];
+
+ while (1) {
+ my ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+
+ if ( $indent > $limit ) {
+ die "Array line over-indented";
+ }
+
+ if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
+ $indent += length $1;
+ $line =~ s/-\s+//;
+ push @$ar, $self->_read_hash( $line, $indent );
+ }
+ elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
+ die "Unexpected start of YAMLish" if $line =~ /^---/;
+ $self->_next;
+ push @$ar, $self->_read_scalar($1);
+ }
+ elsif ( $line =~ /^ - \s* $/x ) {
+ $self->_next;
+ push @$ar, $self->_read_nested;
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ $self->_next;
+ push @$ar, $self->_read_hash( $line, $indent, );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+ }
+
+ return $ar;
+}
+
+sub _read_hash {
+ my ( $self, $line, $limit ) = @_;
+
+ my $indent;
+ my $hash = {};
+
+ while (1) {
+ die "Badly formed hash line: '$line'"
+ unless $line =~ $HASH_LINE;
+
+ my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
+ $self->_next;
+
+ if ( defined $value ) {
+ $hash->{$key} = $self->_read_scalar($value);
+ }
+ else {
+ $hash->{$key} = $self->_read_nested;
+ }
+
+ ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+ }
+
+ return $hash;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
+
+=head1 VERSION
+
+Version 3.20
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Note that parts of this code were derived from L<YAML::Tiny> with the
+permission of Adam Kennedy.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Reader> object.
+
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+
+=head2 Instance Methods
+
+=head3 C<read>
+
+ my $got = $reader->read($iterator);
+
+Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
+represents.
+
+=head3 C<get_raw>
+
+ my $source = $reader->get_source;
+
+Return the raw YAMLish source from the most recent C<read>.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
+the YAML matching regular expressions for this module.
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+Portions copyright 2006-2008 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Writer.pm b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Writer.pm
new file mode 100755
index 00000000000..9dfbf74da09
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TAP/Parser/YAMLish/Writer.pm
@@ -0,0 +1,255 @@
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.20';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
+my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
+
+my @UNPRINTABLE = qw(
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1a e x1c x1d x1e x1f
+);
+
+# new() implementation supplied by TAP::Object
+
+sub write {
+ my $self = shift;
+
+ die "Need something to write"
+ unless @_;
+
+ my $obj = shift;
+ my $out = shift || \*STDOUT;
+
+ die "Need a reference to something I can write to"
+ unless ref $out;
+
+ $self->{writer} = $self->_make_writer($out);
+
+ $self->_write_obj( '---', $obj );
+ $self->_put('...');
+
+ delete $self->{writer};
+}
+
+sub _make_writer {
+ my $self = shift;
+ my $out = shift;
+
+ my $ref = ref $out;
+
+ if ( 'CODE' eq $ref ) {
+ return $out;
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ return sub { push @$out, shift };
+ }
+ elsif ( 'SCALAR' eq $ref ) {
+ return sub { $$out .= shift() . "\n" };
+ }
+ elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
+ return sub { print $out shift(), "\n" };
+ }
+
+ die "Can't write to $out";
+}
+
+sub _put {
+ my $self = shift;
+ $self->{writer}->( join '', @_ );
+}
+
+sub _enc_scalar {
+ my $self = shift;
+ my $val = shift;
+ my $rule = shift;
+
+ return '~' unless defined $val;
+
+ if ( $val =~ /$rule/ ) {
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/"/\\"/g;
+ $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
+ return qq{"$val"};
+ }
+
+ if ( length($val) == 0 or $val =~ /\s/ ) {
+ $val =~ s/'/''/;
+ return "'$val'";
+ }
+
+ return $val;
+}
+
+sub _write_obj {
+ my $self = shift;
+ my $prefix = shift;
+ my $obj = shift;
+ my $indent = shift || 0;
+
+ if ( my $ref = ref $obj ) {
+ my $pad = ' ' x $indent;
+ if ( 'HASH' eq $ref ) {
+ if ( keys %$obj ) {
+ $self->_put($prefix);
+ for my $key ( sort keys %$obj ) {
+ my $value = $obj->{$key};
+ $self->_write_obj(
+ $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
+ $value, $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' {}' );
+ }
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ if (@$obj) {
+ $self->_put($prefix);
+ for my $value (@$obj) {
+ $self->_write_obj(
+ $pad . '-', $value,
+ $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' []' );
+ }
+ }
+ else {
+ die "Don't know how to encode $ref";
+ }
+ }
+ else {
+ $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 3.20
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::YAMLish::Writer;
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+
+ # Write to an array...
+ $yw->write( $data, \@some_array );
+
+ # ...an open file handle...
+ $yw->write( $data, $some_file_handle );
+
+ # ...a string ...
+ $yw->write( $data, \$some_string );
+
+ # ...or a closure
+ $yw->write( $data, sub {
+ my $line = shift;
+ print "$line\n";
+ } );
+
+=head1 DESCRIPTION
+
+Encodes a scalar, hash reference or array reference as YAMLish.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Writer> object.
+
+=head2 Instance Methods
+
+=head3 C<write>
+
+ $writer->write($obj, $output );
+
+Encode a scalar, hash reference or array reference as YAML.
+
+ my $writer = sub {
+ my $line = shift;
+ print SOMEFILE "$line\n";
+ };
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+ $yw->write( $data, $writer );
+
+
+The C< $output > argument may be:
+
+=over
+
+=item * a reference to a scalar to append YAML to
+
+=item * the handle of an open file
+
+=item * a reference to an array into which YAML will be pushed
+
+=item * a code reference
+
+=back
+
+If you supply a code reference the subroutine will be called once for
+each line of output with the line as its only argument. Passed lines
+will have no trailing newline.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/TASKS.pod b/Master/tlpkg/tlperl.straw/lib/TASKS.pod
new file mode 100755
index 00000000000..8285a5f9b3e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/TASKS.pod
@@ -0,0 +1,55 @@
+=head1 NAME
+
+TASKS - Want to help? These things need doing...
+
+=head2 Increase test coverage
+
+More tests need to be added to test the codes that not urrently being tested.
+
+It's pretty poor right now:
+
+ http://pjcj.sytes.net/cover/latest/DBI-1.52/coverage.html
+
+Start with improving the subroutine coverage
+
+ http://pjcj.sytes.net/cover/latest/DBI-1.52/blib-lib-DBI-pm--subroutine.html
+
+=head2 Test the proxy
+
+The current t/80proxy.t is isolated from the rest of the test suite so actually
+tests very little, and what it does test is duplicating other tests.
+
+Ideally the proxy should be tested in the same way as DBI::PurePerl. In other
+words, by creating wrappers test files for each test file that set
+$ENV{DBI_AUTOPROXY} and run the original test. They'll also need to start and
+stop a proxy server.
+
+=head2 Fixing bugs
+
+The official bug list is here:
+
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBI
+
+Naturally I'll offer direction and guidance on any you want to tackle.
+I've also got a few that could be entered into rt.cpan.org.
+
+=head2 Others
+
+General:
+
+ Protect trace_msg from SIGPIPE?
+ prepare(...,{ Err=>\my $isolated_err, ...})
+ Add trace module that just records the last N trace messages into an array
+ and prepends them to any error message to provide context for the error.
+ Document DBI_PROFILE_FLOCK and LockFile attrib in DBI::ProfileData and DBI::ProfileDumper
+
+Performance:
+
+ Move _new_sth to DBI::db::_new_sth (leave alias) and implement in C
+ Or call _new_child and move to DBI::common?
+
+ Implement FETCH_many() in C
+
+ Add high-res dbi_time for windows - via Time::HiRes glob replace dbi_time()?
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/ANSIColor.pm b/Master/tlpkg/tlperl.straw/lib/Term/ANSIColor.pm
new file mode 100755
index 00000000000..72b941f6211
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/ANSIColor.pm
@@ -0,0 +1,725 @@
+# Term::ANSIColor -- Color screen output using ANSI escape sequences.
+#
+# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009, 2010
+# Russ Allbery <rra@stanford.edu> and Zenin
+# PUSH/POP support submitted 2007 by openmethods.com voice solutions
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# Ah, September, when the sysadmins turn colors and fall off the trees....
+# -- Dave Van Domelen
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Term::ANSIColor;
+require 5.001;
+
+$VERSION = '3.00';
+
+use strict;
+use vars qw($AUTOLOAD $AUTOLOCAL $AUTORESET @COLORLIST @COLORSTACK $EACHLINE
+ @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %ATTRIBUTES
+ %ATTRIBUTES_R);
+
+use Exporter ();
+BEGIN {
+ @COLORLIST = qw(
+ CLEAR RESET BOLD DARK
+ FAINT UNDERLINE UNDERSCORE BLINK
+ REVERSE CONCEALED
+
+ BLACK RED GREEN YELLOW
+ BLUE MAGENTA CYAN WHITE
+ ON_BLACK ON_RED ON_GREEN ON_YELLOW
+ ON_BLUE ON_MAGENTA ON_CYAN ON_WHITE
+
+ BRIGHT_BLACK BRIGHT_RED BRIGHT_GREEN BRIGHT_YELLOW
+ BRIGHT_BLUE BRIGHT_MAGENTA BRIGHT_CYAN BRIGHT_WHITE
+ ON_BRIGHT_BLACK ON_BRIGHT_RED ON_BRIGHT_GREEN ON_BRIGHT_YELLOW
+ ON_BRIGHT_BLUE ON_BRIGHT_MAGENTA ON_BRIGHT_CYAN ON_BRIGHT_WHITE
+ );
+ @ISA = qw(Exporter);
+ @EXPORT = qw(color colored);
+ @EXPORT_OK = qw(uncolor colorstrip colorvalid);
+ %EXPORT_TAGS = (constants => \@COLORLIST,
+ pushpop => [ @COLORLIST,
+ qw(PUSHCOLOR POPCOLOR LOCALCOLOR) ]);
+ Exporter::export_ok_tags ('pushpop');
+}
+
+##############################################################################
+# Internal data structures
+##############################################################################
+
+%ATTRIBUTES = ('clear' => 0,
+ 'reset' => 0,
+ 'bold' => 1,
+ 'dark' => 2,
+ 'faint' => 2,
+ 'underline' => 4,
+ 'underscore' => 4,
+ 'blink' => 5,
+ 'reverse' => 7,
+ 'concealed' => 8,
+
+ 'black' => 30, 'on_black' => 40,
+ 'red' => 31, 'on_red' => 41,
+ 'green' => 32, 'on_green' => 42,
+ 'yellow' => 33, 'on_yellow' => 43,
+ 'blue' => 34, 'on_blue' => 44,
+ 'magenta' => 35, 'on_magenta' => 45,
+ 'cyan' => 36, 'on_cyan' => 46,
+ 'white' => 37, 'on_white' => 47,
+
+ 'bright_black' => 90, 'on_bright_black' => 100,
+ 'bright_red' => 91, 'on_bright_red' => 101,
+ 'bright_green' => 92, 'on_bright_green' => 102,
+ 'bright_yellow' => 93, 'on_bright_yellow' => 103,
+ 'bright_blue' => 94, 'on_bright_blue' => 104,
+ 'bright_magenta' => 95, 'on_bright_magenta' => 105,
+ 'bright_cyan' => 96, 'on_bright_cyan' => 106,
+ 'bright_white' => 97, 'on_bright_white' => 107,
+ );
+
+# Reverse lookup. Alphabetically first name for a sequence is preferred.
+for (reverse sort keys %ATTRIBUTES) {
+ $ATTRIBUTES_R{$ATTRIBUTES{$_}} = $_;
+}
+
+##############################################################################
+# Implementation (constant form)
+##############################################################################
+
+# Time to have fun! We now want to define the constant subs, which are named
+# the same as the attributes above but in all caps. Each constant sub needs
+# to act differently depending on whether $AUTORESET is set. Without
+# autoreset:
+#
+# BLUE "text\n" ==> "\e[34mtext\n"
+#
+# If $AUTORESET is set, we should instead get:
+#
+# BLUE "text\n" ==> "\e[34mtext\n\e[0m"
+#
+# The sub also needs to handle the case where it has no arguments correctly.
+# Maintaining all of this as separate subs would be a major nightmare, as well
+# as duplicate the %ATTRIBUTES hash, so instead we define an AUTOLOAD sub to
+# define the constant subs on demand. To do that, we check the name of the
+# called sub against the list of attributes, and if it's an all-caps version
+# of one of them, we define the sub on the fly and then run it.
+#
+# If the environment variable ANSI_COLORS_DISABLED is set, just return the
+# arguments without adding any escape sequences. This is to make it easier to
+# write scripts that also work on systems without any ANSI support, like
+# Windows consoles.
+sub AUTOLOAD {
+ if (defined $ENV{ANSI_COLORS_DISABLED}) {
+ return join ('', @_);
+ }
+ if ($AUTOLOAD =~ /^([\w:]*::([A-Z_]+))$/ and defined $ATTRIBUTES{lc $2}) {
+ $AUTOLOAD = $1;
+ my $attr = "\e[" . $ATTRIBUTES{lc $2} . 'm';
+ eval qq {
+ sub $AUTOLOAD {
+ if (\$AUTORESET && \@_) {
+ return '$attr' . join ('', \@_) . "\e[0m";
+ } elsif (\$AUTOLOCAL && \@_) {
+ return PUSHCOLOR ('$attr') . join ('', \@_) . POPCOLOR;
+ } else {
+ return '$attr' . join ('', \@_);
+ }
+ }
+ };
+ goto &$AUTOLOAD;
+ } else {
+ require Carp;
+ Carp::croak ("undefined subroutine &$AUTOLOAD called");
+ }
+}
+
+# Append a new color to the top of the color stack and return the top of
+# the stack.
+sub PUSHCOLOR {
+ my ($text) = @_;
+ my ($color) = ($text =~ m/^((?:\e\[[\d;]+m)+)/);
+ if (@COLORSTACK) {
+ $color = $COLORSTACK[-1] . $color;
+ }
+ push (@COLORSTACK, $color);
+ return $text;
+}
+
+# Pop the color stack and return the new top of the stack (or reset, if
+# the stack is empty).
+sub POPCOLOR {
+ pop @COLORSTACK;
+ if (@COLORSTACK) {
+ return $COLORSTACK[-1] . join ('', @_);
+ } else {
+ return RESET (@_);
+ }
+}
+
+# Surround arguments with a push and a pop.
+sub LOCALCOLOR {
+ return PUSHCOLOR (join ('', @_)) . POPCOLOR ();
+}
+
+##############################################################################
+# Implementation (attribute string form)
+##############################################################################
+
+# Return the escape code for a given set of color attributes.
+sub color {
+ return '' if defined $ENV{ANSI_COLORS_DISABLED};
+ my @codes = map { split } @_;
+ my $attribute = '';
+ foreach (@codes) {
+ $_ = lc $_;
+ unless (defined $ATTRIBUTES{$_}) {
+ require Carp;
+ Carp::croak ("Invalid attribute name $_");
+ }
+ $attribute .= $ATTRIBUTES{$_} . ';';
+ }
+ chop $attribute;
+ return ($attribute ne '') ? "\e[${attribute}m" : undef;
+}
+
+# Return a list of named color attributes for a given set of escape codes.
+# Escape sequences can be given with or without enclosing "\e[" and "m". The
+# empty escape sequence '' or "\e[m" gives an empty list of attrs.
+sub uncolor {
+ my (@nums, @result);
+ for (@_) {
+ my $escape = $_;
+ $escape =~ s/^\e\[//;
+ $escape =~ s/m$//;
+ unless ($escape =~ /^((?:\d+;)*\d*)$/) {
+ require Carp;
+ Carp::croak ("Bad escape sequence $escape");
+ }
+ push (@nums, split (/;/, $1));
+ }
+ for (@nums) {
+ $_ += 0; # Strip leading zeroes
+ my $name = $ATTRIBUTES_R{$_};
+ if (!defined $name) {
+ require Carp;
+ Carp::croak ("No name for escape sequence $_" );
+ }
+ push (@result, $name);
+ }
+ return @result;
+}
+
+# Given a string and a set of attributes, returns the string surrounded by
+# escape codes to set those attributes and then clear them at the end of the
+# string. The attributes can be given either as an array ref as the first
+# argument or as a list as the second and subsequent arguments. If $EACHLINE
+# is set, insert a reset before each occurrence of the string $EACHLINE and
+# the starting attribute code after the string $EACHLINE, so that no attribute
+# crosses line delimiters (this is often desirable if the output is to be
+# piped to a pager or some other program).
+sub colored {
+ my ($string, @codes);
+ if (ref $_[0]) {
+ @codes = @{+shift};
+ $string = join ('', @_);
+ } else {
+ $string = shift;
+ @codes = @_;
+ }
+ return $string if defined $ENV{ANSI_COLORS_DISABLED};
+ if (defined $EACHLINE) {
+ my $attr = color (@codes);
+ return join '',
+ map { ($_ ne $EACHLINE) ? $attr . $_ . "\e[0m" : $_ }
+ grep { length ($_) > 0 }
+ split (/(\Q$EACHLINE\E)/, $string);
+ } else {
+ return color (@codes) . $string . "\e[0m";
+ }
+}
+
+# Given a string, strip the ANSI color codes out of that string and return the
+# result. This removes only ANSI color codes, not movement codes and other
+# escape sequences.
+sub colorstrip {
+ my (@string) = @_;
+ for my $string (@string) {
+ $string =~ s/\e\[[\d;]*m//g;
+ }
+ return wantarray ? @string : join ('', @string);
+}
+
+# Given a list of color attributes (arguments for color, for instance), return
+# true if they're all valid or false if any of them are invalid.
+sub colorvalid {
+ my @codes = map { split } @_;
+ for (@codes) {
+ unless (defined $ATTRIBUTES{lc $_}) {
+ return;
+ }
+ }
+ return 1;
+}
+
+##############################################################################
+# Module return value and documentation
+##############################################################################
+
+# Ensure we evaluate to true.
+1;
+__END__
+
+=head1 NAME
+
+Term::ANSIColor - Color screen output using ANSI escape sequences
+
+=for stopwords
+cyan colorize namespace runtime TMTOWTDI cmd.exe 4nt.exe command.com NT
+ESC Delvare SSH OpenSSH aixterm ECMA-048 Fraktur overlining Zenin
+reimplemented Allbery PUSHCOLOR POPCOLOR LOCALCOLOR openmethods.com
+grey ATTR
+
+=head1 SYNOPSIS
+
+ use Term::ANSIColor;
+ print color 'bold blue';
+ print "This text is bold blue.\n";
+ print color 'reset';
+ print "This text is normal.\n";
+ print colored ("Yellow on magenta.", 'yellow on_magenta'), "\n";
+ print "This text is normal.\n";
+ print colored ['yellow on_magenta'], 'Yellow on magenta.', "\n";
+ print colored ['red on_bright_yellow'] 'Red on bright yellow.', "\n";
+ print colored ['bright_red on_black], 'Bright red on black.', "\n";
+ print "\n";
+
+ use Term::ANSIColor qw(uncolor);
+ print uncolor ('01;31'), "\n";
+
+ use Term::ANSIColor qw(colorstrip);
+ print colorstrip '\e[1mThis is bold\e[0m', "\n";
+
+ use Term::ANSIColor qw(colorvalid);
+ my $valid = colorvalid ('blue bold', 'on_magenta');
+ print "Color string is ", $valid ? "valid\n" : "invalid\n";
+
+ use Term::ANSIColor qw(:constants);
+ print BOLD, BLUE, "This text is in bold blue.\n", RESET;
+
+ use Term::ANSIColor qw(:constants);
+ {
+ local $Term::ANSIColor::AUTORESET = 1;
+ print BOLD BLUE "This text is in bold blue.\n";
+ print "This text is normal.\n";
+ }
+
+ use Term::ANSIColor qw(:pushpop);
+ print PUSHCOLOR RED ON_GREEN "This text is red on green.\n";
+ print PUSHCOLOR BRIGHT_BLUE "This text is bright blue on green.\n";
+ print RESET BRIGHT_BLUE "This text is just bright blue.\n";
+ print POPCOLOR "Back to red on green.\n";
+ print LOCALCOLOR GREEN ON_BLUE "This text is green on blue.\n";
+ print "This text is red on green.\n";
+ {
+ local $Term::ANSIColor::AUTOLOCAL = 1;
+ print ON_BLUE "This text is red on blue.\n";
+ print "This text is red on green.\n";
+ }
+ print POPCOLOR "Back to whatever we started as.\n";
+
+=head1 DESCRIPTION
+
+This module has two interfaces, one through color() and colored() and the
+other through constants. It also offers the utility functions uncolor(),
+colorstrip(), and colorvalid(), which have to be explicitly imported to be
+used (see L</SYNOPSIS>).
+
+=head2 Supported Colors
+
+Terminal emulators that support color divide into two types: ones that
+support only eight colors, and ones that support sixteen. This module
+provides both the ANSI escape codes for the "normal" colors, supported by
+both types, as well as the additional colors supported by sixteen-color
+emulators. These colors are referred to as ANSI colors 0 through 7
+(normal) and 8 through 15.
+
+Unfortunately, interpretation of colors 0 through 7 often depends on
+whether the emulator supports eight colors or sixteen colors. Emulators
+that only support eight colors (such as the Linux console) will display
+colors 0 through 7 with normal brightness and ignore colors 8 through 15,
+treating them the same as white. Emulators that support 16 colors, such
+as gnome-terminal, normally display colors 0 through 7 as dim or darker
+versions and colors 8 through 15 as normal brightness. On such emulators,
+the "normal" white (color 7) usually is shown as pale grey, requiring
+bright white (15) to be used to get a real white color. Bright black
+usually is a dark grey color, although some terminals display it as pure
+black. Some sixteen-color terminal emulators also treat normal yellow
+(color 3) as orange or brown, and bright yellow (color 11) as yellow.
+
+Following the normal convention of sixteen-color emulators, this module
+provides a pair of attributes for each color. For every normal color (0
+through 7), the corresponding bright color (8 through 15) is obtained by
+prepending the string C<bright_> to the normal color name. For example,
+C<red> is color 1 and C<bright_red> is color 9. The same applies for
+background colors: C<on_red> is the normal color and C<on_bright_red> is
+the bright color. Capitalize these strings for the constant interface.
+
+There is unfortunately no way to know whether the current emulator
+supports sixteen colors or not, which makes the choice of colors
+difficult. The most conservative choice is to use only the regular
+colors, which are at least displayed on all emulators. However, they will
+appear dark in sixteen-color terminal emulators, including most common
+emulators in UNIX X environments. If you know the display is one of those
+emulators, you may wish to use the bright variants instead. Even better,
+offer the user a way to configure the colors for a given application to
+fit their terminal emulator.
+
+Support for colors 8 through 15 (the C<bright_> variants) was added in
+Term::ANSIColor 3.0.
+
+=head2 Function Interface
+
+The function interface uses attribute strings to describe the colors and
+text attributes to assign to text. The recognized non-color attributes
+are clear, reset, bold, dark, faint, underline, underscore, blink,
+reverse, and concealed. Clear and reset (reset to default attributes),
+dark and faint (dim and saturated), and underline and underscore are
+equivalent, so use whichever is the most intuitive to you.
+
+Note that not all attributes are supported by all terminal types, and some
+terminals may not support any of these sequences. Dark and faint, blink,
+and concealed in particular are frequently not implemented.
+
+The recognized normal foreground color attributes (colors 0 to 7) are:
+
+ black red green yellow blue magenta cyan white
+
+The corresponding bright foreground color attributes (colors 8 to 15) are:
+
+ bright_black bright_red bright_green bright_yellow
+ bright_blue bright_magenta bright_cyan bright_white
+
+The recognized normal background color attributes (colors 0 to 7) are:
+
+ on_black on_red on_green on yellow
+ on_blue on_magenta on_cyan on_white
+
+The recognized bright background color attributes (colors 8 to 15) are:
+
+ on_bright_black on_bright_red on_bright_green on_bright_yellow
+ on_bright_blue on_bright_magenta on_bright_cyan on_bright_white
+
+For any of the above listed attributes, case is not significant.
+
+Attributes, once set, last until they are unset (by printing the attribute
+C<clear> or C<reset>). Be careful to do this, or otherwise your attribute
+will last after your script is done running, and people get very annoyed
+at having their prompt and typing changed to weird colors.
+
+=over 4
+
+=item color(ATTR[, ATTR ...])
+
+color() takes any number of strings as arguments and considers them to be
+space-separated lists of attributes. It then forms and returns the escape
+sequence to set those attributes. It doesn't print it out, just returns
+it, so you'll have to print it yourself if you want to. This is so that
+you can save it as a string, pass it to something else, send it to a file
+handle, or do anything else with it that you might care to. color()
+throws an exception if given an invalid attribute.
+
+=item colored(STRING, ATTRIBUTES)
+
+=item colored(ATTR-REF, STRING[, STRING...])
+
+As an aid in resetting colors, colored() takes a scalar as the first
+argument and any number of attribute strings as the second argument and
+returns the scalar wrapped in escape codes so that the attributes will be
+set as requested before the string and reset to normal after the string.
+Alternately, you can pass a reference to an array as the first argument,
+and then the contents of that array will be taken as attributes and color
+codes and the remainder of the arguments as text to colorize.
+
+Normally, colored() just puts attribute codes at the beginning and end of
+the string, but if you set $Term::ANSIColor::EACHLINE to some string, that
+string will be considered the line delimiter and the attribute will be set
+at the beginning of each line of the passed string and reset at the end of
+each line. This is often desirable if the output contains newlines and
+you're using background colors, since a background color that persists
+across a newline is often interpreted by the terminal as providing the
+default background color for the next line. Programs like pagers can also
+be confused by attributes that span lines. Normally you'll want to set
+$Term::ANSIColor::EACHLINE to C<"\n"> to use this feature.
+
+=item uncolor(ESCAPE)
+
+uncolor() performs the opposite translation as color(), turning escape
+sequences into a list of strings corresponding to the attributes being set
+by those sequences.
+
+=item colorstrip(STRING[, STRING ...])
+
+colorstrip() removes all color escape sequences from the provided strings,
+returning the modified strings separately in array context or joined
+together in scalar context. Its arguments are not modified.
+
+=item colorvalid(ATTR[, ATTR ...])
+
+colorvalid() takes attribute strings the same as color() and returns true
+if all attributes are known and false otherwise.
+
+=back
+
+=head2 Constant Interface
+
+Alternately, if you import C<:constants>, you can use the following
+constants directly:
+
+ CLEAR RESET BOLD DARK
+ FAINT UNDERLINE UNDERSCORE BLINK
+ REVERSE CONCEALED
+
+ BLACK RED GREEN YELLOW
+ BLUE MAGENTA CYAN WHITE
+ BRIGHT_BLACK BRIGHT_RED BRIGHT_GREEN BRIGHT_YELLOW
+ BRIGHT_BLUE BRIGHT_MAGENTA BRIGHT_CYAN BRIGHT_WHITE
+
+ ON_BLACK ON_RED ON_GREEN ON_YELLOW
+ ON_BLUE ON_MAGENTA ON_CYAN ON_WHITE
+ ON_BRIGHT_BLACK ON_BRIGHT_RED ON_BRIGHT_GREEN ON_BRIGHT_YELLOW
+ ON_BRIGHT_BLUE ON_BRIGHT_MAGENTA ON_BRIGHT_CYAN ON_BRIGHT_WHITE
+
+These are the same as color('attribute') and can be used if you prefer
+typing:
+
+ print BOLD BLUE ON_WHITE "Text", RESET, "\n";
+
+to
+
+ print colored ("Text", 'bold blue on_white'), "\n";
+
+(Note that the newline is kept separate to avoid confusing the terminal as
+described above since a background color is being used.)
+
+When using the constants, if you don't want to have to remember to add the
+C<, RESET> at the end of each print line, you can set
+$Term::ANSIColor::AUTORESET to a true value. Then, the display mode will
+automatically be reset if there is no comma after the constant. In other
+words, with that variable set:
+
+ print BOLD BLUE "Text\n";
+
+will reset the display mode afterward, whereas:
+
+ print BOLD, BLUE, "Text\n";
+
+will not. If you are using background colors, you will probably want to
+print the newline with a separate print statement to avoid confusing the
+terminal.
+
+The subroutine interface has the advantage over the constants interface in
+that only two subroutines are exported into your namespace, versus
+thirty-eight in the constants interface. On the flip side, the constants
+interface has the advantage of better compile time error checking, since
+misspelled names of colors or attributes in calls to color() and colored()
+won't be caught until runtime whereas misspelled names of constants will
+be caught at compile time. So, pollute your namespace with almost two
+dozen subroutines that you may not even use that often, or risk a silly
+bug by mistyping an attribute. Your choice, TMTOWTDI after all.
+
+=head2 The Color Stack
+
+As of Term::ANSIColor 2.0, you can import C<:pushpop> and maintain a stack
+of colors using PUSHCOLOR, POPCOLOR, and LOCALCOLOR. PUSHCOLOR takes the
+attribute string that starts its argument and pushes it onto a stack of
+attributes. POPCOLOR removes the top of the stack and restores the
+previous attributes set by the argument of a prior PUSHCOLOR. LOCALCOLOR
+surrounds its argument in a PUSHCOLOR and POPCOLOR so that the color
+resets afterward.
+
+When using PUSHCOLOR, POPCOLOR, and LOCALCOLOR, it's particularly
+important to not put commas between the constants.
+
+ print PUSHCOLOR BLUE "Text\n";
+
+will correctly push BLUE onto the top of the stack.
+
+ print PUSHCOLOR, BLUE, "Text\n"; # wrong!
+
+will not, and a subsequent pop won't restore the correct attributes.
+PUSHCOLOR pushes the attributes set by its argument, which is normally a
+string of color constants. It can't ask the terminal what the current
+attributes are.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bad escape sequence %s
+
+(F) You passed an invalid ANSI escape sequence to uncolor().
+
+=item Bareword "%s" not allowed while "strict subs" in use
+
+(F) You probably mistyped a constant color name such as:
+
+ $Foobar = FOOBAR . "This line should be blue\n";
+
+or:
+
+ @Foobar = FOOBAR, "This line should be blue\n";
+
+This will only show up under use strict (another good reason to run under
+use strict).
+
+=item Invalid attribute name %s
+
+(F) You passed an invalid attribute name to either color() or colored().
+
+=item Name "%s" used only once: possible typo
+
+(W) You probably mistyped a constant color name such as:
+
+ print FOOBAR "This text is color FOOBAR\n";
+
+It's probably better to always use commas after constant names in order to
+force the next error.
+
+=item No comma allowed after filehandle
+
+(F) You probably mistyped a constant color name such as:
+
+ print FOOBAR, "This text is color FOOBAR\n";
+
+Generating this fatal compile error is one of the main advantages of using
+the constants interface, since you'll immediately know if you mistype a
+color name.
+
+=item No name for escape sequence %s
+
+(F) The ANSI escape sequence passed to uncolor() contains escapes which
+aren't recognized and can't be translated to names.
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item ANSI_COLORS_DISABLED
+
+If this environment variable is set, all of the functions defined by this
+module (color(), colored(), and all of the constants not previously used
+in the program) will not output any escape sequences and instead will just
+return the empty string or pass through the original text as appropriate.
+This is intended to support easy use of scripts using this module on
+platforms that don't support ANSI escape sequences.
+
+For it to have its proper effect, this environment variable must be set
+before any color constants are used in the program.
+
+=back
+
+=head1 RESTRICTIONS
+
+It would be nice if one could leave off the commas around the constants
+entirely and just say:
+
+ print BOLD BLUE ON_WHITE "Text\n" RESET;
+
+but the syntax of Perl doesn't allow this. You need a comma after the
+string. (Of course, you may consider it a bug that commas between all the
+constants aren't required, in which case you may feel free to insert
+commas unless you're using $Term::ANSIColor::AUTORESET or
+PUSHCOLOR/POPCOLOR.)
+
+For easier debugging, you may prefer to always use the commas when not
+setting $Term::ANSIColor::AUTORESET or PUSHCOLOR/POPCOLOR so that you'll
+get a fatal compile error rather than a warning.
+
+=head1 NOTES
+
+The codes generated by this module are standard terminal control codes,
+complying with ECMA-048 and ISO 6429 (generally referred to as "ANSI
+color" for the color codes). The non-color control codes (bold, dark,
+italic, underline, and reverse) are part of the earlier ANSI X3.64
+standard for control sequences for video terminals and peripherals.
+
+Note that not all displays are ISO 6429-compliant, or even X3.64-compliant
+(or are even attempting to be so). This module will not work as expected
+on displays that do not honor these escape sequences, such as cmd.exe,
+4nt.exe, and command.com under either Windows NT or Windows 2000. They
+may just be ignored, or they may display as an ESC character followed by
+some apparent garbage.
+
+Jean Delvare provided the following table of different common terminal
+emulators and their support for the various attributes and others have
+helped me flesh it out:
+
+ clear bold faint under blink reverse conceal
+ ------------------------------------------------------------------------
+ xterm yes yes no yes yes yes yes
+ linux yes yes yes bold yes yes no
+ rxvt yes yes no yes bold/black yes no
+ dtterm yes yes yes yes reverse yes yes
+ teraterm yes reverse no yes rev/red yes no
+ aixterm kinda normal no yes no yes yes
+ PuTTY yes color no yes no yes no
+ Windows yes no no no no yes no
+ Cygwin SSH yes yes no color color color yes
+ Mac Terminal yes yes no yes yes yes yes
+
+Windows is Windows telnet, Cygwin SSH is the OpenSSH implementation under
+Cygwin on Windows NT, and Mac Terminal is the Terminal application in Mac
+OS X. Where the entry is other than yes or no, that emulator displays the
+given attribute as something else instead. Note that on an aixterm, clear
+doesn't reset colors; you have to explicitly set the colors back to what
+you want. More entries in this table are welcome.
+
+Note that codes 3 (italic), 6 (rapid blink), and 9 (strike-through) are
+specified in ANSI X3.64 and ECMA-048 but are not commonly supported by
+most displays and emulators and therefore aren't supported by this module
+at the present time. ECMA-048 also specifies a large number of other
+attributes, including a sequence of attributes for font changes, Fraktur
+characters, double-underlining, framing, circling, and overlining. As
+none of these attributes are widely supported or useful, they also aren't
+currently supported by this module.
+
+=head1 SEE ALSO
+
+ECMA-048 is available on-line (at least at the time of this writing) at
+L<http://www.ecma-international.org/publications/standards/ECMA-048.HTM>.
+
+ISO 6429 is available from ISO for a charge; the author of this module
+does not own a copy of it. Since the source material for ISO 6429 was
+ECMA-048 and the latter is available for free, there seems little reason
+to obtain the ISO standard.
+
+The current version of this module is always available from its web site
+at L<http://www.eyrie.org/~eagle/software/ansicolor/>. It is also part of
+the Perl core distribution as of 5.6.0.
+
+=head1 AUTHORS
+
+Original idea (using constants) by Zenin, reimplemented using subs by Russ
+Allbery <rra@stanford.edu>, and then combined with the original idea by
+Russ with input from Zenin. Russ Allbery now maintains this module.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009, 2010
+Russ Allbery <rra@stanford.edu> and Zenin. This program is free software;
+you may redistribute it and/or modify it under the same terms as Perl
+itself.
+
+PUSHCOLOR, POPCOLOR, and LOCALCOLOR were contributed by openmethods.com
+voice solutions.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/Cap.pm b/Master/tlpkg/tlperl.straw/lib/Term/Cap.pm
new file mode 100755
index 00000000000..004a03c4124
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/Cap.pm
@@ -0,0 +1,799 @@
+package Term::Cap;
+
+# Since the debugger uses Term::ReadLine which uses Term::Cap, we want
+# to load as few modules as possible. This includes Carp.pm.
+sub carp
+{
+ require Carp;
+ goto &Carp::carp;
+}
+
+sub croak
+{
+ require Carp;
+ goto &Carp::croak;
+}
+
+use strict;
+
+use vars qw($VERSION $VMS_TERMCAP);
+use vars qw($termpat $state $first $entry);
+
+$VERSION = '1.12';
+
+# Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
+# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
+# [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
+# Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu
+# Avoid warnings in Tgetent and Tputs
+# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com
+# Altered layout of the POD
+# Added Test::More to PREREQ_PM in Makefile.PL
+# Fixed no argument Tgetent()
+# Version 1.03: Wed Nov 28 10:09:38 GMT 2001
+# VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
+# Version 1.04: Thu Nov 29 16:22:03 GMT 2001
+# Fixed warnings in test
+# Version 1.05: Mon Dec 3 15:33:49 GMT 2001
+# Don't try to fall back on infocmp if it's not there. From chromatic.
+# Version 1.06: Thu Dec 6 18:43:22 GMT 2001
+# Preload the default VMS termcap from Charles Lane
+# Don't carp at setting OSPEED unless warnings are on.
+# Version 1.07: Wed Jan 2 21:35:09 GMT 2002
+# Sanity check on infocmp output from Norton Allen
+# Repaired INSTALLDIRS thanks to Michael Schwern
+# Version 1.08: Sat Sep 28 11:33:15 BST 2002
+# Late loading of 'Carp' as per Michael Schwern
+# Version 1.09: Tue Apr 20 12:06:51 BST 2004
+# Merged in changes from and to Core
+# Core (Fri Aug 30 14:15:55 CEST 2002):
+# Cope with comments lines from 'infocmp' from Brendan O'Dea
+# Allow for EBCDIC in Tgoto magic test.
+# Version 1.10: Thu Oct 18 16:52:20 BST 2007
+# Don't use try to use $ENV{HOME} if it doesn't exist
+# Give Win32 'dumb' if TERM isn't set
+# Provide fallback 'dumb' termcap entry as last resort
+# Version 1.11: Thu Oct 25 09:33:07 BST 2007
+# EBDIC fixes from Chun Bing Ge <gecb@cn.ibm.com>
+# Version 1.12: Sat Dec 8 00:10:21 GMT 2007
+# QNX test fix from Matt Kraai <kraai@ftbfs.org>
+#
+# TODO:
+# support Berkeley DB termcaps
+# force $FH into callers package?
+# keep $FH in object at Tgetent time?
+
+=head1 NAME
+
+Term::Cap - Perl termcap interface
+
+=head1 SYNOPSIS
+
+ require Term::Cap;
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+ $terminal->Trequire(qw/ce ku kd/);
+ $terminal->Tgoto('cm', $col, $row, $FH);
+ $terminal->Tputs('dl', $count, $FH);
+ $terminal->Tpad($string, $count, $FH);
+
+=head1 DESCRIPTION
+
+These are low-level functions to extract and use capabilities from
+a terminal capability (termcap) database.
+
+More information on the terminal capabilities will be found in the
+termcap manpage on most Unix-like systems.
+
+=head2 METHODS
+
+=over 4
+
+The output strings for B<Tputs> are cached for counts of 1 for performance.
+B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
+data and C<$self-E<gt>{xx}> is the cached version.
+
+ print $terminal->Tpad($self->{_xx}, 1);
+
+B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
+output the string to $FH if specified.
+
+
+=cut
+
+# Preload the default VMS termcap.
+# If a different termcap is required then the text of one can be supplied
+# in $Term::Cap::VMS_TERMCAP before Tgetent is called.
+
+if ( $^O eq 'VMS' )
+{
+ chomp( my @entry = <DATA> );
+ $VMS_TERMCAP = join '', @entry;
+}
+
+# Returns a list of termcap files to check.
+
+sub termcap_path
+{ ## private
+ my @termcap_path;
+
+ # $TERMCAP, if it's a filespec
+ push( @termcap_path, $ENV{TERMCAP} )
+ if (
+ ( exists $ENV{TERMCAP} )
+ && (
+ ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' )
+ ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
+ : $ENV{TERMCAP} =~ /^\//s
+ )
+ );
+ if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) )
+ {
+
+ # Add the users $TERMPATH
+ push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) );
+ }
+ else
+ {
+
+ # Defaults
+ push( @termcap_path,
+ exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef,
+ '/etc/termcap', '/usr/share/misc/termcap', );
+ }
+
+ # return the list of those termcaps that exist
+ return grep { defined $_ && -f $_ } @termcap_path;
+}
+
+=item B<Tgetent>
+
+Returns a blessed object reference which the user can
+then use to send the control strings to the terminal using B<Tputs>
+and B<Tgoto>.
+
+The function extracts the entry of the specified terminal
+type I<TERM> (defaults to the environment variable I<TERM>) from the
+database.
+
+It will look in the environment for a I<TERMCAP> variable. If
+found, and the value does not begin with a slash, and the terminal
+type name is the same as the environment string I<TERM>, the
+I<TERMCAP> string is used instead of reading a termcap file. If
+it does begin with a slash, the string is used as a path name of
+the termcap file to search. If I<TERMCAP> does not begin with a
+slash and name is different from I<TERM>, B<Tgetent> searches the
+files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
+in that order, unless the environment variable I<TERMPATH> exists,
+in which case it specifies a list of file pathnames (separated by
+spaces or colons) to be searched B<instead>. Whenever multiple
+files are searched and a tc field occurs in the requested entry,
+the entry it names must be found in the same file or one of the
+succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
+environment variable string it will continue the search in the
+files as above.
+
+The extracted termcap entry is available in the object
+as C<$self-E<gt>{TERMCAP}>.
+
+It takes a hash reference as an argument with two optional keys:
+
+=over 2
+
+=item OSPEED
+
+The terminal output bit rate (often mistakenly called the baud rate)
+for this terminal - if not set a warning will be generated
+and it will be defaulted to 9600. I<OSPEED> can be be specified as
+either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
+an old DSD-style speed ( where 13 equals 9600).
+
+
+=item TERM
+
+The terminal type whose termcap entry will be used - if not supplied it will
+default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
+
+=back
+
+It calls C<croak> on failure.
+
+=cut
+
+sub Tgetent
+{ ## public -- static method
+ my $class = shift;
+ my ($self) = @_;
+
+ $self = {} unless defined $self;
+ bless $self, $class;
+
+ my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
+ local ( $termpat, $state, $first, $entry ); # used inside eval
+ local $_;
+
+ # Compute PADDING factor from OSPEED (to be used by Tpad)
+ if ( !$self->{OSPEED} )
+ {
+ if ($^W)
+ {
+ carp "OSPEED was not set, defaulting to 9600";
+ }
+ $self->{OSPEED} = 9600;
+ }
+ if ( $self->{OSPEED} < 16 )
+ {
+
+ # delays for old style speeds
+ my @pad = (
+ 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3,
+ 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2
+ );
+ $self->{PADDING} = $pad[ $self->{OSPEED} ];
+ }
+ else
+ {
+ $self->{PADDING} = 10000 / $self->{OSPEED};
+ }
+
+ unless ( $self->{TERM} )
+ {
+ if ( $ENV{TERM} )
+ {
+ $self->{TERM} = $ENV{TERM} ;
+ }
+ else
+ {
+ if ( $^O eq 'Win32' )
+ {
+ $self->{TERM} = 'dumb';
+ }
+ else
+ {
+ croak "TERM not set";
+ }
+ }
+ }
+
+ $term = $self->{TERM}; # $term is the term type we are looking for
+
+ # $tmp_term is always the next term (possibly :tc=...:) we are looking for
+ $tmp_term = $self->{TERM};
+
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term;
+ $termpat =~ s/(\W)/\\$1/g;
+
+ my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
+
+ # $entry is the extracted termcap entry
+ if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
+ {
+ $entry = $foo;
+ }
+
+ my @termcap_path = termcap_path();
+
+ unless ( @termcap_path || $entry )
+ {
+
+ # last resort--fake up a termcap from terminfo
+ local $ENV{TERM} = $term;
+
+ if ( $^O eq 'VMS' )
+ {
+ $entry = $VMS_TERMCAP;
+ }
+ else
+ {
+ if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
+ {
+ eval {
+ my $tmp = `infocmp -C 2>/dev/null`;
+ $tmp =~ s/^#.*\n//gm; # remove comments
+ if ( ( $tmp !~ m%^/%s )
+ && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
+ {
+ $entry = $tmp;
+ }
+ };
+ }
+ else
+ {
+ # this is getting desperate now
+ if ( $self->{TERM} eq 'dumb' )
+ {
+ $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
+ }
+ }
+ }
+ }
+
+ croak "Can't find a valid termcap file" unless @termcap_path || $entry;
+
+ $state = 1; # 0 == finished
+ # 1 == next file
+ # 2 == search again
+
+ $first = 0; # first entry (keeps term name)
+
+ $max = 32; # max :tc=...:'s
+
+ if ($entry)
+ {
+
+ # ok, we're starting with $TERMCAP
+ $first++; # we're the first entry
+ # do we need to continue?
+ if ( $entry =~ s/:tc=([^:]+):/:/ )
+ {
+ $tmp_term = $1;
+
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term;
+ $termpat =~ s/(\W)/\\$1/g;
+ }
+ else
+ {
+ $state = 0; # we're already finished
+ }
+ }
+
+ # This is eval'ed inside the while loop for each file
+ $search = q{
+ while (<TERMCAP>) {
+ next if /^\\t/ || /^#/;
+ if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
+ chomp;
+ s/^[^:]*:// if $first++;
+ $state = 0;
+ while ($_ =~ s/\\\\$//) {
+ defined(my $x = <TERMCAP>) or last;
+ $_ .= $x; chomp;
+ }
+ last;
+ }
+ }
+ defined $entry or $entry = '';
+ $entry .= $_ if $_;
+ };
+
+ while ( $state != 0 )
+ {
+ if ( $state == 1 )
+ {
+
+ # get the next TERMCAP
+ $TERMCAP = shift @termcap_path
+ || croak "failed termcap lookup on $tmp_term";
+ }
+ else
+ {
+
+ # do the same file again
+ # prevent endless recursion
+ $max-- || croak "failed termcap loop at $tmp_term";
+ $state = 1; # ok, maybe do a new file next time
+ }
+
+ open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
+ eval $search;
+ die $@ if $@;
+ close TERMCAP;
+
+ # If :tc=...: found then search this file again
+ $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
+
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term;
+ $termpat =~ s/(\W)/\\$1/g;
+ }
+
+ croak "Can't find $term" if $entry eq '';
+ $entry =~ s/:+\s*:+/:/g; # cleanup $entry
+ $entry =~ s/:+/:/g; # cleanup $entry
+ $self->{TERMCAP} = $entry; # save it
+ # print STDERR "DEBUG: $entry = ", $entry, "\n";
+
+ # Precompile $entry into the object
+ $entry =~ s/^[^:]*://;
+ foreach $field ( split( /:[\s:\\]*/, $entry ) )
+ {
+ if ( defined $field && $field =~ /^(\w\w)$/ )
+ {
+ $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
+
+ # print STDERR "DEBUG: flag $1\n";
+ }
+ elsif ( defined $field && $field =~ /^(\w\w)\@/ )
+ {
+ $self->{ '_' . $1 } = "";
+
+ # print STDERR "DEBUG: unset $1\n";
+ }
+ elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ )
+ {
+ $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
+
+ # print STDERR "DEBUG: numeric $1 = $2\n";
+ }
+ elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ )
+ {
+
+ # print STDERR "DEBUG: string $1 = $2\n";
+ next if defined $self->{ '_' . ( $cap = $1 ) };
+ $_ = $2;
+ if ( ord('A') == 193 )
+ {
+ s/\\E/\047/g;
+ s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\337/g;
+ s/\^\?/\007/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\337/^/g;
+ }
+ else
+ {
+ s/\\E/\033/g;
+ s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\377/g;
+ s/\^\?/\177/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\377/^/g;
+ }
+ $self->{ '_' . $cap } = $_;
+ }
+
+ # else { carp "junk in $term ignored: $field"; }
+ }
+ $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
+ $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
+ $self;
+}
+
+# $terminal->Tpad($string, $cnt, $FH);
+
+=item B<Tpad>
+
+Outputs a literal string with appropriate padding for the current terminal.
+
+It takes three arguments:
+
+=over 2
+
+=item B<$string>
+
+The literal string to be output. If it starts with a number and an optional
+'*' then the padding will be increased by an amount relative to this number,
+if the '*' is present then this amount will me multiplied by $cnt. This part
+of $string is removed before output/
+
+=item B<$cnt>
+
+Will be used to modify the padding applied to string as described above.
+
+=item B<$FH>
+
+An optional filehandle (or IO::Handle ) that output will be printed to.
+
+=back
+
+The padded $string is returned.
+
+=cut
+
+sub Tpad
+{ ## public
+ my $self = shift;
+ my ( $string, $cnt, $FH ) = @_;
+ my ( $decr, $ms );
+
+ if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ )
+ {
+ $ms = $1;
+ $ms *= $cnt if $2;
+ $string = $3;
+ $decr = $self->{PADDING};
+ if ( $decr > .1 )
+ {
+ $ms += $decr / 2;
+ $string .= $self->{'_pc'} x ( $ms / $decr );
+ }
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Tputs($cap, $cnt, $FH);
+
+=item B<Tputs>
+
+Output the string for the given capability padded as appropriate without
+any parameter substitution.
+
+It takes three arguments:
+
+=over 2
+
+=item B<$cap>
+
+The capability whose string is to be output.
+
+=item B<$cnt>
+
+A count passed to Tpad to modify the padding applied to the output string.
+If $cnt is zero or one then the resulting string will be cached.
+
+=item B<$FH>
+
+An optional filehandle (or IO::Handle ) that output will be printed to.
+
+=back
+
+The appropriate string for the capability will be returned.
+
+=cut
+
+sub Tputs
+{ ## public
+ my $self = shift;
+ my ( $cap, $cnt, $FH ) = @_;
+ my $string;
+
+ $cnt = 0 unless $cnt;
+
+ if ( $cnt > 1 )
+ {
+ $string = Tpad( $self, $self->{ '_' . $cap }, $cnt );
+ }
+ else
+ {
+
+ # cache result because Tpad can be slow
+ unless ( exists $self->{$cap} )
+ {
+ $self->{$cap} =
+ exists $self->{"_$cap"}
+ ? Tpad( $self, $self->{"_$cap"}, 1 )
+ : undef;
+ }
+ $string = $self->{$cap};
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Tgoto($cap, $col, $row, $FH);
+
+=item B<Tgoto>
+
+B<Tgoto> decodes a cursor addressing string with the given parameters.
+
+There are four arguments:
+
+=over 2
+
+=item B<$cap>
+
+The name of the capability to be output.
+
+=item B<$col>
+
+The first value to be substituted in the output string ( usually the column
+in a cursor addressing capability )
+
+=item B<$row>
+
+The second value to be substituted in the output string (usually the row
+in cursor addressing capabilities)
+
+=item B<$FH>
+
+An optional filehandle (or IO::Handle ) to which the output string will be
+printed.
+
+=back
+
+Substitutions are made with $col and $row in the output string with the
+following sprintf() line formats:
+
+ %% output `%'
+ %d output value as in printf %d
+ %2 output value as in printf %2d
+ %3 output value as in printf %3d
+ %. output value as in printf %c
+ %+x add x to value, then do %.
+
+ %>xy if value > x then add y, no output
+ %r reverse order of two parameters, no output
+ %i increment by one, no output
+ %B BCD (16*(value/10)) + (value%10), no output
+
+ %n exclusive-or all parameters with 0140 (Datamedia 2500)
+ %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
+
+The output string will be returned.
+
+=cut
+
+sub Tgoto
+{ ## public
+ my $self = shift;
+ my ( $cap, $code, $tmp, $FH ) = @_;
+ my $string = $self->{ '_' . $cap };
+ my $result = '';
+ my $after = '';
+ my $online = 0;
+ my @tmp = ( $tmp, $code );
+ my $cnt = $code;
+
+ while ( $string =~ /^([^%]*)%(.)(.*)/ )
+ {
+ $result .= $1;
+ $code = $2;
+ $string = $3;
+ if ( $code eq 'd' )
+ {
+ $result .= sprintf( "%d", shift(@tmp) );
+ }
+ elsif ( $code eq '.' )
+ {
+ $tmp = shift(@tmp);
+ if ( $tmp == 0 || $tmp == 4 || $tmp == 10 )
+ {
+ if ($online)
+ {
+ ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
+ }
+ else
+ {
+ ++$tmp, $after .= $self->{'_bc'};
+ }
+ }
+ $result .= sprintf( "%c", $tmp );
+ $online = !$online;
+ }
+ elsif ( $code eq '+' )
+ {
+ $result .= sprintf( "%c", shift(@tmp) + ord($string) );
+ $string = substr( $string, 1, 99 );
+ $online = !$online;
+ }
+ elsif ( $code eq 'r' )
+ {
+ ( $code, $tmp ) = @tmp;
+ @tmp = ( $tmp, $code );
+ $online = !$online;
+ }
+ elsif ( $code eq '>' )
+ {
+ ( $code, $tmp, $string ) = unpack( "CCa99", $string );
+ if ( $tmp[$[] > $code )
+ {
+ $tmp[$[] += $tmp;
+ }
+ }
+ elsif ( $code eq '2' )
+ {
+ $result .= sprintf( "%02d", shift(@tmp) );
+ $online = !$online;
+ }
+ elsif ( $code eq '3' )
+ {
+ $result .= sprintf( "%03d", shift(@tmp) );
+ $online = !$online;
+ }
+ elsif ( $code eq 'i' )
+ {
+ ( $code, $tmp ) = @tmp;
+ @tmp = ( $code + 1, $tmp + 1 );
+ }
+ else
+ {
+ return "OOPS";
+ }
+ }
+ $string = Tpad( $self, $result . $string . $after, $cnt );
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Trequire(qw/ce ku kd/);
+
+=item B<Trequire>
+
+Takes a list of capabilities as an argument and will croak if one is not
+found.
+
+=cut
+
+sub Trequire
+{ ## public
+ my $self = shift;
+ my ( $cap, @undefined );
+ foreach $cap (@_)
+ {
+ push( @undefined, $cap )
+ unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap };
+ }
+ croak "Terminal does not support: (@undefined)" if @undefined;
+}
+
+=back
+
+=head1 EXAMPLES
+
+ use Term::Cap;
+
+ # Get terminal output speed
+ require POSIX;
+ my $termios = new POSIX::Termios;
+ $termios->getattr;
+ my $ospeed = $termios->getospeed;
+
+ # Old-style ioctl code to get ospeed:
+ # require 'ioctl.pl';
+ # ioctl(TTY,$TIOCGETP,$sgtty);
+ # ($ispeed,$ospeed) = unpack('cc',$sgtty);
+
+ # allocate and initialize a terminal structure
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+
+ # require certain capabilities to be available
+ $terminal->Trequire(qw/ce ku kd/);
+
+ # Output Routines, if $FH is undefined these just return the string
+
+ # Tgoto does the % expansion stuff with the given args
+ $terminal->Tgoto('cm', $col, $row, $FH);
+
+ # Tputs doesn't do any % expansion.
+ $terminal->Tputs('dl', $count = 1, $FH);
+
+=head1 COPYRIGHT AND LICENSE
+
+Please see the README file in distribution.
+
+=head1 AUTHOR
+
+This module is part of the core Perl distribution and is also maintained
+for CPAN by Jonathan Stowe <jns@gellyfish.com>.
+
+=head1 SEE ALSO
+
+termcap(5)
+
+=cut
+
+# Below is a default entry for systems where there are terminals but no
+# termcap
+1;
+__DATA__
+vt220|vt200|DEC VT220 in vt100 emulation mode:
+am:mi:xn:xo:
+co#80:li#24:
+RA=\E[?7l:SA=\E[?7h:
+ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
+bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
+cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
+ei=\E[4l:ho=\E[H:im=\E[4h:
+is=\E[1;24r\E[24;1H:
+nd=\E[C:
+kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
+mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
+kb=\0177:
+r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
+sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
+ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l:
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/Complete.pm b/Master/tlpkg/tlperl.straw/lib/Term/Complete.pm
new file mode 100755
index 00000000000..601e4956430
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/Complete.pm
@@ -0,0 +1,188 @@
+package Term::Complete;
+require 5.000;
+require Exporter;
+
+use strict;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(Complete);
+our $VERSION = '1.402';
+
+# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91
+
+=head1 NAME
+
+Term::Complete - Perl word completion module
+
+=head1 SYNOPSIS
+
+ $input = Complete('prompt_string', \@completion_list);
+ $input = Complete('prompt_string', @completion_list);
+
+=head1 DESCRIPTION
+
+This routine provides word completion on the list of words in
+the array (or array ref).
+
+The tty driver is put into raw mode and restored using an operating
+system specific command, in UNIX-like environments C<stty>.
+
+The following command characters are defined:
+
+=over 4
+
+=item E<lt>tabE<gt>
+
+Attempts word completion.
+Cannot be changed.
+
+=item ^D
+
+Prints completion list.
+Defined by I<$Term::Complete::complete>.
+
+=item ^U
+
+Erases the current input.
+Defined by I<$Term::Complete::kill>.
+
+=item E<lt>delE<gt>, E<lt>bsE<gt>
+
+Erases one character.
+Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
+
+=back
+
+=head1 DIAGNOSTICS
+
+Bell sounds when word completion fails.
+
+=head1 BUGS
+
+The completion character E<lt>tabE<gt> cannot be changed.
+
+=head1 AUTHOR
+
+Wayne Thompson
+
+=cut
+
+our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore);
+our($tty_saved_state) = '';
+CONFIG: {
+ $complete = "\004";
+ $kill = "\025";
+ $erase1 = "\177";
+ $erase2 = "\010";
+ foreach my $s (qw(/bin/stty /usr/bin/stty)) {
+ if (-x $s) {
+ $tty_raw_noecho = "$s raw -echo";
+ $tty_restore = "$s -raw echo";
+ $tty_safe_restore = $tty_restore;
+ $stty = $s;
+ last;
+ }
+ }
+}
+
+sub Complete {
+ my($prompt, @cmp_lst, $cmp, $test, $l, @match);
+ my ($return, $r) = ("", 0);
+
+ $return = "";
+ $r = 0;
+
+ $prompt = shift;
+ if (ref $_[0] || $_[0] =~ /^\*/) {
+ @cmp_lst = sort @{$_[0]};
+ }
+ else {
+ @cmp_lst = sort(@_);
+ }
+
+ # Attempt to save the current stty state, to be restored later
+ if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') {
+ $tty_saved_state = qx($stty -g 2>/dev/null);
+ if ($?) {
+ # stty -g not supported
+ $tty_saved_state = undef;
+ }
+ else {
+ $tty_saved_state =~ s/\s+$//g;
+ $tty_restore = qq($stty "$tty_saved_state" 2>/dev/null);
+ }
+ }
+ system $tty_raw_noecho if defined $tty_raw_noecho;
+ LOOP: {
+ local $_;
+ print($prompt, $return);
+ while (($_ = getc(STDIN)) ne "\r") {
+ CASE: {
+ # (TAB) attempt completion
+ $_ eq "\t" && do {
+ @match = grep(/^\Q$return/, @cmp_lst);
+ unless ($#match < 0) {
+ $l = length($test = shift(@match));
+ foreach $cmp (@match) {
+ until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
+ $l--;
+ }
+ }
+ print("\a");
+ print($test = substr($test, $r, $l - $r));
+ $r = length($return .= $test);
+ }
+ last CASE;
+ };
+
+ # (^D) completion list
+ $_ eq $complete && do {
+ print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n");
+ redo LOOP;
+ };
+
+ # (^U) kill
+ $_ eq $kill && do {
+ if ($r) {
+ $r = 0;
+ $return = "";
+ print("\r\n");
+ redo LOOP;
+ }
+ last CASE;
+ };
+
+ # (DEL) || (BS) erase
+ ($_ eq $erase1 || $_ eq $erase2) && do {
+ if($r) {
+ print("\b \b");
+ chop($return);
+ $r--;
+ }
+ last CASE;
+ };
+
+ # printable char
+ ord >= 32 && do {
+ $return .= $_;
+ $r++;
+ print;
+ last CASE;
+ };
+ }
+ }
+ }
+
+ # system $tty_restore if defined $tty_restore;
+ if (defined $tty_saved_state && defined $tty_restore && defined $tty_safe_restore)
+ {
+ system $tty_restore;
+ if ($?) {
+ # tty_restore caused error
+ system $tty_safe_restore;
+ }
+ }
+ print("\n");
+ $return;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/ReadKey.pm b/Master/tlpkg/tlperl.straw/lib/Term/ReadKey.pm
new file mode 100755
index 00000000000..92a2c22ec8f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/ReadKey.pm
@@ -0,0 +1,572 @@
+#
+# $Id: ReadKey.pm,v 2.23 2005/01/11 21:16:31 jonathan Exp $
+#
+
+=head1 NAME
+
+Term::ReadKey - A perl module for simple terminal control
+
+=head1 SYNOPSIS
+
+ use Term::ReadKey;
+ ReadMode 4; # Turn off controls keys
+ while (not defined ($key = ReadKey(-1))) {
+ # No key yet
+ }
+ print "Get key $key\n";
+ ReadMode 0; # Reset tty mode before exiting
+
+=head1 DESCRIPTION
+
+Term::ReadKey is a compiled perl module dedicated to providing simple
+control over terminal driver modes (cbreak, raw, cooked, etc.,) support for
+non-blocking reads, if the architecture allows, and some generalized handy
+functions for working with terminals. One of the main goals is to have the
+functions as portable as possible, so you can just plug in "use
+Term::ReadKey" on any architecture and have a good likelyhood of it working.
+
+Version 2.30.01:
+Added handling of arrows, page up/down, home/end, insert/delete keys
+under Win32. These keys emit xterm-compatible sequences.
+Works with Term::ReadLine::Perl.
+
+=over 8
+
+=item ReadMode MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Restore original settings.
+ 1 Change to cooked mode.
+ 2 Change to cooked mode with echo off.
+ (Good for passwords)
+ 3 Change to cbreak mode.
+ 4 Change to raw mode.
+ 5 Change to ultra-raw mode.
+ (LF to CR/LF translation turned off)
+
+ Or, you may use the synonyms:
+
+ restore
+ normal
+ noecho
+ cbreak
+ raw
+ ultra-raw
+
+These functions are automatically applied to the STDIN handle if no
+other handle is supplied. Modes 0 and 5 have some special properties
+worth mentioning: not only will mode 0 restore original settings, but it
+cause the next ReadMode call to save a new set of default settings. Mode
+5 is similar to mode 4, except no CR/LF translation is performed, and if
+possible, parity will be disabled (only if not being used by the terminal,
+however. It is no different from mode 4 under Windows.)
+
+If you are executing another program that may be changing the terminal mode,
+you will either want to say
+
+ ReadMode 1
+ system('someprogram');
+ ReadMode 1;
+
+which resets the settings after the program has run, or:
+
+ $somemode=1;
+ ReadMode 0;
+ system('someprogram');
+ ReadMode 1;
+
+which records any changes the program may have made, before resetting the
+mode.
+
+=item ReadKey MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Perform a normal read using getc
+ -1 Perform a non-blocked read
+ >0 Perform a timed read
+
+(If the filehandle is not supplied, it will default to STDIN.) If there is
+nothing waiting in the buffer during a non-blocked read, then undef will be
+returned. Note that if the OS does not provide any known mechanism for
+non-blocking reads, then a C<ReadKey -1> can die with a fatal error. This
+will hopefully not be common.
+
+If MODE is greater then zero, then ReadKey will use it as a timeout value in
+seconds (fractional seconds are allowed), and won't return C<undef> until
+that time expires. (Note, again, that some OS's may not support this timeout
+behaviour.) If MODE is less then zero, then this is treated as a timeout
+of zero, and thus will return immediately if no character is waiting. A MODE
+of zero, however, will act like a normal getc.
+
+There are currently some limitations with this call under Windows. It may be
+possible that non-blocking reads will fail when reading repeating keys from
+more then one console.
+
+=item ReadLine MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Perform a normal read using scalar(<FileHandle>)
+ -1 Perform a non-blocked read
+ >0 Perform a timed read
+
+If there is nothing waiting in the buffer during a non-blocked read, then
+undef will be returned. Note that if the OS does not provide any known
+mechanism for non-blocking reads, then a C<ReadLine 1> can die with a fatal
+error. This will hopefully not be common. Note that a non-blocking test is
+only performed for the first character in the line, not the entire line.
+This call will probably B<not> do what you assume, especially with
+ReadMode's higher then 1. For example, pressing Space and then Backspace
+would appear to leave you where you started, but any timeouts would now
+be suspended.
+
+This call is currently not available under Windows.
+
+=item GetTerminalSize [Filehandle]
+
+Returns either an empty array if this operation is unsupported, or a four
+element array containing: the width of the terminal in characters, the
+height of the terminal in character, the width in pixels, and the height in
+pixels. (The pixel size will only be valid in some environments.)
+
+Under Windows, this function must be called with an "output" filehandle,
+such as STDOUT, or a handle opened to CONOUT$.
+
+=item SetTerminalSize WIDTH,HEIGHT,XPIX,YPIX [, Filehandle]
+
+Return -1 on failure, 0 otherwise. Note that this terminal size is only for
+B<informative> value, and changing the size via this mechanism will B<not>
+change the size of the screen. For example, XTerm uses a call like this when
+it resizes the screen. If any of the new measurements vary from the old, the
+OS will probably send a SIGWINCH signal to anything reading that tty or pty.
+
+This call does not work under Windows.
+
+=item GetSpeeds [, Filehandle]
+
+Returns either an empty array if the operation is unsupported, or a two
+value array containing the terminal in and out speeds, in B<decimal>. E.g,
+an in speed of 9600 baud and an out speed of 4800 baud would be returned as
+(9600,4800). Note that currently the in and out speeds will always be
+identical in some OS's. No speeds are reported under Windows.
+
+=item GetControlChars [, Filehandle]
+
+Returns an array containing key/value pairs suitable for a hash. The pairs
+consist of a key, the name of the control character/signal, and the value
+of that character, as a single character. This call does nothing under Windows.
+
+Each key will be an entry from the following list:
+
+ DISCARD
+ DSUSPEND
+ EOF
+ EOL
+ EOL2
+ ERASE
+ ERASEWORD
+ INTERRUPT
+ KILL
+ MIN
+ QUIT
+ QUOTENEXT
+ REPRINT
+ START
+ STATUS
+ STOP
+ SUSPEND
+ SWITCH
+ TIME
+
+Thus, the following will always return the current interrupt character,
+regardless of platform.
+
+ %keys = GetControlChars;
+ $int = $keys{INTERRUPT};
+
+=item SetControlChars [, Filehandle]
+
+Takes an array containing key/value pairs, as a hash will produce. The pairs
+should consist of a key that is the name of a legal control
+character/signal, and the value should be either a single character, or a
+number in the range 0-255. SetControlChars will die with a runtime error if
+an invalid character name is passed or there is an error changing the
+settings. The list of valid names is easily available via
+
+ %cchars = GetControlChars();
+ @cnames = keys %cchars;
+
+This call does nothing under Windows.
+
+=back
+
+=head1 AUTHOR
+
+Kenneth Albanowski <kjahds@kjahds.com>
+
+Currently maintained by Jonathan Stowe <jns@gellyfish.com>
+
+=cut
+
+package Term::ReadKey;
+
+$VERSION = '2.30.01';
+
+require Exporter;
+require AutoLoader;
+require DynaLoader;
+use Carp;
+
+@ISA = qw(Exporter AutoLoader DynaLoader);
+
+# Items to export into callers namespace by default
+# (move infrequently used names to @EXPORT_OK below)
+
+@EXPORT = qw(
+ ReadKey
+ ReadMode
+ ReadLine
+ GetTerminalSize
+ SetTerminalSize
+ GetSpeed
+ GetControlChars
+ SetControlChars
+);
+
+@EXPORT_OK = qw();
+
+bootstrap Term::ReadKey;
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+# Should we use LINES and COLUMNS to try and get the terminal size?
+# Change this to zero if you have systems where these are commonly
+# set to erroneous values. (But if either are nero zero, they won't be
+# used anyhow.)
+
+$UseEnv = 1;
+
+$CurrentMode = 0;
+
+%modes = (
+ original => 0,
+ restore => 0,
+ normal => 1,
+ noecho => 2,
+ cbreak => 3,
+ raw => 4,
+ 'ultra-raw' => 5
+);
+
+sub ReadMode
+{
+ my ($mode) = $modes{ $_[0] };
+ my ($fh) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDIN ) );
+ if ( defined($mode) ) { $CurrentMode = $mode }
+ elsif ( $_[0] =~ /^\d/ ) { $CurrentMode = $_[0] }
+ else { croak("Unknown terminal mode `$_[0]'"); }
+ SetReadMode($CurrentMode, $fh);
+}
+
+sub normalizehandle
+{
+ my ($file) = @_;
+
+ # print "Handle = $file\n";
+ if ( ref($file) ) { return $file; } # Reference is fine
+
+ # if($file =~ /^\*/) { return $file; } # Type glob is good
+ if ( ref( \$file ) eq 'GLOB' ) { return $file; } # Glob is good
+
+ # print "Caller = ",(caller(1))[0],"\n";
+ return \*{ ( ( caller(1) )[0] ) . "::$file" };
+}
+
+sub GetTerminalSize
+{
+ my ($file) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDOUT ) );
+ my (@results) = ();
+ my (@fail);
+
+ if ( &termsizeoptions() & 1 ) # VIO
+ {
+ @results = GetTermSizeVIO($file);
+ push( @fail, "VIOGetMode call" );
+ }
+ elsif ( &termsizeoptions() & 2 ) # GWINSZ
+ {
+ @results = GetTermSizeGWINSZ($file);
+ push( @fail, "TIOCGWINSZ ioctl" );
+ }
+ elsif ( &termsizeoptions() & 4 ) # GSIZE
+ {
+ @results = GetTermSizeGSIZE($file);
+ push( @fail, "TIOCGSIZE ioctl" );
+ }
+ elsif ( &termsizeoptions() & 8 ) # WIN32
+ {
+ @results = GetTermSizeWin32($file);
+ push( @fail, "Win32 GetConsoleScreenBufferInfo call" );
+ }
+ else
+ {
+ @results = ();
+ }
+
+ if ( @results < 4 and $UseEnv )
+ {
+ my ($C) = defined( $ENV{COLUMNS} ) ? $ENV{COLUMNS} : 0;
+ my ($L) = defined( $ENV{LINES} ) ? $ENV{LINES} : 0;
+ if ( ( $C >= 2 ) and ( $L >= 2 ) )
+ {
+ @results = ( $C + 0, $L + 0, 0, 0 );
+ }
+ push( @fail, "COLUMNS and LINES environment variables" );
+ }
+
+ if ( @results < 4 )
+ {
+ my ($prog) = "resize";
+
+ # Workaround for Solaris path sillyness
+ if ( -f "/usr/openwin/bin/resize" ) {
+ $prog = "/usr/openwin/bin/resize";
+ }
+
+ my ($resize) = scalar(`$prog 2>/dev/null`);
+ if (
+ defined $resize
+ and ( $resize =~ /COLUMNS\s*=\s*(\d+)/
+ or $resize =~ /setenv\s+COLUMNS\s+'?(\d+)/ )
+ )
+ {
+ $results[0] = $1;
+ if ( $resize =~ /LINES\s*=\s*(\d+)/
+ or $resize =~ /setenv\s+LINES\s+'?(\d+)/ )
+ {
+ $results[1] = $1;
+ @results[ 2, 3 ] = ( 0, 0 );
+ }
+ else
+ {
+ @results = ();
+ }
+ }
+ else
+ {
+ @results = ();
+ }
+ push( @fail, "resize program" );
+ }
+
+ if ( @results < 4 )
+ {
+ die "Unable to get Terminal Size."
+ . join( "", map( " The $_ didn't work.", @fail ) );
+ }
+
+ @results;
+}
+
+if ( &blockoptions() & 1 ) # Use nodelay
+{
+ if ( &blockoptions() & 2 ) #poll
+ {
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if (defined $_[0] && $_[0] > 0) {
+ if ($_[0]) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ }
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,1);
+ }
+ my ($value) = getc $File;
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,0);
+ }
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+
+ if (defined $_[0] && $_[0] > 0) {
+ if ($_[0]) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ }
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,1)
+ };
+ my ($value) = scalar(<$File>);
+ if ( defined $_[0] && $_[0]<0 ) {
+ &setnodelay($File,0)
+ };
+ $value;
+ }
+DONE
+ }
+ elsif ( &blockoptions() & 4 ) #select
+ {
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ if($_[0]) {return undef if &selectfile($File,$_[0])==0}
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
+ my($value) = getc $File;
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ if($_[0]) {return undef if &selectfile($File,$_[0])==0}
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
+ my($value)=scalar(<$File>);
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
+ $value;
+ }
+DONE
+ }
+ else
+ { #nothing
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ # Nothing better seems to exist, so I just use time-of-day
+ # to timeout the read. This isn't very exact, though.
+ $starttime=time;
+ $endtime=$starttime+$_[0];
+ &setnodelay($File,1);
+ my($value)=undef;
+ while(time<$endtime) { # This won't catch wraparound!
+ $value = getc $File;
+ last if defined($value);
+ }
+ &setnodelay($File,0);
+ return $value;
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
+ my($value) = getc $File;
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ # Nothing better seems to exist, so I just use time-of-day
+ # to timeout the read. This isn't very exact, though.
+ $starttime=time;
+ $endtime=$starttime+$_[0];
+ &setnodelay($File,1);
+ my($value)=undef;
+ while(time<$endtime) { # This won't catch wraparound!
+ $value = scalar(<$File>);
+ last if defined($value);
+ }
+ &setnodelay($File,0);
+ return $value;
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
+ my($value)=scalar(<$File>);
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
+ $value;
+ }
+DONE
+ }
+}
+elsif ( &blockoptions() & 2 ) # Use poll
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] != 0) {
+ return undef if &pollfile($File,$_[0]) == 0
+ }
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]!=0) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ scalar(<$File>);
+ }
+DONE
+}
+elsif ( &blockoptions() & 4 ) # Use select
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] !=0 ) {
+ return undef if &selectfile($File,$_[0])==0
+ }
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] != 0) {
+ return undef if &selectfile($File,$_[0]) == 0;
+ }
+ scalar(<$File>);
+ }
+DONE
+}
+elsif ( &blockoptions() & 8 ) # Use Win32
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if ($_[0] || $CurrentMode >= 3) {
+ Win32PeekChar($File, $_[0]);
+ } else {
+ getc $File;
+ }
+ #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
+ #getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
+ #scalar(<$File>);
+ if($_[0])
+ {croak("Non-blocking ReadLine is not supported on this architecture")}
+ scalar(<$File>);
+ }
+DONE
+}
+else
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if($_[0])
+ {croak("Non-blocking ReadKey is not supported on this architecture")}
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if($_[0])
+ {croak("Non-blocking ReadLine is not supported on this architecture")}
+ scalar(<$File>);
+ }
+DONE
+}
+
+package Term::ReadKey; # return to package ReadKey so AutoSplit is happy
+1;
+
+__END__;
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/ReadLine.pm b/Master/tlpkg/tlperl.straw/lib/Term/ReadLine.pm
new file mode 100755
index 00000000000..a8116af5e74
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/ReadLine.pm
@@ -0,0 +1,413 @@
+=head1 NAME
+
+Term::ReadLine - Perl interface to various C<readline> packages.
+If no real package is found, substitutes stubs instead of basic functions.
+
+=head1 SYNOPSIS
+
+ use Term::ReadLine;
+ my $term = Term::ReadLine->new('Simple Perl calc');
+ my $prompt = "Enter your arithmetic expression: ";
+ my $OUT = $term->OUT || \*STDOUT;
+ while ( defined ($_ = $term->readline($prompt)) ) {
+ my $res = eval($_);
+ warn $@ if $@;
+ print $OUT $res, "\n" unless $@;
+ $term->addhistory($_) if /\S/;
+ }
+
+=head1 DESCRIPTION
+
+This package is just a front end to some other packages. It's a stub to
+set up a common interface to the various ReadLine implementations found on
+CPAN (under the C<Term::ReadLine::*> namespace).
+
+=head1 Minimal set of supported functions
+
+All the supported functions should be called as methods, i.e., either as
+
+ $term = Term::ReadLine->new('name');
+
+or as
+
+ $term->addhistory('row');
+
+where $term is a return value of Term::ReadLine-E<gt>new().
+
+=over 12
+
+=item C<ReadLine>
+
+returns the actual package that executes the commands. Among possible
+values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
+C<Term::ReadLine::Stub>.
+
+=item C<new>
+
+returns the handle for subsequent calls to following
+functions. Argument is the name of the application. Optionally can be
+followed by two arguments for C<IN> and C<OUT> filehandles. These
+arguments should be globs.
+
+=item C<readline>
+
+gets an input line, I<possibly> with actual C<readline>
+support. Trailing newline is removed. Returns C<undef> on C<EOF>.
+
+=item C<addhistory>
+
+adds the line to the history of input, from where it can be used if
+the actual C<readline> is present.
+
+=item C<IN>, C<OUT>
+
+return the filehandles for input and output or C<undef> if C<readline>
+input and output cannot be used for Perl.
+
+=item C<MinLine>
+
+If argument is specified, it is an advice on minimal size of line to
+be included into history. C<undef> means do not include anything into
+history. Returns the old value.
+
+=item C<findConsole>
+
+returns an array with two strings that give most appropriate names for
+files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
+
+=item Attribs
+
+returns a reference to a hash which describes internal configuration
+of the package. Names of keys in this hash conform to standard
+conventions with the leading C<rl_> stripped.
+
+=item C<Features>
+
+Returns a reference to a hash with keys being features present in
+current implementation. Several optional features are used in the
+minimal interface: C<appname> should be present if the first argument
+to C<new> is recognized, and C<minline> should be present if
+C<MinLine> method is not dummy. C<autohistory> should be present if
+lines are put into history automatically (maybe subject to
+C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
+
+If C<Features> method reports a feature C<attribs> as present, the
+method C<Attribs> is not dummy.
+
+=back
+
+=head1 Additional supported functions
+
+Actually C<Term::ReadLine> can use some other package, that will
+support a richer set of commands.
+
+All these commands are callable via method interface and have names
+which conform to standard conventions with the leading C<rl_> stripped.
+
+The stub package included with the perl distribution allows some
+additional methods:
+
+=over 12
+
+=item C<tkRunning>
+
+makes Tk event loop run when waiting for user input (i.e., during
+C<readline> method).
+
+=item C<ornaments>
+
+makes the command line stand out by using termcap data. The argument
+to C<ornaments> should be 0, 1, or a string of a form
+C<"aa,bb,cc,dd">. Four components of this string should be names of
+I<terminal capacities>, first two will be issued to make the prompt
+standout, last two to make the input line standout.
+
+=item C<newTTY>
+
+takes two arguments which are input filehandle and output filehandle.
+Switches to use these filehandles.
+
+=back
+
+One can check whether the currently loaded ReadLine package supports
+these methods by checking for corresponding C<Features>.
+
+=head1 EXPORTS
+
+None
+
+=head1 ENVIRONMENT
+
+The environment variable C<PERL_RL> governs which ReadLine clone is
+loaded. If the value is false, a dummy interface is used. If the value
+is true, it should be tail of the name of the package to use, such as
+C<Perl> or C<Gnu>.
+
+As a special case, if the value of this variable is space-separated,
+the tail might be used to disable the ornaments by setting the tail to
+be C<o=0> or C<ornaments=0>. The head should be as described above, say
+
+If the variable is not set, or if the head of space-separated list is
+empty, the best available package is loaded.
+
+ export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments
+ export "PERL_RL= o=0" # Use best available ReadLine without ornaments
+
+(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
+particular used C<Term::ReadLine::*> package).
+
+=head1 CAVEATS
+
+It seems that using Term::ReadLine from Emacs minibuffer doesn't work
+quite right and one will get an error message like
+
+ Cannot open /dev/tty for read at ...
+
+One possible workaround for this is to explicitly open /dev/tty like this
+
+ open (FH, "/dev/tty" )
+ or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }';
+ die $@ if $@;
+ close (FH);
+
+or you can try using the 4-argument form of Term::ReadLine->new().
+
+=cut
+
+use strict;
+
+package Term::ReadLine::Stub;
+our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
+
+$DB::emacs = $DB::emacs; # To peacify -w
+our @rl_term_set;
+*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
+
+sub PERL_UNICODE_STDIN () { 0x0001 }
+
+sub ReadLine {'Term::ReadLine::Stub'}
+sub readline {
+ my $self = shift;
+ my ($in,$out,$str) = @$self;
+ my $prompt = shift;
+ print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
+ $self->register_Tk
+ if not $Term::ReadLine::registered and $Term::ReadLine::toloop
+ and defined &Tk::DoOneEvent;
+ #$str = scalar <$in>;
+ $str = $self->get_line;
+ $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
+ utf8::upgrade($str)
+ if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
+ utf8::valid($str);
+ print $out $rl_term_set[3];
+ # bug in 5.000: chomping empty string creats length -1:
+ chomp $str if defined $str;
+ $str;
+}
+sub addhistory {}
+
+sub findConsole {
+ my $console;
+ my $consoleOUT;
+
+ if ($^O eq 'MacOS') {
+ $console = "Dev:Console";
+ } elsif (-e "/dev/tty") {
+ $console = "/dev/tty";
+ } elsif (-e "con" or $^O eq 'MSWin32') {
+ $console = 'CONIN$';
+ $consoleOUT = 'CONOUT$';
+ } else {
+ $console = "sys\$command";
+ }
+
+ if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
+ $console = undef;
+ }
+ elsif ($^O eq 'os2') {
+ if ($DB::emacs) {
+ $console = undef;
+ } else {
+ $console = "/dev/con";
+ }
+ }
+
+ $consoleOUT = $console unless defined $consoleOUT;
+ $console = "&STDIN" unless defined $console;
+ if (!defined $consoleOUT) {
+ $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
+ }
+ ($console,$consoleOUT);
+}
+
+sub new {
+ die "method new called with wrong number of arguments"
+ unless @_==2 or @_==4;
+ #local (*FIN, *FOUT);
+ my ($FIN, $FOUT, $ret);
+ if (@_==2) {
+ my($console, $consoleOUT) = $_[0]->findConsole;
+
+
+ # the Windows CONIN$ needs GENERIC_WRITE mode to allow
+ # a SetConsoleMode() if we end up using Term::ReadKey
+ open FIN, ( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" :
+ "<$console";
+ open FOUT,">$consoleOUT";
+
+ #OUT->autoflush(1); # Conflicts with debugger?
+ my $sel = select(FOUT);
+ $| = 1; # for DB::OUT
+ select($sel);
+ $ret = bless [\*FIN, \*FOUT];
+ } else { # Filehandles supplied
+ $FIN = $_[2]; $FOUT = $_[3];
+ #OUT->autoflush(1); # Conflicts with debugger?
+ my $sel = select($FOUT);
+ $| = 1; # for DB::OUT
+ select($sel);
+ $ret = bless [$FIN, $FOUT];
+ }
+ if ($ret->Features->{ornaments}
+ and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $ret->ornaments(1);
+ }
+ return $ret;
+}
+
+sub newTTY {
+ my ($self, $in, $out) = @_;
+ $self->[0] = $in;
+ $self->[1] = $out;
+ my $sel = select($out);
+ $| = 1; # for DB::OUT
+ select($sel);
+}
+
+sub IN { shift->[0] }
+sub OUT { shift->[1] }
+sub MinLine { undef }
+sub Attribs { {} }
+
+my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
+sub Features { \%features }
+
+sub get_line {
+ my $self = shift;
+ my $in = $self->IN;
+ local ($/) = "\n";
+ return scalar <$in>;
+}
+
+package Term::ReadLine; # So late to allow the above code be defined?
+
+our $VERSION = '1.04';
+
+my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
+if ($which) {
+ if ($which =~ /\bgnu\b/i){
+ eval "use Term::ReadLine::Gnu;";
+ } elsif ($which =~ /\bperl\b/i) {
+ eval "use Term::ReadLine::Perl;";
+ } else {
+ eval "use Term::ReadLine::$which;";
+ }
+} elsif (defined $which and $which ne '') { # Defined but false
+ # Do nothing fancy
+} else {
+ eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
+}
+
+#require FileHandle;
+
+# To make possible switch off RL in debugger: (Not needed, work done
+# in debugger).
+our @ISA;
+if (defined &Term::ReadLine::Gnu::readline) {
+ @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
+} elsif (defined &Term::ReadLine::Perl::readline) {
+ @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
+} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
+ @ISA = "Term::ReadLine::$which";
+} else {
+ @ISA = qw(Term::ReadLine::Stub);
+}
+
+package Term::ReadLine::TermCap;
+
+# Prompt-start, prompt-end, command-line-start, command-line-end
+# -- zero-width beautifies to emit around prompt and the command line.
+our @rl_term_set = ("","","","");
+# string encoded:
+our $rl_term_set = ',,,';
+
+our $terminal;
+sub LoadTermCap {
+ return if defined $terminal;
+
+ require Term::Cap;
+ $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
+}
+
+sub ornaments {
+ shift;
+ return $rl_term_set unless @_;
+ $rl_term_set = shift;
+ $rl_term_set ||= ',,,';
+ $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
+ my @ts = split /,/, $rl_term_set, 4;
+ eval { LoadTermCap };
+ unless (defined $terminal) {
+ warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
+ $rl_term_set = ',,,';
+ return;
+ }
+ @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
+ return $rl_term_set;
+}
+
+
+package Term::ReadLine::Tk;
+
+our($count_handle, $count_DoOne, $count_loop);
+$count_handle = $count_DoOne = $count_loop = 0;
+
+our($giveup);
+sub handle {$giveup = 1; $count_handle++}
+
+sub Tk_loop {
+ # Tk->tkwait('variable',\$giveup); # needs Widget
+ $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
+ $count_loop++;
+ $giveup = 0;
+}
+
+sub register_Tk {
+ my $self = shift;
+ $Term::ReadLine::registered++
+ or Tk->fileevent($self->IN,'readable',\&handle);
+}
+
+sub tkRunning {
+ $Term::ReadLine::toloop = $_[1] if @_ > 1;
+ $Term::ReadLine::toloop;
+}
+
+sub get_c {
+ my $self = shift;
+ $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ return getc $self->IN;
+}
+
+sub get_line {
+ my $self = shift;
+ $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ my $in = $self->IN;
+ local ($/) = "\n";
+ return scalar <$in>;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/ReadLine/Perl.pm b/Master/tlpkg/tlperl.straw/lib/Term/ReadLine/Perl.pm
new file mode 100755
index 00000000000..599b2c3769a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/ReadLine/Perl.pm
@@ -0,0 +1,153 @@
+package Term::ReadLine::Perl;
+use Carp;
+@ISA = qw(Term::ReadLine::Stub Term::ReadLine::Compa Term::ReadLine::Perl::AU);
+#require 'readline.pl';
+
+$VERSION = $VERSION = 1.0303;
+
+sub readline {
+ shift;
+ #my $in =
+ &readline::readline(@_);
+ #$loaded = defined &Term::ReadKey::ReadKey;
+ #print STDOUT "\nrl=`$in', loaded = `$loaded'\n";
+ #if (ref \$in eq 'GLOB') { # Bug under debugger
+ # ($in = "$in") =~ s/^\*(\w+::)+//;
+ #}
+ #print STDOUT "rl=`$in'\n";
+ #$in;
+}
+
+#sub addhistory {}
+*addhistory = \&AddHistory;
+
+#$term;
+$readline::minlength = 1; # To peacify -w
+$readline::rl_readline_name = undef; # To peacify -w
+$readline::rl_basic_word_break_characters = undef; # To peacify -w
+
+sub new {
+ if (defined $term) {
+ warn "Cannot create second readline interface, falling back to dumb.\n";
+ return Term::ReadLine::Stub::new(@_);
+ }
+ shift; # Package
+ if (@_) {
+ if ($term) {
+ warn "Ignoring name of second readline interface.\n" if defined $term;
+ shift;
+ } else {
+ $readline::rl_readline_name = shift; # Name
+ }
+ }
+ if (!@_) {
+ if (!defined $term) {
+ ($IN,$OUT) = Term::ReadLine->findConsole();
+ # Old Term::ReadLine did not have a workaround for a bug in Win devdriver
+ $IN = 'CONIN$' if $^O eq 'MSWin32' and "\U$IN" eq 'CON';
+ open IN,
+ # A workaround for another bug in Win device driver
+ (($IN eq 'CONIN$' and $^O eq 'MSWin32') ? "+< $IN" : "< $IN")
+ or croak "Cannot open $IN for read";
+ open(OUT,">$OUT") || croak "Cannot open $OUT for write";
+ $readline::term_IN = \*IN;
+ $readline::term_OUT = \*OUT;
+ }
+ } else {
+ if (defined $term and ($term->IN ne $_[0] or $term->OUT ne $_[1]) ) {
+ croak "Request for a second readline interface with different terminal";
+ }
+ $readline::term_IN = shift;
+ $readline::term_OUT = shift;
+ }
+ eval {require Term::ReadLine::readline}; die $@ if $@;
+ # The following is here since it is mostly used for perl input:
+ # $readline::rl_basic_word_break_characters .= '-:+/*,[])}';
+ $term = bless [$readline::term_IN,$readline::term_OUT];
+ unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) {
+ local $Term::ReadLine::termcap_nowarn = 1; # With newer Perls
+ local $SIG{__WARN__} = sub {}; # With older Perls
+ $term->ornaments(1);
+ }
+ return $term;
+}
+sub newTTY {
+ my ($self, $in, $out) = @_;
+ $readline::term_IN = $self->[0] = $in;
+ $readline::term_OUT = $self->[1] = $out;
+ my $sel = select($out);
+ $| = 1; # for DB::OUT
+ select($sel);
+}
+sub ReadLine {'Term::ReadLine::Perl'}
+sub MinLine {
+ my $old = $readline::minlength;
+ $readline::minlength = $_[1] if @_ == 2;
+ return $old;
+}
+sub SetHistory {
+ shift;
+ @readline::rl_History = @_;
+ $readline::rl_HistoryIndex = @readline::rl_History;
+}
+sub GetHistory {
+ @readline::rl_History;
+}
+sub AddHistory {
+ shift;
+ push @readline::rl_History, @_;
+ $readline::rl_HistoryIndex = @readline::rl_History + @_;
+}
+%features = (appname => 1, minline => 1, autohistory => 1, getHistory => 1,
+ setHistory => 1, addHistory => 1, preput => 1,
+ attribs => 1, 'newTTY' => 1,
+ tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'},
+ ornaments => Term::ReadLine::Stub->Features->{'ornaments'},
+ );
+sub Features { \%features; }
+# my %attribs;
+tie %attribs, 'Term::ReadLine::Perl::Tie' or die ;
+sub Attribs {
+ \%attribs;
+}
+sub DESTROY {}
+
+package Term::ReadLine::Perl::AU;
+
+sub AUTOLOAD {
+ { $AUTOLOAD =~ s/.*:://; } # preserve match data
+ my $name = "readline::rl_$AUTOLOAD";
+ die "Unknown method `$AUTOLOAD' in Term::ReadLine::Perl"
+ unless exists $readline::{"rl_$AUTOLOAD"};
+ *$AUTOLOAD = sub { shift; &$name };
+ goto &$AUTOLOAD;
+}
+
+package Term::ReadLine::Perl::Tie;
+
+sub TIEHASH { bless {} }
+sub DESTROY {}
+
+sub STORE {
+ my ($self, $name) = (shift, shift);
+ $ {'readline::rl_' . $name} = shift;
+}
+sub FETCH {
+ my ($self, $name) = (shift, shift);
+ $ {'readline::rl_' . $name};
+}
+
+package Term::ReadLine::Compa;
+
+sub get_c {
+ my $self = shift;
+ getc($self->[0]);
+}
+
+sub get_line {
+ my $self = shift;
+ my $fh = $self->[0];
+ scalar <$fh>;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/ReadLine/readline.pm b/Master/tlpkg/tlperl.straw/lib/Term/ReadLine/readline.pm
new file mode 100755
index 00000000000..a19ddb19a9a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/ReadLine/readline.pm
@@ -0,0 +1,4615 @@
+##
+## Perl Readline -- The Quick Help
+## (see the manual for complete info)
+##
+## Once this package is included (require'd), you can then call
+## $text = &readline'readline($input);
+## to get lines of input from the user.
+##
+## Normally, it reads ~/.inputrc when loaded... to suppress this, set
+## $readline'rl_NoInitFromFile = 1;
+## before requiring the package.
+##
+## Call rl_bind to add your own key bindings, as in
+## &readline'rl_bind('C-L', 'possible-completions');
+##
+## Call rl_set to set mode variables yourself, as in
+## &readline'rl_set('TcshCompleteMode', 'On');
+##
+## To change the input mode (emacs or vi) use ~/.inputrc or call
+## &readline::rl_set('EditingMode', 'vi');
+## or &readline::rl_set('EditingMode', 'emacs');
+##
+## Call rl_basic_commands to set your own command completion, as in
+## &readline'rl_basic_commands('print', 'list', 'quit', 'run', 'status');
+##
+##
+
+# Wrap the code below (initially Perl4, now partially Perl4) into a fake
+# Perl5 pseudo-module; mismatch of package and file name is intentional
+# to make is harder to abuse this (very fragile) code...
+package readline;
+
+my $autoload_broken = 1; # currently: defined does not work with a-l
+my $useioctl = 1;
+my $usestty = 1;
+my $max_include_depth = 10; # follow $include's in init files this deep
+
+BEGIN { # Some old systems have ioctl "unsupported"
+ *ioctl = sub ($$$) { eval { ioctl $_[0], $_[1], $_[2] } };
+}
+
+##
+## BLURB:
+## A pretty full-function package similar to GNU's readline.
+## Includes support for EUC-encoded Japanese text.
+##
+## Written by Jeffrey Friedl, Omron Corporation (jfriedl@omron.co.jp)
+##
+## Comments, corrections welcome.
+##
+## Thanks to the people at FSF for readline (and the code I referenced
+## while writing this), and for Roland Schemers whose line_edit.pl I used
+## as an early basis for this.
+##
+$VERSION = $VERSION = '1.0303';
+
+## - Changes from Slaven Rezic (slaven@rezic.de):
+## * reverted the usage of $ENV{EDITOR} to set startup mode
+## only ~/.inputrc or an explicit call to rl_set should
+## be used to set startup mode
+##
+# 1011109.011 - Changes from Russ Southern (russ@dvns.com):
+## * Added $rl_vi_replace_default_on_insert
+# 1000510.010 - Changes from Joe Petolino (petolino@eng.sun.com), requested
+## by Ilya:
+##
+## * Make it compatible with perl 5.003.
+## * Rename getc() to getc_with_pending().
+## * Change unshift(@Pending) to push(@Pending).
+##
+## 991109.009 - Changes from Joe Petolino (petolino@eng.sun.com):
+## Added vi mode. Also added a way to set the keymap default
+## action for multi-character keymaps, so that a 2-character
+## sequence (e.g. <esc>A) can be treated as two one-character
+## commands (<esc>, then A) if the sequence is not explicitly
+## mapped.
+##
+## Changed subs:
+##
+## * preinit(): Initialize new keymaps and other data structures.
+## Use $ENV{EDITOR} to set startup mode.
+##
+## * init(): Sets the global *KeyMap, since &F_ReReadInitFile
+## may have changed the key map.
+##
+## * InitKeymap(): $KeyMap{default} is now optional - don't
+## set it if $_[1] eq '';
+##
+## * actually_do_binding(): Set $KeyMap{default} for '\*' key;
+## warning if double-defined.
+##
+## * rl_bind(): Implement \* to set the keymap default. Also fix
+## some existing regex bugs that I happened to notice.
+##
+## * readline(): No longer takes input from $pending before
+## calling &$rl_getc(); instead, it calls getc_with_pending(),
+## which takes input from the new array @Pending
+## before calling &$rl_getc(). Sets the global
+## *KeyMap after do_command(), since do_command()
+## may change the keymap now. Does some cursor
+## manipulation after do_command() when at the end
+## of the line in vi command mode, to match the
+## behavior of vi.
+##
+## * rl_getc(): Added a my declaration for $key, which was
+## apparently omitted by the author. rl_getc() is
+## no longer called directly; instead, getc_with_pending() calls
+## it only after exhausting any requeued characters
+## in @Pending. @Pending is used to implement the
+## vi '.' command, as well as the emacs DoSearch
+## functionality.
+##
+## * do_command(): Now defaults the command to 'F_Ding' if
+## $KeyMap{default} is undefined. This is part
+## of the new \* feature.
+##
+## * savestate()/getstate(): Now use an anonymous array instead
+## of packing the fields into a string.
+##
+## * F_AcceptLine(): Code moved to new sub add_line_to_history(),
+## so that it may be called by F_SaveLine()
+## as well as by F_AcceptLine().
+##
+## * F_QuotedInsert(): Calls getc_with_pending() instead of &$rl_getc().
+##
+## * F_UnixWordRubout(): Fixed bug: changed 'my' declaration of
+## global $rl_basic_word_break_characters to 'local'.
+##
+## * DoSearch(): Calls getc_with_pending() instead of &$rl_getc(). Ungets
+## character onto @Pending instead of $pending.
+##
+## * F_EmacsEditingMode(): Resets global $Vi_mode;
+##
+## * F_ToggleEditingMode(): Deleted. We use F_ViInput() and
+## F_EmacsEditingMode() instead.
+##
+## * F_PrefixMeta(): Calls getc_with_pending() instead of &$rl_getc().
+##
+## * F_DigitArgument(): Calls getc_with_pending() instead of &$rl_getc().
+##
+## * F_Ding(): Returns undef, for testing by vi commands.
+##
+## * F_Complete(): Returns true if a completion was done, false
+## otherwise, so vi completion routines can test it.
+##
+## * complete_internal(): Returns true if a completion was done,
+## false otherwise, so vi completion routines can
+## test it. Does a little cursor massaging in vi
+## mode, to match the behavior of ksh vi mode.
+##
+## Disclaimer: the original code dates from the perl 4 days, and
+## isn't very pretty by today's standards (for example,
+## extensive use of typeglobs and localized globals). In the
+## interests of not breaking anything, I've tried to preserve
+## the old code as much as possible, and I've avoided making
+## major stylistic changes. Since I'm not a regular emacs user,
+## I haven't done much testing to see that all the emacs-mode
+## features still work.
+##
+## 940817.008 - Added $var_CompleteAddsuffix.
+## Now recognizes window-change signals (at least on BSD).
+## Various typos and bug fixes.
+## Changes from Chris Arthur (csa@halcyon.com):
+## Added a few new keybindings.
+## Various typos and bug fixes.
+## Support for use from a dumb terminal.
+## Pretty-printing of filename-completion matches.
+##
+## 930306.007 - Added rl_start_default_at_beginning.
+## Added optional message arg to &redisplay.
+## Added explicit numeric argument var to functions that use it.
+## Redid many commands to simplify.
+## Added TransposeChars, UpcaseWord, CapitalizeWord, DownCaseWord.
+## Redid key binding specs to better match GNU.. added
+## undocumented "new-style" bindings.... can now bind
+## arrow keys and other arbitrairly long key sequences.
+## Added if/else/then to .inputrc.
+##
+## 930305.006 - optional "default" added (from mmuegel@cssmp.corp.mot.com).
+##
+## 930211.005 - fixed strange problem with eval while keybinding
+##
+
+##
+## Ilya:
+##
+## Added support for ReadKey,
+##
+## Added customization variable $minlength
+## to denote minimal lenth of a string to be put into history buffer.
+##
+## Added support for a bug in debugger: preinit cannot be a subroutine ?!!!
+## (See immendiately below)
+##
+## Added support for WINCH hooks. The subroutine references should be put into
+## @winchhooks.
+##
+## Added F_ToggleInsertMode, F_HistorySearchBackward,
+## F_HistorySearchForward, PC keyboard bindings.
+## 0.93: Updates to Operate, couple of keybindings added.
+## $rl_completer_terminator_character, $rl_correct_sw added.
+## Reload-init-file moved to C-x C-x.
+## C-x ? and C-x * list/insert possible completions.
+
+$rl_getc = \&rl_getc;
+
+&preinit;
+&init;
+
+# # # # use strict 'vars';
+
+# # # # # Separation into my and vars needs some thought...
+
+# # # # use vars qw(@KeyMap %KeyMap $rl_screen_width $rl_start_default_at_beginning
+# # # # $rl_completion_function $rl_basic_word_break_characters
+# # # # $rl_completer_word_break_characters $rl_special_prefixes
+# # # # $rl_readline_name @rl_History $rl_MaxHistorySize
+# # # # $rl_max_numeric_arg $rl_OperateCount
+# # # # $KillBuffer $dumb_term $stdin_not_tty $InsertMode
+# # # # $rl_NoInitFromFile);
+
+# # # # my ($InputLocMsg, $term_OUT, $term_IN);
+# # # # my ($winsz_t, $TIOCGWINSZ, $winsz, $rl_margin, $hooj, $force_redraw);
+# # # # my ($hook, %var_HorizontalScrollMode, %var_EditingMode, %var_OutputMeta);
+# # # # my ($var_HorizontalScrollMode, $var_EditingMode, $var_OutputMeta);
+# # # # my (%var_ConvertMeta, $var_ConvertMeta, %var_MarkModifiedLines, $var_MarkModifiedLines);
+# # # # my ($term_readkey, $inDOS);
+# # # # my (%var_PreferVisibleBell, $var_PreferVisibleBell);
+# # # # my (%var_TcshCompleteMode, $var_TcshCompleteMode);
+# # # # my (%var_CompleteAddsuffix, $var_CompleteAddsuffix);
+# # # # my ($minlength, @winchhooks);
+# # # # my ($BRKINT, $ECHO, $FIONREAD, $ICANON, $ICRNL, $IGNBRK, $IGNCR, $INLCR,
+# # # # $ISIG, $ISTRIP, $NCCS, $OPOST, $RAW, $TCGETS, $TCOON, $TCSETS, $TCXONC,
+# # # # $TERMIOS_CFLAG, $TERMIOS_IFLAG, $TERMIOS_LFLAG, $TERMIOS_NORMAL_IOFF,
+# # # # $TERMIOS_NORMAL_ION, $TERMIOS_NORMAL_LOFF, $TERMIOS_NORMAL_LON,
+# # # # $TERMIOS_NORMAL_OOFF, $TERMIOS_NORMAL_OON, $TERMIOS_OFLAG,
+# # # # $TERMIOS_READLINE_IOFF, $TERMIOS_READLINE_ION, $TERMIOS_READLINE_LOFF,
+# # # # $TERMIOS_READLINE_LON, $TERMIOS_READLINE_OOFF, $TERMIOS_READLINE_OON,
+# # # # $TERMIOS_VMIN, $TERMIOS_VTIME, $TIOCGETP, $TIOCGWINSZ, $TIOCSETP,
+# # # # $fion, $fionread_t, $mode, $sgttyb_t,
+# # # # $termios, $termios_t, $winsz, $winsz_t);
+# # # # my ($line, $initialized, $term_readkey);
+
+
+# # # # # Global variables added for vi mode (I'm leaving them all commented
+# # # # # out, like the declarations above, until SelfLoader issues
+# # # # # are resolved).
+
+# # # # # True when we're in one of the vi modes.
+# # # # my $Vi_mode;
+
+# # # # # Array refs: saves keystrokes for '.' command. Undefined when we're
+# # # # # not doing a '.'-able command.
+# # # # my $Dot_buf; # Working buffer
+# # # # my $Last_vi_command; # Gets $Dot_buf when a command is parsed
+
+# # # # # These hold state for vi 'u' and 'U'.
+# # # # my($Dot_state, $Vi_undo_state, $Vi_undo_all_state);
+
+# # # # # Refs to hashes used for cursor movement
+# # # # my($Vi_delete_patterns, $Vi_move_patterns,
+# # # # $Vi_change_patterns, $Vi_yank_patterns);
+
+# # # # # Array ref: holds parameters from the last [fFtT] command, for ';'
+# # # # # and ','.
+# # # # my $Last_findchar;
+
+# # # # # Globals for history search commands (/, ?, n, N)
+# # # # my $Vi_search_re; # Regular expression (compiled by qr{})
+# # # # my $Vi_search_reverse; # True for '?' search, false for '/'
+
+
+##
+## What's Cool
+## ----------------------------------------------------------------------
+## * hey, it's in perl.
+## * Pretty full GNU readline like library...
+## * support for ~/.inputrc
+## * horizontal scrolling
+## * command/file completion
+## * rebinding
+## * history (with search)
+## * undo
+## * numeric prefixes
+## * supports multi-byte characters (at least for the Japanese I use).
+## * Has a tcsh-like completion-function mode.
+## call &readline'rl_set('tcsh-complete-mode', 'On') to turn on.
+##
+
+##
+## What's not Cool
+## ----------------------------------------------------------------------
+## Can you say HUGE?
+## I can't spell, so comments riddled with misspellings.
+## Written by someone that has never really used readline.
+## History mechanism is slightly different than GNU... may get fixed
+## someday, but I like it as it is now...
+## Killbuffer not a ring.. just one level.
+## Obviously not well tested yet.
+## Written by someone that doesn't have a bell on his terminal, so
+## proper readline use of the bell may not be here.
+##
+
+
+##
+## Functions beginning with F_ are functions that are mapped to keys.
+## Variables and functions beginning rl_ may be accessed/set/called/read
+## from outside the package. Other things are internal.
+##
+## Some notable internal-only variables of global proportions:
+## $prompt -- line prompt (passed from user)
+## $line -- the line being input
+## $D -- ``Dot'' -- index into $line of the cursor's location.
+## $InsertMode -- usually true. False means overwrite mode.
+## $InputLocMsg -- string for error messages, such as "[~/.inputrc line 2]"
+## *emacs_keymap -- keymap for emacs-mode bindings:
+## @emacs_keymap - bindings indexed by ASCII ordinal
+## $emacs_keymap{'name'} = "emacs_keymap"
+## $emacs_keymap{'default'} = "SelfInsert" (default binding)
+## *vi_keymap -- keymap for vi input mode bindings
+## *vicmd_keymap -- keymap for vi command mode bindings
+## *vipos_keymap -- keymap for vi positioning command bindings
+## *visearch_keymap -- keymap for vi search pattern input mode bindings
+## *KeyMap -- current keymap in effect.
+## $LastCommandKilledText -- needed so that subsequent kills accumulate
+## $lastcommand -- name of command previously run
+## $lastredisplay -- text placed upon screen during previous &redisplay
+## $si -- ``screen index''; index into $line of leftmost char &redisplay'ed
+## $force_redraw -- if set to true, causes &redisplay to be verbose.
+## $AcceptLine -- when set, its value is returned from &readline.
+## $ReturnEOF -- unless this also set, in which case undef is returned.
+## @Pending -- characters to be used as input.
+## @undo -- array holding all states of current line, for undoing.
+## $KillBuffer -- top of kill ring (well, don't have a kill ring yet)
+## @tcsh_complete_selections -- for tcsh mode, possible selections
+##
+## Some internal variables modified by &rl_set (see comment at &rl_set for
+## info about how these set'able variables work)
+## $var_EditingMode -- a keymap typeglob like *emacs_keymap or *vi_keymap
+## $var_TcshCompleteMode -- if true, the completion function works like
+## in tcsh. That is, the first time you try to complete something,
+## the common prefix is completed for you. Subsequent completion tries
+## (without other commands in between) cycles the command line through
+## the various possibilities. If/when you get the one you want, just
+## continue typing.
+## Other $var_ things not supported yet.
+##
+## Some variables used internally, but may be accessed from outside...
+## $VERSION -- just for good looks.
+## $rl_readline_name = name of program -- for .initrc if/endif stuff.
+## $rl_NoInitFromFile -- if defined when package is require'd, ~/.inputrc
+## will not be read.
+## @rl_History -- array of previous lines input
+## $rl_HistoryIndex -- history pointer (for moving about history array)
+## $rl_completion_function -- see "How Command Completion Works" (way) below.
+## $rl_basic_word_break_characters -- string of characters that can cause
+## a word break for forward-word, etc.
+## $rl_start_default_at_beginning --
+## Normally, the user's cursor starts at the end of any default text
+## passed to readline. If this variable is true, it starts at the
+## beginning.
+## $rl_completer_word_break_characters --
+## like $rl_basic_word_break_characters (and in fact defaults to it),
+## but for the completion function.
+## $rl_completer_terminator_character -- what to insert to separate
+## a completed token from the rest. Reset at beginning of
+## completion to ' ' so completion function can change it.
+## $rl_special_prefixes -- characters that are part of this string as well
+## as of $rl_completer_word_break_characters cause a word break for the
+## completer function, but remain part of the word. An example: consider
+## when the input might be perl code, and one wants to be able to
+## complete on variable and function names, yet still have the '$',
+## '&', '@',etc. part of the $text to be completed. Then set this var
+## to '&@$%' and make sure each of these characters is in
+## $rl_completer_word_break_characters as well....
+## $rl_MaxHistorySize -- maximum size that the history array may grow.
+## $rl_screen_width -- width readline thinks it can use on the screen.
+## $rl_correct_sw -- is substructed from the real width of the terminal
+## $rl_margin -- scroll by moving to within this far from a margin.
+## $rl_CLEAR -- what to output to clear the screen.
+## $rl_max_numeric_arg -- maximum numeric arg allowed.
+## $rl_vi_replace_default_on_insert
+## Normally, the text you enter is added to any default text passed to
+## readline. If this variable is true, default text will start out
+## highlighted (if supported by your terminal) and text entered while the
+## default is highlighted (during the _first_ insert mode only) will
+## replace the entire default line. Once you have left insert mode (hit
+## escape), everything works as normal.
+## - This is similar to many GUI controls' behavior, which select the
+## default text so that new text replaces the old.
+## - Use with $rl_start_default_at_beginning for normal-looking behavior
+## (though it works just fine without it).
+## Notes/Bugs:
+## - Control characters (like C-w) do not actually terminate this replace
+## mode, for the same reason it does not work in emacs mode.
+## - Spine-crawlingly scary subroutine redefinitions
+## $rl_mark - start of the region
+## $line_rl_mark - the line on which $rl_mark is active
+## $_rl_japanese_mb - For character movement suppose Japanese (which?!)
+## multi-byte encoding. (How to make a sane default?)
+##
+
+sub get_window_size
+{
+ my $sig = shift;
+ local($., $@, $!, $^E, $?); # Preserve $! etc; the rest for hooks
+ my ($num_cols,$num_rows);
+
+ if (defined $term_readkey) {
+ ($num_cols,$num_rows) = Term::ReadKey::GetTerminalSize($term_OUT);
+ $rl_screen_width = $num_cols - $rl_correct_sw
+ if defined($num_cols) && $num_cols;
+ } elsif (defined $TIOCGWINSZ and &ioctl($term_IN,$TIOCGWINSZ,$winsz)) {
+ ($num_rows,$num_cols) = unpack($winsz_t,$winsz);
+ $rl_screen_width = $num_cols - $rl_correct_sw
+ if defined($num_cols) && $num_cols;
+ }
+ $rl_margin = int($rl_screen_width/3);
+ if (defined $sig) {
+ $force_redraw = 1;
+ &redisplay();
+ }
+
+ for $hook (@winchhooks) {
+ eval {&$hook()}; warn $@ if $@ and $^W;
+ }
+ local $^W = 0; # WINCH may be illegal...
+ $SIG{'WINCH'} = "readline::get_window_size";
+}
+
+# Fix: case-sensitivity of inputrc on/off keywords in
+# `set' commands. readline lib doesn't care about case.
+# changed case of keys 'On' and 'Off' to 'on' and 'off'
+# &rl_set changed so that it converts the value to
+# lower case before hash lookup.
+sub preinit
+{
+ ## Set up the input and output handles
+
+ $term_IN = \*STDIN unless defined $term_IN;
+ $term_OUT = \*STDOUT unless defined $term_OUT;
+ ## not yet supported... always on.
+ $var_HorizontalScrollMode = 1;
+ $var_HorizontalScrollMode{'On'} = 1;
+ $var_HorizontalScrollMode{'Off'} = 0;
+
+ $var_EditingMode{'emacs'} = *emacs_keymap;
+ $var_EditingMode{'vi'} = *vi_keymap;
+ $var_EditingMode{'vicmd'} = *vicmd_keymap;
+ $var_EditingMode{'vipos'} = *vipos_keymap;
+ $var_EditingMode{'visearch'} = *visearch_keymap;
+
+ ## this is an addition. Very nice.
+ $var_TcshCompleteMode = 0;
+ $var_TcshCompleteMode{'On'} = 1;
+ $var_TcshCompleteMode{'Off'} = 0;
+
+ $var_CompleteAddsuffix = 1;
+ $var_CompleteAddsuffix{'On'} = 1;
+ $var_CompleteAddsuffix{'Off'} = 0;
+
+ $var_DeleteSelection = $var_DeleteSelection{'On'} = 1;
+ $var_DeleteSelection{'Off'} = 0;
+ *rl_delete_selection = \$var_DeleteSelection; # Alias
+
+ ## not yet supported... always on
+ for ('InputMeta', 'OutputMeta') {
+ ${"var_$_"} = 1;
+ ${"var_$_"}{'Off'} = 0;
+ ${"var_$_"}{'On'} = 1;
+ }
+
+ ## not yet supported... always off
+ for ('ConvertMeta', 'MetaFlag', 'MarkModifiedLines', 'PreferVisibleBell',
+ 'BlinkMatchingParen', 'VisibleStats', 'ShowAllIfAmbiguous',
+ 'PrintCompletionsHorizontally', 'MarkDirectories', 'ExpandTilde',
+ 'EnableKeypad', 'DisableCompletion', 'CompletionIgnoreCase') {
+ ${"var_$_"} = 0;
+ ${"var_$_"}{'Off'} = 0;
+ ${"var_$_"}{'On'} = 1;
+ }
+
+ # To conform to interface
+ $minlength = 1 unless defined $minlength;
+
+ # WINCH hooks
+ @winchhooks = ();
+
+ $inDOS = $^O eq 'os2' || defined $ENV{OS2_SHELL} unless defined $inDOS;
+ eval {
+ require Term::ReadKey; $term_readkey++;
+ } unless defined $ENV{PERL_RL_USE_TRK}
+ and not $ENV{PERL_RL_USE_TRK};
+ unless ($term_readkey) {
+ eval {require "ioctl.pl"}; ## try to get, don't die if not found.
+ eval {require "sys/ioctl.ph"}; ## try to get, don't die if not found.
+ eval {require "sgtty.ph"}; ## try to get, don't die if not found.
+ if ($inDOS and !defined $TIOCGWINSZ) {
+ $TIOCGWINSZ=0;
+ $TIOCGETP=1;
+ $TIOCSETP=2;
+ $sgttyb_t="I5 C8";
+ $winsz_t="";
+ $RAW=0xf002;
+ $ECHO=0x0008;
+ }
+ $TIOCGETP = &TIOCGETP if defined(&TIOCGETP);
+ $TIOCSETP = &TIOCSETP if defined(&TIOCSETP);
+ $TIOCGWINSZ = &TIOCGWINSZ if defined(&TIOCGWINSZ);
+ $FIONREAD = &FIONREAD if defined(&FIONREAD);
+ $TCGETS = &TCGETS if defined(&TCGETS);
+ $TCSETS = &TCSETS if defined(&TCSETS);
+ $TCXONC = &TCXONC if defined(&TCXONC);
+ $TIOCGETP = 0x40067408 if !defined($TIOCGETP);
+ $TIOCSETP = 0x80067409 if !defined($TIOCSETP);
+ $TIOCGWINSZ = 0x40087468 if !defined($TIOCGWINSZ);
+ $FIONREAD = 0x4004667f if !defined($FIONREAD);
+ $TCGETS = 0x40245408 if !defined($TCGETS);
+ $TCSETS = 0x80245409 if !defined($TCSETS);
+ $TCXONC = 0x20005406 if !defined($TCXONC);
+
+ ## TTY modes
+ $ECHO = &ECHO if defined(&ECHO);
+ $RAW = &RAW if defined(&RAW);
+ $RAW = 040 if !defined($RAW);
+ $ECHO = 010 if !defined($ECHO);
+ #$CBREAK = 002 if !defined($CBREAK);
+ $mode = $RAW; ## could choose CBREAK for testing....
+
+ $IGNBRK = 1 if !defined($IGNBRK);
+ $BRKINT = 2 if !defined($BRKINT);
+ $ISTRIP = 040 if !defined($ISTRIP);
+ $INLCR = 0100 if !defined($INLCR);
+ $IGNCR = 0200 if !defined($IGNCR);
+ $ICRNL = 0400 if !defined($ICRNL);
+ $OPOST = 1 if !defined($OPOST);
+ $ISIG = 1 if !defined($ISIG);
+ $ICANON = 2 if !defined($ICANON);
+ $TCOON = 1 if !defined($TCOON);
+ $TERMIOS_READLINE_ION = $BRKINT;
+ $TERMIOS_READLINE_IOFF = $IGNBRK | $ISTRIP | $INLCR | $IGNCR | $ICRNL;
+ $TERMIOS_READLINE_OON = 0;
+ $TERMIOS_READLINE_OOFF = $OPOST;
+ $TERMIOS_READLINE_LON = 0;
+ $TERMIOS_READLINE_LOFF = $ISIG | $ICANON | $ECHO;
+ $TERMIOS_NORMAL_ION = $BRKINT;
+ $TERMIOS_NORMAL_IOFF = $IGNBRK;
+ $TERMIOS_NORMAL_OON = $OPOST;
+ $TERMIOS_NORMAL_OOFF = 0;
+ $TERMIOS_NORMAL_LON = $ISIG | $ICANON | $ECHO;
+ $TERMIOS_NORMAL_LOFF = 0;
+
+ #$sgttyb_t = 'C4 S';
+ #$winsz_t = "S S S S"; # rows,cols, xpixel, ypixel
+ $sgttyb_t = 'C4 S' if !defined($sgttyb_t);
+ $winsz_t = "S S S S" if !defined($winsz_t);
+ # rows,cols, xpixel, ypixel
+ $winsz = pack($winsz_t,0,0,0,0);
+ $fionread_t = "L";
+ $fion = pack($fionread_t, 0);
+ $NCCS = 17;
+ $termios_t = "LLLLc" . ("c" x $NCCS); # true for SunOS 4.1.3, at least...
+ $termios = ''; ## just to shut up "perl -w".
+ $termios = pack($termios, 0); # who cares, just make it long enough
+ $TERMIOS_IFLAG = 0;
+ $TERMIOS_OFLAG = 1;
+ $TERMIOS_CFLAG = 2;
+ $TERMIOS_LFLAG = 3;
+ $TERMIOS_VMIN = 5 + 4;
+ $TERMIOS_VTIME = 5 + 5;
+ }
+ $rl_delete_selection = 1;
+ $rl_correct_sw = ($inDOS ? 1 : 0);
+ $rl_scroll_nextline = 1 unless defined $rl_scroll_nextline;
+ $rl_last_pos_can_backspace = ($inDOS ? 0 : 1) # Can backspace when the
+ unless defined $rl_last_pos_can_backspace; # whole line is filled?
+
+ $rl_start_default_at_beginning = 0;
+ $rl_vi_replace_default_on_insert = 0;
+ $rl_screen_width = 79; ## default
+
+ $rl_completion_function = "rl_filename_list"
+ unless defined($rl_completion_function);
+ $rl_basic_word_break_characters = "\\\t\n' \"`\@\$><=;|&{(";
+ $rl_completer_word_break_characters = $rl_basic_word_break_characters;
+ $rl_special_prefixes = '';
+ ($rl_readline_name = $0) =~ s#.*[/\\]## if !defined($rl_readline_name);
+
+ @rl_History=() if !(@rl_History);
+ $rl_MaxHistorySize = 100 if !defined($rl_MaxHistorySize);
+ $rl_max_numeric_arg = 200 if !defined($rl_max_numeric_arg);
+ $rl_OperateCount = 0 if !defined($rl_OperateCount);
+
+ $rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
+ @$rl_term_set or $rl_term_set = ["","","",""];
+
+ $InsertMode=1;
+ $KillBuffer='';
+ $line='';
+ $D = 0;
+ $InputLocMsg = ' [initialization]';
+
+ &InitKeymap(*emacs_keymap, 'SelfInsert', 'emacs_keymap',
+ ($inDOS ? () : ('C-@', 'SetMark') ),
+ 'C-a', 'BeginningOfLine',
+ 'C-b', 'BackwardChar',
+ 'C-c', 'Interrupt',
+ 'C-d', 'DeleteChar',
+ 'C-e', 'EndOfLine',
+ 'C-f', 'ForwardChar',
+ 'C-g', 'Abort',
+ 'M-C-g', 'Abort',
+ 'C-h', 'BackwardDeleteChar',
+ "TAB" , 'Complete',
+ "C-j" , 'AcceptLine',
+ 'C-k', 'KillLine',
+ 'C-l', 'ClearScreen',
+ "C-m" , 'AcceptLine',
+ 'C-n', 'NextHistory',
+ 'C-o', 'OperateAndGetNext',
+ 'C-p', 'PreviousHistory',
+ 'C-q', 'QuotedInsert',
+ 'C-r', 'ReverseSearchHistory',
+ 'C-s', 'ForwardSearchHistory',
+ 'C-t', 'TransposeChars',
+ 'C-u', 'UnixLineDiscard',
+ ##'C-v', 'QuotedInsert',
+ 'C-v', 'HistorySearchForward',
+ 'C-w', 'UnixWordRubout',
+ qq/"\cX\cX"/, 'ExchangePointAndMark',
+ qq/"\cX\cR"/, 'ReReadInitFile',
+ qq/"\cX?"/, 'PossibleCompletions',
+ qq/"\cX*"/, 'InsertPossibleCompletions',
+ qq/"\cX\cU"/, 'Undo',
+ qq/"\cXu"/, 'Undo',
+ qq/"\cX\cW"/, 'KillRegion',
+ qq/"\cXw"/, 'CopyRegionAsKill',
+ qq/"\cX\ec\\*"/, 'DoControlVersion',
+ qq/"\cX\ec\0"/, 'SetMark',
+ qq/"\cX\ec\@"/, 'SetMark',
+ qq/"\cX\ec "/, 'SetMark',
+ qq/"\cX\em\\*"/, 'DoMetaVersion',
+ qq/"\cX\@c\\*"/, 'DoControlVersion',
+ qq/"\cX\@c\0"/, 'SetMark',
+ qq/"\cX\@c\@"/, 'SetMark',
+ qq/"\cX\@c "/, 'SetMark',
+ qq/"\cX\@m\\*"/, 'DoMetaVersion',
+ 'C-y', 'Yank',
+ 'C-z', 'Suspend',
+ 'C-\\', 'Ding',
+ 'C-^', 'Ding',
+ 'C-_', 'Undo',
+ 'DEL', ($inDOS ?
+ 'BackwardKillWord' : # <Control>+<Backspace>
+ 'BackwardDeleteChar'
+ ),
+ 'M-<', 'BeginningOfHistory',
+ 'M->', 'EndOfHistory',
+ 'M-DEL', 'BackwardKillWord',
+ 'M-C-h', 'BackwardKillWord',
+ 'M-C-j', 'ViInput',
+ 'M-C-v', 'QuotedInsert',
+ 'M-b', 'BackwardWord',
+ 'M-c', 'CapitalizeWord',
+ 'M-d', 'KillWord',
+ 'M-f', 'ForwardWord',
+ 'M-h', 'PrintHistory',
+ 'M-l', 'DownCaseWord',
+ 'M-r', 'RevertLine',
+ 'M-t', 'TransposeWords',
+ 'M-u', 'UpcaseWord',
+ 'M-v', 'HistorySearchBackward',
+ 'M-y', 'YankPop',
+ "M-?", 'PossibleCompletions',
+ "M-TAB", 'TabInsert',
+ 'M-#', 'SaveLine',
+ qq/"\e[A"/, 'previous-history',
+ qq/"\e[B"/, 'next-history',
+ qq/"\e[C"/, 'forward-char',
+ qq/"\e[D"/, 'backward-char',
+ qq/"\eOA"/, 'previous-history',
+ qq/"\eOB"/, 'next-history',
+ qq/"\eOC"/, 'forward-char',
+ qq/"\eOD"/, 'backward-char',
+ qq/"\eOy"/, 'HistorySearchBackward', # vt: PageUp
+ qq/"\eOs"/, 'HistorySearchForward', # vt: PageDown
+ qq/"\e[[A"/, 'previous-history',
+ qq/"\e[[B"/, 'next-history',
+ qq/"\e[[C"/, 'forward-char',
+ qq/"\e[[D"/, 'backward-char',
+ qq/"\e[2~"/, 'ToggleInsertMode', # X: <Insert>
+ # Mods: 1 + bitmask: 1 Shift, 2 Alt, 4 Control, 8 (sometimes) Meta
+ qq/"\e[2;2~"/, 'YankClipboard', # <Shift>+<Insert>
+ qq/"\e[3;2~"/, 'KillRegionClipboard', # <Shift>+<Delete>
+ #qq/"\0\16"/, 'Undo', # <Alt>+<Backspace>
+ qq/"\eO5D"/, 'BackwardWord', # <Ctrl>+<Left arrow>
+ qq/"\eO5C"/, 'ForwardWord', # <Ctrl>+<Right arrow>
+ qq/"\e[5D"/, 'BackwardWord', # <Ctrl>+<Left arrow>
+ qq/"\e[5C"/, 'ForwardWord', # <Ctrl>+<Right arrow>
+ qq/"\eO5F"/, 'KillLine', # <Ctrl>+<End>
+ qq/"\e[5F"/, 'KillLine', # <Ctrl>+<End>
+ qq/"\e[4;5~"/, 'KillLine', # <Ctrl>+<End>
+ qq/"\eO5s"/, 'EndOfHistory', # <Ctrl>+<Page Down>
+ qq/"\e[6;5~"/, 'EndOfHistory', # <Ctrl>+<Page Down>
+ qq/"\e[5H"/, 'BackwardKillLine', # <Ctrl>+<Home>
+ qq/"\eO5H"/, 'BackwardKillLine', # <Ctrl>+<Home>
+ qq/"\e[1;5~"/, 'BackwardKillLine', # <Ctrl>+<Home>
+ qq/"\eO5y"/, 'BeginningOfHistory', # <Ctrl>+<Page Up>
+ qq/"\e[5;5y"/, 'BeginningOfHistory', # <Ctrl>+<Page Up>
+ qq/"\e[2;5~"/, 'CopyRegionAsKillClipboard', # <Ctrl>+<Insert>
+ qq/"\e[3;5~"/, 'KillWord', # <Ctrl>+<Delete>
+
+ # XTerm mouse editing (f202/f203 not in mainstream yet):
+ # Paste may be: move f200 STRING f201
+ # or f202 move f200 STRING f201 f203;
+ # and Cut may be f202 move delete f203
+ qq/"\e[200~"/, 'BeginPasteGroup', # Pre-paste
+ qq/"\e[201~"/, 'EndPasteGroup', # Post-paste
+ qq/"\e[202~"/, 'BeginEditGroup', # Pre-edit
+ qq/"\e[203~"/, 'EndEditGroup', # Post-edit
+
+ # OSX xterm:
+ # OSX xterm: home \eOH end \eOF delete \e[3~ help \e[28~ f13 \e[25~
+ # gray- \eOm gray+ \eOk gray-enter \eOM gray* \eOj gray/ \eOo gray= \eO
+ # grayClear \e\e.
+
+ qq/"\eOH"/, 'BeginningOfLine', # home
+ qq/"\eOF"/, 'EndOfLine', # end
+
+ # HP xterm
+ #qq/"\e[A"/, 'PreviousHistory', # up arrow
+ #qq/"\e[B"/, 'NextHistory', # down arrow
+ #qq/"\e[C"/, 'ForwardChar', # right arrow
+ #qq/"\e[D"/, 'BackwardChar', # left arrow
+ qq/"\e[H"/, 'BeginningOfLine', # home
+ #'C-k', 'KillLine', # clear display
+ qq/"\e[5~"/, 'HistorySearchBackward', # prev
+ qq/"\e[6~"/, 'HistorySearchForward', # next
+ qq/"\e[\0"/, 'BeginningOfLine', # home
+
+ # These contradict:
+ ($^O =~ /^hp\W?ux/i ? (
+ qq/"\e[1~"/, 'HistorySearchForward', # find
+ qq/"\e[3~"/, 'ToggleInsertMode', # insert char
+ qq/"\e[4~"/, 'ToggleInsertMode', # select
+ ) : ( # "Normal" xterm
+ qq/"\e[1~"/, 'BeginningOfLine', # home
+ qq/"\e[3~"/, 'DeleteChar', # delete
+ qq/"\e[4~"/, 'EndOfLine', # end
+ )),
+
+ # hpterm
+
+ (($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ?
+ (
+ qq/"\eA"/, 'PreviousHistory', # up arrow
+ qq/"\eB"/, 'NextHistory', # down arrow
+ qq/"\eC"/, 'ForwardChar', # right arrow
+ qq/"\eD"/, 'BackwardChar', # left arrow
+ qq/"\eS"/, 'BeginningOfHistory', # shift up arrow
+ qq/"\eT"/, 'EndOfHistory', # shift down arrow
+ qq/"\e&r1R"/, 'EndOfLine', # shift right arrow
+ qq/"\e&r1L"/, 'BeginningOfLine', # shift left arrow
+ qq/"\eJ"/, 'ClearScreen', # clear display
+ qq/"\eM"/, 'UnixLineDiscard', # delete line
+ qq/"\eK"/, 'KillLine', # clear line
+ qq/"\eG\eK"/, 'BackwardKillLine', # shift clear line
+ qq/"\eP"/, 'DeleteChar', # delete char
+ qq/"\eL"/, 'Yank', # insert line
+ qq/"\eQ"/, 'ToggleInsertMode', # insert char
+ qq/"\eV"/, 'HistorySearchBackward',# prev
+ qq/"\eU"/, 'HistorySearchForward',# next
+ qq/"\eh"/, 'BeginningOfLine', # home
+ qq/"\eF"/, 'EndOfLine', # shift home
+ qq/"\ei"/, 'Suspend', # shift tab
+ ) :
+ ()
+ ),
+ ($inDOS ?
+ (
+ qq/"\0\2"/, 'SetMark', # 2: <Control>+<Space>
+ qq/"\0\3"/, 'SetMark', # 3: <Control>+<@>
+ qq/"\0\4"/, 'YankClipboard', # 4: <Shift>+<Insert>
+ qq/"\0\5"/, 'KillRegionClipboard', # 5: <Shift>+<Delete>
+ qq/"\0\16"/, 'Undo', # 14: <Alt>+<Backspace>
+# qq/"\0\23"/, 'RevertLine', # 19: <Alt>+<R>
+# qq/"\0\24"/, 'TransposeWords', # 20: <Alt>+<T>
+# qq/"\0\25"/, 'YankPop', # 21: <Alt>+<Y>
+# qq/"\0\26"/, 'UpcaseWord', # 22: <Alt>+<U>
+# qq/"\0\31"/, 'ReverseSearchHistory', # 25: <Alt>+<P>
+# qq/"\0\40"/, 'KillWord', # 32: <Alt>+<D>
+# qq/"\0\41"/, 'ForwardWord', # 33: <Alt>+<F>
+# qq/"\0\46"/, 'DownCaseWord', # 38: <Alt>+<L>
+ #qq/"\0\51"/, 'TildeExpand', # 41: <Alt>+<\'>
+# qq/"\0\56"/, 'CapitalizeWord', # 46: <Alt>+<C>
+# qq/"\0\60"/, 'BackwardWord', # 48: <Alt>+<B>
+# qq/"\0\61"/, 'ForwardSearchHistory', # 49: <Alt>+<N>
+ #qq/"\0\64"/, 'YankLastArg', # 52: <Alt>+<.>
+ qq/"\0\65"/, 'PossibleCompletions', # 53: <Alt>+</>
+ qq/"\0\107"/, 'BeginningOfLine', # 71: <Home>
+ qq/"\0\110"/, 'previous-history', # 72: <Up arrow>
+ qq/"\0\111"/, 'HistorySearchBackward', # 73: <Page Up>
+ qq/"\0\113"/, 'backward-char', # 75: <Left arrow>
+ qq/"\0\115"/, 'forward-char', # 77: <Right arrow>
+ qq/"\0\117"/, 'EndOfLine', # 79: <End>
+ qq/"\0\120"/, 'next-history', # 80: <Down arrow>
+ qq/"\0\121"/, 'HistorySearchForward', # 81: <Page Down>
+ qq/"\0\122"/, 'ToggleInsertMode', # 82: <Insert>
+ qq/"\0\123"/, 'DeleteChar', # 83: <Delete>
+ qq/"\0\163"/, 'BackwardWord', # 115: <Ctrl>+<Left arrow>
+ qq/"\0\164"/, 'ForwardWord', # 116: <Ctrl>+<Right arrow>
+ qq/"\0\165"/, 'KillLine', # 117: <Ctrl>+<End>
+ qq/"\0\166"/, 'EndOfHistory', # 118: <Ctrl>+<Page Down>
+ qq/"\0\167"/, 'BackwardKillLine', # 119: <Ctrl>+<Home>
+ qq/"\0\204"/, 'BeginningOfHistory', # 132: <Ctrl>+<Page Up>
+ qq/"\0\x92"/, 'CopyRegionAsKillClipboard', # 146: <Ctrl>+<Insert>
+ qq/"\0\223"/, 'KillWord', # 147: <Ctrl>+<Delete>
+ qq/"\0#"/, 'PrintHistory', # Alt-H
+ )
+ : ( 'C-@', 'Ding')
+ )
+ );
+
+ *KeyMap = *emacs_keymap;
+ my @add_bindings = ();
+ foreach ('-', '0' .. '9') { push(@add_bindings, "M-$_", 'DigitArgument'); }
+ foreach ("A" .. "Z") {
+ next if # defined($KeyMap[27]) && defined (%{"$KeyMap{name}_27"}) &&
+ defined $ {"$KeyMap{name}_27"}[ord $_];
+ push(@add_bindings, "M-$_", 'DoLowercaseVersion');
+ }
+ if ($inDOS) {
+ # Default translation of Alt-char
+ $ {"$KeyMap{name}_0"}{'Esc'} = *{"$KeyMap{name}_27"};
+ $ {"$KeyMap{name}_0"}{'default'} = 'F_DoEscVersion';
+ }
+ &rl_bind(@add_bindings);
+
+ # Vi input mode.
+ &InitKeymap(*vi_keymap, 'SelfInsert', 'vi_keymap',
+
+ "\e", 'ViEndInsert',
+ 'C-c', 'Interrupt',
+ 'C-h', 'BackwardDeleteChar',
+ 'C-w', 'UnixWordRubout',
+ 'C-u', 'UnixLineDiscard',
+ 'C-v', 'QuotedInsert',
+ 'DEL', 'BackwardDeleteChar',
+ "\n", 'ViAcceptInsert',
+ "\r", 'ViAcceptInsert',
+ );
+
+ # Vi command mode.
+ &InitKeymap(*vicmd_keymap, 'Ding', 'vicmd_keymap',
+
+ 'C-c', 'Interrupt',
+ 'C-e', 'EmacsEditingMode',
+ 'C-h', 'ViMoveCursor',
+ 'C-l', 'ClearScreen',
+ "\n", 'ViAcceptLine',
+ "\r", 'ViAcceptLine',
+
+ ' ', 'ViMoveCursor',
+ '#', 'SaveLine',
+ '$', 'ViMoveCursor',
+ '%', 'ViMoveCursor',
+ '*', 'ViInsertPossibleCompletions',
+ '+', 'NextHistory',
+ ',', 'ViMoveCursor',
+ '-', 'PreviousHistory',
+ '.', 'ViRepeatLastCommand',
+ '/', 'ViSearch',
+
+ '0', 'ViMoveCursor',
+ '1', 'ViDigit',
+ '2', 'ViDigit',
+ '3', 'ViDigit',
+ '4', 'ViDigit',
+ '5', 'ViDigit',
+ '6', 'ViDigit',
+ '7', 'ViDigit',
+ '8', 'ViDigit',
+ '9', 'ViDigit',
+
+ ';', 'ViMoveCursor',
+ '=', 'ViPossibleCompletions',
+ '?', 'ViSearch',
+
+ 'A', 'ViAppendLine',
+ 'B', 'ViMoveCursor',
+ 'C', 'ViChangeLine',
+ 'D', 'ViDeleteLine',
+ 'E', 'ViMoveCursor',
+ 'F', 'ViMoveCursor',
+ 'G', 'ViHistoryLine',
+ 'H', 'PrintHistory',
+ 'I', 'ViBeginInput',
+ 'N', 'ViRepeatSearch',
+ 'P', 'ViPutBefore',
+ 'R', 'ViReplaceMode',
+ 'S', 'ViChangeEntireLine',
+ 'T', 'ViMoveCursor',
+ 'U', 'ViUndoAll',
+ 'W', 'ViMoveCursor',
+ 'X', 'ViBackwardDeleteChar',
+ 'Y', 'ViYankLine',
+
+ '\\', 'ViComplete',
+ '^', 'ViMoveCursor',
+
+ 'a', 'ViAppend',
+ 'b', 'ViMoveCursor',
+ 'c', 'ViChange',
+ 'd', 'ViDelete',
+ 'e', 'ViMoveCursor',
+ 'f', 'ViMoveCursorFind',
+ 'h', 'ViMoveCursor',
+ 'i', 'ViInput',
+ 'j', 'NextHistory',
+ 'k', 'PreviousHistory',
+ 'l', 'ViMoveCursor',
+ 'n', 'ViRepeatSearch',
+ 'p', 'ViPut',
+ 'r', 'ViReplaceChar',
+ 's', 'ViChangeChar',
+ 't', 'ViMoveCursorTo',
+ 'u', 'ViUndo',
+ 'w', 'ViMoveCursor',
+ 'x', 'ViDeleteChar',
+ 'y', 'ViYank',
+
+ '|', 'ViMoveCursor',
+ '~', 'ViToggleCase',
+
+ (($inDOS
+ and (not $ENV{'TERM'} or $ENV{'TERM'} !~ /^(vt|xterm)/i)) ?
+ (
+ qq/"\0\110"/, 'PreviousHistory', # 72: <Up arrow>
+ qq/"\0\120"/, 'NextHistory', # 80: <Down arrow>
+ qq/"\0\113"/, 'BackwardChar', # 75: <Left arrow>
+ qq/"\0\115"/, 'ForwardChar', # 77: <Right arrow>
+ "\e", 'ViCommandMode',
+ ) :
+
+ (('M-C-j','EmacsEditingMode'), # Conflicts with \e otherwise
+ (($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ?
+ (
+ qq/"\eA"/, 'PreviousHistory', # up arrow
+ qq/"\eB"/, 'NextHistory', # down arrow
+ qq/"\eC"/, 'ForwardChar', # right arrow
+ qq/"\eD"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViAfterEsc',
+ ) :
+
+ # Default
+ (
+ qq/"\e[A"/, 'PreviousHistory', # up arrow
+ qq/"\e[B"/, 'NextHistory', # down arrow
+ qq/"\e[C"/, 'ForwardChar', # right arrow
+ qq/"\e[D"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViAfterEsc',
+ qq/"\e[\\*"/, 'ViAfterEsc',
+ )
+ ))),
+ );
+
+ # Vi positioning commands (suffixed to vi commands like 'd').
+ &InitKeymap(*vipos_keymap, 'ViNonPosition', 'vipos_keymap',
+
+ '^', 'ViFirstWord',
+ '0', 'BeginningOfLine',
+ '1', 'ViDigit',
+ '2', 'ViDigit',
+ '3', 'ViDigit',
+ '4', 'ViDigit',
+ '5', 'ViDigit',
+ '6', 'ViDigit',
+ '7', 'ViDigit',
+ '8', 'ViDigit',
+ '9', 'ViDigit',
+ '$', 'EndOfLine',
+ 'h', 'BackwardChar',
+ 'l', 'ForwardChar',
+ ' ', 'ForwardChar',
+ 'C-h', 'BackwardChar',
+ 'f', 'ViForwardFindChar',
+ 'F', 'ViBackwardFindChar',
+ 't', 'ViForwardToChar',
+ 'T', 'ViBackwardToChar',
+ ';', 'ViRepeatFindChar',
+ ',', 'ViInverseRepeatFindChar',
+ '%', 'ViFindMatchingParens',
+ '|', 'ViMoveToColumn',
+
+ # Arrow keys
+ ($inDOS ?
+ (
+ qq/"\0\115"/, 'ForwardChar', # 77: <Right arrow>
+ qq/"\0\113"/, 'BackwardChar', # 75: <Left arrow>
+ "\e", 'ViPositionEsc',
+ ) :
+
+ ($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ?
+ (
+ qq/"\eC"/, 'ForwardChar', # right arrow
+ qq/"\eD"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViPositionEsc',
+ ) :
+
+ # Default
+ (
+ qq/"\e[C"/, 'ForwardChar', # right arrow
+ qq/"\e[D"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViPositionEsc',
+ qq/"\e[\\*"/, 'ViPositionEsc',
+ )
+ ),
+ );
+
+ # Vi search string input mode for '/' and '?'.
+ &InitKeymap(*visearch_keymap, 'SelfInsert', 'visearch_keymap',
+
+ "\e", 'Ding',
+ 'C-c', 'Interrupt',
+ 'C-h', 'ViSearchBackwardDeleteChar',
+ 'C-w', 'UnixWordRubout',
+ 'C-u', 'UnixLineDiscard',
+ 'C-v', 'QuotedInsert',
+ 'DEL', 'ViSearchBackwardDeleteChar',
+ "\n", 'ViEndSearch',
+ "\r", 'ViEndSearch',
+ );
+
+ # These constant hashes hold the arguments to &forward_scan() or
+ # &backward_scan() for vi positioning commands, which all
+ # behave a little differently for delete, move, change, and yank.
+ #
+ # Note: I originally coded these as qr{}, but changed them to q{} for
+ # compatibility with older perls at the expense of some performance.
+ #
+ # Note: Some of the more obscure key combinations behave slightly
+ # differently in different vi implementation. This module matches
+ # the behavior of /usr/ucb/vi, which is different from the
+ # behavior of vim, nvi, and the ksh command line. One example is
+ # the command '2de', when applied to the string ('^' represents the
+ # cursor, not a character of the string):
+ #
+ # ^5.6 7...88888888
+ #
+ # With /usr/ucb/vi and with this module, the result is
+ #
+ # ^...88888888
+ #
+ # but with the other three vi implementations, the result is
+ #
+ # ^ 7...88888888
+
+ $Vi_delete_patterns = {
+ ord('w') => q{(?:\w+|[^\w\s]+|)\s*},
+ ord('W') => q{\S*\s*},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w+|.\s*[^\w\s]+|.\s*$},
+ ord('E') => q{.\s*\S+|.\s*$},
+ };
+
+ $Vi_move_patterns = {
+ ord('w') => q{(?:\w+|[^\w\s]+|)\s*},
+ ord('W') => q{\S*\s*},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w*(?=\w)|.\s*[^\w\s]*(?=[^\w\s])|.?\s*(?=\s$)},
+ ord('E') => q{.\s*\S*(?=\S)|.?\s*(?=\s$)},
+ };
+
+ $Vi_change_patterns = {
+ ord('w') => q{\w+|[^\w\s]+|\s},
+ ord('W') => q{\S+|\s},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w+|.\s*[^\w\s]+|.\s*$},
+ ord('E') => q{.\s*\S+|.\s*$},
+ };
+
+ $Vi_yank_patterns = {
+ ord('w') => q{(?:\w+|[^\w\s]+|)\s*},
+ ord('W') => q{\S*\s*},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w*(?=\w)|.\s*[^\w\s]*(?=[^\w\s])|.?\s*(?=\s$)},
+ ord('E') => q{.\s*\S*(?=\S)|.?\s*(?=\s$)},
+ };
+
+ my $default_mode = 'emacs';
+
+ *KeyMap = $var_EditingMode = $var_EditingMode{$default_mode};
+
+## my $name;
+## for $name ( keys %{'readline::'} ) {
+## # Create aliases accessible via tied interface
+## *{"rl_$1"} = \$ {"var_$1"} if $name =~ /$var_(.*)/;
+## }
+
+ 1; # Returning a glob causes a bug in db5.001m
+}
+
+sub init
+{
+ if ($ENV{'TERM'} and ($ENV{'TERM'} eq 'emacs' || $ENV{'TERM'} eq 'dumb')) {
+ $dumb_term = 1;
+ } elsif (! -c $term_IN && $term_IN eq \*STDIN) { # Believe if it is given
+ $stdin_not_tty = 1;
+ } else {
+ &get_window_size;
+ &F_ReReadInitFile if !defined($rl_NoInitFromFile);
+ $InputLocMsg = '';
+ *KeyMap = $var_EditingMode;
+ }
+
+ $initialized = 1;
+}
+
+
+##
+## InitKeymap(*keymap, 'default', 'name', bindings.....)
+##
+sub InitKeymap
+{
+ local(*KeyMap) = shift(@_);
+ my $default = shift(@_);
+ my $name = $KeyMap{'name'} = shift(@_);
+
+ # 'default' is now optional - if '', &do_command() defaults it to
+ # 'F_Ding'. Meta-maps now don't set a default - this lets
+ # us detect multiple '\*' default declarations. JP
+ if ($default ne '') {
+ my $func = $KeyMap{'default'} = "F_$default";
+ ### Temporarily disabled
+ die qq/Bad default function [$func] for keymap "$name"/
+ if !$autoload_broken and !defined(&$func);
+ }
+
+ &rl_bind if @_ > 0; ## The rest of @_ gets passed silently.
+}
+
+##
+## Accepts an array as pairs ($keyspec, $function, [$keyspec, $function]...).
+## and maps the associated bindings to the current KeyMap.
+##
+## keyspec should be the name of key sequence in one of two forms:
+##
+## Old (GNU readline documented) form:
+## M-x to indicate Meta-x
+## C-x to indicate Ctrl-x
+## M-C-x to indicate Meta-Ctrl-x
+## x simple char x
+## where 'x' above can be a single character, or the special:
+## special means
+## -------- -----
+## space space ( )
+## spc space ( )
+## tab tab (\t)
+## del delete (0x7f)
+## rubout delete (0x7f)
+## newline newline (\n)
+## lfd newline (\n)
+## ret return (\r)
+## return return (\r)
+## escape escape (\e)
+## esc escape (\e)
+##
+## New form:
+## "chars" (note the required double-quotes)
+## where each char in the list represents a character in the sequence, except
+## for the special sequences:
+## \\C-x Ctrl-x
+## \\M-x Meta-x
+## \\M-C-x Meta-Ctrl-x
+## \\e escape.
+## \\x x (if not one of the above)
+##
+##
+## FUNCTION should be in the form 'BeginningOfLine' or 'beginning-of-line'.
+## It is an error for the function to not be known....
+##
+## As an example, the following lines in .inputrc will bind one's xterm
+## arrow keys:
+## "\e[[A": previous-history
+## "\e[[B": next-history
+## "\e[[C": forward-char
+## "\e[[D": backward-char
+##
+
+sub filler_Pending ($) {
+ my $keys = shift;
+ sub {
+ my $c = shift;
+ push @Pending, map chr, @$keys;
+ return if not @$keys or $c == 1 or not defined(my $in = &getc_with_pending);
+ # provide the numeric argument
+ local(*KeyMap) = $var_EditingMode;
+ $doingNumArg = 1; # Allow NumArg inside NumArg
+ &do_command(*KeyMap, $c, ord $in);
+ return;
+ }
+}
+
+sub _unescape ($) {
+ my($key, @keys) = shift;
+ ## New-style bindings are enclosed in double-quotes.
+ ## Characters are taken verbatim except the special cases:
+ ## \C-x Control x (for any x)
+ ## \M-x Meta x (for any x)
+ ## \e Escape
+ ## \* Set the keymap default (JP: added this)
+ ## (must be the last character of the sequence)
+ ##
+ ## \x x (unless it fits the above pattern)
+ ##
+ ## Look for special case of "\C-\M-x", which should be treated
+ ## like "\M-\C-x".
+
+ while (length($key) > 0) {
+
+ # JP: fixed regex bugs below: changed all 's#' to 's#^'
+
+ if ($key =~ s#^\\C-\\M-(.)##) {
+ push(@keys, ord("\e"), &ctrl(ord($1)));
+ } elsif ($key =~ s#^\\(M-|e)##) {
+ push(@keys, ord("\e"));
+ } elsif ($key =~ s#^\\C-(.)##) {
+ push(@keys, &ctrl(ord($1)));
+ } elsif ($key =~ s#^\\x([0-9a-fA-F]{2})##) {
+ push(@keys, eval('0x'.$1));
+ } elsif ($key =~ s#^\\([0-7]{3})##) {
+ push(@keys, eval('0'.$1));
+ } elsif ($key =~ s#^\\\*$##) { # JP: added
+ push(@keys, 'default');
+ } elsif ($key =~ s#^\\([afnrtv])##) {
+ push(@keys, ord(eval(qq("\\$1"))));
+ } elsif ($key =~ s#^\\d##) {
+ push(@keys, 4); # C-d
+ } elsif ($key =~ s#^\\b##) {
+ push(@keys, 0x7f); # Backspace
+ } elsif ($key =~ s#^\\(.)##) {
+ push(@keys, ord($1));
+ } else {
+ push(@keys, ord($key));
+ substr($key,0,1) = '';
+ }
+ }
+ @keys
+}
+
+sub RL_func ($) {
+ my $name_or_macro = shift;
+ if ($name_or_macro =~ /^"((?:\\.|[^\\\"])*)"|^'((?:\\.|[^\\\'])*)'/s) {
+ filler_Pending [_unescape "$+"];
+ } else {
+ "F_$name_or_macro";
+ }
+}
+
+sub actually_do_binding
+{
+ ##
+ ## actually_do_binding($function1, \@sequence1, ...)
+ ##
+ ## Actually inserts the binding for @sequence to $function into the
+ ## current map. @sequence is an array of character ordinals.
+ ##
+ ## If @sequence is more than one element long, all but the last will
+ ## cause meta maps to be created.
+ ##
+ ## $Function will have an implicit "F_" prepended to it.
+ ##
+ while (@_) {
+ my $func = shift;
+ my ($key, @keys) = @{shift()};
+ $key += 0;
+ local(*KeyMap) = *KeyMap;
+ my $map;
+ while (@keys) {
+ if (defined($KeyMap[$key]) && ($KeyMap[$key] ne 'F_PrefixMeta')) {
+ warn "Warning$InputLocMsg: ".
+ "Re-binding char #$key from [$KeyMap[$key]] to meta for [@keys] => $func.\n" if $^W;
+ }
+ $KeyMap[$key] = 'F_PrefixMeta';
+ $map = "$KeyMap{'name'}_$key";
+ InitKeymap(*$map, '', $map) if !(%$map);
+ *KeyMap = *$map;
+ $key = shift @keys;
+ #&actually_do_binding($func, \@keys);
+ }
+
+ my $name = $KeyMap{'name'};
+ if ($key eq 'default') { # JP: added
+ warn "Warning$InputLocMsg: ".
+ " changing default action to $func in $name key map\n"
+ if $^W && defined $KeyMap{'default'};
+
+ $KeyMap{'default'} = RL_func $func;
+ }
+ else {
+ if (defined($KeyMap[$key]) && $KeyMap[$key] eq 'F_PrefixMeta'
+ && $func ne 'PrefixMeta')
+ {
+ warn "Warning$InputLocMsg: ".
+ " Re-binding char #$key to non-meta ($func) in $name key map\n"
+ if $^W;
+ }
+ $KeyMap[$key] = RL_func $func;
+ }
+ }
+}
+
+sub rl_bind
+{
+ my (@keys, $key, $func, $ord, @arr);
+
+ while (defined($key = shift(@_)) && defined($func = shift(@_)))
+ {
+ ##
+ ## Change the function name from something like
+ ## backward-kill-line
+ ## to
+ ## BackwardKillLine
+ ## if not already there.
+ ##
+ unless ($func =~ /^[\"\']/) {
+ $func = "\u$func";
+ $func =~ s/-(.)/\u$1/g;
+
+ # Temporary disabled
+ if (!$autoload_broken and !defined($ {'readline::'}{"F_$func"})) {
+ warn "Warning$InputLocMsg: bad bind function [$func]\n" if $^W;
+ next;
+ }
+ }
+
+ ## print "sequence [$key] func [$func]\n"; ##DEBUG
+
+ @keys = ();
+ ## See if it's a new-style binding.
+ if ($key =~ m/"((?:\\.|[^\\])*)"/s) {
+ @keys = _unescape "$1";
+ } else {
+ ## ol-dstyle binding... only one key (or Meta+key)
+ my ($isctrl, $orig) = (0, $key);
+ $isctrl = $key =~ s/\b(C|Control|CTRL)-//i;
+ push(@keys, ord("\e")) if $key =~ s/\b(M|Meta)-//i; ## is meta?
+ ## Isolate key part. This matches GNU's implementation.
+ ## If the key is '-', be careful not to delete it!
+ $key =~ s/.*-(.)/$1/;
+ if ($key =~ /^(space|spc)$/i) { $key = ' '; }
+ elsif ($key =~ /^(rubout|del)$/i) { $key = "\x7f"; }
+ elsif ($key =~ /^tab$/i) { $key = "\t"; }
+ elsif ($key =~ /^(return|ret)$/i) { $key = "\r"; }
+ elsif ($key =~ /^(newline|lfd)$/i) { $key = "\n"; }
+ elsif ($key =~ /^(escape|esc)$/i) { $key = "\e"; }
+ elsif (length($key) > 1) {
+ warn "Warning$InputLocMsg: strange binding [$orig]\n" if $^W;
+ }
+ $key = ord($key);
+ $key = &ctrl($key) if $isctrl;
+ push(@keys, $key);
+ }
+
+ #
+ ## Now do the mapping of the sequence represented in @keys
+ #
+ # print "&actually_do_binding($func, @keys)\n"; ##DEBUG
+ push @arr, $func, [@keys];
+ #&actually_do_binding($func, \@keys);
+ }
+ &actually_do_binding(@arr);
+}
+
+sub read_an_init_file {
+ my $file = shift;
+ my $include_depth = shift;
+ local *RC;
+ $file =~ s/^~([\\\/])/$ENV{HOME}$1/ if not -f $file and exists $ENV{HOME};
+ return unless open RC, "< $file";
+ my (@action) = ('exec'); ## exec, skip, ignore (until appropriate endif)
+ my (@level) = (); ## if, else
+
+ local $/ = "\n";
+ while (<RC>) {
+ s/^\s+//;
+ next if m/^\s*(#|$)/;
+ $InputLocMsg = " [$file line $.]";
+ if (/^\$if\s+(.*)/) {
+ my($test) = $1;
+ push(@level, 'if');
+ if ($action[$#action] ne 'exec') {
+ ## We're supposed to be skipping or ignoring this level,
+ ## so for subsequent levels we really ignore completely.
+ push(@action, 'ignore');
+ } else {
+ ## We're executing this IF... do the test.
+ ## The test is either "term=xxxx", or just a string that
+ ## we compare to $rl_readline_name;
+ if ($test =~ /term=([a-z0-9]+)/) {
+ $test = ($ENV{'TERM'} && $1 eq $ENV{'TERM'});
+ } else {
+ $test = $test =~ /^(perl|$rl_readline_name)\s*$/i;
+ }
+ push(@action, $test ? 'exec' : 'skip');
+ }
+ next;
+ } elsif (/^\$endif\b/) {
+ die qq/\rWarning$InputLocMsg: unmatched endif\n/ if @level == 0;
+ pop(@level);
+ pop(@action);
+ next;
+ } elsif (/^\$else\b/) {
+ die qq/\rWarning$InputLocMsg: unmatched else\n/ if
+ @level == 0 || $level[$#level] ne 'if';
+ $level[$#level] = 'else'; ## an IF turns into an ELSE
+ if ($action[$#action] eq 'skip') {
+ $action[$#action] = 'exec'; ## if were SKIPing, now EXEC
+ } else {
+ $action[$#action] = 'ignore'; ## otherwise, just IGNORE.
+ }
+ next;
+ } elsif (/^\$include\s+(\S+)/) {
+ if ($include_depth > $max_include_depth) {
+ warn "Deep recursion in \$include directives in $file.\n";
+ } else {
+ read_an_init_file($1, $include_depth + 1);
+ }
+ } elsif ($action[$#action] ne 'exec') {
+ ## skipping this one....
+ # readline permits trailing comments in inputrc
+ # this seems to solve the warnings caused by trailing comments in the
+ # default /etc/inputrc on Mandrake Linux boxes.
+ } elsif (m/\s*set\s+(\S+)\s+(\S*)/) { # Allow trailing comment
+ &rl_set($1, $2, $file);
+ } elsif (m/^\s*(\S+):\s+("(?:\\.|[^\\\"])*"|'(\\.|[^\\\'])*')/) { # Allow trailing comment
+ &rl_bind($1, $2);
+ } elsif (m/^\s*(\S+|"[^\"]+"):\s+(\S+)/) { # Allow trailing comment
+ &rl_bind($1, $2);
+ } else {
+ chomp;
+ warn "\rWarning$InputLocMsg: Bad line [$_]\n" if $^W;
+ }
+ }
+ close(RC);
+}
+
+sub F_ReReadInitFile
+{
+ my ($file) = $ENV{'TRP_INPUTRC'};
+ $file = $ENV{'INPUTRC'} unless defined $file;
+ unless (defined $file) {
+ return unless defined $ENV{'HOME'};
+ $file = "$ENV{'HOME'}/.inputrc";
+ }
+ read_an_init_file($file, 0);
+}
+
+sub get_ornaments_selected {
+ return if @$rl_term_set >= 6;
+ local $^W=0;
+ my $Orig = $Term::ReadLine::Perl::term->ornaments();
+ eval {
+ # Term::ReadLine does not expose its $terminal, so make another
+ require Term::Cap;
+ my $terminal = Tgetent Term::Cap ({OSPEED=>9600});
+ # and be sure the terminal supports highlighting
+ $terminal->Trequire('mr');
+ };
+ if (!$@ and $Orig ne ',,,'){
+ my @set = @$rl_term_set;
+
+ $Term::ReadLine::Perl::term->ornaments
+ (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me') ;
+ @set[4,5] = @$rl_term_set[2,3];
+ $Term::ReadLine::Perl::term->ornaments($Orig);
+ @$rl_term_set = @set;
+ } else {
+ @$rl_term_set[4,5] = @$rl_term_set[2,3];
+ }
+}
+
+sub readline_dumb {
+ local $\ = '';
+ print $term_OUT $prompt;
+ local $/ = "\n";
+ return undef
+ if !defined($line = $Term::ReadLine::Perl::term->get_line);
+ chomp($line);
+ $| = $oldbar;
+ select $old;
+ return $line;
+}
+
+##
+## This is it. Called as &readline'readline($prompt, $default),
+## (DEFAULT can be omitted) the next input line is returned (undef on EOF).
+##
+sub readline
+{
+ $Term::ReadLine::Perl::term->register_Tk
+ if not $Term::ReadLine::registered and $Term::ReadLine::toloop
+ and defined &Tk::DoOneEvent;
+ if ($stdin_not_tty) {
+ local $/ = "\n";
+ return undef if !defined($line = <$term_IN>);
+ chomp($line);
+ return $line;
+ }
+
+ $old = select $term_OUT;
+ $oldbar = $|;
+ local($|) = 1;
+ local($input);
+
+ ## prompt should be given to us....
+ $prompt = defined($_[0]) ? $_[0] : 'INPUT> ';
+
+ # Try to move cursor to the beginning of the next line if this line
+ # contains anything.
+
+ # On DOSish 80-wide console
+ # perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 79
+ # prints 3 on the same line,
+ # perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 80
+ # on the next; $rl_screen_width is 79.
+
+ # on XTerm one needs to increase the number by 1.
+
+ print $term_OUT ' ' x ($rl_screen_width - !$rl_last_pos_can_backspace) . "\b \r"
+ if $rl_scroll_nextline;
+
+ if ($dumb_term) {
+ return readline_dumb;
+ }
+
+ # test if we resume an 'Operate' command
+ if ($rl_OperateCount > 0 && (!defined $_[1] || $_[1] eq '')) {
+ ## it's from a valid previous 'Operate' command and
+ ## user didn't give a default line
+ ## we leave $rl_HistoryIndex untouched
+ $line = $rl_History[$rl_HistoryIndex];
+ } else {
+ ## set history pointer at the end of history
+ $rl_HistoryIndex = $#rl_History + 1;
+ $rl_OperateCount = 0;
+ $line = defined $_[1] ? $_[1] : '';
+ }
+ $rl_OperateCount-- if $rl_OperateCount > 0;
+
+ $line_for_revert = $line;
+
+# I don't think we need to do this, actually...
+# while (&ioctl(STDIN,$FIONREAD,$fion))
+# {
+# local($n_chars_available) = unpack ($fionread_t, $fion);
+# ## print "n_chars = $n_chars_available\n";
+# last if $n_chars_available == 0;
+# $line .= getc_with_pending; # should we prepend if $rl_start_default_at_beginning?
+# }
+
+ $D = $rl_start_default_at_beginning ? 0 : length($line); ## set dot.
+ $LastCommandKilledText = 0; ## heck, was no last command.
+ $lastcommand = ''; ## Well, there you go.
+ $line_rl_mark = -1;
+
+ ##
+ ## some stuff for &redisplay.
+ ##
+ $lastredisplay = ''; ## Was no last redisplay for this time.
+ $lastlen = length($lastredisplay);
+ $lastpromptlen = 0;
+ $lastdelta = 0; ## Cursor was nowhere
+ $si = 0; ## Want line to start left-justified
+ $force_redraw = 1; ## Want to display with brute force.
+ if (!eval {SetTTY()}) { ## Put into raw mode.
+ warn $@ if $@;
+ $dumb_term = 1;
+ return readline_dumb;
+ }
+
+ *KeyMap = $var_EditingMode;
+ undef($AcceptLine); ## When set, will return its value.
+ undef($ReturnEOF); ## ...unless this on, then return undef.
+ @Pending = (); ## Contains characters to use as input.
+ @undo = (); ## Undo history starts empty for each line.
+ @undoGroupS = (); ## Undo groups start empty for each line.
+ undef $memorizedArg; ## No digitArgument memorized
+ undef $memorizedPos; ## No position memorized
+
+ undef $Vi_undo_state;
+ undef $Vi_undo_all_state;
+
+ # We need to do some additional initialization for vi mode.
+ # RS: bug reports/platform issues are welcome: russ@dvns.com
+ if ($KeyMap{'name'} eq 'vi_keymap'){
+ &F_ViInput();
+ if ($rl_vi_replace_default_on_insert){
+ local $^W=0;
+ my $Orig = $Term::ReadLine::Perl::term->ornaments();
+ eval {
+ # Term::ReadLine does not expose its $terminal, so make another
+ require Term::Cap;
+ my $terminal = Tgetent Term::Cap ({OSPEED=>9600});
+ # and be sure the terminal supports highlighting
+ $terminal->Trequire('mr');
+ };
+ if (!$@ and $Orig ne ',,,'){
+ $Term::ReadLine::Perl::term->ornaments
+ (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me')
+ }
+ my $F_SelfInsert_Real = \&F_SelfInsert;
+ *F_SelfInsert = sub {
+ $Term::ReadLine::Perl::term->ornaments($Orig);
+ &F_ViChangeEntireLine;
+ local $^W=0;
+ *F_SelfInsert = $F_SelfInsert_Real;
+ &F_SelfInsert;
+ };
+ my $F_ViEndInsert_Real = \&F_ViEndInsert;
+ *F_ViEndInsert = sub {
+ $Term::ReadLine::Perl::term->ornaments($Orig);
+ local $^W=0;
+ *F_SelfInsert = $F_SelfInsert_Real;
+ *F_ViEndInsert = $F_ViEndInsert_Real;
+ &F_ViEndInsert;
+ $force_redraw = 1;
+ redisplay();
+ };
+ }
+ }
+
+ if ($rl_default_selected) {
+ redisplay_high();
+ } else {
+ &redisplay(); ## Show the line (prompt+default at this point).
+ }
+
+ # pretend input if we 'Operate' on more than one line
+ &F_OperateAndGetNext($rl_OperateCount) if $rl_OperateCount > 0;
+
+ $rl_first_char = 1;
+ while (!defined($AcceptLine)) {
+ ## get a character of input
+ $input = &getc_with_pending(); # bug in debugger, returns 42. - No more!
+
+ unless (defined $input) {
+ # XXX What to do??? Until this is clear, just pretend we got EOF
+ $AcceptLine = $ReturnEOF = 1;
+ last;
+ }
+ preserve_state();
+
+ $ThisCommandKilledText = 0;
+ ##print "\n\rline is @$D:[$line]\n\r"; ##DEBUG
+ my $cmd = get_command($var_EditingMode, ord($input));
+ if ( $rl_first_char && $cmd =~ /^F_(SelfInsert$|Yank)/
+ && length $line && $rl_default_selected ) {
+ # (Backward)?DeleteChar specialcased in the code
+ $line = '';
+ $D = 0;
+ $cmd = 'F_BackwardDeleteChar' if $cmd eq 'F_DeleteChar';
+ }
+ undef $doingNumArg;
+ &$cmd(1, ord($input)); ## actually execute input
+ $rl_first_char = 0;
+ $lastcommand = $cmd;
+ *KeyMap = $var_EditingMode; # JP: added
+
+ # In Vi command mode, don't position the cursor beyond the last
+ # character of the line buffer.
+ &F_BackwardChar(1) if $Vi_mode and $line ne ''
+ and &at_end_of_line and $KeyMap{'name'} eq 'vicmd_keymap';
+
+ &redisplay();
+ $LastCommandKilledText = $ThisCommandKilledText;
+ }
+
+ undef @undo; ## Release the memory.
+ undef @undoGroupS; ## Release the memory.
+ &ResetTTY; ## Restore the tty state.
+ $| = $oldbar;
+ select $old;
+ return undef if defined($ReturnEOF);
+ #print STDOUT "|al=`$AcceptLine'";
+ $AcceptLine; ## return the line accepted.
+}
+
+## ctrl(ord('a')) will return the ordinal for Ctrl-A.
+sub ctrl {
+ $_[0] ^ (($_[0]>=ord('a') && $_[0]<=ord('z')) ? 0x60 : 0x40);
+}
+
+
+
+sub SetTTY {
+ return if $dumb_term || $stdin_not_tty;
+ #return system 'stty raw -echo' if defined &DB::DB;
+ if (defined $term_readkey) {
+ Term::ReadKey::ReadMode(4, $term_IN);
+ if ($^O eq 'MSWin32') {
+ # If we reached this, Perl isn't cygwin; Enter sends \r; thus we need binmode
+ # XXXX Do we need to undo??? $term_IN is most probably private now...
+ binmode $term_IN;
+ }
+ return 1;
+ }
+# system 'stty raw -echo';
+
+ $sgttyb = ''; ## just to quiet "perl -w";
+ if ($useioctl && $^O ne 'solaris' && defined $TIOCGETP
+ && &ioctl($term_IN,$TIOCGETP,$sgttyb)) {
+ @tty_buf = unpack($sgttyb_t,$sgttyb);
+ if (defined $ENV{OS2_SHELL}) {
+ $tty_buf[3] &= ~$mode;
+ $tty_buf[3] &= ~$ECHO;
+ } else {
+ $tty_buf[4] |= $mode;
+ $tty_buf[4] &= ~$ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@tty_buf);
+ &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
+ } elsif (!$usestty) {
+ return 0;
+ } else {
+ warn <<EOW if $useioctl and not defined $ENV{PERL_READLINE_NOWARN};
+Can't ioctl TIOCGETP: $!
+Consider installing Term::ReadKey from CPAN site nearby
+ at http://www.perl.com/CPAN
+Or use
+ perl -MCPAN -e shell
+to reach CPAN. Falling back to 'stty'.
+ If you do not want to see this warning, set PERL_READLINE_NOWARN
+in your environment.
+EOW
+ # '; # For Emacs.
+ $useioctl = 0;
+ system 'stty raw -echo' and ($usestty = 0, die "Cannot call `stty': $!");
+ if ($^O eq 'MSWin32') {
+ # If we reached this, Perl isn't cygwin, but STTY is present ==> cygwin
+ # The symptoms: now Enter sends \r; thus we need binmode
+ # XXXX Do we need to undo??? $term_IN is most probably private now...
+ binmode $term_IN;
+ }
+ }
+ return 1;
+}
+
+sub ResetTTY {
+ return if $dumb_term || $stdin_not_tty;
+ #return system 'stty -raw echo' if defined &DB::DB;
+ if (defined $term_readkey) {
+ return Term::ReadKey::ReadMode(0, $term_IN);
+ }
+
+# system 'stty -raw echo';
+ if ($useioctl) {
+ &ioctl($term_IN,$TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!";
+ @tty_buf = unpack($sgttyb_t,$sgttyb);
+ if (defined $ENV{OS2_SHELL}) {
+ $tty_buf[3] |= $mode;
+ $tty_buf[3] |= $ECHO;
+ } else {
+ $tty_buf[4] &= ~$mode;
+ $tty_buf[4] |= $ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@tty_buf);
+ &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
+ } elsif ($usestty) {
+ system 'stty -raw echo' and die "Cannot call `stty': $!";
+ }
+}
+
+# Substr_with_props: gives the substr of prompt+string with embedded
+# face-change commands
+
+sub substr_with_props {
+ my ($p, $s, $from, $len, $ket, $bsel, $esel) = @_;
+ my $lp = length $p;
+
+ defined $from or $from = 0;
+ defined $len or $len = length($p) + length($s) - $from;
+ unless (defined $ket) {
+ warn 'bug in Term::ReadLine::Perl, please report to its author cpan@ilyaz.org';
+ $ket = '';
+ }
+ # We may draw over to put cursor in a correct position:
+ $ket = '' if $len < length($p) + length($s) - $from; # Not redrawn
+
+ if ($from >= $lp) {
+ $p = '';
+ $s = substr $s, $from - $lp;
+ $lp = 0;
+ } else {
+ $p = substr $p, $from;
+ $lp -= $from;
+ $from = 0;
+ }
+ $s = substr $s, 0, $len - $lp;
+ $p =~ s/^(\s*)//; my $bs = $1;
+ $p =~ s/(\s*)$//; my $as = $1;
+ $p = $rl_term_set->[0] . $p . $rl_term_set->[1] if length $p;
+ $p = "$bs$p$as";
+ $ket = chop $s if $ket;
+ if (defined $bsel and $bsel != $esel) {
+ $bsel = $len if $bsel > $len;
+ $esel = $len if $esel > $len;
+ }
+ if (defined $bsel and $bsel != $esel) {
+ get_ornaments_selected;
+ $bsel -= $lp; $esel -= $lp;
+ my ($pre, $sel, $post) =
+ (substr($s, 0, $bsel),
+ substr($s, $bsel, $esel-$bsel),
+ substr($s, $esel));
+ $pre = $rl_term_set->[2] . $pre . $rl_term_set->[3] if length $pre;
+ $sel = $rl_term_set->[4] . $sel . $rl_term_set->[5] if length $sel;
+ $post = $rl_term_set->[2] . $post . $rl_term_set->[3] if length $post;
+ $s = "$pre$sel$post"
+ } else {
+ $s = $rl_term_set->[2] . $s . $rl_term_set->[3] if length $s;
+ }
+
+ if (!$lp) { # Should not happen...
+ return $s;
+ } elsif (!length $s) { # Should not happen
+ return $p;
+ } else { # Do not underline spaces in the prompt
+ return "$p$s"
+ . (length $ket ? ($rl_term_set->[0] . $ket . $rl_term_set->[1]) : '');
+ }
+}
+
+sub redisplay_high {
+ get_ornaments_selected();
+ @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
+ &redisplay(); ## Show the line, default inverted.
+ @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
+ $force_redraw = 1;
+}
+
+##
+## redisplay()
+##
+## Updates the screen to reflect the current $line.
+##
+## For the purposes of this routine, we prepend the prompt to a local copy of
+## $line so that we display the prompt as well. We then modify it to reflect
+## that some characters have different sizes (i.e. control-C is represented
+## as ^C, tabs are expanded, etc.)
+##
+## This routine is somewhat complicated by two-byte characters.... must
+## make sure never to try do display just half of one.
+##
+## NOTE: If an argument is given, it is used instead of the prompt.
+##
+## This is some nasty code.
+##
+sub redisplay
+{
+ ## local $line has prompt also; take that into account with $D.
+ local($prompt) = defined($_[0]) ? $_[0] : $prompt;
+ my ($thislen, $have_bra);
+ my($dline) = $prompt . $line;
+ local($D) = $D + length($prompt);
+ my ($bsel, $esel);
+ if (defined pos $line) {
+ $bsel = (pos $line) + length $prompt;
+ }
+ my ($have_ket) = '';
+
+ ##
+ ## If the line contains anything that might require special processing
+ ## for displaying (such as tabs, control characters, etc.), we will
+ ## take care of that now....
+ ##
+ if ($dline =~ m/[^\x20-\x7e]/)
+ {
+ local($new, $Dinc, $c) = ('', 0);
+
+ ## Look at each character of $dline in turn.....
+ for ($i = 0; $i < length($dline); $i++) {
+ $c = substr($dline, $i, 1);
+
+ ## A tab to expand...
+ if ($c eq "\t") {
+ $c = ' ' x (8 - (($i-length($prompt)) % 8));
+
+ ## A control character....
+ } elsif ($c =~ tr/\000-\037//) {
+ $c = sprintf("^%c", ord($c)+ord('@'));
+
+ ## the delete character....
+ } elsif (ord($c) == 127) {
+ $c = '^?';
+ }
+ $new .= $c;
+
+ ## Bump over $D if this char is expanded and left of $D.
+ $Dinc += length($c) - 1 if (length($c) > 1 && $i < $D);
+ ## Bump over $bsel if this char is expanded and left of $bsel.
+ $bsel += length($c) - 1 if (defined $bsel && length($c) > 1 && $i < $bsel);
+ }
+ $dline = $new;
+ $D += $Dinc;
+ }
+
+ ##
+ ## Now $dline is what we'd like to display (with a prepended prompt)
+ ## $D is the position of the cursor on it.
+ ##
+ ## If it's too long to fit on the line, we must decide what we can fit.
+ ##
+ ## If we end up moving the screen index ($si) [index of the leftmost
+ ## character on the screen], to some place other than the front of the
+ ## the line, we'll have to make sure that it's not on the first byte of
+ ## a 2-byte character, 'cause we'll be placing a '<' marker there, and
+ ## that would screw up the 2-byte character.
+ ##
+ ## $si is preserved between several displays (if possible).
+ ##
+ ## Similarly, if the line needs chopped off, we make sure that the
+ ## placement of the tailing '>' won't screw up any 2-byte character in
+ ## the vicinity.
+
+ # Now $si keeps the value from previous display
+ if ($D == length($prompt) # If prompts fits exactly, show only if need not show trailing '>'
+ and length($prompt) < $rl_screen_width - (0 != length $dline)) {
+ $si = 0; ## prefer displaying the whole prompt
+ } elsif ($si >= $D) { # point to the left of what was displayed
+ $si = &max(0, $D - $rl_margin);
+ $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si);
+ } elsif ($si + $rl_screen_width <= $D) { # Point to the right of ...
+ $si = &min(length($dline), ($D - $rl_screen_width) + $rl_margin);
+ $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si);
+ } elsif (length($dline) - $si < $rl_screen_width - $rl_margin and $si) {
+ # Too little of the line shown
+ $si = &max(0, length($dline) - $rl_screen_width + 3);
+ $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si);
+ } else {
+ ## Fine as-is.... don't need to change $si.
+ }
+ $have_bra = 1 if $si != 0; # Need the "chopped-off" marker
+
+ $thislen = &min(length($dline) - $si, $rl_screen_width);
+ if ($si + $thislen < length($dline)) {
+ ## need to place a '>'... make sure to place on first byte.
+ $thislen-- if &OnSecondByte($si+$thislen-1);
+ substr($dline, $si+$thislen-1,1) = '>';
+ $have_ket = 1;
+ }
+
+ ##
+ ## Now know what to display.
+ ## Must get substr($dline, $si, $thislen) on the screen,
+ ## with the cursor at $D-$si characters from the left edge.
+ ##
+ $dline = substr($dline, $si, $thislen);
+ $delta = $D - $si; ## delta is cursor distance from beginning of $dline.
+ if (defined $bsel) { # Highlight the selected part
+ $bsel -= $si;
+ $esel = $delta;
+ ($bsel, $esel) = ($esel, $bsel) if $bsel > $esel;
+ $bsel = 0 if $bsel < 0;
+ if ($have_ket) {
+ $esel = $thislen - 1 if $esel > $thislen - 1;
+ } else {
+ $esel = $thislen if $esel > $thislen;
+ }
+ }
+ if ($si >= length($prompt)) { # Keep $dline for $lastredisplay...
+ $prompt = ($have_bra ? "<" : "");
+ $dline = substr $dline, 1; # After prompt
+ $bsel = 1 if defined $bsel and $bsel == 0;
+ } else {
+ $dline = substr($dline, (length $prompt) - $si);
+ $prompt = substr($prompt,$si);
+ substr($prompt, 0, 1) = '<' if $si > 0;
+ }
+ # Now $dline is the part after the prompt...
+
+ ##
+ ## Now must output $dline, with cursor $delta spaces from left of TTY
+ ##
+
+ local ($\, $,) = ('','');
+
+ ##
+ ## If $force_redraw is not set, we can attempt to optimize the redisplay
+ ## However, if we don't happen to find an easy way to optimize, we just
+ ## fall through to the brute-force method of re-drawing the whole line.
+ ##
+ if (not $force_redraw and not defined $bsel)
+ {
+ ## can try to optimize here a bit.
+
+ ## For when we only need to move the cursor
+ if ($lastredisplay eq $dline and $lastpromptlen == length $prompt) {
+ ## If we need to move forward, just overwrite as far as we need.
+ if ($lastdelta < $delta) {
+ print $term_OUT
+ substr_with_props($prompt, $dline,
+ $lastdelta, $delta-$lastdelta, $have_ket);
+ ## Need to move back.
+ } elsif($lastdelta > $delta) {
+ ## Two ways to move back... use the fastest. One is to just
+ ## backspace the proper amount. The other is to jump to the
+ ## the beginning of the line and overwrite from there....
+ my $out = substr_with_props($prompt, $dline, 0, $delta, $have_ket);
+ if ($lastdelta - $delta <= length $out) {
+ print $term_OUT "\b" x ($lastdelta - $delta);
+ } else {
+ print $term_OUT "\r", $out;
+ }
+ }
+ ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen)
+ = ($thislen, $dline, $delta, length $prompt);
+ # print $term_OUT "\a"; # Debugging
+ return;
+ }
+
+ ## for when we've just added stuff to the end
+ if ($thislen > $lastlen &&
+ $lastdelta == $lastlen &&
+ $delta == $thislen &&
+ $lastpromptlen == length($prompt) &&
+ substr($dline, 0, $lastlen - $lastpromptlen) eq $lastredisplay)
+ {
+ print $term_OUT substr_with_props($prompt, $dline,
+ $lastdelta, undef, $have_ket);
+ # print $term_OUT "\a"; # Debugging
+ ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen)
+ = ($thislen, $dline, $delta, length $prompt);
+ return;
+ }
+
+ ## There is much more opportunity for optimizing.....
+ ## something to work on later.....
+ }
+
+ ##
+ ## Brute force method of redisplaying... redraw the whole thing.
+ ##
+
+ print $term_OUT "\r", substr_with_props($prompt, $dline, 0, undef, $have_ket, $bsel, $esel);
+ my $back = length ($dline) + length ($prompt) - $delta;
+ $back += $lastlen - $thislen,
+ print $term_OUT ' ' x ($lastlen - $thislen) if $lastlen > $thislen;
+
+ if ($back) {
+ my $out = substr_with_props($prompt, $dline, 0, $delta, $have_ket, $bsel, $esel);
+ if ($back <= length $out and not defined $bsel) {
+ print $term_OUT "\b" x $back;
+ } else {
+ print $term_OUT "\r", $out;
+ }
+ }
+
+ ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen)
+ = ($thislen, $dline, $delta, length $prompt);
+
+ $force_redraw = 0;
+}
+
+sub min { $_[0] < $_[1] ? $_[0] : $_[1]; }
+
+sub getc_with_pending {
+
+ my $key = @Pending ? shift(@Pending) : &$rl_getc;
+
+ # Save keystrokes for vi '.' command
+ push(@$Dot_buf, $key) if $Dot_buf;
+
+ $key;
+}
+
+sub rl_getc {
+ my $key; # JP: Added missing declaration
+ if (defined $term_readkey) { # XXXX ???
+ $Term::ReadLine::Perl::term->Tk_loop
+ if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ $key = Term::ReadKey::ReadKey(0, $term_IN);
+ } else {
+ $key = $Term::ReadLine::Perl::term->get_c;
+ }
+}
+
+##
+## get_command(keymap, ord_command_char)
+##
+## If the KEYMAP has an entry for COMMAND, it is returned.
+## Otherwise, the default command is returned.
+##
+sub get_command
+{
+ local *KeyMap = shift;
+ my ($key) = @_;
+ my $cmd = defined($KeyMap[$key]) ? $KeyMap[$key]
+ : ($KeyMap{'default'} || 'F_Ding');
+ if (!defined($cmd) || $cmd eq ''){
+ warn "internal error (key=$key)";
+ $cmd = 'F_Ding';
+ }
+ $cmd
+}
+
+##
+## do_command(keymap, numericarg, command)
+##
+## If the KEYMAP has an entry for COMMAND, it is executed.
+## Otherwise, the default command for the keymap is executed.
+##
+sub do_command
+{
+ my ($keymap, $count, $key) = @_;
+ my $cmd = get_command($keymap, $key);
+
+ local *KeyMap = $keymap; # &$cmd may expect it...
+ &$cmd($count, $key);
+ $lastcommand = $cmd;
+}
+
+##
+## Save whatever state we wish to save as an anonymous array.
+## The only other function that needs to know about its encoding is getstate/preserve_state.
+##
+sub savestate
+{
+ [$D, $si, $LastCommandKilledText, $KillBuffer, $line, @_];
+}
+
+# consolidate only-movement changes together...
+sub preserve_state {
+ return if $Vi_mode;
+ push(@undo, savestate()), return unless @undo;
+ my $last = $undo[-1];
+ my @only_movement;
+ if ( #$last->[1] == $si and $last->[2] eq $LastCommandKilledText
+ # and $last->[3] eq $KillBuffer and
+ $last->[4] eq $line ) {
+ # Only position changed; remove old only-position-changed records
+ pop @undo if $undo[-1]->[5];
+ @only_movement = 1;
+ }
+ push(@undo, savestate(@only_movement));
+}
+
+##
+## $_[1] is an ASCII ordinal; inserts as per $count.
+##
+sub F_SelfInsert
+{
+ remove_selection();
+ my ($count, $ord) = @_;
+ my $text2add = pack('C', $ord) x $count;
+ if ($InsertMode) {
+ substr($line,$D,0) .= $text2add;
+ } else {
+ ## note: this can screw up with 2-byte characters.
+ substr($line,$D,length($text2add)) = $text2add;
+ }
+ $D += length($text2add);
+}
+
+##
+## Return the line as-is to the user.
+##
+sub F_AcceptLine
+{
+ &add_line_to_history;
+ $AcceptLine = $line;
+ local $\ = '';
+ print $term_OUT "\r\n";
+ $force_redraw = 0;
+ (pos $line) = undef; # Another way to force redraw...
+}
+
+sub add_line_to_history
+{
+ ## Insert into history list if:
+ ## * bigger than the minimal length
+ ## * not same as last entry
+ ##
+ if (length($line) >= $minlength
+ && (!@rl_History || $rl_History[$#rl_History] ne $line)
+ ) {
+ ## if the history list is full, shift out an old one first....
+ while (@rl_History >= $rl_MaxHistorySize) {
+ shift(@rl_History);
+ $rl_HistoryIndex--;
+ }
+
+ push(@rl_History, $line); ## tack new one on the end
+ }
+}
+
+
+sub remove_selection {
+ if ( $rl_first_char && length $line && $rl_default_selected ) {
+ $line = '';
+ $D = 0;
+ return 1;
+ }
+ if ($rl_delete_selection and defined pos $line and $D != pos $line) {
+ kill_text(pos $line, $D);
+ return 1;
+ }
+ return;
+}
+
+#sub F_ReReadInitFile;
+#sub rl_getc;
+sub F_ForwardChar;
+sub F_BackwardChar;
+sub F_BeginningOfLine;
+sub F_EndOfLine;
+sub F_ForwardWord;
+sub F_BackwardWord;
+sub F_RedrawCurrentLine;
+sub F_ClearScreen;
+# sub F_SelfInsert;
+sub F_QuotedInsert;
+sub F_TabInsert;
+#sub F_AcceptLine;
+sub F_OperateAndGetNext;
+sub F_BackwardDeleteChar;
+sub F_DeleteChar;
+sub F_UnixWordRubout;
+sub F_UnixLineDiscard;
+sub F_UpcaseWord;
+sub F_DownCaseWord;
+sub F_CapitalizeWord;
+sub F_TransposeWords;
+sub F_TransposeChars;
+sub F_PreviousHistory;
+sub F_NextHistory;
+sub F_BeginningOfHistory;
+sub F_EndOfHistory;
+sub F_ReverseSearchHistory;
+sub F_ForwardSearchHistory;
+sub F_HistorySearchBackward;
+sub F_HistorySearchForward;
+sub F_KillLine;
+sub F_BackwardKillLine;
+sub F_Yank;
+sub F_YankPop;
+sub F_YankNthArg;
+sub F_KillWord;
+sub F_BackwardKillWord;
+sub F_Abort;
+sub F_DoLowercaseVersion;
+sub F_DoMetaVersion;
+sub F_DoControlVersion;
+sub F_Undo;
+sub F_RevertLine;
+sub F_EmacsEditingMode;
+sub F_Interrupt;
+sub F_PrefixMeta;
+sub F_UniversalArgument;
+sub F_DigitArgument;
+sub F_OverwriteMode;
+sub F_InsertMode;
+sub F_ToggleInsertMode;
+sub F_Suspend;
+sub F_Ding;
+sub F_PossibleCompletions;
+sub F_Complete;
+sub F_YankClipboard;
+sub F_CopyRegionAsKillClipboard;
+sub F_KillRegionClipboard;
+sub clipboard_set;
+sub F_BeginUndoGroup;
+sub F_EndUndoGroup;
+sub F_DoNothing;
+sub F_ForceMemorizeDigitArgument;
+sub F_MemorizeDigitArgument;
+sub F_UnmemorizeDigitArgument;
+sub F_ResetDigitArgument;
+sub F_MergeInserts;
+sub F_MemorizePos;
+sub F_BeginPasteGroup;
+sub F_EndPasteGroup;
+sub F_BeginEditGroup;
+sub F_EndEditGroup;
+
+# Comment next line and __DATA__ line below to disable the selfloader.
+
+use SelfLoader;
+
+1;
+
+__DATA__
+
+# From here on anything may be autoloaded
+
+sub max { $_[0] > $_[1] ? $_[0] : $_[1]; }
+sub isupper { ord($_[0]) >= ord('A') && ord($_[0]) <= ord('Z'); }
+sub islower { ord($_[0]) >= ord('a') && ord($_[0]) <= ord('z'); }
+sub toupper { &islower ? pack('c', ord($_[0])-ord('a')+ord('A')) : $_[0];}
+sub tolower { &isupper ? pack('c', ord($_[0])-ord('A')+ord('a')) : $_[0];}
+
+##
+## rl_set(var_name, value_string)
+##
+## Sets the named variable as per the given value, if both are appropriate.
+## Allows the user of the package to set such things as HorizontalScrollMode
+## and EditingMode. Value_string may be of the form
+## HorizontalScrollMode
+## horizontal-scroll-mode
+##
+## Also called during the parsing of ~/.inputrc for "set var value" lines.
+##
+## The previous value is returned, or undef on error.
+###########################################################################
+## Consider the following example for how to add additional variables
+## accessible via rl_set (and hence via ~/.inputrc).
+##
+## Want:
+## We want an external variable called "FooTime" (or "foo-time").
+## It may have values "January", "Monday", or "Noon".
+## Internally, we'll want those values to translate to 1, 2, and 12.
+##
+## How:
+## Have an internal variable $var_FooTime that will represent the current
+## internal value, and initialize it to the default value.
+## Make an array %var_FooTime whose keys and values are are the external
+## (January, Monday, Noon) and internal (1, 2, 12) values:
+##
+## $var_FooTime = $var_FooTime{'January'} = 1; #default
+## $var_FooTime{'Monday'} = 2;
+## $var_FooTime{'Noon'} = 12;
+##
+sub rl_set
+{
+ local($var, $val) = @_;
+
+ # &preinit's keys are all Capitalized
+ $val = ucfirst lc $val if $val =~ /^(on|off)$/i;
+
+ $var = 'CompleteAddsuffix' if $var eq 'visible-stats';
+
+ ## if the variable is in the form "some-name", change to "SomeName"
+ local($_) = "\u$var";
+ local($return) = undef;
+ s/-(.)/\u$1/g;
+
+ # Skip unknown variables:
+ return unless defined $ {'readline::'}{"var_$_"};
+ local(*V); # avoid <Undefined value assign to typeglob> warning
+ { local $^W; *V = $ {'readline::'}{"var_$_"}; }
+ if (!defined($V)) { # XXX Duplicate check?
+ warn("Warning$InputLocMsg:\n".
+ " Invalid variable `$var'\n") if $^W;
+ } elsif (!defined($V{$val})) {
+ local(@selections) = keys(%V);
+ warn("Warning$InputLocMsg:\n".
+ " Invalid value `$val' for variable `$var'.\n".
+ " Choose from [@selections].\n") if $^W;
+ } else {
+ $return = $V;
+ $V = $V{$val}; ## make the setting
+ }
+ $return;
+}
+
+##
+## OnSecondByte($index)
+##
+## Returns true if the byte at $index into $line is the second byte
+## of a two-byte character.
+##
+sub OnSecondByte
+{
+ return 0 if !$_rl_japanese_mb || $_[0] == 0 || $_[0] == length($line);
+
+ die 'internal error' if $_[0] > length($line);
+
+ ##
+ ## must start looking from the beginning of the line .... can
+ ## have one- and two-byte characters interspersed, so can't tell
+ ## without starting from some know location.....
+ ##
+ local($i);
+ for ($i = 0; $i < $_[0]; $i++) {
+ next if ord(substr($line, $i, 1)) < 0x80;
+ ## We have the first byte... must bump up $i to skip past the 2nd.
+ ## If that one we're skipping past is the index, it should be changed
+ ## to point to the first byte of the pair (therefore, decremented).
+ return 1 if ++$i == $_[0];
+ }
+ 0; ## seemed to be OK.
+}
+
+##
+## CharSize(index)
+##
+## Returns the size of the character at the given INDEX in the
+## current line. Most characters are just one byte in length,
+## but if the byte at the index and the one after has the high
+## bit set those two bytes are one character of size=2.
+##
+## Assumes that index points to the first of a 2-byte char if not
+## pointing to a 2-byte char.
+##
+sub CharSize
+{
+ return 2 if $_rl_japanese_mb &&
+ ord(substr($line, $_[0], 1)) >= 0x80 &&
+ ord(substr($line, $_[0]+1, 1)) >= 0x80;
+ 1;
+}
+
+sub GetTTY
+{
+ $base_termios = $termios; # make it long enough
+ &ioctl($term_IN,$TCGETS,$base_termios) || die "Can't ioctl TCGETS: $!";
+}
+
+sub XonTTY
+{
+ # I don't know which of these I actually need to do this to, so we'll
+ # just cover all bases.
+
+ &ioctl($term_IN,$TCXONC,$TCOON); # || die "Can't ioctl TCXONC STDIN: $!";
+ &ioctl($term_OUT,$TCXONC,$TCOON); # || die "Can't ioctl TCXONC STDOUT: $!";
+}
+
+sub ___SetTTY
+{
+# print "before SetTTY\n\r";
+# system 'stty -a';
+
+ &XonTTY;
+
+ &GetTTY
+ if !defined($base_termios);
+
+ @termios = unpack($termios_t,$base_termios);
+ $termios[$TERMIOS_IFLAG] |= $TERMIOS_READLINE_ION;
+ $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_READLINE_IOFF;
+ $termios[$TERMIOS_OFLAG] |= $TERMIOS_READLINE_OON;
+ $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_READLINE_OOFF;
+ $termios[$TERMIOS_LFLAG] |= $TERMIOS_READLINE_LON;
+ $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_READLINE_LOFF;
+ $termios[$TERMIOS_VMIN] = 1;
+ $termios[$TERMIOS_VTIME] = 0;
+ $termios = pack($termios_t,@termios);
+ &ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!";
+
+# print "after SetTTY\n\r";
+# system 'stty -a';
+}
+
+sub normal_tty_mode
+{
+ return if $stdin_not_tty || $dumb_term || !$initialized;
+ &XonTTY;
+ &GetTTY if !defined($base_termios);
+ &ResetTTY;
+}
+
+sub ___ResetTTY
+{
+# print "before ResetTTY\n\r";
+# system 'stty -a';
+
+ @termios = unpack($termios_t,$base_termios);
+ $termios[$TERMIOS_IFLAG] |= $TERMIOS_NORMAL_ION;
+ $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_NORMAL_IOFF;
+ $termios[$TERMIOS_OFLAG] |= $TERMIOS_NORMAL_OON;
+ $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_NORMAL_OOFF;
+ $termios[$TERMIOS_LFLAG] |= $TERMIOS_NORMAL_LON;
+ $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_NORMAL_LOFF;
+ $termios = pack($termios_t,@termios);
+ &ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!";
+
+# print "after ResetTTY\n\r";
+# system 'stty -a';
+}
+
+##
+## WordBreak(index)
+##
+## Returns true if the character at INDEX into $line is a basic word break
+## character, false otherwise.
+##
+sub WordBreak
+{
+ index($rl_basic_word_break_characters, substr($line,$_[0],1)) != -1;
+}
+
+sub getstate
+{
+ ($D, $si, $LastCommandKilledText, $KillBuffer, $line) = @{$_[0]};
+ $ThisCommandKilledText = $LastCommandKilledText;
+}
+
+##
+## kills from D=$_[0] to $_[1] (to the killbuffer if $_[2] is true)
+##
+sub kill_text
+{
+ my($from, $to, $save) = (&min($_[0], $_[1]), &max($_[0], $_[1]), $_[2]);
+ my $len = $to - $from;
+ if ($save) {
+ $KillBuffer = '' if !$LastCommandKilledText;
+ if ($from < $LastCommandKilledText - 1) {
+ $KillBuffer = substr($line, $from, $len) . $KillBuffer;
+ } else {
+ $KillBuffer .= substr($line, $from, $len);
+ }
+ $ThisCommandKilledText = 1 + $from;
+ }
+ substr($line, $from, $len) = '';
+
+ ## adjust $D
+ if ($D > $from) {
+ $D -= $len;
+ $D = $from if $D < $from;
+ }
+}
+
+
+###########################################################################
+## Bindable functions... pretty much in the same order as in readline.c ###
+###########################################################################
+
+##
+## Returns true if $D at the end of the line.
+##
+sub at_end_of_line
+{
+ ($D + &CharSize($D)) == (length($line) + 1);
+}
+
+
+##
+## Move forward (right) $count characters.
+##
+sub F_ForwardChar
+{
+ my $count = shift;
+ return &F_BackwardChar(-$count) if $count < 0;
+
+ while (!&at_end_of_line && $count-- > 0) {
+ $D += &CharSize($D);
+ }
+}
+
+##
+## Move backward (left) $count characters.
+##
+sub F_BackwardChar
+{
+ my $count = shift;
+ return &F_ForwardChar(-$count) if $count < 0;
+
+ while (($D > 0) && ($count-- > 0)) {
+ $D--; ## Move back one regardless,
+ $D-- if &OnSecondByte($D); ## another if over a big char.
+ }
+}
+
+##
+## Go to beginning of line.
+##
+sub F_BeginningOfLine
+{
+ $D = 0;
+}
+
+##
+## Move to the end of the line.
+##
+sub F_EndOfLine
+{
+ &F_ForwardChar(100) while !&at_end_of_line;
+}
+
+##
+## Move to the end of this/next word.
+## Done as many times as $count says.
+##
+sub F_ForwardWord
+{
+ my $count = shift;
+ return &F_BackwardWord(-$count) if $count < 0;
+
+ while (!&at_end_of_line && $count-- > 0)
+ {
+ ## skip forward to the next word (if not already on one)
+ &F_ForwardChar(1) while !&at_end_of_line && &WordBreak($D);
+ ## skip forward to end of word
+ &F_ForwardChar(1) while !&at_end_of_line && !&WordBreak($D);
+ }
+}
+
+##
+##
+## Move to the beginning of this/next word.
+## Done as many times as $count says.
+##
+sub F_BackwardWord
+{
+ my $count = shift;
+ return &F_ForwardWord(-$count) if $count < 0;
+
+ while ($D > 0 && $count-- > 0) {
+ ## skip backward to the next word (if not already on one)
+ &F_BackwardChar(1) while (($D > 0) && &WordBreak($D-1));
+ ## skip backward to start of word
+ &F_BackwardChar(1) while (($D > 0) && !&WordBreak($D-1));
+ }
+}
+
+##
+## Refresh the input line.
+##
+sub F_RedrawCurrentLine
+{
+ $force_redraw = 1;
+}
+
+##
+## Clear the screen and refresh the line.
+## If given a numeric arg other than 1, simply refreshes the line.
+##
+sub F_ClearScreen
+{
+ my $count = shift;
+ return &F_RedrawCurrentLine if $count != 1;
+
+ $rl_CLEAR = `clear` if !defined($rl_CLEAR);
+ local $\ = '';
+ print $term_OUT $rl_CLEAR;
+ $force_redraw = 1;
+}
+
+##
+## Insert the next character read verbatim.
+##
+sub F_QuotedInsert
+{
+ my $count = shift;
+ &F_SelfInsert($count, ord(&getc_with_pending));
+}
+
+##
+## Insert a tab.
+##
+sub F_TabInsert
+{
+ my $count = shift;
+ &F_SelfInsert($count, ord("\t"));
+}
+
+## Operate - accept the current line and fetch from the
+## history the next line relative to current line for default.
+sub F_OperateAndGetNext
+{
+ my $count = shift;
+
+ &F_AcceptLine;
+
+ my $remainingEntries = $#rl_History - $rl_HistoryIndex;
+ if ($count > 0 && $remainingEntries >= 0) { # there is something to repeat
+ if ($remainingEntries > 0) { # if we are not on last line
+ $rl_HistoryIndex++; # fetch next one
+ $count = $remainingEntries if $count > $remainingEntries;
+ }
+ $rl_OperateCount = $count;
+ }
+}
+
+##
+## Removes $count chars to left of cursor (if not at beginning of line).
+## If $count > 1, deleted chars saved to kill buffer.
+##
+sub F_BackwardDeleteChar
+{
+ return if remove_selection();
+
+ my $count = shift;
+ return F_DeleteChar(-$count) if $count < 0;
+ my $oldD = $D;
+ &F_BackwardChar($count);
+ return if $D == $oldD;
+ &kill_text($oldD, $D, $count > 1);
+}
+
+##
+## Removes the $count chars from under the cursor.
+## If there is no line and the last command was different, tells
+## readline to return EOF.
+## If there is a line, and the cursor is at the end of it, and we're in
+## tcsh completion mode, then list possible completions.
+## If $count > 1, deleted chars saved to kill buffer.
+##
+sub F_DeleteChar
+{
+ return if remove_selection();
+
+ my $count = shift;
+ return F_DeleteBackwardChar(-$count) if $count < 0;
+ if (length($line) == 0) { # EOF sent (probably OK in DOS too)
+ $AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar';
+ return;
+ }
+ if ($D == length ($line))
+ {
+ &complete_internal('?') if $var_TcshCompleteMode;
+ return;
+ }
+ my $oldD = $D;
+ &F_ForwardChar($count);
+ return if $D == $oldD;
+ &kill_text($oldD, $D, $count > 1);
+}
+
+##
+## Kill to previous whitespace.
+##
+sub F_UnixWordRubout
+{
+ return &F_Ding if $D == 0;
+ (my $oldD, local $rl_basic_word_break_characters) = ($D, "\t ");
+ # JP: Fixed a bug here - both were 'my'
+ F_BackwardWord(1);
+ kill_text($D, $oldD, 1);
+}
+
+##
+## Kill line from cursor to beginning of line.
+##
+sub F_UnixLineDiscard
+{
+ return &F_Ding if $D == 0;
+ kill_text(0, $D, 1);
+}
+
+sub F_UpcaseWord { &changecase($_[0], 'up'); }
+sub F_DownCaseWord { &changecase($_[0], 'down'); }
+sub F_CapitalizeWord { &changecase($_[0], 'cap'); }
+
+##
+## Translated from GNUs readline.c
+## One arg is 'up' to upcase $_[0] words,
+## 'down' to downcase them,
+## or something else to capitolize them.
+## If $_[0] is negative, the dot is not moved.
+##
+sub changecase
+{
+ my $op = $_[1];
+
+ my ($start, $state, $c, $olddot) = ($D, 0);
+ if ($_[0] < 0)
+ {
+ $olddot = $D;
+ $_[0] = -$_[0];
+ }
+
+ &F_ForwardWord; ## goes forward $_[0] words.
+
+ while ($start < $D) {
+ $c = substr($line, $start, 1);
+
+ if ($op eq 'up') {
+ $c = &toupper($c);
+ } elsif ($op eq 'down') {
+ $c = &tolower($c);
+ } else { ## must be 'cap'
+ if ($state == 1) {
+ $c = &tolower($c);
+ } else {
+ $c = &toupper($c);
+ $state = 1;
+ }
+ $state = 0 if $c !~ tr/a-zA-Z//;
+ }
+
+ substr($line, $start, 1) = $c;
+ $start++;
+ }
+ $D = $olddot if defined($olddot);
+}
+
+sub F_TransposeWords {
+ my $c = shift;
+ return F_Ding() unless $c;
+ # Find "this" word
+ F_BackwardWord(1);
+ my $p0 = $D;
+ F_ForwardWord(1);
+ my $p1 = $D;
+ return F_Ding() if $p1 == $p0;
+ my ($p2, $p3) = ($p0, $p1);
+ if ($c > 0) {
+ F_ForwardWord($c);
+ $p3 = $D;
+ F_BackwardWord(1);
+ $p2 = $D;
+ } else {
+ F_BackwardWord(1 - $c);
+ $p0 = $D;
+ F_ForwardWord(1);
+ $p1 = $D;
+ }
+ return F_Ding() if $p3 == $p2 or $p2 < $p1;
+ my $r = substr $line, $p2, $p3 - $p2;
+ substr($line, $p2, $p3 - $p2) = substr $line, $p0, $p1 - $p0;
+ substr($line, $p0, $p1 - $p0) = $r;
+ $D = $c > 0 ? $p3 : $p0 + $p3 - $p2; # End of "this" word after edit
+ return 1;
+## Exchange words: C-Left, C-right, C-right, C-left. If positions do
+## not overlap, we get two things to transpose. Repeat count?
+}
+
+##
+## Switch char at dot with char before it.
+## If at the end of the line, switch the previous two...
+## (NOTE: this could screw up multibyte characters.. should do correctly)
+sub F_TransposeChars
+{
+ if ($D == length($line) && $D >= 2) {
+ substr($line,$D-2,2) = substr($line,$D-1,1).substr($line,$D-2,1);
+ } elsif ($D >= 1) {
+ substr($line,$D-1,2) = substr($line,$D,1) .substr($line,$D-1,1);
+ } else {
+ &F_Ding;
+ }
+}
+
+sub F_PreviousHistory {
+ &get_line_from_history($rl_HistoryIndex - shift);
+}
+
+sub F_NextHistory {
+ &get_line_from_history($rl_HistoryIndex + shift);
+}
+
+
+
+sub F_BeginningOfHistory
+{
+ &get_line_from_history(0);
+}
+
+sub F_EndOfHistory
+{
+ &get_line_from_history(@rl_History);
+}
+
+sub F_ReverseSearchHistory
+{
+ &DoSearch($_[0] >= 0 ? 1 : 0);
+}
+
+sub F_ForwardSearchHistory
+{
+ &DoSearch($_[0] >= 0 ? 0 : 1);
+}
+
+sub F_HistorySearchBackward
+{
+ &DoSearchStart(($_[0] >= 0 ? 1 : 0),substr($line,0,$D));
+}
+
+sub F_HistorySearchForward
+{
+ &DoSearchStart(($_[0] >= 0 ? 0 : 1),substr($line,0,$D));
+}
+
+## returns a new $i or -1 if not found.
+sub search {
+ my ($i, $str) = @_;
+ return -1 if $i < 0 || $i > $#rl_History; ## for safety
+ while (1) {
+ return $i if rindex($rl_History[$i], $str) >= 0;
+ if ($reverse) {
+ return -1 if $i-- == 0;
+ } else {
+ return -1 if $i++ == $#rl_History;
+ }
+ }
+}
+
+sub DoSearch
+{
+ local $reverse = shift; # Used in search()
+ my $oldline = $line;
+ my $oldD = $D;
+
+ my $searchstr = ''; ## string we're searching for
+ my $I = -1; ## which history line
+
+ $si = 0;
+
+ while (1)
+ {
+ if ($I != -1) {
+ $line = $rl_History[$I];
+ $D += index($rl_History[$I], $searchstr);
+ }
+ &redisplay( '('.($reverse?'reverse-':'') ."i-search) `$searchstr': ");
+
+ $c = &getc_with_pending;
+ if (($KeyMap[ord($c)] || 0) eq 'F_ReverseSearchHistory') {
+ if ($reverse && $I != -1) {
+ if ($tmp = &search($I-1,$searchstr), $tmp >= 0) {
+ $I = $tmp;
+ } else {
+ &F_Ding;
+ }
+ }
+ $reverse = 1;
+ } elsif (($KeyMap[ord($c)] || 0) eq 'F_ForwardSearchHistory') {
+ if (!$reverse && $I != -1) {
+ if ($tmp = &search($I+1,$searchstr), $tmp >= 0) {
+ $I = $tmp;
+ } else {
+ &F_Ding;
+ }
+ }
+ $reverse = 0;
+ } elsif ($c eq "\007") { ## abort search... restore line and return
+ $line = $oldline;
+ $D = $oldD;
+ return;
+ } elsif (ord($c) < 32 || ord($c) > 126) {
+ push(@Pending, $c) if $c ne "\e";
+ if ($I < 0) {
+ ## just restore
+ $line = $oldline;
+ $D = $oldD;
+ } else {
+ #chose this line
+ $line = $rl_History[$I];
+ $D = index($rl_History[$I], $searchstr);
+ }
+ &redisplay();
+ last;
+ } else {
+ ## Add this character to the end of the search string and
+ ## see if that'll match anything.
+ $tmp = &search($I < 0 ? $rl_HistoryIndex-$reverse: $I, $searchstr.$c);
+ if ($tmp == -1) {
+ &F_Ding;
+ } else {
+ $searchstr .= $c;
+ $I = $tmp;
+ }
+ }
+ }
+}
+
+## returns a new $i or -1 if not found.
+sub searchStart {
+ my ($i, $reverse, $str) = @_;
+ $i += $reverse ? - 1: +1;
+ return -1 if $i < 0 || $i > $#rl_History; ## for safety
+ while (1) {
+ return $i if index($rl_History[$i], $str) == 0;
+ if ($reverse) {
+ return -1 if $i-- == 0;
+ } else {
+ return -1 if $i++ == $#rl_History;
+ }
+ }
+}
+
+sub DoSearchStart
+{
+ my ($reverse,$what) = @_;
+ my $i = searchStart($rl_HistoryIndex, $reverse, $what);
+ return if $i == -1;
+ $rl_HistoryIndex = $i;
+ ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
+ F_BeginningOfLine();
+ F_ForwardChar(length($what));
+
+}
+
+###########################################################################
+###########################################################################
+
+##
+## Kill from cursor to end of line.
+##
+sub F_KillLine
+{
+ my $count = shift;
+ return F_BackwardKillLine(-$count) if $count < 0;
+ kill_text($D, length($line), 1);
+}
+
+##
+## Delete from cursor to beginning of line.
+##
+sub F_BackwardKillLine
+{
+ my $count = shift;
+ return F_KillLine(-$count) if $count < 0;
+ return F_Ding if $D == 0;
+ kill_text(0, $D, 1);
+}
+
+##
+## TextInsert(count, string)
+##
+sub TextInsert {
+ my $count = shift;
+ my $text2add = shift(@_) x $count;
+ if ($InsertMode) {
+ substr($line,$D,0) .= $text2add;
+ } else {
+ substr($line,$D,length($text2add)) = $text2add;
+ }
+ $D += length($text2add);
+}
+
+sub F_Yank
+{
+ remove_selection();
+ &TextInsert($_[0], $KillBuffer);
+}
+
+sub F_YankPop {
+ 1;
+ ## not implemented yet
+}
+
+sub F_YankNthArg {
+ 1;
+ ## not implemented yet
+}
+
+##
+## Kill to the end of the current word. If not on a word, kill to
+## the end of the next word.
+##
+sub F_KillWord
+{
+ my $count = shift;
+ return &F_BackwardKillWord(-$count) if $count < 0;
+ my $oldD = $D;
+ &F_ForwardWord($count); ## moves forward $count words.
+ kill_text($oldD, $D, 1);
+}
+
+##
+## Kill backward to the start of the current word, or, if currently
+## not on a word (or just at the start of a word), to the start of the
+## previous word.
+##
+sub F_BackwardKillWord
+{
+ my $count = shift;
+ return F_KillWord(-$count) if $count < 0;
+ my $oldD = $D;
+ &F_BackwardWord($count); ## moves backward $count words.
+ kill_text($D, $oldD, 1);
+}
+
+###########################################################################
+###########################################################################
+
+
+##
+## Abort the current input.
+##
+sub F_Abort
+{
+ &F_Ding;
+}
+
+
+##
+## If the character that got us here is upper case,
+## do the lower-case equiv...
+##
+sub F_DoLowercaseVersion
+{
+ if ($_[1] >= ord('A') && $_[1] <= ord('Z')) {
+ &do_command(*KeyMap, $_[0], $_[1] - ord('A') + ord('a'));
+ } else {
+ &F_Ding;
+ }
+}
+
+##
+## do the equiv with control key...
+##
+sub F_DoControlVersion
+{
+ local *KeyMap = $var_EditingMode;
+ my $key = $_[1];
+
+ if ($key == ord('?')) {
+ $key = 0x7F;
+ } else {
+ $key &= ~(0x80 | 0x60);
+ }
+ &do_command(*KeyMap, $_[0], $key);
+}
+
+##
+## do the equiv with meta key...
+##
+sub F_DoMetaVersion
+{
+ local *KeyMap = $var_EditingMode;
+ unshift @Pending, chr $_[1];
+
+ &do_command(*KeyMap, $_[0], ord "\e");
+}
+
+##
+## If the character that got us here is Alt-Char,
+## do the Esc Char equiv...
+##
+sub F_DoEscVersion
+{
+ my ($ord, $t) = $_[1];
+ &F_Ding unless $KeyMap{'Esc'};
+ for $t (([ord 'w', '`1234567890-='],
+ [ord ',', 'zxcvbnm,./\\'],
+ [16, 'qwertyuiop[]'],
+ [ord(' ') - 2, 'asdfghjkl;\''])) {
+ next unless $ord >= $t->[0] and $ord < $t->[0] + length($t->[1]);
+ $ord = ord substr $t->[1], $ord - $t->[0], 1;
+ return &do_command($KeyMap{'Esc'}, $_[0], $ord);
+ }
+ &F_Ding;
+}
+
+##
+## Undo one level.
+##
+sub F_Undo
+{
+ pop(@undo); # unless $undo[-1]->[5]; ## get rid of the state we just put on, so we can go back one.
+ if (@undo) {
+ &getstate(pop(@undo));
+ } else {
+ &F_Ding;
+ }
+}
+
+##
+## Replace the current line to some "before" state.
+##
+sub F_RevertLine
+{
+ if ($rl_HistoryIndex >= $#rl_History+1) {
+ $line = $line_for_revert;
+ } else {
+ $line = $rl_History[$rl_HistoryIndex];
+ }
+ $D = length($line);
+}
+
+sub F_EmacsEditingMode
+{
+ $var_EditingMode = $var_EditingMode{'emacs'};
+ $Vi_mode = 0;
+}
+
+###########################################################################
+###########################################################################
+
+
+##
+## (Attempt to) interrupt the current program.
+##
+sub F_Interrupt
+{
+ local $\ = '';
+ print $term_OUT "\r\n";
+ &ResetTTY;
+ kill ("INT", 0);
+
+ ## We're back.... must not have died.
+ $force_redraw = 1;
+}
+
+##
+## Execute the next character input as a command in a meta keymap.
+##
+sub F_PrefixMeta
+{
+ my($count, $keymap) = ($_[0], "$KeyMap{'name'}_$_[1]");
+ ##print "F_PrefixMeta [$keymap]\n\r";
+ die "<internal error, $_[1]>" unless %$keymap;
+ do_command(*$keymap, $count, ord(&getc_with_pending));
+}
+
+sub F_UniversalArgument
+{
+ &F_DigitArgument;
+}
+
+##
+## For typing a numeric prefix to a command....
+##
+sub F_DigitArgument
+{
+ my $in = chr $_[1];
+ my ($NumericArg, $sawDigit) = (1, 0);
+ my ($increment, $ord);
+ ($NumericArg, $sawDigit) = ($_[0], $_[0] !~ /e0$/i)
+ if $doingNumArg; # XXX What if Esc-- 1 ?
+
+ do
+ {
+ $ord = ord $in;
+ if (defined($KeyMap[$ord]) && $KeyMap[$ord] eq 'F_UniversalArgument') {
+ $NumericArg *= 4;
+ } elsif ($ord == ord('-') && !$sawDigit) {
+ $NumericArg = -$NumericArg;
+ } elsif ($ord >= ord('0') && $ord <= ord('9')) {
+ $increment = ($ord - ord('0')) * ($NumericArg < 0 ? -1 : 1);
+ if ($sawDigit) {
+ $NumericArg = $NumericArg * 10 + $increment;
+ } else {
+ $NumericArg = $increment;
+ $sawDigit = 1;
+ }
+ } else {
+ local(*KeyMap) = $var_EditingMode;
+ &redisplay();
+ $doingNumArg = 1; # Allow NumArg inside NumArg
+ &do_command(*KeyMap, $NumericArg . ($sawDigit ? '': 'e0'), $ord);
+ return;
+ }
+ ## make sure it's not toooo big.
+ if ($NumericArg > $rl_max_numeric_arg) {
+ $NumericArg = $rl_max_numeric_arg;
+ } elsif ($NumericArg < -$rl_max_numeric_arg) {
+ $NumericArg = -$rl_max_numeric_arg;
+ }
+ &redisplay(sprintf("(arg %d) ", $NumericArg));
+ } while defined($in = &getc_with_pending);
+}
+
+sub F_OverwriteMode
+{
+ $InsertMode = 0;
+}
+
+sub F_InsertMode
+{
+ $InsertMode = 1;
+}
+
+sub F_ToggleInsertMode
+{
+ $InsertMode = !$InsertMode;
+}
+
+##
+## (Attempt to) suspend the program.
+##
+sub F_Suspend
+{
+ if ($inDOS && length($line)==0) { # EOF sent
+ $AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar';
+ return;
+ }
+ local $\ = '';
+ print $term_OUT "\r\n";
+ &ResetTTY;
+ eval { kill ("TSTP", 0) };
+ ## We're back....
+ &SetTTY;
+ $force_redraw = 1;
+}
+
+##
+## Ring the bell.
+## Should do something with $var_PreferVisibleBell here, but what?
+##
+sub F_Ding {
+ local $\ = '';
+ print $term_OUT "\007";
+ return; # Undefined return value
+}
+
+##########################################################################
+#### command/file completion ############################################
+##########################################################################
+
+##
+## How Command Completion Works
+##
+## When asked to do a completion operation, readline isolates the word
+## to the immediate left of the cursor (i.e. what's just been typed).
+## This information is then passed to some function (which may be supplied
+## by the user of this package) which will return an array of possible
+## completions.
+##
+## If there is just one, that one is used. Otherwise, they are listed
+## in some way (depends upon $var_TcshCompleteMode).
+##
+## The default is to do filename completion. The function that performs
+## this task is readline'rl_filename_list.
+##
+## A minimal-trouble way to have command-completion is to call
+## readline'rl_basic_commands with an array of command names, such as
+## &readline'rl_basic_commands('quit', 'run', 'set', 'list')
+## Those command names will then be used for completion if the word being
+## completed begins the line. Otherwise, completion is disallowed.
+##
+## The way to have the most power is to provide a function to readline
+## which will accept information about a partial word that needs completed,
+## and will return the appropriate list of possibilities.
+## This is done by setting $readline'rl_completion_function to the name of
+## the function to run.
+##
+## That function will be called with three args ($text, $line, $start).
+## TEXT is the partial word that should be completed. LINE is the entire
+## input line as it stands, and START is the index of the TEXT in LINE
+## (i.e. zero if TEXT is at the beginning of LINE).
+##
+## A cool completion function will look at LINE and START and give context-
+## sensitive completion lists. Consider something that will do completion
+## for two commands
+## cat FILENAME
+## finger USERNAME
+## status [this|that|other]
+##
+## It (untested) might look like:
+##
+## $readline'rl_completion_function = "main'complete";
+## sub complete { local($text, $_, $start) = @_;
+## ## return commands which may match if at the beginning....
+## return grep(/^$text/, 'cat', 'finger') if $start == 0;
+## return &rl_filename_list($text) if /^cat\b/;
+## return &my_namelist($text) if /^finger\b/;
+## return grep(/^text/, 'this', 'that','other') if /^status\b/;
+## ();
+## }
+## Of course, a real completion function would be more robust, but you
+## get the idea (I hope).
+##
+
+##
+## List possible completions
+##
+sub F_PossibleCompletions
+{
+ &complete_internal('?');
+}
+
+##
+## List possible completions
+##
+sub F_InsertPossibleCompletions
+{
+ &complete_internal('*');
+}
+
+##
+## Do a completion operation.
+## If the last thing we did was a completion operation, we'll
+## now list the options available (under normal emacs mode).
+##
+## Under TcshCompleteMode, each contiguous subsequent completion operation
+## lists another of the possible options.
+##
+## Returns true if a completion was done, false otherwise, so vi completion
+## routines can test it.
+##
+sub F_Complete
+{
+ if ($lastcommand eq 'F_Complete') {
+ if ($var_TcshCompleteMode && @tcsh_complete_selections > 0) {
+ substr($line, $tcsh_complete_start, $tcsh_complete_len)
+ = $tcsh_complete_selections[0];
+ $D -= $tcsh_complete_len;
+ $tcsh_complete_len = length($tcsh_complete_selections[0]);
+ $D += $tcsh_complete_len;
+ push(@tcsh_complete_selections, shift(@tcsh_complete_selections));
+ } else {
+ &complete_internal('?') or return;
+ }
+ } else {
+ @tcsh_complete_selections = ();
+ &complete_internal("\t") or return;
+ }
+
+ 1;
+}
+
+##
+## The meat of command completion. Patterned closely after GNU's.
+##
+## The supposedly partial word at the cursor is "completed" as per the
+## single argument:
+## "\t" complete as much of the word as is unambiguous
+## "?" list possibilities.
+## "*" replace word with all possibilities. (who would use this?)
+##
+## A few notable variables used:
+## $rl_completer_word_break_characters
+## -- characters in this string break a word.
+## $rl_special_prefixes
+## -- but if in this string as well, remain part of that word.
+##
+## Returns true if a completion was done, false otherwise, so vi completion
+## routines can test it.
+##
+sub complete_internal
+{
+ my $what_to_do = shift;
+ my ($point, $end) = ($D, $D);
+
+ # In vi mode, complete if the cursor is at the *end* of a word, not
+ # after it.
+ ($point++, $end++) if $Vi_mode;
+
+ if ($point)
+ {
+ ## Not at the beginning of the line; Isolate the word to be completed.
+ 1 while (--$point && (-1 == index($rl_completer_word_break_characters,
+ substr($line, $point, 1))));
+
+ # Either at beginning of line or at a word break.
+ # If at a word break (that we don't want to save), skip it.
+ $point++ if (
+ (index($rl_completer_word_break_characters,
+ substr($line, $point, 1)) != -1) &&
+ (index($rl_special_prefixes, substr($line, $point, 1)) == -1)
+ );
+ }
+
+ my $text = substr($line, $point, $end - $point);
+ $rl_completer_terminator_character = ' ';
+ @matches = &completion_matches($rl_completion_function,$text,$line,$point);
+
+ if (@matches == 0) {
+ return &F_Ding;
+ } elsif ($what_to_do eq "\t") {
+ my $replacement = shift(@matches);
+ $replacement .= $rl_completer_terminator_character if @matches == 1;
+ &F_Ding if @matches != 1;
+ if ($var_TcshCompleteMode) {
+ @tcsh_complete_selections = (@matches, $text);
+ $tcsh_complete_start = $point;
+ $tcsh_complete_len = length($replacement);
+ }
+ if ($replacement ne '') {
+ substr($line, $point, $end-$point) = $replacement;
+ $D = $D - ($end - $point) + length($replacement);
+ }
+ } elsif ($what_to_do eq '?') {
+ shift(@matches); ## remove prepended common prefix
+ local $\ = '';
+ print $term_OUT "\n\r";
+ # print "@matches\n\r";
+ &pretty_print_list (@matches);
+ $force_redraw = 1;
+ } elsif ($what_to_do eq '*') {
+ shift(@matches); ## remove common prefix.
+ local $" = $rl_completer_terminator_character;
+ my $replacement = "@matches$rl_completer_terminator_character";
+ substr($line, $point, $end-$point) = $replacement; ## insert all.
+ $D = $D - ($end - $point) + length($replacement);
+ } else {
+ warn "\r\n[Internal error]";
+ return &F_Ding;
+ }
+
+ 1;
+}
+
+##
+## completion_matches(func, text, line, start)
+##
+## FUNC is a function to call as FUNC(TEXT, LINE, START)
+## where TEXT is the item to be completed
+## LINE is the whole command line, and
+## START is the starting index of TEXT in LINE.
+## The FUNC should return a list of items that might match.
+##
+## completion_matches will return that list, with the longest common
+## prefix prepended as the first item of the list. Therefor, the list
+## will either be of zero length (meaning no matches) or of 2 or more.....
+##
+
+## Works with &rl_basic_commands. Return items from @rl_basic_commands
+## that start with the pattern in $text.
+sub use_basic_commands {
+ my ($text, $line, $start) = @_;
+ return () if $start != 0;
+ grep(/^$text/, @rl_basic_commands);
+}
+
+sub completion_matches
+{
+ my ($func, $text, $line, $start) = @_;
+
+ ## get the raw list
+ my @matches;
+
+ #print qq/\r\neval("\@matches = &$func(\$text, \$line, \$start)\n\r/;#DEBUG
+ #eval("\@matches = &$func(\$text, \$line, \$start);1") || warn "$@ ";
+ @matches = &$func($text, $line, $start);
+
+ ## if anything returned , find the common prefix among them
+ if (@matches) {
+ my $prefix = $matches[0];
+ my $len = length($prefix);
+ for ($i = 1; $i < @matches; $i++) {
+ next if substr($matches[$i], 0, $len) eq $prefix;
+ $prefix = substr($prefix, 0, --$len);
+ last if $len == 0;
+ $i--; ## retry this one to see if the shorter one matches.
+ }
+ unshift(@matches, $prefix); ## make common prefix the first thing.
+ }
+ @matches;
+}
+
+##
+## For use in passing to completion_matches(), returns a list of
+## filenames that begin with the given pattern. The user of this package
+## can set $rl_completion_function to 'rl_filename_list' to restore the
+## default of filename matching if they'd changed it earlier, either
+## directly or via &rl_basic_commands.
+##
+sub rl_filename_list
+{
+ my $pattern = $_[0];
+ my @files = (<$pattern*>);
+ if ($var_CompleteAddsuffix) {
+ foreach (@files) {
+ if (-l $_) {
+ $_ .= '@';
+ } elsif (-d _) {
+ $_ .= '/';
+ } elsif (-x _) {
+ $_ .= '*';
+ } elsif (-S _ || -p _) {
+ $_ .= '=';
+ }
+ }
+ }
+ return @files;
+}
+
+##
+## For use by the user of the package. Called with a list of possible
+## commands, will allow command completion on those commands, but only
+## for the first word on a line.
+## For example: &rl_basic_commands('set', 'quit', 'type', 'run');
+##
+## This is for people that want quick and simple command completion.
+## A more thoughtful implementation would set $rl_completion_function
+## to a routine that would look at the context of the word being completed
+## and return the appropriate possibilities.
+##
+sub rl_basic_commands
+{
+ @rl_basic_commands = @_;
+ $rl_completion_function = 'use_basic_commands';
+}
+
+##
+## Print an array in columns like ls -C. Originally based on stuff
+## (lsC2.pl) by utashiro@sran230.sra.co.jp (Kazumasa Utashiro).
+##
+sub pretty_print_list
+{
+ my @list = @_;
+ return unless @list;
+ my ($lines, $columns, $mark, $index);
+
+ ## find width of widest entry
+ my $maxwidth = 0;
+ grep(length > $maxwidth && ($maxwidth = length), @list);
+ $maxwidth++;
+
+ $columns = $maxwidth >= $rl_screen_width
+ ? 1 : int($rl_screen_width / $maxwidth);
+
+ ## if there's enough margin to interspurse among the columns, do so.
+ $maxwidth += int(($rl_screen_width % $maxwidth) / $columns);
+
+ $lines = int((@list + $columns - 1) / $columns);
+ $columns-- while ((($lines * $columns) - @list + 1) > $lines);
+
+ $mark = $#list - $lines;
+ local $\ = '';
+ for ($l = 0; $l < $lines; $l++) {
+ for ($index = $l; $index <= $mark; $index += $lines) {
+ printf("%-$ {maxwidth}s", $list[$index]);
+ }
+ print $term_OUT $list[$index] if $index <= $#list;
+ print $term_OUT "\n\r";
+ }
+}
+
+##----------------- Vi Routines --------------------------------
+
+sub F_ViAcceptLine
+{
+ &F_AcceptLine();
+ &F_ViInput();
+}
+
+# Repeat the most recent one of these vi commands:
+#
+# a A c C d D i I p P r R s S x X ~
+#
+sub F_ViRepeatLastCommand {
+ my($count) = @_;
+ return &F_Ding if !$Last_vi_command;
+
+ my @lastcmd = @$Last_vi_command;
+
+ # Multiply @lastcmd's numeric arg by $count.
+ unless ($count == 1) {
+
+ my $n = '';
+ while (@lastcmd and $lastcmd[0] =~ /^\d$/) {
+ $n *= 10;
+ $n += shift(@lastcmd);
+ }
+ $count *= $n unless $n eq '';
+ unshift(@lastcmd, split(//, $count));
+ }
+
+ push(@Pending, @lastcmd);
+}
+
+sub F_ViMoveCursor
+{
+ my($count, $ord) = @_;
+
+ my $new_cursor = &get_position($count, $ord, undef, $Vi_move_patterns);
+ return &F_Ding if !defined $new_cursor;
+
+ $D = $new_cursor;
+}
+
+sub F_ViFindMatchingParens {
+
+ # Move to the first parens at or after $D
+ my $old_d = $D;
+ &forward_scan(1, q/[^[\](){}]*/);
+ my $parens = substr($line, $D, 1);
+
+ my $mate_direction = {
+ '(' => [ ')', 1 ],
+ '[' => [ ']', 1 ],
+ '{' => [ '}', 1 ],
+ ')' => [ '(', -1 ],
+ ']' => [ '[', -1 ],
+ '}' => [ '{', -1 ],
+
+ }->{$parens};
+
+ return &F_Ding() unless $mate_direction;
+
+ my($mate, $direction) = @$mate_direction;
+
+ my $lvl = 1;
+ while ($lvl) {
+ last if !$D && ($direction < 0);
+ &F_ForwardChar($direction);
+ last if &at_end_of_line;
+ my $c = substr($line, $D, 1);
+ if ($c eq $parens) {
+ $lvl++;
+ }
+ elsif ($c eq $mate) {
+ $lvl--;
+ }
+ }
+
+ if ($lvl) {
+ # We didn't find a match
+ $D = $old_d;
+ return &F_Ding();
+ }
+}
+
+sub F_ViForwardFindChar {
+ &do_findchar(1, 1, @_);
+}
+
+sub F_ViBackwardFindChar {
+ &do_findchar(-1, 0, @_);
+}
+
+sub F_ViForwardToChar {
+ &do_findchar(1, 0, @_);
+}
+
+sub F_ViBackwardToChar {
+ &do_findchar(-1, 1, @_);
+}
+
+sub F_ViMoveCursorTo
+{
+ &do_findchar(1, -1, @_);
+}
+
+sub F_ViMoveCursorFind
+{
+ &do_findchar(1, 0, @_);
+}
+
+
+sub F_ViRepeatFindChar {
+ my($n) = @_;
+ return &F_Ding if !defined $Last_findchar;
+ &findchar(@$Last_findchar, $n);
+}
+
+sub F_ViInverseRepeatFindChar {
+ my($n) = @_;
+ return &F_Ding if !defined $Last_findchar;
+ my($c, $direction, $offset) = @$Last_findchar;
+ &findchar($c, -$direction, $offset, $n);
+}
+
+sub do_findchar {
+ my($direction, $offset, $n) = @_;
+ my $c = &getc_with_pending;
+ $c = &getc_with_pending if $c eq "\cV";
+ return &F_ViCommandMode if $c eq "\e";
+ $Last_findchar = [$c, $direction, $offset];
+ &findchar($c, $direction, $offset, $n);
+}
+
+sub findchar {
+ my($c, $direction, $offset, $n) = @_;
+ my $old_d = $D;
+ while ($n) {
+ last if !$D && ($direction < 0);
+ &F_ForwardChar($direction);
+ last if &at_end_of_line;
+ my $char = substr($line, $D, 1);
+ $n-- if substr($line, $D, 1) eq $c;
+ }
+ if ($n) {
+ # Not found
+ $D = $old_d;
+ return &F_Ding;
+ }
+ &F_ForwardChar($offset);
+}
+
+sub F_ViMoveToColumn {
+ my($n) = @_;
+ $D = 0;
+ my $col = 1;
+ while (!&at_end_of_line and $col < $n) {
+ my $c = substr($line, $D, 1);
+ if ($c eq "\t") {
+ $col += 7;
+ $col -= ($col % 8) - 1;
+ }
+ else {
+ $col++;
+ }
+ $D += &CharSize($D);
+ }
+}
+
+sub start_dot_buf {
+ my($count, $ord) = @_;
+ $Dot_buf = [pack('c', $ord)];
+ unshift(@$Dot_buf, split(//, $count)) if $count > 1;
+ $Dot_state = savestate();
+}
+
+sub end_dot_buf {
+ # We've recognized an editing command
+
+ # Save the command keystrokes for use by '.'
+ $Last_vi_command = $Dot_buf;
+ undef $Dot_buf;
+
+ # Save the pre-command state for use by 'u' and 'U';
+ $Vi_undo_state = $Dot_state;
+ $Vi_undo_all_state = $Dot_state if !$Vi_undo_all_state;
+
+ # Make sure the current line is treated as new line for history purposes.
+ $rl_HistoryIndex = $#rl_History + 1;
+}
+
+sub save_dot_buf {
+ &start_dot_buf(@_);
+ &end_dot_buf;
+}
+
+sub F_ViUndo {
+ return &F_Ding unless defined $Vi_undo_state;
+ my $state = savestate();
+ &getstate($Vi_undo_state);
+ $Vi_undo_state = $state;
+}
+
+sub F_ViUndoAll {
+ $Vi_undo_state = $Vi_undo_all_state;
+ &F_ViUndo;
+}
+
+sub F_ViChange
+{
+ my($count, $ord) = @_;
+ &start_dot_buf(@_);
+ &do_delete($count, $ord, $Vi_change_patterns) || return();
+ &vi_input_mode;
+}
+
+sub F_ViDelete
+{
+ my($count, $ord) = @_;
+ &start_dot_buf(@_);
+ &do_delete($count, $ord, $Vi_delete_patterns);
+ &end_dot_buf;
+}
+
+sub do_delete {
+
+ my($count, $ord, $poshash) = @_;
+
+ my $other_end = &get_position($count, undef, $ord, $poshash);
+ return &F_Ding if !defined $other_end;
+
+ if ($other_end < 0) {
+ # dd - delete entire line
+ &kill_text(0, length($line), 1);
+ }
+ else {
+ &kill_text($D, $other_end, 1);
+ }
+
+ 1; # True return value
+}
+
+sub F_ViDeleteChar {
+ my($count) = @_;
+ &save_dot_buf(@_);
+ my $other_end = $D + $count;
+ $other_end = length($line) if $other_end > length($line);
+ &kill_text($D, $other_end, 1);
+}
+
+sub F_ViBackwardDeleteChar {
+ my($count) = @_;
+ &save_dot_buf(@_);
+ my $other_end = $D - $count;
+ $other_end = 0 if $other_end < 0;
+ &kill_text($other_end, $D, 1);
+ $D = $other_end;
+}
+
+##
+## Prepend line with '#', add to history, and clear the input buffer
+## (this feature was borrowed from ksh).
+##
+sub F_SaveLine
+{
+ local $\ = '';
+ $line = '#'.$line;
+ &redisplay();
+ print $term_OUT "\r\n";
+ &add_line_to_history;
+ $line_for_revert = '';
+ &get_line_from_history(scalar @rl_History);
+ &F_ViInput() if $Vi_mode;
+}
+
+#
+# Come here if we see a non-positioning keystroke when a positioning
+# keystroke is expected.
+#
+sub F_ViNonPosition {
+ # Not a positioning command - undefine the cursor to indicate the error
+ # to get_position().
+ undef $D;
+}
+
+#
+# Come here if we see <esc><char>, but *not* an arrow key or other
+# mapped sequence, when a positioning keystroke is expected.
+#
+sub F_ViPositionEsc {
+ my($count, $ord) = @_;
+
+ # We got <esc><char> in vipos mode. Put <char> back onto the
+ # input stream and terminate the positioning command.
+ unshift(@Pending, pack('c', $ord));
+ &F_ViNonPosition;
+}
+
+# Interpret vi positioning commands
+sub get_position {
+ my ($count, $ord, $fullline_ord, $poshash) = @_;
+
+ # Manipulate a copy of the cursor, not the real thing
+ local $D = $D;
+
+ # $ord (first character of positioning command) is an optional argument.
+ $ord = ord(&getc_with_pending) if !defined $ord;
+
+ # Detect double character (for full-line operation, e.g. dd)
+ return -1 if defined $fullline_ord and $ord == $fullline_ord;
+
+ my $re = $poshash->{$ord};
+
+ if ($re) {
+ my $c = pack('c', $ord);
+ if (lc($c) eq 'b') {
+ &backward_scan($count, $re);
+ }
+ else {
+ &forward_scan($count, $re);
+ }
+ }
+ else {
+ # Move the local copy of the cursor
+ &do_command($var_EditingMode{'vipos'}, $count, $ord);
+ }
+
+ # Return the new cursor (undef if illegal command)
+ $D;
+}
+
+##
+## Go to first non-space character of line.
+##
+sub F_ViFirstWord
+{
+ $D = 0;
+ &forward_scan(1, q{\s+});
+}
+
+sub forward_scan {
+ my($count, $re) = @_;
+ while ($count--) {
+ last unless substr($line, $D) =~ m{^($re)};
+ $D += length($1);
+ }
+}
+
+sub backward_scan {
+ my($count, $re) = @_;
+ while ($count--) {
+ last unless substr($line, 0, $D) =~ m{($re)$};
+ $D -= length($1);
+ }
+}
+
+# Note: like the emacs case transforms, this doesn't work for
+# two-byte characters.
+sub F_ViToggleCase {
+ my($count) = @_;
+ &save_dot_buf(@_);
+ while ($count-- > 0) {
+ substr($line, $D, 1) =~ tr/A-Za-z/a-zA-Z/;
+ &F_ForwardChar(1);
+ if (&at_end_of_line) {
+ &F_BackwardChar(1);
+ last;
+ }
+ }
+}
+
+# Go to the numbered history line, as listed by the 'H' command, i.e. the
+# current $line is line 1, the youngest line in @rl_History is 2, etc.
+sub F_ViHistoryLine {
+ my($n) = @_;
+ &get_line_from_history(@rl_History - $n + 1);
+}
+
+sub get_line_from_history {
+ my($n) = @_;
+ return &F_Ding if $n < 0 or $n > @rl_History;
+ return if $n == $rl_HistoryIndex;
+
+ # If we're moving from the currently-edited line, save it for later.
+ $line_for_revert = $line if $rl_HistoryIndex == @rl_History;
+
+ # Get line from history buffer (or from saved edit line).
+ $line = ($n == @rl_History) ? $line_for_revert : $rl_History[$n];
+ $D = $Vi_mode ? 0 : length $line;
+
+ # Subsequent 'U' will bring us back to this point.
+ $Vi_undo_all_state = savestate() if $Vi_mode;
+
+ $rl_HistoryIndex = $n;
+}
+
+sub F_PrintHistory {
+ my($count) = @_;
+
+ $count = 20 if $count == 1; # Default - assume 'H', not '1H'
+ my $end = $rl_HistoryIndex + $count/2;
+ $end = @rl_History if $end > @rl_History;
+ my $start = $end - $count + 1;
+ $start = 0 if $start < 0;
+
+ my $lmh = length $rl_MaxHistorySize;
+
+ my $lspace = ' ' x ($lmh+3);
+ my $hdr = "$lspace-----";
+ $hdr .= " (Use ESC <num> UP to retrieve command <num>) -----" unless $Vi_mode;
+ $hdr .= " (Use '<num>G' to retrieve command <num>) -----" if $Vi_mode;
+
+ local ($\, $,) = ('','');
+ print "\n$hdr\n";
+ print $lspace, ". . .\n" if $start > 0;
+ my $i;
+ my $shift = ($Vi_mode != 0);
+ for $i ($start .. $end) {
+ print + ($i == $rl_HistoryIndex) ? '>' : ' ',
+
+ sprintf("%${lmh}d: ", @rl_History - $i + $shift),
+
+ ($i < @rl_History) ? $rl_History[$i] :
+ ($i == $rl_HistoryIndex) ? $line :
+ $line_for_revert,
+
+ "\n";
+ }
+ print $lspace, ". . .\n" if $end < @rl_History;
+ print "$hdr\n";
+
+ &force_redisplay();
+
+ &F_ViInput() if $line eq '' && $Vi_mode;
+}
+
+# Redisplay the line, without attempting any optimization
+sub force_redisplay {
+ local $force_redraw = 1;
+ &redisplay(@_);
+}
+
+# Search history for matching string. As with vi in nomagic mode, the
+# ^, $, \<, and \> positional assertions, the \* quantifier, the \.
+# character class, and the \[ character class delimiter all have special
+# meaning here.
+sub F_ViSearch {
+ my($n, $ord) = @_;
+
+ my $c = pack('c', $ord);
+
+ my $str = &get_vi_search_str($c);
+ if (!defined $str) {
+ # Search aborted by deleting the '/' at the beginning of the line
+ return &F_ViInput() if $line eq '';
+ return();
+ }
+
+ # Null string repeats last search
+ if ($str eq '') {
+ return &F_Ding unless defined $Vi_search_re;
+ }
+ else {
+ # Convert to a regular expression. Interpret $str Like vi in nomagic
+ # mode: '^', '$', '\<', and '\>' positional assertions, '\*'
+ # quantifier, '\.' and '\[]' character classes.
+
+ my @chars = ($str =~ m{(\\?.)}g);
+ my(@re, @tail);
+ unshift(@re, shift(@chars)) if @chars and $chars[0] eq '^';
+ push (@tail, pop(@chars)) if @chars and $chars[-1] eq '$';
+ my $in_chclass;
+ my %chmap = (
+ '\<' => '\b(?=\w)',
+ '\>' => '(?<=\w)\b',
+ '\*' => '*',
+ '\[' => '[',
+ '\.' => '.',
+ );
+ my $ch;
+ foreach $ch (@chars) {
+ if ($in_chclass) {
+ # Any backslashes in vi char classes are literal
+ push(@re, "\\") if length($ch) > 1;
+ push(@re, $ch);
+ $in_chclass = 0 if $ch =~ /\]$/;
+ }
+ else {
+ push(@re, (length $ch == 2) ? ($chmap{$ch} || $ch) :
+ ($ch =~ /^\w$/) ? $ch :
+ ("\\", $ch));
+ $in_chclass = 1 if $ch eq '\[';
+ }
+ }
+ my $re = join('', @re, @tail);
+ $Vi_search_re = q{$re};
+ }
+
+ local $reverse = $Vi_search_reverse = ($c eq '/') ? 1 : 0;
+ &do_vi_search();
+}
+
+sub F_ViRepeatSearch {
+ my($n, $ord) = @_;
+ my $c = pack('c', $ord);
+ return &F_Ding unless defined $Vi_search_re;
+ local $reverse = $Vi_search_reverse;
+ $reverse ^= 1 if $c eq 'N';
+ &do_vi_search();
+}
+
+## returns a new $i or -1 if not found.
+sub vi_search {
+ my ($i) = @_;
+ return -1 if $i < 0 || $i > $#rl_History; ## for safety
+ while (1) {
+ return $i if $rl_History[$i] =~ /$Vi_search_re/;
+ if ($reverse) {
+ return -1 if $i-- == 0;
+ } else {
+ return -1 if $i++ == $#rl_History;
+ }
+ }
+}
+
+sub do_vi_search {
+ my $incr = $reverse ? -1 : 1;
+
+ my $i = &vi_search($rl_HistoryIndex + $incr);
+ return &F_Ding if $i < 0; # Not found.
+
+ $rl_HistoryIndex = $i;
+ ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
+}
+
+# Using local $line, $D, and $prompt, get and return the string to search for.
+sub get_vi_search_str {
+ my($c) = @_;
+
+ local $prompt = $prompt . $c;
+ local ($line, $D) = ('', 0);
+ &redisplay();
+
+ # Gather a search string in our local $line.
+ while ($lastcommand ne 'F_ViEndSearch') {
+ &do_command($var_EditingMode{'visearch'}, 1, ord(&getc_with_pending));
+ &redisplay();
+
+ # We've backspaced past beginning of line
+ return undef if !defined $line;
+ }
+ $line;
+}
+
+sub F_ViEndSearch {}
+
+sub F_ViSearchBackwardDeleteChar {
+ if ($line eq '') {
+ # Backspaced past beginning of line - terminate search mode
+ undef $line;
+ }
+ else {
+ &F_BackwardDeleteChar(@_);
+ }
+}
+
+##
+## Kill entire line and enter input mode
+##
+sub F_ViChangeEntireLine
+{
+ &start_dot_buf(@_);
+ kill_text(0, length($line), 1);
+ &vi_input_mode;
+}
+
+##
+## Kill characters and enter input mode
+##
+sub F_ViChangeChar
+{
+ &start_dot_buf(@_);
+ &F_DeleteChar(@_);
+ &vi_input_mode;
+}
+
+sub F_ViReplaceChar
+{
+ &start_dot_buf(@_);
+ my $c = &getc_with_pending;
+ $c = &getc_with_pending if $c eq "\cV"; # ctrl-V
+ return &F_ViCommandMode if $c eq "\e";
+ &end_dot_buf;
+
+ local $InsertMode = 0;
+ local $D = $D; # Preserve cursor position
+ &F_SelfInsert(1, ord($c));
+}
+
+##
+## Kill from cursor to end of line and enter input mode
+##
+sub F_ViChangeLine
+{
+ &start_dot_buf(@_);
+ &F_KillLine(@_);
+ &vi_input_mode;
+}
+
+sub F_ViDeleteLine
+{
+ &save_dot_buf(@_);
+ &F_KillLine(@_);
+}
+
+sub F_ViPut
+{
+ my($count) = @_;
+ &save_dot_buf(@_);
+ my $text2add = $KillBuffer x $count;
+ my $ll = length($line);
+ $D++;
+ $D = $ll if $D > $ll;
+ substr($line, $D, 0) = $KillBuffer x $count;
+ $D += length($text2add) - 1;
+}
+
+sub F_ViPutBefore
+{
+ &save_dot_buf(@_);
+ &TextInsert($_[0], $KillBuffer);
+}
+
+sub F_ViYank
+{
+ my($count, $ord) = @_;
+ my $pos = &get_position($count, undef, $ord, $Vi_yank_patterns);
+ &F_Ding if !defined $pos;
+ if ($pos < 0) {
+ # yy
+ &F_ViYankLine;
+ }
+ else {
+ my($from, $to) = ($pos > $D) ? ($D, $pos) : ($pos, $D);
+ $KillBuffer = substr($line, $from, $to-$from);
+ }
+}
+
+sub F_ViYankLine
+{
+ $KillBuffer = $line;
+}
+
+sub F_ViInput
+{
+ @_ = (1, ord('i')) if !@_;
+ &start_dot_buf(@_);
+ &vi_input_mode;
+}
+
+sub F_ViBeginInput
+{
+ &start_dot_buf(@_);
+ &F_BeginningOfLine;
+ &vi_input_mode;
+}
+
+sub F_ViReplaceMode
+{
+ &start_dot_buf(@_);
+ $InsertMode = 0;
+ $var_EditingMode = $var_EditingMode{'vi'};
+ $Vi_mode = 1;
+}
+
+sub vi_input_mode
+{
+ $InsertMode = 1;
+ $var_EditingMode = $var_EditingMode{'vi'};
+ $Vi_mode = 1;
+}
+
+# The previous keystroke was an escape, but the sequence was not recognized
+# as a mapped sequence (like an arrow key). Enter vi comand mode and
+# process this keystroke.
+sub F_ViAfterEsc {
+ my($n, $ord) = @_;
+ &F_ViCommandMode;
+ &do_command($var_EditingMode, 1, $ord);
+}
+
+sub F_ViAppend
+{
+ &start_dot_buf(@_);
+ &vi_input_mode;
+ &F_ForwardChar;
+}
+
+sub F_ViAppendLine
+{
+ &start_dot_buf(@_);
+ &vi_input_mode;
+ &F_EndOfLine;
+}
+
+sub F_ViCommandMode
+{
+ $var_EditingMode = $var_EditingMode{'vicmd'};
+ $Vi_mode = 1;
+}
+
+sub F_ViAcceptInsert {
+ local $in_accept_line = 1;
+ &F_ViEndInsert;
+ &F_ViAcceptLine;
+}
+
+sub F_ViEndInsert
+{
+ if ($Dot_buf) {
+ if ($line eq '' and $Dot_buf->[0] eq 'i') {
+ # We inserted nothing into an empty $line - assume it was a
+ # &F_ViInput() call with no arguments, and don't save command.
+ undef $Dot_buf;
+ }
+ else {
+ # Regardless of which keystroke actually terminated this insert
+ # command, replace it with an <esc> in the dot buffer.
+ @{$Dot_buf}[-1] = "\e";
+ &end_dot_buf;
+ }
+ }
+ &F_ViCommandMode;
+ # Move cursor back to the last inserted character, but not when
+ # we're about to accept a line of input
+ &F_BackwardChar(1) unless $in_accept_line;
+}
+
+sub F_ViDigit {
+ my($count, $ord) = @_;
+
+ my $n = 0;
+ my $ord0 = ord('0');
+ while (1) {
+
+ $n *= 10;
+ $n += $ord - $ord0;
+
+ my $c = &getc_with_pending;
+ return unless defined $c;
+ $ord = ord($c);
+ last unless $c =~ /^\d$/;
+ }
+
+ $n *= $count; # So 2d3w deletes six words
+ $n = $rl_max_numeric_arg if $n > $rl_max_numeric_arg;
+
+ &do_command($var_EditingMode, $n, $ord);
+}
+
+sub F_ViComplete {
+ my($n, $ord) = @_;
+
+ $Dot_state = savestate(); # Completion is undo-able
+ undef $Dot_buf; # but not redo-able
+
+ my $ch;
+ while (1) {
+
+ &F_Complete() or return;
+
+ # Vi likes the cursor one character right of where emacs like it.
+ &F_ForwardChar(1);
+ &force_redisplay();
+
+ # Look ahead to the next input keystroke.
+ $ch = &getc_with_pending();
+ last unless ord($ch) == $ord; # Not a '\' - quit.
+
+ # Another '\' was typed - put the cursor back where &F_Complete left
+ # it, and try again.
+ &F_BackwardChar(1);
+ $lastcommand = 'F_Complete'; # Play along with &F_Complete's kludge
+ }
+ unshift(@Pending, $ch); # Unget the lookahead keystroke
+
+ # Successful completion - enter input mode with cursor beyond end of word.
+ &vi_input_mode;
+}
+
+sub F_ViInsertPossibleCompletions {
+ $Dot_state = savestate(); # Completion is undo-able
+ undef $Dot_buf; # but not redo-able
+
+ &complete_internal('*') or return;
+
+ # Successful completion - enter input mode with cursor beyond end of word.
+ &F_ForwardChar(1);
+ &vi_input_mode;
+}
+
+sub F_ViPossibleCompletions {
+
+ # List possible completions
+ &complete_internal('?');
+
+ # Enter input mode with cursor where we left off.
+ &F_ForwardChar(1);
+ &vi_input_mode;
+}
+
+sub F_SetMark {
+ $rl_mark = $D;
+ pos $line = $rl_mark;
+ $line_rl_mark = $rl_HistoryIndex;
+ $force_redraw = 1;
+}
+
+sub F_ExchangePointAndMark {
+ return F_Ding unless $line_rl_mark == $rl_HistoryIndex;
+ ($rl_mark, $D) = ($D, $rl_mark);
+ pos $line = $rl_mark;
+ $D = length $line if $D > length $line;
+ $force_redraw = 1;
+}
+
+sub F_KillRegion {
+ return F_Ding unless $line_rl_mark == $rl_HistoryIndex;
+ $rl_mark = length $line if $rl_mark > length $line;
+ kill_text($rl_mark, $D, 1);
+ $line_rl_mark = -1; # Disable mark
+}
+
+sub F_CopyRegionAsKill {
+ return F_Ding unless $line_rl_mark == $rl_HistoryIndex;
+ $rl_mark = length $line if $rl_mark > length $line;
+ my ($s, $e) = ($rl_mark, $D);
+ ($s, $e) = ($e, $s) if $s > $e;
+ $ThisCommandKilledText = 1 + $s;
+ $KillBuffer = '' if !$LastCommandKilledText;
+ $KillBuffer .= substr($line, $s, $e - $s);
+}
+
+sub clipboard_set {
+ my $in = shift;
+ if ($^O eq 'os2') {
+ eval {
+ require OS2::Process;
+ OS2::Process::ClipbrdText_set($in); # Do not disable \r\n-conversion
+ 1
+ } and return;
+ } elsif ($^O eq 'MSWin32') {
+ eval {
+ require Win32::Clipboard;
+ Win32::Clipboard::Set($in);
+ 1
+ } and return;
+ }
+ my $mess;
+ if ($ENV{RL_CLCOPY_CMD}) {
+ $mess = "Writing to pipe `$ENV{RL_CLCOPY_CMD}'";
+ open COPY, "| $ENV{RL_CLCOPY_CMD}" or warn("$mess: $!"), return;
+ } elsif (defined $ENV{HOME}) {
+ $mess = "Writing to file `$ENV{HOME}/.rl_cutandpaste'";
+ open COPY, "> $ENV{HOME}/.rl_cutandpaste" or warn("$mess: $!"), return;
+ } else {
+ return;
+ }
+ print COPY $in;
+ close COPY or warn("$mess: closing $!");
+}
+
+sub F_CopyRegionAsKillClipboard {
+ return clipboard_set($line) unless $line_rl_mark == $rl_HistoryIndex;
+ &F_CopyRegionAsKill;
+ clipboard_set($KillBuffer);
+}
+
+sub F_KillRegionClipboard {
+ &F_KillRegion;
+ clipboard_set($KillBuffer);
+}
+
+sub F_YankClipboard
+{
+ remove_selection();
+ my $in;
+ if ($^O eq 'os2') {
+ eval {
+ require OS2::Process;
+ $in = OS2::Process::ClipbrdText();
+ $in =~ s/\r\n/\n/g; # With old versions, or what?
+ }
+ } elsif ($^O eq 'MSWin32') {
+ eval {
+ require Win32::Clipboard;
+ $in = Win32::Clipboard::GetText();
+ $in =~ s/\r\n/\n/g; # is this needed?
+ }
+ } else {
+ my $mess;
+ if ($ENV{RL_PASTE_CMD}) {
+ $mess = "Reading from pipe `$ENV{RL_PASTE_CMD}'";
+ open PASTE, "$ENV{RL_PASTE_CMD} |" or warn("$mess: $!"), return;
+ } elsif (defined $ENV{HOME}) {
+ $mess = "Reading from file `$ENV{HOME}/.rl_cutandpaste'";
+ open PASTE, "< $ENV{HOME}/.rl_cutandpaste" or warn("$mess: $!"), return;
+ }
+ if ($mess) {
+ local $/;
+ $in = <PASTE>;
+ close PASTE or warn("$mess, closing: $!");
+ }
+ }
+ if (defined $in) {
+ $in =~ s/\n+$//;
+ return &TextInsert($_[0], $in);
+ }
+ &TextInsert($_[0], $KillBuffer);
+}
+
+sub F_BeginUndoGroup {
+ push @undoGroupS, $#undo;
+}
+
+sub F_EndUndoGroup {
+ return F_Ding unless @undoGroupS;
+ my $last = pop @undoGroupS;
+ return unless $#undo > $last + 1;
+ my $now = pop @undo;
+ $#undo = $last;
+ push @undo, $now;
+}
+
+sub F_DoNothing { # E.g., reset digit-argument
+ 1;
+}
+
+sub F_ForceMemorizeDigitArgument {
+ $memorizedArg = shift;
+}
+
+sub F_MemorizeDigitArgument {
+ return if defined $memorizedArg;
+ $memorizedArg = shift;
+}
+
+sub F_UnmemorizeDigitArgument {
+ $memorizedArg = undef;
+}
+
+sub F_MemorizePos {
+ $memorizedPos = $D;
+}
+
+# It is assumed that F_MemorizePos was called, then something was inserted,
+# then F_MergeInserts is called with a prefix argument to multiply
+# insertion by
+
+sub F_MergeInserts {
+ my $n = shift;
+ return F_Ding unless defined $memorizedPos and $n > 0;
+ my ($b, $e) = ($memorizedPos, $D);
+ ($b, $e) = ($e, $b) if $e < $b;
+ if ($n) {
+ substr($line, $e, 0) = substr($line, $b, $e - $b) x ($n - 1);
+ } else {
+ substr($line, $b, $e - $b) = '';
+ }
+ $D = $b + ($e - $b) * $n;
+}
+
+sub F_ResetDigitArgument {
+ return F_Ding unless defined $memorizedArg;
+ my $in = &getc_with_pending;
+ return unless defined $in;
+ my $ord = ord $in;
+ local(*KeyMap) = $var_EditingMode;
+ &do_command(*KeyMap, $memorizedArg, $ord);
+}
+
+sub F_BeginPasteGroup {
+ my $c = shift;
+ $memorizedArg = $c unless defined $memorizedArg;
+ F_BeginUndoGroup(1);
+ $memorizedPos = $D;
+}
+
+sub F_EndPasteGroup {
+ my $c = $memorizedArg;
+ undef $memorizedArg;
+ $c = 1 unless defined $c;
+ F_MergeInserts($c);
+ F_EndUndoGroup(1);
+}
+
+sub F_BeginEditGroup {
+ $memorizedArg = shift;
+ F_BeginUndoGroup(1);
+}
+
+sub F_EndEditGroup {
+ undef $memorizedArg;
+ F_EndUndoGroup(1);
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/UI.pm b/Master/tlpkg/tlperl.straw/lib/Term/UI.pm
new file mode 100755
index 00000000000..136f75bb6ad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/UI.pm
@@ -0,0 +1,620 @@
+package Term::UI;
+
+use Carp;
+use Params::Check qw[check allow];
+use Term::ReadLine;
+use Locale::Maketext::Simple Style => 'gettext';
+use Term::UI::History;
+
+use strict;
+
+BEGIN {
+ use vars qw[$VERSION $AUTOREPLY $VERBOSE $INVALID];
+ $VERBOSE = 1;
+ $VERSION = '0.20';
+ $INVALID = loc('Invalid selection, please try again: ');
+}
+
+push @Term::ReadLine::Stub::ISA, __PACKAGE__
+ unless grep { $_ eq __PACKAGE__ } @Term::ReadLine::Stub::ISA;
+
+
+=pod
+
+=head1 NAME
+
+Term::UI - Term::ReadLine UI made easy
+
+=head1 SYNOPSIS
+
+ use Term::UI;
+ use Term::ReadLine;
+
+ my $term = Term::ReadLine->new('brand');
+
+ my $reply = $term->get_reply(
+ prompt => 'What is your favourite colour?',
+ choices => [qw|blue red green|],
+ default => blue,
+ );
+
+ my $bool = $term->ask_yn(
+ prompt => 'Do you like cookies?',
+ default => 'y',
+ );
+
+
+ my $string = q[some_command -option --no-foo --quux='this thing'];
+
+ my ($options,$munged_input) = $term->parse_options($string);
+
+
+ ### don't have Term::UI issue warnings -- default is '1'
+ $Term::UI::VERBOSE = 0;
+
+ ### always pick the default (good for non-interactive terms)
+ ### -- default is '0'
+ $Term::UI::AUTOREPLY = 1;
+
+ ### Retrieve the entire session as a printable string:
+ $hist = Term::UI::History->history_as_string;
+ $hist = $term->history_as_string;
+
+=head1 DESCRIPTION
+
+C<Term::UI> is a transparent way of eliminating the overhead of having
+to format a question and then validate the reply, informing the user
+if the answer was not proper and re-issuing the question.
+
+Simply give it the question you want to ask, optionally with choices
+the user can pick from and a default and C<Term::UI> will DWYM.
+
+For asking a yes or no question, there's even a shortcut.
+
+=head1 HOW IT WORKS
+
+C<Term::UI> places itself at the back of the C<Term::ReadLine>
+C<@ISA> array, so you can call its functions through your term object.
+
+C<Term::UI> uses C<Term::UI::History> to record all interactions
+with the commandline. You can retrieve this history, or alter
+the filehandle the interaction is printed to. See the
+C<Term::UI::History> manpage or the C<SYNOPSIS> for details.
+
+=head1 METHODS
+
+=head2 $reply = $term->get_reply( prompt => 'question?', [choices => \@list, default => $list[0], multi => BOOL, print_me => "extra text to print & record", allow => $ref] );
+
+C<get_reply> asks a user a question, and then returns the reply to the
+caller. If the answer is invalid (more on that below), the question will
+be reposed, until a satisfactory answer has been entered.
+
+You have the option of providing a list of choices the user can pick from
+using the C<choices> argument. If the answer is not in the list of choices
+presented, the question will be reposed.
+
+If you provide a C<default> answer, this will be returned when either
+C<$AUTOREPLY> is set to true, (see the C<GLOBAL VARIABLES> section further
+below), or when the user just hits C<enter>.
+
+You can indicate that the user is allowed to enter multiple answers by
+toggling the C<multi> flag. Note that a list of answers will then be
+returned to you, rather than a simple string.
+
+By specifying an C<allow> hander, you can yourself validate the answer
+a user gives. This can be any of the types that the Params::Check C<allow>
+function allows, so please refer to that manpage for details.
+
+Finally, you have the option of adding a C<print_me> argument, which is
+simply printed before the prompt. It's printed to the same file handle
+as the rest of the questions, so you can use this to keep track of a
+full session of Q&A with the user, and retrieve it later using the
+C<< Term::UI->history_as_string >> function.
+
+See the C<EXAMPLES> section for samples of how to use this function.
+
+=cut
+
+sub get_reply {
+ my $term = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ default => { default => undef, strict_type => 1 },
+ prompt => { default => '', strict_type => 1, required => 1 },
+ choices => { default => [], strict_type => 1 },
+ multi => { default => 0, allow => [0, 1] },
+ allow => { default => qr/.*/ },
+ print_me => { default => '', strict_type => 1 },
+ };
+
+ my $args = check( $tmpl, \%hash, $VERBOSE )
+ or ( carp( loc(q[Could not parse arguments]) ), return );
+
+
+ ### add this to the prompt to indicate the default
+ ### answer to the question if there is one.
+ my $prompt_add;
+
+ ### if you supplied several choices to pick from,
+ ### we'll print them seperately before the prompt
+ if( @{$args->{choices}} ) {
+ my $i;
+
+ for my $choice ( @{$args->{choices}} ) {
+ $i++; # the answer counter -- but humans start counting
+ # at 1 :D
+
+ ### so this choice is the default? add it to 'prompt_add'
+ ### so we can construct a "foo? [DIGIT]" type prompt
+ $prompt_add = $i if (defined $args->{default} and $choice eq $args->{default});
+
+ ### create a "DIGIT> choice" type line
+ $args->{print_me} .= sprintf "\n%3s> %-s", $i, $choice;
+ }
+
+ ### we listed some choices -- add another newline for
+ ### pretty printing
+ $args->{print_me} .= "\n" if $i;
+
+ ### allowable answers are now equal to the choices listed
+ $args->{allow} = $args->{choices};
+
+ ### no choices, but a default? set 'prompt_add' to the default
+ ### to construct a 'foo? [DEFAULT]' type prompt
+ } elsif ( defined $args->{default} ) {
+ $prompt_add = $args->{default};
+ }
+
+ ### we set up the defaults, prompts etc, dispatch to the readline call
+ return $term->_tt_readline( %$args, prompt_add => $prompt_add );
+
+}
+
+=head2 $bool = $term->ask_yn( prompt => "your question", [default => (y|1,n|0), print_me => "extra text to print & record"] )
+
+Asks a simple C<yes> or C<no> question to the user, returning a boolean
+indicating C<true> or C<false> to the caller.
+
+The C<default> answer will automatically returned, if the user hits
+C<enter> or if C<$AUTOREPLY> is set to true. See the C<GLOBAL VARIABLES>
+section further below.
+
+Also, you have the option of adding a C<print_me> argument, which is
+simply printed before the prompt. It's printed to the same file handle
+as the rest of the questions, so you can use this to keep track of a
+full session of Q&A with the user, and retrieve it later using the
+C<< Term::UI->history_as_string >> function.
+
+
+See the C<EXAMPLES> section for samples of how to use this function.
+
+=cut
+
+sub ask_yn {
+ my $term = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ default => { default => undef, allow => [qw|0 1 y n|],
+ strict_type => 1 },
+ prompt => { default => '', required => 1, strict_type => 1 },
+ print_me => { default => '', strict_type => 1 },
+ multi => { default => 0, no_override => 1 },
+ choices => { default => [qw|y n|], no_override => 1 },
+ allow => { default => [qr/^y(?:es)?$/i, qr/^n(?:o)?$/i],
+ no_override => 1
+ },
+ };
+
+ my $args = check( $tmpl, \%hash, $VERBOSE ) or return undef;
+
+ ### uppercase the default choice, if there is one, to be added
+ ### to the prompt in a 'foo? [Y/n]' type style.
+ my $prompt_add;
+ { my @list = @{$args->{choices}};
+ if( defined $args->{default} ) {
+
+ ### if you supplied the default as a boolean, rather than y/n
+ ### transform it to a y/n now
+ $args->{default} = $args->{default} =~ /\d/
+ ? { 0 => 'n', 1 => 'y' }->{ $args->{default} }
+ : $args->{default};
+
+ @list = map { lc $args->{default} eq lc $_
+ ? uc $args->{default}
+ : $_
+ } @list;
+ }
+
+ $prompt_add .= join("/", @list);
+ }
+
+ my $rv = $term->_tt_readline( %$args, prompt_add => $prompt_add );
+
+ return $rv =~ /^y/i ? 1 : 0;
+}
+
+
+
+sub _tt_readline {
+ my $term = shift;
+ my %hash = @_;
+
+ local $Params::Check::VERBOSE = 0; # why is this?
+ local $| = 1; # print ASAP
+
+
+ my ($default, $prompt, $choices, $multi, $allow, $prompt_add, $print_me);
+ my $tmpl = {
+ default => { default => undef, strict_type => 1,
+ store => \$default },
+ prompt => { default => '', strict_type => 1, required => 1,
+ store => \$prompt },
+ choices => { default => [], strict_type => 1,
+ store => \$choices },
+ multi => { default => 0, allow => [0, 1], store => \$multi },
+ allow => { default => qr/.*/, store => \$allow, },
+ prompt_add => { default => '', store => \$prompt_add },
+ print_me => { default => '', store => \$print_me },
+ };
+
+ check( $tmpl, \%hash, $VERBOSE ) or return;
+
+ ### prompts for Term::ReadLine can't be longer than one line, or
+ ### it can display wonky on some terminals.
+ history( $print_me ) if $print_me;
+
+
+ ### we might have to add a default value to the prompt, to
+ ### show the user what will be picked by default:
+ $prompt .= " [$prompt_add]: " if $prompt_add;
+
+
+ ### are we in autoreply mode?
+ if ($AUTOREPLY) {
+
+ ### you used autoreply, but didnt provide a default!
+ carp loc(
+ q[You have '%1' set to true, but did not provide a default!],
+ '$AUTOREPLY'
+ ) if( !defined $default && $VERBOSE);
+
+ ### print it out for visual feedback
+ history( join ' ', grep { defined } $prompt, $default );
+
+ ### and return the default
+ return $default;
+ }
+
+
+ ### so, no AUTOREPLY, let's see what the user will answer
+ LOOP: {
+
+ ### annoying bug in T::R::Perl that mucks up lines with a \n
+ ### in them; So split by \n, save the last line as the prompt
+ ### and just print the rest
+ { my @lines = split "\n", $prompt;
+ $prompt = pop @lines;
+
+ history( "$_\n" ) for @lines;
+ }
+
+ ### pose the question
+ my $answer = $term->readline($prompt);
+ $answer = $default unless length $answer;
+
+ $term->addhistory( $answer ) if length $answer;
+
+ ### add both prompt and answer to the history
+ history( "$prompt $answer", 0 );
+
+ ### if we're allowed to give multiple answers, split
+ ### the answer on whitespace
+ my @answers = $multi ? split(/\s+/, $answer) : $answer;
+
+ ### the return value list
+ my @rv;
+
+ if( @$choices ) {
+
+ for my $answer (@answers) {
+
+ ### a digit implies a multiple choice question,
+ ### a non-digit is an open answer
+ if( $answer =~ /\D/ ) {
+ push @rv, $answer if allow( $answer, $allow );
+ } else {
+
+ ### remember, the answer digits are +1 compared to
+ ### the choices, because humans want to start counting
+ ### at 1, not at 0
+ push @rv, $choices->[ $answer - 1 ]
+ if $answer > 0 && defined $choices->[ $answer - 1];
+ }
+ }
+
+ ### no fixed list of choices.. just check if the answers
+ ### (or otherwise the default!) pass the allow handler
+ } else {
+ push @rv, grep { allow( $_, $allow ) }
+ scalar @answers ? @answers : ($default);
+ }
+
+ ### if not all the answers made it to the return value list,
+ ### at least one of them was an invalid answer -- make the
+ ### user do it again
+ if( (@rv != @answers) or
+ (scalar(@$choices) and not scalar(@answers))
+ ) {
+ $prompt = $INVALID;
+ $prompt .= "[$prompt_add] " if $prompt_add;
+ redo LOOP;
+
+ ### otherwise just return the answer, or answers, depending
+ ### on the multi setting
+ } else {
+ return $multi ? @rv : $rv[0];
+ }
+ }
+}
+
+=head2 ($opts, $munged) = $term->parse_options( STRING );
+
+C<parse_options> will convert all options given from an input string
+to a hash reference. If called in list context it will also return
+the part of the input string that it found no options in.
+
+Consider this example:
+
+ my $str = q[command --no-foo --baz --bar=0 --quux=bleh ] .
+ q[--option="some'thing" -one-dash -single=blah' arg];
+
+ my ($options,$munged) = $term->parse_options($str);
+
+ ### $options would contain: ###
+ $options = {
+ 'foo' => 0,
+ 'bar' => 0,
+ 'one-dash' => 1,
+ 'baz' => 1,
+ 'quux' => 'bleh',
+ 'single' => 'blah\'',
+ 'option' => 'some\'thing'
+ };
+
+ ### and this is the munged version of the input string,
+ ### ie what's left of the input minus the options
+ $munged = 'command arg';
+
+As you can see, you can either use a single or a double C<-> to
+indicate an option.
+If you prefix an option with C<no-> and do not give it a value, it
+will be set to 0.
+If it has no prefix and no value, it will be set to 1.
+Otherwise, it will be set to its value. Note also that it can deal
+fine with single/double quoting issues.
+
+=cut
+
+sub parse_options {
+ my $term = shift;
+ my $input = shift;
+
+ my $return = {};
+
+ ### there's probably a more elegant way to do this... ###
+ while ( $input =~ s/(?:^|\s+)--?([-\w]+=("|').+?\2)(?=\Z|\s+)// or
+ $input =~ s/(?:^|\s+)--?([-\w]+=\S+)(?=\Z|\s+)// or
+ $input =~ s/(?:^|\s+)--?([-\w]+)(?=\Z|\s+)//
+ ) {
+ my $match = $1;
+
+ if( $match =~ /^([-\w]+)=("|')(.+?)\2$/ ) {
+ $return->{$1} = $3;
+
+ } elsif( $match =~ /^([-\w]+)=(\S+)$/ ) {
+ $return->{$1} = $2;
+
+ } elsif( $match =~ /^no-?([-\w]+)$/i ) {
+ $return->{$1} = 0;
+
+ } elsif ( $match =~ /^([-\w]+)$/ ) {
+ $return->{$1} = 1;
+
+ } else {
+ carp(loc(q[I do not understand option "%1"\n], $match)) if $VERBOSE;
+ }
+ }
+
+ return wantarray ? ($return,$input) : $return;
+}
+
+=head2 $str = $term->history_as_string
+
+Convenience wrapper around C<< Term::UI::History->history_as_string >>.
+
+Consult the C<Term::UI::History> man page for details.
+
+=cut
+
+sub history_as_string { return Term::UI::History->history_as_string };
+
+1;
+
+=head1 GLOBAL VARIABLES
+
+The behaviour of Term::UI can be altered by changing the following
+global variables:
+
+=head2 $Term::UI::VERBOSE
+
+This controls whether Term::UI will issue warnings and explanations
+as to why certain things may have failed. If you set it to 0,
+Term::UI will not output any warnings.
+The default is 1;
+
+=head2 $Term::UI::AUTOREPLY
+
+This will make every question be answered by the default, and warn if
+there was no default provided. This is particularly useful if your
+program is run in non-interactive mode.
+The default is 0;
+
+=head2 $Term::UI::INVALID
+
+This holds the string that will be printed when the user makes an
+invalid choice.
+You can override this string from your program if you, for example,
+wish to do localization.
+The default is C<Invalid selection, please try again: >
+
+=head2 $Term::UI::History::HISTORY_FH
+
+This is the filehandle all the print statements from this module
+are being sent to. Please consult the C<Term::UI::History> manpage
+for details.
+
+This defaults to C<*STDOUT>.
+
+=head1 EXAMPLES
+
+=head2 Basic get_reply sample
+
+ ### ask a user (with an open question) for their favourite colour
+ $reply = $term->get_reply( prompt => 'Your favourite colour? );
+
+which would look like:
+
+ Your favourite colour?
+
+and C<$reply> would hold the text the user typed.
+
+=head2 get_reply with choices
+
+ ### now provide a list of choices, so the user has to pick one
+ $reply = $term->get_reply(
+ prompt => 'Your favourite colour?',
+ choices => [qw|red green blue|] );
+
+which would look like:
+
+ 1> red
+ 2> green
+ 3> blue
+
+ Your favourite colour?
+
+C<$reply> will hold one of the choices presented. C<Term::UI> will repose
+the question if the user attempts to enter an answer that's not in the
+list of choices. The string presented is held in the C<$Term::UI::INVALID>
+variable (see the C<GLOBAL VARIABLES> section for details.
+
+=head2 get_reply with choices and default
+
+ ### provide a sensible default option -- everyone loves blue!
+ $reply = $term->get_reply(
+ prompt => 'Your favourite colour?',
+ choices => [qw|red green blue|],
+ default => 'blue' );
+
+which would look like:
+
+ 1> red
+ 2> green
+ 3> blue
+
+ Your favourite colour? [3]:
+
+Note the default answer after the prompt. A user can now just hit C<enter>
+(or set C<$Term::UI::AUTOREPLY> -- see the C<GLOBAL VARIABLES> section) and
+the sensible answer 'blue' will be returned.
+
+=head2 get_reply using print_me & multi
+
+ ### allow the user to pick more than one colour and add an
+ ### introduction text
+ @reply = $term->get_reply(
+ print_me => 'Tell us what colours you like',
+ prompt => 'Your favourite colours?',
+ choices => [qw|red green blue|],
+ multi => 1 );
+
+which would look like:
+
+ Tell us what colours you like
+ 1> red
+ 2> green
+ 3> blue
+
+ Your favourite colours?
+
+An answer of C<3 2 1> would fill C<@reply> with C<blue green red>
+
+=head2 get_reply & allow
+
+ ### pose an open question, but do a custom verification on
+ ### the answer, which will only exit the question loop, if
+ ### the answer matches the allow handler.
+ $reply = $term->get_reply(
+ prompt => "What is the magic number?",
+ allow => 42 );
+
+Unless the user now enters C<42>, the question will be reposed over
+and over again. You can use more sophisticated C<allow> handlers (even
+subroutines can be used). The C<allow> handler is implemented using
+C<Params::Check>'s C<allow> function. Check its manpage for details.
+
+=head2 an elaborate ask_yn sample
+
+ ### ask a user if he likes cookies. Default to a sensible 'yes'
+ ### and inform him first what cookies are.
+ $bool = $term->ask_yn( prompt => 'Do you like cookies?',
+ default => 'y',
+ print_me => 'Cookies are LOVELY!!!' );
+
+would print:
+
+ Cookies are LOVELY!!!
+ Do you like cookies? [Y/n]:
+
+If a user then simply hits C<enter>, agreeing with the default,
+C<$bool> would be set to C<true>. (Simply hitting 'y' would also
+return C<true>. Hitting 'n' would return C<false>)
+
+We could later retrieve this interaction by printing out the Q&A
+history as follows:
+
+ print $term->history_as_string;
+
+which would then print:
+
+ Cookies are LOVELY!!!
+ Do you like cookies? [Y/n]: y
+
+There's a chance we're doing this non-interactively, because a console
+is missing, the user indicated he just wanted the defaults, etc.
+
+In this case, simply setting C<$Term::UI::AUTOREPLY> to true, will
+return from every question with the default answer set for the question.
+Do note that if C<AUTOREPLY> is true, and no default is set, C<Term::UI>
+will warn about this and return C<undef>.
+
+=head1 See Also
+
+C<Params::Check>, C<Term::ReadLine>, C<Term::UI::History>
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-term-ui@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Term/UI/History.pm b/Master/tlpkg/tlperl.straw/lib/Term/UI/History.pm
new file mode 100755
index 00000000000..1d77c01c6f6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Term/UI/History.pm
@@ -0,0 +1,137 @@
+package Term::UI::History;
+
+use strict;
+use base 'Exporter';
+use base 'Log::Message::Simple';
+
+=pod
+
+=head1 NAME
+
+Term::UI::History
+
+=head1 SYNOPSIS
+
+ use Term::UI::History qw[history];
+
+ history("Some message");
+
+ ### retrieve the history in printable form
+ $hist = Term::UI::History->history_as_string;
+
+ ### redirect output
+ local $Term::UI::History::HISTORY_FH = \*STDERR;
+
+=head1 DESCRIPTION
+
+This module provides the C<history> function for C<Term::UI>,
+printing and saving all the C<UI> interaction.
+
+Refer to the C<Term::UI> manpage for details on usage from
+C<Term::UI>.
+
+This module subclasses C<Log::Message::Simple>. Refer to its
+manpage for additional functionality available via this package.
+
+=head1 FUNCTIONS
+
+=head2 history("message string" [,VERBOSE])
+
+Records a message on the stack, and prints it to C<STDOUT>
+(or actually C<$HISTORY_FH>, see the C<GLOBAL VARIABLES> section
+below), if the C<VERBOSE> option is true.
+
+The C<VERBOSE> option defaults to true.
+
+=cut
+
+BEGIN {
+ use Log::Message private => 0;
+
+ use vars qw[ @EXPORT $HISTORY_FH ];
+ @EXPORT = qw[ history ];
+ my $log = new Log::Message;
+ $HISTORY_FH = \*STDOUT;
+
+ for my $func ( @EXPORT ) {
+ no strict 'refs';
+
+ *$func = sub { my $msg = shift;
+ $log->store(
+ message => $msg,
+ tag => uc $func,
+ level => $func,
+ extra => [@_]
+ );
+ };
+ }
+
+ sub history_as_string {
+ my $class = shift;
+
+ return join $/, map { $_->message } __PACKAGE__->stack;
+ }
+}
+
+
+{ package Log::Message::Handlers;
+
+ sub history {
+ my $self = shift;
+ my $verbose = shift;
+ $verbose = 1 unless defined $verbose; # default to true
+
+ ### so you don't want us to print the msg? ###
+ return if defined $verbose && $verbose == 0;
+
+ local $| = 1;
+ my $old_fh = select $Term::UI::History::HISTORY_FH;
+
+ print $self->message . "\n";
+ select $old_fh;
+
+ return;
+ }
+}
+
+
+=head1 GLOBAL VARIABLES
+
+=over 4
+
+=item $HISTORY_FH
+
+This is the filehandle all the messages sent to C<history()> are being
+printed. This defaults to C<*STDOUT>.
+
+=back
+
+=head1 See Also
+
+C<Log::Message::Simple>, C<Term::UI>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2005 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder.pm
new file mode 100755
index 00000000000..26ffea41ff4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder.pm
@@ -0,0 +1,2501 @@
+package Test::Builder;
+
+use 5.006;
+use strict;
+use warnings;
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+BEGIN {
+ if( $] < 5.008 ) {
+ require Test::Builder::IO::Scalar;
+ }
+}
+
+
+# Make Test::Builder thread-safe for ithreads.
+BEGIN {
+ use Config;
+ # Load threads::shared when threads are turned on.
+ # 5.8.0's threads are so busted we no longer support them.
+ if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
+ require threads::shared;
+
+ # Hack around YET ANOTHER threads::shared bug. It would
+ # occassionally forget the contents of the variable when sharing it.
+ # So we first copy the data, then share, then put our copy back.
+ *share = sub (\[$@%]) {
+ my $type = ref $_[0];
+ my $data;
+
+ if( $type eq 'HASH' ) {
+ %$data = %{ $_[0] };
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @$data = @{ $_[0] };
+ }
+ elsif( $type eq 'SCALAR' ) {
+ $$data = ${ $_[0] };
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ $_[0] = &threads::shared::share( $_[0] );
+
+ if( $type eq 'HASH' ) {
+ %{ $_[0] } = %$data;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @{ $_[0] } = @$data;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ ${ $_[0] } = $$data;
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ return $_[0];
+ };
+ }
+ # 5.8.0's threads::shared is busted when threads are off
+ # and earlier Perls just don't have that module at all.
+ else {
+ *share = sub { return $_[0] };
+ *lock = sub { 0 };
+ }
+}
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use base 'Test::Builder::Module';
+
+ my $CLASS = __PACKAGE__;
+
+ sub ok {
+ my($test, $name) = @_;
+ my $tb = $CLASS->builder;
+
+ $tb->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+Test::Simple and Test::More have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program C<new> always returns the same
+Test::Builder object. No matter how many times you call C<new()>, you're
+getting the same object. This is called a singleton. This is done so that
+multiple modules share such global information as the test counter and
+where test output is going.
+
+If you want a completely new Test::Builder object different from the
+singleton, use C<create>.
+
+=cut
+
+our $Test = Test::Builder->new;
+
+sub new {
+ my($class) = shift;
+ $Test ||= $class->create;
+ return $Test;
+}
+
+=item B<create>
+
+ my $Test = Test::Builder->create;
+
+Ok, so there can be more than one Test::Builder object and this is how
+you get it. You might use this instead of C<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is
+still shared amongst B<all> Test::Builder objects, even ones created using
+this method. Also, the method name may change in the future.
+
+=cut
+
+sub create {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+ $self->reset;
+
+ return $self;
+}
+
+=item B<child>
+
+ my $child = $builder->child($name_of_child);
+ $child->plan( tests => 4 );
+ $child->ok(some_code());
+ ...
+ $child->finalize;
+
+Returns a new instance of C<Test::Builder>. Any output from this child will
+indented four spaces more than the parent's indentation. When done, the
+C<finalize> method I<must> be called explicitly.
+
+Trying to create a new child with a previous child still active (i.e.,
+C<finalize> not called) will C<croak>.
+
+Trying to run a test when you have an open child will also C<croak> and cause
+the test suite to fail.
+
+=cut
+
+sub child {
+ my( $self, $name ) = @_;
+
+ if( $self->{Child_Name} ) {
+ $self->croak("You already have a child named ($self->{Child_Name}) running");
+ }
+
+ my $child = bless {}, ref $self;
+ $child->reset;
+
+ # Add to our indentation
+ $child->_indent( $self->_indent . ' ' );
+ $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
+
+ # This will be reset in finalize. We do this here lest one child failure
+ # cause all children to fail.
+ $child->{Child_Error} = $?;
+ $? = 0;
+ $child->{Parent} = $self;
+ $child->{Name} = $name || "Child of " . $self->name;
+ $self->{Child_Name} = $child->name;
+ return $child;
+}
+
+
+=item B<subtest>
+
+ $builder->subtest($name, \&subtests);
+
+See documentation of C<subtest> in Test::More.
+
+=cut
+
+sub subtest {
+ my $self = shift;
+ my($name, $subtests) = @_;
+
+ if ('CODE' ne ref $subtests) {
+ $self->croak("subtest()'s second argument must be a code ref");
+ }
+
+ # Turn the child into the parent so anyone who has stored a copy of
+ # the Test::Builder singleton will get the child.
+ my $child = $self->child($name);
+ my %parent = %$self;
+ %$self = %$child;
+
+ my $error;
+ if( !eval { $subtests->(); 1 } ) {
+ $error = $@;
+ }
+
+ # Restore the parent and the copied child.
+ %$child = %$self;
+ %$self = %parent;
+
+ # Die *after* we restore the parent.
+ die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
+
+ return $child->finalize;
+}
+
+
+=item B<finalize>
+
+ my $ok = $child->finalize;
+
+When your child is done running tests, you must call C<finalize> to clean up
+and tell the parent your pass/fail status.
+
+Calling finalize on a child with open children will C<croak>.
+
+If the child falls out of scope before C<finalize> is called, a failure
+diagnostic will be issued and the child is considered to have failed.
+
+No attempt to call methods on a child after C<finalize> is called is
+guaranteed to succeed.
+
+Calling this on the root builder is a no-op.
+
+=cut
+
+sub finalize {
+ my $self = shift;
+
+ return unless $self->parent;
+ if( $self->{Child_Name} ) {
+ $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
+ }
+ $self->_ending;
+
+ # XXX This will only be necessary for TAP envelopes (we think)
+ #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+
+ my $ok = 1;
+ $self->parent->{Child_Name} = undef;
+ if ( $self->{Skip_All} ) {
+ $self->parent->skip($self->{Skip_All});
+ }
+ elsif ( not @{ $self->{Test_Results} } ) {
+ $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
+ }
+ else {
+ $self->parent->ok( $self->is_passing, $self->name );
+ }
+ $? = $self->{Child_Error};
+ delete $self->{Parent};
+
+ return $self->is_passing;
+}
+
+sub _indent {
+ my $self = shift;
+
+ if( @_ ) {
+ $self->{Indent} = shift;
+ }
+
+ return $self->{Indent};
+}
+
+=item B<parent>
+
+ if ( my $parent = $builder->parent ) {
+ ...
+ }
+
+Returns the parent C<Test::Builder> instance, if any. Only used with child
+builders for nested TAP.
+
+=cut
+
+sub parent { shift->{Parent} }
+
+=item B<name>
+
+ diag $builder->name;
+
+Returns the name of the current builder. Top level builders default to C<$0>
+(the name of the executable). Child builders are named via the C<child>
+method. If no name is supplied, will be named "Child of $parent->name".
+
+=cut
+
+sub name { shift->{Name} }
+
+sub DESTROY {
+ my $self = shift;
+ if ( $self->parent ) {
+ my $name = $self->name;
+ $self->diag(<<"FAIL");
+Child ($name) exited without calling finalize()
+FAIL
+ $self->parent->{In_Destroy} = 1;
+ $self->parent->ok(0, $name);
+ }
+}
+
+=item B<reset>
+
+ $Test->reset;
+
+Reinitializes the Test::Builder singleton to its original state.
+Mostly useful for tests run in persistent environments where the same
+test might be run multiple times in the same process.
+
+=cut
+
+our $Level;
+
+sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my($self) = @_;
+
+ # We leave this a global because it has to be localized and localizing
+ # hash keys is just asking for pain. Also, it was documented.
+ $Level = 1;
+
+ $self->{Name} = $0;
+ $self->is_passing(1);
+ $self->{Ending} = 0;
+ $self->{Have_Plan} = 0;
+ $self->{No_Plan} = 0;
+ $self->{Have_Output_Plan} = 0;
+
+ $self->{Original_Pid} = $$;
+ $self->{Child_Name} = undef;
+ $self->{Indent} ||= '';
+
+ share( $self->{Curr_Test} );
+ $self->{Curr_Test} = 0;
+ $self->{Test_Results} = &share( [] );
+
+ $self->{Exported_To} = undef;
+ $self->{Expected_Tests} = 0;
+
+ $self->{Skip_All} = 0;
+
+ $self->{Use_Nums} = 1;
+
+ $self->{No_Header} = 0;
+ $self->{No_Ending} = 0;
+
+ $self->{Todo} = undef;
+ $self->{Todo_Stack} = [];
+ $self->{Start_Todo} = 0;
+ $self->{Opened_Testhandles} = 0;
+
+ $self->_dup_stdhandles;
+
+ return;
+}
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call C<plan()>, don't call any of the other methods below.
+
+If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
+thrown. Trap this error, call C<finalize()> and don't run any more tests on
+the child.
+
+ my $child = $Test->child('some child');
+ eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
+ if ( eval { $@->isa('Test::Builder::Exception') } ) {
+ $child->finalize;
+ return;
+ }
+ # run your tests
+
+=cut
+
+my %plan_cmds = (
+ no_plan => \&no_plan,
+ skip_all => \&skip_all,
+ tests => \&_plan_tests,
+);
+
+sub plan {
+ my( $self, $cmd, $arg ) = @_;
+
+ return unless $cmd;
+
+ local $Level = $Level + 1;
+
+ $self->croak("You tried to plan twice") if $self->{Have_Plan};
+
+ if( my $method = $plan_cmds{$cmd} ) {
+ local $Level = $Level + 1;
+ $self->$method($arg);
+ }
+ else {
+ my @args = grep { defined } ( $cmd, $arg );
+ $self->croak("plan() doesn't understand @args");
+ }
+
+ return 1;
+}
+
+
+sub _plan_tests {
+ my($self, $arg) = @_;
+
+ if($arg) {
+ local $Level = $Level + 1;
+ return $self->expected_tests($arg);
+ }
+ elsif( !defined $arg ) {
+ $self->croak("Got an undefined number of tests");
+ }
+ else {
+ $self->croak("You said to run 0 tests");
+ }
+
+ return;
+}
+
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the number of tests we expect this test to run and prints out
+the appropriate headers.
+
+=cut
+
+sub expected_tests {
+ my $self = shift;
+ my($max) = @_;
+
+ if(@_) {
+ $self->croak("Number of tests must be a positive integer. You gave it '$max'")
+ unless $max =~ /^\+?\d+$/;
+
+ $self->{Expected_Tests} = $max;
+ $self->{Have_Plan} = 1;
+
+ $self->_output_plan($max) unless $self->no_header;
+ }
+ return $self->{Expected_Tests};
+}
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate number of tests.
+
+=cut
+
+sub no_plan {
+ my($self, $arg) = @_;
+
+ $self->carp("no_plan takes no arguments") if $arg;
+
+ $self->{No_Plan} = 1;
+ $self->{Have_Plan} = 1;
+
+ return 1;
+}
+
+
+=begin private
+
+=item B<_output_plan>
+
+ $tb->_output_plan($max);
+ $tb->_output_plan($max, $directive);
+ $tb->_output_plan($max, $directive => $reason);
+
+Handles displaying the test plan.
+
+If a C<$directive> and/or C<$reason> are given they will be output with the
+plan. So here's what skipping all tests looks like:
+
+ $tb->_output_plan(0, "SKIP", "Because I said so");
+
+It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
+output.
+
+=end private
+
+=cut
+
+sub _output_plan {
+ my($self, $max, $directive, $reason) = @_;
+
+ $self->carp("The plan was already output") if $self->{Have_Output_Plan};
+
+ my $plan = "1..$max";
+ $plan .= " # $directive" if defined $directive;
+ $plan .= " $reason" if defined $reason;
+
+ $self->_print("$plan\n");
+
+ $self->{Have_Output_Plan} = 1;
+
+ return;
+}
+
+=item B<done_testing>
+
+ $Test->done_testing();
+ $Test->done_testing($num_tests);
+
+Declares that you are done testing, no more tests will be run after this point.
+
+If a plan has not yet been output, it will do so.
+
+$num_tests is the number of tests you planned to run. If a numbered
+plan was already declared, and if this contradicts, a failing test
+will be run to reflect the planning mistake. If C<no_plan> was declared,
+this will override.
+
+If C<done_testing()> is called twice, the second call will issue a
+failing test.
+
+If C<$num_tests> is omitted, the number of tests run will be used, like
+no_plan.
+
+C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
+safer. You'd use it like so:
+
+ $Test->ok($a == $b);
+ $Test->done_testing();
+
+Or to plan a variable number of tests:
+
+ for my $test (@tests) {
+ $Test->ok($test);
+ }
+ $Test->done_testing(@tests);
+
+=cut
+
+sub done_testing {
+ my($self, $num_tests) = @_;
+
+ # If done_testing() specified the number of tests, shut off no_plan.
+ if( defined $num_tests ) {
+ $self->{No_Plan} = 0;
+ }
+ else {
+ $num_tests = $self->current_test;
+ }
+
+ if( $self->{Done_Testing} ) {
+ my($file, $line) = @{$self->{Done_Testing}}[1,2];
+ $self->ok(0, "done_testing() was already called at $file line $line");
+ return;
+ }
+
+ $self->{Done_Testing} = [caller];
+
+ if( $self->expected_tests && $num_tests != $self->expected_tests ) {
+ $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
+ "but done_testing() expects $num_tests");
+ }
+ else {
+ $self->{Expected_Tests} = $num_tests;
+ }
+
+ $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
+
+ $self->{Have_Plan} = 1;
+
+ # The wrong number of tests were run
+ $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
+
+ # No tests were run
+ $self->is_passing(0) if $self->{Curr_Test} == 0;
+
+ return 1;
+}
+
+
+=item B<has_plan>
+
+ $plan = $Test->has_plan
+
+Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
+has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
+of expected tests).
+
+=cut
+
+sub has_plan {
+ my $self = shift;
+
+ return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
+ return('no_plan') if $self->{No_Plan};
+ return(undef);
+}
+
+=item B<skip_all>
+
+ $Test->skip_all;
+ $Test->skip_all($reason);
+
+Skips all the tests, using the given C<$reason>. Exits immediately with 0.
+
+=cut
+
+sub skip_all {
+ my( $self, $reason ) = @_;
+
+ $self->{Skip_All} = $self->parent ? $reason : 1;
+
+ $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
+ if ( $self->parent ) {
+ die bless {} => 'Test::Builder::Exception';
+ }
+ exit(0);
+}
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+
+This method isn't terribly useful since modules which share the same
+Test::Builder object might get exported to different packages and only
+the last one will be honored.
+
+=cut
+
+sub exported_to {
+ my( $self, $pack ) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in Test::More.
+
+They all return true if the test passed, false if the test failed.
+
+C<$name> is always optional.
+
+=over 4
+
+=item B<ok>
+
+ $Test->ok($test, $name);
+
+Your basic test. Pass if C<$test> is true, fail if $test is false. Just
+like Test::Simple's C<ok()>.
+
+=cut
+
+sub ok {
+ my( $self, $test, $name ) = @_;
+
+ if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
+ $name = 'unnamed test' unless defined $name;
+ $self->is_passing(0);
+ $self->croak("Cannot run test ($name) with active children");
+ }
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ lock $self->{Curr_Test};
+ $self->{Curr_Test}++;
+
+ # In case $name is a string overloaded object, force it to stringify.
+ $self->_unoverload_str( \$name );
+
+ $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ERR
+
+ # Capture the value of $TODO for the rest of this ok() call
+ # so it can more easily be found by other routines.
+ my $todo = $self->todo();
+ my $in_todo = $self->in_todo;
+ local $self->{Todo} = $todo if $in_todo;
+
+ $self->_unoverload_str( \$todo );
+
+ my $out;
+ my $result = &share( {} );
+
+ unless($test) {
+ $out .= "not ";
+ @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ $out .= "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+
+ if( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $out .= " - $name";
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if( $self->in_todo ) {
+ $out .= " # TODO $todo";
+ $result->{reason} = $todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ unless($test) {
+ my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
+ $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
+
+ my( undef, $file, $line ) = $self->caller;
+ if( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
+ }
+ }
+
+ $self->is_passing(0) unless $test || $self->in_todo;
+
+ # Check that we haven't violated the plan
+ $self->_check_is_passing_plan();
+
+ return $test ? 1 : 0;
+}
+
+
+# Check that we haven't yet violated the plan and set
+# is_passing() accordingly
+sub _check_is_passing_plan {
+ my $self = shift;
+
+ my $plan = $self->has_plan;
+ return unless defined $plan; # no plan yet defined
+ return unless $plan !~ /\D/; # no numeric plan
+ $self->is_passing(0) if $plan < $self->{Curr_Test};
+}
+
+
+sub _unoverload {
+ my $self = shift;
+ my $type = shift;
+
+ $self->_try(sub { require overload; }, die_on_fail => 1);
+
+ foreach my $thing (@_) {
+ if( $self->_is_object($$thing) ) {
+ if( my $string_meth = overload::Method( $$thing, $type ) ) {
+ $$thing = $$thing->$string_meth();
+ }
+ }
+ }
+
+ return;
+}
+
+sub _is_object {
+ my( $self, $thing ) = @_;
+
+ return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
+}
+
+sub _unoverload_str {
+ my $self = shift;
+
+ return $self->_unoverload( q[""], @_ );
+}
+
+sub _unoverload_num {
+ my $self = shift;
+
+ $self->_unoverload( '0+', @_ );
+
+ for my $val (@_) {
+ next unless $self->_is_dualvar($$val);
+ $$val = $$val + 0;
+ }
+
+ return;
+}
+
+# This is a hack to detect a dualvar such as $!
+sub _is_dualvar {
+ my( $self, $val ) = @_;
+
+ # Objects are not dualvars.
+ return 0 if ref $val;
+
+ no warnings 'numeric';
+ my $numval = $val + 0;
+ return $numval != 0 and $numval ne $val ? 1 : 0;
+}
+
+=item B<is_eq>
+
+ $Test->is_eq($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
+string version.
+
+=item B<is_num>
+
+ $Test->is_num($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
+numeric version.
+
+=cut
+
+sub is_eq {
+ my( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_str( \$got, \$expect );
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, 'eq', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'eq', $expect, $name );
+}
+
+sub is_num {
+ my( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_num( \$got, \$expect );
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, '==', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '==', $expect, $name );
+}
+
+sub _diag_fmt {
+ my( $self, $type, $val ) = @_;
+
+ if( defined $$val ) {
+ if( $type eq 'eq' or $type eq 'ne' ) {
+ # quote and force string context
+ $$val = "'$$val'";
+ }
+ else {
+ # force numeric context
+ $self->_unoverload_num($val);
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+
+ return;
+}
+
+sub _is_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: $expect
+DIAGNOSTIC
+
+}
+
+sub _isnt_diag {
+ my( $self, $got, $type ) = @_;
+
+ $self->_diag_fmt( $type, \$got );
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: anything else
+DIAGNOSTIC
+}
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->isnt_num($got, $dont_expect, $name);
+
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, 'ne' ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
+}
+
+sub isnt_num {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, '!=' ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '!=', $dont_expect, $name );
+}
+
+=item B<like>
+
+ $Test->like($this, qr/$regex/, $name);
+ $Test->like($this, '/$regex/', $name);
+
+Like Test::More's C<like()>. Checks if $this matches the given C<$regex>.
+
+=item B<unlike>
+
+ $Test->unlike($this, qr/$regex/, $name);
+ $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's C<unlike()>. Checks if $this B<does not match> the
+given C<$regex>.
+
+=cut
+
+sub like {
+ my( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ return $self->_regex_ok( $this, $regex, '=~', $name );
+}
+
+sub unlike {
+ my( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ return $self->_regex_ok( $this, $regex, '!~', $name );
+}
+
+=item B<cmp_ok>
+
+ $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's C<cmp_ok()>.
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+
+sub cmp_ok {
+ my( $self, $got, $type, $expect, $name ) = @_;
+
+ my $test;
+ my $error;
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ my($pack, $file, $line) = $self->caller();
+
+ $test = eval qq[
+#line 1 "cmp_ok [from $file line $line]"
+\$got $type \$expect;
+];
+ $error = $@;
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok( $test, $name );
+
+ # Treat overloaded objects as numbers if we're asked to do a
+ # numeric comparison.
+ my $unoverload
+ = $numeric_cmps{$type}
+ ? '_unoverload_num'
+ : '_unoverload_str';
+
+ $self->diag(<<"END") if $error;
+An error occurred while using $type:
+------------------------------------
+$error
+------------------------------------
+END
+
+ unless($ok) {
+ $self->$unoverload( \$got, \$expect );
+
+ if( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag( $got, $type, $expect );
+ }
+ elsif( $type =~ /^(ne|!=)$/ ) {
+ $self->_isnt_diag( $got, $type );
+ }
+ else {
+ $self->_cmp_diag( $got, $type, $expect );
+ }
+ }
+ return $ok;
+}
+
+sub _cmp_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ $got
+ $type
+ $expect
+DIAGNOSTIC
+}
+
+sub _caller_context {
+ my $self = shift;
+
+ my( $pack, $file, $line ) = $self->caller(1);
+
+ my $code = '';
+ $code .= "#line $line $file\n" if defined $file and defined $line;
+
+ return $code;
+}
+
+=back
+
+
+=head2 Other Testing Methods
+
+These are methods which are used in the course of writing a test but are not themselves tests.
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ $Test->BAIL_OUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAIL_OUT {
+ my( $self, $reason ) = @_;
+
+ $self->{Bailed_Out} = 1;
+ $self->_print("Bail out! $reason");
+ exit 255;
+}
+
+=for deprecated
+BAIL_OUT() used to be BAILOUT()
+
+=cut
+
+{
+ no warnings 'once';
+ *BAILOUT = \&BAIL_OUT;
+}
+
+=item B<skip>
+
+ $Test->skip;
+ $Test->skip($why);
+
+Skips the current test, reporting C<$why>.
+
+=cut
+
+sub skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+ $self->_unoverload_str( \$why );
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # skip";
+ $out .= " $why" if length $why;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like C<skip()>, only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "not ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # TODO & SKIP $why\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
+
+Like C<skip()>, only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under C<no_plan>, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
+
+=head2 Test building utility methods
+
+These methods are useful when writing your own test methods.
+
+=over 4
+
+=item B<maybe_regex>
+
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
+
+This method used to be useful back when Test::Builder worked on Perls
+before 5.6 which didn't have qr//. Now its pretty useless.
+
+Convenience method for building testing functions that take regular
+expressions as arguments.
+
+Takes a quoted regular expression produced by C<qr//>, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or C<undef> if its argument is not recognised.
+
+For example, a version of C<like()>, sans the useful diagnostic messages,
+could be written as:
+
+ sub laconic_like {
+ my ($self, $this, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($this =~ m/$usable_regex/, $name);
+ }
+
+=cut
+
+sub maybe_regex {
+ my( $self, $regex ) = @_;
+ my $usable_regex = undef;
+
+ return $usable_regex unless defined $regex;
+
+ my( $re, $opts );
+
+ # Check for qr/foo/
+ if( _is_qr($regex) ) {
+ $usable_regex = $regex;
+ }
+ # Check for '/foo/' or 'm,foo,'
+ elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
+ ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+ )
+ {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ }
+
+ return $usable_regex;
+}
+
+sub _is_qr {
+ my $regex = shift;
+
+ # is_regexp() checks for regexes in a robust manner, say if they're
+ # blessed.
+ return re::is_regexp($regex) if defined &re::is_regexp;
+ return ref $regex eq 'Regexp';
+}
+
+sub _regex_ok {
+ my( $self, $this, $regex, $cmp, $name ) = @_;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless( defined $usable_regex ) {
+ local $Level = $Level + 1;
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ my $test;
+ my $context = $self->_caller_context;
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+
+ $test = !$test if $cmp eq '!~';
+
+ local $Level = $Level + 1;
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless($ok) {
+ $this = defined $this ? "'$this'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+
+ local $Level = $Level + 1;
+ $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+# I'm not ready to publish this. It doesn't deal with array return
+# values from the code or context.
+
+=begin private
+
+=item B<_try>
+
+ my $return_from_code = $Test->try(sub { code });
+ my($return_from_code, $error) = $Test->try(sub { code });
+
+Works like eval BLOCK except it ensures it has no effect on the rest
+of the test (ie. C<$@> is not set) nor is effected by outside
+interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
+Perls.
+
+C<$error> is what would normally be in C<$@>.
+
+It is suggested you use this in place of eval BLOCK.
+
+=cut
+
+sub _try {
+ my( $self, $code, %opts ) = @_;
+
+ my $error;
+ my $return;
+ {
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ $return = eval { $code->() };
+ $error = $@;
+ }
+
+ die $error if $error and $opts{die_on_fail};
+
+ return wantarray ? ( $return, $error ) : $return;
+}
+
+=end private
+
+
+=item B<is_fh>
+
+ my $is_fh = $Test->is_fh($thing);
+
+Determines if the given C<$thing> can be used as a filehandle.
+
+=cut
+
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
+
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return eval { $maybe_fh->isa("IO::Handle") } ||
+ eval { tied($maybe_fh)->can('TIEHANDLE') };
+}
+
+=back
+
+
+=head2 Test style
+
+
+=over 4
+
+=item B<level>
+
+ $Test->level($how_high);
+
+How far up the call stack should C<$Test> look when reporting where the
+test failed.
+
+Defaults to 1.
+
+Setting L<$Test::Builder::Level> overrides. This is typically useful
+localized:
+
+ sub my_ok {
+ my $test = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $TB->ok($test);
+ }
+
+To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
+
+=cut
+
+sub level {
+ my( $self, $level ) = @_;
+
+ if( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+=item B<use_numbers>
+
+ $Test->use_numbers($on_or_off);
+
+Whether or not the test should output numbers. That is, this if true:
+
+ ok 1
+ ok 2
+ ok 3
+
+or this if false
+
+ ok
+ ok
+ ok
+
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
+
+Defaults to on.
+
+=cut
+
+sub use_numbers {
+ my( $self, $use_nums ) = @_;
+
+ if( defined $use_nums ) {
+ $self->{Use_Nums} = $use_nums;
+ }
+ return $self->{Use_Nums};
+}
+
+=item B<no_diag>
+
+ $Test->no_diag($no_diag);
+
+If set true no diagnostics will be printed. This includes calls to
+C<diag()>.
+
+=item B<no_ending>
+
+ $Test->no_ending($no_ending);
+
+Normally, Test::Builder does some extra diagnostics when the test
+ends. It also changes the exit code as described below.
+
+If this is true, none of that will be done.
+
+=item B<no_header>
+
+ $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
+=cut
+
+foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
+ my $method = lc $attribute;
+
+ my $code = sub {
+ my( $self, $no ) = @_;
+
+ if( defined $no ) {
+ $self->{$attribute} = $no;
+ }
+ return $self->{$attribute};
+ };
+
+ no strict 'refs'; ## no critic
+ *{ __PACKAGE__ . '::' . $method } = $code;
+}
+
+=back
+
+=head2 Output
+
+Controlling where the test output goes.
+
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
+
+=over 4
+
+=item B<diag>
+
+ $Test->diag(@msgs);
+
+Prints out the given C<@msgs>. Like C<print>, arguments are simply
+appended together.
+
+Normally, it uses the C<failure_output()> handle, but if this is for a
+TODO test, the C<todo_output()> handle is used.
+
+Output will be indented and marked with a # so as not to interfere
+with test output. A newline will be put on the end if there isn't one
+already.
+
+We encourage using this rather than calling print directly.
+
+Returns false. Why? Because C<diag()> is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+ return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+
+=cut
+
+sub diag {
+ my $self = shift;
+
+ $self->_print_comment( $self->_diag_fh, @_ );
+}
+
+=item B<note>
+
+ $Test->note(@msgs);
+
+Like C<diag()>, but it prints to the C<output()> handle so it will not
+normally be seen by the user except in verbose mode.
+
+=cut
+
+sub note {
+ my $self = shift;
+
+ $self->_print_comment( $self->output, @_ );
+}
+
+sub _diag_fh {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ return $self->in_todo ? $self->todo_output : $self->failure_output;
+}
+
+sub _print_comment {
+ my( $self, $fh, @msgs ) = @_;
+
+ return if $self->no_diag;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Smash args together like print does.
+ # Convert undef to 'undef' so its readable.
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
+
+ # Escape the beginning, _print will take care of the rest.
+ $msg =~ s/^/# /;
+
+ local $Level = $Level + 1;
+ $self->_print_to_fh( $fh, $msg );
+
+ return 0;
+}
+
+=item B<explain>
+
+ my @dump = $Test->explain(@msgs);
+
+Will dump the contents of any references in a human readable format.
+Handy for things like...
+
+ is_deeply($have, $want) || diag explain $have;
+
+or
+
+ is_deeply($have, $want) || note explain $have;
+
+=cut
+
+sub explain {
+ my $self = shift;
+
+ return map {
+ ref $_
+ ? do {
+ $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
+
+ my $dumper = Data::Dumper->new( [$_] );
+ $dumper->Indent(1)->Terse(1);
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+ $dumper->Dump;
+ }
+ : $_
+ } @_;
+}
+
+=begin _private
+
+=item B<_print>
+
+ $Test->_print(@msgs);
+
+Prints to the C<output()> filehandle.
+
+=end _private
+
+=cut
+
+sub _print {
+ my $self = shift;
+ return $self->_print_to_fh( $self->output, @_ );
+}
+
+sub _print_to_fh {
+ my( $self, $fh, @msgs ) = @_;
+
+ # Prevent printing headers when only compiling. Mostly for when
+ # tests are deparsed with B::Deparse
+ return if $^C;
+
+ my $msg = join '', @msgs;
+
+ local( $\, $", $, ) = ( undef, ' ', '' );
+
+ # Escape each line after the first with a # so we don't
+ # confuse Test::Harness.
+ $msg =~ s{\n(?!\z)}{\n# }sg;
+
+ # Stick a newline on the end if it needs it.
+ $msg .= "\n" unless $msg =~ /\n\z/;
+
+ return print $fh $self->_indent, $msg;
+}
+
+=item B<output>
+
+=item B<failure_output>
+
+=item B<todo_output>
+
+ my $filehandle = $Test->output;
+ $Test->output($filehandle);
+ $Test->output($filename);
+ $Test->output(\$scalar);
+
+These methods control where Test::Builder will print its output.
+They take either an open C<$filehandle>, a C<$filename> to open and write to
+or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
+
+B<output> is where normal "ok/not ok" test output goes.
+
+Defaults to STDOUT.
+
+B<failure_output> is where diagnostic output on test failures and
+C<diag()> goes. It is normally not read by Test::Harness and instead is
+displayed to the user.
+
+Defaults to STDERR.
+
+C<todo_output> is used instead of C<failure_output()> for the
+diagnostics of a failing TODO test. These will not be seen by the
+user.
+
+Defaults to STDOUT.
+
+=cut
+
+sub output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Out_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Out_FH};
+}
+
+sub failure_output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Fail_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Fail_FH};
+}
+
+sub todo_output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Todo_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Todo_FH};
+}
+
+sub _new_fh {
+ my $self = shift;
+ my($file_or_fh) = shift;
+
+ my $fh;
+ if( $self->is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ elsif( ref $file_or_fh eq 'SCALAR' ) {
+ # Scalar refs as filehandles was added in 5.8.
+ if( $] >= 5.008 ) {
+ open $fh, ">>", $file_or_fh
+ or $self->croak("Can't open scalar ref $file_or_fh: $!");
+ }
+ # Emulate scalar ref filehandles with a tie.
+ else {
+ $fh = Test::Builder::IO::Scalar->new($file_or_fh)
+ or $self->croak("Can't tie scalar ref $file_or_fh");
+ }
+ }
+ else {
+ open $fh, ">", $file_or_fh
+ or $self->croak("Can't open test output log $file_or_fh: $!");
+ _autoflush($fh);
+ }
+
+ return $fh;
+}
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+
+ return;
+}
+
+my( $Testout, $Testerr );
+
+sub _dup_stdhandles {
+ my $self = shift;
+
+ $self->_open_testhandles;
+
+ # Set everything to unbuffered else plain prints to STDOUT will
+ # come out in the wrong order from our own prints.
+ _autoflush($Testout);
+ _autoflush( \*STDOUT );
+ _autoflush($Testerr);
+ _autoflush( \*STDERR );
+
+ $self->reset_outputs;
+
+ return;
+}
+
+sub _open_testhandles {
+ my $self = shift;
+
+ return if $self->{Opened_Testhandles};
+
+ # We dup STDOUT and STDERR so people can change them in their
+ # test suites while still getting normal test output.
+ open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
+ open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
+
+ # $self->_copy_io_layers( \*STDOUT, $Testout );
+ # $self->_copy_io_layers( \*STDERR, $Testerr );
+
+ $self->{Opened_Testhandles} = 1;
+
+ return;
+}
+
+sub _copy_io_layers {
+ my( $self, $src, $dst ) = @_;
+
+ $self->_try(
+ sub {
+ require PerlIO;
+ my @src_layers = PerlIO::get_layers($src);
+
+ binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+ }
+ );
+
+ return;
+}
+
+=item reset_outputs
+
+ $tb->reset_outputs;
+
+Resets all the output filehandles back to their defaults.
+
+=cut
+
+sub reset_outputs {
+ my $self = shift;
+
+ $self->output ($Testout);
+ $self->failure_output($Testerr);
+ $self->todo_output ($Testout);
+
+ return;
+}
+
+=item carp
+
+ $tb->carp(@message);
+
+Warns with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
+
+=item croak
+
+ $tb->croak(@message);
+
+Dies with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
+
+=cut
+
+sub _message_at_caller {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ my( $pack, $file, $line ) = $self->caller;
+ return join( "", @_ ) . " at $file line $line.\n";
+}
+
+sub carp {
+ my $self = shift;
+ return warn $self->_message_at_caller(@_);
+}
+
+sub croak {
+ my $self = shift;
+ return die $self->_message_at_caller(@_);
+}
+
+
+=back
+
+
+=head2 Test Status and Info
+
+=over 4
+
+=item B<current_test>
+
+ my $curr_test = $Test->current_test;
+ $Test->current_test($num);
+
+Gets/sets the current test number we're on. You usually shouldn't
+have to set this.
+
+If set forward, the details of the missing tests are filled in as 'unknown'.
+if set backward, the details of the intervening tests are deleted. You
+can erase history if you really want to.
+
+=cut
+
+sub current_test {
+ my( $self, $num ) = @_;
+
+ lock( $self->{Curr_Test} );
+ if( defined $num ) {
+ $self->{Curr_Test} = $num;
+
+ # If the test counter is being pushed forward fill in the details.
+ my $test_results = $self->{Test_Results};
+ if( $num > @$test_results ) {
+ my $start = @$test_results ? @$test_results : 0;
+ for( $start .. $num - 1 ) {
+ $test_results->[$_] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ }
+ );
+ }
+ }
+ # If backward, wipe history. Its their funeral.
+ elsif( $num < @$test_results ) {
+ $#{$test_results} = $num - 1;
+ }
+ }
+ return $self->{Curr_Test};
+}
+
+=item B<is_passing>
+
+ my $ok = $builder->is_passing;
+
+Indicates if the test suite is currently passing.
+
+More formally, it will be false if anything has happened which makes
+it impossible for the test suite to pass. True otherwise.
+
+For example, if no tests have run C<is_passing()> will be true because
+even though a suite with no tests is a failure you can add a passing
+test to it and start passing.
+
+Don't think about it too much.
+
+=cut
+
+sub is_passing {
+ my $self = shift;
+
+ if( @_ ) {
+ $self->{Is_Passing} = shift;
+ }
+
+ return $self->{Is_Passing};
+}
+
+
+=item B<summary>
+
+ my @tests = $Test->summary;
+
+A simple summary of the tests so far. True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
+
+Of course, test #1 is $tests[0], etc...
+
+=cut
+
+sub summary {
+ my($self) = shift;
+
+ return map { $_->{'ok'} } @{ $self->{Test_Results} };
+}
+
+=item B<details>
+
+ my @tests = $Test->details;
+
+Like C<summary()>, but with a lot more detail.
+
+ $tests[$test_num - 1] =
+ { 'ok' => is the test considered a pass?
+ actual_ok => did it literally say 'ok'?
+ name => name of the test (if any)
+ type => type of test (if any, see below).
+ reason => reason for the above (if any)
+ };
+
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'. This is for examining the result of 'todo'
+tests.
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test. Normal tests have a type
+of ''. Type can be one of the following:
+
+ skip see skip()
+ todo see todo()
+ todo_skip see todo_skip()
+ unknown see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when C<current_test()> is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+its type is 'unknown'. These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left C<undef>.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+ $tests[22] = # 23 - 1, since arrays start from 0.
+ { ok => 1, # logically, the test passed since its todo
+ actual_ok => 0, # in absolute terms, it failed
+ name => 'hole count',
+ type => 'todo',
+ reason => 'insufficient donuts'
+ };
+
+=cut
+
+sub details {
+ my $self = shift;
+ return @{ $self->{Test_Results} };
+}
+
+=item B<todo>
+
+ my $todo_reason = $Test->todo;
+ my $todo_reason = $Test->todo($pack);
+
+If the current tests are considered "TODO" it will return the reason,
+if any. This reason can come from a C<$TODO> variable or the last call
+to C<todo_start()>.
+
+Since a TODO test does not need a reason, this function can return an
+empty string even when inside a TODO block. Use C<< $Test->in_todo >>
+to determine if you are currently inside a TODO block.
+
+C<todo()> is about finding the right package to look for C<$TODO> in. It's
+pretty good at guessing the right package to look at. It first looks for
+the caller based on C<$Level + 1>, since C<todo()> is usually called inside
+a test function. As a last resort it will use C<exported_to()>.
+
+Sometimes there is some confusion about where todo() should be looking
+for the C<$TODO> variable. If you want to be sure, tell it explicitly
+what $pack to use.
+
+=cut
+
+sub todo {
+ my( $self, $pack ) = @_;
+
+ return $self->{Todo} if defined $self->{Todo};
+
+ local $Level = $Level + 1;
+ my $todo = $self->find_TODO($pack);
+ return $todo if defined $todo;
+
+ return '';
+}
+
+=item B<find_TODO>
+
+ my $todo_reason = $Test->find_TODO();
+ my $todo_reason = $Test->find_TODO($pack):
+
+Like C<todo()> but only returns the value of C<$TODO> ignoring
+C<todo_start()>.
+
+=cut
+
+sub find_TODO {
+ my( $self, $pack ) = @_;
+
+ $pack = $pack || $self->caller(1) || $self->exported_to;
+ return unless $pack;
+
+ no strict 'refs'; ## no critic
+ return ${ $pack . '::TODO' };
+}
+
+=item B<in_todo>
+
+ my $in_todo = $Test->in_todo;
+
+Returns true if the test is currently inside a TODO block.
+
+=cut
+
+sub in_todo {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
+}
+
+=item B<todo_start>
+
+ $Test->todo_start();
+ $Test->todo_start($message);
+
+This method allows you declare all subsequent tests as TODO tests, up until
+the C<todo_end> method has been called.
+
+The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
+whether or not we're in a TODO test. However, often we find that this is not
+possible to determine (such as when we want to use C<$TODO> but
+the tests are being executed in other packages which can't be inferred
+beforehand).
+
+Note that you can use this to nest "todo" tests
+
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+
+This is generally not recommended, but large testing systems often have weird
+internal needs.
+
+We've tried to make this also work with the TODO: syntax, but it's not
+guaranteed and its use is also discouraged:
+
+ TODO: {
+ local $TODO = 'We have work to do!';
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+ }
+
+Pick one style or another of "TODO" to be on the safe side.
+
+=cut
+
+sub todo_start {
+ my $self = shift;
+ my $message = @_ ? shift : '';
+
+ $self->{Start_Todo}++;
+ if( $self->in_todo ) {
+ push @{ $self->{Todo_Stack} } => $self->todo;
+ }
+ $self->{Todo} = $message;
+
+ return;
+}
+
+=item C<todo_end>
+
+ $Test->todo_end;
+
+Stops running tests as "TODO" tests. This method is fatal if called without a
+preceding C<todo_start> method call.
+
+=cut
+
+sub todo_end {
+ my $self = shift;
+
+ if( !$self->{Start_Todo} ) {
+ $self->croak('todo_end() called without todo_start()');
+ }
+
+ $self->{Start_Todo}--;
+
+ if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
+ $self->{Todo} = pop @{ $self->{Todo_Stack} };
+ }
+ else {
+ delete $self->{Todo};
+ }
+
+ return;
+}
+
+=item B<caller>
+
+ my $package = $Test->caller;
+ my($pack, $file, $line) = $Test->caller;
+ my($pack, $file, $line) = $Test->caller($height);
+
+Like the normal C<caller()>, except it reports according to your C<level()>.
+
+C<$height> will be added to the C<level()>.
+
+If C<caller()> winds up off the top of the stack it report the highest context.
+
+=cut
+
+sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my( $self, $height ) = @_;
+ $height ||= 0;
+
+ my $level = $self->level + $height + 1;
+ my @caller;
+ do {
+ @caller = CORE::caller( $level );
+ $level--;
+ } until @caller;
+ return wantarray ? @caller : $caller[0];
+}
+
+=back
+
+=cut
+
+=begin _private
+
+=over 4
+
+=item B<_sanity_check>
+
+ $self->_sanity_check();
+
+Runs a bunch of end of test sanity checks to make sure reality came
+through ok. If anything is wrong it will die with a fairly friendly
+error message.
+
+=cut
+
+#'#
+sub _sanity_check {
+ my $self = shift;
+
+ $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
+ $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
+ 'Somehow you got a different number of results than tests ran!' );
+
+ return;
+}
+
+=item B<_whoa>
+
+ $self->_whoa($check, $description);
+
+A sanity check, similar to C<assert()>. If the C<$check> is true, something
+has gone horribly wrong. It will die with the given C<$description> and
+a note to contact the author.
+
+=cut
+
+sub _whoa {
+ my( $self, $check, $desc ) = @_;
+ if($check) {
+ local $Level = $Level + 1;
+ $self->croak(<<"WHOA");
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+
+ return;
+}
+
+=item B<_my_exit>
+
+ _my_exit($exit_num);
+
+Perl seems to have some trouble with exiting inside an C<END> block.
+5.6.1 does some odd things. Instead, this function edits C<$?>
+directly. It should B<only> be called from inside an C<END> block.
+It doesn't actually exit, that's your job.
+
+=cut
+
+sub _my_exit {
+ $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+ return 1;
+}
+
+=back
+
+=end _private
+
+=cut
+
+sub _ending {
+ my $self = shift;
+ return if $self->no_ending;
+ return if $self->{Ending}++;
+
+ my $real_exit_code = $?;
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ if( $self->{Original_Pid} != $$ ) {
+ return;
+ }
+
+ # Ran tests but never declared a plan or hit done_testing
+ if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
+ $self->is_passing(0);
+ $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+ }
+
+ # Exit if plan() was never called. This is so "require Test::Simple"
+ # doesn't puke.
+ if( !$self->{Have_Plan} ) {
+ return;
+ }
+
+ # Don't do an ending if we bailed out.
+ if( $self->{Bailed_Out} ) {
+ $self->is_passing(0);
+ return;
+ }
+ # Figure out if we passed or failed and print helpful messages.
+ my $test_results = $self->{Test_Results};
+ if(@$test_results) {
+ # The plan? We have no plan.
+ if( $self->{No_Plan} ) {
+ $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
+ $self->{Expected_Tests} = $self->{Curr_Test};
+ }
+
+ # Auto-extended arrays and elements which aren't explicitly
+ # filled in with a shared reference will puke under 5.8.0
+ # ithreads. So we have to fill them in by hand. :(
+ my $empty_result = &share( {} );
+ for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
+ $test_results->[$idx] = $empty_result
+ unless defined $test_results->[$idx];
+ }
+
+ my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
+
+ my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
+
+ if( $num_extra != 0 ) {
+ my $s = $self->{Expected_Tests} == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
+FAIL
+ $self->is_passing(0);
+ }
+
+ if($num_failed) {
+ my $num_tests = $self->{Curr_Test};
+ my $s = $num_failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+
+ $self->diag(<<"FAIL");
+Looks like you failed $num_failed test$s of $num_tests$qualifier.
+FAIL
+ $self->is_passing(0);
+ }
+
+ if($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
+FAIL
+ $self->is_passing(0);
+ _my_exit($real_exit_code) && return;
+ }
+
+ my $exit_code;
+ if($num_failed) {
+ $exit_code = $num_failed <= 254 ? $num_failed : 254;
+ }
+ elsif( $num_extra != 0 ) {
+ $exit_code = 255;
+ }
+ else {
+ $exit_code = 0;
+ }
+
+ _my_exit($exit_code) && return;
+ }
+ elsif( $self->{Skip_All} ) {
+ _my_exit(0) && return;
+ }
+ elsif($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code before it could output anything.
+FAIL
+ $self->is_passing(0);
+ _my_exit($real_exit_code) && return;
+ }
+ else {
+ $self->diag("No tests run!\n");
+ $self->is_passing(0);
+ _my_exit(255) && return;
+ }
+
+ $self->is_passing(0);
+ $self->_whoa( 1, "We fell off the end of _ending()" );
+}
+
+END {
+ $Test->_ending if defined $Test;
+}
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+=head1 THREADS
+
+In perl 5.8.1 and later, Test::Builder is thread-safe. The test
+number is shared amongst all threads. This means if one thread sets
+the test number using C<current_test()> they will all be effected.
+
+While versions earlier than 5.8.1 had threads they contain too many
+bugs to support.
+
+Test::Builder is only thread-aware if threads.pm is loaded I<before>
+Test::Builder.
+
+=head1 MEMORY
+
+An informative hash, accessable via C<<details()>>, is stored for each
+test you perform. So memory usage will scale linearly with each test
+run. Although this is not a problem for most test suites, it can
+become an issue if you do large (hundred thousands to million)
+combinatorics tests in the same run.
+
+In such cases, you are advised to either split the test file into smaller
+ones, or use a reverse approach, doing "normal" (code) compares and
+triggering fail() should anything go unexpected.
+
+Future versions of Test::Builder will have a way to turn history off.
+
+
+=head1 EXAMPLES
+
+CPAN can provide the best examples. Test::Simple, Test::More,
+Test::Exception and Test::Differences all use Test::Builder.
+
+=head1 SEE ALSO
+
+Test::Simple, Test::More, Test::Harness
+
+=head1 AUTHORS
+
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
+ Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder/IO/Scalar.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/IO/Scalar.pm
new file mode 100755
index 00000000000..b8ca7207dbb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/IO/Scalar.pm
@@ -0,0 +1,658 @@
+package Test::Builder::IO::Scalar;
+
+
+=head1 NAME
+
+Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder
+
+=head1 DESCRIPTION
+
+This is a copy of IO::Scalar which ships with Test::Builder to
+support scalar references as filehandles on Perl 5.6. Newer
+versions of Perl simply use C<<open()>>'s built in support.
+
+Test::Builder can not have dependencies on other modules without
+careful consideration, so its simply been copied into the distribution.
+
+=head1 COPYRIGHT and LICENSE
+
+This file came from the "IO-stringy" Perl5 toolkit.
+
+Copyright (c) 1996 by Eryq. All rights reserved.
+Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+
+=cut
+
+# This is copied code, I don't care.
+##no critic
+
+use Carp;
+use strict;
+use vars qw($VERSION @ISA);
+use IO::Handle;
+
+use 5.005;
+
+### The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+### Inheritance:
+@ISA = qw(IO::Handle);
+
+#==============================
+
+=head2 Construction
+
+=over 4
+
+=cut
+
+#------------------------------
+
+=item new [ARGS...]
+
+I<Class method.>
+Return a new, unattached scalar handle.
+If any arguments are given, they're sent to open().
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = bless \do { local *FH }, $class;
+ tie *$self, $class, $self;
+ $self->open(@_); ### open on anonymous by default
+ $self;
+}
+sub DESTROY {
+ shift->close;
+}
+
+#------------------------------
+
+=item open [SCALARREF]
+
+I<Instance method.>
+Open the scalar handle on a new scalar, pointed to by SCALARREF.
+If no SCALARREF is given, a "private" scalar is created to hold
+the file data.
+
+Returns the self object on success, undefined on error.
+
+=cut
+
+sub open {
+ my ($self, $sref) = @_;
+
+ ### Sanity:
+ defined($sref) or do {my $s = ''; $sref = \$s};
+ (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
+
+ ### Setup:
+ *$self->{Pos} = 0; ### seek position
+ *$self->{SR} = $sref; ### scalar reference
+ $self;
+}
+
+#------------------------------
+
+=item opened
+
+I<Instance method.>
+Is the scalar handle opened on something?
+
+=cut
+
+sub opened {
+ *{shift()}->{SR};
+}
+
+#------------------------------
+
+=item close
+
+I<Instance method.>
+Disassociate the scalar handle from its underlying scalar.
+Done automatically on destroy.
+
+=cut
+
+sub close {
+ my $self = shift;
+ %{*$self} = ();
+ 1;
+}
+
+=back
+
+=cut
+
+
+
+#==============================
+
+=head2 Input and output
+
+=over 4
+
+=cut
+
+
+#------------------------------
+
+=item flush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub flush { "0 but true" }
+
+#------------------------------
+
+=item getc
+
+I<Instance method.>
+Return the next character, or undef if none remain.
+
+=cut
+
+sub getc {
+ my $self = shift;
+
+ ### Return undef right away if at EOF; else, move pos forward:
+ return undef if $self->eof;
+ substr(${*$self->{SR}}, *$self->{Pos}++, 1);
+}
+
+#------------------------------
+
+=item getline
+
+I<Instance method.>
+Return the next line, or undef on end of string.
+Can safely be called in an array context.
+Currently, lines are delimited by "\n".
+
+=cut
+
+sub getline {
+ my $self = shift;
+
+ ### Return undef right away if at EOF:
+ return undef if $self->eof;
+
+ ### Get next line:
+ my $sr = *$self->{SR};
+ my $i = *$self->{Pos}; ### Start matching at this point.
+
+ ### Minimal impact implementation!
+ ### We do the fast fast thing (no regexps) if using the
+ ### classic input record separator.
+
+ ### Case 1: $/ is undef: slurp all...
+ if (!defined($/)) {
+ *$self->{Pos} = length $$sr;
+ return substr($$sr, $i);
+ }
+
+ ### Case 2: $/ is "\n": zoom zoom zoom...
+ elsif ($/ eq "\012") {
+
+ ### Seek ahead for "\n"... yes, this really is faster than regexps.
+ my $len = length($$sr);
+ for (; $i < $len; ++$i) {
+ last if ord (substr ($$sr, $i, 1)) == 10;
+ }
+
+ ### Extract the line:
+ my $line;
+ if ($i < $len) { ### We found a "\n":
+ $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
+ *$self->{Pos} = $i+1; ### Remember where we finished up.
+ }
+ else { ### No "\n"; slurp the remainder:
+ $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
+ *$self->{Pos} = $len;
+ }
+ return $line;
+ }
+
+ ### Case 3: $/ is ref to int. Do fixed-size records.
+ ### (Thanks to Dominique Quatravaux.)
+ elsif (ref($/)) {
+ my $len = length($$sr);
+ my $i = ${$/} + 0;
+ my $line = substr ($$sr, *$self->{Pos}, $i);
+ *$self->{Pos} += $i;
+ *$self->{Pos} = $len if (*$self->{Pos} > $len);
+ return $line;
+ }
+
+ ### Case 4: $/ is either "" (paragraphs) or something weird...
+ ### This is Graham's general-purpose stuff, which might be
+ ### a tad slower than Case 2 for typical data, because
+ ### of the regexps.
+ else {
+ pos($$sr) = $i;
+
+ ### If in paragraph mode, skip leading lines (and update i!):
+ length($/) or
+ (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
+
+ ### If we see the separator in the buffer ahead...
+ if (length($/)
+ ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
+ : $$sr =~ m,\n\n,g ### (a paragraph)
+ ) {
+ *$self->{Pos} = pos $$sr;
+ return substr($$sr, $i, *$self->{Pos}-$i);
+ }
+ ### Else if no separator remains, just slurp the rest:
+ else {
+ *$self->{Pos} = length $$sr;
+ return substr($$sr, $i);
+ }
+ }
+}
+
+#------------------------------
+
+=item getlines
+
+I<Instance method.>
+Get all remaining lines.
+It will croak() if accidentally called in a scalar context.
+
+=cut
+
+sub getlines {
+ my $self = shift;
+ wantarray or croak("can't call getlines in scalar context!");
+ my ($line, @lines);
+ push @lines, $line while (defined($line = $self->getline));
+ @lines;
+}
+
+#------------------------------
+
+=item print ARGS...
+
+I<Instance method.>
+Print ARGS to the underlying scalar.
+
+B<Warning:> this continues to always cause a seek to the end
+of the string, but if you perform seek()s and tell()s, it is
+still safer to explicitly seek-to-end before subsequent print()s.
+
+=cut
+
+sub print {
+ my $self = shift;
+ *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
+ 1;
+}
+sub _unsafe_print {
+ my $self = shift;
+ my $append = join('', @_) . $\;
+ ${*$self->{SR}} .= $append;
+ *$self->{Pos} += length($append);
+ 1;
+}
+sub _old_print {
+ my $self = shift;
+ ${*$self->{SR}} .= join('', @_) . $\;
+ *$self->{Pos} = length(${*$self->{SR}});
+ 1;
+}
+
+
+#------------------------------
+
+=item read BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Read some bytes from the scalar.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=cut
+
+sub read {
+ my $self = $_[0];
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
+ $n = length($read);
+ *$self->{Pos} += $n;
+ ($off ? substr($_[1], $off) : $_[1]) = $read;
+ return $n;
+}
+
+#------------------------------
+
+=item write BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Write some bytes to the scalar.
+
+=cut
+
+sub write {
+ my $self = $_[0];
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ my $data = substr($_[1], $off, $n);
+ $n = length($data);
+ $self->print($data);
+ return $n;
+}
+
+#------------------------------
+
+=item sysread BUF, LEN, [OFFSET]
+
+I<Instance method.>
+Read some bytes from the scalar.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=cut
+
+sub sysread {
+ my $self = shift;
+ $self->read(@_);
+}
+
+#------------------------------
+
+=item syswrite BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Write some bytes to the scalar.
+
+=cut
+
+sub syswrite {
+ my $self = shift;
+ $self->write(@_);
+}
+
+=back
+
+=cut
+
+
+#==============================
+
+=head2 Seeking/telling and other attributes
+
+=over 4
+
+=cut
+
+
+#------------------------------
+
+=item autoflush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub autoflush {}
+
+#------------------------------
+
+=item binmode
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub binmode {}
+
+#------------------------------
+
+=item clearerr
+
+I<Instance method.> Clear the error and EOF flags. A no-op.
+
+=cut
+
+sub clearerr { 1 }
+
+#------------------------------
+
+=item eof
+
+I<Instance method.> Are we at end of file?
+
+=cut
+
+sub eof {
+ my $self = shift;
+ (*$self->{Pos} >= length(${*$self->{SR}}));
+}
+
+#------------------------------
+
+=item seek OFFSET, WHENCE
+
+I<Instance method.> Seek to a given position in the stream.
+
+=cut
+
+sub seek {
+ my ($self, $pos, $whence) = @_;
+ my $eofpos = length(${*$self->{SR}});
+
+ ### Seek:
+ if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
+ elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
+ elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
+ else { croak "bad seek whence ($whence)" }
+
+ ### Fixup:
+ if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
+ if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
+ return 1;
+}
+
+#------------------------------
+
+=item sysseek OFFSET, WHENCE
+
+I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
+
+=cut
+
+sub sysseek {
+ my $self = shift;
+ $self->seek (@_);
+}
+
+#------------------------------
+
+=item tell
+
+I<Instance method.>
+Return the current position in the stream, as a numeric offset.
+
+=cut
+
+sub tell { *{shift()}->{Pos} }
+
+#------------------------------
+
+=item use_RS [YESNO]
+
+I<Instance method.>
+B<Deprecated and ignored.>
+Obey the curent setting of $/, like IO::Handle does?
+Default is false in 1.x, but cold-welded true in 2.x and later.
+
+=cut
+
+sub use_RS {
+ my ($self, $yesno) = @_;
+ carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
+ }
+
+#------------------------------
+
+=item setpos POS
+
+I<Instance method.>
+Set the current position, using the opaque value returned by C<getpos()>.
+
+=cut
+
+sub setpos { shift->seek($_[0],0) }
+
+#------------------------------
+
+=item getpos
+
+I<Instance method.>
+Return the current position in the string, as an opaque object.
+
+=cut
+
+*getpos = \&tell;
+
+
+#------------------------------
+
+=item sref
+
+I<Instance method.>
+Return a reference to the underlying scalar.
+
+=cut
+
+sub sref { *{shift()}->{SR} }
+
+
+#------------------------------
+# Tied handle methods...
+#------------------------------
+
+# Conventional tiehandle interface:
+sub TIEHANDLE {
+ ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__))
+ ? $_[1]
+ : shift->new(@_));
+}
+sub GETC { shift->getc(@_) }
+sub PRINT { shift->print(@_) }
+sub PRINTF { shift->print(sprintf(shift, @_)) }
+sub READ { shift->read(@_) }
+sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
+sub WRITE { shift->write(@_); }
+sub CLOSE { shift->close(@_); }
+sub SEEK { shift->seek(@_); }
+sub TELL { shift->tell(@_); }
+sub EOF { shift->eof(@_); }
+
+#------------------------------------------------------------
+
+1;
+
+__END__
+
+
+
+=back
+
+=cut
+
+
+=head1 WARNINGS
+
+Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
+it was missing support for C<seek()>, C<tell()>, and C<eof()>.
+Attempting to use these functions with an IO::Scalar will not work
+prior to 5.005_57. IO::Scalar will not have the relevant methods
+invoked; and even worse, this kind of bug can lie dormant for a while.
+If you turn warnings on (via C<$^W> or C<perl -w>),
+and you see something like this...
+
+ attempt to seek on unopened filehandle
+
+...then you are probably trying to use one of these functions
+on an IO::Scalar with an old Perl. The remedy is to simply
+use the OO version; e.g.:
+
+ $SH->seek(0,0); ### GOOD: will work on any 5.005
+ seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
+
+
+=head1 VERSION
+
+$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHORS
+
+=head2 Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=head2 Principal author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+
+=head2 Other contributors
+
+The full set of contributors always includes the folks mentioned
+in L<IO::Stringy/"CHANGE LOG">. But just the same, special
+thanks to the following individuals for their invaluable contributions
+(if I've forgotten or misspelled your name, please email me!):
+
+I<Andy Glew,>
+for contributing C<getc()>.
+
+I<Brandon Browning,>
+for suggesting C<opened()>.
+
+I<David Richter,>
+for finding and fixing the bug in C<PRINTF()>.
+
+I<Eric L. Brine,>
+for his offset-using read() and write() implementations.
+
+I<Richard Jones,>
+for his patches to massively improve the performance of C<getline()>
+and add C<sysread> and C<syswrite>.
+
+I<B. K. Oxley (binkley),>
+for stringification and inheritance improvements,
+and sundry good ideas.
+
+I<Doug Wilson,>
+for the IO::Handle inheritance and automatic tie-ing.
+
+
+=head1 SEE ALSO
+
+L<IO::String>, which is quite similar but which was designed
+more-recently and with an IO::Handle-like interface in mind,
+so you could mix OO- and native-filehandle usage without using tied().
+
+I<Note:> as of version 2.x, these classes all work like
+their IO::Handle counterparts, so we have comparable
+functionality to IO::String.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder/Module.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Module.pm
new file mode 100755
index 00000000000..4f7d1aa7db7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Module.pm
@@ -0,0 +1,173 @@
+package Test::Builder::Module;
+
+use strict;
+
+use Test::Builder;
+
+require Exporter;
+our @ISA = qw(Exporter);
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+
+=head1 NAME
+
+Test::Builder::Module - Base class for test modules
+
+=head1 SYNOPSIS
+
+ # Emulates Test::Simple
+ package Your::Module;
+
+ my $CLASS = __PACKAGE__;
+
+ use base 'Test::Builder::Module';
+ @EXPORT = qw(ok);
+
+ sub ok ($;$) {
+ my $tb = $CLASS->builder;
+ return $tb->ok(@_);
+ }
+
+ 1;
+
+
+=head1 DESCRIPTION
+
+This is a superclass for Test::Builder-based modules. It provides a
+handful of common functionality and a method of getting at the underlying
+Test::Builder object.
+
+
+=head2 Importing
+
+Test::Builder::Module is a subclass of Exporter which means your
+module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
+all act normally.
+
+A few methods are provided to do the C<use Your::Module tests => 23> part
+for you.
+
+=head3 import
+
+Test::Builder::Module provides an import() method which acts in the
+same basic way as Test::More's, setting the plan and controling
+exporting of functions and variables. This allows your module to set
+the plan independent of Test::More.
+
+All arguments passed to import() are passed onto
+C<< Your::Module->builder->plan() >> with the exception of
+C<import =>[qw(things to import)]>.
+
+ use Your::Module import => [qw(this that)], tests => 23;
+
+says to import the functions this() and that() as well as set the plan
+to be 23 tests.
+
+import() also sets the exported_to() attribute of your builder to be
+the caller of the import() function.
+
+Additional behaviors can be added to your import() method by overriding
+import_extra().
+
+=cut
+
+sub import {
+ my($class) = shift;
+
+ # Don't run all this when loading ourself.
+ return 1 if $class eq 'Test::Builder::Module';
+
+ my $test = $class->builder;
+
+ my $caller = caller;
+
+ $test->exported_to($caller);
+
+ $class->import_extra( \@_ );
+ my(@imports) = $class->_strip_imports( \@_ );
+
+ $test->plan(@_);
+
+ $class->export_to_level( 1, $class, @imports );
+}
+
+sub _strip_imports {
+ my $class = shift;
+ my $list = shift;
+
+ my @imports = ();
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'import' ) {
+ push @imports, @{ $list->[ $idx + 1 ] };
+ $idx++;
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return @imports;
+}
+
+=head3 import_extra
+
+ Your::Module->import_extra(\@import_args);
+
+import_extra() is called by import(). It provides an opportunity for you
+to add behaviors to your module based on its import list.
+
+Any extra arguments which shouldn't be passed on to plan() should be
+stripped off by this method.
+
+See Test::More for an example of its use.
+
+B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
+feels like a bit of an ugly hack in its current form.
+
+=cut
+
+sub import_extra { }
+
+=head2 Builder
+
+Test::Builder::Module provides some methods of getting at the underlying
+Test::Builder object.
+
+=head3 builder
+
+ my $builder = Your::Class->builder;
+
+This method returns the Test::Builder object associated with Your::Class.
+It is not a constructor so you can call it as often as you like.
+
+This is the preferred way to get the Test::Builder object. You should
+I<not> get it via C<< Test::Builder->new >> as was previously
+recommended.
+
+The object returned by builder() may change at runtime so you should
+call builder() inside each function rather than store it in a global.
+
+ sub ok {
+ my $builder = Your::Class->builder;
+
+ return $builder->ok(@_);
+ }
+
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester.pm
new file mode 100755
index 00000000000..7bea6f99da6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester.pm
@@ -0,0 +1,603 @@
+package Test::Builder::Tester;
+
+use strict;
+our $VERSION = "1.18";
+
+use Test::Builder;
+use Symbol;
+use Carp;
+
+=head1 NAME
+
+Test::Builder::Tester - test testsuites that have been built with
+Test::Builder
+
+=head1 SYNOPSIS
+
+ use Test::Builder::Tester tests => 1;
+ use Test::More;
+
+ test_out("not ok 1 - foo");
+ test_fail(+1);
+ fail("foo");
+ test_test("fail works");
+
+=head1 DESCRIPTION
+
+A module that helps you test testing modules that are built with
+B<Test::Builder>.
+
+The testing system is designed to be used by performing a three step
+process for each test you wish to test. This process starts with using
+C<test_out> and C<test_err> in advance to declare what the testsuite you
+are testing will output with B<Test::Builder> to stdout and stderr.
+
+You then can run the test(s) from your test suite that call
+B<Test::Builder>. At this point the output of B<Test::Builder> is
+safely captured by B<Test::Builder::Tester> rather than being
+interpreted as real test output.
+
+The final stage is to call C<test_test> that will simply compare what you
+predeclared to what B<Test::Builder> actually outputted, and report the
+results back with a "ok" or "not ok" (with debugging) to the normal
+output.
+
+=cut
+
+####
+# set up testing
+####
+
+my $t = Test::Builder->new;
+
+###
+# make us an exporter
+###
+
+use Exporter;
+our @ISA = qw(Exporter);
+
+our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
+
+sub import {
+ my $class = shift;
+ my(@plan) = @_;
+
+ my $caller = caller;
+
+ $t->exported_to($caller);
+ $t->plan(@plan);
+
+ my @imports = ();
+ foreach my $idx ( 0 .. $#plan ) {
+ if( $plan[$idx] eq 'import' ) {
+ @imports = @{ $plan[ $idx + 1 ] };
+ last;
+ }
+ }
+
+ __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports );
+}
+
+###
+# set up file handles
+###
+
+# create some private file handles
+my $output_handle = gensym;
+my $error_handle = gensym;
+
+# and tie them to this package
+my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
+my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
+
+####
+# exported functions
+####
+
+# for remembering that we're testing and where we're testing at
+my $testing = 0;
+my $testing_num;
+
+# remembering where the file handles were originally connected
+my $original_output_handle;
+my $original_failure_handle;
+my $original_todo_handle;
+
+my $original_test_number;
+my $original_harness_state;
+
+my $original_harness_env;
+
+# function that starts testing and redirects the filehandles for now
+sub _start_testing {
+ # even if we're running under Test::Harness pretend we're not
+ # for now. This needed so Test::Builder doesn't add extra spaces
+ $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
+ $ENV{HARNESS_ACTIVE} = 0;
+
+ # remember what the handles were set to
+ $original_output_handle = $t->output();
+ $original_failure_handle = $t->failure_output();
+ $original_todo_handle = $t->todo_output();
+
+ # switch out to our own handles
+ $t->output($output_handle);
+ $t->failure_output($error_handle);
+ $t->todo_output($error_handle);
+
+ # clear the expected list
+ $out->reset();
+ $err->reset();
+
+ # remeber that we're testing
+ $testing = 1;
+ $testing_num = $t->current_test;
+ $t->current_test(0);
+
+ # look, we shouldn't do the ending stuff
+ $t->no_ending(1);
+}
+
+=head2 Functions
+
+These are the six methods that are exported as default.
+
+=over 4
+
+=item test_out
+
+=item test_err
+
+Procedures for predeclaring the output that your test suite is
+expected to produce until C<test_test> is called. These procedures
+automatically assume that each line terminates with "\n". So
+
+ test_out("ok 1","ok 2");
+
+is the same as
+
+ test_out("ok 1\nok 2");
+
+which is even the same as
+
+ test_out("ok 1");
+ test_out("ok 2");
+
+Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
+been called once all further output from B<Test::Builder> will be
+captured by B<Test::Builder::Tester>. This means that your will not
+be able perform further tests to the normal output in the normal way
+until you call C<test_test> (well, unless you manually meddle with the
+output filehandles)
+
+=cut
+
+sub test_out {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ $out->expect(@_);
+}
+
+sub test_err {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ $err->expect(@_);
+}
+
+=item test_fail
+
+Because the standard failure message that B<Test::Builder> produces
+whenever a test fails will be a common occurrence in your test error
+output, and because has changed between Test::Builder versions, rather
+than forcing you to call C<test_err> with the string all the time like
+so
+
+ test_err("# Failed test ($0 at line ".line_num(+1).")");
+
+C<test_fail> exists as a convenience function that can be called
+instead. It takes one argument, the offset from the current line that
+the line that causes the fail is on.
+
+ test_fail(+1);
+
+This means that the example in the synopsis could be rewritten
+more simply as:
+
+ test_out("not ok 1 - foo");
+ test_fail(+1);
+ fail("foo");
+ test_test("fail works");
+
+=cut
+
+sub test_fail {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ # work out what line we should be on
+ my( $package, $filename, $line ) = caller;
+ $line = $line + ( shift() || 0 ); # prevent warnings
+
+ # expect that on stderr
+ $err->expect("# Failed test ($0 at line $line)");
+}
+
+=item test_diag
+
+As most of the remaining expected output to the error stream will be
+created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
+provides a convience function C<test_diag> that you can use instead of
+C<test_err>.
+
+The C<test_diag> function prepends comment hashes and spacing to the
+start and newlines to the end of the expected output passed to it and
+adds it to the list of expected error output. So, instead of writing
+
+ test_err("# Couldn't open file");
+
+you can write
+
+ test_diag("Couldn't open file");
+
+Remember that B<Test::Builder>'s diag function will not add newlines to
+the end of output and test_diag will. So to check
+
+ Test::Builder->new->diag("foo\n","bar\n");
+
+You would do
+
+ test_diag("foo","bar")
+
+without the newlines.
+
+=cut
+
+sub test_diag {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ # expect the same thing, but prepended with "# "
+ local $_;
+ $err->expect( map { "# $_" } @_ );
+}
+
+=item test_test
+
+Actually performs the output check testing the tests, comparing the
+data (with C<eq>) that we have captured from B<Test::Builder> against
+that that was declared with C<test_out> and C<test_err>.
+
+This takes name/value pairs that effect how the test is run.
+
+=over
+
+=item title (synonym 'name', 'label')
+
+The name of the test that will be displayed after the C<ok> or C<not
+ok>.
+
+=item skip_out
+
+Setting this to a true value will cause the test to ignore if the
+output sent by the test to the output stream does not match that
+declared with C<test_out>.
+
+=item skip_err
+
+Setting this to a true value will cause the test to ignore if the
+output sent by the test to the error stream does not match that
+declared with C<test_err>.
+
+=back
+
+As a convience, if only one argument is passed then this argument
+is assumed to be the name of the test (as in the above examples.)
+
+Once C<test_test> has been run test output will be redirected back to
+the original filehandles that B<Test::Builder> was connected to
+(probably STDOUT and STDERR,) meaning any further tests you run
+will function normally and cause success/errors for B<Test::Harness>.
+
+=cut
+
+sub test_test {
+ # decode the arguements as described in the pod
+ my $mess;
+ my %args;
+ if( @_ == 1 ) {
+ $mess = shift
+ }
+ else {
+ %args = @_;
+ $mess = $args{name} if exists( $args{name} );
+ $mess = $args{title} if exists( $args{title} );
+ $mess = $args{label} if exists( $args{label} );
+ }
+
+ # er, are we testing?
+ croak "Not testing. You must declare output with a test function first."
+ unless $testing;
+
+ # okay, reconnect the test suite back to the saved handles
+ $t->output($original_output_handle);
+ $t->failure_output($original_failure_handle);
+ $t->todo_output($original_todo_handle);
+
+ # restore the test no, etc, back to the original point
+ $t->current_test($testing_num);
+ $testing = 0;
+
+ # re-enable the original setting of the harness
+ $ENV{HARNESS_ACTIVE} = $original_harness_env;
+
+ # check the output we've stashed
+ unless( $t->ok( ( $args{skip_out} || $out->check ) &&
+ ( $args{skip_err} || $err->check ), $mess )
+ )
+ {
+ # print out the diagnostic information about why this
+ # test failed
+
+ local $_;
+
+ $t->diag( map { "$_\n" } $out->complaint )
+ unless $args{skip_out} || $out->check;
+
+ $t->diag( map { "$_\n" } $err->complaint )
+ unless $args{skip_err} || $err->check;
+ }
+}
+
+=item line_num
+
+A utility function that returns the line number that the function was
+called on. You can pass it an offset which will be added to the
+result. This is very useful for working out the correct text of
+diagnostic functions that contain line numbers.
+
+Essentially this is the same as the C<__LINE__> macro, but the
+C<line_num(+3)> idiom is arguably nicer.
+
+=cut
+
+sub line_num {
+ my( $package, $filename, $line ) = caller;
+ return $line + ( shift() || 0 ); # prevent warnings
+}
+
+=back
+
+In addition to the six exported functions there there exists one
+function that can only be accessed with a fully qualified function
+call.
+
+=over 4
+
+=item color
+
+When C<test_test> is called and the output that your tests generate
+does not match that which you declared, C<test_test> will print out
+debug information showing the two conflicting versions. As this
+output itself is debug information it can be confusing which part of
+the output is from C<test_test> and which was the original output from
+your original tests. Also, it may be hard to spot things like
+extraneous whitespace at the end of lines that may cause your test to
+fail even though the output looks similar.
+
+To assist you C<test_test> can colour the background of the debug
+information to disambiguate the different types of output. The debug
+output will have it's background coloured green and red. The green
+part represents the text which is the same between the executed and
+actual output, the red shows which part differs.
+
+The C<color> function determines if colouring should occur or not.
+Passing it a true or false value will enable or disable colouring
+respectively, and the function called with no argument will return the
+current setting.
+
+To enable colouring from the command line, you can use the
+B<Text::Builder::Tester::Color> module like so:
+
+ perl -Mlib=Text::Builder::Tester::Color test.t
+
+Or by including the B<Test::Builder::Tester::Color> module directly in
+the PERL5LIB.
+
+=cut
+
+my $color;
+
+sub color {
+ $color = shift if @_;
+ $color;
+}
+
+=back
+
+=head1 BUGS
+
+Calls C<<Test::Builder->no_ending>> turning off the ending tests.
+This is needed as otherwise it will trip out because we've run more
+tests than we strictly should have and it'll register any failures we
+had that we were testing for as real failures.
+
+The color function doesn't work unless B<Term::ANSIColor> is
+compatible with your terminal.
+
+Bugs (and requests for new features) can be reported to the author
+though the CPAN RT system:
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
+
+=head1 AUTHOR
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+Some code taken from B<Test::More> and B<Test::Catch>, written by by
+Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts
+Copyright Micheal G Schwern 2001. Used and distributed with
+permission.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 NOTES
+
+Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
+me use his testing system to try this module out on.
+
+=head1 SEE ALSO
+
+L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
+
+=cut
+
+1;
+
+####################################################################
+# Helper class that is used to remember expected and received data
+
+package Test::Builder::Tester::Tie;
+
+##
+# add line(s) to be expected
+
+sub expect {
+ my $self = shift;
+
+ my @checks = @_;
+ foreach my $check (@checks) {
+ $check = $self->_translate_Failed_check($check);
+ push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
+ }
+}
+
+sub _translate_Failed_check {
+ my( $self, $check ) = @_;
+
+ if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
+ $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
+ }
+
+ return $check;
+}
+
+##
+# return true iff the expected data matches the got data
+
+sub check {
+ my $self = shift;
+
+ # turn off warnings as these might be undef
+ local $^W = 0;
+
+ my @checks = @{ $self->{wanted} };
+ my $got = $self->{got};
+ foreach my $check (@checks) {
+ $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
+ return 0 unless $got =~ s/^$check//;
+ }
+
+ return length $got == 0;
+}
+
+##
+# a complaint message about the inputs not matching (to be
+# used for debugging messages)
+
+sub complaint {
+ my $self = shift;
+ my $type = $self->type;
+ my $got = $self->got;
+ my $wanted = join "\n", @{ $self->wanted };
+
+ # are we running in colour mode?
+ if(Test::Builder::Tester::color) {
+ # get color
+ eval { require Term::ANSIColor };
+ unless($@) {
+ # colours
+
+ my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
+ my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
+ my $reset = Term::ANSIColor::color("reset");
+
+ # work out where the two strings start to differ
+ my $char = 0;
+ $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
+
+ # get the start string and the two end strings
+ my $start = $green . substr( $wanted, 0, $char );
+ my $gotend = $red . substr( $got, $char ) . $reset;
+ my $wantedend = $red . substr( $wanted, $char ) . $reset;
+
+ # make the start turn green on and off
+ $start =~ s/\n/$reset\n$green/g;
+
+ # make the ends turn red on and off
+ $gotend =~ s/\n/$reset\n$red/g;
+ $wantedend =~ s/\n/$reset\n$red/g;
+
+ # rebuild the strings
+ $got = $start . $gotend;
+ $wanted = $start . $wantedend;
+ }
+ }
+
+ return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
+}
+
+##
+# forget all expected and got data
+
+sub reset {
+ my $self = shift;
+ %$self = (
+ type => $self->{type},
+ got => '',
+ wanted => [],
+ );
+}
+
+sub got {
+ my $self = shift;
+ return $self->{got};
+}
+
+sub wanted {
+ my $self = shift;
+ return $self->{wanted};
+}
+
+sub type {
+ my $self = shift;
+ return $self->{type};
+}
+
+###
+# tie interface
+###
+
+sub PRINT {
+ my $self = shift;
+ $self->{got} .= join '', @_;
+}
+
+sub TIEHANDLE {
+ my( $class, $type ) = @_;
+
+ my $self = bless { type => $type }, $class;
+
+ $self->reset;
+
+ return $self;
+}
+
+sub READ { }
+sub READLINE { }
+sub GETC { }
+sub FILENO { }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester/Color.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester/Color.pm
new file mode 100755
index 00000000000..264fddbfd86
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester/Color.pm
@@ -0,0 +1,51 @@
+package Test::Builder::Tester::Color;
+
+use strict;
+our $VERSION = "1.18";
+
+require Test::Builder::Tester;
+
+
+=head1 NAME
+
+Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester
+
+=head1 SYNOPSIS
+
+ When running a test script
+
+ perl -MTest::Builder::Tester::Color test.t
+
+=head1 DESCRIPTION
+
+Importing this module causes the subroutine color in Test::Builder::Tester
+to be called with a true value causing colour highlighting to be turned
+on in debug output.
+
+The sole purpose of this module is to enable colour highlighting
+from the command line.
+
+=cut
+
+sub import {
+ Test::Builder::Tester::color(1);
+}
+
+=head1 AUTHOR
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 BUGS
+
+This module will have no effect unless Term::ANSIColor is installed.
+
+=head1 SEE ALSO
+
+L<Test::Builder::Tester>, L<Term::ANSIColor>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pm
new file mode 100755
index 00000000000..5ba50944de1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pm
@@ -0,0 +1,517 @@
+use strict;
+use warnings;
+
+package Test::Deep;
+use Carp qw( confess );
+
+use Test::Deep::Cache;
+use Test::Deep::Stack;
+use Test::Deep::RegexpVersion;
+
+require overload;
+use Scalar::Util;
+
+my $Test;
+unless (defined $Test::Deep::NoTest::NoTest)
+{
+# for people who want eq_deeply but not Test::Builder
+ require Test::Builder;
+ $Test = Test::Builder->new;
+}
+
+use Data::Dumper qw(Dumper);
+
+use vars qw(
+ $VERSION @EXPORT @EXPORT_OK @ISA
+ $Stack %Compared $CompareCache %WrapCache
+ $Snobby $Expects $DNE $DNE_ADDR $Shallow
+);
+
+$VERSION = '0.106';
+$VERSION = eval $VERSION;
+
+require Exporter;
+@ISA = qw( Exporter );
+
+@EXPORT = qw( eq_deeply cmp_deeply cmp_set cmp_bag cmp_methods
+ useclass noclass set bag subbagof superbagof subsetof
+ supersetof superhashof subhashof
+);
+ # plus all the ones generated from %constructors below
+
+@EXPORT_OK = qw( descend render_stack class_base cmp_details deep_diag );
+
+$Snobby = 1; # should we compare classes?
+$Expects = 0; # are we comparing got vs expect or expect vs expect
+
+$DNE = \"";
+$DNE_ADDR = Scalar::Util::refaddr($DNE);
+
+# if no sub name is supplied then we use the package name in lower case
+my %constructors = (
+ Number => "num",
+ Methods => "",
+ ListMethods => "",
+ String => "str",
+ Boolean => "bool",
+ ScalarRef => "scalref",
+ ScalarRefOnly => "",
+ Array => "",
+ ArrayEach => "array_each",
+ ArrayElementsOnly => "",
+ Hash => "",
+ HashEach => "hash_each",
+ Regexp => "re",
+ RegexpMatches => "",
+ RegexpOnly => "",
+ RegexpRef => "",
+ Ignore => "",
+ Shallow => "",
+ Any => "",
+ All => "",
+ Isa => "Isa",
+ RegexpRefOnly => "",
+ RefType => "",
+ Blessed => "",
+ ArrayLength => "",
+ ArrayLengthOnly => "",
+ HashKeys => "",
+ HashKeysOnly => "",
+ Code => "",
+);
+
+while (my ($pkg, $name) = each %constructors)
+{
+ $name = lc($pkg) unless $name;
+ my $full_pkg = "Test::Deep::$pkg";
+ my $file = "$full_pkg.pm";
+ $file =~ s#::#/#g;
+ my $sub = sub {
+ require $file;
+ return $full_pkg->new(@_);
+ };
+ {
+ no strict 'refs';
+ *{$name} = $sub;
+ }
+ push(@EXPORT, $name);
+}
+my %count;
+foreach my $e (@EXPORT)
+{
+ $count{$e}++;
+}
+
+# this is ugly, I should never have exported a sub called isa now I
+# have to try figure out if the recipient wanted my isa or if a class
+# imported us and UNIVERSAL::isa is being called on that class.
+# Luckily our isa always expects 1 argument and U::isa always expects
+# 2, so we can figure out (assuming the caller is no buggy).
+sub isa
+{
+ if (@_ == 1)
+ {
+ goto &Isa;
+ }
+ else
+ {
+ goto &UNIVERSAL::isa;
+ }
+}
+
+push(@EXPORT, "isa");
+
+sub cmp_deeply
+{
+ my ($d1, $d2, $name) = @_;
+
+ my ($ok, $stack) = cmp_details($d1, $d2);
+
+ if (not $Test->ok($ok, $name))
+ {
+ my $diag = deep_diag($stack);
+ $Test->diag($diag);
+ }
+
+ return $ok;
+}
+
+sub cmp_details
+{
+ my ($d1, $d2) = @_;
+
+ local $Stack = Test::Deep::Stack->new;
+ local $CompareCache = Test::Deep::Cache->new;
+ local %WrapCache;
+
+ my $ok = descend($d1, $d2);
+
+ return ($ok, $Stack);
+}
+
+sub eq_deeply
+{
+ my ($d1, $d2) = @_;
+
+ my ($ok) = cmp_details($d1, $d2);
+
+ return $ok
+}
+
+sub eq_deeply_cache
+{
+ # this is like cross between eq_deeply and descend(). It doesn't start
+ # with a new $CompareCache but if the comparison fails it will leave
+ # $CompareCache as if nothing happened. However, if the comparison
+ # succeeds then $CompareCache retains all the new information
+
+ # this allows Set and Bag to handle circular refs
+
+ my ($d1, $d2, $name) = @_;
+
+ local $Stack = Test::Deep::Stack->new;
+ $CompareCache->local;
+
+ my $ok = descend($d1, $d2);
+
+ $CompareCache->finish($ok);
+
+ return $ok;
+}
+
+sub deep_diag
+{
+ my $stack = shift;
+ # ick! incArrow and other things expect the stack has to be visible
+ # in a well known place . TODO clean this up
+ local $Stack = $stack;
+
+ my $where = render_stack('$data', $stack);
+
+ confess "No stack to diagnose" unless $stack;
+ my $last = $stack->getLast;
+
+ my $diag;
+ my $message;
+ my $got;
+ my $expected;
+
+ my $exp = $last->{exp};
+ if (ref $exp)
+ {
+ if ($exp->can("diagnostics"))
+ {
+ $diag = $exp->diagnostics($where, $last);
+ $diag =~ s/\n+$/\n/;
+ }
+ else
+ {
+ if ($exp->can("diag_message"))
+ {
+ $message = $exp->diag_message($where);
+ }
+ }
+ }
+
+ if (not defined $diag)
+ {
+ $got = $exp->renderGot($last->{got}) unless defined $got;
+ $expected = $exp->renderExp unless defined $expected;
+ $message = "Compared $where" unless defined $message;
+
+ $diag = <<EOM
+$message
+ got : $got
+expect : $expected
+EOM
+ }
+
+ return $diag;
+}
+
+sub render_val
+{
+ # add in Data::Dumper stuff
+ my $val = shift;
+
+ my $rendered;
+ if (defined $val)
+ {
+ $rendered = ref($val) ?
+ (Scalar::Util::refaddr($val) eq $DNE_ADDR ?
+ "Does not exist" :
+ overload::StrVal($val)
+ ) :
+ qq('$val');
+ }
+ else
+ {
+ $rendered = "undef";
+ }
+
+ return $rendered;
+}
+
+sub descend
+{
+ my ($d1, $d2) = @_;
+
+ if (! $Expects and ref($d1) and UNIVERSAL::isa($d1, "Test::Deep::Cmp"))
+ {
+ my $where = $Stack->render('$data');
+ confess "Found a special comparison in $where\nYou can only the specials in the expects structure";
+ }
+
+ if (ref $d1 and ref $d2)
+ {
+ # this check is only done when we're comparing 2 expecteds against each
+ # other
+
+ if ($Expects and UNIVERSAL::isa($d1, "Test::Deep::Cmp"))
+ {
+ # check they are the same class
+ return 0 unless Test::Deep::blessed(Scalar::Util::blessed($d2))->descend($d1);
+ if ($d1->can("compare"))
+ {
+ return $d1->compare($d2);
+ }
+ }
+
+ my $s1 = Scalar::Util::refaddr($d1);
+ my $s2 = Scalar::Util::refaddr($d2);
+
+ if ($s1 eq $s2)
+ {
+ return 1;
+ }
+ if ($CompareCache->cmp($d1, $d2))
+ {
+ # we've tried comparing these already so either they turned out to
+ # be the same or we must be in a loop and we have to assume they're
+ # the same
+
+ return 1;
+ }
+ else
+ {
+ $CompareCache->add($d1, $d2)
+ }
+ }
+
+ $d2 = wrap($d2);
+
+ $Stack->push({exp => $d2, got => $d1});
+
+ if (ref($d1) and (Scalar::Util::refaddr($d1) == $DNE_ADDR))
+ {
+ # whatever it was suposed to be, it didn't exist and so it's an
+ # automatic fail
+ return 0;
+ }
+
+ if ($d2->descend($d1))
+ {
+# print "d1 = $d1, d2 = $d2\nok\n";
+ $Stack->pop;
+
+ return 1;
+ }
+ else
+ {
+# print "d1 = $d1, d2 = $d2\nnot ok\n";
+ return 0;
+ }
+}
+
+sub wrap
+{
+ my $data = shift;
+
+ return $data if ref($data) and UNIVERSAL::isa($data, "Test::Deep::Cmp");
+
+ my ($class, $base) = class_base($data);
+
+ my $cmp;
+
+ if($base eq '')
+ {
+ $cmp = shallow($data);
+ }
+ else
+ {
+ my $addr = Scalar::Util::refaddr($data);
+
+ return $WrapCache{$addr} if $WrapCache{$addr};
+
+ if($base eq 'ARRAY')
+ {
+ $cmp = array($data);
+ }
+ elsif($base eq 'HASH')
+ {
+ $cmp = hash($data);
+ }
+ elsif($base eq 'SCALAR' or $base eq 'REF')
+ {
+ $cmp = scalref($data);
+ }
+ elsif(($base eq 'Regexp') or ($base eq 'REGEXP'))
+ {
+ $cmp = regexpref($data);
+ }
+ else
+ {
+ $cmp = shallow($data);
+ }
+
+ $WrapCache{$addr} = $cmp;
+ }
+ return $cmp;
+}
+
+sub class_base
+{
+ my $val = shift;
+
+ if (ref $val)
+ {
+ my $blessed = Scalar::Util::blessed($val);
+ $blessed = defined($blessed) ? $blessed : "";
+ my $reftype = Scalar::Util::reftype($val);
+
+
+ if ($Test::Deep::RegexpVersion::OldStyle) {
+ if ($blessed eq "Regexp" and $reftype eq "SCALAR")
+ {
+ $reftype = "Regexp"
+ }
+ }
+ return ($blessed, $reftype);
+ }
+ else
+ {
+ return ("", "");
+ }
+}
+
+sub render_stack
+{
+ my ($var, $stack) = @_;
+
+ return $stack->render($var);
+}
+
+sub cmp_methods
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ return cmp_deeply(shift, methods(@{shift()}), shift);
+}
+
+sub requireclass
+{
+ require Test::Deep::Class;
+
+ my $val = shift;
+
+ return Test::Deep::Class->new(1, $val);
+}
+
+# docs and export say this is call useclass, doh!
+
+*useclass = \&requireclass;
+
+sub noclass
+{
+ require Test::Deep::Class;
+
+ my $val = shift;
+
+ return Test::Deep::Class->new(0, $val);
+}
+
+sub set
+{
+ require Test::Deep::Set;
+
+ return Test::Deep::Set->new(1, "", @_);
+}
+
+sub supersetof
+{
+ require Test::Deep::Set;
+
+ return Test::Deep::Set->new(1, "sup", @_);
+}
+
+sub subsetof
+{
+ require Test::Deep::Set;
+
+ return Test::Deep::Set->new(1, "sub", @_);
+}
+
+sub cmp_set
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ return cmp_deeply(shift, set(@{shift()}), shift);
+}
+
+sub bag
+{
+ require Test::Deep::Set;
+
+ return Test::Deep::Set->new(0, "", @_);
+}
+
+sub superbagof
+{
+ require Test::Deep::Set;
+
+ return Test::Deep::Set->new(0, "sup", @_);
+}
+
+sub subbagof
+{
+ require Test::Deep::Set;
+
+ return Test::Deep::Set->new(0, "sub", @_);
+}
+
+sub cmp_bag
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $ref = ref($_[1]) || "";
+ confess "Argument 2 to cmp_bag is not an ARRAY ref (".render_val($_[1]).")"
+ unless $ref eq "ARRAY";
+ return cmp_deeply(shift, bag(@{shift()}), shift);
+}
+
+sub superhashof
+{
+ require Test::Deep::Hash;
+
+ my $val = shift;
+
+ return Test::Deep::SuperHash->new($val);
+}
+
+sub subhashof
+{
+ require Test::Deep::Hash;
+
+ my $val = shift;
+
+ return Test::Deep::SubHash->new($val);
+}
+
+sub builder
+{
+ if (@_)
+ {
+ $Test = shift;
+ }
+ return $Test;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep.pod b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pod
new file mode 100755
index 00000000000..ffaab48b400
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pod
@@ -0,0 +1,932 @@
+=head1 NAME
+
+Test::Deep - Extremely flexible deep comparison
+
+=head1 SYNOPSIS
+
+ use Test::More tests => $Num_Tests;
+ use Test::Deep;
+
+ cmp_deeply(
+ $actual_horrible_nested_data_structure,
+ $expected_horrible_nested_data_structure,
+ "got the right horrible nested data structure"
+ );
+
+ cmp_deeply(
+ $object,
+ methods(name => "John", phone => "55378008"),
+ "object methods ok"
+ );
+
+ cmp_deeply(
+ \@array,
+ [$hash1, $hash2, ignore(
+ "first 2 elements are as expected, ignoring 3"
+ );
+
+ cmp_deeply(
+ $object,
+ noclass({value => 5}),
+ "object looks ok, not checking it's class"
+ );
+
+ cmp_deeply(
+ \@result,
+ bag('a', 'b', {key => [1, 2]}),
+ "array has the 3 things we wanted in some order"
+ );
+
+=head1 DESCRIPTION
+
+If you don't know anything about automated testing in Perl then you should
+probably read about Test::Simple and Test::More before preceding.
+Test::Deep uses the Test::Builder framework.
+
+Test::Deep gives you very flexible ways to check that the result you got is
+the result you were expecting. At it's simplest it compares two structures
+by going through each level, ensuring that the values match, that arrays and
+hashes have the same elements and that references are blessed into the
+correct class. It also handles circular data structures without getting
+caught in an infinite loop.
+
+Where it becomes more interesting is in allowing you to do something besides
+simple exact comparisons. With strings, the C<eq> operator checks that 2
+strings are exactly equal but sometimes that's not what you want. When you
+don't know exactly what the string should be but you do know some things
+about how it should look, C<eq> is no good and you must use pattern matching
+instead. Test::Deep provides pattern matching for complex data structures
+
+=head1 EXAMPLES
+
+How Test::Deep works is much easier to understand by seeing some examples.
+
+=head2 Without Test::Deep
+
+Say you want to test a function which returns a string. You know that your
+string should be a 7 digit number beginning with 0, C<eq> is no good in this
+situation, you need a regular expression. So you could use Test::More's
+C<like()> function:
+
+ like($string, '/^0d{6}$/', "number looks good");
+
+Similarly, to check that a string looks like a name, you could do:
+
+ like($string, '/^(Mr|Mrs|Miss) \w+ \w+$/',
+ "got title, first and last name");
+
+Now imagine your function produces a hash with some personal details in it.
+You want to make sure that there are 2 keys, Name and Phone and that the
+name looks like a name and the phone number looks like a phone number. You
+could do:
+
+ $hash = make_person();
+ like($hash->{Name}, '/^(Mr|Mrs|Miss) \w+ \w+$/', "name ok");
+ like($hash->{Phone}, '/^0d{6}$/', "phone ok");
+ is(scalar keys %$hash, 2, "correct number of keys");
+
+But that's not quite right, what if make_person has a serious problem and
+didn't even return a hash? We really need to write
+
+ if (ref($hash) eq "HASH")
+ {
+ like($hash->{Name}, '/^(Mr|Mrs|Miss) \w+ \w+$/', "name ok");
+ like($hash->{Phone}, '/^0d{6}$/', "phone ok");
+ is(scalar keys %$hash, 2, "correct number of keys");
+ }
+ else
+ {
+ fail("person not a hash");
+ fail("person not a hash");
+ fail("person not a hash"); # need 3 to keep the plan correct
+ }
+
+Already this is getting messy, now imagine another entry in the hash, an
+array of children's names. This would require
+
+
+ if (ref($hash) eq "HASH")
+ {
+ like($hash->{Name}, $name_pat, "name ok");
+ like($hash->{Phone}, '/^0d{6}$/', "phone ok");
+ my $cn = $hash->{ChildNames};
+ if (ref($cn) eq "ARRAY")
+ {
+ foreach my $child (@$cn)
+ {
+ like($child, $name_pat);
+ }
+ }
+ else
+ {
+ fail("child names not an array")
+ }
+ }
+ else
+ {
+ fail("person not a hash");
+ }
+
+This is a horrible mess and because we don't know in advance how many
+children's names there will be, we can't make a plan for our test anymore
+(actually, we could but it would make things even more complicated).
+
+Test::Deep to the rescue.
+
+=head2 With Test::Deep
+
+ my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
+ cmp_deeply(
+ $person,
+ {
+ Name => $name_re,
+ Phone => re('^0d{6}$'),
+ ChildNames => array_each($name_re)
+ },
+ "person ok"
+ );
+
+This will do everything that the messy code above does and it will give a
+sensible message telling you exactly what went wrong if it finds a part of
+$person that doesn't match the pattern. C<re()> and C<array_each()> are
+special function imported from Test::Deep. They create a marker that tells
+Test::Deep that something different is happening here. Instead of just doing
+a simple comparison and checking are two things exactly equal, it should do
+something else.
+
+If a person was asked to check that 2 structures are equal, they could print
+them both out and compare them line by line. The markers above are similar
+to writing a note in red pen on one of the printouts telling the person that
+for this piece of the structure, they should stop doing simple line by line
+comparison and do something else.
+
+C<re($regex)> means that Test::Deep should check that the current piece of
+data matches the regex in C<$regex>. C<array_each($struct)> means that
+Test::Deep should expect the current piece of data to be an array and it
+should check that every element of that array matches C<$struct>.
+In this case, every element of C<$person->{ChildNames}> should look like a
+name. If say the 3rd one didn't you would get an error message something
+like
+
+ Using Regexp on $data->{ChildNames}[3]
+ got : 'Queen John Paul Sartre'
+ expect : /^(Mr|Mrs|Miss) \w+ \w+$/
+
+There are lots of other special comparisons available, see
+L<SPECIAL COMPARISONS PROVIDED> below for the full list.
+
+=head2 Reusing structures
+
+Test::Deep is good for reusing test structures so you can do this
+
+ my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
+ my $person_cmp = {
+ Name => $name_re,
+ Phone => re('^0d{6}$'),
+ ChildNames => array_each($name_re)
+ };
+
+ cmp_deeply($person1, $person_cmp, "person ok");
+ cmp_deeply($person2, $person_cmp, "person ok");
+ cmp_deeply($person3, $person_cmp, "person ok");
+
+You can even put $person_cmp in a module and let other people use it when
+they are writing test scripts for modules that use your modules.
+
+To make things a little more difficult, lets change the person data
+structure so that instead of a list of ChildNames, it contains a list of
+hashes, one for each child. So in fact our person structure will contain
+other person structures which may contain other person structures and so on.
+This is easy to handle with Test::Deep because Test::Deep structures can
+include themselves. Simply do
+
+ my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
+ my $person_cmp = {
+ Name => $name_re,
+ Phone => re('^0d{6}$'),
+ # note no mention of Children here
+ };
+
+ $person_cmp->{Children} = each_array($person_cmp);
+
+ cmp_deeply($person, $person_cmp, "person ok");
+
+This will now check that $person->{Children} is an array and that every
+element of that array also matches C<$person_cmp>, this includes checking
+that it's children also match the same pattern and so on.
+
+=head2 Circular data structures
+
+A circular data structure is one which loops back on itself, you can make
+one easily by doing
+
+ my @b;
+ my @a = (1, 2, 3, \@b);
+ push(@b, \@a);
+
+now @a contains a reference to be @b and @b contains a reference to @a. This
+causes problems if you have a program that wants to look inside @a and keep
+looking deeper and deeper at every level, it could get caught in an infinite
+loop looking into @a then @b then @a then @b and so on.
+
+Test::Deep avoids this problem so we can extend our example further by
+saying that a person should also list their parents.
+
+ my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
+ my $person_cmp = {
+ Name => $name_re,
+ Phone => re('^0d{6}$'),
+ # note no mention of Children here
+ };
+
+ $person_cmp->{Children} = each_array($person_cmp);
+ $person_cmp->{Parents} = each_array($person_cmp);
+
+ cmp_deeply($person, $person_cmp, "person ok");
+
+So this will check that for each child C<$child> in C<$person->{Children}>
+that the C<$child->{Parents} matches C<$person_cmp> however it is smart
+enough not to get caught in an infinite loop where it keeps bouncing between
+the same Parent and Child.
+
+=head1 TERMINOLOGY
+
+C<cmp_deeply($got, $expected, $name)> takes 3 arguments. C<$got> is the
+structure that you are checking, you must not include any special
+comparisons in this structure or you will get a fatal error. C<$expected>
+describes what Test::Deep will be looking for in $got. You can put special
+comparisons in $expected if you want to.
+
+As Test::Deep descends through the 2 structures, it compares them one piece
+at a time, so at any point in the process, Test::Deep is thinking about 2
+things - the current value from C<$got> and the current value from
+C<$expected>. In the documentation, I call them C<$got_v> and C<exp_v>
+respectively.
+
+=head1 COMPARISON FUNCTIONS
+
+=head3 $ok = cmp_deeply($got, $expected, $name)
+
+$got is the result to be checked. $expected is the structure against which
+$got will be check. $name is the test name.
+
+This is the main comparison function, the others are just wrappers around
+this. Without any special comparisons, it will descend into $expected,
+following every reference and comparing C<$expected_v> to C<$got_v> (using
+C<eq>) at the same position. If at any stage C<$expected_v> is a special
+comparison then Test::Deep may do something else besides a simple string
+comparison, exactly what it does depends on which special comparison it is.
+
+=head3 $ok = cmp_bag(\@got, \@bag, $name)
+
+Is shorthand for cmp_deeply(\@got, bag(@bag), $name)
+
+N.B. Both arguments must be array refs. If they aren't an error will
+be raised via die.
+
+=head3 $ok = cmp_set(\@got, \@set, $name)
+
+Is shorthand for cmp_deeply(\@got, set(@set), $name)
+
+=head3 $ok = cmp_methods(\@got, \@methods, $name)
+
+Is shorthand for cmp_deeply(\@got, methods(@methods), $name)
+
+=head3 $ok = eq_deeply($got, $expected)
+
+This is the same as cmp_deeply() except it just returns true or
+false. It does not create diagnostics or talk to L<Test::Builder>, but
+if you want to use it in a non-testing environment then you should
+import it through L<Test::Deep::NoTest>. For example
+
+ use Test::Deep::NoTest;
+ print "a equals b" unless eq_deeply($a, $b);
+
+otherwise the L<Test::Builder> framework will be loaded and testing messages
+will be output when your program ends.
+
+=head3 ($ok, $stack) = cmp_details($got, $expected)
+
+This behaves much like eq_deeply, but it additionally allows you to
+produce diagnostics in case of failure by passing the value in C<$stack>
+to C<deep_diag>.
+
+Do not make assumptions about the structure or content of C<$stack> and
+do not use it if C<$ok> contains a true value.
+
+See L</USING TEST::DEEP WITH TEST::BUILDER> for example uses.
+
+=head1 SPECIAL COMPARISONS PROVIDED
+
+=head3 ignore()
+
+This makes Test::Deep skip tests on $got_v. No matter what value C<$got_v>
+has, Test::Deep will think it's correct. This is useful if some part of the
+structure you are testing is very complicated and already tested elsewhere,
+or is unpredictable.
+
+ cmp_deeply($got, { name => 'John', random => ignore(), address => ['5 A
+ street', 'a town', 'a country'],
+ })
+
+is the equivalent of checking
+
+ $got->{name} eq 'John';
+ exists $got->{random};
+ cmp_deeply($got->{address};
+ ['5 A street', 'a town', 'a country']);
+
+=head3 methods(%hash)
+
+%hash is a hash of method call => expected value pairs.
+
+This lets you call methods on an object and check the result of each call.
+The methods will be called in the order supplied. If you want to pass
+arguments to the method you should wrap the method name and arguments in an
+array reference.
+
+ cmp_deeply(
+ $obj,
+ methods(name => "John", ["favourite", "food"] => "taco")
+ );
+
+is roughly the equivalent of checking that
+
+ $obj->name eq "John"
+ $obj->favourite("food") eq "taco"
+
+The methods will be called in the order you supply them and will be called
+in scalar context. If you need to test methods called in list context then
+you should use listmethods().
+
+B<NOTE> Just as in a normal test script, you need to be careful if the
+methods you call have side effects like changing the object or other objects
+in the structure. Although the order of the methods is fixed, the order of
+some other tests is not so if $expected is
+
+ {
+ manager => methods(@manager_methods),
+ coder => methods(@coder_methods)
+ }
+
+there is no way to know which if manager and coder will be tested first. If
+the methods you are testing depend on and alter global variables or if
+manager and coder are the same object then you may run into problems.
+
+=head3 listmethods(%hash)
+
+%hash is a hash of method call => expected value pairs.
+
+This is almost identical to methods() except the methods are called in list
+context instead of scalar context. This means that the expected values
+supplied must be an array reference.
+
+ cmp_deeply(
+ $obj,
+ listmethods(
+ name => "John",
+ ["favourites", "food"] => ["Mapo tofu", "Gongbao chicken"]
+ )
+ );
+
+is the equivalent of checking that
+
+ $obj->name eq "John"
+ cmp_deeply([$obj->favourites("food")], ["Mapo tofu", "Gongbao chicken"]);
+
+The methods will be called in the order you supply them.
+
+B<NOTE> The same caveats apply as for methods().
+
+=head3 shallow($thing)
+
+$thing is a ref.
+
+This prevents Test::Deep from looking inside $thing. It allows you to
+check that $got_v and $thing are references to the same variable. So
+
+ my @a = @b = (1, 2, 3);
+ cmp_deeply(\@a, \@b);
+
+will pass because @a and @b have the same elements however
+
+ cmp_deeply(\@a, shallow(\@b))
+
+will fail because although \@a and \@b both contain C<1, 2, 3> they are
+references to different arrays.
+
+=head3 noclass($thing)
+
+$thing is a structure to be compared against.
+
+This makes Test::Deep ignore the class of objects, so it just looks at the
+data they contain. Class checking will be turned off until Test::Deep is
+finished comparing C<$got_v> against C<$thing>. Once Test::Deep comes out of
+C<$thing> it will go back to it's previous setting for checking class.
+
+This can be useful when you want to check that objects have been
+constructed correctly but you don't want to write lots of
+C<bless>es. If \@people is an array of Person objects then
+
+ cmp_deeply(\@people, noclass([
+ bless {name => 'John', phone => '555-5555'}, "Person",
+ bless {name => 'Anne', phone => '444-4444'}, "Person",
+ ]));
+
+can be replaced with
+
+ cmp_deeply(\@people, noclass([
+ {name => 'John', phone => '555-5555'},
+ {name => 'Anne', phone => '444-4444'}
+ ]));
+
+However, this is testing so you should also check that the objects are
+blessed correctly. You could use a map to bless all those hashes or you
+could do a second test like
+
+ cmp_deeply($people, array_each(isa("Person"));
+
+=head3 useclass($thing)
+
+This turns back on the class comparison while inside a noclass().
+
+ cmp_deeply(
+ $got,
+ noclass(
+ [
+ useclass( $object )
+ ]
+ )
+ )
+
+In this example the class of the array reference in C<$got> is ignored but
+the class of C<$object> is checked, as is the class of everything inside
+C<$object>.
+
+=head3 re($regexp, $capture_data, $flags)
+
+$regexp is either a regular expression reference produced with C<qr/.../> or
+a string which will be used to construct a regular expression.
+
+$capture_data is optional and is used to check the strings captured by
+an regex. This should can be an array ref or a Test::Deep comparator
+that works on array refs.
+
+$flags is an optional string which controls whether the regex runs as a
+global match. If $flags is "g" then the regex will run as m/$regexp/g.
+
+Without $capture_data, this simply compares $got_v with the regular expression
+provided. So
+
+ cmp_deeply($got, [ re("ferg") ])
+
+is the equivalent of
+
+ $got->[0] =~ /ferg/
+
+With $capture_data
+
+ cmp_deeply($got, [re($regex, $capture_data])
+
+is the equivalent of
+
+ my @data = $got->[0] =~ /$regex/;
+ cmp_deeply(\@data, $capture_data);
+
+So you can do something simple like
+
+ cmp_deeply($got, re(qr/(\d\d)(\w\w)/, [25, "ab" ])
+
+to check that (\d\d) was 25 and (\w\w) was "ab" but you can also use
+Test::Deep objects to do more complex testing of the captured values
+
+ cmp_deeply("cat=2,dog=67,sheep=3,goat=2,dog=5",
+ re(qr/(\D+)=\d+,?/, set(qw( cat sheep dog )), "g"))
+
+here, the regex will match the string and will capture the animal names and
+check that they match the specified set, in this case it will fail,
+complaining that "goat" is not in the set.
+
+=head3 superhashof(\%hash)
+
+This will check that the hash C<%$got> is a "super-hash" of C<%hash>. That
+is that all the key and value pairs in C<%hash> appear in C<%$got> but
+C<%$got> can have extra ones also.
+
+For example
+
+ cmp_deeply({a => 1, b => 2}, superhashof({a => 1}))
+
+will pass but
+
+ cmp_deeply({a => 1, b => 2}, superhashof({a => 1, c => 3}))
+
+will fail.
+
+=head3 subhashof(\%hash)
+
+This will check that the hash C<%$got> is a "sub-hash" of C<%hash>. That is
+that all the key and value pairs in C<%$got> also appear in C<%hash>.
+
+For example
+
+ cmp_deeply({a => 1}, subhashof({a => 1, b => 2}))
+
+will pass but
+
+ cmp_deeply({a => 1, c => 3}, subhashof({a => 1, b => 2}))
+
+will fail.
+
+=head3 bag(@elements)
+
+@elements is an array of elements.
+
+This does a bag comparison, that is, it compares two arrays but ignores the
+order of the elements so
+
+ cmp_deeply([1, 2, 2], bag(2, 2, 1))
+
+will be a pass.
+
+The object returned by bag() has an add() method.
+
+ my $bag = bag(1, 2, 3);
+ $bag->add(2, 3, 4);
+
+will result in a bag containing 1, 2, 2, 3, 3, 4.
+
+C<NOTE> If you use certain special comparisons within a bag or set
+comparison there is a danger that a test will fail when it should have
+passed. It can only happen if two or more special comparisons in the bag are
+competing to match elements. Consider this comparison
+
+ cmp_deeply(['furry', 'furball'], bag(re("^fur"), re("furb")))
+
+There are two things that could happen, hopefully C<re("^fur")> is paired with
+"furry" and C<re("^furb")> is paired with "furb" and everything is fine but it
+could happen that C<re("^fur")> is paired with "furball" and then C<re("^furb")>
+cannot find a match and so the test fails. Examples of other competing
+comparisons are C<bag(1, 2, 2)> vs C<set(1, 2)> and
+C<methods(m1 => "v1", m2 => "v2")> vs C<methods(m1 => "v1")>
+
+This problem is could be solved by using a slower and more complicated
+algorithm for set and bag matching. Something for the future...
+
+=head3 set(@elements)
+
+@elements is an array of elements.
+
+This does a set comparison, that is, it compares two arrays but ignores the
+order of the elements and it ignores duplicate elements, so
+
+ cmp_deeply([1, 2, 2, 3], set(3, 2, 1, 1))
+
+will be a pass.
+
+The object returned by set() has an add() method.
+
+ my $set = set(1, 2, 3);
+ $set->add(4, 5, 6);
+
+will result in a set containing 1, 2, 3, 4, 5, 5.
+
+C<NOTE> See the NOTE on the bag() comparison for some dangers in using
+special comparisons inside set()
+
+=head3 superbagof(@elements), subbagof(@elements), supersetof(@elements) and subsetof(@elements)
+
+@elements is an array of elements.
+
+These do exactly what you'd expect them to do, so for example
+
+ cmp_deeply($data, subbagof(1, 1, 3, 4));
+
+checks that @$data contains at most 2 "1"s, 1 "3" and 1 "4" and
+
+ cmp_deeply($data, supsersetof(1, 4));
+
+check that @$data contains at least 1 "1" and 1 "4".
+
+These are just special cases of the Set and Bag comparisons so they also
+give you an add() method and they also have the same limitations when using
+special comparisons inside them (see the NOTE in the bag() section).
+
+=head3 all(@expecteds)
+
+@expecteds is an array of expected structures.
+
+This allows you to compare data against multiple expected results and make
+sure each of them matches.
+
+ cmp_deeply($got, all(isa("Person"), methods(name => 'John')))
+
+is equivalent to
+
+ $got->isa("Person")
+ $got->name eq 'John'
+
+If either test fails then the whole thing is considered a fail. This is a
+short-circuit test, the testing is stopped after the first failure, although
+in the future it may complete all tests so that diagnostics can be output
+for all failures. When reporting failure, the parts are counted from 1.
+
+Thanks to the magic of overloading, you can write
+
+ all(isa("Person"), methods(name => 'John'), re("^wi"))
+
+as
+
+ isa("Person") & methods(name => 'John') | re("^wi")
+
+Note B<single> | not double as || cannot be overloaded. This will only work
+when there is a special comparison involved. If you write
+
+ "john" | "anne" | "robert"
+
+Perl will turn this into
+
+ "{onort"
+
+which is presumably not what you wanted. This is because Perl |s them
+together as strings before Test::Deep gets a chance to do any overload
+tricks.
+
+=head3 any(@expecteds)
+
+@expecteds is an array of expected structures.
+
+This can be used to compare data against multiple expected results and make
+sure that at least one of them matches. This is a short-circuit test so if
+a test passes then none of the tests after that will be attempted.
+
+You can also use overloading with | similarly to all().
+
+=head3 isa($class), Isa($class)
+
+$class is a class name.
+
+This uses UNIVERSAL::isa() to check that $got_v is blessed into the class
+$class.
+
+B<NOTE:> Isa() does exactly as documented here, isa() is slightly
+different. If isa() is called with 1 argument it falls through to
+Isa(). If isa() called with 2 arguments, it falls through to
+UNIVERAL::isa. This is to prevent breakage when you import isa() into
+a package that is used as a class. Without this, anyone calling
+C<Class-E<gt>isa($other_class)> would get the wrong answer. This is a
+hack to patch over the fact that isa is exported by default.
+
+=head3 array_each($thing)
+
+$thing is a structure to be compared against.
+
+<$got_v> must be an array reference. Each element of it will be compared to
+$thing. This is useful when you have an array of similar things, for example
+objects of a known type and you don't want to have to repeat the same test
+for each one.
+
+ my $common_tests = all(
+ isa("MyFile"),
+ methods(
+ handle => isa("IO::Handle")
+ filename => re("^/home/ted/tmp"),
+ )
+ );
+
+ cmp_deeply($got, array_each($common_tests));
+
+is similar to
+
+ foreach my $got_v (@$got) {
+ cmp_deeply($got_v, $common_tests)
+ }
+
+Except it will not explode is $got is not an array reference. It will check
+that each of the objects in @$got is a MyFile and that each one gives the
+correct results for it's methods.
+
+You could go further, if for example there were 3 files and you knew the
+size of each one you could do this
+
+ cmp_deeply(
+ $got,
+ all(
+ array_each($common_tests),
+ [
+ methods(size => 1000),
+ methods(size => 200),
+ methods(size => 20)
+ ]
+ )
+ )
+ cmp_deeply($got, array_each($structure));
+
+=head3 str($string)
+
+$string is a string.
+
+This will stringify C<$got_v> and compare it to C<$string> using C<eq>, even
+if $got_v is a ref. It is useful for checking the stringified value of an
+overloaded reference.
+
+=head3 num($number, $tolerance)
+
+$number is a number.
+$tolerance is an optional number.
+
+This will add 0 to C<$got_v> and check if it's numerically equal to
+C<$number>, even if $got_v is a ref. It is useful for checking the numerical
+value of an overloaded reference. If $tolerance is supplied then this will
+check that $got_v and $exp_v are less than $tolerance apart. This is useful
+when comparing floating point numbers as rounding errors can make it hard or
+impossible for $got_v to be exactly equal to $exp_v. When $tolerance is
+supplied, the test passes if C<abs($got_v - $exp_v) <= $tolerance>.
+
+B<Note> in Perl, C<"12blah" == 12> because Perl will be smart and convert
+"12blah" into 12. You may not want this. There was a strict mode but that is
+now gone. A "lookslike s number" test will replace it soon. Until then you
+can usually just use the string() comparison to be more strict. This will
+work fine for almost all situations, however it will not work when <$got_v>
+is an overloaded value who's string and numerical values differ.
+
+=head3 bool($value)
+
+$value is anything you like but it's probably best to use 0 or 1
+
+This will check that C<$got_v> and C<$value> have the same truth value, that
+is they will give the same result when used in boolean context, like in an
+if() statement.
+
+=head3 code(\&subref)
+
+\&subref is a reference to a subroutine which will be passed a single
+argument, it then should return a true or false and possibly a string
+
+This will pass C<$got_v> to the subroutine which returns true or false to
+indicate a pass or fail. Fails can be accompanied by a diagnostic string
+which gives an explanation of why it's a fail.
+
+ sub check_name
+ {
+ my $name = shift;
+ if ($boss->likes($name))
+ {
+ return 1;
+ }
+ else
+ {
+ return (0, "the boss doesn't like your name");
+ }
+ }
+
+ cmp_deeply("Brian", \&check_name);
+
+=head1 DIAGNOSTIC FUNCTIONS
+
+=head3 my $reason = deep_diag($stack)
+
+C<$stack> is a value returned by cmp_details. Do not call this function
+if cmp_details returned a true value for C<$ok>.
+
+deep_diag() returns a human readable string describing how the
+comparison failed.
+
+=head1 ANOTHER EXAMPLE
+
+You've written a module to handle people and their film interests. Say you
+have a function that returns an array of people from a query, each person is
+a hash with 2 keys: Name and Age and the array is sorted by Name. You can do
+
+ cmp_deeply(
+ $result,
+ [
+ {Name => 'Anne', Age => 26},
+ {Name => "Bill", Age => 47}
+ {Name => 'John', Age => 25},
+ ]
+ );
+
+Soon after, your query function changes and all the results now have an ID
+field. Now your test is failing again because you left out ID from each of
+the hashes. The problem is that the IDs are generated by the database and
+you have no way of knowing what each person's ID is. With Test::Deep you can
+change your query to
+
+ cmp_deeply(
+ $result,
+ [
+ {Name => 'John', Age => 25, ID => ignore()},
+ {Name => 'Anne', Age => 26, ID => ignore()},
+ {Name => "Bill", Age => 47, ID => ignore()}
+ ]
+ );
+
+But your test still fails. Now, because you're using a database, you no
+longer know what order the people will appear in. You could add a sort into
+the database query but that could slow down your application. Instead you
+can get Test::Deep to ignore the order of the array by doing a bag
+comparison instead.
+
+ cmp_deeply(
+ $result,
+ bag(
+ {Name => 'John', Age => 25, ID => ignore()},
+ {Name => 'Anne', Age => 26, ID => ignore()},
+ {Name => "Bill", Age => 47, ID => ignore()}
+ )
+ );
+
+Finally person gets even more complicated and includes a new field called
+Movies, this is a list of movies that the person has seen recently, again
+these movies could also come back in any order so we need a bag inside our
+other bag comparison, giving us something like
+
+ cmp_deeply(
+ $result,
+ bag(
+ {Name => 'John', Age => 25, ID => ignore(), Movies => bag(...)},
+ {Name => 'Anne', Age => 26, ID => ignore(), Movies => bag(...)},
+ {Name => "Bill", Age => 47, ID => ignore(), Movies => bag(...)}
+ )
+ );
+
+=head1 USING TEST::DEEP WITH TEST::BUILDER
+
+Combining C<cmp_details> and C<test_diag> makes it possible to use
+Test::Deep in your own test classes.
+
+In a L<Test::Builder> subclass, create a test method in the following
+form:
+
+ sub behaves_ok {
+ my $self = shift;
+ my $expected = shift;
+ my $test_name = shift;
+
+ my $got = do_the_important_work_here();
+
+ my ($ok, $stack) = cmp_details($got, $expected);
+ unless ($Test->ok($ok, $test_name)) {
+ my $diag = deep_diag($stack);
+ $Test->diag($diag);
+ }
+ }
+
+As the subclass defines a test class, not tests themselves, make sure it
+uses L<Test::Deep::NoTest>, not C<Test::Deep> itself.
+
+=head1 LIMITATIONS
+
+Currently any CODE, GLOB or IO refs will be compared using shallow(), which
+means only their memory addresses are compared.
+
+=head1 BUGS
+
+There is a bug in set and bag compare to do with competing SCs. It only
+occurs when you put certain special comparisons inside bag or set
+comparisons you don't need to worry about it. The full details are in the
+bag() docs. It will be fixed in an upcoming version.
+
+=head1 WHAT ARE SPECIAL COMPARISONS?
+
+A special comparison (SC) is simply an object that inherits from
+Test::Deep::Cmp. Whenever C<$expected_v> is an SC then instead of checking
+C<$got_v eq $expected_v>, we pass control over to the SC and let it do it's
+thing.
+
+Test::Deep exports lots of SC constructors, to make it easy for you to use
+them in your test scripts. For example is C<re("hello")> is just a handy way
+of creating a Test::Deep::Regexp object that will match any string containing
+"hello". So
+
+ cmp_deeply([ 'a', 'b', 'hello world'], ['a', 'b', re("^hello")]);
+
+will check C<'a' eq 'a'>, C<'b' eq 'b'> but when it comes to comparing
+C<'hello world'> and C<re("^hello")> it will see that
+$expected_v is an SC and so will pass control to the Test::Deep::Regexp class
+by do something like C<$expected_v->descend($got_v)>. The C<descend()>
+method should just return true or false.
+
+This gives you enough to write your own SCs but I haven't documented how
+diagnostics works because it's about to get an overhaul.
+
+=head1 SEE ALSO
+
+L<Test::More>
+
+=head1 AUTHOR
+
+Fergal Daly E<lt>fergal@esatclear.ieE<gt>, with thanks to Michael G Schwern
+for Test::More's is_deeply function which inspired this.
+
+=head1 COPYRIGHT
+
+Copyright 2003, 2004 by Fergal Daly E<lt>fergal@esatclear.ieE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/All.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/All.pm
new file mode 100755
index 00000000000..d171d3fa7a1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/All.pm
@@ -0,0 +1,64 @@
+use strict;
+use warnings;
+
+package Test::Deep::All;
+
+use Test::Deep::Cmp;
+
+use overload
+ '&' => \&add,
+ fallback => 1,
+;
+
+sub init
+{
+ my $self = shift;
+
+ my @list = map {Test::Deep::wrap($_)} @_;
+
+ $self->{val} = \@list;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $data = $self->data;
+
+ my $index = 1;
+
+ foreach my $cmp (@{$self->{val}})
+ {
+ $data->{index} = $index;
+ $index++;
+
+ next if Test::Deep::descend($got, $cmp);
+ return 0
+ }
+
+ return 1;
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my $var = shift;
+ my $data = shift;
+
+ my $max = @{$self->{val}};
+
+ return "(Part $data->{index} of $max in $var)";
+}
+
+sub add
+{
+ my $self = shift;
+ my $expect = shift;
+
+ push(@{$self->{val}}, Test::Deep::wrap($expect));
+
+ return $self;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Any.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Any.pm
new file mode 100755
index 00000000000..2485d9b87f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Any.pm
@@ -0,0 +1,65 @@
+use strict;
+use warnings;
+
+package Test::Deep::Any;
+
+use Test::Deep::Cmp;
+
+use overload
+ '&' => \&add,
+ fallback => 1,
+;
+
+sub init
+{
+ my $self = shift;
+
+ my @list = map {Test::Deep::wrap($_)} @_;
+
+ $self->{val} = \@list;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ foreach my $cmp (@{$self->{val}})
+ {
+ return 1 if Test::Deep::eq_deeply_cache($got, $cmp);
+ }
+
+ return 0;
+}
+
+sub diagnostics
+{
+ my $self = shift;
+ my ($where, $last) = @_;
+
+ my $expect = $self->{val};
+
+ my $got = $self->renderGot($last->{got});
+ my $things = join(", ", map {$_->renderExp} @$expect);
+
+ my $diag = <<EOM;
+Comparing $where with Any
+got : $got
+expected : Any of ( $things )
+EOM
+
+ $diag =~ s/\n+$/\n/;
+ return $diag;
+}
+
+sub add
+{
+ my $self = shift;
+ my $expect = shift;
+
+ push(@{$self->{val}}, Test::Deep::wrap($expect));
+
+ return $self;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Array.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Array.pm
new file mode 100755
index 00000000000..27c3cd3fe41
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Array.pm
@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+package Test::Deep::Array;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ return 0 unless Test::Deep::descend($got, Test::Deep::arraylength(scalar @$exp));
+
+ return 0 unless $self->test_class($got);
+
+ return Test::Deep::descend($got, Test::Deep::arrayelementsonly($exp));
+}
+
+sub reset_arrow
+{
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayEach.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayEach.pm
new file mode 100755
index 00000000000..f6d9417d5f5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayEach.pm
@@ -0,0 +1,27 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayEach;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $exp = [ ($self->{val}) x @$got ];
+
+ return Test::Deep::descend($got, $exp);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayElementsOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayElementsOnly.pm
new file mode 100755
index 00000000000..7704e80f6d6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayElementsOnly.pm
@@ -0,0 +1,54 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayElementsOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ my $data = $self->data;
+
+ for my $i (0..$#{$exp})
+ {
+ $data->{index} = $i;
+
+ my $got_elem = $got->[$i];
+ my $exp_elem = $exp->[$i];
+
+ return 0 unless Test::Deep::descend($got_elem, $exp_elem)
+ }
+
+ return 1;
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my ($var, $data) = @_;
+ $var .= "->" unless $Test::Deep::Stack->incArrow;
+ $var .= "[$data->{index}]";
+
+ return $var;
+}
+
+sub reset_arrow
+{
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLength.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLength.pm
new file mode 100755
index 00000000000..a4c2c6ac8a1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLength.pm
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayLength;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ return 0 unless $self->test_reftype($got, "ARRAY");
+
+ return Test::Deep::descend($got, Test::Deep::arraylengthonly($exp));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLengthOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLengthOnly.pm
new file mode 100755
index 00000000000..ac11967ff21
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLengthOnly.pm
@@ -0,0 +1,60 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayLengthOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $len = $self->{val};
+
+ return @$got == $len;
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my ($var, $data) = @_;
+
+ return "array length of $var";
+}
+
+sub renderVal
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ return "array with $val element(s)"
+}
+
+sub renderGot
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ return $self->renderVal(@$got + 0);
+}
+
+sub renderExp
+{
+ my $self = shift;
+
+ return $self->renderVal($self->{val});
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Blessed.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Blessed.pm
new file mode 100755
index 00000000000..62fdc48c358
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Blessed.pm
@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+
+package Test::Deep::Blessed;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( blessed );
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $exp = $self->{val};
+ my $blessed = blessed($got);
+
+ return Test::Deep::descend($blessed, Test::Deep::shallow($exp));
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my $var = shift;
+
+ return "blessed($var)"
+}
+
+sub renderGot
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ $self->SUPER::renderGot(blessed($got));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Boolean.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Boolean.pm
new file mode 100755
index 00000000000..e0204031718
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Boolean.pm
@@ -0,0 +1,46 @@
+use strict;
+use warnings;
+
+package Test::Deep::Boolean;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ $self->{val} = shift() ? 1 : 0;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ return !( $got xor $self->{val} );
+}
+
+sub diag_message
+{
+ my $self = shift;
+ my $where = shift;
+ return "Comparing $where as a boolean";
+}
+
+sub renderExp
+{
+ my $self = shift;
+
+ $self->renderGot($self->{val});
+}
+
+sub renderGot
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ return ($val ? "true" : "false")." (".Test::Deep::render_val($val).")";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache.pm
new file mode 100755
index 00000000000..e9ffd952740
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache.pm
@@ -0,0 +1,78 @@
+use strict;
+use warnings;
+
+package Test::Deep::Cache;
+
+use Test::Deep::Cache::Simple;
+
+sub new
+{
+ my $pkg = shift;
+
+ my $self = bless {}, $pkg;
+
+ $self->{expects} = [Test::Deep::Cache::Simple->new];
+ $self->{normal} = [Test::Deep::Cache::Simple->new];
+
+ $self->local;
+
+ return $self;
+}
+
+sub add
+{
+ my $self = shift;
+
+ my $type = $self->type;
+
+ $self->{$type}->[-1]->add(@_);
+}
+
+sub cmp
+{
+ # go through all the caches to see if we know this one
+
+ my $self = shift;
+
+ my $type = $self->type;
+
+ foreach my $cache (@{$self->{$type}})
+ {
+ return 1 if $cache->cmp(@_);
+ }
+
+ return 0
+}
+
+sub local
+{
+ my $self = shift;
+
+ foreach my $type (qw( expects normal ))
+ {
+ push(@{$self->{$type}}, Test::Deep::Cache::Simple->new);
+ }
+}
+
+sub finish
+{
+ my $self = shift;
+
+ my $keep = shift;
+
+ foreach my $type (qw( expects normal ))
+ {
+ my $caches = $self->{$type};
+
+ my $last = pop @$caches;
+
+ $caches->[-1]->absorb($last) if $keep;
+ }
+}
+
+sub type
+{
+ return $Test::Deep::Expects ? "expects" : "normal";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache/Simple.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache/Simple.pm
new file mode 100755
index 00000000000..e8e76a41438
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache/Simple.pm
@@ -0,0 +1,81 @@
+use strict;
+use warnings;
+
+package Test::Deep::Cache::Simple;
+use Carp qw( confess );
+
+use Scalar::Util qw( refaddr );
+
+BEGIN
+{
+ if (grep /^weaken$/, @Scalar::Util::EXPORT_FAIL)
+ {
+ # we're running on a version of perl that has no weak refs, so we
+ # just install a no-op sub for weaken instead of importing it
+ *weaken = sub {};
+ }
+ else
+ {
+ Scalar::Util->import('weaken');
+ }
+}
+
+sub new
+{
+ my $pkg = shift;
+
+ my $self = bless {}, $pkg;
+
+ return $self;
+}
+
+sub add
+{
+ my $self = shift;
+
+ my ($d1, $d2) = @_;
+ {
+ local $SIG{__DIE__};
+
+ # cannot weaken read only refs, no harm if we can't as they never
+ # disappear
+ eval{weaken($d1)};
+ eval{weaken($d2)};
+ }
+
+ $self->{fn_get_key(@_)} = [$d1, $d2];
+}
+
+sub cmp
+{
+ my $self = shift;
+
+ my $key = fn_get_key(@_);
+ my $pair = $self->{$key};
+
+ # are both weakened refs still valid, if not delete this entry
+ if (ref($pair->[0]) and ref($pair->[1]))
+ {
+ return 1;
+ }
+ else
+ {
+ delete $self->{$key};
+ return 0;
+ }
+}
+
+sub absorb
+{
+ my $self = shift;
+
+ my $other = shift;
+
+ @{$self}{keys %$other} = values %$other;
+}
+
+sub fn_get_key
+{
+ return join(",", sort (map {refaddr($_)} @_));
+}
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Class.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Class.pm
new file mode 100755
index 00000000000..2e58484f608
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Class.pm
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::Class;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ my $snobby = shift;
+ my $val = shift;
+
+ $self->{snobby} = $snobby;
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ local $Test::Deep::Snobby = $self->{snobby};
+
+ Test::Deep::wrap($self->{val})->descend($got);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cmp.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cmp.pm
new file mode 100755
index 00000000000..adc8ffb8b81
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cmp.pm
@@ -0,0 +1,130 @@
+use strict;
+use warnings;
+
+package Test::Deep::Cmp;
+
+use overload
+ '&' => \&make_all,
+ '|' => \&make_any,
+ '""' => \&string,
+ fallback => 1,
+;
+
+sub import
+{
+ my $pkg = shift;
+
+ my $callpkg = caller();
+ if ($callpkg =~ /^Test::Deep::/)
+ {
+ no strict 'refs';
+
+ push @{$callpkg."::ISA"}, $pkg;
+ }
+}
+
+sub new
+{
+ my $pkg = shift;
+
+ my $self = bless {}, $pkg;
+
+ $self->init(@_);
+ return $self;
+}
+
+sub init
+{
+}
+
+sub make_all
+{
+ my ($e1, $e2) = @_;
+
+ if (UNIVERSAL::isa($e1, "Test::Deep::All"))
+ {
+ $e1->add($e2);
+ return $e1;
+ }
+ elsif(UNIVERSAL::isa($e2, "Test::Deep::All"))
+ {
+ $e2->add($e1);
+ return $e2;
+ }
+ else
+ {
+ return Test::Deep::all($e1, $e2);
+ }
+}
+
+sub make_any
+{
+ my ($e1, $e2) = @_;
+
+ if (UNIVERSAL::isa($e1, "Test::Deep::Any"))
+ {
+ $e1->add($e2);
+ return $e1;
+ }
+ elsif(UNIVERSAL::isa($e2, "Test::Deep::Any"))
+ {
+ $e2->add($e1);
+ return $e2;
+ }
+ else
+ {
+ return Test::Deep::any($e1, $e2);
+ }
+}
+
+sub cmp
+{
+ my ($a1, $a2, $rev) = @_;
+
+ ($a1, $a2) = ($a2, $a1) if $rev;
+
+ return (overload::StrVal($a1) cmp overload::StrVal($a2));
+}
+
+sub string
+{
+ my $self = shift;
+
+ return overload::StrVal($self);
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my $var = shift;
+
+ return $var;
+}
+
+sub renderExp
+{
+ my $self = shift;
+
+ return $self->renderGot($self->{val});
+}
+
+sub renderGot
+{
+ my $self = shift;
+
+ return Test::Deep::render_val(@_);
+}
+
+sub reset_arrow
+{
+ return 1;
+}
+
+sub data
+{
+ my $self = shift;
+
+ return $Test::Deep::Stack->getLast;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Code.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Code.pm
new file mode 100755
index 00000000000..8768a590f6d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Code.pm
@@ -0,0 +1,58 @@
+use strict;
+use warnings;
+
+package Test::Deep::Code;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ my $code = shift || die "No coderef supplied";
+
+ $self->{code} = $code;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my ($ok, $diag) = &{$self->{code}}($got);
+
+ $self->data->{diag} = $diag;
+
+ return $ok;
+}
+
+sub diagnostics
+{
+ my $self = shift;
+ my ($where, $last) = @_;
+
+ my $error = $last->{diag};
+ my $data = Test::Deep::render_val($last->{got});
+ my $diag = <<EOM;
+Ran coderef at $where on
+
+$data
+EOM
+ if (defined($error))
+ {
+ $diag .= <<EOM;
+and it said
+$error
+EOM
+ }
+ else
+ {
+ $diag .= <<EOM;
+it failed but it didn't say why.
+EOM
+ }
+
+ return $diag;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Hash.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Hash.pm
new file mode 100755
index 00000000000..75975248e24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Hash.pm
@@ -0,0 +1,104 @@
+use strict;
+use warnings;
+
+package Test::Deep::Hash;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ my $data = $self->data;
+
+ return 0 unless Test::Deep::descend($got, $self->hash_keys($exp));
+
+ return 0 unless $self->test_class($got);
+
+ return Test::Deep::descend($got, $self->hash_elements($exp));
+}
+
+sub hash_elements
+{
+ require Test::Deep::HashElements;
+
+ my $self = shift;
+
+ return Test::Deep::HashElements->new(@_);
+}
+
+sub hash_keys
+{
+ require Test::Deep::HashKeys;
+
+ my $self = shift;
+ my $exp = shift;
+
+ return Test::Deep::HashKeys->new(keys %$exp);
+}
+
+sub reset_arrow
+{
+ return 0;
+}
+
+package Test::Deep::SuperHash;
+
+use base 'Test::Deep::Hash';
+
+sub hash_elements
+{
+ require Test::Deep::HashElements;
+
+ my $self = shift;
+
+ return Test::Deep::SuperHashElements->new(@_);
+}
+
+sub hash_keys
+{
+ require Test::Deep::HashKeys;
+
+ my $self = shift;
+ my $exp = shift;
+
+ return Test::Deep::SuperHashKeys->new(keys %$exp);
+}
+
+package Test::Deep::SubHash;
+
+use base 'Test::Deep::Hash';
+
+sub hash_elements
+{
+ require Test::Deep::HashElements;
+
+ my $self = shift;
+
+ return Test::Deep::SubHashElements->new(@_);
+}
+
+sub hash_keys
+{
+ require Test::Deep::HashKeys;
+
+ my $self = shift;
+ my $exp = shift;
+
+ return Test::Deep::SubHashKeys->new(keys %$exp);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashEach.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashEach.pm
new file mode 100755
index 00000000000..b1937c6a780
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashEach.pm
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashEach;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my %exp;
+
+ @exp{keys %$got} = ($self->{val}) x (keys %$got);
+
+ return Test::Deep::descend($got, \%exp);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashElements.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashElements.pm
new file mode 100755
index 00000000000..c398ecacf97
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashElements.pm
@@ -0,0 +1,94 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashElements;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ my $data = $self->data;
+
+ my $master = $self->getMaster($got, $exp);
+
+ foreach my $key (keys %$master)
+ {
+ $data->{index} = $key;
+
+ my $got_elem = exists $got->{$key} ? $got->{$key} : $Test::Deep::DNE;
+ my $exp_elem = exists $exp->{$key} ? $exp->{$key} : $Test::Deep::DNE;
+
+ next if Test::Deep::descend($got_elem, $exp_elem);
+
+ return 0;
+ }
+
+ return 1;
+}
+
+sub getMaster
+{
+ my $self = shift;
+
+ my ($got, $exp) = @_;
+
+ return keys %$got > keys %$exp ? $got : $exp;
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my ($var, $data) = @_;
+ $var .= "->" unless $Test::Deep::Stack->incArrow;
+ $var .= '{"'.quotemeta($data->{index}).'"}';
+
+ return $var;
+}
+
+sub reset_arrow
+{
+ return 0;
+}
+
+package Test::Deep::SuperHashElements;
+
+use base 'Test::Deep::HashElements';
+
+sub getMaster
+{
+ my $self = shift;
+
+ my ($got, $exp) = @_;
+
+ return $exp;
+}
+
+package Test::Deep::SubHashElements;
+
+use base 'Test::Deep::HashElements';
+
+sub getMaster
+{
+ my $self = shift;
+
+ my ($got, $exp) = @_;
+
+ return $got;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeys.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeys.pm
new file mode 100755
index 00000000000..d0f6fc4afc6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeys.pm
@@ -0,0 +1,68 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashKeys;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my %keys;
+ @keys{@_} = ();
+ $self->{val} = \%keys;
+ $self->{keys} = [sort @_];
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ return 0 unless $self->test_reftype($got, "HASH");
+
+ return Test::Deep::descend($got, $self->hashkeysonly($exp));
+}
+
+sub hashkeysonly
+{
+ require Test::Deep::HashKeysOnly;
+
+ my $self = shift;
+ my $exp = shift;
+
+ return Test::Deep::HashKeysOnly->new(keys %$exp)
+}
+
+package Test::Deep::SuperHashKeys;
+
+use base 'Test::Deep::HashKeys';
+
+sub hashkeysonly
+{
+ require Test::Deep::HashKeysOnly;
+
+ my $self = shift;
+ my $exp = shift;
+
+ return Test::Deep::SuperHashKeysOnly->new(keys %$exp)
+}
+
+package Test::Deep::SubHashKeys;
+
+use base 'Test::Deep::HashKeys';
+
+sub hashkeysonly
+{
+ require Test::Deep::HashKeysOnly;
+
+ my $self = shift;
+ my $exp = shift;
+
+ return Test::Deep::SubHashKeysOnly->new(keys %$exp)
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm
new file mode 100755
index 00000000000..26b7de36fdb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm
@@ -0,0 +1,126 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashKeysOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my %keys;
+ @keys{@_} = ();
+ $self->{val} = \%keys;
+ $self->{keys} = [sort @_];
+}
+
+sub descend
+{
+ my $self = shift;
+ my $hash = shift;
+
+ my $data = $self->data;
+ my $exp = $self->{val};
+ my %got;
+ @got{keys %$hash} = ();
+
+ my @missing;
+ my @extra;
+
+ while (my ($key, $value) = each %$exp)
+ {
+ if (exists $got{$key})
+ {
+ delete $got{$key};
+ }
+ else
+ {
+ push(@missing, $key);
+ }
+ }
+
+ my @diags;
+ if (@missing and (not $self->ignoreMissing))
+ {
+ push(@diags, "Missing: ".nice_list(\@missing));
+ }
+
+ if (%got and (not $self->ignoreExtra))
+ {
+ push(@diags, "Extra: ".nice_list([keys %got]));
+ }
+
+ if (@diags)
+ {
+ $data->{diag} = join("\n", @diags);
+ return 0;
+ }
+
+ return 1;
+}
+
+sub diagnostics
+{
+ my $self = shift;
+ my ($where, $last) = @_;
+
+ my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
+
+ my $error = $last->{diag};
+ my $diag = <<EOM;
+Comparing hash keys of $where
+$error
+EOM
+
+ return $diag;
+}
+
+sub nice_list
+{
+ my $list = shift;
+
+ return join(", ",
+ (map {"'$_'"} sort @$list),
+ );
+}
+
+sub ignoreMissing
+{
+ return 0;
+}
+
+sub ignoreExtra
+{
+ return 0;
+}
+
+package Test::Deep::SuperHashKeysOnly;
+
+use base 'Test::Deep::HashKeysOnly';
+
+sub ignoreMissing
+{
+ return 0;
+}
+
+sub ignoreExtra
+{
+ return 1;
+}
+
+package Test::Deep::SubHashKeysOnly;
+
+use base 'Test::Deep::HashKeysOnly';
+
+sub ignoreMissing
+{
+ return 1;
+}
+
+sub ignoreExtra
+{
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ignore.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ignore.pm
new file mode 100755
index 00000000000..2aadcf59772
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ignore.pm
@@ -0,0 +1,20 @@
+use strict;
+use warnings;
+
+package Test::Deep::Ignore;
+
+use Test::Deep::Cmp;
+
+my $Singleton = __PACKAGE__->SUPER::new;
+
+sub new
+{
+ return $Singleton;
+}
+
+sub descend
+{
+ return 1;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Isa.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Isa.pm
new file mode 100755
index 00000000000..5face21b51a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Isa.pm
@@ -0,0 +1,33 @@
+use strict;
+use warnings;
+
+package Test::Deep::Isa;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ return UNIVERSAL::isa($got, $self->{val});
+}
+
+sub diag_message
+{
+ my $self = shift;
+
+ my $where = shift;
+
+ return "Checking class of $where with isa()";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ListMethods.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ListMethods.pm
new file mode 100755
index 00000000000..cfd127bde1c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ListMethods.pm
@@ -0,0 +1,24 @@
+use strict;
+use warnings;
+
+package Test::Deep::ListMethods;
+
+use base 'Test::Deep::Methods';
+
+sub call_method
+{
+ my $self = shift;
+
+ return [$self->SUPER::call_method(@_)];
+}
+
+sub render_stack
+{
+ my $self = shift;
+
+ my $var = $self->SUPER::render_stack(@_);
+
+ return "[$var]";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/MM.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/MM.pm
new file mode 100755
index 00000000000..982b8510857
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/MM.pm
@@ -0,0 +1,64 @@
+use strict;
+use warnings;
+
+package Test::Deep::MM;
+
+sub import
+{
+ my $self = shift;
+
+ my ($pkg) = caller();
+ my $mpkg = $pkg."::Methods";
+ foreach my $attr (@_)
+ {
+ if ($attr =~ /^[a-z]/)
+ {
+ no strict 'refs';
+ *{$mpkg."::$attr"} = \&{$attr};
+ }
+ else
+ {
+ my $get_name = $mpkg."::get$attr";
+ my $set_name = $mpkg."::set$attr";
+ my $get_sub = sub {
+ return $_[0]->{$attr};
+ };
+ my $set_sub = sub {
+ return $_[0]->{$attr} = $_[1];
+ };
+
+ {
+ no strict 'refs';
+ *$get_name = $get_sub;
+ *$set_name = $set_sub;
+ push(@{$pkg."::ISA"}, $mpkg);
+ }
+ }
+ }
+}
+
+sub new
+{
+ my $pkg = shift;
+
+ my $self = bless {}, $pkg;
+
+ $self->init(@_);
+
+ return $self;
+}
+
+sub init
+{
+ my $self = shift;
+
+ while (@_)
+ {
+ my $name = shift || confess("No name");
+
+ my $method = "set$name";
+ $self->$method(shift);
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Methods.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Methods.pm
new file mode 100755
index 00000000000..9d71982af29
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Methods.pm
@@ -0,0 +1,78 @@
+use strict;
+use warnings;
+
+package Test::Deep::Methods;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ # get them all into [$name,@args] => $value format
+ my @methods;
+ while (@_)
+ {
+ my $name = shift;
+ my $value = shift;
+ push(@methods,
+ [
+ ref($name) ? $name : [ $name ],
+ $value
+ ]
+ );
+ }
+ $self->{methods} = \@methods;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $data = $self->data;
+
+ foreach my $method (@{$self->{methods}})
+ {
+ $data->{method} = $method;
+
+ my ($call, $exp_res) = @$method;
+ my ($name) = @$call;
+
+ my $got_res = UNIVERSAL::can($got, $name) ?
+ $self->call_method($got, $call) :
+ $Test::Deep::DNE;
+
+ next if Test::Deep::descend($got_res, $exp_res);
+
+ return 0;
+ }
+
+ return 1;
+}
+
+sub call_method
+{
+ my $self = shift;
+ my ($got, $call) = @_;
+ my ($name, @args) = @$call;
+
+ return $got->$name(@args);
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my ($var, $data) = @_;
+
+ my $method = $data->{method};
+ my ($call, $expect) = @$method;
+ my ($name, @args) = @$call;
+
+ my $args = @args ? "(".join(", ", @args).")" : "";
+ $var .= "->$name$args";
+
+ return $var;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/NoTest.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/NoTest.pm
new file mode 100755
index 00000000000..754c2379443
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/NoTest.pm
@@ -0,0 +1,41 @@
+use strict;
+use warnings;
+
+# this is for people who don't want Test::Builder to be loaded but want to
+# use eq_deeply. It's a bit hacky...
+
+package Test::Deep::NoTest;
+
+use vars qw( $NoTest );
+
+{
+ local $NoTest = 1;
+ require Test::Deep;
+}
+
+sub import {
+ my $import = Test::Deep->can("import");
+ # make the stack look like it should for use Test::Deep
+ my $pkg = shift;
+ unshift(@_, "Test::Deep");
+ goto &$import;
+}
+
+1;
+
+=head1 NAME
+
+Test::Deep::NoTest - Use Test::Deep outside of the testing framework
+
+=head1 SYNOPSIS
+
+ use Test::Deep::NoTest;
+
+ if eq_deeply($a, $b) {
+ print "they were deeply equal\n";
+ };
+
+=head1 DESCRIPTION
+
+This exports all the same things as Test::Deep but it does not load
+Test::Builder so it can be used in ordinary non-test situations.
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Number.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Number.pm
new file mode 100755
index 00000000000..d8366ff09c6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Number.pm
@@ -0,0 +1,80 @@
+use strict;
+use warnings;
+
+package Test::Deep::Number;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util;
+
+sub init
+{
+ my $self = shift;
+
+ $self->{val} = shift(@_) + 0;
+ $self->{tolerance} = shift;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+ $self->data->{got_string} = $got;
+ {
+ no warnings 'numeric';
+ $got += 0;
+ }
+
+ $self->data->{got} = $got;
+ if (defined(my $tolerance = $self->{tolerance}))
+ {
+ return abs($got - $self->{val}) <= $tolerance;
+ }
+ else
+ {
+ return $got == $self->{val};
+ }
+}
+
+sub diag_message
+{
+ my $self = shift;
+
+ my $where = shift;
+
+ return "Comparing $where as a number";
+}
+
+sub renderGot
+{
+ my $self = shift;
+ my $val = shift;
+
+ my $got_string = $self->data->{got_string};
+ if ("$val" ne "$got_string")
+ {
+ $got_string = $self->SUPER::renderGot($got_string);
+ return "$val ($got_string)"
+ }
+ else
+ {
+ return $val;
+ }
+}
+sub renderExp
+{
+ my $self = shift;
+
+ my $exp = $self->{val};
+
+ if (defined(my $tolerance = $self->{tolerance}))
+ {
+ return "$exp +/- $tolerance";
+ }
+ else
+ {
+ return $exp;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ref.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ref.pm
new file mode 100755
index 00000000000..9cc3a6567b7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ref.pm
@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+package Test::Deep::Ref;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( blessed );
+
+sub test_class
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ if ($Test::Deep::Snobby)
+ {
+ return Test::Deep::descend($got, Test::Deep::blessed(blessed($exp)));
+ }
+ else
+ {
+ return 1;
+ }
+}
+
+sub test_reftype
+{
+ my $self = shift;
+ my $got = shift;
+ my $reftype = shift;
+
+ return Test::Deep::descend($got, Test::Deep::reftype($reftype));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RefType.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RefType.pm
new file mode 100755
index 00000000000..5fc48ace245
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RefType.pm
@@ -0,0 +1,46 @@
+use strict;
+use warnings;
+
+package Test::Deep::RefType;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( reftype );
+
+sub init
+{
+ my $self = shift;
+
+ $self->{val} = shift;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ my $exp = $self->{val};
+ my $reftype = reftype($got);
+
+ return Test::Deep::descend($reftype, Test::Deep::shallow($exp));
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my $var = shift;
+
+ return "reftype($var)";
+}
+
+sub renderGot
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ $self->SUPER::renderGot(reftype($got));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Regexp.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Regexp.pm
new file mode 100755
index 00000000000..3f4b9e2bfd1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Regexp.pm
@@ -0,0 +1,85 @@
+use strict;
+use warnings;
+
+package Test::Deep::Regexp;
+
+use Test::Deep::Cmp;
+use Test::Deep::RegexpMatches;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $val = ref $val ? $val : qr/$val/;
+
+ $self->{val} = $val;
+
+ if (my $matches = shift)
+ {
+ $self->{matches} = Test::Deep::regexpmatches($matches, $val);
+
+ $self->{flags} = shift || "";
+ }
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $re = $self->{val};
+ if (my $match_exp = $self->{matches})
+ {
+ my $flags = $self->{flags};
+ my @match_got;
+ if ($flags eq "g")
+ {
+ @match_got = $got =~ /$re/g;
+ }
+ else
+ {
+ @match_got = $got =~ /$re/;
+ }
+
+ if (@match_got)
+ {
+ return Test::Deep::descend(\@match_got, $match_exp);
+ }
+ else
+ {
+ return 0;
+ }
+ }
+ else
+ {
+ return ($got =~ $re) ? 1 : 0;
+ }
+}
+
+sub diag_message
+{
+ my $self = shift;
+
+ my $where = shift;
+
+ return "Using Regexp on $where";
+}
+
+sub render_stack1
+{
+ my $self = shift;
+
+ my $stack = shift;
+ return "($stack =~ $self->{regex})";
+}
+
+sub renderExp
+{
+ my $self = shift;
+
+ return "$self->{val}";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpMatches.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpMatches.pm
new file mode 100755
index 00000000000..ffee7698865
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpMatches.pm
@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpMatches;
+
+use Test::Deep::Array;
+
+use base 'Test::Deep::Array';
+
+use Scalar::Util qw( blessed );
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $val = Test::Deep::array($val) unless
+ blessed($val) and UNIVERSAL::isa($val, "Test::Deep::Cmp");
+
+ $self->{val} = $val;
+ $self->{regex} = shift;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ return Test::Deep::descend($got, $self->{val});
+}
+
+sub render_stack
+{
+ my $self = shift;
+
+ my $stack = shift;
+
+ $stack = "[$stack =~ $self->{regex}]";
+
+ return $stack;
+# return $self->SUPER::render_stack($stack);
+}
+
+sub reset_arrow
+{
+ return 1;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpOnly.pm
new file mode 100755
index 00000000000..08fc6b5971f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpOnly.pm
@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+
+package Test::Deep::Regexp;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( blessed );
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $val = ref $val ? $val : qr/$val/;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift;
+
+ my $re = $self->{val};
+
+ return ($got =~ $self->{val} ? 1 : 0;
+}
+
+sub diag_message
+{
+ my $self = shift;
+
+ my $where = shift;
+
+ return "Using Regexp on $where";
+}
+
+sub renderExp
+{
+ my $self = shift;
+
+ return "$self->{val}";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRef.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRef.pm
new file mode 100755
index 00000000000..270e98909ee
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRef.pm
@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpRef;
+
+use Test::Deep::Ref;
+use Test::Deep::RegexpVersion;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ if ($Test::Deep::RegexpVersion::OldStyle) {
+ return 0 unless $self->test_class($got, "Regexp");
+ return 0 unless $self->test_reftype($got, "SCALAR");
+ } else {
+ return 0 unless $self->test_reftype($got, "REGEXP");
+ }
+
+ return Test::Deep::descend($got, Test::Deep::regexprefonly($exp));
+}
+
+sub renderGot
+{
+ my $self = shift;
+
+ return shift()."";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRefOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRefOnly.pm
new file mode 100755
index 00000000000..c192a70953b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRefOnly.pm
@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpRefOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ return $got eq $exp;
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my ($var, $data) = @_;
+
+ return "m/$var/";
+}
+
+sub renderGot
+{
+ my $self = shift;
+
+ return shift()."";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpVersion.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpVersion.pm
new file mode 100755
index 00000000000..6cbfa857ffc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpVersion.pm
@@ -0,0 +1,13 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpVersion;
+
+use vars qw( $OldStyle );
+
+# Older versions of Perl treated Regexp refs as opaque scalars blessed
+# into the "Regexp" class. Several bits of code need this so we
+# centralise the test for that kind of version.
+$OldStyle = ($] < 5.011);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRef.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRef.pm
new file mode 100755
index 00000000000..b8361668ff3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRef.pm
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::ScalarRef;
+
+use Test::Deep::Ref;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+ my $exp = $self->{val};
+
+ return 0 unless $self->test_class($got);
+ return 0 unless $self->test_reftype($got, Scalar::Util::reftype($exp));
+ return Test::Deep::descend($got, Test::Deep::scalarrefonly($exp));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRefOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRefOnly.pm
new file mode 100755
index 00000000000..c818ae3d0b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRefOnly.pm
@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+package Test::Deep::ScalarRefOnly;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+
+ my $exp = $self->{val};
+
+ return Test::Deep::descend($$got, $$exp);
+}
+
+sub render_stack
+{
+ my $self = shift;
+ my ($var, $data) = @_;
+
+ return "\${$var}";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Set.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Set.pm
new file mode 100755
index 00000000000..b90f1d2da75
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Set.pm
@@ -0,0 +1,185 @@
+use strict;
+use warnings;
+
+package Test::Deep::Set;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ $self->{IgnoreDupes} = shift;
+ $self->{SubSup} = shift;
+
+ $self->{val} = [];
+
+ $self->add(@_);
+}
+
+sub descend
+{
+ my $self = shift;
+ my $d1 = shift;
+
+ my $d2 = $self->{val};
+
+ my $IgnoreDupes = $self->{IgnoreDupes};
+
+ my $data = $self->data;
+
+ my $SubSup = $self->{SubSup};
+
+ my $type = $IgnoreDupes ? "Set" : "Bag";
+
+ my $diag;
+
+ if (ref $d1 ne 'ARRAY')
+ {
+ my $got = Test::Deep::render_val($d1);
+ $diag = <<EOM;
+got : $got
+expect : An array to use as a $type
+EOM
+ }
+
+ if (not $diag)
+ {
+ my @got = @$d1;
+ my @missing;
+ foreach my $expect (@$d2)
+ {
+ my $found = 0;
+
+ for (my $i = $#got; $i >= 0; $i--)
+ {
+ if (Test::Deep::eq_deeply_cache($got[$i], $expect))
+ {
+ $found = 1;
+ splice(@got, $i, 1);
+
+ last unless $IgnoreDupes;
+ }
+ }
+
+ push(@missing, $expect) unless $found;
+ }
+
+
+ my @diags;
+ if (@missing and $SubSup ne "sub")
+ {
+ push(@diags, "Missing: ".nice_list(\@missing));
+ }
+
+ if (@got and $SubSup ne "sup")
+ {
+ my $got = __PACKAGE__->new($IgnoreDupes, "", @got);
+ push(@diags, "Extra: ".nice_list($got->{val}));
+ }
+
+ $diag = join("\n", @diags);
+ }
+
+ if ($diag)
+ {
+ $data->{diag} = $diag;
+
+ return 0;
+ }
+ else
+ {
+ return 1;
+ }
+}
+
+sub diagnostics
+{
+ my $self = shift;
+ my ($where, $last) = @_;
+
+ my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
+ $type = "Sub$type" if $self->{SubSup} eq "sub";
+ $type = "Super$type" if $self->{SubSup} eq "sup";
+
+ my $error = $last->{diag};
+ my $diag = <<EOM;
+Comparing $where as a $type
+$error
+EOM
+
+ return $diag;
+}
+
+sub add
+{
+ # this takes an array.
+
+ # For each element A of the array, it looks for an element, B, already in
+ # the set which are deeply equal to A. If no matching B is found then A is
+ # added to the set. If a B is found and IgnoreDupes is true, then A will
+ # be discarded, if IgnoreDupes is false, then B will be added to the set
+ # again.
+
+ my $self = shift;
+
+ my @array = @_;
+
+ my $IgnoreDupes = $self->{IgnoreDupes};
+
+ my $already = $self->{val};
+
+ local $Test::Deep::Expects = 1;
+ foreach my $new_elem (@array)
+ {
+ my $want_push = 1;
+ my $push_this = $new_elem;
+ foreach my $old_elem (@$already)
+ {
+ if (Test::Deep::eq_deeply($new_elem, $old_elem))
+ {
+ $push_this = $old_elem;
+ $want_push = ! $IgnoreDupes;
+ last;
+ }
+ }
+ push(@$already, $push_this) if $want_push;
+ }
+
+ # so we can compare 2 Test::Deep::Set objects using array comparison
+
+ @$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already;
+}
+
+sub nice_list
+{
+ my $list = shift;
+
+ my @scalars = grep ! ref $_, @$list;
+ my $refs = grep ref $_, @$list;
+
+ my @ref_string = "$refs reference" if $refs;
+ $ref_string[0] .= "s" if $refs > 1;
+
+ # sort them so we can predict the diagnostic output
+
+ return join(", ",
+ (map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars),
+ @ref_string
+ );
+}
+
+sub compare
+{
+ my $self = shift;
+
+ my $other = shift;
+
+ return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes};
+
+ # this works (kind of) because the the arrays are sorted
+
+ return Test::Deep::descend($self->{val}, $other->{val});
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Shallow.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Shallow.pm
new file mode 100755
index 00000000000..11f252cd5f8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Shallow.pm
@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+
+package Test::Deep::Shallow;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( refaddr );
+
+sub init
+{
+ my $self = shift;
+
+ my $val = shift;
+ $self->{val} = $val;
+}
+
+sub descend
+{
+ my $self = shift;
+
+ my $got = shift;
+ my $exp = $self->{val};
+
+ my $ok;
+
+ if (!defined $got and !defined $exp)
+ {
+ $ok = 1;
+ }
+ elsif (defined $got xor defined $exp)
+ {
+ $ok = 0;
+ }
+ elsif (ref $got and ref $exp)
+ {
+ $ok = refaddr($got) == refaddr($exp);
+ }
+ elsif (ref $got xor ref $exp)
+ {
+ $ok = 0;
+ }
+ else
+ {
+ $ok = $got eq $exp;
+ }
+
+ return $ok;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Stack.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Stack.pm
new file mode 100755
index 00000000000..4faec7a87b4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Stack.pm
@@ -0,0 +1,84 @@
+use strict;
+use warnings;
+
+package Test::Deep::Stack;
+
+use Carp qw( confess );
+
+use Test::Deep::MM qw( new init Stack Arrow );
+
+sub init
+{
+ my $self = shift;
+
+ $self->SUPER::init(@_);
+
+ $self->setStack([]) unless $self->getStack;
+}
+
+sub push
+{
+ my $self = shift;
+
+ push(@{$self->getStack}, @_);
+}
+
+sub pop
+{
+ my $self = shift;
+
+ return pop @{$self->getStack};
+}
+
+sub render
+{
+ my $self = shift;
+ my $var = shift;
+
+ my $stack = $self->getStack;
+
+ $self->setArrow(0);
+
+ foreach my $data (@$stack)
+ {
+ my $exp = $data->{exp};
+ if (UNIVERSAL::isa($exp, "Test::Deep::Cmp"))
+ {
+ $var = $exp->render_stack($var, $data);
+
+ $self->setArrow(0) if $exp->reset_arrow;
+ }
+ else
+ {
+ confess "Don't know how to render '$exp'";
+ }
+ }
+
+ return $var;
+}
+
+sub getLast
+{
+ my $self = shift;
+
+ return $self->getStack->[-1];
+}
+
+sub incArrow
+{
+ my $self = shift;
+
+ my $a = $self->getArrow;
+ $self->setArrow($a + 1);
+
+ return $a;
+}
+
+sub length
+{
+ my $self = shift;
+
+ return @{$self->getStack} + 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/String.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/String.pm
new file mode 100755
index 00000000000..217787e5601
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/String.pm
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+package Test::Deep::String;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ $self->{val} = shift;
+}
+
+sub descend
+{
+ my $self = shift;
+ my $got = shift()."";
+
+ $self->data->{got} = $got;
+
+ return $got eq $self->{val};
+}
+
+sub diag_message
+{
+ my $self = shift;
+
+ my $where = shift;
+
+ return "Comparing $where as a string";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Exception.pm b/Master/tlpkg/tlperl.straw/lib/Test/Exception.pm
new file mode 100755
index 00000000000..4dfafdaa159
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Exception.pm
@@ -0,0 +1,464 @@
+use strict;
+use warnings;
+
+package Test::Exception;
+use Test::Builder;
+use Sub::Uplevel qw( uplevel );
+use base qw( Exporter );
+
+our $VERSION = '0.29';
+our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
+
+my $Tester = Test::Builder->new;
+
+sub import {
+ my $self = shift;
+ if ( @_ ) {
+ my $package = caller;
+ $Tester->exported_to( $package );
+ $Tester->plan( @_ );
+ };
+ $self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
+}
+
+=head1 NAME
+
+Test::Exception - Test exception based code
+
+=head1 SYNOPSIS
+
+ use Test::More tests => 5;
+ use Test::Exception;
+
+ # or if you don't need Test::More
+
+ use Test::Exception tests => 5;
+
+ # then...
+
+ # Check that the stringified exception matches given regex
+ throws_ok { $foo->method } qr/division by zero/, 'zero caught okay';
+
+ # Check an exception of the given class (or subclass) is thrown
+ throws_ok { $foo->method } 'Error::Simple', 'simple error thrown';
+
+ # all Test::Exceptions subroutines are guaranteed to preserve the state
+ # of $@ so you can do things like this after throws_ok and dies_ok
+ like $@, 'what the stringified exception should look like';
+
+ # Check that something died - we do not care why
+ dies_ok { $foo->method } 'expecting to die';
+
+ # Check that something did not die
+ lives_ok { $foo->method } 'expecting to live';
+
+ # Check that a test runs without an exception
+ lives_and { is $foo->method, 42 } 'method is 42';
+
+ # or if you don't like prototyped functions
+
+ throws_ok( sub { $foo->method }, qr/division by zero/,
+ 'zero caught okay' );
+ throws_ok( sub { $foo->method }, 'Error::Simple',
+ 'simple error thrown' );
+ dies_ok( sub { $foo->method }, 'expecting to die' );
+ lives_ok( sub { $foo->method }, 'expecting to live' );
+ lives_and( sub { is $foo->method, 42 }, 'method is 42' );
+
+
+=head1 DESCRIPTION
+
+This module provides a few convenience methods for testing exception based code. It is built with
+L<Test::Builder> and plays happily with L<Test::More> and friends.
+
+If you are not already familiar with L<Test::More> now would be the time to go take a look.
+
+You can specify the test plan when you C<use Test::Exception> in the same way as C<use Test::More>.
+See L<Test::More> for details.
+
+NOTE: Test::Exception only checks for exceptions. It will ignore other methods of stopping
+program execution - including exit(). If you have an exit() in evalled code Test::Exception
+will not catch this with any of its testing functions.
+
+=cut
+
+sub _quiet_caller (;$) { ## no critic Prototypes
+ my $height = $_[0];
+ $height++;
+ if( wantarray and !@_ ) {
+ return (CORE::caller($height))[0..2];
+ }
+ else {
+ return CORE::caller($height);
+ }
+}
+
+sub _try_as_caller {
+ my $coderef = shift;
+
+ # local works here because Sub::Uplevel has already overridden caller
+ local *CORE::GLOBAL::caller;
+ { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
+
+ eval { uplevel 3, $coderef };
+ return $@;
+};
+
+
+sub _is_exception {
+ my $exception = shift;
+ return ref $exception || $exception ne '';
+};
+
+
+sub _exception_as_string {
+ my ( $prefix, $exception ) = @_;
+ return "$prefix normal exit" unless _is_exception( $exception );
+ my $class = ref $exception;
+ $exception = "$class ($exception)"
+ if $class && "$exception" !~ m/^\Q$class/;
+ chomp $exception;
+ return "$prefix $exception";
+};
+
+
+=over 4
+
+=item B<throws_ok>
+
+Tests to see that a specific exception is thrown. throws_ok() has two forms:
+
+ throws_ok BLOCK REGEX, TEST_DESCRIPTION
+ throws_ok BLOCK CLASS, TEST_DESCRIPTION
+
+In the first form the test passes if the stringified exception matches the give regular expression. For example:
+
+ throws_ok { read_file( 'unreadable' ) } qr/No file/, 'no file';
+
+If your perl does not support C<qr//> you can also pass a regex-like string, for example:
+
+ throws_ok { read_file( 'unreadable' ) } '/No file/', 'no file';
+
+The second form of throws_ok() test passes if the exception is of the same class as the one supplied, or a subclass of that class. For example:
+
+ throws_ok { $foo->bar } "Error::Simple", 'simple error';
+
+Will only pass if the C<bar> method throws an Error::Simple exception, or a subclass of an Error::Simple exception.
+
+You can get the same effect by passing an instance of the exception you want to look for. The following is equivalent to the previous example:
+
+ my $SIMPLE = Error::Simple->new;
+ throws_ok { $foo->bar } $SIMPLE, 'simple error';
+
+Should a throws_ok() test fail it produces appropriate diagnostic messages. For example:
+
+ not ok 3 - simple error
+ # Failed test (test.t at line 48)
+ # expecting: Error::Simple exception
+ # found: normal exit
+
+Like all other Test::Exception functions you can avoid prototypes by passing a subroutine explicitly:
+
+ throws_ok( sub {$foo->bar}, "Error::Simple", 'simple error' );
+
+A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
+
+A description of the exception being checked is used if no optional test description is passed.
+
+=cut
+
+
+sub throws_ok (&$;$) {
+ my ( $coderef, $expecting, $description ) = @_;
+ unless (defined $expecting) {
+ require Carp;
+ Carp::croak( "throws_ok: must pass exception class/object or regex" );
+ }
+ $description = _exception_as_string( "threw", $expecting )
+ unless defined $description;
+ my $exception = _try_as_caller( $coderef );
+ my $regex = $Tester->maybe_regex( $expecting );
+ my $ok = $regex
+ ? ( $exception =~ m/$regex/ )
+ : eval {
+ $exception->isa( ref $expecting ? ref $expecting : $expecting )
+ };
+ $Tester->ok( $ok, $description );
+ unless ( $ok ) {
+ $Tester->diag( _exception_as_string( "expecting:", $expecting ) );
+ $Tester->diag( _exception_as_string( "found:", $exception ) );
+ };
+ $@ = $exception;
+ return $ok;
+};
+
+
+=item B<dies_ok>
+
+Checks that a piece of code dies, rather than returning normally. For example:
+
+ sub div {
+ my ( $a, $b ) = @_;
+ return $a / $b;
+ };
+
+ dies_ok { div( 1, 0 ) } 'divide by zero detected';
+
+ # or if you don't like prototypes
+ dies_ok( sub { div( 1, 0 ) }, 'divide by zero detected' );
+
+A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
+
+Remember: This test will pass if the code dies for any reason. If you care about the reason it might be more sensible to write a more specific test using throws_ok().
+
+The test description is optional, but recommended.
+
+=cut
+
+sub dies_ok (&;$) {
+ my ( $coderef, $description ) = @_;
+ my $exception = _try_as_caller( $coderef );
+ my $ok = $Tester->ok( _is_exception($exception), $description );
+ $@ = $exception;
+ return $ok;
+}
+
+
+=item B<lives_ok>
+
+Checks that a piece of code doesn't die. This allows your test script to continue, rather than aborting if you get an unexpected exception. For example:
+
+ sub read_file {
+ my $file = shift;
+ local $/;
+ open my $fh, '<', $file or die "open failed ($!)\n";
+ $file = <FILE>;
+ return $file;
+ };
+
+ my $file;
+ lives_ok { $file = read_file('test.txt') } 'file read';
+
+ # or if you don't like prototypes
+ lives_ok( sub { $file = read_file('test.txt') }, 'file read' );
+
+Should a lives_ok() test fail it produces appropriate diagnostic messages. For example:
+
+ not ok 1 - file read
+ # Failed test (test.t at line 15)
+ # died: open failed (No such file or directory)
+
+A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
+
+The test description is optional, but recommended.
+
+=cut
+
+sub lives_ok (&;$) {
+ my ( $coderef, $description ) = @_;
+ my $exception = _try_as_caller( $coderef );
+ my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
+ $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
+ $@ = $exception;
+ return $ok;
+}
+
+
+=item B<lives_and>
+
+Run a test that may throw an exception. For example, instead of doing:
+
+ my $file;
+ lives_ok { $file = read_file('answer.txt') } 'read_file worked';
+ is $file, "42", 'answer was 42';
+
+You can use lives_and() like this:
+
+ lives_and { is read_file('answer.txt'), "42" } 'answer is 42';
+ # or if you don't like prototypes
+ lives_and(sub {is read_file('answer.txt'), "42"}, 'answer is 42');
+
+Which is the same as doing
+
+ is read_file('answer.txt'), "42\n", 'answer is 42';
+
+unless C<read_file('answer.txt')> dies, in which case you get the same kind of error as lives_ok()
+
+ not ok 1 - answer is 42
+ # Failed test (test.t at line 15)
+ # died: open failed (No such file or directory)
+
+A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
+
+The test description is optional, but recommended.
+
+=cut
+
+sub lives_and (&;$) {
+ my ( $test, $description ) = @_;
+ {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $ok = \&Test::Builder::ok;
+ no warnings;
+ local *Test::Builder::ok = sub {
+ $_[2] = $description unless defined $_[2];
+ $ok->(@_);
+ };
+ use warnings;
+ eval { $test->() } and return 1;
+ };
+ my $exception = $@;
+ if ( _is_exception( $exception ) ) {
+ $Tester->ok( 0, $description );
+ $Tester->diag( _exception_as_string( "died:", $exception ) );
+ };
+ $@ = $exception;
+ return;
+}
+
+=back
+
+
+=head1 SKIPPING TEST::EXCEPTION TESTS
+
+Sometimes we want to use Test::Exception tests in a test suite, but don't want to force the user to have Test::Exception installed. One way to do this is to skip the tests if Test::Exception is absent. You can do this with code something like this:
+
+ use strict;
+ use warnings;
+ use Test::More;
+
+ BEGIN {
+ eval "use Test::Exception";
+ plan skip_all => "Test::Exception needed" if $@;
+ }
+
+ plan tests => 2;
+ # ... tests that need Test::Exception ...
+
+Note that we load Test::Exception in a C<BEGIN> block ensuring that the subroutine prototypes are in place before the rest of the test script is compiled.
+
+
+=head1 BUGS
+
+There are some edge cases in Perl's exception handling where Test::Exception will miss exceptions
+thrown in DESTROY blocks. See the RT bug L<http://rt.cpan.org/Ticket/Display.html?id=24678> for
+details, along with the t/edge-cases.t in the distribution test suite. These will be addressed in
+a future Test::Exception release.
+
+If you find any more bugs please let me know by e-mail, or report the problem with
+L<http://rt.cpan.org/>.
+
+
+=head1 COMMUNITY
+
+=over 4
+
+=item perl-qa
+
+If you are interested in testing using Perl I recommend you visit L<http://qa.perl.org/> and join the excellent perl-qa mailing list. See L<http://lists.perl.org/showlist.cgi?name=perl-qa> for details on how to subscribe.
+
+=item perlmonks
+
+You can find users of Test::Exception, including the module author, on L<http://www.perlmonks.org/>. Feel free to ask questions on Test::Exception there.
+
+=item CPAN::Forum
+
+The CPAN Forum is a web forum for discussing Perl's CPAN modules. The Test::Exception forum can be found at L<http://www.cpanforum.com/dist/Test-Exception>.
+
+=item AnnoCPAN
+
+AnnoCPAN is a web site that allows community annotations of Perl module documentation. The Test::Exception annotations can be found at L<http://annocpan.org/~ADIE/Test-Exception/>.
+
+=back
+
+
+=head1 TO DO
+
+If you think this module should do something that it doesn't (or does something that it shouldn't) please let me know.
+
+You can see my current to do list at L<http://adrianh.tadalist.com/lists/public/15421>, with an RSS feed of changes at L<http://adrianh.tadalist.com/lists/feed_public/15421>.
+
+
+=head1 ACKNOWLEDGMENTS
+
+Thanks to chromatic and Michael G Schwern for the excellent Test::Builder, without which this module wouldn't be possible.
+
+Thanks to
+Adam Kennedy,
+Andy Lester,
+Aristotle Pagaltzis,
+Ben Prew,
+Cees Hek,
+Chris Dolan,
+chromatic,
+Curt Sampson,
+David Cantrell,
+David Golden,
+David Wheeler,
+Janek Schleicher,
+Jim Keenan,
+Jos I. Boumans,
+Joshua ben Jore,
+Jost Krieger,
+Mark Fowler,
+Michael G Schwern,
+Nadim Khemir,
+Paul McCann,
+Perrin Harkins,
+Peter Scott,
+Ricardo Signes,
+Rob Muhlestein
+Scott R. Godin,
+Steve Purkis,
+Steve,
+Tim Bunce,
+and various anonymous folk for comments, suggestions, bug reports and patches.
+
+
+=head1 AUTHOR
+
+Adrian Howard <adrianh@quietstars.com>
+
+If you can spare the time, please drop me a line if you find this module useful.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<http://del.icio.us/tag/Test::Exception>
+
+Delicious links on Test::Exception.
+
+=item L<Test::Warn> & L<Test::NoWarnings>
+
+Modules to help test warnings.
+
+=item L<Test::Builder>
+
+Support module for building test libraries.
+
+=item L<Test::Simple> & L<Test::More>
+
+Basic utilities for writing tests.
+
+=item L<http://qa.perl.org/test-modules.html>
+
+Overview of some of the many testing modules available on CPAN.
+
+=item L<http://del.icio.us/tag/perl+testing>
+
+Delicious links on perl testing.
+
+=back
+
+
+=head1 LICENCE
+
+Copyright 2002-2007 Adrian Howard, All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Harness.pm b/Master/tlpkg/tlperl.straw/lib/Test/Harness.pm
new file mode 100755
index 00000000000..4e026ce2b36
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Harness.pm
@@ -0,0 +1,591 @@
+package Test::Harness;
+
+require 5.00405;
+
+use strict;
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source ();
+use TAP::Parser::SourceHandler::Perl ();
+
+use TAP::Parser::Utils qw( split_shell );
+
+use Config;
+use Exporter;
+
+# TODO: Emulate at least some of these
+use vars qw(
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Color
+ $Directives
+ $Timer
+ $Strap
+ $HarnessSubclass
+ $has_time_hires
+ $IgnoreExit
+);
+
+# $ML $Last_ML_Print
+
+BEGIN {
+ eval q{use Time::HiRes 'time'};
+ $has_time_hires = !$@;
+}
+
+=head1 NAME
+
+Test::Harness - Run Perl standard test scripts with statistics
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+# Backwards compatibility for exportable variable names.
+*verbose = *Verbose;
+*switches = *Switches;
+*debug = *Debug;
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+@ISA = ('Exporter');
+@EXPORT = qw(&runtests);
+@EXPORT_OK = qw(&execute_tests $verbose $switches);
+
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
+$Debug = $ENV{HARNESS_DEBUG} || 0;
+$Switches = '-w';
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Columns--; # Some shells have trouble with a full line of text.
+$Timer = $ENV{HARNESS_TIMER} || 0;
+$Color = $ENV{HARNESS_COLOR} || 0;
+$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
+
+=head1 SYNOPSIS
+
+ use Test::Harness;
+
+ runtests(@test_files);
+
+=head1 DESCRIPTION
+
+Although, for historical reasons, the L<Test::Harness> distribution
+takes its name from this module it now exists only to provide
+L<TAP::Harness> with an interface that is somewhat backwards compatible
+with L<Test::Harness> 2.xx. If you're writing new code consider using
+L<TAP::Harness> directly instead.
+
+Emulation is provided for C<runtests> and C<execute_tests> but the
+pluggable 'Straps' interface that previous versions of L<Test::Harness>
+supported is not reproduced here. Straps is now available as a stand
+alone module: L<Test::Harness::Straps>.
+
+See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
+distribution.
+
+=head1 FUNCTIONS
+
+The following functions are available.
+
+=head2 runtests( @test_files )
+
+This runs all the given I<@test_files> and divines whether they passed
+or failed based on their output to STDOUT (details above). It prints
+out each individual test which failed along with a summary report and
+a how long it all took.
+
+It returns true if everything was ok. Otherwise it will C<die()> with
+one of the messages in the DIAGNOSTICS section.
+
+=cut
+
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::SourceHandler::Perl->get_taint(
+ TAP::Parser::Source->shebang($test) );
+}
+
+sub _aggregate {
+ my ( $harness, $aggregate, @tests ) = @_;
+
+ # Don't propagate to our children
+ local $ENV{HARNESS_OPTIONS};
+
+ _apply_extra_INC($harness);
+ _aggregate_tests( $harness, $aggregate, @tests );
+}
+
+# Make sure the child seens all the extra junk in @INC
+sub _apply_extra_INC {
+ my $harness = shift;
+
+ $harness->callback(
+ parser_args => sub {
+ my ( $args, $test ) = @_;
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
+ );
+}
+
+sub _aggregate_tests {
+ my ( $harness, $aggregate, @tests ) = @_;
+ $aggregate->start();
+ $harness->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop();
+
+}
+
+sub runtests {
+ my @tests = @_;
+
+ # shield against -l
+ local ( $\, $, );
+
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ _aggregate( $harness, $aggregate, @tests );
+
+ $harness->formatter->summary($aggregate);
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+ my $failed = $aggregate->failed;
+
+ my @parsers = $aggregate->parsers;
+
+ my $num_bad = 0;
+ for my $parser (@parsers) {
+ $num_bad++ if $parser->has_problems;
+ }
+
+ die(sprintf(
+ "Failed %d/%d test programs. %d/%d subtests failed.\n",
+ $num_bad, scalar @parsers, $failed, $total
+ )
+ ) if $num_bad;
+
+ return $total && $total == $passed;
+}
+
+sub _canon {
+ my @list = sort { $a <=> $b } @_;
+ my @ranges = ();
+ my $count = scalar @list;
+ my $pos = 0;
+
+ while ( $pos < $count ) {
+ my $end = $pos + 1;
+ $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
+ push @ranges, ( $end == $pos + 1 )
+ ? $list[$pos]
+ : join( '-', $list[$pos], $list[ $end - 1 ] );
+ $pos = $end;
+ }
+
+ return join( ' ', @ranges );
+}
+
+sub _new_harness {
+ my $sub_args = shift || {};
+
+ my ( @lib, @switches );
+ my @opt = split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} );
+ while ( my $opt = shift @opt ) {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, length($1) ? $1 : shift @opt;
+ }
+ else {
+ push @switches, $opt;
+ }
+ }
+
+ # Do things the old way on VMS...
+ push @lib, _filtered_inc() if IS_VMS;
+
+ # If $Verbose isn't numeric default to 1. This helps core.
+ my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
+
+ my $args = {
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ color => $Color,
+ verbosity => $verbosity,
+ ignore_exit => $IgnoreExit,
+ };
+
+ $args->{stdout} = $sub_args->{out}
+ if exists $sub_args->{out};
+
+ if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
+ for my $opt ( split /:/, $env_opt ) {
+ if ( $opt =~ /^j(\d*)$/ ) {
+ $args->{jobs} = $1 || 9;
+ }
+ elsif ( $opt eq 'c' ) {
+ $args->{color} = 1;
+ }
+ else {
+ die "Unknown HARNESS_OPTIONS item: $opt\n";
+ }
+ }
+ }
+
+ my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness';
+ return TAP::Harness->_construct( $class, $args );
+}
+
+# Get the parts of @INC which are changed from the stock list AND
+# preserve reordering of stock directories.
+sub _filtered_inc {
+ my @inc = grep { !ref } @INC; #28567
+
+ if (IS_VMS) {
+
+ # VMS has a 255-byte limit on the length of %ENV entries, so
+ # toss the ones that involve perl_root, the install location
+ @inc = grep !/perl_root/i, @inc;
+
+ }
+ elsif (IS_WIN32) {
+
+ # Lose any trailing backslashes in the Win32 paths
+ s/[\\\/]+$// for @inc;
+ }
+
+ my @default_inc = _default_inc();
+
+ my @new_inc;
+ my %seen;
+ for my $dir (@inc) {
+ next if $seen{$dir}++;
+
+ if ( $dir eq ( $default_inc[0] || '' ) ) {
+ shift @default_inc;
+ }
+ else {
+ push @new_inc, $dir;
+ }
+
+ shift @default_inc while @default_inc and $seen{ $default_inc[0] };
+ }
+
+ return @new_inc;
+}
+
+{
+
+ # Cache this to avoid repeatedly shelling out to Perl.
+ my @inc;
+
+ sub _default_inc {
+ return @inc if @inc;
+
+ local $ENV{PERL5LIB};
+ local $ENV{PERLLIB};
+
+ my $perl = $ENV{HARNESS_PERL} || $^X;
+
+ # Avoid using -l for the benefit of Perl 6
+ chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` );
+ return @inc;
+ }
+}
+
+sub _check_sequence {
+ my @list = @_;
+ my $prev;
+ while ( my $next = shift @list ) {
+ return if defined $prev && $next <= $prev;
+ $prev = $next;
+ }
+
+ return 1;
+}
+
+sub execute_tests {
+ my %args = @_;
+
+ my $harness = _new_harness( \%args );
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ my %tot = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ bad => 0,
+ good => 0,
+ files => 0,
+ tests => 0,
+ sub_skipped => 0,
+ todo => 0,
+ skipped => 0,
+ bench => undef,
+ );
+
+ # Install a callback so we get to see any plans the
+ # harness executes.
+ $harness->callback(
+ made_parser => sub {
+ my $parser = shift;
+ $parser->callback(
+ plan => sub {
+ my $plan = shift;
+ if ( $plan->directive eq 'SKIP' ) {
+ $tot{skipped}++;
+ }
+ }
+ );
+ }
+ );
+
+ _aggregate( $harness, $aggregate, @{ $args{tests} } );
+
+ $tot{bench} = $aggregate->elapsed;
+ my @tests = $aggregate->descriptions;
+
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = scalar @tests;
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test (@tests) {
+ my ($parser) = $aggregate->parsers($test);
+
+ my @failed = $parser->failed;
+
+ my $wstat = $parser->wait;
+ my $estat = $parser->exit;
+ my $planned = $parser->tests_planned;
+ my @errors = $parser->parse_errors;
+ my $passed = $parser->passed;
+ my $actual_passed = $parser->actual_passed;
+
+ my $ok_seq = _check_sequence( $parser->actual_passed );
+
+ # Duplicate exit, wait status semantics of old version
+ $estat ||= '' unless $wstat;
+ $wstat ||= '';
+
+ $tot{max} += ( $planned || 0 );
+ $tot{bonus} += $parser->todo_passed;
+ $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
+ $tot{sub_skipped} += $parser->skipped;
+ $tot{todo} += $parser->todo;
+
+ if ( @failed || $estat || @errors ) {
+ $tot{bad}++;
+
+ my $huh_planned = $planned ? undef : '??';
+ my $huh_errors = $ok_seq ? undef : '??';
+
+ $failedtests{$test} = {
+ 'canon' => $huh_planned
+ || $huh_errors
+ || _canon(@failed)
+ || '??',
+ 'estat' => $estat,
+ 'failed' => $huh_planned
+ || $huh_errors
+ || scalar @failed,
+ 'max' => $huh_planned || $planned,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ else {
+ $tot{good}++;
+ }
+
+ my @todo = $parser->todo_passed;
+ if (@todo) {
+ $todo_passed{$test} = {
+ 'canon' => _canon(@todo),
+ 'estat' => $estat,
+ 'failed' => scalar @todo,
+ 'max' => scalar $parser->todo,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ }
+
+ return ( \%tot, \%failedtests, \%todo_passed );
+}
+
+=head2 execute_tests( tests => \@test_files, out => \*FH )
+
+Runs all the given C<@test_files> (just like C<runtests()>) but
+doesn't generate the final report. During testing, progress
+information will be written to the currently selected output
+filehandle (usually C<STDOUT>), or to the filehandle given by the
+C<out> parameter. The I<out> is optional.
+
+Returns a list of two values, C<$total> and C<$failed>, describing the
+results. C<$total> is a hash ref summary of all the tests run. Its
+keys and values are this:
+
+ bonus Number of individual todo tests unexpectedly passed
+ max Number of individual tests ran
+ ok Number of individual tests passed
+ sub_skipped Number of individual tests skipped
+ todo Number of individual todo tests
+
+ files Number of test files ran
+ good Number of test files passed
+ bad Number of test files failed
+ tests Number of test files originally given
+ skipped Number of test files skipped
+
+If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
+got a successful test.
+
+C<$failed> is a hash ref of all the test scripts that failed. Each key
+is the name of a test script, each value is another hash representing
+how that script failed. Its keys are these:
+
+ name Name of the test which failed
+ estat Script's exit value
+ wstat Script's wait status
+ max Number of individual tests
+ failed Number which failed
+ canon List of tests which failed (as string).
+
+C<$failed> should be empty if everything passed.
+
+=cut
+
+1;
+__END__
+
+=head1 EXPORT
+
+C<&runtests> is exported by C<Test::Harness> by default.
+
+C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
+exported upon request.
+
+=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
+
+C<Test::Harness> sets these before executing the individual tests.
+
+=over 4
+
+=item C<HARNESS_ACTIVE>
+
+This is set to a true value. It allows the tests to determine if they
+are being executed through the harness or by any other means.
+
+=item C<HARNESS_VERSION>
+
+This is the version of C<Test::Harness>.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
+
+=over 4
+
+=item C<HARNESS_TIMER>
+
+Setting this to true will make the harness display the number of
+milliseconds each test took. You can also use F<prove>'s C<--timer>
+switch.
+
+=item C<HARNESS_VERBOSE>
+
+If true, C<Test::Harness> will output the verbose results of running
+its tests. Setting C<$Test::Harness::verbose> will override this,
+or you can use the C<-v> switch in the F<prove> utility.
+
+=item C<HARNESS_OPTIONS>
+
+Provide additional options to the harness. Currently supported options are:
+
+=over
+
+=item C<< j<n> >>
+
+Run <n> (default 9) parallel jobs.
+
+=item C<< c >>
+
+Try to color output. See L<TAP::Formatter::Base/"new">.
+
+=back
+
+Multiple options may be separated by colons:
+
+ HARNESS_OPTIONS=j9:c make test
+
+=item C<HARNESS_SUBCLASS>
+
+Specifies a TAP::Harness subclass to be used in place of TAP::Harness.
+
+=back
+
+=head1 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> C<Test::Harness> passes the names of any
+directories found in C<PERL5LIB> as -I switches. The net effect of this
+is that C<PERL5LIB> is honoured even in taint mode.
+
+=head1 SEE ALSO
+
+L<TAP::Harness>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
+notified, and then you'll automatically be notified of progress on your bug
+as I make changes.
+
+=head1 AUTHORS
+
+Andy Armstrong C<< <andy@hexten.net> >>
+
+L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
+module is based) has this attribution:
+
+ Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+ sure is, that it was inspired by Larry Wall's F<TEST> script that came
+ with perl distributions for ages. Numerous anonymous contributors
+ exist. Andreas Koenig held the torch for many years, and then
+ Michael G Schwern.
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Manifest.pm b/Master/tlpkg/tlperl.straw/lib/Test/Manifest.pm
new file mode 100755
index 00000000000..0a3197182de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Manifest.pm
@@ -0,0 +1,336 @@
+package Test::Manifest;
+use strict;
+
+use warnings;
+no warnings;
+
+use base qw(Exporter);
+use vars qw(@EXPORT_OK @EXPORT $VERSION);
+
+use Carp qw(carp);
+use File::Spec::Functions qw(catfile);
+
+@EXPORT = qw(run_t_manifest);
+@EXPORT_OK = qw(get_t_files make_test_manifest manifest_name);
+
+$VERSION = '1.23';
+
+my $Manifest = catfile( "t", "test_manifest" );
+my %SeenInclude = ();
+my %SeenTest = ();
+
+require 5.006;
+
+sub MY::test_via_harness
+ {
+ my($self, $perl, $tests) = @_;
+
+ return qq|\t$perl "-MTest::Manifest" | .
+ qq|"-e" "run_t_manifest(\$(TEST_VERBOSE), '\$(INST_LIB)', | .
+ qq|'\$(INST_ARCHLIB)', \$(TEST_LEVEL) )"\n|;
+ };
+
+=head1 NAME
+
+Test::Manifest - interact with a t/test_manifest file
+
+=head1 SYNOPSIS
+
+ # in Makefile.PL
+ eval "use Test::Manifest";
+
+ # in the file t/test_manifest, list the tests you want
+ # to run
+
+=head1 DESCRIPTION
+
+C<Test::Harness> assumes that you want to run all of the F<.t> files in the
+F<t/> directory in ascii-betical order during C<make test> unless you say
+otherwise. This leads to some interesting naming schemes for test
+files to get them in the desired order. This interesting names ossify
+when they get into source control, and get even more interesting as
+more tests show up.
+
+C<Test::Manifest> overrides the default behaviour by replacing the
+test_via_harness target in the Makefile. Instead of running at the
+F<t/*.t> files in ascii-betical order, it looks in the F<t/test_manifest>
+file to find out which tests you want to run and the order in which
+you want to run them. It constructs the right value for MakeMaker to
+do the right thing.
+
+In F<t/test_manifest>, simply list the tests that you want to run. Their
+order in the file is the order in which they run. You can comment
+lines with a C<#>, just like in Perl, and C<Test::Manifest> will strip
+leading and trailing whitespace from each line. It also checks that
+the specified file is actually in the F<t/> directory. If the file does
+not exist, it does not put its name in the list of test files to run and
+it will issue a warning.
+
+Optionally, you can add a number after the test name in test_manifest
+to define sets of tests. See C<get_t_files> for more information.
+
+=head2 Functions
+
+=over 4
+
+=item run_t_manifest( TEST_VERBOSE, INST_LIB, INST_ARCHLIB, TEST_LEVEL )
+
+Run all of the files in t/test_manifest through Test::Harness:runtests
+in the order they appear in the file.
+
+ eval "use Test::Manifest";
+
+=cut
+
+sub run_t_manifest
+ {
+ require Test::Harness;
+ require File::Spec;
+
+ $Test::Harness::verbose = shift;
+
+ local @INC = @INC;
+ unshift @INC, map { File::Spec->rel2abs($_) } @_[0,1];
+
+ my( $level ) = $_[2] || 0;
+
+ print STDERR "Test::Manifest $VERSION\n"
+ if $Test::Harness::verbose;
+
+ print STDERR "Level is $level\n"
+ if $Test::Harness::verbose;
+
+ my @files = get_t_files( $level );
+ print STDERR "Test::Manifest::test_harness found [@files]\n"
+ if $Test::Harness::verbose;
+
+ Test::Harness::runtests( @files );
+ }
+
+=item get_t_files( [LEVEL] )
+
+In scalar context it returns a single string that you can use directly
+in WriteMakefile(). In list context it returns a list of the files it
+found in t/test_manifest.
+
+If a t/test_manifest file does not exist, get_t_files() returns
+nothing.
+
+get_t_files() warns you if it can't find t/test_manifest, or if
+entries start with "t/". It skips blank lines, and strips Perl
+style comments from the file.
+
+Each line in t/test_manifest can have three parts: the test name,
+the test level (a floating point number), and a comment. By default,
+the test level is 1.
+
+ test_name.t 2 #Run this only for level 2 testing
+
+Without an argument, get_t_files() returns all the test files it
+finds. With an argument that is true (so you can't use 0 as a level)
+and is a number, it skips tests with a level greater than that
+argument. You can then define sets of tests and choose a set to
+run. For instance, you might create a set for end users, but also
+add on a set for deeper testing for developers.
+
+Experimentally, you can include a command to grab test names from
+another file. The command starts with a C<;> to distinguish it
+from a true filename. The filename (currently) is relative to the
+current working directory, unlike the filenames, which are relative
+to C<t/>. The filenames in the included are still relative to C<t/>.
+
+ ;include t/file_with_other_test_names.txt
+
+Also experimentally, you can stop Test::Manifest from reading filenames
+with the C<;skip> directive. Test::Harness will skip the filenames up to
+the C<;unskip> directive (or end of file)
+
+ run_this1
+ ;skip
+ skip_this
+ ;unskip
+ run_this2
+
+To select sets of tests, specify the level in the variable TEST_LEVEL
+during `make test`.
+
+ make test # run all tests no matter the level
+ make test TEST_LEVEL=2 # run all tests level 2 and below
+
+=cut
+
+sub get_t_files
+ {
+ my $upper_bound = shift;
+ print STDERR "# Test level is $upper_bound\n"
+ if $Test::Harness::verbose;
+
+ %SeenInclude = ();
+ %SeenTest = ();
+
+ carp( "$Manifest does not exist!" ) unless -e $Manifest;
+ my $result = _load_test_manifest($Manifest, $upper_bound);
+ return unless defined $result;
+ my @tests = @{$result};
+
+ return wantarray ? @tests : join " ", @tests;
+ }
+
+# Wrapper for loading test manifest files to support including other files
+sub _load_test_manifest
+ {
+ my $manifest = shift;
+ return unless open my( $fh ), $manifest;
+
+ my $upper_bound = shift || 0;
+ my @tests = ();
+
+ LINE: while( <$fh> )
+ {
+ s/#.*//; s/^\s+//; s/\s+$//;
+
+ next unless $_;
+
+ my( $command, $arg ) = split/\s+/, $_, 2;
+ if( ';' eq substr( $command, 0, 1 ) )
+ {
+ if( $command eq ';include' )
+ {
+ my $result = _include_file( $arg, $., $upper_bound );
+ push @tests, @$result if defined $result;
+ next;
+ }
+ elsif( $command eq ';skip' )
+ {
+ while( <$fh> ) { last if m/^;unskip/ }
+ next LINE;
+ }
+ else
+ {
+ croak( "Unknown directive: $command" );
+ }
+ }
+
+ my( $test, $level ) = ( $command, $arg );
+ $level = 1 unless defined $level;
+
+ next if( $upper_bound and $level > $upper_bound );
+
+ carp( "Bad value for test [$test] level [$level]\n".
+ "Level should be a floating-point number\n" )
+ unless $level =~ m/^\d+(?:.\d+)?$/;
+ carp( "test file begins with t/ [$test]" ) if m|^t/|;
+
+ $test = catfile( "t", $test ) if -e catfile( "t", $test );
+
+ unless( -e $test )
+ {
+ carp( "test file [$test] does not exist! Skipping!" );
+ next;
+ }
+
+ # Make sure we don't include a test we've already seen
+ next if exists $SeenTest{$test};
+
+ $SeenTest{$test} = 1;
+ push @tests, $test;
+ }
+
+ close $fh;
+ return \@tests;
+ }
+
+sub _include_file
+ {
+ my( $file, $line, $upper_bound ) = @_;
+ print STDERR "# Including file $file at line $line\n"
+ if $Test::Harness::verbose;
+
+ unless( -e $file )
+ {
+ carp( "$file does not exist" ) ;
+ return;
+ }
+
+ if( exists $SeenInclude{$file} )
+ {
+ carp( "$file already loaded - skipping" ) ;
+ return;
+ }
+
+ $SeenInclude{$file} = $line;
+
+ my $result = _load_test_manifest( $file, $upper_bound );
+ return unless defined $result;
+
+ $result;
+ }
+
+
+=item make_test_manifest()
+
+Creates the test_manifest file in the t directory by reading
+the contents of the t directory.
+
+TO DO: specify tests in argument lists.
+
+TO DO: specify files to skip.
+
+=cut
+
+sub make_test_manifest()
+ {
+ carp( "t/ directory does not exist!" ) unless -d "t";
+ return unless open my( $fh ), "> $Manifest";
+
+ my $count = 0;
+ while( my $file = glob("t/*.t") )
+ {
+ $file =~ s|^t/||;
+ print $fh "$file\n";
+ $count++;
+ }
+ close $fh;
+
+ return $count;
+ }
+
+=item manifest_name()
+
+Returns the name of the test manifest file, relative to t/
+
+=cut
+
+sub manifest_name
+ {
+ return $Manifest;
+ }
+
+=back
+
+=head1 SOURCE AVAILABILITY
+
+This source is in Github:
+
+ http://github.com/briandfoy/Test-Manifest/tree/master
+
+=head1 CREDITS
+
+Matt Vanderpol suggested and supplied a patch for the ;include
+feature.
+
+=head1 AUTHOR
+
+brian d foy, C<< <bdfoy@cpan.org> >>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2009 brian d foy. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/More.pm b/Master/tlpkg/tlperl.straw/lib/Test/More.pm
new file mode 100755
index 00000000000..67284874698
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/More.pm
@@ -0,0 +1,1776 @@
+package Test::More;
+
+use 5.006;
+use strict;
+use warnings;
+
+#---- perlcritic exemptions. ----#
+
+# We use a lot of subroutine prototypes
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
+
+# Can't use Carp because it might cause use_ok() to accidentally succeed
+# even though the module being used forgot to use Carp. Yes, this
+# actually happened.
+sub _carp {
+ my( $file, $line ) = ( caller(1) )[ 1, 2 ];
+ return warn @_, " at $file line $line\n";
+}
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Builder::Module;
+our @ISA = qw(Test::Builder::Module);
+our @EXPORT = qw(ok use_ok require_ok
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
+ pass fail
+ eq_array eq_hash eq_set
+ $TODO
+ plan
+ done_testing
+ can_ok isa_ok new_ok
+ diag note explain
+ subtest
+ BAIL_OUT
+);
+
+=head1 NAME
+
+Test::More - yet another framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use Test::More tests => 23;
+ # or
+ use Test::More skip_all => $reason;
+ # or
+ use Test::More; # see done_testing()
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ require_ok( 'Some::Module' );
+
+ # Various ways to say "ok"
+ ok($got eq $expected, $test_name);
+
+ is ($got, $expected, $test_name);
+ isnt($got, $expected, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($got, qr/expected/, $test_name);
+ unlike($got, qr/expected/, $test_name);
+
+ cmp_ok($got, '==', $expected, $test_name);
+
+ is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
+
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ TODO: {
+ local $TODO = $why;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ can_ok($module, @methods);
+ isa_ok($object, $class);
+
+ pass($test_name);
+ fail($test_name);
+
+ BAIL_OUT($why);
+
+ # UNIMPLEMENTED!!!
+ my @status = Test::More::status;
+
+
+=head1 DESCRIPTION
+
+B<STOP!> If you're just getting started writing tests, have a look at
+L<Test::Simple> first. This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
+
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
+
+
+=head2 I love it when a plan comes together
+
+Before anything else, you need a testing plan. This basically declares
+how many tests your script is going to run to protect against premature
+failure.
+
+The preferred way to do this is to declare a plan when you C<use Test::More>.
+
+ use Test::More tests => 23;
+
+There are cases when you will not know beforehand how many tests your
+script is going to run. In this case, you can declare your tests at
+the end.
+
+ use Test::More;
+
+ ... run your tests ...
+
+ done_testing( $number_of_tests_run );
+
+Sometimes you really don't know how many tests were run, or it's too
+difficult to calculate. In which case you can leave off
+$number_of_tests_run.
+
+In some cases, you'll want to completely skip an entire testing script.
+
+ use Test::More skip_all => $skip_reason;
+
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success). See L<Test::Harness> for
+details.
+
+If you want to control what functions Test::More will export, you
+have to use the 'import' option. For example, to import everything
+but 'fail', you'd do:
+
+ use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function. Useful for when you
+have to calculate the number of tests.
+
+ use Test::More;
+ plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+ use Test::More;
+ if( $^O eq 'MacOS' ) {
+ plan skip_all => 'Test irrelevant on MacOS';
+ }
+ else {
+ plan tests => 42;
+ }
+
+=cut
+
+sub plan {
+ my $tb = Test::More->builder;
+
+ return $tb->plan(@_);
+}
+
+# This implements "use Test::More 'no_diag'" but the behavior is
+# deprecated.
+sub import_extra {
+ my $class = shift;
+ my $list = shift;
+
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'no_diag' ) {
+ $class->builder->no_diag(1);
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return;
+}
+
+=over 4
+
+=item B<done_testing>
+
+ done_testing();
+ done_testing($number_of_tests);
+
+If you don't know how many tests you're going to run, you can issue
+the plan when you're done running tests.
+
+$number_of_tests is the same as plan(), it's the number of tests you
+expected to run. You can omit this, in which case the number of tests
+you ran doesn't matter, just the fact that your tests ran to
+conclusion.
+
+This is safer than and replaces the "no_plan" plan.
+
+=back
+
+=cut
+
+sub done_testing {
+ my $tb = Test::More->builder;
+ $tb->done_testing(@_);
+}
+
+=head2 Test names
+
+By convention, each test is assigned a number in order. This is
+largely done automatically for you. However, it's often very useful to
+assign a name to each test. Which would you rather see:
+
+ ok 4
+ not ok 5
+ ok 6
+
+or
+
+ ok 4 - basic multi-variable
+ not ok 5 - simple exponential
+ ok 6 - force == mass * acceleration
+
+The later gives you some idea of what failed. It also makes it easier
+to find the test in your script, simply search for "simple
+exponential".
+
+All test functions take a name argument. It's optional, but highly
+suggested that you use it.
+
+=head2 I'm ok, you're not ok.
+
+The basic purpose of this module is to print out either "ok #" or "not
+ok #" depending on if a given test succeeded or failed. Everything
+else is just gravy.
+
+All of the following print "ok" or "not ok" depending on if the test
+succeeded or failed. They all also return true or false,
+respectively.
+
+=over 4
+
+=item B<ok>
+
+ ok($got eq $expected, $test_name);
+
+This simply evaluates any expression (C<$got eq $expected> is just a
+simple example) and uses that to determine if the test succeeded or
+failed. A true expression passes, a false one fails. Very simple.
+
+For example:
+
+ ok( $exp{9} == 81, 'simple exponential' );
+ ok( Film->can('db_Main'), 'set_db()' );
+ ok( $p->tests == 4, 'saw tests' );
+ ok( !grep !defined $_, @items, 'items populated' );
+
+(Mnemonic: "This is ok.")
+
+$test_name is a very short description of the test that will be printed
+out. It makes it very easy to find a test in your script when it fails
+and gives others an idea of your intentions. $test_name is optional,
+but we B<very> strongly encourage its use.
+
+Should an ok() fail, it will produce some diagnostics:
+
+ not ok 18 - sufficient mucus
+ # Failed test 'sufficient mucus'
+ # in foo.t at line 42.
+
+This is the same as Test::Simple's ok() routine.
+
+=cut
+
+sub ok ($;$) {
+ my( $test, $name ) = @_;
+ my $tb = Test::More->builder;
+
+ return $tb->ok( $test, $name );
+}
+
+=item B<is>
+
+=item B<isnt>
+
+ is ( $got, $expected, $test_name );
+ isnt( $got, $expected, $test_name );
+
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> respectively and use the result of that to
+determine if the test succeeded or failed. So these:
+
+ # Is the ultimate answer 42?
+ is( ultimate_answer(), 42, "Meaning of Life" );
+
+ # $foo isn't empty
+ isnt( $foo, '', "Got some foo" );
+
+are similar to these:
+
+ ok( ultimate_answer() eq 42, "Meaning of Life" );
+ ok( $foo ne '', "Got some foo" );
+
+(Mnemonic: "This is that." "This isn't that.")
+
+So why use these? They produce better diagnostics on failure. ok()
+cannot know what you are testing for (beyond the name), but is() and
+isnt() know what the test was and why it failed. For example this
+test:
+
+ my $foo = 'waffle'; my $bar = 'yarblokos';
+ is( $foo, $bar, 'Is foo the same as bar?' );
+
+Will produce something like this:
+
+ not ok 17 - Is foo the same as bar?
+ # Failed test 'Is foo the same as bar?'
+ # in foo.t at line 139.
+ # got: 'waffle'
+ # expected: 'yarblokos'
+
+So you can figure out what went wrong without rerunning the test.
+
+You are encouraged to use is() and isnt() over ok() where possible,
+however do not be tempted to use them to find out if something is
+true or false!
+
+ # XXX BAD!
+ is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
+
+This does not check if C<exists $brooklyn{tree}> is true, it checks if
+it returns 1. Very different. Similar caveats exist for false and 0.
+In these cases, use ok().
+
+ ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
+
+A simple call to isnt() usually does not provide a strong test but there
+are cases when you cannot say much more about a value than that it is
+different from some other value:
+
+ new_ok $obj, "Foo";
+
+ my $clone = $obj->clone;
+ isa_ok $obj, "Foo", "Foo->clone";
+
+ isnt $obj, $clone, "clone() produces a different object";
+
+For those grammatical pedants out there, there's an C<isn't()>
+function which is an alias of isnt().
+
+=cut
+
+sub is ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->is_eq(@_);
+}
+
+sub isnt ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->isnt_eq(@_);
+}
+
+*isn't = \&isnt;
+
+=item B<like>
+
+ like( $got, qr/expected/, $test_name );
+
+Similar to ok(), like() matches $got against the regex C<qr/expected/>.
+
+So this:
+
+ like($got, qr/expected/, 'this is like that');
+
+is similar to:
+
+ ok( $got =~ /expected/, 'this is like that');
+
+(Mnemonic "This is like that".)
+
+The second argument is a regular expression. It may be given as a
+regex reference (i.e. C<qr//>) or (for better compatibility with older
+perls) as a string that looks like a regex (alternative delimiters are
+currently not supported):
+
+ like( $got, '/expected/', 'this is like that' );
+
+Regex options may be placed on the end (C<'/expected/i'>).
+
+Its advantages over ok() are similar to that of is() and isnt(). Better
+diagnostics on failure.
+
+=cut
+
+sub like ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->like(@_);
+}
+
+=item B<unlike>
+
+ unlike( $got, qr/expected/, $test_name );
+
+Works exactly as like(), only it checks if $got B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->unlike(@_);
+}
+
+=item B<cmp_ok>
+
+ cmp_ok( $got, $op, $expected, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $got eq $expected );
+ cmp_ok( $got, 'eq', $expected, 'this eq that' );
+
+ # ok( $got == $expected );
+ cmp_ok( $got, '==', $expected, 'this == that' );
+
+ # ok( $got && $expected );
+ cmp_ok( $got, '&&', $expected, 'this && that' );
+ ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $got
+and $expected were:
+
+ not ok 1
+ # Failed test in foo.t at line 12.
+ # '23'
+ # &&
+ # undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+It's especially useful when comparing greater-than or smaller-than
+relation between values:
+
+ cmp_ok( $some_value, '<=', $upper_limit );
+
+
+=cut
+
+sub cmp_ok($$$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->cmp_ok(@_);
+}
+
+=item B<can_ok>
+
+ can_ok($module, @methods);
+ can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+ can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
+ );
+
+only without all the typing and with a better interface. Handy for
+quickly testing an interface.
+
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
+=cut
+
+sub can_ok ($@) {
+ my( $proto, @methods ) = @_;
+ my $class = ref $proto || $proto;
+ my $tb = Test::More->builder;
+
+ unless($class) {
+ my $ok = $tb->ok( 0, "->can(...)" );
+ $tb->diag(' can_ok() called with empty class or reference');
+ return $ok;
+ }
+
+ unless(@methods) {
+ my $ok = $tb->ok( 0, "$class->can(...)" );
+ $tb->diag(' can_ok() called with no methods');
+ return $ok;
+ }
+
+ my @nok = ();
+ foreach my $method (@methods) {
+ $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
+ }
+
+ my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
+ "$class->can(...)" ;
+
+ my $ok = $tb->ok( !@nok, $name );
+
+ $tb->diag( map " $class->can('$_') failed\n", @nok );
+
+ return $ok;
+}
+
+=item B<isa_ok>
+
+ isa_ok($object, $class, $object_name);
+ isa_ok($subclass, $class, $object_name);
+ isa_ok($ref, $type, $ref_name);
+
+Checks to see if the given C<< $object->isa($class) >>. Also checks to make
+sure the object was defined in the first place. Handy for this sort
+of thing:
+
+ my $obj = Some::Module->new;
+ isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+ my $obj = Some::Module->new;
+ ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+You can also test a class, to make sure that it has the right ancestor:
+
+ isa_ok( 'Vole', 'Rodent' );
+
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'. If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
+=cut
+
+sub isa_ok ($$;$) {
+ my( $object, $class, $obj_name ) = @_;
+ my $tb = Test::More->builder;
+
+ my $diag;
+
+ if( !defined $object ) {
+ $obj_name = 'The thing' unless defined $obj_name;
+ $diag = "$obj_name isn't defined";
+ }
+ else {
+ my $whatami = ref $object ? 'object' : 'class';
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
+ if($error) {
+ if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
+ # Its an unblessed reference
+ $obj_name = 'The reference' unless defined $obj_name;
+ if( !UNIVERSAL::isa( $object, $class ) ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+ elsif( $error =~ /Can't call method "isa" without a package/ ) {
+ # It's something that can't even be a class
+ $obj_name = 'The thing' unless defined $obj_name;
+ $diag = "$obj_name isn't a class or reference";
+ }
+ else {
+ die <<WHOA;
+WHOA! I tried to call ->isa on your $whatami and got some weird error.
+Here's the error.
+$error
+WHOA
+ }
+ }
+ else {
+ $obj_name = "The $whatami" unless defined $obj_name;
+ if( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+ }
+
+ my $name = "$obj_name isa $class";
+ my $ok;
+ if($diag) {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
+ }
+ else {
+ $ok = $tb->ok( 1, $name );
+ }
+
+ return $ok;
+}
+
+=item B<new_ok>
+
+ my $obj = new_ok( $class );
+ my $obj = new_ok( $class => \@args );
+ my $obj = new_ok( $class => \@args, $object_name );
+
+A convenience function which combines creating an object and calling
+isa_ok() on that object.
+
+It is basically equivalent to:
+
+ my $obj = $class->new(@args);
+ isa_ok $obj, $class, $object_name;
+
+If @args is not given, an empty list will be used.
+
+This function only works on new() and it assumes new() will return
+just a single object which isa C<$class>.
+
+=cut
+
+sub new_ok {
+ my $tb = Test::More->builder;
+ $tb->croak("new_ok() must be given at least a class") unless @_;
+
+ my( $class, $args, $object_name ) = @_;
+
+ $args ||= [];
+ $object_name = "The object" unless defined $object_name;
+
+ my $obj;
+ my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
+ if($success) {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ isa_ok $obj, $class, $object_name;
+ }
+ else {
+ $tb->ok( 0, "new() died" );
+ $tb->diag(" Error was: $error");
+ }
+
+ return $obj;
+}
+
+=item B<subtest>
+
+ subtest $name => \&code;
+
+subtest() runs the &code as its own little test with its own plan and
+its own result. The main test counts this as a single test using the
+result of the whole subtest to determine if its ok or not ok.
+
+For example...
+
+ use Test::More tests => 3;
+
+ pass("First test");
+
+ subtest 'An example subtest' => sub {
+ plan tests => 2;
+
+ pass("This is a subtest");
+ pass("So is this");
+ };
+
+ pass("Third test");
+
+This would produce.
+
+ 1..3
+ ok 1 - First test
+ 1..2
+ ok 1 - This is a subtest
+ ok 2 - So is this
+ ok 2 - An example subtest
+ ok 3 - Third test
+
+A subtest may call "skip_all". No tests will be run, but the subtest is
+considered a skip.
+
+ subtest 'skippy' => sub {
+ plan skip_all => 'cuz I said so';
+ pass('this test will never be run');
+ };
+
+Returns true if the subtest passed, false otherwise.
+
+=cut
+
+sub subtest($&) {
+ my ($name, $subtests) = @_;
+
+ my $tb = Test::More->builder;
+ return $tb->subtest(@_);
+}
+
+=item B<pass>
+
+=item B<fail>
+
+ pass($test_name);
+ fail($test_name);
+
+Sometimes you just want to say that the tests have passed. Usually
+the case is you've got some complicated condition that is difficult to
+wedge into an ok(). In this case, you can simply use pass() (to
+declare the test ok) or fail (for not ok). They are synonyms for
+ok(1) and ok(0).
+
+Use these very, very, very sparingly.
+
+=cut
+
+sub pass (;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->ok( 1, @_ );
+}
+
+sub fail (;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->ok( 0, @_ );
+}
+
+=back
+
+
+=head2 Module tests
+
+You usually want to test if the module you're testing loads ok, rather
+than just vomiting if its load fails. For such purposes we have
+C<use_ok> and C<require_ok>.
+
+=over 4
+
+=item B<use_ok>
+
+ BEGIN { use_ok($module); }
+ BEGIN { use_ok($module, @imports); }
+
+These simply use the given $module and test to make sure the load
+happened ok. It's recommended that you run use_ok() inside a BEGIN
+block so its functions are exported at compile-time and prototypes are
+properly honored.
+
+If @imports are given, they are passed through to the use. So this:
+
+ BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+ use Some::Module qw(foo bar);
+
+Version numbers can be checked like so:
+
+ # Just like "use Some::Module 1.02"
+ BEGIN { use_ok('Some::Module', 1.02) }
+
+Don't try to do this:
+
+ BEGIN {
+ use_ok('Some::Module');
+
+ ...some code that depends on the use...
+ ...happening at compile time...
+ }
+
+because the notion of "compile-time" is relative. Instead, you want:
+
+ BEGIN { use_ok('Some::Module') }
+ BEGIN { ...some code that depends on the use... }
+
+
+=cut
+
+sub use_ok ($;@) {
+ my( $module, @imports ) = @_;
+ @imports = () unless @imports;
+ my $tb = Test::More->builder;
+
+ my( $pack, $filename, $line ) = caller;
+
+ my $code;
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ $code = <<USE;
+package $pack;
+use $module $imports[0];
+1;
+USE
+ }
+ else {
+ $code = <<USE;
+package $pack;
+use $module \@{\$args[0]};
+1;
+USE
+ }
+
+ my( $eval_result, $eval_error ) = _eval( $code, \@imports );
+ my $ok = $tb->ok( $eval_result, "use $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+ {BEGIN failed--compilation aborted at $filename line $line.}m;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to use '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _eval {
+ my( $code, @args ) = @_;
+
+ # Work around oddities surrounding resetting of $@ by immediately
+ # storing it.
+ my( $sigdie, $eval_result, $eval_error );
+ {
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+ $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+ $eval_error = $@;
+ $sigdie = $SIG{__DIE__} || undef;
+ }
+ # make sure that $code got a chance to set $SIG{__DIE__}
+ $SIG{__DIE__} = $sigdie if defined $sigdie;
+
+ return( $eval_result, $eval_error );
+}
+
+=item B<require_ok>
+
+ require_ok($module);
+ require_ok($file);
+
+Like use_ok(), except it requires the $module or $file.
+
+=cut
+
+sub require_ok ($) {
+ my($module) = shift;
+ my $tb = Test::More->builder;
+
+ my $pack = caller;
+
+ # Try to deterine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ my $code = <<REQUIRE;
+package $pack;
+require $module;
+1;
+REQUIRE
+
+ my( $eval_result, $eval_error ) = _eval($code);
+ my $ok = $tb->ok( $eval_result, "require $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+
+ return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
+}
+
+=back
+
+
+=head2 Complex data structures
+
+Not everything is a simple eq check or regex. There are times you
+need to see if two data structures are equivalent. For these
+instances Test::More provides a handful of useful functions.
+
+B<NOTE> I'm not quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $got, $expected, $test_name );
+
+Similar to is(), except that if $got and $expected are references, it
+does a deep comparison walking each data structure to see if they are
+equivalent. If the two structures are different, it will display the
+place where they start differing.
+
+is_deeply() compares the dereferenced values of references, the
+references themselves (except for their type) are ignored. This means
+aspects such as blessing and ties are not considered "different".
+
+is_deeply() currently has very limited handling of function reference
+and globs. It merely checks if they have the same referent. This may
+improve in the future.
+
+L<Test::Differences> and L<Test::Deep> provide more in-depth functionality
+along these lines.
+
+=cut
+
+our( @Data_Stack, %Refs_Seen );
+my $DNE = bless [], 'Does::Not::Exist';
+
+sub _dne {
+ return ref $_[0] eq ref $DNE;
+}
+
+## no critic (Subroutines::RequireArgUnpacking)
+sub is_deeply {
+ my $tb = Test::More->builder;
+
+ unless( @_ == 2 or @_ == 3 ) {
+ my $msg = <<'WARNING';
+is_deeply() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ _carp sprintf $msg, scalar @_;
+
+ return $tb->ok(0);
+ }
+
+ my( $got, $expected, $name ) = @_;
+
+ $tb->_unoverload_str( \$expected, \$got );
+
+ my $ok;
+ if( !ref $got and !ref $expected ) { # neither is a reference
+ $ok = $tb->is_eq( $got, $expected, $name );
+ }
+ elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
+ }
+ else { # both references
+ local @Data_Stack = ();
+ if( _deep_check( $got, $expected ) ) {
+ $ok = $tb->ok( 1, $name );
+ }
+ else {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack(@Data_Stack) );
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my(@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
+ my @vars = ();
+ ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
+ ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
+
+ my $out = "Structures begin differing at:\n";
+ foreach my $idx ( 0 .. $#vals ) {
+ my $val = $vals[$idx];
+ $vals[$idx]
+ = !defined $val ? 'undef'
+ : _dne($val) ? "Does not exist"
+ : ref $val ? "$val"
+ : "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ return $type if UNIVERSAL::isa( $thing, $type );
+ }
+
+ return '';
+}
+
+=back
+
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Like C<print> @diagnostic_message is simply concatenated
+together.
+
+Returns false, so as to preserve failure.
+
+Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test 'There's a foo user'
+ # in foo.t at line 52.
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=item B<note>
+
+ note(@diagnostic_message);
+
+Like diag(), except the message will not be seen when the test is run
+in a harness. It will only be visible in the verbose TAP stream.
+
+Handy for putting in notes which might be useful for debugging, but
+don't indicate a problem.
+
+ note("Tempfile is $tempfile");
+
+=cut
+
+sub diag {
+ return Test::More->builder->diag(@_);
+}
+
+sub note {
+ return Test::More->builder->note(@_);
+}
+
+=item B<explain>
+
+ my @dump = explain @diagnostic_message;
+
+Will dump the contents of any references in a human readable format.
+Usually you want to pass this into C<note> or C<diag>.
+
+Handy for things like...
+
+ is_deeply($have, $want) || diag explain $have;
+
+or
+
+ note explain \%args;
+ Some::Class->method(%args);
+
+=cut
+
+sub explain {
+ return Test::More->builder->explain(@_);
+}
+
+=back
+
+
+=head2 Conditional tests
+
+Sometimes running a test under certain conditions will cause the
+test script to die. A certain function or method isn't implemented
+(such as fork() on MacOS), some resource isn't available (like a
+net connection) or a module isn't available. In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
+but will work in the future (a todo test).
+
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
+
+The way Test::More handles this is with a named block. Basically, a
+block of tests which can be skipped over or made todo. It's best if I
+just show you...
+
+=over 4
+
+=item B<SKIP: BLOCK>
+
+ SKIP: {
+ skip $why, $how_many if $condition;
+
+ ...normal testing code goes here...
+ }
+
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them. An example is
+the easiest way to illustrate:
+
+ SKIP: {
+ eval { require HTML::Lint };
+
+ skip "HTML::Lint not installed", 2 if $@;
+
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
+
+ $lint->parse( $html );
+ is( $lint->errors, 0, "No errors found in HTML" );
+ }
+
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>. Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
+
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
+
+It's perfectly safe to nest SKIP blocks. Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
+
+You don't skip tests which are failing because there's a bug in your
+program, or for which you don't yet have code written. For that you
+use TODO. Read on.
+
+=cut
+
+## no critic (Subroutines::RequireFinalReturn)
+sub skip {
+ my( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ if( defined $how_many and $how_many =~ /\D/ ) {
+ _carp
+ "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
+ $how_many = 1;
+ }
+
+ for( 1 .. $how_many ) {
+ $tb->skip($why);
+ }
+
+ no warnings 'exiting';
+ last SKIP;
+}
+
+=item B<TODO: BLOCK>
+
+ TODO: {
+ local $TODO = $why if $condition;
+
+ ...normal testing code goes here...
+ }
+
+Declares a block of tests you expect to fail and $why. Perhaps it's
+because you haven't fixed a bug or haven't finished a new feature:
+
+ TODO: {
+ local $TODO = "URI::Geller not finished";
+
+ my $card = "Eight of clubs";
+ is( URI::Geller->your_card, $card, 'Is THIS your card?' );
+
+ my $spoon;
+ URI::Geller->bend_spoon;
+ is( $spoon, 'bent', "Spoon bending, that's original" );
+ }
+
+With a todo block, the tests inside are expected to fail. Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo". Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programmatic todo list. You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+With todo tests, it's best to have the tests actually run. That way
+you'll know when they start passing. Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>. In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "todo_skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ for( 1 .. $how_many ) {
+ $tb->todo_skip($why);
+ }
+
+ no warnings 'exiting';
+ last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
+
+B<If it's something the programmer hasn't done yet>, use TODO. This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
+
+
+=back
+
+
+=head2 Test control
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ BAIL_OUT($reason);
+
+Indicates to the harness that things are going so badly all testing
+should terminate. This includes the running any additional test scripts.
+
+This is typically used when testing cannot continue such as a critical
+module failing to compile or a necessary external utility not being
+available such as a database connection failing.
+
+The test will exit with 255.
+
+For even better control look at L<Test::Most>.
+
+=cut
+
+sub BAIL_OUT {
+ my $reason = shift;
+ my $tb = Test::More->builder;
+
+ $tb->BAIL_OUT($reason);
+}
+
+=back
+
+
+=head2 Discouraged comparison functions
+
+The use of the following functions is discouraged as they are not
+actually testing functions and produce no diagnostics to help figure
+out what went wrong. They were written before is_deeply() existed
+because I couldn't figure out how to display a useful diff of two
+arbitrary data structures.
+
+These functions are usually used inside an ok().
+
+ ok( eq_array(\@got, \@expected) );
+
+C<is_deeply()> can do that better and with diagnostics.
+
+ is_deeply( \@got, \@expected );
+
+They may be deprecated in future versions.
+
+=over 4
+
+=item B<eq_array>
+
+ my $is_eq = eq_array(\@got, \@expected);
+
+Checks if two arrays are equivalent. This is a deep check, so
+multi-level structures are handled correctly.
+
+=cut
+
+#'#
+sub eq_array {
+ local @Data_Stack = ();
+ _deep_check(@_);
+}
+
+sub _eq_array {
+ my( $a1, $a2 ) = @_;
+
+ if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
+ warn "eq_array passed a non-array ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for( 0 .. $max ) {
+ my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+ push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+sub _deep_check {
+ my( $e1, $e2 ) = @_;
+ my $tb = Test::More->builder;
+
+ my $ok = 0;
+
+ # Effectively turn %Refs_Seen into a stack. This avoids picking up
+ # the same referenced used twice (such as [\$a, \$a]) to be considered
+ # circular.
+ local %Refs_Seen = %Refs_Seen;
+
+ {
+ # Quiet uninitialized value warnings when comparing undefs.
+ no warnings 'uninitialized';
+
+ $tb->_unoverload_str( \$e1, \$e2 );
+
+ # Either they're both references or both not.
+ my $same_ref = !( !ref $e1 xor !ref $e2 );
+ my $not_ref = ( !ref $e1 and !ref $e2 );
+
+ if( defined $e1 xor defined $e2 ) {
+ $ok = 0;
+ }
+ elsif( !defined $e1 and !defined $e2 ) {
+ # Shortcut if they're both defined.
+ $ok = 1;
+ }
+ elsif( _dne($e1) xor _dne($e2) ) {
+ $ok = 0;
+ }
+ elsif( $same_ref and( $e1 eq $e2 ) ) {
+ $ok = 1;
+ }
+ elsif($not_ref) {
+ push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ if( $Refs_Seen{$e1} ) {
+ return $Refs_Seen{$e1} eq $e2;
+ }
+ else {
+ $Refs_Seen{$e1} = "$e2";
+ }
+
+ my $type = _type($e1);
+ $type = 'DIFFERENT' unless _type($e2) eq $type;
+
+ if( $type eq 'DIFFERENT' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $ok = _eq_array( $e1, $e2 );
+ }
+ elsif( $type eq 'HASH' ) {
+ $ok = _eq_hash( $e1, $e2 );
+ }
+ elsif( $type eq 'REF' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif($type) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ _whoa( 1, "No type in _deep_check" );
+ }
+ }
+ }
+
+ return $ok;
+}
+
+sub _whoa {
+ my( $check, $desc ) = @_;
+ if($check) {
+ die <<"WHOA";
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+=item B<eq_hash>
+
+ my $is_eq = eq_hash(\%got, \%expected);
+
+Determines if the two hashes contain the same keys and values. This
+is a deep check.
+
+=cut
+
+sub eq_hash {
+ local @Data_Stack = ();
+ return _deep_check(@_);
+}
+
+sub _eq_hash {
+ my( $a1, $a2 ) = @_;
+
+ if( grep _type($_) ne 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ foreach my $k ( keys %$bigger ) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+=item B<eq_set>
+
+ my $is_eq = eq_set(\@got, \@expected);
+
+Similar to eq_array(), except the order of the elements is B<not>
+important. This is a deep check, but the irrelevancy of order only
+applies to the top level.
+
+ ok( eq_set(\@got, \@expected) );
+
+Is better written:
+
+ is_deeply( [sort @got], [sort @expected] );
+
+B<NOTE> By historical accident, this is not a true set comparison.
+While the order of elements does not matter, duplicate elements do.
+
+B<NOTE> eq_set() does not know how to deal with references at the top
+level. The following is an example of a comparison which might not work:
+
+ eq_set([\1, \2], [\2, \1]);
+
+L<Test::Deep> contains much better set comparison functions.
+
+=cut
+
+sub eq_set {
+ my( $a1, $a2 ) = @_;
+ return 0 unless @$a1 == @$a2;
+
+ no warnings 'uninitialized';
+
+ # It really doesn't matter how we sort them, as long as both arrays are
+ # sorted with the same algorithm.
+ #
+ # Ensure that references are not accidentally treated the same as a
+ # string containing the reference.
+ #
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ #
+ # I don't know how references would be sorted so we just don't sort
+ # them. This means eq_set doesn't really work with refs.
+ return eq_array(
+ [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
+ [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
+ );
+}
+
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+ my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+
+=back
+
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+B<NOTE> This behavior may go away in future versions.
+
+
+=head1 CAVEATS and NOTES
+
+=over 4
+
+=item Backwards compatibility
+
+Test::More works with Perls as old as 5.6.0.
+
+
+=item utf8 / "Wide character in print"
+
+If you use utf8 or other non-ASCII characters with Test::More you
+might get a "Wide character in print" warning. Using C<binmode
+STDOUT, ":utf8"> will not fix it. Test::Builder (which powers
+Test::More) duplicates STDOUT and STDERR. So any changes to them,
+including changing their output disciplines, will not be seem by
+Test::More.
+
+The work around is to change the filehandles used by Test::Builder
+directly.
+
+ my $builder = Test::More->builder;
+ binmode $builder->output, ":utf8";
+ binmode $builder->failure_output, ":utf8";
+ binmode $builder->todo_output, ":utf8";
+
+
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings> (or in cmp_ok()'s
+case, strings or numbers as appropriate to the comparison op). This
+prevents Test::More from piercing an object's interface allowing
+better blackbox testing. So if a function starts returning overloaded
+objects instead of bare strings your tests won't notice the
+difference. This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects. In this case I would
+suggest L<Test::Deep> which contains more flexible testing functions for
+complex data structures.
+
+
+=item Threads
+
+Test::More will only be aware of threads if "use threads" has been done
+I<before> Test::More is loaded. This is ok:
+
+ use threads;
+ use Test::More;
+
+This may cause problems:
+
+ use Test::More
+ use threads;
+
+5.8.1 and above are supported. Anything below that has too many bugs.
+
+=back
+
+
+=head1 HISTORY
+
+This is a case of convergent evolution with Joshua Pritikin's Test
+module. I was largely unaware of its existence when I'd first
+written my own ok() routines. This module exists because I can't
+figure out how to easily wedge test names into Test's interface (along
+with a few other problems).
+
+The goal here is to have a testing utility that's simple to learn,
+quick to use and difficult to trip yourself up with while still
+providing more flexibility than the existing Test.pm. As such, the
+names of the most common routines are kept tiny, special cases and
+magic side-effects are kept to a minimum. WYSIWYG.
+
+
+=head1 SEE ALSO
+
+L<Test::Simple> if all this confuses you and you just want to write
+some tests. You can upgrade to Test::More later (it's forward
+compatible).
+
+L<Test::Harness> is the test runner and output interpreter for Perl.
+It's the thing that powers C<make test> and where the C<prove> utility
+comes from.
+
+L<Test::Legacy> tests written with Test.pm, the original testing
+module, do not play well with other testing libraries. Test::Legacy
+emulates the Test.pm interface and does play well with others.
+
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test::Class> is like xUnit but more perlish.
+
+L<Test::Deep> gives you more powerful complex data structure testing.
+
+L<Test::Inline> shows the idea of embedded testing.
+
+L<Bundle::Test> installs a whole bunch of useful test modules.
+
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
+
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/schwern/test-more/>.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings.pm b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings.pm
new file mode 100755
index 00000000000..17dfb1301c4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings.pm
@@ -0,0 +1,305 @@
+package Test::NoWarnings;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+use Exporter ();
+use Test::Builder;
+use Test::NoWarnings::Warning ();
+
+use vars qw( $VERSION @EXPORT_OK @ISA $do_end_test );
+BEGIN {
+ $VERSION = '1.01';
+ @ISA = 'Exporter';
+ @EXPORT_OK = qw(
+ clear_warnings had_no_warnings warnings
+ );
+
+ # Do we add the warning test at the end?
+ $do_end_test = 0;
+}
+
+my $TEST = Test::Builder->new;
+my $PID = $$;
+my @WARNINGS = ();
+
+$SIG{__WARN__} = make_catcher(\@WARNINGS);
+
+sub import {
+ $do_end_test = 1;
+ goto &Exporter::import;
+}
+
+# the END block must be after the "use Test::Builder" to make sure it runs
+# before Test::Builder's end block
+# only run the test if there have been other tests
+END {
+ had_no_warnings() if $do_end_test;
+}
+
+sub make_warning {
+ local $SIG{__WARN__};
+
+ my $msg = shift;
+ my $warning = Test::NoWarnings::Warning->new;
+
+ $warning->setMessage($msg);
+ $warning->fillTest($TEST);
+ $warning->fillTrace(__PACKAGE__);
+
+ $Carp::Internal{__PACKAGE__.""}++;
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ $warning->fillCarp($msg);
+ $Carp::Internal{__PACKAGE__.""}--;
+
+ return $warning;
+}
+
+# this make a subroutine which can be used in $SIG{__WARN__}
+# it takes one argument, a ref to an array
+# it will push the details of the warning onto the end of the array.
+sub make_catcher {
+ my $array = shift;
+
+ return sub {
+ my $msg = shift;
+
+ $Carp::Internal{__PACKAGE__.""}++;
+ push(@$array, make_warning($msg));
+ $Carp::Internal{__PACKAGE__.""}--;
+
+ return $msg;
+ };
+}
+
+sub had_no_warnings {
+ return 0 if $$ != $PID;
+
+ local $SIG{__WARN__};
+ my $name = shift || "no warnings";
+
+ my $ok;
+ my $diag;
+ if ( @WARNINGS == 0 ) {
+ $ok = 1;
+ } else {
+ $ok = 0;
+ $diag = "There were ".@WARNINGS." warning(s)\n";
+ $diag .= join "----------\n", map { $_->toString } @WARNINGS;
+ }
+
+ $TEST->ok($ok, $name) || $TEST->diag($diag);
+
+ return $ok;
+}
+
+sub clear_warnings {
+ local $SIG{__WARN__};
+ @WARNINGS = ();
+}
+
+sub warnings {
+ local $SIG{__WARN__};
+ return @WARNINGS;
+}
+
+sub builder {
+ local $SIG{__WARN__};
+ if ( @_ ) {
+ $TEST = shift;
+ }
+ return $TEST;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Test::NoWarnings - Make sure you didn't emit any warnings while testing
+
+=head1 SYNOPSIS
+
+For scripts that have no plan
+
+ use Test::NoWarnings;
+
+that's it, you don't need to do anything else
+
+For scripts that look like
+
+ use Test::More tests => x;
+
+change to
+
+ use Test::More tests => x + 1;
+ use Test::NoWarnings;
+
+=head1 DESCRIPTION
+
+In general, your tests shouldn't produce warnings. This modules causes any
+warnings to be captured and stored. It automatically adds an extra test that
+will run when your script ends to check that there were no warnings. If
+there were any warings, the test will give a "not ok" and diagnostics of
+where, when and what the warning was, including a stack trace of what was
+going on when the it occurred.
+
+If some of your tests B<are supposed to> produce warnings then you should be
+capturing and checking them with L<Test::Warn>, that way L<Test::NoWarnings>
+will not see them and so not complain.
+
+The test is run by an END block in Test::NoWarnings. It will not be run when
+any forked children exit.
+
+=head1 USAGE
+
+Simply by using the module, you automatically get an extra test at the end
+of your script that checks that no warnings were emitted. So just stick
+
+ use Test::NoWarnings
+
+at the top of your script and continue as normal.
+
+If you want more control you can invoke the test manually at any time with
+C<had_no_warnings()>.
+
+The warnings your test has generated so far are stored in an array. You can
+look inside and clear this whenever you want with C<warnings()> and
+C<clear_warnings()>, however, if you are doing this sort of thing then you
+probably want to use L<Test::Warn> in combination with L<Test::NoWarnings>.
+
+=head1 USE vs REQUIRE
+
+You will almost always want to do
+
+ use Test::NoWarnings
+
+If you do a C<require> rather than a C<use>, then there will be no automatic
+test at the end of your script.
+
+=head1 OUTPUT
+
+If warning is captured during your test then the details will output as part
+of the diagnostics. You will get:
+
+=over 2
+
+=item o
+
+the number and name of the test that was executed just before the warning
+(if no test had been executed these will be 0 and '')
+
+=item o
+
+the message passed to C<warn>,
+
+=item o
+
+a full dump of the stack when warn was called, courtesy of the C<Carp>
+module
+
+=back
+
+=head1 EXPORTABLE FUNCTIONS
+
+=head2 had_no_warnings()
+
+This checks that there have been warnings emitted by your test scripts.
+Usually you will not call this explicitly as it is called automatically when
+your script finishes.
+
+=head2 clear_warnings()
+
+This will clear the array of warnings that have been captured. If the array
+is empty then a call to C<had_no_warnings()> will produce a pass result.
+
+=head2 warnings()
+
+This will return the array of warnings captured so far. Each element of this
+array is an object containing information about the warning. The following
+methods are available on these object.
+
+=over 2
+
+=item *
+
+$warn-E<gt>getMessage
+
+Get the message that would been printed by the warning.
+
+=item *
+
+$warn-E<gt>getCarp
+
+Get a stack trace of what was going on when the warning happened, this stack
+trace is just a string generated by the L<Carp> module.
+
+=item *
+
+$warn-E<gt>getTrace
+
+Get a stack trace object generated by the L<Devel::StackTrace> module. This
+will return undef if L<Devel::StackTrace> is not installed.
+
+=item *
+
+$warn-E<gt>getTest
+
+Get the number of the test that executed before the warning was emitted.
+
+=item *
+
+$warn-E<gt>getTestName
+
+Get the name of the test that executed before the warning was emitted.
+
+=back
+
+=head1 PITFALLS
+
+When counting your tests for the plan, don't forget to include the test that
+runs automatically when your script ends.
+
+=head1 BUGS
+
+None that I know of.
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-NoWarnings>
+
+For other issues, contact the author.
+
+=head1 HISTORY
+
+This was previously known as L<Test::Warn::None>
+
+=head1 SEE ALSO
+
+L<Test::Builder>, L<Test::Warn>
+
+=head1 AUTHORS
+
+Fergal Daly E<lt>fergal@esatclear.ieE<gt>
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2003 - 2007 Fergal Daly.
+
+Some parts copyright 2010 Adam Kennedy.
+
+This program is free software and comes with no warranty. It is distributed
+under the LGPL license
+
+See the file F<LGPL> included in this distribution or
+F<http://www.fsf.org/licenses/licenses.html>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings/Warning.pm b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings/Warning.pm
new file mode 100755
index 00000000000..54db0bba71e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings/Warning.pm
@@ -0,0 +1,79 @@
+package Test::NoWarnings::Warning;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.01';
+}
+
+my $STACKTRACE = eval "require Devel::StackTrace" || 0;
+
+sub new {
+ my $class = shift;
+ bless { @_ }, $class;
+}
+
+sub getTrace {
+ my $self = shift;
+ return $self->{Trace};
+}
+
+sub fillTrace {
+ my $self = shift;
+ $self->{Trace} = Devel::StackTrace->new(
+ ignore_class => [__PACKAGE__, @_],
+ ) if $STACKTRACE;
+}
+
+sub getCarp {
+ $_[0]->{Carp};
+}
+
+sub fillCarp {
+ my $self = shift;
+ my $msg = shift;
+ $Carp::Internal{ __PACKAGE__ . "" }++;
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ $self->{Carp} = Carp::longmess($msg);
+ $Carp::Internal{ __PACKAGE__ . "" }--;
+}
+
+sub getMessage {
+ $_[0]->{Message};
+}
+
+sub setMessage {
+ $_[0]->{Message} = $_[1];
+}
+
+sub fillTest {
+ my $self = shift;
+ my $builder = shift;
+ my $prev_test = $builder->current_test;
+ $self->{Test} = $prev_test;
+ my @tests = $builder->details;
+ my $prev_test_name = $prev_test ? $tests[$prev_test - 1]->{name} : "";
+ $self->{TestName} = $prev_test_name;
+}
+
+sub getTest {
+ $_[0]->{Test};
+}
+
+sub getTestName {
+ $_[0]->{TestName};
+}
+
+sub toString {
+ my $self = shift;
+ return <<EOM;
+ Previous test $self->{Test} '$self->{TestName}'
+ $self->{Carp}
+EOM
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Script.pm b/Master/tlpkg/tlperl.straw/lib/Test/Script.pm
new file mode 100755
index 00000000000..734afecce71
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Script.pm
@@ -0,0 +1,238 @@
+package Test::Script;
+
+=pod
+
+=head1 NAME
+
+Test::Script - Basic cross-platform tests for scripts
+
+=head1 DESCRIPTION
+
+The intent of this module is to provide a series of basic tests for 80%
+of the testing you will need to do for scripts in the F<script> (or F<bin>
+as is also commonly used) paths of your Perl distribution.
+
+Further, it aims to provide this functionality with perfect
+platform-compatibility, and in a way that is as unobtrusive as possible.
+
+That is, if the program works on a platform, then B<Test::Script>
+should always work on that platform as well. Anything less than 100% is
+considered unacceptable.
+
+In doing so, it is hoped that B<Test::Script> can become a module that
+you can safely make a dependency of all your modules, without risking that
+your module won't on some platform because of the dependency.
+
+Where a clash exists between wanting more functionality and maintaining
+platform safety, this module will err on the side of platform safety.
+
+=head1 FUNCTIONS
+
+=cut
+
+use 5.005;
+use strict;
+use Carp ();
+use Exporter ();
+use File::Spec ();
+use File::Spec::Unix ();
+use Probe::Perl ();
+use IPC::Run3 ();
+use Test::Builder ();
+
+use vars qw{$VERSION @ISA @EXPORT};
+BEGIN {
+ $VERSION = '1.07';
+ @ISA = 'Exporter';
+ @EXPORT = qw{
+ script_compiles
+ script_compiles_ok
+ script_runs
+ };
+}
+
+sub import {
+ my $self = shift;
+ my $pack = caller;
+ my $test = Test::Builder->new;
+ $test->exported_to($pack);
+ $test->plan(@_);
+ foreach ( @EXPORT ) {
+ $self->export_to_level(1, $self, $_);
+ }
+}
+
+my $perl = undef;
+
+sub perl () {
+ $perl or
+ $perl = Probe::Perl->find_perl_interpreter;
+}
+
+sub path ($) {
+ my $path = shift;
+ unless ( defined $path ) {
+ Carp::croak("Did not provide a script name");
+ }
+ if ( File::Spec::Unix->file_name_is_absolute($path) ) {
+ Carp::croak("Script name must be relative");
+ }
+ File::Spec->catfile(
+ File::Spec->curdir,
+ split /\//, $path
+ );
+}
+
+
+
+
+
+#####################################################################
+# Test Functions
+
+=pod
+
+=head2 script_compiles
+
+ script_compiles( 'script/foo.pl', 'Main script compiles' );
+
+The C<script_compiles> test calls the script with "perl -c script.pl",
+and checks that it returns without error.
+
+The path it should be passed is a relative unix-format script name. This
+will be localised when running C<perl -c> and if the test fails the local
+name used will be shown in the diagnostic output.
+
+Note also that the test will be run with the same L<perl> interpreter that
+is running the test script (and not with the default system perl). This
+will also be shown in the diagnostic output on failure.
+
+=cut
+
+sub script_compiles {
+ my $args = _script(shift);
+ my $unix = shift @$args;
+ my $path = path( $unix );
+ my $cmd = [ perl, '-Mblib', '-c', $path, @$args ];
+ my $stdin = '';
+ my $stdout = '';
+ my $stderr = '';
+ my $rv = IPC::Run3::run3( $cmd, \$stdin, \$stdout, \$stderr );
+ my $exit = $? ? ($? >> 8) : 0;
+ my $ok = !! (
+ $rv and $exit == 0 and $stderr =~ /syntax OK\s+\z/si
+ );
+
+ my $test = Test::Builder->new;
+ $test->ok( $ok, $_[0] || "Script $unix compiles" );
+ $test->diag( "$exit - $stderr" ) unless $ok;
+
+ return $ok;
+}
+
+=pod
+
+=head2 script_runs
+
+ script_runs( 'script/foo.pl', 'Main script runs' );
+
+The C<script_runs> test executes the script with "perl script.pl" and checks
+that it returns success.
+
+The path it should be passed is a relative unix-format script name. This
+will be localised when running C<perl -c> and if the test fails the local
+name used will be shown in the diagnostic output.
+
+The test will be run with the same L<perl> interpreter that is running the
+test script (and not with the default system perl). This will also be shown
+in the diagnostic output on failure.
+
+=cut
+
+sub script_runs {
+ my $args = _script(shift);
+ my $unix = shift @$args;
+ my $path = path( $unix );
+ my $cmd = [ perl, '-Mblib', $path, @$args ];
+ my $stdin = '';
+ my $stdout = '';
+ my $stderr = '';
+ my $rv = IPC::Run3::run3( $cmd, \$stdin, \$stdout, \$stderr );
+ my $exit = $? ? ($? >> 8) : 0;
+ my $ok = !! ( $rv and $exit == 0 );
+
+ my $test = Test::Builder->new;
+ $test->ok( $ok, $_[0] || "Script $unix runs" );
+ $test->diag( "$exit - $stderr" ) unless $ok;
+
+ return $ok;
+}
+
+
+
+
+
+######################################################################
+# Support Functions
+
+# Script params must be either a simple non-null string with the script
+# name, or an array reference with one or more non-null strings.
+sub _script {
+ my $in = shift;
+ if ( defined _STRING($in) ) {
+ return [ $in ];
+ }
+ if ( _ARRAY($in) ) {
+ unless ( scalar grep { not defined _STRING($_) } @$in ) {
+ return $in;
+ }
+ }
+ Carp::croak("Invalid command parameter");
+}
+
+# Inline some basic Params::Util functions
+
+sub _ARRAY ($) {
+ (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
+}
+
+sub _STRING ($) {
+ (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
+}
+
+BEGIN {
+ # Alias to old name
+ *script_compiles_ok = *script_compiles;
+}
+
+1;
+
+=pod
+
+=head1 SUPPORT
+
+All bugs should be filed via the bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Script>
+
+For other issues, or commercial enhancement and support, contact the author.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<prove>, L<http://ali.as/>
+
+=head1 COPYRIGHT
+
+Copyright 2006 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Simple.pm b/Master/tlpkg/tlperl.straw/lib/Test/Simple.pm
new file mode 100755
index 00000000000..9c8716759a4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Simple.pm
@@ -0,0 +1,214 @@
+package Test::Simple;
+
+use 5.006;
+
+use strict;
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Builder::Module;
+our @ISA = qw(Test::Builder::Module);
+our @EXPORT = qw(ok);
+
+my $CLASS = __PACKAGE__;
+
+=head1 NAME
+
+Test::Simple - Basic utilities for writing tests.
+
+=head1 SYNOPSIS
+
+ use Test::Simple tests => 1;
+
+ ok( $foo eq $bar, 'foo is bar' );
+
+
+=head1 DESCRIPTION
+
+** If you are unfamiliar with testing B<read Test::Tutorial> first! **
+
+This is an extremely simple, extremely basic module for writing tests
+suitable for CPAN modules and other pursuits. If you wish to do more
+complicated testing, use the Test::More module (a drop-in replacement
+for this one).
+
+The basic unit of Perl testing is the ok. For each thing you want to
+test your program will print out an "ok" or "not ok" to indicate pass
+or fail. You do this with the ok() function (see below).
+
+The only other constraint is you must pre-declare how many tests you
+plan to run. This is in case something goes horribly wrong during the
+test and your test program aborts, or skips a test or whatever. You
+do this like so:
+
+ use Test::Simple tests => 23;
+
+You must have a plan.
+
+
+=over 4
+
+=item B<ok>
+
+ ok( $foo eq $bar, $name );
+ ok( $foo eq $bar );
+
+ok() is given an expression (in this case C<$foo eq $bar>). If it's
+true, the test passed. If it's false, it didn't. That's about it.
+
+ok() prints out either "ok" or "not ok" along with a test number (it
+keeps track of that for you).
+
+ # This produces "ok 1 - Hell not yet frozen over" (or not ok)
+ ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
+
+If you provide a $name, that will be printed along with the "ok/not
+ok" to make it easier to find your test when if fails (just search for
+the name). It also makes it easier for the next guy to understand
+what your test is for. It's highly recommended you use test names.
+
+All tests are run in scalar context. So this:
+
+ ok( @stuff, 'I have some stuff' );
+
+will do what you mean (fail if stuff is empty)
+
+=cut
+
+sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
+ return $CLASS->builder->ok(@_);
+}
+
+=back
+
+Test::Simple will start by printing number of tests run in the form
+"1..M" (so "1..5" means you're going to run 5 tests). This strange
+format lets Test::Harness know how many tests you plan on running in
+case something goes horribly wrong.
+
+If all your tests passed, Test::Simple will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Simple
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+This module is by no means trying to be a complete testing system.
+It's just to get you started. Once you're off the ground its
+recommended you look at L<Test::More>.
+
+
+=head1 EXAMPLE
+
+Here's an example of a simple .t file for the fictional Film module.
+
+ use Test::Simple tests => 5;
+
+ use Film; # What you're testing.
+
+ my $btaste = Film->new({ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 1
+ });
+ ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' );
+
+ ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
+ ok( $btaste->Director eq 'Peter Jackson', 'Director() get' );
+ ok( $btaste->Rating eq 'R', 'Rating() get' );
+ ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
+
+It will produce output like this:
+
+ 1..5
+ ok 1 - new() works
+ ok 2 - Title() get
+ ok 3 - Director() get
+ not ok 4 - Rating() get
+ # Failed test 'Rating() get'
+ # in t/film.t at line 14.
+ ok 5 - NumExplodingSheep() get
+ # Looks like you failed 1 tests of 5
+
+Indicating the Film::Rating() method is broken.
+
+
+=head1 CAVEATS
+
+Test::Simple will only report a maximum of 254 failures in its exit
+code. If this is a problem, you probably have a huge test script.
+Split it into multiple files. (Otherwise blame the Unix folks for
+using an unsigned short integer as the exit status).
+
+Because VMS's exit codes are much, much different than the rest of the
+universe, and perl does horrible mangling to them that gets in my way,
+it works like this on VMS.
+
+ 0 SS$_NORMAL all tests successful
+ 4 SS$_ABORT something went wrong
+
+Unfortunately, I can't differentiate any further.
+
+
+=head1 NOTES
+
+Test::Simple is B<explicitly> tested all the way back to perl 5.6.0.
+
+Test::Simple is thread-safe in perl 5.8.1 and up.
+
+=head1 HISTORY
+
+This module was conceived while talking with Tony Bowden in his
+kitchen one night about the problems I was having writing some really
+complicated feature into the new Testing module. He observed that the
+main problem is not dealing with these edge cases but that people hate
+to write tests B<at all>. What was needed was a dead simple module
+that took all the hard work out of testing and was really, really easy
+to learn. Paul Johnson simultaneously had this idea (unfortunately,
+he wasn't in Tony's kitchen). This is it.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Test::More>
+
+More testing functions! Once you outgrow Test::Simple, look at
+Test::More. Test::Simple is 100% forward compatible with Test::More
+(i.e. you can just use Test::More instead of Test::Simple in your
+programs and things will still work).
+
+=back
+
+Look in Test::More's SEE ALSO for more testing modules.
+
+
+=head1 AUTHORS
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester.pm
new file mode 100755
index 00000000000..fd0d7a399ae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester.pm
@@ -0,0 +1,645 @@
+use strict;
+
+package Test::Tester;
+
+BEGIN
+{
+ if (*Test::Builder::new{CODE})
+ {
+ warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)"
+ }
+}
+
+use Test::Builder;
+use Test::Tester::CaptureRunner;
+use Test::Tester::Delegate;
+
+require Exporter;
+
+use vars qw( @ISA @EXPORT $VERSION );
+
+$VERSION = "0.107";
+@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
+@ISA = qw( Exporter );
+
+my $Test = Test::Builder->new;
+my $Capture = Test::Tester::Capture->new;
+my $Delegator = Test::Tester::Delegate->new;
+$Delegator->{Object} = $Test;
+
+my $runner = Test::Tester::CaptureRunner->new;
+
+my $want_space = $ENV{TESTTESTERSPACE};
+
+sub show_space
+{
+ $want_space = 1;
+}
+
+my $colour = '';
+my $reset = '';
+
+if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR})
+{
+ if (eval "require Term::ANSIColor")
+ {
+ my ($f, $b) = split(",", $want_colour);
+ $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b");
+ $reset = Term::ANSIColor::color("reset");
+ }
+
+}
+
+sub new_new
+{
+ return $Delegator;
+}
+
+sub capture
+{
+ return Test::Tester::Capture->new;
+}
+
+sub fh
+{
+ # experiment with capturing output, I don't like it
+ $runner = Test::Tester::FHRunner->new;
+
+ return $Test;
+}
+
+sub find_run_tests
+{
+ my $d = 1;
+ my $found = 0;
+ while ((not $found) and (my ($sub) = (caller($d))[3]) )
+ {
+# print "$d: $sub\n";
+ $found = ($sub eq "Test::Tester::run_tests");
+ $d++;
+ }
+
+# die "Didn't find 'run_tests' in caller stack" unless $found;
+ return $d;
+}
+
+sub run_tests
+{
+ local($Delegator->{Object}) = $Capture;
+
+ $runner->run_tests(@_);
+
+ return ($runner->get_premature, $runner->get_results);
+}
+
+sub check_test
+{
+ my $test = shift;
+ my $expect = shift;
+ my $name = shift;
+ $name = "" unless defined($name);
+
+ @_ = ($test, [$expect], $name);
+ goto &check_tests;
+}
+
+sub check_tests
+{
+ my $test = shift;
+ my $expects = shift;
+ my $name = shift;
+ $name = "" unless defined($name);
+
+ my ($prem, @results) = eval { run_tests($test, $name) };
+
+ $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@);
+ $Test->ok(! length($prem), "Test '$name' no premature diagnostication") ||
+ $Test->diag("Before any testing anything, your tests said\n$prem");
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ cmp_results(\@results, $expects, $name);
+ return ($prem, @results);
+}
+
+sub cmp_field
+{
+ my ($result, $expect, $field, $desc) = @_;
+
+ if (defined $expect->{$field})
+ {
+ $Test->is_eq($result->{$field}, $expect->{$field},
+ "$desc compare $field");
+ }
+}
+
+sub cmp_result
+{
+ my ($result, $expect, $name) = @_;
+
+ my $sub_name = $result->{name};
+ $sub_name = "" unless defined($name);
+
+ my $desc = "subtest '$sub_name' of '$name'";
+
+ {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ cmp_field($result, $expect, "ok", $desc);
+
+ cmp_field($result, $expect, "actual_ok", $desc);
+
+ cmp_field($result, $expect, "type", $desc);
+
+ cmp_field($result, $expect, "reason", $desc);
+
+ cmp_field($result, $expect, "name", $desc);
+ }
+
+ # if we got no depth then default to 1
+ my $depth = 1;
+ if (exists $expect->{depth})
+ {
+ $depth = $expect->{depth};
+ }
+
+ # if depth was explicitly undef then don't test it
+ if (defined $depth)
+ {
+ $Test->is_eq($result->{depth}, $depth, "checking depth") ||
+ $Test->diag('You need to change $Test::Builder::Level');
+ }
+
+ if (defined(my $exp = $expect->{diag}))
+ {
+ # if there actually is some diag then put a \n on the end if it's not
+ # there already
+
+ $exp .= "\n" if (length($exp) and $exp !~ /\n$/);
+ if (not $Test->ok($result->{diag} eq $exp,
+ "subtest '$sub_name' of '$name' compare diag")
+ )
+ {
+ my $got = $result->{diag};
+ my $glen = length($got);
+ my $elen = length($exp);
+ for ($got, $exp)
+ {
+ my @lines = split("\n", $_);
+ $_ = join("\n", map {
+ if ($want_space)
+ {
+ $_ = $colour.escape($_).$reset;
+ }
+ else
+ {
+ "'$colour$_$reset'"
+ }
+ } @lines);
+ }
+
+ $Test->diag(<<EOM);
+Got diag ($glen bytes):
+$got
+Expected diag ($elen bytes):
+$exp
+EOM
+
+ }
+ }
+}
+
+sub escape
+{
+ my $str = shift;
+ my $res = '';
+ for my $char (split("", $str))
+ {
+ my $c = ord($char);
+ if(($c>32 and $c<125) or $c == 10)
+ {
+ $res .= $char;
+ }
+ else
+ {
+ $res .= sprintf('\x{%x}', $c)
+ }
+ }
+ return $res;
+}
+
+sub cmp_results
+{
+ my ($results, $expects, $name) = @_;
+
+ $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count");
+
+ for (my $i = 0; $i < @$expects; $i++)
+ {
+ my $expect = $expects->[$i];
+ my $result = $results->[$i];
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ cmp_result($result, $expect, $name);
+ }
+}
+
+######## nicked from Test::More
+sub plan {
+ my(@plan) = @_;
+
+ my $caller = caller;
+
+ $Test->exported_to($caller);
+
+ my @imports = ();
+ foreach my $idx (0..$#plan) {
+ if( $plan[$idx] eq 'import' ) {
+ my($tag, $imports) = splice @plan, $idx, 2;
+ @imports = @$imports;
+ last;
+ }
+ }
+
+ $Test->plan(@plan);
+
+ __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+}
+
+sub import {
+ my($class) = shift;
+ {
+ no warnings 'redefine';
+ *Test::Builder::new = \&new_new;
+ }
+ goto &plan;
+}
+
+sub _export_to_level
+{
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+
+############
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Tester - Ease testing test modules built with Test::Builder
+
+=head1 SYNOPSIS
+
+ use Test::Tester tests => 6;
+
+ use Test::MyStyle;
+
+ check_test(
+ sub {
+ is_mystyle_eq("this", "that", "not eq");
+ },
+ {
+ ok => 0, # expect this to fail
+ name => "not eq",
+ diag => "Expected: 'this'\nGot: 'that'",
+ }
+ );
+
+or
+
+ use Test::Tester;
+
+ use Test::More tests => 3;
+ use Test::MyStyle;
+
+ my ($premature, @results) = run_tests(
+ sub {
+ is_database_alive("dbname");
+ }
+ );
+
+ # now use Test::More::like to check the diagnostic output
+
+ like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
+
+=head1 DESCRIPTION
+
+If you have written a test module based on Test::Builder then Test::Tester
+allows you to test it with the minimum of effort.
+
+=head1 HOW TO USE (THE EASY WAY)
+
+From version 0.08 Test::Tester no longer requires you to included anything
+special in your test modules. All you need to do is
+
+ use Test::Tester;
+
+in your test script B<before> any other Test::Builder based modules and away
+you go.
+
+Other modules based on Test::Builder can be used to help with the
+testing. In fact you can even use functions from your module to test
+other functions from the same module (while this is possible it is
+probably not a good idea, if your module has bugs, then
+using it to test itself may give the wrong answers).
+
+The easiest way to test is to do something like
+
+ check_test(
+ sub { is_mystyle_eq("this", "that", "not eq") },
+ {
+ ok => 0, # we expect the test to fail
+ name => "not eq",
+ diag => "Expected: 'this'\nGot: 'that'",
+ }
+ );
+
+this will execute the is_mystyle_eq test, capturing it's results and
+checking that they are what was expected.
+
+You may need to examine the test results in a more flexible way, for
+example, the diagnostic output may be quite long or complex or it may involve
+something that you cannot predict in advance like a timestamp. In this case
+you can get direct access to the test results:
+
+ my ($premature, @results) = run_tests(
+ sub {
+ is_database_alive("dbname");
+ }
+ );
+
+ like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
+
+
+We cannot predict how long the database ping will take so we use
+Test::More's like() test to check that the diagnostic string is of the right
+form.
+
+=head1 HOW TO USE (THE HARD WAY)
+
+I<This is here for backwards compatibility only>
+
+Make your module use the Test::Tester::Capture object instead of the
+Test::Builder one. How to do this depends on your module but assuming that
+your module holds the Test::Builder object in $Test and that all your test
+routines access it through $Test then providing a function something like this
+
+ sub set_builder
+ {
+ $Test = shift;
+ }
+
+should allow your test scripts to do
+
+ Test::YourModule::set_builder(Test::Tester->capture);
+
+and after that any tests inside your module will captured.
+
+=head1 TEST RESULTS
+
+The result of each test is captured in a hash. These hashes are the same as
+the hashes returned by Test::Builder->details but with a couple of extra
+fields.
+
+These fields are documented in L<Test::Builder> in the details() function
+
+=over 2
+
+=item ok
+
+Did the test pass?
+
+=item actual_ok
+
+Did the test really pass? That is, did the pass come from
+Test::Builder->ok() or did it pass because it was a TODO test?
+
+=item name
+
+The name supplied for the test.
+
+=item type
+
+What kind of test? Possibilities include, skip, todo etc. See
+L<Test::Builder> for more details.
+
+=item reason
+
+The reason for the skip, todo etc. See L<Test::Builder> for more details.
+
+=back
+
+These fields are exclusive to Test::Tester.
+
+=over 2
+
+=item diag
+
+Any diagnostics that were output for the test. This only includes
+diagnostics output B<after> the test result is declared.
+
+Note that Test::Builder ensures that any diagnostics end in a \n and
+it in earlier versions of Test::Tester it was essential that you have
+the final \n in your expected diagnostics. From version 0.10 onwards,
+Test::Tester will add the \n if you forgot it. It will not add a \n if
+you are expecting no diagnostics. See below for help tracking down
+hard to find space and tab related problems.
+
+=item depth
+
+This allows you to check that your test module is setting the correct value
+for $Test::Builder::Level and thus giving the correct file and line number
+when a test fails. It is calculated by looking at caller() and
+$Test::Builder::Level. It should count how many subroutines there are before
+jumping into the function you are testing. So for example in
+
+ run_tests( sub { my_test_function("a", "b") } );
+
+the depth should be 1 and in
+
+ sub deeper { my_test_function("a", "b") }
+
+ run_tests(sub { deeper() });
+
+depth should be 2, that is 1 for the sub {} and one for deeper(). This
+might seem a little complex but if your tests look like the simple
+examples in this doc then you don't need to worry as the depth will
+always be 1 and that's what Test::Tester expects by default.
+
+B<Note>: if you do not specify a value for depth in check_test() then it
+automatically compares it against 1, if you really want to skip the depth
+test then pass in undef.
+
+B<Note>: depth will not be correctly calculated for tests that run from a
+signal handler or an END block or anywhere else that hides the call stack.
+
+=back
+
+Some of Test::Tester's functions return arrays of these hashes, just
+like Test::Builder->details. That is, the hash for the first test will
+be array element 1 (not 0). Element 0 will not be a hash it will be a
+string which contains any diagnostic output that came before the first
+test. This should usually be empty, if it's not, it means something
+output diagnostics before any test results showed up.
+
+=head1 SPACES AND TABS
+
+Appearances can be deceptive, especially when it comes to emptiness. If you
+are scratching your head trying to work out why Test::Tester is saying that
+your diagnostics are wrong when they look perfectly right then the answer is
+probably whitespace. From version 0.10 on, Test::Tester surrounds the
+expected and got diag values with single quotes to make it easier to spot
+trailing whitesapce. So in this example
+
+ # Got diag (5 bytes):
+ # 'abcd '
+ # Expected diag (4 bytes):
+ # 'abcd'
+
+it is quite clear that there is a space at the end of the first string.
+Another way to solve this problem is to use colour and inverse video on an
+ANSI terminal, see below COLOUR below if you want this.
+
+Unfortunately this is sometimes not enough, neither colour nor quotes will
+help you with problems involving tabs, other non-printing characters and
+certain kinds of problems inherent in Unicode. To deal with this, you can
+switch Test::Tester into a mode whereby all "tricky" characters are shown as
+\{xx}. Tricky characters are those with ASCII code less than 33 or higher
+than 126. This makes the output more difficult to read but much easier to
+find subtle differences between strings. To turn on this mode either call
+show_space() in your test script or set the TESTTESTERSPACE environment
+variable to be a true value. The example above would then look like
+
+ # Got diag (5 bytes):
+ # abcd\x{20}
+ # Expected diag (4 bytes):
+ # abcd
+
+=head1 COLOUR
+
+If you prefer to use colour as a means of finding tricky whitespace
+characters then you can set the TESTTESTCOLOUR environment variable to a
+comma separated pair of colours, the first for the foreground, the second
+for the background. For example "white,red" will print white text on a red
+background. This requires the Term::ANSIColor module. You can specify any
+colour that would be acceptable to the Term::ANSIColor::color function.
+
+If you spell colour differently, that's no problem. The TESTTESTERCOLOR
+variable also works (if both are set then the British spelling wins out).
+
+=head1 EXPORTED FUNCTIONS
+
+=head3 ($premature, @results) = run_tests(\&test_sub)
+
+\&test_sub is a reference to a subroutine.
+
+run_tests runs the subroutine in $test_sub and captures the results of any
+tests inside it. You can run more than 1 test inside this subroutine if you
+like.
+
+$premature is a string containing any diagnostic output from before
+the first test.
+
+@results is an array of test result hashes.
+
+=head3 cmp_result(\%result, \%expect, $name)
+
+\%result is a ref to a test result hash.
+
+\%expect is a ref to a hash of expected values for the test result.
+
+cmp_result compares the result with the expected values. If any differences
+are found it outputs diagnostics. You may leave out any field from the
+expected result and cmp_result will not do the comparison of that field.
+
+=head3 cmp_results(\@results, \@expects, $name)
+
+\@results is a ref to an array of test results.
+
+\@expects is a ref to an array of hash refs.
+
+cmp_results checks that the results match the expected results and if any
+differences are found it outputs diagnostics. It first checks that the
+number of elements in \@results and \@expects is the same. Then it goes
+through each result checking it against the expected result as in
+cmp_result() above.
+
+=head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name)
+
+\&test_sub is a reference to a subroutine.
+
+\@expect is a ref to an array of hash refs which are expected test results.
+
+check_tests combines run_tests and cmp_tests into a single call. It also
+checks if the tests died at any stage.
+
+It returns the same values as run_tests, so you can further examine the test
+results if you need to.
+
+=head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name)
+
+\&test_sub is a reference to a subroutine.
+
+\%expect is a ref to an hash of expected values for the test result.
+
+check_test is a wrapper around check_tests. It combines run_tests and
+cmp_tests into a single call, checking if the test died. It assumes
+that only a single test is run inside \&test_sub and include a test to
+make sure this is true.
+
+It returns the same values as run_tests, so you can further examine the test
+results if you need to.
+
+=head3 show_space()
+
+Turn on the escaping of characters as described in the SPACES AND TABS
+section.
+
+=head1 HOW IT WORKS
+
+Normally, a test module (let's call it Test:MyStyle) calls
+Test::Builder->new to get the Test::Builder object. Test::MyStyle calls
+methods on this object to record information about test results. When
+Test::Tester is loaded, it replaces Test::Builder's new() method with one
+which returns a Test::Tester::Delegate object. Most of the time this object
+behaves as the real Test::Builder object. Any methods that are called are
+delegated to the real Test::Builder object so everything works perfectly.
+However once we go into test mode, the method calls are no longer passed to
+the real Test::Builder object, instead they go to the Test::Tester::Capture
+object. This object seems exactly like the real Test::Builder object,
+except, instead of outputting test results and diagnostics, it just records
+all the information for later analysis.
+
+=head1 SEE ALSO
+
+L<Test::Builder> the source of testing goodness. L<Test::Builder::Tester>
+for an alternative approach to the problem tackled by Test::Tester -
+captures the strings output by Test::Builder. This means you cannot get
+separate access to the individual pieces of information and you must predict
+B<exactly> what your test will output.
+
+=head1 AUTHOR
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Plan handling lifted from Test::More. written by Michael G Schwern
+<schwern@pobox.com>.
+
+Test::Tester::Capture is a cut down and hacked up version of Test::Builder.
+Test::Builder was written by chromatic <chromatic@wgz.org> and Michael G
+Schwern <schwern@pobox.com>.
+
+=head1 LICENSE
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester/Capture.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Capture.pm
new file mode 100755
index 00000000000..b1b4de69c75
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Capture.pm
@@ -0,0 +1,223 @@
+use strict;
+
+package Test::Tester::Capture;
+
+use Test::Builder;
+
+use vars qw( @ISA );
+@ISA = qw( Test::Builder );
+
+# Make Test::Tester::Capture thread-safe for ithreads.
+BEGIN {
+ use Config;
+ if( $] >= 5.008 && $Config{useithreads} ) {
+ require threads;
+ require threads::shared;
+ threads::shared->import;
+ }
+ else {
+ *share = sub { 0 };
+ *lock = sub { 0 };
+ }
+}
+
+my $Curr_Test = 0; share($Curr_Test);
+my @Test_Results = (); share(@Test_Results);
+my $Prem_Diag = {diag => ""}; share($Curr_Test);
+
+sub new
+{
+ # Test::Tester::Capgture::new used to just return __PACKAGE__
+ # because Test::Builder::new enforced it's singleton nature by
+ # return __PACKAGE__. That has since changed, Test::Builder::new now
+ # returns a blessed has and around version 0.78, Test::Builder::todo
+ # started wanting to modify $self. To cope with this, we now return
+ # a blessed hash. This is a short-term hack, the correct thing to do
+ # is to detect which style of Test::Builder we're dealing with and
+ # act appropriately.
+
+ my $class = shift;
+ return bless {}, $class;
+}
+
+sub ok {
+ my($self, $test, $name) = @_;
+
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ lock $Curr_Test;
+ $Curr_Test++;
+
+ my($pack, $file, $line) = $self->caller;
+
+ my $todo = $self->todo($pack);
+
+ my $result = {};
+ share($result);
+
+ unless( $test ) {
+ @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ if( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if( $todo ) {
+ my $what_todo = $todo;
+ $result->{reason} = $what_todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $Test_Results[$Curr_Test-1] = $result;
+
+ unless( $test ) {
+ my $msg = $todo ? "Failed (TODO)" : "Failed";
+ $result->{fail_diag} = (" $msg test ($file at line $line)\n");
+ }
+
+ $result->{diag} = "";
+ $result->{_level} = $Test::Builder::Level;
+ $result->{_depth} = Test::Tester::find_run_tests();
+
+ return $test ? 1 : 0;
+}
+
+sub skip {
+ my($self, $why) = @_;
+ $why ||= '';
+
+ lock($Curr_Test);
+ $Curr_Test++;
+
+ my %result;
+ share(%result);
+ %result = (
+ 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ diag => "",
+ _level => $Test::Builder::Level,
+ _depth => Test::Tester::find_run_tests(),
+ );
+ $Test_Results[$Curr_Test-1] = \%result;
+
+ return 1;
+}
+
+sub todo_skip {
+ my($self, $why) = @_;
+ $why ||= '';
+
+ lock($Curr_Test);
+ $Curr_Test++;
+
+ my %result;
+ share(%result);
+ %result = (
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ diag => "",
+ _level => $Test::Builder::Level,
+ _depth => Test::Tester::find_run_tests(),
+ );
+
+ $Test_Results[$Curr_Test-1] = \%result;
+
+ return 1;
+}
+
+sub diag {
+ my($self, @msgs) = @_;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Escape each line with a #.
+ foreach (@msgs) {
+ $_ = 'undef' unless defined;
+ }
+
+ push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
+ my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag;
+
+ $result->{diag} .= join("", @msgs);
+
+ return 0;
+}
+
+sub details {
+ return @Test_Results;
+}
+
+sub premature
+{
+ return $Prem_Diag->{diag};
+}
+
+sub current_test
+{
+ if (@_ > 1)
+ {
+ die "Don't try to change the test number!";
+ }
+ else
+ {
+ return $Curr_Test;
+ }
+}
+
+sub reset
+{
+ $Curr_Test = 0;
+ @Test_Results = ();
+ $Prem_Diag = {diag => ""};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Tester::Capture - Help testing test modules built with Test::Builder
+
+=head1 DESCRIPTION
+
+This is a subclass of Test::Builder that overrides many of the methods so
+that they don't output anything. It also keeps track of it's own set of test
+results so that you can use Test::Builder based modules to perform tests on
+other Test::Builder based modules.
+
+=head1 AUTHOR
+
+Most of the code here was lifted straight from Test::Builder and then had
+chunks removed by Fergal Daly <fergal@esatclear.ie>.
+
+=head1 LICENSE
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester/CaptureRunner.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester/CaptureRunner.pm
new file mode 100755
index 00000000000..f14a4c145aa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester/CaptureRunner.pm
@@ -0,0 +1,76 @@
+# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $
+use strict;
+
+package Test::Tester::CaptureRunner;
+
+use Test::Tester::Capture;
+require Exporter;
+
+sub new
+{
+ my $pkg = shift;
+ my $self = bless {}, $pkg;
+ return $self;
+}
+
+sub run_tests
+{
+ my $self = shift;
+
+ my $test = shift;
+
+ capture()->reset;
+
+ $self->{StartLevel} = $Test::Builder::Level;
+ &$test();
+}
+
+sub get_results
+{
+ my $self = shift;
+ my @results = capture()->details;
+
+ my $start = $self->{StartLevel};
+ foreach my $res (@results)
+ {
+ next if defined $res->{depth};
+ my $depth = $res->{_depth} - $res->{_level} - $start - 3;
+# print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n";
+ $res->{depth} = $depth;
+ }
+
+ return @results;
+}
+
+sub get_premature
+{
+ return capture()->premature;
+}
+
+sub capture
+{
+ return Test::Tester::Capture->new;
+}
+
+__END__
+
+=head1 NAME
+
+Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder
+
+=head1 DESCRIPTION
+
+This stuff if needed to allow me to play with other ways of monitoring the
+test results.
+
+=head1 AUTHOR
+
+Copyright 2003 by Fergal Daly <fergal@esatclear.ie>.
+
+=head1 LICENSE
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester/Delegate.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Delegate.pm
new file mode 100755
index 00000000000..7ddb921cdfc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Delegate.pm
@@ -0,0 +1,32 @@
+use strict;
+use warnings;
+
+package Test::Tester::Delegate;
+
+use vars '$AUTOLOAD';
+
+sub new
+{
+ my $pkg = shift;
+
+ my $obj = shift;
+ my $self = bless {}, $pkg;
+
+ return $self;
+}
+
+sub AUTOLOAD
+{
+ my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/;
+
+ return if $sub eq "DESTROY";
+
+ my $obj = $_[0]->{Object};
+
+ my $ref = $obj->can($sub);
+ shift(@_);
+ unshift(@_, $obj);
+ goto &$ref;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tutorial.pod b/Master/tlpkg/tlperl.straw/lib/Test/Tutorial.pod
new file mode 100755
index 00000000000..46ac467ddae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Tutorial.pod
@@ -0,0 +1,604 @@
+=head1 NAME
+
+Test::Tutorial - A tutorial about writing really basic tests
+
+=head1 DESCRIPTION
+
+
+I<AHHHHHHH!!!! NOT TESTING! Anything but testing!
+Beat me, whip me, send me to Detroit, but don't make
+me write tests!>
+
+I<*sob*>
+
+I<Besides, I don't know how to write the damned things.>
+
+
+Is this you? Is writing tests right up there with writing
+documentation and having your fingernails pulled out? Did you open up
+a test and read
+
+ ######## We start with some black magic
+
+and decide that's quite enough for you?
+
+It's ok. That's all gone now. We've done all the black magic for
+you. And here are the tricks...
+
+
+=head2 Nuts and bolts of testing.
+
+Here's the most basic test program.
+
+ #!/usr/bin/perl -w
+
+ print "1..1\n";
+
+ print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n";
+
+since 1 + 1 is 2, it prints:
+
+ 1..1
+ ok 1
+
+What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1>
+"The first test passed". And that's about all magic there is to
+testing. Your basic unit of testing is the I<ok>. For each thing you
+test, an C<ok> is printed. Simple. B<Test::Harness> interprets your test
+results to determine if you succeeded or failed (more on that later).
+
+Writing all these print statements rapidly gets tedious. Fortunately,
+there's B<Test::Simple>. It has one function, C<ok()>.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 1;
+
+ ok( 1 + 1 == 2 );
+
+and that does the same thing as the code above. C<ok()> is the backbone
+of Perl testing, and we'll be using it instead of roll-your-own from
+here on. If C<ok()> gets a true value, the test passes. False, it
+fails.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 2;
+ ok( 1 + 1 == 2 );
+ ok( 2 + 2 == 5 );
+
+from that comes
+
+ 1..2
+ ok 1
+ not ok 2
+ # Failed test (test.pl at line 5)
+ # Looks like you failed 1 tests of 2.
+
+C<1..2> "I'm going to run two tests." This number is used to ensure
+your test program ran all the way through and didn't die or skip some
+tests. C<ok 1> "The first test passed." C<not ok 2> "The second test
+failed". Test::Simple helpfully prints out some extra commentary about
+your tests.
+
+It's not scary. Come, hold my hand. We're going to give an example
+of testing a module. For our example, we'll be testing a date
+library, B<Date::ICal>. It's on CPAN, so download a copy and follow
+along. [2]
+
+
+=head2 Where to start?
+
+This is the hardest part of testing, where do you start? People often
+get overwhelmed at the apparent enormity of the task of testing a
+whole module. Best place to start is at the beginning. Date::ICal is
+an object-oriented module, and that means you start by making an
+object. So we test C<new()>.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 2;
+
+ use Date::ICal;
+
+ my $ical = Date::ICal->new; # create an object
+ ok( defined $ical ); # check that we got something
+ ok( $ical->isa('Date::ICal') ); # and it's the right class
+
+run that and you should get:
+
+ 1..2
+ ok 1
+ ok 2
+
+congratulations, you've written your first useful test.
+
+
+=head2 Names
+
+That output isn't terribly descriptive, is it? When you have two
+tests you can figure out which one is #2, but what if you have 102?
+
+Each test can be given a little descriptive name as the second
+argument to C<ok()>.
+
+ use Test::Simple tests => 2;
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+
+So now you'd see...
+
+ 1..2
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+
+
+=head2 Test the manual
+
+Simplest way to build up a decent testing suite is to just test what
+the manual says it does. [3] Let's pull something out of the
+L<Date::ICal/SYNOPSIS> and test that all its bits work.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 8;
+
+ use Date::ICal;
+
+ $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
+ hour => 16, min => 12, sec => 47,
+ tz => '0530' );
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+ ok( $ical->sec == 47, ' sec()' );
+ ok( $ical->min == 12, ' min()' );
+ ok( $ical->hour == 16, ' hour()' );
+ ok( $ical->day == 17, ' day()' );
+ ok( $ical->month == 10, ' month()' );
+ ok( $ical->year == 1964, ' year()' );
+
+run that and you get:
+
+ 1..8
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+ ok 3 - sec()
+ ok 4 - min()
+ ok 5 - hour()
+ not ok 6 - day()
+ # Failed test (- at line 16)
+ ok 7 - month()
+ ok 8 - year()
+ # Looks like you failed 1 tests of 8.
+
+Whoops, a failure! [4] Test::Simple helpfully lets us know on what line
+the failure occurred, but not much else. We were supposed to get 17,
+but we didn't. What did we get?? Dunno. We'll have to re-run the
+test in the debugger or throw in some print statements to find out.
+
+Instead, we'll switch from B<Test::Simple> to B<Test::More>. B<Test::More>
+does everything B<Test::Simple> does, and more! In fact, Test::More does
+things I<exactly> the way Test::Simple does. You can literally swap
+Test::Simple out and put Test::More in its place. That's just what
+we're going to do.
+
+Test::More does more than Test::Simple. The most important difference
+at this point is it provides more informative ways to say "ok".
+Although you can write almost any test with a generic C<ok()>, it
+can't tell you what went wrong. Instead, we'll use the C<is()>
+function, which lets us declare that something is supposed to be the
+same as something else:
+
+ #!/usr/bin/perl -w
+
+ use Test::More tests => 8;
+
+ use Date::ICal;
+
+ $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
+ hour => 16, min => 12, sec => 47,
+ tz => '0530' );
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+ is( $ical->sec, 47, ' sec()' );
+ is( $ical->min, 12, ' min()' );
+ is( $ical->hour, 16, ' hour()' );
+ is( $ical->day, 17, ' day()' );
+ is( $ical->month, 10, ' month()' );
+ is( $ical->year, 1964, ' year()' );
+
+"Is C<$ical-E<gt>sec> 47?" "Is C<$ical-E<gt>min> 12?" With C<is()> in place,
+you get some more information
+
+ 1..8
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+ ok 3 - sec()
+ ok 4 - min()
+ ok 5 - hour()
+ not ok 6 - day()
+ # Failed test (- at line 16)
+ # got: '16'
+ # expected: '17'
+ ok 7 - month()
+ ok 8 - year()
+ # Looks like you failed 1 tests of 8.
+
+letting us know that C<$ical-E<gt>day> returned 16, but we expected 17. A
+quick check shows that the code is working fine, we made a mistake
+when writing up the tests. Just change it to:
+
+ is( $ical->day, 16, ' day()' );
+
+and everything works.
+
+So any time you're doing a "this equals that" sort of test, use C<is()>.
+It even works on arrays. The test is always in scalar context, so you
+can test how many elements are in a list this way. [5]
+
+ is( @foo, 5, 'foo has 5 elements' );
+
+
+=head2 Sometimes the tests are wrong
+
+Which brings us to a very important lesson. Code has bugs. Tests are
+code. Ergo, tests have bugs. A failing test could mean a bug in the
+code, but don't discount the possibility that the test is wrong.
+
+On the flip side, don't be tempted to prematurely declare a test
+incorrect just because you're having trouble finding the bug.
+Invalidating a test isn't something to be taken lightly, and don't use
+it as a cop out to avoid work.
+
+
+=head2 Testing lots of values
+
+We're going to be wanting to test a lot of dates here, trying to trick
+the code with lots of different edge cases. Does it work before 1970?
+After 2038? Before 1904? Do years after 10,000 give it trouble?
+Does it get leap years right? We could keep repeating the code above,
+or we could set up a little try/expect loop.
+
+ use Test::More tests => 32;
+ use Date::ICal;
+
+ my %ICal_Dates = (
+ # An ICal string And the year, month, day
+ # hour, minute and second we expect.
+ '19971024T120000' => # from the docs.
+ [ 1997, 10, 24, 12, 0, 0 ],
+ '20390123T232832' => # after the Unix epoch
+ [ 2039, 1, 23, 23, 28, 32 ],
+ '19671225T000000' => # before the Unix epoch
+ [ 1967, 12, 25, 0, 0, 0 ],
+ '18990505T232323' => # before the MacOS epoch
+ [ 1899, 5, 5, 23, 23, 23 ],
+ );
+
+
+ while( my($ical_str, $expect) = each %ICal_Dates ) {
+ my $ical = Date::ICal->new( ical => $ical_str );
+
+ ok( defined $ical, "new(ical => '$ical_str')" );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+
+ is( $ical->year, $expect->[0], ' year()' );
+ is( $ical->month, $expect->[1], ' month()' );
+ is( $ical->day, $expect->[2], ' day()' );
+ is( $ical->hour, $expect->[3], ' hour()' );
+ is( $ical->min, $expect->[4], ' min()' );
+ is( $ical->sec, $expect->[5], ' sec()' );
+ }
+
+So now we can test bunches of dates by just adding them to
+C<%ICal_Dates>. Now that it's less work to test with more dates, you'll
+be inclined to just throw more in as you think of them.
+Only problem is, every time we add to that we have to keep adjusting
+the C<use Test::More tests =E<gt> ##> line. That can rapidly get
+annoying. There's two ways to make this work better.
+
+First, we can calculate the plan dynamically using the C<plan()>
+function.
+
+ use Test::More;
+ use Date::ICal;
+
+ my %ICal_Dates = (
+ ...same as before...
+ );
+
+ # For each key in the hash we're running 8 tests.
+ plan tests => keys(%ICal_Dates) * 8;
+
+ ...and then your tests...
+
+Or to be even more flexible, we use C<no_plan>. This means we're just
+running some tests, don't know how many. [6]
+
+ use Test::More 'no_plan'; # instead of tests => 32
+
+now we can just add tests and not have to do all sorts of math to
+figure out how many we're running.
+
+
+=head2 Informative names
+
+Take a look at this line here
+
+ ok( defined $ical, "new(ical => '$ical_str')" );
+
+we've added more detail about what we're testing and the ICal string
+itself we're trying out to the name. So you get results like:
+
+ ok 25 - new(ical => '19971024T120000')
+ ok 26 - and it's the right class
+ ok 27 - year()
+ ok 28 - month()
+ ok 29 - day()
+ ok 30 - hour()
+ ok 31 - min()
+ ok 32 - sec()
+
+if something in there fails, you'll know which one it was and that
+will make tracking down the problem easier. So try to put a bit of
+debugging information into the test names.
+
+Describe what the tests test, to make debugging a failed test easier
+for you or for the next person who runs your test.
+
+
+=head2 Skipping tests
+
+Poking around in the existing Date::ICal tests, I found this in
+F<t/01sanity.t> [7]
+
+ #!/usr/bin/perl -w
+
+ use Test::More tests => 7;
+ use Date::ICal;
+
+ # Make sure epoch time is being handled sanely.
+ my $t1 = Date::ICal->new( epoch => 0 );
+ is( $t1->epoch, 0, "Epoch time of 0" );
+
+ # XXX This will only work on unix systems.
+ is( $t1->ical, '19700101Z', " epoch to ical" );
+
+ is( $t1->year, 1970, " year()" );
+ is( $t1->month, 1, " month()" );
+ is( $t1->day, 1, " day()" );
+
+ # like the tests above, but starting with ical instead of epoch
+ my $t2 = Date::ICal->new( ical => '19700101Z' );
+ is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
+
+ is( $t2->epoch, 0, " and back to ICal" );
+
+The beginning of the epoch is different on most non-Unix operating
+systems [8]. Even though Perl smooths out the differences for the
+most part, certain ports do it differently. MacPerl is one off the
+top of my head. [9] So rather than just putting a comment in the test,
+we can explicitly say it's never going to work and skip the test.
+
+ use Test::More tests => 7;
+ use Date::ICal;
+
+ # Make sure epoch time is being handled sanely.
+ my $t1 = Date::ICal->new( epoch => 0 );
+ is( $t1->epoch, 0, "Epoch time of 0" );
+
+ SKIP: {
+ skip('epoch to ICal not working on MacOS', 6)
+ if $^O eq 'MacOS';
+
+ is( $t1->ical, '19700101Z', " epoch to ical" );
+
+ is( $t1->year, 1970, " year()" );
+ is( $t1->month, 1, " month()" );
+ is( $t1->day, 1, " day()" );
+
+ # like the tests above, but starting with ical instead of epoch
+ my $t2 = Date::ICal->new( ical => '19700101Z' );
+ is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
+
+ is( $t2->epoch, 0, " and back to ICal" );
+ }
+
+A little bit of magic happens here. When running on anything but
+MacOS, all the tests run normally. But when on MacOS, C<skip()> causes
+the entire contents of the SKIP block to be jumped over. It's never
+run. Instead, it prints special output that tells Test::Harness that
+the tests have been skipped.
+
+ 1..7
+ ok 1 - Epoch time of 0
+ ok 2 # skip epoch to ICal not working on MacOS
+ ok 3 # skip epoch to ICal not working on MacOS
+ ok 4 # skip epoch to ICal not working on MacOS
+ ok 5 # skip epoch to ICal not working on MacOS
+ ok 6 # skip epoch to ICal not working on MacOS
+ ok 7 # skip epoch to ICal not working on MacOS
+
+This means your tests won't fail on MacOS. This means less emails
+from MacPerl users telling you about failing tests that you know will
+never work. You've got to be careful with skip tests. These are for
+tests which don't work and I<never will>. It is not for skipping
+genuine bugs (we'll get to that in a moment).
+
+The tests are wholly and completely skipped. [10] This will work.
+
+ SKIP: {
+ skip("I don't wanna die!");
+
+ die, die, die, die, die;
+ }
+
+
+=head2 Todo tests
+
+Thumbing through the Date::ICal man page, I came across this:
+
+ ical
+
+ $ical_string = $ical->ical;
+
+ Retrieves, or sets, the date on the object, using any
+ valid ICal date/time string.
+
+"Retrieves or sets". Hmmm, didn't see a test for using C<ical()> to set
+the date in the Date::ICal test suite. So I'll write one.
+
+ use Test::More tests => 1;
+ use Date::ICal;
+
+ my $ical = Date::ICal->new;
+ $ical->ical('20201231Z');
+ is( $ical->ical, '20201231Z', 'Setting via ical()' );
+
+run that and I get
+
+ 1..1
+ not ok 1 - Setting via ical()
+ # Failed test (- at line 6)
+ # got: '20010814T233649Z'
+ # expected: '20201231Z'
+ # Looks like you failed 1 tests of 1.
+
+Whoops! Looks like it's unimplemented. Let's assume we don't have
+the time to fix this. [11] Normally, you'd just comment out the test
+and put a note in a todo list somewhere. Instead, we're going to
+explicitly state "this test will fail" by wrapping it in a C<TODO> block.
+
+ use Test::More tests => 1;
+
+ TODO: {
+ local $TODO = 'ical($ical) not yet implemented';
+
+ my $ical = Date::ICal->new;
+ $ical->ical('20201231Z');
+
+ is( $ical->ical, '20201231Z', 'Setting via ical()' );
+ }
+
+Now when you run, it's a little different:
+
+ 1..1
+ not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented
+ # got: '20010822T201551Z'
+ # expected: '20201231Z'
+
+Test::More doesn't say "Looks like you failed 1 tests of 1". That '#
+TODO' tells Test::Harness "this is supposed to fail" and it treats a
+failure as a successful test. So you can write tests even before
+you've fixed the underlying code.
+
+If a TODO test passes, Test::Harness will report it "UNEXPECTEDLY
+SUCCEEDED". When that happens, you simply remove the TODO block with
+C<local $TODO> and turn it into a real test.
+
+
+=head2 Testing with taint mode.
+
+Taint mode is a funny thing. It's the globalest of all global
+features. Once you turn it on, it affects I<all> code in your program
+and I<all> modules used (and all the modules they use). If a single
+piece of code isn't taint clean, the whole thing explodes. With that
+in mind, it's very important to ensure your module works under taint
+mode.
+
+It's very simple to have your tests run under taint mode. Just throw
+a C<-T> into the C<#!> line. Test::Harness will read the switches
+in C<#!> and use them to run your tests.
+
+ #!/usr/bin/perl -Tw
+
+ ...test normally here...
+
+So when you say C<make test> it will be run with taint mode and
+warnings on.
+
+
+=head1 FOOTNOTES
+
+=over 4
+
+=item 1
+
+The first number doesn't really mean anything, but it has to be 1.
+It's the second number that's important.
+
+=item 2
+
+For those following along at home, I'm using version 1.31. It has
+some bugs, which is good -- we'll uncover them with our tests.
+
+=item 3
+
+You can actually take this one step further and test the manual
+itself. Have a look at B<Test::Inline> (formerly B<Pod::Tests>).
+
+=item 4
+
+Yes, there's a mistake in the test suite. What! Me, contrived?
+
+=item 5
+
+We'll get to testing the contents of lists later.
+
+=item 6
+
+But what happens if your test program dies halfway through?! Since we
+didn't say how many tests we're going to run, how can we know it
+failed? No problem, Test::More employs some magic to catch that death
+and turn the test into a failure, even if every test passed up to that
+point.
+
+=item 7
+
+I cleaned it up a little.
+
+=item 8
+
+Most Operating Systems record time as the number of seconds since a
+certain date. This date is the beginning of the epoch. Unix's starts
+at midnight January 1st, 1970 GMT.
+
+=item 9
+
+MacOS's epoch is midnight January 1st, 1904. VMS's is midnight,
+November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a
+problem.
+
+=item 10
+
+As long as the code inside the SKIP block at least compiles. Please
+don't ask how. No, it's not a filter.
+
+=item 11
+
+Do NOT be tempted to use TODO tests as a way to avoid fixing simple
+bugs!
+
+=back
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers!
+
+=head1 COPYRIGHT
+
+Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This documentation is free; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+Irrespective of its distribution, all code examples in these files
+are hereby placed into the public domain. You are permitted and
+encouraged to use this code in your own programs for fun
+or for profit as you see fit. A simple comment in the code giving
+credit would be courteous but is not required.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Warn.pm b/Master/tlpkg/tlperl.straw/lib/Test/Warn.pm
new file mode 100755
index 00000000000..7776239fe6a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Warn.pm
@@ -0,0 +1,535 @@
+=head1 NAME
+
+Test::Warn - Perl extension to test methods for warnings
+
+=head1 SYNOPSIS
+
+ use Test::Warn;
+
+ warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning";
+ warnings_are {bar(1,1)} ["Width very small", "Height very small"];
+
+ warning_is {add(2,2)} undef, "No warning to calc 2+2"; # or
+ warnings_are {add(2,2)} [], "No warning to calc 2+2"; # what reads better :-)
+
+ warning_like {foo(-dri => "/")} qr/unknown param/i, "an unknown parameter test";
+ warnings_like {bar(1,1)} [qr/width.*small/i, qr/height.*small/i];
+
+ warning_is {foo()} {carped => "didn't found the right parameters"};
+ warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}];
+
+ warning_like {foo(undef)} 'uninitialized';
+ warning_like {bar(file => '/etc/passwd')} 'io';
+
+ warning_like {eval q/"$x"; $x;/}
+ [qw/void uninitialized/],
+ "some warnings at compile time";
+
+ warnings_exist {...} [qr/expected warning/], "Expected warning is thrown";
+
+=head1 DESCRIPTION
+
+A good style of Perl programming calls for a lot of diverse regression tests.
+
+This module provides a few convenience methods for testing warning based code.
+
+If you are not already familiar with the Test::More manpage
+now would be the time to go take a look.
+
+=head2 FUNCTIONS
+
+=over 4
+
+=item warning_is BLOCK STRING, TEST_NAME
+
+Tests that BLOCK gives exactly the one specificated warning.
+The test fails if the BLOCK warns more then one times or doesn't warn.
+If the string is undef,
+then the tests succeeds if the BLOCK doesn't give any warning.
+Another way to say that there aren't any warnings in the block,
+is C<warnings_are {foo()} [], "no warnings in">.
+
+If you want to test for a warning given by carp,
+You have to write something like:
+C<warning_is {carp "msg"} {carped =E<gt> 'msg'}, "Test for a carped warning">.
+The test will fail,
+if a "normal" warning is found instead of a "carped" one.
+
+Note: C<warn "foo"> would print something like C<foo at -e line 1>.
+This method ignores everything after the at. That means, to match this warning
+you would have to call C<warning_is {warn "foo"} "foo", "Foo succeeded">.
+If you need to test for a warning at an exactly line,
+try better something like C<warning_like {warn "foo"} qr/at XYZ.dat line 5/>.
+
+warning_is and warning_are are only aliases to the same method.
+So you also could write
+C<warning_is {foo()} [], "no warning"> or something similar.
+I decided to give two methods to have some better readable method names.
+
+A true value is returned if the test succeeds, false otherwise.
+
+The test name is optional, but recommended.
+
+
+=item warnings_are BLOCK ARRAYREF, TEST_NAME
+
+Tests to see that BLOCK gives exactly the specificated warnings.
+The test fails if the BLOCK warns a different number than the size of the ARRAYREf
+would have expected.
+If the ARRAYREF is equal to [],
+then the test succeeds if the BLOCK doesn't give any warning.
+
+Please read also the notes to warning_is as these methods are only aliases.
+
+If you want more than one tests for carped warnings look that way:
+C<warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2'];> or
+C<warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"]>.
+Note that C<{carped => ...}> has always to be a hash ref.
+
+=item warning_like BLOCK REGEXP, TEST_NAME
+
+Tests that BLOCK gives exactly one warning and it can be matched to the given regexp.
+If the string is undef,
+then the tests succeeds iff the BLOCK doesn't give any warning.
+
+The REGEXP is matched after the whole warn line,
+which consists in general of "WARNING at __FILE__ line __LINE__".
+So you can check for a warning in at File Foo.pm line 5 with
+C<warning_like {bar()} qr/at Foo.pm line 5/, "Testname">.
+I don't know whether it's sensful to do such a test :-(
+However, you should be prepared as a matching with 'at', 'file', '\d'
+or similar will always pass.
+Think to the qr/^foo/ if you want to test for warning "foo something" in file foo.pl.
+
+You can also write the regexp in a string as "/.../"
+instead of using the qr/.../ syntax.
+Note that the slashes are important in the string,
+as strings without slashes are reserved for warning categories
+(to match warning categories as can be seen in the perllexwarn man page).
+
+Similar to C<warning_is>,
+you can test for warnings via C<carp> with:
+C<warning_like {bar()} {carped => qr/bar called too early/i};>
+
+Similar to C<warning_is>/C<warnings_are>,
+C<warning_like> and C<warnings_like> are only aliases to the same methods.
+
+A true value is returned if the test succeeds, false otherwise.
+
+The test name is optional, but recommended.
+
+=item warning_like BLOCK STRING, TEST_NAME
+
+Tests whether a BLOCK gives exactly one warning of the passed category.
+The categories are grouped in a tree,
+like it is expressed in perllexwarn.
+Note, that they have the hierarchical structure from perl 5.8.0,
+wich has a little bit changed to 5.6.1 or earlier versions
+(You can access the internal used tree with C<$Test::Warn::Categorization::tree>,
+although I wouldn't recommend it)
+
+Thanks to the grouping in a tree,
+it's simple possible to test for an 'io' warning,
+instead for testing for a 'closed|exec|layer|newline|pipe|unopened' warning.
+
+Note, that warnings occuring at compile time,
+can only be catched in an eval block. So
+
+ warning_like {eval q/"$x"; $x;/}
+ [qw/void uninitialized/],
+ "some warnings at compile time";
+
+will work,
+while it wouldn't work without the eval.
+
+Note, that it isn't possible yet,
+to test for own categories,
+created with warnings::register.
+
+=item warnings_like BLOCK ARRAYREF, TEST_NAME
+
+Tests to see that BLOCK gives exactly the number of the specificated warnings
+and all the warnings have to match in the defined order to the
+passed regexes.
+
+Please read also the notes to warning_like as these methods are only aliases.
+
+Similar to C<warnings_are>,
+you can test for multiple warnings via C<carp>
+and for warning categories, too:
+
+ warnings_like {foo()}
+ [qr/bar warning/,
+ qr/bar warning/,
+ {carped => qr/bar warning/i},
+ 'io'
+ ],
+ "I hope, you'll never have to write a test for so many warnings :-)";
+
+=item warnings_exist BLOCK STRING|ARRAYREF, TEST_NAME
+
+Same as warning_like, but will warn() all warnings that do not match the supplied regex/category,
+instead of registering an error. Use this test when you just want to make sure that specific
+warnings were generated, and couldn't care less if other warnings happened in the same block
+of code.
+
+ warnings_exist {...} [qr/expected warning/], "Expected warning is thrown";
+
+ warnings_exist {...} ['uninitialized'], "Expected warning is thrown";
+
+=back
+
+=head2 EXPORT
+
+C<warning_is>,
+C<warnings_are>,
+C<warning_like>,
+C<warnings_like>,
+C<warnings_exist> by default.
+
+=head1 BUGS
+
+Please note that warnings with newlines inside are making a lot of trouble.
+The only sensible way to handle them is to use are the C<warning_like> or
+C<warnings_like> methods. Background for these problems is that there is no
+really secure way to distinguish between warnings with newlines and a tracing
+stacktrace.
+
+If a method has it's own warn handler,
+overwriting C<$SIG{__WARN__}>,
+my test warning methods won't get these warnings.
+
+The C<warning_like BLOCK CATEGORY, TEST_NAME> method isn't extremely tested.
+Please use this calling style with higher attention and
+tell me if you find a bug.
+
+=head1 TODO
+
+Improve this documentation.
+
+The code has some parts doubled - especially in the test scripts.
+This is really awkward and has to be changed.
+
+Please feel free to suggest me any improvements.
+
+=head1 SEE ALSO
+
+Have a look to the similar L<Test::Exception> module. Test::Trap
+
+=head1 THANKS
+
+Many thanks to Adrian Howard, chromatic and Michael G. Schwern,
+who have given me a lot of ideas.
+
+=head1 AUTHOR
+
+Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002 by Janek Schleicher
+
+Copyright 2007-2009 by Alexandr Ciornii, L<http://chorny.net/>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+
+package Test::Warn;
+
+use 5.006;
+use strict;
+use warnings;
+
+#use Array::Compare;
+use Sub::Uplevel 0.12;
+
+our $VERSION = '0.21';
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+
+our %EXPORT_TAGS = ( 'all' => [ qw(
+ @EXPORT
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+ warning_is warnings_are
+ warning_like warnings_like
+ warnings_exist
+);
+
+use Test::Builder;
+my $Tester = Test::Builder->new;
+
+{
+no warnings 'once';
+*warning_is = *warnings_are;
+*warning_like = *warnings_like;
+}
+
+sub warnings_are (&$;$) {
+ my $block = shift;
+ my @exp_warning = map {_canonical_exp_warning($_)}
+ _to_array_if_necessary( shift() || [] );
+ my $testname = shift;
+ my @got_warning = ();
+ local $SIG{__WARN__} = sub {
+ my ($called_from) = caller(0); # to find out Carping methods
+ push @got_warning, _canonical_got_warning($called_from, shift());
+ };
+ uplevel 1,$block;
+ my $ok = _cmp_is( \@got_warning, \@exp_warning );
+ $Tester->ok( $ok, $testname );
+ $ok or _diag_found_warning(@got_warning),
+ _diag_exp_warning(@exp_warning);
+ return $ok;
+}
+
+
+sub warnings_like (&$;$) {
+ my $block = shift;
+ my @exp_warning = map {_canonical_exp_warning($_)}
+ _to_array_if_necessary( shift() || [] );
+ my $testname = shift;
+ my @got_warning = ();
+ local $SIG{__WARN__} = sub {
+ my ($called_from) = caller(0); # to find out Carping methods
+ push @got_warning, _canonical_got_warning($called_from, shift());
+ };
+ uplevel 1,$block;
+ my $ok = _cmp_like( \@got_warning, \@exp_warning );
+ $Tester->ok( $ok, $testname );
+ $ok or _diag_found_warning(@got_warning),
+ _diag_exp_warning(@exp_warning);
+ return $ok;
+}
+
+sub warnings_exist (&$;$) {
+ my $block = shift;
+ my @exp_warning = map {_canonical_exp_warning($_)}
+ _to_array_if_necessary( shift() || [] );
+ my $testname = shift;
+ my @got_warning = ();
+ local $SIG{__WARN__} = sub {
+ my ($called_from) = caller(0); # to find out Carping methods
+ my $wrn_text=shift;
+ my $wrn_rec=_canonical_got_warning($called_from, $wrn_text);
+ foreach my $wrn (@exp_warning) {
+ if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) {
+ push @got_warning, $wrn_rec;
+ return;
+ }
+ }
+ warn $wrn_text;
+ };
+ uplevel 1,$block;
+ my $ok = _cmp_like( \@got_warning, \@exp_warning );
+ $Tester->ok( $ok, $testname );
+ $ok or _diag_found_warning(@got_warning),
+ _diag_exp_warning(@exp_warning);
+ return $ok;
+}
+
+
+sub _to_array_if_necessary {
+ return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
+}
+
+sub _canonical_got_warning {
+ my ($called_from, $msg) = @_;
+ my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn';
+ my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included
+ return {$warn_kind => $warning_stack[0]}; # return only the real message
+}
+
+sub _canonical_exp_warning {
+ my ($exp) = @_;
+ if (ref($exp) eq 'HASH') { # could be {carped => ...}
+ my $to_carp = $exp->{carped} or return; # undefined message are ignored
+ return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] }
+ ? map({ {carped => $_} } grep {defined $_} @$to_carp)
+ : +{carped => $to_carp};
+ }
+ return {warn => $exp};
+}
+
+sub _cmp_got_to_exp_warning {
+ my ($got_kind, $got_msg) = %{ shift() };
+ my ($exp_kind, $exp_msg) = %{ shift() };
+ return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
+ my $cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/;
+ return $cmp;
+}
+
+sub _cmp_got_to_exp_warning_like {
+ my ($got_kind, $got_msg) = %{ shift() };
+ my ($exp_kind, $exp_msg) = %{ shift() };
+ return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
+ if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//'
+ my $cmp = $got_msg =~ /$re/;
+ return $cmp;
+ } else {
+ return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg);
+ }
+}
+
+
+sub _cmp_is {
+ my @got = @{ shift() };
+ my @exp = @{ shift() };
+ scalar @got == scalar @exp or return 0;
+ my $cmp = 1;
+ $cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got);
+ return $cmp;
+}
+
+sub _cmp_like {
+ my @got = @{ shift() };
+ my @exp = @{ shift() };
+ scalar @got == scalar @exp or return 0;
+ my $cmp = 1;
+ $cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got);
+ return $cmp;
+}
+
+sub _diag_found_warning {
+ foreach (@_) {
+ if (ref($_) eq 'HASH') {
+ ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
+ : $Tester->diag("found warning: ${$_}{warn}");
+ } else {
+ $Tester->diag( "found warning: $_" );
+ }
+ }
+ $Tester->diag( "didn't found a warning" ) unless @_;
+}
+
+sub _diag_exp_warning {
+ foreach (@_) {
+ if (ref($_) eq 'HASH') {
+ ${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}")
+ : $Tester->diag("expected to find warning: ${$_}{warn}");
+ } else {
+ $Tester->diag( "expected to find warning: $_" );
+ }
+ }
+ $Tester->diag( "didn't expect to find a warning" ) unless @_;
+}
+
+package Test::Warn::DAG_Node_Tree;
+
+use strict;
+use warnings;
+use base 'Tree::DAG_Node';
+
+
+sub nice_lol_to_tree {
+ my $class = shift;
+ $class->new(
+ {
+ name => shift(),
+ daughters => [_nice_lol_to_daughters(shift())]
+ });
+}
+
+sub _nice_lol_to_daughters {
+ my @names = @{ shift() };
+ my @daughters = ();
+ my $last_daughter = undef;
+ foreach (@names) {
+ if (ref($_) ne 'ARRAY') {
+ $last_daughter = Tree::DAG_Node->new({name => $_});
+ push @daughters, $last_daughter;
+ } else {
+ $last_daughter->add_daughters(_nice_lol_to_daughters($_));
+ }
+ }
+ return @daughters;
+}
+
+sub depthsearch {
+ my ($self, $search_name) = @_;
+ my $found_node = undef;
+ $self->walk_down({callback => sub {
+ my $node = shift();
+ $node->name eq $search_name and $found_node = $node,!"go on";
+ "go on with searching";
+ }});
+ return $found_node;
+}
+
+package Test::Warn::Categorization;
+
+use Carp;
+
+our $tree = Test::Warn::DAG_Node_Tree->nice_lol_to_tree(
+ all => [ 'closure',
+ 'deprecated',
+ 'exiting',
+ 'glob',
+ 'io' => [ 'closed',
+ 'exec',
+ 'layer',
+ 'newline',
+ 'pipe',
+ 'unopened'
+ ],
+ 'misc',
+ 'numeric',
+ 'once',
+ 'overflow',
+ 'pack',
+ 'portable',
+ 'recursion',
+ 'redefine',
+ 'regexp',
+ 'severe' => [ 'debugging',
+ 'inplace',
+ 'internal',
+ 'malloc'
+ ],
+ 'signal',
+ 'substr',
+ 'syntax' => [ 'ambiguous',
+ 'bareword',
+ 'digit',
+ 'parenthesis',
+ 'precedence',
+ 'printf',
+ 'prototype',
+ 'qw',
+ 'reserved',
+ 'semicolon'
+ ],
+ 'taint',
+ 'threads',
+ 'uninitialized',
+ 'unpack',
+ 'untie',
+ 'utf8',
+ 'void',
+ 'y2k'
+ ]
+);
+
+sub _warning_category_regexp {
+ my $sub_tree = $tree->depthsearch(shift()) or return;
+ my $re = join "|", map {$_->name} $sub_tree->leaves_under;
+ return qr/(?=\w)$re/;
+}
+
+sub warning_like_category {
+ my ($warning, $category) = @_;
+ my $re = _warning_category_regexp($category) or
+ carp("Unknown warning category '$category'"),return;
+ my $ok = $warning =~ /$re/;
+ return $ok;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/YAML.pm b/Master/tlpkg/tlperl.straw/lib/Test/YAML.pm
new file mode 100755
index 00000000000..a3d5c8d7318
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/YAML.pm
@@ -0,0 +1,270 @@
+package Test::YAML;
+
+use Test::Base 0.47 -Base;
+use lib 'lib';
+
+our $VERSION = '0.71';
+our $YAML = 'YAML';
+our @EXPORT = qw(
+ no_diff
+ run_yaml_tests
+ run_roundtrip_nyn roundtrip_nyn
+ run_load_passes load_passes
+ dumper Load Dump LoadFile DumpFile
+ XXX
+);
+
+delimiters('===', '+++');
+
+sub Dump () { YAML(Dump => @_) }
+sub Load () { YAML(Load => @_) }
+sub DumpFile () { YAML(DumpFile => @_) }
+sub LoadFile () { YAML(LoadFile => @_) }
+
+sub YAML () {
+ load_yaml_pm();
+ my $meth = shift;
+ my $code = $YAML->can($meth) or die "$YAML cannot do $meth";
+ goto &$code;
+}
+
+sub load_yaml_pm {
+ my $file = "$YAML.pm";
+ $file =~ s{::}{/}g;
+ require $file;
+}
+
+sub run_yaml_tests() {
+ run {
+ my $block = shift;
+ &{_get_function($block)}($block) unless
+ _skip_tests_for_now($block) or
+ _skip_yaml_tests($block);
+ };
+}
+
+sub run_roundtrip_nyn() {
+ my @options = @_;
+ run {
+ my $block = shift;
+ roundtrip_nyn($block, @options);
+ };
+}
+
+sub roundtrip_nyn() {
+ my $block = shift;
+ my $option = shift || '';
+ die "'perl' data section required"
+ unless exists $block->{perl};
+ my @values = eval $block->perl;
+ die "roundtrip_nyn eval perl error: $@" if $@;
+ my $config = $block->config || '';
+ my $result = eval "$config; Dump(\@values)";
+ die "roundtrip_nyn YAML::Dump error: $@" if $@;
+ if (exists $block->{yaml}) {
+ is $result, $block->yaml,
+ $block->description . ' (n->y)';
+ }
+ else {
+ pass $block->description . ' (n->y)';
+ }
+
+ return if exists $block->{no_round_trip} or
+ not exists $block->{yaml};
+
+ if ($option eq 'dumper') {
+ is dumper(Load($block->yaml)), dumper(@values),
+ $block->description . ' (y->n)';
+ }
+ else {
+ is_deeply [Load($block->yaml)], [@values],
+ $block->description . ' (y->n)';
+ }
+}
+
+sub count_roundtrip_nyn() {
+ my $block = shift or die "Bad call to count_roundtrip_nyn";
+ return 1 if exists $block->{skip_this_for_now};
+ my $count = 0;
+ $count++ if exists $block->{perl};
+ $count++ unless exists $block->{no_round_trip} or
+ not exists $block->{yaml};
+ die "Invalid test definition" unless $count;
+ return $count;
+}
+
+sub run_load_passes() {
+ run {
+ my $block = shift;
+ my $yaml = $block->yaml;
+ eval { YAML(Load => $yaml) };
+ is("$@", "");
+ };
+}
+
+sub load_passes() {
+ my $block = shift;
+ my $yaml = $block->yaml;
+ eval { YAML(Load => $yaml) };
+ is "$@", "", $block->description;
+}
+
+sub count_load_passes() {1}
+
+sub dumper() {
+ require Data::Dumper;
+ $Data::Dumper::Sortkeys = 1;
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Indent = 1;
+ return Data::Dumper::Dumper(@_);
+}
+
+{
+ no warnings;
+ sub XXX {
+ YAML::Base::XXX(@_);
+ }
+}
+
+sub _count_tests() {
+ my $block = shift or die "Bad call to _count_tests";
+ no strict 'refs';
+ &{'count_' . _get_function_name($block)}($block);
+}
+
+sub _get_function_name() {
+ my $block = shift;
+ return $block->function || 'roundtrip_nyn';
+}
+
+sub _get_function() {
+ my $block = shift;
+ no strict 'refs';
+ \ &{_get_function_name($block)};
+}
+
+sub _skip_tests_for_now() {
+ my $block = shift;
+ if (exists $block->{skip_this_for_now}) {
+ _skip_test(
+ $block->description,
+ _count_tests($block),
+ );
+ return 1;
+ }
+ return 0;
+}
+
+sub _skip_yaml_tests() {
+ my $block = shift;
+ if ($block->skip_unless_modules) {
+ my @modules = split /[\s\,]+/, $block->skip_unless_modules;
+ for my $module (@modules) {
+ eval "require $module";
+ if ($@) {
+ _skip_test(
+ "This test requires the '$module' module",
+ _count_tests($block),
+ );
+ return 1;
+ }
+ }
+ }
+ return 0;
+}
+
+sub _skip_test() {
+ my ($message, $count) = @_;
+ SKIP: {
+ skip($message, $count);
+ }
+}
+
+#-------------------------------------------------------------------------------
+package Test::YAML::Filter;
+
+use Test::Base::Filter ();
+
+our @ISA = 'Test::Base::Filter';
+
+sub yaml_dump {
+ Test::YAML::Dump(@_);
+}
+
+sub yaml_load {
+ Test::YAML::Load(@_);
+}
+
+sub Dump { goto &Test::YAML::Dump }
+sub Load { goto &Test::YAML::Load }
+sub DumpFile { goto &Test::YAML::DumpFile }
+sub LoadFile { goto &Test::YAML::LoadFile }
+
+sub yaml_load_or_fail {
+ my ($result, $error, $warning) =
+ $self->_yaml_load_result_error_warning(@_);
+ return $error || $result;
+}
+
+sub yaml_load_error_or_warning {
+ my ($result, $error, $warning) =
+ $self->_yaml_load_result_error_warning(@_);
+ return $error || $warning || '';
+}
+
+sub perl_eval_error_or_warning {
+ my ($result, $error, $warning) =
+ $self->_perl_eval_result_error_warning(@_);
+ return $error || $warning || '';
+}
+
+sub _yaml_load_result_error_warning {
+ $self->assert_scalar(@_);
+ my $yaml = shift;
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = join '', @_ };
+ my $result = eval {
+ $self->yaml_load($yaml);
+ };
+ return ($result, $@, $warning);
+}
+
+sub _perl_eval_result_error_warning {
+ $self->assert_scalar(@_);
+ my $perl = shift;
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = join '', @_ };
+ my $result = eval $perl;
+ return ($result, $@, $warning);
+}
+
+1;
+
+=head1 NAME
+
+Test::YAML - Testing Module for YAML Implementations
+
+=head1 SYNOPSIS
+
+ use Test::YAML tests => 1;
+
+ pass;
+
+=head1 DESCRIPTION
+
+Test::YAML is a subclass of Test::Base with YAML specific support.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Thread/Queue.pm b/Master/tlpkg/tlperl.straw/lib/Thread/Queue.pm
new file mode 100755
index 00000000000..631edf126a6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Thread/Queue.pm
@@ -0,0 +1,481 @@
+package Thread::Queue;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.11';
+
+use threads::shared 1.21;
+use Scalar::Util 1.10 qw(looks_like_number blessed reftype refaddr);
+
+# Carp errors from threads::shared calls should complain about caller
+our @CARP_NOT = ("threads::shared");
+
+# Predeclarations for internal functions
+my ($validate_count, $validate_index);
+
+# Create a new queue possibly pre-populated with items
+sub new
+{
+ my $class = shift;
+ my @queue :shared = map { shared_clone($_) } @_;
+ return bless(\@queue, $class);
+}
+
+# Add items to the tail of a queue
+sub enqueue
+{
+ my $queue = shift;
+ lock(@$queue);
+ push(@$queue, map { shared_clone($_) } @_)
+ and cond_signal(@$queue);
+}
+
+# Return a count of the number of items on a queue
+sub pending
+{
+ my $queue = shift;
+ lock(@$queue);
+ return scalar(@$queue);
+}
+
+# Return 1 or more items from the head of a queue, blocking if needed
+sub dequeue
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $count = @_ ? $validate_count->(shift) : 1;
+
+ # Wait for requisite number of items
+ cond_wait(@$queue) until (@$queue >= $count);
+ cond_signal(@$queue) if (@$queue > $count);
+
+ # Return single item
+ return shift(@$queue) if ($count == 1);
+
+ # Return multiple items
+ my @items;
+ push(@items, shift(@$queue)) for (1..$count);
+ return @items;
+}
+
+# Return items from the head of a queue with no blocking
+sub dequeue_nb
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $count = @_ ? $validate_count->(shift) : 1;
+
+ # Return single item
+ return shift(@$queue) if ($count == 1);
+
+ # Return multiple items
+ my @items;
+ for (1..$count) {
+ last if (! @$queue);
+ push(@items, shift(@$queue));
+ }
+ return @items;
+}
+
+# Return an item without removing it from a queue
+sub peek
+{
+ my $queue = shift;
+ lock(@$queue);
+ my $index = @_ ? $validate_index->(shift) : 0;
+ return $$queue[$index];
+}
+
+# Insert items anywhere into a queue
+sub insert
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $index = $validate_index->(shift);
+
+ return if (! @_); # Nothing to insert
+
+ # Support negative indices
+ if ($index < 0) {
+ $index += @$queue;
+ if ($index < 0) {
+ $index = 0;
+ }
+ }
+
+ # Dequeue items from $index onward
+ my @tmp;
+ while (@$queue > $index) {
+ unshift(@tmp, pop(@$queue))
+ }
+
+ # Add new items to the queue
+ push(@$queue, map { shared_clone($_) } @_);
+
+ # Add previous items back onto the queue
+ push(@$queue, @tmp);
+
+ # Soup's up
+ cond_signal(@$queue);
+}
+
+# Remove items from anywhere in a queue
+sub extract
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $index = @_ ? $validate_index->(shift) : 0;
+ my $count = @_ ? $validate_count->(shift) : 1;
+
+ # Support negative indices
+ if ($index < 0) {
+ $index += @$queue;
+ if ($index < 0) {
+ $count += $index;
+ return if ($count <= 0); # Beyond the head of the queue
+ return $queue->dequeue_nb($count); # Extract from the head
+ }
+ }
+
+ # Dequeue items from $index+$count onward
+ my @tmp;
+ while (@$queue > ($index+$count)) {
+ unshift(@tmp, pop(@$queue))
+ }
+
+ # Extract desired items
+ my @items;
+ unshift(@items, pop(@$queue)) while (@$queue > $index);
+
+ # Add back any removed items
+ push(@$queue, @tmp);
+
+ # Return single item
+ return $items[0] if ($count == 1);
+
+ # Return multiple items
+ return @items;
+}
+
+### Internal Functions ###
+
+# Check value of the requested index
+$validate_index = sub {
+ my $index = shift;
+
+ if (! defined($index) ||
+ ! looks_like_number($index) ||
+ (int($index) != $index))
+ {
+ require Carp;
+ my ($method) = (caller(1))[3];
+ $method =~ s/Thread::Queue:://;
+ $index = 'undef' if (! defined($index));
+ Carp::croak("Invalid 'index' argument ($index) to '$method' method");
+ }
+
+ return $index;
+};
+
+# Check value of the requested count
+$validate_count = sub {
+ my $count = shift;
+
+ if (! defined($count) ||
+ ! looks_like_number($count) ||
+ (int($count) != $count) ||
+ ($count < 1))
+ {
+ require Carp;
+ my ($method) = (caller(1))[3];
+ $method =~ s/Thread::Queue:://;
+ $count = 'undef' if (! defined($count));
+ Carp::croak("Invalid 'count' argument ($count) to '$method' method");
+ }
+
+ return $count;
+};
+
+1;
+
+=head1 NAME
+
+Thread::Queue - Thread-safe queues
+
+=head1 VERSION
+
+This document describes Thread::Queue version 2.11
+
+=head1 SYNOPSIS
+
+ use strict;
+ use warnings;
+
+ use threads;
+ use Thread::Queue;
+
+ my $q = Thread::Queue->new(); # A new empty queue
+
+ # Worker thread
+ my $thr = threads->create(sub {
+ while (my $item = $q->dequeue()) {
+ # Do work on $item
+ }
+ })->detach();
+
+ # Send work to the thread
+ $q->enqueue($item1, ...);
+
+
+ # Count of items in the queue
+ my $left = $q->pending();
+
+ # Non-blocking dequeue
+ if (defined(my $item = $q->dequeue_nb())) {
+ # Work on $item
+ }
+
+ # Get the second item in the queue without dequeuing anything
+ my $item = $q->peek(1);
+
+ # Insert two items into the queue just behind the head
+ $q->insert(1, $item1, $item2);
+
+ # Extract the last two items on the queue
+ my ($item1, $item2) = $q->extract(-2, 2);
+
+=head1 DESCRIPTION
+
+This module provides thread-safe FIFO queues that can be accessed safely by
+any number of threads.
+
+Any data types supported by L<threads::shared> can be passed via queues:
+
+=over
+
+=item Ordinary scalars
+
+=item Array refs
+
+=item Hash refs
+
+=item Scalar refs
+
+=item Objects based on the above
+
+=back
+
+Ordinary scalars are added to queues as they are.
+
+If not already thread-shared, the other complex data types will be cloned
+(recursively, if needed, and including any C<bless>ings and read-only
+settings) into thread-shared structures before being placed onto a queue.
+
+For example, the following would cause L<Thread::Queue> to create a empty,
+shared array reference via C<&shared([])>, copy the elements 'foo', 'bar'
+and 'baz' from C<@ary> into it, and then place that shared reference onto
+the queue:
+
+ my @ary = qw/foo bar baz/;
+ $q->enqueue(\@ary);
+
+However, for the following, the items are already shared, so their references
+are added directly to the queue, and no cloning takes place:
+
+ my @ary :shared = qw/foo bar baz/;
+ $q->enqueue(\@ary);
+
+ my $obj = &shared({});
+ $$obj{'foo'} = 'bar';
+ $$obj{'qux'} = 99;
+ bless($obj, 'My::Class');
+ $q->enqueue($obj);
+
+See L</"LIMITATIONS"> for caveats related to passing objects via queues.
+
+=head1 QUEUE CREATION
+
+=over
+
+=item ->new()
+
+Creates a new empty queue.
+
+=item ->new(LIST)
+
+Creates a new queue pre-populated with the provided list of items.
+
+=back
+
+=head1 BASIC METHODS
+
+The following methods deal with queues on a FIFO basis.
+
+=over
+
+=item ->enqueue(LIST)
+
+Adds a list of items onto the end of the queue.
+
+=item ->dequeue()
+
+=item ->dequeue(COUNT)
+
+Removes the requested number of items (default is 1) from the head of the
+queue, and returns them. If the queue contains fewer than the requested
+number of items, then the thread will be blocked until the requisite number
+of items are available (i.e., until other threads <enqueue> more items).
+
+=item ->dequeue_nb()
+
+=item ->dequeue_nb(COUNT)
+
+Removes the requested number of items (default is 1) from the head of the
+queue, and returns them. If the queue contains fewer than the requested
+number of items, then it immediately (i.e., non-blocking) returns whatever
+items there are on the queue. If the queue is empty, then C<undef> is
+returned.
+
+=item ->pending()
+
+Returns the number of items still in the queue.
+
+=back
+
+=head1 ADVANCED METHODS
+
+The following methods can be used to manipulate items anywhere in a queue.
+
+To prevent the contents of a queue from being modified by another thread
+while it is being examined and/or changed, L<lock|threads::shared/"lock
+VARIABLE"> the queue inside a local block:
+
+ {
+ lock($q); # Keep other threads from changing the queue's contents
+ my $item = $q->peek();
+ if ($item ...) {
+ ...
+ }
+ }
+ # Queue is now unlocked
+
+=over
+
+=item ->peek()
+
+=item ->peek(INDEX)
+
+Returns an item from the queue without dequeuing anything. Defaults to the
+the head of queue (at index position 0) if no index is specified. Negative
+index values are supported as with L<arrays|perldata/"Subscripts"> (i.e., -1
+is the end of the queue, -2 is next to last, and so on).
+
+If no items exists at the specified index (i.e., the queue is empty, or the
+index is beyond the number of items on the queue), then C<undef> is returned.
+
+Remember, the returned item is not removed from the queue, so manipulating a
+C<peek>ed at reference affects the item on the queue.
+
+=item ->insert(INDEX, LIST)
+
+Adds the list of items to the queue at the specified index position (0
+is the head of the list). Any existing items at and beyond that position are
+pushed back past the newly added items:
+
+ $q->enqueue(1, 2, 3, 4);
+ $q->insert(1, qw/foo bar/);
+ # Queue now contains: 1, foo, bar, 2, 3, 4
+
+Specifying an index position greater than the number of items in the queue
+just adds the list to the end.
+
+Negative index positions are supported:
+
+ $q->enqueue(1, 2, 3, 4);
+ $q->insert(-2, qw/foo bar/);
+ # Queue now contains: 1, 2, foo, bar, 3, 4
+
+Specifying a negative index position greater than the number of items in the
+queue adds the list to the head of the queue.
+
+=item ->extract()
+
+=item ->extract(INDEX)
+
+=item ->extract(INDEX, COUNT)
+
+Removes and returns the specified number of items (defaults to 1) from the
+specified index position in the queue (0 is the head of the queue). When
+called with no arguments, C<extract> operates the same as C<dequeue_nb>.
+
+This method is non-blocking, and will return only as many items as are
+available to fulfill the request:
+
+ $q->enqueue(1, 2, 3, 4);
+ my $item = $q->extract(2) # Returns 3
+ # Queue now contains: 1, 2, 4
+ my @items = $q->extract(1, 3) # Returns (2, 4)
+ # Queue now contains: 1
+
+Specifying an index position greater than the number of items in the
+queue results in C<undef> or an empty list being returned.
+
+ $q->enqueue('foo');
+ my $nada = $q->extract(3) # Returns undef
+ my @nada = $q->extract(1, 3) # Returns ()
+
+Negative index positions are supported. Specifying a negative index position
+greater than the number of items in the queue may return items from the head
+of the queue (similar to C<dequeue_nb>) if the count overlaps the head of the
+queue from the specified position (i.e. if queue size + index + count is
+greater than zero):
+
+ $q->enqueue(qw/foo bar baz/);
+ my @nada = $q->extract(-6, 2); # Returns () - (3+(-6)+2) <= 0
+ my @some = $q->extract(-6, 4); # Returns (foo) - (3+(-6)+4) > 0
+ # Queue now contains: bar, baz
+ my @rest = $q->extract(-3, 4); # Returns (bar, baz) - (2+(-3)+4) > 0
+
+=back
+
+=head1 NOTES
+
+Queues created by L<Thread::Queue> can be used in both threaded and
+non-threaded applications.
+
+=head1 LIMITATIONS
+
+Passing objects on queues may not work if the objects' classes do not support
+sharing. See L<threads::shared/"BUGS AND LIMITATIONS"> for more.
+
+Passing array/hash refs that contain objects may not work for Perl prior to
+5.10.0.
+
+=head1 SEE ALSO
+
+Thread::Queue Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/Thread-Queue>
+
+Annotated POD for Thread::Queue:
+L<http://annocpan.org/~JDHEDDEN/Thread-Queue-2.11/lib/Thread/Queue.pm>
+
+Source repository:
+L<http://code.google.com/p/thread-queue/>
+
+L<threads>, L<threads::shared>
+
+=head1 MAINTAINER
+
+Jerry D. Hedden, S<E<lt>jdhedden AT cpan DOT orgE<gt>>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Thread/Semaphore.pm b/Master/tlpkg/tlperl.straw/lib/Thread/Semaphore.pm
new file mode 100755
index 00000000000..67cb30e66a6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Thread/Semaphore.pm
@@ -0,0 +1,170 @@
+package Thread::Semaphore;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.09';
+
+use threads::shared;
+use Scalar::Util 1.10 qw(looks_like_number);
+
+# Create a new semaphore optionally with specified count (count defaults to 1)
+sub new {
+ my $class = shift;
+ my $val :shared = @_ ? shift : 1;
+ if (!defined($val) ||
+ ! looks_like_number($val) ||
+ (int($val) != $val))
+ {
+ require Carp;
+ $val = 'undef' if (! defined($val));
+ Carp::croak("Semaphore initializer is not an integer: $val");
+ }
+ return bless(\$val, $class);
+}
+
+# Decrement a semaphore's count (decrement amount defaults to 1)
+sub down {
+ my $sema = shift;
+ lock($$sema);
+ my $dec = @_ ? shift : 1;
+ if (! defined($dec) ||
+ ! looks_like_number($dec) ||
+ (int($dec) != $dec) ||
+ ($dec < 1))
+ {
+ require Carp;
+ $dec = 'undef' if (! defined($dec));
+ Carp::croak("Semaphore decrement is not a positive integer: $dec");
+ }
+ cond_wait($$sema) until ($$sema >= $dec);
+ $$sema -= $dec;
+}
+
+# Increment a semaphore's count (increment amount defaults to 1)
+sub up {
+ my $sema = shift;
+ lock($$sema);
+ my $inc = @_ ? shift : 1;
+ if (! defined($inc) ||
+ ! looks_like_number($inc) ||
+ (int($inc) != $inc) ||
+ ($inc < 1))
+ {
+ require Carp;
+ $inc = 'undef' if (! defined($inc));
+ Carp::croak("Semaphore increment is not a positive integer: $inc");
+ }
+ ($$sema += $inc) > 0 and cond_broadcast($$sema);
+}
+
+1;
+
+=head1 NAME
+
+Thread::Semaphore - Thread-safe semaphores
+
+=head1 VERSION
+
+This document describes Thread::Semaphore version 2.09
+
+=head1 SYNOPSIS
+
+ use Thread::Semaphore;
+ my $s = Thread::Semaphore->new();
+ $s->down(); # Also known as the semaphore P operation.
+ # The guarded section is here
+ $s->up(); # Also known as the semaphore V operation.
+
+ # The default semaphore value is 1
+ my $s = Thread::Semaphore-new($initial_value);
+ $s->down($down_value);
+ $s->up($up_value);
+
+=head1 DESCRIPTION
+
+Semaphores provide a mechanism to regulate access to resources. Unlike
+locks, semaphores aren't tied to particular scalars, and so may be used to
+control access to anything you care to use them for.
+
+Semaphores don't limit their values to zero and one, so they can be used to
+control access to some resource that there may be more than one of (e.g.,
+filehandles). Increment and decrement amounts aren't fixed at one either,
+so threads can reserve or return multiple resources at once.
+
+=head1 METHODS
+
+=over 8
+
+=item ->new()
+
+=item ->new(NUMBER)
+
+C<new> creates a new semaphore, and initializes its count to the specified
+number (which must be an integer). If no number is specified, the
+semaphore's count defaults to 1.
+
+=item ->down()
+
+=item ->down(NUMBER)
+
+The C<down> method decreases the semaphore's count by the specified number
+(which must be an integer >= 1), or by one if no number is specified.
+
+If the semaphore's count would drop below zero, this method will block
+until such time as the semaphore's count is greater than or equal to the
+amount you're C<down>ing the semaphore's count by.
+
+This is the semaphore "P operation" (the name derives from the Dutch
+word "pak", which means "capture" -- the semaphore operations were
+named by the late Dijkstra, who was Dutch).
+
+=item ->up()
+
+=item ->up(NUMBER)
+
+The C<up> method increases the semaphore's count by the number specified
+(which must be an integer >= 1), or by one if no number is specified.
+
+This will unblock any thread that is blocked trying to C<down> the
+semaphore if the C<up> raises the semaphore's count above the amount that
+the C<down> is trying to decrement it by. For example, if three threads
+are blocked trying to C<down> a semaphore by one, and another thread C<up>s
+the semaphore by two, then two of the blocked threads (which two is
+indeterminate) will become unblocked.
+
+This is the semaphore "V operation" (the name derives from the Dutch
+word "vrij", which means "release").
+
+=back
+
+=head1 NOTES
+
+Semaphores created by L<Thread::Semaphore> can be used in both threaded and
+non-threaded applications. This allows you to write modules and packages
+that potentially make use of semaphores, and that will function in either
+environment.
+
+=head1 SEE ALSO
+
+Thread::Semaphore Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/Thread-Semaphore>
+
+Annotated POD for Thread::Semaphore:
+L<http://annocpan.org/~JDHEDDEN/Thread-Semaphore-2.09/lib/Thread/Semaphore.pm>
+
+Source repository:
+L<http://code.google.com/p/thread-semaphore/>
+
+L<threads>, L<threads::shared>
+
+=head1 MAINTAINER
+
+Jerry D. Hedden, S<E<lt>jdhedden AT cpan DOT orgE<gt>>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Array.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Array.pm
new file mode 100755
index 00000000000..af8f51e9f51
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Array.pm
@@ -0,0 +1,287 @@
+package Tie::Array;
+
+use 5.006_001;
+use strict;
+use Carp;
+our $VERSION = '1.03';
+
+# Pod documentation after __END__ below.
+
+sub DESTROY { }
+sub EXTEND { }
+sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
+sub SHIFT { shift->SPLICE(0,1) }
+sub CLEAR { shift->STORESIZE(0) }
+
+sub PUSH
+{
+ my $obj = shift;
+ my $i = $obj->FETCHSIZE;
+ $obj->STORE($i++, shift) while (@_);
+}
+
+sub POP
+{
+ my $obj = shift;
+ my $newsize = $obj->FETCHSIZE - 1;
+ my $val;
+ if ($newsize >= 0)
+ {
+ $val = $obj->FETCH($newsize);
+ $obj->STORESIZE($newsize);
+ }
+ $val;
+}
+
+sub SPLICE {
+ my $obj = shift;
+ my $sz = $obj->FETCHSIZE;
+ my $off = (@_) ? shift : 0;
+ $off += $sz if ($off < 0);
+ my $len = (@_) ? shift : $sz - $off;
+ $len += $sz - $off if $len < 0;
+ my @result;
+ for (my $i = 0; $i < $len; $i++) {
+ push(@result,$obj->FETCH($off+$i));
+ }
+ $off = $sz if $off > $sz;
+ $len -= $off + $len - $sz if $off + $len > $sz;
+ if (@_ > $len) {
+ # Move items up to make room
+ my $d = @_ - $len;
+ my $e = $off+$len;
+ $obj->EXTEND($sz+$d);
+ for (my $i=$sz-1; $i >= $e; $i--) {
+ my $val = $obj->FETCH($i);
+ $obj->STORE($i+$d,$val);
+ }
+ }
+ elsif (@_ < $len) {
+ # Move items down to close the gap
+ my $d = $len - @_;
+ my $e = $off+$len;
+ for (my $i=$off+$len; $i < $sz; $i++) {
+ my $val = $obj->FETCH($i);
+ $obj->STORE($i-$d,$val);
+ }
+ $obj->STORESIZE($sz-$d);
+ }
+ for (my $i=0; $i < @_; $i++) {
+ $obj->STORE($off+$i,$_[$i]);
+ }
+ return wantarray ? @result : pop @result;
+}
+
+sub EXISTS {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define an EXISTS method";
+}
+
+sub DELETE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a DELETE method";
+}
+
+package Tie::StdArray;
+use vars qw(@ISA);
+@ISA = 'Tie::Array';
+
+sub TIEARRAY { bless [], $_[0] }
+sub FETCHSIZE { scalar @{$_[0]} }
+sub STORESIZE { $#{$_[0]} = $_[1]-1 }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+sub FETCH { $_[0]->[$_[1]] }
+sub CLEAR { @{$_[0]} = () }
+sub POP { pop(@{$_[0]}) }
+sub PUSH { my $o = shift; push(@$o,@_) }
+sub SHIFT { shift(@{$_[0]}) }
+sub UNSHIFT { my $o = shift; unshift(@$o,@_) }
+sub EXISTS { exists $_[0]->[$_[1]] }
+sub DELETE { delete $_[0]->[$_[1]] }
+
+sub SPLICE
+{
+ my $ob = shift;
+ my $sz = $ob->FETCHSIZE;
+ my $off = @_ ? shift : 0;
+ $off += $sz if $off < 0;
+ my $len = @_ ? shift : $sz-$off;
+ return splice(@$ob,$off,$len,@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tie::Array - base class for tied arrays
+
+=head1 SYNOPSIS
+
+ package Tie::NewArray;
+ use Tie::Array;
+ @ISA = ('Tie::Array');
+
+ # mandatory methods
+ sub TIEARRAY { ... }
+ sub FETCH { ... }
+ sub FETCHSIZE { ... }
+
+ sub STORE { ... } # mandatory if elements writeable
+ sub STORESIZE { ... } # mandatory if elements can be added/deleted
+ sub EXISTS { ... } # mandatory if exists() expected to work
+ sub DELETE { ... } # mandatory if delete() expected to work
+
+ # optional methods - for efficiency
+ sub CLEAR { ... }
+ sub PUSH { ... }
+ sub POP { ... }
+ sub SHIFT { ... }
+ sub UNSHIFT { ... }
+ sub SPLICE { ... }
+ sub EXTEND { ... }
+ sub DESTROY { ... }
+
+ package Tie::NewStdArray;
+ use Tie::Array;
+
+ @ISA = ('Tie::StdArray');
+
+ # all methods provided by default
+
+ package main;
+
+ $object = tie @somearray,Tie::NewArray;
+ $object = tie @somearray,Tie::StdArray;
+ $object = tie @somearray,Tie::NewStdArray;
+
+
+
+=head1 DESCRIPTION
+
+This module provides methods for array-tying classes. See
+L<perltie> for a list of the functions required in order to tie an array
+to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
+and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
+methods that croak() if the delete() or exists() builtins are ever called
+on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
+C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
+C<FETCHSIZE>, C<STORESIZE>.
+
+The B<Tie::StdArray> package provides efficient methods required for tied arrays
+which are implemented as blessed references to an "inner" perl array.
+It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
+like standard arrays, allowing for selective overloading of methods.
+
+For developers wishing to write their own tied arrays, the required methods
+are briefly defined below. See the L<perltie> section for more detailed
+descriptive, as well as example code:
+
+=over 4
+
+=item TIEARRAY classname, LIST
+
+The class method is invoked by the command C<tie @array, classname>. Associates
+an array instance with the specified class. C<LIST> would represent
+additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
+to complete the association. The method should return an object of a class which
+provides the methods below.
+
+=item STORE this, index, value
+
+Store datum I<value> into I<index> for the tied array associated with
+object I<this>. If this makes the array larger then
+class's mapping of C<undef> should be returned for new positions.
+
+=item FETCH this, index
+
+Retrieve the datum in I<index> for the tied array associated with
+object I<this>.
+
+=item FETCHSIZE this
+
+Returns the total number of items in the tied array associated with
+object I<this>. (Equivalent to C<scalar(@array)>).
+
+=item STORESIZE this, count
+
+Sets the total number of items in the tied array associated with
+object I<this> to be I<count>. If this makes the array larger then
+class's mapping of C<undef> should be returned for new positions.
+If the array becomes smaller then entries beyond count should be
+deleted.
+
+=item EXTEND this, count
+
+Informative call that array is likely to grow to have I<count> entries.
+Can be used to optimize allocation. This method need do nothing.
+
+=item EXISTS this, key
+
+Verify that the element at index I<key> exists in the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
+=item DELETE this, key
+
+Delete the element at index I<key> from the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
+=item CLEAR this
+
+Clear (remove, delete, ...) all values from the tied array associated with
+object I<this>.
+
+=item DESTROY this
+
+Normal object destructor method.
+
+=item PUSH this, LIST
+
+Append elements of LIST to the array.
+
+=item POP this
+
+Remove last element of the array and return it.
+
+=item SHIFT this
+
+Remove the first element of the array (shifting other elements down)
+and return it.
+
+=item UNSHIFT this, LIST
+
+Insert LIST elements at the beginning of the array, moving existing elements
+up to make room.
+
+=item SPLICE this, offset, length, LIST
+
+Perform the equivalent of C<splice> on the array.
+
+I<offset> is optional and defaults to zero, negative values count back
+from the end of the array.
+
+I<length> is optional and defaults to rest of the array.
+
+I<LIST> may be empty.
+
+Returns a list of the original I<length> elements at I<offset>.
+
+=back
+
+=head1 CAVEATS
+
+There is no support at present for tied @ISA. There is a potential conflict
+between magic entries needed to notice setting of @ISA, and those needed to
+implement 'tie'.
+
+Very little consideration has been given to the behaviour of tied arrays
+when C<$[> is not default value of zero.
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/EncryptedHash.pm b/Master/tlpkg/tlperl.straw/lib/Tie/EncryptedHash.pm
new file mode 100755
index 00000000000..9b9979895cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/EncryptedHash.pm
@@ -0,0 +1,451 @@
+#!/usr/bin/perl -s
+##
+## Tie::EncryptedHash - A tied hash with encrypted fields.
+##
+## Copyright (c) 2000, Vipul Ved Prakash. All rights reserved.
+## This code is based on Damian Conway's Tie::SecureHash.
+##
+## $Id: EncryptedHash.pm,v 1.8 2000/09/02 19:23:00 vipul Exp vipul $
+## vi:expandtab=1;ts=4;
+
+package Tie::EncryptedHash;
+
+use strict;
+use vars qw($VERSION $strict);
+use Digest::MD5 qw(md5_base64);
+use Crypt::CBC;
+use Data::Dumper;
+use Carp;
+
+( $VERSION ) = '$Revision: 1.8 $' =~ /\s(\d+\.\d+)\s/;
+
+my $DEBUG = 0;
+
+sub debug {
+ return undef unless $DEBUG;
+ my ($caller, undef) = caller;
+ my (undef,undef,$line,$sub) = caller(1); $sub =~ s/.*://;
+ $sub = sprintf "%10s()%4d",$sub,$line;
+ print "$sub " . (shift) . "\n";
+}
+
+# sub new {
+# my ($class,%args) = @_;
+# my %self = (); tie %self, $class;
+# my $self = bless \%self, $class;
+# $self->{__password} = $args{__password} if $args{__password};
+# $self->{__cipher} = $args{__cipher} || qq{Blowfish};
+# return $self;
+# }
+
+sub new {
+ my ($class,%args) = @_;
+ my $self = {}; tie %$self, $class;
+ bless $self, $class;
+ $self->{__password} = $args{__password} if $args{__password};
+ $self->{__cipher} = $args{__cipher} || qq{Blowfish};
+ return $self;
+}
+
+
+sub _access {
+
+ my ($self, $key, $caller, $file, $value, $delete) = @_;
+ my $class = ref $self || $self;
+ # SPECIAL ATTRIBUTE
+ if ( $key =~ /(__password|__hide|__scaffolding|__cipher)$/ ) {
+ my $key = $1;
+ unless($value||$delete) {return undef unless $caller eq $class}
+ if ($delete && ($key =~ /__password/)) {
+ for (keys %{$$self{__scaffolding}}) {
+ if ( ref $self->{$_} ) {
+ $self->{$_} = encrypt($self->{$_}, $self->{__scaffolding}{$_}, $self->{__cipher});
+ delete $self->{__scaffolding}{$_};
+ }
+ }
+ }
+ delete $$self{$key} if $delete;
+ return $self->{$key} = $value if $value;
+ return $self->{$key};
+ # SECRET FIELD
+ } elsif ( $key =~ m/^(_{1}[^_][^:]*)$/ ||$key =~ m/.*?::(_{1}[^_][^:]*)/ ) {
+ my $ctext = $self->{$1};
+ if ( ref $ctext && !($value)) { # ENCRYPT REF AT FETCH
+ my $pass = $self->{__scaffolding}{$1} || $self->{__password};
+ return undef unless $pass;
+ $self->{$1} = encrypt($ctext, $pass, $self->{__cipher});
+ return $self->FETCH ($1);
+ }
+ my $ptext = qq{}; my $isnot = !( exists $self->{$1} );
+ my $auth = verify($self,$1);
+ return undef if !($auth) && ref $self->{$1};
+ return undef if !($auth) && $self->{__hide};
+ if ($auth && $auth ne "1") { $ptext = $auth }
+ if ($value && $auth) { # STORE
+ if ( ref $value ) {
+ $self->{__scaffolding}{$1} = $self->{__password}; $ctext = $value;
+ } else {
+ my $key = $1;
+ unless ($self->{__password}) {
+ if ($value =~ m:^\S+\s\S{22}\s:) {
+ return $self->{$key} = $value;
+ } else { return undef }
+ }
+ $ctext = encrypt($value, $self->{__password}, $self->{__cipher});
+ }
+ $self->{$1} = $ctext;
+ return $value;
+ } elsif ($auth && $delete) { # DELETE
+ delete $$self{$1}
+ } elsif ($isnot && (!($value))) { # DOESN'T EXIST
+ return;
+ } elsif ((!($auth)) && $ctext) {
+ return $ctext; # FETCH return ciphertext
+ } elsif ($auth && !($isnot)) { # FETCH return plaintext
+ if (ref $ptext) {
+ $self->{$1} = $ptext;
+ $self->{__scaffolding}{$1} = $self->{__password}; # Ref counting mechanism
+ return $self->{$1};
+ }
+ }
+ return undef unless $auth;
+ return $ptext;
+ # PUBLIC FIELD
+ } elsif ( $key =~ m/([^:]*)$/ || $key =~ m/.*?::([^:]*)/ ) {
+ $self->{$1} = $value if $value;
+ delete $$self{$1} if $delete;
+ return $self->{$1} if $self->{$1};
+ return undef;
+ }
+
+}
+
+sub encrypt { # ($plaintext, $password, $cipher)
+ $_[0] = qq{REF }. Data::Dumper->new([$_[0]])->Indent(0)->Terse(0)->Purity(1)->Dumpxs if ref $_[0];
+ return qq{$_[2] } . md5_base64($_[0]) .qq{ } .
+ Crypt::CBC->new($_[1],$_[2])->encrypt_hex($_[0])
+}
+
+sub decrypt { # ($cipher $md5sum $ciphertext, $password)
+ return undef unless $_[1];
+ my ($m, $d, $c) = split /\s/,$_[0];
+ my $ptext = Crypt::CBC->new($_[1],$m)->decrypt_hex($c);
+ my $check = md5_base64($ptext);
+ if ( $d eq $check ) {
+ if ($ptext =~ /^REF (.*)/is) {
+ my ($VAR1,$VAR2,$VAR3,$VAR4,$VAR5,$VAR6,$VAR7,$VAR8);
+ return eval qq{$1};
+ }
+ return $ptext;
+ }
+}
+
+sub verify { # ($self, $key)
+ my ($self, $key) = splice @_,0,2;
+ # debug ("$self->{__scaffolding}{$key}, $self->{__password}, $self->{$key}");
+ return 1 unless $key =~ m:^_:;
+ return 1 unless exists $self->{$key};
+ return undef if ref $self->{$key} && ($self->{__scaffolding}{$key} ne
+ $self->{__password});
+ my $ptext = decrypt($self->{$key}, $self->{__password});
+ return $ptext if $ptext;
+}
+
+sub each { CORE::each %{$_[0]} }
+sub keys { CORE::keys %{$_[0]} }
+sub values { CORE::values %{$_[0]} }
+sub exists { CORE::exists $_[0]->{$_[1]} }
+
+sub TIEHASH # ($class, @args)
+{
+ my $class = ref($_[0]) || $_[0];
+ my $self = bless {}, $class;
+ $self->{__password} = $_[1] if $_[1];
+ $self->{__cipher} = $_[2] || qq{Blowfish};
+ return $self;
+}
+
+sub FETCH # ($self, $key)
+{
+ my ($self, $key) = @_;
+ my $entry = _access($self,$key,(caller)[0..1]);
+ return $entry if $entry;
+}
+
+sub STORE # ($self, $key, $value)
+{
+ my ($self, $key, $value) = @_;
+ my $entry = _access($self,$key,(caller)[0..1],$value);
+ return $entry if $entry;
+}
+
+sub DELETE # ($self, $key)
+{
+ my ($self, $key) = @_;
+ return _access($self,$key,(caller)[0..1],'',1);
+}
+
+sub CLEAR # ($self)
+{
+ my ($self) = @_;
+ return undef if grep { ! $self->verify($_) }
+ grep { ! /__/ } CORE::keys %{$self};
+ %{$self} = ();
+}
+
+sub EXISTS # ($self, $key)
+{
+ my ($self, $key) = @_;
+ my @context = (caller)[0..1];
+ return _access($self,$key,@context) ? 1 : '';
+}
+
+sub FIRSTKEY # ($self)
+{
+ my ($self) = @_;
+ CORE::keys %{$self};
+ goto &NEXTKEY;
+}
+
+sub NEXTKEY # ($self)
+{
+ my $self = $_[0]; my $key;
+ my @context = (caller)[0..1];
+ while (defined($key = CORE::each %{$self})) {
+ last if eval { _access($self,$key,@context) }
+ }
+ return $key;
+}
+
+sub DESTROY # ($self)
+{
+}
+
+1;
+__END__
+
+
+=head1 NAME
+
+Tie::EncryptedHash - Hashes (and objects based on hashes) with encrypting fields.
+
+=head1 SYNOPSIS
+
+ use Tie::EncryptedHash;
+
+ my %s = ();
+ tie %s, Tie::EncryptedHash, 'passwd';
+
+ $s{foo} = "plaintext"; # Normal field, stored in plaintext.
+ print $s{foo}; # (plaintext)
+
+ $s{_bar} = "signature"; # Fieldnames that begin in single
+ # underscore are encrypted.
+ print $s{_bar}; # (signature) Though, while the password
+ # is set, they behave like normal fields.
+ delete $s{__password}; # Delete password to disable access
+ # to encrypting fields.
+ print $s{_bar}; # (Blowfish NuRVFIr8UCAJu5AWY0w...)
+
+ $s{__password} = 'passwd'; # Restore password to gain access.
+ print $s{_bar}; # (signature)
+
+ $s{_baz}{a}{b} = 42; # Refs are fine, we encrypt them too.
+
+
+=head1 DESCRIPTION
+
+Tie::EncryptedHash augments Perl hash semantics to build secure, encrypting
+containers of data. Tie::EncryptedHash introduces special hash fields that
+are coupled with encrypt/decrypt routines to encrypt assignments at STORE()
+and decrypt retrievals at FETCH(). By design, I<encrypting fields> are
+associated with keys that begin in single underscore. The remaining
+keyspace is used for accessing normal hash fields, which are retained
+without modification.
+
+While the password is set, a Tie::EncryptedHash behaves exactly like a
+standard Perl hash. This is its I<transparent mode> of access. Encrypting
+and normal fields are identical in this mode. When password is deleted,
+encrypting fields are accessible only as ciphertext. This is
+Tie::EncryptedHash's I<opaque mode> of access, optimized for serialization.
+
+Encryption is done with Crypt::CBC(3) which encrypts in the cipher block
+chaining mode with Blowfish, DES or IDEA. Tie::EncryptedHash uses Blowfish
+by default, but can be instructed to employ any cipher supported by
+Crypt::CBC(3).
+
+=head1 MOTIVATION
+
+Tie::EncryptedHash was designed for storage and communication of key
+material used in public key cryptography algorithms. I abstracted out the
+mechanism for encrypting selected fields of a structured data record because
+of the sheer convenience of this data security method.
+
+Quite often, applications that require data confidentiality eschew strong
+cryptography in favor of OS-based access control mechanisms because of the
+additional costs of cryptography integration. Besides cipher
+implementations, which are available as ready-to-deploy perl modules, use of
+cryptography in an application requires code to aid conversion and
+representation of encrypted data. This code is usually encapsulated in a
+data access layer that manages encryption, decryption, access control and
+re-structuring of flat plaintext according to a data model.
+Tie::EncryptedHash provides these functions under the disguise of a Perl
+hash so perl applications can use strong cryptography without the cost of
+implementing a complex data access layer.
+
+
+=head1 CONSTRUCTION
+
+=head2 Tied Hash
+
+C<tie %h, Tie::EncryptedHash, 'Password', 'Cipher';>
+
+Ties %h to Tie::EncryptedHash and sets the value of password and cipher to
+'Password' and 'Cipher'. Both arguments are optional.
+
+=head2 Blessed Object
+
+C<$h = new Tie::EncryptedHash __password => 'Password',
+ __cipher => 'Cipher';>
+
+The new() constructor returns an object that is both tied and blessed into
+Tie::EncryptedHash. Both arguments are optional. When used in this manner,
+Tie::EncryptedHash behaves like a class with encrypting data members.
+
+=head1 RESERVED ATTRIBUTES
+
+The attributes __password, __cipher and __hide are reserved for
+communication with object methods. They are "write-only" from everywhere
+except the class to which the hash is tied. __scaffolding is inaccessible.
+Tie::EncryptedHash stores the current encryption password and some transient
+data structures in these fields and restricts access to them on need-to-know
+basis.
+
+=head2 __password
+
+C<$h{__password} = "new password";
+delete $h{__password};>
+
+The password is stored under the attribute C<__password>. In addition to
+specifying a password at construction, assigning to the __password attribute
+sets the current encryption password to the assigned value. Deleting the
+__password unsets it and switches the hash into opaque mode.
+
+=head2 __cipher
+
+C<$h{__cipher} = 'DES'; $h{__cipher} = 'Blowfish';>
+
+The cipher used for encryption/decryption is stored under the attribute
+__cipher. The value defaults to 'Blowfish'.
+
+=head2 __hide
+
+C<$h{__hide} = 1;>
+
+Setting this attribute I<hides> encrypting fields in opaque mode. 'undef'
+is returned at FETCH() and EXISTS().
+
+=head1 BEHAVIOR
+
+=head2 References
+
+A reference stored in an encrypting field is serialized before encryption.
+The data structure represented by the reference is folded into a single line
+of ciphertext which is stored under the first level key. In the opaque
+mode, therefore, only the first level of keys of the hash will be visible.
+
+=head2 Opaque Mode
+
+The opaque mode introduces several other constraints on access of encrypting
+fields. Encrypting fields return ciphertext on FETCH() unless __hide
+attribute is set, which forces Tie::EncryptedHash to behave as if encrypting
+fields don't exist. Irrespective of __hide, however, DELETE() and CLEAR()
+fail in opaque mode. So does STORE() on an existing encrypting field.
+Plaintext assignments to encrypting fields are silently ignored, but
+ciphertext assignments are fine. Ciphertext assignments can be used to move
+data between different EncryptedHashes.
+
+=head2 Multiple Passwords and Ciphers
+
+Modality of Tie::EncryptedHash's access system breaks down when more than
+one password is used to with different encrypting fields. This is a
+feature. Tie::EncryptedHash lets you mix passwords and ciphers in the same
+hash. Assign new values to __password and __cipher and create a new
+encrypting field. Transparent mode will be restricted to fields encrypted
+with the current password.
+
+=head2 Error Handling
+
+Tie::Encrypted silently ignores access errors. It doesn't carp/croak when
+you perform an illegal operation (like assign plaintext to an encrypting
+field in opaque mode). This is to prevent data lossage, the kind that
+results from abnormal termination of applications.
+
+=head1 QUIRKS
+
+=head2 Autovivification
+
+Due to the nature of autovivified references (which spring into existence
+when an undefined reference is dereferenced), references are stored as
+plaintext in transparent mode. Analogous ciphertext representations are
+maintained in parallel and restored to encrypting fields when password is
+deleted. This process is completely transparent to the user, though it's
+advisable to delete the password after the final assignment to a
+Tie::EncryptedHash. This ensures plaintext representations and scaffolding
+data structures are duly flushed.
+
+=head2 Data::Dumper
+
+Serialization of references is done with Data::Dumper, therefore the nature
+of data that can be assigned to encrypting fields is limited by what
+Data::Dumper can grok. We set $Data::Dumper::Purity = 1, so
+self-referential and recursive structures should be OK.
+
+=head2 Speed
+
+Tie::EncryptedHash'es keep their contents encrypted as much as possible, so
+there's a rather severe speed penalty. With Blowfish, STORE() on
+EncryptedHash can be upto 70 times slower than a standard perl hash.
+Reference STORE()'es will be quicker, but speed gain will be adjusted at
+FETCH(). FETCH() is about 35 times slower than a standard perl hash. DES
+affords speed improvements of upto 2x, but is not considered secure for
+long-term storage of data. These values were computed on a DELL PIII-300
+Mhz notebook with 128 Mb RAM running perl 5.003 on Linux 2.2.16. Variations
+in speed might be different on your machine.
+
+=head1 STANDARD USAGE
+
+The standard usage for this module would be something along the lines of:
+populate Tie::EncryptedHash with sensitive data, delete the password,
+serialize the encrypted hash with Data::Dumper, store the result on disk or
+send it over the wire to another machine. Later, when the sensitive data is
+required, procure the EncryptedHash, set the password and accesses the
+encrypted data fields.
+
+=head1 SEE ALSO
+
+Data::Dumper(3),
+Crypt::CBC(3),
+Crypt::DES(3),
+Crypt::Blowfish(3),
+Tie::SecureHash(3)
+
+=head1 ACKNOWLEDGEMENTS
+
+The framework of Tie::EncryptedHash derives heavily from Damian Conway's
+Tie::SecureHash. Objects that are blessed as well as tied are just one of
+the pleasant side-effects of stealing Damian's code. Thanks to Damian for
+this brilliant module.
+
+PacificNet (http://www.pacificnet.net) loaned me the aforementioned notebook
+to hack from the comfort of my bed. Thanks folks!
+
+=head1 AUTHOR
+
+Vipul Ved Prakash <mail@vipul.net>
+
+=head1 LICENSE
+
+This module is distributed under the same license as Perl itself.
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/File.pm b/Master/tlpkg/tlperl.straw/lib/Tie/File.pm
new file mode 100755
index 00000000000..9528ab1bfdb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/File.pm
@@ -0,0 +1,2632 @@
+
+package Tie::File;
+require 5.005;
+use Carp ':DEFAULT', 'confess';
+use POSIX 'SEEK_SET';
+use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
+sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }
+
+
+$VERSION = "0.97_02";
+my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes
+my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
+my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful
+
+my %good_opt = map {$_ => 1, "-$_" => 1}
+ qw(memory dw_size mode recsep discipline
+ autodefer autochomp autodefer_threshhold concurrent);
+
+sub TIEARRAY {
+ if (@_ % 2 != 0) {
+ croak "usage: tie \@array, $_[0], filename, [option => value]...";
+ }
+ my ($pack, $file, %opts) = @_;
+
+ # transform '-foo' keys into 'foo' keys
+ for my $key (keys %opts) {
+ unless ($good_opt{$key}) {
+ croak("$pack: Unrecognized option '$key'\n");
+ }
+ my $okey = $key;
+ if ($key =~ s/^-+//) {
+ $opts{$key} = delete $opts{$okey};
+ }
+ }
+
+ if ($opts{concurrent}) {
+ croak("$pack: concurrent access not supported yet\n");
+ }
+
+ unless (defined $opts{memory}) {
+ # default is the larger of the default cache size and the
+ # deferred-write buffer size (if specified)
+ $opts{memory} = $DEFAULT_MEMORY_SIZE;
+ $opts{memory} = $opts{dw_size}
+ if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE;
+ # Dora Winifred Read
+ }
+ $opts{dw_size} = $opts{memory} unless defined $opts{dw_size};
+ if ($opts{dw_size} > $opts{memory}) {
+ croak("$pack: dw_size may not be larger than total memory allocation\n");
+ }
+ # are we in deferred-write mode?
+ $opts{defer} = 0 unless defined $opts{defer};
+ $opts{deferred} = {}; # no records are presently deferred
+ $opts{deferred_s} = 0; # count of total bytes in ->{deferred}
+ $opts{deferred_max} = -1; # empty
+
+ # What's a good way to arrange that this class can be overridden?
+ $opts{cache} = Tie::File::Cache->new($opts{memory});
+
+ # autodeferment is enabled by default
+ $opts{autodefer} = 1 unless defined $opts{autodefer};
+ $opts{autodeferring} = 0; # but is not initially active
+ $opts{ad_history} = [];
+ $opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD
+ unless defined $opts{autodefer_threshhold};
+ $opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD
+ unless defined $opts{autodefer_filelen_threshhold};
+
+ $opts{offsets} = [0];
+ $opts{filename} = $file;
+ unless (defined $opts{recsep}) {
+ $opts{recsep} = _default_recsep();
+ }
+ $opts{recseplen} = length($opts{recsep});
+ if ($opts{recseplen} == 0) {
+ croak "Empty record separator not supported by $pack";
+ }
+
+ $opts{autochomp} = 1 unless defined $opts{autochomp};
+
+ $opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode};
+ $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
+ $opts{sawlastrec} = undef;
+
+ my $fh;
+
+ if (UNIVERSAL::isa($file, 'GLOB')) {
+ # We use 1 here on the theory that some systems
+ # may not indicate failure if we use 0.
+ # MSWin32 does not indicate failure with 0, but I don't know if
+ # it will indicate failure with 1 or not.
+ unless (seek $file, 1, SEEK_SET) {
+ croak "$pack: your filehandle does not appear to be seekable";
+ }
+ seek $file, 0, SEEK_SET; # put it back
+ $fh = $file; # setting binmode is the user's problem
+ } elsif (ref $file) {
+ croak "usage: tie \@array, $pack, filename, [option => value]...";
+ } else {
+ # $fh = \do { local *FH }; # XXX this is buggy
+ if ($] < 5.006) {
+ # perl 5.005 and earlier don't autovivify filehandles
+ require Symbol;
+ $fh = Symbol::gensym();
+ }
+ sysopen $fh, $file, $opts{mode}, 0666 or return;
+ binmode $fh;
+ ++$opts{ourfh};
+ }
+ { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
+ if (defined $opts{discipline} && $] >= 5.006) {
+ # This avoids a compile-time warning under 5.005
+ eval 'binmode($fh, $opts{discipline})';
+ croak $@ if $@ =~ /unknown discipline/i;
+ die if $@;
+ }
+ $opts{fh} = $fh;
+
+ bless \%opts => $pack;
+}
+
+sub FETCH {
+ my ($self, $n) = @_;
+ my $rec;
+
+ # check the defer buffer
+ $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n};
+ $rec = $self->_fetch($n) unless defined $rec;
+
+ # inlined _chomp1
+ substr($rec, - $self->{recseplen}) = ""
+ if defined $rec && $self->{autochomp};
+ $rec;
+}
+
+# Chomp many records in-place; return nothing useful
+sub _chomp {
+ my $self = shift;
+ return unless $self->{autochomp};
+ if ($self->{autochomp}) {
+ for (@_) {
+ next unless defined;
+ substr($_, - $self->{recseplen}) = "";
+ }
+ }
+}
+
+# Chomp one record in-place; return modified record
+sub _chomp1 {
+ my ($self, $rec) = @_;
+ return $rec unless $self->{autochomp};
+ return unless defined $rec;
+ substr($rec, - $self->{recseplen}) = "";
+ $rec;
+}
+
+sub _fetch {
+ my ($self, $n) = @_;
+
+ # check the record cache
+ { my $cached = $self->{cache}->lookup($n);
+ return $cached if defined $cached;
+ }
+
+ if ($#{$self->{offsets}} < $n) {
+ return if $self->{eof}; # request for record beyond end of file
+ my $o = $self->_fill_offsets_to($n);
+ # If it's still undefined, there is no such record, so return 'undef'
+ return unless defined $o;
+ }
+
+ my $fh = $self->{FH};
+ $self->_seek($n); # we can do this now that offsets is populated
+ my $rec = $self->_read_record;
+
+# If we happen to have just read the first record, check to see if
+# the length of the record matches what 'tell' says. If not, Tie::File
+# won't work, and should drop dead.
+#
+# if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) {
+# if (defined $self->{discipline}) {
+# croak "I/O discipline $self->{discipline} not supported";
+# } else {
+# croak "File encoding not supported";
+# }
+# }
+
+ $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing};
+ $rec;
+}
+
+sub STORE {
+ my ($self, $n, $rec) = @_;
+ die "STORE called from _check_integrity!" if $DIAGNOSTIC;
+
+ $self->_fixrecs($rec);
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history($n);
+ }
+
+ return $self->_store_deferred($n, $rec) if $self->_is_deferring;
+
+
+ # We need this to decide whether the new record will fit
+ # It incidentally populates the offsets table
+ # Note we have to do this before we alter the cache
+ # 20020324 Wait, but this DOES alter the cache. TODO BUG?
+ my $oldrec = $self->_fetch($n);
+
+ if (not defined $oldrec) {
+ # We're storing a record beyond the end of the file
+ $self->_extend_file_to($n+1);
+ $oldrec = $self->{recsep};
+ }
+# return if $oldrec eq $rec; # don't bother
+ my $len_diff = length($rec) - length($oldrec);
+
+ # length($oldrec) here is not consistent with text mode TODO XXX BUG
+ $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec));
+ $self->_oadjust([$n, 1, $rec]);
+ $self->{cache}->update($n, $rec);
+}
+
+sub _store_deferred {
+ my ($self, $n, $rec) = @_;
+ $self->{cache}->remove($n);
+ my $old_deferred = $self->{deferred}{$n};
+
+ if (defined $self->{deferred_max} && $n > $self->{deferred_max}) {
+ $self->{deferred_max} = $n;
+ }
+ $self->{deferred}{$n} = $rec;
+
+ my $len_diff = length($rec);
+ $len_diff -= length($old_deferred) if defined $old_deferred;
+ $self->{deferred_s} += $len_diff;
+ $self->{cache}->adj_limit(-$len_diff);
+ if ($self->{deferred_s} > $self->{dw_size}) {
+ $self->_flush;
+ } elsif ($self->_cache_too_full) {
+ $self->_cache_flush;
+ }
+}
+
+# Remove a single record from the deferred-write buffer without writing it
+# The record need not be present
+sub _delete_deferred {
+ my ($self, $n) = @_;
+ my $rec = delete $self->{deferred}{$n};
+ return unless defined $rec;
+
+ if (defined $self->{deferred_max}
+ && $n == $self->{deferred_max}) {
+ undef $self->{deferred_max};
+ }
+
+ $self->{deferred_s} -= length $rec;
+ $self->{cache}->adj_limit(length $rec);
+}
+
+sub FETCHSIZE {
+ my $self = shift;
+ my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets;
+
+ my $top_deferred = $self->_defer_max;
+ $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1;
+ $n;
+}
+
+sub STORESIZE {
+ my ($self, $len) = @_;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('STORESIZE');
+ }
+
+ my $olen = $self->FETCHSIZE;
+ return if $len == $olen; # Woo-hoo!
+
+ # file gets longer
+ if ($len > $olen) {
+ if ($self->_is_deferring) {
+ for ($olen .. $len-1) {
+ $self->_store_deferred($_, $self->{recsep});
+ }
+ } else {
+ $self->_extend_file_to($len);
+ }
+ return;
+ }
+
+ # file gets shorter
+ if ($self->_is_deferring) {
+ # TODO maybe replace this with map-plus-assignment?
+ for (grep $_ >= $len, keys %{$self->{deferred}}) {
+ $self->_delete_deferred($_);
+ }
+ $self->{deferred_max} = $len-1;
+ }
+
+ $self->_seek($len);
+ $self->_chop_file;
+ $#{$self->{offsets}} = $len;
+# $self->{offsets}[0] = 0; # in case we just chopped this
+
+ $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys);
+}
+
+### OPTIMIZE ME
+### It should not be necessary to do FETCHSIZE
+### Just seek to the end of the file.
+sub PUSH {
+ my $self = shift;
+ $self->SPLICE($self->FETCHSIZE, scalar(@_), @_);
+
+ # No need to return:
+ # $self->FETCHSIZE; # because av.c takes care of this for me
+}
+
+sub POP {
+ my $self = shift;
+ my $size = $self->FETCHSIZE;
+ return if $size == 0;
+# print STDERR "# POPPITY POP POP POP\n";
+ scalar $self->SPLICE($size-1, 1);
+}
+
+sub SHIFT {
+ my $self = shift;
+ scalar $self->SPLICE(0, 1);
+}
+
+sub UNSHIFT {
+ my $self = shift;
+ $self->SPLICE(0, 0, @_);
+ # $self->FETCHSIZE; # av.c takes care of this for me
+}
+
+sub CLEAR {
+ my $self = shift;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('CLEAR');
+ }
+
+ $self->_seekb(0);
+ $self->_chop_file;
+ $self->{cache}->set_limit($self->{memory});
+ $self->{cache}->empty;
+ @{$self->{offsets}} = (0);
+ %{$self->{deferred}}= ();
+ $self->{deferred_s} = 0;
+ $self->{deferred_max} = -1;
+}
+
+sub EXTEND {
+ my ($self, $n) = @_;
+
+ # No need to pre-extend anything in this case
+ return if $self->_is_deferring;
+
+ $self->_fill_offsets_to($n);
+ $self->_extend_file_to($n);
+}
+
+sub DELETE {
+ my ($self, $n) = @_;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('DELETE');
+ }
+
+ my $lastrec = $self->FETCHSIZE-1;
+ my $rec = $self->FETCH($n);
+ $self->_delete_deferred($n) if $self->_is_deferring;
+ if ($n == $lastrec) {
+ $self->_seek($n);
+ $self->_chop_file;
+ $#{$self->{offsets}}--;
+ $self->{cache}->remove($n);
+ # perhaps in this case I should also remove trailing null records?
+ # 20020316
+ # Note that delete @a[-3..-1] deletes the records in the wrong order,
+ # so we only chop the very last one out of the file. We could repair this
+ # by tracking deleted records inside the object.
+ } elsif ($n < $lastrec) {
+ $self->STORE($n, "");
+ }
+ $rec;
+}
+
+sub EXISTS {
+ my ($self, $n) = @_;
+ return 1 if exists $self->{deferred}{$n};
+ $n < $self->FETCHSIZE;
+}
+
+sub SPLICE {
+ my $self = shift;
+
+ if ($self->{autodefer}) {
+ $self->_annotate_ad_history('SPLICE');
+ }
+
+ $self->_flush if $self->_is_deferring; # move this up?
+ if (wantarray) {
+ $self->_chomp(my @a = $self->_splice(@_));
+ @a;
+ } else {
+ $self->_chomp1(scalar $self->_splice(@_));
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+ $self->flush if $self->_is_deferring;
+ $self->{cache}->delink if defined $self->{cache}; # break circular link
+ if ($self->{fh} and $self->{ourfh}) {
+ delete $self->{ourfh};
+ close delete $self->{fh};
+ }
+}
+
+sub _splice {
+ my ($self, $pos, $nrecs, @data) = @_;
+ my @result;
+
+ $pos = 0 unless defined $pos;
+
+ # Deal with negative and other out-of-range positions
+ # Also set default for $nrecs
+ {
+ my $oldsize = $self->FETCHSIZE;
+ $nrecs = $oldsize unless defined $nrecs;
+ my $oldpos = $pos;
+
+ if ($pos < 0) {
+ $pos += $oldsize;
+ if ($pos < 0) {
+ croak "Modification of non-creatable array value attempted, subscript $oldpos";
+ }
+ }
+
+ if ($pos > $oldsize) {
+ return unless @data;
+ $pos = $oldsize; # This is what perl does for normal arrays
+ }
+
+ # The manual is very unclear here
+ if ($nrecs < 0) {
+ $nrecs = $oldsize - $pos + $nrecs;
+ $nrecs = 0 if $nrecs < 0;
+ }
+
+ # nrecs is too big---it really means "until the end"
+ # 20030507
+ if ($nrecs + $pos > $oldsize) {
+ $nrecs = $oldsize - $pos;
+ }
+ }
+
+ $self->_fixrecs(@data);
+ my $data = join '', @data;
+ my $datalen = length $data;
+ my $oldlen = 0;
+
+ # compute length of data being removed
+ for ($pos .. $pos+$nrecs-1) {
+ last unless defined $self->_fill_offsets_to($_);
+ my $rec = $self->_fetch($_);
+ last unless defined $rec;
+ push @result, $rec;
+
+ # Why don't we just use length($rec) here?
+ # Because that record might have come from the cache. _splice
+ # might have been called to flush out the deferred-write records,
+ # and in this case length($rec) is the length of the record to be
+ # *written*, not the length of the actual record in the file. But
+ # the offsets are still true. 20020322
+ $oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_]
+ if defined $self->{offsets}[$_+1];
+ }
+ $self->_fill_offsets_to($pos+$nrecs);
+
+ # Modify the file
+ $self->_mtwrite($data, $self->{offsets}[$pos], $oldlen);
+ # Adjust the offsets table
+ $self->_oadjust([$pos, $nrecs, @data]);
+
+ { # Take this read cache stuff out into a separate function
+ # You made a half-attempt to put it into _oadjust.
+ # Finish something like that up eventually.
+ # STORE also needs to do something similarish
+
+ # update the read cache, part 1
+ # modified records
+ for ($pos .. $pos+$nrecs-1) {
+ my $new = $data[$_-$pos];
+ if (defined $new) {
+ $self->{cache}->update($_, $new);
+ } else {
+ $self->{cache}->remove($_);
+ }
+ }
+
+ # update the read cache, part 2
+ # moved records - records past the site of the change
+ # need to be renumbered
+ # Maybe merge this with the previous block?
+ {
+ my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys;
+ my @newkeys = map $_-$nrecs+@data, @oldkeys;
+ $self->{cache}->rekey(\@oldkeys, \@newkeys);
+ }
+
+ # Now there might be too much data in the cache, if we spliced out
+ # some short records and spliced in some long ones. If so, flush
+ # the cache.
+ $self->_cache_flush;
+ }
+
+ # Yes, the return value of 'splice' *is* actually this complicated
+ wantarray ? @result : @result ? $result[-1] : undef;
+}
+
+
+# write data into the file
+# $data is the data to be written.
+# it should be written at position $pos, and should overwrite
+# exactly $len of the following bytes.
+# Note that if length($data) > $len, the subsequent bytes will have to
+# be moved up, and if length($data) < $len, they will have to
+# be moved down
+sub _twrite {
+ my ($self, $data, $pos, $len) = @_;
+
+ unless (defined $pos) {
+ die "\$pos was undefined in _twrite";
+ }
+
+ my $len_diff = length($data) - $len;
+
+ if ($len_diff == 0) { # Woo-hoo!
+ my $fh = $self->{fh};
+ $self->_seekb($pos);
+ $self->_write_record($data);
+ return; # well, that was easy.
+ }
+
+ # the two records are of different lengths
+ # our strategy here: rewrite the tail of the file,
+ # reading ahead one buffer at a time
+ # $bufsize is required to be at least as large as the data we're overwriting
+ my $bufsize = _bufsize($len_diff);
+ my ($writepos, $readpos) = ($pos, $pos+$len);
+ my $next_block;
+ my $more_data;
+
+ # Seems like there ought to be a way to avoid the repeated code
+ # and the special case here. The read(1) is also a little weird.
+ # Think about this.
+ do {
+ $self->_seekb($readpos);
+ my $br = read $self->{fh}, $next_block, $bufsize;
+ $more_data = read $self->{fh}, my($dummy), 1;
+ $self->_seekb($writepos);
+ $self->_write_record($data);
+ $readpos += $br;
+ $writepos += length $data;
+ $data = $next_block;
+ } while $more_data;
+ $self->_seekb($writepos);
+ $self->_write_record($next_block);
+
+ # There might be leftover data at the end of the file
+ $self->_chop_file if $len_diff < 0;
+}
+
+# _iwrite(D, S, E)
+# Insert text D at position S.
+# Let C = E-S-|D|. If C < 0; die.
+# Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E).
+# Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched.
+#
+# In a later version, don't read the entire intervening area into
+# memory at once; do the copying block by block.
+sub _iwrite {
+ my $self = shift;
+ my ($D, $s, $e) = @_;
+ my $d = length $D;
+ my $c = $e-$s-$d;
+ local *FH = $self->{fh};
+ confess "Not enough space to insert $d bytes between $s and $e"
+ if $c < 0;
+ confess "[$s,$e) is an invalid insertion range" if $e < $s;
+
+ $self->_seekb($s);
+ read FH, my $buf, $e-$s;
+
+ $D .= substr($buf, 0, $c, "");
+
+ $self->_seekb($s);
+ $self->_write_record($D);
+
+ return $buf;
+}
+
+# Like _twrite, but the data-pos-len triple may be repeated; you may
+# write several chunks. All the writing will be done in
+# one pass. Chunks SHALL be in ascending order and SHALL NOT overlap.
+sub _mtwrite {
+ my $self = shift;
+ my $unwritten = "";
+ my $delta = 0;
+
+ @_ % 3 == 0
+ or die "Arguments to _mtwrite did not come in groups of three";
+
+ while (@_) {
+ my ($data, $pos, $len) = splice @_, 0, 3;
+ my $end = $pos + $len; # The OLD end of the segment to be replaced
+ $data = $unwritten . $data;
+ $delta -= length($unwritten);
+ $unwritten = "";
+ $pos += $delta; # This is where the data goes now
+ my $dlen = length $data;
+ $self->_seekb($pos);
+ if ($len >= $dlen) { # the data will fit
+ $self->_write_record($data);
+ $delta += ($dlen - $len); # everything following moves down by this much
+ $data = ""; # All the data in the buffer has been written
+ } else { # won't fit
+ my $writable = substr($data, 0, $len - $delta, "");
+ $self->_write_record($writable);
+ $delta += ($dlen - $len); # everything following moves down by this much
+ }
+
+ # At this point we've written some but maybe not all of the data.
+ # There might be a gap to close up, or $data might still contain a
+ # bunch of unwritten data that didn't fit.
+ my $ndlen = length $data;
+ if ($delta == 0) {
+ $self->_write_record($data);
+ } elsif ($delta < 0) {
+ # upcopy (close up gap)
+ if (@_) {
+ $self->_upcopy($end, $end + $delta, $_[1] - $end);
+ } else {
+ $self->_upcopy($end, $end + $delta);
+ }
+ } else {
+ # downcopy (insert data that didn't fit; replace this data in memory
+ # with _later_ data that doesn't fit)
+ if (@_) {
+ $unwritten = $self->_downcopy($data, $end, $_[1] - $end);
+ } else {
+ # Make the file longer to accommodate the last segment that doesn'
+ $unwritten = $self->_downcopy($data, $end);
+ }
+ }
+ }
+}
+
+# Copy block of data of length $len from position $spos to position $dpos
+# $dpos must be <= $spos
+#
+# If $len is undefined, go all the way to the end of the file
+# and then truncate it ($spos - $dpos bytes will be removed)
+sub _upcopy {
+ my $blocksize = 8192;
+ my ($self, $spos, $dpos, $len) = @_;
+ if ($dpos > $spos) {
+ die "source ($spos) was upstream of destination ($dpos) in _upcopy";
+ } elsif ($dpos == $spos) {
+ return;
+ }
+
+ while (! defined ($len) || $len > 0) {
+ my $readsize = ! defined($len) ? $blocksize
+ : $len > $blocksize ? $blocksize
+ : $len;
+
+ my $fh = $self->{fh};
+ $self->_seekb($spos);
+ my $bytes_read = read $fh, my($data), $readsize;
+ $self->_seekb($dpos);
+ if ($data eq "") {
+ $self->_chop_file;
+ last;
+ }
+ $self->_write_record($data);
+ $spos += $bytes_read;
+ $dpos += $bytes_read;
+ $len -= $bytes_read if defined $len;
+ }
+}
+
+# Write $data into a block of length $len at position $pos,
+# moving everything in the block forwards to make room.
+# Instead of writing the last length($data) bytes from the block
+# (because there isn't room for them any longer) return them.
+#
+# Undefined $len means 'until the end of the file'
+sub _downcopy {
+ my $blocksize = 8192;
+ my ($self, $data, $pos, $len) = @_;
+ my $fh = $self->{fh};
+
+ while (! defined $len || $len > 0) {
+ my $readsize = ! defined($len) ? $blocksize
+ : $len > $blocksize? $blocksize : $len;
+ $self->_seekb($pos);
+ read $fh, my($old), $readsize;
+ my $last_read_was_short = length($old) < $readsize;
+ $data .= $old;
+ my $writable;
+ if ($last_read_was_short) {
+ # If last read was short, then $data now contains the entire rest
+ # of the file, so there's no need to write only one block of it
+ $writable = $data;
+ $data = "";
+ } else {
+ $writable = substr($data, 0, $readsize, "");
+ }
+ last if $writable eq "";
+ $self->_seekb($pos);
+ $self->_write_record($writable);
+ last if $last_read_was_short && $data eq "";
+ $len -= $readsize if defined $len;
+ $pos += $readsize;
+ }
+ return $data;
+}
+
+# Adjust the object data structures following an '_mtwrite'
+# Arguments are
+# [$pos, $nrecs, @length] items
+# indicating that $nrecs records were removed at $recpos (a record offset)
+# and replaced with records of length @length...
+# Arguments guarantee that $recpos is strictly increasing.
+# No return value
+sub _oadjust {
+ my $self = shift;
+ my $delta = 0;
+ my $delta_recs = 0;
+ my $prev_end = -1;
+ my %newkeys;
+
+ for (@_) {
+ my ($pos, $nrecs, @data) = @$_;
+ $pos += $delta_recs;
+
+ # Adjust the offsets of the records after the previous batch up
+ # to the first new one of this batch
+ for my $i ($prev_end+2 .. $pos - 1) {
+ $self->{offsets}[$i] += $delta;
+ $newkey{$i} = $i + $delta_recs;
+ }
+
+ $prev_end = $pos + @data - 1; # last record moved on this pass
+
+ # Remove the offsets for the removed records;
+ # replace with the offsets for the inserted records
+ my @newoff = ($self->{offsets}[$pos] + $delta);
+ for my $i (0 .. $#data) {
+ my $newlen = length $data[$i];
+ push @newoff, $newoff[$i] + $newlen;
+ $delta += $newlen;
+ }
+
+ for my $i ($pos .. $pos+$nrecs-1) {
+ last if $i+1 > $#{$self->{offsets}};
+ my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i];
+ $delta -= $oldlen;
+ }
+
+# # also this data has changed, so update it in the cache
+# for (0 .. $#data) {
+# $self->{cache}->update($pos + $_, $data[$_]);
+# }
+# if ($delta_recs) {
+# my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys;
+# my @newkeys = map $_ + $delta_recs, @oldkeys;
+# $self->{cache}->rekey(\@oldkeys, \@newkeys);
+# }
+
+ # replace old offsets with new
+ splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff;
+ # What if we just spliced out the end of the offsets table?
+ # shouldn't we clear $self->{eof}? Test for this XXX BUG TODO
+
+ $delta_recs += @data - $nrecs; # net change in total number of records
+ }
+
+ # The trailing records at the very end of the file
+ if ($delta) {
+ for my $i ($prev_end+2 .. $#{$self->{offsets}}) {
+ $self->{offsets}[$i] += $delta;
+ }
+ }
+
+ # If we scrubbed out all known offsets, regenerate the trivial table
+ # that knows that the file does indeed start at 0.
+ $self->{offsets}[0] = 0 unless @{$self->{offsets}};
+ # If the file got longer, the offsets table is no longer complete
+ # $self->{eof} = 0 if $delta_recs > 0;
+
+ # Now there might be too much data in the cache, if we spliced out
+ # some short records and spliced in some long ones. If so, flush
+ # the cache.
+ $self->_cache_flush;
+}
+
+# If a record does not already end with the appropriate terminator
+# string, append one.
+sub _fixrecs {
+ my $self = shift;
+ for (@_) {
+ $_ = "" unless defined $_;
+ $_ .= $self->{recsep}
+ unless substr($_, - $self->{recseplen}) eq $self->{recsep};
+ }
+}
+
+
+################################################################
+#
+# Basic read, write, and seek
+#
+
+# seek to the beginning of record #$n
+# Assumes that the offsets table is already correctly populated
+#
+# Note that $n=-1 has a special meaning here: It means the start of
+# the last known record; this may or may not be the very last record
+# in the file, depending on whether the offsets table is fully populated.
+#
+sub _seek {
+ my ($self, $n) = @_;
+ my $o = $self->{offsets}[$n];
+ defined($o)
+ or confess("logic error: undefined offset for record $n");
+ seek $self->{fh}, $o, SEEK_SET
+ or confess "Couldn't seek filehandle: $!"; # "Should never happen."
+}
+
+# seek to byte $b in the file
+sub _seekb {
+ my ($self, $b) = @_;
+ seek $self->{fh}, $b, SEEK_SET
+ or die "Couldn't seek filehandle: $!"; # "Should never happen."
+}
+
+# populate the offsets table up to the beginning of record $n
+# return the offset of record $n
+sub _fill_offsets_to {
+ my ($self, $n) = @_;
+
+ return $self->{offsets}[$n] if $self->{eof};
+
+ my $fh = $self->{fh};
+ local *OFF = $self->{offsets};
+ my $rec;
+
+ until ($#OFF >= $n) {
+ $self->_seek(-1); # tricky -- see comment at _seek
+ $rec = $self->_read_record;
+ if (defined $rec) {
+ push @OFF, int(tell $fh); # Tels says that int() saves memory here
+ } else {
+ $self->{eof} = 1;
+ return; # It turns out there is no such record
+ }
+ }
+
+ # we have now read all the records up to record n-1,
+ # so we can return the offset of record n
+ $OFF[$n];
+}
+
+sub _fill_offsets {
+ my ($self) = @_;
+
+ my $fh = $self->{fh};
+ local *OFF = $self->{offsets};
+
+ $self->_seek(-1); # tricky -- see comment at _seek
+
+ # Tels says that inlining read_record() would make this loop
+ # five times faster. 20030508
+ while ( defined $self->_read_record()) {
+ # int() saves us memory here
+ push @OFF, int(tell $fh);
+ }
+
+ $self->{eof} = 1;
+ $#OFF;
+}
+
+# assumes that $rec is already suitably terminated
+sub _write_record {
+ my ($self, $rec) = @_;
+ my $fh = $self->{fh};
+ local $\ = "";
+ print $fh $rec
+ or die "Couldn't write record: $!"; # "Should never happen."
+# $self->{_written} += length($rec);
+}
+
+sub _read_record {
+ my $self = shift;
+ my $rec;
+ { local $/ = $self->{recsep};
+ my $fh = $self->{fh};
+ $rec = <$fh>;
+ }
+ return unless defined $rec;
+ if (substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
+ # improperly terminated final record --- quietly fix it.
+# my $ac = substr($rec, -$self->{recseplen});
+# $ac =~ s/\n/\\n/g;
+ $self->{sawlastrec} = 1;
+ unless ($self->{rdonly}) {
+ local $\ = "";
+ my $fh = $self->{fh};
+ print $fh $self->{recsep};
+ }
+ $rec .= $self->{recsep};
+ }
+# $self->{_read} += length($rec) if defined $rec;
+ $rec;
+}
+
+sub _rw_stats {
+ my $self = shift;
+ @{$self}{'_read', '_written'};
+}
+
+################################################################
+#
+# Read cache management
+
+sub _cache_flush {
+ my ($self) = @_;
+ $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s});
+}
+
+sub _cache_too_full {
+ my $self = shift;
+ $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory};
+}
+
+################################################################
+#
+# File custodial services
+#
+
+
+# We have read to the end of the file and have the offsets table
+# entirely populated. Now we need to write a new record beyond
+# the end of the file. We prepare for this by writing
+# empty records into the file up to the position we want
+#
+# assumes that the offsets table already contains the offset of record $n,
+# if it exists, and extends to the end of the file if not.
+sub _extend_file_to {
+ my ($self, $n) = @_;
+ $self->_seek(-1); # position after the end of the last record
+ my $pos = $self->{offsets}[-1];
+
+ # the offsets table has one entry more than the total number of records
+ my $extras = $n - $#{$self->{offsets}};
+
+ # Todo : just use $self->{recsep} x $extras here?
+ while ($extras-- > 0) {
+ $self->_write_record($self->{recsep});
+ push @{$self->{offsets}}, int(tell $self->{fh});
+ }
+}
+
+# Truncate the file at the current position
+sub _chop_file {
+ my $self = shift;
+ truncate $self->{fh}, tell($self->{fh});
+}
+
+
+# compute the size of a buffer suitable for moving
+# all the data in a file forward $n bytes
+# ($n may be negative)
+# The result should be at least $n.
+sub _bufsize {
+ my $n = shift;
+ return 8192 if $n <= 0;
+ my $b = $n & ~8191;
+ $b += 8192 if $n & 8191;
+ $b;
+}
+
+################################################################
+#
+# Miscellaneous public methods
+#
+
+# Lock the file
+sub flock {
+ my ($self, $op) = @_;
+ unless (@_ <= 3) {
+ my $pack = ref $self;
+ croak "Usage: $pack\->flock([OPERATION])";
+ }
+ my $fh = $self->{fh};
+ $op = LOCK_EX unless defined $op;
+ my $locked = flock $fh, $op;
+
+ if ($locked && ($op & (LOCK_EX | LOCK_SH))) {
+ # If you're locking the file, then presumably it's because
+ # there might have been a write access by another process.
+ # In that case, the read cache contents and the offsets table
+ # might be invalid, so discard them. 20030508
+ $self->{offsets} = [0];
+ $self->{cache}->empty;
+ }
+
+ $locked;
+}
+
+# Get/set autochomp option
+sub autochomp {
+ my $self = shift;
+ if (@_) {
+ my $old = $self->{autochomp};
+ $self->{autochomp} = shift;
+ $old;
+ } else {
+ $self->{autochomp};
+ }
+}
+
+# Get offset table entries; returns offset of nth record
+sub offset {
+ my ($self, $n) = @_;
+
+ if ($#{$self->{offsets}} < $n) {
+ return if $self->{eof}; # request for record beyond the end of file
+ my $o = $self->_fill_offsets_to($n);
+ # If it's still undefined, there is no such record, so return 'undef'
+ return unless defined $o;
+ }
+
+ $self->{offsets}[$n];
+}
+
+sub discard_offsets {
+ my $self = shift;
+ $self->{offsets} = [0];
+}
+
+################################################################
+#
+# Matters related to deferred writing
+#
+
+# Defer writes
+sub defer {
+ my $self = shift;
+ $self->_stop_autodeferring;
+ @{$self->{ad_history}} = ();
+ $self->{defer} = 1;
+}
+
+# Flush deferred writes
+#
+# This could be better optimized to write the file in one pass, instead
+# of one pass per block of records. But that will require modifications
+# to _twrite, so I should have a good _twrite test suite first.
+sub flush {
+ my $self = shift;
+
+ $self->_flush;
+ $self->{defer} = 0;
+}
+
+sub _old_flush {
+ my $self = shift;
+ my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
+
+ while (@writable) {
+ # gather all consecutive records from the front of @writable
+ my $first_rec = shift @writable;
+ my $last_rec = $first_rec+1;
+ ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
+ --$last_rec;
+ $self->_fill_offsets_to($last_rec);
+ $self->_extend_file_to($last_rec);
+ $self->_splice($first_rec, $last_rec-$first_rec+1,
+ @{$self->{deferred}}{$first_rec .. $last_rec});
+ }
+
+ $self->_discard; # clear out defered-write-cache
+}
+
+sub _flush {
+ my $self = shift;
+ my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
+ my @args;
+ my @adjust;
+
+ while (@writable) {
+ # gather all consecutive records from the front of @writable
+ my $first_rec = shift @writable;
+ my $last_rec = $first_rec+1;
+ ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
+ --$last_rec;
+ my $end = $self->_fill_offsets_to($last_rec+1);
+ if (not defined $end) {
+ $self->_extend_file_to($last_rec);
+ $end = $self->{offsets}[$last_rec];
+ }
+ my ($start) = $self->{offsets}[$first_rec];
+ push @args,
+ join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data
+ $start, # position
+ $end-$start; # length
+ push @adjust, [$first_rec, # starting at this position...
+ $last_rec-$first_rec+1, # this many records...
+ # are replaced with these...
+ @{$self->{deferred}}{$first_rec .. $last_rec},
+ ];
+ }
+
+ $self->_mtwrite(@args); # write multiple record groups
+ $self->_discard; # clear out defered-write-cache
+ $self->_oadjust(@adjust);
+}
+
+# Discard deferred writes and disable future deferred writes
+sub discard {
+ my $self = shift;
+ $self->_discard;
+ $self->{defer} = 0;
+}
+
+# Discard deferred writes, but retain old deferred writing mode
+sub _discard {
+ my $self = shift;
+ %{$self->{deferred}} = ();
+ $self->{deferred_s} = 0;
+ $self->{deferred_max} = -1;
+ $self->{cache}->set_limit($self->{memory});
+}
+
+# Deferred writing is enabled, either explicitly ($self->{defer})
+# or automatically ($self->{autodeferring})
+sub _is_deferring {
+ my $self = shift;
+ $self->{defer} || $self->{autodeferring};
+}
+
+# The largest record number of any deferred record
+sub _defer_max {
+ my $self = shift;
+ return $self->{deferred_max} if defined $self->{deferred_max};
+ my $max = -1;
+ for my $key (keys %{$self->{deferred}}) {
+ $max = $key if $key > $max;
+ }
+ $self->{deferred_max} = $max;
+ $max;
+}
+
+################################################################
+#
+# Matters related to autodeferment
+#
+
+# Get/set autodefer option
+sub autodefer {
+ my $self = shift;
+ if (@_) {
+ my $old = $self->{autodefer};
+ $self->{autodefer} = shift;
+ if ($old) {
+ $self->_stop_autodeferring;
+ @{$self->{ad_history}} = ();
+ }
+ $old;
+ } else {
+ $self->{autodefer};
+ }
+}
+
+# The user is trying to store record #$n Record that in the history,
+# and then enable (or disable) autodeferment if that seems useful.
+# Note that it's OK for $n to be a non-number, as long as the function
+# is prepared to deal with that. Nobody else looks at the ad_history.
+#
+# Now, what does the ad_history mean, and what is this function doing?
+# Essentially, the idea is to enable autodeferring when we see that the
+# user has made three consecutive STORE calls to three consecutive records.
+# ("Three" is actually ->{autodefer_threshhold}.)
+# A STORE call for record #$n inserts $n into the autodefer history,
+# and if the history contains three consecutive records, we enable
+# autodeferment. An ad_history of [X, Y] means that the most recent
+# STOREs were for records X, X+1, ..., Y, in that order.
+#
+# Inserting a nonconsecutive number erases the history and starts over.
+#
+# Performing a special operation like SPLICE erases the history.
+#
+# There's one special case: CLEAR means that CLEAR was just called.
+# In this case, we prime the history with [-2, -1] so that if the next
+# write is for record 0, autodeferring goes on immediately. This is for
+# the common special case of "@a = (...)".
+#
+sub _annotate_ad_history {
+ my ($self, $n) = @_;
+ return unless $self->{autodefer}; # feature is disabled
+ return if $self->{defer}; # already in explicit defer mode
+ return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold};
+
+ local *H = $self->{ad_history};
+ if ($n eq 'CLEAR') {
+ @H = (-2, -1); # prime the history with fake records
+ $self->_stop_autodeferring;
+ } elsif ($n =~ /^\d+$/) {
+ if (@H == 0) {
+ @H = ($n, $n);
+ } else { # @H == 2
+ if ($H[1] == $n-1) { # another consecutive record
+ $H[1]++;
+ if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) {
+ $self->{autodeferring} = 1;
+ }
+ } else { # nonconsecutive- erase and start over
+ @H = ($n, $n);
+ $self->_stop_autodeferring;
+ }
+ }
+ } else { # SPLICE or STORESIZE or some such
+ @H = ();
+ $self->_stop_autodeferring;
+ }
+}
+
+# If autodeferring was enabled, cut it out and discard the history
+sub _stop_autodeferring {
+ my $self = shift;
+ if ($self->{autodeferring}) {
+ $self->_flush;
+ }
+ $self->{autodeferring} = 0;
+}
+
+################################################################
+
+
+# This is NOT a method. It is here for two reasons:
+# 1. To factor a fairly complicated block out of the constructor
+# 2. To provide access for the test suite, which need to be sure
+# files are being written properly.
+sub _default_recsep {
+ my $recsep = $/;
+ if ($^O eq 'MSWin32') { # Dos too?
+ # Windows users expect files to be terminated with \r\n
+ # But $/ is set to \n instead
+ # Note that this also transforms \n\n into \r\n\r\n.
+ # That is a feature.
+ $recsep =~ s/\n/\r\n/g;
+ }
+ $recsep;
+}
+
+# Utility function for _check_integrity
+sub _ci_warn {
+ my $msg = shift;
+ $msg =~ s/\n/\\n/g;
+ $msg =~ s/\r/\\r/g;
+ print "# $msg\n";
+}
+
+# Given a file, make sure the cache is consistent with the
+# file contents and the internal data structures are consistent with
+# each other. Returns true if everything checks out, false if not
+#
+# The $file argument is no longer used. It is retained for compatibility
+# with the existing test suite.
+sub _check_integrity {
+ my ($self, $file, $warn) = @_;
+ my $rsl = $self->{recseplen};
+ my $rs = $self->{recsep};
+ my $good = 1;
+ local *_; # local $_ does not work here
+ local $DIAGNOSTIC = 1;
+
+ if (not defined $rs) {
+ _ci_warn("recsep is undef!");
+ $good = 0;
+ } elsif ($rs eq "") {
+ _ci_warn("recsep is empty!");
+ $good = 0;
+ } elsif ($rsl != length $rs) {
+ my $ln = length $rs;
+ _ci_warn("recsep <$rs> has length $ln, should be $rsl");
+ $good = 0;
+ }
+
+ if (not defined $self->{offsets}[0]) {
+ _ci_warn("offset 0 is missing!");
+ $good = 0;
+
+ } elsif ($self->{offsets}[0] != 0) {
+ _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!");
+ $good = 0;
+ }
+
+ my $cached = 0;
+ {
+ local *F = $self->{fh};
+ seek F, 0, SEEK_SET;
+ local $. = 0;
+ local $/ = $rs;
+
+ while (<F>) {
+ my $n = $. - 1;
+ my $cached = $self->{cache}->_produce($n);
+ my $offset = $self->{offsets}[$.];
+ my $ao = tell F;
+ if (defined $offset && $offset != $ao) {
+ _ci_warn("rec $n: offset <$offset> actual <$ao>");
+ $good = 0;
+ }
+ if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) {
+ $good = 0;
+ _ci_warn("rec $n: cached <$cached> actual <$_>");
+ }
+ if (defined $cached && substr($cached, -$rsl) ne $rs) {
+ $good = 0;
+ _ci_warn("rec $n in the cache is missing the record separator");
+ }
+ if (! defined $offset && $self->{eof}) {
+ $good = 0;
+ _ci_warn("The offset table was marked complete, but it is missing element $.");
+ }
+ }
+ if (@{$self->{offsets}} > $.+1) {
+ $good = 0;
+ my $n = @{$self->{offsets}};
+ _ci_warn("The offset table has $n items, but the file has only $.");
+ }
+
+ my $deferring = $self->_is_deferring;
+ for my $n ($self->{cache}->ckeys) {
+ my $r = $self->{cache}->_produce($n);
+ $cached += length($r);
+ next if $n+1 <= $.; # checked this already
+ _ci_warn("spurious caching of record $n");
+ $good = 0;
+ }
+ my $b = $self->{cache}->bytes;
+ if ($cached != $b) {
+ _ci_warn("cache size is $b, should be $cached");
+ $good = 0;
+ }
+ }
+
+ # That cache has its own set of tests
+ $good = 0 unless $self->{cache}->_check_integrity;
+
+ # Now let's check the deferbuffer
+ # Unless deferred writing is enabled, it should be empty
+ if (! $self->_is_deferring && %{$self->{deferred}}) {
+ _ci_warn("deferred writing disabled, but deferbuffer nonempty");
+ $good = 0;
+ }
+
+ # Any record in the deferbuffer should *not* be present in the readcache
+ my $deferred_s = 0;
+ while (my ($n, $r) = each %{$self->{deferred}}) {
+ $deferred_s += length($r);
+ if (defined $self->{cache}->_produce($n)) {
+ _ci_warn("record $n is in the deferbuffer *and* the readcache");
+ $good = 0;
+ }
+ if (substr($r, -$rsl) ne $rs) {
+ _ci_warn("rec $n in the deferbuffer is missing the record separator");
+ $good = 0;
+ }
+ }
+
+ # Total size of deferbuffer should match internal total
+ if ($deferred_s != $self->{deferred_s}) {
+ _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s");
+ $good = 0;
+ }
+
+ # Total size of deferbuffer should not exceed the specified limit
+ if ($deferred_s > $self->{dw_size}) {
+ _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit of $self->{dw_size}");
+ $good = 0;
+ }
+
+ # Total size of cached data should not exceed the specified limit
+ if ($deferred_s + $cached > $self->{memory}) {
+ my $total = $deferred_s + $cached;
+ _ci_warn("total stored data size is $total which exceeds the limit of $self->{memory}");
+ $good = 0;
+ }
+
+ # Stuff related to autodeferment
+ if (!$self->{autodefer} && @{$self->{ad_history}}) {
+ _ci_warn("autodefer is disabled, but ad_history is nonempty");
+ $good = 0;
+ }
+ if ($self->{autodeferring} && $self->{defer}) {
+ _ci_warn("both autodeferring and explicit deferring are active");
+ $good = 0;
+ }
+ if (@{$self->{ad_history}} == 0) {
+ # That's OK, no additional tests required
+ } elsif (@{$self->{ad_history}} == 2) {
+ my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}};
+ if (@non_number) {
+ my $msg;
+ { local $" = ')(';
+ $msg = "ad_history contains non-numbers (@{$self->{ad_history}})";
+ }
+ _ci_warn($msg);
+ $good = 0;
+ } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) {
+ _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}");
+ $good = 0;
+ }
+ } else {
+ _ci_warn("ad_history has bad length <@{$self->{ad_history}}>");
+ $good = 0;
+ }
+
+ $good;
+}
+
+################################################################
+#
+# Tie::File::Cache
+#
+# Read cache
+
+package Tie::File::Cache;
+$Tie::File::Cache::VERSION = $Tie::File::VERSION;
+use Carp ':DEFAULT', 'confess';
+
+sub HEAP () { 0 }
+sub HASH () { 1 }
+sub MAX () { 2 }
+sub BYTES() { 3 }
+#sub STAT () { 4 } # Array with request statistics for each record
+#sub MISS () { 5 } # Total number of cache misses
+#sub REQ () { 6 } # Total number of cache requests
+use strict 'vars';
+
+sub new {
+ my ($pack, $max) = @_;
+ local *_;
+ croak "missing argument to ->new" unless defined $max;
+ my $self = [];
+ bless $self => $pack;
+ @$self = (Tie::File::Heap->new($self), {}, $max, 0);
+ $self;
+}
+
+sub adj_limit {
+ my ($self, $n) = @_;
+ $self->[MAX] += $n;
+}
+
+sub set_limit {
+ my ($self, $n) = @_;
+ $self->[MAX] = $n;
+}
+
+# For internal use only
+# Will be called by the heap structure to notify us that a certain
+# piece of data has moved from one heap element to another.
+# $k is the hash key of the item
+# $n is the new index into the heap at which it is stored
+# If $n is undefined, the item has been removed from the heap.
+sub _heap_move {
+ my ($self, $k, $n) = @_;
+ if (defined $n) {
+ $self->[HASH]{$k} = $n;
+ } else {
+ delete $self->[HASH]{$k};
+ }
+}
+
+sub insert {
+ my ($self, $key, $val) = @_;
+ local *_;
+ croak "missing argument to ->insert" unless defined $key;
+ unless (defined $self->[MAX]) {
+ confess "undefined max" ;
+ }
+ confess "undefined val" unless defined $val;
+ return if length($val) > $self->[MAX];
+
+# if ($self->[STAT]) {
+# $self->[STAT][$key] = 1;
+# return;
+# }
+
+ my $oldnode = $self->[HASH]{$key};
+ if (defined $oldnode) {
+ my $oldval = $self->[HEAP]->set_val($oldnode, $val);
+ $self->[BYTES] -= length($oldval);
+ } else {
+ $self->[HEAP]->insert($key, $val);
+ }
+ $self->[BYTES] += length($val);
+ $self->flush if $self->[BYTES] > $self->[MAX];
+}
+
+sub expire {
+ my $self = shift;
+ my $old_data = $self->[HEAP]->popheap;
+ return unless defined $old_data;
+ $self->[BYTES] -= length $old_data;
+ $old_data;
+}
+
+sub remove {
+ my ($self, @keys) = @_;
+ my @result;
+
+# if ($self->[STAT]) {
+# for my $key (@keys) {
+# $self->[STAT][$key] = 0;
+# }
+# return;
+# }
+
+ for my $key (@keys) {
+ next unless exists $self->[HASH]{$key};
+ my $old_data = $self->[HEAP]->remove($self->[HASH]{$key});
+ $self->[BYTES] -= length $old_data;
+ push @result, $old_data;
+ }
+ @result;
+}
+
+sub lookup {
+ my ($self, $key) = @_;
+ local *_;
+ croak "missing argument to ->lookup" unless defined $key;
+
+# if ($self->[STAT]) {
+# $self->[MISS]++ if $self->[STAT][$key]++ == 0;
+# $self->[REQ]++;
+# my $hit_rate = 1 - $self->[MISS] / $self->[REQ];
+# # Do some testing to determine this threshhold
+# $#$self = STAT - 1 if $hit_rate > 0.20;
+# }
+
+ if (exists $self->[HASH]{$key}) {
+ $self->[HEAP]->lookup($self->[HASH]{$key});
+ } else {
+ return;
+ }
+}
+
+# For internal use only
+sub _produce {
+ my ($self, $key) = @_;
+ my $loc = $self->[HASH]{$key};
+ return unless defined $loc;
+ $self->[HEAP][$loc][2];
+}
+
+# For internal use only
+sub _promote {
+ my ($self, $key) = @_;
+ $self->[HEAP]->promote($self->[HASH]{$key});
+}
+
+sub empty {
+ my ($self) = @_;
+ %{$self->[HASH]} = ();
+ $self->[BYTES] = 0;
+ $self->[HEAP]->empty;
+# @{$self->[STAT]} = ();
+# $self->[MISS] = 0;
+# $self->[REQ] = 0;
+}
+
+sub is_empty {
+ my ($self) = @_;
+ keys %{$self->[HASH]} == 0;
+}
+
+sub update {
+ my ($self, $key, $val) = @_;
+ local *_;
+ croak "missing argument to ->update" unless defined $key;
+ if (length($val) > $self->[MAX]) {
+ my ($oldval) = $self->remove($key);
+ $self->[BYTES] -= length($oldval) if defined $oldval;
+ } elsif (exists $self->[HASH]{$key}) {
+ my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val);
+ $self->[BYTES] += length($val);
+ $self->[BYTES] -= length($oldval) if defined $oldval;
+ } else {
+ $self->[HEAP]->insert($key, $val);
+ $self->[BYTES] += length($val);
+ }
+ $self->flush;
+}
+
+sub rekey {
+ my ($self, $okeys, $nkeys) = @_;
+ local *_;
+ my %map;
+ @map{@$okeys} = @$nkeys;
+ croak "missing argument to ->rekey" unless defined $nkeys;
+ croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys;
+ my %adjusted; # map new keys to heap indices
+ # You should be able to cut this to one loop TODO XXX
+ for (0 .. $#$okeys) {
+ $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]};
+ }
+ while (my ($nk, $ix) = each %adjusted) {
+ # @{$self->[HASH]}{keys %adjusted} = values %adjusted;
+ $self->[HEAP]->rekey($ix, $nk);
+ $self->[HASH]{$nk} = $ix;
+ }
+}
+
+sub ckeys {
+ my $self = shift;
+ my @a = keys %{$self->[HASH]};
+ @a;
+}
+
+# Return total amount of cached data
+sub bytes {
+ my $self = shift;
+ $self->[BYTES];
+}
+
+# Expire oldest item from cache until cache size is smaller than $max
+sub reduce_size_to {
+ my ($self, $max) = @_;
+ until ($self->[BYTES] <= $max) {
+ # Note that Tie::File::Cache::expire has been inlined here
+ my $old_data = $self->[HEAP]->popheap;
+ return unless defined $old_data;
+ $self->[BYTES] -= length $old_data;
+ }
+}
+
+# Why not just $self->reduce_size_to($self->[MAX])?
+# Try this when things stabilize TODO XXX
+# If the cache is too full, expire the oldest records
+sub flush {
+ my $self = shift;
+ $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX];
+}
+
+# For internal use only
+sub _produce_lru {
+ my $self = shift;
+ $self->[HEAP]->expire_order;
+}
+
+BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
+
+sub _check_integrity { # For CACHE
+ my $self = shift;
+ my $good = 1;
+
+ # Test HEAP
+ $self->[HEAP]->_check_integrity or $good = 0;
+
+ # Test HASH
+ my $bytes = 0;
+ for my $k (keys %{$self->[HASH]}) {
+ if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) {
+ $good = 0;
+ _ci_warn "Cache hash key <$k> is non-numeric";
+ }
+
+ my $h = $self->[HASH]{$k};
+ if (! defined $h) {
+ $good = 0;
+ _ci_warn "Heap index number for key $k is undefined";
+ } elsif ($h == 0) {
+ $good = 0;
+ _ci_warn "Heap index number for key $k is zero";
+ } else {
+ my $j = $self->[HEAP][$h];
+ if (! defined $j) {
+ $good = 0;
+ _ci_warn "Heap contents key $k (=> $h) are undefined";
+ } else {
+ $bytes += length($j->[2]);
+ if ($k ne $j->[1]) {
+ $good = 0;
+ _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k";
+ }
+ }
+ }
+ }
+
+ # Test BYTES
+ if ($bytes != $self->[BYTES]) {
+ $good = 0;
+ _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]";
+ }
+
+ # Test MAX
+ if ($bytes > $self->[MAX]) {
+ $good = 0;
+ _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]";
+ }
+
+ return $good;
+}
+
+sub delink {
+ my $self = shift;
+ $self->[HEAP] = undef; # Bye bye heap
+}
+
+################################################################
+#
+# Tie::File::Heap
+#
+# Heap data structure for use by cache LRU routines
+
+package Tie::File::Heap;
+use Carp ':DEFAULT', 'confess';
+$Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION;
+sub SEQ () { 0 };
+sub KEY () { 1 };
+sub DAT () { 2 };
+
+sub new {
+ my ($pack, $cache) = @_;
+ die "$pack: Parent cache object $cache does not support _heap_move method"
+ unless eval { $cache->can('_heap_move') };
+ my $self = [[0,$cache,0]];
+ bless $self => $pack;
+}
+
+# Allocate a new sequence number, larger than all previously allocated numbers
+sub _nseq {
+ my $self = shift;
+ $self->[0][0]++;
+}
+
+sub _cache {
+ my $self = shift;
+ $self->[0][1];
+}
+
+sub _nelts {
+ my $self = shift;
+ $self->[0][2];
+}
+
+sub _nelts_inc {
+ my $self = shift;
+ ++$self->[0][2];
+}
+
+sub _nelts_dec {
+ my $self = shift;
+ --$self->[0][2];
+}
+
+sub is_empty {
+ my $self = shift;
+ $self->_nelts == 0;
+}
+
+sub empty {
+ my $self = shift;
+ $#$self = 0;
+ $self->[0][2] = 0;
+ $self->[0][0] = 0; # might as well reset the sequence numbers
+}
+
+# notify the parent cache object that we moved something
+sub _heap_move {
+ my $self = shift;
+ $self->_cache->_heap_move(@_);
+}
+
+# Insert a piece of data into the heap with the indicated sequence number.
+# The item with the smallest sequence number is always at the top.
+# If no sequence number is specified, allocate a new one and insert the
+# item at the bottom.
+sub insert {
+ my ($self, $key, $data, $seq) = @_;
+ $seq = $self->_nseq unless defined $seq;
+ $self->_insert_new([$seq, $key, $data]);
+}
+
+# Insert a new, fresh item at the bottom of the heap
+sub _insert_new {
+ my ($self, $item) = @_;
+ my $i = @$self;
+ $i = int($i/2) until defined $self->[$i/2];
+ $self->[$i] = $item;
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ $self->_nelts_inc;
+}
+
+# Insert [$data, $seq] pair at or below item $i in the heap.
+# If $i is omitted, default to 1 (the top element.)
+sub _insert {
+ my ($self, $item, $i) = @_;
+# $self->_check_loc($i) if defined $i;
+ $i = 1 unless defined $i;
+ until (! defined $self->[$i]) {
+ if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older
+ ($self->[$i], $item) = ($item, $self->[$i]);
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ }
+ # If either is undefined, go that way. Otherwise, choose at random
+ my $dir;
+ $dir = 0 if !defined $self->[2*$i];
+ $dir = 1 if !defined $self->[2*$i+1];
+ $dir = int(rand(2)) unless defined $dir;
+ $i = 2*$i + $dir;
+ }
+ $self->[$i] = $item;
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ $self->_nelts_inc;
+}
+
+# Remove the item at node $i from the heap, moving child items upwards.
+# The item with the smallest sequence number is always at the top.
+# Moving items upwards maintains this condition.
+# Return the removed item. Return undef if there was no item at node $i.
+sub remove {
+ my ($self, $i) = @_;
+ $i = 1 unless defined $i;
+ my $top = $self->[$i];
+ return unless defined $top;
+ while (1) {
+ my $ii;
+ my ($L, $R) = (2*$i, 2*$i+1);
+
+ # If either is undefined, go the other way.
+ # Otherwise, go towards the smallest.
+ last unless defined $self->[$L] || defined $self->[$R];
+ $ii = $R if not defined $self->[$L];
+ $ii = $L if not defined $self->[$R];
+ unless (defined $ii) {
+ $ii = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
+ }
+
+ $self->[$i] = $self->[$ii]; # Promote child to fill vacated spot
+ $self->[0][1]->_heap_move($self->[$i][KEY], $i);
+ $i = $ii; # Fill new vacated spot
+ }
+ $self->[0][1]->_heap_move($top->[KEY], undef);
+ undef $self->[$i];
+ $self->_nelts_dec;
+ return $top->[DAT];
+}
+
+sub popheap {
+ my $self = shift;
+ $self->remove(1);
+}
+
+# set the sequence number of the indicated item to a higher number
+# than any other item in the heap, and bubble the item down to the
+# bottom.
+sub promote {
+ my ($self, $n) = @_;
+# $self->_check_loc($n);
+ $self->[$n][SEQ] = $self->_nseq;
+ my $i = $n;
+ while (1) {
+ my ($L, $R) = (2*$i, 2*$i+1);
+ my $dir;
+ last unless defined $self->[$L] || defined $self->[$R];
+ $dir = $R unless defined $self->[$L];
+ $dir = $L unless defined $self->[$R];
+ unless (defined $dir) {
+ $dir = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
+ }
+ @{$self}[$i, $dir] = @{$self}[$dir, $i];
+ for ($i, $dir) {
+ $self->[0][1]->_heap_move($self->[$_][KEY], $_) if defined $self->[$_];
+ }
+ $i = $dir;
+ }
+}
+
+# Return item $n from the heap, promoting its LRU status
+sub lookup {
+ my ($self, $n) = @_;
+# $self->_check_loc($n);
+ my $val = $self->[$n];
+ $self->promote($n);
+ $val->[DAT];
+}
+
+
+# Assign a new value for node $n, promoting it to the bottom of the heap
+sub set_val {
+ my ($self, $n, $val) = @_;
+# $self->_check_loc($n);
+ my $oval = $self->[$n][DAT];
+ $self->[$n][DAT] = $val;
+ $self->promote($n);
+ return $oval;
+}
+
+# The hask key has changed for an item;
+# alter the heap's record of the hash key
+sub rekey {
+ my ($self, $n, $new_key) = @_;
+# $self->_check_loc($n);
+ $self->[$n][KEY] = $new_key;
+}
+
+sub _check_loc {
+ my ($self, $n) = @_;
+ unless (1 || defined $self->[$n]) {
+ confess "_check_loc($n) failed";
+ }
+}
+
+BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
+
+sub _check_integrity {
+ my $self = shift;
+ my $good = 1;
+ my %seq;
+
+ unless (eval {$self->[0][1]->isa("Tie::File::Cache")}) {
+ _ci_warn "Element 0 of heap corrupt";
+ $good = 0;
+ }
+ $good = 0 unless $self->_satisfies_heap_condition(1);
+ for my $i (2 .. $#{$self}) {
+ my $p = int($i/2); # index of parent node
+ if (defined $self->[$i] && ! defined $self->[$p]) {
+ _ci_warn "Element $i of heap defined, but parent $p isn't";
+ $good = 0;
+ }
+
+ if (defined $self->[$i]) {
+ if ($seq{$self->[$i][SEQ]}) {
+ my $seq = $self->[$i][SEQ];
+ _ci_warn "Nodes $i and $seq{$seq} both have SEQ=$seq";
+ $good = 0;
+ } else {
+ $seq{$self->[$i][SEQ]} = $i;
+ }
+ }
+ }
+
+ return $good;
+}
+
+sub _satisfies_heap_condition {
+ my $self = shift;
+ my $n = shift || 1;
+ my $good = 1;
+ for (0, 1) {
+ my $c = $n*2 + $_;
+ next unless defined $self->[$c];
+ if ($self->[$n][SEQ] >= $self->[$c]) {
+ _ci_warn "Node $n of heap does not predate node $c";
+ $good = 0 ;
+ }
+ $good = 0 unless $self->_satisfies_heap_condition($c);
+ }
+ return $good;
+}
+
+# Return a list of all the values, sorted by expiration order
+sub expire_order {
+ my $self = shift;
+ my @nodes = sort {$a->[SEQ] <=> $b->[SEQ]} $self->_nodes;
+ map { $_->[KEY] } @nodes;
+}
+
+sub _nodes {
+ my $self = shift;
+ my $i = shift || 1;
+ return unless defined $self->[$i];
+ ($self->[$i], $self->_nodes($i*2), $self->_nodes($i*2+1));
+}
+
+"Cogito, ergo sum."; # don't forget to return a true value from the file
+
+__END__
+
+=head1 NAME
+
+Tie::File - Access the lines of a disk file via a Perl array
+
+=head1 SYNOPSIS
+
+ # This file documents Tie::File version 0.97
+ use Tie::File;
+
+ tie @array, 'Tie::File', filename or die ...;
+
+ $array[13] = 'blah'; # line 13 of the file is now 'blah'
+ print $array[42]; # display line 42 of the file
+
+ $n_recs = @array; # how many records are in the file?
+ $#array -= 2; # chop two records off the end
+
+
+ for (@array) {
+ s/PERL/Perl/g; # Replace PERL with Perl everywhere in the file
+ }
+
+ # These are just like regular push, pop, unshift, shift, and splice
+ # Except that they modify the file in the way you would expect
+
+ push @array, new recs...;
+ my $r1 = pop @array;
+ unshift @array, new recs...;
+ my $r2 = shift @array;
+ @old_recs = splice @array, 3, 7, new recs...;
+
+ untie @array; # all finished
+
+
+=head1 DESCRIPTION
+
+C<Tie::File> represents a regular text file as a Perl array. Each
+element in the array corresponds to a record in the file. The first
+line of the file is element 0 of the array; the second line is element
+1, and so on.
+
+The file is I<not> loaded into memory, so this will work even for
+gigantic files.
+
+Changes to the array are reflected in the file immediately.
+
+Lazy people and beginners may now stop reading the manual.
+
+=head2 C<recsep>
+
+What is a 'record'? By default, the meaning is the same as for the
+C<E<lt>...E<gt>> operator: It's a string terminated by C<$/>, which is
+probably C<"\n">. (Minor exception: on DOS and Win32 systems, a
+'record' is a string terminated by C<"\r\n">.) You may change the
+definition of "record" by supplying the C<recsep> option in the C<tie>
+call:
+
+ tie @array, 'Tie::File', $file, recsep => 'es';
+
+This says that records are delimited by the string C<es>. If the file
+contained the following data:
+
+ Curse these pesky flies!\n
+
+then the C<@array> would appear to have four elements:
+
+ "Curse th"
+ "e p"
+ "ky fli"
+ "!\n"
+
+An undefined value is not permitted as a record separator. Perl's
+special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not
+emulated.
+
+Records read from the tied array do not have the record separator
+string on the end; this is to allow
+
+ $array[17] .= "extra";
+
+to work as expected.
+
+(See L<"autochomp">, below.) Records stored into the array will have
+the record separator string appended before they are written to the
+file, if they don't have one already. For example, if the record
+separator string is C<"\n">, then the following two lines do exactly
+the same thing:
+
+ $array[17] = "Cherry pie";
+ $array[17] = "Cherry pie\n";
+
+The result is that the contents of line 17 of the file will be
+replaced with "Cherry pie"; a newline character will separate line 17
+from line 18. This means that this code will do nothing:
+
+ chomp $array[17];
+
+Because the C<chomp>ed value will have the separator reattached when
+it is written back to the file. There is no way to create a file
+whose trailing record separator string is missing.
+
+Inserting records that I<contain> the record separator string is not
+supported by this module. It will probably produce a reasonable
+result, but what this result will be may change in a future version.
+Use 'splice' to insert records or to replace one record with several.
+
+=head2 C<autochomp>
+
+Normally, array elements have the record separator removed, so that if
+the file contains the text
+
+ Gold
+ Frankincense
+ Myrrh
+
+the tied array will appear to contain C<("Gold", "Frankincense",
+"Myrrh")>. If you set C<autochomp> to a false value, the record
+separator will not be removed. If the file above was tied with
+
+ tie @gifts, "Tie::File", $gifts, autochomp => 0;
+
+then the array C<@gifts> would appear to contain C<("Gold\n",
+"Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n",
+"Frankincense\r\n", "Myrrh\r\n")>.
+
+=head2 C<mode>
+
+Normally, the specified file will be opened for read and write access,
+and will be created if it does not exist. (That is, the flags
+C<O_RDWR | O_CREAT> are supplied in the C<open> call.) If you want to
+change this, you may supply alternative flags in the C<mode> option.
+See L<Fcntl> for a listing of available flags.
+For example:
+
+ # open the file if it exists, but fail if it does not exist
+ use Fcntl 'O_RDWR';
+ tie @array, 'Tie::File', $file, mode => O_RDWR;
+
+ # create the file if it does not exist
+ use Fcntl 'O_RDWR', 'O_CREAT';
+ tie @array, 'Tie::File', $file, mode => O_RDWR | O_CREAT;
+
+ # open an existing file in read-only mode
+ use Fcntl 'O_RDONLY';
+ tie @array, 'Tie::File', $file, mode => O_RDONLY;
+
+Opening the data file in write-only or append mode is not supported.
+
+=head2 C<memory>
+
+This is an upper limit on the amount of memory that C<Tie::File> will
+consume at any time while managing the file. This is used for two
+things: managing the I<read cache> and managing the I<deferred write
+buffer>.
+
+Records read in from the file are cached, to avoid having to re-read
+them repeatedly. If you read the same record twice, the first time it
+will be stored in memory, and the second time it will be fetched from
+the I<read cache>. The amount of data in the read cache will not
+exceed the value you specified for C<memory>. If C<Tie::File> wants
+to cache a new record, but the read cache is full, it will make room
+by expiring the least-recently visited records from the read cache.
+
+The default memory limit is 2Mib. You can adjust the maximum read
+cache size by supplying the C<memory> option. The argument is the
+desired cache size, in bytes.
+
+ # I have a lot of memory, so use a large cache to speed up access
+ tie @array, 'Tie::File', $file, memory => 20_000_000;
+
+Setting the memory limit to 0 will inhibit caching; records will be
+fetched from disk every time you examine them.
+
+The C<memory> value is not an absolute or exact limit on the memory
+used. C<Tie::File> objects contains some structures besides the read
+cache and the deferred write buffer, whose sizes are not charged
+against C<memory>.
+
+The cache itself consumes about 310 bytes per cached record, so if
+your file has many short records, you may want to decrease the cache
+memory limit, or else the cache overhead may exceed the size of the
+cached data.
+
+
+=head2 C<dw_size>
+
+(This is an advanced feature. Skip this section on first reading.)
+
+If you use deferred writing (See L<"Deferred Writing">, below) then
+data you write into the array will not be written directly to the
+file; instead, it will be saved in the I<deferred write buffer> to be
+written out later. Data in the deferred write buffer is also charged
+against the memory limit you set with the C<memory> option.
+
+You may set the C<dw_size> option to limit the amount of data that can
+be saved in the deferred write buffer. This limit may not exceed the
+total memory limit. For example, if you set C<dw_size> to 1000 and
+C<memory> to 2500, that means that no more than 1000 bytes of deferred
+writes will be saved up. The space available for the read cache will
+vary, but it will always be at least 1500 bytes (if the deferred write
+buffer is full) and it could grow as large as 2500 bytes (if the
+deferred write buffer is empty.)
+
+If you don't specify a C<dw_size>, it defaults to the entire memory
+limit.
+
+=head2 Option Format
+
+C<-mode> is a synonym for C<mode>. C<-recsep> is a synonym for
+C<recsep>. C<-memory> is a synonym for C<memory>. You get the
+idea.
+
+=head1 Public Methods
+
+The C<tie> call returns an object, say C<$o>. You may call
+
+ $rec = $o->FETCH($n);
+ $o->STORE($n, $rec);
+
+to fetch or store the record at line C<$n>, respectively; similarly
+the other tied array methods. (See L<perltie> for details.) You may
+also call the following methods on this object:
+
+=head2 C<flock>
+
+ $o->flock(MODE)
+
+will lock the tied file. C<MODE> has the same meaning as the second
+argument to the Perl built-in C<flock> function; for example
+C<LOCK_SH> or C<LOCK_EX | LOCK_NB>. (These constants are provided by
+the C<use Fcntl ':flock'> declaration.)
+
+C<MODE> is optional; the default is C<LOCK_EX>.
+
+C<Tie::File> maintains an internal table of the byte offset of each
+record it has seen in the file.
+
+When you use C<flock> to lock the file, C<Tie::File> assumes that the
+read cache is no longer trustworthy, because another process might
+have modified the file since the last time it was read. Therefore, a
+successful call to C<flock> discards the contents of the read cache
+and the internal record offset table.
+
+C<Tie::File> promises that the following sequence of operations will
+be safe:
+
+ my $o = tie @array, "Tie::File", $filename;
+ $o->flock;
+
+In particular, C<Tie::File> will I<not> read or write the file during
+the C<tie> call. (Exception: Using C<mode =E<gt> O_TRUNC> will, of
+course, erase the file during the C<tie> call. If you want to do this
+safely, then open the file without C<O_TRUNC>, lock the file, and use
+C<@array = ()>.)
+
+The best way to unlock a file is to discard the object and untie the
+array. It is probably unsafe to unlock the file without also untying
+it, because if you do, changes may remain unwritten inside the object.
+That is why there is no shortcut for unlocking. If you really want to
+unlock the file prematurely, you know what to do; if you don't know
+what to do, then don't do it.
+
+All the usual warnings about file locking apply here. In particular,
+note that file locking in Perl is B<advisory>, which means that
+holding a lock will not prevent anyone else from reading, writing, or
+erasing the file; it only prevents them from getting another lock at
+the same time. Locks are analogous to green traffic lights: If you
+have a green light, that does not prevent the idiot coming the other
+way from plowing into you sideways; it merely guarantees to you that
+the idiot does not also have a green light at the same time.
+
+=head2 C<autochomp>
+
+ my $old_value = $o->autochomp(0); # disable autochomp option
+ my $old_value = $o->autochomp(1); # enable autochomp option
+
+ my $ac = $o->autochomp(); # recover current value
+
+See L<"autochomp">, above.
+
+=head2 C<defer>, C<flush>, C<discard>, and C<autodefer>
+
+See L<"Deferred Writing">, below.
+
+=head2 C<offset>
+
+ $off = $o->offset($n);
+
+This method returns the byte offset of the start of the C<$n>th record
+in the file. If there is no such record, it returns an undefined
+value.
+
+=head1 Tying to an already-opened filehandle
+
+If C<$fh> is a filehandle, such as is returned by C<IO::File> or one
+of the other C<IO> modules, you may use:
+
+ tie @array, 'Tie::File', $fh, ...;
+
+Similarly if you opened that handle C<FH> with regular C<open> or
+C<sysopen>, you may use:
+
+ tie @array, 'Tie::File', \*FH, ...;
+
+Handles that were opened write-only won't work. Handles that were
+opened read-only will work as long as you don't try to modify the
+array. Handles must be attached to seekable sources of data---that
+means no pipes or sockets. If C<Tie::File> can detect that you
+supplied a non-seekable handle, the C<tie> call will throw an
+exception. (On Unix systems, it can detect this.)
+
+Note that Tie::File will only close any filehandles that it opened
+internally. If you passed it a filehandle as above, you "own" the
+filehandle, and are responsible for closing it after you have untied
+the @array.
+
+=head1 Deferred Writing
+
+(This is an advanced feature. Skip this section on first reading.)
+
+Normally, modifying a C<Tie::File> array writes to the underlying file
+immediately. Every assignment like C<$a[3] = ...> rewrites as much of
+the file as is necessary; typically, everything from line 3 through
+the end will need to be rewritten. This is the simplest and most
+transparent behavior. Performance even for large files is reasonably
+good.
+
+However, under some circumstances, this behavior may be excessively
+slow. For example, suppose you have a million-record file, and you
+want to do:
+
+ for (@FILE) {
+ $_ = "> $_";
+ }
+
+The first time through the loop, you will rewrite the entire file,
+from line 0 through the end. The second time through the loop, you
+will rewrite the entire file from line 1 through the end. The third
+time through the loop, you will rewrite the entire file from line 2 to
+the end. And so on.
+
+If the performance in such cases is unacceptable, you may defer the
+actual writing, and then have it done all at once. The following loop
+will perform much better for large files:
+
+ (tied @a)->defer;
+ for (@a) {
+ $_ = "> $_";
+ }
+ (tied @a)->flush;
+
+If C<Tie::File>'s memory limit is large enough, all the writing will
+done in memory. Then, when you call C<-E<gt>flush>, the entire file
+will be rewritten in a single pass.
+
+(Actually, the preceding discussion is something of a fib. You don't
+need to enable deferred writing to get good performance for this
+common case, because C<Tie::File> will do it for you automatically
+unless you specifically tell it not to. See L<"autodeferring">,
+below.)
+
+Calling C<-E<gt>flush> returns the array to immediate-write mode. If
+you wish to discard the deferred writes, you may call C<-E<gt>discard>
+instead of C<-E<gt>flush>. Note that in some cases, some of the data
+will have been written already, and it will be too late for
+C<-E<gt>discard> to discard all the changes. Support for
+C<-E<gt>discard> may be withdrawn in a future version of C<Tie::File>.
+
+Deferred writes are cached in memory up to the limit specified by the
+C<dw_size> option (see above). If the deferred-write buffer is full
+and you try to write still more deferred data, the buffer will be
+flushed. All buffered data will be written immediately, the buffer
+will be emptied, and the now-empty space will be used for future
+deferred writes.
+
+If the deferred-write buffer isn't yet full, but the total size of the
+buffer and the read cache would exceed the C<memory> limit, the oldest
+records will be expired from the read cache until the total size is
+under the limit.
+
+C<push>, C<pop>, C<shift>, C<unshift>, and C<splice> cannot be
+deferred. When you perform one of these operations, any deferred data
+is written to the file and the operation is performed immediately.
+This may change in a future version.
+
+If you resize the array with deferred writing enabled, the file will
+be resized immediately, but deferred records will not be written.
+This has a surprising consequence: C<@a = (...)> erases the file
+immediately, but the writing of the actual data is deferred. This
+might be a bug. If it is a bug, it will be fixed in a future version.
+
+=head2 Autodeferring
+
+C<Tie::File> tries to guess when deferred writing might be helpful,
+and to turn it on and off automatically.
+
+ for (@a) {
+ $_ = "> $_";
+ }
+
+In this example, only the first two assignments will be done
+immediately; after this, all the changes to the file will be deferred
+up to the user-specified memory limit.
+
+You should usually be able to ignore this and just use the module
+without thinking about deferring. However, special applications may
+require fine control over which writes are deferred, or may require
+that all writes be immediate. To disable the autodeferment feature,
+use
+
+ (tied @o)->autodefer(0);
+
+or
+
+ tie @array, 'Tie::File', $file, autodefer => 0;
+
+
+Similarly, C<-E<gt>autodefer(1)> re-enables autodeferment, and
+C<-E<gt>autodefer()> recovers the current value of the autodefer setting.
+
+
+=head1 CONCURRENT ACCESS TO FILES
+
+Caching and deferred writing are inappropriate if you want the same
+file to be accessed simultaneously from more than one process. Other
+optimizations performed internally by this module are also
+incompatible with concurrent access. A future version of this module will
+support a C<concurrent =E<gt> 1> option that enables safe concurrent access.
+
+Previous versions of this documentation suggested using C<memory
+=E<gt> 0> for safe concurrent access. This was mistaken. Tie::File
+will not support safe concurrent access before version 0.98.
+
+=head1 CAVEATS
+
+(That's Latin for 'warnings'.)
+
+=over 4
+
+=item *
+
+Reasonable effort was made to make this module efficient. Nevertheless,
+changing the size of a record in the middle of a large file will
+always be fairly slow, because everything after the new record must be
+moved.
+
+=item *
+
+The behavior of tied arrays is not precisely the same as for regular
+arrays. For example:
+
+ # This DOES print "How unusual!"
+ undef $a[10]; print "How unusual!\n" if defined $a[10];
+
+C<undef>-ing a C<Tie::File> array element just blanks out the
+corresponding record in the file. When you read it back again, you'll
+get the empty string, so the supposedly-C<undef>'ed value will be
+defined. Similarly, if you have C<autochomp> disabled, then
+
+ # This DOES print "How unusual!" if 'autochomp' is disabled
+ undef $a[10];
+ print "How unusual!\n" if $a[10];
+
+Because when C<autochomp> is disabled, C<$a[10]> will read back as
+C<"\n"> (or whatever the record separator string is.)
+
+There are other minor differences, particularly regarding C<exists>
+and C<delete>, but in general, the correspondence is extremely close.
+
+=item *
+
+I have supposed that since this module is concerned with file I/O,
+almost all normal use of it will be heavily I/O bound. This means
+that the time to maintain complicated data structures inside the
+module will be dominated by the time to actually perform the I/O.
+When there was an opportunity to spend CPU time to avoid doing I/O, I
+usually tried to take it.
+
+=item *
+
+You might be tempted to think that deferred writing is like
+transactions, with C<flush> as C<commit> and C<discard> as
+C<rollback>, but it isn't, so don't.
+
+=item *
+
+There is a large memory overhead for each record offset and for each
+cache entry: about 310 bytes per cached data record, and about 21 bytes per offset table entry.
+
+The per-record overhead will limit the maximum number of records you
+can access per file. Note that I<accessing> the length of the array
+via C<$x = scalar @tied_file> accesses B<all> records and stores their
+offsets. The same for C<foreach (@tied_file)>, even if you exit the
+loop early.
+
+=back
+
+=head1 SUBCLASSING
+
+This version promises absolutely nothing about the internals, which
+may change without notice. A future version of the module will have a
+well-defined and stable subclassing API.
+
+=head1 WHAT ABOUT C<DB_File>?
+
+People sometimes point out that L<DB_File> will do something similar,
+and ask why C<Tie::File> module is necessary.
+
+There are a number of reasons that you might prefer C<Tie::File>.
+A list is available at C<http://perl.plover.com/TieFile/why-not-DB_File>.
+
+=head1 AUTHOR
+
+Mark Jason Dominus
+
+To contact the author, send email to: C<mjd-perl-tiefile+@plover.com>
+
+To receive an announcement whenever a new version of this module is
+released, send a blank email message to
+C<mjd-perl-tiefile-subscribe@plover.com>.
+
+The most recent version of this module, including documentation and
+any news of importance, will be available at
+
+ http://perl.plover.com/TieFile/
+
+
+=head1 LICENSE
+
+C<Tie::File> version 0.97 is copyright (C) 2003 Mark Jason Dominus.
+
+This library is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+These terms are your choice of any of (1) the Perl Artistic Licence,
+or (2) version 2 of the GNU General Public License as published by the
+Free Software Foundation, or (3) any later version of the GNU General
+Public License.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this library program; it should be in the file C<COPYING>.
+If not, write to the Free Software Foundation, Inc., 51 Franklin Street,
+Fifth Floor, Boston, MA 02110-1301, USA
+
+For licensing inquiries, contact the author at:
+
+ Mark Jason Dominus
+ 255 S. Warnock St.
+ Philadelphia, PA 19107
+
+=head1 WARRANTY
+
+C<Tie::File> version 0.97 comes with ABSOLUTELY NO WARRANTY.
+For details, see the license.
+
+=head1 THANKS
+
+Gigantic thanks to Jarkko Hietaniemi, for agreeing to put this in the
+core when I hadn't written it yet, and for generally being helpful,
+supportive, and competent. (Usually the rule is "choose any one.")
+Also big thanks to Abhijit Menon-Sen for all of the same things.
+
+Special thanks to Craig Berry and Peter Prymmer (for VMS portability
+help), Randy Kobes (for Win32 portability help), Clinton Pierce and
+Autrijus Tang (for heroic eleventh-hour Win32 testing above and beyond
+the call of duty), Michael G Schwern (for testing advice), and the
+rest of the CPAN testers (for testing generally).
+
+Special thanks to Tels for suggesting several speed and memory
+optimizations.
+
+Additional thanks to:
+Edward Avis /
+Mattia Barbon /
+Tom Christiansen /
+Gerrit Haase /
+Gurusamy Sarathy /
+Jarkko Hietaniemi (again) /
+Nikola Knezevic /
+John Kominetz /
+Nick Ing-Simmons /
+Tassilo von Parseval /
+H. Dieter Pearcey /
+Slaven Rezic /
+Eric Roode /
+Peter Scott /
+Peter Somu /
+Autrijus Tang (again) /
+Tels (again) /
+Juerd Waalboer
+
+=head1 TODO
+
+More tests. (Stuff I didn't think of yet.)
+
+Paragraph mode?
+
+Fixed-length mode. Leave-blanks mode.
+
+Maybe an autolocking mode?
+
+For many common uses of the module, the read cache is a liability.
+For example, a program that inserts a single record, or that scans the
+file once, will have a cache hit rate of zero. This suggests a major
+optimization: The cache should be initially disabled. Here's a hybrid
+approach: Initially, the cache is disabled, but the cache code
+maintains statistics about how high the hit rate would be *if* it were
+enabled. When it sees the hit rate get high enough, it enables
+itself. The STAT comments in this code are the beginning of an
+implementation of this.
+
+Record locking with fcntl()? Then the module might support an undo
+log and get real transactions. What a tour de force that would be.
+
+Keeping track of the highest cached record. This would allow reads-in-a-row
+to skip the cache lookup faster (if reading from 1..N with empty cache at
+start, the last cached value will be always N-1).
+
+More tests.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Handle.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Handle.pm
new file mode 100755
index 00000000000..4e92f75a3d1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Handle.pm
@@ -0,0 +1,201 @@
+package Tie::Handle;
+
+use 5.006_001;
+our $VERSION = '4.2';
+
+# Tie::StdHandle used to be inside Tie::Handle. For backwards compatibility
+# loading Tie::Handle has to make Tie::StdHandle available.
+use Tie::StdHandle;
+
+=head1 NAME
+
+Tie::Handle - base class definitions for tied handles
+
+=head1 SYNOPSIS
+
+ package NewHandle;
+ require Tie::Handle;
+
+ @ISA = qw(Tie::Handle);
+
+ sub READ { ... } # Provide a needed method
+ sub TIEHANDLE { ... } # Overrides inherited method
+
+
+ package main;
+
+ tie *FH, 'NewHandle';
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for handle-tying classes. See
+L<perltie> for a list of the functions required in tying a handle to a package.
+The basic B<Tie::Handle> package provides a C<new> method, as well as methods
+C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>.
+
+For developers wishing to write their own tied-handle classes, the methods
+are summarized below. The L<perltie> section not only documents these, but
+has sample code as well:
+
+=over 4
+
+=item TIEHANDLE classname, LIST
+
+The method invoked by the command C<tie *glob, classname>. Associates a new
+glob instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item WRITE this, scalar, length, offset
+
+Write I<length> bytes of data from I<scalar> starting at I<offset>.
+
+=item PRINT this, LIST
+
+Print the values in I<LIST>
+
+=item PRINTF this, format, LIST
+
+Print the values in I<LIST> using I<format>
+
+=item READ this, scalar, length, offset
+
+Read I<length> bytes of data into I<scalar> starting at I<offset>.
+
+=item READLINE this
+
+Read a single line
+
+=item GETC this
+
+Get a single character
+
+=item CLOSE this
+
+Close the handle
+
+=item OPEN this, filename
+
+(Re-)open the handle
+
+=item BINMODE this
+
+Specify content is binary
+
+=item EOF this
+
+Test for end of file.
+
+=item TELL this
+
+Return position in the file.
+
+=item SEEK this, offset, whence
+
+Position the file.
+
+Test for end of file.
+
+=item DESTROY this
+
+Free the storage associated with the tied handle referenced by I<this>.
+This is rarely needed, as Perl manages its memory quite well. But the
+option exists, should a class wish to perform specific actions upon the
+destruction of an instance.
+
+=back
+
+=head1 MORE INFORMATION
+
+The L<perltie> section contains an example of tying handles.
+
+=head1 COMPATIBILITY
+
+This version of Tie::Handle is neither related to nor compatible with
+the Tie::Handle (3.0) module available on CPAN. It was due to an
+accident that two modules with the same name appeared. The namespace
+clash has been cleared in favor of this module that comes with the
+perl core in September 2000 and accordingly the version number has
+been bumped up to 4.0.
+
+=cut
+
+use Carp;
+use warnings::register;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIEHANDLE(@_);
+}
+
+# "Grandfather" the new, a la Tie::Hash
+
+sub TIEHANDLE {
+ my $pkg = shift;
+ if (defined &{"{$pkg}::new"}) {
+ warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing");
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIEHANDLE method";
+ }
+}
+
+sub PRINT {
+ my $self = shift;
+ if($self->can('WRITE') != \&WRITE) {
+ my $buf = join(defined $, ? $, : "",@_);
+ $buf .= $\ if defined $\;
+ $self->WRITE($buf,length($buf),0);
+ }
+ else {
+ croak ref($self)," doesn't define a PRINT method";
+ }
+}
+
+sub PRINTF {
+ my $self = shift;
+
+ if($self->can('WRITE') != \&WRITE) {
+ my $buf = sprintf(shift,@_);
+ $self->WRITE($buf,length($buf),0);
+ }
+ else {
+ croak ref($self)," doesn't define a PRINTF method";
+ }
+}
+
+sub READLINE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a READLINE method";
+}
+
+sub GETC {
+ my $self = shift;
+
+ if($self->can('READ') != \&READ) {
+ my $buf;
+ $self->READ($buf,1);
+ return $buf;
+ }
+ else {
+ croak ref($self)," doesn't define a GETC method";
+ }
+}
+
+sub READ {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a READ method";
+}
+
+sub WRITE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a WRITE method";
+}
+
+sub CLOSE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a CLOSE method";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Hash.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Hash.pm
new file mode 100755
index 00000000000..1ca8887e7e3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Hash.pm
@@ -0,0 +1,257 @@
+package Tie::Hash;
+
+our $VERSION = '1.03';
+
+=head1 NAME
+
+Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
+
+=head1 SYNOPSIS
+
+ package NewHash;
+ require Tie::Hash;
+
+ @ISA = qw(Tie::Hash);
+
+ sub DELETE { ... } # Provides needed method
+ sub CLEAR { ... } # Overrides inherited method
+
+
+ package NewStdHash;
+ require Tie::Hash;
+
+ @ISA = qw(Tie::StdHash);
+
+ # All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0]};
+ # TIEHASH should return a reference to the actual storage
+ sub DELETE { ... }
+
+ package NewExtraHash;
+ require Tie::Hash;
+
+ @ISA = qw(Tie::ExtraHash);
+
+ # All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0][0]};
+ # TIEHASH should return an array reference with the first element being
+ # the reference to the actual storage
+ sub DELETE {
+ $_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer
+ delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1])
+ }
+
+
+ package main;
+
+ tie %new_hash, 'NewHash';
+ tie %new_std_hash, 'NewStdHash';
+ tie %new_extra_hash, 'NewExtraHash',
+ sub {warn "Doing \U$_[1]\E of $_[2].\n"};
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for hash-tying classes. See
+L<perltie> for a list of the functions required in order to tie a hash
+to a package. The basic B<Tie::Hash> package provides a C<new> method, as well
+as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and
+B<Tie::ExtraHash> packages
+provide most methods for hashes described in L<perltie> (the exceptions
+are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes,
+and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the
+C<new> method: it is used if C<TIEHASH> is not defined
+in the case a class forgets to include a C<TIEHASH> method.
+
+For developers wishing to write their own tied hashes, the required methods
+are briefly defined below. See the L<perltie> section for more detailed
+descriptive, as well as example code:
+
+=over 4
+
+=item TIEHASH classname, LIST
+
+The method invoked by the command C<tie %hash, classname>. Associates a new
+hash instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item STORE this, key, value
+
+Store datum I<value> into I<key> for the tied hash I<this>.
+
+=item FETCH this, key
+
+Retrieve the datum in I<key> for the tied hash I<this>.
+
+=item FIRSTKEY this
+
+Return the first key in the hash.
+
+=item NEXTKEY this, lastkey
+
+Return the next key in the hash.
+
+=item EXISTS this, key
+
+Verify that I<key> exists with the tied hash I<this>.
+
+The B<Tie::Hash> implementation is a stub that simply croaks.
+
+=item DELETE this, key
+
+Delete the key I<key> from the tied hash I<this>.
+
+=item CLEAR this
+
+Clear all values from the tied hash I<this>.
+
+=item SCALAR this
+
+Returns what evaluating the hash in scalar context yields.
+
+B<Tie::Hash> does not implement this method (but B<Tie::StdHash>
+and B<Tie::ExtraHash> do).
+
+=back
+
+=head1 Inheriting from B<Tie::StdHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten
+C<TIEHASH> method should return a hash reference, and the remaining methods
+should operate on the hash referenced by the first argument:
+
+ package ReportHash;
+ our @ISA = 'Tie::StdHash';
+
+ sub TIEHASH {
+ my $storage = bless {}, shift;
+ warn "New ReportHash created, stored in $storage.\n";
+ $storage
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0]{$_[1]} = $_[2]
+ }
+
+
+=head1 Inheriting from B<Tie::ExtraHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten
+C<TIEHASH> method should return an array reference with the first
+element being a hash reference, and the remaining methods should operate on the
+hash C<< %{ $_[0]->[0] } >>:
+
+ package ReportHash;
+ our @ISA = 'Tie::ExtraHash';
+
+ sub TIEHASH {
+ my $class = shift;
+ my $storage = bless [{}, @_], $class;
+ warn "New ReportHash created, stored in $storage.\n";
+ $storage;
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0][0]{$_[1]} = $_[2]
+ }
+
+The default C<TIEHASH> method stores "extra" arguments to tie() starting
+from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the
+same storage algorithm as in TIEHASH subroutine above. Hence, a typical
+package inheriting from B<Tie::ExtraHash> does not need to overwrite this
+method.
+
+=head1 C<SCALAR>, C<UNTIE> and C<DESTROY>
+
+The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>,
+B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require
+presence of these methods, but if defined, the methods will be called in
+proper time, see L<perltie>.
+
+C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>.
+
+If needed, these methods should be defined by the package inheriting from
+B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<perltie/"SCALAR">
+to find out what happens when C<SCALAR> does not exist.
+
+=head1 MORE INFORMATION
+
+The packages relating to various DBM-related implementations (F<DB_File>,
+F<NDBM_File>, etc.) show examples of general tied hashes, as does the
+L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
+good working examples.
+
+=cut
+
+use Carp;
+use warnings::register;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIEHASH(@_);
+}
+
+# Grandfather "new"
+
+sub TIEHASH {
+ my $pkg = shift;
+ if (defined &{"${pkg}::new"}) {
+ warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing");
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIEHASH method";
+ }
+}
+
+sub EXISTS {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define an EXISTS method";
+}
+
+sub CLEAR {
+ my $self = shift;
+ my $key = $self->FIRSTKEY(@_);
+ my @keys;
+
+ while (defined $key) {
+ push @keys, $key;
+ $key = $self->NEXTKEY(@_, $key);
+ }
+ foreach $key (@keys) {
+ $self->DELETE(@_, $key);
+ }
+}
+
+# The Tie::StdHash package implements standard perl hash behaviour.
+# It exists to act as a base class for classes which only wish to
+# alter some parts of their behaviour.
+
+package Tie::StdHash;
+# @ISA = qw(Tie::Hash); # would inherit new() only
+
+sub TIEHASH { bless {}, $_[0] }
+sub STORE { $_[0]->{$_[1]} = $_[2] }
+sub FETCH { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { each %{$_[0]} }
+sub EXISTS { exists $_[0]->{$_[1]} }
+sub DELETE { delete $_[0]->{$_[1]} }
+sub CLEAR { %{$_[0]} = () }
+sub SCALAR { scalar %{$_[0]} }
+
+package Tie::ExtraHash;
+
+sub TIEHASH { my $p = shift; bless [{}, @_], $p }
+sub STORE { $_[0][0]{$_[1]} = $_[2] }
+sub FETCH { $_[0][0]{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
+sub NEXTKEY { each %{$_[0][0]} }
+sub EXISTS { exists $_[0][0]->{$_[1]} }
+sub DELETE { delete $_[0][0]->{$_[1]} }
+sub CLEAR { %{$_[0][0]} = () }
+sub SCALAR { scalar %{$_[0][0]} }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Hash/NamedCapture.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Hash/NamedCapture.pm
new file mode 100755
index 00000000000..58ae743d874
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Hash/NamedCapture.pm
@@ -0,0 +1,62 @@
+package Tie::Hash::NamedCapture;
+
+our $VERSION = "0.06";
+
+# The real meat implemented in XS in universal.c in the core, but this
+# method was left behind because gv.c expects a Purl-Perl method in
+# this package when it loads the tie magic for %+ and %-
+
+my ($one, $all) = Tie::Hash::NamedCapture::flags();
+
+sub TIEHASH {
+ my ($pkg, %arg) = @_;
+ my $flag = $arg{all} ? $all : $one;
+ bless \$flag => $pkg;
+}
+
+tie %+, __PACKAGE__;
+tie %-, __PACKAGE__, all => 1;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tie::Hash::NamedCapture - Named regexp capture buffers
+
+=head1 SYNOPSIS
+
+ tie my %hash, "Tie::Hash::NamedCapture";
+ # %hash now behaves like %+
+
+ tie my %hash, "Tie::Hash::NamedCapture", all => 1;
+ # %hash now access buffers from regexp in $qr like %-
+
+=head1 DESCRIPTION
+
+This module is used to implement the special hashes C<%+> and C<%->, but it
+can be used to tie other variables as you choose.
+
+When the C<all> parameter is provided, then the tied hash elements will be
+array refs listing the contents of each capture buffer whose name is the
+same as the associated hash key. If none of these buffers were involved in
+the match, the contents of that array ref will be as many C<undef> values
+as there are capture buffers with that name. In other words, the tied hash
+will behave as C<%->.
+
+When the C<all> parameter is omitted or false, then the tied hash elements
+will be the contents of the leftmost defined buffer with the name of the
+associated hash key. In other words, the tied hash will behave as
+C<%+>.
+
+The keys of C<%->-like hashes correspond to all buffer names found in the
+regular expression; the keys of C<%+>-like hashes list only the names of
+buffers that have captured (and that are thus associated to defined values).
+
+=head1 SEE ALSO
+
+L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">,
+L<perlvar/"%-">.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Memoize.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Memoize.pm
new file mode 100755
index 00000000000..dbe14428280
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Memoize.pm
@@ -0,0 +1,128 @@
+use strict;
+package Tie::Memoize;
+use Tie::Hash;
+our @ISA = 'Tie::ExtraHash';
+our $VERSION = '1.1';
+
+our $exists_token = \undef;
+
+sub croak {require Carp; goto &Carp::croak}
+
+# Format: [0: STORAGE, 1: EXISTS-CACHE, 2: FETCH_function;
+# 3: EXISTS_function, 4: DATA, 5: EXISTS_different ]
+
+sub FETCH {
+ my ($h,$key) = ($_[0][0], $_[1]);
+ my $res = $h->{$key};
+ return $res if defined $res; # Shortcut if accessible
+ return $res if exists $h->{$key}; # Accessible, but undef
+ my $cache = $_[0][1]{$key};
+ return if defined $cache and not $cache; # Known to not exist
+ my @res = $_[0][2]->($key, $_[0][4]); # Autoload
+ $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
+ delete $_[0][1]{$key}; # Clear existence cache, not needed any more
+ $_[0][0]{$key} = $res[0]; # Store data and return
+}
+
+sub EXISTS {
+ my ($a,$key) = (shift, shift);
+ return 1 if exists $a->[0]{$key}; # Have data
+ my $cache = $a->[1]{$key};
+ return $cache if defined $cache; # Existence cache
+ my @res = $a->[3]($key,$a->[4]);
+ $a->[1]{$key} = 0, return unless @res; # Cache non-existence
+ # Now we know it exists
+ return ($a->[1]{$key} = 1) if $a->[5]; # Only existence reported
+ # Now know the value
+ $a->[0]{$key} = $res[0]; # Store data
+ return 1
+}
+
+sub TIEHASH {
+ croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr' if @_ < 2;
+ croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr, $data, \&exists_subr, \%data_cache, \%existence_cache' if @_ > 6;
+ push @_, undef if @_ < 3; # Data
+ push @_, $_[1] if @_ < 4; # exists
+ push @_, {} while @_ < 6; # initial value and caches
+ bless [ @_[4,5,1,3,2], $_[1] ne $_[3]], $_[0]
+}
+
+1;
+
+=head1 NAME
+
+Tie::Memoize - add data to hash when needed
+
+=head1 SYNOPSIS
+
+ require Tie::Memoize;
+ tie %hash, 'Tie::Memoize',
+ \&fetch, # The rest is optional
+ $DATA, \&exists,
+ {%ini_value}, {%ini_existence};
+
+=head1 DESCRIPTION
+
+This package allows a tied hash to autoload its values on the first access,
+and to use the cached value on the following accesses.
+
+Only read-accesses (via fetching the value or C<exists>) result in calls to
+the functions; the modify-accesses are performed as on a normal hash.
+
+The required arguments during C<tie> are the hash, the package, and
+the reference to the C<FETCH>ing function. The optional arguments are
+an arbitrary scalar $data, the reference to the C<EXISTS> function,
+and initial values of the hash and of the existence cache.
+
+Both the C<FETCH>ing function and the C<EXISTS> functions have the
+same signature: the arguments are C<$key, $data>; $data is the same
+value as given as argument during tie()ing. Both functions should
+return an empty list if the value does not exist. If C<EXISTS>
+function is different from the C<FETCH>ing function, it should return
+a TRUE value on success. The C<FETCH>ing function should return the
+intended value if the key is valid.
+
+=head1 Inheriting from B<Tie::Memoize>
+
+The structure of the tied() data is an array reference with elements
+
+ 0: cache of known values
+ 1: cache of known existence of keys
+ 2: FETCH function
+ 3: EXISTS function
+ 4: $data
+
+The rest is for internal usage of this package. In particular, if
+TIEHASH is overwritten, it should call SUPER::TIEHASH.
+
+=head1 EXAMPLE
+
+ sub slurp {
+ my ($key, $dir) = shift;
+ open my $h, '<', "$dir/$key" or return;
+ local $/; <$h> # slurp it all
+ }
+ sub exists { my ($key, $dir) = shift; return -f "$dir/$key" }
+
+ tie %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
+ { fake_file1 => $content1, fake_file2 => $content2 },
+ { pretend_does_not_exists => 0, known_to_exist => 1 };
+
+This example treats the slightly modified contents of $directory as a
+hash. The modifications are that the keys F<fake_file1> and
+F<fake_file2> fetch values $content1 and $content2, and
+F<pretend_does_not_exists> will never be accessed. Additionally, the
+existence of F<known_to_exist> is never checked (so if it does not
+exists when its content is needed, the user of %hash may be confused).
+
+=head1 BUGS
+
+FIRSTKEY and NEXTKEY methods go through the keys which were already read,
+not all the possible keys of the hash.
+
+=head1 AUTHOR
+
+Ilya Zakharevich L<mailto:perl-module-hash-memoize@ilyaz.org>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm b/Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm
new file mode 100755
index 00000000000..f95bf41efdf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm
@@ -0,0 +1,274 @@
+package Tie::RefHash;
+
+use vars qw/$VERSION/;
+
+$VERSION = "1.38";
+
+use 5.005;
+
+=head1 NAME
+
+Tie::RefHash - use references as hash keys
+
+=head1 SYNOPSIS
+
+ require 5.004;
+ use Tie::RefHash;
+ tie HASHVARIABLE, 'Tie::RefHash', LIST;
+ tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
+
+ untie HASHVARIABLE;
+
+=head1 DESCRIPTION
+
+This module provides the ability to use references as hash keys if you
+first C<tie> the hash variable to this module. Normally, only the
+keys of the tied hash itself are preserved as references; to use
+references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
+included as part of Tie::RefHash.
+
+It is implemented using the standard perl TIEHASH interface. Please
+see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
+
+The Nestable version works by looking for hash references being stored
+and converting them to tied hashes so that they too can have
+references as keys. This will happen without warning whenever you
+store a reference to one of your own hashes in the tied hash.
+
+=head1 EXAMPLE
+
+ use Tie::RefHash;
+ tie %h, 'Tie::RefHash';
+ $a = [];
+ $b = {};
+ $c = \*main;
+ $d = \"gunk";
+ $e = sub { 'foo' };
+ %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
+ $a->[0] = 'foo';
+ $b->{foo} = 'bar';
+ for (keys %h) {
+ print ref($_), "\n";
+ }
+
+ tie %h, 'Tie::RefHash::Nestable';
+ $h{$a}->{$b} = 1;
+ for (keys %h, keys %{$h{$a}}) {
+ print ref($_), "\n";
+ }
+
+=head1 THREAD SUPPORT
+
+L<Tie::RefHash> fully supports threading using the C<CLONE> method.
+
+=head1 STORABLE SUPPORT
+
+L<Storable> hooks are provided for semantically correct serialization and
+cloning of tied refhashes.
+
+=head1 RELIC SUPPORT
+
+This version of Tie::RefHash seems to no longer work with 5.004. This has not
+been throughly investigated. Patches welcome ;-)
+
+=head1 MAINTAINER
+
+Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@activestate.com
+
+'Nestable' by Ed Avis ed@membled.com
+
+=head1 SEE ALSO
+
+perl(1), perlfunc(1), perltie(1)
+
+=cut
+
+use Tie::Hash;
+use vars '@ISA';
+@ISA = qw(Tie::Hash);
+use strict;
+use Carp qw/croak/;
+
+BEGIN {
+ local $@;
+ # determine whether we need to take care of threads
+ use Config ();
+ my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
+ *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
+ *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
+ *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
+}
+
+BEGIN {
+ # create a refaddr function
+
+ local $@;
+
+ if ( _HAS_SCALAR_UTIL ) {
+ Scalar::Util->import("refaddr");
+ } else {
+ require overload;
+
+ *refaddr = sub {
+ if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
+ return $1;
+ } else {
+ die "couldn't parse StrVal: " . overload::StrVal($_[0]);
+ }
+ };
+ }
+}
+
+my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
+
+sub TIEHASH {
+ my $c = shift;
+ my $s = [];
+ bless $s, $c;
+ while (@_) {
+ $s->STORE(shift, shift);
+ }
+
+ if (_HAS_THREADS ) {
+
+ if ( _HAS_WEAKEN ) {
+ # remember the object so that we can rekey it on CLONE
+ push @thread_object_registry, $s;
+ # but make this a weak reference, so that there are no leaks
+ Scalar::Util::weaken( $thread_object_registry[-1] );
+
+ if ( ++$count > 1000 ) {
+ # this ensures we don't fill up with a huge array dead weakrefs
+ @thread_object_registry = grep { defined } @thread_object_registry;
+ $count = 0;
+ }
+ } else {
+ $count++; # used in the warning
+ }
+ }
+
+ return $s;
+}
+
+my $storable_format_version = join("/", __PACKAGE__, "0.01");
+
+sub STORABLE_freeze {
+ my ( $self, $is_cloning ) = @_;
+ my ( $refs, $reg ) = @$self;
+ return ( $storable_format_version, [ values %$refs ], $reg );
+}
+
+sub STORABLE_thaw {
+ my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
+ croak "incompatible versions of Tie::RefHash between freeze and thaw"
+ unless $version eq $storable_format_version;
+
+ @$self = ( {}, $reg );
+ $self->_reindex_keys( $refs );
+}
+
+sub CLONE {
+ my $pkg = shift;
+
+ if ( $count and not _HAS_WEAKEN ) {
+ warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
+ }
+
+ # when the thread has been cloned all the objects need to be updated.
+ # dead weakrefs are undefined, so we filter them out
+ @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
+ $count = 0; # we just cleaned up
+}
+
+sub _reindex_keys {
+ my ( $self, $extra_keys ) = @_;
+ # rehash all the ref keys based on their new StrVal
+ %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
+}
+
+sub FETCH {
+ my($s, $k) = @_;
+ if (ref $k) {
+ my $kstr = refaddr($k);
+ if (defined $s->[0]{$kstr}) {
+ $s->[0]{$kstr}[1];
+ }
+ else {
+ undef;
+ }
+ }
+ else {
+ $s->[1]{$k};
+ }
+}
+
+sub STORE {
+ my($s, $k, $v) = @_;
+ if (ref $k) {
+ $s->[0]{refaddr($k)} = [$k, $v];
+ }
+ else {
+ $s->[1]{$k} = $v;
+ }
+ $v;
+}
+
+sub DELETE {
+ my($s, $k) = @_;
+ (ref $k)
+ ? (delete($s->[0]{refaddr($k)}) || [])->[1]
+ : delete($s->[1]{$k});
+}
+
+sub EXISTS {
+ my($s, $k) = @_;
+ (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
+}
+
+sub FIRSTKEY {
+ my $s = shift;
+ keys %{$s->[0]}; # reset iterator
+ keys %{$s->[1]}; # reset iterator
+ $s->[2] = 0; # flag for iteration, see NEXTKEY
+ $s->NEXTKEY;
+}
+
+sub NEXTKEY {
+ my $s = shift;
+ my ($k, $v);
+ if (!$s->[2]) {
+ if (($k, $v) = each %{$s->[0]}) {
+ return $v->[0];
+ }
+ else {
+ $s->[2] = 1;
+ }
+ }
+ return each %{$s->[1]};
+}
+
+sub CLEAR {
+ my $s = shift;
+ $s->[2] = 0;
+ %{$s->[0]} = ();
+ %{$s->[1]} = ();
+}
+
+package Tie::RefHash::Nestable;
+use vars '@ISA';
+@ISA = 'Tie::RefHash';
+
+sub STORE {
+ my($s, $k, $v) = @_;
+ if (ref($v) eq 'HASH' and not tied %$v) {
+ my @elems = %$v;
+ tie %$v, ref($s), @elems;
+ }
+ $s->SUPER::STORE($k, $v);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Registry.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Registry.pm
new file mode 100755
index 00000000000..2ded338d342
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Registry.pm
@@ -0,0 +1,45 @@
+package Tie::Registry;
+
+# Tie/Registry.pm -- Provides backward compatibility for Win32::TieRegistry
+# that was called Tie::Registry prior to version 0.20.
+# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/.
+
+use strict;
+use Carp;
+
+use vars qw( $VERSION @ISA );
+BEGIN {
+ require Win32::TieRegistry;
+ $VERSION = '0.15';
+ @ISA = qw{Win32::TieRegistry};
+}
+
+sub import {
+ my $pkg = shift;
+ Win32::TieRegistry->import( ExportLevel => 1, SplitMultis => 0, @_ );
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Tie::Registry - Legacy interface to Win32::TieRegistry (DEPRECATED)
+
+=head1 DESCRIPTION
+
+This module provides backward compatibility for L<Win32::TieRegistry>
+that was called Tie::Registry prior to version 0.20.
+
+=head1 AUTHOR
+
+Tye McQueen E<lt>tye@metronet.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 1999 Tye McQueen.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Scalar.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Scalar.pm
new file mode 100755
index 00000000000..9bf03f9105c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Scalar.pm
@@ -0,0 +1,140 @@
+package Tie::Scalar;
+
+our $VERSION = '1.01';
+
+=head1 NAME
+
+Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
+
+=head1 SYNOPSIS
+
+ package NewScalar;
+ require Tie::Scalar;
+
+ @ISA = qw(Tie::Scalar);
+
+ sub FETCH { ... } # Provide a needed method
+ sub TIESCALAR { ... } # Overrides inherited method
+
+
+ package NewStdScalar;
+ require Tie::Scalar;
+
+ @ISA = qw(Tie::StdScalar);
+
+ # All methods provided by default, so define only what needs be overridden
+ sub FETCH { ... }
+
+
+ package main;
+
+ tie $new_scalar, 'NewScalar';
+ tie $new_std_scalar, 'NewStdScalar';
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for scalar-tying classes. See
+L<perltie> for a list of the functions required in tying a scalar to a
+package. The basic B<Tie::Scalar> package provides a C<new> method, as well
+as methods C<TIESCALAR>, C<FETCH> and C<STORE>. The B<Tie::StdScalar>
+package provides all the methods specified in L<perltie>. It inherits from
+B<Tie::Scalar> and causes scalars tied to it to behave exactly like the
+built-in scalars, allowing for selective overloading of methods. The C<new>
+method is provided as a means of grandfathering, for classes that forget to
+provide their own C<TIESCALAR> method.
+
+For developers wishing to write their own tied-scalar classes, the methods
+are summarized below. The L<perltie> section not only documents these, but
+has sample code as well:
+
+=over 4
+
+=item TIESCALAR classname, LIST
+
+The method invoked by the command C<tie $scalar, classname>. Associates a new
+scalar instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item FETCH this
+
+Retrieve the value of the tied scalar referenced by I<this>.
+
+=item STORE this, value
+
+Store data I<value> in the tied scalar referenced by I<this>.
+
+=item DESTROY this
+
+Free the storage associated with the tied scalar referenced by I<this>.
+This is rarely needed, as Perl manages its memory quite well. But the
+option exists, should a class wish to perform specific actions upon the
+destruction of an instance.
+
+=back
+
+=head1 MORE INFORMATION
+
+The L<perltie> section uses a good example of tying scalars by associating
+process IDs with priority.
+
+=cut
+
+use Carp;
+use warnings::register;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIESCALAR(@_);
+}
+
+# "Grandfather" the new, a la Tie::Hash
+
+sub TIESCALAR {
+ my $pkg = shift;
+ if ($pkg->can('new') and $pkg ne __PACKAGE__) {
+ warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing");
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIESCALAR method";
+ }
+}
+
+sub FETCH {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a FETCH method";
+}
+
+sub STORE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a STORE method";
+}
+
+#
+# The Tie::StdScalar package provides scalars that behave exactly like
+# Perl's built-in scalars. Good base to inherit from, if you're only going to
+# tweak a small bit.
+#
+package Tie::StdScalar;
+@ISA = qw(Tie::Scalar);
+
+sub TIESCALAR {
+ my $class = shift;
+ my $instance = shift || undef;
+ return bless \$instance => $class;
+}
+
+sub FETCH {
+ return ${$_[0]};
+}
+
+sub STORE {
+ ${$_[0]} = $_[1];
+}
+
+sub DESTROY {
+ undef ${$_[0]};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/StdHandle.pm b/Master/tlpkg/tlperl.straw/lib/Tie/StdHandle.pm
new file mode 100755
index 00000000000..3a1a3db4788
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/StdHandle.pm
@@ -0,0 +1,71 @@
+package Tie::StdHandle;
+
+use strict;
+
+use Tie::Handle;
+use vars qw(@ISA $VERSION);
+@ISA = 'Tie::Handle';
+$VERSION = '4.2';
+
+=head1 NAME
+
+Tie::StdHandle - base class definitions for tied handles
+
+=head1 SYNOPSIS
+
+ package NewHandle;
+ require Tie::Handle;
+
+ @ISA = qw(Tie::Handle);
+
+ sub READ { ... } # Provide a needed method
+ sub TIEHANDLE { ... } # Overrides inherited method
+
+
+ package main;
+
+ tie *FH, 'NewHandle';
+
+=head1 DESCRIPTION
+
+The B<Tie::StdHandle> package provide most methods for file handles described
+in L<perltie> (the exceptions are C<UNTIE> and C<DESTROY>). It causes tied
+file handles to behave exactly like standard file handles and allow for
+selective overwriting of methods.
+
+=cut
+
+sub TIEHANDLE
+{
+ my $class = shift;
+ my $fh = \do { local *HANDLE};
+ bless $fh,$class;
+ $fh->OPEN(@_) if (@_);
+ return $fh;
+}
+
+sub EOF { eof($_[0]) }
+sub TELL { tell($_[0]) }
+sub FILENO { fileno($_[0]) }
+sub SEEK { seek($_[0],$_[1],$_[2]) }
+sub CLOSE { close($_[0]) }
+sub BINMODE { binmode($_[0]) }
+
+sub OPEN
+{
+ $_[0]->CLOSE if defined($_[0]->FILENO);
+ @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
+}
+
+sub READ { read($_[0],$_[1],$_[2]) }
+sub READLINE { my $fh = $_[0]; <$fh> }
+sub GETC { getc($_[0]) }
+
+sub WRITE
+{
+ my $fh = $_[0];
+ print $fh substr($_[1],0,$_[2])
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/SubstrHash.pm b/Master/tlpkg/tlperl.straw/lib/Tie/SubstrHash.pm
new file mode 100755
index 00000000000..476dd686787
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/SubstrHash.pm
@@ -0,0 +1,215 @@
+package Tie::SubstrHash;
+
+our $VERSION = '1.00';
+
+=head1 NAME
+
+Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
+
+=head1 SYNOPSIS
+
+ require Tie::SubstrHash;
+
+ tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
+
+=head1 DESCRIPTION
+
+The B<Tie::SubstrHash> package provides a hash-table-like interface to
+an array of determinate size, with constant key size and record size.
+
+Upon tying a new hash to this package, the developer must specify the
+size of the keys that will be used, the size of the value fields that the
+keys will index, and the size of the overall table (in terms of key-value
+pairs, not size in hard memory). I<These values will not change for the
+duration of the tied hash>. The newly-allocated hash table may now have
+data stored and retrieved. Efforts to store more than C<$table_size>
+elements will result in a fatal error, as will efforts to store a value
+not exactly C<$value_len> characters in length, or reference through a
+key not exactly C<$key_len> characters in length. While these constraints
+may seem excessive, the result is a hash table using much less internal
+memory than an equivalent freely-allocated hash table.
+
+=head1 CAVEATS
+
+Because the current implementation uses the table and key sizes for the
+hashing algorithm, there is no means by which to dynamically change the
+value of any of the initialization parameters.
+
+The hash does not support exists().
+
+=cut
+
+use Carp;
+
+sub TIEHASH {
+ my $pack = shift;
+ my ($klen, $vlen, $tsize) = @_;
+ my $rlen = 1 + $klen + $vlen;
+ $tsize = [$tsize,
+ findgteprime($tsize * 1.1)]; # Allow 10% empty.
+ local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
+ $$self[0] x= $rlen * $tsize->[1];
+ $self;
+}
+
+sub CLEAR {
+ local($self) = @_;
+ $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
+ $$self[5] = 0;
+ $$self[6] = -1;
+}
+
+sub FETCH {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ return substr($record, 1+$klen, $vlen);
+ }
+ &rehash;
+ }
+}
+
+sub STORE {
+ local($self,$key,$val) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
+ croak(qq/Value "$val" is not $vlen characters long/)
+ if length($val) != $vlen;
+ my $writeoffset;
+
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ $writeoffset = $offset unless defined $writeoffset;
+ substr($$self[0], $writeoffset, $rlen) = $record;
+ ++$$self[5];
+ return;
+ }
+ elsif (ord($record) == 1) {
+ $writeoffset = $offset unless defined $writeoffset;
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ substr($$self[0], $offset, $rlen) = $record;
+ return;
+ }
+ &rehash;
+ }
+}
+
+sub DELETE {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ substr($$self[0], $offset, 1) = "\1";
+ return substr($record, 1+$klen, $vlen);
+ --$$self[5];
+ }
+ &rehash;
+ }
+}
+
+sub FIRSTKEY {
+ local($self) = @_;
+ $$self[6] = -1;
+ &NEXTKEY;
+}
+
+sub NEXTKEY {
+ local($self) = @_;
+ local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
+ for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
+ next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
+ $$self[6] = $iterix;
+ return substr($$self[0], $iterix * $rlen + 1, $klen);
+ }
+ $$self[6] = -1;
+ undef;
+}
+
+sub EXISTS {
+ croak "Tie::SubstrHash does not support exists()";
+}
+
+sub hashkey {
+ croak(qq/Key "$key" is not $klen characters long/)
+ if length($key) != $klen;
+ $hash = 2;
+ for (unpack('C*', $key)) {
+ $hash = $hash * 33 + $_;
+ &_hashwrap if $hash >= 1e13;
+ }
+ &_hashwrap if $hash >= $tsize->[1];
+ $hash = 1 unless $hash;
+ $hashbase = $hash;
+}
+
+sub _hashwrap {
+ $hash -= int($hash / $tsize->[1]) * $tsize->[1];
+}
+
+sub rehash {
+ $hash += $hashbase;
+ $hash -= $tsize->[1] if $hash >= $tsize->[1];
+}
+
+# using POSIX::ceil() would be too heavy, and not all platforms have it.
+sub ceil {
+ my $num = shift;
+ $num = int($num + 1) unless $num == int $num;
+ return $num;
+}
+
+# See:
+#
+# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html
+#
+
+sub findgteprime { # find the smallest prime integer greater than or equal to
+ use integer;
+
+ my $num = ceil(shift);
+ return 2 if $num <= 2;
+
+ $num++ unless $num % 2;
+ my $i;
+ my $sqrtnum = int sqrt $num;
+ my $sqrtnumsquared = $sqrtnum * $sqrtnum;
+
+ NUM:
+ for (;; $num += 2) {
+ if ($sqrtnumsquared < $num) {
+ $sqrtnum++;
+ $sqrtnumsquared = $sqrtnum * $sqrtnum;
+ }
+ for ($i = 3; $i <= $sqrtnum; $i += 2) {
+ next NUM unless $num % $i;
+ }
+ return $num;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/Watch.pm b/Master/tlpkg/tlperl.straw/lib/Tie/Watch.pm
new file mode 100755
index 00000000000..48f46acd2b0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/Watch.pm
@@ -0,0 +1,560 @@
+$Tie::Watch::VERSION = '1.2';
+
+package Tie::Watch;
+
+=head1 NAME
+
+ Tie::Watch - place watchpoints on Perl variables.
+
+=head1 SYNOPSIS
+
+ use Tie::Watch;
+
+ $watch = Tie::Watch->new(
+ -variable => \$frog,
+ -debug => 1,
+ -shadow => 0,
+ -fetch => [\&fetch, 'arg1', 'arg2', ..., 'argn'],
+ -store => \&store,
+ -destroy => sub {print "Final value=$frog.\n"},
+ }
+ %vinfo = $watch->Info;
+ $args = $watch->Args(-fetch);
+ $val = $watch->Fetch;
+ print "val=", $watch->Say($val), ".\n";
+ $watch->Store('Hello');
+ $watch->Unwatch;
+
+=head1 DESCRIPTION
+
+This class module binds one or more subroutines of your devising to a
+Perl variable. All variables can have B<FETCH>, B<STORE> and
+B<DESTROY> callbacks. Additionally, arrays can define B<CLEAR>,
+B<DELETE>, B<EXISTS>, B<EXTEND>, B<FETCHSIZE>, B<POP>, B<PUSH>,
+B<SHIFT>, B<SPLICE>, B<STORESIZE> and B<UNSHIFT> callbacks, and hashes
+can define B<CLEAR>, B<DELETE>, B<EXISTS>, B<FIRSTKEY> and B<NEXTKEY>
+callbacks. If these term are unfamiliar to you, I I<really> suggest
+you read L<perltie>.
+
+With Tie::Watch you can:
+
+ . alter a variable's value
+ . prevent a variable's value from being changed
+ . invoke a Perl/Tk callback when a variable changes
+ . trace references to a variable
+
+Callback format is patterned after the Perl/Tk scheme: supply either a
+code reference, or, supply an array reference and pass the callback
+code reference in the first element of the array, followed by callback
+arguments. (See examples in the Synopsis, above.)
+
+Tie::Watch provides default callbacks for any that you fail to
+specify. Other than negatively impacting performance, they perform
+the standard action that you'd expect, so the variable behaves
+"normally". Once you override a default callback, perhaps to insert
+debug code like print statements, your callback normally finishes by
+calling the underlying (overridden) method. But you don't have to!
+
+To map a tied method name to a default callback name simply lowercase
+the tied method name and uppercase its first character. So FETCH
+becomes Fetch, NEXTKEY becomes Nextkey, etcetera.
+
+Here are two callbacks for a scalar. The B<FETCH> (read) callback does
+nothing other than illustrate the fact that it returns the value to
+assign the variable. The B<STORE> (write) callback uppercases the
+variable and returns it. In all cases the callback I<must> return the
+correct read or write value - typically, it does this by invoking the
+underlying method.
+
+ my $fetch_scalar = sub {
+ my($self) = @_;
+ $self->Fetch;
+ };
+
+ my $store_scalar = sub {
+ my($self, $new_val) = @_;
+ $self->Store(uc $new_val);
+ };
+
+Here are B<FETCH> and B<STORE> callbacks for either an array or hash.
+They do essentially the same thing as the scalar callbacks, but
+provide a little more information.
+
+ my $fetch = sub {
+ my($self, $key) = @_;
+ my $val = $self->Fetch($key);
+ print "In fetch callback, key=$key, val=", $self->Say($val);
+ my $args = $self->Args(-fetch);
+ print ", args=('", join("', '", @$args), "')" if $args;
+ print ".\n";
+ $val;
+ };
+
+ my $store = sub {
+ my($self, $key, $new_val) = @_;
+ my $val = $self->Fetch($key);
+ $new_val = uc $new_val;
+ $self->Store($key, $new_val);
+ print "In store callback, key=$key, val=", $self->Say($val),
+ ", new_val=", $self->Say($new_val);
+ my $args = $self->Args(-store);
+ print ", args=('", join("', '", @$args), "')" if $args;
+ print ".\n";
+ $new_val;
+ };
+
+In all cases, the first parameter is a reference to the Watch object,
+used to invoke the following class methods.
+
+=head1 METHODS
+
+=over 4
+
+=item $watch = Tie::Watch->new(-options => values);
+
+The watchpoint constructor method that accepts option/value pairs to
+create and configure the Watch object. The only required option is
+B<-variable>.
+
+B<-variable> is a I<reference> to a scalar, array or hash variable.
+
+B<-debug> (default 0) is 1 to activate debug print statements internal
+to Tie::Watch.
+
+B<-shadow> (default 1) is 0 to disable array and hash shadowing. To
+prevent infinite recursion Tie::Watch maintains parallel variables for
+arrays and hashes. When the watchpoint is created the parallel shadow
+variable is initialized with the watched variable's contents, and when
+the watchpoint is deleted the shadow variable is copied to the original
+variable. Thus, changes made during the watch process are not lost.
+Shadowing is on my default. If you disable shadowing any changes made
+to an array or hash are lost when the watchpoint is deleted.
+
+Specify any of the following relevant callback parameters, in the
+format described above: B<-fetch>, B<-store>, B<-destroy>.
+Additionally for arrays: B<-clear>, B<-extend>, B<-fetchsize>,
+B<-pop>, B<-push>, B<-shift>, B<-splice>, B<-storesize> and
+B<-unshift>. Additionally for hashes: B<-clear>, B<-delete>,
+B<-exists>, B<-firstkey> and B<-nextkey>.
+
+=item $args = $watch->Args(-fetch);
+
+Returns a reference to a list of arguments for the specified callback,
+or undefined if none.
+
+=item $watch->Fetch(); $watch->Fetch($key);
+
+Returns a variable's current value. $key is required for an array or
+hash.
+
+=item %vinfo = $watch->Info();
+
+Returns a hash detailing the internals of the Watch object, with these
+keys:
+
+ %vinfo = {
+ -variable => SCALAR(0x200737f8)
+ -debug => '0'
+ -shadow => '1'
+ -value => 'HELLO SCALAR'
+ -destroy => ARRAY(0x200f86cc)
+ -fetch => ARRAY(0x200f8558)
+ -store => ARRAY(0x200f85a0)
+ -legible => above data formatted as a list of string, for printing
+ }
+
+For array and hash Watch objects, the B<-value> key is replaced with a
+B<-ptr> key which is a reference to the parallel array or hash.
+Additionally, for an array or hash, there are key/value pairs for
+all the variable specific callbacks.
+
+=item $watch->Say($val);
+
+Used mainly for debugging, it returns $val in quotes if required, or
+the string "undefined" for undefined values.
+
+=item $watch->Store($new_val); $watch->Store($key, $new_val);
+
+Store a variable's new value. $key is required for an array or hash.
+
+=item $watch->Unwatch();
+
+Stop watching the variable.
+
+=back
+
+=head1 EFFICIENCY CONSIDERATIONS
+
+If you can live using the class methods provided, please do so. You
+can meddle with the object hash directly and improved watch
+performance, at the risk of your code breaking in the future.
+
+=head1 AUTHOR
+
+Stephen O. Lidie
+
+=head1 HISTORY
+
+ lusol@Lehigh.EDU, LUCC, 96/05/30
+ . Original version 0.92 release, based on the Trace module from Hans Mulder,
+ and ideas from Tim Bunce.
+
+ lusol@Lehigh.EDU, LUCC, 96/12/25
+ . Version 0.96, release two inner references detected by Perl 5.004.
+
+ lusol@Lehigh.EDU, LUCC, 97/01/11
+ . Version 0.97, fix Makefile.PL and MANIFEST (thanks Andreas Koenig).
+ Make sure test.pl doesn't fail if Tk isn't installed.
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 97/10/03
+ . Version 0.98, implement -shadow option for arrays and hashes.
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 98/02/11
+ . Version 0.99, finally, with Perl 5.004_57, we can completely watch arrays.
+ With tied array support this module is essentially complete, so its been
+ optimized for speed at the expense of clarity - sorry about that. The
+ Delete() method has been renamed Unwatch() because it conflicts with the
+ builtin delete().
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 99/04/04
+ . Version 1.0, for Perl 5.005_03, update Makefile.PL for ActiveState, and
+ add two examples (one for Perl/Tk).
+
+ sol0@lehigh.edu, Lehigh University Computing Center, 2003/06/07
+ . Version 1.1, for Perl 5.8, can trace a reference now, patch from Slaven
+ Rezic.
+
+ sol0@lehigh.edu, Lehigh University Computing Center, 2005/05/17
+ . Version 1.2, for Perl 5.8, per Rob Seegel's suggestion, support array
+ DELETE and EXISTS.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1996 - 2005 Stephen O. Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+use 5.004_57;;
+use Carp;
+use strict;
+use subs qw/normalize_callbacks/;
+use vars qw/@array_callbacks @hash_callbacks @scalar_callbacks/;
+
+@array_callbacks = qw/-clear -delete -destroy -exists -extend -fetch
+ -fetchsize -pop -push -shift -splice -store
+ -storesize -unshift/;
+@hash_callbacks = qw/-clear -delete -destroy -exists -fetch -firstkey
+ -nextkey -store/;
+@scalar_callbacks = qw/-destroy -fetch -store/;
+
+sub new {
+
+ # Watch constructor. The *real* constructor is Tie::Watch->base_watch(),
+ # invoked by methods in other Watch packages, depending upon the variable's
+ # type. Here we supply defaulted parameter values and then verify them,
+ # normalize all callbacks and bind the variable to the appropriate package.
+
+ my($class, %args) = @_;
+ my $version = $Tie::Watch::VERSION;
+ my (%arg_defaults) = (-debug => 0, -shadow => 1);
+ my $variable = $args{-variable};
+ croak "Tie::Watch::new(): -variable is required." if not defined $variable;
+
+ my($type, $watch_obj) = (ref $variable, undef);
+ if ($type =~ /(SCALAR|REF)/) {
+ @arg_defaults{@scalar_callbacks} = (
+ [\&Tie::Watch::Scalar::Destroy], [\&Tie::Watch::Scalar::Fetch],
+ [\&Tie::Watch::Scalar::Store]);
+ } elsif ($type =~ /ARRAY/) {
+ @arg_defaults{@array_callbacks} = (
+ [\&Tie::Watch::Array::Clear], [\&Tie::Watch::Array::Delete],
+ [\&Tie::Watch::Array::Destroy], [\&Tie::Watch::Array::Exists],
+ [\&Tie::Watch::Array::Extend], [\&Tie::Watch::Array::Fetch],
+ [\&Tie::Watch::Array::Fetchsize], [\&Tie::Watch::Array::Pop],
+ [\&Tie::Watch::Array::Push], [\&Tie::Watch::Array::Shift],
+ [\&Tie::Watch::Array::Splice], [\&Tie::Watch::Array::Store],
+ [\&Tie::Watch::Array::Storesize], [\&Tie::Watch::Array::Unshift]);
+ } elsif ($type =~ /HASH/) {
+ @arg_defaults{@hash_callbacks} = (
+ [\&Tie::Watch::Hash::Clear], [\&Tie::Watch::Hash::Delete],
+ [\&Tie::Watch::Hash::Destroy], [\&Tie::Watch::Hash::Exists],
+ [\&Tie::Watch::Hash::Fetch], [\&Tie::Watch::Hash::Firstkey],
+ [\&Tie::Watch::Hash::Nextkey], [\&Tie::Watch::Hash::Store]);
+ } else {
+ croak "Tie::Watch::new() - not a variable reference.";
+ }
+ my(@margs, %ahsh, $args, @args);
+ @margs = grep ! defined $args{$_}, keys %arg_defaults;
+ %ahsh = %args; # argument hash
+ @ahsh{@margs} = @arg_defaults{@margs}; # fill in missing values
+ normalize_callbacks \%ahsh;
+
+ if ($type =~ /(SCALAR|REF)/) {
+ $watch_obj = tie $$variable, 'Tie::Watch::Scalar', %ahsh;
+ } elsif ($type =~ /ARRAY/) {
+ $watch_obj = tie @$variable, 'Tie::Watch::Array', %ahsh;
+ } elsif ($type =~ /HASH/) {
+ $watch_obj = tie %$variable, 'Tie::Watch::Hash', %ahsh;
+ }
+ $watch_obj;
+
+} # end new, Watch constructor
+
+sub Args {
+
+ # Return a reference to a list of callback arguments, or undef if none.
+ #
+ # $_[0] = self
+ # $_[1] = callback type
+
+ defined $_[0]->{$_[1]}->[1] ? [@{$_[0]->{$_[1]}}[1 .. $#{$_[0]->{$_[1]}}]]
+ : undef;
+
+} # end Args
+
+sub Info {
+
+ # Info() method subclassed by other Watch modules.
+ #
+ # $_[0] = self
+ # @_[1 .. $#_] = optional callback types
+
+ my(%vinfo, @results);
+ my(@info) = (qw/-variable -debug -shadow/);
+ push @info, @_[1 .. $#_] if scalar @_ >= 2;
+ foreach my $type (@info) {
+ push @results, sprintf('%-10s: ', substr $type, 1) .
+ $_[0]->Say($_[0]->{$type});
+ $vinfo{$type} = $_[0]->{$type};
+ }
+ $vinfo{-legible} = [@results];
+ %vinfo;
+
+} # end Info
+
+sub Say {
+
+ # For debugging, mainly.
+ #
+ # $_[0] = self
+ # $_[1] = value
+
+ defined $_[1] ? (ref($_[1]) ne '' ? $_[1] : "'$_[1]'") : "undefined";
+
+} # end Say
+
+sub Unwatch {
+
+ # Stop watching a variable by releasing the last reference and untieing it.
+ # Update the original variable with its shadow, if appropriate.
+ #
+ # $_[0] = self
+
+ my $variable = $_[0]->{-variable};
+ my $type = ref $variable;
+ my $copy = $_[0]->{-ptr} if $type !~ /(SCALAR|REF)/;
+ my $shadow = $_[0]->{-shadow};
+ undef $_[0];
+ if ($type =~ /(SCALAR|REF)/) {
+ untie $$variable;
+ } elsif ($type =~ /ARRAY/) {
+ untie @$variable;
+ @$variable = @$copy if $shadow;
+ } elsif ($type =~ /HASH/) {
+ untie %$variable;
+ %$variable = %$copy if $shadow;
+ } else {
+ croak "Tie::Watch::Delete() - not a variable reference.";
+ }
+
+} # end Unwatch
+
+# Watch private methods.
+
+sub base_watch {
+
+ # Watch base class constructor invoked by other Watch modules.
+
+ my($class, %args) = @_;
+ my $watch_obj = {%args};
+ $watch_obj;
+
+} # end base_watch
+
+sub callback {
+
+ # Execute a Watch callback, either the default or user specified.
+ # Note that the arguments are those supplied by the tied method,
+ # not those (if any) specified by the user when the watch object
+ # was instantiated. This is for performance reasons, and why the
+ # Args() method exists.
+ #
+ # $_[0] = self
+ # $_[1] = callback type
+ # $_[2] through $#_ = tied arguments
+
+ &{$_[0]->{$_[1]}->[0]} ($_[0], @_[2 .. $#_]);
+
+} # end callback
+
+sub normalize_callbacks {
+
+ # Ensure all callbacks are normalized in [\&code, @args] format.
+
+ my($args_ref) = @_;
+ my($cb, $ref);
+ foreach my $arg (keys %$args_ref) {
+ next if $arg =~ /variable|debug|shadow/;
+ $cb = $args_ref->{$arg};
+ $ref = ref $cb;
+ if ($ref =~ /CODE/) {
+ $args_ref->{$arg} = [$cb];
+ } elsif ($ref !~ /ARRAY/) {
+ croak "Tie::Watch: malformed callback $arg=$cb.";
+ }
+ }
+
+} # end normalize_callbacks
+
+###############################################################################
+
+package Tie::Watch::Scalar;
+
+use Carp;
+@Tie::Watch::Scalar::ISA = qw/Tie::Watch/;
+
+sub TIESCALAR {
+
+ my($class, %args) = @_;
+ my $variable = $args{-variable};
+ my $watch_obj = Tie::Watch->base_watch(%args);
+ $watch_obj->{-value} = $$variable;
+ print "WatchScalar new: $variable created, \@_=", join(',', @_), "!\n"
+ if $watch_obj->{-debug};
+ bless $watch_obj, $class;
+
+} # end TIESCALAR
+
+sub Info {$_[0]->SUPER::Info('-value', @Tie::Watch::scalar_callbacks)}
+
+# Default scalar callbacks.
+
+sub Destroy {undef %{$_[0]}}
+sub Fetch {$_[0]->{-value}}
+sub Store {$_[0]->{-value} = $_[1]}
+
+# Scalar access methods.
+
+sub DESTROY {$_[0]->callback('-destroy')}
+sub FETCH {$_[0]->callback('-fetch')}
+sub STORE {$_[0]->callback('-store', $_[1])}
+
+###############################################################################
+
+package Tie::Watch::Array;
+
+use Carp;
+@Tie::Watch::Array::ISA = qw/Tie::Watch/;
+
+sub TIEARRAY {
+
+ my($class, %args) = @_;
+ my($variable, $shadow) = @args{-variable, -shadow};
+ my @copy = @$variable if $shadow; # make a private copy of user's array
+ $args{-ptr} = $shadow ? \@copy : [];
+ my $watch_obj = Tie::Watch->base_watch(%args);
+ print "WatchArray new: $variable created, \@_=", join(',', @_), "!\n"
+ if $watch_obj->{-debug};
+ bless $watch_obj, $class;
+
+} # end TIEARRAY
+
+sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::array_callbacks)}
+
+# Default array callbacks.
+
+sub Clear {$_[0]->{-ptr} = ()}
+sub Delete {delete $_[0]->{-ptr}->[$_[1]]}
+sub Destroy {undef %{$_[0]}}
+sub Exists {exists $_[0]->{-ptr}->[$_[1]]}
+sub Extend {}
+sub Fetch {$_[0]->{-ptr}->[$_[1]]}
+sub Fetchsize {scalar @{$_[0]->{-ptr}}}
+sub Pop {pop @{$_[0]->{-ptr}}}
+sub Push {push @{$_[0]->{-ptr}}, @_[1 .. $#_]}
+sub Shift {shift @{$_[0]->{-ptr}}}
+sub Splice {
+ my $n = scalar @_; # splice() is wierd!
+ return splice @{$_[0]->{-ptr}}, $_[1] if $n == 2;
+ return splice @{$_[0]->{-ptr}}, $_[1], $_[2] if $n == 3;
+ return splice @{$_[0]->{-ptr}}, $_[1], $_[2], @_[3 .. $#_] if $n >= 4;
+}
+sub Store {$_[0]->{-ptr}->[$_[1]] = $_[2]}
+sub Storesize {$#{$_[0]->{-ptr}} = $_[1] - 1}
+sub Unshift {unshift @{$_[0]->{-ptr}}, @_[1 .. $#_]}
+
+# Array access methods.
+
+sub CLEAR {$_[0]->callback('-clear')}
+sub DELETE {$_[0]->callback('-delete', $_[1])}
+sub DESTROY {$_[0]->callback('-destroy')}
+sub EXISTS {$_[0]->callback('-exists', $_[1])}
+sub EXTEND {$_[0]->callback('-extend', $_[1])}
+sub FETCH {$_[0]->callback('-fetch', $_[1])}
+sub FETCHSIZE {$_[0]->callback('-fetchsize')}
+sub POP {$_[0]->callback('-pop')}
+sub PUSH {$_[0]->callback('-push', @_[1 .. $#_])}
+sub SHIFT {$_[0]->callback('-shift')}
+sub SPLICE {$_[0]->callback('-splice', @_[1 .. $#_])}
+sub STORE {$_[0]->callback('-store', $_[1], $_[2])}
+sub STORESIZE {$_[0]->callback('-storesize', $_[1])}
+sub UNSHIFT {$_[0]->callback('-unshift', @_[1 .. $#_])}
+
+###############################################################################
+
+package Tie::Watch::Hash;
+
+use Carp;
+@Tie::Watch::Hash::ISA = qw/Tie::Watch/;
+
+sub TIEHASH {
+
+ my($class, %args) = @_;
+ my($variable, $shadow) = @args{-variable, -shadow};
+ my %copy = %$variable if $shadow; # make a private copy of user's hash
+ $args{-ptr} = $shadow ? \%copy : {};
+ my $watch_obj = Tie::Watch->base_watch(%args);
+ print "WatchHash new: $variable created, \@_=", join(',', @_), "!\n"
+ if $watch_obj->{-debug};
+ bless $watch_obj, $class;
+
+} # end TIEHASH
+
+sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::hash_callbacks)}
+
+# Default hash callbacks.
+
+sub Clear {$_[0]->{-ptr} = ()}
+sub Delete {delete $_[0]->{-ptr}->{$_[1]}}
+sub Destroy {undef %{$_[0]}}
+sub Exists {exists $_[0]->{-ptr}->{$_[1]}}
+sub Fetch {$_[0]->{-ptr}->{$_[1]}}
+sub Firstkey {my $c = keys %{$_[0]->{-ptr}}; each %{$_[0]->{-ptr}}}
+sub Nextkey {each %{$_[0]->{-ptr}}}
+sub Store {$_[0]->{-ptr}->{$_[1]} = $_[2]}
+
+# Hash access methods.
+
+sub CLEAR {$_[0]->callback('-clear')}
+sub DELETE {$_[0]->callback('-delete', $_[1])}
+sub DESTROY {$_[0]->callback('-destroy')}
+sub EXISTS {$_[0]->callback('-exists', $_[1])}
+sub FETCH {$_[0]->callback('-fetch', $_[1])}
+sub FIRSTKEY {$_[0]->callback('-firstkey')}
+sub NEXTKEY {$_[0]->callback('-nextkey')}
+sub STORE {$_[0]->callback('-store', $_[1], $_[2])}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Time/HiRes.pm b/Master/tlpkg/tlperl.straw/lib/Time/HiRes.pm
new file mode 100755
index 00000000000..da4d45a96e8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Time/HiRes.pm
@@ -0,0 +1,591 @@
+package Time::HiRes;
+
+use strict;
+use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+
+require Exporter;
+require DynaLoader;
+
+@ISA = qw(Exporter DynaLoader);
+
+@EXPORT = qw( );
+@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
+ getitimer setitimer nanosleep clock_gettime clock_getres
+ clock clock_nanosleep
+ CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID
+ CLOCK_TIMEOFDAY CLOCKS_PER_SEC
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
+ TIMER_ABSTIME
+ d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
+ d_nanosleep d_clock_gettime d_clock_getres
+ d_clock d_clock_nanosleep
+ stat
+ );
+
+$VERSION = '1.9719';
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+sub AUTOLOAD {
+ my $constname;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ # print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n";
+ die "&Time::HiRes::constant not defined" if $constname eq 'constant';
+ my ($error, $val) = constant($constname);
+ # print "AUTOLOAD: error = $error, val = $val\n";
+ if ($error) {
+ my (undef,$file,$line) = caller;
+ die "$error at $file line $line.\n";
+ }
+ {
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
+ }
+ goto &$AUTOLOAD;
+}
+
+sub import {
+ my $this = shift;
+ for my $i (@_) {
+ if (($i eq 'clock_getres' && !&d_clock_getres) ||
+ ($i eq 'clock_gettime' && !&d_clock_gettime) ||
+ ($i eq 'clock_nanosleep' && !&d_clock_nanosleep) ||
+ ($i eq 'clock' && !&d_clock) ||
+ ($i eq 'nanosleep' && !&d_nanosleep) ||
+ ($i eq 'usleep' && !&d_usleep) ||
+ ($i eq 'ualarm' && !&d_ualarm)) {
+ require Carp;
+ Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
+ }
+ }
+ Time::HiRes->export_to_level(1, $this, @_);
+}
+
+bootstrap Time::HiRes;
+
+# Preloaded methods go here.
+
+sub tv_interval {
+ # probably could have been done in C
+ my ($a, $b) = @_;
+ $b = [gettimeofday()] unless defined($b);
+ (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
+}
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
+
+=head1 SYNOPSIS
+
+ use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
+ clock_gettime clock_getres clock_nanosleep clock
+ stat );
+
+ usleep ($microseconds);
+ nanosleep ($nanoseconds);
+
+ ualarm ($microseconds);
+ ualarm ($microseconds, $interval_microseconds);
+
+ $t0 = [gettimeofday];
+ ($seconds, $microseconds) = gettimeofday;
+
+ $elapsed = tv_interval ( $t0, [$seconds, $microseconds]);
+ $elapsed = tv_interval ( $t0, [gettimeofday]);
+ $elapsed = tv_interval ( $t0 );
+
+ use Time::HiRes qw ( time alarm sleep );
+
+ $now_fractions = time;
+ sleep ($floating_seconds);
+ alarm ($floating_seconds);
+ alarm ($floating_seconds, $floating_interval);
+
+ use Time::HiRes qw( setitimer getitimer );
+
+ setitimer ($which, $floating_seconds, $floating_interval );
+ getitimer ($which);
+
+ use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF );
+
+ $realtime = clock_gettime(CLOCK_REALTIME);
+ $resolution = clock_getres(CLOCK_REALTIME);
+
+ clock_nanosleep(CLOCK_REALTIME, 1.5e9);
+ clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME);
+
+ my $ticktock = clock();
+
+ use Time::HiRes qw( stat );
+
+ my @stat = stat("file");
+ my @stat = stat(FH);
+
+=head1 DESCRIPTION
+
+The C<Time::HiRes> module implements a Perl interface to the
+C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and
+C<setitimer>/C<getitimer> system calls, in other words, high
+resolution time and timers. See the L</EXAMPLES> section below and the
+test scripts for usage; see your system documentation for the
+description of the underlying C<nanosleep> or C<usleep>, C<ualarm>,
+C<gettimeofday>, and C<setitimer>/C<getitimer> calls.
+
+If your system lacks C<gettimeofday()> or an emulation of it you don't
+get C<gettimeofday()> or the one-argument form of C<tv_interval()>.
+If your system lacks all of C<nanosleep()>, C<usleep()>,
+C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>,
+C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>.
+If your system lacks both C<ualarm()> and C<setitimer()> you don't get
+C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>.
+
+If you try to import an unimplemented function in the C<use> statement
+it will fail at compile time.
+
+If your subsecond sleeping is implemented with C<nanosleep()> instead
+of C<usleep()>, you can mix subsecond sleeping with signals since
+C<nanosleep()> does not use signals. This, however, is not portable,
+and you should first check for the truth value of
+C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and
+then carefully read your C<nanosleep()> C API documentation for any
+peculiarities.
+
+If you are using C<nanosleep> for something else than mixing sleeping
+with signals, give some thought to whether Perl is the tool you should
+be using for work requiring nanosecond accuracies.
+
+Remember that unless you are working on a I<hard realtime> system,
+any clocks and timers will be imprecise, especially so if you are working
+in a pre-emptive multiuser system. Understand the difference between
+I<wallclock time> and process time (in UNIX-like systems the sum of
+I<user> and I<system> times). Any attempt to sleep for X seconds will
+most probably end up sleeping B<more> than that, but don't be surpised
+if you end up sleeping slightly B<less>.
+
+The following functions can be imported from this module.
+No functions are exported by default.
+
+=over 4
+
+=item gettimeofday ()
+
+In array context returns a two-element array with the seconds and
+microseconds since the epoch. In scalar context returns floating
+seconds like C<Time::HiRes::time()> (see below).
+
+=item usleep ( $useconds )
+
+Sleeps for the number of microseconds (millionths of a second)
+specified. Returns the number of microseconds actually slept.
+Can sleep for more than one second, unlike the C<usleep> system call.
+Can also sleep for zero seconds, which often works like a I<thread yield>.
+See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and
+C<Time::HiRes::clock_nanosleep()>.
+
+Do not expect usleep() to be exact down to one microsecond.
+
+=item nanosleep ( $nanoseconds )
+
+Sleeps for the number of nanoseconds (1e9ths of a second) specified.
+Returns the number of nanoseconds actually slept (accurate only to
+microseconds, the nearest thousand of them). Can sleep for more than
+one second. Can also sleep for zero seconds, which often works like
+a I<thread yield>. See also C<Time::HiRes::sleep()>,
+C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>.
+
+Do not expect nanosleep() to be exact down to one nanosecond.
+Getting even accuracy of one thousand nanoseconds is good.
+
+=item ualarm ( $useconds [, $interval_useconds ] )
+
+Issues a C<ualarm> call; the C<$interval_useconds> is optional and
+will be zero if unspecified, resulting in C<alarm>-like behaviour.
+
+Returns the remaining time in the alarm in microseconds, or C<undef>
+if an error occurred.
+
+ualarm(0) will cancel an outstanding ualarm().
+
+Note that the interaction between alarms and sleeps is unspecified.
+
+=item tv_interval
+
+tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )
+
+Returns the floating seconds between the two times, which should have
+been returned by C<gettimeofday()>. If the second argument is omitted,
+then the current time is used.
+
+=item time ()
+
+Returns a floating seconds since the epoch. This function can be
+imported, resulting in a nice drop-in replacement for the C<time>
+provided with core Perl; see the L</EXAMPLES> below.
+
+B<NOTE 1>: This higher resolution timer can return values either less
+or more than the core C<time()>, depending on whether your platform
+rounds the higher resolution timer values up, down, or to the nearest second
+to get the core C<time()>, but naturally the difference should be never
+more than half a second. See also L</clock_getres>, if available
+in your system.
+
+B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when
+the C<time()> seconds since epoch rolled over to 1_000_000_000, the
+default floating point format of Perl and the seconds since epoch have
+conspired to produce an apparent bug: if you print the value of
+C<Time::HiRes::time()> you seem to be getting only five decimals, not
+six as promised (microseconds). Not to worry, the microseconds are
+there (assuming your platform supports such granularity in the first
+place). What is going on is that the default floating point format of
+Perl only outputs 15 digits. In this case that means ten digits
+before the decimal separator and five after. To see the microseconds
+you can use either C<printf>/C<sprintf> with C<"%.6f">, or the
+C<gettimeofday()> function in list context, which will give you the
+seconds and microseconds as two separate values.
+
+=item sleep ( $floating_seconds )
+
+Sleeps for the specified amount of seconds. Returns the number of
+seconds actually slept (a floating point value). This function can
+be imported, resulting in a nice drop-in replacement for the C<sleep>
+provided with perl, see the L</EXAMPLES> below.
+
+Note that the interaction between alarms and sleeps is unspecified.
+
+=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
+
+The C<SIGALRM> signal is sent after the specified number of seconds.
+Implemented using C<setitimer()> if available, C<ualarm()> if not.
+The C<$interval_floating_seconds> argument is optional and will be
+zero if unspecified, resulting in C<alarm()>-like behaviour. This
+function can be imported, resulting in a nice drop-in replacement for
+the C<alarm> provided with perl, see the L</EXAMPLES> below.
+
+Returns the remaining time in the alarm in seconds, or C<undef>
+if an error occurred.
+
+B<NOTE 1>: With some combinations of operating systems and Perl
+releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
+This means that an C<alarm()> followed by a C<select()> may together
+take the sum of the times specified for the the C<alarm()> and the
+C<select()>, not just the time of the C<alarm()>.
+
+Note that the interaction between alarms and sleeps is unspecified.
+
+=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )
+
+Start up an interval timer: after a certain time, a signal ($which) arrives,
+and more signals may keep arriving at certain intervals. To disable
+an "itimer", use C<$floating_seconds> of zero. If the
+C<$interval_floating_seconds> is set to zero (or unspecified), the
+timer is disabled B<after> the next delivered signal.
+
+Use of interval timers may interfere with C<alarm()>, C<sleep()>,
+and C<usleep()>. In standard-speak the "interaction is unspecified",
+which means that I<anything> may happen: it may work, it may not.
+
+In scalar context, the remaining time in the timer is returned.
+
+In list context, both the remaining time and the interval are returned.
+
+There are usually three or four interval timers (signals) available: the
+C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
+C<ITIMER_REALPROF>. Note that which ones are available depends: true
+UNIX platforms usually have the first three, but only Solaris seems to
+have C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
+Win32 unfortunately does not haveinterval timers.
+
+C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in
+I<real time>; that is, wallclock time. C<SIGALRM> is delivered when
+the timer expires.
+
+C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is,
+only when the process is running. In multiprocessor/user/CPU systems
+this may be more or less than real or wallclock time. (This time is
+also known as the I<user time>.) C<SIGVTALRM> is delivered when the
+timer expires.
+
+C<ITIMER_PROF> counts time when either the process virtual time or when
+the operating system is running on behalf of the process (such as I/O).
+(This time is also known as the I<system time>.) (The sum of user
+time and system time is known as the I<CPU time>.) C<SIGPROF> is
+delivered when the timer expires. C<SIGPROF> can interrupt system calls.
+
+The semantics of interval timers for multithreaded programs are
+system-specific, and some systems may support additional interval
+timers. For example, it is unspecified which thread gets the signals.
+See your C<setitimer()> documentation.
+
+=item getitimer ( $which )
+
+Return the remaining time in the interval timer specified by C<$which>.
+
+In scalar context, the remaining time is returned.
+
+In list context, both the remaining time and the interval are returned.
+The interval is always what you put in using C<setitimer()>.
+
+=item clock_gettime ( $which )
+
+Return as seconds the current value of the POSIX high resolution timer
+specified by C<$which>. All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, which is supposed to return results close to the
+results of C<gettimeofday>, or the number of seconds since 00:00:00:00
+January 1, 1970 Greenwich Mean Time (GMT). Do not assume that
+CLOCK_REALTIME is zero, it might be one, or something else.
+Another potentially useful (but not available everywhere) value is
+C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
+value (unlike time() or gettimeofday(), which can be adjusted).
+See your system documentation for other possibly supported values.
+
+=item clock_getres ( $which )
+
+Return as seconds the resolution of the POSIX high resolution timer
+specified by C<$which>. All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, see L</clock_gettime>.
+
+=item clock_nanosleep ( $which, $nanoseconds, $flags = 0)
+
+Sleeps for the number of nanoseconds (1e9ths of a second) specified.
+Returns the number of nanoseconds actually slept. The $which is the
+"clock id", as with clock_gettime() and clock_getres(). The flags
+default to zero but C<TIMER_ABSTIME> can specified (must be exported
+explicitly) which means that C<$nanoseconds> is not a time interval
+(as is the default) but instead an absolute time. Can sleep for more
+than one second. Can also sleep for zero seconds, which often works
+like a I<thread yield>. See also C<Time::HiRes::sleep()>,
+C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>.
+
+Do not expect clock_nanosleep() to be exact down to one nanosecond.
+Getting even accuracy of one thousand nanoseconds is good.
+
+=item clock()
+
+Return as seconds the I<process time> (user + system time) spent by
+the process since the first call to clock() (the definition is B<not>
+"since the start of the process", though if you are lucky these times
+may be quite close to each other, depending on the system). What this
+means is that you probably need to store the result of your first call
+to clock(), and subtract that value from the following results of clock().
+
+The time returned also includes the process times of the terminated
+child processes for which wait() has been executed. This value is
+somewhat like the second value returned by the times() of core Perl,
+but not necessarily identical. Note that due to backward
+compatibility limitations the returned value may wrap around at about
+2147 seconds or at about 36 minutes.
+
+=item stat
+
+=item stat FH
+
+=item stat EXPR
+
+As L<perlfunc/stat> but with the access/modify/change file timestamps
+in subsecond resolution, if the operating system and the filesystem
+both support such timestamps. To override the standard stat():
+
+ use Time::HiRes qw(stat);
+
+Test for the value of &Time::HiRes::d_hires_stat to find out whether
+the operating system supports subsecond file timestamps: a value
+larger than zero means yes. There are unfortunately no easy
+ways to find out whether the filesystem supports such timestamps.
+UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp
+granularity is B<two> seconds).
+
+A zero return value of &Time::HiRes::d_hires_stat means that
+Time::HiRes::stat is a no-op passthrough for CORE::stat(),
+and therefore the timestamps will stay integers. The same
+thing will happen if the filesystem does not do subsecond timestamps,
+even if the &Time::HiRes::d_hires_stat is non-zero.
+
+In any case do not expect nanosecond resolution, or even a microsecond
+resolution. Also note that the modify/access timestamps might have
+different resolutions, and that they need not be synchronized, e.g.
+if the operations are
+
+ write
+ stat # t1
+ read
+ stat # t2
+
+the access time stamp from t2 need not be greater-than the modify
+time stamp from t1: it may be equal or I<less>.
+
+=back
+
+=head1 EXAMPLES
+
+ use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
+
+ $microseconds = 750_000;
+ usleep($microseconds);
+
+ # signal alarm in 2.5s & every .1s thereafter
+ ualarm(2_500_000, 100_000);
+ # cancel that ualarm
+ ualarm(0);
+
+ # get seconds and microseconds since the epoch
+ ($s, $usec) = gettimeofday();
+
+ # measure elapsed time
+ # (could also do by subtracting 2 gettimeofday return values)
+ $t0 = [gettimeofday];
+ # do bunch of stuff here
+ $t1 = [gettimeofday];
+ # do more stuff here
+ $t0_t1 = tv_interval $t0, $t1;
+
+ $elapsed = tv_interval ($t0, [gettimeofday]);
+ $elapsed = tv_interval ($t0); # equivalent code
+
+ #
+ # replacements for time, alarm and sleep that know about
+ # floating seconds
+ #
+ use Time::HiRes;
+ $now_fractions = Time::HiRes::time;
+ Time::HiRes::sleep (2.5);
+ Time::HiRes::alarm (10.6666666);
+
+ use Time::HiRes qw ( time alarm sleep );
+ $now_fractions = time;
+ sleep (2.5);
+ alarm (10.6666666);
+
+ # Arm an interval timer to go off first at 10 seconds and
+ # after that every 2.5 seconds, in process virtual time
+
+ use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
+
+ $SIG{VTALRM} = sub { print time, "\n" };
+ setitimer(ITIMER_VIRTUAL, 10, 2.5);
+
+ use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME );
+ # Read the POSIX high resolution timer.
+ my $high = clock_getres(CLOCK_REALTIME);
+ # But how accurate we can be, really?
+ my $reso = clock_getres(CLOCK_REALTIME);
+
+ use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME );
+ clock_nanosleep(CLOCK_REALTIME, 1e6);
+ clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME);
+
+ use Time::HiRes qw( clock );
+ my $clock0 = clock();
+ ... # Do something.
+ my $clock1 = clock();
+ my $clockd = $clock1 - $clock0;
+
+ use Time::HiRes qw( stat );
+ my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10];
+
+=head1 C API
+
+In addition to the perl API described above, a C API is available for
+extension writers. The following C functions are available in the
+modglobal hash:
+
+ name C prototype
+ --------------- ----------------------
+ Time::NVtime double (*)()
+ Time::U2time void (*)(pTHX_ UV ret[2])
+
+Both functions return equivalent information (like C<gettimeofday>)
+but with different representations. The names C<NVtime> and C<U2time>
+were selected mainly because they are operating system independent.
+(C<gettimeofday> is Unix-centric, though some platforms like Win32 and
+VMS have emulations for it.)
+
+Here is an example of using C<NVtime> from C:
+
+ double (*myNVtime)(); /* Returns -1 on failure. */
+ SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0);
+ if (!svp) croak("Time::HiRes is required");
+ if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer");
+ myNVtime = INT2PTR(double(*)(), SvIV(*svp));
+ printf("The current time is: %f\n", (*myNVtime)());
+
+=head1 DIAGNOSTICS
+
+=head2 useconds or interval more than ...
+
+In ualarm() you tried to use number of microseconds or interval (also
+in microseconds) more than 1_000_000 and setitimer() is not available
+in your system to emulate that case.
+
+=head2 negative time not invented yet
+
+You tried to use a negative time argument.
+
+=head2 internal error: useconds < 0 (unsigned ... signed ...)
+
+Something went horribly wrong-- the number of microseconds that cannot
+become negative just became negative. Maybe your compiler is broken?
+
+=head2 useconds or uinterval equal to or more than 1000000
+
+In some platforms it is not possible to get an alarm with subsecond
+resolution and later than one second.
+
+=head2 unimplemented in this platform
+
+Some calls simply aren't available, real or emulated, on every platform.
+
+=head1 CAVEATS
+
+Notice that the core C<time()> maybe rounding rather than truncating.
+What this means is that the core C<time()> may be reporting the time
+as one second later than C<gettimeofday()> and C<Time::HiRes::time()>.
+
+Adjusting the system clock (either manually or by services like ntp)
+may cause problems, especially for long running programs that assume
+a monotonously increasing time (note that all platforms do not adjust
+time as gracefully as UNIX ntp does). For example in Win32 (and derived
+platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily
+drift off from the system clock (and the original time()) by up to 0.5
+seconds. Time::HiRes will notice this eventually and recalibrate.
+Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
+might help in this (in case your system supports CLOCK_MONOTONIC).
+
+Some systems have APIs but not implementations: for example QNX and Haiku
+have the interval timer APIs but not the functionality.
+
+=head1 SEE ALSO
+
+Perl modules L<BSD::Resource>, L<Time::TAI64>.
+
+Your system documentation for C<clock>, C<clock_gettime>,
+C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>,
+C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>.
+
+=head1 AUTHORS
+
+D. Wegscheid <wegscd@whirlpool.com>
+R. Schertler <roderick@argon.org>
+J. Hietaniemi <jhi@iki.fi>
+G. Aas <gisle@aas.no>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
+
+Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi.
+All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Time/Local.pm b/Master/tlpkg/tlperl.straw/lib/Time/Local.pm
new file mode 100755
index 00000000000..1eb0a0240e8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Time/Local.pm
@@ -0,0 +1,371 @@
+package Time::Local;
+
+require Exporter;
+use Carp;
+use Config;
+use strict;
+use integer;
+
+use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
+$VERSION = '1.1901';
+
+@ISA = qw( Exporter );
+@EXPORT = qw( timegm timelocal );
+@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
+
+my @MonthDays = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
+
+# Determine breakpoint for rolling century
+my $ThisYear = ( localtime() )[5];
+my $Breakpoint = ( $ThisYear + 50 ) % 100;
+my $NextCentury = $ThisYear - $ThisYear % 100;
+$NextCentury += 100 if $Breakpoint < 50;
+my $Century = $NextCentury - 100;
+my $SecOff = 0;
+
+my ( %Options, %Cheat );
+
+use constant SECS_PER_MINUTE => 60;
+use constant SECS_PER_HOUR => 3600;
+use constant SECS_PER_DAY => 86400;
+
+my $MaxInt;
+if ( $^O eq 'MacOS' ) {
+ # time_t is unsigned...
+ $MaxInt = ( 1 << ( 8 * $Config{ivsize} ) ) - 1;
+}
+else {
+ $MaxInt = ( ( 1 << ( 8 * $Config{ivsize} - 2 ) ) - 1 ) * 2 + 1;
+}
+
+my $MaxDay = int( ( $MaxInt - ( SECS_PER_DAY / 2 ) ) / SECS_PER_DAY ) - 1;
+
+# Determine the EPOC day for this machine
+my $Epoc = 0;
+if ( $^O eq 'vos' ) {
+ # work around posix-977 -- VOS doesn't handle dates in the range
+ # 1970-1980.
+ $Epoc = _daygm( 0, 0, 0, 1, 0, 70, 4, 0 );
+}
+elsif ( $^O eq 'MacOS' ) {
+ $MaxDay *=2 if $^O eq 'MacOS'; # time_t unsigned ... quick hack?
+ # MacOS time() is seconds since 1 Jan 1904, localtime
+ # so we need to calculate an offset to apply later
+ $Epoc = 693901;
+ $SecOff = timelocal( localtime(0)) - timelocal( gmtime(0) ) ;
+ $Epoc += _daygm( gmtime(0) );
+}
+else {
+ $Epoc = _daygm( gmtime(0) );
+}
+
+%Cheat = (); # clear the cache as epoc has changed
+
+sub _daygm {
+
+ # This is written in such a byzantine way in order to avoid
+ # lexical variables and sub calls, for speed
+ return $_[3] + (
+ $Cheat{ pack( 'ss', @_[ 4, 5 ] ) } ||= do {
+ my $month = ( $_[4] + 10 ) % 12;
+ my $year = ( $_[5] + 1900 ) - ( $month / 10 );
+
+ ( ( 365 * $year )
+ + ( $year / 4 )
+ - ( $year / 100 )
+ + ( $year / 400 )
+ + ( ( ( $month * 306 ) + 5 ) / 10 )
+ )
+ - $Epoc;
+ }
+ );
+}
+
+sub _timegm {
+ my $sec =
+ $SecOff + $_[0] + ( SECS_PER_MINUTE * $_[1] ) + ( SECS_PER_HOUR * $_[2] );
+
+ return $sec + ( SECS_PER_DAY * &_daygm );
+}
+
+sub timegm {
+ my ( $sec, $min, $hour, $mday, $month, $year ) = @_;
+
+ if ( $year >= 1000 ) {
+ $year -= 1900;
+ }
+ elsif ( $year < 100 and $year >= 0 ) {
+ $year += ( $year > $Breakpoint ) ? $Century : $NextCentury;
+ }
+
+ unless ( $Options{no_range_check} ) {
+ croak "Month '$month' out of range 0..11"
+ if $month > 11
+ or $month < 0;
+
+ my $md = $MonthDays[$month];
+ ++$md
+ if $month == 1 && _is_leap_year( $year + 1900 );
+
+ croak "Day '$mday' out of range 1..$md" if $mday > $md or $mday < 1;
+ croak "Hour '$hour' out of range 0..23" if $hour > 23 or $hour < 0;
+ croak "Minute '$min' out of range 0..59" if $min > 59 or $min < 0;
+ croak "Second '$sec' out of range 0..59" if $sec > 59 or $sec < 0;
+ }
+
+ my $days = _daygm( undef, undef, undef, $mday, $month, $year );
+
+ unless ($Options{no_range_check} or abs($days) < $MaxDay) {
+ my $msg = '';
+ $msg .= "Day too big - $days > $MaxDay\n" if $days > $MaxDay;
+
+ $year += 1900;
+ $msg .= "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
+
+ croak $msg;
+ }
+
+ return $sec
+ + $SecOff
+ + ( SECS_PER_MINUTE * $min )
+ + ( SECS_PER_HOUR * $hour )
+ + ( SECS_PER_DAY * $days );
+}
+
+sub _is_leap_year {
+ return 0 if $_[0] % 4;
+ return 1 if $_[0] % 100;
+ return 0 if $_[0] % 400;
+
+ return 1;
+}
+
+sub timegm_nocheck {
+ local $Options{no_range_check} = 1;
+ return &timegm;
+}
+
+sub timelocal {
+ my $ref_t = &timegm;
+ my $loc_for_ref_t = _timegm( localtime($ref_t) );
+
+ my $zone_off = $loc_for_ref_t - $ref_t
+ or return $loc_for_ref_t;
+
+ # Adjust for timezone
+ my $loc_t = $ref_t - $zone_off;
+
+ # Are we close to a DST change or are we done
+ my $dst_off = $ref_t - _timegm( localtime($loc_t) );
+
+ # If this evaluates to true, it means that the value in $loc_t is
+ # the _second_ hour after a DST change where the local time moves
+ # backward.
+ if ( ! $dst_off &&
+ ( ( $ref_t - SECS_PER_HOUR ) - _timegm( localtime( $loc_t - SECS_PER_HOUR ) ) < 0 )
+ ) {
+ return $loc_t - SECS_PER_HOUR;
+ }
+
+ # Adjust for DST change
+ $loc_t += $dst_off;
+
+ return $loc_t if $dst_off > 0;
+
+ # If the original date was a non-extent gap in a forward DST jump,
+ # we should now have the wrong answer - undo the DST adjustment
+ my ( $s, $m, $h ) = localtime($loc_t);
+ $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2];
+
+ return $loc_t;
+}
+
+sub timelocal_nocheck {
+ local $Options{no_range_check} = 1;
+ return &timelocal;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Time::Local - efficiently compute time from local and GMT time
+
+=head1 SYNOPSIS
+
+ $time = timelocal($sec,$min,$hour,$mday,$mon,$year);
+ $time = timegm($sec,$min,$hour,$mday,$mon,$year);
+
+=head1 DESCRIPTION
+
+This module provides functions that are the inverse of built-in perl
+functions C<localtime()> and C<gmtime()>. They accept a date as a
+six-element array, and return the corresponding C<time(2)> value in
+seconds since the system epoch (Midnight, January 1, 1970 GMT on Unix,
+for example). This value can be positive or negative, though POSIX
+only requires support for positive values, so dates before the
+system's epoch may not work on all operating systems.
+
+It is worth drawing particular attention to the expected ranges for
+the values provided. The value for the day of the month is the actual
+day (ie 1..31), while the month is the number of months since January
+(0..11). This is consistent with the values returned from
+C<localtime()> and C<gmtime()>.
+
+=head1 FUNCTIONS
+
+=head2 C<timelocal()> and C<timegm()>
+
+This module exports two functions by default, C<timelocal()> and
+C<timegm()>.
+
+The C<timelocal()> and C<timegm()> functions perform range checking on
+the input $sec, $min, $hour, $mday, and $mon values by default.
+
+=head2 C<timelocal_nocheck()> and C<timegm_nocheck()>
+
+If you are working with data you know to be valid, you can speed your
+code up by using the "nocheck" variants, C<timelocal_nocheck()> and
+C<timegm_nocheck()>. These variants must be explicitly imported.
+
+ use Time::Local 'timelocal_nocheck';
+
+ # The 365th day of 1999
+ print scalar localtime timelocal_nocheck 0,0,0,365,0,99;
+
+If you supply data which is not valid (month 27, second 1,000) the
+results will be unpredictable (so don't do that).
+
+=head2 Year Value Interpretation
+
+Strictly speaking, the year should be specified in a form consistent
+with C<localtime()>, i.e. the offset from 1900. In order to make the
+interpretation of the year easier for humans, however, who are more
+accustomed to seeing years as two-digit or four-digit values, the
+following conventions are followed:
+
+=over 4
+
+=item *
+
+Years greater than 999 are interpreted as being the actual year,
+rather than the offset from 1900. Thus, 1964 would indicate the year
+Martin Luther King won the Nobel prize, not the year 3864.
+
+=item *
+
+Years in the range 100..999 are interpreted as offset from 1900, so
+that 112 indicates 2012. This rule also applies to years less than
+zero (but see note below regarding date range).
+
+=item *
+
+Years in the range 0..99 are interpreted as shorthand for years in the
+rolling "current century," defined as 50 years on either side of the
+current year. Thus, today, in 1999, 0 would refer to 2000, and 45 to
+2045, but 55 would refer to 1955. Twenty years from now, 55 would
+instead refer to 2055. This is messy, but matches the way people
+currently think about two digit dates. Whenever possible, use an
+absolute four digit year instead.
+
+=back
+
+The scheme above allows interpretation of a wide range of dates,
+particularly if 4-digit years are used.
+
+=head2 Limits of time_t
+
+The range of dates that can be actually be handled depends on the size
+of C<time_t> (usually a signed integer) on the given
+platform. Currently, this is 32 bits for most systems, yielding an
+approximate range from Dec 1901 to Jan 2038.
+
+Both C<timelocal()> and C<timegm()> croak if given dates outside the
+supported range.
+
+=head2 Ambiguous Local Times (DST)
+
+Because of DST changes, there are many time zones where the same local
+time occurs for two different GMT times on the same day. For example,
+in the "Europe/Paris" time zone, the local time of 2001-10-28 02:30:00
+can represent either 2001-10-28 00:30:00 GMT, B<or> 2001-10-28
+01:30:00 GMT.
+
+When given an ambiguous local time, the timelocal() function should
+always return the epoch for the I<earlier> of the two possible GMT
+times.
+
+=head2 Non-Existent Local Times (DST)
+
+When a DST change causes a locale clock to skip one hour forward,
+there will be an hour's worth of local times that don't exist. Again,
+for the "Europe/Paris" time zone, the local clock jumped from
+2001-03-25 01:59:59 to 2001-03-25 03:00:00.
+
+If the C<timelocal()> function is given a non-existent local time, it
+will simply return an epoch value for the time one hour later.
+
+=head2 Negative Epoch Values
+
+Negative epoch (C<time_t>) values are not officially supported by the
+POSIX standards, so this module's tests do not test them. On some
+systems, they are known not to work. These include MacOS (pre-OSX) and
+Win32.
+
+On systems which do support negative epoch values, this module should
+be able to cope with dates before the start of the epoch, down the
+minimum value of time_t for the system.
+
+=head1 IMPLEMENTATION
+
+These routines are quite efficient and yet are always guaranteed to
+agree with C<localtime()> and C<gmtime()>. We manage this by caching
+the start times of any months we've seen before. If we know the start
+time of the month, we can always calculate any time within the month.
+The start times are calculated using a mathematical formula. Unlike
+other algorithms that do multiple calls to C<gmtime()>.
+
+The C<timelocal()> function is implemented using the same cache. We
+just assume that we're translating a GMT time, and then fudge it when
+we're done for the timezone and daylight savings arguments. Note that
+the timezone is evaluated for each date because countries occasionally
+change their official timezones. Assuming that C<localtime()> corrects
+for these changes, this routine will also be correct.
+
+=head1 BUGS
+
+The whole scheme for interpreting two-digit years can be considered a
+bug.
+
+=head1 SUPPORT
+
+Support for this module is provided via the datetime@perl.org email
+list. See http://lists.perl.org/ for more details.
+
+Please submit bugs to the CPAN RT system at
+http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Time-Local or via email
+at bug-time-local@rt.cpan.org.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2003 Graham Barr, 2003-2007 David Rolsky. All
+rights reserved. This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file included
+with this module.
+
+=head1 AUTHOR
+
+This module is based on a Perl 4 library, timelocal.pl, that was
+included with Perl 4.036, and was most likely written by Tom
+Christiansen.
+
+The current version was written by Graham Barr.
+
+It is now being maintained separately from the Perl core by Dave
+Rolsky, <autarch@urth.org>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Time/Piece.pm b/Master/tlpkg/tlperl.straw/lib/Time/Piece.pm
new file mode 100755
index 00000000000..ee028706f8d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Time/Piece.pm
@@ -0,0 +1,874 @@
+# $Id: Piece.pm 90 2010-01-11 21:02:28Z matt $
+
+package Time::Piece;
+
+use strict;
+
+require Exporter;
+require DynaLoader;
+use Time::Seconds;
+use Carp;
+use Time::Local;
+
+our @ISA = qw(Exporter DynaLoader);
+
+our @EXPORT = qw(
+ localtime
+ gmtime
+);
+
+our %EXPORT_TAGS = (
+ ':override' => 'internal',
+ );
+
+our $VERSION = '1.16';
+
+bootstrap Time::Piece $VERSION;
+
+my $DATE_SEP = '-';
+my $TIME_SEP = ':';
+my @MON_LIST = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+my @FULLMON_LIST = qw(January February March April May June July
+ August September October November December);
+my @DAY_LIST = qw(Sun Mon Tue Wed Thu Fri Sat);
+my @FULLDAY_LIST = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
+
+use constant 'c_sec' => 0;
+use constant 'c_min' => 1;
+use constant 'c_hour' => 2;
+use constant 'c_mday' => 3;
+use constant 'c_mon' => 4;
+use constant 'c_year' => 5;
+use constant 'c_wday' => 6;
+use constant 'c_yday' => 7;
+use constant 'c_isdst' => 8;
+use constant 'c_epoch' => 9;
+use constant 'c_islocal' => 10;
+
+sub localtime {
+ unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
+ my $class = shift;
+ my $time = shift;
+ $time = time if (!defined $time);
+ $class->_mktime($time, 1);
+}
+
+sub gmtime {
+ unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
+ my $class = shift;
+ my $time = shift;
+ $time = time if (!defined $time);
+ $class->_mktime($time, 0);
+}
+
+sub new {
+ my $class = shift;
+ my ($time) = @_;
+
+ my $self;
+
+ if (defined($time)) {
+ $self = $class->localtime($time);
+ }
+ elsif (ref($class) && $class->isa(__PACKAGE__)) {
+ $self = $class->_mktime($class->epoch, $class->[c_islocal]);
+ }
+ else {
+ $self = $class->localtime();
+ }
+
+ return bless $self, ref($class) || $class;
+}
+
+sub parse {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my @components;
+ if (@_ > 1) {
+ @components = @_;
+ }
+ else {
+ @components = shift =~ /(\d+)$DATE_SEP(\d+)$DATE_SEP(\d+)(?:(?:T|\s+)(\d+)$TIME_SEP(\d+)(?:$TIME_SEP(\d+)))/;
+ @components = reverse(@components[0..5]);
+ }
+ return $class->new(_strftime("%s", @components));
+}
+
+sub _mktime {
+ my ($class, $time, $islocal) = @_;
+ $class = eval { (ref $class) && (ref $class)->isa('Time::Piece') }
+ ? ref $class
+ : $class;
+ if (ref($time)) {
+ $time->[c_epoch] = undef;
+ return wantarray ? @$time : bless [@$time[0..9], $islocal], $class;
+ }
+ _tzset();
+ my @time = $islocal ?
+ CORE::localtime($time)
+ :
+ CORE::gmtime($time);
+ wantarray ? @time : bless [@time, $time, $islocal], $class;
+}
+
+my %_special_exports = (
+ localtime => sub { my $c = $_[0]; sub { $c->localtime(@_) } },
+ gmtime => sub { my $c = $_[0]; sub { $c->gmtime(@_) } },
+);
+
+sub export {
+ my ($class, $to, @methods) = @_;
+ for my $method (@methods) {
+ if (exists $_special_exports{$method}) {
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$to . "::$method"} = $_special_exports{$method}->($class);
+ } else {
+ $class->SUPER::export($to, $method);
+ }
+ }
+}
+
+sub import {
+ # replace CORE::GLOBAL localtime and gmtime if required
+ my $class = shift;
+ my %params;
+ map($params{$_}++,@_,@EXPORT);
+ if (delete $params{':override'}) {
+ $class->export('CORE::GLOBAL', keys %params);
+ }
+ else {
+ $class->export((caller)[0], keys %params);
+ }
+}
+
+## Methods ##
+
+sub sec {
+ my $time = shift;
+ $time->[c_sec];
+}
+
+*second = \&sec;
+
+sub min {
+ my $time = shift;
+ $time->[c_min];
+}
+
+*minute = \&min;
+
+sub hour {
+ my $time = shift;
+ $time->[c_hour];
+}
+
+sub mday {
+ my $time = shift;
+ $time->[c_mday];
+}
+
+*day_of_month = \&mday;
+
+sub mon {
+ my $time = shift;
+ $time->[c_mon] + 1;
+}
+
+sub _mon {
+ my $time = shift;
+ $time->[c_mon];
+}
+
+sub month {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_mon]];
+ }
+ elsif (@MON_LIST) {
+ return $MON_LIST[$time->[c_mon]];
+ }
+ else {
+ return $time->strftime('%b');
+ }
+}
+
+*monname = \&month;
+
+sub fullmonth {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_mon]];
+ }
+ elsif (@FULLMON_LIST) {
+ return $FULLMON_LIST[$time->[c_mon]];
+ }
+ else {
+ return $time->strftime('%B');
+ }
+}
+
+sub year {
+ my $time = shift;
+ $time->[c_year] + 1900;
+}
+
+sub _year {
+ my $time = shift;
+ $time->[c_year];
+}
+
+sub yy {
+ my $time = shift;
+ my $res = $time->[c_year] % 100;
+ return $res > 9 ? $res : "0$res";
+}
+
+sub wday {
+ my $time = shift;
+ $time->[c_wday] + 1;
+}
+
+sub _wday {
+ my $time = shift;
+ $time->[c_wday];
+}
+
+*day_of_week = \&_wday;
+
+sub wdayname {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_wday]];
+ }
+ elsif (@DAY_LIST) {
+ return $DAY_LIST[$time->[c_wday]];
+ }
+ else {
+ return $time->strftime('%a');
+ }
+}
+
+*day = \&wdayname;
+
+sub fullday {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_wday]];
+ }
+ elsif (@FULLDAY_LIST) {
+ return $FULLDAY_LIST[$time->[c_wday]];
+ }
+ else {
+ return $time->strftime('%A');
+ }
+}
+
+sub yday {
+ my $time = shift;
+ $time->[c_yday];
+}
+
+*day_of_year = \&yday;
+
+sub isdst {
+ my $time = shift;
+ $time->[c_isdst];
+}
+
+*daylight_savings = \&isdst;
+
+# Thanks to Tony Olekshy <olekshy@cs.ualberta.ca> for this algorithm
+sub tzoffset {
+ my $time = shift;
+
+ return Time::Seconds->new(0) unless $time->[c_islocal];
+
+ my $epoch = $time->epoch;
+
+ my $j = sub {
+
+ my ($s,$n,$h,$d,$m,$y) = @_; $m += 1; $y += 1900;
+
+ $time->_jd($y, $m, $d, $h, $n, $s);
+
+ };
+
+ # Compute floating offset in hours.
+ #
+ my $delta = 24 * (&$j(CORE::localtime $epoch) - &$j(CORE::gmtime $epoch));
+
+ # Return value in seconds rounded to nearest minute.
+ return Time::Seconds->new( int($delta * 60 + ($delta >= 0 ? 0.5 : -0.5)) * 60 );
+}
+
+sub epoch {
+ my $time = shift;
+ if (defined($time->[c_epoch])) {
+ return $time->[c_epoch];
+ }
+ else {
+ my $epoch = $time->[c_islocal] ?
+ timelocal(@{$time}[c_sec .. c_mon], $time->[c_year]+1900)
+ :
+ timegm(@{$time}[c_sec .. c_mon], $time->[c_year]+1900);
+ $time->[c_epoch] = $epoch;
+ return $epoch;
+ }
+}
+
+sub hms {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $TIME_SEP;
+ sprintf("%02d$sep%02d$sep%02d", $time->[c_hour], $time->[c_min], $time->[c_sec]);
+}
+
+*time = \&hms;
+
+sub ymd {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%d$sep%02d$sep%02d", $time->year, $time->mon, $time->[c_mday]);
+}
+
+*date = \&ymd;
+
+sub mdy {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%02d$sep%02d$sep%d", $time->mon, $time->[c_mday], $time->year);
+}
+
+sub dmy {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%02d$sep%02d$sep%d", $time->[c_mday], $time->mon, $time->year);
+}
+
+sub datetime {
+ my $time = shift;
+ my %seps = (date => $DATE_SEP, T => 'T', time => $TIME_SEP, @_);
+ return join($seps{T}, $time->date($seps{date}), $time->time($seps{time}));
+}
+
+
+
+# Julian Day is always calculated for UT regardless
+# of local time
+sub julian_day {
+ my $time = shift;
+ # Correct for localtime
+ $time = $time->gmtime( $time->epoch ) if $time->[c_islocal];
+
+ # Calculate the Julian day itself
+ my $jd = $time->_jd( $time->year, $time->mon, $time->mday,
+ $time->hour, $time->min, $time->sec);
+
+ return $jd;
+}
+
+# MJD is defined as JD - 2400000.5 days
+sub mjd {
+ return shift->julian_day - 2_400_000.5;
+}
+
+# Internal calculation of Julian date. Needed here so that
+# both tzoffset and mjd/jd methods can share the code
+# Algorithm from Hatcher 1984 (QJRAS 25, 53-55), and
+# Hughes et al, 1989, MNRAS, 238, 15
+# See: http://adsabs.harvard.edu/cgi-bin/nph-bib_query?bibcode=1989MNRAS.238.1529H&db_key=AST
+# for more details
+
+sub _jd {
+ my $self = shift;
+ my ($y, $m, $d, $h, $n, $s) = @_;
+
+ # Adjust input parameters according to the month
+ $y = ( $m > 2 ? $y : $y - 1);
+ $m = ( $m > 2 ? $m - 3 : $m + 9);
+
+ # Calculate the Julian Date (assuming Julian calendar)
+ my $J = int( 365.25 *( $y + 4712) )
+ + int( (30.6 * $m) + 0.5)
+ + 59
+ + $d
+ - 0.5;
+
+ # Calculate the Gregorian Correction (since we have Gregorian dates)
+ my $G = 38 - int( 0.75 * int(49+($y/100)));
+
+ # Calculate the actual Julian Date
+ my $JD = $J + $G;
+
+ # Modify to include hours/mins/secs in floating portion.
+ return $JD + ($h + ($n + $s / 60) / 60) / 24;
+}
+
+sub week {
+ my $self = shift;
+
+ my $J = $self->julian_day;
+ # Julian day is independent of time zone so add on tzoffset
+ # if we are using local time here since we want the week day
+ # to reflect the local time rather than UTC
+ $J += ($self->tzoffset/(24*3600)) if $self->[c_islocal];
+
+ # Now that we have the Julian day including fractions
+ # convert it to an integer Julian Day Number using nearest
+ # int (since the day changes at midday we oconvert all Julian
+ # dates to following midnight).
+ $J = int($J+0.5);
+
+ use integer;
+ my $d4 = ((($J + 31741 - ($J % 7)) % 146097) % 36524) % 1461;
+ my $L = $d4 / 1460;
+ my $d1 = (($d4 - $L) % 365) + $L;
+ return $d1 / 7 + 1;
+}
+
+sub _is_leap_year {
+ my $year = shift;
+ return (($year %4 == 0) && !($year % 100 == 0)) || ($year % 400 == 0)
+ ? 1 : 0;
+}
+
+sub is_leap_year {
+ my $time = shift;
+ my $year = $time->year;
+ return _is_leap_year($year);
+}
+
+my @MON_LAST = qw(31 28 31 30 31 30 31 31 30 31 30 31);
+
+sub month_last_day {
+ my $time = shift;
+ my $year = $time->year;
+ my $_mon = $time->_mon;
+ return $MON_LAST[$_mon] + ($_mon == 1 ? _is_leap_year($year) : 0);
+}
+
+sub strftime {
+ my $time = shift;
+ my $tzname = $time->[c_islocal] ? '%Z' : 'UTC';
+ my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S $tzname";
+ if (!defined $time->[c_wday]) {
+ if ($time->[c_islocal]) {
+ return _strftime($format, CORE::localtime($time->epoch));
+ }
+ else {
+ return _strftime($format, CORE::gmtime($time->epoch));
+ }
+ }
+ return _strftime($format, (@$time)[c_sec..c_isdst]);
+}
+
+sub strptime {
+ my $time = shift;
+ my $string = shift;
+ my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z";
+ my @vals = _strptime($string, $format);
+# warn(sprintf("got vals: %d-%d-%d %d:%d:%d\n", reverse(@vals)));
+ return scalar $time->_mktime(\@vals, (ref($time) ? $time->[c_islocal] : 0));
+}
+
+sub day_list {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @DAY_LIST;
+ if (@_) {
+ @DAY_LIST = @_;
+ }
+ return @old;
+}
+
+sub mon_list {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @MON_LIST;
+ if (@_) {
+ @MON_LIST = @_;
+ }
+ return @old;
+}
+
+sub time_separator {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
+ my $old = $TIME_SEP;
+ if (@_) {
+ $TIME_SEP = $_[0];
+ }
+ return $old;
+}
+
+sub date_separator {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
+ my $old = $DATE_SEP;
+ if (@_) {
+ $DATE_SEP = $_[0];
+ }
+ return $old;
+}
+
+use overload '""' => \&cdate,
+ 'cmp' => \&str_compare,
+ 'fallback' => undef;
+
+sub cdate {
+ my $time = shift;
+ if ($time->[c_islocal]) {
+ return scalar(CORE::localtime($time->epoch));
+ }
+ else {
+ return scalar(CORE::gmtime($time->epoch));
+ }
+}
+
+sub str_compare {
+ my ($lhs, $rhs, $reverse) = @_;
+ if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ $rhs = "$rhs";
+ }
+ return $reverse ? $rhs cmp $lhs->cdate : $lhs->cdate cmp $rhs;
+}
+
+use overload
+ '-' => \&subtract,
+ '+' => \&add;
+
+sub subtract {
+ my $time = shift;
+ my $rhs = shift;
+ if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
+ $rhs = $rhs->seconds;
+ }
+
+ if (shift)
+ {
+ # SWAPED is set (so someone tried an expression like NOTDATE - DATE).
+ # Imitate Perl's standard behavior and return the result as if the
+ # string $time resolves to was subtracted from NOTDATE. This way,
+ # classes which override this one and which have a stringify function
+ # that resolves to something that looks more like a number don't need
+ # to override this function.
+ return $rhs - "$time";
+ }
+
+ if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ return Time::Seconds->new($time->epoch - $rhs->epoch);
+ }
+ else {
+ # rhs is seconds.
+ return $time->_mktime(($time->epoch - $rhs), $time->[c_islocal]);
+ }
+}
+
+sub add {
+ my $time = shift;
+ my $rhs = shift;
+ if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
+ $rhs = $rhs->seconds;
+ }
+ croak "Invalid rhs of addition: $rhs" if ref($rhs);
+
+ return $time->_mktime(($time->epoch + $rhs), $time->[c_islocal]);
+}
+
+use overload
+ '<=>' => \&compare;
+
+sub get_epochs {
+ my ($lhs, $rhs, $reverse) = @_;
+ if (!UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ $rhs = $lhs->new($rhs);
+ }
+ if ($reverse) {
+ return $rhs->epoch, $lhs->epoch;
+ }
+ return $lhs->epoch, $rhs->epoch;
+}
+
+sub compare {
+ my ($lhs, $rhs) = get_epochs(@_);
+ return $lhs <=> $rhs;
+}
+
+sub add_months {
+ my ($time, $num_months) = @_;
+
+ croak("add_months requires a number of months") unless defined($num_months);
+
+ my $final_month = $time->_mon + $num_months;
+ my $num_years = 0;
+ if ($final_month > 11 || $final_month < 0) {
+ # these two ops required because we have no POSIX::floor and don't
+ # want to load POSIX.pm
+ if ($final_month < 0 && $final_month % 12 == 0) {
+ $num_years = int($final_month / 12) + 1;
+ }
+ else {
+ $num_years = int($final_month / 12);
+ }
+ $num_years-- if ($final_month < 0);
+
+ $final_month = $final_month % 12;
+ }
+
+ my @vals = _mini_mktime($time->sec, $time->min, $time->hour,
+ $time->mday, $final_month, $time->year - 1900 + $num_years);
+ # warn(sprintf("got %d vals: %d-%d-%d %d:%d:%d [%d]\n", scalar(@vals), reverse(@vals), $time->[c_islocal]));
+ return scalar $time->_mktime(\@vals, $time->[c_islocal]);
+}
+
+sub add_years {
+ my ($time, $years) = @_;
+ $time->add_months($years * 12);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Time::Piece - Object Oriented time objects
+
+=head1 SYNOPSIS
+
+ use Time::Piece;
+
+ my $t = localtime;
+ print "Time is $t\n";
+ print "Year is ", $t->year, "\n";
+
+=head1 DESCRIPTION
+
+This module replaces the standard localtime and gmtime functions with
+implementations that return objects. It does so in a backwards
+compatible manner, so that using localtime/gmtime in the way documented
+in perlfunc will still return what you expect.
+
+The module actually implements most of an interface described by
+Larry Wall on the perl5-porters mailing list here:
+http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html
+
+=head1 USAGE
+
+After importing this module, when you use localtime or gmtime in a scalar
+context, rather than getting an ordinary scalar string representing the
+date and time, you get a Time::Piece object, whose stringification happens
+to produce the same effect as the localtime and gmtime functions. There is
+also a new() constructor provided, which is the same as localtime(), except
+when passed a Time::Piece object, in which case it's a copy constructor. The
+following methods are available on the object:
+
+ $t->sec # also available as $t->second
+ $t->min # also available as $t->minute
+ $t->hour # 24 hour
+ $t->mday # also available as $t->day_of_month
+ $t->mon # 1 = January
+ $t->_mon # 0 = January
+ $t->monname # Feb
+ $t->month # same as $t->monname
+ $t->fullmonth # February
+ $t->year # based at 0 (year 0 AD is, of course 1 BC)
+ $t->_year # year minus 1900
+ $t->yy # 2 digit year
+ $t->wday # 1 = Sunday
+ $t->_wday # 0 = Sunday
+ $t->day_of_week # 0 = Sunday
+ $t->wdayname # Tue
+ $t->day # same as wdayname
+ $t->fullday # Tuesday
+ $t->yday # also available as $t->day_of_year, 0 = Jan 01
+ $t->isdst # also available as $t->daylight_savings
+
+ $t->hms # 12:34:56
+ $t->hms(".") # 12.34.56
+ $t->time # same as $t->hms
+
+ $t->ymd # 2000-02-29
+ $t->date # same as $t->ymd
+ $t->mdy # 02-29-2000
+ $t->mdy("/") # 02/29/2000
+ $t->dmy # 29-02-2000
+ $t->dmy(".") # 29.02.2000
+ $t->datetime # 2000-02-29T12:34:56 (ISO 8601)
+ $t->cdate # Tue Feb 29 12:34:56 2000
+ "$t" # same as $t->cdate
+
+ $t->epoch # seconds since the epoch
+ $t->tzoffset # timezone offset in a Time::Seconds object
+
+ $t->julian_day # number of days since Julian period began
+ $t->mjd # modified Julian date (JD-2400000.5 days)
+
+ $t->week # week number (ISO 8601)
+
+ $t->is_leap_year # true if it its
+ $t->month_last_day # 28-31
+
+ $t->time_separator($s) # set the default separator (default ":")
+ $t->date_separator($s) # set the default separator (default "-")
+ $t->day_list(@days) # set the default weekdays
+ $t->mon_list(@days) # set the default months
+
+ $t->strftime(FORMAT) # same as POSIX::strftime (without the overhead
+ # of the full POSIX extension)
+ $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT"
+
+ Time::Piece->strptime(STRING, FORMAT)
+ # see strptime man page. Creates a new
+ # Time::Piece object
+
+=head2 Local Locales
+
+Both wdayname (day) and monname (month) allow passing in a list to use
+to index the name of the days against. This can be useful if you need
+to implement some form of localisation without actually installing or
+using locales.
+
+ my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi );
+
+ my $french_day = localtime->day(@days);
+
+These settings can be overriden globally too:
+
+ Time::Piece::day_list(@days);
+
+Or for months:
+
+ Time::Piece::mon_list(@months);
+
+And locally for months:
+
+ print localtime->month(@months);
+
+=head2 Date Calculations
+
+It's possible to use simple addition and subtraction of objects:
+
+ use Time::Seconds;
+
+ my $seconds = $t1 - $t2;
+ $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds)
+
+The following are valid ($t1 and $t2 are Time::Piece objects):
+
+ $t1 - $t2; # returns Time::Seconds object
+ $t1 - 42; # returns Time::Piece object
+ $t1 + 533; # returns Time::Piece object
+
+However adding a Time::Piece object to another Time::Piece object
+will cause a runtime error.
+
+Note that the first of the above returns a Time::Seconds object, so
+while examining the object will print the number of seconds (because
+of the overloading), you can also get the number of minutes, hours,
+days, weeks and years in that delta, using the Time::Seconds API.
+
+In addition to adding seconds, there are two APIs for adding months and
+years:
+
+ $t->add_months(6);
+ $t->add_years(5);
+
+The months and years can be negative for subtractions. Note that there
+is some "strange" behaviour when adding and subtracting months at the
+ends of months. Generally when the resulting month is shorter than the
+starting month then the number of overlap days is added. For example
+subtracting a month from 2008-03-31 will not result in 2008-02-31 as this
+is an impossible date. Instead you will get 2008-03-02. This appears to
+be consistent with other date manipulation tools.
+
+=head2 Date Comparisons
+
+Date comparisons are also possible, using the full suite of "<", ">",
+"<=", ">=", "<=>", "==" and "!=".
+
+=head2 Date Parsing
+
+Time::Piece links to your C library's strptime() function, allowing
+you incredibly flexible date parsing routines. For example:
+
+ my $t = Time::Piece->strptime("Sun 3rd Nov, 1943",
+ "%A %drd %b, %Y");
+
+ print $t->strftime("%a, %d %b %Y");
+
+Outputs:
+
+ Wed, 03 Nov 1943
+
+(see, it's even smart enough to fix my obvious date bug)
+
+For more information see "man strptime", which should be on all unix
+systems.
+
+=head2 YYYY-MM-DDThh:mm:ss
+
+The ISO 8601 standard defines the date format to be YYYY-MM-DD, and
+the time format to be hh:mm:ss (24 hour clock), and if combined, they
+should be concatenated with date first and with a capital 'T' in front
+of the time.
+
+=head2 Week Number
+
+The I<week number> may be an unknown concept to some readers. The ISO
+8601 standard defines that weeks begin on a Monday and week 1 of the
+year is the week that includes both January 4th and the first Thursday
+of the year. In other words, if the first Monday of January is the
+2nd, 3rd, or 4th, the preceding days of the January are part of the
+last week of the preceding year. Week numbers range from 1 to 53.
+
+=head2 Global Overriding
+
+Finally, it's possible to override localtime and gmtime everywhere, by
+including the ':override' tag in the import list:
+
+ use Time::Piece ':override';
+
+=head1 CAVEATS
+
+=head2 Setting $ENV{TZ} in Threads on Win32
+
+Note that when using perl in the default build configuration on Win32
+(specifically, when perl is built with PERL_IMPLICIT_SYS), each perl
+interpreter maintains its own copy of the environment and only the main
+interpreter will update the process environment seen by strftime.
+
+Therefore, if you make changes to $ENV{TZ} from inside a thread other than
+the main thread then those changes will not be seen by strftime if you
+subsequently call that with the %Z formatting code. You must change $ENV{TZ}
+in the main thread to have the desired effect in this case (and you must
+also call _tzset() in the main thread to register the environment change).
+
+Furthermore, remember that this caveat also applies to fork(), which is
+emulated by threads on Win32.
+
+=head2 Use of epoch seconds
+
+This module internally uses the epoch seconds system that is provided via
+the perl C<time()> function and supported by C<gmtime()> and C<localtime()>.
+
+If your perl does not support times larger than C<2^31> seconds then this
+module is likely to fail at processing dates beyond the year 2038. There are
+moves afoot to fix that in perl. Alternatively use 64 bit perl. Or if none
+of those are options, use the L<DateTime> module which has support for years
+well into the future and past.
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org
+Jarkko Hietaniemi, jhi@iki.fi (while creating Time::Piece for core perl)
+
+=head1 License
+
+This module is free software, you may distribute it under the same terms
+as Perl.
+
+=head1 SEE ALSO
+
+The excellent Calendar FAQ at http://www.tondering.dk/claus/calendar.html
+
+=head1 BUGS
+
+The test harness leaves much to be desired. Patches welcome.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Time/Seconds.pm b/Master/tlpkg/tlperl.straw/lib/Time/Seconds.pm
new file mode 100755
index 00000000000..abc1b2c82d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Time/Seconds.pm
@@ -0,0 +1,230 @@
+# $Id: Seconds.pm 69 2006-09-07 17:41:05Z matt $
+
+package Time::Seconds;
+use strict;
+use vars qw/@EXPORT @EXPORT_OK @ISA/;
+use UNIVERSAL qw(isa);
+
+@ISA = 'Exporter';
+
+@EXPORT = qw(
+ ONE_MINUTE
+ ONE_HOUR
+ ONE_DAY
+ ONE_WEEK
+ ONE_MONTH
+ ONE_REAL_MONTH
+ ONE_YEAR
+ ONE_REAL_YEAR
+ ONE_FINANCIAL_MONTH
+ LEAP_YEAR
+ NON_LEAP_YEAR
+ );
+
+@EXPORT_OK = qw(cs_sec cs_mon);
+
+use constant ONE_MINUTE => 60;
+use constant ONE_HOUR => 3_600;
+use constant ONE_DAY => 86_400;
+use constant ONE_WEEK => 604_800;
+use constant ONE_MONTH => 2_629_744; # ONE_YEAR / 12
+use constant ONE_REAL_MONTH => '1M';
+use constant ONE_YEAR => 31_556_930; # 365.24225 days
+use constant ONE_REAL_YEAR => '1Y';
+use constant ONE_FINANCIAL_MONTH => 2_592_000; # 30 days
+use constant LEAP_YEAR => 31_622_400; # 366 * ONE_DAY
+use constant NON_LEAP_YEAR => 31_536_000; # 365 * ONE_DAY
+
+# hacks to make Time::Piece compile once again
+use constant cs_sec => 0;
+use constant cs_mon => 1;
+
+use overload
+ 'fallback' => 'undef',
+ '0+' => \&seconds,
+ '""' => \&seconds,
+ '<=>' => \&compare,
+ '+' => \&add,
+ '-' => \&subtract,
+ '-=' => \&subtract_from,
+ '+=' => \&add_to,
+ '=' => \&copy;
+
+sub new {
+ my $class = shift;
+ my ($val) = @_;
+ $val = 0 unless defined $val;
+ bless \$val, $class;
+}
+
+sub _get_ovlvals {
+ my ($lhs, $rhs, $reverse) = @_;
+ $lhs = $lhs->seconds;
+
+ if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
+ $rhs = $rhs->seconds;
+ }
+ elsif (ref($rhs)) {
+ die "Can't use non Seconds object in operator overload";
+ }
+
+ if ($reverse) {
+ return $rhs, $lhs;
+ }
+
+ return $lhs, $rhs;
+}
+
+sub compare {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return $lhs <=> $rhs;
+}
+
+sub add {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return Time::Seconds->new($lhs + $rhs);
+}
+
+sub add_to {
+ my $lhs = shift;
+ my $rhs = shift;
+ $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds');
+ $$lhs += $rhs;
+ return $lhs;
+}
+
+sub subtract {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return Time::Seconds->new($lhs - $rhs);
+}
+
+sub subtract_from {
+ my $lhs = shift;
+ my $rhs = shift;
+ $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds');
+ $$lhs -= $rhs;
+ return $lhs;
+}
+
+sub copy {
+ Time::Seconds->new(${$_[0]});
+}
+
+sub seconds {
+ my $s = shift;
+ return $$s;
+}
+
+sub minutes {
+ my $s = shift;
+ return $$s / 60;
+}
+
+sub hours {
+ my $s = shift;
+ $s->minutes / 60;
+}
+
+sub days {
+ my $s = shift;
+ $s->hours / 24;
+}
+
+sub weeks {
+ my $s = shift;
+ $s->days / 7;
+}
+
+sub months {
+ my $s = shift;
+ $s->days / 30.4368541;
+}
+
+sub financial_months {
+ my $s = shift;
+ $s->days / 30;
+}
+
+sub years {
+ my $s = shift;
+ $s->days / 365.24225;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Time::Seconds - a simple API to convert seconds to other date values
+
+=head1 SYNOPSIS
+
+ use Time::Piece;
+ use Time::Seconds;
+
+ my $t = localtime;
+ $t += ONE_DAY;
+
+ my $t2 = localtime;
+ my $s = $t - $t2;
+
+ print "Difference is: ", $s->days, "\n";
+
+=head1 DESCRIPTION
+
+This module is part of the Time::Piece distribution. It allows the user
+to find out the number of minutes, hours, days, weeks or years in a given
+number of seconds. It is returned by Time::Piece when you delta two
+Time::Piece objects.
+
+Time::Seconds also exports the following constants:
+
+ ONE_DAY
+ ONE_WEEK
+ ONE_HOUR
+ ONE_MINUTE
+ ONE_MONTH
+ ONE_YEAR
+ ONE_FINANCIAL_MONTH
+ LEAP_YEAR
+ NON_LEAP_YEAR
+
+Since perl does not (yet?) support constant objects, these constants are in
+seconds only, so you cannot, for example, do this: C<print ONE_WEEK-E<gt>minutes;>
+
+=head1 METHODS
+
+The following methods are available:
+
+ my $val = Time::Seconds->new(SECONDS)
+ $val->seconds;
+ $val->minutes;
+ $val->hours;
+ $val->days;
+ $val->weeks;
+ $val->months;
+ $val->financial_months; # 30 days
+ $val->years;
+
+The methods make the assumption that there are 24 hours in a day, 7 days in
+a week, 365.24225 days in a year and 12 months in a year.
+(from The Calendar FAQ at http://www.tondering.dk/claus/calendar.html)
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org
+
+Tobias Brox, tobiasb@tobiasb.funcom.com
+
+Bal�zs Szab� (dLux), dlux@kapu.hu
+
+=head1 LICENSE
+
+Please see Time::Piece for the license.
+
+=head1 Bugs
+
+Currently the methods aren't as efficient as they could be, for reasons of
+clarity. This is probably a bad idea.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Time/gmtime.pm b/Master/tlpkg/tlperl.straw/lib/Time/gmtime.pm
new file mode 100755
index 00000000000..eb5b371a004
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Time/gmtime.pm
@@ -0,0 +1,91 @@
+package Time::gmtime;
+use strict;
+use 5.006_001;
+
+use Time::tm;
+
+our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
+BEGIN {
+ use Exporter ();
+ @ISA = qw(Exporter Time::tm);
+ @EXPORT = qw(gmtime gmctime);
+ @EXPORT_OK = qw(
+ $tm_sec $tm_min $tm_hour $tm_mday
+ $tm_mon $tm_year $tm_wday $tm_yday
+ $tm_isdst
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+ $VERSION = 1.03;
+}
+use vars @EXPORT_OK;
+
+sub populate (@) {
+ return unless @_;
+ my $tmob = Time::tm->new();
+ @$tmob = (
+ $tm_sec, $tm_min, $tm_hour, $tm_mday,
+ $tm_mon, $tm_year, $tm_wday, $tm_yday,
+ $tm_isdst )
+ = @_;
+ return $tmob;
+}
+
+sub gmtime (;$) { populate CORE::gmtime(@_ ? shift : time)}
+sub gmctime (;$) { scalar CORE::gmtime(@_ ? shift : time)}
+
+1;
+__END__
+
+=head1 NAME
+
+Time::gmtime - by-name interface to Perl's built-in gmtime() function
+
+=head1 SYNOPSIS
+
+ use Time::gmtime;
+ $gm = gmtime();
+ printf "The day in Greenwich is %s\n",
+ (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ $gm->wday() ];
+
+ use Time::gmtime qw(:FIELDS);
+ gmtime();
+ printf "The day in Greenwich is %s\n",
+ (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ $tm_wday ];
+
+ $now = gmctime();
+
+ use Time::gmtime;
+ use File::stat;
+ $date_string = gmctime(stat($file)->mtime);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core gmtime() function,
+replacing it with a version that returns "Time::tm" objects.
+This object has methods that return the similarly named structure field
+name from the C's tm structure from F<time.h>; namely sec, min, hour,
+mday, mon, year, wday, yday, and isdst.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this
+still overrides your core functions.) Access these fields as variables
+named with a preceding C<tm_> in front their method names. Thus,
+C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields.
+
+The gmctime() function provides a way of getting at the
+scalar sense of the original CORE::gmtime() function.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl.straw/lib/Time/localtime.pm b/Master/tlpkg/tlperl.straw/lib/Time/localtime.pm
new file mode 100755
index 00000000000..c3d9fb36085
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Time/localtime.pm
@@ -0,0 +1,86 @@
+package Time::localtime;
+use strict;
+use 5.006_001;
+
+use Time::tm;
+
+our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
+BEGIN {
+ use Exporter ();
+ @ISA = qw(Exporter Time::tm);
+ @EXPORT = qw(localtime ctime);
+ @EXPORT_OK = qw(
+ $tm_sec $tm_min $tm_hour $tm_mday
+ $tm_mon $tm_year $tm_wday $tm_yday
+ $tm_isdst
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+ $VERSION = 1.02;
+}
+use vars @EXPORT_OK;
+
+sub populate (@) {
+ return unless @_;
+ my $tmob = Time::tm->new();
+ @$tmob = (
+ $tm_sec, $tm_min, $tm_hour, $tm_mday,
+ $tm_mon, $tm_year, $tm_wday, $tm_yday,
+ $tm_isdst )
+ = @_;
+ return $tmob;
+}
+
+sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)}
+sub ctime (;$) { scalar CORE::localtime(@_ ? shift : time) }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Time::localtime - by-name interface to Perl's built-in localtime() function
+
+=head1 SYNOPSIS
+
+ use Time::localtime;
+ printf "Year is %d\n", localtime->year() + 1900;
+
+ $now = ctime();
+
+ use Time::localtime;
+ use File::stat;
+ $date_string = ctime(stat($file)->mtime);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core localtime() function,
+replacing it with a version that returns "Time::tm" objects.
+This object has methods that return the similarly named structure field
+name from the C's tm structure from F<time.h>; namely sec, min, hour,
+mday, mon, year, wday, yday, and isdst.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as
+variables named with a preceding C<tm_> in front their method names.
+Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import
+the fields.
+
+The ctime() function provides a way of getting at the
+scalar sense of the original CORE::localtime() function.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl.straw/lib/Time/tm.pm b/Master/tlpkg/tlperl.straw/lib/Time/tm.pm
new file mode 100755
index 00000000000..2c308ebb411
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Time/tm.pm
@@ -0,0 +1,33 @@
+package Time::tm;
+use strict;
+
+our $VERSION = '1.00';
+
+use Class::Struct qw(struct);
+struct('Time::tm' => [
+ map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst }
+]);
+
+1;
+__END__
+
+=head1 NAME
+
+Time::tm - internal object used by Time::gmtime and Time::localtime
+
+=head1 SYNOPSIS
+
+Don't use this module directly.
+
+=head1 DESCRIPTION
+
+This module is used internally as a base class by Time::localtime And
+Time::gmtime functions. It creates a Time::tm struct object which is
+addressable just like's C's tm structure from F<time.h>; namely with sec,
+min, hour, mday, mon, year, wday, yday, and isdst.
+
+This class is an internal interface only.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/804delta.pod b/Master/tlpkg/tlperl.straw/lib/Tk/804delta.pod
new file mode 100755
index 00000000000..1472f38c86b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/804delta.pod
@@ -0,0 +1,110 @@
+=head1 NAME
+
+Tk::804delta - what is new for perl/Tk 804
+
+=head1 DESCRIPTION
+
+This document describes differences between the Tk800 series and the
+Tk804 series.
+
+=head1 Incompatible Changes
+
+In Tk804.028, there are some additional incompatible changes:
+
+Return values of some B<Tk::Wm> methods (e.g. B<aspect>, B<wmGrid>,
+B<iconposition>, B<resizable> ...) were changed from returning tclish
+lists (e.g. "1 2 3 4") to perlish lists (1,2,3,4).
+
+B<Tk::Wm::wmTracing> needs argument for setting on/off, without argument
+just return the current value.
+
+All Tk804 releases have the following incompatible changes:
+
+Tk804 will only work with perl 5.8.0 and above. For older perl
+versions look for Tk800.025.
+
+B<curselection> of B<Tk::Listbox> now returns an array reference in
+scalar context. This means you have to write
+
+ my(@selected) = $listbox->curselection
+
+or
+
+ my(@selected) = @{ $listbox->curselection }
+
+now.
+
+The B<fontActual> method now returns the pixel value instead of the
+point value for B<-size>. Pixel values are expressed as negative
+numbers.
+
+Some enhancements from the E<quot>dashE<quot> patches are lost for now
+(i.e. B<-tile>, B<-troughtile> ...).
+
+The B<-state> option is not available anymore for B<Tk::Text> tags.
+Use B<-elide> instead.
+
+=head1 Enhancements
+
+Tk804 is Unicode-aware.
+
+It is possible to build Tk with Xft support on X11. This is strongly
+recommened if you are planning to make use of Unicode rendering
+capabilities of Tk. It also gives anti-aliased fonts for regular text
+(if you have TrueType or Type1 fonts and they are in your fontconfig
+config file).
+
+The new method B<chooseDirectory> is available as a standard directory
+selector.
+
+B<Tk::PNG> and B<Tk::JPEG> are bundled now with the perl/Tk
+distribution, providing support for the image formats B<png> and
+B<jpeg>.
+
+Improvements to B<Tk::Listbox>: new option B<-activestyle>, new
+methods B<itemconfigure> and B<itemcget>, new virtual event B<<<
+<<ListboxSelect>> >>>.
+
+More tests.
+
+=head1 New Widgets
+
+=over
+
+=item Tk::Labelframe
+
+An alternative to B<Tk::LabFrame>.
+
+=item Tk::Panedwindow
+
+An alternative to B<Tk::Adjuster>.
+
+=item Tk::Spinbox
+
+An alternative to the CPAN module B<Tk::NumEntry>.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=head1 Changed Internals
+
+=head1 Platform Specific Problems
+
+=head1 Future Directions
+
+=head1 Reporting Bugs
+
+If you find what you think is a bug, you might check the articles
+recently posted to the comp.lang.perl.tk newsgroup.
+
+If you believe you have an unreported bug, please send a mail to <ptk@lists.stanford.edu> and/or <nick@ing-simmons.net>. Be sure to trim your bug down
+to a tiny but sufficient test case.
+
+=head1 SEE ALSO
+
+L<Tk>, C<Changes> file in the Perl/Tk distribution.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Adjuster.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Adjuster.pm
new file mode 100755
index 00000000000..bbe44f33dc8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Adjuster.pm
@@ -0,0 +1,438 @@
+package Tk::Adjuster;
+
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Adjuster.pm#7 $
+
+use base qw(Tk::Frame);
+
+# We cannot do this :
+
+# Construct Tk::Widget 'packAdjust';
+
+# because if managed object is Derived (e.g. a Scrolled) then our 'new'
+# will be delegated and hierachy gets turned inside-out
+# So packAdjust is autoloaded in Widget.pm
+
+
+Construct Tk::Widget qw(Adjuster);
+
+{package Tk::Adjuster::Item;
+
+use strict;
+use base qw(Tk::Frame);
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<1>',['BDown', 1]);
+ $mw->bind($class,'<Shift-1>',['BDown', 0]);
+ $mw->bind($class,'<B1-Motion>',['Motion',1]);
+ $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]);
+ $mw->bind($class,'<ButtonRelease-1>',['Motion',0]);
+ return $class;
+}
+
+sub BDown
+{
+ my($w, $delay_mask) = @_;
+ $w->{'start_x'} = $w->XEvent->x;
+ $w->{'start_y'} = $w->XEvent->y;
+ my $adj = $w->Parent;
+ delete $adj->{'lin_info'};
+ my $delay = $delay_mask && $adj->cget('-delay');
+ if ($delay)
+ {
+ $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0);
+ }
+}
+
+sub Motion
+{
+ my($w, $delay_mask) = @_;
+ my $ev = $w->XEvent;
+ my $adj = $w->Parent;
+
+ my $delay = $delay_mask && $adj->cget('-delay');
+ if ($adj->vert)
+ {
+ my $dx = $ev->x - $w->{'start_x'};
+ $delay ? $adj->delta_width_bar($dx) : $adj->delta_width($dx);
+ }
+ else
+ {
+ my $dy = $ev->y - $w->{'start_y'};
+ $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy);
+ }
+}
+
+}
+
+
+
+sub packAfter
+{
+ my ($w,$s,%args) = @_;
+ my $side = $args{'-side'} ? $args{'-side'} : 'top';
+ $w->configure(-side => $side, -widget => $s);
+ $w->packed($s, %args);
+}
+
+sub packForget
+{
+ my ($w,$forget_slave) = @_;
+ $w->Tk::Widget::packForget;
+ $w->slave->packForget if $forget_slave;
+}
+
+# Called by Tk::Widget::packAdjust. It was here before packAfter was added
+sub packed
+{
+ my ($w,$s,%args) = @_;
+ delete $args{'-before'};
+ delete $args{'-in'};
+ $args{'-expand'} = 0;
+ $args{'-after'} = $s;
+ $args{'-fill'} = (($w->vert) ? 'y' : 'x');
+ $w->pack(%args);
+}
+
+sub gridded
+{
+ my ($w,$s,%args) = @_;
+ # delete $args{'-before'};
+ # $args{'-expand'} = 0;
+ # $args{'-after'} = $s;
+ # $args{'-fill'} = (($w->vert) ? 'y' : 'x');
+ $w->grid(%args);
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>','SizeChange');
+ $mw->bind($class,'<Unmap>','Restore');
+ $mw->bind($class,'<Map>','Mapped');
+ return $class;
+}
+
+sub SizeChange
+{
+ my $w = shift;
+ # reqwidth/height of Adjuster is stored here. If it is partially pushed out
+ # of the window, then $w->width/height returns that of the visible part.
+ if ($w->vert)
+ {
+ my $sx = ($w->Width - $w->{'sep'}->Width)/2;
+ $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18);
+ $w->{'sep'}->place('-x' => $sx, '-y' => 0, -relheight => 1);
+ $w->configure(-width => $w->{'but'}->ReqWidth);
+ $w->{'reqwidth'} = $w->reqwidth;
+ }
+ else
+ {
+ my $sy = ($w->Height - $w->{'sep'}->Height)/2;
+ $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0);
+ $w->{'sep'}->place('-x' => 0, '-y' => $sy, -relwidth => 1);
+ $w->configure(-height => $w->{'but'}->ReqHeight);
+ $w->{'reqheight'} = $w->reqheight;
+ }
+ # Turn off geometry propagation in the slave. Do only if necessary, as this
+ # causes repacking.
+ my $s = $w->slave;
+ $s->packPropagate('0') if $s->packSlaves && $s->packPropagate();
+ $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate();
+}
+
+sub Mapped
+{
+ my $w = shift;
+ $w->idletasks;
+ my $m = $w->manager;
+ if ($m =~ /^(?:pack|grid)$/)
+ {
+ my %info = $w->$m('info');
+ my $master = $info{'-in'};
+ $master->$m('propagate',0);
+ $w->{'master'} = $master;
+ }
+ $w->slave_expand_off;
+}
+
+sub Populate
+{
+ my ($w,$args) = @_;
+ $w->SUPER::Populate($args);
+ $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken');
+ $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised');
+
+ # Force creation of Frame in widget's Toplevel. This makes a difference
+ # where the widget's Toplevel has Delegates('Construct') set.
+ # Need to explicitly set frame width to 0 for Win32
+ my $l = $w->{'lin'} = Tk::Frame->new($w->toplevel, -bd => 0);
+ # my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0);
+
+ my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
+ -side => ['METHOD','side','Side','top'],
+ -delay => ['PASSIVE','delay','Delay', 1],
+ -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef],
+ -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'],
+ -restore => ['PASSIVE','restore', 'Restore', 1],
+ );
+ $w->_OnDestroy(qw(sep but lin master));
+}
+
+sub side
+{
+ my ($w,$val) = @_;
+ if (@_ > 1)
+ {
+ $w->{'side'} = $val;
+ my $cursor;
+ if ($w->vert)
+ {
+ $cursor = 'sb_h_double_arrow';
+ $w->{'sep'}->configure(-width => 2, -height => 10000);
+ }
+ else
+ {
+ $cursor = 'sb_v_double_arrow';
+ $w->{'sep'}->configure(-height => 2, -width => 10000);
+ }
+ my $x;
+ foreach $x ($w->{'sep'},$w->{'but'})
+ {
+ $x->configure(-cursor => $cursor);
+ }
+ }
+ return $w->{'side'};
+}
+
+sub slave
+{
+ my $w = shift;
+ my $s = $w->cget('-widget');
+ return $s;
+}
+
+sub vert
+{
+ my $w = shift;
+ my $side = $w->cget('-side');
+ return 1 if $side eq 'left';
+ return -1 if $side eq 'right';
+ return 0;
+}
+
+# If the Adjuster gets unmapped, it attempts to restore itself. If its
+# slave is mapped, then it reduces the size of the slave so that there is
+# then room in the master for the Adjuster widget.
+sub Restore
+{
+ my $w = shift;
+ return if ! $w->toplevel->IsMapped ||
+ ! $w->slave->IsMapped ||
+ ! $w->cget('-restore');
+ $w->vert ? $w->delta_width(0) : $w->delta_height(0);
+}
+
+sub delta_width_bar
+{
+ my ($w,$dx) = @_;
+ my $l = $w->{'lin'};
+ my $r = $w->{'sep'};
+ my $t = $w->toplevel;
+ my $m = $w->{'master'};
+ my $s = $w->slave;
+ my ($min_rootx, $max_rootx, $t_border);
+ if (! $w->{'lin_info'})
+ {
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ $t_border = $t->cget('-bd') + $t->cget('-highlightthickness');
+ if ($w->cget('-side') eq 'right')
+ {
+ $min_rootx = $m->rootx + $m_border;
+ $max_rootx = $s->rootx + $s->width - 1;
+ }
+ else
+ {
+ $min_rootx = $s->rootx;
+ $max_rootx = $m->rootx + $m->width - $m_border - 1;
+ }
+ $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border];
+ }
+ else
+ {
+ ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}};
+ }
+ $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped;
+
+ my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx;
+ $new_rootx = $min_rootx if $new_rootx < $min_rootx;
+ $new_rootx = $max_rootx if $new_rootx > $max_rootx;
+ my $placex = $new_rootx - $t->rootx - $t_border;
+ my $placey = $w->rooty - $t->rooty - $t_border;
+ $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey);
+ my $this = $w->containing($new_rootx, $w->rooty + 1);
+ $l->raise($this) if $this && $this ne $t;
+}
+
+sub delta_width
+{
+ my ($w,$dx) = @_;
+ my $l = $w->{'lin'};
+ $l->placeForget;
+ my $s = $w->slave;
+ if ($s)
+ {
+ my $m = $w->{'master'};
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ my $w_width = $w->{'reqwidth'};
+ my $m_width = $m->width;
+ my $s_width = $s->width;
+ my $max_width = $m_width - $w_width;
+ my $max_s_width;
+ if ($w->cget('-side') eq 'right')
+ {
+ $dx = -$dx;
+ $max_s_width = $max_width -
+ ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border;
+ }
+ else
+ {
+ $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border;
+ }
+ my $new_width = $s_width+$dx;
+ $new_width = $max_s_width if $new_width > $max_s_width;
+ $new_width = 0 if $new_width < 0;
+ $s->GeometryRequest($new_width, $s->height);
+ }
+}
+
+sub delta_height_bar
+{
+ my ($w,$dy) = @_;
+ my $l = $w->{'lin'};
+ my $r = $w->{'sep'};
+ my $t = $w->toplevel;
+ my $m = $w->{'master'};
+ my $s = $w->slave;
+ my ($min_rooty, $max_rooty, $t_border);
+ if (! $w->{'lin_info'})
+ {
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ $t_border = $t->cget('-bd') + $t->cget('-highlightthickness');
+ if ($w->cget('-side') eq 'bottom')
+ {
+ $min_rooty = $m->rooty + $m_border;
+ $max_rooty = $s->rooty + $s->height - 1;
+ }
+ else
+ {
+ $min_rooty = $s->rooty;
+ $max_rooty = $m->rooty + $m->height - $m_border - 1;
+ }
+ $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border];
+ }
+ else
+ {
+ ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}};
+ }
+ $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped;
+
+ my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy;
+ $new_rooty = $min_rooty if $new_rooty < $min_rooty;
+ $new_rooty = $max_rooty if $new_rooty > $max_rooty;
+ my $placey = $new_rooty - $t->rooty - $t_border;
+ my $placex = $w->rootx - $t->rootx - $t_border;
+ $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey);
+ my $this = $w->containing($w->rootx + 1, $new_rooty);
+ $l->raise($this) if $this && $this ne $t;
+}
+
+sub delta_height
+{
+ my ($w,$dy) = @_;
+ my $l = $w->{'lin'};
+ $l->placeForget;
+ my $s = $w->slave;
+ if ($s)
+ {
+ my $m = $w->{'master'};
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ my $w_height = $w->{'reqheight'};
+ my $m_height = $m->height;
+ my $s_height = $s->height;
+ my $max_height = $m_height - $w_height;
+ my $max_s_height;
+ if ($w->cget('-side') eq 'bottom')
+ {
+ $dy = -$dy;
+ $max_s_height = $max_height -
+ ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border;
+ }
+ else
+ {
+ $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border;
+ }
+ my $new_height = $s_height+$dy;
+
+ $new_height = $max_s_height if $new_height > $max_s_height;
+ $new_height = 0 if $new_height < 0;
+ $s->GeometryRequest($s->width, $new_height);
+ }
+}
+
+# Turn off expansion in the slave.
+# This is done only if necessary, as calls to pack/gridConfigure cause
+# repacking.
+# Before call to pack/gridConfigure, the reqwidth/reqheight is set to the
+# current width/height. This is because the geometry managers use
+# the requested values, not the actual, to calculate the new geometry.
+sub slave_expand_off
+{
+ my $w = shift;
+ my $s = $w->slave;
+ return if ! $s;
+
+ my $manager = $s->manager;
+ if ($manager eq 'pack')
+ {
+ my %info = $s->packInfo;
+ my $expand = $info{'-expand'};
+ if ($expand)
+ {
+ $s->GeometryRequest($s->width, $s->height);
+ $s->packConfigure(-expand => 0);
+ }
+ }
+ elsif ($manager eq 'grid')
+ {
+ my %info = $s->gridInfo;
+ my $master = $info{'-in'};
+ if ($w->vert)
+ {
+ my $col = $info{'-column'};
+ my $expand = $master->gridColumnconfigure($col, '-weight');
+ if ($expand)
+ {
+ $s->GeometryRequest($s->width, $s->height);
+ $master->gridColumnconfigure($col, -weight => 0);
+ }
+ }
+ else
+ {
+ my $row = $info{'-row'};
+ my $expand = $master->gridRowconfigure($row, '-weight');
+ if ($expand)
+ {
+ $s->GeometryRequest($s->width, $s->height);
+ $master->gridRowconfigure($row, -weight => 0);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Adjuster.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Adjuster.pod
new file mode 100755
index 00000000000..7d094f4e262
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Adjuster.pod
@@ -0,0 +1,223 @@
+
+=head1 NAME
+
+Tk::Adjuster - Allow size of packed widgets to be adjusted by user
+
+=for pm Tk/Adjuster.pm
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+use Tk::Adjuster;
+
+I<$adjuster> = I<$widget>->B<Adjuster>I<(?options?)>;
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<restore>
+
+=item Class: B<Restore>
+
+=item Switch: B<-restore>
+
+Specifies a boolean value that determines whether the Adjuster
+should forcibly attempt to make room
+for itself (by reducing the size of its managed widget) when it is
+unmapped (for example, due to a size change in a top level window).
+The default value is 1.
+
+=item Name: B<side>
+
+=item Class: B<Side>
+
+=item Switch: B<-side>
+
+Specifies the side on which the managed widget lies relative to the
+Adjuster. In conjunction with the pack geometry manager, this relates to
+the side of the master against which the managed widget and the Adjuster
+are packed.
+Must be B<left>, B<right>, B<top>, or B<bottom>. Defaults to B<top>.
+
+=item Name: B<widget>
+
+=item Class: B<Widget>
+
+=item Switch: B<-widget>
+
+Specifies the widget which is to be managed by the Adjuster.
+
+=back
+
+=head1 DESCRIPTION
+
+B<Tk::Adjuster> is a Frame containing a "line" and a "blob".
+
+Dragging with Mouse Button-1 results in a line being dragged
+to indicate new size. Releasing Button-1 submits GeometryRequests
+on behalf of the managed widget which will cause the packer to change the
+widget's size.
+
+If Drag is done with Shift button down, then GeometryRequests are made
+in "real time" so that text-flow effects can be seen, but as a lot more
+work is done behaviour may be sluggish.
+
+If widget is packed with -side => left or -side => right then width is
+adjusted. If packed -side => top or -side => bottom then height is adjusted.
+
+B<packPropagate> is turned off for the master window to prevent adjustment
+changing overall window size. Similarly B<packPropagate> is turned off
+for the managed widget if it has things packed inside it. This is so that
+the GeometryRequests made by B<Tk::Adjuster> are not overridden by pack.
+
+In addition, the managed widget is made non-expandable
+to prevent the geometry manager reallocating freed space in the master
+back to the managed widget.
+Note however that expansion is turned off only after the Adjuster is mapped,
+which allows the managed widget to expand naturally on window creation.
+
+The Tk::Widget method, B<packAdjust>, calls pack on the widget, then
+creates an instance of B<Tk::Adjuster>,
+and packs that "after" the widget. Its use has two disadvantages however: the
+Adjuster widget is not made available to the caller, and
+options cannot be set on the Adjuster. For these reasons, the Tk::Adjuster
+method, B<packAfter> is preferred, but B<packAdjust> is retained
+for backwards compatibility.
+
+=head1 WIDGET METHODS
+
+=over 4
+
+=item I<$adjuster>->B<packAfter>(I<managed_widget, ?pack_options?>)
+
+This command configures the Adjuster's B<-widget> and B<-side> options
+respectively to I<managed_widget> and the B<-side> value specified in
+I<pack_options> (B<top> if not specified). It then packs the Adjuster
+after I<managed_widget>, with B<-fill> set to B<x> or B<y> as appropriate.
+
+=item I<$adjuster>->B<packForget>I<?(boolean)?>
+
+This command calls B<Tk::Widget::packForget> on the Adjuster.
+If a parameter is provided and it has a true boolean value, then
+B<packForget> is also called on the managed widget.
+
+=item I<$adjuster>->B<slave>
+
+This command returns the value I<$adjuster>->I<cget('-widget')>, ie. the
+reference to the managed widget.
+
+=back
+
+=head1 EXAMPLES
+
+B<Using an Adjuster to separate two widgets, whereby the left widget
+is managed, and right widget expands to fill space on a window resize>
+
+a) Using packAfter (preferred interface)
+
+ use Tk;
+ use Tk::Adjuster;
+
+ my $f = MainWindow->new;
+ my $lst1 = $f->Listbox();
+ my $adj1 = $f->Adjuster();
+ my $lst2 = $f->Listbox();
+
+ my $side = 'left';
+ $lst1->pack(-side => $side, -fill => 'both', -expand => 1);
+ $adj1->packAfter($lst1, -side => $side);
+ $lst2->pack(-side => $side, -fill => 'both', -expand => 1);
+ MainLoop;
+
+b) Using packAdjust
+
+ use Tk;
+ use Tk::Adjuster;
+
+ my $f = MainWindow->new;
+ my $lst1 = $f->Listbox();
+ my $lst2 = $f->Listbox();
+
+ my $side = 'left';
+ $lst1->packAdjust(-side => $side, -fill => 'both');
+ $lst2->pack (-side => $side, -fill => 'both', -expand => 1);
+ MainLoop;
+
+c) Using the standard Tk::Widget::pack
+
+ use Tk;
+ use Tk::Adjuster;
+
+ my $f = MainWindow->new;
+ my $side = 'left';
+ my $lst1 = $f->Listbox();
+ my $adj = $f->Adjuster(-widget => $lst1, -side => $side);
+ my $lst2 = $f->Listbox();
+
+ $lst1->pack(-side => $side, -fill => 'both', -expand => 1);
+ $adj->pack (-side => $side, -fill => 'y');
+ $lst2->pack(-side => $side, -fill => 'both', -expand => 1);
+
+ MainLoop;
+
+Changing the above examples so that $side has the value 'right' means the
+left widget expands to fill space on a window resize.
+
+Changing the above examples so that $side has the value 'top'
+produces a testcase with a horizontal Adjuster.
+Here the bottom widget expands to fill space on a window resize.
+Packing to the 'bottom' makes the top widget expand to fill space on window
+resize.
+
+B<Using -restore =E<gt> 0 for multiple columns>
+
+In the case of multiple columns (or rows) the "restore" functionality of the
+Adjuster can be inconvenient. When the user adjusts the width of one column
+and thereby pushes the Adjuster of another column off the window, this
+adjuster tries to restore itself by reducing the size of its managed widget.
+This has the effect that column widths shrink; and the original size
+is not restored when
+the user reverses the originating change. The B<-restore> option can be
+used to turn off this functionality. (It makes some sense, however, to
+leave B<-restore>
+turned on for the first-packed Adjuster, so that at least one Adjuster
+always remains visible.)
+
+ use Tk;
+ use Tk::Adjuster;
+ my $f = MainWindow->new;
+ my $lst1 = $f->Listbox();
+ my $adj1 = $f->Adjuster();
+ my $lst2 = $f->Listbox();
+ my $adj2 = $f->Adjuster(-restore => 0);
+ my $lst3 = $f->Listbox();
+
+ my $side = 'left';
+ $lst1->pack(-side => $side, -fill => 'both', -expand => 1);
+ $adj1->packAfter($lst1, -side => $side);
+ $lst2->pack(-side => $side, -fill => 'both', -expand => 1);
+ $adj2->packAfter($lst2, -side => $side);
+ $lst3->pack(-side => $side, -fill => 'both', -expand => 1);
+
+ MainLoop;
+
+=head1 BUGS
+
+It is currently not possible to configure the appearance of the Adjuster.
+It would be nice to be able to set the width and relief of the Adjuster "line"
+and the presence/absence of the "blob" on the Adjuster.
+
+Tk::Adjuster works theoretically with the grid geometry manager but there
+are currently some problems which seem to be due to bugs in grid:
+
+ a) There's never an Unmap event for the adjuster, so the "restore"
+ functionality has no effect.
+ b) After adjusting, widgets protrude into the border of the master.
+ c) grid('Propagate', 0) on MainWindow has no effect - window shrinks/grows
+ when widgets are adjusted.
+ d) Widgets shuffle to correct position on startup
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/After.pm b/Master/tlpkg/tlperl.straw/lib/Tk/After.pm
new file mode 100755
index 00000000000..85a0e406ee5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/After.pm
@@ -0,0 +1,104 @@
+# 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.
+package Tk::After;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $
+
+sub _cancelAll
+{
+ my $w = shift;
+ my $h = delete $w->{_After_};
+ foreach my $obj (values %$h)
+ {
+ # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
+ $obj->cancel;
+ bless $obj,"Tk::After::Cancelled";
+ }
+}
+
+sub Tk::After::Cancelled::once { }
+sub Tk::After::Cancelled::repeat { }
+
+sub submit
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ my $t = $obj->[2];
+ my $method = $obj->[3];
+ delete($w->{_After_}{$id}) if (defined $id);
+ $id = $w->Tk::after($t,[$method => $obj]);
+ unless (exists $w->{_After_})
+ {
+ $w->{_After_} = {};
+ $w->OnDestroy([\&_cancelAll, $w]);
+ }
+ $w->{_After_}{$id} = $obj;
+ $obj->[1] = $id;
+ return $obj;
+}
+
+sub DESTROY
+{
+ my $obj = shift;
+ $obj->cancel;
+ undef $obj->[0];
+ undef $obj->[4];
+}
+
+sub new
+{
+ my ($class,$w,$t,$method,@cb) = @_;
+ my $cb = (@cb == 1) ? shift(@cb) : [@cb];
+ my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
+ return $obj->submit;
+}
+
+sub cancel
+{
+ my $obj = shift;
+ my $id = $obj->[1];
+ my $w = $obj->[0];
+ if ($id)
+ {
+ $w->Tk::after('cancel'=> $id) if Tk::Exists($w);
+ delete $w->{_After_}{$id} if exists $w->{_After_};
+ $obj->[1] = undef;
+ }
+ return $obj;
+}
+
+sub repeat
+{
+ my $obj = shift;
+ $obj->submit;
+ local $Tk::widget = $obj->[0];
+ $obj->[4]->Call;
+}
+
+sub once
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ delete $w->{_After_}{$id};
+ local $Tk::widget = $w;
+ $obj->[4]->Call;
+}
+
+sub time {
+ my $obj = shift;
+ my $delay = shift;
+ if (defined $delay) {
+ $obj->cancel if $delay == 0;
+ $obj->[2] = $delay;
+ }
+ $obj->[2];
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Animation.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Animation.pm
new file mode 100755
index 00000000000..24cfacb4a7c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Animation.pm
@@ -0,0 +1,230 @@
+package Tk::Animation;
+
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Animation.pm#8 $
+
+use Tk::Photo;
+use base qw(Tk::Photo);
+
+Construct Tk::Widget 'Animation';
+
+sub MainWindow
+{
+ return shift->{'_MainWIndow_'};
+}
+
+sub add_frame
+{
+ my $obj = shift;
+ $obj->{'_frames_'} = [] unless exists $obj->{'_frames_'};
+ push(@{$obj->{'_frames_'}},@_);
+}
+
+sub new
+{
+ my ($class,$widget,%args) = @_;
+ my $obj = $class->SUPER::new($widget,%args);
+ $obj->{'_MainWIndow_'} = $widget->MainWindow;
+ if ($args{'-format'} eq 'gif')
+ {
+ my @images;
+ local $@;
+ while (1)
+ {
+ my $index = @images;
+ $args{'-format'} = "gif -index $index";
+ my $img;
+ eval {local $SIG{'__DIE__'}; $img = $class->SUPER::new($widget,%args) };
+ last if $@;
+ push(@images,$img);
+ }
+ if (@images > 1)
+ {
+ $obj->add_frame(@images);
+ $obj->{'_frame_index_'} = 0;
+ }
+ }
+ $obj->set_image( 0 );
+ $obj->_get_gif_info;
+ return $obj;
+}
+
+sub fast_forward {
+
+ my( $self, $delta) = @_;
+
+ $self->{_delta_} = $delta;
+ if( not exists $self->{_playing_} ) {
+ my $playing = exists $self->{'_NextId_'};
+ $self->{_playing_} = $playing;
+ $self->resume_animation if not $playing;
+ } else {
+ my $playing = delete $self->{_playing_};
+ $self->pause_animation if not $playing;
+ }
+
+} # end fast_forward
+
+*fast_reverse = \&fast_forward;
+
+sub frame_count {
+ my $frames = shift->{'_frames_'};
+ return -1 unless $frames;
+ return @$frames;
+}
+
+sub set_disposal_method {
+ my( $self, $blank ) = @_;
+ $blank = 1 if not defined $blank;
+ $self->{_blank_} = $blank;
+ $blank;
+}
+
+sub set_image
+{
+ my ($obj,$index) = @_;
+ my $frames = $obj->{'_frames_'};
+ return unless $frames && @$frames;
+ $index = 0 unless $index < @$frames;
+ $obj->blank if $obj->{_blank_}; # helps some make others worse
+ $obj->copy($frames->[$index]);
+ $obj->{'_frame_index_'} = $index;
+}
+
+sub next_image
+{
+ my ($obj, $delta) = @_;
+ $obj->_next_image($delta);
+}
+
+sub _next_image
+{
+ my ($obj, $delta, $in_animation) = @_;
+ $delta = $obj->{_delta_} unless $delta;
+ my $frames = $obj->{'_frames_'};
+ return unless $frames && @$frames;
+ my $next_index = (($obj->{'_frame_index_'} || 0) + $delta);
+ if ($next_index > @$frames && $in_animation && $obj->{'_loop_'} ne 'forever')
+ {
+ return 0; # signal to stop animation
+ }
+ $next_index %= @$frames;
+ $obj->set_image($next_index);
+ 1;
+}
+
+sub prev_image { shift->next_image( -1 ) }
+
+sub next_image_in_animation
+{
+ my ($obj, $delta) = @_;
+ my $continue = $obj->_next_image($delta, 1);
+ if (!$continue && $self->{'_NextId_'})
+ {
+ $obj->pause_animation;
+ }
+}
+
+sub pause_animation {
+ my $self = shift;
+ my $id = delete $self->{'_NextId_'};
+ Tk::catch { $id->cancel } if $id;
+}
+
+sub resume_animation {
+ my( $self, $period ) = @_;
+ if( not defined $self->{'_period_'} ) {
+ $self->{'_period_'} = defined( $period ) ? $period : 100;
+ }
+ $period = $self->{'_period_'};
+ my $w = $self->MainWindow;
+ $self->{'_NextId_'} = $w->repeat( $period => [ $self => 'next_image_in_animation' ] );
+}
+
+sub start_animation
+{
+ my ($obj,$period) = @_;
+ my $frames = $obj->{'_frames_'};
+ return unless $frames && @$frames;
+ my $w = $obj->MainWindow;
+ $obj->stop_animation;
+ $obj->{'_period_'} = $period if $period;
+ $obj->{'_NextId_'} = $w->repeat($obj->{'_period_'},[$obj,'next_image_in_animation']);
+}
+
+sub stop_animation
+{
+ my ($obj) = @_;
+ my $id = delete $obj->{'_NextId_'};
+ Tk::catch { $id->cancel } if $id;
+ $obj->set_image(0);
+}
+
+sub _get_gif_info
+{
+ my ($obj) = @_;
+ my $info;
+ if (defined(my $file = $obj->cget(-file)) && eval { require Image::Info; 1; })
+ {
+ $info = Image::Info::image_info($file);
+ }
+ elsif (defined(my $data = $obj->cget(-data)))
+ {
+ if ($data =~ m{^GIF8} && eval { require Image::Info; 1; })
+ {
+ $info = Image::Info::image_info(\$data);
+ }
+ elsif (eval { require Image::Info; require MIME::Base64; 1; })
+ {
+ $data = MIME::Base64::decode_base64($data);
+ $info = Image::Info::image_info(\$data);
+ }
+ }
+ if ($info)
+ {
+ $obj->{'_blank_'} = $info->{DisposalMethod} == 2 || $info->{DisposalMethod} == 3;
+ $obj->{'_period_'} = $info->{Delay}*1000 if defined $info->{Delay};
+ $obj->{'_loop_'} = $info->{GIF_Loop};
+ }
+ $obj->{'_blank_'} = 0 if !defined $obj->{'_blank_'};
+ $obj->{'_period_'} = 100 if !defined $obj->{'_period_'};
+ $obj->{'_loop_'} = 'forever' if !defined $obj->{'_loop_'};
+ $obj->{'_delta_'} = 1;
+}
+
+1;
+
+__END__
+
+#
+# This almost works for changing the animation on the fly
+# but does not resize things correctly
+#
+
+sub gif_sequence
+{
+ my ($obj,%args) = @_;
+ my $widget = $obj->MainWindow;
+ my @images;
+ local $@;
+ while (1)
+ {
+ my $index = @images;
+ $args{'-format'} = "gif -index $index";
+ my $img;
+ eval
+ {local $SIG{'__DIE__'};
+ my $img = $widget->Photo(%args);
+ push(@images,$img);
+ };
+ last if $@;
+ }
+ if (@images)
+ {
+ delete $obj->{'_frames_'};
+ $obj->add_frame(@images);
+ $obj->configure(-width => 0, -height => 0);
+ $obj->set_frame(0);
+ }
+}
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Animation.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Animation.pod
new file mode 100755
index 00000000000..996b035b1c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Animation.pod
@@ -0,0 +1,92 @@
+
+=head1 NAME
+
+Tk::Animation - Display sequence of Tk::Photo images
+
+=for pm Tk/Animation.pm
+
+=for category Tk Image Classes
+
+=head1 SYNOPSIS
+
+ use Tk::Animation
+ my $img = $widget->Animation('-format' => 'gif', -file => 'somefile.gif');
+
+ $img->add_frame(@images);
+
+ $img->start_animation;
+ $img->start_animation( $period );
+
+ $img->next_image;
+ $img->prev_image;
+ $img->set_image( 0 .. $#frames );
+
+ $img->pause_animation;
+ $img->resume_animation( $period );
+
+ $img->fast_forward( $multiplier );
+ $img->fast_reverse( $multiplier );
+
+ $img->stop_animation;
+
+ $img->set_disposal_method( $boolean );
+
+=head1 DESCRIPTION
+
+In the simple case when C<Animation> is passed a GIF89 style GIF with
+multiple 'frames', it will build an internal array of C<Photo> images.
+
+The C<add_frame> method adds images to the sequence. It is provided
+to allow animations to be constructed from separate images.
+All images must be C<Photo>s and should all be the same size.
+
+C<start_animation($period)> then initiates a C<repeat> with specified
+I<$period> to sequence through these images. As for raw C<repeat>
+I<$period> is in milliseconds, for a 50Hz monitor it should be at
+least 20ms. If I<$period> is omitted it is determined from the GIF
+metadata (see below), or if this is not possible it defaults to 100
+milliseconds.
+
+C<stop_animation> cancels the C<repeat> and resets the image to the first
+image in the sequence.
+
+For fine-grained control C<next_image> and C<prev_image> move one frame forward
+or backward. C<set_image> randomly positions the animation to a particular frame.
+
+C<pause_animation> pauses the movie and C<resume_animation> continues from the
+pause point.
+
+C<fast_forward> and C<fast_reverse> speed through the movie either
+forwards or backwards. $multiplier specifies how much faster the
+animation moves.
+
+If L<Image::Info> is installed, then the repeat period time and
+disposal method of GIF animations are determined from the GIF metadata
+directly. Otherwise the disposal method must be set manually by using
+C<set_disposal_method> (1 for blanking the previous images, 0 for
+leaving the previous images as is). The repeat period time may be
+given in the C<start_animation> method.
+
+=head1 NOTES
+
+C<set_disposal_method> was formerly known as C<blank> method, but the
+naming of this method was a mistake.
+
+If the disposal method is not set correctly, either by
+C<set_disposal_method> or by determining from the GIF metadata, then
+the following may happen: By default Animation leaves the previous
+movie frame in the animation photo. Many times overlaying subsequent
+frames produces a composite that looks blurred.
+
+=head1 BUGS
+
+This module should not depend on a module which is not declared as a
+dependency (Image::Info).
+
+The delays between images may vary in a GIF animation. This cannot be
+handled by this module yet.
+
+The handling of the various disposal methods is not correct.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Balloon.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Balloon.pm
new file mode 100755
index 00000000000..4771ba37cf9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Balloon.pm
@@ -0,0 +1,633 @@
+#
+# The help widget that provides both "balloon" and "status bar"
+# types of help messages.
+#
+# This is a patched version of Balloon 3.037 - it adds support
+# for different orientations of the balloon widget, depending
+# on wether there's enough space for it. The little arrow now
+# should always point directly to the client.
+# Added by Gerhard Petrowitsch (gerhard.petrowitsch@philips.com)
+#
+# Nov 1, 2003 - Jack Dunnigan
+# Added support for more than one screen in single logical
+# screen mode (i.e. xinerama, dual monitors)
+
+package Tk::Balloon;
+
+use vars qw($VERSION);
+$VERSION = '4.011'; # was: sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev Exists);
+use Carp;
+require Tk::Toplevel;
+
+Tk::Widget->Construct('Balloon');
+use base qw(Tk::Toplevel);
+
+# use UNIVERSAL; avoid the UNIVERSAL.pm file subs are XS in perl core
+
+use strict;
+
+my @balloons;
+my $button_up = 0;
+my %arrows = ( TL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAINjA0HAEdwLCwMKIQfBQA7',
+ TR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIRBGMDwAEQkgAIAAoCABEEuwAAOw==',
+ BR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPDOHHhYVRAIgIAEISQLELADs=',
+ BL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPhB1xAUFALCIMKAaAWQAVADs=',
+ NO => 'R0lGODlhAQABAJEAANnZ2f///////////yH5BAEAAAAALAAAAAABAAEAAAICRAEAOw=='
+ );
+
+
+sub ClassInit {
+ my ($class, $mw) = @_;
+ $mw->bind('all', '<Motion>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
+ $mw->bind('all', '<Leave>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
+ $mw->bind('all', '<Button>', 'Tk::Balloon::ButtonDown');
+ $mw->bind('all', '<ButtonRelease>', 'Tk::Balloon::ButtonUp');
+ return $class;
+}
+
+sub Populate {
+ my ($w, $args) = @_;
+
+ $w->SUPER::Populate($args);
+
+ $w->overrideredirect(1);
+ $w->withdraw;
+ # Only the container frame's background should be black... makes it
+ # look better.
+ $w->configure(-background => 'black');
+
+ # the balloon arrows
+ $w->{img_tl} = $w->Photo(-data => $arrows{TL}, -format => 'gif');
+ $w->{img_tr} = $w->Photo(-data => $arrows{TR}, -format => 'gif');
+ $w->{img_bl} = $w->Photo(-data => $arrows{BL}, -format => 'gif');
+ $w->{img_br} = $w->Photo(-data => $arrows{BR}, -format => 'gif');
+ $w->{img_no} = $w->Photo(-data => $arrows{NO}, -format => 'gif');
+ $w->OnDestroy([$w, '_destroyed']);
+
+ $w->{'pointer'} = $w->Label(-bd=>0, -relief=>'flat',-image=>$w->{img_no});
+
+ # the balloon message
+ # We give the Label a big borderwidth
+ # ..enough to slide a 6x6 gif image along the border including some space
+
+ my $ml = $w->Label(-bd => 0,
+ -padx => 10,
+ -pady => 3,
+ -justify => 'left',
+ -relief=>'flat');
+ $w->Advertise('message' => $ml);
+
+ $ml->pack(
+ -side => 'top',
+ -anchor => 'nw',
+ -expand => 1,
+ -fill => 'both',
+ -padx => 0,
+ -pady => 0);
+
+ # append to global list of balloons
+ push(@balloons, $w);
+ $w->{'popped'} = 0;
+ $w->{'buttonDown'} = 0;
+ $w->{'menu_index'} = 'none';
+ $w->{'menu_index_over'} = 'none';
+ $w->{'canvas_tag'} = '';
+ $w->{'canvas_tag_over'} = '';
+ $w->{'current_screen'} = 0;
+
+ $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0],
+ -initwait => ['PASSIVE', 'initWait', 'InitWait', 350],
+ -state => ['PASSIVE', 'state', 'State', 'both'],
+ -statusbar => ['PASSIVE', 'statusBar', 'StatusBar', undef],
+ -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''],
+ -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''],
+ -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'],
+ -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef],
+ -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef],
+ -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef],
+ -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'],
+ -foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef],
+ -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'],
+ -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1],
+ -numscreens=>['PASSIVE', 'numScreens','NumScreens',1],
+ );
+}
+
+# attach a client to the balloon
+sub attach {
+ my ($w, $client, %args) = @_;
+ foreach my $key (grep(/command$/,keys %args))
+ {
+ $args{$key} = Tk::Callback->new($args{$key});
+ }
+ my $msg = delete $args{-msg};
+ $args{-balloonmsg} = $msg unless exists $args{-balloonmsg};
+ $args{-statusmsg} = $msg unless exists $args{-statusmsg};
+ $w->{'clients'}{$client} = \%args;
+ $client->OnDestroy([$w, 'detach', $client]);
+}
+
+# detach a client from the balloon.
+sub detach {
+ my ($w, $client) = @_;
+ if (Exists($w))
+ {
+ $w->Deactivate if ($client->IS($w->{'client'}));
+ }
+ delete $w->{'clients'}{$client};
+}
+
+sub GetOption
+{
+ my ($w,$opt,$client) = @_;
+ $client = $w->{'client'} unless defined $client;
+ if (defined $client)
+ {
+ my $info = $w->{'clients'}{$client};
+ return $info->{$opt} if exists $info->{$opt};
+ }
+ return $w->cget($opt);
+}
+
+sub Motion {
+ my ($ewin, $x, $y, $s) = @_;
+
+ return if not defined $ewin;
+
+ # Find which window we are over
+ my $over = $ewin->Containing($x, $y);
+
+ return if &grabBad($ewin, $over);
+
+ foreach my $w (@balloons) {
+ # if cursor has moved over the balloon -- ignore
+ next if defined $over and $over->toplevel eq $w;
+
+ # find the client window that matches
+ my $client = $over;
+ while (defined $client) {
+ last if (exists $w->{'clients'}{$client});
+ if ($client->can("MasterMenu")) {
+ my $master = $client->MasterMenu;
+ if ($master && exists $w->{'clients'}{$master}) {
+ $w->{'clients'}{$client} = $w->{'clients'}{$master};
+ last;
+ }
+ }
+ $client = $client->Parent;
+ }
+ if (defined $client) {
+ # popping up disabled -- ignore
+ my $state = $w->GetOption(-state => $client);
+ next if $state eq 'none';
+ # Check if a button was recently released:
+ my $deactivate = 0;
+ if ($button_up) {
+ $deactivate = 1;
+ $button_up = 0;
+ }
+ # Deactivate it if the motioncommand says to:
+ my $command = $w->GetOption(-motioncommand => $client);
+ $deactivate = $command->Call($client, $x, $y) if defined $command;
+ if ($deactivate)
+ {
+ $w->Deactivate;
+ }
+ else
+ {
+ # warn "deact: $client $w->{'client'}";
+ $w->Deactivate unless $client->IS($w->{'client'});
+ my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
+ if (defined($msg))
+ {
+ my $delay = delete $w->{'delay'};
+ $delay->cancel if defined $delay;
+ my $initwait = $w->GetOption(-initwait => $client);
+ $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);});
+ $w->{'client'} = $client;
+ }
+ }
+ } else {
+ # cursor is at a position covered by a non client
+ # pop down the balloon if it is up or scheduled.
+ $w->Deactivate;
+ }
+ }
+}
+
+sub ButtonDown {
+ my ($ewin) = @_;
+
+ foreach my $w (@balloons) {
+ $w->Deactivate;
+ }
+}
+
+sub ButtonUp {
+ $button_up = 1;
+}
+
+# switch the balloon to a new client
+sub SwitchToClient {
+ my ($w, $client) = @_;
+ return unless Exists($w);
+ return unless Exists($client);
+ return unless $client->IS($w->{'client'});
+ return if &grabBad($w, $client);
+ my $command = $w->GetOption(-postcommand => $client);
+ if (defined $command) {
+ # Execute the user's command and return if it returns false:
+ my $pos = $command->Call($client);
+ return if not $pos;
+ if ($pos =~ /^(\d+),(\d+)$/) {
+ # Save the returned position so the Popup method can use it:
+ $w->{'clients'}{$client}{'postposition'} = [$1, $2];
+ }
+ }
+ my $state = $w->GetOption(-state => $client);
+ $w->Popup if ($state =~ /both|balloon/);
+ $w->SetStatus if ($state =~ /both|status/);
+ $w->{'popped'} = 1;
+ $w->{'delay'} = $w->repeat(200, ['Verify', $w, $client]);
+}
+
+sub grabBad {
+
+ my ($w, $client) = @_;
+
+ return 0 unless Exists($client);
+ my $g = $w->grabCurrent;
+ return 0 unless defined $g;
+ return 0 if $g->isa('Tk::Menu');
+ return 0 if $g eq $client;
+
+ # Ignore grab check if $w is the balloon itself.
+ # XXX Why is this necessary? Is it possible to remove the grabBad
+ # condition in SwitchToClient altogether?
+ return 0 if $w->isa(__PACKAGE__);
+
+ # The grab is OK if $client is a decendant of $g. Use the internal Tcl/Tk
+ # pathname (yes, it's cheating, but it's legal).
+
+ return 0 if $g == $w->MainWindow;
+ my $wp = $w->PathName;
+ my $gp = $g->PathName;
+ return 0 if $wp =~ /^$gp/;
+ return 1; # bad grab
+
+} # end grabBad
+
+
+sub Subclient
+{
+ my ($w,$data) = @_;
+ if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data))
+ {
+ $w->Deactivate;
+ }
+ $w->{'subclient'} = $data;
+}
+
+sub Verify {
+ my $w = shift;
+ my $client = shift;
+ my ($X,$Y) = (@_) ? @_ : ($w->pointerxy);
+ my $over = $w->Containing($X,$Y);
+ return if not defined $over or ($over->toplevel eq $w);
+ my $deactivate = # DELETE? or move it to the isa-Menu section?:
+ # ($over ne $client) or
+ not $client->IS($w->{'client'})
+# or (!$client->isa('Tk::Menu') && $w->grabCurrent);
+# or $w->grabbad($client);
+ or &grabBad($w, $client);
+ if ($deactivate)
+ {
+ $w->Deactivate;
+ }
+ else
+ {
+ $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');
+ }
+}
+
+sub Deactivate {
+ my ($w) = @_;
+ my $delay = delete $w->{'delay'};
+ $delay->cancel if defined $delay;
+ if ($w->{'popped'}) {
+ my $client = $w->{'client'};
+ my $command = $w->GetOption(-cancelcommand => $client);
+ if (defined $command) {
+ # Execute the user's command and return if it returns false:
+ return if not $command->Call($client);
+ }
+ $w->withdraw;
+ $w->ClearStatus;
+ $w->{'popped'} = 0;
+ $w->{'menu_index'} = 'none';
+ $w->{'canvas_tag'} = '';
+ }
+ $w->{'client'} = undef;
+ $w->{'subclient'} = undef;
+ $w->{'location'} = undef;
+}
+
+sub Popup {
+ my ($w) = @_;
+ if ($w->cget(-installcolormap)) {
+ $w->colormapwindows($w->winfo('toplevel'))
+ }
+ my $client = $w->{'client'};
+ return if not defined $client or not exists $w->{'clients'}{$client};
+ my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg');
+ # Dereference it if it looks like a scalar reference:
+ $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
+
+ $w->Subwidget('message')->configure(-text => $msg);
+ $w->idletasks;
+
+ return unless Exists($w);
+ return unless Exists($client);
+ return if $msg eq ''; # Don't popup empty balloons.
+
+ my ($x, $y);
+ my $pos = $w->GetOption(-balloonposition => $client);
+ my $postpos = delete $w->{'clients'}{$client}{'postposition'};
+ if (defined $postpos) {
+ # The postcommand must have returned a position for the balloon - I will use that:
+ ($x,$y) = @{$postpos};
+ } elsif ($pos eq 'mouse') {
+ ($x,$y)=$client->pointerxy; # We adjust the position later
+ } elsif ($pos eq 'widget') {
+ $x = int($client->rootx + $client->width/2);
+ $y = int($client->rooty + int ($client->height/1.3));
+ } else {
+ croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";
+ }
+
+ $w->idletasks;
+
+ # Explanation of following code. [JD]
+ # PREMISE: We want to ensure that the balloon is always "on screen".
+ # To do this we use calculate the size of the
+ # toplevel before it is mapped. Then we adjust it's position with respect to the
+ # mouse cursor or widget. Balloons are usually shown below and to the right of the target.
+ # From extensive KDE experience using Xinerama, and from using dual monitors on WinXP..
+ # the balloon will extend across two monitors in single logical screen mode (SLS).
+ # This is an undesirable characteristic indeed. Trying to read a disjointed balloon
+ # across monitors is not fun.
+ #
+ # The intent of the following code is to fix this problem. We do this by avoiding
+ # placement of any part of the balloon over,say, the "half screenwidth" mark (for two
+ # monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on...
+ # i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard
+ # boundaries to be avoided.
+ #
+ # The only drawback of this code, is I know of no way to actually determine this on a
+ # user by user basis. This means that the developer or administrator will have to know
+ # the hardware (monitor) setup for which the application is designed.
+ #
+ # This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead
+ # of creating four separate labels, we configure only ONE label with the proper image.
+ # Then using the place geometry manager, this image/label can be "slid" along the
+ # appropriate side of the toplevel so that it always points directly at the target widget.
+ #
+ # Here we go..
+
+ my ($width, $height) = ($w->reqwidth, $w->reqheight);
+ my ($sw, $sh) = ($w->screenwidth, $w->screenheight);
+ my $numscreen = $w->cget(-numscreens);
+ my $deltax = $sw/$numscreen;
+ my $leftedge;
+ my $rightedge;
+ my $count = 0;
+ for (my $i=0; $i<$sw; $i+=$deltax){
+ $leftedge = $i;
+ $rightedge = $i + $deltax;
+ if ($x >= $leftedge && $x < $rightedge ){
+ last;
+ }
+ $count++;
+ }
+
+ # Force another look at balloon location because mouse has switched
+ # virtual screens.
+ $w->{'location'} = undef unless ( $count == $w->{'current_screen'} );
+ $w->{'current_screen'} = $count;
+
+ my $xx=undef;
+ my $yy=undef; # to hold final toplevel placement
+ my $slideOffsetX = 0;
+ my $slideOffsetY = 0;
+ my $cornerOffset = 5; #default - keep corner away from pointer
+ my $testtop = $y - $height - $cornerOffset;
+ my $testbottom = $y + $height + (2*$cornerOffset);
+ my $testright = $x + $width + (2*$cornerOffset);
+ my $testleft = $x - $width - $cornerOffset;
+ my $vert='bottom'; #default
+ my $horiz='right'; #default
+
+
+ if ( defined $w->{'location'} ){
+ # Once balloon is activated, **don't** change the location of the balloon.
+ # It is annoying to have it jump from one location to another.
+ ( $w->{'location'}=~/top/ ) ? ( $vert = 'top' ) : ( $vert = 'bottom' );
+ ( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' );
+
+ if ($vert eq 'top' && $testtop < 0) {
+ $yy = 0;
+ $slideOffsetY = $testtop;
+ }
+ elsif ($vert eq 'bottom' && $testbottom > $sh) {
+ $slideOffsetY = $testbottom - $sh;
+ }
+
+ if ($horiz eq 'left' && $testleft < $leftedge) {
+ $xx = $leftedge;
+ }
+ elsif ($horiz eq 'right' && $testright > $rightedge) {
+ $slideOffsetX = $testright - $rightedge;
+ }
+ }
+ else {
+ #Test balloon positions in the vertical
+ if ($testbottom > $sh) {
+ #Then offscreen to bottom, check top
+ if ($testtop >= 0) {
+ $vert = 'top';
+ }
+ elsif ($y > $sh/2) {
+ #still offscreen to top but there is more room above then below
+ $vert = 'top';
+ $yy=0;
+ $slideOffsetY = $testtop;
+ }
+ if ($vert eq 'bottom'){
+ #Calculate Yoffset to fit entire balloon onto screen
+ $slideOffsetY = $testbottom - $sh;
+ }
+ }
+ #Test balloon positions in the horizontal
+
+ if ($testright > $rightedge) {
+ #The offscreen, check left
+ if ($testleft >= $leftedge) {
+ $horiz = 'left';
+ }
+ elsif ($x > ($leftedge+$deltax) ) {
+ #still offscreen to left but there is more room to left than right
+ $horiz = 'left';
+ $xx=0;
+ $slideOffsetX = $testleft;
+ }
+ if ($horiz eq 'right'){
+ #Calculate Xoffset to fit entire balloon onto screen
+ $slideOffsetX = $testright - $rightedge;
+ }
+ }
+ }
+
+ $w->{'location'} = $vert.$horiz unless (defined $w->{'location'});
+
+ if ($w->{'location'} eq 'bottomright') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_tl});
+ }
+
+ $w->{'pointer'}->place(
+ -in=>$w,
+# -relx=>0, -x=>$slideOffsetX + 2,
+# -rely=>0, -y=>$slideOffsetY + 2,
+ -relx=>0, -x=>2,
+ -rely=>0, -y=>2,
+ -bordermode=>'outside',
+ -anchor=>'nw');
+
+ $xx=$x-$slideOffsetX+(2*$cornerOffset) unless (defined $xx);
+ $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
+
+ }
+ elsif ($w->{'location'} eq 'bottomleft') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_tr});
+ }
+
+ $w->{'pointer'}->place(-in=>$w,
+# -relx=>1, -x=>$slideOffsetX - 2,
+# -rely=>0, -y=>$slideOffsetY + 2,
+ -relx=>1, -x=>-2,
+ -rely=>0, -y=>2,
+ -bordermode=>'outside',
+ -anchor=>'ne');
+
+ $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
+ $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
+
+ }
+ elsif ($w->{'location'} eq 'topright') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_bl});
+ }
+
+ $w->{'pointer'}->place(-in=>$w,
+# -relx=>0, -x=>$slideOffsetX + 2,
+# -rely=>1, -y=>$slideOffsetY - 2,
+ -relx=>0, -x=>2,
+ -rely=>1, -y=>-2,
+ -bordermode=>'outside',
+ -anchor=>'sw');
+
+ $xx=$x-$slideOffsetX+$cornerOffset unless (defined $xx);
+ $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
+ }
+ elsif ($w->{'location'} eq 'topleft') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_br});
+ }
+
+ $w->{'pointer'}->place(-in=>$w,
+# -relx=>1, -x=>$slideOffsetX - 2,
+# -rely=>1, -y=>$slideOffsetY - 2,
+ -relx=>1, -x=>-2,
+ -rely=>1, -y=>-2,
+ -bordermode=>'outside',
+ -anchor=>'se');
+
+ $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
+ $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
+ }
+
+ $w->{'pointer'}->raise;
+ $xx = int($xx);
+ $yy = int($yy);
+ $w->geometry("+$xx+$yy");
+ $w->deiconify();
+ $w->raise;
+}
+
+sub SetStatus {
+ my ($w) = @_;
+ my $client = $w->{'client'};
+ my $s = $w->GetOption(-statusbar => $client);
+ if (defined $s and $s->winfo('exists')) {
+ my $vref = $s->cget(-textvariable);
+ return if not defined $client or not exists $w->{'clients'}{$client};
+ my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg');
+ # Dereference it if it looks like a scalar reference:
+ $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
+ if (not defined $vref) {
+ eval { $s->configure(-text => $msg); };
+ } else {
+ $$vref = $msg;
+ }
+ }
+}
+
+sub ClearStatus {
+ my ($w) = @_;
+ my $client = $w->{'client'};
+ my $s = $w->GetOption(-statusbar => $client);
+ if (defined $s and $s->winfo('exists')) {
+ my $vref = $s->cget(-textvariable);
+ if (defined $vref) {
+ $$vref = '';
+ } else {
+ eval { $s->configure(-text => ''); }
+ }
+ }
+}
+
+sub _destroyed {
+ my ($w) = @_;
+ # This is called when widget is destroyed (no matter how!)
+ # via the ->OnDestroy hook set in Populate.
+ # remove ourselves from the list of baloons.
+ @balloons = grep($w != $_, @balloons);
+
+ # FIXME: If @balloons is now empty perhaps remove the 'all' bindings
+ # to reduce overhead until another balloon is created?
+
+ # Delete the images
+ for (qw(no tl tr bl br)) {
+ my $img = delete $w->{"img_$_"};
+ $img->delete if defined $img;
+ }
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Balloon.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Balloon.pod
new file mode 100755
index 00000000000..c5afb91e089
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Balloon.pod
@@ -0,0 +1,282 @@
+
+=head1 NAME
+
+Tk::Balloon - pop up help balloons.
+
+=for pm Tixish/Balloon.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+ use Tk::Balloon;
+ ...
+ $b = $top->Balloon(-statusbar => $status_bar_widget);
+
+ # Normal Balloon:
+ $b->attach($widget,
+ -balloonmsg => "Balloon help message",
+ -statusmsg => "Status bar message");
+
+ # Balloon attached to entries in a menu widget:
+ $b->attach($menu, -state => 'status',
+ -msg => ['first menu entry',
+ 'second menu entry',
+ ...
+ ],
+ );
+
+ # Balloon attached to individual items in a canvas widget:
+ $b->attach($canvas, -balloonposition => 'mouse',
+ -msg => {'item1' => 'msg1',
+ 'tag2' => 'msg2',
+ ...
+ },
+ );
+
+ # Balloon attached to items in a listbox widget:
+ $b->attach($listbox, -balloonposition => 'mouse',
+ -msg => ['first listbox element',
+ '2nd listbox element',
+ ...
+ ],
+ );
+
+=head1 DESCRIPTION
+
+B<Balloon> provides the framework to create and attach help
+balloons to various widgets so that when the mouse pauses over the
+widget for more than a specified amount of time, a help balloon is
+popped up.
+
+=head2 Balloons and Menus or Listboxes
+
+If the balloon is attached to a B<Menu> or B<Listbox> widget and the
+message arguments are array references, then each element in the array
+will be the message corresponding to a menu entry or listbox element.
+The balloon message will then be shown for the entry which the mouse
+pauses over. Otherwise it is assumed that the balloon is to be
+attached to the B<Menu> or B<Listbox> as a whole. You can have
+separate status and balloon messages just like normal balloons.
+
+=head2 Balloons and Canvases
+
+If the balloon is attached to a B<Canvas> widget and the message
+arguments are hash references, then each hash key should correspond to
+a canvas item ID or tag and the associated value will correspond to the
+message for that canvas item. The balloon message will then be shown for
+the current item (the one at the position of the mouse). Otherwise it is
+assumed that the balloon is to be attached to the B<Canvas> as a whole.
+You can have separate status and balloon messages just like normal
+balloons.
+
+=head2 Balloon Position
+
+By default, the balloon pops up at the lower right side of the client.
+If it would extend outside the lower screen border, its positioned at the
+upper right side. If it would extend outside the right screen border
+it's shown on the lower left side of the client. If it would extend
+outside both the lower and the right screen border, it's positioned
+at the upper left side of the client. Thus, the little arrow always
+points to the attached client.
+
+=head1 OPTIONS
+
+B<Balloon> accepts all of the options that the B<Frame> widget
+accepts. In addition, the following options are also recognized.
+
+=over 4
+
+=item B<-initwait>
+
+Specifies the amount of time to wait without activity before
+popping up a help balloon. Specified in milliseconds. Defaults to
+350 milliseconds. This applies to both the popped up balloon and
+the status bar message.
+
+=item B<-state>
+
+Can be one of B<'balloon'>, B<'status'>, B<'both'> or B<'none'>
+indicating that the help balloon, status bar help, both or none
+respectively should be activated when the mouse pauses over the
+client widget. Default is B<'both'>.
+
+=item B<-statusbar>
+
+Specifies the widget used to display the status message. This
+widget should accept the B<-text> option and is typically a
+B<Label>. If the widget accepts the B<-textvariable> option and
+that option is defined then it is used instead of the B<-text>
+option.
+
+=item B<-balloonposition>
+
+Can be one of B<'widget'> or B<'mouse'>. It controls where the balloon
+will popup. B<'widget'> makes the balloon appear at the lower right
+corner of the widget it is attached to (default), and B<'mouse'> makes
+the balloon appear below and to the right of the current mouse position.
+
+=item B<-postcommand>
+
+This option takes a B<CODE> reference which will be executed before the
+balloon and statusbar messages are displayed and should return a true
+or false value to indicate whether you want the balloon to be displayed
+or not. This also lets you control where the balloon is positioned by
+returning a true value that looks like I<X,Y> (matches this regular
+expression: C</^(\d+),(\d+)$/>). If the postcommand returns a value that
+matches that re then those coordinates will be used as the position to
+post the balloon. I<Warning:> this subroutine should return quickly or
+the balloon response will appear slow.
+
+=item B<-cancelcommand>
+
+This option takes a B<CODE> reference which will be executed before the
+balloon and statusbar messages are canceled and should return a true
+or false value to indicate whether you want the balloon to be canceled
+or not. I<Warning:> this subroutine should return quickly or the balloon
+response will appear slow.
+
+=item B<-motioncommand>
+
+This option takes a B<CODE> reference which will be executed for any
+motion event and should return a true or false value to indicate
+whether the currently displayed balloon should be canceled (deactivated).
+If it returns true then the balloon will definitely be canceled, if it
+returns false then it may still be canceled depending the internal rules.
+I<Note:> a new balloon may be posted after the B<-initwait> time
+interval, use the B<-postcommand> option to control that behavior.
+I<Warning:> the subroutine should be extremely fast or the balloon
+response will appear slow and consume a lot of CPU time (it is executed
+every time the mouse moves over the widgets the balloon is attached to).
+
+=item B<-numscreens>
+
+This option accepts an integer 1 or greater. This option should be used
+to avoid disjointed balloons across multiple screens in single logical
+sceen (SLS) mode. This only currently works in the horizontal direction.
+Example: If you are running dual screens in SLS mode then you would set
+this value to 2. Default value is 1.
+
+=back
+
+=head1 METHODS
+
+The B<Balloon> widget supports only three non-standard methods:
+
+=head2 B<attach(>I<widget>, I<options>B<)>
+
+Attaches the widget indicated by I<widget> to the help system. The
+allowed options are:
+
+=over 4
+
+=item B<-statusmsg>
+
+The argument is the message to be shown on the status bar when the
+mouse pauses over this client. If this is not specified, but
+B<-msg> is specified then the message displayed on the status bar
+is the same as the argument for B<-msg>. If you give it a scalar
+reference then it is dereferenced before being displayed. Useful
+if the postcommand is used to change the message.
+
+=item B<-balloonmsg>
+
+The argument is the message to be displayed in the balloon that
+will be popped up when the mouse pauses over this client. As with
+B<-statusmsg> if this is not specified, then it takes its value
+from the B<-msg> specification if any. If neither B<-balloonmsg>
+nor B<-msg> are specified, or they are the empty string then
+no balloon is popped up instead of an empty balloon. If you
+give it a scalar reference then it is dereferenced before being
+displayed. Useful if the postcommand is used to change the message.
+
+=item B<-msg>
+
+The catch-all for B<-statusmsg> and B<-balloonmsg>. This is a
+convenient way of specifying the same message to be displayed in
+both the balloon and the status bar for the client.
+
+=item B<-initwait>
+
+=item B<-state>
+
+=item B<-statusbar>
+
+=item B<-balloonposition>
+
+=item B<-postcommand>
+
+=item B<-cancelcommand>
+
+=item B<-motioncommand>
+
+These options allow you to override the balloon's default value for
+those option for some of the widgets it is attached to. It accepts the
+same values as above and will default to the B<Balloon>'s value.
+
+=back
+
+=head2 B<detach(>I<widget>B<)>
+
+Detaches the specified I<widget> from the help system.
+
+=head2 B<destroy>
+
+Destroys the specified balloon.
+
+=head1 ADVERTISED SUBWIDGETS
+
+The balloon label is advertised as C<message>.
+
+=head1 EXAMPLES
+
+See the balloon demo included with the widget demo script that came with
+the distribution for examples on various ways to use balloons.
+
+=head1 NOTES
+
+Because of the overhead associated with each balloon you create (from
+tracking the mouse movement to know when to activate and deactivate
+them) you will see the best performance (low CPU consumption) if you
+create as few balloons as possible and attach them to as many widgets
+as you can. In other words, don't create a balloon for each widget
+you want to attach one to.
+
+=head1 CAVEATS
+
+Pressing any button will deactivate (cancel) the current balloon,
+if one exists. You can usually make the balloon reappear by moving
+the mouse a little. Creative use of the 3 command options can help
+you out also. If the mouse is over the balloon when a menu is unposted
+then the balloon will remain until you move off of it.
+
+=head1 BUGS
+
+If using balloons attached to listbox entries or canvas items in a
+scrolled widget, then the subwidget have to be used:
+
+ $balloon->attach($w->Subwidget("scrolled"), -msg => ...);
+
+=head1 AUTHORS
+
+B<Rajappa Iyer> <rsi@earthling.net> did the original coding.
+
+B<Jason A. Smith> <smithj4@rpi.edu> added support for menus and made some
+other enhancements.
+
+B<Slaven Rezic> <srezic@cpan.org> added support for canvas items.
+
+B<Gerhard Petrowitsch> <gerhard@petrowitsch.de> added intelligent positioning
+
+B<Jack Dunnigan> <dunniganj@cpan.org> Made positioning I<more> intelligent and
+added support for multiple monitors under single logical screen.
+
+=head1 HISTORY
+
+The code and documentation was derived from Balloon.tcl from the
+Tix4.0 distribution by Ioi Lam and modified by the above mentioned
+authors. This code may be redistributed under the same terms as Perl.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Bitmap.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Bitmap.pm
new file mode 100755
index 00000000000..d081a393804
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Bitmap.pm
@@ -0,0 +1,10 @@
+package Tk::Bitmap;
+require Tk;
+require Tk::Image;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Bitmap.pm#4 $
+use base qw(Tk::Image);
+Construct Tk::Image 'Bitmap';
+sub Tk_image { 'bitmap' }
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Bitmap.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Bitmap.pod
new file mode 100755
index 00000000000..49bf20ce4b4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Bitmap.pod
@@ -0,0 +1,103 @@
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Bitmap - Images that display two colors
+
+=for category Tk Image Classes
+
+=head1 SYNOPSIS
+
+S< >I<$image> = I<$widget>-E<gt>B<Bitmap>?(I<name>??,I<options>?)
+
+=head1 DESCRIPTION
+
+A bitmap is an image whose pixels can display either of two colors
+or be transparent.
+A bitmap image is defined by four things: a background color,
+a foreground color, and two bitmaps, called the I<source>
+and the I<mask>.
+Each of the bitmaps specifies 0/1 values for a rectangular
+array of pixels, and the two bitmaps must have the same
+dimensions.
+For pixels where the mask is zero, the image displays nothing,
+producing a transparent effect.
+For other pixels, the image displays the foreground color if
+the source data is one and the background color if the source
+data is zero.
+
+=head1 CREATING BITMAPS
+
+Bitmaps are created using I<$widget>-E<gt>B<Bitmap>.
+Bitmaps support the following I<options>:
+
+=over 4
+
+=item B<-background> =E<gt> I<color>
+
+Specifies a background color for the image in any of the standard
+ways accepted by Tk. If this option is set to an empty string
+then the background pixels will be transparent. This effect
+is achieved by using the source bitmap as the mask bitmap, ignoring
+any B<-maskdata> or B<-maskfile> options.
+
+=item B<-data> =E<gt> I<string>
+
+Specifies the contents of the source bitmap as a string.
+The string must adhere to X11 bitmap format (e.g., as generated
+by the B<bitmap> program).
+If both the B<-data> and B<-file> options are specified,
+the B<-data> option takes precedence.
+
+=item B<-file> =E<gt> I<name>
+
+I<name> gives the name of a file whose contents define the
+source bitmap.
+The file must adhere to X11 bitmap format (e.g., as generated
+by the B<bitmap> program).
+
+=item B<-foreground> =E<gt> I<color>
+
+Specifies a foreground color for the image in any of the standard
+ways accepted by Tk.
+
+=item B<-maskdata> =E<gt> I<string>
+
+Specifies the contents of the mask as a string.
+The string must adhere to X11 bitmap format (e.g., as generated
+by the B<bitmap> program).
+If both the B<-maskdata> and B<-maskfile> options are specified,
+the B<-maskdata> option takes precedence.
+
+=item B<-maskfile> =E<gt> I<name>
+
+I<name> gives the name of a file whose contents define the
+mask.
+The file must adhere to X11 bitmap format (e.g., as generated
+by the B<bitmap> program).
+
+=back
+
+=head1 IMAGE METHODS
+
+When a bitmap image is created, Tk also creates a new object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+
+=head1 SEE ALSO
+
+L<Tk::Image|Tk::Image>
+L<Tk::Pixmap|Tk::Pixmap>
+L<Tk::Photo|Tk::Photo>
+
+=head1 KEYWORDS
+
+bitmap, image
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pm b/Master/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pm
new file mode 100755
index 00000000000..5078d9e06d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pm
@@ -0,0 +1,522 @@
+#
+# BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
+#
+# Some additions by Slaven Rezic <slaven@rezic.de> to make the widget
+# look like the Windows' Combobox. There are also additional options.
+#
+
+package Tk::BrowseEntry;
+
+use vars qw($VERSION);
+$VERSION = '4.014'; # was: sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev);
+use Carp;
+use strict;
+
+use base qw(Tk::Frame);
+Construct Tk::Widget 'BrowseEntry';
+
+require Tk::LabEntry;
+
+sub LabEntryWidget { "LabEntry" }
+sub ButtonWidget { "Button" }
+sub ListboxWidget { "Listbox" }
+
+sub Populate {
+ my ($w, $args) = @_;
+
+ my %labelArgs;
+ while(my($k,$v) = each %$args) {
+ $labelArgs{$k} = $v;
+ delete $args->{$k};
+ }
+
+ $w->Tk::Frame::Populate($args);
+
+ while(my($k,$v) = each %labelArgs) {
+ $args->{$k} = $v;
+ }
+
+ # entry widget and arrow button
+ my $lpack = delete $args->{-labelPack};
+ if (not defined $lpack) {
+ $lpack = [-side => 'left', -anchor => 'e'];
+ }
+ $w->{_BE_Style} = delete $args->{-style} || $Tk::platform;
+ my $LabEntry = $w->LabEntryWidget;
+ my $Listbox = $w->ListboxWidget;
+ my $Button = $w->ButtonWidget;
+ # XXX should this be retained?
+# if (defined $args->{-state} and $args->{-state} eq 'readonly') { # XXX works only at construction time
+# $LabEntry = "NoSelLabEntry";
+# require Tk::NoSelLabEntry;
+# }
+ my $e;
+ my $var = "";
+ my @LabEntry_args = (-textvariable => \$var);
+ if (exists $args->{-label}) {
+ $e = $w->$LabEntry(-labelPack => $lpack,
+ -label => delete $args->{-label},
+ @LabEntry_args,
+ );
+ } else {
+ $e = $w->$LabEntry(@LabEntry_args);
+ }
+ my $b = $w->$Button(-bitmap => '@' . Tk->findINC($w->{_BE_Style} eq 'MSWin32' ? 'arrowdownwin.xbm' : 'cbxarrow.xbm'));
+ $w->Advertise('entry' => $e);
+ $w->Advertise('arrow' => $b);
+
+ # Pack the button to align vertically with the entry widget
+ my @anch;
+ my $edge = {@$lpack}->{-side};
+ push(@anch,-anchor => 's') if ($edge && $edge eq 'top');
+ push(@anch,-anchor => 'n') if ($edge && $edge eq 'bottom');
+ $b->pack(-side => 'right', -padx => 1, @anch);
+
+ $e->pack(-side => 'right', -fill => 'x', -expand => 1); #XXX, -padx => 1);
+
+ # popup shell for listbox with values.
+ my $c = $w->Toplevel(-bd => 2,
+ -relief => ($w->{_BE_Style} eq 'MSWin32'
+ ? "solid" : "raised"));
+ $c->overrideredirect(1);
+ $c->withdraw;
+ my $sl = $c->Scrolled( $Listbox, qw/-selectmode browse -scrollbars oe/ );
+ if ($w->{_BE_Style} eq 'MSWin32' and $Tk::platform eq 'MSWin32') {
+ $sl->configure(-bg => 'SystemWindow', -relief => "flat");
+ }
+ $w->Advertise('choices' => $c);
+ $w->Advertise('slistbox' => $sl);
+ $sl->pack(-expand => 1, -fill => 'both');
+
+ $sl->Subwidget("scrolled")->bind("<Motion>",sub {
+ return unless ($w->{_BE_Style} eq 'MSWin32');
+ my $e = $_[0]->XEvent;
+ my $y = $e->y;
+ my $inx = $sl->nearest($y);
+ if (defined $inx) {
+ $sl->selectionClear(0, "end");
+ $sl->selectionSet($inx);
+ }
+ });
+
+ # other initializations
+ $w->SetBindings;
+ $w->{'_BE_popped'} = 0;
+ $w->Delegates(get => $sl, DEFAULT => $e);
+ $w->ConfigSpecs(
+ -font => [qw/DESCENDANTS font Font/],
+ -listwidth => [qw/PASSIVE listWidth ListWidth/, undef],
+ -listheight => [{-height => $sl}, qw/listHeight ListHeight/, undef],
+ -listcmd => [qw/CALLBACK listCmd ListCmd/, undef],
+ -autolistwidth => [qw/PASSIVE autoListWidth AutoListWidth/, undef],
+ -autolimitheight => [qw/PASSIVE autoLimitHeight AutoLimitHeight 0/],
+ -browsecmd => [qw/CALLBACK browseCmd BrowseCmd/, undef],
+ -browse2cmd => [qw/CALLBACK browse2Cmd Browse2Cmd/, undef],
+ -choices => [qw/METHOD choices Choices/, undef],
+ -state => [qw/METHOD state State normal/],
+ -arrowimage => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
+ -variable => [ {'-textvariable' => $e} ],
+ -colorstate => [qw/PASSIVE colorState ColorState/, undef],
+ -command => '-browsecmd',
+ -options => '-choices',
+ -label => [qw/PASSIVE label Label/, undef],
+ -labelPack => [qw/PASSIVE labelPack LabelPack/, undef],
+ #-background => [$e, qw/background Background/, undef],
+ #-foreground => [$e, qw/foreground Foreground/, undef],
+ -buttontakefocus => [{-takefocus => $b}, 'buttonTakefocus',
+ 'ButtonTakefocus', 1],
+ DEFAULT => [$e] );
+}
+
+sub SetBindings {
+ my ($w) = @_;
+
+ my $e = $w->Subwidget('entry');
+ my $b = $w->Subwidget('arrow');
+
+ # set bind tags
+ $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']);
+ # as we don't bind $e here leave its tags alone ...
+ # $e->bindtags([$e, ref($e), $e->toplevel, 'all']);
+
+ # bindings for the button and entry
+ $b->bind('<1>',[$w,'BtnDown']);
+ $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']);
+ $b->bind('<space>',[$w,'space']);
+
+ # bindings for listbox
+ my $sl = $w->Subwidget('slistbox');
+ my $l = $sl->Subwidget('listbox');
+ $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
+ $l->bind('<Escape>' => [$w,'LbClose']);
+ $l->bind('<Return>' => [$w,'Return',$l]);
+
+ # allow click outside the popped up listbox to pop it down.
+ $w->bind('<1>','BtnDown');
+}
+
+sub space
+{
+ my $w = shift;
+ $w->BtnDown;
+ $w->{'_BE_savefocus'} = $w->focusCurrent;
+ $w->Subwidget('slistbox')->focus;
+}
+
+
+sub ListboxRelease
+{
+ my ($w,$x,$y) = @_;
+ $w->ButtonHack;
+ $w->LbChoose($x, $y);
+}
+
+sub Return
+{
+ my ($w,$l) = @_;
+ my($x, $y) = $l->bbox($l->curselection);
+ $w->LbChoose($x, $y)
+}
+
+
+sub BtnDown {
+ my ($w) = @_;
+ return if $w->cget( '-state' ) eq 'disabled';
+
+ if ($w->{'_BE_popped'}) {
+ $w->Popdown;
+ $w->{'_BE_buttonHack'} = 0;
+ } else {
+ $w->PopupChoices;
+ $w->{'_BE_buttonHack'} = 1;
+ }
+}
+
+sub PopupChoices {
+ my ($w) = @_;
+
+ if (!$w->{'_BE_popped'}) {
+ $w->Callback(-listcmd => $w);
+ my $e = $w->Subwidget('entry');
+ my $c = $w->Subwidget('choices');
+ my $s = $w->Subwidget('slistbox');
+ my $a = $w->Subwidget('arrow');
+ my $y1 = ($w->{_BE_Style} eq 'MSWin32'
+ ? $a->rooty + $a->height
+ : $e->rooty + $e->height + 3
+ );
+ my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
+ # using the real listbox reqheight rather than the
+ # container frame one, which does not change after resizing the
+ # listbox
+ my $ht = $s->Subwidget("scrolled")->reqheight + 2 * $bd;
+ my $x1 = ($w->{_BE_Style} eq 'MSWin32'
+ ? $e->Subwidget("entry")->rootx
+ : $e->rootx
+ );
+ my ($width, $x2);
+ if (defined $w->cget(-listwidth)) {
+ $width = $w->cget(-listwidth);
+ $x2 = $x1 + $width;
+ } else {
+ $x2 = $a->rootx + $a->width;
+ $width = $x2 - $x1;
+ }
+ my $rw = $c->reqwidth;
+ if ($rw < $width) {
+ $rw = $width
+ } else {
+ if ($rw > $width * 3) {
+ $rw = $width * 3;
+ }
+ if ($rw > $w->vrootwidth) {
+ $rw = $w->vrootwidth;
+ }
+ }
+ $width = $rw;
+
+ # if listbox is too far right, pull it back to the left
+ #
+ if ($x2 > $w->vrootwidth) {
+ $x1 = $w->vrootwidth - $width;
+ }
+
+ # if listbox is too far left, pull it back to the right
+ #
+ if ($x1 < 0) {
+ $x1 = 0;
+ }
+
+ # if listbox is below bottom of screen, pull it up.
+ # check the Win32 taskbar, if possible
+ my $rootheight;
+ if ($Tk::platform eq 'MSWin32' and $^O eq 'MSWin32') {
+ eval {
+ require Win32Util; # XXX should not use a non-CPAN widget
+ $rootheight = (Win32Util::screen_region($w))[3];
+ };
+ }
+ if (!defined $rootheight) {
+ $rootheight = $w->vrootheight;
+ }
+
+ my $y2 = $y1 + $ht;
+ if ($y2 > $rootheight) {
+ $y1 = $y1 - $ht - ($e->height - 5);
+ }
+ $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
+ $c->deiconify;
+ $c->raise;
+ $e->focus;
+ $w->{'_BE_popped'} = 1;
+
+ # highlight current selection
+ my $current_sel = $e->get;
+ if (defined $current_sel) {
+ my $i = 0;
+ foreach my $str ($s->get(0, "end")) {
+ local $^W = 0; # in case of undefined strings
+ if ($str eq $current_sel) {
+ $s->selectionClear(0, "end");
+ $s->selectionSet($i);
+ last;
+ }
+ $i++;
+ }
+ }
+
+ $c->configure(-cursor => 'arrow');
+ $w->{'_BE_grabinfo'} = $w->grabSave;
+ $w->grabGlobal;
+ }
+}
+
+# choose value from listbox if appropriate
+sub LbChoose {
+ my ($w, $x, $y) = @_;
+ my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+ if ((($x < 0) || ($x > $l->Width)) ||
+ (($y < 0) || ($y > $l->Height))) {
+ # mouse was clicked outside the listbox... close the listbox
+ $w->LbClose;
+ } else {
+ # select appropriate entry and close the listbox
+ $w->LbCopySelection;
+ $w->Callback(-browsecmd, $w, $w->Subwidget('entry')->get());
+ $w->Callback(-browse2cmd => $w, $w->LbIndex);
+ }
+}
+
+# close the listbox after clearing selection
+sub LbClose {
+ my ($w) = @_;
+ my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+ $l->selection('clear', 0, 'end');
+ $w->Popdown;
+}
+
+# copy the selection to the entry and close listbox
+sub LbCopySelection {
+ my ($w) = @_;
+ my $index = $w->LbIndex;
+ if (defined $index) {
+ $w->{'_BE_curIndex'} = $index;
+ my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+ my $var_ref = $w->cget( '-textvariable' );
+ $$var_ref = $l->get($index);
+ if ($w->{'_BE_popped'}) {
+ $w->Popdown;
+ }
+ }
+ $w->Popdown;
+}
+
+sub LbIndex {
+ my ($w, $flag) = @_;
+ my ($sel) = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
+ if (defined $sel) {
+ return int($sel);
+ } else {
+ if (defined $flag && ($flag eq 'emptyOK')) {
+ return undef;
+ } else {
+ return 0;
+ }
+ }
+}
+
+# pop down the listbox
+sub Popdown {
+ my ($w) = @_;
+ if ($w->{'_BE_savefocus'} && Tk::Exists($w->{'_BE_savefocus'})) {
+ $w->{'_BE_savefocus'}->focus;
+ delete $w->{'_BE_savefocus'};
+ }
+ if ($w->{'_BE_popped'}) {
+ my $c = $w->Subwidget('choices');
+ $c->withdraw;
+ $w->grabRelease;
+ if (ref $w->{'_BE_grabinfo'} eq 'CODE') {
+ $w->{'_BE_grabinfo'}->();
+ delete $w->{'_BE_grabinfo'};
+ }
+ $w->{'_BE_popped'} = 0;
+ }
+}
+
+# This hack is to prevent the ugliness of the arrow being depressed.
+#
+sub ButtonHack {
+ my ($w) = @_;
+ my $b = $w->Subwidget('arrow');
+ if ($w->{'_BE_buttonHack'}) {
+ $b->butUp;
+ }
+}
+
+sub choices
+{
+ my ($w,$choices) = @_;
+ if (@_ > 1)
+ {
+ $w->delete( qw/0 end/ );
+ my %hash;
+ my $var = $w->cget('-textvariable');
+ my $old = $$var;
+ foreach my $val (@$choices)
+ {
+ local $^W = 0; # in case of undefined values
+ $w->insert( 'end', $val);
+ $hash{$val} = 1;
+ }
+ $old = $choices->[0]
+ if defined $old && !exists $hash{$old} && defined $choices->[0];
+ $$var = $old;
+ }
+ else
+ {
+ return( $w->get( qw/0 end/ ) );
+ }
+}
+
+sub _set_edit_state {
+ my( $w, $state ) = @_;
+
+ my $entry = $w->Subwidget( 'entry' );
+ my $button = $w->Subwidget( 'arrow' );
+
+ if ($w->cget( '-colorstate' )) {
+ my $color;
+ if( $state eq 'normal' ) { # Editable
+ $color = 'gray95';
+ } else { # Not Editable
+ $color = $w->cget( -background ) || 'lightgray';
+ }
+ $entry->Subwidget( 'entry' )->configure( -background => $color );
+ }
+
+ if( $state eq 'readonly' ) {
+ $entry->configure( -state => 'disabled' );
+ $button->configure( -state => 'normal' );
+ if ($w->{_BE_Style} eq 'MSWin32') {
+ $entry->bind('<1>',[$w,'BtnDown']);
+ $w->{_BE_OriginalCursor} = $entry->cget( -cursor );
+ $entry->configure( -cursor => 'left_ptr' );
+ }
+ } else {
+ $entry->configure( -state => $state );
+ if (exists $w->{_BE_OriginalCursor}) {
+ $entry->configure(-cursor => delete $w->{_BE_OriginalCursor});
+ }
+ $button->configure( -state => $state );
+ if ($w->{_BE_Style} eq 'MSWin32') {
+ $entry->bind('<1>',['Button1',Tk::Ev('x')]);
+ }
+ }
+}
+
+sub state {
+ my $w = shift;
+ unless( @_ ) {
+ return( $w->{Configure}{-state} );
+ } else {
+ my $state = shift;
+ $w->{Configure}{-state} = $state;
+ $w->_set_edit_state( $state );
+ }
+}
+
+sub _max {
+ my $max = shift;
+ foreach my $val (@_) {
+ $max = $val if $max < $val;
+ }
+ return( $max );
+}
+
+sub shrinkwrap {
+ my( $w, $size ) = @_;
+
+ unless( defined $size ) {
+ $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
+ }
+
+ my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
+ $w->configure( -width => $size );
+ $lb->configure( -width => $size );
+}
+
+sub limitheight {
+ my $w = shift;
+ my $choices_number = shift || $w->Subwidget('slistbox')->index("end");
+ $choices_number = 10 if $choices_number > 10;
+ $w->configure(-listheight => $choices_number) if ($choices_number > 0);
+}
+
+sub insert {
+ my $w = shift;
+ $w->Subwidget("slistbox")->insert(@_);
+ if ($w->cget(-autolimitheight)) {
+ $w->limitheight;
+ }
+ if ($w->cget(-autolistwidth)) {
+ $w->updateListWidth(@_[1..$#_]);
+ }
+}
+
+sub delete {
+ my $w = shift;
+ $w->Subwidget("slistbox")->delete(@_);
+ if ($w->cget(-autolimitheight)) {
+ $w->limitheight;
+ }
+ if ($w->cget(-autolistwidth)) {
+ $w->updateListWidth();
+ }
+}
+
+sub updateListWidth {
+ my $w = shift;
+ my @ins = @_;
+ if (!@ins) {
+ @ins = $w->get(0, "end");
+ }
+
+ my $max_width = 0;
+ foreach my $ins (@ins) {
+ my $new_width = $w->fontMeasure($w->cget(-font), $ins);
+ if ($new_width > $max_width) {
+ $max_width = $new_width;
+ }
+ }
+ if ($max_width > 20) { # be sane
+ $w->configure(-listwidth => $max_width + 32); # XXX for scrollbar
+ }
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pod b/Master/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pod
new file mode 100755
index 00000000000..98a547c4084
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/BrowseEntry.pod
@@ -0,0 +1,210 @@
+
+=head1 NAME
+
+Tk::BrowseEntry - entry widget with popup choices.
+
+=for pm Tixish/BrowseEntry.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+ use Tk::BrowseEntry;
+
+ $b = $frame->BrowseEntry(-label => "Label", -variable => \$var);
+ $b->insert("end", "opt1");
+ $b->insert("end", "opt2");
+ $b->insert("end", "opt3");
+ ...
+ $b->pack;
+
+=head1 SUPER-CLASS
+
+The C<BrowseEntry> class is derived from the C<Frame> class and
+inherits all the methods, options and subwidgets of its super-class.
+By default, options and methods are delegated to the entry subwidget.
+
+=head1 DESCRIPTION
+
+BrowseEntry is a poor man's ComboBox. It may be considered an
+enhanced version of LabEntry which provides a button to popup the
+choices of the possible values that the Entry may
+take. BrowseEntry supports all the options LabEntry supports
+except B<-textvariable>. This is replaced by B<-variable>. Other
+options that BrowseEntry supports:
+
+=over 4
+
+=item B<-arrowimage>
+
+Specifies the image to be used in the arrow button beside the entry
+widget. The default is an downward arrow image in the file cbxarrow.xbm
+
+=item B<-autolimitheight>
+
+If set to a true value, then the height of the listbox will be at most
+the number of entries in the list. The overall maximum of
+C<-listheight> still applies.
+
+=item B<-autolistwidth>
+
+If set to a true value, then the width of the listbox will match the
+width of the largest entry.
+
+=item B<-browsecmd>
+
+Specifies a function to call when a selection is made in the
+popped up listbox. It is passed the widget and the text of the
+entry selected. This function is called after the entry variable
+has been assigned the value.
+
+=item B<-browse2cmd>
+
+Like C<-browsecmd>, but the callback is called with the listbox index
+instead of the selected value.
+
+=item B<-buttontakefocus>
+
+Set the C<-takefocus> option of the button subwidget.
+
+=item B<-choices>
+
+Specifies the list of choices to pop up. This is a reference to an
+array of strings specifying the choices.
+
+=item B<-colorstate>
+
+The state of the widget is reflected by color. A non-editable entry
+widget will get a light gray background, while an editable entry will
+be almost white. [This may change]
+
+=item B<-listcmd>
+
+Specifies the function to call when the button next to the entry
+is pressed to popup the choices in the listbox. This is called before
+popping up the listbox, so can be used to populate the entries in
+the listbox.
+
+=item B<-listheight>
+
+Set the height of the listbox. See also C<-autolimitheight>.
+
+=item B<-listwidth>
+
+Specifies the width of the popup listbox.
+
+=item B<-state>
+
+Specifies one of three states for the widget: normal, readonly, or
+disabled. If the widget is disabled then the value may not be changed
+and the arrow button won't activate. If the widget is readonly, the
+entry may not be edited, but it may be changed by choosing a value
+from the popup listbox. normal is the default.
+
+=item B<-style>
+
+Set the "style" of the widget. Permitted values are C<MSWin32> and
+C<unix>. By default C<-style> is set to the current platform. Widgets
+with the C<unix> style will look like a normal C<BrowseEntry> widget,
+whereas with the C<MSWin32> style the arrow will look close to the
+Windows' standard combobox widget, while moving the mouse the entries
+will be highlighted, and probably includes other changes.
+
+=item B<-variable>
+
+Specifies the variable in which the entered value is to be stored.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<insert(>I<index>, I<string>B<)>
+
+Inserts the text of I<string> at the specified I<index>. This string
+then becomes available as one of the choices.
+
+=item B<delete(>I<index1>, I<index2>B<)>
+
+Deletes items from I<index1> to I<index2>.
+
+=item B<get>
+
+The get method is delegated to the choices listbox.
+
+=back
+
+=head1 ADVERTISED WIDGETS
+
+The following widgets are advertised:
+
+=over
+
+=item entry
+
+The entry widget.
+
+=item arrow
+
+The button with the arrow image.
+
+=item choices
+
+The toplevel widget containing the choice listbox.
+
+=item slistbox
+
+The scrolled listbox with the choices.
+
+=back
+
+=head1 SUBCLASSING
+
+To make subclassing easier, the following methods may be overridden to
+use other standard widgets in composing the mega widget:
+
+=over
+
+=item LabEntryWidget
+
+A widget class compatible with Tk::LabEntry used for the entry.
+
+=item ButtonWidget
+
+A widget class compatible with Tk::Button used for the arrow button.
+
+=item ListboxWidget
+
+A widget class compatible with Tk::Listbox used for the choices
+listbox.
+
+=back
+
+For example to use a C<NumEntry> widget (from the Tk-GBARR CPAN
+distribution) instead of the normal C<Entry> widget:
+
+ package Tk::NumBrowseEntry;
+ use base qw(Tk::BrowseEntry);
+ use Tk::NumEntry;
+ Construct Tk::Widget 'NumBrowseEntry';
+ sub LabEntryWidget { "NumEntry" }
+
+=head1 BUGS
+
+BrowseEntry should really provide more of the ComboBox options.
+
+=head1 AUTHOR
+
+B<Rajappa Iyer> rsi@earthling.net
+
+B<Chris Dean> ctdean@cogit.com made additions.
+
+More additions by B<Slaven Rezic> slaven@rezic.de
+
+This code was inspired by ComboBox.tcl in Tix4.0 by Ioi Lam and
+bears more than a passing resemblance to ComboBox code. This may
+be distributed under the same conditions as Perl.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Button.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Button.pm
new file mode 100755
index 00000000000..b423f8caaa5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Button.pm
@@ -0,0 +1,247 @@
+package Tk::Button;
+# Conversion from Tk4.0 button.tcl competed.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use strict;
+
+require Tk::Widget;
+use base qw(Tk::Widget);
+
+use vars qw($buttonWindow $afterId $repeated);
+
+Tk::Methods('deselect','flash','invoke','select','toggle');
+
+sub Tk_cmd { \&Tk::button }
+
+Construct Tk::Widget 'Button';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'butDown');
+ $mw->bind($class,'<ButtonRelease-1>', 'butUp');
+ $mw->bind($class,'<space>', 'Invoke');
+ $mw->bind($class,'<Return>', 'Invoke');
+ return $class;
+}
+
+# tkButtonEnter --
+# The procedure below is invoked when the mouse pointer enters a
+# button widget. It records the button we're in and changes the
+# state of the button to active unless the button is disabled.
+#
+# Arguments:
+# w - The name of the widget.
+
+sub Enter
+{
+ my $w = shift;
+ my $E = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ # On unix the state is active just with mouse-over
+ $w->configure(-state => 'active');
+
+ # If the mouse button is down, set the relief to sunken on entry.
+ # Overwise, if there's an -overrelief value, set the relief to that.
+ $w->{__relief__} = $w->cget('-relief');
+ if (defined $buttonWindow && $w == $buttonWindow)
+ {
+ $w->configure(-relief => 'sunken');
+ $w->{__prelief__} = 'sunken';
+ }
+ elsif ((my $over = $w->cget('-overrelief')) ne '')
+ {
+ $w->configure(-relief => $over);
+ $w->{__prelief__} = $over;
+ }
+ }
+ $Tk::window = $w;
+}
+
+# tkButtonLeave --
+# The procedure below is invoked when the mouse pointer leaves a
+# button widget. It changes the state of the button back to
+# inactive. If we're leaving the button window with a mouse button
+# pressed (tkPriv(buttonWindow) == $w), restore the relief of the
+# button too.
+#
+# Arguments:
+# w - The name of the widget.
+sub Leave
+{
+ my $w = shift;
+ $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled');
+ # Restore the original button relief if it was changed by Tk.
+ # That is signaled by the existence of Priv($w,prelief).
+ if (exists $w->{__relief__})
+ {
+ if (exists $w->{__prelief__} &&
+ $w->{__prelief__} eq $w->cget('-relief'))
+ {
+ $w->configure(-relief => $w->{__relief__});
+ }
+ delete $w->{__relief__};
+ delete $w->{__prelief__};
+ }
+ undef $Tk::window;
+}
+
+# tkButtonDown --
+# The procedure below is invoked when the mouse button is pressed in
+# a button widget. It records the fact that the mouse is in the button,
+# saves the button's relief so it can be restored later, and changes
+# the relief to sunken.
+#
+# Arguments:
+# w - The name of the widget.
+sub butDown
+{
+ my $w = shift;
+
+ # Only save the button's relief if it does not yet exist. If there
+ # is an overrelief setting, Priv($w,relief) will already have been set,
+ # and the current value of the -relief option will be incorrect.
+
+ if (!exists $w->{__relief__})
+ {
+ $w->{__relief__} = $w->cget('-relief');
+ }
+
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $buttonWindow = $w;
+ $w->configure('-relief' => 'sunken', '-state' => 'active');
+ $w->{__prelief__} = 'sunken';
+
+ # If this button has a repeatdelay set up, get it going with an after
+ $w->afterCancel($afterId);
+ my $delay = $w->cget('-repeatdelay');
+ $repeated = 0;
+ if ($delay > 0)
+ {
+ $afterId = $w->after($delay, [$w, 'AutoInvoke']);
+ }
+ }
+}
+
+# tkButtonUp --
+# The procedure below is invoked when the mouse button is released
+# in a button widget. It restores the button's relief and invokes
+# the command as long as the mouse hasn't left the button.
+#
+# Arguments:
+# w - The name of the widget.
+sub butUp
+{
+ my $w = shift;
+ if (defined($buttonWindow) && $buttonWindow == $w)
+ {
+ undef $buttonWindow;
+
+ # Restore the button's relief if it was cached.
+ if (exists $w->{__relief__})
+ {
+ if (exists $w->{__prelief__} &&
+ $w->{__prelief__} eq $w->cget('-relief'))
+ {
+ $w->configure(-relief => $w->{__relief__});
+ }
+ delete $w->{__relief__};
+ delete $w->{__prelief__};
+ }
+
+ # Clean up the after event from the auto-repeater
+ $w->afterCancel($afterId);
+
+ if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled')
+ {
+ $w->configure(-state => 'normal');
+ # Only invoke the command if it wasn't already invoked by the
+ # auto-repeater functionality
+ if ($repeated == 0)
+ {
+ $w->invoke;
+ }
+ }
+ }
+}
+
+# tkButtonInvoke --
+# The procedure below is called when a button is invoked through
+# the keyboard. It simulate a press of the button via the mouse.
+#
+# Arguments:
+# w - The name of the widget.
+sub Invoke
+{
+ my $w = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ my $oldRelief = $w->cget('-relief');
+ my $oldState = $w->cget('-state');
+ $w->configure('-state' => 'active', '-relief' => 'sunken');
+ $w->idletasks;
+ $w->after(100);
+ $w->configure('-state' => $oldState, '-relief' => $oldRelief);
+ $w->invoke;
+ }
+}
+
+# ::tk::ButtonAutoInvoke --
+#
+# Invoke an auto-repeating button, and set it up to continue to repeat.
+#
+# Arguments:
+# w button to invoke.
+#
+# Results:
+# None.
+#
+# Side effects:
+# May create an after event to call ::tk::ButtonAutoInvoke.
+sub AutoInvoke
+{
+ my $w = shift;
+ $w->afterCancel($afterId);
+ my $delay = $w->cget('-repeatinterval');
+ if ($w->IS($Tk::window))
+ {
+ $repeated++;
+ $w->invoke;
+ }
+ if ($delay > 0)
+ {
+ $afterId = $w->after($delay, [$w, 'AutoInvoke']);
+ }
+}
+
+# Used for Tk::Widget::AmpWidget
+sub AmpWidgetPostHook
+{
+ my $w = shift;
+ $w->bind('<<AltUnderlined>>' => ['invoke']);
+}
+
+
+1;
+
+__END__
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Button.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Button.pod
new file mode 100755
index 00000000000..2eb6401ca9d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Button.pod
@@ -0,0 +1,255 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Button - Create and manipulate Button widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$button> = I<$parent>-E<gt>B<Button>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground>
+B<-activeforeground>
+B<-anchor>
+B<-background>
+B<-bitmap>
+B<-borderwidth>
+B<-compound>
+B<-cursor>
+B<-disabledforeground>
+B<-font>
+B<-foreground>
+B<-highlightbackground>
+B<-highlightcolor>
+B<-highlightthickness>
+B<-image>
+B<-justify>
+B<-padx>
+B<-pady>
+B<-relief>
+B<-repeatdelay>
+B<-repeatinterval>
+B<-takefocus>
+B<-text>
+B<-textvariable>
+B<-underline>
+B<-wraplength>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies a L<Perl/Tk callback|Tk::callbacks> to associate with the
+button. This command is typically invoked when mouse button 1 is
+released over the button window.
+
+=item Command-Line Name: B<-compound>
+
+=item Database Name: B<compound>
+
+=item Database Class: B<Compound>
+
+Specifies whether the button should display both an image and text,
+and if so, where the image should be placed relative to the text.
+Valid values for this option are B<bottom>, B<center>, B<left>,
+B<none>, B<right> and B<top>. The default value is B<none>, meaning
+that the button will display either an image or text, depending on the
+values of the -image and -bitmap options.
+
+=item Name: B<default>
+
+=item Class: B<Default>
+
+=item Switch: B<-default>
+
+Specifies one of three states for the default ring: B<normal>,
+B<active>, or B<disabled>. In active state, the button is drawn
+with the platform specific appearance for a default button. In normal
+state, the button is drawn with the platform specific appearance for a
+non-default button, leaving enough space to draw the default button
+appearance. The normal and active states will result in buttons of
+the same size. In disabled state, the button is drawn with the
+non-default button appearance without leaving space for the default
+appearance. The disabled state may result in a smaller button than
+the active state.
+ring.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies a desired height for the button.
+If an image or bitmap is being displayed in the button then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in lines of text.
+If this option isn't specified, the button's desired height is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=item Command-Line Name: B<-overrelief>
+
+=item Database Name: B<overRelief>
+
+=item Database Class: B<OverRelief>
+
+Specifies an alternative relief for the button, to be used when
+the mouse cursor is over the widget. This option can be used to
+make toolbar buttons, by configuring B<-relief flat -overrelief
+raised>. If the value of this option is the empty string, then
+no alternative relief is used when the mouse cursor is over the
+button. The empty string is the default value.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of three states for the button: B<normal>, B<active>,
+or B<disabled>. In normal state the button is displayed using the
+B<foreground> and B<background> options. The active state is
+typically used when the pointer is over the button. In active state
+the button is displayed using the B<activeForeground> and
+B<activeBackground> options. Disabled state means that the button
+should be insensitive: the default bindings will refuse to activate
+the widget and will ignore mouse button presses.
+In this state the B<disabledForeground> and
+B<background> options determine how the button is displayed.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies a desired width for the button.
+If an image or bitmap is being displayed in the button then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in characters.
+If this option isn't specified, the button's desired width is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Button> method creates a new window (given by the
+$widget argument) and makes it into a button widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the button such as its colors, font,
+text, and initial relief. The B<button> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A button is a widget that displays a textual string, bitmap or image.
+If text is displayed, it must all be in a single font, but it
+can occupy multiple lines on the screen (if it contains newlines
+or if wrapping occurs because of the B<-wraplength> option) and
+one of the characters may optionally be underlined using the
+B<-underline> option.
+It can display itself in either of three different ways, according
+to
+the B<-state> option;
+it can be made to appear raised, sunken, or flat;
+and it can be made to flash. When a user invokes the
+button (by pressing mouse button 1 with the cursor over the
+button), then the L<perl/Tk callback|Tk::callbacks> specified in the B<-command>
+option is invoked.
+
+=head1 WIDGET METHODS
+
+The B<Button> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for button widgets:
+
+=over 4
+
+=item I<$button>-E<gt>B<flash>
+
+Flash the button. This is accomplished by redisplaying the button
+several times, alternating between active and normal colors. At
+the end of the flash the button is left in the same normal/active
+state as when the command was invoked.
+This command is ignored if the button's state is B<disabled>.
+
+=item I<$button>-E<gt>B<invoke>
+
+Invoke the L<callback|Tk::callbacks> associated with the buttons
+B<-command> option, if there is one.
+The return value is the return value from the callback, or the
+undefined value if there is no callback associated with the button.
+This command is ignored if the button's state is B<disabled>.
+
+=back
+
+=head1 DEFAULT BINDINGS
+
+Tk automatically creates class bindings for buttons that give them
+default behavior:
+
+=over 4
+
+=item [1]
+
+A button activates whenever the mouse passes over it and deactivates
+whenever the mouse leaves the button.
+Under Windows, this binding is only active when mouse button 1 has
+been pressed over the button.
+
+=item [2]
+
+A button's relief is changed to sunken whenever mouse button 1 is
+pressed over the button, and the relief is restored to its original
+value when button 1 is later released.
+
+=item [3]
+
+If mouse button 1 is pressed over a button and later released over
+the button, the button is invoked. However, if the mouse is not
+over the button when button 1 is released, then no invocation occurs.
+
+=item [4]
+
+When a button has the input focus, the space key causes the button
+to be invoked.
+
+If the button's state is B<disabled> then none of the above
+actions occur: the button is completely non-responsive.
+
+The behavior of buttons can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 KEYWORDS
+
+button, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Camel.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/Camel.xpm
new file mode 100755
index 00000000000..ba33c0149ec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Camel.xpm
@@ -0,0 +1,41 @@
+/* XPM */
+static char *Camel[] = {
+/* width height num_colors chars_per_pixel */
+" 32 32 2 1",
+/* colors */
+". c #ffffff",
+"# c #7f7f00",
+/* pixels */
+"................................",
+"................................",
+"...................###..........",
+".......####......######.........",
+"....####.##.....########........",
+"....########....#########.......",
+"......######..###########.......",
+"......#####..#############......",
+".....######.##############......",
+".....######.###############.....",
+".....######################.....",
+".....#######################....",
+".....#######################....",
+"......#######################...",
+".......####################.#...",
+"........###################.#...",
+"........###############.###.#...",
+"............#######.###.###.#...",
+"............###.###.##...##.....",
+"............###.###..#...##.....",
+"............##.####..#....#.....",
+"............##.###...#....#.....",
+"............##.##...#.....#.....",
+"............#...#...#.....#.....",
+"............#....#..#.....#.....",
+"............#.....#.#.....#.....",
+"............#.....###.....#.....",
+"...........##....##.#....#......",
+"...........#..............#.....",
+".........###.............#......"
+"................................",
+"................................",
+};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Canvas.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Canvas.pm
new file mode 100755
index 00000000000..210bc30bfc2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Canvas.pm
@@ -0,0 +1,1436 @@
+package Tk::Canvas;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+
+use base qw(Tk::Widget);
+Construct Tk::Widget 'Canvas';
+
+bootstrap Tk::Canvas;
+
+sub Tk_cmd { \&Tk::canvas }
+
+Tk::Methods('addtag','bbox','bind','canvasx','canvasy','coords','create',
+ 'dchars','delete','dtag','find','focus','gettags','icursor',
+ 'index','insert','itemcget','itemconfigure','lower','move',
+ 'postscript','raise','scale','scan','select','type','xview','yview');
+
+use Tk::Submethods ( 'create' => [qw(arc bitmap grid group image line oval
+ polygon rectangle text window)],
+ 'scan' => [qw(mark dragto)],
+ 'select' => [qw(from clear item to)],
+ 'xview' => [qw(moveto scroll)],
+ 'yview' => [qw(moveto scroll)],
+ );
+
+*CanvasBind = \&Tk::bind;
+*CanvasFocus = \&Tk::focus;
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->XYscrollBind($class);
+ return $class;
+}
+
+sub BalloonInfo
+{
+ my ($canvas,$balloon,$X,$Y,@opt) = @_;
+ my @tags = ($canvas->find('withtag', 'current'),$canvas->gettags('current'));
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$canvas);
+ if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
+ {
+ $balloon->Subclient($tags[0]);
+ foreach my $tag (@tags)
+ {
+ return $info->{$tag} if exists $info->{$tag};
+ }
+ return '';
+ }
+ return $info;
+ }
+}
+
+sub get_corners
+{
+ my $c = shift;
+ my(@xview) = $c->xview;
+ my(@yview) = $c->yview;
+ my(@scrollregion) = @{$c->cget(-scrollregion)};
+ return (
+ $xview[0] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0],
+ $yview[0] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1],
+ $xview[1] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0],
+ $yview[1] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1],
+ );
+}
+
+# List of adobe glyph names. Converted from glyphlist.txt, downloaded
+# from Adobe
+
+$Tk::psglyphs = {qw(
+ 0020 space
+ 0021 exclam
+ 0022 quotedbl
+ 0023 numbersign
+ 0024 dollar
+ 0025 percent
+ 0026 ampersand
+ 0027 quotesingle
+ 0028 parenleft
+ 0029 parenright
+ 002A asterisk
+ 002B plus
+ 002C comma
+ 002D hyphen
+ 002E period
+ 002F slash
+ 0030 zero
+ 0031 one
+ 0032 two
+ 0033 three
+ 0034 four
+ 0035 five
+ 0036 six
+ 0037 seven
+ 0038 eight
+ 0039 nine
+ 003A colon
+ 003B semicolon
+ 003C less
+ 003D equal
+ 003E greater
+ 003F question
+ 0040 at
+ 0041 A
+ 0042 B
+ 0043 C
+ 0044 D
+ 0045 E
+ 0046 F
+ 0047 G
+ 0048 H
+ 0049 I
+ 004A J
+ 004B K
+ 004C L
+ 004D M
+ 004E N
+ 004F O
+ 0050 P
+ 0051 Q
+ 0052 R
+ 0053 S
+ 0054 T
+ 0055 U
+ 0056 V
+ 0057 W
+ 0058 X
+ 0059 Y
+ 005A Z
+ 005B bracketleft
+ 005C backslash
+ 005D bracketright
+ 005E asciicircum
+ 005F underscore
+ 0060 grave
+ 0061 a
+ 0062 b
+ 0063 c
+ 0064 d
+ 0065 e
+ 0066 f
+ 0067 g
+ 0068 h
+ 0069 i
+ 006A j
+ 006B k
+ 006C l
+ 006D m
+ 006E n
+ 006F o
+ 0070 p
+ 0071 q
+ 0072 r
+ 0073 s
+ 0074 t
+ 0075 u
+ 0076 v
+ 0077 w
+ 0078 x
+ 0079 y
+ 007A z
+ 007B braceleft
+ 007C bar
+ 007D braceright
+ 007E asciitilde
+ 00A0 space
+ 00A1 exclamdown
+ 00A2 cent
+ 00A3 sterling
+ 00A4 currency
+ 00A5 yen
+ 00A6 brokenbar
+ 00A7 section
+ 00A8 dieresis
+ 00A9 copyright
+ 00AA ordfeminine
+ 00AB guillemotleft
+ 00AC logicalnot
+ 00AD hyphen
+ 00AE registered
+ 00AF macron
+ 00B0 degree
+ 00B1 plusminus
+ 00B2 twosuperior
+ 00B3 threesuperior
+ 00B4 acute
+ 00B5 mu
+ 00B6 paragraph
+ 00B7 periodcentered
+ 00B8 cedilla
+ 00B9 onesuperior
+ 00BA ordmasculine
+ 00BB guillemotright
+ 00BC onequarter
+ 00BD onehalf
+ 00BE threequarters
+ 00BF questiondown
+ 00C0 Agrave
+ 00C1 Aacute
+ 00C2 Acircumflex
+ 00C3 Atilde
+ 00C4 Adieresis
+ 00C5 Aring
+ 00C6 AE
+ 00C7 Ccedilla
+ 00C8 Egrave
+ 00C9 Eacute
+ 00CA Ecircumflex
+ 00CB Edieresis
+ 00CC Igrave
+ 00CD Iacute
+ 00CE Icircumflex
+ 00CF Idieresis
+ 00D0 Eth
+ 00D1 Ntilde
+ 00D2 Ograve
+ 00D3 Oacute
+ 00D4 Ocircumflex
+ 00D5 Otilde
+ 00D6 Odieresis
+ 00D7 multiply
+ 00D8 Oslash
+ 00D9 Ugrave
+ 00DA Uacute
+ 00DB Ucircumflex
+ 00DC Udieresis
+ 00DD Yacute
+ 00DE Thorn
+ 00DF germandbls
+ 00E0 agrave
+ 00E1 aacute
+ 00E2 acircumflex
+ 00E3 atilde
+ 00E4 adieresis
+ 00E5 aring
+ 00E6 ae
+ 00E7 ccedilla
+ 00E8 egrave
+ 00E9 eacute
+ 00EA ecircumflex
+ 00EB edieresis
+ 00EC igrave
+ 00ED iacute
+ 00EE icircumflex
+ 00EF idieresis
+ 00F0 eth
+ 00F1 ntilde
+ 00F2 ograve
+ 00F3 oacute
+ 00F4 ocircumflex
+ 00F5 otilde
+ 00F6 odieresis
+ 00F7 divide
+ 00F8 oslash
+ 00F9 ugrave
+ 00FA uacute
+ 00FB ucircumflex
+ 00FC udieresis
+ 00FD yacute
+ 00FE thorn
+ 00FF ydieresis
+ 0100 Amacron
+ 0101 amacron
+ 0102 Abreve
+ 0103 abreve
+ 0104 Aogonek
+ 0105 aogonek
+ 0106 Cacute
+ 0107 cacute
+ 0108 Ccircumflex
+ 0109 ccircumflex
+ 010A Cdotaccent
+ 010B cdotaccent
+ 010C Ccaron
+ 010D ccaron
+ 010E Dcaron
+ 010F dcaron
+ 0110 Dcroat
+ 0111 dcroat
+ 0112 Emacron
+ 0113 emacron
+ 0114 Ebreve
+ 0115 ebreve
+ 0116 Edotaccent
+ 0117 edotaccent
+ 0118 Eogonek
+ 0119 eogonek
+ 011A Ecaron
+ 011B ecaron
+ 011C Gcircumflex
+ 011D gcircumflex
+ 011E Gbreve
+ 011F gbreve
+ 0120 Gdotaccent
+ 0121 gdotaccent
+ 0122 Gcommaaccent
+ 0123 gcommaaccent
+ 0124 Hcircumflex
+ 0125 hcircumflex
+ 0126 Hbar
+ 0127 hbar
+ 0128 Itilde
+ 0129 itilde
+ 012A Imacron
+ 012B imacron
+ 012C Ibreve
+ 012D ibreve
+ 012E Iogonek
+ 012F iogonek
+ 0130 Idotaccent
+ 0131 dotlessi
+ 0132 IJ
+ 0133 ij
+ 0134 Jcircumflex
+ 0135 jcircumflex
+ 0136 Kcommaaccent
+ 0137 kcommaaccent
+ 0138 kgreenlandic
+ 0139 Lacute
+ 013A lacute
+ 013B Lcommaaccent
+ 013C lcommaaccent
+ 013D Lcaron
+ 013E lcaron
+ 013F Ldot
+ 0140 ldot
+ 0141 Lslash
+ 0142 lslash
+ 0143 Nacute
+ 0144 nacute
+ 0145 Ncommaaccent
+ 0146 ncommaaccent
+ 0147 Ncaron
+ 0148 ncaron
+ 0149 napostrophe
+ 014A Eng
+ 014B eng
+ 014C Omacron
+ 014D omacron
+ 014E Obreve
+ 014F obreve
+ 0150 Ohungarumlaut
+ 0151 ohungarumlaut
+ 0152 OE
+ 0153 oe
+ 0154 Racute
+ 0155 racute
+ 0156 Rcommaaccent
+ 0157 rcommaaccent
+ 0158 Rcaron
+ 0159 rcaron
+ 015A Sacute
+ 015B sacute
+ 015C Scircumflex
+ 015D scircumflex
+ 015E Scedilla
+ 015F scedilla
+ 0160 Scaron
+ 0161 scaron
+ 0162 Tcommaaccent
+ 0163 tcommaaccent
+ 0164 Tcaron
+ 0165 tcaron
+ 0166 Tbar
+ 0167 tbar
+ 0168 Utilde
+ 0169 utilde
+ 016A Umacron
+ 016B umacron
+ 016C Ubreve
+ 016D ubreve
+ 016E Uring
+ 016F uring
+ 0170 Uhungarumlaut
+ 0171 uhungarumlaut
+ 0172 Uogonek
+ 0173 uogonek
+ 0174 Wcircumflex
+ 0175 wcircumflex
+ 0176 Ycircumflex
+ 0177 ycircumflex
+ 0178 Ydieresis
+ 0179 Zacute
+ 017A zacute
+ 017B Zdotaccent
+ 017C zdotaccent
+ 017D Zcaron
+ 017E zcaron
+ 017F longs
+ 0192 florin
+ 01A0 Ohorn
+ 01A1 ohorn
+ 01AF Uhorn
+ 01B0 uhorn
+ 01E6 Gcaron
+ 01E7 gcaron
+ 01FA Aringacute
+ 01FB aringacute
+ 01FC AEacute
+ 01FD aeacute
+ 01FE Oslashacute
+ 01FF oslashacute
+ 0218 Scommaaccent
+ 0219 scommaaccent
+ 021A Tcommaaccent
+ 021B tcommaaccent
+ 02BC afii57929
+ 02BD afii64937
+ 02C6 circumflex
+ 02C7 caron
+ 02C9 macron
+ 02D8 breve
+ 02D9 dotaccent
+ 02DA ring
+ 02DB ogonek
+ 02DC tilde
+ 02DD hungarumlaut
+ 0300 gravecomb
+ 0301 acutecomb
+ 0303 tildecomb
+ 0309 hookabovecomb
+ 0323 dotbelowcomb
+ 0384 tonos
+ 0385 dieresistonos
+ 0386 Alphatonos
+ 0387 anoteleia
+ 0388 Epsilontonos
+ 0389 Etatonos
+ 038A Iotatonos
+ 038C Omicrontonos
+ 038E Upsilontonos
+ 038F Omegatonos
+ 0390 iotadieresistonos
+ 0391 Alpha
+ 0392 Beta
+ 0393 Gamma
+ 0394 Delta
+ 0395 Epsilon
+ 0396 Zeta
+ 0397 Eta
+ 0398 Theta
+ 0399 Iota
+ 039A Kappa
+ 039B Lambda
+ 039C Mu
+ 039D Nu
+ 039E Xi
+ 039F Omicron
+ 03A0 Pi
+ 03A1 Rho
+ 03A3 Sigma
+ 03A4 Tau
+ 03A5 Upsilon
+ 03A6 Phi
+ 03A7 Chi
+ 03A8 Psi
+ 03A9 Omega
+ 03AA Iotadieresis
+ 03AB Upsilondieresis
+ 03AC alphatonos
+ 03AD epsilontonos
+ 03AE etatonos
+ 03AF iotatonos
+ 03B0 upsilondieresistonos
+ 03B1 alpha
+ 03B2 beta
+ 03B3 gamma
+ 03B4 delta
+ 03B5 epsilon
+ 03B6 zeta
+ 03B7 eta
+ 03B8 theta
+ 03B9 iota
+ 03BA kappa
+ 03BB lambda
+ 03BC mu
+ 03BD nu
+ 03BE xi
+ 03BF omicron
+ 03C0 pi
+ 03C1 rho
+ 03C2 sigma1
+ 03C3 sigma
+ 03C4 tau
+ 03C5 upsilon
+ 03C6 phi
+ 03C7 chi
+ 03C8 psi
+ 03C9 omega
+ 03CA iotadieresis
+ 03CB upsilondieresis
+ 03CC omicrontonos
+ 03CD upsilontonos
+ 03CE omegatonos
+ 03D1 theta1
+ 03D2 Upsilon1
+ 03D5 phi1
+ 03D6 omega1
+ 0401 afii10023
+ 0402 afii10051
+ 0403 afii10052
+ 0404 afii10053
+ 0405 afii10054
+ 0406 afii10055
+ 0407 afii10056
+ 0408 afii10057
+ 0409 afii10058
+ 040A afii10059
+ 040B afii10060
+ 040C afii10061
+ 040E afii10062
+ 040F afii10145
+ 0410 afii10017
+ 0411 afii10018
+ 0412 afii10019
+ 0413 afii10020
+ 0414 afii10021
+ 0415 afii10022
+ 0416 afii10024
+ 0417 afii10025
+ 0418 afii10026
+ 0419 afii10027
+ 041A afii10028
+ 041B afii10029
+ 041C afii10030
+ 041D afii10031
+ 041E afii10032
+ 041F afii10033
+ 0420 afii10034
+ 0421 afii10035
+ 0422 afii10036
+ 0423 afii10037
+ 0424 afii10038
+ 0425 afii10039
+ 0426 afii10040
+ 0427 afii10041
+ 0428 afii10042
+ 0429 afii10043
+ 042A afii10044
+ 042B afii10045
+ 042C afii10046
+ 042D afii10047
+ 042E afii10048
+ 042F afii10049
+ 0430 afii10065
+ 0431 afii10066
+ 0432 afii10067
+ 0433 afii10068
+ 0434 afii10069
+ 0435 afii10070
+ 0436 afii10072
+ 0437 afii10073
+ 0438 afii10074
+ 0439 afii10075
+ 043A afii10076
+ 043B afii10077
+ 043C afii10078
+ 043D afii10079
+ 043E afii10080
+ 043F afii10081
+ 0440 afii10082
+ 0441 afii10083
+ 0442 afii10084
+ 0443 afii10085
+ 0444 afii10086
+ 0445 afii10087
+ 0446 afii10088
+ 0447 afii10089
+ 0448 afii10090
+ 0449 afii10091
+ 044A afii10092
+ 044B afii10093
+ 044C afii10094
+ 044D afii10095
+ 044E afii10096
+ 044F afii10097
+ 0451 afii10071
+ 0452 afii10099
+ 0453 afii10100
+ 0454 afii10101
+ 0455 afii10102
+ 0456 afii10103
+ 0457 afii10104
+ 0458 afii10105
+ 0459 afii10106
+ 045A afii10107
+ 045B afii10108
+ 045C afii10109
+ 045E afii10110
+ 045F afii10193
+ 0462 afii10146
+ 0463 afii10194
+ 0472 afii10147
+ 0473 afii10195
+ 0474 afii10148
+ 0475 afii10196
+ 0490 afii10050
+ 0491 afii10098
+ 04D9 afii10846
+ 05B0 afii57799
+ 05B1 afii57801
+ 05B2 afii57800
+ 05B3 afii57802
+ 05B4 afii57793
+ 05B5 afii57794
+ 05B6 afii57795
+ 05B7 afii57798
+ 05B8 afii57797
+ 05B9 afii57806
+ 05BB afii57796
+ 05BC afii57807
+ 05BD afii57839
+ 05BE afii57645
+ 05BF afii57841
+ 05C0 afii57842
+ 05C1 afii57804
+ 05C2 afii57803
+ 05C3 afii57658
+ 05D0 afii57664
+ 05D1 afii57665
+ 05D2 afii57666
+ 05D3 afii57667
+ 05D4 afii57668
+ 05D5 afii57669
+ 05D6 afii57670
+ 05D7 afii57671
+ 05D8 afii57672
+ 05D9 afii57673
+ 05DA afii57674
+ 05DB afii57675
+ 05DC afii57676
+ 05DD afii57677
+ 05DE afii57678
+ 05DF afii57679
+ 05E0 afii57680
+ 05E1 afii57681
+ 05E2 afii57682
+ 05E3 afii57683
+ 05E4 afii57684
+ 05E5 afii57685
+ 05E6 afii57686
+ 05E7 afii57687
+ 05E8 afii57688
+ 05E9 afii57689
+ 05EA afii57690
+ 05F0 afii57716
+ 05F1 afii57717
+ 05F2 afii57718
+ 060C afii57388
+ 061B afii57403
+ 061F afii57407
+ 0621 afii57409
+ 0622 afii57410
+ 0623 afii57411
+ 0624 afii57412
+ 0625 afii57413
+ 0626 afii57414
+ 0627 afii57415
+ 0628 afii57416
+ 0629 afii57417
+ 062A afii57418
+ 062B afii57419
+ 062C afii57420
+ 062D afii57421
+ 062E afii57422
+ 062F afii57423
+ 0630 afii57424
+ 0631 afii57425
+ 0632 afii57426
+ 0633 afii57427
+ 0634 afii57428
+ 0635 afii57429
+ 0636 afii57430
+ 0637 afii57431
+ 0638 afii57432
+ 0639 afii57433
+ 063A afii57434
+ 0640 afii57440
+ 0641 afii57441
+ 0642 afii57442
+ 0643 afii57443
+ 0644 afii57444
+ 0645 afii57445
+ 0646 afii57446
+ 0647 afii57470
+ 0648 afii57448
+ 0649 afii57449
+ 064A afii57450
+ 064B afii57451
+ 064C afii57452
+ 064D afii57453
+ 064E afii57454
+ 064F afii57455
+ 0650 afii57456
+ 0651 afii57457
+ 0652 afii57458
+ 0660 afii57392
+ 0661 afii57393
+ 0662 afii57394
+ 0663 afii57395
+ 0664 afii57396
+ 0665 afii57397
+ 0666 afii57398
+ 0667 afii57399
+ 0668 afii57400
+ 0669 afii57401
+ 066A afii57381
+ 066D afii63167
+ 0679 afii57511
+ 067E afii57506
+ 0686 afii57507
+ 0688 afii57512
+ 0691 afii57513
+ 0698 afii57508
+ 06A4 afii57505
+ 06AF afii57509
+ 06BA afii57514
+ 06D2 afii57519
+ 06D5 afii57534
+ 1E80 Wgrave
+ 1E81 wgrave
+ 1E82 Wacute
+ 1E83 wacute
+ 1E84 Wdieresis
+ 1E85 wdieresis
+ 1EF2 Ygrave
+ 1EF3 ygrave
+ 200C afii61664
+ 200D afii301
+ 200E afii299
+ 200F afii300
+ 2012 figuredash
+ 2013 endash
+ 2014 emdash
+ 2015 afii00208
+ 2017 underscoredbl
+ 2018 quoteleft
+ 2019 quoteright
+ 201A quotesinglbase
+ 201B quotereversed
+ 201C quotedblleft
+ 201D quotedblright
+ 201E quotedblbase
+ 2020 dagger
+ 2021 daggerdbl
+ 2022 bullet
+ 2024 onedotenleader
+ 2025 twodotenleader
+ 2026 ellipsis
+ 202C afii61573
+ 202D afii61574
+ 202E afii61575
+ 2030 perthousand
+ 2032 minute
+ 2033 second
+ 2039 guilsinglleft
+ 203A guilsinglright
+ 203C exclamdbl
+ 2044 fraction
+ 2070 zerosuperior
+ 2074 foursuperior
+ 2075 fivesuperior
+ 2076 sixsuperior
+ 2077 sevensuperior
+ 2078 eightsuperior
+ 2079 ninesuperior
+ 207D parenleftsuperior
+ 207E parenrightsuperior
+ 207F nsuperior
+ 2080 zeroinferior
+ 2081 oneinferior
+ 2082 twoinferior
+ 2083 threeinferior
+ 2084 fourinferior
+ 2085 fiveinferior
+ 2086 sixinferior
+ 2087 seveninferior
+ 2088 eightinferior
+ 2089 nineinferior
+ 208D parenleftinferior
+ 208E parenrightinferior
+ 20A1 colonmonetary
+ 20A3 franc
+ 20A4 lira
+ 20A7 peseta
+ 20AA afii57636
+ 20AB dong
+ 20AC Euro
+ 2105 afii61248
+ 2111 Ifraktur
+ 2113 afii61289
+ 2116 afii61352
+ 2118 weierstrass
+ 211C Rfraktur
+ 211E prescription
+ 2122 trademark
+ 2126 Omega
+ 212E estimated
+ 2135 aleph
+ 2153 onethird
+ 2154 twothirds
+ 215B oneeighth
+ 215C threeeighths
+ 215D fiveeighths
+ 215E seveneighths
+ 2190 arrowleft
+ 2191 arrowup
+ 2192 arrowright
+ 2193 arrowdown
+ 2194 arrowboth
+ 2195 arrowupdn
+ 21A8 arrowupdnbse
+ 21B5 carriagereturn
+ 21D0 arrowdblleft
+ 21D1 arrowdblup
+ 21D2 arrowdblright
+ 21D3 arrowdbldown
+ 21D4 arrowdblboth
+ 2200 universal
+ 2202 partialdiff
+ 2203 existential
+ 2205 emptyset
+ 2206 Delta
+ 2207 gradient
+ 2208 element
+ 2209 notelement
+ 220B suchthat
+ 220F product
+ 2211 summation
+ 2212 minus
+ 2215 fraction
+ 2217 asteriskmath
+ 2219 periodcentered
+ 221A radical
+ 221D proportional
+ 221E infinity
+ 221F orthogonal
+ 2220 angle
+ 2227 logicaland
+ 2228 logicalor
+ 2229 intersection
+ 222A union
+ 222B integral
+ 2234 therefore
+ 223C similar
+ 2245 congruent
+ 2248 approxequal
+ 2260 notequal
+ 2261 equivalence
+ 2264 lessequal
+ 2265 greaterequal
+ 2282 propersubset
+ 2283 propersuperset
+ 2284 notsubset
+ 2286 reflexsubset
+ 2287 reflexsuperset
+ 2295 circleplus
+ 2297 circlemultiply
+ 22A5 perpendicular
+ 22C5 dotmath
+ 2302 house
+ 2310 revlogicalnot
+ 2320 integraltp
+ 2321 integralbt
+ 2329 angleleft
+ 232A angleright
+ 2500 SF100000
+ 2502 SF110000
+ 250C SF010000
+ 2510 SF030000
+ 2514 SF020000
+ 2518 SF040000
+ 251C SF080000
+ 2524 SF090000
+ 252C SF060000
+ 2534 SF070000
+ 253C SF050000
+ 2550 SF430000
+ 2551 SF240000
+ 2552 SF510000
+ 2553 SF520000
+ 2554 SF390000
+ 2555 SF220000
+ 2556 SF210000
+ 2557 SF250000
+ 2558 SF500000
+ 2559 SF490000
+ 255A SF380000
+ 255B SF280000
+ 255C SF270000
+ 255D SF260000
+ 255E SF360000
+ 255F SF370000
+ 2560 SF420000
+ 2561 SF190000
+ 2562 SF200000
+ 2563 SF230000
+ 2564 SF470000
+ 2565 SF480000
+ 2566 SF410000
+ 2567 SF450000
+ 2568 SF460000
+ 2569 SF400000
+ 256A SF540000
+ 256B SF530000
+ 256C SF440000
+ 2580 upblock
+ 2584 dnblock
+ 2588 block
+ 258C lfblock
+ 2590 rtblock
+ 2591 ltshade
+ 2592 shade
+ 2593 dkshade
+ 25A0 filledbox
+ 25A1 H22073
+ 25AA H18543
+ 25AB H18551
+ 25AC filledrect
+ 25B2 triagup
+ 25BA triagrt
+ 25BC triagdn
+ 25C4 triaglf
+ 25CA lozenge
+ 25CB circle
+ 25CF H18533
+ 25D8 invbullet
+ 25D9 invcircle
+ 25E6 openbullet
+ 263A smileface
+ 263B invsmileface
+ 263C sun
+ 2640 female
+ 2642 male
+ 2660 spade
+ 2663 club
+ 2665 heart
+ 2666 diamond
+ 266A musicalnote
+ 266B musicalnotedbl
+ F6BE dotlessj
+ F6BF LL
+ F6C0 ll
+ F6C1 Scedilla
+ F6C2 scedilla
+ F6C3 commaaccent
+ F6C4 afii10063
+ F6C5 afii10064
+ F6C6 afii10192
+ F6C7 afii10831
+ F6C8 afii10832
+ F6C9 Acute
+ F6CA Caron
+ F6CB Dieresis
+ F6CC DieresisAcute
+ F6CD DieresisGrave
+ F6CE Grave
+ F6CF Hungarumlaut
+ F6D0 Macron
+ F6D1 cyrBreve
+ F6D2 cyrFlex
+ F6D3 dblGrave
+ F6D4 cyrbreve
+ F6D5 cyrflex
+ F6D6 dblgrave
+ F6D7 dieresisacute
+ F6D8 dieresisgrave
+ F6D9 copyrightserif
+ F6DA registerserif
+ F6DB trademarkserif
+ F6DC onefitted
+ F6DD rupiah
+ F6DE threequartersemdash
+ F6DF centinferior
+ F6E0 centsuperior
+ F6E1 commainferior
+ F6E2 commasuperior
+ F6E3 dollarinferior
+ F6E4 dollarsuperior
+ F6E5 hypheninferior
+ F6E6 hyphensuperior
+ F6E7 periodinferior
+ F6E8 periodsuperior
+ F6E9 asuperior
+ F6EA bsuperior
+ F6EB dsuperior
+ F6EC esuperior
+ F6ED isuperior
+ F6EE lsuperior
+ F6EF msuperior
+ F6F0 osuperior
+ F6F1 rsuperior
+ F6F2 ssuperior
+ F6F3 tsuperior
+ F6F4 Brevesmall
+ F6F5 Caronsmall
+ F6F6 Circumflexsmall
+ F6F7 Dotaccentsmall
+ F6F8 Hungarumlautsmall
+ F6F9 Lslashsmall
+ F6FA OEsmall
+ F6FB Ogoneksmall
+ F6FC Ringsmall
+ F6FD Scaronsmall
+ F6FE Tildesmall
+ F6FF Zcaronsmall
+ F721 exclamsmall
+ F724 dollaroldstyle
+ F726 ampersandsmall
+ F730 zerooldstyle
+ F731 oneoldstyle
+ F732 twooldstyle
+ F733 threeoldstyle
+ F734 fouroldstyle
+ F735 fiveoldstyle
+ F736 sixoldstyle
+ F737 sevenoldstyle
+ F738 eightoldstyle
+ F739 nineoldstyle
+ F73F questionsmall
+ F760 Gravesmall
+ F761 Asmall
+ F762 Bsmall
+ F763 Csmall
+ F764 Dsmall
+ F765 Esmall
+ F766 Fsmall
+ F767 Gsmall
+ F768 Hsmall
+ F769 Ismall
+ F76A Jsmall
+ F76B Ksmall
+ F76C Lsmall
+ F76D Msmall
+ F76E Nsmall
+ F76F Osmall
+ F770 Psmall
+ F771 Qsmall
+ F772 Rsmall
+ F773 Ssmall
+ F774 Tsmall
+ F775 Usmall
+ F776 Vsmall
+ F777 Wsmall
+ F778 Xsmall
+ F779 Ysmall
+ F77A Zsmall
+ F7A1 exclamdownsmall
+ F7A2 centoldstyle
+ F7A8 Dieresissmall
+ F7AF Macronsmall
+ F7B4 Acutesmall
+ F7B8 Cedillasmall
+ F7BF questiondownsmall
+ F7E0 Agravesmall
+ F7E1 Aacutesmall
+ F7E2 Acircumflexsmall
+ F7E3 Atildesmall
+ F7E4 Adieresissmall
+ F7E5 Aringsmall
+ F7E6 AEsmall
+ F7E7 Ccedillasmall
+ F7E8 Egravesmall
+ F7E9 Eacutesmall
+ F7EA Ecircumflexsmall
+ F7EB Edieresissmall
+ F7EC Igravesmall
+ F7ED Iacutesmall
+ F7EE Icircumflexsmall
+ F7EF Idieresissmall
+ F7F0 Ethsmall
+ F7F1 Ntildesmall
+ F7F2 Ogravesmall
+ F7F3 Oacutesmall
+ F7F4 Ocircumflexsmall
+ F7F5 Otildesmall
+ F7F6 Odieresissmall
+ F7F8 Oslashsmall
+ F7F9 Ugravesmall
+ F7FA Uacutesmall
+ F7FB Ucircumflexsmall
+ F7FC Udieresissmall
+ F7FD Yacutesmall
+ F7FE Thornsmall
+ F7FF Ydieresissmall
+ F8E5 radicalex
+ F8E6 arrowvertex
+ F8E7 arrowhorizex
+ F8E8 registersans
+ F8E9 copyrightsans
+ F8EA trademarksans
+ F8EB parenlefttp
+ F8EC parenleftex
+ F8ED parenleftbt
+ F8EE bracketlefttp
+ F8EF bracketleftex
+ F8F0 bracketleftbt
+ F8F1 bracelefttp
+ F8F2 braceleftmid
+ F8F3 braceleftbt
+ F8F4 braceex
+ F8F5 integralex
+ F8F6 parenrighttp
+ F8F7 parenrightex
+ F8F8 parenrightbt
+ F8F9 bracketrighttp
+ F8FA bracketrightex
+ F8FB bracketrightbt
+ F8FC bracerighttp
+ F8FD bracerightmid
+ F8FE bracerightbt
+ FB00 ff
+ FB01 fi
+ FB02 fl
+ FB03 ffi
+ FB04 ffl
+ FB1F afii57705
+ FB2A afii57694
+ FB2B afii57695
+ FB35 afii57723
+ FB4B afii57700
+)};
+
+
+sub CreatePostscriptEncoding
+{
+ my ($encoding) = @_;
+ my $result = "/CurrentEncoding \[\n";
+ for (my $i = 0; $i < 256; $i += 8)
+ {
+ for (my $j = 0; $j < 8; $j++)
+ {
+ my $ch;
+ Tk::catch { $ch = $encoding->decode(chr($i+$j),1) };
+ if ($@)
+ {
+ $result .= '/space';
+ }
+ else
+ {
+ my $hexcode = sprintf("%04X",ord($ch));
+ $result .= '/'.((exists $Tk::psglyphs->{$hexcode}) ? $Tk::psglyphs->{$hexcode} : 'space');
+ }
+ }
+ $result .= "\n";
+ }
+ $result .= "\] def\n";
+ return $result;
+}
+
+# precalculate entire prolog when this file is loaded
+# (to speed things up)
+$Tk::ps_preamable = "%%BeginProlog\n".
+ CreatePostscriptEncoding(Tk::SystemEncoding()). <<'END';
+50 dict begin
+% This is a standard prolog for Postscript generated by Tk's canvas
+% widget.
+% RCS: @(#) $Id: //depot/Tkutf8/Canvas/Canvas.pm#12 $
+
+% The definitions below just define all of the variables used in
+% any of the procedures here. This is needed for obscure reasons
+% explained on p. 716 of the Postscript manual (Section H.2.7,
+% "Initializing Variables," in the section on Encapsulated Postscript).
+
+/baseline 0 def
+/stipimage 0 def
+/height 0 def
+/justify 0 def
+/lineLength 0 def
+/spacing 0 def
+/stipple 0 def
+/strings 0 def
+/xoffset 0 def
+/yoffset 0 def
+/tmpstip null def
+
+
+/cstringshow {
+ {
+ dup type /stringtype eq
+ { show } { glyphshow }
+ ifelse
+ }
+ forall
+} bind def
+
+
+
+/cstringwidth {
+ 0 exch 0 exch
+ {
+ dup type /stringtype eq
+ { stringwidth } {
+ currentfont /Encoding get exch 1 exch put (\001) stringwidth
+ }
+ ifelse
+ exch 3 1 roll add 3 1 roll add exch
+ }
+ forall
+} bind def
+
+% font ISOEncode font
+% This procedure changes the encoding of a font from the default
+% Postscript encoding to current system encoding. It's typically invoked just
+% before invoking "setfont". The body of this procedure comes from
+% Section 5.6.1 of the Postscript book.
+
+/ISOEncode {
+ dup length dict begin
+ {1 index /FID ne {def} {pop pop} ifelse} forall
+ /Encoding CurrentEncoding def
+ currentdict
+ end
+
+ % I'm not sure why it's necessary to use "definefont" on this new
+ % font, but it seems to be important; just use the name "Temporary"
+ % for the font.
+
+ /Temporary exch definefont
+} bind def
+
+% StrokeClip
+%
+% This procedure converts the current path into a clip area under
+% the assumption of stroking. It's a bit tricky because some Postscript
+% interpreters get errors during strokepath for dashed lines. If
+% this happens then turn off dashes and try again.
+
+/StrokeClip {
+ {strokepath} stopped {
+ (This Postscript printer gets limitcheck overflows when) =
+ (stippling dashed lines; lines will be printed solid instead.) =
+ [] 0 setdash strokepath} if
+ clip
+} bind def
+
+% desiredSize EvenPixels closestSize
+%
+% The procedure below is used for stippling. Given the optimal size
+% of a dot in a stipple pattern in the current user coordinate system,
+% compute the closest size that is an exact multiple of the device's
+% pixel size. This allows stipple patterns to be displayed without
+% aliasing effects.
+
+/EvenPixels {
+ % Compute exact number of device pixels per stipple dot.
+ dup 0 matrix currentmatrix dtransform
+ dup mul exch dup mul add sqrt
+
+ % Round to an integer, make sure the number is at least 1, and compute
+ % user coord distance corresponding to this.
+ dup round dup 1 lt {pop 1} if
+ exch div mul
+} bind def
+
+% width height string StippleFill --
+%
+% Given a path already set up and a clipping region generated from
+% it, this procedure will fill the clipping region with a stipple
+% pattern. "String" contains a proper image description of the
+% stipple pattern and "width" and "height" give its dimensions. Each
+% stipple dot is assumed to be about one unit across in the current
+% user coordinate system. This procedure trashes the graphics state.
+
+/StippleFill {
+ % The following code is needed to work around a NeWSprint bug.
+
+ /tmpstip 1 index def
+
+ % Change the scaling so that one user unit in user coordinates
+ % corresponds to the size of one stipple dot.
+ 1 EvenPixels dup scale
+
+ % Compute the bounding box occupied by the path (which is now
+ % the clipping region), and round the lower coordinates down
+ % to the nearest starting point for the stipple pattern. Be
+ % careful about negative numbers, since the rounding works
+ % differently on them.
+
+ pathbbox
+ 4 2 roll
+ 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll
+ 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll
+
+ % Stack now: width height string y1 y2 x1 x2
+ % Below is a doubly-nested for loop to iterate across this area
+ % in units of the stipple pattern size, going up columns then
+ % across rows, blasting out a stipple-pattern-sized rectangle at
+ % each position
+
+ 6 index exch {
+ 2 index 5 index 3 index {
+ % Stack now: width height string y1 y2 x y
+
+ gsave
+ 1 index exch translate
+ 5 index 5 index true matrix tmpstip imagemask
+ grestore
+ } for
+ pop
+ } for
+ pop pop pop pop pop
+} bind def
+
+% -- AdjustColor --
+% Given a color value already set for output by the caller, adjusts
+% that value to a grayscale or mono value if requested by the CL
+% variable.
+
+/AdjustColor {
+ CL 2 lt {
+ currentgray
+ CL 0 eq {
+ .5 lt {0} {1} ifelse
+ } if
+ setgray
+ } if
+} bind def
+
+% x y strings spacing xoffset yoffset justify stipple DrawText --
+% This procedure does all of the real work of drawing text. The
+% color and font must already have been set by the caller, and the
+% following arguments must be on the stack:
+%
+% x, y - Coordinates at which to draw text.
+% strings - An array of strings, one for each line of the text item,
+% in order from top to bottom.
+% spacing - Spacing between lines.
+% xoffset - Horizontal offset for text bbox relative to x and y: 0 for
+% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.
+% yoffset - Vertical offset for text bbox relative to x and y: 0 for
+% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.
+% justify - 0 for left justification, 0.5 for center, 1 for right justify.
+% stipple - Boolean value indicating whether or not text is to be
+% drawn in stippled fashion. If text is stippled,
+% procedure StippleText must have been defined to call
+% StippleFill in the right way.
+%
+% Also, when this procedure is invoked, the color and font must already
+% have been set for the text.
+
+/DrawText {
+ /stipple exch def
+ /justify exch def
+ /yoffset exch def
+ /xoffset exch def
+ /spacing exch def
+ /strings exch def
+
+ % First scan through all of the text to find the widest line.
+
+ /lineLength 0 def
+ strings {
+ cstringwidth pop
+ dup lineLength gt {/lineLength exch def} {pop} ifelse
+ newpath
+ } forall
+
+ % Compute the baseline offset and the actual font height.
+
+ 0 0 moveto (TXygqPZ) false charpath
+ pathbbox dup /baseline exch def
+ exch pop exch sub /height exch def pop
+ newpath
+
+ % Translate coordinates first so that the origin is at the upper-left
+ % corner of the text's bounding box. Remember that x and y for
+ % positioning are still on the stack.
+
+ translate
+ lineLength xoffset mul
+ strings length 1 sub spacing mul height add yoffset mul translate
+
+ % Now use the baseline and justification information to translate so
+ % that the origin is at the baseline and positioning point for the
+ % first line of text.
+
+ justify lineLength mul baseline neg translate
+
+ % Iterate over each of the lines to output it. For each line,
+ % compute its width again so it can be properly justified, then
+ % display it.
+
+ strings {
+ dup cstringwidth pop
+ justify neg mul 0 moveto
+ stipple {
+
+
+ % The text is stippled, so turn it into a path and print
+ % by calling StippledText, which in turn calls StippleFill.
+ % Unfortunately, many Postscript interpreters will get
+ % overflow errors if we try to do the whole string at
+ % once, so do it a character at a time.
+
+ gsave
+ /char (X) def
+ {
+ dup type /stringtype eq {
+ % This segment is a string.
+ {
+ char 0 3 -1 roll put
+ currentpoint
+ gsave
+ char true charpath clip StippleText
+ grestore
+ char stringwidth translate
+ moveto
+ } forall
+ } {
+ % This segment is glyph name
+ % Temporary override
+ currentfont /Encoding get exch 1 exch put
+ currentpoint
+ gsave (\001) true charpath clip StippleText
+ grestore
+ (\001) stringwidth translate
+ moveto
+ } ifelse
+ } forall
+ grestore
+ } {cstringshow} ifelse
+ 0 spacing neg translate
+ } forall
+} bind def
+
+%%EndProlog
+END
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Canvas.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Canvas.pod
new file mode 100755
index 00000000000..0f99036bb6c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Canvas.pod
@@ -0,0 +1,2393 @@
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+=head1 NAME
+
+Tk::Canvas - Create and manipulate Canvas widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$canvas> = I<$parent>-E<gt>B<Canvas>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-background> B<-highlightthickness> B<-insertwidth> B<-state>
+B<-borderwidth> B<-insertbackground> B<-relief> B<-tile>
+B<-cursor> B<-insertborderwidth> B<-selectbackground> B<-takefocus>
+B<-highlightbackground> B<-insertofftime> B<-selectborderwidth> B<-xscrollcommand>
+B<-highlightcolor> B<-insertontime> B<-selectforeground> B<-yscrollcommand>
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<closeEnough>
+
+=item Class: B<CloseEnough>
+
+=item Switch: B<-closeenough>
+
+Specifies a floating-point value indicating how close the mouse cursor
+must be to an item before it is considered to be ``inside'' the item.
+Defaults to 1.0.
+
+=item Name: B<confine>
+
+=item Class: B<Confine>
+
+=item Switch: B<-confine>
+
+Specifies a boolean value that indicates whether or not it should be
+allowable to set the canvas's view outside the region defined by the
+B<scrollRegion> argument.
+Defaults to true, which means that the view will
+be constrained within the scroll region.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies a desired window height that the canvas widget should request from
+its geometry manager. The value may be specified in any
+of the forms described in the L<"COORDINATES"> section below.
+
+=item Name: B<scrollRegion>
+
+=item Class: B<ScrollRegion>
+
+=item Switch: B<-scrollregion>
+
+Specifies a list with four coordinates describing the left, top, right, and
+bottom coordinates of a rectangular region.
+This region is used for scrolling purposes and is considered to be
+the boundary of the information in the canvas.
+Each of the coordinates may be specified
+in any of the forms given in the L<"COORDINATES"> section below.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Modifies the default state of the canvas where I<state> may be set to one of:
+normal, disabled, or hidden. Individual canvas objects all have their own
+state option, which overrides the default state. Many options can take
+separate specifications such that the appearance of the item can be different
+in different situations. The options that start with "active" control the
+appearence when the mouse pointer is over it, while the option starting
+with "disabled" controls the appearence when the state is disabled.
+
+=item Name: B<width>
+
+=item Class: B<width>
+
+=item Switch: B<-width>
+
+Specifies a desired window width that the canvas widget should request from
+its geometry manager. The value may be specified in any
+of the forms described in the L<"COORDINATES"> section below.
+
+=item Name: B<xScrollIncrement>
+
+=item Class: B<ScrollIncrement>
+
+=item Switch: B<-xscrollincrement>
+
+Specifies an increment for horizontal scrolling, in any of the usual forms
+permitted for screen distances. If the value of this option is greater
+than zero, the horizontal view in the window will be constrained so that
+the canvas x coordinate at the left edge of the window is always an even
+multiple of B<xScrollIncrement>; furthermore, the units for scrolling
+(e.g., the change in view when the left and right arrows of a scrollbar
+are selected) will also be B<xScrollIncrement>. If the value of
+this option is less than or equal to zero, then horizontal scrolling
+is unconstrained.
+
+=item Name: B<yScrollIncrement>
+
+=item Class: B<ScrollIncrement>
+
+=item Switch: B<-yscrollincrement>
+
+Specifies an increment for vertical scrolling, in any of the usual forms
+permitted for screen distances. If the value of this option is greater
+than zero, the vertical view in the window will be constrained so that
+the canvas y coordinate at the top edge of the window is always an even
+multiple of B<yScrollIncrement>; furthermore, the units for scrolling
+(e.g., the change in view when the top and bottom arrows of a scrollbar
+are selected) will also be B<yScrollIncrement>. If the value of
+this option is less than or equal to zero, then vertical scrolling
+is unconstrained.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Canvas> method creates a new window (given
+by the $canvas argument) and makes it into a canvas widget.
+Additional options, described above, may be specified on the
+command line or in the option database
+to configure aspects of the canvas such as its colors and 3-D relief.
+The B<canvas> command returns its
+$canvas argument. At the time this command is invoked,
+there must not exist a window named $canvas, but
+$canvas's parent must exist.
+
+Canvas widgets implement structured graphics.
+A canvas displays any number of I<items>, which may be things like
+rectangles, circles, lines, and text.
+Items may be manipulated (e.g. moved or re-colored) and
+L<callbacks|Tk::callbacks> may
+be associated with items in much the same way that the L<bind|Tk::bind>
+method allows callbacks to be bound to widgets. For example,
+a particular callback may be associated with the B<E<lt>Button-1E<gt>> event
+so that the callback is invoked whenever button 1 is pressed with
+the mouse cursor over an item.
+This means that items in a canvas can have behaviors defined by
+the Callbacks bound to them.
+
+=head1 DISPLAY LIST
+
+The items in a canvas are ordered for purposes of display,
+with the first item in the display list being displayed
+first, followed by the next item in the list, and so on.
+Items later in the display list obscure those that are
+earlier in the display list and are sometimes referred to
+as being I<``on top''> of earlier items.
+When a new item is created it is placed at the end of the
+display list, on top of everything else.
+Widget methods may be used to re-arrange the order of the
+display list.
+
+Window items are an exception to the above rules. The underlying
+window systems require them always to be drawn on top of other items.
+In addition, the stacking order of window items
+is not affected by any of the canvas methods; you must use
+the L<raise|Tk::Widget> and L<lower|Tk::Widget> Tk widget methods instead.
+
+=head1 ITEM IDS AND TAGS
+
+Items in a canvas widget may be named in either of two ways:
+by id or by tag.
+Each item has a unique identifying number which is assigned to
+that item when it is created. The id of an item never changes
+and id numbers are never re-used within the lifetime of a
+canvas widget.
+
+Each item may also have any number of I<tags> associated
+with it. A tag is just a string of characters, and it may
+take any form except that of an integer.
+For example, ``x123'' is OK but ``123'' isn't.
+The same tag may be associated with many different items.
+This is commonly done to group items in various interesting
+ways; for example, all selected items might be given the
+tag ``selected''.
+
+The tag B<all> is implicitly associated with every item
+in the canvas; it may be used to invoke operations on
+all the items in the canvas.
+
+The tag B<current> is managed automatically by Tk;
+it applies to the I<current item>, which is the
+topmost item whose drawn area covers the position of
+the mouse cursor.
+If the mouse is not in the canvas widget or is not over
+an item, then no item has the B<current> tag.
+
+When specifying items in canvas methods, if the
+specifier is an integer then it is assumed to refer to
+the single item with that id.
+If the specifier is not an integer, then it is assumed to
+refer to all of the items in the canvas that have a tag
+matching the specifier.
+The symbol I<tagOrId> is used below to indicate that
+an argument specifies either an id that selects a single
+item or a tag that selects zero or more items.
+
+I<tagOrId> may contain a logical expressions of
+tags by using operators: 'E<amp>E<amp>', '||', '^' '!', and parenthezised
+subexpressions. For example:
+
+$c-E<gt>find('withtag', '(aE<amp>E<amp>!b)|(!aE<amp>E<amp>b)');
+
+or equivalently:
+
+$c-E<gt>find('withtag', 'a^b');
+
+will find only those items with either "a" or "b" tags, but not both.
+
+Some methods only operate on a single item at a
+time; if I<tagOrId> is specified in a way that
+names multiple items, then the normal behavior is for
+the methods is to use the first (lowest) of these items in
+the display list that is suitable for the method.
+Exceptions are noted in the method descriptions
+below.
+
+=head1 COORDINATES
+
+All coordinates related to canvases are stored as floating-point
+numbers.
+Coordinates and distances are specified in screen units,
+which are floating-point numbers optionally followed
+by one of several letters.
+If no letter is supplied then the distance is in pixels.
+If the letter is B<m> then the distance is in millimeters on
+the screen; if it is B<c> then the distance is in centimeters;
+B<i> means inches, and B<p> means printers points (1/72 inch).
+Larger y-coordinates refer to points lower on the screen; larger
+x-coordinates refer to points farther to the right.
+
+=head1 TRANSFORMATIONS
+
+Normally the origin of the canvas coordinate system is at the
+upper-left corner of the window containing the canvas.
+It is possible to adjust the origin of the canvas
+coordinate system relative to the origin of the window using the
+B<xview> and B<yview> methods; this is typically used
+for scrolling.
+Canvases do not support scaling or rotation of the canvas coordinate
+system relative to the window coordinate system.
+
+Individual items may be moved or scaled using methods
+described below, but they may not be rotated.
+
+=head1 INDICES
+
+Text items support the notion of an I<index> for identifying
+particular positions within the item.
+
+Indices are used for methods such as inserting text, deleting
+a range of characters, and setting the insertion cursor position.
+An index may be specified in any of a number of ways, and
+different types of items may support different forms for
+specifying indices.
+
+In a similar fashion, line and polygon items support I<index> for
+identifying, inserting and deleting subsets of their coordinates.
+Indices are used for commands such as inserting or deleting
+a range of characters or coordinates, and setting the insertion
+cursor position. An index may be specified in any of a number
+of ways, and different types of items may support different forms
+for specifying indices.
+
+Text items support the following forms for an index; if you
+define new types of text-like items, it would be advisable to
+support as many of these forms as practical.
+Note that it is possible to refer to the character just after
+the last one in the text item; this is necessary for such
+tasks as inserting new text at the end of the item.
+Lines and Polygons don't support the insertion cursor
+and the selection. Their indices are supposed to be even
+always, because coordinates always appear in pairs.
+
+=over 4
+
+=item I<number>
+
+A decimal number giving the position of the desired character
+within the text item.
+0 refers to the first character, 1 to the next character, and
+so on. If indexes are odd for lines and polygons, they will be
+automatically decremented by one.
+A number less than 0 is treated as if it were zero, and a
+number greater than the length of the text item is treated
+as if it were equal to the length of the text item. For
+polygons, numbers less than 0 or greater then the length
+of the coordinate list will be adjusted by adding or substracting
+the length until the result is between zero and the length,
+inclusive.
+
+=item B<end>
+
+Refers to the character or coordinate just after the last one
+in the item (same as the number of characters or coordinates
+in the item).
+
+=item B<insert>
+
+Refers to the character just before which the insertion cursor
+is drawn in this item. Not valid for lines and polygons.
+
+=item B<sel.first>
+
+Refers to the first selected character in the item.
+If the selection isn't in this item then this form is illegal.
+
+=item B<sel.last>
+
+Refers to the last selected character in the item.
+If the selection isn't in this item then this form is illegal.
+
+=item B<[>I<x,y>B<]>
+
+Refers to the character or coordinate at the point given by I<x> and
+I<y>, where I<x> and I<y> are specified in the coordinate
+system of the canvas.
+If I<x> and I<y> lie outside the coordinates covered by the
+text item, then they refer to the first or last character in the
+line that is closest to the given point.
+The Tcl string form "@x,y" is also allowed.
+
+=back
+
+=head1 DASH PATTERNS
+
+Many items support the notion of an dash pattern for outlines.
+
+The first possible syntax is a list of integers. Each element
+represents the number of pixels of a line segment. Only the odd
+segments are drawn using the "outline" color. The other segments
+are drawn transparent.
+
+The second possible syntax is a character list containing only
+5 possible characters B<[.,-_ ]>, with the first 4 characters
+producing a segment of length 1 to 4, respectively, followed
+by a transparent segment of length 2. The space can be used
+repeatedly to enlarge the space between other line elements
+by 1, and can not occur as the first position in the string.
+The main difference of this syntax with the previous one is
+that it it shape-conserving. This means that all values in the dash
+list will be multiplied by the line width before display. This
+assures that "." will always be displayed as a dot and "-"
+always as a dash regardless of the line width.
+
+Some examples, for a line width of 2:
+
+ -dash . = -dash [2,4]
+ -dash - = -dash [6,4]
+ -dash -. = -dash [6,4,2,4]
+ -dash -.. = -dash [6,4,2,4,2,4]
+ -dash '. ' = -dash [2,8]
+ -dash ',' = -dash [4,4]
+
+On systems where only a limited set of dash patterns is available,
+the dash pattern will be displayed as the closest available dash
+pattern. For example, on Windows only the first 4 of the
+above examples are available. The last 2 examples will be
+displayed identically as the first one.
+
+=head1 WIDGET METHODS
+
+The B<Canvas> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for canvas widgets:
+
+=over 4
+
+=item I<$canvas>-E<gt>B<addtag>(I<tag, searchSpec, >?I<arg, arg, ...>?)
+
+For each item that meets the constraints specified by
+I<searchSpec> and the I<arg>s, add
+I<tag> to the list of tags associated with the item if it
+isn't already present on that list.
+It is possible that no items will satisfy the constraints
+given by I<searchSpec> and I<arg>s, in which case the
+method has no effect.
+This command returns an empty string as result.
+I<SearchSpec> and I<arg>'s may take any of the following
+forms:
+
+=over 8
+
+=item B<above >I<tagOrId>
+
+Selects the item just after (above) the one given by I<tagOrId>
+in the display list.
+If I<tagOrId> denotes more than one item, then the last (topmost)
+of these items in the display list is used.
+
+=item B<all>
+
+Selects all the items in the canvas.
+
+=item B<below >I<tagOrId>
+
+Selects the item just before (below) the one given by I<tagOrId>
+in the display list.
+If I<tagOrId> denotes more than one item, then the first (lowest)
+of these items in the display list is used.
+
+=item B<closest >I<x y >?I<halo>? ?I<start>?
+
+Selects the item closest to the point given by I<x> and I<y>.
+If more than one item is at the same closest distance (e.g. two
+items overlap the point), then the top-most of these items (the
+last one in the display list) is used.
+If I<halo> is specified, then it must be a non-negative
+value.
+Any item closer than I<halo> to the point is considered to
+overlap it.
+The I<start> argument may be used to step circularly through
+all the closest items.
+If I<start> is specified, it names an item using a tag or id
+(if by tag, it selects the first item in the display list with
+the given tag).
+Instead of selecting the topmost closest item, this form will
+select the topmost closest item that is below I<start> in
+the display list; if no such item exists, then the selection
+behaves as if the I<start> argument had not been specified.
+
+=item B<enclosed> I<x1> I<y1> I<x2> I<y2>
+
+Selects all the items completely enclosed within the rectangular
+region given by I<x1>, I<y1>, I<x2>, and I<y2>.
+I<X1> must be no greater then I<x2> and I<y1> must be
+no greater than I<y2>.
+
+=item B<overlapping> I<x1> I<y1> I<x2> I<y2>
+
+Selects all the items that overlap or are enclosed within the
+rectangular region given by I<x1>, I<y1>, I<x2>,
+and I<y2>.
+I<X1> must be no greater then I<x2> and I<y1> must be
+no greater than I<y2>.
+
+=item B<withtag >I<tagOrId>
+
+Selects all the items given by I<tagOrId>.
+
+=back
+
+=item I<$canvas>-E<gt>B<bbox>(I<tagOrId, >?I<tagOrId, tagOrId, ...>?)
+
+Returns a list with four elements giving an approximate bounding box
+for all the items named by the I<tagOrId> arguments.
+The list has the form ``I<x1 y1 x2 y2>'' such that the drawn
+areas of all the named elements are within the region bounded by
+I<x1> on the left, I<x2> on the right, I<y1> on the top,
+and I<y2> on the bottom.
+The return value may overestimate the actual bounding box by
+a few pixels.
+If no items match any of the I<tagOrId> arguments or if the
+matching items have empty bounding boxes (i.e. they have nothing
+to display)
+then an empty string is returned.
+
+=item I<$canvas>-E<gt>B<bind>(I<tagOrId>?, I<sequence>? ?,I<callback>?)
+
+This method associates I<callback> with all the items given by
+I<tagOrId> such that whenever the event sequence given by
+I<sequence> occurs for one of the items the callback will
+be invoked.
+This method is similar to the B<bind> method except that
+it operates on items in a canvas rather than entire widgets.
+See L<Tk::bind> for complete details
+on the syntax of I<sequence> and the substitutions performed
+on I<callback> before invoking it.
+If all arguments are specified then a new binding is created, replacing
+any existing binding for the same I<sequence> and I<tagOrId>
+(if the first character of I<command> is ``+'' then I<command>
+augments an existing binding rather than replacing it).
+In this case the return value is an empty string.
+If I<callback> is omitted then the method returns the I<callback>
+associated with I<tagOrId> and I<sequence> (an error occurs
+if there is no such binding).
+If both I<callback> and I<sequence> are omitted then the method
+returns a list of all the sequences for which bindings have been
+defined for I<tagOrId>.
+
+=over 8
+
+The only events for which bindings may be specified are those related to
+the mouse and keyboard (such as B<Enter>, B<Leave>,
+B<ButtonPress>, B<Motion>, and B<KeyPress>) or virtual events.
+The handling of events in canvases uses the current item defined
+in L<"ITEM IDS AND TAGS"> above. B<Enter> and B<Leave> events trigger for an
+item when it becomes the current item or ceases to be the current item;
+note that these events are different than B<Enter> and B<Leave>
+events for windows. Mouse-related events are directed to the current
+item, if any. Keyboard-related events are directed to the focus item, if
+any (see the L<focus|/focus> method below for more on this). If a
+virtual event is used in a binding, that binding can trigger only if the
+virtual event is defined by an underlying mouse-related or
+keyboard-related event.
+
+It is possible for multiple bindings to match a particular event.
+This could occur, for example, if one binding is associated with the
+item's id and another is associated with one of the item's tags.
+When this occurs, all of the matching bindings are invoked.
+A binding associated with the B<all> tag is invoked first,
+followed by one binding for each of the item's tags (in order),
+followed by a binding associated with the item's id.
+If there are multiple matching bindings for a single tag,
+then only the most specific binding is invoked.
+A B<continue> in a callback terminates that
+subroutine, and a B<break> method terminates that subroutine
+and skips any remaining callbacks for the event, just as for the
+B<bind> method.
+
+If bindings have been created for a canvas window using the B<CanvasBind>
+method, then they are invoked in addition to bindings created for
+the canvas's items using the B<bind> method.
+The bindings for items will be invoked before any of the bindings
+for the window as a whole.
+
+=back
+
+=item I<$canvas>-E<gt>B<canvasx>(I<screenx>?, I<gridspacing>?)
+
+Given a window x-coordinate in the canvas I<screenx>, this method returns
+the canvas x-coordinate that is displayed at that location.
+If I<gridspacing> is specified, then the canvas coordinate is
+rounded to the nearest multiple of I<gridspacing> units.
+
+=item I<$canvas>-E<gt>B<canvasy>(I<screeny, >?I<gridspacing>?)
+
+Given a window y-coordinate in the canvas I<screeny> this method returns
+the canvas y-coordinate that is displayed at that location.
+If I<gridspacing> is specified, then the canvas coordinate is
+rounded to the nearest multiple of I<gridspacing> units.
+
+=item I<$canvas>-E<gt>B<coords>(I<tagOrId >?I<x0,y0 ...>?)
+
+Query or modify the coordinates that define an item.
+If no coordinates are specified, this method returns a list
+whose elements are the coordinates of the item named by
+I<tagOrId>.
+If coordinates are specified, then they replace the current
+coordinates for the named item.
+If I<tagOrId> refers to multiple items, then
+the first one in the display list is used.
+
+=item I<$canvas>-E<gt>B<create>(I<type, x, y, >?I<x, y, ...>?, ?I<option, value, ...>?)
+
+Create a new item in I<$canvas> of type I<type>.
+The exact format of the arguments after B<type> depends
+on B<type>, but usually they consist of the coordinates for
+one or more points, followed by specifications for zero or
+more item options.
+See the subsections on individual item types below for more
+on the syntax of this method.
+This method returns the id for the new item.
+
+=item I<$canvas>-E<gt>B<dchars>(I<tagOrId, first, >?I<last>?)
+
+For each item given by I<tagOrId>, delete the characters, or coordinates,
+in the range given by I<first> and I<last>, inclusive.
+If some of the items given by I<tagOrId> don't support
+Text items interpret I<first> and I<last> as indices to a character,
+line and polygon items interpret them indices to a coordinate (an x,y pair).
+within the item(s) as described in L<"INDICES"> above.
+If I<last> is omitted, it defaults to I<first>.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<delete>(?I<tagOrId, tagOrId, ...>?)
+
+Delete each of the items given by each I<tagOrId>, and return
+an empty string.
+
+=item I<$canvas>-E<gt>B<dtag>(I<tagOrId, >?I<tagToDelete>?)
+
+For each of the items given by I<tagOrId>, delete the
+tag given by I<tagToDelete> from the list of those
+associated with the item.
+If an item doesn't have the tag I<tagToDelete> then
+the item is unaffected by the method.
+If I<tagToDelete> is omitted then it defaults to I<tagOrId>.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<find>(I<searchCommand, >?I<arg, arg, ...>?)
+
+This method returns a list consisting of all the items that
+meet the constraints specified by I<searchCommand> and
+I<arg>'s.
+I<SearchCommand> and I<args> have any of the forms
+accepted by the B<addtag> method.
+The items are returned in stacking order, with the lowest item first.
+
+=item focus
+
+=item I<$canvas>-E<gt>B<focus>(?I<tagOrId>?)
+
+Set the keyboard focus for the canvas widget to the item given by
+I<tagOrId>.
+If I<tagOrId> refers to several items, then the focus is set
+to the first such item in the display list that supports the
+insertion cursor.
+If I<tagOrId> doesn't refer to any items, or if none of them
+support the insertion cursor, then the focus isn't changed.
+If I<tagOrId> is an empty
+string, then the focus item is reset so that no item has the focus.
+If I<tagOrId> is not specified then the method returns the
+id for the item that currently has the focus, or an empty string
+if no item has the focus.
+
+=over 8
+
+Once the focus has been set to an item, the item will display
+the insertion cursor and all keyboard events will be directed
+to that item.
+The focus item within a canvas and the focus window on the
+screen (set with the B<focus> method) are totally independent:
+a given item doesn't actually have the input focus unless (a)
+its canvas is the focus window and (b) the item is the focus item
+within the canvas.
+In most cases it is advisable to follow the B<focus> widget
+method with the B<CanvasFocus> method to set the focus window to
+the canvas (if it wasn't there already).
+
+=back
+
+=item I<$canvas>-E<gt>B<gettags>(I<tagOrId>)
+
+Return a list whose elements are the tags associated with the
+item given by I<tagOrId>.
+If I<tagOrId> refers to more than one item, then the tags
+are returned from the first such item in the display list.
+If I<tagOrId> doesn't refer to any items, or if the item
+contains no tags, then an empty string is returned.
+
+=item I<$canvas>-E<gt>B<icursor>(I<tagOrId, index>)
+
+Set the position of the insertion cursor for the item(s) given by I<tagOrId>
+to just before the character whose position is given by I<index>.
+If some or all of the items given by I<tagOrId> don't support
+an insertion cursor then this method has no effect on them.
+See L<"INDICES"> above for a description of the
+legal forms for I<index>.
+Note: the insertion cursor is only displayed in an item if
+that item currently has the keyboard focus (see the widget
+method B<focus>, below), but the cursor position may
+be set even when the item doesn't have the focus.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<index>(I<tagOrId, index>)
+
+This method returns a decimal string giving the numerical index
+within I<tagOrId> corresponding to I<index>.
+I<Index> gives a textual description of the desired position
+as described in L<"INDICES"> above.
+Text items interpret I<index> as an index to a character,
+line and polygon items interpret it as an index to a coordinate (an x,y pair).
+The return value is guaranteed to lie between 0 and the number
+of characters, or coordinates, within the item, inclusive.
+If I<tagOrId> refers to multiple items, then the index
+is processed in the first of these items that supports indexing
+operations (in display list order).
+
+=item I<$canvas>-E<gt>B<insert>(I<tagOrId, beforeThis, string>)
+
+For each of the items given by I<tagOrId>, if the item supports
+text or coordinate, insertion then I<string> is inserted into the item's
+text just before the character, or coordinate, whose index is I<beforeThis>.
+Text items interpret I<beforethis> as an index to a character,
+line and polygon items interpret it as an index to a coordinate (an x,y pair).
+For lines and polygons the I<string> must be a valid coordinate
+sequence.
+See L<"INDICES"> above for information about the forms allowed
+for I<beforeThis>.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<itemcget>(I<tagOrId, >I<option>)
+
+Returns the current value of the configuration option for the
+item given by I<tagOrId> whose name is I<option>.
+This method is similar to the L<cget|Tk::option> method except that
+it applies to a particular item rather than the widget as a whole.
+I<Option> may have any of the values accepted by the B<create>
+method when the item was created.
+If I<tagOrId> is a tag that refers to more than one item,
+the first (lowest) such item is used.
+
+=item I<$canvas>-E<gt>B<itemconfigure>(I<tagOrId, >?I<option>?, ?I<value>?, ?I<option, value, ...>?)
+
+This method is similar to the L<configure|Tk::option> method except
+that it modifies item-specific options for the items given by
+I<tagOrId> instead of modifying options for the overall
+canvas widget.
+If no I<option> is specified, returns a list describing all of
+the available options for the first item given by I<tagOrId>
+(see L<Tk::options> for
+information on the format of this list). If I<option> is specified
+with no I<value>, then the method returns a list describing the
+one named option (this list will be identical to the corresponding
+sublist of the value returned if no I<option> is specified). If
+one or more I<option-value> pairs are specified, then the method
+modifies the given widget option(s) to have the given value(s) in
+each of the items given by I<tagOrId>; in
+this case the method returns an empty string.
+The I<option>s and I<value>s are the same as those permissible
+in the B<create> method when the item(s) were created;
+see the sections describing individual item types below for details
+on the legal options.
+
+=item I<$canvas>-E<gt>B<lower>(I<tagOrId, >?I<belowThis>?)
+
+Move all of the items given by I<tagOrId> to a new position
+in the display list just before the item given by I<belowThis>.
+If I<tagOrId> refers to more than one item then all are moved
+but the relative order of the moved items will not be changed.
+I<BelowThis> is a tag or id; if it refers to more than one
+item then the first (lowest) of these items in the display list is used
+as the destination location for the moved items.
+Note: this method has no effect on window items. Window items always
+obscure other item types, and the stacking order of window items is
+determined by the B<raise> and B<lower> methods of the widget, not the
+B<raise> and B<lower> methods for canvases.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<move>(I<tagOrId, xAmount, yAmount>)
+
+Move each of the items given by I<tagOrId> in the canvas coordinate
+space by adding I<xAmount> to the x-coordinate of each point
+associated with the item and I<yAmount> to the y-coordinate of
+each point associated with the item.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<postscript>(?I<option, value, option, value, ...>?)
+
+Generate a Postscript representation for part or all of the canvas.
+If the B<-file> option is specified then the Postscript is written
+to a file and an empty string is returned; otherwise the Postscript
+is returned as the result of the method.
+If the interpreter that owns the canvas is marked as safe, the operation
+will fail because safe interpreters are not allowed to write files.
+If the B<-channel> option is specified, the argument denotes the name
+of a channel already opened for writing. The Postscript is written to
+that channel, and the channel is left open for further writing at the end
+of the operation.
+The Postscript is created in Encapsulated Postscript form using
+version 3.0 of the Document Structuring Conventions.
+Note: by default Postscript is only generated for information that
+appears in the canvas's window on the screen. If the canvas is
+freshly created it may still have its initial size of 1x1 pixel
+so nothing will appear in the Postscript. To get around this problem
+either invoke the B<update> method to wait for the canvas window
+to reach its final size, or else use the B<-width> and B<-height>
+options to specify the area of the canvas to print.
+The I<option>-I<value> argument pairs provide additional
+information to control the generation of Postscript. The following
+options are supported:
+
+=over 8
+
+=item B<-colormap> =E<gt> I<hashRef>
+
+I<HashRef> must be a reference to a hash variable or an anonymous hash
+that specifies a color mapping to use in the Postscript.
+Each value of the hash must consist of Postscript
+code to set a particular color value (e.g. ``B<1.0 1.0 0.0 setrgbcolor>'').
+When outputting color information in the Postscript, Tk checks
+to see if there is a key in the hash with the same
+name as the color.
+If so, Tk uses the value of the element as the Postscript method
+to set the color.
+If this option hasn't been specified, or if there isn't a key
+in I<hashRef> for a given color, then Tk uses the red, green,
+and blue intensities from the X color.
+
+=item B<-colormode> =E<gt> I<mode>
+
+Specifies how to output color information. I<Mode> must be either
+B<color> (for full color output), B<gray> (convert all colors
+to their gray-scale equivalents) or B<mono> (convert all colors
+to black or white).
+
+=item B<-file> =E<gt> I<fileName>
+
+Specifies the name of the file in which to write the Postscript.
+If this option isn't specified then the Postscript is returned as the
+result of the method instead of being written to a file.
+
+=item B<-fontmap> =E<gt> I<hashRef>
+
+I<HashRef> must be a reference to a hash variable or an anonymous hash
+that specifies a font mapping to use in the Postscript.
+Each value of the hash must consist of an array reference with
+two elements, which are the name and point size of a Postscript font.
+When outputting Postscript commands for a particular font, Tk
+checks to see if I<hashRef> contains a value with the same
+name as the font.
+If there is such an element, then the font information contained in
+that element is used in the Postscript.
+Otherwise Tk attempts to guess what Postscript font to use.
+Tk's guesses generally only work for well-known fonts such as
+Times and Helvetica and Courier, and only if the X font name does not
+omit any dashes up through the point size.
+For example, B<-*-Courier-Bold-R-Normal--*-120-*> will work but
+B<*Courier-Bold-R-Normal*120*> will not; Tk needs the dashes to
+parse the font name).
+
+=item B<-height> =E<gt> I<size>
+
+Specifies the height of the area of the canvas to print.
+Defaults to the height of the canvas window.
+
+=item B<-pageanchor> =E<gt> I<anchor>
+
+Specifies which point of the printed area of the canvas should appear over
+the positioning point on the page (which is given by the B<-pagex>
+and B<-pagey> options).
+For example, B<-pageanchor>=>B<n> means that the top center of the
+area of the canvas being printed (as it appears in the canvas window)
+should be over the positioning point. Defaults to B<center>.
+
+=item B<-pageheight> =E<gt> I<size>
+
+Specifies that the Postscript should be scaled in both x and y so
+that the printed area is I<size> high on the Postscript page.
+I<Size> consists of a floating-point number followed by
+B<c> for centimeters, B<i> for inches, B<m> for millimeters,
+or B<p> or nothing for printer's points (1/72 inch).
+Defaults to the height of the printed area on the screen.
+If both B<-pageheight> and B<-pagewidth> are specified then
+the scale factor from B<-pagewidth> is used (non-uniform scaling
+is not implemented).
+
+=item B<-pagewidth> =E<gt> I<size>
+
+Specifies that the Postscript should be scaled in both x and y so
+that the printed area is I<size> wide on the Postscript page.
+I<Size> has the same form as for B<-pageheight>.
+Defaults to the width of the printed area on the screen.
+If both B<-pageheight> and B<-pagewidth> are specified then
+the scale factor from B<-pagewidth> is used (non-uniform scaling
+is not implemented).
+
+=item B<-pagex> =E<gt> I<position>
+
+I<Position> gives the x-coordinate of the positioning point on
+the Postscript page, using any of the forms allowed for B<-pageheight>.
+Used in conjunction with the B<-pagey> and B<-pageanchor> options
+to determine where the printed area appears on the Postscript page.
+Defaults to the center of the page.
+
+=item B<-pagey> =E<gt> I<position>
+
+I<Position> gives the y-coordinate of the positioning point on
+the Postscript page, using any of the forms allowed for B<-pageheight>.
+Used in conjunction with the B<-pagex> and B<-pageanchor> options
+to determine where the printed area appears on the Postscript page.
+Defaults to the center of the page.
+
+=item B<-rotate> =E<gt> I<boolean>
+
+I<Boolean> specifies whether the printed area is to be rotated 90
+degrees.
+In non-rotated output the x-axis of the printed area runs along
+the short dimension of the page (``portrait'' orientation);
+in rotated output the x-axis runs along the long dimension of the
+page (``landscape'' orientation).
+Defaults to non-rotated.
+
+=item B<-width> =E<gt> I<size>
+
+Specifies the width of the area of the canvas to print.
+Defaults to the width of the canvas window.
+
+=item B<-x> => I<position>
+
+Specifies the x-coordinate of the left edge of the area of the
+canvas that is to be printed, in canvas coordinates, not window
+coordinates.
+Defaults to the coordinate of the left edge of the window.
+
+=item B<-y> => I<position>
+
+Specifies the y-coordinate of the top edge of the area of the
+canvas that is to be printed, in canvas coordinates, not window
+coordinates.
+Defaults to the coordinate of the top edge of the window.
+
+=back
+
+=item I<$canvas>-E<gt>B<raise>(I<tagOrId, >?I<aboveThis>?)
+
+Move all of the items given by I<tagOrId> to a new position
+in the display list just after the item given by I<aboveThis>.
+If I<tagOrId> refers to more than one item then all are moved
+but the relative order of the moved items will not be changed.
+I<AboveThis> is a tag or id; if it refers to more than one
+item then the last (topmost) of these items in the display list is used
+as the destination location for the moved items.
+Note: this method has no effect on window items. Window items always
+obscure other item types, and the stacking order of window items is
+determined by the B<raise> and B<lower> widget commands, not the
+B<raise> and B<lower> methods for canvases.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<scale>(I<tagOrId, xOrigin, yOrigin, xScale, yScale>)
+
+Rescale all of the items given by I<tagOrId> in canvas coordinate
+space.
+I<XOrigin> and I<yOrigin> identify the origin for the scaling
+operation and I<xScale> and I<yScale> identify the scale
+factors for x- and y-coordinates, respectively (a scale factor of
+1.0 implies no change to that coordinate).
+For each of the points defining each item, the x-coordinate is
+adjusted to change the distance from I<xOrigin> by a factor
+of I<xScale>.
+Similarly, each y-coordinate is adjusted to change the distance
+from I<yOrigin> by a factor of I<yScale>.
+This method returns an empty string.
+
+=item I<$canvas>-E<gt>B<scan>(I<option, args>)
+
+This method is used to implement scanning on canvases. It has
+two forms, depending on I<option>:
+
+=over 8
+
+=item I<$canvas>-E<gt>B<scanMark>(I<x, y>)
+
+Records I<x> and I<y> and the canvas's current view; used
+in conjunction with later B<scanDragto> method.
+Typically this method is associated with a mouse button press in
+the widget and I<x> and I<y> are the coordinates of the
+mouse. It returns an empty string.
+
+=item I<$canvas>-E<gt>B<scanDragto>(I<x, y, ?gain?>.)
+
+This method computes the difference between its I<x> and I<y>
+arguments (which are typically mouse coordinates) and the I<x> and
+I<y> arguments to the last B<scanMark> method for the widget.
+It then adjusts the view by 10 times the
+difference in coordinates. This method is typically associated
+It then adjusts the view by I<gain> times the
+difference in coordinates, where I<gain> defaults to 10.
+This command is typically associated
+with mouse motion events in the widget, to produce the effect of
+dragging the canvas at high speed through its window. The return
+value is an empty string.
+
+=back
+
+=item I<$canvas>-E<gt>B<select>(I<option, >?I<tagOrId, arg>?)
+
+Manipulates the selection in one of several ways, depending on
+I<option>.
+The method may take any of the forms described below.
+In all of the descriptions below, I<tagOrId> must refer to
+an item that supports indexing and selection; if it refers to
+multiple items then the first of
+these that supports indexing and the selection is used.
+I<Index> gives a textual description of a position
+within I<tagOrId>, as described in L<"INDICES"> above.
+
+=over 8
+
+=item I<$canvas>-E<gt>B<selectAdjust>(I<tagOrId, index>)
+
+Locate the end of the selection in I<tagOrId> nearest
+to the character given by I<index>, and adjust that
+end of the selection to be at I<index> (i.e. including
+but not going beyond I<index>).
+The other end of the selection is made the anchor point
+for future B<selectTo> method calls.
+If the selection isn't currently in I<tagOrId> then
+this method behaves the same as the B<selectTo> widget
+method.
+Returns an empty string.
+
+=item I<$canvas>-E<gt>B<selectClear>
+
+Clear the selection if it is in this widget.
+If the selection isn't in this widget then the method
+has no effect.
+Returns an empty string.
+
+=item I<$canvas>-E<gt>B<selectFrom>(I<tagOrId, index>)
+
+Set the selection anchor point for the widget to be just
+before the character
+given by I<index> in the item given by I<tagOrId>.
+This method doesn't change the selection; it just sets
+the fixed end of the selection for future B<selectTo>
+method calls.
+Returns an empty string.
+
+=item I<$canvas>-E<gt>B<selectItem>
+
+Returns the id of the selected item, if the selection is in an
+item in this canvas.
+If the selection is not in this canvas then an empty string
+is returned.
+
+=item I<$canvas>-E<gt>B<selectTo>(I<tagOrId, index>)
+
+Set the selection to consist of those characters of I<tagOrId>
+between the selection anchor point and
+I<index>.
+The new selection will include the character given by I<index>;
+it will include the character given by the anchor point only if
+I<index> is greater than or equal to the anchor point.
+The anchor point is determined by the most recent B<selectAdjust>
+or B<selectFrom> method calls for this widget.
+If the selection anchor point for the widget isn't currently in
+I<tagOrId>, then it is set to the same character given
+by I<index>.
+Returns an empty string.
+
+=back
+
+=item I<$canvas>-E<gt>B<type>(I<tagOrId>)
+
+Returns the type of the item given by I<tagOrId>, such as
+B<rectangle> or B<text>.
+If I<tagOrId> refers to more than one item, then the type
+of the first item in the display list is returned.
+If I<tagOrId> doesn't refer to any items at all then
+an empty string is returned.
+
+=item I<$canvas>-E<gt>B<xview>(?I<args>?)
+
+This method is used to query and change the horizontal position of the
+information displayed in the canvas's window.
+It can take any of the following forms:
+
+=over 8
+
+=item I<$canvas>-E<gt>B<xview>
+
+Returns a list containing two elements.
+Each element is a real fraction between 0 and 1; together they describe
+the horizontal span that is visible in the window.
+For example, if the first element is .2 and the second element is .6,
+20% of the canvas's area (as defined by the B<-scrollregion> option)
+is off-screen to the left, the middle 40% is visible
+in the window, and 40% of the canvas is off-screen to the right.
+These are the same values passed to scrollbars via the B<-xscrollcommand>
+option.
+
+=item I<$canvas>-E<gt>B<xviewMoveto>(I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the
+total width of the canvas is off-screen to the left.
+I<Fraction> must be a fraction between 0 and 1.
+
+=item I<$canvas>-E<gt>B<xviewScroll>(I<number, what>)
+
+This method shifts the view in the window left or right according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages> or an abbreviation
+of one of these.
+If I<what> is B<units>, the view adjusts left or right in units
+of the B<xScrollIncrement> option, if it is greater than zero,
+or in units of one-tenth the window's width otherwise.
+If I<what is >B<pages> then the view
+adjusts in units of nine-tenths the window's width.
+If I<number> is negative then information farther to the left
+becomes visible; if it is positive then information farther to the right
+becomes visible.
+
+=back
+
+=item I<$canvas>-E<gt>B<yview>(I<?args>?)
+
+This method is used to query and change the vertical position of the
+information displayed in the canvas's window.
+It can take any of the following forms:
+
+=over 8
+
+=item I<$canvas>-E<gt>B<yview>
+
+Returns a list containing two elements.
+Each element is a real fraction between 0 and 1; together they describe
+the vertical span that is visible in the window.
+For example, if the first element is .6 and the second element is 1.0,
+the lowest 40% of the canvas's area (as defined by the B<-scrollregion>
+option) is visible in the window.
+These are the same values passed to scrollbars via the B<-yscrollcommand>
+option.
+
+=item I<$canvas>-E<gt>B<yviewMoveto>(I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the canvas's
+area is off-screen to the top.
+I<Fraction> is a fraction between 0 and 1.
+
+=item I<$canvas>-E<gt>B<yviewScroll>(I<number, what>)
+
+This method adjusts the view in the window up or down according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages>.
+If I<what> is B<units>, the view adjusts up or down in units
+of the B<yScrollIncrement> option, if it is greater than zero,
+or in units of one-tenth the window's height otherwise.
+If I<what> is B<pages> then
+the view adjusts in units of nine-tenths the window's height.
+If I<number> is negative then higher information becomes
+visible; if it is positive then lower information
+becomes visible.
+
+=back
+
+=back
+
+=head1 OVERVIEW OF ITEM TYPES
+
+The sections below describe the various types of items supported
+by canvas widgets. Each item type is characterized by two things:
+first, the form of the B<create> method used to create
+instances of the type; and second, a set of configuration options
+for items of that type, which may be used in the
+B<create> and B<itemconfigure> methods.
+Most items don't support indexing or selection or the methods
+related to them, such as B<index> and B<insert>.
+Where items do support these facilities, it is noted explicitly
+in the descriptions below.
+At present, text, line and polygon items provide this support.
+For lines and polygons the indexing facility is used to manipulate
+the coordinates of the item.
+
+=head1 ARC ITEMS
+
+Items of type B<arc> appear on the display as arc-shaped regions.
+An arc is a section of an oval delimited by two angles (specified
+by the B<-start> and B<-extent> options) and displayed in
+one of several ways (specified by the B<-style> option).
+Arcs are created with methods of the following form:
+
+ $canvas->createArc(x1, y1, x2, y2, ?option, value, option, value, ...?)
+
+The arguments I<x1>, I<y1>, I<x2>, and I<y2> give
+the coordinates of two diagonally opposite corners of a
+rectangular region enclosing the oval that defines the arc.
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for arcs:
+
+=over 4
+
+=item B<-dash> =E<gt> I<pattern>
+
+=item B<-activedash> =E<gt> I<pattern>
+
+=item B<-disableddash> =E<gt> I<pattern>
+
+This option specifies dash patterns for the normal state, the active
+state, and the disabled state of an arc item.
+I<pattern> may have any of the forms accepted by B<Tk_GetDash>.
+If the dash options are omitted then the default is a solid outline.
+
+=item B<-dashoffset> =E<gt> I<offset>
+
+The starting I<offset> into the pattern provided by the
+B<-dash> option.
+B<-dashoffset> is ignored if there is no B<-dash> pattern.
+
+=item B<-extent> =E<gt> I<degrees>
+
+Specifies the size of the angular range occupied by the arc.
+The arc's range extends for I<degrees> degrees counter-clockwise
+from the starting angle given by the B<-start> option.
+I<Degrees> may be negative.
+If it is greater than 360 or less than -360, then I<degrees>
+modulo 360 is used as the extent.
+
+=item B<-fill> =E<gt> I<color>
+
+=item B<-activefill> =E<gt> I<color>
+
+=item B<-disabledfill> =E<gt> I<color>
+
+Specifies the color to be used to fill the arc region in its normal, active, and
+disabled states,
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+If I<color> is an empty string (the default), then
+then the arc will not be filled.
+
+=item B<-outline> =E<gt> I<color>
+
+=item B<-activeoutline> =E<gt> I<color>
+
+=item B<-disabledoutline> =E<gt> I<color>
+
+This option specifies the color that should be used to draw the
+outline of the arc in its normal, active and disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+This option defaults to B<black>. If I<color> is specified
+as undef then no outline is drawn for the arc.
+
+=item B<-outlinestipple> =E<gt> I<bitmap>
+
+=item B<-activeoutlinestipple> =E<gt> I<bitmap>
+
+=item B<-disabledoutlinestipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to draw the
+outline of the arc in its normal, active and disabled states.
+Indicates that the outline for the arc should be drawn with a stipple pattern;
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If the B<-outline> option hasn't been specified then this option
+has no effect.
+If I<bitmap> is an empty string (the default), then the outline is drawn
+in a solid fashion.
+
+=item B<-start> =E<gt> I<degrees>
+
+Specifies the beginning of the angular range occupied by the
+arc.
+I<Degrees> is given in units of degrees measured counter-clockwise
+from the 3-o'clock position; it may be either positive or negative.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the arc item where I<state> may be set to one of:
+normal, disabled, hidden or "". If set to empty, the state of the canvas
+itself is used. An arc item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-stipple> =E<gt> I<bitmap>
+
+=item B<-activestipple> =E<gt> I<bitmap>
+
+=item B<-disabledstipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to fill the
+the arc in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If the B<-fill> option hasn't been specified then this option
+has no effect.
+If I<bitmap> is an empty string (the default), then filling is done
+in a solid fashion.
+
+=item B<-style> =E<gt> I<type>
+
+Specifies how to draw the arc. If I<type> is B<pieslice>
+(the default) then the arc's region is defined by a section
+of the oval's perimeter plus two line segments, one between the center
+of the oval and each end of the perimeter section.
+If I<type> is B<chord> then the arc's region is defined
+by a section of the oval's perimeter plus a single line segment
+connecting the two end points of the perimeter section.
+If I<type> is B<arc> then the arc's region consists of
+a section of the perimeter alone.
+In this last case the B<-fill> option is ignored.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the arc item is updated on the screen.
+
+=item B<-width> =E<gt> I<outlineWidth>
+
+=item B<-activewidth> =E<gt> I<outlineWidth>
+
+=item B<-disabledwidth> =E<gt> I<outlineWidth>
+
+Specifies the width of the outline to be drawn around
+the arc's region, in its normal, active and disabled states.
+I<outlineWidth> may be in any of the forms described in
+the L<"COORDINATES"> section above.
+If the B<-outline> option has been specified as undef
+then this option has no effect.
+Wide outlines will be drawn centered on the edges of the arc's region.
+This option defaults to 1.0.
+
+=back
+
+=head1 BITMAP ITEMS
+
+Items of type B<bitmap> appear on the display as images with
+two colors, foreground and background.
+Bitmaps are created with methods of the following form:
+
+ $canvas->createBitmap(x, y, ?option, value, option, value, ...?)
+
+The arguments I<x> and I<y> specify the coordinates of a
+point used to position the bitmap on the display (see the B<-anchor>
+option below for more information on how bitmaps are displayed).
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for bitmaps:
+
+=over 4
+
+=item B<-anchor> =E<gt> I<anchorPos>
+
+I<AnchorPos> tells how to position the bitmap relative to the
+positioning point for the item; it may have any of the forms
+accepted by B<Tk_GetAnchor>. For example, if I<anchorPos>
+is B<center> then the bitmap is centered on the point; if
+I<anchorPos> is B<n> then the bitmap will be drawn so that
+its top center point is at the positioning point.
+This option defaults to B<center>.
+
+=item B<-background> =E<gt> I<color>
+
+=item B<-activebackground> =E<gt> I<color>
+
+=item B<-disabledbackground> =E<gt> I<color>
+
+Specifies the color to use for each of the bitmap's '0' valued pixels
+in its normal, active and disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+If this option isn't specified, or if it is specified as undef,
+then nothing is displayed where the bitmap pixels are 0; this
+produces a transparent effect.
+
+=item B<-bitmap> =E<gt> I<bitmap>
+
+=item B<-activebitmap> =E<gt> I<bitmap>
+
+=item B<-disabledbitmap> =E<gt> I<bitmap>
+
+Specifies the bitmaps to display in the item in its normal, active and
+disabled states. All bitmaps must have the same width and height.
+I<Bitmap> may have any of the forms accepted by B<Tk_GetBitmap>.
+
+=item B<-foreground> =E<gt> I<color>
+
+=item B<-activeforeground> =E<gt> I<color>
+
+=item B<-disabledforeground> =E<gt> I<color>
+
+Specifies the color to use for each of the bitmap's '1' valued pixels
+in its normal, active and disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor> and
+defaults to B<black>.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the bitmap item where I<state> may be set to one of:
+normal, disabled, or hidden. An bitmap item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the bitmap item is updated on the screen.
+
+=back
+
+=head1 GRID ITEMS
+
+Items of type B<grid> are intended for producing a visual reference for
+interpreting other items. They can be drawn as either lines (with dash
+style) or as rectangular "dots" at each grid point.
+
+Items of type B<grid> are unlike other items they always cover the
+whole of the canvas, but are never enclosed by nor overlap any area
+and are not near any point. That is they are intended to be always visible
+but not "pickable", as such they do support the "active" state.
+They are like other items in that: multiple
+grids are permitted, they can be raised and lowered relative to other
+items, they can be moved and scaled. As yet grids do not apear in
+PostScript output.
+
+Grids have outline like configure options. Grids are created with methods of the
+following form:
+
+ $canvas->createGrid(x1, y1, x2, y2, ?option, value, option, value, ...?)
+
+The arguments I<x1>, I<y1> give the origin of the grid. I<x2>, and I<y2> give
+the coordinates of the next grid point in their respective directions.
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for grids:
+
+=over 4
+
+=item B<-lines> =E<gt> I<boolean>
+
+If B<-lines> is set to a true value then lines are drawn for both X and Y
+grids in the style determined by B<-dash>. Otherwise retangular "dots"
+are drawn at each grid point.
+
+=item B<-dash> =E<gt> I<pattern>
+
+=item B<-disableddash> =E<gt> I<pattern>
+
+This option specifies dash patterns for the normal state,
+and the disabled state of a grid item.
+I<pattern> may have any of the forms accepted by B<Tk_GetDash>.
+If the dash options are omitted then the default is a solid outline.
+
+=item B<-dashoffset> =E<gt> I<offset>
+
+The starting I<offset> into the pattern provided by the
+B<-dash> option.
+B<-dashoffset> is ignored if there is no B<-dash> pattern.
+
+=item B<-color> =E<gt> I<color>
+
+=item B<-disabledcolor> =E<gt> I<color>
+
+This option specifies the color that should be used to draw the
+outline of the grid in its normal and disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+This option defaults to B<black>.
+If I<color> is undef then no grid will be drawn.
+
+=item B<-stipple> =E<gt> I<bitmap>
+
+=item B<-disabledstipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to draw the
+outline of the rectangle in its normal and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If I<bitmap> is an empty string (the default), then the outline is drawn
+in a solid fashion.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the rectangle item where I<state> may be set to one of:
+normal, disabled, or hidden. Many options can take
+separate specifications in normal and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the grid item is updated on the screen.
+
+=item B<-width> =E<gt> I<outlineWidth>
+
+=item B<-disabledwidth> =E<gt> I<outlineWidth>
+
+Specifies the width of the lines drawn by the grid or the size (in both X and Y)
+of the dots, in its normal and disabled states.
+This option defaults to 1.0.
+
+=back
+
+=head1 IMAGE ITEMS
+
+Items of type B<image> are used to display images on a
+canvas.
+Images are created with methods of the following form:
+
+ $canvas->createImage(x, y, ?option, value, option, value, ...?)
+
+The arguments I<x> and I<y> specify the coordinates of a
+point used to position the image on the display (see the B<-anchor>
+option below for more information).
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for images:
+
+=over 4
+
+=item B<-anchor> =E<gt> I<anchorPos>
+
+I<AnchorPos> tells how to position the image relative to the
+positioning point for the item; it may have any of the forms
+accepted by B<Tk_GetAnchor>. For example, if I<anchorPos>
+is B<center> then the image is centered on the point; if
+I<anchorPos> is B<n> then the image will be drawn so that
+its top center point is at the positioning point.
+This option defaults to B<center>.
+
+=item B<-image> =E<gt> I<name>
+
+=item B<-activeimage> =E<gt> I<name>
+
+=item B<-disabledimage> =E<gt> I<name>
+
+Specifies the name of the images to display in the item in is normal,
+active and disabled states. This image must have been created
+previously, see L<Tk::Image>.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the image item where I<state> may be set to one of:
+normal, disabled, or hidden. An image item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item; it may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the image item is updated on the screen.
+
+=back
+
+=head1 LINE ITEMS
+
+Items of type B<line> appear on the display as one or more connected
+line segments or curves.
+Line items support coordinate indexing operations using the canvas
+methods: B<dchars, index, insert.>
+Lines are created with methods of the following form:
+
+ $canvas->createLine(x1, y1..., xn, yn, ?option, value, option, value, ...?)
+
+The arguments I<x1> through I<yn> give
+the coordinates for a series of two or more points that describe
+a series of connected line segments.
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for lines:
+
+=over 4
+
+=item B<-arrow> =E<gt> I<where>
+
+Indicates whether or not arrowheads are to be drawn at one or both
+ends of the line.
+I<Where> must have one of the values B<none> (for no arrowheads),
+B<first> (for an arrowhead at the first point of the line),
+B<last> (for an arrowhead at the last point of the line), or
+B<both> (for arrowheads at both ends).
+This option defaults to B<none>.
+
+=item B<-arrowshape> =E<gt> I<shape>
+
+This option indicates how to draw arrowheads.
+The I<shape> argument must be a list with three elements, each
+specifying a distance in any of the forms described in
+the L<"COORDINATES"> section above.
+The first element of the list gives the distance along the line
+from the neck of the arrowhead to its tip.
+The second element gives the distance along the line from the
+trailing points of the arrowhead to the tip, and the third
+element gives the distance from the outside edge of the line to the
+trailing points.
+If this option isn't specified then Tk picks a ``reasonable'' shape.
+
+=item B<-capstyle> =E<gt> I<style>
+
+Specifies the ways in which caps are to be drawn at the endpoints
+of the line.
+I<Style> may have any of the forms accepted by B<Tk_GetCapStyle>
+(B<butt>, B<projecting>, or B<round>).
+If this option isn't specified then it defaults to B<butt>.
+Where arrowheads are drawn the cap style is ignored.
+
+=item B<-dash> =E<gt> I<pattern>
+
+=item B<-activedash> =E<gt> I<pattern>
+
+=item B<-disableddash> =E<gt> I<pattern>
+
+This option specifies dash patterns for the normal state, the active
+state, and the disabled state of a line item.
+I<pattern> may have any of the forms accepted by B<Tk_GetDash>.
+If the dash options are omitted then the default is a solid outline.
+
+=item B<-dashoffset> =E<gt> I<offset>
+
+The starting I<offset> into the pattern provided by the
+B<-dash> option.
+B<-dashoffset> is ignored if there is no B<-dash> pattern.
+
+=item B<-fill> =E<gt> I<color>
+
+=item B<-activefill> =E<gt> I<color>
+
+=item B<-disabledfill> =E<gt> I<color>
+
+Specifies the color to be used to fill the line in its normal, active, and
+disabled states.
+I<Color> may have
+any of the forms acceptable to B<Tk_GetColor>. It may also be undef,
+in which case the line will be transparent.
+This option defaults to B<black>.
+
+=item B<-joinstyle> =E<gt> I<style>
+
+Specifies the ways in which joints are to be drawn at the vertices
+of the line.
+I<Style> may have any of the forms accepted by B<Tk_GetCapStyle>
+(B<bevel>, B<miter>, or B<round>).
+If this option isn't specified then it defaults to B<miter>.
+If the line only contains two points then this option is
+irrelevant.
+
+=item B<-smooth> =E<gt> I<boolean>
+
+I<Boolean> must have one of the forms accepted by B<Tk_GetBoolean>.
+It indicates whether or not the line should be drawn as a curve.
+If so, the line is rendered as a set of parabolic splines: one spline
+is drawn for the first and second line segments, one for the second
+and third, and so on. Straight-line segments can be generated within
+a curve by duplicating the end-points of the desired line segment.
+
+=item B<-splinesteps> =E<gt> I<number>
+
+Specifies the degree of smoothness desired for curves: each spline
+will be approximated with I<number> line segments. This
+option is ignored unless the B<-smooth> option is true.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the line item where I<state> may be set to one of:
+normal, disabled, or hidden. A line item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-stipple> =E<gt> I<bitmap>
+
+=item B<-activestipple> =E<gt> I<bitmap>
+
+=item B<-disabledstipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to fill the
+the line in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If I<bitmap> is an empty string (the default), then filling is
+done in a solid fashion.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the line item is updated on the screen.
+
+=item B<-width> =E<gt> I<lineWidth>
+
+=item B<-activewidth> =E<gt> I<lineWidth>
+
+=item B<-disabledwidth> =E<gt> I<lineWidth>
+
+Specifies the width of the line
+in its normal, active and disabled states.
+I<lineWidth> may be in any of the forms
+described in the L<"COORDINATES"> section above.
+
+Wide lines will be drawn centered on the path specified by the
+points.
+If this option isn't specified then it defaults to 1.0.
+
+=back
+
+=head1 OVAL ITEMS
+
+Items of type B<oval> appear as circular or oval regions on
+the display. Each oval may have an outline, a fill, or
+both. Ovals are created with methods of the
+following form:
+
+ $canvas->createOval(x1, y1, x2, y2, ?option, value, option, value, ...?)
+
+The arguments I<x1>, I<y1>, I<x2>, and I<y2> give
+the coordinates of two diagonally opposite corners of a
+rectangular region enclosing the oval.
+The oval will include the top and left edges of the rectangle
+not the lower or right edges.
+If the region is square then the resulting oval is circular;
+otherwise it is elongated in shape.
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for ovals:
+
+=over 4
+
+=item B<-dash> =E<gt> I<pattern>
+
+=item B<-activedash> =E<gt> I<pattern>
+
+=item B<-disableddash> =E<gt> I<pattern>
+
+This option specifies dash patterns for the normal state, the active
+state, and the disabled state of an oval item.
+I<pattern> may have any of the forms accepted by B<Tk_GetDash>.
+If the dash options are omitted then the default is a solid outline.
+
+=item B<-dashoffset> =E<gt> I<offset>
+
+The starting I<offset> into the pattern provided by the
+B<-dash> option.
+B<-dashoffset> is ignored if there is no B<-dash> pattern.
+
+=item B<-fill> =E<gt> I<color>
+
+=item B<-activefill> =E<gt> I<color>
+
+=item B<-disabledfill> =E<gt> I<color>
+
+Specifies the color to be used to fill the oval in its normal, active, and
+disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+If I<color> is undef (the default), then
+then the oval will not be filled.
+
+=item B<-outline> =E<gt> I<color>
+
+=item B<-activeoutline> =E<gt> I<color>
+
+=item B<-disabledoutline> =E<gt> I<color>
+
+This option specifies the color that should be used to draw the
+outline of the oval in its normal, active and disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+This option defaults to B<black>.
+If I<color> is undef then no outline will be
+drawn for the oval.
+
+=item B<-outlinestipple> =E<gt> I<bitmap>
+
+=item B<-activeoutlinestipple> =E<gt> I<bitmap>
+
+=item B<-disabledoutlinestipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to draw the
+outline of the oval in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If the B<-outline> option hasn't been specified then this option
+has no effect.
+If I<bitmap> is an empty string (the default), then the outline is drawn
+in a solid fashion.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the oval item where I<state> may be set to one of:
+normal, disabled, or hidden. An oval item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-stipple> =E<gt> I<bitmap>
+
+=item B<-activestipple> =E<gt> I<bitmap>
+
+=item B<-disabledstipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to fill the
+the oval in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If the B<-fill> option hasn't been specified then this option
+has no effect.
+If I<bitmap> is an empty string (the default), then filling is done
+in a solid fashion.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the oval item is updated on the screen.
+
+=item B<-width> =E<gt> I<outlineWidth>
+
+=item B<-activewidth> =E<gt> I<outlineWidth>
+
+=item B<-disabledwidth> =E<gt> I<outlineWidth>
+
+Specifies the width of the outline to be drawn around
+the oval, in its normal, active and disabled states.
+I<outlineWidth> specifies the width of the outline to be drawn around
+the oval, in any of the forms described in the L<"COORDINATES"> section above.
+
+If the B<-outline> option hasn't been specified then this option
+has no effect.
+Wide outlines are drawn centered on the oval path defined by
+I<x1>, I<y1>, I<x2>, and I<y2>.
+This option defaults to 1.0.
+
+=back
+
+=head1 POLYGON ITEMS
+
+Items of type B<polygon> appear as polygonal or curved filled regions
+on the display.
+Polygon items support coordinate indexing operations using the canvas
+methods: B<dchars, index, insert.>
+Polygons are created with methods of the following form:
+
+ $canvas->createPolygon(x1, y1, ..., xn, yn, ?option, value, option, value, ...?)
+
+The arguments I<x1> through I<yn> specify the coordinates for
+three or more points that define a closed polygon.
+The first and last points may be the same; whether they are or not,
+Tk will draw the polygon as a closed polygon.
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for polygons:
+
+=over 4
+
+=item B<-dash> =E<gt> I<pattern>
+
+=item B<-activedash> =E<gt> I<pattern>
+
+=item B<-disableddash> =E<gt> I<pattern>
+
+This option specifies dash patterns for the normal state, the active
+state, and the disabled state of an polygon item.
+I<pattern> may have any of the forms accepted by B<Tk_GetDash>.
+If the dash options are omitted then the default is a solid outline.
+
+=item B<-dashoffset> =E<gt> I<offset>
+
+The starting I<offset> into the pattern provided by the
+B<-dash> option.
+B<-dashoffset> is ignored if there is no B<-dash> pattern.
+
+=item B<-fill> =E<gt> I<color>
+
+=item B<-activefill> =E<gt> I<color>
+
+=item B<-disabledfill> =E<gt> I<color>
+
+Specifies the color to be used to fill the polygon in its normal, active, and
+disabled states.
+I<Color>
+may have any of the forms acceptable to B<Tk_GetColor>.
+If I<color> is undef then the polygon will be
+transparent.
+This option defaults to B<black>.
+
+=item B<-joinstyle> =E<gt> I<style>
+
+Specifies the ways in which joints are to be drawn at the vertices
+of the outline.
+I<Style> may have any of the forms accepted by B<Tk_GetCapStyle>
+(B<bevel>, B<miter>, or B<round>).
+If this option isn't specified then it defaults to B<miter>.
+
+=item B<-outline> =E<gt> I<color>
+
+=item B<-activeoutline> =E<gt> I<color>
+
+=item B<-disabledoutline> =E<gt> I<color>
+
+This option specifies the color that should be used to draw the
+outline of the polygon in its normal, active and disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+If I<color> is undef then no outline will be
+drawn for the polygon.
+This option defaults to undef (no outline).
+
+=item B<-outlinestipple> =E<gt> I<bitmap>
+
+=item B<-activeoutlinestipple> =E<gt> I<bitmap>
+
+=item B<-disabledoutlinestipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to draw the
+outline of the polygon in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If the B<-outline> option hasn't been specified then this option
+has no effect.
+If I<bitmap> is an empty string (the default), then the outline is drawn
+in a solid fashion.
+
+=item B<-smooth> =E<gt> I<boolean>
+
+I<Boolean> must have one of the forms accepted by B<Tk_GetBoolean>
+It indicates whether or not the polygon should be drawn with a
+curved perimeter.
+If so, the outline of the polygon becomes a set of parabolic splines,
+one spline for the first and second line segments, one for the second
+and third, and so on. Straight-line segments can be generated in a
+smoothed polygon by duplicating the end-points of the desired line segment.
+
+=item B<-splinesteps> =E<gt> I<number>
+
+Specifies the degree of smoothness desired for curves: each spline
+will be approximated with I<number> line segments. This
+option is ignored unless the B<-smooth> option is true.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the polygon item where I<state> may be set to one of:
+normal, disabled, or hidden. A polygon item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-stipple> =E<gt> I<bitmap>
+
+=item B<-activestipple> =E<gt> I<bitmap>
+
+=item B<-disabledstipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to fill the
+the polygon in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If I<bitmap> is an empty string (the default), then filling is
+done in a solid fashion.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the polygon item is updated on the screen.
+
+=item B<-width> =E<gt> I<outlineWidth>
+
+=item B<-activewidth> =E<gt> I<outlineWidth>
+
+=item B<-disabledwidth> =E<gt> I<outlineWidth>
+
+=item Specifies the width of the outline to be drawn around
+
+the polygon, in its normal, active and disabled states.
+I<outlineWidth> may be in any of the forms described in the COORDINATES
+section above.
+I<OutlineWidth> specifies the width of the outline to be drawn around
+the polygon, in any of the forms described in the L<"COORDINATES"> section above.
+If the B<-outline> option hasn't been specified then this option
+has no effect. This option defaults to 1.0.
+
+Polygon items are different from other items such as rectangles, ovals
+and arcs in that interior points are considered to be ``inside'' a
+polygon (e.g. for purposes of the B<find closest> and
+B<find overlapping> methods) even if it is not filled.
+For most other item types, an
+interior point is considered to be inside the item only if the item
+is filled or if it has neither a fill nor an outline. If you would
+like an unfilled polygon whose interior points are not considered
+to be inside the polygon, use a line item instead.
+
+=back
+
+=head1 RECTANGLE ITEMS
+
+Items of type B<rectangle> appear as rectangular regions on
+the display. Each rectangle may have an outline, a fill, or
+both. Rectangles are created with methods of the
+following form:
+
+ $canvas->createRectangle(x1, y1, x2, y2, ?option, value, option, value, ...?)
+
+The arguments I<x1>, I<y1>, I<x2>, and I<y2> give
+the coordinates of two diagonally opposite corners of the rectangle
+(the rectangle will include its upper and left edges but not
+its lower or right edges).
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for rectangles:
+
+=over 4
+
+=item B<-dash> =E<gt> I<pattern>
+
+=item B<-activedash> =E<gt> I<pattern>
+
+=item B<-disableddash> =E<gt> I<pattern>
+
+This option specifies dash patterns for the normal state, the active
+state, and the disabled state of a rectangle item.
+I<pattern> may have any of the forms accepted by B<Tk_GetDash>.
+If the dash options are omitted then the default is a solid outline.
+
+=item B<-dashoffset> =E<gt> I<offset>
+
+The starting I<offset> into the pattern provided by the
+B<-dash> option.
+B<-dashoffset> is ignored if there is no B<-dash> pattern.
+
+=item B<-fill> =E<gt> I<color>
+
+=item B<-activefill> =E<gt> I<color>
+
+=item B<-disabledfill> =E<gt> I<color>
+
+Specifies the color to be used to fill the rectangle in its normal, active, and
+disabled states.
+I<Color>
+may be specified in any of the forms accepted by B<Tk_GetColor>.
+If I<color> is undef (the default),
+then the rectangle will not be filled.
+
+=item B<-outline> =E<gt> I<color>
+
+=item B<-activeoutline> =E<gt> I<color>
+
+=item B<-disabledoutline> =E<gt> I<color>
+
+This option specifies the color that should be used to draw the
+outline of the rectangle in its normal, active and disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+This option defaults to B<black>.
+If I<color> is undef then no outline will be
+drawn for the rectangle.
+
+=item B<-outlinestipple> =E<gt> I<bitmap>
+
+=item B<-activeoutlinestipple> =E<gt> I<bitmap>
+
+=item B<-disabledoutlinestipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to draw the
+outline of the rectangle in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If the B<-outline> option hasn't been specified then this option
+has no effect.
+If I<bitmap> is an empty string (the default), then the outline is drawn
+in a solid fashion.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the rectangle item where I<state> may be set to one of:
+normal, disabled, or hidden. A rectangle item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-stipple> =E<gt> I<bitmap>
+
+=item B<-activestipple> =E<gt> I<bitmap>
+
+=item B<-disabledstipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to fill the
+the rectangle in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If the B<-fill> option hasn't been specified then this option
+has no effect.
+If I<bitmap> is an empty string (the default), then filling
+is done in a solid fashion.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the rectangle item is updated on the screen.
+
+=item B<-width> =E<gt> I<outlineWidth>
+
+=item B<-activewidth> =E<gt> I<outlineWidth>
+
+=item B<-disabledwidth> =E<gt> I<outlineWidth>
+
+Specifies the width of the outline to be drawn around
+the rectangle, in its normal, active and disabled states.
+I<OutlineWidth> specifies the width of the outline to be drawn around
+the rectangle, in any of the forms described in the L<"COORDINATES"> section above.
+
+If the B<-outline> option hasn't been specified then this option
+has no effect.
+Wide outlines are drawn centered on the rectangular path
+defined by I<x1>, I<y1>, I<x2>, and I<y2>.
+This option defaults to 1.0.
+
+=back
+
+=head1 TEXT ITEMS
+
+A text item displays a string of characters on the screen in one
+or more lines.
+Text items support indexing and selection, along with the
+following text-related canvas methods: B<dchars>,
+B<focus>, B<icursor>, B<index>, B<insert>,
+B<select>.
+Text items are created with methods of the following
+form:
+
+ $canvas->createText(x, y, ?option, value, option, value, ...?)
+
+The arguments I<x> and I<y> specify the coordinates of a
+point used to position the text on the display (see the options
+below for more information on how text is displayed).
+After the coordinates there may be any number of I<option>-I<value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> methods to change the item's
+configuration.
+The following options are supported for text items:
+
+=over 4
+
+=item B<-anchor> =E<gt> I<anchorPos>
+
+I<AnchorPos> tells how to position the text relative to the
+positioning point for the text; it may have any of the forms
+accepted by B<Tk_GetAnchor>. For example, if I<anchorPos>
+is B<center> then the text is centered on the point; if
+I<anchorPos> is B<n> then the text will be drawn such that
+the top center point of the rectangular region occupied by the
+text will be at the positioning point.
+This option defaults to B<center>.
+
+=item B<-fill> =E<gt> I<color>
+
+=item B<-activefill> =E<gt> I<color>
+
+=item B<-disabledfill> =E<gt> I<color>
+
+Specifies the color to be used to fill the text in its normal, active, and
+disabled states.
+I<Color> may have any of the forms accepted by B<Tk_GetColor>.
+If I<color> is undef then the text will be transparent.
+If this option isn't specified then it defaults to B<black>.
+
+=item B<-font> =E<gt> I<fontName>
+
+Specifies the font to use for the text item.
+I<FontName> may be any string acceptable to B<Tk_GetFontStruct>.
+If this option isn't specified, it defaults to a system-dependent
+font.
+
+=item B<-justify> =E<gt> I<how>
+
+Specifies how to justify the text within its bounding region.
+I<How> must be one of the values B<left>, B<right>,
+or B<center>.
+This option will only matter if the text is displayed as multiple
+lines.
+If the option is omitted, it defaults to B<left>.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the text item where I<state> may be set to one of:
+normal, disabled, or hidden. A text item may also be in the "active"
+state if the mouse is currently over it. Many options can take
+separate specifications in normal, active and disabled states such that the
+appearance of the item can be different in each state.
+
+=item B<-stipple> =E<gt> I<bitmap>
+
+=item B<-activestipple> =E<gt> I<bitmap>
+
+=item B<-disabledstipple> =E<gt> I<bitmap>
+
+This option specifies stipple patterns that should be used to fill the
+the text in its normal, active and disabled states.
+I<bitmap> specifies the stipple pattern to use, in any of the
+forms accepted by B<Tk_GetBitmap>.
+If I<bitmap> is an empty string (the default) then the text
+is drawn in a solid fashion.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-text> =E<gt> I<string>
+
+I<String> specifies the characters to be displayed in the text item.
+Newline characters cause line breaks.
+The characters in the item may also be changed with the
+B<insert> and B<delete> methods.
+This option defaults to an empty string.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the text item is updated on the screen.
+
+=item B<-width> =E<gt> I<lineLength>
+
+Specifies a maximum line length for the text, in any of the forms
+described in the L<"COORDINATES"> section above.
+If this option is zero (the default) the text is broken into
+lines only at newline characters.
+However, if this option is non-zero then any line that would
+be longer than I<lineLength> is broken just before a space
+character to make the line shorter than I<lineLength>; the
+space character is treated as if it were a newline
+character.
+
+=back
+
+=head1 WINDOW ITEMS
+
+Items of type B<window> cause a particular window to be displayed
+at a given position on the canvas.
+Window items are created with methods of the following form:
+
+S< >I<$canvas>->B<createWindow>(I<x, y>?, I<-option>=>I<value>, I<-option>=>I<value>, ...?)
+
+The arguments I<x> and I<y> specify the coordinates of a
+point used to position the window on the display (see the B<-anchor>
+option below for more information on how bitmaps are displayed).
+After the coordinates there may be any number of I<option-value>
+pairs, each of which sets one of the configuration options
+for the item. These same I<option>-I<value> pairs may be
+used in B<itemconfigure> method to change the item's
+configuration.
+The following options are supported for window items:
+
+=over 4
+
+=item B<-anchor> =E<gt> I<anchorPos>
+
+I<AnchorPos> tells how to position the window relative to the
+positioning point for the item; it may have any of the forms
+accepted by B<Tk_GetAnchor>. For example, if I<anchorPos>
+is B<center> then the window is centered on the point; if
+I<anchorPos> is B<n> then the window will be drawn so that
+its top center point is at the positioning point.
+This option defaults to B<center>.
+
+=item B<-height> =E<gt> I<pixels>
+
+Specifies the height to assign to the item's window.
+I<Pixels> may have any of the
+forms described in the L<"COORDINATES"> section above.
+If this option isn't specified, or if it is specified as an empty
+string, then the window is given whatever height it requests internally.
+
+=item B<-state> =E<gt> I<state>
+
+Modifies the state of the window item where I<state> may be set to one of:
+normal, disabled, or hidden.
+
+=item B<-tags> =E<gt> I<tagList>
+
+Specifies a set of tags to apply to the item.
+I<TagList> consists of a list of tag names, which replace any
+existing tags for the item.
+I<TagList> may be an empty list.
+
+=item B<-updatecommand> =E<gt> I<command>
+
+Specifies a callback that is to be executed every time
+the window item is updated on the screen.
+
+=item B<-width> =E<gt> I<pixels>
+
+Specifies the width to assign to the item's window.
+I<Pixels> may have any of the
+forms described in the L<"COORDINATES"> section above.
+If this option isn't specified, or if it is specified as an empty
+string, then the window is given whatever width it requests internally.
+
+=item B<-window> =E<gt> I<$widget>
+
+Specifies the window to associate with this item.
+The window specified by $widget must either be a child of
+the canvas widget or a child of some ancestor of the canvas widget.
+I<PathName> may not refer to a top-level window.
+
+Note: due to restrictions in the ways that windows are managed, it is not
+possible to draw other graphical items (such as lines and images) on top
+of window items. A window item always obscures any graphics that
+overlap it, regardless of their order in the display list.
+
+=back
+
+=head1 APPLICATION-DEFINED ITEM TYPES
+
+It is possible for individual applications to define new item
+types for canvas widgets using C code.
+See the documentation for B<Tk_CreateItemType>.
+
+=head1 BINDINGS
+
+Canvas has default bindings to allow scrolling if necessary:
+<Up>, <Down>, <Left> and <Right> (and their <Control-*> counter
+parts). Further <Proir>, <Next>, <Home> and <End>. These
+bindings allow you to navigate the same way as in other
+widgets that can scroll.
+
+=head1 Perl/Tk Methods
+
+The following methods are added as perl code:
+
+=over 4
+
+=item $canvas->get_corners
+
+Returns the bounding box in Canvas coordinates of the visible portion
+of the Canvas. (Written by Slaven Rezic.)
+
+=back
+
+=head1 CREDITS
+
+Tk's canvas widget is a blatant ripoff of ideas from Joel Bartlett's
+I<ezd> program. I<Ezd> provides structured graphics in a Scheme
+environment and preceded canvases by a year or two. Its simple
+mechanisms for placing and animating graphical objects inspired the
+functions of canvases.
+
+=head1 KEYWORDS
+
+canvas, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pm
new file mode 100755
index 00000000000..491d8cd2444
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pm
@@ -0,0 +1,42 @@
+package Tk::Checkbutton;
+# Conversion from Tk4.0 button.tcl competed.
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+require Tk::Widget;
+require Tk::Button;
+
+use base qw(Tk::Button);
+
+Construct Tk::Widget 'Checkbutton';
+
+sub Tk_cmd { \&Tk::checkbutton }
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'Invoke');
+ $mw->bind($class,'<space>', 'Invoke');
+ return $class;
+}
+
+sub Invoke
+{
+ my $w = shift;
+ $w->invoke() unless($w->cget('-state') eq 'disabled');
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pod
new file mode 100755
index 00000000000..35c4fa8ffbc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Checkbutton.pod
@@ -0,0 +1,347 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Checkbutton - Create and manipulate Checkbutton widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$checkbutton> = I<$parent>-E<gt>B<Checkbutton>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground>
+B<-activeforeground>
+B<-anchor>
+B<-background>
+B<-bitmap>
+B<-borderwidth>
+B<-compound>
+B<-cursor>
+B<-disabledforeground>
+B<-font>
+B<-foreground>
+B<-highlightbackground>
+B<-highlightcolor>
+B<-highlightthickness>
+B<-image>
+B<-justify>
+B<-padx>
+B<-pady>
+B<-relief>
+B<-takefocus>
+B<-text>
+B<-textvariable>
+B<-underline>
+B<-wraplength>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies a L<perl/Tk callback|Tk::callbacks> to associate with the button. This command
+is typically invoked when mouse button 1 is released over the button
+window. The button's global variable (B<-variable> option) will
+be updated before the command is invoked.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies a desired height for the button.
+If an image or bitmap is being displayed in the button then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in lines of text.
+If this option isn't specified, the button's desired height is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=item Name: B<indicatorOn>
+
+=item Class: B<IndicatorOn>
+
+=item Switch: B<-indicatoron>
+
+Specifies whether or not the indicator should be drawn. Must be a
+proper boolean value. If false, the B<relief> option is
+ignored and the widget's relief is always sunken if the widget is
+selected and raised otherwise.
+
+=item Command-Line Name: B<-offrelief>
+
+=item Database Name: B<offRelief>
+
+=item Database Class: B<OffRelief>
+
+Specifies the relief for the checkbutton when the indicator is not
+drawn and the checkbutton is off. The default value is B<raised>. By
+setting this option to B<flat> and setting
+B<-indicatoron false -overrelief raised>, the effect is achieved of
+having a flat button
+that raises on mouse-over and which is depressed when activated. This
+is the behavior typically exhibited by the Bold, Italic, and
+Underline checkbuttons on the toolbar of a word-processor, for
+example.
+
+=item Name: B<offValue>
+
+=item Class: B<Value>
+
+=item Switch: B<-offvalue>
+
+Specifies value to store in the button's associated variable whenever
+this button is deselected. Defaults to ``0''.
+
+=item Name: B<onValue>
+
+=item Class: B<Value>
+
+=item Switch: B<-onvalue>
+
+Specifies value to store in the button's associated variable whenever
+this button is selected. Defaults to ``1''.
+
+=item Command-Line Name: B<-overrelief>
+
+=item Database Name: B<overRelief>
+
+=item Database Class: B<OverRelief>
+
+Specifies an alternative relief for the button, to be used when
+the mouse cursor is over the widget. This option can be used to
+make toolbar buttons, by configuring B<-relief flat -overrelief
+raised>. If the value of this option is the empty string, then
+no alternative relief is used when the mouse cursor is over the
+button. The empty string is the default value.
+
+=item Name: B<selectColor>
+
+=item Class: B<Background>
+
+=item Switch: B<-selectcolor>
+
+Specifies a background color to use when the button is selected.
+If B<indicatorOn> is true then the color applies to the indicator.
+Under Windows, this color is used as the background for the indicator
+regardless of the select state.
+If B<indicatorOn> is false, this color is used as the background
+for the entire widget, in place of B<background> or B<activeBackground>,
+whenever the widget is selected.
+If specified as an empty string then no special color is used for
+displaying when the widget is selected.
+
+=item Name: B<selectImage>
+
+=item Class: B<SelectImage>
+
+=item Switch: B<-selectimage>
+
+Specifies an image to display (in place of the B<image> option)
+when the checkbutton is selected.
+This option is ignored unless the B<image> option has been
+specified.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of three states for the checkbutton: B<normal>, B<active>,
+or B<disabled>. In normal state the checkbutton is displayed using the
+B<foreground> and B<background> options. The active state is
+typically used when the pointer is over the checkbutton. In active state
+the checkbutton is displayed using the B<activeForeground> and
+B<activeBackground> options. Disabled state means that the checkbutton
+should be insensitive: the default bindings will refuse to activate
+the widget and will ignore mouse button presses.
+In this state the B<disabledForeground> and
+B<background> options determine how the checkbutton is displayed.
+
+=item Name: B<variable>
+
+=item Class: B<Variable>
+
+=item Switch: B<-variable>
+
+Specifies reference to a variable to set to indicate whether
+or not this button is selected. Defaults to C<\$widget-E<gt>{'Value'}>
+member of the widget's hash. In general perl variables are C<undef> unless
+specifically initialized which will not match either default B<-onvalue> or
+default B<-offvalue>.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies a desired width for the button.
+If an image or bitmap is being displayed in the button then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in characters.
+If this option isn't specified, the button's desired width is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Checkbutton> method creates a new window (given by the
+$widget argument) and makes it into a checkbutton widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the checkbutton such as its colors, font,
+text, and initial relief. The B<checkbutton> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A checkbutton is a widget
+that displays a textual string, bitmap or image
+and a square called an I<indicator>.
+If text is displayed, it must all be in a single font, but it
+can occupy multiple lines on the screen (if it contains newlines
+or if wrapping occurs because of the B<wrapLength> option) and
+one of the characters may optionally be underlined using the
+B<underline> option.
+A checkbutton has
+all of the behavior of a simple button, including the
+following: it can display itself in either of three different
+ways, according to the B<state> option;
+it can be made to appear
+raised, sunken, or flat; it can be made to flash; and it invokes
+a L<perl/Tk callback|Tk::callbacks> whenever mouse button 1 is clicked over the
+checkbutton.
+
+In addition, checkbuttons can be I<selected>.
+If a checkbutton is selected then the indicator is normally
+drawn with a selected appearance, and
+a Tcl variable associated with the checkbutton is set to a particular
+value (normally 1).
+Under Unix, the indicator is drawn with a sunken relief and a special
+color. Under Windows, the indicator is drawn with a check mark inside.
+If the checkbutton is not selected, then the indicator is drawn with a
+deselected appearance, and the associated variable is
+set to a different value (typically 0).
+Under Unix, the indicator is drawn with a raised relief and no special
+color. Under Windows, the indicator is drawn without a check mark inside.
+By default, the name of the variable associated with a checkbutton is the
+same as the I<name> used to create the checkbutton.
+The variable name, and the ``on'' and ``off'' values stored in it,
+may be modified with options on the command line or in the option
+database.
+Configuration options may also be used to modify the way the
+indicator is displayed (or whether it is displayed at all).
+By default a checkbutton is configured to select and deselect
+itself on alternate button clicks.
+In addition, each checkbutton monitors its associated variable and
+automatically selects and deselects itself when the variables value
+changes to and from the button's ``on'' value.
+
+=head1 WIDGET METHODS
+
+The B<Checkbutton> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for checkbutton widgets:
+
+=over 4
+
+=item I<$checkbutton>-E<gt>B<deselect>
+
+Deselects the checkbutton and sets the associated variable to its ``off''
+value.
+
+=item I<$checkbutton>-E<gt>B<flash>
+
+Flashes the checkbutton. This is accomplished by redisplaying the checkbutton
+several times, alternating between active and normal colors. At
+the end of the flash the checkbutton is left in the same normal/active
+state as when the command was invoked.
+This command is ignored if the checkbutton's state is B<disabled>.
+
+=item I<$checkbutton>-E<gt>B<invoke>
+
+Does just what would have happened if the user invoked the checkbutton
+with the mouse: toggle the selection state of the button and invoke
+the L<perl/Tk callback|Tk::callbacks> associated with the checkbutton, if there is one.
+The return value is the return value from the L<perl/Tk callback|Tk::callbacks>, or an
+empty string if there is no command associated with the checkbutton.
+This command is ignored if the checkbutton's state is B<disabled>.
+
+=item I<$checkbutton>-E<gt>B<select>
+
+Selects the checkbutton and sets the associated variable to its ``on''
+value.
+
+=item I<$checkbutton>-E<gt>B<toggle>
+
+Toggles the selection state of the button, redisplaying it and
+modifying its associated variable to reflect the new state.
+
+=back
+
+=head1 BINDINGS
+
+Tk automatically creates class bindings for checkbuttons that give them
+the following default behavior:
+
+=over 4
+
+=item [1]
+
+On Unix systems, a checkbutton activates whenever the mouse passes
+over it and deactivates whenever the mouse leaves the checkbutton. On
+Mac and Windows systems, when mouse button 1 is pressed over a
+checkbutton, the button activates whenever the mouse pointer is inside
+the button, and deactivates whenever the mouse pointer leaves the
+button.
+
+=item [2]
+
+When mouse button 1 is pressed over a checkbutton, it is invoked (its
+selection state toggles and the command associated with the button is
+invoked, if there is one).
+
+=item [3]
+
+When a checkbutton has the input focus, the space key causes the checkbutton
+to be invoked. Under Windows, there are additional key bindings; plus
+(+) and equal (=) select the button, and minus (-) deselects the button.
+
+If the checkbutton's state is B<disabled> then none of the above
+actions occur: the checkbutton is completely non-responsive.
+
+The behavior of checkbuttons can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 KEYWORDS
+
+checkbutton, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Clipboard.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Clipboard.pm
new file mode 100755
index 00000000000..b0eb0ea2b07
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Clipboard.pm
@@ -0,0 +1,122 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Clipboard;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use AutoLoader qw(AUTOLOAD);
+use Tk qw(catch);
+
+sub clipEvents
+{
+ return qw[Copy Cut Paste];
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ foreach my $op ($class->clipEvents)
+ {
+ $mw->Tk::bind($class,"<<$op>>","clipboard$op");
+ }
+ return $class;
+}
+
+sub clipboardSet
+{
+ my $w = shift;
+ $w->clipboardClear;
+ $w->clipboardAppend(@_);
+}
+
+sub clipboardCopy
+{
+ my $w = shift;
+ my $val = $w->getSelected;
+ if (defined $val)
+ {
+ $w->clipboardSet('--',$val);
+ }
+ return $val;
+}
+
+sub clipboardCut
+{
+ my $w = shift;
+ my $val = $w->clipboardCopy;
+ if (defined $val)
+ {
+ $w->deleteSelected;
+ }
+ return $val;
+}
+
+sub clipboardGet
+{
+ my $w = shift;
+ $w->SelectionGet('-selection','CLIPBOARD',@_);
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ local $@;
+ catch
+ {
+## Different from Tcl/Tk version:
+# if ($w->windowingsystem eq 'x11')
+# {
+# catch
+# {
+# $w->deleteSelected;
+# };
+# }
+ $w->insert("insert", $w->clipboardGet);
+ $w->SeeInsert if $w->can('SeeInsert');
+ };
+}
+
+sub clipboardOperations
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ while (@_)
+ {
+ my $op = shift;
+ $mw->Tk::bind(@class,"<<$op>>","clipboard$op");
+ }
+}
+
+# These methods work for Entry and Text
+# and can be overridden where they don't work
+
+sub deleteSelected
+{
+ my $w = shift;
+ catch { $w->delete('sel.first','sel.last') };
+}
+
+
+1;
+__END__
+
+sub getSelected
+{
+ my $w = shift;
+ my $val = Tk::catch { $w->get('sel.first','sel.last') };
+ return $val;
+}
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Clipboard.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Clipboard.pod
new file mode 100755
index 00000000000..15c8ce2b623
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Clipboard.pod
@@ -0,0 +1,89 @@
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::clipboard - Manipulate Tk clipboard
+
+=for category User Interaction
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<clipboard>I<Option>?(I<args>)?
+
+=head1 DESCRIPTION
+
+This command provides an interface to the Tk clipboard,
+which stores data for later retrieval using the selection mechanism.
+In order to copy data into the clipboard, B<clipboardClear> must
+be called, followed by a sequence of one or more calls to
+B<clipboardAppend>. To ensure that the clipboard is updated atomically, all
+appends should be completed before returning to the event loop.
+
+The following methods are currently supported:
+
+=over 4
+
+=item I<$widget>-E<gt>B<clipboardClear>
+
+Claims ownership of the clipboard on I<$widget>'s display and removes
+any previous contents. Returns an empty string.
+
+=item I<$widget>-E<gt>B<clipboardAppend>(?B<-format>=E<gt>I<format>?,?B<-type>=E<gt>I<type>?,?B<-->?,I<data>)
+
+Appends I<data> to the clipboard on $widget's
+display in the form given by I<type> with the representation given
+by I<format> and claims ownership of the clipboard on $widget's
+display.
+
+=over 4
+
+I<Type> specifies the form in which the selection is to be returned
+(the desired ``target'' for conversion, in ICCCM terminology), and
+should be an atom name such as STRING or FILE_NAME; see the
+Inter-Client Communication Conventions Manual for complete details.
+I<Type> defaults to STRING.
+
+The I<format> argument specifies the representation that should be
+used to transmit the selection to the requester (the second column of
+Table 2 of the ICCCM), and defaults to STRING. If I<format> is
+STRING, the selection is transmitted as 8-bit ASCII characters.
+See the L<Tk::Selection> documentation for explanation of what happens
+if I<format> is not STRING.
+Note that arguments passed to
+B<clipboardAppend> are concatenated before conversion, so the
+caller must take care to ensure appropriate spacing across string
+boundaries. All items appended to the clipboard with the same
+I<type> must have the same I<format>.
+
+A B<--> argument may be specified to mark the end of options: the
+next argument will always be used as I<data>.
+This feature may be convenient if, for example, I<data> starts
+with a B<->.
+
+=back
+
+=back
+
+=over 4
+
+=item I<$widget>-E<gt>B<clipboardGet>( ?-type? );
+
+Retrieve data from the clipboard on I<widget>'s display.
+I<-type> specifies the form in which the data is
+to be returned and should be an atom name such as STRING or
+FILE_NAME. Type defaults to STRING. This command is equivalent
+to C<selectionGet( -selection =E<gt> 'CLIPBOARD' )>.
+
+=back
+
+=head1 KEYWORDS
+
+clear, format, clipboard, append, selection, type
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/CmdLine.pm b/Master/tlpkg/tlperl.straw/lib/Tk/CmdLine.pm
new file mode 100755
index 00000000000..ebe43a7f1e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/CmdLine.pm
@@ -0,0 +1,497 @@
+package Tk::CmdLine; # -*-Perl-*-
+
+#/----------------------------------------------------------------------------//
+#/ Module: Tk/CmdLine.pm
+#/
+#/ Purpose:
+#/
+#/ Process standard X11 command line options and set initial resources.
+#/
+#/ Author: ???? Date: ????
+#/
+#/ History: SEE POD
+#/----------------------------------------------------------------------------//
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $
+
+use 5.004;
+
+use strict;
+
+use Config;
+
+my $OBJECT = undef; # define the current object
+
+#/----------------------------------------------------------------------------//
+#/ Constructor
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub new # Tk::CmdLine::new()
+{
+ my $this = shift(@_);
+ my $class = ref($this) || $this;
+
+ my $name = 'pTk';
+ $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e'));
+
+ my $self = {
+ name => $name,
+ config => { -name => $name },
+ options => {},
+ methods => {},
+ command => [],
+ synchronous => 0,
+ iconic => 0,
+ motif => ($Tk::strictMotif || 0),
+ resources => {} };
+
+ return bless($self, $class);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Process the arguments in a given array or in @ARGV.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub Argument_ # Tk::CmdLine::Argument_($flag) # private method
+{
+ my $self = shift(@_);
+ my $flag = shift(@_);
+ unless ($self->{offset} < @{$self->{argv}})
+ {
+ die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n";
+ }
+ return splice(@{$self->{argv}}, $self->{offset}, 1);
+}
+
+sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{config}->{"-$name"} = $val;
+}
+
+sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ push(@{$self->{command}}, $flag);
+ $self->{$name} = 1;
+}
+
+sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{"*$name"} = $val;
+}
+
+sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{methods}->{$name} = $val;
+}
+
+sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/)
+ {
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{$1} = $2;
+ }
+}
+
+my %Method = (
+ background => 'Option_',
+ bg => 'background', # alias
+ class => 'Config_',
+ display => 'screen', # alias
+ fg => 'foreground', # alias
+ fn => 'font', # alias
+ font => 'Option_',
+ foreground => 'Option_',
+ geometry => 'Method_',
+ iconic => 'Flag_',
+ iconposition => 'Method_',
+ motif => 'Flag_',
+ name => 'Config_',
+ screen => 'Config_',
+ synchronous => 'Flag_',
+ title => 'Config_',
+ xrm => 'Resource_'
+);
+
+sub SetArguments # Tk::CmdLine::SetArguments([@argument])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ $self->{argv} = (@_ ? [ @_ ] : \@ARGV);
+ $self->{offset} = 0; # its existence will denote that this method has been called
+
+ my @option = ();
+
+ while ($self->{offset} < @{$self->{argv}})
+ {
+ last if ($self->{argv}->[$self->{offset}] eq '--');
+ unless (
+ (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) ||
+ (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2))))
+ {
+ ++$self->{offset};
+ next;
+ }
+
+ next if (!exists($Method{$option[0]}) && ++$self->{offset});
+
+ $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}});
+
+ my $method = $Method{$option[0]};
+
+ if (@option > 1) # replace --<option>=<value> with <value>
+ {
+ $self->{argv}->[$self->{offset}] = $option[1];
+ }
+ else # remove the argument
+ {
+ splice(@{$self->{argv}}, $self->{offset}, 1);
+ }
+
+ $self->$method(('-' . $option[0]), $option[0]);
+ }
+
+ $self->{config}->{-class} ||= ucfirst($self->{config}->{-name});
+
+ delete($self->{argv}); # no longer needed
+
+ return $self;
+}
+
+use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy
+
+#/----------------------------------------------------------------------------//
+#/ Get a list of the arguments that have been processed by SetArguments().
+#/ Returns an array.
+#/----------------------------------------------------------------------------//
+
+sub GetArguments # Tk::CmdLine::GetArguments()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return @{$self->{command}};
+}
+
+#/----------------------------------------------------------------------------//
+#/ Get the value of a configuration option (default: -class).
+#/ Returns the option value.
+#/----------------------------------------------------------------------------//
+
+sub cget # Tk::CmdLine::cget([$option])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ my $option = shift(@_) || '-class';
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef);
+}
+
+#/----------------------------------------------------------------------------//
+
+sub CreateArgs # Tk::CmdLine::CreateArgs()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return $self->{config};
+}
+
+#/----------------------------------------------------------------------------//
+
+sub Tk::MainWindow::apply_command_line
+{
+ my $mw = shift(@_);
+
+ my $self = ($OBJECT ||= __PACKAGE__->new());
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ foreach my $priority (keys(%{$self->{resources}}))
+ {
+ foreach my $resource (@{$self->{resources}->{$priority}})
+ {
+ $mw->optionAdd(@{$resource}, $priority);
+ }
+ }
+
+ foreach my $key (keys(%{$self->{options}}))
+ {
+ $mw->optionAdd($key => $self->{options}->{$key}, 'interactive');
+ }
+
+ foreach my $key (keys(%{$self->{methods}}))
+ {
+ $mw->$key($self->{methods}->{$key});
+ }
+
+ if ($self->{methods}->{geometry})
+ {
+ if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/)
+ {
+ $mw->positionfrom('user');
+ }
+ if ($self->{methods}->{geometry} =~ /\d+x\d+/)
+ {
+ $mw->sizefrom('user');
+ }
+ delete $self->{methods}->{geometry}; # XXX needed?
+ }
+
+ $mw->Synchronize() if $self->{synchronous};
+
+ if ($self->{iconic})
+ {
+ $mw->iconify();
+ $self->{iconic} = 0;
+ }
+
+ $Tk::strictMotif = ($self->{motif} || 0);
+
+ # Both these are needed to reliably save state
+ # but 'hostname' is tricky to do portably.
+ # $mw->client(hostname());
+ $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]);
+ $mw->command([ $self->{name}, @{$self->{command}} ]);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Set the initial resources.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+ return $self unless @_;
+
+ my $data = shift(@_);
+ my $priority = shift(@_) || 'userDefault';
+
+ $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority});
+
+ foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data)
+ {
+ if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format
+ {
+ push(@{$self->{resources}->{$priority}}, [ @{$resource} ])
+ if (@{$resource} == 2);
+ }
+ else # resources in resource file format
+ {
+ push(@{$self->{resources}->{$priority}}, [ $1, $2 ])
+ if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/);
+ }
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with
+#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault').
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub LoadResources # Tk::CmdLine::LoadResources([%options])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ my %options = @_;
+
+ my @file = ();
+ my $echo = (exists($options{-echo})
+ ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef);
+
+ unless (%options && (exists($options{-file}) || exists($options{-symbol})))
+ {
+ @file = (
+ { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' },
+ { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } );
+ }
+ else
+ {
+ @file = { %options };
+ }
+
+ my $delimiter = (($^O eq 'MSWin32') ? ';' : ':');
+
+ foreach my $file (@file)
+ {
+ my $fileSpec = $file->{-spec} = undef;
+ if (exists($file->{-symbol}))
+ {
+ my $xpath = undef;
+ if ($file->{-symbol} eq 'XUSERFILESEARCHPATH')
+ {
+ $file->{-priority} ||= 'userDefault';
+ foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME))
+ {
+ last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol}));
+ }
+ next unless defined($xpath);
+ }
+ else
+ {
+ $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH')
+ ? 'startupFile' : 'userDefault');
+ next unless (
+ exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}}));
+ }
+
+ unless (exists($self->{translation}))
+ {
+ $self->{translation} = {
+ '%l' => '', # ignored
+ '%C' => '', # ignored
+ '%S' => '', # ignored
+ '%L' => ($ENV{LANG} || 'C'), # language
+ '%T' => 'app-defaults', # type
+ '%N' => $self->{config}->{-class} # filename
+ };
+ }
+
+ my @postfix = map({ $_ . '/' . $self->{config}->{-class} }
+ ('/' . $self->{translation}->{'%L'}), '');
+
+ ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath))
+ {
+ if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern
+ {
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec, "\n";
+ }
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ last;
+ }
+ else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS>
+ {
+ foreach my $postfix (@postfix)
+ {
+ my $fileSpec2 = $fileSpec . $postfix;
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec2, "\n";
+ }
+ next unless ((-f $fileSpec2) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec2;
+ last ITEM;
+ }
+ }
+ }
+ }
+ elsif (exists($file->{-file}) && ($fileSpec = $file->{-file}))
+ {
+ print $echo 'Checking ', $fileSpec, "\n" if defined($echo);
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ }
+ }
+
+ foreach my $file (@file)
+ {
+ next unless defined($file->{-spec});
+ local *SPEC;
+ next unless open(SPEC,$file->{-spec});
+ print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo);
+
+ my $resource = undef;
+ my @resource = ();
+ my $continuation = 0;
+
+ while (defined(my $line = <SPEC>))
+ {
+ chomp($line);
+ next if ($line =~ /^\s*$/); # skip blank lines
+ next if ($line =~ /^\s*!/); # skip comments
+ $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash
+ unless (defined($resource)) # it is the first line
+ {
+ $resource = $line;
+ }
+ else # it is a continuation line
+ {
+ $line =~ s/^\s*//; # remove leading whitespace
+ $resource .= $line;
+ }
+ next if $continuation;
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ $resource = undef;
+ }
+
+ close(SPEC);
+
+ if (defined($resource)) # special case - EOF after line with trailing backslash
+ {
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ }
+
+ $self->SetResources(\@resource, $file->{-priority}) if @resource;
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/CmdLine.pod b/Master/tlpkg/tlperl.straw/lib/Tk/CmdLine.pod
new file mode 100755
index 00000000000..58b69fded17
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/CmdLine.pod
@@ -0,0 +1,454 @@
+=head1 NAME
+
+Tk::CmdLine - Process standard X11 command line options and set initial resources
+
+=for pm Tk/CmdLine.pm
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+ Tk::CmdLine::SetArguments([@argument]);
+
+ my $value = Tk::CmdLine::cget([$option]);
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]);
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+=head1 DESCRIPTION
+
+Process standard X11 command line options and set initial resources.
+
+The X11R5 man page for X11 says: "Most X programs attempt to use the same names
+for command line options and arguments. All applications written with the
+X Toolkit Intrinsics automatically accept the following options: ...".
+This module processes these command line options for perl/Tk applications
+using the C<SetArguments>() function.
+
+This module can optionally be used to load initial resources explicitly via
+function C<SetResources>(), or from specified files (default: the standard X11
+application-specific resource files) via function C<LoadResources>().
+
+=head2 Command Line Options
+
+=over 4
+
+=item B<-background> I<Color> | B<-bg> I<Color>
+
+Specifies the color to be used for the window background.
+
+=item B<-class> I<Class>
+
+Specifies the class under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-display> I<Display> | B<-screen> I<Display>
+
+Specifies the name of the X server to be used.
+
+=item B<-font> I<Font> | B<-fn> I<Font>
+
+Specifies the font to be used for displaying text.
+
+=item B<-foreground> I<Color> | B<-fg> I<Color>
+
+Specifies the color to be used for text or graphics.
+
+=item B<-geometry> I<Geometry>
+
+Specifies the initial size and location of the I<first>
+L<MainWindow|Tk::MainWindow>.
+
+=item B<-iconic>
+
+Indicates that the user would prefer that the application's windows initially
+not be visible as if the windows had been immediately iconified by the user.
+Window managers may choose not to honor the application's request.
+
+=item B<-motif>
+
+Specifies that the application should adhere as closely as possible to Motif
+look-and-feel standards. For example, active elements such as buttons and
+scrollbar sliders will not change color when the pointer passes over them.
+
+=item B<-name> I<Name>
+
+Specifies the name under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-synchronous>
+
+Indicates that requests to the X server should be sent synchronously, instead of
+asynchronously. Since Xlib normally buffers requests to the server, errors do
+do not necessarily get reported immediately after they occur. This option turns
+off the buffering so that the application can be debugged. It should never
+be used with a working program.
+
+=item B<-title> I<TitleString>
+
+This option specifies the title to be used for this window. This information is
+sometimes used by a window manager to provide some sort of header identifying
+the window.
+
+=item B<-xrm> I<ResourceString>
+
+Specifies a resource pattern and value to override any defaults. It is also
+very useful for setting resources that do not have explicit command line
+arguments.
+
+The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>,
+that is (the first) ':' is used to determine which part is pattern and which
+part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered
+into the options database with B<optionAdd> (for each
+L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority.
+
+=back
+
+=head2 Initial Resources
+
+There are several mechanism for initializing the resource database to be used
+by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file,
+a system application defaults file (e.g.
+/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>),
+or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>).
+The Tk::CmdLine functionality for setting initial resources concerns itself
+with the latter two.
+
+Resource files contain data lines of the form
+E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+They may also contain blank lines and comment lines (denoted
+by a ! character as the first non-blank character). Refer to L<option|Tk::option>
+for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+
+=over 4
+
+=item System Application Defaults Files
+
+System application defaults files may be specified via environment variable
+$C<XFILESEARCHPATH> which, if set, contains a list of file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+
+=item User Application Defaults Files
+
+User application defaults files may be specified via environment variables
+$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument])
+
+Extract the X11 options contained in a specified array (@ARGV by default).
+
+ Tk::CmdLine::SetArguments([@argument])
+
+The X11 options may be specified using a single dash I<-> as per the X11
+convention, or using two dashes I<--> as per the POSIX standard (e.g.
+B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>).
+The options may be interspersed with other options or arguments.
+A I<--> by itself terminates option processing.
+
+By default, command line options are extracted from @ARGV the first time
+a MainWindow is created. The Tk::MainWindow constructor indirectly invokes
+C<SetArguments>() to do this.
+
+=item B<GetArguments> - Tk::CmdLine::GetArguments()
+
+Get a list of the X11 options that have been processed by C<SetArguments>().
+(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+=item B<cget> - Tk::CmdLine::cget([$option])
+
+Get the value of a configuration option specified via C<SetArguments>().
+(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+ Tk::CmdLine::cget([$option])
+
+The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>.
+If no option is specified, B<-class> is implied.
+
+A typical use of C<cget>() might be to obtain the application class in order
+to define the name of a resource file to be loaded in via C<LoadResources>().
+
+ my $class = Tk::CmdLine::cget(); # process command line and return class
+
+=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+Set the initial resources.
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+A single resource may be specified using a string of the form
+'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified
+by passing an array reference whose elements are either strings of the above
+form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>,
+E<lt>I<value>E<gt> ]. The optional second argument specifies the priority,
+as defined in L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+Note that C<SetResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=item B<LoadResources> - Tk::CmdLine::LoadResources([%options])
+
+Load initial resources from one or more files.
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable
+that, if set, defines a list of one or more directories and/or file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+$C<XUSERFILESEARCHPATH> is a special case.
+If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead.
+If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead.
+
+An item is identified as a file pattern if it contains one or more /%[A-Za-z]/
+patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All
+others are replaced with the null string. Pattern B<%L> is translated into
+$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is
+translated into the application class name.
+
+Each file pattern, after substitutions are applied, is assumed to define a
+FileSpec to be examined.
+
+When a directory is specified, FileSpecs
+E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt>
+and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order.
+
+[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in.
+The file is silently skipped if if does not exist, or if it is not readable.
+
+[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in
+L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be
+printed to the corresponding FileHandle (default: \*STDOUT) everytime a file
+is examined / loaded.
+
+If no B<-symbol> or B<-file> options are specified, C<LoadResources>()
+processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and
+$C<XUSERFILESEARCHPATH> with priority I<userDefault>.
+(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to
+contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single
+directory. C<LoadResources>() does not check/care whether this is the case.)
+
+For each set of FileSpecs, C<LoadResources>() examines each FileSpec to
+determine if the file exists and is readable. The first file that meets this
+criteria is read in and C<SetResources>() is invoked.
+
+Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=back
+
+=head1 NOTES
+
+This module is an object-oriented module whose methods can be invoked as object
+methods, class methods or regular functions. This is accomplished via an
+internally-maintained object reference which is created as necessary, and which
+always points to the last object used. C<SetArguments>(), C<SetResources>() and
+C<LoadResources>() return the object reference.
+
+=head1 EXAMPLES
+
+=over
+
+=item 1
+
+@ARGV is processed by Tk::CmdLine at MainWindow creation.
+
+ use Tk;
+
+ # <Process @ARGV - ignoring all X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 2
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+An @ARGV of (--geometry=100x100 -opt1 a b c -bg red)
+is equal to (-opt1 a b c) after C<SetArguments>() is invoked.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 3
+
+Just like 2) except that default arguments are loaded first.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(qw(-name test -iconic));
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 4
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 5
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation
+using non-default priorities.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 65, -symbol => 'XFILESEARCHPATH' );
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 75, -symbol => 'XUSERFILESEARCHPATH' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 6
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+Individual resources are also loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ Tk::CmdLine::SetResources( # set a single resource
+ '*Button*background: red',
+ 'widgetDefault' );
+
+ Tk::CmdLine::SetResources( # set multiple resources
+ [ '*Button*background: red', '*Button*foreground: blue' ],
+ 'widgetDefault' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item B<HOME> (optional)
+
+Home directory which may contain user application defaults files as
+$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>.
+
+=item B<LANG> (optional)
+
+The current language (default: I<C>).
+
+=item B<XFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining system application defaults files.
+
+=item B<XUSERFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining user application defaults files.
+
+=item B<XAPPLRESDIR> (optional)
+
+Directory containing user application defaults files as
+$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or
+$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>.
+
+=back
+
+=head1 SEE ALSO
+
+L<MainWindow|Tk::MainWindow>
+L<option|Tk::option>
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Rewritten as an object-oriented module.
+
+Allow one to process command line options in a specified array (@ARGV by default).
+Eliminate restrictions on the format and location of the options within the array
+(previously the X11 options could not be specified in POSIX format and had to be
+at the beginning of the array).
+
+Added the C<SetResources>() and C<LoadResources>() functions to allow the definition
+of resources prior to MainWindow creation.
+
+=item *
+
+2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Added the C<GetArguments>() method which returns the list of arguments that
+have been processed by C<SetArguments>().
+
+Modified C<LoadResources>() to split the symbols using the OS-dependent
+path delimiter defined in the B<Config> module.
+
+Modified C<LoadResources>() to eliminate a warning message when processing
+patterns B<%l>, B<%C>, B<%S>.
+
+=back
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ColorEdit.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/ColorEdit.xpm
new file mode 100755
index 00000000000..ef3474cd869
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ColorEdit.xpm
@@ -0,0 +1,58 @@
+/* XPM */
+static char * ColorEditor_xpm[] = {
+"48 48 6 1",
+" c #0000FFFF0000",
+". c #FFFFFFFF0000",
+"X c #FFFF00000000",
+"o c #000000000000",
+"O c #0000FFFFFFFF",
+"+ c #00000000FFFF",
+" . . ......X..XXXXXXXXXXXXXXXX",
+" . .X.X. X...XX.XXXXXXXXXXX",
+" . . . ... ...XXXXXXXXXXXXXX",
+" . . .. .....XX.XXXXXXXXXXXX",
+" . .X.X...XXX..XXXXXXXXXXXX",
+" .. . ....X...X.XXXXXXXXX",
+" .. ..X.. . ..X..XXXXXXXX",
+" .... ..X.X..X.XXXXXXX",
+" ... .X. X...X...XX.XXX",
+" . .. ... XX...XXXX..XXXX",
+" ooo o ooo. . .. .X...X..X.XXXXX",
+" oo oo oo. . . . .......X.X.XX",
+" oo o oo . . .. ........XX.XXXX",
+" oo ooo oo ooo Xooo.oo..... X XX.X",
+" oo o oo oo o oo ooo o.. . X...X X",
+" oo oo oo oo oo oo .oo . X.X.....XX ",
+"O oo o oo oo oo oo oo oo. ... X..... .",
+"O O oo oo oo o oo ooo o. oo . ... .X..X",
+"O OOOooooO ooo ooo ooo oo ... ....... X ",
+" O OOO . . .. ... ..",
+"OOO OOOO OO O . .... . . .. .",
+" + O O O O .. .. . .",
+" O OOO OO . .. .... ",
+"OOOOO O OO . .. . ... ",
+"+OOOO OOOO OO O ... .. ..",
+" O+OO OO O . ",
+"OOOOOOOOoooooooOOOO ooo oo .... ",
+"OO++ OOO ooO OoOO oo oo oo .. ",
+"+OOOOOOOOooOOOo O O oo oo .",
+"++OOO +oo+oOO O oo oo ooo ooooo ooo ooo oo. ",
+"+OO O OOoooooO O o ooo oo oo o oo ooo o ",
+"++++ O OooOOoO Ooo Ooo oo oo oo oo oo ",
+"+++OOOO ooOOOoOOooOOooO oo oo oo oo oo ",
+"++++++ Ooo OOoOOooOooo ooo ooo o oo o oo ",
+"+++O+++oooooooOOOooOoooOooo ooo Oooo oo ",
+"++++++++O++OOOO O OOOOOOO ",
+"++O++++O+O+OOOOOOO O O OOOOOO O ",
+"+++O+++OOO+OO OOOO O OO O O O ",
+"++++++++O++O OO OO OO OOO OO O O ",
+"+++++++++++++ OOOOOO OOOO OO OO ",
+"+++++++++++++O+ +O OOOO OOO OOO OOO ",
+"++++++++++++++ OOOOO O OOOOOOOOOO ",
+"+++++++++++++ ++ OO +O OOOOO O O O ",
+"+++++++++++++++O+++O+O+O OOOOOOOOOO O ",
+"+++++++++++++O++++O++ O OOO O OOO OO ",
+"++++++++++++++++O+++O+O+OOOO OOOO O OO ",
+"+++++++++++++++++++O+++ +++O OOOOOO OO O ",
+"++++++++++++++++++++++ +++ O OOOOOOOOO "};
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pm b/Master/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pm
new file mode 100755
index 00000000000..dc31b9c435b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pm
@@ -0,0 +1,768 @@
+package Tk::ColorSelect; # XXX why is this the Tk::ColorSelect package?
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # was: sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev);
+
+require Tk::Frame;
+
+use base qw(Tk::Frame);
+Construct Tk::Widget 'ColorSelect';
+
+sub Populate
+{
+ my ($middle,$args) = @_;
+ my($i, @a);
+ require Tk::Config;
+ my(@xlibpath) = map { s/^-L//; "$_/X11/rgb.txt" }
+ split /\s+/, $Tk::Config::xlib;
+ my %seen_names;
+ foreach $i (@xlibpath,
+ '/usr/local/lib/X11/rgb.txt', '/usr/lib/X11/rgb.txt',
+ '/usr/X11R6/lib/X11/rgb.txt',
+ '/usr/local/X11R5/lib/X11/rgb.txt', '/X11/R5/lib/X11/rgb.txt',
+ '/X11/R4/lib/rgb/rgb.txt', '/usr/openwin/lib/X11/rgb.txt',
+ '/usr/share/X11/rgb.txt', # This is the Debian location
+ ) {
+ local *FOO;
+ next if ! open FOO, $i;
+ my $middle_left = $middle->Frame;
+ $middle_left->pack(
+ -side => 'left',
+ -padx => '0.25c',
+ -pady => '0.25c',
+ );
+ my $names = $middle->Listbox(
+ -width => 20,
+ -height => 12,
+ -relief => 'sunken',
+ -borderwidth => 2,
+ -exportselection => 0,
+ );
+ $middle->Advertise(Names => $names);
+
+ $names->bind('<Double-1>' => [$middle,'color',Ev(['getSelected'])]);
+
+ my $scroll = $middle->Scrollbar(
+ -orient => 'vertical',
+ -command => ['yview', $names],
+ -relief => 'sunken',
+ -borderwidth => 2,
+ );
+ $names->configure(-yscrollcommand => ['set',$scroll]);
+ $names->pack(-in => $middle_left, -side => 'left');
+ $scroll->pack(-in => $middle_left, -side => 'right', -fill => 'y');
+
+ while(<FOO>) {
+ chomp;
+ next if /^!/;
+ my @a = split;
+ my $color = join(' ', @a[3 .. $#a]);
+ my $hex;
+ eval { $hex = $middle->Hex($color); };
+ if ($@) {
+ #print STDERR "unknown color: '$color'\n";
+ if ($@ =~ /unknown color name "/) {
+ next;
+ } else {
+ chomp $@;
+ die $@;
+ }
+ }
+ if (!exists($seen_names{$hex}) ||
+ length($seen_names{$hex}) > length($color)) {
+ $seen_names{$hex} = $color;
+ $names->insert('end', $color);
+ }
+ }
+ close FOO;
+ last;
+ }
+
+ # Create the three scales for editing the color, and the entry for typing
+ # in a color value.
+
+ my $middle_middle = $middle->Frame;
+ $middle_middle->pack(-side => 'left', -expand => 1, -fill => 'y');
+ my $mcm1 = $middle_middle->Optionmenu(-variable => \$middle->{'color_space'},
+ -command => [ $middle, 'color_space'],
+ -relief => 'raised',
+ -options => [ ['HSB color space' => 'hsb'],
+ ['RGB color space' => 'rgb'],
+ ['CMY color space' => 'cmy']]);
+ $mcm1->pack(-side => 'top', -fill => 'x');
+
+ my(@middle_middle, @label, @scale);
+ $middle_middle[0] = $middle_middle->Frame;
+ $middle_middle[1] = $middle_middle->Frame;
+ $middle_middle[2] = $middle_middle->Frame;
+ $middle_middle[3] = $middle_middle->Frame;
+ $middle_middle[0]->pack(-side => 'top', -expand => 1);
+ $middle_middle[1]->pack(-side => 'top', -expand => 1);
+ $middle_middle[2]->pack(-side => 'top', -expand => 1);
+ $middle_middle[3]->pack(-side => 'top', -expand => 1, -fill => 'x');
+ $middle->{'Labels'} = ['zero','one','two'];
+ foreach $i (0..2) {
+ $label[$i] = $middle->Label(-textvariable => \$middle->{'Labels'}[$i]);
+ $scale[$i] = $middle->Scale(
+ -from => 0,
+ -to => 1000,
+ '-length' => '6c',
+ -orient => 'horizontal',
+ -command => [\&scale_changed, $middle],
+ );
+ $scale[$i]->pack(
+ -in => $middle_middle[$i],
+ -side => 'top',
+ -anchor => 'w',
+ );
+ $label[$i]->pack(
+ -in => $middle_middle[$i],
+ -side => 'top',
+ -anchor => 'w',
+ );
+ }
+ my $nameLabel = $middle->Label(-text => 'Name:');
+ $middle->{'Entry'} = '';
+ my $name = $middle->Entry(
+ -relief => 'sunken',
+ -borderwidth => 2,
+ -textvariable => \$middle->{'Entry'},
+ -width => 10,
+# For some reason giving this font causes problems at end of t/create.t
+# -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
+ );
+
+ $nameLabel->pack(-in => $middle_middle[3], -side => 'left');
+ $name->pack(
+ -in => $middle_middle[3],
+ -side => 'right',
+ -expand => 1,
+ -fill => 'x',
+ );
+ $name->bind('<Return>' => [ $middle, 'color', Ev(['get'])]);
+
+ # Create the color display swatch on the right side of the window.
+
+ my $middle_right = $middle->Frame;
+ $middle_right->pack(
+ -side => 'left',
+ -pady => '.25c',
+ -padx => '.25c',
+ -anchor => 's',
+ );
+ my $swatch = $middle->Canvas(
+ -width => '2.5c',
+ -height => '5c',
+ );
+ my $swatch_item = $swatch->create('oval', '.5c', '.3c', '2.26c', '4.76c');
+
+ my $value = $middle->Label(
+ -textvariable => \$middle->{'color'},
+ -width => 13,
+ -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
+ );
+
+ $swatch->pack(
+ -in => $middle_right,
+ -side => 'top',
+ -expand => 1,
+ -fill => 'both',
+ );
+ $value->pack(-in => $middle_right, -side => 'bottom', -pady => '.25c');
+
+ $middle->ConfigSpecs(
+ '-color_space' => ['METHOD', undef, undef, 'hsb'],
+ '-initialcolor' => '-color',
+ '-color' => ['METHOD', 'background', 'Background',
+ $middle->cget('-background')]
+ );
+
+ $middle->{'swatch'} = $swatch;
+ $middle->{'swatch_item'} = $swatch_item;
+ $middle->{'scale'} = [@scale];
+ $middle->{'red'} = 0;
+ $middle->{'blue'} = 0;
+ $middle->{'green'} = 0;
+
+}
+
+sub Hex
+{
+ my $w = shift;
+ my @rgb = (@_ == 3) ? @_ : $w->rgb(@_);
+ sprintf('#%04x%04x%04x',@rgb)
+}
+
+sub color_space {
+
+ my($objref, $space) = @_;
+
+ if (@_ > 1)
+ {
+ my %Labels = ( 'rgb' => [qw(Red Green Blue)],
+ 'cmy' => [qw(Cyan Magenta Yellow)],
+ 'hsb' => [qw(Hue Saturation Brightness)] );
+
+ # The procedure below is invoked when a new color space is selected. It
+ # changes the labels on the scales and re-loads the scales with the
+ # appropriate values for the current color in the new color space
+
+ $space = 'hsb' unless (exists $Labels{$space});
+ my $i;
+ for $i (0..2)
+ {
+ $objref->{'Labels'}[$i] = $Labels{$space}->[$i];
+ }
+ $objref->{'color_space'} = $space;
+ $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
+ }
+ return $objref->{'color_space'};
+} # color_space
+
+sub hsvToRgb {
+
+ # The procedure below converts an HSB value to RGB. It takes hue,
+ # saturation, and value components (floating-point, 0-1.0) as arguments,
+ # and returns a list containing RGB components (integers, 0-65535) as
+ # result. The code here is a copy of the code on page 616 of
+ # "Fundamentals of Interactive Computer Graphics" by Foley and Van Dam.
+
+ my($hue, $sat, $value) = @_;
+ my($v, $i, $f, $p, $q, $t);
+
+ $v = int(65535 * $value);
+ return ($v, $v, $v) if $sat == 0;
+ $hue *= 6;
+ $hue = 0 if $hue >= 6;
+ $i = int($hue);
+ $f = $hue - $i;
+ $p = int(65535 * $value * (1 - $sat));
+ $q = int(65535 * $value * (1 - ($sat * $f)));
+ $t = int(65535 * $value * (1 - ($sat * (1 - $f))));
+ return ($v, $t, $p) if $i == 0;
+ return ($q, $v, $p) if $i == 1;
+ return ($p, $v, $t) if $i == 2;
+ return ($p, $q, $v) if $i == 3;
+ return ($t, $p, $v) if $i == 4;
+ return ($v, $p, $q) if $i == 5;
+
+} # end hsvToRgb
+
+sub color
+{
+ my ($objref,$name) = @_;
+ if (@_ > 1 && defined($name) && length($name))
+ {
+ if ($name eq 'cancel') {
+ $objref->{color} = undef;
+ return;
+ }
+ my ($format, $shift);
+ my ($red, $green, $blue);
+
+ if ($name !~ /^#/)
+ {
+ ($red, $green, $blue) = $objref->{'swatch'}->rgb($name);
+ }
+ else
+ {
+ my $len = length $name;
+ if($len == 4) { $format = '#(.)(.)(.)'; $shift = 12; }
+ elsif($len == 7) { $format = '#(..)(..)(..)'; $shift = 8; }
+ elsif($len == 10) { $format = '#(...)(...)(...)'; $shift = 4; }
+ elsif($len == 13) { $format = '#(....)(....)(....)'; $shift = 0; }
+ else {
+ $objref->BackTrace(
+ "ColorEditor error: syntax error in color name \"$name\"");
+ return;
+ }
+ ($red,$green,$blue) = $name =~ /$format/;
+ # Looks like a call for 'pack' or similar rather than eval
+ eval "\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;";
+ $red = $red << $shift;
+ $green = $green << $shift;
+ $blue = $blue << $shift;
+ }
+ $objref->{'red'} = $red;
+ $objref->{'blue'} = $blue;
+ $objref->{'green'} = $green;
+ my $hex = sprintf('#%04x%04x%04x', $red, $green, $blue);
+ $objref->{'color'} = $hex;
+ $objref->{'Entry'} = $name;
+ $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
+ $objref->{'swatch'}->itemconfigure($objref->{'swatch_item'},
+ -fill => $objref->{'color'});
+ }
+ return $objref->{'color'};
+}
+
+sub rgbToHsv {
+
+ # The procedure below converts an RGB value to HSB. It takes red, green,
+ # and blue components (0-65535) as arguments, and returns a list
+ # containing HSB components (floating-point, 0-1) as result. The code
+ # here is a copy of the code on page 615 of "Fundamentals of Interactive
+ # Computer Graphics" by Foley and Van Dam.
+
+ my($red, $green, $blue) = @_;
+ my($max, $min, $sat, $range, $hue, $rc, $gc, $bc);
+
+ $max = ($red > $green) ? (($blue > $red) ? $blue : $red) :
+ (($blue > $green) ? $blue : $green);
+ $min = ($red < $green) ? (($blue < $red) ? $blue : $red) :
+ (($blue < $green) ? $blue : $green);
+ $range = $max - $min;
+ if ($max == 0) {
+ $sat = 0;
+ } else {
+ $sat = $range / $max;
+ }
+ if ($sat == 0) {
+ $hue = 0;
+ } else {
+ $rc = ($max - $red) / $range;
+ $gc = ($max - $green) / $range;
+ $bc = ($max - $blue) / $range;
+ $hue = ($max == $red)?(0.166667*($bc - $gc)):
+ (($max == $green)?(0.166667*(2 + $rc - $bc)):
+ (0.166667*(4 + $gc - $rc)));
+ }
+ $hue += 1 if $hue < 0;
+ return ($hue, $sat, $max/65535);
+
+} # end rgbToHsv
+
+sub scale_changed {
+
+ # The procedure below is invoked when one of the scales is adjusted. It
+ # propagates color information from the current scale readings to
+ # everywhere else that it is used.
+
+ my($objref) = @_;
+
+ return if $objref->{'updating'};
+ my ($red, $green, $blue);
+
+ if($objref->{'color_space'} eq 'rgb') {
+ $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5);
+ $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5);
+ $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5);
+ } elsif($objref->{'color_space'} eq 'cmy') {
+ $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5);
+ $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5);
+ $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5);
+ } else {
+ ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0,
+ $objref->{'scale'}->[1]->get/1000.0,
+ $objref->{'scale'}->[2]->get/1000.0);
+ }
+ $objref->{'red'} = $red;
+ $objref->{'blue'} = $blue;
+ $objref->{'green'} = $green;
+ $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue));
+ $objref->idletasks;
+
+} # end scale_changed
+
+sub set_scales {
+
+ my($objref) = @_;
+ $objref->{'pending'} = 0;
+ $objref->{'updating'} = 1;
+
+ # The procedure below is invoked to update the scales from the current red,
+ # green, and blue intensities. It's invoked after a change in the color
+ # space and after a named color value has been loaded.
+
+ my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'},
+ $objref->{'green'});
+
+ if($objref->{'color_space'} eq 'rgb') {
+ $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5));
+ $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5));
+ $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5));
+ } elsif($objref->{'color_space'} eq 'cmy') {
+ $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5));
+ $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5));
+ $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5));
+ } else {
+ my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue);
+ $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5));
+ $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5));
+ $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5));
+ }
+ $objref->{'updating'} = 0;
+
+} # end set_scales
+
+package Tk::ColorDialog;
+require Tk::Toplevel;
+use base qw(Tk::Toplevel);
+
+Construct Tk::Widget 'ColorDialog';
+
+sub Accept
+{
+ my $cw = shift;
+ $cw->withdraw;
+ $cw->{'done'} = 1;
+}
+
+sub Cancel
+{
+ my $cw = shift;
+# $cw->configure(-color => undef);
+ $cw->configure(-color => 'cancel');
+ $cw->Accept;
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->SUPER::Populate($args);
+ $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]);
+ $cw->transient($cw->Parent->toplevel);
+ $cw->withdraw;
+ my $sel = $cw->ColorSelect;
+ my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]);
+ my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]);
+ Tk::grid($sel);
+ Tk::grid($accept,$cancel);
+ $cw->ConfigSpecs(DEFAULT => [$sel]);
+}
+
+sub Show
+{
+ my $cw = shift;
+ $cw->configure(@_) if @_;
+ $cw->Popup();
+ $cw->OnDestroy(sub { $cw->{'done'} = 0 }); # auto-cancel
+ $cw->waitVariable(\$cw->{'done'});
+ if (Tk::Exists($cw))
+ {
+ $cw->withdraw;
+ $cw->cget('-color');
+ }
+ else
+ {
+ undef;
+ }
+}
+
+package Tk::ColorEditor;
+
+use vars qw($VERSION $SET_PALETTE);
+$VERSION = '4.009'; # was: sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(lsearch Ev);
+use Tk::Toplevel;
+use base qw(Tk::Toplevel);
+use Tk::widgets qw(Pixmap);
+Construct Tk::Widget 'ColorEditor';
+
+use Tk::Dialog;
+use Tk::Pretty;
+
+BEGIN { $SET_PALETTE = 'Set Palette' };
+
+use subs qw(color_space hsvToRgb rgbToHsv);
+
+# ColorEditor public methods.
+
+sub add_menu_item
+{
+ my $objref = shift;
+ my $value;
+ foreach $value (@_)
+ {
+ if ($value eq 'SEP')
+ {
+ $objref->{'mcm2'}->separator;
+ }
+ else
+ {
+ $objref->{'mcm2'}->command( -label => $value,
+ -command => [ 'configure', $objref, '-highlight' => $value ] );
+ push @{$objref->{'highlight_list'}}, $value;
+ }
+ }
+}
+
+sub set_title
+{
+ my ($w) = @_;
+ my $t = $w->{Configure}{'-title'} || '' ;
+ my $h = $w->{Configure}{'-highlight'} || '';
+ $w->SUPER::title("$t $h Color Editor");
+}
+
+sub highlight
+{
+ my ($w,$h) = @_;
+ if (@_ > 1)
+ {
+ $w->{'update'}->configure( -text => "Apply $h Color" );
+ my $state = ($h eq 'background') ? 'normal' : 'disabled';
+ $w->{'palette'}->entryconfigure( $SET_PALETTE, -state => $state);
+ $w->{'highlight'} = $h;
+ $w->configure(-color => $w->Palette->{$h});
+ $w->set_title;
+ }
+ return $w->{'highlight'};
+}
+
+sub title
+{
+ my ($w,$val) = @_;
+ $w->set_title if (@_ > 1);
+ return $w->{Configure}{'-title'};
+}
+
+sub delete_menu_item
+{
+ my $objref = shift;
+ my $value;
+ foreach $value (@_)
+ {
+ $objref->{'mcm2'}->delete($value);
+ my $list_ord = $value =~ /\d+/ ? $value : lsearch($objref->{'highlight_list'}, $value);
+ splice(@{$objref->{'highlight_list'}}, $list_ord, 1) if $list_ord != -1;
+ }
+}
+
+sub delete_widgets {
+
+ # Remove widgets from consideration by the color configurator.
+ # $widgets_ref points to widgets previously added via `configure'.
+
+ my($objref, $widgets_ref) = @_;
+
+ my($i, $found, $r1, $r2, @wl) = (0, 0, 0, 0, @{$objref->cget(-widgets)});
+ foreach $r1 (@{$widgets_ref}) {
+ $i = -1;
+ $found = 0;
+ foreach $r2 (@wl) {
+ $i++;
+ next if $r1 != $r2;
+ $found = 1;
+ last;
+ }
+ splice(@wl, $i, 1) if $found;
+ }
+ $objref->configure(-widgets => [@wl]);
+
+} # end delete_widgets
+
+sub ApplyDefault
+{
+ my($objref) = @_;
+ my $cb = $objref->cget('-command');
+ my $h;
+ foreach $h (@{$objref->{'highlight_list'}})
+ {
+ next if $h =~ /TEAR_SEP|SEP/;
+ $cb->Call($h);
+ die unless (defined $cb);
+ }
+}
+
+sub Populate
+{
+
+ # ColorEditor constructor.
+
+ my($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+ $cw->withdraw;
+
+ my $color_space = 'hsb'; # rgb, cmy, hsb
+ my(@highlight_list) = qw(
+ TEAR_SEP
+ foreground background SEP
+ activeForeground activeBackground SEP
+ highlightColor highlightBackground SEP
+ selectForeground selectBackground SEP
+ disabledForeground insertBackground selectColor troughColor
+ );
+
+ # Create the Usage Dialog;
+
+ my $usage = $cw->Dialog( '-title' => 'ColorEditor Usage',
+ -justify => 'left',
+ -wraplength => '6i',
+ -text => "The Colors menu allows you to:\n\nSelect a color attribute such as \"background\" that you wish to colorize. Click on \"Apply\" to update that single color attribute.\n\nSelect one of three color spaces. All color spaces display a color value as a hexadecimal number under the oval color swatch that can be directly supplied on widget commands.\n\nApply Tk's default color scheme to the application. Useful if you've made a mess of things and want to start over!\n\nChange the application's color palette. Make sure \"background\" is selected as the color attribute, find a pleasing background color to apply to all current and future application widgets, then select \"Set Palette\".",
+ );
+
+ # Create the menu bar at the top of the window for the File, Colors
+ # and Help menubuttons.
+
+ my $m0 = $cw->Frame(-relief => 'raised', -borderwidth => 2);
+ $m0->pack(-side => 'top', -fill => 'x');
+ my $mf = $m0->Menubutton(
+ -text => 'File',
+ -underline => 0,
+ -bd => 1,
+ -relief => 'raised',
+ );
+ $mf->pack(-side => 'left');
+ my $close_command = [sub {shift->withdraw}, $cw];
+ $mf->command(
+ -label => 'Close',
+ -underline => 0,
+ -command => $close_command,
+ -accelerator => 'Ctrl-w',
+ );
+ $cw->bind('<Control-Key-w>' => $close_command);
+ $cw->protocol(WM_DELETE_WINDOW => $close_command);
+
+ my $mc = $m0->Menubutton(
+ -text => 'Colors',
+ -underline => 0,
+ -bd => 1,
+ -relief => 'raised',
+ );
+ $mc->pack(-side => 'left');
+ my $color_attributes = 'Color Attributes';
+ $mc->cascade(-label => $color_attributes, -underline => 6);
+ $mc->separator;
+
+ $mc->command(
+ -label => 'Apply Default Colors',
+ -underline => 6,
+ -command => ['ApplyDefault',$cw]
+ );
+ $mc->separator;
+ $mc->command(
+ -label => $SET_PALETTE,
+ -underline => 0,
+ -command => sub { $cw->setPalette($cw->cget('-color'))}
+ );
+
+ my $m1 = $mc->cget(-menu);
+
+ my $mcm2 = $m1->Menu;
+ $m1->entryconfigure($color_attributes, -menu => $mcm2);
+ my $mh = $m0->Menubutton(
+ -text => 'Help',
+ -underline => 0,
+ -bd => 1,
+ -relief => 'raised',
+ );
+ $mh->pack(-side => 'right');
+ $mh->command(
+ -label => 'Usage',
+ -underline => 0,
+ -command => [sub {shift->Show}, $usage],
+ );
+
+ # Create the Apply button.
+
+ my $bot = $cw->Frame(-relief => 'raised', -bd => 2);
+ $bot->pack(-side => 'bottom', -fill =>'x');
+ my $update = $bot->Button(
+ -command => [
+ sub {
+ my ($objref) = @_;
+ $objref->Callback(-command => ($objref->{'highlight'}, $objref->cget('-color')));
+ $cw->{'done'} = 1;
+ }, $cw,
+ ],
+ );
+ $update->pack(-pady => 1, -padx => '0.25c');
+
+ # Create the listbox that holds all of the color names in rgb.txt, if an
+ # rgb.txt file can be found.
+
+ my $middle = $cw->ColorSelect(-relief => 'raised', -borderwidth => 2);
+ $middle->pack(-side => 'top', -fill => 'both');
+ # Create the status window.
+
+ my $status = $cw->Toplevel;
+ $status->withdraw;
+ $status->geometry('+0+0');
+ my $status_l = $status->Label(-width => 50, -anchor => 'w');
+ $status_l->pack(-side => 'top');
+
+ $cw->{'highlight_list'} = [@highlight_list];
+ $cw->{'mcm2'} = $mcm2;
+
+ foreach (@highlight_list)
+ {
+ next if /^TEAR_SEP$/;
+ $cw->add_menu_item($_);
+ }
+
+ $cw->{'updating'} = 0;
+ $cw->{'pending'} = 0;
+ $cw->{'Status'} = $status;
+ $cw->{'Status_l'} = $status_l;
+ $cw->{'update'} = $update;
+ $cw->{'gwt_depth'} = 0;
+ $cw->{'palette'} = $mc;
+
+ my $pixmap = $cw->Pixmap('-file' => Tk->findINC('ColorEdit.xpm'));
+ $cw->Icon(-image => $pixmap);
+
+ $cw->ConfigSpecs(
+ DEFAULT => [$middle],
+ -widgets => ['PASSIVE', undef, undef,
+ [$cw->parent->Descendants]],
+ -display_status => ['PASSIVE', undef, undef, 0],
+ '-title' => ['METHOD', undef, undef, ''],
+ -command => ['CALLBACK', undef, undef, ['set_colors',$cw]],
+ '-highlight' => ['METHOD', undef, undef, 'background'],
+ -cursor => ['DESCENDANTS', 'cursor', 'Cursor', 'left_ptr'],
+ );
+
+} # end Populate, ColorEditor constructor
+
+sub Show {
+
+ my($objref, @args) = @_;
+
+ Tk::ColorDialog::Show(@_);
+
+} # end show
+
+# ColorEditor default configurator procedure - can be redefined by the
+# application.
+
+sub set_colors {
+
+ # Configure all the widgets in $widgets for attribute $type and color
+ # $color. If $color is undef then reset all colors
+ # to the Tk defaults.
+
+ my($objref, $type, $color) = @_;
+ my $display = $objref->cget('-display_status');
+
+ $objref->{'Status'}->title("Configure $type");
+ $objref->{'Status'}->deiconify if $display;
+ my $widget;
+ my $reset = !defined($color);
+
+ foreach $widget (@{$objref->cget('-widgets')}) {
+ if ($display) {
+ $objref->{'Status_l'}->configure(
+ -text => 'WIDGET: ' . $widget->PathName
+ );
+ $objref->update;
+ }
+ eval {local $SIG{'__DIE__'}; $color = ($widget->configure("-\L${type}"))[3]} if $reset;
+ eval {local $SIG{'__DIE__'}; $widget->configure("-\L${type}" => $color)};
+ }
+
+ $objref->{'Status'}->withdraw if $display;
+
+} # end set_colors
+
+# ColorEditor private methods.
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pod b/Master/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pod
new file mode 100755
index 00000000000..48e6477f3ef
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ColorEditor.pod
@@ -0,0 +1,120 @@
+
+=head1 NAME
+
+Tk::ColorEditor - a general purpose Tk widget Color Editor
+
+=for pm Tk/ColorEditor.pm
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+ use Tk::ColorEditor;
+
+ $cref = $mw->ColorEditor(-title => $title, -cursor => @cursor);
+
+ $cref->Show;
+
+=head1 DESCRIPTION
+
+ColorEditor is implemented as an object with various methods, described
+below. First, create your ColorEditor object during program initialization
+(one should be sufficient), and then configure it by specifying a list of Tk
+widgets to colorize. When it's time to use the editor, invoke the Show()
+method.
+
+ColorEditor allows some customization: you may alter the color attribute
+menu by adding and/or deleting menu items and/or separators, turn the status
+window on or off, alter the configurator's list of color widgets, or even
+supply your own custom color configurator callback.
+
+=over 4
+
+=item 1.
+
+Call the constructor to create the editor object, which in turn returns a
+blessed reference to the new object:
+
+ use Tk::ColorEditor;
+
+ $cref = $mw->ColorEditor(
+ -title => $title,
+ -cursor => @cursor,
+ );
+
+ mw - a window reference, usually the result of a MainWindow->new
+ call. As the default root of a widget tree, $mw and all
+ descendant widgets at object-creation-time are configured
+ by the default color configurator procedure. (You probably
+ want to change this though or you might end up colorizing
+ ColorEditor!)
+ title - Toplevel title, default = ' '.
+ cursor - a valid Tk '-cursor' specification (default is
+ 'top_left_arrow'). This cursor is used over all ColorEditor
+ "hot spots".
+
+=item 2.
+
+Invoke the configure() method to change editor characteristics:
+
+ $cref->configure(-option => value, ..., -option-n => value-n);
+
+ options:
+ -command : a callback to a `set_colors' replacement.
+ -widgets : a reference to a list of widget references
+ for the color configurator.
+ -display_status : TRUE IFF display the ColorEditor status
+ window when applying colors.
+ -add_menu_item : 'SEP', or a color attribute menu item.
+ -delete_menu_item : 'SEP', a color attribute menu item, or color
+ attribute menu ordinal.
+
+ For example:
+
+ $cref->configure(-delete_menu_item => 3,
+ -delete_menu_item => 'disabledforeground',
+ -add_menu_item => 'SEP',
+ -add_menu_item => 'New color attribute',
+ -widgets => [$ce, $qu, $f2b2],
+ -widgets => [$f2->Descendants],
+ -command => [\&my_special_configurator, some, args ]
+ );
+
+=item 3.
+
+Invoke the Show() method on the editor object, say, by a button or menu press:
+
+ $cref->Show;
+
+=item 4.
+
+The cget(-widgets) method returns a reference to a list of widgets that
+are colorized by the configurator. Typically, you add new widgets to
+this list and then use it in a subsequent configure() call to expand your
+color list.
+
+ $cref->configure(
+ -widgets => [
+ @{$Filesystem_ref->cget(-widgets)}, @{$cref->cget(-widgets)},
+ ]
+ );
+
+=item 5.
+
+The delete_widgets() method expects a reference to a list of widgets which are
+then removed from the current color list.
+
+ $cref->delete_widgets($OBJTABLE{$objname}->{'-widgets'})
+
+=back
+
+=head1 AUTHORS
+
+Stephen O. Lidie, Lehigh University Computing Center. 95/03/05
+lusol@Lehigh.EDU
+
+Many thanks to Guy Decoux (decoux@moulon.inra.fr) for doing the initial
+translation of tcolor.tcl to TkPerl, from which this code has been derived.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Common.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Common.pod
new file mode 100755
index 00000000000..cd53ab79a99
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Common.pod
@@ -0,0 +1,16 @@
+
+=head1 NAME
+
+Tk::DragDrop::Common - private class used by Drag&Drop
+
+=for pm DragDrop/DragDrop/Common.pm
+
+=for category Experimental Modules
+
+=head1 DESCRIPTION
+
+This class provides methods to automate the the loading and declaring
+of Drop and Site 'types'.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Compound.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Compound.pm
new file mode 100755
index 00000000000..9f1ccd64487
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Compound.pm
@@ -0,0 +1,40 @@
+package Tk::Compound;
+require Tk;
+import Tk qw($XS_VERSION);
+require Tk::Image;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Compound/Compound.pm#4 $
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Compound';
+
+bootstrap Tk::Compound;
+
+sub Tk_image { 'compound' }
+
+Tk::Methods('add');
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ my $leaf = $package->Tk_image;
+ $package->InitClass($widget);
+ my $obj = $widget->image(create => $leaf,@_,-window => $widget);
+ return bless($obj,$package);
+}
+
+BEGIN
+ {
+ foreach my $type (qw(line text image bitmap space))
+ {
+ my $meth = ucfirst($type);
+ no strict qw 'refs';
+ *{$meth} = sub { shift->add($type,@_) };
+ }
+ }
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Compound.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Compound.pod
new file mode 100755
index 00000000000..01f6e5f2639
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Compound.pod
@@ -0,0 +1,298 @@
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distrobution are in the file
+# license.tcl.
+
+=head1 NAME
+
+Tk::Compound - Create multi-line compound images.
+
+=for category Tk Image Classes
+
+=head1 SYNOPSIS
+
+ use Tk::Compound;
+ $image = $widget->Compound(name,options);
+ $image->Line(options);
+ $image->Text(options);
+ $image->Bitmap(options);
+ $image->Image(options);
+ $image->Space(options);
+
+=for comment
+This paragraph used to be written different, but perldoc 3.14 cannot
+display this paragraph.
+S< >use Tk::Compound;
+S< >I<$image> = I<$widget>-E<gt>B<Compound>?(I<name>??,I<options>?)
+S< >I<$image>-E<gt>B<Line>?(I<options>?)
+S< >I<$image>-E<gt>B<Text>?(I<options>?)
+S< >I<$image>-E<gt>B<Bitmap>?(I<options>?)
+S< >I<$image>-E<gt>B<Image>?(I<options>?)
+S< >I<$image>-E<gt>B<Space>?(I<options>?)
+
+=head1 DESCRIPTION
+
+Compound image types can be used to create images that consists of
+multiple horizontal lines; each line is composed of a series of items
+(texts, bitmaps, images or spaces) arranged from left to
+right. Compound images are mainly used to embed complex drawings into
+widgets that support the B<-image> option. As shown in the EXAMPLE
+section below, a compound image can be used to display a bitmap and a
+text string simutaneously in a Tk B<Button> widget.
+
+Compound images can only be used on windows on the same display as, and
+with the same pixel depth and visual as the I<$widget> used to create them.
+
+=head1 CREATING COMPOUND IMAGES
+
+Compounds are created using I<$widget>-E<gt>B<Compound>.
+Compounds support the following I<options>:
+
+=over 4
+
+=item B<-background> =E<gt> I<color>
+
+Specifies the background color of the compound image. This color is
+also used as the default background color for the bitmap items in the
+compound image.
+
+=item B<-borderwidth> =E<gt> I<pixels>
+
+Specifies a non-negative value indicating the width of the 3-D border
+drawn around the compound image.
+
+=item B<-font> =E<gt> I<font>
+
+Specifies the default font for the text items in the compound image.
+
+=item B<-foreground> =E<gt> I<color>
+
+Specifies the default foreground color for the bitmap and text items
+in the compound image.
+
+=item B<-padx> =E<gt> I<value>
+
+Specifies a non-negative value indicating how much extra space to
+request for the compound image in the X-direction. The I<value> may
+have any of the forms acceptable to B<Tk_GetPixels(3)>.
+
+=item B<-pady> =E<gt> I<value>
+
+Specifies a non-negative value indicating how much extra space to
+request for the compound image in the Y-direction.
+
+=item B<-relief> =E<gt> I<value>
+
+Specifies the 3-D effect desired for the background of the compound
+image. Acceptable values are B<raised>, B<sunken>, B<flat>,
+B<ridge>, and B<groove>.
+
+=item B<-showbackground> =E<gt> I<value>
+
+Specifies whether the background and the 3D borders should be drawn.
+Must be a valid boolean value. By default the background is not drawn
+and the compound image appears to have a transparent background.
+
+
+=back
+
+=head1 IMAGE COMMAND
+
+When a compound image is created, Tk also creates a new object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+
+The object also supports the following methods:
+
+=over 4
+
+=item I<$compound>-E<gt>B<Line>?(I<option => value ...>)?
+
+Creates a new line at the bottom of the compound image. Lines support
+the following I<options>:
+
+=over 4
+
+=item B<-anchor> value
+
+Specifies how the line should be aligned along the horizontal axis.
+When the values are B<w>, B<sw> or B<nw>, the line is aligned
+to the left. When the values are B<c>, B<s> or B<n>, the line
+is aligned to the middle. When the values are B<e>, B<se> or
+B<ne>, the line is aligned to the right.
+
+=item B<-padx> =E<gt> I<value>
+
+Specifies a non-negative value indicating how much extra space to
+request for this line in the X-direction.
+
+=back
+
+=item I<$compound>-E<gt>I<Itemtype>?(I<option => value ...>)?
+
+Creates a new item of the type I<Itemtype> at the end of the last
+line of the compound image. All types of items support
+these following common I<options>:
+
+=over 4
+
+=item B<-anchor> value
+
+Specifies how the item should be aligned along the vertical axis. When
+the values are B<n>, B<nw> or B<ne>, the item is aligned to
+the top of the line. When the values are B<c>, B<w> or B<e>,
+the item is aligned to the middle of the line. When the values are
+B<s>, B<se> or B<sw>, the item is aligned to the bottom of
+the line.
+
+=item B<-padx> =E<gt> I<value>
+
+Specifies a non-negative value indicating how much extra space to
+request for this item in the X-direction.
+
+=item B<-pady> =E<gt> I<value>
+
+Specifies a non-negative value indicating how much extra space to
+request for this item in the Y-direction.
+
+=item I<item-type> can be any of the following:
+
+=back
+
+=item I<$compound>-E<gt>B<Bitmap>?(I<option => value ...>)?
+
+Creates a new bitmap item of at the end of the last
+line of the compound image. Additional I<options> accepted by the
+bitmap type are:
+
+=over 4
+
+=item B<-background> =E<gt> I<color>
+
+Specifies the background color of the bitmap item.
+
+=item B<-bitmap> =E<gt> I<name>
+
+Specifies a bitmap to display in this item, in any of the forms
+acceptable to B<Tk_GetBitmap(3)>.
+
+=item B<-foreground> =E<gt> I<color>
+
+Specifies the foreground color of the bitmap item.
+
+=back
+
+=item I<$compound>-E<gt>B<Image>?(I<option => value ...>)?
+
+Creates a new image item of at the end of the last
+line of the compound image. Additional I<options> accepted by the
+image type are:
+
+=over 4
+
+=item B<-image> =E<gt> I<name>
+
+Specifies an image to display in this item. I<name>
+must have been created with the B<image create> command.
+
+=back
+
+=item I<$compound>-E<gt>B<Space>?(I<option => value ...>)?
+
+Creates a new space item of at the end of the last line of the
+compound image. Space items do not display anything. They just acts as
+space holders that add additional spaces between items inside a
+compound image. Additional I<options> accepted by the image type
+are:
+
+=over 4
+
+=item B<-width> =E<gt> I<value>
+
+Specifies the width of this space. The I<value> may have any of the
+forms acceptable to B<Tk_GetPixels(3)>.
+
+=item B<-height> =E<gt> I<value>
+
+Specifies the height of this space. The I<value> may have any of
+the forms acceptable to B<Tk_GetPixels(3)>.
+
+=back
+
+=item I<$compound>-E<gt>B<Text>?(I<option => value ...>)?
+
+Creates a new text item of at the end of the last line of the compound
+image. Additional I<options> accepted by the text type are:
+
+=over 4
+
+=item B<-background> =E<gt> I<color>
+
+Specifies the background color of the text item.
+
+=item B<-font> =E<gt> I<name>
+
+Specifies the font to be used for this text item.
+
+=item B<-foreground> =E<gt> I<color>
+
+Specifies the foreground color of the text item.
+
+=item B<-justify> I<value>
+
+When there are multiple lines of text displayed in a text item, this
+option determines how the lines line up with each other. I<value>
+must be one of B<left>, B<center>, or B<right>. B<Left>
+means that the lines' left edges all line up, B<center> means that
+the lines' centers are aligned, and B<right> means that the lines'
+right edges line up.
+
+=item B<-text> =E<gt> I<string>
+
+Specifies a text string to display in this text item.
+
+=item B<-underline> I<value>
+
+Specifies the integer index of a character to underline in the text
+item. 0 corresponds to the first character of the text displayed in
+the text item, 1 to the next character, and so on.
+
+=item B<-wraplength> I<value>
+
+This option specifies the maximum line length of the label string on
+this text item. If the line length of the label string exceeds this
+length, it is wrapped onto the next line, so that no line is longer
+than the specified length. The value may be specified in any of the
+standard forms for screen distances. If this value is less than or
+equal to 0 then no wrapping is done: lines will break only at newline
+characters in the text.
+
+=back
+
+=back
+
+=head1 EXAMPLE
+
+The following example creates a compound image with a bitmap and a
+text string and places this image into a B<Button(n)>
+widget. Notice that the image must be created using the widget
+that it resides in.
+
+ my $b = $parent->Button;
+ my $c = $b->Compound;
+ $b->configure(-image => $c);
+ $c->Line;
+ $c->Bitmap(-bitmap => 'warning');
+ $c->Space(-width => 8);
+ $c->Text(-text => "Warning", -underline => 0);
+ $b->pack;
+
+=head1 KEYWORDS
+
+image(n), Tix(n)
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Config.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Config.pm
new file mode 100755
index 00000000000..9d342cb54ea
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Config.pm
@@ -0,0 +1,13 @@
+# DO NOT EDIT. CREATED AUTOMATICALLY BY myConfig
+package Tk::Config;
+require Exporter;
+use base qw(Exporter);
+$VERSION = '804.028';
+$inc = '-I$(TKDIR)/pTk/mTk/xlib';
+$define = '';
+$xlib = '';
+$xinc = '';
+$gccopt = ' -Wall -Wno-implicit-int -Wno-comment -Wno-unused -D__USE_FIXED_PROTOTYPES__';
+$win_arch = 'MSWin32';
+@EXPORT = qw($VERSION $inc $define $xlib $xinc $gccopt $win_arch);
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ConfigSpecs.pod b/Master/tlpkg/tlperl.straw/lib/Tk/ConfigSpecs.pod
new file mode 100755
index 00000000000..5f90c2716bb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ConfigSpecs.pod
@@ -0,0 +1,262 @@
+# $Id: configspec.pod 1.2 Wed, 12 Nov 1997 00:30:45 +0100 ach $
+
+=head1 NAME
+
+Tk::ConfigSpecs - Defining behaviour of 'configure' for composite widgets.
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ sub Populate
+ {
+ my ($composite,$args) = @_;
+ ...
+ $composite->ConfigSpecs('-attribute' => [ where,dbName,dbClass,default ]);
+ $composite->ConfigSpecs('-alias' => '-otherattribute');
+ $composite->ConfigSpecs('DEFAULT' => [ where ]);
+ $composite->ConfigSpecs($subwidget->ConfigSpecs);
+ ...
+ }
+
+ $composite->configure(-attribute => value);
+
+=head1 DESCRIPTION
+
+The aim is to make the composite widget configure method look as much like
+a regular Tk widget's configure as possible.
+(See L<Tk::options> for a description of this behaviour.)
+To enable this the attributes that the composite as a whole accepts
+needs to be defined.
+
+=head2 Defining the ConfigSpecs for a class.
+
+Typically a widget will have one or more calls like the following
+
+ $composite->ConfigSpecs(-attribute => [where,dbName,dbClass,default]);
+
+in its B<Populate> method. When B<ConfigSpecs> is called this way
+(with arguments) the arguments are used to construct or augment/replace
+a hash table for the widget. (More than one I<-option>=E<gt>I<value>
+pair can be specified to a single call.)
+
+B<dbName>, B<dbClass> and default are only used by B<ConfigDefault> described
+below, or to respond to 'inquiry' configure commands.
+
+It may be either one of the values below, or a list of such values
+enclosed in B<[]>.
+
+The currently permitted values of B<where> are:
+
+=over 4
+
+=item B<'ADVERTISED'>
+
+Apply B<configure> to I<advertised> subwidgets.
+
+=item B<'DESCENDANTS'>
+
+Apply B<configure> recursively to all descendants.
+
+=item B<'CALLBACK'>
+
+Setting the attribute does C<Tk::Callback-E<gt>new($value)> before storing
+in C<$composite-E<gt>{Configure}{-attribute}>. This is appropriate for
+C<-command =E<gt> ...> attributes that are handled by the composite and not
+forwarded to a subwidget. (E.g. B<Tk::Tiler> has C<-yscrollcommand> to
+allow it to have scrollbar attached.)
+
+This may be the first of several 'validating' keywords (e.g. font, cursor,
+anchor etc.) that core Tk makes special for C code.
+
+=item B<'CHILDREN'>
+
+Apply B<configure> to all children. (Children are the immediate
+descendants of a widget.)
+
+=item B<'METHOD'>
+
+Call C<$cw-E<gt>attribute(value)>
+
+This is the most general case. Simply have a method of the composite
+class with the same name as the attribute. The method may do any
+validation and have whatever side-effects you like. (It is probably
+worth 'queueing' using B<afterIdle> for more complex side-effects.)
+
+=item B<'PASSIVE'>
+
+Simply store value in C<$composite-E<gt>{Configure}{-attribute}>.
+
+This form is also a useful placeholder for attributes which you
+currently only handle at create time.
+
+=item B<'SELF'>
+
+Apply B<configure> to the core widget (e.g. B<Frame>) that is the basis of
+the composite. (This is the default behaviour for most attributes which
+makes a simple Frame behave the way you would expect.) Note that once
+you have specified B<ConfigSpecs> for an attribute you must explicitly
+include C<'SELF'> in the list if you want the attribute to apply to the
+composite itself (this avoids nasty infinite recursion problems).
+
+=item B<$reference> (blessed)
+
+Call B<$reference>->configure(-attribute => value)
+
+A common case is where B<$reference> is a subwidget.
+
+$reference may also be result of
+
+ Tk::Config->new(setmethod,getmethod,args,...);
+
+B<Tk::Config> class is used to implement all the above keyword types. The
+class has C<configure> and C<cget> methods so allows higher level code to
+I<always> just call one of those methods on an I<object> of some kind.
+
+=item B<hash reference>
+
+Defining:
+
+ $cw->ConfigSpecs(
+ ...
+ -option => [ { -optionX=>$w1, -optionY=>[$w2, $w3] },
+ dbname dbclass default ],
+ ...
+ );
+
+So C<$cw-E<gt>configure(-option =E<gt> value)> actually does
+
+ $w1->configure(-optionX => value);
+ $w2->configure(-optionY => value);
+ $w3->configure(-optionY => value);
+
+=item B<'otherstring'>
+
+Call
+
+ $composite->Subwidget('otherstring')->configure( -attribute => value );
+
+While this is here for backward compatibility with Tk-b5, it is probably
+better just to use the subwidget reference directly. The only
+case for retaining this form is to allow an additional layer of
+abstraction - perhaps having a 'current' subwidget - this is unproven.
+
+=item B<Aliases>
+
+C<ConfigSpecs( -alias =E<gt> '-otherattribute' )> is used to make C<-alias>
+equivalent to C<-otherattribute>. For example the aliases
+
+ -fg => '-foreground',
+ -bg => '-background'
+
+are provided automatically (if not already specified).
+
+=back
+
+=head2 Delegating all options of a widget class to a subwidget
+
+ $composite->ConfigSpecs($subwidget->ConfigSpecs);
+
+The above generates a list of I<composite> ConfigSpecs arguments, one
+for each valid option in $subwidget's class, and delegates said option
+to $subwidget. See L<Tk::Widget> and the I<widget> method
+ConfigSpecs. Duplicating I<composite> ConfigSpecs and I<widget>
+ConfigSpecs keys will yield undefined results.
+
+
+=head2 Default values
+
+When the B<Populate> method returns B<ConfigDefault> is called. This calls
+
+ $composite->ConfigSpecs;
+
+(with no arguments) to return a reference to a hash. Entries in the hash
+take the form:
+
+ '-attribute' => [ where, dbName, dbClass, default ]
+
+B<ConfigDefault> ignores 'where' completely (and also the DEFAULT entry) and
+checks the 'options' database on the widget's behalf, and if an entry is
+present matching dbName/dbClass
+
+ -attribute => value
+
+is added to the list of options that B<new> will eventually apply to the
+widget. Likewise if there is not a match and default is defined this
+default value will be added.
+
+Alias entries in the hash are used to convert user-specified values for the
+alias into values for the real attribute.
+
+=head2 B<New()-time configure>
+
+Once control returns to B<new>, the list of user-supplied options
+augmented by those from B<ConfigDefault> are applied to the widget using the
+B<configure> method below.
+
+Widgets are most flexible and most Tk-like if they handle the majority of
+their attributes this way.
+
+=head2 Configuring composites
+
+Once the above have occurred calls of the form:
+
+ $composite->configure( -attribute => value );
+
+should behave like any other widget as far as end-user code is concerned.
+B<configure> will be handled by B<Tk::Derived::configure> as follows:
+
+ $composite->ConfigSpecs;
+
+is called (with no arguments) to return a reference to a hash B<-attribute> is
+looked up in this hash, if B<-attribute> is not present in the hash then
+B<'DEFAULT'> is looked for instead. (Aliases are tried as well and cause
+redirection to the aliased attribute). The result should be a reference to a
+list like:
+
+ [ where, dbName, dbClass, default ]
+
+at this stage only I<where> is of interest, it maps to a list of object
+references (maybe only one) foreach one
+
+ $object->configure( -attribute => value );
+
+is B<eval>ed.
+
+=head2 Inquiring attributes of composites
+
+ $composite->cget( '-attribute' );
+
+This is handled by B<Tk::Derived::cget> in a similar manner to configure. At
+present if I<where> is a list of more than one object it is ignored completely
+and the "cached" value in
+
+ $composite->{Configure}{-attribute}.
+
+is returned.
+
+=head1 CAVEATS
+
+The C<-background> and C<-foreground> option values are automatically
+propagated down to all composite widget's children. This may be
+sometimes not desirable, especially if some subwidgets should use own
+color schemes, either by using explicit options or by option database
+definitions. If this is the case, then just add
+
+ -foreground => 'SELF',
+ -background => 'SELF',
+
+to C<ConfigSpecs>.
+
+It is the author's intention to port as many of the "Tix" composite widgets
+as make sense. The mechanism described above may have to evolve in order to
+make this possible, although now aliases are handled I think the above is
+sufficient.
+
+=head1 SEE ALSO
+
+L<Tk::composite|Tk::composite>,
+L<Tk::options|Tk::options>,
+L<Tk::Widget>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Configure.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Configure.pm
new file mode 100755
index 00000000000..26252ae4958
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Configure.pm
@@ -0,0 +1,69 @@
+package Tk::Configure;
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $
+
+use Carp;
+use Tk::Pretty;
+
+
+# Class that handles cget/configure for options that
+# need translating from public form
+# e.g. $cw->configure(-label => 'fred')
+# into $cw->subwiget('label')->configure(-text => 'fred')
+# Should probably do something clever with regexp's here
+
+
+sub new
+{
+ my ($class,@args) = @_;
+ unshift(@args,'configure','cget') if (@args < 3);
+ return bless \@args,$class;
+}
+
+sub cget
+{
+ croak('Wrong number of args to cget') unless (@_ == 2);
+ my ($alias,$key) = @_;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$get(@args);
+}
+
+sub configure
+{
+ my $alias = shift;
+ shift if (@_);
+ my ($set,$get,$widget,@args) = @$alias;
+ if (wantarray)
+ {
+ my @results;
+ eval { @results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return @results;
+ }
+ else
+ {
+ my $results;
+ eval { $results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return $results;
+ }
+}
+
+*TIESCALAR = \&new;
+*TIEHASH = \&new;
+
+sub FETCH
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ return $widget->$get(@args,@_);
+}
+
+sub STORE
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$set(@args,@_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Credits b/Master/tlpkg/tlperl.straw/lib/Tk/Credits
new file mode 100755
index 00000000000..3ea9be43b7d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Credits
@@ -0,0 +1,7 @@
+The two Camel/X 'logo' GIFs were produced by :
+
+Grafix, Sussex, UK, +44-1293-886725
+
+For a very reasonable fee. We have rights to distribute them.
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DItem.pod b/Master/tlpkg/tlperl.straw/lib/Tk/DItem.pod
new file mode 100755
index 00000000000..27db79744df
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DItem.pod
@@ -0,0 +1,439 @@
+=head1 NAME
+
+Tk::DItem - Tix Display Items
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+The Tix B<Display Items> and B<Display Types> are devised to
+solve a general problem: many Tix widgets (both existing and planned
+ones) display many items of many types simultaneously.
+
+For example, a hierarchical listbox widget (see L<Tk::HList>) can display
+items
+of images, plain text and subwindows in the form of a
+hierarchy. Another widget, the tabular listbox widget (see L<Tk::TList>)
+also displays items of the
+same types, although it arranges the items in a tabular form. Yet
+another widget, the spreadsheet widget (see L<Tk::TixGrid>),
+also displays similar types
+items, but in yet another format.
+
+In these examples, the display items in different widgets are only
+different in how they are arranged by the B<host widget>. In Tix,
+display items are clearly separated from the host widgets. The
+advantage is two-fold: first, the creation and configuration of
+display items become uniform across different host widgets. Second,
+new display item types can be added without the need to modify the
+existing host widgets.
+
+In a way, Tix display items are similar to the items inside Tk
+the canvas widget. However, unlike the Tix display items, the canvas
+items are not independent of the canvas widget; this makes it
+impossible to use the canvas items inside other types of TK widgets.
+
+The appearance of a display item is controlled by a set of
+I<attributes>. It is observed that each the attributes usually fall
+into one of two categroies: ``I<individual>'' or
+``I<collective>''. For example, the text items inside a HList widget
+may all display a different text string; however, in most cases, the
+text items share the same color, font and spacing. Instead of keeping
+a duplicated version of the same attributes inside each display item,
+it will be advantageous to put the collective attributes in a
+special object called a B<display style>. First, there is the space
+concern: a host widget may have many thousands of items; keeping
+dupilcated attributes will be very wasteful. Second, when it becomes
+necessary to change a collective attribute, such as changing all the
+text items' foreground color to red, it will be more efficient to
+change only the display style object than to modify all the text
+items one by one.
+
+The attributes of the a display item are thus stored in two places: it
+has a set of B<item options> to store its individual attributes. Each
+display item is also associated with a I<display style>, which specifies
+the collective attributes of all items associated with itself.
+
+The division between the individual and collective attributes are
+fixed and cannot be changed. Thus, when it becomes necessary for some
+items to differ in their collective attributes, two or more B<display styles>
+can be used. For example, suppose you want to display two
+columns of text items inside an HList widget, one column in red and
+the other in blue. You can create a TextStyle object called ``$red''
+which defines a red foreground, and another called ``$blue'', which
+defines a blue foreground. You can then associate all text items of
+the first column to ``$red'' and the second column to ``$blue''
+
+=head1 DISPLAY ITEM TYPES AND OPTIONS
+
+Currently there are three types of display items: B<text>,
+B<imagetext> and I<window>.
+
+=head1 IMAGETEXT ITEMS
+
+Display items of the type B<imagetext> are used to display an image
+together with a text string. Imagetext items support the following options:
+
+=head2 Imagetext Item Options
+
+=over 4
+
+=item Name: B<bitmap>
+
+=item Class: B<Bitmap>
+
+=item Switch: B<-bitmap>
+
+Specifies the bitmap to display in the item.
+
+=item Name: B<image>
+
+=item Class: B<Image>
+
+=item Switch: B<-image>
+
+Specifies the image to display in the item. When both the
+B<-bitmap> and B<-image> options are specified, only the image
+will be displayed.
+
+=item Name: B<imageTextStyle>
+
+=item Class: B<ImageTextStyle>
+
+=item Switch: B<-style>
+
+Specifies the display style to use for this item. Must be the
+name of a B<imagetext> display style that has already be created with
+B<ItemStyle>.
+
+=item Name: B<showImage>
+
+=item Class: B<ShowImage>
+
+=item Switch: B<-showimage>
+
+A Boolean value that specifies whether the image/bitmap should be
+displayed.
+
+=item Name: B<showText>
+
+=item Class: B<ShowText>
+
+=item Switch: B<-showtext>
+
+A Boolean value that specifies whether the text string should be
+displayed.
+
+=item Name: B<text>
+
+=item Class: B<Text>
+
+=item Switch: B<-text>
+
+Specifies the text string to display in the item.
+
+=item Name: B<underline>
+
+=item Class: B<Underline>
+
+=item Switch: B<-underline>
+
+Specifies the integer index of a character to underline in the text
+string in the item. 0 corresponds to the first character of the text
+displayed in the widget, 1 to the next character, and so on.
+
+=back
+
+=head2 Imagetext Style Options
+
+The style information of B<imagetext> items are stored in the
+B<imagetext> display style. The following options are supported:
+
+B<STANDARD OPTIONS>
+
+B<-activebackground> B<-activeforeground>
+B<-anchor> B<-background>
+B<-disabledbackground> B<-disabledforeground>
+B<-foreground> B<-font>
+B<-justify> B<-padx>
+B<-pady> B<-selectbackground>
+B<-selectforeground> B<-wraplength>
+
+See L<Tk::options> for details of the standard options.
+
+B<STYLE-SPECIFIC OPTIONS>
+
+=over 4
+
+=item Name: B<gap>
+
+=item Class: B<Gap>
+
+=item Switch: B<-gap>
+
+Specifies the distance between the bitmap/image and the text string,
+in number of pixels.
+
+=item Name: B<textAnchor>
+
+=item Class: B<TextAnchor>
+
+=item Switch: B<-textanchor>
+
+The anchor position on the image to which text part is attached.
+This is a perl/Tk addition. Defaults to B<e> for compatibility with standard
+Tix. The interesting cases are
+
+=over 8
+
+=item B<n>
+
+Text is centred above the image.
+
+=item B<s>
+
+Text is centred below the image
+
+=item B<e>
+
+Text is centred to right of the image.
+
+=item B<w>
+
+Text is centred to left of the image.
+
+=item B<c>
+
+Text is centred over the image.
+
+=back
+
+The B<sw>, B<se>, B<ne>, and b<nw> cases look rather odd.
+
+To get items to line up correctly it will usually be necessary
+to specify B<-anchor> as well. e.g. with default B<e> then anchoring
+item as a whole B<w> lines images up down left with text stuck to right side.
+
+=back
+
+=head1 TEXT ITEMS
+
+Display items of the type B<text> are used to display a text string
+in a widget. Text items support the following options:
+
+=head2 Text Item Options
+
+=over 4
+
+=item Name: B<textStyle>
+
+=item Class: B<TextStyle>
+
+=item Switch: B<-style>
+
+Specifies the display style to use for this text item. Must be the
+name of a B<text> display style that has already be created with
+B<ItemStyle>.
+
+=item Name: B<text>
+
+=item Class: B<Text>
+
+=item Switch: B<-text>
+
+Specifies the text string to display in the item.
+
+=item Name: B<underline>
+
+=item Class: B<Underline>
+
+=item Switch: B<-underline>
+
+Specifies the integer index of a character to underline in the item.
+0 corresponds to the first character of the text displayed in the
+widget, 1 to the next character, and so on.
+
+=back
+
+=head2 Text Style Options
+
+B<STANDARD OPTIONS>
+
+B<-activebackground> B<-activeforeground>
+B<-anchor> B<-background>
+B<-disabledbackground> B<-disabledforeground>
+B<-foreground> B<-font>
+B<-justify> B<-padx>
+B<-pady> B<-selectbackground>
+B<-selectforeground> B<-wraplength>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WINDOW ITEMS
+
+Display items of the type I<window> are used to display a
+sub-window in a widget. B<Window> items support the following
+options:
+
+=head2 Window Item Options
+
+=over 4
+
+=item Name: B<windowStyle>
+
+=item Class: B<WindowStyle>
+
+=item Switch: B<-style>
+
+Specifies the display style to use for this window item. Must be the
+name of a I<window> display style that has already be created with
+the B<ItemStyle> method.
+
+=item Name: B<window>
+
+=item Class: B<Window>
+
+=item Switch: B<-window>
+
+=item Alias: B<-widget>
+
+Specifies the sub-window to display in the item.
+
+=back
+
+=head2 Window Style Options
+
+B<STYLE STANDARD OPTIONS>
+
+B<-anchor> B<-padx> B<-pady>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 CREATING DISPLAY ITEMS
+
+Display items do not exist on their and thus they cannot be created
+independently of the widgets they reside in. As a rule, display items
+are created by special methods of their ``host'' widgets. For
+example, the HList widgets has a method B<item> which can be used
+to create new display items. The following code creates a new text
+item at the third column of the entry foo inside an HList widget:
+
+ my $hlist = $parent->HList(-columns=>3);
+ $hlist->add('foo');
+ $hlist->itemCreate('foo', 2, -itemtype=>'text', -text=>'Hello');
+
+The B<itemCreate> method of the HList widget accepts a variable
+number of arguments. The special argument B<-itemtype> specifies
+which type of display item to create. Options that are valid for this
+type of display items can then be specified by one or more
+I<option-value> pairs.
+
+After the display item is created, they can then be configured or
+destroyed using the methods provided by the host widget. For example,
+the HList widget has the methods B<itemConfigure>, B<itemCget>
+and B<itemDelete> for accessing the display items.
+
+=head1 CREATING AND MANIPULATING ITEM STYLES
+
+Item styles are created with B<ItemStyle>:
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<ItemStyle>(I<itemType> ?,B<-stylename>=E<gt>I<name>? ?,B<-refwindow>=E<gt>I<pathName>? ?,I<option>=E<gt>I<value>, ...>?);
+
+I<itemType> must be one of the existing display items types such as
+B<text>, B<imagetext>, B<window> or any new types added by
+the user. Additional arguments can be given in one or more
+I<option-value> pairs. I<option> can be any of the valid option
+for this display style or any of the following:
+
+=over 4
+
+=item B<-stylename> =E<gt> I<name>
+
+Specifies a name for this style. If unspecified, then a default name
+will be chosen for this style.
+
+=item B<-refwindow> =E<gt> I<$otherwidget>
+
+Specifies a window to use for determine the default values of the
+display type. If unspecified, the I<$widget> will be used. Default
+values for the display types can be set via the options database. The
+following example sets the B<-disablebackground> and
+B<-disabledforeground> options of a B<text> display style via
+the option database:
+
+ $widget->optionAdd('*table.list*disabledForeground' => 'blue');
+ $widget->optionAdd('*table.list*disabledBackground' => 'darkgray');
+ $widget->ItemStyle('text', -refwindow => $table_list, -fg => 'red');
+
+By using the option database to set the options of the display styles,
+we can advoid hard-coding the option values and give the user more
+flexibility in customization. See L<Tk::option> for a detailed description
+of the option database.
+
+=back
+
+=head1 STYLE METHODS
+
+The B<ItemStyle> method creates an object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+
+The following additional methods are available for item styles:
+
+=over 4
+
+=item I<$style>-E<gt>B<delete>
+
+Destroy this display style object.
+
+=back
+
+=head1 EXAMPLE
+
+The following example creates two columns of data in a HList
+widget. The first column is in red and the second column in blue. The
+colors of the columns are controlled by two different B<text>
+styles. Also, the anchor and font of the second column is chosen so
+that the income data is aligned properly.
+
+ use strict;
+ use Tk;
+ use Tk::HList;
+ use Tk::ItemStyle;
+
+ my $mw = MainWindow->new();
+
+ my $hlist = $mw->HList(-columns=>2)->pack;
+
+ my $red = $hlist->ItemStyle('text', -foreground=>'#800000');
+ my $blue = $hlist->ItemStyle('text', -foreground=>'#000080', -anchor=>'e');
+
+ my $e;
+ foreach ([Joe => '$10,000'], [Peter => '$20,000'],
+ [Raj => '$90,000'], [Zinh => '$0']) {
+ $e = $hlist->addchild("");
+ $hlist->itemCreate($e, 0, -itemtype=>'text',
+ -text=>$_->[0], -style=>$red );
+ $hlist->itemCreate($e, 1, -itemtype=>'text',
+ -text=>$_->[1], -style=>$blue);
+ }
+
+ Tk::MainLoop;
+
+=head1 SEE ALSO
+
+L<Tk::HList|Tk::HList>
+L<Tk::TixGrid|Tk::TixGrid>
+L<Tk::TList|Tk::TList>
+
+=head1 KEYWORDS
+
+display item, display style, item style
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Derived.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Derived.pm
new file mode 100755
index 00000000000..c31c205d2fb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Derived.pm
@@ -0,0 +1,512 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Derived;
+require Tk::Widget;
+require Tk::Configure;
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+$Tk::Derived::Debug = 0;
+
+my $ENHANCED_CONFIGSPECS = 0; # disable for now
+
+use Tk qw(NORMAL_BG BLACK);
+
+sub Subwidget
+{
+ my $cw = shift;
+ my @result = ();
+ if (exists $cw->{SubWidget})
+ {
+ if (@_)
+ {
+ foreach my $name (@_)
+ {
+ push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name});
+ }
+ }
+ else
+ {
+ @result = values %{$cw->{SubWidget}};
+ }
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub _makelist
+{
+ my $widget = shift;
+ my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget);
+ return @specs;
+}
+
+sub Subconfigure
+{
+ # This finds the widget or widgets to to which to apply a particular
+ # configure option
+ my ($cw,$opt) = @_;
+ my $config = $cw->ConfigSpecs;
+ my $widget;
+ my @subwidget = ();
+ my @arg = ();
+ if (defined $opt)
+ {
+ $widget = $config->{$opt};
+ unless (defined $widget)
+ {
+ $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt};
+ }
+ # Handle alias entries
+ if (defined($widget) && !ref($widget))
+ {
+ $opt = $widget;
+ $widget = $config->{$widget};
+ }
+ push(@arg,$opt) unless ($opt eq 'DEFAULT');
+ }
+ $widget = $config->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY'));
+ $widget = $widget->[0];
+ }
+ else
+ {
+ $widget = 'SELF';
+ }
+ foreach $widget (_makelist($widget))
+ {
+ $widget = 'SELF' if (ref($widget) && $widget == $cw);
+ if (ref $widget)
+ {
+ my $ref = ref $widget;
+ if ($ref eq 'ARRAY')
+ {
+ $widget = Tk::Configure->new(@$widget);
+ push(@subwidget,$widget)
+ }
+ elsif ($ref eq 'HASH')
+ {
+ foreach my $key (%$widget)
+ {
+ foreach my $sw (_makelist($widget->{$key}))
+ {
+ push(@subwidget,Tk::Configure->new($sw,$key));
+ }
+ }
+ }
+ else
+ {
+ push(@subwidget,$widget)
+ }
+ }
+ elsif ($widget eq 'ADVERTISED')
+ {
+ push(@subwidget,$cw->Subwidget)
+ }
+ elsif ($widget eq 'DESCENDANTS')
+ {
+ push(@subwidget,$cw->Descendants)
+ }
+ elsif ($widget eq 'CHILDREN')
+ {
+ push(@subwidget,$cw->children)
+ }
+ elsif ($widget eq 'METHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,$method,$cw))
+ }
+ elsif ($widget eq 'SETMETHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'SELF')
+ {
+ push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg))
+ }
+ elsif ($widget eq 'PASSIVE')
+ {
+ push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'CALLBACK')
+ {
+ push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg))
+ }
+ else
+ {
+ push(@subwidget,$cw->Subwidget($widget));
+ }
+ }
+ $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget);
+ return (wantarray) ? @subwidget : $subwidget[0];
+}
+
+sub _cget
+{
+ my ($cw,$opt) = @_;
+ $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2);
+ return $cw->{Configure}{$opt}
+}
+
+sub _configure
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub _callback
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $val = Tk::Callback->new($val) if defined($val) && ref($val);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub cget
+{my ($cw,$opt) = @_;
+ my @result;
+ local $SIG{'__DIE__'};
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ if (wantarray)
+ {
+ eval { @result = $sw->cget($opt) };
+ }
+ else
+ {
+ eval { $result[0] = $sw->cget($opt) };
+ }
+ last unless $@;
+ }
+ return wantarray ? @result : $result[0];
+}
+
+sub Configured
+{
+ # Called whenever a derived widget is re-configured
+ my ($cw,$args,$changed) = @_;
+ if (@_ > 1)
+ {
+ $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed);
+ }
+ return exists $cw->{'Configure'};
+}
+
+sub configure
+{
+ # The default composite widget configuration method uses hash stored
+ # in the widget's hash to map configuration options
+ # onto subwidgets.
+ #
+ my @results = ();
+ my $cw = shift;
+ if (@_ <= 1)
+ {
+ # Enquiry cases
+ my $spec = $cw->ConfigSpecs;
+ if (@_)
+ {
+ # Return info on the nominated option
+ my $opt = $_[0];
+ my $info = $spec->{$opt};
+ unless (defined $info)
+ {
+ $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt};
+ }
+ if (defined $info)
+ {
+ if (ref $info)
+ {
+ # If the default slot is undef then ask subwidgets in turn
+ # for their default value until one accepts it.
+ if ($ENHANCED_CONFIGSPECS && !defined($info->[3]))
+ {local $SIG{'__DIE__'};
+ my @def;
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ eval { @def = $sw->configure($opt) };
+ last unless $@;
+ }
+ $info->[3] = $def[3];
+ $info->[1] = $def[1] unless defined $info->[1];
+ $info->[2] = $def[2] unless defined $info->[2];
+ }
+ push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt));
+ }
+ else
+ {
+ # Real (core) Tk widgets return db name rather than option name
+ # for aliases so recurse to get that ...
+ my @real = $cw->configure($info);
+ push(@results,$opt,$real[1]);
+ }
+ }
+ else
+ {
+ push(@results,$cw->Subconfigure($opt)->configure($opt));
+ }
+ }
+ else
+ {
+ my $opt;
+ my %results;
+ if (exists $spec->{'DEFAULT'})
+ {
+ foreach $opt ($cw->Subconfigure('DEFAULT')->configure)
+ {
+ $results{$opt->[0]} = $opt;
+ }
+ }
+ foreach $opt (keys %$spec)
+ {
+ $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT');
+ }
+ foreach $opt (sort keys %results)
+ {
+ push(@results,$results{$opt});
+ }
+ }
+ }
+ else
+ {
+ my (%args) = @_;
+ my %changed = ();
+ my ($opt,$val);
+ my $config = $cw->TkHash('Configure');
+
+ while (($opt,$val) = each %args)
+ {
+ my $var = \$config->{$opt};
+ my $old = $$var;
+ $$var = $val;
+ my $accepted = 0;
+ my $error = "No widget handles $opt";
+ foreach my $subwidget ($cw->Subconfigure($opt))
+ {
+ next unless (defined $subwidget);
+ eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) };
+ if ($@)
+ {
+ my $val2 = (defined $val) ? $val : 'undef';
+ $error = "Can't set $opt to `$val2' for $cw: " . $@;
+ undef $@;
+ }
+ else
+ {
+ $accepted = 1;
+ }
+ }
+ $cw->BackTrace($error) unless ($accepted);
+ $val = $$var;
+ $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val");
+ }
+ $cw->Configured(\%args,\%changed);
+ }
+ return (wantarray) ? @results : \@results;
+}
+
+sub ConfigDefault
+{
+ my ($cw,$args) = @_;
+
+ $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH');
+
+ my $specs = $cw->ConfigSpecs;
+ # Should we enforce a Delagates(DEFAULT => ) as well ?
+ $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'});
+
+ #
+ # This is a pain with Text or Entry as core widget, they don't
+ # inherit SELF's cursor. So comment it out for Tk402.001
+ #
+ # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'});
+
+ # Now some hacks that cause colours to propogate down a composite widget
+ # tree - really needs more thought, other options adding such as active
+ # colours too and maybe fonts
+
+ my $child = ($cw->children)[0]; # 1st child window (if any)
+
+ unless (exists($specs->{'-background'}))
+ {
+ Tk::catch { $cw->Tk::cget('-background') };
+ my (@bg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@bg,'CHILDREN') if $child;
+ $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG];
+ }
+ unless (exists($specs->{'-foreground'}))
+ {
+ Tk::catch { $cw->Tk::cget('-foreground') };
+ my (@fg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@fg,'CHILDREN') if $child;
+ $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK];
+ }
+ $cw->ConfigAlias(-fg => '-foreground', -bg => '-background');
+
+ # Pre-scan args for aliases - this avoids defaulting
+ # options specified via alias
+ foreach my $opt (keys %$args)
+ {
+ my $info = $specs->{$opt};
+ if (defined($info) && !ref($info))
+ {
+ $args->{$info} = delete $args->{$opt};
+ }
+ }
+
+ # Now walk %$specs supplying defaults for all the options
+ # which have a defined default value, potentially looking up .Xdefaults database
+ # options for the name/class of the 'frame'
+
+ foreach my $opt (keys %$specs)
+ {
+ if ($opt ne 'DEFAULT')
+ {
+ unless (exists $args->{$opt})
+ {
+ my $info = $specs->{$opt};
+ if (ref $info)
+ {
+ # Not an alias
+ if ($ENHANCED_CONFIGSPECS && !defined $info->[3])
+ {
+ # configure inquire to fill in default slot from subwidget
+ $cw->configure($opt);
+ }
+ if (defined $info->[3])
+ {
+ if (defined $info->[1] && defined $info->[2])
+ {
+ # Should we do this on the Subconfigure widget instead?
+ # to match *Entry.Background
+ my $db = $cw->optionGet($info->[1],$info->[2]);
+ $info->[3] = $db if (defined $db);
+ }
+ $args->{$opt} = $info->[3];
+ }
+ }
+ }
+ }
+ }
+}
+
+sub ConfigSpecs
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('ConfigSpecs');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub _alias
+{
+ my ($specs,$opt,$main) = @_;
+ if (exists($specs->{$opt}))
+ {
+ unless (exists $specs->{$main})
+ {
+ my $targ = $specs->{$opt};
+ if (ref($targ))
+ {
+ # opt is a real option
+ $specs->{$main} = $opt
+ }
+ else
+ {
+ # opt is itself an alias
+ # make main point to same place
+ $specs->{$main} = $targ unless $targ eq $main;
+ }
+ }
+ return 1;
+ }
+ return 0;
+}
+
+sub ConfigAlias
+{
+ my $cw = shift;
+ my $specs = $cw->ConfigSpecs;
+ while (@_ >= 2)
+ {
+ my $opt = shift;
+ my $main = shift;
+ unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt))
+ {
+ $cw->BackTrace("Neither $opt nor $main exist");
+ }
+ }
+ $cw->BackTrace('Odd number of args to ConfigAlias') if (@_);
+}
+
+sub Delegate
+{
+ my ($cw,$method,@args) = @_;
+ my $widget = $cw->DelegateFor($method);
+ if ($widget == $cw)
+ {
+ $method = "Tk::Widget::$method"
+ }
+ my @result;
+ if (wantarray)
+ {
+ @result = $widget->$method(@args);
+ }
+ else
+ {
+ $result[0] = $widget->$method(@args);
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub InitObject
+{
+ my ($cw,$args) = @_;
+ $cw->Populate($args);
+ $cw->ConfigDefault($args);
+}
+
+sub ConfigChanged
+{
+ my ($cw,$args) = @_;
+}
+
+sub Advertise
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ my $hash = $cw->TkHash('SubWidget');
+ $hash->{$name} = $widget; # advertise it
+ return $widget;
+}
+
+sub Component
+{
+ my ($cw,$kind,$name,%args) = @_;
+ $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'});
+ # my $pack = delete $args{'-pack'};
+ my $delegate = delete $args{'-delegate'};
+ my $w = $cw->$kind(%args); # Create it
+ # $w->pack(@$pack) if (defined $pack);
+ $cw->Advertise($name,$w) if (defined $name);
+ $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate);
+ return $w; # and return it
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Derived.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Derived.pod
new file mode 100755
index 00000000000..4b99934d5bd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Derived.pod
@@ -0,0 +1,89 @@
+
+=head1 NAME
+
+Tk::Derived - Base class for widgets derived from others
+
+=for pm Tk/Derived.pm
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ package Tk::MyNewWidget;
+
+ use Tk::widgets qw/ BaseWidget, list of Tk widgets /;
+ use base qw/ Tk::Derived Tk::BaseWidget /;
+
+ Construct Tk::Widget 'MyNewWidget';
+
+ sub ClassInit {
+ my( $class, $mw ) = @_;
+ #... e.g., class bindings here ...
+ $class->SUPER::ClassInit( $mw );
+ }
+
+ sub Populate {
+ my( $self, $args ) = @_;
+
+ my $flag = delete $args->{-flag};
+ if( defined $flag ) {
+ # handle -flag => xxx which can only be done at create
+ # time the delete above ensures that new() does not try
+ # and do $self->configure( -flag => xxx );
+ }
+
+ $self->SUPER::Populate( $args );
+
+ $self = $self->Component( ... );
+
+ $self->Delegates( ... );
+
+ $self->ConfigSpecs(
+ '-cursor' => [ SELF, 'cursor', 'Cursor', undef ],
+ '-something' => [ METHOD, dbName, dbClass, default ],
+ '-text' => [ $label, dbName, dbClass, default ],
+ '-heading' => [ {-text => $head},
+ heading, Heading, 'My Heading' ],
+ );
+ }
+
+ sub something {
+ my( $self, $value) = @_;
+ if ( @_ > 1 ) {
+ # set it
+ }
+ return # current value
+ }
+
+=head1 DESCRIPTION
+
+Tk::Derived is used with Perl's multiple inheritance to override some
+methods normally inherited from Tk::Widget.
+
+Tk::Derived should precede any Tk widgets in the class's base class
+definition.
+
+Tk::Derived's main purpose is to apply wrappers to C<configure> and C<cget>
+methods of widgets to allow the derived widget to add to or modify behaviour
+of the configure options supported by the base widget.
+
+The derived class should normally override the C<Populate> method provided
+by Tk::Derived and call C<ConfigSpecs> to declare configure options.
+
+The public methods provided by Tk::Derived are as follows:
+
+=over 4
+
+=item -E<gt>ConfigSpecs(-I<key> =E<gt> [I<kind>, I<name>, I<Class>, I<default>], ...)
+
+=back
+
+=head1 SEE ALSO
+
+L<Tk::ConfigSpecs|Tk::ConfigSpecs>
+L<Tk::mega|Tk::mega>
+L<Tk::composite|Tk::composite>
+
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Dialog.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Dialog.pm
new file mode 100755
index 00000000000..d713814813b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Dialog.pm
@@ -0,0 +1,68 @@
+package Tk::Dialog;
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $
+
+# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on
+# John Stoffel's idea).
+#
+# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27
+# lusol@Lehigh.EDU
+
+# Documentation after __END__
+
+use Carp;
+use strict;
+use base qw(Tk::DialogBox);
+
+Construct Tk::Widget 'Dialog';
+
+sub Populate
+{
+
+ # Dialog object constructor. Uses `new' method from base class
+ # to create object container then creates the dialog toplevel.
+
+ my($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+
+ my ($w_bitmap,$w_but,$pad1,$pad2);
+
+ # Create the Toplevel window and divide it into top and bottom parts.
+
+ my (@pl) = (-side => 'top', -fill => 'both');
+
+ ($pad1, $pad2) =
+ ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']);
+
+
+ $cw->iconname('Dialog');
+
+ my $w_top = $cw->Subwidget('top');
+
+ # Fill the top part with the bitmap and message.
+
+ @pl = (-side => 'left');
+
+ $w_bitmap = $w_top->Label(Name => 'bitmap');
+ $w_bitmap->pack(@pl, @$pad1);
+
+ my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' );
+
+ $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1);
+
+ $cw->Advertise(message => $w_msg);
+ $cw->Advertise(bitmap => $w_bitmap );
+
+ $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef],
+ -bitmap => ['bitmap',undef,undef,undef],
+ -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'],
+ DEFAULT => ['message',undef,undef,undef]
+ );
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Dialog.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Dialog.pod
new file mode 100755
index 00000000000..871206d504c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Dialog.pod
@@ -0,0 +1,107 @@
+# Copyright (c) 1992 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Dialog - Create modal dialog and wait for a response.
+
+=for pm Tk/Dialog.pm
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+S< >I<$dialog> = I<$parent>-E<gt>B<Dialog>(I<-option> =E<gt> I<value>, ... );
+
+=head1 DESCRIPTION
+
+This procedure is part of the Tk script library - its arguments
+describe a dialog box. After creating a dialog box, B<Dialog> waits
+for the user to select one of the Buttons either by clicking on the
+Button with the mouse or by typing return to invoke the default Button
+(if any). Then it returns the text string of the selected Button.
+
+While waiting for the user to respond, B<Dialog> sets a local
+grab. This prevents the user from interacting with the application
+in any way except to invoke the dialog box. See the B<Show()> method.
+
+=head1 OPTIONS
+
+The following option/value pairs are supported:
+
+=over 4
+
+=item B<-title>
+
+Text to appear in the window manager's title bar for the dialog.
+
+=item B<-text>
+
+Message to appear in the top portion of the Dialog.
+
+=item B<-bitmap>
+
+If non-empty, specifies a bitmap to display in the top portion of the
+Dialog, to the left of the text. If this is an empty string then no
+bitmap is displayed in the Dialog.
+
+=item B<-default_button>
+
+Text label string of the Button that displays the default ring.
+
+=item B<-buttons>
+
+A reference to a list of Button label strings. Each I<string>
+specifies text to display in a Button, in order from left to right.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item I<$answer> = $dialog-E<gt>B<Show(>?-global?B<)>;
+
+This method displays the Dialog, waits for the user's response, and stores
+the text string of the selected Button in I<$answer>. If I<-global> is
+specified a global (rather than local) grab is performed.
+
+The actual Dialog is shown using the B<Popup> method. Any other
+options supplied to B<Show> are passed to B<Popup>, and can be used to
+position the Dialog on the screen. Please read Tk::Popup for details.
+
+=back
+
+=head1 ADVERTISED WIDGETS
+
+Because Tk::Dialog is a subclass of Tk::DialogBox it inherits all the
+advertised subwidgets of its superclass: e.g. "B_button-text", where
+'button-text' is a Button's -text value. Additionally, Tk::Dialog
+advertises:
+
+=over 4
+
+=item B<message>
+
+The dialog's Label widget containing the message text.
+
+=item B<bitmap>
+
+The dialog's Label widget containing the bitmap image.
+
+=back
+
+=head1 EXAMPLE
+
+I<$dialog> = I<$mw>-E<gt>B<Dialog>(-text =E<gt> 'Save File?', -bitmap =E<gt> 'question', -title =E<gt> 'Save File Dialog', -default_button =E<gt> 'Yes', -buttons =E<gt> [qw/Yes No Cancel/);
+
+=head1 KEYWORDS
+
+bitmap, dialog, modal, messageBox
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DialogBox.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DialogBox.pm
new file mode 100755
index 00000000000..fa39cf44dde
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DialogBox.pm
@@ -0,0 +1,146 @@
+#
+# DialogBox is similar to Dialog except that it allows any widget
+# in the top frame. Widgets can be added with the add method. Currently
+# there exists no way of deleting a widget once it has been added.
+
+package Tk::DialogBox;
+
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.015'; # was: sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::Toplevel);
+
+Tk::Widget->Construct('DialogBox');
+
+sub Populate {
+ my ($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+ my $buttons = delete $args->{'-buttons'};
+ $buttons = ['OK'] unless defined $buttons;
+ my $default_button = delete $args->{'-default_button'};
+ $default_button = $buttons->[0] unless defined $default_button;
+ my $cancel_button = delete $args->{'-cancel_button'};
+ if (!$cancel_button && @$buttons == 1) {
+ $cancel_button = $buttons->[0];
+ }
+
+ $cw->{'selected_button'} = '';
+ $cw->transient($cw->Parent->toplevel);
+ $cw->withdraw;
+ if ($cancel_button) {
+ $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'cancel_button'}->invoke });
+ } else {
+ $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'selected_button'} = undef });
+ }
+ # Make sure waitVariable exits if a waiting dialog is destroyed
+ $cw->OnDestroy(sub { $cw->{'selected_button'} = $cw->{'selected_button'} });
+
+ # create the two frames
+ my $top = $cw->Component('Frame', 'top');
+ $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
+ my $bot = $cw->Component('Frame', 'bottom');
+ $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
+ $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/);
+ $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/);
+
+ # create a row of buttons in the bottom.
+ my $bl; # foreach my $var: perl > 5.003_08
+ foreach $bl (@$buttons)
+ {
+ my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } );
+ $b->bind('<Return>' => [ $b, 'Invoke']);
+ $cw->Advertise("B_$bl" => $b);
+ if ($Tk::platform eq 'MSWin32')
+ {
+ $b->configure(-width => 10, -pady => 0);
+ }
+ if ($bl eq $default_button) {
+ my $db = $bot->Frame(-relief => 'sunken', -bd => 1);
+ $b->raise($db);
+ $b->pack(-in => $db, -padx => '2', -pady => '2');
+ $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ $cw->{'default_button'} = $b;
+ $cw->bind('<Return>' => [ $b, 'Invoke']);
+ } else {
+ $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ }
+ if (defined $cancel_button && $bl eq $cancel_button) {
+ $cw->{'cancel_button'} = $b;
+ }
+ }
+ if (defined $default_button && !$cw->{'default_button'}) {
+ warn "Default button `$default_button' does not exist.\n";
+ }
+ if (defined $cancel_button && !$cw->{'cancel_button'}) {
+ warn "Cancel button `$cancel_button' does not exist.\n";
+ }
+ $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ],
+ -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'],
+ -background => ['DESCENDANTS', 'background','Background', undef],
+ -focus => ['PASSIVE', undef, undef, undef],
+ -showcommand => ['CALLBACK', undef, undef, undef],
+ );
+ $cw->Delegates('Construct',$top);
+}
+
+sub add {
+ my ($cw, $wnam, @args) = @_;
+ my $w = $cw->Subwidget('top')->$wnam(@args);
+ $cw->Advertise("\L$wnam" => $w);
+ return $w;
+}
+
+sub Wait
+{
+ my $cw = shift;
+ $cw->Callback(-showcommand => $cw);
+ $cw->waitVariable(\$cw->{'selected_button'});
+ $cw->grabRelease if Tk::Exists($cw);
+ $cw->withdraw if Tk::Exists($cw);
+ $cw->Callback(-command => $cw->{'selected_button'});
+}
+
+sub Show {
+
+ croak 'DialogBox: "Show" method requires at least 1 argument'
+ if scalar @_ < 1;
+ my $cw = shift;
+ my ($grab) = @_;
+ my $old_focus = $cw->focusSave;
+ my $old_grab = $cw->grabSave;
+
+ shift if defined $grab && length $grab && ($grab =~ /global/);
+ $cw->Popup(@_);
+
+ Tk::catch {
+ if (defined $grab && length $grab && ($grab =~ /global/)) {
+ $cw->grabGlobal;
+ } else {
+ $cw->grab;
+ }
+ };
+ if (my $focusw = $cw->cget(-focus)) {
+ $focusw->focus;
+ } elsif (defined $cw->{'default_button'}) {
+ $cw->{'default_button'}->focus;
+ } else {
+ $cw->focus;
+ }
+ $cw->Wait;
+ &$old_focus;
+ &$old_grab;
+ return $cw->{'selected_button'};
+}
+
+sub Exit
+{
+ my $cw = shift;
+ #kill the dialogbox, by faking a 'DONE'
+ $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DialogBox.pod b/Master/tlpkg/tlperl.straw/lib/Tk/DialogBox.pod
new file mode 100755
index 00000000000..a091cd98427
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DialogBox.pod
@@ -0,0 +1,156 @@
+
+=head1 NAME
+
+Tk::DialogBox - create and manipulate a dialog screen.
+
+=for pm Tixish/DialogBox.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+ use Tk::DialogBox
+ ...
+ $d = $top->DialogBox(-title => "Title", -buttons => ["OK", "Cancel"]);
+ $w = $d->add(Widget, args)->pack;
+ ...
+ $button = $d->Show;
+
+=head1 DESCRIPTION
+
+B<DialogBox> is very similar to B<Dialog> except that it allows
+any widget in the top Frame. B<DialogBox> creates two
+Frames, I<top> and I<bottom>. The bottom Frame shows all the
+specified Buttons, lined up from left to right. The top Frame acts
+as a container for all other widgets that can be added with the
+B<add()> method.
+
+=head1 OPTIONS
+
+The options recognized by B<DialogBox> are as follows:
+
+=over 4
+
+=item B<-title>
+
+Specify the title of the DialogBox. If this is not set, then the
+name of the program is used.
+
+=item B<-buttons>
+
+The button names to display in the bottom Frame. This is a reference
+to an array of strings containing the text to put on each
+Button. There is no default value for this. If you do not specify any
+button names, no Buttons are displayed.
+
+=item B<-default_button>
+
+Specifies the default Button that is considered invoked when user
+presses <Return> on the DialogBox. This Button is highlighted. If
+no default Button is specified, then the first element of the
+array whose reference is passed to the B<-buttons> option is used
+as the default.
+
+=item B<-cancel_button>
+
+Specifies the Button that is considered invoked when the user closes
+the DialogBox using the window manager's close button. If the
+B<-cancel_button> option is not given, and if there's only one button
+configured, then this button is also used as the cancel button.
+Otherwise no button is considered as the cancel button; in such a case
+B<Show> just returns C<undef> when the user closes the DialogBox.
+
+=item B<-command>
+
+A callback which is executed after invoking an action to close the
+DialogBox, but before restoring focus and grab information. The
+selected button is passed as the first argument.
+
+=item B<-focus>
+
+Specify the widget to receive the initial focus after popping up the
+DialogBox. By default the B<-default_button> widget receives the
+initial focus.
+
+=item B<-showcommand>
+
+A callback which is executed before displaying the DialogBox and
+waiting for user input. The DialogBox itself is passed as the first
+argument.
+
+=back
+
+=head1 METHODS
+
+B<DialogBox> supports only two methods as of now:
+
+=over 4
+
+=item B<add(>I<widget>, I<options>B<)>
+
+Add the widget indicated by I<widget>. I<Widget> can be the name
+of any Tk widget (standard or contributed). I<options> are the
+options that the widget accepts. The widget is advertized as a
+subwidget of B<DialogBox>. The name of I<widget> is
+lower-cased and used as the advertised name. If multiple instances of
+I<widget> are created in the B<DialogBox>, then only the last one gets
+the advertised name. B<add()> does not automatically B<pack()> or
+B<grid()> I<widget> into the B<DialogBox>.
+
+=item B<Show(>I<?-global?>B<)>
+
+Displays the Dialog until the user invokes one of the Buttons in the
+bottom Frame. If the grab type I<-global> is specified, then B<Show>
+uses that grab; otherwise it defaults to a local grab. Returns the
+name of the Button invoked.
+
+The actual Dialog is shown using the B<Popup> method. Any other
+options supplied to B<Show> are passed to B<Popup>, and can be used to
+position the Dialog on the screen. Please read Tk::Popup for details.
+
+=item B<Exit()>
+
+Close the dialogbox, by emulating a click on the default button.
+
+=back
+
+=head1 ADVERTISED WIDGETS
+
+=over 4
+
+=item B<top>
+
+The subwidget reference to the top half of the DialogBox widget, the Frame
+containing widgets added by the B<add> method.
+
+=item B<bottom>
+
+The subwidget reference to the bottom half of the DialogBox widget, the Frame
+containing the Button widgets.
+
+=item B<B_"button-text">
+
+Individual subwidget references to the Buttons in the DialogBox widget. The
+subwidget name is the string I<B_> concatenated with the Button's -text
+value.
+
+=back
+
+=head1 BUGS
+
+There is no way of removing a widget once it has been added to the
+top Frame, unless you access the I<top> subwidget and go through the
+child widgets.
+
+There is no control over the appearance of the Buttons in the
+bottom Frame nor is there any way to control the placement of the
+two Frames with respect to each other.
+
+=head1 AUTHOR
+
+B<Rajappa Iyer> rsi@earthling.net
+
+This code is distributed under the same terms as Perl.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DirTree.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DirTree.pm
new file mode 100755
index 00000000000..bd3e0f85879
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DirTree.pm
@@ -0,0 +1,259 @@
+package Tk::DirTree;
+# DirTree -- TixDirTree widget
+#
+# Derived from DirTree.tcl in Tix 4.1
+#
+# Chris Dean <ctdean@cogit.com>
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.019';
+
+use Tk;
+use Tk::Derived;
+use Tk::Tree;
+use Cwd;
+use DirHandle;
+use File::Spec qw();
+
+use base qw(Tk::Derived Tk::Tree);
+use strict;
+
+Construct Tk::Widget 'DirTree';
+
+my $sep = $^O eq 'MSWin32' ? '\\' : '/';
+
+*_fs_encode = eval { require Encode; 1 } ? sub { Encode::encode("iso-8859-1", $_[0]) } : sub { $_[0] };
+
+sub Populate {
+ my( $cw, $args ) = @_;
+
+ $cw->SUPER::Populate( $args );
+
+ $cw->ConfigSpecs(
+ -dircmd => [qw/CALLBACK dirCmd DirCmd DirCmd/],
+ -showhidden => [qw/PASSIVE showHidden ShowHidden 0/],
+ -image => [qw/PASSIVE image Image folder/],
+ -directory => [qw/SETMETHOD directory Directory ./],
+ -value => '-directory' );
+
+ $cw->configure( -separator => $sep,
+ -itemtype => 'imagetext',
+ );
+}
+
+sub DirCmd {
+ my( $w, $dir, $showhidden ) = @_;
+ $dir .= $sep if $dir =~ /^[a-z]:$/i and $^O eq 'MSWin32';
+ my $h = DirHandle->new( $dir ) or return();
+ my @names = grep( $_ ne '.' && $_ ne '..', $h->read );
+ @names = grep( ! /^[.]/, @names ) unless $showhidden;
+ return( @names );
+}
+
+*dircmd = \&DirCmd;
+
+sub fullpath
+{
+ my ($path) = @_;
+ my $cwd = getcwd();
+ if (CORE::chdir($path))
+ {
+ $path = getcwd();
+ CORE::chdir($cwd) || die "Cannot cd back to $cwd:$!";
+ }
+ else
+ {
+ warn "Cannot cd to $path:$!"
+ }
+ $path = File::Spec->canonpath($path);
+ return $path;
+}
+
+sub directory
+{
+ my ($w,$key,$val) = @_;
+ # We need a value for -image, so its being undefined
+ # is probably caused by order of handling config defaults
+ # so defer it.
+ $w->afterIdle([$w, 'set_dir' => $val]);
+}
+
+sub set_dir {
+ my( $w, $val ) = @_;
+ my $fulldir = fullpath( $val );
+
+ my $parent = $sep;
+ if ($^O eq 'MSWin32')
+ {
+ if ($fulldir =~ s/^([a-z]:)//i)
+ {
+ $parent = $1;
+ }
+ }
+ $w->add_to_tree( $parent, $parent) unless $w->infoExists($parent);
+
+ my @dirs = ($parent);
+ foreach my $name (split( /\Q$sep\E/, $fulldir )) {
+ next unless length $name;
+ push @dirs, $name;
+ my $dir = File::Spec->catfile( @dirs );
+ $w->add_to_tree( $dir, $name, $parent )
+ unless $w->infoExists( $dir );
+ $parent = $dir;
+ }
+
+ $w->OpenCmd( $parent );
+ $w->setmode( $parent, 'close' );
+}
+*chdir = \&set_dir;
+
+
+sub OpenCmd {
+ my( $w, $dir ) = @_;
+
+ my $parent = $dir;
+ foreach my $name ($w->dirnames( $parent )) {
+ next if ($name eq '.' || $name eq '..');
+ my $subdir = File::Spec->catfile( $dir, $name );
+ $subdir = _fs_encode($subdir);
+ next unless -d $subdir;
+ if( $w->infoExists( $subdir ) ) {
+ $w->show( -entry => $subdir );
+ } else {
+ $w->add_to_tree( $subdir, $name, $parent );
+ }
+ }
+}
+
+*opencmd = \&OpenCmd;
+
+sub add_to_tree {
+ my( $w, $dir, $name, $parent ) = @_;
+
+ my $dir8 = _fs_encode($dir);
+ my $image = $w->cget('-image');
+ if ( !UNIVERSAL::isa($image, 'Tk::Image') ) {
+ $image = $w->Getimage( $image );
+ }
+ my $mode = 'none';
+ $mode = 'open' if $w->has_subdir( $dir );
+
+ my @args = (-image => $image, -text => $name);
+ if( $parent ) { # Add in alphabetical order.
+ foreach my $sib ($w->infoChildren( $parent )) {
+ use locale;
+ my $sib8 = _fs_encode($sib);
+ if ($sib8 gt $dir8) {
+ push @args, (-before => $sib);
+ last;
+ }
+ }
+ }
+
+ $w->add( $dir, @args );
+ $w->setmode( $dir, $mode );
+}
+
+sub has_subdir {
+ my( $w, $dir ) = @_;
+ foreach my $name ($w->dirnames( $dir )) {
+ next if ($name eq '.' || $name eq '..');
+ next if ($name =~ /^\.+$/);
+ return( 1 ) if -d File::Spec->catfile( $dir, $name );
+ }
+ return( 0 );
+}
+
+sub dirnames {
+ my( $w, $dir ) = @_;
+ my @names = $w->Callback( '-dircmd', $dir, $w->cget( '-showhidden' ) );
+ return( @names );
+}
+
+{
+ package Tk::DirTreeDialog;
+ use base qw(Tk::Toplevel);
+ Construct Tk::Widget 'DirTreeDialog';
+
+ sub Populate {
+ my($w, $args) = @_;
+ $w->{curr_dir} = delete $args->{-initialdir};
+ if (!defined $w->{curr_dir}) {
+ require Cwd;
+ $w->{curr_dir} = Cwd::cwd();
+ }
+ if (defined $args->{-mustexist}) {
+ die "-mustexist is not yet implemented";
+ }
+ my $title = $args->{-title} || "Choose directory:";
+ delete $args->{-popover};
+
+ $w->title($title);
+ $w->{ok} = 0; # flag: "1" means OK, "-1" means cancelled
+
+ # Create Frame widget before the DirTree widget, so it's always visible
+ # if the window gets resized.
+ my $f = $w->Frame->pack(-fill => "x", -side => "bottom");
+
+ my $d;
+ $d = $w->Scrolled('DirTree',
+ -scrollbars => 'osoe',
+ -width => 35,
+ -height => 20,
+ -selectmode => 'browse',
+ -exportselection => 1,
+ -browsecmd => sub {
+ $w->{curr_dir} = shift;
+ },
+
+ # With this version of -command a double-click will
+ # select the directory
+ -command => sub { $w->{ok} = 1 },
+
+ # With this version of -command a double-click will
+ # open a directory. Selection is only possible with
+ # the Ok button.
+ #-command => sub { $d->opencmd($_[0]) },
+ )->pack(-fill => "both", -expand => 1);
+ # Set the initial directory
+ $d->set_dir($w->{curr_dir});
+
+ $f->Button(-text => 'Ok',
+ -command => sub { $w->{ok} = 1 })->pack(-side => 'left');
+ $f->Button(-text => 'Cancel',
+ -command => sub { $w->{ok} = -1 })->pack(-side => 'left');
+ $w->OnDestroy(sub { $w->{ok} = -1 });
+ }
+
+ sub Show {
+ my $w = shift;
+ my $old_focus = $w->focusSave;
+ my $old_grab = $w->grabSave;
+ Tk::catch {
+ $w->grab;
+ };
+ $w->waitVariable(\$w->{ok});
+ my $ret = $w->{ok} == 1 ? $w->{curr_dir} : undef;
+ $w->grabRelease if Tk::Exists($w);
+ &$old_focus;
+ &$old_grab;
+ $w->destroy if Tk::Exists($w);
+ $ret;
+ }
+}
+
+1;
+
+__END__
+
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distrobution are in the file
+# license.tcl.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DirTree.pod b/Master/tlpkg/tlperl.straw/lib/Tk/DirTree.pod
new file mode 100755
index 00000000000..d8ded2f41b7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DirTree.pod
@@ -0,0 +1,172 @@
+
+=head1 NAME
+
+Tk::DirTree - Create and manipulate DirTree widgets
+
+=for pm Tixish/DirTree.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+S< >B<use Tk::DirTree;>
+
+S< >I<$dirtree> = I<$parent>-E<gt>B<DirTree>(?I<options>?);
+
+=head1 SUPER-CLASS
+
+The B<DirTree> class is derived from the L<Tree|Tk::Tree> class and inherits
+all the methods, options and subwidgets of its super-class.
+
+=head1 STANDARD OPTIONS
+
+B<Tree> supports all the standard options of a Tree widget. See
+L<Tk::options> for details on the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<browseCmd>
+
+=item Class: B<BrowseCmd>
+
+=item Switch: B<-browsecmd>
+
+Specifies a L<callback|Tk::callbacks> to call whenever the user browses on a directory
+(usually by single-clicking on the name of the directory). The callback
+is called with one argument, the complete pathname of the directory.
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies the L<callback|Tk::callbacks> to be called when the user activates on a directory
+(usually by double-clicking on the name of the directory). The callback
+is called with one argument, the complete pathname of the directory.
+
+=item Name: B<dircmd>
+
+=item Class: B<DirCmd>
+
+=item Switch: B<-dircmd>
+
+Specifies the L<callback|Tk::callbacks> to be called when a directory listing is needed
+for a particular directory. If this option is not specified, by
+default the DirTree widget will attempt to read the directory as a
+Unix directory. On special occasions, the application programmer may
+want to supply a special method for reading directories: for example,
+when he needs to list remote directories. In this case, the B<-dircmd>
+option can be used. The specified callback accepts two arguments: the
+first is the name of the directory to be listed; the second is a
+Boolean value indicating whether hidden sub-directories should be
+listed. This callback returns a list of names of the sub-directories of
+this directory. For example:
+
+ sub read_dir {
+ my( $dir, $showhidden ) = @_;
+ return( qw/DOS NORTON WINDOWS/ ) if $dir eq "C:\\";
+ return();
+ }
+
+=item Name: B<showHidden>
+
+=item Class: B<ShowHidden>
+
+=item Switch: B<-showhidden>
+
+Specifies whether hidden directories should be shown. By default, a
+directory name starting with a period "." is considered as a hidden
+directory. This rule can be overridden by supplying an alternative
+B<-dircmd> option.
+
+=item Name: B<directory>
+
+=item Class: B<Directory>
+
+=item Switch: B<-directory>
+
+=item Alias: B<-value>
+
+Specifies the name of the current directory to be displayed in the
+DirTree widget.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<DirTree> constructor method creates a new window (given by the $dirtree
+argument) and makes it into a DirTree widget. Additional options,
+described above, may be specified on the command line or in the
+option database to configure aspects of the DirTree such as its
+cursor and relief. The DirTree widget displays a list view of a
+directory, its previous directories and its sub-directories. The
+user can choose one of the directories displayed in the list or
+change to another directory.
+
+=head1 WIDGET METHODS
+
+The B<DirTree> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for DirTree widgets:
+
+=over 4
+
+=item I<$dirtree>-E<gt>B<chdir>(I<dir>)
+
+Change the current directory to I<dir>.
+
+=back
+
+=head1 OTHER METHODS
+
+These methods have to be documented or made private:
+
+=over 4
+
+=item OpenCmd
+
+=item Populate
+
+=item add_to_tree
+
+=item dirnames
+
+=item fullpath
+
+=item has_subdir
+
+=item opencmd
+
+=item set_dir
+
+=back
+
+=head1 BINDINGS
+
+The mouse and keyboard bindings of the DirTree widget are the same as
+the bindings of the L<Tree|Tk::Tree> widget.
+
+=head1 KEYWORDS
+
+directory, tree, tix
+
+=head1 SEE ALSO
+
+L<Tk::Tree|Tk::Tree>
+L<Tk::HList|Tk::HList>
+
+=head1 AUTHOR
+
+Perl/TK version by Chris Dean <ctdean@cogit.com>. Original Tcl/Tix
+version by Ioi Kim Lam.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Dirlist.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Dirlist.pm
new file mode 100755
index 00000000000..f16ce021f41
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Dirlist.pm
@@ -0,0 +1,113 @@
+package Tk::Dirlist;
+require Tk::Derived;
+require Tk::HList;
+require DirHandle;
+use Cwd;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dirlist.pm#5 $
+
+use base qw(Tk::Derived Tk::HList);
+use strict;
+Construct Tk::Widget 'Dirlist';
+
+sub getimage
+{
+ my ($w,$key) = @_;
+ unless (exists $w->{$key})
+ {
+ $w->{$key} = $w->Pixmap(-id => $key);
+ unless ($w->{$key})
+ {
+ $w->{$key} = $w->Bitmap($key);
+ }
+ }
+ return $w->{$key};
+}
+
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->configure(-separator => '/', -itemtype => 'imagetext');
+ $cw->ConfigSpecs(-directory => ['SETMETHOD','directory','Directory','.']);
+}
+
+sub fullpath
+{
+ my ($path) = @_;
+ my $cwd = getcwd;
+ if (chdir($path))
+ {
+ $path = getcwd;
+ chdir($cwd);
+ }
+ else
+ {
+ warn "Cannot cd to $path:$!"
+ }
+# print "$path\n";
+ return $path;
+}
+
+sub AddDir
+{
+ my ($w,$dir) = @_;
+ my $path = '';
+ my $prefix = '';
+ my $first = 0;
+ my $name;
+ foreach $name (split m#/#,$dir)
+ {
+ $first++;
+ if ($name eq '')
+ {
+ next unless ($first == 1);
+ $path = '/';
+ $name = '/';
+ }
+ else
+ {
+ $path .= $prefix;
+ $path .= $name;
+ $prefix = '/';
+ }
+ unless ($w->info('exists' => $path))
+ {
+# print "Add $path\n";
+ $w->add($path,-image => $w->getimage('folder'), -text => $name);
+ }
+ }
+}
+
+sub choose_image
+{
+ my ($w,$path) = @_;
+ return 'folder' if (-d $path);
+ return 'srcfile' if ($path =~ /\.[ch]$/);
+ return 'textfile' if (-T $path);
+ return 'file';
+}
+
+
+sub directory
+{
+ my ($w,$key,$val) = @_;
+ my $h = DirHandle->new($val);
+ $w->AddDir($val = fullpath($val));
+ my $f;
+ $w->entryconfigure($val,-image => $w->getimage('act_fold'));
+ foreach $f (sort $h->read)
+ {
+ next if ($f =~ /^\.+$/);
+ my $path = "$val/$f";
+ unless ($w->info('exists' => $path))
+ {
+ my $image = $w->getimage($w->choose_image($path));
+ $w->add($path,-image => $image, -text => $f);
+ }
+ }
+ $h->close;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop.pm
new file mode 100755
index 00000000000..bdc54f74367
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop.pm
@@ -0,0 +1,332 @@
+package Tk::DragDrop;
+require Tk::DragDrop::Common;
+require Tk::Toplevel;
+require Tk::Label;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Common Tk::Toplevel);
+
+# This is a little tricky, ISA says 'Toplevel' but we
+# define a Tk_cmd to actually build a 'Label', then
+# use wmRelease in Populate to make it a toplevel.
+
+my $useWmRelease = Tk::Wm->can('release'); # ($^O ne 'MSWin32');
+
+sub Tk_cmd { ($useWmRelease) ? \&Tk::label : \&Tk::toplevel }
+
+Construct Tk::Widget 'DragDrop';
+
+use strict;
+use vars qw(%type @types);
+use Carp;
+
+
+# There is a snag with having a token window and moving to
+# exactly where cursor is - the cursor is "inside" the token
+# window - hence it is not "inside" the dropsite window
+# so we offset X,Y by OFFSET pixels.
+sub OFFSET () {3}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Map>','Mapped');
+ $mw->bind($class,'<Any-KeyPress>','Done');
+ $mw->bind($class,'<Any-ButtonRelease>','Drop');
+ $mw->bind($class,'<Any-Motion>','Drag');
+ return $class;
+}
+
+sub Populate
+{
+ my ($token,$args) = @_;
+ my $parent = $token->parent;
+ if ($useWmRelease)
+ {
+ $token->wmRelease;
+ $token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]);
+ }
+ else
+ {
+ my $lab = $token->Label->pack(-expand => 1, -fill => 'both');
+ bless $lab,ref($token);
+ $lab->bindtags([ref($token), $lab, $token, 'all']);
+ $token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class],
+ DEFAULT => [$lab]);
+ }
+ $token->withdraw;
+ $token->overrideredirect(1);
+ $token->ConfigSpecs(-sitetypes => ['METHOD','siteTypes','SiteTypes',undef],
+ -startcommand => ['CALLBACK',undef,undef,undef],
+ -endcommand => ['CALLBACK',undef,undef,undef],
+ -predropcommand => ['CALLBACK',undef,undef,undef],
+ -postdropcommand => ['CALLBACK',undef,undef,undef],
+ -delta => ['PASSIVE','delta','Delta',10],
+ -cursor => ['SELF','cursor','Cursor','hand2'],
+ -handlers => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]],
+ -selection => ['SETMETHOD','selection','Selection','XdndSelection'],
+ -event => ['SETMETHOD','event','Event','<B1-Motion>']
+ );
+ $token->{InstallHandlers} = 0;
+ $args->{-borderwidth} = 3;
+ $args->{-relief} = 'flat';
+ $args->{-takefocus} = 1;
+}
+
+sub sitetypes
+{
+ my ($w,$val) = @_;
+ confess "Not a widget $w" unless (ref $w);
+ my $var = \$w->{Configure}{'-sitetypes'};
+ if (@_ > 1)
+ {
+ if (defined $val)
+ {
+ $val = [$val] unless (ref $val);
+ my $type;
+ foreach $type (@$val)
+ {
+ Tk::DragDrop->import($type);
+ }
+ }
+ $$var = $val;
+ }
+ return (defined $$var) ? $$var : \@types;
+}
+
+sub SendText
+{
+ my ($w,$offset,$max) = @_;
+ my $s = substr($w->cget('-text'),$offset);
+ $s = substr($s,0,$max) if (length($s) > $max);
+ return $s;
+}
+
+sub handlers
+{
+ my ($token,$opt,$value) = @_;
+ $token->{InstallHandlers} = (defined($value) && @$value);
+ $token->{'handlers'} = $value;
+}
+
+sub selection
+{
+ my ($token,$opt,$value) = @_;
+ my $handlers = $token->{'handlers'};
+ $token->{InstallHandlers} = (defined($handlers) && @$handlers);
+}
+
+sub event
+{
+ my ($w,$opt,$value) = @_;
+ # delete old bindings
+ $w->parent->Tk::bind($value,[$w,'StartDrag']);
+}
+
+#
+
+sub FindSite
+{
+ my ($token,$X,$Y,$e) = @_;
+ my $site;
+ my $types = $token->sitetypes;
+ if (defined $types && @$types)
+ {
+ foreach my $type (@$types)
+ {
+ my $class = $type{$type};
+ last if (defined($class) && ($site = $class->FindSite($token,$X,$Y)));
+ }
+ }
+ else
+ {
+ warn 'No sitetypes';
+ }
+ my $new = $site || 'undef';
+ my $over = $token->{'Over'};
+ if ($over)
+ {
+ if (!$over->Match($site))
+ {
+ $over->Leave($token,$e);
+ delete $token->{'Over'};
+ }
+ }
+ if ($site)
+ {
+ unless ($token->{'Over'})
+ {
+ $site->Enter($token,$e);
+ $token->{'Over'} = $site;
+ }
+ $site->Motion($token,$e) if (defined $site)
+ }
+ return $site;
+}
+
+sub Mapped
+{
+ my ($token) = @_;
+ my $e = $token->parent->XEvent;
+ $token = $token->toplevel;
+ $token->grabGlobal;
+ $token->focus;
+ if (defined $e)
+ {
+ my $X = $e->X;
+ my $Y = $e->Y;
+ $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
+ $token->NewDrag;
+ $token->FindSite($X,$Y,$e);
+ }
+}
+
+sub NewDrag
+{
+ my ($token) = @_;
+ my $types = $token->sitetypes;
+ if (defined $types && @$types)
+ {
+ my $type;
+ foreach $type (@$types)
+ {
+ my $class = $type{$type};
+ if (defined $class)
+ {
+ $class->NewDrag($token);
+ }
+ }
+ }
+}
+
+sub Drag
+{
+ my $token = shift;
+ my $e = $token->XEvent;
+ my $X = $e->X;
+ my $Y = $e->Y;
+ $token = $token->toplevel;
+ $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
+ $token->FindSite($X,$Y,$e);
+}
+
+sub Done
+{
+ my $token = shift;
+ my $e = $token->XEvent;
+ $token = $token->toplevel;
+ my $over = delete $token->{'Over'};
+ $over->Leave($token,$e) if (defined $over);
+ my $w = $token->parent;
+ eval {local $SIG{__DIE__}; $token->grabRelease };
+ $token->withdraw;
+ delete $w->{'Dragging'};
+ $w->update;
+}
+
+sub AcceptDrop
+{
+ my ($token) = @_;
+ $token->configure(-relief => 'sunken');
+ $token->{'Accepted'} = 1;
+}
+
+sub RejectDrop
+{
+ my ($token) = @_;
+ $token->configure(-relief => 'flat');
+ $token->{'Accepted'} = 0;
+}
+
+sub HandleLoose
+{
+ my ($w,$seln) = @_;
+ return '';
+}
+
+sub InstallHandlers
+{
+ my ($token,$seln) = @_;
+ my $w = $token->parent;
+ $token->configure('-selection' => $seln) if $seln;
+ $seln = $token->cget('-selection');
+ if ($token->{InstallHandlers})
+ {
+ foreach my $h (@{$token->cget('-handlers')})
+ {
+ $w->SelectionHandle('-selection' => $seln,@$h);
+ }
+ $token->{InstallHandlers} = 0;
+ }
+ if (!$w->IS($w->SelectionOwner('-selection'=>$seln)))
+ {
+ $w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]);
+ }
+}
+
+sub Drop
+{
+ my $ewin = shift;
+ my $e = $ewin->XEvent;
+ my $token = $ewin->toplevel;
+ my $site = $token->FindSite($e->X,$e->Y,$e);
+ Tk::catch { $token->grabRelease };
+ if (defined $site)
+ {
+ my $seln = $token->cget('-selection');
+ unless ($token->Callback(-predropcommand => $seln, $site))
+ {
+# XXX This is ugly if the user restarts a drag within the 2000 ms:
+# my $id = $token->after(2000,[$token,'Done']);
+ my $w = $token->parent;
+ $token->InstallHandlers;
+ $site->Drop($token,$seln,$e);
+ $token->Callback(-postdropcommand => $seln);
+ $token->Done;
+ }
+ }
+ else
+ {
+ $token->Done;
+ }
+ $token->Callback('-endcommand');
+}
+
+sub StartDrag
+{
+ my $token = shift;
+ my $w = $token->parent;
+ unless ($w->{'Dragging'})
+ {
+ my $e = $w->XEvent;
+ my $X = $e->X;
+ my $Y = $e->Y;
+ my $was = $token->{'XY'};
+ if ($was)
+ {
+ my $dx = $was->[0] - $X;
+ my $dy = $was->[1] - $Y;
+ if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta'))
+ {
+ unless ($token->Callback('-startcommand',$token,$e))
+ {
+ delete $token->{'XY'};
+ $w->{'Dragging'} = $token;
+ $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
+ $token->raise;
+ $token->deiconify;
+ $token->FindSite($X,$Y,$e);
+ }
+ }
+ }
+ else
+ {
+ $token->{'XY'} = [$X,$Y];
+ }
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Common.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Common.pm
new file mode 100755
index 00000000000..de28ce60e8b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Common.pm
@@ -0,0 +1,61 @@
+package Tk::DragDrop::Common;
+
+use strict;
+use Carp;
+
+no warnings 'once'; # cease warning about Tk::DragDrop::type
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/Common.pm#4 $
+
+sub Type
+{
+ my ($base,$name,$class) = @_;
+ no strict 'refs';
+ my $hash = \%{"${base}::type"};
+ my $array = \@{"${base}::types"};
+ unless (exists $hash->{$name})
+ {
+ push(@$array,$name);
+ $class = (caller(0))[0] unless (@_ > 2);
+ $hash->{$name} = $class;
+ # confess "Strange class $class for $base/$name" unless ($class =~ /^Tk/);
+ # print "$base $name is ",$class,"\n";
+ }
+}
+
+sub import
+{
+ my $class = shift;
+ no strict 'refs';
+ my $types = \%{"${class}::type"};
+ while (@_)
+ {
+ my $type = shift;
+ unless (exists $types->{$type})
+ {
+ if ($type eq 'Local')
+ {
+ $class->Type($type,$class);
+ }
+ else
+ {
+ my ($kind) = $class =~ /([A-Z][a-z]+)$/;
+ my $file = Tk->findINC("DragDrop/${type}${kind}.pm");
+ if (defined $file)
+ {
+ # print "Loading $file\n";
+ require $file;
+ }
+ else
+ {
+ croak "Cannot find ${type}${kind}";
+ }
+ }
+ }
+ }
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/LocalDrop.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/LocalDrop.pm
new file mode 100755
index 00000000000..0f5028ae64c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/LocalDrop.pm
@@ -0,0 +1,61 @@
+package Tk::DragDrop::Local;
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/LocalDrop.pm#4 $
+
+use base qw(Tk::DragDrop::Rect);
+require Tk::DragDrop;
+
+my @toplevels;
+
+Tk::DragDrop->Type('Local');
+
+sub XY
+{
+ my ($site,$event) = @_;
+ return ($event->X - $site->X,$event->Y - $site->Y);
+}
+
+sub Apply
+{
+ my $site = shift;
+ my $name = shift;
+ my $cb = $site->{$name};
+ if ($cb)
+ {
+ my $event = shift;
+ $cb->Call(@_,$site->XY($event));
+ }
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$event) = @_;
+ $site->Apply(-dropcommand => $event, $seln);
+ $site->Apply(-entercommand => $event, 0);
+ $token->Done;
+}
+
+sub Enter
+{
+ my ($site,$token,$event) = @_;
+ $token->AcceptDrop;
+ $site->Apply(-entercommand => $event, 1);
+}
+
+sub Leave
+{
+ my ($site,$token,$event) = @_;
+ $token->RejectDrop;
+ $site->Apply(-entercommand => $event, 0);
+}
+
+sub Motion
+{
+ my ($site,$token,$event) = @_;
+ $site->Apply(-motioncommand => $event);
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Rect.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Rect.pm
new file mode 100755
index 00000000000..04cfa8772f2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Rect.pm
@@ -0,0 +1,110 @@
+package Tk::DragDrop::Rect;
+use strict;
+use Carp;
+
+# Proxy class which represents sites to the dropping side
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/;
+
+# Some default methods when called site side
+# XIDs and viewable-ness from widget
+
+# XID of ancestor
+sub ancestor { ${shift->widget->toplevel->WindowId} }
+
+# XID of site window
+sub win { ${shift->widget->WindowId} }
+
+# Is site window mapped
+sub viewable { shift->widget->viewable }
+
+sub Over
+{
+ my ($site,$X,$Y) = @_;
+
+ my $x = $site->X;
+ my $y = $site->Y;
+ my $w = $site->width;
+ my $h = $site->height;
+ my $val = ($X >= $x && $X < ($x + $w) && $Y >= $y && $Y < ($y + $h));
+
+ return 0 unless $val;
+
+ my $widget = $site->widget;
+
+ # Now XTranslateCoords from root window to site window's
+ # ancestor. Ancestors final descendant should be the site window.
+ # Like $win->containing but avoids a problem that dropper's "token"
+ # window may be the toplevel (child of root) that contains X,Y
+ # so if that is in another application ->containing does not
+ # give us a window.
+ my $id = $site->ancestor;
+ while (1)
+ {
+ my $cid = $widget->PointToWindow($X,$Y,$id);
+ last unless $cid;
+ $id = $cid;
+ }
+ return ($id == $site->win);
+}
+
+sub FindSite
+{
+ my ($class,$widget,$X,$Y) = @_;
+ foreach my $site ($class->SiteList($widget))
+ {
+ return $site if ($site->viewable && $site->Over($X,$Y));
+ }
+ return undef;
+}
+
+sub NewDrag
+{
+ my ($class,$widget) = @_;
+}
+
+sub Match
+{
+ my ($site,$other) = @_;
+ return 0 unless (defined $other);
+ return 1 if ($site == $other);
+ return 0 unless (ref($site) eq ref($other));
+ for ("$site")
+ {
+ if (/ARRAY/)
+ {
+ my $i;
+ return 0 unless (@$site == @$other);
+ for ($i = 0; $i < @$site; $i++)
+ {
+ return 0 unless ($site->[$i] == $other->[$i]);
+ }
+ return 1;
+ }
+ elsif (/SCALAR/)
+ {
+ return $site == $other;
+ }
+ elsif (/HASH/)
+ {
+ my $key;
+ foreach $key (keys %$site)
+ {
+ return 0 unless exists $other->{$key};
+ return 0 unless ($other->{$key} eq $site->{$key});
+ }
+ foreach $key (keys %$other)
+ {
+ return 0 unless exists $site->{$key};
+ return 0 unless ($other->{$key} eq $site->{$key});
+ }
+ return 1;
+ }
+ return 0;
+ }
+ return 0;
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunConst.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunConst.pm
new file mode 100755
index 00000000000..66325466e68
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunConst.pm
@@ -0,0 +1,34 @@
+package Tk::DragDrop::SunConst;
+require Exporter;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/SunConst.pm#4 $
+
+use base qw(Exporter);
+
+@EXPORT = qw(_enter _leave _motion
+ ENTERLEAVE MOTION DEFAULT_SITE
+ MOVE_FLAG ACK_FLAG TRANSIENT_FLAG FORWARDED_FLAG
+ );
+
+# Event types
+sub _enter () {7};
+sub _leave () {8};
+sub _motion () {6};
+
+# Site flags
+
+sub ENTERLEAVE () {1<<0}
+sub MOTION () {1<<1}
+sub DEFAULT_SITE () {1<<2}
+
+# Trigger flags
+sub MOVE_FLAG () {1<<0}
+sub ACK_FLAG () {1<<1}
+sub TRANSIENT_FLAG () {1<<2}
+sub FORWARDED_FLAG () {1<<3}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunDrop.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunDrop.pm
new file mode 100755
index 00000000000..422a08196ea
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunDrop.pm
@@ -0,0 +1,200 @@
+package Tk::DragDrop::SunDrop;
+require Tk::DragDrop::Rect;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #5 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Rect);
+use strict;
+use Tk::DragDrop::SunConst;
+
+Tk::DragDrop->Type('Sun');
+
+BEGIN
+ {
+ # Define the Rect API as members of the array
+ my @fields = qw(name win X Y width height flags ancestor widget);
+ my $i = 0;
+ no strict 'refs';
+ for ($i=0; $i < @fields; $i++)
+ {
+ my $j = $i;
+ *{"$fields[$i]"} = sub { shift->[$j] };
+ }
+ }
+
+
+sub Preview
+{
+ my ($site,$token,$e,$kind,$flags) = (@_);
+ $token->BackTrace('No flags') unless defined $flags;
+ my $sflags = $site->flags;
+ return if ($kind == _motion && !($sflags & MOTION));
+ return if ($kind != _motion && !($sflags & ENTERLEAVE));
+ my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags);
+ $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data);
+}
+
+sub Enter
+{
+ my ($site,$token,$e) = @_;
+ $token->AcceptDrop;
+ $site->Preview($token,$e,_enter,0);
+}
+
+sub Leave
+{
+ my ($site,$token,$e) = @_;
+ $token->RejectDrop;
+ $site->Preview($token,$e,_leave,0);
+}
+
+sub Motion
+{
+ my ($site,$token,$e) = @_;
+ $site->Preview($token,$e,_motion,0);
+}
+
+sub HandleDone
+{
+ my ($token,$seln,$offset,$max) = @_;
+ $token->Done;
+ return '';
+}
+
+sub HandleAck
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return '';
+}
+
+sub HandleItem
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return undef;
+}
+
+sub HandleCount
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return 1;
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$e) = @_;
+ my $w = $token->parent;
+ $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$token,$seln]);
+ $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$token,$seln]);
+ my $atom = $w->InternAtom($seln);
+ my $flags = ACK_FLAG | TRANSIENT_FLAG;
+ my $data = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags);
+ $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data);
+}
+
+sub FindSite
+{
+ my ($class,$token,$X,$Y) = @_;
+ $token->{'SunDD'} = [] unless exists $token->{'SunDD'};
+ my $site = $class->SUPER::FindSite($token,$X,$Y);
+ if (!defined $site)
+ {
+ my $id = $token->PointToWindow($X,$Y);
+ while ($id)
+ {
+ my @prop;
+ Tk::catch { @prop = $token->property('get','_SUN_DRAGDROP_INTEREST', $id) };
+ if (!$@ && shift(@prop) eq '_SUN_DRAGDROP_INTEREST' && shift(@prop) == 0)
+ {
+ # This is a "toplevel" which has some sites associated with it.
+ my ($bx,$by) = $token->WindowXY($id);
+ $token->{'SunDDSeen'} = {} unless exists $token->{'SunDDSeen'};
+ return $site if $token->{'SunDDSeen'}{$id};
+ $token->{'SunDDSeen'}{$id} = 1;
+ my $sites = $token->{'SunDD'};
+ my $count = shift(@prop);
+ while (@prop && $count-- > 0)
+ {
+ my ($xid,$sn,$flags,$kind,$n) = splice(@prop,0,5);
+ if ($kind != 0)
+ {
+ warn "Don't understand site type $kind";
+ last;
+ }
+ while (@prop >= 4 && $n-- > 0)
+ {
+ my ($x,$y,$w,$h) = splice(@prop,0,4);
+ push(@$sites,bless [$sn,$xid,$x+$bx,$y+$by,$w,$h,$flags,$id,$token],$class);
+ }
+ }
+ return $class->SUPER::FindSite($token,$X,$Y);
+ }
+ $id = $token->PointToWindow($X,$Y,$id)
+ }
+ }
+ return $site;
+}
+
+my $busy = 0;
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ delete $token->{'SunDD'} unless $busy;
+ delete $token->{'SunDDSeen'};
+}
+
+sub SiteList
+{
+ my ($class,$token) = @_;
+ return @{$token->{'SunDD'}};
+}
+
+1;
+__END__
+
+# this code is obsolete now that we look at properties ourselves
+# which means we don't need dropsite manager running
+# On Sun's running OpenLook the window manager or dropsite mananger
+# watches for and caches site info in a special selection
+# This code got sites from that
+#
+
+sub SiteList
+{
+ my ($class,$token) = @_;
+ unless (1 || $busy || exists $token->{'SunDD'})
+ {
+ Carp::confess('Already doing it!') if ($busy++);
+ my @data = ();
+ my @sites = ();
+ my $mw = $token->MainWindow;
+ $token->{'SunDD'} = \@sites;
+ Tk::catch {
+ @data = $mw->SelectionGet( '-selection'=>'_SUN_DRAGDROP_DSDM', '_SUN_DRAGDROP_SITE_RECTS');
+ };
+ if ($@)
+ {
+ $token->configure('-cursor'=>'hand2');
+ $token->grab(-global);
+ }
+ else
+ {
+ while (@data)
+ {
+ my $version = shift(@data);
+ if ($version != 0)
+ {
+ warn "Unexpected site version $version";
+ last;
+ }
+ push(@sites,bless [splice(@data,0,7)],$class);
+ }
+ }
+ $busy--;
+ }
+ return @{$token->{'SunDD'}};
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunSite.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunSite.pm
new file mode 100755
index 00000000000..ab3f4f9793b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/SunSite.pm
@@ -0,0 +1,107 @@
+package Tk::DragDrop::SunSite;
+require Tk::DropSite;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+
+use Tk::DragDrop::SunConst;
+use base qw(Tk::DropSite);
+use strict;
+
+Tk::DropSite->Type('Sun');
+
+sub SunDrop
+{
+ my ($w,$site) = @_;
+ my $e = $w->XEvent;
+ my ($seln,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$e->A);
+ $w->MakeAtom($seln);
+ if ($flags & &ACK_FLAG)
+ {
+ Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_ACK') };
+ }
+ my @targ = $w->SelectionGet(-selection => $seln,'TARGETS');
+ $site->Apply(-dropcommand => $x, $y, $seln, SunDrop => \@targ);
+ if ($flags & &TRANSIENT_FLAG)
+ {
+ Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_DONE') };
+ }
+ $w->configure('-relief' => $w->{'_DND_RELIEF_'}) if (defined $w->{'_DND_RELIEF_'});
+ $site->Apply(-entercommand => $x, $y, 0);
+}
+
+sub SunPreview
+{
+ my ($w,$site) = @_;
+ my $event = $w->XEvent;
+ my ($kind,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$event->A);
+ $x -= $site->X;
+ $y -= $site->Y;
+ if ($kind == _enter)
+ {
+ $site->Callback(-entercommand => 1, $x, $y);
+ }
+ elsif ($kind == _leave)
+ {
+ $site->Callback(-entercommand => 0, $x, $y);
+ }
+ elsif ($kind == _motion)
+ {
+ $site->Callback(-motioncommand => $x, $y);
+ }
+}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ my $w = $site->widget;
+ $w->BindClientMessage('_SUN_DRAGDROP_TRIGGER',[\&SunDrop,$site]);
+ $w->BindClientMessage('_SUN_DRAGDROP_PREVIEW',[\&SunPreview,$site]);
+}
+
+sub NoteSites
+{
+ my ($class,$t,$sites) = @_;
+ my $count = @$sites;
+ my @data = (0,0);
+ my ($wrapper,$offset) = $t->wrapper;
+ if ($t->viewable)
+ {
+ my $s;
+ my $i = 0;
+ my @win;
+ my $bx = $t->rootx;
+ my $by = $t->rooty - $offset;
+ $t->MakeWindowExist;
+ foreach $s (@$sites)
+ {
+ my $w = $s->widget;
+ if ($w->viewable)
+ {
+ $w->MakeWindowExist;
+ $data[1]++;
+ push(@data,${$w->WindowId}); # XID
+ push(@data,$i++); # Our 'tag'
+ push(@data,ENTERLEAVE|MOTION); # Flags
+ push(@data,0); # Kind is 'rect'
+ push(@data,1); # Number of rects
+ push(@data,$s->X-$bx,$s->Y-$by,$s->width,$s->height); # The rect
+ }
+ }
+ }
+ if ($data[1])
+ {
+ $t->property('set',
+ '_SUN_DRAGDROP_INTEREST', # name
+ '_SUN_DRAGDROP_INTEREST', # type
+ 32, # format
+ \@data,$wrapper); # the data
+ }
+ else
+ {
+ $t->property('delete','_SUN_DRAGDROP_INTEREST',$wrapper);
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Drop.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Drop.pm
new file mode 100755
index 00000000000..08a4656ecce
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Drop.pm
@@ -0,0 +1,8 @@
+package Tk::DragDrop::Win32Drop;
+# Dummy placeholder for symetry
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/Win32Site/Win32Drop.pm#4 $
+
+use Tk ();
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Site.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Site.pm
new file mode 100755
index 00000000000..f45d06bc92b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/Win32Site.pm
@@ -0,0 +1,50 @@
+package Tk::DragDrop::Win32Site;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+require DynaLoader;
+require Tk::DropSite;
+
+use base qw(Tk::DropSite DynaLoader);
+
+bootstrap Tk::DragDrop::Win32Site;
+
+use strict;
+
+Tk::DropSite->Type('Win32');
+
+sub WM_DROPFILES () {563}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ my $w = $site->widget;
+ $w->BindClientMessage(WM_DROPFILES,[\&Win32Drop,$site]);
+ DragAcceptFiles($w,1);
+}
+
+sub Win32Drop
+{
+ # print join(',',@_),"\n";
+ my ($w,$site,$msg,$wParam,$lParam) = @_;
+ my ($x,$y,@files) = DropInfo($wParam);
+ my $cb = $site->{'-dropcommand'};
+ $site->Apply(-entercommand => $x, $y, 1);
+ if ($cb)
+ {
+ foreach my $file (@files)
+ {
+ # print "$file @ $x,$y\n";
+ $w->clipboardClear;
+ $w->clipboardAppend('--',$file);
+ $cb->Call('CLIPBOARD',Win32Drop => ['STRING'],$x,$y);
+ }
+ }
+ $site->Apply(-entercommand => $x, $y, 0);
+ return 0;
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDDrop.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDDrop.pm
new file mode 100755
index 00000000000..7376c8d69c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDDrop.pm
@@ -0,0 +1,145 @@
+package Tk::DragDrop::XDNDDrop;
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+use base qw(Tk::DragDrop::Rect);
+
+sub XDND_PROTOCOL_VERSION () { 4 }
+
+Tk::DragDrop->Type('XDND');
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ $token->{$class} = {};
+}
+
+sub new
+{
+ my ($class,$token,$id,@prop) = @_;
+ my $ver = $token->InternAtom(shift(@prop));
+ # warn "XDND version $ver ".join(' ',@prop)."\n";
+ $ver = XDND_PROTOCOL_VERSION if $ver > XDND_PROTOCOL_VERSION;
+ my $site = bless { id => $id, token => $token, ver => $ver, state => 0, accept => \@prop}, $class;
+ my $w = $token->parent;
+ $w->BindClientMessage('XdndStatus',[$site => 'XdndStatus']);
+ $w->BindClientMessage('XdndFinished',[$site => 'XdndFinished']);
+ return $site;
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$e) = @_;
+ my $w = $token->parent;
+ my $data = pack('LLLLL',oct($w->id),0,$e->t,0,0);
+ $w->SendClientMessage('XdndDrop',$site->{id},32,$data);
+}
+
+sub FindSite
+{
+ my ($class,$token,$X,$Y) = @_;
+ my $id = $token->PointToWindow($X,$Y);
+ while ($id)
+ {
+ my @prop;
+ Tk::catch { @prop = $token->property('get','XdndAware', $id) };
+ if (!$@ && shift(@prop) eq 'ATOM')
+ {
+ my $hash = $token->{$class};
+ my $site = $hash->{$id};
+ if (!defined $site)
+ {
+ $site = $class->new($token,$id,@prop);
+ $hash->{$id} = $site;
+ }
+ return $site;
+ }
+ $id = $token->PointToWindow($X,$Y,$id)
+ }
+ return undef;
+}
+
+sub Enter
+{
+ my ($site,$token,$e) = @_;
+ my $w = $token->parent;
+ $token->InstallHandlers('XdndSelection');
+ my $seln = $token->cget('-selection');
+ my @targets = grep(!/^(TARGETS|MULTIPLE|TIMESTAMP)$/,reverse($token->SelectionGet('-selection'=> 'XdndSelection','TARGETS')));
+ # print join(' ',@targets),"\n";
+ my $flags = ($site->{ver} << 24);
+ my @atarg = map($token->InternAtom($_),@targets);
+ my $ntarg = @atarg;
+ if ($ntarg > 3)
+ {
+ $flags |= 1;
+ $w->property('set','XdndTypeList','ATOM',32,\@atarg);
+ splice(@atarg,3);
+ }
+ else
+ {
+ splice(@atarg,$ntarg,(0 x 3 - $ntarg));
+ }
+ unshift(@atarg,oct($w->id),$flags);
+ # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n";
+ my $data = pack('LLLLL',@atarg);
+ $w->SendClientMessage('XdndEnter',$site->{id},32,$data);
+}
+
+sub Leave
+{
+ my ($site,$token,$e) = @_;
+ my $w = $token->parent;
+ my $data = pack('LLLLL',oct($w->id), 0, 0, 0, 0);
+ $w->SendClientMessage('XdndLeave',$site->{id},32,$data);
+}
+
+sub Motion
+{
+ my ($site,$token,$e) = @_;
+ my $X = $e->X;
+ my $Y = $e->Y;
+ my $w = $token->parent;
+ my $action = $token->InternAtom($site->{'action'} || 'XdndActionCopy');
+ my @atarg = (oct($w->id),0,($X << 16) | $Y, $e->t, $action);
+ # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n";
+ my $data = pack('LLLLL',@atarg);
+ $w->SendClientMessage('XdndPosition',$site->{id},32,$data);
+}
+
+sub XdndFinished
+{
+ my ($site) = @_;
+ my $token = $site->{token};
+ # printf "XdndFinished $site\n",
+ $token->Done;
+}
+
+sub XdndStatus
+{
+ my ($site) = @_;
+ my $token = $site->{token};
+ my $w = $token->parent;
+ my $event = $w->XEvent;
+ my ($tid,$flags,$xy,$wh,$action) = unpack('LLLLL',$event->A);
+ $action = $w->GetAtomName($action) if $action;
+ $site->{flags} = $flags;
+ $site->{'X'} = $xy >> 16;
+ $site->{'Y'} = $xy & 0xFFFF;
+ $site->{'width'} = $wh >> 16;
+ $site->{'height'} = $wh & 0xFFFF;
+ #printf "XdndStatus $site targ=%x flags=%08X x=%d y=%d w=%d h=%d a=%s\n",
+ # $tid,$flags,$xy >> 16, $xy & 0xFFFF, $wh >> 16, $wh & 0xFFFF,$action;
+ if ($flags & 1)
+ {
+ $token->AcceptDrop;
+ }
+ else
+ {
+ $token->RejectDrop;
+ }
+}
+
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDSite.pm
new file mode 100755
index 00000000000..4ac75d63c40
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DragDrop/XDNDSite.pm
@@ -0,0 +1,159 @@
+package Tk::DragDrop::XDNDSite;
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+use base qw(Tk::DropSite);
+
+sub XDND_PROTOCOL_VERSION () { 4 }
+
+Tk::DropSite->Type('XDND');
+
+sub InitSite
+{my ($class,$site) = @_;
+ my $w = $site->widget;
+}
+
+sub XdndEnter
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ my $ver = ($flags >> 24) & 0xFF;
+ if ($flags & 1)
+ {
+ my @prop;
+ Tk::catch { @prop = $t->property('get','XdndTypeList',$src) };
+ @types = @prop if (!$@ && shift(@prop) eq 'ATOM');
+ }
+ else
+ {
+ $t->MakeAtom(@types);
+ }
+ # print "XdndEnter $src $ver @types\n";
+ $t->{"XDND$src"} = { ver => $ver, types => \@types };
+}
+
+sub XdndLeave
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ # print "XdndLeave $src\n";
+ my $info = $t->{"XDND$src"};
+ if ($info)
+ {
+ my $over = $info->{site};
+ if ($over)
+ {
+ my $X = $info->{X};
+ my $Y = $info->{Y};
+ $over->Apply(-entercommand => $X, $Y, 0)
+ }
+ }
+ delete $t->{"XDND$src"};
+}
+
+sub XdndPosition
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A);
+ $t->MakeAtom($action);
+ my $X = $xy >> 16;
+ my $Y = $xy & 0xFFFF;
+ my $info = $t->{"XDND$src"};
+ $info->{X} = $X;
+ $info->{Y} = $Y;
+ $info->{action} = $action;
+ $info->{t} = $time;
+ my ($id) = $t->wrapper;
+ my $sxy = 0;
+ my $swh = 0;
+ my $sflags = 0;
+ my $saction = 0;
+ my $over = $info->{site};
+ foreach my $site (@$sites)
+ {
+ if ($site->Over($X,$Y))
+ {
+ $sxy = ($site->X << 16) | $site->Y;
+ $swh = ($site->width << 16) | $site->height;
+ $saction = $action;
+ $sflags |= 1;
+ if ($over)
+ {
+ if ($over == $site)
+ {
+ $site->Apply(-motioncommand => $X, $Y);
+ }
+ else
+ {
+ $over->Apply(-entercommand => $X, $Y, 0);
+ $site->Apply(-entercommand => $X, $Y, 1);
+ }
+ }
+ else
+ {
+ $site->Apply(-entercommand => $X, $Y, 1);
+ }
+ $info->{site} = $site;
+ last;
+ }
+ }
+ unless ($sflags & 1)
+ {
+ if ($over)
+ {
+ $over->Apply(-entercommand => $X, $Y, 0)
+ }
+ delete $info->{site};
+ }
+ my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action);
+ $t->SendClientMessage('XdndStatus',$src,32,$data);
+}
+
+sub XdndDrop
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A);
+ my $info = $t->{"XDND$src"};
+ my $sflags = 0;
+ my $action = 0;
+ if ($info)
+ {
+ $info->{t} = $time;
+ my $site = $info->{'site'};
+ if ($site)
+ {
+ my $X = $info->{'X'};
+ my $Y = $info->{'Y'};
+ $action = $info->{action};
+ $site->Apply(-dropcommand => $X, $Y, 'XdndSelection',$action,$info->{types});
+ $site->Apply(-entercommand => $X, $Y, 0);
+ }
+ }
+ my ($id) = $t->wrapper;
+ my $data = pack('LLLLL',$id,$sflags,$action,0,0);
+ $t->SendClientMessage('XdndFinished',$src,32,$data);
+}
+
+sub NoteSites
+{my ($class,$t,$sites) = @_;
+ my ($wrapper) = $t->wrapper;
+ if (@$sites)
+ {
+ $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]);
+ $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]);
+ $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]);
+ $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]);
+ $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION],$wrapper);
+ }
+ else
+ {
+ $t->property('delete','XdndAware',$wrapper);
+ }
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DropSite.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DropSite.pm
new file mode 100755
index 00000000000..3519c108384
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DropSite.pm
@@ -0,0 +1,257 @@
+package Tk::DropSite;
+require Tk::DragDrop::Common;
+require Tk::DragDrop::Rect;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Common Tk::DragDrop::Rect);
+
+Construct Tk::Widget 'DropSite';
+
+use strict;
+use vars qw(%type @types);
+
+Tk::DragDrop->Tk::DragDrop::Common::Type('Local');
+
+my @toplevels;
+
+BEGIN
+{
+ # Are these really methods of Tk::DragDrop::Rect ?
+ no strict 'refs';
+ foreach my $name (qw(x y X Y width height widget))
+ {
+ my $key = $name;
+ *{"$key"} = sub { shift->{$key} };
+ }
+}
+
+# Dropping side API - really only here for Local drops
+# inheritance is a mess right now.
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ # No need to clear cached sites we see live data
+}
+
+sub SiteList
+{
+ # this should be inheritable - so that receive side of XDND can re-use it.
+ my ($class,$widget) = @_;
+ my $t;
+ my @list;
+ foreach $t (@toplevels)
+ {
+ my $sites = $t->{'DropSites'};
+ if ($sites)
+ {
+ $sites = $sites->{'Local'};
+ push(@list,@{$sites}) if ($sites);
+ }
+ }
+ return @list;
+}
+
+sub Apply
+{
+ my $site = shift;
+ my $name = shift;
+ my $cb = $site->{$name};
+ if ($cb)
+ {
+ my $X = shift;
+ my $Y = shift;
+ $cb->Call(@_,$X - $site->X, $Y - $site->Y);
+ }
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$event) = @_;
+ my $X = $event->X;
+ my $Y = $event->Y;
+ my @targ = $token->SelectionGet(-selection => $seln,'TARGETS');
+ $site->Apply(-dropcommand => $X, $Y, $seln,'LocalDrop',\@targ);
+ $site->Apply(-entercommand => $X, $Y, 0);
+ $token->Done;
+}
+
+sub Enter
+{
+ my ($site,$token,$event) = @_;
+ $token->AcceptDrop;
+ $site->Apply(-entercommand => $event->X, $event->Y, 1);
+}
+
+sub Leave
+{
+ my ($site,$token,$event) = @_;
+ $token->RejectDrop;
+ $site->Apply(-entercommand => $event->X, $event->Y, 0);
+}
+
+sub Motion
+{
+ my ($site,$token,$event) = @_;
+ $site->Apply(-motioncommand => $event->X, $event->Y);
+}
+
+# This is receive side API.
+
+sub NoteSites
+{
+ my ($class,$t,$sites) = @_;
+ unless (grep($_ == $t,@toplevels))
+ {
+ $Tk::DragDrop::types{'Local'} = $class if (@$sites);
+ push(@toplevels,$t);
+ $t->OnDestroy(sub { @toplevels = grep($_ != $t,@toplevels) });
+ }
+}
+
+sub UpdateDropSites
+{
+ my ($t) = @_;
+ $t->{'DropUpdate'} = 0;
+ foreach my $type (@types)
+ {
+ my $sites = $t->{'DropSites'}->{$type};
+ if ($sites && @$sites)
+ {
+ my $class = $type{$type};
+ $class->NoteSites($t,$sites);
+ }
+ }
+}
+
+sub QueueDropSiteUpdate
+{
+ my $obj = shift;
+ my $class = ref($obj);
+ my $t = $obj->widget->toplevel;
+ unless ($t->{'DropUpdate'})
+ {
+ $t->{'DropUpdate'} = 1;
+ $t->afterIdle(sub { UpdateDropSites($t) });
+ }
+}
+
+sub delete
+{
+ my ($obj) = @_;
+ my $w = $obj->widget;
+ $w->bindtags([grep($_ ne $obj,$w->bindtags)]);
+ my $t = $w->toplevel;
+ foreach my $type (@{$obj->{'-droptypes'}})
+ {
+ my $a = $t->{'DropSites'}->{$type};
+ @$a = grep($_ ne $obj,@$a);
+ }
+ $obj->QueueDropSiteUpdate;
+}
+
+sub DropSiteUpdate
+{
+ # Note size of widget and arrange to update properties etc.
+ my $obj = shift;
+ my $w = $obj->widget;
+ $obj->{'x'} = $w->X;
+ $obj->{'y'} = $w->Y;
+ $obj->{'X'} = $w->rootx;
+ $obj->{'Y'} = $w->rooty;
+ $obj->{'width'} = $w->Width;
+ $obj->{'height'} = $w->Height;
+ $obj->QueueDropSiteUpdate;
+}
+
+sub TopSiteUpdate
+{
+ my ($t) = @_;
+ foreach my $type (@types)
+ {
+ my $sites = $t->{'DropSites'}->{$type};
+ if ($sites && @$sites)
+ {
+ my $site;
+ foreach $site (@$sites)
+ {
+ $site->DropSiteUpdate;
+ }
+ }
+ }
+}
+
+sub Callback
+{
+ my $obj = shift;
+ my $key = shift;
+ my $cb = $obj->{$key};
+ $cb->Call(@_) if (defined $cb);
+}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ # Tk::DragDrop->Type('Local');
+}
+
+sub new
+{
+ my ($class,$w,%args) = @_;
+ my $t = $w->toplevel;
+ $args{'widget'} = $w;
+ if (exists $args{'-droptypes'})
+ {
+ # Convert single type to array-of-one
+ $args{'-droptypes'} = [$args{'-droptypes'}] unless (ref $args{'-droptypes'});
+ }
+ else
+ {
+ # Default to all known types.
+ $args{'-droptypes'} = \@types;
+ }
+ my ($key,$val);
+ while (($key,$val) = each %args)
+ {
+ if ($key =~ /command$/)
+ {
+ $val = Tk::Callback->new($val);
+ $args{$key} = $val;
+ }
+ }
+ my $obj = bless \%args,$class;
+ unless (exists $t->{'DropSites'})
+ {
+ $t->{'DropSites'} = {};
+ $t->{'DropUpdate'} = 0;
+ }
+ my $type;
+ foreach $type (@{$args{'-droptypes'}})
+ {
+ Tk::DropSite->import($type) unless (exists $type{$type});
+ my $class = $type{$type};
+ $class->InitSite($obj);
+ # Should this be indexed by type or class ?
+ unless (exists $t->{'DropSites'}->{$type})
+ {
+ $t->{'DropSites'}->{$type} = [];
+ }
+ push(@{$t->{'DropSites'}->{$type}},$obj);
+ }
+ $w->OnDestroy([$obj,'delete']);
+ $obj->DropSiteUpdate;
+ $w->bindtags([$w->bindtags,$obj]);
+ $w->Tk::bind($obj,'<Map>',[$obj,'DropSiteUpdate']);
+ $w->Tk::bind($obj,'<Unmap>',[$obj,'DropSiteUpdate']);
+ $w->Tk::bind($obj,'<Configure>',[$obj,'DropSiteUpdate']);
+ $t->Tk::bind($class,'<Configure>',[\&TopSiteUpdate,$t]);
+ unless (grep($_ eq $class,$t->bindtags))
+ {
+ $t->bindtags([$t->bindtags,$class]);
+ }
+ return $obj;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DropSite.pod b/Master/tlpkg/tlperl.straw/lib/Tk/DropSite.pod
new file mode 100755
index 00000000000..8ae5a199fe3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DropSite.pod
@@ -0,0 +1,33 @@
+=head1 NAME
+
+Tk::DropSite - Receive side of Drag & Drop abstraction
+
+=for category User Interaction
+
+=head1 SYNOPSIS
+
+ use Tk::DropSite qw(...);
+ $widget->DropSite(-entercommand => ...,
+ -dropcommand => ...,
+ -motioncommand => ...,
+ -dropcommand => ...,
+ );
+
+=head1 DESCRIPTION
+
+C<DropSite> creates an object which represents a site on which things
+may be "Dropped".
+
+A DropSite provides the following methods:
+
+=over 4
+
+=item $site->Enter($token,$event)
+
+=item $site->Leave($token,$event)
+
+=item $site->Motion($token,$event)
+
+=item $site->Drop($token,$event)
+
+=back
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/DummyEncode.pm b/Master/tlpkg/tlperl.straw/lib/Tk/DummyEncode.pm
new file mode 100755
index 00000000000..5ead808405d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/DummyEncode.pm
@@ -0,0 +1,46 @@
+package Tk::DummyEncode;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $
+
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ return undef unless ($name =~ /(iso8859-1|X11ControlChars)/);
+ my $pkg = $name;
+ $pkg =~ s/\W+/_/g;
+ return bless {Name => $name},$class.'::'.$pkg;
+}
+
+package Tk::DummyEncode::iso8859_1;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ $_[1] = '' if $chk;
+ return $uni;
+}
+
+sub decode
+{
+ my ($obj,$byt,$chk) = @_;
+ $_[1]
+= '' if $chk;
+ return $byt;
+}
+
+package Tk::DummyEncode::X11ControlChars;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ my $str = '';
+ foreach my $ch (split(//,$uni))
+ {
+ $str .= sprintf("\\x{%x}",ord($ch));
+ }
+ $_[1] = '' if $chk;
+ return $str;
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/English.pm b/Master/tlpkg/tlperl.straw/lib/Tk/English.pm
new file mode 100755
index 00000000000..de640376580
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/English.pm
@@ -0,0 +1,307 @@
+package Tk::English;
+
+require Exporter;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/English.pm#6 $
+
+use base qw(Exporter);
+
+# This file is generated automatically by pTk/makeenglish from Tk distribution.
+
+
+@EXPORT = qw(
+ &ABOVE &ACTIVATE &ACTIVE &ADD &ADDTAG &ADJUST &AFTER &ALL &ANCHOR &APPEND
+ &APPLY &ARROW1 &ARROW2 &ASCII &ASPECT &AUTO &BASELINE &BBOX &BEFORE &BELOW
+ &BEVEL &BIND &BITMAP &BLANK &BOTH &BOTTOM &BUTT &CANVASX &CANVASY &CAPTURE
+ &CASCADE &CENTER &CGET &CHAR &CHARS &CHECKBUTTON &CHILDREN &CLEAR &CLIENT
+ &CLONE &CLOSEST &COLOR &COLORMAPWINDOWS &COLUMN &COLUMNCONFIGURE &COMMAND
+ &COMPARE &CONFIGURE &COORDS &COPY &CREATE &CURRENT &CURSELECTION &DATA
+ &DCHARS &DEACTIVATE &DEBUG &DECORATIONS &DECREASING &DEFAULT &DEICONIFY
+ &DELETE &DELTA &DESELECT &DLINEINFO &DOWN &DRAGSITE &DRAGTO &DROPSITE &DTAG
+ &DUMP &ENCLOSED &END &ENTRY &ENTRYCGET &ENTRYCONFIGURE &EVAL &EXISTS &EXPAND
+ &FILL &FILLX &FILLY &FIND &FIRST &FLASH &FLAT &FOCUS &FOCUSMODEL &FOCUSNEXT
+ &FOCUSPREV &FORGET &FRACTION &FRAME &FROM &GENERATE &GEOMETRY &GEOMETRYINFO
+ &GET &GETTAGS &GRAVITY &GRAY &GRID &GROOVE &GROUP &HANDLE &HEAD &HEIGHT
+ &HIDDEN &HIDE &HORIZONTAL &ICONBITMAP &ICONIFY &ICONMASK &ICONNAME
+ &ICONPOSITION &ICONWINDOW &ICURSOR &IDENTIFY &IDLETASKS &IGNORE &IMAGE
+ &INCLUDES &INCREASING &INDEX &INFO &INSERT &INSIDE &INTEGER &INTERACTIVE
+ &INVOKE &ISMWMRUNNING &ITEM &ITEMCGET &ITEMCONFIGURE &LAST &LEFT &LINE
+ &LINECONFIGURE &LINEEND &LINES &LINESTART &LIST &LOCATION &LOWER &MARK &MAX
+ &MAXSIZE &MENUBAR &MINSIZE &MITER &MONOCHROME &MOVE &MOVETO &NAMES &NEAREST
+ &NEW &NEXT &NEXTRANGE &NONE &NORMAL &NOW &OFFSPRINGS &OUTSIDE &OVERLAPPING
+ &OVERRIDEREDIRECT &OWN &PADX &PADY &PAGECGET &PAGECONFIGURE &PAGES &PARENT
+ &PASSIVE &POSITION &POSITIONFROM &POST &POSTCASCADE &POSTSCRIPT &PRESENT
+ &PREV &PREVIOUS &PREVRANGE &PROGRAM &PROJECTING &PROPAGATE &PROTOCOL &PUT
+ &RADIOBUTTON &RAISE &RAISED &RANGE &RANGES &READ &READFILE &REAL &RECORD
+ &REDITHER &REFCOUNT &RELEASE &REMOVE &RESIZABLE &RIDGE &RIGHT &ROOT &ROUND
+ &ROW &ROWCONFIGURE &ROWS &SAVEUNDER &SCALE &SCAN &SCROLL &SEARCH &SEE
+ &SELECT &SELECTION &SEPARATOR &SET &SHOW &SIBLINGS &SIZE &SIZEFROM &SLAVES
+ &SLIDER &SOLID &SPACE &STATE &STATUS &SUNKEN &TAG &TAIL &TEAROFF &TEXT
+ &TITLE &TO &TOGGLE &TOP &TRACING &TRANSIENT &TRANSIENTFOR &TYPE &TYPES
+ &UNITS &UNPACK &UNPOST &UNSET &UP &USER &VARIABLE &VERTICAL &VISIBILITY
+ &WIDTH &WINDOW &WITHDRAW &WITHTAG &WORDEND &WORDSTART &WRITE &XVIEW
+ &YPOSITION &YVIEW
+);
+sub ABOVE () { 'above' }
+sub ACTIVATE () { 'activate' }
+sub ACTIVE () { 'active' }
+sub ADD () { 'add' }
+sub ADDTAG () { 'addtag' }
+sub ADJUST () { 'adjust' }
+sub AFTER () { 'after' }
+sub ALL () { 'all' }
+sub ANCHOR () { 'anchor' }
+sub APPEND () { 'append' }
+sub APPLY () { 'apply' }
+sub ARROW1 () { 'arrow1' }
+sub ARROW2 () { 'arrow2' }
+sub ASCII () { 'ascii' }
+sub ASPECT () { 'aspect' }
+sub AUTO () { 'auto' }
+sub BASELINE () { 'baseline' }
+sub BBOX () { 'bbox' }
+sub BEFORE () { 'before' }
+sub BELOW () { 'below' }
+sub BEVEL () { 'bevel' }
+sub BIND () { 'bind' }
+sub BITMAP () { 'bitmap' }
+sub BLANK () { 'blank' }
+sub BOTH () { 'both' }
+sub BOTTOM () { 'bottom' }
+sub BUTT () { 'butt' }
+sub CANVASX () { 'canvasx' }
+sub CANVASY () { 'canvasy' }
+sub CAPTURE () { 'capture' }
+sub CASCADE () { 'cascade' }
+sub CENTER () { 'center' }
+sub CGET () { 'cget' }
+sub CHAR () { 'char' }
+sub CHARS () { 'chars' }
+sub CHECKBUTTON () { 'checkbutton' }
+sub CHILDREN () { 'children' }
+sub CLEAR () { 'clear' }
+sub CLIENT () { 'client' }
+sub CLONE () { 'clone' }
+sub CLOSEST () { 'closest' }
+sub COLOR () { 'color' }
+sub COLORMAPWINDOWS () { 'colormapwindows' }
+sub COLUMN () { 'column' }
+sub COLUMNCONFIGURE () { 'columnconfigure' }
+sub COMMAND () { 'command' }
+sub COMPARE () { 'compare' }
+sub CONFIGURE () { 'configure' }
+sub COORDS () { 'coords' }
+sub COPY () { 'copy' }
+sub CREATE () { 'create' }
+sub CURRENT () { 'current' }
+sub CURSELECTION () { 'curselection' }
+sub DATA () { 'data' }
+sub DCHARS () { 'dchars' }
+sub DEACTIVATE () { 'deactivate' }
+sub DEBUG () { 'debug' }
+sub DECORATIONS () { 'decorations' }
+sub DECREASING () { 'decreasing' }
+sub DEFAULT () { 'default' }
+sub DEICONIFY () { 'deiconify' }
+sub DELETE () { 'delete' }
+sub DELTA () { 'delta' }
+sub DESELECT () { 'deselect' }
+sub DLINEINFO () { 'dlineinfo' }
+sub DOWN () { 'down' }
+sub DRAGSITE () { 'dragsite' }
+sub DRAGTO () { 'dragto' }
+sub DROPSITE () { 'dropsite' }
+sub DTAG () { 'dtag' }
+sub DUMP () { 'dump' }
+sub ENCLOSED () { 'enclosed' }
+sub END () { 'end' }
+sub ENTRY () { 'entry' }
+sub ENTRYCGET () { 'entrycget' }
+sub ENTRYCONFIGURE () { 'entryconfigure' }
+sub EVAL () { 'eval' }
+sub EXISTS () { 'exists' }
+sub EXPAND () { 'expand' }
+sub FILL () { 'fill' }
+sub FILLX () { 'fillx' }
+sub FILLY () { 'filly' }
+sub FIND () { 'find' }
+sub FIRST () { 'first' }
+sub FLASH () { 'flash' }
+sub FLAT () { 'flat' }
+sub FOCUS () { 'focus' }
+sub FOCUSMODEL () { 'focusmodel' }
+sub FOCUSNEXT () { 'focusnext' }
+sub FOCUSPREV () { 'focusprev' }
+sub FORGET () { 'forget' }
+sub FRACTION () { 'fraction' }
+sub FRAME () { 'frame' }
+sub FROM () { 'from' }
+sub GENERATE () { 'generate' }
+sub GEOMETRY () { 'geometry' }
+sub GEOMETRYINFO () { 'geometryinfo' }
+sub GET () { 'get' }
+sub GETTAGS () { 'gettags' }
+sub GRAVITY () { 'gravity' }
+sub GRAY () { 'gray' }
+sub GRID () { 'grid' }
+sub GROOVE () { 'groove' }
+sub GROUP () { 'group' }
+sub HANDLE () { 'handle' }
+sub HEAD () { 'head' }
+sub HEIGHT () { 'height' }
+sub HIDDEN () { 'hidden' }
+sub HIDE () { 'hide' }
+sub HORIZONTAL () { 'horizontal' }
+sub ICONBITMAP () { 'iconbitmap' }
+sub ICONIFY () { 'iconify' }
+sub ICONMASK () { 'iconmask' }
+sub ICONNAME () { 'iconname' }
+sub ICONPOSITION () { 'iconposition' }
+sub ICONWINDOW () { 'iconwindow' }
+sub ICURSOR () { 'icursor' }
+sub IDENTIFY () { 'identify' }
+sub IDLETASKS () { 'idletasks' }
+sub IGNORE () { 'ignore' }
+sub IMAGE () { 'image' }
+sub INCLUDES () { 'includes' }
+sub INCREASING () { 'increasing' }
+sub INDEX () { 'index' }
+sub INFO () { 'info' }
+sub INSERT () { 'insert' }
+sub INSIDE () { 'inside' }
+sub INTEGER () { 'integer' }
+sub INTERACTIVE () { 'interactive' }
+sub INVOKE () { 'invoke' }
+sub ISMWMRUNNING () { 'ismwmrunning' }
+sub ITEM () { 'item' }
+sub ITEMCGET () { 'itemcget' }
+sub ITEMCONFIGURE () { 'itemconfigure' }
+sub LAST () { 'last' }
+sub LEFT () { 'left' }
+sub LINE () { 'line' }
+sub LINECONFIGURE () { 'lineconfigure' }
+sub LINEEND () { 'lineend' }
+sub LINES () { 'lines' }
+sub LINESTART () { 'linestart' }
+sub LIST () { 'list' }
+sub LOCATION () { 'location' }
+sub LOWER () { 'lower' }
+sub MARK () { 'mark' }
+sub MAX () { 'max' }
+sub MAXSIZE () { 'maxsize' }
+sub MENUBAR () { 'menubar' }
+sub MINSIZE () { 'minsize' }
+sub MITER () { 'miter' }
+sub MONOCHROME () { 'monochrome' }
+sub MOVE () { 'move' }
+sub MOVETO () { 'moveto' }
+sub NAMES () { 'names' }
+sub NEAREST () { 'nearest' }
+sub NEW () { 'new' }
+sub NEXT () { 'next' }
+sub NEXTRANGE () { 'nextrange' }
+sub NONE () { 'none' }
+sub NORMAL () { 'normal' }
+sub NOW () { 'now' }
+sub OFFSPRINGS () { 'offsprings' }
+sub OUTSIDE () { 'outside' }
+sub OVERLAPPING () { 'overlapping' }
+sub OVERRIDEREDIRECT () { 'overrideredirect' }
+sub OWN () { 'own' }
+sub PADX () { 'padx' }
+sub PADY () { 'pady' }
+sub PAGECGET () { 'pagecget' }
+sub PAGECONFIGURE () { 'pageconfigure' }
+sub PAGES () { 'pages' }
+sub PARENT () { 'parent' }
+sub PASSIVE () { 'passive' }
+sub POSITION () { 'position' }
+sub POSITIONFROM () { 'positionfrom' }
+sub POST () { 'post' }
+sub POSTCASCADE () { 'postcascade' }
+sub POSTSCRIPT () { 'postscript' }
+sub PRESENT () { 'present' }
+sub PREV () { 'prev' }
+sub PREVIOUS () { 'previous' }
+sub PREVRANGE () { 'prevrange' }
+sub PROGRAM () { 'program' }
+sub PROJECTING () { 'projecting' }
+sub PROPAGATE () { 'propagate' }
+sub PROTOCOL () { 'protocol' }
+sub PUT () { 'put' }
+sub RADIOBUTTON () { 'radiobutton' }
+sub RAISE () { 'raise' }
+sub RAISED () { 'raised' }
+sub RANGE () { 'range' }
+sub RANGES () { 'ranges' }
+sub READ () { 'read' }
+sub READFILE () { 'readfile' }
+sub REAL () { 'real' }
+sub RECORD () { 'record' }
+sub REDITHER () { 'redither' }
+sub REFCOUNT () { 'refcount' }
+sub RELEASE () { 'release' }
+sub REMOVE () { 'remove' }
+sub RESIZABLE () { 'resizable' }
+sub RIDGE () { 'ridge' }
+sub RIGHT () { 'right' }
+sub ROOT () { 'root' }
+sub ROUND () { 'round' }
+sub ROW () { 'row' }
+sub ROWCONFIGURE () { 'rowconfigure' }
+sub ROWS () { 'rows' }
+sub SCALE () { 'scale' }
+sub SCAN () { 'scan' }
+sub SCROLL () { 'scroll' }
+sub SEARCH () { 'search' }
+sub SEE () { 'see' }
+sub SELECT () { 'select' }
+sub SELECTION () { 'selection' }
+sub SEPARATOR () { 'separator' }
+sub SET () { 'set' }
+sub SHOW () { 'show' }
+sub SIBLINGS () { 'siblings' }
+sub SIZE () { 'size' }
+sub SIZEFROM () { 'sizefrom' }
+sub SLAVES () { 'slaves' }
+sub SLIDER () { 'slider' }
+sub SOLID () { 'solid' }
+sub SPACE () { 'space' }
+sub STATE () { 'state' }
+sub STATUS () { 'status' }
+sub SUNKEN () { 'sunken' }
+sub TAG () { 'tag' }
+sub TAIL () { 'tail' }
+sub TEAROFF () { 'tearoff' }
+sub TEXT () { 'text' }
+sub TITLE () { 'title' }
+sub TO () { 'to' }
+sub TOGGLE () { 'toggle' }
+sub TOP () { 'top' }
+sub TRACING () { 'tracing' }
+sub TRANSIENT () { 'transient' }
+sub TRANSIENTFOR () { 'transientfor' }
+sub TYPE () { 'type' }
+sub TYPES () { 'types' }
+sub UNITS () { 'units' }
+sub UNPACK () { 'unpack' }
+sub UNPOST () { 'unpost' }
+sub UNSET () { 'unset' }
+sub UP () { 'up' }
+sub USER () { 'user' }
+sub VARIABLE () { 'variable' }
+sub VERTICAL () { 'vertical' }
+sub VISIBILITY () { 'visibility' }
+sub WIDTH () { 'width' }
+sub WINDOW () { 'window' }
+sub WITHDRAW () { 'withdraw' }
+sub WITHTAG () { 'withtag' }
+sub WORDEND () { 'wordend' }
+sub WORDSTART () { 'wordstart' }
+sub WRITE () { 'write' }
+sub XVIEW () { 'xview' }
+sub YPOSITION () { 'yposition' }
+sub YVIEW () { 'yview' }
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Entry.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Entry.pm
new file mode 100755
index 00000000000..51b3f0c6767
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Entry.pm
@@ -0,0 +1,615 @@
+package Tk::Entry;
+
+# Converted from entry.tcl --
+#
+# This file defines the default bindings for Tk entry widgets.
+#
+# @(#) entry.tcl 1.22 94/12/17 16:05:14
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+use strict;
+$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/;
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use Tk::Widget ();
+use Tk::Clipboard ();
+use base qw(Tk::Clipboard Tk::Widget);
+
+import Tk qw(Ev $XS_VERSION);
+
+Construct Tk::Widget 'Entry';
+
+bootstrap Tk::Entry;
+
+sub Tk_cmd { \&Tk::entry }
+
+Tk::Methods('bbox','delete','get','icursor','index','insert','scan',
+ 'selection','validate','xview');
+
+use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)],
+ 'xview' => [qw(moveto scroll)],
+ );
+
+sub wordstart
+{my ($w,$pos) = @_;
+ my $string = $w->get;
+ $pos = $w->index('insert')-1 unless(defined $pos);
+ $string = substr($string,0,$pos);
+ $string =~ s/\S*$//;
+ length $string;
+}
+
+sub wordend
+{my ($w,$pos) = @_;
+ my $string = $w->get;
+ my $anc = length $string;
+ $pos = $w->index('insert') unless(defined $pos);
+ $string = substr($string,$pos);
+ $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x;
+ $anc - length($string);
+}
+
+sub deltainsert
+{
+ my ($w,$d) = @_;
+ return $w->index('insert')+$d;
+}
+
+#
+# Bind --
+# This procedure is invoked the first time the mouse enters an
+# entry widget or an entry widget receives the input focus. It creates
+# all of the class bindings for entries.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard
+ $mw->bind($class,'<<Clear>>' => sub {
+ my $w = shift;
+ $w->delete("sel.first", "sel.last");
+ });
+ $mw->bind($class,'<<PasteSelection>>' => [sub {
+ my($w, $x) = @_;
+ # XXX logic in Tcl/Tk version screwed up?
+ if (!$Tk::strictMotif && !$Tk::mouseMoved) {
+ $w->Paste($x);
+ }
+ }, Ev('x')]);
+
+ # Standard Motif bindings:
+ # The <Escape> binding is different from the Tcl/Tk version:
+ $mw->bind($class,'<Escape>','selectionClear');
+
+ $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']);
+ $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']);
+ $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]);
+ $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']);
+
+ $mw->bind($class,'<Shift-1>','Shift_1');
+
+
+ $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]);
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<Control-1>','Control_1');
+ $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]);
+ $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]);
+ $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]);
+ $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]);
+ $mw->bind($class,'<Home>',['SetCursor',0]);
+ $mw->bind($class,'<Shift-Home>',['KeySelect',0]);
+ $mw->bind($class,'<End>',['SetCursor','end']);
+ $mw->bind($class,'<Shift-End>',['KeySelect','end']);
+ $mw->bind($class,'<Delete>','Delete');
+
+ $mw->bind($class,'<BackSpace>','Backspace');
+
+ $mw->bind($class,'<Control-space>',['selectionFrom','insert']);
+ $mw->bind($class,'<Select>',['selectionFrom','insert']);
+ $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']);
+ $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']);
+
+ $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']);
+ $mw->bind($class,'<Control-backslash>','selectionClear');
+
+ # $class->clipboardOperations($mw,qw[Copy Cut Paste]);
+
+ $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]);
+
+ # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
+ # Otherwise, if a widget binding for one of these is defined, the
+ # <KeyPress> class binding will also fire and insert the character,
+ # which is wrong. Ditto for Return, and Tab.
+
+ $mw->bind($class,'<Alt-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Meta-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Control-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Return>' ,'NoOp');
+ $mw->bind($class,'<KP_Enter>' ,'NoOp');
+ $mw->bind($class,'<Tab>' ,'NoOp');
+ if ($mw->windowingsystem =~ /^(?:classic|aqua)$/)
+ {
+ $mw->bind($class,'<Command-KeyPress>', 'NoOp');
+ }
+
+ # On Windows, paste is done using Shift-Insert. Shift-Insert already
+ # generates the <<Paste>> event, so we don't need to do anything here.
+ if ($Tk::platform ne 'MSWin32')
+ {
+ $mw->bind($class,'<Insert>','InsertSelection');
+ }
+
+ if (!$Tk::strictMotif)
+ {
+ # Additional emacs-like bindings:
+ $mw->bind($class,'<Control-a>',['SetCursor',0]);
+ $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Control-d>',['delete','insert']);
+ $mw->bind($class,'<Control-e>',['SetCursor','end']);
+ $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Control-h>','Backspace');
+ $mw->bind($class,'<Control-k>',['delete','insert','end']);
+
+ $mw->bind($class,'<Control-t>','Transpose');
+
+ # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead
+ $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]);
+ $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]);
+ $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]);
+ $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']);
+ $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']);
+
+ # A few additional bindings from John Ousterhout.
+# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']);
+ $mw->bind($class,'<2>','Button_2');
+ $mw->bind($class,'<B2-Motion>','B2_Motion');
+# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2');
+ }
+ return $class;
+}
+
+
+sub Shift_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::selectMode = 'char';
+ $w->selectionAdjust('@' . $Ev->x)
+}
+
+
+sub Control_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->icursor('@' . $Ev->x)
+}
+
+
+sub Delete
+{
+ my $w = shift;
+ if ($w->selectionPresent)
+ {
+ $w->deleteSelected
+ }
+ else
+ {
+ $w->delete('insert')
+ }
+}
+
+
+sub InsertSelection
+{
+ my $w = shift;
+ eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)}
+}
+
+
+# Original is ::tk::EntryScanMark
+sub Button_2
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->scan('mark',$Ev->x);
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::mouseMoved = 0
+}
+
+
+# Original is ::tk::EntryScanDrag
+sub B2_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ # Make sure these exist, as some weird situations can trigger the
+ # motion binding without the initial press. [Tcl/Tk Bug #220269]
+ if (!defined $Tk::x) { $Tk::x = $Ev->x }
+ if (abs(($Ev->x-$Tk::x)) > 2)
+ {
+ $Tk::mouseMoved = 1
+ }
+ $w->scan('dragto',$Ev->x)
+}
+
+
+# XXX Not needed anymore
+sub ButtonRelease_2
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if (!$Tk::mouseMoved)
+ {
+ eval
+ {local $SIG{__DIE__};
+ $w->insert('insert',$w->SelectionGet);
+ $w->SeeInsert;
+ }
+ }
+}
+
+sub Button1Release
+{
+ shift->CancelRepeat;
+}
+
+# ::tk::EntryClosestGap --
+# Given x and y coordinates, this procedure finds the closest boundary
+# between characters to the given coordinates and returns the index
+# of the character just after the boundary.
+#
+# Arguments:
+# w - The entry window.
+# x - X-coordinate within the window.
+sub ClosestGap
+{
+ my($w, $x) = @_;
+ my $pos = $w->index('@'.$x);
+ my @bbox = $w->bbox($pos);
+ if ($x - $bbox[0] < $bbox[2] / 2)
+ {
+ return $pos;
+ }
+ $pos + 1;
+}
+
+# Button1 --
+# This procedure is invoked to handle button-1 presses in entry
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the button press.
+sub Button1
+{
+ my $w = shift;
+ my $x = shift;
+ $Tk::selectMode = 'char';
+ $Tk::mouseMoved = 0;
+ $Tk::pressX = $x;
+ $w->icursor($w->ClosestGap($x));
+ $w->selectionFrom('insert');
+ $w->selectionClear;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->focus()
+ }
+}
+
+sub Motion
+{
+ my ($w,$x,$y) = @_;
+ $Tk::x = $x; # XXX ?
+ $w->MouseSelect($x);
+}
+
+# MouseSelect --
+# This procedure is invoked when dragging out a selection with
+# the mouse. Depending on the selection mode (character, word,
+# line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the mouse.
+sub MouseSelect
+{
+
+ my $w = shift;
+ my $x = shift;
+ return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry';
+ $Tk::selectMode = shift if (@_);
+ my $cur = $w->index($w->ClosestGap($x));
+ return unless defined $cur;
+ my $anchor = $w->index('anchor');
+ return unless defined $anchor;
+ $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"?
+ if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3))
+ {
+ $Tk::mouseMoved = 1
+ }
+ my $mode = $Tk::selectMode;
+ return unless $mode;
+ if ($mode eq 'char')
+ {
+ # The Tcl version uses selectionRange here XXX
+ if ($Tk::mouseMoved)
+ {
+ if ($cur < $anchor)
+ {
+ $w->selectionTo($cur)
+ }
+ else
+ {
+ $w->selectionTo($cur+1)
+ }
+ }
+ }
+ elsif ($mode eq 'word')
+ {
+ # The Tcl version uses tcl_wordBreakBefore/After here XXX
+ if ($cur < $w->index('anchor'))
+ {
+ $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1))
+ }
+ else
+ {
+ $w->selectionRange($w->wordstart($anchor),$w->wordend($cur))
+ }
+ }
+ elsif ($mode eq 'line')
+ {
+ $w->selectionRange(0,'end')
+ }
+ if (@_)
+ {
+ my $ipos = shift;
+ eval {local $SIG{__DIE__}; $w->icursor($ipos) };
+ }
+ $w->idletasks;
+}
+# ::tk::EntryPaste --
+# This procedure sets the insertion cursor to the current mouse position,
+# pastes the selection there, and sets the focus to the window.
+#
+# Arguments:
+# w - The entry window.
+# x - X position of the mouse.
+sub Paste
+{
+ my($w, $x) = @_;
+ $w->icursor($w->ClosestGap($x));
+ eval { local $SIG{__DIE__};
+ $w->insert("insert", $w->GetSelection);
+ $w->SeeInsert; # Perl/Tk extension
+ };
+ if ($w->cget(-state) ne 'disabled')
+ {
+ $w->focus;
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window left or right,
+# depending on where the mouse is, and reschedules itself as an
+# 'after' command so that the window continues to scroll until the
+# mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ my $x = shift;
+ return if !Tk::Exists($w);
+ if ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->MouseSelect($x);
+ $w->RepeatId($w->after(50,['AutoScan',$w,$x]))
+}
+# KeySelect
+# This procedure is invoked when stroking out selections using the
+# keyboard. It moves the cursor to a new position, then extends
+# the selection to that position.
+#
+# Arguments:
+# w - The entry window.
+# new - A new position for the insertion cursor (the cursor hasn't
+# actually been moved to this position yet).
+sub KeySelect
+{
+ my $w = shift;
+ my $new = shift;
+ if (!$w->selectionPresent)
+ {
+ $w->selectionFrom('insert');
+ $w->selectionTo($new)
+ }
+ else
+ {
+ $w->selectionAdjust($new)
+ }
+ $w->icursor($new);
+ $w->SeeInsert;
+}
+# Insert --
+# Insert a string into an entry at the point of the insertion cursor.
+# If there is a selection in the entry, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.
+#
+# Arguments:
+# w - The entry window in which to insert the string
+# s - The string to insert (usually just a single character)
+sub Insert
+{
+ my $w = shift;
+ my $s = shift;
+ return unless (defined $s && $s ne '');
+ eval
+ {local $SIG{__DIE__};
+ my $insert = $w->index('insert');
+ if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert)
+ {
+ $w->deleteSelected
+ }
+ };
+ $w->insert('insert',$s);
+ $w->SeeInsert
+}
+# Backspace --
+# Backspace over the character just before the insertion cursor.
+#
+# Arguments:
+# w - The entry window in which to backspace.
+sub Backspace
+{
+ my $w = shift;
+ if ($w->selectionPresent)
+ {
+ $w->deleteSelected
+ }
+ else
+ {
+ my $x = $w->index('insert')-1;
+ $w->delete($x) if ($x >= 0);
+ # XXX Missing repositioning part from Tcl/Tk source
+ }
+}
+# SeeInsert
+# Make sure that the insertion cursor is visible in the entry window.
+# If not, adjust the view so that it is.
+#
+# Arguments:
+# w - The entry window.
+sub SeeInsert
+{
+ my $w = shift;
+ my $c = $w->index('insert');
+#
+# Probably a bug in your version of tcl/tk (I've not this problem
+# when I test Entry in the widget demo for tcl/tk)
+# index('\@0') give always 0. Consequence :
+# if you make <Control-E> or <Control-F> view is adapted
+# but with <Control-A> or <Control-B> view is not adapted
+#
+ my $left = $w->index('@0');
+ if ($left > $c)
+ {
+ $w->xview($c);
+ return;
+ }
+ my $x = $w->width;
+ while ($w->index('@' . $x) <= $c && $left < $c)
+ {
+ $left += 1;
+ $w->xview($left)
+ }
+}
+# SetCursor
+# Move the insertion cursor to a given position in an entry. Also
+# clears the selection, if there is one in the entry, and makes sure
+# that the insertion cursor is visible.
+#
+# Arguments:
+# w - The entry window.
+# pos - The desired new position for the cursor in the window.
+sub SetCursor
+{
+ my $w = shift;
+ my $pos = shift;
+ $w->icursor($pos);
+ $w->selectionClear;
+ $w->SeeInsert;
+}
+# Transpose
+# This procedure implements the 'transpose' function for entry widgets.
+# It tranposes the characters on either side of the insertion cursor,
+# unless the cursor is at the end of the line. In this case it
+# transposes the two characters to the left of the cursor. In either
+# case, the cursor ends up to the right of the transposed characters.
+#
+# Arguments:
+# w - The entry window.
+sub Transpose
+{
+ my $w = shift;
+ my $i = $w->index('insert');
+ $i++ if ($i < $w->index('end'));
+ my $first = $i-2;
+ return if ($first < 0);
+ my $str = $w->get;
+ my $new = substr($str,$i-1,1) . substr($str,$first,1);
+ $w->delete($first,$i);
+ $w->insert('insert',$new);
+ $w->SeeInsert;
+}
+
+sub tabFocus
+{
+ my $w = shift;
+ $w->selectionRange(0,'end');
+ $w->icursor('end');
+ $w->SUPER::tabFocus;
+}
+
+# ::tk::EntryGetSelection --
+#
+# Returns the selected text of the entry with respect to the -show option.
+#
+# Arguments:
+# w - The entry window from which the text to get
+sub getSelected
+{
+ my $w = shift;
+ return undef unless $w->selectionPresent;
+ my $str = $w->get;
+ my $show = $w->cget('-show');
+ $str = $show x length($str) if (defined $show);
+ my $s = $w->index('sel.first');
+ my $e = $w->index('sel.last');
+ return substr($str,$s,$e-$s);
+}
+
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Entry.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Entry.pod
new file mode 100755
index 00000000000..af3ee7e623f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Entry.pod
@@ -0,0 +1,693 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Entry - Create and manipulate Entry widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+S< >I<$entry> = I<$parent>-E<gt>B<Entry>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-background> B<-highlightbackground> B<-insertontime> B<-selectforeground>
+B<-borderwidth> B<-highlightcolor> B<-insertwidth> B<-takefocus>
+B<-cursor> B<-highlightthickness> B<-justify> B<-textvariable>
+B<-exportselection> B<-insertbackground> B<-relief> B<-xscrollcommand>
+B<-font> B<-insertborderwidth> B<-selectbackground>
+B<-foreground> B<-insertofftime> B<-selectborderwidth>
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Command-Line Name: B<-disabledbackground>
+
+=item Database Name: B<disabledBackground>
+
+=item Database Class: B<DisabledBackground>
+
+Specifies the background color to use when the entry is disabled. If
+this option is the empty string, the normal background color is used.
+
+=item Command-Line Name: B<-disabledforeground>
+
+=item Database Name: B<disabledForeground>
+
+=item Database Class: B<DisabledForeground>
+
+Specifies the foreground color to use when the entry is disabled. If
+this option is the empty string, the normal foreground color is used.
+
+=item Name: B<invalidCommand>
+
+=item Class: B<InvalidCommand>
+
+=item Switch: B<-invalidcommand>
+
+=item Alias: B<-invcmd>
+
+Specifies a script to eval when B<validateCommand> returns 0.
+Setting it to <undef> disables this feature (the default). The best use
+of this option is to set it to I<bell>. See B<Validation>
+below for more information.
+
+=item Command-Line Name: B<-readonlybackground>
+
+=item Database Name: B<readonlyBackground>
+
+=item Database Class: B<ReadonlyBackground>
+
+Specifies the background color to use when the entry is read-only. If
+this option is the empty string, the normal background color is used.
+
+=item Name: B<show>
+
+=item Class: B<Show>
+
+=item Switch: B<-show>
+
+If this option is specified, then the true contents of the entry
+are not displayed in the window.
+Instead, each character in the entry's value will be displayed as
+the first character in the value of this option, such as ``*''.
+This is useful, for example, if the entry is to be used to enter
+a password.
+If characters in the entry are selected and copied elsewhere, the
+information copied will be what is displayed, not the true contents
+of the entry.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of three states for the entry: B<normal>, B<disabled>, or
+B<readonly>. If the entry is B<readonly>, then the value may not be changed
+using widget commands and no insertion cursor will be displayed, even
+if the input focus is in the widget; the contents of the widget may
+still be selected. If the entry is B<disabled>, the value may not be
+changed, no insertion cursor will be displayed, the contents will not
+be selectable, and the entry may be displayed in a different color,
+depending on the values of the B<-disabledforeground> and
+B<-disabledbackground> options.
+
+=item Name: B<validate>
+
+=item Class: B<Validate>
+
+=item Switch: B<-validate>
+
+Specifies the mode in which validation should operate: B<none>,
+B<focus>, B<focusin>, B<focusout>, B<key>, or B<all>.
+It defaults to B<none>. When you want validation, you must explicitly
+state which mode you wish to use. See B<Validation> below for more.
+
+=item Name: B<validateCommand>
+
+=item Class: B<ValidateCommand>
+
+=item Switch: B<-validatecommand>
+
+=item Alias: B<-vcmd>
+
+Specifies a script to eval when you want to validate the input into
+the entry widget. Setting it to C<undef> disables this feature (the default).
+This command must return a valid boolean value. If it returns 0 (or
+the valid boolean equivalent) then it means you reject the new edition
+and it will not occur and the B<invalidCommand> will be evaluated if it
+is set. If it returns 1, then the new edition occurs.
+See B<Validation> below for more information.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies an integer value indicating the desired width of the entry window,
+in average-size characters of the widget's font.
+If the value is less than or equal to zero, the widget picks a
+size just large enough to hold its current text.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Entry> method creates a new window (given by the
+$entry argument) and makes it into an entry widget.
+Additional options, described above, may be specified on the
+command line or in the option database
+to configure aspects of the entry such as its colors, font,
+and relief. The B<entry> command returns its
+$entry argument. At the time this command is invoked,
+there must not exist a window named $entry, but
+$entry's parent must exist.
+
+An entry is a widget that displays a one-line text string and
+allows that string to be edited using methods described below, which
+are typically bound to keystrokes and mouse actions.
+When first created, an entry's string is empty.
+A portion of the entry may be selected as described below.
+If an entry is exporting its selection (see the B<exportSelection>
+option), then it will observe the standard X11 protocols for handling the
+selection; entry selections are available as type B<STRING>.
+Entries also observe the standard Tk rules for dealing with the
+input focus. When an entry has the input focus it displays an
+I<insertion cursor> to indicate where new characters will be
+inserted.
+
+Entries are capable of displaying strings that are too long to
+fit entirely within the widget's window. In this case, only a
+portion of the string will be displayed; methods described below
+may be used to change the view in the window. Entries use
+the standard B<xScrollCommand> mechanism for interacting with
+scrollbars (see the description of the B<-xscrollcommand> option
+for details). They also support scanning, as described below.
+
+=head1 VALIDATION
+
+Validation of entry widgets is derived from part of the patch written by
+jhobbs@cs.uoregon.edu. This works by setting the B<validateCommand>
+option to a callback which will be evaluated according to the B<validate>
+option as follows:
+
+=over 4
+
+=item B<none>
+
+Default. This means no validation will occur.
+
+=item B<focus>
+
+B<validateCommand> will be called when the entry receives or
+loses focus.
+
+=item B<focusin>
+
+B<validateCommand> will be called when the entry receives focus.
+
+=item B<focusout>
+
+B<validateCommand> will be called when the entry loses focus.
+
+=item B<key>
+
+B<validateCommand> will be called when the entry is edited.
+
+=item B<all>
+
+B<validateCommand> will be called for all above conditions.
+
+=back
+
+The B<validateCommand> and B<invalidCommand> are called with the following
+arguments:
+
+=over 4
+
+=item * The proposed value of the entry. If you are configuring the
+entry widget to have a new textvariable, this will be the value of that
+textvariable.
+
+=item * The characters to be added (or deleted). This will be C<undef>
+if validation is due to focus, explcit call to validate or if change
+is due to C<-textvariable> changing.
+
+=item * The current value of entry i.e. before the proposed change.
+
+=item * index of char string to be added/deleted, if any. -1 otherwise
+
+=item * type of action. 1 == INSERT, 0 == DELETE,
+-1 if it's a forced validation or textvariable validation
+
+=back
+
+In general, the B<textVariable> and B<validateCommand> can be
+dangerous to mix. If you try set the B<textVariable>
+to something that the B<validateCommand> will not accept it will
+be set back to the value of the entry widget.
+Using the B<textVariable> for read-only purposes will never cause problems.
+
+The B<validateCommand> will turn itself off by setting
+B<validate> to B<none> when an error occurs, for example
+when the B<validateCommand> or B<invalidCommand> encounters
+an error in its script while evaluating, or
+B<validateCommand> does not return a valid boolean value.
+
+With the perl/Tk version B<validate> option is supposed to be
+"suspended" while executing the B<validateCommand> or the B<invalidCommand>.
+This is experimental but in theory either callback can "correct" the
+value of the widget, and override the proposed change. (B<validateCommand>
+should still return false to inhibit the change from happening when
+it returns.)
+
+=head1 WIDGET METHODS
+
+The B<Entry> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+Many of the additional methods for entries take one or more indices as
+arguments. An index specifies a particular character in the entry's
+string, in any of the following ways:
+
+=over 4
+
+=item I<number>
+
+Specifies the character as a numerical index, where 0 corresponds
+to the first character in the string.
+
+=item B<anchor>
+
+Indicates the anchor point for the selection, which is set with the
+B<selectionFrom> and B<selectionAdjust> methods.
+
+=item B<end>
+
+Indicates the character just after the last one in the entry's string.
+This is equivalent to specifying a numerical index equal to the length
+of the entry's string.
+
+=item B<insert>
+
+Indicates the character adjacent to and immediately following the
+insertion cursor.
+
+=item B<sel.first>
+
+Indicates the first character in the selection. It is an error to
+use this form if the selection isn't in the entry window.
+
+=item B<sel.last>
+
+Indicates the character just after the last one in the selection.
+It is an error to use this form if the selection isn't in the
+entry window.
+
+=item B<@>I<number>
+
+In this form, I<number> is treated as an x-coordinate in the
+entry's window; the character spanning that x-coordinate is used.
+For example, ``B<@0>'' indicates the left-most character in the
+window.
+
+=back
+
+Abbreviations may be used for any of the forms above, e.g. ``B<e>''
+or ``B<sel.f>''. In general, out-of-range indices are automatically
+rounded to the nearest legal value.
+
+The following additional methods are available for entry widgets:
+
+=over 4
+
+=item I<$entry>-E<gt>B<bbox>(I<index>)
+
+Returns a list of four numbers describing the bounding box of the
+character given by I<index>.
+The first two elements of the list give the x and y coordinates of
+the upper-left corner of the screen area covered by the character
+(in pixels relative to the widget) and the last two elements give
+the width and height of the character, in pixels.
+The bounding box may refer to a region outside the visible area
+of the window.
+
+=item I<$entry>-E<gt>B<delete>(I<first, >?I<last>?)
+
+Returns the current value of the configuration option given
+by I<option>.
+I<Option> may have any of the values accepted by the B<entry>
+command.
+
+=item I<$entry>-E<gt>B<configure>(?I<option>?, ?I<value, option, value, ...>?)
+
+Query or modify the configuration options of the widget.
+If no I<option> is specified, returns a list describing all of
+the available options for $entry (see L<Tk::configure> for
+information on the format of this list). If I<option> is specified
+with no I<value>, then the command returns a list describing the
+one named option (this list will be identical to the corresponding
+sublist of the value returned if no I<option> is specified). If
+one or more I<option-value> pairs are specified, then the command
+modifies the given widget option(s) to have the given value(s); in
+this case the command returns an empty string.
+I<Option> may have any of the values accepted by the B<entry>
+command.
+
+=item I<$entry>-E<gt>B<delete>(I<first, >?I<last>?)
+
+Delete one or more elements of the entry.
+I<First> is the index of the first character to delete, and
+I<last> is the index of the character just after the last
+one to delete.
+If I<last> isn't specified it defaults to I<first>+1,
+i.e. a single character is deleted.
+This method returns an empty string.
+
+=item I<$entry>-E<gt>B<get>
+
+Returns the entry's string.
+
+=item I<$entry>-E<gt>B<icursor>(I<index>)
+
+Arrange for the insertion cursor to be displayed just before the character
+given by I<index>. Returns an empty string.
+
+=item I<$entry>-E<gt>B<index>(I<index>)
+
+Returns the numerical index corresponding to I<index>.
+
+=item I<$entry>-E<gt>B<insert>(I<index, string>)
+
+Insert the characters of I<string> just before the character
+indicated by I<index>. Returns an empty string.
+
+=item I<$entry>->B<scan>(I<option, args>)
+
+=item I<$entry>->B<scan>I<Option>(I<args>)
+
+This method is used to implement scanning on entries. It has
+two forms, depending on I<Option>:
+
+=over 8
+
+=item I<$entry>->B<scanMark>(I<x>)
+
+Records I<x> and the current view in the entry widget; used in
+conjunction with later B<scanDragto> methods. Typically this
+method is associated with a mouse button press in the widget. It
+returns an empty string.
+
+=item I<$entry>->B<scanDragto>(I<x>)
+
+This method computes the difference between its I<x> argument
+and the I<x> argument to the last B<scanMark> method for
+the widget. It then adjusts the view left or right by 10 times the
+difference in x-coordinates. This method is typically associated
+with mouse motion events in the widget, to produce the effect of
+dragging the entry at high speed through the widget. The return
+value is an empty string.
+
+=back
+
+=item I<$entry>->B<selection>(I<option, arg>)
+
+=item I<$entry>->B<selection>I<Option>(I<arg>)
+
+This method is used to adjust the selection within an entry. It
+has several forms, depending on I<Option>:
+
+=over 8
+
+=item I<$entry>-E<gt>B<selectionAdjust>(I<index>)
+
+Locate the end of the selection nearest to the character given by
+I<index>, and adjust that end of the selection to be at I<index>
+(i.e including but not going beyond I<index>). The other
+end of the selection is made the anchor point for future
+B<selectionTo> methods. If the selection
+isn't currently in the entry, then a new selection is created to
+include the characters between I<index> and the most recent
+selection anchor point, inclusive.
+Returns an empty string.
+
+=item I<$entry>-E<gt>B<selectionClear>
+
+Clear the selection if it is currently in this widget. If the
+selection isn't in this widget then the method has no effect.
+Returns an empty string.
+
+=item I<$entry>-E<gt>B<selectionFrom>(I<index>)
+
+Set the selection anchor point to just before the character
+given by I<index>. Doesn't change the selection.
+Returns an empty string.
+
+=item I<$entry>-E<gt>B<selectionPresent>
+
+Returns 1 if there is are characters selected in the entry,
+0 if nothing is selected.
+
+=item I<$entry>-E<gt>B<selectionRange>(I<start, >I<end>)
+
+Sets the selection to include the characters starting with
+the one indexed by I<start> and ending with the one just
+before I<end>.
+If I<end> refers to the same character as I<start> or an
+earlier one, then the entry's selection is cleared.
+
+=item I<$entry>-E<gt>B<selectionTo>(I<index>)
+
+If I<index> is before the anchor point, set the selection
+to the characters from I<index> up to but not including
+the anchor point.
+If I<index> is the same as the anchor point, do nothing.
+If I<index> is after the anchor point, set the selection
+to the characters from the anchor point up to but not including
+I<index>.
+The anchor point is determined by the most recent B<selectionFrom>
+or B<selectionAdjust> method in this widget.
+If the selection isn't in this widget then a new selection is
+created using the most recent anchor point specified for the widget.
+Returns an empty string.
+
+=back
+
+=item I<$entry>-E<gt>B<validate>
+
+This command is used to force an evaluation of the B<validateCommand>
+independent of the conditions specified by the B<validate> option. It
+returns 0 or 1.
+
+=item I<$entry>-E<gt>B<xview>(I<args>)
+
+This command is used to query and change the horizontal position of the
+text in the widget's window. It can take any of the following
+forms:
+
+=over 8
+
+=item I<$entry>-E<gt>B<xview>
+
+Returns a list containing two elements.
+Each element is a real fraction between 0 and 1; together they describe
+the horizontal span that is visible in the window.
+For example, if the first element is .2 and the second element is .7,
+20% of the entry's text is off-screen to the left, the middle 50% is visible
+in the window, and 30% of the text is off-screen to the right.
+These are the same values passed to scrollbars via the B<-xscrollcommand>
+option.
+
+=item I<$entry>-E<gt>B<xview>(I<index>)
+
+Adjusts the view in the window so that the character given by I<index>
+is displayed at the left edge of the window.
+
+=item I<$entry>-E<gt>B<xviewMoveto>(I<fraction>)
+
+Adjusts the view in the window so that the character I<fraction> of the
+way through the text appears at the left edge of the window.
+I<Fraction> must be a fraction between 0 and 1.
+
+=item I<$entry>-E<gt>B<xviewScroll>(I<number, what>)
+
+This method shifts the view in the window left or right according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages> or an abbreviation
+of one of these.
+If I<what> is B<units>, the view adjusts left or right by
+I<number> average-width characters on the display; if it is
+B<pages> then the view adjusts by I<number> screenfuls.
+If I<number> is negative then characters farther to the left
+become visible; if it is positive then characters farther to the right
+become visible.
+
+=back
+
+=back
+
+=head1 DEFAULT BINDINGS
+
+Tk automatically creates class bindings for entries that give them
+the following default behavior.
+In the descriptions below, ``word'' refers to a contiguous group
+of letters, digits, or ``_'' characters, or any single character
+other than these.
+
+=over 4
+
+=item [1]
+
+Clicking mouse button 1 positions the insertion cursor
+just before the character underneath the mouse cursor, sets the
+input focus to this widget, and clears any selection in the widget.
+Dragging with mouse button 1 strokes out a selection between
+the insertion cursor and the character under the mouse.
+
+=item [2]
+
+Double-clicking with mouse button 1 selects the word under the mouse
+and positions the insertion cursor at the beginning of the word.
+Dragging after a double click will stroke out a selection consisting
+of whole words.
+
+=item [3]
+
+Triple-clicking with mouse button 1 selects all of the text in the
+entry and positions the insertion cursor before the first character.
+
+=item [4]
+
+The ends of the selection can be adjusted by dragging with mouse
+button 1 while the Shift key is down; this will adjust the end
+of the selection that was nearest to the mouse cursor when button
+1 was pressed.
+If the button is double-clicked before dragging then the selection
+will be adjusted in units of whole words.
+
+=item [5]
+
+Clicking mouse button 1 with the Control key down will position the
+insertion cursor in the entry without affecting the selection.
+
+=item [6]
+
+If any normal printing characters are typed in an entry, they are
+inserted at the point of the insertion cursor.
+
+=item [7]
+
+The view in the entry can be adjusted by dragging with mouse button 2.
+If mouse button 2 is clicked without moving the mouse, the selection
+is copied into the entry at the position of the mouse cursor.
+
+=item [8]
+
+If the mouse is dragged out of the entry on the left or right sides
+while button 1 is pressed, the entry will automatically scroll to
+make more text visible (if there is more text off-screen on the side
+where the mouse left the window).
+
+=item [9]
+
+The Left and Right keys move the insertion cursor one character to the
+left or right; they also clear any selection in the entry and set
+the selection anchor.
+If Left or Right is typed with the Shift key down, then the insertion
+cursor moves and the selection is extended to include the new character.
+Control-Left and Control-Right move the insertion cursor by words, and
+Control-Shift-Left and Control-Shift-Right move the insertion cursor
+by words and also extend the selection.
+Control-b and Control-f behave the same as Left and Right, respectively.
+Meta-b and Meta-f behave the same as Control-Left and Control-Right,
+respectively.
+
+=item [10]
+
+The Home key, or Control-a, will move the insertion cursor to the
+beginning of the entry and clear any selection in the entry.
+Shift-Home moves the insertion cursor to the beginning of the entry
+and also extends the selection to that point.
+
+=item [11]
+
+The End key, or Control-e, will move the insertion cursor to the
+end of the entry and clear any selection in the entry.
+Shift-End moves the cursor to the end and extends the selection
+to that point.
+
+=item [12]
+
+The Select key and Control-Space set the selection anchor to the position
+of the insertion cursor. They don't affect the current selection.
+Shift-Select and Control-Shift-Space adjust the selection to the
+current position of the insertion cursor, selecting from the anchor
+to the insertion cursor if there was not any selection previously.
+
+=item [13]
+
+Control-/ selects all the text in the entry.
+
+=item [14]
+
+Control-\ clears any selection in the entry.
+
+=item [15]
+
+The F16 key (labelled Copy on many Sun workstations) or Meta-w
+copies the selection in the widget to the clipboard, if there is a selection.
+
+=item [16]
+
+The F20 key (labelled Cut on many Sun workstations) or Control-w
+copies the selection in the widget to the clipboard and deletes
+the selection.
+If there is no selection in the widget then these keys have no effect.
+
+=item [17]
+
+The F18 key (labelled Paste on many Sun workstations) or Control-y
+inserts the contents of the clipboard at the position of the
+insertion cursor.
+
+=item [18]
+
+The Delete key deletes the selection, if there is one in the entry.
+If there is no selection, it deletes the character to the right of
+the insertion cursor.
+
+=item [19]
+
+The BackSpace key and Control-h delete the selection, if there is one
+in the entry.
+If there is no selection, it deletes the character to the left of
+the insertion cursor.
+
+=item [20]
+
+Control-d deletes the character to the right of the insertion cursor.
+
+=item [21]
+
+Meta-d deletes the word to the right of the insertion cursor.
+
+=item [22]
+
+Control-k deletes all the characters to the right of the insertion
+cursor.
+
+=item [23]
+
+Control-t reverses the order of the two characters to the right of
+the insertion cursor.
+
+If the entry is disabled using the B<-state> option, then the entry's
+view can still be adjusted and text in the entry can still be selected,
+but no insertion cursor will be displayed and no text modifications will
+take place.
+
+The behavior of entries can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 KEYWORDS
+
+entry, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Error.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Error.pod
new file mode 100755
index 00000000000..9c38f0b7d74
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Error.pod
@@ -0,0 +1,145 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Error - Method invoked to process background errors
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+Customization:
+
+ require Tk::ErrorDialog;
+
+or
+
+ sub Tk::Error
+ {
+ my ($widget,$error,@locations) = @_;
+ ...
+
+ }
+
+=head1 DESCRIPTION
+
+The B<Tk::Error> method is invoked by perl/Tk when a background
+error occurs. Two possible implementations are provided in the
+distribution and individual applications or users can (re)define a B<Tk::Error>
+method (e.g. as a perl sub) if they wish to handle background
+errors in some other manner.
+
+A background error is one that occurs in a command that didn't
+originate with the application. For example, if an error occurs
+while executing a L<callback|Tk::callbacks> specified with a
+L<bind|Tk::bind> or a L<after|Tk::after>
+command, then it is a background error. For a non-background error,
+the error can simply be returned up through nested subroutines
+until it reaches the top-level code in the application;
+then the application can report the error in whatever way it
+wishes. When a background error occurs, the unwinding ends in
+the Tk library and there is no obvious way for Tk to report
+the error.
+
+When Tk detects a background error, it saves information about the
+error and invokes the B<Tk::Error> method later when Tk is idle.
+
+B<Tk::Error> is invoked by perl/Tk as if by the perl code:
+
+S< >I<$mainwindow>-E<gt>B<Tk::Error>(I<"error message">, I<location ...>);
+
+I<$mainwindow> is the B<MainWindow> associated with widget which
+detected the error, I<"error message"> is a string describing the error
+that has been detected, I<location> is a list of one or more "locations"
+which describe the call sequence at the point the error was detected.
+
+The locations are a typically a mixture of perl location reports giving
+script name and line number, and simple strings describing locations in
+core Tk or perl/Tk C code.
+
+Tk will ignore any result returned by the B<Tk::Error> method.
+If another error occurs within the B<Tk::Error> method
+(for example if it calls B<die>) then Tk reports this error
+itself by writing a message to stderr (this is to avoid infinite loops
+due to any bugs in B<Tk::Error>).
+
+If several background errors accumulate before B<Tk::Error>
+is invoked to process them, B<Tk::Error> will be invoked once
+for each error, in the order they occurred.
+However, if B<Tk::Error> calls B<Tk-E<gt>break>, then
+any remaining errors are skipped without calling B<Tk::Error>.
+
+The B<Tk> module includes a default B<Tk::Error> subroutine
+that simply reports the error on stderr.
+
+=head1 Tk::ErrorDialog
+
+An alternate definition is provided via:
+
+S< >C<require Tk::ErrorDialog;>
+
+that posts a dialog box containing the error message and offers
+the user a chance to see a stack trace showing where the
+error occurred.
+
+This is an OO implementation of the Tcl/Tk command B<bgerror>, with a
+twist: since there is only one B<ErrorDialog> widget, you aren't required
+to invoke the constructor to create it; it will be created
+automatically when the first background error occurs. However, in
+order to configure the I<-cleanupcode> and I<-appendtraceback>
+B<ErrorDialog> options you must call the constructor and create it
+manually.
+
+The B<ErrorDialog> object essentially consists of two subwidgets: a
+B<Dialog> widget to display the background error and a B<Text> widget
+for the traceback information. If required, you can invoke various
+widget methods to customize these subwidgets - their advertised names
+are described below.
+
+S< >I<$mw>-E<gt>B<ErrorDialog>(-cleanupcode => I<code>, -appendtraceback => I<bool>);
+
+$mw is a window reference.
+
+I<code> is a CODE reference if special post-background error
+processing is required (default is undefined). The callback subroutine
+is called with @_ having the same arguments that B<Tk::Error> was
+invoked with.
+
+I<bool> is a boolean indicating whether or not to append successive
+tracebacks (default is 1, do append).
+
+=head2 Advertised ErrorDialog widgets
+
+I<error_dialog> is the Dialog widget reference.
+
+I<text> is the Text widget reference containing the traceback information.
+
+=head1 BUGS
+
+If B<after> or B<fileevent> are not invoked as methods of a widget
+then perl/Tk is unable to provide a I<$mainwindow> argument.
+To support such code from earlier versions of perl/Tk
+perl/Tk therefore calls B<Tk::Error> with string 'Tk' instead:
+B<Tk-E<gt>Tk::Error\(...\)>.
+In this case the B<Tk::Error> in B<Tk::ErrorDialog> and similar
+implementations cannot "popup" a window as they don't know which display
+to use. A mechanism to supply I<the> B<MainWindow> in applications
+which only have one (a very common case) should be provided.
+
+=head1 SEE ALSO
+
+L<Tk::bind|Tk::bind>
+L<Tk::after|Tk::after>
+L<Tk::fileevent|Tk::fileevent>
+
+=head1 KEYWORDS
+
+background error, reporting
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ErrorDialog.pm b/Master/tlpkg/tlperl.straw/lib/Tk/ErrorDialog.pm
new file mode 100755
index 00000000000..19377eaeca4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ErrorDialog.pm
@@ -0,0 +1,125 @@
+package Tk::ErrorDialog;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use Tk ();
+require Tk::Dialog;
+use base qw(Tk::Toplevel);
+
+
+# ErrorDialog - a translation of bgerror() from Tcl/Tk to Perl/Tk.
+#
+# Currently TkPerl background errors are sent to stdout/stderr; use this
+# module if you want them in a window. You can also "roll your own" by
+# supplying the routine Tk::Error.
+
+use strict;
+
+Construct Tk::Widget 'ErrorDialog';
+
+my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'],
+ -bitmap => 'error'
+ );
+my $ED_OBJECT;
+
+sub import
+{
+ my $class = shift;
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $options{$key} = $val;
+ }
+}
+
+sub Populate {
+
+ # ErrorDialog constructor. Uses `new' method from base class
+ # to create object container then creates the dialog toplevel and the
+ # traceback toplevel.
+
+ my($cw, $args) = @_;
+
+ my $dr = $cw->Dialog(
+ -title => 'Error in '.$cw->MainWindow->name,
+ -text => 'on-the-fly-text',
+ -bitmap => $options{'-bitmap'},
+ -buttons => $options{'-buttons'},
+ );
+ $cw->minsize(1, 1);
+ $cw->title('Stack Trace for Error');
+ $cw->iconname('Stack Trace');
+ my $t_ok = $cw->Button(
+ -text => 'OK',
+ -command => [
+ sub {
+ shift->withdraw;
+ }, $cw,
+ ]
+ );
+ my $t_text = $cw->Text(
+ -relief => 'sunken',
+ -bd => 2,
+ -setgrid => 'true',
+ -width => 60,
+ -height => 20,
+ );
+ my $t_scroll = $cw->Scrollbar(
+ -relief => 'sunken',
+ -command => ['yview', $t_text],
+ );
+ $t_text->configure(-yscrollcommand => ['set', $t_scroll]);
+ $t_ok->pack(-side => 'bottom', -padx => '3m', -pady => '2m');
+ $t_scroll->pack(-side => 'right', -fill => 'y');
+ $t_text->pack(-side => 'left', -expand => 'yes', -fill => 'both');
+ $cw->withdraw;
+
+ $cw->Advertise(error_dialog => $dr); # advertise dialog widget
+ $cw->Advertise(text => $t_text); # advertise text widget
+ $cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef],
+ -appendtraceback => [ PASSIVE => undef, undef, 1 ]);
+ $ED_OBJECT = $cw;
+ $cw->protocol('WM_DELETE_WINDOW' => sub {$cw->withdraw});
+ return $cw;
+
+} # end Populate
+
+sub Tk::Error {
+
+ # Post a dialog box with the error message and give the user a chance
+ # to see a more detailed stack trace.
+
+ my($w, $error, @msgs) = @_;
+
+ my $grab = $w->grab('current');
+ $grab->Unbusy if (defined $grab);
+
+ $w->ErrorDialog if not defined $ED_OBJECT;
+
+ my($d, $t) = ($ED_OBJECT->Subwidget('error_dialog'), $ED_OBJECT->Subwidget('text'));
+# chop $error;
+ $d->configure(-text => "Error: $error");
+ $d->bell;
+ my $ans = $d->Show;
+
+ $t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'};
+ $t->insert('end', "\n");
+ $t->mark('set', 'ltb', 'end');
+ $t->insert('end', "--- Begin Traceback ---\n$error\n");
+ my $msg;
+ for $msg (@msgs) {
+ $t->insert('end', "$msg\n");
+ }
+ $t->yview('ltb');
+
+ $ED_OBJECT->deiconify if ($ans =~ /trace/i);
+
+ my $c = $ED_OBJECT->{Configure}{'-cleanupcode'};
+ &$c if defined $c; # execute any cleanup code if it was defined
+ $w->break if ($ans =~ /skip/i);
+
+} # end Tk::Error
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Event.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Event.pm
new file mode 100755
index 00000000000..540d7bec428
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Event.pm
@@ -0,0 +1,14 @@
+package Tk::Event;
+use vars qw($VERSION $XS_VERSION @EXPORT_OK);
+END { CleanupGlue() }
+$VERSION = '4.019'; # was: sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
+$XS_VERSION = '804.028';
+$XS_VERSION = eval $XS_VERSION;
+use base qw(Exporter);
+use XSLoader;
+@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS);
+XSLoader::load 'Tk::Event',$XS_VERSION;
+require Tk::Event::IO;
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Event/IO.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Event/IO.pm
new file mode 100755
index 00000000000..10b47e246ff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Event/IO.pm
@@ -0,0 +1,132 @@
+package Tk::Event::IO;
+use strict;
+use Carp;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Exporter);
+use Symbol ();
+
+@EXPORT_OK = qw(READABLE WRITABLE);
+
+sub PrintArgs
+{
+ my $func = (caller(1))[3];
+ print "$func(",join(',',@_),")\n";
+}
+
+sub PRINT
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return print $h @_;
+}
+
+sub PRINTF
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return printf $h @_;
+}
+
+sub WRITE
+{
+ my $obj = $_[0];
+ $obj->wait(WRITABLE);
+ return syswrite($obj->handle,$_[1],$_[2]);
+}
+
+my $depth = 0;
+sub READLINE
+{
+ my $obj = shift;
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ my $w = <$h>;
+ return $w;
+}
+
+sub READ
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0);
+}
+
+sub GETC
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return getc($h);
+}
+
+sub CLOSE
+{
+ my $obj = shift;
+ $obj->unwatch;
+ my $h = $obj->handle;
+ return close($h);
+}
+
+sub EOF
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return eof($h);
+}
+
+sub FILENO
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return fileno($h);
+}
+
+sub imode
+{
+ my $mode = shift;
+ my $imode = ${{'readable' => READABLE(),
+ 'writable' => WRITABLE()}}{$mode};
+ croak("Invalid handler type '$mode'") unless (defined $imode);
+ return $imode;
+}
+
+sub fileevent
+{
+ my ($widget,$file,$mode,$cb) = @_;
+ my $imode = imode($mode);
+ unless (ref $file)
+ {
+ no strict 'refs';
+ $file = Symbol::qualify($file,(caller)[0]);
+ $file = \*{$file};
+ }
+ my $obj = tied(*$file);
+ unless ($obj && $obj->isa('Tk::Event::IO'))
+ {
+ $obj = tie *$file,'Tk::Event::IO', $file;
+ }
+ if (@_ == 3)
+ {
+ # query return the handler
+ return $obj->handler($imode);
+ }
+ else
+ {
+ # set the handler
+ my $h = $obj->handler($imode,$cb);
+ undef $obj; # Prevent warnings about untie with ref to object
+ unless ($h)
+ {
+ untie *$file;
+ }
+ }
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Eventloop.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Eventloop.pod
new file mode 100755
index 00000000000..a4c99e7988e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Eventloop.pod
@@ -0,0 +1,62 @@
+
+=head1 NAME
+
+Tk::Event - ToolKit for Events
+
+=for category Implementation
+
+=head1 SYNOPSIS
+
+ use Tk::Event;
+
+ Tk::Event->fileevent(\*FH, 'readable' => callback);
+
+ Tk::Event->lineavail(\*FH, callback);
+
+ use Tk::Event::Signal qw(INT);
+
+ $SIG{'INT'} = callback;
+
+ use Tk::Event::process;
+
+ Tk::Event->proc($pid, callback);
+
+ QueueEvent(callback [, position])
+
+
+=head1 DESCRIPTION
+
+
+That is better than nothing but still hard to use. Most scripts want higher
+level result (a line, a "block" of data etc.)
+
+So it has occured to me that we could use new-ish TIEHANDLE thus:
+
+ my $obj = tie SOMEHANDLE,Tk::Event::IO;
+
+ while (<SOMEHANDLE>)
+ {
+ }
+
+Then the READLINE routine registers a callback and looks something like:
+
+ sub READLINE
+ {
+ my $obj = shift;
+ Event->io(*$obj,'readable',sub { sysread(*$obj,${*$obj},1,length(${*$obj}) });
+ my $pos;
+ while (($pos = index(${*$obj},$/) < 0)
+ {
+ DoOneEvent();
+ }
+ Event->io(*$obj,'readable',''); # unregister
+ $pos += length($/);
+ my $result = substr(${*$obj},0,$pos);
+ substr(${*$obj},0,$pos) = '';
+ return $result;
+ }
+
+This is using the scalar part of the glob representing the _inner_ IO
+as a buffer in which to accumulate chars.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/FBox.pm b/Master/tlpkg/tlperl.straw/lib/Tk/FBox.pm
new file mode 100755
index 00000000000..74e4ab4199b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/FBox.pm
@@ -0,0 +1,1063 @@
+# -*- perl -*-
+#
+# tkfbox.tcl --
+#
+# Implements the "TK" standard file selection dialog box. This
+# dialog box is used on the Unix platforms whenever the tk_strictMotif
+# flag is not set.
+#
+# The "TK" standard file selection dialog box is similar to the
+# file selection dialog box on Win95(TM). The user can navigate
+# the directories by clicking on the folder icons or by
+# selecting the "Directory" option menu. The user can select
+# files by clicking on the file icons or by entering a filename
+# in the "Filename:" entry.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Translated to perl/Tk by Slaven Rezic <slaven@rezic.de>.
+#
+
+#----------------------------------------------------------------------
+#
+# F I L E D I A L O G
+#
+#----------------------------------------------------------------------
+# tkFDialog --
+#
+# Implements the TK file selection dialog. This dialog is used when
+# the tk_strictMotif flag is set to false. This procedure shouldn't
+# be called directly. Call tk_getOpenFile or tk_getSaveFile instead.
+#
+
+package Tk::FBox;
+require Tk::Toplevel;
+
+use strict;
+use vars qw($VERSION $updirImage $folderImage $fileImage);
+
+#$VERSION = sprintf '4.%03d', q$Revision: #18 $ =~ /\D(\d+)\s*$/;
+$VERSION = '4.019';
+
+use base qw(Tk::Toplevel);
+
+Construct Tk::Widget 'FBox';
+
+sub import {
+ if (defined $_[1] and $_[1] eq 'as_default') {
+ local $^W = 0;
+ package Tk;
+ if ($Tk::VERSION < 804) {
+ *FDialog = \&Tk::FBox::FDialog;
+ *MotifFDialog = \&Tk::FBox::FDialog;
+ } else {
+ *tk_getOpenFile = sub {
+ Tk::FBox::FDialog("tk_getOpenFile", @_);
+ };
+ *tk_getSaveFile = sub {
+ Tk::FBox::FDialog("tk_getSaveFile", @_);
+ };
+ }
+ }
+}
+
+# Note that -sortcmd is experimental and the interface is likely to change.
+# Using -sortcmd is really strange :-(
+# $top->getOpenFile(-sortcmd => sub { package Tk::FBox; uc $b cmp uc $a});
+# or, un-perlish, but useable (now activated in code):
+# $top->getOpenFile(-sortcmd => sub { uc $_[1] cmp uc $_[0]});
+
+sub Populate {
+ my($w, $args) = @_;
+
+ require Tk::IconList;
+ require File::Basename;
+ require Cwd;
+
+ $w->SUPER::Populate($args);
+
+ $w->{'encoding'} = $w->getEncoding('iso_8859_1');
+
+ # f1: the frame with the directory option menu
+ my $f1 = $w->Frame;
+ my $lab = $f1->Label(-text => 'Directory:', -underline => 0);
+ $w->{'dirMenu'} = my $dirMenu =
+ $f1->Optionmenu(-variable => \$w->{'selectPath'},
+ -textvariable => \$w->{'selectPath'},
+ -command => ['SetPath', $w]);
+ my $upBtn = $f1->Button;
+ if (!defined $updirImage->{$w->MainWindow}) {
+ $updirImage->{$w->MainWindow} = $w->Bitmap(-data => <<EOF);
+#define updir_width 28
+#define updir_height 16
+static char updir_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
+ 0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
+ 0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
+ 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
+ 0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
+ 0xf0, 0xff, 0xff, 0x01};
+EOF
+ }
+ $upBtn->configure(-image => $updirImage->{$w->MainWindow});
+ $dirMenu->configure(-takefocus => 1, -highlightthickness => 2);
+ $upBtn->pack(-side => 'right', -padx => 4, -fill => 'both');
+ $lab->pack(-side => 'left', -padx => 4, -fill => 'both');
+ $dirMenu->pack(-expand => 'yes', -fill => 'both', -padx => 4);
+
+ $w->{'icons'} = my $icons =
+ $w->IconList(-command => ['OkCmd', $w, 'iconlist'],
+ );
+ $icons->bind('<<ListboxSelect>>' => [$w, 'ListBrowse']);
+
+ # f2: the frame with the OK button and the "file name" field
+ my $f2 = $w->Frame(-bd => 0);
+#XXX File name => File names if multiple
+ my $f2_lab = $f2->Label(-text => 'File name:', -anchor => 'e',
+ -width => 14, -underline => 5, -pady => 0);
+ $w->{'ent'} = my $ent = $f2->Entry;
+
+ # The font to use for the icons. The default Canvas font on Unix
+ # is just deviant.
+# $w->{'icons'}{'font'} = $ent->cget(-font);
+ $w->{'icons'}->configure(-font => $ent->cget(-font));
+
+ # f3: the frame with the cancel button and the file types field
+ my $f3 = $w->Frame(-bd => 0);
+
+ # The "File of types:" label needs to be grayed-out when
+ # -filetypes are not specified. The label widget does not support
+ # grayed-out text on monochrome displays. Therefore, we have to
+ # use a button widget to emulate a label widget (by setting its
+ # bindtags)
+ $w->{'typeMenuLab'} = my $typeMenuLab = $f3->Button
+ (-text => 'Files of type:',
+ -anchor => 'e',
+ -width => 14,
+ -underline => 9,
+ -bd => $f2_lab->cget(-bd),
+ -highlightthickness => $f2_lab->cget(-highlightthickness),
+ -relief => $f2_lab->cget(-relief),
+ -padx => $f2_lab->cget(-padx),
+ -pady => $f2_lab->cget(-pady),
+ -takefocus => 0,
+ );
+ $typeMenuLab->bindtags([$typeMenuLab, 'Label',
+ $typeMenuLab->toplevel, 'all']);
+ $w->{'typeMenuBtn'} = my $typeMenuBtn =
+ $f3->Menubutton(-indicatoron => 1, -tearoff => 0);
+ $typeMenuBtn->configure(-takefocus => 1,
+ -highlightthickness => 2,
+ -relief => 'raised',
+ -bd => 2,
+ -anchor => 'w',
+ );
+
+ # the okBtn is created after the typeMenu so that the keyboard traversal
+ # is in the right order
+ $w->{'okBtn'} = my $okBtn = $f2->Button
+ (-text => 'OK',
+ -underline => 0,
+ -width => 6,
+ -default => 'active',
+ -pady => 3,
+ );
+ my $cancelBtn = $f3->Button
+ (-text => 'Cancel',
+ -underline => 0,
+ -width => 6,
+ -default => 'normal',
+ -pady => 3,
+ );
+
+ # pack the widgets in f2 and f3
+ $okBtn->pack(-side => 'right', -padx => 4, -anchor => 'e');
+ $f2_lab->pack(-side => 'left', -padx => 4);
+ $ent->pack(-expand => 'yes', -fill => 'x', -padx => 2, -pady => 0);
+ $cancelBtn->pack(-side => 'right', -padx => 4, -anchor => 'w');
+ $typeMenuLab->pack(-side => 'left', -padx => 4);
+ $typeMenuBtn->pack(-expand => 'yes', -fill => 'x', -side => 'right');
+
+ # Pack all the frames together. We are done with widget construction.
+ $f1->pack(-side => 'top', -fill => 'x', -pady => 4);
+ $f3->pack(-side => 'bottom', -fill => 'x');
+ $f2->pack(-side => 'bottom', -fill => 'x');
+ $icons->pack(-expand => 'yes', -fill => 'both', -padx => 4, -pady => 1);
+
+ # Set up the event handlers
+ $ent->bind('<Return>',[$w,'ActivateEnt']);
+ $upBtn->configure(-command => ['UpDirCmd', $w]);
+ $okBtn->configure(-command => ['OkCmd', $w]);
+ $cancelBtn->configure(-command, ['CancelCmd', $w]);
+
+ $w->bind('<Alt-d>',[$dirMenu,'focus']);
+ $w->bind('<Alt-t>',sub {
+ if ($typeMenuBtn->cget(-state) eq 'normal') {
+ $typeMenuBtn->focus;
+ } });
+ $w->bind('<Alt-n>',[$ent,'focus']);
+ $w->bind('<KeyPress-Escape>',[$cancelBtn,'invoke']);
+ $w->bind('<Alt-c>',[$cancelBtn,'invoke']);
+ $w->bind('<Alt-o>',['InvokeBtn','Open']);
+ $w->bind('<Alt-s>',['InvokeBtn','Save']);
+ $w->protocol('WM_DELETE_WINDOW', ['CancelCmd', $w]);
+ $w->OnDestroy(['CancelCmd', $w]);
+
+ # Build the focus group for all the entries
+ $w->FG_Create;
+ $w->FG_BindIn($ent, ['EntFocusIn', $w]);
+ $w->FG_BindOut($ent, ['EntFocusOut', $w]);
+
+ $w->SetPath(_cwd());
+
+ $w->ConfigSpecs(-defaultextension => ['PASSIVE', undef, undef, undef],
+ -filetypes => ['PASSIVE', undef, undef, undef],
+ -initialdir => ['PASSIVE', undef, undef, undef],
+ -initialfile => ['PASSIVE', undef, undef, undef],
+# -sortcmd => ['PASSIVE', undef, undef, sub { lc($a) cmp lc($b) }],
+ -sortcmd => ['PASSIVE', undef, undef, sub { lc($_[0]) cmp lc($_[1]) }],
+ -title => ['PASSIVE', undef, undef, undef],
+ -type => ['PASSIVE', undef, undef, 'open'],
+ -filter => ['PASSIVE', undef, undef, '*'],
+ -force => ['PASSIVE', undef, undef, 0],
+ -multiple => ['PASSIVE', undef, undef, 0],
+ 'DEFAULT' => [$icons],
+ );
+ # So-far-failed attempt to break reference loops ...
+ $w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId));
+ $w;
+}
+
+# -initialdir fix with ResolveFile
+sub Show {
+ my $w = shift;
+
+ $w->configure(@_);
+
+ # Dialog boxes should be transient with respect to their parent,
+ # so that they will always stay on top of their parent window. However,
+ # some window managers will create the window as withdrawn if the parent
+ # window is withdrawn or iconified. Combined with the grab we put on the
+ # window, this can hang the entire application. Therefore we only make
+ # the dialog transient if the parent is viewable.
+
+ if (Tk::Exists($w->Parent) && $w->Parent->viewable) {
+ $w->transient($w->Parent);
+ }
+
+ # set the default directory and selection according to the -initial
+ # settings
+ {
+ my $initialdir = $w->cget(-initialdir);
+ if (defined $initialdir) {
+ my ($flag, $path, $file) = ResolveFile($initialdir, 'junk');
+ if ($flag eq 'OK' or $flag eq 'FILE') {
+ $w->{'selectPath'} = $path;
+ } else {
+ $w->Error("\"$initialdir\" is not a valid directory");
+ }
+ }
+ $w->{'selectFile'} = $w->cget(-initialfile);
+ }
+
+ # Set -multiple to a one or zero value (not other boolean types
+ # like "yes") so we can use it in tests more easily.
+ if ($w->cget('-type') ne 'open') {
+ $w->configure(-multiple => 0);
+ } else {
+ $w->configure(-multiple => !!$w->cget('-multiple'));
+ }
+ $w->{'icons'}->configure(-multiple => $w->cget('-multiple'));
+
+ # Initialize the file types menu
+ my $typeMenuBtn = $w->{'typeMenuBtn'};
+ my $typeMenuLab = $w->{'typeMenuLab'};
+ if (defined $w->cget('-filetypes')) {
+ my(@filetypes) = GetFileTypes($w->cget('-filetypes'));
+ my $typeMenu = $typeMenuBtn->cget(-menu);
+ $typeMenu->delete(0, 'end');
+ foreach my $ft (@filetypes) {
+ my $title = $ft->[0];
+ my $filter = join(' ', @{ $ft->[1] });
+ $typeMenuBtn->command
+ (-label => $title,
+ -command => ['SetFilter', $w, $title, $filter],
+ );
+ }
+ $w->SetFilter($filetypes[0]->[0], join(' ', @{ $filetypes[0]->[1] }));
+ $typeMenuBtn->configure(-state => 'normal');
+ $typeMenuLab->configure(-state => 'normal');
+ } else {
+#XXX $w->configure(-filter => '*');
+ $typeMenuBtn->configure(-state => 'disabled',
+ -takefocus => 0);
+ $typeMenuLab->configure(-state => 'disabled');
+ }
+ $w->UpdateWhenIdle;
+
+ {
+ my $title = $w->cget(-title);
+ if (!defined $title) {
+ my $type = $w->cget(-type);
+ $title = ($type eq 'dir') ? 'Choose Directory'
+ : ($type eq 'save') ? 'Save As' : 'Open';
+ }
+ $w->title($title);
+ }
+
+ # Withdraw the window, then update all the geometry information
+ # so we know how big it wants to be, then center the window in the
+ # display and de-iconify it.
+ $w->withdraw;
+ $w->idletasks;
+ if (0)
+ {
+ #XXX use Tk::Wm::Popup? or Tk::PlaceWindow?
+ my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx);
+ my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty);
+ $w->geometry("+$x+$y");
+ $w->deiconify;
+ }
+ else
+ {
+ $w->Popup;
+ }
+
+ # Set a grab and claim the focus too.
+#XXX use Tk::setFocusGrab when it's available
+ my $oldFocus = $w->focusCurrent;
+ my $oldGrab = $w->grabCurrent;
+ my $grabStatus = $oldGrab->grabStatus if ($oldGrab);
+ $w->grab;
+ my $ent = $w->{'ent'};
+ $ent->focus;
+ $ent->delete(0, 'end');
+ if (defined $w->{'selectFile'} && $w->{'selectFile'} ne '') {
+ $ent->insert(0, $w->{'selectFile'});
+ $ent->selectionRange(0,'end');
+ $ent->icursor('end');
+ }
+
+ # 8. Wait for the user to respond, then restore the focus and
+ # return the index of the selected button. Restore the focus
+ # before deleting the window, since otherwise the window manager
+ # may take the focus away so we can't redirect it. Finally,
+ # restore any grab that was in effect.
+ $w->waitVariable(\$w->{'selectFilePath'});
+ eval {
+ $oldFocus->focus if $oldFocus;
+ };
+ if (Tk::Exists($w)) { # widget still exists
+ $w->grabRelease;
+ $w->withdraw;
+ }
+ if (Tk::Exists($oldGrab) && $oldGrab->viewable) {
+ if ($grabStatus eq 'global') {
+ $oldGrab->grabGlobal;
+ } else {
+ $oldGrab->grab;
+ }
+ }
+ return $w->{'selectFilePath'};
+}
+
+# tkFDialog_UpdateWhenIdle --
+#
+# Creates an idle event handler which updates the dialog in idle
+# time. This is important because loading the directory may take a long
+# time and we don't want to load the same directory for multiple times
+# due to multiple concurrent events.
+#
+sub UpdateWhenIdle {
+ my $w = shift;
+ if (exists $w->{'updateId'}) {
+ return;
+ } else {
+ $w->{'updateId'} = $w->after('idle', [$w, 'Update']);
+ }
+}
+
+# tkFDialog_Update --
+#
+# Loads the files and directories into the IconList widget. Also
+# sets up the directory option menu for quick access to parent
+# directories.
+#
+sub Update {
+ my $w = shift;
+ my $dataName = $w->name;
+
+ # This proc may be called within an idle handler. Make sure that the
+ # window has not been destroyed before this proc is called
+ if (!Tk::Exists($w) || $w->class ne 'FBox') {
+ return;
+ } else {
+ delete $w->{'updateId'};
+ }
+ unless (defined $folderImage->{$w->MainWindow}) {
+ require Tk::Pixmap;
+ $folderImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('folder.xpm'));
+ $fileImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('file.xpm'));
+ }
+ my $folder = $folderImage->{$w->MainWindow};
+ my $file = $fileImage->{$w->MainWindow};
+ my $appPWD = _cwd();
+ if (!ext_chdir($w->_get_select_path)) {
+ # We cannot change directory to $data(selectPath). $data(selectPath)
+ # should have been checked before tkFDialog_Update is called, so
+ # we normally won't come to here. Anyways, give an error and abort
+ # action.
+ $w->messageBox(-type => 'OK',
+ -message => 'Cannot change to the directory "' .
+ $w->_get_select_path . "\".\nPermission denied.",
+ -icon => 'warning',
+ );
+ ext_chdir($appPWD);
+ return;
+ }
+
+ # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
+ # so the user may still click and cause havoc ...
+ my $ent = $w->{'ent'};
+ my $entCursor = $ent->cget(-cursor);
+ my $dlgCursor = $w->cget(-cursor);
+ $ent->configure(-cursor => 'watch');
+ $w->configure(-cursor => 'watch');
+ $w->idletasks;
+ my $icons = $w->{'icons'};
+ $icons->DeleteAll;
+
+ # Make the dir & file list
+ my $cwd = _cwd();
+ local *FDIR;
+ if (opendir(FDIR, $cwd)) {
+ my @files;
+# my $sortcmd = $w->cget(-sortcmd);
+ my $sortcmd = sub { $w->cget(-sortcmd)->($a,$b) };
+ my $flt = $w->cget(-filter);
+ my $fltcb;
+ if (ref $flt eq 'CODE') {
+ $fltcb = $flt;
+ } else {
+ $flt = _rx_to_glob($flt);
+ }
+ my $type_dir = $w->cget(-type) eq 'dir';
+ foreach my $f (sort $sortcmd readdir(FDIR)) {
+ next if $f eq '.' or $f eq '..';
+ next if $type_dir && ! -d "$cwd/$f"; # XXX use File::Spec?
+ if ($fltcb) {
+ next if !$fltcb->($w, $f, $cwd);
+ } else {
+ next if !-d $f && $f !~ m!$flt!;
+ }
+ if (-d $f) {
+ $icons->Add($folder, $f);
+ } else {
+ push @files, $f;
+ }
+ }
+ closedir(FDIR);
+ $icons->Add($file, @files);
+ }
+
+ $icons->Arrange;
+
+ # Update the Directory: option menu
+ my @list;
+ my $dir = '';
+ foreach my $subdir (TclFileSplit($w->_get_select_path)) {
+ $dir = TclFileJoin($dir, $subdir);
+ push @list, $dir;
+ }
+ my $dirMenu = $w->{'dirMenu'};
+ $dirMenu->configure(-options => \@list);
+
+ # Restore the PWD to the application's PWD
+ ext_chdir($appPWD);
+
+ # Restore the Save label
+ if ($w->cget(-type) eq 'save') {
+ $w->{'okBtn'}->configure(-text => 'Save');
+ }
+
+ # turn off the busy cursor.
+ $ent->configure(-cursor => $entCursor);
+ $w->configure(-cursor => $dlgCursor);
+}
+
+# tkFDialog_SetPathSilently --
+#
+# Sets data(selectPath) without invoking the trace procedure
+#
+sub SetPathSilently {
+ my($w, $path) = @_;
+
+ $w->{'selectPath'} = $path;
+}
+
+# This proc gets called whenever data(selectPath) is set
+#
+sub SetPath {
+ my $w = shift;
+ $w->{'selectPath'} = $_[0] if @_;
+ $w->UpdateWhenIdle;
+}
+
+# This proc gets called whenever data(filter) is set
+#
+#XXX here's much more code in the tcl version ... check it out
+sub SetFilter {
+ my($w, $title, $filter) = @_;
+ $w->configure(-filter => $filter);
+ $w->{'typeMenuBtn'}->configure(-text => $title,
+ -indicatoron => 1);
+ $w->{'icons'}->Subwidget('sbar')->set(0.0, 0.0);
+ $w->UpdateWhenIdle;
+}
+
+# tkFDialogResolveFile --
+#
+# Interpret the user's text input in a file selection dialog.
+# Performs:
+#
+# (1) ~ substitution
+# (2) resolve all instances of . and ..
+# (3) check for non-existent files/directories
+# (4) check for chdir permissions
+#
+# Arguments:
+# context: the current directory you are in
+# text: the text entered by the user
+# defaultext: the default extension to add to files with no extension
+#
+# Return value:
+# [list $flag $directory $file]
+#
+# flag = OK : valid input
+# = PATTERN : valid directory/pattern
+# = PATH : the directory does not exist
+# = FILE : the directory exists but the file doesn't
+# exist
+# = CHDIR : Cannot change to the directory
+# = ERROR : Invalid entry
+#
+# directory : valid only if flag = OK or PATTERN or FILE
+# file : valid only if flag = OK or PATTERN
+#
+# directory may not be the same as context, because text may contain
+# a subdirectory name
+#
+sub ResolveFile {
+ my($context, $text, $defaultext) = @_;
+ my $appPWD = _cwd();
+ my $path = JoinFile($context, $text);
+ # If the file has no extension, append the default. Be careful not
+ # to do this for directories, otherwise typing a dirname in the box
+ # will give back "dirname.extension" instead of trying to change dir.
+ if (!-d $path && $path !~ /\..+$/ && defined $defaultext) {
+ $path = "$path$defaultext";
+ }
+ # Cannot just test for existance here as non-existing files are
+ # not an error for getSaveFile type dialogs.
+ # return ('ERROR', $path, "") if (!-e $path);
+ my($directory, $file, $flag);
+ if (-e $path) {
+ if (-d $path) {
+ if (!ext_chdir($path)) {
+ return ('CHDIR', $path, '');
+ }
+ $directory = _cwd();
+ $file = '';
+ $flag = 'OK';
+ ext_chdir($appPWD);
+ } else {
+ my $dirname = File::Basename::dirname($path);
+ if (!ext_chdir($dirname)) {
+ return ('CHDIR', $dirname, '');
+ }
+ $directory = _cwd();
+ $file = File::Basename::basename($path);
+ $flag = 'OK';
+ ext_chdir($appPWD);
+ }
+ } else {
+ my $dirname = File::Basename::dirname($path);
+ if (-e $dirname) {
+ if (!ext_chdir($dirname)) {
+ return ('CHDIR', $dirname, '');
+ }
+ $directory = _cwd();
+ $file = File::Basename::basename($path);
+ if ($file =~ /[*?]/) {
+ $flag = 'PATTERN';
+ } else {
+ $flag = 'FILE';
+ }
+ ext_chdir($appPWD);
+ } else {
+ $directory = $dirname;
+ $file = File::Basename::basename($path);
+ $flag = 'PATH';
+ }
+ }
+ return ($flag,$directory,$file);
+}
+
+# Gets called when the entry box gets keyboard focus. We clear the selection
+# from the icon list . This way the user can be certain that the input in the
+# entry box is the selection.
+#
+sub EntFocusIn {
+ my $w = shift;
+ my $ent = $w->{'ent'};
+ if ($ent->get ne '') {
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } else {
+ $ent->selectionClear;
+ }
+#XXX is this missing in the tcl version, too??? $w->{'icons'}->Selection('clear');
+ my $okBtn = $w->{'okBtn'};
+ if ($w->cget(-type) ne 'save') {
+ $okBtn->configure(-text => 'Open');
+ } else {
+ $okBtn->configure(-text => 'Save');
+ }
+}
+
+sub EntFocusOut {
+ my $w = shift;
+ $w->{'ent'}->selectionClear;
+}
+
+# Gets called when user presses Return in the "File name" entry.
+#
+sub ActivateEnt {
+ my $w = shift;
+ if ($w->cget(-multiple)) {
+ # For the multiple case we have to be careful to get the file
+ # names as a true list, watching out for a single file with a
+ # space in the name. Thus we query the IconList directly.
+
+ $w->{'selectFile'} = [];
+ for my $item ($w->{'icons'}->Curselection) {
+ $w->VerifyFileName($w->_get_from_icons($item));
+ }
+ } else {
+ my $ent = $w->{'ent'};
+ my $text = $w->_encode_filename($ent->get);
+ $w->VerifyFileName($text);
+ }
+}
+
+# Verification procedure
+#
+sub VerifyFileName {
+ my($w, $text) = @_;
+#XXX leave this here?
+# $text =~ s/^\s+//;
+# $text =~ s/\s+$//;
+ my($flag, $path, $file) = ResolveFile($w->_get_select_path, $text,
+ $w->cget(-defaultextension));
+ my $ent = $w->{'ent'};
+ if ($flag eq 'OK') {
+ if ($file eq '') {
+ # user has entered an existing (sub)directory
+ $w->SetPath($path);
+ $ent->delete(0, 'end');
+ } else {
+ $w->SetPathSilently($path);
+ if ($w->cget(-multiple)) {
+ push @{ $w->{'selectFile'} }, $file;
+ } else {
+ $w->{'selectFile'} = $file;
+ }
+ $w->Done;
+ }
+ } elsif ($flag eq 'PATTERN') {
+ $w->SetPath($path);
+ $w->configure(-filter => $file);
+ } elsif ($flag eq 'FILE') {
+ if ($w->cget(-type) eq 'open') {
+ $w->messageBox(-icon => 'warning',
+ -type => 'OK',
+ -message => 'File "' . TclFileJoin($path, $file)
+ . '" does not exist.');
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } elsif ($w->cget(-type) eq 'save') {
+ $w->SetPathSilently($path);
+ if ($w->cget(-multiple)) {
+ push @{ $w->{'selectFile'} }, $file;
+ } else {
+ $w->{'selectFile'} = $file;
+ }
+ $w->Done;
+ }
+ } elsif ($flag eq 'PATH') {
+ $w->messageBox(-icon => 'warning',
+ -type => 'OK',
+ -message => "Directory \'$path\' does not exist.");
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } elsif ($flag eq 'CHDIR') {
+ $w->messageBox(-type => 'OK',
+ -message => "Cannot change to the directory \"$path\".\nPermission denied.",
+ -icon => 'warning');
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } elsif ($flag eq 'ERROR') {
+ $w->messageBox(-type => 'OK',
+ -message => "Invalid file name \"$path\".",
+ -icon => 'warning');
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ }
+}
+
+# Gets called when user presses the Alt-s or Alt-o keys.
+#
+sub InvokeBtn {
+ my($w, $key) = @_;
+ my $okBtn = $w->{'okBtn'};
+ $okBtn->invoke if ($okBtn->cget(-text) eq $key);
+}
+
+# Gets called when user presses the "parent directory" button
+#
+sub UpDirCmd {
+ my $w = shift;
+ $w->SetPath(File::Basename::dirname($w->_get_select_path))
+ unless ($w->_get_select_path eq '/');
+}
+
+# Join a file name to a path name. The "file join" command will break
+# if the filename begins with ~
+sub JoinFile {
+ my($path, $file) = @_;
+ if ($file =~ /^~/ && -e "$path/$file") {
+ TclFileJoin($path, "./$file");
+ } else {
+ TclFileJoin($path, $file);
+ }
+}
+
+# XXX replace with File::Spec when perl/Tk depends on 5.005
+sub TclFileJoin {
+ my $path = '';
+ foreach (@_) {
+ if (m|^/|) {
+ $path = $_;
+ }
+ elsif (m|^[a-z]:/|i) { # DOS-ish
+ $path = $_;
+ } elsif ($_ eq '~') {
+ $path = _get_homedir();
+ } elsif (m|^~/(.*)|) {
+ $path = _get_homedir() . "/" . $1;
+ } elsif (m|^~([^/]+)(.*)|) {
+ my($user, $p) = ($1, $2);
+ my $dir = _get_homedir($user);
+ if (!defined $dir) {
+ $path = "~$user$p";
+ } else {
+ $path = $dir . $p;
+ }
+ } elsif ($path eq '/' or $path eq '') {
+ $path .= $_;
+ } else {
+ $path .= "/$_";
+ }
+ }
+ $path;
+}
+
+sub TclFileSplit {
+ my $path = shift;
+ my @comp;
+ $path =~ s|/+|/|g; # strip multiple slashes
+ if ($path =~ m|^/|) {
+ push @comp, '/';
+ $path = substr($path, 1);
+ }
+ push @comp, split /\//, $path;
+ @comp;
+}
+
+# Gets called when user presses the "OK" button
+#
+sub OkCmd {
+ my $w = shift;
+ my $from = shift || "button";
+
+ my $filenames = [];
+ for my $item ($w->{'icons'}->Curselection) {
+ push @$filenames, $w->_get_from_icons($item);
+ }
+
+ my $filename = $filenames->[0];
+ $filename = "" if !defined $filename;
+ if ($w->cget('-type') eq 'dir' && $from ne "iconlist") {
+ my $file = $filename eq '' ? $w->_get_select_path : JoinFile($w->_get_select_path, $filename);
+ $w->Done($file);
+ } elsif ((@$filenames && !$w->cget('-multiple')) ||
+ ($w->cget('-multiple') && @$filenames == 1)) {
+ my $file = JoinFile($w->_get_select_path, $filename);
+ if (-d $file) {
+ $w->ListInvoke($filename);
+ return;
+ }
+ }
+
+ $w->ActivateEnt;
+}
+
+# Gets called when user presses the "Cancel" button
+#
+sub CancelCmd {
+ my $w = shift;
+ undef $w->{'selectFilePath'};
+}
+
+# Gets called when user browses the IconList widget (dragging mouse, arrow
+# keys, etc)
+#
+sub ListBrowse {
+ my($w) = @_;
+
+ my $text = [];
+ for my $item ($w->{'icons'}->Curselection) {
+ push @$text, $w->_get_from_icons($item);
+ }
+ return if @$text == 0;
+ my $isDir;
+ if (@$text > 1) {
+ my $newtext = [];
+ for my $file (@$text) {
+ my $fullfile = JoinFile($w->_get_select_path, $file);
+ if (!-d $fullfile) {
+ push @$newtext, $file;
+ }
+ }
+ $text = $newtext;
+ $isDir = 0;
+ } else {
+ my $file = JoinFile($w->_get_select_path, $text->[0]);
+ $isDir = -d $file;
+ }
+ my $ent = $w->{'ent'};
+ my $okBtn = $w->{'okBtn'};
+ if (!$isDir) {
+ $ent->delete(qw(0 end));
+ $ent->insert(0, "@$text"); # XXX quote!
+
+ if ($w->cget('-type') ne 'save') {
+ $okBtn->configure(-text => 'Open');
+ } else {
+ $okBtn->configure(-text => 'Save');
+ }
+ } else {
+ $okBtn->configure(-text => 'Open');
+ }
+}
+
+# Gets called when user invokes the IconList widget (double-click,
+# Return key, etc)
+#
+sub ListInvoke {
+ my($w, @filenames) = @_;
+ return if !@filenames;
+ my $file = JoinFile($w->_get_select_path, $filenames[0]);
+ if (-d $file) {
+ my $appPWD = _cwd();
+ if (!ext_chdir($file)) {
+ $w->messageBox(-type => 'OK',
+ -message => "Cannot change to the directory \"$file\".\nPermission denied.",
+ -icon => 'warning');
+ } else {
+ ext_chdir($appPWD);
+ $w->SetPath($file);
+ }
+ } else {
+ if ($w->cget('-multiple')) {
+ $w->{'selectFile'} = [@filenames];
+ } else {
+ $w->{'selectFile'} = $file;
+ }
+ $w->Done;
+ }
+}
+
+# tkFDialog_Done --
+#
+# Gets called when user has input a valid filename. Pops up a
+# dialog box to confirm selection when necessary. Sets the
+# tkPriv(selectFilePath) variable, which will break the "tkwait"
+# loop in tkFDialog and return the selected filename to the
+# script that calls tk_getOpenFile or tk_getSaveFile
+#
+sub Done {
+ my $w = shift;
+ my $selectFilePath = (@_) ? shift : '';
+ if ($selectFilePath eq '') {
+ if ($w->cget('-multiple')) {
+ $selectFilePath = [];
+ for my $f (@{ $w->{'selectFile'} }) {
+ push @$selectFilePath, JoinFile($w->_get_select_Path, $f);
+ }
+ } else {
+ $selectFilePath = JoinFile($w->_get_select_path,
+ $w->{'selectFile'});
+ }
+ if ($w->cget(-type) eq 'save' and
+ -e $selectFilePath and
+ !$w->cget(-force)) {
+ my $reply = $w->messageBox
+ (-icon => 'warning',
+ -type => 'YesNo',
+ -message => "File \"$selectFilePath\" already exists.\nDo you want to overwrite it?");
+ return unless (lc($reply) eq 'yes');
+ }
+ }
+ $w->{'selectFilePath'} = ($selectFilePath ne '' ? $selectFilePath : undef);
+}
+
+sub FDialog {
+ my $cmd = shift;
+ if ($cmd =~ /Save/) {
+ push @_, -type => 'save';
+ } elsif ($cmd =~ /Directory/) {
+ push @_, -type => 'dir';
+ }
+ Tk::DialogWrapper('FBox', $cmd, @_);
+}
+
+# tkFDGetFileTypes --
+#
+# Process the string given by the -filetypes option of the file
+# dialogs. Similar to the C function TkGetFileFilters() on the Mac
+# and Windows platform.
+#
+sub GetFileTypes {
+ my $in = shift;
+ my %fileTypes;
+ foreach my $t (@$in) {
+ if (@$t < 2 || @$t > 3) {
+ require Carp;
+ Carp::croak("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\"");
+ }
+ push @{ $fileTypes{$t->[0]} }, (ref $t->[1] eq 'ARRAY'
+ ? @{ $t->[1] }
+ : $t->[1]);
+ }
+
+ my @types;
+ my %hasDoneType;
+ my %hasGotExt;
+ foreach my $t (@$in) {
+ my $label = $t->[0];
+ my @exts;
+
+ next if (exists $hasDoneType{$label});
+
+ my $name = "$label (";
+ my $sep = '';
+ foreach my $ext (@{ $fileTypes{$label} }) {
+ next if ($ext eq '');
+ $ext =~ s/^\./*./;
+ if (!exists $hasGotExt{$label}->{$ext}) {
+ $name .= "$sep$ext";
+ push @exts, $ext;
+ $hasGotExt{$label}->{$ext}++;
+ }
+ $sep = ',';
+ }
+ $name .= ')';
+ push @types, [$name, \@exts];
+
+ $hasDoneType{$label}++;
+ }
+
+ return @types;
+}
+
+# ext_chdir --
+#
+# Change directory with tilde substitution
+#
+sub ext_chdir {
+ my $dir = shift;
+ if ($dir eq '~') {
+ chdir _get_homedir();
+ } elsif ($dir =~ m|^~/(.*)|) {
+ chdir _get_homedir() . "/" . $1;
+ } elsif ($dir =~ m|^~([^/]+(.*))|) {
+ chdir _get_homedir($1) . $2;
+ } else {
+ chdir $dir;
+ }
+}
+
+# _get_homedir --
+#
+# Get home directory of the current user
+#
+sub _get_homedir {
+ my($user) = @_;
+ if (!defined $user) {
+ eval {
+ local $SIG{__DIE__};
+ (getpwuid($<))[7];
+ } || $ENV{HOME} || undef; # chdir undef changes to home directory, too
+ } else {
+ eval {
+ local $SIG{__DIE__};
+ (getpwnam($user))[7];
+ };
+ }
+}
+
+sub _cwd {
+ #Cwd::cwd();
+ Cwd::fastcwd(); # this is taint-safe
+}
+
+sub _untaint {
+ my $s = shift;
+ $s =~ /^(.*)$/;
+ $1;
+}
+
+sub _rx_to_glob {
+ my $arg = shift;
+ $arg = join('|', split(' ', $arg));
+ $arg =~ s!([\.\+])!\\$1!g;
+ $arg =~ s!\*!.*!g;
+ $arg = "^" . $arg . "\$";
+ if ($] >= 5.005) {
+ $arg = qr/$arg/;
+ }
+ $arg;
+}
+
+sub _get_from_icons {
+ my($w, $item) = @_;
+ $w->_encode_filename($w->{'icons'}->Get($item));
+}
+
+sub _get_select_path {
+ my($w) = @_;
+ $w->_encode_filename($w->{'selectPath'});
+}
+
+sub _encode_filename {
+ my($w, $filename) = @_;
+ $filename = $w->{encoding}->encode($filename);
+ $filename;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/FBox.pod b/Master/tlpkg/tlperl.straw/lib/Tk/FBox.pod
new file mode 100755
index 00000000000..dada482a761
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/FBox.pod
@@ -0,0 +1,67 @@
+=head1 NAME
+
+Tk::FBox - a file dialog
+
+=for pm Tk/FBox.pm
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+ use Tk::FBox;
+ $file = $mw->FBox(...)->Show;
+
+=head1 DESCRIPTION
+
+C<Tk::FBox> is the dialog implementation behind the C<getOpenFile>,
+C<getSaveFile>, and C<chooseDirectory> method calls in the Unix/X11
+world. As such, it supports all options for these methods and
+additionally:
+
+=over
+
+=item -sortcmd => sub { $_[0] cmp $_[1] }
+
+Specified a callback for changing the sorting of the icons in the
+C<IconList> widget. By default, perl's C<cmp> operator will be used.
+
+From the source code:
+
+ # Using -sortcmd is really strange :-(
+ # $top->getOpenFile(-sortcmd => sub { package Tk::FBox; uc $b cmp uc $a});
+ # or, un-perlish, but useable (now activated in code):
+ # $top->getOpenFile(-sortcmd => sub { uc $_[1] cmp uc $_[0]});
+
+This is an experimental option!
+
+=item -type => $type
+
+Type should be "open" for choosing existing files to open (default),
+"save" for choosing existing or non-existing files to save, or "dir"
+for choosing directories.
+
+=item -filter => $glob
+
+A file glob to restrict displayed files. This is only active if no
+B<-filetypes> are defined.
+
+=item -force => $bool
+
+If true, then there will be no dialog if a file already exists.
+
+=back
+
+=head1 COPYRIGHT
+
+The original tkfbox.tcl from Tcl/Tk is:
+
+Copyright (c) 1994-1996 Sun Microsystems, Inc.
+
+See the file "license.terms" for information on usage and redistribution
+of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+Translated to Perl/Tk by Slaven Rezic <srezic@cpan.org>.
+
+=head1 SEE ALSO
+
+L<Tk::getOpenFile>, L<Tk::IconList>.
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/FileSelect.pm b/Master/tlpkg/tlperl.straw/lib/Tk/FileSelect.pm
new file mode 100755
index 00000000000..0de44327259
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/FileSelect.pm
@@ -0,0 +1,577 @@
+package Tk::FileSelect;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = '4.017'; # was: sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
+@EXPORT_OK = qw(glob_to_re);
+
+use Tk qw(Ev);
+use strict;
+use Carp;
+use base qw(Tk::Toplevel);
+use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar);
+use File::Basename;
+
+Construct Tk::Widget 'FileSelect';
+
+use vars qw(%error_text);
+%error_text = (
+ '-r' => 'is not readable by effective uid/gid',
+ '-w' => 'is not writeable by effective uid/gid',
+ '-x' => 'is not executable by effective uid/gid',
+ '-R' => 'is not readable by real uid/gid',
+ '-W' => 'is not writeable by real uid/gid',
+ '-X' => 'is not executable by real uid/gid',
+ '-o' => 'is not owned by effective uid/gid',
+ '-O' => 'is not owned by real uid/gid',
+ '-e' => 'does not exist',
+ '-z' => 'is not of size zero',
+ '-s' => 'does not exists or is of size zero',
+ '-f' => 'is not a file',
+ '-d' => 'is not a directory',
+ '-l' => 'is not a link',
+ '-S' => 'is not a socket',
+ '-p' => 'is not a named pipe',
+ '-b' => 'is not a block special file',
+ '-c' => 'is not a character special file',
+ '-u' => 'is not setuid',
+ '-g' => 'is not setgid',
+ '-k' => 'is not sticky',
+ '-t' => 'is not a terminal file',
+ '-T' => 'is not a text file',
+ '-B' => 'is not a binary file',
+ '-M' => 'has no modification date/time',
+ '-A' => 'has no access date/time',
+ '-C' => 'has no inode change date/time',
+ );
+
+# Documentation after __END__
+
+sub import {
+ if (defined $_[1] and $_[1] eq 'as_default') {
+ local $^W = 0;
+ package Tk;
+ if ($Tk::VERSION < 804) {
+ *FDialog = \&Tk::FileSelect::FDialog;
+ *MotifFDialog = \&Tk::FileSelect::FDialog;
+ } else {
+ *tk_getOpenFile = sub {
+ Tk::FileSelect::FDialog("tk_getOpenFile", @_);
+ };
+ *tk_getSaveFile = sub {
+ Tk::FileSelect::FDialog("tk_getSaveFile", @_);
+ };
+ }
+ }
+}
+
+sub Cancel
+{
+ my ($cw) = @_;
+ $cw->{Selected} = undef;
+ $cw->withdraw unless $cw->cget('-transient');
+}
+
+sub Accept {
+
+ # Accept the file or directory name if possible.
+
+ my ($cw) = @_;
+
+ my($path, $so) = ($cw->cget('-directory'), $cw->SelectionOwner);
+ my $leaf = undef;
+ my $leaves;
+
+ if (defined $so and
+ $so == $cw->Subwidget('dir_list')->Subwidget('listbox')) {
+ $leaves = [$cw->Subwidget('dir_list')->getSelected];
+ $leaves = [$cw->Subwidget('dir_entry')->get] if !scalar(@$leaves);
+ } else {
+ $leaves = [$cw->Subwidget('file_list')->getSelected];
+ $leaves = [$cw->Subwidget('file_entry')->get] if !scalar(@$leaves);
+ }
+
+ foreach $leaf (@$leaves)
+ {
+ if (defined $leaf and $leaf ne '') {
+ if (!$cw->cget('-create') || -e "$path/$leaf")
+ {
+ foreach (@{$cw->cget('-verify')}) {
+ my $r = ref $_;
+ if (defined $r and $r eq 'ARRAY') {
+ #local $_ = $leaf; # use strict var problem here
+ return if not &{$_->[0]}($cw, $path, $leaf, @{$_}[1..$#{$_}]);
+ } else {
+ my $s = eval "$_ '$path/$leaf'";
+ print $@ if $@;
+ if (not $s) {
+ my $err;
+ if (substr($_,0,1) eq '!')
+ {
+ my $t = substr($_,1);
+ if (exists $error_text{$t})
+ {
+ $err = $error_text{$t};
+ $err =~ s/\b(?:no|not) //;
+ }
+ }
+ $err = $error_text{$_} unless defined $err;
+ $err = "failed '$_' test" unless defined $err;
+ $cw->Error("'$leaf' $err.");
+ return;
+ }
+ }
+ } # forend
+ }
+ else
+ {
+ unless (-w $path)
+ {
+ $cw->Error("Cannot write to $path");
+ return;
+ }
+ }
+ $leaf = $path . '/' . $leaf;
+ } else {
+ $leaf = undef;
+ }
+ }
+ if (scalar(@$leaves))
+ {
+ my $sm = $cw->Subwidget('file_list')->cget(-selectmode);
+ $cw->{Selected} = $leaves;
+ my $command = $cw->cget('-command');
+ $command->Call(@{$cw->{Selected}}) if defined $command;
+ }
+
+} # end Accept
+
+sub Accept_dir
+{
+ my ($cw,$new) = @_;
+ return if !defined $new;
+ my $dir = $cw->cget('-directory');
+ $cw->configure(-directory => "$dir/$new");
+}
+
+sub Populate {
+
+ my ($w, $args) = @_;
+
+ require Tk::Listbox;
+ require Tk::Button;
+ require Tk::Dialog;
+ require Tk::Toplevel;
+ require Tk::LabEntry;
+ require Cwd;
+
+ $w->SUPER::Populate($args);
+ $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]);
+
+ $w->{'reread'} = 0;
+ $w->withdraw;
+
+ # Create directory/filter entry, place at the top.
+ my $e = $w->Component(
+ LabEntry => 'dir_entry',
+ -textvariable => \$w->{DirectoryString},
+ -labelVariable => \$w->{Configure}{-dirlabel},
+ );
+ $e->pack(-side => 'top', -expand => 0, -fill => 'x');
+ $e->bind('<Return>' => [$w => 'validateDir', Ev(['get'])]);
+
+ # Create file entry, place at the bottom.
+ $e = $w->Component(
+ LabEntry => 'file_entry',
+ -textvariable => \$w->{Configure}{-initialfile},
+ -labelVariable => \$w->{Configure}{-filelabel},
+ );
+ $e->pack(-side => 'bottom', -expand => 0, -fill => 'x');
+ $e->bind('<Return>' => [$w => 'validateFile', Ev(['get'])]);
+ $e->bind('<FocusIn>' => [$w => 'SelectionClear']);
+
+ # Create directory scrollbox, place at the left-middle.
+ my $b = $w->Component(
+ ScrlListbox => 'dir_list',
+ -labelVariable => \$w->{Configure}{-dirlistlabel},
+ -scrollbars => 'se',
+ );
+ $b->pack(-side => 'left', -expand => 1, -fill => 'both');
+ $b->bind('<Double-Button-1>' => [$w => 'Accept_dir', Ev(['getSelected'])]);
+
+ # Add a label.
+
+ my $f = $w->Frame();
+ $f->pack(-side => 'right', -fill => 'y', -expand => 0);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-acceptlabel'},
+ -command => [ 'Accept', $w ],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-cancellabel'},
+ -command => [ 'Cancel', $w ],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-resetlabel'},
+ -command => [$w => 'configure','-directory','.'],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-homelabel'},
+ -command => [$w => 'configure','-directory',$ENV{'HOME'}],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+
+ # Create file scrollbox, place at the right-middle.
+
+ $b = $w->Component(
+ ScrlListbox => 'file_list',
+ -labelVariable => \$w->{Configure}{-filelistlabel},
+ -scrollbars => 'se',
+ );
+ $b->pack(-side => 'right', -expand => 1, -fill => 'both');
+ $b->bind('<Double-1>' => [$w => 'Accept']);
+
+ # Create -very dialog.
+
+ my $v = $w->Component(
+ Dialog => 'dialog',
+ -title => 'Verify Error',
+ -bitmap => 'error',
+ -buttons => ['Dismiss'],
+ );
+
+ $w->ConfigSpecs(
+ -width => [ ['file_list','dir_list'], undef, undef, 14 ],
+ -height => [ ['file_list','dir_list'], undef, undef, 14 ],
+ -directory => [ 'METHOD', undef, undef, '.' ],
+ -initialdir => '-directory',
+ -filelabel => [ 'PASSIVE', 'fileLabel', 'FileLabel', 'File' ],
+ -initialfile => [ 'PASSIVE', undef, undef, '' ],
+ -filelistlabel => [ 'PASSIVE', undef, undef, 'Files' ],
+ -filter => [ 'METHOD', undef, undef, undef ],
+ -defaultextension => [ 'METHOD', undef, undef, undef ],
+ -regexp => [ 'METHOD', undef, undef, undef ],
+ -dirlistlabel => [ 'PASSIVE', undef, undef, 'Directories'],
+ -dirlabel => [ 'PASSIVE', undef, undef, 'Directory'],
+ '-accept' => [ 'CALLBACK',undef,undef, undef ],
+ -command => [ 'CALLBACK',undef,undef, undef ],
+ -transient => [ 'PASSIVE', undef, undef, 1 ],
+ -verify => [ 'PASSIVE', undef, undef, ['!-d'] ],
+ -create => [ 'PASSIVE', undef, undef, 0 ],
+ -acceptlabel => [ 'PASSIVE', undef, undef, 'Accept'],
+ -cancellabel => [ 'PASSIVE', undef, undef, 'Cancel'],
+ -resetlabel => [ 'PASSIVE', undef, undef, 'Reset'],
+ -homelabel => [ 'PASSIVE', undef, undef, 'Home'],
+ DEFAULT => [ 'file_list' ],
+ );
+ $w->Delegates(DEFAULT => 'file_list');
+
+ return $w;
+
+} # end Populate
+
+sub translate
+ {
+ my ($bs,$ch) = @_;
+ return "\\$ch" if (length $bs);
+ return '.*' if ($ch eq '*');
+ return '.' if ($ch eq '?');
+ return "\\." if ($ch eq '.');
+ return "\\/" if ($ch eq '/');
+ return "\\\\" if ($ch eq '\\');
+ return $ch;
+}
+
+sub glob_to_re
+{
+ my $regex = shift;
+ $regex =~ s/(\\?)(.)/&translate($1,$2)/ge;
+ return sub { shift =~ /^${regex}$/ };
+}
+
+sub filter
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-filter'};
+ if (@_ > 1 || !defined($$var))
+ {
+ $val = '*' unless defined $val;
+ $$var = $val;
+ $cw->{'match'} = glob_to_re($val) unless defined $cw->{'match'};
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw,$cw->cget('-directory')])
+ }
+ }
+ return $$var;
+}
+
+sub regexp
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-regexp'};
+ if (@_ > 1)
+ {
+ $$var = $val;
+ $cw->{'match'} = (defined $val) ? sub { shift =~ m|^${val}$| } : sub { 1 };
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw])
+ }
+ }
+ return $$var;
+}
+
+sub defaultextension
+{
+ my ($cw,$val) = @_;
+ if (@_ > 1)
+ {
+ $val = '' unless defined $val;
+ $val = ".$val" if ($val !~ /^\./);
+ $cw->filter("*$val");
+ }
+ else
+ {
+ $val = $cw->filter;
+ my ($ext) = $val =~ /(\.[^\.]*)$/;
+ return $ext;
+ }
+}
+
+sub directory
+{
+ my ($cw,$dir) = @_;
+ my $var = \$cw->{Configure}{'-directory'};
+ if (@_ > 1 && defined $dir)
+ {
+ if (substr($dir,0,1) eq '~')
+ {
+ if (substr($dir,1,1) eq '/')
+ {
+ $dir = (defined $ENV{'HOME'} ? $ENV{'HOME'} : '') . substr($dir,1);
+ }
+ else
+ {my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#);
+ $dir = (getpwnam($uid))[7] . $rest;
+ }
+ }
+ my $revert_dir = sub
+ {
+ my $message = shift;
+ $$var = $cw->{OldDirectory};
+ $cw->messageBox(-message => $message, -icon => 'error');
+ if (!defined $$var)
+ {
+ # OldDirectory was never set, so force reread...
+ $$var = $cw->{OldDirectory} = Cwd::getcwd(); # XXX maybe use check like code below...
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw])
+ }
+ }
+ $$var;
+ };
+ $dir =~ s#([^/\\])[\\/]+$#$1#;
+ if (-d $dir)
+ {
+ unless (Tk::tainting())
+ {
+ my $pwd = Cwd::getcwd();
+ if (chdir( (defined($dir) ? $dir : '') ) )
+ {
+ my $new = Cwd::getcwd();
+ if ($new)
+ {
+ $dir = $new;
+ }
+ else
+ {
+ return $revert_dir->("Cannot getcwd in '$dir'");
+ }
+ if (!chdir($pwd))
+ {
+ return $revert_dir->("Cannot change directory to $pwd:\n$!");
+ }
+ $$var = $dir;
+ }
+ else
+ {
+ return $revert_dir->("Cannot change directory to $dir:\n$!");
+ }
+ $$var = $cw->{OldDirectory} = $dir;
+ }
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw])
+ }
+ }
+ }
+ return $$var;
+}
+
+sub reread
+{
+ my ($w) = @_;
+ my $dir = $w->cget('-directory');
+ if (defined $dir)
+ {
+ if (!defined $w->cget('-filter') or $w->cget('-filter') eq '')
+ {
+ $w->configure('-filter', '*');
+ }
+ my $dl = $w->Subwidget('dir_list');
+ $dl->delete(0, 'end');
+ $dl->selectionClear(0,'end');
+ my $fl = $w->Subwidget('file_list');
+ $fl->delete(0, 'end');
+ local *DIR;
+ if (opendir(DIR, $dir))
+ {
+ my $file = $w->cget('-initialfile');
+ my $seen = 0;
+ my $accept = $w->cget('-accept');
+ foreach my $f (sort(readdir(DIR)))
+ {
+ next if ($f eq '.');
+ my $path = "$dir/$f";
+ if (-d $path)
+ {
+ $dl->insert('end', $f);
+ }
+ else
+ {
+ if (&{$w->{match}}($f))
+ {
+ if (!defined($accept) || $accept->Call($path))
+ {
+ $seen = $fl->index('end') if ($file && $f eq $file);
+ $fl->insert('end', $f)
+ }
+ }
+ }
+ }
+ closedir(DIR);
+ if ($seen)
+ {
+ $fl->selectionSet($seen);
+ $fl->see($seen);
+ }
+ else
+ {
+ $w->configure(-initialfile => undef) unless $w->cget('-create');
+ }
+ }
+ $w->{DirectoryString} = $dir . ($dir ne '/' ? '/' : '') . $w->cget('-filter');
+ }
+ $w->{'reread'} = 0;
+ $w->Unbusy if $w->{'Busy'};
+}
+
+sub validateDir
+{
+ my ($cw,$name) = @_;
+ my ($leaf,$base) = fileparse($name);
+ if ($leaf =~ /[*?]/)
+ {
+ $cw->configure('-directory' => $base,'-filter' => $leaf);
+ }
+ else
+ {
+ $cw->configure('-directory' => $name);
+ }
+}
+
+sub validateFile
+{
+ my ($cw,$name) = @_;
+ my $i = 0;
+ my $n = $cw->index('end');
+ # See if it is an existing file
+ for ($i= 0; $i < $n; $i++)
+ {
+ my $f = $cw->get($i);
+ if ($f eq $name)
+ {
+ $cw->selection('set',$i);
+ $cw->Accept;
+ }
+ }
+ # otherwise allow if -create is set, directory is writable
+ # and it passes filter and accept criteria
+ if ($cw->cget('-create'))
+ {
+ my $path = $cw->cget('-directory');
+ if (-w $path)
+ {
+ if (&{$cw->{match}}($name))
+ {
+ my $accept = $cw->cget('-accept');
+ my $full = "$path/$name";
+ if (!defined($accept) || $accept->Call($full))
+ {
+ $cw->{Selected} = [$full];
+ $cw->Callback(-command => @{$cw->{Selected}});
+ }
+ else
+ {
+ $cw->Error("$name is not 'acceptable'");
+ }
+ }
+ else
+ {
+ $cw->Error("$name does not match '".$cw->cget('-filter').'\'');
+ }
+ }
+ else
+ {
+ $cw->Error("Directory '$path' is not writable");
+ return;
+ }
+ }
+}
+
+sub Error
+{
+ my $cw = shift;
+ my $msg = shift;
+ my $dlg = $cw->Subwidget('dialog');
+ $dlg->configure(-text => $msg);
+ $dlg->Show;
+}
+
+sub Show
+{
+ my ($cw,@args) = @_;
+ if ($cw->cget('-transient')) {
+ $cw->Popup(@args);
+ $cw->focus;
+ $cw->waitVariable(\$cw->{Selected});
+ $cw->withdraw;
+ return defined($cw->{Selected})
+ ? (wantarray) ? @{$cw->{Selected}} : $cw->{Selected}[0]
+ : undef;
+ } else {
+ $cw->Popup(@args);
+ }
+}
+
+sub FDialog
+{
+ my($cmd, %args) = @_;
+ if ($cmd =~ /Save/)
+ {
+ $args{-create} = 1;
+ $args{-verify} = [qw(!-d -w)];
+ }
+ delete $args{-filetypes};
+ delete $args{-force};
+ Tk::DialogWrapper('FileSelect',$cmd, %args);
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/FileSelect.pod b/Master/tlpkg/tlperl.straw/lib/Tk/FileSelect.pod
new file mode 100755
index 00000000000..c8ce0a6db59
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/FileSelect.pod
@@ -0,0 +1,146 @@
+
+=head1 NAME
+
+Tk::FileSelect - a widget for choosing files
+
+=for pm Tk/FileSelect.pm
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+ use Tk::FileSelect;
+
+ $FSref = $top->FileSelect(-directory => $start_dir);
+ $top - a window reference, e.g. MainWindow->new
+ $start_dir - the starting point for the FileSelect
+ $file = $FSref->Show;
+ Executes the fileselector until either a filename is
+ accepted or the user hits Cancel. Returns the filename
+ or the empty string, respectively, and unmaps the
+ FileSelect.
+ $FSref->configure(option => value[, ...])
+ Please see the Populate subroutine as the configuration
+ list changes rapidly.
+
+=head1 DESCRIPTION
+
+This Module pops up a Fileselector box, with a directory entry on
+top, a list of directories in the current directory, a list of
+files in the current directory, an entry for entering/modifying a
+file name, an accept button and a cancel button.
+
+You can enter a starting directory in the directory entry. After
+hitting Return, the listboxes get updated. Double clicking on any
+directory shows you the respective contents. Single clicking on a
+file brings it into the file entry for further consideration,
+double clocking on a file pops down the file selector and calls
+the optional command with the complete path for the selected file.
+Hitting return in the file selector box or pressing the accept
+button will also work. *NOTE* the file selector box will only then
+get destroyed if the file name is not zero length. If you want
+yourself take care of it, change the if(length(.. in sub
+accept_file.
+
+=head1 AUTHORS
+
+Based on original FileSelect by
+Klaus Lichtenwalder, Lichtenwalder@ACM.org, Datapat GmbH, Munich,
+April 22, 1995 adapted by
+Frederick L. Wagner, derf@ti.com, Texas Instruments Incorporated, Dallas,
+21Jun95
+
+=head1 HISTORY
+
+=head2 950621 -- The following changes were made:
+
+=over 4
+
+=item *
+
+Rewrote Tk stuff to take advantage of new Compound widget module, so
+FileSelect is now composed of 2 LabEntry and 2 ScrlListbox2
+subwidgets.
+
+=item *
+
+Moved entry labels (from to the left of) to above the entry fields.
+
+=item *
+
+Caller is now able to control these aspects of widget, in both
+FileSelect (new) and configure :
+
+(Please see subroutine Populate for details, as these options
+change rapidly!)
+
+=item *
+
+I changed from Double-Button-1 to Button-1 in the Files listbox,
+to work with multiple mode in addition to browse mode. I also
+made some name changes (LastPath --> saved_path, ...).
+
+=item *
+
+The show method is not yet updated.
+
+=item *
+
+The topLevel stuff is not done yet. I took it out while I toy with
+the idea of FileSelect as a subwidget. Then the 'normal' topLevel
+thing with Buttons along the bottom could be build on top of it.
+
+=item *
+
+By request of Henry Katz <katz@fs09.webo.dg.com>, I added the functionality
+of using the Directory entry as a filter. So, if you want to only see the
+*.c files, you add a .c (the *'s already there :) and hit return.
+
+=back
+
+=head2 95/10/17, SOL, LUCC. lusol@Lehigh.EDU
+
+=over 4
+
+=item *
+
+ Allow either file or directory names to be accepted.
+
+=item *
+
+Require double click to move into a new directory rather than a single
+click. This allows a single click to select a directory name so it can
+be accepted.
+
+=item *
+
+Add -verify list option so that standard Perl file test operators (like
+-d and -x) can be specified for further name validation. The default
+value is the special value '!-d' (not a directory), so any name can be
+selected as long as it's not a directory - after all, this IS FileSelect!
+
+For example:
+
+ $fs->configure(-verify => ['-d', [\&verify_code, $P1, $P2, ... $Pn]]);
+
+ensures that the selected name is a directory. Further, if an element of
+the list is an array reference, the first element is a code reference to a
+subroutine and the remaining optional elements are it's parameters. The
+subroutine is called like this:
+
+ &verify_code($cd, $leaf, $P1, $P2, ... $Pn);
+
+where $cd is the current directory, $leaf is a directory or file name, and
+$P1 .. $Pn are your optional parameters. The subroutine should return TRUE
+if success or FALSE if failure.
+
+=back
+
+=head2 961008 -- derf@ti.com :
+
+By request of Jim Stern <js@world.northgrum.com> and Brad Vance
+<bvance@ti.com>, I updated the Accept and Show functions to support
+selection of multiple files. I also corrected a typo in the -verify code.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/FloatEntry.pm b/Master/tlpkg/tlperl.straw/lib/Tk/FloatEntry.pm
new file mode 100755
index 00000000000..eb6465dbe61
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/FloatEntry.pm
@@ -0,0 +1,109 @@
+# Tranlation of FloatEnt.tcl in Tix4.1
+
+# TODO/IDEA:
+# o extract a widget (SimpleEntry?) without post/unpost methods
+# and derive FloatEntry fron this widget.
+
+package Tk::FloatEntry;
+use strict;
+
+BEGIN
+ {
+ use vars '$DEBUG';
+ $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'achx') ? 1 : 0;
+ print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG;
+ }
+
+require Tk;
+require Tk::Widget;
+require Tk::Derived;
+require Tk::Entry;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TixGrid/FloatEntry.pm#4 $
+
+use base qw(Tk::Derived Tk::Entry);
+
+Construct Tk::Widget 'FloatEntry';
+
+sub ClassInit
+ {
+ my ($class, $mw) = @_;
+ $class->SUPER::ClassInit($mw);
+ $mw->bind($class, '<Return>', 'invoke');
+ $mw->bind($class, '<FocusIn>', 'FocusIn');
+ $class;
+ }
+
+sub Populate
+ {
+ my ($e, $args) = @_;
+ $e->ConfigSpecs(
+ -value => ['METHOD', 'value', 'Value', undef],
+ -highlightthickness => [$e, 'highlightThickness', 'HighlightThickness', 0 ],
+ -command => ['CALLBACK', 'command', 'Command', undef],
+ );
+ print "FloatEntry Init: $e\n" if $DEBUG;
+ $e;
+ }
+
+## option method
+
+sub value
+ {
+ my $e = shift;
+ unless (@_)
+ {
+ return $e->get
+ }
+ $e->delete(0,'end');
+ $e->insert(0,$_[0]);
+ $e->selection('from', 0);
+ $e->selection('to', 'end');
+
+ }
+
+## public methods
+
+sub invoke
+ {
+ my ($e) = @_;
+ $e->Callback('-command', $e->get);
+ }
+
+sub post
+ {
+ my ($e, $x, $y, $dx, $dy) = @_;
+
+ $dx = $e->reqwidth unless defined $dx;
+ $dy = $e->reqheight unless defined $dy;
+
+ $e->place('-x'=>$x, '-y'=>$y, -width=>$dx, -height=>$dy, -bordermode=>'ignore');
+ $e->raise;
+ $e->focus;
+ }
+
+sub unpost
+ {
+ my ($e) = @_;
+ $e->place('forget');
+ }
+
+## bindings
+
+sub FocusIn
+ {
+ my ($e) = @_;
+
+ # FIX: xxx only if entry has not already focus
+ {
+ $e->focus;
+ $e->selection('from', 0);
+ $e->selection('to', 'end');
+ $e->icursor('end');
+ }
+ }
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Font.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Font.pm
new file mode 100755
index 00000000000..bb1b52cc7c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Font.pm
@@ -0,0 +1,163 @@
+package Tk::Font;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Font.pm#4 $
+require Tk::Widget;
+use strict;
+use Carp;
+use overload '""' => 'as_string';
+sub as_string { return ${$_[0]} }
+
+*MainWindow = \&Tk::Widget::MainWindow;
+
+foreach my $key (qw(actual metrics measure configure))
+ {
+ no strict 'refs';
+ *{$key} = sub { shift->Tk::font($key,@_) };
+ }
+
+Construct Tk::Widget 'Font';
+
+my @xfield = qw(foundry family weight slant swidth adstyle pixel
+ point xres yres space avgwidth registry encoding);
+my @tkfield = qw(family size weight slant underline overstrike);
+my %tkfield = map { $_ => "-$_" } @tkfield;
+
+sub _xonly { my $old = '*'; return $old }
+
+sub Pixel
+{
+ my $me = shift;
+ my $old = $me->configure('-size');
+ $old = '*' if ($old > 0);
+ if (@_)
+ {
+ $me->configure(-size => -$_[0]);
+ }
+ return $old;
+}
+
+sub Point
+{
+ my $me = shift;
+ my $old = 10*$me->configure('-size');
+ $old = '*' if ($old < 0);
+ if (@_)
+ {
+ $me->configure(-size => int($_[0]/10));
+ }
+ return $old;
+}
+
+foreach my $f (@tkfield,@xfield)
+ {
+ no strict 'refs';
+ my $sub = "\u$f";
+ unless (defined &{$sub})
+ {
+ my $key = $tkfield{$f};
+ if (defined $key)
+ {
+ *{$sub} = sub { shift->configure($key,@_) };
+ }
+ else
+ {
+ *{$sub} = \&_xonly;
+ }
+ }
+ }
+
+sub new
+{
+ my $pkg = shift;
+ my $w = shift;
+ my $me;
+ if (scalar(@_) == 1)
+ {
+ $me = $w->Tk::font('create',@_);
+ }
+ else
+ {
+ croak 'Odd number of args' if @_ & 1;
+ my %attr;
+ while (@_)
+ {
+ my $k = shift;
+ my $v = shift;
+ my $t = (substr($k,0,1) eq '-') ? $k : $tkfield{$k};
+ if (defined $t)
+ {
+ $attr{$t} = $v;
+ }
+ elsif ($k eq 'point')
+ {
+ $attr{'-size'} = -int($v/10+0.5);
+ }
+ elsif ($k eq 'pixel')
+ {
+ $attr{'-size'} = -$v;
+ }
+ else
+ {
+ carp "$k ignored" if $^W;
+ }
+ }
+ $me = $w->Tk::font('create',%attr);
+ }
+ return bless $me,$pkg;
+}
+
+sub Pattern
+{
+ my $me = shift;
+ my @str;
+ foreach my $f (@xfield)
+ {
+ my $meth = "\u$f";
+ my $str = $me->$meth();
+ if ($f eq 'family')
+ {
+ $str =~ s/(?:Times\s+New\s+Roman|New York)/Times/i;
+ $str =~ s/(?:Courier\s+New|Monaco)/Courier/i;
+ $str =~ s/(?:Arial|Geneva)/Helvetica/i;
+ }
+ elsif ($f eq 'slant')
+ {
+ $str = substr($str,0,1);
+ }
+ elsif ($f eq 'weight')
+ {
+ $str = 'medium' if ($str eq 'normal');
+ }
+ push(@str,$str);
+ }
+ return join('-', '', @str);
+}
+
+sub Name
+{
+ my $me = shift;
+ return $$me if (!wantarray || ($^O eq 'MSWin32'));
+ my $max = shift || 128;
+ my $w = $me->MainWindow;
+ my $d = $w->Display;
+ return $d->XListFonts($me->Pattern,$max);
+}
+
+sub Clone
+{
+ my $me = shift;
+ return ref($me)->new($me,$me->actual,@_);
+}
+
+sub ascent
+{
+ return shift->metrics('-ascent');
+}
+
+sub descent
+{
+ return shift->metrics('-descent');
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Font.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Font.pod
new file mode 100755
index 00000000000..594efa58bca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Font.pod
@@ -0,0 +1,407 @@
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+font - Create and inspect fonts.
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+S< >I<$widget>->B<Font>(I<option>?, I<arg, arg, ...>?)
+
+S< >I<$font>->I<Option>?(I<arg, arg, ...>)?
+
+=head1 DESCRIPTION
+
+The B<Font> method provides several facilities for dealing with
+fonts, such as defining named fonts and inspecting the actual attributes of
+a font. The command has several different forms, determined by the
+first argument. The following forms are currently supported:
+
+=over 4
+
+=item I<$font>-E<gt>B<actual>(I<-option>?)
+
+=item I<$widget>-E<gt>B<fontActual>(I<font>?, I<-option>?)
+
+Returns information about the actual attributes that are obtained when
+I<font> is used on I<$font>'s display; the actual attributes obtained
+may differ from the attributes requested due to platform-dependant
+limitations, such as the availability of font families and pointsizes.
+I<font> is a font description; see L<"FONT DESCRIPTION"> below. If
+I<option> is specified, returns the value of that attribute; if it is
+omitted, the return value is a list of all the attributes and their values.
+See L<"FONT OPTIONS"> below for a list of the possible attributes.
+
+=item I<$font>-E<gt>B<configure>(I<-option>??=>I<value>, I<-option>=>I<value>, ...?)
+
+Query or modify the desired attributes for I<$font>.
+If no I<-option> is specified, returns a list describing
+all the options and their values for I<fontname>. If a single I<-option>
+is specified with no I<value>, then returns the current value of that
+attribute. If one or more I<option-value> pairs are specified,
+then the method modifies the given named font to have the given values; in
+this case, all widgets using that font will redisplay themselves using the
+new attributes for the font. See L<"FONT OPTIONS"> below for a list of the
+possible attributes.
+
+Note: the above behaviour differs in detail to B<configure> on widgets,
+images etc.
+
+=item I<$font> = I<$widget>-E<gt>B<Font>(I<-option>=>I<value>, ...>?)
+
+=item I<$font> = I<$widget>-E<gt>B<fontCreate>(?I<fontname>??, I<-option>=>I<value>, ...>?)
+
+Creates a new font object and returns a reference to it.
+I<fontname> specifies the name for the font; if it is omitted, then Tk generates
+a new name of the form B<font>I<x>, where I<x> is an integer. There may be any
+number of I<option-value> pairs, which provide the desired attributes for
+the new named font. See L<"FONT OPTIONS"> below for a list of the possible
+attributes.
+
+Note: the created font is I<not> shared between widgets of different
+L<MainWindow|Tk::MainWindow>s.
+
+=item I<$font>-E<gt>B<delete>
+
+=item I<$widget>-E<gt>B<fontDelete>(I<fontname>?, I<fontname>, ...?)
+
+Delete the specified named fonts. If there are widgets using the named font,
+the named font won't actually be deleted until all the instances are
+released. Those widgets will continue to display using the last known values
+for the named font. If a deleted named font is subsequently recreated with
+another call to B<fontCreate>, the widgets will use the new named font
+and redisplay themselves using the new attributes of that font.
+
+=item I<$widget>-E<gt>B<fontFamilies>
+
+The return value is a list of the case-insensitive names of all font families
+that exist on I<$widget>'s display.
+
+=item I<$font>-E<gt>B<measure>(I<text>)
+
+=item I<$widget>-E<gt>B<fontMeasure>(I<font>, I<text>)
+
+Measures the amount of space the string I<text> would use in the given
+I<font> when displayed in I<$widget>. I<font> is a font description;
+see L<"FONT DESCRIPTION"> below.
+The return value is the total width in pixels
+of I<text>, not including the extra pixels used by highly exagerrated
+characters such as cursive ``I<f>''. If the string contains newlines or tabs,
+those characters are not expanded or treated specially when measuring the
+string.
+
+=item I<$font>-E<gt>B<metrics>(I<-option>?)
+
+=item I<$widget>-E<gt>B<fontMetrics>(I<font>?, I<-option>?)
+
+Returns information about the metrics (the font-specific data), for
+I<font> when it is used on I<$widget>'s display. I<font> is a font
+description; see L<"FONT DESCRIPTION"> below.
+If I<option> is specified,
+returns the value of that metric; if it is omitted, the return value is a
+list of all the metrics and their values. See L<"FONT METRICS"> below for a list
+of the possible metrics.
+
+=item I<$widget>-E<gt>B<fontNames>
+
+The return value is a list of all font objects that are currently defined for
+I<$widget>'s MainWindow.
+
+=back
+
+=head1 FONT DESCRIPTION
+
+The following formats are accepted as a font description anywhere
+I<font> is specified as an argument above; these same forms are also
+permitted when specifying the B<-font> option for widgets.
+
+=over 4
+
+=item [1] I<fontname>
+
+The name of a named font, created using the B<fontCreate> method. When
+a widget uses a named font, it is guaranteed that this will never cause an
+error, as long as the named font exists, no matter what potentially invalid
+or meaningless set of attributes the named font has. If the named font
+cannot be displayed with exactly the specified attributes, some other close
+font will be substituted automatically.
+
+=item [1a] I<$font>
+
+A font object created using the B<Font> method. This is essentially the same
+as using a named font. The object is a reference to the name, and carries
+additional information e.g. which MainWindow it relates to in an manner peculiar
+to perl/Tk.
+
+=item [3] I<systemfont>
+
+The platform-specific name of a font, interpreted by the graphics server.
+This also includes, under X, an XLFD (see L<[4]|/[4]>) for which a single ``B<*>''
+character was used to elide more than one field in the middle of the
+name. See L<"PLATFORM-SPECIFIC ISSUES"> for a list of the system fonts.
+
+=item [3] [I<family>,?I<size>,??I<style>,??I<style ...>?]
+
+A properly formed list whose first element is the desired font
+I<family> and whose optional second element is the desired I<size>.
+The interpretation of the I<size> attribute follows the same rules
+described for L<-size|/-size> in L<"FONT OPTIONS"> below. Any additional optional
+arguments following the I<size> are font I<style>s. Possible values
+for the I<style> arguments are as follows:
+
+ normal bold roman italic
+ underline overstrike
+
+=item [4] X-font names (XLFD)
+
+A Unix-centric font name of the form
+I<-foundry-family-weight-slant-setwidth-addstyle-pixel-point-resx-resy-spacing-width-charset-encoding>.
+The ``B<*>'' character may be used to skip individual fields that the
+user does not care about. There must be exactly one ``B<*>'' for each
+field skipped, except that a ``B<*>'' at the end of the XLFD skips any
+remaining fields; the shortest valid XLFD is simply ``B<*>'', signifying
+all fields as defaults. Any fields that were skipped are given default
+values. For compatibility, an XLFD always chooses a font of the specified
+pixel size (not point size); although this interpretation is not strictly
+correct, all existing applications using XLFDs assumed that one ``point''
+was in fact one pixel and would display incorrectly (generally larger) if
+the correct size font were actually used.
+
+=item [5] I<option value >?I<option value ...>?
+
+A properly formed list of I<option-value> pairs that specify
+the desired attributes of the font, in the same format used when defining
+a named font; see L<"FONT OPTIONS"> below.
+
+=back
+
+When font description I<font> is used, the system attempts to parse the
+description according to each of the above five rules, in the order specified.
+Cases [1] and [2] must match the name of an existing named font or of a
+system font. Cases [3], [4], and [5] are accepted on all
+platforms and the closest available font will be used. In some situations
+it may not be possible to find any close font (e.g., the font family was
+a garbage value); in that case, some system-dependant default font is
+chosen. If the font description does not match any of the above patterns,
+an error is generated.
+
+=head1 FONT METRICS
+
+The following options are used by the B<metrics>/B<fontMetrics> method to query
+font-specific data determined when the font was created. These properties are
+for the whole font itself and not for individual characters drawn in that
+font. In the following definitions, the ``baseline'' of a font is the
+horizontal line where the bottom of most letters line up; certain letters,
+such as lower-case ``g'' stick below the baseline.
+
+=over 4
+
+=item B<-ascent>
+
+The amount in pixels that the tallest letter sticks up above the baseline of
+the font, plus any extra blank space added by the designer of the font.
+(I<$font>-E<gt>B<ascent> is provided for compatibility.)
+
+=item B<-descent>
+
+The largest amount in pixels that any letter sticks down below the baseline
+of the font, plus any extra blank space added by the designer of the font.
+(I<$font>-E<gt>B<descent> is provided for compatibility.)
+
+=item B<-linespace>
+
+Returns how far apart vertically in pixels two lines of text using the same
+font should be placed so that none of the characters in one line overlap any
+of the characters in the other line. This is generally the sum of the ascent
+above the baseline line plus the descent below the baseline.
+
+=item B<-fixed>
+
+Returns a boolean flag that is ``B<1>'' if this is a fixed-width font,
+where each normal character is the the same width as all the other
+characters, or is ``B<0>'' if this is a proportionally-spaced font, where
+individual characters have different widths. The widths of control
+characters, tab characters, and other non-printing characters are not
+included when calculating this value.
+
+=back
+
+=head1 FONT OPTIONS
+
+The following options are supported on all platforms, and are used when
+constructing a named font or when specifying a font using style [5] as
+above:
+
+=over 4
+
+=item B<-family> => I<name>
+
+The case-insensitive font family name. Tk guarantees to support the font
+families named B<Courier> (a monospaced ``typewriter'' font), B<Times>
+(a serifed ``newspaper'' font), and B<Helvetica> (a sans-serif
+``European'' font). The most closely matching native font family will
+automatically be substituted when one of the above font families is used.
+The I<name> may also be the name of a native, platform-specific font
+family; in that case it will work as desired on one platform but may not
+display correctly on other platforms. If the family is unspecified or
+unrecognized, a platform-specific default font will be chosen.
+
+=item B<-size> => I<size>
+
+The desired size of the font. If the I<size> argument is a positive
+number, it is interpreted as a size in points. If I<size> is a negative
+number, its absolute value is interpreted as a size in pixels. If a
+font cannot be displayed at the specified size, a nearby size will be
+chosen. If I<size> is unspecified or zero, a platform-dependent default
+size will be chosen.
+
+The original Tcl/Tk authors believe sizes should normally be specified in points
+so the application will remain the same ruler size on the screen, even when
+changing screen resolutions or moving scripts across platforms. While this is an
+admirable goal it does not work as well in practice as they hoped.
+The mapping between points and pixels is set when the application starts, based
+on alleged properties of the installed monitor, but it can be overridden by
+calling the L<scaling|Tk::Widget/scaling> command. However this can be
+problematic when system has no way of telling if (say) an 11" or 22" monitor is
+attached, also if it I<can> tell then some monitor sizes may result in poorer
+quality scaled fonts being used rather than a "tuned" bitmap font.
+In addition specifying pixels is useful in certain circumstances such as when a piece of text
+must line up with respect to a fixed-size bitmap.
+
+At present the Tcl/Tk scheme is used unchanged, with "point" size being returned
+by I<actual> (as an integer), and used internally. Suggestions for work-rounds
+to undesirable behaviour welcome.
+
+=item B<-weight> => I<weight>
+
+The nominal thickness of the characters in the font. The value
+B<normal> specifies a normal weight font, while B<bold> specifies a
+bold font. The closest available weight to the one specified will
+be chosen. The default weight is B<normal>.
+
+=item B<-slant> => I<slant>
+
+The amount the characters in the font are slanted away from the
+vertical. Valid values for slant are B<roman> and B<italic>.
+A roman font is the normal, upright appearance of a font, while
+an italic font is one that is tilted some number of degrees from upright.
+The closest available slant to the one specified will be chosen.
+The default slant is B<roman>.
+
+=item B<-underline> => I<boolean>
+
+The value is a boolean flag that specifies whether characters in this
+font should be underlined. The default value for underline is B<false>.
+
+=item B<-overstrike> => I<boolean>
+
+The value is a boolean flag that specifies whether a horizontal line should
+be drawn through the middle of characters in this font. The default value
+for overstrike is B<false>.
+
+=back
+
+=head1 PLATFORM-SPECIFIC ISSUES
+
+The following named system fonts are supported:
+
+=over 4
+
+=item X Windows:
+
+All valid X font names, including those listed by xlsfonts(1), are available.
+
+=item MS Windows:
+
+ system ansi device
+ systemfixed ansifixed oemfixed
+
+=item Macintosh:
+
+ system application
+
+=back
+
+=head1 COMPATIBILITY WITH PREVIOUS VERSIONS
+
+In prior versions of perl/Tk the I<$widget>-E<gt>B<Font> method was a perl
+wrapper on the original "[4] X-font names (XLFD)" style as described above
+(which was the only form supported by versions of core tk prior to version
+tk8.0).
+This module is provided in its original form (it has just been renamed)
+via:
+
+ use Tk::X11Font;
+ I<$widget>-E<gt>B<X11Font>(...)
+
+However the methods of the old scheme have been mimiced as closely as possible
+with the new scheme. It is intended that code should work without modification,
+except for the case of using :
+
+ @names = $font->Name;
+
+i.e. the I<Name> method in an array/list context. This now returns one element
+on all platforms (as it did on Win32), while previously on X systems it returned
+a list of fonts that matched an under-specified pattern.
+
+Briefly the methods supported for compatibilty are as follows:
+
+=over 4
+
+=item $newfont = I<$font>-E<gt>B<Clone>(I<-option>=>I<value>, ...>?)
+
+Returns a new font object I<$newfont> related to the original I<$font> by
+changing the values of the specified I<-option>s.
+
+=item I<$font>-E<gt>Family - maps to -family
+
+=item I<$font>-E<gt>Weight - maps to -weight
+
+=item I<$font>-E<gt>Slant - maps to -slant
+
+=item I<$font>-E<gt>Pixel and Point - map to -size
+
+=back
+
+New code should use I<$font>-E<gt>B<configure> to achieve same effect as last
+four items above.
+
+=over 4
+
+=item Foundry, Swidth, Adstyle, Xres, Yres, Space, Avgwidth, Registry, Encoding
+
+Are all ignored if set, and return '*' if queried.
+
+=item I<$font>-E<gt>B<Name>
+
+Returns the name of a named font, or a string representation of an unnamed
+font. Using I<$font> in a scalar context does the same. Note this is distinctly
+different from behaviour of L<X11Font's Name|Tk::X11Font/Name( [ $max ] )> in
+a list context.
+
+=item I<$font>-E<gt>B<Pattern>
+
+Returns a XLFD string for the font based on I<actual> values, and some heuristics
+to map Tk's forms to the "standard" X conventions.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Tk::options|Tk::options>
+
+L<Tk::X11Font|Tk::X11Font>
+
+=head1 KEYWORDS
+
+font
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Frame.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Frame.pm
new file mode 100755
index 00000000000..a5716cdf9bd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Frame.pm
@@ -0,0 +1,378 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Frame;
+require Tk::Widget;
+require Tk::Derived;
+use AutoLoader;
+use strict qw(vars);
+use Carp;
+
+use base qw(Tk::Derived Tk::Widget);
+
+Construct Tk::Widget 'Frame';
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $
+
+sub Tk_cmd { \&Tk::frame }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-colormap','-visual','-container')
+}
+
+sub Default
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ $cw->Delegates(DEFAULT => $widget);
+ $cw->ConfigSpecs(DEFAULT => [$widget]);
+ $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect
+ $cw->Advertise($name,$widget);
+}
+
+sub ConfigDelegate
+{
+ my ($cw,$name,@skip) = @_;
+ my $sw = $cw->Subwidget($name);
+ my $sc;
+ my %skip = ();
+ foreach $sc (@skip)
+ {
+ $skip{$sc} = 1;
+ }
+ foreach $sc ($sw->configure)
+ {
+ my (@info) = @$sc;
+ next if (@info == 2);
+ my $option = $info[0];
+ unless ($skip{$option})
+ {
+ $option =~ s/^-(.*)/-$name\u$1/;
+ $info[0] = Tk::Configure->new($sw,$info[0]);
+ pop(@info);
+ $cw->ConfigSpecs($option => \@info);
+ }
+ }
+}
+
+sub bind
+{my ($cw,@args) = @_;
+ $cw->Delegate('bind',@args);
+}
+
+sub menu
+{my ($cw,@args) = @_;
+ $cw->Delegate('menu',@args);
+}
+
+sub focus
+{my ($cw,@args) = @_;
+ $cw->Delegate('focus',@args);
+}
+
+#sub bindtags
+#{my ($cw,@args) = @_;
+# $cw->Delegate('bindtags',@args);
+#}
+
+sub selection
+{my ($cw,@args) = @_;
+ $cw->Delegate('selection',@args);
+}
+
+sub autoLabel { 1 }
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ if ($cw->autoLabel)
+ {
+ $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]);
+ $cw->labelPack([]) if grep /^-label\w+/, keys %$args;
+ }
+}
+
+sub Menubar
+{
+ my $frame = shift;
+ my $menu = $frame->cget('-menu');
+ if (defined $menu)
+ {
+ $menu->configure(@_) if @_;
+ }
+ else
+ {
+ $menu = $frame->Menu(-type => 'menubar',@_);
+ $frame->configure('-menu' => $menu);
+ }
+ $frame->Advertise('menubar' => $menu);
+ return $menu;
+}
+
+1;
+
+__END__
+
+sub labelPack
+{
+ my ($cw,$val) = @_;
+ my $w = $cw->Subwidget('label');
+ my @result = ();
+ if (@_ > 1)
+ {
+ if (defined($w) && !defined($val))
+ {
+ $w->packForget;
+ }
+ elsif (defined($val) && !defined ($w))
+ {
+ require Tk::Label;
+ $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable);
+ $cw->Advertise('label' => $w);
+ $cw->ConfigDelegate('label',qw(-text -textvariable));
+ }
+ if (defined($val) && defined($w))
+ {
+ my %pack = @$val;
+ unless (exists $pack{-side})
+ {
+ $pack{-side} = 'top' unless (exists $pack{-side});
+ }
+ unless (exists $pack{-fill})
+ {
+ $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/);
+ $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/);
+ }
+ unless (exists($pack{'-before'}) || exists($pack{'-after'}))
+ {
+ my $before = ($cw->packSlaves)[0];
+ $pack{'-before'} = $before if (defined $before);
+ }
+ $w->pack(%pack);
+ }
+ }
+ @result = $w->packInfo if (defined $w);
+ return (wantarray) ? @result : \@result;
+}
+
+sub labelVariable
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-labelVariable'};
+ if (@_ > 1 && defined $val)
+ {
+ $$var = $val;
+ $$val = '' unless (defined $$val);
+ my $w = $cw->Subwidget('label');
+ unless (defined $w)
+ {
+ $cw->labelPack([]);
+ $w = $cw->Subwidget('label');
+ }
+ $w->configure(-textvariable => $val);
+ }
+ return $$var;
+}
+
+sub label
+{
+ my ($cw,$val) = @_;
+ my $var = $cw->cget('-labelVariable');
+ if (@_ > 1 && defined $val)
+ {
+ if (!defined $var)
+ {
+ $var = \$cw->{Configure}{'-label'};
+ $cw->labelVariable($var);
+ }
+ $$var = $val;
+ }
+ return (defined $var) ? $$var : undef;;
+}
+
+sub queuePack
+{
+ my ($cw) = @_;
+ unless ($cw->{'pack_pending'})
+ {
+ $cw->{'pack_pending'} = 1;
+ $cw->afterIdle([$cw,'packscrollbars']);
+ }
+}
+
+sub sbset
+{
+ my ($cw,$sb,$ref,@args) = @_;
+ $sb->set(@args);
+ $cw->queuePack if (@args == 2 && $sb->Needed != $$ref);
+}
+
+sub freeze_on_map
+{
+ my ($w) = @_;
+ unless ($w->Tk::bind('Freeze','<Map>'))
+ {
+ $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0])
+ }
+ $w->AddBindTag('Freeze');
+}
+
+sub AddScrollbars
+{
+ require Tk::Scrollbar;
+ my ($cw,$w) = @_;
+ my $def = '';
+ my ($x,$y) = ('','');
+ my $s = 0;
+ my $c;
+ $cw->freeze_on_map;
+ foreach $c ($w->configure)
+ {
+ my $opt = $c->[0];
+ if ($opt eq '-yscrollcommand')
+ {
+ my $slice = Tk::Frame->new($cw,Name => 'ysbslice');
+ my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]);
+ my $size = $ysb->cget('-width');
+ my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised',
+ '-width' => $size, '-height' => $size);
+ $ysb->pack(-side => 'left', -fill => 'y');
+ $cw->Advertise('yscrollbar' => $ysb);
+ $cw->Advertise('corner' => $corner);
+ $cw->Advertise('ysbslice' => $slice);
+ $corner->{'before'} = $ysb->PathName;
+ $slice->{'before'} = $w->PathName;
+ $y = 'w';
+ $s = 1;
+ }
+ elsif ($opt eq '-xscrollcommand')
+ {
+ my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]);
+ $cw->Advertise('xscrollbar' => $xsb);
+ $xsb->{'before'} = $w->PathName;
+ $x = 's';
+ $s = 1;
+ }
+ }
+ if ($s)
+ {
+ $cw->Advertise('scrolled' => $w);
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]);
+ }
+}
+
+sub packscrollbars
+{
+ my ($cw) = @_;
+ my $opt = $cw->cget('-scrollbars');
+ my $slice = $cw->Subwidget('ysbslice');
+ my $xsb = $cw->Subwidget('xscrollbar');
+ my $corner = $cw->Subwidget('corner');
+ my $w = $cw->Subwidget('scrolled');
+ my $xside = (($opt =~ /n/) ? 'top' : 'bottom');
+ my $havex = 0;
+ my $havey = 0;
+ $opt =~ s/r//;
+ $cw->{'pack_pending'} = 0;
+ if (defined $slice)
+ {
+ my $reqy;
+ my $ysb = $cw->Subwidget('yscrollbar');
+ if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed))
+ {
+ my $yside = (($opt =~ /w/) ? 'left' : 'right');
+ $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'});
+ $havey = 1;
+ if ($reqy)
+ {
+ $w->configure(-yscrollcommand => ['set', $ysb]);
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//;
+ $slice->packForget;
+ }
+ $cw->{'packysb'} = $havey;
+ }
+ if (defined $xsb)
+ {
+ my $reqx;
+ if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed))
+ {
+ $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'});
+ $havex = 1;
+ if ($reqx)
+ {
+ $w->configure(-xscrollcommand => ['set', $xsb]);
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//;
+ $xsb->packForget;
+ }
+ $cw->{'packxsb'} = $havex;
+ }
+ if (defined $corner)
+ {
+ if ($havex && $havey && defined $corner->{'before'})
+ {
+ my $anchor = $opt;
+ $anchor =~ s/o//g;
+ $corner->configure(-height => $xsb->ReqHeight);
+ $corner->pack(-before => $corner->{'before'}, -side => $xside,
+ -anchor => $anchor, -fill => 'x');
+ }
+ else
+ {
+ $corner->packForget;
+ }
+ }
+}
+
+sub scrollbars
+{
+ my ($cw,$opt) = @_;
+ my $var = \$cw->{'-scrollbars'};
+ if (@_ > 1)
+ {
+ my $old = $$var;
+ if (!defined $old || $old ne $opt)
+ {
+ $$var = $opt;
+ $cw->queuePack;
+ }
+ }
+ return $$var;
+}
+
+sub FindMenu
+{
+ my ($w,$char) = @_;
+ my $child;
+ my $match;
+ foreach $child ($w->children)
+ {
+ next unless (ref $child);
+ $match = $child->FindMenu($char);
+ return $match if (defined $match);
+ }
+ return undef;
+}
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Frame.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Frame.pod
new file mode 100755
index 00000000000..6570b6a18c7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Frame.pod
@@ -0,0 +1,146 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Frame - Create and manipulate Frame widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+S< >I<$frame> = I<$parent>-E<gt>B<Frame>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-borderwidth> B<-highlightbackground> B<-highlightthickness> B<-takefocus>
+B<-class> B<-highlightcolor> B<-relief>
+B<-cursor>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<background>
+
+=item Class: B<Background>
+
+=item Switch: B<-background>
+
+This option is the same as the standard B<background> option
+except that its value may also be specified as an undefined value.
+In this case, the widget will display no background or border, and
+no colors will be consumed from its colormap for its background
+and border.
+
+=item Name: B<colormap>
+
+=item Class: B<Colormap>
+
+=item Switch: B<-colormap>
+
+Specifies a colormap to use for the window.
+The value may be either B<new>, in which case a new colormap is
+created for the window and its children, or the name of another
+window (which must be on the same screen and have the same visual
+as $widget), in which case the new window will use the colormap
+from the specified window.
+If the B<colormap> option is not specified, the new window
+uses the same colormap as its parent.
+This option may not be changed with the B<configure>
+method.
+
+=item Name: B<container>
+
+=item Class: B<Container>
+
+=item Switch: B<-container>
+
+The value must be a boolean. If true, it means that this window will
+be used as a container in which some other application will be embedded
+(for example, a Tk toplevel can be embedded using the B<-use> option).
+The window will support the appropriate window manager protocols for
+things like geometry requests. The window should not have any
+children of its own in this application.
+This option may not be changed with the B<configure>
+method.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies the desired height for the window in any of the forms
+acceptable to B<Tk_GetPixels>.
+If this option is less than or equal to zero then the window will
+not request any size at all.
+
+=item Name: B<visual>
+
+=item Class: B<Visual>
+
+=item Switch: B<-visual>
+
+Specifies visual information for the new window in any of the
+forms accepted by B<Tk_GetVisual>.
+If this option is not specified, the new window will use the same
+visual as its parent.
+The B<visual> option may not be modified with the B<configure>
+method.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired width for the window in any of the forms
+acceptable to B<Tk_GetPixels>.
+If this option is less than or equal to zero then the window will
+not request any size at all.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Frame> method creates a new window (given by the
+$widget argument) and makes it into a frame widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the frame such as its background color
+and relief. The B<frame> command returns the
+path name of the new window.
+
+A frame is a simple widget. Its primary purpose is to act as a
+spacer or container for complex window layouts. The only features
+of a frame are its background color and an optional 3-D border to make the
+frame appear raised or sunken.
+
+=head1 WIDGET METHODS
+
+The B<Frame> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+=head1 BINDINGS
+
+When a new frame is created, it has no default event bindings:
+frames are not intended to be interactive.
+
+=head1 KEYWORDS
+
+frame, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/HList.pm b/Master/tlpkg/tlperl.straw/lib/Tk/HList.pm
new file mode 100755
index 00000000000..d259ca9ce24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/HList.pm
@@ -0,0 +1,685 @@
+package Tk::HList;
+
+use vars qw($VERSION);
+$VERSION = '4.015'; # was: sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'HList';
+sub Tk::Widget::ScrlHList { shift->Scrolled('HList'=>@_) }
+
+bootstrap Tk::HList;
+
+sub Tk_cmd { \&Tk::hlist }
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ my @result = $package->SUPER::CreateArgs($parent,$args);
+ my $columns = delete $args->{-columns};
+ push(@result, '-columns' => $columns) if (defined $columns);
+ return @result;
+}
+
+Tk::Methods qw(add addchild anchor column
+ delete dragsite dropsite entrycget
+ entryconfigure geometryinfo indicator header hide item info
+ nearest see select selection show xview yview);
+
+use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)],
+ 'header' => [qw(configure cget create delete exists size)],
+ 'indicator' => [qw(configure cget create delete exists size)],
+ 'info' => [qw(anchor bbox children data dragsite
+ dropsite exists hidden item next parent prev
+ selection)],
+ 'item' => [qw(configure cget create delete exists)],
+ 'selection' => [qw(clear get includes set)],
+ 'anchor' => [qw(clear set)],
+ 'column' => [qw(width)],
+ );
+
+# This is undocumented, but worked until 804.027:
+sub hideEntry { shift->hide('entry', @_) }
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] );
+ $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] );
+ $mw->bind($class,'<Control-ButtonRelease-1>','Control_ButtonRelease_1');
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+ $mw->bind($class,'<Double-ButtonRelease-1>','NoOp');
+ $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] );
+ $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] );
+
+ $mw->bind($class,'<Double-ButtonPress-1>',['Double1']);
+
+ $mw->bind($class,'<Control-B1-Motion>','Control_B1_Motion');
+ $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']);
+ $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']);
+
+ $mw->bind($class,'<B1-Enter>','B1_Enter');
+
+ $mw->bind($class,'<Up>',['UpDown', 'prev']);
+ $mw->bind($class,'<Down>',['UpDown', 'next']);
+
+ $mw->bind($class,'<Shift-Up>',['ShiftUpDown', 'prev']);
+ $mw->bind($class,'<Shift-Down>',['ShiftUpDown', 'next']);
+
+ $mw->bind($class,'<Left>', ['LeftRight', 'left']);
+ $mw->bind($class,'<Right>',['LeftRight', 'right']);
+
+ $mw->PriorNextBind($class);
+ $mw->MouseWheelBind($class);
+
+ $mw->bind($class,'<Return>', ['KeyboardActivate']);
+ $mw->bind($class,'<space>', ['KeyboardBrowse']);
+ $mw->bind($class,'<Home>', ['KeyboardHome']);
+ $mw->bind($class,'<End>', ['KeyboardEnd']);
+
+ $mw->YMouseWheelBind($class);
+ $mw->XMouseWheelBind($class);
+
+ return $class;
+}
+
+sub Control_ButtonRelease_1
+{
+}
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+ $w->ButtonRelease1($Ev);
+}
+
+sub Control_B1_Motion
+{
+}
+
+sub B1_Enter
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+}
+
+sub Button1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+ delete $w->{tixindicator};
+
+ $w->focus() if($w->cget('-takefocus'));
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+ # $w->Send_WaitDrag($Ev->y);
+ return;
+ }
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ if (!defined($ent) || !length($ent))
+ {
+ $w->selectionClear;
+ $w->anchorClear;
+ return;
+ }
+
+ my @info = $w->info('item',$Ev->x, $Ev->y);
+ if (@info)
+ {
+ die 'Assert' unless $info[0] eq $ent;
+ }
+ else
+ {
+ @info = $ent;
+ }
+
+ if (defined($info[1]) && $info[1] eq 'indicator')
+ {
+ $w->{tixindicator} = $ent;
+ $w->Callback(-indicatorcmd => $ent, '<Arm>');
+ }
+ else
+ {
+ my $browse = 0;
+
+ if ($mode eq 'single')
+ {
+ $w->anchorSet($ent);
+ }
+ elsif ($mode eq 'browse')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->selectionClear;
+ $w->anchorSet($ent);
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+ elsif ($mode eq 'extended')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+
+ if ($browse)
+ {
+ $w->Callback(-browsecmd => @info);
+ }
+ }
+}
+
+sub ShiftButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ my $to = $w->GetNearest($Ev->y, 1);
+
+ delete $w->{'shiftanchor'};
+ delete $w->{tixindicator};
+
+ return unless (defined($to) and length($to));
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended' or $mode eq 'multiple')
+ {
+ my $from = $w->info('anchor');
+ if(defined $from)
+ {
+ $w->selectionClear;
+ $w->selectionSet($from, $to);
+ }
+ else
+ {
+ $w->anchorSet($to);
+ $w->selectionClear;
+ $w->selectionSet($to);
+ }
+ }
+}
+
+sub GetNearest
+{
+ my ($w,$y,$undefafterend) = @_;
+ my $ent = $w->nearest($y);
+ if (defined $ent)
+ {
+ if ($undefafterend)
+ {
+ my $borderwidth = $w->cget('-borderwidth');
+ my $highlightthickness = $w->cget('-highlightthickness');
+ my $bottomy = ($w->infoBbox($ent))[3];
+ $bottomy += $borderwidth + $highlightthickness;
+ if ($w->header('exist', 0))
+ {
+ $bottomy += $w->header('height');
+ }
+ if ($y > $bottomy)
+ {
+ #print "$y > $bottomy\n";
+ return undef;
+ }
+ }
+ my $state = $w->entrycget($ent, '-state');
+ return $ent if (!defined($state) || $state ne 'disabled');
+ }
+ return undef;
+}
+
+sub ButtonRelease1
+{
+ my ($w, $Ev) = @_;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'dragdrop')
+ {
+# $w->Send_DoneDrag();
+ return;
+ }
+
+ my ($x, $y) = ($Ev->x, $Ev->y);
+ my $ent = $w->GetNearest($y, 1);
+
+ if (!defined($ent) and $mode eq 'single')
+ {
+ my $ent = $w->info('selection');
+ if (defined $ent)
+ {
+ $w->anchorSet($ent);
+ }
+ }
+ return unless (defined($ent) and length($ent));
+
+ if (exists $w->{tixindicator})
+ {
+ return unless delete($w->{tixindicator}) eq $ent;
+ my @info = $w->info('item',$Ev->x, $Ev->y);
+ if(defined($info[1]) && $info[1] eq 'indicator')
+ {
+ $w->Callback(-indicatorcmd => $ent, '<Activate>');
+ }
+ else
+ {
+ $w->Callback(-indicatorcmd => $ent, '<Disarm>');
+ }
+ return;
+ }
+
+ if($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+
+ }
+ elsif($mode eq 'multiple')
+ {
+ $w->selectionSet($ent);
+ }
+ elsif($mode eq 'extended')
+ {
+ $w->selectionSet($ent);
+ }
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub Button1Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ return unless defined $Ev;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+# $w->Send_StartDrag();
+ return;
+ }
+
+ my $ent;
+ if (defined $w->info('anchor'))
+ {
+ $ent = $w->GetNearest($Ev->y);
+ }
+ else
+ {
+ $ent = $w->GetNearest($Ev->y, 1);
+ }
+ return unless (defined($ent) and length($ent));
+
+ if(exists $w->{tixindicator})
+ {
+ my $event_type = $w->{tixindicator} eq $ent ? '<Arm>' : '<Disarm>';
+ $w->Callback(-indicatorcmd => $w->{tixindicator}, $event_type );
+ return;
+ }
+
+ if ($mode eq 'single')
+ {
+ $w->anchorSet($ent);
+ }
+ elsif ($mode eq 'multiple' || $mode eq 'extended')
+ {
+ my $from = $w->info('anchor');
+ if(defined $from)
+ {
+ $w->selectionClear;
+ $w->selectionSet($from, $ent);
+ }
+ else
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ }
+ }
+
+ if ($mode ne 'single')
+ {
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub Double1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ return unless (defined($ent) and length($ent));
+
+ $w->anchorSet($ent)
+ unless(defined $w->info('anchor'));
+
+ $w->selectionSet($ent);
+
+ $w->Callback(-command => $ent);
+}
+
+sub CtrlButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ return unless (defined($ent) and length($ent));
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended')
+ {
+ $w->anchorSet($ent) unless( defined $w->info('anchor') );
+
+ if($w->select('includes', $ent))
+ {
+ $w->select('clear', $ent);
+ }
+ else
+ {
+ $w->selectionSet($ent);
+ }
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub UpDown
+{
+ my $w = shift;
+ my $spec = shift;
+
+ my $done = 0;
+ my $anchor = $w->info('anchor');
+
+ delete $w->{'shiftanchor'};
+
+ unless( defined $anchor )
+ {
+ $anchor = ($w->info('children'))[0];
+
+ return unless (defined($anchor) and length($anchor));
+
+ if($w->entrycget($anchor, '-state') ne 'disabled')
+ {
+ # That's a good anchor
+ $done = 1;
+ }
+ else
+ {
+ # We search for the first non-disabled entry (downward)
+ $spec = 'next';
+ }
+ }
+
+ my $ent = $anchor;
+
+ # Find the prev/next non-disabled entry
+ #
+ while(!$done)
+ {
+ $ent = $w->info($spec, $ent);
+ last unless( defined $ent );
+ next if( $w->entrycget($ent, '-state') eq 'disabled' );
+ next if( $w->info('hidden', $ent) );
+ last;
+ }
+
+ unless( defined $ent )
+ {
+ $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->anchorSet($ent);
+ $w->see($ent);
+
+ if($w->cget('-selectmode') ne 'single')
+ {
+ $w->selectionClear;
+ $w->selection('set', $ent);
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub ShiftUpDown
+{
+ my $w = shift;
+ my $spec = shift;
+
+ my $mode = $w->cget('-selectmode');
+
+ return $w->UpDown($spec)
+ if($mode eq 'single' || $mode eq 'browse');
+
+ my $anchor = $w->info('anchor');
+
+ return $w->UpDown($spec) unless (defined($anchor) and length($anchor));
+
+ my $done = 0;
+
+ $w->{'shiftanchor'} = $anchor unless( $w->{'shiftanchor'} );
+
+ my $ent = $w->{'shiftanchor'};
+
+ while( !$done )
+ {
+ $ent = $w->info($spec, $ent);
+ last unless( defined $ent );
+ next if( $w->entrycget($ent, '-state') eq 'disabled' );
+ next if( $w->info('hidden', $ent) );
+ last;
+ }
+
+ unless( $ent )
+ {
+ $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->selectionClear;
+ $w->selection('set', $anchor, $ent);
+ $w->see($ent);
+
+ $w->{'shiftanchor'} = $ent;
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub LeftRight
+{
+ my $w = shift;
+ my $spec = shift;
+
+ delete $w->{'shiftanchor'};
+
+ my $anchor = $w->info('anchor');
+
+ unless(defined $anchor)
+ {
+ $anchor = ($w->info('children'))[0]
+ }
+ unless(defined $anchor)
+ {
+ $anchor = '';
+ }
+
+ my $done = 0;
+ my $ent = $anchor;
+
+ while(!$done)
+ {
+ my $e = $ent;
+
+ if($spec eq 'left')
+ {
+ $ent = $w->info('parent', $e);
+
+ $ent = $w->info('prev', $e)
+ unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
+ }
+ else
+ {
+ $ent = ($w->info('children', $e))[0];
+
+ $ent = $w->info('next', $e)
+ unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
+ }
+
+ last unless( defined $ent );
+ last if($w->entrycget($ent, '-state') ne 'disabled');
+ }
+
+ unless( defined $ent )
+ {
+ $w->xview('scroll', $spec eq 'left' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->anchorSet($ent);
+ $w->see($ent);
+
+ if($w->cget('-selectmode') ne 'single')
+ {
+ $w->selectionClear;
+ $w->selectionSet($ent);
+
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub KeyboardHome
+{
+ my $w = shift;
+ $w->yview('moveto' => 0);
+ $w->xview('moveto' => 0);
+}
+
+sub KeyboardEnd
+{
+ my $w = shift;
+ $w->yview('moveto' => 1);
+ $w->xview('moveto' => 0);
+}
+
+sub KeyboardActivate
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless (defined($anchor) and length($anchor));
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selectionClear;
+ $w->selectionSet($anchor);
+ }
+
+ $w->Callback(-command => $anchor);
+}
+
+sub KeyboardBrowse
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless (defined($anchor) and length($anchor));
+
+ if ($w->indicatorExists($anchor))
+ {
+ $w->Callback(-indicatorcmd => $anchor);
+ }
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selectionClear;
+ $w->selectionSet($anchor);
+ }
+ $w->Callback(-browsecmd =>$anchor);
+}
+
+sub AutoScan
+{
+ my ($w,$x,$y) = @_;
+
+ return if ($w->cget('-selectmode') eq 'dragdrop');
+ if (@_ < 3)
+ {
+ my $Ev = $w->XEvent;
+ return unless defined $Ev;
+ $y = $Ev->y;
+ $x = $Ev->x;
+ }
+
+ if($y >= $w->height)
+ {
+ $w->yview('scroll', 1, 'units');
+ }
+ elsif($y < 0)
+ {
+ $w->yview('scroll', -1, 'units');
+ }
+ elsif($x >= $w->width)
+ {
+ $w->xview('scroll', 2, 'units');
+ }
+ elsif($x < 0)
+ {
+ $w->xview('scroll', -2, 'units');
+ }
+ else
+ {
+ return;
+ }
+ $w->RepeatId($w->SUPER::after(50,[ AutoScan => $w, $x, $y ]));
+ $w->Button1Motion;
+}
+
+sub children
+{
+ # Tix has core-tk window(s) which are not a widget(s)
+ # the generic code returns these as an "undef"
+ my $w = shift;
+ my @info = grep(defined($_),$w->winfo('children'));
+ @info;
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/HList.pod b/Master/tlpkg/tlperl.straw/lib/Tk/HList.pod
new file mode 100755
index 00000000000..4bbb8643c00
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/HList.pod
@@ -0,0 +1,1050 @@
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distribution are in the file
+# license.tcl.
+
+=head1 NAME
+
+Tk::HList - Create and manipulate Tix Hierarchial List widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$hlist> = I<$parent>-E<gt>B<HList>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-background> B<-borderwidth> B<-cursor> B<-exportselection>
+B<-foreground> B<-font> B<-height> B<-highlightcolor>
+B<-highlightthickness> B<-relief> B<-selectbackground>
+B<-selectforeground> B<-xscrollcommand> B<-yscrollcommand>
+B<-width>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<browsecmd>
+
+=item Class: B<BrowseCmd>
+
+=item Switch: B<-browsecmd>
+
+Specifies a perl/Tk L<callback|Tk::callbacks> to be executed when the user browses through the
+entries in the HList widget.
+
+=item Name: B<columns>
+
+=item Class: B<Columns>
+
+=item Switch: B<-columns>
+
+Specifies the number of columns in this HList widget. This option can
+only be set during the creation of the HList widget and cannot be
+changed subsequently.
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies the perl/Tk L<callback|Tk::callbacks> to be executed when the user invokes a list
+entry in the HList widget. Normally the user invokes a list
+entry by double-clicking it or pressing the Return key.
+
+=item Name: B<drawBranch>
+
+=item Class: B<DrawBranch>
+
+=item Switch: B<-drawbranch>
+
+A Boolean value to specify whether branch line should be drawn to
+connect list entries to their parents.
+
+=item Name: B<foreground>
+
+=item Class: B<Foreground>
+
+=item Switch: B<-foreground>
+
+=item Alias: B<-fg>
+
+B<[OBSOLETE]> Specifies the default foreground color for the list entries.
+
+=item Name: B<gap>
+
+=item Class: B<Gap>
+
+=item Switch: B<-gap>
+
+B<[OBSOLETE]> The default distance between the bitmap/image and the
+text in list entries.
+
+=item Name: B<header>
+
+=item Class: B<Header>
+
+=item Switch: B<-header>
+
+A Boolean value specifying whether headers should be displayed for
+this HList widget (see the B<header> method below).
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies the desired height for the window in number of characters.
+
+=item Name: B<indent>
+
+=item Class: B<Indent>
+
+=item Switch: B<-indent>
+
+Specifies the amount of horizontal indentation between a list entry
+and its children. Must be a valid screen distance value.
+
+=item Name: B<indicator>
+
+=item Class: B<Indicator>
+
+=item Switch: B<-indicator>
+
+Specifies whether the indicators should be displayed inside the HList
+widget. See the B<indicator> method below.
+
+=item Name: B<indicatorCmd>
+
+=item Class: B<IndicatorCmd>
+
+=item Switch: B<-indicatorcmd>
+
+Specifies a perl/Tk L<callback|Tk::callbacks> to be executed when the user manipulates the
+indicator of an HList entry. The B<-indicatorcmd> is triggered
+when the user press or releases the mouse button over the indicator in
+an HList entry. By default the perl/Tk B<callback> specified by
+B<-indicatorcmd> is executed with two additional arguments, the
+entryPath of the entry whose indicator has been triggered and additional
+information about the event. The additional information is one of the
+following strings: B<E<lt>ArmE<gt>>, B<E<lt>DisarmE<gt>>,
+and B<E<lt>ActivateE<gt>>.
+
+=item Name: B<itemType>
+
+=item Class: B<ItemType>
+
+=item Switch: B<-itemtype>
+
+Specifies the default type of display item for this HList widget. When
+you call the B<itemCreate>, B<add> and B<addchild> methods, display
+items of this
+type will be created if the B<-itemtype> option is not specified .
+
+=item Name: B<padX>
+
+=item Class: B<Pad>
+
+=item Switch: B<-padx>
+
+B<[OBSOLETE]> The default horizontal padding for list entries.
+
+=item Name: B<padY>
+
+=item Class: B<Pad>
+
+=item Switch: B<-padx>
+
+B<[OBSOLETE]> The default vertical padding for list entries.
+
+=item Name: B<selectBackground>
+
+=item Class: B<SelectBackground>
+
+=item Switch: B<-selectbackground>
+
+Specifies the background color for the selected list entries.
+
+=item Name: B<selectBorderWidth>
+
+=item Class: B<BorderWidth>
+
+=item Switch: B<-selectborderwidth>
+
+Specifies a non-negative value indicating the width of the 3-D border
+to draw around selected items. The value may have any of the forms
+acceptable to B<Tk_GetPixels>.
+
+=item Name: B<selectForeground>
+
+=item Class: B<SelectForeground>
+
+=item Switch: B<-selectforeground>
+
+Specifies the foreground color for the selected list entries.
+
+=item Name: B<selectMode>
+
+=item Class: B<SelectMode>
+
+=item Switch: B<-selectmode>
+
+Specifies one of several styles for manipulating the selection. The
+value of the option may be arbitrary, but the default bindings expect
+it to be either B<single>, B<browse>, B<multiple>, or
+B<extended>; the default value is B<single>.
+
+=item Name: B<sizeCmd>
+
+=item Class: B<SizeCmd>
+
+=item Switch: B<-sizecmd>
+
+Specifies a perl/Tk L<callback|Tk::callbacks> to be called whenever the HList widget
+changes its size. This method can be useful to implement ``I<user scroll
+bars when needed>'' features.
+
+=item Name: B<separator>
+
+=item Class: B<Separator>
+
+=item Switch: B<-separator>
+
+Specifies the character to used as the separator character when
+intepreting the path-names of list entries. By default the character
+"." is used.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired width for the window in characters.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<HList> method creates a new window (given by the
+$widget argument) and makes it into a HList widget.
+Additional options, described above, may be specified on the command
+line or in the option database to configure aspects of the
+HList widget such as its cursor and relief.
+
+The HList widget can be used to display any data that have a
+hierarchical structure, for example, file system directory trees. The
+list entries are indented and connected by branch lines according to
+their places in the hierachy.
+
+Each list entry is identified by an B<entryPath>. The entryPath is a
+sequence of B<entry names> separated by the separator charactor
+(specified by the B<-separator> option). An B<entry name> can be
+any string that does not contain the separator charactor, or it can be
+the a string that contains only one separator charactor.
+
+For example, when "." is used as the separator charactor,
+"one.two.three" is the entryPath for a list entry whose parent is
+"one.two", whose parent is "one", which is a toplevel entry (has no
+parents).
+
+Another examples: ".two.three" is the entryPath for a list entry whose
+parent is ".two", whose parent is ".", which is a toplevel entry.
+
+=head1 DISPLAY ITEMS
+
+Each list entry in an HList widget is associated with a B<display>
+item. The display item determines what visual information should
+be displayed for this list entry. Please see L<Tk::DItem>
+for a list of all display items.
+When a list entry is created by the B<itemCreate>, B<add> or
+B<addchild> widget
+methods, the type of its display item is determined by the
+B<-itemtype> option passed to these methods. If the
+B<-itemtype> is omitted, then by default the type specified by
+this HList widget's B<-itemtype> option is used.
+
+=head1 WIDGET METHODS
+
+The B<HList> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available HList widgets:
+
+=over 4
+
+=item I<$hlist>-E<gt>B<add>(I<$entryPath> ?,I<option>=E<gt>I<value>, ...?)
+
+Creates a new list entry with the pathname I<$entryPath>. A list
+entry must be created after its parent is created (unless this entry
+is a top-level entry, which has no parent). See also L<"BUGS"> below.
+This method returns the
+entryPath of the newly created list entry. The following
+configuration options can be given to configure the list entry:
+
+=over 8
+
+=item B<-at> =E<gt> I<position>
+
+Insert the new list at the position given by I<position>.
+I<position> must be a valid integer. The position B<0> indicates
+the first position, B<1> indicates the second position, and so on.
+
+=item B<-after> =E<gt> I<afterWhich>
+
+Insert the new list entry after the entry identified by
+I<afterWhich>. I<afterWhich> must be a valid list entry and it
+mush have the same parent as the new list entry
+
+=item B<-before> =E<gt> I<beforeWhich>
+
+Insert the new list entry before the entry identified by
+I<beforeWhich>. I<beforeWhich> must be a valid list entry and it
+mush have the same parent as the new list entry
+
+=item B<-data> =E<gt> I<string>
+
+Specifies a string to associate with this list entry. This string can
+be queried by the B<info> method. The application
+programmer can use the B<-data> option to associate the list entry
+with the data it represents.
+
+=item B<-itemtype> =E<gt> I<type>
+
+Specifies the type of display item to be display for the new list
+entry. B<type> must be a valid display item type. Currently the
+available display item types are B<imagetext>, B<text>, and
+$widget. If this option is not specified, then by default the
+type specified by this HList widget's B<-itemtype> option is used.
+
+=item B<-state> =E<gt> I<state>
+
+Specifies whether this entry can be selected or invoked by the user.
+Must be either B<normal> or B<disabled>.
+
+=back
+
+The B<add> method accepts additional configuration options
+to configure the display item associated with this list entry. The set
+of additional configuration options depends on the type of the display
+item given by the B<-itemtype> option. Please see
+L<Tk::DItem> for a list of the configuration options for
+each of the display item types.
+
+=item I<$hlist>-E<gt>B<addchild>(I<$parentPath, >?I<option, value, ..., >?)
+
+Adds a new child entry to the children list of the list entry
+identified by I<$parentPath>. Or, if I<$parentPath> is set to be
+the empty string, then creates a new toplevel entry. The name of the
+new list entry will be a unique name automatically generated by the
+HList widget. Usually if I<$parentPath> is B<foo>, then the
+entryPath of the new entry will be B<foo.0>, B<foo.1>, ... etc.
+This method returns the entryPath of the newly created list entry.
+I<option> can be any option for the B<add> method.
+See also L<"BUGS"> below.
+
+=item I<$hlist>-E<gt>B<anchorSet>(I<$entryPath>)
+
+Sets the anchor to the list entry identified by I<$entryPath>. The
+anchor is the end of the selection that is fixed while the user is
+dragging out a selection with the mouse.
+
+=item I<$hlist>-E<gt>B<anchorClear>
+
+Removes the anchor, if any, from this HList widget. This only
+removes the surrounding highlights of the anchor entry and does not
+affect its selection status.
+
+=item I<$hlist>-E<gt>B<columnWidth>(I<$col>?, I<-char>?, ?I<width>?)
+
+Querys or sets the width of a the column I<$col> in the HList
+widget. The value of I<$col> is zero-based: 0 stands for the first
+column, 1 stands for the second, and so on. If no further parameters
+are given, returns the current width of this column (in number of
+pixels). Additional parameters can be given to set the width of this
+column:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<columnWidth>(I<$col>, B<''>)
+
+An empty string indicates that the width of the column should be just
+wide enough to display the widest element in this column. In this
+case, the width of this column may change as a result of the elements
+in this column changing their sizes.
+
+=item I<$hlist>-E<gt>B<columnWidth>(I<$col, >I<width>)
+
+I<width> must be in a form accepted by B<Tk_GetPixels>.
+
+=item I<$hlist>-E<gt>B<columnWidth>(I<$col, >B<-char, >I<nChars>)
+
+The width is set to be the average width occupied by I<nChars>
+number of characters of the font specified by the B<-font> option
+of this HList widget.
+
+=back
+
+=item I<$hlist>-E<gt>B<delete>(I<option>, I<$entryPath>)
+
+Delete one or more list entries. I<option> may be one of the
+following:
+
+=over 8
+
+=item B<all>
+
+Delete all entries in the HList. In this case the I<$entryPath>
+does not need to be specified.
+
+=item B<entry>
+
+Delete the entry specified by I<$entryPath> and all its offsprings,
+if any.
+
+=item B<offsprings>
+
+Delete all the offsprings, if any, of the entry specified by
+I<$entryPath>. However, I<$entryPath> itself is not deleted.
+
+=item B<siblings>
+
+Delete all the list entries that share the same parent with the entry
+specified by I<$entryPath>. However, I<$entryPath> itself is not
+deleted.
+
+=back
+
+=item I<$hlist>-E<gt>B<dragsiteSet>(I<$entryPath>)
+
+Sets the dragsite to the list entry identified by
+I<$entryPath>. The dragsite is used to indicate the source of a
+drag-and-drop action. Currently drag-and-drop functionality has not
+been implemented in Tix yet.
+
+=item I<$hlist>-E<gt>B<dragsiteClear>
+
+Remove the dragsite, if any, from the this HList widget. This only
+removes the surrounding highlights of the dragsite entry and does not
+affect its selection status.
+
+=item I<$hlist>-E<gt>B<dropsiteSet>(I<$entryPath>)
+
+Sets the dropsite to the list entry identified by I<$entryPath>. The
+dropsite is used to indicate the target of a drag-and-drop
+action. Currently drag-and-drop functionality has not been implemented
+in Tix yet.
+
+=item I<$hlist>-E<gt>B<dropsiteClear>
+
+Remove the dropsite, if any, from the this HList widget. This only
+removes the surrounding highlights of the dropsite entry and does not
+affect its selection status.
+
+=item I<$hlist>-E<gt>B<entrycget>(I<$entryPath>, I<option>)
+
+Returns the current value of the configuration option given by
+I<option> for the entry indentfied by I<$entryPath>. I<Option>
+may have any of the values accepted by the B<add> method.
+
+=item I<$hlist>-E<gt>B<entryconfigure>(I<$entryPath> ?,I<option>?, ?I<value>=E<gt>I<option>, ...?)
+
+Query or modify the configuration options of the list entry indentfied
+by I<$entryPath>. If no I<option> is specified, returns a list
+describing all of the available options for I<$entryPath> (see
+L<Tk::options> for information on the format of this list.) If
+I<option> is specified with no I<value>, then the method
+returns a list describing the one named option (this list will be
+identical to the corresponding sublist of the value returned if no
+I<option> is specified). If one or more I<option-value> pairs
+are specified, then the method modifies the given option(s) to have
+the given value(s); in this case the method returns an empty string.
+I<Option> may have any of the values accepted by the B<add> or
+B<addchild> method. The exact set of options depends on the
+value of the B<-itemtype> option passed to the the B<add> or
+B<addchild> method when this list entry is created.
+
+=item I<$hlist>-E<gt>B<header>(I<option>, I<$col> ?,I<args>, ...?)
+
+Manipulates the header items of this HList widget. If the
+B<-header> option of this HList widget is set to true, then a
+header item is displayed at the top of each column. The I<$col>
+argument for this method must be a valid integer. 0 indicates the
+first column, 1 the second column, ... and so on. This method
+supports the following options:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<header>(B<cget>, I<$col>, I<option>)
+
+If the I<$col>-th column has a header display item, returns the
+value of the specified I<option> of the header item. If the header
+doesn't exist, returns an error.
+
+=item I<$hlist>-E<gt>B<header>(B<configure, >I<$col, >?I<option>?, I<?value, option, value, ...>?)
+
+Query or modify the configuration options of the header display item
+of the I<$col>-th column. The header item must exist, or an error
+will result. If no I<option> is specified, returns a list
+describing all of the available options for the header display item
+(see L<Tk::options> for information on the format of this
+list.) If I<option> is specified with no I<value>, then the
+method returns a list describing the one named option (this list will
+be identical to the corresponding sublist of the value returned if no
+I<option> is specified). If one or more I<option-value> pairs
+are specified, then the method modifies the given option(s) to have
+the given value(s); in this case the method returns an empty
+string. I<Option> may have any of the values accepted by the
+B<header create> method. The exact set of options depends
+on the value of the B<-itemtype> option passed to the the B<header>
+create method when this display item was created.
+
+=item I<$hlist>-E<gt>B<header>(B<create, >I<$col, >?I<-itemtype type>? ?I<option value ...>?
+
+Creates a new display item as the header for the I<$col>-th
+column. See also L<"BUGS"> below.
+If an header display item already exists for this column, it
+will be replaced by the new item. An optional parameter
+I<-itemtype> can be used to specify what type of display item
+should be created. If the I<-itemtype> is not given, then by
+default the type specified by this HList widget's B<-itemtype>
+option is used. Additional parameters, in I<option-value> pairs,
+can be passed to configure the appearance of the display item. Each
+I<option-value> pair must be a valid option for this type of
+display item or one of the following:
+
+=over 12
+
+=item B<-borderwidth> =E<gt> I<color>
+
+Specifies the border width of this header item.
+
+=item B<-headerbackground> =E<gt> I<color>
+
+Specifies the background color of this header item.
+
+=item B<-relief> =E<gt> I<type>
+
+Specifies the relief type of the border of this header item.
+
+=back
+
+=item I<$hlist>-E<gt>B<header>(B<delete, >I<$col>)
+
+Deletes the header display item for the I<$col>-th column.
+
+=item I<$hlist>-E<gt>B<header>(B<exists, >I<$col>)
+
+Return true if an header display item exists for the I<$col>-th
+column; return false otherwise.
+
+=item I<$hlist>-E<gt>B<header>(B<size>, I<$entryPath>)
+
+If an header display item exists for the I<$col>-th column , returns
+its size in pixels in a two element list I<(width, height)>;
+returns an error if the header display item does not exist.
+
+=back
+
+=item I<$hlist>-E<gt>B<hide>(I<option> ?,I<$entryPath>?)
+
+Makes some of entries invisible without deleting them.
+I<Option> can be one of the following:
+
+=over 8
+
+=item B<entry>
+
+Hides the list entry identified by I<$entryPath>.
+
+=back
+
+Currently only the B<entry> option is supported. Other options will
+be added in the next release.
+
+=item I<$hlist>-E<gt>B<indicator>(I<option>, I<$entryPath>, ?I<args, ...>?)
+
+Manipulates the indicator on the list entries. An indicator is usually
+a small display item (such as an image) that is displayed to the left
+to an entry to indicate the status of the entry. For example, it may
+be used to indicate whether a directory is opened or
+closed. I<Option> can be one of the following:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<indicator>(B<cget>, I<$entryPath>, I<option>)
+
+If the list entry given by I<$entryPath> has an indicator, returns
+the value of the specified I<option> of the indicator. If the
+indicator doesn't exist, returns an error.
+
+=item I<$hlist>-E<gt>B<indicator>(B<configure>, I<$entryPath>, ?I<option>?, I<?value, option, value, ...>?)
+
+Query or modify the configuration options of the indicator display
+item of the entry specified by I<$entryPath>. The indicator item
+must exist, or an error will result. If no I<option> is specified,
+returns a list describing all of the available options for the
+indicator display item (see L<Tk::options> for information
+on the format of this list). If I<option> is specified with no
+I<value>, then the method returns a list describing the one named
+option (this list will be identical to the corresponding sublist of
+the value returned if no I<option> is specified). If one or more
+I<option-value> pairs are specified, then the method modifies the
+given option(s) to have the given value(s); in this case the method
+returns an empty string. I<Option> may have any of the values
+accepted by the B<indicator create> method. The exact set
+of options depends on the value of the B<-itemtype> option passed
+to the the B<indicator create> method when this display item
+was created.
+
+=item I<$hlist>-E<gt>B<indicator>(B<create, >I<$entryPath, >?, I<-itemtype type>? ?I<option value ...>?)
+
+Creates a new display item as the indicator for the entry specified by
+I<$entryPath>. If an indicator display item already exists for this
+entry, it will be replaced by the new item. An optional parameter
+I<-itemtype> can be used to specify what type of display item
+should be created. If the I<-itemtype> is not given, then by
+default the type specified by this HList widget's B<-itemtype>
+option is used. Additional parameters, in I<option-value> pairs,
+can be passed to configure the appearance of the display item. Each
+I<option-value> pair must be a valid option for this type of
+display item.
+
+=item I<$hlist>-E<gt>B<indicator>(B<delete>, I<$entryPath>)
+
+Deletes the indicator display item for the entry given by I<$entryPath>.
+
+=item I<$hlist>-E<gt>B<indicator>(B<exists>, I<$entryPath>)
+
+Return true if an indicator display item exists for the entry given by
+I<$entryPath>; return false otherwise.
+
+=item I<$hlist>-E<gt>B<indicator>(B<size>, I<$entryPath>)
+
+If an indicator display item exists for the entry given by
+I<$entryPath>, returns its size in a two element list of the form
+{I<width height>}; returns an error if the indicator display item
+does not exist.
+
+=back
+
+=item I<$hlist>-E<gt>B<info>(I<option>, I<arg, ...>)
+
+Query information about the HList widget. I<option> can be one
+of the following:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<info>(B<anchor>)
+
+Returns the entryPath of the current anchor, if any, of the HList
+widget. If the anchor is not set, returns the empty string.
+
+=item I<$hlist>-E<gt>B<infoBbox>(I<$entryPath>)
+
+Returns a list of four numbers describing the visible bounding box of
+the entry given I<$entryPath>. The first two elements of the list
+give the x and y coordinates of the upper-left corner of the screen
+area covered by the entry (specified in pixels relative to the widget)
+and the last two elements give the lower-right corner of the area, in
+pixels. If no part of the entry given by index is visible on the
+screen then the result is an empty string; if the entry is partially
+visible, the result gives the only the visible area of the entry.
+
+=item I<$hlist>-E<gt>B<info>(B<children> ?,I<$entryPath>?)
+
+If I<$entryPath> is given, returns a list of the entryPath's of its
+children entries. Otherwise returns a list of the toplevel
+entryPath's.
+
+=item I<$hlist>-E<gt>B<info>(B<data> ?,I<$entryPath>?)
+
+Returns the data associated with I<$entryPath>.
+
+=item I<$hlist>-E<gt>B<info>(B<dragsite>)
+
+Returns the entryPath of the current dragsite, if any, of the HList
+widget. If the dragsite is not set, returns the empty string.
+
+=item I<$hlist>-E<gt>B<info>(B<dropsite>)
+
+Returns the entryPath of the current dropsite, if any, of the HList
+widget. If the dropsite is not set, returns the empty string.
+
+=item I<$hlist>-E<gt>B<info>(B<exists>, I<$entryPath>)
+
+Returns a boolean value indicating whether the list entry
+I<$entryPath> exists.
+
+=item I<$hlist>-E<gt>B<info>(B<hidden>, I<$entryPath>)
+
+Returns a boolean value indicating whether the list entry
+B<$entryPath> is hidden or not.
+
+=item I<$hlist>-E<gt>B<info>(B<next>, I<$entryPath>)
+
+Returns the entryPath of the list entry, if any, immediately below
+this list entry. If this entry is already at the bottom of the HList
+widget, returns an empty string.
+
+=item I<$hlist>-E<gt>B<info>(B<parent>, I<$entryPath>)
+
+Returns the name of the parent of the list entry identified by
+I<$entryPath>. If I<entryPath> is a toplevel list entry,
+returns the empty string.
+
+=item I<$hlist>-E<gt>B<info>(B<prev>, I<$entryPath>)
+
+Returns the entryPath of the list entry, if any, immediately above
+this list entry. If this entry is already at the top of the HList
+widget, returns an empty string.
+
+=item I<$hlist>-E<gt>B<info>(B<selection>)
+
+Returns a list of selected entries in the HList widget. In scalar
+context, returns an anonymous list of the selected entries.
+If no entries are selected, undef is returned in scalar context, and
+an empty list otherwise.
+
+=back
+
+=item I<$hlist>-E<gt>B<item>(I<option, >?I<args, ...>?)
+
+Creates and configures the display items at individual columns the
+entries. The form of additional of arguments depends on the choice of
+I<option>:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<itemCget>(I<$entryPath>, I<$col>, I<option>)
+
+Returns the current value of the configure I<option> of the display
+item at the column designated by I<$col> of the entry specified by
+I<$entryPath>.
+
+=item I<$hlist>-E<gt>B<itemConfigure>(I<$entryPath>, I<$col> ?,I<option>?, I<?value, option, value, ...>?)
+
+Query or modify the configuration options of the display item at the
+column designated by I<$col> of the entry specified by
+I<$entryPath>. If no I<option> is specified, returns a list
+describing all of the available options for I<$entryPath> (see
+L<Tk::options> for information on the format of this
+list). If I<option> is specified with no I<value>, then the
+method returns a list describing the one named option (this list will
+be identical to the corresponding sublist of the value returned if no
+I<option> is specified). If one or more I<option-value> pairs
+are specified, then the method modifies the given option(s) to have
+the given value(s); in this case the method returns an empty string.
+I<Option> may have any of the values accepted by the B<item>
+create method. The exact set of options depends on the
+value of the B<-itemtype> option passed to the the B<item>
+create method when this display item was created.
+
+=item I<$hlist>-E<gt>B<itemCreate>(I<$entryPath>, I<$col> ?,I<-itemtype>=E<gt>I<type>? ?,I<option value ...>?)
+
+Creates a new display item at the column designated by I<$col> of
+the entry specified by I<$entryPath>. An optional parameter
+I<-itemtype> can be used to specify what type of display items
+should be created. If the I<-itemtype> is not specified, then by
+default the type specified by this HList widget's B<-itemtype>
+option is used. Additional parameters, in I<option-value> pairs,
+can be passed to configure the appearance of the display item. Each
+I<option- value> pair must be a valid option for this type of
+display item.
+
+=item I<$hlist>-E<gt>B<itemDelete>(I<$entryPath>, I<$col>)
+
+Deletes the display item at the column designated by I<$col> of
+the entry specified by I<$entryPath>.
+
+=item I<$hlist>-E<gt>B<itemExists>(I<$entryPath>, I<$col>)
+
+Returns true if there is a display item at the column designated by
+I<$col> of the entry specified by I<$entryPath>; returns false
+otherwise.
+
+=back
+
+=item I<$hlist>-E<gt>B<nearest>(I<y>)
+
+I<$hlist>-E<gt>B<nearest>(I<y>)
+Given a y-coordinate within the HList window, this method returns
+the entryPath of the (visible) HList element nearest to that
+y-coordinate.
+
+=item I<$hlist>-E<gt>B<see>(I<$entryPath>)
+
+Adjust the view in the HList so that the entry given by I<$entryPath> is
+visible. If the entry is already visible then the method has no
+effect; if the entry is near one edge of the window then the HList
+scrolls to bring the element into view at the edge; otherwise the
+HList widget scrolls to center the entry.
+
+=item I<$hlist>-E<gt>B<selection>(I<option>, I<arg>, ...)
+
+=item I<$hlist>-E<gt>B<selection>I<Option>(I<arg>, ...)
+
+This method is used to adjust the selection within a HList widget. It
+has several forms, depending on I<option>:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<selectionClear>(?I<from>?, ?I<to>?)
+
+When no extra arguments are given, deselects all of the list entrie(s)
+in this HList widget. When only I<from> is given, only the list
+entry identified by I<from> is deselected. When both I<from> and
+I<to> are given, deselects all of the list entrie(s) between
+between I<from> and I<to>, inclusive, without affecting the
+selection state of elements outside that range.
+
+=item I<$hlist>-E<gt>B<selectionGet>
+
+This is an alias for the B<infoSelection> method.
+
+=item I<$hlist>-E<gt>B<selectionIncludes>(I<$entryPath>)
+
+Returns 1 if the list entry indicated by I<$entryPath> is currently
+selected; returns 0 otherwise.
+
+=item I<$hlist>-E<gt>B<selectionSet>(I<from>?, I<to>?)
+
+Selects all of the list entrie(s) between between I<from> and
+I<to>, inclusive, without affecting the selection state of entries
+outside that range. When only I<from> is given, only the list entry
+identified by I<from> is selected.
+
+=back
+
+=item I<$hlist>-E<gt>B<show>(I<option> ?,I<$entryPath>?)
+
+Show the entries that are hidden by the B<hide> method,
+I<option> can be one of the following:
+
+=over 8
+
+=item B<entry>
+
+Shows the list entry identified by I<$entryPath>.
+
+=back
+
+Currently only the B<entry> option is supported. Other options will
+be added in future releases.
+
+=item I<$hlist>-E<gt>B<xview>(I<args>)
+
+This method is used to query and change the horizontal position of the
+information in the widget's window. It can take any of the following
+forms:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<xview>
+
+Returns a list containing two elements. Each element is a real
+fraction between 0 and 1; together they describe the horizontal span
+that is visible in the window. For example, if the first element is
+.2 and the second element is .6, 20% of the HList entry is
+off-screen to the left, the middle 40% is visible in the window, and
+40% of the entry is off-screen to the right. These are the same values
+passed to scrollbars via the B<-xscrollcommand> option.
+
+=item I<$hlist>-E<gt>B<xview>(I<$entryPath>)
+
+Adjusts the view in the window so that the list entry identified by
+I<$entryPath> is aligned to the left edge of the window.
+
+=item I<$hlist>-E<gt>B<xview>(B<moveto> =E<gt> I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the total
+width of the HList is off-screen to the left. I<fraction> must be
+a fraction between 0 and 1.
+
+=item I<$hlist>-E<gt>B<xview>(B<scroll> =E<gt> I<number, what>)
+
+This method shifts the view in the window left or right according to
+I<number> and I<what>. I<Number> must be an integer.
+I<What> must be either B<units> or B<pages> or an
+abbreviation of one of these. If I<what> is B<units>, the view
+adjusts left or right by I<number> character units (the width of
+the B<0> character) on the display; if it is B<pages> then the
+view adjusts by I<number> screenfuls. If I<number> is negative
+then characters farther to the left become visible; if it is positive
+then characters farther to the right become visible.
+
+=back
+
+=item I<$hlist>-E<gt>B<yview>(I<?args>?)
+
+This method is used to query and change the vertical position of the
+entries in the widget's window. It can take any of the following forms:
+
+=over 8
+
+=item I<$hlist>-E<gt>B<yview>
+
+Returns a list containing two elements, both of which are real
+fractions between 0 and 1. The first element gives the position of
+the list element at the top of the window, relative to the HList as a
+whole (0.5 means it is halfway through the HList, for example). The
+second element gives the position of the list entry just after the
+last one in the window, relative to the HList as a whole. These are
+the same values passed to scrollbars via the B<-yscrollcommand>
+option.
+
+=item I<$hlist>-E<gt>B<yview>(I<$entryPath>)
+
+Adjusts the view in the window so that the list entry given by
+I<$entryPath> is displayed at the top of the window.
+
+=item I<$hlist>-E<gt>B<yview>(B<moveto> =E<gt> I<fraction>)
+
+Adjusts the view in the window so that the list entry given by
+I<fraction> appears at the top of the window. I<Fraction> is a
+fraction between 0 and 1; 0 indicates the first entry in the
+HList, 0.33 indicates the entry one-third the way through the
+HList, and so on.
+
+=item I<$hlist>-E<gt>B<yview>(B<scroll> =E<gt> I<number, what>)
+
+This method adjust the view in the window up or down according to
+I<number> and I<what>. I<Number> must be an integer.
+I<What> must be either B<units> or B<pages>. If I<what>
+is B<units>, the view adjusts up or down by I<number> lines; if
+it is B<pages> then the view adjusts by I<number> screenfuls.
+If I<number> is negative then earlier entries become visible; if
+it is positive then later entries become visible.
+
+=back
+
+=back
+
+=head1 BINDINGS
+
+=over 4
+
+=item [1]
+
+If the B<-selectmode> is "browse", when the user drags the mouse
+pointer over the list entries, the entry under the pointer will be
+highlighted and the B<-browsecmd> callback will be called with
+one parameter, the entryPath of the highlighted entry. Only one entry
+can be highlighted at a time. The B<-command> callback will be
+called when the user double-clicks on a list entry.
+
+=item [2]
+
+If the B<-selectmode> is "single", the entries will only be
+highlighted by mouse E<lt>ButtonRelease-1E<gt> events. When a new list entry
+is highlighted, the B<-browsecmd> callback will be called with
+one parameter indicating the highlighted list entry. The
+B<-command> callback will be called when the user double-clicks
+on a list entry.
+
+=item [3]
+
+If the B<-selectmode> is "multiple", when the user drags the mouse
+pointer over the list entries, all the entries under the pointer will
+be highlighted. However, only a contiguous region of list entries can
+be selected. When the highlighted area is changed, the
+B<-browsecmd> callback will be called with an undefined
+parameter. It is the responsibility of the B<-browsecmd> callback
+to find out the exact highlighted selection in the HList. The
+B<-command> callback will be called when the user double-clicks
+on a list entry.
+
+=item [4]
+
+If the B<-selectmode> is "extended", when the user drags the mouse
+pointer over the list entries, all the entries under the pointer will
+be highlighted. The user can also make disjointed selections using
+E<lt>Control-ButtonPress-1E<gt>. When the highlighted area is changed, the
+B<-browsecmd> callback will be called with an undefined
+parameter. It is the responsibility of the B<-browsecmd> callback
+to find out the exact highlighted selection in the HList. The
+B<-command> callback will be called when the user double-clicks
+on a list entry.
+
+=item [5]
+
+B<Arrow key bindings:> E<lt>UpE<gt> arrow key moves the anchor point to the
+item right on top of the current anchor item. E<lt>DownE<gt> arrow key moves
+the anchor point to the item right below the current anchor item.
+E<lt>LeftE<gt> arrow key moves the anchor to the parent item of the current
+anchor item. E<lt>RightE<gt> moves the anchor to the first child of the
+current anchor item. If the current anchor item does not have any
+children, moves the anchor to the item right below the current anchor
+item.
+
+=back
+
+=head1 EXAMPLE
+
+This example demonstrates how to use an HList to store a file
+directory structure and respond to the user's browse events:
+
+ use strict;
+ use Tk;
+ use Tk::Label;
+ use Tk::HList;
+
+ my $mw = MainWindow->new();
+ my $label = $mw->Label(-width=>15);
+ my $hlist = $mw->HList(
+ -itemtype => 'text',
+ -separator => '/',
+ -selectmode => 'single',
+ -browsecmd => sub {
+ my $file = shift;
+ $label->configure(-text=>$file);
+ }
+ );
+
+ foreach ( qw(/ /home /home/ioi /home/foo /usr /usr/lib) ) {
+ $hlist->add($_, -text=>$_);
+ }
+
+ $hlist->pack;
+ $label->pack;
+
+ MainLoop;
+
+=head1 BUGS
+
+The fact that the display item at column 0 is implicitly associated
+with the whole entry is probably a design bug. This was done for
+backward compatibility purposes. The result is that there is a large
+overlap between the B<item> method and the B<add>,
+B<addchild>, B<entrycget> and B<entryconfigure>
+methods. Whenever multiple columns exist, the programmer should use
+ONLY the B<item> method to create and configure the display items
+in each column; the B<add>, B<addchild>, B<entrycget> and
+B<entryconfigure> should be used ONLY to create and configure
+entries.
+
+=head1 KEYWORDS
+
+Hierarchical Listbox
+
+=head1 SEE ALSO
+
+L<Tk::DItem|Tk::DItem>
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/IO.pm b/Master/tlpkg/tlperl.straw/lib/Tk/IO.pm
new file mode 100755
index 00000000000..771e9f7103a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/IO.pm
@@ -0,0 +1,182 @@
+package Tk::IO;
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/IO/IO.pm#4 $
+
+require 5.002;
+use Tk::Event qw($XS_VERSION);
+
+use Carp;
+use base qw(DynaLoader IO::Handle);
+
+bootstrap Tk::IO;
+
+my %fh2obj;
+my %obj2fh;
+
+sub new
+{
+ my ($package,%args) = @_;
+ # Do whatever IO::Handle does
+ my $fh = $package->SUPER::new;
+ %{*$fh} = (); # The hash is used for configure options
+ ${*$fh} = ''; # The scalar is used as the 'readable' buffer
+ @{*$fh} = (); # The array
+ $fh->configure(%args);
+ return $fh;
+}
+
+sub pending
+{
+ my $fh = shift;
+ return ${*$fh};
+}
+
+sub cget
+{
+ my ($fh,$key) = @_;
+ return ${*$fh}{$key};
+}
+
+sub configure
+{
+ my ($fh,%args) = @_;
+ my $key;
+ foreach $key (keys %args)
+ {
+ my $val = $args{$key};
+ $val = Tk::Callback->new($val) if ($key =~ /command$/);
+ ${*$fh}{$key} = $val;
+ }
+}
+
+sub killpg
+{
+ my ($fh,$sig) = @_;
+ my $pid = $fh->pid;
+ croak 'No child' unless (defined $pid);
+ kill($sig,-$pid);
+}
+
+sub kill
+{
+ my ($fh,$sig) = @_;
+ my $pid = $fh->pid;
+ croak 'No child' unless (defined $pid);
+ kill($sig,$pid) || croak "Cannot kill($sig,$pid):$!";
+}
+
+sub readable
+{
+ my $fh = shift;
+ my $count = sysread($fh,${*$fh},1,length(${*$fh}));
+ if ($count < 0)
+ {
+ if (exists ${*$fh}{-errorcommand})
+ {
+ ${*$fh}{-errorcommand}->Call($!);
+ }
+ else
+ {
+ warn "Cannot read $fh:$!";
+ $fh->close;
+ }
+ }
+ elsif ($count)
+ {
+ if (exists ${*$fh}{-linecommand})
+ {
+ my $eol = index(${*$fh},"\n");
+ if ($eol >= 0)
+ {
+ my $line = substr(${*$fh},0,++$eol);
+ substr(${*$fh},0,$eol) = '';
+ ${*$fh}{-linecommand}->Call($line);
+ }
+ }
+ }
+ else
+ {
+ $fh->close;
+ }
+}
+
+sub pid
+{
+ my $fh = shift;
+ return ${*$fh}{-pid};
+}
+
+sub command
+{
+ my $fh = shift;
+ my $cmd = ${*$fh}{'-exec'};
+ return (wantarray) ? @$cmd : $cmd;
+}
+
+sub exec
+{
+ my $fh = shift;
+ my $pid = open($fh,'-|');
+ if ($pid)
+ {
+ ${*$fh} = '' unless (defined ${*$fh});
+ ${*$fh}{'-exec'} = [@_];
+ ${*$fh}{'-pid'} = $pid;
+ if (exists ${*$fh}{-linecommand})
+ {
+ my $w = ${*$fh}{-widget};
+ $w = 'Tk' unless (defined $w);
+ $w->fileevent($fh,'readable',[$fh,'readable']);
+ ${*$fh}{_readable} = $w;
+ }
+ else
+ {
+ croak Tk::Pretty::Pretty(\%{*$fh});
+ }
+ return $pid;
+ }
+ else
+ {
+ # make STDERR same as STDOUT here
+ setpgrp;
+ exec(@_) || die 'Cannot exec ',join(' ',@_),":$!";
+ }
+}
+
+sub wait
+{
+ my $fh = shift;
+ my $code;
+ my $ch = delete ${*$fh}{-childcommand};
+ ${*$fh}{-childcommand} = Tk::Callback->new(sub { $code = shift });
+ Tk::Event::DoOneEvent(0) until (defined $code);
+ if (defined $ch)
+ {
+ ${*$fh}{-childcommand} = $ch;
+ $ch->Call($code,$fh)
+ }
+ return $code;
+}
+
+sub close
+{
+ my $fh = shift;
+ my $code;
+ if (defined fileno($fh))
+ {
+ my $w = delete ${*$fh}{_readable};
+ $w->fileevent($fh,'readable','') if (defined $w);
+ $code = close($fh);
+ if (exists ${*$fh}{-childcommand})
+ {
+ ${*$fh}{-childcommand}->Call($?,$fh);
+ }
+ }
+ return $code;
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/IO.pod b/Master/tlpkg/tlperl.straw/lib/Tk/IO.pod
new file mode 100755
index 00000000000..2781d2e17e6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/IO.pod
@@ -0,0 +1,51 @@
+
+=head1 NAME
+
+Tk::IO - high level interface to Tk's 'fileevent' mechanism
+
+=for pm IO/IO.pm
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+ my $fh = Tk::IO->new(-linecommand => callback, -childcommand => callback);
+ $fh->exec("command")
+ $fh->wait
+ $fh->kill
+
+=head1 WARNING
+
+INTERFACES TO THIS MODULE MAY CHANGE AS PERL'S IO EVOLVES
+AND WITH PORT OF TK4.1
+
+=head1 DESCRIPTION
+
+Tk::IO is now layered on perl's IO::Handle class. Interfaces
+have changed, and are still evolving.
+
+In theory C methods which enable non-blocking IO as in earlier Tk-b*
+release(s) are still there. I have not changed them to use perl's
+additional Configure information, or tested them much.
+
+Assumption is that B<exec> is
+used to fork a child process and a callback is called each time a
+complete line arrives up the implied pipe.
+
+"line" should probably be defined in terms of perl's input record
+separator but is not yet.
+
+The -childcommand callback is called when end-of-file occurs.
+
+$fh->B<wait> can be used to wait for child process while processing
+other Tk events.
+
+$fh->B<kill> can be used to send signal to child process.
+
+=head1 BUGS
+
+Still not finished.
+Idea is to use "exec" to emulate "system" in a non-blocking manner.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/IconList.pm b/Master/tlpkg/tlperl.straw/lib/Tk/IconList.pm
new file mode 100755
index 00000000000..1972809ea2a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/IconList.pm
@@ -0,0 +1,712 @@
+# -*- perl -*-
+#
+# tkfbox.tcl --
+#
+# Implements the "TK" standard file selection dialog box. This
+# dialog box is used on the Unix platforms whenever the tk_strictMotif
+# flag is not set.
+#
+# The "TK" standard file selection dialog box is similar to the
+# file selection dialog box on Win95(TM). The user can navigate
+# the directories by clicking on the folder icons or by
+# selectinf the "Directory" option menu. The user can select
+# files by clicking on the file icons or by entering a filename
+# in the "Filename:" entry.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Translated to perk/Tk and modified by Slaven Rezic <slaven@rezic.de>.
+#
+
+#----------------------------------------------------------------------
+#
+# I C O N L I S T
+#
+# This is a pseudo-widget that implements the icon list inside the
+# tkFDialog dialog box.
+#
+#----------------------------------------------------------------------
+# tkIconList --
+#
+# Creates an IconList widget.
+#
+
+package Tk::IconList;
+require Tk::Frame;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/IconList.pm#7 $
+
+use Tk qw(Ev);
+use strict;
+use Carp;
+
+use base 'Tk::Frame';
+
+Construct Tk::Widget 'IconList';
+
+# tkIconList_Create --
+#
+# Creates an IconList widget by assembling a canvas widget and a
+# scrollbar widget. Sets all the bindings necessary for the IconList's
+# operations.
+#
+sub Populate {
+ my($w, $args) = @_;
+ $w->SUPER::Populate($args);
+
+ my $sbar = $w->Component('Scrollbar' => 'sbar',
+ -orient => 'horizontal',
+ -highlightthickness => 0,
+ -takefocus => 0,
+ );
+ # make sure that the size does not exceed handhelds' dimensions
+ my($sw,$sh) = ($w->screenwidth, $w->screenheight);
+ my $canvas = $w->Component('Canvas' => 'canvas',
+ -bd => 2,
+ -relief => 'sunken',
+ -width => ($sw > 420 ? 400 : $sw-20),
+ -height => ($sh > 160 ? 120 : $sh-40),
+ -takefocus => 1,
+ );
+ $sbar->pack(-side => 'bottom', -fill => 'x', -padx => 2);
+ $canvas->pack(-expand => 'yes', -fill => 'both');
+ $sbar->configure(-command => ['xview', $canvas]);
+ $canvas->configure(-xscrollcommand => ['set', $sbar]);
+
+ # Initializes the max icon/text width and height and other variables
+ $w->{'maxIW'} = 1;
+ $w->{'maxIH'} = 1;
+ $w->{'maxTW'} = 1;
+ $w->{'maxTH'} = 1;
+ $w->{'numItems'} = 0;
+#XXX curItem never used delete $w->{'curItem'};
+ $w->{'noScroll'} = 1;
+ $w->{'selection'} = [];
+ $w->{'index,anchor'} = '';
+
+ # Creates the event bindings.
+ $canvas->Tk::bind('<Configure>', sub { $w->Arrange } );
+ $canvas->Tk::bind('<1>', [$w,'Btn1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<B1-Motion>', [$w,'Motion1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Control-B1-Motion>', 'NoOp');
+ $canvas->Tk::bind('<Shift-B1-Motion>', 'NoOp');
+ $canvas->Tk::bind('<Control-1>', [$w,'CtrlBtn1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Shift-1>', [$w,'ShiftBtn1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Double-ButtonRelease-1>', [$w,'Double1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Control-Double-ButtonRelease-1>', 'NoOp');
+ $canvas->Tk::bind('<Shift-Double-ButtonRelease-1>', 'NoOp');
+ $canvas->Tk::bind('<ButtonRelease-1>', [$w,'CancelRepeat']);
+ $canvas->Tk::bind('<B1-Leave>', [$w,'Leave1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<B1-Enter>', [$w,'CancelRepeat']);
+ $canvas->Tk::bind('<Up>', [$w,'UpDown', -1]);
+ $canvas->Tk::bind('<Down>', [$w,'UpDown', 1]);
+ $canvas->Tk::bind('<Left>', [$w,'LeftRight',-1]);
+ $canvas->Tk::bind('<Right>', [$w,'LeftRight', 1]);
+ $canvas->Tk::bind('<Return>', [$w,'ReturnKey']);
+ $canvas->Tk::bind('<KeyPress>', [$w,'KeyPress',Ev('A')]);
+ $canvas->Tk::bind('<Control-KeyPress>', 'NoOp');
+ $canvas->Tk::bind('<Alt-KeyPress>', 'NoOp');
+ $canvas->Tk::bind('<Meta-KeyPress>', 'NoOp');
+#XXX bad....
+# $canvas->Tk::bind('<FocusIn>', sub { $w->FocusIn });
+# $canvas->Tk::bind('<FocusOut>', sub { $w->FocusOut });
+
+ # additional bindings not in tkfbox.tcl
+ $canvas->Tk::bind('<2>',['scan','mark',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
+ # Remove the standard Canvas bindings
+ $canvas->bindtags([$canvas, $canvas->toplevel, 'all']);
+ # ... and define some again
+ $canvas->Tk::bind('<Home>', ['xview','moveto',0]);
+ $canvas->Tk::bind('<End>', ['xview','moveto',1]);
+
+ $w->ConfigSpecs(-browsecmd =>
+ ['METHOD', 'browseCommand', 'BrowseCommand', undef],
+ -command =>
+ ['CALLBACK', 'command', 'Command', undef],
+ -font =>
+ ['PASSIVE', 'font', 'Font', undef],
+ -foreground =>
+ ['PASSIVE', 'foreground', 'Foreground', undef],
+ -fg => '-foreground',
+ -multiple =>
+ ['PASSIVE', 'multiple', 'Multiple', 0],
+ -selectmode =>
+ ['PASSIVE', 'selectMode', 'SelectMode', 'browse'],
+ -selectbackground =>
+ ['PASSIVE', 'selectBackground', 'Foreground', '#a0a0ff'],
+ );
+
+ $w;
+}
+
+# compatibility for old -browsecmd options
+sub browsecmd {
+ my $w = shift;
+ if (@_) {
+ $w->{Configure}{'-browsecmd'} = $_[0];
+ $w->bind('<<ListboxSelect>>' => $_[0]);
+ }
+ $w->{Configure}{'-browsecmd'};
+}
+
+sub Index {
+ my($w, $i) = @_;
+ if (!$w->{'list'}) { $w->{'list'} = [] }
+ if ($i =~ /^-?[0-9]+$/) {
+ if ($i < 0) {
+ $i = 0;
+ }
+ if ($i > @{ $w->{'list'} }) {
+ $i = @{ $w->{'list'} } - 1;
+ }
+ return $i;
+ } elsif ($i eq 'active') {
+ return $w->{'index,active'};
+ } elsif ($i eq 'anchor') {
+ return $w->{'index,anchor'};
+ } elsif ($i eq 'end') {
+ return @{ $w->{'list'} };
+ } elsif ($i =~ /@(-?[0-9]+),(-?[0-9]+)/) {
+ my($x, $y) = ($1, $2);
+ my $canvas = $w->Subwidget('canvas');
+ my $item = $canvas->find('closest', $x, $y);
+ if (defined $item) {
+ return $canvas->itemcget($item, '-tags')->[1];
+ } else {
+ return "";
+ }
+ } else {
+ croak "Unrecognized Index parameter `$i', use active, anchor, end, \@x,y, or x";
+ }
+}
+
+sub Selection {
+ my($w, $op, @args) = @_;
+ if ($op eq 'anchor') {
+ if (@args == 1) {
+ $w->{'index,anchor'} = $w->Index($args[0]);
+ } else {
+ return $w->{'index,anchor'};
+ }
+ } elsif ($op eq 'clear') {
+ my($first, $last);
+ if (@args == 2) {
+ ($first, $last) = @args;
+ } elsif (@args == 1) {
+ $first = $last = $args[0];
+ } else {
+ croak "wrong # args: should be Selection('clear', first, ?last?)"
+ }
+ $first = $w->Index($first);
+ $last = $w->Index($last);
+ if ($first > $last) {
+ ($first, $last) = ($last, $first);
+ }
+ my $ind = 0;
+ for my $item (@{ $w->{'selection'} }) {
+ if ($item >= $first) {
+ $first = $ind;
+ last;
+ }
+ $ind++; # XXX seems to be missing in the Tcl version
+ }
+ $ind = @{ $w->{'selection'} } - 1;
+ for(; $ind >= 0; $ind--) {
+ my $item = $w->{'selection'}->[$ind];
+ if ($item <= $last) {
+ $last = $ind;
+ last;
+ }
+ }
+ if ($first > $last) {
+ return;
+ }
+ splice @{ $w->{'selection'} }, $first, $last-$first+1;
+ $w->event('generate', '<<ListboxSelect>>');
+ $w->DrawSelection;
+ } elsif ($op eq 'includes') {
+ my $index;
+ for (@{ $w->{'selection'} }) {
+ if ($args[0] eq $_) {
+ return 1;
+ }
+ }
+ return 0;
+ } elsif ($op eq 'set') {
+ my($first, $last);
+ if (@args == 2) {
+ ($first, $last) = @args;
+ } elsif (@args == 1) {
+ $first = $last = $args[0];
+ } else {
+ croak "wrong # args: should be Selection('set', first, ?last?)";
+ }
+
+ $first = $w->Index($first);
+ $last = $w->Index($last);
+ if ($first > $last) {
+ ($first, $last) = ($last, $first);
+ }
+ for(my $i = $first; $i <= $last; $i++) {
+ push @{ $w->{'selection'} }, $i;
+ }
+ # lsort -integer -unique
+ my %sel = map { ($_ => 1) } @{ $w->{'selection'} };
+ @{ $w->{'selection'} } = sort { $a <=> $b } keys %sel;
+ $w->event('generate', '<<ListboxSelect>>');
+ $w->DrawSelection;
+ } else {
+ croak "Unrecognized Selection parameter `$op', use anchor, clear, includes, or set";
+ }
+}
+
+# XXX why lower case 's' here and upper in DrawSelection?
+sub Curselection {
+ my $w = shift;
+ @{ $w->{'selection'} };
+}
+
+sub DrawSelection {
+ my $w = shift;
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->delete('selection');
+ my $selBg = $w->cget('-selectbackground');
+ for my $item (@{ $w->{'selection'} }) {
+ my $rTag = $w->{'list'}->[$item][2];
+ my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
+ my @bbox = $canvas->bbox($tTag);
+ # XXX don't hardcode colors
+ $canvas->createRectangle
+ (@bbox, -fill => $selBg, -outline => $selBg, -tags => 'selection');
+ }
+ $canvas->lower('selection');
+}
+
+# Returns the selected item
+#
+sub Get {
+ my($w, $item) = @_;
+ my $rTag = $w->{'list'}->[$item][2];
+ my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
+ $text;
+}
+
+
+# tkIconList_AutoScan --
+#
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The IconList window.
+#
+sub AutoScan {
+ my $w = shift;
+ return unless ($w->exists);
+ return if ($w->{'noScroll'});
+ my($x, $y);
+ $x = $Tk::x;
+ $y = $Tk::y;
+ my $canvas = $w->Subwidget('canvas');
+ if ($x >= $canvas->width) {
+ $canvas->xview('scroll', 1, 'units');
+ } elsif ($x < 0) {
+ $canvas->xview('scroll', -1, 'units');
+ } elsif ($y >= $canvas->height) {
+ # do nothing
+ } elsif ($y < 0) {
+ # do nothing
+ } else {
+ return;
+ }
+ $w->Motion1($x, $y);
+ $w->RepeatId($w->after(50, ['AutoScan', $w]));
+}
+
+# Deletes all the items inside the canvas subwidget and reset the IconList's
+# state.
+#
+sub DeleteAll {
+ my $w = shift;
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->delete('all');
+ delete $w->{'selected'};
+ delete $w->{'rect'};
+ delete $w->{'list'};
+ delete $w->{'itemList'};
+ $w->{'maxIW'} = 1;
+ $w->{'maxIH'} = 1;
+ $w->{'maxTW'} = 1;
+ $w->{'maxTH'} = 1;
+ $w->{'numItems'} = 0;
+#XXX curItem never used delete $w->{'curItem'};
+ $w->{'noScroll'} = 1;
+ $w->{'selection'} = [];
+ $w->{'index,anchor'} = '';
+ $w->Subwidget('sbar')->set(0.0, 1.0);
+ $canvas->xview('moveto', 0);
+}
+
+# Adds an icon into the IconList with the designated image and items
+#
+sub Add {
+ my($w, $image, @items) = @_;
+ my $canvas = $w->Subwidget('canvas');
+ my $font = $w->cget(-font);
+ my $fg = $w->cget(-foreground);
+ foreach my $text (@items) {
+ my $iTag = $canvas->createImage
+ (0, 0, -image => $image, -anchor => 'nw',
+ -tags => ['icon', $w->{numItems}, 'item'.$w->{numItems}],
+ );
+ my $tTag = $canvas->createText
+ (0, 0, -text => $text, -anchor => 'nw',
+ (defined $fg ? (-fill => $fg) : ()),
+ (defined $font ? (-font => $font) : ()),
+ -tags => ['text', $w->{numItems}, 'item'.$w->{numItems}],
+ );
+ my $rTag = $canvas->createRectangle
+ (0, 0, 0, 0,
+ -fill => undef,
+ -outline => undef,
+ -tags => ['rect', $w->{numItems}, 'item'.$w->{numItems}],
+ );
+ my(@b) = $canvas->bbox($iTag);
+ my $iW = $b[2] - $b[0];
+ my $iH = $b[3] - $b[1];
+ $w->{'maxIW'} = $iW if ($w->{'maxIW'} < $iW);
+ $w->{'maxIH'} = $iH if ($w->{'maxIH'} < $iH);
+ @b = $canvas->bbox($tTag);
+ my $tW = $b[2] - $b[0];
+ my $tH = $b[3] - $b[1];
+ $w->{'maxTW'} = $tW if ($w->{'maxTW'} < $tW);
+ $w->{'maxTH'} = $tH if ($w->{'maxTH'} < $tH);
+ push @{ $w->{'list'} }, [$iTag, $tTag, $rTag, $iW, $iH, $tW, $tH,
+ $w->{'numItems'}];
+ $w->{'itemList'}{$rTag} = [$iTag, $tTag, $text, $w->{'numItems'}];
+ $w->{'textList'}{$w->{'numItems'}} = lc($text);
+ ++$w->{'numItems'};
+ }
+}
+
+# Places the icons in a column-major arrangement.
+#
+sub Arrange {
+ my $w = shift;
+ my $canvas = $w->Subwidget('canvas');
+ my $sbar = $w->Subwidget('sbar');
+ unless (exists $w->{'list'}) {
+ if (defined $canvas && Tk::Exists($canvas)) {
+ $w->{'noScroll'} = 1;
+ $sbar->configure(-command => sub { });
+ }
+ return;
+ }
+
+ my $W = $canvas->width;
+ my $H = $canvas->height;
+ my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
+ $pad = 2 if ($pad < 2);
+ $W -= $pad*2;
+ $H -= $pad*2;
+ my $dx = $w->{'maxIW'} + $w->{'maxTW'} + 8;
+ my $dy;
+ if ($w->{'maxTH'} > $w->{'maxIH'}) {
+ $dy = $w->{'maxTH'};
+ } else {
+ $dy = $w->{'maxIH'};
+ }
+ $dy += 2;
+ my $shift = $w->{'maxIW'} + 4;
+ my $x = $pad * 2;
+ my $y = $pad;
+ my $usedColumn = 0;
+ foreach my $sublist (@{ $w->{'list'} }) {
+ $usedColumn = 1;
+ my($iTag, $tTag, $rTag, $iW, $iH, $tW, $tH) = @$sublist;
+ my $i_dy = ($dy - $iH) / 2;
+ my $t_dy = ($dy - $tH) / 2;
+ $canvas->coords($iTag, $x, $y + $i_dy);
+ $canvas->coords($tTag, $x + $shift, $y + $t_dy);
+ $canvas->coords($rTag, $x, $y, $x + $dx, $y + $dy);
+ $y += $dy;
+ if ($y + $dy > $H) {
+ $y = $pad;
+ $x += $dx;
+ $usedColumn = 0;
+ }
+ }
+ my $sW;
+ if ($usedColumn) {
+ $sW = $x + $dx;
+ } else {
+ $sW = $x;
+ }
+ if ($sW < $W) {
+ $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
+ $sbar->configure(-command => sub { });
+ $canvas->xview(moveto => 0);
+ $w->{'noScroll'} = 1;
+ } else {
+ $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
+ $sbar->configure(-command => ['xview', $canvas]);
+ $w->{'noScroll'} = 0;
+ }
+ $w->{'itemsPerColumn'} = int(($H - $pad) / $dy);
+ $w->{'itemsPerColumn'} = 1 if ($w->{'itemsPerColumn'} < 1);
+#XXX $w->Select($w->{'list'}[$w->{'curItem'}][2], 0)
+# if (exists $w->{'curItem'});
+ $w->DrawSelection; # missing in Tcl XXX
+}
+
+# Gets called when the user invokes the IconList (usually by double-clicking
+# or pressing the Return key).
+#
+sub Invoke {
+ my $w = shift;
+ $w->Callback(-command => $w->{'selected'}) if (@{ $w->{'selection'} });
+}
+
+# tkIconList_See --
+#
+# If the item is not (completely) visible, scroll the canvas so that
+# it becomes visible.
+sub See {
+ my($w, $rTag) = @_;
+ return if ($w->{'noScroll'});
+ return if ($rTag < 0 || $rTag >= @{ $w->{'list'} });
+ my $canvas = $w->Subwidget('canvas');
+ my(@sRegion) = @{ $canvas->cget('-scrollregion') };
+ return unless (@sRegion);
+ my(@bbox) = $canvas->bbox('item'.$rTag);
+ my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
+ my $x1 = $bbox[0];
+ my $x2 = $bbox[2];
+ $x1 -= $pad * 2;
+ $x2 -= $pad;
+ my $cW = $canvas->width - $pad * 2;
+ my $scrollW = $sRegion[2] - $sRegion[0] + 1;
+ my $dispX = int(($canvas->xview)[0] * $scrollW);
+ my $oldDispX = $dispX;
+ # check if out of the right edge
+ $dispX = $x2 - $cW if ($x2 - $dispX >= $cW);
+ # check if out of the left edge
+ $dispX = $x1 if ($x1 - $dispX < 0);
+ if ($oldDispX != $dispX) {
+ my $fraction = $dispX / $scrollW;
+ $canvas->xview('moveto', $fraction);
+ }
+}
+
+sub Btn1 {
+ my($w, $x, $y) = @_;
+
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ $x = int($canvas->canvasx($x));
+ $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+}
+
+sub CtrlBtn1 {
+ my($w, $x, $y) = @_;
+
+ if ($w->cget(-multiple)) {
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ my $x = int($canvas->canvasx($x));
+ my $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ if ($w->Selection('includes', $i)) {
+ $w->Selection('clear', $i);
+ } else {
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+ }
+ }
+}
+
+sub ShiftBtn1 {
+ my($w, $x, $y) = @_;
+
+ if ($w->cget(-multiple)) {
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ my $x = int($canvas->canvasx($x));
+ my $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ my $a = $w->Index('anchor');
+ if ($a eq '') {
+ $a = $i;
+ }
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $a, $i);
+ }
+}
+
+# Gets called on button-1 motions
+#
+sub Motion1 {
+ my($w, $x, $y) = @_;
+ $Tk::x = $x;
+ $Tk::y = $y;
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ $x = int($canvas->canvasx($x));
+ $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+}
+
+sub Double1 {
+ my($w, $x, $y) = @_;
+ $w->Invoke if (@{ $w->{'selection'} });
+}
+
+sub ReturnKey {
+ my $w = shift;
+ $w->Invoke;
+}
+
+sub Leave1 {
+ my($w, $x, $y) = @_;
+ $Tk::x = $x;
+ $Tk::y = $y;
+ $w->AutoScan;
+}
+
+sub FocusIn {
+ my $w = shift;
+ return unless (exists $w->{'list'});
+ if (@{ $w->{'selection'} }) {
+ $w->DrawSelection;
+ }
+}
+
+sub FocusOut {
+ my $w = shift;
+ $w->Selection('clear', 0, 'end');
+}
+
+# tkIconList_UpDown --
+#
+# Moves the active element up or down by one element
+#
+# Arguments:
+# w - The IconList widget.
+# amount - +1 to move down one item, -1 to move back one item.
+#
+sub UpDown {
+ my($w, $amount) = @_;
+ return unless (exists $w->{'list'});
+ my $i;
+ my(@curr) = $w->Curselection;
+ if (!@curr) {
+ $i = 0;
+ } else {
+ $i = $w->Index('anchor');
+ return if ($i eq '');
+ $i += $amount;
+ }
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+ $w->See($i);
+}
+
+# tkIconList_LeftRight --
+#
+# Moves the active element left or right by one column
+#
+# Arguments:
+# w - The IconList widget.
+# amount - +1 to move right one column, -1 to move left one column.
+#
+sub LeftRight {
+ my($w, $amount) = @_;
+ return unless (exists $w->{'list'});
+ my $i;
+ my(@curr) = $w->Curselection;
+ if (!@curr) {
+ $i = 0;
+ } else {
+ $i = $w->Index('anchor');
+ return if ($i eq '');
+ $i += $amount*$w->{'itemsPerColumn'};
+ }
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+ $w->See($i);
+}
+
+#----------------------------------------------------------------------
+# Accelerator key bindings
+#----------------------------------------------------------------------
+# tkIconList_KeyPress --
+#
+# Gets called when user enters an arbitrary key in the listbox.
+#
+sub KeyPress {
+ my($w, $key) = @_;
+ $w->{'_ILAccel'} .= $key;
+ $w->Goto($w->{'_ILAccel'});
+ eval {
+ $w->afterCancel($w->{'_ILAccel_afterid'});
+ };
+ $w->{'_ILAccel_afterid'} = $w->after(500, ['Reset', $w]);
+}
+
+sub Goto {
+ my($w, $text) = @_;
+ return unless (exists $w->{'list'});
+ return if (not defined $text or $text eq '');
+#XXX curItem never used my $start = (!exists $w->{'curItem'} ? 0 : $w->{'curItem'});
+ my $start = 0;
+ $text = lc($text);
+ my $theIndex = -1;
+ my $less = 0;
+ my $len = length($text);
+ my $i = $start;
+ # Search forward until we find a filename whose prefix is an exact match
+ # with $text
+ while (1) {
+ my $sub = substr($w->{'textList'}{$i}, 0, $len);
+ if ($text eq $sub) {
+ $theIndex = $i;
+ last;
+ }
+ ++$i;
+ $i = 0 if ($i == $w->{'numItems'});
+ last if ($i == $start);
+ }
+ if ($theIndex > -1) {
+ $w->Selection(qw(clear 0 end));
+ $w->Selection('set', $theIndex);
+ $w->Selection('anchor', $theIndex);
+ $w->See($theIndex);
+ }
+}
+
+sub Reset {
+ my $w = shift;
+ undef $w->{'_ILAccel'};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/IconList.pod b/Master/tlpkg/tlperl.straw/lib/Tk/IconList.pod
new file mode 100755
index 00000000000..e68324ce4b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/IconList.pod
@@ -0,0 +1,82 @@
+=head1 NAME
+
+Tk::IconList - an icon list widget
+
+=for pm Tk/IconList.pm
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::IconList;
+ $il = $mw->IconList(-browsecmd => sub { ... },
+ -command => sub { ... })->pack;
+ $il->Add($icon1, $text1);
+ $il->Add($icon2, $text2);
+ $il->Arrange;
+ ...
+ $il->DeleteAll;
+
+=head1 DESCRIPTION
+
+=head2 OPTIONS
+
+=over
+
+=item -browsecmd
+
+=item -command
+
+=item -font
+
+-item -foreground|-fg
+
+=back
+
+=head2 METHODS
+
+=over 4
+
+=item DeleteAll
+
+Deletes all the items inside the canvas subwidget and reset the IconList's
+state.
+
+=item Add($image, $text)
+
+Adds an icon into the IconList with the designated image and text.
+
+=item Arrange
+
+Places the icons in a column-major arrangement.
+
+=item Get
+
+Return the selected item.
+
+=item Invoke
+
+Gets called when the user invokes the IconList (usually by double-clicking
+or pressing the Return key) (internal method).
+
+=item See($tag)
+
+If the item is not (completely) visible, scroll the canvas so that it
+becomes visible (internal method).
+
+=back
+
+=head1 COPYRIGHT
+
+The original tkfbox.tcl from Tcl/Tk is:
+
+Copyright (c) 1994-1996 Sun Microsystems, Inc.
+
+See the file "license.terms" for information on usage and redistribution
+of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+Translated to Perl/Tk by Slaven Rezic <srezic@cpan.org>.
+
+=head1 SEE ALSO
+
+L<Tk::FBox>.
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Image.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Image.pm
new file mode 100755
index 00000000000..0f41c387fc2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Image.pm
@@ -0,0 +1,74 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Image;
+
+# This module does for images what Tk::Widget does for widgets:
+# provides a base class for them to inherit from.
+require DynaLoader;
+
+use base qw(DynaLoader Tk); # but are they ?
+
+use vars qw($VERSION);
+$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ $package->InitClass($widget);
+ my $leaf = $package->Tk_image;
+ my $obj = $widget->Tk::image('create',$leaf,@_);
+ $obj = $widget->_object($obj) unless (ref $obj);
+ return bless $obj,$package;
+}
+
+sub Install
+{
+ # Dynamically loaded image types can install standard images here
+ my ($class,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+require Tk::Submethods;
+
+Direct Tk::Submethods ('image' => [qw(delete width height type)]);
+
+sub Tk::Widget::imageNames
+{
+ my $w = shift;
+ $w->image('names',@_);
+}
+
+sub Tk::Widget::imageTypes
+{
+ my $w = shift;
+ map("\u$_",$w->image('types',@_));
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ *{"Tk::Widget::$name"} = sub { $class->new(@_) };
+}
+
+# This is here to prevent AUTOLOAD trying to find it.
+sub DESTROY
+{
+ my $i = shift;
+ # maybe do image delete ???
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Image.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Image.pod
new file mode 100755
index 00000000000..9a9b6b6b646
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Image.pod
@@ -0,0 +1,145 @@
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Image - Create and manipulate images
+
+=for category Tk Image Classes
+
+=head1 SYNOPSIS
+
+I<$image> = I<$widget>-E<gt>I<type>(?I<arg arg ...>?)
+
+I<$image>-E<gt>I<method>(?I<arg arg ...>?)
+
+=head1 DESCRIPTION
+
+The B<image> constructors and methods are used to create, delete, and query images.
+It can take several different forms, depending on the
+I<type>.
+
+The constructors require a I<$widget> to invoke them, this is used
+to locate a B<MainWindow>. (This is because the underlying Tk code
+registers the images in the data structure for the B<MainWindow>.)
+
+The legal forms are:
+
+=over 4
+
+=item I<$widget>-E<gt>I<type>?(?I<name>?,?I<option>=E<gt>I<value ...>)?
+
+Creates a new image and returns an object.
+I<type> specifies the type of the image, which must be one of
+the types currently defined (e.g., B<Bitmap>).
+I<name> specifies the name for the image; if it is omitted then
+Tk picks a name of the form B<image>I<x>, where I<x> is
+an integer.
+There may be any number of I<option>=E<gt>I<value> pairs,
+which provide configuration options for the new image.
+The legal set of options is defined separately for each image
+type; see below for details on the options for built-in image types.
+If an image already exists by the given name then it is replaced
+with the new image and any instances of that image will redisplay
+with the new contents.
+
+=item I<$image>-E<gt>B<delete>
+
+Deletes the image I<$image> and returns an empty string.
+If there are instances of the image displayed in widgets,
+the image won't actually be deleted until all of the instances
+are released.
+However, the association between the instances and the image
+manager will be dropped.
+Existing instances will retain their sizes but redisplay as
+empty areas.
+If a deleted image is recreated (with the same I<name>)
+the existing instances will use the new image.
+
+=item I<$image>-E<gt>B<height>
+
+Returns a decimal string giving the height of image I<name>
+in pixels.
+
+=item I<$widget>-E<gt>B<imageInuse>( 'name' );
+
+Returns a boolean value indicating whether or not the image
+given by I<name> is in use by any widgets.
+
+=item I<$widget>-E<gt>B<imageNames>
+
+Returns a list containing all existing images for I<$widget>'s
+B<MainWindow>.
+
+=item I<$image>-E<gt>B<type>
+
+Returns the type of I<$image> (the value of the I<type>
+method when the image was created).
+
+=item I<$widget>-E<gt>B<imageTypes>
+
+Returns a list whose elements are all of the valid image types
+(i.e., all of the values that may be supplied for the I<type>
+to create an image).
+
+=item I<$image>-E<gt>B<width>
+
+Returns a decimal string giving the width of image I<name>
+in pixels.
+
+=back
+
+=head1 BUILT-IN IMAGE TYPES
+
+The following image types are defined by Tk so they will be available
+in any Tk application.
+Individual applications or extensions may define additional types.
+
+=over 4
+
+=item B<Bitmap>
+
+Each pixel in the image displays a foreground color, a background
+color, or nothing.
+See L<Tk::Bitmap> for more information.
+
+=item B<Pixmap>
+
+B<Pixmap> is slightly more general than B<Bitmap>, each pixel can
+be any available color or "transparent" (rendered as background color of the
+widget image is displayed in). B<Pixmap> is best used for icons and other
+simple graphics with only a few colors.
+
+B<Pixmap> is derived from Tix. See L<Tk::Pixmap> for more information.
+
+=item B<Photo>
+
+Displays a variety of full-color images, using dithering to
+approximate colors on displays with limited color capabilities.
+See L<Tk::Photo> documentation for more information.
+
+=back
+
+=head1 CAVEATS
+
+It's necessary to use the L</delete> method to delete an image object
+and free memory associated with it. Just using a lexical variable for
+storing the image object and letting the variable to go out of scope
+or setting to C<undef> is not sufficient.
+
+=head1 SEE ALSO
+
+L<Tk::Bitmap|Tk::Bitmap>
+L<Tk::Pixmap|Tk::Pixmap>
+L<Tk::Photo|Tk::Photo>
+
+=head1 KEYWORDS
+
+height, image, types of images, width
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/InputO.pod b/Master/tlpkg/tlperl.straw/lib/Tk/InputO.pod
new file mode 100755
index 00000000000..03a43b29ed7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/InputO.pod
@@ -0,0 +1,50 @@
+=head1 NAME
+
+Tk::InputO - Create and manipulate TIX InputO widgets
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+I<$inputonly> = I<$parent>-E<gt>B<InputO>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+Only the following three standard options are supported by
+B<InputO>:
+
+B<cursor> B<width> B<height>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+B<InputO> does not have any widget specific options.
+
+=head1 DESCRIPTION
+
+The B<InputO> method creates a new window (given by the
+$widget argument) and makes it into a B<InputO>
+widget. Additional options, described above, may be specified on the
+command line or in the option database to configure aspects of the
+B<InputO> such as its cursor or width.
+
+B<InputO> widgets are not visible to the user. The only
+purpose of B<InputO> widgets are to accept inputs from the
+user, which can be done with the B<bind> method.
+
+=head1 WIDGET METHODS
+
+The B<InputO> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+=head1 BINDINGS
+
+B<InputO> widgets have no default bindings.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Internals.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Internals.pod
new file mode 100755
index 00000000000..4ee1e0126ca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Internals.pod
@@ -0,0 +1,142 @@
+=head1 NAME
+
+CallingTk - what is Perl Tk interface doing when you call Tk functions.
+
+=for category C Programming
+
+This information is worse than useless for C<perlTk> users, but can of
+some help for people interested in using modified Tk source with
+C<perlTk>.
+
+I<This document is under construction. The information is believed to
+be pertinent to the version of> C<portableTk> I<available when it was
+created. All the details are subject to change.>
+
+=head1 DESCRIPTION
+
+=over 4
+
+=item PreCompiling
+
+Before the actual compilation stage a script scans the source
+and extracts the subcommands of different commands. This information
+resides in the file C<pTk/Methods.def>.
+
+=item Compilation
+
+During compilation the above file is included in the source of booting
+routine of dynamic (or static) library. More precisely, the booting
+code of module C<Tk> calls the subroutine Boot_Glue() from the module
+C<tkGlue.c>, and this subroutine includes the file (with appropriate
+macro definitions).
+
+=item Inside C<use Tk;>
+
+The module bootstraps the C code, then loads the Perl libraries. The
+heart of the Perl code is contained in the C<Tk::Widget> library, all the
+widgets inherit from this module. Code for toplevels is loaded from
+C<Tk::MainWindow>.
+
+During bootstrap of the C glue code the C<Xevent::?> codes and a
+handful of C<Tk::Widget> and C<Tk::Image> routines are defined. (Much
+more XSUBs are created from C<Tk.xs> code.) The widget subcommands are
+glued to Perl basing on the list included from C<pTk/Methods.def>. In
+fact all the subcommands are glued to XSUBs that are related to the
+same C subroutine XStoWidget(), but have different data parts.
+
+During the Perl code bootstrap the method C<Tk::Widget::import> is
+called. This call requires all the code from particular widget
+packages.
+
+Code from the widget packages calls an obscure command like
+
+ (bless \"Text")->WidgetClass;
+
+This command (actually Tk::Widget::WidgetClass()) creates three
+routines: Tk::Widget::Text(), Tk::Widget::isText(), and
+Tk::Text::isText(). The first one is basically C<new> of C<Tk::Text>,
+the other two return constants. It also puts the class into
+depository.
+
+=item Inside C<$top = MainWindow-E<gt>new;>
+
+This is quite intuitive. This call goes direct to
+C<Tk::MainWindow::new>, that calls XSUB
+C<Tk::MainWindow::CreateMainWindow>, that calls C subroutine
+Tk_CreateMainWindow(). It is a C<Tk> subroutine, so here black magic
+ends (almost).
+
+The only remaining black magic is that the C<Tk> initialization
+routine creates a lot of commands, but the subroutine for creation is
+usurped by B<portableTk> and the commands are created in the package
+C<Tk>. They are associated to XSUBs that are related to one of three C
+subroutines XStoSubCmd(), XStoBind(), or XStoTk(), but have different
+data parts.
+
+The result of the call is blessed into C<Tk::MainWindow>, as it should.
+
+=item Inside C<$top-E<gt>title('Text demo');>
+
+The package C<Tk::Toplevel> defines a lot of subroutines on the fly on
+some list. All the commands from the list are converted to the
+corresponding subcommands of C<wm> method of the widget. Here
+subcommand is a command with some particular second argument (in this
+case C<"title">). Recall that the first argument is $self.
+
+Now C<Tk::Toplevel> @ISA C<Tk::Widget>, that in turn @ISA C<Tk>. So a
+call to C<$top-E<gt>wm('title','Text demo')> calls C<Tk::wm>, that is
+defined during call to Tk_CreateMainWindow(). As it is described
+above, the XSUB associated to XStoSubCmd() is called.
+
+This C routine is defined in C<tkGlue.c>. It gets the data part of
+XSUB, creates a C<SV> with the name of the command, and calls
+Call_Tk() with the XSUB data as the first argument, and with the name
+of XSUB stuffed into the Perl stack in the place there C<tk> expects
+it. (In fact it can also reorder the arguments if it thinks it is
+what you want).
+
+The latter procedure extracts name of C<tk> procedure and
+C<clientData> from the first argument and makes a call, using Perl
+stack as C<argv> for the procedure. A lot of black magic is performed
+afterwards to convert result of the procedure to a Perl array return.
+
+=item Inside C<$text = $top-E<gt>Text(background =E<gt> $txtBg);>
+
+Above we discussed how the command C<Tk::Widget::Text> is created. The
+above command calls it via inheritance. It is translated to
+
+ Tk::Text::new($top, background => $txtBg);
+
+The package C<Tk::Text> has no method C<new>, so the
+C<Tk::Widget::new> is called. In turn it calls
+C<Tk::Text-E<gt>DoInit($top)>, that is
+C<Tk::Widget::DoInit(Tk::Text,$top)>, that initializes the bindings if
+necessary. Then it creates the name for the widget of the form
+C<.text0>, and calls C<Tk::text('.text0', background =E<gt> $txtBg)>
+(note lowercase). The result of the call is blessed into C<Tk::Text>,
+and the method C<bindtags> for this object is called.
+
+Now the only thing to discuss is who defines the methods C<text> and
+C<bindtags>. The answer is that they are defined in C<tkWindow.c>,
+and these commands are created in the package C<Tk> in the same sweep
+that created the command C<Tk::wm> discussed above.
+
+So the the same C code that corresponds to the processing of
+corresponding TCL commands is called here as well (this time via
+C<XStoTk> interface).
+
+=item Inside C<$text-E<gt>insert('insert','Hello, world!');>
+
+As we discussed above, the subcommands of widget procedures correspond
+to XSUB C<XStoWidget>. This XSUB substitutes the first argument $text
+(that is a hash reference) to an appropriate value from this hash,
+adds the additional argument after the first one that contains the
+name of the subcommand extracted from the data part of XSUB, and calls
+the corresponding Tk C subroutine via C<Call_Tk>.
+
+=back
+
+Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ItemStyle.pm b/Master/tlpkg/tlperl.straw/lib/Tk/ItemStyle.pm
new file mode 100755
index 00000000000..85c6c11a76c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ItemStyle.pm
@@ -0,0 +1,38 @@
+package Tk::ItemStyle;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/ItemStyle.pm#4 $
+
+require Tk;
+use base qw(Tk);
+require Tk::Widget;
+Construct Tk::Widget 'ItemStyle';
+
+Tk::Methods ('delete');
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ my $type = shift;
+ my %args = @_;
+ $args{'-refwindow'} = $widget unless exists $args{'-refwindow'};
+ $package->InitClass($widget);
+ my $obj = $widget->itemstyle($type, %args);
+ return bless $obj,$package;
+}
+
+sub Install
+{
+ # Dynamically loaded image types can install standard images here
+ my ($class,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/JPEG.pm b/Master/tlpkg/tlperl.straw/lib/Tk/JPEG.pm
new file mode 100755
index 00000000000..6565c4157b3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/JPEG.pm
@@ -0,0 +1,57 @@
+package Tk::JPEG;
+require DynaLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.003'; # was: sprintf '4.%03d', q$Revision: #2$ =~ /\D(\d+)\s*$/;
+use Tk 800.015;
+require Tk::Image;
+require Tk::Photo;
+require DynaLoader;
+
+use vars qw($VERSION $XS_VERSION);
+
+@ISA = qw(DynaLoader);
+
+$XS_VERSION = $Tk::VERSION;
+bootstrap Tk::JPEG;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tk::JPEG - JPEG loader for Tk::Photo
+
+=head1 SYNOPSIS
+
+ use Tk;
+ use Tk::JPEG;
+
+ my $image = $widget->Photo('-format' => 'jpeg', -file => 'something.jpg');
+
+
+=head1 DESCRIPTION
+
+This is an extension for Tk which supplies
+JPEG format loader for Photo image type.
+
+JPEG access is via release 5 of the The Independent JPEG Group's (IJG)
+free JPEG software.
+
+=head1 HISTORY
+
+This extension works for Tk800.015 and later and is by default bundled
+with Perl/Tk since Tk804.
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=head1 SEE ALSO
+
+L<Tk::Photo>.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/LabEntry.pm b/Master/tlpkg/tlperl.straw/lib/Tk/LabEntry.pm
new file mode 100755
index 00000000000..64cb392fa8c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/LabEntry.pm
@@ -0,0 +1,31 @@
+# Copyright (c) 1995-2003 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.
+
+package Tk::LabEntry;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/LabEntry.pm#6 $
+
+use base qw(Tk::Frame);
+use Tk::widgets qw(Frame Label Entry);
+
+Construct Tk::Widget 'LabEntry';
+
+sub Populate
+{
+ require Tk::Entry;
+ # LabeledEntry constructor.
+ #
+ my($cw, $args) = @_;
+ $cw->SUPER::Populate($args);
+ # Advertised subwidgets: entry.
+ my $e = $cw->Entry();
+ $e->pack('-expand' => 1, '-fill' => 'both');
+ $cw->Advertise('entry' => $e );
+ $cw->ConfigSpecs(DEFAULT => [$e]);
+ $cw->Delegates(DEFAULT => $e);
+ $cw->AddScrollbars($e) if (exists $args->{-scrollbars});
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/LabFrame.pm b/Master/tlpkg/tlperl.straw/lib/Tk/LabFrame.pm
new file mode 100755
index 00000000000..6fcab1acc56
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/LabFrame.pm
@@ -0,0 +1,138 @@
+#
+# Labeled frame. Derives from Tk::Frame, but intercepts the labeling
+# part.
+
+package Tk::LabFrame;
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tixish/LabFrame.pm#11 $
+
+use Tk;
+use base qw(Tk::Frame);
+Tk::Widget->Construct('LabFrame');
+
+sub autoLabel { 0 }
+
+sub Populate {
+ my ($cw, $args) = @_;
+
+ $cw->{m_geoMgr} = "";
+
+ my $border = $cw->Component(
+ Frame => 'border',
+ -relief => 'groove',
+ -bd => 2,
+ );
+
+ my $pad = $border->Frame;
+ $cw->Advertise(pad => $pad);
+
+ my $frame = $border->Frame;
+ $cw->Advertise(frame => $frame);
+
+ my $label = $cw->Component(Label => 'label');
+
+ $cw->SUPER::Populate($args);
+
+ $cw->Delegates(DEFAULT => $frame);
+ $cw->ConfigSpecs(
+ -background => [[qw/SELF ADVERTISED/],
+ qw/background Background/],
+ -borderwidth => [$border, qw/borderWidth Border 2/],
+ -font => [$label, qw/font Font/],
+ -foreground => [$label, qw/foreground Foreground black/],
+ -label => [{-text => $label}, qw/label Label/],
+ -labelside => [qw/METHOD labelSide LabelSide acrosstop/],
+ -labelvariable => [{-textvariable => $label}],
+ -relief => [$border, qw/relief Relief groove/],
+ DEFAULT => [$frame]
+ );
+ return $cw;
+}
+
+use Tk::Submethods(
+ form => [qw/check forget grid info slaves/],
+ grid => [qw/bbox columnconfigure configure forget info location
+ propagate rowconfigure remove size slaves/],
+ pack => [qw/forget info propagate slaves/],
+ place => [qw/forget info slaves/]
+);
+
+sub labelside {
+ my ($cw, $side) = @_;
+ return $cw->{Configure}{-labelside} unless $side;
+
+ my $border = $cw->Subwidget('border');
+ my $pad = $cw->Subwidget('pad');
+ my $frame = $cw->Subwidget('frame');
+ my $label = $cw->Subwidget('label');
+
+ ## packForget/formForget as appropriate
+ foreach ($border, $label, $pad, $frame) {
+ $_->formForget if $cw->{m_geoMgr} eq "form";
+ $_->packForget if ($cw->{m_geoMgr} eq "pack" && $_->ismapped);
+ }
+
+ if ($side eq "acrosstop") {
+
+ my $y = $label->reqheight / 2;
+ my $ph = $y - ($border->cget(-bd));
+ $ph = 0 if $ph < 0;
+
+ $label->form(qw/-top 0 -left 4 -padx 6 -pady 2/);
+ $border->form(-top => $y,
+ qw/-bottom -1 -left 0 -right -1 -padx 2 -pady 2/);
+ $pad->form(-bottom => $ph,
+ qw/-top 0 -left 0 -right -1/);
+ $frame->form(-top => $pad,
+ qw/-bottom -1 -left 0 -right -1 -fill both/);
+ $cw->{m_geoMgr} = "form";
+
+ } else {
+
+ $label->pack(-side => $side);
+ $frame->pack(-expand => 1, -fill => 'both');
+ $border->pack(-side => $side, -expand => 1, -fill => 'both');
+ $cw->{m_geoMgr} = "pack";
+ }
+}
+
+sub form {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:slaves)$/);
+ $cw->SUPER::form(@_);
+}
+
+sub grid {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame') if (@_ && $_[0] =~
+ /^(?:bbox
+ |columnconfigure
+ |location
+ |propagate
+ |rowconfigure
+ |size
+ |slaves)
+ $/x);
+ $cw->SUPER::grid(@_);
+}
+
+
+sub pack {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:propagate|slaves)$/);
+ $cw->SUPER::pack(@_);
+}
+
+sub place {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:slaves)$/);
+ $cw->SUPER::place(@_);
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/LabFrame.pod b/Master/tlpkg/tlperl.straw/lib/Tk/LabFrame.pod
new file mode 100755
index 00000000000..cf5cebf754a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/LabFrame.pod
@@ -0,0 +1,110 @@
+=head1 NAME
+
+Tk::LabFrame - labeled frame.
+
+=for pm Tixish/LabFrame.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+S< >B<use Tk::LabFrame;>
+
+S< >I<$f> = I<$parent>-E<gt>B<LabFrame>(?B<-label>=E<gt>I<text>,
+B<-labelside>=E<gt>I<where>, ...?);
+
+=head1 DESCRIPTION
+
+B<LabFrame> is exactly like B<Frame> and additionaly allows to
+add a label to the frame.
+
+=head1 WIDGET-OPTIONS
+
+B<LabFrame> supports the same options as the
+L<Frame|Tk::Frame/"STANDARD OPTIONS"> widget.
+
+Additional options of B<LabFrame> are:
+
+=over 4
+
+=item B<-font> =E<gt> I<font>
+
+Specifies the label's font
+
+=item B<-foreground> =E<gt> I<color>
+
+Specifies the label's foreground color
+
+=item B<-label> =E<gt> I<text>
+
+The text of the label to be placed with the Frame.
+
+=item B<-labelside> =E<gt> I<where>
+
+I<Where> can be one of B<left>, B<right>, B<top>, B<bottom> or B<acrosstop>.
+The first four work as might be expected and place the label to the
+left, right, above or below the frame respectively. The B<acrosstop>
+creates a grooved frame around the central frame and puts the label
+near the northwest corner such that it appears to "overwrite" the
+groove.
+
+=item B<-labelvariable> =E<gt> I<scalar_ref>
+
+Specifies a reference to a variable and used as an
+alternative to -label. If the value of the variable changes,
+then the widget will be updated automatically to reflect the
+change. Used like -textvariable.
+
+=back
+
+=head1 ADVERTISED SUBWIDGETS
+
+See L<Tk::mega/"Subwidget"> how to use advertised widgets.
+
+=over 4
+
+=item I<border>
+
+ Frame used to display the border
+
+=item I<frame>
+
+ Frame used to create new LabFrame children.
+
+=item I<label>
+
+ Label used for displaying text
+
+=back
+
+=head1 EXAMPLE
+
+Run the following test program to see this in action:
+
+ use strict;
+ use Tk;
+ require Tk::LabFrame;
+ require Tk::LabEntry;
+
+ my $test = 'Test this';
+ my $mw = Tk::MainWindow->new;
+ my $f = $mw->LabFrame(-label => "This is a label",
+ -labelside => "acrosstop");
+ $f->LabEntry(-label => "Testing", -textvariable => \$test)->pack;
+ $f->pack;
+ Tk::MainLoop;
+
+=head1 BUGS
+
+Perhaps B<LabFrame> should be subsumed within the generic pTk
+labeled widget mechanism.
+
+=head1 AUTHOR
+
+B<Rajappa Iyer> rsi@earthling.net
+
+This code is derived from LabFrame.tcl and LabWidg.tcl in the Tix4.0
+distribution by Ioi Lam. The code may be redistributed under the same
+terms as Perl.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/LabRadio.pm b/Master/tlpkg/tlperl.straw/lib/Tk/LabRadio.pm
new file mode 100755
index 00000000000..69e07b12f01
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/LabRadio.pm
@@ -0,0 +1,63 @@
+# Class LabeledRadiobutton
+
+package Tk::LabRadiobutton;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/LabRadio.pm#4 $
+
+require Tk::Frame;
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'LabRadiobutton';
+
+
+# Although there is no fundamental reason why -radiobuttons
+# should be fixed at create time converting to METHOD form
+# is extra work an this can serve as an example of CreateArgs
+# checking.
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ $parent->BackTrace("Must specify -radiobuttons for $package")
+ unless (defined $args->{'-radiobuttons'});
+ return $package->SUPER::CreateArgs($parent,$args);
+}
+
+sub Populate
+{
+ require Tk::Radiobutton;
+
+ my ($cw,$args) = @_;
+ $cw->SUPER::Populate($args);
+
+ # LabeledRadiobutton(s) constructor.
+ #
+ # Advertised subwidgets: the name(s) of your radiobutton(s).
+
+
+
+ my (@widgets) = ();
+
+ my $rl;
+ foreach $rl (@{$args->{'-radiobuttons'}})
+ {
+ my $r = $cw->Component( Radiobutton => $rl,
+ -text => $rl,
+ -value => $rl );
+ $r->pack(-side => 'left', -expand => 1, -fill => 'both');
+ push(@widgets,$r);
+ $cw->{Configure}{-value} = $rl;
+ }
+
+ $cw->BackTrace('No buttons') unless (@widgets);
+
+ $cw->ConfigSpecs('-variable' => [ \@widgets, undef, undef, \$cw->{Configure}{-value} ],
+ '-radiobuttons' => [ 'PASSIVE', undef, undef, undef ],
+ '-value' => [ 'PASSIVE', undef, undef, $cw->{Configure}{-value} ],
+ 'DEFAULT' => [ \@widgets ]
+ );
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Label.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Label.pm
new file mode 100755
index 00000000000..ebea1741c2f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Label.pm
@@ -0,0 +1,21 @@
+# Copyright (c) 1995-2003 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.
+
+package Tk::Label;
+require Tk;
+
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Label';
+
+sub Tk_cmd { \&Tk::label }
+
+1;
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Label.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Label.pod
new file mode 100755
index 00000000000..96386b09b5c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Label.pod
@@ -0,0 +1,133 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Label - Create and manipulate Label widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$label> = I<$parent>-E<gt>B<Label>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground>
+B<-activeforeground>
+B<-anchor>
+B<-background>
+B<-bitmap>
+B<-borderwidth>
+B<-compound>
+B<-cursor>
+B<-disabledforeground>
+B<-font>
+B<-foreground>
+B<-highlightbackground>
+B<-highlightcolor>
+B<-highlightthickness>
+B<-image>
+B<-justify>
+B<-padx>
+B<-pady>
+B<-relief>
+B<-takefocus>
+B<-text>
+B<-textvariable>
+B<-underline>
+B<-wraplength>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies a desired height for the label.
+If an image or bitmap is being displayed in the label then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in lines of text.
+If this option isn't specified, the label's desired height is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of three states for the label: B<normal>, B<active>, or
+B<disabled>. In normal state the label is displayed using the
+B<foreground> and B<background> options. In active state the label is
+displayed using the B<activeForeground> and B<activeBackground>
+options. In the disabled state the B<disabledForeground> and
+B<background> options determine how the button is displayed.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies a desired width for the label.
+If an image or bitmap is being displayed in the label then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in characters.
+If this option isn't specified, the label's desired width is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Label> method creates a new window (given by the
+$widget argument) and makes it into a label widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the label such as its colors, font,
+text, and initial relief. The B<label> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A label is a widget that displays a textual string, bitmap or image.
+If text is displayed, it must all be in a single font, but it
+can occupy multiple lines on the screen (if it contains newlines
+or if wrapping occurs because of the B<wrapLength> option) and
+one of the characters may optionally be underlined using the
+B<underline> option.
+The label can be manipulated in a few simple ways, such as
+changing its relief or text, using the commands described below.
+
+=head1 WIDGET METHODS
+
+The B<Label> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+=head1 BINDINGS
+
+When a new label is created, it has no default event bindings:
+labels are not intended to be interactive.
+
+=head1 KEYWORDS
+
+label, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Labelframe.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Labelframe.pm
new file mode 100755
index 00000000000..14c577b5e35
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Labelframe.pm
@@ -0,0 +1,16 @@
+package Tk::Labelframe;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #2 $ =~ /#(\d+)/;
+
+# New widget which is a kind of Frame with a label ...
+
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'Labelframe';
+
+sub Tk_cmd { \&Tk::labelframe }
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Labelframe.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Labelframe.pod
new file mode 100755
index 00000000000..b904ad7775b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Labelframe.pod
@@ -0,0 +1,206 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# RCS: @(#) $Id: labelframe.n,v 1.1 2001/09/26 21:36:19 pspjuth Exp $
+
+=head1 NAME
+
+Tk::Labelframe - Create and manipulate Labelframe widgets
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+I<$labelframe> = I<$parent>-E<gt>B<Labelframe>(?I<options>?);
+
+ -borderwidth -highlightbackground -pady
+ -cursor -highlightcolor -relief
+ -font -highlightthickness -takefocus
+ -foreground -padx -text
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Option: B<-background>
+
+=item Name: B<background>
+
+=item Class: B<Background>
+
+This option is the same as the standard B<background> option
+except that its value may also be specified as an empty string.
+In this case, the widget will display no background or border, and
+no colors will be consumed from its colormap for its background
+and border.
+
+=item Option: B<-class>
+
+=item Name: B<class>
+
+=item Class: B<Class>
+
+Specifies a class for the window.
+This class will be used when querying the option database for
+the window's other options, and it will also be used later for
+other purposes such as bindings.
+The B<class> option may not be changed with the B<configure>
+method.
+
+=item Option: B<-colormap>
+
+=item Name: B<colormap>
+
+=item Class: B<Colormap>
+
+Specifies a colormap to use for the window.
+The value may be either B<new>, in which case a new colormap is
+created for the window and its children, or the name of another
+window (which must be on the same screen and have the same visual
+as $widget), in which case the new window will use the colormap
+from the specified window.
+If the B<colormap> option is not specified, the new window
+uses the same colormap as its parent.
+This option may not be changed with the B<configure>
+method.
+
+=item Option: B<-container>
+
+=item Name: B<container>
+
+=item Class: B<Container>
+
+The value must be a boolean. If true, it means that this window will
+be used as a container in which some other application will be embedded
+(for example, a Tk toplevel can be embedded using the B<-use> option).
+The window will support the appropriate window manager protocols for
+things like geometry requests. The window should not have any
+children of its own in this application.
+This option may not be changed with the B<configure>
+method.
+
+=item Option: B<-height>
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+Specifies the desired height for the window in any of the forms
+acceptable to B<Tk_GetPixels>.
+If this option is less than or equal to zero then the window will
+not request any size at all.
+
+=item Option: B<-labelanchor>
+
+=item Name: B<labelAnchor>
+
+=item Class: B<LabelAnchor>
+
+Specifies where to place the label. A label is only displayed if the
+B<-text> option is not the empty string.
+Valid values for this option are (listing them clockwise)
+B<nw>, B<n>, B<ne>, B<en>, B<e>, B<es>,
+B<se>, B<s>,B<sw>, B<ws>, B<w> and B<wn>.
+The default value is B<nw>.
+
+=item Option: B<-labelwidget>
+
+=item Name: B<labelWidget>
+
+=item Class: B<LabelWidget>
+
+Specifies a widget to use as label. This overrides any B<-text>
+option. The widget must exist before being used as B<-labelwidget>
+and if it is not a descendant of this window, it will be raised
+above it in the stacking order.
+
+=item Option: B<-visual>
+
+=item Name: B<visual>
+
+=item Class: B<Visual>
+
+Specifies visual information for the new window in any of the
+forms accepted by B<Tk_GetVisual>.
+If this option is not specified, the new window will use the same
+visual as its parent.
+The B<visual> option may not be modified with the B<configure>
+method.
+
+=item Option: B<-width>
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+Specifies the desired width for the window in any of the forms
+acceptable to B<Tk_GetPixels>.
+If this option is less than or equal to zero then the window will
+not request any size at all.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Labelframe> method creates a new window (given by the
+$labelframe argument) and makes it into a Labelframe widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the Labelframe such as its background color
+and relief.
+
+A Labelframe is a simple widget. Its primary purpose is to act as a
+spacer or container for complex window layouts. It has the features
+of a B<Frame> plus the ability to display a label.
+
+=head1 WIDGET METHODS
+
+The B<Labelframe> method
+may be used to invoke various operations on the widget. It has the
+following general form:
+
+ $widget->method(?arg arg ...?);
+
+The following
+methods are possible for Labelframe widgets:
+
+=over 4
+
+=item I<$widget>-E<gt>B<cget>(I<option>);
+
+Returns the current value of the configuration option given
+by I<option>.
+I<Option> may have any of the values accepted by the B<Labelframe>
+command.
+
+=item I<$widget>-E<gt>B<configure>(?I<option>?, I<?value, option, value, ...>?);
+
+Query or modify the configuration options of the widget.
+If no I<option> is specified, returns a list describing all of
+the available options for $widget (see L<Tk::configure> for
+information on the format of this list). If I<option> is specified
+with no I<value>, then the command returns a list describing the
+one named option (this list will be identical to the corresponding
+sublist of the value returned if no I<option> is specified). If
+one or more I<option-value> pairs are specified, then the command
+modifies the given widget option(s) to have the given value(s); in
+this case the command returns an empty string.
+I<Option> may have any of the values accepted by the B<Labelframe>
+command.
+
+=back
+
+=head1 BINDINGS
+
+When a new Labelframe is created, it has no default event bindings:
+Labelframes are not intended to be interactive.
+
+=head1 SEE ALSO
+
+L<Tk::Frame>, L<Tk::Label>
+
+=head1 KEYWORDS
+
+Labelframe, widget
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Listbox.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Listbox.pm
new file mode 100755
index 00000000000..249a8eed7f4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Listbox.pm
@@ -0,0 +1,910 @@
+# Converted from listbox.tcl --
+#
+# This file defines the default bindings for Tk listbox widgets.
+#
+# @(#) listbox.tcl 1.7 94/12/17 16:05:18
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# 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.
+
+# Modifications from standard Listbox.pm
+# --------------------------------------
+# 27-JAN-2001 Alasdair Allan
+# Modified for local use by adding tied scalar and arrays
+# Implemented TIESCALAR, TIEARRAY, FETCH, FETCHSIZE, STORE, CLEAR & EXTEND
+# 31-JAN-2001 Alasdair Allan
+# Made changes suggested by Tim Jenness
+# 03-FEB-2001 Alasdair Allan
+# Modified STORE for tied scalars to clear and select elements
+# 06-FEB-2001 Alasdair Allan
+# Added POD documentation for tied listbox
+# 13-FEB-2001 Alasdair Allan
+# Implemented EXISTS, DELETE, PUSH, POP, SHIFT & UNSHIFT for tied arrays
+# 14-FEB-2001 Alasdair Allan
+# Implemented SPLICE for tied arrays, all tied functionality in place
+# 16-FEB-2001 Alasdair Allan
+# Tweak to STORE interface for tied scalars
+# 23-FEB-2001 Alasdair Allan
+# Added flag to FETCH for tied scalars, modified to return hashes
+# 24-FEB-2001 Alasdair Allan
+# Updated Pod documentation
+#
+
+package Tk::Listbox;
+
+use vars qw($VERSION @Selection $Prev);
+use strict;
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+use Tk::Clipboard ();
+use AutoLoader;
+
+use base qw(Tk::Clipboard Tk::Widget);
+
+Construct Tk::Widget 'Listbox';
+
+bootstrap Tk::Listbox;
+
+sub Tk_cmd { \&Tk::listbox }
+
+Tk::Methods('activate','bbox','curselection','delete','get','index',
+ 'insert','itemcget','itemconfigure','nearest','scan','see',
+ 'selection','size','xview','yview');
+
+use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)],
+ 'scan' => [qw(mark dragto)],
+ 'xview' => [qw(moveto scroll)],
+ 'yview' => [qw(moveto scroll)],
+ );
+
+*Getselected = \&getSelected;
+
+sub clipEvents
+{
+ return qw[Copy];
+}
+
+sub BalloonInfo
+{
+ my ($listbox,$balloon,$X,$Y,@opt) = @_;
+ my $e = $listbox->XEvent;
+ return if !$e;
+ my $index = $listbox->index('@' . $e->x . ',' . $e->y);
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$listbox);
+ if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
+ {
+ $balloon->Subclient($index);
+ if (defined $info->[$index])
+ {
+ return $info->[$index];
+ }
+ return '';
+ }
+ return $info;
+ }
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $class->SUPER::ClassInit($mw);
+ # Standard Motif bindings:
+ $mw->bind($class,'<1>',[sub {
+ my $w = shift;
+ if (Tk::Exists($w)) {
+ $w->BeginSelect(@_);
+ }
+ }, Ev('index',Ev('@'))]);
+ $mw->bind($class, '<Double-1>' => \&Tk::NoOp);
+ $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+ ;
+ $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
+
+ $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<Up>',['UpDown',-1]);
+ $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
+ $mw->bind($class,'<Down>',['UpDown',1]);
+ $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
+
+ $mw->XscrollBind($class);
+ $mw->bind($class,'<Prior>', sub {
+ my $w = shift;
+ $w->yview('scroll',-1,'pages');
+ $w->activate('@0,0');
+ });
+ $mw->bind($class,'<Next>', sub {
+ my $w = shift;
+ $w->yview('scroll',1,'pages');
+ $w->activate('@0,0');
+ });
+ $mw->bind($class,'<Control-Prior>', ['xview', 'scroll', -1, 'pages']);
+ $mw->bind($class,'<Control-Next>', ['xview', 'scroll', 1, 'pages']);
+ # <Home> and <End> defined in XscrollBind
+ $mw->bind($class,'<Control-Home>','Cntrl_Home');
+ ;
+ $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
+ $mw->bind($class,'<Control-End>','Cntrl_End');
+ ;
+ $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
+ # XXX What about <<Copy>>? Already handled in Tk::Clipboard?
+ # $class->clipboardOperations($mw,'Copy');
+ $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Escape>','Cancel');
+ $mw->bind($class,'<Control-slash>','SelectAll');
+ $mw->bind($class,'<Control-backslash>','Cntrl_backslash');
+ ;
+ # Additional Tk bindings that aren't part of the Motif look and feel:
+ $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
+
+ $mw->MouseWheelBind($class); # XXX Both needed?
+ $mw->YMouseWheelBind($class);
+ return $class;
+}
+
+1;
+__END__
+
+sub TIEARRAY {
+ my ( $class, $obj, %options ) = @_;
+ return bless {
+ OBJECT => \$obj,
+ OPTION => \%options }, $class;
+}
+
+
+
+sub TIESCALAR {
+ my ( $class, $obj, %options ) = @_;
+ return bless {
+ OBJECT => \$obj,
+ OPTION => \%options }, $class;
+}
+
+# FETCH
+# -----
+# Return either the full contents or only the selected items in the
+# box depending on whether we tied it to an array or scalar respectively
+sub FETCH {
+ my $class = shift;
+
+ my $self = ${$class->{OBJECT}};
+ my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
+
+ # Define the return variable
+ my $result;
+
+ # Check whether we are have a tied array or scalar quantity
+ if ( @_ ) {
+ my $i = shift;
+ # The Tk:: Listbox has been tied to an array, we are returning
+ # an array list of the current items in the Listbox
+ $result = $self->get($i);
+ } else {
+ # The Tk::Listbox has been tied to a scalar, we are returning a
+ # reference to an array or hash containing the currently selected items
+ my ( @array, %hash );
+
+ if ( defined $options{ReturnType} ) {
+
+ # THREE-WAY SWITCH
+ if ( $options{ReturnType} eq "index" ) {
+ $result = [$self->curselection];
+ } elsif ( $options{ReturnType} eq "element" ) {
+ foreach my $selection ( $self->curselection ) {
+ push(@array,$self->get($selection)); }
+ $result = \@array;
+ } elsif ( $options{ReturnType} eq "both" ) {
+ foreach my $selection ( $self->curselection ) {
+ %hash = ( %hash, $selection => $self->get($selection)); }
+ $result = \%hash;
+ }
+ } else {
+ # return elements (default)
+ foreach my $selection ( $self->curselection ) {
+ push(@array,$self->get($selection)); }
+ $result = \@array;
+ }
+ }
+ return $result;
+}
+
+# FETCHSIZE
+# ---------
+# Return the number of elements in the Listbox when tied to an array
+sub FETCHSIZE {
+ my $class = shift;
+ return ${$class->{OBJECT}}->size();
+}
+
+# STORE
+# -----
+# If tied to an array we will modify the Listbox contents, while if tied
+# to a scalar we will select and clear elements.
+sub STORE {
+
+ if ( scalar(@_) == 2 ) {
+ # we have a tied scalar
+ my ( $class, $selected ) = @_;
+ my $self = ${$class->{OBJECT}};
+ my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
+
+ # clear currently selected elements
+ $self->selectionClear(0,'end');
+
+ # set selected elements
+ if ( defined $options{ReturnType} ) {
+
+ # THREE-WAY SWITCH
+ if ( $options{ReturnType} eq "index" ) {
+ for ( my $i=0; $i < scalar(@$selected) ; $i++ ) {
+ for ( my $j=0; $j < $self->size() ; $j++ ) {
+ if( $j == $$selected[$i] ) {
+ $self->selectionSet($j); last; }
+ }
+ }
+ } elsif ( $options{ReturnType} eq "element" ) {
+ for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
+ for ( my $l=0; $l < $self->size() ; $l++ ) {
+ if( $self->get($l) eq $$selected[$k] ) {
+ $self->selectionSet($l); last; }
+ }
+ }
+ } elsif ( $options{ReturnType} eq "both" ) {
+ foreach my $key ( keys %$selected ) {
+ $self->selectionSet($key)
+ if $$selected{$key} eq $self->get($key);
+ }
+ }
+ } else {
+ # return elements (default)
+ for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
+ for ( my $l=0; $l < $self->size() ; $l++ ) {
+ if( $self->get($l) eq $$selected[$k] ) {
+ $self->selectionSet($l); last; }
+ }
+ }
+ }
+
+ } else {
+ # we have a tied array
+ my ( $class, $index, $value ) = @_;
+ my $self = ${$class->{OBJECT}};
+
+ # check size of current contents list
+ my $sizeof = $self->size();
+
+ if ( $index <= $sizeof ) {
+ # Change a current listbox entry
+ $self->delete($index);
+ $self->insert($index, $value);
+ } else {
+ # Add a new value
+ if ( defined $index ) {
+ $self->insert($index, $value);
+ } else {
+ $self->insert("end", $value);
+ }
+ }
+ }
+}
+
+# CLEAR
+# -----
+# Empty the Listbox of contents if tied to an array
+sub CLEAR {
+ my $class = shift;
+ ${$class->{OBJECT}}->delete(0, 'end');
+}
+
+# EXTEND
+# ------
+# Do nothing and be happy about it
+sub EXTEND { }
+
+# PUSH
+# ----
+# Append elements onto the Listbox contents
+sub PUSH {
+ my ( $class, @list ) = @_;
+ ${$class->{OBJECT}}->insert('end', @list);
+}
+
+# POP
+# ---
+# Remove last element of the array and return it
+sub POP {
+ my $class = shift;
+
+ my $value = ${$class->{OBJECT}}->get('end');
+ ${$class->{OBJECT}}->delete('end');
+ return $value;
+}
+
+# SHIFT
+# -----
+# Removes the first element and returns it
+sub SHIFT {
+ my $class = shift;
+
+ my $value = ${$class->{OBJECT}}->get(0);
+ ${$class->{OBJECT}}->delete(0);
+ return $value
+}
+
+# UNSHIFT
+# -------
+# Insert elements at the beginning of the Listbox
+sub UNSHIFT {
+ my ( $class, @list ) = @_;
+ ${$class->{OBJECT}}->insert(0, @list);
+}
+
+# DELETE
+# ------
+# Delete element at specified index
+sub DELETE {
+ my ( $class, @list ) = @_;
+
+ my $value = ${$class->{OBJECT}}->get(@list);
+ ${$class->{OBJECT}}->delete(@list);
+ return $value;
+}
+
+# EXISTS
+# ------
+# Returns true if the index exist, and undef if not
+sub EXISTS {
+ my ( $class, $index ) = @_;
+ return undef unless ${$class->{OBJECT}}->get($index);
+}
+
+# SPLICE
+# ------
+# Performs equivalent of splice on the listbox contents
+sub SPLICE {
+ my $class = shift;
+
+ my $self = ${$class->{OBJECT}};
+
+ # check for arguments
+ my @elements;
+ if ( scalar(@_) == 0 ) {
+ # none
+ @elements = $self->get(0,'end');
+ $self->delete(0,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];;
+
+ } elsif ( scalar(@_) == 1 ) {
+ # $offset
+ my ( $offset ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,'end');
+ $self->delete($start,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,'end');
+ $self->delete($offset,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+
+ } elsif ( scalar(@_) == 2 ) {
+ # $offset and $length
+ my ( $offset, $length ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ my $end = $self->size() + $offset + $length - 1;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,$end);
+ $self->delete($start,$end);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,$offset+$length-1);
+ $self->delete($offset,$offset+$length-1);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+
+ } else {
+ # $offset, $length and @list
+ my ( $offset, $length, @list ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ my $end = $self->size() + $offset + $length - 1;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,$end);
+ $self->delete($start,$end);
+ $self->insert($start,@list);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,$offset+$length-1);
+ $self->delete($offset,$offset+$length-1);
+ $self->insert($offset,@list);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+ }
+}
+
+# ----
+
+#
+# Bind --
+# This procedure is invoked the first time the mouse enters a listbox
+# widget or a listbox widget receives the input focus. It creates
+# all of the class bindings for listboxes.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+
+sub xyIndex
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ return $w->index($Ev->xy);
+}
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat;
+ $w->activate($Ev->xy);
+}
+
+
+sub Cntrl_Home
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate(0);
+ $w->see(0);
+ $w->selectionClear(0,'end');
+ $w->selectionSet(0);
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+
+sub Cntrl_End
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate('end');
+ $w->see('end');
+ $w->selectionClear(0,'end');
+ $w->selectionSet('end');
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+
+sub Cntrl_backslash
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if ($w->cget('-selectmode') ne 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+
+# BeginSelect --
+#
+# This procedure is typically invoked on button-1 presses. It begins
+# the process of making a selection in the listbox. Its exact behavior
+# depends on the selection mode currently in effect for the listbox;
+# see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginSelect
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'multiple')
+ {
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ }
+ else
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ @Selection = ();
+ $Prev = $el
+ }
+ $w->focus if ($w->cget('-takefocus'));
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+# Motion --
+#
+# This procedure is called to process mouse motion events while
+# button 1 is down. It may move or extend the selection, depending
+# on the listbox's selection mode.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element under the pointer (must be a number).
+sub Motion
+{
+ my $w = shift;
+ my $el = shift;
+ if (defined($Prev) && $el == $Prev)
+ {
+ return;
+ }
+ my $anchor = $w->index('anchor');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $Prev = $el;
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+ elsif ($mode eq 'extended')
+ {
+ my $i = $Prev;
+ if (!defined $i || $i eq '')
+ {
+ $i = $el;
+ $w->selectionSet($el);
+ }
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionSet('anchor',$el)
+ }
+ else
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionClear('anchor',$el)
+ }
+ if (!@Selection)
+ {
+ @Selection = $w->curselection;
+ }
+ while ($i < $el && $i < $anchor)
+ {
+ if (Tk::lsearch(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i++
+ }
+ while ($i > $el && $i > $anchor)
+ {
+ if (Tk::lsearch(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i--
+ }
+ $Prev = $el;
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+# BeginExtend --
+#
+# This procedure is typically invoked on shift-button-1 presses. It
+# begins the process of extending a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginExtend
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ else
+ {
+ # No selection yet; simulate the begin-select operation.
+ $w->BeginSelect($el);
+ }
+}
+# BeginToggle --
+#
+# This procedure is typically invoked on control-button-1 presses. It
+# begins the process of toggling a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginToggle
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended')
+ {
+ @Selection = $w->curselection();
+ $Prev = $el;
+ $w->selectionAnchor($el);
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+# y - The y-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ return if !Tk::Exists($w);
+ my $x = shift;
+ my $y = shift;
+ if ($y >= $w->height)
+ {
+ $w->yview('scroll',1,'units')
+ }
+ elsif ($y < 0)
+ {
+ $w->yview('scroll',-1,'units')
+ }
+ elsif ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->Motion($w->index("@" . $x . ',' . $y));
+ $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
+}
+# UpDown --
+#
+# Moves the location cursor (active element) up or down by one element,
+# and changes the selection if we're in browse or extended selection
+# mode.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub UpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ $w->activate($w->index('active')+$amount);
+ $w->see('active');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+ elsif ($mode eq 'extended')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->selectionAnchor('active');
+ $Prev = $w->index('active');
+ @Selection = ();
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+# ExtendUpDown --
+#
+# Does nothing unless we're in extended selection mode; in this
+# case it moves the location cursor (active element) up or down by
+# one element, and extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub ExtendUpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ if ($w->cget('-selectmode') ne 'extended')
+ {
+ return;
+ }
+ my $active = $w->index('active');
+ if (!@Selection)
+ {
+ $w->selectionSet($active);
+ @Selection = $w->curselection;
+ }
+ $w->activate($active + $amount);
+ $w->see('active');
+ $w->Motion($w->index('active'))
+}
+# DataExtend
+#
+# This procedure is called for key-presses such as Shift-KEndData.
+# If the selection mode isn't multiple or extend then it does nothing.
+# Otherwise it moves the active element to el and, if we're in
+# extended mode, extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# el - An integer element number.
+sub DataExtend
+{
+ my $w = shift;
+ my $el = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'extended')
+ {
+ $w->activate($el);
+ $w->see($el);
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->activate($el);
+ $w->see($el)
+ }
+}
+# Cancel
+#
+# This procedure is invoked to cancel an extended selection in
+# progress. If there is an extended selection in progress, it
+# restores all of the items between the active one and the anchor
+# to their previous selection state.
+#
+# Arguments:
+# w - The listbox widget.
+sub Cancel
+{
+ my $w = shift;
+ if ($w->cget('-selectmode') ne 'extended' || !defined $Prev)
+ {
+ return;
+ }
+ my $first = $w->index('anchor');
+ my $last = $Prev;
+ if ($first > $last)
+ {
+ ($first, $last) = ($last, $first);
+ }
+ $w->selectionClear($first,$last);
+ while ($first <= $last)
+ {
+ if (Tk::lsearch(\@Selection,$first) >= 0)
+ {
+ $w->selectionSet($first)
+ }
+ $first++
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+# SelectAll
+#
+# This procedure is invoked to handle the "select all" operation.
+# For single and browse mode, it just selects the active element.
+# Otherwise it selects everything in the widget.
+#
+# Arguments:
+# w - The listbox widget.
+sub SelectAll
+{
+ my $w = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ else
+ {
+ $w->selectionSet(0,'end')
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+# Perl/Tk extensions:
+sub SetList
+{
+ my $w = shift;
+ $w->delete(0,'end');
+ $w->insert('end',@_);
+}
+
+sub deleteSelected
+{
+ my $w = shift;
+ my $i;
+ foreach $i (reverse $w->curselection)
+ {
+ $w->delete($i);
+ }
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ my $index = $w->index('active') || $w->index($w->XEvent->xy);
+ my $str;
+ eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
+ return if $@;
+ foreach (split("\n",$str))
+ {
+ $w->insert($index++,$_);
+ }
+}
+
+sub getSelected
+{
+ my ($w) = @_;
+ my $i;
+ my (@result) = ();
+ foreach $i ($w->curselection)
+ {
+ push(@result,$w->get($i));
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Listbox.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Listbox.pod
new file mode 100755
index 00000000000..ba00afe3ed9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Listbox.pod
@@ -0,0 +1,794 @@
+# Copyright (c) 1990 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Listbox - Create and manipulate Listbox widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$listbox> = I<$parent>-E<gt>B<Listbox>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-background> B<-borderwidth> B<-cursor> B<-disabledforeground>
+B<-exportselection> B<-font> B<-foreground> B<-height>
+B<-highlightbackground> B<-highlightcolor> B<-highlightthickness>
+B<-offset> B<-relief> B<-selectbackground> B<-selectborderwidth>
+B<-selectforeground> B<-setgrid> B<-state> B<-takefocus> B<-tile>
+B<-width> B<-xscrollcommand> B<-yscrollcommand>
+
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<activeStyle>
+
+=item Class: B<ActiveStyle>
+
+=item Switch: B<-activestyle>
+
+Specifies the style in which to draw the active element. This must be
+one of B<dotbox> (show a focus ring around the active element), B<none>
+(no special indication of active element) or B<underline> (underline the
+active element). The default is B<underline>.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies the desired height for the window, in lines.
+If zero or less, then the desired height for the window is made just
+large enough to hold all the elements in the listbox.
+
+=item Name: B<listVariable>
+
+=item Class: B<Variable>
+
+=item Switch: B<-listvariable>
+
+I<The following is only partially implemented in Perl/Tk:>
+
+Specifies the reference of a variable. The value of the variable is an array
+to be displayed inside the widget; if the variable value changes
+then the widget will automatically update itself to reflect the new
+value. Attempts to assign a variable with an invalid list value to
+B<-listvariable> will cause an error. Attempts to unset a variable in use
+as a B<-listvariable> will fail but will not generate an error.
+
+=item Name: B<selectMode>
+
+=item Class: B<SelectMode>
+
+=item Switch: B<-selectmode>
+
+Specifies one of several styles for manipulating the selection.
+The value of the option may be arbitrary, but the default bindings
+expect it to be either B<single>, B<browse>, B<multiple>,
+or B<extended>; the default value is B<browse>.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of two states for the listbox: B<normal> or B<disabled>.
+If the listbox is disabled then items may not be inserted or deleted,
+items are drawn in the B<-disabledforeground> color, and selection
+cannot be modified and is not shown (though selection information is
+retained).
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired width for the window in characters.
+If the font doesn't have a uniform width then the width of the
+character ``0'' is used in translating from character units to
+screen units.
+If zero or less, then the desired width for the window is made just
+large enough to hold all the elements in the listbox.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Listbox> method creates a new window (given by the
+$widget argument) and makes it into a listbox widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the listbox such as its colors, font,
+text, and relief. The B<listbox> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A listbox is a widget that displays a list of strings, one per line.
+When first created, a new listbox has no elements.
+Elements may be added or deleted using methods described
+below. In addition, one or more elements may be selected as described
+below.
+If a listbox is exporting its selection (see B<exportSelection>
+option), then it will observe the standard X11 protocols
+for handling the selection.
+Listbox selections are available as type B<STRING>;
+the value of the selection will be the text of the selected elements, with
+newlines separating the elements.
+
+It is not necessary for all the elements to be
+displayed in the listbox window at once; commands described below
+may be used to change the view in the window. Listboxes allow
+scrolling in both directions using the standard B<xScrollCommand>
+and B<yScrollCommand> options.
+They also support scanning, as described below.
+
+=head1 INDICES
+
+Many of the methods for listboxes take one or more indices
+as arguments.
+An index specifies a particular element of the listbox, in any of
+the following ways:
+
+=over 4
+
+=item I<number>
+
+Specifies the element as a numerical index, where 0 corresponds
+to the first element in the listbox.
+
+=item B<active>
+
+Indicates the element that has the location cursor. This element
+will be displayed with an underline when the listbox has the
+keyboard focus, and it is specified with the B<activate>
+method.
+
+=item B<anchor>
+
+Indicates the anchor point for the selection, which is set with the
+B<selection anchor> method.
+
+=item B<end>
+
+Indicates the end of the listbox.
+For most commands this refers to the last element in the listbox,
+but for a few commands such as B<index> and B<insert>
+it refers to the element just after the last one.
+
+=item B<@>I<x>B<,>I<y>
+
+Indicates the element that covers the point in the listbox window
+specified by I<x> and I<y> (in pixel coordinates). If no
+element covers that point, then the closest element to that
+point is used.
+
+=back
+
+In the method descriptions below, arguments named I<index>,
+I<first>, and I<last> always contain text indices in one of
+the above forms.
+
+=head1 WIDGET METHODS
+
+The B<Listbox> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for listbox widgets:
+
+=over 4
+
+=item I<$listbox>-E<gt>B<activate>(I<index>)
+
+Sets the active element to the one indicated by I<index>.
+If I<index> is outside the range of elements in the listbox
+then the closest element is activated.
+The active element is drawn with an underline when the widget
+has the input focus, and its index may be retrieved with the
+index B<active>.
+
+=item I<$listbox>-E<gt>B<bbox>(I<index>)
+
+Returns a list of four numbers describing the bounding box of
+the text in the element given by I<index>.
+The first two elements of the list give the x and y coordinates
+of the upper-left corner of the screen area covered by the text
+(specified in pixels relative to the widget) and the last two
+elements give the width and height of the area, in pixels.
+If no part of the element given by I<index> is visible on the
+screen,
+or if I<index> refers to a non-existent element,
+then the result is an empty string; if the element is
+partially visible, the result gives the full area of the element,
+including any parts that are not visible.
+
+=item I<$listbox>-E<gt>B<curselection>
+
+Returns a list containing the numerical indices of
+all of the elements in the listbox that are currently selected.
+If there are no elements selected in the listbox then an empty
+string is returned.
+
+=item I<$listbox>-E<gt>B<delete>(I<first, >?I<last>?)
+
+Deletes one or more elements of the listbox. I<First> and I<last>
+are indices specifying the first and last elements in the range
+to delete. If I<last> isn't specified it defaults to
+I<first>, i.e. a single element is deleted.
+
+=item I<$listbox>-E<gt>B<get>(I<first, >?I<last>?)
+
+If I<last> is omitted, returns the contents of the listbox
+element indicated by I<first>,
+or an empty string if I<first> refers to a non-existent element.
+If I<last> is specified, the command returns a list whose elements
+are all of the listbox elements between I<first> and I<last>,
+inclusive.
+Both I<first> and I<last> may have any of the standard
+forms for indices.
+
+=item I<$listbox>-E<gt>B<index>(I<index>)
+
+Returns the integer index value that corresponds to I<index>.
+If I<index> is B<end> the return value is a count of the number
+of elements in the listbox (not the index of the last element).
+
+=item I<$listbox>-E<gt>B<insert>(I<index, >?I<element, element, ...>?)
+
+Inserts zero or more new elements in the list just before the
+element given by I<index>. If I<index> is specified as
+B<end> then the new elements are added to the end of the
+list. Returns an empty string.
+
+=item I<$listbox>-E<gt>B<itemcget>(I<index>, I<option>)
+
+Returns the current value of the item configuration option given by
+I<option>. Option may have any of the values accepted by the listbox
+B<itemconfigure> command.
+
+=item I<$listbox>-E<gt>B<itemconfigure>(I<index, >?I<option, value,
+option, value, ...>?)
+
+Query or modify the configuration options of an item in the listbox.
+If no option is specified, returns a list describing all of the
+available options for the item (see Tk_ConfigureInfo for information
+on the format of this list). If option is specified with no value,
+then the command returns a list describing the one named option (this
+list will be identical to the corresponding sublist of the value
+returned if no option is specified). If one or more option-value pairs
+are specified, then the command modifies the given widget option(s) to
+have the given value(s); in this case the command returns an empty
+string. The following options are currently supported for items:
+
+=over
+
+=item B<-background> =E<gt> I<color>
+
+I<Color> specifies the background color to use when displaying the
+item. It may have any of the forms accepted by Tk_GetColor.
+
+=item B<-foreground> =E<gt> I<color>
+
+I<Color> specifies the foreground color to use when displaying the
+item. It may have any of the forms accepted by Tk_GetColor.
+
+=item B<-selectbackground> =E<gt> I<color>
+
+I<Color> specifies the background color to use when displaying the
+item while it is selected. It may have any of the forms accepted by
+Tk_GetColor.
+
+=item B<-selectforeground> =E<gt> I<color>
+
+I<Color> specifies the foreground color to use when displaying the
+item while it is selected. It may have any of the forms accepted by
+Tk_GetColor.
+
+=back
+
+=item I<$listbox>-E<gt>B<nearest>(I<y>)
+
+Given a y-coordinate within the listbox window, this command returns
+the index of the (visible) listbox element nearest to that y-coordinate.
+
+=item I<$listbox>-E<gt>B<scan>(I<option, args>)
+
+This command is used to implement scanning on listboxes. It has
+two forms, depending on I<option>:
+
+=over 8
+
+=item I<$listbox>-E<gt>B<scanMark>(I<x, y>)
+
+Records I<x> and I<y> and the current view in the listbox
+window; used in conjunction with later B<scan dragto> commands.
+Typically this command is associated with a mouse button press in
+the widget. It returns an empty string.
+
+=item I<$listbox>-E<gt>B<scanDragto>(I<x, y>.)
+
+This command computes the difference between its I<x> and I<y>
+arguments and the I<x> and I<y> arguments to the last
+B<scan mark> command for the widget.
+It then adjusts the view by 10 times the
+difference in coordinates. This command is typically associated
+with mouse motion events in the widget, to produce the effect of
+dragging the list at high speed through the window. The return
+value is an empty string.
+
+=back
+
+=item I<$listbox>-E<gt>B<see>(I<index>)
+
+Adjust the view in the listbox so that the element given by I<index>
+is visible.
+If the element is already visible then the command has no effect;
+if the element is near one edge of the window then the listbox
+scrolls to bring the element into view at the edge; otherwise
+the listbox scrolls to center the element.
+
+=item I<$listbox>-E<gt>B<selection>(I<option, arg>)
+
+This command is used to adjust the selection within a listbox. It
+has several forms, depending on I<option>:
+
+=over 8
+
+=item I<$listbox>-E<gt>B<selectionAnchor>(I<index>)
+
+Sets the selection anchor to the element given by I<index>.
+If I<index> refers to a non-existent element, then the closest
+element is used.
+The selection anchor is the end of the selection that is fixed
+while dragging out a selection with the mouse.
+The index B<anchor> may be used to refer to the anchor
+element.
+
+=item I<$listbox>-E<gt>B<selectionClear>(I<first, >?I<last>?)
+
+If any of the elements between I<first> and I<last>
+(inclusive) are selected, they are deselected.
+The selection state is not changed for elements outside
+this range.
+
+=item I<$listbox>-E<gt>B<selectionIncludes>(I<index>)
+
+Returns 1 if the element indicated by I<index> is currently
+selected, 0 if it isn't.
+
+=item I<$listbox>-E<gt>B<selectionSet>(I<first, >?I<last>?)
+
+Selects all of the elements in the range between
+I<first> and I<last>, inclusive, without affecting
+the selection state of elements outside that range.
+
+=back
+
+=item I<$listbox>-E<gt>B<size>
+
+Returns a decimal string indicating the total number of elements
+in the listbox.
+
+=item I<$listbox>-E<gt>B<xview>(I<args>)
+
+This command is used to query and change the horizontal position of the
+information in the widget's window. It can take any of the following
+forms:
+
+=over 8
+
+=item I<$listbox>-E<gt>B<xview>
+
+Returns a list containing two elements.
+Each element is a real fraction between 0 and 1; together they describe
+the horizontal span that is visible in the window.
+For example, if the first element is .2 and the second element is .6,
+20% of the listbox's text is off-screen to the left, the middle 40% is visible
+in the window, and 40% of the text is off-screen to the right.
+These are the same values passed to scrollbars via the B<-xscrollcommand>
+option.
+
+=item I<$listbox>-E<gt>B<xview>(I<index>)
+
+Adjusts the view in the window so that the character position given by
+I<index> is displayed at the left edge of the window.
+Character positions are defined by the width of the character B<0>.
+
+=item I<$listbox>-E<gt>B<xviewMoveto>( I<fraction> );
+
+Adjusts the view in the window so that I<fraction> of the
+total width of the listbox text is off-screen to the left.
+I<fraction> must be a fraction between 0 and 1.
+
+=item I<$listbox>-E<gt>B<xviewScroll>( I<number, what> );
+
+This command shifts the view in the window left or right according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages> or an abbreviation
+of one of these.
+If I<what> is B<units>, the view adjusts left or right by
+I<number> character units (the width of the B<0> character)
+on the display; if it is B<pages> then the view adjusts by
+I<number> screenfuls.
+If I<number> is negative then characters farther to the left
+become visible; if it is positive then characters farther to the right
+become visible.
+
+=back
+
+=item I<$listbox>-E<gt>B<yview>(I<?args>?)
+
+This command is used to query and change the vertical position of the
+text in the widget's window.
+It can take any of the following forms:
+
+=over 8
+
+=item I<$listbox>-E<gt>B<yview>
+
+Returns a list containing two elements, both of which are real fractions
+between 0 and 1.
+The first element gives the position of the listbox element at the
+top of the window, relative to the listbox as a whole (0.5 means
+it is halfway through the listbox, for example).
+The second element gives the position of the listbox element just after
+the last one in the window, relative to the listbox as a whole.
+These are the same values passed to scrollbars via the B<-yscrollcommand>
+option.
+
+=item I<$listbox>-E<gt>B<yview>(I<index>)
+
+Adjusts the view in the window so that the element given by
+I<index> is displayed at the top of the window.
+
+=item I<$listbox>-E<gt>B<yviewMoveto>( I<fraction> );
+
+Adjusts the view in the window so that the element given by I<fraction>
+appears at the top of the window.
+I<Fraction> is a fraction between 0 and 1; 0 indicates the first
+element in the listbox, 0.33 indicates the element one-third the
+way through the listbox, and so on.
+
+=item I<$listbox>-E<gt>B<yviewScroll>( I<number, what> );
+
+This command adjusts the view in the window up or down according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages>.
+If I<what> is B<units>, the view adjusts up or down by
+I<number> lines; if it is B<pages> then
+the view adjusts by I<number> screenfuls.
+If I<number> is negative then earlier elements
+become visible; if it is positive then later elements
+become visible.
+
+=back
+
+=back
+
+=head1 DEFAULT BINDINGS
+
+Tk automatically creates class bindings for listboxes that give them
+Motif-like behavior. Much of the behavior of a listbox is determined
+by its B<selectMode> option, which selects one of four ways
+of dealing with the selection.
+
+If the selection mode is B<single> or B<browse>, at most one
+element can be selected in the listbox at once.
+In both modes, clicking button 1 on an element selects
+it and deselects any other selected item.
+In B<browse> mode it is also possible to drag the selection
+with button 1.
+
+If the selection mode is B<multiple> or B<extended>,
+any number of elements may be selected at once, including discontiguous
+ranges. In B<multiple> mode, clicking button 1 on an element
+toggles its selection state without affecting any other elements.
+In B<extended> mode, pressing button 1 on an element selects
+it, deselects everything else, and sets the anchor to the element
+under the mouse; dragging the mouse with button 1
+down extends the selection to include all the elements between
+the anchor and the element under the mouse, inclusive.
+
+Most people will probably want to use B<browse> mode for
+single selections and B<extended> mode for multiple selections;
+the other modes appear to be useful only in special situations.
+
+Any time the selection changes in the listbox, the virtual event
+B<<< <<ListboxSelect>> >>> will be generated. It is easiest to bind to this
+event to be made aware of any changes to listbox selection.
+
+
+In addition to the above behavior, the following additional behavior
+is defined by the default bindings:
+
+=over 4
+
+=item [1]
+
+In B<extended> mode, the selected range can be adjusted by pressing
+button 1 with the Shift key down: this modifies the selection to
+consist of the elements between the anchor and the element under
+the mouse, inclusive.
+The un-anchored end of this new selection can also be dragged with
+the button down.
+
+=item [2]
+
+In B<extended> mode, pressing button 1 with the Control key down
+starts a toggle operation: the anchor is set to the element under
+the mouse, and its selection state is reversed. The selection state
+of other elements isn't changed.
+If the mouse is dragged with button 1 down, then the selection state
+of all elements between the anchor and the element under the mouse
+is set to match that of the anchor element; the selection state of
+all other elements remains what it was before the toggle operation
+began.
+
+=item [3]
+
+If the mouse leaves the listbox window with button 1 down, the window
+scrolls away from the mouse, making information visible that used
+to be off-screen on the side of the mouse.
+The scrolling continues until the mouse re-enters the window, the
+button is released, or the end of the listbox is reached.
+
+=item [4]
+
+Mouse button 2 may be used for scanning.
+If it is pressed and dragged over the listbox, the contents of
+the listbox drag at high speed in the direction the mouse moves.
+
+=item [5]
+
+If the Up or Down key is pressed, the location cursor (active
+element) moves up or down one element.
+If the selection mode is B<browse> or B<extended> then the
+new active element is also selected and all other elements are
+deselected.
+In B<extended> mode the new active element becomes the
+selection anchor.
+
+=item [6]
+
+In B<extended> mode, Shift-Up and Shift-Down move the location
+cursor (active element) up or down one element and also extend
+the selection to that element in a fashion similar to dragging
+with mouse button 1.
+
+=item [7]
+
+The Left and Right keys scroll the listbox view left and right
+by the width of the character B<0>.
+Control-Left and Control-Right scroll the listbox view left and
+right by the width of the window.
+Control-Prior and Control-Next also scroll left and right by
+the width of the window.
+
+=item [8]
+
+The Prior and Next keys scroll the listbox view up and down
+by one page (the height of the window).
+
+=item [9]
+
+The Home and End keys scroll the listbox horizontally to
+the left and right edges, respectively.
+
+=item [10]
+
+Control-Home sets the location cursor to the the first element in
+the listbox, selects that element, and deselects everything else
+in the listbox.
+
+=item [11]
+
+Control-End sets the location cursor to the the last element in
+the listbox, selects that element, and deselects everything else
+in the listbox.
+
+=item [12]
+
+In B<extended> mode, Control-Shift-Home extends the selection
+to the first element in the listbox and Control-Shift-End extends
+the selection to the last element.
+
+=item [13]
+
+In B<multiple> mode, Control-Shift-Home moves the location cursor
+to the first element in the listbox and Control-Shift-End moves
+the location cursor to the last element.
+
+=item [14]
+
+The space and Select keys make a selection at the location cursor
+(active element) just as if mouse button 1 had been pressed over
+this element.
+
+=item [15]
+
+In B<extended> mode, Control-Shift-space and Shift-Select
+extend the selection to the active element just as if button 1
+had been pressed with the Shift key down.
+
+=item [16]
+
+In B<extended> mode, the Escape key cancels the most recent
+selection and restores all the elements in the selected range
+to their previous selection state.
+
+=item [17]
+
+Control-slash selects everything in the widget, except in
+B<single> and B<browse> modes, in which case it selects
+the active element and deselects everything else.
+
+=item [18]
+
+Control-backslash deselects everything in the widget, except in
+B<browse> mode where it has no effect.
+
+=item [19]
+
+The F16 key (labelled Copy on many Sun workstations) or Meta-w
+copies the selection in the widget to the clipboard, if there is
+a selection.
+
+The behavior of listboxes can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 TIED INTERFACE
+
+The Tk::Listbox widget can also be tied to a scalar or array variable, with
+different behaviour depending on the variable type, with the following
+tie commands:
+
+ use Tk;
+
+ my ( @array, $scalar, $other );
+ my %options = ( ReturnType => "index" );
+
+ my $MW = MainWindow->new();
+ my $lbox = $MW->Listbox()->pack();
+
+ my @list = ( "a", "b", "c", "d", "e", "f" );
+ $lbox->insert('end', @list );
+
+ tie @array, "Tk::Listbox", $lbox
+ tie $scalar, "Tk::Listbox", $lbox;
+ tie $other, "Tk::Listbox", $lbox, %options;
+
+currently only one modifier is implemented, a 3 way flag for tied scalars
+"ReturnType" which can have values "element", "index" or "both". The default
+is "element".
+
+=over 4
+
+=item Tied Arrays
+
+If you tie an array to the Listbox you can manipulate the items currently
+contained by the box in the same manner as a normal array, e.g.
+
+ print @array;
+ push(@array, @list);
+ my $popped = pop(@array);
+ my $shifted = shift(@array);
+ unshift(@array, @list);
+ delete $array[$index];
+ print $string if exists $array[$i];
+ @array = ();
+ splice @array, $offset, $length, @list
+
+The delete function is implemented slightly differently from the standard
+array implementation. Instead of setting the element at that index to undef
+it instead physically removes it from the Listbox. This has the effect of
+changing the array indices, so for instance if you had a list on non-continuous
+indices you wish to remove from the Listbox you should reverse sort the list
+and then apply the delete function, e.g.
+
+ my @list = ( 1, 2, 4, 12, 20 );
+ my @remove = reverse sort { $a <=> $b } @list;
+ delete @array[@remove];
+
+would safely remove indices 20, 12, 4, 2 and 1 from the Listbox without
+problems. It should also be noted that a similar warning applies to the
+splice function (which would normally be used in this context to perform
+the same job).
+
+
+=item Tied Scalars
+
+Unlike tied arrays, if you tie a scalar to the Listbox you can retrieve the
+currently selected elements in the box as an array referenced by the scalar,
+for instance
+
+ my @list = ( "a", "b", "c", "d", "e", "f" );
+ $lbox->insert('end', sort @list );
+ $lbox->selectionSet(1);
+
+inserts @list as elements in an already existing listbox and selects the
+element at index 1, which is "b". If we then
+
+ print @$selected;
+
+this will return the currently selected elements, in this case "b".
+
+However, if the "ReturnType" arguement is passed when tying the Listbox to the
+scalar with value "index" then the indices of the selected elements will be
+returned instead of the elements themselves, ie in this case "1". This can be
+useful when manipulating both contents and selected elements in the Listbox at
+the same time.
+
+Importantly, if a value "both" is given the scalar will not be tied to an
+array, but instead to a hash, with keys being the indices and values being
+the elements at those indices
+
+You can also manipulate the selected items using the scalar. Equating the
+scalar to an array reference will select any elements that match elements
+in the Listbox, non-matching array items are ignored, e.g.
+
+ my @list = ( "a", "b", "c", "d", "e", "f" );
+ $lbox->insert('end', sort @list );
+ $lbox->selectionSet(1);
+
+would insert the array @list into an already existing Listbox and select
+element at index 1, i.e. "b"
+
+ @array = ( "a", "b", "f" );
+ $selected = \@array;
+
+would select elements "a", "b" and "f" in the Listbox.
+
+Again, if the "index" we indicate we want to use indices in the options hash
+then the indices are use instead of elements, e.g.
+
+ @array = ( 0, 1, 5 );
+ $selected = \@array;
+
+would have the same effect, selecting elements "a", "b" and "f" if the
+$selected variable was tied with %options = ( ReturnType => "index" ).
+
+If we are returning "both", i.e. the tied scalar points to a hash, both key and
+value must match, e.g.
+
+ %hash = ( 0 => "a", 1 => "b", 5 => "f" );
+ $selected = \%hash;
+
+would have the same effect as the previous examples.
+
+It should be noted that, despite being a reference to an array (or possibly a has), you still can not copy the tied variable without it being untied, instead
+you must pass a reference to the tied scalar between subroutines.
+
+=back
+
+=head1 KEYWORDS
+
+listbox, widget, tied
+
+=head1 SEE ALSO
+
+L<Tk::HList>, L<Tk::TextList>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/MMtry.pm b/Master/tlpkg/tlperl.straw/lib/Tk/MMtry.pm
new file mode 100755
index 00000000000..110f6b2ae81
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/MMtry.pm
@@ -0,0 +1,58 @@
+# Copyright (c) 1995-2003 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.
+package Tk::MMtry;
+use Config;
+require Exporter;
+
+use vars qw($VERSION @EXPORT $VERBOSE);
+#$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
+$VERSION = '4.010';
+
+use base qw(Exporter);
+@EXPORT = qw(try_compile try_run);
+use strict;
+use File::Basename;
+use File::Spec;
+
+my $stderr_too = ($^O eq 'MSWin32') ? '' : '2>&1';
+
+sub try_compile
+{
+ my ($file,$inc,$lib,$def) = @_;
+ $inc = [] unless $inc;
+ $lib = [] unless $lib;
+ $def = [] unless $def;
+ my $out = basename($file,'.c').$Config{'exe_ext'};
+ warn "Test Compiling $file\n";
+ my $msgs = `$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib @$def $stderr_too`;
+ my $ok = ($? == 0);
+ warn "$msgs\n" if $VERBOSE && $msgs;
+ unlink($out) if (-f $out);
+ return $ok;
+}
+
+sub try_run
+{
+ my ($file,$inc,$lib,$def) = @_;
+ $inc = [] unless $inc;
+ $lib = [] unless $lib;
+ $def = [] unless $def;
+ my $out = basename($file,'.c').$Config{'exe_ext'};
+ warn "Test Compile/Run $file\n";
+ my $cmdline = "$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib @$def";
+ my $msgs = `$cmdline $stderr_too`;
+ my $ok = ($? == 0);
+ warn "$cmdline:\n$msgs\n" if $VERBOSE && $msgs;
+ if ($ok)
+ {
+ my $path = File::Spec->rel2abs($out);
+ $msgs = `$path $stderr_too`;
+ $ok = ($? == 0);
+ warn "$path:$msgs\n" if $VERBOSE && $msgs;
+ }
+ unlink($out) if (-f $out);
+ return $ok;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/MMutil.pm b/Master/tlpkg/tlperl.straw/lib/Tk/MMutil.pm
new file mode 100755
index 00000000000..621e9539376
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/MMutil.pm
@@ -0,0 +1,602 @@
+# Copyright (c) 1995-2003 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.
+package Tk::MMutil;
+use ExtUtils::MakeMaker;
+use Cwd;
+use Config;
+use Carp;
+use File::Basename;
+
+use vars qw($VERSION);
+$VERSION = '4.022'; # was: sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/;
+
+# warn __FILE__." $VERSION\n";
+
+use Tk::MakeDepend;
+
+use Tk::Config qw(!$VERSION);
+use vars qw($IsWin32);
+
+*IsWin32 = \$main::IsWin32;
+$IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/)
+ unless defined $IsWin32;
+
+@MYEXPORT = qw(pasthru perldepend cflags const_config constants installbin c_o xs_o makefile manifypods);
+
+sub arch_prune
+{
+ my $hash = shift;
+ foreach (keys %$hash)
+ {
+ if ($win_arch eq 'x')
+ {
+ delete $hash->{$_} if /Win[A-Z0-9]/ or /OS2/ or /ImgUtil/ or /^x/;
+ }
+ elsif ($win_arch eq 'open32')
+ {
+ delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/;
+ delete $hash->{$_} if /winMain|dllMain/;
+ }
+ elsif ($win_arch eq 'pm')
+ {
+ delete $hash->{$_}
+ if /Unix|Mwm/ and not
+ /tclUnix|Unix(3d|Button|Dialog|Color|Embed|Focus|Font|Menu|Scrlbr|Send|Int\.|Scale)/;
+ delete $hash->{$_} if /os2Main|dllMain|tkOS2Dll|^x(colors\.c|gc\.)/;
+ delete $hash->{$_} if /ImgUtil|tkWin[A-Z0-9]/ and not /OS2/;
+ }
+ elsif ($win_arch eq 'MSWin32')
+ {
+ delete $hash->{$_} if /Mwm/ and not /tclUnix/;
+ delete $hash->{$_} if /winMain|dllMain/;
+ # delete $hash->{$_} if /^Xrm/;
+ }
+ }
+}
+
+sub mTk_postamble
+{
+ my ($self) = @_;
+ my $dep = "config :: \$(C_FILES) \$(H_FILES)\n\t$self->{NOECHO}\$(NOOP)\n";
+ my $mTk = $self->{'MTK'};
+ $dep .= "# Begin Munging dependencies\n";
+ foreach my $file (sort keys %$mTk)
+ {
+ $dep .= "$file : ".$mTk->{$file}." \$(TKDIR)/pTk/Tcl-pTk\n";
+ $dep .= "\t\$(PERL) \$(TKDIR)/pTk/Tcl-pTk ".$mTk->{$file}." $file\n";
+ }
+ $dep .= "# End Munging dependencies\n\n";
+ return $dep;
+}
+
+sub mTk_CHO
+{
+ my $self = shift;
+ my $mTk = shift;
+ my $exc = shift;
+ my %c;
+ my %h;
+ foreach (@{$self->{H}}) { $h{$_} = 1 }
+ foreach (@{$self->{C}}) { $c{$_} = 1 }
+ foreach (keys %$mTk)
+ {
+ if (/\.c$/)
+ {
+ $c{$_} = 1;
+ }
+ elsif (/\.h$/)
+ {
+ $h{$_} = 1;
+ }
+ }
+ foreach (keys %$exc)
+ {
+ if (/\.c$/)
+ {
+ delete $c{$_};
+ }
+ elsif (/\.h$/)
+ {
+ delete $h{$_};
+ }
+ }
+ while (@_)
+ {
+ my $name = shift;
+ cluck("No $name") unless (exists $c{$name});
+ delete $c{$name}
+ }
+ arch_prune(\%h);
+ arch_prune(\%c);
+ $self->{'H'} = [sort keys %h];
+ $self->{'C'} = [sort keys %c];
+ my(@o_files) = @{$self->{C}};
+ $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ;
+ $self->{'MTK'} = $mTk;
+ my $tk = installed_tk();
+ my $perl = $self->{'PERL'};
+ if ($IsWin32 && !-f $perl && -f "$perl.exe")
+ {
+ print "perl=$perl X=$^X\n";
+ $perl = "$perl.exe";
+ $self->{'PERL'} = $perl;
+ }
+ foreach my $file (sort keys %$mTk)
+ {
+ unless (-f $file && -M $file < -M $mTk->{$file})
+ {
+ warn "Extracting $file\n";
+ system($perl,"$tk/pTk/Tcl-pTk",$mTk->{$file},$file);
+ }
+ }
+}
+
+my %visited;
+
+sub abspath
+{
+ my $dir = shift;
+ my $here = getcwd() || die "Cannot get current directory:$!";
+ if (chdir($dir))
+ {
+ $dir = getcwd();
+ chdir($here) || die "Cannot cd back to $here:$!";
+ }
+ return $dir;
+}
+
+sub relpath
+{
+ my ($path,$dir) = @_;
+ unless (defined $dir)
+ {
+ $dir = (-d $path) ? $path : dirname($path);
+ }
+ if (defined $dir and -d $dir)
+ {
+ if ($path =~ m#^\Q$dir\E([/\\]?.*)$#)
+ {
+ my $base = $1;
+ my $here = getcwd;
+ if ($here =~ m#^\Q$dir\E([/\\]?.*)#)
+ {
+ my $depth = reverse($1);
+ if ($depth)
+ {
+ $depth =~ s,[^/\\]+,..,g;
+ }
+ else
+ {
+ $depth = '.' ;
+ }
+ $depth =~ s,[/\\]+$,,;
+ $base =~ s,^[/\\]+,,;
+ $depth .= "/$base" if ($base);
+ if (-e $depth)
+ {
+ # print "$path is $depth from $here\n";
+ return $depth;
+ }
+ else
+ {
+ warn "Cannot find $depth\n";
+ }
+ }
+ else
+ {
+ unless(exists $visited{$here})
+ {
+ $visited{$here} = 1;
+ warn "$here does not start with $dir\n";
+ warn "i.e. building outside Tk itself\n";
+ }
+ }
+ }
+ else
+ {
+ die "'$path' not under '$dir'\n";
+ }
+ }
+ else
+ {
+ die "Cannot get directory for $path\n";
+ }
+ return $path;
+}
+
+use strict;
+
+sub upgrade_pic
+{
+ my $flags = '';
+ die 'upgrade_pic is obsolete';
+ return $flags;
+}
+
+sub pasthru
+{
+ my $self = shift;
+ my $str = $self->MM::pasthru;
+ if ($str =~ s/^\s+INC=.*\n//m)
+ {
+ $str = "# - Do NOT pasthru INC for Tk - it is computed by subdir\n$str"
+ }
+ if ($str =~ s/\bLIB="\$\(LIB\)"//)
+ {
+ $str = qq[# - Drop LIB="\$(LIB)" - not used\n$str];
+ }
+ $str = "#Tk::MMutil pasthru\n$str";
+ return $str;
+}
+
+sub perldepend
+{
+ my $self = shift;
+ my $str = $self->MM::perldepend;
+ my $name;
+ my %c;
+ foreach my $file (@{$self->{'C'}})
+ {
+ $c{$file} = 1;
+ }
+ foreach my $file (keys %{$self->{'XS'}})
+ {
+ $c{$file} = 1;
+ delete $c{$self->{'XS'}{$file}};
+ }
+ my @files = grep(-f $_,sort(keys %c));
+ if (@files)
+ {
+ my $tk = installed_tk();
+ my @inc = split(/\s+/,$self->{'INC'});
+ my @def = split(/\s+/,$self->{'DEFINE'});
+ push(@def,qw(-DWIN32 -D__WIN32__)) if ($IsWin32);
+ if ($^O eq 'cygwin')
+ {
+ push(@def,qw(-D__CYGWIN__));
+ if ($win_arch eq 'MSWin32')
+ {
+ push(@def,qw(-D__WIN32__)) unless $self->{'DEFINE'} =~ /-D__WIN32__/;
+ push(@def,qw(-DWIN32)) if $self->{'NAME'} eq 'Tk::pTk';
+ push(@def,qw(-dWINARCH_MSWIN32));
+ }
+ elsif ($win_arch eq 'x')
+ {
+ push(@def,qw(-U_WIN32));
+ push(@def,qw(-DWINARCH_X));
+ }
+ }
+ foreach (@inc)
+ {
+ s/\$\(TKDIR\)/$tk/g;
+ warn "Odd:$_" if /\$\(/;
+ }
+ $str .= Tk::MakeDepend::command_line(@inc,@def,@files) unless ($ENV{'TKNOMAKEDEPEND'});
+ }
+ return $str;
+}
+
+sub const_config
+{
+ my $self = shift;
+ my $name;
+ foreach $name (grep /(%|\.(old|bak|q4|orig|rej))$/,keys %{$self->{PM}})
+ {
+ delete $self->{PM}->{$name};
+ }
+ my $flags = $self->{'CCCDLFLAGS'};
+ $flags =~ s/(-[fK]?\s*)pic\b/${1}PIC/;
+ $self->{'CCCDLFLAGS'} = $flags;
+ if ($^O eq 'MSWin32' && $Config{'ccflags'} =~ /-DPERL_OBJECT/)
+ {
+ $self->{'LDFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
+ $self->{'LDDLFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
+ }
+ elsif ($^O eq 'darwin' )
+ {
+ $self->{'LDDLFLAGS'} =~ s/-flat_namespace//;
+ $self->{'LDDLFLAGS'} =~ s/-undefined\s+suppress//;
+ if ( -e "$Config{'archlib'}/CORE/$Config{'libperl'}" ) {
+ $self->{'LDDLFLAGS'} .= " -L\${PERL_ARCHLIB}/CORE -lperl ";
+ }
+ elsif ( -e "/System/Library/Perl/darwin/CORE/libperl.dylib" ) {
+ $self->{'LDDLFLAGS'} .= " -L/System/Library/Perl/darwin/CORE -lperl ";
+ }
+ else {
+ warn "Can't find libperl.dylib";
+ }
+ $self->{'LDFLAGS'} =~ s/-flat_namespace//;
+ $self->{'LDFLAGS'} =~ s/-undefined\s+suppress//;
+ } elsif ($^O =~ /(openbsd)/i)
+ {
+ # -Bforcearchive is bad news for Tk - we don't want all of libpTk.a in all .so-s.
+ $self->{'LDDLFLAGS'} =~ s/-Bforcearchive\s*//g;
+ }
+ return $self->MM::const_config;
+}
+
+sub constants
+{
+ my $self = shift;
+ local $_ = $self->MM::constants;
+ s/(\.SUFFIXES)/$1:\n$1/;
+ $_ .= "\nGCCOPT = $Tk::Config::gccopt\n";
+ if ($IsWin32)
+ {
+ }
+ $_;
+}
+
+sub cflags
+{
+ my $self = shift;
+ local $_ = $self->MM::cflags;
+ if (0 && $IsWin32)
+ {
+ if ($Config::Config{cc} =~ /^bcc/i) {
+ # s/(CCFLAGS\s*=)/$1/;
+ }
+ else {
+ s/(CCFLAGS\s*=)/$1 \$(cflags) \$(cvarsdll)/;
+ s/(OPTIMIZE\s*=).*/$1 \$(cdebug)/;
+ }
+ }
+ $_;
+}
+
+sub c_o
+{
+ my $self = shift;
+ local $_ = $self->MM::c_o;
+ s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
+ $_;
+}
+
+sub xs_o
+{
+ my $self = shift;
+ local $_ = $self->MM::xs_o;
+ s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
+ $_;
+}
+
+sub manifypods
+{
+ my $self = shift;
+ # Maybe always call UNIX version - we HTMLize them later
+ local $_ = $self->MM::manifypods;
+ if ($] >= 5.00565)
+ {
+ s/(POD2MAN_EXE.*pod2man.*)/$1 --center "perl\/Tk Documentation" --release "Tk\$(VERSION)"/;
+ }
+ elsif ($] >= 5.003)
+ {
+ s/(POD2MAN_EXE.*pod2man.*)/$1 -center "perl\/Tk Documentation" -release "Tk\$(VERSION)"/;
+ }
+ else
+ {
+ s/(POD2MAN_EXE.*pod2man.*)/$1 -center \\"perl\/Tk Documentation\\" -release \\"Tk\$(VERSION)\\"/;
+ }
+ s/\bpod::/Tk::/mg;
+ s/\bpTk:://mg;
+ $_;
+}
+
+sub findINC
+{
+ my $file = shift;
+ my $dir;
+ foreach $dir (@INC)
+ {
+ my $try = "$dir/$file";
+ return $try if (-f $try);
+ }
+ die "Cannot find $file in \@INC\n";
+}
+
+
+sub makefile
+{
+ my $self = shift;
+ my $str = $self->MM::makefile;
+ my $mm = findINC('Tk/MMutil.pm');
+ my $cf = findINC('Tk/Config.pm');
+ $str =~ s/(\$\(CONFIGDEP\))/$1 $cf $mm/;
+ $str =~ s/\$\(OBJECT\)\s*:.*\n//;
+ return $str;
+}
+
+sub installed_tk
+{
+ my $tk;
+ my $dir;
+ foreach $dir (@INC)
+ {
+ if (-f "$dir/tkGlue.h")
+ {
+ $tk = relpath($dir);
+ last;
+ }
+ my $try = "$dir/Tk";
+ if (-f "$try/tkGlue.h")
+ {
+ $tk = relpath($try,$dir);
+ last;
+ }
+ }
+ die "Cannot find perl/Tk include files\n" unless (defined $tk);
+ $tk =~ s,^(\./)+,,;
+ return $tk;
+}
+
+sub installbin
+{
+ my ($self) = @_;
+ my $str = $self->MM::installbin;
+ my $prog = 'perl'; # $self->{'MAP_TARGET'} || 'perl';
+ my $inc = findINC('Tk/MMutil.pm');
+ $inc =~ s,/Tk/MMutil.pm$,,;
+ $inc = relpath($inc);
+ $str =~ s/^\tcp\s/\t\$(PERL) -I$inc -MTk::install -e installbin $prog /mg;
+ return $str;
+}
+
+sub findpTk
+{
+ my $ptk;
+ my $dir;
+ foreach $dir (map(abspath($_),@_),@INC)
+ {
+ my $try = "$dir/pTk";
+ if (-d $try && (-f "$try/Lang.h" || -f "$try/libpTk\$(LIB_EXT)"))
+ {
+ $ptk = relpath($try,$dir);
+ last;
+ }
+ }
+ confess "Cannot locate pTk\n" unless (defined $ptk);
+ return $ptk;
+}
+
+sub find_subdir
+{
+ my %dir;
+ opendir(DIR,'.') || die "Cannot opendir:$!";
+ foreach my $dir (readdir(DIR))
+ {
+ next if $dir =~ /^\.\.?$/;
+ next if -l $dir;
+ next unless -d $dir;
+ if (-f "$dir/Makefile.PL")
+ {
+ my $exc = ($win_arch eq 'x') ? 'Unix' : 'Win';
+ if (-f "$dir/Not${exc}.exc")
+ {
+ warn "Skip $dir on $win_arch\n"
+ }
+ else
+ {
+ $dir{$dir} = 1
+ }
+ }
+ }
+ closedir(DIR);
+ return \%dir;
+}
+
+sub TkExtMakefile
+{
+ my (%att) = @_;
+ if ($Config{'ccflags'} =~ /-DPERL_OBJECT/)
+ {
+ $att{'CAPI'} = 'TRUE' unless exists $att{'CAPI'};
+ }
+ unless (exists $att{'DIR'})
+ {
+ my $dir = find_subdir();
+ $att{'DIR'} = [sort(keys %$dir)];
+ }
+ unless (exists $att{'NAME'})
+ {
+ my $dir = getcwd;
+ my ($pack) = $dir =~ m#/([^/]+)$#;
+ if (defined $pack)
+ {
+ $att{NAME} = 'Tk::'.$pack;
+ }
+ else
+ {
+ warn "No Name and cannot deduce from '$dir'";
+ }
+ }
+ my $tk = installed_tk();
+ $att{'macro'} = {} unless (exists $att{'macro'});
+ $att{'macro'}{'TKDIR'} = $tk;
+ my @opt = ('VERSION' => $Tk::Config::VERSION,
+ 'XS_VERSION' => $Tk::Config::VERSION);
+ push(@opt,'clean' => {} ) unless (exists $att{'clean'});
+ $att{'clean'}->{FILES} = '' unless (exists $att{'clean'}->{FILES});
+ $att{'clean'}->{FILES} .= ' *.bak';
+ unless (exists($att{'linkext'}) && $att{linkext}{LINKTYPE} eq '')
+ {
+ my $ptk = findpTk($tk);
+ my @tm = (findINC('Tk/typemap'));
+ unshift(@tm,@{$att{'TYPEMAPS'}}) if (exists $att{'TYPEMAPS'});
+ $att{'TYPEMAPS'} = \@tm;
+ my $i = delete ($att{'INC'});
+ $i = (defined $i) ? "$i $inc" : $inc;
+ if (delete $att{'dynamic_ptk'})
+ {
+ push(@opt,
+ 'MYEXTLIB' => "$ptk/libpTk\$(LIB_EXT)",
+# 'dynamic_lib' => { INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)" }
+ );
+ }
+ # Several loadable widgets use things from -lm
+ # if platform does not have a shared -lm need to link against it
+ if ($Config{libs} =~/-lm\b/)
+ {
+ my $libs = $att{'LIBS'}->[0];
+ $att{'LIBS'}->[0] = "$libs -lm" unless $libs =~ /-lm\b/;
+ }
+ if ($IsWin32 && $Config{'cc'} =~ /^bcc/)
+ {
+ # Borland compiler is very dumb at finding files
+ $i = "-I$tk $i";
+ $i = "-I$ptk $i";
+ }
+ if ($IsWin32 && $Config{'cc'} =~ /^gcc/i)
+ {
+ my $base = $Config{'libpth'};
+ $base =~ s#lib$#i386-mingw32/lib#;
+ my $extra = "-L$base -lcomdlg32 -lgdi32";
+ my $libs = $att{'LIBS'}->[0];
+ $att{'LIBS'}->[0] = "$extra $libs";
+ }
+ if ($^O eq 'cygwin')
+ {
+ # NOTE: use gcc -shared instead of dllwrap (ld2),
+ # dllwrap tries to resolve all symbols, even those
+ # that are brought in from libraries like libpTk.a
+ push(@opt,'LD' => 'gcc -shared');
+ if ($win_arch eq 'MSWin32')
+ {
+ my $extra = "-L/lib/w32api -lcomdlg32 -lgdi32";
+ my $libs = $att{'LIBS'}->[0];
+ $att{'LIBS'}->[0] = "$extra $libs";
+ $att{'DEFINE'} .= ' -D__WIN32__ -D_WIN32 -DWINARCH_MSWIN32';
+ $att{'DEFINE'} .= ' -DWIN32' if($att{'NAME'} eq 'Tk::pTk');
+ }
+ elsif ($win_arch eq 'x')
+ {
+ $att{'DEFINE'} .= ' -U_WIN32 -DWINARCH_X';
+ }
+ }
+ if (delete $att{'ptk_include'})
+ {
+ $i = "-I$ptk $i" unless ($ptk eq '.');
+ }
+ else
+ {
+ $i = "-I$tk $i" unless ($tk eq '.');
+ }
+ push(@opt,'DEFINE' => $define, 'INC' => $i);
+ }
+ WriteMakefile(@opt, %att);
+}
+
+sub import
+{
+ no strict 'refs';
+ my $class = shift;
+ my @list = (@_) ? @_ : @{"${class}::MYEXPORT"};
+ my $name;
+ foreach $name (@list)
+ {
+ *{"MY::$name"} = \&{"$name"};
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/MainWindow.pm b/Master/tlpkg/tlperl.straw/lib/Tk/MainWindow.pm
new file mode 100755
index 00000000000..c3e4ba90877
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/MainWindow.pm
@@ -0,0 +1,212 @@
+# Copyright (c) 1995-2003 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.
+package Tk::MainWindow;
+use base qw(Tk::Toplevel);
+BEGIN { @MainWindow::ISA = 'Tk::MainWindow' }
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.013'; # was: sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk::CmdLine;
+use Tk qw(catch);
+require Tk::Toplevel;
+
+use Carp;
+
+$| = 1;
+
+my $pid = $$;
+
+my %Windows = ();
+
+sub CreateArgs
+{
+ my ($class,$args) = @_;
+ my $cmd = Tk::CmdLine->CreateArgs();
+ my $key;
+ foreach $key (keys %$cmd)
+ {
+ $args->{$key} = $cmd->{$key} unless exists $args->{$key};
+ }
+ my %result = $class->SUPER::CreateArgs(undef,$args);
+ my $name = delete($args->{'-name'});
+ unless (Tk::tainting)
+ {
+ $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'});
+ $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'};
+ }
+ return (-name => "\l$name",%result);
+}
+
+sub new
+{
+ my $package = shift;
+ if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/)
+ {
+ carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W;
+ unshift(@_,'-screen');
+ }
+ croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2;
+ my %args = @_;
+
+ my $top = eval { bless Create($package->CreateArgs(\%args)), $package };
+ croak($@ . "$package->new(" . join(',',@_) .')') if ($@);
+ $top->apply_command_line;
+ $top->InitBindings;
+ $top->SetBindtags;
+ $top->InitObject(\%args);
+ eval { $top->configure(%args) };
+ croak "$@" if ($@);
+ if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') {
+ my $geometry = $top->optionGet(qw(geometry Geometry));
+ if ($geometry) {
+ $top->geometry($geometry);
+ }
+ }
+ $Windows{$top} = $top;
+ return $top;
+}
+
+sub _Destroyed
+{
+ my $top = shift;
+ $top->SUPER::_Destroyed;
+ delete $Windows{$top};
+}
+
+sub InitBindings
+{
+ my $mw = shift;
+ $mw->bind('all','<Tab>','focusNext');
+ # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk
+ $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]);
+ # This is needed for XFree86 systems
+ catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) };
+ # This seems to be correct on *some* HP systems.
+ catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) };
+ $mw->bind('all','<<LeftTab>>','focusPrev');
+ if ($mw->windowingsystem eq 'x11')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14>
+ <Control-Key-underscore>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]);
+ }
+ elsif ($mw->windowingsystem eq 'win32')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'aqua')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'classic')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]);
+ }
+
+ # FIXME - Should these move to Menubutton ?
+ my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton';
+ $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]);
+ $mw->bind($c,'<F10>','FirstMenu');
+}
+
+sub Existing
+{
+ my @Windows;
+ foreach my $name (keys %Windows)
+ {
+ my $obj = $Windows{$name};
+ if (Tk::Exists($obj))
+ {
+ push(@Windows,$obj);
+ }
+ else
+ {
+ delete $Windows{$name};
+ }
+ }
+ return @Windows;
+}
+
+END
+{
+ if (Tk::IsParentProcess())
+ {
+ foreach my $top (values %Windows)
+ {
+ if ($top->IsWidget)
+ {
+ # Tk data structuctures are still in place
+ # this can occur if non-callback perl code did a 'die'.
+ # It will also handle some cases of non-Tk 'exit' being called
+ # Destroy this mainwindow and hence is descendants ...
+ $top->destroy;
+ }
+ }
+ }
+}
+
+sub CmdLine { return shift->command }
+
+sub WMSaveYourself
+{
+ my $mw = shift;
+ my @args = @{$mw->command};
+# warn 'preWMSaveYourself:'.join(' ',@args)."\n";
+ @args = ($0) unless (@args);
+ my $i = 1;
+ while ($i < @args)
+ {
+ if ($args[$i] eq '-iconic')
+ {
+ splice(@args,$i,1);
+ }
+ elsif ($args[$i] =~ /^-(geometry|iconposition)$/)
+ {
+ splice(@args,$i,2);
+ }
+ }
+
+ my @ip = $mw->wm('iconposition');
+# print 'ip ',join(',',@ip),"\n";
+ my $icon = $mw->iconwindow;
+ if (defined($icon))
+ {
+ @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/;
+ }
+ splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2);
+
+ splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic');
+
+ splice(@args,1,0,'-geometry' => $mw->geometry);
+# warn 'postWMSaveYourself:'.join(' ',@args)."\n";
+ $mw->command([@args]);
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/MainWindow.pod b/Master/tlpkg/tlperl.straw/lib/Tk/MainWindow.pod
new file mode 100755
index 00000000000..565658adc1d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/MainWindow.pod
@@ -0,0 +1,85 @@
+
+=head1 NAME
+
+Tk::MainWindow - Root widget of a widget tree
+
+=for pm Tk/MainWindow.pm
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+ use Tk;
+
+ my $mw = MainWindow->new( ... options ... );
+
+ my $this = $mw->ThisWidget -> pack ;
+ my $that = $mw->ThatWidget;
+ ...
+
+ MainLoop;
+
+=head1 DESCRIPTION
+
+Perl/Tk applications (which have windows associated with them) create
+one or more B<MainWindow>s which act as the containers and parents
+of the other widgets.
+
+B<Tk::MainWindow> is a special kind of L<Toplevel|Tk::Toplevel> widget. It is
+the root of a widget tree. Therefore C<$mw-E<gt>Parent> returns
+C<undef>.
+
+The default title of a MainWindow is the basename of the script
+(actually the Class name used for options lookup, i.e. with basename
+with inital caps) or 'Ptk' as the fallback value. If more than one MainWindow is created
+or several instances of the script are running at the same time the
+string C<" #n"> is appended where the number C<n> is set to get
+a unique value.
+
+Unlike the standard Tcl/Tk's wish, perl/Tk allows you to create
+several MainWindows. When the I<last> B<MainWindow> is destroyed
+the Tk eventloop exits (the eventloop is entered with the call of
+C<MainLoop>). Various resources (bindings, fonts, images, colors) are
+maintained or cached for each MainWindow, so each MainWindow consumes more
+resources than a Toplevel. However multiple MainWindows can make sense when
+the user can destroy them independently.
+
+=head1 METHODS
+
+You can apply all methods that a L<Toplevel|Tk::Toplevel> widget accepts.
+
+The method I<$w>-E<gt>B<MainWindow> applied to any widget will return the
+B<MainWindow> to which the widget belongs (the MainWindow belongs to itself).
+
+=head1 MISSING
+
+Documentation is incomplete.
+Here are I<some> missing items that should be explained in
+more detail:
+
+=over 4
+
+=item *
+
+The new mechanism for MainWindows is slightly different to
+other widgets.
+
+=item *
+
+There no explanation about what resources are bound
+to a MainWindow (e.g., ClassInit done per MainWindow)
+
+=item *
+
+Passing of command line options to override or augment
+arguments of the C<new> method (see L<Tk::CmdLine>).
+
+=back
+
+=head1 SEE ALSO
+
+L<Tk::Toplevel|Tk::Toplevel>
+L<Tk::CmdLine|Tk::CmdLine>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/MakeDepend.pm b/Master/tlpkg/tlperl.straw/lib/Tk/MakeDepend.pm
new file mode 100755
index 00000000000..bfb7b43ccbc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/MakeDepend.pm
@@ -0,0 +1,292 @@
+package Tk::MakeDepend;
+use strict;
+use vars qw(%define);
+use Config;
+
+my @include;
+
+use Carp;
+
+$SIG{__DIE__} = \&Carp::confess;
+
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
+
+sub scan_file;
+
+sub do_include
+{
+ my ($inc,$dep,@include) = @_;
+ foreach my $dir (@include)
+ {
+ my $path = "$dir/$inc";
+ if (-f $path)
+ {
+ scan_file($path,$dep) unless exists $dep->{$path};
+ return;
+ }
+ }
+ warn "Cannot find '$inc' assume made\n";
+ $dep->{$inc} = 1;
+}
+
+sub remove_comment
+{
+ s#^\s*/\*.*?\*/\s*##g;
+}
+
+
+sub term
+{
+ remove_comment();
+ return !term() if s/^\s*!//;
+ return exists($define{$1}) if s/^\s*defined\s*\(([_A-Za-z][_\w]*)\s*\)//;
+ return exists($define{$1}) if s/^\s*defined\s*([_A-Za-z][_\w]*)//;
+ return eval "$1" if s/^\s*(0x[0-9a-f]+)//i;
+ return $1 if s/^\s*(\d+)//;
+ return $define{$1} || 0 if s/^\s*([_A-Za-z][_\w]*)//;
+ if (s/^\s*\(//)
+ {
+ my $val = expression(0);
+ warn "Missing ')'\n" unless s/^\s*\)//;
+ return $val;
+ }
+ warn "Invalid term:$_";
+ return undef;
+}
+
+my %pri = ( '&&' => 4,
+ '||' => 3,
+ '>=' => 2, '<=' => 2, '<' => 2, '>' => 2,
+ '==' => 1, '!=' => 1 );
+
+sub expression
+{
+ my $pri = shift;
+ # printf STDERR "%d# expr . $_\n";
+ my $invert = 0;
+ my $lhs = term() || 0;
+ remove_comment();
+ while (/^\s*(&&|\|\||>=?|<=?|==|!=)/)
+ {
+ my $op = $1;
+ last unless ($pri{$op} >= $pri);
+ s/^\s*\Q$op\E//;
+ # printf STDERR "%d# $lhs $op . $_\n";
+ my $rhs = expression($pri{$op}) || 0;
+ my $e = "$lhs $op $rhs";
+ $lhs = eval "$e" || 0;
+ die "'$e' $@" if $@;
+ remove_comment();
+ }
+ return $lhs;
+}
+
+sub do_if
+{
+ my ($key,$expr) = @_;
+ chomp($expr);
+ if ($key eq 'ifdef' || $key eq 'ifndef')
+ {
+ if ($expr =~ /^\s*(\w+)/)
+ {
+ my $val = exists $define{$1};
+ $val = !$val if ($key eq 'ifndef');
+# printf STDERR "%d from $key $expr\n",$val;
+ return $val;
+ }
+ }
+ else
+ {
+ local $_ = $expr;
+ my $val = expression(0) != 0;
+ warn "trailing: $_" if /\S/;
+ #printf STDERR "%d from $key $expr\n",$val;
+ return $val;
+ }
+}
+
+sub scan_file
+{
+ no strict 'refs';
+ my ($file,$dep) = @_;
+ open($file,"<$file") || die "Cannot open $file:$!";
+ local $_;
+ my ($srcdir) = $file =~ m#^(.*)[\\/][^\\/]*$#;
+ $srcdir = '.' unless defined $srcdir;
+ my $live = 1;
+ $dep->{$file} = 1;
+ my @stack;
+ while (<$file>)
+ {
+ $_ .= <$file> while (s/\\\n/ /);
+ if (/^\s*#\s*(\w+)\s*(.*?)\s*$/)
+ {
+ my $ol = $live;
+ my $key = $1;
+ my $rest = $2;
+ if ($key =~ /^if(.*)$/)
+ {
+ push(@stack,$live);
+ $live &&= do_if($key,$rest);
+ }
+ elsif ($key eq 'elif')
+ {
+ $live = ($live) ? 0 : $stack[-1];
+ $live &&= do_if('if',$rest);
+ }
+ elsif ($key eq 'else')
+ {
+ $live = ($live) ? 0 : $stack[-1];
+ }
+ elsif ($key eq 'endif')
+ {
+ if (@stack)
+ {
+ $live = pop(@stack);
+ }
+ else
+ {
+ die "$file:$.: Mismatched #endif\n";
+ }
+ }
+ elsif ($live)
+ {
+ if ($key eq 'include')
+ {
+ do_include($1,$dep,$srcdir,@include) if $rest =~ /^"(.*)"/;
+ }
+ elsif ($key eq 'define')
+ {
+ if ($rest =~ /^\s*([_A-Za-z][\w_]*)\s*(.*)$/)
+ {
+ my $sym = $1;
+ my $val = $2 || 1;
+ $val =~ s#\s*/\*.*?\*/\s*# #g;
+ $define{$sym} = $val;
+ }
+ else
+ {
+ warn "ignore '$key $rest'\n";
+ }
+ }
+ elsif ($key eq 'undef')
+ {
+ if ($rest =~ /^\s*([_A-Za-z][\w_]*)/)
+ {
+ delete $define{$1};
+ }
+ }
+ elsif ($key =~ /^(line|pragma)$/)
+ {
+
+ }
+ else
+ {
+ warn "ignore '$key $rest'\n";
+ }
+ }
+ # printf STDERR "$file:$.: %d $key $rest\n",$live if ($ol != $live);
+ }
+ else
+ {
+ # print if $live;
+ }
+ }
+ close($file);
+ if (@stack)
+ {
+ warn "$file:$.: unclosed #if\n";
+ }
+}
+
+sub command_line
+{
+ @include = ();
+ local %define = ('__STDC__' => 1 );
+ my $data = '';
+ my @files;
+ while (@_ && $_[-1] !~ /^-/)
+ {
+ unshift(@files,pop(@_));
+ }
+ my $flags = $Config{ccflags};
+ $flags =~ s/^\s+|\s+$//g;
+ my @opt = (@_, split(/\s+/,$flags));
+ while (@opt)
+ {
+ local $_ = shift(@opt);
+ if (/^-I(.*)$/)
+ {
+ push @include,$1;
+ }
+ elsif (/^-D([^=]+)(?:=(.*))?$/)
+ {
+ $define{$1} = $2 || 1;
+ }
+ elsif (/^-U(.*)$/)
+ {
+ delete $define{$1};
+ }
+ elsif (/^(-.*)$/)
+ {
+ # Some option
+ if ($opt[0] !~ /^-/)
+ {
+ # next arg does not start with '-' assume it
+ # belongs to this option and discard it silently
+ shift(@opt);
+ }
+ }
+ else
+ {
+ # We got confused
+ warn "Ignoring $1\n";
+ }
+ }
+ # force /usr/include to be last element of @include
+ push @include, $Config{'usrinc'}
+ if (defined $Config{'usrinc'} and $Config{'usrinc'} ne '');
+ # warn "Include:@include\n";
+ while (@files)
+ {
+ local $_ = shift(@files);
+ unless (/^(.*)\.[^\.]+$/)
+ {
+ warn "Skip $_";
+ next;
+ }
+ local %define = %define;
+ my $base = $1;
+ my $file = $_;
+ my %dep;
+ warn "Finding dependencies for $file\n";
+ scan_file($_,\%dep);
+ my $str = "\n$base\$(OBJ_EXT) : $base.c";
+ delete $dep{$file};
+ my @dep = (sort(keys %dep));
+ while (@dep)
+ {
+ my $dep = shift(@dep);
+ $dep =~ s#^\./##;
+ if (length($str)+length($dep) > 70)
+ {
+ $data .= "$str \\\n";
+ $str = ' ';
+ }
+ else
+ {
+ $str .= ' ';
+ }
+ $str .= $dep;
+ }
+ $data .= "$str\n";
+ }
+ return $data;
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Menu.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Menu.pm
new file mode 100755
index 00000000000..98ef0f71800
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Menu.pm
@@ -0,0 +1,1201 @@
+# Converted from menu.tcl --
+#
+# This file defines the default bindings for Tk menus and menubuttons.
+# It also implements keyboard traversal of menus and implements a few
+# other utility procedures related to menus.
+#
+# @(#) menu.tcl 1.34 94/12/19 17:09:09
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# 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.
+
+package Tk::Menu;
+require Tk;
+require Tk::Widget;
+require Tk::Wm;
+require Tk::Derived;
+require Tk::Menu::Item;
+
+
+use vars qw($VERSION);
+$VERSION = '4.023'; # was: sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/;
+
+use strict;
+
+use base qw(Tk::Wm Tk::Derived Tk::Widget);
+
+Construct Tk::Widget 'Menu';
+
+sub Tk_cmd { \&Tk::_menu }
+
+Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure',
+ 'index','insert','invoke','post','postcascade','type',
+ 'unpost','yposition');
+
+import Tk qw(Ev);
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ # Remove from hash %$args any configure-like
+ # options which only apply at create time (e.g. -class for Frame)
+ # return these as a list of -key => value pairs
+ my @result = ();
+ my $opt;
+ foreach $opt (qw(-type -screen -visual -colormap))
+ {
+ my $val = delete $args->{$opt};
+ push(@result, $opt => $val) if (defined $val);
+ }
+ return @result;
+}
+
+sub InitObject
+{
+ my ($menu,$args) = @_;
+ my $menuitems = delete $args->{-menuitems};
+ $menu->SUPER::InitObject($args);
+ $menu->ConfigSpecs(-foreground => ['SELF']);
+ if (defined $menuitems)
+ {
+ # If any other args do configure now
+ if (%$args)
+ {
+ $menu->configure(%$args);
+ %$args = ();
+ }
+ $menu->AddItems(@$menuitems)
+ }
+}
+
+sub AddItems
+{
+ my $menu = shift;
+ ITEM:
+ while (@_)
+ {
+ my $item = shift;
+ if (!ref($item))
+ {
+ $menu->separator; # A separator
+ }
+ else
+ {
+ my ($kind,$name,%minfo) = ( @$item );
+ my $invoke = delete $minfo{'-invoke'};
+ if (defined $name)
+ {
+ $minfo{-label} = $name unless defined($minfo{-label});
+ $menu->$kind(%minfo);
+ }
+ else
+ {
+ $menu->BackTrace("Don't recognize " . join(' ',@$item));
+ }
+ } # A non-separator
+ }
+}
+
+#
+#-------------------------------------------------------------------------
+# Elements of tkPriv that are used in this file:
+#
+# cursor - Saves the -cursor option for the posted menubutton.
+# focus - Saves the focus during a menu selection operation.
+# Focus gets restored here when the menu is unposted.
+# inMenubutton - The name of the menubutton widget containing
+# the mouse, or an empty string if the mouse is
+# not over any menubutton.
+# popup - If a menu has been popped up via tk_popup, this
+# gives the name of the menu. Otherwise this
+# value is empty.
+# postedMb - Name of the menubutton whose menu is currently
+# posted, or an empty string if nothing is posted
+# A grab is set on this widget.
+# relief - Used to save the original relief of the current
+# menubutton.
+# window - When the mouse is over a menu, this holds the
+# name of the menu; it's cleared when the mouse
+# leaves the menu.
+#-------------------------------------------------------------------------
+#-------------------------------------------------------------------------
+# Overall note:
+# This file is tricky because there are four different ways that menus
+# can be used:
+#
+# 1. As a pulldown from a menubutton. This is the most common usage.
+# In this style, the variable tkPriv(postedMb) identifies the posted
+# menubutton.
+# 2. As a torn-off menu copied from some other menu. In this style
+# tkPriv(postedMb) is empty, and the top-level menu is no
+# override-redirect.
+# 3. As an option menu, triggered from an option menubutton. In thi
+# style tkPriv(postedMb) identifies the posted menubutton.
+# 4. As a popup menu. In this style tkPriv(postedMb) is empty and
+# the top-level menu is override-redirect.
+#
+# The various binding procedures use the state described above to
+# distinguish the various cases and take different actions in each
+# case.
+#-------------------------------------------------------------------------
+# Bind --
+# This procedure is invoked the first time the mouse enters a menubutton
+# widget or a menubutton widget receives the input focus. It creates
+# all of the class bindings for both menubuttons and menus.
+#
+# Arguments:
+# w - The widget that was just entered or just received
+# the input focus.
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ # Must set focus when mouse enters a menu, in order to allow
+ # mixed-mode processing using both the mouse and the keyboard.
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', ['Leave',Ev('X'),Ev('Y'),Ev('s')]);
+ $mw->bind($class,'<Motion>', ['Motion',Ev('x'),Ev('y'),Ev('s')]);
+ $mw->bind($class,'<ButtonPress>','ButtonDown');
+ $mw->bind($class,'<ButtonRelease>',['Invoke',1]);
+ $mw->bind($class,'<space>',['Invoke',0]);
+ $mw->bind($class,'<Return>',['Invoke',0]);
+ $mw->bind($class,'<Escape>','Escape');
+ $mw->bind($class,'<Left>','LeftArrow');
+ $mw->bind($class,'<Right>','RightArrow');
+ $mw->bind($class,'<Up>','UpArrow');
+ $mw->bind($class,'<Down>','DownArrow');
+ $mw->bind($class,'<KeyPress>', ['TraverseWithinMenu',Ev('K')]);
+ $mw->bind($class,'<Alt-KeyPress>', ['TraverseWithinMenu',Ev('K')]);
+ return $class;
+}
+
+sub UpArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextMenu('left');
+ }
+ else
+ {
+ $menu->NextEntry(-1);
+ }
+}
+
+sub DownArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextMenu('right');
+ }
+ else
+ {
+ $menu->NextEntry(1);
+ }
+}
+
+sub LeftArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextEntry(-1);
+ }
+ else
+ {
+ $menu->NextMenu('left');
+ }
+}
+
+sub RightArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextEntry(1);
+ }
+ else
+ {
+ $menu->NextMenu('right');
+ }
+}
+
+
+
+# Unpost --
+# This procedure unposts a given menu, plus all of its ancestors up
+# to (and including) a menubutton, if any. It also restores various
+# values to what they were before the menu was posted, and releases
+# a grab if there's a menubutton involved. Special notes:
+# 1. It's important to unpost all menus before releasing the grab, so
+# that any Enter-Leave events (e.g. from menu back to main
+# application) have mode NotifyGrab.
+# 2. Be sure to enclose various groups of commands in "catch" so that
+# the procedure will complete even if the menubutton or the menu
+# or the grab window has been deleted.
+#
+# Arguments:
+# menu - Name of a menu to unpost. Ignored if there
+# is a posted menubutton.
+sub Unpost
+{
+ my $menu = shift;
+ my $mb = $Tk::postedMb;
+
+ # Restore focus right away (otherwise X will take focus away when
+ # the menu is unmapped and under some window managers (e.g. olvwm)
+ # we'll lose the focus completely).
+
+ eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus);
+ undef $Tk::focus;
+
+ # Unpost menu(s) and restore some stuff that's dependent on
+ # what was posted.
+ eval {local $SIG{__DIE__};
+ if (defined $mb)
+ {
+ $menu = $mb->cget('-menu');
+ $menu->unpost();
+ $Tk::postedMb = undef;
+ $mb->configure('-cursor',$Tk::cursor);
+ $mb->configure('-relief',$Tk::relief)
+ }
+ elsif (defined $Tk::popup)
+ {
+ $Tk::popup->unpost();
+ my $grab = $Tk::popup->grabCurrent;
+ $grab->grabRelease if (defined $grab);
+
+ undef $Tk::popup;
+ }
+ elsif (defined $menu && ref $menu &&
+ $menu->cget('-type') ne 'menubar' &&
+ $menu->cget('-type') ne 'tearoff'
+ )
+ {
+ # We're in a cascaded sub-menu from a torn-off menu or popup.
+ # Unpost all the menus up to the toplevel one (but not
+ # including the top-level torn-off one) and deactivate the
+ # top-level torn off menu if there is one.
+ while (1)
+ {
+ my $parent = $menu->parent;
+ last if (!$parent->IsMenu || !$parent->ismapped);
+ $parent->postcascade('none');
+ $parent->GenerateMenuSelect;
+ $parent->activate('none');
+ my $type = $parent->cget('-type');
+ last if ($type eq 'menubar' || $type eq 'tearoff');
+ $menu = $parent
+ }
+ $menu->unpost() if ($menu->cget('-type') ne 'menubar');
+ }
+ };
+ warn "$@" if ($@);
+ if ($Tk::tearoff || $Tk::menubar)
+ {
+ # Release grab, if any.
+ if (defined $menu && ref $menu)
+ {
+ my $grab = $menu->grabCurrent;
+ $grab->grabRelease if (defined $grab);
+ }
+ RestoreOldGrab();
+ if ($Tk::menubar)
+ {
+ $Tk::menubar->configure(-cursor => $Tk::cursor);
+ undef $Tk::menubar;
+ }
+ if ($Tk::platform ne 'unix')
+ {
+ undef $Tk::tearoff;
+ }
+ }
+}
+
+sub RestoreOldGrab
+{
+ if (defined $Tk::oldGrab)
+ {
+ eval
+ {
+ local $SIG{__DIE__};
+ if ($Tk::grabStatus eq 'global')
+ {
+ $Tk::oldGrab->grabGlobal;
+ }
+ else
+ {
+ $Tk::oldGrab->grab;
+ }
+ };
+ undef $Tk::oldGrab;
+ }
+}
+
+sub typeIS
+{my $w = shift;
+ my $type = $w->type(shift);
+ return defined $type && $type eq shift;
+}
+
+# Motion --
+# This procedure is called to handle mouse motion events for menus.
+# It does two things. First, it resets the active element in the
+# menu, if the mouse is over the menu. Second, if a mouse button
+# is down, it posts and unposts cascade entries to match the mouse
+# position.
+#
+# Arguments:
+# menu - The menu window.
+# y - The y position of the mouse.
+# state - Modifier state (tells whether buttons are down).
+sub Motion
+{
+ my $menu = shift;
+ my $x = shift;
+ my $y = shift;
+ my $state = shift;
+ my $t = $menu->cget('-type');
+
+ if ($menu->IS($Tk::window))
+ {
+ if ($menu->cget('-type') eq 'menubar')
+ {
+# if (defined($Tk::focus) && $Tk::focus != $menu)
+ {
+ $menu->activate("\@$x,$y");
+ $menu->GenerateMenuSelect;
+ }
+ }
+ else
+ {
+ $menu->activate("\@$x,$y");
+ $menu->GenerateMenuSelect;
+ }
+ }
+ if (($state & 0x1f00) != 0)
+ {
+ $menu->postcascade('active')
+ }
+}
+# ButtonDown --
+# Handles button presses in menus. There are a couple of tricky things
+# here:
+# 1. Change the posted cascade entry (if any) to match the mouse position.
+# 2. If there is a posted menubutton, must grab to the menubutton so
+# that it can track mouse motions over other menubuttons and change
+# the posted menu.
+# 3. If there's no posted menubutton (e.g. because we're a torn-off menu
+# or one of its descendants) must grab to the top-level menu so that
+# we can track mouse motions across the entire menu hierarchy.
+
+#
+# Arguments:
+# menu - The menu window.
+sub ButtonDown
+{
+ my $menu = shift;
+ return if (!$menu->viewable);
+ $menu->postcascade('active');
+ if (defined $Tk::postedMb && $Tk::postedMb->viewable)
+ {
+ $Tk::postedMb->grabGlobal
+ }
+ else
+ {
+ while ($menu->cget('-type') eq 'normal'
+ && $menu->parent->IsMenu
+ && $menu->parent->ismapped
+ )
+ {
+ $menu = $menu->parent;
+ }
+
+ if (!defined $Tk::menuBar)
+ {
+ $Tk::menuBar = $menu;
+ $Tk::cursor = $menu->cget('-cursor');
+ $menu->configure(-cursor => 'arrow');
+ }
+
+ # Don't update grab information if the grab window isn't changing.
+ # Otherwise, we'll get an error when we unpost the menus and
+ # restore the grab, since the old grab window will not be viewable
+ # anymore.
+
+ $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent));
+
+ # Must re-grab even if the grab window hasn't changed, in order
+ # to release the implicit grab from the button press.
+
+ $menu->grabGlobal if ($Tk::platform eq 'unix');
+ }
+}
+
+sub Enter
+{
+ my $w = shift;
+ my $ev = $w->XEvent;
+ $Tk::window = $w;
+ if ($w->cget('-type') eq 'tearoff')
+ {
+ if ($ev->m ne 'NotifyUngrab')
+ {
+ $w->SetFocus if ($Tk::platform eq 'unix');
+ }
+ }
+ $w->Motion($ev->x, $ev->y, $ev->s);
+}
+
+# Leave --
+# This procedure is invoked to handle Leave events for a menu. It
+# deactivates everything unless the active element is a cascade element
+# and the mouse is now over the submenu.
+#
+# Arguments:
+# menu - The menu window.
+# rootx, rooty - Root coordinates of mouse.
+# state - Modifier state.
+sub Leave
+{
+ my $menu = shift;
+ my $rootx = shift;
+ my $rooty = shift;
+ my $state = shift;
+ undef $Tk::window;
+ return if ($menu->index('active') eq 'none');
+ if ($menu->typeIS('active','cascade'))
+ {
+ my $c = $menu->Containing($rootx,$rooty);
+ return if (defined $c && $menu->entrycget('active','-menu')->IS($c));
+ }
+ $menu->activate('none');
+ $menu->GenerateMenuSelect;
+}
+
+# Invoke --
+# This procedure is invoked when button 1 is released over a menu.
+# It invokes the appropriate menu action and unposts the menu if
+# it came from a menubutton.
+#
+# Arguments:
+# w - Name of the menu widget.
+sub Invoke
+{
+ my $w = shift;
+ my $release = shift;
+
+ if ($release && !defined($Tk::window))
+ {
+ # Mouse was pressed over a menu without a menu button, then
+ # dragged off the menu (possibly with a cascade posted) and
+ # released. Unpost everything and quit.
+
+ $w->postcascade('none');
+ $w->activate('none');
+ $w->eventGenerate('<<MenuSelect>>');
+ $w->Unpost;
+ return;
+ }
+
+ my $type = $w->type('active');
+ if ($w->typeIS('active','cascade'))
+ {
+ $w->postcascade('active');
+ my $menu = $w->entrycget('active','-menu');
+ $menu->FirstEntry() if (defined $menu);
+ }
+ elsif ($w->typeIS('active','tearoff'))
+ {
+ $w->tearOffMenu();
+ $w->Unpost();
+ }
+ elsif ($w->typeIS('active','menubar'))
+ {
+ $w->postcascade('none');
+ $w->activate('none');
+ $w->eventGenerate('<<MenuSelect>>');
+ $w->Unpost;
+ }
+ else
+ {
+ $w->Unpost();
+ $w->invoke('active')
+ }
+}
+# Escape --
+# This procedure is invoked for the Cancel (or Escape) key. It unposts
+# the given menu and, if it is the top-level menu for a menu button,
+# unposts the menu button as well.
+#
+# Arguments:
+# menu - Name of the menu window.
+sub Escape
+{
+ my $menu = shift;
+ my $parent = $menu->parent;
+ if (!$parent->IsMenu)
+ {
+ $menu->Unpost()
+ }
+ elsif ($parent->cget('-type') eq 'menubar')
+ {
+ $menu->Unpost;
+ RestoreOldGrab();
+ }
+ else
+ {
+ $menu->NextMenu(-1)
+ }
+}
+# LeftRight --
+# This procedure is invoked to handle "left" and "right" traversal
+# motions in menus. It traverses to the next menu in a menu bar,
+# or into or out of a cascaded menu.
+#
+# Arguments:
+# menu - The menu that received the keyboard
+# event.
+# direction - Direction in which to move: "left" or "right"
+sub NextMenu
+{
+ my $menu = shift;
+ my $direction = shift;
+ # First handle traversals into and out of cascaded menus.
+ my $count;
+ if ($direction eq 'right')
+ {
+ $count = 1;
+ if ($menu->typeIS('active','cascade'))
+ {
+ $menu->postcascade('active');
+ my $m2 = $menu->entrycget('active','-menu');
+ $m2->FirstEntry if (defined $m2);
+ return;
+ }
+ else
+ {
+ my $parent = $menu->parent;
+ while ($parent->PathName ne '.')
+ {
+ if ($parent->IsMenu && $parent->cget('-type') eq 'menubar')
+ {
+ $parent->SetFocus;
+ $parent->NextEntry(1);
+ return;
+ }
+ $parent = $parent->parent;
+ }
+ }
+ }
+ else
+ {
+ $count = -1;
+ my $m2 = $menu->parent;
+ if ($m2->IsMenu)
+ {
+ $menu->activate('none');
+ $menu->GenerateMenuSelect;
+ $m2->SetFocus;
+
+ $m2->postcascade('none');
+
+ if ($m2->cget('-type') ne 'menubar')
+ {
+ return;
+ }
+ }
+ }
+ # Can't traverse into or out of a cascaded menu. Go to the next
+ # or previous menubutton, if that makes sense.
+
+ my $m2 = $menu->parent;
+ if ($m2->IsMenu)
+ {
+ if ($m2->cget('-type') eq 'menubar')
+ {
+ $m2->SetFocus;
+ $m2->NextEntry(-1);
+ return;
+ }
+ }
+
+ my $w = $Tk::postedMb;
+ return unless defined $w;
+ my @buttons = $w->parent->children;
+ my $length = @buttons;
+ my $i = Tk::lsearch(\@buttons,$w)+$count;
+ my $mb;
+ while (1)
+ {
+ while ($i < 0)
+ {
+ $i += $length
+ }
+ while ($i >= $length)
+ {
+ $i += -$length
+ }
+ $mb = $buttons[$i];
+ last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled'
+ && defined($mb->cget('-menu'))
+ && $mb->cget('-menu')->index('last') ne 'none'
+ );
+ return if ($mb == $w);
+ $i += $count
+ }
+ $mb->PostFirst();
+}
+# NextEntry --
+# Activate the next higher or lower entry in the posted menu,
+# wrapping around at the ends. Disabled entries are skipped.
+#
+# Arguments:
+# menu - Menu window that received the keystroke.
+# count - 1 means go to the next lower entry,
+# -1 means go to the next higher entry.
+sub NextEntry
+{
+ my $menu = shift;
+ my $count = shift;
+ if ($menu->index('last') eq 'none')
+ {
+ return;
+ }
+ my $length = $menu->index('last')+1;
+ my $quitAfter = $length;
+ my $active = $menu->index('active');
+ my $i = ($active eq 'none') ? 0 : $active+$count;
+ while (1)
+ {
+ return if ($quitAfter <= 0);
+ while ($i < 0)
+ {
+ $i += $length
+ }
+ while ($i >= $length)
+ {
+ $i += -$length
+ }
+ my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') };
+ last if (defined($state) && $state ne 'disabled');
+ return if ($i == $active);
+ $i += $count;
+ $quitAfter -= 1;
+ }
+ $menu->activate($i);
+ $menu->GenerateMenuSelect;
+ if ($menu->cget('-type') eq 'menubar' && $menu->type($i) eq 'cascade')
+ {
+ my $cascade = $menu->entrycget($i, '-menu');
+ $menu->postcascade($i);
+ $cascade->FirstEntry if (defined $cascade);
+ }
+}
+
+
+# tkTraverseWithinMenu
+# This procedure implements keyboard traversal within a menu. It
+# searches for an entry in the menu that has "char" underlined. If
+# such an entry is found, it is invoked and the menu is unposted.
+#
+# Arguments:
+# w - The name of the menu widget.
+# char - The character to look for; case is
+# ignored. If the string is empty then
+# nothing happens.
+sub TraverseWithinMenu
+{
+ my $w = shift;
+ my $char = shift;
+ return unless (defined $char);
+ $char = "\L$char";
+ my $last = $w->index('last');
+ return if ($last eq 'none');
+ for (my $i = 0;$i <= $last;$i += 1)
+ {
+ my $label = eval {local $SIG{__DIE__}; $w->entrycget($i,'-label') };
+ next unless defined($label);
+ my $ul = $w->entrycget($i,'-underline');
+ if (defined $ul && $ul >= 0)
+ {
+ $label = substr("\L$label",$ul,1);
+ if (defined($label) && $label eq $char)
+ {
+ if ($w->type($i) eq 'cascade')
+ {
+ $w->postcascade($i);
+ $w->activate($i);
+ my $m2 = $w->entrycget($i,'-menu');
+ $m2->FirstEntry if (defined $m2);
+ }
+ else
+ {
+ $w->Unpost();
+ $w->invoke($i);
+ }
+ return;
+ }
+ }
+ }
+}
+
+sub FindMenu
+{
+ my ($menu,$char) = @_;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ if (!defined($char) || $char eq '')
+ {
+ $menu->FirstEntry;
+ }
+ else
+ {
+ $menu->TraverseWithinMenu($char);
+ }
+ return $menu;
+ }
+ return undef;
+}
+
+
+# FirstEntry --
+# Given a menu, this procedure finds the first entry that isn't
+# disabled or a tear-off or separator, and activates that entry.
+# However, if there is already an active entry in the menu (e.g.,
+# because of a previous call to tkPostOverPoint) then the active
+# entry isn't changed. This procedure also sets the input focus
+# to the menu.
+#
+# Arguments:
+# menu - Name of the menu window (possibly empty).
+sub FirstEntry
+{
+ my $menu = shift;
+ return if (!defined($menu) || $menu eq '' || !ref($menu));
+ $menu->SetFocus;
+ return if ($menu->index('active') ne 'none');
+ my $last = $menu->index('last');
+ return if ($last eq 'none');
+ for (my $i = 0;$i <= $last;$i += 1)
+ {
+ my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') };
+ if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff'))
+ {
+ $menu->activate($i);
+ $menu->GenerateMenuSelect;
+ if ($menu->type($i) eq 'cascade')
+ {
+ my $cascade = $menu->entrycget($i,'-menu');
+ if (0 && defined $cascade)
+ {
+ $menu->postcascade($i);
+ $cascade->FirstEntry;
+ }
+ }
+ return;
+ }
+ }
+}
+
+# FindName --
+# Given a menu and a text string, return the index of the menu entry
+# that displays the string as its label. If there is no such entry,
+# return an empty string. This procedure is tricky because some names
+# like "active" have a special meaning in menu commands, so we can't
+# always use the "index" widget command.
+#
+# Arguments:
+# menu - Name of the menu widget.
+# s - String to look for.
+sub FindName
+{
+ my $menu = shift;
+ my $s = shift;
+ my $i = undef;
+ if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/)
+ {
+ $i = eval {local $SIG{__DIE__}; $menu->index($s) };
+ return $i;
+ }
+ my $last = $menu->index('last');
+ return if ($last eq 'none');
+ for ($i = 0;$i <= $last;$i += 1)
+ {
+ my $label = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-label') };
+ return $i if (defined $label && $label eq $s);
+ }
+ return undef;
+}
+# PostOverPoint --
+# This procedure posts a given menu such that a given entry in the
+# menu is centered over a given point in the root window. It also
+# activates the given entry.
+#
+# Arguments:
+# menu - Menu to post.
+# x, y - Root coordinates of point.
+# entry - Index of entry within menu to center over (x,y).
+# If omitted or specified as {}, then the menu's
+# upper-left corner goes at (x,y).
+sub PostOverPoint
+{
+ my $menu = shift;
+ my $x = shift;
+ my $y = shift;
+ my $entry = shift;
+ if (defined $entry)
+ {
+ if ($entry == $menu->index('last'))
+ {
+ $y -= ($menu->yposition($entry)+$menu->height)/2;
+ }
+ else
+ {
+ $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2;
+ }
+ $x -= $menu->reqwidth/2;
+ }
+ $menu->post($x,$y);
+ if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled')
+ {
+ $menu->activate($entry);
+ $menu->GenerateMenuSelect;
+ }
+}
+# tk_popup --
+# This procedure pops up a menu and sets things up for traversing
+# the menu and its submenus.
+#
+# Arguments:
+# menu - Name of the menu to be popped up.
+# x, y - Root coordinates at which to pop up the
+# menu.
+# entry - Index of a menu entry to center over (x,y).
+# If omitted or specified as {}, then menu's
+# upper-left corner goes at (x,y).
+sub Post
+{
+ my $menu = shift;
+ return unless (defined $menu);
+ my $x = shift;
+ my $y = shift;
+ my $entry = shift;
+ Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb));
+ $menu->PostOverPoint($x,$y,$entry);
+ if ($Tk::platform eq 'unix' && $menu->viewable)
+ {
+ $menu->grabGlobal;
+ $Tk::popup = $menu;
+ $Tk::focus = $menu->focusCurrent;
+ $menu->focus();
+ }
+}
+
+sub SetFocus
+{
+ my $menu = shift;
+ $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus));
+ $menu->focus;
+}
+
+sub GenerateMenuSelect
+{
+ my $menu = shift;
+ $Tk::activeMenu = $menu;
+ $Tk::activeItem = $menu->index('active');
+ $menu->eventGenerate('<<MenuSelect>>'); # FIXME
+}
+
+# Converted from tearoff.tcl --
+#
+# This file contains procedures that implement tear-off menus.
+#
+# @(#) tearoff.tcl 1.3 94/12/17 16:05:25
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# 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.
+#
+# tkTearoffMenu --
+# Given the name of a menu, this procedure creates a torn-off menu
+# that is identical to the given menu (including nested submenus).
+# The new torn-off menu exists as a toplevel window managed by the
+# window manager. The return value is the name of the new menu.
+#
+# Arguments:
+# w - The menu to be torn-off (duplicated).
+sub tearOffMenu
+{
+ my $w = shift;
+ my $x = (@_) ? shift : 0;
+ my $y = (@_) ? shift : 0;
+
+ $x = $w->rootx if $x == 0;
+ $y = $w->rooty if $y == 0;
+
+ # Find a unique name to use for the torn-off menu. Find the first
+ # ancestor of w that is a toplevel but not a menu, and use this as
+ # the parent of the new menu. This guarantees that the torn off
+ # menu will be on the same screen as the original menu. By making
+ # it a child of the ancestor, rather than a child of the menu, it
+ # can continue to live even if the menu is deleted; it will go
+ # away when the toplevel goes away.
+
+ my $parent = $w->parent;
+ while ($parent->toplevel != $parent || $parent->IsMenu)
+ {
+ $parent = $parent->parent;
+ }
+ my $menu = $w->clone($parent->PathName,'tearoff');
+
+ # Pick a title for the new menu by looking at the parent of the
+ # original: if the parent is a menu, then use the text of the active
+ # entry. If it's a menubutton then use its text.
+ my $title = $w->cget('-title');
+ # print ref($w),' ',$w->PathName," ",$menu->PathName," $w\n";
+ unless (defined $title && length($title))
+ {
+ $parent = $w->parent;
+ if ($parent)
+ {
+ if ($parent->IsMenubutton)
+ {
+ $title = $parent->cget('-text');
+ }
+ elsif ($parent->IsMenu)
+ {
+ $title = $parent->entrycget('active','-label');
+ }
+ }
+ }
+ $menu->title($title) if (defined $title && length($title));
+ $menu->post($x,$y);
+
+ if (!Tk::Exists($menu))
+ {
+ return;
+ }
+
+ # Set tkPriv(focus) on entry: otherwise the focus will get lost
+ # after keyboard invocation of a sub-menu (it will stay on the
+ # submenu).
+
+
+ # This seems to conflict with <Enter> class binding above
+ # if this fires before the class binding the wrong thing
+ # will get saved in $Tk::focus
+ # $menu->bind('<Enter>','EnterFocus');
+ $menu->Callback('-tearoffcommand');
+
+ # Strangely tear-off menus do not work in tkpod and Tk804.027.
+ # Explicitely setting normal state helps here - why?
+ $menu->state("normal");
+
+ return $menu;
+}
+
+# tkMenuDup --
+# Given a menu (hierarchy), create a duplicate menu (hierarchy)
+# in a given window.
+#
+# Arguments:
+# src - Source window. Must be a menu. It and its
+# menu descendants will be duplicated at path.
+# path - Name to use for topmost menu in duplicate
+# hierarchy.
+
+sub tkMenuDup
+{
+ my ($src,$path,$type) = @_;
+ my ($pname,$name) = $path =~ /^(.*)\.([^\.]*)$/;
+ ($name) = $src->PathName =~ /^.*\.([^\.]*)$/ unless $name;
+ my $parent = ($pname) ? $src->Widget($pname) : $src->MainWindow;
+ my %args = (Name => $name, -type => $type);
+ foreach my $option ($src->configure())
+ {
+ next if (@$option == 2);
+ $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]};
+ }
+ my $dst = ref($src)->new($parent,%args);
+ # print "MenuDup $src $path $name $type ->",$dst->PathName,"\n";
+ $_[1] = $dst;
+ if ($type eq 'tearoff')
+ {
+ $dst->transient($parent->toplevel);
+ }
+ my $last = $src->index('last');
+ if ($last ne 'none')
+ {
+ for (my $i = $src->cget('-tearoff'); $i <= $last; $i++)
+ {
+ my $type = $src->type($i);
+ if (defined $type)
+ {
+ my @args = ();
+ foreach my $option ($src->entryconfigure($i))
+ {
+ next if (@$option == 2);
+ push(@args,$$option[0],$$option[4]) if (defined $$option[4]);
+ }
+ $dst->add($type,@args);
+ }
+ }
+ }
+ # Duplicate the binding tags and bindings from the source menu.
+ my @bindtags = $src->bindtags;
+ $path = $src->PathName;
+ foreach (@bindtags)
+ {
+ $_ = $dst if ($_ eq $path);
+ }
+ $dst->bindtags([@bindtags]);
+ foreach my $event ($src->bind)
+ {
+ my $cb = $src->bind($event);
+# print "$event => $cb\n";
+ $dst->bind($event,$cb->Substitute($src,$dst));
+ }
+ return $dst;
+}
+
+
+
+# Some convenience methods
+
+sub separator { require Tk::Menu::Item; shift->Separator(@_); }
+sub cascade { require Tk::Menu::Item; shift->Cascade(@_); }
+sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); }
+sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); }
+
+sub command
+{
+ my ($menu,%args) = @_;
+ require Tk::Menu::Item;
+ if (exists $args{-button})
+ {
+ # Backward compatible stuff from 'Menubar'
+ my $button = delete $args{-button};
+ $button = ['Misc', -underline => 0 ] unless (defined $button);
+ my @bargs = ();
+ ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY');
+ $menu = $menu->Menubutton(-label => $button, @bargs);
+ }
+ $menu->Command(%args);
+}
+
+sub Menubutton
+{
+ my ($menu,%args) = @_;
+ my $name = delete($args{'-text'}) || $args{'-label'};;
+ $args{'-label'} = $name if (defined $name);
+ my $items = delete $args{'-menuitems'};
+ foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill))
+ {
+ delete $args{$opt};
+ }
+ if (defined($name) && !defined($args{-underline}))
+ {
+ my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef;
+ if (defined($underline) && ($underline >= 0))
+ {
+ $args{-underline} = $underline;
+ $args{-label} = $name;
+ }
+ }
+ my $hash = $menu->TkHash('MenuButtons');
+ my $mb = $hash->{$name};
+ if (defined $mb)
+ {
+ delete $args{'-tearoff'}; # too late!
+ $mb->configure(%args) if %args;
+ }
+ else
+ {
+ $mb = $menu->cascade(%args);
+ $hash->{$name} = $mb;
+ }
+ $mb->menu->AddItems(@$items) if defined($items) && @$items;
+ return $mb;
+}
+
+sub BalloonInfo
+{
+ my ($menu,$balloon,$X,$Y,@opt) = @_;
+ my $i = $menu->index('active');
+ if ($i eq 'none')
+ {
+ my $y = $Y - $menu->rooty;
+ $i = $menu->index("\@$y");
+ }
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$menu);
+ if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
+ {
+ $balloon->Subclient($i);
+ return '' if $i eq 'none';
+ return ${$info}[$i] || '';
+ }
+ return $info;
+ }
+}
+
+sub MasterMenu
+{
+ my ($menu) = @_;
+ my $pathname = $menu->PathName;
+ my $master_menu;
+ if ($pathname =~ m{#})
+ {
+ my $master_pathname = (split m{\.}, $pathname)[-1];
+ $master_pathname =~ s{#}{.}g;
+ $master_menu = $menu->Widget($master_pathname);
+ if (0 && !Tk::Exists($master_menu))
+ {
+ warn "Cannot find master menu <$master_pathname>";
+ }
+ }
+ $master_menu;
+}
+
+
+# ::tk::AmpMenuArgs --
+# Processes arguments for a menu entry, turning -label option into
+# -label and -underline options, returned by ::tk::UnderlineAmpersand.
+#
+sub AmpArgs
+{
+ my ($w, $add, $type, %args) = @_;
+ my @options;
+ while(my($opt,$val) = each %args)
+ {
+ if ($opt eq "-label")
+ {
+ my ($newtext,$under) = $w->UnderlineAmpersand($val);
+ push @options, -label => $newtext, -underline => $under;
+ }
+ else
+ {
+ push @options, $opt, $val;
+ }
+ }
+ $w->$type(@options);
+}
+
+1;
+
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Menu.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Menu.pod
new file mode 100755
index 00000000000..b7414e57510
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Menu.pod
@@ -0,0 +1,876 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Menu - Create and manipulate Menu widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+S< >I<$menu> = I<$parent>-E<gt>B<Menu>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground> B<-background> B<-disabledforeground> B<-relief>
+B<-activeborderwidth> B<-borderwidth> B<-font> B<-takefocus>
+B<-activeforeground> B<-cursor> B<-foreground>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<postCommand>
+
+=item Class: B<Command>
+
+=item Switch: B<-postcommand>
+
+If this option is specified then it provides a L<callback|Tk::callbacks> to execute
+each time the menu is posted. The callback is invoked by the B<post>
+method before posting the menu. Note that in 8.0 on Macintosh
+and Windows, all commands in a menu systems are executed before any
+are posted. This is due to the limitations in the individual platforms'
+menu managers.
+
+=item Name: B<selectColor>
+
+=item Class: B<Background>
+
+=item Switch: B<-selectcolor>
+
+For menu entries that are check buttons or radio buttons, this option
+specifies the color to display in the indicator when the check button
+or radio button is selected.
+
+=item Name: B<tearOff>
+
+=item Class: B<TearOff>
+
+=item Switch: B<-tearoff>
+
+This option must have a proper boolean value, which specifies
+whether or not the menu should include a tear-off entry at the
+top. If so, it will exist as entry 0 of the menu and the other
+entries will number starting at 1. The default
+menu bindings arrange for the menu to be torn off when the tear-off
+entry is invoked.
+
+=item Name: B<tearOffCommand>
+
+=item Class: B<TearOffCommand>
+
+=item Switch: B<-tearoffcommand>
+
+If this option has a non-empty value, then it specifies a L<perl/Tk callback|Tk::callbacks>
+to invoke whenever the menu is torn off. The actual command will
+consist of the value of this option, followed by a space, followed
+by the name of the menu window, followed by a space, followed by
+the name of the name of the torn off menu window. For example, if
+the option's is ``B<a b>'' and menu B<.x.y> is torn off to
+create a new menu B<.x.tearoff1>, then the command
+``B<a b .x.y .x.tearoff1>'' will be invoked.
+
+=item Name: B<title>
+
+=item Class: B<Title>
+
+=item Switch: B<-title>
+
+The string will be used to title the window created when this menu is
+torn off. If the title is NULL, then the window will have the title
+of the menubutton or the text of the cascade item from which this menu
+was invoked.
+
+=item Name: B<type>
+
+=item Class: B<Type>
+
+=item Switch: B<-type>
+
+This option can be one of B<menubar>, B<tearoff>, or
+B<normal>, and is set when the menu is created. While the string
+returned by the configuration database will change if this option is
+changed, this does not affect the menu widget's behavior. This is used
+by the cloning mechanism and is not normally set outside of the Tk
+library.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Menu> method creates a new top-level window (given
+by the $widget argument) and makes it into a menu widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the menu such as its colors and font.
+The B<menu> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A menu is a widget that displays a collection of one-line entries arranged
+in one or more columns. There exist several different types of entries,
+each with different properties. Entries of different types may be
+combined in a single menu. Menu entries are not the same as
+entry widgets. In fact, menu entries are not even distinct widgets;
+the entire menu is one widget.
+
+Menu entries are displayed with up to three separate fields.
+The main field is a label in the form of a text string,
+a bitmap, or an image, controlled by the B<-label>,
+B<-bitmap>, and B<-image> options for the entry.
+If the B<-accelerator> option is specified for an entry then a second
+textual field is displayed to the right of the label. The accelerator
+typically describes a keystroke sequence that may be typed in the
+application to cause the same result as invoking the menu entry.
+The third field is an I<indicator>. The indicator is present only for
+checkbutton or radiobutton entries. It indicates whether the entry
+is selected or not, and is displayed to the left of the entry's
+string.
+
+In normal use, an entry becomes active (displays itself differently)
+whenever the mouse pointer is over the entry. If a mouse
+button is released over the entry then the entry is I<invoked>.
+The effect of invocation is different for each type of entry;
+these effects are described below in the sections on individual
+entries.
+
+Entries may be I<disabled>, which causes their labels
+and accelerators to be displayed
+with dimmer colors.
+The default menu bindings will not allow
+a disabled entry to be activated or invoked.
+Disabled entries may be re-enabled, at which point it becomes
+possible to activate and invoke them again.
+
+Whenever a menu's active entry is changed, a E<lt>E<lt>MenuSelectE<gt>E<gt> virtual
+event is sent to the menu. The active item can then be queried from
+the menu, and an action can be taken, such as setting
+context-sensitive help text for the entry.
+
+=head2 COMMAND ENTRIES
+
+The most common kind of menu entry is a command entry, which
+behaves much like a button widget. When a command entry is
+invoked, a callback is executed. The callback
+is specified with the B<-command> option.
+
+=head2 SEPARATOR ENTRIES
+
+A separator is an entry that is displayed as a horizontal dividing
+line. A separator may not be activated or invoked, and it has
+no behavior other than its display appearance.
+
+=head2 CHECKBUTTON ENTRIES
+
+A checkbutton menu entry behaves much like a checkbutton widget.
+When it is invoked it toggles back and forth between the selected
+and deselected states. When the entry is selected, a particular
+value is stored in a particular global variable (as determined by
+the B<-onvalue> and B<-variable> options for the entry); when
+the entry is deselected another value (determined by the
+B<-offvalue> option) is stored in the global variable.
+An indicator box is displayed to the left of the label in a checkbutton
+entry. If the entry is selected then the indicator's center is displayed
+in the color given by the B<-selectcolor> option for the entry;
+otherwise the indicator's center is displayed in the background color for
+the menu. If a B<-command> option is specified for a checkbutton
+entry, then its value is evaluated each time the entry
+is invoked; this happens after toggling the entry's
+selected state.
+
+=head2 RADIOBUTTON ENTRIES
+
+A radiobutton menu entry behaves much like a radiobutton widget.
+Radiobutton entries are organized in groups of which only one
+entry may be selected at a time. Whenever a particular entry
+becomes selected it stores a particular value into a particular
+global variable (as determined by the B<-value> and
+B<-variable> options for the entry). This action
+causes any previously-selected entry in the same group
+to deselect itself.
+Once an entry has become selected, any change to the entry's
+associated variable will cause the entry to deselect itself.
+Grouping of radiobutton entries is determined by their
+associated variables: if two entries have the same associated
+variable then they are in the same group.
+An indicator diamond is displayed to the left of the label in each
+radiobutton entry. If the entry is selected then the indicator's
+center is displayed in the color given by the B<-selectcolor> option
+for the entry;
+otherwise the indicator's center is displayed in the background color for
+the menu. If a B<-command> option is specified for a radiobutton
+entry, then its value is evaluated each time the entry
+is invoked; this happens after selecting the entry.
+
+=head2 CASCADE ENTRIES
+
+A cascade entry is one with an associated menu (determined
+by the B<-menu> option). Cascade entries allow the construction
+of cascading menus.
+The B<postcascade> method can be used to post and unpost
+the associated menu just next to of the cascade entry.
+The associated menu must be a child of the menu containing
+the cascade entry (this is needed in order for menu traversal to
+work correctly).
+
+A cascade entry posts its associated menu by invoking
+
+=over 4
+
+I<$menu>-E<gt>B<post>(I<x,y>)
+
+=back
+
+where I<menu> is the path name of the associated menu, and I<x>
+and I<y> are the root-window coordinates of the upper-right
+corner of the cascade entry.
+On Unix, the lower-level menu is unposted by executing
+
+=over 4
+
+I<$menu>-E<gt>B<unpost>
+
+=back
+
+where I<menu> is the name of the associated menu.
+On other platforms, the platform's native code takes care of unposting the
+menu.
+
+If a B<-command> option is specified for a cascade entry then it is
+evaluated whenever the entry is invoked. This is not supported on Windows.
+
+=head2 TEAR-OFF ENTRIES
+
+A tear-off entry appears at the top of the menu if enabled with the
+B<tearOff> option. It is not like other menu entries in that
+it cannot be created with the B<add> method and
+cannot be deleted with the B<delete> method.
+When a tear-off entry is created it appears as a dashed line at
+the top of the menu. Under the default bindings, invoking the
+tear-off entry causes a torn-off copy to be made of the menu and
+all of its submenus.
+
+=head2 MENUBARS
+
+Any menu can be set as a menubar for a toplevel window (see the
+L<Toplevel|Tk::Toplevel> constructor for syntax). On the Macintosh, whenever the
+toplevel is in front, this menu's cascade items will appear in the
+menubar across the top of the main monitor. On Windows and Unix, this
+menu's items will be displayed in a menubar accross the top of the
+window. These menus will behave according to the interface guidelines
+of their platforms. For every menu set as a menubar, a clone menu is
+made. See L<"CLONES"> for more information.
+
+As noted, menubars may behave differently on different platforms. One
+example of this concerns the handling of checkbuttons and radiobuttons
+within the menu. While it is permitted to put these menu elements on
+menubars, they may not be drawn with indicators on some platforms, due
+to system restrictions.
+
+=head2 SPECIAL MENUS IN MENUBARS
+
+Certain menus in a menubar will be treated specially. On the Macintosh,
+access to the special Apple and Help menus is provided. On Windows,
+access to the Windows System menu in each window is provided. On X Windows,
+a special right-justified help menu is provided. In all cases, these
+menus must be created with the command name of the menubar menu concatenated
+with the special name. So for a menubar named .menubar, on the Macintosh,
+the special menus would be .menubar.apple and .menubar.help; on Windows,
+the special menu would be .menubar.system; on X Windows, the help
+menu would be .menubar.help.
+
+When Tk sees an Apple menu on the Macintosh, that menu's contents make
+up the first items of the Apple menu on the screen whenever the window
+containing the menubar is in front. The menu is the
+first one that the user sees and has a title which is an Apple logo.
+After all of the Tk-defined items, the menu will have a separator,
+followed by all of the items in the user's Apple Menu Items folder.
+Since the System uses a different menu definition procedure for
+the Apple menu than Tk uses for its menus, and the system APIs do
+not fully support everything Tk tries to do, the menu item will only
+have its text displayed. No font attributes, images, bitmaps, or colors
+will be displayed. In addition, a menu with a tearoff item will have
+the tearoff item displayed as "(TearOff)".
+
+When Tk see a Help menu on the Macintosh, the menu's contents are
+appended to the standard help menu on the right of the user's menubar
+whenever the user's menubar is in front. The first items in the menu
+are provided by Apple. Similar to the Apple Menu, cusomization in this
+menu is limited to what the system provides.
+
+When Tk sees a System menu on Windows, its items are appended to the
+system menu that the menubar is attached to. This menu has an icon
+representing a spacebar, and can be invoked with the mouse or by typing
+Alt+Spacebar. Due to limitations in the Windows API, any font changes,
+colors, images, bitmaps, or tearoff images will not appear in the
+system menu.
+
+When Tk see a Help menu on X Windows, the menu is moved to be last in
+the menubar and is right justified.
+
+=head2 CLONES
+
+When a menu is set as a menubar for a toplevel window, or when a menu
+is torn off, a clone of the menu is made. This clone is a menu widget
+in its own right, but it is a child of the original. Changes in the
+configuration of the original are reflected in the
+clone. Additionally, any cascades that are pointed to are also cloned
+so that menu traversal will work right. Clones are destroyed when
+either the tearoff or menubar goes away, or when the original menu is
+destroyed.
+
+=head2 WIDGET METHODS
+
+The B<Menu> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class, and the L<Tk::Wm|Tk::Wm> class.
+
+Many of the methods for a menu take as one argument an
+indicator of which entry of the menu to operate on. These
+indicators are called I<index>es and may be specified in
+any of the following forms:
+
+=over 4
+
+=item I<number>
+
+Specifies the entry numerically, where 0 corresponds
+to the top-most entry of the menu, 1 to the entry below it, and
+so on.
+
+=item B<active>
+
+Indicates the entry that is currently active. If no entry is
+active then this form is equivalent to B<none>. This form may
+not be abbreviated.
+
+=item B<end>
+
+Indicates the bottommost entry in the menu. If there are no
+entries in the menu then this form is equivalent to B<none>.
+This form may not be abbreviated.
+
+=item B<last>
+
+Same as B<end>.
+
+=item B<none>
+
+Indicates ``no entry at all''; this is used most commonly with
+the B<activate> option to deactivate all the entries in the
+menu. In most cases the specification of B<none> causes
+nothing to happen in the method.
+This form may not be abbreviated.
+
+=item B<@>I<number>
+
+In this form, I<number> is treated as a y-coordinate in the
+menu's window; the entry closest to that y-coordinate is used.
+For example, ``B<@0>'' indicates the top-most entry in the
+window.
+
+=item I<pattern>
+
+If the index doesn't satisfy one of the above forms then this
+form is used. I<Pattern> is pattern-matched against the label of
+each entry in the menu, in order from the top down, until a
+matching entry is found.
+(In perl/Tk the matching is under review, but exact match
+should work.)
+
+=back
+
+The following methods are possible for menu widgets:
+
+=over 4
+
+=item I<$menu>-E<gt>B<activate>(I<index>)
+
+Change the state of the entry indicated by I<index> to B<active>
+and redisplay it using its active colors.
+Any previously-active entry is deactivated. If I<index>
+is specified as B<none>, or if the specified entry is
+disabled, then the menu ends up with no active entry.
+Returns an empty string.
+
+=item I<$menu>-E<gt>B<add>(I<type, >?I<option, value, option, value, ...>?)
+
+Add a new entry to the bottom of the menu. The new entry's type
+is given by I<type> and must be one of B<cascade>,
+B<checkbutton>, B<command>, B<radiobutton>, or B<separator>,
+or a unique abbreviation of one of the above. If additional arguments
+are present, they specify any of the following options:
+
+=over 8
+
+=item B<-activebackground> =E<gt> I<value>
+
+Specifies a background color to use for displaying this entry when it
+is active.
+If this option is specified as an empty string (the default), then the
+B<activeBackground> option for the overall menu is used.
+If the B<$Tk::strictMotif> variable has been set to request strict
+Motif compliance, then this option is ignored and the B<-background>
+option is used in its place.
+This option is not available for separator or tear-off entries.
+
+=item B<-activeforeground> =E<gt> I<value>
+
+Specifies a foreground color to use for displaying this entry when it
+is active.
+If this option is specified as an empty string (the default), then the
+B<activeForeground> option for the overall menu is used.
+This option is not available for separator or tear-off entries.
+
+=item B<-accelerator> =E<gt> I<value>
+
+Specifies a string to display at the right side of the menu entry.
+Normally describes an accelerator keystroke sequence that may be
+typed to invoke the same function as the menu entry. This option
+is not available for separator or tear-off entries.
+
+=item B<-background> =E<gt> I<value>
+
+Specifies a background color to use for displaying this entry when it
+is in the normal state (neither active nor disabled).
+If this option is specified as an empty string (the default), then the
+B<background> option for the overall menu is used.
+This option is not available for separator or tear-off entries.
+
+=item B<-bitmap> =E<gt> I<value>
+
+Specifies a bitmap to display in the menu instead of a textual
+label, in any of the forms accepted by B<Tk_GetBitmap>.
+This option overrides the B<-label> option but may be reset
+to an empty string to enable a textual label to be displayed.
+If a B<-image> option has been specified, it overrides
+B<-bitmap>.
+This option is not available for separator or tear-off entries.
+
+=item B<-columnbreak> =E<gt> I<value>
+
+When this option is zero, the appears below the previous entry. When
+this option is one, the menu appears at the top of a new column in the
+menu.
+
+=item B<-compound> =E<gt> I<value>
+
+Specifies whether the button should display both an image and text,
+and if so, where the image should be placed relative to the text.
+Valid values for this option are B<bottom>, B<center>, B<left>,
+B<none>, B<right> and B<top>. The default value is B<none>, meaning
+that the button will display either an image or text, depending on the
+values of the -image and -bitmap options.
+
+=item B<-command> =E<gt> I<value>
+
+For command, checkbutton, and radiobutton entries, specifies a
+callback to execute when the menu entry is invoked.
+For cascade entries, specifies a callback to execute
+when the entry is activated (i.e. just before its submenu is
+posted).
+Not available for separator or tear-off entries.
+
+=item B<-font> =E<gt> I<value>
+
+Specifies the font to use when drawing the label or accelerator
+string in this entry.
+If this option is specified as an empty string (the default) then
+the B<font> option for the overall menu is used.
+This option is not available for separator or tear-off entries.
+
+=item B<-foreground> =E<gt> I<value>
+
+Specifies a foreground color to use for displaying this entry when it
+is in the normal state (neither active nor disabled).
+If this option is specified as an empty string (the default), then the
+B<foreground> option for the overall menu is used.
+This option is not available for separator or tear-off entries.
+
+=item B<-hidemargin> =E<gt> I<value>
+
+Specifies whether the standard margins should be drawn for this menu
+entry. This is useful when creating palette with images in them, i.e.,
+color palettes, pattern palettes, etc. 1 indicates that the margin for
+the entry is hidden; 0 means that the margin is used.
+
+=item B<-image> =E<gt> I<value>
+
+Specifies an image to display in the menu instead of a text string
+or bitmap
+The image must have been created by some previous invocation of
+B<image create>.
+This option overrides the B<-label> and B<-bitmap> options
+but may be reset to an empty string to enable a textual or
+bitmap label to be displayed.
+This option is not available for separator or tear-off entries.
+
+=item B<-indicatoron> =E<gt> I<value>
+
+Available only for checkbutton and radiobutton entries.
+I<Value> is a boolean that determines whether or not the
+indicator should be displayed.
+
+=item B<-label> =E<gt> I<value>
+
+Specifies a string to display as an identifying label in the menu
+entry. Not available for separator or tear-off entries.
+
+=item B<-menu> =E<gt> I<value>
+
+Available only for cascade entries. Specifies the path name of
+the submenu associated with this entry.
+The submenu must be a child of the menu.
+
+=item B<-offvalue> =E<gt> I<value>
+
+Available only for checkbutton entries. Specifies the value to
+store in the entry's associated variable when the entry is
+deselected.
+
+=item B<-onvalue> =E<gt> I<value>
+
+Available only for checkbutton entries. Specifies the value to
+store in the entry's associated variable when the entry is selected.
+
+=item B<-selectcolor> =E<gt> I<value>
+
+Available only for checkbutton and radiobutton entries.
+Specifies the color to display in the indicator when the entry is
+selected.
+If the value is an empty string (the default) then the B<selectColor>
+option for the menu determines the indicator color.
+
+=item B<-selectimage> =E<gt> I<value>
+
+Available only for checkbutton and radiobutton entries.
+Specifies an image to display in the entry (in place of
+the B<-image> option) when it is selected.
+I<Value> is the name of an image, which must have been created
+by some previous invocation of B<image create>.
+This option is ignored unless the B<-image> option has
+been specified.
+
+=item B<-state> =E<gt> I<value>
+
+Specifies one of three states for the entry: B<normal>, B<active>,
+or B<disabled>. In normal state the entry is displayed using the
+B<foreground> option for the menu and the B<background>
+option from the entry or the menu.
+The active state is typically used when the pointer is over the entry.
+In active state the entry is displayed using the B<activeForeground>
+option for the menu along with the B<activebackground> option from
+the entry. Disabled state means that the entry
+should be insensitive: the default bindings will refuse to activate
+or invoke the entry.
+In this state the entry is displayed according to the
+B<disabledForeground> option for the menu and the
+B<background> option from the entry.
+This option is not available for separator entries.
+
+=item B<-underline> =E<gt> I<value>
+
+Specifies the integer index of a character to underline in the entry.
+This option is also queried by the default bindings and used to
+implement keyboard traversal.
+0 corresponds to the first character of the text displayed in the entry,
+1 to the next character, and so on.
+If a bitmap or image is displayed in the entry then this option is ignored.
+This option is not available for separator or tear-off entries.
+
+=item B<-value> =E<gt> I<value>
+
+Available only for radiobutton entries. Specifies the value to
+store in the entry's associated variable when the entry is selected.
+If an empty string is specified, then the B<-label> option
+for the entry as the value to store in the variable.
+
+=item B<-variable> =E<gt> I<value>
+
+Available only for checkbutton and radiobutton entries. Specifies
+the name of a global value to set when the entry is selected.
+For checkbutton entries the variable is also set when the entry
+is deselected. For radiobutton entries, changing the variable
+causes the currently-selected entry to deselect itself.
+
+=back
+
+The B<add> method returns an empty string.
+
+=item I<$menu>-E<gt>B<clone>(I<$parent> ?, I<cloneType?>)
+
+Makes a clone of the current menu as a child of I<$parent>. This clone
+is a menu in its own right, but any changes to the clone are
+propogated to the original menu and vice versa. I<cloneType> can be
+B<normal>, B<menubar>, or B<tearoff>. Should not normally be
+called outside of the Tk library. See L<"CLONES"> for
+more information.
+
+=item I<$menu>-E<gt>B<delete>(I<index1>?, I<index2>?)
+
+Delete all of the menu entries between I<index1> and
+I<index2> inclusive.
+If I<index2> is omitted then it defaults to I<index1>.
+Attempts to delete a tear-off menu entry are ignored (instead, you
+should change the B<tearOff> option to remove the tear-off entry).
+
+=item I<$menu>-E<gt>B<entrycget>(I<index, option>)
+
+Returns the current value of a configuration option for
+the entry given by I<index>.
+I<Option> may have any of the values accepted by the B<add>
+method.
+
+=item I<$menu>-E<gt>B<entryconfigure>(I<index> ?,I<options>?)
+
+This method is similar to the B<configure> method, except that
+it applies to the options for an individual entry, whereas B<configure>
+applies to the options for the menu as a whole.
+I<Options> may have any of the values accepted by the B<add>
+method. If I<options> are specified, options are modified
+as indicated
+in the method call and the method returns an empty string.
+If no I<options> are specified, returns a list describing
+the current options for entry I<index> (see L<Tk::options> for
+information on the format of this list).
+
+=item I<$menu>-E<gt>B<index>(I<index>)
+
+Returns the numerical index corresponding to I<index>, or
+B<none> if I<index> was specified as B<none>.
+
+=item I<$menu>-E<gt>B<insert>(I<index, type>?, I<-option>=E<gt>I<value>, ...?)
+
+Same as the B<add> method except that it inserts the new
+entry just before the entry given by I<index>, instead of appending
+to the end of the menu. The I<type>, I<-option>, and I<value>
+arguments have the same interpretation as for the B<add> widget
+method. It is not possible to insert new menu entries before the
+tear-off entry, if the menu has one.
+
+=item I<$menu>-E<gt>B<invoke>(I<index>)
+
+Invoke the action of the menu entry. See the sections on the
+individual entries above for details on what happens. If the
+menu entry is disabled then nothing happens. If the
+entry has a callback associated with it then the result of that
+callback is returned as the result of the B<invoke> widget
+method. Otherwise the result is an empty string. Note: invoking
+a menu entry does not automatically unpost the menu; the default
+bindings normally take care of this before invoking the B<invoke>
+method.
+
+=item I<$menu>-E<gt>B<post>(I<x, y>)
+
+Arrange for the menu to be displayed on the screen at the root-window
+coordinates given by I<x> and I<y>. These coordinates are
+adjusted if necessary to guarantee that the entire menu is visible on
+the screen. This method normally returns an empty string.
+If the B<postCommand> option has been specified, then its value is
+executed before posting the menu and the result of
+that callback is returned as the result of the B<post> widget
+method.
+If an error returns while executing the method, then the error is
+returned without posting the menu.
+
+=item I<$menu>-E<gt>B<postcascade>(I<index>)
+
+Posts the submenu associated with the cascade entry given by
+I<index>, and unposts any previously posted submenu.
+If I<index> doesn't correspond to a cascade entry,
+or if I<$menu> isn't posted,
+the method has no effect except to unpost any currently posted
+submenu.
+
+=item I<$menu>-E<gt>B<type>(I<index>)
+
+Returns the type of the menu entry given by I<index>.
+This is the I<type> argument passed to the B<add> widget
+method when the entry was created, such as B<command>
+or B<separator>, or B<tearoff> for a tear-off entry.
+
+=item I<$menu>-E<gt>B<unpost>
+
+Unmap the window so that it is no longer displayed. If a
+lower-level cascaded menu is posted, unpost that menu. Returns an
+empty string. This method does not work on Windows and the
+Macintosh, as those platforms have their own way of unposting menus.
+
+=item I<$menu>-E<gt>B<yposition>(I<index>)
+
+Returns a decimal string giving the y-coordinate within the menu
+window of the topmost pixel in the entry specified by I<index>.
+
+=back
+
+=head1 MENU CONFIGURATIONS
+
+The default bindings support four different ways of using menus:
+
+=over 4
+
+=item B<Pulldown Menus in Menubar>
+
+This is the most command case. You create a menu widget that will become the
+menu bar. You then add cascade entries to this menu, specifying the
+pull down menus you wish to use in your menu bar. You then create all
+of the pulldowns. Once you have done this, specify the menu using the
+B<-menu> option of the toplevel's method. See the
+B<toplevel> manual entry for details.
+
+=item B<Pulldown Menus in Menu Buttons>
+
+This is the compatable way to do menu bars. You create one menubutton
+widget for each top-level menu, and typically you arrange a series of
+menubuttons in a row in a menubar window. You also create the top-level menus
+and any cascaded submenus, and tie them together with B<-menu>
+options in menubuttons and cascade menu entries. The top-level menu must
+be a child of the menubutton, and each submenu must be a child of the
+menu that refers to it. Once you have done this, the default bindings
+will allow users to traverse and invoke the tree of menus via its
+menubutton; see the B<menubutton> documentation for details.
+
+=item B<Popup Menus>
+
+Popup menus typically post in response to a mouse button press or
+keystroke. You create the popup menus and any cascaded submenus,
+then you call the B<Post> method at the appropriate time
+to post the top-level menu.
+
+I<$menu>-E<gt>B<Post>(I<$x>,I<$y>?,I<$entry>?)
+
+I<$x> and I<$y> are the root window coordinates at which the I<$menu>
+will be displayed. If I<$entry> is specified then that entry is centred
+on that point, otherwise the top-left corner of the I<$menu> is placed
+at that point.
+
+B<Menu> also inherits methods from L<Tk::Wm> and so the method
+B<Popup> can be used to position menu relative to other windows, the
+mouse cursor or the screen.
+
+=item B<Option Menus>
+
+An option menu consists of a menubutton with an associated menu
+that allows you to select one of several values. The current value
+is displayed in the menubutton and is also stored in a global
+variable. Use the L<Tk::Optionmenu> class to create option
+menubuttons and their menus.
+
+=item B<Torn-off Menus>
+
+You create a torn-off menu by invoking the tear-off entry at
+the top of an existing menu. The default bindings will create a new menu
+that is a copy of the original menu and leave it permanently
+posted as a top-level window. The torn-off menu behaves just
+the same as the original menu.
+
+=back
+
+=head1 DEFAULT BINDINGS
+
+Tk automatically creates class bindings for menus that give them
+the following default behavior:
+
+=over 4
+
+=item [1]
+
+When the mouse enters a menu, the entry underneath the mouse
+cursor activates; as the mouse moves around the menu, the active
+entry changes to track the mouse.
+
+=item [2]
+
+When the mouse leaves a menu all of the entries in the menu
+deactivate, except in the special case where the mouse moves from
+a menu to a cascaded submenu.
+
+=item [3]
+
+When a button is released over a menu, the active entry (if any) is invoked.
+The menu also unposts unless it is a torn-off menu.
+
+=item [4]
+
+The Space and Return keys invoke the active entry and
+unpost the menu.
+
+=item [5]
+
+If any of the entries in a menu have letters underlined with
+with B<-underline> option, then pressing one of the underlined
+letters (or its upper-case or lower-case equivalent) invokes that
+entry and unposts the menu.
+
+=item [6]
+
+The Escape key aborts a menu selection in progress without invoking any
+entry. It also unposts the menu unless it is a torn-off menu.
+
+=item [7]
+
+The Up and Down keys activate the next higher or lower entry
+in the menu. When one end of the menu is reached, the active
+entry wraps around to the other end.
+
+=item [8]
+
+The Left key moves to the next menu to the left.
+If the current menu is a cascaded submenu, then the submenu is
+unposted and the current menu entry becomes the cascade entry
+in the parent.
+If the current menu is a top-level menu posted from a
+menubutton, then the current menubutton is unposted and the
+next menubutton to the left is posted.
+Otherwise the key has no effect.
+The left-right order of menubuttons is determined by their stacking
+order: Tk assumes that the lowest menubutton (which by default
+is the first one created) is on the left.
+
+=item [9]
+
+The Right key moves to the next menu to the right.
+If the current entry is a cascade entry, then the submenu is
+posted and the current menu entry becomes the first entry
+in the submenu.
+Otherwise, if the current menu was posted from a
+menubutton, then the current menubutton is unposted and the
+next menubutton to the right is posted.
+
+Disabled menu entries are non-responsive: they don't activate and
+they ignore mouse button presses and releases.
+
+The behavior of menus can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 BUGS
+
+At present it isn't possible to use the
+option database to specify values for the options to individual
+entries.
+
+=head1 SEE ALSO
+
+L<Tk::callbacks|Tk::callbacks>
+
+=head1 KEYWORDS
+
+menu, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pm
new file mode 100755
index 00000000000..167715f9382
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pm
@@ -0,0 +1,178 @@
+package Tk::Menu::Item;
+
+require Tk::Menu;
+
+use Carp;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tk/Menu/Item.pm#4 $
+
+sub PreInit
+{
+ # Dummy (virtual) method
+ my ($class,$menu,$minfo) = @_;
+}
+
+sub new
+{
+ my ($class,$menu,%minfo) = @_;
+ my $kind = $class->kind;
+ my $name = $minfo{'-label'};
+ if (defined $kind)
+ {
+ my $invoke = delete $minfo{'-invoke'};
+ if (defined $name)
+ {
+ # Use ~ in name/label to set -underline
+ if (defined($minfo{-label}) && !defined($minfo{-underline}))
+ {
+ my $cleanlabel = $minfo{-label};
+ my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef;
+ if (defined($underline) && ($underline >= 0))
+ {
+ $minfo{-underline} = $underline;
+ $name = $cleanlabel if ($minfo{-label} eq $name);
+ $minfo{-label} = $cleanlabel;
+ }
+ }
+ }
+ else
+ {
+ $name = $minfo{'-bitmap'} || $minfo{'-image'};
+ croak('No -label') unless defined($name);
+ $minfo{'-label'} = $name;
+ }
+ $class->PreInit($menu,\%minfo);
+ $menu->add($kind,%minfo);
+ $menu->invoke('last') if ($invoke);
+ }
+ else
+ {
+ $menu->add('separator');
+ }
+ return bless [$menu,$name],$class;
+}
+
+sub configure
+{
+ my $obj = shift;
+ my ($menu,$name) = @$obj;
+ my %args = @_;
+ $obj->[1] = $args{'-label'} if exists $args{'-label'};
+ $menu->entryconfigure($name,@_);
+}
+
+sub cget
+{
+ my $obj = shift;
+ my ($menu,$name) = @$obj;
+ $menu->entrycget($name,@_);
+}
+
+sub parentMenu
+{
+ my $obj = shift;
+ return $obj->[0];
+}
+
+# Default "kind" is a command
+sub kind { return 'command' }
+
+# Now the derived packages
+
+package Tk::Menu::Separator;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Separator';
+sub kind { return undef }
+
+package Tk::Menu::Button;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Button';
+Construct Tk::Menu 'Command';
+
+#package Tk::Menu::Command;
+#use base qw(Tk::Menu::Button);
+#Construct Tk::Menu 'Command';
+
+package Tk::Menu::Cascade;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Cascade';
+sub kind { return 'cascade' }
+use Carp;
+
+sub PreInit
+{
+ my ($class,$menu,$minfo) = @_;
+ my $tearoff = delete $minfo->{-tearoff};
+ my $items = delete $minfo->{-menuitems};
+ my $widgetvar = delete $minfo->{-menuvar};
+ my $command = delete $minfo->{-postcommand};
+ my $name = delete $minfo->{'Name'};
+ $name = $minfo->{'-label'} unless defined $name;
+ my @args = ();
+ push(@args, '-tearoff' => $tearoff) if (defined $tearoff);
+ push(@args, '-menuitems' => $items) if (defined $items);
+ push(@args, '-postcommand' => $command) if (defined $command);
+ my $submenu = $minfo->{'-menu'};
+ unless (defined $submenu)
+ {
+ $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args);
+ }
+ $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar));
+}
+
+sub menu
+{
+ my ($self,%args) = @_;
+ my $w = $self->parentMenu;
+ my $menu = $self->cget('-menu');
+ if (!defined $menu)
+ {
+ require Tk::Menu;
+ $w->ColorOptions(\%args);
+ my $name = $self->cget('-label');
+ warn "Had to (re-)reate menu for $name";
+ $menu = $w->Menu(Name => $name, %args);
+ $self->configure('-menu'=>$menu);
+ }
+ else
+ {
+ $menu->configure(%args) if %args;
+ }
+ return $menu;
+}
+
+# Some convenience methods
+
+sub separator { shift->menu->Separator(@_); }
+sub command { shift->menu->Command(@_); }
+sub cascade { shift->menu->Cascade(@_); }
+sub checkbutton { shift->menu->Checkbutton(@_); }
+sub radiobutton { shift->menu->Radiobutton(@_); }
+
+sub pack
+{
+ my $w = shift;
+ if ($^W)
+ {
+ require Carp;
+ Carp::carp("Cannot 'pack' $w - done automatically")
+ }
+}
+
+package Tk::Menu::Checkbutton;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Checkbutton';
+sub kind { return 'checkbutton' }
+
+package Tk::Menu::Radiobutton;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Radiobutton';
+sub kind { return 'radiobutton' }
+
+package Tk::Menu::Item;
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pod
new file mode 100755
index 00000000000..dabaadb8a58
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Menu/Item.pod
@@ -0,0 +1,96 @@
+
+=head1 NAME
+
+Tk::Menu::Item - Base class for Menu items
+
+=for pm Tk/Menu/Item.pm
+
+=for category Implementation
+
+=head1 SYNOPSIS
+
+ require Tk::Menu::Item;
+
+ my $but = $menu->Button(...);
+ $but->configure(...);
+ my $what = $but->cget();
+
+ package Whatever;
+ require Tk::Menu::Item;
+ @ISA = qw(Tk::Menu::Item);
+
+ sub PreInit
+ {
+ my ($class,$menu,$info) = @_;
+ $info->{'-xxxxx'} = ...
+ my $y = delete $info->{'-yyyy'};
+ }
+
+=head1 DESCRIPTION
+
+Tk::Menu::Item is the base class from which Tk::Menu::Button,
+Tk::Menu::Cascade, Tk::Menu::Radiobutton and Tk::Menu::Checkbutton are derived.
+There is also a Tk::Menu::Separator.
+
+Constructors are declared so that $menu-E<gt>Button(...) etc. do what you would
+expect.
+
+The C<-label> option is pre-processed allowing ~ to be prefixed to the character
+to derive a C<-underline> value. Thus
+
+ $menu->Button(-label => 'Goto ~Home',...)
+
+ is equivalent to
+
+ $menu->Button(-label => 'Goto Home', -underline => 6, ...)
+
+The C<Cascade> menu item creates a sub-menu and accepts
+these options:
+
+=over 4
+
+=item B<-menuitems>
+
+A list of items for the sub-menu.
+Within this list (which is also accepted by Menu and Menubutton) the first
+two elements of each item should be the "constructor" name and the label:
+
+ -menuitems => [
+ [Button => '~Quit', -command => [destroy => $mw]],
+ [Checkbutton => '~Oil', -variable => \$oil],
+ ]
+
+=item B<-postcommand>
+
+A callback to be invoked before posting the menu.
+
+=item B<-tearoff>
+
+Specifies whether sub-menu can be torn-off or not.
+
+=item B<-menuvar>
+
+Scalar reference that will be set to the newly-created sub-menu.
+
+=back
+
+The returned object is currently a blessed reference to an array of two items:
+the containing Menu and the 'label'.
+Methods C<configure> and C<cget> are mapped onto underlying C<entryconfigure>
+and C<entrycget>.
+
+The main purpose of the OO interface is to allow derived item classes to
+be defined which pre-set the options used to create a more basic item.
+
+=head1 BUGS
+
+This OO interface is very new. Using the label as the "key" is a problem
+for separaror items which don't have one. The alternative would be to
+use an index into the menu but that is a problem if items are deleted
+(or inserted other than at the end).
+
+There should probably be a PostInit entry point too, or a more widget like
+defered 'configure'.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Menubar.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Menubar.pm
new file mode 100755
index 00000000000..54b745130bf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Menubar.pm
@@ -0,0 +1,15 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Menubar;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Menubar.pm#6 $
+
+use Tk::Frame;
+use Tk::Menu;
+# use Carp;
+# carp "Tk::Menubar is obsolete" if $^W;
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Menubutton.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Menubutton.pm
new file mode 100755
index 00000000000..f3f4481b2ca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Menubutton.pm
@@ -0,0 +1,401 @@
+# Converted from menu.tcl --
+#
+# This file defines the default bindings for Tk menus and menubuttons.
+# It also implements keyboard traversal of menus and implements a few
+# other utility procedures related to menus.
+#
+# @(#) menu.tcl 1.34 94/12/19 17:09:09
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# 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.
+
+
+package Tk::Menubutton;
+require Tk;
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Menubutton/Menubutton.pm#4 $
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Menubutton';
+
+import Tk qw(&Ev $XS_VERSION);
+
+bootstrap Tk::Menubutton;
+
+sub Tk_cmd { \&Tk::menubutton }
+
+sub InitObject
+{
+ my ($mb,$args) = @_;
+ my $menuitems = delete $args->{-menuitems};
+ my $tearoff = delete $args->{-tearoff};
+ $mb->SUPER::InitObject($args);
+ if ((defined($menuitems) || defined($tearoff)) && %$args)
+ {
+ $mb->configure(%$args);
+ %$args = ();
+ }
+ $mb->menu(-tearoff => $tearoff) if (defined $tearoff);
+ $mb->AddItems(@$menuitems) if (defined $menuitems)
+}
+
+
+#
+#-------------------------------------------------------------------------
+# Elements of tkPriv that are used in this file:
+#
+# cursor - Saves the -cursor option for the posted menubutton.
+# focus - Saves the focus during a menu selection operation.
+# Focus gets restored here when the menu is unposted.
+# inMenubutton - The name of the menubutton widget containing
+# the mouse, or an empty string if the mouse is
+# not over any menubutton.
+# popup - If a menu has been popped up via tk_popup, this
+# gives the name of the menu. Otherwise this
+# value is empty.
+# postedMb - Name of the menubutton whose menu is currently
+# posted, or an empty string if nothing is posted
+# A grab is set on this widget.
+# relief - Used to save the original relief of the current
+# menubutton.
+# window - When the mouse is over a menu, this holds the
+# name of the menu; it's cleared when the mouse
+# leaves the menu.
+#-------------------------------------------------------------------------
+#-------------------------------------------------------------------------
+# Overall note:
+# This file is tricky because there are four different ways that menus
+# can be used:
+#
+# 1. As a pulldown from a menubutton. This is the most common usage.
+# In this style, the variable tkPriv(postedMb) identifies the posted
+# menubutton.
+# 2. As a torn-off menu copied from some other menu. In this style
+# tkPriv(postedMb) is empty, and the top-level menu is no
+# override-redirect.
+# 3. As an option menu, triggered from an option menubutton. In thi
+# style tkPriv(postedMb) identifies the posted menubutton.
+# 4. As a popup menu. In this style tkPriv(postedMb) is empty and
+# the top-level menu is override-redirect.
+#
+# The various binding procedures use the state described above to
+# distinguish the various cases and take different actions in each
+# case.
+#-------------------------------------------------------------------------
+# Menu::Bind --
+# This procedure is invoked the first time the mouse enters a menubutton
+# widget or a menubutton widget receives the input focus. It creates
+# all of the class bindings for both menubuttons and menus.
+#
+# Arguments:
+# w - The widget that was just entered or just received
+# the input focus.
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<FocusIn>','NoOp');
+ $mw->bind($class,'<Enter>','Enter');
+ $mw->bind($class,'<Leave>','Leave');
+ $mw->bind($class,'<1>','ButtonDown');
+ $mw->bind($class,'<Motion>',['Motion','up',Ev('X'),Ev('Y')]);
+ $mw->bind($class,'<B1-Motion>',['Motion','down',Ev('X'),Ev('Y')]);
+ $mw->bind($class,'<ButtonRelease-1>','ButtonUp');
+ $mw->bind($class,'<space>','PostFirst');
+ $mw->bind($class,'<Return>','PostFirst');
+ return $class;
+}
+
+sub ButtonDown
+{my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton);
+}
+
+sub PostFirst
+{
+ my $w = shift;
+ my $menu = $w->cget('-menu');
+ $w->Post();
+ $menu->FirstEntry() if (defined $menu);
+}
+
+
+# Enter --
+# This procedure is invoked when the mouse enters a menubutton
+# widget. It activates the widget unless it is disabled. Note:
+# this procedure is only invoked when mouse button 1 is *not* down.
+# The procedure B1Enter is invoked if the button is down.
+#
+# Arguments:
+# w - The name of the widget.
+sub Enter
+{
+ my $w = shift;
+ $Tk::inMenubutton->Leave if (defined $Tk::inMenubutton);
+ $Tk::inMenubutton = $w;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->configure('-state','active')
+ }
+}
+
+sub Leave
+{
+ my $w = shift;
+ $Tk::inMenubutton = undef;
+ return unless Tk::Exists($w);
+ if ($w->cget('-state') eq 'active')
+ {
+ $w->configure('-state','normal')
+ }
+}
+# Post --
+# Given a menubutton, this procedure does all the work of posting
+# its associated menu and unposting any other menu that is currently
+# posted.
+#
+# Arguments:
+# w - The name of the menubutton widget whose menu
+# is to be posted.
+# x, y - Root coordinates of cursor, used for positioning
+# option menus. If not specified, then the center
+# of the menubutton is used for an option menu.
+sub Post
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ return if ($w->cget('-state') eq 'disabled');
+ return if (defined $Tk::postedMb && $w == $Tk::postedMb);
+ my $menu = $w->cget('-menu');
+ return unless (defined($menu) && $menu->index('last') ne 'none');
+
+ my $tearoff = $Tk::platform eq 'unix' || $menu->cget('-type') eq 'tearoff';
+
+ my $wpath = $w->PathName;
+ my $mpath = $menu->PathName;
+ unless (index($mpath,"$wpath.") == 0)
+ {
+ die "Cannot post $mpath : not a descendant of $wpath";
+ }
+
+ my $cur = $Tk::postedMb;
+ if (defined $cur)
+ {
+ Tk::Menu->Unpost(undef); # fixme
+ }
+ $Tk::cursor = $w->cget('-cursor');
+ $Tk::relief = $w->cget('-relief');
+ $w->configure('-cursor','arrow');
+ $w->configure('-relief','raised');
+ $Tk::postedMb = $w;
+ $Tk::focus = $w->focusCurrent;
+ $menu->activate('none');
+ $menu->GenerateMenuSelect;
+ # If this looks like an option menubutton then post the menu so
+ # that the current entry is on top of the mouse. Otherwise post
+ # the menu just below the menubutton, as for a pull-down.
+
+ eval
+ {local $SIG{'__DIE__'};
+ my $dir = $w->cget('-direction');
+ if ($dir eq 'above')
+ {
+ $menu->post($w->rootx, $w->rooty - $menu->ReqHeight);
+ }
+ elsif ($dir eq 'below')
+ {
+ $menu->post($w->rootx, $w->rooty + $w->Height);
+ }
+ elsif ($dir eq 'left')
+ {
+ my $x = $w->rootx - $menu->ReqWidth;
+ my $y = int((2*$w->rooty + $w->Height) / 2);
+ if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
+ {
+ $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
+ }
+ else
+ {
+ $menu->post($x,$y);
+ }
+ }
+ elsif ($dir eq 'right')
+ {
+ my $x = $w->rootx + $w->Width;
+ my $y = int((2*$w->rooty + $w->Height) / 2);
+ if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
+ {
+ $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
+ }
+ else
+ {
+ $menu->post($x,$y);
+ }
+ }
+ else
+ {
+ if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
+ {
+ if (!defined($y))
+ {
+ $x = $w->rootx+$w->width/2;
+ $y = $w->rooty+$w->height/2
+ }
+ $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
+ }
+ else
+ {
+ $menu->post($w->rootx,$w->rooty+$w->height);
+ }
+ }
+ };
+ if ($@)
+ {
+ Tk::Menu->Unpost;
+ die $@
+ }
+
+ $Tk::tearoff = $tearoff;
+ if ($tearoff)
+ {
+ $menu->focus;
+ if ($w->viewable)
+ {
+ $w->SaveGrabInfo;
+ $w->grabGlobal;
+ }
+ }
+}
+# Motion --
+# This procedure handles mouse motion events inside menubuttons, and
+# also outside menubuttons when a menubutton has a grab (e.g. when a
+# menu selection operation is in progress).
+#
+# Arguments:
+# w - The name of the menubutton widget.
+# upDown - "down" means button 1 is pressed, "up" means
+# it isn't.
+# rootx, rooty - Coordinates of mouse, in (virtual?) root window.
+sub Motion
+{
+ my $w = shift;
+ my $upDown = shift;
+ my $rootx = shift;
+ my $rooty = shift;
+ return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w);
+ my $new = $w->Containing($rootx,$rooty);
+ if (defined($Tk::inMenubutton))
+ {
+ if (!defined($new) || ($new != $Tk::inMenubutton && $w->toplevel != $new->toplevel))
+ {
+ $Tk::inMenubutton->Leave();
+ }
+ }
+ if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0 &&
+ $w->cget('-indicatoron') == 0)
+ {
+ if ($upDown eq 'down')
+ {
+ $new->Post($rootx,$rooty);
+ }
+ else
+ {
+ $new->Enter();
+ }
+ }
+}
+# ButtonUp --
+# This procedure is invoked to handle button 1 releases for menubuttons.
+# If the release happens inside the menubutton then leave its menu
+# posted with element 0 activated. Otherwise, unpost the menu.
+#
+# Arguments:
+# w - The name of the menubutton widget.
+
+sub ButtonUp {
+ my $w = shift;
+
+ my $tearoff = $Tk::platform eq 'unix' || (defined($w->cget('-menu')) &&
+ $w->cget('-menu')->cget('-type') eq 'tearoff');
+ if ($tearoff && (defined($Tk::postedMb) && $Tk::postedMb == $w)
+ && (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)) {
+ $Tk::postedMb->cget(-menu)->FirstEntry();
+ } else {
+ Tk::Menu->Unpost(undef);
+ }
+} # end ButtonUp
+
+# Some convenience methods
+
+sub menu
+{
+ my ($w,%args) = @_;
+ my $menu = $w->cget('-menu');
+ if (!defined $menu)
+ {
+ require Tk::Menu;
+ $w->ColorOptions(\%args) if ($Tk::platform eq 'unix');
+ $menu = $w->Menu(%args);
+ $w->configure('-menu'=>$menu);
+ }
+ else
+ {
+ $menu->configure(%args);
+ }
+ return $menu;
+}
+
+sub separator { require Tk::Menu::Item; shift->menu->Separator(@_); }
+sub command { require Tk::Menu::Item; shift->menu->Command(@_); }
+sub cascade { require Tk::Menu::Item; shift->menu->Cascade(@_); }
+sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); }
+sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); }
+
+sub AddItems
+{
+ shift->menu->AddItems(@_);
+}
+
+sub entryconfigure
+{
+ shift->menu->entryconfigure(@_);
+}
+
+sub entrycget
+{
+ shift->menu->entrycget(@_);
+}
+
+sub FindMenu
+{
+ my $child = shift;
+ my $char = shift;
+ my $ul = $child->cget('-underline');
+ if (defined $ul && $ul >= 0 && $child->cget('-state') ne 'disabled')
+ {
+ my $char2 = $child->cget('-text');
+ $char2 = substr("\L$char2",$ul,1) if (defined $char2);
+ if (!defined($char) || $char eq '' || (defined($char2) && "\l$char" eq $char2))
+ {
+ $child->PostFirst;
+ return $child;
+ }
+ }
+ return undef;
+}
+
+1;
+
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Menubutton.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Menubutton.pod
new file mode 100755
index 00000000000..fcda3e958aa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Menubutton.pod
@@ -0,0 +1,249 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Menubutton - Create and manipulate Menubutton widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$menubutton> = I<$parent>-E<gt>B<Menubutton>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground> B<-cursor> B<-highlightthickness> B<-takefocus>
+B<-activeforeground> B<-disabledforeground> B<-image> B<-text>
+B<-anchor> B<-font> B<-justify> B<-textvariable>
+B<-background> B<-foreground> B<-padx> B<-underline>
+B<-bitmap> B<-highlightbackground> B<-pady> B<-wraplength>
+B<-borderwidth> B<-highlightcolor> B<-relief>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Command-Line Name: B<-compound>
+
+=item Database Name: B<compound>
+
+=item Database Class: B<Compound>
+
+Specifies whether the button should display both an image and text,
+and if so, where the image should be placed relative to the text.
+Valid values for this option are B<bottom>, B<center>, B<left>,
+B<none>, B<right> and B<top>. The default value is B<none>, meaning
+that the button will display either an image or text, depending on the
+values of the -image and -bitmap options.
+
+=item Name: B<direction>
+
+=item Class: B<Height>
+
+=item Switch: B<-direction>
+
+Specifies where the menu is going to be popup up. B<above> tries to
+pop the menu above the menubutton. B<below> tries to pop the menu
+below the menubutton. B<left> tries to pop the menu to the left of
+the menubutton. B<right> tries to pop the menu to the right of the
+menu button. B<flush> pops the menu directly over the menubutton.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies a desired height for the menubutton.
+If an image or bitmap is being displayed in the menubutton then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in lines of text.
+If this option isn't specified, the menubutton's desired height is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=item Name: B<indicatorOn>
+
+=item Class: B<IndicatorOn>
+
+=item Switch: B<-indicatoron>
+
+The value must be a proper boolean value. If it is true then
+a small indicator rectangle will be displayed on the right side
+of the menubutton and the default menu bindings will treat this
+as an option menubutton. If false then no indicator will be
+displayed.
+
+=item Name: B<menu>
+
+=item Class: B<MenuName>
+
+=item Switch: B<-menu>
+
+Specifies the path name of the menu associated with this menubutton.
+The menu must be a child of the menubutton.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of three states for the menubutton: B<normal>, B<active>,
+or B<disabled>. In normal state the menubutton is displayed using the
+B<foreground> and B<background> options. The active state is
+typically used when the pointer is over the menubutton. In active state
+the menubutton is displayed using the B<activeForeground> and
+B<activeBackground> options. Disabled state means that the menubutton
+should be insensitive: the default bindings will refuse to activate
+the widget and will ignore mouse button presses.
+In this state the B<disabledForeground> and
+B<background> options determine how the button is displayed.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies a desired width for the menubutton.
+If an image or bitmap is being displayed in the menubutton then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in characters.
+If this option isn't specified, the menubutton's desired width is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Menubutton> method creates a new window (given by the
+$widget argument) and makes it into a menubutton widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the menubutton such as its colors, font,
+text, and initial relief. The B<menubutton> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A menubutton is a widget that displays a textual string, bitmap, or image
+and is associated with a menu widget.
+If text is displayed, it must all be in a single font, but it
+can occupy multiple lines on the screen (if it contains newlines
+or if wrapping occurs because of the B<wrapLength> option) and
+one of the characters may optionally be underlined using the
+B<underline> option. In normal usage, pressing
+mouse button 1 over the menubutton causes the associated menu to
+be posted just underneath the menubutton. If the mouse is moved over
+the menu before releasing the mouse button, the button release
+causes the underlying menu entry to be invoked. When the button
+is released, the menu is unposted.
+
+Menubuttons are typically organized into groups called menu bars
+that allow scanning:
+if the mouse button is pressed over one menubutton (causing it
+to post its menu) and the mouse is moved over another menubutton
+in the same menu bar without releasing the mouse button, then the
+menu of the first menubutton is unposted and the menu of the
+new menubutton is posted instead.
+
+There are several interactions between menubuttons and menus; see
+the B<menu> manual entry for information on various menu configurations,
+such as pulldown menus and option menus.
+
+=head1 WIDGET METHODS
+
+The B<Menubutton> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The B<menu> method returns the menu associated with the widget.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+=head1 DEFAULT BINDINGS
+
+Tk automatically creates class bindings for menubuttons that give them
+the following default behavior:
+
+=over 4
+
+=item [1]
+
+A menubutton activates whenever the mouse passes over it and deactivates
+whenever the mouse leaves it.
+
+=item [2]
+
+Pressing mouse button 1 over a menubutton posts the menubutton:
+its relief changes to raised and its associated menu is posted
+under the menubutton. If the mouse is dragged down into the menu
+with the button still down, and if the mouse button is then
+released over an entry in the menu, the menubutton is unposted
+and the menu entry is invoked.
+
+=item [3]
+
+If button 1 is pressed over a menubutton and then released over that
+menubutton, the menubutton stays posted: you can still move the mouse
+over the menu and click button 1 on an entry to invoke it.
+Once a menu entry has been invoked, the menubutton unposts itself.
+
+=item [4]
+
+If button 1 is pressed over a menubutton and then dragged over some
+other menubutton, the original menubutton unposts itself and the
+new menubutton posts.
+
+=item [5]
+
+If button 1 is pressed over a menubutton and released outside
+any menubutton or menu, the menubutton unposts without invoking
+any menu entry.
+
+=item [6]
+
+When a menubutton is posted, its associated menu claims the input
+focus to allow keyboard traversal of the menu and its submenus.
+See the B<menu> documentation for details on these bindings.
+
+=item [7]
+
+If the B<underline> option has been specified for a menubutton
+then keyboard traversal may be used to post the menubutton:
+Alt+I<x>, where I<x> is the underlined character (or its
+lower-case or upper-case equivalent), may be typed in any window
+under the menubutton's toplevel to post the menubutton.
+
+=item [8]
+
+The F10 key may be typed in any window to post the first menubutton
+under its toplevel window that isn't disabled.
+
+=item [9]
+
+If a menubutton has the input focus, the space and return keys
+post the menubutton.
+
+If the menubutton's state is B<disabled> then none of the above
+actions occur: the menubutton is completely non-responsive.
+
+The behavior of menubuttons can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 KEYWORDS
+
+menubutton, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Message.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Message.pm
new file mode 100755
index 00000000000..63b0f170097
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Message.pm
@@ -0,0 +1,20 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Message;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Message.pm#6 $
+
+require Tk::Widget;
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Message';
+
+sub Tk_cmd { \&Tk::message }
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Message.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Message.pod
new file mode 100755
index 00000000000..9b0d67f3118
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Message.pod
@@ -0,0 +1,151 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Message - Create and manipulate Message widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$message> = I<$parent>-E<gt>B<Message>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-anchor> B<-font> B<-highlightthickness> B<-takefocus>
+B<-background> B<-foreground> B<-padx> B<-text>
+B<-borderwidth> B<-highlightbackground> B<-pady> B<-textvariable>
+B<-cursor> B<-highlightcolor> B<-relief> B<-width>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<aspect>
+
+=item Class: B<Aspect>
+
+=item Switch: B<-aspect>
+
+Specifies a non-negative integer value indicating desired
+aspect ratio for the text. The aspect ratio is specified as
+100*width/height. 100 means the text should
+be as wide as it is tall, 200 means the text should
+be twice as wide as it is tall, 50 means the text should
+be twice as tall as it is wide, and so on.
+Used to choose line length for text if B<width> option
+isn't specified.
+Defaults to 150.
+
+=item Name: B<justify>
+
+=item Class: B<Justify>
+
+=item Switch: B<-justify>
+
+Specifies how to justify lines of text.
+Must be one of B<left>, B<center>, or B<right>. Defaults
+to B<left>.
+This option works together with the B<anchor>, B<aspect>,
+B<padX>, B<padY>, and B<width> options to provide a variety
+of arrangements of the text within the window.
+The B<aspect> and B<width> options determine the amount of
+screen space needed to display the text.
+The B<anchor>, B<padX>, and B<padY> options determine where this
+rectangular area is displayed within the widget's window, and the
+B<justify> option determines how each line is displayed within that
+rectangular region.
+For example, suppose B<anchor> is B<e> and B<justify> is
+B<left>, and that the message window is much larger than needed
+for the text.
+The the text will displayed so that the left edges of all the lines
+line up and the right edge of the longest line is B<padX> from
+the right side of the window; the entire text block will be centered
+in the vertical span of the window.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the length of lines in the window.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+If this option has a value greater than zero then the B<aspect>
+option is ignored and the B<width> option determines the line
+length.
+If this option has a value less than or equal to zero, then
+the B<aspect> option determines the line length.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Message> method creates a new window (given by the
+$widget argument) and makes it into a message widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the message such as its colors, font,
+text, and initial relief. The B<message> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A message is a widget that displays a textual string. A message
+widget has three special features. First, it breaks up
+its string into lines in order to produce a given aspect ratio
+for the window. The line breaks are chosen at word boundaries
+wherever possible (if not even a single word would fit on a
+line, then the word will be split across lines). Newline characters
+in the string will force line breaks; they can be used, for example,
+to leave blank lines in the display.
+
+The second feature of a message widget is justification. The text
+may be displayed left-justified (each line starts at the left side of
+the window), centered on a line-by-line basis, or right-justified
+(each line ends at the right side of the window).
+
+The third feature of a message widget is that it handles control
+characters and non-printing characters specially. Tab characters
+are replaced with enough blank space to line up on the next
+8-character boundary. Newlines cause line breaks. Other control
+characters (ASCII code less than 0x20) and characters not defined
+in the font are displayed as a four-character sequence B<\x>I<hh> where
+I<hh> is the two-digit hexadecimal number corresponding to
+the character. In the unusual case where the font doesn't contain
+all of the characters in ``0123456789abcdef\x'' then control
+characters and undefined characters are not displayed at all.
+
+=head1 WIDGET METHODS
+
+The B<Message> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+=head1 DEFAULT BINDINGS
+
+When a new message is created, it has no default event bindings:
+messages are intended for output purposes only.
+
+=head1 BUGS
+
+Tabs don't work very well with text that is centered or right-justified.
+The most common result is that the line is justified wrong.
+
+=head1 KEYWORDS
+
+message, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/MsgBox.pm b/Master/tlpkg/tlperl.straw/lib/Tk/MsgBox.pm
new file mode 100755
index 00000000000..d50c528916a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/MsgBox.pm
@@ -0,0 +1,505 @@
+# -*- perl -*-
+
+# msgbox.tcl --
+#
+# Implements messageboxes for platforms that do not have native
+# messagebox support.
+#
+# RCS: @(#) $Id: msgbox.tcl,v 1.30 2006/01/25 18:22:04 dgp Exp $
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+# Translated to Perl/Tk by Slaven Rezic
+
+package Tk::MsgBox;
+
+use Tk qw(Ev);
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.001';
+
+use base qw(Tk::Toplevel);
+Construct Tk::Widget 'MsgBox';
+
+sub import {
+ if (defined $_[1] and $_[1] eq 'as_default') {
+ local $^W = 0;
+ package Tk;
+ *tk_messageBox = sub {
+ Tk::MsgBox::_tk_messageBox(@_);
+ };
+ }
+}
+
+use vars qw(%image);
+
+sub ClassInit {
+ my($class, $mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $image{b1}{$mw} = $mw->Bitmap(-foreground => 'black',
+ -data => "#define b1_width 32\n#define b1_height 32
+static unsigned char q1_bits[] = {
+ 0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,
+ 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,
+ 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
+ 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+ 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+ 0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
+ 0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,
+ 0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,
+ 0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,
+ 0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};");
+
+ $image{b2}{$mw} = $mw->Bitmap(-foreground => 'white',
+ -data => "#define b2_width 32\n#define b2_height 32
+static unsigned char b2_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,
+ 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,
+ 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
+ 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+ 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+ 0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
+ 0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,
+ 0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,
+ 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};");
+
+ $image{'q'}{$mw} = $mw->Bitmap(-foreground => 'blue',
+ -data => "#define q_width 32\n#define q_height 32
+static unsigned char q_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,
+ 0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,
+ 0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,
+ 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,
+ 0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};");
+
+ $image{'i'}{$mw} = $mw->Bitmap(-foreground => 'blue',
+ -data => "#define i_width 32\n#define i_height 32
+static unsigned char i_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,
+ 0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
+ 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
+ 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,
+ 0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};");
+
+ $image{'w1'}{$mw} = $mw->Bitmap(-foreground => 'black',
+ -data => "#define w1_width 32\n#define w1_height 32
+static unsigned char w1_bits[] = {
+ 0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,
+ 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,
+ 0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,
+ 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,
+ 0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,
+ 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
+ 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,
+ 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,
+ 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,
+ 0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,
+ 0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};");
+
+ $image{'w2'}{$mw} = $mw->Bitmap(-foreground => 'yellow',
+ -data => "#define w2_width 32\n#define w2_height 32
+static unsigned char w2_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
+ 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,
+ 0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,
+ 0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,
+ 0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,
+ 0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,
+ 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,
+ 0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,
+ 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,
+ 0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};");
+
+ $image{'w3'}{$mw} = $mw->Bitmap(-foreground => 'black',
+ -data => "#define w3_width 32\n#define w3_height 32
+static unsigned char w3_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
+ 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,
+ 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};");
+
+ $class;
+}
+
+# ::tk::MessageBox --
+#
+# Pops up a messagebox with an application-supplied message with
+# an icon and a list of buttons. This procedure will be called
+# by tk_messageBox if the platform does not have native
+# messagebox support, or if the particular type of messagebox is
+# not supported natively.
+#
+# Color icons are used on Unix displays that have a color
+# depth of 4 or more and $tk_strictMotif is not on.
+#
+# This procedure is a private procedure shouldn't be called
+# directly. Call tk_messageBox instead.
+#
+# See the user documentation for details on what tk_messageBox does.
+#
+sub Populate {
+ my($w, $args) = @_;
+
+ $w->SUPER::Populate($args);
+
+ {
+ my $icon = delete $args->{-icon};
+ if (!defined $icon) {
+ $icon = 'info';
+ }
+ if (!grep {$icon eq $_} qw(info warning error question)) {
+ die "bad -icon value \"$icon\": must be error, info, question, or warning";
+ }
+ if ($Tk::platform eq 'aqua') {
+ if ($icon eq 'error') {
+ $icon = 'stop';
+ } elsif ($icon eq 'warning') {
+ $icon = 'caution';
+ } elsif ($icon eq 'info') {
+ $icon = 'note';
+ }
+ }
+ $w->{Configure}{icon} = $icon;
+ }
+
+ {
+ my $type = delete $args->{-type};
+ if (!defined $type) {
+ $type = 'ok';
+ }
+ if ($type =~ m{^abortretryignore$}i) {
+ $w->{Names} = [qw(abort retry ignore)];
+ $w->{Labels} = [qw(&Abort &Retry &Ignore)];
+ $w->{Cancel} = 'abort';
+ } elsif ($type =~ m{^ok$}i) {
+ $w->{Names} = [qw(ok)];
+ $w->{Labels} = [qw(&OK)];
+ $w->{Cancel} = 'ok';
+ } elsif ($type =~ m{^okcancel$}i) {
+ $w->{Names} = [qw(ok cancel)];
+ $w->{Labels} = [qw(&OK &Cancel)];
+ $w->{Cancel} = 'cancel';
+ } elsif ($type =~ m{^retrycancel$}i) {
+ $w->{Names} = [qw(retry cancel)];
+ $w->{Labels} = [qw(&Retry &Cancel)];
+ $w->{Cancel} = 'cancel';
+ } elsif ($type =~ m{^yesno$}i) {
+ $w->{Names} = [qw(yes no)];
+ $w->{Labels} = [qw(&Yes &No)];
+ $w->{Cancel} = 'no';
+ } elsif ($type =~ m{^yesnocancel$}i) {
+ $w->{Names} = [qw(yes no cancel)];
+ $w->{Labels} = [qw(&Yes &No &Cancel)];
+ $w->{Cancel} = 'cancel';
+ } else {
+ die "bad -type value \"$type\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel";
+ }
+ $w->{Configure}{type} = $type;
+ }
+
+ $w->iconname('Dialog');
+
+ #
+ # The default value of the title is space (" ") not the empty string
+ # because for some window managers, a
+ # wm title .foo ""
+ # causes the window title to be "foo" instead of the empty string.
+ #
+ $w->ConfigSpecs
+ ('-default' => ['PASSIVE',undef,undef,''],
+ '-detail' => ['PASSIVE',undef,undef,''],
+ '-message' => ['PASSIVE',undef,undef,''],
+ #not needed, we can do it different way in perl: '-parent' => ['PASSIVE' ...],
+ '-title' => ['PASSIVE',undef,undef," "],
+ );
+ $w;
+}
+
+sub Show {
+ my $w = shift;
+
+ # If reusing the widget:
+ $_->destroy for ($w->children);
+
+ my @buttons;
+ for my $i (0 .. $#{ $w->{Names} }) {
+ my($name, $lab) = ($w->{Names}[$i], $w->{Labels}[$i]);
+ push @buttons, [$name, -text => $lab]; # XXX missing: mc (message catalog)
+ }
+
+ # If no default button was specified, the default default is the
+ # first button (Bug: 2218).
+
+ if ($w->cget(-default) eq "") {
+ $w->configure(-default => $buttons[0][0]);
+ }
+
+ my $valid = 0;
+ foreach my $btn (@buttons) {
+ if ($btn->[0] eq $w->cget(-default)) {
+ $valid = 1;
+ last;
+ }
+ }
+ if (!$valid) {
+ die "invalid default button \"" . $w->cget(-default) . "\"";
+ }
+
+ ### skip the step 2, not needed in Perl/Tk
+
+ # 3. Create the top-level window and divide it into top
+ # and bottom parts.
+
+ $w->title($w->cget(-title));
+ $w->protocol('WM_DELETE_WINDOW' => sub {
+ $w->Subwidget($w->{Cancel})->invoke;
+ });
+ # There is only one background colour for the whole dialog
+ my $bg = $w->cget(-background);
+
+ # Message boxes should be transient with respect to their parent so that
+ # they always stay on top of the parent window. But some window managers
+ # will simply create the child window as withdrawn if the parent is not
+ # viewable (because it is withdrawn or iconified). This is not good for
+ # "grab"bed windows. So only make the message box transient if the parent
+ # is viewable.
+ #
+ if ($w->parent->toplevel->viewable) {
+ $w->transient($w->parent);
+ }
+
+#XXX?
+# if {$windowingsystem eq "aqua"} {
+# unsupported::MacWindowStyle style $w dBoxProc # XXX what's that?
+# }
+
+ my $w_bot = $w->Frame(-background => $bg)->pack(qw(-side bottom -fill both));
+#XXX??? NYI? $w_bot->gridAnchor('center');
+ my $w_top = $w->Frame(-background => $bg)->pack(qw(-side top -fill both -expand 1));
+ if ($Tk::platform ne "aqua") {
+ $w_bot->configure(qw(-relief raised -bd 1));
+ $w_top->configure(qw(-relief raised -bd 1));
+ }
+
+ # 4. Fill the top part with bitmap, message and detail (use the
+ # option database for -wraplength and -font so that they can be
+ # overridden by the caller).
+
+ $w->optionAdd('*MsgBox.msg.wrapLength', '3i', 'widgetDefault');
+ $w->optionAdd('*MsgBox.dtl.wrapLength', '3i', 'widgetDefault');
+ if ($Tk::platform eq "aqua") {
+ $w->optionAdd('*MsgBox.msg.font', 'system', 'widgetDefault');
+ $w->optionAdd('*MsgBox.dtl.font', 'system', 'widgetDefault');
+ } else {
+ $w->optionAdd('*MsgBox.msg.font', [qw(Times 14)], 'widgetDefault');
+ $w->optionAdd('*MsgBox.dtl.font', [qw(Times 10)], 'widgetDefault');
+ }
+
+ my $w_msg = $w->Label(qw(Name msg -anchor nw -justify left),
+ -text => $w->cget(-message),
+ -background => $bg,
+ );
+ my $w_dtl;
+ if ($w->cget(-detail) ne "") {
+ $w_dtl = $w->Label(qw(Name dtl -anchor nw -justify left),
+ -text => $w->cget(-detail),
+ -background => $bg,
+ );
+ }
+ my $w_bitmap;
+ my $icon = $w->{Configure}{icon};
+ if ($icon ne "") {
+ if ($Tk::platform eq "aqua"
+ || ($w->depth < 4) || $Tk::strictMotif) {
+ $w_bitmap = $w->Label(Name => "bitmap",
+ -bitmap => $icon,
+ -background => $bg,
+ );
+ } else {
+ $w_bitmap = $w->Canvas(Name => "bitmap",
+ qw(-width 32 -height 32 -highlightthickness 0),
+ -background => $bg,
+ );
+ my $mw = $w->MainWindow;
+ if ($icon eq 'error') {
+ $w_bitmap->create(qw(oval 0 0 31 31 -fill red -outline black));
+ $w_bitmap->create(qw(line 9 9 23 23 -fill white -width 4));
+ $w_bitmap->create(qw(line 9 23 23 9 -fill white -width 4));
+ } elsif ($icon eq 'info') {
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{b1}{$mw});
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{b2}{$mw});
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{i}{$mw});
+ } elsif ($icon eq 'question') {
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{b1}{$mw});
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{b2}{$mw});
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{'q'}{$mw});
+ } else {
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{w1}{$mw});
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{w2}{$mw});
+ $w_bitmap->create(qw(image 0 0 -anchor nw),
+ -image => $image{w3}{$mw});
+ }
+ }
+ } else {
+ # Unlike in Tcl/Tk, a placeholder is needed here
+ $w_bitmap = $w->Label;
+ }
+ Tk::grid($w_bitmap, $w_msg, -in => $w_top, qw(-sticky news -padx 2m -pady 2m));
+ $w_top->gridColumnconfigure(qw(1 -weight 1));
+ if (Tk::Exists($w_dtl)) {
+ Tk::grid('^', $w_dtl, -in => $w_top, qw(-sticky news -padx 2m), -pady => [0, '2m']);
+ $w_top->gridRowconfigure(qw(1 -weight 1));
+ } else {
+ $w_top->gridRowconfigure(qw(0 -weight 1));
+ }
+
+ # 5. Create a row of buttons at the bottom of the dialog.
+
+ my $i = 0;
+ for my $but (@buttons) {
+ my($name, @opts) = @$but;
+ if (!@opts) {
+ # Capitalize the first letter of $name
+ @opts = (-text => ucfirst $name);
+ }
+
+ my $cw = $w->AmpWidget('Button', -padx => '3m', @opts,
+ -command => sub { $w->{selectedButton} = $name });
+ $w->Advertise($name => $cw);
+ if ($name eq $w->cget(-default)) {
+ $cw->configure(qw(-default active));
+ } else {
+ $cw->configure(qw(-default normal));
+ }
+ $cw->grid(-in => $w_bot, -row => 0, -column => $i,
+ qw(-padx 3m -pady 2m -sticky ew));
+ $w_bot->gridColumnconfigure($i, -uniform => 'buttons');
+ $i++;
+
+ # create the binding for the key accelerator, based on the underline
+ #
+ # set underIdx [$w.$name cget -under]
+ # if {$underIdx >= 0} {
+ # set key [string index [$w.$name cget -text] $underIdx]
+ # bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
+ # bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
+ # }
+ }
+ $w->bind('<Alt-Key>', [sub { $w->AltKeyInDialog($_[1]) }, Ev('%A')]);
+
+ if ($w->cget(-default) ne "") {
+ $w->bind('<FocusIn>', sub {
+ my $e = shift->XEvent;
+ my $w = $e->W;
+ if ($w->isa('Tk::Button')) {
+ $w->configure(qw(-default active));
+ }
+ });
+ $w->bind('<FocusOut>', sub {
+ my $e = shift->XEvent;
+ my $w = $e->W;
+ if ($w->isa('Tk::Button')) {
+ $w->configure(qw(-default normal));
+ }
+ });
+ }
+
+ # 6. Create bindings for <Return>, <Escape> and <Destroy> on the dialog
+
+ $w->bind('<Return>' => sub {
+ my $e = shift->XEvent;
+ my $w = $e->W;
+ if ($w->isa('Tk::Button')) {
+ $w->invoke;
+ }
+ });
+
+ # Invoke the designated cancelling operation
+ $w->bind('<Escape>' => sub { $w->Subwidget($w->{Cancel})->invoke });
+
+ # At <Destroy> the buttons have vanished, so must do this directly.
+ $w_msg->bind('<Destroy>' => sub { $w->{selectedButton} = $w->{Cancel} });
+
+ # 7. Withdraw the window, then update all the geometry information
+ # so we know how big it wants to be, then center the window in the
+ # display and de-iconify it.
+
+ # ::tk::PlaceWindow $w widget $data(-parent)
+ $w->withdraw;
+ $w->Popup;
+
+ # 8. Set a grab and claim the focus too.
+
+ my $focus;
+ if ($w->cget(-default) ne "") {
+ $focus = $w->Subwidget($w->cget(-default));
+ } else {
+ $focus = $w;
+ }
+ $w->SetFocusGrab($focus);
+
+ # 9. Wait for the user to respond, then restore the focus and
+ # return the index of the selected button. Restore the focus
+ # before deleting the window, since otherwise the window manager
+ # may take the focus away so we can't redirect it. Finally,
+ # restore any grab that was in effect.
+
+ $w->waitVariable(\$w->{selectedButton});
+ # Copy the result now so any <Destroy> that happens won't cause
+ # trouble
+ my $result = $w->{selectedButton};
+
+ $w->RestoreFocusGrab($focus, 'withdraw');
+
+ return $result;
+}
+
+sub _tk_messageBox {
+ my(%args) = @_;
+ my $parent = delete $args{-parent};
+ my $md = $parent->MsgBox(%args);
+ my $an = $md->Show;
+ $md->destroy;
+ $an;
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/MsgBox.pod b/Master/tlpkg/tlperl.straw/lib/Tk/MsgBox.pod
new file mode 100755
index 00000000000..6f5536cf89c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/MsgBox.pod
@@ -0,0 +1,83 @@
+
+=head1 NAME
+
+Tk::MsgBox - create and manipulate a message dialog
+
+=for pm Tk/MsgBox.pm
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+ use Tk::MsgBox
+ ...
+ $d = $top->MsgBox(-title => "Title", -type => "okcancel");
+ ...
+ $button = $d->Show;
+
+=head1 DESCRIPTION
+
+B<MsgBox> is a simple dialog with predefined buttons.
+
+=head1 OPTIONS
+
+The options recognized by B<MsgBox> are as follows:
+
+=over 4
+
+=item B<-icon>
+
+Specify the icon of the MsgBox. Valid values are B<error>, B<info>,
+B<question>, or B<warning>.
+
+=item B<-type>
+
+Specify the type of the MsgBox. Valid values are B<abortretryignore>,
+B<ok>, B<okcancel>, B<retrycancel>, B<yesno>, or B<yesnocancel>. The
+type determines the buttons to be shown.
+
+=item B<-default>
+
+Specify the default button. This must be one of B<abort>, B<retry>,
+B<ignore>, B<ok>, B<cancel>, B<yes>, or B<no>, depending on the type
+of the MsgBox previously specified.
+
+=item B<-detail>
+
+Specify text for the detail region of the MsgBox.
+
+=item B<-message>
+
+Specify the message text of the MsgBox.
+
+=item B<-title>
+
+Specify the title of the MsgBox.
+
+=back
+
+=head1 METHODS
+
+B<MsgBox> supports only one method as of now:
+
+=over 4
+
+=item B<Show()>
+
+Displays the MsgBox until the user invokes one of the buttons. Returns
+the name of the button invoked.
+
+=back
+
+=head1 AUTHOR
+
+Translated from Tcl/Tk by B<Slaven Rezic> srezic@cpan.org
+
+This code is distributed under the same terms as Perl.
+
+=head1 SEE ALSO
+
+L<Tk::messageBox>, L<Tk::DialogBox>, L<Tk::Dialog>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Mwm.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Mwm.pod
new file mode 100755
index 00000000000..e9c09cd0358
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Mwm.pod
@@ -0,0 +1,109 @@
+
+=head1 NAME
+
+Tk::Mwm - Communicate with the Motif(tm) window manager.
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+S< >B<use Tk::Mwm;>
+
+S< >I<$toplevel>-E<gt>B<mwm>I<Option>?(I<args>)?
+
+S< >I<$toplevel>-E<gt>B<mwm>(I<option> ?,I<args>?)
+
+=head1 DESCRIPTION
+
+Interface to special extentions supported by mwm.
+
+=head1 METHODS
+
+=over 4
+
+=item I<$toplevel>-E<gt>B<mwmDecoration>?(?option??=E<gt>value? ?,...?)?
+
+When no options are given, this method returns the values of all the
+decorations options for the toplevel window with the I<$toplevel>.
+When only one option is given without specifying the value, the
+current value of that option is returned.
+When more than one "option-value" pairs are passed to this method,
+the specified values will be assigned to the corresponding options. As
+a result, the appearance of the Motif decorations around the toplevel
+window will be changed.
+Possible options are: B<-border>, B<-menu>, B<-maximize>,
+B<-minimize>, B<-resizeh> and B<-title>. The value must be a
+Boolean value. The values returned by this command are undefined when
+the window is not managed by mwm.
+
+=item I<$toplevel>-E<gt>B<mwmIsmwmrunning>
+
+This returns value is true if mwm is running on the screen where the specified
+window is located, false otherwise.
+
+=item I<$toplevel>-E<gt>B<mwmProtocol>
+
+When no additional options are given, this method returns all
+protocols associated with this toplevel window.
+
+=item I<$toplevel>-E<gt>B<mwmProtocol>(B<activate> =E<gt> I<protocol_name>)
+
+Activate the mwm protocol message in mwm's menu.
+
+=item I<$toplevel>-E<gt>B<MwmProtocol>(B<add> =E<gt> I<protocol_name>, I<menu_message>)
+
+Add a new mwm protocol message for this toplevel window. The
+message is identified by the string name specified in
+I<protocol_name>. A menu item will be added into mwm's menu as
+specified by I<menu_message>. Once a new mwm protocol message is
+added to a toplevel, it can be caught by the TK B<protocol>
+method. Here is an example:
+
+S< >I<$toplevel>-E<gt>B<mwmProtocol>(B<'add'> =E<gt> 'MY_PRINT_HELLO', '"Print Hello" _H CtrlE<lt>KeyE<gt>H');
+
+S< >I<$toplevel>-E<gt>B<protocol>(B<'MY_PRINT_HELLO'> =E<gt> sub {print "Hello"});
+
+=item I<$toplevel>-E<gt>B<mwmProtocol>(B<'deactivate'> =E<gt> I<protocol_name>)
+
+Deactivate the mwm protocol message in mwm's menu.
+
+=item I<$toplevel>-E<gt>B<mwmProtocol>(B<'delete'> =E<gt> I<protocol_name>)
+
+Delete the mwm protocol message from mwm's menu. Please note that the
+window manager protocol handler associated with this protocol (by the
+B<protocol> method) is not deleted automatically. You have to
+delete the protocol handle explicitly. E.g.:
+
+S< >I<$mw>-E<gt>B<mwmProtocol>(B<'delete'> =E<gt> 'MY_PRINT_HELLO');
+
+S< >I<$mw>-E<gt>B<protocol>(B<'MY_PRINT_HELLO'> =E<gt> '');
+
+=back
+
+=head1 BUGS
+
+This is a Tix extension which perl/Tk has adopted. It has not been
+tested as perl/Tk's author has not got round to installing a Motif Window
+Manager.
+
+On some versions of mwm, the B<-border> will not disappear unless
+B<-resizeh> is turned off. Also, the B<-title> will not disappear
+unless all of B<-title>, B<-menu>, B<-maximize> and
+B<-minimize> are turned off.
+
+=head1 SEE ALSO
+
+L<Tk::Wm|Tk::Wm>
+L<Tk::tixWm|Tk::tixWm>
+L<Tk::Toplevel|Tk::Toplevel>
+
+=head1 KEYWORDS
+
+window manager, mwm, TIX
+
+=head1 AUTHOR
+
+Ioi Kim Lam - ioi@graphics.cis.upenn.edu
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/NBFrame.pm b/Master/tlpkg/tlperl.straw/lib/Tk/NBFrame.pm
new file mode 100755
index 00000000000..0e45251f852
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/NBFrame.pm
@@ -0,0 +1,20 @@
+package Tk::NBFrame;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/NBFrame/NBFrame.pm#4 $
+
+use Tk qw($XS_VERSION);
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'NBFrame';
+
+bootstrap Tk::NBFrame;
+
+sub Tk_cmd { \&Tk::nbframe }
+
+Tk::Methods qw(activate add delete focus info geometryinfo identify
+ move pagecget pageconfigure);
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/NoteBook.pm b/Master/tlpkg/tlperl.straw/lib/Tk/NoteBook.pm
new file mode 100755
index 00000000000..a1f2eedb09e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/NoteBook.pm
@@ -0,0 +1,480 @@
+package Tk::NoteBook;
+#
+# Implementation of NoteBook widget.
+# Derived from NoteBook.tcl in Tix 4.0
+
+# Contributed by Rajappa Iyer <rsi@earthling.net>
+# Hacked by Nick for 'menu' traversal.
+# Restructured by Nick
+
+use vars qw($VERSION);
+
+#$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
+$VERSION = '4.011';
+require Tk::NBFrame;
+
+use base qw(Tk::Derived Tk::NBFrame);
+Tk::Widget->Construct('NoteBook');
+use strict;
+
+use Tk qw(Ev);
+
+use Carp;
+require Tk::Frame;
+
+sub TraverseToNoteBook;
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ # class binding does not work right due to extra level of
+ # widget hierachy
+ $mw->bind($class,'<ButtonPress-1>', ['MouseDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<ButtonRelease-1>', ['MouseUp',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<B1-Motion>', ['MouseDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<Left>', ['FocusNext','prev']);
+ $mw->bind($class,'<Right>', ['FocusNext','next']);
+
+ $mw->bind($class,'<Return>', 'SetFocusByKey');
+ $mw->bind($class,'<space>', 'SetFocusByKey');
+ return $class;
+}
+
+sub raised
+{
+ return shift->{'topchild'};
+}
+
+sub Populate
+{
+ my ($w, $args) = @_;
+
+ $w->SUPER::Populate($args);
+ $w->{'pad-x1'} = undef;
+ $w->{'pad-x2'} = undef;
+ $w->{'pad-y1'} = undef;
+ $w->{'pad-y2'} = undef;
+
+ $w->{'windows'} = [];
+ $w->{'nWindows'} = 0;
+ $w->{'minH'} = 1;
+ $w->{'minW'} = 1;
+
+ $w->{'counter'} = 0;
+ $w->{'resize'} = 0;
+
+ $w->ConfigSpecs(-ipadx => ['PASSIVE', 'ipadX', 'Pad', 0],
+ -ipady => ['PASSIVE', 'ipadY', 'Pad', 0],
+ -takefocus => ['SELF', 'takeFocus', 'TakeFocus', 0],
+ -dynamicgeometry => ['PASSIVE', 'dynamicGeometry', 'DynamicGeometry', 0]);
+
+ # SetBindings
+ $w->bind('<Configure>','MasterGeomProc');
+
+ $args->{-slave} = 1;
+ $args->{-takefocus} = 1;
+ $args->{-relief} = 'raised';
+
+ $w->QueueResize;
+}
+
+
+#---------------------------
+# Public methods
+#---------------------------
+
+sub page_widget
+{
+ my $w = shift;
+ $w->{'_pages_'} = {} unless exists $w->{'_pages_'};
+ my $h = $w->{'_pages_'};
+ if (@_)
+ {
+ my $name = shift;
+ if (@_)
+ {
+ my $cw = shift;
+ if (defined $cw)
+ {
+ $h->{$name} = $cw;
+ }
+ else
+ {
+ return delete $h->{$name};
+ }
+ }
+ return $h->{$name};
+ }
+ else
+ {
+ return (values %$h);
+ }
+}
+
+sub add
+{
+ my ($w, $child, %args) = @_;
+
+ croak("$child already exists") if defined $w->page_widget($child);
+
+ my $f = Tk::Frame->new($w,Name => $child,-relief => 'raised');
+
+ my $ccmd = delete $args{-createcmd};
+ my $rcmd = delete $args{-raisecmd};
+ $f->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
+ $f->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
+
+ # manage our geometry
+ $w->ManageGeometry($f);
+ # create default bindings
+ $f->bind('<Configure>',[$w,'ClientGeomProc','-configure', $f]);
+ $f->bind('<Destroy>', [$w,'delete',$child,1]);
+ $w->page_widget($child,$f);
+ $w->{'nWindows'}++;
+ push(@{$w->{'windows'}}, $child);
+ $w->SUPER::add($child,%args);
+ return $f;
+}
+
+sub raise
+{
+ my ($w, $child) = @_;
+ return unless defined $child;
+ if ($w->pagecget($child, -state) eq 'normal')
+ {
+ $w->activate($child);
+ $w->focus($child);
+ my $childw = $w->page_widget($child);
+ if ($childw)
+ {
+ if (defined $childw->{-createcmd})
+ {
+ $childw->{-createcmd}->Call($childw);
+ delete $childw->{-createcmd};
+ }
+ # hide the original visible window
+ my $oldtop = $w->{'topchild'};
+ if (defined($oldtop) && ($oldtop ne $child))
+ {
+ $w->page_widget($oldtop)->UnmapWindow;
+ }
+ $w->{'topchild'} = $child;
+ my $myW = $w->Width;
+ my $myH = $w->Height;
+
+ if (!defined $w->{'pad-x1'}) {
+ $w->InitTabSize;
+ }
+
+ my $cW = $myW - $w->{'pad-x1'} - $w->{'pad-x2'} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
+ my $cH = $myH - $w->{'pad-y1'} - $w->{'pad-y2'} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
+ my $cX = $w->{'pad-x1'} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
+ my $cY = $w->{'pad-y1'} + (defined $w->{-ipady} ? $w->{-ipady} : 0);
+
+ if ($cW > 0 && $cH > 0)
+ {
+ $childw->MoveResizeWindow($cX, $cY, $cW, $cH);
+ $childw->MapWindow;
+ $childw->raise;
+ }
+ if ((not defined $oldtop) || ($oldtop ne $child))
+ {
+ if (defined $childw->{-raisecmd})
+ {
+ $childw->{-raisecmd}->Call($childw);
+ }
+ }
+ }
+ }
+}
+
+sub pageconfigure
+{
+ my ($w, $child, %args) = @_;
+ my $childw = $w->page_widget($child);
+ if (defined $childw)
+ {
+ my $ccmd = delete $args{-createcmd};
+ my $rcmd = delete $args{-raisecmd};
+ $childw->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
+ $childw->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
+ $w->SUPER::pageconfigure($child, %args) if (keys %args);
+ }
+}
+
+sub pages {
+ my ($w) = @_;
+ return @{$w->{'windows'}};
+}
+
+sub pagecget
+{
+ my ($w, $child, $opt) = @_;
+ my $childw = $w->page_widget($child);
+ if (defined $childw)
+ {
+ return $childw->{-createcmd} if ($opt =~ /-createcmd/);
+ return $childw->{-raisecmd} if ($opt =~ /-raisecmd/);
+ return $w->SUPER::pagecget($child, $opt);
+ }
+ else
+ {
+ carp "page $child does not exist";
+ }
+}
+
+sub delete
+{
+ my ($w, $child, $destroy) = @_;
+ my $childw = $w->page_widget($child,undef);
+ if (defined $childw)
+ {
+ $childw->bind('<Destroy>', undef);
+ $childw->destroy;
+ @{$w->{'windows'}} = grep($_ ne $child, @{$w->{'windows'}});
+ $w->{'nWindows'}--;
+ $w->SUPER::delete($child);
+ # see if the child to be deleted was the top child
+ if ((defined $w->{'topchild'}) && ($w->{'topchild'} eq $child))
+ {
+ delete $w->{'topchild'};
+ if ( @{$w->{'windows'}})
+ {
+ $w->raise($w->{'windows'}[0]);
+ }
+ }
+ }
+ else
+ {
+ carp "page $child does not exist" unless $destroy;
+ }
+}
+
+#---------------------------------------
+# Private methods
+#---------------------------------------
+
+sub MouseDown {
+ my ($w, $x, $y) = @_;
+ my $name = $w->identify($x, $y);
+ $w->focus($name);
+ $w->{'down'} = $name;
+}
+
+sub MouseUp {
+ my ($w, $x, $y) = @_;
+ my $name = $w->identify($x, $y);
+ if ((defined $name) && (defined $w->{'down'}) &&
+ ($name eq $w->{'down'}) &&
+ ($w->pagecget($name, -state) eq 'normal')) {
+ $w->raise($name);
+ } else {
+ $w->focus($name);
+ }
+}
+
+sub FocusNext {
+ my ($w, $dir) = @_;
+ my $name;
+
+ if (not defined $w->info('focus')) {
+ $name = $w->info('active');
+ $w->focus($name);
+ } else {
+ $name = $w->info('focus' . $dir);
+ $w->focus($name);
+ }
+}
+
+sub SetFocusByKey {
+ my ($w) = @_;
+
+ my $name = $w->info('focus');
+ if (defined $name) {
+ if ($w->pagecget($name, -state) eq 'normal') {
+ $w->raise($name);
+ $w->activate($name);
+ }
+ }
+}
+
+sub NoteBookFind {
+ my ($w, $char) = @_;
+
+ my $page;
+ foreach $page (@{$w->{'windows'}}) {
+ my $i = $w->pagecget($page, -underline);
+ my $c = substr($page, $i, 1);
+ if ($char =~ /$c/) {
+ if ($w->pagecget($page, -state) ne 'disabled') {
+ return $page;
+ }
+ }
+ }
+ return undef;
+}
+
+# This is called by TraveseToMenu when an <Alt-Keypress> occurs
+# See the code in Tk.pm
+sub FindMenu {
+ my ($w, $char) = @_;
+
+ my $page;
+ foreach $page (@{$w->{'windows'}}) {
+ my $i = $w->pagecget($page, -underline);
+ my $l = $w->pagecget($page, -label);
+ next if (not defined $l);
+ my $c = substr($l, $i, 1);
+ if ($char =~ /$c/i) {
+ if ($w->pagecget($page, -state) ne 'disabled') {
+ $w->raise($page);
+ return $w;
+ }
+ }
+ }
+ return undef;
+}
+
+
+sub MasterGeomProc
+{
+ my ($w) = @_;
+ if (Tk::Exists($w))
+ {
+ $w->{'resize'} = 0 unless (defined $w->{'resize'});
+ $w->QueueResize;
+ }
+}
+
+sub SlaveGeometryRequest
+{
+ my $w = shift;
+ if (Tk::Exists($w))
+ {
+ $w->QueueResize;
+ }
+}
+
+sub LostSlave {
+ my ($w, $s) = @_;
+ $s->UnmapWindow;
+}
+
+sub ClientGeomProc
+{
+ my ($w, $flag, $client) = @_;
+ $w->QueueResize if (Tk::Exists($w));
+ if ($flag =~ /-lostslave/)
+ {
+ carp "Geometry Management Error: Another geometry manager has taken control of $client. This error is usually caused because a widget has been created in the wrong frame: it should have been created inside $client instead of $w";
+ }
+}
+
+sub QueueResize
+{
+ my $w = shift;
+ $w->afterIdle(['Resize', $w]) unless ($w->{'resize'}++);
+}
+
+sub Resize {
+
+ my ($w) = @_;
+
+ return unless Tk::Exists($w) && $w->{'nWindows'} && $w->{'resize'};
+
+ $w->InitTabSize;
+
+ $w->{'resize'} = 0;
+ my $reqW = $w->{-width} || 0;
+ my $reqH = $w->{-height} || 0;
+
+ if ($reqW * $reqH == 0)
+ {
+ if ((not defined $w->cget('-dynamicgeometry')) ||
+ ($w->cget('-dynamicgeometry') == 0)) {
+ $reqW = 1;
+ $reqH = 1;
+
+ my $childw;
+ foreach $childw ($w->page_widget)
+ {
+ my $cW = $childw->ReqWidth;
+ my $cH = $childw->ReqHeight;
+ $reqW = $cW if ($reqW < $cW);
+ $reqH = $cH if ($reqH < $cH);
+ }
+ } else {
+ if (defined $w->{'topchild'}) {
+ my $topw = $w->page_widget($w->{'topchild'});
+ $reqW = $topw->ReqWidth;
+ $reqH = $topw->ReqHeight;
+ } else {
+ $reqW = 1;
+ $reqH = 1;
+ }
+ }
+ $reqW += $w->{'pad-x1'} + $w->{'pad-x2'} + 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
+ $reqH += $w->{'pad-y1'} + $w->{'pad-y2'} + 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
+ $reqW = ($reqW > $w->{'minW'}) ? $reqW : $w->{'minW'};
+ $reqH = ($reqH > $w->{'minH'}) ? $reqH : $w->{'minH'};
+ }
+ if (($w->ReqWidth != $reqW) ||
+ ($w->ReqHeight != $reqH)) {
+ $w->{'counter'} = 0 if (not defined $w->{'counter'});
+ if ($w->{'counter'} < 50) {
+ $w->{'counter'}++;
+ $w->GeometryRequest($reqW, $reqH);
+ $w->afterIdle([$w,'Resize']);
+ $w->{'resize'} = 1;
+ return;
+ }
+ }
+ $w->{'counter'} = 0;
+ $w->raise($w->{'topchild'} || ${$w->{'windows'}}[0]);
+ $w->{'resize'} = 0;
+}
+
+sub InitTabSize {
+ my ($w) = @_;
+ my ($tW, $tH) = $w->geometryinfo;
+ $w->{'pad-x1'} = 2;
+ $w->{'pad-x2'} = 2;
+ $w->{'pad-y1'} = $tH + (defined $w->{'-ipadx'} ? $w->{'-ipadx'} : 0) + 1;
+ $w->{'pad-y2'} = 2;
+ $w->{'minW'} = $tW;
+ $w->{'minH'} = $tH;
+}
+
+sub BalloonInfo
+{
+ my ($notebook,$balloon,$X,$Y,@opt) = @_;
+ my $page = $notebook->identify($X-$notebook->rootx,$Y-$notebook->rooty);
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$notebook);
+ if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
+ {
+ if (!defined $page)
+ {
+ $balloon->Deactivate;
+ return;
+ }
+ $balloon->Subclient($page);
+ if (exists $info->{$page})
+ {
+ return $info->{$page}
+ }
+ else
+ {
+ return '';
+ }
+ }
+ return $info;
+ }
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/NoteBook.pod b/Master/tlpkg/tlperl.straw/lib/Tk/NoteBook.pod
new file mode 100755
index 00000000000..ae1d88d12dd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/NoteBook.pod
@@ -0,0 +1,231 @@
+
+=head1 NAME
+
+Tk::NoteBook - display several windows in limited space with notebook metaphor.
+
+=for pm Tixish/NoteBook.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+ use Tk::NoteBook;
+ ...
+ $w = $frame->NoteBook();
+ $page1 = $w->add("page1", options);
+ $page2 = $w->add("page2", options);
+ ...
+ $page2 = $w->add("page2", options);
+
+=head1 DESCRIPTION
+
+The NoteBook widget provides a notebook metaphor to display several
+windows in limited space. The notebook is divided into a stack of pages
+of which only one is displayed at any time. The other pages can be
+selected by means of choosing the visual "tabs" at the top of the
+widget. Additionally, the <Tab> key may be used to traverse the pages.
+If B<-underline> is used, Alt- bindings will also work.
+
+The widget takes all the options that a Frame does. In addition,
+it supports the following options:
+
+=over 4
+
+=item B<-dynamicgeometry>
+
+If set to false (default and recommended), the size of the NoteBook
+will match the size of the largest page. Otherwise the size will
+match the size of the current page causing the NoteBook to change
+size when different pages of different sizes are selected.
+
+=item B<-ipadx>
+
+The amount of internal horizontal padding around the pages.
+
+=item B<-ipady>
+
+The amount of internal vertical padding around the pages.
+
+=item B<-backpagecolor>
+
+The background color of the tabs and back page.
+
+=item B<-disabledforeground>
+
+XXX
+
+=item B<-focuscolor>
+
+The color of the focus border around the tabs.
+
+=item B<-font>
+
+The font of the tab labels.
+
+=item B<-inactivebackground>
+
+XXX
+
+=item B<-tabpadx>
+
+Horizonzal padding around the tab label.
+
+=item B<-tabpady>
+
+Vertical padding around the tab label.
+
+=back
+
+=head1 METHODS
+
+The following methods may be used with a NoteBook object in addition
+to standard methods.
+
+=over 4
+
+=item B<add(>I<pageName>, I<options>B<)>
+
+Adds a page with name I<pageName> to the notebook. Returns an object
+of type B<Frame>. The recognized I<options> are:
+
+=over 4
+
+=item B<-anchor>
+
+Specifies how the information in a tab is to be displayed. Must be
+one of B<n>, B<ne>, B<e>, B<se>, B<s>, B<sw>, B<w>, B<nw> or
+B<center>.
+
+=item B<-bitmap>
+
+Specifies a bitmap to display on the tab of this page. The bitmap
+is displayed only if none of the B<-label> or B<-image> options
+are specified.
+
+=item B<-image>
+
+Specifies an image to display on the tab of this page. The image
+is displayed only if the B<-label> option is not specified.
+
+=item B<-label>
+
+Specifies the text string to display on the tab of this page.
+
+=item B<-justify>
+
+When there are multiple lines of text displayed in a tab, this
+option determines the justification of the lines.
+
+=item B<-createcmd>
+
+Specifies a L<callback|Tk::callbacks> to be called the first time the page is
+shown on the screen. This option can be used to delay the creation
+of the contents of a page until necessary. It can be useful in
+situations where there are a large number of pages in a NoteBook
+widget; with B<-createcmd> you do not have to make the user wait
+until all pages are constructed before displaying the first page.
+
+=item B<-raisecmd>
+
+Specifies a L<callback|Tk::callbacks> to be called whenever this page is raised
+by the user.
+
+=item B<-state>
+
+Specifies whether this page can be raised by the user. Must be
+either B<normal> or B<disabled>.
+
+=item B<-underline>
+
+Specifies the integer index of a character to underline in the
+tab. This option is used by the default bindings to implement
+keyboard traversal for menu buttons and menu entries. 0
+corresponds to the first character of text displayed on the
+widget, 1 to the next character and so on.
+
+=item B<-wraplength>
+
+This option specifies the maximum line length of the label string
+on this tab. If the line length of the label string exceeds this
+length, then it is wrapped onto the next line so that no line is
+longer than the specified length. The value may be specified in
+any standard forms for screen distances. If this value is less
+than or equal to 0, then no wrapping is done: lines will break
+only at newline characters in the text.
+
+=back
+
+=item B<delete(>I<pageName>B<)>
+
+Deletes the page identified by I<pageName>.
+
+=item B<pagecget(>I<pageName>, I<-option>B<)>
+
+Returns the current value of the configuration option given by
+I<-option> in the page given by I<pageName>. I<Option> may have any of
+the values accepted in the B<add> method.
+
+=item B<pageconfigure(>I<pageName>, I<options>B<)>
+
+Like configure for the page indicated by I<pageName>. I<Options> may
+be any of the options accepted by the B<add> method.
+
+=item B<pages>
+
+Returns a list consisting of the names of all currently defined
+pages, i.e., those created with the B<add> method.
+
+=item B<page_widget(>I<pageName>B<)>
+
+Returns the page with name I<pageName>.
+
+=item B<raise(>I<pageName>B<)>
+
+Raise the page identified by I<pageName>.
+
+=item B<raised()>
+
+Returns the name of the currently raised page.
+
+=item B<geometryinfo>
+
+Return the dimensions of the tab area.
+
+=item B<identify(>I<x>,I<y>B<)>
+
+Identify the tab's page name under the specified coordinates. Return
+an empty string if there's no tab.
+
+=item B<info(E<quot>pagesE<quot>)>
+
+Return a list of all pages.
+
+=item B<info(E<quot>focusE<quot>)>
+
+Return the page name of the tab with the current focus.
+
+=item B<info(E<quot>focusnextE<quot>)>
+
+Return the page name of the tab which would receive the next focus.
+
+=item B<info(E<quot>focusprevE<quot>)>
+
+Return the page name of the tab which had the previous focus.
+
+=item B<info(E<quot>activeE<quot>)>
+
+Return the page name of the active tab.
+
+=back
+
+=head1 AUTHORS
+
+B<Rajappa Iyer> <rsi@earthling.net>
+Nick Ing-Simmons <nick@ni-s.u-net.com>
+
+This code and documentation was derived from NoteBook.tcl in
+Tix4.0 written by Ioi Lam. It may be distributed under the same
+conditions as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pm
new file mode 100755
index 00000000000..c95f008cd4d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pm
@@ -0,0 +1,128 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Optionmenu;
+require Tk::Menubutton;
+require Tk::Menu;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.014'; # $Id: //depot/Tkutf8/Tk/Optionmenu.pm#13 $
+
+use base qw(Tk::Derived Tk::Menubutton);
+
+use strict;
+
+Construct Tk::Widget 'Optionmenu';
+
+sub Populate
+{
+ my ($w,$args) = @_;
+ $w->SUPER::Populate($args);
+ $args->{-indicatoron} = 1;
+ my $menu = $w->menu(-tearoff => 0);
+
+ # Should we allow -menubackground etc. as in -label* of Frame ?
+
+ $w->ConfigSpecs(-command => ['CALLBACK',undef,undef,undef],
+ -options => ['METHOD', undef, undef, undef],
+ -variable=> ['PASSIVE', undef, undef, undef],
+ -font => [['SELF',$menu], undef, undef, undef],
+ -foreground => [['SELF', 'CHILDREN'], undef, undef, undef],
+
+ -takefocus => [ qw/SELF takefocus Takefocus 1/ ],
+ -highlightthickness => [ qw/SELF highlightThickness HighlightThickness 1/ ],
+ -relief => [ qw/SELF relief Relief raised/ ],
+
+ );
+
+ # configure -variable and -command now so that when -options
+ # is set by main-line configure they are there to be set/called.
+
+ my $tvar = delete $args->{-textvariable};
+ my $vvar = delete $args->{-variable};
+ if (!defined($vvar))
+ {
+ if (defined $tvar)
+ {
+ $vvar = $tvar;
+ }
+ else
+ {
+ my $new;
+ $vvar = \$new;
+ }
+ }
+ $tvar = $vvar if (!defined($tvar));
+ $w->configure(-textvariable => $tvar, -variable => $vvar);
+ $w->configure(-command => $vvar) if ($vvar = delete $args->{-command});
+}
+
+sub setOption
+{
+ my ($w, $label, $val) = @_;
+ my $tvar = $w->cget(-textvariable);
+ my $vvar = $w->cget(-variable);
+ if (@_ == 2)
+ {
+ $val = $label;
+ }
+ $$tvar = $label if $tvar;
+ $$vvar = $val if $vvar;
+ $w->Callback(-command => $val);
+}
+
+sub addOptions
+{
+ my $w = shift;
+ my $menu = $w->menu;
+ my $tvar = $w->cget(-textvariable);
+ my $vvar = $w->cget(-variable);
+ my $oldt = $$tvar;
+ my $width = $w->cget('-width');
+ my %hash;
+ my $first;
+ while (@_)
+ {
+ my $val = shift;
+ my $label = $val;
+ if (ref $val)
+ {
+ if ($vvar == $tvar)
+ {
+ my $new = $label;
+ $w->configure(-textvariable => ($tvar = \$new));
+ }
+ ($label, $val) = @$val;
+ }
+ my $len = length($label);
+ $width = $len if (!defined($width) || $len > $width);
+ $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]);
+ $hash{$label} = $val;
+ $first = $label unless defined $first;
+ }
+ if (!defined($oldt) || !exists($hash{$oldt}))
+ {
+ $w->setOption($first, $hash{$first}) if defined $first;
+ }
+ $w->configure('-width' => $width);
+}
+
+sub options
+{
+ my ($w,$opts) = @_;
+ if (@_ > 1)
+ {
+ $w->menu->delete(0,'end');
+ $w->addOptions(@$opts);
+ }
+ else
+ {
+ return $w->_cget('-options');
+ }
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pod
new file mode 100755
index 00000000000..f5e514c63b3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Optionmenu.pod
@@ -0,0 +1,100 @@
+
+=head1 NAME
+
+Tk::Optionmenu - Let the user select one of some predefined options values
+
+=for pm Tk/Optionmenu.pm
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+ use Tk::Optionmenu;
+
+ $opt = $w->Optionmenu(
+ -options => REFERENCE_to_OPTIONLIST,
+ -command => CALLBACK,
+ -variable => SCALAR_REF,
+ );
+
+ $opt->addOptions( OPTIONLIST );
+
+ # OPTION LIST is
+ # a) $val1, $val2, $val3,...
+ # b) [ $lab1=>$val1], [$lab2=>val2], ... ]
+ # c) combination of a) and b), e.g.,
+ # val1, [$lab2=>val2], val3, val4, [...], ...
+
+=head1 DESCRIPTION
+
+The B<Optionmenu> widget allows the user chose between a given set
+of options.
+
+If the user should be able to change the available option have a look
+at L<Tk::BrowseEntry>.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -options
+
+(Re)sets the list of options presented.
+
+=item -command
+
+Defines the L<callback|Tk::callbacks> that is invokes when a new option
+is selected.
+
+=item -variable
+
+Reference to a scalar that contains the current value of the
+selected option.
+
+=item -textvariable
+
+Reference to a scalar that contains the text label of the current value of the
+selected option.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item addOptions
+
+Adds OPTION_LIST to the already available options.
+
+=back
+
+=head1 EXAMPLE
+
+ use Tk;
+ my $mw = MainWindow->new();
+
+ my ($var, $tvar);
+ my $opt = $mw->Optionmenu(
+ -options => [[jan=>1], [feb=>2], [mar=>3], [apr=>4]],
+ -command => sub { print "got: ", shift, "\n" },
+ -variable => \$var,
+ -textvariable => \$tvar
+ )->pack;
+
+ $opt->addOptions([may=>5],[jun=>6],[jul=>7],[aug=>8]);
+
+ my $f = $mw->Frame(-relief=>'groove', -borderwidth => 2)->pack;
+ $f->Label(-textvariable=>\$tvar)->pack(-side => 'left');
+ $f->Label(-text => " -> ")->pack(-side => 'left');
+ $f->Label(-textvariable=>\$var)->pack(-side => 'left');
+
+ $mw->Button(-text=>'Exit', -command=>sub{$mw->destroy})->pack;
+
+ MainLoop;
+
+=head1 SEE ALSO
+
+L<Tk::Menubutton>, L<Tk::BrowseEntry>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/PNG.pm b/Master/tlpkg/tlperl.straw/lib/Tk/PNG.pm
new file mode 100755
index 00000000000..39974315645
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/PNG.pm
@@ -0,0 +1,50 @@
+package Tk::PNG;
+require DynaLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # was: sprintf '4.%03d', q$Revision: #3 $ =~ /\D(\d+)\s*$/;
+
+use Tk 800.005;
+require Tk::Image;
+require Tk::Photo;
+
+use base qw(DynaLoader);
+
+bootstrap Tk::PNG $Tk::VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tk::PNG - PNG loader for Tk::Photo
+
+=head1 SYNOPSIS
+
+ use Tk;
+ use Tk::PNG;
+
+ my $image = $widget->Photo('-format' => 'png', -file => 'something.png');
+
+
+=head1 DESCRIPTION
+
+This is an extension for Tk which supplies
+PNG format loader for Photo image type.
+
+=head1 HISTORY
+
+This extension is by default bundled with Perl/Tk since Tk804.
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=head1 SEE ALSO
+
+L<Tk::Photo>.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Pane.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Pane.pm
new file mode 100755
index 00000000000..36c5203a42d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Pane.pm
@@ -0,0 +1,544 @@
+# Tk::Pane.pm
+#
+# Copyright (c) 1997-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Tk::Pane;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/Pane.pm#7 $
+
+use Tk;
+use Tk::Widget;
+use Tk::Derived;
+use Tk::Frame;
+
+use strict;
+
+use base qw(Tk::Derived Tk::Frame);
+
+Construct Tk::Widget 'Pane';
+
+use Tk::Submethods(
+ grid => [qw/bbox columnconfigure location propagate rowconfigure size slaves/],
+ pack => [qw/propagate slaves/]
+);
+
+sub ClassInit {
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>',['QueueLayout',4]);
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ return $class;
+}
+
+sub Populate {
+ my $pan = shift;
+
+ my $frame = $pan->Component(Frame => "frame");
+
+ $pan->afterIdle(['Manage',$pan,$frame]);
+ $pan->afterIdle(['QueueLayout',$pan,1]);
+
+ $pan->Delegates(
+ DEFAULT => $frame,
+ # FIXME
+ # These are a hack to avoid an existing bug in Tk::Widget::DelegateFor
+ # which has been reported and should be fixed in the next Tk release
+ see => $pan,
+ xview => $pan,
+ yview => $pan,
+ );
+
+ $pan->ConfigSpecs(
+ DEFAULT => [$frame],
+ -sticky => [PASSIVE => undef, undef, undef],
+ -gridded => [PASSIVE => undef, undef, undef],
+ -xscrollcommand => [CALLBACK => undef, undef, undef],
+ -yscrollcommand => [CALLBACK => undef, undef, undef],
+ );
+
+
+ $pan;
+}
+
+
+sub grid {
+ my $w = shift;
+ $w = $w->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?: bbox
+ |columnconfigure
+ |location
+ |propagate
+ |rowconfigure
+ |size
+ |slaves)$/x);
+ $w->SUPER::grid(@_);
+}
+
+sub slave {
+ my $w = shift;
+ $w->Subwidget('frame');
+}
+
+sub pack {
+ my $w = shift;
+ $w = $w->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:propagate|slaves)$/x);
+ $w->SUPER::pack(@_);
+}
+
+sub QueueLayout {
+ shift if ref $_[1];
+ my($m,$why) = @_;
+ $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
+ $m->{LayoutPending} |= $why;
+}
+
+sub AdjustXY {
+ my($w,$Wref,$X,$st,$scrl,$getx) = @_;
+ my $W = $$Wref;
+
+ if($w >= $W) {
+ my $v = 0;
+ if($getx) {
+ $v |= 1 if $st =~ /[Ww]/;
+ $v |= 2 if $st =~ /[Ee]/;
+ }
+ else {
+ $v |= 1 if $st =~ /[Nn]/;
+ $v |= 2 if $st =~ /[Ss]/;
+ }
+
+ if($v == 0) {
+ $X = int(($w - $W) / 2);
+ }
+ elsif($v == 1) {
+ $X = 0;
+ }
+ elsif($v == 2) {
+ $X = int($w - $W);
+ }
+ else {
+ $X = 0;
+ $$Wref = $w;
+ }
+ $scrl->Call(0,1)
+ if $scrl;
+ }
+ elsif($scrl) {
+ $X = 0
+ if $X > 0;
+ $X = $w - $W
+ if(($X + $W) < $w);
+ $scrl->Call(-$X / $W,(-$X + $w) / $W);
+ }
+ else {
+ $X = 0;
+ $$Wref = $w;
+ }
+
+ return $X;
+}
+
+sub Layout {
+ my $pan = shift;
+ my $why = $pan->{LayoutPending};
+
+ my $slv = $pan->Subwidget('frame');
+
+ return unless $slv;
+
+ my $H = $slv->ReqHeight;
+ my $W = $slv->ReqWidth;
+ my $X = $slv->x;
+ my $Y = $slv->y;
+ my $w = $pan->width;
+ my $h = $pan->height;
+ my $yscrl = $pan->{Configure}{'-yscrollcommand'};
+ my $xscrl = $pan->{Configure}{'-xscrollcommand'};
+
+ $yscrl = undef
+ if(defined($yscrl) && UNIVERSAL::isa($yscrl, 'SCALAR') && !defined($$yscrl));
+ $xscrl = undef
+ if(defined($xscrl) && UNIVERSAL::isa($xscrl, 'SCALAR') && !defined($$xscrl));
+
+ if($why & 1) {
+ $h = $pan->{Configure}{'-height'} || 0
+ unless($h > 1);
+ $w = $pan->{Configure}{'-width'} || 0
+ unless($w > 1);
+
+ $h = $H
+ unless($h > 1 || defined($yscrl));
+ $w = $W
+ unless($w > 1 || defined($xscrl));
+
+ $w = 100 if $w <= 1;
+ $h = 100 if $h <= 1;
+
+ $pan->GeometryRequest($w,$h);
+ }
+
+ my $st = $pan->{Configure}{'-sticky'} || '';
+
+ $pan->{LayoutPending} = 0;
+
+ $slv->MoveResizeWindow(
+ AdjustXY($w,\$W,$X,$st,$xscrl,1),
+ AdjustXY($h,\$H,$Y,$st,$yscrl,0),
+ $W,$H
+ );
+}
+
+sub SlaveGeometryRequest {
+ my ($m,$s) = @_;
+ $m->QueueLayout(1);
+}
+
+sub LostSlave {
+ my($m,$s) = @_;
+ $m->{Slave} = undef;
+}
+
+sub Manage {
+ my $m = shift;
+ my $s = shift;
+
+ $m->{Slave} = $s;
+ $m->ManageGeometry($s);
+ $s->MapWindow;
+ $m->QueueLayout(2);
+}
+
+sub xview {
+ my $pan = shift;
+
+ unless(@_) {
+ my $scrl = $pan->{Configure}{'-xscrollcommand'};
+ return (0,1) unless $scrl;
+ my $slv = $pan->Subwidget('frame');
+ my $sw = $slv->ReqWidth;
+ my $ldx = $pan->rootx - $slv->rootx;
+ my $rdx = $ldx + $pan->width;
+ $ldx = $ldx <= 0 ? 0 : $ldx / $sw;
+ $rdx = $rdx >= $sw ? 1 : $rdx / $sw;
+ return( $ldx , $rdx);
+ }
+ elsif(@_ == 1) {
+ my $widget = shift;
+ my $slv = $pan->Subwidget('frame');
+ xyview(1,$pan,
+ moveto => ($widget->rootx - $slv->rootx) / $slv->ReqWidth);
+ }
+ else {
+ xyview(1,$pan,@_);
+ }
+}
+
+sub yview {
+ my $pan = shift;
+
+ unless(@_) {
+ my $scrl = $pan->{Configure}{'-yscrollcommand'};
+ return (0,1) unless $scrl;
+ my $slv = $pan->Subwidget('frame');
+ my $sh = $slv->ReqHeight;
+ my $tdy = $pan->rooty - $slv->rooty;
+ my $bdy = $tdy + $pan->height;
+ $tdy = $tdy <= 0 ? 0 : $tdy / $sh;
+ $bdy = $bdy >= $sh ? 1 : $bdy / $sh;
+ return( $tdy, $bdy);
+ }
+ elsif(@_ == 1) {
+ my $widget = shift;
+ my $slv = $pan->Subwidget('frame');
+ xyview(0,$pan,
+ moveto => ($widget->rooty - $slv->rooty) / $slv->ReqHeight);
+ }
+ else {
+ xyview(0,$pan,@_);
+ }
+}
+
+sub xyview {
+ my($horz,$pan,$cmd,$val,$mul) = @_;
+ my $slv = $pan->Subwidget('frame');
+ return unless $slv;
+
+ my($XY,$WH,$wh,$scrl,@a);
+
+ if($horz) {
+ $XY = $slv->x;
+ $WH = $slv->ReqWidth;
+ $wh = $pan->width;
+ $scrl = $pan->{Configure}{'-xscrollcommand'};
+ }
+ else {
+ $XY = $slv->y;
+ $WH = $slv->ReqHeight;
+ $wh = $pan->height;
+ $scrl = $pan->{Configure}{'-yscrollcommand'};
+ }
+
+ $scrl = undef
+ if(UNIVERSAL::isa($scrl, 'SCALAR') && !defined($$scrl));
+
+ if($WH < $wh) {
+ $scrl->Call(0,1);
+ return;
+ }
+
+ if($cmd eq 'scroll') {
+ my $dxy = 0;
+
+ my $gridded = $pan->{Configure}{'-gridded'} || '';
+ my $do_gridded = ($gridded eq 'both'
+ || (!$horz == ($gridded ne 'x'))) ? 1 : 0;
+
+ if($do_gridded && $mul eq 'pages') {
+ my $ch = ($slv->children)[0];
+ if(defined($ch) && $ch->manager eq 'grid') {
+ @a = $horz
+ ? (1-$XY,int($slv->width / 2))
+ : (int($slv->height / 2),1-$XY);
+ my $rc = ($slv->gridLocation(@a))[$horz ? 0 : 1];
+ my $mrc = ($slv->gridSize)[$horz ? 0 : 1];
+ $rc += $val;
+ $rc = 0 if $rc < 0;
+ $rc = $mrc if $rc > $mrc;
+ my $gsl;
+ while($rc >= 0 && $rc < $mrc) {
+ $gsl = ($slv->gridSlaves(-row => $rc))[0];
+ last
+ if defined $gsl;
+ $rc += $val;
+ }
+ if(defined $gsl) {
+ @a = $horz ? ($rc,0) : (0,$rc);
+ $XY = 0 - ($slv->gridBbox(@a))[$horz ? 0 : 1];
+ }
+ else {
+ $XY = $val > 0 ? $wh - $WH : 0;
+ }
+ $dxy = $val; $val = 0;
+ }
+ }
+ $dxy = $mul eq 'pages' ? ($horz ? $pan->width : $pan->height) : 10
+ unless $dxy;
+ $XY -= $dxy * $val;
+ }
+ elsif($cmd eq 'moveto') {
+ $XY = -int($WH * $val);
+ }
+
+ $XY = $wh - $WH
+ if($XY < ($wh - $WH));
+ $XY = 0
+ if $XY > 0;
+
+ @a = $horz
+ ? ( $XY, $slv->y)
+ : ($slv->x, $XY);
+
+ $slv->MoveWindow(@a);
+
+ $scrl->Call(-$XY / $WH,(-$XY + $wh) / $WH);
+}
+
+sub see {
+ my $pan = shift;
+ my $widget = shift;
+ my %opt = @_;
+ my $slv = $pan->Subwidget('frame');
+
+ my $anchor = defined $opt{'-anchor'} ? $opt{'-anchor'} : "";
+
+ if($pan->{Configure}{'-yscrollcommand'}) {
+ my $yanchor = lc(($anchor =~ /([NnSs]?)/)[0] || "");
+ my $pty = $pan->rooty;
+ my $ph = $pan->height;
+ my $pby = $pty + $ph;
+ my $ty = $widget->rooty;
+ my $wh = $widget->height;
+ my $by = $ty + $wh;
+ my $h = $slv->ReqHeight;
+
+ if($yanchor eq 'n' || ($yanchor ne 's' && ($wh >= $h || $ty < $pty))) {
+ my $y = $ty - $slv->rooty;
+ $pan->yview(moveto => $y / $h);
+ }
+ elsif($yanchor eq 's' || $by > $pby) {
+ my $y = $by - $ph - $slv->rooty;
+ $pan->yview(moveto => $y / $h);
+ }
+ }
+
+ if($pan->{Configure}{'-xscrollcommand'}) {
+ my $xanchor = lc(($anchor =~ /([WwEe]?)/)[0] || "");
+ my $ptx = $pan->rootx;
+ my $pw = $pan->width;
+ my $pbx = $ptx + $pw;
+ my $tx = $widget->rootx;
+ my $ww = $widget->width;
+ my $bx = $tx + $ww;
+ my $w = $slv->ReqWidth;
+
+ if($xanchor eq 'w' || ( $xanchor ne 'e' && ($ww >= $w || $tx < $ptx))) {
+ my $x = $tx - $slv->rootx;
+ $pan->xview(moveto => $x / $w);
+ }
+ elsif($xanchor eq 'e' || $bx > $pbx) {
+ my $x = $bx - $pw - $slv->rootx;
+ $pan->xview(moveto => $x / $w);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tk::Pane - A window panner
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::Pane;
+
+ $pane = $mw->Scrolled(Pane, Name => 'fred',
+ -scrollbars => 'soe',
+ -sticky => 'we',
+ -gridded => 'y'
+ );
+
+ $pane->Frame;
+
+ $pane->pack;
+
+=head1 DESCRIPTION
+
+B<Tk::Pane> provides a scrollable frame widget. Once created it can be
+treated as a frame, except it is scrollable.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-gridded> =E<gt> I<direction>
+
+Specifies if the top and left edges of the pane should snap to a
+grid column. This option is only useful if the widgets in the pane
+are managed by the I<grid> geometry manager. Possible values are
+B<x>, B<y> and B<xy>.
+
+=item B<-sticky> =E<gt> I<style>
+
+If Pane is larger than its requested dimensions, this option may be used to
+position (or stretch) the slave within its cavity. I<Style> is a string that
+contains zero or more of the characters n, s, e or w. The string can optionally
+contains spaces or commas, but they are ignored. Each letter refers to a side
+(north, south, east, or west) that the slave will "stick" to. If both n and s
+(or e and w) are specified, the slave will be stretched to fill the entire
+height (or width) of its cavity.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item I<$pane>-E<gt>B<see>(I<$widget> ?,I<options>?)
+
+Adjusts the view so that I<$widget> is visable. Aditional parameters in
+I<options-value> pairs can be passed, each I<option-value> pair must be
+one of the following
+
+=over 8
+
+=item B<-anchor> =E<gt> I<anchor>
+
+Specifies how to make the widget visable. If not given then as much of
+the widget as possible is made visable.
+
+Possible values are B<n>, B<s>, B<w>, B<e>, B<nw>, B<ne>, B<sw> and B<se>.
+This will cause an edge on the widget to be aligned with the corresponding
+edge on the pane. for example B<nw> will cause the top left of the widget
+to be placed at the top left of the pane. B<s> will cause the bottom of the
+widget to be placed at the bottom of the pane, and as much of the widget
+as possible made visable in the x direction.
+
+=back
+
+=item I<$pane>-E<gt>B<xview>
+
+Returns a list containing two elements, both of which are real fractions
+between 0 and 1. The first element gives the position of the left of the
+window, relative to the Pane as a whole (0.5 means it is halfway through the
+Pane, for example). The second element gives the position of the right of the
+window, relative to the Pane as a whole.
+
+=item I<$pane>-E<gt>B<xview>(I<$widget>)
+
+Adjusts the view in the window so that I<widget> is displayed at the left of
+the window.
+
+=item I<$pane>-E<gt>B<xview>(B<moveto> =E<gt> I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the total width of the
+Pane is off-screen to the left. fraction must be a fraction between 0 and 1.
+
+=item I<$pane>-E<gt>B<xview>(B<scroll> =E<gt> I<number>, I<what>)
+
+This command shifts the view in the window left or right according to I<number>
+and I<what>. I<Number> must be an integer. I<What> must be either B<units> or
+B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view
+adjusts left or right by I<number>*10 screen units on the display; if it is
+B<pages> then the view adjusts by number screenfuls. If number is negative then
+widgets farther to the left become visible; if it is positive then widgets
+farther to the right become visible.
+
+=item I<$pane>-E<gt>B<yview>
+
+Returns a list containing two elements, both of which are real fractions
+between 0 and 1. The first element gives the position of the top of the
+window, relative to the Pane as a whole (0.5 means it is halfway through the
+Pane, for example). The second element gives the position of the bottom of the
+window, relative to the Pane as a whole.
+
+=item I<$pane>-E<gt>B<yview>(I<$widget>)
+
+Adjusts the view in the window so that I<widget> is displayed at the top of the
+window.
+
+=item I<$pane>-E<gt>B<yview>(B<moveto> =E<gt> I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the total width of the
+Pane is off-screen to the top. fraction must be a fraction between 0 and 1.
+
+=item I<$pane>-E<gt>B<yview>(B<scroll> =E<gt> I<number>, I<what>)
+
+This command shifts the view in the window up or down according to I<number>
+and I<what>. I<Number> must be an integer. I<What> must be either B<units> or
+B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view
+adjusts up or down by I<number>*10 screen units on the display; if it is
+B<pages> then the view adjusts by number screenfuls. If number is negative then
+widgets farther up become visible; if it is positive then widgets farther down
+become visible.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-1998 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pm
new file mode 100755
index 00000000000..d984b648897
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pm
@@ -0,0 +1,221 @@
+package Tk::Panedwindow;
+use strict;
+
+use vars qw/$VERSION/;
+$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /#(\d+)/;
+
+# A Panedwindow widget (similar to Adjuster).
+
+use Tk qw/Ev/;
+use base qw/Tk::Widget/;
+
+Construct Tk::Widget 'Panedwindow';
+
+sub Tk_cmd { \&Tk::panedwindow }
+
+Tk::Methods('add', 'forget', 'identify', 'proxy', 'sash', 'panes');
+
+use Tk::Submethods (
+ 'proxy' => [qw/coord forget place/],
+ 'sash' => [qw/coord mark place/],
+);
+
+sub ClassInit {
+
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class, '<Button-1>' => ['MarkSash' => Ev('x'), Ev('y'), 1]);
+ $mw->bind($class, '<Button-2>' => ['MarkSash' => Ev('x'), Ev('y'), 0]);
+ $mw->bind($class, '<B1-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 1]);
+ $mw->bind($class, '<B2-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 0]);
+ $mw->bind($class, '<ButtonRelease-1>' => ['ReleaseSash' => 1]);
+ $mw->bind($class, '<ButtonRelease-2>' => ['ReleaseSash' => 0]);
+ $mw->bind($class, '<Motion>' => ['Motion' => Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Leave>' => ['Leave']);
+
+ return $class;
+
+} # end ClassInit
+
+sub MarkSash {
+
+ # MarkSash
+ #
+ # Handle marking the correct sash for possible dragging
+ #
+ # Arguments:
+ # w the widget
+ # x widget local x coord
+ # y widget local y coord
+ # proxy whether this should be a proxy sash
+ # Results:
+ # None
+
+ my ($w, $x, $y, $proxy) = @_;
+
+ my @what = $w->identify($x, $y);
+ if ( @what == 2 ) {
+ my ($index, $which) = @what[0 .. 1];
+ if (not $Tk::strictMotif or $which eq 'handle') {
+ $w->sashMark($index, $x, $y) if not $proxy;
+ $w->{_sash} = $index;
+ my ($sx, $sy) = $w->sashCoord($index);
+ $w->{_dx} = $sx - $x;
+ $w->{_dy} = $sy - $y;
+ }
+ }
+
+} # end MarkSash
+
+sub DragSash {
+
+ # DragSash
+ #
+ # Handle dragging of the correct sash
+ #
+ # Arguments:
+ # w the widget
+ # x widget local x coord
+ # y widget local y coord
+ # proxy whether this should be a proxy sash
+ # Results:
+ # Moves sash
+
+ my ($w, $x, $y, $proxy) = @_;
+
+ if ( exists $w->{_sash} ) {
+ if ($proxy) {
+ $w->proxyPlace($x + $w->{_dx}, $y + $w->{_dy});
+ } else {
+ $w->sashPlace($w->{_sash}, $x + $w->{_dx}, $y + $w->{_dy});
+ }
+ }
+
+} # end DragSash
+
+sub ReleaseSash {
+
+ # ReleaseSash
+ #
+ # Handle releasing of the sash
+ #
+ # Arguments:
+ # w the widget
+ # proxy whether this should be a proxy sash
+ # Results:
+ # Returns ...
+
+ my ($w, $proxy) = @_;
+
+ if ( exists $w->{_sash} ) {
+ if ($proxy) {
+ my ($x, $y) = $w->proxyCoord;
+ $w->sashPlace($w->{_sash}, $x, $y);
+ $w->proxyForget;
+ }
+ delete $w->{'_sash', '_dx', '_dy'};
+ }
+
+} # end ReleaseSash
+
+sub Motion {
+
+ # Motion
+ #
+ # Handle motion on the widget. This is used to change the cursor
+ # when the user moves over the sash area.
+ #
+ # Arguments:
+ # w the widget
+ # x widget local x coord
+ # y widget local y coord
+ # Results:
+ # May change the cursor. Sets up a timer to verify that we are still
+ # over the widget.
+
+ my ($w, $x, $y) = @_;
+
+ my @id = $w->identify($x, $y);
+ if ( (@id == 2) and
+ (not $Tk::strictMotif or $id[1] eq 'handle') ) {
+ if ( not exists $w->{_panecursor} ) {
+ $w->{_panecursor} = $w->cget(-cursor);
+ if ( not defined $w->cget(-sashcursor) ) {
+ if ( $w->cget(-orient) eq 'horizontal' ) {
+ $w->configure(-cursor => 'sb_h_double_arrow');
+ } else {
+ $w->configure(-cursor => 'sb_v_double_arrow');
+ }
+ } else {
+ $w->configure(-cursor => $w->cget(-sashcursor));
+ }
+ if ( exists $w->{_pwAfterId} ) {
+ $w->afterCancel($w->{_pwAfterId});
+ }
+ $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]);
+ }
+ return
+ }
+ if ( exists $w->{_panecursor} ) {
+ $w->configure(-cursor => $w->{_panecursor});
+ delete $w->{_panecursor};
+ }
+
+} # end Motion
+
+sub Cursor {
+
+ # Cursor
+ #
+ # Handles returning the normal cursor when we are no longer over the
+ # sash area. This needs to be done this way, because the panedwindow
+ # won't see Leave events when the mouse moves from the sash to a
+ # paned child, although the child does receive an Enter event.
+ #
+ # Arguments:
+ # w the widget
+ # Results:
+ # May restore the default cursor, or schedule a timer to do it.
+
+ my ($w) = @_;
+
+ if ( exists $w->{_panecursor} ) {
+ if ( $w->containing($w->pointerx, $w->pointery) == $w ) {
+ $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]);
+ } else {
+ $w->configure(-cursor => $w->{_panecursor});
+ delete $w->{_panecursor};
+ if ( exists $w->{_pwAfterId} ) {
+ $w->afterCancel($w->{_pwAfterId});
+ delete $w->{_pwAfterId};
+ }
+ }
+ }
+
+} # end Cursor
+
+sub Leave {
+
+ # Leave
+ #
+ # Return to default cursor when leaving the pw widget.
+ #
+ # Arguments:
+ # w the widget
+ # Results:
+ # Restores the default cursor
+
+ my ($w) = @_;
+
+ if ( exists $w->{_panecursor} ) {
+ $w->configure(-cursor => $w->{_panecursor});
+ delete $w->{_panecursor};
+ }
+
+} # end Leave
+
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pod
new file mode 100755
index 00000000000..673938d55e5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Panedwindow.pod
@@ -0,0 +1,326 @@
+# Copyright (c) 1992 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# RCS: @(#) $Id: panedwindow.n,v 1.2.2.1 2003/07/17 20:49:00 dkf Exp $
+
+=head1 NAME
+
+Tk::Panedwindow - Create and manipulate Panedwindow widgets
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+I<$panedwindow> = I<$parent>-E<gt>B<Panedwindow>(?I<options>?);
+
+ -background -height -width
+ -borderwidth -orient
+ -cursor -relief
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Option: B<-handlepad>
+
+=item Name: B<handlePad>
+
+=item Class: B<HandlePad>
+
+When sash handles are drawn, specifies the distance from the top or
+left end of the sash (depending on the orientation of the widget) at
+which to draw the handle. May be any value accepted by B<Tk_GetPixels>.
+
+=item Option: B<-handlesize>
+
+=item Name: B<handleSize>
+
+=item Class: B<HandleSize>
+
+Specifies the side length of a sash handle. Handles are always
+drawn as squares. May be any value accepted by B<Tk_GetPixels>.
+
+=item Option: B<-opaqueresize>
+
+=item Name: B<opaqueResize>
+
+=item Class: B<OpaqueResize>
+
+Specifies whether panes should be resized as a sash is moved (true),
+or if resizing should be deferred until the sash is placed (false).
+
+=item Option: B<-sashcursor>
+
+=item Name: B<sashCursor>
+
+=item Class: B<SashCursor>
+
+Mouse cursor to use when over a sash. If null,
+B<sb_h_double_arrow> will be used for horizontal Panedwindows, and
+B<sb_v_double_arrow> will be used for vertical Panedwindows.
+
+=item Option: B<-sashpad>
+
+=item Name: B<sashPad>
+
+=item Class: B<SashPad>
+
+Specifies the amount of padding to leave of each side of a sash. May
+be any value accepted by B<Tk_GetPixels>.
+
+=item Option: B<-sashrelief>
+
+=item Name: B<sashRelief>
+
+=item Class: B<SashRelief>
+
+Relief to use when drawing a sash. May be any of the standard Tk
+relief values.
+
+=item Option: B<-sashwidth>
+
+=item Name: B<sashWidth>
+
+=item Class: B<SashWidth>
+
+Specifies the width of each sash. May be any value accepted by
+B<Tk_GetPixels>.
+
+=item Option: B<-showhandle>
+
+=item Name: B<showHandle>
+
+=item Class: B<ShowHandle>
+
+Specifies whether sash handles should be shown. May be any valid
+boolean value.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Panedwindow> method creates a new window (given by the
+$panedwindow argument) and makes it into a Panedwindow widget.
+Additional options, described above, may be specified on the command
+line or in the option database to configure aspects of the Panedwindow
+such as its default background color and relief.
+
+A Panedwindow widget contains any number of panes, arranged
+horizontally or vertically, according to the value of the
+B<-orient> option. Each pane contains one widget, and each pair of
+panes is separated by a moveable (via mouse movements) sash. Moving a
+sash causes the widgets on either side of the sash to be resized.
+
+=head1 WIDGET METHODS
+
+The B<Panedwindow> method
+may be used to invoke various operations on the widget. It has the
+following general form:
+
+ $widget->method(?arg arg ...?);
+
+The following
+commands are possible for Panedwindow widgets:
+
+=over 4
+
+=item I<$widget>-E<gt>B<add>(?window ...? ?option value ...?);
+
+Add one or more windows to the Panedwindow, each in a separate pane.
+The arguments consist of the names of one or more windows
+followed by pairs of arguments that specify how to manage the windows.
+I<Option> may have any of the values accepted by the
+B<configure> subcommand.
+
+=item I<$widget>-E<gt>B<cget>(I<option>);
+
+Returns the current value of the configuration option given by
+I<option>. I<Option> may have any of the values accepted by the
+B<Panedwindow> command.
+
+=item I<$widget>-E<gt>B<configure>(I<?option?, ?value, option, value, ...?>);
+
+Query or modify the configuration options of the widget. If no
+I<option> is specified, returns a list describing all of the
+available options for $widget (see L<Tk::configure> for
+information on the format of this list). If I<option> is specified
+with no I<value>, then the command returns a list describing the
+one named option (this list will be identical to the corresponding
+sublist of the value returned if no I<option> is specified). If
+one or more I<option-value> pairs are specified, then the command
+modifies the given widget option(s) to have the given value(s); in
+this case the command returns an empty string. I<Option> may have
+any of the values accepted by the B<Panedwindow> command.
+
+=item I<$widget>-E<gt>B<forget>(?window ...?);
+
+Remove the pane containing $widget from the Panedwindow. All
+geometry management options for $widget will be forgotten.
+
+=item I<$widget>-E<gt>B<identify>(I<x, y>);
+
+Identify the Panedwindow component underneath the point given by
+I<x> and I<y>, in window coordinates. If the point is over a
+sash or a sash handle, the result is a two element list containing the
+index of the sash or handle, and a word indicating whether it is over
+a sash or a handle, such as [0, 'sash'] or [2, 'handle']. If the point is
+over any other part of the Panedwindow, the result is an empty list.
+
+=item I<$widget>-E<gt>B<proxy>(I<?args?>);
+
+This command is used to query and change the position of the sash
+proxy, used for rubberband-style pane resizing. It can take any of
+the following forms:
+
+=over 4
+
+=item I<$widget>-E<gt>B<proxyCoord>;
+
+Return a list containing the x and y coordinates of the most recent
+proxy location.
+
+=item I<$widget>-E<gt>B<proxyForget>;
+
+Remove the proxy from the display.
+
+=item I<$widget>-E<gt>B<proxyPlace>(I<x, y>);
+
+Place the proxy at the given I<x> and I<y> coordinates.
+
+=back
+
+=item I<$widget>-E<gt>B<sash>(I<?args?>);
+
+This command is used to query and change the position of sashes in the
+Panedwindow. It can take any of the following forms:
+
+=over 4
+
+=item I<$widget>-E<gt>B<sashCoord>(I<index>);
+
+Return the current x and y coordinate pair for the sash given by
+I<index>. I<Index> must be an integer between 0 and 1 less than
+the number of panes in the Panedwindow. The coordinates given are
+those of the top left corner of the region containing the sash.
+I<$widget>-E<gt>B<sashDragto>(I<index, x, y>)
+This command computes the difference between the given coordinates and the
+coordinates given to the last B<sash coord> command for the given
+sash. It then moves that sash the computed difference. The return
+value is the empty string.
+
+=item I<$widget>-E<gt>B<sashMark>(I<index, x, y>);
+
+Records I<x> and I<y> for the sash given by I<index>; used in
+conjunction with later dragto commands to move the sash.
+
+=item I<$widget>-E<gt>B<sashPlace>(I<index, x, y>);
+
+Place the sash given by I<index> at the given coordinates.
+
+=back
+
+=item $widget I<$widget>-E<gt>B<panecget>(option);
+
+Query a management option for $widget. I<Option> may be any
+value allowed by the B<paneconfigure> subcommand.
+
+=item $widget I<$widget>-E<gt>B<paneconfigure>(?option? ?value option value ...?);
+
+Query or modify the management options for $widget. If no
+I<option> is specified, returns a list describing all of the
+available options for $widget (see L<Tk::configure> for
+information on the format of this list). If I<option> is specified
+with no I<value>, then the command returns a list describing the
+one named option (this list will be identical to the corresponding
+sublist of the value returned if no I<option> is specified). If
+one or more I<option-value> pairs are specified, then the command
+modifies the given widget option(s) to have the given value(s); in
+this case the command returns an empty string. The following options
+are supported:
+
+=over 4
+
+=item B<-after> =E<gt> $widget
+
+Insert the window after the window specified. $widget should be the
+name of a window already managed by $widget.
+
+=item B<-before> =E<gt> $widget
+
+Insert the window before the window specified. $widget should be
+the name of a window already managed by $widget.
+
+=item B<-height> =E<gt> I<size>
+
+Specify a height for the window. The height will be the outer
+dimension of the window including its border, if any. If I<size>
+is an empty string, or if B<-height> is not specified, then the
+height requested internally by the window will be used initially; the
+height may later be adjusted by the movement of sashes in the
+Panedwindow. I<Size> may be any value accepted by B<Tk_GetPixels>.
+
+=item B<-minsize> =E<gt> I<n>
+
+Specifies that the size of the window cannot be made less than
+I<n>. This constraint only affects the size of the widget in the
+paned dimension -- the x dimension for horizontal Panedwindows, the y
+dimension for vertical Panedwindows. May be any value accepted by
+B<Tk_GetPixels>.
+
+=item B<-padx> =E<gt> I<n>
+
+Specifies a non-negative value indicating how much extra space to
+leave on each side of the window in the X-direction. The value may
+have any of the forms accepted by B<Tk_GetPixels>.
+
+=item B<-pady> =E<gt> I<n>
+
+Specifies a non-negative value indicating how much extra space to
+leave on each side of the window in the Y-direction. The value may
+have any of the forms accepted by B<Tk_GetPixels>.
+
+=item B<-sticky> =E<gt> I<style>
+
+If a window's pane is larger than the requested dimensions of the
+window, this option may be used to position (or stretch) the window
+within its pane. I<Style> is a string that contains zero or more
+of the characters B<n>, B<s>, B<e> or B<w>. The string
+can optionally contains spaces or commas, but they are ignored. Each
+letter refers to a side (north, south, east, or west) that the window
+will "stick" to. If both B<n> and B<s> (or B<e> and B<w>)
+are specified, the window will be stretched to fill the entire height
+(or width) of its cavity.
+
+=item B<-width> =E<gt> I<size>
+
+Specify a width for the window. The width will be the outer
+dimension of the window including its border, if any. If I<size>
+is an empty string, or if B<-width> is not specified, then the
+width requested internally by the window will be used initially; the
+width may later be adjusted by the movement of sashes in the
+Panedwindow. I<Size> may be any value accepted by B<Tk_GetPixels>.
+
+=back
+
+=item I<$widget>-E<gt>B<panes>;
+
+Returns an ordered list of the widgets managed by $widget.
+
+=back
+
+=head1 RESIZING PANES
+
+A pane is resized by grabbing the sash (or sash handle if present) and
+dragging with the mouse. This is accomplished via mouse motion
+bindings on the widget. When a sash is moved, the sizes of the panes
+on each side of the sash, and thus the widgets in those panes, are
+adjusted.
+
+When a pane is resized from outside (eg, it is packed to expand and
+fill, and the containing toplevel is resized), space is added to the final
+(rightmost or bottommost) pane in the window.
+
+=head1 KEYWORDS
+
+Panedwindow, widget, geometry management
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Photo.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Photo.pm
new file mode 100755
index 00000000000..a596dc4d78b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Photo.pm
@@ -0,0 +1,22 @@
+package Tk::Photo;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', 4+q$Revision: #4 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Photo';
+
+sub Tk_image { 'photo' }
+
+Tk::Methods('blank','copy','data','formats','get','put','read',
+ 'redither','transparency','write');
+
+use Tk::Submethods (
+ 'transparency' => [qw/get set/],
+);
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Photo.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Photo.pod
new file mode 100755
index 00000000000..02a691d6261
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Photo.pod
@@ -0,0 +1,475 @@
+# Copyright (c) 1994 The Australian National University
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# Author: Paul Mackerras (paulus@cs.anu.edu.au),
+# Department of Computer Science,
+# Australian National University.
+# RCS: @(#) $Id: photo.n,v 1.2 1998/09/14 18:22:59 stanton Exp $
+#
+
+=head1 NAME
+
+Tk::Photo - Full-color images
+
+=for category Tk Image Classes
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<Photo>(?I<name>??, I<options>?)
+
+=head1 DESCRIPTION
+
+A photo is an L<image|Tk::Image> whose pixels can display any color or be
+transparent. A photo image is stored internally in full color (32
+bits per pixel), and is displayed using dithering if necessary. Image
+data for a photo image can be obtained from a file or a string, or it
+can be supplied from
+C code through a procedural interface. At present, only GIF,
+XBM, XPM, BMP, JPEG, PNG and PPM/PGM
+formats are supported, but an interface exists to allow additional
+image file formats to be added easily. A photo image is transparent
+in regions where no image data has been supplied
+or where it has been set transparent by the B<transparencySet>
+subcommand.
+
+=head1 CREATING PHOTOS
+
+Photos are created using the B<Photo> method.
+B<Photo> supports the following I<options>:
+
+=over 4
+
+=item B<-data> =E<gt> I<string>
+
+Specifies the contents of the image as a string.
+The string can
+contain base64 encoded data or binary data.
+The format of the
+string must be one of those for which there is an image file format
+handler that will accept string data. If both the B<-data>
+and B<-file> options are specified, the B<-file> option takes
+precedence.
+
+=item B<-format> =E<gt> I<format-name>
+
+Specifies the name of the file format for the data specified with the
+B<-data> or B<-file> option.
+
+=item B<-file> =E<gt> I<name>
+
+I<name> gives the name of a file that is to be read to supply data
+for the photo image. The file format must be one of those for which
+there is an image file format handler that can read data.
+
+=item B<-gamma> =E<gt> I<value>
+
+Specifies that the colors allocated for displaying this image in a
+window should be corrected for a non-linear display with the specified
+gamma exponent value. (The intensity produced by most
+CRT displays is a power function of the input value, to a good
+approximation; gamma is the exponent and is typically around 2).
+The value specified must be greater than zero. The default
+value is one (no correction). In general, values greater than one
+will make the image lighter, and values less than one will make it
+darker.
+
+=item B<-height> =E<gt> I<number>
+
+Specifies the height of the image, in pixels. This option is useful
+primarily in situations where the user wishes to build up the contents
+of the image piece by piece. A value of zero (the default) allows the
+image to expand or shrink vertically to fit the data stored in it.
+
+=item B<-palette> =E<gt> I<palette-spec>
+
+Specifies the resolution of the color cube to be allocated for
+displaying this image, and thus the number of colors used from the
+colormaps of the windows where it is displayed. The
+I<palette-spec> string may be either a single decimal number,
+specifying the number of shades of gray to use, or three decimal
+numbers separated by slashes (/), specifying the number of shades of
+red, green and blue to use, respectively. If the first form (a single
+number) is used, the image will be displayed in monochrome (i.e.,
+grayscale).
+
+=item B<-width> =E<gt> I<number>
+
+Specifies the width of the image, in pixels. This option is useful
+primarily in situations where the user wishes to build up the contents
+of the image piece by piece. A value of zero (the default) allows the
+image to expand or shrink horizontally to fit the data stored in it.
+
+=back
+
+=head1 IMAGE METHODS
+
+When a photo image is created, Tk also creates a new object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+
+Those options that write data to the image generally expand the size
+of the image, if necessary, to accommodate the data written to the
+image, unless the user has specified non-zero values for the
+B<-width> and/or B<-height> configuration options, in which
+case the width and/or height, respectively, of the image will not be
+changed.
+
+The following addition methods are available for photo images:
+
+=over 4
+
+=item I<$image>-E<gt>B<blank>
+
+Blank the image; that is, set the entire image to have no data, so it
+will be displayed as transparent, and the background of whatever
+window it is displayed in will show through.
+
+=item I<$image>-E<gt>B<copy>(I<sourceImage> ?,I<option value(s) ...>?)
+
+Copies a region from the image called I<$sourceImage> (which must
+be a photo image) to the image called I<$image>, possibly with
+pixel zooming and/or subsampling. If no options are specified, this
+method copies the whole of I<$sourceImage> into I<$image>,
+starting at coordinates (0,0) in I<$image>. The following
+options may be specified:
+
+=over 8
+
+=item B<-from> =E<gt> I<x1, y1, ? ,x2, y2?>
+
+Specifies a rectangular sub-region of the source image to be copied.
+(I<x1,y1>) and (I<x2,y2>) specify diagonally opposite corners of
+the rectangle. If I<x2> and I<y2> are not specified, the
+default value is the bottom-right corner of the source image. The
+pixels copied will include the left and top edges of the specified
+rectangle but not the bottom or right edges. If the B<-from>
+option is not given, the default is the whole source image.
+
+=item B<-to> =E<gt> I<x1, y1, ?, x2, y2?>
+
+Specifies a rectangular sub-region of the destination image to be
+affected. (I<x1,y1>) and (I<x2,y2>) specify diagonally opposite
+corners of the rectangle. If I<x2> and I<y2> are not specified,
+the default value is (I<x1,y1>) plus the size of the source
+region (after subsampling and zooming, if specified). If I<x2> and
+I<y2> are specified, the source region will be replicated if
+necessary to fill the destination region in a tiled fashion.
+
+=item B<-shrink>
+
+Specifies that the size of the destination image should be reduced, if
+necessary, so that the region being copied into is at the bottom-right
+corner of the image. This option will not affect the width or height
+of the image if the user has specified a non-zero value for the
+B<-width> or B<-height> configuration option, respectively.
+
+=item B<-zoom> =E<gt> I<x, y>
+
+Specifies that the source region should be magnified by a factor of
+I<x> in the X direction and I<y> in the Y direction. If I<y>
+is not given, the default value is the same as I<x>. With this
+option, each pixel in the source image will be expanded into a block
+of I<x> x I<y> pixels in the destination image, all the same
+color. I<x> and I<y> must be greater than 0.
+
+=item B<-subsample> =E<gt> I<x, y>
+
+Specifies that the source image should be reduced in size by using
+only every I<x>th pixel in the X direction and I<y>th pixel in
+the Y direction. Negative values will cause the image to be flipped
+about the Y or X axes, respectively. If I<y> is not given, the
+default value is the same as I<x>.
+
+=item B<-compositingrule> =E<gt> I<rule>
+
+Specifies how transparent pixels in the source image are combined with
+the destination image. When a compositing rule of I<overlay> is
+set, the old contents of the destination image are visible, as if the
+source image were printed on a piece of transparent film and placed
+over the top of the destination. When a compositing rule of I<set>
+is set, the old contents of the destination image are discarded and
+the source image is used as-is. The default compositing rule is
+I<overlay>.
+
+=back
+
+=item I<$image>-E<gt>B<data>(?I<option value(s), ...>?)
+
+Returns image data in the form of a string.
+The following options may be specified:
+
+=over 8
+
+=item B<-background> =E<gt> I< color>
+
+If the color is specified, the data will not contain any transparency
+information. In all transparent pixels the color will be replaced by
+the specified color.
+
+=item B<-format> =E<gt> I<format-name>
+
+Specifies the name of the image file format handler to be used.
+Specifically, this method searches
+for the first handler whose name matches a initial substring of
+I<format-name> and which has the capability to read this image data.
+If this option is not given, this method uses the first
+handler that has the capability to read the image data.
+
+=item B<-from> =E<gt> I<x1, y1, ?, x2, y2?>
+
+Specifies a rectangular region of I<$image> to be
+returned. If only I<x1> and I<y1> are specified, the region
+extends from I<(x1,y1)> to the bottom-right corner of
+I<$image>. If all four coordinates are given, they specify
+diagonally opposite corners of the rectangular region, including x1,y1
+and excluding x2,y2. The default,
+if this option is not given, is the whole image.
+
+=item B<-grayscale>
+
+If this options is specified, the data will not contain color
+information. All pixel data will be transformed into grayscale.
+
+=back
+
+=item I<$image>-E<gt>B<get>(I<x, y>)
+
+Returns the color of the pixel at coordinates (I<x>,I<y>) in the
+image as a list of three integers between 0 and 255, representing the
+red, green and blue components respectively.
+
+=item I<$image>-E<gt>B<put>(I<data> ?,B<-format>=E<gt>I<format-name>? ?,B<-to>=E<gt>I< x1 y1 ?x2 y2?>?)
+
+Sets pixels in I<$image> to the data specified in I<data>.
+This command first searches the list of image file format handlers for
+a handler that can interpret the data in I<data>, and then reads
+the image encoded within into I<$image> (the destination image).
+If I<data> does not match any known format, an attempt to interpret
+it as a (top-to-bottom) list of scan-lines is made, with each
+scan-line being a (left-to-right) list of pixel colors (see
+B<Tk_GetColor> for a description of valid colors.) Every scan-line
+must be of the same length. Note that when I<data> is a single
+color name, you are instructing Tk to fill a rectangular region with
+that color. The following options may be specified:
+
+=over 4
+
+=item B<-format> =E<gt>I<format-name>
+
+Specifies the format of the image data in I<data>.
+Specifically, only image file format handlers whose names begin with
+I<format-name> will be used while searching for an image data
+format handler to read the data.
+
+=item B<-to> =E<gt>I<x, y> ?I<, x2, y2>?
+
+Specifies the coordinates of the top-left corner (I<x1>,I<y1>)
+of the region of I<$image> into which data from I<filename>
+are to be read. The default is (0,0). If I<x2>,I<y2> is given
+and I<data> is not large enough to cover the rectangle specified by
+this option, the image data extracted will be tiled so it covers the
+entire destination rectangle. Note that if I<data> specifies a
+single color value, then a region extending to the bottom-right corner
+represented by (I<x2>,I<y2>) will be filled with that color.
+
+=back
+
+=item I<$image>-E<gt>B<read>(I<filename> ?,I<option value(s), ...>?)
+
+Reads image data from the file named I<filename> into the image.
+This method first searches the list of
+image file format handlers for a handler that can interpret the data
+in I<filename>, and then reads the image in I<filename> into
+I<$image> (the destination image). The following options may be
+specified:
+
+=over 8
+
+=item B<-format> =E<gt> I<format-name>
+
+Specifies the format of the image data in I<filename>.
+Specifically, only image file format handlers whose names begin with
+I<format-name> will be used while searching for an image data
+format handler to read the data.
+
+=item B<-from> =E<gt> I<x1, y1, x2, y2>
+
+Specifies a rectangular sub-region of the image file data to be copied
+to the destination image. If only I<x1> and I<y1> are
+specified, the region extends from (I<x1,y1>) to the bottom-right
+corner of the image in the image file. If all four coordinates are
+specified, they specify diagonally opposite corners or the region.
+The default, if this option is not specified, is the whole of the
+image in the image file.
+
+=item B<-shrink>
+
+If this option is specified, the size of I<$image> will be reduced, if
+necessary, so that the region into which the image file data are read
+is at the bottom-right corner of the I<$image>. This option
+will not affect the width or height of the image if the user has
+specified a non-zero value for the B<-width> or B<-height>
+configuration option, respectively.
+
+=item B<-to> =E<gt> I<x, y>
+
+Specifies the coordinates of the top-left corner of the region of
+I<$image> into which data from I<filename> are to be read.
+The default is (0,0).
+
+=back
+
+=item I<$image>-E<gt>B<redither>
+
+The dithering algorithm used in displaying photo images propagates
+quantization errors from one pixel to its neighbors.
+If the image data for I<$image> is supplied in pieces, the
+dithered image may not be exactly correct. Normally the difference is
+not noticeable, but if it is a problem, this method can be used to
+recalculate the dithered image in each window where the image is
+displayed.
+
+=item I<$image>-E<gt>B<transparency>(I<subcommand, ?arg, arg ...?>);
+
+Allows examination and manipulation of the transparency information in
+the photo image. Several subcommands are available:
+
+=over 4
+
+=item I<$image>-E<gt>B<transparencyGet>(I<x, y>);
+
+Returns a boolean indicating if the pixel at (I<x>,I<y>) is
+transparent.
+
+=item I<$image>-E<gt>B<transparencySet>(I<x, y, boolean>);
+
+Makes the pixel at (I<x>,I<y>) transparent if I<boolean> is
+true, and makes that pixel opaque otherwise.
+
+=back
+
+=item I<$image>-E<gt>B<write>(I<filename> ?,I<option value(s), ...>?)
+
+Writes image data from I<$image> to a file named I<filename>.
+The following options may be specified:
+
+=over 8
+
+=item B<-background> =E<gt> I< color>
+
+If the color is specified, the data will not contain any transparency
+information. In all transparent pixels the color will be replaced by
+the specified color.
+
+=item B<-format> =E<gt> I<format-name>
+
+Specifies the name of the image file format handler to be used to
+write the data to the file. Specifically, this subcommand searches
+for the first handler whose name matches a initial substring of
+I<format-name> and which has the capability to write an image
+file. If this option is not given, this subcommand uses the first
+handler that has the capability to write an image file.
+
+=item B<-from> =E<gt> I<x1, y1, ?, x2, y2?>
+
+Specifies a rectangular region of I<$image> to be written to the
+image file. If only I<x1> and I<y1> are specified, the region
+extends from I<(x1,y1)> to the bottom-right corner of
+I<$image>. If all four coordinates are given, they specify
+diagonally opposite corners of the rectangular region. The default,
+if this option is not given, is the whole image.
+
+
+=item B<-grayscale>
+
+If this options is specified, the data will not contain color
+information. All pixel data will be transformed into grayscale.
+
+=back
+
+=back
+
+=head1 IMAGE FORMATS
+
+The photo image code is structured to allow handlers for additional
+image file formats to be added easily. The photo image code maintains
+a list of these handlers. Handlers are added to the list by
+registering them with a call to B<Tk_CreatePhotoImageFormat>. The
+standard Tk distribution comes with handlers for XBM, XPM, BMP, JPEG,
+PNG and PPM/PGM formats, which are automatically registered on
+initialization.
+
+When reading an image file or processing
+string data specified with the B<-data> configuration option, the
+photo image code invokes each handler in turn until one is
+found that claims to be able to read the data in the file or string.
+Usually this will find the correct handler, but if it doesn't, the
+user may give a format name with the B<-format> option to specify
+which handler to use. In fact the photo image code will try those
+handlers whose names begin with the string specified for the
+B<-format> option (the comparison is case-insensitive). For
+example, if the user specifies B<-format> B<=E<gt>> B<gif>, then a handler
+named GIF87 or GIF89 may be invoked, but a handler
+named JPEG may not (assuming that such handlers had been
+registered).
+
+When writing image data to a file, the processing of the
+B<-format> option is slightly different: the string value given
+for the B<-format> option must begin with the complete name of the
+requested handler, and may contain additional information following
+that, which the handler can use, for example, to specify which variant
+to use of the formats supported by the handler.
+Note that not all image handlers may support writing transparency data
+to a file, even where the target image format does.
+
+=head1 COLOR ALLOCATION
+
+When a photo image is displayed in a window, the photo image code
+allocates colors to use to display the image and dithers the image, if
+necessary, to display a reasonable approximation to the image using
+the colors that are available. The colors are allocated as a color
+cube, that is, the number of colors allocated is the product of the
+number of shades of red, green and blue.
+
+Normally, the number of
+colors allocated is chosen based on the depth of the window. For
+example, in an 8-bit PseudoColor window, the photo image code will
+attempt to allocate seven shades of red, seven shades of green and
+four shades of blue, for a total of 198 colors. In a 1-bit StaticGray
+(monochrome) window, it will allocate two colors, black and white. In
+a 24-bit DirectColor or TrueColor window, it will allocate 256 shades
+each of red, green and blue. Fortunately, because of the way that
+pixel values can be combined in DirectColor and TrueColor windows,
+this only requires 256 colors to be allocated. If not all of the
+colors can be allocated, the photo image code reduces the number of
+shades of each primary color and tries again.
+
+The user can exercise some control over the number of colors that a
+photo image uses with the B<-palette> configuration option. If
+this option is used, it specifies the maximum number of shades of
+each primary color to try to allocate. It can also be used to force
+the image to be displayed in shades of gray, even on a color display,
+by giving a single number rather than three numbers separated by
+slashes.
+
+=head1 CREDITS
+
+The photo image type was designed and implemented by Paul Mackerras,
+based on his earlier photo widget and some suggestions from
+John Ousterhout.
+
+=head1 SEE ALSO
+
+L<Tk::Bitmap|Tk::Bitmap>
+L<Tk::Image|Tk::Image>
+L<Tk::Pixmap|Tk::Pixmap>
+
+=head1 KEYWORDS
+
+photo, image, color
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Pixmap.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Pixmap.pm
new file mode 100755
index 00000000000..3fbc3179b56
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Pixmap.pm
@@ -0,0 +1,19 @@
+package Tk::Pixmap;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TixPixmap/Pixmap.pm#4 $
+
+use Tk qw($XS_VERSION);
+
+use Tk::Image ();
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Pixmap';
+
+bootstrap Tk::Pixmap;
+
+sub Tk_image { 'pixmap' }
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Pixmap.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Pixmap.pod
new file mode 100755
index 00000000000..d0f36b00e65
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Pixmap.pod
@@ -0,0 +1,64 @@
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distribution are in the file
+# license.tcl.
+
+=head1 NAME
+
+Tk::Pixmap - Create color images from XPM files.
+
+=for category Tk Image Classes
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<Pixmap>?(I<name>?,I<options>?)?
+
+=head1 DESCRIPTION
+
+XPM is a popular X Window image file format for storing color icons.
+The B<Pixmap> image type can be used to create color images using XPM files.
+
+Pixmaps support the following I<options>:
+
+=over 4
+
+=item B<-data> =E<gt> I<string>
+
+Specifies the contents of the source pixmap as a string. The string
+must adhere to the XPM file format (e.g., as generated by the
+B<pixmap(1)> program). If both the B<-data> and B<-file>
+options are specified, the B<-data> option takes precedence.
+Please note that the XPM file parsing code in the xpm library is
+somewhat fragile. The first line of the string must be "B</* XPM>
+*/" or otherwise a segmatation fault will be caused.
+
+=item B<-file> =E<gt> I<name>
+
+I<name> gives the name of a file whose contents define the source
+pixmap. The file must adhere to the XPM file format (e.g., as
+generated by the B<pixmap(1)> program).
+
+=back
+
+=head1 IMAGE METHODS
+
+When a pixmap image is created, Tk also creates a new object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+
+=head1 SEE ALSO
+
+L<Tk::Image|Tk::Image>
+
+=head1 KEYWORDS
+
+pixmap, image, tix
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Popup.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Popup.pod
new file mode 100755
index 00000000000..8d40a4ed275
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Popup.pod
@@ -0,0 +1,89 @@
+
+=head1 NAME
+
+Tk::Wm::Popup - popup dialog windows.
+
+=for pm Tk/Wm.pm
+
+=for category Tk Toplevel widgets
+
+=head1 SYNOPSIS
+
+ $dialog->Popup(qw/
+ -popover => 'cursor' | $widget | undef,
+ -overanchor => c | n | ne | e | se | s | sw | w | nw,
+ -popanchor => c | n | ne | e | se | s | sw | w | nw,
+ /);
+
+=head1 DESCRIPTION
+
+You've probably had occasion to use a Dialog (or DialogBox)
+widget. These widgets are derived from a Toplevel (which is a subclass
+of Tk::Wm, the window manager) and spend most of their time in a
+withdrawn state. It's also common to use Toplevels as containers for
+custom built popup windows. Menus, too, are dialogs derived from the
+window manager class. For this discussion, we'll use the simple term
+I<dialog> to refer any widget that pops up and awaits user
+interaction, whether it be a Menu, a special purpose Toplevel, or any
+of the dialog-type widgets, including, but not limited to, ColorEditor,
+Dialog, DialogBox, ErrorDialog, FileSelect, FBox, getOpenFile and
+getSaveFile.
+
+When it's time to display these dialogs, we call the Perl/Tk
+window manager B<Popup> method. B<Popup> accepts three special purpose
+options that specify placement information in high-level terms rather
+than numerical coordinates. It is B<Popup>'s responsibility to take
+our human specifications and turn them into actual screen
+coordinates before displaying the dialog.
+
+We can direct the dialog to appear in two general locations, either
+over another window (e.g. the root window (screen) or a particular
+widget), or over the cursor. This is called the I<popover
+location>. Once we've made this decision we can further refine the
+exact placement of the dialog relative to the popover location by
+specifying the intersection of two I<anchor points>. The I<popanchor
+point> is associated with the dialog and the I<overanchor point> is
+associated with the popover location (whether it be a window or the
+cursor). The point where the two anchor points coincide is the I<popup
+locus>. Anchor points are string values and can be I<c> (for center),
+or any of the eight cardinal compass points: I<n>, I<ne>, I<e>, I<se>,
+I<s>, I<sw>, I<w> or I<nw>.
+
+For example, if I<-popover> specifies a widget, I<-popanchor> is I<sw>,
+and I<-overanchor> is I<ne>, the the dialog's southwest corner pops up
+at the widget's northeast corner.
+
+=head1 OPTIONS
+
+The options recognized by B<Popup> are as follows:
+
+=over 4
+
+=item B<-popover>
+
+Specifies whether the dialog "pops over" a window or the cursor.
+It may be the string I<cursor>, a widget reference, or undef for the
+root window.
+
+=item B<-popanchor>
+
+Specifies the anchor point of the dialog. For instance, if I<e> is
+specified, the right side of the dialog is the anchor.
+
+=item B<-overanchor>
+
+Specifies where the dialog should anchor relative to the popover
+location. For instance, if I<e> is specified the dialog appears over
+the right side of the popover location and if it's I<ne> the the
+dialog is positioned at the upper-right corner of the popover location.
+
+=back
+
+=head1 AUTHOR
+
+Nick Ing-Simmons, Steve Lidie
+
+This code is distributed under the same terms as Perl.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Pretty.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Pretty.pm
new file mode 100755
index 00000000000..7e442a4bcbc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Pretty.pm
@@ -0,0 +1,93 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Pretty;
+require Exporter;
+
+use vars qw($VERSION @EXPORT);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $
+
+use base qw(Exporter);
+
+@EXPORT = qw(Pretty PrintArgs);
+
+sub pretty_list
+{
+ join(',',map(&Pretty($_),@_));
+}
+
+sub Pretty
+{
+ return pretty_list(@_) if (@_ > 1);
+ my $obj = shift;
+ return 'undef' unless defined($obj);
+ my $type = "$obj";
+ return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"}));
+ my $result = '';
+ if (ref $obj)
+ {
+ my $class;
+ if ($type =~ /^([^=]+)=(.*)$/)
+ {
+ $class = $1;
+ $type = $2;
+ $result .= 'bless(';
+ }
+ if ($type =~ /^ARRAY/)
+ {
+ $result .= '[';
+ $result .= pretty_list(@$obj);
+ $result .= ']';
+ }
+ elsif ($type =~ /^HASH/)
+ {
+ $result .= '{';
+ if (%$obj)
+ {
+ my ($key, $value);
+ while (($key,$value) = each %$obj)
+ {
+ $result .= $key . '=>' . Pretty($value) . ',';
+ }
+ chop($result);
+ }
+ $result .= '}';
+ }
+ elsif ($type =~ /^REF/)
+ {
+ $result .= "\\" . Pretty($$obj);
+ }
+ elsif ($type =~ /^SCALAR/)
+ {
+ $result .= Pretty($$obj);
+ }
+ else
+ {
+ $result .= $type;
+ }
+ $result .= ",$class)" if (defined $class);
+ }
+ else
+ {
+ if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ ||
+ $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ ||
+ $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/
+ )
+ {
+ $result .= $obj;
+ }
+ else
+ {
+ $result .= "'" . $obj . "'";
+ }
+ }
+ return $result;
+}
+
+sub PrintArgs
+{
+ my $name = (caller(1))[3];
+ print "$name(",Pretty(@_),")\n";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ProgressBar.pm b/Master/tlpkg/tlperl.straw/lib/Tk/ProgressBar.pm
new file mode 100755
index 00000000000..33e24fbb7ec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ProgressBar.pm
@@ -0,0 +1,498 @@
+package Tk::ProgressBar;
+
+use vars qw($VERSION);
+$VERSION = '4.011'; # was: sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+use Tk;
+use Tk::Canvas;
+use Tk::Trace;
+use Carp;
+use strict;
+
+use base qw(Tk::Derived Tk::Canvas);
+
+Construct Tk::Widget 'ProgressBar';
+
+sub ClassInit {
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class,'<Configure>', ['_layoutRequest',1]);
+}
+
+
+sub Populate {
+ my($c,$args) = @_;
+
+ $c->ConfigSpecs(
+ -width => [PASSIVE => undef, undef, 0],
+ '-length' => [PASSIVE => undef, undef, 0],
+ -from => [PASSIVE => undef, undef, 0],
+ -to => [PASSIVE => undef, undef, 100],
+ -blocks => [PASSIVE => undef, undef, 10],
+ -padx => [PASSIVE => 'padX', 'Pad', 0],
+ -pady => [PASSIVE => 'padY', 'Pad', 0],
+ -gap => [PASSIVE => undef, undef, 1],
+ -colors => [PASSIVE => undef, undef, undef],
+ -relief => [SELF => 'relief', 'Relief', 'sunken'],
+ -value => [METHOD => undef, undef, undef],
+ -variable => [METHOD => undef, undef, undef],
+ -anchor => [METHOD => 'anchor', 'Anchor', 'w'],
+ -resolution
+ => [PASSIVE => undef, undef, 1.0],
+ -highlightthickness
+ => [SELF => 'highlightThickness','HighlightThickness',0],
+ -troughcolor
+ => [PASSIVE => 'troughColor', 'Background', 'grey55'],
+ );
+ _layoutRequest($c,1);
+ $c->OnDestroy(['Destroyed' => $c]);
+}
+
+sub anchor {
+ my $c = shift;
+ my $var = \$c->{Configure}{'-anchor'};
+ my $old = $$var;
+
+ if(@_) {
+ my $new = shift;
+ croak "bad anchor position \"$new\": must be n, s, w or e"
+ unless $new =~ /^[news]$/;
+ $$var = $new;
+ }
+
+ $old;
+}
+
+sub _layoutRequest {
+ my $c = shift;
+ my $why = shift;
+ $c->afterIdle(['_arrange',$c]) unless $c->{'layout_pending'};
+ $c->{'layout_pending'} |= $why;
+}
+
+sub _arrange {
+ my $c = shift;
+ my $why = $c->{'layout_pending'};
+
+ $c->{'layout_pending'} = 0;
+
+ my $w = $c->Width;
+ my $h = $c->Height;
+ my $bw = $c->cget('-borderwidth') + $c->cget('-highlightthickness');
+ my $x = abs(int($c->{Configure}{'-padx'})) + $bw;
+ my $y = abs(int($c->{Configure}{'-pady'})) + $bw;
+ my $value = $c->value;
+ my $from = $c->{Configure}{'-from'};
+ my $to = $c->{Configure}{'-to'};
+ my $horz = $c->{Configure}{'-anchor'} =~ /[ew]/i ? 1 : 0;
+ my $dir = $c->{Configure}{'-anchor'} =~ /[se]/i ? -1 : 1;
+
+ my($minv,$maxv) = $from < $to ? ($from,$to) : ($to,$from);
+
+ if($w == 1 && $h == 1) {
+ my $bw = $c->cget('-borderwidth');
+ my $defw = 10 + $y*2 + $bw *2;
+ my $defl = ($maxv - $minv) + $x*2 + $bw*2;
+
+ $h = $c->pixels($c->{Configure}{'-length'}) || $defl;
+ $w = $c->pixels($c->{Configure}{'-width'}) || $defw;
+
+ ($w,$h) = ($h,$w) if $horz;
+ $c->GeometryRequest($w,$h);
+ $c->parent->update;
+ $c->update;
+
+ $w = $c->Width;
+ $h = $c->Height;
+ }
+
+ $w -= $x*2;
+ $h -= $y*2;
+
+ my $length = $horz ? $w : $h;
+ my $width = $horz ? $h : $w;
+
+ my $blocks = int($c->{Configure}{'-blocks'});
+ my $gap = int($c->{Configure}{'-gap'});
+
+ $blocks = 1 if $blocks < 1;
+
+ my $gwidth = $gap * ( $blocks - 1);
+ my $bwidth = ($length - $gwidth) / $blocks;
+
+ if($bwidth < 3 || $blocks <= 1 || $gap <= 0) {
+ $blocks = 1;
+ $bwidth = $length;
+ $gap = 0;
+ }
+
+ if($why & 1) {
+ my $colors = $c->{Configure}{'-colors'} || [];
+ my $bdir = $from < $to ? $dir : 0 - $dir;
+
+ $c->delete('all');
+
+ $c->createRectangle(0,0,$w+$x*2,$h+$y*2,
+ -fill => $c->{Configure}{'-troughcolor'},
+ -width => 0,
+ -outline => undef);
+
+ $c->{'cover'} = $c->createRectangle($x,$y,$w,$h,
+ -fill => $c->{Configure}{'-troughcolor'},
+ -width => 0,
+ -outline => undef);
+
+ my($x0,$y0,$x1,$y1);
+
+ if($horz) {
+ if($bdir > 0) {
+ ($x0,$y0) = ($x - $gap,$y);
+ }
+ else {
+ ($x0,$y0) = ($length + $x + $gap,$y);
+ }
+ ($x1,$y1) = ($x0,$y0 + $width);
+ }
+ else {
+ if($bdir > 0) {
+ ($x0,$y0) = ($x,$y - $gap);
+ }
+ else {
+ ($x0,$y0) = ($x,$length + $y + $gap);
+ }
+ ($x1,$y1) = ($x0 + $width,$y0);
+ }
+
+ my $blks = $blocks;
+ my $dval = ($maxv - $minv) / $blocks;
+ my $color = $c->cget('-foreground');
+ my $pos = 0;
+ my $val = $minv;
+
+ while($val < $maxv) {
+ my($bw,$nval);
+
+ while(($pos < @$colors) && $colors->[$pos] <= $val) {
+ $color = $colors->[$pos+1];
+ $pos += 2;
+ }
+
+ if($blocks == 1) {
+ $nval = defined($colors->[$pos])
+ ? $colors->[$pos] : $maxv;
+ $bw = (($nval - $val) / ($maxv - $minv)) * $length;
+ }
+ else {
+ $bw = $bwidth;
+ $nval = $val + $dval if($blocks > 1);
+ }
+
+ if($horz) {
+ if($bdir > 0) {
+ $x0 = $x1 + $gap;
+ $x1 = $x0 + $bw;
+ }
+ else {
+ $x1 = $x0 - $gap;
+ $x0 = $x1 - $bw;
+ }
+ }
+ else {
+ if($bdir > 0) {
+ $y0 = $y1 + $gap;
+ $y1 = $y0 + $bw;
+ }
+ else {
+ $y1 = $y0 - $gap;
+ $y0 = $y1 - $bw;
+ }
+ }
+
+ $c->createRectangle($x0,$y0,$x1,$y1,
+ -fill => $color,
+ -width => 0,
+ -outline => undef
+ );
+ $val = $nval;
+ }
+ }
+
+ my $cover = $c->{'cover'};
+ my $ddir = $from > $to ? 1 : -1;
+
+ if(($value <=> $to) == (0-$ddir)) {
+ $c->lower($cover);
+ }
+ elsif(($value <=> $from) == $ddir) {
+ $c->raise($cover);
+ my $x1 = $horz ? $x + $length : $x + $width;
+ my $y1 = $horz ? $y + $width : $y + $length;
+ $c->coords($cover,$x,$y,$x1,$y1);
+ }
+ else {
+ my $step;
+ $value = int($value / $step) * $step
+ if(defined($step = $c->{Configure}{'-resolution'}) && $step > 0);
+
+ $maxv = $minv+1
+ if $minv == $maxv;
+
+ my $range = $maxv - $minv;
+ my $bval = $range / $blocks;
+ my $offset = abs($value - $from);
+ my $ioff = int($offset / $bval);
+ my $start = $ioff * ($bwidth + $gap);
+ $start += ($offset - ($ioff * $bval)) / $bval * $bwidth;
+
+ my($x0,$x1,$y0,$y1);
+
+ if($horz) {
+ $y0 = $y;
+ $y1 = $y + $h;
+ if($dir > 0) {
+ $x0 = $x + $start;
+ $x1 = $x + $w;
+ }
+ else {
+ $x0 = $x;
+ $x1 = $w + $x - $start;
+ }
+ }
+ else {
+ $x0 = $x;
+ $x1 = $x + $w;
+ if($dir > 0) {
+ $y0 = $y + $start;
+ $y1 = $y + $h;
+ }
+ else {
+ $y0 = $y;
+ $y1 = $h + $y - $start;
+ }
+ }
+
+
+ $c->raise($cover);
+ $c->coords($cover,$x0,$y0,$x1,$y1);
+ }
+}
+
+sub value {
+ my $c = shift;
+ my $val = defined($c->{'-variable'})
+ ? $c->{'-variable'}
+ : \$c->{'-value'};
+ my $old = defined($$val) ? $$val : $c->{Configure}{'-from'};
+
+ if(@_) {
+ my $value = shift;
+ $$val = defined($value) ? $value : $c->{Configure}{'-from'};
+ _layoutRequest($c,2);
+ }
+
+ $old;
+}
+
+sub variable {
+ my $c = shift;
+ my $oldvarref = $c->{'-variable'};
+ my $oldval = $$oldvarref if $oldvarref;
+ if(@_) {
+ my $varref = shift;
+ if ($oldvarref)
+ {
+ $c->traceVdelete($oldvarref);
+ }
+ $c->{'-variable'} = $varref;
+ $c->traceVariable($varref, 'w', sub { $c->value($_[1]) });
+ $$varref = $oldval;
+ _layoutRequest($c,2);
+ }
+ $oldval;
+}
+
+sub Destroyed
+{
+ my $c = shift;
+ my $var = delete $c->{'-variable'};
+ $c->traceVdelete($var);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Tk::ProgressBar - A graphical progress bar
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::ProgressBar;
+
+ $progress = $parent->ProgressBar(
+ -width => 200,
+ -length => 20,
+ -anchor => 's',
+ -from => 0,
+ -to => 100,
+ -blocks => 10,
+ -colors => [0, 'green', 50, 'yellow' , 80, 'red'],
+ -variable => \$percent_done
+ );
+
+ $progress->value($position);
+
+=head1 DESCRIPTION
+
+B<Tk::ProgressBar> provides a widget which will show a graphical representation
+of a value, given maximum and minimum reference values.
+
+=head1 STANDARD OPTIONS
+
+The following standard widget options are supported:
+
+=over 4
+
+=item B<-borderwidth>
+
+=item B<-highlightthickness>
+
+Defaults to 0.
+
+=item B<-padx>
+
+Defaults to 0.
+
+=item B<-pady>
+
+Defaults to 0.
+
+=item B<-relief>
+
+Defaults to C<sunken>
+
+=item B<-troughcolor>
+
+The color to be used for the background (trough) of the progress bar.
+Default is to use grey55.
+
+=back
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item B<-anchor>
+
+This can be used to position the start point of the bar. Default
+is 'w' (horizontal bar starting from the left). A vertical bar can be
+configured by using either 's' or 'n'.
+
+=item B<-blocks>
+
+This controls the number of blocks to be used to construct the progress
+bar. The default is to break the bar into 10 blocks.
+
+=item B<-colors>
+
+Controls the colors to be used for different positions of the progress bar.
+The colors should be supplied as a reference to an array containing pairs
+of positions and colors.
+
+ -colors => [ 0, 'green', 50, 'red' ]
+
+means that for the range 0 to 50 the progress bar should be green
+and for higher values it should be red.
+
+
+=item B<-from>
+
+This sets the lower limit of the progress bar. If the bar is set to a
+value below the lower limt no bar will be displayed. Defaults to 0.
+See the C<-to> description for more information.
+
+=item B<-gap>
+
+This is the spacing (in pixels) between each block. Defaults to 1.
+Use 0 to get a continuous bar.
+
+
+=item B<-length>
+
+Specifies the desired long dimension of the ProgressBar in screen
+units (i.e. any of the forms acceptable to Tk_GetPixels). For vertical
+ProgressBars this is the ProgressBars height; for horizontal scales it
+is the ProgressBars width. The default length is calculated from the
+values of C<-padx>, C<-borderwidth>, C<-highlightthickness> and the
+difference between C<-from> and C<-to>.
+
+
+=item B<-resolution>
+
+A real value specifying the resolution for the scale. If this value is greater
+than zero then the scale's value will always be rounded to an even multiple of
+this value, as will tick marks and the endpoints of the scale. If the value is
+less than zero then no rounding occurs. Defaults to 1 (i.e., the value will be
+integral).
+
+=item B<-to>
+
+This sets the upper limit of the progress bar. If a value is specified
+(for example, using the C<value> method) that lies above this value the
+full progress bar will be displayed. Defaults to 100.
+
+
+
+=item B<-variable>
+
+Specifies the reference to a scalar variable to link to the ProgressBar.
+Whenever the value of the variable changes, the ProgressBar will upate
+to reflect this value. (See also the B<value> method below.)
+
+=item B<-value>
+
+The can be used to set the current position of the progress bar
+when used in conjunction with the standard C<configure>. It is
+usually recommended to use the B<value> method instead.
+
+
+=item B<-width>
+
+Specifies the desired narrow dimension of the ProgressBar in screen
+units (i.e. any of the forms acceptable to Tk_GetPixels). For
+vertical ProgressBars this is the ProgressBars width; for horizontal
+bars this is the ProgressBars height. The default width is derived
+from the values of C<-borderwidth> and C<-pady> and C<-highlightthickness>.
+
+=back
+
+=head1 WIDGET METHODS
+
+=over 4
+
+=item I<$ProgressBar>-E<gt>B<value>(?I<value>?)
+
+If I<value> is omitted, returns the current value of the ProgressBar. If
+I<value> is given, the value of the ProgressBar is set. If I<$value> is
+given but undefined the value of the option B<-from> is used.
+
+=back
+
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-1998 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/README.Adjust b/Master/tlpkg/tlperl.straw/lib/Tk/README.Adjust
new file mode 100755
index 00000000000..8c3eba45717
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/README.Adjust
@@ -0,0 +1,77 @@
+Subject: Adjuster
+Date: Wed, 16 Dec 1998 22:23:23 +0100
+From: Stephen Kun <stephen.kun@is.gaertner.de>
+To: Nick Ing-Simmons <nick@ni-s.u-net.com>
+
+
+
+
+3. How do I find out whether slave is a pack or grid master or if it is not a
+master (for setting packPropagate(0))
+Currently I set both on the slave.
+
+4. In setting position of drag bar, I do a lot of calcs for each motion event.
+Some could be done one for first, then used again for subsequent calls, eg:
+borderwidth of master, etc.
+I've now partially done this and store them on the widget.
+
+5. Do I need XSync and idletasks calls in Adjuster.pm?
+XSync causes a bug. idletasks doesn't make any difference in practice, from
+what I can see. I've commented both out.
+Bug when using XSync:
+ Run pack_adj_4r
+ Shorten whole window from right so that left window edge crosses leftmost
+ adjuster. Buttons on other adjusters disappear
+
+6. Sometimes the effect given by the Restore method, is undesirable. Eg.
+for multi-columns. Then when you expand say the 1st column, the size of the
+col at the end gets reduced to 0 width when the Adjuster forces itself in.
+Then when you reduce the size of the first column again, the end col is still
+0 width.
+Better would be:
+a) put the restore functionality on a flag OR
+b) when a col is reduced because of a Restore, it saves previous width of
+its slave, and attempts to restore it when the space becomes availabe. (Sounds
+impracticable.)
+I've implemented a) with default ON. In the documentation I'll recommend the
+default for the 1st Adjuster, then OFF for the remaining.
+
+8. What about a packAdjustForget? Given that Adjuster doesn't work well for
+grid anyway, and doesn't consider other managers, that wouldn't be too bad.
+I'm not going to do this, but someone mentioned it a while ago. I can
+see me probably wanting it too at some point.
+Are you for the idea?
+
+10. Grid doesn't work well with Adjuster, didn't before either. I think
+this has to do with grid, rather than adjuster. You get the same effect
+if you grid a row of widgets, then reduce the width of the window.
+Bugs demonstrated by grid_adj_4l:
+a) there's never an Unmap event for the adjuster.
+b) after adjusting, widgets protrude into border on right.
+c) grid('Propagate', 0) on MainWindow has no effect - window shrinks/grows
+ when widgets are adjusted
+d) widgets shuffle to correct position on startup
+I don't recommend use of grid with Adjust!
+
+11. Have taken out __END__ temporarily for testing
+Will put it back before publishing on the mailing list.
+
+12. Why do the adjusters in my testcases come out grey? That's not the
+default background.
+
+13. Could packAdjust return ($adj, $w). Could then do:
+ my $canv = $top->Canvas()->packAdjust();
+OR
+ my ($adj, $canv) = $top->Canvas()->packAdjust();
+Latter is good if you want to configure or unpack adjuster later.
+I realise this is very Kludgy, but there's no other way to get the
+Adjuster from packAdjust.
+I suppose the workaround of creating the Adjuster yourself is OK. When
+you do it by hand though, there's more chance of making mistakes, eg
+forgetting the -side (which defaults then to 'top') which would cause havoc.
+What's your opinion.
+
+14. Run the script adj_button_bug: You can't reduce size of button.
+Button can be expanded, but as soon as focus enters button, it springs back
+to its original size. Why?
+It's not important though.
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ROText.pm b/Master/tlpkg/tlperl.straw/lib/Tk/ROText.pm
new file mode 100755
index 00000000000..cc5634f5475
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ROText.pm
@@ -0,0 +1,43 @@
+# Copyright (c) 1995-2003 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.
+package Tk::ROText;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Text;
+use base qw(Tk::Derived Tk::Text);
+
+Construct Tk::Widget 'ROText';
+
+sub clipEvents
+{
+ return qw[Copy];
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ my $val = $class->bindRdOnly($mw);
+ my $cb = $mw->bind($class,'<Next>');
+ $mw->bind($class,'<space>',$cb) if (defined $cb);
+ $cb = $mw->bind($class,'<Prior>');
+ $mw->bind($class,'<BackSpace>',$cb) if (defined $cb);
+ $class->clipboardOperations($mw,'Copy');
+ return $val;
+}
+
+sub Populate {
+ my($self,$args) = @_;
+ $self->SUPER::Populate($args);
+ my $m = $self->menu->entrycget($self->menu->index('Search'), '-menu');
+ $m->delete($m->index('Replace'));
+}
+
+sub Tk::Widget::ScrlROText { shift->Scrolled('ROText' => @_) }
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ROText.pod b/Master/tlpkg/tlperl.straw/lib/Tk/ROText.pod
new file mode 100755
index 00000000000..efc64ed79f3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ROText.pod
@@ -0,0 +1,31 @@
+
+=head1 NAME
+
+Tk::ROText - 'readonly' perl/Tk Text widget
+
+=for pm Tk/ROText.pm
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::ROText;
+ ...
+ $ro = $mw->ROText(?options,...?);
+
+=head1 DESCRIPTION
+
+This "I<IS A>" text widget with all bindings removed that would alter
+the contents of the text widget. The contents can still be modified
+via method calls.
+
+=head1 KEYS
+
+widget, text, readonly
+
+=head1 SEE ALSO
+
+L<Tk::Text>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pm
new file mode 100755
index 00000000000..d09d41b4208
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pm
@@ -0,0 +1,45 @@
+# Conversion from Tk4.0 button.tcl competed.
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+package Tk::Radiobutton;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Radiobutton.pm#6 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+require Tk::Button;
+
+
+use base qw(Tk::Button);
+Construct Tk::Widget 'Radiobutton';
+
+sub Tk_cmd { \&Tk::radiobutton }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-variable');
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'Invoke');
+ $mw->bind($class,'<space>', 'Invoke');
+ return $class;
+}
+
+sub Invoke
+{
+ my $w = shift;
+ $w->invoke() unless($w->cget('-state') eq 'disabled');
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pod
new file mode 100755
index 00000000000..82fad4893fd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Radiobutton.pod
@@ -0,0 +1,333 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Radiobutton - Create and manipulate Radiobutton widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$radiobutton> = I<$parent>-E<gt>B<Radiobutton>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground>
+B<-activeforeground>
+B<-anchor>
+B<-background>
+B<-bitmap>
+B<-borderwidth>
+B<-compound>
+B<-cursor>
+B<-disabledforeground>
+B<-font>
+B<-foreground>
+B<-highlightbackground>
+B<-highlightcolor>
+B<-highlightthickness>
+B<-image>
+B<-justify>
+B<-padx>
+B<-pady>
+B<-relief>
+B<-takefocus>
+B<-text>
+B<-textvariable>
+B<-underline>
+B<-wraplength>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies a L<perl/Tk callback|Tk::callbacks> to associate with the button. This command
+is typically invoked when mouse button 1 is released over the button
+window. The button's global variable (B<-variable> option) will
+be updated before the command is invoked.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies a desired height for the button.
+If an image or bitmap is being displayed in the button then the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in lines of text.
+If this option isn't specified, the button's desired height is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=item Name: B<indicatorOn>
+
+=item Class: B<IndicatorOn>
+
+=item Switch: B<-indicatoron>
+
+Specifies whether or not the indicator should be drawn. Must be a
+proper boolean value. If false, the B<relief> option is
+ignored and the widget's relief is always sunken if the widget is
+selected and raised otherwise.
+
+=item Command-Line Name: B<-offrelief>
+
+=item Database Name: B<offRelief>
+
+=item Database Class: B<OffRelief>
+
+Specifies the relief for the checkbutton when the indicator is not
+drawn and the checkbutton is off. The default value is B<raised>. By
+setting this option to B<flat> and setting
+B<-indicatoron false -overrelief raised>, the effect is achieved of
+having a flat button
+that raises on mouse-over and which is depressed when activated. This
+is the behavior typically exhibited by the Bold, Italic, and
+Underline checkbuttons on the toolbar of a word-processor, for
+example.
+
+=item Command-Line Name: B<-overrelief>
+
+=item Database Name: B<overRelief>
+
+=item Database Class: B<OverRelief>
+
+Specifies an alternative relief for the button, to be used when
+the mouse cursor is over the widget. This option can be used to
+make toolbar buttons, by configuring B<-relief flat -overrelief
+raised>. If the value of this option is the empty string, then
+no alternative relief is used when the mouse cursor is over the
+button. The empty string is the default value.
+
+=item Name: B<selectColor>
+
+=item Class: B<Background>
+
+=item Switch: B<-selectcolor>
+
+Specifies a background color to use when the button is selected.
+If B<indicatorOn> is true then the color applies to the indicator.
+Under Windows, this color is used as the background for the indicator
+regardless of the select state.
+If B<indicatorOn> is false, this color is used as the background
+for the entire widget, in place of B<background> or B<activeBackground>,
+whenever the widget is selected.
+If specified as an empty string then no special color is used for
+displaying when the widget is selected.
+
+=item Name: B<selectImage>
+
+=item Class: B<SelectImage>
+
+=item Switch: B<-selectimage>
+
+Specifies an image to display (in place of the B<image> option)
+when the radiobutton is selected.
+This option is ignored unless the B<image> option has been
+specified.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of three states for the radiobutton: B<normal>, B<active>,
+or B<disabled>. In normal state the radiobutton is displayed using the
+B<foreground> and B<background> options. The active state is
+typically used when the pointer is over the radiobutton. In active state
+the radiobutton is displayed using the B<activeForeground> and
+B<activeBackground> options. Disabled state means that the radiobutton
+should be insensitive: the default bindings will refuse to activate
+the widget and will ignore mouse button presses.
+In this state the B<disabledForeground> and
+B<background> options determine how the radiobutton is displayed.
+
+=item Name: B<value>
+
+=item Class: B<Value>
+
+=item Switch: B<-value>
+
+Specifies value to store in the button's associated variable whenever
+this button is selected.
+
+=item Name: B<variable>
+
+=item Class: B<Variable>
+
+=item Switch: B<-variable>
+
+Specifies reference to a variable to set whenever this button is
+selected. Changes in this variable also cause the button to select
+or deselect itself. Defaults to the value C<\$Tk::selectedButton>.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies a desired width for the button.
+If an image or bitmap is being displayed in the button, the value is in
+screen units (i.e. any of the forms acceptable to B<Tk_GetPixels>);
+for text it is in characters.
+If this option isn't specified, the button's desired width is computed
+from the size of the image or bitmap or text being displayed in it.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Radiobutton> method creates a new window (given by the
+$widget argument) and makes it into a radiobutton widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the radiobutton such as its colors, font,
+text, and initial relief. The B<radiobutton> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A radiobutton is a widget that displays a textual string, bitmap or image
+and a diamond or circle called an I<indicator>.
+If text is displayed, it must all be in a single font, but it
+can occupy multiple lines on the screen (if it contains newlines
+or if wrapping occurs because of the B<wrapLength> option) and
+one of the characters may optionally be underlined using the
+B<underline> option. A radiobutton has
+all of the behavior of a simple button: it can display itself in either
+of three different ways, according to the B<state> option;
+it can be made to appear
+raised, sunken, or flat; it can be made to flash; and it invokes
+a L<perl/Tk callback|Tk::callbacks> whenever mouse button 1 is clicked over the
+check button.
+
+In addition, radiobuttons can be I<selected>.
+If a radiobutton is selected, the indicator is normally
+drawn with a selected appearance, and
+a Tcl variable associated with the radiobutton is set to a particular
+value (normally 1).
+Under Unix, the indicator is drawn with a sunken relief and a special
+color. Under Windows, the indicator is drawn with a round mark inside.
+If the radiobutton is not selected, then the indicator is drawn with a
+deselected appearance, and the associated variable is
+set to a different value (typically 0).
+Under Unix, the indicator is drawn with a raised relief and no special
+color. Under Windows, the indicator is drawn without a round mark inside.
+Typically, several radiobuttons share a single variable and the
+value of the variable indicates which radiobutton is to be selected.
+When a radiobutton is selected it sets the value of the variable to
+indicate that fact; each radiobutton also monitors the value of
+the variable and automatically selects and deselects itself when the
+variable's value changes.
+By default the variable B<selectedButton>
+is used; its contents give the name of the button that is
+selected, or the empty string if no button associated with that
+variable is selected.
+The name of the variable for a radiobutton,
+plus the variable to be stored into it, may be modified with options
+on the command line or in the option database.
+Configuration options may also be used to modify the way the
+indicator is displayed (or whether it is displayed at all).
+By default a radiobutton is configured to select itself on button clicks.
+
+=head1 WIDGET METHODS
+
+The B<Radiobutton> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for radiobutton widgets:
+
+=over 4
+
+=item I<$radiobutton>-E<gt>B<deselect>
+
+Deselects the radiobutton and sets the associated variable to an
+empty string.
+If this radiobutton was not currently selected, the command has
+no effect.
+
+=item I<$radiobutton>-E<gt>B<flash>
+
+Flashes the radiobutton. This is accomplished by redisplaying the radiobutton
+several times, alternating between active and normal colors. At
+the end of the flash the radiobutton is left in the same normal/active
+state as when the command was invoked.
+This command is ignored if the radiobutton's state is B<disabled>.
+
+=item I<$radiobutton>-E<gt>B<invoke>
+
+Does just what would have happened if the user invoked the radiobutton
+with the mouse: selects the button and invokes
+its associated Tcl command, if there is one.
+The return value is the return value from the Tcl command, or an
+empty string if there is no command associated with the radiobutton.
+This command is ignored if the radiobutton's state is B<disabled>.
+
+=item I<$radiobutton>-E<gt>B<select>
+
+Selects the radiobutton and sets the associated variable to the
+value corresponding to this widget.
+
+=back
+
+=head1 BINDINGS
+
+Tk automatically creates class bindings for radiobuttons that give them
+the following default behavior:
+
+=over 4
+
+=item [1]
+
+On Unix systems, a radiobutton activates whenever the mouse passes
+over it and deactivates whenever the mouse leaves the radiobutton. On
+Mac and Windows systems, when mouse button 1 is pressed over a
+radiobutton, the button activates whenever the mouse pointer is inside
+the button, and deactivates whenever the mouse pointer leaves the
+button.
+
+=item [2]
+
+When mouse button 1 is pressed over a radiobutton it is invoked (it
+becomes selected and the command associated with the button is
+invoked, if there is one).
+
+=item [3]
+
+When a radiobutton has the input focus, the space key causes the radiobutton
+to be invoked.
+
+If the radiobutton's state is B<disabled> then none of the above
+actions occur: the radiobutton is completely non-responsive.
+
+The behavior of radiobuttons can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 KEYWORDS
+
+radiobutton, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Region.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Region.pm
new file mode 100755
index 00000000000..3e02bd2ff49
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Region.pm
@@ -0,0 +1,182 @@
+package Tk::Region;
+
+# Ideas in progress do not document ...
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Region.pm#6 $
+
+use Tk::Widget ();
+
+Construct Tk::Widget 'Region';
+
+my %index = (-widget => 1, '-x' => 2, '-y' => 3, -width => 4, -height => 5);
+
+sub _attr
+{
+ my ($obj,$key,$val) = @_;
+ if (@_ > 2)
+ {
+ $obj->{$key} = $val;
+ }
+ return $obj->{$key}
+}
+
+foreach my $name (qw(widget x y width height))
+ {
+ my $key = "-$name";
+ no strict 'refs';
+ *{$name} = sub { shift->_attr($key,@_) };
+ }
+
+sub new
+{
+ my $class = shift;
+ my $widget = shift;
+ my $obj = bless [\%index,$widget,0,0,0,0],$class;
+ $obj->configure(@_);
+}
+
+sub cfgDefault
+{
+ my ($class,$key) = @_;
+ return undef;
+}
+
+sub cfgName
+{
+ my ($class,$key) = @_;
+ $key =~ s/^-//;
+ return lcfirst($key);
+}
+
+sub cfgClass
+{
+ return ucfirst(shift->cfgName(@_));
+}
+
+sub configure
+{
+ my $obj = shift;
+ my @results;
+ if (@_ > 1)
+ {
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ if (exists $obj->{$key})
+ {
+ $obj->{$key} = $val;
+ }
+ else
+ {
+ my ($meth) = $key =~ /^-(\w+)$/;
+ croak("Invalid option $key") unless $obj->can($meth);
+ $obj->$meth($val);
+ }
+ }
+ }
+ elsif (@_ == 1)
+ {
+ my $key = shift;
+ my $value = $obj->cget($key);
+ push(@results,$key,$obj->cfgName($key),$obj->cfgClass($key),$obj->cfgDefault($key),$value);
+ }
+ else
+ {
+ foreach my $key (sort keys %$obj)
+ {
+ push(@results,scalar($obj->configure($key)))
+ }
+ }
+ return wantarray ? @results : \@results;
+}
+
+sub cget
+{
+ my $obj = shift;
+ my $key = shift;
+ return $obj->{$key} if exists $obj->{$key};
+ my ($meth) = $key =~ /^-(\w+)$/;
+ croak("Invalid option $key") unless $obj->can($meth);
+ return $obj->$meth();
+}
+
+sub bbox
+{
+ my $obj = shift;
+ my @results;
+ if (@_)
+ {
+ my $ref = (@_ == 1) ? shift : \@_;
+ my ($x1,$y1,$x2,$y2) = (ref $ref) ? @$ref : split(/\s+/,$ref);
+ ($x2,$x1) = ($x1,$x2) if ($x2 < $x1);
+ ($y2,$y1) = ($y1,$y2) if ($y2 < $y1);
+ $obj->width($x2-$x1);
+ $obj->height($y2-$y1);
+ $obj->x($x1);
+ $obj->y($y1);
+ }
+ else
+ {
+ my $x = $obj->x;
+ my $y = $obj->x;
+ push(@results,$x,$y,$x+$obj->width,$y+$obj->height);
+ }
+ return wantarray ? @results : \@results;
+}
+
+sub rootx
+{
+ my $obj = shift;
+ if (@_)
+ {
+ my $x = shift;
+ $obj->x($x-$obj->widget->rootx);
+ }
+ return $obj->widget->rootx + $obj->{'-x'}
+}
+
+sub rooty
+{
+ my $obj = shift;
+ if (@_)
+ {
+ my $y = shift;
+ $obj->y($y-$obj->widget->rootx);
+ }
+ return $obj->widget->rooty + $obj->{'-y'}
+}
+
+sub rootxy
+{
+ my $obj = shift;
+ if (@_)
+ {
+ $obj->rootx(shift);
+ $obj->rooty(shift);
+ }
+ my @results = ($obj->rootx,$obj->rooty);
+ return wantarray ? @results : \@results;
+}
+
+sub rootbbox
+{
+ my $obj = shift;
+ my ($x1,$y1) = $obj->rootxy;
+ my $x2 = $x1+$obj->width;
+ my $y2 = $y1+$obj->height;
+ my @results = ($x1,$y1,$x2,$y2);
+ return wantarray ? @results : \@results;
+}
+
+
+*Width = \&width;
+*Height = \&height;
+*X = \&rootx;
+*Y = \&rooty;
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Reindex.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Reindex.pm
new file mode 100755
index 00000000000..d18ca8b19fc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Reindex.pm
@@ -0,0 +1,233 @@
+package Tk::Reindex;
+
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/TextList/Reindex.pm#4 $
+
+use Tk;
+use base qw(Tk::Derived);
+
+
+sub Populate
+{
+ my ($w, $args) = @_;
+
+ $w->_callbase('Populate',$args);
+
+ $w->ConfigSpecs(-linestart => ["PASSIVE", "lineStart", "LineStart", 0],
+ -toindexcmd => ["CALLBACK", "toIndexCmd", "ToIndexCmd" , [\&to_index,$w]],
+ -fromindexcmd => ["CALLBACK", "fromIndexCmd","FromIndexCmd", [\&from_index,$w]]);
+}
+
+sub import
+{
+ my($module,$base)=@_;
+ my $pkg=(caller)[0];
+
+ no strict 'refs';
+ *{"${pkg}::_reindexbase"}=sub{$base};
+}
+
+sub _callbase
+{
+ my($w,$sub)=(shift,shift);
+ my $supersub=$w->_reindexbase()."::$sub";
+ $w->$supersub(@_);
+}
+
+BEGIN
+{
+ # list of subroutines and index argument number (-1 as first element means return value)
+ my %subs=('bbox' => [0],
+ 'compare' => [0,2],
+ 'delete' => [0,1],
+ 'dlineinfo' => [0],
+ 'dump' => \&_find_dump_index,
+ 'get' => [0,1],
+ 'index' => [-1,0],
+ 'insert' => [0],
+ 'mark' => \&_find_mark_index,
+ 'search' => \&_find_search_index,
+ 'see' => [0],
+ 'tag' => \&_find_tag_index,
+ 'window' => [1],
+ 'image' => [1],
+ );
+
+ foreach my $sub (keys %subs)
+ {
+ my $args=$subs{$sub};
+ my $argsub=ref $args eq 'CODE'?$args:sub{$args};
+ my $newsub=sub
+ {
+ my($w)=shift;
+ my(@iargs)=grep($_<=$#_,@{$argsub->(@_)});
+ my $iret=shift @iargs if @iargs && $iargs[0]==-1;
+ my(@args)=@_;
+ @args[@iargs]=$w->Callback(-toindexcmd,@args[@iargs]);
+ my(@ret)=$w->_callbase($sub,@args);
+ @ret=$w->Callback(-fromindexcmd,@ret) if $iret;
+ wantarray?@ret:$ret[0];
+ };
+ no strict 'refs';
+ *{$sub}=$newsub;
+ }
+}
+
+sub to_index
+{
+ my $w=shift;
+ my $offset=$w->cget(-linestart)+1;
+ my(@args)=@_;
+ foreach (@args)
+ {
+ s/^\d+(?=\.)/$&+$offset/e;
+ }
+ @args;
+}
+
+sub from_index
+{
+ my $w=shift;
+ my $offset=$w->cget(-linestart)+1;
+ my(@args)=@_;
+ foreach (@args)
+ {
+ s/^\d+(?=\.)/$&-$offset/e
+ }
+ @args;
+}
+
+sub _find_dump_index
+{
+ my $idx=_count_options(@_);
+ [$idx,$idx+1];
+}
+
+sub _find_search_index
+{
+ my $idx=_count_options(@_);
+ [$idx+1,$idx+2];
+}
+
+sub _count_options
+{
+ my $idx=0;
+ while($_[$idx]=~/^-/g)
+ {
+ $idx++;
+ $idx++ if $' eq 'count' or $' eq 'command';
+ last if $' eq '-';
+ }
+ $idx;
+}
+
+sub _find_tag_index
+{
+ return [1] if $_[0] eq 'names';
+ return [2,3] if $_[0]=~/^(add|remove|nextrange|prevrange)$/;
+ return [-1] if $_[0] eq 'ranges';
+ return [];
+}
+
+sub _find_mark_index
+{
+ return [2] if $_[0] eq 'set';
+ return [1] if $_[0] eq 'next' or $_[0] eq 'previous';
+ return [];
+}
+
+1;
+
+=head1 NAME
+
+Tk::Reindex - change the base index of Text-like widgets
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::ReindexedText;
+ $t1=$w->ReindexedText(-linestart => 2);
+
+ use Tk::ReindexedROText;
+ $t2=$w->ReindexedROText(-linestart => 0);
+
+=head1 DESCRIPTION
+
+Creates a new widget class based on B<Text>-like widgets that can
+redefine the line number base (normally B<Text> widgets start line
+numbers at 1), or possibly other manipulations on indexes.
+
+=head1 STANDARD OPTIONS
+
+The newly-defined widget takes all the same options as the base
+widget, which defaults to B<Text>.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over
+
+=item Name: B<lineStart>
+
+=item Class: B<LineStart>
+
+=item Switch: B<-linestart>
+
+Sets the line number of the first line in the B<Text> widget. The
+default B<-toindexcmd> and B<-fromindexcmd> use this configuration
+option.
+
+-item Name: B<toIndexCmd> B<fromIndexCmd>
+
+-item Class: B<ToIndexCmd> B<FromIndexCmd>
+
+-item Switch: B<-toindexcmd> B<-fromindexcmd>
+
+These two options specify callbacks that are called with a list of
+indexes and are responsible for translating them to/from indexes that
+the base B<Text> widget can understand. The callback is passed the
+widget followed by a list of indexes, and should return a list of
+translated indexes. B<-toindexcmd> should translate from 'user'
+indexes to 'native' B<Text>-compatible indexes, and B<-fromindexcmd>
+should translate from 'native' indexes to 'user' indexes.
+
+The default callbacks simply add/subtract the offset given by the
+B<-linestart> option for all indexes in 'line.character' format.
+
+It would probably be prudent to make these functions inverses of each
+other.
+
+=back
+
+=head1 CLASS METHODS
+
+=over
+
+=item import
+
+To make new Reindex widgets, this function should be called via B<use>
+with the name of the Text-like base class that you are extending with
+"Reindex" capability. 'use base(Tk::Reindex Tk::nameofbasewidget)'
+should also be specified for that widget.
+
+=back
+
+=head1 BUGS
+
+I've used the word "indexes" instead of "indices" throughout the
+documentation.
+
+All the built-in perl code for widget bindings & methods will use the
+new 'user' indexes. Which means all this index manipulation might
+might break code that is trying to parse/manipulate indexes. Or even
+assume that '1.0' is the beginning index. B<Tk::Text::Contents> comes
+to mind.
+
+=head1 AUTHOR
+
+Andrew Allen <ada@fc.hp.com>
+
+This code may be distributed under the same conditions as Perl.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ReindexedROText.pm b/Master/tlpkg/tlperl.straw/lib/Tk/ReindexedROText.pm
new file mode 100755
index 00000000000..8c293f5fa61
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ReindexedROText.pm
@@ -0,0 +1,13 @@
+use strict;
+package Tk::ReindexedROText;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/ReindexedROText.pm#4 $
+
+use Tk::Reindex qw(Tk::ROText);
+use base qw(Tk::Reindex Tk::ROText);
+Construct Tk::Widget 'ReindexedROText';
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/ReindexedText.pm b/Master/tlpkg/tlperl.straw/lib/Tk/ReindexedText.pm
new file mode 100755
index 00000000000..c16a6fe7fd7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/ReindexedText.pm
@@ -0,0 +1,13 @@
+use strict;
+package Tk::ReindexedText;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/ReindexedText.pm#4 $
+
+use Tk::Reindex qw(Tk::Text);
+use base qw(Tk::Reindex Tk::Text);
+Construct Tk::Widget 'ReindexedText';
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Scale.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Scale.pm
new file mode 100755
index 00000000000..57c7bb11aa1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Scale.pm
@@ -0,0 +1,278 @@
+# Converted from scale.tcl --
+#
+# This file defines the default bindings for Tk scale widgets.
+#
+# @(#) scale.tcl 1.3 94/12/17 16:05:23
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# 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.
+
+package Tk::Scale;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Scale/Scale.pm#4 $
+
+use Tk qw($XS_VERSION);
+use AutoLoader;
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Scale';
+
+bootstrap Tk::Scale;
+
+sub Tk_cmd { \&Tk::scale }
+
+Tk::Methods('coords','get','identify','set');
+
+
+import Tk qw(Ev);
+
+#
+# Bind --
+# This procedure below invoked the first time the mouse enters a
+# scale widget or a scale widget receives the input focus. It creates
+# all of the class bindings for scales.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $mw->bind($class,'<Enter>',['Enter',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<Motion>',['Activate',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<Leave>','Leave');
+
+ $mw->bind($class,'<1>',['ButtonDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>',['Drag',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Leave>','NoOp');
+ $mw->bind($class,'<B1-Enter>','NoOp');
+ $mw->bind($class,'<ButtonRelease-1>',['ButtonUp',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<2>',['ButtonDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['Drag',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Leave>','NoOp');
+ $mw->bind($class,'<B2-Enter>','NoOp');
+ $mw->bind($class,'<ButtonRelease-2>',['ButtonUp',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<Control-1>',['ControlPress',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<Up>',['Increment','up','little','noRepeat']);
+ $mw->bind($class,'<Down>',['Increment','down','little','noRepeat']);
+ $mw->bind($class,'<Left>',['Increment','up','little','noRepeat']);
+ $mw->bind($class,'<Right>',['Increment','down','little','noRepeat']);
+
+ $mw->bind($class,'<Control-Up>',['Increment','up','big','noRepeat']);
+ $mw->bind($class,'<Control-Down>',['Increment','down','big','noRepeat']);
+ $mw->bind($class,'<Control-Left>',['Increment','up','big','noRepeat']);
+ $mw->bind($class,'<Control-Right>',['Increment','down','big','noRepeat']);
+
+ $mw->bind($class,'<Home>',['set',Ev('cget','-from')]);
+ $mw->bind($class,'<End>',['set',Ev('cget','-to')]);
+ return $class;
+}
+
+1;
+
+__END__
+
+# Activate --
+# This procedure is invoked to check a given x-y position in the
+# scale and activate the slider if the x-y position falls within
+# the slider.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates.
+sub Activate
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ return if ($w->cget('-state') eq 'disabled');
+ my $ident = $w->identify($x,$y);
+ if (defined($ident) && $ident eq 'slider')
+ {
+ $w->configure(-state => 'active')
+ }
+ else
+ {
+ $w->configure(-state => 'normal')
+ }
+}
+
+sub Leave
+{
+ my ($w) = @_;
+ $w->configure('-activebackground',$w->{'activeBg'}) if ($Tk::strictMotif);
+ $w->configure('-state','normal') if ($w->cget('-state') eq 'active');
+}
+
+sub Enter
+{
+ my ($w,$x,$y) = @_;
+ if ($Tk::strictMotif)
+ {
+ $w->{'activeBg'} = $w->cget('-activebackground');
+ $w->configure('-activebackground',$w->cget('-background'));
+ }
+ $w->Activate($x,$y);
+}
+
+sub ButtonUp
+{
+ my ($w,$x,$y) = @_;
+ $w->CancelRepeat();
+ $w->EndDrag();
+ $w->Activate($x,$y)
+}
+
+
+# ButtonDown --
+# This procedure is invoked when a button is pressed in a scale. It
+# takes different actions depending on where the button was pressed.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates of button press.
+sub ButtonDown
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ $Tk::dragging = 0;
+ $el = $w->identify($x,$y);
+ return unless ($el);
+ if ($el eq 'trough1')
+ {
+ $w->Increment('up','little','initial')
+ }
+ elsif ($el eq 'trough2')
+ {
+ $w->Increment('down','little','initial')
+ }
+ elsif ($el eq 'slider')
+ {
+ $Tk::dragging = 1;
+ my @coords = $w->coords();
+ $Tk::deltaX = $x-$coords[0];
+ $Tk::deltaY = $y-$coords[1];
+ }
+}
+# Drag --
+# This procedure is called when the mouse is dragged with
+# mouse button 1 down. If the drag started inside the slider
+# (i.e. the scale is active) then the scale's value is adjusted
+# to reflect the mouse's position.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates.
+sub Drag
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ if (!$Tk::dragging)
+ {
+ return;
+ }
+ $w->set($w->get($x-$Tk::deltaX,$y-$Tk::deltaY))
+}
+# EndDrag --
+# This procedure is called to end an interactive drag of the
+# slider. It just marks the drag as over.
+# Arguments:
+# w - The scale widget.
+sub EndDrag
+{
+ my $w = shift;
+ if (!$Tk::dragging)
+ {
+ return;
+ }
+ $Tk::dragging = 0;
+}
+# Increment --
+# This procedure is invoked to increment the value of a scale and
+# to set up auto-repeating of the action if that is desired. The
+# way the value is incremented depends on the "dir" and "big"
+# arguments.
+#
+# Arguments:
+# w - The scale widget.
+# dir - "up" means move value towards -from, "down" means
+# move towards -to.
+# big - Size of increments: "big" or "little".
+# repeat - Whether and how to auto-repeat the action: "noRepeat"
+# means don't auto-repeat, "initial" means this is the
+# first action in an auto-repeat sequence, and "again"
+# means this is the second repetition or later.
+sub Increment
+{
+ my $w = shift;
+ my $dir = shift;
+ my $big = shift;
+ my $repeat = shift;
+ my $inc;
+ if ($big eq 'big')
+ {
+ $inc = $w->cget('-bigincrement');
+ if ($inc == 0)
+ {
+ $inc = abs(($w->cget('-to')-$w->cget('-from')))/10.0
+ }
+ if ($inc < $w->cget('-resolution'))
+ {
+ $inc = $w->cget('-resolution')
+ }
+ }
+ else
+ {
+ $inc = $w->cget('-resolution')
+ }
+ if (($w->cget('-from') > $w->cget('-to')) ^ ($dir eq 'up'))
+ {
+ $inc = -$inc
+ }
+ $w->set($w->get()+$inc);
+ if ($repeat eq 'again')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatinterval'),'Increment',$w,$dir,$big,'again'));
+ }
+ elsif ($repeat eq 'initial')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatdelay'),'Increment',$w,$dir,$big,'again'));
+ }
+}
+# ControlPress --
+# This procedure handles button presses that are made with the Control
+# key down. Depending on the mouse position, it adjusts the scale
+# value to one end of the range or the other.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates where the button was pressed.
+sub ControlPress
+{
+ my ($w,$x,$y) = @_;
+ my $el = $w->identify($x,$y);
+ return unless ($el);
+ if ($el eq 'trough1')
+ {
+ $w->set($w->cget('-from'))
+ }
+ elsif ($el eq 'trough2')
+ {
+ $w->set($w->cget('-to'))
+ }
+}
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Scale.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Scale.pod
new file mode 100755
index 00000000000..f7de2390bba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Scale.pod
@@ -0,0 +1,356 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Scale - Create and manipulate Scale widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$scale> = I<$parent>-E<gt>B<Scale>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground> B<-font> B<-highlightthickness> B<-repeatinterval>
+B<-background> B<-foreground> B<-orient> B<-takefocus>
+B<-borderwidth> B<-highlightbackground> B<-relief> B<-troughcolor>
+B<-cursor> B<-highlightcolor> B<-repeatdelay>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<bigIncrement>
+
+=item Class: B<BigIncrement>
+
+=item Switch: B<-bigincrement>
+
+Some interactions with the scale cause its value to change by
+``large'' increments; this option specifies the size of the
+large increments. If specified as 0, the large increments default
+to 1/10 the range of the scale.
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies the prefix of a L<perl/Tk callback|Tk::callbacks> to invoke whenever the scale's
+value is changed via a method.
+The actual command consists
+of this option followed by a space and a real number indicating the
+new value of the scale.
+
+=item Name: B<digits>
+
+=item Class: B<Digits>
+
+=item Switch: B<-digits>
+
+An integer specifying how many significant digits should be retained
+when converting the value of the scale to a string.
+If the number is less than or equal to zero, then the scale picks
+the smallest value that guarantees that every possible slider
+position prints as a different string.
+
+=item Name: B<from>
+
+=item Class: B<From>
+
+=item Switch: B<-from>
+
+A real value corresponding to the left or top end of the scale.
+
+=item Name: B<label>
+
+=item Class: B<Label>
+
+=item Switch: B<-label>
+
+A string to display as a label for the scale. For
+vertical scales the label is displayed just to the right of the
+top end of the scale. For horizontal scales the label is displayed
+just above the left end of the scale. If the option is specified
+as an empty string, no label is displayed.
+
+=item Name: B<length>
+
+=item Class: B<Length>
+
+=item Switch: B<-length>
+
+Specifies the desired long dimension of the scale in screen units
+(i.e. any of the forms acceptable to B<Tk_GetPixels>).
+For vertical scales this is the scale's height; for horizontal scales
+it is the scale's width.
+
+=item Name: B<resolution>
+
+=item Class: B<Resolution>
+
+=item Switch: B<-resolution>
+
+A real value specifying the resolution for the scale.
+If this value is greater than zero then the scale's value will always be
+rounded to an even multiple of this value, as will tick marks and
+the endpoints of the scale. If the value is less than zero then no
+rounding occurs. Defaults to 1 (i.e., the value will be integral).
+
+=item Name: B<showValue>
+
+=item Class: B<ShowValue>
+
+=item Switch: B<-showvalue>
+
+Specifies a boolean value indicating whether or not the current
+value of the scale is to be displayed.
+
+=item Name: B<sliderLength>
+
+=item Class: B<SliderLength>
+
+=item Switch: B<-sliderlength>
+
+Specfies the size of the slider, measured in screen units along the slider's
+long dimension. The value may be specified in any of the forms acceptable
+to B<Tk_GetPixels>.
+
+=item Name: B<sliderRelief>
+
+=item Class: B<SliderRelief>
+
+=item Switch: B<-sliderrelief>
+
+Specifies the relief to use when drawing the slider, such as B<raised>
+or B<sunken>.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of three states for the scale: B<normal>,
+B<active>, or B<disabled>.
+If the scale is disabled then the value may not be changed and the scale
+won't activate.
+If the scale is active, the slider is displayed using the color
+specified by the B<activeBackground> option.
+
+=item Name: B<tickInterval>
+
+=item Class: B<TickInterval>
+
+=item Switch: B<-tickinterval>
+
+Must be a real value.
+Determines the spacing between numerical
+tick marks displayed below or to the left of the slider.
+If 0, no tick marks will be displayed.
+
+=item Name: B<to>
+
+=item Class: B<To>
+
+=item Switch: B<-to>
+
+Specifies a real value corresponding
+to the right or bottom end of the scale.
+This value may be either less than or greater than the B<from> option.
+
+=item Name: B<variable>
+
+=item Class: B<Variable>
+
+=item Switch: B<-variable>
+
+Specifies the name of a global variable to link to the scale. Whenever the
+value of the variable changes, the scale will update to reflect this
+value.
+Whenever the scale is manipulated interactively, the variable
+will be modified to reflect the scale's new value.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired narrow dimension of the trough in screen units
+(i.e. any of the forms acceptable to B<Tk_GetPixels>).
+For vertical scales this is the trough's width; for horizontal scales
+this is the trough's height.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Scale> method creates a new window (given by the
+$widget argument) and makes it into a scale widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the scale such as its colors, orientation,
+and relief. The B<scale> command returns its
+$widget argument. At the time this command is invoked,
+there must not exist a window named $widget, but
+$widget's parent must exist.
+
+A scale is a widget that displays a rectangular I<trough> and a
+small I<slider>. The trough corresponds to a range
+of real values (determined by the B<from>, B<to>, and
+B<resolution> options),
+and the position of the slider selects a particular real value.
+The slider's position (and hence the scale's value) may be adjusted
+with the mouse or keyboard as described in
+the L<"BINDINGS"> section below. Whenever the scale's value is changed, a Tcl
+command is invoked (using the B<command> option) to notify
+other interested widgets of the change.
+In addition, the value
+of the scale can be linked to a Tcl variable (using the B<variable>
+option), so that changes in either are reflected in the other.
+
+Three annotations may be displayed in a scale widget: a label
+appearing at the top right of the widget (top left for horizontal
+scales), a number displayed just to the left of the slider
+(just above the slider for horizontal scales), and a collection
+of numerical tick marks just to the left of the current value
+(just below the trough for horizontal scales). Each of these three
+annotations may be enabled or disabled using the
+configuration options.
+
+=head1 WIDGET METHODS
+
+The B<Scale> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for scale widgets:
+
+=over 4
+
+=item I<$scale>-E<gt>B<coords>(?I<value>?)
+
+Returns a list whose elements are the x and y coordinates of
+the point along the centerline of the trough that corresponds
+to I<value>.
+If I<value> is omitted then the scale's current value is used.
+
+=item I<$scale>-E<gt>B<get>(?I<x, y>?)
+
+If I<x> and I<y> are omitted, returns the current value
+of the scale. If I<x> and I<y> are specified, they give
+pixel coordinates within the widget; the command returns
+the scale value corresponding to the given pixel.
+Only one of I<x> or I<y> is used: for horizontal scales
+I<y> is ignored, and for vertical scales I<x> is ignored.
+
+=item I<$scale>-E<gt>B<identify>(I<x, y>)
+
+Returns a string indicating what part of the scale lies under
+the coordinates given by I<x> and I<y>.
+A return value of B<slider> means that the point is over
+the slider; B<trough1> means that the point is over the
+portion of the slider above or to the left of the slider;
+and B<trough2> means that the point is over the portion
+of the slider below or to the right of the slider.
+If the point isn't over one of these elements, an empty string
+is returned.
+
+=item I<$scale>-E<gt>B<set>(I<value>)
+
+This command is invoked to change the current value of the scale,
+and hence the position at which the slider is displayed. I<Value>
+gives the new value for the scale.
+The command has no effect if the scale is disabled.
+
+=back
+
+=head1 BINDINGS
+
+Tk automatically creates class bindings for scales that give them
+the following default behavior.
+Where the behavior is different for vertical and horizontal scales,
+the horizontal behavior is described in parentheses.
+
+=over 4
+
+=item [1]
+
+If button 1 is pressed in the trough, the scale's value will
+be incremented or decremented by the value of the B<resolution>
+option so that the slider moves in the direction of the cursor.
+If the button is held down, the action auto-repeats.
+
+=item [2]
+
+If button 1 is pressed over the slider, the slider can be dragged
+with the mouse.
+
+=item [3]
+
+If button 1 is pressed in the trough with the Control key down,
+the slider moves all the way to the end of its range, in the
+direction towards the mouse cursor.
+
+=item [4]
+
+If button 2 is pressed, the scale's value is set to the mouse
+position. If the mouse is dragged with button 2 down, the scale's
+value changes with the drag.
+
+=item [5]
+
+The Up and Left keys move the slider up (left) by the value
+of the B<resolution> option.
+
+=item [6]
+
+The Down and Right keys move the slider down (right) by the value
+of the B<resolution> option.
+
+=item [7]
+
+Control-Up and Control-Left move the slider up (left) by the
+value of the B<bigIncrement> option.
+
+=item [8]
+
+Control-Down and Control-Right move the slider down (right) by the
+value of the B<bigIncrement> option.
+
+=item [9]
+
+Home moves the slider to the top (left) end of its range.
+
+=item [10]
+
+End moves the slider to the bottom (right) end of its range.
+
+If the scale is disabled using the B<state> option then
+none of the above bindings have any effect.
+
+The behavior of scales can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 KEYWORDS
+
+scale, slider, trough, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pm
new file mode 100755
index 00000000000..6b416e04b30
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pm
@@ -0,0 +1,429 @@
+# Conversion from Tk4.0 scrollbar.tcl competed.
+package Tk::Scrollbar;
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Scrollbar/Scrollbar.pm#10 $
+
+use Tk qw($XS_VERSION Ev);
+use AutoLoader;
+
+use base qw(Tk::Widget);
+
+#use strict;
+#use vars qw($pressX $pressY @initValues $initPos $activeBg);
+
+Construct Tk::Widget 'Scrollbar';
+
+bootstrap Tk::Scrollbar;
+
+sub Tk_cmd { \&Tk::scrollbar }
+
+Tk::Methods('activate','delta','fraction','get','identify','set');
+
+sub Needed
+{
+ my ($sb) = @_;
+ my @val = $sb->get;
+ return 1 unless (@val == 2);
+ return 1 if $val[0] != 0.0;
+ return 1 if $val[1] != 1.0;
+ return 0;
+}
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class, '<Enter>', 'Enter');
+ $mw->bind($class, '<Motion>', 'Motion');
+ $mw->bind($class, '<Leave>', 'Leave');
+
+ $mw->bind($class, '<1>', 'ButtonDown');
+ $mw->bind($class, '<B1-Motion>', ['Drag', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp');
+ $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave>
+ $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter>
+ $mw->bind($class, '<Control-1>', 'ScrlTopBottom');
+
+ $mw->bind($class, '<2>', 'ButtonDown');
+ $mw->bind($class, '<B2-Motion>', ['Drag', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp');
+ $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave>
+ $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter>
+ $mw->bind($class, '<Control-2>', 'ScrlTopBottom');
+
+ $mw->bind($class, '<Up>', ['ScrlByUnits','v',-1]);
+ $mw->bind($class, '<Down>', ['ScrlByUnits','v', 1]);
+ $mw->bind($class, '<Control-Up>', ['ScrlByPages','v',-1]);
+ $mw->bind($class, '<Control-Down>', ['ScrlByPages','v', 1]);
+
+ $mw->bind($class, '<Left>', ['ScrlByUnits','h',-1]);
+ $mw->bind($class, '<Right>', ['ScrlByUnits','h', 1]);
+ $mw->bind($class, '<Control-Left>', ['ScrlByPages','h',-1]);
+ $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]);
+
+ $mw->bind($class, '<Prior>', ['ScrlByPages','hv',-1]);
+ $mw->bind($class, '<Next>', ['ScrlByPages','hv', 1]);
+
+ # X11 mousewheel - honour for horizontal too.
+ $mw->bind($class, '<4>', ['ScrlByUnits','hv',-5]);
+ $mw->bind($class, '<5>', ['ScrlByUnits','hv', 5]);
+
+ $mw->bind($class, '<Home>', ['ScrlToPos', 0]);
+ $mw->bind($class, '<End>', ['ScrlToPos', 1]);
+
+ $mw->bind($class, '<4>', ['ScrlByUnits','v',-3]);
+ $mw->bind($class, '<5>', ['ScrlByUnits','v', 3]);
+
+ return $class;
+
+}
+
+1;
+
+__END__
+
+sub Enter
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ if ($Tk::strictMotif)
+ {
+ my $bg = $w->cget('-background');
+ $activeBg = $w->cget('-activebackground');
+ $w->configure('-activebackground' => $bg);
+ }
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+sub Leave
+{
+ my $w = shift;
+ if ($Tk::strictMotif)
+ {
+ $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ;
+ }
+ $w->activate('');
+}
+
+sub Motion
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+# tkScrollButtonDown --
+# This procedure is invoked when a button is pressed in a scrollbar.
+# It changes the way the scrollbar is displayed and takes actions
+# depending on where the mouse is.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates.
+
+sub ButtonDown
+{my $w = shift;
+ my $e = $w->XEvent;
+ my $element = $w->identify($e->x,$e->y);
+ $w->configure('-activerelief' => 'sunken');
+ if ($e->b == 1 and
+ (defined($element) && $element eq 'slider'))
+ {
+ $w->StartDrag($e->x,$e->y);
+ }
+ elsif ($e->b == 2 and
+ (defined($element) && $element =~ /^(trough[12]|slider)$/o))
+ {
+ my $pos = $w->fraction($e->x, $e->y);
+ my($head, $tail) = $w->get;
+ my $len = $tail - $head;
+
+ $head = $pos - $len/2;
+ $tail = $pos + $len/2;
+ if ($head < 0) {
+ $head = 0;
+ $tail = $len;
+ }
+ elsif ($tail > 1) {
+ $head = 1 - $len;
+ $tail = 1;
+ }
+ $w->ScrlToPos($head);
+ $w->set($head, $tail);
+
+ $w->StartDrag($e->x,$e->y);
+ }
+ else
+ {
+ $w->Select($element,'initial');
+ }
+}
+
+# tkScrollButtonUp --
+# This procedure is invoked when a button is released in a scrollbar.
+# It cancels scans and auto-repeats that were in progress, and restores
+# the way the active element is displayed.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates.
+
+sub ButtonUp
+{my $w = shift;
+ my $e = $w->XEvent;
+ $w->CancelRepeat;
+ $w->configure('-activerelief' => 'raised');
+ $w->EndDrag($e->x,$e->y);
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+# tkScrollSelect --
+# This procedure is invoked when button 1 is pressed over the scrollbar.
+# It invokes one of several scrolling actions depending on where in
+# the scrollbar the button was pressed.
+#
+# Arguments:
+# w - The scrollbar widget.
+# element - The element of the scrollbar that was selected, such
+# as "arrow1" or "trough2". Shouldn't be "slider".
+# repeat - Whether and how to auto-repeat the action: "noRepeat"
+# means don't auto-repeat, "initial" means this is the
+# first action in an auto-repeat sequence, and "again"
+# means this is the second repetition or later.
+
+sub Select
+{
+ my $w = shift;
+ my $element = shift;
+ my $repeat = shift;
+ return unless defined ($element);
+ if ($element eq 'arrow1')
+ {
+ $w->ScrlByUnits('hv',-1);
+ }
+ elsif ($element eq 'trough1')
+ {
+ $w->ScrlByPages('hv',-1);
+ }
+ elsif ($element eq 'trough2')
+ {
+ $w->ScrlByPages('hv', 1);
+ }
+ elsif ($element eq 'arrow2')
+ {
+ $w->ScrlByUnits('hv', 1);
+ }
+ else
+ {
+ return;
+ }
+
+ if ($repeat eq 'again')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again']));
+ }
+ elsif ($repeat eq 'initial')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again']));
+ }
+}
+
+# tkScrollStartDrag --
+# This procedure is called to initiate a drag of the slider. It just
+# remembers the starting position of the slider.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The mouse position at the start of the drag operation.
+
+sub StartDrag
+{
+ my($w,$x,$y) = @_;
+ return unless (defined ($w->cget('-command')));
+ $pressX = $x;
+ $pressY = $y;
+ @initValues = $w->get;
+ my $iv0 = $initValues[0];
+ if (@initValues == 2)
+ {
+ $initPos = $iv0;
+ }
+ elsif ($iv0 == 0)
+ {
+ $initPos = 0;
+ }
+ else
+ {
+ $initPos = $initValues[2]/$initValues[0];
+ }
+}
+
+# tkScrollDrag --
+# This procedure is called for each mouse motion even when the slider
+# is being dragged. It notifies the associated widget if we're not
+# jump scrolling, and it just updates the scrollbar if we are jump
+# scrolling.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The current mouse position.
+
+sub Drag
+{
+ my($w,$x,$y) = @_;
+ return if !defined $initPos;
+ my $delta = $w->delta($x-$pressX, $y-$pressY);
+ if ($w->cget('-jump'))
+ {
+ if (@initValues == 2)
+ {
+ $w->set($initValues[0]+$delta, $initValues[1]+$delta);
+ }
+ else
+ {
+ $delta = sprintf "%d", $delta * $initValues[0]; # round()
+ $initValues[2] += $delta;
+ $initValues[3] += $delta;
+ $w->set(@initValues[2,3]);
+ }
+ }
+ else
+ {
+ $w->ScrlToPos($initPos+$delta);
+ }
+}
+
+# tkScrollEndDrag --
+# This procedure is called to end an interactive drag of the slider.
+# It scrolls the window if we're in jump mode, otherwise it does nothing.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The mouse position at the end of the drag operation.
+
+sub EndDrag
+{
+ my($w,$x,$y) = @_;
+ return if (!defined $initPos);
+ if ($w->cget('-jump'))
+ {
+ my $delta = $w->delta($x-$pressX, $y-$pressY);
+ $w->ScrlToPos($initPos+$delta);
+ }
+ undef $initPos;
+}
+
+# tkScrlByUnits --
+# This procedure tells the scrollbar's associated widget to scroll up
+# or down by a given number of units. It notifies the associated widget
+# in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# orient - Which kinds of scrollbars this applies to: "h" for
+# horizontal, "v" for vertical, "hv" for both.
+# amount - How many units to scroll: typically 1 or -1.
+
+sub ScrlByUnits
+{my $w = shift;
+ my $orient = shift;
+ my $amount = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('scroll',$amount,'units');
+ }
+ else
+ {
+ $cmd->Call($info[2]+$amount);
+ }
+}
+
+# tkScrlByPages --
+# This procedure tells the scrollbar's associated widget to scroll up
+# or down by a given number of screenfuls. It notifies the associated
+# widget in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# orient - Which kinds of scrollbars this applies to: "h" for
+# horizontal, "v" for vertical, "hv" for both.
+# amount - How many screens to scroll: typically 1 or -1.
+
+sub ScrlByPages
+{
+ my $w = shift;
+ my $orient = shift;
+ my $amount = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('scroll',$amount,'pages');
+ }
+ else
+ {
+ $cmd->Call($info[2]+$amount*($info[1]-1));
+ }
+}
+
+# tkScrlToPos --
+# This procedure tells the scrollbar's associated widget to scroll to
+# a particular location, given by a fraction between 0 and 1. It notifies
+# the associated widget in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# pos - A fraction between 0 and 1 indicating a desired position
+# in the document.
+
+sub ScrlToPos
+{
+ my $w = shift;
+ my $pos = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('moveto',$pos);
+ }
+ else
+ {
+ $cmd->Call(int($info[0]*$pos));
+ }
+}
+
+# tkScrlTopBottom
+# Scroll to the top or bottom of the document, depending on the mouse
+# position.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates within the widget.
+
+sub ScrlTopBottom
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ my $element = $w->identify($e->x,$e->y);
+ return unless ($element);
+ if ($element =~ /1$/)
+ {
+ $w->ScrlToPos(0);
+ }
+ elsif ($element =~ /2$/)
+ {
+ $w->ScrlToPos(1);
+ }
+}
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pod
new file mode 100755
index 00000000000..838eb97e666
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Scrollbar.pod
@@ -0,0 +1,429 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Scrollbar - Create and manipulate Scrollbar widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+I<$scrollbar> = I<$parent>-E<gt>B<Scrollbar>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-activebackground> B<-highlightbackground> B<-orient> B<-takefocus>
+B<-background> B<-highlightcolor> B<-relief> B<-troughcolor>
+B<-borderwidth> B<-highlightthickness> B<-repeatdelay>
+B<-cursor> B<-jump> B<-repeatinterval>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<activeRelief>
+
+=item Class: B<ActiveRelief>
+
+=item Switch: B<-activerelief>
+
+Specifies the relief to use when displaying the element that is
+active, if any.
+Elements other than the active element are always displayed with
+a raised relief.
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies a callback to invoke to change the view
+in the widget associated with the scrollbar. When a user requests
+a view change by manipulating the scrollbar, the callback is
+invoked. The callback is passed
+additional arguments as described later. This option almost always has
+a value such as B<[xview =E<gt> $widget]> or B<[yview =E<gt> $widget]>, consisting of the
+a widget object and either B<xview> (if the scrollbar is for
+horizontal scrolling) or B<yview> (for vertical scrolling).
+All scrollable widgets have B<xview> and B<yview> methods
+that take exactly the additional arguments appended by the scrollbar
+as described in L<"SCROLLING COMMANDS"> below.
+
+=item Name: B<elementBorderWidth>
+
+=item Class: B<BorderWidth>
+
+=item Switch: B<-elementborderwidth>
+
+Specifies the width of borders drawn around the internal elements
+of the scrollbar (the two arrows and the slider). The value may
+have any of the forms acceptable to B<Tk_GetPixels>.
+If this value is less than zero, the value of the B<borderWidth>
+option is used in its place.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired narrow dimension of the scrollbar window,
+not including 3-D border, if any. For vertical
+scrollbars this will be the width and for horizontal scrollbars
+this will be the height.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Scrollbar> method creates a new window (given by the
+$widget argument) and makes it into a scrollbar widget.
+Additional options, described above, may be specified on the command
+line or in the option database to configure aspects of the scrollbar
+such as its colors, orientation, and relief.
+The B<scrollbar> command returns its $widget argument.
+At the time this command is invoked, there must not exist a window
+named $widget, but $widget's parent must exist.
+
+A scrollbar is a widget that displays two arrows, one at each end of
+the scrollbar, and a I<slider> in the middle portion of the
+scrollbar.
+It provides information about what is visible in an I<associated window>
+that displays an document of some sort (such as a file being edited or
+a drawing).
+The position and size of the slider indicate which portion of the
+document is visible in the associated window. For example, if the
+slider in a vertical scrollbar covers the top third of the area
+between the two arrows, it means that the associated window displays
+the top third of its document.
+
+Scrollbars can be used to adjust the view in the associated window
+by clicking or dragging with the mouse.
+See L<"BINDINGS"> below for details.
+
+=head1 ELEMENTS
+
+A scrollbar displays five elements, which are referred to in the
+methods for the scrollbar:
+
+=over 4
+
+=item B<arrow1>
+
+The top or left arrow in the scrollbar.
+
+=item B<trough1>
+
+The region between the slider and B<arrow1>.
+
+=item B<slider>
+
+The rectangle that indicates what is visible in the associated widget.
+
+=item B<trough2>
+
+The region between the slider and B<arrow2>.
+
+=item B<arrow2>
+
+The bottom or right arrow in the scrollbar.
+
+=back
+
+=head1 WIDGET METHODS
+
+The B<Scrollbar> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for scrollbar widgets:
+
+=over 4
+
+=item I<$scrollbar>-E<gt>B<activate>(?I<element>?)
+
+Marks the element indicated by I<element> as active, which
+causes it to be displayed as specified by the B<activeBackground>
+and B<activeRelief> options.
+The only element values understood by this command are B<arrow1>,
+B<slider>, or B<arrow2>.
+If any other value is specified then no element of the scrollbar
+will be active.
+If I<element> is not specified, the command returns
+the name of the element that is currently active, or an empty string
+if no element is active.
+
+=item I<$scrollbar>-E<gt>B<delta>(I<deltaX, deltaY>)
+
+Returns a real number indicating the fractional change in
+the scrollbar setting that corresponds to a given change
+in slider position. For example, if the scrollbar is horizontal,
+the result indicates how much the scrollbar setting must change
+to move the slider I<deltaX> pixels to the right (I<deltaY> is
+ignored in this case).
+If the scrollbar is vertical, the result indicates how much the
+scrollbar setting must change to move the slider I<deltaY> pixels
+down. The arguments and the result may be zero or negative.
+
+=item I<$scrollbar>-E<gt>B<fraction>(I<x, y>)
+
+Returns a real number between 0 and 1 indicating where the point
+given by I<x> and I<y> lies in the trough area of the scrollbar.
+The value 0 corresponds to the top or left of the trough, the
+value 1 corresponds to the bottom or right, 0.5 corresponds to
+the middle, and so on.
+I<X> and I<y> must be pixel coordinates relative to the scrollbar
+widget.
+If I<x> and I<y> refer to a point outside the trough, the closest
+point in the trough is used.
+
+=item I<$scrollbar>-E<gt>B<get>
+
+Returns the scrollbar settings in the form of a list whose
+elements are the arguments to the most recent B<set> method.
+
+=item I<$scrollbar>-E<gt>B<identify>(I<x, y>)
+
+Returns the name of the element under the point given by I<x> and
+I<y> (such as B<arrow1>), or an empty string if the point does
+not lie in any element of the scrollbar.
+I<X> and I<y> must be pixel coordinates relative to the scrollbar
+widget.
+
+=item I<$scrollbar>-E<gt>B<set>(I<first, last>)
+
+This command is invoked by the scrollbar's associated widget to
+tell the scrollbar about the current view in the widget.
+The command takes two arguments, each of which is a real fraction
+between 0 and 1.
+The fractions describe the range of the document that is visible in
+the associated widget.
+For example, if I<first> is 0.2 and I<last> is 0.4, it means
+that the first part of the document visible in the window is 20%
+of the way through the document, and the last visible part is 40%
+of the way through.
+
+=back
+
+=head1 SCROLLING COMMANDS
+
+When the user interacts with the scrollbar, for example by dragging
+the slider, the scrollbar notifies the associated widget that it
+must change its view.
+The scrollbar makes the notification by evaluating a callback
+specified as the scrollbar's B<-command> option.
+The callback may take several forms.
+In each case, the intial arguments passed are those
+specified in the B<-command> callback itself,
+which usually has a form like [B<yview> =E<gt> I<$widget>].
+(Which will invoke I<$widget>-E<gt>B<yview>(...) where
+the ... part is as below. See L<Tk::callbacks> for details.)
+The callback is passed additional arguments as follows:
+
+=over 4
+
+=item B<moveto>,I<fraction>
+
+I<Fraction> is a real number between 0 and 1.
+The widget should adjust its view so that the point given
+by I<fraction> appears at the beginning of the widget.
+If I<fraction> is 0 it refers to the beginning of the
+document. 1.0 refers to the end of the document, 0.333
+refers to a point one-third of the way through the document,
+and so on.
+
+=item B<scroll,>I<number,>B<units>
+
+The widget should adjust its view by I<number> units.
+The units are defined in whatever way makes sense for the widget,
+such as characters or lines in a text widget.
+I<Number> is either 1, which means one unit should scroll off
+the top or left of the window, or -1, which means that one unit
+should scroll off the bottom or right of the window.
+
+=item B<scroll>,I<number>,B<page>
+
+The widget should adjust its view by I<number> pages.
+It is up to the widget to define the meaning of a page; typically
+it is slightly less than what fits in the window, so that there
+is a slight overlap between the old and new views.
+I<Number> is either 1, which means the next page should
+become visible, or -1, which means that the previous page should
+become visible.
+
+=back
+
+=head1 OLD COMMAND SYNTAX
+
+In versions of Tk before 4.0, the B<set> and B<get> widget
+commands used a different form.
+This form is still supported for backward compatibility, but it
+is deprecated.
+In the old command syntax, the B<set> method has the
+following form:
+
+=over 4
+
+=item I<$scrollbar>-E<gt>B<set>(I<totalUnits, windowUnits, firstUnit, lastUnit>)
+
+In this form the arguments are all integers.
+I<TotalUnits> gives the total size of the object being displayed in the
+associated widget. The meaning of one unit depends on the associated
+widget; for example, in a text editor widget units might
+correspond to lines of
+text. I<WindowUnits> indicates the total number of units that
+can fit in the associated window at one time. I<FirstUnit>
+and I<lastUnit> give the indices of the first and last units
+currently visible in the associated window (zero corresponds to the
+first unit of the object).
+
+=back
+
+Under the old syntax the B<get> method returns a list
+of four integers, consisting of the I<totalUnits>, I<windowUnits>,
+I<firstUnit>, and I<lastUnit> values from the last B<set>
+method.
+
+The callbacks generated by scrollbars also have a different form
+when the old syntax is being used, the callback is passed a single argument:
+
+=over 4
+
+=item I<unit>
+
+I<Unit> is an integer that indicates what should appear at
+the top or left of the associated widget's window.
+It has the same meaning as the I<firstUnit> and I<lastUnit>
+arguments to the B<set> method.
+
+=back
+
+The most recent B<set> method determines whether or not
+to use the old syntax.
+If it is given two real arguments then the new syntax will be
+used in the future, and if it is given four integer arguments then
+the old syntax will be used.
+
+=head1 BINDINGS
+
+Tk automatically creates class bindings for scrollbars that give them
+the following default behavior.
+If the behavior is different for vertical and horizontal scrollbars,
+the horizontal behavior is described in parentheses.
+
+=over 4
+
+=item [1]
+
+Pressing button 1 over B<arrow1> causes the view in the
+associated widget to shift up (left) by one unit so that the
+document appears to move down (right) one unit.
+If the button is held down, the action auto-repeats.
+
+=item [2]
+
+Pressing button 1 over B<trough1> causes the view in the
+associated widget to shift up (left) by one screenful so that the
+document appears to move down (right) one screenful.
+If the button is held down, the action auto-repeats.
+
+=item [3]
+
+Pressing button 1 over the slider and dragging causes the view
+to drag with the slider.
+If the B<jump> option is true, then the view doesn't drag along
+with the slider; it changes only when the mouse button is released.
+
+=item [4]
+
+Pressing button 1 over B<trough2> causes the view in the
+associated widget to shift down (right) by one screenful so that the
+document appears to move up (left) one screenful.
+If the button is held down, the action auto-repeats.
+
+=item [5]
+
+Pressing button 1 over B<arrow2> causes the view in the
+associated widget to shift down (right) by one unit so that the
+document appears to move up (left) one unit.
+If the button is held down, the action auto-repeats.
+
+=item [6]
+
+If button 2 is pressed over the trough or the slider, it sets
+the view to correspond to the mouse position; dragging the
+mouse with button 2 down causes the view to drag with the mouse.
+If button 2 is pressed over one of the arrows, it causes the
+same behavior as pressing button 1.
+
+=item [7]
+
+If button 1 is pressed with the Control key down, then if the
+mouse is over B<arrow1> or B<trough1> the view changes
+to the very top (left) of the document; if the mouse is over
+B<arrow2> or B<trough2> the view changes
+to the very bottom (right) of the document; if the mouse is
+anywhere else then the button press has no effect.
+
+=item [8]
+
+In vertical scrollbars the Up and Down keys have the same behavior
+as mouse clicks over B<arrow1> and B<arrow2>, respectively.
+In horizontal scrollbars these keys have no effect.
+
+=item [9]
+
+In vertical scrollbars Control-Up and Control-Down have the same
+behavior as mouse clicks over B<trough1> and B<trough2>, respectively.
+In horizontal scrollbars these keys have no effect.
+
+=item [10]
+
+In horizontal scrollbars the Up and Down keys have the same behavior
+as mouse clicks over B<arrow1> and B<arrow2>, respectively.
+In vertical scrollbars these keys have no effect.
+
+=item [11]
+
+In horizontal scrollbars Control-Up and Control-Down have the same
+behavior as mouse clicks over B<trough1> and B<trough2>, respectively.
+In vertical scrollbars these keys have no effect.
+
+=item [12]
+
+The Prior and Next keys have the same behavior
+as mouse clicks over B<trough1> and B<trough2>, respectively.
+
+=item [13]
+
+The Home key adjusts the view to the top (left edge) of the document.
+
+=item [14]
+
+The End key adjusts the view to the bottom (right edge) of the document.
+
+=back
+
+=head1 SEE ALSO
+
+L<Tk::callbacks|Tk::callbacks>
+L<Tk::Scrolled|Tk::Scrolled>
+
+=head1 KEYWORDS
+
+scrollbar, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Scrolled.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Scrolled.pod
new file mode 100755
index 00000000000..cd6c648ef5e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Scrolled.pod
@@ -0,0 +1,86 @@
+=head1 NAME
+
+Tk::Scrolled - Create a widget with attached scrollbar(s)
+
+=for category Derived Widgets
+
+=for index_group Perl/Tk Constructs
+
+=head1 SYNOPSIS
+
+S< >I<$whatever> = I<$parent>-E<gt>B<Scrolled>(I<Whatever> ?,B<-scrollbars>=E<gt>I<where>? ?,...?);
+
+=head1 DESCRIPTION
+
+To stop a flood of B<ScrlWhatever> widgets Perl/Tk introcuded the special
+constructor B<Scrolled>. B<Scrolled> creates a widget of the given Class
+I<Whatever> with attached L<scrollbar(s)|Tk::Scrollbar>.
+
+=head1 OPTIONS
+
+All options beside B<-scrollbars> explained below are passed to
+the I<Whatever> widget constructor.
+
+=over 4
+
+=item -scrollbars
+
+Expects as argument the position where the scrollbars should be
+created: B<w>, B<e> or B<n>, B<s> or a combination of
+them. If the one or both positions are prefixed with B<o> the
+scrollbar will only show up if there is a 'real' need to scroll.
+
+=back
+
+=head1 ADVERTISED SUBWIDGETS
+
+See L<Tk::mega/"Subwidget"> how to use advertised widgets.
+
+=over 4
+
+=item scrolled
+
+the scrolled widget
+
+=item I<widget>
+
+same as B<scrolled> above. I<widget> is the kind of widget passed
+to scrolled as first argument in all lowercase.
+
+=item xscrollbar
+
+the B<Scrollbar> widget used for horizontal scrolling (if it exists)
+
+=item yscrollbar
+
+the B<Scrollbar> widget used for vertical scrolling (if it exists)
+
+=item corner
+
+a frame in the corner between the vertical and horizontal scrolbar
+
+=back
+
+=head1 BUGS
+
+If a widget does not support I<-{x,y}scrollcommand> options,
+B<Scrolled> does not complain if the specified widget class does
+not support them. E.g.,
+
+S< >I<$parent>->B<Scrolled>(B<'Button'>, ...)
+
+One does not get an error message or warning when one tries to
+configure scrollbars after the widget construction:
+
+S< >I<$ascrolled>->B<configure>(B<-scrollbars> => B<'e'>);
+
+=head1 SEE ALSO
+
+L<Tk::Scrollbar|Tk::Scrollbar>
+
+=head1 KEYWORDS
+
+scrolled, scrollbar
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Spinbox.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Spinbox.pm
new file mode 100755
index 00000000000..673a1e181ce
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Spinbox.pm
@@ -0,0 +1,115 @@
+package Tk::Spinbox;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d',q$Revision: #6 $ =~ /#(\d+)/;
+
+use base 'Tk::Entry';
+
+sub Tk_cmd { \&Tk::spinbox }
+
+# Also inherits Entry's methods
+Tk::Methods( "identify", "invoke", "set" );
+use Tk::Submethods ( 'selection' => ["element"] );
+
+Construct Tk::Widget 'Spinbox';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class, '<Up>', [invoke => 'buttonup']);
+ $mw->bind($class, '<4>', [invoke => 'buttonup']);
+ $mw->bind($class, '<Down>',[invoke => 'buttondown']);
+ $mw->bind($class, '<5>', [invoke => 'buttondown']);
+
+ return $class;
+}
+
+sub Invoke
+{
+ my ($w,$elem) = @_;
+ unless ($w->{_outside})
+ {
+ $w->invoke($elem);
+ $w->{_repeated}++;
+ }
+ my $delay = $w->cget('-repeatinterval');
+ if ($delay > 0)
+ {
+ $w->RepeatId($w->after($delay,[Invoke => $w,$elem]));
+ }
+}
+
+sub Button1
+{
+ my ($w,$x,$y) = @_;
+ my $elem = $w->identify($x,$y);
+ $w->{_element} = $elem || 'entry';
+ if ($w->{_element} eq 'entry')
+ {
+ $w->SUPER::Button1($x,$y);
+ }
+ elsif ($w->cget('-state') ne 'disabled')
+ {
+ $w->selectionElement($elem);
+ $w->{_repeated} = 0;
+ $w->{_outside} = 0;
+ $w->{_relief} = $w->cget("-${elem}relief");
+ $w->CancelRepeat;
+ my $delay = $w->cget('-repeatdelay');
+ $w->RepeatId($w->after($delay,[Invoke => $w,$elem])) if $delay > 0;
+ }
+}
+
+sub Motion
+{
+ my ($w,$x,$y) = @_;
+ my $elem = $w->identify($x,$y);
+ $w->{_element} = $elem || 'entry' unless $w->{_element};
+ if ($w->{_element} eq 'entry')
+ {
+ $w->SUPER::Motion($x,$y);
+ }
+ else
+ {
+ if (!defined($elem) || $elem ne $w->{_element})
+ {
+ # Moved outside the button
+ unless ($w->{_outside})
+ {
+ $w->{_outside} = 1;
+ $w->selectionElement('none');
+ }
+ }
+ elsif ($w->{_outside})
+ {
+ # Moved back over the button
+ $w->selectionElement($elem);
+ $w->{_outside} = 0;
+ }
+ }
+}
+
+sub Button1Release
+{
+ my ($w,$x,$y) = @_;
+ $w->SUPER::Button1Release($x,$y);
+ my $elem = $w->{_element};
+ if (defined($elem) && $elem ne 'entry')
+ {
+ my $repeated = $w->{_repeated};
+ if (defined($repeated) && !$repeated)
+ {
+ $w->invoke($elem);
+ }
+ my $relief = delete $w->{_relief};
+ $w->configure("-${elem}relief",$relief) if $relief
+ }
+ $w->selectionElement('none');
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Spinbox.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Spinbox.pod
new file mode 100755
index 00000000000..b18b7e1b9ae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Spinbox.pod
@@ -0,0 +1,819 @@
+# Copyright (c) 2000 Jeffrey Hobbs.
+# Copyright (c) 2000 Ajuba Solutions.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# RCS: @(#) $Id: spinbox.n,v 1.3 2001/12/18 23:02:35 hobbs Exp $
+
+=head1 NAME
+
+Tk::Spinbox - Create and manipulate Spinbox widgets
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+I<$spinbox> = I<$parent>-E<gt>Spinbox(?I<options>?);
+
+ -activebackground -highlightthickness -repeatinterval
+ -background -insertbackground -selectbackground
+ -borderwidth -insertborderwidth -selectborderwidth
+ -cursor -insertontime -selectforeground
+ -exportselection -insertwidth -takefocus
+ -font -insertofftime -textvariable
+ -foreground -justify -xscrollcommand
+ -highlightbackground -relief
+ -highlightcolor -repeatdelay
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Option: B<-buttonbackground>
+
+=item Name: B<buttonBackground>
+
+=item Class: B<Background>
+
+The background color to be used for the spin buttons.
+
+=item Option: B<-buttoncursor>
+
+=item Name: B<buttonCursor>
+
+=item Class: B<Cursor>
+
+The cursor to be used when over the spin buttons. If this is empty
+(the default), a default cursor will be used.
+
+=item Option: B<-buttondownrelief>
+
+=item Name: B<buttonDownRelief>
+
+=item Class: B<Relief>
+
+The relief to be used for the upper spin button.
+
+=item Option: B<-buttonuprelief>
+
+=item Name: B<buttonUpRelief>
+
+=item Class: B<Relief>
+
+The relief to be used for the lower spin button.
+
+=item Option: B<-command>
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+Specifies a Perl/Tk callback to invoke whenever a Spinbutton is invoked.
+The callback has these two arguments I<appended> to any existing callback
+arguments: the current value of the widget and the direction of the button
+press (B<up> or B<down>).
+
+=item Option: B<-disabledbackground>
+
+=item Name: B<disabledBackground>
+
+=item Class: B<DisabledBackground>
+
+Specifies the background color to use when the Spinbox is disabled. If
+this option is the empty string, the normal background color is used.
+
+=item Option: B<-disabledforeground>
+
+=item Name: B<disabledForeground>
+
+=item Class: B<DisabledForeground>
+
+Specifies the foreground color to use when the Spinbox is disabled. If
+this option is the empty string, the normal foreground color is used.
+
+=item Option: B<-format>
+
+=item Name: B<format>
+
+=item Class: B<Format>
+
+Specifies an alternate format to use when setting the string value
+when using the B<-from> and B<-to> range.
+This must be a format specifier of the form B<%E<lt>padE<gt>.E<lt>padE<gt>f>,
+as it will format a floating-point number.
+
+=item Option: B<-from>
+
+=item Name: B<from>
+
+=item Class: B<From>
+
+A floating-point value corresponding to the lowest value for a Spinbox, to
+be used in conjunction with B<-to> and B<-increment>. When all
+are specified correctly, the Spinbox will use these values to control its
+contents. This value must be less than the B<-to> option.
+If B<-values> is specified, it supercedes this option.
+
+=item Option: B<-invalidcommand>
+
+=item Alias: B<-invcmd>
+
+=item Name: B<invalidCommand>
+
+=item Class: B<InvalidCommand>
+
+Specifies a script to eval when B<validateCommand> returns 0. Setting
+it to an empty string disables this feature (the default). The best use of
+this option is to set it to I<bell>. See B<Validation> below for
+more information.
+
+=item Option: B<-increment>
+
+=item Name: B<increment>
+
+=item Class: B<Increment>
+
+A floating-point value specifying the increment. When used with
+B<-from> and B<-to>, the value in the widget will be adjusted by
+B<-increment> when a spin button is pressed (up adds the value,
+down subtracts the value).
+
+=item Option: B<-readonlybackground>
+
+=item Name: B<readonlyBackground>
+
+=item Class: B<ReadonlyBackground>
+
+Specifies the background color to use when the Spinbox is readonly. If
+this option is the empty string, the normal background color is used.
+
+=item Option: B<-state>
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+Specifies one of three states for the Spinbox: B<normal>,
+B<disabled>, or B<readonly>. If the Spinbox is readonly, then the
+value may not be changed using methods and no insertion cursor
+will be displayed, even if the input focus is in the widget; the
+contents of the widget may still be selected. If the Spinbox is
+disabled, the value may not be changed, no insertion cursor will be
+displayed, the contents will not be selectable, and the Spinbox may
+be displayed in a different color, depending on the values of the
+B<-disabledforeground> and B<-disabledbackground> options.
+
+=item Option: B<-to>
+
+=item Name: B<to>
+
+=item Class: B<To>
+
+A floating-point value corresponding to the highest value for the Spinbox,
+to be used in conjunction with B<-from> and B<-increment>. When
+all are specified correctly, the Spinbox will use these values to control
+its contents. This value must be greater than the B<-from> option.
+If B<-values> is specified, it supercedes this option.
+
+=item Option: B<-validate>
+
+=item Name: B<validate>
+
+=item Class: B<Validate>
+
+Specifies the mode in which validation should operate: B<none>,
+B<focus>, B<focusin>, B<focusout>, B<key>, or B<all>.
+It defaults to B<none>. When you want validation, you must explicitly
+state which mode you wish to use. See B<Validation> below for more.
+
+=item Option: B<-validatecommand>
+
+=item Alias: B<-vcmd>
+
+=item Name: B<validateCommand>
+
+=item Class: B<ValidateCommand>
+
+Specifies a script to evaluate when you want to validate the input in the
+widget. Setting it to an empty string disables this feature (the default).
+Validation occurs according to the value of B<-validate>.
+This command must return a valid boolean value. If it returns 0 (or
+the valid boolean equivalent) then the value of the widget will not
+change and the B<invalidCommand> will be evaluated if it is set. If it
+returns 1, then value will be changed.
+See B<Validation> below for more information.
+
+=item Option: B<-values>
+
+=item Name: B<values>
+
+=item Class: B<Values>
+
+Must be a proper list value. If specified, the Spinbox will use these
+values as to control its contents, starting with the first value. This
+option has precedence over the B<-from> and B<-to> range.
+
+=item Option: B<-width>
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+Specifies an integer value indicating the desired width of the Spinbox window,
+in average-size characters of the widget's font.
+If the value is less than or equal to zero, the widget picks a
+size just large enough to hold its current text.
+
+=item Option: B<-wrap>
+
+=item Name: B<wrap>
+
+=item Class: B<Wrap>
+
+Must be a proper boolean value. If on, the Spinbox will wrap around the
+values of data in the widget.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Spinbox> method creates a new window (given by the
+$spinbox argument) and makes it into a Spinbox widget.
+Additional options, described above, may be specified on the
+command line or in the option database
+to configure aspects of the Spinbox such as its colors, font,
+and relief.
+
+A B<Spinbox> is an extended B<Entry> widget that allows he user
+to move, or spin, through a fixed set of ascending or descending values
+such as times or dates in addition to editing the value as in an
+B<entry>. When first created, a Spinbox's string is empty.
+A portion of the Spinbox may be selected as described below.
+If a Spinbox is exporting its selection (see the B<exportSelection>
+option), then it will observe the standard protocols for handling the
+selection; Spinbox selections are available as type B<STRING>.
+Spinboxes also observe the standard Tk rules for dealing with the
+input focus. When a Spinbox has the input focus it displays an
+I<insertion cursor> to indicate where new characters will be
+inserted.
+
+Spinboxes are capable of displaying strings that are too long to
+fit entirely within the widget's window. In this case, only a
+portion of the string will be displayed; commands described below
+may be used to change the view in the window. Spinboxes use
+the standard B<-xscrollcommand> mechanism for interacting with
+scrollbars (see the description of the B<-xscrollcommand> option
+for details). They also support scanning, as described below.
+
+=head1 VALIDATION
+
+Validation works by setting the B<validateCommand>
+option to a callback which will be evaluated according to the B<validate>
+option as follows:
+
+=over 4
+
+=item B<none>
+
+Default. This means no validation will occur.
+
+=item B<focus>
+
+B<validateCommand> will be called when the Spinbox receives or
+loses focus.
+
+=item B<focusin>
+
+B<validateCommand> will be called when the Spinbox receives focus.
+
+=item B<focusout>
+
+B<validateCommand> will be called when the Spinbox loses focus.
+
+=item B<key>
+
+B<validateCommand> will be called when the Spinbox is edited.
+
+=item B<all>
+
+B<validateCommand> will be called for all above conditions.
+
+
+The B<validateCommand> and B<invalidCommand> callbacks are invoked
+with at least 5 positional arguments, which are I<appended> to any already
+existing callback arguments:
+
+=over 4
+
+=item * 1
+
+The proposed value of the entry. If you are configuring the
+entry widget to have a new textVariable, this will be the value of that
+textVariable.
+
+=item * 2
+
+The characters to be added (or deleted). This will be C<undef>
+if validation is due to focus, explcit call to validate or if change
+is due to C<-textvariable> changing.
+
+=item * 3
+
+The current value of entry i.e. before the proposed change.
+
+=item * 4
+
+The index of character string to be added/deleted, if any. Otherwise -1.
+
+=item * 5
+
+Type of action. 1 == INSERT, 0 == DELETE,
+-1 if it's a forced validation or textVariable validation.
+
+=back
+
+In general, the B<textVariable> and B<validateCommand> can be
+dangerous to mix. Any problems have been overcome so that using the
+B<validateCommand> will not interfere with the traditional behavior of
+the Spinbox widget. Using the B<textVariable> for read-only purposes will
+never cause problems. The danger comes when you try set the
+B<textVariable> to something that the B<validateCommand> would not
+accept, which causes B<validate> to become I<none> (the
+B<invalidCommand> will not be triggered). The same happens
+when an error occurs evaluating the B<validateCommand>.
+
+Primarily, an error will occur when the B<validateCommand> or
+B<invalidCommand> encounters an error in its script while evaluating or
+B<validateCommand> does not return a valid boolean value. The
+B<validate> option will also set itself to B<none> when you edit the
+Spinbox widget from within either the B<validateCommand> or the
+B<invalidCommand>. Such editions will override the one that was being
+validated. If you wish to edit the value of the widget
+during validation and still have the B<validate> option set, you should
+include the command
+
+ my $val = $spinbox->cget(-validate);
+ $spinbox->configure(-validate => $val);
+
+in the B<validateCommand> or B<invalidCommand> (whichever one you
+were editing the Spinbox widget from). It is also recommended to not set an
+associated B<textVariable> during validation, as that can cause the
+Spinbox widget to become out of sync with the B<textVariable>.
+
+=back
+
+=head1 WIDGET METHODS
+
+The B<Spinbox> command creates a widget object whose
+name is $widget. This command may be used to invoke various
+operations on the widget. It has the following general form:
+
+ $widget->method(?arg arg ...?);
+
+Many of the methods for Spinboxes take one or more indices as
+arguments. An index specifies a particular character in the Spinbox's
+string, in any of the following ways:
+
+=over 4
+
+=item I<number>
+
+Specifies the character as a numerical index, where 0 corresponds
+to the first character in the string.
+
+=item B<anchor>
+
+Indicates the anchor point for the selection, which is set with the
+B<select from> and B<select adjust> methods.
+
+=item B<end>
+
+Indicates the character just after the last one in the Spinbox's string.
+This is equivalent to specifying a numerical index equal to the length
+of the Spinbox's string.
+
+=item B<insert>
+
+Indicates the character adjacent to and immediately following the
+insertion cursor.
+
+=item B<sel.first>
+
+Indicates the first character in the selection. It is an error to
+use this form if the selection isn't in the Spinbox window.
+
+=item B<sel.last>
+
+Indicates the character just after the last one in the selection.
+It is an error to use this form if the selection isn't in the
+Spinbox window.
+
+=item B<@>I<number>
+
+In this form, I<number> is treated as an x-coordinate in the
+Spinbox's window; the character spanning that x-coordinate is used.
+For example, ``B<@0>'' indicates the left-most character in the
+window.
+
+=back
+
+Abbreviations may be used for any of the forms above, e.g. ``B<e>''
+or ``B<sel.f>''. In general, out-of-range indices are automatically
+rounded to the nearest legal value.
+
+The following commands are possible for Spinbox widgets:
+
+=over 4
+
+=item I<$widget>-E<gt>B<bbox>(I<index>);
+
+Returns a list of four numbers describing the bounding box of the
+character given by I<index>.
+The first two elements of the list give the x and y coordinates of
+the upper-left corner of the screen area covered by the character
+(in pixels relative to the widget) and the last two elements give
+the width and height of the character, in pixels.
+The bounding box may refer to a region outside the visible area
+of the window.
+
+=item I<$widget>-E<gt>B<cget>(I<option>);
+
+Returns the current value of the configuration option given
+by I<option>.
+I<Option> may have any of the values accepted by the B<Spinbox>
+command.
+
+=item I<$widget>-E<gt>B<configure>(?I<option>?, ?I<value, option, value, ...>?);
+
+Query or modify the configuration options of the widget.
+If no I<option> is specified, returns a list describing all of
+the available options for $widget (see L<Tk::configure> for
+information on the format of this list). If I<option> is specified
+with no I<value>, then the command returns a list describing the
+one named option (this list will be identical to the corresponding
+sublist of the value returned if no I<option> is specified). If
+one or more I<option-value> pairs are specified, then the command
+modifies the given widget option(s) to have the given value(s); in
+this case the command returns an empty string.
+I<Option> may have any of the values accepted by the B<Spinbox>
+command.
+
+=item I<$widget>-E<gt>B<delete>(I<first, >?I<last>?);
+
+Delete one or more elements of the Spinbox.
+I<First> is the index of the first character to delete, and
+I<last> is the index of the character just after the last
+one to delete.
+If I<last> isn't specified it defaults to I<first>+1,
+i.e. a single character is deleted.
+This command returns an empty string.
+
+=item I<$widget>-E<gt>B<get>;
+
+Returns the Spinbox's string.
+
+=item I<$widget>-E<gt>B<icursor>(I<index>);
+
+Arrange for the insertion cursor to be displayed just before the character
+given by I<index>. Returns an empty string.
+
+=item I<$widget>-E<gt>B<identify>(I<x, y>);
+
+Returns the name of the window element corresponding to coordinates
+I<x> and I<y> in the Spinbox. Return value is one of:
+B<none>, B<buttondown>, B<buttonup>, B<entry>.
+
+=item I<$widget>-E<gt>B<index>(I<index>);
+
+Returns the numerical index corresponding to I<index>.
+
+=item I<$widget>-E<gt>B<insert>(I<index, string>);
+
+Insert the characters of I<string> just before the character
+indicated by I<index>. Returns an empty string.
+
+=item I<$widget>-E<gt>B<invoke>(I<element>);
+
+Causes the specified element, either B<buttondown> or B<buttonup>,
+to be invoked, triggering the action associated with it.
+
+=item I<$widget>-E<gt>B<scan>(I<option, args>);
+
+This command is used to implement scanning on Spinboxes. It has
+two forms, depending on I<option>:
+
+=over 4
+
+=item I<$widget>-E<gt>B<scanMark>(I<x>);
+
+Records I<x> and the current view in the Spinbox window; used in
+conjunction with later B<scan dragto> commands. Typically this
+command is associated with a mouse button press in the widget. It
+returns an empty string.
+
+=item I<$widget>-E<gt>B<scanDragto>(I<x>);
+
+This command computes the difference between its I<x> argument
+and the I<x> argument to the last B<scan mark> command for
+the widget. It then adjusts the view left or right by 10 times the
+difference in x-coordinates. This command is typically associated
+with mouse motion events in the widget, to produce the effect of
+dragging the Spinbox at high speed through the window. The return
+value is an empty string.
+
+=back
+
+=item I<$widget>-E<gt>B<selection>(I<option, arg>);
+
+This command is used to adjust the selection within a Spinbox. It
+has several forms, depending on I<option>:
+
+=over 4
+
+=item I<$widget>-E<gt>B<selectionAdjust>(I<index>);
+
+Locate the end of the selection nearest to the character given by
+I<index>, and adjust that end of the selection to be at I<index>
+(i.e including but not going beyond I<index>). The other
+end of the selection is made the anchor point for future
+B<select to> commands. If the selection
+isn't currently in the Spinbox, then a new selection is created to
+include the characters between I<index> and the most recent
+selection anchor point, inclusive.
+Returns an empty string.
+
+=item I<$widget>-E<gt>B<selectionClear>;
+
+Clear the selection if it is currently in this widget. If the
+selection isn't in this widget then the command has no effect.
+Returns an empty string.
+
+=item I<$widget>-E<gt>B<selectionElement>(?I<element>?);
+
+Sets or gets the currently selected element. If a spinbutton element
+is specified, it will be displayed depressed.
+
+=item I<$widget>-E<gt>B<selectionFrom>(I<index>);
+
+Set the selection anchor point to just before the character
+given by I<index>. Doesn't change the selection.
+Returns an empty string.
+
+=item I<$widget>-E<gt>B<selectionPresent>;
+
+Returns 1 if there is are characters selected in the Spinbox,
+0 if nothing is selected.
+
+=item I<$widget>-E<gt>B<selectionRange>(I<start, >I<end>);
+
+Sets the selection to include the characters starting with
+the one indexed by I<start> and ending with the one just
+before I<end>.
+If I<end> refers to the same character as I<start> or an
+earlier one, then the Spinbox's selection is cleared.
+
+=item I<$widget>-E<gt>B<selectionTo>(I<index>);
+
+If I<index> is before the anchor point, set the selection
+to the characters from I<index> up to but not including
+the anchor point.
+If I<index> is the same as the anchor point, do nothing.
+If I<index> is after the anchor point, set the selection
+to the characters from the anchor point up to but not including
+I<index>.
+The anchor point is determined by the most recent B<select from>
+or B<select adjust> command in this widget.
+If the selection isn't in this widget then a new selection is
+created using the most recent anchor point specified for the widget.
+Returns an empty string.
+
+=back
+
+=item I<$widget>-E<gt>B<set>(?I<string>?);
+
+If I<string> is specified, the Spinbox will try and set it to this
+value, otherwise it just returns the Spinbox's string.
+If validation is on, it will occur when setting the string.
+
+=item I<$widget>-E<gt>B<validate>;
+
+This command is used to force an evaluation of the B<validateCommand>
+independent of the conditions specified by the B<validate> option.
+This is done by temporarily setting the B<validate> option to B<all>.
+It returns 0 or 1.
+
+=item I<$widget>-E<gt>B<xview>(I<args>);
+
+This command is used to query and change the horizontal position of the
+text in the widget's window. It can take any of the following
+forms:
+
+=over 4
+
+=item I<$widget>-E<gt>B<xview>;
+
+Returns a list containing two elements.
+Each element is a real fraction between 0 and 1; together they describe
+the horizontal span that is visible in the window.
+For example, if the first element is .2 and the second element is .6,
+20% of the Spinbox's text is off-screen to the left, the middle 40% is visible
+in the window, and 40% of the text is off-screen to the right.
+These are the same values passed to scrollbars via the B<-xscrollcommand>
+option.
+
+=item I<$widget>-E<gt>B<xview>(I<index>);
+
+Adjusts the view in the window so that the character given by I<index>
+is displayed at the left edge of the window.
+
+=item I<$widget>-E<gt>B<xviewMoveto>(I<fraction>);
+
+Adjusts the view in the window so that the character I<fraction> of the
+way through the text appears at the left edge of the window.
+I<Fraction> must be a fraction between 0 and 1.
+
+=item I<$widget>-E<gt>B<xviewScroll>(I<number, what>);
+
+This command shifts the view in the window left or right according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages> or an abbreviation
+of one of these.
+If I<what> is B<units>, the view adjusts left or right by
+I<number> average-width characters on the display; if it is
+B<pages> then the view adjusts by I<number> screenfuls.
+If I<number> is negative then characters farther to the left
+become visible; if it is positive then characters farther to the right
+become visible.
+
+=back
+
+=back
+
+=head1 DEFAULT BINDINGS
+
+Tk automatically creates class bindings for Spinboxes that give them
+the following default behavior.
+In the descriptions below, ``word'' refers to a contiguous group
+of letters, digits, or ``_'' characters, or any single character
+other than these.
+
+=over 4
+
+=item [1]
+
+Clicking mouse button 1 positions the insertion cursor
+just before the character underneath the mouse cursor, sets the
+input focus to this widget, and clears any selection in the widget.
+Dragging with mouse button 1 strokes out a selection between
+the insertion cursor and the character under the mouse.
+
+=item [2]
+
+Double-clicking with mouse button 1 selects the word under the mouse
+and positions the insertion cursor at the beginning of the word.
+Dragging after a double click will stroke out a selection consisting
+of whole words.
+
+=item [3]
+
+Triple-clicking with mouse button 1 selects all of the text in the
+Spinbox and positions the insertion cursor before the first character.
+
+=item [4]
+
+The ends of the selection can be adjusted by dragging with mouse
+button 1 while the Shift key is down; this will adjust the end
+of the selection that was nearest to the mouse cursor when button
+1 was pressed.
+If the button is double-clicked before dragging then the selection
+will be adjusted in units of whole words.
+
+=item [5]
+
+Clicking mouse button 1 with the Control key down will position the
+insertion cursor in the Spinbox without affecting the selection.
+
+=item [6]
+
+If any normal printing characters are typed in a Spinbox, they are
+inserted at the point of the insertion cursor.
+
+=item [7]
+
+The view in the Spinbox can be adjusted by dragging with mouse button 2.
+If mouse button 2 is clicked without moving the mouse, the selection
+is copied into the Spinbox at the position of the mouse cursor.
+
+=item [8]
+
+If the mouse is dragged out of the Spinbox on the left or right sides
+while button 1 is pressed, the Spinbox will automatically scroll to
+make more text visible (if there is more text off-screen on the side
+where the mouse left the window).
+
+=item [9]
+
+The Left and Right keys move the insertion cursor one character to the
+left or right; they also clear any selection in the Spinbox and set
+the selection anchor.
+If Left or Right is typed with the Shift key down, then the insertion
+cursor moves and the selection is extended to include the new character.
+Control-Left and Control-Right move the insertion cursor by words, and
+Control-Shift-Left and Control-Shift-Right move the insertion cursor
+by words and also extend the selection.
+Control-b and Control-f behave the same as Left and Right, respectively.
+Meta-b and Meta-f behave the same as Control-Left and Control-Right,
+respectively.
+
+=item [10]
+
+The Home key, or Control-a, will move the insertion cursor to the
+beginning of the Spinbox and clear any selection in the Spinbox.
+Shift-Home moves the insertion cursor to the beginning of the Spinbox
+and also extends the selection to that point.
+
+=item [11]
+
+The End key, or Control-e, will move the insertion cursor to the
+end of the Spinbox and clear any selection in the Spinbox.
+Shift-End moves the cursor to the end and extends the selection
+to that point.
+
+=item [12]
+
+The Select key and Control-Space set the selection anchor to the position
+of the insertion cursor. They don't affect the current selection.
+Shift-Select and Control-Shift-Space adjust the selection to the
+current position of the insertion cursor, selecting from the anchor
+to the insertion cursor if there was not any selection previously.
+
+=item [13]
+
+Control-/ selects all the text in the Spinbox.
+
+=item [14]
+
+Control-\ clears any selection in the Spinbox.
+
+=item [15]
+
+The F16 key (labelled Copy on many Sun workstations) or Meta-w
+copies the selection in the widget to the clipboard, if there is a selection.
+
+=item [16]
+
+The F20 key (labelled Cut on many Sun workstations) or Control-w
+copies the selection in the widget to the clipboard and deletes
+the selection.
+If there is no selection in the widget then these keys have no effect.
+
+=item [17]
+
+The F18 key (labelled Paste on many Sun workstations) or Control-y
+inserts the contents of the clipboard at the position of the
+insertion cursor.
+
+=item [18]
+
+The Delete key deletes the selection, if there is one in the Spinbox.
+If there is no selection, it deletes the character to the right of
+the insertion cursor.
+
+=item [19]
+
+The BackSpace key and Control-h delete the selection, if there is one
+in the Spinbox.
+If there is no selection, it deletes the character to the left of
+the insertion cursor.
+
+=item [20]
+
+Control-d deletes the character to the right of the insertion cursor.
+
+=item [21]
+
+Meta-d deletes the word to the right of the insertion cursor.
+
+=item [22]
+
+Control-k deletes all the characters to the right of the insertion
+cursor.
+
+=item [23]
+
+Control-t reverses the order of the two characters to the right of
+the insertion cursor.
+
+If the Spinbox is disabled using the B<-state> option, then the Spinbox's
+view can still be adjusted and text in the Spinbox can still be selected,
+but no insertion cursor will be displayed and no text modifications will
+take place.
+
+The behavior of Spinboxes can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+=back
+
+=head1 KEYWORDS
+
+Spinbox, Entry, widget
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Stats.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Stats.pm
new file mode 100755
index 00000000000..39bedfb1a47
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Stats.pm
@@ -0,0 +1,26 @@
+package Tk::Stats;
+
+($lu,$ls) = times;
+
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Stats.pm#4 $
+
+sub stats
+ {
+ my ($u,$s) = times;
+ my $du = $u-$lu;
+ my $ds = $s-$ls;
+ $ls = $s;
+ $lu = $u;
+ print sprintf(' dt=%4.2f du=%4.2f ds=%4.2f',$du+$ds,$du,$ds);
+ print sprintf(' t=%4.2f u=%4.2f s=%4.2f',$u+$s,$u,$s);
+ print ' ',shift,"\n";
+ }
+
+sub import
+{
+ stats($_[1]);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Submethods.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Submethods.pm
new file mode 100755
index 00000000000..2741611172e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Submethods.pm
@@ -0,0 +1,45 @@
+package Tk::Submethods;
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $
+
+sub import
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ foreach my $sub (@{$sm})
+ {
+ my ($suffix) = $sub =~ /(\w+)$/;
+ my $pfn = $package.'::'.$fn;
+ *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) };
+ }
+ }
+}
+
+sub Direct
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ my $sub;
+ foreach $sub (@{$sm})
+ {
+ # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }";
+ *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) };
+ }
+ }
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Submethods.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Submethods.pod
new file mode 100755
index 00000000000..2a83334f8b2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Submethods.pod
@@ -0,0 +1,27 @@
+
+=head1 NAME
+
+Tk::Submethods - add aliases for tk sub-commands
+
+=for pm Tk/Submethods.pm
+
+=for category Implementation
+
+=head1 SYNOPSIS
+
+ use Tk::Submethods ( 'command1' => [qw(sub1 sub2 sub3)],
+ 'command2' => [qw(sub1 sub2 sub3)]);
+
+=head1 DESCRIPTION
+
+Creates C<-E<gt>commandSub(...)> as an alias for C<-E<gt>command('sub',...)>
+e.g. C<-E<gt>grabRelease> for C<-E<gt>grab('release')>.
+
+For each command/subcommand pair this creates a closure with command
+and subcommand as bound lexical variables and assigns a reference to this
+to a 'glob' in the callers package.
+
+Someday the sub-commands may be created directly in the C code.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/SunConst.pod b/Master/tlpkg/tlperl.straw/lib/Tk/SunConst.pod
new file mode 100755
index 00000000000..eb5d892871b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/SunConst.pod
@@ -0,0 +1,18 @@
+
+=head1 NAME
+
+Tk::DragDrop::SunConst - Constants for Sun's Drag&Drop protocol
+
+=for pm DragDrop/DragDrop/SunConst.pm
+
+=for category Experimental Modules
+
+=head1 DESCRIPTION
+
+This module defines symbolic name subs for the numeric constants that
+make up Sun's Drag&Drop protocol. They are in this module with Exporter
+as they are shared between the two halves (Dropper and Receiver) of
+the protocol.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TList.pm b/Master/tlpkg/tlperl.straw/lib/Tk/TList.pm
new file mode 100755
index 00000000000..65ce18796bb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TList.pm
@@ -0,0 +1,416 @@
+package Tk::TList;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/TList/TList.pm#6 $
+
+use Tk qw(Ev $XS_VERSION);
+
+use base qw(Tk::Widget);
+
+use strict;
+
+Construct Tk::Widget 'TList';
+
+bootstrap Tk::TList;
+
+sub Tk_cmd { \&Tk::tlist }
+
+Tk::Methods qw(insert index anchor delete dragsite dropsite entrycget
+ entryconfigure info nearest see selection xview yview);
+
+use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)],
+ 'info' => [qw(anchor dragsite dropsite selection)],
+ 'selection' => [qw(clear get includes set)],
+ 'anchor' => [qw(clear set)],
+ 'dragsite' => [qw(clear set)],
+ 'dropsite' => [qw(clear set)],
+ );
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] );
+ $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] );
+ $mw->bind($class,'<Control-ButtonRelease-1>','Control_ButtonRelease_1');
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+ $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] );
+ $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] );
+
+ $mw->bind($class,'<Double-ButtonPress-1>',['Double1']);
+
+ $mw->bind($class,'<Control-B1-Motion>','Control_B1_Motion');
+ $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']);
+ $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']);
+
+ $mw->bind($class,'<B1-Enter>','B1_Enter');
+
+ $mw->bind($class,'<Up>', ['DirKey', 'up']);
+ $mw->bind($class,'<Down>',['DirKey', 'down']);
+
+ $mw->bind($class,'<Left>', ['DirKey', 'left']);
+ $mw->bind($class,'<Right>',['DirKey', 'right']);
+
+ $mw->bind($class,'<Prior>','Prior');
+ $mw->bind($class,'<Next>','Next');
+
+ $mw->bind($class,'<Return>', ['KeyboardActivate']);
+ $mw->bind($class,'<space>', ['KeyboardBrowse']);
+
+ return $class;
+}
+
+sub Control_ButtonRelease_1
+{
+}
+
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+ $w->ButtonRelease1($Ev);
+}
+
+
+sub Control_B1_Motion
+{
+}
+
+
+sub B1_Enter
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+}
+
+
+sub Prior
+{
+shift->yview('scroll', -1, 'pages')
+}
+
+
+sub Next
+{
+shift->yview('scroll', 1, 'pages')
+}
+
+
+sub Button1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ $w->focus()
+ if($w->cget('-takefocus'));
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+ # $w->Send_WaitDrag($Ev->y);
+ return;
+ }
+
+ my $ent = $w->GetNearest($Ev->x, $Ev->y);
+
+ return unless defined $ent;
+
+ my $browse = 0;
+
+ if($mode eq 'single')
+ {
+ $w->anchor('set', $ent);
+ }
+ elsif($mode eq 'browse')
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear' );
+ $w->selection('set', $ent);
+ $browse = 1;
+ }
+ elsif($mode eq 'multiple')
+ {
+ $w->selection('clear');
+ $w->anchor('set', $ent);
+ $w->selection('set', $ent);
+ $browse = 1;
+ }
+ elsif($mode eq 'extended')
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear');
+ $w->selection('set', $ent);
+ $browse = 1;
+ }
+
+ $w->Callback(-browsecmd => $ent) if ($browse);
+}
+
+sub ShiftButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ my $to = $w->GetNearest($Ev->x,$Ev->y);
+
+ delete $w->{'shiftanchor'};
+
+ return unless defined $to;
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'extended')
+ {
+ my $from = $w->info('anchor');
+ if (defined $from)
+ {
+ $w->selection('clear');
+ $w->selection('set', $from, $to);
+ }
+ else
+ {
+ $w->anchor('set', $to);
+ $w->selection('clear');
+ $w->selection('set', $to);
+ }
+ }
+}
+
+sub GetNearest
+{
+ my ($w,$x,$y) = @_;
+ my $ent = $w->nearest($x,$y);
+ if (defined $ent)
+ {
+ my $state = $w->entrycget($ent, '-state');
+ return $ent if (!defined($state) || $state ne 'disabled');
+ }
+ return undef;
+}
+
+sub ButtonRelease1
+{
+ my ($w, $Ev) = @_;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'dragdrop')
+ {
+# $w->Send_DoneDrag();
+ return;
+ }
+
+ my ($x, $y) = ($Ev->x, $Ev->y);
+ my $ent = $w->GetNearest($x,$y);
+
+ return unless defined $ent;
+
+ if($x < 0 || $y < 0 || $x > $w->width || $y > $w->height)
+ {
+ $w->selection('clear');
+
+ return if($mode eq 'single' || $mode eq 'browse')
+
+ }
+ else
+ {
+ if($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear');
+ $w->selection('set', $ent);
+
+ }
+ elsif($mode eq 'multiple')
+ {
+ $w->selection('set', $ent);
+ }
+ elsif($mode eq 'extended')
+ {
+ $w->selection('set', $ent);
+ }
+ }
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub Button1Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+# $w->Send_StartDrag();
+ return;
+ }
+
+ my $ent = $w->GetNearest($Ev->x,$Ev->y);
+
+ return unless defined $ent;
+
+ if($mode eq 'single')
+ {
+ $w->anchor('set', $ent);
+ }
+ elsif($mode eq 'multiple' || $mode eq 'extended')
+ {
+ my $from = $w->info('anchor');
+ if (defined $from)
+ {
+ $w->selection('clear');
+ $w->selection('set', $from, $ent);
+ }
+ else
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear');
+ $w->selection('set', $ent);
+ }
+ }
+
+ if($mode ne 'single')
+ {
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub Double1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->x,$Ev->y);
+
+ return unless defined $ent;
+
+ $w->anchor('set', $ent) unless defined($w->info('anchor'));
+
+ $w->selection('set', $ent);
+ $w->Callback(-command => $ent);
+}
+
+sub CtrlButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->x,$Ev->y);
+
+ return unless defined $ent;
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended')
+ {
+ $w->anchor('set', $ent) unless defined( $w->info('anchor') );
+
+ if($w->selection('includes', $ent))
+ {
+ $w->selection('clear', $ent);
+ }
+ else
+ {
+ $w->selection('set', $ent);
+ }
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub DirKey
+{
+ my ($w,$dir) = @_;
+ my $anchor = $w->info('anchor');
+
+ my $new = (defined $anchor) ? $w->info($dir,$anchor) : 0;
+
+ $w->anchorSet($new);
+ $w->see($new);
+}
+
+sub KeyboardActivate
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless defined $anchor;
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selection('clear');
+ $w->selection('set', $anchor);
+ }
+ $w->Callback(-command => $anchor);
+}
+
+sub KeyboardBrowse
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless defined $anchor;
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selection('clear');
+ $w->selection('set', $anchor);
+ }
+ $w->Callback(-browsecmd =>$anchor);
+}
+
+sub AutoScan
+{
+ my $w = shift;
+
+ return if($w->cget('-selectmode') eq 'dragdrop');
+
+ my $Ev = $w->XEvent;
+ my $y = $Ev->y;
+ my $x = $Ev->x;
+
+ if($y >= $w->height)
+ {
+ $w->yview('scroll', 1, 'units');
+ }
+ elsif($y < 0)
+ {
+ $w->yview('scroll', -1, 'units');
+ }
+ elsif($x >= $w->width)
+ {
+ $w->xview('scroll', 2, 'units');
+ }
+ elsif($x < 0)
+ {
+ $w->xview('scroll', -2, 'units');
+ }
+ else
+ {
+ return;
+ }
+ $w->RepeatId($w->after(50,[AutoScan => $w]));
+ $w->Button1Motion;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TList.pod b/Master/tlpkg/tlperl.straw/lib/Tk/TList.pod
new file mode 100755
index 00000000000..b8937fa8ef0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TList.pod
@@ -0,0 +1,597 @@
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distribution are in the file
+# license.tcl.
+
+=head1 NAME
+
+Tk::TList - Create and manipulate Tix Tabular List widgets
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+S< >I<$tlist> = I<$parent>-E<gt>B<TList>(?I<options>?);
+
+=head1 SUPER-CLASS
+
+None.
+
+=head1 STANDARD OPTIONS
+
+B<-background> B<-borderwidth> B<-class> B<-cursor> B<-foreground>
+B<-font> B<-height> B<-highlightcolor> B<-highlightthickness>
+B<-relief> B<-selectbackground> B<-selectforeground>
+B<-xscrollcommand> B<-yscrollcommand> B<-width>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<browsecmd>
+
+=item Class: B<BrowseCmd>
+
+=item Switch: B<-browsecmd>
+
+Specifies a perl/Tk B<callback> to be executed when the user browses through the
+entries in the TList widget.
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies the perl/Tk B<callback> to be executed when the user invokes a list
+entry in the TList widget. Normally the user invokes a list
+entry by double-clicking it or pressing the Return key.
+
+=item Name: B<foreground>
+
+=item Class: B<Foreground>
+
+=item Switch: B<-foreground>
+
+=item Alias: B<-fg>
+
+Specifies the default foreground color for the list entries.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies the desired height for the window in number of characters.
+
+=item Name: B<itemType>
+
+=item Class: B<ItemType>
+
+=item Switch: B<-itemtype>
+
+Specifies the default type of display item for this TList widget. When
+you call the B<insert> methods, display items of this
+type will be created if the B<-itemtype> option is not specified.
+
+=item Name: B<orient>
+
+=item Class: B<Orient>
+
+=item Switch: B<-orient>
+
+Specifies the order of tabularizing the list entries. When set to
+"B<vertical>", the entries are arranged in a column, from top to
+bottom. If the entries cannot be contained in one column, the
+remaining entries will go to the next column, and so on. When set to
+"B<horizontal>", the entries are arranged in a row, from left to
+right. If the entries cannot be contained in one row, the remaining
+entries will go to the next row, and so on.
+
+=item Name: B<padX>
+
+=item Class: B<Pad>
+
+=item Switch: B<-padx>
+
+The default horizontal padding for list entries.
+
+=item Name: B<padY>
+
+=item Class: B<Pad>
+
+=item Switch: B<-padx>
+
+The default vertical padding for list entries.
+
+=item Name: B<selectBackground>
+
+=item Class: B<SelectBackground>
+
+=item Switch: B<-selectbackground>
+
+Specifies the background color for the selected list entries.
+
+=item Name: B<selectBorderWidth>
+
+=item Class: B<BorderWidth>
+
+=item Switch: B<-selectborderwidth>
+
+Specifies a non-negative value indicating the width of the 3-D border
+to draw around selected items. The value may have any of the forms
+acceptable to B<Tk_GetPixels>.
+
+=item Name: B<selectForeground>
+
+=item Class: B<SelectForeground>
+
+=item Switch: B<-selectforeground>
+
+Specifies the foreground color for the selected list entries.
+
+=item Name: B<selectMode>
+
+=item Class: B<SelectMode>
+
+=item Switch: B<-selectmode>
+
+Specifies one of several styles for manipulating the selection. The
+value of the option may be arbitrary, but the default bindings expect
+it to be either B<single>, B<browse>, B<multiple>, or
+B<extended>; the default value is B<single>.
+
+=item Name: B<sizeCmd>
+
+=item Class: B<SizeCmd>
+
+=item Switch: B<-sizecmd>
+
+Specifies a perl/Tk B<callback> to be called whenever the TList widget
+changes its size. This command can be useful to implement "user scroll
+bars when needed" features.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies whether the TList command should react to user actions. When
+set to "B<normal>", the TList reacts to user actions in the normal
+way. When set to "B<disabled>", the TList can only be scrolled, but
+its entries cannot be selected or activated.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired width for the window in characters.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<TList> method creates a new window (given by the
+$widget argument) and makes it into a TList widget.
+Additional options, described above, may be specified on the command
+line or in the option database to configure aspects of the
+TList widget such as its cursor and relief.
+
+The TList widget can be used to display data in a tabular format. The
+list entries of a TList widget are similar to the entries in the Tk
+listbox widget. The main differences are (1) the TList widget can
+display the list entries in a two dimensional format and (2) you can
+use graphical images as well as multiple colors and fonts for
+the list entries.
+
+Each list entry is identified by an B<index>, which can be in the
+following forms:
+
+=over 4
+
+=item I<number>
+
+An integer that indicates the position of the entry in the list. 0
+means the first position, 1 means the second position, and so on.
+
+=item B<end>
+
+Indicates the end of the listbox. For some commands this means just
+after the last entry; for other commands it means the last entry.
+
+=item B<@>I<x>,I<y>
+
+Indicates the element that covers the point in the listbox window
+specified by x and y (in pixel coordinates). If no element covers that
+point, then the closest element to that point is used.
+
+=back
+
+=head1 DISPLAY ITEMS
+
+Each list entry in an TList widget is associated with a B<display>
+item. The display item determines what visual information should
+be displayed for this list entry. Please see L<Tk::DItem>
+for a list of all display items.
+
+When a list entry is created by the B<insert> command, the type of
+its display item is determined by the B<-itemtype> option passed
+to these commands. If the B<-itemtype> is omitted, then by default
+the type specified by this TList widget's B<-itemtype> option is
+used.
+
+=head1 WIDGET METHODS
+
+The B<TList> method creates a widget object.
+
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for TList widgets:
+
+=over 4
+
+=item I<$tlist>-E<gt>B<anchorSet>(I<index>)
+
+Sets the anchor to the list entry identified by I<index>. The
+anchor is the end of the selection that is fixed while dragging out a
+selection with the mouse.
+
+=item I<$tlist>-E<gt>B<anchorClear>
+
+Removes the anchor, if any, from this TList widget. This only removes
+the surrounding highlights of the anchor entry and does not affect its
+selection status.
+
+=item I<$tlist>-E<gt>B<delete>(I<from, >?I<to>?)
+
+Deletes one or more list entries between the two entries specified by
+the indices I<from> and I<to>. If I<to> is not specified, deletes
+the single entry specified by I<from>.
+
+=item I<$tlist>-E<gt>B<dragsiteSet>(I<index>)
+
+Sets the dragsite to the list entry identified by
+I<index>. The dragsite is used to indicate the source of a
+drag-and-drop action. Currently drag-and-drop functionality has not
+been implemented in Tix yet.
+
+=item I<$tlist>-E<gt>B<dragsiteClear>
+
+Remove the dragsite, if any, from the this TList widget. This only
+removes the surrounding highlights of the dragsite entry and does not
+affect its selection status.
+
+=item I<$tlist>-E<gt>B<dropsiteSet>(I<index>)
+
+Sets the dropsite to the list entry identified by I<index>. The
+dropsite is used to indicate the target of a drag-and-drop
+action. Currently drag-and-drop functionality has not been implemented
+in Tix yet.
+
+=item I<$tlist>-E<gt>B<dropsiteClear>
+
+Remove the dropsite, if any, from the this TList widget. This only
+removes the surrounding highlights of the dropsite entry and does not
+affect its selection status.
+
+=item I<$tlist>-E<gt>B<entrycget>(I<index, option>)
+
+Returns the current value of the configuration option given by
+I<option> for the entry indentfied by I<index>. I<Option> may
+have any of the values accepted by the B<insert> method.
+
+=item I<$tlist>-E<gt>B<entryconfigure>(I<index, >?I<option>?, I<?value, option, value, ...>?)
+
+Query or modify the configuration options of the list entry identified
+by I<index>. If no I<option> is specified, returns a list
+describing all of the available options for I<index> (see
+B<Tk_ConfigureInfo> for information on the format of this list). If
+I<option> is specified with no I<value>, then the method
+returns a list describing the one named option (this list will be
+identical to the corresponding sublist of the value returned if no
+I<option> is specified). If one or more I<option-value> pairs
+are specified, then the command modifies the given option(s) to have
+the given value(s); in this case the method returns an empty string.
+I<Option> may have any of the values accepted by the B<insert>
+method. The exact set of options depends on the
+value of the B<-itemtype> option passed to the the B<insert>
+method when this list entry is created.
+
+=item I<$tlist>-E<gt>B<insert>(I<index, >?I<option, value, ...>?)
+
+Creates a new list entry at the position indicated by I<index>. The
+following configuration options can be given to configure the list
+entry:
+
+=over 8
+
+=item B<-itemtype> => I<type>
+
+Specifies the type of display item to be display for the new list
+entry. I<type> must be a valid display item type. Currently the
+available display item types are B<image>, B<imagetext>,
+B<text>, and I<$widget>. If this option is not specified, then by
+default the type specified by this TList widget's B<-itemtype>
+option is used.
+
+=item B<-state> => I<state>
+
+Specifies whether this entry can be selected or invoked by the user.
+Must be either B<normal> or B<disabled>.
+
+=item B<-data> => I<data>
+
+Arbitrary data to be associated with the entry (a perl scalar value).
+
+=back
+
+The B<insert> method accepts additional configuration options
+to configure the display item associated with this list entry. The set
+of additional configuration options depends on the type of the display
+item given by the B<-itemtype> option. Please see
+L<Tk::DItem> for a list of the configuration options for
+each of the display item types.
+
+=item I<$tlist>-E<gt>B<info>(I<option, >I<arg, ...>)
+
+Query information about the TList widget. I<option> can be one
+of the following:
+
+=over 8
+
+=item I<$tlist>-E<gt>B<info>(B<anchor, >I<index>)
+
+Returns the index of the current anchor, if any, of the TList
+widget. If the anchor is not set, returns the empty string.
+
+=item I<$tlist>-E<gt>B<info>(B<dragsite, >I<index>)
+
+Returns the index of the current dragsite, if any, of the TList
+widget. If the dragsite is not set, returns the empty string.
+
+=item I<$tlist>-E<gt>B<info>(B<dropsite, >I<index>)
+
+Returns the index of the current dropsite, if any, of the TList
+widget. If the dropsite is not set, returns the empty string.
+
+=item I<$tlist>-E<gt>B<info>(B<selection>)
+
+Returns a list of selected elements in the TList widget. If no entries
+are selected, returns an empty string.
+
+=back
+
+=item I<$tlist>-E<gt>B<nearest>(I<x, y>)
+
+Given an I<(x,y)> coordinate within the TList window, this command
+returns the index of the TList element nearest to that coordinate.
+
+=item I<$tlist>-E<gt>B<see>(I<index>)
+
+Adjust the view in the TList so that the entry given by I<index> is
+visible. If the entry is already visible then the command has no
+effect; otherwise TList scrolls to bring the element into view at the edge
+to which it is nearest.
+
+=item I<$tlist>-E<gt>B<selection>(I<option, >I<arg, ...>)
+
+This command is used to adjust the selection within a TList widget. It
+has several forms, depending on I<option>:
+
+=over 8
+
+=item I<$tlist>-E<gt>B<selectionClear>(?I<from>?, ?I<to>?)
+
+When no extra arguments are given, deselects all of the list entrie(s)
+in this TList widget. When only I<from> is given, only the list
+entry identified by I<from> is deselected. When both I<from> and
+I<to> are given, deselects all of the list entrie(s) between
+between I<from> and I<to>, inclusive, without affecting the
+selection state of entries outside that range.
+
+=item I<$tlist>-E<gt>B<selectionIncludes>(I<index>)
+
+Returns 1 if the list entry indicated by I<index> is currently
+selected; returns 0 otherwise.
+
+=item I<$tlist>-E<gt>B<selectionSet>(I<from, >?I<to>?)
+
+Selects all of the list entrie(s) between between I<from> and
+I<to>, inclusive, without affecting the selection state of entries
+outside that range. When only I<from> is given, only the list entry
+identified by I<from> is selected.
+
+=back
+
+=item I<$tlist>-E<gt>B<xview>(I<args>)
+
+This command is used to query and change the horizontal position of the
+information in the widget's window. It can take any of the following
+forms:
+
+=over 8
+
+=item I<$tlist>-E<gt>B<xview>
+
+Returns a list containing two elements. Each element is a real
+fraction between 0 and 1; together they describe the horizontal span
+that is visible in the window. For example, if the first element is
+0.2 and the second element is 0.6, 20% of the TList entry is
+off-screen to the left, the middle 40% is visible in the window, and
+40% of the entry is off-screen to the right. These are the same values
+passed to scrollbars via the B<-xscrollcommand> option.
+
+=item I<$tlist>-E<gt>B<xview>(I<index>)
+
+Adjusts the view in the window so that the list entry identified by
+I<index> is aligned to the left edge of the window.
+
+=item I<$tlist>-E<gt>B<xviewMoveto>(I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the total
+width of the TList is off-screen to the left. I<fraction> must be
+a fraction between 0 and 1.
+
+=item I<$tlist>-E<gt>B<xviewScroll>(I<number, what>)
+
+This command shifts the view in the window left or right according to
+I<number> and I<what>. I<Number> must be an integer.
+I<What> must be either B<units> or B<pages> or an
+abbreviation of one of these. If I<what> is B<units>, the view
+adjusts left or right by I<number> character units (the width of
+the B<0> character) on the display; if it is B<pages> then the
+view adjusts by I<number> screenfuls. If I<number> is negative
+then characters farther to the left become visible; if it is positive
+then characters farther to the right become visible.
+
+=back
+
+=item I<$tlist>-E<gt>B<yview>(I<?args>?)
+
+This command is used to query and change the vertical position of the
+entries in the widget's window. It can take any of the following forms:
+
+=over 8
+
+=item I<$tlist>-E<gt>B<yview>
+
+Returns a list containing two elements, both of which are real
+fractions between 0 and 1. The first element gives the position of
+the list element at the top of the window, relative to the TList as a
+whole (0.5 means it is halfway through the TList, for example). The
+second element gives the position of the list entry just after the
+last one in the window, relative to the TList as a whole. These are
+the same values passed to scrollbars via the B<-yscrollcommand>
+option.
+
+=item I<$tlist>-E<gt>B<yview>(I<index>)
+
+Adjusts the view in the window so that the list entry given by
+I<index> is displayed at the top of the window.
+
+=item I<$tlist>-E<gt>B<yviewMoveto>(I<fraction>)
+
+Adjusts the view in the window so that the list entry given by
+I<fraction> appears at the top of the window. I<Fraction> is a
+fraction between 0 and 1; 0 indicates the first entry in the TList,
+0.33 indicates the entry one-third the way through the TList, and so
+on.
+
+=item I<$tlist>-E<gt>B<yviewScroll>(I<number, what>)
+
+This command adjust the view in the window up or down according to
+I<number> and I<what>. I<Number> must be an integer.
+I<What> must be either B<units> or B<pages>. If I<what>
+is B<units>, the view adjusts up or down by I<number> lines; if
+it is B<pages> then the view adjusts by I<number> screenfuls.
+If I<number> is negative then earlier entries become visible; if
+it is positive then later entries become visible.
+
+=back
+
+=back
+
+=head1 BINDINGS
+
+=over 4
+
+=item [1]
+
+If the B<-selectmode> is "browse", when the user drags the mouse
+pointer over the list entries, the entry under the pointer will be
+highlighted and the B<-browsecmd> procedure will be called with
+one parameter, the index of the highlighted entry. Only one entry
+can be highlighted at a time. The B<-command> procedure will be
+called when the user double-clicks on a list entry.
+
+=item [2]
+
+If the B<-selectmode> is "single", the entries will only be
+highlighted by mouse E<lt>ButtonRelease-1E<gt> events. When a new list entry
+is highlighted, the B<-browsecmd> procedure will be called with
+one parameter indicating the highlighted list entry. The
+B<-command> procedure will be called when the user double-clicks
+on a list entry.
+
+=item [3]
+
+If the B<-selectmode> is "multiple", when the user drags the mouse
+pointer over the list entries, all the entries under the pointer will
+be highlighted. However, only a contiguous region of list entries can
+be selected. When the highlighted area is changed, the
+B<-browsecmd> procedure will be called with an undefined
+parameter. It is the responsibility of the B<-browsecmd> procedure
+to find out the exact highlighted selection in the TList. The
+B<-command> procedure will be called when the user double-clicks
+on a list entry.
+
+=item [4]
+
+If the B<-selectmode> is "extended", when the user drags the mouse
+pointer over the list entries, all the entries under the pointer will
+be highlighted. The user can also make disjointed selections using
+E<lt>Control-ButtonPress-1E<gt>. When the highlighted area is changed, the
+B<-browsecmd> procedure will be called with an undefined
+parameter. It is the responsibility of the B<-browsecmd> procedure
+to find out the exact highlighted selection in the TList. The
+B<-command> procedure will be called when the user double-clicks
+on a list entry.
+
+=back
+
+=cut
+
+# BUG:
+# click on 'one' in example below does not make
+# it 'active' item (didn't GBARR reported this before!?)
+
+=head1 EXAMPLE
+
+This example demonstrates how to use an TList to store a list of
+numbers:
+
+ use strict;
+ use Tk ();
+ use Tk::TList;
+
+ my $mw = Tk::MainWindow->new();
+ my $image = $mw->Getimage('folder');
+ my $tlist = $mw->TList(-orient => 'vertical');
+ for my $text ( qw/one two three four five six seven eight nine/ ) {
+ $tlist->insert('end',
+ -itemtype=>'imagetext', -image=>$image, -text=>$text);
+ }
+
+ $tlist->pack(-expand=>'yes', -fill=>'both');
+
+ Tk::MainLoop;
+
+=head1 SEE ALSO
+
+L<Tk::options|Tk::options>
+L<Tk::Widget|Tk::Widget>
+L<Tk::DItem|Tk::DItem>
+L<Tk::HList|Tk::HList>
+L<Tk::TixGrid|Tk::TixGrid>
+
+=head1 KEYWORDS
+
+Tix(n), Tabular Listbox, Display Items
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Table.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Table.pm
new file mode 100755
index 00000000000..a8c9d9a3bfa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Table.pm
@@ -0,0 +1,598 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Table;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.014'; # was: sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Pretty;
+use AutoLoader;
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'Table';
+
+# Constants for QueueLayout flags
+sub _SlaveSize () { 1 } # Slave has asked for change of width or height
+sub _SlaveChange () { 2 } # We lost or gained a slave
+sub _ViewChange () { 4 } # xview or yview called
+sub _ConfigEvent () { 8 } # Table has changed size
+sub _ScrollBars () { 32 } # Scrollabrs came or went
+sub _RowColCount () { 16 } # rows or columns configured
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>',['QueueLayout',_ConfigEvent]);
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ $mw->XYscrollBind($class);
+ return $class;
+}
+
+sub _view
+{
+ my ($t,$s,$page,$a,$op,$num,$type) = @_;
+ if ($op eq 'moveto')
+ {
+ $$s = int(@$a*$num);
+ }
+ else
+ {
+ $num *= ($page/2) if ($type eq 'pages');
+ $$s += $num;
+ }
+ $$s = 0 if ($$s < 0);
+ $t->QueueLayout(_ViewChange);
+}
+
+sub xview
+{
+ my $t = shift;
+ $t->_view(\$t->{Left},$t->cget('-columns'),$t->{Width},@_);
+}
+
+sub yview
+{
+ my $t = shift;
+ $t->_view(\$t->{Top},$t->cget('-rows'),$t->{Height},@_);
+}
+
+sub FocusChildren
+{
+ my $t = shift;
+ return () if ($t->cget('-takefocus'));
+ return $t->SUPER::FocusChildren;
+}
+
+sub Populate
+{
+ my ($t,$args) = @_;
+ $t->SUPER::Populate($args);
+ $t->ConfigSpecs('-scrollbars' => [METHOD => 'scrollbars','Scrollbars','nw'],
+ '-takefocus' => [SELF => 'takeFocus','TakeFocus',1],
+ '-rows' => [METHOD => 'rows','Rows',10],
+ '-fixedrows' => [METHOD => 'fixedRows','FixedRows',0],
+ '-columns' => [METHOD => 'columns','Columns',10],
+ '-fixedcolumns' => [METHOD => 'fixedColumn','FixedColumns',0],
+ '-highlightthickness' => [SELF => 'highlightThickness','HighlightThickness',2]
+ );
+ $t->_init;
+}
+
+sub sizeN
+{
+ my ($n,$a) = @_;
+ my $max = 0;
+ my $i = 0;
+ my $sum = 0;
+ while ($i < @$a && $i < $n)
+ {
+ my $n = $a->[$i++];
+ $a->[$i-1] = $n = 0 unless (defined $n);
+ $sum += $n;
+ }
+ $max = $sum if ($sum > $max);
+ while ($i < @$a)
+ {
+ $sum = $sum-$a->[$i-$n]+$a->[$i];
+ $max = $sum if ($sum > $max);
+ $i++;
+ }
+ return $max;
+}
+
+sub total
+{
+ my ($a) = @_;
+ my $total = 0;
+ my $x;
+ foreach $x (@{$a})
+ {
+ $total += $x;
+ }
+ return $total;
+}
+
+sub constrain
+{
+ my ($sb,$a,$pixels,$fixed) = @_;
+ my $n = $$sb+$fixed;
+ my $total = 0;
+ my $i;
+ $n = @$a if ($n > @$a);
+ $n = $fixed if ($n < $fixed);
+ for ($i= 0; $i < $fixed; $i++)
+ {
+ (defined($a->[$i])) && ($total += $a->[$i]);
+ }
+ for ($i=$n; $total < $pixels && $i < @$a; $i++)
+ {
+ $a->[$i] ||= 0;
+ $total += $a->[$i];
+ }
+ while ($n > $fixed)
+ {
+ if (($total += $a->[--$n]) > $pixels)
+ {
+ $n++;
+ last;
+ }
+ }
+ $$sb = $n-$fixed;
+}
+
+sub Layout
+{
+ my ($t) = @_;
+ return unless Tk::Exists($t);
+ my $rows = @{$t->{Row}};
+ my $bw = $t->cget(-highlightthickness);
+ my $frows = $t->cget(-fixedrows);
+ my $fcols = $t->cget(-fixedcolumns);
+ my $sb = $t->cget(-scrollbars);
+ my $H = $t->Height;
+ my $W = $t->Width;
+ my $tadj = $bw;
+ my $badj = $bw;
+ my $ladj = $bw;
+ my $radj = $bw;
+ my @xs = ($W,0,0,0);
+ my @ys = (0,$H,0,0);
+ my $xsb;
+ my $ysb;
+
+ my $why = $t->{LayoutPending};
+ $t->{LayoutPending} = 0;
+
+ if ($sb =~ /[ns]/)
+ {
+ $t->{xsb} = $t->Scrollbar(-orient => 'horizontal', -command => ['xview' => $t]) unless (defined $t->{xsb});
+ $xsb = $t->{xsb};
+ $t->Advertise('xscrollbar' => $xsb);
+ $xs[3] = $xsb->ReqHeight;
+ if ($sb =~ /n/)
+ {
+ $xs[1] = $tadj;
+ $tadj += $xs[3];
+ }
+ else
+ {
+ $badj += $xs[3];
+ $xs[1] = $H-$badj;
+ }
+ }
+ else
+ {
+ $t->{xsb}->UnmapWindow if (defined $t->{xsb});
+ }
+
+ if ($sb =~ /[ew]/)
+ {
+ $t->{ysb} = $t->Scrollbar(-orient => 'vertical', -command => ['yview' => $t]) unless (defined $t->{ysb});
+ $ysb = $t->{ysb};
+ $t->Advertise('yscrollbar' => $ysb);
+ $ys[2] = $ysb->ReqWidth;
+ if ($sb =~ /w/)
+ {
+ $ys[0] = $ladj;
+ $ladj += $ys[2];
+ }
+ else
+ {
+ $radj += $ys[2];
+ $ys[0] = $W-$radj;
+ }
+ }
+ else
+ {
+ $t->{ysb}->UnmapWindow if (defined $t->{ysb});
+ }
+
+ constrain(\$t->{Top}, $t->{Height},$H-($tadj+$badj),$frows);
+ constrain(\$t->{Left},$t->{Width}, $W-($ladj+$radj),$fcols);
+
+ my $top = $t->{Top}+$frows;
+ my $left = $t->{Left}+$fcols;
+
+ if ($why & (_ScrollBars|_RowColCount|_SlaveSize))
+ {
+ # Width and/or Height of element or
+ # number of rows and/or columns or
+ # scrollbar presence has changed
+ my $w = sizeN($t->cget('-columns'),$t->{Width})+$radj+$ladj;
+ my $h = sizeN($t->cget('-rows'),$t->{Height})+$tadj+$badj;
+ $t->GeometryRequest($w,$h);
+ }
+
+ if ($rows)
+ {
+ my $cols = @{$t->{Width}};
+ my $yhwm = $top-$frows;
+ my $xhwm = $left-$fcols;
+ my $y = $tadj;
+ my $r;
+ for ($r = 0; $r < $rows; $r++)
+ {
+ my $h = $t->{Height}[$r];
+ next unless defined $h;
+ if (($r < $top && $r >= $frows) || ($y+$h > $H-$badj))
+ {
+ if (defined $t->{Row}[$r])
+ {
+ my $c;
+ for ($c = 0; $c < @{$t->{Row}[$r]}; $c++)
+ {
+ my $s = $t->{Row}[$r][$c];
+ if (defined $s)
+ {
+ $s->UnmapWindow;
+ if ($why & 1)
+ {
+ my $w = $t->{Width}[$c];
+ $s->ResizeWindow($w,$h);
+ }
+ }
+ }
+ }
+ }
+ else
+ {
+ my $hwm = $left-$fcols;
+ my $sh = 0;
+ my $x = $ladj;
+ my $c;
+ $ys[1] = $y if ($y < $ys[1] && $r >= $frows);
+ for ($c = 0; $c <$cols; $c++)
+ {
+ my $s = $t->{Row}[$r][$c];
+ my $w = $t->{Width}[$c];
+ if (($c < $left && $c >= $fcols) || ($x+$w > $W-$radj) )
+ {
+ if (defined $s)
+ {
+ $s->UnmapWindow;
+ $s->ResizeWindow($w,$h) if ($why & 1);
+ }
+ }
+ else
+ {
+ $xs[0] = $x if ($x < $xs[0] && $c >= $fcols);
+ if (defined $s)
+ {
+ if ($why & 1)
+ {
+ $s->MoveResizeWindow($x,$y,$w,$h);
+ }
+ else
+ {
+ $s->MoveWindow($x,$y);
+ }
+ $s->MapWindow;
+ }
+ $x += $w;
+ if ($c >= $fcols)
+ {
+ $hwm++;
+ $sh += $w
+ }
+ }
+ }
+ $xhwm = $hwm if ($hwm > $xhwm);
+ $xs[2] = $sh if ($sh > $xs[2]);
+ $y += $h;
+ if ($r >= $frows)
+ {
+ $ys[3] += $h;
+ $yhwm++;
+ }
+ }
+ }
+ $t->{Bottom} = $yhwm;
+ $t->{Right} = $xhwm;
+ if (defined $xsb && $xs[2] > 0)
+ {
+ $xsb->MoveResizeWindow(@xs);
+ $cols -= $fcols;
+ if ($cols > 0)
+ {
+ $xsb->set($t->{Left}/$cols,$t->{Right}/$cols);
+ $xsb->MapWindow;
+ }
+ }
+ if (defined $ysb && $ys[3] > 0)
+ {
+ $ysb->MoveResizeWindow(@ys);
+ $rows -= $frows;
+ if ($rows > 0)
+ {
+ $ysb->set($t->{Top}/$rows,$t->{Bottom}/$rows);
+ $ysb->MapWindow;
+ }
+ }
+ }
+}
+
+sub QueueLayout
+{
+ my ($m,$why) = @_;
+ $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
+ $m->{LayoutPending} |= $why;
+}
+
+sub SlaveGeometryRequest
+{
+ my ($m,$s) = @_;
+ my ($row,$col) = @{$m->{Slave}{$s->PathName}};
+ my $sw = $s->ReqWidth;
+ my $sh = $s->ReqHeight;
+ my $sz = 0;
+ if ($sw > $m->{Width}[$col])
+ {
+ $m->{Width}[$col] = $sw;
+ $m->QueueLayout(_SlaveSize);
+ $sz++;
+ }
+ if ( (not defined ($m->{Height}[$row])) or $sh > $m->{Height}[$row])
+ {
+ $m->{Height}[$row] = $sh;
+ $m->QueueLayout(_SlaveSize);
+ $sz++;
+ }
+ if (!$sz)
+ {
+ $s->ResizeWindow($m->{Width}[$col],$m->{Height}[$row]);
+ }
+}
+
+sub get
+{
+ my ($t,$row,$col) = @_;
+ return $t->{Row}[$row][$col];
+}
+
+sub LostSlave
+{
+ my ($t,$s) = @_;
+ my $info = delete $t->{Slave}{$s->PathName};
+ if (defined $info)
+ {
+ my ($row,$col) = @$info;
+ $t->{Row}[$row][$col] = undef;
+ $s->UnmapWindow;
+ }
+ else
+ {
+ $t->BackTrace('Cannot find' . $s->PathName);
+ }
+ $t->QueueLayout(_SlaveChange);
+}
+
+sub clear {
+ my $self = shift;
+ my $rows = $self->cget(-rows);
+ my $cols = $self->cget(-columns);
+ foreach my $r (1 .. $rows) {
+ foreach my $c (1 .. $cols) {
+ my $old = $self->get( $r, $c );
+ next unless $old;
+ $self->LostSlave($old);
+ $old->destroy;
+ }
+ }
+ $self->_init;
+ $self->QueueLayout(_SlaveSize);
+}
+
+sub _init {
+ my $self = shift;
+ $self->{'Width'} = [];
+ $self->{'Height'} = [];
+ $self->{'Row'} = [];
+ $self->{'Slave'} = {};
+ $self->{'Top'} = 0;
+ $self->{'Left'} = 0;
+ $self->{'Bottom'} = 0;
+ $self->{'Right'} = 0;
+ $self->{LayoutPending} = 0;
+}
+
+sub put
+{
+ my ($t,$row,$col,$w) = @_;
+ $w = $t->Label(-text => $w) unless (ref $w);
+ $t->ManageGeometry($w);
+ unless (defined $t->{Row}[$row])
+ {
+ $t->{Row}[$row] = [];
+ $t->{Height}[$row] = 0;
+ }
+ unless (defined $t->{Width}[$col])
+ {
+ $t->{Width}[$col] = 0;
+ }
+ my $old = $t->{Row}[$row][$col];
+ if (defined $old)
+ {
+ $old->UnmanageGeometry;
+ $t->LostSlave($old);
+ }
+ $t->{Row}[$row][$col] = $w;
+ $t->{Slave}{$w->PathName} = [$row,$col];
+ $t->SlaveGeometryRequest($w);
+ $t->QueueLayout(_SlaveChange);
+ return $old;
+}
+
+#
+# configure methods
+#
+
+sub scrollbars
+{
+ my ($t,$v) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-scrollbars => $v);
+ $t->QueueLayout(_ScrollBars);
+ }
+ return $t->_cget('-scrollbars');
+}
+
+sub rows
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-rows => $r);
+ if ($t->{Row} && @{$t->{Row}} > $r)
+ {
+ for my $y ($r .. $#{$t->{Row}})
+ {
+ for my $s (@{$t->{Row}[$y]})
+ {
+ $s->destroy if $s;
+ }
+ }
+ splice @{ $t->{Row} }, $r;
+ }
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-rows');
+}
+
+sub fixedrows
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-fixedrows => $r);
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-fixedrows');
+}
+
+sub columns
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-columns => $r);
+ if ($t->{Row})
+ {
+ for my $row (@{$t->{Row}})
+ {
+ for my $s (@$row[$r .. $#$row])
+ {
+ $s->destroy if $s;
+ }
+ { # FIXME? - Steve was getting warnings :
+ # splice() offset past end of array
+ local $^W = 0;
+ splice @$row, $r;
+ }
+ }
+ }
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-columns');
+}
+
+sub fixedcolumns
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-fixedcolumns => $r);
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-fixedcolumns');
+}
+
+1;
+__END__
+sub Create
+{
+ my $t = shift;
+ my $r = shift;
+ my $c = shift;
+ my $kind = shift;
+ $t->put($r,$c,$t->$kind(@_));
+}
+
+sub totalColumns
+{
+ scalar @{shift->{'Width'}};
+}
+
+sub totalRows
+{
+ scalar @{shift->{'Height'}};
+}
+
+sub Posn
+{
+ my ($t,$s) = @_;
+ my $info = $t->{Slave}{$s->PathName};
+ return (wantarray) ? @$info : $info;
+}
+
+sub see
+{
+ my $t = shift;
+ my ($row,$col) = (@_ == 2) ? @_ : @{$t->{Slave}{$_[0]->PathName}};
+ my $see = 1;
+ if (($row -= $t->cget('-fixedrows')) >= 0)
+ {
+ if ($row < $t->{Top})
+ {
+ $t->{Top} = $row;
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ elsif ($row >= $t->{Bottom})
+ {
+ $t->{Top} += ($row - $t->{Bottom}+1);
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ }
+ if (($col -= $t->cget('-fixedcolumns')) >= 0)
+ {
+ if ($col < $t->{Left})
+ {
+ $t->{Left} = $col;
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ elsif ($col >= $t->{Right})
+ {
+ $t->{Left} += ($col - $t->{Right}+1);
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ }
+ return $see;
+}
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Table.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Table.pod
new file mode 100755
index 00000000000..f73e93907b4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Table.pod
@@ -0,0 +1,97 @@
+
+=head1 NAME
+
+Tk::Table - Scrollable 2 dimensional table of Tk widgets
+
+=for pm Tk/Table.pm
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+ use Tk::Table;
+
+ $table = $parent->Table(-rows => number,
+ -columns => number,
+ -scrollbars => anchor,
+ -fixedrows => number,
+ -fixedcolumns => number,
+ -takefocus => boolean);
+
+ $widget = $table->Button(...);
+
+ $old = $table->put($row,$col,$widget);
+ $old = $table->put($row,$col,"Text"); # simple Label
+ $widget = $table->get($row,$col);
+
+ $cols = $table->totalColumns;
+ $rows = $table->totalRows;
+
+ $table->see($widget);
+ $table->see($row,$col);
+
+ ($row,$col) = $table->Posn($widget);
+
+=head1 DESCRIPTION
+
+Tk::Table is an all-perl widget/geometry manager which allows a two dimensional
+table of arbitary perl/Tk widgets to be displayed.
+
+Entries in the Table are simply ordinary perl/Tk widgets. They should
+be created with the Table as their parent. Widgets are positioned in the
+table using:
+
+ $table->put($row,$col,$widget)
+
+If I<$widget> is not a reference it is treated as a string, and
+a Lable widget is created with the string as its text.
+
+All the widgets in each column are set to the same width - the requested
+width of the widest widget in the column.
+Likewise, all the widgets in each row are set to the same height - the requested
+height of the tallest widget in the column.
+
+A number of rows and/or columns can be marked as 'fixed' - and so can serve
+as 'headings' for the remainder the rows which are scrollable.
+
+The requested size of the table as a whole is such that the number of rows
+specified by -rows (default 10), and number of columns specified by -columns
+(default 10) can be displayed.
+
+If the Table is told it can take the keyboard focus then cursor and scroll
+keys scroll the displayed widgets.
+
+The Table will create and manage its own scrollbars if requested via
+-scrollbars.
+
+The table can be emptied using
+
+ $table->clear
+
+the widgets which were in the table are destroyed.
+
+
+The Tk::Table widget is derived from a Tk::Frame, so inherits all its
+configure options.
+
+=head1 BUGS / Snags / Possible enhancements
+
+=over 4
+
+=item *
+
+Very large Tables consume a lot of X windows.
+
+=item *
+
+No equivalent of pack's -anchor/-pad etc. options
+
+=back
+
+=head1 SEE ALSO
+
+L<Tk::grid>, L<Tk::HList>, L<Tk::TableMatrix>, L<Tk::MListbox>,
+L<Tk::Columns>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Tcl-perl.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Tcl-perl.pod
new file mode 100755
index 00000000000..2310e0738e4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Tcl-perl.pod
@@ -0,0 +1,200 @@
+=head1 NAME
+
+Tcl vs perl - very old suspect documentation on porting.
+
+=for category Other Modules and Languages
+
+=head1 DESCRIPTION
+
+This isn't really a .pod yet, nor is it Tcl vs perl
+it is a copy of John's comparison of Malcolm's original perl/Tk
+port with the current one. It is also out-of-date in places.
+
+ From: john@WPI.EDU (John Stoffel )
+
+ Here are some thoughts on the new Tk extension and how I think the
+ organization of the commands looks. Mostly, I'm happy with it, it
+ makes some things more organized and more consistent with tcl/tk, but
+ since the overlying language is so different, I don't think we need to
+ follow exactly the tcl/tk model for how to call the language.
+
+ The basic structure of the Tk program is:
+
+ require Tk;
+
+ $top = MainWindow->new();
+
+ #
+ # create widgets
+ #
+
+ Tk::MainLoop;
+
+ sub method1 {
+ }
+
+ sub methodN {
+ }
+
+ This is pretty much the same as tkperl5a5, with some cosmetic naming
+ changes, and some more useful command name and usage changes. A quick
+ comparison in no particular order follows:
+
+ tkperl5a5 Tk
+ ------------------------------- -----------------------------------
+ $top=tkinit(name,display,sync); $top=MainWindow->new();
+
+ tkpack $w, ... ; $w->pack(...)
+
+ $w = Class::new($top, ...); $w = $top->Class(...);
+
+ tkmainloop; Tk::MainLoop;
+
+ tkbind($w,"<key>",sub); $w->bind("<key>",sub);
+
+ tkdelete($w, ...); $w->delete(...);
+
+ $w->scanmark(...); $w->scan("mark", ...);
+
+ $w->scandragto(...); $w->scan("dragto", ...);
+
+ $w->tkselect(); $w->Select();
+
+ $w->selectadjust(...); $w->selection("adjust", ...);
+
+ $w->selectto(...); $w->selection("to", ...);
+
+ $w->selectfrom(...); $w->selection("from", ...);
+
+ $w->tkindex(...); $w->index(...);
+
+ tclcmd("xxx",...); &Tk::xxx(...) # all Tk commands, but no Tcl at all
+
+ tclcmd("winfo", xxx, $w, ...); $w->xxx(...);
+
+ $w->mark(...);
+
+ $w->tag(...);
+
+ $w->grabstatus(); $w->grab("status");
+
+ $w->grabrelease(...); $w->grab("release", ...);
+
+ focus($w); $w->focus;
+
+ update(); Tk->update();
+
+ idletasks(); Tk->update("idletasks");
+
+ wm("cmd",$w, ...); $w->cmd(...);
+
+ destroy($w); $w->destroy();
+
+ Tk::option(...);
+ $w->OptionGet(name,Class)
+
+ $w->place(...)
+
+ Tk::property(...);
+
+ $w = Entry::new($parent,...)
+
+ is now
+
+ $w = $parent->Entry(...)
+
+ As this allows new to be inherited from a Window class.
+
+ -method=>x,-slave=>y
+
+ is now
+
+ -command => [x,y]
+
+ 1st element of list is treated as "method" if y is an object reference.
+ (You can have -command => [a,b,c,d,e] too; b..e get passed as args).
+
+ Object references are now hashes rather than scalars and there
+ is only ever one such per window. The Tcl_CmdInfo and PathName
+ are entries in the hash.
+
+ (This allows derived classes to
+ re-bless the hash and keep their on stuff in it too.)
+
+ Tk's "Tcl_Interp" is in fact a ref to "." window.
+ You can find all the Tk windows descended from it as their object
+ references get added (by PathName) into this hash.
+ $w->MainWindow returns this hash from any window.
+
+ I think that it should extend to multiple tkinits / Tk->news
+ with different Display's - if Tk code does.
+
+ Finally "bind" passes window as "extra" (or only)
+ argument. Thus
+
+ Tk::Button->bind(<Any-Enter>,"Enter");
+
+ Binds Enter events to Tk::Button::Enter by default
+ but gets called as $w->Enter so derived class of Button can just
+ define its own Enter method. &EvWref and associated globals and race
+ conditions are no longer needed.
+
+ One thing to beware of : commands bound to events with $widget->bind
+ follow same pattern, but get passed extra args :
+
+ $widget->bind(<Any-1>,[sub {print shift}, $one, $two ]);
+
+ When sub gets called it has :
+
+ $widget $one $two
+
+ passed.
+
+ 1st extra arg is reference to the per-widget hash that serves as the
+ perl object for the widget.
+
+ Every time an XEvent a reference to a special class is placed
+ in the widget hash. It can be retrieved by $w->XEvent method.
+
+ The methods of the XEvent class are the
+ Tcl/Tk % special characters.
+
+ Thus:
+
+ $widget->bind(<Any-KeyPress>,
+ sub {
+ my $w = shift;
+ my $e = $w->XEvent;
+ print $w->PathName," ",$e->A," pressed ,$e->xy,"\n");
+ });
+
+ XEvent->xy is a special case which returns "@" . $e->x . "," . $e->y
+ which is common in Text package.
+
+ Because of passing a blessed widget hash to "bound" subs they can be
+ bound to (possibly inherited) methods of the widget's class:
+
+ Class->bind(<Any-Down>,Down);
+
+ sub Class::Down
+ {
+ my $w = shift;
+ # handle down arrow
+ }
+
+ Also:
+
+ -command and friends can take a list the 1st element can be a ref to
+ as sub or a method name. Remaining elements are passed as args to the
+ sub at "invoke" time. Thus :
+
+ $b= $w->Button(blah blah, '-command' => [sub{print shift} , $fred ]);
+
+ Should do the trick, provided $fred is defined at time of button creation.
+
+ Thus 1st element of list is equivalent to Malcolm's -method and second
+ would be his -slave. Any further elements are a bonus and avoid
+ having to pass ref to an array/hash as a slave.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Text.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Text.pm
new file mode 100755
index 00000000000..171fcf1379c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Text.pm
@@ -0,0 +1,1662 @@
+# text.tcl --
+#
+# This file defines the default bindings for Tk text widgets.
+#
+# @(#) text.tcl 1.18 94/12/17 16:05:26
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# perl/Tk version:
+# Copyright (c) 1995-2004 Nick Ing-Simmons
+# Copyright (c) 1999 Greg London
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+package Tk::Text;
+use AutoLoader;
+use Carp;
+use strict;
+
+use Text::Tabs;
+
+use vars qw($VERSION);
+#$VERSION = sprintf '4.%03d', q$Revision: #24 $ =~ /\D(\d+)\s*$/;
+$VERSION = '4.026';
+
+use Tk qw(Ev $XS_VERSION);
+use base qw(Tk::Clipboard Tk::Widget);
+
+Construct Tk::Widget 'Text';
+
+bootstrap Tk::Text;
+
+sub Tk_cmd { \&Tk::text }
+
+sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) }
+
+Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump','edit',
+ 'get','image','index','insert','mark','scan','search',
+ 'see','tag','window','xview','yview');
+
+use Tk::Submethods ( 'mark' => [qw(gravity names next previous set unset)],
+ 'scan' => [qw(mark dragto)],
+ 'tag' => [qw(add bind cget configure delete lower
+ names nextrange prevrange raise ranges remove)],
+ 'window' => [qw(cget configure create names)],
+ 'image' => [qw(cget configure create names)],
+ 'xview' => [qw(moveto scroll)],
+ 'yview' => [qw(moveto scroll)],
+ 'edit' => [qw(modified redo reset separator undo)],
+ );
+
+sub Tag;
+sub Tags;
+
+sub bindRdOnly
+{
+
+ my ($class,$mw) = @_;
+
+ # Standard Motif bindings:
+ $mw->bind($class,'<Meta-B1-Motion>','NoOp');
+ $mw->bind($class,'<Meta-1>','NoOp');
+ $mw->bind($class,'<Alt-KeyPress>','NoOp');
+ $mw->bind($class,'<Escape>','unselectAll');
+
+ $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>','B1_Motion' ) ;
+ $mw->bind($class,'<B1-Leave>','B1_Leave' ) ;
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<ButtonRelease-1>','CancelRepeat');
+ $mw->bind($class,'<Control-1>',['markSet','insert',Ev('@')]);
+
+ $mw->bind($class,'<Double-1>','selectWord' ) ;
+ $mw->bind($class,'<Triple-1>','selectLine' ) ;
+ $mw->bind($class,'<Shift-1>','adjustSelect' ) ;
+ $mw->bind($class,'<Double-Shift-1>',['SelectTo',Ev('@'),'word']);
+ $mw->bind($class,'<Triple-Shift-1>',['SelectTo',Ev('@'),'line']);
+
+ $mw->bind($class,'<Left>',['SetCursor',Ev('index','insert-1c')]);
+ $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('index','insert-1c')]);
+ $mw->bind($class,'<Control-Left>',['SetCursor',Ev('index','insert-1c wordstart')]);
+ $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev('index','insert-1c wordstart')]);
+
+ $mw->bind($class,'<Right>',['SetCursor',Ev('index','insert+1c')]);
+ $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('index','insert+1c')]);
+ $mw->bind($class,'<Control-Right>',['SetCursor',Ev('index','insert+1c wordend')]);
+ $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev('index','insert wordend')]);
+
+ $mw->bind($class,'<Up>',['SetCursor',Ev('UpDownLine',-1)]);
+ $mw->bind($class,'<Shift-Up>',['KeySelect',Ev('UpDownLine',-1)]);
+ $mw->bind($class,'<Control-Up>',['SetCursor',Ev('PrevPara','insert')]);
+ $mw->bind($class,'<Shift-Control-Up>',['KeySelect',Ev('PrevPara','insert')]);
+
+ $mw->bind($class,'<Down>',['SetCursor',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Shift-Down>',['KeySelect',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Control-Down>',['SetCursor',Ev('NextPara','insert')]);
+ $mw->bind($class,'<Shift-Control-Down>',['KeySelect',Ev('NextPara','insert')]);
+
+ $mw->bind($class,'<Home>',['SetCursor','insert linestart']);
+ $mw->bind($class,'<Shift-Home>',['KeySelect','insert linestart']);
+ $mw->bind($class,'<Control-Home>',['SetCursor','1.0']);
+ $mw->bind($class,'<Control-Shift-Home>',['KeySelect','1.0']);
+
+ $mw->bind($class,'<End>',['SetCursor','insert lineend']);
+ $mw->bind($class,'<Shift-End>',['KeySelect','insert lineend']);
+ $mw->bind($class,'<Control-End>',['SetCursor','end-1char']);
+ $mw->bind($class,'<Control-Shift-End>',['KeySelect','end-1char']);
+
+ $mw->bind($class,'<Prior>',['SetCursor',Ev('ScrollPages',-1)]);
+ $mw->bind($class,'<Shift-Prior>',['KeySelect',Ev('ScrollPages',-1)]);
+ $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'page']);
+
+ $mw->bind($class,'<Next>',['SetCursor',Ev('ScrollPages',1)]);
+ $mw->bind($class,'<Shift-Next>',['KeySelect',Ev('ScrollPages',1)]);
+ $mw->bind($class,'<Control-Next>',['xview','scroll',1,'page']);
+
+ $mw->bind($class,'<Shift-Tab>', 'NoOp'); # Needed only to keep <Tab> binding from triggering; does not have to actually do anything.
+ $mw->bind($class,'<Control-Tab>','focusNext');
+ $mw->bind($class,'<Control-Shift-Tab>','focusPrev');
+
+ $mw->bind($class,'<Control-space>',['markSet','anchor','insert']);
+ $mw->bind($class,'<Select>',['markSet','anchor','insert']);
+ $mw->bind($class,'<Control-Shift-space>',['SelectTo','insert','char']);
+ $mw->bind($class,'<Shift-Select>',['SelectTo','insert','char']);
+ $mw->bind($class,'<Control-slash>','selectAll');
+ $mw->bind($class,'<Control-backslash>','unselectAll');
+
+ if (!$Tk::strictMotif)
+ {
+ $mw->bind($class,'<Control-a>', ['SetCursor','insert linestart']);
+ $mw->bind($class,'<Control-b>', ['SetCursor','insert-1c']);
+ $mw->bind($class,'<Control-e>', ['SetCursor','insert lineend']);
+ $mw->bind($class,'<Control-f>', ['SetCursor','insert+1c']);
+ $mw->bind($class,'<Meta-b>', ['SetCursor','insert-1c wordstart']);
+ $mw->bind($class,'<Meta-f>', ['SetCursor','insert wordend']);
+ $mw->bind($class,'<Meta-less>', ['SetCursor','1.0']);
+ $mw->bind($class,'<Meta-greater>', ['SetCursor','end-1c']);
+
+ $mw->bind($class,'<Control-n>', ['SetCursor',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Control-p>', ['SetCursor',Ev('UpDownLine',-1)]);
+
+ $mw->bind($class,'<2>',['Button2',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['Motion2',Ev('x'),Ev('y')]);
+ }
+ $mw->bind($class,'<Destroy>','Destroy');
+ $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')] );
+ $mw->YMouseWheelBind($class);
+ $mw->XMouseWheelBind($class);
+
+ $mw->MouseWheelBind($class);
+
+ return $class;
+}
+
+sub selectAll
+{
+ my ($w) = @_;
+ $w->tagAdd('sel','1.0','end');
+}
+
+sub unselectAll
+{
+ my ($w) = @_;
+ $w->tagRemove('sel','1.0','end');
+}
+
+sub adjustSelect
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->ResetAnchor($Ev->xy);
+ $w->SelectTo($Ev->xy,'char')
+}
+
+sub selectLine
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->SelectTo($Ev->xy,'line');
+ Tk::catch { $w->markSet('insert','sel.first') };
+}
+
+sub selectWord
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->SelectTo($Ev->xy,'word');
+ Tk::catch { $w->markSet('insert','sel.first') }
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $class->bindRdOnly($mw);
+
+ $mw->bind($class,'<Tab>', 'insertTab');
+ $mw->bind($class,'<Control-i>', ['Insert',"\t"]);
+ $mw->bind($class,'<Return>', ['Insert',"\n"]);
+ $mw->bind($class,'<Delete>','Delete');
+ $mw->bind($class,'<BackSpace>','Backspace');
+ $mw->bind($class,'<Insert>', \&ToggleInsertMode ) ;
+ $mw->bind($class,'<KeyPress>',['InsertKeypress',Ev('A')]);
+
+ $mw->bind($class,'<F1>', 'clipboardColumnCopy');
+ $mw->bind($class,'<F2>', 'clipboardColumnCut');
+ $mw->bind($class,'<F3>', 'clipboardColumnPaste');
+
+ # Additional emacs-like bindings:
+
+ if (!$Tk::strictMotif)
+ {
+ $mw->bind($class,'<Control-d>',['delete','insert']);
+ $mw->bind($class,'<Control-k>','deleteToEndofLine') ;
+ $mw->bind($class,'<Control-o>','openLine');
+ $mw->bind($class,'<Control-t>','Transpose');
+ $mw->bind($class,'<Meta-d>',['delete','insert','insert wordend']);
+ $mw->bind($class,'<Meta-BackSpace>',['delete','insert-1c wordstart','insert']);
+
+ # A few additional bindings of my own.
+ $mw->bind($class,'<Control-h>','deleteBefore');
+ $mw->bind($class,'<ButtonRelease-2>','ButtonRelease2');
+ }
+#JD# $Tk::prevPos = undef;
+ return $class;
+}
+
+sub insertTab
+{
+ my ($w) = @_;
+ $w->Insert("\t");
+ $w->focus;
+ $w->break
+}
+
+sub deleteToEndofLine
+{
+ my ($w) = @_;
+ if ($w->compare('insert','==','insert lineend'))
+ {
+ $w->delete('insert')
+ }
+ else
+ {
+ $w->delete('insert','insert lineend')
+ }
+}
+
+sub openLine
+{
+ my ($w) = @_;
+ $w->insert('insert',"\n");
+ $w->markSet('insert','insert-1c')
+}
+
+sub Button2
+{
+ my ($w,$x,$y) = @_;
+ $w->scan('mark',$x,$y);
+ $Tk::x = $x;
+ $Tk::y = $y;
+ $Tk::mouseMoved = 0;
+}
+
+sub Motion2
+{
+ my ($w,$x,$y) = @_;
+ $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y);
+ $w->scan('dragto',$x,$y) if ($Tk::mouseMoved);
+}
+
+sub ButtonRelease2
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ if (!$Tk::mouseMoved)
+ {
+ Tk::catch
+ {
+ $w->mark('set','insert',$Ev->xy);
+ $w->insert($Ev->xy,$w->SelectionGet);
+ $w->focus if ($w->cget('-state') eq "normal");
+ }
+ }
+}
+
+sub InsertSelection
+{
+ my ($w) = @_;
+ Tk::catch { $w->Insert($w->SelectionGet) }
+}
+
+sub Backspace
+{
+ my ($w) = @_;
+ my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
+ if (defined $sel)
+ {
+ $w->delete('sel.first','sel.last');
+ return;
+ }
+ $w->deleteBefore;
+}
+
+sub deleteBefore
+{
+ my ($w) = @_;
+ if ($w->compare('insert','!=','1.0'))
+ {
+ $w->delete('insert-1c');
+ $w->see('insert')
+ }
+}
+
+sub Delete
+{
+ my ($w) = @_;
+ my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
+ if (defined $sel)
+ {
+ $w->delete('sel.first','sel.last')
+ }
+ else
+ {
+ $w->delete('insert');
+ $w->see('insert')
+ }
+}
+
+# Button1 --
+# This procedure is invoked to handle button-1 presses in text
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The text window in which the button was pressed.
+# x - The x-coordinate of the button press.
+# y - The x-coordinate of the button press.
+sub Button1
+{
+ my ($w,$x,$y) = @_;
+ $Tk::selectMode = 'char';
+ $Tk::mouseMoved = 0;
+ $w->SetCursor('@'.$x.','.$y);
+ $w->markSet('anchor','insert');
+ $w->focus() if ($w->cget('-state') eq 'normal');
+}
+
+sub B1_Motion
+{
+ my ($w) = @_;
+ return unless defined $Tk::mouseMoved;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $w->SelectTo($Ev->xy)
+}
+
+sub B1_Leave
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $w->AutoScan;
+}
+
+# SelectTo --
+# This procedure is invoked to extend the selection, typically when
+# dragging it with the mouse. Depending on the selection mode (character,
+# word, line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The text window in which the button was pressed.
+# index - Index of character at which the mouse button was pressed.
+sub SelectTo
+{
+ my ($w, $index, $mode)= @_;
+ $Tk::selectMode = $mode if defined ($mode);
+ my $cur = $w->index($index);
+ my $anchor = Tk::catch { $w->index('anchor') };
+ if (!defined $anchor)
+ {
+ $w->markSet('anchor',$anchor = $cur);
+ $Tk::mouseMoved = 0;
+ }
+ elsif ($w->compare($cur,'!=',$anchor))
+ {
+ $Tk::mouseMoved = 1;
+ }
+ $Tk::selectMode = 'char' unless (defined $Tk::selectMode);
+ $mode = $Tk::selectMode;
+ my ($first,$last);
+ if ($mode eq 'char')
+ {
+ if ($w->compare($cur,'<','anchor'))
+ {
+ $first = $cur;
+ $last = 'anchor';
+ }
+ else
+ {
+ $first = 'anchor';
+ $last = $cur
+ }
+ }
+ elsif ($mode eq 'word')
+ {
+ if ($w->compare($cur,'<','anchor'))
+ {
+ $first = $w->index("$cur wordstart");
+ $last = $w->index('anchor - 1c wordend')
+ }
+ else
+ {
+ $first = $w->index('anchor wordstart');
+ $last = $w->index("$cur wordend")
+ }
+ }
+ elsif ($mode eq 'line')
+ {
+ if ($w->compare($cur,'<','anchor'))
+ {
+ $first = $w->index("$cur linestart");
+ $last = $w->index('anchor - 1c lineend + 1c')
+ }
+ else
+ {
+ $first = $w->index('anchor linestart');
+ $last = $w->index("$cur lineend + 1c")
+ }
+ }
+ if ($Tk::mouseMoved || $Tk::selectMode ne 'char')
+ {
+ $w->tagRemove('sel','1.0',$first);
+ $w->tagAdd('sel',$first,$last);
+ $w->tagRemove('sel',$last,'end');
+ $w->idletasks;
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves a text window
+# with button 1 down. It scrolls the window up, down, left, or right,
+# depending on where the mouse is (this information was saved in
+# tkPriv(x) and tkPriv(y)), and reschedules itself as an 'after'
+# command so that the window continues to scroll until the mouse
+# moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The text window.
+sub AutoScan
+{
+ my ($w) = @_;
+ if ($Tk::y >= $w->height)
+ {
+ $w->yview('scroll',2,'units')
+ }
+ elsif ($Tk::y < 0)
+ {
+ $w->yview('scroll',-2,'units')
+ }
+ elsif ($Tk::x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($Tk::x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->SelectTo('@' . $Tk::x . ','. $Tk::y);
+ $w->RepeatId($w->after(50,['AutoScan',$w]));
+}
+# SetCursor
+# Move the insertion cursor to a given position in a text. Also
+# clears the selection, if there is one in the text, and makes sure
+# that the insertion cursor is visible.
+#
+# Arguments:
+# w - The text window.
+# pos - The desired new position for the cursor in the window.
+sub SetCursor
+{
+ my ($w,$pos) = @_;
+ $pos = 'end - 1 chars' if $w->compare($pos,'==','end');
+ $w->markSet('insert',$pos);
+ $w->unselectAll;
+ $w->see('insert');
+}
+# KeySelect
+# This procedure is invoked when stroking out selections using the
+# keyboard. It moves the cursor to a new position, then extends
+# the selection to that position.
+#
+# Arguments:
+# w - The text window.
+# new - A new position for the insertion cursor (the cursor has not
+# actually been moved to this position yet).
+sub KeySelect
+{
+ my ($w,$new) = @_;
+ my ($first,$last);
+ if (!defined $w->tag('ranges','sel'))
+ {
+ # No selection yet
+ $w->markSet('anchor','insert');
+ if ($w->compare($new,'<','insert'))
+ {
+ $w->tagAdd('sel',$new,'insert')
+ }
+ else
+ {
+ $w->tagAdd('sel','insert',$new)
+ }
+ }
+ else
+ {
+ # Selection exists
+ if ($w->compare($new,'<','anchor'))
+ {
+ $first = $new;
+ $last = 'anchor'
+ }
+ else
+ {
+ $first = 'anchor';
+ $last = $new
+ }
+ $w->tagRemove('sel','1.0',$first);
+ $w->tagAdd('sel',$first,$last);
+ $w->tagRemove('sel',$last,'end')
+ }
+ $w->markSet('insert',$new);
+ $w->see('insert');
+ $w->idletasks;
+}
+# ResetAnchor --
+# Set the selection anchor to whichever end is farthest from the
+# index argument. One special trick: if the selection has two or
+# fewer characters, just leave the anchor where it is. In this
+# case it does not matter which point gets chosen for the anchor,
+# and for the things like Shift-Left and Shift-Right this produces
+# better behavior when the cursor moves back and forth across the
+# anchor.
+#
+# Arguments:
+# w - The text widget.
+# index - Position at which mouse button was pressed, which determines
+# which end of selection should be used as anchor point.
+sub ResetAnchor
+{
+ my ($w,$index) = @_;
+ if (!defined $w->tag('ranges','sel'))
+ {
+ $w->markSet('anchor',$index);
+ return;
+ }
+ my $a = $w->index($index);
+ my $b = $w->index('sel.first');
+ my $c = $w->index('sel.last');
+ if ($w->compare($a,'<',$b))
+ {
+ $w->markSet('anchor','sel.last');
+ return;
+ }
+ if ($w->compare($a,'>',$c))
+ {
+ $w->markSet('anchor','sel.first');
+ return;
+ }
+ my ($lineA,$chA) = split(/\./,$a);
+ my ($lineB,$chB) = split(/\./,$b);
+ my ($lineC,$chC) = split(/\./,$c);
+ if ($lineB < $lineC+2)
+ {
+ my $total = length($w->get($b,$c));
+ if ($total <= 2)
+ {
+ return;
+ }
+ if (length($w->get($b,$a)) < $total/2)
+ {
+ $w->markSet('anchor','sel.last')
+ }
+ else
+ {
+ $w->markSet('anchor','sel.first')
+ }
+ return;
+ }
+ if ($lineA-$lineB < $lineC-$lineA)
+ {
+ $w->markSet('anchor','sel.last')
+ }
+ else
+ {
+ $w->markSet('anchor','sel.first')
+ }
+}
+
+########################################################################
+sub markExists
+{
+ my ($w, $markname)=@_;
+ my $mark_exists=0;
+ my @markNames_list = $w->markNames;
+ foreach my $mark (@markNames_list)
+ { if ($markname eq $mark) {$mark_exists=1;last;} }
+ return $mark_exists;
+}
+
+########################################################################
+sub OverstrikeMode
+{
+ my ($w,$mode) = @_;
+
+ $w->{'OVERSTRIKE_MODE'} =0 unless exists($w->{'OVERSTRIKE_MODE'});
+
+ $w->{'OVERSTRIKE_MODE'}=$mode if (@_ > 1);
+
+ return $w->{'OVERSTRIKE_MODE'};
+}
+
+########################################################################
+# pressed the <Insert> key, just above 'Del' key.
+# this toggles between insert mode and overstrike mode.
+sub ToggleInsertMode
+{
+ my ($w)=@_;
+ $w->OverstrikeMode(!$w->OverstrikeMode);
+}
+
+########################################################################
+sub InsertKeypress
+{
+ my ($w,$char)=@_;
+ return unless length($char);
+ if ($w->OverstrikeMode)
+ {
+ my $current=$w->get('insert');
+ $w->delete('insert') unless($current eq "\n");
+ }
+ $w->Insert($char);
+}
+
+########################################################################
+sub GotoLineNumber
+{
+ my ($w,$line_number) = @_;
+ $line_number=~ s/^\s+|\s+$//g;
+ return if $line_number =~ m/\D/;
+ my ($last_line,$junk) = split(/\./, $w->index('end'));
+ if ($line_number > $last_line) {$line_number = $last_line; }
+ $w->{'LAST_GOTO_LINE'} = $line_number;
+ $w->markSet('insert', $line_number.'.0');
+ $w->see('insert');
+}
+
+########################################################################
+sub GotoLineNumberPopUp
+{
+ my ($w)=@_;
+ my $popup = $w->{'GOTO_LINE_NUMBER_POPUP'};
+
+ unless (defined($w->{'LAST_GOTO_LINE'}))
+ {
+ my ($line,$col) = split(/\./, $w->index('insert'));
+ $w->{'LAST_GOTO_LINE'} = $line;
+ }
+
+ ## if anything is selected when bring up the pop-up, put it in entry window.
+ my $selected;
+ eval { $selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ unless ($@)
+ {
+ if (defined($selected) and length($selected))
+ {
+ unless ($selected =~ /\D/)
+ {
+ $w->{'LAST_GOTO_LINE'} = $selected;
+ }
+ }
+ }
+ unless (defined($popup))
+ {
+ require Tk::DialogBox;
+ $popup = $w->DialogBox(-buttons => [qw[Ok Cancel]],-title => "Goto Line Number", -popover => $w,
+ -command => sub { $w->GotoLineNumber($w->{'LAST_GOTO_LINE'}) if $_[0] eq 'Ok'});
+ $w->{'GOTO_LINE_NUMBER_POPUP'}=$popup;
+ $popup->resizable('no','no');
+ my $frame = $popup->Frame->pack(-fill => 'x');
+ $frame->Label(-text=>'Enter line number: ')->pack(-side => 'left');
+ my $entry = $frame->Entry(-background=>'white', -width=>25,
+ -textvariable => \$w->{'LAST_GOTO_LINE'})->pack(-side =>'left',-fill => 'x');
+ $popup->Advertise(entry => $entry);
+ }
+ $popup->Popup;
+ $popup->Subwidget('entry')->focus;
+ $popup->Wait;
+}
+
+########################################################################
+
+sub getSelected
+{
+ shift->GetTextTaggedWith('sel');
+}
+
+sub deleteSelected
+{
+ shift->DeleteTextTaggedWith('sel');
+}
+
+sub GetTextTaggedWith
+{
+ my ($w,$tag) = @_;
+
+ my @ranges = $w->tagRanges($tag);
+ my $range_total = @ranges;
+ my $return_text='';
+
+ # if nothing selected, then ignore
+ if ($range_total == 0) {return $return_text;}
+
+ # for every range-pair, get selected text
+ while(@ranges)
+ {
+ my $first = shift(@ranges);
+ my $last = shift(@ranges);
+ my $text = $w->get($first , $last);
+ if(defined($text))
+ {$return_text = $return_text . $text;}
+ # if there is more tagged text, separate with an end of line character
+ if(@ranges)
+ {$return_text = $return_text . "\n";}
+ }
+ return $return_text;
+}
+
+########################################################################
+sub DeleteTextTaggedWith
+{
+ my ($w,$tag) = @_;
+ my @ranges = $w->tagRanges($tag);
+ my $range_total = @ranges;
+
+ # if nothing tagged with that tag, then ignore
+ if ($range_total == 0) {return;}
+
+ # insert marks where selections are located
+ # marks will move with text even as text is inserted and deleted
+ # in a previous selection.
+ for (my $i=0; $i<$range_total; $i++)
+ { $w->markSet('mark_tag_'.$i => $ranges[$i]); }
+
+ # for every selected mark pair, insert new text and delete old text
+ for (my $i=0; $i<$range_total; $i=$i+2)
+ {
+ my $first = $w->index('mark_tag_'.$i);
+ my $last = $w->index('mark_tag_'.($i+1));
+
+ my $text = $w->delete($first , $last);
+ }
+
+ # delete the marks
+ for (my $i=0; $i<$range_total; $i++)
+ { $w->markUnset('mark_tag_'.$i); }
+}
+
+
+########################################################################
+sub FindAll
+{
+ my ($w,$mode, $case, $pattern ) = @_;
+ ### 'sel' tags accumulate, need to remove any previous existing
+ $w->unselectAll;
+
+ my $match_length=0;
+ my $start_index;
+ my $end_index = '1.0';
+
+ while(defined($end_index))
+ {
+ if ($case eq '-nocase')
+ {
+ $start_index = $w->search(
+ $mode,
+ $case,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ $end_index,
+ 'end');
+ }
+ else
+ {
+ $start_index = $w->search(
+ $mode,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ $end_index,
+ 'end');
+ }
+
+ unless(defined($start_index) && $start_index) {last;}
+
+ my ($line,$col) = split(/\./, $start_index);
+ $col = $col + $match_length;
+ $end_index = $line.'.'.$col;
+ $w->tagAdd('sel', $start_index, $end_index);
+ }
+}
+
+########################################################################
+# get current selected text and search for the next occurrence
+sub FindSelectionNext
+{
+ my ($w) = @_;
+ my $selected;
+ eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ return if($@);
+ return unless (defined($selected) and length($selected));
+
+ $w->FindNext('-forward', '-exact', '-case', $selected);
+}
+
+########################################################################
+# get current selected text and search for the previous occurrence
+sub FindSelectionPrevious
+{
+ my ($w) = @_;
+ my $selected;
+ eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ return if($@);
+ return unless (defined($selected) and length($selected));
+
+ $w->FindNext('-backward', '-exact', '-case', $selected);
+}
+
+
+
+########################################################################
+sub FindNext
+{
+ my ($w,$direction, $mode, $case, $pattern ) = @_;
+
+ ## if searching forward, start search at end of selected block
+ ## if backward, start search from start of selected block.
+ ## dont want search to find currently selected text.
+ ## tag 'sel' may not be defined, use eval loop to trap error
+ eval {
+ if ($direction eq '-forward')
+ {
+ $w->markSet('insert', 'sel.last');
+ $w->markSet('current', 'sel.last');
+ }
+ else
+ {
+ $w->markSet('insert', 'sel.first');
+ $w->markSet('current', 'sel.first');
+ }
+ };
+
+ my $saved_index=$w->index('insert');
+
+ # remove any previous existing tags
+ $w->unselectAll;
+
+ my $match_length=0;
+ my $start_index;
+
+ if ($case eq '-nocase')
+ {
+ $start_index = $w->search(
+ $direction,
+ $mode,
+ $case,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ 'insert');
+ }
+ else
+ {
+ $start_index = $w->search(
+ $direction,
+ $mode,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ 'insert');
+ }
+
+ unless(defined($start_index)) { return 0; }
+ if(length($start_index) == 0) { return 0; }
+
+ my ($line,$col) = split(/\./, $start_index);
+ $col = $col + $match_length;
+ my $end_index = $line.'.'.$col;
+ $w->tagAdd('sel', $start_index, $end_index);
+
+ $w->see($start_index);
+
+ if ($direction eq '-forward')
+ {
+ $w->markSet('insert', $end_index);
+ $w->markSet('current', $end_index);
+ }
+ else
+ {
+ $w->markSet('insert', $start_index);
+ $w->markSet('current', $start_index);
+ }
+
+ my $compared_index = $w->index('insert');
+
+ my $ret_val;
+ if ($compared_index eq $saved_index)
+ {$ret_val=0;}
+ else
+ {$ret_val=1;}
+ return $ret_val;
+}
+
+########################################################################
+sub FindAndReplaceAll
+{
+ my ($w,$mode, $case, $find, $replace ) = @_;
+ $w->markSet('insert', '1.0');
+ $w->unselectAll;
+ while($w->FindNext('-forward', $mode, $case, $find))
+ {
+ $w->ReplaceSelectionsWith($replace);
+ }
+}
+
+########################################################################
+sub ReplaceSelectionsWith
+{
+ my ($w,$new_text ) = @_;
+
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+
+ # if nothing selected, then ignore
+ if ($range_total == 0) {return};
+
+ # insert marks where selections are located
+ # marks will move with text even as text is inserted and deleted
+ # in a previous selection.
+ for (my $i=0; $i<$range_total; $i++)
+ {$w->markSet('mark_sel_'.$i => $ranges[$i]); }
+
+ # for every selected mark pair, insert new text and delete old text
+ my ($first, $last);
+ for (my $i=0; $i<$range_total; $i=$i+2)
+ {
+ $first = $w->index('mark_sel_'.$i);
+ $last = $w->index('mark_sel_'.($i+1));
+
+ ##########################################################################
+ # eventually, want to be able to get selected text,
+ # support regular expression matching, determine replace_text
+ # $replace_text = $selected_text=~m/$new_text/ (or whatever would work)
+ # will have to pass in mode and case flags.
+ # this would allow a regular expression search and replace to be performed
+ # example, look for "line (\d+):" and replace with "$1 >" or similar
+ ##########################################################################
+
+ $w->insert($last, $new_text);
+ $w->delete($first, $last);
+
+ }
+ ############################################################
+ # set the insert cursor to the end of the last insertion mark
+ $w->markSet('insert',$w->index('mark_sel_'.($range_total-1)));
+
+ # delete the marks
+ for (my $i=0; $i<$range_total; $i++)
+ { $w->markUnset('mark_sel_'.$i); }
+}
+########################################################################
+sub FindAndReplacePopUp
+{
+ my ($w)=@_;
+ $w->findandreplacepopup(0);
+}
+
+########################################################################
+sub FindPopUp
+{
+ my ($w)=@_;
+ $w->findandreplacepopup(1);
+}
+
+########################################################################
+
+sub findandreplacepopup
+{
+ my ($w,$find_only)=@_;
+
+ my $pop = $w->Toplevel;
+ $pop->transient($w->toplevel);
+ if ($find_only)
+ { $pop->title("Find"); }
+ else
+ { $pop->title("Find and/or Replace"); }
+ my $frame = $pop->Frame->pack(-anchor=>'nw');
+
+ $frame->Label(-text=>"Direction:")
+ ->grid(-row=> 1, -column=>1, -padx=> 20, -sticky => 'nw');
+ my $direction = '-forward';
+ $frame->Radiobutton(
+ -variable => \$direction,
+ -text => 'forward',-value => '-forward' )
+ ->grid(-row=> 2, -column=>1, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+ -variable => \$direction,
+ -text => 'backward',-value => '-backward' )
+ ->grid(-row=> 3, -column=>1, -padx=> 20, -sticky => 'nw');
+
+ $frame->Label(-text=>"Mode:")
+ ->grid(-row=> 1, -column=>2, -padx=> 20, -sticky => 'nw');
+ my $mode = '-exact';
+ $frame->Radiobutton(
+ -variable => \$mode, -text => 'exact',-value => '-exact' )
+ ->grid(-row=> 2, -column=>2, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+ -variable => \$mode, -text => 'regexp',-value => '-regexp' )
+ ->grid(-row=> 3, -column=>2, -padx=> 20, -sticky => 'nw');
+
+ $frame->Label(-text=>"Case:")
+ ->grid(-row=> 1, -column=>3, -padx=> 20, -sticky => 'nw');
+ my $case = '-case';
+ $frame->Radiobutton(
+ -variable => \$case, -text => 'case',-value => '-case' )
+ ->grid(-row=> 2, -column=>3, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+ -variable => \$case, -text => 'nocase',-value => '-nocase' )
+ ->grid(-row=> 3, -column=>3, -padx=> 20, -sticky => 'nw');
+
+ ######################################################
+ my $find_entry = $pop->Entry(-width=>25);
+ $find_entry->focus;
+
+ my $donext = sub {$w->FindNext ($direction,$mode,$case,$find_entry->get())};
+
+ $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing
+
+ ###### if any $w text is selected, put it in the find entry
+ ###### could be more than one text block selected, get first selection
+ my @ranges = $w->tagRanges('sel');
+ if (@ranges)
+ {
+ my $first = shift(@ranges);
+ my $last = shift(@ranges);
+
+ # limit to one line
+ my ($first_line, $first_col) = split(/\./,$first);
+ my ($last_line, $last_col) = split(/\./,$last);
+ unless($first_line == $last_line)
+ {$last = $first. ' lineend';}
+
+ $find_entry->insert('insert', $w->get($first , $last));
+ }
+ else
+ {
+ my $selected;
+ eval {$selected=$w->SelectionGet(-selection => "PRIMARY"); };
+ if($@) {}
+ elsif (defined($selected))
+ {$find_entry->insert('insert', $selected);}
+ }
+
+ $find_entry->icursor(0);
+
+ my ($replace_entry,$button_replace,$button_replace_all);
+ unless ($find_only)
+ {
+ $replace_entry = $pop->Entry(-width=>25);
+
+ $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x');
+ }
+
+
+ my $button_find = $pop->Button(-text=>'Find', -command => $donext, -default => 'active')
+ -> pack(-side => 'left');
+
+ my $button_find_all = $pop->Button(-text=>'Find All',
+ -command => sub {$w->FindAll($mode,$case,$find_entry->get());} )
+ ->pack(-side => 'left');
+
+ unless ($find_only)
+ {
+ $button_replace = $pop->Button(-text=>'Replace', -default => 'normal',
+ -command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} )
+ -> pack(-side =>'left');
+ $button_replace_all = $pop->Button(-text=>'Replace All',
+ -command => sub {$w->FindAndReplaceAll
+ ($mode,$case,$find_entry->get(),$replace_entry->get());} )
+ ->pack(-side => 'left');
+ }
+
+
+ my $button_cancel = $pop->Button(-text=>'Cancel',
+ -command => sub {$pop->destroy()} )
+ ->pack(-side => 'left');
+
+ $find_entry->bind("<Return>" => [$button_find, 'invoke']);
+ $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
+
+ $find_entry->bind("<Return>" => [$button_find, 'invoke']);
+ $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
+
+ $pop->resizable('yes','no');
+ return $pop;
+}
+
+# paste clipboard into current location
+sub clipboardPaste
+{
+ my ($w) = @_;
+ local $@;
+ Tk::catch { $w->Insert($w->clipboardGet) };
+}
+
+########################################################################
+# Insert --
+# Insert a string into a text at the point of the insertion cursor.
+# If there is a selection in the text, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.
+#
+# Arguments:
+# w - The text window in which to insert the string
+# string - The string to insert (usually just a single character)
+sub Insert
+{
+ my ($w,$string) = @_;
+ return unless (defined $string && $string ne '');
+ #figure out if cursor is inside a selection
+ my @ranges = $w->tagRanges('sel');
+ if (@ranges)
+ {
+ while (@ranges)
+ {
+ my ($first,$last) = splice(@ranges,0,2);
+ if ($w->compare($first,'<=','insert') && $w->compare($last,'>=','insert'))
+ {
+ $w->ReplaceSelectionsWith($string);
+ return;
+ }
+ }
+ }
+ # paste it at the current cursor location
+ $w->insert('insert',$string);
+ $w->see('insert');
+}
+
+# UpDownLine --
+# Returns the index of the character one *display* line above or below the
+# insertion cursor. There are two tricky things here. First,
+# we want to maintain the original column across repeated operations,
+# even though some lines that will get passed through do not have
+# enough characters to cover the original column. Second, do not
+# try to scroll past the beginning or end of the text.
+#
+# This may have some weirdness associated with a proportional font. Ie.
+# the insertion cursor will zigzag up or down according to the width of
+# the character at destination.
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# n - The number of lines to move: -1 for up one line,
+# +1 for down one line.
+sub UpDownLine
+{
+ my ($w,$n) = @_;
+ $w->see('insert');
+ my $i = $w->index('insert');
+
+ my ($line,$char) = split(/\./,$i);
+
+ my $testX; #used to check the "new" position
+ my $testY; #used to check the "new" position
+
+ (my $bx, my $by, my $bw, my $bh) = $w->bbox($i);
+ (my $lx, my $ly, my $lw, my $lh) = $w->dlineinfo($i);
+
+ if ( ($n == -1) and ($by <= $bh) )
+ {
+ #On first display line.. so scroll up and recalculate..
+ $w->yview('scroll', -1, 'units');
+ unless (($w->yview)[0]) {
+ #first line of entire text - keep same position.
+ return $i;
+ }
+ ($bx, $by, $bw, $bh) = $w->bbox($i);
+ ($lx, $ly, $lw, $lh) = $w->dlineinfo($i);
+ }
+ elsif ( ($n == 1) and
+ ($ly + $lh) > ( $w->height - 2*$w->cget(-bd) - 2*$w->cget(-highlightthickness) ) )
+ {
+ #On last display line.. so scroll down and recalculate..
+ $w->yview('scroll', 1, 'units');
+ ($bx, $by, $bw, $bh) = $w->bbox($i);
+ ($lx, $ly, $lw, $lh) = $w->dlineinfo($i);
+ }
+
+ # Calculate the vertical position of the next display line
+ my $Yoffset = 0;
+ $Yoffset = $by - $ly + 1 if ($n== -1);
+ $Yoffset = $ly + $lh + 1 - $by if ($n == 1);
+ $Yoffset*=$n;
+ $testY = $by + $Yoffset;
+
+ # Save the original 'x' position of the insert cursor if:
+ # 1. This is the first time through -- or --
+ # 2. The insert cursor position has changed from the previous
+ # time the up or down key was pressed -- or --
+ # 3. The cursor has reached the beginning or end of the widget.
+
+ {
+ no warnings 'uninitialized';
+ if (not defined $w->{'origx'} or ($w->{'lastindex'} != $i) )
+ {
+ $w->{'origx'} = $bx;
+ }
+ }
+
+ # Try to keep the same column if possible
+ $testX = $w->{'origx'};
+
+ # Get the coordinates of the possible new position
+ my $testindex = $w->index('@'.$testX.','.$testY );
+ $w->see($testindex);
+ my ($nx,$ny,$nw,$nh) = $w->bbox($testindex);
+
+ # Which side of the character should we position the cursor -
+ # mainly for a proportional font
+ if ($testX > $nx+$nw/2)
+ {
+ $testX = $nx+$nw+1;
+ }
+
+ my $newindex = $w->index('@'.$testX.','.$testY );
+
+ if ( $w->compare($newindex,'==','end - 1 char') and ($ny == $ly ) )
+ {
+ # Then we are trying to the 'end' of the text from
+ # the same display line - don't do that
+ return $i;
+ }
+
+ $w->{'lastindex'} = $newindex;
+ $w->see($newindex);
+ return $newindex;
+}
+
+# PrevPara --
+# Returns the index of the beginning of the paragraph just before a given
+# position in the text (the beginning of a paragraph is the first non-blank
+# character after a blank line).
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# pos - Position at which to start search.
+sub PrevPara
+{
+ my ($w,$pos) = @_;
+ $pos = $w->index("$pos linestart");
+ while (1)
+ {
+ if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq '1.0' )
+ {
+ my $string = $w->get($pos,"$pos lineend");
+ if ($string =~ /^(\s)+/)
+ {
+ my $off = length($1);
+ $pos = $w->index("$pos + $off chars")
+ }
+ if ($w->compare($pos,'!=','insert') || $pos eq '1.0')
+ {
+ return $pos;
+ }
+ }
+ $pos = $w->index("$pos - 1 line")
+ }
+}
+# NextPara --
+# Returns the index of the beginning of the paragraph just after a given
+# position in the text (the beginning of a paragraph is the first non-blank
+# character after a blank line).
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# start - Position at which to start search.
+sub NextPara
+{
+ my ($w,$start) = @_;
+ my $pos = $w->index("$start linestart + 1 line");
+ while ($w->get($pos) ne "\n")
+ {
+ if ($w->compare($pos,'==','end'))
+ {
+ return $w->index('end - 1c');
+ }
+ $pos = $w->index("$pos + 1 line")
+ }
+ while ($w->get($pos) eq "\n" )
+ {
+ $pos = $w->index("$pos + 1 line");
+ if ($w->compare($pos,'==','end'))
+ {
+ return $w->index('end - 1c');
+ }
+ }
+ my $string = $w->get($pos,"$pos lineend");
+ if ($string =~ /^(\s+)/)
+ {
+ my $off = length($1);
+ return $w->index("$pos + $off chars");
+ }
+ return $pos;
+}
+# ScrollPages --
+# This is a utility procedure used in bindings for moving up and down
+# pages and possibly extending the selection along the way. It scrolls
+# the view in the widget by the number of pages, and it returns the
+# index of the character that is at the same position in the new view
+# as the insertion cursor used to be in the old view.
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# count - Number of pages forward to scroll; may be negative
+# to scroll backwards.
+sub ScrollPages
+{
+ my ($w,$count) = @_;
+ my @bbox = $w->bbox('insert');
+ $w->yview('scroll',$count,'pages');
+ if (!@bbox)
+ {
+ return $w->index('@' . int($w->height/2) . ',' . 0);
+ }
+ my $x = int($bbox[0]+$bbox[2]/2);
+ my $y = int($bbox[1]+$bbox[3]/2);
+ return $w->index('@' . $x . ',' . $y);
+}
+
+sub Contents
+{
+ my $w = shift;
+ if (@_)
+ {
+ $w->delete('1.0','end');
+ $w->insert('end',shift) while (@_);
+ }
+ else
+ {
+ return $w->get('1.0','end');
+ }
+}
+
+sub Destroy
+{
+ my ($w) = @_;
+ delete $w->{_Tags_};
+}
+
+sub Transpose
+{
+ my ($w) = @_;
+ my $pos = 'insert';
+ $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend"));
+ return if ($w->compare("$pos - 1 char",'==','1.0'));
+ my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char");
+ $w->delete("$pos - 2 char",$pos);
+ $w->insert('insert',$new);
+ $w->see('insert');
+}
+
+sub Tag
+{
+ my $w = shift;
+ my $name = shift;
+ Carp::confess('No args') unless (ref $w and defined $name);
+ $w->{_Tags_} = {} unless (exists $w->{_Tags_});
+ unless (exists $w->{_Tags_}{$name})
+ {
+ require Tk::Text::Tag;
+ $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name);
+ }
+ $w->{_Tags_}{$name}->configure(@_) if (@_);
+ return $w->{_Tags_}{$name};
+}
+
+sub Tags
+{
+ my ($w,$name) = @_;
+ my @result = ();
+ foreach $name ($w->tagNames(@_))
+ {
+ push(@result,$w->Tag($name));
+ }
+ return @result;
+}
+
+sub TIEHANDLE
+{
+ my ($class,$obj) = @_;
+ return $obj;
+}
+
+sub PRINT
+{
+ my $w = shift;
+ # Find out whether 'end' is displayed at the moment
+ # Retrieve the position of the bottom of the window as
+ # a fraction of the entire contents of the Text widget
+ my $yview = ($w->yview)[1];
+
+ # If $yview is 1.0 this means that 'end' is visible in the window
+ my $update = 0;
+ $update = 1 if $yview == 1.0;
+
+ # Loop over all input strings
+ while (@_)
+ {
+ $w->insert('end',shift);
+ }
+ # Move the window to see the end of the text if required
+ $w->see('end') if $update;
+}
+
+sub PRINTF
+{
+ my $w = shift;
+ $w->PRINT(sprintf(shift,@_));
+}
+
+sub WhatLineNumberPopUp
+{
+ my ($w)=@_;
+ my ($line,$col) = split(/\./,$w->index('insert'));
+ $w->messageBox(-type => 'Ok', -title => "What Line Number",
+ -message => "The cursor is on line $line (column is $col)");
+}
+
+sub MenuLabels
+{
+ return qw[~File ~Edit ~Search ~View];
+}
+
+sub SearchMenuItems
+{
+ my ($w) = @_;
+ return [
+ ['command'=>'~Find', -command => [$w => 'FindPopUp']],
+ ['command'=>'Find ~Next', -command => [$w => 'FindSelectionNext']],
+ ['command'=>'Find ~Previous', -command => [$w => 'FindSelectionPrevious']],
+ ['command'=>'~Replace', -command => [$w => 'FindAndReplacePopUp']]
+ ];
+}
+
+sub EditMenuItems
+{
+ my ($w) = @_;
+ my @items = ();
+ foreach my $op ($w->clipEvents)
+ {
+ push(@items,['command' => "~$op", -command => [ $w => "clipboard$op"]]);
+ }
+ push(@items,
+ '-',
+ ['command'=>'Select All', -command => [$w => 'selectAll']],
+ ['command'=>'Unselect All', -command => [$w => 'unselectAll']],
+ );
+ return \@items;
+}
+
+sub ViewMenuItems
+{
+ my ($w) = @_;
+ my $v;
+ tie $v,'Tk::Configure',$w,'-wrap';
+ return [
+ ['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']],
+ ['command'=>'~Which Line?', -command => [$w => 'WhatLineNumberPopUp']],
+ ['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [
+ [radiobutton => 'Word', -variable => \$v, -value => 'word'],
+ [radiobutton => 'Character', -variable => \$v, -value => 'char'],
+ [radiobutton => 'None', -variable => \$v, -value => 'none'],
+ ]],
+ ];
+}
+
+########################################################################
+sub clipboardColumnCopy
+{
+ my ($w) = @_;
+ $w->Column_Copy_or_Cut(0);
+}
+
+sub clipboardColumnCut
+{
+ my ($w) = @_;
+ $w->Column_Copy_or_Cut(1);
+}
+
+########################################################################
+sub Column_Copy_or_Cut
+{
+ my ($w, $cut) = @_;
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+ # this only makes sense if there is one selected block
+ unless ($range_total==2)
+ {
+ $w->bell;
+ return;
+ }
+
+ my $selection_start_index = shift(@ranges);
+ my $selection_end_index = shift(@ranges);
+
+ my ($start_line, $start_column) = split(/\./, $selection_start_index);
+ my ($end_line, $end_column) = split(/\./, $selection_end_index);
+
+ # correct indices for tabs
+ my $string;
+ $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
+ $string = substr($string, 0, $start_column);
+ $string = expand($string);
+ my $tab_start_column = length($string);
+
+ $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
+ $string = substr($string, 0, $end_column);
+ $string = expand($string);
+ my $tab_end_column = length($string);
+
+ my $length = $tab_end_column - $tab_start_column;
+
+ $selection_start_index = $start_line . '.' . $tab_start_column;
+ $selection_end_index = $end_line . '.' . $tab_end_column;
+
+ # clear the clipboard
+ $w->clipboardClear;
+ my ($clipstring, $startstring, $endstring);
+ my $padded_string = ' 'x$tab_end_column;
+ for(my $line = $start_line; $line <= $end_line; $line++)
+ {
+ $string = $w->get($line.'.0', $line.'.0 lineend');
+ $string = expand($string) . $padded_string;
+ $clipstring = substr($string, $tab_start_column, $length);
+ #$clipstring = unexpand($clipstring);
+ $w->clipboardAppend($clipstring."\n");
+
+ if ($cut)
+ {
+ $startstring = substr($string, 0, $tab_start_column);
+ $startstring = unexpand($startstring);
+ $start_column = length($startstring);
+
+ $endstring = substr($string, 0, $tab_end_column );
+ $endstring = unexpand($endstring);
+ $end_column = length($endstring);
+
+ $w->delete($line.'.'.$start_column, $line.'.'.$end_column);
+ }
+ }
+}
+
+########################################################################
+
+sub clipboardColumnPaste
+{
+ my ($w) = @_;
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+ if ($range_total)
+ {
+ warn " there cannot be any selections during clipboardColumnPaste. \n";
+ $w->bell;
+ return;
+ }
+
+ my $clipboard_text;
+ eval
+ {
+ $clipboard_text = $w->SelectionGet(-selection => "CLIPBOARD");
+ };
+
+ return unless (defined($clipboard_text));
+ return unless (length($clipboard_text));
+ my $string;
+
+ my $current_index = $w->index('insert');
+ my ($current_line, $current_column) = split(/\./,$current_index);
+ $string = $w->get($current_line.'.0', $current_line.'.'.$current_column);
+ $string = expand($string);
+ $current_column = length($string);
+
+ my @clipboard_lines = split(/\n/,$clipboard_text);
+ my $length;
+ my $end_index;
+ my ($delete_start_column, $delete_end_column, $insert_column_index);
+ foreach my $line (@clipboard_lines)
+ {
+ if ($w->OverstrikeMode)
+ {
+ #figure out start and end indexes to delete, compensating for tabs.
+ $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $current_column);
+ $string = unexpand($string);
+ $delete_start_column = length($string);
+
+ $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $current_column + length($line));
+ chomp($string); # dont delete a "\n" on end of line.
+ $string = unexpand($string);
+ $delete_end_column = length($string);
+
+
+
+ $w->delete(
+ $current_line.'.'.$delete_start_column ,
+ $current_line.'.'.$delete_end_column
+ );
+ }
+
+ $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $current_column);
+ $string = unexpand($string);
+ $insert_column_index = length($string);
+
+ $w->insert($current_line.'.'.$insert_column_index, unexpand($line));
+ $current_line++;
+ }
+
+}
+
+# Backward compatibility
+sub GetMenu
+{
+ carp((caller(0))[3]." is deprecated") if $^W;
+ shift->menu
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Text.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Text.pod
new file mode 100755
index 00000000000..b6db20423f3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Text.pod
@@ -0,0 +1,2215 @@
+# Copyright (c) 1992 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 2002 O'Reilly & Associates Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Text - Create and manipulate Text widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+B<text> $text ?I<options>?
+
+B<-background> B<-highlightbackground> B<-insertontime> B<-selectborderwidth>
+B<-borderwidth> B<-highlightcolor> B<-insertwidth> B<-selectforeground>
+B<-cursor> B<-highlightthickness> B<-padx> B<-setgrid>
+B<-exportselection> B<-insertbackground> B<-pady> B<-takefocus>
+B<-font> B<-insertborderwidth> B<-relief> B<-xscrollcommand>
+B<-foreground> B<-insertofftime> B<-selectbackground> B<-yscrollcommand>
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies the desired height for the window, in units of characters
+in the font given by the B<-font> option.
+Must be at least one.
+
+=item Name: B<spacing1>
+
+=item Class: B<Spacing1>
+
+=item Switch: B<-spacing1>
+
+Requests additional space above each text line in the widget,
+using any of the standard forms for screen distances.
+If a line wraps, this option only applies to the first line
+on the display.
+This option may be overriden with B<-spacing1> options in
+tags.
+
+=item Name: B<spacing2>
+
+=item Class: B<Spacing2>
+
+=item Switch: B<-spacing2>
+
+For lines that wrap (so that they cover more than one line on the
+display) this option specifies additional space to provide between
+the display lines that represent a single line of text.
+The value may have any of the standard forms for screen distances.
+This option may be overriden with B<-spacing2> options in
+tags.
+
+=item Name: B<spacing3>
+
+=item Class: B<Spacing3>
+
+=item Switch: B<-spacing3>
+
+Requests additional space below each text line in the widget,
+using any of the standard forms for screen distances.
+If a line wraps, this option only applies to the last line
+on the display.
+This option may be overriden with B<-spacing3> options in
+tags.
+
+=item Name: B<state>
+
+=item Class: B<State>
+
+=item Switch: B<-state>
+
+Specifies one of two states for the text: B<normal> or B<disabled>.
+If the text is disabled then characters may not be inserted or deleted
+and no insertion cursor will be displayed, even if the input focus is
+in the widget.
+
+=item Name: B<tabs>
+
+=item Class: B<Tabs>
+
+=item Switch: B<-tabs>
+
+Specifies a set of tab stops for the window. The option's value consists
+of a list of screen distances giving the positions of the tab stops. Each
+position may optionally be followed in the next list element
+by one of the keywords B<left>, B<right>, B<center>,
+or B<numeric>, which specifies how to justify
+text relative to the tab stop. B<Left> is the default; it causes
+the text following the tab character to be positioned with its left edge
+at the tab position. B<Right> means that the right edge of the text
+following the tab character is positioned at the tab position, and
+B<center> means that the text is centered at the tab position.
+B<Numeric> means that the decimal point in the text is positioned
+at the tab position; if there is no decimal point then the least
+significant digit of the number is positioned just to the left of the
+tab position; if there is no number in the text then the text is
+right-justified at the tab position.
+For example, B<-tabs =E<gt> [qw/2c left 4c 6c center/]> creates three
+tab stops at two-centimeter intervals; the first two use left
+justification and the third uses center justification.
+If the list of tab stops does not have enough elements to cover all
+of the tabs in a text line, then Tk extrapolates new tab stops using
+the spacing and alignment from the last tab stop in the list.
+The value of the B<tabs> option may be overridden by B<-tabs>
+options in tags.
+If no B<-tabs> option is specified, or if it is specified as
+an empty list, then Tk uses default tabs spaced every eight
+(average size) characters.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired width for the window in units of characters
+in the font given by the B<-font> option.
+If the font doesn't have a uniform width then the width of the
+character ``0'' is used in translating from character units to
+screen units.
+
+=item Name: B<wrap>
+
+=item Class: B<Wrap>
+
+=item Switch: B<-wrap>
+
+Specifies how to handle lines in the text that are too long to be
+displayed in a single line of the text's window.
+The value must be B<none> or B<char> or B<word>.
+A wrap mode of B<none> means that each line of text appears as
+exactly one line on the screen; extra characters that don't fit
+on the screen are not displayed.
+In the other modes each line of text will be broken up into several
+screen lines if necessary to keep all the characters visible.
+In B<char> mode a screen line break may occur after any character;
+in B<word> mode a line break will only be made at word boundaries.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Text> method creates a new window (given by the
+$text argument) and makes it into a text widget.
+Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the text such as its default background color
+and relief. The B<text> command returns the
+path name of the new window.
+
+A text widget displays one or more lines of text and allows that
+text to be edited.
+Text widgets support four different kinds of annotations on the
+text, called tags, marks, embedded windows or embedded images.
+Tags allow different portions of the text
+to be displayed with different fonts and colors.
+In addition, L<perl/Tk callbacks|Tk::callbacks> can be associated with tags so
+that scripts are invoked when particular actions such as keystrokes
+and mouse button presses occur in particular ranges of the text.
+See L<"TAGS"> below for more details.
+
+The second form of annotation consists of marks, which are floating
+markers in the text.
+Marks are used to keep track of various interesting positions in the
+text as it is edited.
+See L<"MARKS"> below for more details.
+
+The third form of annotation allows arbitrary windows to be
+embedded in a text widget.
+See L<"EMBEDDED WINDOWS"> below for more details.
+
+The fourth form of annotation allows Tk images to be embedded in a text
+widget.
+See L<"EMBEDDED IMAGES"> below for more details.
+
+The Perl/Tk B<Text> widget does not support undo/redo, use the B<TextUndo>
+widget instead.
+
+=head1 INDICES
+
+Many of the methods for texts take one or more indices
+as arguments.
+An index is a string used to indicate a particular place within
+a text, such as a place to insert characters or one endpoint of a
+range of characters to delete.
+Indices have the syntax
+
+ base modifier modifier modifier ...
+
+Where I<base> gives a starting point and the I<modifier>s
+adjust the index from the starting point (e.g. move forward or
+backward one character). Every index must contain a I<base>,
+but the I<modifier>s are optional.
+
+The I<base> for an index must have one of the following forms:
+
+=over 4
+
+=item I<line>B<.>I<char>
+
+Indicates I<char>'th character on line I<line>.
+Lines are numbered from 1 for consistency with other UNIX programs
+that use this numbering scheme.
+Within a line, characters are numbered from 0.
+If I<char> is B<end> then it refers to the newline character
+that ends the line.
+
+=item B<@>I<x>B<,>I<y>
+
+Indicates the character that covers the pixel whose x and y coordinates
+within the text's window are I<x> and I<y>.
+
+=item B<end>
+
+Indicates the end of the text (the character just after the last
+newline).
+
+=item I<mark>
+
+Indicates the character just after the mark whose name is I<mark>.
+
+=item I<tag>B<.first>
+
+Indicates the first character in the text that has been tagged with
+I<tag>.
+This form generates an error if no characters are currently tagged
+with I<tag>.
+
+=item I<tag>B<.last>
+
+Indicates the character just after the last one in the text that has
+been tagged with I<tag>.
+This form generates an error if no characters are currently tagged
+with I<tag>.
+
+=item I<$widget>
+
+Indicates the position of the embedded window referenced by I<$widget>.
+This form generates an error if I<$widget> does not reference to an
+embedded window.
+
+=item I<imageName>
+
+Indicates the position of the embedded image whose name is
+I<imageName>.
+This form generates an error if there is no embedded image
+by the given name.
+
+If the I<base> could match more than one of the above forms, such
+as a I<mark> and I<imageName> both having the same value, then
+the form earlier in the above list takes precedence.
+If modifiers follow the base index, each one of them must have one
+of the forms listed below. Keywords such as B<chars> and B<wordend>
+may be abbreviated as long as the abbreviation is unambiguous.
+
+=item B<+ >I<count>B< chars>
+
+Adjust the index forward by I<count> characters, moving to later
+lines in the text if necessary. If there are fewer than I<count>
+characters in the text after the current index, then set the index
+to the last character in the text.
+Spaces on either side of I<count> are optional.
+
+=item B<- >I<count>B< chars>
+
+Adjust the index backward by I<count> characters, moving to earlier
+lines in the text if necessary. If there are fewer than I<count>
+characters in the text before the current index, then set the index
+to the first character in the text.
+Spaces on either side of I<count> are optional.
+
+=item B<+ >I<count>B< lines>
+
+Adjust the index forward by I<count> lines, retaining the same
+character position within the line. If there are fewer than I<count>
+lines after the line containing the current index, then set the index
+to refer to the same character position on the last line of the text.
+Then, if the line is not long enough to contain a character at the indicated
+character position, adjust the character position to refer to the last
+character of the line (the newline).
+Spaces on either side of I<count> are optional.
+
+=item B<- >I<count>B< lines>
+
+Adjust the index backward by I<count> lines, retaining the same
+character position within the line. If there are fewer than I<count>
+lines before the line containing the current index, then set the index
+to refer to the same character position on the first line of the text.
+Then, if the line is not long enough to contain a character at the indicated
+character position, adjust the character position to refer to the last
+character of the line (the newline).
+Spaces on either side of I<count> are optional.
+
+=item B<linestart>
+
+Adjust the index to refer to the first character on the line.
+
+=item B<lineend>
+
+Adjust the index to refer to the last character on the line (the newline).
+
+=item B<wordstart>
+
+Adjust the index to refer to the first character of the word containing
+the current index. A word consists of any number of adjacent characters
+that are letters, digits, or underscores, or a single character that
+is not one of these.
+
+=item B<wordend>
+
+Adjust the index to refer to the character just after the last one of the
+word containing the current index. If the current index refers to the last
+character of the text then it is not modified.
+
+If more than one modifier is present then they are applied in
+left-to-right order. For example, the index ``B<end - 1 chars>''
+refers to the next-to-last character in the text and
+``B<insert wordstart - 1 c>'' refers to the character just before
+the first one in the word containing the insertion cursor.
+
+=back
+
+=head1 TAGS
+
+The first form of annotation in text widgets is a tag.
+A tag is a textual string that is associated with some of the characters
+in a text.
+Tags may contain arbitrary characters, but it is probably best to
+avoid using the the characters `` '' (space), B<+>, or B<->:
+these characters have special meaning in indices, so tags containing
+them can't be used as indices.
+There may be any number of tags associated with characters in a
+text.
+Each tag may refer to a single character, a range of characters, or
+several ranges of characters.
+An individual character may have any number of tags associated with it.
+
+A priority order is defined among tags, and this order is used in
+implementing some of the tag-related functions described below.
+When a tag is defined (by associating it with characters or setting
+its display options or binding callbacks to it), it is given
+a priority higher than any existing tag.
+The priority order of tags may be redefined using the
+``I<$text>-E<gt>B<tagRaise>'' and ``I<$text>-E<gt>B<tagLower>''
+methods.
+
+Tags serve three purposes in text widgets.
+First, they control the way information is displayed on the screen.
+By default, characters are displayed as determined by the
+B<background>, B<font>, and B<foreground> options for the
+text widget.
+However, display options may be associated with individual tags
+using the ``I<$text>-E<gt>B<tagConfigure>'' method.
+If a character has been tagged, then the display options associated
+with the tag override the default display style.
+The following options are currently supported for tags:
+
+=over 4
+
+=item B<-background> =E<gt> I<color>
+
+I<Color> specifies the background color to use for characters
+associated with the tag.
+It may have any of the forms accepted by B<Tk_GetColor>.
+
+=item B<-bgstipple> =E<gt> I<bitmap>
+
+I<Bitmap> specifies a bitmap that is used as a stipple pattern
+for the background.
+It may have any of the forms accepted by B<Tk_GetBitmap>.
+If I<bitmap> hasn't been specified, or if it is specified
+as an empty string, then a solid fill will be used for the
+background.
+
+=item B<-borderwidth> =E<gt> I<pixels>
+
+I<Pixels> specifies the width of a 3-D border to draw around
+the background.
+It may have any of the forms accepted by B<Tk_GetPixels>.
+This option is used in conjunction with the B<-relief>
+option to give a 3-D appearance to the background for characters;
+it is ignored unless the B<-background> option
+has been set for the tag.
+
+=item B<-elide> =E<gt> boolean
+
+Elide specifies whether the data should be elided. Elided data
+is not displayed and takes no space on screen, but further on
+behaves just as normal data.
+
+=item B<-data> =E<gt> I<value>
+
+Allows an arbitrary perl scalar I<value> to be associated with the tag.
+
+=item B<-fgstipple> =E<gt> I<bitmap>
+
+I<Bitmap> specifies a bitmap that is used as a stipple pattern
+when drawing text and other foreground information such as
+underlines.
+It may have any of the forms accepted by B<Tk_GetBitmap>.
+If I<bitmap> hasn't been specified, or if it is specified
+as an empty string, then a solid fill will be used.
+
+=item B<-font> =E<gt> I<fontName>
+
+I<FontName> is the name of a font to use for drawing characters.
+It may have any of the forms accepted by B<Tk_GetFontStruct>.
+
+=item B<-foreground> =E<gt> I<color>
+
+I<Color> specifies the color to use when drawing text and other
+foreground information such as underlines.
+It may have any of the forms accepted by B<Tk_GetColor>.
+
+=item B<-justify> =E<gt> I<justify>
+
+If the first character of a display line has a tag for which this
+option has been specified, then I<justify> determines how to
+justify the line.
+It must be one of B<left>, B<right>, or B<center>.
+If a line wraps, then the justification for each line on the
+display is determined by the first character of that display line.
+
+=item B<-lmargin1> =E<gt> I<pixels>
+
+If the first character of a text line has a tag for which this
+option has been specified, then I<pixels> specifies how
+much the line should be indented from the left edge of the
+window.
+I<Pixels> may have any of the standard forms for screen
+distances.
+If a line of text wraps, this option only applies to the
+first line on the display; the B<-lmargin2> option controls
+the indentation for subsequent lines.
+
+=item B<-lmargin2> =E<gt> I<pixels>
+
+If the first character of a display line has a tag for which this
+option has been specified, and if the display line is not the
+first for its text line (i.e., the text line has wrapped), then
+I<pixels> specifies how much the line should be indented from
+the left edge of the window.
+I<Pixels> may have any of the standard forms for screen
+distances.
+This option is only used when wrapping is enabled, and it only
+applies to the second and later display lines for a text line.
+
+=item B<-offset> =E<gt> I<pixels>
+
+I<Pixels> specifies an amount by which the text's baseline
+should be offset vertically from the baseline of the overall
+line, in pixels.
+For example, a positive offset can be used for superscripts
+and a negative offset can be used for subscripts.
+I<Pixels> may have any of the standard forms for screen
+distances.
+
+=item B<-overstrike> =E<gt> I<boolean>
+
+Specifies whether or not to draw a horizontal rule through
+the middle of characters.
+I<Boolean> may have any of the forms accepted by B<Tk_GetBoolean>.
+
+=item B<-relief> =E<gt> I<relief>
+
+I<Relief> specifies the 3-D relief to use for drawing backgrounds,
+in any of the forms accepted by B<Tk_GetRelief>.
+This option is used in conjunction with the B<-borderwidth>
+option to give a 3-D appearance to the background for characters;
+it is ignored unless the B<-background> option
+has been set for the tag.
+
+=item B<-rmargin> =E<gt> I<pixels>
+
+If the first character of a display line has a tag for which this
+option has been specified, then I<pixels> specifies how wide
+a margin to leave between the end of the line and the right
+edge of the window.
+I<Pixels> may have any of the standard forms for screen
+distances.
+This option is only used when wrapping is enabled.
+If a text line wraps, the right margin for each line on the
+display is determined by the first character of that display
+line.
+
+=item B<-spacing1> =E<gt> I<pixels>
+
+I<Pixels> specifies how much additional space should be
+left above each text line, using any of the standard forms for
+screen distances.
+If a line wraps, this option only applies to the first
+line on the display.
+
+=item B<-spacing2> =E<gt> I<pixels>
+
+For lines that wrap, this option specifies how much additional
+space to leave between the display lines for a single text line.
+I<Pixels> may have any of the standard forms for screen
+distances.
+
+=item B<-spacing3> =E<gt> I<pixels>
+
+I<Pixels> specifies how much additional space should be
+left below each text line, using any of the standard forms for
+screen distances.
+If a line wraps, this option only applies to the last
+line on the display.
+
+=item B<-tabs> =E<gt> I<tabList>
+
+I<TabList> specifies a set of tab stops in the same form
+as for the B<-tabs> option for the text widget. This
+option only applies to a display line if it applies to the
+first character on that display line.
+If this option is specified as an empty string, it cancels
+the option, leaving it unspecified for the tag (the default).
+If the option is specified as a non-empty string that is
+an empty list, such as B<-tabs => " ">, then it requests
+default 8-character tabs as described for the B<tabs>
+widget option.
+
+=item B<-underline> =E<gt> I<boolean>
+
+I<Boolean> specifies whether or not to draw an underline underneath
+characters.
+It may have any of the forms accepted by B<Tk_GetBoolean>.
+
+=item B<-wrap> =E<gt> I<mode>
+
+I<Mode> specifies how to handle lines that are wider than the
+text's window.
+It has the same legal values as the B<-wrap> option
+for the text widget: B<none>, B<char>, or B<word>.
+If this tag option is specified, it overrides the B<-wrap> option
+for the text widget.
+
+=back
+
+If a character has several tags associated with it, and if their
+display options conflict, then the options of the highest priority
+tag are used.
+If a particular display option hasn't been specified for a
+particular tag, or if it is specified as an empty string, then
+that option will never be used; the next-highest-priority
+tag's option will used instead.
+If no tag specifies a particular display option, then the default
+style for the widget will be used.
+
+The second purpose for tags is event bindings.
+You can associate bindings with a tag in much the same way you can
+associate bindings with a widget class: whenever particular X
+events occur on characters with the given tag, a given
+<perl/Tk callback|Tk::callbacks> will be executed.
+Tag bindings can be used to give behaviors to ranges of characters;
+among other things, this allows hypertext-like
+features to be implemented.
+For details, see the description of the B<tagBind> widget
+method below.
+
+The third use for tags is in managing the selection.
+See L<"THE SELECTION"> below.
+
+=head1 MARKS
+
+The second form of annotation in text widgets is a mark.
+Marks are used for remembering particular places in a text.
+They are something like tags, in that they have names and
+they refer to places in the file, but a mark isn't associated
+with particular characters.
+Instead, a mark is associated with the gap between two characters.
+Only a single position may be associated with a mark at any given
+time.
+If the characters around a mark are deleted the mark will still
+remain; it will just have new neighbor characters.
+In contrast, if the characters containing a tag are deleted then
+the tag will no longer have an association with characters in
+the file.
+Marks may be manipulated with the ``I<$text>-E<gt>B<mark>'' text widget
+method, and their current locations may be determined by using the
+mark name as an index in methods.
+
+Each mark also has a I<gravity>, which is either B<left> or
+B<right>.
+The gravity for a mark specifies what happens to the mark when
+text is inserted at the point of the mark.
+If a mark has left gravity, then the mark is treated as if it
+were attached to the character on its left, so the mark will
+remain to the left of any text inserted at the mark position.
+If the mark has right gravity, new text inserted at the mark
+position will appear to the right of the mark. The gravity
+for a mark defaults to B<right>.
+
+The name space for marks is different from that for tags: the
+same name may be used for both a mark and a tag, but they will refer
+to different things.
+
+Two marks have special significance.
+First, the mark B<insert> is associated with the insertion cursor,
+as described under L<"THE INSERTION CURSOR"> below.
+Second, the mark B<current> is associated with the character
+closest to the mouse and is adjusted automatically to track the
+mouse position and any changes to the text in the widget (one
+exception: B<current> is not updated in response to mouse
+motions if a mouse button is down; the update will be deferred
+until all mouse buttons have been released).
+Neither of these special marks may be deleted.
+
+=head1 EMBEDDED WINDOWS
+
+The third form of annotation in text widgets is an embedded window.
+Each embedded window annotation causes a window to be displayed
+at a particular point in the text.
+There may be any number of embedded windows in a text widget,
+and any widget may be used as an embedded window (subject to the
+usual rules for geometry management, which require the text window
+to be the parent of the embedded window or a descendant of its
+parent).
+The embedded window's position on the screen will be updated as the
+text is modified or scrolled, and it will be mapped and unmapped as
+it moves into and out of the visible area of the text widget.
+Each embedded window occupies one character's worth of index space
+in the text widget, and it may be referred to either by the name
+of its embedded window or by its position in the widget's
+index space.
+If the range of text containing the embedded window is deleted then
+the window is destroyed.
+
+When an embedded window is added to a text widget with the
+B<widgetCreate> method, several configuration
+options may be associated with it.
+These options may be modified later with the B<widgetConfigure>
+method.
+The following options are currently supported:
+
+=over 4
+
+=item B<-align> =E<gt> I<where>
+
+If the window is not as tall as the line in which it is displayed,
+this option determines where the window is displayed in the line.
+I<Where> must have one of the values B<top> (align the top of the window
+with the top of the line), B<center> (center the window
+within the range of the line), B<bottom> (align the bottom of the
+window with the bottom of the line's area),
+or B<baseline> (align the bottom of the window with the baseline
+of the line).
+
+=item B<-create> =E<gt> I<callback>
+
+Specifies a L<callback|Tk::callbacks> that may be evaluated to create the window
+for the annotation.
+If no B<-window> option has been specified for the annotation
+this I<callback> will be evaluated when the annotation is about to
+be displayed on the screen.
+I<Callback> must create a window for the annotation and return
+the name of that window as its result.
+If the annotation's window should ever be deleted, I<callback>
+will be evaluated again the next time the annotation is displayed.
+
+=item B<-padx> =E<gt> I<pixels>
+
+I<Pixels> specifies the amount of extra space to leave on
+each side of the embedded window.
+It may have any of the usual forms defined for a screen distance
+(see B<Tk_GetPixels>).
+
+=item B<-pady> =E<gt> I<pixels>
+
+I<Pixels> specifies the amount of extra space to leave on
+the top and on the bottom of the embedded window.
+It may have any of the usual forms defined for a screen distance
+(see B<Tk_GetPixels>).
+
+=item B<-stretch> =E<gt> I<boolean>
+
+If the requested height of the embedded window is less than the
+height of the line in which it is displayed, this option can be
+used to specify whether the window should be stretched vertically
+to fill its line.
+If the B<-pady> option has been specified as well, then the
+requested padding will be retained even if the window is
+stretched.
+
+=item B<-window> =E<gt> I<$widget>
+
+Specifies the name of a window to display in the annotation.
+
+=back
+
+=head1 EMBEDDED IMAGES
+
+The final form of annotation in text widgets is an embedded image.
+Each embedded image annotation causes an image to be displayed
+at a particular point in the text.
+There may be any number of embedded images in a text widget,
+and a particular image may be embedded in multiple places in the same
+text widget.
+The embedded image's position on the screen will be updated as the
+text is modified or scrolled.
+Each embedded image occupies one character's worth of index space
+in the text widget, and it may be referred to either by
+its position in the widget's index space, or the name it is assigned
+when the image is inserted into the text widget with B<imageCreate>.
+If the range of text containing the embedded image is deleted then
+that copy of the image is removed from the screen.
+
+When an embedded image is added to a text widget with the B<image>
+create method, a name unique to this instance of the image
+is returned. This name may then be used to refer to this image
+instance. The name is taken to be the value of the B<-name> option
+(described below). If the B<-name> option is not provided, the
+B<-image> name is used instead. If the I<imageName> is already
+in use in the text widget, then B<#>I<nn> is added to the end of the
+I<imageName>, where I<nn> is an arbitrary integer. This insures
+the I<imageName> is unique.
+Once this name is assigned to this instance of the image, it does not
+change, even though the B<-image> or B<-name> values can be changed
+with B<image configure>.
+
+When an embedded image is added to a text widget with the
+B<imageCreate> method, several configuration
+options may be associated with it.
+These options may be modified later with the B<image configure>
+method.
+The following options are currently supported:
+
+=over 4
+
+=item B<-align> =E<gt> I<where>
+
+If the image is not as tall as the line in which it is displayed,
+this option determines where the image is displayed in the line.
+I<Where> must have one of the values B<top> (align the top of the image
+with the top of the line), B<center> (center the image
+within the range of the line), B<bottom> (align the bottom of the
+image with the bottom of the line's area),
+or B<baseline> (align the bottom of the image with the baseline
+of the line).
+
+=item B<-image> =E<gt> I<image>
+
+Specifies the name of the Tk image to display in the annotation.
+If I<image> is not a valid Tk image, then an error is returned.
+
+=item B<-name> =E<gt> I<ImageName>
+
+Specifies the name by which this image instance may be referenced in
+the text widget. If I<ImageName> is not supplied, then the
+name of the Tk image is used instead.
+If the I<imageName> is already in use, I<#nn> is appended to
+the end of the name as described above.
+
+=item B<-padx> =E<gt> I<pixels>
+
+I<Pixels> specifies the amount of extra space to leave on
+each side of the embedded image.
+It may have any of the usual forms defined for a screen distance.
+
+=item B<-pady> =E<gt> I<pixels>
+
+I<Pixels> specifies the amount of extra space to leave on
+the top and on the bottom of the embedded image.
+It may have any of the usual forms defined for a screen distance.
+
+=back
+
+=head1 THE SELECTION
+
+Selection support is implemented via tags.
+If the B<exportSelection> option for the text widget is true
+then the B<sel> tag will be associated with the selection:
+
+=over 4
+
+=item [1]
+
+Whenever characters are tagged with B<sel> the text widget
+will claim ownership of the selection.
+
+=item [2]
+
+Attempts to retrieve the
+selection will be serviced by the text widget, returning all the
+characters with the B<sel> tag.
+
+=item [3]
+
+If the selection is claimed away by another application or by another
+window within this application, then the B<sel> tag will be removed
+from all characters in the text.
+
+=item [4]
+
+Whenever the sel tag range changes a virtual event B<<<Selection>>>
+is generated.
+
+The B<sel> tag is automatically defined when a text widget is
+created, and it may not be deleted with the ``I<$text>-E<gt>B<tagDelete>''
+method. Furthermore, the B<selectBackground>,
+B<selectBorderWidth>, and B<selectForeground> options for
+the text widget are tied to the B<-background>,
+B<-borderwidth>, and B<-foreground> options for the B<sel>
+tag: changes in either will automatically be reflected in the
+other.
+
+=back
+
+=head1 THE INSERTION CURSOR
+
+The mark named B<insert> has special significance in text widgets.
+It is defined automatically when a text widget is created and it
+may not be unset with the ``I<$text>-E<gt>B<markUnset>'' widget
+command.
+The B<insert> mark represents the position of the insertion
+cursor, and the insertion cursor will automatically be drawn at
+this point whenever the text widget has the input focus.
+
+=head1 THE MODIFIED FLAG
+
+The text widget can keep track of changes to the content of the widget
+by means of the modified flag. Inserting or deleting text will set this
+flag. The flag can be queried, set and cleared programatically as well.
+Whenever the flag changes state a B<<<Modified>>> virtual event is gener-
+ated. See the edit modified widget command for more details.
+
+
+=head1 WIDGET METHODS
+
+The B<Text> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for text widgets.
+In addition, the extended text widget methods as documented
+in I<"Mastering Perl/Tk"> are included in this pod (with
+permission from the publisher, B<O'Reilly and Associates Inc.>).
+
+=over 4
+
+=item I<$text>-E<gt>B<adjustSelect>
+
+Moves the end point of the selection and anchor point to the
+mouse pointer location.
+
+=item I<$text>-E<gt>B<bbox>(I<index>)
+
+Returns a list of four elements describing the screen area
+of the character given by I<index>.
+The first two elements of the list give the x and y coordinates
+of the upper-left corner of the area occupied by the
+character, and the last two elements give the width and height
+of the area.
+If the character is only partially visible on the screen, then
+the return value reflects just the visible part.
+If the character is not visible on the screen then the return
+value is an empty list.
+
+=item I<$text>-E<gt>B<clipboardColumnCopy>
+
+Performs a rectangular copy of the currently selected text with
+basic compensation for tab characters.
+
+=item I<$text>-E<gt>B<clipboardColumnCut>
+
+Performs a rectangular cut of the currently selected text with
+basic compensation for tab characters.
+
+=item I<$text>-E<gt>B<clipboardColumnPaste>
+
+Performs a rectangular paste of the text in the clipboard. The
+upper-left corner is specified by the current position of the
+insert mark with basic compensation for tab characters.
+
+=item I<$text>-E<gt>B<compare>(I<index1, op, index2>)
+
+Compares the indices given by I<index1> and I<index2> according
+to the relational operator given by I<op>, and returns 1 if
+the relationship is satisfied and 0 if it isn't.
+I<Op> must be one of the operators E<lt>, E<lt>=, ==, E<gt>=, E<gt>, or !=.
+If I<op> is == then 1 is returned if the two indices refer to
+the same character, if I<op> is E<lt> then 1 is returned if I<index1>
+refers to an earlier character in the text than I<index2>, and
+so on.
+
+=item I<$text>-E<gt>B<Contents>(I<?args>?)
+
+Query or change the entire contents of the text widget. If no
+arguments are given, the entire contents of the text widget are
+returned. If any arguments are given, the entire contents of the
+text widget are deleted and replaced by the argument list.
+
+=item I<$text>-E<gt>B<debug>(?I<boolean>?)
+
+If I<boolean> is specified, then it must have one of the true or
+false values accepted by Tcl_GetBoolean.
+If the value is a true one then internal consistency checks will be
+turned on in the B-tree code associated with text widgets.
+If I<boolean> has a false value then the debugging checks will
+be turned off.
+In either case the command returns an empty string.
+If I<boolean> is not specified then the command returns B<on>
+or B<off> to indicate whether or not debugging is turned on.
+There is a single debugging switch shared by all text widgets: turning
+debugging on or off in any widget turns it on or off for all widgets.
+For widgets with large amounts of text, the consistency checks may
+cause a noticeable slow-down.
+
+=item I<$text>-E<gt>B<delete>(I<index1, >?I<index2>?)
+
+Delete a range of characters from the text.
+If both I<index1> and I<index2> are specified, then delete
+all the characters starting with the one given by I<index1>
+and stopping just before I<index2> (i.e. the character at
+I<index2> is not deleted).
+If I<index2> doesn't specify a position later in the text
+than I<index1> then no characters are deleted.
+If I<index2> isn't specified then the single character at
+I<index1> is deleted.
+It is not allowable to delete characters in a way that would leave
+the text without a newline as the last character.
+The command returns an empty string.
+If more indices are given, multiple ranges of text will
+be deleted. All indices are first checked for validity before
+any deletions are made. They are sorted and the text is removed
+from the last range to the first range to deleted text does not
+cause a undesired index shifting side-effects. If multiple
+ranges with the same start index are given, then the longest
+range is used. If overlapping ranges are given, then they will
+be merged into spans that do not cause deletion of text outside
+the given ranges due to text shifted during deletion.
+
+=item I<$text>-E<gt>B<deleteSelected>
+
+Delete the currently selected text.
+
+=item I<$text>-E<gt>B<deleteTextTaggedWith>(I<tag>)
+
+Delete the text tagged with the I<tag> parameter.
+
+=item I<$text>-E<gt>B<deleteToEndofLine>
+
+Delete from the insert mark location to the end of line.
+
+=item I<$text>-E<gt>B<dlineinfo>(I<index>)
+
+Returns a list with five elements describing the area occupied
+by the display line containing I<index>.
+The first two elements of the list give the x and y coordinates
+of the upper-left corner of the area occupied by the
+line, the third and fourth elements give the width and height
+of the area, and the fifth element gives the position of the baseline
+for the line, measured down from the top of the area.
+All of this information is measured in pixels.
+If the current wrap mode is B<none> and the line extends beyond
+the boundaries of the window,
+the area returned reflects the entire area of the line, including the
+portions that are out of the window.
+If the line is shorter than the full width of the window then the
+area returned reflects just the portion of the line that is occupied
+by characters and embedded windows.
+If the display line containing I<index> is not visible on
+the screen then the return value is an empty list.
+
+=item I<$text>-E<gt>B<dump>(?I<switches>?, I<index1, >?I<index2>?)
+
+Return the contents of the text widget from I<index1> up to,
+but not including I<index2>,
+including the text and
+information about marks, tags, and embedded windows.
+If I<index2> is not specified, then it defaults to
+one character past I<index1>. The information is returned
+in the following format:
+
+I<key1 value1 index1 key2 value2 index2> ...
+
+The possible I<key> values are B<text>, B<mark>,
+B<tagon>, B<tagoff>, and I<$text>. The corresponding
+I<value> is the text, mark name, tag name, or window name.
+The I<index> information is the index of the
+start of the text, the mark, the tag transition, or the window.
+One or more of the following switches (or abbreviations thereof)
+may be specified to control the dump:
+
+=over 4
+
+=item B<-all>
+
+Return information about all elements: text, marks, tags, and windows.
+This is the default.
+
+=item B<-command> =E<gt> I<callback>
+
+Instead of returning the information as the result of the dump operation,
+invoke the I<callback> on each element of the text widget within the range.
+The callback has three arguments appended to it before it is evaluated:
+the I<key>, I<value>, and I<index>.
+
+=item B<-mark>
+
+Include information about marks in the dump results.
+
+=item B<-tag>
+
+Include information about tag transitions in the dump results. Tag information is
+returned as B<tagon> and B<tagoff> elements that indicate the
+begin and end of each range of each tag, respectively.
+
+=item B<-text>
+
+Include information about text in the dump results. The value is the
+text up to the next element or the end of range indicated by I<index2>.
+A text element does not span newlines. A multi-line block of text that
+contains no marks or tag transitions will still be dumped as a set
+of text seqments that each end with a newline. The newline is part
+of the value.
+
+=item B<-window>
+
+=back
+
+Include information about embedded windows in the dump results.
+The value of a window is its Tk pathname, unless the window
+has not been created yet. (It must have a create script.)
+In this case an empty string is returned, and you must query the
+window by its index position to get more information.
+
+=item I<$text>-E<gt>B<edit>( I< option, ?arg, arg ...?> );
+
+This command controls the undo mechanism and the modified flag.
+The exact behavior of the command depends on the option argument
+that follows the edit argument. The following forms of the command
+are currently supported:
+
+=over 4
+
+=item I<$text>-E<gt>B<editModified>( ?boolean? );
+
+If boolean is not specified, returns the modified flag of
+the widget. The insert, delete, edit undo and edit redo
+commands or the user can set or clear the modified flag.
+If boolean is specified, sets the modified flag of the
+widget to boolean.
+
+=item I<$text>-E<gt>B<editRedo>;
+
+(Not implemented, use B<TextUndo>.) When the B<-undo> option is true,
+reapplies the last undone edits provided no other edits were done
+since then. Generates an error when the redo stack is empty. Does
+nothing when the B<-undo> option is false.
+
+=item I<$text>-E<gt>B<editReset>;
+
+(Not implemented, use B<TextUndo>.) Clears the undo and redo stacks.
+
+=item I<$text>-E<gt>B<editSeparator>;
+
+(Not implemented, use B<TextUndo>.) Inserts a separator (boundary) on
+the undo stack. Does nothing when the -undo option is false.
+
+=item I<$text>-E<gt>B<editUndo>;
+
+(Not implemented, use B<TextUndo>.) Undoes the last edit action when
+the -undo option is true. An edit action is defined as all the insert
+and delete commands that are recorded on the undo stack in between two
+separators. Generates an error when the undo stack is empty. Does
+nothing when the -undo option is false.
+
+=back
+
+=item I<$text>-E<gt>B<FindAll>(I<mode, case, pattern>)
+
+Removes any current selections and then performs a global text
+search. All matches are tagged with the B<sel> tag.
+
+I<mode> can be be B<-exact> or B<-regexp>. See the B<search> command
+for more information
+
+I<case> can be B<-nocase> or B<-case>. See the B<search> command
+for more information
+
+I<pattern> is an exact string to match if I<mode> is B<-exact> or a
+regular expression if the match I<mode> is B<-regexp>.
+
+
+=item I<$text>-E<gt>B<FindAndReplaceAll>(I<mode, case, find, replace>)
+
+Same as the B<FindAll> method, however additionally substitutes the
+matched text with the characters I<replace>.
+
+=item I<$text>-E<gt>B<FindAndReplacePopUp>
+
+Creates a find-and-replace popup window if one does not already exist.
+If there is currently selected text, then the 'find' field will be
+'pre-filled' with the selection.
+
+=item I<$text>-E<gt>B<FindNext>(I<direction, mode, case, pattern>)
+
+Removes any current selections and then performs a forward or reverse
+text search. All matches are tagged with the B<sel> tag. I<direction>
+can be B<-forward> or B<-reverse>. I<mode, case> and I<pattern> are
+as for the B<FindAll> method.
+
+=item I<$text>-E<gt>B<FindPopUp>
+
+Creates a find popup, if one does not yet exist. If there is currently
+selected text, then the 'find' field will be 'pre-filled' with the
+selection.
+
+=item I<$text>-E<gt>B<FindSelectionNext>
+
+Gets the currently selected text and removes all selections. It then
+finds the next exact, case-sensitive string that matches in a forward
+direction and selects the text and makes the new selection visible.
+
+=item I<$text>-E<gt>B<FindSelectionPrevious>
+
+Gets the currently selected text and removes all selections. It then
+finds the next exact, case-sensitive string that matches in a reverse
+direction and selects the text and makes the new selection visible.
+
+=item I<$text>-E<gt>B<get>(I<index1, >?I<index2>?)
+
+Return a range of characters from the text. The return value will be
+all the characters in the text starting with the one whose index is
+I<index1> and ending just before the one whose index is I<index2> (the
+character at I<index2> will not be returned). If I<index2> is omitted
+then the single character at I<index1> is returned. If there are no
+characters in the specified range (e.g. I<index1> is past the end of
+the file or I<index2> is less than or equal to I<index1>) then an
+empty string is returned. If the specified range contains embedded
+windows, no information about them is included in the returned string.
+If multiple index pairs are given, multiple ranges of text will be
+returned in a list. Invalid ranges will not be represented with empty
+strings in the list. The ranges are returned in the order passed to
+B<get>.
+
+=item I<$text>-E<gt>B<getSelected>
+
+Return the currently selected text.
+
+=item I<$text>-E<gt>B<GetTextTaggedWith>(I<tag>)
+
+Return the text tagged with the I<tag> parameter.
+
+=item I<$text>-E<gt>B<GotoLineNumber>(I<line_number>)
+
+Set the insert mark to I<line_number> and ensures the line is
+visible.
+
+=item I<$text>-E<gt>B<GotoLineNumberPopUp>(I<line_number>)
+
+Displays a popup, pre-filling it with selected numeric text
+(if any), or the line number from B<GotoLineNumber> (if any).
+
+=item I<$text>-E<gt>B<image>(I<option>, ?I<arg, arg, ...>?)
+
+=item I<$text>-E<gt>B<image>I<Option>(?I<arg, arg, ...>?)
+
+This method is used to manipulate embedded images.
+The behavior of the method depends on the I<option> argument
+that follows the B<image> prefix.
+The following forms of the methods are currently supported:
+
+=over 8
+
+=item I<$text>-E<gt>B<imageCget>(I<index, option>)
+
+Returns the value of a configuration option for an embedded image.
+I<Index> identifies the embedded image, and I<option>
+specifies a particular configuration option, which must be one of
+the ones listed in L<"EMBEDDED IMAGES">.
+
+=item I<$text>-E<gt>B<imageConfigure>(I<index, >?I<option, value, ...>?)
+
+Query or modify the configuration options for an embedded image.
+If no I<option> is specified, returns a list describing all of
+the available options for the embedded image at I<index>
+(see L<Tk::options> for information on the format of this list).
+If I<option> is specified with no I<value>, then the command
+returns a list describing the one named option (this list will be
+identical to the corresponding sublist of the value returned if no
+I<option> is specified).
+If one or more I<option-value> pairs are specified, then the command
+modifies the given option(s) to have the given value(s); in
+this case the command returns an empty string.
+See L<"EMBEDDED IMAGES"> for information on the options that
+are supported.
+
+=item I<$text>-E<gt>B<imageCreate>(I<index, >?I<option, value, ...>?)
+
+This command creates a new image annotation, which will appear
+in the text at the position given by I<index>.
+Any number of I<option-value> pairs may be specified to
+configure the annotation.
+Returns a unique identifier that may be used as an index to refer to
+this image.
+See L<"EMBEDDED IMAGES"> for information on the options that
+are supported, and a description of the identifier returned.
+
+=item I<$text>-E<gt>B<imageNames>
+
+Returns a list whose elements are the names of all image instances currently
+embedded in $text.
+
+=back
+
+=item I<$text>-E<gt>B<index>(I<index>)
+
+Returns the position corresponding to I<index> in the form
+I<line.char> where I<line> is the line number and I<char>
+is the character number.
+I<Index> may have any of the forms described under L<"INDICES"> above.
+
+=item I<$text>-E<gt>B<insert>(I<index, chars, >?I<tagList, chars, tagList, ...>?)
+
+Inserts all of the I<chars> arguments just before the character at
+I<index>.
+If I<index> refers to the end of the text (the character after
+the last newline) then the new text is inserted just before the
+last newline instead.
+If there is a single I<chars> argument and no I<tagList>, then
+the new text will receive any tags that are present on both the
+character before and the character after the insertion point; if a tag
+is present on only one of these characters then it will not be
+applied to the new text.
+If I<tagList> is specified then it consists of a list of
+tag names; the new characters will receive all of the tags in
+this list and no others, regardless of the tags present around
+the insertion point.
+If multiple I<chars>-I<tagList> argument pairs are present,
+they produce the same effect as if a separate B<insert> widget
+command had been issued for each pair, in order.
+The last I<tagList> argument may be omitted.
+
+=item I<$text>-E<gt>B<Insert>(I<string>)
+
+Do NOT confuse this with the lower-case B<insert> method.
+Insert I<string> at the point of the insertion cursor. If there is
+a selection in the text, and it covers the point of the insertion
+cursor, then it deletes the selection before inserting.
+
+=item I<$text>-E<gt>B<InsertKeypress>(I<character>)
+
+Inserts I<character> at the B<insert> mark. If in overstrike mode,
+it firsts deletes the character at the B<insert> mark.
+
+=item I<$text>-E<gt>B<InsertSelection>
+
+Inserts the current selection at the B<insert> mark.
+
+=item I<$text>-E<gt>B<insertTab>
+
+Inserts a tab (\t) character at the B<insert> mark.
+
+=item I<$text>-E<gt>B<mark>(I<option, >?I<arg, arg, ...>?)
+
+This command is used to manipulate marks. The exact behavior of
+the command depends on the I<option> argument that follows
+the B<mark> argument. The following forms of the command
+are currently supported:
+
+=over 8
+
+=item I<$text>-E<gt>B<markGravity>(I<markName, >?I<direction>?)
+
+If I<direction> is not specified, returns B<left> or B<right>
+to indicate which of its adjacent characters I<markName> is attached
+to.
+If I<direction> is specified, it must be B<left> or B<right>;
+the gravity of I<markName> is set to the given value.
+
+=item I<$text>-E<gt>B<markNames>
+
+Returns a list whose elements are the names of all the marks that
+are currently set.
+
+=item I<$text>-E<gt>B<markNext>(I<index>)
+
+Returns the name of the next mark at or after I<index>.
+If I<index> is specified in numerical form, then the search for
+the next mark begins at that index.
+If I<index> is the name of a mark, then the search for
+the next mark begins immediately after that mark.
+This can still return a mark at the same position if
+there are multiple marks at the same index.
+These semantics mean that the B<mark next> operation can be used to
+step through all the marks in a text widget in the same order
+as the mark information returned by the B<dump> operation.
+If a mark has been set to the special B<end> index,
+then it appears to be I<after> B<end> with respect to the B<mark next> operation.
+An empty string is returned if there are no marks after I<index>.
+
+=item I<$text>-E<gt>B<markPrevious>(I<index>)
+
+Returns the name of the mark at or before I<index>.
+If I<index> is specified in numerical form, then the search for
+the previous mark begins with the character just before that index.
+If I<index> is the name of a mark, then the search for
+the next mark begins immediately before that mark.
+This can still return a mark at the same position if
+there are multiple marks at the same index.
+These semantics mean that the B<mark previous> operation can be used to
+step through all the marks in a text widget in the reverse order
+as the mark information returned by the B<dump> operation.
+An empty string is returned if there are no marks before I<index>.
+
+=item I<$text>-E<gt>B<markSet>(I<markName, index>)
+
+Sets the mark named I<markName> to a position just before the
+character at I<index>.
+If I<markName> already exists, it is moved from its old position;
+if it doesn't exist, a new mark is created.
+This command returns an empty string.
+
+=item I<$text>-E<gt>B<markUnset>(I<markName>?, I<markName, markName, ...>?)
+
+Remove the mark corresponding to each of the I<markName> arguments.
+The removed marks will not be usable in indices and will not be
+returned by future calls to ``I<$text>-E<gt>B<markNames>''.
+This command returns an empty string.
+
+=back
+
+=item I<$text>-E<gt>B<markExists>(I<markname>)
+
+Returns true if I<markname> exists - false otherwise.
+
+=item I<$text>-E<gt>B<menu>(I<?menu?>)
+
+If I<menu> reference is given as an argument, then the text widget
+menu is adjusted to use this new I<menu>. If the I<menu> argument
+is B<undef>, then this command disables the current text widget menu.
+If the I<menu> argument is omitted altogether, then the current text
+widget menu reference is returned.
+
+=item I<$text>-E<gt>B<openLine>
+
+Inserts a newline (\n) at the insert mark.
+
+=item I<$text>-E<gt>B<OverstrikeMode>(I<?boolean?>)
+
+Returns the overstrike mode if I<boolean> is omitted or sets the
+overstrike mode to I<boolean>. True means overstrike mode is enabled.
+
+=item I<$text>-E<gt>B<PostPopupMenu>(I<x,y>)
+
+Creates a popup menu at the specified (I<x,y>) pixel coordinates. The
+default menu has File, Edit, Search and View menu items which cascade
+to sub-menus for further commands. There is an implicit E<lt>Button-3E<gt>
+binding to this method that posts the menu over the cursor.
+
+=item I<$text>-E<gt>B<ResetAnchor>
+
+Sets the selection anchor to whichever end is farthest from the index
+argument.
+
+=item I<$text>-E<gt>B<scan>(I<option>, I<args>) or
+
+=item I<$text>-E<gt>B<scan>I<option>(I<args>)
+
+This method is used to implement scanning on texts. It has
+two forms, depending on I<option>:
+
+=over 8
+
+=item I<$text>-E<gt>B<scanMark>(I<x, y>)
+
+Records I<x> and I<y> and the current view in the text window,
+for use in conjunction with later B<scanDragto> method.
+Typically this method is associated with a mouse button press in
+the widget. It returns an empty string.
+
+=item I<$text>-E<gt>B<scanDragto>(I<x, y>)
+
+This command computes the difference between its I<x> and I<y>
+arguments and the I<x> and I<y> arguments to the last
+B<scanMark> method for the widget.
+It then adjusts the view by 10 times the difference in coordinates.
+This command is typically associated
+with mouse motion events in the widget, to produce the effect of
+dragging the text at high speed through the window. The return
+value is an empty string.
+
+=back
+
+=item I<$text>-E<gt>B<search>(?I<switches>,? I<pattern, index, >?I<stopIndex>?)
+
+Searches the text in I<$text> starting at I<index> for a range
+of characters that matches I<pattern>.
+If a match is found, the index of the first character in the match is
+returned as result; otherwise an empty string is returned.
+One or more of the following switches (or abbreviations thereof)
+may be specified to control the search:
+
+=over 8
+
+=item B<-forwards>
+
+The search will proceed forward through the text, finding the first
+matching range starting at or after the position given by I<index>.
+This is the default.
+
+=item B<-backwards>
+
+The search will proceed backward through the text, finding the
+matching range closest to I<index> whose first character
+is before I<index>.
+
+=item B<-exact>
+
+Use exact matching: the characters in the matching range must be
+identical to those in I<pattern>.
+This is the default.
+
+=item B<-regexp>
+
+Treat I<pattern> as a regular expression and match it against
+the text using the rules for regular expressions (see the B<regexp>
+command for details).
+
+=item B<-nocase>
+
+Ignore case differences between the pattern and the text.
+
+=item B<-count>I< varName>
+
+The argument following B<-count> gives the name of a variable;
+if a match is found, the number of characters in the matching
+range will be stored in the variable.
+
+=item B<-hidden>
+
+Find hidden text as well. By default only displayed text is found.
+
+=item B<-->
+
+This switch has no effect except to terminate the list of switches:
+the next argument will be treated as I<pattern> even if it starts
+with B<->.
+
+=back
+
+=back
+
+The matching range must be entirely within a single line of text.
+For regular expression matching the newlines are removed from the ends
+of the lines before matching: use the B<$> feature in regular
+expressions to match the end of a line.
+For exact matching the newlines are retained.
+If I<stopIndex> is specified, the search stops at that index:
+for forward searches, no match at or after I<stopIndex> will
+be considered; for backward searches, no match earlier in the
+text than I<stopIndex> will be considered.
+If I<stopIndex> is omitted, the entire text will be searched:
+when the beginning or end of the text is reached, the search
+continues at the other end until the starting location is reached
+again; if I<stopIndex> is specified, no wrap-around will occur.
+
+=over 4
+
+=item I<$text>-E<gt>B<see>(I<index>)
+
+Adjusts the view in the window so that the character given by I<index>
+is completely visible.
+If I<index> is already visible then the command does nothing.
+If I<index> is a short distance out of view, the command
+adjusts the view just enough to make I<index> visible at the
+edge of the window.
+If I<index> is far out of view, then the command centers
+I<index> in the window.
+
+=item I<$text>-E<gt>B<selectAll>
+
+Selects all the text in the widget.
+
+=item I<$text>-E<gt>B<selectLine>
+
+Selects the line with the insert mark.
+
+=item I<$text>-E<gt>B<selectWord>
+
+Selects the word with the insert mark.
+
+=item I<$text>-E<gt>B<SetCursor>(I<position>)
+
+Moves the insert mark to I<position>.
+
+=item I<$text>-E<gt>B<tag>(I<option, >?I<arg, arg, ...>?)
+
+This command is used to manipulate tags. The exact behavior of the
+command depends on the I<option> argument that follows the
+B<tag> argument. The following forms of the command are currently
+supported:
+
+=over 8
+
+=item I<$text>-E<gt>B<tagAdd>(I<tagName, index1, >?I<index2, index1, index2, ...>?)
+
+Associate the tag I<tagName> with all of the characters starting
+with I<index1> and ending just before
+I<index2> (the character at I<index2> isn't tagged).
+A single command may contain any number of I<index1>-I<index2>
+pairs.
+If the last I<index2> is omitted then the single character at
+I<index1> is tagged.
+If there are no characters in the specified range (e.g. I<index1>
+is past the end of the file or I<index2> is less than or equal
+to I<index1>) then the command has no effect.
+
+=item I<$text>-E<gt>B<tagBind>(I<tagName, >?I<sequence>?, ?I<script>?)
+
+This command associates I<script> with the tag given by
+I<tagName>.
+Whenever the event sequence given by I<sequence> occurs for a
+character that has been tagged with I<tagName>,
+the script will be invoked.
+This method is similar to the B<bind> command except that
+it operates on characters in a text rather than entire widgets.
+See the L<Tk::bind> documentation for complete details
+on the syntax of I<sequence> and the substitutions performed
+on I<script> before invoking it.
+If all arguments are specified then a new binding is created, replacing
+any existing binding for the same I<sequence> and I<tagName>
+(if the first character of I<script> is ``+'' then I<script>
+augments an existing binding rather than replacing it).
+In this case the return value is an empty string.
+If I<script> is omitted then the command returns the I<script>
+associated with I<tagName> and I<sequence> (an error occurs
+if there is no such binding).
+If both I<script> and I<sequence> are omitted then the command
+returns a list of all the sequences for which bindings have been
+defined for I<tagName>.
+
+The only events for which bindings may be specified are those related
+to the mouse and keyboard (such as B<Enter>, B<Leave>,
+B<ButtonPress>, B<Motion>, and B<KeyPress>) or virtual events.
+Event bindings for a text widget use the B<current> mark described
+under L<"MARKS"> above. An B<Enter> event triggers for a tag when the tag
+first becomes present on the current character, and a B<Leave> event
+triggers for a tag when it ceases to be present on the current character.
+B<Enter> and B<Leave> events can happen either because the
+B<current> mark moved or because the character at that position
+changed. Note that these events are different than B<Enter> and
+B<Leave> events for windows. Mouse and keyboard events are directed
+to the current character. If a virtual event is used in a binding, that
+binding can trigger only if the virtual event is defined by an underlying
+mouse-related or keyboard-related event.
+
+It is possible for the current character to have multiple tags,
+and for each of them to have a binding for a particular event
+sequence.
+When this occurs, one binding is invoked for each tag, in order
+from lowest-priority to highest priority.
+If there are multiple matching bindings for a single tag, then
+the most specific binding is chosen (see the the documentation for
+the B<bind> command for details).
+B<continue> and B<break> commands within binding scripts
+are processed in the same way as for bindings created with
+the B<bind> command.
+
+If bindings are created for the widget as a whole using the
+B<bind> command, then those bindings will supplement the
+tag bindings.
+The tag bindings will be invoked first, followed by bindings
+for the window as a whole.
+
+=item I<$text>-E<gt>B<tagCget>(I<tagName, option>)
+
+This command returns the current value of the option named I<option>
+associated with the tag given by I<tagName>.
+I<Option> may have any of the values accepted by the B<tag configure>
+method.
+
+=item I<$text>-E<gt>B<tagConfigure>(I<tagName, >?I<option>?, ?I<value>?, ?I<option, value, ...>?)
+
+This command is similar to the B<configure> method except
+that it modifies options associated with the tag given by I<tagName>
+instead of modifying options for the overall text widget.
+If no I<option> is specified, the command returns a list describing
+all of the available options for I<tagName>
+(see L<Tk::options> for information on the format of this list).
+If I<option> is specified with no I<value>, then the command returns
+a list describing the one named option (this list will be identical to
+the corresponding sublist of the value returned if no I<option>
+is specified).
+If one or more I<option-value> pairs are specified, then the command
+modifies the given option(s) to have the given value(s) in I<tagName>;
+in this case the command returns an empty string.
+See L<"TAGS"> above for details on the options available for tags.
+
+=item I<$text>-E<gt>B<tagDelete>(I<tagName, >?I<tagName, ...>?)
+
+Deletes all tag information for each of the I<tagName>
+arguments.
+The command removes the tags from all characters in the file
+and also deletes any other information associated with the tags,
+such as bindings and display information.
+The command returns an empty string.
+
+=item I<$text>-E<gt>B<tagLower>(I<tagName>?, I<belowThis>?)
+
+Changes the priority of tag I<tagName> so that it is just lower
+in priority than the tag whose name is I<belowThis>.
+If I<belowThis> is omitted, then I<tagName>'s priority
+is changed to make it lowest priority of all tags.
+
+=item I<$text>-E<gt>B<tagNames>(?I<index>?)
+
+Returns a list whose elements are the names of all the tags that
+are active at the character position given by I<index>.
+If I<index> is omitted, then the return value will describe
+all of the tags that exist for the text (this includes all tags
+that have been named in a ``I<$text>-E<gt>B<tag>'' widget
+command but haven't been deleted by a ``I<$text>-E<gt>B<tagDelete>''
+method, even if no characters are currently marked with
+the tag).
+The list will be sorted in order from lowest priority to highest
+priority.
+
+=item I<$text>-E<gt>B<tagNextrange>(I<tagName, index1, >?I<index2>?)
+
+This command searches the text for a range of characters tagged
+with I<tagName> where the first character of the range is
+no earlier than the character at I<index1> and no later than
+the character just before I<index2> (a range starting at
+I<index2> will not be considered).
+If several matching ranges exist, the first one is chosen.
+The command's return value is a list containing
+two elements, which are the index of the first character of the
+range and the index of the character just after the last one in
+the range.
+If no matching range is found then the return value is an
+empty string.
+If I<index2> is not given then it defaults to the end of the text.
+
+=item I<$text>-E<gt>B<tagPrevrange>(I<tagName, index1, >?I<index2>?)
+
+This command searches the text for a range of characters tagged
+with I<tagName> where the first character of the range is
+before the character at I<index1> and no earlier than
+the character at I<index2> (a range starting at
+I<index2> will be considered).
+If several matching ranges exist, the one closest to I<index1> is chosen.
+The command's return value is a list containing
+two elements, which are the index of the first character of the
+range and the index of the character just after the last one in
+the range.
+If no matching range is found then the return value is an
+empty string.
+If I<index2> is not given then it defaults to the beginning of the text.
+
+=item I<$text>-E<gt>B<tagRaise>(I<tagName, >?I<aboveThis>?)
+
+Changes the priority of tag I<tagName> so that it is just higher
+in priority than the tag whose name is I<aboveThis>.
+If I<aboveThis> is omitted, then I<tagName>'s priority
+is changed to make it highest priority of all tags.
+
+=item I<$text>-E<gt>B<tagRanges>(I<tagName>)
+
+Returns a list describing all of the ranges of text that have been
+tagged with I<tagName>.
+The first two elements of the list describe the first tagged range
+in the text, the next two elements describe the second range, and
+so on.
+The first element of each pair contains the index of the first
+character of the range, and the second element of the pair contains
+the index of the character just after the last one in the
+range.
+If there are no characters tagged with I<tag> then an
+empty string is returned.
+
+=item I<$text>-E<gt>B<tagRemove>(I<tagName, index1, >?I<index2, index1, index2, ...>?)
+
+Remove the tag I<tagName> from all of the characters starting
+at I<index1> and ending just before
+I<index2> (the character at I<index2> isn't affected).
+A single command may contain any number of I<index1>-I<index2>
+pairs.
+If the last I<index2> is omitted then the single character at
+I<index1> is tagged.
+If there are no characters in the specified range (e.g. I<index1>
+is past the end of the file or I<index2> is less than or equal
+to I<index1>) then the command has no effect.
+This command returns an empty string.
+
+=back
+
+=item I<$text>-E<gt>B<ToggleInsertMode>
+
+Toggles the current overstrike mode.
+
+=item I<$text>-E<gt>B<unselectAll>
+
+Unselects all the text in the widget.
+
+=item I<$text>-E<gt>B<WhatLineNumberPopup>
+
+Creates a popup that displays the current line number of the
+insert mark.
+
+=item I<$text>->B<widget>(I<option?, arg, arg, ...>?)
+
+=item I<$text>->B<widget>I<Option>(?I<arg, arg, ...>?)
+
+This method is used to manipulate embedded windows.
+The behavior of the method depends on the I<option> argument
+that follows the B<window> argument.
+The following forms of the method are currently supported:
+
+=over 8
+
+=item I<$text>->B<windowCget>(I<index, option>)
+
+Returns the value of a configuration option for an embedded window.
+I<Index> identifies the embedded window, and I<option>
+specifies a particular configuration option, which must be one of
+the ones listed in L<"EMBEDDED WINDOWS"> above.
+
+=item I<$text>->B<windowConfigure>(I<index>?, I<option, value, ...>?)
+
+Query or modify the configuration options for an embedded window.
+If no I<option> is specified, returns a list describing all of
+the available options for the embedded window at I<index>
+(see L<Tk::options> for information on the format of this list).
+If I<option> is specified with no I<value>, then the command
+returns a list describing the one named option (this list will be
+identical to the corresponding sublist of the value returned if no
+I<option> is specified).
+If one or more I<option-value> pairs are specified, then the command
+modifies the given option(s) to have the given value(s); in
+this case the command returns an empty string.
+See L<"EMBEDDED WINDOWS"> above for information on the options that
+are supported.
+
+=item I<$text>->B<windowCreate>(I<index>?, I<option, value, ...>?)
+
+This command creates a new window annotation, which will appear
+in the text at the position given by I<index>.
+Any number of I<option-value> pairs may be specified to
+configure the annotation.
+See L<"EMBEDDED WINDOWS"> above for information on the options that
+are supported.
+Returns an empty string.
+
+=item I<$text>->B<windowNames>
+
+Returns a list whose elements are the names of all windows currently
+embedded in $text.
+
+=back
+
+=item I<$text>->B<xview>(I<option, args>)
+
+This command is used to query and change the horizontal position of the
+text in the widget's window. It can take any of the following
+forms:
+
+=over 8
+
+=item I<$text>->B<xview>
+
+Returns a list containing two elements.
+Each element is a real fraction between 0 and 1; together they describe
+the portion of the document's horizontal span that is visible in
+the window.
+For example, if the first element is .2 and the second element is .6,
+20% of the text is off-screen to the left, the middle 40% is visible
+in the window, and 40% of the text is off-screen to the right.
+The fractions refer only to the lines that are actually visible in the
+window: if the lines in the window are all very short, so that they
+are entirely visible, the returned fractions will be 0 and 1,
+even if there are other lines in the text that are
+much wider than the window.
+These are the same values passed to scrollbars via the B<-xscrollcommand>
+option.
+
+=item I<$text>-E<gt>B<xviewMoveto>(I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the horizontal
+span of the text is off-screen to the left.
+I<Fraction> is a fraction between 0 and 1.
+
+=item I<$text>-E<gt>B<xviewScroll>(I<number, what>)
+
+This command shifts the view in the window left or right according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages> or an abbreviation
+of one of these.
+If I<what> is B<units>, the view adjusts left or right by
+I<number> average-width characters on the display; if it is
+B<pages> then the view adjusts by I<number> screenfuls.
+If I<number> is negative then characters farther to the left
+become visible; if it is positive then characters farther to the right
+become visible.
+
+=back
+
+=item I<$text>-E<gt>B<yview>(I<?args>?)
+
+This command is used to query and change the vertical position of the
+text in the widget's window.
+It can take any of the following forms:
+
+=over 8
+
+=item I<$text>-E<gt>B<yview>
+
+Returns a list containing two elements, both of which are real fractions
+between 0 and 1.
+The first element gives the position of the first character in the
+top line in the window, relative to the text as a whole (0.5 means
+it is halfway through the text, for example).
+The second element gives the position of the character just after
+the last one in the bottom line of the window,
+relative to the text as a whole.
+These are the same values passed to scrollbars via the B<-yscrollcommand>
+option.
+
+=item I<$text>-E<gt>B<yviewMoveto>(I<fraction>)
+
+Adjusts the view in the window so that the character given by I<fraction>
+appears on the top line of the window.
+I<Fraction> is a fraction between 0 and 1; 0 indicates the first
+character in the text, 0.33 indicates the character one-third the
+way through the text, and so on.
+
+=item I<$text>-E<gt>B<yviewScroll>(I<number, what>)
+
+This command adjust the view in the window up or down according to
+I<number> and I<what>.
+I<Number> must be an integer.
+I<What> must be either B<units> or B<pages>.
+If I<what> is B<units>, the view adjusts up or down by
+I<number> lines on the display; if it is B<pages> then
+the view adjusts by I<number> screenfuls.
+If I<number> is negative then earlier positions in the text
+become visible; if it is positive then later positions in the text
+become visible.
+
+=item I<$text>->B<yview>(?B<-pickplace>,? I<index>)
+
+Changes the view in the I<$text>'s window to make I<index> visible.
+If the B<-pickplace> option isn't specified then I<index> will
+appear at the top of the window.
+If B<-pickplace> is specified then the widget chooses where
+I<index> appears in the window:
+
+=over 12
+
+=item [1]
+
+If I<index> is already visible somewhere in the window then the
+command does nothing.
+
+=item [2]
+
+If I<index> is only a few lines off-screen above the window then
+it will be positioned at the top of the window.
+
+=item [3]
+
+If I<index> is only a few lines off-screen below the window then
+it will be positioned at the bottom of the window.
+
+=item [4]
+
+Otherwise, I<index> will be centered in the window.
+
+=back
+
+=back
+
+=back
+
+The B<-pickplace> option has been obsoleted by the B<see> widget
+command (B<see> handles both x- and y-motion to make a location
+visible, whereas B<-pickplace> only handles motion in y).
+
+=over 4
+
+=item I<$text>-E<gt>B<yview>(I<number>)
+
+This command makes the first character on the line after
+the one given by I<number> visible at the top of the window.
+I<Number> must be an integer.
+This command used to be used for scrolling, but now it is obsolete.
+
+=back
+
+=head1 BINDINGS
+
+Tk automatically creates class bindings for texts that give them
+the following default behavior.
+In the descriptions below, ``word'' refers to a contiguous group
+of letters, digits, or ``_'' characters, or any single character
+other than these.
+
+=over 4
+
+=item [1]
+
+Clicking mouse button 1 positions the insertion cursor
+just before the character underneath the mouse cursor, sets the
+input focus to this widget, and clears any selection in the widget.
+Dragging with mouse button 1 strokes out a selection between
+the insertion cursor and the character under the mouse.
+
+=item [2]
+
+Double-clicking with mouse button 1 selects the word under the mouse
+and positions the insertion cursor at the beginning of the word.
+Dragging after a double click will stroke out a selection consisting
+of whole words.
+
+=item [3]
+
+Triple-clicking with mouse button 1 selects the line under the mouse
+and positions the insertion cursor at the beginning of the line.
+Dragging after a triple click will stroke out a selection consisting
+of whole lines.
+
+=item [4]
+
+The ends of the selection can be adjusted by dragging with mouse
+button 1 while the Shift key is down; this will adjust the end
+of the selection that was nearest to the mouse cursor when button
+1 was pressed.
+If the button is double-clicked before dragging then the selection
+will be adjusted in units of whole words; if it is triple-clicked
+then the selection will be adjusted in units of whole lines.
+
+=item [5]
+
+Clicking mouse button 1 with the Control key down will reposition the
+insertion cursor without affecting the selection.
+
+=item [6]
+
+If any normal printing characters are typed, they are
+inserted at the point of the insertion cursor.
+
+=item [7]
+
+The view in the widget can be adjusted by dragging with mouse button 2.
+If mouse button 2 is clicked without moving the mouse, the selection
+is copied into the text at the position of the mouse cursor.
+The Insert key also inserts the selection, but at the position of
+the insertion cursor.
+
+=item [8]
+
+If the mouse is dragged out of the widget
+while button 1 is pressed, the entry will automatically scroll to
+make more text visible (if there is more text off-screen on the side
+where the mouse left the window).
+
+=item [9]
+
+The Left and Right keys move the insertion cursor one character to the
+left or right; they also clear any selection in the text.
+If Left or Right is typed with the Shift key down, then the insertion
+cursor moves and the selection is extended to include the new character.
+Control-Left and Control-Right move the insertion cursor by words, and
+Control-Shift-Left and Control-Shift-Right move the insertion cursor
+by words and also extend the selection.
+Control-b and Control-f behave the same as Left and Right, respectively.
+Meta-b and Meta-f behave the same as Control-Left and Control-Right,
+respectively.
+
+=item [10]
+
+The Up and Down keys move the insertion cursor one line up or
+down and clear any selection in the text.
+If Up or Right is typed with the Shift key down, then the insertion
+cursor moves and the selection is extended to include the new character.
+Control-Up and Control-Down move the insertion cursor by paragraphs (groups
+of lines separated by blank lines), and
+Control-Shift-Up and Control-Shift-Down move the insertion cursor
+by paragraphs and also extend the selection.
+Control-p and Control-n behave the same as Up and Down, respectively.
+
+=item [11]
+
+The Next and Prior keys move the insertion cursor forward or backwards
+by one screenful and clear any selection in the text.
+If the Shift key is held down while Next or Prior is typed, then
+the selection is extended to include the new character.
+Control-v moves the view down one screenful without moving the
+insertion cursor or adjusting the selection.
+
+=item [12]
+
+Control-Next and Control-Prior scroll the view right or left by one page
+without moving the insertion cursor or affecting the selection.
+
+=item [13]
+
+Home and Control-a move the insertion cursor to the
+beginning of its line and clear any selection in the widget.
+Shift-Home moves the insertion cursor to the beginning of the line
+and also extends the selection to that point.
+
+=item [14]
+
+End and Control-e move the insertion cursor to the
+end of the line and clear any selection in the widget.
+Shift-End moves the cursor to the end of the line and extends the selection
+to that point.
+
+=item [15]
+
+Control-Home and Meta-E<lt> move the insertion cursor to the beginning of
+the text and clear any selection in the widget.
+Control-Shift-Home moves the insertion cursor to the beginning of the text
+and also extends the selection to that point.
+
+=item [16]
+
+Control-End and Meta-E<gt> move the insertion cursor to the end of the
+text and clear any selection in the widget.
+Control-Shift-End moves the cursor to the end of the text and extends
+the selection to that point.
+
+=item [17]
+
+The Select key and Control-Space set the selection anchor to the position
+of the insertion cursor. They don't affect the current selection.
+Shift-Select and Control-Shift-Space adjust the selection to the
+current position of the insertion cursor, selecting from the anchor
+to the insertion cursor if there was not any selection previously.
+
+=item [18]
+
+Control-/ selects the entire contents of the widget.
+
+=item [19]
+
+Control-\ clears any selection in the widget.
+
+=item [20]
+
+The F16 key (labelled Copy on many Sun workstations) or Meta-w
+copies the selection in the widget to the clipboard, if there is a selection.
+
+=item [21]
+
+The F20 key (labelled Cut on many Sun workstations) or Control-w
+copies the selection in the widget to the clipboard and deletes
+the selection.
+If there is no selection in the widget then these keys have no effect.
+
+=item [22]
+
+The F18 key (labelled Paste on many Sun workstations) or Control-y
+inserts the contents of the clipboard at the position of the
+insertion cursor.
+
+=item [23]
+
+The Delete key deletes the selection, if there is one in the widget.
+If there is no selection, it deletes the character to the right of
+the insertion cursor.
+
+=item [24]
+
+Backspace and Control-h delete the selection, if there is one
+in the widget.
+If there is no selection, they delete the character to the left of
+the insertion cursor.
+
+=item [25]
+
+Control-d deletes the character to the right of the insertion cursor.
+
+=item [26]
+
+Meta-d deletes the word to the right of the insertion cursor.
+
+=item [27]
+
+Control-k deletes from the insertion cursor to the end of its line;
+if the insertion cursor is already at the end of a line, then
+Control-k deletes the newline character.
+
+=item [28]
+
+Control-o opens a new line by inserting a newline character in
+front of the insertion cursor without moving the insertion cursor.
+
+=item [29]
+
+Meta-backspace and Meta-Delete delete the word to the left of the
+insertion cursor.
+
+=item [30]
+
+Control-x deletes whatever is selected in the text widget.
+
+=item [31]
+
+Control-t reverses the order of the two characters to the right of
+the insertion cursor.
+
+=item [32]
+
+Control-z (and Control-underscore on UNIX when tk_strictMotif is
+true) undoes the last edit action if the -undo option is true.
+Does nothing otherwise.
+
+=item [33]
+
+Control-Z (or Control-y on Windows) reapplies the last undone edit
+action if the -undo option is true. Does nothing otherwise.
+
+=back
+
+If the widget is disabled using the B<-state> option, then its
+view can still be adjusted and text can still be selected,
+but no insertion cursor will be displayed and no text modifications will
+take place.
+
+The behavior of texts can be changed by defining new bindings for
+individual widgets or by redefining the class bindings.
+
+
+=head1 TIED INTERFACE
+
+The Perl/Tk Text widget also has built-in TIEHANDLE methods for
+B<print> and B<printf> statements. This means you can print to file
+handles tied to a Text widget, and the tied methods automatically
+insert the print statement's arguments into the Text widget.
+
+For example:
+
+ #!/usr/local/bin/perl -w
+ use POSIX 'acos';
+ use Tk;
+ use strict;
+
+ my $mw = MainWindow->new;
+ my $text = $mw->Text(qw/-width 40 -height 10/)->pack;
+
+ tie *STDOUT, ref $text, $text;
+
+ print "Hello Text World!\n";
+ printf "pi ~= %1.5f", acos(-1.0);
+
+ MainLoop;
+
+
+=head1 PERFORMANCE ISSUES
+
+Text widgets should run efficiently under a variety
+of conditions. The text widget uses about 2-3 bytes of
+main memory for each byte of text, so texts containing a megabyte
+or more should be practical on most workstations.
+Text is represented internally with a modified B-tree structure
+that makes operations relatively efficient even with large texts.
+Tags are included in the B-tree structure in a way that allows
+tags to span large ranges or have many disjoint smaller ranges
+without loss of efficiency.
+Marks are also implemented in a way that allows large numbers of
+marks.
+In most cases it is fine to have large numbers of unique tags,
+or a tag that has many distinct ranges.
+
+One performance problem can arise if you have hundreds or thousands
+of different tags that all have the following characteristics:
+the first and last ranges of each tag are near the beginning and
+end of the text, respectively,
+or a single tag range covers most of the text widget.
+The cost of adding and deleting tags like this is proportional
+to the number of other tags with the same properties.
+In contrast, there is no problem with having thousands of distinct
+tags if their overall ranges are localized and spread uniformly throughout
+the text.
+
+Very long text lines can be expensive,
+especially if they have many marks and tags within them.
+
+The display line with the insert cursor is redrawn each time the
+cursor blinks, which causes a steady stream of graphics traffic.
+Set the B<-insertofftime> option to 0 avoid this.
+
+=head1 SEE ALSO
+
+L<Tk::ROText|Tk::ROText>
+L<Tk::TextUndo|Tk::TextUndo>
+
+=head1 KEYWORDS
+
+text, widget
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Text/Tag.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Text/Tag.pm
new file mode 100755
index 00000000000..827278eb88c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Text/Tag.pm
@@ -0,0 +1,46 @@
+package Tk::Text::Tag;
+require Tk::Text;
+
+use overload '""' => \&name;
+
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Text/Text/Tag.pm#4 $
+
+sub _apply
+{
+ my $self = shift;
+ my $meth = shift;
+ $self->widget->tag($meth => $self->name,@_);
+}
+
+sub name
+{
+ return shift->[0];
+}
+
+sub widget
+{
+ return shift->[1];
+}
+
+BEGIN
+{
+ my $meth;
+ foreach $meth (qw(cget configure bind add))
+ {
+ *{$meth} = sub { shift->_apply($meth,@_) }
+ }
+}
+
+sub new
+{
+ my $class = shift;
+ my $widget = shift;
+ my $name = shift;
+ my $obj = bless [$name,$widget],$class;
+ $obj->configure(@_) if (@_);
+ return $obj;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TextEdit.pm b/Master/tlpkg/tlperl.straw/lib/Tk/TextEdit.pm
new file mode 100755
index 00000000000..e1ff20b6149
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TextEdit.pm
@@ -0,0 +1,509 @@
+# Copyright (c) 1999 Greg Bartels. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+# Special thanks to Nick Ing-Simmons for pushing a lot of
+# my text edit functionality into Text.pm and TextUndo.pm
+# otherwise, this module would have been monstrous.
+
+# Andy Worhal had it wrong, its "fifteen megabytes of fame"
+# -Greg Bartels
+
+package Tk::TextEdit;
+
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/TextEdit.pm#4 $
+
+use Tk qw (Ev);
+use AutoLoader;
+
+use Text::Tabs;
+
+use base qw(Tk::TextUndo);
+
+Construct Tk::Widget 'TextEdit';
+
+#######################################################################
+#######################################################################
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class,'<F5>', 'IndentSelectedLines');
+ $mw->bind($class,'<F6>', 'UnindentSelectedLines');
+
+ $mw->bind($class,'<F7>', 'CommentSelectedLines');
+ $mw->bind($class,'<F8>', 'UncommentSelectedLines');
+
+ return $class;
+}
+
+# 8 horizontal pixels in the "space" character in default font.
+my $tab_multiplier = 8;
+
+sub debug_code_f1
+{
+ my $w=shift;
+}
+
+sub debug_code_f2
+{
+ my $w=shift;
+}
+
+#######################################################################
+#######################################################################
+sub InitObject
+{
+ my ($w) = @_;
+ $w->SUPER::InitObject;
+
+ $w->{'INDENT_STRING'} = "\t"; # Greg mode=>"\t", Nick mode=>" "
+ $w->{'LINE_COMMENT_STRING'} = "#"; # assuming perl comments
+
+ my %pair_descriptor_hash =
+ (
+ 'PARENS' => [ 'multiline', '(', ')', "[()]" ],
+ 'CURLIES' => [ 'multiline', '{', '}', "[{}]" ],
+ 'BRACES' => [ 'multiline', '[', ']', "[][]" ],
+ 'DOUBLEQUOTE' => [ 'singleline', "\"","\"" ],
+ 'SINGLEQUOTE' => [ 'singleline', "'","'" ],
+ );
+
+ $w->{'HIGHLIGHT_PAIR_DESCRIPTOR_HASH_REF'}=\%pair_descriptor_hash;
+
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_PARENS', -foreground=>'white', -background=>'violet');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_CURLIES', -foreground=>'white', -background=>'blue');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_BRACES', -foreground=>'white', -background=>'purple');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_DOUBLEQUOTE', -foreground=>'black', -background=>'green');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_SINGLEQUOTE', -foreground=>'black', -background=>'grey');
+
+ $w->tagConfigure('BLOCK_HIGHLIGHT_PARENS', -background=>'red');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_CURLIES', -background=>'orange');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_BRACES', -background=>'red');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_DOUBLEQUOTE', -background=>'red');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_SINGLEQUOTE', -background=>'red');
+
+ $w->tagRaise('BLOCK_HIGHLIGHT_PARENS','CURSOR_HIGHLIGHT_PARENS');
+ $w->tagRaise('BLOCK_HIGHLIGHT_CURLIES','CURSOR_HIGHLIGHT_CURLIES');
+ $w->tagRaise('BLOCK_HIGHLIGHT_BRACES','CURSOR_HIGHLIGHT_BRACES');
+ $w->tagRaise('BLOCK_HIGHLIGHT_DOUBLEQUOTE','CURSOR_HIGHLIGHT_DOUBLEQUOTE');
+ $w->tagRaise('BLOCK_HIGHLIGHT_SINGLEQUOTE','CURSOR_HIGHLIGHT_SINGLEQUOTE');
+
+ $w->{'UPDATE_WIDGET_PERIOD'}=300; # how much time between each call.
+ $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}=80;
+ $w->SetGUICallbackIndex(0);
+ $w->schedule_next_callback;
+
+}
+
+#######################################################################
+
+sub cancel_current_gui_callback_and_restart_from_beginning
+{
+ my ($w)=@_;
+ if(defined($w->{'UPDATE_WIDGET_AFTER_REFERENCE'}))
+ {$w->{'UPDATE_WIDGET_AFTER_REFERENCE'}->cancel();}
+ $w->SetGUICallbackIndex(0);
+
+ $w->schedule_next_callback;
+}
+
+sub schedule_next_callback
+{
+ my ($w)=@_;
+ return if $w->NoMoreGUICallbacksToCall; #stops infinite recursive call.
+ $w->{'UPDATE_WIDGET_AFTER_REFERENCE'} = $w->after
+ ($w->{'UPDATE_WIDGET_PERIOD'},
+ sub
+ {
+ $w->CallNextGUICallback;
+ $w->schedule_next_callback;
+ }
+ );
+
+}
+
+
+#######################################################################
+# use these methods to pass the TextEdit widget an anonymous array
+# of code references.
+# any time the widget changes that requires the display to be updated,
+# then these code references will be scheduled in sequence for calling.
+# splitting them up allows them to be prioritized by order,
+# and prevents the widget from "freezing" too long if they were
+# one large callback. scheduling them apart allows the widget time
+# to respond to user inputs.
+#######################################################################
+sub SetGUICallbacks
+{
+ my ($w,$callback_array_ref) = @_;
+ $w->{GUI_CALLBACK_ARRAY_REF}=$callback_array_ref;
+ $w->SetGUICallbackIndex(0);
+}
+
+sub GetGUICallbacks
+{
+ return shift->{GUI_CALLBACK_ARRAY_REF};
+}
+
+sub SetGUICallbackIndex
+{
+ my ($w, $val)=@_;
+ $w->{GUI_CALLBACK_ARRAY_INDEX}=$val;
+}
+
+sub GetGUICallbackIndex
+{
+ return shift->{GUI_CALLBACK_ARRAY_INDEX};
+}
+
+sub IncrementGUICallbackIndex
+{
+ shift->{GUI_CALLBACK_ARRAY_INDEX} += 1;
+}
+
+sub NoMoreGUICallbacksToCall
+{
+ my ($w) = @_;
+ return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_REF});
+ return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_INDEX});
+ my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF};
+ my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX};
+ return $arr_ind >= @$arr_ref;
+}
+
+sub CallNextGUICallback
+{
+ my ($w) = @_;
+ return if $w->NoMoreGUICallbacksToCall;
+ my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF};
+ my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX};
+ &{$arr_ref->[$arr_ind]};
+ $w->IncrementGUICallbackIndex;
+}
+
+
+#######################################################################
+#######################################################################
+
+sub insert
+{
+ my $w = shift;
+ $w->SUPER::insert(@_);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+}
+
+sub delete
+{
+ my $w = shift;
+ $w->SUPER::delete(@_);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+}
+
+sub SetCursor
+{
+ my $w = shift;
+ $w->SUPER::SetCursor(@_);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+}
+
+sub OverstrikeMode
+{
+ my ($w,$mode) = @_;
+ if (defined($mode))
+ {
+ $w->SUPER::OverstrikeMode($mode);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+ }
+ return $w->SUPER::OverstrikeMode;
+}
+
+
+#######################################################################
+# use yview on scrollbar to get fractional coordinates.
+# scale this by the total length of the text to find the
+# approximate start line of widget and end line of widget.
+#######################################################################
+sub GetScreenWindowCoordinates
+{
+ my $w = shift;
+ my ($top_frac, $bot_frac) = $w->yview;
+ my $end_index = $w->index('end');
+ my ($lines,$columns) = split (/\./,$end_index);
+ my $window = $w->{'WINDOW_PLUS_AND_MINUS_VALUE'};
+ my $top_line = int(($top_frac * $lines) - $window);
+ $top_line = 0 if ($top_line < 0);
+ my $bot_line = int(($bot_frac * $lines) + $window);
+ $bot_line = $lines if ($bot_line > $lines);
+ my $top_index = $top_line . '.0';
+ my $bot_index = $bot_line . '.0';
+
+ $_[0] = $top_index;
+ $_[1] = $bot_index;
+}
+
+########################################################################
+# take two indices as inputs.
+# if they are on the same line or same column (accounting for tabs)
+# then return 1
+# else return 0
+# (assume indices passed in are in line.column format)
+########################################################################
+sub IndicesLookGood
+{
+ my ($w, $start, $end, $singleline) = @_;
+
+ return 0 unless ( (defined($start)) and (defined($end)));
+
+ my ($start_line, $start_column) = split (/\./,$start);
+ my ($end_line, $end_column) = split (/\./,$end);
+
+ ##########################
+ # good if on the same line
+ ##########################
+ return 1 if ($start_line == $end_line);
+
+ ##########################
+ # if not on same line and its a singleline, its bad
+ ##########################
+ return 0 if $singleline;
+
+
+ # get both lines, convert the tabs to spaces, and get the new column.
+ # see if they line up or not.
+ my $string;
+ $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
+ $string = substr($string, 0, $start_column+1);
+ $string = expand($string);
+ $start_column = length($string);
+
+ $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
+ $string = substr($string, 0, $end_column +1);
+ $string = expand($string);
+ $end_column = length($string);
+
+ ##########################
+ # good if on the same column (adjusting for tabs)
+ ##########################
+ return 1 if ($start_column == $end_column);
+
+ # otherwise its bad
+ return 0;
+}
+
+########################################################################
+# if searching backward, count paranthesis until find a start parenthesis
+# which does not have a forward match.
+#
+# (<= search backward will return this index
+# ()
+# START X HERE
+# ( ( ) () )
+# )<== search forward will return this index
+#
+# if searching forward, count paranthesis until find a end parenthesis
+# which does not have a rearward match.
+########################################################################
+sub searchForBaseCharacterInPair
+{
+ my
+ (
+ $w, $top_index, $searchfromindex, $bot_index,
+ $direction, $startchar, $endchar, $charpair
+ )=@_;
+ my ($plus_one_char, $search_end_index, $index_offset, $done_index);
+ if ($direction eq '-forward')
+ {
+ $plus_one_char = $endchar;
+ $search_end_index = $bot_index;
+ $index_offset = ' +1c';
+ $done_index = $w->index('end');
+ }
+ else
+ {
+ $plus_one_char = $startchar;
+ $search_end_index = $top_index;
+ $index_offset = '';
+ $done_index = '1.0';
+ }
+
+ my $at_done_index = 0;
+ my $count = 0;
+ my $char;
+ while(1)
+ {
+ $searchfromindex = $w->search
+ ($direction, '-regexp', $charpair, $searchfromindex, $search_end_index );
+
+ last unless(defined($searchfromindex));
+ $char = $w->get($searchfromindex, $w->index($searchfromindex.' +1c'));
+ if ($char eq $plus_one_char)
+ {$count += 1;}
+ else
+ {$count -= 1;}
+ last if ($count==1);
+ # boundary condition exists when first char in widget is the match char
+ # need to be able to determine if search tried to go past index '1.0'
+ # if so, set index to undef and return.
+ if ( $at_done_index )
+ {
+ $searchfromindex = undef;
+ last;
+ }
+ $at_done_index = 1 if ($searchfromindex eq $done_index);
+ $searchfromindex=$w->index($searchfromindex . $index_offset);
+ }
+ return $searchfromindex;
+}
+
+########################################################################
+# highlight a character pair that most closely brackets the cursor.
+# allows you to pick and choose which ones you want to do.
+########################################################################
+
+sub HighlightParenthesisAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( '(', ')', '[()]', 'CURSOR_HIGHLIGHT_PARENS','BLOCK_HIGHLIGHT_PARENS',0);
+}
+
+sub HighlightCurlyBracesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( '{', '}', '[{}]', 'CURSOR_HIGHLIGHT_CURLIES','BLOCK_HIGHLIGHT_CURLIES',0);
+}
+
+sub HighlightBracesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( '[', ']','[][]', 'CURSOR_HIGHLIGHT_BRACES','BLOCK_HIGHLIGHT_BRACES',0);
+}
+
+sub HighlightDoubleQuotesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( "\"", "\"", "\"", 'CURSOR_HIGHLIGHT_DOUBLEQUOTE','BLOCK_HIGHLIGHT_DOUBLEQUOTE',1);
+}
+
+sub HighlightSingleQuotesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( "'", "'", "'", 'CURSOR_HIGHLIGHT_SINGLEQUOTE','BLOCK_HIGHLIGHT_SINGLEQUOTE',1);
+}
+
+########################################################################
+# highlight all the character pairs that most closely bracket the cursor.
+########################################################################
+sub HighlightAllPairsBracketingCursor
+{
+ my ($w)=@_;
+ $w->HighlightParenthesisAroundCursor;
+ $w->HighlightCurlyBracesAroundCursor;
+ $w->HighlightBracesAroundCursor;
+ $w->HighlightDoubleQuotesAroundCursor;
+ $w->HighlightSingleQuotesAroundCursor;
+}
+
+########################################################################
+# search for a pair of matching characters that bracket the
+# cursor and tag them with the given tagname.
+# startchar might be '['
+# endchar would then be ']'
+# tagname is a name of a tag, which has already been
+# configured to highlight however the user wants them to behave.
+# error tagname is the tag to highlight the chars with if there
+# is a problem of some kind.
+# singleline indicates whether the character pairs must occur
+# on a single line. quotation marks are single line characters usually.
+########################################################################
+sub HighlightSinglePairBracketingCursor
+{
+ my
+ (
+ $w, $startchar, $endchar, $charpair,
+ $good_tagname, $bad_tagname, $single_line
+ ) = @_;
+ $single_line=0 unless defined($single_line);
+ $w->tagRemove($good_tagname, '1.0','end');
+ $w->tagRemove($bad_tagname, '1.0','end');
+ my $top_index; my $bot_index;
+ my $cursor = $w->index('insert');
+ if ($single_line)
+ {
+ $top_index = $w->index($cursor.' linestart');
+ $bot_index = $w->index($cursor.' lineend');
+ }
+ else
+ {
+ $w->GetScreenWindowCoordinates($top_index, $bot_index);
+ }
+
+ # search backward for the startchar
+ # $top_index, $searchfromindex, $bot_index,
+ # $direction, $startchar, $endchar, $charpair
+
+ my $startindex = $w->searchForBaseCharacterInPair
+ (
+ $top_index, $cursor, $bot_index,
+ '-backward', $startchar, $endchar, $charpair
+ );
+
+ # search forward for the endchar
+ my $endindex = $w->searchForBaseCharacterInPair
+ (
+ $top_index, $cursor, $bot_index,
+ '-forward', $startchar, $endchar, $charpair
+ );
+ return unless ((defined $startindex) and (defined $endindex));
+
+ my $final_tag = $bad_tagname;
+ if ($w->IndicesLookGood( $startindex, $endindex, $single_line))
+ {
+ $final_tag = $good_tagname;
+ }
+
+ $w->tagAdd($final_tag, $startindex, $w->index($startindex.'+1c') );
+ $w->tagAdd($final_tag, $endindex, $w->index( $endindex.'+1c') );
+}
+
+####################################################################
+sub IndentSelectedLines
+{
+ my($w)=@_;
+ $w->insertStringAtStartOfSelectedLines($w->{'INDENT_STRING'});
+}
+
+sub UnindentSelectedLines
+{
+ my($w)=@_;
+ $w->deleteStringAtStartOfSelectedLines($w->{'INDENT_STRING'});
+}
+
+sub CommentSelectedLines
+{
+ my($w)=@_;
+ $w->insertStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'});
+}
+
+sub UncommentSelectedLines
+{
+ my($w)=@_;
+ $w->deleteStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'});
+}
+
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TextList.pm b/Master/tlpkg/tlperl.straw/lib/Tk/TextList.pm
new file mode 100755
index 00000000000..40c4c6ee7eb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TextList.pm
@@ -0,0 +1,982 @@
+# Copyright (c) 1999 Greg London. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+# code for bindings taken from Listbox.pm
+
+# comments specifying method functionality taken from
+# "Perl/Tk Pocket Reference" by Stephen Lidie.
+
+#######################################################################
+# this module uses a text module as its base class to create a list box.
+# this will allow list box functionality to also have all the functionality
+# of the Text widget.
+#
+# note that most methods use an element number to indicate which
+# element in the list to work on.
+# the exception to this is the tag and mark methods which
+# are dual natured. These methods may accept either the
+# normal element number, or they will also take a element.char index,
+# which would be useful for applying tags to part of a line in the list.
+#
+#######################################################################
+
+package Tk::TextList;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/TextList/TextList.pm#5 $
+
+use base qw(Tk::Derived Tk::ReindexedROText );
+
+use Tk qw (Ev);
+
+Construct Tk::Widget 'TextList';
+
+#######################################################################
+# the following line causes Populate to get called
+# @ISA = qw(Tk::Derived ... );
+#######################################################################
+sub Populate
+{
+ my ($w,$args)=@_;
+ my $option=delete $args->{'-selectmode'};
+ $w->SUPER::Populate($args);
+ $w->ConfigSpecs( -selectmode => ['PASSIVE','selectMode','SelectMode','browse'],
+ -takefocus => ['PASSIVE','takeFocus','TakeFocus',1],
+ -spacing3 => ['SELF', undef, undef, 3],
+ -insertwidth => ['SELF', undef, undef, 0],
+ );
+
+}
+
+#######################################################################
+#######################################################################
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ # Standard Motif bindings:
+ $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+
+ $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
+
+ $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<Up>',['UpDown',-1]);
+ $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
+ $mw->bind($class,'<Down>',['UpDown',1]);
+ $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
+
+ $mw->XscrollBind($class);
+ $mw->PriorNextBind($class);
+
+ $mw->bind($class,'<Control-Home>','Cntrl_Home');
+
+ $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
+ $mw->bind($class,'<Control-End>','Cntrl_End');
+
+ $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
+ $class->clipboardOperations($mw,'Copy');
+ $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Escape>','Cancel');
+ $mw->bind($class,'<Control-slash>','SelectAll');
+ $mw->bind($class,'<Control-backslash>','Cntrl_backslash');
+ ;
+ # Additional Tk bindings that aren't part of the Motif look and feel:
+ $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<FocusIn>' , ['tagConfigure','_ACTIVE_TAG', -underline=>1]);
+ $mw->bind($class,'<FocusOut>', ['tagConfigure','_ACTIVE_TAG', -underline=>0]);
+
+ return $class;
+}
+
+#######################################################################
+# set the active element to index
+# "active" is a text "mark" which underlines the marked text.
+#######################################################################
+sub activate
+{
+ my($w,$element)=@_;
+ $element= $w->index($element).'.0';
+ $w->SUPER::tag('remove', '_ACTIVE_TAG', '1.0','end');
+ $w->SUPER::tag('add', '_ACTIVE_TAG',
+ $element.' linestart', $element.' lineend');
+ $w->SUPER::mark('set', 'active', $element);
+}
+
+
+#######################################################################
+# bbox returns a list (x,y,width,height) giving an approximate
+# bounding box of character given by index
+#######################################################################
+sub bbox
+{
+ my($w,$element)=@_;
+ $element=$w->index($element).'.0' unless ($element=~/\./);
+ return $w->SUPER::bbox($element);
+}
+
+#######################################################################
+# returns a list of indices of all elements currently selected
+#######################################################################
+sub curselection
+{
+ my ($w)=@_;
+ my @ranges = $w->SUPER::tag('ranges', 'sel');
+ my @selection_list;
+ while (@ranges)
+ {
+ my ($first,$firstcol) = split(/\./,shift(@ranges));
+ my ($last,$lastcol) = split(/\./,shift(@ranges));
+
+ #########################################################################
+ # if previous selection ended on the same line that this selection starts,
+ # then fiddle the numbers so that this line number isnt included twice.
+ #########################################################################
+ if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
+ {
+ $first++; # count this selection starting from the next line.
+ }
+
+ if ($lastcol==0)
+ {
+ $last-=1;
+ }
+
+ #########################################################################
+ # if incrementing $first causes it to be greater than $last,
+ # then do nothing,
+ # else add (first .. last) to list
+ #########################################################################
+ unless ($first>$last)
+ {
+ push(@selection_list, $first .. $last);
+ }
+ }
+ return @selection_list;
+}
+
+
+#######################################################################
+# deletes range of elements from element1 to element2
+# defaults to element1
+#######################################################################
+sub delete
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $w->SUPER::delete($element1.'.0' , $element2.'.0 lineend');
+}
+
+#######################################################################
+# deletes range of characters from index1 to index2
+# defaults to index1+1c
+# index is line.char notation.
+#######################################################################
+sub deleteChar
+{
+ my ($w, $index1, $index2)=@_;
+ $index1=$w->index($index1);
+ $index2=$index1.' +1c' unless(defined($index2));
+ $index2=$w->index($index2);
+ $w->SUPER::delete($index1, $index2);
+}
+
+#######################################################################
+# returns as a list contents of elements from $element1 to $element2
+# defaults to element1.
+#######################################################################
+sub get
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ my @getlist;
+ for(my $i=$element1; $i<=$element2; $i++)
+ {
+ push(@getlist, $w->SUPER::get($i.'.0 linestart', $i.'.0 lineend'));
+ }
+
+ return @getlist;
+}
+
+#######################################################################
+# return text between index1 and index2 which are line.char notation.
+# return value is a single string. index2 defaults to index1+1c
+# index is line.char notation.
+######################################################################
+sub getChar
+{
+ my $w=shift;
+ return $w->SUPER::get(@_);
+}
+
+#######################################################################
+# returns index in number notation
+# this method returns an element number, ie the 5th element.
+#######################################################################
+sub index
+{
+ my ($w,$element)=@_;
+ return undef unless(defined($element));
+ $element=0 if $element<0;
+ $element .= '.0' unless $element=~/\D/;
+ $element = $w->SUPER::index($element);
+ my($line,$col)=split(/\./,$element);
+ return $line;
+}
+
+#######################################################################
+# returns index in line.char notation
+# this method returns an index specific to a character within an element
+#######################################################################
+sub indexChar
+{
+ my $w=shift;
+ return $w->SUPER::index(@_);
+}
+
+
+#######################################################################
+# inserts specified elements just before element at index
+#######################################################################
+sub insert
+{
+ my $w=shift;
+ my $element=shift;
+ $element=$w->index($element);
+ my $item;
+ while (@_)
+ {
+ $item = shift(@_);
+ $item .= "\n";
+ $w->SUPER::insert($element++.'.0', $item);
+ }
+}
+
+#######################################################################
+# inserts string just before character at index.
+# index is line.char notation.
+#######################################################################
+sub insertChar
+{
+ my $w=shift;
+ $w->SUPER::insert(@_);
+}
+
+
+
+#######################################################################
+# returns index of element nearest to y-coordinate
+#
+# currently not defined
+#######################################################################
+#sub nearest
+#{
+# return undef;
+#}
+
+#######################################################################
+# Sets the selection anchor to element at index
+#######################################################################
+sub selectionAnchor
+{
+ my ($w, $element)=@_;
+ $element=$w->index($element);
+ $w->SUPER::mark('set', 'anchor', $element.'.0');
+}
+
+#######################################################################
+# deselects elements between index1 and index2, inclusive
+#######################################################################
+sub selectionClear
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $w->SUPER::tag('remove', 'sel', $element1.'.0', $element2.'.0 lineend +1c');
+}
+
+#######################################################################
+# returns 1 if element at index is selected, 0 otherwise.
+#######################################################################
+sub selectionIncludes
+{
+ my ($w, $element)=@_;
+ $element=$w->index($element);
+ my @list = $w->curselection;
+ my $line;
+ foreach $line (@list)
+ {
+ if ($line == $element) {return 1;}
+ }
+ return 0;
+}
+
+#######################################################################
+# adds all elements between element1 and element2 inclusive to selection
+#######################################################################
+sub selectionSet
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $w->SUPER::tag('add', 'sel', $element1.'.0', $element2.'.0 lineend +1c');
+}
+
+#######################################################################
+# for ->selection(option,args) calling convention
+#######################################################################
+sub selection
+{
+# my ($w,$sub)=(shift,"selection".ucfirst(shift));
+# no strict 'refs';
+# # can't use $w->$sub, since it might call overridden method-- bleh
+# &($sub)($w,@_);
+}
+
+
+#######################################################################
+# adjusts the view in window so element at index is completely visible
+#######################################################################
+sub see
+{
+ my ($w, $element)=@_;
+ $element=$w->index($element);
+ $w->SUPER::see($element.'.0');
+}
+
+#######################################################################
+# returns number of elements in listbox
+#######################################################################
+sub size
+{
+ my ($w)=@_;
+ my $element = $w->index('end');
+ # theres a weird thing with the 'end' mark sometimes being on a line
+ # with text, and sometimes being on a line all by itself
+ my ($text) = $w->get($element);
+ if (length($text) == 0)
+ {$element -= 1;}
+ return $element;
+}
+
+
+
+#######################################################################
+# add a tag based on element numbers
+#######################################################################
+sub tagAdd
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1.' lineend' unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ $w->SUPER::tag('add', $tagName, $element1, $element2);
+}
+
+#######################################################################
+# add a tag based on line.char indexes
+#######################################################################
+sub tagAddChar
+{
+ my $w=shift;
+ $w->SUPER::tag('add',@_);
+}
+
+
+#######################################################################
+# remove a tag based on element numbers
+#######################################################################
+sub tagRemove
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1.' lineend' unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ $w->SUPER::tag('remove', 'sel', $element1, $element2);
+}
+
+#######################################################################
+# remove a tag based on line.char indexes
+#######################################################################
+sub tagRemoveChar
+{
+ my $w=shift;
+ $w->SUPER::tag('remove', @_);
+}
+
+
+
+
+#######################################################################
+# perform tagNextRange based on element numbers
+#######################################################################
+sub tagNextRange
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ my $index = $w->SUPER::tag('nextrange', 'sel', $element1, $element2);
+ my ($line,$col)=split(/\./,$index);
+ return $line;
+}
+
+#######################################################################
+# perform tagNextRange based on line.char indexes
+#######################################################################
+sub tagNextRangeChar
+{
+ my $w=shift;
+ $w->SUPER::tag('nextrange', @_);
+}
+
+#######################################################################
+# perform tagPrevRange based on element numbers
+#######################################################################
+sub tagPrevRange
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ my $index = $w->SUPER::tag('prevrange', 'sel', $element1, $element2);
+ my ($line,$col)=split(/\./,$index);
+ return $line;
+}
+
+#######################################################################
+# perform tagPrevRange based on line.char indexes
+#######################################################################
+sub tagPrevRangeChar
+{
+ my $w=shift;
+ $w->SUPER::tag('prevrange', @_);
+}
+
+
+
+#######################################################################
+# perform markSet based on element numbers
+#######################################################################
+sub markSet
+{
+ my ($w,$mark,$element1)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+ $w->SUPER::mark('set', $element1,$mark);
+}
+
+#######################################################################
+# perform markSet based on line.char indexes
+#######################################################################
+sub markSetChar
+{
+ my $w=shift;
+ $w->SUPER::mark('set', @_);
+}
+
+#######################################################################
+# perform markNext based on element numbers
+#######################################################################
+sub markNext
+{
+ my ($w,$element1)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+ return $w->SUPER::mark('next', $element1);
+}
+
+#######################################################################
+# perform markNext based on line.char indexes
+#######################################################################
+sub markNextChar
+{
+ my $w=shift;
+ $w->SUPER::mark('next', @_);
+}
+
+
+#######################################################################
+# perform markPrevious based on element numbers
+#######################################################################
+sub markPrevious
+{
+ my ($w,$element1)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+ return $w->SUPER::mark('previous', $element1);
+}
+
+#######################################################################
+# perform markPrevious based on line.char indexes
+#######################################################################
+sub markPreviousChar
+{
+ my $w=shift;
+ $w->SUPER::mark('previous', @_);
+}
+
+
+
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat;
+ $w->activate($Ev->xy);
+}
+
+
+sub Cntrl_Home
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate(0);
+ $w->see(0);
+ $w->selectionClear(0,'end');
+ $w->selectionSet(0)
+}
+
+
+sub Cntrl_End
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate('end');
+ $w->see('end');
+ $w->selectionClear(0,'end');
+ $w->selectionSet('end')
+}
+
+
+sub Cntrl_backslash
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if ($w->cget('-selectmode') ne 'browse')
+ {
+ $w->selectionClear(0,'end');
+ }
+}
+
+# BeginSelect --
+#
+# This procedure is typically invoked on button-1 presses. It begins
+# the process of making a selection in the listbox. Its exact behavior
+# depends on the selection mode currently in effect for the listbox;
+# see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginSelect
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'multiple')
+ {
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ }
+ else
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ my @list = ();
+ $w->{'SELECTION_LIST_REF'} = \@list;
+ $w->{'PREVIOUS_ELEMENT'} = $el
+ }
+ $w->focus if ($w->cget('-takefocus'));
+}
+# Motion --
+#
+# This procedure is called to process mouse motion events while
+# button 1 is down. It may move or extend the selection, depending
+# on the listbox's selection mode.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element under the pointer (must be a number).
+sub Motion
+{
+ my $w = shift;
+ my $el = shift;
+ if (defined($w->{'PREVIOUS_ELEMENT'}) && $el == $w->{'PREVIOUS_ELEMENT'})
+ {
+ return;
+ }
+
+ # if no selections, select current
+ if($w->curselection==0)
+ {
+ $w->activate($el);
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ $w->{'PREVIOUS_ELEMENT'}=$el;
+ return;
+ }
+
+ my $anchor = $w->index('anchor');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $w->{'PREVIOUS_ELEMENT'} = $el;
+ }
+ elsif ($mode eq 'extended')
+ {
+ my $i = $w->{'PREVIOUS_ELEMENT'};
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionSet('anchor',$el)
+ }
+ else
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionClear('anchor',$el)
+ }
+ while ($i < $el && $i < $anchor)
+ {
+ if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i += 1
+ }
+ while ($i > $el && $i > $anchor)
+ {
+ if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i += -1
+ }
+ $w->{'PREVIOUS_ELEMENT'} = $el
+ }
+}
+# BeginExtend --
+#
+# This procedure is typically invoked on shift-button-1 presses. It
+# begins the process of extending a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginExtend
+{
+ my $w = shift;
+ my $el = shift;
+
+ # if no selections, select current
+ if($w->curselection==0)
+ {
+ $w->activate($el);
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ $w->{'PREVIOUS_ELEMENT'}=$el;
+ return;
+ }
+
+ if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+}
+# BeginToggle --
+#
+# This procedure is typically invoked on control-button-1 presses. It
+# begins the process of toggling a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginToggle
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended')
+ {
+ my @list = $w->curselection();
+ $w->{'SELECTION_LIST_REF'} = \@list;
+ $w->{'PREVIOUS_ELEMENT'} = $el;
+ $w->selectionAnchor($el);
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+# y - The y-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ if ($y >= $w->height)
+ {
+ $w->yview('scroll',1,'units')
+ }
+ elsif ($y < 0)
+ {
+ $w->yview('scroll',-1,'units')
+ }
+ elsif ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->Motion($w->index("@" . $x . ',' . $y));
+ $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
+}
+# UpDown --
+#
+# Moves the location cursor (active element) up or down by one element,
+# and changes the selection if we're in browse or extended selection
+# mode.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub UpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ $w->activate($w->index('active')+$amount);
+ $w->see('active');
+ my $selectmode = $w->cget('-selectmode');
+ if ($selectmode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ elsif ($selectmode eq 'extended')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->selectionAnchor('active');
+ $w->{'PREVIOUS_ELEMENT'} = $w->index('active');
+ my @list = ();
+ $w->{'SELECTION_LIST_REF'}=\@list;
+ }
+}
+# ExtendUpDown --
+#
+# Does nothing unless we're in extended selection mode; in this
+# case it moves the location cursor (active element) up or down by
+# one element, and extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub ExtendUpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ if ($w->cget('-selectmode') ne 'extended')
+ {
+ return;
+ }
+ $w->activate($w->index('active')+$amount);
+ $w->see('active');
+ $w->Motion($w->index('active'))
+}
+# DataExtend
+#
+# This procedure is called for key-presses such as Shift-KEndData.
+# If the selection mode isn't multiple or extend then it does nothing.
+# Otherwise it moves the active element to el and, if we're in
+# extended mode, extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# el - An integer element number.
+sub DataExtend
+{
+ my $w = shift;
+ my $el = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'extended')
+ {
+ $w->activate($el);
+ $w->see($el);
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->activate($el);
+ $w->see($el)
+ }
+}
+# Cancel
+#
+# This procedure is invoked to cancel an extended selection in
+# progress. If there is an extended selection in progress, it
+# restores all of the items between the active one and the anchor
+# to their previous selection state.
+#
+# Arguments:
+# w - The listbox widget.
+sub Cancel
+{
+ my $w = shift;
+ if ($w->cget('-selectmode') ne 'extended' || !defined $w->{'PREVIOUS_ELEMENT'})
+ {
+ return;
+ }
+ my $first = $w->index('anchor');
+ my $last = $w->{'PREVIOUS_ELEMENT'};
+ if ($first > $last)
+ {
+ ($first,$last)=($last,$first);
+ }
+ $w->selectionClear($first,$last);
+ while ($first <= $last)
+ {
+ if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$first) >= 0)
+ {
+ $w->selectionSet($first)
+ }
+ $first += 1
+ }
+}
+# SelectAll
+#
+# This procedure is invoked to handle the "select all" operation.
+# For single and browse mode, it just selects the active element.
+# Otherwise it selects everything in the widget.
+#
+# Arguments:
+# w - The listbox widget.
+sub SelectAll
+{
+ my $w = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ else
+ {
+ $w->selectionSet(0,'end')
+ }
+}
+
+sub SetList
+{
+ my $w = shift;
+ $w->delete(0,'end');
+ $w->insert('end',@_);
+}
+
+sub deleteSelected
+{
+ my $w = shift;
+ my $i;
+ foreach $i (reverse $w->curselection)
+ {
+ $w->delete($i);
+ }
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ my $element = $w->index('active') || $w->index($w->XEvent->xy);
+ my $str;
+ eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
+ return if $@;
+ foreach (split("\n",$str))
+ {
+ $w->insert($element++,$_);
+ }
+}
+
+sub getSelected
+{
+ my ($w) = @_;
+ my $i;
+ my (@result) = ();
+ foreach $i ($w->curselection)
+ {
+ push(@result,$w->get($i));
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TextUndo.pm b/Master/tlpkg/tlperl.straw/lib/Tk/TextUndo.pm
new file mode 100755
index 00000000000..066e4027a3a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TextUndo.pm
@@ -0,0 +1,1022 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons.
+# Copyright (c) 1999 Greg London.
+# All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::TextUndo;
+
+use vars qw($VERSION $DoDebug);
+$VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/TextUndo.pm#15 $
+$DoDebug = 0;
+
+use Tk qw (Ev);
+use AutoLoader;
+
+use Tk::Text ();
+use base qw(Tk::Text);
+
+Construct Tk::Widget 'TextUndo';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<<Undo>>','undo');
+ $mw->bind($class,'<<Redo>>','redo');
+
+ return $class->SUPER::ClassInit($mw);
+}
+
+
+####################################################################
+# methods for manipulating the undo and redo stacks.
+# no one should directly access the stacks except for these methods.
+# everyone else must access the stacks through these methods.
+####################################################################
+sub ResetUndo
+{
+ my ($w) = @_;
+ delete $w->{UNDO};
+ delete $w->{REDO};
+}
+
+sub PushUndo
+{
+ my $w = shift;
+ $w->{UNDO} = [] unless (exists $w->{UNDO});
+ push(@{$w->{UNDO}},@_);
+}
+
+sub PushRedo
+{
+ my $w = shift;
+ $w->{REDO} = [] unless (exists $w->{REDO});
+ push(@{$w->{REDO}},@_);
+}
+
+sub PopUndo
+{
+ my ($w) = @_;
+ return pop(@{$w->{UNDO}}) if defined $w->{UNDO};
+ return undef;
+}
+
+sub PopRedo
+{
+ my ($w) = @_;
+ return pop(@{$w->{REDO}}) if defined $w->{REDO};
+ return undef;
+}
+
+sub ShiftRedo
+{
+ my ($w) = @_;
+ return shift(@{$w->{REDO}}) if defined $w->{REDO};
+ return undef;
+}
+
+sub numberChanges
+{
+ my ($w) = @_;
+ return 0 unless (exists $w->{'UNDO'}) and (defined($w->{'UNDO'}));
+ return scalar(@{$w->{'UNDO'}});
+}
+
+sub SizeRedo
+{
+ my ($w) = @_;
+ return 0 unless exists $w->{'REDO'};
+ return scalar(@{$w->{'REDO'}});
+}
+
+sub getUndoAtIndex
+{
+ my ($w,$index) = @_;
+ return undef unless (exists $w->{UNDO});
+ return $w->{UNDO}[$index];
+}
+
+sub getRedoAtIndex
+{
+ my ($w,$index) = @_;
+ return undef unless (exists $w->{REDO});
+ return $w->{REDO}[$index];
+}
+
+####################################################################
+# type "hello there"
+# hello there_
+# hit UNDO
+# hello_
+# type "out"
+# hello out_
+# pressing REDO should not do anything
+# pressing UNDO should make "out" disappear.
+# pressing UNDO should make "there" reappear.
+# pressing UNDO should make "there" disappear.
+# pressing UNDO should make "hello" disappear.
+#
+# if there is anything in REDO stack and
+# the OperationMode is normal, (i.e. not in the middle of an ->undo or ->redo)
+# then before performing the current operation
+# take the REDO stack, and put it on UNDO stack
+# such that UNDO/REDO keystrokes will still make logical sense.
+#
+# call this method at the beginning of any overloaded method
+# which adds operations to the undo or redo stacks.
+# it will perform all the magic needed to handle the redo stack.
+####################################################################
+sub CheckForRedoShuffle
+{
+ my ($w) = @_;
+ my $size_redo = $w->SizeRedo;
+ return unless $size_redo && ($w->OperationMode eq 'normal');
+ # local $DoDebug = 1;
+
+ # we are about to 'do' something new, but have something in REDO stack.
+ # The REDOs may conflict with new ops, but we want to preserve them.
+ # So convert them to UNDOs - effectively do them and their inverses
+ # so net effect on the widget is no-change.
+
+ $w->dump_array('StartShuffle');
+
+ $w->OperationMode('REDO_MAGIC');
+ $w->MarkSelectionsSavePositions;
+
+ my @pvtundo;
+
+ # go through REDO array from end downto 0, i.e. pseudo pop
+ # then pretend we did 'redo' get inverse, and push into UNDO array
+ # and 'do' the op.
+ for (my $i=$size_redo-1; $i>=0 ; $i--)
+ {
+ my ($op,@args) = @{$w->getRedoAtIndex($i)};
+ my $op_undo = $op .'_UNDO';
+ # save the inverse of the op on the UNDO array
+ # do this before the re-doing the op - after a 'delete' we cannot see
+ # text we deleted!
+ my $undo = $w->$op_undo(@args);
+ $w->PushUndo($undo);
+ # We must 'do' the operation now so if this is an insert
+ # the text and tags are available for inspection in delete_UNDO, and
+ # indices reflect changes.
+ $w->$op(@args);
+ # Save the undo that will reverse what we just did - it is
+ # on the undo stack but will be tricky to find
+ push(@pvtundo,$undo);
+ }
+
+ # Now shift each item off REDO array until empty
+ # push each item onto UNDO array - this reverses the order
+ # and we are not altering buffer so we cannot look in the
+ # buffer to compute inverses - which is why we saved them above
+
+ while ($w->SizeRedo)
+ {
+ my $ref = $w->ShiftRedo;
+ $w->PushUndo($ref);
+ }
+
+ # Finally undo whatever we did to compensate for doing it
+ # and get buffer back to state it was before we started.
+ while (@pvtundo)
+ {
+ my ($op,@args) = @{pop(@pvtundo)};
+ $w->$op(@args);
+ }
+
+ $w->RestoreSelectionsMarkedSaved;
+ $w->OperationMode('normal');
+ $w->dump_array('EndShuffle');
+}
+
+# sets/returns undo/redo/normal operation mode
+sub OperationMode
+{
+ my ($w,$mode) = @_;
+ $w->{'OPERATION_MODE'} = $mode if (@_ > 1);
+ $w->{'OPERATION_MODE'} = 'normal' unless exists($w->{'OPERATION_MODE'});
+ return $w->{'OPERATION_MODE'};
+}
+
+####################################################################
+# dump the undo and redo stacks to the screen.
+# used for debug purposes.
+sub dump_array
+{
+ return unless $DoDebug;
+ my ($w,$why) = @_;
+ print "At $why:\n";
+ foreach my $key ('UNDO','REDO')
+ {
+ if (defined($w->{$key}))
+ {
+ print " $key array is:\n";
+ my $array = $w->{$key};
+ foreach my $ref (@$array)
+ {
+ my @items;
+ foreach my $item (@$ref)
+ {
+ my $loc = $item;
+ $loc =~ tr/\n/\^/;
+ push(@items,$loc);
+ }
+ print " [",join(',',@items),"]\n";
+ }
+ }
+ }
+ print "\n";
+}
+
+
+############################################################
+############################################################
+# these are a group of methods used to indicate the start and end of
+# several operations that are to be undo/redo 'ed in a single step.
+#
+# in other words, "glob" a bunch of operations together.
+#
+# for example, a search and replace should be undone with a single
+# keystroke, rather than one keypress undoes the insert and another
+# undoes the delete.
+# all other methods should access the count via these methods.
+# no other method should directly access the {GLOB_COUNT} value directly
+#############################################################
+#############################################################
+
+sub AddOperation
+{
+ my ($w,@operation) = @_;
+ my $mode = $w->OperationMode;
+
+ if ($mode eq 'normal')
+ {$w->PushUndo([@operation]);}
+ elsif ($mode eq 'undo')
+ {$w->PushRedo([@operation]);}
+ elsif ($mode eq 'redo')
+ {$w->PushUndo([@operation]);}
+ else
+ {die "invalid destination '$mode', must be one of 'normal', 'undo' or 'redo'";}
+}
+
+sub addGlobStart # add it to end of undo list
+{
+ my ($w, $who) = @_;
+ unless (defined($who)) {$who = (caller(1))[3];}
+ $w->CheckForRedoShuffle;
+ $w->dump_array('Start'.$who);
+ $w->AddOperation('GlobStart', $who) ;
+}
+
+sub addGlobEnd # add it to end of undo list
+{
+ my ($w, $who) = @_;
+ unless (defined($who)) {$who = (caller(1))[3];}
+ my $topundo = $w->getUndoAtIndex(-1);
+ if ($topundo->[0] eq 'GlobStart')
+ {
+ $w->PopUndo;
+ }
+ else
+ {
+ my $nxtundo = $w->getUndoAtIndex(-2);
+ if ($nxtundo->[0] eq 'GlobStart')
+ {
+ $w->PopUndo;
+ $w->PopUndo;
+ $w->PushUndo($topundo);
+ }
+ else
+ {
+ $w->AddOperation('GlobEnd', $who);
+ }
+ }
+ $w->dump_array('End'.$who);
+}
+
+sub GlobStart
+{
+ my ($w, $who) = @_;
+ unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->PushUndo($w->GlobStart_UNDO($who));
+ }
+ $w->{GLOB_COUNT} = $w->{GLOB_COUNT} + 1;
+}
+
+sub GlobStart_UNDO
+{
+ my ($w, $who) = @_;
+ $who = 'GlobEnd_UNDO' unless defined($who);
+ return ['GlobEnd',$who];
+}
+
+sub GlobEnd
+{
+ my ($w, $who) = @_;
+ unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->PushUndo($w->GlobStart_UNDO($who));
+ }
+ $w->{GLOB_COUNT} = $w->{GLOB_COUNT} - 1;
+}
+
+sub GlobEnd_UNDO
+{
+ my ($w, $who) = @_;
+ $who = 'GlobStart_UNDO' unless defined($who);
+ return ['GlobStart',$who];
+}
+
+sub GlobCount
+{
+ my ($w,$count) = @_;
+ unless ( exists($w->{'GLOB_COUNT'}) and defined($w->{'GLOB_COUNT'}) )
+ {
+ $w->{'GLOB_COUNT'}=0;
+ }
+ if (defined($count))
+ {
+ $w->{'GLOB_COUNT'}=$count;
+ }
+ return $w->{'GLOB_COUNT'};
+}
+
+####################################################################
+# two methods should be used by applications to access undo and redo
+# capability, namely, $w->undo; and $w->redo; methods.
+# these methods undo and redo the last operation, respectively.
+####################################################################
+sub undo
+{
+ my ($w) = @_;
+ $w->dump_array('Start'.'undo');
+ unless ($w->numberChanges) {$w->bell; return;} # beep and return if empty
+ $w->GlobCount(0); #initialize to zero
+ $w->OperationMode('undo');
+ do
+ {
+ my ($op,@args) = @{$w->PopUndo}; # get undo operation, convert ref to array
+ my $undo_op = $op .'_UNDO';
+ $w->PushRedo($w->$undo_op(@args)); # find out how to undo it
+ $w->$op(@args); # do the operation
+ } while($w->GlobCount and $w->numberChanges);
+ $w->OperationMode('normal');
+ $w->dump_array('End'.'undo');
+}
+
+sub redo
+{
+ my ($w) = @_;
+ unless ($w->SizeRedo) {$w->bell; return;} # beep and return if empty
+ $w->OperationMode('redo');
+ $w->GlobCount(0); #initialize to zero
+ do
+ {
+ my ($op,@args) = @{$w->PopRedo}; # get op from redo stack, convert to list
+ my $undo_op = $op .'_UNDO';
+ $w->PushUndo($w->$undo_op(@args)); # figure out how to undo operation
+ $w->$op(@args); # do the operation
+ } while($w->GlobCount and $w->SizeRedo);
+ $w->OperationMode('normal');
+}
+
+
+############################################################
+# override low level subroutines so that they work with UNDO/REDO capability.
+# every overridden subroutine must also have a corresponding *_UNDO subroutine.
+# the *_UNDO method takes the same parameters in and returns an array reference
+# which is how to undo itself.
+# note that the *_UNDO must receive absolute indexes.
+# ->insert receives 'markname' as the starting index.
+# ->insert must convert 'markname' using $absindex=$w->index('markname')
+# and pass $absindex to ->insert_UNDO.
+############################################################
+
+sub insert
+{
+ my $w = shift;
+ $w->markSet('insert', $w->index(shift) );
+ while(@_)
+ {
+ my $index1 = $w->index('insert');
+ my $string = shift;
+ my $taglist_ref = shift if @_;
+
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->CheckForRedoShuffle;
+ $w->PushUndo($w->insert_UNDO($index1,$string,$taglist_ref));
+ }
+ $w->markSet('notepos' => $index1);
+ $w->SUPER::insert($index1,$string,$taglist_ref);
+ $w->markSet('insert', $w->index('notepos'));
+ }
+}
+
+sub insert_UNDO
+{
+ my $w = shift;
+ my $index = shift;
+ my $string = '';
+ # This possible call: ->insert (index, string, tag, string, tag...);
+ # if more than one string, keep reading strings in (discarding tags)
+ # until all strings are read in and $string contains entire text inserted.
+ while (@_)
+ {
+ $string .= shift;
+ my $tags = shift if (@_);
+ }
+ # calculate index
+ # possible things to insert:
+ # carriage return
+ # single character (not CR)
+ # single line of characters (not ending in CR)
+ # single line of characters ending with a CR
+ # multi-line characters. last line does not end with CR
+ # multi-line characters, last line does end with CR.
+ my ($line,$col) = split(/\./,$index);
+ if ($string =~ /\n(.*)$/)
+ {
+ $line += $string =~ tr/\n/\n/;
+ $col = length($1);
+ }
+ else
+ {
+ $col += length($string);
+ }
+ return ['delete', $index, $line.'.'.$col];
+}
+
+sub delete
+{
+ my ($w, $start, $stop) = @_;
+ unless(defined($stop))
+ { $stop = $start .'+1c'; }
+ my $index1 = $w->index($start);
+ my $index2 = $w->index($stop);
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->CheckForRedoShuffle;
+ $w->PushUndo($w->delete_UNDO($index1,$index2));
+ }
+ $w->SUPER::delete($index1,$index2);
+ # why call SetCursor - it has side effects
+ # which cause a whole slew if save/restore hassles ?
+ $w->SetCursor($index1);
+}
+
+sub delete_UNDO
+{
+ my ($w, $index1, $index2) = @_;
+ my %tags;
+ my @result = ( 'insert' => $index1 );
+ my $str = '';
+
+ ###############################################################
+ # get tags in range and return them in a format that
+ # can be inserted.
+ # $text->insert('1.0', $string1, [tag1,tag2], $string2, [tag2, tag3]);
+ # note, have to break tags up into sequential order
+ # in reference to _all_ tags.
+ ###############################################################
+
+ $w->dump('-text','-tag', -command => sub {
+ my ($kind,$value,$posn) = @_;
+ if ($kind eq 'text')
+ {
+ $str .= $value;
+ }
+ else
+ {
+ push(@result,$str,[keys %tags]) if (length $str);
+ $str = '';
+ if ($kind eq 'tagon')
+ {
+ $tags{$value} = 1;
+ }
+ elsif ($kind eq 'tagoff')
+ {
+ delete $tags{$value};
+ }
+ }
+ }, $index1, $index2);
+ push(@result,$str,[keys %tags]) if (length $str);
+ return \@result;
+}
+
+############################################################
+# override subroutines which are collections of low level
+# routines executed in sequence.
+# wrap a globstart and globend around the SUPER:: version of routine.
+############################################################
+
+sub ReplaceSelectionsWith
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::ReplaceSelectionsWith(@_);
+ $w->addGlobEnd;
+}
+
+sub FindAndReplaceAll
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::FindAndReplaceAll(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardCut
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardCut(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardPaste(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardColumnCut
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardColumnCut(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardColumnPaste
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardColumnPaste(@_);
+ $w->addGlobEnd;
+}
+
+# Greg: this method is more tightly coupled to the base class
+# than I would prefer, but I know of no other way to do it.
+
+sub Insert
+{
+ my ($w,$char)=@_;
+ return if $char eq '';
+ $w->addGlobStart;
+ $w->SUPER::Insert($char);
+ $w->addGlobEnd;
+ $w->see('insert');
+}
+
+
+sub InsertKeypress
+{
+ my ($w,$char)=@_;
+ return if $char eq '';
+ if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel'))
+ {
+ my $index = $w->index('insert');
+ my $undo_item = $w->getUndoAtIndex(-1);
+ if (defined($undo_item) &&
+ ($undo_item->[0] eq 'delete') &&
+ ($undo_item->[2] == $index)
+ )
+ {
+ $w->SUPER::insert($index,$char);
+ $undo_item->[2] = $w->index('insert');
+ return;
+ }
+ }
+ $w->addGlobStart;
+ $w->SUPER::InsertKeypress($char);
+ $w->addGlobEnd;
+}
+
+############################################################
+sub TextUndoFileProgress
+{
+ my ($w,$action,$filename,$count,$val,$total) = @_;
+ return unless(defined($filename) and defined($count));
+
+ my $popup = $w->{'FILE_PROGRESS_POP_UP'};
+ unless (defined($popup))
+ {
+ $w->update;
+ $popup = $w->Toplevel(-title => "File Progress",-popover => $w);
+ $popup->transient($w->toplevel);
+ $popup->withdraw;
+ $popup->resizable('no','no');
+ $popup->Label(-textvariable => \$popup->{ACTION})->pack;
+ $popup->Label(-textvariable => \$popup->{FILENAME})->pack;
+ $popup->Label(-textvariable => \$popup->{COUNT})->pack;
+ my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x');
+ my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2);
+ $w->{'FILE_PROGRESS_POP_UP'} = $popup;
+ $popup->{PROGBAR} = $i;
+ }
+ $popup->{ACTION} = $action;
+ $popup->{COUNT} = "lines: $count";
+ $popup->{FILENAME} = "Filename: $filename";
+ if (defined($val) && defined($total) && $total != 0)
+ {
+ $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total);
+ }
+ else
+ {
+ $popup->{PROGBAR}->placeForget;
+ }
+
+ $popup->idletasks;
+ unless ($popup->viewable)
+ {
+ $w->idletasks;
+ $w->toplevel->deiconify unless $w->viewable;
+ $popup->Popup;
+ }
+ $popup->update;
+ return $popup;
+}
+
+sub FileName
+{
+ my ($w,$filename) = @_;
+ if (@_ > 1)
+ {
+ $w->{'FILENAME'}=$filename;
+ }
+ return $w->{'FILENAME'};
+}
+
+sub PerlIO_layers
+{
+ my ($w,$layers) = @_;
+ $w->{PERLIO_LAYERS} = $layers if @_ > 1;
+ return $w->{PERLIO_LAYERS} || '' ;
+}
+
+sub ConfirmDiscard
+{
+ my ($w)=@_;
+ if ($w->numberChanges)
+ {
+ my $ans = $w->messageBox(-icon => 'warning',
+ -type => 'YesNoCancel', -default => 'Yes',
+ -message =>
+"The text has been modified without being saved.
+Save edits?");
+ return 0 if $ans eq 'Cancel';
+ return 0 if ($ans eq 'Yes' && !$w->Save);
+ }
+ return 1;
+}
+
+################################################################################
+# if the file has been modified since being saved, a pop up window will be
+# created, asking the user to confirm whether or not to exit.
+# this allows the user to return to the application and save the file.
+# the code would look something like this:
+#
+# if ($w->user_wants_to_exit)
+# {$w->ConfirmExit;}
+#
+# it is also possible to trap attempts to delete the main window.
+# this allows the ->ConfirmExit method to be called when the main window
+# is attempted to be deleted.
+#
+# $mw->protocol('WM_DELETE_WINDOW'=>
+# sub{$w->ConfirmExit;});
+#
+# finally, it might be desirable to trap Control-C signals at the
+# application level so that ->ConfirmExit is also called.
+#
+# $SIG{INT}= sub{$w->ConfirmExit;};
+#
+################################################################################
+
+sub ConfirmExit
+{
+ my ($w) = @_;
+ $w->toplevel->destroy if $w->ConfirmDiscard;
+}
+
+sub Save
+{
+ my ($w,$filename) = @_;
+ $filename = $w->FileName unless defined $filename;
+ return $w->FileSaveAsPopup unless defined $filename;
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,">$layers",$filename))
+ {
+ my $status;
+ my $count=0;
+ my $index = '1.0';
+ my $progress;
+ my ($lines) = $w->index('end - 1 chars') =~ /^(\d+)\./;
+ while ($w->compare($index,'<','end'))
+ {
+# my $end = $w->index("$index + 1024 chars");
+ my $end = $w->index("$index lineend +1c");
+ print $file $w->get($index,$end);
+ $index = $end;
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines);
+ }
+ }
+ $progress->withdraw if defined $progress;
+ if (close($file))
+ {
+ $w->ResetUndo;
+ $w->FileName($filename);
+ return 1;
+ }
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+ return 0;
+}
+
+sub Load
+{
+ my ($w,$filename) = @_;
+ $filename = $w->FileName unless (defined($filename));
+ return 0 unless defined $filename;
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,"<$layers",$filename))
+ {
+ $w->MainWindow->Busy;
+ $w->EmptyDocument;
+ my $count=1;
+ my $progress;
+ while (<$file>)
+ {
+ $w->SUPER::insert('end',$_);
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress (Loading => $filename,
+ $count,tell($file),-s $filename);
+ }
+ }
+ close($file);
+ $progress->withdraw if defined $progress;
+ $w->markSet('insert' => '1.0');
+ $w->FileName($filename);
+ $w->MainWindow->Unbusy;
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+}
+
+sub IncludeFile
+{
+ my ($w,$filename) = @_;
+ unless (defined($filename))
+ {$w->BackTrace("filename not specified"); return;}
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,"<$layers",$filename))
+ {
+ $w->Busy;
+ my $count=1;
+ $w->addGlobStart;
+ my $progress;
+ while (<$file>)
+ {
+ $w->insert('insert',$_);
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress(Including => $filename,
+ $count,tell($file),-s $filename);
+ }
+ }
+ $progress->withdraw if defined $progress;
+ $w->addGlobEnd;
+ close($file);
+ $w->Unbusy;
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+}
+
+# clear document without pushing it into UNDO array, (use SUPER::delete)
+# (using plain delete(1.0,end) on a really big document fills up the undo array)
+# and then clear the Undo and Redo stacks.
+sub EmptyDocument
+{
+ my ($w) = @_;
+ $w->SUPER::delete('1.0','end');
+ $w->ResetUndo;
+ $w->FileName(undef);
+}
+
+sub ConfirmEmptyDocument
+{
+ my ($w)=@_;
+ $w->EmptyDocument if $w->ConfirmDiscard;
+}
+
+sub FileMenuItems
+{
+ my ($w) = @_;
+ return [
+ ["command"=>'~Open', -command => [$w => 'FileLoadPopup']],
+ ["command"=>'~Save', -command => [$w => 'Save' ]],
+ ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']],
+ ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']],
+ ["command"=>'~Clear', -command => [$w => 'ConfirmEmptyDocument']],
+ "-",@{$w->SUPER::FileMenuItems}
+ ]
+}
+
+sub EditMenuItems
+{
+ my ($w) = @_;
+
+ return [
+ ["command"=>'Undo', -command => [$w => 'undo']],
+ ["command"=>'Redo', -command => [$w => 'redo']],
+ "-",@{$w->SUPER::EditMenuItems}
+ ];
+}
+
+sub CreateFileSelect
+{
+ my $w = shift;
+ my $k = shift;
+ my $name = $w->FileName;
+ my @types = (['All Files', '*']);
+ my $dir = undef;
+ if (defined $name)
+ {
+ require File::Basename;
+ my $sfx;
+ ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*');
+ #
+ # it should never happen where we have a file suffix and
+ # no file name... but fileparse() screws this up with dotfiles.
+ #
+ if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) }
+
+ if (defined($sfx) && length($sfx))
+ {
+ unshift(@types,['Similar Files',[$sfx]]);
+ $name .= $sfx;
+ }
+ }
+ return $w->$k(-initialdir => $dir, -initialfile => $name,
+ -filetypes => \@types, @_);
+}
+
+sub FileLoadPopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load');
+ return $w->Load($name) if defined($name) and length($name);
+ return 0;
+}
+
+sub IncludeFilePopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include');
+ return $w->IncludeFile($name) if defined($name) and length($name);
+ return 0;
+}
+
+sub FileSaveAsPopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As');
+ return $w->Save($name) if defined($name) and length($name);
+ return 0;
+}
+
+
+sub MarkSelectionsSavePositions
+{
+ my ($w)=@_;
+ $w->markSet('MarkInsertSavePosition','insert');
+ my @ranges = $w->tagRanges('sel');
+ my $i = 0;
+ while (@ranges)
+ {
+ my ($start,$end) = splice(@ranges,0,2);
+ $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start);
+ $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end);
+ $w->tagRemove('sel',$start,$end);
+ }
+}
+
+sub RestoreSelectionsMarkedSaved
+{
+ my ($w)=@_;
+ my $i = 1;
+ my %mark_hash;
+ foreach my $mark ($w->markNames)
+ {
+ $mark_hash{$mark}=1;
+ }
+ while(1)
+ {
+ my $markstart = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markstart}));
+ my $indexstart = $w->index($markstart);
+ my $markend = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markend}));
+ my $indexend = $w->index($markend);
+ $w->tagAdd('sel',$indexstart, $indexend);
+ $w->markUnset($markstart, $markend);
+ }
+ $w->markSet('insert','MarkInsertSavePosition');
+}
+
+####################################################################
+# selected lines may be discontinous sequence.
+sub GetMarkedSelectedLineNumbers
+{
+ my ($w) = @_;
+
+ my $i = 1;
+ my %mark_hash;
+ my @ranges;
+ foreach my $mark ($w->markNames)
+ {
+ $mark_hash{$mark}=1;
+ }
+
+ while(1)
+ {
+ my $markstart = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markstart}));
+ my $indexstart = $w->index($markstart);
+ my $markend = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markend}));
+ my $indexend = $w->index($markend);
+
+ push(@ranges, $indexstart, $indexend);
+ }
+
+ my @selection_list;
+ while (@ranges)
+ {
+ my ($first) = split(/\./,shift(@ranges));
+ my ($last) = split(/\./,shift(@ranges));
+ # if previous selection ended on the same line that this selection starts,
+ # then fiddle the numbers so that this line number isnt included twice.
+ if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
+ {
+ # if this selection ends on the same line its starts, then skip this sel
+ next if ($first == $last);
+ $first++; # count this selection starting from the next line.
+ }
+ push(@selection_list, $first .. $last);
+ }
+ return @selection_list;
+}
+
+sub insertStringAtStartOfSelectedLines
+{
+ my ($w,$insert_string)=@_;
+ $w->addGlobStart;
+ $w->MarkSelectionsSavePositions;
+ foreach my $line ($w->GetMarkedSelectedLineNumbers)
+ {
+ $w->insert($line.'.0', $insert_string);
+ }
+ $w->RestoreSelectionsMarkedSaved;
+ $w->addGlobEnd;
+}
+
+sub deleteStringAtStartOfSelectedLines
+{
+ my ($w,$insert_string)=@_;
+ $w->addGlobStart;
+ $w->MarkSelectionsSavePositions;
+ my $length = length($insert_string);
+ foreach my $line ($w->GetMarkedSelectedLineNumbers)
+ {
+ my $start = $line.'.0';
+ my $end = $line.'.'.$length;
+ my $current_text = $w->get($start, $end);
+ next unless ($current_text eq $insert_string);
+ $w->delete($start, $end);
+ }
+ $w->RestoreSelectionsMarkedSaved;
+ $w->addGlobEnd;
+}
+
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TextUndo.pod b/Master/tlpkg/tlperl.straw/lib/Tk/TextUndo.pod
new file mode 100755
index 00000000000..2b9d98a3c4a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TextUndo.pod
@@ -0,0 +1,73 @@
+
+=head1 NAME
+
+Tk::TextUndo - perl/tk text widget with bindings to undo changes.
+
+=for pm Tk/TextUndo.pm
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+S< >B<use Tk::TextUndo;>
+
+S< >I<$testundo> = I<$parent>-E<gt>B<TextUndo>(?I<-option>=E<gt>I<value>, ...?);
+
+=head1 DESCRIPTION
+
+This IS-A text widget with an unlimited 'undo' history but without
+a re'undo' capability.
+
+=head2 Bindings
+
+The C<TextUndo> widget has the same bindings as the L<Text|Tk::Text> widget.
+In addition there are the following bindings:
+
+=over 4
+
+=item Event <L4> <<Undo>>
+
+undo the last change. Pressing <L4> several times undo
+step by step the changes made to the text widget.
+
+=back
+
+=head2 Methods
+
+The C<TextUndo> widget has the same methods as C<Text> widget.
+Additional methods for the C<TextUndo> widget are:
+
+=over 4
+
+=item $text->Load($filename);
+
+Loads the contents of the $filename into the text widget. Load()
+delete the previous contents of the text widget as well as it's
+undo history of the previous file.
+
+=item $text->Save(?$otherfilename?)
+
+Save contents of the text widget to a file. If the
+$otherfilename is not specified, the text widget contents
+writes the file of $filename used in the last Load()
+call. If no file was previously Load()'ed an error message
+pops up. The default filename of the last Load() call
+is not overwriten by $otherfilename.
+
+=item $text->FileName(?$otherfilename?)
+
+If passed an argument sets the file name associated with the loaded
+document. Returns the current file name associated with the document.
+
+=back
+
+=head1 KEYS
+
+widget, text, undo
+
+=head1 SEE ALSO
+
+L<Tk::Text>, L<Tk::ROText>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Tiler.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Tiler.pm
new file mode 100755
index 00000000000..1256612f801
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Tiler.pm
@@ -0,0 +1,203 @@
+# 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.
+# An example of a geometry manager "widget" in perl
+package Tk::Tiler;
+require Tk;
+require Tk::Frame;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'Tiler';
+sub Tk::Widget::ScrlTiler { shift->Scrolled('Tiler' => @_) }
+
+use Tk::Pretty;
+
+sub FocusChildren
+{
+ return (wantarray) ? () : 0;
+}
+
+sub Populate
+{
+ my ($obj,$args) = @_;
+ $obj->SUPER::Populate($args);
+ $obj->{Slaves} = [];
+ $obj->{LayoutPending} = 0;
+ $obj->{Start} = 0;
+ $obj->{Sw} = 0;
+ $obj->{Sh} = 0;
+ $obj->ConfigSpecs('-takefocus' => ['SELF', 'takeFocus','TakeFocus',1],
+ '-highlightthickness' => ['SELF', 'highlightThickness','HighlightThickness',2],
+ '-yscrollcommand' => ['CALLBACK',undef,undef,undef],
+ '-columns' => ['PASSIVE','columns','Columns',5],
+ '-rows' => ['PASSIVE','rows','Rows',10]
+ );
+ return $obj;
+}
+
+sub change_size
+{
+ my ($w) = shift;
+ my $r = $w->cget('-rows');
+ my $c = $w->cget('-columns');
+ my $bw = $w->cget(-highlightthickness);
+ if (defined $r && defined $c)
+ {
+ $w->GeometryRequest($c*$w->{Sw}+2*$bw,$r*$w->{Sh}+2*$bw);
+ }
+}
+
+sub Layout
+{
+ my $m = shift;
+ my $bw = $m->cget(-highlightthickness);
+ my $why = $m->{LayoutPending};
+ $m->{LayoutPending} = 0;
+ my $W = $m->Width;
+ my $H = $m->Height;
+ my $w = $m->{Sw} || 1; # max width of slave
+ my $h = $m->{Sh} || 1; # max height of slave
+ my $x = $bw;
+ my $y = $bw;
+ my $start = 0;
+ # Set size and position of slaves
+ my $rows = $m->{Rows} = int(($H-2*$bw)/$h) || 1;
+ my $cols = $m->{Cols} = int(($W-2*$bw)/$w) || 1;
+ my $need = $m->{Need} = int( (@{$m->{Slaves}}+$cols-1)/$cols );
+ $m->{Start} = ($need - $rows) if ($m->{Start} + $rows > $need);
+
+ $m->{Start} = 0 if ($m->{Start} < 0);
+ my $row = 0;
+ my @posn = ();
+ my $s;
+ foreach $s (@{$m->{Slaves}})
+ {
+ if ($row < $m->{Start})
+ {
+ $s->UnmapWindow;
+ $x += $w;
+ if ($x+$w+$bw > $W)
+ {
+ $x = $bw;
+ $row++;
+ }
+ }
+ elsif ($y+$h+$bw > $H)
+ {
+ $s->UnmapWindow;
+ $s->ResizeWindow($w,$h) if ($why & 1);
+ }
+ else
+ {
+ push(@posn,[$s,$x,$y]);
+ $x += $w;
+ if ($x+$w+$bw > $W)
+ {
+ $x = $bw;
+ $y += $h;
+ $row++;
+ }
+ }
+ $s->ResizeWindow($w,$h) if ($why & 1);
+ }
+ $row++ if ($x > $bw);
+ if (defined $m->{Prev} && $m->{Prev} > $m->{Start})
+ {
+ @posn = reverse(@posn);
+ }
+ while (@posn)
+ {
+ my $posn = shift(@posn);
+ my ($s,$x,$y) = (@$posn);
+ $s->MoveWindow($x,$y);
+ $s->MapWindow;
+ }
+ $m->{Prev} = $m->{Start};
+ $m->Callback(-yscrollcommand => $m->{Start}/$need,$row/$need) if $need;
+}
+
+sub QueueLayout
+{
+ my ($m,$why) = @_;
+ $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
+ $m->{LayoutPending} |= $why;
+}
+
+sub SlaveGeometryRequest
+{
+ my ($m,$s) = @_;
+ my $sw = $s->ReqWidth;
+ my $sh = $s->ReqHeight;
+ my $sz = 0;
+ if ($sw > $m->{Sw})
+ {
+ $m->{Sw} = $sw;
+ $m->QueueLayout(1);
+ $sz++;
+ }
+ if ($sh > $m->{Sh})
+ {
+ $m->{Sh} = $sh;
+ $m->QueueLayout(1);
+ $sz++;
+ }
+ $m->change_size if ($sz);
+}
+
+sub LostSlave
+{
+ my ($m,$s) = @_;
+ @{$m->{Slaves}} = grep($_ != $s,@{$m->{Slaves}});
+ $m->QueueLayout(2);
+}
+
+sub Manage
+{
+ my $m = shift;
+ my $s;
+ foreach $s (@_)
+ {
+ $m->ManageGeometry($s);
+ push(@{$m->{Slaves}},$s);
+ $m->SlaveGeometryRequest($s);
+ }
+ $m->QueueLayout(2 | 1);
+}
+
+sub moveto
+ {
+ my ($m,$frac) = (@_);
+ $m->{Start} = int($m->{Need} * $frac);
+ $m->QueueLayout(4);
+ }
+
+sub scroll
+ {
+ my ($m,$delta,$type) = @_;
+ $delta *= $m->{Rows}/2 if ($type eq 'pages');
+ $m->{Start} += $delta;
+ $m->QueueLayout(4);
+ }
+
+sub yview { my $w = shift; my $c = shift; $w->$c(@_) }
+
+sub FocusIn
+{
+ my ($w) = @_;
+# print 'Focus ',$w->PathName,"\n";
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>',['QueueLayout',8]);
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ $mw->YscrollBind($class);
+ return $class;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Tiler.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Tiler.pod
new file mode 100755
index 00000000000..2db172ebaf1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Tiler.pod
@@ -0,0 +1,32 @@
+
+=head1 NAME
+
+Tk::Tiler - Scrollable frame with sub-widgets arranged into rows
+
+=for pm Tk/Tiler.pm
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+ use Tk::Tiler;
+
+ my $tl = $parent->Scrolled('Tiler', -columns => n, -rows => n);
+
+ my $a = $tl->Xxxxx(...);
+ my $b = $tl->Xxxxx(...);
+ my $c = $tl->Xxxxx(...);
+
+ $tl->Manage($a,$b,$c);
+
+=head1 DESCRIPTION
+
+Tiler is derived form Tk::Frame. It is a geometry managing widget which
+accepts widgets to manage. It places the widgets in a grid with as many
+widgets as possible in a row. All the "slots" in the grid are the same size,
+which is determined by the largest managed widget.
+
+The grid may be scrolled vertically.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TixGrid.pm b/Master/tlpkg/tlperl.straw/lib/Tk/TixGrid.pm
new file mode 100755
index 00000000000..2dd238095f3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TixGrid.pm
@@ -0,0 +1,1597 @@
+
+# TODO:
+#
+# o How to get into state 's0' 'b0' so cursor keys start
+# working (compare with Tk/Widget XYscrollBind
+# o the options -browsecmd and -command callback are not
+# not implemented (as in Tix)
+# o privateData 'state' used only once (check again Grid.tcl)
+# o FloatEntry 'sometimes not activeted immediately on selection
+# o check also Leave Binding. Looks like entry does get unpost'ed
+
+package Tk::TixGrid;
+
+BEGIN
+ {
+ use vars '$DEBUG';
+ $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'ach') ? 1 : 0;
+ print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG;
+ }
+
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+use Tk::Widget;
+use Carp;
+
+# carp "\n".__PACKAGE__.' is deprecated' unless defined($Test::ntest);
+
+use base 'Tk::Widget';
+
+Construct Tk::Widget 'TixGrid';
+
+bootstrap Tk::TixGrid;
+
+sub Tk_cmd { \&Tk::tixGrid }
+
+sub Tk::Widget::SrclTixGrid { shift->Scrolled('TixGrid' => @_) }
+
+Tk::Methods qw(anchor bdtype delete entrycget entryconfigure format index
+ move set size unset xview yview
+ dragsite dropsite geometryinfo info
+ nearest see selection sort );
+
+use Tk::Submethods
+ (
+ 'anchor' => [ qw(get set) ],
+ 'delete' => [ qw(column row) ],
+ 'info' => [ qw(bbox exists anchor) ],
+ 'move' => [ qw(column row) ],
+ 'selection' => [ qw(adjust clear includes set) ],
+ 'size' => [ qw(column row) ],
+ 'format' => [ qw(grid border) ],
+ );
+
+# edit subcommand is special. It justs invokes tcl code:
+#
+# edit set x y -> tixGrid:EditCell $w, x, y
+# edit apply -> tixGrid:EditApply
+
+# xxx Create an edit sub?
+# sub edit { .... }
+
+sub editSet
+ {
+ die "wrong args. Should be \$w->editSet(x,y)\n" unless @_ == 3;
+ my ($w, $x, $y) = @_;
+ $w->EditCell($x, $y);
+ }
+
+sub editApply
+ {
+ die "wrong args. Should be \$w->editApply()\n" unless @_ == 1;
+ my ($w) = @_;
+ $w->EditApply()
+ }
+
+
+####################################################
+##
+## For button 2 scrolling. So TixGrid has 'standard'
+## standard scrolling interface
+##
+
+#sub scanMark
+# {
+# die "wrong # args: \$w->scanMark(x,y)\n" unless @_ == 3;
+# my ($w) = @_;
+# $w->{__scanMarkXY__} = [ @_[1,2] ];
+# return "";
+# }
+#
+#sub scanDragto
+# {
+# die "wrong # args: \$w->scanDragto(x,y)\n" unless @_ == 3;
+# my ($w, $x, $y) = @_;
+# my ($ox, $oy) = @{ $w->{__scanMarkXY__} };
+#
+# #...
+#
+# return "";
+# }
+
+### end button 2 scrolling stuff ####################
+
+
+# Grid.tcl --
+#
+# This file defines the default bindings for Tix Grid widgets.
+#
+# Copyright (c) 1996, Expert Interface Technologies
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Bindings translated to perl/Tk by Achim Bohnet <ach@mpe.mpg.de>
+
+sub ClassInit
+ {
+ my ($class, $mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $mw->XYscrollBind($class);
+
+ ##
+ ## Button bindings
+ ##
+
+ $mw->bind($class, '<ButtonPress-1>', ['Button_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Shift-ButtonPress-1>', ['Shift_Button_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Control-ButtonPress-1>',['Control_Button_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<ButtonRelease-1>', ['ButtonRelease_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<B1-Motion>','Button_Motion');
+ $mw->bind($class, '<Control-B1-Motion>','Control_Button_Motion');
+ $mw->bind($class, '<B1-Leave>','Button_Leave');
+ $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<B1-Enter>', ['B1_Enter', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Control-B1-Leave>','Control_Button_Leave');
+ $mw->bind($class, '<Control-B1-Enter>', ['Control_B1_Enter', Ev('x'), Ev('y')]);
+
+ ##
+ ## Keyboard bindings
+ ##
+
+ $mw->bind($class, '<Up>', ['DirKey', 'up' ]);
+ $mw->bind($class, '<Down>', ['DirKey', 'down' ]);
+ $mw->bind($class, '<Left>', ['DirKey', 'left' ]);
+ $mw->bind($class, '<Right>', ['DirKey', 'right' ]);
+
+ $mw->PriorNextBind($class);
+
+ $mw->bind($class, '<Return>', 'Return');
+ $mw->bind($class, '<space>', 'Space' );
+
+ return $class;
+ }
+
+#----------------------------------------------------------------------
+#
+#
+# Mouse bindings
+#
+#
+#----------------------------------------------------------------------
+
+sub Button_1
+ {
+ my $w = shift;
+
+ return if $w->cget('-state') eq 'disabled';
+ $w->SetFocus;
+ $w->ChgState(@_,
+ [
+ '0'=>'1',
+ ]
+ );
+ }
+
+sub Shift_Button_1
+ {
+ my $w = shift;
+
+ return if $w->cget('-state') eq 'disabled';
+ $w->SetFocus;
+
+# $w->ChgState(@_,
+# [
+# ]
+# );
+ }
+
+sub Control_Button_1
+ {
+ my $w = shift;
+
+ return if $w->cget('-state') eq 'disabled';
+ $w->SetFocus;
+
+ $w->ChgState(@_,
+ [
+ 's0' => 's1',
+ 'b0' => 'b1',
+ 'm0' => 'm1',
+ 'e0' => 'e10',
+ ]
+ );
+ }
+
+sub ButtonRelease_1
+ {
+ shift->ChgState(@_,
+ [
+ '2' => '5',
+ '4' => '3',
+ ]
+ );
+ }
+
+sub B1_Motion
+ {
+ shift->ChgState(@_,
+ [
+ '2' => '4',
+ '4' => '4',
+ ]
+ );
+ }
+
+
+sub Control_B1_Motion
+ {
+ shift->ChgState(@_,
+ [
+ 's2' => 's4',
+ 's4' => 's4',
+ 'b2' => 'b4',
+ 'b4' => 'b4',
+ 'm2' => 'm4',
+ 'm5' => 'm4',
+ ]
+ );
+ }
+
+
+sub Double_1
+ {
+ shift->ChgState(@_,
+ [
+ 's0' => 's7',
+ 'b0' => 'b7',
+ ]
+ );
+ }
+
+
+sub B1_Leave
+ {
+ shift->ChgState(@_,
+ [
+ 's2' => 's5',
+ 's4' => 's5',
+ 'b2' => 'b5',
+ 'b4' => 'b5',
+ 'm2' => 'm8',
+ 'm5' => 'm8',
+ 'e2' => 'e8',
+ 'e5' => 'e8',
+ ]
+ );
+ }
+
+
+sub B1_Enter
+ {
+ shift->ChgState(@_,
+ [
+ 's5' => 's4',
+ 's6' => 's4',
+ 'b5' => 'b4',
+ 'b6' => 'b4',
+ 'm8' => 'm4',
+ 'm9' => 'm4',
+ 'e8' => 'e4',
+ 'e9' => 'e4',
+ ]
+ );
+ }
+
+
+sub Control_B1_Leave
+ {
+ shift->ChgState(@_,
+ [
+ 's2' => 's5',
+ 's4' => 's5',
+ 'b2' => 'b5',
+ 'b4' => 'b5',
+ 'm2' => 'm8',
+ 'm5' => 'm8',
+ ]
+ );
+ }
+
+
+sub Control_B1_Enter
+ {
+ shift->ChgState(@_,
+ [
+ 's5' => 's4',
+ 's6' => 's4',
+ 'b5' => 'b4',
+ 'b6' => 'b4',
+ 'm8' => 'm4',
+ 'm9' => 'm4',
+ ]
+ );
+ }
+
+
+sub AutoScan
+ {
+ shift->ChgState(@_,
+ [
+ 's5' => 's9',
+ 's6' => 's9',
+ 'b5' => 'b9',
+ 'b6' => 'b9',
+ 'm8' => 'm9',
+ 'm9' => 'm9',
+ 'e8' => 'm9',
+ 'e9' => 'm9',
+ ]
+ );
+ }
+
+#----------------------------------------------------------------------
+#
+#
+# Key bindings
+#
+#
+#----------------------------------------------------------------------
+
+sub DirKey
+ {
+ my ($w, $key) = @_;
+
+ return if $w->cget('-state') eq 'disabled';
+
+print STDERR "$w->DirKey($key)\n" if $DEBUG;
+ $w->ChgState($key,
+ [
+ 's0' => 's8',
+ 'b0' => 'b8',
+ ]
+ );
+ }
+
+
+sub Return
+ {
+ my ($w) = @_;
+
+ return if $w->cget('-state') eq 'disabled';
+
+ $w->ChgState(
+ [
+ 's0' => 's9',
+ 'b0' => 'b9',
+ ]
+ );
+ }
+
+
+sub Space
+ {
+ my ($w) = @_;
+
+ return if $w->cget('-state') eq 'disabled';
+
+ $w->ChgState(
+ [
+ 's0' => 's10',
+ 'b0' => 'b10',
+ ]
+ );
+ }
+
+
+#----------------------------------------------------------------------
+#
+# STATE MANIPULATION
+#
+#
+#----------------------------------------------------------------------
+
+sub GetState
+ {
+ my ($w) = @_;
+ my $data = $w->privateData();
+ $data->{state} = 0 unless exists $data->{state};
+ return $data->{state};
+}
+
+sub Button_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->B1_Motion($Tk::x, $Tk::y);
+}
+
+
+sub Control_Button_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->Control_B1_Motion($Tk::x, $Tk::y);
+}
+
+
+sub Button_Leave
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->B1_Leave();
+}
+
+
+sub Control_Button_Leave
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->Control_B1_Leave();
+}
+
+
+sub SetState
+ {
+ my ($w, $state) = @_;
+ $w->privateData()->{state} = $state;
+ }
+
+sub GoState
+ {
+ my ($w, $state) = (shift, shift);
+ print STDERR 'Gostate: ', $w->GetState, " --> $state, " if $DEBUG;
+ $w->SetState($state);
+ my $method = "GoState_$state";
+
+ print STDERR 'args=(', join(',',@_), ')'.
+ "\t(",$w->cget('-selectmode').
+ ',',$w->cget('-selectunit').")\n" if $DEBUG;
+
+ if (0)
+ {
+ $@ = '';
+ %@ = (); # Workaround to prevent spurious loss of $@
+ eval { $w->$method(@_) };
+ print STDERR "Error Gostate: '$state': ", $@ if $@;
+ return undef;
+ }
+
+ $w->$method(@_);
+ return undef
+ }
+
+##
+## ChgState is a fancy case statement
+##
+
+sub ChgState
+ {
+ my $w = shift;
+ my $map = pop;
+ print STDERR 'ChgState(', join(',',@_,'['), join(',',@$map,),']) ' if $DEBUG;
+ my $state = $w->GetState;
+
+ my ($match, $to);
+ while (@$map)
+ {
+ $match = shift @$map;
+ $to = shift @$map;
+ if ($match eq $state)
+ {
+ print STDERR "$state --> $to \n" if $DEBUG;
+ $w->GoState($to, @_);
+ return;
+ }
+ }
+ print STDERR "*no* chg for $state\n" if $DEBUG;
+ }
+
+
+#----------------------------------------------------------------------
+# SELECTION ROUTINES
+#----------------------------------------------------------------------
+
+#proc tixGrid:SelectSingle {w ent} {
+# $w selection set [lindex $ent 0] [lindex $ent 1]
+# tixGrid:CallBrowseCmd $w $ent
+#}
+
+sub SelectSingle
+ {
+ my ($w, $n1, $n2) = @_;
+ $w->selection('set', $n1, $n2);
+ $w->Callback('-browsecmd' => $n1, $n2);
+ }
+
+#----------------------------------------------------------------------
+# SINGLE SELECTION
+#----------------------------------------------------------------------
+
+sub GoState_0
+ {
+ my ($w) = @_;
+ my $list = $w->privateData()->{list};
+ return unless defined $list;
+
+ foreach my $cmd (@$list)
+ {
+ # XXX should do more something like $w->Callback'('__pending_cmds__');
+ eval $cmd; # XXX why in tcl in global context (binding?)
+ }
+ undef(@$list); # XXX should really delete? Maybe on needed in TCL
+ }
+
+# XXXX how to translate global context
+# what does unset
+#proc tixGrid:GoState-0 {w} {
+# set list $w:_list
+# global $list
+#
+# if [info exists $list] {
+# foreach cmd [set $list] {
+# uplevel #0 $cmd
+# }
+# if [info exists $list] {
+# unset $list
+# }
+# }
+#}
+
+sub GoState_1
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->SetAnchor(@ent);
+ }
+ $w->CheckEdit;
+ $w->selection('clear', 0, 0, 'max', 'max');
+
+ if ($w->cget('-selectmode') ne 'single')
+ {
+ $w->SelectSingle(@ent);
+ }
+ $w->GoState(2);
+ }
+
+sub GoState_2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_3
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->SelectSingle(@ent);
+ }
+ $w->GoState(0);
+
+ }
+
+sub GoState_4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x,$y);
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'single')
+ {
+ $w->SetAnchor(@ent);
+ }
+ elsif ($mode eq 'browse')
+ {
+ $w->SetAnchor(@ent);
+ $w->selection('clear', 0, 0, 'max', 'max');
+ $w->SelectSingle(@ent);
+ }
+ elsif ($mode eq 'multiple' ||
+ $mode eq 'extended')
+ {
+ my (@anchor) = $w->anchor('get');
+ $w->selection('adjust', @anchor[0,1], @ent[0,1]);
+ }
+ }
+
+sub GoState_5
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->SelectSingle(@ent);
+ $w->SetEdit(@ent);
+ }
+ $w->GoState(0);
+
+ }
+
+##############################################
+# BUG xxx
+# return scalar instead of errors
+
+sub mynearest { shift->split_s2a('nearest', @_); }
+sub myanchorGet { shift->split_s2a('anchor', 'get', @_); }
+
+sub split_s2a
+ {
+ my $w = shift;
+ my $method = shift;
+ my @ent = $w->$method(@_);
+ if (@ent == 1)
+ {
+my $tmp = $ent[0];
+ @ent = split(/ /, $ent[0]) if @ent == 1;
+print STDERR join('|',"$method splitted '$tmp' =>",@ent,"\n") if $DEBUG;
+ }
+ else
+ {
+#print STDERR join("|","$method splitted is okay :",@ent,"\n") if $DEBUG;
+ }
+ return @ent;
+ }
+
+##############################################
+
+
+sub GoState_s5
+ {
+ shift->StartScan();
+ }
+
+
+sub GoState_s6
+ {
+ shift->DoScan();
+ }
+
+
+sub GoState_s7
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-command' => @ent);
+ }
+ $w->GoState('s0');
+ }
+
+
+sub GoState_s8
+ {
+ my ($w, $key) = @_;
+
+ ## BUGS ....
+ ## - anchor is bad, only bbox, exists8
+ ## - looks like anchor is 1-dim: set anchor 0
+ ## - method see unknown (even when defined with Tk::Method)
+
+ my (@anchor) = $w->info('anchor');
+ if (@anchor)
+ {
+ @anchor = ();
+ }
+ else
+ {
+ @anchor = $w->info($key, @anchor);
+ }
+
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+
+ $w->GoState('s0');
+ }
+
+#proc tixGrid:GoState-s8 {w key} {
+# set anchor [$w info anchor]
+#
+# if {$anchor == ""} {
+# set anchor 0
+# } else {
+# set anchor [$w info $key $anchor]
+# }
+#
+# $w anchor set $anchor
+# $w see $anchor
+# tixGrid:GoState s0 $w
+#}
+
+
+sub GoState_s9
+ {
+ my ($w, $key) = @_;
+
+#print STDERR "GoState_s9 is not implemented\n";
+
+ my (@anchor) = $w->info('anchor');
+ unless (@anchor)
+ {
+ @anchor = ();
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ unless ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-command' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('s0');
+ }
+
+
+sub GoState_s10
+ {
+ my ($w, $key) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ if (@anchor)
+ {
+ @anchor = ();
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ unless ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-browsecmd' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('s0');
+ }
+
+
+#----------------------------------------------------------------------
+# BROWSE SELECTION
+#----------------------------------------------------------------------
+
+sub GoState_b0
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_b1
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('b2');
+ }
+
+sub GoState_b2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_b3
+ {
+ my ($w) = @_;
+
+ my (@ent) = $w->info('anchor');
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+ }
+
+
+sub GoState_b5 { shift->StartScan(); }
+
+
+sub GoState_b6 { shift->DoScan(); }
+
+
+sub GoState_b7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-command' => @ent);
+ }
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b8
+ {
+ my ($w, $key) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ if (@anchor)
+ {
+ @anchor = $w->info('key', @anchor);
+ }
+ else
+ {
+ @anchor = (0,0); # ?????
+ }
+
+ $w->anchor('set', @anchor);
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ $w->see(@anchor);
+
+ $w->Callback('-browsecmd' => @anchor);
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b9
+ {
+ my ($w) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ unless (@anchor)
+ {
+ @anchor = (0,0);
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ if ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-command' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b10
+ {
+ my ($w) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ unless (@anchor)
+ {
+ @anchor = (0,0);
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ if ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-browsecmd' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('b0');
+ }
+
+#----------------------------------------------------------------------
+# MULTIPLE SELECTION
+#----------------------------------------------------------------------
+
+
+sub GoState_m0
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_m1
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('m2');
+ }
+
+sub GoState_m2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_m3
+ {
+ my ($w) = @_;
+
+ my (@ent) = $w->info('anchor');
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('m0');
+ }
+
+
+sub GoState_m4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('m5');
+ }
+
+sub GoState_m5
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_m6
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('m0');
+ }
+
+sub GoState_m7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ unless (@from)
+ {
+ @from = @to;
+ $w->anchor('set', @from);
+ }
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('m5');
+ }
+
+
+sub GoState_m8 { shift->StartScan() }
+
+
+sub GoState_m9 { shift->DoScan() }
+
+
+sub GoState_xm7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('m0');
+ }
+
+#----------------------------------------------------------------------
+# EXTENDED SELECTION
+#----------------------------------------------------------------------
+
+sub GoState_e0
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_e1
+ {
+ my ($w, $x, $y) = @_;
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e2');
+ }
+
+
+sub GoState_e2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_e3
+ {
+ my ($w) = @_;
+
+ my (@ent) = $w->info('anchor');
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e0');
+ }
+
+sub GoState_e4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('e5');
+ }
+
+sub GoState_e5
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_e6
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e0');
+ }
+
+sub GoState_e7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ unless (@from)
+ {
+ @from = @to;
+ $w->anchor('set', @from);
+ }
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('e5');
+ }
+
+sub GoState_e8 { shift->StartScan(); }
+
+sub GoState_e9 { shift->DoScan(); }
+
+sub GoState_e10
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ if ($w->info('anchor'))
+ {
+ $w->anchor('set', @ent);
+ }
+ if ($w->selection('includes', @ent))
+ {
+ $w->selection('clear', @ent);
+ }
+ else
+ {
+ $w->selection('set', @ent);
+ }
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e2');
+ }
+
+sub GoState_xe7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-command' => @ent);
+ }
+ $w->GoState('e0');
+ }
+
+
+#----------------------------------------------------------------------
+# HODGE PODGE
+#----------------------------------------------------------------------
+
+sub GoState_12
+ {
+ my ($w, $x, $y) = @_;
+
+ $w->CancelRepeat; # xxx will not work
+ $w->GoState(5, $x, $y);
+ }
+#proc tixGrid:GoState-12 {w x y} {
+# tkCancelRepeat
+# tixGrid:GoState 5 $w $x $y
+#}
+
+sub GoState_13
+ {
+ # FIX: a) $ent or @ent, b) 13 is never called!!? same in Grid.tcl
+ my ($w, @ent, @oldEnt) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ $data->{indicator} = \@ent;
+ $data->{oldEntry} = \@oldEnt;
+ $w->IndicatorCmd('<Arm>', @ent);
+ }
+# set tkPriv(tix,oldEnt) $oldEnt
+# tixGrid:IndicatorCmd $w <Arm> $ent
+#}
+
+sub GoState_14
+ {
+ my ($w, $x, $y) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ if ($w->InsideArmedIndicator($x, $y))
+ {
+ $w->anchor('set', @{ $data->{indicator} });
+ $w->selection('clear');
+ $w->selection('set', @{ $data->{indicator} });
+ $w->IndicatorCmd('<Activate>', @{ $data->{indicator} });
+ }
+ else
+ {
+ $w->IndicatorCmd('<Disarm>', @{ $data->{indicator} });
+ }
+ delete($data->{indicator});
+ $w->GoState(0);
+ }
+
+sub GoState_16
+ {
+ my ($w, @ent) = @_;
+
+ return unless (@ent);
+ if ($w->cget('-selectmode') ne 'single')
+ {
+ $w->Select(@ent);
+ $w->Browse(@ent);
+ }
+ }
+
+sub GoState_18
+ {
+ my ($w) = @_;
+
+ $w->CancelRepeat; ## xxx
+ $w->GoState(6, $Tk::x, $Tk::y);
+ }
+
+sub GoState_20
+ {
+ my ($w, $x, $y) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ if ($w->InsideArmedIndicator($x, $y))
+ {
+ $w->IndicatorCmd('<Arm>', $data->{'indicator'});
+ }
+ else
+ {
+ $w->GoState(21, $x, $y);
+ }
+ }
+
+sub GoState_21
+ {
+ my ($w, $x, $y) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ unless ($w->InsideArmedIndicator($x, $y))
+ {
+ $w->IndicatorCmd('<Disarm>', $data->{'indicator'});
+ }
+ else
+ {
+ $w->GoState(20, $x, $y);
+ }
+ }
+
+sub GoState_22
+ {
+ my ($w) = @_;
+ my $data = $w->MainWindow->privateData('Tix');
+ if (@{ $data->{oldEntry} })
+ {
+ $w->anchor('set', @{ $data->{oldEntry} });
+ }
+ else
+ {
+ $w->anchor('clear');
+ }
+ $w->GoState(0);
+ }
+
+
+#----------------------------------------------------------------------
+# callback actions
+#----------------------------------------------------------------------
+
+sub SetAnchor
+ {
+ my ($w, @ent) = @_;
+
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+# $w->see(@ent);
+ }
+ }
+
+# xxx check @ent of @$ent
+sub Select
+ {
+ my ($w, @ent) = @_;
+ $w->selection('clear');
+ $w->selection('set', @ent)
+ }
+
+# xxx check new After handling
+sub StartScan
+ {
+ my ($w) = @_;
+ $Tk::afterId = $w->after(50, [AutoScan, $w]);
+ }
+
+sub DoScan
+ {
+ my ($w) = @_;
+ my $x = $Tk::x;
+ my $y = $Tk::y;
+ my $X = $Tk::X;
+ my $Y = $Tk::Y;
+
+ my $out = 0;
+ if ($y >= $w->height)
+ {
+ $w->yview('scroll', 1, 'units');
+ $out = 1;
+ }
+ if ($y < 0)
+ {
+ $w->yview('scroll', -1, 'units');
+ $out = 1;
+ }
+ if ($x >= $w->width)
+ {
+ $w->xview('scroll', 2, 'units');
+ $out = 1;
+ }
+ if ($x < 0)
+ {
+ $w->xview('scroll', -2, 'units');
+ $out = 1;
+ }
+ if ($out)
+ {
+ $Tk::afterId = $w->after(50, ['AutoScan', $w]);
+ }
+ }
+
+
+#proc tixGrid:CallBrowseCmd {w ent} {
+# return
+#
+# set browsecmd [$w cget -browsecmd]
+# if {$browsecmd != ""} {
+# set bind(specs) {%V}
+# set bind(%V) $ent
+#
+# tixEvalCmdBinding $w $browsecmd bind $ent
+# }
+#}
+
+#proc tixGrid:CallCommand {w ent} {
+# set command [$w cget -command]
+# if {$command != ""} {
+# set bind(specs) {%V}
+# set bind(%V) $ent
+#
+# tixEvalCmdBinding $w $command bind $ent
+# }
+#}
+
+# tixGrid:EditCell --
+#
+# This command is called when "$w edit set $x $y" is called. It causes
+# an SetEdit call when the grid's state is 0.
+#
+
+sub EditCell
+ {
+ my ($w, $x, $y) = @_;
+ my $list = $w->privateData()->{'list'};
+ if ($w->GetState == 0)
+ {
+ $w->SetEdit($x, $y); # xxx really correct ? once 2, once 4 args?
+ }
+ else
+ {
+ push(@$list, [ $w, 'SetEdit', $x, $y]);
+ }
+ }
+#proc tixGrid:EditCell {w x y} {
+# set list $w:_list
+# global $list
+#
+# case [tixGrid:GetState $w] {
+# {0} {
+# tixGrid:SetEdit $w [list $x $y]
+# }
+# default {
+# lappend $list [list tixGrid:SetEdit $w [list $x $y]]
+# }
+# }
+#}
+
+
+# tixGrid:EditApply --
+#
+# This command is called when "$w edit apply $x $y" is called. It causes
+# an CheckEdit call when the grid's state is 0.
+#
+
+sub EditApply
+ {
+ my ($w) = @_;
+ my $list = $w->privateData()->{'list'};
+ if ($w->GetState eq 0)
+ {
+ $w->CheckEdit; # xxx really correct ? once 2, once 4 args?
+ }
+ else
+ {
+ push(@$list, $w->CheckEdit);
+ }
+ }
+#proc tixGrid:EditApply {w} {
+# set list $w:_list
+# global $list
+#
+# case [tixGrid:GetState $w] {
+# {0} {
+# tixGrid:CheckEdit $w
+# }
+# default {
+# lappend $list [list tixGrid:CheckEdit $w]
+# }
+# }
+#}
+
+# tixGrid:CheckEdit --
+#
+# This procedure is called when the user sets the focus on a cell.
+# If another cell is being edited, apply the changes of that cell.
+#
+
+sub CheckEdit
+ {
+ my ($w) = @_;
+ my $edit = $w->privateData->{editentry};
+ if (Tk::Exists($edit))
+ {
+ # If it -command is not empty, it is being used for another cell.
+ # Invoke it so that the other cell can be updated.
+ #
+ if (defined $edit->cget('-command'))
+ {
+ $edit->invoke; # xxx no args??
+ }
+ }
+ }
+
+sub SetFocus
+ {
+ my ($w) = @_;
+ if ($w->cget('-takefocus'))
+ {
+$w->focus;
+# # xxx translation of if ![string match $w.* [focus -displayof $w]] {
+# my $hasfocus = $w->focus(-displayof => $w)->pathname;
+# my $pathname = $w->pathname;
+# if ($hasfocus =~ /\Q$pathname\E.*/)
+# {
+# $w->focus
+# }
+ }
+ }
+
+
+# tixGrid:SetEdit --
+#
+# Puts a floatentry on top of an editable entry.
+#
+
+sub SetEdit
+ {
+ my ($w, $px, $py) = @_;
+
+ $w->CheckEdit;
+
+ my $efc = $w->cget('-editnotifycmd');
+ return unless ( defined($efc) && length($efc) );
+
+ unless ($w->Callback('-editnotifycmd' => $px, $py))
+ {
+ print STDERR "editnotifycmd not defined or returned false\n";
+ return;
+ }
+
+ my $oldvalue;
+ if ($w->info('exists', $px, $py))
+ {
+ # if entry doesn't support -text option. Can't edit it.
+ #
+ # If the application wants to force editing of an entry, it could
+ # delete or replace the entry in the editnotifyCmd procedure.
+ #
+ Tk::catch { $oldvalue = $w->entrycget($px, $py, '-text'); };
+ if ($@)
+ {
+ return;
+ }
+ }
+ else
+ {
+ $oldvalue = '';
+ }
+
+ my @bbox = $w->info('bbox', $px, $py);
+
+ my $edit = $w->privateData()->{__EDIT__};
+ unless (Tk::Exists($edit))
+ {
+ require Tk::FloatEntry;
+ $edit = $w->FloatEntry();
+ $w->privateData()->{__EDIT__} = $edit;
+ }
+ $edit->configure(-command=>[\&DoneEdit, $w, $px, $py]);
+ $edit->post(@bbox);
+ $edit->configure(-value=>$oldvalue);
+}
+
+
+sub DoneEdit
+ {
+ my ($w, $x, $y, @args) = @_;
+
+ my $edit = $w->privateData()->{__EDIT__};
+ $edit->configure(-command=>undef);
+ $edit->unpost;
+
+ # FIX xxx
+ # set value [tixEvent value]
+ my $value = $edit->get;
+ if ($w->info('exists', $x, $y))
+ {
+ Tk::catch { $w->entryconfigure($x, $y, -text=>$value) };
+ if ($@)
+ {
+ return
+ }
+ }
+ elsif ( length($value) )
+ {
+ # This needs to be catch'ed because the default itemtype may
+ # not support the -text option
+ #
+ Tk::catch { $w->set($x,$y,-text $value); };
+ if ($@)
+ {
+ return;
+ }
+ }
+ else
+ {
+ return;
+ }
+ $w->Callback('-editdonecmd' => $x, $y);
+ }
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TixGrid.pod b/Master/tlpkg/tlperl.straw/lib/Tk/TixGrid.pod
new file mode 100755
index 00000000000..23aa4468bfa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TixGrid.pod
@@ -0,0 +1,539 @@
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distribution are in the file
+# license.tcl.
+
+## TO CHECK:
+##
+## callback: checked for defined of code ref (compare -edit*cmd)
+##
+## option
+## formatcmd mentions format method but there is no format
+## method documented
+##
+## methods:
+## bdtype: what is it? no description given
+## see: not documented? Not implemented??
+##
+## todo: missing peaces marked by ????
+
+=head1 NAME
+
+Tk::TixGrid - Create and manipulate Tix Grid widgets
+
+=for pm TixGrid/TixGrid.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+S< >I<$tixgrid> = I<$parent>->B<TixGrid>?(I<options>)?;
+
+=head1 DESCRIPTION
+
+This widget is intended as the basis of "spread sheet" like interfaces.
+The widget displays its contents in a two dimensional "grid" of cells.
+Each cell may contain one Tix display item, which may be in text,
+graphics or other formats. See L<Tk::DItem> for more information
+about Tix display items. Because these "items" need not be "windows" large
+grids can be handled without consuming excessive display system resources.
+
+Individual cells, or groups of cells, can be formatted with a wide range of
+attributes, such as its color, relief and border. However because the
+widget is intended to handle large grids the mechanisms to achieve these
+are lower level, and more callback oriented than for other widgets. The
+assumption is that to avoid storing display details of a large number
+of cells, the data will be re-computed as needed.
+
+The port of Tix C code and some of the bindings to perl/Tk is done but still
+need further work. In several places the intent of the Tix code is not
+yet understood. For example the 'edit' interface is clearly intended
+for spread-sheet like cell content editing in an auxillary "entry" widget
+or similar, but how that should work is not yet clear.
+
+The B<TixGrid> method creates a new TixGrid window and returns a
+blessed reference of this TixGrid widget. Additional options,
+described below, may be specified on the command line or in the
+option database to configure aspects of the B<TixGrid> widget.
+
+=head1 STANDARD OPTIONS
+
+B<-background>
+ B<-borderwidth>
+ B<-cursor>
+ B<-font>
+ B<-foreground>
+ B<-height>
+ B<-highlightbackground>
+ B<-highlightcolor>
+ B<-highlightthickness>
+ B<-padx>
+ B<-pady>
+ B<-relief>
+ B<-selectbackground>
+ B<-selectborderwidth>
+ B<-selectforeground>
+ B<-state>
+ B<-takefocus>
+ B<-width>
+ B<-xscrollcommand>
+ B<-yscrollcommand>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<browseCmd>
+
+=item Class: B<BrowseCmd>
+
+=item Switch: B<-browsecmd>
+
+If defined, gives a perl/Tk L<callback|Tk::callbacks> to be executed when the
+user browses a grid cell (This is normally the case when the user clicks on an
+entry). When this callback is called, it is passed with two additional
+parameters: I<x> I<y>, where (I<x>,I<y>) is the location of the cell that has
+just been clicked.
+
+=item Name: B<Command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+If defined, gives a perl/Tk L<callback|Tk::callbacks> to be executed when the
+user double-clicks a grid cell. When this callback is called, it is passed
+with two additional parameters: I<x> I<y>, where (I<x>,I<y>) is the location of
+the cell that has just been clicked.
+
+=item Name: B<editDoneCmd>
+
+=item Class: B<EditDoneCmd>
+
+=item Switch: B<-editdonecmd>
+
+If defined, gives a perl/Tk L<callback|Tk::callbacks>
+to be executed when the
+user has edited grid cell. When this callback is called, it is
+passed with two additional parameters: I<x> I<y>, where (I<x>,I<y>)
+is the location of the cell that has just been edited.
+
+=item Name: B<editNotifyCmd>
+
+=item Class: B<EditNotifyCmd>
+
+=item Switch: B<-editnotifycmd>
+
+If defined gives a perl/Tk L<callback|Tk::callbacks>
+to be executed when the user tries to edit a grid cell.
+When this callback is called, it is passed with two additional
+parameters: I<x> I<y>, where (I<x>,I<y>,) is the location
+of the cell. This callback should return a boolean value: B<true>
+indicates that the cell is editable and B<false> otherwise.
+
+=item Name: B<FloatingCols>
+
+=item Class: B<floatingCols>
+
+=item Switch: B<-floatingcols>
+
+Defines the number of extra columns beyond the existing grid
+that can be brought into view by scrolling.
+
+=item Name: B<FloatingRows>
+
+=item Class: B<floatingRows>
+
+=item Switch: B<-floatingrows>
+
+Defines the number of extra rows beyond the the existing grid
+that can be brought into view by scrolling.
+
+=item Name: B<formatCmd>
+
+=item Class: B<FormatCmd>
+
+=item Switch: B<-formatcmd>
+
+If defined, gives a perl/Tk L<callback|Tk::callbacks> to be
+executed when the grid cells need to be displayed on the screen.
+Its primary purpose is to draw the background of the region
+before the cells are rendered on top. This is normally
+achieved by calling B<formatGrid> or B<formatBorder> (see below).
+However other uses can be made of this low-level callback. For example it can be used
+to "lazily" populate the grid by calling the B<set> method only as cells come
+into view.
+
+When this callback is called, it is passed with five additional
+parameters: I<type> I<x1> I<y1> I<x2> I<y2>.
+
+I<x1> I<y1> I<x2> I<y2> gives the extent of the region that needs
+formatting.
+
+I<type> gives the logical type of the region in the grid. It may be one of the
+following.
+
+=over 8
+
+=item B<x_region>
+
+The horizontal margin.
+
+=item B<y_region>
+
+The vertical margin.
+
+=item B<s_region>
+
+The area in the top left corner where the horizontal and vertical margins
+are joined.
+
+=item B<main>
+
+The main body i.e. all the cells that do not fall into the above three types.
+
+=back
+
+=item Name: B<leftMargin>
+
+=item Class: B<LeftMargin>
+
+=item Switch: B<-leftmargin>
+
+Gives the width of vertical margin in cells (columns).
+A zero indicates that no vertical margin exists. A positive value I<N>
+indicates that first I<N> columns are "labels" and are always displayed
+and not scrolled.
+
+=item Name: B<itemType>
+
+=item Class: B<ItemType>
+
+=item Switch: B<-itemtype>
+
+Default item type for cells.
+
+=item Name: B<selectMode>
+
+=item Class: B<SelectMode>
+
+=item Switch: B<-selectmode>
+
+Specifies one of several styles for manipulating the selection.
+The value of the option may be arbitrary, but the default bindings
+expect it to be either B<single>, B<browse>, B<multiple>, or B<extended>;
+the default value is B<single>.
+
+=item Name: B<selectUnit>
+
+=item Class: B<SelectUnit>
+
+=item Switch: B<-selectunit>
+
+Specifies the selection unit. Valid values are B<cell>, B<column> or B<row>.
+
+=item Name: B<sizeCmd>
+
+=item Class: B<SizeCmd>
+
+=item Switch: B<-sizecmd>
+
+Callback is called (with no extra arguments) when grid sizes are
+re-computed. For example if window changes size, a different font
+is specified etc.
+
+It is called just after scrollbars (if present) are updated.
+
+=item Name: B<topMargin>
+
+=item Class: B<TopMargin>
+
+=item Switch: B<-topmargin>
+
+Gives the width of horizontal margin in cells (rows).
+A zero indicates that no horizontal margin exists. A positive value
+I<N> indicates that first I<N> rows are "labels" and are always
+displayed and not scrolled.
+
+=back
+
+=head1 WIDGET METHODS
+
+The B<TixGrid> method creates a TixGrid widget and returns a blessed
+reference of this TixGrid widget. This reference may be used to
+invoke various operations on the widget. It has the following general
+form:
+
+S< >I<$tixgrid>->B<method>?(I<arg, arg, ...>)?
+
+I<arg>s determine the exact behavior of the method.
+
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are possible for B<TixGrid> widgets:
+
+=over 4
+
+=item I<$tixgrid>->B<anchorGet>(I<x>, I<y>)
+
+=item I<$tixgrid>->B<anchorSet>(I<x>, I<y>)
+
+=item I<$tixgrid>->B<anchorClear>
+
+Manipulates the B<anchor cell> of the B<TixGrid> widget.
+The anchor cell is the end of the selection that is fixed
+while the user is dragging out a selection with the mouse.
+
+=item ($bd,$col,$row) = I<$tixgrid>->B<bdtype>(I<x,y> ?,I<xDelta>,I<yDelta>?)
+
+Determines if the the screen (pixel) position I<x,y> is in a border.
+This is useful for changing the mouse cursor when the user points at a
+border - e.g. to indicate that the border can be adjusted
+interactively.
+
+If in a border returns a list of three elements. First element
+is 'xy', 'x' or 'y', second two elements are integers.
+(Value of these are not understood, seem to indicate which
+column and row of the border the screen position corresponds to?)
+
+If not in a border returns an empty list.
+
+=item I<$tixgrid>->B<delete>(I<dim>, I<from>?, I<to>?)
+
+=item I<$tixgrid>->B<deleteColumn>(I<from>?, I<to>?)
+
+=item I<$tixgrid>->B<deleteRow>(I<from>?, I<to>?)
+
+I<Dim> may be B<row> or B<column>. If I<to> is not given,
+deletes a single row (or column) at the position I<from>.
+If I<to> is given, deletes the range of rows (or columns)
+from position I<from> through I<to>.
+
+=item I<$tixgrid>->B<dragsite>(I<option>, I<x>, I<y>)
+
+=item I<$tixgrid>->B<dropsite>(I<option>, I<x>, I<y>)
+
+Tcl/Tix has (or was going to have) Drag&Drop support.
+Meaning for perl/Tk is not clear yet.
+
+=item I<$tixgrid>->B<editApply>
+
+If any cell is being edited, de-highlight the cell and
+applies the changes.
+
+=item I<$tixgrid>->B<editSet>(I<x>, I<y>)
+
+Highlights the cell at (I<x>,I<y>) for editing,
+if the B<-editnotify> callback returns true for this cell.
+
+=item I<$tixgrid>->B<entrycget>(I<x>, I<y>, 'I<-option>')
+
+=item I<$tixgrid>->B<entryconfigure>(I<x>, I<y>?, I<-option>??=>I<value>, I<-option>=>I<value>, I<...>?)
+
+Provide a configue interface to cells in the grid.
+The I<-option>s depend on the item type of the cell.
+
+=item I<$tixgrid>->B<formatBorder>(I<x1,y1>, I<x2,y2>, I<options>);
+
+=item I<$tixgrid>->B<formatGrid>(I<x1,y1>, I<x2,y2>, I<options>);
+
+The B<formatBorder> and B<formatBorder> methods can only be called by the
+B<-formatcmd> callback of the tixGrid widget. They draw the background of
+the region described by I<x1,y1>, I<x2,y2> according the the supplied
+I<options>. One call to B<-formatcmd> callback can make multiple
+calls to B<formatBorder> and/or B<formatBorder> for different
+sub-regions.
+
+B<formatBorder> draws the background using Tk relief style,
+B<formatGrid> also draws grid lines between the cells.
+It only makes sense to call one or the other for a particular
+sub-region as one will over-write the other.
+
+The options allowed are:
+
+=over 8
+
+=item -background / -bg
+
+=item -borderwidth / -bd
+
+=item -filled
+
+=item -relief
+
+=item -selectbackground
+
+=item -xoff
+
+=item -xon
+
+=item -yoff
+
+=item -yon
+
+=back
+
+The B<-xon/-xoff and -yon/-yoff> options are obscure. If anyone
+can figure out how to do something interesting given what
+F<pTk/tixGrFmt.c> is doing with them please let Nick know!.
+
+=item I<$tixgrid>->B<geometryinfo>(?I<width>, I<height>?)
+
+Returns list of four values - two sets of two floating point numbers.
+First set is the scrollbar fractions for x direction, second set
+is scrollbar fractions for y direction. If I<width> and I<height>
+are specified then fractions are based on as if window size was of
+specified size (in pixels, but not allowing normal GetPixels units).
+Otherwise fractions are based on current size of the window.
+
+Usage obscure.
+
+=item I<$tixgrid>->B<index>(I<xcoord>, I<ycoord>)
+
+Retuns I<(x, y)> of entry at position (I<$coordx>, I<$coordy>).
+Either coordinate may be B<'max'> which is largest existing entry
+in that direction, B<'end'> which is one I<beyond> largest existing
+entry, or a number. (This is how you find out how big the grid is.)
+
+=item I<$tixgrid>->B<infoBbox>(I<x>,I<y>)
+
+Return the pixel bounding box of the cell at I<x,y>.
+
+=item I<$tixgrid>->B<infoExists>(I<x>,I<y>)
+
+Returns true if there is an item in the cell at I<x,y>.
+Throws an exception (dies) if I<x,y> is outside the
+grid - this may change (Nick doesn't like it).
+
+=item I<$tixgrid>->B<move>(I<dim>, I<from>, I<to>, I<offset>)
+
+=item I<$tixgrid>->B<moveColumn>(I<from>, I<to>, I<offset>)
+
+=item I<$tixgrid>->B<moveRow>(I<from>, I<to>, I<offset>)
+
+I<Dim> may be B<row> or B<column>. Moves the range of rows
+(or columns) from position I<from> through I<to> by the distance
+indicated by I<offset>. For example,
+I<$tixgrid>->B<moveRow>(B<2>, B<4>, B<1>) moves the rows 2,3,4
+to rows 3,4,5.
+
+=item I<$tixgrid>->B<nearest>(I<x>, I<y>)
+
+Screen pos (pixels) to entry (nx,ny) translation.
+
+=item I<$tixgrid>->B<selectionAdjust>(I<x1>, I<y1> ?,I<x2>, I<y2>?)
+
+=item I<$tixgrid>->B<selectionClear>(I<x1>, I<y1> ?,I<x2>, I<y2>?)
+
+=item I<$tixgrid>->B<selectionIncludes>(I<x1>, I<y1> ?,I<x2>, I<y2>?)
+
+=item I<$tixgrid>->B<selectionSet>(I<x1>, I<y1> ?,I<x2>, I<y2>?)
+
+=item I<$tixgrid>->B<selectionToggle>(I<x1>, I<y1> ?,I<x2>, I<y2>?)
+
+Selection support methods - probably buggy.
+
+x1 (y1) has not to be greater than x2 (y2), but only x2 and y2 can be 'max'.
+
+BUG: I<selectionIncludes>: has no visible effect (as in Tix). Eh???
+
+BUG: I<selectionClear>: only works for 0, 0, max, max (as in Tix). Eh???
+
+When I<x2, y2> are not given they default to I<x1, y1>, respectively.
+
+=item I<$tixgrid>->B<set>(I<x>, I<y>?, B<-itemtype>=>I<type>??, I<-option>=>I<value>, I<...>?)
+
+Creates a new display item at the cell at (I<x>,I<y>). The optional
+B<-itemtype> parameter gives the type of the display item.
+An additional list of I<option-value> pairs specify options
+of the display item. If a display item already exists at this cell,
+the old item will be deleted automatically.
+
+=item I<$tixgrid>->B<size>(I<dim>, I<index>?, I<-option>??=>I<value>, I<...>?)
+
+=item I<$tixgrid>->B<sizeColumn>(I<index>?, I<-option>??=>I<value>, I<...>?)
+
+=item I<$tixgrid>->B<sizeRow>(I<index>?, I<-option>??=>I<value>, I<...>?)
+
+Queries or sets the size of the row or column given by I<dim> and
+I<index>. I<Dim> may be B<row> or B<column>. I<Index> may be any
+non-negative integer that gives the position of a given row (or column).
+I<Index> can also be the string B<default>; in this case, this method
+queries or sets the default size of all rows (or columns).
+When no I<option-value> pair is given, this method returns
+a list containing the current size setting of the given row (or column).
+When I<option-value> pairs are given, the corresponding options
+of the size setting of the given row are changed. I<-option> may be
+one of the following:
+
+=over 8
+
+=item B<-pad0> => I<pixels>
+
+Specifies the paddings to the left of a column or the top of a row.
+
+=item B<-pad1> => I<pixels>
+
+Specifies the paddings to the right of a column or the bottom of a row.
+
+=item B<-size> => I<val>
+
+Specifies the width of a column or the height of a row.
+I<Val> may be: B<auto> -- the width of the column is set
+the widest cell in the column; a valid Tk screen distance
+unit (see B<Tk_GetPixels>); or a real number following by the
+word B<chars> (e.g. B<3.4chars>) that sets the width of the
+column to the given number of characters.
+
+=back
+
+=item I<$tixgrid>->B<sort>(I<dimension>, I<start>, I<end>, ?I<args ...>?)
+
+?docu here? (not supported on Win* OSs up to now)
+
+=item I<$tixgrid>->B<unset>(I<x>, I<y>)
+
+Clears the cell at (I<x>,I<y>) by removing its display item.
+
+=item I<$tixgrid>->B<xview>
+
+Normal horizontal scrollbar method.
+
+=item I<$tixgrid>->B<yview>
+
+Normal vertical scrollbar method.
+
+=back
+
+=head1 BINDINGS
+
+To be done - only most obvious basic bindings work. The Tcl/Tix code
+was coded as a "state machine" which is not easy to follow.
+
+=head1 SEE ALSO
+
+L<Tk::DItem|Tk::DItem>
+L<Tk::callbacks|Tk::callbacks>
+L<Tk::FloatEntry|Tk::FloatEntry>
+
+=head1 BUGS
+
+Tcl/Tix was/is not finished and both C code and bindings of TixGrid
+have some bugs.
+
+=head1 KEYWORDS
+
+tix, tixgrid, table, display item, spreadsheet
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Tk.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/Tk.xbm
new file mode 100755
index 00000000000..136d4793037
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Tk.xbm
@@ -0,0 +1,44 @@
+#define Tk.xbm_width 61
+#define Tk.xbm_height 61
+static unsigned char Tk.xbm_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x80, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0xe0, 0x0f, 0x00, 0x00, 0x00, 0x80, 0x07, 0x00, 0xf8, 0x0e, 0x00, 0x00,
+ 0x00, 0xe0, 0x1e, 0x00, 0xbe, 0x3e, 0x00, 0x00, 0x00, 0xfb, 0x1e, 0x00,
+ 0xfe, 0x7f, 0x00, 0x00, 0x80, 0xdf, 0x0f, 0x00, 0xff, 0xbf, 0x00, 0x00,
+ 0x80, 0xe0, 0x3d, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x47, 0x7f, 0x80,
+ 0xff, 0xfd, 0x01, 0x00, 0x00, 0x7f, 0x3e, 0xc0, 0xff, 0xf1, 0x01, 0x00,
+ 0x00, 0x30, 0x7f, 0xf0, 0xfe, 0xb3, 0x03, 0x00, 0x00, 0xf8, 0x3e, 0x7c,
+ 0xff, 0xcf, 0x07, 0x00, 0x00, 0x78, 0x37, 0xfc, 0x7b, 0xc3, 0x07, 0x00,
+ 0x00, 0xfc, 0x3d, 0xfe, 0x3c, 0x25, 0x0e, 0x00, 0x00, 0xfc, 0x3e, 0x5f,
+ 0x18, 0x41, 0x0b, 0x00, 0x00, 0x5c, 0x3f, 0x5f, 0xf0, 0x59, 0x1b, 0x00,
+ 0x00, 0xdc, 0x9f, 0x3f, 0xe8, 0xbe, 0x17, 0x00, 0x00, 0xbc, 0x9f, 0x2f,
+ 0xa8, 0x5b, 0x15, 0x00, 0x00, 0xdc, 0xdf, 0x25, 0x48, 0x7a, 0x34, 0x00,
+ 0x00, 0x7c, 0xce, 0x1f, 0x20, 0x2c, 0x36, 0x00, 0x00, 0x7c, 0xa7, 0x1f,
+ 0xcc, 0x09, 0xf0, 0x00, 0x00, 0xfc, 0xae, 0x1f, 0x49, 0x05, 0xf6, 0x00,
+ 0x00, 0xfc, 0xac, 0x3f, 0xf8, 0x11, 0xf6, 0x00, 0x00, 0xf8, 0x8d, 0x3f,
+ 0x8e, 0x0e, 0xd6, 0x01, 0x00, 0xf8, 0x9c, 0x7e, 0xd7, 0x5b, 0xff, 0x03,
+ 0x00, 0x70, 0x83, 0x5f, 0xcf, 0xfd, 0xbf, 0x01, 0x00, 0xe0, 0xc3, 0x3b,
+ 0xc7, 0xff, 0x3f, 0x03, 0x00, 0xe0, 0xcf, 0xbf, 0xe3, 0xff, 0x97, 0x03,
+ 0x00, 0x80, 0xfb, 0x7f, 0xfb, 0xff, 0x17, 0x01, 0x00, 0x80, 0xef, 0xff,
+ 0xb3, 0x6f, 0x17, 0x03, 0x00, 0x00, 0xff, 0xff, 0xdf, 0x3f, 0x17, 0x03,
+ 0x00, 0x00, 0x88, 0xff, 0xbf, 0x3f, 0x1b, 0x03, 0x00, 0x00, 0x00, 0x7b,
+ 0x3d, 0x1f, 0x9f, 0x01, 0x00, 0x00, 0x80, 0x1f, 0x7f, 0x1f, 0x9e, 0x00,
+ 0x00, 0x00, 0x80, 0x1f, 0x3f, 0x0f, 0x1e, 0x00, 0x00, 0x00, 0x80, 0x1f,
+ 0x1f, 0x0f, 0x1e, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x1f, 0x0e, 0x1e, 0x00,
+ 0x00, 0xfe, 0x81, 0x8f, 0x1f, 0x0f, 0x1c, 0x00, 0x00, 0x98, 0x81, 0xc7,
+ 0x1f, 0x0e, 0x18, 0x00, 0x00, 0x98, 0x01, 0xc7, 0x0f, 0x0a, 0x18, 0x00,
+ 0xfc, 0x98, 0x99, 0xc7, 0x07, 0x0e, 0x18, 0x00, 0x8c, 0x99, 0x8d, 0xc7,
+ 0x02, 0x0e, 0x18, 0x00, 0x8c, 0x99, 0x07, 0xc3, 0x03, 0x03, 0x18, 0x00,
+ 0x8c, 0x99, 0x07, 0xc7, 0x01, 0x03, 0x28, 0x00, 0x8c, 0x99, 0x0d, 0x03,
+ 0x03, 0x01, 0x08, 0x00, 0xfc, 0x98, 0x19, 0x03, 0x86, 0x01, 0x18, 0x00,
+ 0x0c, 0x00, 0x00, 0x03, 0xc4, 0x01, 0x10, 0x00, 0x0c, 0x00, 0x00, 0x03,
+ 0x88, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x03, 0x90, 0x00, 0x18, 0x00,
+ 0x00, 0x00, 0x00, 0x01, 0x30, 0x00, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01,
+ 0xf0, 0x01, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01, 0xf8, 0x01, 0x18, 0x00,
+ 0x00, 0x00, 0xc0, 0x01, 0x9e, 0x03, 0x04, 0x00, 0x00, 0x00, 0xc0, 0x01,
+ 0xb3, 0x01, 0x04, 0x00, 0x00, 0x00, 0x60, 0x00, 0x00, 0x01, 0x18, 0x00,
+ 0x00, 0x00, 0x60, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0xdc, 0x00,
+ 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x88, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Tk.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/Tk.xpm
new file mode 100755
index 00000000000..7880a637f39
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Tk.xpm
@@ -0,0 +1,41 @@
+/* XPM */
+static char *Tk[] = {
+/* width height num_colors chars_per_pixel */
+" 32 32 2 1",
+/* colors */
+"# c #008080",
+"a c #ff0000",
+/* pixels */
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"##########aaaaaaaa##############",
+"#######aaaaaaaaaaaa#######aa####",
+"#####aaaaaaaaaaaaaa######aaa####",
+"####aaaaaaaaaaaaaaaa####aaaa####",
+"####aaaaaaa######aa####aaaa#####",
+"###aaaa#########aaa###aaaa######",
+"###aaaa#########aa###aaaa#######",
+"######aa#######aa####aaa########",
+"##############aaa###aaaa########",
+"#############aaa###aaaa##aaa####",
+"#############aa####aaa#aaaaa####",
+"############aaa###aaa#aaaaaa####",
+"###########aaa####aa#aa#aaa#####",
+"###########aaa###aa#aa#aaa######",
+"##########aaa####aaaaaaaa#aa####",
+"##########aaa####aaaaaaa##aa####",
+"#########aaaa####aaaaaaaaaa#####",
+"#########aaa#####aa##aaaaa######",
+"#########aaa##########aa########",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################"
+};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/TkXSUB.def b/Master/tlpkg/tlperl.straw/lib/Tk/TkXSUB.def
new file mode 100755
index 00000000000..8f60974226e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/TkXSUB.def
@@ -0,0 +1,62 @@
+MkXSUB("Tk::bind", XS_Tk_bind, XStoBind, Tk_BindObjCmd)
+MkXSUB("Tk::pack", XS_Tk_pack, XStoAfterSub, Tk_PackObjCmd)
+MkXSUB("Tk::grid", XS_Tk_grid, XStoGrid, Tk_GridObjCmd)
+MkXSUB("Tk::place", XS_Tk_place, XStoAfterSub, Tk_PlaceObjCmd)
+MkXSUB("Tk::form", XS_Tk_form, XStoAfterSub, Tix_FormCmd)
+MkXSUB("Tk::itemstyle", XS_Tk_itemstyle, XStoTclCmd, Tix_ItemStyleCmd)
+MkXSUB("Tk::winfo", XS_Tk_winfo, XStoSubCmd, Tk_WinfoObjCmd)
+MkXSUB("Tk::font", XS_Tk_font, XStoFont, Tk_FontObjCmd)
+MkXSUB("Tk::wm", XS_Tk_wm, XStoAfterSub, Tk_WmObjCmd)
+MkXSUB("Tk::grab", XS_Tk_grab, XStoSubCmd, Tk_GrabObjCmd)
+MkXSUB("Tk::focus", XS_Tk_focus, XStoSubCmd, Tk_FocusObjCmd)
+MkXSUB("Tk::event", XS_Tk_event, XStoEvent, Tk_EventObjCmd)
+MkXSUB("Tk::property", XS_Tk_property, XStoSubCmd, Tk_PropertyCmd)
+MkXSUB("Tk::clipboard", XS_Tk_clipboard, XStoDisplayof, Tk_ClipboardObjCmd)
+MkXSUB("Tk::bell", XS_Tk_bell, XStoDisplayof, Tk_BellObjCmd)
+MkXSUB("Tk::bindtags", XS_Tk_bindtags, XStoTk, Tk_BindtagsObjCmd)
+MkXSUB("Tk::destroy", XS_Tk_destroy, XStoTk, Tk_DestroyObjCmd)
+MkXSUB("Tk::raise", XS_Tk_raise, XStoTk, Tk_RaiseObjCmd)
+MkXSUB("Tk::lower", XS_Tk_lower, XStoTk, Tk_LowerObjCmd)
+MkXSUB("Tk::option", XS_Tk_option, XStoOption, Tk_OptionObjCmd)
+MkXSUB("Tk::image", XS_Tk_image, XStoImage, Tk_ImageObjCmd)
+MkXSUB("Tk::selection", XS_Tk_selection, XStoTk, Tk_SelectionObjCmd)
+
+#if defined(__WIN32__) || defined(MAC_TCL)
+MkXSUB("Tk::tk_chooseColor", XS_Tk_tk_chooseColor, XStoTk, Tk_ChooseColorObjCmd)
+MkXSUB("Tk::tk_chooseDirectory", XS_Tk_tk_chooseDirectory, XStoTk, Tk_ChooseDirectoryObjCmd)
+MkXSUB("Tk::tk_getOpenFile", XS_Tk_tk_getOpenFile, XStoTk, Tk_GetOpenFileObjCmd)
+MkXSUB("Tk::tk_getSaveFile", XS_Tk_tk_getSaveFile, XStoTk, Tk_GetSaveFileObjCmd)
+#endif
+#if defined(__WIN32__)
+MkXSUB("Tk::tk_messageBox", XS_Tk_tk_messageBox, XStoTk, Tk_MessageBoxObjCmd)
+#endif
+
+MkXSUB("Tk::tk", XS_Tk_tk, XStoTclCmd, Tk_TkObjCmd)
+
+#if 0
+MkXSUB("Tk::exit", XS_Tk_exit, XStoNoWindow, Tcl_ExitCmd)
+MkXSUB("Tk::fileevent", XS_Tk_fileevent, XStoNoWindow, Tcl_FileeventCmd)
+#endif
+MkXSUB("Tk::after", XS_Tk_after, XStoNoWindow, Tcl_AfterObjCmd)
+#ifndef WIN32
+MkXSUB("Tk::send", XS_Tk_send, XStoTclCmd, Tk_SendCmd)
+#endif
+
+MkXSUB("Tk::button", XS_Tk_button, XStoTclCmdNull, Tk_ButtonObjCmd)
+MkXSUB("Tk::checkbutton", XS_Tk_checkbutton, XStoTclCmdNull, Tk_CheckbuttonObjCmd)
+MkXSUB("Tk::label", XS_Tk_label, XStoTclCmdNull, Tk_LabelObjCmd)
+MkXSUB("Tk::radiobutton", XS_Tk_radiobutton, XStoTclCmdNull, Tk_RadiobuttonObjCmd)
+MkXSUB("Tk::_menu", XS_Tk__menu, XStoTclCmdNull, 0)
+
+MkXSUB("Tk::message", XS_Tk_message, XStoTclCmd, Tk_MessageObjCmd)
+MkXSUB("Tk::frame", XS_Tk_frame, XStoTclCmd, Tk_FrameObjCmd)
+MkXSUB("Tk::labelframe", XS_Tk_labelframe, XStoTclCmd, Tk_LabelframeObjCmd)
+MkXSUB("Tk::panedwindow", XS_Tk_panedwindow, XStoTclCmd, Tk_PanedWindowObjCmd)
+MkXSUB("Tk::toplevel", XS_Tk_toplevel, XStoTclCmd, Tk_ToplevelObjCmd)
+MkXSUB("Tk::update", XS_Tk_update, XStoTclCmd, Tk_UpdateObjCmd)
+MkXSUB("Tk::tkwait", XS_Tk_tkwait, XStoTclCmd, Tk_TkwaitObjCmd)
+MkXSUB("Tk::configure", XS_Tk_configure, XStoWidget, newSVpv("configure",0))
+MkXSUB("Tk::cget", XS_Tk_cget, XStoWidget, newSVpv("cget",0))
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Toplevel.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Toplevel.pm
new file mode 100755
index 00000000000..7bcd156d475
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Toplevel.pm
@@ -0,0 +1,211 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Toplevel;
+use AutoLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $
+
+use base qw(Tk::Wm Tk::Frame);
+
+Construct Tk::Widget 'Toplevel';
+
+sub Tk_cmd { \&Tk::toplevel }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-screen','-use')
+}
+
+sub Populate
+{
+ my ($cw,$arg) = @_;
+ $cw->SUPER::Populate($arg);
+ $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]);
+}
+
+sub Icon
+{
+ my ($top,%args) = @_;
+ my $icon = $top->iconwindow;
+ my $state = $top->state;
+ if ($state ne 'withdrawn')
+ {
+ $top->withdraw;
+ $top->update; # Let attributes propogate
+ }
+ unless (defined $icon)
+ {
+ $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon');
+ $icon->withdraw;
+ # Fake Populate
+ my $lab = $icon->Component('Label' => 'icon');
+ $lab->pack('-expand'=>1,'-fill' => 'both');
+ $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']);
+ # Now do tail of InitObject
+ $icon->ConfigDefault(\%args);
+ # And configure that new would have done
+ $top->iconwindow($icon);
+ $top->update;
+ $lab->DisableButtonEvents;
+ $lab->update;
+ }
+ $top->iconimage($args{'-image'}) if (exists $args{'-image'});
+ $icon->configure(%args);
+ $icon->idletasks; # Let size request propogate
+ $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight);
+ $icon->update; # Let attributes propogate
+ $top->deiconify if ($state eq 'normal');
+ $top->iconify if ($state eq 'iconic');
+}
+
+sub menu
+{
+ my $w = shift;
+ my $menu;
+ $menu = $w->cget('-menu');
+ unless (defined $menu)
+ {
+ $w->configure(-menu => ($menu = $w->SUPER::menu))
+ }
+ $menu->configure(@_) if @_;
+ return $menu;
+}
+
+
+1;
+__END__
+
+#----------------------------------------------------------------------
+#
+# Focus Group
+#
+# Focus groups are used to handle the user's focusing actions inside a
+# toplevel.
+#
+# One example of using focus groups is: when the user focuses on an
+# entry, the text in the entry is highlighted and the cursor is put to
+# the end of the text. When the user changes focus to another widget,
+# the text in the previously focused entry is validated.
+#
+
+#----------------------------------------------------------------------
+# tkFocusGroup_Create --
+#
+# Create a focus group. All the widgets in a focus group must be
+# within the same focus toplevel. Each toplevel can have only
+# one focus group, which is identified by the name of the
+# toplevel widget.
+#
+sub FG_Create {
+ my $t = shift;
+ unless (exists $t->{'_fg'}) {
+ $t->{'_fg'} = 1;
+ $t->bind('<FocusIn>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_In($w, $Ev->d);
+ }
+ );
+ $t->bind('<FocusOut>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Out($w, $Ev->d);
+ }
+ );
+ $t->bind('<Destroy>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Destroy($w);
+ }
+ );
+ # <Destroy> is not sufficient to break loops if never mapped.
+ $t->OnDestroy([$t,'FG_Destroy']);
+ }
+}
+
+# tkFocusGroup_BindIn --
+#
+# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
+# called when the widget is focused on by the user.
+#
+sub FG_BindIn {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_BindOut --
+#
+# Add a widget into the "FocusOut" list of the focus group. The
+# $cmd will be called when the widget loses the focus (User
+# types Tab or click on another widget).
+#
+sub FG_BindOut {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_Destroy --
+#
+# Cleans up when members of the focus group is deleted, or when the
+# toplevel itself gets deleted.
+#
+sub FG_Destroy {
+ my($t, $w) = @_;
+ if (!defined($w) || $t == $w) {
+ delete $t->{'_fg'};
+ delete $t->{'_focus'};
+ delete $t->{'_FocusOut'};
+ delete $t->{'_FocusIn'};
+ } else {
+ if (exists $t->{'_focus'}) {
+ delete $t->{'_focus'} if ($t->{'_focus'} == $w);
+ }
+ delete $t->{'_FocusIn'}{$w};
+ delete $t->{'_FocusOut'}{$w};
+ }
+}
+
+# tkFocusGroup_In --
+#
+# Handles the <FocusIn> event. Calls the FocusIn command for the newly
+# focused widget in the focus group.
+#
+sub FG_In {
+ my($t, $w, $detail) = @_;
+ if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) {
+ # This is already in focus
+ return;
+ } else {
+ $t->{'_focus'} = $w;
+ $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w};
+ }
+}
+
+# tkFocusGroup_Out --
+#
+# Handles the <FocusOut> event. Checks if this is really a lose
+# focus event, not one generated by the mouse moving out of the
+# toplevel window. Calls the FocusOut command for the widget
+# who loses its focus.
+#
+sub FG_Out {
+ my($t, $w, $detail) = @_;
+ if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') {
+ # This is caused by mouse moving out of the window
+ return;
+ }
+ unless (exists $t->{'_FocusOut'}{$w}) {
+ return;
+ } else {
+ $t->{'_FocusOut'}{$w}->Call;
+ delete $t->{'_focus'};
+ }
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Toplevel.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Toplevel.pod
new file mode 100755
index 00000000000..e3bbf579c0b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Toplevel.pod
@@ -0,0 +1,199 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Toplevel - Create and manipulate Toplevel widgets
+
+=for category Tk Widget Classes
+
+=head1 SYNOPSIS
+
+S< >I<$toplevel> = I<$parent>-E<gt>B<Toplevel>(?I<options>?);
+
+=head1 STANDARD OPTIONS
+
+B<-borderwidth> B<-highlightbackground> B<-highlightthickness> B<-takefocus>
+B<-class> B<-highlightcolor> B<-relief>
+B<-cursor>
+
+See L<Tk::options> for details of the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<background>
+
+=item Class: B<Background>
+
+=item Switch: B<-background>
+
+This option is the same as the standard B<background> option
+except that its value may also be specified as an undefined value.
+In this case, the widget will display no background or border, and
+no colors will be consumed from its colormap for its background
+and border.
+
+=item Name: B<colormap>
+
+=item Class: B<Colormap>
+
+=item Switch: B<-colormap>
+
+Specifies a colormap to use for the window.
+The value may be either B<new>, in which case a new colormap is
+created for the window and its children, or the name of another
+window (which must be on the same screen and have the same visual
+as $widget), in which case the new window will use the colormap
+from the specified window.
+If the B<colormap> option is not specified, the new window
+uses the default colormap of its screen.
+This option may not be changed with the B<configure>
+method.
+
+=item Name: B<container>
+
+=item Class: B<Container>
+
+=item Switch: B<-container>
+
+The value must be a boolean. If true, it means that this window will
+be used as a container in which some other application will be embedded
+(for example, a Tk toplevel can be embedded using the B<-use> option).
+The window will support the appropriate window manager protocols for
+things like geometry requests. The window should not have any
+children of its own in this application.
+This option may not be changed with the B<configure>
+method.
+
+=item Name: B<height>
+
+=item Class: B<Height>
+
+=item Switch: B<-height>
+
+Specifies the desired height for the window in any of the forms
+acceptable to B<Tk_GetPixels>.
+If this option is less than or equal to zero then the window will
+not request any size at all.
+
+=item Name: B<menu>
+
+=item Class: B<Menu>
+
+=item Switch: B<-menu>
+
+Specifies a menu widget to be used as a menubar. On the Macintosh, the
+menubar will be displayed accross the top of the main monitor. On
+Microsoft Windows and all UNIX platforms, the menu will appear accross
+the toplevel window as part of the window dressing maintained by the
+window manager.
+
+=item Name: B<"">
+
+=item Class: B<"">
+
+=item Switch: B<-screen>
+
+Specifies the screen on which to place the new window.
+Any valid screen name may be used, even one associated with a
+different display.
+Defaults to the same screen as its parent.
+This option is special in that it may not be specified via the option
+database, and it may not be modified with the B<configure>
+method.
+
+=item Switch: B<-title>
+
+Specifies the title of the toplevel window.
+
+=item Name: B<use>
+
+=item Class: B<Use>
+
+=item Switch: B<-use>
+
+This option is used for embedding. If the value isn't an empty string,
+it must be the the window identifier of a container window, specified as
+a hexadecimal string like the ones returned by the B<winfo id>
+command. The toplevel widget will be created as a child of the given
+container instead of the root window for the screen. If the container
+window is in a Tk application, it must be a frame or toplevel widget for
+which the B<-container> option was specified.
+This option may not be changed with the B<configure>
+method.
+
+=item Name: B<visual>
+
+=item Class: B<Visual>
+
+=item Switch: B<-visual>
+
+Specifies visual information for the new window in any of the
+forms accepted by B<Tk_GetVisual>.
+If this option is not specified, the new window will use the default
+visual for its screen.
+The B<visual> option may not be modified with the B<configure>
+method.
+
+=item Name: B<width>
+
+=item Class: B<Width>
+
+=item Switch: B<-width>
+
+Specifies the desired width for the window in any of the forms
+acceptable to B<Tk_GetPixels>.
+If this option is less than or equal to zero then the window will
+not request any size at all.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Toplevel> method creates a new toplevel widget (given
+by the $widget argument). Additional
+options, described above, may be specified on the command line
+or in the option database
+to configure aspects of the toplevel such as its background color
+and relief. The B<toplevel> command returns the
+path name of the new window.
+
+A toplevel is similar to a frame except that it is created as a
+top-level window: its X parent is the root window of a screen
+rather than the logical parent from its path name. The primary
+purpose of a toplevel is to serve as a container for dialog boxes
+and other collections of widgets. The only visible features
+of a toplevel are its background color and an optional 3-D border
+to make the toplevel appear raised or sunken.
+
+=head1 WIDGET METHODS
+
+The B<Toplevel> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class, and the L<Tk::Wm|Tk::Wm> class.
+
+=head1 BINDINGS
+
+When a new toplevel is created, it has no default event bindings:
+toplevels are not intended to be interactive.
+
+=head1 SEE ALSO
+
+L<Tk::Widget|Tk::Widget>
+L<Tk::Wm|Tk::Wm>
+
+=head1 KEYWORDS
+
+toplevel, widget
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Trace.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Trace.pm
new file mode 100755
index 00000000000..d4bd5600438
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Trace.pm
@@ -0,0 +1,405 @@
+package Tk::Trace;
+
+use vars qw($VERSION);
+$VERSION = '4.008'; # was: sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use Carp;
+use Tie::Watch;
+use strict;
+
+# The %TRACE hash is indexed by stringified variable reference. Each hash
+# bucket contains an array reference having two elements:
+#
+# ->[0] = a reference to the variable's Tie::Watch object
+# ->[1] = a hash reference with these keys: -fetch, -store, -destroy
+# ->{key} = [ active flag, [ callback list ] ]
+# where each callback is a normalized callback array reference
+#
+# Thus, each trace type (r w u ) may have multiple traces.
+
+my %TRACE; # watchpoints indexed by stringified ref
+
+my %OP = ( # trace to Tie::Watch operation map
+ r => '-fetch',
+ w => '-store',
+ u => '-destroy',
+);
+
+sub fetch {
+
+ # fetch() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ # $_[1] = undef for a scalar, an index/key for an array/hash
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = current value
+ # $_[2] = operation 'r'
+ # $_[3 .. $#_] = optional user callback arguments
+ #
+ # The user callback returns the final value to assign the variable.
+
+ my $self = shift; # Tie::Watch object
+ my $val = $self->Fetch(@_); # get variable's current value
+ my $aref = $self->Args('-fetch'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-fetch}; # active flag/callbacks
+ return $val unless $call->[0]; # if fetch inactive
+
+ my $final_val;
+ foreach my $aref (reverse @$call[ 1 .. $#{$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ unshift @_, undef if scalar @_ == 0; # undef "index" for a scalar
+ my @args = @_; # save for post-callback work
+ $args[1] = &$sub(@_, $val, 'r', @args_copy); # invoke user callback
+ shift @args unless defined $args[0]; # drop scalar "index"
+ $final_val = $self->Store(@args); # update variable's value
+ }
+ $final_val;
+
+} # end fetch
+
+sub store {
+
+ # store() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ # $_[1] = new value for a scalar, index/key for an array/hash
+ # $_[2] = undef for a scalar, new value for an array/hash
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = new value
+ # $_[2] = operation 'w'
+ # $_[3 .. $#_] = optional user callback arguments
+ #
+ # The user callback returns the final value to assign the variable.
+
+ my $self = shift; # Tie::Watch object
+ my $val = $self->Store(@_); # store variable's new value
+ my $aref = $self->Args('-store'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-store}; # active flag/callbacks
+ return $val unless $call->[0]; # if store inactive
+
+ foreach my $aref ( reverse @$call[ 1 .. $#{$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ unshift @_, undef if scalar @_ == 1; # undef "index" for a scalar
+ my @args = @_; # save for post-callback work
+ $args[1] = &$sub(@_, 'w', @args_copy); # invoke user callback
+ shift @args unless defined $args[0]; # drop scalar "index"
+ $self->Store(@args); # update variable's value
+ }
+
+} # end store
+
+sub destroy {
+
+ # destroy() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = final value
+ # $_[2] = operation 'u'
+ # $_[3 .. $#_] = optional user callback arguments
+
+ my $self = shift; # Tie::Watch object
+ my $val = $self->Fetch(@_); # variable's final value
+ my $aref = $self->Args('-destroy'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-destroy}; # active flag/callbacks
+ return $val unless $call->[0]; # if destroy inactive
+
+ foreach my $aref ( reverse @$call[ 1 .. $#{$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ my $val = $self->Fetch(@_); # get final value
+ &$sub(undef, $val, 'u', @args_copy); # invoke user callback
+ $self->Destroy(@_); # destroy variable
+ }
+
+} # end destroy
+
+sub Tk::Widget::traceVariable {
+
+ my( $parent, $vref, $op, $callback ) = @_;
+
+ {
+ $^W = 0;
+ croak "Illegal parent '$parent', not a widget" unless ref $parent;
+ croak "Illegal variable '$vref', not a reference" unless ref $vref;
+ croak "Illegal trace operation '$op'" unless $op;
+ croak "Illegal trace operation '$op'" if $op =~ /[^rwu]/;
+ croak "Illegal callback ($callback)" unless $callback;
+ }
+
+ # Need to add our internal callback to user's callback arg list
+ # so we can call ours first, followed by the user's callback and
+ # any user arguments. Trace callbacks are activated as requied.
+
+ my $trace = $TRACE{$vref};
+ if ( not defined $trace ) {
+ my $watch = Tie::Watch->new(
+ -variable => $vref,
+ -fetch => [ \&fetch, $vref ],
+ -store => [ \&store, $vref ],
+ -destroy => [ \&destroy, $vref ],
+ );
+ $trace = $TRACE{$vref} =
+ [$watch,
+ {
+ -fetch => [ 0 ],
+ -store => [ 0 ],
+ -destroy => [ 0 ],
+ }
+ ];
+ }
+
+ $callback = [ $callback ] if ref $callback eq 'CODE';
+
+ foreach my $o (split '', $op) {
+ push @{$trace->[1]->{$OP{$o}}}, $callback;
+ $trace->[1]->{$OP{$o}}->[0] = 1; # activate
+ }
+
+ return $trace; # for peeking
+
+} # end traceVariable
+
+sub Tk::Widget::traceVdelete {
+
+ my ( $parent, $vref, $op_not_honored, $callabck_not_honored ) = @_;
+
+ if ( defined $TRACE{$vref}->[0] ) {
+ $$vref = $TRACE{$vref}->[0]->Fetch;
+ $TRACE{$vref}->[0]->Unwatch;
+ delete $TRACE{$vref};
+ }
+
+} # end traceVdelete
+
+sub Tk::Widget::traceVinfo {
+
+ my ( $parent, $vref ) = @_;
+
+ return ( defined $TRACE{$vref}->[0] ) ? $TRACE{$vref}->[0]->Info : undef;
+
+} # end traceVinfo
+
+=head1 NAME
+
+Tk::Trace - emulate Tcl/Tk B<trace> functions.
+
+=head1 SYNOPSIS
+
+ use Tk::Trace
+
+ $mw->traceVariable(\$v, 'wru' => [\&update_meter, $scale]);
+ %vinfo = $mw->traceVinfo(\$v);
+ print "Trace info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
+ $mw->traceVdelete(\$v);
+
+=head1 DESCRIPTION
+
+This class module emulates the Tcl/Tk B<trace> family of commands by
+binding subroutines of your devising to Perl variables using simple
+B<Tie::Watch> features.
+
+Callback format is patterned after the Perl/Tk scheme: supply either a
+code reference, or, supply an array reference and pass the callback
+code reference in the first element of the array, followed by callback
+arguments.
+
+User callbacks are passed these arguments:
+
+ $_[0] = undef for a scalar, index/key for array/hash
+ $_[1] = variable's current (read), new (write), final (undef) value
+ $_[2] = operation (r, w, or u)
+ $_[3 .. $#_] = optional user callback arguments
+
+As a Trace user, you have an important responsibility when writing your
+callback, since you control the final value assigned to the variable.
+A typical callback might look like:
+
+ sub callback {
+ my($index, $value, $op, @args) = @_;
+ return if $op eq 'u';
+ # .... code which uses $value ...
+ return $value; # variable's final value
+ }
+
+Note that the callback's return value becomes the variable's final value,
+for either read or write traces.
+
+For write operations, the variable is updated with its new value before
+the callback is invoked.
+
+Multiple read, write and undef callbacks can be attached to a variable,
+which are invoked in reverse order of creation.
+
+=head1 METHODS
+
+=over 4
+
+=item $mw->traceVariable(varRef, op => callback);
+
+B<varRef> is a reference to the scalar, array or hash variable you
+wish to trace. B<op> is the trace operation, and can be any combination
+of B<r> for read, B<w> for write, and B<u> for undef. B<callback> is a
+standard Perl/Tk callback, and is invoked, depending upon the value of
+B<op>, whenever the variable is read, written, or destroyed.
+
+=item %vinfo = $mw->traceVinfo(varRef);
+
+Returns a hash detailing the internals of the Trace object, with these
+keys:
+
+ %vinfo = (
+ -variable => varRef
+ -debug => '0'
+ -shadow => '1'
+ -value => 'HELLO SCALAR'
+ -destroy => callback
+ -fetch => callback
+ -store => callback
+ -legible => above data formatted as a list of string, for printing
+ );
+
+For array and hash Trace objects, the B<-value> key is replaced with a
+B<-ptr> key which is a reference to the parallel array or hash.
+Additionally, for an array or hash, there are key/value pairs for
+all the variable specific callbacks.
+
+=item $mw->traceVdelete(\$v);
+
+Stop tracing the variable.
+
+=back
+
+=head1 EXAMPLES
+
+ # Trace a Scale's variable and move a meter in unison.
+
+ use Tk;
+ use Tk::widgets qw/Trace/;
+
+ $pi = 3.1415926;
+ $mw = MainWindow->new;
+ $c = $mw->Canvas( qw/-width 200 -height 110 -bd 2 -relief sunken/ )->grid;
+ $c->createLine( qw/100 100 10 100 -tag meter -arrow last -width 5/ );
+ $s = $mw->Scale( qw/-orient h -from 0 -to 100 -variable/ => \$v )->grid;
+ $mw->Label( -text => 'Slide Me for 5 Seconds' )->grid;
+
+ $mw->traceVariable( \$v, 'w' => [ \&update_meter, $s ] );
+
+ $mw->after( 5000 => sub {
+ print "Untrace time ...\n";
+ %vinfo = $s->traceVinfo( \$v );
+ print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
+ $c->traceVdelete( \$v );
+ });
+
+ MainLoop;
+
+ sub update_meter {
+ my( $index, $value, $op, @args ) = @_;
+ return if $op eq 'u';
+ $min = $s->cget( -from );
+ $max = $s->cget( -to );
+ $pos = $value / abs( $max - $min );
+ $x = 100.0 - 90.0 * ( cos( $pos * $pi ) );
+ $y = 100.0 - 90.0 * ( sin( $pos * $pi ) );
+ $c->coords( qw/meter 100 100/, $x, $y );
+ return $value;
+ }
+
+ # Predictive text entry.
+
+ use Tk;
+ use Tk::widgets qw/ LabEntry Trace /;
+ use strict;
+
+ my @words = qw/radio television telephone turntable microphone/;
+
+ my $mw = MainWindow->new;
+
+ my $e = $mw->LabEntry(
+ qw/ -label Thing -width 40 /,
+ -labelPack => [ qw/ -side left / ],
+ -textvariable => \my $thing,
+ );
+ my $t = $mw->Text( qw/ -height 10 -width 50 / );;
+
+ $t->pack( $e, qw/ -side top / );
+
+ $e->focus;
+ $e->traceVariable( \$thing, 'w', [ \&trace_thing, $e, $t ] );
+
+ foreach my $k ( 1 .. 12 ) {
+ $e->bind( "<F${k}>" => [ \&ins, $t, Ev('K') ] );
+ }
+ $e->bind( '<Return>' =>
+ sub {
+ print "$thing\n";
+ $_[0]->delete( 0, 'end' );
+ }
+ );
+
+ MainLoop;
+
+ sub trace_thing {
+
+ my( $index, $value, $op, $e, $t ) = @_;
+
+ return unless $value;
+
+ $t->delete( qw/ 1.0 end / );
+ foreach my $w ( @words ) {
+ if ( $w =~ /^$value/ ) {
+ $t->insert( 'end', "$w\n" );
+ }
+ }
+
+ return $value;
+
+ } # end trace_thing
+
+ sub ins {
+
+ my( $e, $t, $K ) = @_;
+
+ my( $index ) = $K =~ /^F(\d+)$/;
+
+ $e->delete( 0, 'end' );
+ $e->insert( 'end', $t->get( "$index.0", "$index.0 lineend" ) );
+ $t->delete( qw/ 1.0 end / );
+
+ } # end ins
+
+=head1 HISTORY
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 2000/08/01
+ . Version 1.0, for Tk800.022.
+
+ sol0@Lehigh.EDU, Lehigh University Computing Center, 2003/09/22
+ . Version 1.1, for Tk804.025, add support for multiple traces of the same
+ type on the same variable.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000 - 2003 Stephen O. Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Tree.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Tree.pm
new file mode 100755
index 00000000000..8f4fe2640d8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Tree.pm
@@ -0,0 +1,313 @@
+package Tk::Tree;
+# Tree -- TixTree widget
+#
+# Derived from Tree.tcl in Tix 4.1
+#
+# Chris Dean <ctdean@cogit.com>
+# Changes: Renee Baecker <module@renee-baecker.de>
+
+use vars qw($VERSION);
+$VERSION = '4.72'; # $Id: Tree.pm,v 1.4 2007/11/04 09:11:31 eserte Exp $
+
+use Tk ();
+use Tk::Derived;
+use Tk::HList;
+use base qw(Tk::Derived Tk::HList);
+use strict;
+
+Construct Tk::Widget 'Tree';
+
+sub Tk::Widget::ScrlTree { shift->Scrolled('Tree' => @_) }
+
+sub Populate
+{
+ my( $w, $args ) = @_;
+
+ $w->SUPER::Populate( $args );
+
+ $w->ConfigSpecs(
+ -ignoreinvoke => ['PASSIVE', 'ignoreInvoke', 'IgnoreInvoke', 0],
+ -opencmd => ['CALLBACK', 'openCmd', 'OpenCmd', 'OpenCmd' ],
+ -indicatorcmd => ['CALLBACK', 'indicatorCmd', 'IndicatorCmd', 'IndicatorCmd'],
+ -closecmd => ['CALLBACK', 'closeCmd', 'CloseCmd', 'CloseCmd'],
+ -indicator => ['SELF', 'indicator', 'Indicator', 1],
+ -indent => ['SELF', 'indent', 'Indent', 20],
+ -width => ['SELF', 'width', 'Width', 20],
+ -itemtype => ['SELF', 'itemtype', 'Itemtype', 'imagetext'],
+ -foreground => ['SELF'],
+ );
+}
+
+sub autosetmode
+{
+ my( $w ) = @_;
+ $w->setmode();
+}
+
+sub add_pathimage
+{
+ my ($w,$path,$imgopen,$imgclose) = @_;
+ $imgopen ||= "minusarm";
+ $imgclose ||= "plusarm";
+
+ my $separator = $w->cget(-separator);
+
+ $path =~ s/([\.?()|])/\\$1/g;
+ $path =~ s/\$/\\\$/g;
+ $path =~ s/\\\$$/\$/;
+ $path =~ s/\*/[^$separator]+/g;
+
+ push(@{$w->{Images}},[$path,$imgopen,$imgclose]);
+}
+
+sub child_entries
+{
+ my ($w,$path,$depth) = @_;
+
+ my $level = 1;
+ $depth ||= 1;
+ $path ||= '';
+
+ my @children = $w->_get_childinfos($depth,$level,$path);
+
+ return wantarray ? @children : scalar(@children);
+}
+
+sub _get_childinfos
+{
+ my ($w,$maxdepth,$level,$path) = @_;
+ my @children = $w->infoChildren($path);
+ my @tmp;
+
+ if($level < $maxdepth)
+ {
+ for my $child(@children)
+ {
+ push(@tmp,$w->_get_childinfos($maxdepth,$level +1,$child));
+ }
+ }
+
+ push(@children,@tmp);
+
+ return @children;
+}
+
+sub IndicatorCmd
+{
+ my( $w, $ent, $event ) = @_;
+
+ my $mode = $w->getmode( $ent );
+
+ if ( $event eq '<Arm>' )
+ {
+ if ($mode eq 'open' )
+ {
+ #$w->_indicator_image( $ent, 'plusarm' );
+ $w->_open($ent);
+ }
+ else
+ {
+ #$w->_indicator_image( $ent, 'minusarm' );
+ $w->_close($ent);
+ }
+ }
+ elsif ( $event eq '<Disarm>' )
+ {
+ if ($mode eq 'open' )
+ {
+ #$w->_indicator_image( $ent, 'plus' );
+ $w->_open($ent);
+ }
+ else
+ {
+ #$w->_indicator_image( $ent, 'minus' );
+ $w->_close($ent);
+ }
+ }
+ elsif( $event eq '<Activate>' )
+ {
+ $w->Activate( $ent, $mode );
+ $w->Callback( -browsecmd => $ent );
+ }
+}
+
+sub close
+{
+ my( $w, $ent ) = @_;
+ my $mode = $w->getmode( $ent );
+ $w->Activate( $ent, $mode ) if( $mode eq 'close' );
+}
+
+sub open
+{
+ my( $w, $ent ) = @_;
+ my $mode = $w->getmode( $ent );
+ $w->Activate( $ent, $mode ) if( $mode eq 'open' );
+}
+
+sub getmode
+{
+ my( $w, $ent ) = @_;
+
+ return( 'none' ) unless $w->indicatorExists( $ent );
+
+ my $img = $w->_indicator_image( $ent );
+ if ($img eq "plus" || $img eq "plusarm" || grep{$img eq $_->[2]}@{$w->{Images}})
+ {
+ return( 'open' );
+ }
+ return( 'close' );
+}
+
+sub setmode
+{
+ my ($w,$ent,$mode) = @_;
+ unless (defined $mode)
+ {
+ $mode = 'none';
+ my @args;
+ push(@args,$ent) if defined $ent;
+ my @children = $w->infoChildren( @args );
+ if ( @children )
+ {
+ $mode = 'close';
+ foreach my $c (@children)
+ {
+ $mode = 'open' if $w->infoHidden( $c );
+ $w->setmode( $c );
+ }
+ }
+ }
+
+ if (defined $ent)
+ {
+ if ( $mode eq 'open' )
+ {
+ #$w->_indicator_image( $ent, 'plus' );
+ $w->_open($ent);
+ }
+ elsif ( $mode eq 'close' )
+ {
+ #$w->_indicator_image( $ent, 'minus' );
+ $w->_close($ent);
+ }
+ elsif( $mode eq 'none' )
+ {
+ $w->_indicator_image( $ent, undef );
+ }
+ }
+}
+
+sub _open
+{
+ my ($w,$ent) = @_;
+ $w->_indicator_image( $ent, "plus" );
+ for my $entry (@{$w->{Images}})
+ {
+ if($ent =~ $entry->[0])
+ {
+ $w->_indicator_image( $ent, $entry->[2] );
+ }
+ }
+}
+
+sub _close
+{
+ my ($w,$ent) = @_;
+ $w->_indicator_image( $ent, "minus" );
+ for my $entry (@{$w->{Images}})
+ {
+ if($ent =~ $entry->[0])
+ {
+ $w->_indicator_image( $ent, $entry->[1] );
+ }
+ }
+}
+
+sub Activate
+{
+ my( $w, $ent, $mode ) = @_;
+ if ( $mode eq 'open' )
+ {
+ $w->Callback( -opencmd => $ent );
+ #$w->_indicator_image( $ent, 'minus' );
+ $w->_close($ent);
+ }
+ elsif ( $mode eq 'close' )
+ {
+ $w->Callback( -closecmd => $ent );
+ #$w->_indicator_image( $ent, 'plus' );
+ $w->_open($ent);
+ }
+ else
+ {
+
+ }
+}
+
+sub OpenCmd
+{
+ my( $w, $ent ) = @_;
+ # The default action
+ foreach my $kid ($w->infoChildren( $ent ))
+ {
+ $w->show( -entry => $kid );
+ }
+}
+
+sub CloseCmd
+{
+ my( $w, $ent ) = @_;
+
+ # The default action
+ foreach my $kid ($w->infoChildren( $ent ))
+ {
+ $w->hide( -entry => $kid );
+ }
+}
+
+sub Command
+{
+ my( $w, $ent ) = @_;
+
+ return if $w->{Configure}{-ignoreInvoke};
+
+ $w->Activate( $ent, $w->getmode( $ent ) ) if $w->indicatorExists( $ent );
+}
+
+sub _indicator_image
+{
+ my( $w, $ent, $image ) = @_;
+ my $data = $w->privateData();
+ if (@_ > 2)
+ {
+ if (defined $image)
+ {
+ $w->indicatorCreate( $ent, -itemtype => 'image' )
+ unless $w->indicatorExists($ent);
+ $data->{$ent} = $image;
+ $w->indicatorConfigure( $ent, -image => $w->Getimage( $image ) );
+ }
+ else
+ {
+ $w->indicatorDelete( $ent ) if $w->indicatorExists( $ent );
+ delete $data->{$ent};
+ }
+ }
+ return $data->{$ent};
+}
+
+1;
+
+__END__
+
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distrobution are in the file
+# license.tcl.
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Tree.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Tree.pod
new file mode 100755
index 00000000000..8a69462338e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Tree.pod
@@ -0,0 +1,274 @@
+
+=head1 NAME
+
+Tk::Tree - Create and manipulate Tree widgets
+
+=for pm Tixish/Tree.pm
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+S< >B<use Tk::Tree;>
+
+S< >I<$tree> = I<$parent>-E<gt>B<Tree>(?I<options>?);
+
+=head1 SUPER-CLASS
+
+The B<Tree> class is derived from the L<HList|Tk::HList> class and inherits all
+the methods, options and subwidgets of its super-class. A B<Tree> widget is
+not scrolled by default.
+
+=head1 STANDARD OPTIONS
+
+B<Tree> supports all the standard options of an HList widget.
+See L<Tk::options> for details on the standard options.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item Name: B<browseCmd>
+
+=item Class: B<BrowseCmd>
+
+=item Switch: B<-browsecmd>
+
+Specifies a L<callback|Tk::callbacks> to call whenever the user browses on an entry
+(usually by single-clicking on the entry). The callback is called with
+one argument, the pathname of the entry.
+
+=item Name: B<closeCmd>
+
+=item Class: B<CloseCmd>
+
+=item Switch: B<-closecmd>
+
+Specifies a L<callback|Tk::callbacks> to call whenever an entry needs to be closed (See
+L<"BINDINGS"> below). This method is called with one argument,
+the pathname of the entry. This method should perform appropriate
+actions to close the specified entry. If the B<-closecmd> option
+is not specified, the default closing action is to hide all child
+entries of the specified entry.
+
+=item Name: B<command>
+
+=item Class: B<Command>
+
+=item Switch: B<-command>
+
+Specifies a L<callback|Tk::callbacks> to call whenever the user activates an entry
+(usually by double-clicking on the entry). The callback
+is called with one argument, the pathname of the entry.
+
+=item Name: B<ignoreInvoke>
+
+=item Class: B<IgnoreInvoke>
+
+=item Switch: B<-ignoreinvoke>
+
+A Boolean value that specifies when a branch should be opened or
+closed. A branch will always be opened or closed when the user presses
+the (+) and (-) indicators. However, when the user invokes a branch
+(by doublc-clicking or pressing E<lt>ReturnE<gt>), the branch will be opened
+or closed only if B<-ignoreinvoke> is set to false (the default
+setting).
+
+=item Name: B<openCmd>
+
+=item Class: B<OpenCmd>
+
+=item Switch: B<-opencmd>
+
+Specifies a L<callback|Tk::callbacks> to call whenever an entry needs to be opened (See
+L<"BINDINGS"> below). This method is called with one argument,
+the pathname of the entry. This method should perform appropriate
+actions to open the specified entry. If the B<-opencmd> option
+is not specified, the default opening action is to show all the child
+entries of the specified entry.
+
+=back
+
+=head1 DESCRIPTION
+
+The B<Tree> method creates a new window and makes it into a Tree widget
+and return a reference to it. Additional options, described above, may
+be specified on the command line or in the option database to configure
+aspects of the Tree widget such as its cursor and relief.
+
+The Tree widget can be used to display hierarchical data in a tree
+form. The user can adjust the view of the tree by opening or closing
+parts of the tree.
+
+To display a static tree structure, you can add the entries into the
+Tree widget and hide any entries as desired. Then you can call
+the B<autosetmode> method. This will set up the Tree widget so that it
+handles all the I<open> and I<close> events automatically.
+the demonstration program F<Tixish/examples/perl-tix-tree>).
+
+The above method is not applicable if you want to maintain a dynamic tree
+structure, i.e, you do not know all the entries in the tree and you need
+to add or delete entries subsequently. To do this, you should first create
+the entries in the Tree widget. Then, use the B<setmode> method to
+indicate the entries that can be opened or closed, and use the B<-opencmd>
+and B<-closecmd> options to handle the opening and closing events. (Please
+see the demonstration program F<Tixish/examples/perl-tix-dyntree>).
+
+Use either
+
+S< >I<$parent>-E<gt>B<Scrolled>(B<'Tree'>, ... );
+
+or
+
+S< >I<$parent>-E<gt>B<ScrlTree>( ... );
+
+to create a scrolled B<Tree>. See L<Tk::Scrolled> for details.
+
+=head1 WIDGET METHODS
+
+The B<Tree> method creates a widget object.
+This object supports the B<configure> and B<cget> methods
+described in L<Tk::options> which can be used to enquire and
+modify the options described above.
+The widget also inherits all the methods provided by the generic
+L<Tk::Widget|Tk::Widget> class.
+
+The following additional methods are available for Tree widgets:
+
+=over 4
+
+=item I<$tree-E<gt>>B<add_pathimage>(I<treeRegExp [, openImg, closeImg]>)
+
+This method defines images for a given path (images must be in xpm
+format). The path can be determined by a simplified regular
+expression. There are just three metasymbols:
+
+=over
+
+=item ^
+
+at the beginning of the C<treeRegExp> same as in Perl regular
+expressions
+
+=item *
+
+anything
+
+=item $
+
+at the end of the C<TreeRegExp>, the same as in Perl regular
+expressions
+
+=back
+
+Examples:
+
+ $tree->add_pathimage('^root','openfolder','folder');
+
+matches C<root>, C<root.foo>, C<root.bar>, but not C<foo.root>
+
+ $tree->add_pathimage('root.*.class','openfolder','folder');
+
+matches all paths containing C<< root.<anything>.class >>, but not
+C<< root.<anything>.<anything>.class >> C<*> is one part of the path. If
+you want to use a wildcard for two steps, you have to use C<*.*>.
+
+ $tree->add_pathimage('class$','openfolder','folder');
+
+This matches all path with C<class> at the end.
+
+=item I<$tree>-E<gt>B<autosetmode>
+
+This method calls the B<setmode> method for all the entries in
+this Tree widget: if an entry has no child entries, its mode is set to
+B<none>. Otherwise, if the entry has any hidden child entries, its
+mode is set to B<open>; otherwise its mode is set to B<close>.
+
+=item I<$tree-E<gt>>B<child_entries>([$path][,$depth])
+
+This method returns in list context an array that contains all
+pathnames of subentries within the given path. In scalar context it
+returns the number of subentries in the given path.
+
+ Example:
+ root
+ | foo
+ | bar
+ | | bar1
+ | | bar2
+
+ my @childentries = $tree->child_entries('root.bar');
+ # returns (root.bar.bar1, root.bar.bar2)
+
+ my $nr_of_subentries = $tree->child_entries('root',2);
+ # returns 4
+
+If C<$path> is omitted, all it is assumed, that the entry above
+'root' is meant. C<$depth> defines the numbers of levels.
+
+=item I<$tree>-E<gt>B<close>(I<entryPath>)
+
+Close the entry given by I<entryPath> if its I<mode> is B<close>.
+
+=item I<$tree>-E<gt>B<getmode>(I<entryPath>)
+
+Returns the current I<mode> of the entry given by I<entryPath>.
+
+=item I<$tree>-E<gt>B<open>(I<entryPath>)
+
+Open the entry given by I<entryPath> if its I<mode> is B<open>.
+
+=item I<$tree>-E<gt>B<setmode>(I<entryPath, mode>)
+
+This method is used to indicate whether the entry given by
+I<entryPath> has children entries and whether the children are
+visible. I<mode> must be one of B<open>,
+B<close> or B<none>. If I<mode> is set to B<open>, a (+)
+indicator is drawn next the the entry. If I<mode> is set to
+B<close>, a (-) indicator is drawn next the the entry. If
+I<mode> is set to B<none>, no indicators will be drawn for this
+entry. The default I<mode> is none. The B<open> mode indicates
+the entry has hidden children and this entry can be opened by the
+user. The B<close> mode indicates that all the children of the entry
+are now visible and the entry can be closed by the user.
+
+=back
+
+=head1 BINDINGS
+
+The basic mouse and keyboard bindings of the Tree widget are the same
+as the L<bindings of the HList|Tk::HList/"BINDINGS"> widget.
+In addition, the entries can be opened or closed under the following
+conditions:
+
+=over 4
+
+=item [1]
+
+If the I<mode> of the entry is B<open>, it can be opened by clicking
+on its (+) indicator.
+
+=item [2]
+
+If the I<mode> of the entry is B<close>, it can be closed by clicking
+on its (-) indicator.
+
+=back
+
+=head1 SEE ALSO
+
+L<Tk::HList|Tk::HList>
+
+=head1 AUTHOR
+
+Perl/TK version by Chris Dean <ctdean@cogit.com>. Original Tcl/Tix
+version by Ioi Kim Lam.
+
+Additions by Renee Baecker <module@renee-baecker.de>
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Achim Bohnet <ach@mpe.mpg.de> for all his help.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/UserGuide.pod b/Master/tlpkg/tlperl.straw/lib/Tk/UserGuide.pod
new file mode 100755
index 00000000000..4d1d4ffaa5c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/UserGuide.pod
@@ -0,0 +1,493 @@
+=head1 NAME
+
+Perl/Tk - Writing Tk applications in Perl 5
+
+=for category Introduction
+
+=head1 DESCRIPTION
+
+This document is for beginners. It assumes you know some B<Perl>, and
+have it and Tk running. If you are I<not> currently reading this
+document courtesy of the B<widget> demonstration program, please be
+sure to run B<widget>, as it will show you the various widget types
+supported by Tk and how to use them. B<widget> should be installed in
+your default path, so type I<widget> at a command prompt.
+
+Here are links to other novice tutorials:
+
+L<http://www.lehigh.edu/~sol0/ptk/tpj1.html>
+L<http://www.lehigh.edu/~sol0/ptk/perlmonth01/pm1.html>
+
+I<Mastering Perl/Tk> is the definitive book on Perl/Tk:
+
+L<http://www.oreilly.com/catalog/mastperltk>
+
+=head1 Some Background
+
+Tk GUI programming is event-driven. (This may already be familiar to
+you.) In event-driven programs, the main GUI loop is outside of the
+user program and inside the GUI library. This loop - initiated by
+calling B<MainLoop> - watches all events of interest and activates
+the correct handler procedures to handle these events. Some of these
+handler procedures may be user-supplied; others will be part of the
+library.
+
+For a programmer, this means that you're not watching what is happening;
+instead, you are requested by the toolkit to perform actions whenever
+necessary.
+So, you're not watching for 'raise window / close window / redraw window'
+requests, but you tell the toolkit which routine will handle such cases,
+and the toolkit will call the procedures when required. These procedures
+are known as I<callbacks>, and some of them you write yourself.
+
+=head1 First Requirements
+
+B<Perl> programs that use Tk need to include C<use Tk>.
+A program should also use C<use strict> and the B<-w> switch to ensure
+the program is working without common errors.
+
+Any Perl/Tk application starts by creating the Tk B<L<MainWindow|Tk::MainWindow>>. You
+then create items inside the B<MainWindow>, and/or create new windows
+called B<L<Toplevel|Tk::Toplevel>>s that also contain child items, before starting the
+B<MainLoop>, which is the last logical statment in your program. You
+can also create more items and windows while you're running, using
+callbacks. Items are only shown on the display after they have been
+arranged by a I<geometry manager> like B<L<pack|Tk::pack>>; more information on
+this later. B<MainLoop> starts the GUI and handle all events. That's
+all there is to it! A trivial one-window example is shown below:
+
+ #!/usr/bin/perl -w
+ use Tk;
+ use strict;
+
+ my $mw = MainWindow->new;
+ $mw->Label(-text => 'Hello, world!')->pack;
+ $mw->Button(
+ -text => 'Quit',
+ -command => sub { exit },
+ )->pack;
+ MainLoop;
+
+Please run this example. It shows you two widget types, a B<L<Label|Tk::Label>>
+and a B<L<Button|Tk::Button>>, and how they are packed. When clicked, the B<Button>
+widget invokes the callback specified by the C<-command> option. Finally,
+note the typical Tk style using C<-option> =E<gt> C<value> pairs.
+
+=head1 Widget creation
+
+Tk windows and widgets are hierarchical, S<i.e. one> window includes
+one or more other windows. You create the first Tk window using
+C<MainWindow-E<gt>new>. This returns a window handle, assigned to
+C<$mw> in the example above. Keep track of the main handle, commonly
+called a I<widget reference>.
+
+You can use any Tk handle to create child widgets within the window (or
+widget). This is done by calling the Tk constructor method on the
+variable. In the example above, the C<Label> method called from
+C<$mw> creates a B<Label> widget inside the B<MainWindow>. In the
+constructor call, you can specify various options; you can later add
+or change options for any widget using the B<configure> method, which
+takes the same parameters as the constructor. The one exception to
+the hierarchical structure is the B<Toplevel> constructor, which
+creates a new outermost window.
+
+After you create any widget (other than the B<MainWindow> or
+B<Toplevel>s, you must render it by calling B<pack>. (This is not
+entirely true; more later)). If you do not need to refer to the widget
+after construction and packing, call B<pack> off the constructor
+results, as shown for the B<Label> and B<Button> in the example above. Note
+that the result of the compound call is the result of B<pack>, which
+is a valid Tk handle.
+
+Windows and widgets are deleted by calling B<destroy> on them;
+this will delete and un-draw the widget and all its children.
+
+=head1 Standard Tk widgets
+
+Here is an itemize of the standard Tk widget set.
+
+=over 4
+
+=item L<Button|Tk::Button>
+
+=item L<Canvas|Tk::Canvas>
+
+=item L<Checkbutton|Tk::Checkbutton>
+
+=item L<Entry|Tk::Entry>
+
+=item L<Frame|Tk::Frame>
+
+=item L<Label|Tk::Label>
+
+=item L<Labelframe|Tk::Labelframe>
+
+=item L<Listbox|Tk::Listbox>
+
+=item L<Menu|Tk::Menu>
+
+=item L<Menubutton|Tk::Menubutton>
+
+=item L<Message|Tk::Message>
+
+=item L<Panedwindow|Tk::Panedwindow>
+
+=item L<Radiobutton|Tk::Radiobutton>
+
+=item L<Scale|Tk::Scale>
+
+=item L<Scrollbar|Tk::Scrollbar>
+
+=item L<Spinbox|Tk::Spinbox>
+
+=item L<Text|Tk::Text>
+
+=item L<Toplevel|Tk::Toplevel>
+
+=back
+
+Perl/Tk provides an equal number of new widgets, above and beyond this
+core set.
+
+=over 4
+
+=item L<Adjuster|Tk::Adjuster>
+
+=item L<Balloon|Tk::Balloon>
+
+=item L<BrowseEntry|Tk::BrowseEntry>
+
+=item L<ColorEditor|Tk::ColorEditor>
+
+=item L<Dialog|Tk::Dialog>
+
+=item L<DialogBox|Tk::DialogBox>
+
+=item L<DirTree|Tk::DirTree>
+
+=item ErrorDialog
+
+=item L<FBox|Tk::FBox>
+
+=item L<FileSelect|Tk::FileSelect>
+
+=item L<HList|Tk::HList>
+
+=item LabEntry
+
+=item L<LabFrame|Tk::LabFrame>
+
+=item L<NoteBook|Tk::NoteBook>
+
+=item L<Optionmenu|Tk::Optionmenu>
+
+=item L<Pane|Tk::Pane>
+
+=item L<ProgressBar|Tk::ProgressBar>
+
+=item L<ROText|Tk::ROText>
+
+=item L<Table|Tk::Table>
+
+=item L<TextUndo|Tk::TextUndo>
+
+=item L<Tiler|Tk::Tiler>
+
+=item L<TList|Tk::TList>
+
+=item L<Tree|Tk::Tree>
+
+=back
+
+=head1 Variables and callback routines
+
+Most graphical interfaces are used to set up a set of values and conditions,
+and then perform the appropriate action. The Tk toolkit is different
+from your average text-based prompting or menu driven system in that you do
+not collect settings yourself, and decide on an action based on an
+input code; instead, you leave these
+values to your toolkit and only get them when the action is performed.
+
+So, where a traditional text-based system would look like this:
+
+ #!/usr/bin/perl -w
+ use strict;
+
+ print "Please type a font name\n";
+ my $font = <>; chomp $font;
+ # Validate font
+
+ print "Please type a file name\n";
+ my $filename = <>; chomp $filename;
+ # Validate filename
+
+ print "Type <1> to fax, <2> to print\n";
+ my $option = <>; chomp $option;
+ if ($option eq 1) {
+ print "Faxing $filename in font $font\n";
+ } elsif ($option eq 2) {
+ print "Now sending $filename to printer in font $font\n";
+ }
+
+The slightly larger example below shows how to do this in Tk.
+Note the use of callbacks. Note, also, that Tk handles the values, and
+the subroutine uses the method B<get> to get at the values.
+If a user changes his mind and wants to change the font again,
+the application never notices; it's all handled by Tk.
+
+ #!/usr/bin/perl -w
+ use Tk;
+ use strict;
+
+ my $mw = MainWindow->new;
+
+ $mw->Label(-text => 'File Name')->pack;
+ my $filename = $mw->Entry(-width => 20);
+ $filename->pack;
+
+ $mw->Label(-text => 'Font Name')->pack;
+ my $font = $mw->Entry(-width => 10);
+ $font->pack;
+
+ $mw->Button(
+ -text => 'Fax',
+ -command => sub{do_fax($filename, $font)}
+ )->pack;
+
+ $mw->Button(
+ -text => 'Print',
+ -command => sub{do_print($filename, $font)}
+ )->pack;
+
+ MainLoop;
+
+ sub do_fax {
+ my ($file, $font) = @_;
+ my $file_val = $file->get;
+ my $font_val = $font->get;
+ print "Now faxing $file_val in font $font_val\n";
+ }
+
+ sub do_print {
+ my ($file, $font) = @_;
+ my $file_val = $file->get;
+ my $font_val = $font->get;
+ print "Sending file $file_val to printer in font $font_val\n";
+ }
+
+=head1 The packer - grouping with Frame widgets
+
+In the examples above, you must have noticed the B<pack> calls. This
+is one of the more complicated parts of Tk. The basic idea is that
+any window or widget should be subject to a Tk geometry manager; the
+I<packer> is one of the placement managers, and B<L<grid|Tk::grid>> is another.
+
+The actions of the packer are rather simple: when applied
+to a widget, the packer positions that widget on the indicated position
+within the remaining space in its parent. By default, the position is
+on top; this means the next items will be put below. You can also
+specify the left, right, or bottom positions. Specify position
+using B<-side =E<gt> 'right'>.
+
+Additional packing parameters specify the behavior of the widget when
+there is some space left in the B<L<Frame|Tk::Frame>> or when the window size is
+increased. If widgets should maintain a fixed size, specify nothing;
+this is the default. For widgets that you want to fill up the current
+horizontal and/or vertical space, specify B<-fill =E<gt> 'x'>, B<'y'>,
+or B<'both'>; for widgets that should grow, specify B<-expand =E<gt> 1>.
+These parameters are not shown in the example below; see the B<widget>
+demonstration.
+
+If you want to group some items within a window that have a different
+packing order than others, you can include them in a Frame. This is a
+do-nothing window type that is meant for packing or filling (and to
+play games with borders and colors).
+
+The example below shows the use of pack and Frames:
+
+ #!/usr/bin/perl -w
+ use Tk;
+ use strict;
+
+ # Take top and the bottom - now implicit top is in the middle
+ my $mw = MainWindow->new;
+ $mw->title( 'The MainWindow' );
+ $mw->Label(-text => 'At the top (default)')->pack;
+ $mw->Label(-text => 'At the bottom')->pack(-side => 'bottom');
+ $mw->Label(-text => 'The middle remains')->pack;
+
+ # Since left and right are taken, bottom will not work...
+ my $top1 = $mw->Toplevel;
+ $top1->title( 'Toplevel 1' );
+ $top1->Label(-text => 'Left')->pack(-side => 'left');
+ $top1->Label(-text => 'Right')->pack(-side => 'right');
+ $top1->Label(-text => '?Bottom?')->pack(-side => 'bottom');
+
+ # But when you use Frames, things work quite alright
+ my $top2 = $mw->Toplevel;
+ $top2->title( 'Toplevel 2' );
+ my $frame = $top2->Frame;
+ $frame->pack;
+ $frame->Label(-text => 'Left2')->pack(-side => 'left');
+ $frame->Label(-text => 'Right2')->pack(-side => 'right');
+ $top2->Label(-text => 'Bottom2')->pack(-side => 'bottom');
+
+ MainLoop;
+
+=head1 More than one window
+
+Most real applications require more than one window. As you just saw,
+you can create more outermost windows by using a B<Toplevel> widget.
+Each window is independent; destroying a B<Toplevel> window does not
+affect the others as long as they are not a child of the closed
+B<Toplevel>. However, exiting the B<MainWindow> will destroy all remaining
+B<Toplevel> widgets and end the application. The
+example below shows a trivial three-window application:
+
+ #!/usr/bin/perl -w
+ use Tk;
+ use strict;
+
+ my $mw = MainWindow->new;
+ fill_window($mw, 'Main');
+ my $top1 = $mw->Toplevel;
+ fill_window($top1, 'First top-level');
+ my $top2 = $mw->Toplevel;
+ fill_window($top2, 'Second top-level');
+ MainLoop;
+
+ sub fill_window {
+ my ($window, $header) = @_;
+ $window->Label(-text => $header)->pack;
+ $window->Button(
+ -text => 'close',
+ -command => [$window => 'destroy']
+ )->pack(-side => 'left');
+ $window->Button(
+ -text => 'exit',
+ -command => [$mw => 'destroy']
+ )->pack(-side => 'right');
+ }
+
+=head1 More callbacks
+
+So far, all callback routines shown called a user procedure.
+You can also have a callback routine call another Tk routine.
+This is the way that scroll bars are implemented: scroll-bars
+can call a Tk item or a user procedure, whenever their position
+has changed. The Tk item that has a scrollbar attached calls the
+scrollbar when its size or offset has changed. In this way,
+the items are linked. You can still ask a scrollbar's position,
+or set it by hand - but the defaults will be taken care of.
+
+The example below shows a B<L<Listbox|Tk::Listbox>> with a scroll bar. Moving
+the scrollbar moves the B<Listbox>. Scanning a B<Listbox> (dragging
+an item with the left mouse button) moves the scrollbar.
+
+ #!/usr/bin/perl -w
+ use Tk;
+ use strict;
+
+ my $mw = MainWindow->new;
+ my $box = $mw->Listbox(
+ -relief => 'sunken',
+ -height => 5,
+ -setgrid => 1,
+ );
+ my @items = qw(One Two Three Four Five Six Seven
+ Eight Nine Ten Eleven Twelve);
+ foreach (@items) {
+ $box->insert('end', $_);
+ }
+ my $scroll = $mw->Scrollbar(-command => ['yview', $box]);
+ $box->configure(-yscrollcommand => ['set', $scroll]);
+ $box->pack(-side => 'left', -fill => 'both', -expand => 1);
+ $scroll->pack(-side => 'right', -fill => 'y');
+
+ MainLoop;
+
+Note that there's a convenience method B<L<Scrolled|Tk::Scrolled>>
+which helps constructing widgets with automatically managed
+scrollbars.
+
+=head1 Canvases and tags
+
+One of the most powerful widgets in Tk is the B<L<Canvas|Tk::Canvas>> window.
+In a B<Canvas> window, you can draw simple graphics and include
+other widgets. The B<Canvas> area may be larger than the visible window,
+and may then be scrolled. Any item you draw on the canvas has its own id,
+and may optionally have one or more I<tags>. You may refer to any
+item by its id, and may refer to any group of items by a common tag;
+you can move, delete, or change groups of items using these tags,
+and you can I<bind> actions to tags. For a properly designed (often
+structured) B<Canvas>, you can specify powerful actions quite simply.
+
+In the example below, actions are bound to circles (single click)
+and blue items (double-click); obviously, this can be extended to any
+tag or group of tags.
+
+ #!/usr/bin/perl -w
+ use Tk;
+ use strict;
+
+ # Create B<MainWindow> and canvas
+ my $mw = MainWindow->new;
+ my $canvas = $mw->Canvas;
+ $canvas->pack(-expand => 1, -fill => 'both');
+
+ # Create various items
+ create_item($canvas, 1, 1, 'circle', 'blue', 'Jane');
+ create_item($canvas, 4, 4, 'circle', 'red', 'Peter');
+ create_item($canvas, 4, 1, 'square', 'blue', 'James');
+ create_item($canvas, 1, 4, 'square', 'red', 'Patricia');
+
+ # Single-clicking with left on a 'circle' item invokes a procedure
+ $canvas->bind('circle', '<1>' => sub {handle_circle($canvas)});
+ # Double-clicking with left on a 'blue' item invokes a procedure
+ $canvas->bind('blue', '<Double-1>' => sub {handle_blue($canvas)});
+ MainLoop;
+
+ # Create an item; use parameters as tags (this is not a default!)
+ sub create_item {
+ my ($can, $x, $y, $form, $color, $name) = @_;
+
+ my $x2 = $x + 1;
+ my $y2 = $y + 1;
+ my $kind;
+ $kind = 'oval' if ($form eq 'circle');
+ $kind = 'rectangle' if ($form eq 'square');
+ $can->create(
+ ($kind, "$x" . 'c', "$y" . 'c',
+ "$x2" . 'c', "$y2" . 'c'),
+ -tags => [$form, $color, $name],
+ -fill => $color);
+ }
+
+ # This gets the real name (not current, blue/red, square/circle)
+ # Note: you'll want to return a list in realistic situations...
+ sub get_name {
+ my ($can) = @_;
+ my $item = $can->find('withtag', 'current');
+ my @taglist = $can->gettags($item);
+ my $name;
+ foreach (@taglist) {
+ next if ($_ eq 'current');
+ next if ($_ eq 'red' or $_ eq 'blue');
+ next if ($_ eq 'square' or $_ eq 'circle');
+ $name = $_;
+ last;
+ }
+ return $name;
+ }
+
+ sub handle_circle {
+ my ($can) = @_;
+ my $name = get_name($can);
+ print "Action on circle $name...\n";
+ }
+
+ sub handle_blue {
+ my ($can) = @_;
+ my $name = get_name($can);
+ print "Action on blue item $name...\n";
+ }
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Widget.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Widget.pm
new file mode 100755
index 00000000000..12c6df53143
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Widget.pm
@@ -0,0 +1,1770 @@
+# 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.
+package Tk::Widget;
+use vars qw($VERSION @DefaultMenuLabels);
+$VERSION = '4.033'; # was: sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/;
+
+require Tk;
+use AutoLoader;
+use strict;
+use Carp;
+use base qw(DynaLoader Tk);
+
+# stubs for 'autoloaded' widget classes
+sub Button;
+sub Canvas;
+sub Checkbutton;
+sub Entry;
+sub Frame;
+sub Label;
+sub Labelframe;
+sub Listbox;
+sub Menu;
+sub Menubutton;
+sub Message;
+sub Panedwindow;
+sub Radiobutton;
+sub Scale;
+sub Scrollbar;
+sub Spinbox;
+sub Text;
+sub Toplevel;
+
+sub Pixmap;
+sub Bitmap;
+sub Photo;
+
+sub ScrlListbox;
+sub Optionmenu;
+
+sub import
+{
+ my $package = shift;
+ carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_);
+ my $need;
+ foreach $need (@_)
+ {
+ unless (defined &{$need})
+ {
+ require "Tk/${need}.pm";
+ }
+ croak "Cannot locate $need" unless (defined &{$need});
+ }
+}
+
+@DefaultMenuLabels = qw[~File ~Help];
+
+# Some tidy-ness functions for winfo stuff
+
+sub True { 1 }
+sub False { 0 }
+
+use Tk::Submethods( 'grab' => [qw(current status release -global)],
+ 'focus' => [qw(-force -lastfor)],
+ 'pack' => [qw(configure forget info propagate slaves)],
+ 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)],
+ 'form' => [qw(check configure forget grid info slaves)],
+ 'event' => [qw(add delete generate info)],
+ 'place' => [qw(configure forget info slaves)],
+ 'wm' => [qw(capture release)],
+ 'font' => [qw(actual configure create delete families measure metrics names subfonts)]
+ );
+
+BEGIN {
+ # FIXME - these don't work in the compiler
+ *IsMenu = \&False;
+ *IsMenubutton = \&False;
+ *configure_self = \&Tk::configure;
+ *cget_self = \&Tk::cget;
+}
+
+
+
+Direct Tk::Submethods (
+ 'winfo' => [qw(cells class colormapfull depth exists
+ geometry height id ismapped manager name parent reqheight
+ reqwidth rootx rooty screen screencells screendepth screenheight
+ screenmmheight screenmmwidth screenvisual screenwidth visual
+ visualsavailable vrootheight viewable vrootwidth vrootx vrooty
+ width x y toplevel children pixels pointerx pointery pointerxy
+ server fpixels rgb )],
+ 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]);
+
+
+sub DESTROY
+{
+ my $w = shift;
+ $w->destroy if ($w->IsWidget);
+}
+
+sub Install
+{
+ # Dynamically loaded widgets add their core commands
+ # to the Tk base class here
+ my ($package,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+sub CreateOptions
+{
+ return ();
+}
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ # Remove from hash %$args any configure-like
+ # options which only apply at create time (e.g. -colormap for Frame),
+ # or which may as well be applied right away
+ # return these as a list of -key => value pairs
+ # Augment same hash with default values for missing mandatory options,
+ # allthough this can be done later in InitObject.
+
+ # Honour -class => if present, we have hacked Tk_ConfigureWidget to
+ # allow -class to be passed to any widget.
+ my @result = ();
+ my $class = delete $args->{'-class'};
+ ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class);
+ @result = (-class => "\u$class") if (defined $class);
+ foreach my $opt ($package->CreateOptions)
+ {
+ push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt};
+ }
+ return @result;
+}
+
+sub InitObject
+{
+ my ($obj,$args) = @_;
+ # per object initialization, for example populating
+ # with sub-widgets, adding a few object bindings to augment
+ # inherited class bindings, changing binding tags.
+ # Also another chance to mess with %$args before configure...
+}
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']);
+}
+
+sub new
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $package = shift;
+ my $parent = shift;
+ $package->InitClass($parent);
+ $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0);
+ my %args = @_;
+ my @args = $package->CreateArgs($parent,\%args);
+ my $cmd = $package->Tk_cmd;
+ my $pname = $parent->PathName;
+ $pname = '' if ($pname eq '.');
+ my $leaf = delete $args{'Name'};
+ if (defined $leaf)
+ {
+ $leaf =~ s/[^a-z0-9_#]+/_/ig;
+ $leaf = lcfirst($leaf);
+ }
+ else
+ {
+ ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/;
+ }
+ my $lname = $pname . '.' . $leaf;
+ # create a hash indexed by leaf name to speed up
+ # creation of a lot of sub-widgets of the same type
+ # e.g. entries in Table
+ my $nhash = $parent->TkHash('_names_');
+ $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf});
+ while (defined ($parent->Widget($lname)))
+ {
+ $lname = $pname . '.' . $leaf . ++$nhash->{$leaf};
+ }
+ my $obj = eval { &$cmd($parent, $lname, @args) };
+ confess $@ if $@;
+ unless (ref $obj)
+ {
+ die "No value from $cmd $lname" unless defined $obj;
+ warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname;
+ $obj = $parent->Widget($lname = $obj);
+ die "$obj from $lname" unless ref $obj;
+ }
+ bless $obj,$package;
+ $obj->SetBindtags;
+ my $notice = $parent->can('NoticeChild');
+ $parent->$notice($obj,\%args) if $notice;
+ $obj->InitObject(\%args);
+# ASkludge(\%args,1);
+ $obj->configure(%args) if (%args);
+# ASkludge(\%args,0);
+ return $obj;
+}
+
+sub DelegateFor
+{
+ my ($w,$method) = @_;
+ while(exists $w->{'Delegates'})
+ {
+ my $delegate = $w->{'Delegates'};
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget);
+ last unless (defined $widget);
+ last if $widget == $w;
+ $w = $widget;
+ }
+ return $w;
+}
+
+sub Delegates
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('Delegates');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+ no strict 'refs';
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ # Pre ->isa scheme
+ *{$base.'::Is'.$name} = \&False;
+ *{$class.'::Is'.$name} = \&True;
+
+ # DelegateFor trickyness is to allow Frames and other derived things
+ # to force creation in a delegate e.g. a ScrlText with embeded windows
+ # need those windows to be children of the Text to get clipping right
+ # and not of the Frame which contains the Text and the scrollbars.
+ *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) };
+}
+
+sub IS
+{
+ return (defined $_[1]) && $_[0] == $_[1];
+}
+
+sub _AutoloadTkWidget
+{
+ my ($self,$method) = @_;
+ my $what = "Tk::Widget::$method";
+ unless (defined &$what)
+ {
+ require "Tk/$method.pm";
+ }
+ return $what;
+}
+
+# require UNIVERSAL; don't load .pm use XS code from perl core though
+
+sub AUTOLOAD
+{
+ # Take a copy into a 'my' variable so we can recurse
+ my $what = $Tk::Widget::AUTOLOAD;
+ my $save = $@;
+ my $name;
+ # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n";
+ # Braces used to preserve $1 et al.
+ {
+ my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/;
+ confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/;
+ $pkg =~ s#::#/#g;
+ if (defined($name=$INC{"$pkg.pm"}))
+ {
+ $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
+ }
+ else
+ {
+ $name = "auto/$what.al";
+ $name =~ s#::#/#g;
+ }
+ }
+ # This may fail, catch error and prevent user's __DIE__ handler
+ # from triggering as well...
+ eval {local $SIG{'__DIE__'}; require $name};
+ if ($@)
+ {
+ croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/);
+ my($package,$method) = ($what =~ /^(.*)::([^:]*)$/);
+ if (ref $_[0] && !$_[0]->can($method)
+ && $_[0]->can('Delegate')
+ && $method !~ /^(ConfigSpecs|Delegates)/ )
+ {
+ my $delegate = $_[0]->Delegates;
+ if (%$delegate || tied %$delegate)
+ {
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget);
+ if (defined $subwidget)
+ {
+ no strict 'refs';
+ # print "AUTOLOAD: $what\n";
+ *{$what} = sub { shift->Delegate($method,@_) };
+ }
+ else
+ {
+ croak "No delegate subwidget '$widget' for $what";
+ }
+ }
+ }
+ }
+ if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/)
+ {
+ # Use ->can as ->isa is broken in perl5.6.0
+ my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget');
+ if ($sub)
+ {
+ carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method);
+ $what = $_[0]->$sub($method)
+ }
+ }
+ }
+ $@ = $save;
+ $DB::sub = $what; # Tell debugger what is going on...
+ unless (defined &$what)
+ {
+ no strict 'refs';
+ *{$what} = sub { croak("Failed to AUTOLOAD '$what'") };
+ }
+ goto &$what;
+}
+
+sub _Destroyed
+{
+ my $w = shift;
+ my $a = delete $w->{'_Destroy_'};
+ if (ref($a))
+ {
+ while (@$a)
+ {
+ my $ent = pop(@$a);
+ if (ref $ent)
+ {
+ eval {local $SIG{'__DIE__'}; $ent->Call };
+ }
+ else
+ {
+ delete $w->{$ent};
+ }
+ }
+ }
+}
+
+sub _OnDestroy
+{
+ my $w = shift;
+ $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'});
+ push(@{$w->{'_Destroy_'}},@_);
+}
+
+sub OnDestroy
+{
+ my $w = shift;
+ $w->_OnDestroy(Tk::Callback->new(@_));
+}
+
+sub TkHash
+{
+ my ($w,$key) = @_;
+ return $w->{$key} if exists $w->{$key};
+ my $hash = $w->{$key} = {};
+ $w->_OnDestroy($key);
+ return $hash;
+}
+
+sub privateData
+{
+ my $w = shift;
+ my $p = shift || caller;
+ $w->{$p} ||= {};
+}
+
+my @image_types;
+my %image_method;
+
+sub ImageMethod
+{
+ shift if (@_ & 1);
+ while (@_)
+ {
+ my ($name,$method) = splice(@_,0,2);
+ push(@image_types,$name);
+ $image_method{$name} = $method;
+ }
+}
+
+sub Getimage
+{
+ my ($w, $name) = @_;
+ my $mw = $w->MainWindow;
+ croak "Usage \$widget->Getimage('name')" unless defined($name);
+ my $images = ($mw->{'__Images__'} ||= {});
+
+ return $images->{$name} if $images->{$name};
+
+ ImageMethod(xpm => 'Pixmap',
+ gif => 'Photo',
+ ppm => 'Photo',
+ xbm => 'Bitmap' ) unless @image_types;
+
+ foreach my $type (@image_types)
+ {
+ my $method = $image_method{$type};
+ my $file = Tk->findINC( "$name.$type" );
+ next unless( $file && $method );
+ my $sub = $w->can($method);
+ unless (defined &$sub)
+ {
+ require Tk::widgets;
+ Tk::widgets->import($method);
+ }
+ $images->{$name} = $w->$method( -file => $file );
+ return $images->{$name};
+ }
+
+ # Try built-in bitmaps
+ $images->{$name} = $w->Pixmap( -id => $name );
+ return $images->{$name};
+}
+
+sub SaveGrabInfo
+{
+ my $w = shift;
+ $Tk::oldGrab = $w->grabCurrent;
+ if (defined $Tk::oldGrab)
+ {
+ $Tk::grabStatus = $Tk::oldGrab->grabStatus;
+ }
+}
+
+sub grabSave
+{
+ my ($w) = @_;
+ my $grab = $w->grabCurrent;
+ return sub {} if (!defined $grab);
+ my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab';
+ return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } };
+}
+
+sub focusCurrent
+{
+ my ($w) = @_;
+ $w->Tk::focus('-displayof');
+}
+
+sub focusSave
+{
+ my ($w) = @_;
+ my $focus = $w->focusCurrent;
+ return sub {} if (!defined $focus);
+ return sub { eval {local $SIG{'__DIE__'}; $focus->focus } };
+}
+
+# This is supposed to replicate Tk::after behaviour,
+# but does auto-cancel when widget is deleted.
+require Tk::After;
+
+sub afterCancel
+{
+ my ($w,$what) = @_;
+ if (defined $what)
+ {
+ return $what->cancel if ref($what);
+ carp "dubious cancel of $what" if 0 && $^W;
+ $w->Tk::after('cancel' => $what);
+ }
+}
+
+sub afterIdle
+{
+ my $w = shift;
+ return Tk::After->new($w,'idle','once',@_);
+}
+
+sub afterInfo {
+ my ($w, $id) = @_;
+ if (defined $id) {
+ return ($id->[4], $id->[2], $id->[3]);
+ } else {
+ return sort( keys %{$w->{_After_}} );
+ }
+}
+
+sub after
+{
+ my $w = shift;
+ my $t = shift;
+ if (@_)
+ {
+ if ($t ne 'cancel')
+ {
+ require Tk::After;
+ return Tk::After->new($w,$t,'once',@_)
+ }
+ while (@_)
+ {
+ my $what = shift;
+ $w->afterCancel($what);
+ }
+ }
+ else
+ {
+ $w->Tk::after($t);
+ }
+}
+
+sub repeat
+{
+ require Tk::After;
+ my $w = shift;
+ my $t = shift;
+ return Tk::After->new($w,$t,'repeat',@_);
+}
+
+sub FindMenu
+{
+ # default FindMenu is that there is no menu.
+ return undef;
+}
+
+sub XEvent { shift->{'_XEvent_'} }
+
+sub propertyRoot
+{
+ my $w = shift;
+ return $w->property(@_,'root');
+}
+
+# atom, atomname, containing, interps, pathname
+# don't work this way - there is no window arg
+# So we pretend there was an call the C versions from Tk.xs
+
+sub atom { shift->InternAtom(@_) }
+sub atomname { shift->GetAtomName(@_) }
+sub containing { shift->Containing(@_) }
+
+# interps not done yet
+# pathname not done yet
+
+# walk and descendants adapted from Stephen's composite
+# versions as they only use core features they can go here.
+# hierachy is reversed in that descendants calls walk rather
+# than vice versa as this avoids building a list.
+# Walk should possibly be enhanced so allow early termination
+# like '-prune' of find.
+
+sub Walk
+{
+ # Traverse a widget hierarchy while executing a subroutine.
+ my($cw, $proc, @args) = @_;
+ my $subwidget;
+ foreach $subwidget ($cw->children)
+ {
+ $subwidget->Walk($proc,@args);
+ &$proc($subwidget, @args);
+ }
+} # end walk
+
+sub Descendants
+{
+ # Return a list of widgets derived from a parent widget and all its
+ # descendants of a particular class.
+ # If class is not passed returns the entire widget hierarchy.
+
+ my($widget, $class) = @_;
+ my(@widget_tree) = ();
+
+ $widget->Walk(
+ sub { my ($widget,$list,$class) = @_;
+ push(@$list, $widget) if (!defined($class) or $class eq $widget->class);
+ },
+ \@widget_tree, $class
+ );
+ return @widget_tree;
+}
+
+sub Palette
+{
+ my $w = shift->MainWindow;
+ unless (exists $w->{_Palette_})
+ {
+ my %Palette = ();
+ my $c = $w->Checkbutton();
+ my $e = $w->Entry();
+ my $s = $w->Scrollbar();
+ $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ;
+ $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3];
+ $Palette{'background'} = ($c->configure('-background'))[3];
+ $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3];
+
+ $Palette{'foreground'} = ($c->configure('-foreground'))[3];
+ $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3];
+ $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3];
+ $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3];
+ $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3];
+ $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3];
+ $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3];
+ $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3];
+ $c->destroy;
+ $e->destroy;
+ $s->destroy;
+ $w->{_Palette_} = \%Palette;
+ }
+ return $w->{_Palette_};
+}
+
+# tk_setPalette --
+# Changes the default color scheme for a Tk application by setting
+# default colors in the option database and by modifying all of the
+# color options for existing widgets that have the default value.
+#
+# Arguments:
+# The arguments consist of either a single color name, which
+# will be used as the new background color (all other colors will
+# be computed from this) or an even number of values consisting of
+# option names and values. The name for an option is the one used
+# for the option database, such as activeForeground, not -activeforeground.
+# Additional special option names are:
+# priority: set the priority for the option database entries, see Tk::option
+sub setPalette
+{
+ my $w = shift->MainWindow;
+ # Just return on monochrome displays, otherwise errors will occur
+ return if $w->depth == 1;
+ my %new = (@_ == 1) ? (background => $_[0]) : @_;
+ my $priority = delete($new{'priority'}) || 'widgetDefault';
+
+ # Create an array that has the complete new palette. If some colors
+ # aren't specified, compute them from other colors that are specified.
+
+ die 'must specify a background color' if (!exists $new{background});
+ my @bg = $w->rgb($new{'background'});
+
+ if (!exists $new{foreground})
+ {
+ # Note that the range of each value in the triple returned by
+ # [winfo rgb] is 0-65535, and your eyes are more sensitive to
+ # green than to red, and more to red than to blue.
+ my($r,$g,$b) = @bg;
+ if ($r+1.5*$g+0.5*$b > 100000)
+ {
+ $new{'foreground'} = 'black';
+ }
+ else
+ {
+ $new{'foreground'} = 'white';
+ }
+ }
+ my @fg = $w->rgb($new{'foreground'});
+ my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560);
+ foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor')
+ {
+ $new{$i} = $new{'foreground'} unless (exists $new{$i});
+ }
+ unless (exists $new{'disabledForeground'})
+ {
+ $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024);
+ }
+ $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'});
+
+ unless (exists $new{'activeBackground'})
+ {
+ my @light;
+ # Pick a default active background that is lighter than the
+ # normal background. To do this, round each color component
+ # up by 15% or 1/3 of the way to full white, whichever is
+ # greater.
+ foreach my $i (0, 1, 2)
+ {
+ $light[$i] = $bg[$i]/256;
+ my $inc1 = $light[$i]*15/100;
+ my $inc2 = (255-$light[$i])/3;
+ if ($inc1 > $inc2)
+ {
+ $light[$i] += $inc1
+ }
+ else
+ {
+ $light[$i] += $inc2
+ }
+ $light[$i] = 255 if ($light[$i] > 255);
+ }
+ $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light);
+ }
+ $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'});
+ $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'});
+ $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'});
+
+ # Before doing this, make sure that the Tk::Palette variable holds
+ # the default values of all options, so that tkRecolorTree can
+ # be sure to only change options that have their default values.
+ # If the variable exists, then it is already correct (it was created
+ # the last time this procedure was invoked). If the variable
+ # doesn't exist, fill it in using the defaults from a few widgets.
+ my $Palette = $w->Palette;
+
+ # let's make one of each of the widgets so we know what the
+ # defaults are currently for this platform.
+ $Tk::___tk_set_palette = $w->Toplevel(Name => "___tk_set_palette");
+ $Tk::___tk_set_palette->withdraw;
+ foreach my $q (qw(Button Canvas Checkbutton Entry Frame Label Labelframe
+ Listbox Menubutton Menu Message Radiobutton Scale Scrollbar
+ Spinbox Text
+ ))
+ {
+ $Tk::___tk_set_palette->Component($q, $q);
+ }
+
+ # Walk the widget hierarchy, recoloring all existing windows.
+ my $res = $w->RecolorTree(\%new);
+ if ($res->{addOptionDB})
+ {
+ for (@{ $res->{addOptionDB} })
+ {
+ $w->optionAdd(@$_);
+ }
+ }
+
+ $Tk::___tk_set_palette->destroy;
+
+ # Change the option database so that future windows will get the
+ # same colors.
+ foreach my $option (keys %new)
+ {
+ $w->option('add',"*$option",$new{$option},$priority);
+ # Save the options in the global variable Tk::Palette, for use the
+ # next time we change the options.
+ $Palette->{$option} = $new{$option};
+ }
+}
+
+# tkRecolorTree --
+# This procedure changes the colors in a window and all of its
+# descendants, according to information provided by the colors
+# argument. It only modifies colors that have their default values
+# as specified by the Tk::Palette variable.
+#
+# Arguments:
+# w - The name of a window. This window and all its
+# descendants are recolored.
+# colors - The name of an array variable in the caller,
+# which contains color information. Each element
+# is named after a widget configuration option, and
+# each value is the value for that option.
+sub RecolorTree
+{
+ my ($w,$colors) = @_;
+ local ($@);
+ my @addOptionDB;
+ my $prototype = $Tk::___tk_set_palette->Subwidget($w->Class) || undef;
+ foreach my $dbOption (keys %$colors)
+ {
+ my $option = "-\L$dbOption";
+ my $class = ucfirst($dbOption);
+ my @value;
+ eval {local $SIG{'__DIE__'}; @value = $w->configure($option) };
+ if (@value)
+ {
+ # if the option database has a preference for this
+ # dbOption, then use it, otherwise use the defaults
+ # for the widget.
+ my $defaultcolor = $w->optionGet($dbOption, $class);
+ no warnings 'uninitialized';
+ if ($defaultcolor eq '' ||
+ ($prototype && $prototype->cget($option) ne $defaultcolor))
+ {
+ $defaultcolor = $value[3];
+ }
+ if ($defaultcolor ne '' && $value[4] ne '') # XXX why this can be empty?
+ {
+ $defaultcolor = join ",", $w->rgb($defaultcolor);
+ my $chosencolor = join ",", $w->rgb($value[4]);
+ if ($defaultcolor eq $chosencolor)
+ {
+ # Change the option database so that future windows will get
+ # the same colors.
+ push @addOptionDB, ['*'.$w->Class.".$dbOption", $colors->{$dbOption}, 60];
+ $w->configure($option,$colors->{$dbOption});
+ }
+ }
+ }
+ }
+ foreach my $child ($w->children)
+ {
+ my $res = $child->RecolorTree($colors);
+ if ($res->{addOptionDB})
+ {
+ push @addOptionDB, @{ $res->{addOptionDB} };
+ }
+ }
+ return { addOptionDB => \@addOptionDB };
+}
+# tkDarken --
+# Given a color name, computes a new color value that darkens (or
+# brightens) the given color by a given percent.
+#
+# Arguments:
+# color - Name of starting color.
+# perecent - Integer telling how much to brighten or darken as a
+# percent: 50 means darken by 50%, 110 means brighten
+# by 10%.
+sub Darken
+{
+ my ($w,$color,$percent) = @_;
+ my @l = $w->rgb($color);
+ my $red = $l[0]/256;
+ my $green = $l[1]/256;
+ my $blue = $l[2]/256;
+ $red = int($red*$percent/100);
+ $red = 255 if ($red > 255);
+ $green = int($green*$percent/100);
+ $green = 255 if ($green > 255);
+ $blue = int($blue*$percent/100);
+ $blue = 255 if ($blue > 255);
+ sprintf('#%02x%02x%02x',$red,$green,$blue)
+}
+# tk_bisque --
+# Reset the Tk color palette to the old "bisque" colors.
+#
+# Arguments:
+# None.
+sub bisque
+{
+ shift->setPalette('activeBackground' => '#e6ceb1',
+ 'activeForeground' => 'black',
+ 'background' => '#ffe4c4',
+ 'disabledForeground' => '#b0b0b0',
+ 'foreground' => 'black',
+ 'highlightBackground' => '#ffe4c4',
+ 'highlightColor' => 'black',
+ 'insertBackground' => 'black',
+ 'selectColor' => '#b03060',
+ 'selectBackground' => '#e6ceb1',
+ 'selectForeground' => 'black',
+ 'troughColor' => '#cdb79e'
+ );
+}
+
+sub PrintConfig
+{
+ require Tk::Pretty;
+ my ($w) = (@_);
+ my $c;
+ foreach $c ($w->configure)
+ {
+ print Tk::Pretty::Pretty(@$c),"\n";
+ }
+}
+
+sub BusyRecurse
+{
+ my ($restore,$w,$cursor,$recurse,$top) = @_;
+ my $c = $w->cget('-cursor');
+ my @tags = $w->bindtags;
+ if ($top || defined($c))
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) });
+ $w->configure(-cursor => $cursor);
+ }
+ else
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) });
+ }
+ $w->bindtags(['Busy',@tags]);
+ if ($recurse)
+ {
+ foreach my $child ($w->children)
+ {
+ BusyRecurse($restore,$child,$cursor,1,0);
+ }
+ }
+ return $restore;
+}
+
+sub Busy
+{
+ my ($w,@args) = @_;
+ return unless $w->viewable;
+ my($sub, %args);
+ for(my $i=0; $i<=$#args; $i++)
+ {
+ if (ref $args[$i] eq 'CODE')
+ {
+ if (defined $sub)
+ {
+ croak "Multiple code definitions not allowed in Tk::Widget::Busy";
+ }
+ $sub = $args[$i];
+ }
+ else
+ {
+ $args{$args[$i]} = $args[$i+1]; $i++;
+ }
+ }
+ my $cursor = delete $args{'-cursor'};
+ my $recurse = delete $args{'-recurse'};
+ $cursor = 'watch' unless defined $cursor;
+ unless (exists $w->{'Busy'})
+ {
+ my @old = ($w->grabSave);
+ my $key;
+ my @config;
+ foreach $key (keys %args)
+ {
+ push(@config,$key => $w->Tk::cget($key));
+ }
+ if (@config)
+ {
+ push(@old, sub { $w->Tk::configure(@config) });
+ $w->Tk::configure(%args);
+ }
+ unless ($w->Tk::bind('Busy'))
+ {
+ $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]);
+ }
+ $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1);
+ }
+ my $g = $w->grabCurrent;
+ if (defined $g)
+ {
+ # warn "$g has the grab";
+ $g->grabRelease;
+ }
+ $w->update;
+ if (Tk::Exists($w))
+ {
+ eval {local $SIG{'__DIE__'}; $w->grab };
+ $w->update;
+ }
+ if ($sub && Tk::Exists($w))
+ {
+ eval { $sub->() };
+ my $err = $@;
+ $w->Unbusy(-recurse => $recurse);
+ die $err if $err;
+ }
+}
+
+sub _busy
+{
+ my ($w,$f) = @_;
+ $w->bell if $f;
+ $w->break;
+}
+
+sub Unbusy
+{
+ my ($w) = @_;
+ $w->update;
+ $w->grabRelease if Tk::Exists($w);
+ my $old = delete $w->{'Busy'};
+ if (defined $old)
+ {
+ local $SIG{'__DIE__'};
+ eval { &{pop(@$old)} } while (@$old);
+ }
+ $w->update if Tk::Exists($w);
+}
+
+sub waitVisibility
+{
+ my ($w) = shift;
+ $w->tkwait('visibility',$w);
+}
+
+sub waitVariable
+{
+ my ($w) = shift;
+ $w->tkwait('variable',@_);
+}
+
+sub waitWindow
+{
+ my ($w) = shift;
+ $w->tkwait('window',$w);
+}
+
+sub EventWidget
+{
+ my ($w) = @_;
+ return $w->{'_EventWidget_'};
+}
+
+sub Popwidget
+{
+ my ($ew,$method,$w,@args) = @_;
+ $w->{'_EventWidget_'} = $ew;
+ $w->$method(@args);
+}
+
+sub ColorOptions
+{
+ my ($w,$args) = @_;
+ my $opt;
+ $args = {} unless (defined $args);
+ foreach $opt (qw(-foreground -background -disabledforeground
+ -activebackground -activeforeground
+ ))
+ {
+ $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt})
+ }
+ return (wantarray) ? %$args : $args;
+}
+
+sub XscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Right>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']);
+ $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']);
+
+ $mw->bind($class,'<Home>', ['xview','moveto',0]);
+ $mw->bind($class,'<End>', ['xview','moveto',1]);
+ $mw->XMouseWheelBind($class);
+}
+
+sub PriorNextBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']);
+ $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']);
+}
+
+sub XMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']);
+}
+
+sub YMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<4>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<5>', ['yview','scroll',1,'units']);
+}
+
+sub YscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->PriorNextBind($class);
+ $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<Down>', ['yview','scroll',1,'units']);
+ $mw->YMouseWheelBind($class);
+}
+
+sub XYscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->YscrollBind($class);
+ $mw->XscrollBind($class);
+ # <4> and <5> are how mousewheel looks on X
+}
+
+sub MouseWheelBind
+{
+ my($mw,$class) = @_;
+
+ # The MouseWheel will typically only fire on Windows. However, one
+ # could use the "event generate" command to produce MouseWheel
+ # events on other platforms.
+
+ $mw->Tk::bind($class, '<MouseWheel>',
+ [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]);
+
+ if ($Tk::platform eq 'unix')
+ {
+ # Support for mousewheels on Linux/Unix commonly comes through mapping
+ # the wheel to the extended buttons. If you have a mousewheel, find
+ # Linux configuration info at:
+ # http://www.inria.fr/koala/colas/mouse-wheel-scroll/
+ $mw->Tk::bind($class, '<4>',
+ sub { $_[0]->yview('scroll', -3, 'units')
+ unless $Tk::strictMotif;
+ });
+ $mw->Tk::bind($class, '<5>',
+ sub { $_[0]->yview('scroll', 3, 'units')
+ unless $Tk::strictMotif;
+ });
+ }
+}
+
+sub ScrlListbox
+{
+ my $parent = shift;
+ return $parent->Scrolled('Listbox',-scrollbars => 'w', @_);
+}
+
+sub AddBindTag
+{
+ my ($w,$tag) = @_;
+ my $t;
+ my @tags = $w->bindtags;
+ foreach $t (@tags)
+ {
+ return if $t eq $tag;
+ }
+ $w->bindtags([@tags,$tag]);
+}
+
+sub Callback
+{
+ my $w = shift;
+ my $name = shift;
+ my $cb = $w->cget($name);
+ if (defined $cb)
+ {
+ return $cb->Call(@_) if (ref $cb);
+ return $w->$cb(@_);
+ }
+ return (wantarray) ? () : undef;
+}
+
+sub packAdjust
+{
+# print 'packAdjust(',join(',',@_),")\n";
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->pack(%args);
+ %args = $w->packInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},
+ -widget => $w, -delay => $delay, -side => $args{'-side'});
+ $adj->packed($w,%args);
+ return $w;
+}
+
+sub gridAdjust
+{
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->grid(%args);
+ %args = $w->gridInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay);
+ $adj->gridded($w,%args);
+ return $w;
+}
+
+sub place
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x)
+ {
+ $w->Tk::place(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::place('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub pack
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
+ {
+ # maybe array/scalar context issue with slaves
+ $w->Tk::pack(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::pack('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub grid
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x)
+ {
+ my $opt = shift;
+ Tk::grid($opt,$w,@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ Tk::grid('configure',$w,@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub form
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x)
+ {
+ $w->Tk::form(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::form('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub Scrolled
+{
+ my ($parent,$kind,%args) = @_;
+ $kind = 'Pane' if $kind eq 'Frame';
+ # Find args that are Frame create time args
+ my @args = Tk::Frame->CreateArgs($parent,\%args);
+ my $name = delete $args{'Name'};
+ push(@args,'Name' => $name) if (defined $name);
+ my $cw = $parent->Frame(@args);
+ @args = ();
+ # Now remove any args that Frame can handle
+ foreach my $k ('-scrollbars',map($_->[0],$cw->configure))
+ {
+ push(@args,$k,delete($args{$k})) if (exists $args{$k})
+ }
+ # Anything else must be for target widget - pass at widget create time
+ my $w = $cw->$kind(%args);
+ # Now re-set %args to be ones Frame can handle
+ %args = @args;
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'],
+ '-background' => [$w,'background','Background'],
+ '-foreground' => [$w,'foreground','Foreground'],
+ );
+ $cw->AddScrollbars($w);
+ $cw->Default("\L$kind" => $w);
+ $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w);
+ $cw->ConfigDefault(\%args);
+ $cw->configure(%args);
+ return $cw;
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+}
+
+sub ForwardEvent
+{
+ my $self = shift;
+ my $to = shift;
+ $to->PassEvent($self->XEvent);
+}
+
+# Save / Return abstract event type as in Tix.
+sub EventType
+{
+ my $w = shift;
+ $w->{'_EventType_'} = $_[0] if @_;
+ return $w->{'_EventType_'};
+}
+
+sub PostPopupMenu
+{
+ my ($w, $X, $Y) = @_;
+ if (@_ < 3)
+ {
+ my $e = $w->XEvent;
+ $X = $e->X;
+ $Y = $e->Y;
+ }
+ my $menu = $w->menu;
+ $menu->Post($X,$Y) if defined $menu;
+}
+
+sub FillMenu
+{
+ my ($w,$menu,@labels) = @_;
+ foreach my $lab (@labels)
+ {
+ my $method = $lab.'MenuItems';
+ $method =~ s/~//g;
+ $method =~ s/[\s-]+/_/g;
+ if ($w->can($method))
+ {
+ $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method());
+ }
+ }
+ return $menu;
+}
+
+sub menu
+{
+ my ($w,$menu) = @_;
+ if (@_ > 1)
+ {
+ $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'};
+ $w->{'_MENU_'} = $menu;
+ }
+ return unless defined wantarray;
+ unless (exists $w->{'_MENU_'})
+ {
+ $w->_OnDestroy('_MENU_');
+ $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0);
+ $w->FillMenu($menu,$w->MenuLabels);
+ }
+ return $w->{'_MENU_'};
+}
+
+sub MenuLabels
+{
+ return @DefaultMenuLabels;
+}
+
+sub FileMenuItems
+{
+ my ($w) = @_;
+ return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]];
+}
+
+sub WmDeleteWindow
+{
+ shift->toplevel->WmDeleteWindow
+}
+
+sub BalloonInfo
+{
+ my ($widget,$balloon,$X,$Y,@opt) = @_;
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$widget);
+ return $info if defined $info;
+ }
+}
+
+sub ConfigSpecs {
+
+ my $w = shift;
+
+ return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure;
+
+}
+
+*GetSelection =
+ ($Tk::platform eq 'unix'
+ ? sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING")
+ };
+ if ($@)
+ {
+ $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ }
+ $txt;
+ }
+ : sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ $txt;
+ }
+ );
+
+1;
+__END__
+
+sub bindDump {
+
+ # Dump lots of good binding information. This pretty-print subroutine
+ # is, essentially, the following code in disguise:
+ #
+ # print "Binding information for $w\n";
+ # foreach my $tag ($w->bindtags) {
+ # printf "\n Binding tag '$tag' has these bindings:\n";
+ # foreach my $binding ($w->bind($tag)) {
+ # printf " $binding\n";
+ # }
+ # }
+
+ my ($w) = @_;
+
+ my (@bindtags) = $w->bindtags;
+ my $digits = length( scalar @bindtags );
+ my ($spc1, $spc2) = ($digits + 33, $digits + 35);
+ my $format1 = "%${digits}d.";
+ my $format2 = ' ' x ($digits + 2);
+ my $n = 0;
+
+ my @out;
+ push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w );
+
+ foreach my $tag (@bindtags) {
+ my (@bindings) = $w->bind($tag);
+ $n++; # count this bindtag
+
+ if ($#bindings == -1) {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n );
+ } else {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n );
+
+ foreach my $binding ( @bindings ) {
+ my $callback = $w->bind($tag, $binding);
+ push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback );
+
+ if ($callback =~ /SCALAR/) {
+ if (ref $$callback) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback );
+ }
+ } elsif ($callback =~ /ARRAY/) {
+ if (ref $callback->[0]) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" );
+ }
+ foreach my $arg (@$callback[1 .. $#$callback]) {
+ if (ref $arg) {
+ push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
+ } else {
+ push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
+ }
+
+ if (ref $arg eq 'Tk::Ev') {
+ if ($arg =~ /SCALAR/) {
+ push @out, sprintf( ": '$$arg'" );
+ } else {
+ push @out, sprintf( ": '%s'", join("' '", @$arg) );
+ }
+ }
+
+ push @out, sprintf( "\n" );
+ } # forend callback arguments
+ } # ifend callback
+
+ } # forend all bindings for one tag
+
+ } # ifend have bindings
+
+ } # forend all tags
+ push @out, sprintf( "\n" );
+ return @out;
+
+} # end bindDump
+
+
+sub ASkludge
+{
+ my ($hash,$sense) = @_;
+ foreach my $key (%$hash)
+ {
+ if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR')
+ {
+ if ($sense)
+ {
+ my $val = ${$hash->{$key}};
+ require Tie::Scalar;
+ tie ${$hash->{$key}},'Tie::StdScalar';
+ ${$hash->{$key}} = $val;
+ }
+ else
+ {
+ untie ${$hash->{$key}};
+ }
+ }
+ }
+}
+
+
+
+# clipboardKeysyms --
+# This procedure is invoked to identify the keys that correspond to
+# the "copy", "cut", and "paste" functions for the clipboard.
+#
+# Arguments:
+# copy - Name of the key (keysym name plus modifiers, if any,
+# such as "Meta-y") used for the copy operation.
+# cut - Name of the key used for the cut operation.
+# paste - Name of the key used for the paste operation.
+#
+# This method is obsolete use clipboardOperations and abstract
+# event types instead. See Clipboard.pm and Mainwindow.pm
+
+sub clipboardKeysyms
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ if (@_)
+ {
+ my $copy = shift;
+ $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy);
+ }
+ if (@_)
+ {
+ my $cut = shift;
+ $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut);
+ }
+ if (@_)
+ {
+ my $paste = shift;
+ $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste);
+ }
+}
+
+sub pathname
+{
+ my ($w,$id) = @_;
+ my $x = $w->winfo('pathname',-displayof => oct($id));
+ return $x->PathName;
+}
+
+# ::tk::UnderlineAmpersand --
+# This procedure takes some text with ampersand and returns
+# text w/o ampersand and position of the ampersand.
+# Double ampersands are converted to single ones.
+# Position returned is -1 when there is no ampersand.
+#
+sub UnderlineAmpersand
+{
+ my (undef,$text) = @_;
+ if ($text =~ m{(?<!&)&(?!&)}g)
+ {
+ my $idx = pos $text;
+ $text =~ s{(?<!&)&(?!&)}{};
+ ($text, $idx);
+ }
+ else
+ {
+ ($text, -1);
+ }
+}
+
+# ::tk::SetAmpText --
+# Given widget path and text with "magic ampersands",
+# sets -text and -underline options for the widget
+#
+sub SetAmpText
+{
+ my ($w,$text) = @_;
+ my ($newtext,$under) = $w->UnderlineAmpersand($text);
+ $w->configure(-text => $newtext, -underline => $under);
+}
+
+# ::tk::AmpWidget --
+# Creates new widget, turning -text option into -text and
+# -underline options, returned by ::tk::UnderlineAmpersand.
+#
+sub AmpWidget
+{
+ my ($w,$class,%args) = @_;
+ my @options;
+ while(my($opt,$val) = each %args)
+ {
+ if ($opt eq "-text")
+ {
+ my ($newtext,$under) = $w->UnderlineAmpersand($val);
+ push @options, -text => $newtext, -underline => $under;
+ }
+ else
+ {
+ push @options, $opt, $val;
+ }
+ }
+ my $result = $w->$class(@options);
+ if ($result->can('AmpWidgetPostHook'))
+ {
+ $result->AmpWidgetPostHook;
+ }
+ return $result;
+}
+
+# ::tk::FindAltKeyTarget --
+# search recursively through the hierarchy of visible widgets
+# to find button or label which has $char as underlined character
+#
+sub FindAltKeyTarget
+{
+ my ($w,$char) = @_;
+ $char = lc $char;
+ if ($w->isa('Tk::Button') || $w->isa('Tk::Label'))
+ {
+ if ($char eq lc substr($w->cget(-text), $w->cget(-underline), 1))
+ {
+ return $w;
+ }
+ else
+ {
+ return undef;
+ }
+ }
+ else
+ {
+ for my $cw ($w->gridSlaves, $w->packSlaves, $w->placeSlaves) # Cannot handle $w->formSlaves here?
+ {
+ my $target = $cw->FindAltKeyTarget($char);
+ return $target if ($target);
+ }
+ }
+ undef;
+}
+
+# ::tk::AltKeyInDialog --
+# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
+# to button or label which has appropriate underlined character
+#
+sub AltKeyInDialog
+{
+ my ($w, $key) = @_;
+ my $target = $w->FindAltKeyTarget($key);
+ return if !$target;
+ $target->eventGenerate('<<AltUnderlined>>');
+}
+
+# ::tk::SetFocusGrab --
+# swap out current focus and grab temporarily (for dialogs)
+# Arguments:
+# grab new window to grab
+# focus window to give focus to
+# Results:
+# Returns nothing
+#
+sub SetFocusGrab
+{
+ my ($grab,$focus) = @_;
+ my $index = "$grab,$focus";
+ $Tk::FocusGrab{$index} ||= [];
+ my $data = $Tk::FocusGrab{$index};
+ push @$data, $grab->focusCurrent;
+ my $oldGrab = $grab->grabCurrent;
+ push @$data, $oldGrab;
+ if (Tk::Exists($oldGrab))
+ {
+ push @$data, $oldGrab->grabStatus;
+ }
+ # The "grab" command will fail if another application
+ # already holds the grab. So catch it.
+ Tk::catch { $grab->grab };
+ if (Tk::Exists($focus))
+ {
+ $focus->focus;
+ }
+}
+
+# ::tk::RestoreFocusGrab --
+# restore old focus and grab (for dialogs)
+# Arguments:
+# grab window that had taken grab
+# focus window that had taken focus
+# destroy destroy|withdraw - how to handle the old grabbed window
+# Results:
+# Returns nothing
+#
+sub RestoreFocusGrab
+{
+ my ($grab, $focus, $destroy) = @_;
+ $destroy = 'destroy' if !$destroy;
+ my $index = "$grab,$focus";
+ my ($oldFocus, $oldGrab, $oldStatus);
+ if (exists $Tk::FocusGrab{$index})
+ {
+ ($oldFocus, $oldGrab, $oldStatus) = $Tk::FocusGrab{$index};
+ delete $Tk::FocusGrab{$index};
+ }
+ else
+ {
+ $oldGrab = "";
+ }
+
+ Tk::catch { $oldFocus->focus };
+ if (Tk::Exists($grab))
+ {
+ $grab->grabRelease;
+ if ($destroy eq "withdraw")
+ {
+ $grab->withdraw;
+ }
+ else
+ {
+ $grab->destroy;
+ }
+ }
+ if (Tk::Exists($oldGrab) && $oldGrab->ismapped)
+ {
+ if ($oldStatus eq "global")
+ {
+ $oldGrab->grabGlobal;
+ }
+ else
+ {
+ $oldGrab->grab;
+ }
+ }
+}
+
+# See http://rt.cpan.org/Ticket/Display.html?id=30929 and
+# http://rt.cpan.org/Ticket/Display.html?id=31016
+sub MasterMenu
+ {
+ }
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Widget.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Widget.pod
new file mode 100755
index 00000000000..696bbab22b7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Widget.pod
@@ -0,0 +1,678 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Widget - Base class of all widgets
+
+=for pm Tk/Widget.pm
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+ package Tk::Whatever;
+ require Tk::Widget;
+ @ISA = qw(Tk::Widget);
+ Construct Tk::Widget 'Whatever';
+
+ sub Tk_cmd { \&Tk::whatever }
+
+S< >I<$widget>-E<gt>I<method>(?I<arg, arg, ...>?)
+
+=head1 DESCRIPTION
+
+The B<Tk::Widget> is an abstract base class for all Tk widgets.
+
+Generic methods available to all widgets include the methods based on core
+C<winfo> mechanism and are used to retrieve information about windows managed by
+Tk. They can take any of a number of different forms, depending on the I<method>.
+The legal forms are:
+
+=over 4
+
+=item I<$widget>-E<gt>B<appname>?(I<newName>)?
+
+If I<newName> isn't specified, this method returns the name
+of the application (the name that may be used in B<send>
+commands to communicate with the application).
+If I<newName> is specified, then the name of the application
+is changed to I<newName>.
+If the given name is already in use, then a suffix of the form
+``B< #2>'' or ``B< #3>'' is appended in order to make the name unique.
+The method's result is the name actually chosen.
+I<newName> should not start with a capital letter.
+This will interfere with L<option|Tk::option> processing, since names starting with
+capitals are assumed to be classes; as a result, Tk may not
+be able to find some options for the application.
+If sends have been disabled by deleting the B<send> command,
+this command will reenable them and recreate the B<send>
+command.
+
+=item I<$widget>-E<gt>B<atom>(I<name>)
+
+Returns a decimal string giving the integer identifier for the
+atom whose name is I<name>. If no atom exists with the name
+I<name> then a new one is created.
+
+=item I<$widget>-E<gt>B<atomname>(I<id>)
+
+Returns the textual name for the atom whose integer identifier is
+I<id>.
+This command is the inverse of the I<$widget>-E<gt>B<atom> command.
+It generates an error if no such atom exists.
+
+=item I<$widget>-E<gt>B<bell>( ?-nice? );
+
+This command rings the bell on the display for I<$widget> and
+returns an empty string.
+The command uses the current bell-related settings for the display, which
+may be modified with programs such as B<xset>.
+
+If I<-nice> is not specified, this command also resets the screen saver
+for the screen. Some screen savers will ignore this, but others will
+reset so that the screen becomes visible again.
+
+=item I<$widget>-E<gt>B<bindDump>
+
+This command returns a list of strings suitable for printing detailing
+binding information for a widget. It prints a widget's
+bindtags. For each binding tag it prints all the bindings, comprised
+of the event descriptor and the callback. Callback arguments are
+printed, and B<Tk::Ev> objects are expanded.
+
+=item I<$widget>-E<gt>B<Busy>?(?-recurse => 1?,I<-option> => I<value>?)?
+
+This method B<configure>s a B<-cursor> option for I<$widget> and
+(if B<-recurse => 1> is specified) all its descendants. The cursor to
+be set may be passed as S<B<-cursor> => I<cursor>> or defaults to 'watch'.
+Additional B<configure> options are applied to I<$widget> only.
+It also adds a special tag B<'Busy'> to the B<bindtags> of the widgets so
+configured so that B<KeyPress>, B<KeyRelease>, B<ButtonPress> and
+B<ButtonRelease> events are ignored (with press events generating a call to
+B<bell>). It then acquires a local B<grab> for I<$widget>.
+The state of the widgets and the grab is restored by a call to
+I<$widget>-E<gt>B<Unbusy>.
+
+=item I<$widget>-E<gt>B<caret>( ?-x => I<x>?, ?-y => I<y>?, ?-height
+=> I<height>? );
+
+Sets and queries the caret location for the display of the specified
+Tk window window. The caret is the per-display cursor location used
+for indicating global focus (e.g. to comply with Microsoft
+Accessibility guidelines), as well as for location of the
+over-the-spot XIM (X Input Methods) or Windows IME windows. If no
+options are specified, the last values used for setting the caret are
+return in option-value pair format. -x and -y represent
+window-relative coordinates, and -height is the height of the current
+cursor location, or the height of the specified window if none is
+given.
+
+=item I<$widget>-E<gt>B<cells>
+
+Returns a decimal string giving the number of cells in the
+color map for I<$widget>.
+
+=item I<$widget>-E<gt>B<children>
+
+I<$widget->>B<children>
+Returns a list containing all the children
+of $widget. The list is in stacking order, with the lowest
+window first. Top-level windows are returned as children
+of their logical parents.
+
+=item I<$widget>-E<gt>B<class>
+
+Returns the class name for I<$widget>.
+
+=item I<$widget>-E<gt>B<colormapfull>
+
+Returns 1 if the colormap for I<$widget> is known to be full, 0
+otherwise. The colormap for a window is ``known'' to be full if the last
+attempt to allocate a new color on that window failed and this
+application hasn't freed any colors in the colormap since the
+failed allocation.
+
+=item I<$widget>-E<gt>B<ConfigSpecs>
+
+Used to perform delegated option configuration for a mega-widget.
+Returns, in Tk::Derived::ConfigSpecs notation (see L<Tk::ConfigSpecs>),
+all possible options for a widget. For example,
+
+ $s = $self->Scale;
+ $self->ConfigSpecs(
+ $s->ConfigSpecs,
+ .... more ConfigSpecs specifications
+ );
+
+returns a hash of all Tk::Scale options, delegated to $s - e.g. some
+representative examples:
+
+ -bigincrement => [$s, bigIncrement, BigIncrement, 0, 0]
+ -digits => [$s, digits, Digits, 0, 0]
+ -sliderlength => [$s, sliderLength, SliderLength, 10m, 30]
+ -troughcolor => [$s, troughColor, Background, #c3c3c3, #c3c3c3]
+
+This provides an easy means of populating a mega-widget's ConfigSpecs
+with initializers.
+
+=item I<$widget>-E<gt>B<containing>(I<rootX,rootY>)
+
+Returns the window containing the point given
+by I<rootX> and I<rootY>.
+I<RootX> and I<rootY> are specified in screen units (i.e.
+any form acceptable to B<Tk_GetPixels>) in the coordinate
+system of the root window (if a virtual-root window manager is in
+use then the coordinate system of the virtual root window is used).
+If no window in this application contains the point then an empty
+string is returned.
+In selecting the containing window, children are given higher priority
+than parents and among siblings the highest one in the stacking order is
+chosen.
+
+=item I<$widget>-E<gt>B<depth>
+
+Returns a decimal string giving the depth of I<$widget> (number
+of bits per pixel).
+
+=item I<$widget>-E<gt>B<destroy>
+
+This command deletes the window related to
+I<$widget>, plus all its descendants.
+If all the B<MainWindows> are deleted then the entire application
+will be destroyed.
+
+The perl object I<$widget> continues to exist while references
+to it still exist, e.g. until variable goes out of scope.
+However any attempt to use Tk methods on the object will fail.
+B<Exists>(I<$widget>) will return false on such objects.
+
+Note however that while a window exists for I<$widget> the
+perl object is maintained (due to "references" in perl/Tk internals)
+even though original variables may have gone out of scope.
+(Normally this is intuitive.)
+
+=item B<Exists>(I<$widget>)
+
+Returns 1 if there exists a window for I<$widget>, 0 if no such
+window exists.
+
+=item I<$widget>-E<gt>B<font>(I<option>?, I<arg, arg, ...>?)
+
+Create and inspect fonts. See L<Tk::Font> for further details.
+
+=item I<$widget>-E<gt>B<fpixels>(I<number>)
+
+Returns a floating-point value giving the number of pixels
+in I<$widget> corresponding to the distance given by I<number>.
+I<Number> may be specified in any of the forms acceptable
+to B<Tk_GetScreenMM>, such as ``2.0c'' or ``1i''.
+The return value may be fractional; for an integer value, use
+I<$widget>-E<gt>B<pixels>.
+
+=item I<$widget>-E<gt>B<Getimage>(I<name>)
+
+Given I<name>, look for an image file with that base name and return
+a L<Tk::Image>. File extensions are tried in this order: F<xpm>,
+F<gif>, F<ppm>, F<xbm> until a valid iamge is found. If no image is
+found, try a builtin image with that name.
+
+=item I<$widget>-E<gt>B<geometry>
+
+Returns the geometry for I<$widget>, in the form
+I<width>B<x>I<height>B<+>I<x>B<+>I<y>. All dimensions are
+in pixels.
+
+=item I<$widget>-E<gt>B<height>
+
+Returns a decimal string giving I<$widget>'s height in pixels.
+When a window is first created its height will be 1 pixel; the
+height will eventually be changed by a geometry manager to fulfill
+the window's needs.
+If you need the true height immediately after creating a widget,
+invoke B<update> to force the geometry manager to arrange it,
+or use I<$widget>-E<gt>B<reqheight> to get the window's requested height
+instead of its actual height.
+
+=item I<$widget>-E<gt>B<id>
+
+Returns a hexadecimal string giving a low-level platform-specific
+identifier for $widget. On Unix platforms, this is the X
+window identifier. Under Windows, this is the Windows
+HWND. On the Macintosh the value has no meaning outside Tk.
+
+=item I<$widget>-E<gt>B<idletasks>
+
+One of two methods which are used to bring the application ``up to date''
+by entering the event loop repeated until all pending events
+(including idle callbacks) have been processed.
+
+If the B<idletasks> method is specified, then no new events or errors
+are processed; only idle callbacks are invoked. This causes operations
+that are normally deferred, such as display updates and window layout
+calculations, to be performed immediately.
+
+The B<idletasks> command is useful in scripts where changes have been
+made to the application's state and you want those changes to appear
+on the display immediately, rather than waiting for the script to
+complete. Most display updates are performed as idle callbacks, so
+B<idletasks> will cause them to run. However, there are some kinds of
+updates that only happen in response to events, such as those
+triggered by window size changes; these updates will not occur in
+B<idletasks>.
+
+=item I<$widget>-E<gt>B<interps>
+
+Returns a list whose members are the names of all Tcl interpreters
+(e.g. all Tk-based applications) currently registered for
+a particular display.
+The return value refers
+to the display of I<$widget>.
+
+=item I<$widget>-E<gt>B<ismapped>
+
+Returns B<1> if I<$widget> is currently mapped, B<0> otherwise.
+
+=item I<$widget->>B<lower>(?I<belowThis>?)
+
+If the I<belowThis> argument is omitted then the command lowers
+$widget so that it is below all of its siblings in the stacking
+order (it will be obscured by any siblings that overlap it and
+will not obscure any siblings).
+If I<belowThis> is specified then it must be the path name of
+a window that is either a sibling of $widget or the descendant
+of a sibling of $widget.
+In this case the B<lower> command will insert
+$widget into the stacking order just below I<belowThis>
+(or the ancestor of I<belowThis> that is a sibling of $widget);
+this could end up either raising or lowering $widget.
+
+=item I<$widget>-E<gt>B<MapWindow>
+
+Cause I<$widget> to be "mapped" i.e. made visible on the display.
+May confuse the geometry manager (pack, grid, place, ...)
+that thinks it is managing the widget.
+
+=item I<$widget>-E<gt>B<manager>
+
+Returns the name of the geometry manager currently
+responsible for I<$widget>, or an empty string if I<$widget>
+isn't managed by any geometry manager.
+The name is usually the name of the method for the geometry
+manager, such as B<pack> or B<place>.
+If the geometry manager is a widget, such as canvases or text, the
+name is the widget's class command, such as B<canvas>.
+
+=item I<$widget>-E<gt>B<name>
+
+Returns I<$widget>'s name (i.e. its name within its parent, as opposed
+to its full path name).
+The command I<$mainwin>-E<gt>B<name> will return the name of the application.
+
+=item I<$widget>-E<gt>B<OnDestroy>(I<callback>);
+
+OnDestroy accepts a standard perl/Tk I<callback>.
+When the window associated with I<$widget> is destroyed then
+the callback is invoked. Unlike I<$widget->>bind('E<lt>DestroyE<gt>',...)
+the widgets methods are still available when I<callback> is executed,
+so (for example) a B<Text> widget can save its contents to a file.
+
+OnDestroy was required for new B<after> mechanism.
+
+=item I<$widget>-E<gt>B<parent>
+
+Returns I<$widget>'s parent, or an empty string
+if I<$widget> is the main window of the application.
+
+=item I<$widget>-E<gt>B<PathName>
+
+Returns the Tk path name of I<$widget>. This is the inverse of the
+L</Widget> method. (This is an import from the C interface.)
+
+=item I<$widget>-E<gt>B<pathname>(I<id>)
+
+Returns an object whose X identifier is I<id>.
+The identifier is looked up on the display of I<$widget>.
+I<Id> must be a decimal, hexadecimal, or octal integer and must
+correspond to a window in the invoking application, or an error
+occurs which can be trapped with C<eval { }> or C<Tk::catch { }>.
+If the window belongs to the application, but is not an object
+(for example wrapper windows, HList header, etc.) then C<undef>
+is returned.
+
+=item I<$widget>-E<gt>B<pixels>(I<number>)
+
+Returns the number of pixels in I<$widget> corresponding
+to the distance given by I<number>.
+I<Number> may be specified in any of the forms acceptable
+to B<Tk_GetPixels>, such as ``2.0c'' or ``1i''.
+The result is rounded to the nearest integer value; for a
+fractional result, use I<$widget>-E<gt>B<fpixels>.
+
+=item I<$widget>-E<gt>B<pointerx>
+
+If the mouse pointer is on the same screen as I<$widget>, returns the
+pointer's x coordinate, measured in pixels in the screen's root window.
+If a virtual root window is in use on the screen, the position is
+measured in the virtual root.
+If the mouse pointer isn't on the same screen as I<$widget> then
+-1 is returned.
+
+=item I<$widget>-E<gt>B<pointerxy>
+
+If the mouse pointer is on the same screen as I<$widget>, returns a list
+with two elements, which are the pointer's x and y coordinates measured
+in pixels in the screen's root window.
+If a virtual root window is in use on the screen, the position
+is computed in the virtual root.
+If the mouse pointer isn't on the same screen as I<$widget> then
+both of the returned coordinates are -1.
+
+=item I<$widget>-E<gt>B<pointery>
+
+If the mouse pointer is on the same screen as I<$widget>, returns the
+pointer's y coordinate, measured in pixels in the screen's root window.
+If a virtual root window is in use on the screen, the position
+is computed in the virtual root.
+If the mouse pointer isn't on the same screen as I<$widget> then
+-1 is returned.
+
+=item I<$widget>-E<gt>B<raise>(?I<aboveThis>?)
+
+If the I<aboveThis> argument is omitted then the command raises
+$widget so that it is above all of its siblings in the stacking
+order (it will not be obscured by any siblings and will obscure
+any siblings that overlap it).
+If I<aboveThis> is specified then it must be the path name of
+a window that is either a sibling of $widget or the descendant
+of a sibling of $widget.
+In this case the B<raise> command will insert
+$widget into the stacking order just above I<aboveThis>
+(or the ancestor of I<aboveThis> that is a sibling of $widget);
+this could end up either raising or lowering $widget.
+
+=item I<$widget>-E<gt>B<reqheight>
+
+Returns a decimal string giving I<$widget>'s requested height,
+in pixels. This is the value used by I<$widget>'s geometry
+manager to compute its geometry.
+
+=item I<$widget>-E<gt>B<reqwidth>
+
+Returns a decimal string giving I<$widget>'s requested width,
+in pixels. This is the value used by I<$widget>'s geometry
+manager to compute its geometry.
+
+=item I<$widget>-E<gt>B<rgb>(I<color>)
+
+Returns a list containing three decimal values, which are the
+red, green, and blue intensities that correspond to I<color> in
+the window given by I<$widget>. I<Color>
+may be specified in any of the forms acceptable for a color
+option.
+
+=item I<$widget>-E<gt>B<rootx>
+
+Returns a decimal string giving the x-coordinate, in the root
+window of the screen, of the
+upper-left corner of I<$widget>'s border (or I<$widget> if it
+has no border).
+
+=item I<$widget>-E<gt>B<rooty>
+
+Returns a decimal string giving the y-coordinate, in the root
+window of the screen, of the
+upper-left corner of I<$widget>'s border (or I<$widget> if it
+has no border).
+
+=item I<$widget>-E<gt>B<scaling>?(I<number>)?
+
+Sets and queries the current scaling factor used by Tk to convert between
+physical units (for example, points, inches, or millimeters) and pixels. The
+I<number> argument is a floating point number that specifies the number of
+pixels per point on $widget's display. If the I<number> argument is
+omitted, the current value of the scaling factor is returned.
+
+A ``point'' is a unit of measurement equal to 1/72 inch. A scaling factor
+of 1.0 corresponds to 1 pixel per point, which is equivalent to a standard
+72 dpi monitor. A scaling factor of 1.25 would mean 1.25 pixels per point,
+which is the setting for a 90 dpi monitor; setting the scaling factor to
+1.25 on a 72 dpi monitor would cause everything in the application to be
+displayed 1.25 times as large as normal. The initial value for the scaling
+factor is set when the application starts, based on properties of the
+installed monitor (as reported via the window system),
+but it can be changed at any time. Measurements made
+after the scaling factor is changed will use the new scaling factor, but it
+is undefined whether existing widgets will resize themselves dynamically to
+accomodate the new scaling factor.
+
+=item I<$widget>-E<gt>B<screen>
+
+Returns the name of the screen associated with I<$widget>, in
+the form I<displayName>.I<screenIndex>.
+
+=item I<$widget>-E<gt>B<screencells>
+
+Returns a decimal string giving the number of cells in the default
+color map for I<$widget>'s screen.
+
+=item I<$widget>-E<gt>B<screendepth>
+
+Returns a decimal string giving the depth of the root window
+of I<$widget>'s screen (number of bits per pixel).
+
+=item I<$widget>-E<gt>B<screenheight>
+
+Returns a decimal string giving the height of I<$widget>'s screen,
+in pixels.
+
+=item I<$widget>-E<gt>B<screenmmheight>
+
+Returns a decimal string giving the height of I<$widget>'s screen,
+in millimeters.
+
+=item I<$widget>-E<gt>B<screenmmwidth>
+
+Returns a decimal string giving the width of I<$widget>'s screen,
+in millimeters.
+
+=item I<$widget>-E<gt>B<screenvisual>
+
+Returns one of the following strings to indicate the default visual
+class for I<$widget>'s screen: B<directcolor>, B<grayscale>,
+B<pseudocolor>, B<staticcolor>, B<staticgray>, or
+B<truecolor>.
+
+=item I<$widget>-E<gt>B<screenwidth>
+
+Returns a decimal string giving the width of I<$widget>'s screen,
+in pixels.
+
+=item I<$widget>-E<gt>B<server>
+
+Returns a string containing information about the server for
+I<$widget>'s display. The exact format of this string may vary
+from platform to platform. For X servers the string
+has the form ``B<X>I<major>B<R>I<minor vendor vendorVersion>''
+where I<major> and I<minor> are the version and revision
+numbers provided by the server (e.g., B<X11R5>), I<vendor>
+is the name of the vendor for the server, and I<vendorRelease>
+is an integer release number provided by the server.
+
+=item I<$widget>-E<gt>B<toplevel>
+
+Returns the reference of the top-level window containing I<$widget>.
+
+=item I<$widget>-E<gt>B<Unbusy>
+
+Restores widget state after a call to I<$widget>-E<gt>B<Busy>.
+
+=item I<$widget>-E<gt>B<UnmapWindow>
+
+Cause I<$widget> to be "unmapped" i.e. removed from the display.
+This does for any widget what I<$widget>-E<gt>withdraw does for
+toplevel widgets. May confuse the geometry manager (pack, grid, place, ...)
+that thinks it is managing the widget.
+
+=item I<$widget>-E<gt>B<update>
+
+One of two methods which are used to bring the application ``up to date''
+by entering the event loop repeated until all pending events
+(including idle callbacks) have been processed.
+
+The B<update> method is useful in scripts where you are performing a
+long-running computation but you still want the application to respond
+to events such as user interactions; if you occasionally call
+B<update> then user input will be processed during the next call to
+B<update>.
+
+=item I<$widget>-E<gt>B<useinputmethods>( ?I<boolean>? )
+
+Sets and queries the state of whether Tk should use XIM (X Input
+Methods) for filtering events. The resulting state is returned.
+XIM is used in some locales (ie: Japanese, Korean), to handle
+special input devices. This feature is only significant on X.
+If XIM support is not available, this will always return 0.
+If the boolean argument is omitted, the current state is
+returned. This is turned on by default for the main display.
+
+=item I<$widget>-E<gt>B<viewable>
+
+Returns 1 if I<$widget> and all of its ancestors up through the
+nearest toplevel window are mapped. Returns 0 if any of these
+windows are not mapped.
+
+=item I<$widget>-E<gt>B<visual>
+
+Returns one of the following strings to indicate the visual
+class for I<$widget>: B<directcolor>, B<grayscale>,
+B<pseudocolor>, B<staticcolor>, B<staticgray>, or
+B<truecolor>.
+
+=item I<$widget>-E<gt>B<visualid>
+
+Returns the X identifier for the visual for $widget.
+
+=item I<$widget>-E<gt>B<visualsavailable>(?B<includeids>?)
+
+Returns a list whose elements describe the visuals available for
+I<$widget>'s screen.
+Each element consists of a visual class followed by an integer depth.
+The class has the same form as returned by I<$widget>-E<gt>B<visual>.
+The depth gives the number of bits per pixel in the visual.
+In addition, if the B<includeids> argument is provided, then the
+depth is followed by the X identifier for the visual.
+
+=item I<$widget>-E<gt>B<vrootheight>
+
+Returns the height of the virtual root window associated with I<$widget>
+if there is one; otherwise returns the height of I<$widget>'s screen.
+
+=item I<$widget>-E<gt>B<vrootwidth>
+
+Returns the width of the virtual root window associated with I<$widget>
+if there is one; otherwise returns the width of I<$widget>'s screen.
+
+=item I<$widget>-E<gt>B<vrootx>
+
+Returns the x-offset of the virtual root window associated with I<$widget>,
+relative to the root window of its screen.
+This is normally either zero or negative.
+Returns 0 if there is no virtual root window for I<$widget>.
+
+=item I<$widget>-E<gt>B<vrooty>
+
+Returns the y-offset of the virtual root window associated with I<$widget>,
+relative to the root window of its screen.
+This is normally either zero or negative.
+Returns 0 if there is no virtual root window for I<$widget>.
+
+=item I<$widget->>B<waitVariable>(\$I<name>)
+
+=item I<$widget->>B<waitVisibility>
+
+=item I<$widget->>B<waitWindow>
+
+The B<tk wait> methods wait for one of several things to happen,
+then it returns without taking any other actions.
+The return value is always an empty string.
+B<waitVariable> expects a reference to a perl
+variable and the command waits for that variable to be modified.
+This form is typically used to wait for a user to finish interacting
+with a dialog which sets the variable as part (possibly final)
+part of the interaction.
+B<waitVisibility> waits for a change in I<$widget>'s
+visibility state (as indicated by the arrival of a VisibilityNotify
+event). This form is typically used to wait for a newly-created
+window to appear on the screen before taking some action.
+B<waitWindow> waits for I<$widget> to be destroyed.
+This form is typically used to wait for a user to finish interacting
+with a dialog box before using the result of that interaction.
+Note that creating and destroying the window each time a dialog is required
+makes code modular but imposes overhead which can be avoided by B<withdrawing>
+the window instead and using B<waitVisibility>.
+
+While the B<tk wait> methods are waiting they processes events in
+the normal fashion, so the application will continue to respond
+to user interactions.
+If an event handler invokes B<tkwait> again, the nested call
+to B<tkwait> must complete before the outer call can complete.
+
+=item I<$widget>-E<gt>B<Walk>(I<proc>?, I<arg, ...>?)
+
+Traverse a widget hierarchy starting at I<$widget> while executing the
+subroutine I<proc> to every visited widget. The arguments I<arg, ...>
+are supplied to the subroutine.
+
+=item I<$widget>-E<gt>B<Widget>(I<pathname>)
+
+Returns the widget reference for the given Tk path name, or C<undef>
+if the path name does not match a Tk widget. This is the inverse of
+the L</PathName> method. (This is an import from the C interface.)
+
+=item I<$widget>-E<gt>B<width>
+
+Returns a decimal string giving I<$widget>'s width in pixels.
+When a window is first created its width will be 1 pixel; the
+width will eventually be changed by a geometry manager to fulfill
+the window's needs.
+If you need the true width immediately after creating a widget,
+invoke B<update> to force the geometry manager to arrange it,
+or use I<$widget>-E<gt>B<reqwidth> to get the window's requested width
+instead of its actual width.
+
+=item I<$widget>-E<gt>B<windowingsystem>
+
+Returns the current Tk windowing system, one of B<x11> (X11-based),
+B<win32> (MS Windows), B<classic> (Mac OS Classic), or B<aqua> (Mac OS X Aqua).
+
+=item I<$widget>-E<gt>B<x>
+
+Returns a decimal string giving the x-coordinate, in I<$widget>'s
+parent, of the upper-left corner of I<$widget>'s border (or I<$widget>
+if it has no border).
+
+=item I<$widget>-E<gt>B<y>
+
+Returns a decimal string giving the y-coordinate, in I<$widget>'s
+parent, of the
+upper-left corner of I<$widget>'s border (or I<$widget> if it
+has no border).
+
+=back
+
+=head1 CAVEATS
+
+The above documentaion on generic methods is incomplete.
+
+=head1 KEYWORDS
+
+atom, children, class, geometry, height, identifier, information, interpreters,
+mapped, parent, path name, screen, virtual root, width, window
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/WidgetDemo.pod b/Master/tlpkg/tlperl.straw/lib/Tk/WidgetDemo.pod
new file mode 100755
index 00000000000..32c7a101dc6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/WidgetDemo.pod
@@ -0,0 +1,59 @@
+
+=head1 NAME
+
+WidgetDemo() - create a standard widget demonstration window.
+
+=for pm demos/demos/widget_lib/WidgetDemo.pm
+
+=for category Implementation
+
+=head1 SYNOPSIS
+
+ use WidgetDemo;
+ my $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Learn how to write a widget demonstration!',
+ -title => 'WidgetDemo Demonstration',
+ -iconname => 'WidgetDemo',
+ -geometry_manager => 'grid',
+ -font => $FONT,
+ );
+
+=head1 DESCRIPTION
+
+This constructor builds a standard widget demonstration window, composed of
+three frames. The top frame contains descriptive demonstration text. The
+bottom frame contains the "Dismiss" and "See Code" buttons. The middle frame
+is demonstration container, which came be managed by either the pack or grid
+geometry manager.
+
+The -text attribute is supplied to a Label widget, which is left-adjusted
+with -wraplength set to 4 inches. If you require different specifications
+then pass an array to -text; the first element is the text string and
+the remaining array elements are standard Label widget attributes - WidgetDemo
+will rearrange things as required..
+
+ -text => ['Hello World!', qw/-wraplength 6i/],
+
+=head1 AUTHOR
+
+Steve Lidie <Stephen.O.Lidie@Lehigh.EDU>
+
+=head1 HISTORY
+
+lusol@Lehigh.EDU, LUCC, 97/02/11
+lusol@Lehigh.EDU, LUCC, 97/06/07
+Stephen.O.Lidie@Lehigh.EDU, LUCC, 97/06/07
+ . Add Delegates() call that obviates the need for Top(). Many thanks to
+ Achim Bohnet for this patch.
+ . Fix -title so that it works.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1997 - 1998 Stephen O. Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Wm.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Wm.pm
new file mode 100755
index 00000000000..113bf951a15
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Wm.pm
@@ -0,0 +1,174 @@
+# Copyright (c) 1995-2003 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.
+package Tk::Wm;
+use AutoLoader;
+
+require Tk::Widget;
+*AUTOLOAD = \&Tk::Widget::AUTOLOAD;
+
+use strict qw(vars);
+
+# There are issues with this stuff now we have Tix's wm release/capture
+# as toplevel-ness is now dynamic.
+
+
+use vars qw($VERSION);
+$VERSION = '4.015'; # was: sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Submethods;
+
+*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) };
+*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) };
+
+Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command
+ deiconify focusmodel frame geometry group
+ iconbitmap iconify iconimage iconmask iconname iconphoto
+ iconwindow maxsize minsize overrideredirect positionfrom
+ protocol resizable sizefrom stackorder state title transient
+ withdraw wrapper)]);
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,'all']);
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef],
+ '-popanchor' => ['PASSIVE',undef,undef,undef],
+ '-popover' => ['PASSIVE',undef,undef,undef]
+ );
+}
+
+sub MoveResizeWindow
+{
+ my ($w,$x,$y,$width,$height) = @_;
+ $w->withdraw;
+ $w->geometry($width.'x'.$height);
+ $w->MoveToplevelWindow($x,$y);
+ $w->deiconify;
+}
+
+sub WmDeleteWindow
+{
+ my ($w) = @_;
+ my $cb = $w->protocol('WM_DELETE_WINDOW');
+ if (defined $cb)
+ {
+ $cb->Call;
+ }
+ else
+ {
+ $w->destroy;
+ }
+}
+
+
+1;
+
+__END__
+
+
+sub Post
+{
+ my ($w,$X,$Y) = @_;
+ $X = int($X);
+ $Y = int($Y);
+ $w->positionfrom('user');
+ $w->geometry("+$X+$Y");
+ # $w->MoveToplevelWindow($X,$Y);
+ $w->deiconify;
+ $w->raise;
+}
+
+sub AnchorAdjust
+{
+ my ($anchor,$X,$Y,$w,$h) = @_;
+ $anchor = 'c' unless (defined $anchor);
+ $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
+ $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
+ return ($X,$Y);
+}
+
+sub Popup
+{
+ my $w = shift;
+ $w->configure(@_) if @_;
+ $w->idletasks;
+ my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
+ my ($rx,$ry,$rw,$rh) = (0,0,0,0);
+ my $base = $w->cget('-popover');
+ my $outside = 0;
+ if (defined $base)
+ {
+ if ($base eq 'cursor')
+ {
+ ($rx,$ry) = $w->pointerxy;
+ }
+ else
+ {
+ $rx = $base->rootx;
+ $ry = $base->rooty;
+ $rw = $base->Width;
+ $rh = $base->Height;
+ }
+ }
+ else
+ {
+ my $sc = ($w->parent) ? $w->parent->toplevel : $w;
+ $rx = -$sc->vrootx;
+ $ry = -$sc->vrooty;
+ $rw = $w->screenwidth;
+ $rh = $w->screenheight;
+ }
+ my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
+ ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
+ # adjust to not cross screen borders
+ if ($X < 0) { $X = 0 }
+ if ($Y < 0) { $Y = 0 }
+ if ($mw > $w->screenwidth) { $X = 0 }
+ if ($mh > $w->screenheight) { $Y = 0 }
+ $w->Post($X,$Y);
+ $w->waitVisibility;
+}
+
+sub FullScreen
+{
+ my $w = shift;
+ my $over = (@_) ? shift : 0;
+ my $width = $w->screenwidth;
+ my $height = $w->screenheight;
+ $w->GeometryRequest($width,$height);
+ $w->overrideredirect($over & 1);
+ $w->Post(0,0);
+ $w->update;
+ if ($over & 2)
+ {
+ my $x = $w->rootx;
+ my $y = $w->rooty;
+ $width -= 2*$x;
+ $height -= $x + $y;
+ $w->GeometryRequest($width,$height);
+ $w->update;
+ }
+}
+
+sub iconposition
+{
+ my $w = shift;
+ if (@_ == 1)
+ {
+ return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
+ if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
+ {
+ my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
+ my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
+ return $w->wm('iconposition',$x,$y);
+ }
+ }
+ $w->wm('iconposition',@_);
+}
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Wm.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Wm.pod
new file mode 100755
index 00000000000..841ca1bc4ac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Wm.pod
@@ -0,0 +1,668 @@
+# Copyright (c) 1991-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Wm - Communicate with window manager
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+S< >I<$toplevel>-E<gt>I<method>(?I<args>?)
+
+=head1 DESCRIPTION
+
+The B<wm> methods are used to interact with window managers in
+order to control such things as the title for a window, its geometry,
+or the increments in terms of which it may be resized.
+The B<wm> methods can take any of a number of different forms, depending on
+the particular I<method> argument.
+All of the forms expect I<$toplevel>, which must be a
+top-level window object.
+
+The legal forms for the B<wm> methods are:
+
+=over 4
+
+=item I<$toplevel>-E<gt>B<aspect>(?I<minNumer minDenom maxNumer maxDenom>?)
+
+If I<minNumer>, I<minDenom>, I<maxNumer>, and I<maxDenom>
+are all specified, then they will be passed to the window manager
+and the window manager should use them to enforce a range of
+acceptable aspect ratios for I<$toplevel>. The aspect ratio of
+I<$toplevel> (width/length) will be constrained to lie
+between I<minNumer>/I<minDenom> and I<maxNumer>/I<maxDenom>.
+If I<minNumer> etc. are all specified as empty strings, then
+any existing aspect ratio restrictions are removed.
+If I<minNumer> etc. are specified, then the method returns an
+empty string. Otherwise, it returns
+a array containing four elements, which are the current values
+of I<minNumer>, I<minDenom>, I<maxNumer>, and I<maxDenom>
+(if no aspect restrictions are in effect, then an empty string is
+returned).
+
+=item I<$widget>-E<gt>B<attributes>( I<?args?> );
+
+This subcommand returns or sets platform specific attributes
+associated with a window.
+
+=over 4
+
+=item I<$widget>-E<gt>B<attributes>;
+
+Returns a list of the platform specific flags and their values.
+
+=item I<$widget>-E<gt>B<attributes>( I<?option?> );
+
+Returns the value for the specific option.
+
+=item I<$widget>-E<gt>B<attributes>( I<?option value option value...?> );
+
+Sets one or more of the values. The values are as follows:
+
+On Windows, -disabled gets or sets whether the window is in a
+disabled state. -toolwindow gets or sets the style of the window
+to toolwindow (as defined in the MSDN). -topmost gets or sets
+whether this is a topmost window (displays above all other win-
+dows).
+
+On Macintosh, there are currently no special attribute values.
+
+On Unix, there are currently no special attribute values.
+
+=back
+
+=item I<$toplevel>-E<gt>B<client>(?I<name>?)
+
+If I<name> is specified, this method stores I<name> (which
+should be the name of
+the host on which the application is executing) in I<$toplevel>'s
+B<WM_CLIENT_MACHINE> property for use by the window manager or
+session manager.
+The method returns an empty string in this case.
+If I<name> isn't specified, the method returns the last name
+set in a B<client> method for I<$toplevel>.
+If I<name> is specified as an empty string, the method deletes the
+B<WM_CLIENT_MACHINE> property from I<$toplevel>.
+
+=item I<$toplevel>-E<gt>B<colormapwindows>(?I<windowList>?)
+
+This method is used to manipulate the B<WM_COLORMAP_WINDOWS>
+property, which provides information to the window managers about
+windows that have private colormaps.
+If I<windowList> isn't specified, the method returns a list
+whose elements are the names of the windows in the B<WM_COLORMAP_WINDOWS>
+property.
+If I<windowList> is specified, it consists of a list of widgets;
+the method overwrites the B<WM_COLORMAP_WINDOWS>
+property with the given windows and returns an empty string.
+The B<WM_COLORMAP_WINDOWS> property should normally contain a
+list of the internal windows within I<$toplevel> whose colormaps differ
+from their parents.
+The order of the windows in the property indicates a priority order:
+the window manager will attempt to install as many colormaps as possible
+from the head of this list when I<$widget> gets the colormap focus.
+If I<$widget> is not included among the windows in I<windowList>,
+Tk implicitly adds it at the end of the B<WM_COLORMAP_WINDOWS>
+property, so that its colormap is lowest in priority.
+If I<$widget>-E<gt>colormapwindows is not invoked, Tk will automatically set
+the property for each top-level window to all the internal windows
+whose colormaps differ from their parents, followed by the top-level
+itself; the order of the internal windows is undefined.
+See the ICCCM documentation for more information on the
+B<WM_COLORMAP_WINDOWS> property.
+
+=item I<$toplevel>-E<gt>B<command>(?I<value>?)
+
+If I<value> is specified, this method stores I<value> in I<$toplevel>'s
+B<WM_COMMAND> property for use by the window manager or
+session manager and returns an empty string.
+I<Value> must have proper list structure; the elements should
+contain the words of the command used to invoke the application.
+If I<value> isn't specified then the method returns the last value
+set in a B<command> method for I<$toplevel>.
+If I<value> is specified as an empty string, the method
+deletes the B<WM_COMMAND> property from I<$toplevel>.
+
+=item I<$toplevel>-E<gt>B<deiconify>
+
+Arrange for I<$toplevel> to be displayed in normal (non-iconified) form.
+This is done by mapping the window. If the window has never been
+mapped then this method will not map the window, but it will ensure
+that when the window is first mapped it will be displayed
+in de-iconified form. Returns an empty string.
+
+=item I<$toplevel>-E<gt>B<focusmodel>(?B<active>|B<passive>?)
+
+If B<active> or B<passive> is supplied as an optional argument
+to the method, then it specifies the focus model for I<$toplevel>.
+In this case the method returns an empty string. If no additional
+argument is supplied, then the method returns the current focus
+model for I<$toplevel>.
+An B<active> focus model means that I<$toplevel> will claim the
+input focus for itself or its descendants, even at times when
+the focus is currently in some other application. B<Passive> means that
+I<$toplevel> will never claim the focus for itself: the window manager
+should give the focus to I<$toplevel> at appropriate times. However,
+once the focus has been given to I<$toplevel> or one of its descendants,
+the application may re-assign the focus among I<$toplevel>'s descendants.
+The focus model defaults to B<passive>, and Tk's B<focus> method
+assumes a passive model of focusing.
+
+=item I<$toplevel>-E<gt>B<frame>
+
+If I<$widget> has been reparented by the window manager into a
+decorative frame, the method returns the platform specific window
+identifier for the outermost frame that contains I<$toplevel> (the
+window whose parent is the root or virtual root). If I<$toplevel>
+hasn't been reparented by the window manager then the method returns
+the platform specific window identifier for I<$toplevel>.
+
+=item I<$toplevel>-E<gt>B<geometry>(?I<newGeometry>?)
+
+If I<newGeometry> is specified, then the geometry of I<$toplevel>
+is changed and an empty string is returned. Otherwise the current
+geometry for I<$toplevel> is returned (this is the most recent
+geometry specified either by manual resizing or
+in a B<geometry> method). I<NewGeometry> has
+the form B<=>I<width>B<x>I<height>B<+->I<x>B<+->I<y>, where
+any of B<=>, I<width>B<x>I<height>, or B<+->I<x>B<+->I<y>
+may be omitted. I<Width> and I<height> are positive integers
+specifying the desired dimensions of I<$toplevel>. If I<$toplevel>
+is gridded (see L<"GRIDDED GEOMETRY MANAGEMENT"> below) then the dimensions
+are specified in grid units; otherwise they are specified in pixel
+units. I<X> and I<y> specify the desired location of
+I<$toplevel> on the screen, in pixels.
+If I<x> is preceded by B<+>, it specifies
+the number of pixels between the left edge of the screen and the left
+edge of I<$toplevel>'s border; if preceded by B<-> then
+I<x> specifies the number of pixels
+between the right edge of the screen and the right edge of I<$toplevel>'s
+border. If I<y> is preceded by B<+> then it specifies the
+number of pixels between the top of the screen and the top
+of I<$toplevel>'s border; if I<y> is preceded by B<-> then
+it specifies the number of pixels between the bottom of I<$toplevel>'s
+border and the bottom of the screen.
+If I<newGeometry> is specified as an empty string then any
+existing user-specified geometry for I<$toplevel> is cancelled, and
+the window will revert to the size requested internally by its
+widgets.
+
+=item I<$toplevel>-E<gt>B<wmGrid>(?I<baseWidth,baseHeight,widthInc,heightInc>?)
+
+This method indicates that I<$toplevel> is to be managed as a
+gridded window.
+It also specifies the relationship between grid units and pixel units.
+I<BaseWidth> and I<baseHeight> specify the number of grid
+units corresponding to the pixel dimensions requested internally
+by I<$toplevel> using B<Tk_GeometryRequest>. I<WidthInc>
+and I<heightInc> specify the number of pixels in each horizontal
+and vertical grid unit.
+These four values determine a range of acceptable sizes for
+I<$toplevel>, corresponding to grid-based widths and heights
+that are non-negative integers.
+Tk will pass this information to the window manager; during
+manual resizing, the window manager will restrict the window's size
+to one of these acceptable sizes.
+Furthermore, during manual resizing the window manager will display
+the window's current size in terms of grid units rather than pixels.
+If I<baseWidth> etc. are all specified as empty strings, then
+I<$toplevel> will no longer be managed as a gridded window. If
+I<baseWidth> etc. are specified then the return value is an
+empty string.
+Otherwise the return value is a array containing
+four elements corresponding to the current I<baseWidth>,
+I<baseHeight>, I<widthInc>, and I<heightInc>; if
+I<$toplevel> is not currently gridded, then an empty string
+is returned.
+Note: this command should not be needed very often, since the
+B<Tk_SetGrid> library procedure and the B<-setgrid> option
+provide easier access to the same functionality.
+
+=item I<$toplevel>-E<gt>B<group>(?I<$widget>?)
+
+If I<$widget> is specified, it is the the leader of
+a group of related windows. The window manager may use this information,
+for example, to unmap all of the windows in a group when the group's
+leader is iconified. I<$widget> may be specified as an empty string to
+remove I<$toplevel> from any group association. If I<$widget> is
+specified then the method returns an empty string; otherwise it
+returns the I<$toplevel>'s current group leader, or an empty
+string if I<$toplevel> isn't part of any group.
+
+=item I<$toplevel>-E<gt>B<iconbitmap>(?I<bitmap>?)
+
+If I<bitmap> is specified, then it names a bitmap in the standard
+forms accepted by Tk (see the B<Tk_GetBitmap> documentation for details).
+This I<black and white> bitmap is passed to the window manager to be displayed
+in I<$toplevel>'s icon, and the method returns an empty string. If
+an empty string is specified for I<bitmap>, then any current icon
+bitmap or image is cancelled for I<$toplevel>.
+If I<bitmap> is specified then the method returns an empty string.
+Otherwise it returns the name of
+the current icon bitmap associated with I<$toplevel>, or an empty
+string if I<$toplevel> has no icon bitmap.
+
+=item I<$toplevel>-E<gt>B<iconify>
+
+Arrange for I<$toplevel> to be iconified. It I<$toplevel> hasn't
+yet been mapped for the first time, this method will arrange for
+it to appear in the iconified state when it is eventually mapped.
+
+=item I<$toplevel>-E<gt>B<iconimage>(?I<image>?)
+
+If I<image> is specified, then it names a normal Tk image.
+This image is rendered into a private I<coloured> bitmap which is passed to
+the window manager to be displayed in I<$toplevel>'s icon, and the method returns
+an empty string. If an empty string is specified for I<image>, then any current
+icon bitmap or image is cancelled for I<$toplevel>.
+If I<image> is specified then the method returns an empty string.
+Otherwise it returns the name of
+the current icon image associated with I<$toplevel>, or an empty
+string if I<$toplevel> has no icon image.
+The private pixmap is not pre-cleared so images which are partly "transparent"
+display rubbish in their transparent parts.
+
+The sizes of images that can be used as icons in this manner are platform
+dependant. On Win32 this sets the "large" icon, which should be 32x32, it
+will automatically be scaled down to 16x16 for use as a small icon.
+
+=item I<$toplevel>-E<gt>B<iconmask>(?I<bitmap>?)
+
+If I<bitmap> is specified, then it names a bitmap in the standard
+forms accepted by Tk (see the B<Tk_GetBitmap> documentation for details).
+This bitmap is passed to the window manager to be used as a mask
+in conjunction with the B<iconbitmap> option: where the mask
+has zeroes no icon will be displayed; where it has ones, the bits
+from the icon bitmap will be displayed. If
+an empty string is specified for I<bitmap> then any current icon
+mask is cancelled for I<$toplevel> (this is equivalent to specifying
+a bitmap of all ones). If I<bitmap> is specified
+then the method returns an empty string. Otherwise it
+returns the name of the current icon mask associated with
+I<$toplevel>, or an empty string if no mask is in effect.
+
+=item I<$toplevel>-E<gt>B<iconname>(?I<newName>?)
+
+If I<newName> is specified, then it is passed to the window
+manager; the window manager should display I<newName> inside
+the icon associated with I<$toplevel>. In this case an empty
+string is returned as result. If I<newName> isn't specified
+then the method returns the current icon name for I<$toplevel>,
+or an empty string if no icon name has been specified (in this
+case the window manager will normally display the window's title,
+as specified with the B<title> method).
+
+=item I<$toplevel>-E<gt>B<iconphoto>(?-default? I<image1> ?I<image2>
+...?)
+
+Sets the titlebar icon for window based on the named photo
+images. If -default is specified, this is applied to all future
+created toplevels as well. The data in the images is taken as a
+snapshot at the time of invocation. If the images are later
+changed, this is not reflected to the titlebar icons. Multiple
+images are accepted to allow different images sizes (eg, 16x16
+and 32x32) to be provided. The window manager may scale pro-
+vided icons to an appropriate size.
+
+On Windows, the images are packed into a Windows icon structure.
+This will override an ico specified to wm iconbitmap, and vice
+versa. [NOTE: This is not implemented yet!]
+
+On X, the images are arranged into the _NET_WM_ICON X property,
+which most modern window managers support. A wm iconbitmap may
+exist simultaneously. It is recommended to use not more than 2
+icons, placing the larger icon first.
+
+On Macintosh, this is currently does nothing.
+
+=item I<$toplevel>-E<gt>B<iconposition>(?I<x y>?)
+
+If I<x> and I<y> are specified, they are passed to the window
+manager as a hint about where to position the icon for I<$toplevel>.
+In this case an empty string is returned. If I<x> and I<y> are
+specified as empty strings then any existing icon position hint is cancelled.
+If neither I<x> nor I<y> is specified, then the method returns
+a array containing two values, which are the current icon position
+hints (if no hints are in effect then an empty string is returned).
+
+=item I<$toplevel>-E<gt>B<iconwindow>(?I<$widget>?)
+
+If I<$widget> is specified, it is a window to
+use as icon for I<$toplevel>: when I<$toplevel> is iconified then
+I<$widget> will be mapped to serve as icon, and when I<$toplevel>
+is de-iconified then I<$widget> will be unmapped again. If
+I<$widget> is specified as an empty string then any existing
+icon window association for I<$toplevel> will be cancelled. If
+the I<$widget> argument is specified then an empty string is
+returned. Otherwise the method returns the
+current icon window for I<$toplevel>, or an empty string if there
+is no icon window currently specified for I<$toplevel>.
+Button press events are disabled for I<$toplevel> as long as it is
+an icon window; this is needed in order to allow window managers
+to ``own'' those events.
+Note: not all window managers support the notion of an icon window.
+
+=item I<$toplevel>-E<gt>B<maxsize>(?I<width,height>?)
+
+If I<width> and I<height> are specified, they give
+the maximum permissible dimensions for I<$toplevel>.
+For gridded windows the dimensions are specified in
+grid units; otherwise they are specified in pixel units.
+The window manager will restrict the window's dimensions to be
+less than or equal to I<width> and I<height>.
+If I<width> and I<height> are
+specified, then the method returns an empty string. Otherwise
+it returns a array with two elements, which are the
+maximum width and height currently in effect.
+The maximum size defaults to the size of the screen.
+If resizing has been disabled with the B<resizable> method,
+then this method has no effect.
+See the sections on geometry management below for more information.
+
+=item I<$toplevel>-E<gt>B<minsize>(?I<width,height>?)
+
+If I<width> and I<height> are specified, they give the
+minimum permissible dimensions for I<$toplevel>.
+For gridded windows the dimensions are specified in
+grid units; otherwise they are specified in pixel units.
+The window manager will restrict the window's dimensions to be
+greater than or equal to I<width> and I<height>.
+If I<width> and I<height> are
+specified, then the method returns an empty string. Otherwise
+it returns a array with two elements, which are the
+minimum width and height currently in effect.
+The minimum size defaults to one pixel in each dimension.
+If resizing has been disabled with the B<resizable> method,
+then this method has no effect.
+See the sections on geometry management below for more information.
+
+=item I<$toplevel>-E<gt>B<overrideredirect(?>I<boolean>?)
+
+If I<boolean> is specified, it must have a proper boolean form and
+the override-redirect flag for I<$toplevel> is set to that value.
+If I<boolean> is not specified then B<1> or B<0> is
+returned to indicate whether or not the override-redirect flag
+is currently set for I<$toplevel>.
+Setting the override-redirect flag for a window causes
+it to be ignored by the window manager; among other things, this means
+that the window will not be reparented from the root window into a
+decorative frame and the user will not be able to manipulate the
+window using the normal window manager mechanisms.
+
+=item I<$toplevel>-E<gt>B<positionfrom>(?I<who>?)
+
+If I<who> is specified, it must be either B<program> or
+B<user>, or an abbreviation of one of these two. It indicates
+whether I<$toplevel>'s current position was requested by the
+program or by the user. Many window managers ignore program-requested
+initial positions and ask the user to manually position the window; if
+B<user> is specified then the window manager should position the
+window at the given place without asking the user for assistance.
+If I<who> is specified as an empty string, then the current position
+source is cancelled.
+If I<who> is specified, then the method returns an empty string.
+Otherwise it returns B<user> or $widget to indicate the
+source of the window's current position, or an empty string if
+no source has been specified yet. Most window managers interpret
+``no source'' as equivalent to B<program>.
+Tk will automatically set the position source to B<user>
+when a B<geometry> method is invoked, unless the source has
+been set explicitly to B<program>.
+
+=item I<$toplevel>-E<gt>B<protocol>(?I<name>?,?I<callback>?)
+
+This method is used to manage window manager protocols such as
+B<WM_DELETE_WINDOW>.
+I<Name> is the name of an atom corresponding to a window manager
+protocol, such as B<WM_DELETE_WINDOW> or B<WM_SAVE_YOURSELF>
+or B<WM_TAKE_FOCUS>.
+If both I<name> and I<callback> are specified, then I<callback>
+is associated with the protocol specified by I<name>.
+I<Name> will be added to I<$toplevel>'s B<WM_PROTOCOLS>
+property to tell the window manager that the application has a
+protocol handler for I<name>, and I<callback> will
+be invoked in the future whenever the window manager sends a
+message to the client for that protocol.
+In this case the method returns an empty string.
+If I<name> is specified but I<callback> isn't, then the current
+callback for I<name> is returned, or an empty string if there
+is no handler defined for I<name>.
+If I<callback> is specified as an empty string then the current
+handler for I<name> is deleted and it is removed from the
+B<WM_PROTOCOLS> property on I<$toplevel>; an empty string is
+returned.
+Lastly, if neither I<name> nor I<callback> is specified, the
+method returns a list of all the protocols for which handlers
+are currently defined for I<$toplevel>.
+
+=over 8
+
+Tk always defines a protocol handler for B<WM_DELETE_WINDOW>, even if
+you haven't asked for one with B<protocol>.
+If a B<WM_DELETE_WINDOW> message arrives when you haven't defined
+a handler, then Tk handles the message by destroying the window for
+which it was received.
+
+=back
+
+=item I<$toplevel>-E<gt>B<resizable>(?I<width,height>?)
+
+This method controls whether or not the user may interactively
+resize a top-level window. If I<width> and I<height> are
+specified, they are boolean values that determine whether the
+width and height of I<$toplevel> may be modified by the user.
+In this case the method returns an empty string.
+If I<width> and I<height> are omitted then the method
+returns a list with two 0/1 elements that indicate whether the
+width and height of I<$toplevel> are currently resizable.
+By default, windows are resizable in both dimensions.
+If resizing is disabled, then the window's size will be the size
+from the most recent interactive resize or B<geometry>
+method. If there has been no such operation then
+the window's natural size will be used.
+
+=item I<$toplevel>-E<gt>B<sizefrom>(?I<who>?)
+
+If I<who> is specified, it must be either B<program> or
+B<user>, or an abbreviation of one of these two. It indicates
+whether I<$toplevel>'s current size was requested by the
+program or by the user. Some window managers ignore program-requested
+sizes and ask the user to manually size the window; if
+B<user> is specified then the window manager should give the
+window its specified size without asking the user for assistance.
+If I<who> is specified as an empty string, then the current size
+source is cancelled.
+If I<who> is specified, then the method returns an empty string.
+Otherwise it returns B<user> or $widget to indicate the
+source of the window's current size, or an empty string if
+no source has been specified yet. Most window managers interpret
+``no source'' as equivalent to B<program>.
+
+=item I<$toplevel>-E<gt>B<stackorder>( I<?isabove|isbelow $toplevel?> );
+
+The stackorder command returns a list of toplevel windows in
+stacking order, from lowest to highest. When a single toplevel
+window is passed, the returned list recursively includes all of
+the window's children that are toplevels. Only those toplevels
+that are currently mapped to the screen are returned. The
+stackorder command can also be used to determine if one toplevel
+is positioned above or below a second toplevel. When two window
+arguments separated by either isabove or isbelow are passed, a
+boolean result indicates whether or not the first window is
+currently above or below the second window in the stacking order.
+
+
+=item I<$toplevel>-E<gt>B<state>(?I<newstate>?)
+
+If I<newstate> is specified, the window will be set to
+the new state, otherwise it returns the current state of
+I<$toplevel>: either B<normal>, B<iconic>, B<withdrawn>, B<icon>, or
+(Windows only) B<zoomed>. The
+difference between B<iconic> and B<icon> is that B<iconic> refers to a
+window that has been iconified (e.g., with the B<iconify> method)
+while B<icon> refers to a window whose only purpose is to serve as the
+icon for some other window (via the B<iconwindow> method). The
+B<icon> state cannot be set.
+
+
+=item I<$toplevel>-E<gt>B<title>(?I<string>?)
+
+If I<string> is specified, then it will be passed to the window
+manager for use as the title for I<$toplevel> (the window manager
+should display this string in I<$toplevel>'s title bar). In this
+case the method returns an empty string. If I<string> isn't
+specified then the method returns the current title for the
+I<$toplevel>. The title for a window defaults to its name.
+
+=item I<$toplevel>-E<gt>B<transient>(?I<master>?)
+
+If I<master> is specified, then the window manager is informed
+that I<$toplevel> is a transient window (e.g. pull-down menu) working
+on behalf of I<master> (where I<master> is
+a top-level window). Some window managers will use
+this information to manage I<$toplevel> specially. If I<master>
+is specified as an empty string then I<$toplevel> is marked as not
+being a transient window any more. If I<master> is specified,
+then the method returns an empty string. Otherwise the method
+returns the path name of I<$toplevel>'s current master, or an
+empty string if I<$toplevel> isn't currently a transient window.
+
+=item I<$toplevel>-E<gt>B<withdraw>
+
+Arranges for I<$toplevel> to be withdrawn from the screen. This
+causes the window to be unmapped and forgotten about by the window
+manager. If the window
+has never been mapped, then this method
+causes the window to be mapped in the withdrawn state. Not all
+window managers appear to know how to handle windows that are
+mapped in the withdrawn state.
+Note: it sometimes seems to be necessary to withdraw a
+window and then re-map it (e.g. with B<deiconify>) to get some
+window managers to pay attention to changes in window attributes
+such as group.
+
+=item I<$toplevel>-E<gt>B<wrapper>
+
+Returns the window id of the wrapper window in which Tk has placed
+I<$toplevel>. This is the id by which window manager will know
+I<$toplevel>, and so is appropriate place to add X properties.
+
+=back
+
+=head1 ICON SIZES
+
+The sizes of bitmaps/images that can be used as icons in this manner are platform
+and window manager dependant. Unix window managers are typically more tolerant
+than Win32. It is possible that coloured C<iconimage> icons may cause problems
+on some X window managers.
+
+=over 4
+
+=item * Win32
+
+C<iconimage> and C<iconbitmap> set the "large" icon, which should be
+32x32, it will automatically be scaled down to 16x16 for use as a small icon.
+Win32 ignores C<iconwin> requests.
+
+=item * KDE's "kwm"
+
+Accepts coloured C<iconimage> and black and white C<iconbitmap> but
+will scale either to a small (14x14?) icon. Kwm ignores C<iconwin>.
+
+=item * Sun's "olwm" or "olvwm"
+
+Honours C<iconwin> which will override C<iconimage> or C<iconbitmap>.
+Coloured images work.
+
+=item * Sun's CDE window manager
+
+Coloured images work. ...
+
+=back
+
+=head1 GEOMETRY MANAGEMENT
+
+By default a top-level window appears on the screen in its
+I<natural size>, which is the one determined internally by its
+widgets and geometry managers.
+If the natural size of a top-level window changes, then the window's size
+changes to match.
+A top-level window can be given a size other than its natural size in two ways.
+First, the user can resize the window manually using the facilities
+of the window manager, such as resize handles.
+Second, the application can request a particular size for a
+top-level window using the B<geometry> method.
+These two cases are handled identically by Tk; in either case,
+the requested size overrides the natural size.
+You can return the window to its natural by invoking B<geometry>
+with an empty I<geometry> string.
+
+Normally a top-level window can have any size from one pixel in each
+dimension up to the size of its screen.
+However, you can use the B<minsize> and B<maxsize> methods
+to limit the range of allowable sizes.
+The range set by B<minsize> and B<maxsize> applies to
+all forms of resizing, including the window's natural size as
+well as manual resizes and the B<geometry> method.
+You can also use the method B<resizable> to completely
+disable interactive resizing in one or both dimensions.
+
+=head1 GRIDDED GEOMETRY MANAGEMENT
+
+Gridded geometry management occurs when one of the widgets of an
+application supports a range of useful sizes.
+This occurs, for example, in a text editor where the scrollbars,
+menus, and other adornments are fixed in size but the edit widget
+can support any number of lines of text or characters per line.
+In this case, it is usually desirable to let the user specify the
+number of lines or characters-per-line, either with the
+B<geometry> method or by interactively resizing the window.
+In the case of text, and in other interesting cases also, only
+discrete sizes of the window make sense, such as integral numbers
+of lines and characters-per-line; arbitrary pixel sizes are not useful.
+
+Gridded geometry management provides support for this kind of
+application.
+Tk (and the window manager) assume that there is a grid of some
+sort within the application and that the application should be
+resized in terms of I<grid units> rather than pixels.
+Gridded geometry management is typically invoked by turning on
+the B<setGrid> option for a widget; it can also be invoked
+with the B<wmGrid> method or by calling B<Tk_SetGrid>.
+In each of these approaches the particular widget (or sometimes
+code in the application as a whole) specifies the relationship between
+integral grid sizes for the window and pixel sizes.
+To return to non-gridded geometry management, invoke
+B<grid> with empty argument strings.
+
+When gridded geometry management is enabled then all the dimensions specified
+in B<minsize>, B<maxsize>, and B<geometry> methods
+are treated as grid units rather than pixel units.
+Interactive resizing is also carried out in even numbers of grid units
+rather than pixels.
+
+=head1 BUGS
+
+Most existing window managers appear to have bugs that affect the
+operation of the B<wm> methods. For example, some changes won't
+take effect if the window is already active: the window will have
+to be withdrawn and de-iconified in order to make the change happen.
+
+=head1 SEE ALSO
+
+L<Tk::Widget|Tk::Widget>
+L<Tk::tixWm|Tk::tixWm>
+L<Tk::Mwm|Tk::Mwm>
+
+=head1 KEYWORDS
+
+aspect ratio, deiconify, focus model, geometry, grid, group, icon, iconify, increments, position, size, title, top-level window, units, window manager
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X.pm b/Master/tlpkg/tlperl.straw/lib/Tk/X.pm
new file mode 100755
index 00000000000..f32ca93d325
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X.pm
@@ -0,0 +1,391 @@
+package Tk::X;
+
+use strict;
+use Carp;
+use vars qw($VERSION @EXPORT $AUTOLOAD);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Xlib/X/X.pm#4 $
+use Tk qw($XS_VERSION);
+
+require Exporter;
+require DynaLoader;
+require AutoLoader;
+
+
+use base qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ Above
+ AllTemporary
+ AllocAll
+ AllocNone
+ AllowExposures
+ AlreadyGrabbed
+ Always
+ AnyButton
+ AnyKey
+ AnyModifier
+ AnyPropertyType
+ ArcChord
+ ArcPieSlice
+ AsyncBoth
+ AsyncKeyboard
+ AsyncPointer
+ AutoRepeatModeDefault
+ AutoRepeatModeOff
+ AutoRepeatModeOn
+ BadAccess
+ BadAlloc
+ BadAtom
+ BadColor
+ BadCursor
+ BadDrawable
+ BadFont
+ BadGC
+ BadIDChoice
+ BadImplementation
+ BadLength
+ BadMatch
+ BadName
+ BadPixmap
+ BadRequest
+ BadValue
+ BadWindow
+ Below
+ BottomIf
+ Button1
+ Button1Mask
+ Button1MotionMask
+ Button2
+ Button2Mask
+ Button2MotionMask
+ Button3
+ Button3Mask
+ Button3MotionMask
+ Button4
+ Button4Mask
+ Button4MotionMask
+ Button5
+ Button5Mask
+ Button5MotionMask
+ ButtonMotionMask
+ ButtonPress
+ ButtonPressMask
+ ButtonRelease
+ ButtonReleaseMask
+ CWBackPixel
+ CWBackPixmap
+ CWBackingPixel
+ CWBackingPlanes
+ CWBackingStore
+ CWBitGravity
+ CWBorderPixel
+ CWBorderPixmap
+ CWBorderWidth
+ CWColormap
+ CWCursor
+ CWDontPropagate
+ CWEventMask
+ CWHeight
+ CWOverrideRedirect
+ CWSaveUnder
+ CWSibling
+ CWStackMode
+ CWWidth
+ CWWinGravity
+ CWX
+ CWY
+ CapButt
+ CapNotLast
+ CapProjecting
+ CapRound
+ CenterGravity
+ CirculateNotify
+ CirculateRequest
+ ClientMessage
+ ClipByChildren
+ ColormapChangeMask
+ ColormapInstalled
+ ColormapNotify
+ ColormapUninstalled
+ Complex
+ ConfigureNotify
+ ConfigureRequest
+ ControlMapIndex
+ ControlMask
+ Convex
+ CoordModeOrigin
+ CoordModePrevious
+ CopyFromParent
+ CreateNotify
+ CurrentTime
+ CursorShape
+ DefaultBlanking
+ DefaultExposures
+ DestroyAll
+ DestroyNotify
+ DirectColor
+ DisableAccess
+ DisableScreenInterval
+ DisableScreenSaver
+ DoBlue
+ DoGreen
+ DoRed
+ DontAllowExposures
+ DontPreferBlanking
+ EastGravity
+ EnableAccess
+ EnterNotify
+ EnterWindowMask
+ EvenOddRule
+ Expose
+ ExposureMask
+ FamilyChaos
+ FamilyDECnet
+ FamilyInternet
+ FillOpaqueStippled
+ FillSolid
+ FillStippled
+ FillTiled
+ FirstExtensionError
+ FocusChangeMask
+ FocusIn
+ FocusOut
+ FontChange
+ FontLeftToRight
+ FontRightToLeft
+ ForgetGravity
+ GCArcMode
+ GCBackground
+ GCCapStyle
+ GCClipMask
+ GCClipXOrigin
+ GCClipYOrigin
+ GCDashList
+ GCDashOffset
+ GCFillRule
+ GCFillStyle
+ GCFont
+ GCForeground
+ GCFunction
+ GCGraphicsExposures
+ GCJoinStyle
+ GCLastBit
+ GCLineStyle
+ GCLineWidth
+ GCPlaneMask
+ GCStipple
+ GCSubwindowMode
+ GCTile
+ GCTileStipXOrigin
+ GCTileStipYOrigin
+ GXand
+ GXandInverted
+ GXandReverse
+ GXclear
+ GXcopy
+ GXcopyInverted
+ GXequiv
+ GXinvert
+ GXnand
+ GXnoop
+ GXnor
+ GXor
+ GXorInverted
+ GXorReverse
+ GXset
+ GXxor
+ GrabFrozen
+ GrabInvalidTime
+ GrabModeAsync
+ GrabModeSync
+ GrabNotViewable
+ GrabSuccess
+ GraphicsExpose
+ GravityNotify
+ GrayScale
+ HostDelete
+ HostInsert
+ IncludeInferiors
+ InputFocus
+ InputOnly
+ InputOutput
+ IsUnmapped
+ IsUnviewable
+ IsViewable
+ JoinBevel
+ JoinMiter
+ JoinRound
+ KBAutoRepeatMode
+ KBBellDuration
+ KBBellPercent
+ KBBellPitch
+ KBKey
+ KBKeyClickPercent
+ KBLed
+ KBLedMode
+ KeyPress
+ KeyPressMask
+ KeyRelease
+ KeyReleaseMask
+ KeymapNotify
+ KeymapStateMask
+ LASTEvent
+ LSBFirst
+ LastExtensionError
+ LeaveNotify
+ LeaveWindowMask
+ LedModeOff
+ LedModeOn
+ LineDoubleDash
+ LineOnOffDash
+ LineSolid
+ LockMapIndex
+ LockMask
+ LowerHighest
+ MSBFirst
+ MapNotify
+ MapRequest
+ MappingBusy
+ MappingFailed
+ MappingKeyboard
+ MappingModifier
+ MappingNotify
+ MappingPointer
+ MappingSuccess
+ Mod1MapIndex
+ Mod1Mask
+ Mod2MapIndex
+ Mod2Mask
+ Mod3MapIndex
+ Mod3Mask
+ Mod4MapIndex
+ Mod4Mask
+ Mod5MapIndex
+ Mod5Mask
+ MotionNotify
+ NoEventMask
+ NoExpose
+ NoSymbol
+ Nonconvex
+ None
+ NorthEastGravity
+ NorthGravity
+ NorthWestGravity
+ NotUseful
+ NotifyAncestor
+ NotifyDetailNone
+ NotifyGrab
+ NotifyHint
+ NotifyInferior
+ NotifyNonlinear
+ NotifyNonlinearVirtual
+ NotifyNormal
+ NotifyPointer
+ NotifyPointerRoot
+ NotifyUngrab
+ NotifyVirtual
+ NotifyWhileGrabbed
+ Opposite
+ OwnerGrabButtonMask
+ ParentRelative
+ PlaceOnBottom
+ PlaceOnTop
+ PointerMotionHintMask
+ PointerMotionMask
+ PointerRoot
+ PointerWindow
+ PreferBlanking
+ PropModeAppend
+ PropModePrepend
+ PropModeReplace
+ PropertyChangeMask
+ PropertyDelete
+ PropertyNewValue
+ PropertyNotify
+ PseudoColor
+ RaiseLowest
+ ReparentNotify
+ ReplayKeyboard
+ ReplayPointer
+ ResizeRedirectMask
+ ResizeRequest
+ RetainPermanent
+ RetainTemporary
+ RevertToNone
+ RevertToParent
+ RevertToPointerRoot
+ ScreenSaverActive
+ ScreenSaverReset
+ SelectionClear
+ SelectionNotify
+ SelectionRequest
+ SetModeDelete
+ SetModeInsert
+ ShiftMapIndex
+ ShiftMask
+ SouthEastGravity
+ SouthGravity
+ SouthWestGravity
+ StaticColor
+ StaticGravity
+ StaticGray
+ StippleShape
+ StructureNotifyMask
+ SubstructureNotifyMask
+ SubstructureRedirectMask
+ Success
+ SyncBoth
+ SyncKeyboard
+ SyncPointer
+ TileShape
+ TopIf
+ TrueColor
+ UnmapGravity
+ UnmapNotify
+ Unsorted
+ VisibilityChangeMask
+ VisibilityFullyObscured
+ VisibilityNotify
+ VisibilityPartiallyObscured
+ VisibilityUnobscured
+ WestGravity
+ WhenMapped
+ WindingRule
+ XYBitmap
+ XYPixmap
+ X_H
+ X_PROTOCOL
+ X_PROTOCOL_REVISION
+ YSorted
+ YXBanded
+ YXSorted
+ ZPixmap
+);
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function. If a constant is not found then control is passed
+ # to the AUTOLOAD in AutoLoader.
+
+ my $constname;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ croak "Your vendor has not defined X macro $constname";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap Tk::X;
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X.pod b/Master/tlpkg/tlperl.straw/lib/Tk/X.pod
new file mode 100755
index 00000000000..e6c7614a72c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X.pod
@@ -0,0 +1,373 @@
+
+=head1 NAME
+
+Tk::X - Perl extension for Xlib constants.
+
+=for pm Xlib/X/X.pm
+
+=for category Other Modules and Languages
+
+=head1 SYNOPSIS
+
+ use Tk::X;
+
+=head1 DESCRIPTION
+
+A module generated by h2xs. It exists to export Xlib #define type
+constants for possible use with Tk::Xlib.
+
+=head1 Exported constants
+
+ Above
+ AllTemporary
+ AllocAll
+ AllocNone
+ AllowExposures
+ AlreadyGrabbed
+ Always
+ AnyButton
+ AnyKey
+ AnyModifier
+ AnyPropertyType
+ ArcChord
+ ArcPieSlice
+ AsyncBoth
+ AsyncKeyboard
+ AsyncPointer
+ AutoRepeatModeDefault
+ AutoRepeatModeOff
+ AutoRepeatModeOn
+ BadAccess
+ BadAlloc
+ BadAtom
+ BadColor
+ BadCursor
+ BadDrawable
+ BadFont
+ BadGC
+ BadIDChoice
+ BadImplementation
+ BadLength
+ BadMatch
+ BadName
+ BadPixmap
+ BadRequest
+ BadValue
+ BadWindow
+ Below
+ BottomIf
+ Button1
+ Button1Mask
+ Button1MotionMask
+ Button2
+ Button2Mask
+ Button2MotionMask
+ Button3
+ Button3Mask
+ Button3MotionMask
+ Button4
+ Button4Mask
+ Button4MotionMask
+ Button5
+ Button5Mask
+ Button5MotionMask
+ ButtonMotionMask
+ ButtonPress
+ ButtonPressMask
+ ButtonRelease
+ ButtonReleaseMask
+ CWBackPixel
+ CWBackPixmap
+ CWBackingPixel
+ CWBackingPlanes
+ CWBackingStore
+ CWBitGravity
+ CWBorderPixel
+ CWBorderPixmap
+ CWBorderWidth
+ CWColormap
+ CWCursor
+ CWDontPropagate
+ CWEventMask
+ CWHeight
+ CWOverrideRedirect
+ CWSaveUnder
+ CWSibling
+ CWStackMode
+ CWWidth
+ CWWinGravity
+ CWX
+ CWY
+ CapButt
+ CapNotLast
+ CapProjecting
+ CapRound
+ CenterGravity
+ CirculateNotify
+ CirculateRequest
+ ClientMessage
+ ClipByChildren
+ ColormapChangeMask
+ ColormapInstalled
+ ColormapNotify
+ ColormapUninstalled
+ Complex
+ ConfigureNotify
+ ConfigureRequest
+ ControlMapIndex
+ ControlMask
+ Convex
+ CoordModeOrigin
+ CoordModePrevious
+ CopyFromParent
+ CreateNotify
+ CurrentTime
+ CursorShape
+ DefaultBlanking
+ DefaultExposures
+ DestroyAll
+ DestroyNotify
+ DirectColor
+ DisableAccess
+ DisableScreenInterval
+ DisableScreenSaver
+ DoBlue
+ DoGreen
+ DoRed
+ DontAllowExposures
+ DontPreferBlanking
+ EastGravity
+ EnableAccess
+ EnterNotify
+ EnterWindowMask
+ EvenOddRule
+ Expose
+ ExposureMask
+ FamilyChaos
+ FamilyDECnet
+ FamilyInternet
+ FillOpaqueStippled
+ FillSolid
+ FillStippled
+ FillTiled
+ FirstExtensionError
+ FocusChangeMask
+ FocusIn
+ FocusOut
+ FontChange
+ FontLeftToRight
+ FontRightToLeft
+ ForgetGravity
+ GCArcMode
+ GCBackground
+ GCCapStyle
+ GCClipMask
+ GCClipXOrigin
+ GCClipYOrigin
+ GCDashList
+ GCDashOffset
+ GCFillRule
+ GCFillStyle
+ GCFont
+ GCForeground
+ GCFunction
+ GCGraphicsExposures
+ GCJoinStyle
+ GCLastBit
+ GCLineStyle
+ GCLineWidth
+ GCPlaneMask
+ GCStipple
+ GCSubwindowMode
+ GCTile
+ GCTileStipXOrigin
+ GCTileStipYOrigin
+ GXand
+ GXandInverted
+ GXandReverse
+ GXclear
+ GXcopy
+ GXcopyInverted
+ GXequiv
+ GXinvert
+ GXnand
+ GXnoop
+ GXnor
+ GXor
+ GXorInverted
+ GXorReverse
+ GXset
+ GXxor
+ GrabFrozen
+ GrabInvalidTime
+ GrabModeAsync
+ GrabModeSync
+ GrabNotViewable
+ GrabSuccess
+ GraphicsExpose
+ GravityNotify
+ GrayScale
+ HostDelete
+ HostInsert
+ IncludeInferiors
+ InputFocus
+ InputOnly
+ InputOutput
+ IsUnmapped
+ IsUnviewable
+ IsViewable
+ JoinBevel
+ JoinMiter
+ JoinRound
+ KBAutoRepeatMode
+ KBBellDuration
+ KBBellPercent
+ KBBellPitch
+ KBKey
+ KBKeyClickPercent
+ KBLed
+ KBLedMode
+ KeyPress
+ KeyPressMask
+ KeyRelease
+ KeyReleaseMask
+ KeymapNotify
+ KeymapStateMask
+ LASTEvent
+ LSBFirst
+ LastExtensionError
+ LeaveNotify
+ LeaveWindowMask
+ LedModeOff
+ LedModeOn
+ LineDoubleDash
+ LineOnOffDash
+ LineSolid
+ LockMapIndex
+ LockMask
+ LowerHighest
+ MSBFirst
+ MapNotify
+ MapRequest
+ MappingBusy
+ MappingFailed
+ MappingKeyboard
+ MappingModifier
+ MappingNotify
+ MappingPointer
+ MappingSuccess
+ Mod1MapIndex
+ Mod1Mask
+ Mod2MapIndex
+ Mod2Mask
+ Mod3MapIndex
+ Mod3Mask
+ Mod4MapIndex
+ Mod4Mask
+ Mod5MapIndex
+ Mod5Mask
+ MotionNotify
+ NoEventMask
+ NoExpose
+ NoSymbol
+ Nonconvex
+ None
+ NorthEastGravity
+ NorthGravity
+ NorthWestGravity
+ NotUseful
+ NotifyAncestor
+ NotifyDetailNone
+ NotifyGrab
+ NotifyHint
+ NotifyInferior
+ NotifyNonlinear
+ NotifyNonlinearVirtual
+ NotifyNormal
+ NotifyPointer
+ NotifyPointerRoot
+ NotifyUngrab
+ NotifyVirtual
+ NotifyWhileGrabbed
+ Opposite
+ OwnerGrabButtonMask
+ ParentRelative
+ PlaceOnBottom
+ PlaceOnTop
+ PointerMotionHintMask
+ PointerMotionMask
+ PointerRoot
+ PointerWindow
+ PreferBlanking
+ PropModeAppend
+ PropModePrepend
+ PropModeReplace
+ PropertyChangeMask
+ PropertyDelete
+ PropertyNewValue
+ PropertyNotify
+ PseudoColor
+ RaiseLowest
+ ReparentNotify
+ ReplayKeyboard
+ ReplayPointer
+ ResizeRedirectMask
+ ResizeRequest
+ RetainPermanent
+ RetainTemporary
+ RevertToNone
+ RevertToParent
+ RevertToPointerRoot
+ ScreenSaverActive
+ ScreenSaverReset
+ SelectionClear
+ SelectionNotify
+ SelectionRequest
+ SetModeDelete
+ SetModeInsert
+ ShiftMapIndex
+ ShiftMask
+ SouthEastGravity
+ SouthGravity
+ SouthWestGravity
+ StaticColor
+ StaticGravity
+ StaticGray
+ StippleShape
+ StructureNotifyMask
+ SubstructureNotifyMask
+ SubstructureRedirectMask
+ Success
+ SyncBoth
+ SyncKeyboard
+ SyncPointer
+ TileShape
+ TopIf
+ TrueColor
+ UnmapGravity
+ UnmapNotify
+ Unsorted
+ VisibilityChangeMask
+ VisibilityFullyObscured
+ VisibilityNotify
+ VisibilityPartiallyObscured
+ VisibilityUnobscured
+ WestGravity
+ WhenMapped
+ WindingRule
+ XYBitmap
+ XYPixmap
+ X_H
+ X_PROTOCOL
+ X_PROTOCOL_REVISION
+ YSorted
+ YXBanded
+ YXSorted
+ ZPixmap
+
+=head1 AUTHOR
+
+Nick Ing-Simmons ran h2xs ...
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/X.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/X.h
new file mode 100755
index 00000000000..95db07f903f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/X.h
@@ -0,0 +1,677 @@
+/*
+ * $XConsortium: X.h,v 1.66 88/09/06 15:55:56 jim Exp $
+ */
+
+/* Definitions for the X window system likely to be used by applications */
+
+#ifndef X_H
+#define X_H
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+#define X_PROTOCOL 11 /* current protocol version */
+#define X_PROTOCOL_REVISION 0 /* current minor version */
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# define Cursor XCursor
+# define Region XRegion
+#endif
+
+/* Resources */
+
+#ifdef _WIN64
+typedef __int64 XID;
+#else
+typedef unsigned long XID;
+#endif
+
+typedef XID Window;
+typedef XID Drawable;
+typedef XID Font;
+typedef XID Pixmap;
+typedef XID Cursor;
+typedef XID Colormap;
+typedef XID GContext;
+typedef XID KeySym;
+
+typedef unsigned long Mask;
+
+typedef unsigned long Atom;
+
+typedef unsigned long VisualID;
+
+typedef unsigned long Time;
+
+typedef unsigned long KeyCode; /* In order to use IME, the Macintosh needs
+ * to pack 3 bytes into the keyCode field in
+ * the XEvent. In the real X.h, a KeyCode is
+ * defined as a short, which wouldn't be big
+ * enough. */
+
+/*****************************************************************
+ * RESERVED RESOURCE AND CONSTANT DEFINITIONS
+ *****************************************************************/
+
+#define None 0L /* universal null resource or null atom */
+
+#define ParentRelative 1L /* background pixmap in CreateWindow
+ and ChangeWindowAttributes */
+
+#define CopyFromParent 0L /* border pixmap in CreateWindow
+ and ChangeWindowAttributes
+ special VisualID and special window
+ class passed to CreateWindow */
+
+#define PointerWindow 0L /* destination window in SendEvent */
+#define InputFocus 1L /* destination window in SendEvent */
+
+#define PointerRoot 1L /* focus window in SetInputFocus */
+
+#define AnyPropertyType 0L /* special Atom, passed to GetProperty */
+
+#define AnyKey 0L /* special Key Code, passed to GrabKey */
+
+#define AnyButton 0L /* special Button Code, passed to GrabButton */
+
+#define AllTemporary 0L /* special Resource ID passed to KillClient */
+
+#define CurrentTime 0L /* special Time */
+
+#define NoSymbol 0L /* special KeySym */
+
+/*****************************************************************
+ * EVENT DEFINITIONS
+ *****************************************************************/
+
+/* Input Event Masks. Used as event-mask window attribute and as arguments
+ to Grab requests. Not to be confused with event names. */
+
+#define NoEventMask 0L
+#define KeyPressMask (1L<<0)
+#define KeyReleaseMask (1L<<1)
+#define ButtonPressMask (1L<<2)
+#define ButtonReleaseMask (1L<<3)
+#define EnterWindowMask (1L<<4)
+#define LeaveWindowMask (1L<<5)
+#define PointerMotionMask (1L<<6)
+#define PointerMotionHintMask (1L<<7)
+#define Button1MotionMask (1L<<8)
+#define Button2MotionMask (1L<<9)
+#define Button3MotionMask (1L<<10)
+#define Button4MotionMask (1L<<11)
+#define Button5MotionMask (1L<<12)
+#define ButtonMotionMask (1L<<13)
+#define KeymapStateMask (1L<<14)
+#define ExposureMask (1L<<15)
+#define VisibilityChangeMask (1L<<16)
+#define StructureNotifyMask (1L<<17)
+#define ResizeRedirectMask (1L<<18)
+#define SubstructureNotifyMask (1L<<19)
+#define SubstructureRedirectMask (1L<<20)
+#define FocusChangeMask (1L<<21)
+#define PropertyChangeMask (1L<<22)
+#define ColormapChangeMask (1L<<23)
+#define OwnerGrabButtonMask (1L<<24)
+
+/* Event names. Used in "type" field in XEvent structures. Not to be
+confused with event masks above. They start from 2 because 0 and 1
+are reserved in the protocol for errors and replies. */
+
+#define KeyPress 2
+#define KeyRelease 3
+#define ButtonPress 4
+#define ButtonRelease 5
+#define MotionNotify 6
+#define EnterNotify 7
+#define LeaveNotify 8
+#define FocusIn 9
+#define FocusOut 10
+#define KeymapNotify 11
+#define Expose 12
+#define GraphicsExpose 13
+#define NoExpose 14
+#define VisibilityNotify 15
+#define CreateNotify 16
+#define DestroyNotify 17
+#define UnmapNotify 18
+#define MapNotify 19
+#define MapRequest 20
+#define ReparentNotify 21
+#define ConfigureNotify 22
+#define ConfigureRequest 23
+#define GravityNotify 24
+#define ResizeRequest 25
+#define CirculateNotify 26
+#define CirculateRequest 27
+#define PropertyNotify 28
+#define SelectionClear 29
+#define SelectionRequest 30
+#define SelectionNotify 31
+#define ColormapNotify 32
+#define ClientMessage 33
+#define MappingNotify 34
+#define LASTEvent 35 /* must be bigger than any event # */
+
+
+/* Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer,
+ state in various key-, mouse-, and button-related events. */
+
+#define ShiftMask (1<<0)
+#define LockMask (1<<1)
+#define ControlMask (1<<2)
+#define Mod1Mask (1<<3)
+#define Mod2Mask (1<<4)
+#define Mod3Mask (1<<5)
+#define Mod4Mask (1<<6)
+#define Mod5Mask (1<<7)
+
+/* modifier names. Used to build a SetModifierMapping request or
+ to read a GetModifierMapping request. These correspond to the
+ masks defined above. */
+#define ShiftMapIndex 0
+#define LockMapIndex 1
+#define ControlMapIndex 2
+#define Mod1MapIndex 3
+#define Mod2MapIndex 4
+#define Mod3MapIndex 5
+#define Mod4MapIndex 6
+#define Mod5MapIndex 7
+
+
+/* button masks. Used in same manner as Key masks above. Not to be confused
+ with button names below. */
+
+#define Button1Mask (1<<8)
+#define Button2Mask (1<<9)
+#define Button3Mask (1<<10)
+#define Button4Mask (1<<11)
+#define Button5Mask (1<<12)
+
+#define AnyModifier (1<<15) /* used in GrabButton, GrabKey */
+
+
+/* button names. Used as arguments to GrabButton and as detail in ButtonPress
+ and ButtonRelease events. Not to be confused with button masks above.
+ Note that 0 is already defined above as "AnyButton". */
+
+#define Button1 1
+#define Button2 2
+#define Button3 3
+#define Button4 4
+#define Button5 5
+
+/* Notify modes */
+
+#define NotifyNormal 0
+#define NotifyGrab 1
+#define NotifyUngrab 2
+#define NotifyWhileGrabbed 3
+
+#define NotifyHint 1 /* for MotionNotify events */
+
+/* Notify detail */
+
+#define NotifyAncestor 0
+#define NotifyVirtual 1
+#define NotifyInferior 2
+#define NotifyNonlinear 3
+#define NotifyNonlinearVirtual 4
+#define NotifyPointer 5
+#define NotifyPointerRoot 6
+#define NotifyDetailNone 7
+
+/* Visibility notify */
+
+#define VisibilityUnobscured 0
+#define VisibilityPartiallyObscured 1
+#define VisibilityFullyObscured 2
+
+/* Circulation request */
+
+#define PlaceOnTop 0
+#define PlaceOnBottom 1
+
+/* protocol families */
+
+#define FamilyInternet 0
+#define FamilyDECnet 1
+#define FamilyChaos 2
+
+/* Property notification */
+
+#define PropertyNewValue 0
+#define PropertyDelete 1
+
+/* Color Map notification */
+
+#define ColormapUninstalled 0
+#define ColormapInstalled 1
+
+/* GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes */
+
+#define GrabModeSync 0
+#define GrabModeAsync 1
+
+/* GrabPointer, GrabKeyboard reply status */
+
+#define GrabSuccess 0
+#define AlreadyGrabbed 1
+#define GrabInvalidTime 2
+#define GrabNotViewable 3
+#define GrabFrozen 4
+
+/* AllowEvents modes */
+
+#define AsyncPointer 0
+#define SyncPointer 1
+#define ReplayPointer 2
+#define AsyncKeyboard 3
+#define SyncKeyboard 4
+#define ReplayKeyboard 5
+#define AsyncBoth 6
+#define SyncBoth 7
+
+/* Used in SetInputFocus, GetInputFocus */
+
+#define RevertToNone (int)None
+#define RevertToPointerRoot (int)PointerRoot
+#define RevertToParent 2
+
+/*****************************************************************
+ * ERROR CODES
+ *****************************************************************/
+
+#define Success 0 /* everything's okay */
+#define BadRequest 1 /* bad request code */
+#define BadValue 2 /* int parameter out of range */
+#define BadWindow 3 /* parameter not a Window */
+#define BadPixmap 4 /* parameter not a Pixmap */
+#define BadAtom 5 /* parameter not an Atom */
+#define BadCursor 6 /* parameter not a Cursor */
+#define BadFont 7 /* parameter not a Font */
+#define BadMatch 8 /* parameter mismatch */
+#define BadDrawable 9 /* parameter not a Pixmap or Window */
+#define BadAccess 10 /* depending on context:
+ - key/button already grabbed
+ - attempt to free an illegal
+ cmap entry
+ - attempt to store into a read-only
+ color map entry.
+ - attempt to modify the access control
+ list from other than the local host.
+ */
+#define BadAlloc 11 /* insufficient resources */
+#define BadColor 12 /* no such colormap */
+#define BadGC 13 /* parameter not a GC */
+#define BadIDChoice 14 /* choice not in range or already used */
+#define BadName 15 /* font or color name doesn't exist */
+#define BadLength 16 /* Request length incorrect */
+#define BadImplementation 17 /* server is defective */
+
+#define FirstExtensionError 128
+#define LastExtensionError 255
+
+/*****************************************************************
+ * WINDOW DEFINITIONS
+ *****************************************************************/
+
+/* Window classes used by CreateWindow */
+/* Note that CopyFromParent is already defined as 0 above */
+
+#define InputOutput 1
+#define InputOnly 2
+
+/* Window attributes for CreateWindow and ChangeWindowAttributes */
+
+#define CWBackPixmap (1L<<0)
+#define CWBackPixel (1L<<1)
+#define CWBorderPixmap (1L<<2)
+#define CWBorderPixel (1L<<3)
+#define CWBitGravity (1L<<4)
+#define CWWinGravity (1L<<5)
+#define CWBackingStore (1L<<6)
+#define CWBackingPlanes (1L<<7)
+#define CWBackingPixel (1L<<8)
+#define CWOverrideRedirect (1L<<9)
+#define CWSaveUnder (1L<<10)
+#define CWEventMask (1L<<11)
+#define CWDontPropagate (1L<<12)
+#define CWColormap (1L<<13)
+#define CWCursor (1L<<14)
+
+/* ConfigureWindow structure */
+
+#define CWX (1<<0)
+#define CWY (1<<1)
+#define CWWidth (1<<2)
+#define CWHeight (1<<3)
+#define CWBorderWidth (1<<4)
+#define CWSibling (1<<5)
+#define CWStackMode (1<<6)
+
+
+/* Bit Gravity */
+
+#define ForgetGravity 0
+#define NorthWestGravity 1
+#define NorthGravity 2
+#define NorthEastGravity 3
+#define WestGravity 4
+#define CenterGravity 5
+#define EastGravity 6
+#define SouthWestGravity 7
+#define SouthGravity 8
+#define SouthEastGravity 9
+#define StaticGravity 10
+
+/* Window gravity + bit gravity above */
+
+#define UnmapGravity 0
+
+/* Used in CreateWindow for backing-store hint */
+
+#define NotUseful 0
+#define WhenMapped 1
+#define Always 2
+
+/* Used in GetWindowAttributes reply */
+
+#define IsUnmapped 0
+#define IsUnviewable 1
+#define IsViewable 2
+
+/* Used in ChangeSaveSet */
+
+#define SetModeInsert 0
+#define SetModeDelete 1
+
+/* Used in ChangeCloseDownMode */
+
+#define DestroyAll 0
+#define RetainPermanent 1
+#define RetainTemporary 2
+
+/* Window stacking method (in configureWindow) */
+
+#define Above 0
+#define Below 1
+#define TopIf 2
+#define BottomIf 3
+#define Opposite 4
+
+/* Circulation direction */
+
+#define RaiseLowest 0
+#define LowerHighest 1
+
+/* Property modes */
+
+#define PropModeReplace 0
+#define PropModePrepend 1
+#define PropModeAppend 2
+
+/*****************************************************************
+ * GRAPHICS DEFINITIONS
+ *****************************************************************/
+
+/* graphics functions, as in GC.alu */
+
+#define GXclear 0x0 /* 0 */
+#define GXand 0x1 /* src AND dst */
+#define GXandReverse 0x2 /* src AND NOT dst */
+#define GXcopy 0x3 /* src */
+#define GXandInverted 0x4 /* NOT src AND dst */
+#define GXnoop 0x5 /* dst */
+#define GXxor 0x6 /* src XOR dst */
+#define GXor 0x7 /* src OR dst */
+#define GXnor 0x8 /* NOT src AND NOT dst */
+#define GXequiv 0x9 /* NOT src XOR dst */
+#define GXinvert 0xa /* NOT dst */
+#define GXorReverse 0xb /* src OR NOT dst */
+#define GXcopyInverted 0xc /* NOT src */
+#define GXorInverted 0xd /* NOT src OR dst */
+#define GXnand 0xe /* NOT src OR NOT dst */
+#define GXset 0xf /* 1 */
+
+/* LineStyle */
+
+#define LineSolid 0
+#define LineOnOffDash 1
+#define LineDoubleDash 2
+
+/* capStyle */
+
+#define CapNotLast 0
+#define CapButt 1
+#define CapRound 2
+#define CapProjecting 3
+
+/* joinStyle */
+
+#define JoinMiter 0
+#define JoinRound 1
+#define JoinBevel 2
+
+/* fillStyle */
+
+#define FillSolid 0
+#define FillTiled 1
+#define FillStippled 2
+#define FillOpaqueStippled 3
+
+/* fillRule */
+
+#define EvenOddRule 0
+#define WindingRule 1
+
+/* subwindow mode */
+
+#define ClipByChildren 0
+#define IncludeInferiors 1
+
+/* SetClipRectangles ordering */
+
+#define Unsorted 0
+#define YSorted 1
+#define YXSorted 2
+#define YXBanded 3
+
+/* CoordinateMode for drawing routines */
+
+#define CoordModeOrigin 0 /* relative to the origin */
+#define CoordModePrevious 1 /* relative to previous point */
+
+/* Polygon shapes */
+
+#define Complex 0 /* paths may intersect */
+#define Nonconvex 1 /* no paths intersect, but not convex */
+#define Convex 2 /* wholly convex */
+
+/* Arc modes for PolyFillArc */
+
+#define ArcChord 0 /* join endpoints of arc */
+#define ArcPieSlice 1 /* join endpoints to center of arc */
+
+/* GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into
+ GC.stateChanges */
+
+#define GCFunction (1L<<0)
+#define GCPlaneMask (1L<<1)
+#define GCForeground (1L<<2)
+#define GCBackground (1L<<3)
+#define GCLineWidth (1L<<4)
+#define GCLineStyle (1L<<5)
+#define GCCapStyle (1L<<6)
+#define GCJoinStyle (1L<<7)
+#define GCFillStyle (1L<<8)
+#define GCFillRule (1L<<9)
+#define GCTile (1L<<10)
+#define GCStipple (1L<<11)
+#define GCTileStipXOrigin (1L<<12)
+#define GCTileStipYOrigin (1L<<13)
+#define GCFont (1L<<14)
+#define GCSubwindowMode (1L<<15)
+#define GCGraphicsExposures (1L<<16)
+#define GCClipXOrigin (1L<<17)
+#define GCClipYOrigin (1L<<18)
+#define GCClipMask (1L<<19)
+#define GCDashOffset (1L<<20)
+#define GCDashList (1L<<21)
+#define GCArcMode (1L<<22)
+
+#define GCLastBit 22
+/*****************************************************************
+ * FONTS
+ *****************************************************************/
+
+/* used in QueryFont -- draw direction */
+
+#define FontLeftToRight 0
+#define FontRightToLeft 1
+
+#define FontChange 255
+
+/*****************************************************************
+ * IMAGING
+ *****************************************************************/
+
+/* ImageFormat -- PutImage, GetImage */
+
+#define XYBitmap 0 /* depth 1, XYFormat */
+#define XYPixmap 1 /* depth == drawable depth */
+#define ZPixmap 2 /* depth == drawable depth */
+
+/*****************************************************************
+ * COLOR MAP STUFF
+ *****************************************************************/
+
+/* For CreateColormap */
+
+#define AllocNone 0 /* create map with no entries */
+#define AllocAll 1 /* allocate entire map writeable */
+
+
+/* Flags used in StoreNamedColor, StoreColors */
+
+#define DoRed (1<<0)
+#define DoGreen (1<<1)
+#define DoBlue (1<<2)
+
+/*****************************************************************
+ * CURSOR STUFF
+ *****************************************************************/
+
+/* QueryBestSize Class */
+
+#define CursorShape 0 /* largest size that can be displayed */
+#define TileShape 1 /* size tiled fastest */
+#define StippleShape 2 /* size stippled fastest */
+
+/*****************************************************************
+ * KEYBOARD/POINTER STUFF
+ *****************************************************************/
+
+#define AutoRepeatModeOff 0
+#define AutoRepeatModeOn 1
+#define AutoRepeatModeDefault 2
+
+#define LedModeOff 0
+#define LedModeOn 1
+
+/* masks for ChangeKeyboardControl */
+
+#define KBKeyClickPercent (1L<<0)
+#define KBBellPercent (1L<<1)
+#define KBBellPitch (1L<<2)
+#define KBBellDuration (1L<<3)
+#define KBLed (1L<<4)
+#define KBLedMode (1L<<5)
+#define KBKey (1L<<6)
+#define KBAutoRepeatMode (1L<<7)
+
+#define MappingSuccess 0
+#define MappingBusy 1
+#define MappingFailed 2
+
+#define MappingModifier 0
+#define MappingKeyboard 1
+#define MappingPointer 2
+
+/*****************************************************************
+ * SCREEN SAVER STUFF
+ *****************************************************************/
+
+#define DontPreferBlanking 0
+#define PreferBlanking 1
+#define DefaultBlanking 2
+
+#define DisableScreenSaver 0
+#define DisableScreenInterval 0
+
+#define DontAllowExposures 0
+#define AllowExposures 1
+#define DefaultExposures 2
+
+/* for ForceScreenSaver */
+
+#define ScreenSaverReset 0
+#define ScreenSaverActive 1
+
+/*****************************************************************
+ * HOSTS AND CONNECTIONS
+ *****************************************************************/
+
+/* for ChangeHosts */
+
+#define HostInsert 0
+#define HostDelete 1
+
+/* for ChangeAccessControl */
+
+#define EnableAccess 1
+#define DisableAccess 0
+
+/* Display classes used in opening the connection
+ * Note that the statically allocated ones are even numbered and the
+ * dynamically changeable ones are odd numbered */
+
+#define StaticGray 0
+#define GrayScale 1
+#define StaticColor 2
+#define PseudoColor 3
+#define TrueColor 4
+#define DirectColor 5
+
+
+/* Byte order used in imageByteOrder and bitmapBitOrder */
+
+#define LSBFirst 0
+#define MSBFirst 1
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# undef Cursor
+# undef Region
+#endif
+
+#endif /* X_H */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xatom.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xatom.h
new file mode 100755
index 00000000000..485a4236db8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xatom.h
@@ -0,0 +1,79 @@
+#ifndef XATOM_H
+#define XATOM_H 1
+
+/* THIS IS A GENERATED FILE
+ *
+ * Do not change! Changing this file implies a protocol change!
+ */
+
+#define XA_PRIMARY ((Atom) 1)
+#define XA_SECONDARY ((Atom) 2)
+#define XA_ARC ((Atom) 3)
+#define XA_ATOM ((Atom) 4)
+#define XA_BITMAP ((Atom) 5)
+#define XA_CARDINAL ((Atom) 6)
+#define XA_COLORMAP ((Atom) 7)
+#define XA_CURSOR ((Atom) 8)
+#define XA_CUT_BUFFER0 ((Atom) 9)
+#define XA_CUT_BUFFER1 ((Atom) 10)
+#define XA_CUT_BUFFER2 ((Atom) 11)
+#define XA_CUT_BUFFER3 ((Atom) 12)
+#define XA_CUT_BUFFER4 ((Atom) 13)
+#define XA_CUT_BUFFER5 ((Atom) 14)
+#define XA_CUT_BUFFER6 ((Atom) 15)
+#define XA_CUT_BUFFER7 ((Atom) 16)
+#define XA_DRAWABLE ((Atom) 17)
+#define XA_FONT ((Atom) 18)
+#define XA_INTEGER ((Atom) 19)
+#define XA_PIXMAP ((Atom) 20)
+#define XA_POINT ((Atom) 21)
+#define XA_RECTANGLE ((Atom) 22)
+#define XA_RESOURCE_MANAGER ((Atom) 23)
+#define XA_RGB_COLOR_MAP ((Atom) 24)
+#define XA_RGB_BEST_MAP ((Atom) 25)
+#define XA_RGB_BLUE_MAP ((Atom) 26)
+#define XA_RGB_DEFAULT_MAP ((Atom) 27)
+#define XA_RGB_GRAY_MAP ((Atom) 28)
+#define XA_RGB_GREEN_MAP ((Atom) 29)
+#define XA_RGB_RED_MAP ((Atom) 30)
+#define XA_STRING ((Atom) 31)
+#define XA_VISUALID ((Atom) 32)
+#define XA_WINDOW ((Atom) 33)
+#define XA_WM_COMMAND ((Atom) 34)
+#define XA_WM_HINTS ((Atom) 35)
+#define XA_WM_CLIENT_MACHINE ((Atom) 36)
+#define XA_WM_ICON_NAME ((Atom) 37)
+#define XA_WM_ICON_SIZE ((Atom) 38)
+#define XA_WM_NAME ((Atom) 39)
+#define XA_WM_NORMAL_HINTS ((Atom) 40)
+#define XA_WM_SIZE_HINTS ((Atom) 41)
+#define XA_WM_ZOOM_HINTS ((Atom) 42)
+#define XA_MIN_SPACE ((Atom) 43)
+#define XA_NORM_SPACE ((Atom) 44)
+#define XA_MAX_SPACE ((Atom) 45)
+#define XA_END_SPACE ((Atom) 46)
+#define XA_SUPERSCRIPT_X ((Atom) 47)
+#define XA_SUPERSCRIPT_Y ((Atom) 48)
+#define XA_SUBSCRIPT_X ((Atom) 49)
+#define XA_SUBSCRIPT_Y ((Atom) 50)
+#define XA_UNDERLINE_POSITION ((Atom) 51)
+#define XA_UNDERLINE_THICKNESS ((Atom) 52)
+#define XA_STRIKEOUT_ASCENT ((Atom) 53)
+#define XA_STRIKEOUT_DESCENT ((Atom) 54)
+#define XA_ITALIC_ANGLE ((Atom) 55)
+#define XA_X_HEIGHT ((Atom) 56)
+#define XA_QUAD_WIDTH ((Atom) 57)
+#define XA_WEIGHT ((Atom) 58)
+#define XA_POINT_SIZE ((Atom) 59)
+#define XA_RESOLUTION ((Atom) 60)
+#define XA_COPYRIGHT ((Atom) 61)
+#define XA_NOTICE ((Atom) 62)
+#define XA_FONT_NAME ((Atom) 63)
+#define XA_FAMILY_NAME ((Atom) 64)
+#define XA_FULL_NAME ((Atom) 65)
+#define XA_CAP_HEIGHT ((Atom) 66)
+#define XA_WM_CLASS ((Atom) 67)
+#define XA_WM_TRANSIENT_FOR ((Atom) 68)
+
+#define XA_LAST_PREDEFINED ((Atom) 68)
+#endif /* XATOM_H */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xfuncproto.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xfuncproto.h
new file mode 100755
index 00000000000..a59379b3b65
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xfuncproto.h
@@ -0,0 +1,60 @@
+/* $XConsortium: Xfuncproto.h,v 1.7 91/05/13 20:49:21 rws Exp $ */
+/*
+ * Copyright 1989, 1991 by the Massachusetts Institute of Technology
+ *
+ * Permission to use, copy, modify, and distribute this software and its
+ * documentation for any purpose and without fee is hereby granted, provided
+ * that the above copyright notice appear in all copies and that both that
+ * copyright notice and this permission notice appear in supporting
+ * documentation, and that the name of M.I.T. not be used in advertising
+ * or publicity pertaining to distribution of the software without specific,
+ * written prior permission. M.I.T. makes no representations about the
+ * suitability of this software for any purpose. It is provided "as is"
+ * without express or implied warranty.
+ *
+ */
+
+/* Definitions to make function prototypes manageable */
+
+#ifndef _XFUNCPROTO_H_
+#define _XFUNCPROTO_H_
+
+#ifndef NeedFunctionPrototypes
+#define NeedFunctionPrototypes 1
+#endif /* NeedFunctionPrototypes */
+
+#ifndef NeedVarargsPrototypes
+#define NeedVarargsPrototypes 0
+#endif /* NeedVarargsPrototypes */
+
+#if NeedFunctionPrototypes
+
+#ifndef NeedNestedPrototypes
+#define NeedNestedPrototypes 1
+#endif /* NeedNestedPrototypes */
+
+#ifndef _Xconst
+#define _Xconst const
+#endif /* _Xconst */
+
+#ifndef NeedWidePrototypes
+#ifdef NARROWPROTO
+#define NeedWidePrototypes 0
+#else
+#define NeedWidePrototypes 1 /* default to make interropt. easier */
+#endif
+#endif /* NeedWidePrototypes */
+
+#endif /* NeedFunctionPrototypes */
+
+#ifdef __cplusplus
+#define _XFUNCPROTOBEGIN extern "C" {
+#define _XFUNCPROTOEND }
+#endif
+
+#ifndef _XFUNCPROTOBEGIN
+#define _XFUNCPROTOBEGIN
+#define _XFUNCPROTOEND
+#endif /* _XFUNCPROTOBEGIN */
+
+#endif /* _XFUNCPROTO_H_ */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xlib.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xlib.h
new file mode 100755
index 00000000000..0a9e3ddd45d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xlib.h
@@ -0,0 +1,1214 @@
+/* $XConsortium: Xlib.h,v 11.221 93/07/02 14:13:28 gildea Exp $ */
+/*
+ * Copyright 1985, 1986, 1987, 1991 by the Massachusetts Institute of Technology
+ *
+ * Permission to use, copy, modify, and distribute this software and its
+ * documentation for any purpose and without fee is hereby granted, provided
+ * that the above copyright notice appear in all copies and that both that
+ * copyright notice and this permission notice appear in supporting
+ * documentation, and that the name of M.I.T. not be used in advertising
+ * or publicity pertaining to distribution of the software without specific,
+ * written prior permission. M.I.T. makes no representations about the
+ * suitability of this software for any purpose. It is provided "as is"
+ * without express or implied warranty.
+ *
+ * X Window System is a Trademark of MIT.
+ *
+ */
+
+
+/*
+ * Xlib.h - Header definition and support file for the C subroutine
+ * interface library (Xlib) to the X Window System Protocol (V11).
+ * Structures and symbols starting with "_" are private to the library.
+ */
+#ifndef _XLIB_H_
+#define _XLIB_H_
+
+#define XlibSpecificationRelease 5
+
+#if !defined(MAC_TCL) && !defined(MAC_OSX_TK)
+# include <X11/X.h>
+#endif
+#ifdef MAC_TCL
+# include <X.h>
+# define Cursor XCursor
+# define Region XRegion
+#endif
+#ifdef MAC_OSX_TK
+# include <X11/X.h>
+# define Cursor XCursor
+# define Region XRegion
+#endif
+
+/* applications should not depend on these two headers being included! */
+#ifdef MAC_TCL
+#include <Xfuncproto.h>
+#else
+#include <X11/Xfuncproto.h>
+#endif
+
+#ifndef X_WCHAR
+#ifdef X_NOT_STDC_ENV
+#define X_WCHAR
+#endif
+#endif
+
+#ifndef X_WCHAR
+#include <stddef.h>
+#else
+/* replace this with #include or typedef appropriate for your system */
+typedef unsigned long wchar_t;
+#endif
+
+typedef char *XPointer;
+
+#define Bool int
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+/* Use define rather than typedef, since may need to undefine this later */
+#define Status int
+#else
+typedef int Status;
+#endif
+#define True 1
+#define False 0
+
+#define QueuedAlready 0
+#define QueuedAfterReading 1
+#define QueuedAfterFlush 2
+
+#define ConnectionNumber(dpy) ((dpy)->fd)
+#define RootWindow(dpy, scr) (((dpy)->screens[(scr)]).root)
+#define DefaultScreen(dpy) ((dpy)->default_screen)
+#define DefaultRootWindow(dpy) (((dpy)->screens[(dpy)->default_screen]).root)
+#define DefaultVisual(dpy, scr) (((dpy)->screens[(scr)]).root_visual)
+#define DefaultGC(dpy, scr) (((dpy)->screens[(scr)]).default_gc)
+#define BlackPixel(dpy, scr) (((dpy)->screens[(scr)]).black_pixel)
+#define WhitePixel(dpy, scr) (((dpy)->screens[(scr)]).white_pixel)
+#define AllPlanes ((unsigned long)~0L)
+#define QLength(dpy) ((dpy)->qlen)
+#define DisplayWidth(dpy, scr) (((dpy)->screens[(scr)]).width)
+#define DisplayHeight(dpy, scr) (((dpy)->screens[(scr)]).height)
+#define DisplayWidthMM(dpy, scr)(((dpy)->screens[(scr)]).mwidth)
+#define DisplayHeightMM(dpy, scr)(((dpy)->screens[(scr)]).mheight)
+#define DisplayPlanes(dpy, scr) (((dpy)->screens[(scr)]).root_depth)
+#define DisplayCells(dpy, scr) (DefaultVisual((dpy), (scr))->map_entries)
+#define ScreenCount(dpy) ((dpy)->nscreens)
+#define ServerVendor(dpy) ((dpy)->vendor)
+#define ProtocolVersion(dpy) ((dpy)->proto_major_version)
+#define ProtocolRevision(dpy) ((dpy)->proto_minor_version)
+#define VendorRelease(dpy) ((dpy)->release)
+#define DisplayString(dpy) ((dpy)->display_name)
+#define DefaultDepth(dpy, scr) (((dpy)->screens[(scr)]).root_depth)
+#define DefaultColormap(dpy, scr)(((dpy)->screens[(scr)]).cmap)
+#define BitmapUnit(dpy) ((dpy)->bitmap_unit)
+#define BitmapBitOrder(dpy) ((dpy)->bitmap_bit_order)
+#define BitmapPad(dpy) ((dpy)->bitmap_pad)
+#define ImageByteOrder(dpy) ((dpy)->byte_order)
+#define NextRequest(dpy) ((dpy)->request + 1)
+#define LastKnownRequestProcessed(dpy) ((dpy)->last_request_read)
+
+/* macros for screen oriented applications (toolkit) */
+#define ScreenOfDisplay(dpy, scr)(&((dpy)->screens[(scr)]))
+#define DefaultScreenOfDisplay(dpy) (&((dpy)->screens[(dpy)->default_screen]))
+#define DisplayOfScreen(s) ((s)->display)
+#define RootWindowOfScreen(s) ((s)->root)
+#define BlackPixelOfScreen(s) ((s)->black_pixel)
+#define WhitePixelOfScreen(s) ((s)->white_pixel)
+#define DefaultColormapOfScreen(s)((s)->cmap)
+#define DefaultDepthOfScreen(s) ((s)->root_depth)
+#define DefaultGCOfScreen(s) ((s)->default_gc)
+#define DefaultVisualOfScreen(s)((s)->root_visual)
+#define WidthOfScreen(s) ((s)->width)
+#define HeightOfScreen(s) ((s)->height)
+#define WidthMMOfScreen(s) ((s)->mwidth)
+#define HeightMMOfScreen(s) ((s)->mheight)
+#define PlanesOfScreen(s) ((s)->root_depth)
+#define CellsOfScreen(s) (DefaultVisualOfScreen((s))->map_entries)
+#define MinCmapsOfScreen(s) ((s)->min_maps)
+#define MaxCmapsOfScreen(s) ((s)->max_maps)
+#define DoesSaveUnders(s) ((s)->save_unders)
+#define DoesBackingStore(s) ((s)->backing_store)
+#define EventMaskOfScreen(s) ((s)->root_input_mask)
+
+/*
+ * Extensions need a way to hang private data on some structures.
+ */
+typedef struct _XExtData {
+ int number; /* number returned by XRegisterExtension */
+ struct _XExtData *next; /* next item on list of data for structure */
+ int (*free_private)(); /* called to free private storage */
+ XPointer private_data; /* data private to this extension. */
+} XExtData;
+
+/*
+ * This file contains structures used by the extension mechanism.
+ */
+typedef struct { /* public to extension, cannot be changed */
+ int extension; /* extension number */
+ int major_opcode; /* major op-code assigned by server */
+ int first_event; /* first event number for the extension */
+ int first_error; /* first error number for the extension */
+} XExtCodes;
+
+/*
+ * Data structure for retrieving info about pixmap formats.
+ */
+
+typedef struct {
+ int depth;
+ int bits_per_pixel;
+ int scanline_pad;
+} XPixmapFormatValues;
+
+
+/*
+ * Data structure for setting graphics context.
+ */
+typedef struct {
+ int function; /* logical operation */
+ unsigned long plane_mask;/* plane mask */
+ unsigned long foreground;/* foreground pixel */
+ unsigned long background;/* background pixel */
+ int line_width; /* line width */
+ int line_style; /* LineSolid, LineOnOffDash, LineDoubleDash */
+ int cap_style; /* CapNotLast, CapButt,
+ CapRound, CapProjecting */
+ int join_style; /* JoinMiter, JoinRound, JoinBevel */
+ int fill_style; /* FillSolid, FillTiled,
+ FillStippled, FillOpaeueStippled */
+ int fill_rule; /* EvenOddRule, WindingRule */
+ int arc_mode; /* ArcChord, ArcPieSlice */
+ Pixmap tile; /* tile pixmap for tiling operations */
+ Pixmap stipple; /* stipple 1 plane pixmap for stipping */
+ int ts_x_origin; /* offset for tile or stipple operations */
+ int ts_y_origin;
+ Font font; /* default text font for text operations */
+ int subwindow_mode; /* ClipByChildren, IncludeInferiors */
+ Bool graphics_exposures;/* boolean, should exposures be generated */
+ int clip_x_origin; /* origin for clipping */
+ int clip_y_origin;
+ Pixmap clip_mask; /* bitmap clipping; other calls for rects */
+ int dash_offset; /* patterned/dashed line information */
+ char dashes;
+} XGCValues;
+
+/*
+ * Graphics context. The contents of this structure are implementation
+ * dependent. A GC should be treated as opaque by application code.
+ */
+
+typedef XGCValues *GC;
+
+/*
+ * Visual structure; contains information about colormapping possible.
+ */
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ VisualID visualid; /* visual id of this visual */
+#if defined(__cplusplus) || defined(c_plusplus)
+ int c_class; /* C++ class of screen (monochrome, etc.) */
+#else
+ int class; /* class of screen (monochrome, etc.) */
+#endif
+ unsigned long red_mask, green_mask, blue_mask; /* mask values */
+ int bits_per_rgb; /* log base 2 of distinct color values */
+ int map_entries; /* color map entries */
+} Visual;
+
+/*
+ * Depth structure; contains information for each possible depth.
+ */
+typedef struct {
+ int depth; /* this depth (Z) of the depth */
+ int nvisuals; /* number of Visual types at this depth */
+ Visual *visuals; /* list of visuals possible at this depth */
+} Depth;
+
+/*
+ * Information about the screen. The contents of this structure are
+ * implementation dependent. A Screen should be treated as opaque
+ * by application code.
+ */
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ struct _XDisplay *display;/* back pointer to display structure */
+ Window root; /* Root window id. */
+ int width, height; /* width and height of screen */
+ int mwidth, mheight; /* width and height of in millimeters */
+ int ndepths; /* number of depths possible */
+ Depth *depths; /* list of allowable depths on the screen */
+ int root_depth; /* bits per pixel */
+ Visual *root_visual; /* root visual */
+ GC default_gc; /* GC for the root root visual */
+ Colormap cmap; /* default color map */
+ unsigned long white_pixel;
+ unsigned long black_pixel; /* White and Black pixel values */
+ int max_maps, min_maps; /* max and min color maps */
+ int backing_store; /* Never, WhenMapped, Always */
+ Bool save_unders;
+ long root_input_mask; /* initial root input mask */
+} Screen;
+
+/*
+ * Format structure; describes ZFormat data the screen will understand.
+ */
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ int depth; /* depth of this image format */
+ int bits_per_pixel; /* bits/pixel at this depth */
+ int scanline_pad; /* scanline must padded to this multiple */
+} ScreenFormat;
+
+/*
+ * Data structure for setting window attributes.
+ */
+typedef struct {
+ Pixmap background_pixmap; /* background or None or ParentRelative */
+ unsigned long background_pixel; /* background pixel */
+ Pixmap border_pixmap; /* border of the window */
+ unsigned long border_pixel; /* border pixel value */
+ int bit_gravity; /* one of bit gravity values */
+ int win_gravity; /* one of the window gravity values */
+ int backing_store; /* NotUseful, WhenMapped, Always */
+ unsigned long backing_planes;/* planes to be preseved if possible */
+ unsigned long backing_pixel;/* value to use in restoring planes */
+ Bool save_under; /* should bits under be saved? (popups) */
+ long event_mask; /* set of events that should be saved */
+ long do_not_propagate_mask; /* set of events that should not propagate */
+ Bool override_redirect; /* boolean value for override-redirect */
+ Colormap colormap; /* color map to be associated with window */
+ Cursor cursor; /* cursor to be displayed (or None) */
+} XSetWindowAttributes;
+
+typedef struct {
+ int x, y; /* location of window */
+ int width, height; /* width and height of window */
+ int border_width; /* border width of window */
+ int depth; /* depth of window */
+ Visual *visual; /* the associated visual structure */
+ Window root; /* root of screen containing window */
+#if defined(__cplusplus) || defined(c_plusplus)
+ int c_class; /* C++ InputOutput, InputOnly*/
+#else
+ int class; /* InputOutput, InputOnly*/
+#endif
+ int bit_gravity; /* one of bit gravity values */
+ int win_gravity; /* one of the window gravity values */
+ int backing_store; /* NotUseful, WhenMapped, Always */
+ unsigned long backing_planes;/* planes to be preserved if possible */
+ unsigned long backing_pixel;/* value to be used when restoring planes */
+ Bool save_under; /* boolean, should bits under be saved? */
+ Colormap colormap; /* color map to be associated with window */
+ Bool map_installed; /* boolean, is color map currently installed*/
+ int map_state; /* IsUnmapped, IsUnviewable, IsViewable */
+ long all_event_masks; /* set of events all people have interest in*/
+ long your_event_mask; /* my event mask */
+ long do_not_propagate_mask; /* set of events that should not propagate */
+ Bool override_redirect; /* boolean value for override-redirect */
+ Screen *screen; /* back pointer to correct screen */
+} XWindowAttributes;
+
+/*
+ * Data structure for host setting; getting routines.
+ *
+ */
+
+typedef struct {
+ int family; /* for example FamilyInternet */
+ int length; /* length of address, in bytes */
+ char *address; /* pointer to where to find the bytes */
+} XHostAddress;
+
+/*
+ * Data structure for "image" data, used by image manipulation routines.
+ */
+typedef struct _XImage {
+ int width, height; /* size of image */
+ int xoffset; /* number of pixels offset in X direction */
+ int format; /* XYBitmap, XYPixmap, ZPixmap */
+ char *data; /* pointer to image data */
+ int byte_order; /* data byte order, LSBFirst, MSBFirst */
+ int bitmap_unit; /* quant. of scanline 8, 16, 32 */
+ int bitmap_bit_order; /* LSBFirst, MSBFirst */
+ int bitmap_pad; /* 8, 16, 32 either XY or ZPixmap */
+ int depth; /* depth of image */
+ int bytes_per_line; /* accelarator to next line */
+ int bits_per_pixel; /* bits per pixel (ZPixmap) */
+ unsigned long red_mask; /* bits in z arrangment */
+ unsigned long green_mask;
+ unsigned long blue_mask;
+ XPointer obdata; /* hook for the object routines to hang on */
+ struct funcs { /* image manipulation routines */
+ struct _XImage *(*create_image)();
+#if NeedFunctionPrototypes
+ int (*destroy_image) (struct _XImage *);
+ unsigned long (*get_pixel) (struct _XImage *, int, int);
+ int (*put_pixel) (struct _XImage *, int, int, unsigned long);
+ struct _XImage *(*sub_image)(struct _XImage *, int, int, unsigned int, unsigned int);
+ int (*add_pixel) (struct _XImage *, long);
+#else
+ int (*destroy_image)();
+ unsigned long (*get_pixel)();
+ int (*put_pixel)();
+ struct _XImage *(*sub_image)();
+ int (*add_pixel)();
+#endif
+ } f;
+} XImage;
+
+/*
+ * Data structure for XReconfigureWindow
+ */
+typedef struct {
+ int x, y;
+ int width, height;
+ int border_width;
+ Window sibling;
+ int stack_mode;
+} XWindowChanges;
+
+/*
+ * Data structure used by color operations
+ */
+typedef struct {
+ unsigned long pixel;
+ unsigned short red, green, blue;
+ char flags; /* do_red, do_green, do_blue */
+ char pad;
+} XColor;
+
+/*
+ * Data structures for graphics operations. On most machines, these are
+ * congruent with the wire protocol structures, so reformatting the data
+ * can be avoided on these architectures.
+ */
+typedef struct {
+ short x1, y1, x2, y2;
+} XSegment;
+
+typedef struct {
+ short x, y;
+} XPoint;
+
+typedef struct {
+ short x, y;
+ unsigned short width, height;
+} XRectangle;
+
+typedef struct {
+ short x, y;
+ unsigned short width, height;
+ short angle1, angle2;
+} XArc;
+
+
+/* Data structure for XChangeKeyboardControl */
+
+typedef struct {
+ int key_click_percent;
+ int bell_percent;
+ int bell_pitch;
+ int bell_duration;
+ int led;
+ int led_mode;
+ int key;
+ int auto_repeat_mode; /* On, Off, Default */
+} XKeyboardControl;
+
+/* Data structure for XGetKeyboardControl */
+
+typedef struct {
+ int key_click_percent;
+ int bell_percent;
+ unsigned int bell_pitch, bell_duration;
+ unsigned long led_mask;
+ int global_auto_repeat;
+ char auto_repeats[32];
+} XKeyboardState;
+
+/* Data structure for XGetMotionEvents. */
+
+typedef struct {
+ Time time;
+ short x, y;
+} XTimeCoord;
+
+/* Data structure for X{Set,Get}ModifierMapping */
+
+typedef struct {
+ int max_keypermod; /* The server's max # of keys per modifier */
+ KeyCode *modifiermap; /* An 8 by max_keypermod array of modifiers */
+} XModifierKeymap;
+
+
+/*
+ * Display datatype maintaining display specific data.
+ * The contents of this structure are implementation dependent.
+ * A Display should be treated as opaque by application code.
+ */
+typedef struct _XDisplay {
+ XExtData *ext_data; /* hook for extension to hang data */
+ struct _XFreeFuncs *free_funcs; /* internal free functions */
+ int fd; /* Network socket. */
+ int conn_checker; /* ugly thing used by _XEventsQueued */
+ int proto_major_version;/* maj. version of server's X protocol */
+ int proto_minor_version;/* minor version of servers X protocol */
+ char *vendor; /* vendor of the server hardware */
+ XID resource_base; /* resource ID base */
+ XID resource_mask; /* resource ID mask bits */
+ XID resource_id; /* allocator current ID */
+ int resource_shift; /* allocator shift to correct bits */
+ XID (*resource_alloc)(); /* allocator function */
+ int byte_order; /* screen byte order, LSBFirst, MSBFirst */
+ int bitmap_unit; /* padding and data requirements */
+ int bitmap_pad; /* padding requirements on bitmaps */
+ int bitmap_bit_order; /* LeastSignificant or MostSignificant */
+ int nformats; /* number of pixmap formats in list */
+ ScreenFormat *pixmap_format; /* pixmap format list */
+ int vnumber; /* Xlib's X protocol version number. */
+ int release; /* release of the server */
+ struct _XSQEvent *head, *tail; /* Input event queue. */
+ int qlen; /* Length of input event queue */
+ unsigned long last_request_read; /* seq number of last event read */
+ unsigned long request; /* sequence number of last request. */
+ char *last_req; /* beginning of last request, or dummy */
+ char *buffer; /* Output buffer starting address. */
+ char *bufptr; /* Output buffer index pointer. */
+ char *bufmax; /* Output buffer maximum+1 address. */
+ unsigned max_request_size; /* maximum number 32 bit words in request*/
+ struct _XrmHashBucketRec *db;
+ int (*synchandler)(); /* Synchronization handler */
+ char *display_name; /* "host:display" string used on this connect*/
+ int default_screen; /* default screen for operations */
+ int nscreens; /* number of screens on this server*/
+ Screen *screens; /* pointer to list of screens */
+ unsigned long motion_buffer; /* size of motion buffer */
+ unsigned long flags; /* internal connection flags */
+ int min_keycode; /* minimum defined keycode */
+ int max_keycode; /* maximum defined keycode */
+ KeySym *keysyms; /* This server's keysyms */
+ XModifierKeymap *modifiermap; /* This server's modifier keymap */
+ int keysyms_per_keycode;/* number of rows */
+ char *xdefaults; /* contents of defaults from server */
+ char *scratch_buffer; /* place to hang scratch buffer */
+ unsigned long scratch_length; /* length of scratch buffer */
+ int ext_number; /* extension number on this display */
+ struct _XExten *ext_procs; /* extensions initialized on this display */
+ /*
+ * the following can be fixed size, as the protocol defines how
+ * much address space is available.
+ * While this could be done using the extension vector, there
+ * may be MANY events processed, so a search through the extension
+ * list to find the right procedure for each event might be
+ * expensive if many extensions are being used.
+ */
+ Bool (*event_vec[128])(); /* vector for wire to event */
+ int (*wire_vec[128])(); /* vector for event to wire */
+ KeySym lock_meaning; /* for XLookupString */
+ struct _XLockInfo *lock; /* multi-thread state, display lock */
+ struct _XInternalAsync *async_handlers; /* for internal async */
+ unsigned long bigreq_size; /* max size of big requests */
+ struct _XLockPtrs *lock_fns; /* pointers to threads functions */
+ /* things above this line should not move, for binary compatibility */
+ struct _XKeytrans *key_bindings; /* for XLookupString */
+ Font cursor_font; /* for XCreateFontCursor */
+ struct _XDisplayAtoms *atoms; /* for XInternAtom */
+ unsigned int mode_switch; /* keyboard group modifiers */
+ struct _XContextDB *context_db; /* context database */
+ Bool (**error_vec)(); /* vector for wire to error */
+ /*
+ * Xcms information
+ */
+ struct {
+ XPointer defaultCCCs; /* pointer to an array of default XcmsCCC */
+ XPointer clientCmaps; /* pointer to linked list of XcmsCmapRec */
+ XPointer perVisualIntensityMaps;
+ /* linked list of XcmsIntensityMap */
+ } cms;
+ struct _XIMFilter *im_filters;
+ struct _XSQEvent *qfree; /* unallocated event queue elements */
+ unsigned long next_event_serial_num; /* inserted into next queue elt */
+ int (*savedsynchandler)(); /* user synchandler when Xlib usurps */
+} Display;
+
+#if NeedFunctionPrototypes /* prototypes require event type definitions */
+#undef _XEVENT_
+#endif
+#ifndef _XEVENT_
+
+#define XMaxTransChars 4
+
+/*
+ * Definitions of specific events.
+ */
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window it is reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ unsigned int state; /* key or button mask */
+ unsigned int keycode; /* detail */
+ Bool same_screen; /* same screen flag */
+ char trans_chars[XMaxTransChars];
+ /* translated characters */
+ int nbytes;
+} XKeyEvent;
+typedef XKeyEvent XKeyPressedEvent;
+typedef XKeyEvent XKeyReleasedEvent;
+
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window it is reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ unsigned int state; /* key or button mask */
+ unsigned int button; /* detail */
+ Bool same_screen; /* same screen flag */
+} XButtonEvent;
+typedef XButtonEvent XButtonPressedEvent;
+typedef XButtonEvent XButtonReleasedEvent;
+
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ unsigned int state; /* key or button mask */
+ char is_hint; /* detail */
+ Bool same_screen; /* same screen flag */
+} XMotionEvent;
+typedef XMotionEvent XPointerMovedEvent;
+
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ int mode; /* NotifyNormal, NotifyGrab, NotifyUngrab */
+ int detail;
+ /*
+ * NotifyAncestor, NotifyVirtual, NotifyInferior,
+ * NotifyNonlinear,NotifyNonlinearVirtual
+ */
+ Bool same_screen; /* same screen flag */
+ Bool focus; /* boolean focus */
+ unsigned int state; /* key or button mask */
+} XCrossingEvent;
+typedef XCrossingEvent XEnterWindowEvent;
+typedef XCrossingEvent XLeaveWindowEvent;
+
+typedef struct {
+ int type; /* FocusIn or FocusOut */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* window of event */
+ int mode; /* NotifyNormal, NotifyGrab, NotifyUngrab */
+ int detail;
+ /*
+ * NotifyAncestor, NotifyVirtual, NotifyInferior,
+ * NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer,
+ * NotifyPointerRoot, NotifyDetailNone
+ */
+} XFocusChangeEvent;
+typedef XFocusChangeEvent XFocusInEvent;
+typedef XFocusChangeEvent XFocusOutEvent;
+
+/* generated on EnterWindow and FocusIn when KeyMapState selected */
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ char key_vector[32];
+} XKeymapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ int x, y;
+ int width, height;
+ int count; /* if non-zero, at least this many more */
+} XExposeEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Drawable drawable;
+ int x, y;
+ int width, height;
+ int count; /* if non-zero, at least this many more */
+ int major_code; /* core is CopyArea or CopyPlane */
+ int minor_code; /* not defined in the core */
+} XGraphicsExposeEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Drawable drawable;
+ int major_code; /* core is CopyArea or CopyPlane */
+ int minor_code; /* not defined in the core */
+} XNoExposeEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ int state; /* Visibility state */
+} XVisibilityEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent; /* parent of the window */
+ Window window; /* window id of window created */
+ int x, y; /* window location */
+ int width, height; /* size of window */
+ int border_width; /* border width */
+ Bool override_redirect; /* creation should be overridden */
+} XCreateWindowEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+} XDestroyWindowEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ Bool from_configure;
+} XUnmapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ Bool override_redirect; /* boolean, is override set... */
+} XMapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent;
+ Window window;
+} XMapRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ Window parent;
+ int x, y;
+ Bool override_redirect;
+} XReparentEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ int x, y;
+ int width, height;
+ int border_width;
+ Window above;
+ Bool override_redirect;
+} XConfigureEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ int x, y;
+} XGravityEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ int width, height;
+} XResizeRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent;
+ Window window;
+ int x, y;
+ int width, height;
+ int border_width;
+ Window above;
+ int detail; /* Above, Below, TopIf, BottomIf, Opposite */
+ unsigned long value_mask;
+} XConfigureRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ int place; /* PlaceOnTop, PlaceOnBottom */
+} XCirculateEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent;
+ Window window;
+ int place; /* PlaceOnTop, PlaceOnBottom */
+} XCirculateRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Atom atom;
+ Time time;
+ int state; /* NewValue, Deleted */
+} XPropertyEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Atom selection;
+ Time time;
+} XSelectionClearEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window owner;
+ Window requestor;
+ Atom selection;
+ Atom target;
+ Atom property;
+ Time time;
+} XSelectionRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window requestor;
+ Atom selection;
+ Atom target;
+ Atom property; /* ATOM or None */
+ Time time;
+} XSelectionEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Colormap colormap; /* COLORMAP or None */
+#if defined(__cplusplus) || defined(c_plusplus)
+ Bool c_new; /* C++ */
+#else
+ Bool new;
+#endif
+ int state; /* ColormapInstalled, ColormapUninstalled */
+} XColormapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Atom message_type;
+ int format;
+ union {
+ char b[20];
+ short s[10];
+ long l[5];
+ } data;
+} XClientMessageEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* unused */
+ int request; /* one of MappingModifier, MappingKeyboard,
+ MappingPointer */
+ int first_keycode; /* first keycode */
+ int count; /* defines range of change w. first_keycode*/
+} XMappingEvent;
+
+typedef struct {
+ int type;
+ Display *display; /* Display the event was read from */
+ XID resourceid; /* resource id */
+ unsigned long serial; /* serial number of failed request */
+ unsigned char error_code; /* error code of failed request */
+ unsigned char request_code; /* Major op-code of failed request */
+ unsigned char minor_code; /* Minor op-code of failed request */
+} XErrorEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display;/* Display the event was read from */
+ Window window; /* window on which event was requested in event mask */
+} XAnyEvent;
+
+/*
+ * this union is defined so Xlib can always use the same sized
+ * event structure internally, to avoid memory fragmentation.
+ */
+typedef union _XEvent {
+ int type; /* must not be changed; first element */
+ XAnyEvent xany;
+ XKeyEvent xkey;
+ XButtonEvent xbutton;
+ XMotionEvent xmotion;
+ XCrossingEvent xcrossing;
+ XFocusChangeEvent xfocus;
+ XExposeEvent xexpose;
+ XGraphicsExposeEvent xgraphicsexpose;
+ XNoExposeEvent xnoexpose;
+ XVisibilityEvent xvisibility;
+ XCreateWindowEvent xcreatewindow;
+ XDestroyWindowEvent xdestroywindow;
+ XUnmapEvent xunmap;
+ XMapEvent xmap;
+ XMapRequestEvent xmaprequest;
+ XReparentEvent xreparent;
+ XConfigureEvent xconfigure;
+ XGravityEvent xgravity;
+ XResizeRequestEvent xresizerequest;
+ XConfigureRequestEvent xconfigurerequest;
+ XCirculateEvent xcirculate;
+ XCirculateRequestEvent xcirculaterequest;
+ XPropertyEvent xproperty;
+ XSelectionClearEvent xselectionclear;
+ XSelectionRequestEvent xselectionrequest;
+ XSelectionEvent xselection;
+ XColormapEvent xcolormap;
+ XClientMessageEvent xclient;
+ XMappingEvent xmapping;
+ XErrorEvent xerror;
+ XKeymapEvent xkeymap;
+ long pad[24];
+} XEvent;
+#endif
+
+#define XAllocID(dpy) ((*(dpy)->resource_alloc)((dpy)))
+
+/*
+ * per character font metric information.
+ */
+typedef struct {
+ short lbearing; /* origin to left edge of raster */
+ short rbearing; /* origin to right edge of raster */
+ short width; /* advance to next char's origin */
+ short ascent; /* baseline to top edge of raster */
+ short descent; /* baseline to bottom edge of raster */
+ unsigned short attributes; /* per char flags (not predefined) */
+} XCharStruct;
+
+/*
+ * To allow arbitrary information with fonts, there are additional properties
+ * returned.
+ */
+typedef struct {
+ Atom name;
+ unsigned long card32;
+} XFontProp;
+
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ Font fid; /* Font id for this font */
+ unsigned direction; /* hint about direction the font is painted */
+ unsigned min_char_or_byte2;/* first character */
+ unsigned max_char_or_byte2;/* last character */
+ unsigned min_byte1; /* first row that exists */
+ unsigned max_byte1; /* last row that exists */
+ Bool all_chars_exist;/* flag if all characters have non-zero size*/
+ unsigned default_char; /* char to print for undefined character */
+ int n_properties; /* how many properties there are */
+ XFontProp *properties; /* pointer to array of additional properties*/
+ XCharStruct min_bounds; /* minimum bounds over all existing char*/
+ XCharStruct max_bounds; /* maximum bounds over all existing char*/
+ XCharStruct *per_char; /* first_char to last_char information */
+ int ascent; /* log. extent above baseline for spacing */
+ int descent; /* log. descent below baseline for spacing */
+} XFontStruct;
+
+/*
+ * PolyText routines take these as arguments.
+ */
+typedef struct {
+ char *chars; /* pointer to string */
+ int nchars; /* number of characters */
+ int delta; /* delta between strings */
+ Font font; /* font to print it in, None don't change */
+} XTextItem;
+
+typedef struct { /* normal 16 bit characters are two bytes */
+ unsigned char byte1;
+ unsigned char byte2;
+} XChar2b;
+
+typedef struct {
+ XChar2b *chars; /* two byte characters */
+ int nchars; /* number of characters */
+ int delta; /* delta between strings */
+ Font font; /* font to print it in, None don't change */
+} XTextItem16;
+
+
+typedef union { Display *display;
+ GC gc;
+ Visual *visual;
+ Screen *screen;
+ ScreenFormat *pixmap_format;
+ XFontStruct *font; } XEDataObject;
+
+typedef struct {
+ XRectangle max_ink_extent;
+ XRectangle max_logical_extent;
+} XFontSetExtents;
+
+typedef struct _XFontSet *XFontSet;
+
+typedef struct {
+ char *chars;
+ int nchars;
+ int delta;
+ XFontSet font_set;
+} XmbTextItem;
+
+typedef struct {
+ wchar_t *chars;
+ int nchars;
+ int delta;
+ XFontSet font_set;
+} XwcTextItem;
+
+typedef void (*XIMProc)();
+
+typedef struct _XIM *XIM;
+typedef struct _XIC *XIC;
+
+typedef unsigned long XIMStyle;
+
+typedef struct {
+ unsigned short count_styles;
+ XIMStyle *supported_styles;
+} XIMStyles;
+
+#define XIMPreeditArea 0x0001L
+#define XIMPreeditCallbacks 0x0002L
+#define XIMPreeditPosition 0x0004L
+#define XIMPreeditNothing 0x0008L
+#define XIMPreeditNone 0x0010L
+#define XIMStatusArea 0x0100L
+#define XIMStatusCallbacks 0x0200L
+#define XIMStatusNothing 0x0400L
+#define XIMStatusNone 0x0800L
+
+#define XNVaNestedList "XNVaNestedList"
+#define XNClientWindow "clientWindow"
+#define XNInputStyle "inputStyle"
+#define XNFocusWindow "focusWindow"
+#define XNResourceName "resourceName"
+#define XNResourceClass "resourceClass"
+#define XNGeometryCallback "geometryCallback"
+#define XNFilterEvents "filterEvents"
+#define XNPreeditStartCallback "preeditStartCallback"
+#define XNPreeditDoneCallback "preeditDoneCallback"
+#define XNPreeditDrawCallback "preeditDrawCallback"
+#define XNPreeditCaretCallback "preeditCaretCallback"
+#define XNPreeditAttributes "preeditAttributes"
+#define XNStatusStartCallback "statusStartCallback"
+#define XNStatusDoneCallback "statusDoneCallback"
+#define XNStatusDrawCallback "statusDrawCallback"
+#define XNStatusAttributes "statusAttributes"
+#define XNArea "area"
+#define XNAreaNeeded "areaNeeded"
+#define XNSpotLocation "spotLocation"
+#define XNColormap "colorMap"
+#define XNStdColormap "stdColorMap"
+#define XNForeground "foreground"
+#define XNBackground "background"
+#define XNBackgroundPixmap "backgroundPixmap"
+#define XNFontSet "fontSet"
+#define XNLineSpace "lineSpace"
+#define XNCursor "cursor"
+
+#define XBufferOverflow -1
+#define XLookupNone 1
+#define XLookupChars 2
+#define XLookupKeySym 3
+#define XLookupBoth 4
+
+#if NeedFunctionPrototypes
+typedef void *XVaNestedList;
+#else
+typedef XPointer XVaNestedList;
+#endif
+
+typedef struct {
+ XPointer client_data;
+ XIMProc callback;
+} XIMCallback;
+
+typedef unsigned long XIMFeedback;
+
+#define XIMReverse 1
+#define XIMUnderline (1<<1)
+#define XIMHighlight (1<<2)
+#define XIMPrimary (1<<5)
+#define XIMSecondary (1<<6)
+#define XIMTertiary (1<<7)
+
+typedef struct _XIMText {
+ unsigned short length;
+ XIMFeedback *feedback;
+ Bool encoding_is_wchar;
+ union {
+ char *multi_byte;
+ wchar_t *wide_char;
+ } string;
+} XIMText;
+
+typedef struct _XIMPreeditDrawCallbackStruct {
+ int caret; /* Cursor offset within pre-edit string */
+ int chg_first; /* Starting change position */
+ int chg_length; /* Length of the change in character count */
+ XIMText *text;
+} XIMPreeditDrawCallbackStruct;
+
+typedef enum {
+ XIMForwardChar, XIMBackwardChar,
+ XIMForwardWord, XIMBackwardWord,
+ XIMCaretUp, XIMCaretDown,
+ XIMNextLine, XIMPreviousLine,
+ XIMLineStart, XIMLineEnd,
+ XIMAbsolutePosition,
+ XIMDontChange
+} XIMCaretDirection;
+
+typedef enum {
+ XIMIsInvisible, /* Disable caret feedback */
+ XIMIsPrimary, /* UI defined caret feedback */
+ XIMIsSecondary /* UI defined caret feedback */
+} XIMCaretStyle;
+
+typedef struct _XIMPreeditCaretCallbackStruct {
+ int position; /* Caret offset within pre-edit string */
+ XIMCaretDirection direction; /* Caret moves direction */
+ XIMCaretStyle style; /* Feedback of the caret */
+} XIMPreeditCaretCallbackStruct;
+
+typedef enum {
+ XIMTextType,
+ XIMBitmapType
+} XIMStatusDataType;
+
+typedef struct _XIMStatusDrawCallbackStruct {
+ XIMStatusDataType type;
+ union {
+ XIMText *text;
+ Pixmap bitmap;
+ } data;
+} XIMStatusDrawCallbackStruct;
+
+typedef int (*XErrorHandler) ( /* WARNING, this type not in Xlib spec */
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XErrorEvent* /* error_event */
+#endif
+);
+
+_XFUNCPROTOBEGIN
+
+
+
+#include "../../../pTk/tkIntXlibDecls.h"
+
+_XFUNCPROTOEND
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# undef Cursor
+#endif
+
+#endif /* _XLIB_H_ */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xutil.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xutil.h
new file mode 100755
index 00000000000..af44e0e9c2e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/Xutil.h
@@ -0,0 +1,855 @@
+/* $XConsortium: Xutil.h,v 11.73 91/07/30 16:21:37 rws Exp $ */
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+
+#ifndef _XUTIL_H_
+#define _XUTIL_H_
+
+/* You must include <X11/Xlib.h> before including this file */
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# define Region XRegion
+#endif
+
+/*
+ * Bitmask returned by XParseGeometry(). Each bit tells if the corresponding
+ * value (x, y, width, height) was found in the parsed string.
+ */
+#define NoValue 0x0000
+#define XValue 0x0001
+#define YValue 0x0002
+#define WidthValue 0x0004
+#define HeightValue 0x0008
+#define AllValues 0x000F
+#define XNegative 0x0010
+#define YNegative 0x0020
+
+/*
+ * new version containing base_width, base_height, and win_gravity fields;
+ * used with WM_NORMAL_HINTS.
+ */
+typedef struct {
+ long flags; /* marks which fields in this structure are defined */
+ int x, y; /* obsolete for new window mgrs, but clients */
+ int width, height; /* should set so old wm's don't mess up */
+ int min_width, min_height;
+ int max_width, max_height;
+ int width_inc, height_inc;
+ struct {
+ int x; /* numerator */
+ int y; /* denominator */
+ } min_aspect, max_aspect;
+ int base_width, base_height; /* added by ICCCM version 1 */
+ int win_gravity; /* added by ICCCM version 1 */
+} XSizeHints;
+
+/*
+ * The next block of definitions are for window manager properties that
+ * clients and applications use for communication.
+ */
+
+/* flags argument in size hints */
+#define USPosition (1L << 0) /* user specified x, y */
+#define USSize (1L << 1) /* user specified width, height */
+
+#define PPosition (1L << 2) /* program specified position */
+#define PSize (1L << 3) /* program specified size */
+#define PMinSize (1L << 4) /* program specified minimum size */
+#define PMaxSize (1L << 5) /* program specified maximum size */
+#define PResizeInc (1L << 6) /* program specified resize increments */
+#define PAspect (1L << 7) /* program specified min and max aspect ratios */
+#define PBaseSize (1L << 8) /* program specified base for incrementing */
+#define PWinGravity (1L << 9) /* program specified window gravity */
+
+/* obsolete */
+#define PAllHints (PPosition|PSize|PMinSize|PMaxSize|PResizeInc|PAspect)
+
+
+
+typedef struct {
+ long flags; /* marks which fields in this structure are defined */
+ Bool input; /* does this application rely on the window manager to
+ get keyboard input? */
+ int initial_state; /* see below */
+ Pixmap icon_pixmap; /* pixmap to be used as icon */
+ Window icon_window; /* window to be used as icon */
+ int icon_x, icon_y; /* initial position of icon */
+ Pixmap icon_mask; /* icon mask bitmap */
+ XID window_group; /* id of related window group */
+ /* this structure may be extended in the future */
+} XWMHints;
+
+/* definition for flags of XWMHints */
+
+#define InputHint (1L << 0)
+#define StateHint (1L << 1)
+#define IconPixmapHint (1L << 2)
+#define IconWindowHint (1L << 3)
+#define IconPositionHint (1L << 4)
+#define IconMaskHint (1L << 5)
+#define WindowGroupHint (1L << 6)
+#define AllHints (InputHint|StateHint|IconPixmapHint|IconWindowHint| \
+IconPositionHint|IconMaskHint|WindowGroupHint)
+
+/* definitions for initial window state */
+#define WithdrawnState 0 /* for windows that are not mapped */
+#define NormalState 1 /* most applications want to start this way */
+#define IconicState 3 /* application wants to start as an icon */
+
+/*
+ * Obsolete states no longer defined by ICCCM
+ */
+#define DontCareState 0 /* don't know or care */
+#define ZoomState 2 /* application wants to start zoomed */
+#define InactiveState 4 /* application believes it is seldom used; */
+ /* some wm's may put it on inactive menu */
+
+
+/*
+ * new structure for manipulating TEXT properties; used with WM_NAME,
+ * WM_ICON_NAME, WM_CLIENT_MACHINE, and WM_COMMAND.
+ */
+typedef struct {
+ unsigned char *value; /* same as Property routines */
+ Atom encoding; /* prop type */
+ int format; /* prop data format: 8, 16, or 32 */
+ unsigned long nitems; /* number of data items in value */
+} XTextProperty;
+
+#define XNoMemory -1
+#define XLocaleNotSupported -2
+#define XConverterNotFound -3
+
+typedef enum {
+ XStringStyle, /* STRING */
+ XCompoundTextStyle, /* COMPOUND_TEXT */
+ XTextStyle, /* text in owner's encoding (current locale)*/
+ XStdICCTextStyle /* STRING, else COMPOUND_TEXT */
+} XICCEncodingStyle;
+
+typedef struct {
+ int min_width, min_height;
+ int max_width, max_height;
+ int width_inc, height_inc;
+} XIconSize;
+
+typedef struct {
+ char *res_name;
+ char *res_class;
+} XClassHint;
+
+/*
+ * These macros are used to give some sugar to the image routines so that
+ * naive people are more comfortable with them.
+ */
+#define XDestroyImage(ximage) \
+ ((*((ximage)->f.destroy_image))((ximage)))
+#define XGetPixel(ximage, x, y) \
+ ((*((ximage)->f.get_pixel))((ximage), (x), (y)))
+#define XPutPixel(ximage, x, y, pixel) \
+ ((*((ximage)->f.put_pixel))((ximage), (x), (y), (pixel)))
+#define XSubImage(ximage, x, y, width, height) \
+ ((*((ximage)->f.sub_image))((ximage), (x), (y), (width), (height)))
+#define XAddPixel(ximage, value) \
+ ((*((ximage)->f.add_pixel))((ximage), (value)))
+
+/*
+ * Compose sequence status structure, used in calling XLookupString.
+ */
+typedef struct _XComposeStatus {
+ XPointer compose_ptr; /* state table pointer */
+ int chars_matched; /* match state */
+} XComposeStatus;
+
+/*
+ * Keysym macros, used on Keysyms to test for classes of symbols
+ */
+#define IsKeypadKey(keysym) \
+ (((unsigned)(keysym) >= XK_KP_Space) && ((unsigned)(keysym) <= XK_KP_Equal))
+
+#define IsCursorKey(keysym) \
+ (((unsigned)(keysym) >= XK_Home) && ((unsigned)(keysym) < XK_Select))
+
+#define IsPFKey(keysym) \
+ (((unsigned)(keysym) >= XK_KP_F1) && ((unsigned)(keysym) <= XK_KP_F4))
+
+#define IsFunctionKey(keysym) \
+ (((unsigned)(keysym) >= XK_F1) && ((unsigned)(keysym) <= XK_F35))
+
+#define IsMiscFunctionKey(keysym) \
+ (((unsigned)(keysym) >= XK_Select) && ((unsigned)(keysym) <= XK_Break))
+
+#define IsModifierKey(keysym) \
+ ((((unsigned)(keysym) >= XK_Shift_L) && ((unsigned)(keysym) <= XK_Hyper_R)) \
+ || ((unsigned)(keysym) == XK_Mode_switch) \
+ || ((unsigned)(keysym) == XK_Num_Lock))
+/*
+ * opaque reference to Region data type
+ */
+typedef struct _XRegion *Region;
+
+/* Return values from XRectInRegion() */
+
+#define RectangleOut 0
+#define RectangleIn 1
+#define RectanglePart 2
+
+
+/*
+ * Information used by the visual utility routines to find desired visual
+ * type from the many visuals a display may support.
+ */
+
+typedef struct {
+ Visual *visual;
+ VisualID visualid;
+ int screen;
+ int depth;
+#if defined(__cplusplus) || defined(c_plusplus)
+ int c_class; /* C++ */
+#else
+ int class;
+#endif
+ unsigned long red_mask;
+ unsigned long green_mask;
+ unsigned long blue_mask;
+ int colormap_size;
+ int bits_per_rgb;
+} XVisualInfo;
+
+#define VisualNoMask 0x0
+#define VisualIDMask 0x1
+#define VisualScreenMask 0x2
+#define VisualDepthMask 0x4
+#define VisualClassMask 0x8
+#define VisualRedMaskMask 0x10
+#define VisualGreenMaskMask 0x20
+#define VisualBlueMaskMask 0x40
+#define VisualColormapSizeMask 0x80
+#define VisualBitsPerRGBMask 0x100
+#define VisualAllMask 0x1FF
+
+/*
+ * This defines a window manager property that clients may use to
+ * share standard color maps of type RGB_COLOR_MAP:
+ */
+typedef struct {
+ Colormap colormap;
+ unsigned long red_max;
+ unsigned long red_mult;
+ unsigned long green_max;
+ unsigned long green_mult;
+ unsigned long blue_max;
+ unsigned long blue_mult;
+ unsigned long base_pixel;
+ VisualID visualid; /* added by ICCCM version 1 */
+ XID killid; /* added by ICCCM version 1 */
+} XStandardColormap;
+
+#define ReleaseByFreeingColormap ((XID) 1L) /* for killid field above */
+
+
+/*
+ * return codes for XReadBitmapFile and XWriteBitmapFile
+ */
+#define BitmapSuccess 0
+#define BitmapOpenFailed 1
+#define BitmapFileInvalid 2
+#define BitmapNoMemory 3
+
+/****************************************************************
+ *
+ * Context Management
+ *
+ ****************************************************************/
+
+
+/* Associative lookup table return codes */
+
+#define XCSUCCESS 0 /* No error. */
+#define XCNOMEM 1 /* Out of memory */
+#define XCNOENT 2 /* No entry in table */
+
+typedef int XContext;
+
+#define XUniqueContext() ((XContext) XrmUniqueQuark())
+#define XStringToContext(string) ((XContext) XrmStringToQuark(string))
+
+_XFUNCPROTOBEGIN
+
+/* The following declarations are alphabetized. */
+
+extern XClassHint *XAllocClassHint (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XIconSize *XAllocIconSize (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XSizeHints *XAllocSizeHints (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XStandardColormap *XAllocStandardColormap (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XWMHints *XAllocWMHints (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern void XClipBox(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ XRectangle* /* rect_return */
+#endif
+);
+
+extern Region XCreateRegion(
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern char *XDefaultString(
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern int XDeleteContext(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XID /* rid */,
+ XContext /* context */
+#endif
+);
+
+extern void XDestroyRegion(
+#if NeedFunctionPrototypes
+ Region /* r */
+#endif
+);
+
+extern void XEmptyRegion(
+#if NeedFunctionPrototypes
+ Region /* r */
+#endif
+);
+
+extern void XEqualRegion(
+#if NeedFunctionPrototypes
+ Region /* r1 */,
+ Region /* r2 */
+#endif
+);
+
+extern int XFindContext(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XID /* rid */,
+ XContext /* context */,
+ XPointer* /* data_return */
+#endif
+);
+
+extern int XGetClassHint(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XClassHint* /* class_hints_return */
+#endif
+);
+
+extern int XGetIconSizes(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XIconSize** /* size_list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern int XGetNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */
+#endif
+);
+
+extern int XGetRGBColormaps(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap** /* stdcmap_return */,
+ int* /* count_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetStandardColormap(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap* /* colormap_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* window */,
+ XTextProperty* /* text_prop_return */,
+ Atom /* property */
+#endif
+);
+
+
+extern int XGetWMClientMachine(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern XWMHints *XGetWMHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */
+#endif
+);
+
+extern int XGetWMIconName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern int XGetWMName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern int XGetWMNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */,
+ long* /* supplied_return */
+#endif
+);
+
+extern int XGetWMSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */,
+ long* /* supplied_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetZoomHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* zhints_return */
+#endif
+);
+
+extern void XIntersectRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+extern int XLookupString(
+#if NeedFunctionPrototypes
+ XKeyEvent* /* event_struct */,
+ char* /* buffer_return */,
+ int /* bytes_buffer */,
+ KeySym* /* keysym_return */,
+ XComposeStatus* /* status_in_out */
+#endif
+);
+
+extern int XMatchVisualInfo(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ int /* screen */,
+ int /* depth */,
+ int /* class */,
+ XVisualInfo* /* vinfo_return */
+#endif
+);
+
+extern void XOffsetRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* dx */,
+ int /* dy */
+#endif
+);
+
+extern Bool XPointInRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* x */,
+ int /* y */
+#endif
+);
+
+extern Region XPolygonRegion(
+#if NeedFunctionPrototypes
+ XPoint* /* points */,
+ int /* n */,
+ int /* fill_rule */
+#endif
+);
+
+extern int XRectInRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* x */,
+ int /* y */,
+ unsigned int /* width */,
+ unsigned int /* height */
+#endif
+);
+
+extern int XSaveContext(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XID /* rid */,
+ XContext /* context */,
+ _Xconst char* /* data */
+#endif
+);
+
+extern void XSetClassHint(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XClassHint* /* class_hints */
+#endif
+);
+
+extern void XSetIconSizes(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XIconSize* /* size_list */,
+ int /* count */
+#endif
+);
+
+extern void XSetNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */
+#endif
+);
+
+extern void XSetRGBColormaps(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap* /* stdcmaps */,
+ int /* count */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetStandardProperties(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ _Xconst char* /* window_name */,
+ _Xconst char* /* icon_name */,
+ Pixmap /* icon_pixmap */,
+ char** /* argv */,
+ int /* argc */,
+ XSizeHints* /* hints */
+#endif
+);
+
+extern void XSetTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetWMHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XWMHints* /* wm_hints */
+#endif
+);
+
+extern void XSetWMIconName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop */
+#endif
+);
+
+extern void XSetWMName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop */
+#endif
+);
+
+extern void XSetWMNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */
+#endif
+);
+
+extern void XSetWMProperties(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* window_name */,
+ XTextProperty* /* icon_name */,
+ char** /* argv */,
+ int /* argc */,
+ XSizeHints* /* normal_hints */,
+ XWMHints* /* wm_hints */,
+ XClassHint* /* class_hints */
+#endif
+);
+
+extern void XmbSetWMProperties(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ _Xconst char* /* window_name */,
+ _Xconst char* /* icon_name */,
+ char** /* argv */,
+ int /* argc */,
+ XSizeHints* /* normal_hints */,
+ XWMHints* /* wm_hints */,
+ XClassHint* /* class_hints */
+#endif
+);
+
+extern void XSetWMSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetRegion(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ GC /* gc */,
+ Region /* r */
+#endif
+);
+
+extern void XSetStandardColormap(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap* /* colormap */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetZoomHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* zhints */
+#endif
+);
+
+extern void XShrinkRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* dx */,
+ int /* dy */
+#endif
+);
+
+extern void XSubtractRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+extern int XmbTextListToTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ char** /* list */,
+ int /* count */,
+ XICCEncodingStyle /* style */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern int XwcTextListToTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ wchar_t** /* list */,
+ int /* count */,
+ XICCEncodingStyle /* style */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern void XwcFreeStringList(
+#if NeedFunctionPrototypes
+ wchar_t** /* list */
+#endif
+);
+
+extern int XTextPropertyToStringList(
+#if NeedFunctionPrototypes
+ XTextProperty* /* text_prop */,
+ char*** /* list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern int XmbTextPropertyToTextList(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XTextProperty* /* text_prop */,
+ char*** /* list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern int XwcTextPropertyToTextList(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XTextProperty* /* text_prop */,
+ wchar_t*** /* list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern void XUnionRectWithRegion(
+#if NeedFunctionPrototypes
+ XRectangle* /* rectangle */,
+ Region /* src_region */,
+ Region /* dest_region_return */
+#endif
+);
+
+extern void XUnionRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+extern int XWMGeometry(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ int /* screen_number */,
+ _Xconst char* /* user_geometry */,
+ _Xconst char* /* default_geometry */,
+ unsigned int /* border_width */,
+ XSizeHints* /* hints */,
+ int* /* x_return */,
+ int* /* y_return */,
+ int* /* width_return */,
+ int* /* height_return */,
+ int* /* gravity_return */
+#endif
+);
+
+extern void XXorRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+_XFUNCPROTOEND
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# undef Region
+#endif
+
+#endif /* _XUTIL_H_ */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/cursorfont.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/cursorfont.h
new file mode 100755
index 00000000000..617274fa806
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/cursorfont.h
@@ -0,0 +1,79 @@
+/* $XConsortium: cursorfont.h,v 1.2 88/09/06 16:44:27 jim Exp $ */
+#define XC_num_glyphs 154
+#define XC_X_cursor 0
+#define XC_arrow 2
+#define XC_based_arrow_down 4
+#define XC_based_arrow_up 6
+#define XC_boat 8
+#define XC_bogosity 10
+#define XC_bottom_left_corner 12
+#define XC_bottom_right_corner 14
+#define XC_bottom_side 16
+#define XC_bottom_tee 18
+#define XC_box_spiral 20
+#define XC_center_ptr 22
+#define XC_circle 24
+#define XC_clock 26
+#define XC_coffee_mug 28
+#define XC_cross 30
+#define XC_cross_reverse 32
+#define XC_crosshair 34
+#define XC_diamond_cross 36
+#define XC_dot 38
+#define XC_dotbox 40
+#define XC_double_arrow 42
+#define XC_draft_large 44
+#define XC_draft_small 46
+#define XC_draped_box 48
+#define XC_exchange 50
+#define XC_fleur 52
+#define XC_gobbler 54
+#define XC_gumby 56
+#define XC_hand1 58
+#define XC_hand2 60
+#define XC_heart 62
+#define XC_icon 64
+#define XC_iron_cross 66
+#define XC_left_ptr 68
+#define XC_left_side 70
+#define XC_left_tee 72
+#define XC_leftbutton 74
+#define XC_ll_angle 76
+#define XC_lr_angle 78
+#define XC_man 80
+#define XC_middlebutton 82
+#define XC_mouse 84
+#define XC_pencil 86
+#define XC_pirate 88
+#define XC_plus 90
+#define XC_question_arrow 92
+#define XC_right_ptr 94
+#define XC_right_side 96
+#define XC_right_tee 98
+#define XC_rightbutton 100
+#define XC_rtl_logo 102
+#define XC_sailboat 104
+#define XC_sb_down_arrow 106
+#define XC_sb_h_double_arrow 108
+#define XC_sb_left_arrow 110
+#define XC_sb_right_arrow 112
+#define XC_sb_up_arrow 114
+#define XC_sb_v_double_arrow 116
+#define XC_shuttle 118
+#define XC_sizing 120
+#define XC_spider 122
+#define XC_spraycan 124
+#define XC_star 126
+#define XC_target 128
+#define XC_tcross 130
+#define XC_top_left_arrow 132
+#define XC_top_left_corner 134
+#define XC_top_right_corner 136
+#define XC_top_side 138
+#define XC_top_tee 140
+#define XC_trek 142
+#define XC_ul_angle 144
+#define XC_umbrella 146
+#define XC_ur_angle 148
+#define XC_watch 150
+#define XC_xterm 152
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/keysym.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/keysym.h
new file mode 100755
index 00000000000..027afe08d5f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/keysym.h
@@ -0,0 +1,39 @@
+/* $XConsortium: keysym.h,v 1.13 91/03/13 20:09:49 rws Exp $ */
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+
+/* default keysyms */
+#define XK_MISCELLANY
+#define XK_LATIN1
+#define XK_LATIN2
+#define XK_LATIN3
+#define XK_LATIN4
+#define XK_GREEK
+
+#ifdef MAC_TCL
+#include <keysymdef.h>
+#else
+#include <X11/keysymdef.h>
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/keysymdef.h b/Master/tlpkg/tlperl.straw/lib/Tk/X11/keysymdef.h
new file mode 100755
index 00000000000..b22d41b3385
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/keysymdef.h
@@ -0,0 +1,1169 @@
+/* $XConsortium: keysymdef.h,v 1.15 93/04/02 10:57:36 rws Exp $ */
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+
+#define XK_VoidSymbol 0xFFFFFF /* void symbol */
+
+#ifdef XK_MISCELLANY
+/*
+ * TTY Functions, cleverly chosen to map to ascii, for convenience of
+ * programming, but could have been arbitrary (at the cost of lookup
+ * tables in client code.
+ */
+
+#define XK_BackSpace 0xFF08 /* back space, back char */
+#define XK_Tab 0xFF09
+#define XK_Linefeed 0xFF0A /* Linefeed, LF */
+#define XK_Clear 0xFF0B
+#define XK_Return 0xFF0D /* Return, enter */
+#define XK_Pause 0xFF13 /* Pause, hold */
+#define XK_Scroll_Lock 0xFF14
+#define XK_Sys_Req 0xFF15
+#define XK_Escape 0xFF1B
+#define XK_Delete 0xFFFF /* Delete, rubout */
+
+
+
+/* International & multi-key character composition */
+
+#define XK_Multi_key 0xFF20 /* Multi-key character compose */
+
+/* Japanese keyboard support */
+
+#define XK_Kanji 0xFF21 /* Kanji, Kanji convert */
+#define XK_Muhenkan 0xFF22 /* Cancel Conversion */
+#define XK_Henkan_Mode 0xFF23 /* Start/Stop Conversion */
+#define XK_Henkan 0xFF23 /* Alias for Henkan_Mode */
+#define XK_Romaji 0xFF24 /* to Romaji */
+#define XK_Hiragana 0xFF25 /* to Hiragana */
+#define XK_Katakana 0xFF26 /* to Katakana */
+#define XK_Hiragana_Katakana 0xFF27 /* Hiragana/Katakana toggle */
+#define XK_Zenkaku 0xFF28 /* to Zenkaku */
+#define XK_Hankaku 0xFF29 /* to Hankaku */
+#define XK_Zenkaku_Hankaku 0xFF2A /* Zenkaku/Hankaku toggle */
+#define XK_Touroku 0xFF2B /* Add to Dictionary */
+#define XK_Massyo 0xFF2C /* Delete from Dictionary */
+#define XK_Kana_Lock 0xFF2D /* Kana Lock */
+#define XK_Kana_Shift 0xFF2E /* Kana Shift */
+#define XK_Eisu_Shift 0xFF2F /* Alphanumeric Shift */
+#define XK_Eisu_toggle 0xFF30 /* Alphanumeric toggle */
+
+/* Cursor control & motion */
+
+#define XK_Home 0xFF50
+#define XK_Left 0xFF51 /* Move left, left arrow */
+#define XK_Up 0xFF52 /* Move up, up arrow */
+#define XK_Right 0xFF53 /* Move right, right arrow */
+#define XK_Down 0xFF54 /* Move down, down arrow */
+#define XK_Prior 0xFF55 /* Prior, previous */
+#define XK_Page_Up 0xFF55
+#define XK_Next 0xFF56 /* Next */
+#define XK_Page_Down 0xFF56
+#define XK_End 0xFF57 /* EOL */
+#define XK_Begin 0xFF58 /* BOL */
+
+/* Special Windows keyboard keys */
+
+#define XK_Win_L 0xFF5B /* Left-hand Windows */
+#define XK_Win_R 0xFF5C /* Right-hand Windows */
+#define XK_App 0xFF5D /* Menu key */
+
+/* Misc Functions */
+
+#define XK_Select 0xFF60 /* Select, mark */
+#define XK_Print 0xFF61
+#define XK_Execute 0xFF62 /* Execute, run, do */
+#define XK_Insert 0xFF63 /* Insert, insert here */
+#define XK_Undo 0xFF65 /* Undo, oops */
+#define XK_Redo 0xFF66 /* redo, again */
+#define XK_Menu 0xFF67
+#define XK_Find 0xFF68 /* Find, search */
+#define XK_Cancel 0xFF69 /* Cancel, stop, abort, exit */
+#define XK_Help 0xFF6A /* Help, ? */
+#define XK_Break 0xFF6B
+#define XK_Mode_switch 0xFF7E /* Character set switch */
+#define XK_script_switch 0xFF7E /* Alias for mode_switch */
+#define XK_Num_Lock 0xFF7F
+
+/* Keypad Functions, keypad numbers cleverly chosen to map to ascii */
+
+#define XK_KP_Space 0xFF80 /* space */
+#define XK_KP_Tab 0xFF89
+#define XK_KP_Enter 0xFF8D /* enter */
+#define XK_KP_F1 0xFF91 /* PF1, KP_A, ... */
+#define XK_KP_F2 0xFF92
+#define XK_KP_F3 0xFF93
+#define XK_KP_F4 0xFF94
+#define XK_KP_Home 0xFF95
+#define XK_KP_Left 0xFF96
+#define XK_KP_Up 0xFF97
+#define XK_KP_Right 0xFF98
+#define XK_KP_Down 0xFF99
+#define XK_KP_Prior 0xFF9A
+#define XK_KP_Page_Up 0xFF9A
+#define XK_KP_Next 0xFF9B
+#define XK_KP_Page_Down 0xFF9B
+#define XK_KP_End 0xFF9C
+#define XK_KP_Begin 0xFF9D
+#define XK_KP_Insert 0xFF9E
+#define XK_KP_Delete 0xFF9F
+#define XK_KP_Equal 0xFFBD /* equals */
+#define XK_KP_Multiply 0xFFAA
+#define XK_KP_Add 0xFFAB
+#define XK_KP_Separator 0xFFAC /* separator, often comma */
+#define XK_KP_Subtract 0xFFAD
+#define XK_KP_Decimal 0xFFAE
+#define XK_KP_Divide 0xFFAF
+
+#define XK_KP_0 0xFFB0
+#define XK_KP_1 0xFFB1
+#define XK_KP_2 0xFFB2
+#define XK_KP_3 0xFFB3
+#define XK_KP_4 0xFFB4
+#define XK_KP_5 0xFFB5
+#define XK_KP_6 0xFFB6
+#define XK_KP_7 0xFFB7
+#define XK_KP_8 0xFFB8
+#define XK_KP_9 0xFFB9
+
+
+
+/*
+ * Auxilliary Functions; note the duplicate definitions for left and right
+ * function keys; Sun keyboards and a few other manufactures have such
+ * function key groups on the left and/or right sides of the keyboard.
+ * We've not found a keyboard with more than 35 function keys total.
+ */
+
+#define XK_F1 0xFFBE
+#define XK_F2 0xFFBF
+#define XK_F3 0xFFC0
+#define XK_F4 0xFFC1
+#define XK_F5 0xFFC2
+#define XK_F6 0xFFC3
+#define XK_F7 0xFFC4
+#define XK_F8 0xFFC5
+#define XK_F9 0xFFC6
+#define XK_F10 0xFFC7
+#define XK_F11 0xFFC8
+#define XK_L1 0xFFC8
+#define XK_F12 0xFFC9
+#define XK_L2 0xFFC9
+#define XK_F13 0xFFCA
+#define XK_L3 0xFFCA
+#define XK_F14 0xFFCB
+#define XK_L4 0xFFCB
+#define XK_F15 0xFFCC
+#define XK_L5 0xFFCC
+#define XK_F16 0xFFCD
+#define XK_L6 0xFFCD
+#define XK_F17 0xFFCE
+#define XK_L7 0xFFCE
+#define XK_F18 0xFFCF
+#define XK_L8 0xFFCF
+#define XK_F19 0xFFD0
+#define XK_L9 0xFFD0
+#define XK_F20 0xFFD1
+#define XK_L10 0xFFD1
+#define XK_F21 0xFFD2
+#define XK_R1 0xFFD2
+#define XK_F22 0xFFD3
+#define XK_R2 0xFFD3
+#define XK_F23 0xFFD4
+#define XK_R3 0xFFD4
+#define XK_F24 0xFFD5
+#define XK_R4 0xFFD5
+#define XK_F25 0xFFD6
+#define XK_R5 0xFFD6
+#define XK_F26 0xFFD7
+#define XK_R6 0xFFD7
+#define XK_F27 0xFFD8
+#define XK_R7 0xFFD8
+#define XK_F28 0xFFD9
+#define XK_R8 0xFFD9
+#define XK_F29 0xFFDA
+#define XK_R9 0xFFDA
+#define XK_F30 0xFFDB
+#define XK_R10 0xFFDB
+#define XK_F31 0xFFDC
+#define XK_R11 0xFFDC
+#define XK_F32 0xFFDD
+#define XK_R12 0xFFDD
+#define XK_F33 0xFFDE
+#define XK_R13 0xFFDE
+#define XK_F34 0xFFDF
+#define XK_R14 0xFFDF
+#define XK_F35 0xFFE0
+#define XK_R15 0xFFE0
+
+/* Modifiers */
+
+#define XK_Shift_L 0xFFE1 /* Left shift */
+#define XK_Shift_R 0xFFE2 /* Right shift */
+#define XK_Control_L 0xFFE3 /* Left control */
+#define XK_Control_R 0xFFE4 /* Right control */
+#define XK_Caps_Lock 0xFFE5 /* Caps lock */
+#define XK_Shift_Lock 0xFFE6 /* Shift lock */
+
+#define XK_Meta_L 0xFFE7 /* Left meta */
+#define XK_Meta_R 0xFFE8 /* Right meta */
+#define XK_Alt_L 0xFFE9 /* Left alt */
+#define XK_Alt_R 0xFFEA /* Right alt */
+#define XK_Super_L 0xFFEB /* Left super */
+#define XK_Super_R 0xFFEC /* Right super */
+#define XK_Hyper_L 0xFFED /* Left hyper */
+#define XK_Hyper_R 0xFFEE /* Right hyper */
+#endif /* XK_MISCELLANY */
+
+/*
+ * Latin 1
+ * Byte 3 = 0
+ */
+#ifdef XK_LATIN1
+#define XK_space 0x020
+#define XK_exclam 0x021
+#define XK_quotedbl 0x022
+#define XK_numbersign 0x023
+#define XK_dollar 0x024
+#define XK_percent 0x025
+#define XK_ampersand 0x026
+#define XK_apostrophe 0x027
+#define XK_quoteright 0x027 /* deprecated */
+#define XK_parenleft 0x028
+#define XK_parenright 0x029
+#define XK_asterisk 0x02a
+#define XK_plus 0x02b
+#define XK_comma 0x02c
+#define XK_minus 0x02d
+#define XK_period 0x02e
+#define XK_slash 0x02f
+#define XK_0 0x030
+#define XK_1 0x031
+#define XK_2 0x032
+#define XK_3 0x033
+#define XK_4 0x034
+#define XK_5 0x035
+#define XK_6 0x036
+#define XK_7 0x037
+#define XK_8 0x038
+#define XK_9 0x039
+#define XK_colon 0x03a
+#define XK_semicolon 0x03b
+#define XK_less 0x03c
+#define XK_equal 0x03d
+#define XK_greater 0x03e
+#define XK_question 0x03f
+#define XK_at 0x040
+#define XK_A 0x041
+#define XK_B 0x042
+#define XK_C 0x043
+#define XK_D 0x044
+#define XK_E 0x045
+#define XK_F 0x046
+#define XK_G 0x047
+#define XK_H 0x048
+#define XK_I 0x049
+#define XK_J 0x04a
+#define XK_K 0x04b
+#define XK_L 0x04c
+#define XK_M 0x04d
+#define XK_N 0x04e
+#define XK_O 0x04f
+#define XK_P 0x050
+#define XK_Q 0x051
+#define XK_R 0x052
+#define XK_S 0x053
+#define XK_T 0x054
+#define XK_U 0x055
+#define XK_V 0x056
+#define XK_W 0x057
+#define XK_X 0x058
+#define XK_Y 0x059
+#define XK_Z 0x05a
+#define XK_bracketleft 0x05b
+#define XK_backslash 0x05c
+#define XK_bracketright 0x05d
+#define XK_asciicircum 0x05e
+#define XK_underscore 0x05f
+#define XK_grave 0x060
+#define XK_quoteleft 0x060 /* deprecated */
+#define XK_a 0x061
+#define XK_b 0x062
+#define XK_c 0x063
+#define XK_d 0x064
+#define XK_e 0x065
+#define XK_f 0x066
+#define XK_g 0x067
+#define XK_h 0x068
+#define XK_i 0x069
+#define XK_j 0x06a
+#define XK_k 0x06b
+#define XK_l 0x06c
+#define XK_m 0x06d
+#define XK_n 0x06e
+#define XK_o 0x06f
+#define XK_p 0x070
+#define XK_q 0x071
+#define XK_r 0x072
+#define XK_s 0x073
+#define XK_t 0x074
+#define XK_u 0x075
+#define XK_v 0x076
+#define XK_w 0x077
+#define XK_x 0x078
+#define XK_y 0x079
+#define XK_z 0x07a
+#define XK_braceleft 0x07b
+#define XK_bar 0x07c
+#define XK_braceright 0x07d
+#define XK_asciitilde 0x07e
+
+#define XK_nobreakspace 0x0a0
+#define XK_exclamdown 0x0a1
+#define XK_cent 0x0a2
+#define XK_sterling 0x0a3
+#define XK_currency 0x0a4
+#define XK_yen 0x0a5
+#define XK_brokenbar 0x0a6
+#define XK_section 0x0a7
+#define XK_diaeresis 0x0a8
+#define XK_copyright 0x0a9
+#define XK_ordfeminine 0x0aa
+#define XK_guillemotleft 0x0ab /* left angle quotation mark */
+#define XK_notsign 0x0ac
+#define XK_hyphen 0x0ad
+#define XK_registered 0x0ae
+#define XK_macron 0x0af
+#define XK_degree 0x0b0
+#define XK_plusminus 0x0b1
+#define XK_twosuperior 0x0b2
+#define XK_threesuperior 0x0b3
+#define XK_acute 0x0b4
+#define XK_mu 0x0b5
+#define XK_paragraph 0x0b6
+#define XK_periodcentered 0x0b7
+#define XK_cedilla 0x0b8
+#define XK_onesuperior 0x0b9
+#define XK_masculine 0x0ba
+#define XK_guillemotright 0x0bb /* right angle quotation mark */
+#define XK_onequarter 0x0bc
+#define XK_onehalf 0x0bd
+#define XK_threequarters 0x0be
+#define XK_questiondown 0x0bf
+#define XK_Agrave 0x0c0
+#define XK_Aacute 0x0c1
+#define XK_Acircumflex 0x0c2
+#define XK_Atilde 0x0c3
+#define XK_Adiaeresis 0x0c4
+#define XK_Aring 0x0c5
+#define XK_AE 0x0c6
+#define XK_Ccedilla 0x0c7
+#define XK_Egrave 0x0c8
+#define XK_Eacute 0x0c9
+#define XK_Ecircumflex 0x0ca
+#define XK_Ediaeresis 0x0cb
+#define XK_Igrave 0x0cc
+#define XK_Iacute 0x0cd
+#define XK_Icircumflex 0x0ce
+#define XK_Idiaeresis 0x0cf
+#define XK_ETH 0x0d0
+#define XK_Eth 0x0d0 /* deprecated */
+#define XK_Ntilde 0x0d1
+#define XK_Ograve 0x0d2
+#define XK_Oacute 0x0d3
+#define XK_Ocircumflex 0x0d4
+#define XK_Otilde 0x0d5
+#define XK_Odiaeresis 0x0d6
+#define XK_multiply 0x0d7
+#define XK_Ooblique 0x0d8
+#define XK_Ugrave 0x0d9
+#define XK_Uacute 0x0da
+#define XK_Ucircumflex 0x0db
+#define XK_Udiaeresis 0x0dc
+#define XK_Yacute 0x0dd
+#define XK_THORN 0x0de
+#define XK_Thorn 0x0de /* deprecated */
+#define XK_ssharp 0x0df
+#define XK_agrave 0x0e0
+#define XK_aacute 0x0e1
+#define XK_acircumflex 0x0e2
+#define XK_atilde 0x0e3
+#define XK_adiaeresis 0x0e4
+#define XK_aring 0x0e5
+#define XK_ae 0x0e6
+#define XK_ccedilla 0x0e7
+#define XK_egrave 0x0e8
+#define XK_eacute 0x0e9
+#define XK_ecircumflex 0x0ea
+#define XK_ediaeresis 0x0eb
+#define XK_igrave 0x0ec
+#define XK_iacute 0x0ed
+#define XK_icircumflex 0x0ee
+#define XK_idiaeresis 0x0ef
+#define XK_eth 0x0f0
+#define XK_ntilde 0x0f1
+#define XK_ograve 0x0f2
+#define XK_oacute 0x0f3
+#define XK_ocircumflex 0x0f4
+#define XK_otilde 0x0f5
+#define XK_odiaeresis 0x0f6
+#define XK_division 0x0f7
+#define XK_oslash 0x0f8
+#define XK_ugrave 0x0f9
+#define XK_uacute 0x0fa
+#define XK_ucircumflex 0x0fb
+#define XK_udiaeresis 0x0fc
+#define XK_yacute 0x0fd
+#define XK_thorn 0x0fe
+#define XK_ydiaeresis 0x0ff
+#endif /* XK_LATIN1 */
+
+/*
+ * Latin 2
+ * Byte 3 = 1
+ */
+
+#ifdef XK_LATIN2
+#define XK_Aogonek 0x1a1
+#define XK_breve 0x1a2
+#define XK_Lstroke 0x1a3
+#define XK_Lcaron 0x1a5
+#define XK_Sacute 0x1a6
+#define XK_Scaron 0x1a9
+#define XK_Scedilla 0x1aa
+#define XK_Tcaron 0x1ab
+#define XK_Zacute 0x1ac
+#define XK_Zcaron 0x1ae
+#define XK_Zabovedot 0x1af
+#define XK_aogonek 0x1b1
+#define XK_ogonek 0x1b2
+#define XK_lstroke 0x1b3
+#define XK_lcaron 0x1b5
+#define XK_sacute 0x1b6
+#define XK_caron 0x1b7
+#define XK_scaron 0x1b9
+#define XK_scedilla 0x1ba
+#define XK_tcaron 0x1bb
+#define XK_zacute 0x1bc
+#define XK_doubleacute 0x1bd
+#define XK_zcaron 0x1be
+#define XK_zabovedot 0x1bf
+#define XK_Racute 0x1c0
+#define XK_Abreve 0x1c3
+#define XK_Lacute 0x1c5
+#define XK_Cacute 0x1c6
+#define XK_Ccaron 0x1c8
+#define XK_Eogonek 0x1ca
+#define XK_Ecaron 0x1cc
+#define XK_Dcaron 0x1cf
+#define XK_Dstroke 0x1d0
+#define XK_Nacute 0x1d1
+#define XK_Ncaron 0x1d2
+#define XK_Odoubleacute 0x1d5
+#define XK_Rcaron 0x1d8
+#define XK_Uring 0x1d9
+#define XK_Udoubleacute 0x1db
+#define XK_Tcedilla 0x1de
+#define XK_racute 0x1e0
+#define XK_abreve 0x1e3
+#define XK_lacute 0x1e5
+#define XK_cacute 0x1e6
+#define XK_ccaron 0x1e8
+#define XK_eogonek 0x1ea
+#define XK_ecaron 0x1ec
+#define XK_dcaron 0x1ef
+#define XK_dstroke 0x1f0
+#define XK_nacute 0x1f1
+#define XK_ncaron 0x1f2
+#define XK_odoubleacute 0x1f5
+#define XK_udoubleacute 0x1fb
+#define XK_rcaron 0x1f8
+#define XK_uring 0x1f9
+#define XK_tcedilla 0x1fe
+#define XK_abovedot 0x1ff
+#endif /* XK_LATIN2 */
+
+/*
+ * Latin 3
+ * Byte 3 = 2
+ */
+
+#ifdef XK_LATIN3
+#define XK_Hstroke 0x2a1
+#define XK_Hcircumflex 0x2a6
+#define XK_Iabovedot 0x2a9
+#define XK_Gbreve 0x2ab
+#define XK_Jcircumflex 0x2ac
+#define XK_hstroke 0x2b1
+#define XK_hcircumflex 0x2b6
+#define XK_idotless 0x2b9
+#define XK_gbreve 0x2bb
+#define XK_jcircumflex 0x2bc
+#define XK_Cabovedot 0x2c5
+#define XK_Ccircumflex 0x2c6
+#define XK_Gabovedot 0x2d5
+#define XK_Gcircumflex 0x2d8
+#define XK_Ubreve 0x2dd
+#define XK_Scircumflex 0x2de
+#define XK_cabovedot 0x2e5
+#define XK_ccircumflex 0x2e6
+#define XK_gabovedot 0x2f5
+#define XK_gcircumflex 0x2f8
+#define XK_ubreve 0x2fd
+#define XK_scircumflex 0x2fe
+#endif /* XK_LATIN3 */
+
+
+/*
+ * Latin 4
+ * Byte 3 = 3
+ */
+
+#ifdef XK_LATIN4
+#define XK_kra 0x3a2
+#define XK_kappa 0x3a2 /* deprecated */
+#define XK_Rcedilla 0x3a3
+#define XK_Itilde 0x3a5
+#define XK_Lcedilla 0x3a6
+#define XK_Emacron 0x3aa
+#define XK_Gcedilla 0x3ab
+#define XK_Tslash 0x3ac
+#define XK_rcedilla 0x3b3
+#define XK_itilde 0x3b5
+#define XK_lcedilla 0x3b6
+#define XK_emacron 0x3ba
+#define XK_gcedilla 0x3bb
+#define XK_tslash 0x3bc
+#define XK_ENG 0x3bd
+#define XK_eng 0x3bf
+#define XK_Amacron 0x3c0
+#define XK_Iogonek 0x3c7
+#define XK_Eabovedot 0x3cc
+#define XK_Imacron 0x3cf
+#define XK_Ncedilla 0x3d1
+#define XK_Omacron 0x3d2
+#define XK_Kcedilla 0x3d3
+#define XK_Uogonek 0x3d9
+#define XK_Utilde 0x3dd
+#define XK_Umacron 0x3de
+#define XK_amacron 0x3e0
+#define XK_iogonek 0x3e7
+#define XK_eabovedot 0x3ec
+#define XK_imacron 0x3ef
+#define XK_ncedilla 0x3f1
+#define XK_omacron 0x3f2
+#define XK_kcedilla 0x3f3
+#define XK_uogonek 0x3f9
+#define XK_utilde 0x3fd
+#define XK_umacron 0x3fe
+#endif /* XK_LATIN4 */
+
+/*
+ * Katakana
+ * Byte 3 = 4
+ */
+
+#ifdef XK_KATAKANA
+#define XK_overline 0x47e
+#define XK_kana_fullstop 0x4a1
+#define XK_kana_openingbracket 0x4a2
+#define XK_kana_closingbracket 0x4a3
+#define XK_kana_comma 0x4a4
+#define XK_kana_conjunctive 0x4a5
+#define XK_kana_middledot 0x4a5 /* deprecated */
+#define XK_kana_WO 0x4a6
+#define XK_kana_a 0x4a7
+#define XK_kana_i 0x4a8
+#define XK_kana_u 0x4a9
+#define XK_kana_e 0x4aa
+#define XK_kana_o 0x4ab
+#define XK_kana_ya 0x4ac
+#define XK_kana_yu 0x4ad
+#define XK_kana_yo 0x4ae
+#define XK_kana_tsu 0x4af
+#define XK_kana_tu 0x4af /* deprecated */
+#define XK_prolongedsound 0x4b0
+#define XK_kana_A 0x4b1
+#define XK_kana_I 0x4b2
+#define XK_kana_U 0x4b3
+#define XK_kana_E 0x4b4
+#define XK_kana_O 0x4b5
+#define XK_kana_KA 0x4b6
+#define XK_kana_KI 0x4b7
+#define XK_kana_KU 0x4b8
+#define XK_kana_KE 0x4b9
+#define XK_kana_KO 0x4ba
+#define XK_kana_SA 0x4bb
+#define XK_kana_SHI 0x4bc
+#define XK_kana_SU 0x4bd
+#define XK_kana_SE 0x4be
+#define XK_kana_SO 0x4bf
+#define XK_kana_TA 0x4c0
+#define XK_kana_CHI 0x4c1
+#define XK_kana_TI 0x4c1 /* deprecated */
+#define XK_kana_TSU 0x4c2
+#define XK_kana_TU 0x4c2 /* deprecated */
+#define XK_kana_TE 0x4c3
+#define XK_kana_TO 0x4c4
+#define XK_kana_NA 0x4c5
+#define XK_kana_NI 0x4c6
+#define XK_kana_NU 0x4c7
+#define XK_kana_NE 0x4c8
+#define XK_kana_NO 0x4c9
+#define XK_kana_HA 0x4ca
+#define XK_kana_HI 0x4cb
+#define XK_kana_FU 0x4cc
+#define XK_kana_HU 0x4cc /* deprecated */
+#define XK_kana_HE 0x4cd
+#define XK_kana_HO 0x4ce
+#define XK_kana_MA 0x4cf
+#define XK_kana_MI 0x4d0
+#define XK_kana_MU 0x4d1
+#define XK_kana_ME 0x4d2
+#define XK_kana_MO 0x4d3
+#define XK_kana_YA 0x4d4
+#define XK_kana_YU 0x4d5
+#define XK_kana_YO 0x4d6
+#define XK_kana_RA 0x4d7
+#define XK_kana_RI 0x4d8
+#define XK_kana_RU 0x4d9
+#define XK_kana_RE 0x4da
+#define XK_kana_RO 0x4db
+#define XK_kana_WA 0x4dc
+#define XK_kana_N 0x4dd
+#define XK_voicedsound 0x4de
+#define XK_semivoicedsound 0x4df
+#define XK_kana_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_KATAKANA */
+
+/*
+ * Arabic
+ * Byte 3 = 5
+ */
+
+#ifdef XK_ARABIC
+#define XK_Arabic_comma 0x5ac
+#define XK_Arabic_semicolon 0x5bb
+#define XK_Arabic_question_mark 0x5bf
+#define XK_Arabic_hamza 0x5c1
+#define XK_Arabic_maddaonalef 0x5c2
+#define XK_Arabic_hamzaonalef 0x5c3
+#define XK_Arabic_hamzaonwaw 0x5c4
+#define XK_Arabic_hamzaunderalef 0x5c5
+#define XK_Arabic_hamzaonyeh 0x5c6
+#define XK_Arabic_alef 0x5c7
+#define XK_Arabic_beh 0x5c8
+#define XK_Arabic_tehmarbuta 0x5c9
+#define XK_Arabic_teh 0x5ca
+#define XK_Arabic_theh 0x5cb
+#define XK_Arabic_jeem 0x5cc
+#define XK_Arabic_hah 0x5cd
+#define XK_Arabic_khah 0x5ce
+#define XK_Arabic_dal 0x5cf
+#define XK_Arabic_thal 0x5d0
+#define XK_Arabic_ra 0x5d1
+#define XK_Arabic_zain 0x5d2
+#define XK_Arabic_seen 0x5d3
+#define XK_Arabic_sheen 0x5d4
+#define XK_Arabic_sad 0x5d5
+#define XK_Arabic_dad 0x5d6
+#define XK_Arabic_tah 0x5d7
+#define XK_Arabic_zah 0x5d8
+#define XK_Arabic_ain 0x5d9
+#define XK_Arabic_ghain 0x5da
+#define XK_Arabic_tatweel 0x5e0
+#define XK_Arabic_feh 0x5e1
+#define XK_Arabic_qaf 0x5e2
+#define XK_Arabic_kaf 0x5e3
+#define XK_Arabic_lam 0x5e4
+#define XK_Arabic_meem 0x5e5
+#define XK_Arabic_noon 0x5e6
+#define XK_Arabic_ha 0x5e7
+#define XK_Arabic_heh 0x5e7 /* deprecated */
+#define XK_Arabic_waw 0x5e8
+#define XK_Arabic_alefmaksura 0x5e9
+#define XK_Arabic_yeh 0x5ea
+#define XK_Arabic_fathatan 0x5eb
+#define XK_Arabic_dammatan 0x5ec
+#define XK_Arabic_kasratan 0x5ed
+#define XK_Arabic_fatha 0x5ee
+#define XK_Arabic_damma 0x5ef
+#define XK_Arabic_kasra 0x5f0
+#define XK_Arabic_shadda 0x5f1
+#define XK_Arabic_sukun 0x5f2
+#define XK_Arabic_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_ARABIC */
+
+/*
+ * Cyrillic
+ * Byte 3 = 6
+ */
+#ifdef XK_CYRILLIC
+#define XK_Serbian_dje 0x6a1
+#define XK_Macedonia_gje 0x6a2
+#define XK_Cyrillic_io 0x6a3
+#define XK_Ukrainian_ie 0x6a4
+#define XK_Ukranian_je 0x6a4 /* deprecated */
+#define XK_Macedonia_dse 0x6a5
+#define XK_Ukrainian_i 0x6a6
+#define XK_Ukranian_i 0x6a6 /* deprecated */
+#define XK_Ukrainian_yi 0x6a7
+#define XK_Ukranian_yi 0x6a7 /* deprecated */
+#define XK_Cyrillic_je 0x6a8
+#define XK_Serbian_je 0x6a8 /* deprecated */
+#define XK_Cyrillic_lje 0x6a9
+#define XK_Serbian_lje 0x6a9 /* deprecated */
+#define XK_Cyrillic_nje 0x6aa
+#define XK_Serbian_nje 0x6aa /* deprecated */
+#define XK_Serbian_tshe 0x6ab
+#define XK_Macedonia_kje 0x6ac
+#define XK_Byelorussian_shortu 0x6ae
+#define XK_Cyrillic_dzhe 0x6af
+#define XK_Serbian_dze 0x6af /* deprecated */
+#define XK_numerosign 0x6b0
+#define XK_Serbian_DJE 0x6b1
+#define XK_Macedonia_GJE 0x6b2
+#define XK_Cyrillic_IO 0x6b3
+#define XK_Ukrainian_IE 0x6b4
+#define XK_Ukranian_JE 0x6b4 /* deprecated */
+#define XK_Macedonia_DSE 0x6b5
+#define XK_Ukrainian_I 0x6b6
+#define XK_Ukranian_I 0x6b6 /* deprecated */
+#define XK_Ukrainian_YI 0x6b7
+#define XK_Ukranian_YI 0x6b7 /* deprecated */
+#define XK_Cyrillic_JE 0x6b8
+#define XK_Serbian_JE 0x6b8 /* deprecated */
+#define XK_Cyrillic_LJE 0x6b9
+#define XK_Serbian_LJE 0x6b9 /* deprecated */
+#define XK_Cyrillic_NJE 0x6ba
+#define XK_Serbian_NJE 0x6ba /* deprecated */
+#define XK_Serbian_TSHE 0x6bb
+#define XK_Macedonia_KJE 0x6bc
+#define XK_Byelorussian_SHORTU 0x6be
+#define XK_Cyrillic_DZHE 0x6bf
+#define XK_Serbian_DZE 0x6bf /* deprecated */
+#define XK_Cyrillic_yu 0x6c0
+#define XK_Cyrillic_a 0x6c1
+#define XK_Cyrillic_be 0x6c2
+#define XK_Cyrillic_tse 0x6c3
+#define XK_Cyrillic_de 0x6c4
+#define XK_Cyrillic_ie 0x6c5
+#define XK_Cyrillic_ef 0x6c6
+#define XK_Cyrillic_ghe 0x6c7
+#define XK_Cyrillic_ha 0x6c8
+#define XK_Cyrillic_i 0x6c9
+#define XK_Cyrillic_shorti 0x6ca
+#define XK_Cyrillic_ka 0x6cb
+#define XK_Cyrillic_el 0x6cc
+#define XK_Cyrillic_em 0x6cd
+#define XK_Cyrillic_en 0x6ce
+#define XK_Cyrillic_o 0x6cf
+#define XK_Cyrillic_pe 0x6d0
+#define XK_Cyrillic_ya 0x6d1
+#define XK_Cyrillic_er 0x6d2
+#define XK_Cyrillic_es 0x6d3
+#define XK_Cyrillic_te 0x6d4
+#define XK_Cyrillic_u 0x6d5
+#define XK_Cyrillic_zhe 0x6d6
+#define XK_Cyrillic_ve 0x6d7
+#define XK_Cyrillic_softsign 0x6d8
+#define XK_Cyrillic_yeru 0x6d9
+#define XK_Cyrillic_ze 0x6da
+#define XK_Cyrillic_sha 0x6db
+#define XK_Cyrillic_e 0x6dc
+#define XK_Cyrillic_shcha 0x6dd
+#define XK_Cyrillic_che 0x6de
+#define XK_Cyrillic_hardsign 0x6df
+#define XK_Cyrillic_YU 0x6e0
+#define XK_Cyrillic_A 0x6e1
+#define XK_Cyrillic_BE 0x6e2
+#define XK_Cyrillic_TSE 0x6e3
+#define XK_Cyrillic_DE 0x6e4
+#define XK_Cyrillic_IE 0x6e5
+#define XK_Cyrillic_EF 0x6e6
+#define XK_Cyrillic_GHE 0x6e7
+#define XK_Cyrillic_HA 0x6e8
+#define XK_Cyrillic_I 0x6e9
+#define XK_Cyrillic_SHORTI 0x6ea
+#define XK_Cyrillic_KA 0x6eb
+#define XK_Cyrillic_EL 0x6ec
+#define XK_Cyrillic_EM 0x6ed
+#define XK_Cyrillic_EN 0x6ee
+#define XK_Cyrillic_O 0x6ef
+#define XK_Cyrillic_PE 0x6f0
+#define XK_Cyrillic_YA 0x6f1
+#define XK_Cyrillic_ER 0x6f2
+#define XK_Cyrillic_ES 0x6f3
+#define XK_Cyrillic_TE 0x6f4
+#define XK_Cyrillic_U 0x6f5
+#define XK_Cyrillic_ZHE 0x6f6
+#define XK_Cyrillic_VE 0x6f7
+#define XK_Cyrillic_SOFTSIGN 0x6f8
+#define XK_Cyrillic_YERU 0x6f9
+#define XK_Cyrillic_ZE 0x6fa
+#define XK_Cyrillic_SHA 0x6fb
+#define XK_Cyrillic_E 0x6fc
+#define XK_Cyrillic_SHCHA 0x6fd
+#define XK_Cyrillic_CHE 0x6fe
+#define XK_Cyrillic_HARDSIGN 0x6ff
+#endif /* XK_CYRILLIC */
+
+/*
+ * Greek
+ * Byte 3 = 7
+ */
+
+#ifdef XK_GREEK
+#define XK_Greek_ALPHAaccent 0x7a1
+#define XK_Greek_EPSILONaccent 0x7a2
+#define XK_Greek_ETAaccent 0x7a3
+#define XK_Greek_IOTAaccent 0x7a4
+#define XK_Greek_IOTAdiaeresis 0x7a5
+#define XK_Greek_OMICRONaccent 0x7a7
+#define XK_Greek_UPSILONaccent 0x7a8
+#define XK_Greek_UPSILONdieresis 0x7a9
+#define XK_Greek_OMEGAaccent 0x7ab
+#define XK_Greek_accentdieresis 0x7ae
+#define XK_Greek_horizbar 0x7af
+#define XK_Greek_alphaaccent 0x7b1
+#define XK_Greek_epsilonaccent 0x7b2
+#define XK_Greek_etaaccent 0x7b3
+#define XK_Greek_iotaaccent 0x7b4
+#define XK_Greek_iotadieresis 0x7b5
+#define XK_Greek_iotaaccentdieresis 0x7b6
+#define XK_Greek_omicronaccent 0x7b7
+#define XK_Greek_upsilonaccent 0x7b8
+#define XK_Greek_upsilondieresis 0x7b9
+#define XK_Greek_upsilonaccentdieresis 0x7ba
+#define XK_Greek_omegaaccent 0x7bb
+#define XK_Greek_ALPHA 0x7c1
+#define XK_Greek_BETA 0x7c2
+#define XK_Greek_GAMMA 0x7c3
+#define XK_Greek_DELTA 0x7c4
+#define XK_Greek_EPSILON 0x7c5
+#define XK_Greek_ZETA 0x7c6
+#define XK_Greek_ETA 0x7c7
+#define XK_Greek_THETA 0x7c8
+#define XK_Greek_IOTA 0x7c9
+#define XK_Greek_KAPPA 0x7ca
+#define XK_Greek_LAMDA 0x7cb
+#define XK_Greek_LAMBDA 0x7cb
+#define XK_Greek_MU 0x7cc
+#define XK_Greek_NU 0x7cd
+#define XK_Greek_XI 0x7ce
+#define XK_Greek_OMICRON 0x7cf
+#define XK_Greek_PI 0x7d0
+#define XK_Greek_RHO 0x7d1
+#define XK_Greek_SIGMA 0x7d2
+#define XK_Greek_TAU 0x7d4
+#define XK_Greek_UPSILON 0x7d5
+#define XK_Greek_PHI 0x7d6
+#define XK_Greek_CHI 0x7d7
+#define XK_Greek_PSI 0x7d8
+#define XK_Greek_OMEGA 0x7d9
+#define XK_Greek_alpha 0x7e1
+#define XK_Greek_beta 0x7e2
+#define XK_Greek_gamma 0x7e3
+#define XK_Greek_delta 0x7e4
+#define XK_Greek_epsilon 0x7e5
+#define XK_Greek_zeta 0x7e6
+#define XK_Greek_eta 0x7e7
+#define XK_Greek_theta 0x7e8
+#define XK_Greek_iota 0x7e9
+#define XK_Greek_kappa 0x7ea
+#define XK_Greek_lamda 0x7eb
+#define XK_Greek_lambda 0x7eb
+#define XK_Greek_mu 0x7ec
+#define XK_Greek_nu 0x7ed
+#define XK_Greek_xi 0x7ee
+#define XK_Greek_omicron 0x7ef
+#define XK_Greek_pi 0x7f0
+#define XK_Greek_rho 0x7f1
+#define XK_Greek_sigma 0x7f2
+#define XK_Greek_finalsmallsigma 0x7f3
+#define XK_Greek_tau 0x7f4
+#define XK_Greek_upsilon 0x7f5
+#define XK_Greek_phi 0x7f6
+#define XK_Greek_chi 0x7f7
+#define XK_Greek_psi 0x7f8
+#define XK_Greek_omega 0x7f9
+#define XK_Greek_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_GREEK */
+
+/*
+ * Technical
+ * Byte 3 = 8
+ */
+
+#ifdef XK_TECHNICAL
+#define XK_leftradical 0x8a1
+#define XK_topleftradical 0x8a2
+#define XK_horizconnector 0x8a3
+#define XK_topintegral 0x8a4
+#define XK_botintegral 0x8a5
+#define XK_vertconnector 0x8a6
+#define XK_topleftsqbracket 0x8a7
+#define XK_botleftsqbracket 0x8a8
+#define XK_toprightsqbracket 0x8a9
+#define XK_botrightsqbracket 0x8aa
+#define XK_topleftparens 0x8ab
+#define XK_botleftparens 0x8ac
+#define XK_toprightparens 0x8ad
+#define XK_botrightparens 0x8ae
+#define XK_leftmiddlecurlybrace 0x8af
+#define XK_rightmiddlecurlybrace 0x8b0
+#define XK_topleftsummation 0x8b1
+#define XK_botleftsummation 0x8b2
+#define XK_topvertsummationconnector 0x8b3
+#define XK_botvertsummationconnector 0x8b4
+#define XK_toprightsummation 0x8b5
+#define XK_botrightsummation 0x8b6
+#define XK_rightmiddlesummation 0x8b7
+#define XK_lessthanequal 0x8bc
+#define XK_notequal 0x8bd
+#define XK_greaterthanequal 0x8be
+#define XK_integral 0x8bf
+#define XK_therefore 0x8c0
+#define XK_variation 0x8c1
+#define XK_infinity 0x8c2
+#define XK_nabla 0x8c5
+#define XK_approximate 0x8c8
+#define XK_similarequal 0x8c9
+#define XK_ifonlyif 0x8cd
+#define XK_implies 0x8ce
+#define XK_identical 0x8cf
+#define XK_radical 0x8d6
+#define XK_includedin 0x8da
+#define XK_includes 0x8db
+#define XK_intersection 0x8dc
+#define XK_union 0x8dd
+#define XK_logicaland 0x8de
+#define XK_logicalor 0x8df
+#define XK_partialderivative 0x8ef
+#define XK_function 0x8f6
+#define XK_leftarrow 0x8fb
+#define XK_uparrow 0x8fc
+#define XK_rightarrow 0x8fd
+#define XK_downarrow 0x8fe
+#endif /* XK_TECHNICAL */
+
+/*
+ * Special
+ * Byte 3 = 9
+ */
+
+#ifdef XK_SPECIAL
+#define XK_blank 0x9df
+#define XK_soliddiamond 0x9e0
+#define XK_checkerboard 0x9e1
+#define XK_ht 0x9e2
+#define XK_ff 0x9e3
+#define XK_cr 0x9e4
+#define XK_lf 0x9e5
+#define XK_nl 0x9e8
+#define XK_vt 0x9e9
+#define XK_lowrightcorner 0x9ea
+#define XK_uprightcorner 0x9eb
+#define XK_upleftcorner 0x9ec
+#define XK_lowleftcorner 0x9ed
+#define XK_crossinglines 0x9ee
+#define XK_horizlinescan1 0x9ef
+#define XK_horizlinescan3 0x9f0
+#define XK_horizlinescan5 0x9f1
+#define XK_horizlinescan7 0x9f2
+#define XK_horizlinescan9 0x9f3
+#define XK_leftt 0x9f4
+#define XK_rightt 0x9f5
+#define XK_bott 0x9f6
+#define XK_topt 0x9f7
+#define XK_vertbar 0x9f8
+#endif /* XK_SPECIAL */
+
+/*
+ * Publishing
+ * Byte 3 = a
+ */
+
+#ifdef XK_PUBLISHING
+#define XK_emspace 0xaa1
+#define XK_enspace 0xaa2
+#define XK_em3space 0xaa3
+#define XK_em4space 0xaa4
+#define XK_digitspace 0xaa5
+#define XK_punctspace 0xaa6
+#define XK_thinspace 0xaa7
+#define XK_hairspace 0xaa8
+#define XK_emdash 0xaa9
+#define XK_endash 0xaaa
+#define XK_signifblank 0xaac
+#define XK_ellipsis 0xaae
+#define XK_doubbaselinedot 0xaaf
+#define XK_onethird 0xab0
+#define XK_twothirds 0xab1
+#define XK_onefifth 0xab2
+#define XK_twofifths 0xab3
+#define XK_threefifths 0xab4
+#define XK_fourfifths 0xab5
+#define XK_onesixth 0xab6
+#define XK_fivesixths 0xab7
+#define XK_careof 0xab8
+#define XK_figdash 0xabb
+#define XK_leftanglebracket 0xabc
+#define XK_decimalpoint 0xabd
+#define XK_rightanglebracket 0xabe
+#define XK_marker 0xabf
+#define XK_oneeighth 0xac3
+#define XK_threeeighths 0xac4
+#define XK_fiveeighths 0xac5
+#define XK_seveneighths 0xac6
+#define XK_trademark 0xac9
+#define XK_signaturemark 0xaca
+#define XK_trademarkincircle 0xacb
+#define XK_leftopentriangle 0xacc
+#define XK_rightopentriangle 0xacd
+#define XK_emopencircle 0xace
+#define XK_emopenrectangle 0xacf
+#define XK_leftsinglequotemark 0xad0
+#define XK_rightsinglequotemark 0xad1
+#define XK_leftdoublequotemark 0xad2
+#define XK_rightdoublequotemark 0xad3
+#define XK_prescription 0xad4
+#define XK_minutes 0xad6
+#define XK_seconds 0xad7
+#define XK_latincross 0xad9
+#define XK_hexagram 0xada
+#define XK_filledrectbullet 0xadb
+#define XK_filledlefttribullet 0xadc
+#define XK_filledrighttribullet 0xadd
+#define XK_emfilledcircle 0xade
+#define XK_emfilledrect 0xadf
+#define XK_enopencircbullet 0xae0
+#define XK_enopensquarebullet 0xae1
+#define XK_openrectbullet 0xae2
+#define XK_opentribulletup 0xae3
+#define XK_opentribulletdown 0xae4
+#define XK_openstar 0xae5
+#define XK_enfilledcircbullet 0xae6
+#define XK_enfilledsqbullet 0xae7
+#define XK_filledtribulletup 0xae8
+#define XK_filledtribulletdown 0xae9
+#define XK_leftpointer 0xaea
+#define XK_rightpointer 0xaeb
+#define XK_club 0xaec
+#define XK_diamond 0xaed
+#define XK_heart 0xaee
+#define XK_maltesecross 0xaf0
+#define XK_dagger 0xaf1
+#define XK_doubledagger 0xaf2
+#define XK_checkmark 0xaf3
+#define XK_ballotcross 0xaf4
+#define XK_musicalsharp 0xaf5
+#define XK_musicalflat 0xaf6
+#define XK_malesymbol 0xaf7
+#define XK_femalesymbol 0xaf8
+#define XK_telephone 0xaf9
+#define XK_telephonerecorder 0xafa
+#define XK_phonographcopyright 0xafb
+#define XK_caret 0xafc
+#define XK_singlelowquotemark 0xafd
+#define XK_doublelowquotemark 0xafe
+#define XK_cursor 0xaff
+#endif /* XK_PUBLISHING */
+
+/*
+ * APL
+ * Byte 3 = b
+ */
+
+#ifdef XK_APL
+#define XK_leftcaret 0xba3
+#define XK_rightcaret 0xba6
+#define XK_downcaret 0xba8
+#define XK_upcaret 0xba9
+#define XK_overbar 0xbc0
+#define XK_downtack 0xbc2
+#define XK_upshoe 0xbc3
+#define XK_downstile 0xbc4
+#define XK_underbar 0xbc6
+#define XK_jot 0xbca
+#define XK_quad 0xbcc
+#define XK_uptack 0xbce
+#define XK_circle 0xbcf
+#define XK_upstile 0xbd3
+#define XK_downshoe 0xbd6
+#define XK_rightshoe 0xbd8
+#define XK_leftshoe 0xbda
+#define XK_lefttack 0xbdc
+#define XK_righttack 0xbfc
+#endif /* XK_APL */
+
+/*
+ * Hebrew
+ * Byte 3 = c
+ */
+
+#ifdef XK_HEBREW
+#define XK_hebrew_doublelowline 0xcdf
+#define XK_hebrew_aleph 0xce0
+#define XK_hebrew_bet 0xce1
+#define XK_hebrew_beth 0xce1 /* deprecated */
+#define XK_hebrew_gimel 0xce2
+#define XK_hebrew_gimmel 0xce2 /* deprecated */
+#define XK_hebrew_dalet 0xce3
+#define XK_hebrew_daleth 0xce3 /* deprecated */
+#define XK_hebrew_he 0xce4
+#define XK_hebrew_waw 0xce5
+#define XK_hebrew_zain 0xce6
+#define XK_hebrew_zayin 0xce6 /* deprecated */
+#define XK_hebrew_chet 0xce7
+#define XK_hebrew_het 0xce7 /* deprecated */
+#define XK_hebrew_tet 0xce8
+#define XK_hebrew_teth 0xce8 /* deprecated */
+#define XK_hebrew_yod 0xce9
+#define XK_hebrew_finalkaph 0xcea
+#define XK_hebrew_kaph 0xceb
+#define XK_hebrew_lamed 0xcec
+#define XK_hebrew_finalmem 0xced
+#define XK_hebrew_mem 0xcee
+#define XK_hebrew_finalnun 0xcef
+#define XK_hebrew_nun 0xcf0
+#define XK_hebrew_samech 0xcf1
+#define XK_hebrew_samekh 0xcf1 /* deprecated */
+#define XK_hebrew_ayin 0xcf2
+#define XK_hebrew_finalpe 0xcf3
+#define XK_hebrew_pe 0xcf4
+#define XK_hebrew_finalzade 0xcf5
+#define XK_hebrew_finalzadi 0xcf5 /* deprecated */
+#define XK_hebrew_zade 0xcf6
+#define XK_hebrew_zadi 0xcf6 /* deprecated */
+#define XK_hebrew_qoph 0xcf7
+#define XK_hebrew_kuf 0xcf7 /* deprecated */
+#define XK_hebrew_resh 0xcf8
+#define XK_hebrew_shin 0xcf9
+#define XK_hebrew_taw 0xcfa
+#define XK_hebrew_taf 0xcfa /* deprecated */
+#define XK_Hebrew_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_HEBREW */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11/license.terms b/Master/tlpkg/tlperl.straw/lib/Tk/X11/license.terms
new file mode 100755
index 00000000000..03ca6fcb319
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11/license.terms
@@ -0,0 +1,39 @@
+This software is copyrighted by the Regents of the University of
+California, Sun Microsystems, Inc., and other parties. The following
+terms apply to all files associated with the software unless explicitly
+disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11Font.pm b/Master/tlpkg/tlperl.straw/lib/Tk/X11Font.pm
new file mode 100755
index 00000000000..870dfd4b7dc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11Font.pm
@@ -0,0 +1,184 @@
+package Tk::X11Font;
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/X11Font.pm#7 $
+
+require Tk::Widget;
+require Tk::Xlib;
+use strict;
+
+Construct Tk::Widget 'X11Font';
+
+my @field = qw(foundry family weight slant swidth adstyle pixel
+ point xres yres space avgwidth registry encoding);
+
+map { eval "sub \u$_ { shift->elem('$_', \@_) }" } @field;
+
+use overload '""' => 'as_string';
+
+sub new
+{
+ my $pkg = shift;
+ my $w = shift;
+
+ my %me = ();
+ my $d = $w->Display;
+
+ local $_;
+
+ if(scalar(@_) == 1)
+ {
+ my $pattern = shift;
+
+ if($pattern =~ /\A(-[^-]*){14}\Z/)
+ {
+ @me{@field} = split(/-/, substr($pattern,1));
+ }
+ else
+ {
+ $me{Name} = $pattern;
+
+ if($pattern =~ /^[^-]?-([^-]*-){2,}/)
+ {
+ my $f = $d->XListFonts($pattern,1);
+
+ if($f && $f =~ /\A(-[^-]*){14}/)
+ {
+ my @f = split(/-/, substr($f,1));
+ my @n = split(/-/, $pattern);
+ my %f = ();
+ my $i = 0;
+
+ shift @n if($pattern =~ /\A-/);
+
+ while(@n && @f)
+ {
+ if($n[0] eq '*')
+ {
+ shift @n;
+ }
+ elsif($n[0] eq $f[0])
+ {
+ $f{$field[$i]} = shift @n;
+ }
+ $i++;
+ shift @f;
+ }
+
+ %me = %f
+ unless(@n);
+ }
+ }
+ }
+ }
+ else
+ {
+ %me = @_;
+ }
+
+ map { $me{$_} ||= '*' } @field;
+
+ $me{Display} = $d;
+ $me{MainWin} = $w->MainWindow;
+
+ bless \%me, $pkg;
+}
+
+sub Pattern
+{
+ my $me = shift;
+ return join('-', '',@{$me}{@field});
+}
+
+sub Name
+{
+ my $me = shift;
+ my $max = wantarray ? shift || 128 : 1;
+
+ if ($^O eq 'MSWin32' or ($^O eq 'cygwin' and $Tk::platform eq 'MSWin32'))
+ {
+ my $name = $me->{Name};
+ if (!defined $name)
+ {
+ my $fm = $me->{'family'} || 'system';
+ my $sz = -int($me->{'point'}/10) || -($me->{'pixel'}) || 12;
+ my @opt = (-family => $fm, -size => $sz );
+ my $wt = $me->{'weight'};
+ if (defined $wt)
+ {
+ $wt = 'normal' unless $wt =~ /bold/i;
+ push(@opt,-weight => lc($wt));
+ }
+ my $sl = $me->{'slant'};
+ if (defined $sl)
+ {
+ $sl = ($sl =~ /^[io]/) ? 'italic' : 'roman';
+ push(@opt,-slant => $sl);
+ }
+ $name = join(' ',@opt);
+ }
+ return $name;
+ }
+ else
+ {
+ my $name = $me->{Name} ||
+ join('-', '',@{$me}{@field});
+ return $me->{Display}->XListFonts($name,$max);
+ }
+}
+
+sub as_string
+{
+ return shift->Name;
+}
+
+sub elem
+{
+ my $me = shift;
+ my $elem = shift;
+
+ return undef
+ if(exists $me->{'Name'});
+
+ my $old = $me->{$elem};
+
+ $me->{$elem} = shift
+ if(@_);
+
+ $old;
+}
+
+sub Clone
+{
+ my $me = shift;
+
+ $me = bless { %$me }, ref($me);
+
+ unless(exists $me->{'Name'})
+ {
+ while(@_)
+ {
+ my $k = shift;
+ my $v = shift || $me->{MainWin}->BackTrace('Tk::Font->Clone( key => value, ... )');
+ $me->{$k} = $v;
+ }
+ }
+
+ $me;
+}
+
+sub ascent
+{
+ my $me = shift;
+ my $name = $me->Name;
+ $me->{MainWin}->fontMetrics($name, '-ascent');
+}
+
+sub descent
+{
+ my $me = shift;
+ my $name = $me->Name;
+ $me->{MainWin}->fontMetrics($name, '-descent');
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/X11Font.pod b/Master/tlpkg/tlperl.straw/lib/Tk/X11Font.pod
new file mode 100755
index 00000000000..bd5b353abe0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/X11Font.pod
@@ -0,0 +1,88 @@
+
+=head1 NAME
+
+Tk::Font - a class for finding X Fonts
+
+=for pm Tk/X11Font.pm
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+ use Tk::X11Font;
+
+ $font = $widget->X11Font(foundry => 'adobe',
+ family => 'times',
+ point => 120
+ );
+
+ $font = $widget->X11Font('*-courier-medium-r-normal-*-*');
+
+=head1 DESCRIPTION
+
+ This module can be use to interrogate the X server what fonts are
+ avaliable.
+
+=head1 METHODS
+
+=head2 Foundry( [ $val ] )
+
+=head2 Family( [ $val ] )
+
+=head2 Weight( [ $val ] )
+
+=head2 Slant( [ $val ] )
+
+=head2 Swidth( [ $val ] )
+
+=head2 Adstyle( [ $val ] )
+
+=head2 Pixel( [ $val ] )
+
+=head2 Point( [ $val ] )
+
+=head2 Xres( [ $val ] )
+
+=head2 Yres( [ $val ] )
+
+=head2 Space( [ $val ] )
+
+=head2 Avgwidth( [ $val ] )
+
+=head2 Registry( [ $val ] )
+
+=head2 Encoding( [ $val ] )
+
+Set the given field in the font name to C<$val> if given and return the current
+or previous value
+
+=head2 Name( [ $max ] )
+
+In a list context it returns a list of all font names that match the
+fields given. It will return a maximum of C<$max> names, or 128 if
+$max is not given.
+
+In a scalar contex it returns the first matching name or undef
+
+=head2 Clone( [ key => value, [ ...]] )
+
+Create a duplicate of the curent font object and modify the given fields
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 HISTORY
+
+11-Jan-96 Initial version
+
+08-Nov-98 Renamed for Tk800.012
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-1996 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.straw/lib/Tk/Xcamel.gif b/Master/tlpkg/tlperl.straw/lib/Tk/Xcamel.gif
new file mode 100755
index 00000000000..cb88bc0afd8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Xcamel.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Xlib.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Xlib.pm
new file mode 100755
index 00000000000..1432361dc18
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Xlib.pm
@@ -0,0 +1,15 @@
+package Tk::Xlib;
+require DynaLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Xlib/Xlib.pm#4 $
+
+use Tk qw($XS_VERSION);
+use Exporter;
+
+use base qw(DynaLoader Exporter);
+@EXPORT_OK = qw(XDrawString XLoadFont XDrawRectangle);
+
+bootstrap Tk::Xlib;
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Xrm.pm b/Master/tlpkg/tlperl.straw/lib/Tk/Xrm.pm
new file mode 100755
index 00000000000..88f0d76a8c2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Xrm.pm
@@ -0,0 +1,9 @@
+package Tk::Xrm;
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tk/Xrm.pm#4 $
+
+use Tk ();
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/Xrm.pod b/Master/tlpkg/tlperl.straw/lib/Tk/Xrm.pod
new file mode 100755
index 00000000000..55f885bc849
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/Xrm.pod
@@ -0,0 +1,45 @@
+
+=head1 NAME
+
+Tk::Xrm - X Resource/Defaults/Options routines that obey the rules.
+
+=for pm Tk/Xrm.pm
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+ use Tk;
+ use Tk::Xrm;
+
+=head1 DESCRIPTION
+
+Using this modules causes Tk's Option code to be replaced by versions
+which use routines from <X11/Xresource.h> - i.e. same ones every other
+X toolkit uses.
+
+Result is that "matching" of name/Class with the options database follows
+the same rules as other X toolkits. This makes it more predictable,
+and makes it easier to have a single ~/.Xdefaults file which gives sensible
+results for both Tk and (say) Motif applications.
+
+=head1 BUGS
+
+Currently B<optionAdd>(I<key> =E<gt> I<value>?, I<priority>?) ignores optional
+priority completely and just does XrmPutStringResource().
+Perhaps it should be more subtle and do XrmMergeDatabases() or
+XrmCombineDatabase().
+
+This version is a little slower than Tk's re-invention but there is
+more optimization that can be done.
+
+=head1 SEE ALSO
+
+L<Tk::option|Tk::option>
+
+=head1 KEYWORDS
+
+database, option, priority, retrieve
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/act_folder.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/act_folder.xbm
new file mode 100755
index 00000000000..fc82949945b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/act_folder.xbm
@@ -0,0 +1,5 @@
+#define act_folder_width 16
+#define act_folder_height 10
+static unsigned char act_folder_bits[] = {
+ 0xfc, 0x00, 0xaa, 0x0f, 0x55, 0x15, 0xeb, 0xff, 0x15, 0x80, 0x0b, 0x40,
+ 0x05, 0x20, 0x03, 0x10, 0x01, 0x08, 0xff, 0x07};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/act_folder.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/act_folder.xpm
new file mode 100755
index 00000000000..0e7d682713a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/act_folder.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * act_folder_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 4 1",
+/* colors */
+" s None c None",
+". c black",
+"X c yellow",
+"o c #5B5B57574646",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".oXoXoXoXoXo. ",
+".XoX............",
+".oX.XXXXXXXXXXX.",
+".Xo.XXXXXXXXXX. ",
+".o.XXXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+"..XXXXXXXXXX.. ",
+"............. "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/after.pod b/Master/tlpkg/tlperl.straw/lib/Tk/after.pod
new file mode 100755
index 00000000000..97c61ba380b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/after.pod
@@ -0,0 +1,168 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::after - Execute a command after a time delay
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<after>(I<ms>)
+
+S< >I<$id> = I<$widget>-E<gt>B<after>(I<ms>?,I<callback>?)
+
+S< >I<$id> = I<$widget>-E<gt>B<repeat>(I<ms>?,I<callback>?)
+
+S< >I<$widget>-E<gt>B<afterCancel>(I<$id>)
+
+S< >I<$id> = I<$widget>-E<gt>B<afterIdle>(I<callback>)
+
+S< >I<$widget>-E<gt>B<afterInfo>?(I<$id>)?
+
+S< >I<$id>-E<gt>B<time>(?I<delay>?)
+
+=head1 DESCRIPTION
+
+This method is used to delay execution of the program or to execute
+a callback in background sometime in the future.
+
+In perl/Tk I<$widget>-E<gt>B<after> is implemented via the class C<Tk::After>,
+and callbacks are associated with I<$widget>, and are automatically cancelled
+when the widget is destroyed. An almost identical interface, but without
+automatic cancel, and without repeat is provided via Tk::after method.
+
+=head2 Internal Details
+
+The internal Tk::After class has the following synopsis:
+
+ $id = Tk::After->new($widget, tid, $time, 'once', callback);
+ $id = Tk::After->new($widget, tid, $time, 'repeat', callback);
+ $id->cancel;
+ $id->time(?delay?);
+
+$id is a Tk::After object, an array of 5 elements:
+
+I<$widget> is the parent widget reference.
+
+I<tid> is the internal timer id, a unique string.
+
+I<$time> is the string 'idle', representing an idle queue timer, or a
+integer millisecond value.
+
+I<once> or I<repeat> specifies whether the timer is a one-time B<after>
+event, or a repeating B<repeat> event.
+
+I<callback> specifies a Perl/Tk Tk::Callback object.
+
+=head1 Changing a B<repeat> timer interval
+
+It's posible to change a B<repeat> timer's delay value, or even cancel
+any timer, using the B<time> method. If I<delay> is specified and
+non-zero, a new timer delay is established. If I<delay> is zero the
+timer event is canceled just as if I<$id>-E<gt>B<cancel> were invoked.
+In all cases the current millisecond timer delay is returned.
+
+Note: the new timer delay will take effect on the I<subsequent> timer
+event - this command will not cancel the pending timer event and
+re-issue it with the new delay time.
+
+=head1 The after() method has several forms as follows:
+
+=over 4
+
+=item I<$widget>-E<gt>B<after>(I<ms>)
+
+The value I<ms> must be an integer giving a time in milliseconds.
+The command sleeps for I<ms> milliseconds and then returns.
+While the command is sleeping the application does not respond to
+events.
+
+=item I<$widget>-E<gt>B<after>(I<ms>,I<callback>)
+
+In this form the command returns immediately, but it arranges
+for I<callback> be executed I<ms> milliseconds later as an
+event handler.
+The callback will be executed exactly once, at the given time.
+The command will be executed in context of I<$widget>.
+If an error occurs while executing the delayed command then the
+L<Tk::Error|Tk::Error> mechanism is used to report the error.
+The B<after> command returns an identifier (an object in the perl/Tk
+case) that can be used to cancel the delayed command using B<afterCancel>.
+
+=item I<$widget>-E<gt>B<repeat>(I<ms>,I<callback>)
+
+In this form the command returns immediately, but it arranges
+for I<callback> be executed I<ms> milliseconds later as an
+event handler. After I<callback> has executed it is re-scheduled,
+to be executed in a futher I<ms>, and so on until it is cancelled.
+
+=item I<$widget>-E<gt>B<afterCancel>(I<$id>)
+
+=item I<$id>-E<gt>B<cancel>
+
+Cancels the execution of a delayed command that
+was previously scheduled.
+I<$id> indicates which command should be canceled; it must have
+been the return value from a previous B<after> command.
+If the command given by I<$id> has already been executed (and
+is not scheduled to be executed again) then B<afterCancel>
+has no effect.
+
+=item I<$widget>-E<gt>B<afterCancel>(I<callback>)
+
+I<This form is not robust in perl/Tk - its use is deprecated.>
+This command should also cancel the execution of a delayed command.
+The I<callback> argument is compared with pending callbacks,
+if a match is found, that callback is
+cancelled and will never be executed; if no such callback is
+currently pending then the B<afterCancel> has no effect.
+
+=item I<$widget>-E<gt>B<afterIdle>(I<callback>)
+
+Arranges for I<callback> to be evaluated later as an idle callback.
+The script will be run exactly once, the next time the event
+loop is entered and there are no events to process.
+The command returns an identifier that can be used
+to cancel the delayed command using B<afterCancel>.
+If an error occurs while executing the script then the
+L<Tk::Error|Tk::Error> mechanism is used to report the error.
+
+=item I<$widget>-E<gt>B<afterInfo>?(I<$id>)?
+
+This command returns information about existing event handlers. If no
+I<$id> argument is supplied, the command returns a list of the
+identifiers for all existing event handlers created by the B<after>
+and B<repeat> commands for I<$widget>. If I<$id> is supplied, it
+specifies an existing handler; I<$id> must have been the return value
+from some previous call to B<after> or B<repeat> and it must not have
+triggered yet or been cancelled. In this case the command returns a
+list with three elements. The first element of the list is the
+callback associated with I<$id>, the second element is either B<idle>
+or the I<integer> timer millisecond value to indicate what kind of
+event handler it is, and the third is a string I<once> or I<repeat> to
+differentiate an B<after> from a B<repeat> event.
+
+=back
+
+The B<after>(I<ms>) and B<afterIdle> forms of the command
+assume that the application is event driven: the delayed commands
+will not be executed unless the application enters the event loop.
+In applications that are not normally event-driven,
+the event loop can be entered with the B<vwait> and B<update> commands.
+
+=head1 SEE ALSO
+
+L<Tk::Error|Tk::Error>
+L<Tk::callbacks|Tk::callbacks>
+
+=head1 KEYWORDS
+
+cancel, delay, idle callback, sleep, time
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/anim.gif b/Master/tlpkg/tlperl.straw/lib/Tk/anim.gif
new file mode 100755
index 00000000000..96a50b701be
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/anim.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/arrowdownwin.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/arrowdownwin.xbm
new file mode 100755
index 00000000000..ea43fc75e7a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/arrowdownwin.xbm
@@ -0,0 +1,5 @@
+#define arrowdownwin2_width 9
+#define arrowdownwin2_height 13
+static char arrowdownwin2_bits[] = {
+ 0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x7c,0xfe,0x38,0xfe,0x10,
+ 0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/balArrow.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/balArrow.xbm
new file mode 100755
index 00000000000..ee0664a4727
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/balArrow.xbm
@@ -0,0 +1,4 @@
+#define balArrow_width 6
+#define balArrow_height 6
+static char balArrow_bits[] = {
+ 0x1f, 0x07, 0x07, 0x09, 0x11, 0x20};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/bind.pod b/Master/tlpkg/tlperl.straw/lib/Tk/bind.pod
new file mode 100755
index 00000000000..f595a48e318
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/bind.pod
@@ -0,0 +1,583 @@
+# Copyright (c) 1990 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::bind - Arrange for X events to invoke callbacks
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+Retrieve bindings:
+
+S< >I<$widget>-E<gt>B<bind>
+
+S< >I<$widget>-E<gt>B<bind>(I<tag>)
+
+S< >I<$widget>-E<gt>B<bind>(I<sequence>)
+
+S< >I<$widget>-E<gt>B<bind>(I<tag>,I<sequence>)
+
+Associate and destroy bindings:
+
+S< >I<$widget>-E<gt>B<bind>(I<sequence>,I<callback>)
+
+S< >I<$widget>-E<gt>B<bind>(I<tag>,I<sequence>,I<callback>)
+
+=head1 DESCRIPTION
+
+The B<bind> method associates callbacks with X events.
+If I<callback> is specified, B<bind> will
+arrange for I<callback> to be evaluated whenever
+the event(s) given by I<sequence> occur in the window(s)
+identified by I<$widget> or I<tag>.
+If I<callback> is an empty string then the current binding for
+I<sequence> is destroyed, leaving I<sequence> unbound.
+In all of the cases where a I<callback> argument is provided,
+B<bind> returns an empty string.
+
+If I<sequence> is specified without a I<callback>, then the
+callback currently bound to I<sequence> is returned, or
+B<undef> is returned if there is no binding for I<sequence>.
+If neither I<sequence> nor I<callback> is specified, then the
+return value is a list whose elements are all the sequences
+for which there exist bindings for I<tag>.
+
+If no I<tag> is specified then the B<bind> refers to I<$widget>.
+If I<tag> is specified then it is typically a class name and the B<bind>
+refers to all instances of the class on the B<MainWindow> associated
+with I<$widget>. (It is possible for I<tag> to be another "widget object"
+but this practice is deprecated.) Perl's B<ref>(I<$object>) can be used
+to get the class name of any object.
+Each window has an associated list of tags, and a binding applies
+to a particular window if its tag is among those specified for
+the window.
+Although the B<bindtags> method may be used to assign an
+arbitrary set of binding tags to a window, the default binding
+tags provide the following behavior:
+
+If a tag is the name of an internal window the binding applies
+to that window.
+
+If the tag is the name of a toplevel window the binding applies
+to the toplevel window and all its internal windows.
+
+If the tag is the name of a class of widgets, such as B<Tk::Button>,
+the binding applies to all widgets in that class;
+
+If I<tag> has the value B<all>,
+the binding applies to all windows descended from the MainWindow
+of the application.
+
+=head1 EVENT PATTERNS
+
+The I<sequence> argument specifies a sequence of one or more event
+patterns, with optional white space between the patterns. Each event
+pat may take one of three forms. In the simplest case it is a single
+printing ASCII character, such as B<a> or B<[>. The character may not
+be a space character or the character <. This form of pattern matches
+a B<KeyPress> event for the particular character. The second form of
+pattern is longer but more general. It has the following syntax:
+
+S< >'<modifier-modifier-type-detail>'
+
+The entire event pattern is surrounded by angle brackets, and normally
+needs to be quoted, as angle brackets are special to perl.
+Inside the angle brackets are zero or more modifiers, an event
+type, and an extra piece of information (I<detail>) identifying
+a particular button or keysym. Any of the fields may be omitted,
+as long as at least one of I<type> and I<detail> is present.
+The fields must be separated by white space or dashes.
+
+The third form of pattern is used to specify a user-defined, named virtual
+event; see L<Tk::event> for details. It has the following syntax:
+
+S< >'<<name>>'
+
+The entire virtual event pattern is surrounded by double angle brackets.
+Inside the angle brackets is the user-defined name of the virtual event.
+Modifiers, such as B<Shift> or B<Control>, may not be combined with a
+virtual event to modify it. Bindings on a virtual event may be created
+before the virtual event is defined, and if the definition of a virtual
+event changes dynamically, all windows bound to that virtual event will
+respond immediately to the new definition.
+
+=head1 MODIFIERS
+
+Modifiers consist of any of the following values:
+
+ Control Mod2, M2
+ Shift Mod3, M3
+ Lock Mod4, M4
+ Button1, B1 Mod5, M5
+ Button2, B2 Meta, M
+ Button3, B3 Alt
+ Button4, B4 Double
+ Button5, B5 Triple
+ Mod1, M1 Quadruple
+
+Where more than one value is listed, separated by commas, the values
+are equivalent.
+Most of the modifiers have the obvious X meanings.
+For example, B<Button1> requires that
+button 1 be depressed when the event occurs.
+For a binding to match a given event, the modifiers in the event
+must include all of those specified in the event pattern.
+An event may also contain additional modifiers not specified in
+the binding.
+For example, if button 1 is pressed while the shift and control keys
+are down, the pattern B<E<lt>Control-Button-1E<gt>> will match
+the event, but B<E<lt>Mod1-Button-1E<gt>> will not.
+If no modifiers are specified, then any combination of modifiers may
+be present in the event.
+
+B<Meta> and B<M> refer to whichever of the
+B<M1> through B<M5> modifiers is associated with the meta
+key(s) on the keyboard (keysyms B<Meta_R> and B<Meta_L>).
+If there are no meta keys, or if they are not associated with any
+modifiers, then B<Meta> and B<M> will not match any events.
+Similarly, the B<Alt> modifier refers to whichever modifier
+is associated with the alt key(s) on the keyboard (keysyms
+B<Alt_L> and B<Alt_R>).
+
+The B<Double>, B<Triple> and B<Quadruple> modifiers are a convenience
+for specifying double mouse clicks and other repeated events. They
+cause a particular event pattern to be repeated 2, 3 or 4 times, and
+also place a time and space requirement on the sequence: for a
+sequence of events to match a B<Double>, B<Triple> or B<Quadruple>
+pattern, all of the events must occur close together in time and
+without substantial mouse motion in between. For example,
+B<E<lt>Double-Button-1E<gt>> is equivalent to
+B<E<lt>Button-1E<gt>E<lt>Button-1E<gt>> with the extra time and space
+requirement.
+
+=head1 EVENT TYPES
+
+The I<type> field may be any of the standard X event types, with a
+few extra abbreviations. Below is a list of all the valid types;
+where two names appear together, they are synonyms.
+
+
+ Activate Destroy Map
+ ButtonPress, Button Enter MapRequest
+ ButtonRelease Expose Motion
+ Circulate FocusIn MouseWheel
+ CirculateRequest FocusOut Property
+ Colormap Gravity Reparent
+ Configure KeyPress, Key ResizeRequest
+ ConfigureRequest KeyRelease Unmap
+ Create Leave Visibility
+ Deactivate
+
+Most of the above events have the same fields and behaviors as events
+in the X Windowing system. You can find more detailed descriptions of
+these events in any X window programming book. A couple of the events
+are extensions to the X event system to support features unique to the
+Macintosh and Windows platforms. We provide a little more detail on
+these events here. These include:
+
+ Activate
+ Deactivate
+
+These two events are sent to every sub-window of a toplevel when they
+change state. In addition to the focus Window, the Macintosh platform
+and Windows platforms have a notion of an active window (which often
+has but is not required to have the focus). On the Macintosh, widgets
+in the active window have a different appearance than widgets in
+deactive windows. The Activate event is sent to all the sub-windows
+in a toplevel when it changes from being deactive to active.
+Likewise, the Deactive event is sent when the window's state changes
+from active to deactive. There are no use- ful percent substitutions
+you would make when binding to these events.
+
+ MouseWheel
+
+Some mice on the Windows platform support a mouse wheel which is
+used for scrolling documents without using the scrollbars. By
+rolling the wheel, the system will generate MouseWheel events that
+the application can use to scroll. Like Key events the event is
+always routed to the window that currently has focus. When the
+event is received you can use the %D substitution to get the delta
+field for the event which is a integer value of motion that the
+mouse wheel has moved. The smallest value for which the system
+will report is defined by the OS. On Windows 95 & 98 machines
+this value is at least 120 before it is reported. However, higher
+resolution devices may be available in the future. The sign of
+the value determines which direction your widget should scroll.
+Positive values should scroll up and negative values should scroll
+down.
+
+The last part of a long event specification is I<detail>. In the
+case of a B<ButtonPress> or B<ButtonRelease> event, it is the
+number of a button (1-5). If a button number is given, then only an
+event on that particular button will match; if no button number is
+given, then an event on any button will match. Note: giving a
+specific button number is different than specifying a button modifier;
+in the first case, it refers to a button being pressed or released,
+while in the second it refers to some other button that is already
+depressed when the matching event occurs. If a button
+number is given then I<type> may be omitted: if will default
+to B<ButtonPress>. For example, the specifier B<E<lt>1E<gt>>
+is equivalent to B<E<lt>ButtonPress-1E<gt>>.
+
+If the event type is B<KeyPress> or B<KeyRelease>, then
+I<detail> may be specified in the form of an X keysym. Keysyms
+are textual specifications for particular keys on the keyboard;
+they include all the alphanumeric ASCII characters (e.g. ``a'' is
+the keysym for the ASCII character ``a''), plus descriptions for
+non-alphanumeric characters (``comma'' is the keysym for the comma
+character), plus descriptions for all the non-ASCII keys on the
+keyboard (``Shift_L'' is the keysm for the left shift key, and
+``F1'' is the keysym for the F1 function key, if it exists). The
+complete list of keysyms is not presented here; it is
+available in other X documentation and may vary from system to
+system.
+If necessary, you can use the B<'K'> notation described below
+to print out the keysym name for a particular key.
+If a keysym I<detail> is given, then the
+I<type> field may be omitted; it will default to B<KeyPress>.
+For example, B<E<lt>Control-commaE<gt>> is equivalent to
+B<E<lt>Control-KeyPress-commaE<gt>>.
+
+=head1 BINDING CALLBACKS AND SUBSTITUTIONS
+
+The I<callback> argument to B<bind> is a perl/Tk callback.
+which will be executed whenever the given event sequence occurs.
+(See L<Tk::callbacks> for description of the possible forms.)
+I<Callback> will be associated with the same B<MainWindow>
+that is associated with the I<$widget> that was used to invoke
+the B<bind> method, and it will run as though called from B<MainLoop>.
+If I<callback> contains
+any B<Ev>(I<%>) calls, then each "nested" B<Ev>(I<%>)
+"callback" will be evaluated when the event occurs to form arguments
+to be passed to the main I<callback>.
+The replacement
+depends on the character I<%>, as defined in the
+list below. Unless otherwise indicated, the
+replacement string is the numeric (decimal) value of the given field from
+the current event. Perl/Tk has enhanced this mechanism slightly compared
+to the comparable Tcl/Tk mechanism. The enhancements are not yet all
+reflected in the list below.
+Some of the substitutions are only valid for
+certain types of events; if they are used for other types of events
+the value substituted is undefined (not the same as B<undef>!).
+
+=over 4
+
+=item B<'#'>
+
+The number of the last client request processed by the server
+(the I<serial> field from the event). Valid for all event
+types.
+
+=item B<'a'>
+
+The I<above> field from the event,
+formatted as a hexadecimal number.
+Valid only for B<Configure> events.
+
+=item B<'b'>
+
+The number of the button that was pressed or released. Valid only
+for B<ButtonPress> and B<ButtonRelease> events.
+
+=item B<'c'>
+
+The I<count> field from the event. Valid only for B<Expose> events.
+
+=item B<'d'>
+
+The I<detail> field from the event. The B<'d'> is replaced by
+a string identifying the detail. For B<Enter>,
+B<Leave>, B<FocusIn>, and B<FocusOut> events,
+the string will be one of the following:
+
+ NotifyAncestor NotifyNonlinearVirtual
+ NotifyDetailNone NotifyPointer
+ NotifyInferior NotifyPointerRoot
+ NotifyNonlinear NotifyVirtual
+
+For B<ConfigureRequest> events, the string will be one of:
+
+ Above Opposite
+ Below None
+ BottomIf TopIf
+
+For events other than these, the substituted string is undefined.
+(Note that this is I<not> the same as Detail part of sequence
+use to specify the event.)
+
+=item B<'f'>
+
+The I<focus> field from the event (B<0> or B<1>). Valid only
+for B<Enter> and B<Leave> events.
+
+=item B<'h'>
+
+The I<height> field from the event. Valid only for B<Configure>,
+B<ConfigureRequest>, B<Create>, B<Expose>, and B<ResizeRequest> events.
+
+=item B<'i'>
+
+The window field from the event, represented as a hexadecimal integer.
+
+=item B<'k'>
+
+The I<keycode> field from the event. Valid only for B<KeyPress>
+and B<KeyRelease> events.
+
+=item B<'m'>
+
+The I<mode> field from the event. The substituted string is one of
+B<NotifyNormal>, B<NotifyGrab>, B<NotifyUngrab>, or
+B<NotifyWhileGrabbed>. Valid only for B<Enter>,
+B<FocusIn>, B<FocusOut>, and B<Leave> events.
+
+=item B<'o'>
+
+The I<override_redirect> field from the event. Valid only for
+B<Map>, B<Reparent>, and B<Configure> events.
+
+=item B<'p'>
+
+The I<place> field from the event, substituted as one of the
+strings B<PlaceOnTop> or B<PlaceOnBottom>. Valid only
+for B<Circulate> and B<CirculateRequest> events.
+
+=item B<'s'>
+
+The I<state> field from the event. For B<ButtonPress>,
+B<ButtonRelease>, B<Enter>, B<KeyPress>, B<KeyRelease>,
+B<Leave>, and B<Motion> events, a decimal string
+is substituted. For B<Visibility>, one of the strings
+B<VisibilityUnobscured>, B<VisibilityPartiallyObscured>,
+and B<VisibilityFullyObscured> is substituted.
+
+=item B<'t'>
+
+The I<time> field from the event. Valid only for events that
+contain a I<time> field.
+
+=item B<'w'>
+
+The I<width> field from the event. Valid only for B<Configure>,
+B<ConfigueRequest>, B<Create>, B<Expose>, and B<ResizeREquest> events.
+
+=item B<'x'>
+
+The I<x> field from the event. Valid only for events containing
+an I<x> field.
+
+=item B<'y'>
+
+The I<y> field from the event. Valid only for events containing
+a I<y> field.
+
+=item B<'@'>
+
+The string "@I<x,y>" where I<x> and I<y> are as above.
+Valid only for events containing I<x> and I<y> fields.
+This format is used my methods of B<Tk::Text> and similar widgets.
+
+=item B<'A'>
+
+Substitutes the UNICODE character corresponding to the event, or
+the empty string if the event doesn't correspond to a UNICODE character
+(e.g. the shift key was pressed). B<XmbLookupString> does all the
+work of translating from the event to a UNICODE character.
+Valid only for B<KeyPress> and B<KeyRelease> events.
+
+=item B<'B'>
+
+The I<border_width> field from the event. Valid only for
+B<Configure>, B<ConfigureRequest> and B<Create> events.
+
+=item B<'D'>
+
+This reports the delta value of a B<MouseWheel> event. The delta
+value represents the rotation units the mouse wheel has been
+moved. On Windows 95 & 98 systems the smallest value for the
+delta is 120. Future systems may support higher resolution values
+for the delta. The sign of the value represents the direction the
+mouse wheel was scrolled.
+
+=item B<'E'>
+
+The I<send_event> field from the event. Valid for all event types.
+
+=item B<'K'>
+
+The keysym corresponding to the event, substituted as a textual
+string. Valid only for B<KeyPress> and B<KeyRelease> events.
+
+=item B<'N'>
+
+The keysym corresponding to the event, substituted as
+a decimal
+number. Valid only for B<KeyPress> and B<KeyRelease> events.
+
+=item B<'R'>
+
+The I<root> window identifier from the event. Valid only for
+events containing a I<root> field.
+
+=item B<'S'>
+
+The I<subwindow> window identifier from the event,
+as an object if it is one otherwise as a hexadecimal number.
+Valid only for events containing a I<subwindow> field.
+
+=item B<'T'>
+
+The I<type> field from the event. Valid for all event types.
+
+=item B<'W'>
+
+The window to which the event was reported (the
+$widget field from the event) - as an perl/Tk object.
+Valid for all event types.
+
+=item B<'X'>
+
+The I<x_root> field from the event.
+If a virtual-root window manager is being used then the substituted
+value is the corresponding x-coordinate in the virtual root.
+Valid only for
+B<ButtonPress>, B<ButtonRelease>, B<KeyPress>, B<KeyRelease>,
+and B<Motion> events.
+
+=item B<'Y'>
+
+The I<y_root> field from the event.
+If a virtual-root window manager is being used then the substituted
+value is the corresponding y-coordinate in the virtual root.
+Valid only for
+B<ButtonPress>, B<ButtonRelease>, B<KeyPress>, B<KeyRelease>,
+and B<Motion> events.
+
+=back
+
+=head1 MULTIPLE MATCHES
+
+It is possible for several bindings to match a given X event.
+If the bindings are associated with different I<tag>'s,
+then each of the bindings will be executed, in order.
+By default, a class binding will be executed first, followed
+by a binding for the widget, a binding for its toplevel, and
+an B<all> binding.
+The B<bindtags> method may be used to change this order for
+a particular window or to associate additional binding tags with
+the window.
+
+B<return> and B<Tk-E<gt>break> may be used inside a
+callback to control the processing of matching callbacks.
+If B<return> is invoked, then the current callback
+is terminated but Tk will continue processing callbacks
+associated with other I<tag>'s.
+If B<Tk-E<gt>break> is invoked within a callback,
+then that callback terminates and no other callbacks will be invoked
+for the event.
+(B<Tk-E<gt>break> is implemented via perl's B<die> with a special value
+which is "caught" by the perl/Tk "glue" code.)
+
+If more than one binding matches a particular event and they
+have the same I<tag>, then the most specific binding
+is chosen and its callback is evaluated.
+The following tests are applied, in order, to determine which of
+several matching sequences is more specific:
+(a) an event pattern that specifies a specific button or key is more specific
+than one that doesn't;
+(b) a longer sequence (in terms of number
+of events matched) is more specific than a shorter sequence;
+(c) if the modifiers specified in one pattern are a subset of the
+modifiers in another pattern, then the pattern with more modifiers
+is more specific.
+(d) a virtual event whose physical pattern matches the sequence is less
+specific than the same physical pattern that is not associated with a
+virtual event.
+(e) given a sequence that matches two or more virtual events, one
+of the virtual events will be chosen, but the order is undefined.
+
+If the matching sequences contain more than one event, then tests
+(c)-(e) are applied in order from the most recent event to the least recent
+event in the sequences. If these tests fail to determine a winner, then the
+most recently registered sequence is the winner.
+
+If there are two (or more) virtual events that are both triggered by the
+same sequence, and both of those virtual events are bound to the same window
+tag, then only one of the virtual events will be triggered, and it will
+be picked at random:
+
+ $widget->eventAdd('<<Paste>>' => '<Control-y>');
+ $widget->eventAdd('<<Paste>>' => '<Button-2>');
+ $widget->eventAdd <<Scroll>>' => '<Button-2>');
+ $widget->bind('Tk::Entry','<<Paste>>',sub { print 'Paste'});
+ $widget->bind('Tk::Entry','<<Scroll>>', sub {print 'Scroll'});
+
+If the user types Control-y, the B<E<lt>E<lt>PasteE<gt>E<gt>> binding
+will be invoked, but if the user presses button 2 then one of
+either the B<E<lt>E<lt>PasteE<gt>E<gt>> or the B<E<lt>E<lt>ScrollE<gt>E<gt>> bindings will
+be invoked, but exactly which one gets invoked is undefined.
+
+If an X event does not match any of the existing bindings, then the
+event is ignored.
+An unbound event is not considered to be an error.
+
+=head1 MULTI-EVENT SEQUENCES AND IGNORED EVENTS
+
+When a I<sequence> specified in a B<bind> method contains
+more than one event pattern, then its callback is executed whenever
+the recent events (leading up to and including the current event)
+match the given sequence. This means, for example, that if button 1 is
+clicked repeatedly the sequence B<E<lt>Double-ButtonPress-1E<gt>> will match
+each button press but the first.
+If extraneous events that would prevent a match occur in the middle
+of an event sequence then the extraneous events are
+ignored unless they are B<KeyPress> or B<ButtonPress> events.
+For example, B<E<lt>Double-ButtonPress-1E<gt>> will match a sequence of
+presses of button 1, even though there will be B<ButtonRelease>
+events (and possibly B<Motion> events) between the
+B<ButtonPress> events.
+Furthermore, a B<KeyPress> event may be preceded by any number
+of other B<KeyPress> events for modifier keys without the
+modifier keys preventing a match.
+For example, the event sequence B<aB> will match a press of the
+B<a> key, a release of the B<a> key, a press of the B<Shift>
+key, and a press of the B<b> key: the press of B<Shift> is
+ignored because it is a modifier key.
+Finally, if several B<Motion> events occur in a row, only
+the last one is used for purposes of matching binding sequences.
+
+=head1 ERRORS
+
+If an error occurs in executing the callback for a binding then the
+B<Tk::Error> mechanism is used to report the error.
+The B<Tk::Error> mechanism will be executed at same call level,
+and associated with the same B<MainWindow> as
+as the callback was invoked.
+
+=head1 CAVEATS
+
+Note that for the B<Canvas> widget, the call to B<bind> has to be
+fully qualified. This is because there is already a bind method for
+the B<Canvas> widget, which binds individual canvas tags.
+
+S< >I<$canvas>-E<gt>B<Tk::bind>
+
+=head1 SEE ALSO
+
+L<Tk::Error|Tk::Error>
+L<Tk::callbacks|Tk::callbacks>
+L<Tk::bindtags|Tk::bindtags>
+
+=head1 KEYWORDS
+
+Event, binding
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/bindtags.pod b/Master/tlpkg/tlperl.straw/lib/Tk/bindtags.pod
new file mode 100755
index 00000000000..e6a2b93bad7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/bindtags.pod
@@ -0,0 +1,107 @@
+# Copyright (c) 1990 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::bindtags - Determine which bindings apply to a window, and order of evaluation
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<bindtags>([I<tagList>]);
+
+I<@tags> = I<$widget>-E<gt>B<bindtags>;
+
+=head1 DESCRIPTION
+
+When a binding is created with the B<bind> command, it is
+associated either with a particular window such as I<$widget>,
+a class name such as B<Tk::Button>, the keyword B<all>, or any
+other string.
+All of these forms are called I<binding tags>.
+Each window has a list of binding tags that determine how
+events are processed for the window.
+When an event occurs in a window, it is applied to each of the
+window's tags in order: for each tag, the most specific binding
+that matches the given tag and event is executed.
+See the L<Tk::bind> documentation for more information on the matching
+process.
+
+By default, each window has four binding tags consisting of the
+the window's class name, name of the window, the name of the window's
+nearest toplevel ancestor, and B<all>, in that order.
+Toplevel windows have only three tags by default, since the toplevel
+name is the same as that of the window.
+
+Note that this order is I<different> from order used by Tcl/Tk.
+Tcl/Tk has the window ahead of the class name in the binding order.
+This is because Tcl is procedural rather than object oriented and
+the normal way for Tcl/Tk applications to override class bindings
+is with an instance binding. However, with perl/Tk the normal way
+to override a class binding is to derive a class. The perl/Tk order
+causes instance bindings to execute after the class binding, and
+so instance bind callbacks can make use of state changes (e.g. changes
+to the selection) than the class bindings have made.
+
+The B<bindtags> command allows the binding tags for a window to be
+read and modified.
+
+If I<$widget>-E<gt>B<bindtags> is invoked without an argument, then the
+current set of binding tags for $widget is returned as a list.
+If the I<tagList> argument is specified to B<bindtags>,
+then it must be a reference to and array; the tags for $widget are changed
+to the elements of the array. (A reference to an anonymous array can
+be created by enclosin the elements in B<[ ]>.)
+The elements of I<tagList> may be arbitrary strings or widget objects,
+if no window exists for an object at the time an event is processed,
+then the tag is ignored for that event.
+The order of the elements in I<tagList> determines the order in
+which binding callbacks are executed in response to events.
+For example, the command
+
+ $b->bindtags([$b,ref($b),$b->toplevel,'all'])
+
+applies the Tcl/Tk binding order which binding callbacks will be
+evaluated for a button (say) B<$b> so that B<$b>'s instance bindings
+are invoked first, following by bindings for B<$b>'s class, followed by
+bindings for B<$b>'s toplevel, followed by 'B<all>' bindings.
+
+If I<tagList> is an empty list i.e. B<[]>, then the binding
+tags for $widget are returned to the perl/Tk default state described above.
+
+The B<bindtags> command may be used to introduce arbitrary
+additional binding tags for a window, or to remove standard tags.
+For example, the command
+
+ $b->bindtags(['TrickyButton',$b->toplevel,'all'])
+
+replaces the (say) B<Tk::Button> tag for B<$b> with B<TrickyButton>.
+This means that the default widget bindings for buttons, which are
+associated with the B<Tk::Button> tag, will no longer apply to B<$b>,
+but any bindings associated with B<TrickyButton> (perhaps some
+new button behavior) will apply.
+
+=head1 BUGS
+
+The current mapping of the 'native' Tk behaviour of this method
+i.e. returning a list but only accepting a reference to an array is
+counter intuitive. The perl/Tk interface may be tidied up, returning
+a list is sensible so, most likely fix will be to allow a list to be
+passed to /fIset/fR the bindtags.
+
+=head1 SEE ALSO
+
+L<Tk::bind|Tk::bind>
+L<Tk::callbacks|Tk::callbacks>
+
+=head1 KEYWORDS
+
+binding, event, tag
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/callbacks.pod b/Master/tlpkg/tlperl.straw/lib/Tk/callbacks.pod
new file mode 100755
index 00000000000..5b62cb7c12c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/callbacks.pod
@@ -0,0 +1,104 @@
+# $Id: callbacks.pod 1.3 Thu, 27 Nov 1997 00:26:00 +0100 ach $
+
+=head1 NAME
+
+Tk::callbacks - Specifying code for Tk to call.
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+One can specify a callback in one of the following ways:
+
+Without arguments:
+
+ ... => \&subname, ...
+ ... => sub { ... }, ...
+ ... => 'methodname', ...
+
+or with arguments:
+
+ ... => [ \&subname, args ... ], ...
+ ... => [ sub { ... }, args... ], ...
+ ... => [ 'methodname', args... ], ...
+
+=head1 DESCRIPTION
+
+Perl/Tk has a callback, where Tcl/Tk has a command string (i.e. a fragment of
+Tcl to be executed). A perl/Tk callback can take one of the following
+basic forms:
+
+=over 4
+
+=item * Reference to a subroutine C<\E<amp>subname>
+
+=item * Anonymous subroutine (closure) C<sub { ... }>
+
+=item * A method name C<'methodname'>
+
+=back
+
+Any of these can be provided with arguments by enclosing them and the
+arguments in B<[]>. Here are some examples:
+
+I<$mw>->B<bind>(I<$class,> B<"E<lt>DeleteE<gt>" =E<gt> 'Delete'>);
+
+This will call I<$widget>->B<Delete>, the I<$widget> being provided (by bind) as
+the one where the Delete key was pressed.
+
+While having bind provide a widget object for you is ideal in many cases
+it can be irritating in others. Using the list form this behaviour
+can be modified:
+
+I<$a>-E<gt>B<bind>(B<"E<lt>DeleteE<gt>">,[I<$b> =E<gt> 'Delete']);
+
+because the first element I<$b> is an object bind
+will call I<$b>-E<gt>B<Delete>.
+
+Note that method/object ordering only matters for C<bind> callbacks,
+the auto-quoting in perl5.001 makes the first of these a little more readable:
+
+ $w->configure(-yscrollcommand => [ set => $ysb]);
+ $w->configure(-yscrollcommand => [ $ysb => 'set' ]);
+
+but both will call C<$ysb>-E<gt>set(args provided by Tk)
+
+Another use of arguments allows you to write generalized methods which are
+easier to re-use:
+
+ $a->bind("<Next>",['Next','Page']);
+ $a->bind("<Down>",['Next','Line']);
+
+This will call C<$a>-E<gt>I<Next>('Page') or C<$a>-E<gt>I<Next>('Line') respectively.
+
+Note that the contents of the C<[]> are evaluated by perl when the
+callback is created. It is often desirable for the arguments provided
+to the callback to depend on the details of the event which caused
+it to be executed. To allow for this callbacks can be nested using the
+C<Ev(...)> "constructor".
+C<Ev(...)> inserts callback objects into the
+argument list. When perl/Tk glue code is preparing the argument list for
+the callback it is about to call it spots these special objects and
+recursively applies the callback process to them.
+
+=head1 EXAMPLES
+
+ $entry->bind('<Return>' => [$w , 'validate', Ev(['get'])]);
+
+ $toplevel->bind('all', '<Visibility>', [\&unobscure, Ev('s')]);
+
+ $mw->bind($class, '<Down>', ['SetCursor', Ev('UpDownLine',1)]);
+
+=head1 SEE ALSO
+
+L<Tk::bind|Tk::bind>
+L<Tk::after|Tk::after>
+L<Tk::options|Tk::options>
+L<Tk::fileevent|Tk::fileevent>
+
+=head1 KEYWORDS
+
+callback, closure, anonymous subroutine, bind
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/cbxarrow.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/cbxarrow.xbm
new file mode 100755
index 00000000000..ae4054488b9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/cbxarrow.xbm
@@ -0,0 +1,6 @@
+#define cbxarrow_width 11
+#define cbxarrow_height 14
+static char cbxarrow_bits[] = {
+ 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00,
+ 0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00,
+ 0xfe, 0x03, 0xfe, 0x03};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/chooseColor.pod b/Master/tlpkg/tlperl.straw/lib/Tk/chooseColor.pod
new file mode 100755
index 00000000000..dbb8f158efa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/chooseColor.pod
@@ -0,0 +1,64 @@
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+chooseColor - pops up a dialog box for the user to select a color.
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+S< >I<$color> = I<$widget>-E<gt>B<chooseColor>?(I<-option>=E<gt>I<value>, ...)?;
+
+=head1 DESCRIPTION
+
+The method B<chooseColor> is implemented as a perl wrapper
+on the core tk "command" B<tk_chooseColor>, and I<$widget>
+is passed as the argument to the hidden B<-parent> option.
+The implementation of internal B<tk_chooseColor> is platform
+specific, on Win32 it is a native dialog, and on UNIX/X11 it is implemented
+in terms of L<Tk::ColorEditor|Tk::ColorEditor>.
+
+The B<chooseColor> method pops up a dialog box for the
+user to select a color. The following I<option-value> pairs are
+possible as command line arguments:
+
+=over 4
+
+=item B<-initialcolor>=E<gt>I<color>
+
+Specifies the color to display in the color dialog when it pops
+up. I<color> must be in a form acceptable to the B<Tk_GetColor>
+function.
+
+=item B<-parent>=E<gt>$widget
+
+Makes $widget the logical parent of the color dialog. The color
+dialog is displayed on top of its parent window.
+
+=item B<-title>=E<gt>I<titleString>
+
+Specifies a string to display as the title of the dialog box. If this
+option is not specified, then a default title will be displayed.
+
+=back
+
+If the user selects a color, B<tk_chooseColor> will return the
+name of the color in a form acceptable to B<Tk_GetColor>. If the
+user cancels the operation, the command will return B<undef>.
+
+=head1 EXAMPLE
+
+ $widget->configure(-fg => $parent->chooseColor(-initialcolor => 'gray',
+ -title => "Choose color"));
+
+=head1 KEYWORDS
+
+color selection dialog
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/chooseDirectory.pod b/Master/tlpkg/tlperl.straw/lib/Tk/chooseDirectory.pod
new file mode 100755
index 00000000000..dee14186c82
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/chooseDirectory.pod
@@ -0,0 +1,85 @@
+# Copyright (c) 1998-2000 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: chooseDirectory.n,v 1.1 2000/01/27 00:23:10 ericm Exp $
+#
+
+=head1 NAME
+
+chooseDirectory - pops up a dialog box for the user to select a directory.
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<chooseDirectory>( ?I<option value ...>? );
+
+=head1 DESCRIPTION
+
+The method B<chooseDirectory> is implemented as a perl wrapper on the
+core tk "command" B<tk_chooseDirectory>, and I<$widget> is passed as
+the argument to the hidden B<-parent> option.
+
+The B<chooseDirectory>
+method pops up a dialog box for the user to select a directory. The
+following I<option-value> pairs are possible as command line
+arguments:
+
+=over 4
+
+=item B<-initialdir> I<dirname>
+
+Specifies that the directories in I<directory> should be displayed
+when the dialog pops up. If this parameter is not specified, then
+the directories in the current working directory are displayed. If the
+parameter specifies a relative path, the return value will convert the
+relative path to an absolute path. This option may not always work on
+the Macintosh. This is not a bug. Rather, the I<General Controls>
+control panel on the Mac allows the end user to override the
+application default directory.
+
+=item B<-parent> $widget
+
+Makes $widget the logical parent of the dialog. The dialog
+is displayed on top of its parent window.
+
+=item B<-title> I<titleString>
+
+Specifies a string to display as the title of the dialog box. If this
+option is not specified, then a default title will be displayed.
+
+=item B<-mustexist> I<boolean>
+
+Specifies whether the user may specify non-existant directories. If
+this parameter is true, then the user may only select directories that
+already exist. The default value is I<false>.
+
+=back
+
+=head1 CAVEATS
+
+Perl does not have a concept of encoded filesystems yet. This means
+that operations on filenames like C<opendir> and C<open> still use
+byte semantics. Tk however uses character semantics internally, which
+means that you can get filenames with the UTF-8 flag set in functions
+like C<chooseDirectory>, C<getOpenFile> and similar. It's the user's
+responsibility to determine the encoding of the underlying filesystem
+and convert the result into bytes, e.g.
+
+ use Encode;
+ ...
+ my $dir = $mw->chooseDirectory;
+ $dir = encode("windows-1252", $dir);
+ opendir DIR, $dir or die $!;
+ ...
+
+See also L<perlunicode/When Unicode Does Not Happen> and
+L<perltodo/Unicode in Filenames>.
+
+=head1 SEE ALSO
+
+L<Tk::getOpenFile>, L<Tk::getOpenFile>
+
+=head1 KEYWORDS
+
+directory selection dialog
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/composite.pod b/Master/tlpkg/tlperl.straw/lib/Tk/composite.pod
new file mode 100755
index 00000000000..a493b5ee1f2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/composite.pod
@@ -0,0 +1,171 @@
+# $Id: composite.pod 1.2 Wed, 12 Nov 1997 00:30:45 +0100 ach $
+
+=head1 NAME
+
+Tk::composite - Defining a new composite widget class
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ package Tk::MyNewWidget;
+
+ use Tk:widgets qw/ list of Tk widgets /;
+ use base qw/ Tk::Frame /; # or Tk::Toplevel
+
+ Construct Tk::Widget 'MyNewWidget';
+
+ sub ClassInit {
+ my( $class, $mw ) = @_;
+ #... e.g., class bindings here ...
+ $class->SUPER::ClassInit( $mw );
+ }
+
+ sub Populate {
+ my( $self, $args ) = @_;
+
+ my $flag = delete $args->{-flag};
+ if( defined $flag ) {
+ # handle -flag => xxx which can only be done at create
+ # time the delete above ensures that new() does not try
+ # and do $self->configure( -flag => xxx );
+ }
+
+ $self->SUPER::Populate( $args );
+
+ $self = $self->Component( ... );
+
+ $self->Delegates( ... );
+
+ $self->ConfigSpecs(
+ '-cursor' => [ SELF, 'cursor', 'Cursor', undef ],
+ '-something' => [ METHOD, dbName, dbClass, default ],
+ '-text' => [ $label, dbName, dbClass, default ],
+ '-heading' => [ {-text => $head},
+ heading, Heading, 'My Heading' ],
+ );
+ }
+
+ sub something {
+ my( $self, $value) = @_;
+ if ( @_ > 1 ) {
+ # set it
+ }
+ return # current value
+ }
+
+ 1;
+
+ __END__
+
+
+ =head1 NAME
+
+ Tk::Whatever - a whatever widget
+
+ =head1 SYNOPSIS
+
+ use Tk::Whatever;
+
+ $widget = $parent->Whatever(...);
+
+ =head1 DESCRIPTION
+
+ ...
+
+=head1 DESCRIPTION
+
+The intention behind a composite is to create a higher-level widget,
+sometimes called a "super-widget" or "mega-widget". Most often,
+a composite will be
+built upon other widgets by B<using> them, as opposed to specializing on them.
+For example, the supplied composite widget B<LabEntry> is I<made of> an
+B<Entry> and a B<Label>; it is neither a I<kind-of> B<Label>
+nor is it a I<kind-of> B<Entry>.
+
+Most of the work of a composite widget consistd in creating subwidgets,
+arranging to dispatch configure options to the proper subwidgets and manage
+composite-specific configure options.
+
+=head1 GLORY DETAILS
+
+Depending on your Perl/Tk knowledge this section may be enlighting
+or confusing.
+
+=head2 Composite Widget
+
+Since Perl/Tk is heavilly using an object-oriented approach, it is no
+suprise that creating a composite goes through a B<new()> method.
+However, the composite does not normally define a B<new()> method
+itself: it is usually sufficient to simply inherit it from
+B<Tk::Widget>.
+
+This is what happens when the composite uses
+
+ use base qw/ Tk::Frame /; # or Tk::Toplevel
+
+to specify its inheritance chain. To complete the initialisation of the
+widget, it must call the B<Construct> method from class B<Widget>. That
+method accepts the name of the new class to create, i.e. the package name
+of your composite widget:
+
+ Construct Tk::Widget 'MyNewWidget';
+
+Here, B<MyNewWidget> is the package name (aka the widget's B<class>). This
+will define a constructor method for B<MyNewWidget>, normally named after the
+widget's class. Instanciating that composite in client code would
+the look like:
+
+ $mw = MainWindow->new; # creates a top-level MainWindow
+
+ $self = $mw->MyNewWidget(); # creates an instance of the
+ # composite widget MyNewWidget
+
+Whenever a composite is instanciated in client code,
+C<Tk::Widget::new()> will be invoked via the widget's class
+constructor. That B<new> method will call
+
+ $self->Populate(\%args);
+
+where I<%args> is the arguments passed to the widget's constructor. Note
+that B<Populate> receives a B<reference> to the hash array
+containing all arguments.
+
+B<Populate> is typically defined in the composite class (package),
+which creates the characteristic subwidgets of the class.
+
+=head2 Creating Subwidgets
+
+Subwidget creation happens usually in B<Populate()>.
+The composite usually calls the
+subwidget's constructor method either directly, for "private" subwidgets,
+or indirectly through the B<Component> method for subwidgets that should
+be advertised to clients.
+
+B<Populate> may call B<Delegates> to direct calls to methods
+of chosen subwidgets. For simple composites, typically most if not all
+methods are directed
+to a single subwidget - e.g. B<ScrListbox> directs all methods to the core
+B<Listbox> so that I<$composite>-E<gt>B<get>(...) calls
+I<$listbox>-E<gt>B<get>(...).
+
+=head2 Defining mega-widget options
+
+B<Populate> should also call B<ConfigSpecs()> to specify the
+way that configure-like options should be handled in the composite.
+Once B<Populate> returns, method B<Tk::Frame::ConfigDefault>
+walks through the B<ConfigSpecs> entries and populates
+%$args hash with defaults for options from X resources (F<.Xdefaults>, etc).
+
+When B<Populate> returns to B<Tk::Widget::new()>,
+a call to B<$self>-E<gt>I<configure>(%$args) is made which sets *all*
+the options.
+
+=head1 SEE ALSO
+
+L<Tk::ConfigSpecs|Tk::ConfigSpecs>
+L<Tk::mega|Tk::mega>
+L<Tk::Derived|Tk::Derived>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/LabEnLabRad.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/LabEnLabRad.pm
new file mode 100755
index 00000000000..c49ef0b1881
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/LabEnLabRad.pm
@@ -0,0 +1,41 @@
+package Tk::LabeledEntryLabeledRadiobutton;
+require Tk::Frame;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/demos/demos/LabEnLabRad.pm#4 $
+
+use base qw(Tk::Frame);
+
+require Tk::LabEntry;
+require Tk::LabRadio;
+
+Construct Tk::Widget 'LabeledEntryLabeledRadiobutton';
+
+sub Populate
+{
+
+ # LabeledEntryLabeledRadiobutton(s) constructor.
+ #
+ # Advertised subwidgets: labeled_entry, labeled_radiobutton.
+
+ my($cw, $args) = @_;
+
+ my $e = $cw->Component(LabEntry => 'labeled_entry');
+ $e->pack(-side => 'left', -expand => 1, -fill => 'both');
+
+ my $r = $cw->Component(LabRadiobutton => 'labeled_radiobutton',
+ -radiobuttons => delete $args->{'-radiobuttons'}
+ );
+ $r->pack(-side => 'left', -expand => 1, -fill => 'both');
+ $cw->ConfigSpecs(-entry_label => [ Tk::Configure->new($e,'-label'), undef, undef, 'Entry' ],
+ -radio_label => [ Tk::Configure->new($r,'-label'), undef, undef, Choose ],
+ -entry_variable => [ Tk::Configure->new($e,'-textvariable'), undef, undef, \$cw->{Config}{-text} ],
+ -radio_variable => [ Tk::Configure->new($r,'-variable'), undef, undef, undef ],
+ -indicatoron => [ 'labeled_radiobutton' , undef, undef, undef ],
+ DEFAULT => [ ['labeled_entry','labeled_radiobutton']],
+ );
+ $cw->Delegates(DEFAULT => 'labeled_entry');
+
+} # end LabeledEntryLabeledRadiobutton(s) constructor
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPB.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPB.xpm
new file mode 100755
index 00000000000..54f69c505d2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPB.xpm
@@ -0,0 +1,48 @@
+/* XPM */
+static char * QuitPB_xpm[] = {
+"64 40 5 1",
+" c none",
+". c #000000000000",
+"X c #00000000FFFF",
+"o c #FFFFFFFFFFFF",
+"O c #820782078207",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ............. ",
+" .XXXXXXXXXXX. ",
+" .XXXXXXXXXXX. ",
+" .XXXXXXXXXXX. ",
+" .XXXXXXXXXXX. ",
+" .XXXXXXXXXXX. ",
+" .XXXXXXXXXXX. .. . ",
+" .XXXXXXX..XX. . . . . ",
+" .XXXXXX.o .X. . . . ",
+" .XXXXXX. .X. . . . . . .... ",
+" .XXXXXXX..XX. . . . . . . ",
+" .XXXXXXXXXXX. . . . . . . ",
+" .XXXXXXXXXXX. . . . . . . ",
+" .XXXXXXXXXXX. . . . . . . . ",
+" .XXXXXXXXXXX. . .. . . . . ",
+" .XXXXXXXXXXX. . .. .. .. . . ",
+" .......XXXXXXXXXXX........ .. . .. . . .. ",
+" OOOOOO.XXXXXXXXXXX.OOOOOOO ",
+" .......................... ........ ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPBa.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPBa.xpm
new file mode 100755
index 00000000000..6f00b62c1a5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/QuitPBa.xpm
@@ -0,0 +1,48 @@
+/* XPM */
+static char * QuitPBa_xpm[] = {
+"64 40 5 1",
+" c none",
+". c #820782078207",
+"X c #000000000000",
+"o c #000082070000",
+"O c #00000000FFFF",
+" ",
+" ",
+" . ",
+" . ",
+" . .X ",
+" . ... ",
+" XXXXXXXXXXXXX . X.oo ",
+" XX X .Xooo ",
+" XX X oX.ooo . ",
+" XOX . X ooo.oo . ",
+" XOX . X . .. oooo . ",
+" XOOX . X . . oo . ",
+" XOOX XX . . ",
+" XOOX XXXX ",
+" XOOX XXX XX XX X ",
+" XOOX XX XXX XX X X X X ",
+" XOOX XXX XX X X X X ",
+" XOXX . XXXXXX X X X X X XXXX ",
+" XX X .. XXXX X X X X X X ",
+" XX X . . XXX X X X X X X ",
+" XOXX .. XXXXX X X X X X X ",
+" XOOX . . XX X XXX X X X X X X X ",
+" XXXXXXXOOX . XXXXXXXXX X XX X X X X ",
+" ......XOOX . XX....XXX X XX XX XX X X ",
+" XXXXXXXOOX . . XXXXXXXXX XX X XX X X XX ",
+" XOX . XXXX X ",
+" XOX . XXX XXXXXXXX ",
+" XX . ",
+" XX . ",
+" . ",
+" . ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/c.icon b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/c.icon
new file mode 100755
index 00000000000..6ae6638097c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/c.icon
@@ -0,0 +1,16 @@
+#define c.icon_width 32
+#define c.icon_height 32
+#define c.icon_x_hot 16
+#define c.icon_y_hot 16
+static char c.icon_bits[] = {
+ 0xfc, 0xff, 0xff, 0x00, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x02,
+ 0x04, 0x00, 0x80, 0x04, 0x04, 0x00, 0x80, 0x08, 0x04, 0x00, 0x80, 0x10,
+ 0x04, 0x00, 0x80, 0x20, 0x04, 0x00, 0x80, 0x7f, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0xe0, 0x37, 0x60,
+ 0x04, 0xf8, 0x3f, 0x60, 0x04, 0x38, 0x3c, 0x60, 0x04, 0x1c, 0x38, 0x60,
+ 0x04, 0x0c, 0x30, 0x60, 0x04, 0x0c, 0x00, 0x60, 0x04, 0x0c, 0x00, 0x60,
+ 0x04, 0x1c, 0x00, 0x60, 0x04, 0x38, 0x70, 0x60, 0x64, 0xf8, 0x7f, 0x60,
+ 0x64, 0xe0, 0x1f, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0xfc, 0xff, 0xff, 0x7f, 0xf8, 0xff, 0xff, 0x7f};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.cur b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.cur
new file mode 100755
index 00000000000..c74a85ff8ff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.cur
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.mask b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.mask
new file mode 100755
index 00000000000..2548715dd01
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.mask
@@ -0,0 +1,6 @@
+#define cursor_mask_width 17
+#define cursor_mask_height 12
+static char cursor_mask_bits[] = {
+ 0x20, 0x00, 0x00, 0x90, 0x20, 0x00, 0x40, 0x40, 0x00, 0x0c, 0x40, 0x00,
+ 0x1c, 0x8f, 0x00, 0x9c, 0xbf, 0x00, 0xfc, 0x3f, 0x01, 0xfc, 0x7f, 0x01,
+ 0xfe, 0x7f, 0x01, 0xfe, 0xff, 0x00, 0xff, 0xff, 0x00, 0xff, 0x7f, 0x00};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.xbm
new file mode 100755
index 00000000000..2646ea7aa77
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/cursor.xbm
@@ -0,0 +1,8 @@
+#define cursor_width 17
+#define cursor_height 12
+#define cursor_x_hot 8
+#define cursor_y_hot 7
+static char cursor_bits[] = {
+ 0x20, 0x00, 0x00, 0x90, 0x20, 0x00, 0x40, 0x40, 0x00, 0x0c, 0x40, 0x00,
+ 0x14, 0x8f, 0x00, 0x94, 0xb0, 0x00, 0x7c, 0x20, 0x01, 0x0c, 0x4c, 0x01,
+ 0x0a, 0x42, 0x01, 0x42, 0x82, 0x00, 0x3b, 0x87, 0x00, 0xff, 0x7f, 0x00};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.icon b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.icon
new file mode 100755
index 00000000000..af2dc3e4fa1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.icon
@@ -0,0 +1,16 @@
+#define nfm_dir.icon_width 32
+#define nfm_dir.icon_height 32
+#define nfm_dir.icon_x_hot 16
+#define nfm_dir.icon_y_hot 16
+static char nfm_dir.icon_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08, 0x20,
+ 0xfe, 0xff, 0x07, 0x40, 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0,
+ 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0,
+ 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0,
+ 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0,
+ 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0,
+ 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0,
+ 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0,
+ 0xff, 0xff, 0xff, 0xff, 0xfe, 0xff, 0xff, 0xff};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.mask b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.mask
new file mode 100755
index 00000000000..1cd406b5802
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/dir.mask
@@ -0,0 +1,16 @@
+#define nfm_dir.mask_width 32
+#define nfm_dir.mask_height 32
+#define nfm_dir.mask_x_hot 16
+#define nfm_dir.mask_y_hot 16
+static char nfm_dir.mask_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00, 0xf8, 0x3f,
+ 0xfe, 0xff, 0xff, 0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0xff, 0xfe, 0xff, 0xff, 0xff};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/earth.gif b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/earth.gif
new file mode 100755
index 00000000000..2c229eb1101
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/earth.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/earthris.gif b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/earthris.gif
new file mode 100755
index 00000000000..c4ee4737279
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/earthris.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/face b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/face
new file mode 100755
index 00000000000..03d829f4d1f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/face
@@ -0,0 +1,173 @@
+#define face_width 108
+#define face_height 144
+#define face_x_hot 48
+#define face_y_hot 80
+static char face_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x09,
+ 0x20, 0x80, 0x24, 0x05, 0x00, 0x80, 0x08, 0x00, 0x00, 0x00, 0x00, 0x88,
+ 0x24, 0x20, 0x80, 0x24, 0x00, 0x00, 0x00, 0x10, 0x80, 0x04, 0x00, 0x01,
+ 0x00, 0x01, 0x40, 0x0a, 0x09, 0x00, 0x92, 0x04, 0x80, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x10, 0x40, 0x12, 0x00, 0x00, 0x10, 0x40, 0x00, 0x00, 0x84,
+ 0x24, 0x40, 0x22, 0xa8, 0x02, 0x14, 0x84, 0x92, 0x40, 0x42, 0x12, 0x04,
+ 0x10, 0x00, 0x00, 0x00, 0x00, 0x52, 0x00, 0x52, 0x11, 0x00, 0x12, 0x00,
+ 0x40, 0x02, 0x00, 0x20, 0x00, 0x08, 0x00, 0xaa, 0x02, 0x54, 0x85, 0x24,
+ 0x00, 0x10, 0x12, 0x00, 0x00, 0x81, 0x44, 0x00, 0x90, 0x5a, 0x00, 0xea,
+ 0x1b, 0x00, 0x80, 0x40, 0x40, 0x02, 0x00, 0x08, 0x00, 0x20, 0xa2, 0x05,
+ 0x8a, 0xb4, 0x6e, 0x45, 0x12, 0x04, 0x08, 0x00, 0x00, 0x00, 0x10, 0x02,
+ 0xa8, 0x92, 0x00, 0xda, 0x5f, 0x10, 0x00, 0x10, 0xa1, 0x04, 0x20, 0x41,
+ 0x02, 0x00, 0x5a, 0x25, 0xa0, 0xff, 0xfb, 0x05, 0x41, 0x02, 0x04, 0x00,
+ 0x00, 0x08, 0x40, 0x80, 0xec, 0x9b, 0xec, 0xfe, 0x7f, 0x01, 0x04, 0x20,
+ 0x90, 0x02, 0x04, 0x00, 0x08, 0x20, 0xfb, 0x2e, 0xf5, 0xff, 0xff, 0x57,
+ 0x00, 0x04, 0x02, 0x00, 0x00, 0x20, 0x01, 0xc1, 0x6e, 0xab, 0xfa, 0xff,
+ 0xff, 0x05, 0x90, 0x20, 0x48, 0x02, 0x00, 0x04, 0x20, 0xa8, 0xdf, 0xb5,
+ 0xfe, 0xff, 0xff, 0x0b, 0x01, 0x00, 0x01, 0x00, 0x80, 0x80, 0x04, 0xe0,
+ 0xbb, 0xef, 0xff, 0xff, 0x7f, 0x01, 0x00, 0x04, 0x48, 0x02, 0x00, 0x20,
+ 0x80, 0xf4, 0x6f, 0xfb, 0xff, 0xff, 0xff, 0x20, 0x90, 0x40, 0x02, 0x00,
+ 0x00, 0x04, 0x08, 0xb8, 0xf6, 0xff, 0xff, 0xdf, 0xbe, 0x12, 0x45, 0x10,
+ 0x90, 0x04, 0x90, 0x00, 0x22, 0xfa, 0xff, 0xff, 0xff, 0xbb, 0xd7, 0xe9,
+ 0x3a, 0x02, 0x02, 0x00, 0x04, 0x90, 0x80, 0xfe, 0xdf, 0xf6, 0xb7, 0xef,
+ 0xbe, 0x56, 0x57, 0x40, 0x48, 0x09, 0x00, 0x04, 0x00, 0xfa, 0xf5, 0xdf,
+ 0xed, 0x5a, 0xd5, 0xea, 0xbd, 0x09, 0x00, 0x00, 0x40, 0x00, 0x92, 0xfe,
+ 0xbf, 0x7d, 0xb7, 0x6a, 0x55, 0xbf, 0xf7, 0x02, 0x11, 0x01, 0x00, 0x91,
+ 0x00, 0xff, 0xff, 0xaf, 0x55, 0x55, 0x5b, 0xeb, 0xef, 0x22, 0x04, 0x04,
+ 0x04, 0x00, 0xa4, 0xff, 0xf7, 0xad, 0xaa, 0xaa, 0xaa, 0xbe, 0xfe, 0x03,
+ 0x20, 0x00, 0x10, 0x44, 0x80, 0xff, 0x7f, 0x55, 0x12, 0x91, 0x2a, 0xeb,
+ 0xbf, 0x0b, 0x82, 0x02, 0x00, 0x00, 0xd1, 0x7f, 0xdf, 0xa2, 0xa4, 0x54,
+ 0x55, 0xfd, 0xfd, 0x47, 0x08, 0x08, 0x00, 0x21, 0xe4, 0xff, 0x37, 0x11,
+ 0x09, 0xa5, 0xaa, 0xb6, 0xff, 0x0d, 0x80, 0x00, 0x00, 0x04, 0xd0, 0xff,
+ 0x4f, 0x44, 0x20, 0x48, 0x55, 0xfb, 0xff, 0x27, 0x11, 0x02, 0x40, 0x40,
+ 0xe2, 0xfb, 0x15, 0x11, 0x4a, 0x55, 0x4a, 0x7d, 0xf7, 0x0f, 0x00, 0x00,
+ 0x04, 0x08, 0xf8, 0xdf, 0x52, 0x44, 0x01, 0x52, 0xb5, 0xfa, 0xff, 0x0f,
+ 0x49, 0x02, 0x00, 0x02, 0xe9, 0xf6, 0x0a, 0x11, 0xa4, 0x88, 0x4a, 0x6d,
+ 0xff, 0x5f, 0x00, 0x00, 0x10, 0x20, 0xf0, 0x2f, 0x21, 0x44, 0x10, 0x52,
+ 0xb5, 0xfa, 0xff, 0x0f, 0x44, 0x04, 0x80, 0x08, 0xf8, 0xab, 0x8a, 0x00,
+ 0x81, 0xa4, 0xd4, 0xd6, 0xfe, 0x2f, 0x00, 0x00, 0x04, 0x40, 0xb5, 0x2d,
+ 0x21, 0x08, 0x04, 0x90, 0xaa, 0xfa, 0xff, 0x1f, 0x11, 0x01, 0x00, 0x04,
+ 0xf0, 0x57, 0x0a, 0x22, 0x40, 0x4a, 0xda, 0x5e, 0xfb, 0x1f, 0x40, 0x00,
+ 0x40, 0x20, 0xba, 0x95, 0x90, 0x00, 0x01, 0xa0, 0xaa, 0xea, 0xff, 0x5f,
+ 0x02, 0x02, 0x00, 0x01, 0xe8, 0x57, 0x05, 0x00, 0x00, 0x12, 0xd5, 0xfe,
+ 0xfd, 0x1f, 0x48, 0x00, 0x04, 0x48, 0x7a, 0x95, 0x08, 0x02, 0x10, 0x40,
+ 0xaa, 0x55, 0xf7, 0x1f, 0x00, 0x09, 0x20, 0x00, 0xf8, 0x57, 0x22, 0x10,
+ 0x00, 0x28, 0xa9, 0xfa, 0xff, 0x5f, 0x02, 0x00, 0x00, 0x49, 0xdd, 0x29,
+ 0x01, 0x00, 0x80, 0x80, 0xaa, 0xd7, 0xff, 0x0f, 0x10, 0x00, 0x08, 0x00,
+ 0xf8, 0x96, 0x08, 0x00, 0x00, 0x20, 0x54, 0xfa, 0xee, 0x3f, 0x81, 0x04,
+ 0x40, 0x24, 0xfe, 0x55, 0x82, 0x00, 0x00, 0x82, 0xd2, 0xad, 0xff, 0x0f,
+ 0x08, 0x00, 0x04, 0x80, 0x6c, 0x97, 0x00, 0x00, 0x02, 0x20, 0xa9, 0xf6,
+ 0xdf, 0x5f, 0x00, 0x02, 0x20, 0x09, 0xfa, 0x49, 0x12, 0x00, 0x20, 0x84,
+ 0x54, 0xdb, 0xfe, 0x1f, 0x91, 0x00, 0x00, 0x00, 0xf8, 0x2b, 0x00, 0x20,
+ 0x00, 0x40, 0xa4, 0xf6, 0xbb, 0x1f, 0x04, 0x00, 0x44, 0x92, 0x7e, 0x95,
+ 0x02, 0x00, 0x00, 0x89, 0xaa, 0xdd, 0xff, 0x1f, 0x20, 0x09, 0x10, 0x00,
+ 0xf4, 0x57, 0x20, 0x01, 0x08, 0x20, 0xa9, 0x76, 0xff, 0x5f, 0x02, 0x00,
+ 0x00, 0x21, 0xfc, 0x4a, 0x05, 0x00, 0x01, 0x80, 0x54, 0xdb, 0xff, 0x1e,
+ 0x08, 0x02, 0x04, 0x08, 0xf9, 0x2b, 0x00, 0x00, 0x40, 0x28, 0xd2, 0xf6,
+ 0xff, 0xbf, 0x80, 0x00, 0x90, 0x00, 0xbc, 0x92, 0x08, 0x10, 0x00, 0x82,
+ 0x54, 0xdb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x44, 0xf9, 0x55, 0x02, 0x01,
+ 0x00, 0x20, 0xaa, 0xbd, 0xfd, 0x3f, 0x08, 0x04, 0x04, 0x10, 0xf4, 0x2a,
+ 0x01, 0x00, 0x22, 0x80, 0xd4, 0xf6, 0xff, 0x5f, 0x82, 0x00, 0x40, 0x02,
+ 0xf8, 0x55, 0x20, 0x00, 0x00, 0x50, 0x6a, 0xdf, 0xfe, 0x3f, 0x00, 0x00,
+ 0x00, 0x48, 0xe9, 0x4a, 0x05, 0x08, 0x00, 0xa5, 0xd5, 0xf5, 0xff, 0x3f,
+ 0x10, 0x01, 0x10, 0x01, 0xb0, 0xab, 0x92, 0x02, 0x40, 0xf8, 0xbf, 0xde,
+ 0xfe, 0x5f, 0x02, 0x04, 0x04, 0x48, 0xfa, 0xd4, 0x6f, 0x20, 0x84, 0xef,
+ 0xff, 0xfb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x00, 0xe0, 0xed, 0xbf, 0x0b,
+ 0xa1, 0x7e, 0xff, 0xbf, 0xfd, 0x5f, 0x04, 0x01, 0x20, 0x49, 0xd2, 0xfb,
+ 0xfe, 0x55, 0xd4, 0xff, 0xff, 0xf6, 0xff, 0x07, 0x00, 0x04, 0x00, 0x00,
+ 0xc0, 0xaa, 0xfb, 0x2b, 0xa2, 0xfe, 0xff, 0xdf, 0xee, 0x1f, 0x91, 0x00,
+ 0x82, 0xa4, 0xa4, 0xf5, 0xff, 0x57, 0xd5, 0xff, 0xbf, 0xfd, 0xff, 0x4d,
+ 0x00, 0x00, 0x20, 0x00, 0x88, 0x5b, 0xff, 0x2f, 0x69, 0xff, 0xff, 0xdb,
+ 0xfe, 0x1f, 0x24, 0x02, 0x00, 0x49, 0xa2, 0xd6, 0xff, 0x5f, 0xea, 0xff,
+ 0x7f, 0x7f, 0x7f, 0x0d, 0x00, 0x00, 0x10, 0x00, 0x40, 0xab, 0xf7, 0xbb,
+ 0xf0, 0xdf, 0xff, 0xd5, 0xff, 0xbf, 0x82, 0x04, 0x42, 0x24, 0x91, 0xd5,
+ 0xaa, 0xae, 0xd4, 0xaa, 0x52, 0x7b, 0xff, 0x15, 0x08, 0x00, 0x00, 0x01,
+ 0x04, 0x55, 0xd5, 0x55, 0x70, 0x5b, 0x75, 0xdd, 0xdf, 0x1f, 0x40, 0x00,
+ 0x08, 0x48, 0xa0, 0x4a, 0xa9, 0x56, 0xea, 0x56, 0xad, 0x6a, 0x7d, 0x9b,
+ 0x04, 0x01, 0x00, 0x02, 0x42, 0x2a, 0xd5, 0xaa, 0xa8, 0xaa, 0xaa, 0xfa,
+ 0xdf, 0x2f, 0x10, 0x04, 0x22, 0x48, 0x08, 0x45, 0x2a, 0x15, 0x68, 0x55,
+ 0x55, 0xd7, 0x76, 0x1b, 0x00, 0x00, 0x00, 0x01, 0x40, 0x2a, 0x80, 0xa0,
+ 0xb2, 0x09, 0x48, 0xb9, 0xdf, 0x17, 0x22, 0x01, 0x00, 0x24, 0x45, 0x8a,
+ 0x24, 0x4a, 0x54, 0x51, 0x91, 0xf6, 0x6e, 0x4b, 0x00, 0x04, 0x90, 0x00,
+ 0x80, 0x52, 0x00, 0x20, 0x69, 0x05, 0xa4, 0xaa, 0xff, 0x1e, 0x48, 0x00,
+ 0x02, 0x92, 0x08, 0x05, 0x81, 0x94, 0xd4, 0x92, 0x40, 0xfd, 0xb6, 0x8b,
+ 0x00, 0x01, 0x40, 0x00, 0x82, 0x54, 0x00, 0x48, 0x68, 0x05, 0x90, 0xa4,
+ 0xef, 0x06, 0x24, 0x00, 0x08, 0x12, 0x10, 0x05, 0x00, 0x10, 0xb5, 0x01,
+ 0x42, 0xfb, 0xbf, 0x43, 0x00, 0x09, 0x00, 0x40, 0x81, 0xa8, 0x08, 0x4a,
+ 0xaa, 0x96, 0x90, 0xac, 0x6d, 0x15, 0x22, 0x00, 0x20, 0x09, 0x04, 0x15,
+ 0x80, 0x28, 0xdc, 0x01, 0x24, 0xfb, 0xbf, 0x01, 0x80, 0x04, 0x09, 0x00,
+ 0x40, 0x48, 0x02, 0x45, 0xb2, 0x2e, 0x41, 0x6d, 0xef, 0x05, 0x11, 0x00,
+ 0x40, 0x52, 0x02, 0x15, 0x29, 0x2a, 0xac, 0x42, 0x54, 0xfb, 0x3b, 0x51,
+ 0x84, 0x00, 0x08, 0x00, 0x20, 0x54, 0x80, 0x05, 0xb5, 0x3d, 0xa2, 0xb6,
+ 0xdf, 0x00, 0x20, 0x04, 0x20, 0x49, 0x89, 0xa8, 0x6a, 0x29, 0xac, 0xd6,
+ 0x54, 0xff, 0x3f, 0x84, 0x00, 0x01, 0x04, 0x10, 0x00, 0x94, 0xa8, 0x56,
+ 0xda, 0x5f, 0xab, 0xd5, 0x1e, 0x10, 0x48, 0x00, 0x90, 0x82, 0x48, 0xa8,
+ 0xb2, 0xac, 0xfd, 0x55, 0xd5, 0xfe, 0x9f, 0x80, 0x00, 0x0a, 0x02, 0x08,
+ 0x02, 0x55, 0x5a, 0x75, 0xff, 0xaf, 0xb6, 0xf7, 0x2d, 0x12, 0x92, 0x00,
+ 0x10, 0x20, 0x10, 0xa8, 0x54, 0xd5, 0xbf, 0x5d, 0xad, 0xdd, 0x0f, 0x00,
+ 0x00, 0x04, 0x40, 0x09, 0x84, 0xa8, 0xaa, 0x5a, 0xed, 0xeb, 0x6a, 0xff,
+ 0x9f, 0xa4, 0x24, 0x01, 0x02, 0xa0, 0x20, 0x50, 0x55, 0xd5, 0xbe, 0xae,
+ 0xad, 0xfd, 0x16, 0x00, 0x10, 0x04, 0x20, 0x0a, 0x08, 0xb4, 0xaa, 0x95,
+ 0xaa, 0x7b, 0xb7, 0xdb, 0x5f, 0x92, 0x04, 0x01, 0x84, 0x20, 0x21, 0x51,
+ 0xd5, 0x2a, 0xa9, 0xee, 0xd5, 0xfe, 0x0d, 0x00, 0x20, 0x04, 0x10, 0x00,
+ 0x08, 0x50, 0xe9, 0xd7, 0xd4, 0xfb, 0xb5, 0xff, 0x9f, 0x24, 0x09, 0x01,
+ 0x42, 0x4a, 0xa2, 0x64, 0xd5, 0x55, 0x7b, 0x7f, 0xda, 0x7d, 0x4f, 0x00,
+ 0x20, 0x04, 0x00, 0x80, 0x00, 0xa0, 0x2a, 0x13, 0x84, 0x6a, 0x55, 0xff,
+ 0x1d, 0x48, 0x8a, 0x00, 0x94, 0x24, 0x8a, 0xc8, 0xaa, 0x42, 0x20, 0x5d,
+ 0xf5, 0xff, 0x5f, 0x01, 0x00, 0x02, 0x01, 0x00, 0x20, 0xa2, 0x4a, 0x1a,
+ 0x82, 0x56, 0xda, 0xbd, 0x3f, 0x92, 0x92, 0x00, 0x90, 0x92, 0x00, 0x40,
+ 0x95, 0x6a, 0xf4, 0x55, 0x6d, 0xff, 0xd6, 0x00, 0x00, 0x0a, 0x04, 0x20,
+ 0x14, 0x49, 0x4b, 0xaa, 0xaa, 0x56, 0xf5, 0xff, 0xbf, 0xab, 0xa4, 0x00,
+ 0x20, 0x89, 0x40, 0x80, 0xaa, 0xaa, 0xaa, 0xaa, 0xde, 0xbf, 0xeb, 0x03,
+ 0x00, 0x02, 0x04, 0x02, 0x0a, 0x10, 0x2b, 0x2a, 0x55, 0x5b, 0xf5, 0xff,
+ 0xd7, 0x2f, 0x92, 0x00, 0x10, 0x28, 0x21, 0x01, 0x56, 0x95, 0xa0, 0x56,
+ 0xdf, 0xef, 0xea, 0x87, 0x40, 0x0a, 0x42, 0x41, 0x00, 0x90, 0xaa, 0x52,
+ 0xb6, 0xad, 0xfa, 0xff, 0xd5, 0x2f, 0x14, 0x00, 0x00, 0x04, 0x95, 0x04,
+ 0xaa, 0xac, 0x55, 0x6b, 0xff, 0xb7, 0xea, 0x9f, 0x40, 0x02, 0x28, 0x51,
+ 0x00, 0x40, 0x58, 0xd5, 0xda, 0xd6, 0x6e, 0x7f, 0xf9, 0x3f, 0x12, 0x04,
+ 0x02, 0x04, 0x49, 0x25, 0x55, 0xaa, 0x77, 0xab, 0xff, 0x2b, 0xfd, 0x3f,
+ 0x48, 0x01, 0x20, 0x41, 0x00, 0x00, 0x58, 0xa9, 0xda, 0xea, 0xfd, 0xaf,
+ 0xfa, 0xff, 0x02, 0x04, 0x08, 0x14, 0x29, 0x49, 0x52, 0x55, 0x55, 0x55,
+ 0xff, 0x8d, 0xfe, 0x3f, 0xa8, 0x00, 0x02, 0x41, 0x00, 0x02, 0xa0, 0xa2,
+ 0xaa, 0xea, 0xff, 0x53, 0xfd, 0xff, 0x02, 0x04, 0x50, 0x04, 0x25, 0xa8,
+ 0x54, 0x49, 0x52, 0xb5, 0xbf, 0x8a, 0xfe, 0xff, 0xa9, 0x08, 0x04, 0x50,
+ 0x80, 0x02, 0xa1, 0x2a, 0x95, 0xea, 0xff, 0xa1, 0xff, 0xff, 0x03, 0x02,
+ 0x90, 0x02, 0x09, 0x08, 0x44, 0x49, 0x52, 0xbd, 0x7f, 0xca, 0xff, 0xff,
+ 0x2b, 0x09, 0x04, 0x48, 0x40, 0x82, 0x90, 0x56, 0xa9, 0xf6, 0xbf, 0xd0,
+ 0xff, 0xff, 0x47, 0x00, 0x50, 0x02, 0x15, 0x11, 0x40, 0x95, 0xaa, 0xfd,
+ 0x2f, 0xe9, 0xff, 0xff, 0x8f, 0x0a, 0x84, 0x50, 0x40, 0x84, 0x14, 0xaa,
+ 0x6a, 0xff, 0x5f, 0xf2, 0xff, 0xff, 0x7f, 0x00, 0x10, 0x02, 0x09, 0x10,
+ 0x40, 0x7d, 0xf7, 0xff, 0x0b, 0xfc, 0xff, 0xff, 0xaf, 0x02, 0x84, 0x50,
+ 0x42, 0x85, 0x12, 0xd0, 0xdd, 0xff, 0xa7, 0xf2, 0xff, 0xff, 0xff, 0x04,
+ 0x00, 0x0a, 0x08, 0x10, 0x48, 0xf8, 0xff, 0xff, 0x0a, 0xfe, 0xff, 0xff,
+ 0x7f, 0x03, 0xa4, 0x80, 0xa2, 0x8a, 0x02, 0x68, 0xff, 0xff, 0x52, 0xfd,
+ 0xff, 0xff, 0xff, 0x07, 0x00, 0x2a, 0x08, 0x20, 0x28, 0xdc, 0xff, 0x5f,
+ 0x05, 0xff, 0xff, 0xff, 0xff, 0x0d, 0x92, 0x40, 0x22, 0x09, 0x02, 0xea,
+ 0xfb, 0xaf, 0x48, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x12, 0x81, 0xa0,
+ 0x48, 0x9c, 0x6e, 0x93, 0xa2, 0xff, 0xff, 0xff, 0xff, 0x07, 0xa8, 0x40,
+ 0x28, 0x0a, 0x02, 0x74, 0xb5, 0x45, 0x81, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x02, 0x0a, 0x81, 0x20, 0x08, 0xae, 0xaa, 0x90, 0xe8, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0x90, 0x40, 0x28, 0x88, 0x12, 0x58, 0x15, 0x50, 0xd0, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x44, 0x0a, 0x41, 0x21, 0x08, 0xae, 0x04, 0x14,
+ 0xf0, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40, 0x14, 0x88, 0x04, 0xba,
+ 0x02, 0x28, 0xe8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x42, 0x15, 0x41, 0x21,
+ 0x05, 0xad, 0x00, 0x05, 0xf8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40,
+ 0x24, 0x8a, 0x0e, 0x36, 0x00, 0x0a, 0xf4, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x42, 0x25, 0x90, 0xd0, 0x8b, 0xc2, 0x41, 0x05, 0xfc, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0x10, 0x08, 0x05, 0xe8, 0x8e, 0x58, 0x80, 0x02, 0xfa, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x4a, 0x20, 0xa8, 0xba, 0x0b, 0x2b, 0x51, 0x01,
+ 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x8a, 0x02, 0xe8, 0xaf, 0x84,
+ 0x90, 0x04, 0xfd, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x52, 0x21, 0x54, 0xbf,
+ 0x1f, 0x15, 0xa5, 0x02, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x08,
+ 0x01, 0xfa, 0xb6, 0xa4, 0x52, 0x40, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x4a, 0xa2, 0x54, 0xef, 0x5f, 0x4b, 0xa4, 0x80, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0x80, 0x10, 0x82, 0xfe, 0xbf, 0x92, 0x52, 0x42, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x12, 0x42, 0xa8, 0xbf, 0x1f, 0x24, 0x80, 0xa0,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28, 0x8a, 0xf7, 0x37, 0x80,
+ 0x52, 0x80, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x82, 0xe0, 0xff,
+ 0x1f, 0x00, 0x20, 0xe1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28,
+ 0xca, 0xff, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x10, 0x42, 0xf0, 0xfd, 0x1b, 0x00, 0x50, 0xf0, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0xa4, 0x10, 0xc5, 0xff, 0x1f, 0x00, 0x00, 0xe0, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x00, 0x22, 0xf8, 0xff, 0x0e, 0x00, 0x00, 0xf0,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xaa, 0x88, 0xe2, 0xff, 0x0f, 0x10,
+ 0x00, 0xf0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x25, 0xfa, 0xff,
+ 0x0f, 0x01, 0x11, 0xfd, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xff, 0xfb,
+ 0xfb, 0xff, 0x7f, 0x5d, 0xd5, 0xfa, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/flagdown b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/flagdown
new file mode 100755
index 00000000000..55abc51825b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/flagdown
@@ -0,0 +1,27 @@
+#define flagdown_width 48
+#define flagdown_height 48
+static char flagdown_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00,
+ 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00,
+ 0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00,
+ 0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04,
+ 0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07,
+ 0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07,
+ 0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07,
+ 0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03,
+ 0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00,
+ 0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00,
+ 0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
+ 0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
+ 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00,
+ 0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
+ 0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00,
+ 0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00,
+ 0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a,
+ 0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/flagup b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/flagup
new file mode 100755
index 00000000000..6eb0d846a32
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/flagup
@@ -0,0 +1,27 @@
+#define flagup_width 48
+#define flagup_height 48
+static char flagup_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00,
+ 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00,
+ 0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00,
+ 0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00,
+ 0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00,
+ 0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00,
+ 0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00,
+ 0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00,
+ 0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00,
+ 0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00,
+ 0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00,
+ 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00,
+ 0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00,
+ 0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00,
+ 0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
+ 0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a,
+ 0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a,
+ 0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a,
+ 0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a,
+ 0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a,
+ 0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.25 b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.25
new file mode 100755
index 00000000000..b234b3cb0be
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.25
@@ -0,0 +1,6 @@
+#define grey_width 16
+#define grey_height 16
+static char grey_bits[] = {
+ 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44,
+ 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44,
+ 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.5 b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.5
new file mode 100755
index 00000000000..37688893f08
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/grey.5
@@ -0,0 +1,6 @@
+#define grey_width 16
+#define grey_height 16
+static char grey_bits[] = {
+ 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa,
+ 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa,
+ 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/letters b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/letters
new file mode 100755
index 00000000000..0f12568d1a0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/letters
@@ -0,0 +1,27 @@
+#define letters_width 48
+#define letters_height 48
+static char letters_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xfe, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0x00, 0x00, 0x00, 0x20,
+ 0x00, 0xfa, 0x00, 0x00, 0x00, 0x2e, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2a,
+ 0x00, 0x3a, 0x00, 0x00, 0x00, 0x2a, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2e,
+ 0xe0, 0xff, 0xff, 0xff, 0xff, 0x21, 0x20, 0x00, 0x00, 0x00, 0x00, 0x21,
+ 0xa0, 0x03, 0x00, 0x00, 0x70, 0x21, 0x20, 0x00, 0x00, 0x00, 0x50, 0x21,
+ 0xa0, 0x1f, 0x00, 0x00, 0x50, 0x21, 0x20, 0x00, 0x00, 0x00, 0x70, 0x21,
+ 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21,
+ 0xfa, 0x01, 0x00, 0x80, 0x0b, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0a, 0x21,
+ 0xba, 0x01, 0x00, 0x80, 0x0a, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0b, 0x21,
+ 0x3a, 0x00, 0x00, 0x00, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21,
+ 0x02, 0xc0, 0xfb, 0x03, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x3f,
+ 0x02, 0xc0, 0xbd, 0x0f, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01,
+ 0x02, 0xc0, 0x7f, 0x7b, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01,
+ 0x02, 0x00, 0x00, 0x00, 0xf8, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
+ 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
+ 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
+ 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/mickey.gif b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/mickey.gif
new file mode 100755
index 00000000000..91baba9795f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/mickey.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/ned.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/ned.xpm
new file mode 100755
index 00000000000..88fe4bf098c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/ned.xpm
@@ -0,0 +1,69 @@
+! XPM2
+64 64 3 1
+ c None s None
+. c #000000000000
+X c #FFFFFFFFFFFF
+
+
+
+
+
+
+
+
+
+ .........
+ ...............XXXXXXXXX..
+ .............XXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ X.XXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXX.......
+ .XXXXXXXXXX.XXXXXXXXXXXXX..........X.
+ .XXXXXXXXX.XXXX..........XXXXXXXXXXX.
+ .XXXXXXX......XXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXX...XX....X........X......XXXXX.
+ .XXXXX..XXX..XXX..XXX..XX..XX..XXXX.
+ .XXXXX...XX..XXX..XXX..XX..XXX..XXX.
+ .XXXXX...XX..XXX..X.XXXXX..XXX..XXX.
+ .XXXXX..X.X..XXX....XXXXX..XXX..XXX.
+ .XXXXX..X.X..XXX..X.XXXXX..XXX..XXX.
+ .XXXXX..XX...XXX..XXX..XX..XXX..XXX.
+ .XXXXX..XX...XXX..XXX..XX..XX..XXXX.
+ .XXX....XX..XX........X......XXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX. ....
+ .XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.....XXXX.
+ .XXXXXXXXXXXXXX................XXXXXXXXX.
+ .XXXXXX.........XXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
+ .XXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXX.......
+ .XXXXXX.XXXXXXXXXXXXXX..........
+ .XXXX..XXXX..........
+ ...........
+
+
+
+
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/noletters b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/noletters
new file mode 100755
index 00000000000..5774124efe9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/noletters
@@ -0,0 +1,27 @@
+#define noletters_width 48
+#define noletters_height 48
+static char noletters_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00,
+ 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00,
+ 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00,
+ 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01,
+ 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07,
+ 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x0f, 0xe0, 0x00, 0x00, 0x00, 0x78, 0x0e,
+ 0xf0, 0x00, 0x00, 0x00, 0x3c, 0x1e, 0x70, 0x00, 0x00, 0x00, 0x1e, 0x1c,
+ 0x38, 0x00, 0x00, 0x00, 0x0f, 0x38, 0x38, 0x00, 0x00, 0x80, 0x07, 0x38,
+ 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x1c, 0x04, 0x00, 0xe0, 0x41, 0x70,
+ 0x1c, 0x04, 0x00, 0xf0, 0x40, 0x70, 0x1c, 0x74, 0x00, 0x78, 0x4e, 0x70,
+ 0x0e, 0x04, 0x00, 0x3c, 0x4a, 0xe0, 0x0e, 0x74, 0x03, 0x1e, 0x4a, 0xe0,
+ 0x0e, 0x04, 0x00, 0x0f, 0x4e, 0xe0, 0x0e, 0x04, 0x80, 0x07, 0x40, 0xe0,
+ 0x0e, 0x04, 0xf8, 0x0f, 0x40, 0xe0, 0x0e, 0x04, 0xe0, 0x01, 0x40, 0xe0,
+ 0x0e, 0x04, 0xf8, 0x00, 0x40, 0xe0, 0x0e, 0x04, 0x78, 0x00, 0x40, 0xe0,
+ 0x0e, 0x04, 0xfc, 0xf3, 0x40, 0xe0, 0x1c, 0x04, 0x1e, 0x00, 0x40, 0x70,
+ 0x1c, 0x04, 0x0f, 0x00, 0x40, 0x70, 0x1c, 0x84, 0x07, 0x00, 0x40, 0x70,
+ 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x38, 0xe0, 0x01, 0x00, 0x00, 0x38,
+ 0x38, 0xf0, 0x00, 0x00, 0x00, 0x38, 0x70, 0x78, 0x00, 0x00, 0x00, 0x1c,
+ 0xf0, 0x3c, 0x00, 0x00, 0x00, 0x1e, 0xe0, 0x1e, 0x00, 0x00, 0x00, 0x0e,
+ 0xe0, 0x0f, 0x00, 0x00, 0x00, 0x0f, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x07,
+ 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01,
+ 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00,
+ 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00,
+ 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/page.icon b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/page.icon
new file mode 100755
index 00000000000..c065c48f9b2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/page.icon
@@ -0,0 +1,16 @@
+#define page.icon_width 32
+#define page.icon_height 32
+#define page.icon_x_hot 16
+#define page.icon_y_hot 16
+static char page.icon_bits[] = {
+ 0xfc, 0xff, 0xff, 0x00, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x02,
+ 0x04, 0x00, 0x80, 0x04, 0x04, 0x00, 0x80, 0x08, 0x04, 0x00, 0x80, 0x10,
+ 0x04, 0x00, 0x80, 0x20, 0x04, 0x00, 0x80, 0x7f, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60, 0x04, 0x00, 0x00, 0x60,
+ 0xfc, 0xff, 0xff, 0x7f, 0xf8, 0xff, 0xff, 0x7f};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/page.mask b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/page.mask
new file mode 100755
index 00000000000..f4b5226598c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/page.mask
@@ -0,0 +1,16 @@
+#define page.mask_width 32
+#define page.mask_height 32
+#define page.mask_x_hot 16
+#define page.mask_y_hot 16
+static char page.mask_bits[] = {
+ 0xfc, 0xff, 0xff, 0x00, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x03,
+ 0xfc, 0xff, 0xff, 0x07, 0xfc, 0xff, 0xff, 0x0f, 0xfc, 0xff, 0xff, 0x1f,
+ 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x7f,
+ 0xfc, 0xff, 0xff, 0x7f, 0xf8, 0xff, 0xff, 0x7f};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/pattern b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/pattern
new file mode 100755
index 00000000000..df31baf7895
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/pattern
@@ -0,0 +1,6 @@
+#define foo_width 16
+#define foo_height 16
+static char foo_bits[] = {
+ 0x60, 0x06, 0x90, 0x09, 0x90, 0x09, 0xb0, 0x0d, 0x4e, 0x72, 0x49, 0x92,
+ 0x71, 0x8e, 0x8e, 0x71, 0x8e, 0x71, 0x71, 0x8e, 0x49, 0x92, 0x4e, 0x72,
+ 0xb0, 0x0d, 0x90, 0x09, 0x90, 0x09, 0x60, 0x06};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/teapot.ppm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/teapot.ppm
new file mode 100755
index 00000000000..b8ab85f3a5d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/images/teapot.ppm
@@ -0,0 +1,31 @@
+P6
+256 256
+255
+\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[7 eOLjQLmSMoTMnSMlRMhPL_9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀnSMtVMzYN~[N~[N\N\O€\O€]O€]O€]O€]O€\O€\O}[NyYNtVM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG-wXN}[N€]O„^O†_O†`O‡`Oˆ`Oˆ`OˆaO‰aO‰aO‰aO‰aO‰aO‰aOˆaOˆ`O†_Oƒ^O\N \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀaMLyYN…_O‰aP‹bPcPŽcPŽdPŽdPdPdPdPdPdPdPdPeP‘eP’eP’eP‘ePdPcP…_OpUM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀwXN…_OdP“fP•gQ–hQ˜hQ˜iQ™iQ™iQšiQšiQšjQ›jQ›jQœjQœjQœjQœjQœjQ›jQœjQ™iQ“fP‡`O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJiQL‹bP—hQkQ¡mR¤nR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¦pR¨pS©qSªqS«rS¬rS«rS©qS¤oRœjQ€]O\KK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀfOLrUMcPŸlR©qS¯tS²uTµwT·xT¸xT¹yTºyT»zT»zU¼zU¼zU¼zU»zUºyT¸xT¶wT¯tS¡mR‰aOhPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àa0 cNLqUM€\O”fQ¦pS²wVºzV¿|VÂ}VÄVÆVÇ€VÉ‚WÌ…[Õeæ w÷³‹êª…Ĉg§qT“fQ{ZNYIK9\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀO1{G#‘JkRMqUMtVN–iS¨v\·€d¹bµzZ±vU°uT®sSªqS¤nRœjQ’eP„^OrUMHh>!T4\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG-V5wE"~I#†M%U+¥e7²l:°g2®b*­a(­`(©^(¥])¡^-›]1ŠS,qC$`9 R3G-\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@)J/i>!pA"tD"wF$yH&xH&tE$wE#yG%}M+ƒT4S5mE*Z7!K/B*;'\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‰aO¦oR½{UÇ€VÏ…X<(F-a: e<!h>!j@#k@$h>"d<!c=$hD-fF2[<)K0@);'5$Ë‚VÇ€V¿|U_LKYIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À…_O·xTÉ‚Wó«€ûµ‹Ö’k¼|X×>µf-¨^(¡Z'šW&–T&œN>)F-J/b; g>#nD(jB&c<!b=%jH2_A/I0!<(8&5$”J¥Y’S%8&;'?)E,<:HA=HE?IJAISFJYIKXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À£nRÁ}UܘqÊŠe±vU²e,™V&¥V†C €@ |> y< u: r9 o7 l6
+j5
+h4
+g3
+5$D,K/b; h>"wM1tK.e="a<#cA,U8&E-<(9&.!a0 b1 c1    
+
++3#@)46G<:HMCIXHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀU*´vT¿~X¸{YÃk+›W&‰N$|> u: p8 k5
+f3
+a0 _/ ]. [- I¡\*ª_(‘LkRMmSMmSMnSMnSMD,R3W5mA"|O0|P1j?"c<!a=%Y7"N1F,;'NCJNCJNDJODJODJODJh>!a: X/K%
+g3
+a0 Z- \/ T*Q(ŠHµm8kRMmSMnTMoTMpTMpUM15G15G05G04G04GpUMpTM5^9 d<!yF#O+€N,rC#qB"pB#k?"a: Z7 6ODJPDJPEJQEJQEJREJREJREJRFJSFJSFJSFJSFJe<!X/
+^/ V+Q(L&I$r9  TlRMnSM46G47G47G46G46G46G46G46G36G36G25G25G15G04G/4F.3F
+
+X&pUMuWMwXNxXN<:H<:H<:H<:H<;H<;H<;H<;H=;H=;H=;H=;H>;H>;H?<H@<HA=HC>HG@ILBIREJ[JKcNLjQL§pR±uTºzUÃ~VÈWË‚XÖŽcäsÒŽe¼{V²vT¨pSžkR•gQŒbP†_O‚^O]O€\O€\O€\O€\O€]O]O]O]O]O]O]O]O]O]O]O€\O€\O~\N}[N|ZNxXN•T%H$
+›W&rVMvWNyYNzYN|ZN}[N}[N><H?<H?<H?<H?<H?<H@<H@<H@<HA=HA=HB=HC>HE?IG@IIAIKBIODJSFJWHK—hQŸlR§pR°b(¾i*Én+Ù|7Û|6Ïr,Íq+Êp-Ãl+»g)±b(®sS§pS lRšiQ•gQePcPŠaPˆaO‡`O‡`O†_O†_O…_O…_O…_O…_O…_O…_O…_O„_O„^O„^Oƒ^Oƒ^O‚]O]O€\O~[N{ZN•T%
+
+ 
+@%<-$G?@…pfdNLuWM\NdNL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀTFJvWN‰aP./01„E}[N]O…_Oˆ`O‰aP‹bPŒbPcPcPŽcPdPdPdPeP‘eP’eP’eP“fP“fQ”fQ•gQ•gQ–gQ–hQ—hQ˜hQ™iQšiQ›jQœjQkQkRžlRŸlRžY&¤\'¨^'µ^½bÀcÃeÇi ÄgÀc½b¼a¹`µ^´]¯X¢[' Z'žY&¢mR¡mR¡mR lRŸlRŸlRžkRkQœkQœjQ›jQšjQšiQ™iQ™iQ˜iQ˜hQ—hQ—hQ—hQ–gQ–gQ•gQ•gQ•gQ”fQ”fQ“fQ“fP’eP‘ePdPcP‰aP—O
+ B\À\À\À\À\À\À\À\À\À\À%7!!C*F#P) {dYœze»p€\OgPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ`LKvWNŠaPm6
+ 
+$5 ¬`(¶e)£nRœjQƒ^OJAI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXIK^KKdNLhPLuWM‚]OŒbP”fQeP m6
+†`OŽcP“fQ—hQ˜hQ™iQšiQšjQ›jQ›jQ›jQœjQœjQœjQœkQkQkQkRžkRžkRžkRžlRŸlRŸlRŸlR lR lR lR¡mR¡mR¡mR¡mRºg)³c(²c(±b(­V¿cÂeÅi!Åi!Àd¼bº`¹`·_·_¶^¢Q§]'ª_(­`(¹f)£nR£nR£nR£nR£nR£nR£nR¢nR¢nR¢nR¢nR¢nR¢nR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢nR¢mR¢mR£nR¢mR¢mR¡mR mRkR—hQˆGa0 ŠbP mRœjQ“fQ‰aP}[NrUMmSM…L$\À\À\À\À\À\À\À\À B B #C, 8&H.Z7 §pR›jQ{ZN\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀQEJ[JK`LKdNLhQLqUM{ZN…_OŽcP–gQ—hQ
+‹bP‘eP–hQšiQ›jQœjQkQkQkRžkRžkRžlRžlRŸlRŸlRŸlRŸlRŸlR lR lR lR mR¡mR¡mR¡mR¡mR¡mR¢mR¢mR¢mR¢nR£nRÀj*ºg)·e)¶d)Âd°XÅgÅhÂe¿c½b½b¾bªU­`(®a(¯a(³c(¾i*¤oR¤oR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤oR¤oR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¥oR¥oR¤nR¡mR›jQŽQ%Z- œjQ£nRŸlR—hQŽdP…_OuWMpTMnSMkRLa: \À\À\À\À\À\À\À B B&D2 @*S6#G@IPDJ˜hQmSM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ]KKbMLeOLiQLlRMvWN\OˆaO‘eP—hQœjQ•gQ
+!C+E'0F.4F7%8%U/lG.SFJZIK]KKZIKB=H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀREJZJK`LKdNLgPLjQLlRMnSMpTMqUMtWMxXN{ZN~[N]O„^O†`O‰aO‹bPdP•gQ™iQœkQ lR¤nR§pSªrS­sS¯tT²uT´vT¶wT·xT¹yT¹yTºyTºyT¹yT¶xT´vT¬rS¢nR—hQ¿|U¿|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ}UÀ}UÁ}UÁ}UÁ}UÁ}UÂ}UÂ~UÃ~UÃ~VÃ~VÄVÅ€WÆX®a(ŸlRªrS´vT¸yT¼zU¾|UÁ~VÃXÆ‚[Ɇ_΋dÓ‘jÔ“mÔ“nБlÊŒhĆd½_¶{[°vWªsU¦pS¢nRžkRšiQ˜hQ•gQ“fQ‘ePdPŒbP‰aO†_Oƒ^O€\O|ZNxXNsVMpTMnTMmSMjQL€C B)D&/F-3F47G6%>" Y7 kA$YIK]KK^KKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ\KKbMLeOLhPLkRLmSMnTMpTMrUMuWNyYN|ZN\N‚]O„_O‡`OŠaPŒbPŽcPeP“fP—hQ›jQžlR¢nR¥oS©qT¬sT¯uU²vU´wV¶xV¸yV¹yUºzU»zU¼{U½{U¾{U¾|U¿|U¿|U¿|U¿|U¾{U½{U¼{U¼zU»zTºyT¹yT¸xTµwT³vT´vT´vT´vT´wT´wTµwT·xT¹yTºzT¼zU½{U¾{U¿|UÀ|UÂ}UÄVÅ€WÇ‚YÉ„\͈_ÑŒdÙ”láuç£|쩂ſt명æ¦ÞŸ{Õ—sËŽl†d¹^³yZ­uW¨qU¤oSŸlRžkRœjQšiQ˜hQ–gQ”fQ‘ePdPcPŠaP‡`O„^O]O}[NyYNuWMpTMoTMmSMkRLgPL&D#.E,3F46G;'<(D"iB(VGJ]KK`LK[JKB>H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRMmSMoTMqUMsVMvXNzYN}[N€\O‚^O…_Oˆ`OŠaPŒcPdP‘eP“fQ•gQ—hQ™iQkR mS¤oT¨rU¬tW°wY´zZ¸}\»]¾€^À^Á‚^‚^Â\Á€ZÁYÁXÁ~WÁ~WÂ~VÂ~VÂ~VÃ~VÃ~UÃ~UÄ~UÄ~UÄUÄUÅVÅVÅVÅVÆVÆ€VÆ€VÇ€WÇWÈ‚XɃZË…[͇^ЊaÓdØ’iÜ—nâtè£zî©ó¯‡ø´û¸‘üº“û¹“÷¶ñ±Œé©…à¡~Ö˜vËmÇf»€`´z[®vX©rU¥pT£oS¢nS lRžkRœkRšjQ˜iQ–hQ”fQ’ePdPcP‹bPˆ`O…_O‚]O~[NzYNvWNpTMoTMnSMkRMhQLo7 ,2F36G99HC+@ ]8 nA"\JK`ML_LKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMpTMqUMtVMwXNzZN}[N€]Oƒ^O†_OˆaO‹bPcPdP‘eP“fQ•gQ—hQ™iQ›jRžlR mS£oU§rW¬vZ²{]¹€a¿…fÅŠjËnГqÓ•sÕ–sÕ–rÕ–qÕ”oÓ’mÑjÏgÍŠcˈaɆ^È„\Ç‚[ÆYÅ€XÅ€WÅWÅWÅVÅVÅWÅ€WÆ€WÇXÈ‚YɃ[Ê…\͇_ÏŠaÒeÕ‘hÙ•mÝ™qávä¡zç¤}꧀멃몄騃奀ߠ|Ù›wÓ•rÌmƉh¿„c¸~^²yZ®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRœkR›jQ™iQ—hQ•gQ“fPePŽcP‹bPˆaO…_O‚^O\N{ZNwXNsVMoTMnSMlRMiQL~I#26G99G?<HA*E$ i@$ZIKaMLbML[JK;:H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀWHJ]KKbMLeOLhPLjRLlSMnTMpTMrUMuWMxXN{ZN~\N]O„^O†`O‰aO‹bPŽcPdP’eP”fQ–gQ˜hQšiQœkRžlS mT£oU¦rWªuZ¯y]´~aºƒfŠlË’sÔšzÜ¡€ã§†è«‰ë®‹í¯Œí®‹ë¬ˆè¨„ã£~ßžyÚ™tÖ•oÒjÎŒfˈbÈ…_ƃ\ÅZÄ€YÃXÂWÂ~WÂ~WÂ~WÃXÀXÄ€YÅZƃ\Ç…^Ɇ`ˈbÌŠdÍ‹fÎgÎŽiÎŽjÎŽjÍŽjËŒiljgÆd¿ƒaº^¸}]¶|\´{[²yZ°xY®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRkR›jQ™iQ—hQ•gQ“fP‘ePŽdPŒbP‰aO†_Oƒ^O€\O|ZNxXNtVMpTMnSMmSMjQLgPL99G?<HG-E&b;!YIK`MLdOM`LKNCJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀŸlRºyTÄ~UÊ‚XʃYÄXº{W­tUšW'¢[(—hQ lRcP€\OhQL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRLmSMoTMqUMrVMvWNyYN|ZN\N‚]O„_O‡`O‰aPŒbPŽcPdP’fP”gQ–hQ˜iQšjRœkRžlS¡nT¤pU§sW«vZ°z]µb»„gŠlÉ‘sИyØžÞ¤…ã©Šè­ì±ï³‘ﳑ뭊穅⣀ݞzؘtÒ“nÎiɉdÆ…`Â]Á€[¿~Y¾}X½|W½|V¼{V¼{V¼{V¼{V¼{V¼|W¼|W½}X½}Y½~Z½~Z¼~Z»}[º}[º}[º~\º~\º~]º~]¹~]¸~]·}]¶|\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS mRŸlRkR›jQšiQ˜hQ–gQ“fQ‘ePdPŒcPŠaP‡`O„^O]O}[NyYNuWNpTMnTMmSMkRLhPL|H$D>IQ2P+XHK_LLfQOcNLXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À©qSºyTÃ~VΈ`遲ޜv¾€]ªqS–LŽG|> g3
+S)?*%.—hQ—hQ‘eP‡`OuWM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMoTMqUMsVMwXNzYN}[N€\O‚^O…_O‡`OŠaPŒbPŽdP‘eP“fP•gQ—hQ˜iQšjRœkRŸlS¡nT¤pV§sX«vZ°z^¶b¼…gËmÊ’sјzØŸ€Þ¤…ã©Šè­ê¯ë°ê¯Žè¬‹å¨‡à¤‚Ûž|Ö™wÑ“qÌŽlljgÃ…bÀ‚_½\»}Zº{X¹zW¸yV·yU·xU·xU·xT·xT·xU·xU·xU·yV·yV·yW¸zW¸{X¹{Y¹|Zº}[º}[º}\º~\¹~]¹~]¸}]·|\µ{\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS¡mRŸlRkRœjQšiQ˜hQ–gQ”fQ’ePdPcPŠbP‡`O…_O‚]O~[NzZNvWNrUMoTMmSMlRMiQLeOLJAIJ(h>!]KKfQOgQN_LKD>I\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À™iQ°tS¸yT¼{UÂYÎŒeï­ˆô´Õ—u¶|\ Z'™LˆD |>
+
+ &3#.$-% .% .& /&!,#,#@70A71XNHXNHWNHWNHZRLYQLYQLXQLWQLWPLUOLSNLQMKOLJMJJ0//.-.,,-&(+"(!'
+ %' %$#" ! !$ 
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Ball.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Ball.pm
new file mode 100755
index 00000000000..c05605e4aaa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Ball.pm
@@ -0,0 +1,143 @@
+
+package Ball;
+
+# Ball.pm, a class module that allows concurrent simulation (canvas) instances.
+#
+# This is simply a class module, nothing fancy like a derived widget or
+# composite widget. It has two virtual methods, new() and move_one_ball().
+# There are two static methods, get_canvas_hash() and move_all_balls().
+#
+# Essentially, move_all_balls() is invoked to move all of the balls in a
+# simulation's @BALLS list once - from their current to their new postion.
+# After moving one ball a call to DoOneEvent() is made to handle pending
+# XEvents. The *user* of this module, in this case bounce.pl, has their
+# own main loop which also calls DoOneEvent() and move_all_balls() to keep
+# the simulation active.
+#
+# Gurusamy Sarathy (gsar@engin.umich.edu)
+# Tidied up by SOL.
+
+use vars qw/$VERSION/;
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/demos/demos/widget_lib/Ball.pm#4 $
+
+use Tk::Canvas;
+use Tk::Widget;
+use Tk qw/DoOneEvent DONT_WAIT/;
+Construct Tk::Canvas 'Ball';
+use strict;
+
+# Class Ball global variables.
+
+my %BALLS = (); # hold @BALLS list on a per canvas basis
+my (%DEFAULTS) = ( # Ball constructor option defaults
+ -color => 'blue',
+ -size => 20.0,
+ -position => [12.0,12.0],
+ -velocity => [6.0, 9.0],
+ );
+
+sub new { # Ball object constructor
+
+ # Create a new Ball object, which just happens to be a Canvas item.
+ # Fill-in values for defaulted parameters, create the oval item, and
+ # store object-specific information in the ball's hash.
+ #
+ # Finally, update the class global %BALLS hash, indexed by a hashed canvas
+ # reference, with the new ball. Note the special Tk::bind statement that
+ # removes a canvas from the %BALLS hash when the canvas is destroyed, thus
+ # keeping %BALLS trimmed and preventing a very slow memory leak.
+
+ my($class, $canvas, %args) = @_;
+
+ my @missing_args = grep ! defined $args{$_}, keys %DEFAULTS;
+ @args{@missing_args} = @DEFAULTS{@missing_args};
+ my($color, $size, $pos, $vel) = @args{-color, -size, -position, -velocity};
+
+ my $ball = $canvas->create('oval',
+ ($pos->[0] - ($size/2.0)), ($pos->[1] - ($size/2.0)),
+ ($pos->[0] + ($size/2.0)), ($pos->[1] + ($size/2.0)),
+ -fill => $color,
+ );
+ $canvas->Tk::bind(
+ '<Destroy>' => sub {delete $BALLS{Ball->get_canvas_hash($canvas)}}
+ );
+
+ my $ball_obj = {'canvas_ID' => $ball,
+ 'canvas' => $canvas,
+ 'color' => $color,
+ 'size' => $size,
+ 'pos' => [@$pos],
+ 'vel' => [@$vel],
+ };
+
+ push @{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}, $ball_obj;
+ return bless $ball_obj, $class;
+
+} # end new, Ball constructor
+
+sub get_canvas_hash {
+
+ # Hash a canvas reference to a key for indexing into the %BALLS hash.
+ # For now, just use the string-ified widget reference. If this trick
+ # were ever to fail in the future then only this code needs to be fixed
+ # and the Ball class would be up and running in short oder.
+
+ my($class, $canvas) = @_;
+
+ return $canvas
+
+} # end get_canvas_hash
+
+sub move_one_ball {
+
+ # Move one ball, belonging to one simulation, one clock tick.
+
+ my ($ball_obj, $speed_ratio) = @_;
+
+ my($ball, $canv, $minx, $miny, $maxx, $maxy);
+ my($ballx, $bally, $deltax, $deltay);
+
+ $speed_ratio = 1.0 unless defined $speed_ratio;
+ $ball = $ball_obj->{'canvas_ID'};
+ $canv = $ball_obj->{'canvas'};
+ $ballx = $ball_obj->{'pos'}[0];
+ $bally = $ball_obj->{'pos'}[1];
+
+ $minx = $ball_obj->{'size'} / 2.0;
+ $maxx = $ball_obj->{'canvas'}->cget(-width) - $minx;
+
+ $miny = $ball_obj->{'size'} / 2.0;
+ $maxy = $ball_obj->{'canvas'}->cget(-height) - $miny;
+
+ if ($ballx > $maxx || $ballx < $minx) {
+ $ball_obj->{'vel'}[0] = -1.0 * $ball_obj->{'vel'}[0];
+ }
+ if ($bally > $maxy || $bally < $miny) {
+ $ball_obj->{'vel'}[1] = -1.0 * $ball_obj->{'vel'}[1];
+ }
+
+ $deltax = $ball_obj->{'vel'}[0] * $speed_ratio;
+ $deltay = $ball_obj->{'vel'}[1] * $speed_ratio;
+
+ $canv->move($ball, $deltax, $deltay);
+ $ball_obj->{'pos'}[0] = $ballx + $deltax;
+ $ball_obj->{'pos'}[1] = $bally + $deltay;
+
+ return $ball_obj;
+
+} # end move_one_ball
+
+sub move_all_balls {
+
+ # Move all the balls belong to one simulation instance one clock tick.
+
+ my($class, $canvas, $speed_ratio) = @_;
+
+ foreach (@{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}) {
+ $_->move_one_ball($speed_ratio);
+ DoOneEvent(DONT_WAIT); # be kind and process XEvents if they arise
+ }
+
+} # end move_all_balls
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList.pl
new file mode 100755
index 00000000000..62d683b2dbb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList.pl
@@ -0,0 +1,65 @@
+# HList, a hierarchial listbox widget.
+
+use Tk::HList;
+use Cwd;
+use subs qw/show_dir/;
+use vars qw/$TOP $FILEIMG $FOLDIMG/;
+
+sub HList {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'HList - A hierarchial listbox widget.',
+ -geometry_manager => 'grid',
+ );
+
+ my $h = $TOP->Scrolled(qw\HList -separator / -selectmode extended -width 30
+ -height 20 -indent 35 -scrollbars se
+ -itemtype imagetext \
+ )->grid(qw/-sticky nsew/);
+ $h->configure(-command => sub {
+ print "Double click $_[0], size=", $h->info('data', $_[0]) ,".\n";
+ });
+
+ $FILEIMG = $TOP->Bitmap(-file => Tk->findINC('file.xbm'));
+ $FOLDIMG = $TOP->Bitmap(-file => Tk->findINC('folder.xbm'));
+
+ my $root = Tk->findINC('demos');
+ my $olddir = cwd;
+ chdir $root;
+ show_dir '.', $root, $h;
+ chdir $olddir;
+ my $b = $TOP->Button(-text => 'Select All', -command => [\&select_all, $h]);
+ Tk::grid($b);
+}
+
+sub select_all
+{
+ my $h = shift;
+ my @list = $h->infoChildren(@_);
+ if (@list)
+ {
+ $h->selectionSet($list[0],$list[-1]);
+ foreach my $e (@list)
+ {
+ select_all($h,$e);
+ }
+ }
+}
+
+sub show_dir {
+ my($entry_path, $text, $h) = @_;
+ opendir H, $entry_path;
+ my(@dirent) = grep ! /^\.\.?$/, sort(readdir H);
+ closedir H;
+ $h->add($entry_path, -text => $text, -image => $FOLDIMG, -data => 'DIR');
+ while ($_ = shift @dirent) {
+ my $file = "$entry_path/$_";
+ if (-d $file) {
+ show_dir $file, $_, $h;
+ } else {
+ my $size = -s $file;
+ $h->add($file, -text => $_, -image => $FILEIMG, -data => $size);
+ }
+ }
+} # end show_dir
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList2.pl
new file mode 100755
index 00000000000..10ada400a65
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList2.pl
@@ -0,0 +1,124 @@
+# HList and ItemStyle, multicolumn listbox with individual cell styles.
+# -*- perl -*-
+
+#
+# $Id: $
+# Author: Slaven Rezic
+#
+# Copyright (C) 1999 Slaven Rezic. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Mail: eserte@cs.tu-berlin.de
+# WWW: http://user.cs.tu-berlin.de/~eserte/
+#
+
+use Tk::HList;
+use Tk::ItemStyle;
+
+sub HList2 {
+ my($demo) = @_;
+ my $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'HList and ItemStyle, multicolumn listbox with individual cell styles.',
+ -geometry_manager => 'grid',
+ );
+
+ my $h = $TOP->Scrolled
+ (qw/HList
+ -header 1
+ -columns 4
+ -width 50
+ -height 20/
+ )->grid(qw/-sticky nsew/);
+
+ for (0 .. 3) {
+ $h->header('create', $_, -text => 'Column ' . $_);
+ }
+
+ my @img;
+ foreach ('Xcamel.gif', 'anim.gif', 'icon.gif', 'Camel.xpm') {
+ push @img, $TOP->Photo(-file => Tk->findINC($_)),
+ }
+
+ my(@fonts) = ('-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*',
+ '-*-Courier-Medium-R-Normal--*-180-*-*-*-*-*-*',
+ '-*-times-medium-r-normal--*-240-*-*-*-*-*-*',
+ '-Adobe-Courier-Bold-O-Normal--*-120-*-*-*-*-*-*',
+ 'fixed',
+ );
+
+ my(@colors) = qw(red green blue yellow red cyan black);
+
+ my $rnd_font = sub {
+ $fonts[rand($#fonts+1)];
+ };
+ my $rnd_color = sub {
+ $colors[rand($#colors+1)];
+ };
+ my $rnd_image = sub {
+ my $yn = int(rand(2));
+ if ($yn) {
+ $img[rand($#img+1)];
+ } else {
+ undef;
+ }
+ };
+ my $rnd_window = sub {
+ my $yn = int(rand(10));
+ if ($yn == 3) {
+ ('Button', 'Entry')[rand(2)];
+ } else {
+ undef;
+ }
+ };
+
+ for my $y (0 .. 20) {
+ my $e = $h->addchild("");
+ for my $col (0 .. 3) {
+ my $window = $rnd_window->();
+ my $image = $rnd_image->();
+ my $fg = $rnd_color->();
+ my $bg = $rnd_color->();
+ if ($bg eq $fg) { $fg = 'white' }
+
+ my $style_type = ($window ? 'window' :
+ ($image ? 'imagetext' : 'text'));
+ my $btn;
+ my $style = $h->ItemStyle($style_type);
+ if ($style_type eq 'window') {
+ $style->configure(-pady => 0, -padx => 0, -anchor => "nw");
+ if ($window eq 'Button') {
+ $btn = $h->Button
+ (-text => 'Click me!',
+ -command => sub {
+ $btn->configure(-activeforeground => $rnd_color->());
+ },
+ );
+ } else {
+ $btn = $h->Entry;
+ }
+ } else {
+ $style->configure(-foreground => $fg,
+ -background => $bg,
+ -font => $rnd_font->(),
+ );
+ }
+ $h->itemCreate
+ ($e, $col,
+ -itemtype => $style_type,
+ -style => $style,
+ ($style_type eq 'imagetext'
+ ? (-image => $image) : ()
+ ),
+ ($style_type eq 'window'
+ ? (-widget => $btn) : (-text => 'Cell ' . $y . '/' . $col)
+ ),
+ );
+ }
+ }
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Plot.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Plot.pm
new file mode 100755
index 00000000000..5ce7791a7d9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Plot.pm
@@ -0,0 +1,198 @@
+
+package Plot;
+
+# Class "Plot": constructor, methods, destructor, global class data,
+# etcetera.
+#
+# Because a Plot object is a composite widget all the Composite base
+# class methods and advertised widgets are available to you.
+#
+# Advertised Plot widgets: canvas, entry, PostScript_button, view_button.
+
+require 5.005_03;
+
+use vars qw/$VERSION @ISA/;
+$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Frame;
+use base qw/Tk::Frame/;
+Construct Tk::Widget 'Plot';
+use strict;
+
+sub Populate {
+
+ # Plot composite widget constructor.
+
+ my($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+ my($tc, $ih, $ah) = (
+ delete $args->{-title_color},
+ delete $args->{-inactive_highlight},
+ delete $args->{-active_highlight},
+ );
+
+ my %pinfo; # plot information hash
+ $pinfo{'lastX'} = 0;
+ $pinfo{'lastY'} = 0;
+ $pinfo{'areaX2'} = -1;
+ $pinfo{'prcmd'} = 'lpr';
+
+ my $plot_font = '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*';
+
+ my $c = $cw->Canvas(
+ -relief => 'raised',
+ -width => '450',
+ -height => '300',
+ -cursor => 'top_left_arrow',
+ );
+ $cw->Advertise('canvas' => $c);
+ $c->pack(-side => 'top', -fill => 'x');
+
+ $c->createLine(100, 250, 400, 250, -width => 2);
+ $c->createLine(100, 250, 100, 50, -width => 2);
+ $c->createText(225, 20, -text => 'A Simple Plot', -font => $plot_font,
+ -fill => $tc);
+
+ my($i, $x, $y, $point, $item);
+ for($i = 0; $i <= 10; $i++) {
+ $x = 100 + ($i * 30);
+ $c->createLine($x, 250, $x, 245, -width => 2);
+ $c->createText($x, 254, -text => 10 * $i, -anchor => 'n',
+ -font => $plot_font);
+ } # forend
+ for ($i = 0; $i <= 5; $i++) {
+ $y = 250 - ($i * 40);
+ $c->createLine(100, $y, 105, $y, -width => 2);
+ $c->createText(96, $y, -text => $i * 50.0, -anchor => 'e',
+ -font => $plot_font);
+ } # forend
+
+ foreach $point ([12, 56], [20, 94], [33, 98], [32, 120], [61, 180],
+ [75, 160], [98, 223]) {
+ $x = 100 + (3 * ${$point}[0]);
+ $y = 250 - (4 * ${$point}[1]) / 5;
+ $item = $c->createOval($x-6, $y-6, $x+6, $y+6, -width => 1,
+ -outline => 'black', -fill => $ih);
+ $c->addtag('point', 'withtag', $item);
+ }
+
+ $c->bind('point', '<Any-Enter>' => [sub{shift->itemconfigure(@_)},
+ 'current', -fill => $ah]);
+ $c->bind('point', '<Any-Leave>' => [sub{shift->itemconfigure(@_)},
+ 'current', -fill => $ih]);
+ $c->bind('point', '<1>' => [sub {plot_down(@_)}, \%pinfo]);
+ $c->bind('point', '<ButtonRelease-1>' => sub {shift->dtag('selected')});
+ $c->CanvasBind('<B1-Motion>' => [sub {plot_move(@_)}, \%pinfo]);
+ $c->CanvasBind('<2>' => [sub {area_down(@_)}, \%pinfo]);
+ $c->CanvasBind('<B2-Motion>' => [sub {area_move(@_)}, \%pinfo]);
+
+ my $w_prcmd = $cw->Entry(
+ -textvariable => \$pinfo{'prcmd'},
+ );
+ $cw->Advertise('entry' => $w_prcmd);
+ $w_prcmd->pack;
+
+ my $w_print = $cw->Button(
+ -text => 'Print in PostScript Format',
+ -command => [\&area_save, $c, \%pinfo],
+ );
+ $cw->Advertise('PostScript_button' => $w_print);
+ $w_print->pack;
+ $w_prcmd->bind('<Return>' => [$w_print => 'invoke']);
+
+ my $w_view = $cw->Button(
+ -text => 'View Composite Plot Widget',
+ -command => [\&::view_widget,
+ Tk->findINC('demos/widget_lib/Plot.pm'),
+ ],
+ );
+ $cw->Advertise('view_button' => $w_view);
+ $w_view->pack;
+
+ return $cw;
+
+} # end Populate, Plot constructor
+
+# Private methods.
+
+sub area_down {
+
+ my($w, $pinfo) = @_;
+
+ my $e = $w->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $pinfo->{'areaX1'} = $x;
+ $pinfo->{'areaY1'} = $y;
+ $pinfo->{'areaX2'} = -1;
+ $pinfo->{'areaY2'} = -1;
+ eval {local $SIG{'__DIE__'}; $w->delete('area');};
+
+} # end area_down
+
+sub area_move {
+
+ my($w, $pinfo) = @_;
+
+ my $e = $w->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ if($x != $pinfo->{'areaX1'} && $y != $pinfo->{'areaY1'}) {
+ eval {local $SIG{'__DIE__'}; $w->delete('area');};
+ $w->addtag('area','withtag',$w->createRectangle($pinfo->{'areaX1'},
+ $pinfo->{'areaY1'},$x,$y));
+ $pinfo->{'areaX2'} = $x;
+ $pinfo->{'areaY2'} = $y;
+ }
+} # end area_move
+
+sub area_save {
+
+ my($w, $pinfo) = @_;
+
+ my($x1, $x2, $y1, $y2, $a);
+
+ if($pinfo->{'areaX2'} != -1) {
+ ($x1, $x2, $y1, $y2) =
+ @$pinfo{'areaX1', 'areaX2', 'areaY1', 'areaY2'}; # slice !
+ ($x1, $x2) = @$pinfo{'areaX2', 'areaX1'} if $x2 <= $x1;
+ ($y1, $y2) = @$pinfo{'areaY2', 'areaY1'} if $y2 <= $y1;
+ $a = $w->postscript('-x' => $x1, '-y' => $y1,
+ -width => $x2 - $x1, -height => $y2 - $y1);
+ } else {
+ $a = $w->postscript;
+ }
+
+ $SIG{'PIPE'} = sub {};
+ open(LPR, "| $pinfo->{'prcmd'}");
+ print LPR $a;
+ close(LPR);
+
+} # end area_save
+
+sub plot_down {
+
+ my($w, $pinfo) = @_;
+
+ my $e = $w->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $w->dtag('selected');
+ $w->addtag('selected', 'withtag', 'current');
+ $w->raise('current');
+ $pinfo->{'lastX'} = $x;
+ $pinfo->{'lastY'} = $y;
+
+} # end plot_down
+
+sub plot_move {
+
+ my($w, $pinfo) = @_;
+
+ my $e = $w->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $w->move('selected', $x-$pinfo->{'lastX'}, $y-$pinfo->{'lastY'});
+ $pinfo->{'lastX'} = $x;
+ $pinfo->{'lastY'} = $y;
+
+} # end plot_move
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm
new file mode 100755
index 00000000000..61513b657ea
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm
@@ -0,0 +1,130 @@
+package WidgetDemo;
+
+use 5.005_03;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/;
+
+use Tk 800.000;
+use Carp;
+
+use Tk;
+use Tk::Toplevel;
+use strict;
+use base 'Tk::Toplevel';
+Construct Tk::Widget 'WidgetDemo';
+
+# %WIDGDEMO is a class global that tracks all WidgetDemo composite widgets,
+# providing a means of destroying a previous instance of a demonstration.
+
+my %WIDGDEMO; # class hash of active widget demonstrations
+
+sub Populate {
+ my($self, $args) = @_;
+
+ my (%arg_defaults) = (
+ -name => 'Unknown Demo Name',
+ -font => 'Helvetica 12',
+ -text => 'Unknown Demo Text',
+ -geometry_manager => 'pack',
+ );
+ my $name = $arg_defaults{-name};
+ $arg_defaults{-title} = "$name Demonstration",
+ $arg_defaults{-iconname} = $name;
+
+ my(@margs, %ahsh, @args);
+ @margs = grep ! defined $args->{$_}, keys %arg_defaults;
+ %ahsh = %$args;
+ @ahsh{@margs} = @arg_defaults{@margs};
+ my($demo, $font, $text, $title, $iconname, $gm) =
+ @ahsh{-name, -font, -text, -title, -iconname, -geometry_manager};
+ delete $args->{-name};
+ delete $args->{-font};
+ delete $args->{-iconname};
+ delete $args->{-geometry_manager};
+
+ $WIDGDEMO{$demo}->destroy if Exists($WIDGDEMO{$demo});
+ $WIDGDEMO{$demo} = $self;
+
+ $self->SUPER::Populate($args);
+ $self->iconname($iconname);
+
+ my(@label_attributes) = ();
+ if (ref($text) eq 'ARRAY') {
+ @label_attributes = @$text[1 .. $#{$text}];
+ $text = $text->[0];
+ }
+ my $msg = $self->Label(
+ -font => $font,
+ -wraplength => '4i',
+ -justify => 'left',
+ -text => $text,
+ @label_attributes,
+ );
+
+ my $demo_frame = $self->Frame;
+ $self->Advertise('WidgetDemo' => $demo_frame); # deprecated
+
+ my $buttons = $self->Frame;
+ my $dismiss = $buttons->Button(
+ -text => 'Dismiss',
+ -command => [$self => 'destroy'],
+ );
+ my $see = $buttons->Button(-text => 'See Code',
+ -command => [\&main::see_code, $demo]);
+
+ if ($gm eq 'pack') {
+ $buttons->pack(qw/-side bottom -fill x -pady 2m/);
+ $dismiss->pack(qw/-side left -expand 1/);
+ $see->pack(qw/-side left -expand 1/);
+ $msg->pack;
+ $demo_frame->pack(qw/-fill both -expand 1 -anchor n/);
+ } elsif ($gm eq 'grid') {
+ $msg->grid;
+ $demo_frame->grid(-sticky => "news");
+ $demo_frame->gridColumnconfigure(0,-weight=>1);
+ $demo_frame->gridRowconfigure(0,-weight=>1);
+ $self->gridColumnconfigure(qw/0 -weight 1/);
+ $self->gridRowconfigure(qw/1 -weight 1/);
+ $buttons->grid(qw/-pady 2m -sticky ew/);
+ $buttons->gridColumnconfigure(qw/0 -weight 1/);
+ $buttons->gridColumnconfigure(qw/1 -weight 1/);
+ $dismiss->grid(qw/-row 0 -column 0/);
+ $see->grid(qw/-row 0 -column 1/);
+ } else {
+ croak "Only pack or grid geometry management supported.";
+ }
+
+ $self->Delegates('Construct' => $demo_frame);
+
+ $self->ConfigSpecs(
+ -text => [qw/METHOD text Text NoText/],
+ );
+
+ $self->{msg} = $msg;
+
+ return $self;
+
+} # end Populate
+
+sub Top {return $_[0]->Subwidget('WidgetDemo')} # deprecated
+*top = *top = \&Top; # peacify -w
+
+sub text {
+
+ my ($self, $text) = @_;
+
+ my(@label_attributes) = ();
+ if (ref($text) eq 'ARRAY') {
+ @label_attributes = @$text[1 .. $#{$text}];
+ $text = $text->[0];
+ }
+
+ $self->{msg}->configure(
+ -text => $text,
+ @label_attributes,
+ );
+
+} # end text
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/arrows.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/arrows.pl
new file mode 100755
index 00000000000..de4973071b9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/arrows.pl
@@ -0,0 +1,242 @@
+# arrows.pl
+
+use subs qw/arrow_err arrow_move1 arrow_move2 arrow_move3 arrow_setup/;
+use vars qw/$TOP/;
+
+sub arrows {
+
+ # Create a top-level window containing a canvas demonstration that
+ # allows the user to experiment with arrow shapes.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you\'d enter them for a canvas line item.', qw/-wraplength 5i/],
+ -title => 'Arrowhead Editor Demonstration',
+ -iconname => 'arrows',
+ );
+
+ my $c = $TOP->Canvas(
+ -width => '500',
+ -height => '350',
+ -relief => 'sunken',
+ -borderwidth => 2,
+ )->pack(qw/-expand yes -fill both/);
+
+ my %ainfo; # arrow information hash
+ $ainfo{a} = 8;
+ $ainfo{b} = 10;
+ $ainfo{c} = 3;
+ $ainfo{width} = 2;
+ $ainfo{move_sub} = undef;
+ $ainfo{x1} = 40;
+ $ainfo{x2} = 350;
+ $ainfo{'y'} = 150;
+ $ainfo{smallTips} = [5, 5, 2];
+ $ainfo{count} = 0;
+
+ if ($TOP->depth > 1) {
+ $ainfo{bigLineStyle} = [qw/-fill SkyBlue1/];
+ $ainfo{boxStyle} = [-fill => undef, qw/-outline black -width 1/];
+ $ainfo{activeStyle} = [qw/-fill red -outline black -width 1/];
+ } else {
+ $ainfo{bigLineStyle} = [
+ -fill => 'black',
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ ];
+ $ainfo{boxStyle} = [-fill => undef, qw/-outline black -width 1/];
+ $ainfo{activeStyle} = [qw/-fill black -outline black -width 1/];
+ }
+ arrow_setup $c, \%ainfo;
+
+ # Bindings to highlight the 3 tiny resize boxes.
+
+ foreach ([qw/<Enter> activeStyle/], [qw/<Leave> boxStyle/]) {
+ $c->bind('box', $_->[0] =>[
+ sub {
+ my($c, $style) = @_;
+ $c->itemconfigure('current', @{$ainfo{$style}})
+ }, $_->[1]],
+ );
+ }
+ $c->bind(qw/box <B1-Enter>/ => 'NoOp');
+ $c->bind(qw/box <B1-Leave>/ => 'NoOp');
+
+ # Bindings that select one of the 3 tiny resize boxes' "move code".
+
+ my $n;
+ for $n (1,2,3) {
+ $c->bind("box${n}", '<1>' =>
+ sub {$ainfo{move_sub} = \&{"arrow_move${n}"}}
+ );
+ }
+
+ # Bindings to move a resize box and redraw the arrow.
+
+ $c->bind('box', '<B1-Motion>' =>
+ sub {&{$ainfo{move_sub}}($c, \%ainfo)}
+ );
+ $c->Tk::bind('<Any-ButtonRelease-1>' => [\&arrow_setup, \%ainfo]);
+
+} # end arrows
+
+sub arrow_err {
+
+ my($c) = @_;
+
+ my $i = $c->createText(qw/.6i .1i -anchor n -text/ => "Range error!");
+ $c->after(4000, sub { $c->delete($i) });
+
+} # end errow_err
+
+sub arrow_move1 {
+
+ my($c, $v) = @_;
+ my $e = $c->XEvent;
+
+ my($x, $y, $err) = ($e->x, $e->y, 0);
+ my $newA = int(($v->{x2} + 5 - int($c->canvasx($x))) / 10);
+ $newA = 0, $err = 1 if $newA < 0;
+ $newA = 25, $err = 1 if $newA > 25;
+ if ($newA != $v->{a}) {
+ $c->move('box1', 10 * ($v->{a} - $newA), 0);
+ $v->{a} = $newA;
+ }
+ arrow_err($c) if $err;
+
+} # end arrow_move1
+
+sub arrow_move2 {
+
+ my($c, $v) = @_;
+ my $e = $c->XEvent;
+
+ my($x, $y, $errx, $erry) = ($e->x, $e->y, 0, 0);
+ my $newB = int(($v->{x2} + 5 - int($c->canvasx($x))) / 10);
+ $newB = 0, $errx = 1 if $newB < 0;
+ $newB = 25, $errx = 1 if $newB > 25;
+ my $newC = int(($v->{'y'} + 5 - int($c->canvasy($y)) - 5 * $v->{width})
+ / 10);
+ $newC = 0, $erry = 1 if $newC < 0;
+ $newC = 12, $erry = 1 if $newC > 12;
+ if (($newB != $v->{b}) or ($newC != $v->{c})) {
+ $c->move('box2', 10*($v->{b}-$newB), 10*($v->{c}-$newC));
+ $v->{b} = $newB;
+ $v->{c} = $newC;
+ }
+ arrow_err($c) if $errx or $erry;
+
+} # end arrow_move2
+
+sub arrow_move3 {
+
+ my($c, $v) = @_;
+ my $e = $c->XEvent;
+
+ my($x, $y, $err) = ($e->x, $e->y, 0);
+ my $newWidth = int(($v->{'y'} + 2 - int($c->canvasy($y))) / 5);
+ $newWidth = 0, $err = 1 if $newWidth < 0;
+ $newWidth = 20, $err = 1 if $newWidth > 20;
+ if ($newWidth != $v->{width}) {
+ $c->move('box3', 0, 5*($v->{width}-$newWidth));
+ $v->{width} = $newWidth;
+ }
+ arrow_err($c) if $err;
+
+} # end arrow_move3
+
+sub arrow_setup {
+
+ # The procedure below completely regenerates all the text and graphics in
+ # the canvas window. It's called when the canvas is initially created,
+ # and also whenever any of the parameters of the arrow head are changed
+ # interactively. The argument is the name of the canvas widget to be
+ # regenerated, and also the name of a global variable containing the
+ # parameters for the display.
+
+ my($c, $v) = @_;
+
+ # Remember the current box, if there is one.
+
+ my(@tags) = $c->gettags('current');
+ my $cur = defined $tags[0] ? $tags[lsearch('box?', @tags)] : '';
+
+ # Create the arrow and outline.
+
+ $c->delete('all');
+ $c->createLine($v->{x1}, $v->{'y'}, $v->{x2}, $v->{'y'},
+ -width => 10*$v->{width},
+ -arrowshape => [10*$v->{a}, 10*$v->{b}, 10*$v->{c}],
+ -arrow => 'last', @{$v->{bigLineStyle}});
+ my $xtip = $v->{x2}-10*$v->{b};
+ my $deltaY = 10*$v->{c}+5*$v->{width};
+ $c->createLine($v->{x2}, $v->{'y'}, $xtip, $v->{'y'}+$deltaY,
+ $v->{x2}-10*$v->{a}, $v->{'y'}, $xtip, $v->{'y'}-$deltaY,
+ $v->{x2}, $v->{'y'}, -width => 2, -capstyle => 'round',
+ -joinstyle => 'round');
+
+ # Create the boxes for reshaping the line and arrowhead.
+
+ $c->createRectangle($v->{x2}-10*$v->{a}-5, $v->{'y'}-5,
+ $v->{x2}-10*$v->{a}+5, $v->{'y'}+5, @{$v->{boxStyle}},
+ -tags => ['box1', 'box']);
+ $c->createRectangle($xtip-5, $v->{'y'}-$deltaY-5, $xtip+5,
+ $v->{'y'}-$deltaY+5, @{$v->{boxStyle}},
+ -tags => ['box2', 'box']);
+ $c->createRectangle($v->{x1}-5, $v->{'y'}-5*$v->{width}-5,
+ $v->{x1}+5, $v->{'y'}-5*$v->{width}+5, @{$v->{boxStyle}},
+ -tags => ['box3', 'box']);
+
+ # Create three arrows in actual size with the same parameters
+
+ $c->createLine($v->{x2}+50, 0, $v->{x2}+50, 1000, -width => 2);
+ my $tmp = $v->{x2}+100;
+ $c->createLine($tmp, $v->{'y'}-125, $tmp, $v->{'y'}-75,
+ -width => $v->{width}, -arrow => 'both',
+ -arrowshape => [$v->{a}, $v->{b}, $v->{c}]);
+ $c->createLine($tmp-25, $v->{'y'}, $tmp+25, $v->{'y'},
+ -width => $v->{width}, -arrow => 'both',
+ -arrowshape =>[$v->{a}, $v->{b}, $v->{c}]);
+ $c->createLine($tmp-25, $v->{'y'}+75, $tmp+25, $v->{'y'}+125,
+ -width => $v->{width}, -arrow => 'both',
+ -arrowshape => [$v->{a}, $v->{b}, $v->{c}]);
+ $c->itemconfigure($cur, @{$v->{activeStyle}}) if $cur =~ /box?/;
+
+ # Create a bunch of other arrows and text items showing the current
+ # dimensions.
+
+ $tmp = $v->{x2}+10;
+ $c->createLine($tmp, $v->{'y'}-5*$v->{width}, $tmp, $v->{'y'}-$deltaY,
+ -arrow => 'both', -arrowshape => $v->{smallTips});
+ $c->createText($v->{x2}+15, $v->{'y'}-$deltaY+5*$v->{c},
+ -text => $v->{c}, -anchor => 'w');
+ $tmp = $v->{x1}-10;
+ $c->createLine($tmp, $v->{'y'}-5*$v->{width}, $tmp,
+ $v->{'y'}+5*$v->{width}, -arrow => 'both',
+ -arrowshape => $v->{smallTips});
+ $c->createText($v->{x1}-15, $v->{'y'}, -text => $v->{width},
+ -anchor => 'e');
+ $tmp = $v->{'y'}+5*$v->{width}+10*$v->{c}+10;
+ $c->createLine($v->{x2}-10*$v->{a}, $tmp, $v->{x2}, $tmp,
+ -arrow => 'both', -arrowshape => $v->{smallTips});
+ $c->createText($v->{x2}-5*$v->{a}, $tmp+5, -text => $v->{a},
+ -anchor => 'n');
+ $tmp = $tmp+25;
+ $c->createLine($v->{x2}-10*$v->{b}, $tmp, $v->{x2}, $tmp,
+ -arrow => 'both', -arrowshape => $v->{smallTips});
+ $c->createText($v->{x2}-5*$v->{b}, $tmp+5, -text => $v->{b},
+ -anchor => 'n');
+
+ $c->createText($v->{x1}, 310, -text => "-width => $v->{width}",
+ -anchor => 'w',
+ -font => '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*');
+ $c->createText($v->{x1}, 330,
+ -text => "-arrowshape => [$v->{a}, $v->{b}, $v->{c}]",
+ -anchor => 'w',
+ -font => '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*');
+
+ $v->{count}++;
+
+} # end arrow_setup
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/balloon.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/balloon.pl
new file mode 100755
index 00000000000..630ac957950
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/balloon.pl
@@ -0,0 +1,168 @@
+# Balloon, pop up help window when mouse lingers over widget.
+
+use Tk;
+use English;
+use Carp;
+
+use Tk::Frame;
+use Tk::Balloon;
+
+my $lmsg = "";
+
+my $top = MainWindow->new;
+my $f = $top->Frame;
+
+# status bar widget
+my $status = $top->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w');
+$status->pack(-side => "bottom", -fill => "y", -padx => 2, -pady => 1);
+
+# create the widgets to be explained
+my $mb = $top->Menubutton(-relief => 'raised',
+ -text => 'Menu button');
+my $xxx = 0;
+$mb->checkbutton(-label => 'checkbutton',
+ -variable => \$xxx);
+$mb->cascade(-label => 'cascade entry');
+my $menu = $mb->cget(-menu);
+my $cm = $menu->Menu(-tearoff => 0);
+$mb->entryconfigure('cascade entry', -menu => $cm);
+$cm->command(-label => 'first');
+$cm->command(-label => 'second');
+$mb->separator;
+$mb->command(-label => 'Close',
+ -command => sub {$top->destroy;});
+
+my $tm = $top->Menu(-title => "Balloon menu");
+$tm->cascade(-label => "Toplevel menu", -menu => $menu);
+$top->configure(-menu => $tm);
+
+my $b1 = $top->Button(-text => "Something Unexpected",
+ -command => sub {$top->destroy;});
+my $b2 = $top->Button(-text => "Something Else Unexpected");
+$b2->configure(-command => sub {$b2->destroy;});
+
+# Pack the created widgets:
+$mb->pack(-side => "top", -expand => 1);
+$b1->pack(-side => "top", -expand => 1);
+$b2->pack(-side => "top", -expand => 1);
+
+my $t = $top->Text(-height => 10, -cursor => 'top_left_arrow')->pack;
+$t->insert('end',<<END);
+
+Move the mouse cursor over the buttons above and let it linger.
+A message will be displayed in status box below and a descriptive
+balloon will appear. The top button is a menu button which has
+different messages set for each menu entry. This text widget has
+a balloon attached to it which will change depending on which word
+the mouse is over.
+
+END
+
+my $clbf = $top->Frame->pack;
+my $cf = $clbf->Frame->pack(-side => "left");
+
+my $c1 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8);
+my $c2 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8);
+my $id = $c1->create('text', 10, 10,
+ -anchor => 'nw',
+ -text => "This is a canvas. You can also attach\nballoons to specific items in a canvas");
+$c1->create('rectangle', 40, 60, 80, 80,
+ -fill => 'red',
+ -tags => 'rectangle',);
+$c1->create('oval', 100, 50, 140, 90,
+ -fill => 'blue',
+ -tags => 'circle',);
+$c2->create('text', 10, 10,
+ -anchor => 'nw',
+ -text => "Or you can attach the balloon\nto the canvas as a whole.");
+
+my $lb = $clbf->Listbox->pack(-side => "left");
+$lb->insert(qw/end one two three four/);
+
+# create the balloon widget
+my $b = $top->Balloon(-statusbar => $status);
+
+$b->attach($mb,
+ -msg => 'Press and hold this button to see the menu.');
+$b->attach($menu,
+ #-state => 'status',
+ -balloonposition => 'mouse',
+ -msg => ['Use this to tear off the menu.',
+ 'This is a checkbox entry.',
+ 'cascade', # Cascade entry (ignored by Balloon)
+ 'separator', # Separator: never active so no message will be displayed for this entry.
+ 'This is a command entry - it will close this window.',
+ ],
+ );
+$b->attach($cm,
+ -msg => 'This balloon is attached to the cascade menu, not it\'s entries',
+ #-statusmsg => 'msg cm',
+ #-balloonmsg => 'cm msg.',
+ );
+$b->attach($b1,
+ -balloonmsg => "Close Window",
+ -statusmsg => "Press this button to close this window");
+$b->attach($b2,
+ -balloonmsg => "Self-destruct\nButton",
+ -statusmsg => "Press this button and it will get rid of itself");
+
+my $msg = '';
+my @word = ('', ''); # Indicies surrounding the current word.
+my @last = ('', ''); # Same for last word.
+$b->attach($t, -msg => \$msg,
+ -balloonposition => 'mouse', # Not really used since the postcommand returns the real position.
+ -postcommand => sub { if ($word[0] eq $word[1]) {
+ # No word under mouse - don't post the balloon.
+ 0;
+ } else {
+ # Have a word under mouse - change the message:
+ my $word = $t->get($word[0], $word[1]);
+ # Skip it if it contains non-word chars:
+ return 0 if $word =~ /\W/;
+ $msg = "The word under the mouse is: $word";
+ $t->tag('add', 'sel', $word[0] => $word[1]);
+ # Find a good place to put the balloon (right below the last char in the word):
+ my $i = $t->index("$word[1] - 1 chars");
+ my @p = $t->bbox($i);
+ my $x = $t->rootx + $p[0] + $p[2] - 4;
+ my $y = $t->rooty + $p[1] + $p[3] + 2;
+ "$x,$y";
+ }
+ },
+ -motioncommand => sub { my $x = $t->pointerx - $t->rootx;
+ my $y = $t->pointery - $t->rooty;
+ @word = ($t->index("\@$x,$y wordstart"), $t->index("\@$x,$y wordend"));
+ if ($word[0] eq $last[0] and $word[1] eq $last[1]) {
+ # Same word - don't cancel the balloon.
+ 0;
+ } else {
+ # New word under mouse - cancel it so a new balloon will be posted.
+ $t->SelectionClear;
+ @last = @word;
+ 1;
+ }
+ },
+ );
+$b->attach($c1,
+ -balloonposition => 'mouse',
+ -msg => {'rectangle' => 'You are over the red rectangle right now.',
+ $id => 'You are over the text right now.',
+ 'circle' => 'You are over the blue circle right now.',
+ });
+$b->attach($c2,
+ -msg => 'This balloon is attached to the canvas itself.',
+ );
+
+$b->attach($lb,
+ -balloonposition => 'mouse',
+ -msg => [qw/1 2 3 4/],
+ );
+
+# As $b is a child of $top it is destroyed when $top is destroyed.
+# Balloon.pm now registers a handler for that, and so
+# this hackery is no longer required (and did not actually work
+# before).
+# $top->OnDestroy(sub { $b->destroy; });
+
+MainLoop;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bind.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bind.pl
new file mode 100755
index 00000000000..65579183a91
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bind.pl
@@ -0,0 +1,65 @@
+# bind.pl
+
+use vars qw/$TOP/;
+
+sub bind {
+
+ # Create a top-level window that illustrates how you can bind Perl
+ # commands to regions of text in a text widget.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text =>'',
+ -title => 'Text Demonstration - Tag Bindings',
+ -iconname => 'bind',
+ );
+
+ my $t = $TOP->Scrolled(qw/Text -setgrid true -width 60 -height 24
+ -scrollbars e -wrap word/, -font => $FONT);
+ $t->pack(qw/-expand yes -fill both/);
+
+ # Set up display styles
+
+ my(@bold, @normal, $tag);
+ if ($TOP->depth > 1) {
+ @bold = (-background => '#43ce80', qw/-relief raised -borderwidth 1/);
+ @normal = (-background => undef, qw/-relief flat/);
+ } else {
+ @bold = (qw/-foreground white -background black/);
+ @normal = (-foreground => undef, -background => undef);
+ }
+
+ $t->insert('0.0', "The same tag mechanism that controls display styles in text widgets can also be used to associate Perl commands with regions of text, so that mouse or keyboard actions on the text cause particular Perl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked.\n\n");
+ $t->insert('end','1. Samples of all the different types of items that can be created in canvas widgets.', 'd1');
+ $t->insert('end', "\n\n");
+ $t->insert('end', '2. A simple two-dimensional plot that allows you to adjust the positions of the data points.', 'd2');
+ $t->insert('end', "\n\n");
+ $t->insert('end', '3. Anchoring and justification modes for text items.', 'd3');
+ $t->insert('end', "\n\n");
+ $t->insert('end', '4. An editor for arrow-head shapes for line items.', 'd4');
+ $t->insert('end', "\n\n");
+ $t->insert('end', '5. A ruler with facilities for editing tab stops.', 'd5');
+ $t->insert('end', "\n\n");
+ $t->insert('end', '6. A grid that demonstrates how canvases can be scrolled.', 'd6');
+
+ foreach $tag (qw(d1 d2 d3 d4 d5 d6)) {
+ $t->tagBind($tag, '<Any-Enter>' =>
+ sub {shift->tagConfigure($tag, @bold)}
+ );
+ $t->tagBind($tag, '<Any-Leave>' =>
+ sub {shift->tagConfigure($tag, @normal)}
+ );
+ }
+ $t->tagBind(qw/d1 <1>/ => sub {&items('items')});
+ $t->tagBind(qw/d2 <1>/ => sub {&plot('plot')});
+ $t->tagBind(qw/d3 <1>/ => sub {&ctext('ctext')});
+ $t->tagBind(qw/d4 <1>/ => sub {&arrows('arrows')});
+ $t->tagBind(qw/d5 <1>/ => sub {&ruler('ruler')});
+ $t->tagBind(qw/d6 <1>/ => sub {&cscroll('cscroll')});
+
+ $t->mark(qw/set insert 0.0/);
+
+} # end bind
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bitmaps.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bitmaps.pl
new file mode 100755
index 00000000000..8001e884b2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bitmaps.pl
@@ -0,0 +1,44 @@
+# bitmaps.pl
+
+use subs qw/bitmaps_row/;
+use vars qw/$TOP/;
+
+sub bitmaps {
+
+ # Create a top-level window that displays all of Tk's built-in bitmaps.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This window displays all of Tk\'s built-in bitmaps, along with the names you can use for them in Perl scripts.',
+ -title => 'Bitmap Demonstration',
+ -iconname => 'bitmaps',
+ );
+
+ my $frame = $TOP->Frame;
+ $frame->pack(qw/-side top -expand yes -fill both/);
+ bitmaps_row $frame, qw/error gray12 gray25 gray50 gray75 hourglass/;
+ bitmaps_row $frame, qw/info questhead question Tk transparent warning/;
+
+} # end bitmaps
+
+sub bitmaps_row {
+
+ # The procedure below creates a new row of bitmaps in a window.
+
+ my($w, @names) = @_;
+
+ my $row = $w->Frame->pack(qw/-side top -fill both/);
+
+ foreach my $bitmap_name (@names) {
+ my $bit = $row->Frame;
+ $bit->pack(qw/-side left -fill both -pady .25c -padx .25c/);
+ my $label = $bit->Label(-text => $bitmap_name, -width => 9);
+ $label->pack(qw/-side bottom/);
+ my $bitmap = $bit->Label('-bitmap' => $bitmap_name);
+ $bitmap->pack(qw/-side bottom/);
+ }
+
+} # end bitmaps_row
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bounce.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bounce.pl
new file mode 100755
index 00000000000..a6012fb818b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bounce.pl
@@ -0,0 +1,274 @@
+# bounce.pl
+
+use Ball;
+use Tk qw/:eventtypes/;
+use subs qw/ClearMsg DoSingleStep NotDone ShowMsg SimStart SimStop mkmb/;
+use vars qw/$TOP/;
+
+my(@menu_button_list, $quit_flag, $quit_code,
+ $bounce_status, $bounce_speed, $bounce_running, $bounce_counter);
+
+sub bounce {
+
+ # This began as a borrowed idea from Python distribution examples, ended up
+ # with a Ball module of its own. It illustrates how one can run something
+ # without blocking XEvent processing in a simple-minded sorta way.
+ #
+ # Handles resizes to the main window
+ #
+ # Gurusamy Sarathy (gsar@engin.umich.edu)
+ # Tidied up by SOL.
+ #
+ # 97/06/10 This demo is sufficiently bizarre enough that we don't use
+ # WidgetDemo! (-: Plus, you get to see Exists() in action.
+
+ my($demo) = @_;
+
+ $TOP->destroy if Exists($TOP);
+ $TOP = $MW->Toplevel;
+ $TOP->title('Bouncing Ball Simulator');
+ $TOP->iconname('bounce');
+
+ @menu_button_list = ();
+ $quit_flag = 0;
+ $quit_code = sub {$quit_flag = 1};
+ $TOP->protocol('WM_DELETE_WINDOW' => $quit_code);
+
+ my $menubar = $TOP->Frame(qw/-relief raised -background DarkGreen -bd 2/);
+ $menubar->pack(-side => 'top', -fill => 'x');
+
+ mkmb($menubar, 'File', 0, 'File related stuff',
+ [
+ ['Open', \&NotDone, 0],
+ ['New', \&NotDone, 0],
+ ['Print', \&NotDone, 0],
+ ['Exit', sub{$TOP->bell}, 0],
+ ]);
+
+ mkmb($menubar, 'Simulate', 0, 'Simulator control',
+ [
+ ['Start', \&SimStart, 2],
+ ['Stop', \&SimStop, 2],
+ ]);
+
+ mkmb($menubar, 'Display', 0, 'Display settings',
+ [
+ ['Redraw', \&NotDone, 2],
+ ['Clear', \&NotDone, 2],
+ ]);
+
+ mkmb($menubar, 'Options', 0, 'Various preferences',
+ [
+ ['Steptime', \&NotDone, 0],
+ ['Colors', \&NotDone, 0],
+ ['Display', \&NotDone, 0],
+ ]);
+
+ mkmb($menubar, 'Help', 0, 'There when you need it',
+ [
+ ['About..', \&NotDone, 0],
+ ['Intro', \&NotDone, 0],
+ ['Contents', \&NotDone, 0],
+ ]);
+ $menu_button_list[$#menu_button_list]->pack(-side => 'right');
+
+ my $feedback = $TOP->Frame();
+ $feedback->pack(-side => 'bottom', -fill => 'x');
+ $bounce_status = $feedback->Text(
+ -relief => 'sunken',
+ -height => 1,
+ -background => 'gray',
+ -borderwidth => 2,
+ );
+ $bounce_status->pack(-side => 'left', -fill => 'x', -expand => 1);
+
+ my $drawarea = $TOP->Frame();
+ $drawarea->pack(-side => 'top', -fill => 'both', -expand => 1);
+
+ my $canvas = $drawarea->Canvas(
+ -relief => 'ridge',
+ -height => 400,
+ -width => 600,
+ -borderwidth => 2,
+ );
+ $canvas->pack(-side => 'left', -fill => 'both', -expand => 1);
+
+ $bounce_speed = $drawarea->Scale(
+ -orient => 'vert',
+ -showvalue => 0,
+ -width => 10,
+ -from => 100,
+ -to => 0,
+ -borderwidth => 1,
+ );
+ $bounce_speed->pack(-side => 'left', -fill => 'y');
+ $bounce_speed->bind('<Enter>' => sub {
+ ClearMsg; ShowMsg('Adjust slider for ball speed');
+ });
+ $bounce_speed->bind('<Leave>' => \&ClearMsg);
+ $bounce_speed->set(50);
+
+ my $w_buttons = $TOP->Frame;
+ $w_buttons->pack(qw(-side bottom -expand y -fill x -pady 2m));
+ my $w_dismiss = $w_buttons->Button(
+ -text => 'Dismiss',
+ -command => $quit_code,
+ );
+ $w_dismiss->pack(qw(-side left -expand 1));
+ my $w_see = $w_buttons->Button(
+ -text => 'See Code',
+ -command => [\&see_code, $demo],
+ );
+ $w_see->pack(qw(-side left -expand 1));
+ my $w_ball = $w_buttons->Button(
+ -text => 'View Ball Class Module',
+ -command => [\&view_widget,
+ Tk->findINC('demos/widget_lib') . '/Ball.pm'],
+ );
+ $w_ball->pack(qw(-side left -expand 1));
+
+ $bounce_running = 0;
+ $menu_button_list[1]->cget(-menu)->entryconfigure(1, -state => 'disabled');
+
+ $canvas->Ball;
+ $canvas->Ball(-color => 'red', -size => 30, -position => [200, 75]);
+ $canvas->Ball(
+ -color => 'green',
+ -size => 60,
+ -position => [490, 275],
+ -velocity => [8.0, 12.0],
+ );
+ $canvas->Ball(
+ -color => 'yellow',
+ -size => 100,
+ -position => [360, 60],
+ -velocity => [8.0, 12.0],
+ );
+
+ $bounce_counter = 0;
+ $TOP->repeat(1000 => sub {
+ return unless $bounce_running;
+ ClearMsg;
+ ShowMsg(sprintf("%6d interations/second", $bounce_counter));
+ $bounce_counter = 0
+ });
+
+
+ # This runs the Tk mainloop. Note that the simulation itself has a main
+ # loop which must be processed. DoSingleStep runs a bit of the simulation
+ # during every iteration. Also note that, with a flag of 0,
+ # Tk::DoOneEvent will suspend the process until an X-event arrives,
+ # effectively blocking the while loop.
+ #
+ # My original idea was to run the simulation mainloop as an asynchronous
+ # proc handler that runs when Tk is idle, but the necessary Async(3) calls
+ # from Tcl haven't made it into nTk yet.
+
+ while (1) {
+ if ($quit_flag) {
+ $TOP->destroy;
+ return;
+ }
+ DoOneEvent($bounce_running ? DONT_WAIT : ALL_EVENTS);
+ DoSingleStep($canvas) if $bounce_running;
+ }
+
+} # end bounce
+
+sub mkmb {
+
+ # (Ripped from nTk examples)
+ # Make a Menubutton widget; note that the menu is automatically created.
+ # We maintain a list of the Menubutton references since some callers
+ # need to refer to the Menubutton, as well as to suppress stray name
+ # warnings with Perl -w.
+
+ my($mb0, $mb_label, $mb_label_underline, $mb_msg, $mb_list_ref) = @_;
+ my $mb = $mb0->Menubutton(
+ -text => $mb_label,
+ -underline => $mb_label_underline,
+ -background => 'DarkGreen',
+ -foreground => 'Yellow',
+ );
+ my($menu) = $mb->Menu(-tearoff => 0);
+ $mb->configure(-menu => $menu);
+
+ my $mb_list;
+ foreach $mb_list (@{$mb_list_ref}) {
+ $mb->command(
+ -label => $mb_list->[0],
+ -command => $mb_list->[1] ,
+ -underline => $mb_list->[2],
+ -background => 'DarkGreen',
+ -foreground => 'White',
+ );
+ }
+ $mb->pack(-side => 'left');
+ $TOP->bind($mb, '<Enter>' => sub {ClearMsg; ShowMsg($mb_msg)});
+ $TOP->bind($mb, '<Leave>' => \&ClearMsg);
+
+ push @menu_button_list, $mb;
+ return $mb;
+
+} # end mkmb
+
+sub SimStart {
+
+ if (not $bounce_running) {
+ $bounce_running = 1;
+ $menu_button_list[1]->cget(-menu)->entryconfigure(0,
+ -state => 'disabled',
+ );
+ $menu_button_list[1]->cget(-menu)->entryconfigure(1,
+ -state => 'normal',
+ );
+ }
+
+} # end SimStart
+
+sub SimStop {
+
+ if ($bounce_running) {
+ $bounce_running = 0;
+ $menu_button_list[1]->cget(-menu)->entryconfigure(0,
+ -state => 'normal',
+ );
+ $menu_button_list[1]->cget(-menu)->entryconfigure(1,
+ -state => 'disabled',
+ );
+ }
+
+} # end SimStop
+
+sub NotDone {
+
+ print "Not yet implemented.\n";
+
+} # end NotDone
+
+sub ShowMsg {
+
+ my($msg) = shift;
+ $bounce_status->insert('1.0', $msg);
+
+} # end ShowMsg
+
+sub ClearMsg {
+
+ $bounce_status->delete('1.0', 'end');
+
+} # end ClearMsg
+
+sub DoSingleStep {
+
+ # The simulation handler.
+ #
+ # Note that this handler must be cooperative and return after a short
+ # period, so that other X events may be processed by the mainloop below.
+
+ my($canvas) = @_;
+
+ $bounce_counter++;
+ Ball->move_all_balls($canvas, $bounce_speed->get() / 100.0);
+
+} # end DoSingle Step
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry.pl
new file mode 100755
index 00000000000..ce32f13934b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry.pl
@@ -0,0 +1,34 @@
+# BrowseEntry, entry with listbox to select list values.
+
+use Tk::BrowseEntry;
+
+my $month = "January";
+
+outer:
+{
+ my $top = MainWindow->new;
+ my $f = $top->Frame;
+ my $c = $f->BrowseEntry(-label => "Month:", -variable => \$month);
+ $c->pack;
+ $c->insert("end", "January");
+ $c->insert("end", "February");
+ $c->insert("end", "March");
+ $c->insert("end", "April");
+ $c->insert("end", "May");
+ $c->insert("end", "June");
+ $c->insert("end", "July");
+ $c->insert("end", "August");
+ $c->insert("end", "September");
+ $c->insert("end", "October");
+ $c->insert("end", "November");
+ $c->insert("end", "December");
+ my $bf = $f->Frame;
+ $bf->Button(-text => "Print value",
+ -command => sub {
+ print "The month is $month\n";
+ }, -relief => "raised")->pack;
+
+ $bf->pack;
+ $f->pack;
+ MainLoop;
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry2.pl
new file mode 100755
index 00000000000..5c8f9919847
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry2.pl
@@ -0,0 +1,39 @@
+# BrowseEntry, another example.
+#
+# Chris Dean <ctdean@cogit.com>
+
+use strict;
+use Tk;
+use Tk::BrowseEntry;
+
+my $top = new MainWindow( -title => "BrowseEntry 2" );
+main( $top );
+MainLoop();
+
+sub main {
+ my( $top ) = @_;
+
+ my @countries = qw( America Belize Canada Denmark Egypt Fruitopia );
+ my @states = qw( normal readonly disabled );
+ foreach my $i (0..$#states) {
+ my $state = $states[$i];
+ my $var = $countries[$i];
+ my $f = $top->Frame->pack( qw/-side left/ );
+ my $be = $f->BrowseEntry( -variable => \$var,
+ -choices => \@countries,
+ -state => $state )->pack;
+ if( $state eq "disabled" ) {
+ $be->configure( -arrowimage => $f->Getimage( "balArrow" ) )
+ }
+ foreach my $s (@states) {
+ $f->Radiobutton( -text => $s,
+ -value => $s,
+ -variable => \$state,
+ -command => sub {
+ $be->configure( -state => $state ); }
+ )->pack( qw/-anchor w/ );
+ }
+ $f->Button( -text => "Print value", -command => sub {
+ print "$var\n" } )->pack;
+ }
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/button.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/button.pl
new file mode 100755
index 00000000000..4cc1b581678
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/button.pl
@@ -0,0 +1,28 @@
+# button.pl
+
+use vars qw/$TOP/;
+
+sub button {
+
+ # Create a top-level window that displays a bunch of buttons.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button.',
+ -title => 'Button Demonstration',
+ -iconname => 'button',
+ );
+
+ foreach my $color (qw/PeachPuff1 LightBlue1 SeaGreen2 Yellow1/) {
+ my $b = $TOP->Button(
+ -text => $color,
+ -width => 10,
+ -command => sub {$TOP->configure(-background => lc($color))},
+ );
+ $b->pack(qw/-side top -expand yes -pady 2/);
+ }
+
+} # end button
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/check.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/check.pl
new file mode 100755
index 00000000000..a5f9a10c093
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/check.pl
@@ -0,0 +1,44 @@
+# check.pl
+
+use vars qw/$TOP/;
+
+sub check {
+
+ # Create a top-level window that displays a bunch of check buttons.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Three checkbuttons are displayed below. If you click on a button, it will toggle the button\'s selection state and set a Perl variable to a value indicating the state of the checkbutton. Click the "See Variables" button to see the current values of the variables.',
+ -title => 'Checkbutton Demonstration',
+ -iconname => 'check',
+ );
+
+ my $var = $TOP->Button(
+ -text => 'See Variables',
+ -command => [\&see_vars, $TOP, [
+ ['wipers', \$WIPERS],
+ ['brakes', \$BRAKES],
+ ['sober', \$SOBER],
+ ],
+ ],
+ );
+ $var->pack(qw/-side bottom -expand 1/);
+
+ my(@pl) = qw/-side top -pady 2 -anchor w/;
+ my $b1 = $TOP->Checkbutton(
+ -text => 'Wipers OK',
+ -variable => \$WIPERS,
+ -relief => 'flat')->pack(@pl);
+ my $b2 = $TOP->Checkbutton(
+ -text => 'Brakes OK',
+ -variable => \$BRAKES,
+ -relief => 'flat')->pack(@pl);
+ my $b3 = $TOP->Checkbutton(
+ -text => 'Driver Sober',
+ -variable => \$SOBER,
+ -relief => 'flat')->pack(@pl);
+
+} # end check
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/choosedir.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/choosedir.pl
new file mode 100755
index 00000000000..5062afa0fad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/choosedir.pl
@@ -0,0 +1,39 @@
+# This demonstration script prompts the user to select a directory.
+
+use vars qw/$TOP/;
+
+sub choosedir {
+ my $demo = shift;
+
+ $TOP = $MW->WidgetDemo
+ (
+ -name => $demo,
+ -text => "Enter a directory name in the entry box or click on the \"Browse\" buttons to select a directory name using the directory selection dialog.",
+ -title => 'Choose Directory Demonstration',
+ -iconname => 'choosedir',
+ );
+ {
+ my $f = $TOP->Frame;
+ my $lab = $f->Label(-text => "Select a directory to open: ",
+ -anchor => 'e');
+ my $ent = $f->Entry(-width => 20);
+ my $but = $f->Button(-text => "Browse ...",
+ -command => sub { dirDialog($TOP, $ent)});
+ $lab->pack(-side => 'left');
+ $ent->pack(-side => 'left',-expand => 'yes', -fill => 'x');
+ $but->pack(-side => 'left');
+ $f->pack(-fill => 'x', -padx => '1c', -pady => 3);
+ }
+}
+
+sub dirDialog {
+ my $w = shift;
+ my $ent = shift;
+ my $dir;
+ $dir = $w->chooseDirectory;
+ if (defined $dir and $dir ne '') {
+ $ent->delete(0, 'end');
+ $ent->insert(0, $dir);
+ $ent->xview('end');
+ }
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/clrpick.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/clrpick.pl
new file mode 100755
index 00000000000..df9d3a72cd7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/clrpick.pl
@@ -0,0 +1,45 @@
+# clrpick.pl
+
+use Tk qw/catch/;
+use subs qw/setColor setColor_helper/;
+use vars qw/$TOP/;
+
+sub clrpick {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Press the buttons below to choose the foreground and background colors for the widgets in this window.',
+ -title => 'chooseColor Demo',
+ -iconname => 'chooseColor',
+ );
+
+ my(@pl) = qw/-side top -anchor c -pady 2m/;
+ my($back, $front);
+ $back = $TOP->Button(-text => 'Set background color ...')->pack(@pl);
+ $back->configure(-command => [\&setColor => $TOP, $back, '-background',
+ [-background, -highlightbackground]]);
+ $front = $TOP->Button(-text => 'Set foreground color ...')->pack(@pl);
+ $front->configure(-command => [\&setColor => $TOP, $front, '-foreground',
+ [-foreground]]);
+}
+
+sub setColor {
+ my($top, $button, $name, $options) = @_;
+ my $initialColor = $button->cget($name);
+ my $color = $button->chooseColor(-title => "Choose a $name color",
+ -initialcolor => $initialColor);
+ setColor_helper $top, $options, $color if defined $color;
+}
+
+sub setColor_helper {
+ my($widget, $options, $color) = @_;
+ foreach my $option (@$options) {
+ catch {
+ $widget->configure($option => $color);
+ }
+ }
+ foreach my $child ($widget->children) {
+ setColor_helper $child, $options, $color;
+ }
+}
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/colors.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/colors.pl
new file mode 100755
index 00000000000..922225107c1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/colors.pl
@@ -0,0 +1,85 @@
+# colors.pl
+
+use vars qw/$TOP/;
+
+sub colors {
+
+ # Create a top-level window containing a listbox showing a bunch of
+ # colors from the X color database.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the application\'s color palette will be set to match that color.',
+ -title => 'Listbox Demonstration (colors)',
+ -iconname => 'colors',
+ );
+
+ my $list = $TOP->Scrolled(qw/Listbox -width 20 -height 16 -setgrid 1
+ -scrollbars e/);
+ $list->pack(qw/-side left -fill y/);
+ $list->focus;
+
+ $list->bind('<Double-1>' =>
+ sub {
+ $_[0]->setPalette($_[0]->get('active'));
+ },
+ );
+
+ $list->insert(0, qw/gray60 gray70 gray80 gray85 gray90
+gray95 snow1 snow2 snow3 snow4 seashell1 seashell2 seashell3 seashell4
+AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 AntiqueWhite4 bisque1
+bisque2 bisque3 bisque4 PeachPuff1 PeachPuff2 PeachPuff3 PeachPuff4
+NavajoWhite1 NavajoWhite2 NavajoWhite3 NavajoWhite4 LemonChiffon1
+LemonChiffon2 LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2
+cornsilk3 cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2
+honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 LavenderBlush3
+LavenderBlush4 MistyRose1 MistyRose2 MistyRose3 MistyRose4 azure1
+azure2 azure3 azure4 SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4
+RoyalBlue1 RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4
+DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 SteelBlue2
+SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 DeepSkyBlue3
+DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 SkyBlue4 LightSkyBlue1
+LightSkyBlue2 LightSkyBlue3 LightSkyBlue4 SlateGray1 SlateGray2
+SlateGray3 SlateGray4 LightSteelBlue1 LightSteelBlue2 LightSteelBlue3
+LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 LightBlue4 LightCyan1
+LightCyan2 LightCyan3 LightCyan4 PaleTurquoise1 PaleTurquoise2
+PaleTurquoise3 PaleTurquoise4 CadetBlue1 CadetBlue2 CadetBlue3
+CadetBlue4 turquoise1 turquoise2 turquoise3 turquoise4 cyan1 cyan2
+cyan3 cyan4 DarkSlateGray1 DarkSlateGray2 DarkSlateGray3
+DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 aquamarine4
+DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 DarkSeaGreen4 SeaGreen1
+SeaGreen2 SeaGreen3 SeaGreen4 PaleGreen1 PaleGreen2 PaleGreen3
+PaleGreen4 SpringGreen1 SpringGreen2 SpringGreen3 SpringGreen4 green1
+green2 green3 green4 chartreuse1 chartreuse2 chartreuse3 chartreuse4
+OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 DarkOliveGreen1
+DarkOliveGreen2 DarkOliveGreen3 DarkOliveGreen4 khaki1 khaki2 khaki3
+khaki4 LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4
+LightYellow1 LightYellow2 LightYellow3 LightYellow4 yellow1 yellow2
+yellow3 yellow4 gold1 gold2 gold3 gold4 goldenrod1 goldenrod2
+goldenrod3 goldenrod4 DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3
+DarkGoldenrod4 RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1
+IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4
+burlywood1 burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3
+wheat4 tan1 tan2 tan3 tan4 chocolate1 chocolate2 chocolate3 chocolate4
+firebrick1 firebrick2 firebrick3 firebrick4 brown1 brown2 brown3
+brown4 salmon1 salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2
+LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 DarkOrange1
+DarkOrange2 DarkOrange3 DarkOrange4 coral1 coral2 coral3 coral4
+tomato1 tomato2 tomato3 tomato4 OrangeRed1 OrangeRed2 OrangeRed3
+OrangeRed4 red1 red2 red3 red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4
+HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 LightPink1
+LightPink2 LightPink3 LightPink4 PaleVioletRed1 PaleVioletRed2
+PaleVioletRed3 PaleVioletRed4 maroon1 maroon2 maroon3 maroon4
+VioletRed1 VioletRed2 VioletRed3 VioletRed4 magenta1 magenta2 magenta3
+magenta4 orchid1 orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4
+MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 DarkOrchid1
+DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 purple2 purple3 purple4
+MediumPurple1 MediumPurple2 MediumPurple3 MediumPurple4 thistle1
+thistle2 thistle3 thistle4/);
+
+ $list->activate(0);
+
+} # end colors
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/cscroll.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/cscroll.pl
new file mode 100755
index 00000000000..e39e9caac56
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/cscroll.pl
@@ -0,0 +1,86 @@
+# cscroll.pl
+
+use subs qw/cscroll_button cscroll_enter cscroll_leave/;
+use vars qw/$TOP/;
+
+sub cscroll {
+
+ # Create a top-level window containing a simple canvas that can be
+ # scrolled in two dimensions.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout.',
+ -title => 'Scrollable Canvas Demonstration',
+ -iconname => 'cscroll',
+ );
+
+ my $c = $TOP->Scrolled(qw/Canvas -relief sunken -borderwidth 2
+ -scrollbars se -scrollregion/ => ['-10c', '-10c', '50c', '20c']);
+ $c->pack(qw/-expand yes -fill both/);
+
+ my($bg, $i, $j, $x, $y) = ($c->configure(-background))[4];
+ for ($i = 0; $i < 20; $i++) {
+ $x = -10 + 3 * $i;
+ $j = 0;
+ $y = -10;
+ while ($j < 10) {
+ $c->createRectangle("${x}c", "${y}c",
+ ($x+2).'c', ($y+2).'c',
+ -outline => 'black', -fill => $bg, -tags => 'rect');
+ $c->createText(($x+1).'c', ($y+1).'c',
+ -text => "$i,$j", -anchor => 'center', -tags => 'text');
+ $j++;
+ $y += 3;
+ } # whilend
+ } # forend
+
+ my $old_fill = '';
+ $c->bind('all', '<Any-Enter>' => [\&cscroll_enter, \$old_fill]);
+ $c->bind('all', '<Any-Leave>' => [\&cscroll_leave, \$old_fill]);
+ $c->bind('all', '<1>' => \&cscroll_button);
+
+ $c->CanvasBind('<2>' => [ scanMark => Ev('x'), Ev('y') ]);
+ $c->CanvasBind('<B2-Motion>' => [ scanDragto => Ev('x'), Ev('y') ]);
+
+} # end cscroll
+
+sub cscroll_button {
+
+ my($c) = @_;
+
+ my ($id) = $c->find(qw/withtag current/);
+ $id++ if ($c->gettags('current'))[0] ne 'text';
+ print STDOUT 'You buttoned at ', ($c->itemconfigure($id, -text))[4], "\n";
+
+} # end cscroll_button
+
+sub cscroll_enter {
+
+ my($c, $old_fill) = @_;
+
+ my ($id) = $c->find(qw/withtag current/);
+ $id-- if ($c->gettags('current'))[0] eq 'text';
+ $$old_fill = ($c->itemconfigure($id, -fill))[4];
+ if ($c->depth > 1) {
+ $c->itemconfigure($id, -fill => 'SeaGreen1');
+ } else {
+ $c->itemconfigure($id, -fill => 'black');
+ $c->itemconfigure($id+1, -fill => 'white');
+ }
+
+} # end cscroll_enter
+
+sub cscroll_leave {
+
+ my($c, $old_fill) = @_;
+
+ my ($id) = $c->find(qw/withtag current/);
+ $id-- if ($c->gettags('current'))[0] eq 'text';
+ $c->itemconfigure($id, -fill => $$old_fill);
+ $c->itemconfigure($id+1, -fill => 'black');
+
+} # end cscroll_leave
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ctext.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ctext.pl
new file mode 100755
index 00000000000..9c2ca476379
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ctext.pl
@@ -0,0 +1,170 @@
+# ctext.pl
+
+use subs qw/ctext_bs ctext_configure ctext_enter ctext_move ctext_press/;
+use vars qw/$TOP/;
+
+sub ctext {
+
+ # Create a window containing a canvas displaying a text string and
+ # allowing the string to be edited and re-anchored.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adijust the position of the text relative to its positioning point or change its justification. The text also supports the following simple bindings for editing:
+ 1. You can point, click, and type.
+ 2. You can also select with button 1.
+ 3. You can copy the selection to the mouse position with button 2.
+ 4. Backspace and Control+h delete the selection if there is one;
+ otherwise they delete the character just before the insertion cursor.
+ 5. Delete deletes the selection if there is one; otherwise it deletes
+ the character just after the insertion cursor.', qw/-wraplength 5i/],
+ -title => 'Canvas Text Demonstration',
+ -iconname => 'ctext',
+ );
+
+ my $c = $TOP->Canvas(qw/-relief flat -bd 0 -width 500 -height 350/);
+ $c->pack(qw/-side top -expand yes -fill both/);
+
+ $c->create(qw/rectangle 245 195 255 205 -outline black -fill red/);
+
+ # First, create the text item and give it bindings so it can be edited.
+
+ $c->addtag(qw/text withtag/,
+ $c->create('text', 250, 200,
+ -text => 'This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)."',
+ qw/-width 440 -anchor n -justify left
+ -font -*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-*/
+ ),
+ );
+ $c->bind(qw/text <1>/ => \&ctext_press);
+ $c->bind(qw/text <B1-Motion>/ => \&ctext_move);
+ $c->bind(qw/text <Shift-1>/ => sub {
+ my($c) = @_;
+ my $e = $c->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $c->select(qw/adjust current/, "\@$x,$y");
+ });
+ $c->bind(qw/text <Shift-B1-Motion>/ => \&ctext_move);
+ $c->bind(qw/text <KeyPress>/ => sub {
+ my($c) = @_;
+ my $e = $c->XEvent;
+ my $A = $e->A;
+ $c->insert(qw/text insert/, "$A");
+ });
+ $c->bind(qw/text <Return>/ => sub {
+ my($c) = @_;
+ $c->insert(qw/text insert/, "\\n");
+ });
+ $c->bind(qw/text <Control-h>/ => \&ctext_bs);
+ $c->bind(qw/text <BackSpace>/ => \&ctext_bs);
+ $c->bind(qw/text <Delete>/ => sub {
+ my($c) = @_;
+ eval {local $SIG{__DIE__}; $c->dchars(qw/text sel.first sel.last/)};
+ $c->dchars('text', 'insert');
+ });
+ $c->bind(qw/text <2>/ => sub {
+ my($c) = @_;
+ my $e = $c->XEvent;
+ $c->insert('text', $e->xy, $MW->SelectionGet);
+ });
+
+ # Next, create some items that allow the text's anchor position to
+ # be edited.
+
+ my($x, $y, $color) = (50, 50, 'LightSkyBlue1');
+ ctext_configure $c, $x, $y, -anchor => 'se', $color;
+ ctext_configure $c, $x+30, $y, -anchor => 's', $color;
+ ctext_configure $c, $x+60, $y, -anchor => 'sw', $color;
+ ctext_configure $c, $x, $y+30, -anchor => 'e', $color;
+ ctext_configure $c, $x+30, $y+30, -anchor => 'center', $color;
+ ctext_configure $c, $x+60, $y+30, -anchor => 'w', $color;
+ ctext_configure $c, $x, $y+60, -anchor => 'ne', $color;
+ ctext_configure $c, $x+30, $y+60, -anchor => 'n', $color;
+ ctext_configure $c, $x+60, $y+60, -anchor => 'nw', $color;
+ my $item = $c->create('rectangle', $x+40, $y+40, $x+50, $y+50,
+ qw/-outline black -fill red/);
+ $c->bind($item, '<1>' => sub {
+ shift->itemconfigure(qw/text -anchor center/);
+ });
+ $c->create('text', $x+45, $y-5, -text => 'Text Position', qw/-anchor s
+ -font -*-times-medium-r-normal--*-240-*-*-*-*-*-*
+ -fill brown/);
+
+ # Lastly, create some items that allow the text's justification
+ # to be changed.
+
+ $x = 350; $y = 50; $color = 'SeaGreen2';
+ ctext_configure $c, $x, $y, -justify => 'left', $color;
+ ctext_configure $c, $x+30, $y, -justify => 'center', $color;
+ ctext_configure $c, $x+60, $y, -justify => 'right', $color;
+ $c->create('text', $x+45, $y-5, qw/-text Justification -anchor s
+ -font -*-times-medium-r-normal--*-240-*-*-*-*-*-*
+ -fill brown/);
+
+ my $config_fill = '';
+ $c->bind(qw/config <Enter>/ => [\&ctext_enter, \$config_fill]);
+ $c->bind(qw/config <Leave>/ =>
+ sub {$c->itemconfigure('current', -fill => $config_fill)}
+ );
+
+} # end ctext
+
+sub ctext_bs {
+
+ my($c) = @_;
+
+ eval {local $SIG{__DIE__}; $c->dchars(qw/text sel.first sel.last/)};
+ my $char = $c->index(qw/text insert/) - 1;
+ $c->dchars('text', $char) if $char >= 0;
+
+} # end ctext_bs
+
+sub ctext_configure {
+
+ my($w, $x, $y, $option, $value, $color) = @_;
+
+ my $item = $w->create('rectangle', $x, $y, $x+30, $y+30,
+ -outline => 'black', -fill => $color, -width => 1);
+ $w->bind($item, '<1>',
+ sub {$w->itemconfigure('text', $option => $value)}
+ );
+ $w->addtag(qw/config withtag/, $item);
+
+} # end ctext_configure
+
+sub ctext_enter {
+
+ my($w, $config_fill) = @_;
+
+ $$config_fill = ($w->itemconfigure('current', -fill))[4];
+ $w->itemconfigure(qw/current -fill black/);
+
+} # end ctext_enter
+
+sub ctext_move {
+
+ my($w) = @_;
+ my $e = $w->XEvent;
+
+ my($x, $y) = ($e->x, $e->y);
+ $w->select(qw/to current/, "\@$x,$y");
+
+} # end ctext_move
+
+sub ctext_press {
+
+ my($w) = @_;
+ my $e = $w->XEvent;
+
+ my($x, $y) = ($e->x, $e->y);
+ $w->icursor('current', "\@$x,$y");
+ $w->focus('current');
+ $w->CanvasFocus;
+ $w->select(qw/from current/, "\@$x,$y");
+
+} # end ctext_press
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog1.pl
new file mode 100755
index 00000000000..9c98bdfca22
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog1.pl
@@ -0,0 +1,33 @@
+# dialog1.pl
+
+use subs qw/see_code/;
+use vars qw/$DIALOG1/;
+
+sub dialog1 {
+
+ my($demo) = @_;
+
+ my($ok, $can, $see) = ('OK', 'Cancel', 'See Code');
+ if (not Exists($DIALOG1)) {
+ $DIALOG1 = $MW->Dialog(
+ -title => 'Dialog with local grab',
+ -text => '',
+ -bitmap => 'info',
+ -default_button => $ok,
+ -buttons => [$ok, $can, $see],
+ );
+ $DIALOG1->configure(
+ -wraplength => '4i',
+ -text => 'This is a modal dialog box. It uses Tk\'s "grab" command to create a "local grab" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications.',
+ );
+ }
+
+ my $button = $DIALOG1->Show;
+
+ print "You pressed OK\n" if $button eq $ok;
+ print "You pressed Cancel\n" if $button eq $can;
+ see_code 'dialog1' if $button eq $see;
+
+} # end dialog1
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog2.pl
new file mode 100755
index 00000000000..15b2102edcd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog2.pl
@@ -0,0 +1,33 @@
+# dialog2.pl
+
+use subs qw/see_code/;
+use vars qw/$DIALOG2/;
+
+sub dialog2 {
+
+ my($demo) = @_;
+
+ my($ok, $can, $see) = ('OK', 'Cancel', 'See Code');
+ if (not Exists($DIALOG2)) {
+ $DIALOG2 = $MW->Dialog(
+ -title => 'Dialog with global grab',
+ -text => '',
+ -bitmap => 'info',
+ -default_button => $ok,
+ -buttons => [$ok, $can, $see],
+ );
+ $DIALOG2->configure(
+ -wraplength => '4i',
+ -text => 'This dialog box uses a global grab, so it prevents you from interacting with anything on your display until you invoke one of the buttons below. Global grabs are almost always a bad idea; don\'t use them unless you\'re truly desperate.',
+ );
+ }
+
+ my $button = $DIALOG2->Show('-global');
+
+ print "You pressed OK\n" if $button eq $ok;
+ print "You pressed Cancel\n" if $button eq $can;
+ see_code 'dialog2' if $button eq $see;
+
+} # end dialog2
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dirtree.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dirtree.pl
new file mode 100755
index 00000000000..0cf91417a56
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dirtree.pl
@@ -0,0 +1,7 @@
+# DirTree, display directory tree.
+
+use Tk;
+use Tk::DirTree;
+my $top = MainWindow->new;
+my $dl = $top->Scrolled('DirTree')->pack(-expand => 1 , -fill => 'both');
+MainLoop;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry1.pl
new file mode 100755
index 00000000000..6250df5f4d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry1.pl
@@ -0,0 +1,28 @@
+# entry1.pl
+
+use vars qw/$TOP/;
+
+sub entry1 {
+
+ # Create a top-level window that displays a bunch of entries.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed.', qw/-wraplength 5i/],
+ -title => 'Entry Demonstration (no scrollbars)',
+ -iconname => 'entry1',
+ );
+
+ my(@relief) = qw/-relief sunken/;
+ my(@pl) = qw/-side top -padx 10 -pady 5 -fill x/;
+ my $e1 = $TOP->Entry(@relief)->pack(@pl);
+ my $e2 = $TOP->Entry(@relief)->pack(@pl);
+ my $e3 = $TOP->Entry(@relief)->pack(@pl);
+
+ $e1->insert(0, 'Initial value');
+ $e2->insert('end', 'This entry contains a long value, much too long to fit in the window at one time, so long in fact that you\'ll have to scan or scroll to see the end.');
+
+} # end entry1
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry2.pl
new file mode 100755
index 00000000000..4f3c85e3454
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry2.pl
@@ -0,0 +1,33 @@
+# entry2.pl
+
+use vars qw/$TOP/;
+
+sub entry2 {
+
+ # Create a top-level window that displays a bunch of entries with
+ # scrollbars.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed.', -wraplength => '5i'],
+ -title => 'Entry Demonstration (with scrollbars)',
+ -iconname => 'entry2',
+ );
+
+ my(@pl) = qw/-side top -fill x/;
+ my(@scrolled_attributes) = qw/Entry -relief sunken -scrollbars s/;
+ my(@spacer_attributes) = qw/-width 20 -height 10/;
+
+ my $e1 = $TOP->Scrolled(@scrolled_attributes)->pack(@pl);
+ my $spacer1 = $TOP->Frame(@spacer_attributes)->pack(@pl);
+ my $e2 = $TOP->Scrolled(@scrolled_attributes)->pack(@pl);
+ my $spacer2 = $TOP->Frame(@spacer_attributes)->pack(@pl);
+ my $e3 = $TOP->Scrolled(@scrolled_attributes)->pack(@pl);
+
+ $e1->insert(0, 'Initial value');
+ $e2->insert('end', 'This entry contains a long value, much too long to fit in the window at one time, so long in fact that you\'ll have to scan or scroll to see the end.');
+
+} # end entry2
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry3.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry3.pl
new file mode 100755
index 00000000000..b296fbb0353
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry3.pl
@@ -0,0 +1,199 @@
+# entry3.pl
+
+use vars qw/$TOP/;
+
+sub entry3 {
+
+ # This demonstration script creates several entry widgets whose
+ # permitted input is constrained in some way. It also shows off a
+ # password entry.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Four different entries are displayed below. You can add characters by pointing, clicking and typing, though each is constrained in what it will accept. The first only accepts integers or the empty string (checking when focus leaves it) and will flash to indicate any problem. The second only accepts strings with fewer than ten characters and sounds the bell when an attempt to go over the limit is made. The third accepts US phone numbers, mapping letters to their digit equivalent and sounding the bell on encountering an illegal character or if trying to type over a character that is not a digit. The fourth is a password field that accepts up to eight characters (silently ignoring further ones), and displaying them as asterisk characters.',
+ -title => 'Constrained Entry Demonstration',
+ -iconname => 'entry3',
+ );
+
+
+ my $lf1 = $TOP->Labelframe(-text => 'Integer Entry');
+ my $e1;
+ $e1 = $lf1->Entry(
+ -validate => 'focus',
+ -validatecommand => sub {
+ my ($proposed, $changes, $current, $index, $type) = @_;
+ return not $proposed =~ m/[^\d]/g;
+ },
+ );
+ $e1->configure(
+ -invalidcommand =>
+ [\&entry3_flash, $e1, $e1->cget(-fg), $e1->cget(-bg)],
+ );
+ $e1->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/);
+
+ my $lf2 = $TOP->Labelframe(-text => 'Length-Constrained Entry');
+ my $e2 = $lf2->Entry(
+ -validate => 'key',
+ -invalidcommand => sub {$TOP->bell},
+ -validatecommand => sub {
+ my ($proposed, $changes, $current, $index, $type) = @_;
+ return length($proposed) < 10 ? 1 : 0;
+ },
+ );
+ $e2->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/);
+
+ # phone number entry
+ #
+ # Note that the source to this is quite a bit longer as the behaviour
+ # demonstrated is a lot more ambitious than with the others.
+ #
+ # Mapping from alphabetic characters to numbers. This is probably
+ # wrong, but it is the only mapping I have; the UK doesn't really go
+ # for associating letters with digits for some reason.
+
+ my %phone_letters = qw/abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9/;
+ my %l2n; # letter to number mapping hash
+
+ while (my ($k, $v) = each %phone_letters) {
+ map {$l2n{$_} = $v} split '', $k;
+ }
+
+ my $lf3 = $TOP->Labelframe(-text => 'US Phone-Number Entry');
+ my $e3_var = '1-(000)-000-0000';
+ my $e3;
+ $e3 = $lf3->Entry(
+ -validate => 'key',
+ -invalidcommand => sub {$TOP->bell},
+ -textvariable => \$e3_var,
+ );
+ $e3->configure(
+ -validatecommand => [\&entry3_validate_phone, $e3, \%l2n],
+ );
+ $e3->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/);
+ # Click to focus goes to the first editable character...
+ $e3->bind('<FocusIn>' => sub {
+ my $e = shift;
+ if ($Tk::event->d ne "NotifyAncestor") {
+ $e->icursor(3);
+ $e->afterIdle(sub {$e->selectionClear});
+ }
+ });
+ $e3->bind('<Left>' => \&entry3_phone_left);
+ $e3->bind('<Right>' => \&entry3_phone_right);
+
+ my $lf4 = $TOP->Labelframe(-text => 'Password Entry');
+ my $e4 = $lf4->Entry(
+ -validate => 'key',
+ -show => '*',
+ -validatecommand => sub {
+ my ($proposed, $changes, $current, $index, $type) = @_;
+ return length($proposed) <= 8 ? 1 : 0;
+ },
+ );
+ $e4->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/);
+
+ my $f = $TOP->Frame;
+ $f->lower;
+ $lf1->grid($lf2, -in => $f, qw/-padx 3m -pady 1m -sticky ew/);
+ $lf3->grid($lf4, -in => $f, qw/-padx 3m -pady 1m -sticky ew/);
+ $f->gridColumnconfigure([0, 1], -uniform => 1);
+ $f->pack(qw/-fill both -expand 1/);
+
+} # end entry3
+
+sub entry3_flash {
+ my ($w, $fg, $bg) = @_;
+ $w->focusForce;
+ $w->{count} = 9 unless defined $w->{count};
+ if ($w->{count} < 1) {
+ $w->configure(-foreground => $fg, -background => $bg);
+ $w->{count} = 9;
+ } else {
+ if ($w->{count} % 2) {
+ $w->configure(-foreground => $bg, -background => $fg);
+ } else {
+ $w->configure(-foreground => $fg, -background => $bg);
+ }
+ $w->{count}--;
+ $w->after(200 => [\&entry3_flash, $w, $fg, $bg]);
+ }
+} # end entry3_flash
+
+sub entry3_phone_left {
+
+ # Skip over fixed characters in a phone-number string when moving left.
+
+ my $e = shift;
+ my $index = $e->index('insert');
+ if ($index == 8) {
+ # Skip back two extra characters
+ $index -= 2;
+ $e->icursor($index);
+ } elsif ($index == 7 or $index == 12) {
+ # Skip back one extra character
+ $index -= 1;
+ $e->icursor($index);
+ } elsif ($index <= 3) {
+ # Can't move any further
+ $e->bell;
+ #return -code break
+ $e->break;
+ }
+
+} # end entry3_phone_left
+
+sub entry3_phone_right {
+
+ # Skip over fixed characters in a phone-number string when moving right.
+
+ my ($e, $add) = @_;
+
+ $add = 0 unless defined $add;
+ my $index = $e->index('insert');
+ if ($index + $add == 5) {
+ # Skip forward two extra characters
+ $index += 2;
+ $e->icursor($index);
+ } elsif ($index + $add == 6 or $index + $add == 10) {
+ # Skip forward one extra character
+ $index++;
+ $e->icursor($index);
+ } elsif ($index + $add == 15 and not $add) {
+ # Can't move any further
+ $e->bell;
+ #return -code break
+ $e->break;
+ }
+
+} # end entry3_phone_right
+
+sub entry3_validate_phone {
+
+ # Checks that the replacement (mapped to a digit) of the given
+ # character in an entry widget at the given position will leave a
+ # valid phone number in the widget.
+
+ my ($w, $l2n_ref, $proposed, $changes, $current, $index, $type) = @_;
+
+ return 1 if $index == -1;
+ my $val = $w->cget(-validate);
+ $w->afterIdle(sub {
+ $w->configure(
+ -validate => $val,
+ -invalidcommand => sub {$w->bell},
+ );
+ });
+ if (not ($index < 3 or $index == 6 or $index == 7 or $index == 11 or
+ $index > 15) and $changes =~ m/[0-9A-Z]/i) {
+ $w->delete($index);
+ $changes =~ s/$_/$l2n_ref->{$_}/ig foreach (keys %$l2n_ref);
+ $w->insert($index, $changes);
+ $w->afterIdle([\&entry3_phone_right, $w, -1]);
+ return 1;
+ }
+ return 0;
+
+} # end entry3_validate_phone;
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/filebox.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/filebox.pl
new file mode 100755
index 00000000000..0d1b9737c01
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/filebox.pl
@@ -0,0 +1,106 @@
+# filebox.tcl --
+#
+# This demonstration script prompts the user to select a file.
+#
+# SCCS: @(#) filebox.tcl 1.3 97/03/02 16:22:36
+
+use vars qw/$TOP/;
+
+sub filebox {
+ my $demo = shift;
+
+ $TOP = $MW->WidgetDemo
+ (
+ -name => $demo,
+ -text => "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog.",
+ -title => 'File box Demonstration',
+ -iconname => 'filebox',
+ );
+ foreach my $i (qw(open save)) {
+ my $f = $TOP->Frame;
+ my $lab = $f->Label(-text => "Select a file to $i: ",
+ -anchor => 'e');
+ my $ent = $f->Entry(-width => 20);
+ my $but = $f->Button(-text => "Browse ...",
+ -command => sub { fileDialog($TOP, $ent, $i)});
+ $lab->pack(-side => 'left');
+ $ent->pack(-side => 'left',-expand => 'yes', -fill => 'x');
+ $but->pack(-side => 'left');
+ $f->pack(-fill => 'x', -padx => '1c', -pady => 3);
+ }
+
+ my $cbf = $TOP->Frame->pack(-fill => 'x', -padx => '1c', -pady => 3);
+ my $fd;
+ $cbf->Radiobutton
+ (-text => 'FileSelect',
+ -variable => \$fd,
+ -value => 'FileSelect',
+ -command => sub { local($^W) = 0;
+ require Tk::FileSelect;
+ Tk::FileSelect->import('as_default');
+ _removeCachedFileDialogs();
+ })->pack(-side => 'left');
+ my $fdb = $cbf->Radiobutton
+ (-text => 'FBox',
+ -variable => \$fd,
+ -value => 'FBox',
+ -command => sub { local($^W) = 0;
+ require Tk::FBox;
+ Tk::FBox->import('as_default');
+ _removeCachedFileDialogs();
+ })->pack(-side => 'left');
+ $fdb->invoke;
+
+# XXX Motif style file box not implemented
+# unless (compare($tcl_platform{'platform'},'unix'))
+# {
+# $w->{'.strict'} = $w->Checkbutton('Name','strict','-text',"Use Motif Style Dialog",'-variable','tk_strictMotif','-onvalue',1,'-offvalue',0);
+# $w->{'.strict'}->pack('-anchor','c');
+# }
+}
+
+sub fileDialog {
+ my $w = shift;
+ my $ent = shift;
+ my $operation = shift;
+ my $types;
+ my $file;
+ # Type names Extension(s) Mac File Type(s)
+ #
+ #---------------------------------------------------------
+ @types =
+ (["Text files", [qw/.txt .doc/]],
+ ["Text files", '', 'TEXT'],
+ ["Perl Scripts", '.pl', 'TEXT'],
+ ["C Source Files", ['.c', '.h']],
+ ["All Source Files", [qw/.tcl .c .h/]],
+ ["Image Files", '.gif'],
+ ["Image Files", ['.jpeg', '.jpg']],
+ ["Image Files", '', [qw/GIFF JPEG/]],
+ ["All files", '*']
+ );
+ if ($operation eq 'open') {
+ $file = $w->getOpenFile(-filetypes => \@types);
+ } else {
+ $file = $w->getSaveFile(-filetypes => \@types,
+ -initialfile => 'Untitled',
+ -defaultextension => '.txt');
+ }
+ if (defined $file and $file ne '') {
+ $ent->delete(0, 'end');
+ $ent->insert(0, $file);
+ $ent->xview('end');
+ }
+}
+
+sub _removeCachedFileDialogs {
+ my $mw = $TOP->MainWindow;
+ my $remove = sub {
+ my $t = shift;
+ return if (!UNIVERSAL::isa($t, "Tk::Toplevel"));
+ delete $t->{'tk_getOpenFile'};
+ delete $t->{'tk_getSaveFile'};
+ };
+ $remove->($mw);
+ $mw->Walk($remove);
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/floor.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/floor.pl
new file mode 100755
index 00000000000..5fa5be1ead2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/floor.pl
@@ -0,0 +1,1324 @@
+# floor.pl
+
+use Tk::Trace;
+use subs qw/floor_bg1 floor_bg2 floor_bg3 floor_display floor_fg1 floor_fg2
+ floor_fg3 floor_room_changed/;
+use vars qw/$TOP/;
+
+sub floor {
+
+ # Create a top-level window containing a Canvas that displays the
+ # floorplan for DEC's Western Research Laboratory.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['This window contains a canvas widget showing the floorplan of Digital Equipment Corporation\'s Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the "Room:" entry. You can also type a room number in the entry and the room will light up.', qw/-wraplength 8i/],
+ -title => 'Floorplan Canvas Demonstration',
+ -iconname => 'floor',
+ );
+
+ my $c = $TOP->Scrolled(qw/Canvas -width 900 -height 500 -relief sunken
+ -borderwidth 2 -scrollbars se/);
+ $c->pack(qw/-expand yes -fill both/);
+
+ # Create an Entry for displaying and typing in current room.
+
+ $floor::current_room = '';
+ my $c_entry = $c->Entry(qw/-width 10 -relief sunken -borderwidth 2
+ -textvariable/ => \$floor::current_room);
+
+ # Choose colors, then fill in the floorplan.
+
+ my %cinfo; # color information hash
+ if ($TOP->depth > 1) {
+ $cinfo{'floor_bg1'} = '#a9c1da';
+ $cinfo{outline1} = '#77889a';
+ $cinfo{'floor_bg2'} = '#9ab0c6';
+ $cinfo{outline2} = '#687786';
+ $cinfo{'floor_bg3'} = '#8ba0b3';
+ $cinfo{outline3} = '#596673';
+ $cinfo{offices} = 'Black';
+ $cinfo{active} = '#c4d1df';
+ } else {
+ $cinfo{'floor_bg1'} = 'white';
+ $cinfo{outline1} = 'black';
+ $cinfo{'floor_bg2'} = 'white';
+ $cinfo{outline2} = 'black';
+ $cinfo{'floor_bg3'} = 'white';
+ $cinfo{outline3} = 'black';
+ $cinfo{offices} = 'Black';
+ $cinfo{active} = 'black';
+ }
+
+ my %floor_labels = ();
+ my %floor_items = ();
+ my $active_floor = 0;
+ floor_display $c->Subwidget('canvas'), 3, \%floor_labels, \%floor_items,
+ \%cinfo, \$active_floor, $c_entry;
+
+ # Set up event bindings for the Canvas.
+
+ my $floor_number;
+ for $floor_number (1..3) {
+ $c->bind("floor${floor_number}", '<1>' =>
+ [\&floor_display, $floor_number, \%floor_labels, \%floor_items,
+ \%cinfo, \$active_floor, $c_entry],
+ );
+ }
+ $c->bind('room', '<Enter>' => sub {
+ my($c) = @_;
+ my $id = $c->find('withtag' => 'current');
+ $id = $id->[0] if ref($id) eq 'ARRAY';
+ $floor::current_room = $floor_labels{$id} if defined $id;
+ $c->idletasks;
+ });
+ $c->bind('room', '<Leave>' => sub {$floor::current_room = ''});
+ $c->CanvasBind('<2>' => sub {
+ my($c) = @_;
+ my $e = $c->XEvent;
+ $c->scanMark($e->x, $e->y);
+ });
+ $c->CanvasBind('<B2-Motion>' => sub {
+ my($c) = @_;
+ my $e = $c->XEvent;
+ $c->scanDragto($e->x, $e->y);
+ });
+ $c->CanvasBind('<Enter>', => [sub {shift; shift->focus}, $c_entry]);
+
+ $c->traceVariable(\$floor::current_room, 'w' =>
+ [sub {
+ my($index, $value, $op, $floor_items, $cinfo) = @_;
+ return if $op eq 'u';
+ $floor_current_room = $value;
+ &floor_room_changed($c->Subwidget('canvas'), $floor_items, $cinfo);
+ $value; # always return variable's new value
+ }, \%floor_items, \%cinfo],
+ );
+
+} # floor
+
+sub floor_display {
+
+ # The following procedure recreates the floorplan display in the
+ # Canvas given by "w". The floor given by "active" (1, 2, or 3) is
+ # displayed on top, with office structure visible. (Used as a callback
+ # and a normal function.)
+
+ my($c, $active, $floor_labels, $floor_items, $cinfo, $active_floor,
+ $c_entry) = @_;
+
+ return if $$active_floor eq $active;
+
+ $c->delete('all');
+ $$active_floor = $active;
+
+ # First go through the three floors, displaying the backgrounds for
+ # each floor.
+
+ floor_bg1 $c, $cinfo->{'floor_bg1'}, $cinfo->{outline1};
+ floor_bg2 $c, $cinfo->{'floor_bg2'}, $cinfo->{outline2};
+ floor_bg3 $c, $cinfo->{'floor_bg3'}, $cinfo->{outline3};
+
+ # Raise the background for the active floor so that it's on top.
+
+ $c->raise("floor${active}");
+
+ # Create a dummy item just to mark this point in the display list, so
+ # we can insert highlights here.
+
+ $c->create('rectangle', 0, 100, 1, 101, -fill => undef, -outline => undef,
+ -tags => 'marker');
+
+ # Add the walls and labels for the active floor, along with transparent
+ # polygons that define the rooms on the floor. Make sure that the room
+ # polygons are on top.
+
+ my $cmd = "floor_fg${active}";
+ {
+ no strict qw(refs);
+ &$cmd($c, $cinfo->{offices}, $floor_labels, $floor_items);
+ }
+ $c->raise('room');
+
+ # Offset the floors diagonally from each other.
+
+ $c->move(qw(floor1 2c 2c));
+ $c->move(qw(floor2 1c 1c));
+
+ # Create items for the room entry and its label.
+
+ $c->create('window', 600, 100, -anchor => 'w', -window => $c_entry);
+ $c->create('text', 600, 100, -anchor => 'e', -text => 'Room: ');
+ $c->configure(-scrollregion => [$c->bbox('all')]);
+
+} # end floor_display
+
+
+sub floor_room_changed {
+
+ # Whenever the current_room variable changes, this procedure highlights
+ # the current room and unhighlights any previous room.
+
+ my($w, $floor_items, $cinfo) = @_;
+
+ $w->delete('highlight');
+ my $item = $floor_items->{$floor::current_room};
+ return if not defined $item;
+ my(@c) = $w->coords($item);
+ if ($c[0]) {
+ $w->raise(
+ $w->create('polygon', @c,
+ -fill => $cinfo->{active},
+ -tags => 'highlight',
+ ),
+ 'marker');
+ } # ifend we have coordinates
+
+} # end floor_room_changed
+
+# The following procedures are invoked to instantiate various portions of
+# the building floorplan. The bodies of these procedures were generated
+# automatically from database files describing the building.
+
+
+sub floor_bg1 {
+
+ my ($w, $fill, $outline) = @_;
+
+ $w->create('poly', qw(347 80 349 82 351 84 353 85 363 92 375 99 386 104 386 129 398 129 398 162 484 162 484 129 559 129 559
+ 133 725 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 508 327 508 311 484 311 484 278 395 278 395 288 400
+ 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335
+ 338 332 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 331 365 326 366 304 366 304 355 258 355 258 387 60
+ 387 60 391 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220
+ 68 220 34 221 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 321 14 335 22 348 25 365 29 363 39 358 48 352
+ 56 337 70 344 76 347 80), -tags => ['floor1', 'bg'], -fill => $fill);
+
+ $w->create('line', qw(386 129 398 129), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(258 355 258 387), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(60 387 60 391), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(0 337 0 391), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(60 391 0 391), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(3 114 3 337), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(258 387 60 387), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(484 162 398 162), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(398 162 398 129), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(484 278 484 311), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(484 311 508 311), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(508 327 508 311), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(559 327 508 327), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(644 391 559 391), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(644 389 644 391), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(559 129 484 129), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(484 162 484 129), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(725 133 559 133), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(559 129 559 133), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(725 129 802 129), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(802 389 802 129), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(3 337 0 337), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(559 391 559 327), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(802 389 644 389), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(725 133 725 129), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(8 25 8 114), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(8 114 3 114), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(30 25 8 25), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(484 278 395 278), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(30 25 30 5), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(93 5 30 5), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(98 5 93 5), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(104 7 98 5), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(110 10 104 7), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(116 16 110 10), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(119 20 116 16), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(122 28 119 20), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(123 32 122 28), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(123 68 123 32), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(220 68 123 68), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(386 129 386 104), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(386 104 375 99), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(375 99 363 92), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(353 85 363 92), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(220 68 220 34), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(337 70 352 56), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(352 56 358 48), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(358 48 363 39), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(363 39 365 29), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(365 29 348 25), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(348 25 335 22), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(335 22 321 14), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(321 14 300 5), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(300 5 283 1), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(283 1 260 0), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(260 0 246 0), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(246 0 242 2), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(242 2 236 4), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(236 4 231 8), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(231 8 227 13), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(223 17 227 13), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(221 22 223 17), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(220 34 221 22), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(340 360 335 363), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(335 363 331 365), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(331 365 326 366), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(326 366 304 366), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(304 355 304 366), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(395 288 400 288), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(404 288 400 288), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(409 290 404 288), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(413 292 409 290), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(418 297 413 292), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(421 302 418 297), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(422 309 421 302), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(421 318 422 309), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(421 318 417 325), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(417 325 411 330), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(411 330 405 332), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(405 332 397 333), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(397 333 344 333), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(344 333 340 334), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(340 334 336 336), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(336 336 335 338), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(335 338 332 342), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(331 347 332 342), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(332 351 331 347), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(334 354 332 351), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(336 357 334 354), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(341 359 336 357), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(341 359 340 360), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(395 288 395 278), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(304 355 258 355), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(347 80 344 76), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(344 76 337 70), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(349 82 347 80), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(351 84 349 82), -fill => $outline, -tags => ['floor1', 'bg']);
+ $w->create('line', qw(353 85 351 84), -fill => $outline, -tags => ['floor1', 'bg']);
+
+} # end floor_bg1
+
+sub floor_bg2 {
+
+ my ($w, $fill, $outline) = @_;
+
+ $w->create('poly', qw(559 129 484 129 484 162 398 162 398 129 315 129 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0
+ 339 0 391 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 484 280 484 311 508 311 508 327 558 327 558 391
+ 644 391 644 367 802 367 802 129 725 129 725 133 559 133 559 129), -tags => ['floor2', 'bg'], -fill => $fill);
+ $w->create('line', qw(350 311 350 329), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(398 129 398 162), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(802 367 802 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(802 129 725 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(725 133 725 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(559 129 559 133), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(559 133 725 133), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(484 162 484 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(559 129 484 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(802 367 644 367), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(644 367 644 391), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(644 391 558 391), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(558 327 558 391), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(558 327 508 327), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(508 327 508 311), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(484 311 508 311), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(484 280 484 311), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(398 162 484 162), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(484 280 395 280), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(395 280 395 311), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(258 387 60 387), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(3 133 3 339), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(3 339 0 339), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(60 391 0 391), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(0 339 0 391), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(60 387 60 391), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(258 329 258 387), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(350 329 258 329), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(395 311 350 311), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(398 129 315 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(176 133 315 133), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(176 129 96 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(3 133 96 133), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(315 133 315 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(176 133 176 129), -fill => $outline, -tags => ['floor2', 'bg']);
+ $w->create('line', qw(96 133 96 129), -fill => $outline, -tags => ['floor2', 'bg']);
+
+} # end floor_bg2
+
+sub floor_bg3 {
+
+ my ($w, $fill, $outline) = @_;
+
+ $w->create('poly', qw(159 300 107 300 107 248 159 248 159 129 96 129 96 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370
+ 159 300), -tags => ['floor3', 'bg'], -fill => $fill);
+ $w->create('poly', qw(258 370 258 329 350 329 350 311 399 311 399 129 315 129 315 133 176 133 176 129 159 129 159 370 258
+ 370), -tags =>['floor3', 'bg'], -fill => $fill);
+ $w->create('line', qw(96 133 96 129), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(176 129 96 129), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(176 129 176 133), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(315 133 176 133), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(315 133 315 129), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(399 129 315 129), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(399 311 399 129), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(399 311 350 311), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(350 329 350 311), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(350 329 258 329), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(258 370 258 329), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(60 370 258 370), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(60 370 60 391), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(60 391 0 391), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(0 391 0 331), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(21 331 0 331), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(21 331 21 133), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(96 133 21 133), -fill => $outline, -tags => ['floor3', 'bg']);
+ $w->create('line', qw(107 300 159 300 159 248 107 248 107 300), -fill => $outline, -tags => ['floor3', 'bg']);
+
+} # end floor_bg3
+
+sub floor_fg1 {
+
+ my($w, $color, $fl, $fi) = @_;
+
+ my($i);
+ $i = $w->create('polygon', qw(375 246 375 172 341 172 341 246), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 101;
+ $fi->{101} = $i;
+ $w->create('text', qw(358 209), -text => '101', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(307 240 339 240 339 206 307 206), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'Pub Lift1';
+ $fi->{'Pub Lift1'} = $i;
+ $w->create('text', qw(323 223), -text => 'Pub Lift1', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(339 205 307 205 307 171 339 171), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'Priv Lift1';
+ $fi->{'Priv Lift1'} = $i;
+ $w->create('text', qw(323 188), -text => 'Priv Lift1', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(42 389 42 337 1 337 1 389), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 110;
+ $fi->{110} = $i;
+ $w->create('text', qw(21.5 363), -text => '110', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(59 389 59 385 90 385 90 337 44 337 44 389), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 109;
+ $fi->{109} = $i;
+ $w->create('text', qw(67 363), -text => '109', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(51 300 51 253 6 253 6 300), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 111;
+ $fi->{111} = $i;
+ $w->create('text', qw(28.5 276.5), -text => '111', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(98 248 98 309 79 309 79 248), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = '117B';
+ $fi->{'117B'} = $i;
+ $w->create('text', qw(88.5 278.5), -text => '117B', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(51 251 51 204 6 204 6 251), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 112;
+ $fi->{112} = $i;
+ $w->create('text', qw(28.5 227.5), -text => '112', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(6 156 51 156 51 203 6 203), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 113;
+ $fi->{113} = $i;
+ $w->create('text', qw(28.5 179.5), -text => '113', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(85 169 79 169 79 192 85 192), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = '117A';
+ $fi->{'117A'} = $i;
+ $w->create('text', qw(82 180.5), -text => '117A', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(77 302 77 168 53 168 53 302), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 117;
+ $fi->{117} = $i;
+ $w->create('text', qw(65 235), -text => '117', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(51 155 51 115 6 115 6 155), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 114;
+ $fi->{114} = $i;
+ $w->create('text', qw(28.5 135), -text => '114', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(95 115 53 115 53 168 95 168), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 115;
+ $fi->{115} = $i;
+ $w->create('text', qw(74 141.5), -text => '115', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(87 113 87 27 10 27 10 113), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 116;
+ $fi->{116} = $i;
+ $w->create('text', qw(48.5 70), -text => '116', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(89 91 128 91 128 113 89 113), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 118;
+ $fi->{118} = $i;
+ $w->create('text', qw(108.5 102), -text => '118', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 120;
+ $fi->{120} = $i;
+ $w->create('text', qw(189.5 111.5), -text => '120', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 122;
+ $fi->{122} = $i;
+ $w->create('text', qw(131 207.5), -text => '122', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(138 169 154 169 154 191 138 191), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 121;
+ $fi->{121} = $i;
+ $w->create('text', qw(146 180), -text => '121', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(99 300 126 300 126 309 99 309), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = '106A';
+ $fi->{'106A'} = $i;
+ $w->create('text', qw(112.5 304.5), -text => '106A', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(128 299 128 309 150 309 150 248 99 248 99 299), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 105;
+ $fi->{105} = $i;
+ $w->create('text', qw(124.5 278.5), -text => '105', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(174 309 174 300 152 300 152 309), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = '106B';
+ $fi->{'106B'} = $i;
+ $w->create('text', qw(163 304.5), -text => '106B', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(176 299 176 309 216 309 216 248 152 248 152 299), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 104;
+ $fi->{104} = $i;
+ $w->create('text', qw(184 278.5), -text => '104', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(138 385 138 337 91 337 91 385), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 108;
+ $fi->{108} = $i;
+ $w->create('text', qw(114.5 361), -text => '108', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(256 337 140 337 140 385 256 385), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 107;
+ $fi->{107} = $i;
+ $w->create('text', qw(198 361), -text => '107', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(300 353 300 329 260 329 260 353), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'Smoking';
+ $fi->{Smoking} = $i;
+ $w->create('text', qw(280 341), -text => 'Smoking', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(314 135 314 170 306 170 306 246 177 246 177 135), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 123;
+ $fi->{123} = $i;
+ $w->create('text', qw(245.5 190.5), -text => '123', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(217 248 301 248 301 326 257 326 257 310 217 310), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 103;
+ $fi->{103} = $i;
+ $w->create('text', qw(259 287), -text => '103', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(396 188 377 188 377 169 316 169 316 131 396 131), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 124;
+ $fi->{124} = $i;
+ $w->create('text', qw(356 150), -text => '124', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(397 226 407 226 407 189 377 189 377 246 397 246), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 125;
+ $fi->{125} = $i;
+ $w->create('text', qw(392 217.5), -text => '125', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(399 187 409 187 409 207 474 207 474 164 399 164), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 126;
+ $fi->{126} = $i;
+ $w->create('text', qw(436.5 185.5), -text => '126', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 127;
+ $fi->{127} = $i;
+ $w->create('text', qw(436.5 231), -text => '127', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'MShower';
+ $fi->{MShower} = $i;
+ $w->create('text', qw(488.5 184), -text => 'MShower', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(497 176 513 176 513 204 492 204 492 190 497 190), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'Closet';
+ $fi->{Closet} = $i;
+ $w->create('text', qw(502.5 190), -text => 'Closet', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(476 237 476 206 513 206 513 254 488 254 488 237), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'WShower';
+ $fi->{WShower} = $i;
+ $w->create('text', qw(494.5 230), -text => 'WShower', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 130;
+ $fi->{130} = $i;
+ $w->create('text', qw(638.5 205), -text => '130', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 102;
+ $fi->{102} = $i;
+ $w->create('text', qw(367.5 278.5), -text => '102', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(397 255 486 255 486 276 397 276), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 128;
+ $fi->{128} = $i;
+ $w->create('text', qw(441.5 265.5), -text => '128', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 129;
+ $fi->{129} = $i;
+ $w->create('text', qw(535.5 293), -text => '129', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 133;
+ $fi->{133} = $i;
+ $w->create('text', qw(628.5 335), -text => '133', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(742 387 742 281 800 281 800 387), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 132;
+ $fi->{132} = $i;
+ $w->create('text', qw(771 334), -text => '132', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(800 168 800 280 699 280 699 168), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 134;
+ $fi->{134} = $i;
+ $w->create('text', qw(749.5 224), -text => '134', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(726 131 726 166 800 166 800 131), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 135;
+ $fi->{135} = $i;
+ $w->create('text', qw(763 148.5), -text => '135', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'Ramona Stair';
+ $fi->{'Ramona Stair'} = $i;
+ $w->create('text', qw(368 323), -text => 'Ramona Stair', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'University Stair';
+ $fi->{'University Stair'} = $i;
+ $w->create('text', qw(155 77.5), -text => 'University Stair', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'Plaza Stair';
+ $fi->{'Plaza Stair'} = $i;
+ $w->create('text', qw(317.5 28.5), -text => 'Plaza Stair', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 'Plaza Deck';
+ $fi->{'Plaza Deck'} = $i;
+ $w->create('text', qw(303 81), -text => 'Plaza Deck', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(257 336 77 336 6 336 6 301 77 301 77 310 257 310), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 106;
+ $fi->{106} = $i;
+ $w->create('text', qw(131.5 318.5), -text => '106', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $i = $w->create('polygon', qw(146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131), -fill => undef, -tags => ['floor1', 'room']);
+ $fl->{$i} = 119;
+ $fi->{119} = $i;
+ $w->create('text', qw(143.5 133), -text => '119', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']);
+ $w->create('line', qw(155 191 155 189), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(155 177 155 169), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(96 129 96 169), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(78 169 176 169), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(176 247 176 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(340 206 307 206), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(340 187 340 170), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(340 210 340 201), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(340 247 340 224), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(340 241 307 241), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(376 246 376 170), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(307 247 307 170), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(376 170 307 170), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(315 129 315 170), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(147 129 176 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(202 133 176 133), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(398 129 315 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(258 352 258 387), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(60 387 60 391), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(0 337 0 391), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(60 391 0 391), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(3 114 3 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(258 387 60 387), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 237 52 273), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 189 52 225), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 140 52 177), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(395 306 395 311), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(531 254 398 254), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(475 178 475 238), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(502 162 398 162), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(398 129 398 188), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(383 188 376 188), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(408 188 408 194), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(398 227 398 254), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(408 227 398 227), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(408 222 408 227), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(408 206 408 210), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(408 208 475 208), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(484 278 484 311), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(484 311 508 311), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(508 327 508 311), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(559 327 508 327), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(644 391 559 391), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(644 389 644 391), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(514 205 475 205), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(496 189 496 187), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(559 129 484 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(484 162 484 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(725 133 559 133), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(559 129 559 133), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(725 149 725 167), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(725 129 802 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(802 389 802 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(739 167 802 167), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(396 188 408 188), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(0 337 9 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(58 337 21 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(43 391 43 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(105 337 75 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(91 387 91 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(154 337 117 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(139 387 139 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(227 337 166 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(258 337 251 337), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(258 328 302 328), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(302 355 302 311), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(395 311 302 311), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(484 278 395 278), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(395 294 395 278), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(473 278 473 275), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(473 256 473 254), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(533 257 531 254), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(553 276 551 274), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(698 276 553 276), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(559 391 559 327), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(802 389 644 389), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(741 314 741 389), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(698 280 698 167), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(707 280 698 280), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(802 280 731 280), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(741 280 741 302), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(698 167 727 167), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(725 137 725 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(514 254 514 175), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(496 175 514 175), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(502 175 502 162), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(475 166 475 162), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(496 176 496 175), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(491 189 496 189), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(491 205 491 189), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(487 238 475 238), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(487 240 487 238), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(487 252 487 254), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(315 133 304 133), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(256 133 280 133), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(78 247 270 247), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(307 247 294 247), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(214 133 232 133), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(217 247 217 266), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(217 309 217 291), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(217 309 172 309), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(154 309 148 309), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(175 300 175 309), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(151 300 175 300), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(151 247 151 309), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(78 237 78 265), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(78 286 78 309), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(106 309 78 309), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(130 309 125 309), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(99 309 99 247), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(127 299 99 299), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(127 309 127 299), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(155 191 137 191), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(137 169 137 191), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(78 171 78 169), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(78 190 78 218), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(86 192 86 169), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(86 192 78 192), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 301 3 301), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 286 52 301), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 252 3 252), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 203 3 203), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(3 156 52 156), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(8 25 8 114), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(63 114 3 114), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(75 114 97 114), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(108 114 129 114), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(129 114 129 89), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(52 114 52 128), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(132 89 88 89), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(88 25 88 89), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(88 114 88 89), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(218 89 144 89), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(147 111 147 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(162 111 147 111), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(162 109 162 111), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(162 96 162 89), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(218 89 218 94), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(218 89 218 119), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(8 25 88 25), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(258 337 258 328), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(113 129 96 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(302 355 258 355), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(386 104 386 129), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(377 100 386 104), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(365 94 377 100), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(350 83 365 94), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(337 70 350 83), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(337 70 323 56), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(312 49 323 56), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(295 40 312 49), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(282 37 295 40), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(260 34 282 37), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(253 34 260 34), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(386 128 386 104), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(113 152 156 152), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(113 152 156 152), -fill => $color, -tags => ['floor1', 'wall']);
+ $w->create('line', qw(113 152 113 129), -fill => $color, -tags => ['floor1', 'wall']);
+
+} # end floor_fg1;
+
+sub floor_fg2 {;
+
+ my($w, $color, $fl, $fi) = @_;
+
+ my($i);
+ $i = $w->create('polygon', qw(748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 238;
+ $fi->{238} = $i;
+ $w->create('text', qw(774 195), -text => '238', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(726 188 746 188 746 166 800 166 800 131 726 131), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 237;
+ $fi->{237} = $i;
+ $w->create('text', qw(763 148.5), -text => '237', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 246;
+ $fi->{246} = $i;
+ $w->create('text', qw(600 264), -text => '246', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(694 279 643 279 643 314 694 314), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 247;
+ $fi->{247} = $i;
+ $w->create('text', qw(668.5 296.5), -text => '247', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 202;
+ $fi->{202} = $i;
+ $w->create('text', qw(285.5 260), -text => '202', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 206;
+ $fi->{206} = $i;
+ $w->create('text', qw(143 267), -text => '206', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(51 277 6 277 6 338 51 338), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 212;
+ $fi->{212} = $i;
+ $w->create('text', qw(28.5 307.5), -text => '212', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(557 276 486 276 486 309 510 309 510 325 557 325), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 245;
+ $fi->{245} = $i;
+ $w->create('text', qw(521.5 300.5), -text => '245', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(560 389 599 389 599 326 560 326), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 244;
+ $fi->{244} = $i;
+ $w->create('text', qw(579.5 357.5), -text => '244', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(601 389 601 326 643 326 643 389), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 243;
+ $fi->{243} = $i;
+ $w->create('text', qw(622 357.5), -text => '243', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(688 316 645 316 645 365 688 365), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 242;
+ $fi->{242} = $i;
+ $w->create('text', qw(666.5 340.5), -text => '242', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(802 367 759 367 759 226 802 226), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 'Barbecue Deck';
+ $fi->{'Barbecue Deck'} = $i;
+ $w->create('text', qw(780.5 296.5), -text => 'Barbecue Deck', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(755 262 755 314 717 314 717 262), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 240;
+ $fi->{240} = $i;
+ $w->create('text', qw(736 288), -text => '240', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(755 316 689 316 689 365 755 365), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 241;
+ $fi->{241} = $i;
+ $w->create('text', qw(722 340.5), -text => '241', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(755 206 717 206 717 261 755 261), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 239;
+ $fi->{239} = $i;
+ $w->create('text', qw(736 233.5), -text => '239', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(695 277 643 277 643 206 695 206), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 248;
+ $fi->{248} = $i;
+ $w->create('text', qw(669 241.5), -text => '248', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(676 135 676 185 724 185 724 135), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 236;
+ $fi->{236} = $i;
+ $w->create('text', qw(700 160), -text => '236', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(675 135 635 135 635 145 628 145 628 185 675 185), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 235;
+ $fi->{235} = $i;
+ $w->create('text', qw(651.5 160), -text => '235', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 234;
+ $fi->{234} = $i;
+ $w->create('text', qw(606 160), -text => '234', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 233;
+ $fi->{233} = $i;
+ $w->create('text', qw(552.5 158), -text => '233', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(476 249 557 249 557 205 476 205), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 230;
+ $fi->{230} = $i;
+ $w->create('text', qw(516.5 227), -text => '230', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(476 164 486 164 486 131 525 131 525 185 476 185), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 232;
+ $fi->{232} = $i;
+ $w->create('text', qw(500.5 158), -text => '232', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(476 186 495 186 495 204 476 204), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 229;
+ $fi->{229} = $i;
+ $w->create('text', qw(485.5 195), -text => '229', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(474 207 409 207 409 187 399 187 399 164 474 164), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 227;
+ $fi->{227} = $i;
+ $w->create('text', qw(436.5 185.5), -text => '227', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(399 228 399 253 474 253 474 209 409 209 409 228), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 228;
+ $fi->{228} = $i;
+ $w->create('text', qw(436.5 231), -text => '228', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(397 246 397 226 407 226 407 189 377 189 377 246), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 226;
+ $fi->{226} = $i;
+ $w->create('text', qw(392 217.5), -text => '226', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(377 169 316 169 316 131 397 131 397 188 377 188), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 225;
+ $fi->{225} = $i;
+ $w->create('text', qw(356.5 150), -text => '225', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(234 198 306 198 306 249 234 249), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 224;
+ $fi->{224} = $i;
+ $w->create('text', qw(270 223.5), -text => '224', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(270 179 306 179 306 170 314 170 314 135 270 135), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 223;
+ $fi->{223} = $i;
+ $w->create('text', qw(292 157), -text => '223', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(268 179 221 179 221 135 268 135), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 222;
+ $fi->{222} = $i;
+ $w->create('text', qw(244.5 157), -text => '222', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(177 179 219 179 219 135 177 135), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 221;
+ $fi->{221} = $i;
+ $w->create('text', qw(198 157), -text => '221', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(299 327 349 327 349 284 341 284 341 276 299 276), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 204;
+ $fi->{204} = $i;
+ $w->create('text', qw(324 301.5), -text => '204', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(234 276 297 276 297 327 257 327 257 338 234 338), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 205;
+ $fi->{205} = $i;
+ $w->create('text', qw(265.5 307), -text => '205', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(256 385 256 340 212 340 212 385), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 207;
+ $fi->{207} = $i;
+ $w->create('text', qw(234 362.5), -text => '207', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(210 340 164 340 164 385 210 385), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 208;
+ $fi->{208} = $i;
+ $w->create('text', qw(187 362.5), -text => '208', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(115 340 162 340 162 385 115 385), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 209;
+ $fi->{209} = $i;
+ $w->create('text', qw(138.5 362.5), -text => '209', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(89 228 89 156 53 156 53 228), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 217;
+ $fi->{217} = $i;
+ $w->create('text', qw(71 192), -text => '217', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(89 169 97 169 97 190 89 190), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = '217A';
+ $fi->{'217A'} = $i;
+ $w->create('text', qw(93 179.5), -text => '217A', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(89 156 89 168 95 168 95 135 53 135 53 156), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 216;
+ $fi->{216} = $i;
+ $w->create('text', qw(71 145.5), -text => '216', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(51 179 51 135 6 135 6 179), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 215;
+ $fi->{215} = $i;
+ $w->create('text', qw(28.5 157), -text => '215', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(51 227 6 227 6 180 51 180), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 214;
+ $fi->{214} = $i;
+ $w->create('text', qw(28.5 203.5), -text => '214', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(51 275 6 275 6 229 51 229), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 213;
+ $fi->{213} = $i;
+ $w->create('text', qw(28.5 252), -text => '213', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(114 340 67 340 67 385 114 385), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 210;
+ $fi->{210} = $i;
+ $w->create('text', qw(90.5 362.5), -text => '210', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(59 389 59 385 65 385 65 340 1 340 1 389), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 211;
+ $fi->{211} = $i;
+ $w->create('text', qw(33 364.5), -text => '211', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(393 309 350 309 350 282 342 282 342 276 393 276), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 203;
+ $fi->{203} = $i;
+ $w->create('text', qw(367.5 292.5), -text => '203', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 220;
+ $fi->{220} = $i;
+ $w->create('text', qw(132.5 208.5), -text => '220', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(339 205 307 205 307 171 339 171), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 'Priv Lift2';
+ $fi->{'Priv Lift2'} = $i;
+ $w->create('text', qw(323 188), -text => 'Priv Lift2', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(307 240 339 240 339 206 307 206), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 'Pub Lift2';
+ $fi->{'Pub Lift2'} = $i;
+ $w->create('text', qw(323 223), -text => 'Pub Lift2', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(175 168 97 168 97 131 175 131), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 218;
+ $fi->{218} = $i;
+ $w->create('text', qw(136 149.5), -text => '218', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(154 191 111 191 111 169 154 169), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 219;
+ $fi->{219} = $i;
+ $w->create('text', qw(132.5 180), -text => '219', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $i = $w->create('polygon', qw(375 246 375 172 341 172 341 246), -fill => undef, -tags => ['floor2', 'room']);
+ $fl->{$i} = 201;
+ $fi->{201} = $i;
+ $w->create('text', qw(358 209), -text => '201', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']);
+ $w->create('line', qw(641 186 678 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 350 757 367), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(634 133 634 144), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(634 144 627 144), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(572 133 572 144), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(572 144 579 144), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(398 129 398 162), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(174 197 175 197), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(175 197 175 227), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 206 757 221), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(396 188 408 188), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(727 189 725 189), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(747 167 802 167), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(747 167 747 189), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(755 189 739 189), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(769 224 757 224), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(802 224 802 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(802 129 725 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(725 189 725 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(725 186 690 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(676 133 676 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(627 144 627 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(629 186 593 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(579 144 579 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(559 129 559 133), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(725 133 559 133), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(484 162 484 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(559 129 484 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(526 129 526 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(540 186 581 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(528 186 523 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(511 186 475 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(496 190 496 186), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(496 205 496 202), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(475 205 527 205), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(558 205 539 205), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(558 205 558 249), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(558 249 475 249), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(662 206 642 206), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(695 206 675 206), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(695 278 642 278), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(642 291 642 206), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(695 291 695 206), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(716 208 716 206), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 206 716 206), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 221 757 224), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(793 224 802 224), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 262 716 262), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(716 220 716 264), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(716 315 716 276), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 315 703 315), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 325 757 224), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(757 367 644 367), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(689 367 689 315), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(647 315 644 315), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(659 315 691 315), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(600 325 600 391), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(627 325 644 325), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(644 391 644 315), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(615 325 575 325), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(644 391 558 391), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(563 325 558 325), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(558 391 558 314), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(558 327 508 327), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(558 275 484 275), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(558 302 558 275), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(508 327 508 311), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(484 311 508 311), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(484 275 484 311), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(475 208 408 208), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(408 206 408 210), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(408 222 408 227), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(408 227 398 227), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(398 227 398 254), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(408 188 408 194), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(383 188 376 188), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(398 188 398 162), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(398 162 484 162), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(475 162 475 254), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(398 254 475 254), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(484 280 395 280), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(395 311 395 275), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(307 197 293 197), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(278 197 233 197), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(233 197 233 249), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(307 179 284 179), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(233 249 278 249), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(269 179 269 133), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(220 179 220 133), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(155 191 110 191), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(90 190 98 190), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(98 169 98 190), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(52 133 52 165), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(52 214 52 177), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(52 226 52 262), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(52 274 52 276), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(234 275 234 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(226 339 258 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(211 387 211 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(214 339 177 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(258 387 60 387), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(3 133 3 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(165 339 129 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(117 339 80 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(68 339 59 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(0 339 46 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(60 391 0 391), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(0 339 0 391), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(60 387 60 391), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(258 329 258 387), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(350 329 258 329), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(395 311 350 311), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(398 129 315 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(176 133 315 133), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(176 129 96 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(3 133 96 133), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(66 387 66 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(115 387 115 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(163 387 163 339), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(234 275 276 275), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(288 275 309 275), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(298 275 298 329), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(341 283 350 283), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(321 275 341 275), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(375 275 395 275), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(315 129 315 170), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(376 170 307 170), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(307 250 307 170), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(376 245 376 170), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(340 241 307 241), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(340 245 340 224), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(340 210 340 201), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(340 187 340 170), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(340 206 307 206), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(293 250 307 250), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(271 179 238 179), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(226 179 195 179), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(176 129 176 179), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(182 179 176 179), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(174 169 176 169), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(162 169 90 169), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(96 169 96 129), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(175 227 90 227), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(90 190 90 227), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(52 179 3 179), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(52 228 3 228), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(52 276 3 276), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(155 177 155 169), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(110 191 110 169), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(155 189 155 197), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(350 283 350 329), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(162 197 155 197), -fill => $color, -tags => ['floor2', 'wall']);
+ $w->create('line', qw(341 275 341 283), -fill => $color, -tags => ['floor2', 'wall']);
+
+} # end floor_fg2;
+
+sub floor_fg3 {;
+
+ my($w, $color, $fl, $fi) = @_;
+
+ my($i);
+ $i = $w->create('polygon', qw(89 228 89 180 70 180 70 228), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 316;
+ $fi->{316} = $i;
+ $w->create('text', qw(79.5 204), -text => '316', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(115 368 162 368 162 323 115 323), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 309;
+ $fi->{309} = $i;
+ $w->create('text', qw(138.5 345.5), -text => '309', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(164 323 164 368 211 368 211 323), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 308;
+ $fi->{308} = $i;
+ $w->create('text', qw(187.5 345.5), -text => '308', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(256 368 212 368 212 323 256 323), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 307;
+ $fi->{307} = $i;
+ $w->create('text', qw(234 345.5), -text => '307', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(244 276 297 276 297 327 260 327 260 321 244 321), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 305;
+ $fi->{305} = $i;
+ $w->create('text', qw(270.5 301.5), -text => '305', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(251 219 251 203 244 203 244 219), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = '324B';
+ $fi->{'324B'} = $i;
+ $w->create('text', qw(247.5 211), -text => '324B', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(251 249 244 249 244 232 251 232), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = '324A';
+ $fi->{'324A'} = $i;
+ $w->create('text', qw(247.5 240.5), -text => '324A', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(223 135 223 179 177 179 177 135), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 320;
+ $fi->{320} = $i;
+ $w->create('text', qw(200 157), -text => '320', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(114 368 114 323 67 323 67 368), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 310;
+ $fi->{310} = $i;
+ $w->create('text', qw(90.5 345.5), -text => '310', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(23 277 23 321 68 321 68 277), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 312;
+ $fi->{312} = $i;
+ $w->create('text', qw(45.5 299), -text => '312', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(23 229 68 229 68 275 23 275), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 313;
+ $fi->{313} = $i;
+ $w->create('text', qw(45.5 252), -text => '313', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(68 227 23 227 23 180 68 180), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 314;
+ $fi->{314} = $i;
+ $w->create('text', qw(45.5 203.5), -text => '314', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(95 179 95 135 23 135 23 179), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 315;
+ $fi->{315} = $i;
+ $w->create('text', qw(59 157), -text => '315', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(99 226 99 204 91 204 91 226), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = '316B';
+ $fi->{'316B'} = $i;
+ $w->create('text', qw(95 215), -text => '316B', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(91 202 99 202 99 180 91 180), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = '316A';
+ $fi->{'316A'} = $i;
+ $w->create('text', qw(95 191), -text => '316A', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 319;
+ $fi->{319} = $i;
+ $w->create('text', qw(141.5 209), -text => '319', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 311;
+ $fi->{311} = $i;
+ $w->create('text', qw(29.5 361), -text => '311', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(154 191 111 191 111 169 154 169), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 318;
+ $fi->{318} = $i;
+ $w->create('text', qw(132.5 180), -text => '318', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(175 168 97 168 97 131 175 131), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 317;
+ $fi->{317} = $i;
+ $w->create('text', qw(136 149.5), -text => '317', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(274 194 274 221 306 221 306 194), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 323;
+ $fi->{323} = $i;
+ $w->create('text', qw(290 207.5), -text => '323', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(306 222 274 222 274 249 306 249), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 325;
+ $fi->{325} = $i;
+ $w->create('text', qw(290 235.5), -text => '325', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(263 179 224 179 224 135 263 135), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 321;
+ $fi->{321} = $i;
+ $w->create('text', qw(243.5 157), -text => '321', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(314 169 306 169 306 192 273 192 264 181 264 135 314 135), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 322;
+ $fi->{322} = $i;
+ $w->create('text', qw(293.5 163.5), -text => '322', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(307 240 339 240 339 206 307 206), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 'Pub Lift3';
+ $fi->{'Pub Lift3'} = $i;
+ $w->create('text', qw(323 223), -text => 'Pub Lift3', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(339 205 307 205 307 171 339 171), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 'Priv Lift3';
+ $fi->{'Priv Lift3'} = $i;
+ $w->create('text', qw(323 188), -text => 'Priv Lift3', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(350 284 376 284 376 276 397 276 397 309 350 309), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 303;
+ $fi->{303} = $i;
+ $w->create('text', qw(373.5 292.5), -text => '303', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 324;
+ $fi->{324} = $i;
+ $w->create('text', qw(262 226), -text => '324', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(299 276 299 327 349 327 349 284 341 284 341 276), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 304;
+ $fi->{304} = $i;
+ $w->create('text', qw(324 301.5), -text => '304', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(375 246 375 172 341 172 341 246), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 301;
+ $fi->{301} = $i;
+ $w->create('text', qw(358 209), -text => '301', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(397 246 377 246 377 185 397 185), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 327;
+ $fi->{327} = $i;
+ $w->create('text', qw(387 215.5), -text => '327', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(316 131 316 169 377 169 377 185 397 185 397 131), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 326;
+ $fi->{326} = $i;
+ $w->create('text', qw(356.5 150), -text => '326', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 302;
+ $fi->{302} = $i;
+ $w->create('text', qw(319.5 261), -text => '302', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $i = $w->create('polygon', qw(70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275), -fill => undef, -tags => ['floor3', 'room']);
+ $fl->{$i} = 306;
+ $fi->{306} = $i;
+ $w->create('text', qw(200.5 284.5), -text => '306', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']);
+ $w->create('line', qw(341 275 341 283), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(162 197 155 197), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(396 247 399 247), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(399 129 399 311), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(258 202 243 202), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(350 283 350 329), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(251 231 243 231), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(243 220 251 220), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(243 250 243 202), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(155 197 155 190), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(110 192 110 169), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(155 192 110 192), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(155 177 155 169), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(176 197 176 227), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(69 280 69 274), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(21 276 69 276), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(69 262 69 226), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(21 228 69 228), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(21 179 75 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(69 179 69 214), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(90 220 90 227), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(90 204 90 202), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(90 203 100 203), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(90 187 90 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(90 227 176 227), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(100 179 100 227), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(100 179 87 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(96 179 96 129), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(162 169 96 169), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(173 169 176 169), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(182 179 176 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(176 129 176 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(195 179 226 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(224 133 224 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(264 179 264 133), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(238 179 264 179), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(273 207 273 193), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(273 235 273 250), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(273 224 273 219), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(273 193 307 193), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(273 222 307 222), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(273 250 307 250), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(384 247 376 247), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(340 206 307 206), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(340 187 340 170), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(340 210 340 201), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(340 247 340 224), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(340 241 307 241), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(376 247 376 170), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(307 250 307 170), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(376 170 307 170), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(315 129 315 170), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(376 283 366 283), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(376 283 376 275), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(399 275 376 275), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(341 275 320 275), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(341 283 350 283), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(298 275 298 329), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(308 275 298 275), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(243 322 243 275), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(243 275 284 275), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(258 322 226 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(212 370 212 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(214 322 177 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(163 370 163 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(165 322 129 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(84 322 117 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(71 322 64 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(115 322 115 370), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(66 322 66 370), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(52 322 21 322), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(21 331 0 331), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(21 331 21 133), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(96 133 21 133), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(176 129 96 129), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(315 133 176 133), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(315 129 399 129), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(399 311 350 311), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(350 329 258 329), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(258 322 258 370), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(60 370 258 370), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(60 370 60 391), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(0 391 0 331), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(60 391 0 391), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(307 250 307 242), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(273 250 307 250), -fill => $color, -tags => ['floor3', 'wall']);
+ $w->create('line', qw(258 250 243 250), -fill => $color, -tags => ['floor3', 'wall']);
+
+} # end floor_fg3;
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form.pl
new file mode 100755
index 00000000000..bd60ef91475
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form.pl
@@ -0,0 +1,31 @@
+# form.pl
+
+use vars qw/$TOP/;
+
+sub form {
+
+ # Create a top-level window that displays a bunch of entries with
+ # tabs set up to move between them.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries.',
+ -title => 'Form Demonstration',
+ -iconname => 'form',
+ );
+ my $f = $TOP->Frame->pack(-fill => 'both');
+ my $row = 0;
+ foreach ('Name:', 'Address:', '', '', 'Phone:') {
+ my $e = $f->Entry(qw/-relief sunken -width 40/);
+ my $l = $f->Label(-text => $_, -anchor => 'e', -justify => 'right');
+ $l->grid(-row => $row, -column => 0, -sticky => 'e');
+ $e->grid(-row => $row++, -column => 1,-sticky => 'ew');
+ $f->gridRowconfigure(1,-weight => 1);
+ $e->focus if $_ eq 'Name:';
+ }
+ $TOP->bind('<Return>' => [$TOP => 'destroy']);
+
+} # end form
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form_mgr.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form_mgr.pl
new file mode 100755
index 00000000000..1a328f94c53
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form_mgr.pl
@@ -0,0 +1,21 @@
+# Form, window management by Tix->form.
+
+use Tk;
+
+my $Main = MainWindow->new();
+
+my $box4 = $Main->Label(-text => 'box4', -borderwidth => 1, -relief => "raised");
+my $box1 = $Main->Label(-text => 'box1',-borderwidth => 1, -relief => "raised");
+my $box2 = $Main->Label(-text => 'box2',-borderwidth => 1, -relief => "raised");
+my $box3 = $Main->Label(-text => 'box3',-borderwidth => 1, -relief => "raised");
+
+$box1->form(-top => '%0', -left => '%0', -right => '%100');
+$box2->form(-top => $box1, -left => '%0', -right => '%50', -bottom =>
+$box4);
+$box3->form(-top => $box1, -left => $box2, -right => '%100', -bottom =>
+$box4);
+$box4->form(-left => '%0', -right => '%100', -bottom => '%100');
+
+MainLoop;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hello.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hello.pl
new file mode 100755
index 00000000000..08b1a8b52ec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hello.pl
@@ -0,0 +1,51 @@
+# hello.pl
+
+use Config;
+use Tk::widgets qw/ ROText /;
+use vars qw/ $TOP /;
+use strict;
+
+sub hello {
+
+ my( $demo ) = @_;
+
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => [ "This demonstration describes the basics of Perl/Tk programming. Besides this small user guide, there are various FAQs and other resources and tutorials available on the web, such as:
+
+http://phaseit.net/claird/comp.lang.perl.tk/ptkFAQ.html
+http://www.perltk.org
+http://user.cs.tu-berlin.de/~eserte
+http://www.lehigh.edu/sol0/ptk
+", -wraplength => '7i' ],
+ -title => 'Perl/Tk User Guide',
+ -iconname => 'hello',
+ );
+
+ # Pipe perldoc help output via fileevent() into a Scrolled ROText widget.
+
+ my $t = $TOP->Scrolled(
+ qw/ ROText -width 80 -height 25 -wrap none -scrollbars osoe/,
+ );
+ $t->focus;
+ my $cmd = $Config{installbin} . '/perldoc -t Tk::UserGuide';
+ $t->pack( qw/ -expand 1 -fill both / );
+
+ open( H, "$cmd|" ) or die "Cannot get pTk user guide: $!";
+ $TOP->fileevent( \*H, 'readable' => [ \&hello_fill, $t ] );
+
+} # end hello
+
+sub hello_fill {
+
+ my( $t ) = @_;
+
+ my $stat = sysread H, my $data, 4096;
+ die "sysread error: $!" unless defined $stat;
+ if( $stat == 0 ) { # EOF
+ $TOP->fileevent( \*H, 'readable' => '' );
+ return;
+ }
+ $t->insert( 'end', $data );
+
+} # end hello_fill
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hscale.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hscale.pl
new file mode 100755
index 00000000000..dcfd1437139
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hscale.pl
@@ -0,0 +1,48 @@
+# hscale.pl
+
+use subs qw /hscale_width/;
+use vars qw/$TOP/;
+
+sub hscale {
+
+ # Create a top-level window that displays a horizontal scale.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow.',
+ -title => 'Horizontal Scale Demonstration',
+ -iconname => 'hscale',
+ );
+
+ my $frame = $TOP->Frame(-borderwidth => 10)->pack(qw/-side top -fill x/);
+
+ my $canvas = $frame->Canvas(
+ qw/width 50 -height 50 -bd 0 -highlightthickness 0/);
+ $canvas->createPolygon(qw/0 0 1 1 2 2 -fill DeepSkyBlue3 -tags poly/);
+ $canvas->createLine (qw/0 0 1 1 2 2 0 0 -fill black -tags line/);
+
+ my $scale = $frame->Scale(qw/-orient horizontal -length 284 -from 0
+ -to 250 -tickinterval 50 -command/ => [\&hscale_width, $canvas]);
+ $scale->set(75);
+
+ $canvas->pack(qw/-side top -expand yes -anchor w -fill x/);
+ $scale->pack(qw/-side bottom -expand yes -anchor w/);
+
+} # end hscale
+
+sub hscale_width {
+
+ my($w, $width) = @_;
+
+ $width += 21;
+ my $x2 = $width - 30;
+ $x2 = 21 if $x2 < 21;
+ $w->coords('poly', 20, 15, 20, 35, $x2, 35, $x2, 45, $width, 25, $x2, 5,
+ $x2, 15, 20, 15);
+ $w->coords('line', 20, 15, 20, 35, $x2, 35, $x2, 45, $width, 25, $x2, 5,
+ $x2, 15, 20, 15);
+
+} # end hscale_width
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/icon.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/icon.pl
new file mode 100755
index 00000000000..876f1181baa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/icon.pl
@@ -0,0 +1,64 @@
+# icon.pl
+
+use vars qw/$TOP/;
+
+sub icon {
+
+ # Create a top-level window that displays a bunch of iconic buttons.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected.', qw/-wraplength 5i/],
+ -title => 'Iconic Button Demonstration',
+ -iconname => 'icon',
+ );
+
+ $TOP->Bitmap('flagup',
+ -file => Tk->findINC('demos/images/flagup'),
+ -maskfile => Tk->findINC('demos/images/flagup'),
+ );
+ $TOP->Bitmap('flagdown',
+ -file => Tk->findINC('demos/images/flagdown'),
+ -maskfile => Tk->findINC('demos/images/flagdown'),
+ );
+
+ my $frame = $TOP->Frame(qw/-borderwidth 10/);
+ $frame->pack(qw/-side top/);
+
+ my(@pl) = qw/-side left -expand yes -padx 5m/;
+ my $frame_left = $frame->Frame;
+ $frame_left->pack(@pl);
+
+ my $frame_b1 = $frame->Checkbutton(
+ -image => 'flagdown',
+ -selectimage => 'flagup',
+ -indicatoron => 0,
+ );
+ $frame_b1->pack(@pl);
+ $frame_b1->configure(-selectcolor => $frame_b1->cget(-background));
+ my $frame_b2 = $frame->Checkbutton(
+ -bitmap => '@' . Tk->findINC('demos/images/letters'),
+ -indicatoron => 0,
+ -selectcolor => 'SeaGreen1',
+ );
+ $frame_b2->pack(@pl);
+
+ my $letters = '';
+ @pl = qw/-side top -expand yes/;
+ my $frame_left_b3 = $frame_left->Radiobutton(
+ -bitmap => '@' . Tk->findINC('demos/images/letters'),
+ -variable => \$letters,
+ -value => 'full',
+ );
+ $frame_left_b3->pack(@pl);
+ my $frame_left_b4 = $frame_left->Radiobutton(
+ -bitmap => '@' . Tk->findINC('demos/images/noletters'),
+ -variable => \$letters,
+ -value => 'empty',
+ );
+ $frame_left_b4->pack(@pl);
+
+} # end icon
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image1.pl
new file mode 100755
index 00000000000..61e6ec61b77
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image1.pl
@@ -0,0 +1,28 @@
+# image1.pl
+
+use vars qw/$TOP/;
+
+sub image1 {
+
+ # This demonstration script displays two image widgets.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This demonstration displays two images, each in a separate label widget.',
+ -title => 'Image Demonstration #1',
+ -iconname => 'image1',
+ );
+
+ my(@pl) = qw/-side top -padx .5m -pady .5m/;
+ $TOP->Photo('image1a', -file => Tk->findINC('demos/images/earth.gif'));
+ $TOP->Label(-image => 'image1a')->pack(@pl);
+
+ $TOP->Photo('image1b', -file => Tk->findINC('demos/images/earthris.gif'));
+ $TOP->Label(-image => 'image1b')->pack(@pl);
+
+} # end image1
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image2.pl
new file mode 100755
index 00000000000..fd318895254
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image2.pl
@@ -0,0 +1,104 @@
+# image2.pl
+
+use File::Basename;
+use subs qw/image2_load_dir image2_load_image/;
+use vars qw/$TOP/;
+
+sub image2 {
+
+ # This demonstration script creates a simple collection of widgets
+ # that allow you to select and view images in a Tk label.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This demonstration allows you to view images using a Tk "photo" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image.',
+ -title => 'Image Demonstration #2',
+ -iconname => 'image2',
+ );
+
+ my $dir_label = $TOP->Label(-text => 'Directory:');
+ my $demo_img = Tk->findINC('demos/images');
+ my $dir_name = $TOP->Entry(-width => 30, -textvariable => \$demo_img);
+ my $frog0 = $TOP->Frame;
+ my $frog = $frog0->Frame;
+ my $file_label = $frog->Label(-text => 'File:');
+ my $f = $frog->Frame;
+ my(@pl) = qw/-side top -anchor w/;
+ $dir_label->pack(@pl);
+ $dir_name->pack(@pl);
+
+ # All these "frog" and "toad" frames are just to repackage the listbox
+ # and image side by side so they fit within an SVGA screen.
+
+ $frog0->pack;
+ $frog->pack(qw/-side left/);
+ my $toad = $frog0->Frame;
+ $toad->pack(qw/-side right/);
+ $file_label->pack(@pl);
+ $f->pack(@pl);
+
+ my $f_list = $f->Listbox(-width => 20, -height => 10);
+ $dir_name->bind('<Return>' => [\&image2_load_dir, $f_list, \$demo_img]);
+ my $f_scroll = $f->Scrollbar(-command => [$f_list => 'yview']);
+ $f_list->configure(-yscrollcommand => [$f_scroll => 'set']);
+ @pl = qw/-side left -fill y -expand 1/;
+ $f_list->pack(@pl);
+ $f_scroll->pack(@pl);
+ $f_list->insert(0, qw(earth.gif earthris.gif mickey.gif teapot.ppm));
+
+ my $image2a = $TOP->Photo;
+ $f_list->bind('<Double-1>' => [\&image2_load_image, $image2a, \$demo_img]);
+ my $image_label = $toad->Label(-text => 'Image:');
+ my $image = $toad->Label(-image => $image2a);
+ @pl = qw/-side top -anchor w/;
+ $image_label->pack(@pl);
+ $image->pack(@pl);
+
+} # end image2
+
+sub image2_load_dir {
+
+ # This procedure reloads the directory listbox from the directory
+ # named in the demo's entry.
+ #
+ # Arguments:
+ # e - Reference to entry widget.
+ # l - Reference to listbox widget.
+ # dir_name - Directory name reference.
+
+ my($e, $l, $dir_name) = @_;
+
+ $l->delete(0, 'end');
+ my $i;
+ local *DIR;
+ opendir DIR, $$dir_name;
+ foreach $i (sort readdir DIR) {
+ $l->insert('end', $i);
+ }
+ closedir DIR;
+
+} # end image2_load_dir
+
+sub image2_load_image {
+
+ # Given the name of the toplevel window of the demo and the mouse
+ # position, extracts the directory entry under the mouse and loads
+ # that file into a photo image for display.
+ #
+ # Arguments:
+ # l - Reference to listbox widget.
+ # i - Reference to image object.
+ # dir_name - Directory name reference.
+
+ my($l, $i, $dir_name) = @_;
+
+ my $e = $l->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $i->configure(-file => "$$dir_name/" . $l->get("\@$x,$y"));
+
+ # NOTE: $l->get('active') works just as well.
+
+} # end image2_load_image
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/items.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/items.pl
new file mode 100755
index 00000000000..c720821babb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/items.pl
@@ -0,0 +1,358 @@
+# items.pl
+
+use subs qw/items_button_press items_drag items_enter items_leave items_mark
+ items_start_drag items_stroke items_under_area/;
+use vars qw/$TOP/;
+
+sub items {
+
+ # Create a top-level window containing a canvas that displays the various
+ # item types and allows them to be selected and moved.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ["This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tdisplays items under area.", qw/-wraplength 5i/],
+ -title => 'Canvas Item Demonstration',
+ -iconname => 'items',
+ );
+
+ my $c = $TOP->Scrolled(qw/Canvas -width 15c -height 10c -relief sunken
+ -borderwidth 2 -scrollbars se -scrollregion/ =>
+ [qw/0c 0c 30c 24c/]);
+ $c->pack(qw/-expand yes -fill both/);
+
+ my %iinfo = (); # item information hash
+ $iinfo{areaX1} = 0;
+ $iinfo{areaY1} = 0;
+ $iinfo{areaX2} = 0;
+ $iinfo{areaY2} = 0;
+ $iinfo{restore_cmd} = '';
+
+
+ if ($Tk::VERSION cmp '800.015') {
+ # Display a 3x3 rectangular grid (800.016 or greater).
+ $c->createGrid(qw/0c 0c 10c 8c -width 2 -lines 1/);
+ $c->createGrid(qw/0c 0c 5c 4c -lines 1 -dash ./);
+ $c->createGrid(qw/0c 0c 10m 8m -width 1/);
+ } else {
+ # Display a 3x3 rectangular grid.
+ $c->createRectangle(qw/ 0c 0c 30c 24c -width 2/);
+ $c->createLine (qw/ 0c 8c 30c 8c -width 2/);
+ $c->createLine (qw/ 0c 16c 30c 16c -width 2/);
+ $c->createLine (qw/10c 0c 10c 24c -width 2/);
+ $c->createLine (qw/20c 0c 20c 24c -width 2/);
+ }
+
+ my $font1 = '-*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*';
+ my $font2 = '-*-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*';
+ my($blue, $red, $bisque, $green);
+ if ($TOP->depth > 1) {
+ $blue = 'DeepSkyBlue3';
+ $red = 'red';
+ $bisque = 'bisque3';
+ $green = 'SeaGreen3';
+ } else {
+ $blue = 'black';
+ $red = 'black';
+ $bisque = 'black';
+ $green = 'black';
+ }
+
+ # Set up demos within each of the areas of the grid.
+
+ $c->createText(qw/5c .2c -text Lines -anchor n/);
+ $c->createLine(qw/1c 1c 3c 1c 1c 4c 3c 4c -width 2m/, -fill => $blue,
+ qw/-cap butt -join miter -tags item/);
+ $c->createLine(qw/4.67c 1c 4.67c 4c -arrow last -activedash - -tags item/);
+ $c->createLine(qw/6.33c 1c 6.33c 4c -arrow both -activedash . -tags item/);
+ $c->createLine(qw/5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c
+ 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c
+ 8.4c 4.4c -width 3 -tags item -fill/ => $red);
+ $c->createLine(qw/1c 5c 7c 5c 7c 7c 9c 7c -width .5c/,
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ qw/-arrow both -tags item -arrowshape/ => [15, 15, 7]);
+ $c->createLine(qw/1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c
+ -cap round -join round -tags item/);
+
+ $c->createText(qw/15c .2c -anchor n -text/ => 'Curves (smoothed lines)');
+ $c->createLine(qw/11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on/,
+ -fill =>$blue, qw/-tags item/);
+ $c->createLine(qw/15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on
+ -arrow both -width 3 -tags item/);
+ $c->createLine(qw/12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c
+ 7.5c 12c 6c -smooth on -width 3m -cap round -tags item/,
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ -fill => $red);
+
+ $c->createText(qw/25c .2c -text Polygons -anchor n/);
+ $c->createPolygon(qw/21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c
+ 22.5c 3.25c 21c 4.0c 21.75c 2.5c -tags item/,
+ -fill => $green);
+ $c->createPolygon(qw/25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c
+ 29c 4c 29c 4c -smooth on -tags item/, -fill => $red);
+ $c->createPolygon(qw/22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c
+ 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c -tags item/,
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'));
+
+ $c->createText(qw/5c 8.2c -text Rectangles -anchor n/);
+ $c->createRectangle(qw/1c 9.5c 4c 12.5c/, -outline => $red,
+ qw/-width 3m -tags item/);
+ $c->createRectangle(qw/0.5c 13.5c 4.5c 15.5c/, -fill => $green,
+ qw/-tags item/);
+ $c->createRectangle(qw/6c 10c 9c 15c -tags item/, -outline => undef,
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ -fill => $blue);
+
+ $c->createText(qw/15c 8.2c -text Ovals -anchor n/);
+ $c->createOval(qw/11c 9.5c 14c 12.5c/, -outline => $red,
+ qw/-width 3m -tags item/);
+ $c->createOval(qw/10.5c 13.5c 14.5c 15.5c/, -fill => $green,
+ qw/-tags item/);
+ $c->createOval(qw/16c 10c 19c 15c -tags item/, -outline => undef,
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ -fill => $blue);
+
+ $c->createText(qw/25c 8.2c -text Text -anchor n/);
+ $c->createRectangle(qw/22.4c 8.9c 22.6c 9.1c/);
+ $c->createText(qw/22.5c 9c -anchor n -width 4c/, -font => $font1,
+ -text => 'A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text.', qw/-tags item/);
+ $c->createRectangle(qw/25.4c 10.9c 25.6c 11.1c/);
+ $c->createText(qw/25.5c 11c -anchor w/, -font => $font1, -fill => $blue,
+ -text => "Several lines,\n each centered\n" .
+ "individually,\nand all anchored\nat the left edge.",
+ qw/-justify center -tags item/);
+ $c->createRectangle(qw/24.9c 13.9c 25.1c 14.1c/);
+ $c->createText(qw/25c 14c -anchor c/, -font => $font2, -fill => $red,
+ -stipple => 'gray50',
+ -text => 'Stippled characters', qw/-tags item/);
+
+ $c->createText(qw/5c 16.2c -text Arcs -anchor n/);
+ $c->createArc(qw/0.5c 17c 7c 20c/, -fill => $green, qw/-outline black/,
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ qw/-start 45 -extent 270 -style pieslice -tags item/);
+ $c->createArc(qw/6.5c 17c 9.5c 20c -width 4m -style arc/, -fill => $blue,
+ qw/-start -135 -extent 270 -tags item/);
+ $c->createArc(qw/0.5c 20c 9.5c 24c -width 4m -style pieslice/,
+ -fill => undef, -outline => $red,
+ qw/-start 225 -extent -90 -tags item/);
+ $c->createArc(qw/5.5c 20.5c 9.5c 23.5c -width 4m -style chord/,
+ -fill => $blue, -outline => undef,
+ qw/-start 45 -extent 270 -tags item/);
+
+ $c->createText(qw/15c 16.2c -text Bitmaps -anchor n/);
+ $c->createBitmap(qw/13c 20c -bitmap/ =>
+ '@'.Tk->findINC('demos/images/face'), qw/-tags item/);
+ $c->createBitmap(qw/17c 18.5c/,
+ -bitmap => '@'.Tk->findINC('demos/images/noletters'),
+ qw/-tags item/);
+ $c->createBitmap(qw/17c 21.5c/,
+ -bitmap => '@'.Tk->findINC('demos/images/letters'),
+ qw/-tags item/);
+
+ $c->createText(qw/25c 16.2c -text Windows -anchor n/);
+ my $c_button = $c->Button(-text => 'Press Me',
+ -command => [\&items_button_press, $c, $red],
+ );
+ $c->createWindow(qw/21c 18c/, -window => $c_button,
+ qw/-anchor nw -tags item/);
+ my $c_entry = $c->Entry(-width => '20', -relief => 'sunken',
+ -validate => 'all',
+ -validatecommand => sub {$n++ ? 1 : 0},
+ -invalidcommand => sub {$TOP->bell});
+ $c_entry->insert('end' => 'Edit this text');
+ $c->createWindow(qw/21c 21c/, -window => $c_entry,
+ qw/-anchor nw -tags item/);
+ my $c_scale = $c->Scale(qw/-from 0 -to 100 -length 6c -sliderlength .4c
+ -width .5c -tickinterval 0/);
+ $c->createWindow(qw/28.5c 17.5c/, -window => $c_scale,
+ qw/-anchor n -tags item/);
+ $c->createText(qw/21c 17.9c -text Button: -anchor sw/);
+ $c->createText(qw/21c 20.9c -text Entry: -anchor sw/);
+ $c->createText(qw/28.5c 17.4c -text Scale: -anchor s/);
+
+ # Set up event bindings for canvas.
+
+ $c->bind('item', '<Any-Enter>' => [\&items_enter, \%iinfo]);
+ $c->bind('item', '<Any-Leave>' => [\&items_leave, \%iinfo]);
+
+ # Get real canvas widget reference to apply bind() commands to: the
+ # Canvas widget is a subwidget of the Scrolled composite widget. To
+ # reference the X event structure, either use the XEvent() method or
+ # read the specially localized variable $Tk::event. We'll use XEvent
+ # first, and the variable from then on.
+
+ $c->CanvasBind('<<Copy>>',sub { print "Do Copy\n" });
+
+ $c->CanvasBind('<1>' => sub {
+ my($c) = @_;
+ my $e = $c->XEvent;
+ items_start_drag $c, $e->x, $e->y, \%iinfo;
+ });
+ $c->CanvasBind('<B1-Motion>' =>
+ sub {items_drag shift, $Tk::event->x, $Tk::event->y, \%iinfo});
+ $c->CanvasBind('<2>' =>
+ sub {shift->scan('mark', $Tk::event->x, $Tk::event->y)});
+ $c->CanvasBind('<B2-Motion>' =>
+ sub {shift->scan('dragto', $Tk::event->x, $Tk::event->y)});
+ $c->CanvasBind('<3>' =>
+ sub {items_mark shift, $Tk::event->x, $Tk::event->y, \%iinfo});
+ $c->CanvasBind('<B3-Motion>' =>
+ sub {items_stroke shift, $Tk::event->x, $Tk::event->y, \%iinfo});
+ $c->CanvasBind('<Control-f>' => [sub {
+ my($c, $iinfo) = @_;
+ my $e = $c->XEvent;
+ items_under_area $c, $iinfo;
+ }, \%iinfo]);
+ $c->CanvasBind('<Any-Enter>' => sub {$_[0]->CanvasFocus});
+
+} # end items
+
+# Utility procedures for highlighting the item under the pointer:
+
+sub items_button_press {
+
+ # Procedure that's invoked when the button embedded in the canvas
+ # is invoked.
+
+ my($w, $color) = @_;
+
+ my $i = $w->createText(qw/25c 18.1c -anchor n/, -text => 'Ouch!!',
+ -fill => $color);
+ $w->after(500, sub { $w->delete($i) });
+
+} # end items_button_press
+
+sub items_drag {
+
+ my($c, $x, $y, $iinfo) = @_;
+
+ $x = $c->canvasx($x);
+ $y = $c->canvasy($y);
+ $c->move('current', $x-$iinfo->{lastX}, $y-$iinfo->{lastY});
+ $iinfo->{lastX} = $x;
+ $iinfo->{lastY} = $y;
+
+} # end items_drag
+
+sub items_enter {
+
+ my($c, $iinfo) = @_;
+
+ $iinfo->{restore_cmd} = '';
+
+ if ($TOP->depth == 1) {
+ $iinfo->{restore_cmd} = '';
+ return;
+ }
+ my $type = $c->type('current');
+ if ($type eq 'window') {
+ $iinfo->{restore_cmd} = '';
+ return;
+ }
+
+ if ($type eq 'bitmap') {
+ my $bg = ($c->itemconfigure(qw/current -background/))[4];
+ if (defined $bg) {
+ $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
+ -background => '$bg');";
+ } else {
+ $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
+ -background => undef);";
+ }
+ $c->itemconfigure(qw/current -background SteelBlue2/);
+ return;
+ }
+ my $fill = ($c->itemconfigure(qw/current -fill/))[4];
+ my $stipple = ($c->itemconfigure(qw/current -stipple/))[4];
+ if (defined $stipple) {
+ $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
+ -stipple => '$stipple')";
+ $c->itemconfigure(qw/current -stipple /,'');
+ } elsif (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc')
+ and not defined $fill) {
+ my $outline = ($c->itemconfigure(qw/current -outline/))[4];
+ $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
+ -outline => '$outline')";
+ $c->itemconfigure(qw/current -outline SteelBlue2/);
+ } else {
+ $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
+ -fill => '$fill')";
+ $c->itemconfigure(qw/current -fill SteelBlue2/);
+ }
+
+} # end items_enter
+
+sub items_leave {
+
+ my($c, $iinfo) = @_;
+
+ eval $iinfo->{restore_cmd};
+
+} # end items_leave
+
+sub items_mark {
+
+ my($c, $x, $y, $iinfo) = @_;
+
+ $iinfo->{areaX1} = $c->canvasx($x);
+ $iinfo->{areaY1} = $c->canvasy($y);
+ $c->delete('area');
+
+} # end items_mark
+
+sub items_start_drag {
+
+ my($c, $x, $y, $iinfo) = @_;
+
+ $iinfo->{lastX} = $c->canvasx($x);
+ $iinfo->{lastY} = $c->canvasy($y);
+
+} # end items_start_drag
+
+sub items_stroke {
+
+ my($c, $x, $y, $iinfo) = @_;
+
+ $x = $c->canvasx($x);
+ $y = $c->canvasy($y);
+ if (($iinfo->{areaX1} != $x) and ($iinfo->{areaY1} != $y)) {
+ $c->delete('area');
+ $c->addtag('area', 'withtag', $c->create('rectangle',
+ $iinfo->{areaX1}, $iinfo->{areaY1}, $x, $y, -outline => 'black'));
+ $iinfo->{areaX2} = $x;
+ $iinfo->{areaY2} = $y;
+ }
+
+} # end items_stroke
+
+sub items_under_area {
+
+ my($c, $iinfo) = @_;
+
+ my $area = $c->find('withtag', 'area');
+ my @items = ();
+ my $i;
+ foreach $i ($c->find('enclosed', $iinfo->{areaX1},
+ $iinfo->{areaY1}, $iinfo->{areaX2}, $iinfo->{areaY2})) {
+ my @tags = $c->gettags($i);
+ if (defined($tags[0]) and grep $_ eq 'item', @tags) {
+ push @items, $i;
+ }
+ }
+ @items = 'None' unless @items;
+ print STDOUT 'Items enclosed by area: ', join(' ', @items), ".\n";
+ @items = ();
+ foreach $i ($c->find('overlapping', $iinfo->{areaX1}, $iinfo->{areaY1},
+ $iinfo->{areaX2}, $iinfo->{areaY2})) {
+ my @tags = $c->gettags($i);
+ if (defined($tags[0]) and grep $_ eq 'item', @tags) {
+ push @items, $i;
+ }
+ }
+ @items = 'None' unless @items;
+ print STDOUT 'Items overlapping area: ', join(' ', @items), ".\n";
+
+} # end items_under_area
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/keysyms.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/keysyms.pl
new file mode 100755
index 00000000000..17f594d7061
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/keysyms.pl
@@ -0,0 +1,20 @@
+use strict;
+
+sub keysyms {
+
+ my( $demo ) = @_;
+
+ my $mw = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This demonstration displays the keysym for any keyboard character.',
+ -title => 'Display Keysyms',
+ -iconname => 'keysyms',
+ );
+
+ $mw->Label( qw/ -relief solid -width 20 /, -textvariable => \my $k )->pack;
+
+ $mw->bind( '<KeyPress>' => sub {
+ $k = sprintf( "%s", $Tk::event->K );
+ });
+
+} # end keysyms
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labelframe.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labelframe.pl
new file mode 100755
index 00000000000..17d191a7c9b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labelframe.pl
@@ -0,0 +1,74 @@
+# labelframe.pl
+
+use vars qw/$TOP/;
+
+sub labelframe {
+
+ # Create a top-level window that displays several Labelframe widgets.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -geometry_manager => 'grid',
+ -name => $demo,
+ -text => 'Labelframes are used to group related widgets together. The label maybe either plain text or another widget.',
+ -title => 'Labelframe Demonstration',
+ -iconname => 'labelframe',
+ );
+
+ # A group of radiobuttons in a labelframe
+
+ my $lf1 = $TOP->Labelframe(qw/-text Value -padx 2 -pady 2/);
+ $lf1->grid(qw/-row 0 -column 0 -pady 2m -padx 2m/);
+
+ my $lfdummy;
+ foreach my $value (1 .. 4) {
+ $lf1->Radiobutton(
+ -text => "This is value $value" ,
+ -variable => \$lfdummy,
+ -value => $value,
+ )->pack(qw/-side top -fill x -pady 2/);
+ }
+
+ # A label window controlling a group of options.
+
+ my $lf2 = $TOP->Labelframe(qw/-pady 2 -padx 2/);
+ $lf2->grid(qw/-row 0 -column 1 -pady 2m -padx 2m/);
+ my $lfdummy2;
+ my $cb;
+ $cb = $lf2->Checkbutton(
+ -text => 'Use this option',
+ -variable => \$lfdummy2,
+ -command => sub {&labelframe_buttons($lf2, $cb, \$lfdummy2)},
+ -padx => 0,
+ );
+ $lf2->configure(-labelwidget => $cb);
+
+ foreach my $str (qw/Option1 Option2 Option3/) {
+ $lf2->Checkbutton(-text => $str)->pack(qw/-side top -fill x -pady 2/);
+ }
+
+ &labelframe_buttons($lf2, $cb, \$lfdummy2);
+
+ $TOP->gridColumnconfigure([0, 1], -weight => 1);
+
+} # end labelframe
+
+sub labelframe_buttons {
+
+ # The state of the sub-Checkbuttons is dependent upon the state of
+ # the master -labelwidget Checkbutton.
+
+ my ($lf, $cb, $var_ref) = @_;
+
+ foreach my $child ($lf->children) {
+ next if $child == $cb;
+ if ($$var_ref) {
+ $child->configure(qw/-state normal/);
+ } else {
+ $child->configure(qw/-state disabled/);
+ }
+ }
+
+} # end labelframe_buttons
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labels.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labels.pl
new file mode 100755
index 00000000000..4650ffdfd50
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labels.pl
@@ -0,0 +1,43 @@
+# labels.pl
+
+use vars qw/$TOP/;
+
+sub labels {
+
+ # Create a top-level window that displays a bunch of labels. @pl is the
+ # "packing list" variable which specifies the list of packer attributes.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Five labels are displayed below: three textual ones on the left, and an image label and a text label on the right. Labels are pretty boring because you can\'t do anything with them.',
+ -title => 'Label Demonstration',
+ -iconname => 'label',
+ );
+
+ my(@pl) = qw/-side left -expand yes -padx 10 -pady 10 -fill both/;
+ my $left = $TOP->Frame->pack(@pl);
+ my $right = $TOP->Frame->pack(@pl);
+
+ @pl = qw/-side top -expand yes -pady 2 -anchor w/;
+ my $left_l1 = $left->Label(-text => 'First label')->pack(@pl);
+ my $left_l2 = $left->Label(
+ -text => 'Second label, raised just for fun',
+ -relief => 'raised',
+ )->pack(@pl);
+ my $left_l3 = $left->Label(
+ -text => 'Third label, sunken',
+ -relief => 'sunken',
+ )->pack(@pl);
+
+ @pl = qw/-side top/;
+ my $right_bitmap = $right->Label(
+ -image => $TOP->Photo(-file => Tk->findINC('Xcamel.gif')),
+ -borderwidth => 2,
+ -relief => 'sunken',
+ )->pack(@pl);
+ my $right_caption = $right->Label(-text => 'Perl/Tk')->pack(@pl);
+
+} # end labels
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labframe.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labframe.pl
new file mode 100755
index 00000000000..c5f09f88bca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labframe.pl
@@ -0,0 +1,13 @@
+# LabFrame, frame with embedded label.
+
+use Tk;
+use Tk::LabFrame;
+use Tk::LabEntry;
+
+my $test = 'Test this';
+
+my $top = MainWindow->new;
+my $f = $top->LabFrame(-label => "This is a label", -labelside => "acrosstop");
+$f->LabEntry(-label => "Testing", -textvariable => \$test)->pack;
+$f->pack;
+MainLoop;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/mega.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/mega.pl
new file mode 100755
index 00000000000..cbd1b6cbd4c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/mega.pl
@@ -0,0 +1,135 @@
+# mega.pl
+
+use vars qw / $TOP /;
+use strict;
+
+sub mega {
+
+ my( $demo ) = @_;
+
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => [ "Perl/Tk provides a powerful framework for creating custom widgets. There are two types of these mega-widgets: composite and derived. Subsequent demonstrations detail a complete mega-widget of each type. Regardless of the type of mega-widget, they share a common programming structure. The key that differentiates the various types of mega-widget is the definition of the new widget's base class(es).", -wraplength => '7i' ],
+ -title => 'Introduction to writing pure Perl mega-widgets ',
+ -iconname => 'mega',
+ );
+
+ my $t = $TOP->Scrolled( qw/ ROText -wrap word -scrollbars oe/ );
+ $t->focus;
+ $t->pack( qw/ -fill both -expand 1 / );
+ $t->insert( 'end', <<'end-of-instructions' );
+
+Here, briefly, is the Perl/Tk mega-widget implementation for pure Perl mega-widgets. As much of the work as possible has been abstracted and incorporated into the pTk core. This mimimizes the code the mega-widget author has to write, increasing consistency.
+
+There are two varieties of mega-widgets in Perl/Tk: composite and derived. A composite is Toplevel or Frame-based, having other, more elemental, widgets packed (or gridded) inside. A derived widget has a ISA-like relationship, generally adding (but sometimes subtracting) options/methods to/from a single, existing, widget. Of course, that single widget may itself be a composite widget.
+
+To create a Perl/Tk mega-widget one:
+
+. chooses a namespace (class name)
+. defines a subroutine to initialize the class (optional)
+. defines an instance constructor (subroutine) that (optional):
+ . builds the new widget
+ . defines options (configuration specifications, analagous to C widgets)
+ . defines delegates for widget methods
+. defines private and instance methods (optional)
+
+As with core widgets, methods like configure() and cget() are automatically provided by the mega-widget framework and are "just there", and option database operations "just work".
+
+Here is a minimal Perl/Tk Toplevel-based composite mega-widget:
+
+ package Tk::Nil;
+ use base qw/Tk::Toplevel/;
+ Construct Tk::Widget 'Nil';
+
+Unless overridden, options and methods are inherited from the mega-widget's base class(es).
+
+You create a Nil just like any other Perl/Tk widget:
+
+ my $nil = $mw->Nil;
+
+And an empty Nil window appears that functions just like a Toplevel! But other than that, the Nil widget doesn't do anything more since no additonal subwidgets or behavior have been defined. The purpose of that example was to demonstrate how much the Perl/Tk mega-widget mechanism did for the mega-widget author - a fully functional composite mega-widget in three lines of code.
+
+There's a second container-like mega-widget in Perl/Tk, based on a Frame. But other than the logical container, the two mega-widget types are more-or-less equivalent. The third and final mega-widget type we call a derived mega-widget, because it adds or subtracts behavior to/from an existing widget.
+
+Functional mega-widgets look more like this:
+
+ package Tk::MyNewWidget;
+
+ # Declare base class.
+ use base qw/ Tk::Frame /; # Frame-based composite
+or
+ use base qw/ Tk::Toplevel /; # Toplevel-based composite
+or
+ use Tk:SomeWidget;
+ use base qw/ Tk::Derived Tk::SomeWidget /; # derived from SomeWidget
+
+ Construct Tk::Widget 'MyNewWidget'; # install MyNewWidget in pTk namespace
+
+ sub ClassInit{ # called once to initialize new class
+ my($class, $mw) = @_;
+ $class->SUPER::ClassInit($mw);
+ }
+
+ sub Populate { # called to build each widget instance
+ my($self, $args) = @_;
+ $self->SUPER::Populate($args);
+ $self->Advertise(); # advertise subwidgets
+ $self->Callback(); # invoke -command callbacks
+ $self->Component(); # define a subwidget component
+ $self->ConfigSpecs(); # define cget() / configure() options
+ $self->Delegates(); # how methods are delegated to subwidgets
+ $self->Subwidget(); # map a subwidget name to subwidget reference
+ }
+
+ # Private methods.
+
+ # Public methods.
+
+ 1; # end class MyNewWidget
+
+ # Don't forget POD documentation here!
+
+Here's an excerpt from a Text dervived mega-widget called TraceText; you can examine the complete code in another demonstration. This widget defines its content using a new -textvariable option.
+
+ package Tk::TraceText;
+ use base qw/Tk::Derived Tk::Text/;
+ Construct Tk::Widget 'TraceText';
+
+ sub Populate {
+
+ my( $self, $args ) = @_;
+
+ $self->ConfigSpecs(
+ -textvariable => 'METHOD', 'textVariable', 'TextVariable', undef,
+ );
+
+ } # end Populate
+
+ # Private methods.
+
+ sub textvariable {
+
+ my ( $self, $vref ) = @_;
+
+ $self->traceVariable( $vref, 'w', [ \&tracew => $self, $vref ] );
+ $self->{_vref} = $vref; # store watchpoint in an instance variable
+
+ } # end textvariable
+
+If you compare the preamble (the first three lines) with that of the Nil mega-widget, you'll note that they are virtually identical - the important difference is the addition of the Tk::Derived class that provides additional methods specifically for derived mega-widgets.
+
+At that point, with three lines of code, we have a completely functional mega-widget called TraceText that is identical to the standard Text widget in every way, and the key to all this is the Construct() call, which, among other duties, installs the new widget name in the symbol table.
+
+Construct() also arranges for the TraceText "instantiator" to call-out to the well-known method Populate() - this is how the mega-widget author adds behavior to the new widget. Similarly, the mega-widget author can provide a ClassInit() method that is called once per MainWindow to initialize class bindings, variables, images, etcetera.
+
+Tk::TraceText::Populate defines the -textvariable option and provides a private method to establish the watchpoint. In Perl/Tk, all mega-widget options are specified via a ConfigSpecs() call, named after the C structure.
+
+Briefly, ConfigSpecs() names options and tells Perl/Tk what to do when one is specified on a configure() or cget() call. It also specifies the option's database name, class name and default value for option DB lookups. For our -textvariable option, the Perl/Tk framework invokes a METHOD (subroutine) by the same name as the option, minus the dash, of course. Other choices include CHILDREN, DECENDENTS, a name (or list of names) of a subwidget, etcetera.
+
+More details on mega-widget construction can be found in these man pages:
+
+Tk::ConfigSpecs, Tk::Derived, Tk::composite, Tk::mega
+
+end-of-instructions
+
+} # end mega
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menbut.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menbut.pl
new file mode 100755
index 00000000000..9fd624bdc22
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menbut.pl
@@ -0,0 +1,122 @@
+# menbut.pl
+
+use vars qw/$TOP/;
+
+sub menbut {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => '',
+ -title => 'Menubutton Demo',
+ -iconname => 'Menubutton',
+ );
+
+ my @menubuttons;
+ foreach (qw/below right left above/) {
+ my $pos = ucfirst;
+ my $menubutton = $TOP->Menubutton(qw/-underline 0 -relief raised/,
+ -text => $pos, -direction => $_);
+ push @menubuttons, $menubutton;
+ my $menu = $menubutton->menu(qw/-tearoff 0/);
+ $menubutton->configure(-menu => $menu);
+ $menubutton->command(-label => "$pos menu: first item", -command =>
+ sub {print "You selected the first item from the $pos menu.\n"});
+ $menubutton->command(-label => "$pos menu: second item", -command =>
+ sub {print "You selected the second item from the $pos menu.\n"});
+ }
+ $menubuttons[0]->grid(qw/-row 0 -column 1 -sticky n/);
+ $menubuttons[3]->grid(qw/-row 2 -column 1 -sticky n/);
+ $menubuttons[1]->grid(qw/-row 1 -column 0 -sticky w/);
+ $menubuttons[2]->grid(qw/-row 1 -column 2 -sticky e/);
+
+ my $body = $TOP->Frame;
+ $body->grid(qw/-row 1 -column 1 -sticky news/);
+ $body->Label(qw/-wraplength 300 -justify left/, -font => 'Helvetica 14',
+ -text => 'This is a demonstration of menubuttons. The "Below" menubutton pops its menu below the button; the "Right" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette.')->pack(qw/-side top -padx 25
+ -pady 25/);
+ $bbutt = $body->Frame->pack(qw/-padx 25 -pady 25/);
+ $bbutt->Optionmenu(-options => [qw/one two three/])->pack(qw/-side left
+ -padx 25 -pady 25/);
+
+ my $palette;
+ my(@colors) = qw/Black red4 DarkGreen NavyBlue gray75 Red Green Blue
+ gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet/;
+
+ my $colors = native_optionmenu(
+ $bbutt,
+ \$palette,
+ [sub {print "args=@_.\n"}, 'First'],
+ @colors,
+ );
+ $colors->pack(qw/-side left -padx 25 -pady 25/);
+
+ my $menu = $colors->cget(-menu);
+ my $topborder = 'gray50';
+ my $bottomborder = 'gray75';
+
+ foreach my $i (0 .. $#colors) {
+
+ # Create a 16 pixel x 16 pixel solid color swatch.
+ # Add a black ring around the currently selected item.
+
+ my $color = $menu->entrycget($i, -label);
+ my $p = $TOP->Photo(qw/-width 16 -height 16/);
+ $p->put($topborder, qw/-to 0 0 16 1/);
+ $p->put($topborder, qw/-to 0 1 1 16/);
+ $p->put($bottomborder, qw/-to 1 15 16 16/);
+ $p->put($bottomborder, qw/-to 15 1 16 15/);
+ $p->put($color, qw/-to 1 1 15 15/);
+
+ my $r = $TOP->Photo(qw/-width 16 -height 16/);
+ $r->put(qw/black -to 0 0 16 2/);
+ $r->put(qw/black -to 0 2 2 16/);
+ $r->put(qw/black -to 2 14 16 16/);
+ $r->put(qw/black -to 14 2 16 14/);
+ $r->put($color , qw/-to 2 2 14 14/);
+
+ $menu->entryconfigure($i, -columnbreak => 1) unless $i % 4;
+ $menu->entryconfigure($i,
+ -image => $p,
+ -hidemargin => 1,
+ -selectimage => $r,
+ );
+
+ } # forend all colors
+
+ $menu->configure(-tearoff => 1);
+
+} # end menbut
+
+sub native_optionmenu {
+
+ my($parent, $varref, $command, @optionvals) = @_;
+
+ $$varref = $optionvals[0];
+
+ my $mb = $parent->Menubutton(
+ -textvariable => $varref,
+ -indicatoron => 1,
+ -relief => 'raised',
+ -borderwidth => 2,
+ -highlightthickness => 2,
+ -anchor => 'c',
+ -direction => 'flush',
+ );
+ my $menu = $mb->Menu(-tearoff => 0);
+ $mb->configure(-menu => $menu);
+
+ my $callback = ref($command) =~ /CODE/ ? [$command] : $command;
+
+ foreach (@optionvals) {
+ $menu->radiobutton(
+ -label => $_,
+ -variable => $varref,
+ -command => [@$callback, $_],
+ );
+ }
+
+ $mb;
+
+} # end native_optionmenu
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus.pl
new file mode 100755
index 00000000000..10fa7bfac89
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus.pl
@@ -0,0 +1,196 @@
+# menus.pl
+
+use subs qw/menus_error/;
+use vars qw/$TOP/;
+
+sub menus {
+
+ # This demonstration script creates a window with a bunch of menus
+ # and cascaded menus using a menubar. A <<MenuSelect>> virtual event
+ # tracks the active menu item.
+
+ my ($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['', -wraplength => '5i'],
+ -title => 'Menu Demonstration',
+ -iconname => 'menus',
+ );
+
+ my $ws = $TOP->windowingsystem;
+
+ my $text = ($ws eq 'classic' or $ws eq 'aqua') ?
+ 'This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where "x" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging outside of its bounds and releasing the mouse.' :
+ 'This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where "x" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu.';
+
+ $TOP->configure(-text => $text);
+
+ my $toplevel = $TOP->toplevel; # get $TOP's Toplevel widget reference
+ my $menubar = $toplevel->Menu(-type => 'menubar');
+ $toplevel->configure(-menu => $menubar);
+
+ my $modifier;
+ if ( $ws eq 'classic' or $ws eq 'aqua') {
+ $modifier = 'Command';
+ } elsif ($Tk::platform eq 'windows') {
+ $modifier = 'Control';
+ } else {
+ $modifier = 'Meta';
+ }
+
+ my $f = $menubar->cascade(-label => '~File', -tearoff => 0);
+ $f->command(-label => 'Open ...', -command => [\&menus_error, 'Open'],
+ -image => $toplevel->Getimage("openfile"), -compound => "left");
+ $f->command(-label => 'New', -command => [\&menus_error, 'New'],
+ -image => $toplevel->Getimage("file"), -compound => "left");
+ $f->command(-label => 'Save', -command => [\&menus_error, 'Save']);
+ $f->command(-label => 'Save As ...', -command => [\&menus_error, 'Save As']);
+ $f->separator;
+ $f->command(-label => 'Setup ...', -command => [\&menus_error, 'Setup']);
+ $f->command(-label => 'Print ...', -command => [\&menus_error, 'Print']);
+ $f->separator;
+ $f->command(-label => 'Quit', -command => [$TOP => 'bell']);
+
+ my $b = $menubar->cascade(-label => '~Basic', -tearoff => 0);
+ $b->command(-label => 'Long entry that does nothing');
+ my $label;
+ foreach $label (qw/A B C D E F/) {
+ $b->command(
+ -label => "Print letter \"$label\"",
+ -underline => 14,
+ -accelerator => "$modifier+$label",
+ -command => sub {print "$label\n"},
+ );
+ $TOP->bind("<$modifier-${label}>" => sub {print "$label\n"});
+ }
+ my $c = $menubar->cascade(-label => '~Cascades', -tearoff => 0);
+ $c->command(
+ -label => 'Print hello',
+ -command => sub {print "Hello\n"},
+ -accelerator => "$modifier+H",
+ -underline => 6,
+ );
+ $TOP->bind("<$modifier-h>" => sub {print "Hello\n"});
+ $c->command(
+ -label => 'Print goodbye',
+ -command => sub {print "Goodbye\n"},
+ -accelerator => "$modifier+G",
+ -underline => 6,
+ );
+ $TOP->bind("<$modifier-g>" => sub {print "Goodbye\n"});
+ my $cc = $c->cascade(-label => '~Check buttons', -tearoff => 0);
+
+ $cc->checkbutton(-label => 'Oil checked', -variable => \$OIL);
+ $cc->checkbutton(-label => 'Transmission checked', -variable => \$TRANS);
+ $cc->checkbutton(-label => 'Brakes checked', -variable => \$BRAKES);
+ $cc->checkbutton(-label => 'Lights checked', -variable => \$LIGHTS);
+ $cc->separator;
+ $cc->command(
+ -label => 'See current values',
+ -command => [\&see_vars, $MW, [
+ ['oil', \$OIL],
+ ['trans', \$TRANS],
+ ['brakes', \$BRAKES],
+ ['lights', \$LIGHTS],
+ ],
+ ],
+ );
+ my $cc_menu = $cc->cget(-menu);
+ $cc_menu->invoke(1);
+ $cc_menu->invoke(3);
+
+ my $rc = $c->cascade(-label => '~Radio buttons', -tearoff => 0);
+
+ foreach $label (qw/10 14 18 24 32/) {
+ $rc->radiobutton(
+ -label => "$label point",
+ -variable => \$POINT_SIZE,
+ -value => $label,
+ );
+ }
+ $rc->separator;
+ foreach $label (qw/Roman Bold Italic/) {
+ $rc->radiobutton(
+ -label => $label,
+ -variable => \$FONT_STYLE,
+ -value => $label,
+ );
+ }
+ $rc->separator;
+ $rc->command(
+ -label => 'See current values',
+ -command => [\&see_vars, $MW, [
+ ['point size', \$POINT_SIZE],
+ ['font style', \$FONT_STYLE],
+ ],
+ ],
+ );
+ my $rc_menu = $rc->cget(-menu);
+ $rc_menu->invoke(1);
+ $rc_menu->invoke(7);
+
+ my $i = $menubar->cascade(-label => '~Icons', -tearoff => 0);
+ $i->command(
+ -bitmap => '@'.Tk->findINC('demos/images/pattern'),
+ -command => sub {
+ $TOP->messageBox(
+ -title => 'Bitmap Menu Entry',
+ -message => 'The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.',
+ -type => 'ok'),
+ },
+ -hidemargin => 1,
+ );
+ foreach $label (qw/info questhead error/) {
+ $i->command(
+ -bitmap => $label,
+ -command => sub {print "You invoked the \"$label\" bitmap\n"},
+ -hidemargin => 1,
+ );
+ }
+ $i->cget(-menu)->entryconfigure(2, -columnbreak => 1);
+
+ my $m = $menubar->cascade(-label => '~More', -tearoff => 0);
+ foreach $label ('An entry', 'Another entry', 'Does nothing',
+ 'Does almost nothing', 'Make life meaningful') {
+ $m->command(
+ -label => $label,
+ -command => sub {print "You invoked \"$label\"\n"},
+ );
+ }
+
+ my $k = $menubar->cascade(-label => 'C~olors');
+ foreach $label (qw/red orange yellow green blue/) {
+ $k->command(
+ -label => $label,
+ -background => $label,
+ -command => sub {print "You invoked \"$label\"\n"},
+ );
+ }
+
+ my $status_bar;
+ $TOP->Label(
+ qw/-relief sunken -borderwidth 1 -anchor w/,
+ -font => 'Helvetica 10', -textvariable => \$status_bar)->
+ pack(qw/-padx 2 -pady 2 -expand yes -fill both/);
+ $menubar->bind('<<MenuSelect>>' => sub {
+ $status_bar = undef;
+ $status_bar = $_[0]->entrycget('active', -label);
+ $TOP->idletasks;
+ });
+
+} # end menus
+
+sub menus_error {
+
+ # Generate a background error, which may even be displayed in a window if
+ # using ErrorDialog.
+
+ my($msg) = @_;
+
+ $msg = "This is just a demo: no action has been defined for \"$msg\".";
+ $TOP->BackTrace($msg);
+
+} # end menus_error
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus2.pl
new file mode 100755
index 00000000000..632b786b524
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus2.pl
@@ -0,0 +1,216 @@
+# menus2.pl
+
+use subs qw/menus_error2/;
+use vars qw/$TOP/;
+
+sub menus2 {
+
+ # This demonstration script creates a window with a bunch of menus
+ # and cascaded menus, but uses the unique Perl/Tk -menuitems way.
+ # A <<MenuSelect>> virtual event tracks the active menu item.
+
+ my ($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['', -wraplength => '5i'],
+ -title => 'Menuitems Demonstration',
+ -iconname => 'menus2',
+ );
+
+ my $ws = $TOP->windowingsystem;
+
+ my $text = ($ws eq 'classic' or $ws eq 'aqua') ?
+ 'This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where "x" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging outside of its bounds and releasing the mouse.' :
+ 'This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where "x" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu.';
+
+ $TOP->configure(-text => $text);
+
+ my $toplevel = $TOP->toplevel; # get $TOP's Toplevel widget reference
+ my $menubar = $toplevel->Menu(-type => 'menubar');
+ $toplevel->configure(-menu => $menubar);
+
+ my $modifier;
+ if ( $ws eq 'classic' or $ws eq 'aqua') {
+ $modifier = 'Command';
+ } elsif ($Tk::platform eq 'windows') {
+ $modifier = 'Control';
+ } else {
+ $modifier = 'Meta';
+ }
+
+ my $f = $menubar->Cascade(qw/-label ~File -tearoff 0 -menuitems/ =>
+ [
+ [Button => 'Open ...', -command => [\&menus_error2, 'Open'],
+ -image => $toplevel->Getimage("openfile"),
+ -compound=> "left",
+ ],
+ [Button => 'New', -command => [\&menus_error2, 'New'],
+ -image => $toplevel->Getimage("file"),
+ -compound=> "left",
+ ],
+ [Button => 'Save', -command => [\&menus_error2, 'Save']],
+ [Button => 'Save As ...', -command => [\&menus_error2, 'Save As']],
+ [Separator => ''],
+ [Button => 'Setup ...', -command => [\&menus_error2, 'Setup']],
+ [Button => 'Print ...', -command => [\&menus_error2, 'Print']],
+ [Separator => ''],
+ [Button => 'Quit', -command => [$TOP => 'bell']],
+ ],
+ );
+
+ my $b = $menubar->Cascade(qw/-label ~Basic -tearoff 0 -menuitems/ =>
+ [
+ [Button => 'Long entry that does nothing'],
+ map (
+ [Button => "Print letter \"~$_\"",
+ -command => [sub {print "$_[0]\n"}, $_],
+ -accelerator => "Meta+$_" ],
+ ('a' .. 'g')
+ ),
+ ],
+ );
+
+ my $menu_cb = '~Check buttons';
+ my $menu_rb = '~Radio buttons';
+
+ my $c = $menubar->Cascade(qw/-label ~Cascades -tearoff 0 -menuitems/ =>
+ [
+ [Button => 'Print ~hello', -command => sub {print "Hello\n"},
+ -accelerator => 'Control+a'],
+ [Button => 'Print ~goodbye', -command => sub {print "Goodbye\n"},
+ -accelerator => 'Control+b'],
+ [Cascade => $menu_cb, -tearoff => 0, -menuitems =>
+ [
+ [Checkbutton => 'Oil checked', -variable => \$OIL],
+ [Checkbutton => 'Transmission checked', -variable => \$TRANS],
+ [Checkbutton => 'Brakes checked', -variable => \$BRAKES],
+ [Checkbutton => 'Lights checked', -variable => \$LIGHTS],
+ [Separator => ''],
+ [Button => 'See current values', -command =>
+ [\&see_vars, $TOP, [
+ ['oil', \$OIL],
+ ['trans', \$TRANS],
+ ['brakes', \$BRAKES],
+ ['lights', \$LIGHTS],
+ ],
+ ], # end see_vars
+ ], # end button
+ ], # end checkbutton menuitems
+ ], # end checkbuttons cascade
+ [Cascade => $menu_rb, -tearoff => 0, -menuitems =>
+ [
+ map (
+ [Radiobutton => "$_ point", -variable => \$POINT_SIZE,
+ -value => $_,
+ ],
+ (qw/10 14 18 24 32/),
+ ),
+ [Separator => ''],
+ map (
+ [Radiobutton => "$_", -variable => \$FONT_STYLE,
+ -value => $_,
+ ],
+ (qw/Roman Bold Italic/),
+ ),
+ [Separator => ''],
+ [Button => 'See current values', -command =>
+ [\&see_vars, $TOP, [
+ ['point size', \$POINT_SIZE],
+ ['font style', \$FONT_STYLE],
+ ],
+ ], # end see_vars
+ ], # end button
+ ], # end radiobutton menuitems
+ ], # end radiobuttons cascade
+ ],
+ );
+
+ $TOP->bind('<Control-a>' => sub {print "Hello\n"});
+ $TOP->bind('<Control-b>' => sub {print "Goodbye\n"});
+
+ # Fetch the Cascades menu, and from that get the checkbutton and
+ # radiobutton cascade menus and invoke a few menu items.
+
+ my $cm = $c->cget(-menu);
+ $menu_cb = substr $menu_cb, 1;
+ my $cc = $cm->entrycget($menu_cb, -menu);
+ $cc->invoke(1);
+ $cc->invoke(3);
+ $menu_rb = substr $menu_rb, 1;
+ my $cr = $cm->entrycget($menu_rb, -menu);
+ $cr->invoke(1);
+ $cr->invoke(7);
+
+ my $i = $menubar->Cascade(qw/-label ~Icons -tearoff 0 -menuitems/ =>
+ [
+ [Button => '', -bitmap => '@'.Tk->findINC('demos/images/pattern'),
+ -command => sub {
+ $TOP->messageBox(
+ -title => 'Bitmap Menu Entry',
+ -message => 'The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.',
+ -type => 'ok'),
+ },
+ ],
+ map (
+ [Button => '', -bitmap => $_,
+ -command =>
+ [sub {print "You invoked the \"$_[0]\" bitmap\n"}, $_]],
+ (qw/info questhead error/),
+ ),
+ ],
+ );
+ my $im = $i->cget(-menu);
+ $im->entryconfigure(2, -columnbreak => 1);
+
+ my $m = $menubar->Cascade(qw/-label ~More -tearoff 0 -menuitems/ =>
+ [
+ map (
+ [Button => $_,
+ -command =>
+ [sub {print "You invoked \"$_[0]\"\n"}, $_]],
+ ('An entry', 'Another entry', 'Does nothing',
+ 'Does almost nothing', 'Make life meaningful'),
+ ),
+ ],
+ );
+
+ my $k = $menubar->cascade(qw/-label C~olors -tearoff 1 -menuitems/ =>
+ [
+ map (
+ [Button => $_,
+ -background => $_,
+ -command =>
+ [sub {print "You invoked \"$_[0]\"\n"}, $_]],
+ (qw/red orange yellow green blue/),
+ ),
+ ],
+ );
+
+ my $status_bar;
+ $TOP->Label(
+ qw/-relief sunken -borderwidth 1 -anchor w/,
+ -font => 'Helvetica 10', -textvariable => \$status_bar)->
+ pack(qw/-padx 2 -pady 2 -expand yes -fill both/);
+ $menubar->bind('<<MenuSelect>>' => sub {
+ $status_bar = undef;
+ $status_bar = $_[0]->entrycget('active', -label);
+ $TOP->idletasks;
+ });
+
+} # end menus2
+
+sub menus_error2 {
+
+
+ # Generate a background error, which may even be displayed in a window if
+ # using ErrorDialog.
+
+ my($msg) = @_;
+
+ $msg = "This is just a demo: no action has been defined for \"$msg\".";
+ $TOP->BackTrace($msg);
+
+} # end menus_error
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/msgBox.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/msgBox.pl
new file mode 100755
index 00000000000..4ac739519e8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/msgBox.pl
@@ -0,0 +1,82 @@
+# msgBox.pl
+
+use vars qw/$TOP/;
+
+sub msgBox {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Choose the icon and type option of the message box. Then press the "Message Box" button to see the message box.',
+ -title => 'messageBox Demo',
+ -iconname => 'messageBox',
+ );
+
+ my $upper = $TOP->Frame->pack;
+ my $left = $upper->Frame;
+ my $right = $upper->Frame;
+ $left->pack(qw/-side left -expand yes -fill y -pady .5c -padx .5c/);
+ $right->pack(qw/-side left -expand yes -fill y -pady .5c -padx .5c/);
+
+ my $icon = $left->Label(qw/-text Icon/);
+ my $lsep = $left->Frame(qw/-relief ridge -bd 1 -height 2/);
+ $icon->pack(qw/-side top/);
+ $lsep->pack(qw/-side top -fill x -expand no/);
+
+ my $iconvar = 'info';
+ foreach my $i (qw/error info question warning/) {
+ $left->Radiobutton(-text => $i, -variable => \$iconvar, -value => $i,
+ qw/-width 16 -anchor w -relief flat/)->pack(
+ qw/-side top -pady 2 -anchor w -fill x/);
+ }
+
+
+ my $rl = $right->Label(qw/-text Type/);
+ my $rsep = $right->Frame(qw/-relief ridge -bd 1 -height 2/);
+ $rl->pack(qw/-side top/);
+ $rsep->pack(qw/-side top -fill x -expand no/);
+
+ my $typevar = 'OK';
+ foreach my $t (qw/AbortRetryIgnore OK OKCancel RetryCancel YesNo YesNoCancel/) {
+ $right->Radiobutton(-text => $t, -variable => \$typevar, -value => $t,
+ qw/-relief flat -width 16 -anchor w/)->pack(
+ qw/-side top -pady 2 -anchor w -fill x/);
+ }
+
+ {
+ my $cbf = $TOP->Frame->pack(-fill => 'x', -padx => '.5c', -pady => 3);
+ my $fd;
+ my $fdb = $cbf->Radiobutton
+ (-text => 'Tk::DialogBox',
+ -variable => \$fd,
+ -value => 'DialogBox',
+ -command => sub { local($^W) = 0;
+ *Tk::tk_messageBox = sub{ Tk::MessageBox('tk_messageBox', @_) };
+ })->pack(-side => 'left');
+ $cbf->Radiobutton
+ (-text => 'Tk::MsgBox',
+ -variable => \$fd,
+ -value => 'MsgBox',
+ -command => sub { local($^W) = 0;
+ require Tk::MsgBox;
+ Tk::MsgBox->import('as_default');
+ })->pack(-side => 'left');
+ $fdb->invoke;
+ }
+
+ my $show = $TOP->Button(-text => "Message Box",
+ -command => [\&show_messageBox, \$iconvar, \$typevar]);
+ $show->pack;
+
+} # end msgBox
+
+sub show_messageBox {
+ my($iconvar, $typevar) = @_;
+
+ my $button = $TOP->messageBox('-icon' => $$iconvar, -type => $$typevar,
+ -title => 'Message',
+ -message => "This is a \"$$typevar\" type messagebox with the \"$$iconvar\" icon");
+
+ $TOP->messageBox(qw/-icon info -type OK -message/ => "You have selected \"$button\"");
+
+} # end show_messageBox
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/notebook.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/notebook.pl
new file mode 100755
index 00000000000..ed45ef83190
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/notebook.pl
@@ -0,0 +1,59 @@
+# Notebook, selectable pages.
+
+use Tk;
+use Tk::DialogBox;
+use Tk::NoteBook;
+use Tk::LabEntry;
+
+my $name = "Rajappa Iyer";
+my $email = "rsi\@netcom.com";
+my $os = "Linux";
+
+use vars qw($top);
+
+$top = MainWindow->new;
+my $pb = $top->Button(-text => "Notebook", -command => \&donotebook);
+$pb->pack;
+MainLoop;
+
+
+my $f;
+
+sub donotebook {
+ if (not defined $f) {
+ # The current example uses a DialogBox, but you could just
+ # as easily not use one... replace the following by
+ # $n = $top->NoteBook(-ipadx => 6, -ipady => 6);
+ # Of course, then you'd have to take care of the OK and Cancel
+ # buttons yourself. :-)
+ $f = $top->DialogBox(-title => "Personal Profile",
+ -buttons => ["OK", "Cancel"]);
+ my $n = $f->add('NoteBook', -ipadx => 6, -ipady => 6);
+
+ my $address_p = $n->add("address", -label => "Address", -underline => 0);
+ my $pref_p = $n->add("pref", -label => "Preferences", -underline => 0);
+
+ $address_p->LabEntry(-label => "Name: ",
+ -labelPack => [-side => "left", -anchor => "w"],
+ -width => 20,
+ -textvariable => \$name)->pack(-side => "top", -anchor => "nw");
+ $address_p->LabEntry(-label => "Email Address:",
+ -labelPack => [-side => "left", -anchor => "w"],
+ -width => 50,
+ -textvariable => \$email)->pack(-side => "top", -anchor => "nw");
+ $pref_p->LabEntry(-label => "Operating System:",
+ -labelPack => [-side => "left"],
+ -width => 15,
+ -textvariable => \$os)->pack(-side => "top", -anchor => "nw");
+ $n->pack(-expand => "yes",
+ -fill => "both",
+ -padx => 5, -pady => 5,
+ -side => "top");
+
+ }
+ my $result = $f->Show;
+ if ($result =~ /OK/) {
+ print "name = $name, email = $email, os = $os\n";
+ }
+}
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned1.pl
new file mode 100755
index 00000000000..4a988ddd6da
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned1.pl
@@ -0,0 +1,26 @@
+# paned1.pl
+
+use vars qw/$TOP/;
+
+sub paned1 {
+
+ # This demonstration script creates a toplevel window containing
+ # a paned window that separates two windows horizontally.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'The sash between the two coloured windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)',
+ -title => 'Horizontal Paned Window Demonstration',
+ -iconname => 'paned1',
+ );
+
+ my $pw = $TOP->Panedwindow;
+ $pw->pack(qw/-side top -expand yes -fill both -pady 2 -padx 2m/);
+
+ my $l1 = $pw->Label(-text => "This is the\nleft side", -background => 'yellow');
+ my $l2 = $pw->Label(-text => "This is the\nright side", -background =>'cyan');
+
+ $pw->add($l1, $l2);
+
+} # end paned1
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned2.pl
new file mode 100755
index 00000000000..28ccf0ba4bf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned2.pl
@@ -0,0 +1,65 @@
+# paned2.pl
+
+use vars qw/$TOP/;
+
+sub paned2 {
+
+ # This demonstration script creates a toplevel window containing
+ # a paned window that separates two windows vertically.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'The sash between the two scrolled windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)',
+ -title => 'Vertical Paned Window Demonstration',
+ -iconname => 'paned2',
+ );
+
+ my $pw = $TOP->Panedwindow(qw/-orient vertical/);
+ $pw->pack(qw/-side top -expand yes -fill both -pady 2 -padx 2m/);
+
+ my $paneList = [
+ 'List of Tk Widgets', qw/
+ button
+ canvas
+ checkbutton
+ entry
+ frame
+ label
+ labelframe
+ listbox
+ menu
+ menubutton
+ message
+ panedwindow
+ radiobutton
+ scale
+ scrollbar
+ spinbox
+ text
+ toplevel
+ /,
+ ];
+
+ my $f1 = $pw->Frame;
+ my $lb = $f1->Listbox(-listvariable => $paneList);
+ $lb->pack(qw/-fill both -expand 1/);
+ my ($fg, $bg) = ($lb->cget(-foreground), $lb->cget(-background));
+ $lb->itemconfigure(0,
+ -background => $fg,
+ -foreground => $bg,
+ );
+
+ my $f2 = $pw->Frame;
+ my $t = $f2->Text(qw/-width 30 -wrap none/);
+
+ $t->grid(qw/-sticky nsew/);
+ $f2->gridColumnconfigure(qw/0 -weight 1/);
+ $f2->gridRowconfigure(qw/0 -weight 1/);
+ $t->insert('1.0', 'This is just a normal text widget');
+
+ $pw->add($f1, $f2);
+
+} # end paned2
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo1.pl
new file mode 100755
index 00000000000..aed66103bb2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo1.pl
@@ -0,0 +1,30 @@
+# photo1.pl
+
+use vars qw/$TOP/;
+
+sub photo1 {
+
+ my($demo) = @_;
+
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This demonstration displays, for two seconds, a picture of a teapot over a green background, then proceeeds to render transparent a 50 x 50 pixel area of the teapot so that the green background shows through.',
+ -title => 'Transparent Pixels',
+ -iconname => 'photo1',
+ );
+
+ my $l = $TOP->Label( qw/ -background green -width 300 -height 300 / )->pack;
+
+ my $f1 = $TOP->Photo( -file => Tk->findINC( 'demos/images/teapot.ppm' ) );
+ $l->configure( -image => $f1 );
+ $TOP->idletasks;
+ $TOP->after(2000);
+
+ foreach my $x ( 50 .. 100 ) {
+ foreach my $y ( 50 .. 100 ) {
+ $f1->transparencySet( $x, $y, 1 );
+ $f1->update;
+ }
+ }
+
+} # end photo1
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo2.pl
new file mode 100755
index 00000000000..d55d8210423
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo2.pl
@@ -0,0 +1,156 @@
+# photo2.pl
+
+use vars qw/ $TOP $photo2_use_bg /;
+use strict;
+
+sub photo2 {
+
+ my( $demo ) = @_;
+
+ my $alpha; # transparency
+ my( $dx, $dy ) = ( 0, 0 ); # delta offsets
+ my $svar = 100; # Scale variable
+ $photo2_use_bg = 0; # nz IFF a green background
+
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => [ "This demonstration illustrates compositing. Commonly, each pixel of a color image is represented by three color components, red, green and blue, each specifiying a relative percentage of the color \"white\", such that, when the components are combined, they produce a visible color. Here are a few samples of 8-bit RGB triplets and the visible colors they produce:\n
+(255, 255, 255) = white (000, 000, 000) = black\n(255, 000, 000) = red (000, 255, 000) = green (000, 000, 255) = blue\n\nAn additional transparency factor can be supplied that describes the importance of each pixel's RGB components when composited over another image. This transparency channel is called the Alpha channel. Although the Alpha channel is said to contain transparency information, in fact, it actually contains opacity information.\n\nIt is still possible to think in terms of transparency, although in this case the transparency is applied to the background image over which the current image is composited. The composited color is computed as:\n\n (image_RGB_component * alpha) + (background_RGB_component * (1.0 - alpha))", -wraplength => 640 ],
+ -title => 'Alpha Channel Compositing',
+ -iconname => 'photo2',
+ );
+
+ my $mw = $TOP;
+ my $i1 = $mw->Photo( -file => Tk->findINC( 'demos/images/earth.gif' ) );
+ my $i2 = $mw->Photo( -file => Tk->findINC( 'demos/images/earthris.gif' ) );
+ my $i3 = $mw->Photo( qw/ -format png -width 320 -height 200 / );
+
+ my $tf = $mw->Frame;
+ $tf->Label( -image => $i2 )->pack( qw/ -side left / );
+ $tf->Label( -image => $i1 )->pack( qw/ -side left / );
+
+ my $bf = $mw->Frame;
+ my $controls = $bf->Frame;
+ my $results = $bf->Frame;
+
+ $controls->pack( qw/ -side left -fill both -expand 1/ ) ;
+ $results->pack( qw/ -side right/ );
+
+ $controls->Label(
+ -font => '9x15',
+ -foreground => 'blue',
+ -text => 'Left Image Options',
+ )->pack;
+ my $s = $controls->Scale(
+ qw/
+ -from 100.0
+ -resolution 10.0
+ -tickinterval 10.0
+ -to 0.0
+ /,
+ -label => '% Opacity',
+ -variable => \$svar,
+ );
+ $svar = 80;
+
+ my $spacer = $controls->Frame( qw/ -borderwidth 2 -relief solid -width 5/ );
+
+ my $rt = $controls->Label( -text => 'Background' );
+ my $r = $controls->Frame;
+ my $r1 = $r->Radiobutton(
+ -anchor => 'w',
+ -text => 'Right Image',
+ -value => 0,
+ -variable => \$photo2_use_bg,
+ -width => 20,
+ );
+ my $r2 = $r->Radiobutton(
+ -anchor => 'w',
+ -text => 'The Color Green',
+ -value => 1,
+ -variable => \$photo2_use_bg,
+ -width => 20,
+ );
+ $r2->pack( qw/ -side bottom/ );
+ $r1->pack( qw/ -side bottom/ );
+
+ my $b = $controls->Button(
+ -command => [ \&photo2_blend, $i1, $i2, $i3, $dx, $dy, \$svar ],
+ -text => 'Composite ==>>',
+ );
+
+ my $l = $results->Label( -image => $i3 );
+
+ $tf->pack;
+ $bf->pack( qw/-fill both -expand 1/ ) ;
+ $b->pack( qw/ -side bottom -fill x/ );
+ $s->pack( qw/ -side left -fill both -expand 1 / );
+ $spacer->pack( qw/ -side left -fill y -expand 1 / );
+ $rt->pack( qw/ -side top / );
+ $r->pack( qw/ -side right / );
+ $l->pack( qw/ -side right / );
+
+} # end photo2
+
+sub photo2_blend {
+
+ my( $img1, $img2, $img3, $dx, $dy, $svar_ref ) = @_;
+
+ my $a2 = $$svar_ref / 100.0;
+ my $a1 = 1.0 - $a2;
+
+ my $width1 = $img1->width;
+ my $height1 = $img1->height;
+ my $width2 = $img2->width;
+ my $height2 = $img2->height;
+
+ $img3->blank;
+
+ my $x1 = $dx;
+ my $x2 = 0;
+
+ for ( my $i = 0; $i < $width1; $i++ ) {
+ last if $i > $width2;
+ my $y1 = $dy;
+ my $y2 = 0;
+
+ for ( my $j = 0; $j < $height1; $j++ ) {
+ last if $j > $height2;
+
+ # Skip if no pixel at this coordinate or if transparent. Else,
+ # combine the proper percentage of each color component and
+ # put the pixel into the third image.
+
+ Tk::catch {
+ if ( not $img2->transparencyGet( $x2, $y2 ) ) {
+
+ my ( @c1 ) = $img1->get( $x1, $y1 );
+ my ( @c2 ) = $img2->get( $x2, $y2 );
+
+ # You can use a colored background rather than another
+ # image to test alpha channels. Uncomment this line to
+ # ignore the first image and force a green backround.
+ @c1 = ( 0, 255, 0 ) if $photo2_use_bg;
+
+ foreach my $c ( 0 .. 2 ) {
+ $c1[$c] = $c1[$c] * $a1 + $c2[$c] * $a2;
+ }
+
+ my $color = sprintf( "#%02x%02x%02x", @c1[0 .. 2] );
+ $img3->put( $color, -to => $x1, $y1 );
+
+ } # ifend
+ }; # catchend
+
+ $y1++;
+ $y2++;
+
+ } # forend $j
+
+ $img3->update;
+ $x1++;
+ $x2++;
+
+ } # forend $i
+
+} # end photo2_blend
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/plot.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/plot.pl
new file mode 100755
index 00000000000..1f7d3d03904
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/plot.pl
@@ -0,0 +1,28 @@
+# plot.pl
+
+use Plot;
+use vars qw/$TOP/;
+
+sub plot {
+
+ # Create a top-level window containing a canvas displaying a simple
+ # graph with data points that can be dragged with the pointing device.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1.\n\nYou can also select a printable area with the mouse button 2.",
+ -title => 'Plot Demonstration',
+ -iconname => 'plot',
+ );
+
+ my $c = $TOP->Plot(
+ -title_color => 'Brown',
+ -inactive_highlight => 'Skyblue2',
+ -active_highlight => 'red',
+ );
+ $c->pack(qw/-fill x/);
+
+} # end plot
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/progress.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/progress.pl
new file mode 100755
index 00000000000..5875ba1d2b8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/progress.pl
@@ -0,0 +1,46 @@
+# ProgressBar - display various progress bars.
+
+use strict;
+use Tk;
+use Tk::ProgressBar;
+use Tk::Scale;
+
+my $mw = MainWindow->new;
+
+my $status_var = 0;
+
+my($fromv,$tov) = (0,100);
+foreach my $loop (0..1) {
+ my $res = 0;
+ my $blks = 10;
+ my @p = qw(top bottom left right);
+ foreach my $dir (qw(n s w e)) {
+ $mw->ProgressBar(
+ -borderwidth => 2,
+ -relief => 'sunken',
+ -width => 20,
+ -padx => 2,
+ -pady => 2,
+ -variable => \$status_var,
+ -colors => [0 => 'green', 50 => 'yellow' , 80 => 'red'],
+ -resolution => $res,
+ -blocks => $blks,
+ -anchor => $dir,
+ -from => $fromv,
+ -to => $tov
+ )->pack(
+ -padx => 10,
+ -pady => 10,
+ -side => pop(@p),
+ -fill => 'both',
+ -expand => 1
+ );
+ $blks = abs($blks - ($res * 2));
+ $res = abs(5 - $res);
+ }
+ ($fromv,$tov) = ($tov,$fromv);
+}
+
+$mw->Scale(-from => 0, -to => 100, -variable => \$status_var)->pack;
+
+MainLoop;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/puzzle.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/puzzle.pl
new file mode 100755
index 00000000000..43910eca7e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/puzzle.pl
@@ -0,0 +1,86 @@
+# puzzle.pl
+
+use subs qw/puzzle_switch/;
+use vars qw/$TOP/;
+
+sub puzzle {
+
+ # Create a top-level window containing a 15-puzzle game.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right.',
+ -title => '15-Puzzle Demonstration',
+ -iconname => 'puzzle',
+ );
+
+ # Special trick: select a darker color for the space by creating a
+ # scrollbar widget and using its trough color.
+
+ my $s = $TOP->Scrollbar;
+ my $frame = $TOP->Frame(
+ -width => 120,
+ -height => 120,
+ -borderwidth => '2',
+ -relief => 'sunken',
+ -background => $s->cget(-troughcolor),
+ );
+ $frame->pack(qw/-side top -padx 1c -pady 1c/);
+ $s->destroy;
+
+ my(@order) = (3, 1, 6, 2, 5, 7, 15, 13, 4, 11, 8, 9, 14, 10, 12);
+ my %xpos = ();
+ my %ypos = ();
+
+ my($i, $num, $frame_num);
+ for ($i=0; $i<15; $i++) {
+ $num = $order[$i];
+ $xpos{$num} = ($i%4) * 0.25;
+ $ypos{$num} = (int($i/4)) * 0.25;
+ $frame_num = $frame->Button(
+ -relief => 'raised',
+ -text => $num,
+ -highlightthickness => 0,
+ );
+ $frame_num->configure(
+ -command => [\&puzzle_switch, $frame_num, $num, \%xpos, \%ypos],
+ );
+ $frame_num->place(
+ -relx => $xpos{$num},
+ -rely => $ypos{$num},
+ -relwidth => 0.25,
+ -relheight => 0.25,
+ );
+ } # forend all puzzle numbers
+ $xpos{'space'} = 0.75;
+ $ypos{'space'} = 0.75;
+
+} # end puzzle
+
+sub puzzle_switch {
+
+ # Procedure invoked by buttons in the puzzle to resize the puzzle entries.
+
+ my($w, $num, $xpos, $ypos) = @_;
+
+ if ( (($ypos->{$num} >= ($ypos->{'space'} - 0.01)) &&
+ ($ypos->{$num} <= ($ypos->{'space'} + 0.01))
+ && ($xpos->{$num} >= ($xpos->{'space'} - 0.26)) &&
+ ($xpos->{$num} <= ($xpos->{'space'} + 0.26)))
+ || (($xpos->{$num} >= ($xpos->{'space'} - 0.01)) &&
+ ($xpos->{$num} <= ($xpos->{'space'} + 0.01))
+ && ($ypos->{$num} >= ($ypos->{'space'} - 0.26)) &&
+ ($ypos->{$num} <= ($ypos->{'space'} + 0.26))) ) {
+ my $tmp = $xpos->{'space'};
+ $xpos->{'space'} = $xpos->{$num};
+ $xpos->{$num} = $tmp;
+ $tmp = $ypos->{'space'};
+ $ypos->{'space'} = $ypos->{$num};
+ $ypos->{$num} = $tmp;
+ $w->place(-relx => $xpos->{$num}, -rely => $ypos->{$num});
+ }
+
+} # end puzzle_switch
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/radio.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/radio.pl
new file mode 100755
index 00000000000..bae8c9daf3e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/radio.pl
@@ -0,0 +1,78 @@
+# radio.pl
+
+use Tk::widgets qw/LabFrame/;
+use vars qw/$TOP/;
+
+sub radio {
+
+ # Create a top-level window that displays a bunch of radio buttons.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Perl variable is associated with each group to indicate which of the group\'s buttons is selected. Click the "See Variables" button to see the current values of the variables.', qw/-wraplength 5i/],
+ -title => 'Radiobutton Demonstration',
+ -iconname => 'radio',
+ );
+
+ my $var = $TOP->Button(
+ -text => 'See Variables',
+ -command => [\&see_vars, $TOP, [
+ ['point size', \$POINT_SIZE],
+ ['color', \$COLOR],
+ ['alignment', \$ALIGN],
+ ]
+ ],
+ );
+ $var->pack(qw/-side bottom -expand 1/);
+
+ my @pl = qw/-side left -expand 1 -padx .5c -pady .5c/;
+ my $left = $TOP->LabFrame(-label => 'Point Size')->pack(@pl);
+ my $mid = $TOP->LabFrame(-label => 'Color')->pack(@pl);
+ my $right = $TOP->LabFrame(-label => 'Alignment')->pack(@pl);
+
+ @pl = qw/-side top -pady 2 -anchor w/;
+ foreach my $p (10, 12, 18, 24) {
+ $left->Radiobutton(
+ -text => "Point Size $p",
+ -variable => \$POINT_SIZE,
+ -relief => 'flat',
+ -value => $p,
+ )->pack(@pl);
+ }
+
+ foreach my $c (qw/Red Green Blue Yellow Orange Purple/) {
+ $mid->Radiobutton(
+ -text => $c,
+ -variable => \$COLOR,
+ -relief => 'flat',
+ -value => lc($c),
+ -command => sub {$mid->configure(-foreground => $c)},
+ )->pack(@pl);
+ }
+
+ my $l = $right->Label(qw/-text Label -bitmap questhead -compound left/);
+ $l->configure(-width => $l->reqwidth, -compound => 'top');
+ $l->configure(-height => $l->reqheight);
+ my %w;
+ foreach my $a (qw/Top Left Right Bottom/) {
+ my $lower = lc $a;
+ $w{$lower} = $right->Radiobutton(
+ -text => $a,
+ -variable => \$ALIGN,
+ -relief => 'flat',
+ -value => $lower,
+ -indicatoron => 0,
+ -width => 7,
+ -command => sub {
+ $l->configure(-compound => $ALIGN);
+ },
+ );
+ }
+ Tk::grid('x', $w{'top'});
+ $w{'left'}->grid($l, $w{'right'});
+ Tk::grid('x', $w{'bottom'});
+
+} # end radio
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ruler.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ruler.pl
new file mode 100755
index 00000000000..83e946f06e5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ruler.pl
@@ -0,0 +1,146 @@
+# ruler.pl
+
+use subs qw/ruler_make_tab ruler_move_tab ruler_new_tab ruler_release_tab
+ ruler_select_tab/;
+use vars qw/$TOP/;
+
+sub ruler {
+
+ # Create a canvas demonstration consisting of a ruler displays a ruler
+ # with tab stops that can be set individually.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.', qw/-wraplength 5i/],
+ -title => 'Ruler Demonstration',
+ -iconname => 'ruler',
+ );
+
+ my $c = $TOP->Canvas(qw/-width 14.8c -height 2.5c/);
+ $c->pack(qw/-side top -fill x/);
+
+ my %rinfo; # ruler information hash
+ $rinfo{grid} = '.25c';
+ $rinfo{left} = $c->fpixels('1c');
+ $rinfo{right} = $c->fpixels('13c');
+ $rinfo{top} = $c->fpixels('1c');
+ $rinfo{bottom} = $c->fpixels('1.5c');
+ $rinfo{size} = $c->fpixels('.2c');
+ $rinfo{normalStyle} = [qw/-fill black/];
+ if ($TOP->depth > 1) {
+ $rinfo{activeStyle} = [qw/-fill red -stipple/ => undef];
+ $rinfo{deleteStyle} = [
+ -fill => 'red',
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ ];
+ } else {
+ $rinfo{activeStyle} = [qw/-fill black -stipple/ => undef];
+ $rinfo{deleteStyle} = [
+ -fill => 'black',
+ -stipple => '@'.Tk->findINC('demos/images/grey.25'),
+ ];
+ }
+
+ $c->create(qw/line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1/);
+ my $i;
+ for ($i = 0; $i < 12; $i++) {
+ my $x = $i+1;
+ $c->create('line', "$x.c", '1c', "$x.c", '0.6c', -width => 1);
+ $c->create('line', "$x.25c", '1c', "$x.25c", '0.8c', -width => 1);
+ $c->create('line', "$x.5c", '1c', "$x.5c", '0.7c', -width => 1);
+ $c->create('line', "$x.75c", '1c', "$x.75c", '0.8c', -width => 1);
+ $c->create('text', "$x.15c", '.75c',-text => $i, -anchor => 'sw');
+ }
+ $c->addtag('well', 'withtag', $c->create(qw/rect 13.2c 1c 13.8c 0.5c
+ -outline black -fill/, ($c->configure(-bg))[4]));
+ $c->addtag('well', 'withtag', ruler_make_tab($c, $c->pixels('13.5c'),
+ $c->pixels('.65c'), \%rinfo));
+
+ $c->bind('well', '<1>' => [\&ruler_new_tab, \%rinfo]);
+ $c->bind('tab', '<1>' => [\&ruler_select_tab, \%rinfo]);
+ $c->Tk::bind('<B1-Motion>' => [\&ruler_move_tab, \%rinfo]);
+ $c->Tk::bind('<Any-ButtonRelease-1>', [\&ruler_release_tab, \%rinfo]);
+
+} # end ruler
+
+sub ruler_make_tab {
+
+ my($c, $x, $y, $rinfo) = @_;
+
+ return $c->create('polygon', $x, $y, $x+$rinfo->{size}, $y+$rinfo->{size},
+ $x-$rinfo->{size}, $y+$rinfo->{size});
+
+} # end ruler_make_tab
+
+sub ruler_move_tab {
+
+ my($c, $rinfo) = @_;
+
+ return if not defined $c->find('withtag', 'active');
+ my $e = $c->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ my $cx = $c->canvasx($x, $rinfo->{grid});
+ my $cy = $c->canvasy($y);
+ if ($cx < $rinfo->{left}) {
+ $cx = $rinfo->{left};
+ }
+ if ($cx > $rinfo->{right}) {
+ $cx = $rinfo->{right};
+ }
+ if (($cy >= $rinfo->{top}) and ($cy <= $rinfo->{bottom})) {
+ $cy = $rinfo->{top} + 2;
+ $c->itemconfigure('active', @{$rinfo->{activeStyle}});
+ } else {
+ $cy = $cy - $rinfo->{size} - 2;
+ $c->itemconfigure('active', @{$rinfo->{deleteStyle}});
+ }
+ $c->move('active', $cx-$rinfo->{'x'}, $cy-$rinfo->{'y'});
+ $rinfo->{'x'} = $cx;
+ $rinfo->{'y'} = $cy;
+
+} # end ruler_move_tab
+
+sub ruler_new_tab {
+
+ my($c, $rinfo) = @_;
+
+ my $e = $c->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $c->addtag('active', 'withtag', ruler_make_tab($c, $x, $y, $rinfo));
+ $c->addtag('tab', 'withtag', 'active');
+ $rinfo->{'x'} = $x;
+ $rinfo->{'y'} = $y;
+ ruler_move_tab($c, $rinfo);
+
+} # end ruler_new_tab
+
+sub ruler_release_tab {
+
+ my($c, $rinfo) = @_;
+
+ return if not defined $c->find('withtag', 'active');
+ if ($rinfo->{'y'} != $rinfo->{top} + 2) {
+ $c->delete('active');
+ } else {
+ $c->itemconfigure('active', @{$rinfo->{normalStyle}});
+ $c->dtag('active');
+ }
+
+} # end ruler_release_tab
+
+sub ruler_select_tab {
+
+ my($c, $rinfo) = @_;
+
+ my $e = $c->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $rinfo->{'x'} = $c->canvasx($x, $rinfo->{grid});
+ $rinfo->{'y'} = $rinfo->{top} + 2;
+ $c->addtag('active', 'withtag', 'current');
+ $c->itemconfigure('active', @{$rinfo->{activeStyle}});
+ $c->raise('active');
+
+} # end ruler_select_tab
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/sayings.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/sayings.pl
new file mode 100755
index 00000000000..cd9ec5bd898
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/sayings.pl
@@ -0,0 +1,48 @@
+# sayings.pl
+
+use vars qw/$TOP/;
+
+sub sayings {
+
+ # Create a top-level window containing a listbox with a bunch of
+ # well-known sayings. The listbox can be scrolled or scanned in
+ # two dimensions.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed.',
+ -title => 'Listbox Demonstration (well-known sayings)',
+ -iconname => 'sayings',
+ );
+
+ my $list = $TOP->Scrolled(qw/Listbox -width 20 -height 10 -setgrid 1
+ -scrollbars se/);
+ $list->pack(qw/-expand yes -fill y/);
+ $list->focus;
+
+ $list->insert(0,
+ 'Waste not, want not',
+ 'Early to bed and early to rise makes a man healthy, wealthy, and wise',
+ 'Ask not what your country can do for you, ask what you can do for your country',
+ 'I shall return',
+ 'NOT',
+ 'A picture is worth a thousand words',
+ 'User interfaces are hard to build',
+ 'Thou shalt not steal',
+ 'A penny for your thoughts',
+ 'Fool me once, shame on you; fool me twice, shame on me',
+ 'Every cloud has a silver lining',
+ 'Where there\'s smoke there\'s fire',
+ 'It takes one to know one',
+ 'Take this job and shove it',
+ 'Up a creek without a paddle',
+ 'I\'m mad as hell and I\'m not going to take it any more',
+ 'An apple a day keeps the doctor away',
+ 'Don\'t look a gift horse in the mouth');
+
+ $list->activate(0);
+
+} # end sayings
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/search.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/search.pl
new file mode 100755
index 00000000000..ddc42213a0f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/search.pl
@@ -0,0 +1,177 @@
+# search.pl
+
+use Tk::LabEntry;
+use subs qw/search_flash_matches search_load_file search_text/;
+use vars qw/$TOP/;
+
+sub search {
+
+ # Create a top-level window with a text widget that allows you to load a
+ # file and highlight all instances of a given string. A LabEntry widget
+ # is used to collect the file name and search string.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text =>'',
+ -title => 'Text Demonstration - Search and Highlight',
+ -iconname => 'search',
+ );
+
+ my $file_name = '';
+ my $file = $TOP->Frame;
+ my $fn = $file->LabEntry(-label => 'File Name: ', -width => 40,
+ -labelPack => [qw/-side left -anchor w/],
+ -textvariable => \$file_name)->pack(qw/-side left/);
+ $fn->Subwidget('entry')->focus;
+ my $fn_button = $file->Button(-text => 'Load File');
+ $fn_button->pack(qw/-side left -pady 5 -padx 10/);
+
+ my $search_string = '';
+ my $kind = 'exact';
+ my $string = $TOP->Frame;
+ my $ss = $string->LabEntry(-label => 'Search string:', -width => 40,
+ -labelPack => [qw/-side left -anchor w/],
+ -textvariable => \$search_string)->pack(qw/-side left/);
+ my $ss_button = $string->Button(-text => 'Highlight');
+ $ss_button->pack(qw/-side left -pady 5 -padx 10/);
+
+ my $text = $TOP->Scrolled(qw/Text -setgrid true -scrollbars e/);
+
+ my $subframe = $TOP->Frame;
+ my $exact = $subframe->Radiobutton(-text => 'Exact match',
+ -variable => \$kind,
+ -value => 'exact');
+ my $regexp = $subframe->Radiobutton(-text => 'Regular expression',
+ -variable => \$kind,
+ -value => 'regexp');
+ $exact->pack(qw/-side left/, -fill => 'x');
+ $regexp->pack(qw/-side right/, -fill => 'x');
+
+ $file->pack(qw/-side top -fill x/);
+ $string->pack(qw/-side top -fill x/);
+ $subframe->pack(qw/-side top -fill x/);
+ $text->pack(qw/-expand yes -fill both/);
+
+ my $command = sub {search_load_file $text, \$file_name, $ss};
+ $fn_button->configure(-command => $command);
+ $fn->bind('<Return>' => $command);
+
+ $command = sub {search_text $text, \$search_string, 'search', $kind};
+ $ss_button->configure(-command => $command);
+ $ss->bind('<Return>' => $command);
+
+ # Set up display styles for text highlighting.
+
+ if ($TOP->depth > 1) {
+ search_flash_matches $text,
+ ['configure', 'search',
+ -background => '#ce5555', -foreground => 'white'], 800,
+ ['configure', 'search',
+ -background => undef, -foreground => undef], 200;
+ } else {
+ search_flash_matches $text,
+ ['configure', 'search',
+ -background => 'black', -foreground => 'white'], 800,
+ ['configure', 'search',
+ -background => undef, -foreground => undef], 200;
+ }
+
+ $text->insert('0.0', 'This window demonstrates how to use the tagging facilities in text
+widgets to implement a searching mechanism. First, type a file name
+in the top entry, then type <Return> or click on "Load File". Then
+type a string in the lower entry and type <Return> or click on
+"Highlight". This will cause all of the instances of the string to
+be tagged with the tag "search", and it will arrange for the tag\'s
+display attributes to change to make all of the strings blink.');
+
+ $text->mark(qw/set insert 0.0/);
+
+} # end search
+
+sub search_flash_matches {
+
+ # The procedure below is invoked repeatedly to invoke two commands at
+ # periodic intervals. It normally reschedules itself after each execution
+ # but if an error occurs (e.g. because the window was deleted) then it
+ # doesn't reschedule itself.
+ # Arguments:
+ #
+ # w - Text widget reference.
+ # cmd1 - Reference to a list of tag options.
+ # sleep1 - Ms to sleep after executing cmd1 before executing cmd2.
+ # cmd2 - Reference to a list of tag options.
+ # sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again.
+
+ my($w, $cmd1, $sleep1, $cmd2, $sleep2) = @_;
+
+ $w->tag(@{$cmd1});
+ $w->after($sleep1,
+ [\&search_flash_matches, $w, $cmd2, $sleep2, $cmd1, $sleep1]);
+
+} # end search_flash_matches
+
+sub search_load_file {
+
+ # The utility procedure below loads a file into a text widget, discarding
+ # the previous contents of the widget. Tags for the old widget are not
+ # affected, however.
+ # Arguments:
+ #
+ # w - The window into which to load the file. Must be a text widget.
+ # file - Reference to the name of the file to load. Must be readable.
+ # e - Entry widget to get next focus.
+
+ my ($w, $file, $e) = @_;
+
+ my ($buf, $bytes) = ('', 0);
+
+ if (not open(F, "<$$file")) {
+ $MW->Dialog(
+ -title => 'File Not Found',
+ -text => "$!: '$$file'",
+ -bitmap => 'error',
+ )->Show;
+ return;
+ }
+ $w->delete(qw/1.0 end/);
+ $bytes = read F, $buf, 10_000; # after all, it IS just an example
+ $w->insert('end', $buf);
+ if ($bytes == 10000) {
+ $w->insert('end', "\n\n**************** File truncated at 10,000 bytes! ****************\n");
+ }
+ close F;
+
+ $e->Subwidget('entry')->focus;
+
+} # end search_load_file
+
+sub search_text {
+
+ # The utility procedure below searches for all instances of a given
+ # string in a text widget and applies a given tag to each instance found.
+ # Arguments:
+ #
+ # w - The window in which to search. Must be a text widget.
+ # string - Reference to the string to search for. The search is done
+ # using exact matching only; no special characters.
+ # tag - Tag to apply to each instance of a matching string.
+
+ my($w, $string, $tag, $kind) = @_;
+
+ return unless ref($string) && length($$string);
+
+ $w->tagRemove($tag, qw/0.0 end/);
+ my($current, $length) = ('1.0', 0);
+
+ while (1) {
+ $current = $w->search(-count => \$length, "-$kind", $$string, $current, 'end');
+ last if not $current;
+ warn "Posn=$current count=$length\n",
+ $w->tagAdd($tag, $current, "$current + $length char");
+ $current = $w->index("$current + $length char");
+ }
+
+} # end search_text
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/showVars.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/showVars.pl
new file mode 100755
index 00000000000..0130ccd153b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/showVars.pl
@@ -0,0 +1,37 @@
+
+
+sub showVars {
+
+ # Create a top-level window that displays a bunch of global variable values
+ # and keeps the display up-to-date even when the variables change value.
+ #
+ # Arguments:
+ # w - Perl widget reference of parent.
+ # vars - Name of variable(s) to monitor.
+
+ $showVars->destroy if Exists($showVars);
+ $showVars = shift->Toplevel();
+ my $w = $showVars;
+ dpos($w);
+ $w->title('Variable values');
+ $w->iconname('Variables');
+
+ my $w_title = $w->Label(-text => 'Variable values:', -width => 20, -anchor, 'center',
+ -font => '-Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-*');
+ $w_title->pack(-fill => 'x');
+ my $i;
+ foreach $i (@_) {
+ my $w_i = $w->Frame();
+ my $w_i_name = $w_i->Label(-text => "$i: ");
+ my $w_i_value = $w_i->Label(-textvariable => \${$i});
+ $w_i_name->pack(-side => 'left');
+ $w_i_value->pack(-side => 'left');
+ $w_i->pack(-side => 'top', -anchor => 'w');
+ }
+ $w->Button(-text => 'OK', -command => [$w => 'destroy'])->
+ pack(-side => 'bottom', -pady => 2);
+
+} # end showVars
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/slide.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/slide.pl
new file mode 100755
index 00000000000..7bd31a0b369
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/slide.pl
@@ -0,0 +1,178 @@
+# slide.pl
+
+$Tk::SlideSwitch::VERSION = '1.1';
+
+package Tk::SlideSwitch;
+
+use Tk;
+use Tk::widgets qw/Label Scale/;
+use base qw/Tk::Frame/;
+use strict;
+
+Construct Tk::Widget 'SlideSwitch';
+
+sub Populate {
+
+ my($self, $args) = @_;
+
+ $self->SUPER::Populate($args);
+
+ my $ll = $self->Label->pack(-side => 'left');
+ my $sl = $self->Scale->pack(-side => 'left');
+ my $rl = $self->Label->pack(-side => 'left');
+
+ $self->ConfigSpecs(
+ -command => [$sl, qw/command Command /],
+ -from => [$sl, qw/from From 0/],
+ -highlightthickness => [$sl,
+ qw/highlightThickness HighlightThickness 0/],
+ -length => [$sl, qw/length Length 30/],
+ -llabel => [qw/METHOD llabel Llabel /],
+ -orient => [$sl, qw/orient Orient horizontal/],
+ -rlabel => [qw/METHOD rlabel Rlabel /],
+ -showvalue => [$sl, qw/showValue ShowValue 0/],
+ -sliderlength => [$sl, qw/sliderLength SliderLength 15/],
+ -sliderrelief => [$sl, qw/sliderRelief SliderRelief raised/],
+ -to => [$sl, qw/to To 1/],
+ -troughcolor => [$sl, qw/troughColor TroughColor /],
+ -width => [$sl, qw/width Width 8/],
+ -variable => [$sl, qw/variable Variable /],
+ 'DEFAULT' => [$ll, $rl],
+ );
+
+ $self->{ll} = $ll;
+ $self->{sl} = $sl;
+ $self->{rl} = $rl;
+
+ $self->bind('<Configure>' => sub {
+ my ($self) = @_;
+ my $orient = $self->cget(-orient);
+ return if $orient eq 'horizontal';
+ my ($ll, $sl, $rl) = ($self->{ll}, $self->{sl}, $self->{rl});
+ $ll->packForget;
+ $sl->packForget;
+ $rl->packForget;
+ $ll->pack;
+ $sl->pack;
+ $rl->pack;
+ });
+
+} # end Populate
+
+# Private methods and subroutines.
+
+sub llabel {
+ my ($self, $args) = @_;
+ $self->{ll}->configure(@$args);
+} # end llabel
+
+sub rlabel {
+ my ($self, $args) = @_;
+ $self->{rl}->configure(@$args);
+} # end rlabel
+
+1;
+
+package main;
+
+use vars qw / $TOP /;
+use strict;
+
+sub slide {
+
+ my( $demo ) = @_;
+
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => "This demonstration creates a new composite SlideSwitch widget that can be either on or off. The widget is really a customized Scale widget.",
+ -title => 'A binary sliding switch',
+ -iconname => 'slide',
+ );
+
+ my $mw = $TOP;
+
+ my $sl = $mw->SlideSwitch(
+ -bg => 'gray',
+ -orient => 'horizontal',
+ -command => sub {print "Switch value is @_\n"},
+ -llabel => [-text => 'OFF', -foreground => 'blue'],
+ -rlabel => [-text => 'ON', -foreground => 'blue'],
+ -troughcolor => 'tan',
+ )->pack(qw/-side left -expand 1/);
+
+} # end slide
+
+__END__
+
+=head1 NAME
+
+Tk::SlideSwitch - a 2 position horizontal or vertical switch.
+
+=head1 SYNOPSIS
+
+ use Tk::SlideSwitch;
+
+ my $sl = $frame1->SlideSwitch(
+ -bg => 'gray',
+ -orient => 'horizontal',
+ -command => [$self => 'on'],
+ -llabel => [-text => 'OFF', -foreground => 'blue'],
+ -rlabel => [-text => 'ON', -foreground => 'blue'],
+ -troughcolor => 'tan',
+ )->pack(qw/-side left -expand 1/);
+
+=head1 DESCRIPTION
+
+Tk::SlideSwitch is a Frame based composite mega-widget featuring a binary Scale
+widget surrounded by two Label widgets. The Scale's value can be either 0 or
+1. The Labels are positioned to the left and right of the Scale if its
+orientation is horizontal, else on the top and bottom of the Scale.
+
+=head1 OPTIONS
+
+In addition to all Scale options, the following option/value pairs are
+also supported:
+
+=over 4
+
+=item B<-llabel>
+
+A reference to an array of left (or top) Label configuration options.
+
+=item B<-rlabel>
+
+A reference to an array of right (or bottom) Label configuration options.
+
+=back
+
+=head1 METHODS
+
+There are no special methods.
+
+=head1 ADVERTISED WIDGETS
+
+Component subwidgets can be accessed via the B<Subwidget> method.
+This mega widget has no advertised subwidgets.
+
+=head1 EXAMPLE
+
+See Synopsis.
+
+=head1 BUGS
+
+This widget uses only the pack geometry manager.
+
+=head1 AUTHOR
+
+sol0@Lehigh.EDU
+
+Copyright (C) 2002 - 2003, Steve Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 KEYWORDS
+
+SlideSwitch, Scale
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/spin.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/spin.pl
new file mode 100755
index 00000000000..f9b8c05a891
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/spin.pl
@@ -0,0 +1,36 @@
+# spin.pl
+
+use vars qw/$TOP/;
+
+sub spin {
+
+ # This demonstration script creates several spinbox widgets.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['Three different spin-boxes are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For values that are too large to fit in the window all at once, you can scan through the value by dragging with mouse button2 pressed. Note that the first spin-box will only permit you to type in integers, and the third selects from a list of Australian cities.',
+ -wraplength => '5i'],
+ -title => 'Spinbox Demonstration',
+ -iconname => 'spin',
+ );
+
+ my $s1 = $TOP->Spinbox(
+ qw/-from 1 -to 10 -width 10 -validate key/,
+ -validatecommand => sub {
+ my ($proposed, $changes, $current, $index, $type) = @_;
+ return not $proposed =~ m/[^\d]/g;
+ },
+ );
+ my $s2 = $TOP->Spinbox(
+ qw/-from 0 -to 3 -increment .5 -format %05.2f -width 10/,
+ );
+ my $s3 = $TOP->Spinbox(
+ -values => [qw/Canberra Sydney Melbourne Perth Adelaide Brisbane Hobart
+ Darwin/, 'Alice Springs'],
+ -width => 10,
+ );
+
+ $s1->pack($s2, $s3, qw/-side top -pady 5 -padx 10/);
+
+} # end spin.pl
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/states.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/states.pl
new file mode 100755
index 00000000000..b9b350df952
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/states.pl
@@ -0,0 +1,28 @@
+# states.pl
+
+use vars qw/$TOP/;
+
+sub states {
+
+ # Create a top-level window that displays a listbox with the names of the
+ # 50 states.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down.',
+ -title => 'Listbox Demonstration (50 states)',
+ -iconname => 'states',
+ );
+
+ my $list = $TOP->Scrolled(qw/Listbox -setgrid 1 -height 12 -scrollbars e/);
+ $list->pack(qw/-side left -expand yes -fill both/);
+ $list->focus;
+
+ $list->insert(0, qw/Alabama Alaska Arizona Arkansas California Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois Indiana Iowa Kansas Kentucky Louisiana Maine Maryland Massachusetts Michigan Minnesota Mississippi Missouri Montana Nebraska Nevada/, 'New Hampshire', 'New Jersey', 'New Mexico', 'New York', 'North Carolina', 'North Dakota', qw/Ohio Oklahoma Oregon Pennsylvania/, 'Rhode Island', 'South Carolina', 'South Dakota', qw/Tennessee Texas Utah Vermont Virginia Washington/, 'West Virginia', 'Wisconsin', 'Wyoming');
+
+ $list->activate(0);
+
+} # end states
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/style.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/style.pl
new file mode 100755
index 00000000000..d7fd82112ea
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/style.pl
@@ -0,0 +1,154 @@
+# style.pl
+
+use vars qw/$TOP/;
+
+sub style {
+
+ # Create a top-level window with a text widget that demonstrates
+ # the various display styles that are available in texts.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text =>'',
+ -title => 'Text Demonstration - Display Styles',
+ -iconname => 'style',
+ );
+
+ eval { # eval, in case fonts already exist
+ $TOP->fontCreate(qw/C_small -family courier -size 10/);
+ $TOP->fontCreate(qw/C_big -family courier -size 14 -weight bold/);
+ $TOP->fontCreate(qw/C_vbig -family helvetica -size 24 -weight bold/);
+ $TOP->fontCreate(qw/C_bold -family courier -size 12 -weight bold
+ -slant italic/);
+ };
+
+ my $t = $TOP->Scrolled(qw/Text -setgrid true -width 70 -height 32
+ -font normal -wrap word -scrollbars e/);
+ $t->pack(qw/-expand yes -fill both/);
+
+ # Set up display styles.
+
+ $t->tag(qw/configure bold -font C_bold/);
+ $t->tag(qw/configure big -font C_big/);
+ $t->tag(qw/configure verybig -font C_vbig/);
+ if ($TOP->depth > 1) {
+ $t->tag(qw/configure color1 -background/ => '#a0b7ce');
+ $t->tag(qw/configure color2 -foreground red/);
+ $t->tag(qw/configure raised -relief raised -borderwidth 1/);
+ $t->tag(qw/configure sunken -relief sunken -borderwidth 1/);
+ } else {
+ $t->tag(qw/configure color1 -background black -foreground white/);
+ $t->tag(qw/configure color2 -background black -foreground white/);
+ $t->tag(qw/configure raised -background white -relief raised -bd 1/);
+ $t->tag(qw/configure sunken -background white -relief sunken -bd 1/);
+ }
+ $t->tag(qw/configure bgstipple -background black -borderwidth 0
+ -bgstipple gray12/);
+ $t->tag(qw/configure fgstipple -fgstipple gray50/);
+ $t->tag(qw/configure underline -underline on/);
+ $t->tag(qw/configure overstrike -overstrike on/);
+ $t->tag(qw/configure right -justify right/);
+ $t->tag(qw/configure center -justify center/);
+ $t->tag(qw/configure super -offset 4p -font C_small/);
+ $t->tag(qw/configure sub -offset -2p -font C_small/);
+ $t->tag(qw/configure margins -lmargin1 12m -lmargin2 6m -rmargin 10m/);
+ $t->tag(qw/configure spacing -spacing1 10p -spacing2 2p
+ -lmargin1 12m -lmargin2 6m -rmargin 10m/);
+
+ $t->insert('0.0', 'Text widgets like this one allow you to display ' .
+ 'information in a variety of styles. Display styles are ' .
+ 'controlled using a mechanism called ');
+ $t->insert('insert', 'tags', 'bold');
+ $t->insert('insert', '. Tags are just textual names that you can apply ' .
+ 'to one or more ranges of characters within a text widget. ' .
+ 'You can configure tags with various display styles. If ' .
+ 'you do this, then the tagged characters will be displayed ' .
+ 'with the styles you chose. The available display styles ' .
+ 'are: ');
+ $t->insert('insert', "\n\n1. Font.", 'big');
+ $t->insert('insert', ' You can choose any X font, ');
+ $t->insert('insert', 'large', 'verybig');
+ $t->insert('insert', ' or small.');
+ $t->insert('insert', "\n\n2. Color.", 'big');
+ $t->insert('insert', ' You can change either the ');
+ $t->insert('insert', 'background', 'color1');
+ $t->insert('insert', ' or ');
+ $t->insert('insert', 'foreground', 'color2');
+ $t->insert('insert', "\ncolor, or ");
+ $t->insert('insert', 'both', ['color1', 'color2']);
+ $t->insert('insert', '.');
+ $t->insert('insert', "\n\n3. Stippling.", 'big');
+ $t->insert('insert', ' You can cause either the ');
+ $t->insert('insert', 'background', 'bgstipple');
+ $t->insert('insert', ' or ');
+ $t->insert('insert', 'foreground', 'fgstipple');
+ $t->insert('insert', "\ninformation to be drawn with a stipple fill instead of a solid fill.");
+ $t->insert('insert', "\n\n4. Underlining.", 'big');
+ $t->insert('insert', ' You can ');
+ $t->insert('insert', 'underline', 'underline');
+ $t->insert('insert', ' ranges of text.');
+ $t->insert('insert', "\n\n5. Overstrikes.", 'big');
+ $t->insert('insert', " You can ");
+ $t->insert('insert', "draw lines through", 'overstrike');
+ $t->insert('insert', " ranges of text.");
+ $t->insert('insert', "\n\n6. 3-D effects.", ' big');
+ $t->insert('insert', " You can arrange for the background to be drawn ");
+ $t->insert('insert', 'with a border that makes characters appear either ');
+ $t->insert('insert', 'raised', 'raised');
+ $t->insert('insert', ' or ');
+ $t->insert('insert', 'sunken', 'sunken');
+ $t->insert('insert', '.');
+ $t->insert('insert', "\n\n7. Justification.", 'big');
+ $t->insert('insert', " You can arrange for lines to be displayed\n");
+ $t->insert('insert', "left-justified,\n");
+ $t->insert('insert', "right-justified, or\n", 'right');
+ $t->insert('insert', "centered.", 'center');
+ $t->insert('insert', "\n\n8. Superscripts and subscripts." , 'big');
+ $t->insert('insert', " You can control the vertical ");
+ $t->insert('insert', "position of text to generate superscript effects " .
+ "like 10");
+ $t->insert('insert', "n", 'super');
+ $t->insert('insert', " or subscript effects like X");
+ $t->insert('insert', "i", 'sub');
+ $t->insert('insert', ".");
+ $t->insert('insert', "\n\n9. Margins.", 'big');
+ $t->insert('insert', " You can control the amount of extra space left");
+ $t->insert('insert', " on\neach side of the text:\n");
+ $t->insert('insert', "This paragraph is an example of the use of ", 'margins');
+ $t->insert('insert', "margins. It consists of a single line of text ", 'margins');
+ $t->insert('insert', "that wraps around on the screen. There are two ", 'margins');
+ $t->insert('insert', "separate left margin values, one for the first ", 'margins');
+ $t->insert('insert', "display line associated with the text line, ", 'margins');
+ $t->insert('insert', "and one for the subsequent display lines, which ", 'margins');
+ $t->insert('insert', "occur because of wrapping. There is also a ", 'margins');
+ $t->insert('insert', "separate specification for the right margin, ", 'margins');
+ $t->insert('insert', "which is used to choose wrap points for lines.", 'margins');
+
+ $t->insert('insert', "\n\n10. Spacing.", 'big');
+ $t->insert('insert', " You can control the spacing of lines with three ");
+ $t->insert('insert', "separate parameters. \"Spacing1\" tells how much ");
+ $t->insert('insert', "extra space to leave\nabove a line, \"spacing3\" ");
+ $t->insert('insert', "tells how much space to leave below a line,\nand ");
+ $t->insert('insert', "if a text line wraps, \"spacing2\" tells how much ");
+ $t->insert('insert', "space to leave\nbetween the display lines that ");
+ $t->insert('insert', "make up the text line.\n");
+ $t->insert('insert', "These indented paragraphs illustrate how spacing ", 'spacing');
+ $t->insert('insert', "can be used. Each paragraph is actually a ", 'spacing');
+ $t->insert('insert', "single line in the text widget, which is ", 'spacing');
+ $t->insert('insert', "word-wrapped by the widget.\n", 'spacing');
+ $t->insert('insert', "Spacing1 is set to 10 points for this text, ", 'spacing');
+ $t->insert('insert', "which results in relatively large gaps between ", 'spacing');
+ $t->insert('insert', "the paragraphs. Spacing2 is set to 2 points, ", 'spacing');
+ $t->insert('insert', "which results in just a bit of extra space ", 'spacing');
+ $t->insert('insert', "within a pararaph. Spacing3 isn't used ", 'spacing');
+ $t->insert('insert', "in this example.\n", 'spacing');
+ $t->insert('insert', "To see where the space is, select ranges of ", 'spacing');
+ $t->insert('insert', "text within these paragraphs. The selection ", 'spacing');
+ $t->insert('insert', "highlight will cover the extra space.", 'spacing');
+
+ $t->mark(qw/set insert 0.0/);
+
+} # end style
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/texts.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/texts.pl
new file mode 100755
index 00000000000..3a2dc0115d8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/texts.pl
@@ -0,0 +1,71 @@
+# texts.pl
+
+use vars qw/$TOP/;
+
+sub texts {
+
+ # Create a top-level window that displays a basic text widget.
+
+ my ($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => '',
+ -title => 'Text Demonstration - Basic Facilities',
+ -iconname => 'texts',
+ );
+
+ my $t = $TOP->Scrolled(qw/Text -relief sunken -borderwidth 2 -setgrid true
+ -height 30 -scrollbars e/);
+ $t->pack(qw/-expand yes -fill both/);
+
+ $t->insert('0.0', 'This window is a text widget. It displays one or more lines of text
+and allows you to edit the text. Here is a summary of the things you
+can do to a text widget:
+
+1. Scrolling. Use the scrollbar to adjust the view in the text window.
+
+2. Scanning. Press mouse button 2 in the text window and drag up or down.
+This will drag the text at high speed to allow you to scan its contents.
+
+3. Insert text. Press mouse button 1 to set the insertion cursor, then
+type text. What you type will be added to the widget.
+
+4. Select. Press mouse button 1 and drag to select a range of characters.
+Once you\'ve released the button, you can adjust the selection by pressing
+button 1 with the shift key down. This will reset the end of the
+selection nearest the mouse cursor and you can drag that end of the
+selection by dragging the mouse before releasing the mouse button.
+You can double-click to select whole words or triple-click to select
+whole lines.
+
+5. Delete and replace. To delete text, select the characters you\'d like
+to delete and type Backspace or Delete. Alternatively, you can type new
+text, in which case it will replace the selected text.
+
+6. Copy the selection. To copy the selection into this window, select
+what you want to copy (either here or in another application), then
+click button 2 to copy the selection to the point of the mouse cursor.
+
+7. Edit. Text widgets support the standard Motif editing characters
+plus many Emacs editing characters. Backspace and Control-h erase the
+character to the left of the insertion cursor. Delete and Control-d
+erase the character to the right of the insertion cursor. Meta-backspace
+deletes the word to the left of the insertion cursor, and Meta-d deletes
+the word to the right of the insertion cursor. Control-k deletes from
+the insertion cursor to the end of the line, or it deletes the newline
+character if that is the only thing left on the line. Control-o opens
+a new line by inserting a newline character to the right of the insertion
+cursor. Control-t transposes the two characters on either side of the
+insertion cursor.
+
+7. Resize the window. This widget has been configured with the "setGrid"
+option on, so that if you resize the window it will always resize to an
+even number of characters high and wide. Also, if you make the window
+narrow you can see that long lines automatically wrap around onto
+additional lines so that all the information is always visible.');
+
+ $t->mark(qw/set insert 0.0/);
+
+} # end texts
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace1.pl
new file mode 100755
index 00000000000..eba655c7ba0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace1.pl
@@ -0,0 +1,49 @@
+# trace1.pl
+
+use Tk::widgets qw/ Trace /;
+use vars qw/ $TOP /;
+use strict;
+
+sub trace1 {
+
+ my( $demo ) = @_;
+
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => "This demonstration animates an analog display as you move the Scale's slider.",
+ -title => 'Move a meter tied to a variable',
+ -iconname => 'trace1',
+ );
+
+ my $mw = $TOP;
+ my $v; # variable to trace
+
+ my $c = $mw->Canvas(qw/-width 200 -height 110 -bd 2 -relief sunken/)->grid;
+ $c->createLine(qw/ 100 100 10 100 -tag meter -arrow last -width 5/);
+ my $s = $mw->Scale(qw/-orient h -from 0 -to 100 -variable/ => \$v)->grid;
+ $mw->Label(-text => 'Slide Me')->grid;
+
+ # Trace $v when written. The callback is supplied three explicit arguments:
+ # the index if an array or hash, else undef, the proposed new value, and the
+ # trace operation (rwu) for read, write, undef, respectively. Additionally,
+ # we pass the Canvas and Scale widget references.
+
+ $mw->traceVariable(\$v, 'w' => [\&trace1_update_meter, $c, $s]);
+
+} # end trace1
+
+sub trace1_update_meter {
+
+ my( $index, $value, $op, $c, $s ) = @_;
+
+ return if $op eq 'u';
+
+ my($min, $max) = ($s->cget(-from), $s->cget(-to));
+ my $pos = $value / abs($max - $min);
+ my $pi = 3.1415926;
+ my $x = 100.0 - 90.0 * (cos( $pos * $pi ));
+ my $y = 100.0 - 90.0 * (sin( $pos * $pi ));
+ $c->coords(qw/meter 100 100/, $x, $y);
+ return $value;
+
+ } # end trace1_update_meter
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace2.pl
new file mode 100755
index 00000000000..9d7c38806d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace2.pl
@@ -0,0 +1,188 @@
+# trace2.pl
+
+$Tk::TraceText::VERSION = '1.0';
+
+package Tk::TraceText;
+
+use Tk::widgets qw/ Trace /;
+use base qw/ Tk::Derived Tk::Text /;
+use strict;
+
+Construct Tk::Widget 'TraceText';
+
+sub Populate {
+
+ my( $self, $args ) = @_;
+
+ $self->SUPER::Populate( $args );
+
+ $self->ConfigSpecs(
+ -textvariable => [ 'METHOD', 'textVariable', 'TextVariable', undef ],
+ );
+
+ $self->OnDestroy( sub {
+ my $vref = $self->{_vref};
+ $self->traceVdelete ( $vref ) if defined $vref;
+ } );
+
+} # end Populate
+
+# Private methods.
+
+sub insdel {
+
+ my( $self, $sub, @args ) = @_;
+
+ $self->{_busy} = 1;
+ $self->$sub( @args );
+ my $vref = $self->{_vref};
+ $$vref = $self->get( qw/1.0 end/ );
+ $self->{_busy} = 0;
+
+} # end insedel
+
+sub textvariable {
+
+ my ( $self, $vref ) = @_;
+
+ $self->traceVariable( $vref, 'w', [ \&tracew => $self, $vref ] );
+ $self->{_vref} = $vref;
+
+} # end textvariable
+
+sub tracew {
+
+ my ( $index, $value, $op, $self, $vref ) = @_;
+
+ return unless defined $self; # if app is being destroyed
+ return if $self->{_busy};
+
+ if ( $op eq 'w' ) {
+ $self->delete( qw/1.0 end/ );
+ $self->insert( '1.0', $value );
+ } elsif ( $op eq 'r' ) {
+ } elsif ( $op eq 'u' ) {
+ $self->traceVdelete ( $vref );
+ }
+
+} # end tracew
+
+# Overridden methods.
+
+sub delete {
+
+ my ( $self, @args ) = @_;
+
+ $self->insdel( 'SUPER::delete', @args )
+
+} # end delete
+
+sub insert {
+
+ my ( $self, @args ) = @_;
+
+ $self->insdel( 'SUPER::insert', @args );
+
+} # end insert
+
+1;
+
+package main;
+
+use Tk::widgets qw/ Trace /;
+use vars qw / $TOP /;
+use strict;
+
+sub trace2 {
+
+ my( $demo ) = @_;
+
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => "This demonstration derives a new Text widget whose contents are modified using a normal Perl variable.",
+ -title => 'Contents of a Text widget tied to a variable',
+ -iconname => 'trace2',
+ );
+
+ my $mw = $TOP;
+ my $tt = $mw->Scrolled( 'TraceText', -textvariable => \my $frog )->grid;
+ $tt->focus;
+
+ $mw->traceVariable( \$frog, 'wu', [ \&trace2_tracefrog, $mw, \$frog ] );
+
+ $frog = "Frogs lacking lipophores are blue.";
+
+} # end trace2
+
+sub trace2_tracefrog {
+
+ my( $index, $value, $op ) = @_;
+
+ print "Final " if $op eq 'u';
+ print "User trace: $value";
+ return $value;
+
+}
+
+__END__
+
+=head1 NAME
+
+Tk::TraceText - Text contents defined by a traced variable.
+
+=for pm Tk/TraceText.pm
+
+=for category Text
+
+=head1 SYNOPSIS
+
+ $tt = $parent->TraceText(-option => value, ... );
+
+=head1 DESCRIPTION
+
+Create a new B<TraceText> widget that is derived from the standard B<Text>
+widget. Because it inherits all the base options and methods it behaves
+just like a B<Text> widget. Additionally, B<TraceText> adds a -textvariable
+option, which is a reference to a Perl scalar that defines the contents of
+the widget.
+
+Based on the Tcl/Tk TracedText "overridden widget" by Kevin Kenny.
+
+=over 4
+
+=item B<-textvariable>
+
+A scalar reference. The value of the variable defines the contents of the
+TraceText widget. Using the keyboard to insert or delete text changes the
+value of the variable, and changing the variable alters the contents of the
+TraceText widget.
+
+=back
+
+=head1 METHODS
+
+Standard Text widget methods.
+
+=head1 ADVERTISED SUBWIDGETS
+
+None.
+
+=head1 EXAMPLE
+
+ my $tt = $mw->TraceText( -textvariable => \$scalar );
+
+=head1 AUTHOR
+
+Stephen.O.Lidie@Lehigh.EDU
+
+Copyright (C) 2003 - 2004, Steve Lidie. All rights reserved.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 KEYWORDS
+
+text, trace
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/transtile.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/transtile.pl
new file mode 100755
index 00000000000..55e7130a1af
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/transtile.pl
@@ -0,0 +1,113 @@
+# transtile.pl
+
+use vars qw/$TOP/;
+
+sub transtile {
+
+ # Create a top-level window that demonstrates tiles
+ # and transparent stuff.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => ['This window demonstrates tiles and transparent images. The Canvas has a yellow background, which displays for one second before it\'s overlayed with a tile of tiny camels. On top of the tile layer are three non-transparent images that obscure the tile. Canvas items such as ovals, rectangles and polygons cannot react to bound events unless they are filled with a color - move the cursor over the blue circle and note that it reacts to <Motion> events. The transparent circle outlined in red to the left of the blue circle does not react to <Motion> events in its interior because it\'s transparent, or unfilled. If you need a transparent item that also reacts to events then add a transparent stipple. The bottom red circle is both transparent and aware of events. Finally, a blue lattice (a transparent GIF that\'s been Base64 encoded so it can be embedded in the source) is overlayed on top of everything, anchored to the southeast corner of the Canvas.', -wraplength => '8i'],
+ -title => 'Tile and Transparent Demonstration',
+ -iconname => 'transtile',
+ );
+
+ my $tile = $TOP->Photo(-file =>Tk->findINC('Camel.xpm'));
+
+ # A tiled Canvas - the tile overlays the background color.
+
+ my $c = $TOP->Canvas(
+ -background => 'yellow',
+ -width => 300,
+ -height => 250,
+ -relief => 'raised',
+ -borderwidth => 3,
+ )->grid;
+ $c->update;
+ $c->after(1000);
+ $c->configure(-tile => $tile);
+
+ # These images are not transparent, thus they obscure the tile
+ # or background.
+
+ my($x, $y) = (30, 30);
+ foreach (qw/Xcamel.gif anim.gif icon.gif/) {
+ $c->createImage($x, $y, -image => $TOP->Photo(-file => Tk->findINC($_)));
+ $x += 50;
+ $y += 50;
+ }
+
+ # Transparent Canvas items do not generate events.
+
+ my $cb = sub {
+ print "Over circle, args = @_!\n";
+ };
+
+ # Not filled (transparent), no events.
+
+ my $o1 = $c->createOval(25, 25, 100, 100,
+ -outline => 'red',
+ );
+ $c->bind($o1, '<Motion>' => $cb);
+
+ # Filled (non-transparent), but with events.
+
+ my $o2 = $c->createOval(155, 25, 225, 100,
+ -outline => 'red',
+ -fill => 'blue',
+ );
+ $c->bind($o2, '<Motion>' => $cb);
+
+ # Transparently filled, with events.
+
+ my $o3 = $c->createOval(25, 120, 100, 195,
+ -outline => 'red',
+ -fill => 'blue',
+ -stipple => 'transparent',
+ );
+ $c->bind($o3, '<Motion>' => $cb);
+
+ # A transparent GIF overlaying everything.
+
+ $c->createImage(300, 300,
+ -image => $TOP->Photo(-data => &encoded_gif, -format => 'gif'),
+ -anchor => 'se',
+ );
+
+} # end transtile
+
+sub encoded_gif {
+
+ # A Base64 encoded transparent GIF.
+
+ my $gif = <<'END_OF_GIF';
+R0lGODlhyADIAIAAAB0A/////yH+Dk1hZGUgd2l0aCBHSU1QACH5BAEKAAEALAAAAADIAMgAAAL+
+jI+py+0Po5y02ouz3rz7D4biSJbmiabqCgJuC7DZK9Ly5+Zdrt8Sb+MAYzDUkKgZ+n5AXNOjLB03
+R6TQmpxeo9seSTsDZ3ldctk7fo7EGC5VnQ6+zWd5CB6mx9Ft/N6p92WXBejXt4Z1trTI4MboM/i4
+6ChZabkUeam5ydnp+QkaKjpKWmp6ipqqusoKldjqWvOqSQmbx3ebSTiH+yZrZHhR+9c3bGFcgcwb
+KMy2PBtR5cpc3DsdTCF9Tc3Efez8rUysWOgNId6NPaGNaJ6t3uweDV2t+y5/9SuLf4M+z2/rXSh7
+zQIaPIgwocKFDBs6fAgxosSJjehRHGhxB7z+ZBm/6StSrmMukec2piN4kuQDfyUBhjPZ0tpLlP9k
+cnTZgN0dcDdhOtBZz2ZKmj95asRZkWVOo+uYDlW5FOk9oU2lLlBa1KoCrFGp5gu5DWpXoit9zmNF
+lslHJxfbun0LN67cuXTr2r2LN6/evbvspj2oVcbfnoP7iR17uGK7xCl37iy81WxWxkm9xpM8GexR
+ygi4ToZc1vNVzJVBJzDdmXRmKapHBz5tGVNsgSZEV3aMsRXq0Xx7+/4NPLjw4cSLGz+OPLmK3b5f
+p3COinlN6QGo21bsCfp05tqrt3bNGfZm6ojDe+/e/fzs1eNqXz/wXjwM6PHTh17fdZT2+N7+BeMv
+Wop1/ykHCnkEHohgggouyGCDDj4oCITRDQiYeYyYx598oti3wnfqkcfhPhRqeIJTMT02Im+a8fJc
+fRamll6MKRqQ4WcGFjLfjKmFBYyHJb5Io4+s3QgekAHq6J5gcBEpYZNOPglllFJO2R+V2SFpZY5M
+NvlijVXqZ+SWMHKHpXq45Yjjj0J+OV6XZfLnZZFijsRjnc+oGeI1K26WpntrRojmmbG0WOaRehmZ
+ZaKKLspoo44+CmmkksyZZIJ54kkmoAX+2aGQHF5qJylAzQRknCIKuthrXsYJYpiFRkbfq/aBSo4g
++yEaJIqUBgXMW6YGCiGtGj25q6TGHov+bLLKLstss2ziOWhc0gn7YXif4morhpyWxtmqrz57Z7hD
+flcjq1jC+S2sM8rI7rnuLucporNyWuypmy7mbK/57stvv/7+C3DAAvd1r4S/9gnSXAe3ieKG2MJn
+Im21MvwJqKPeoqeWpbpp8Z8Z3thuqCJOuy0iGmf8o70UlfswvL6m22+9A89Mc80231yXzKLKiyvJ
+OieMMp/AtjcsphZ+7LGP3oqJ9K3oxSvgpRdfNrTQRe+p67uoRlsxzEFSm9ycC+/7M85mn4122mqv
+zfZXbSOWM89rUez2hE4j2bTS3zK9Zt5kvmcuk1NP5dzghFlLb8lf6+2i39q2KnXfks8fCzTCIx89
+ude56Vv51W9/Dnrooo9Oeummn4566g4UAAA7
+END_OF_GIF
+
+ return $gif;
+
+} # end encoded_gif
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/twind.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/twind.pl
new file mode 100755
index 00000000000..5b67fa1d60a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/twind.pl
@@ -0,0 +1,186 @@
+# twind.pl
+
+use Plot;
+use subs qw/twind_create_plot twind_delete_plot twind_restore_bg/;
+use vars qw/$TOP/;
+
+sub twind {
+
+ # Create a top-level window with a text widget that demonstrates the
+ # use of embedded windows in Text widgets.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => '',
+ -title => 'Text Demonstration - Embedded Windows',
+ -iconname => 'twind',
+ );
+
+ # By default, when you create a Scrolled instance of a Perl/Tk widget
+ # the scrollbars are always displayed; that is, they are required. But
+ # you can have optional scrollbars as well, specified via the -scrollbars
+ # specifier. So, assume scrollbars can be postioned 'nsew' (north, south
+ # east or west), or 'se' for southeast, etcetera. You specify 'required'
+ # or 'optional' using an 'r' or 'o' character, respectively, preceeding
+ # the scrollbar position. So the following Scrolled widget has an
+ # optional scrollbar at the bottom of the text widget and a required
+ # scrollbar positioned to the right.
+ #
+ # Optional scrollbars are only displayed if they are required, so, the
+ # the southern scrollbar is displayed IFF -wrap => none.
+
+ my $t = $TOP->Scrolled(qw/Text -setgrid true -width 70 -height 35
+ -wrap word -highlightthickness 0 -borderwidth 0 -scrollbars osre
+ -font/ => $FONT)->pack;
+
+ $t->tag(qw/configure center -justify center -spacing1 5m -spacing3 5m/);
+ $t->tag(qw/configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c
+ -spacing1 3m -spacing2 0 -spacing3 0/);
+
+ my $t_on = $t->Button(
+ -text => 'Turn On',
+ -command => [$t => qw/configure -wrap none/],
+ -cursor => 'top_left_arrow',
+ );
+ my $t_off = $t->Button(
+ -text => 'Turn Off',
+ -command => [$t => qw/configure -wrap word/],
+ -cursor => 'top_left_arrow',
+ );
+
+ my $t_click = $t->Button(
+ -text => 'Click Here',
+ -command => [\&twind_create_plot, $t],
+ -cursor => 'top_left_arrow',
+ );
+ my $t_delete = $t->Button(
+ -text => 'Delete',
+ -command => [\&twind_delete_plot, $t],
+ -cursor => 'top_left_arrow',
+ );
+
+ $t->insert('end', "A text widget can contain other widgets embedded ");
+ $t->insert('end', "in it. These are called ");
+ $t->insert('end', "\"embedded windows\"");
+ $t->insert('end', ", and they can consist of arbitrary widgets. ");
+ $t->insert('end', "For example, here are two embedded button ");
+ $t->insert('end', "widgets. You can click on the first button to ");
+ $t->window('create', 'end', -window => $t_on);
+ $t->insert('end', " horizontal scrolling, which also turns off ");
+ $t->insert('end', "word wrapping. Or, you can click on the second ");
+ $t->insert('end', "button to\n");
+ $t->window('create', 'end', -window => $t_off);
+ $t->insert('end', " horizontal scrolling and turn back on word ");
+ $t->insert('end', "wrapping.\n\n");
+
+ $t->insert('end', "Or, here is another example. If you ");
+ $t->window('create', 'end', -window => $t_click);
+ $t->insert('end', " a canvas displaying an x-y plot will appear ");
+ $t->insert('end', "right here.");
+ $t->mark('set', 'plot', 'insert');
+ $t->mark('gravity', 'plot', 'left');
+ $t->insert('end', " You can drag the data points around with the ");
+ $t->insert('end', "mouse, or you can click here to ");
+ $t->window('create', 'end', -window => $t_delete);
+ $t->insert('end', " the plot again.\n\n");
+
+ $t->insert('end', "You may also find it useful to put embedded windows");
+ $t->insert('end', " in a text without any actual text. In this case ");
+ $t->insert('end', "the text widget acts like a geometry manager. For ");
+ $t->insert('end', "example, here is a collection of buttons laid out ");
+ $t->insert('end', "neatly into rows by the text widget. These buttons");
+ $t->insert('end', " can be used to change the background color of the ");
+ $t->insert('end', "text widget (\"Default\" restores the color to ");
+ $t->insert('end', "its default). If you click on the button labeled ");
+ $t->insert('end', "\"Short\", it changes to a longer string so that ");
+ $t->insert('end', "you can see how the text widget automatically ");
+ $t->insert('end', "changes the layout. Click on the button again ");
+ $t->insert('end', "to restore the short string.\n");
+
+ my $t_default = $t->Button(
+ -text => 'Default',
+ -command => [\&twind_restore_bg, $t],
+ -cursor => 'top_left_arrow',
+ );
+ $t->window('create', 'end', -window => $t_default, -padx => 3);
+ my $embToggle = 'Short';
+ my $t_toggle = $t->Checkbutton(
+ -textvariable => \$embToggle,
+ -indicatoron => 0,
+ -variable => \$embToggle,
+ -onvalue => 'A much longer string',
+ -offvalue => 'Short',
+ -cursor => 'top_left_arrow',
+ );
+ $t->window('create', 'end', -window => $t_toggle,
+ -padx => 3, -pady => 2);
+ my($i, $color) = (1, '');
+ foreach $color (qw(AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4
+ SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3
+ LightBlue1 DarkSlateGray1 Aquamarine2 DarkSeaGreen2
+ SeaGreen1 Yellow1 IndianRed1 IndianRed2 Tan1 Tan4)) {
+ my $col = $t->Button(
+ -text => "$color",
+ -cursor => 'top_left_arrow',
+ );
+ $col->configure(-command => sub {
+ $t->configure(-background => $color);
+ });
+ $t->window('create', 'end', -window => $col,
+ -padx => 3, -pady => 2);
+ $i++;
+ }
+ $t->tag('add', 'buttons', $t_default, 'end');
+
+} # end twind
+
+sub twind_create_plot {
+
+ # We are required to create a new Plot object everytime since embedded
+ # widgets are destroyed when their tag is deleted. (Too bad.)
+
+ my($text) = @_;
+
+ if (not Exists($twind::plot)) {
+ $twind::plot = $text->Plot(
+ -title_color => 'Brown',
+ -inactive_highlight => 'Skyblue2',
+ -active_highlight => 'red',
+ );
+
+ while ($text->get('plot') =~ / |\t|\n/) {
+ $text->delete('plot');
+ }
+ $text->insert('plot', "\n");
+ $text->window('create', 'plot', -window => $twind::plot);
+ $text->tag('add', 'center', 'plot');
+ $text->insert('plot', "\n");
+ } # ifend
+
+} # end twind_create_plot
+
+sub twind_delete_plot {
+
+ my($text) = @_;
+
+ if (Exists($twind::plot)) {
+ $text->delete($twind::plot);
+ while ($text->get('plot') =~ / |\t|\n/) {
+ $text->delete('plot');
+ }
+ $text->insert('plot', ' ');
+ }
+
+} # end twind_delete_plot
+
+sub twind_restore_bg {
+
+ my($text) = @_;
+
+ $text->configure(-background =>
+ ($text->Subwidget('text')->configure(-background))[3]);
+
+} # end twind_restore_bg
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/unicodeout.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/unicodeout.pl
new file mode 100755
index 00000000000..b898810fd6d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/unicodeout.pl
@@ -0,0 +1,64 @@
+# unicodeout.pl
+
+use vars qw/$TOP/;
+use subs qw/unicodeadd/;
+
+sub unicodeout {
+
+ # This demonstration script shows how you can produce output (in label
+ # widgets) using many different alphabets.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'This is a sample of Perl/Tk\'s support for languages that use non-Western character sets. However, what you will actually seebelow depends largely on what character sets you have installed, and what you see for characters that are not present varies greatly between platforms as well. The strings are written in Perl Unicode characters using the \\x{XXXX} escape sequence so as to do so in a portable fashion.',
+ -title => 'Unicode Label Demonstration',
+ -iconname => 'unicodeout',
+ );
+
+ my $unicode_wait = $TOP->Label(
+ -text => 'Please wait while loading fonts...',
+ -font => 'Helvetica 12 italic',
+ )->pack;
+ $TOP->update;
+
+ # Processing when some characters are missing might take a while, so make
+ # sure we're displaying something in the meantime.
+
+ $TOP->Busy;
+
+ unicodeadd $TOP, 'Arabic',
+ "\x{FE94}\x{FEF4}\x{FE91}\x{FEAE}\x{FECC}\x{FEDF}\x{FE8D}\x{FE94}\x{FEE4}\x{FEE0}\x{FEDC}\x{FEDF}\x{FE8D}";
+ unicodeadd $TOP, "Trad. Chinese", "\x{4E2D}\x{570B}\x{7684}\x{6F22}\x{5B57}";
+ unicodeadd $TOP, "Simpl. Chinese", "\x{6C49}\x{8BED}";
+ unicodeadd $TOP, 'Greek',
+ "\x{0395}\x{03BB}\x{03BB}\x{03B7}\x{03BD}\x{03B9}\x{03BA}\x{03AE}\x{03B3}\x{03BB}\x{03CE}\x{03C3}\x{03C3}\x{03B1}";
+ unicodeadd $TOP, 'Hebrew',
+ "\x{05DD}\x{05D9}\x{05DC}\x{05E9}\x{05D5}\x{05E8}\x{05D9}\x{05DC}\x{05D9}\x{05D0}\x{05E8}\x{05E9}\x{05D9}";
+ unicodeadd $TOP, 'Japanese',
+ "\x{65E5}\x{672C}\x{8A9E}\x{306E}\x{3072}\x{3089}\x{304C}\x{306A}\x{6F22}\x{5B57}\x{3068}\x{30AB}\x{30BF}\x{30AB}\x{30CA}";
+ unicodeadd $TOP, 'Korean',
+ "\x{B300}\x{D55C}\x{BBFC}\x{AD6D}\x{C758}\x{D55C}\x{AE00}";
+ unicodeadd $TOP, 'Russian',
+ "\x{0420}\x{0443}\x{0441}\x{0441}\x{043A}\x{0438}\x{0439}\x{044F}\x{0437}\x{044B}\x{043A}";
+
+ # We're done processing, so change things back to normal running.
+
+ $unicode_wait->destroy;
+ $TOP->Unbusy;
+
+} # end unicodeout
+
+sub unicodeadd {
+
+ my ($w, $language, @args) = @_;
+
+ my $sample = join('', @args);
+ my $l1 = $w->Label(-text => "$language: ", qw/-anchor nw -pady 0/);
+ my $l2 = $w->Label(-text => $sample, qw/-anchor nw -width 30 -pady 0/);
+ $l1->grid($l1, $l2, qw/-sticky ew -pady 0/);
+ $l1->gridConfigure(qw/-padx 1m/);
+
+} # end unicodeadd
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/virtevents1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/virtevents1.pl
new file mode 100755
index 00000000000..8e2e85106f8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/virtevents1.pl
@@ -0,0 +1,59 @@
+use strict;
+
+sub virtevents1 {
+
+ my( $demo ) = @_;
+
+ my $mw = $MW->WidgetDemo(
+ -name => $demo,
+ -text => [ "This demonstration shows how you can use keysyms (keyboard symbols) to programmatically synthesize events that simulate a person typing on the keyboard. To learn about keyboard keysyms, run to previous demonstration, \"Show keyboard symbols\".
+
+A virtual event named <<pTkRules>> is defined that is activated by pressing the \"caps lock\" key (go ahead, press \"caps lock\"). A callback is bound to that virtual event - the callback synthesizes physicals events that \"type\" into the Entry widget displayed below. Pressing the \"Synthesize\" Button calls eventGenerate(), which synthesizes the virtual event <<pTkRules>> directly.
+
+Warning: it's easy to make this demonstration recurse indefinitely because synthesized physical events behave just like the real thing. So, it's possible for the <<pTkRules>> callback to eventGenerate() the keysym that activates the <<pTkRules>> virtual event, which invokes the <<pTkRules>> callback to eventGenerate() the keysym that activates the <<pTkRules>> virtual event, which ...", -wraplength => '6i' ],
+ -title => 'Simulate KeyPress events.',
+ -iconname => 'vevents1',
+ );
+
+ # Define a virtual event - <<pTkRules>> - that is activated when
+ # the physical event - pressing the "caps lock" key - occurs.
+
+ $mw->eventAdd( qw/ <<pTkRules>> <Caps_Lock> / );
+
+ # Alphabetics are their own keysyms. The %keysyms hash maps other
+ # characters to their keysym string. To see the keysyms associated
+ # with keyboard characters run the previous widget demonstration.
+
+ my %keysyms = (' ' => 'space', '/' => 'slash', '!' => 'exclam' );
+
+ # Create an Entry widget for a person or this program to type into.
+ # The Button explicitly generates the virtual event.
+
+ my $e = $mw->Entry->pack;
+ my $b = $mw->Button(
+ -command => sub { $mw->eventGenerate( '<<pTkRules>>' ) },
+ -text => 'Synthesize <<pTkRules>>',
+ )->pack;
+
+ # Now bind the virtual event to a callback that "types" for us.
+
+ $mw->bind( qw/ <<pTkRules>> / => sub {
+
+ # This subroutine is invoked whenever the "caps lock" key is
+ # pressed or the virtual event <<pTkRules>> is programatically
+ # generated via eventGenerate.
+
+ $e->focus;
+ $mw->update;
+ my $string_to_type = 'Perl/Tk rules!';
+
+ foreach ( split '', $string_to_type ) {
+ $_ = $keysyms{$_} if exists $keysyms{$_};
+ $e->eventGenerate( '<KeyPress>', -keysym => $_ );
+ $mw->idletasks;
+ $mw->after( 100 );
+
+ } # end sub type characters
+ } );
+
+} # end virtevents1
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/vscale.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/vscale.pl
new file mode 100755
index 00000000000..1f7d076e93d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/vscale.pl
@@ -0,0 +1,48 @@
+# vscale.pl
+
+use subs qw/vscale_height/;
+use vars qw/$TOP/;
+
+sub vscale {
+
+ # Create a top-level window that displays a vertical scale.
+
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'An arrow and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow.',
+ -title => 'Vertical Scale Demonstration',
+ -iconname => 'vscale',
+ );
+
+ my $frame = $TOP->Frame(-borderwidth => 10)->pack;
+
+ my $canvas = $frame->Canvas(
+ qw/-width 50 -height 50 -borderwidth 0 -highlightthickness 0/);
+ $canvas->createPolygon(qw/0 0 1 1 2 2 -fill SeaGreen3 -tags poly/);
+ $canvas->createLine(qw/0 0 1 1 2 2 0 0 -fill black -tags line/);
+
+ my $scale = $frame->Scale(qw/-orient vertical -length 284 -from 0
+ -to 250 -tickinterval 50 -command/ => [\&vscale_height, $canvas]);
+ $scale->set(75);
+
+ $scale->pack(qw/-side left -anchor ne/);
+ $canvas->pack(qw/-side left -anchor nw -fill y/)
+
+} # end vscale
+
+sub vscale_height {
+
+ my($w, $height) = @_;
+
+ $height += 21;
+ my $y2 = $height - 30;
+ $y2 = 21 if $y2 < 21;
+ $w->coords('poly', 15, 20, 35, 20, 35, $y2, 45, $y2, 25, $height, 5, $y2,
+ 15, $y2, 15, 20);
+ $w->coords('line', 15, 20, 35, 20, 35, $y2, 45, $y2, 25, $height, 5, $y2,
+ 15, $y2, 15, 20);
+
+} # end vscale_height
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Gedi.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Gedi.pl
new file mode 100755
index 00000000000..ff847000e05
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Gedi.pl
@@ -0,0 +1,429 @@
+# Gedi master advanced text editor.
+
+use Tk::TextEdit;
+
+use vars qw/$TOP/;
+
+my $TOP;
+my $text_frame;
+my $counter_frame;
+my $textwindow;
+my $current_line_label;
+my $total_line_label;
+my $current_column_label;
+my $insert_overstrike_mode_label;
+my $about_pop_up_reference;
+my $menu;
+my $help_menu;
+
+sub about_pop_up
+{
+ my $name = ref($about_pop_up_reference);
+ if (defined($about_pop_up_reference))
+ {
+ $about_pop_up_reference->raise;
+ $about_pop_up_reference->focus;
+ }
+ else
+ {
+ my $pop = $TOP->Toplevel();
+ $pop->title("About");
+
+ $pop->Label(-text=>"Gedi (Gregs EDItor)")->pack();
+ $pop->Label(-text=>"Ver. 1.0")->pack();
+ $pop->Label(-text=>"Copyright 1999")->pack();
+ $pop->Label(-text=>"Greg London")->pack();
+ $pop->Label(-text=>"All Rights Reserved.")->pack();
+ $pop->Label(-text=>"This program is free software.")->pack();
+ $pop->Label(-text=>"You can redistribute it and/or")->pack();
+ $pop->Label(-text=>"modify it under the same terms")->pack();
+ $pop->Label(-text=>"as Perl itself.")->pack();
+ $pop->Label(-text=>"Special Thanks to")->pack();
+ $pop->Label(-text=>"Nick Ing-Simmons.")->pack();
+
+ my $button_ok = $pop->Button(-text=>'OK',
+ -command => sub {$pop->destroy();
+ $about_pop_up_reference = undef;
+ } )
+ ->pack();
+ $pop->resizable('no','no');
+ $about_pop_up_reference = $pop;
+ }
+}
+
+
+sub update_indicators
+{
+ my ($line,$column)= split(/\./,$textwindow->index('insert'));
+ $current_line_label->configure (-text=> "line: $line");
+ $current_column_label->configure (-text=> "column: $column");
+
+ my ($last_line,$last_col) = split(/\./,$textwindow->index('end'));
+ $total_line_label->configure (-text=> "total lines: $last_line");
+
+ my $mode = $textwindow->OverstrikeMode;
+ my $overstrke_insert='Insert Mode';
+ if ($mode)
+ {$overstrke_insert='Overstrike Mode';}
+ $insert_overstrike_mode_label->configure
+ (-text=> "$overstrke_insert");
+
+ my $filename = $textwindow->FileName;
+ $filename = 'NoName' unless(defined($filename));
+ my $edit_flag='';
+ if($textwindow->numberChanges)
+ {$edit_flag='edited';}
+ $TOP->configure(-title => "Gedi $edit_flag $filename");
+ $textwindow->idletasks;
+
+}
+
+
+
+
+
+
+sub Gedi {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Gedi master advanced text editor ',
+ -geometry_manager => 'grid',
+ -title => 'GEDI Text Editor',
+ -iconname => 'GEDI',
+ );
+
+$TOP->withdraw;
+
+$text_frame = $TOP->Frame->pack
+ (-anchor=>'nw', -expand=>'yes', -fill => 'both'); # autosizing
+$counter_frame = $TOP->Frame->pack(-anchor=>'nw');
+
+$textwindow = $text_frame->Scrolled(
+ 'TextEdit',
+ exportselection => 'true', # 'sel' tag is associated with selections
+ # initial height, if it isnt 1, then autosizing fails
+ # once window shrinks below height
+ # and the line counters go off the screen.
+ # seems to be a problem with the Tk::pack command;
+# height => 40,
+ -background => 'white',
+ -wrap=> 'none',
+ -setgrid => 'true', # use this for autosizing
+ -scrollbars =>'se')
+ -> pack(-expand => 'yes' , -fill => 'both'); # autosizing
+
+$TOP->protocol('WM_DELETE_WINDOW'=>
+ sub{$textwindow->ConfirmExit;}
+ );
+
+$SIG{INT} = sub {$textwindow->ConfirmExit;};
+
+$current_line_label = $counter_frame
+ -> Label(-text=>'line: 1')
+ -> grid(-row=>1,-column=>1, -sticky=>'nw' );
+
+$total_line_label = $counter_frame
+ -> Label(-text=>'total lines: 1')
+ -> grid(-row=>2,-column=>1, -sticky=>'nw' );
+
+$current_column_label = $counter_frame
+ -> Label(-text=>'column: 0')
+ -> grid(-row=>3,-column=>1, -sticky=>'nw' );
+
+$insert_overstrike_mode_label = $counter_frame
+ -> Label(-text=>' ')
+ -> grid(-row=>5,-column=>1, -sticky=>'nw' );
+
+$textwindow->SetGUICallbacks (
+ [
+ \&update_indicators,
+ sub{$textwindow->HighlightAllPairsBracketingCursor}
+ ]
+);
+
+$menu = $textwindow->menu;
+
+$TOP->configure(-menu => $menu);
+
+$help_menu = $menu->cascade(-label=>'~Help', -tearoff => 0, -menuitems => [
+ [Command => 'A~bout', -command => \&about_pop_up]
+ ]);
+
+
+#$TOP->minsize(30,1);
+#$TOP->geometry("80x24");
+
+while(<DATA>)
+ {$textwindow->insert('insert',$_);}
+$textwindow->ResetUndo;
+
+$textwindow->CallNextGUICallback;
+
+# adjust height
+$TOP->update;
+my $menuheight = ($TOP->wrapper)[1];
+my $TOPheight = 30 + $TOP->reqheight + $menuheight;
+if ($TOP->screenheight < $TOPheight) {
+ $textwindow->GeometryRequest($textwindow->reqwidth, $textwindow->reqheight - ($TOPheight - $TOP->screenheight));
+}
+$TOP->deiconify;
+
+}
+
+
+__DATA__
+
+Tk800.015 contains many modifications to the
+text based modules, as well as new text modules
+and an application that uses them all.
+Text.pm, TextUndo.pm, TextEdit.pm, and gedi
+have all been updated since the release prior
+to Tk800.015.
+
+This demo contains a rundown of all the features
+of the text modules, and
+
+What is available in the text modules?
+================================================
+
+Text.pm
+========
+
+Text.pm is the base text editing module.
+Beyond the core functionality of typing text,
+Text.pm has built in menu support for basic
+editing features such as Find/Replace text,
+Copy/Cut/Paste, Goto Line Number, and What
+Line Number queries.
+
+These functions are available simply by right
+clicking the mouse over the text area. Doing
+so will cause a pop-up menu to appear which will
+contain cascading menus to give access to all of
+these new functions.
+
+Many of these functions will create their own
+pop-up windows. Find/Replace will create a pop-up
+window which contains an entry for text to
+find, an entry for replace text, a number of
+radio buttons to control options such as
+case sensitivity, and several command buttons to
+perform functions such as Find, Find All,
+Replace, Replace All.
+
+All of these features have corresponding methods
+built into the Text widget. This allows the basic
+functions to be built into the widget, and also
+allows added features to be built on the lower
+level methods as needed. No one should have to
+reinvent the wheel when it comes to text editing
+features.
+
+Insert and Overstrike modes are also supported
+in the Text.pm module. Pressing the <Insert>
+key will toggle modes back and forth.
+
+Column based copy/cut/paste features are also
+available in the Text.pm module. They are bound
+to the following keys:
+
+<F1> clipboardColumnCopy
+<F2> clipboardColumnCut
+<F3> clipboardColumnPaste
+
+Currently, column based operations are beta versions.
+They compensate for tabs, but they will not behave
+properly unless the text is all the same font, and
+is the same width per character.
+
+Hopefully some future version of Text.pm will correct
+for this deficiency.
+
+Column paste should work with overstrike mode.
+
+
+TextUndo.pm
+=============
+
+TextUndo.pm is the second level module, being
+derived from the Text.pm module. As it's name
+implies, TextUndo supports "UNDO" capability.
+It now also supports "REDO" capability.
+
+Undo/redo works on user typed commands and
+also programmatically, so that any application
+that causes text to be inserted or deleted
+can be undone/redone, whether it was directly
+typed by the user or indirectly through another
+method.
+
+The undo/redo functions support tags, so that
+if you delete text with tags, undo will re-insert
+the text and re-tag it as well. This will eventually
+allow the text modules to support more sophisticated
+word processing type features. Such functionality
+should be available in a future release of the
+text modules.
+
+The TextUndo.pm module also has several added
+features to support file based operations.
+File based methods include ->Save, ->Load, and
+->Include. All methods take a filename as a
+parameter. These methods will create a progress
+widget to indicate the progress of the operation.
+
+The other feature of the TextUndo.pm module
+is the ConfirmDiscard method. This method checks to
+see if the text has been modified since it was
+last saved. If it has been modified, and the
+it will create a pop-up menu asking the user
+if they want to save the text to a file before
+exiting. This method can easily be tied into
+the exit routines, and signal handlers, to provide
+a consistent "save before exit?" feel.
+
+TextEdit.pm
+=============
+
+The TextEdit.pm is a new module in prototype version
+which adds further features to the text modules.
+TextEdit is based off of the TextUndo module,
+and so has all of the features of TextUndo and
+Text.
+
+Features of the TextEdit.pm module include
+parenthesis matching. The module looks at the
+current cursor position and then tries to find
+the parenthesis that bracket the cursor.
+Character pairs that are searched for are:
+() {} [] "" ''
+
+It also checks the position of the pairs to
+try to highlight bad positions. The module
+assumes that if the pairs are not on the same
+line or not on the same column, then there
+might be a missing parenthesis somewhere.
+Characters that appear to not align are
+highlighted in red.
+
+(quotations must start and end on the same line)
+
+
+PARENTHISIS MATCHING DEMO:
+move the cursor to the x between the quotes
+on the line below:
+
+
+{
+ ( )
+ ( { }
+ [
+ ' ">> x <<" '
+ [] ]
+ )
+
+}
+
+PARENTHESIS MISMATCHING DEMO:
+move the cursor to the x between the quotes
+on the line below:
+
+
+{
+ ( )
+ ( <<RED possible error { }
+ [
+ ' ">> x <<" '
+ [] ]
+ ) <<RED possible error
+
+}
+
+
+
+Another feature of the TextEdit module is support
+for application level indicators which reflect
+the status of certain internals. The line and
+column position of the cursor, the total length
+of the file, whether the widget is in insert or
+overstrike mode. Anytime anything occurs that could
+affect these values, a user supplied callback
+is invoked. This callback is supplied by the
+application so that the application can update
+whatever indicators it uses, however it implements
+them.
+
+One other feature of the TextEdit.pm module is
+block level text indention and block level text
+commenting. If a block of text is selected,
+that text can be indented or unindented wiht
+a single keystroke. It can also be commented
+out or uncommented as well. The keystroke bindings
+that support this are:
+
+<F5> IndentSelectedLines
+<F6> UnindentSelectedLines
+
+<F7> CommentSelectedLines
+<F8> UncommentSelectedLines
+
+These bindings only operate on the currently
+selected text. The indent string and the comment
+string can be programmed to be anything, but
+defaults to "\t" (tab) for indent and "#" for
+comments.
+
+(currently the widget hash is used to store these values.
+$w->{'INDENT_STRING'} and $w->{'LINE_COMMENT_STRING'}
+At some point in the future, this will be changed to
+use configure options to set these values.
+any application that changes these values should do
+so in such a way that when the TextEdit module changes,
+the application can be easily changed to handle this)
+
+
+
+gedi application
+=====================
+gedi is short for Greg's EDItor.
+The "g" is soft, pronounced like a "j".
+
+The gedi application uses all of the features of
+the text modules, Text, TextUndo, and TextEdit.
+It supplies TextEdit with a callback to update
+the indicator displays. This information includes
+the current cursor position, insert/overstrike
+mode, length of the file, filename, and whether
+the file has been edited or not.
+
+The bottom of this display contains
+line number
+column number
+total lines
+insert/overstrike mode.
+
+The title bar contains
+filename
+and if the file has been edited, the word "edited".
+
+Where gedi is installed depends on your system,
+but it is part of the tarkit for Tk800.015 and above.
+
+gedi was created to be put a perl editor in with the
+perl tar kit.
+
+NOTE: THIS IS NOT THE ACTUAL GEDI APPLICATION, BUT
+A DEMO SET UP TO BE SIMILAR IN NATURE TO THE GEDI
+APPLICATION. THE ACTUAL GEDI APPLICATION IS PART OF
+THE TK800.015 TARKIT. WHERE IT IS LOCATED ON YOUR
+SYSTEM WILL VARY DEPENDING ON YOUR SYSTEM. ONCE
+YOU LOCATE THE GEDI APPLICATION, PUT IT IN YOUR
+EXECUTABLE PATH, AND YOU WILL BE ABLE TO USE IT AS
+A TEXT EDITOR.
+
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/TEMPLATE.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/TEMPLATE.pl
new file mode 100755
index 00000000000..f0415ea9cae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/TEMPLATE.pl
@@ -0,0 +1,92 @@
+# Learn how to write your own widget demonstration.
+
+use vars qw/$TOP/;
+
+sub TEMPLATE {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Learn how to write a widget demonstration!',
+ -geometry_manager => 'grid',
+ -title => 'WidgetDemo Example',
+ -iconname => 'WidgetDemo',
+ );
+ $TOP->Label(-text => 'Click "See Code".')->grid;
+}
+__END__
+
+The template code above specifies how user contributed widget demonstrations
+can be written.
+
+widget looks in the directory specified on the command line to load user
+contributed demonstrations. If no directory name is specified when widget is
+invoked and the environment variable WIDTRIB is defined then demonstrations
+are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget
+defaults to the released user contributed directory.
+
+The first line of the file is the DDD (Demonstration Description Data), which
+briefly describes the purpose of the demonstration. The widget program reads
+this line and uses it when building its interface.
+
+Demonstrations must have a unique subroutine which is the same as the filename
+with .pl stripped off. When widget calls your subroutine it's passed one
+argument, the demonstration name. So file TEMPLATE.pl contains subroutine
+TEMPLATE(). But a demo can actually be an entire program - read on!
+
+For consistency your demonstration should use the WidgetDemo widget. This is
+a toplevel widget with three frames. The top frame contains descriptive
+demonstration text. The bottom frame contains the "Dismiss" and "See Code"
+buttons. The middle frame is the demonstration container, which can be
+managed by either the pack or grid geometry manager.
+
+Since your subroutine can "see" all of widget's global variables, you
+use $MW (the main window reference) to create the WidgetDemo toplevel; be sure
+to pass at least the -name and -text parameters. -geometry_manager defaults
+to "pack". The call to WidgetDemo() returns a reference to the containing
+frame for your demonstration, so treat it as if it were the MainWindow, the
+top-most window of your widget hierarchy.
+
+Alternatively the .pl file may contain typical Perl/Tk code of the form:
+
+ # Demonstration Description Data
+
+ use Tk;
+ my $top = MainWindow->new;
+ $top->Label(-text => 'Whatever');
+ MainLoop;
+ __END__
+
+widget has re-defined normal MainWindow to actually create a WidgetDemo
+on your code's behalf. MainLoop is optional in a demo (it will immediately
+return as MainLoop is already active).
+
+Other consideration:
+
+ . widget global variables are all uppercase, like $MW - be careful not
+ to stomp on them!
+
+ . Demo files should really be run in private packages to avoid those
+ problems.
+
+ . Don't subvert the inheritance mechanism by calling Tk::MainWindow
+ in your demo code.
+
+ . The description should really be extracted from POD documentation
+ in the .pl file rather than a magic comment.
+
+ . If your demonstration has a Quit button change it to ring the bell
+ and use the builtin Dismiss instead. In particular destroying a
+ MainWindow is acceptable, but exit will shut down widget itself!
+
+ . Be sure $TOP is declared in a "use vars" statement and not as a
+ lexical my() in the subroutine (see below).
+
+ . If you're wrapping an existing main program in a subroutine be very
+ alert for closure bugs. Lexicals inside a subroutine become closed
+ so you may run into initialization problems on the second and
+ subsequent invokations of the demonstration. The npuz and plop
+ demonstrations show how to work around this. Essentially, remove
+ all "global" my() variables and place them within a "use vars".
+ This practice is prone to subtle bugs and is not recommended!
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Tiler.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Tiler.pl
new file mode 100755
index 00000000000..c9a44b8c0b1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/Tiler.pl
@@ -0,0 +1,15 @@
+# Tiler, arrange widgets in rows.
+
+use strict;
+use Tk;
+use Tk::Tiler;
+
+my $mw = MainWindow->new();
+my $tiler = $mw->Scrolled('Tiler');
+my $num = $tiler->cget('-rows') * $tiler->cget('-columns');
+$mw->Label(-text => "Tiler with $num widgets")->pack;
+foreach (1 .. $num) {
+ $tiler->Manage( $tiler->Label(-text => "**$_**") );
+}
+$tiler->pack(qw/-expand yes -fill both/);
+MainLoop;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/all.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/all.pl
new file mode 100755
index 00000000000..2152465c462
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/all.pl
@@ -0,0 +1,315 @@
+# All widgets at a glance.
+# -*- perl -*-
+
+#
+# $Id: $
+# Author: Slaven Rezic
+#
+# Copyright (C) 2007 Slaven Rezic. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Mail: slaven@rezic.de
+# WWW: http://www.rezic.de/eserte/
+#
+
+use strict;
+use Tk::Pane;
+
+use vars qw/$TOP $MW $DEMO_FILE/;
+
+sub all {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => <<"EOF",
+All Tk widgets at a glance in one Toplevel.
+
+The left column contains the class name, the middle column a sample representation of this widget, and the right column a button to the widget's Pod (requires Tk::Pod from CPAN).
+
+There are two sections: core Tk modules which come with stock Tk $Tk::VERSION and a sample of non-standard Tk modules from CPAN. The non-standard modules are only displayed if installed, otherwise they are skipped.
+EOF
+ -geometry_manager => 'pack',
+ -title => 'All widgets',
+ -iconname => 'All widgets',
+ );
+
+ my($px_w, $px_h) = (400, 200);
+ my($txt_w, $txt_h) = (40, 6);
+ my @px_geom = (-width => $px_w, -height => $px_h);
+ my @txt_geom = (-height => $txt_h, -width => $txt_w);
+ my $insert_txt = sub {
+ my $w = shift;
+ if ($w->can("Subwidget") && $w->Subwidget("scrolled")) {
+ $w = $w->Subwidget("scrolled");
+ }
+ $w->insert("end", "This is some sample text for the widget class " . $w->Class);
+ };
+ my $insert_lb = sub {
+ shift->insert("end", sort grep { !m{^/} } keys %INC);
+ };
+
+ my $f = $TOP->Scrolled('Pane',
+ qw(-width 900 -height 500), # XXX check for screensize!
+ -gridded => 'xy',
+ -scrollbars => 'osoe',
+ -sticky => 'news',
+ )->pack(qw(-expand 1 -fill both));
+ $f = $f->Subwidget("scrolled");
+ my @w_def = (
+ {separator => 'Core Tk modules'},
+
+ 'Adjuster',
+ # XXX 'Balloon',
+ {class => 'BrowseEntry', action => $insert_lb},
+ {class => 'Button', w_args => [-text => 'This is a button']},
+ {class => 'Canvas', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..50) {
+ $w->createLine(rand($px_w),rand($px_h),
+ rand($px_w),rand($px_h),
+ -fill => $colors[rand @colors],
+ -width => rand(4)+1,
+ );
+ }
+ },
+ },
+ {class => 'Checkbutton', w_args => [-text => 'This is a checkbutton']},
+ {class => 'ColorEditor', dialog => 1},
+ {class => 'Dialog', dialog => 1},
+ {class => 'DialogBox', dialog => 1},
+ {class => 'DirTree', scrolled => 'oe'},
+ {class => 'Dirlist', scrolled => 'oe'},
+ {class => 'Entry', w_args => [-width => 20], action => $insert_txt},
+ {class => 'FBox', dialog => 1},
+ {class => 'FileDialog', dialog => 1},
+ {class => 'FileSelect', dialog => 1},
+ {class => 'Frame', w_args => [@px_geom, -bg => 'red']},
+ {class => 'Label', w_args => [-text => 'This is a label']},
+ {class => 'Labelframe', w_args => [@px_geom, -bg => 'red', -text => 'Title of frame']},
+ {class => 'Listbox', action => $insert_lb, scrolled => 'oe'},
+ # XXX Menubar?
+ {class => 'Menubutton', w_args => [-text => 'Menu button']},#XXX menuitems
+ {class => 'Message', w_args => [-text => 'This is a message widget']},
+ {class => 'MsgBox', dialog => 1},
+ {class => 'NoteBook', action => sub {
+ my $w = shift;
+ for (1..5) {
+ my $p = $w->add("page$_", -label => "Page $_");
+ $p->Label(-text => "A label in the page $_")->pack;
+ }
+ },
+ },
+ # XXX Pane
+ {class => 'Radiobutton', w_args => [-text => 'This is a radiobutton']},
+ {class => 'ROText', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ {class => 'Scale', w_args => [-orient => 'horiz', -from => 0, -showvalue => 1, -to => 100]},
+ {class => 'Scrollbar', w_args => [-orient => 'horiz']},
+ {class => 'Spinbox', w_args => [-from => 0, -to => 100]},
+ {class => 'Text', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ # disabled because of warning loop, line 189 ... {class => 'TextEdit', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ {class => 'TextList', w_args => [@txt_geom], action => $insert_lb, scrolled => 'oe'},
+ {class => 'TextUndo', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ # XXX Toplevel
+ qw(FloatEntry HList IconList InputO
+ LabEntry LabFrame LabRadio NBFrame Optionmenu
+ Panedwindow ProgressBar TList Table
+ Tiler TixGrid Tree
+ ),
+
+ {separator => 'Installed non-core Tk modules'},
+
+ qw(Date DateEntry NumEntry NumEntryPlain
+ PathEntry
+ ),
+ {class => 'FireButton', action => sub {
+ my $w = shift;
+ my $text = 'This is a firebutton 0';
+ $w->configure(-textvariable => \$text,
+ -command => sub {
+ $text =~ s{(\d+)}{$1+1}e;
+ },
+ );
+ },
+ },
+ {class => 'TFrame', w_args => [@px_geom, -bg => 'red',
+ -label => [ -text => 'Title' ],
+ -borderwidth => 2,
+ -relief => 'groove',
+ ],
+ },
+ {class => 'ToolBar', w_args => [qw/-movable 1 -side top
+ -indicatorcolor blue/],
+ action => sub {
+ my $tb = shift;
+ $tb->ToolButton (-text => 'Button',
+ -tip => 'tool tip',
+ -command => sub { print "hi\n" });
+ $tb->ToolLabel (-text => 'A Label');
+ $tb->Label (-text => 'Another Label');
+ $tb->ToolLabEntry(-label => 'A LabEntry',
+ -labelPack => [-side => "left",
+ -anchor => "w"]);
+ },
+ },
+ {class => 'HistEntry', action => sub {
+ my $w = shift;
+ $w->bind("<Return>" => sub {
+ # do something with value, and then:
+ $w->historyAdd;
+ $w->delete('0', 'end');
+ });
+ },
+ },
+ {class => 'MListbox', w_args => [-columns=>[[-text=>'Heading1',
+ -sortable=>0],
+ [-text=>'Heading2']]],
+ action => sub {
+ my $w = shift;
+ $w->insert("end", [qw(Cell11 Cell12)], [qw(Cell21 Cell22)]);
+ },
+ },
+ {class => 'Cloth', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..50) {
+ $w->Line(-coords => [rand($px_w),rand($px_h),
+ rand($px_w),rand($px_h)],
+ -fill => $colors[rand @colors],
+ -width => rand(4)+1,
+ );
+ }
+ },
+ },
+ {class => 'DirSelect', dialog => 1},
+ {class => 'ExecuteCommand', w_args => [@txt_geom]},
+ {class => 'FontDialog', dialog => 1},
+ {class => 'JBrowseEntry', action => $insert_lb},
+ {class => 'JFileDialog', dialog => 1},
+ {class => 'More', w_args => [@txt_geom], action => sub {
+ shift->Load($DEMO_FILE),
+ }, scrolled => 'oe'},
+ {class => 'ObjEditor', w_args => [@txt_geom, -caller => { dummy => 'object'}]},
+ {class => 'ObjScanner', w_args => [@txt_geom, -caller => $TOP]},
+ {class => 'PodText', require => 'Tk::Pod::Text',
+ w_args => [@txt_geom, -file => 'Tk']},
+ {class => 'XMLViewer', w_args => [@txt_geom], action => sub {
+ shift->insertXML(-text => "<?xml version='1.0' ?><a><bla /><foo>bar</foo></a>");
+ }, scrolled => 'oe'},
+ {class => 'Zinc', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..20) {
+ $w->add('curve', 1, [map { (rand($px_w),rand($px_h)) } (1..5)],
+ -relief => 'roundgroove',
+ -filled => 1,
+ -fillcolor => $colors[rand @colors],
+ );
+ }
+ },
+ },
+ );
+ $f->grid('columnconfigure', $_, -pad => 3, -weight => 1) for (0 .. 1);
+ $f->grid('rowconfigure', $_, -pad => 3, -weight => 1) for (0 .. $#w_def);
+ my $row = -1;
+ for my $w_def (@w_def) {
+ my($separator, $text, $class, @w_args, $action, $scrolled, $dialog, $dialog_action);
+ if (UNIVERSAL::isa($w_def, "HASH")) {
+ $separator = $w_def->{separator};
+ if (!$separator) {
+ $class = $w_def->{class};
+ $text = $w_def->{text} || $class;
+ @w_args = @{ $w_def->{w_args} || [] };
+ $action = $w_def->{action};
+ $scrolled = $w_def->{scrolled};
+ $dialog = $w_def->{dialog};
+ $dialog_action = $w_def->{dialog_action};
+ if ($dialog && !$dialog_action) {
+ $dialog_action = sub { shift->Show };
+ }
+ if ($w_def->{require}) {
+ eval 'require ' . $w_def->{require};
+ if ($@) {
+ warn $@;
+ next;
+ }
+ }
+ }
+ } else {
+ ($text, $class) = ($w_def, $w_def);
+ }
+
+ $row++;
+
+ if ($separator) {
+ $f->Label(-text => $separator,
+ -font => 'Helvetica 18',
+ -pady => 5,
+ )->grid(-row => $row,
+ -column => 0,
+ -columnspan => 3,
+ );
+ next;
+ }
+
+ my $bgcolor = $row%2==0 ? '#c0c0c0' : '#a0a0a0';
+ my $ff = $f->Frame(-background => $bgcolor,
+ )->grid(-row => $row,
+ -column => 1,
+ -sticky => 'news',
+ );
+ my $cw = eval {
+ if ($dialog) {
+ $ff->$class(@w_args)->destroy; # just load it...
+ $ff->Button(-text => 'Open ' . $class,
+ -command => sub {
+ # There are some buggy dialogs which display
+ # already without calling a Show method (e.g. Tk::FBox),
+ # so create here
+ my $d = $ff->$class(@w_args);
+ $dialog_action->($d) if $dialog_action;
+ })->pack;
+ } else {
+ if ($scrolled) {
+ $ff->Scrolled($class, @w_args, -scrollbars => $scrolled)->pack;
+ } else {
+ $ff->$class(@w_args)->pack;
+ }
+ }
+ };
+ if ($@ || !$cw) {
+ warn $@;
+ $row--;
+ $ff->destroy;
+ next;
+ }
+
+ $action->($cw) if $action && !$dialog;
+
+ $f->Label(-text => $text,
+ -background => $bgcolor,
+ -anchor => 'w',
+ )->grid(-row => $row,
+ -column => 0,
+ -sticky => "news",
+ );
+
+ $f->Button(-text => 'Pod',
+ -background => $bgcolor,
+ -command => sub {
+ require Tk::Pod;
+ $TOP->Pod(-file => 'Tk::' . $class);
+ },
+ )->grid(-row => $row,
+ -column => 2,
+ -sticky => 'news',
+ );
+ }
+ # $TOP->WidgetDump;
+}
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/cursor.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/cursor.pl
new file mode 100755
index 00000000000..88809b31af3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/cursor.pl
@@ -0,0 +1,61 @@
+# Predefined cursors.
+# -*- perl -*-
+
+#
+# $Id: $
+# Author: Slaven Rezic
+#
+# Copyright (C) 2006 Slaven Rezic. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Mail: slaven@rezic.de
+# WWW: http://www.rezic.de/eserte/
+#
+
+use vars qw/$TOP/;
+
+sub cursor {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => <<'EOF',
+This window displays the names of Tk's built-in
+resp. predefined X11 cursors. Click on the names
+to see the cursor shape.
+EOF
+ -geometry_manager => 'grid',
+ -title => 'Predefined cursors',
+ -iconname => 'Predefined cursors',
+ );
+
+ my $fh;
+ TRY_CURSORFONTH: {
+ for my $cursorfonth (Tk->findINC("X11/cursorfont.h"),
+ "/usr/X11R6/include/X11/cursorfont.h",
+ "/usr/include/X11/cursorfont.h",
+ ) {
+ last TRY_CURSORFONTH if (open $fh, $cursorfonth);
+ }
+ $TOP->Label(-text => "Sorry. I can't find X11/cursorfont.h on this system.")->grid;
+ return;
+ }
+
+ while(<$fh>) {
+ chomp;
+ if (/XC_(\S+)/) {
+ my $cursorname = $1;
+ next if $cursorname eq 'num_glyphs';
+ push @cursors, $cursorname;
+ }
+ }
+
+ $lb = $TOP->Scrolled("Listbox", -scrollbars => "ose")->grid;
+ $lb->insert("end", @cursors);
+ $lb->bind("<1>", sub {
+ my($inx) = $lb->curselection;
+ $lb->configure(-cursor => $cursors[$inx]);
+ });
+}
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz
new file mode 100755
index 00000000000..c5c8318d145
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/npuz.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/npuz.pl
new file mode 100755
index 00000000000..3a6ba17f937
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/npuz.pl
@@ -0,0 +1,226 @@
+# A N-puzzle implemented via the Grid geometry manager.
+#
+# This program is described in the Perl/Tk column from Volume 1, Issue 4 of
+# The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk
+# distribution with permission. It has been modified slightly to conform
+# to the widget demo standard.
+
+#!/usr/local/bin/perl -w
+#
+# puz - demonstrate the Grid geometry manager by implementing an n-puzzle.
+#
+# Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.EDU
+# 96/08/11.
+#
+# Copyright (C) 1996 - 1998 Stephen O. Lidie. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself.
+
+require 5.002;
+use Tk;
+use Tk::Dialog;
+use strict;
+use subs qw(beep create_puz create_ui puz_fini move_piece new_puz randomly xy);
+
+my $CAMEL; # Perl/Tk Xcamel.gif Photo image
+my $CAMEL_HEIGHT; # Xcamel height
+my $CAMEL_WIDTH; # Xcamel width
+my (@LEVELS) = (9, 16, 36, 64); # possible puzzle piece counts
+my $MW = MainWindow->new; # program's main window
+my @ORDER; # random puzzle piece ordinals
+my $PIECES = $LEVELS[1]; # total puzzle piece count
+my $OLD_PIECES = -1; # previous puzzle piece count
+my $PF; # puzzle Frame
+my @PUZ; # puzzle piece information
+my $SIDE; # pieces per side of puzzle
+my $SPACE; # shortcut to puzzle space piece
+my $SPACE_IMAGE; # space piece image
+
+create_ui;
+create_puz;
+
+sub beep {$MW->bell}
+
+sub create_puz {
+
+ return if $PIECES == $OLD_PIECES;
+
+ # Create all the puzzle pieces - buttons with images - and arrange them
+ # in a rectangular grid. @PUZ is a list of button widget references which
+ # represent the puzzle pieces.
+ #
+ # The actual ordering is controlled by @ORDER, a list of list of two:
+ #
+ # $ORDER[$i]->[0] = puzzle piece ordinal
+ # $ORDER[$i]->[1] = random number used to shuffle the puzzle ordinals
+ #
+ # If the puzzle frame $PF exists, we've been here before, which means that
+ # all images and widgets associated with the previous puzzle need
+ # destroying, plugging a potential memory leak. It's important to note
+ # that an image must be explicity deleted - it doesn't magically go away
+ # if a widget, which just happens to use it, is destroyed. So, loop
+ # through all the puzzle pieces and delete their images, then destroy the
+ # puzzle's master frame $PF, destroying all child widgets. Now, this
+ # scheme isn't particulary efficient, but it is simple; ideally, we'd like
+ # to create these images only once and reuse them as required.
+
+ if (Exists $PF) {
+ my $image;
+ foreach (@PUZ) {
+ $image = $_->cget(-image);
+ $image = $SPACE_IMAGE if not defined $image;
+ $image->delete;
+ }
+ $PF->destroy;
+ }
+
+ $PF = $MW->Frame->grid; # create the puzzle frame grid master
+ $OLD_PIECES = $PIECES;
+ $#PUZ = $#ORDER = $PIECES - 1;
+ $SIDE = sqrt $PIECES;
+
+ my($i, $o, $c, $r, $w, $h, $x, $y, $but, $gif);
+
+ foreach (0..$#ORDER) {$ORDER[$_] = [$_, undef]}
+
+ for($i = 0; $i <= $#PUZ; $i++) {
+ $o = $ORDER[$i]->[0];
+ ($c, $r) = xy $o; # puzzle ordinal to column/row
+ $w = $CAMEL_WIDTH / $SIDE;
+ $h = $CAMEL_HEIGHT / $SIDE;
+ $x = $c * $w; # x/column pixel offset
+ $y = $r * $h; # y/row pixel offset
+ $gif = $PF->Photo; # new, empty, GIF image
+ $gif->copy($CAMEL, -from => $x, $y, $x+$w, $y+$h);
+ $but = $PF->Button(-image => $gif,
+ -relief => 'flat',
+ -borderwidth => 0,
+ -command => \&beep,
+ -highlightthickness => 0,
+ );
+ $PUZ[$o] = $but;
+ ($c, $r) = xy $i;
+ $but->grid(-column => $c, -row => $r, -sticky => 'nsew');
+ if ($o == 0) {
+ $SPACE_IMAGE = $gif;
+ $SPACE = $but;
+ }
+ } # forend all puzzle pieces
+
+} # end create_puz
+
+sub create_ui {
+
+ # Create a color Photo image of the Xcamel puzzle.
+
+ $CAMEL = $MW->Photo(-file => "$WIDTRIB/lib/npuz/Xcamel.npuz");
+ $CAMEL_WIDTH = $CAMEL->image('width');
+ $CAMEL_HEIGHT = $CAMEL->image('height');
+
+ # Create the menubar.
+
+ my $mf = $MW->Frame(-bg => 'blue')->grid(-sticky => 'ew');
+ $mf->gridColumnconfigure(1, -weight => 1);
+
+ my $mbf = $mf->Menubutton(-text => 'File', -relief => 'raised');
+ $mbf->command(-label => 'New Puzzle', -command => \&new_puz);
+ $mbf->separator;
+ $mbf->command(-label => 'Quit', -command => [$MW => 'bell']);
+
+ my $mbp = $mf->Menubutton(-text => 'Prefs', -relief => 'raised');
+ my $pieces = 'Pieces';
+ $mbp->cascade(-label => $pieces);
+ my $mbpm = $mbp->cget(-menu);
+ my $mbpmp = $mbpm->Menu;
+ $mbp->entryconfigure($pieces, -menu => $mbpmp);
+ foreach (@LEVELS) {
+ $mbpmp->radiobutton(-label => $_,
+ -variable => \$PIECES,
+ -value => $_,
+ -command => \&create_puz,
+ );
+ }
+
+ my $mbq = $mf->Menubutton(-text => 'Help', -relief => 'raised');
+ my $about = $MW->Dialog(-text => <<"END"
+npuz Version 1.0\n
+Select \"File/New Puzzle\", then click around the red \"space\" to rearrange the pieces and solve the puzzle!\n\nThis program is described in the Perl/Tk column from Volume 1, Issue 4 of The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk distribution with permission.
+END
+ );
+ $about->configure(-wraplength => '6i');
+ $mbq->command(-label => 'About', -command => [$about => 'Show']);
+
+ $mbf->grid(-row => 0, -column => 0, -sticky => 'w');
+ $mbp->grid(-row => 0, -column => 1, -sticky => 'w');
+ $mbq->grid(-row => 0, -column => 2, -sticky => 'e');
+
+} # end create_ui
+
+sub puz_fini {
+
+ # Return true iff all puzzle pieces are in order.
+
+ my($i, $c, $r, %info);
+ for($i = 0; $i <= $#PUZ; $i++) {
+ ($c, $r) = xy $i;
+ %info = $PUZ[$i]->gridInfo;
+ return 0 if $c != $info{-column} or $r != $info{-row};
+ }
+ return 1;
+
+} # end puz_fini
+
+sub move_piece {
+
+ my($piece) = @_;
+
+ my(%info, $c, $r, $sc, $sr);
+ %info = $piece->gridInfo; ($c, $r) = @info{-column,-row};
+ %info = $SPACE->gridInfo; ($sc, $sr) = @info{-column,-row};
+ if ( ($sr == $r and ($sc == $c-1 or $sc == $c+1)) or
+ ($sc == $c and ($sr == $r-1 or $sr == $r+1)) ) {
+ $SPACE->grid(-column => $c, -row => $r);
+ $piece->grid(-column => $sc, -row => $sr);
+ }
+ if (puz_fini) {
+ my $color = ($SPACE->configure(-activebackground))[3];
+ $SPACE->configure(-image => $SPACE_IMAGE,
+ -activebackground => $color,
+ -background => $color,
+ -relief => 'flat',
+ );
+ foreach (@PUZ) {$_->configure(-command => \&beep)}
+ }
+
+} # end move_piece
+
+sub new_puz {
+
+ srand time;
+ foreach (0..$#ORDER) {$ORDER[$_]->[1] = rand $#ORDER}
+ my @order = sort randomly @ORDER;
+ #@order = @ORDER; # here's how I solve the puzzle (;
+ my($i, $o, $c, $r, $but);
+
+ for($i = 0; $i <= $#PUZ; $i++) {
+ $o = $order[$i]->[0];
+ $but = $PUZ[$o];
+ if ($o == 0) {
+ $but->configure(-background => 'red',
+ -relief => 'sunken',
+ -image => undef,
+ -activebackground => 'red',
+ );
+ } else {
+ $but->configure(-command => [\&move_piece, $but]);
+ }
+ ($c, $r) = xy $i;
+ $but->grid(-column => $c, -row => $r, -sticky => 'nsew');
+ }
+
+} # end new_puz
+
+sub randomly {$a->[1] <=> $b->[1]} # randomize order of puzzle pieces
+
+sub xy {my($n) = @_; ($n % $SIDE, int $n / $SIDE)} # ordinal to X/Y
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/plop.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/plop.pl
new file mode 100755
index 00000000000..bd6f801b03f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widtrib/plop.pl
@@ -0,0 +1,381 @@
+# Plot a series of continuous functions on a Perl/Tk Canvas.
+#
+# This program is described in the Perl/Tk column from Volume 1, Issue 1 of
+# The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk
+# distribution with permission. It has been modified slightly to conform
+# to the widget demo standard.
+
+#!/usr/local/bin/perl -w
+#
+# plot_program - plot a series of continuous functions on a Perl/Tk Canvas.
+#
+# Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.EDU
+# 96/01/27.
+#
+# Copyright (C) 1996 - 1998 Stephen O. Lidie. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself.
+
+require 5.002;
+use strict;
+use Tk;
+use Tk::Dialog;
+use Tk::LabEntry;
+eval {require "plop.fnc";}; # user supplied math functions
+
+# Predeclare global subroutines and variables.
+
+sub collect_errors;
+sub display_coordinates;
+sub initialize_canvas;
+sub initialize_dialogs;
+sub initialize_functions;
+sub initialize_menus;
+sub make_menubutton;
+sub plot_functions;
+sub update_functions;
+
+my $VERSION = '1.0';
+
+# The default sample functions and limits, each in a different color.
+
+my (@FUNCTIONS) = ('sin($x)', 'cos($x)', 'exp($x)', '$x', 'int($x)');
+my (@COLORS) = qw(red green blue orange olivedrab magenta black salmon purple);
+my $NUM_COLORS = scalar @COLORS;
+my ($X_MIN, $X_MAX, $Y_MIN, $Y_MAX) = (-5, 5, -5, 5);
+my ($DX, $DY) = ($X_MAX - $X_MIN, $Y_MAX - $Y_MIN);
+
+# Declare constants that configure the plotting area: a square approximately
+# 500 pixels on a side, with left/right and top/bottom margins of 80 pixles
+# where we can paint axes labels. With this layout there is a 340x340 area
+# available for graphs.
+
+my $MIN_PXL = 0; # minimum Canvas pixel coordinate
+my $MAX_PXL = 300; # maximum Canvas pixel coordinate
+my $MARGIN = 80; # margin size, in pixels
+my $ALEN = $MAX_PXL - 2 * $MARGIN; # X/Y axes length, in pixels
+
+# Declare Perl/Tk widgets and other data.
+
+my $CANV; # Canvas widget used for plotting functions
+my $DIALOG_ABOUT; # Dialog widget showing "About" information
+my $DIALOG_USAGE; # Dialog widget describing plot usage
+my $MBF; # Menubutton frame
+my $MW = MainWindow->new; # program's main window
+my $ORIGINAL_CURSOR = ($MW->configure(-cursor))[3]; # restore this cursor
+my $TEXT; # Text widget showing function definitions
+
+# %ERRORS is a hash to collect eval() and -w errors. The keys are the error
+# messages themselves and the values are the number of times a particular
+# error was detected.
+
+my %ERRORS;
+
+# Begin main.
+
+initialize_dialogs;
+initialize_menus;
+initialize_canvas;
+initialize_functions;
+
+# End main.
+
+sub collect_errors {
+
+ # Update the hash %ERRORS with the latest eval() error message. Remove
+ # the eval() line number (it's useless to us) to maintain a compact hash.
+
+ my($error) = @_;
+
+ $error =~ s/eval\s+(\d+)/eval/;
+ $ERRORS{$error}++;
+
+} # end collect_errors
+
+sub display_coordinates {
+
+ # Print Canvas and Plot coordinates.
+
+ my($canvas) = @_;
+
+ my $e = $canvas->XEvent;
+ my($canv_x, $canv_y) = ($e->x, $e->y);
+ my($x, $y);
+ $x = $X_MIN + $DX * (($canv_x - $MARGIN) / $ALEN);
+ $y = $Y_MAX - $DY * (($canv_y - $MARGIN) / $ALEN);
+ print STDOUT "\nCanvas x = $canv_x, Canvas y = $canv_y.\n";
+ print STDOUT "Plot x = $x, Plot y = $y.\n";
+
+} # end display_coordinates
+
+sub initialize_canvas {
+
+ # Create the Canvas widget and draw axes and labels.
+
+ my($label_offset, $tick_length) = (20, 5);
+
+ $CANV = $MW->Canvas(
+ -width => $MAX_PXL + $MARGIN * 2,
+ -height => $MAX_PXL,
+ -relief => 'sunken',
+ );
+ $CANV->pack;
+ $CANV->Tk::bind('<Button-1>' => \&display_coordinates);
+
+ $CANV->create('text',
+ 225, 25,
+ -text => 'Plot Continuous Functions Of The Form y=f($x)',
+ -fill => 'blue',
+ );
+
+ # Create the line to represent the X axis and label it. Then label the
+ # minimum and maximum X values and draw tick marks to indicate where they
+ # fall. The axis limits are LabEntry widgets embedded in Canvas windows.
+
+ $CANV->create('line',
+ $MIN_PXL + $MARGIN, $MAX_PXL - $MARGIN,
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN,
+ );
+
+ $CANV->create('window',
+ $MIN_PXL + $MARGIN, $MAX_PXL - $label_offset,
+ -window => $MW->LabEntry(
+ -textvariable => \$X_MIN,
+ -label => 'X Minimum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MIN_PXL + $MARGIN, $MAX_PXL - $MARGIN - $tick_length,
+ $MIN_PXL + $MARGIN, $MAX_PXL - $MARGIN + $tick_length,
+ );
+
+ $CANV->create('window',
+ $MAX_PXL - $MARGIN, $MAX_PXL - $label_offset,
+ -window => $MW->LabEntry(
+ -textvariable => \$X_MAX,
+ -label => 'X Maximum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN - $tick_length,
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN + $tick_length,
+ );
+
+ # Create the line to represent the Y axis and label it. Then label the
+ # minimum and maximum Y values and draw tick marks to indicate where they
+ # fall. The axis limits are LabEntry widgets embedded in Canvas windows.
+
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN, $MIN_PXL + $MARGIN,
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN,
+ );
+
+ $CANV->create('window',
+ $MAX_PXL + $label_offset, $MIN_PXL + $MARGIN,
+ -window => $MW->LabEntry(
+ -textvariable => \$Y_MAX,
+ -label => 'Y Maximum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN - $tick_length, $MIN_PXL + $MARGIN,
+ $MAX_PXL - $MARGIN + $tick_length, $MIN_PXL + $MARGIN,
+ );
+
+ $CANV->create('window',
+ $MAX_PXL + $label_offset, $MAX_PXL - $MARGIN,
+ -window => $MW->LabEntry(
+ -textvariable => \$Y_MIN,
+ -label => 'Y Minimum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN - $tick_length, $MAX_PXL - $MARGIN,
+ $MAX_PXL - $MARGIN + $tick_length, $MAX_PXL - $MARGIN,
+ );
+
+} # end initialize_canvas
+
+sub initialize_dialogs {
+
+ # Create all application Dialog objects.
+
+ $DIALOG_ABOUT = $MW->Dialog(
+ -title => 'About',
+ -text =>
+"plot_program $VERSION\n\n95/12/04\n\nThis program is described in the Perl/Tk column from Volume 1, Issue 1 of The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk distribution with permission.",
+ -bitmap => 'info',
+ -buttons => ['Dismiss'],
+ );
+ $DIALOG_ABOUT->configure(-wraplength => '6i');
+ $DIALOG_USAGE = $MW->Dialog(
+ -title => 'Usage',
+ -buttons => ['Dismiss'],
+ );
+ $DIALOG_USAGE->Subwidget('message')->configure(
+ -wraplength => '4i',
+ -text => "plot_program iterates over the range of values X Minimum to X Maximum, setting the variable \$x to each value in turn, then evaluates each f(\$x) and paints a point on the Y axis. The X axis increment is (Xmax - Xmin) / $ALEN.\n\nJust enter your functions in the Text widget and click the Plot button.\n\nYou can define a file named \"plop.fnc\" that contains additional private math functions, which is automatically \"require\"d by plot_program. In this file are your private functions that you can plot.\n\nPressing button one on the pointing device displays on standard output the current canvas and plot X and Y coordinates.",
+ );
+
+} # end initialize_dialogs
+
+sub initialize_functions {
+
+ # Pack a spacer Frame and then display instructions in a Label widget.
+
+# $MW->Frame(-height => 10)->pack;
+ $MW->Label(
+ -text => 'Enter your functions here',
+ -foreground => 'blue',
+ )->pack;
+
+ # Create a Frame with a scrollable Text widget that displays the function
+ # list, and a Button to initiate plot activities.
+
+ my $functions_frame = $MW->Frame;
+ $functions_frame->pack;
+ $TEXT = $functions_frame->Text(-height => 3);
+ $TEXT->pack;
+ $functions_frame->AddScrollbars($TEXT);
+ $functions_frame->configure(-scrollbars => 'e');
+ update_functions;
+
+ my $buttons_frame = $MW->Frame;
+ $buttons_frame->pack(-padx => 10, -pady => 5, -expand => 1, -fill => 'x');
+ my @pack_attributes = qw(-side left -fill x -expand 1);
+ $buttons_frame->Button(
+ -text => 'Plot',
+ -command => \&plot_functions,
+ )->pack(@pack_attributes);
+
+} # end initialize_functions
+
+sub initialize_menus {
+
+ # Create the Menubuttons and their associated Menu items.
+
+ $MBF = $MW->Frame(-relief => 'raised', -borderwidth => 1);
+ $MBF->pack(-fill => 'x');
+
+ make_menubutton($MBF, 'File', 0, 'left',
+ [
+ ['Quit', [$MW => 'bell'], 0],
+ ],
+ );
+ make_menubutton($MBF, 'Help', 0, 'right',
+ [
+ ['About', [$DIALOG_ABOUT => 'Show'], 0],
+ ['', undef, 0],
+ ['Usage', [$DIALOG_USAGE => 'Show'], 0],
+ ],
+ );
+
+} # end initialize_menus
+
+sub make_menubutton {
+
+ # Make a Menubutton widget; note that the Menu is automatically created.
+ # If the label is '', make a separator.
+
+ my($mbf, $mb_label, $mb_label_underline, $pack, $mb_list_ref) = @_;
+
+ my $mb = $mbf->Menubutton(
+ -text => $mb_label,
+ -underline => $mb_label_underline,
+ );
+ my $mb_list;
+ foreach $mb_list (@{$mb_list_ref}) {
+ $mb_list->[0] eq '' ? $mb->separator :
+ $mb->command(
+ -label => $mb_list->[0],
+ -command => $mb_list->[1],
+ -underline => $mb_list->[2],
+ );
+ }
+ $mb->pack(-side => $pack);
+
+} # end make_menubutton
+
+sub plot_functions {
+
+ # Plot all the functions.
+
+ my($x, $y, $canv_x, $canv_y) = (0, 0, 0, 0);
+ $canv_x = $MIN_PXL + $MARGIN; # X minimum
+ $MW->configure(-cursor => 'watch');
+ $DX = $X_MAX - $X_MIN; # update delta X
+ $DY = $Y_MAX - $Y_MIN; # update delta Y
+ $CANV->delete('plot'); # erase all previous plots
+
+ # Fetch the newline-separated Text widget contents and update the function
+ # list @FUNCTIONS. Also update the Text widget with the new colors.
+
+ @FUNCTIONS = ();
+ foreach (split /\n/, $TEXT->get('0.0', 'end')) {
+ next if $_ eq '';
+ push @FUNCTIONS, $_;
+ }
+ update_functions;
+ $MW->idletasks;
+
+ %ERRORS = ();
+ local $SIG{'__WARN__'} = sub {collect_errors($_[0])};
+
+ALL_X_VALUES:
+ for ($x = $X_MIN; $x <= $X_MAX; $x += ($X_MAX - $X_MIN) / $ALEN) {
+
+ ALL_FUNCTIONS:
+ foreach (0 .. $#FUNCTIONS) {
+ next if $FUNCTIONS[$_] =~ /^ERROR:/;
+ $y = eval $FUNCTIONS[$_];
+ if ($::EVAL_ERROR) {
+ collect_errors($::EVAL_ERROR);
+ next;
+ }
+ $canv_y = (($Y_MAX - $y) / $DY) * $ALEN + $MARGIN;
+ $CANV->create('text', $canv_x, $canv_y,
+ -fill => $COLORS[$_ % $NUM_COLORS],
+ -tags => ['plot'],
+ -text => '.',
+ ) if $canv_y > $MIN_PXL + $MARGIN and
+ $canv_y < $MAX_PXL - $MARGIN;
+ } # forend ALL_FUNCTIONS
+
+ $canv_x++; # next X pixel
+
+ } # forend ALL_X_VALUES
+
+ $MW->configure(-cursor => $ORIGINAL_CURSOR);
+ $MW->idletasks;
+
+ # Print all the eval() errors to alert the user of malformed functions.
+
+ print STDOUT "\n" if %ERRORS;
+ foreach (keys %ERRORS) {
+ print STDOUT "$ERRORS{$_} occurrences of $_";
+ }
+
+} # end plot_functions
+
+sub update_functions {
+
+ # Insert the function list into the Text widget.
+
+ $TEXT->delete('0.0', 'end');
+ my $i = 0;
+ foreach (@FUNCTIONS) {
+ $TEXT->insert('end', "$_\n", [$i]);
+ $TEXT->tagConfigure($i,
+ -foreground => $COLORS[$i % $NUM_COLORS],
+ -font => 'fixed',
+ );
+ $i++;
+ }
+ $TEXT->yview('end');
+
+} # end update_function_list
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/event.pod b/Master/tlpkg/tlperl.straw/lib/Tk/event.pod
new file mode 100755
index 00000000000..9012a596267
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/event.pod
@@ -0,0 +1,417 @@
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::event - Miscellaneous event facilities: define virtual events and generate events
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<event>I<Action>(?I<arg, arg, ...>?);
+
+=head1 DESCRIPTION
+
+The B<event>I<Action> methods provides several facilities for dealing with
+window system events, such as defining virtual events and synthesizing
+events. Virtual events are shared by all widgets of the same
+B<MainWindow>. Different L<MainWindow|Tk::MainWindow>s can have different
+virtual event.
+
+The following methods are currently supported:
+
+=over 4
+
+=item I<$widget>-E<gt>B<eventAdd>(B<'E<lt>E<lt>>I<virtual>B<E<gt>E<gt>'>I<, sequence >?,I<sequence, ...>?)
+
+Associates the virtual event I<virtual> with the physical
+event sequence(s) given by the I<sequence> arguments, so that
+the virtual event will trigger whenever any one of the I<sequence>s
+occurs.
+I<Virtual> may be any string value and I<sequence> may have
+any of the values allowed for the I<sequence> argument to the
+L<bind|Tk::bind> method.
+If I<virtual> is already defined, the new physical event sequences
+add to the existing sequences for the event.
+
+=item I<$widget>-E<gt>B<eventDelete>(B<'E<lt>E<lt>>I<virtual>B<E<gt>E<gt>'> ?,I<sequence,> I<sequence, ...>?)
+
+Deletes each of the I<sequence>s from those associated with
+the virtual event given by I<virtual>.
+I<Virtual> may be any string value and I<sequence> may have
+any of the values allowed for the I<sequence> argument to the
+L<bind|Tk::bind> method.
+Any I<sequence>s not currently associated with I<virtual>
+are ignored.
+If no I<sequence> argument is provided, all physical event sequences
+are removed for I<virtual>, so that the virtual event will not
+trigger anymore.
+
+=item I<$widget>-E<gt>B<eventGenerate>(I<event> ?,I<option =E<gt> value, option =E<gt> value, ...>?)
+
+Generates a window event and arranges for it to be processed just as if
+it had come from the window system.
+I<$window> is a reference to the window for which the event
+will be generated.
+I<Event> provides a basic description of
+the event, such as B<E<lt>Shift-Button-2E<gt>> or B<E<lt>E<lt>PasteE<gt>E<gt>>.
+If I<Window> is empty the whole screen is meant, and coordinates
+are relative to the screen.
+I<Event> may have any of the forms allowed for the I<sequence>
+argument of the L<bind|Tk::bind> method except that it must consist
+of a single event pattern, not a sequence.
+I<Option-value> pairs may be used to specify additional
+attributes of the event, such as the x and y mouse position;
+see L<"EVENT FIELDS"> below. If the B<-when> option is not specified, the
+event is processed immediately: all of the handlers for the event
+will complete before the B<eventGenerate> method returns.
+If the B<-when> option is specified then it determines when the
+event is processed.
+
+=item I<$widget>-E<gt>B<eventInfo>(?'B<E<lt>E<lt>>I<virtual>B<E<gt>E<gt>'>?)
+
+Returns information about virtual events.
+If the B<E<lt>E<lt>>I<virtual>B<E<gt>E<gt>> argument is omitted, the return value
+is a list of all the virtual events that are currently defined.
+If B<E<lt>E<lt>>I<virtual>B<E<gt>E<gt>> is specified then the return value is
+a list whose elements are the physical event sequences currently
+defined for the given virtual event; if the virtual event is
+not defined then B<undef> is returned.
+
+=back
+
+=head1 EVENT FIELDS
+
+The following options are supported for the B<eventGenerate>
+method. These correspond to the ``%'' expansions
+allowed in binding callback for the L<bind|Tk::bind> method.
+
+=over 4
+
+=item B<-above> => I<window>
+
+I<Window> specifies the I<above> field for the event,
+either as a window path name or as an integer window id.
+Valid for B<Configure> events.
+Corresponds to the L<%a|Tk::bind/'a'> substitution for binding scripts.
+
+=item B<-borderwidth> => I<size>
+
+I<Size> must be a screen distance; it specifies the
+I<border_width> field for the event.
+Valid for B<Configure> events.
+Corresponds to the L<%B|Tk::bind/'B'> substitution for binding scripts.
+
+=item B<-button> => I<number>
+
+I<Number> must be an integer; it specifies the I<detail> field
+for a B<ButtonPress> or B<ButtonRelease> event, overriding
+any button number provided in the base I<event> argument.
+Corresponds to the L<%b|Tk::bind/'b'> substitution for binding scripts.
+
+=item B<-count> => I<number>
+
+I<Number> must be an integer; it specifies the I<count> field
+for the event. Valid for B<Expose> events.
+Corresponds to the L<%c|Tk::bind/'c'> substitution for binding scripts.
+
+=item B<-delta> =E<gt> I<number>
+
+B<number> must be an integer; it specifies the B<delta> field for the
+B<MouseWheel> event. The delta refers to the direction and magnitude the
+mouse wheel was rotated. Note the value is not a screen distance but
+are units of motion in the mouse wheel. Typically these values are
+multiples of 120. For example, 120 should scroll the text widget up 4
+lines and -240 would scroll the text widget down 8 lines. Of course,
+other widgets may define different behaviors for mouse wheel motion.
+This field corresponds to the %D substitution for binding scripts.
+
+=item B<-detail> => I<detail>
+
+I<Detail> specifies the I<detail> field for the event
+and must be one of the following:
+
+=over 8
+
+ NotifyAncestor NotifyNonlinearVirtual
+ NotifyDetailNone NotifyPointer
+ NotifyInferior NotifyPointerRoot
+ NotifyNonlinear NotifyVirtual
+
+=back
+
+Valid for B<Enter>, B<Leave>, B<FocusIn> and
+B<FocusOut> events.
+Corresponds to the L<%d|Tk::bind/'d'> substitution for binding scripts.
+
+=item B<-focus>I< boolean>
+
+I<Boolean> must be a boolean value; it specifies the I<focus>
+field for the event.
+Valid for B<Enter> and B<Leave> events.
+Corresponds to the L<%f|Tk::bind/'f'> substitution for binding scripts.
+
+=item B<-height>I< size>
+
+I<Size> must be a screen distance; it specifies the I<height>
+field for the event. Valid for B<Configure> events.
+Corresponds to the L<%h|Tk::bind/'h'> substitution for binding scripts.
+
+=item B<-keycode>I< number>
+
+I<Number> must be an integer; it specifies the I<keycode>
+field for the event.
+Valid for B<KeyPress> and B<KeyRelease> events.
+Corresponds to the L<%k|Tk::bind/'k'> substitution for binding scripts.
+
+=item B<-keysym>I< name>
+
+I<Name> must be the name of a valid keysym, such as B<g>,
+B<space>, or B<Return>; its corresponding
+keycode value is used as the I<keycode> field for event, overriding
+any detail specified in the base I<event> argument.
+Valid for B<KeyPress> and B<KeyRelease> events.
+Corresponds to the L<%K|Tk::bind/'K'> substitution for binding scripts.
+
+=item B<-mode>I< notify>
+
+I<Notify> specifies the I<mode> field for the event and must be
+one of B<NotifyNormal>, B<NotifyGrab>, B<NotifyUngrab>, or
+B<NotifyWhileGrabbed>.
+Valid for B<Enter>, B<Leave>, B<FocusIn>, and
+B<FocusOut> events.
+Corresponds to the L<%m|Tk::bind/'m'> substitution for binding scripts.
+
+=item B<-override>I< boolean>
+
+I<Boolean> must be a boolean value; it specifies the
+I<override_redirect> field for the event.
+Valid for B<Map>, B<Reparent>, and B<Configure> events.
+Corresponds to the L<%o|Tk::bind/'o'> substitution for binding scripts.
+
+=item B<-place>I< where>
+
+I<Where> specifies the I<place> field for the event; it must be
+either B<PlaceOnTop> or B<PlaceOnBottom>.
+Valid for B<Circulate> events.
+Corresponds to the L<%p|Tk::bind/'p'> substitution for binding scripts.
+
+=item B<-root>I< window>
+
+I<Window> must be either a window path name or an integer window
+identifier; it specifies the I<root> field for the event.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Enter>, B<Leave>, and B<Motion>
+events.
+Corresponds to the L<%R|Tk::bind/'R'> substitution for binding scripts.
+
+=item B<-rootx>I< coord>
+
+I<Coord> must be a screen distance; it specifies the I<x_root>
+field for the event.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Enter>, B<Leave>, and B<Motion>
+events. Corresponds to the L<%X|Tk::bind/'X'> substitution for binding scripts.
+
+=item B<-rooty>I< coord>
+
+I<Coord> must be a screen distance; it specifies the I<y_root>
+field for the event.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Enter>, B<Leave>, and B<Motion>
+events.
+Corresponds to the L<%Y|Tk::bind/'Y'> substitution for binding scripts.
+
+=item B<-sendevent>I< boolean>
+
+B<Boolean> must be a boolean value; it specifies the I<send_event>
+field for the event. Valid for all events. Corresponds to the
+L<%E|Tk::bind/'E'> substitution for binding scripts.
+
+=item B<-serial>I< number>
+
+I<Number> must be an integer; it specifies the I<serial> field
+for the event. Valid for all events.
+Corresponds to the L<%#|Tk::bind/'#'> substitution for binding scripts.
+
+=item B<-state>I< state>
+
+I<State> specifies the I<state> field for the event.
+For B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Enter>, B<Leave>, and B<Motion> events
+it must be an integer value.
+For B<Visibility> events it must be one of B<VisibilityUnobscured>,
+B<VisibilityPartiallyObscured>, or B<VisibilityFullyObscured>.
+This option overrides any modifiers such as B<Meta> or B<Control>
+specified in the base I<event>.
+Corresponds to the L<%s|Tk::bind/'s'> substitution for binding scripts.
+
+=item B<-subwindow>I< window>
+
+I<Window> specifies the I<subwindow> field for the event, either
+as a path name for a Tk widget or as an integer window identifier.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Enter>, B<Leave>, and B<Motion> events.
+Similar to L<%S|Tk::bind/'S'> substitution for binding scripts.
+
+=item B<-time>I< integer>
+
+I<Integer> must be an integer value; it specifies the I<time> field
+for the event.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Enter>, B<Leave>, B<Motion>,
+and B<Property> events.
+Corresponds to the L<%t|Tk::bind/'t'> substitution for binding scripts.
+
+
+=item B<-warp>I< boolean>
+
+I<boolean> must be a boolean value; it specifies whether
+the screen pointer should be warped as well.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, and B<Motion> events.
+
+=item B<-width>I< size>
+
+I<Size> must be a screen distance; it specifies the I<width> field
+for the event.
+Valid for B<Configure> events.
+Corresponds to the L<%w|Tk::bind/'w'> substitution for binding scripts.
+
+=item B<-when>I< when>
+
+I<When> determines when the event will be processed; it must have one
+of the following values:
+
+=over 8
+
+=item B<now>
+
+Process the event immediately, before the command returns.
+This also happens if the B<-when> option is omitted.
+
+=item B<tail>
+
+Place the event on perl/Tk's event queue behind any events already
+queued for this application.
+
+=item B<head>
+
+Place the event at the front of perl/Tk's event queue, so that it
+will be handled before any other events already queued.
+
+=item B<mark>
+
+Place the event at the front of perl/Tk's event queue but behind any
+other events already queued with B<-when mark>.
+This option is useful when generating a series of events that should
+be processed in order but at the front of the queue.
+
+=back
+
+=item B<-x>I< coord>
+
+I<Coord> must be a screen distance; it specifies the I<x> field
+for the event.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Motion>, B<Enter>, B<Leave>,
+B<Expose>, B<Configure>, B<Gravity>, and B<Reparent>
+events.
+Corresponds to the the L<%x|Tk::bind/'x'> substitution for binding scripts.
+If I<Window> is empty the coordinate is relative to the
+screen, and this option corresponds to the L<%X|Tk::bind/'X'> substitution
+for binding scripts.
+
+=item B<-y>I< coord>
+
+I<Coord> must be a screen distance; it specifies the I<y>
+field for the event.
+Valid for B<KeyPress>, B<KeyRelease>, B<ButtonPress>,
+B<ButtonRelease>, B<Motion>, B<Enter>, B<Leave>,
+B<Expose>, B<Configure>, B<Gravity>, and B<Reparent>
+events.
+Corresponds to the the L<%y|Tk::bind/'y'> substitution for binding scripts.
+If I<Window> is empty the coordinate is relative to the
+screen, and this option corresponds to the L<%Y|Tk::bind/'Y'> substitution
+for binding scripts.
+
+Any options that are not specified when generating an event are filled
+with the value 0, except for I<serial>, which is filled with the
+next X event serial number.
+
+=back
+
+=head1 VIRTUAL EVENT EXAMPLES
+
+In order for a virtual event binding to trigger, two things must
+happen. First, the virtual event must be defined with the
+B<eventAdd> method. Second, a binding must be created for
+the virtual event with the B<bind> method.
+Consider the following virtual event definitions:
+
+ $widget->eventAdd('<<Paste>>' => '<Control-y>');
+ $widget->eventAdd('<<Paste>>' => '<Button-2>');
+ $widget->eventAdd('<<Save>>' => '<Control-X><Control-S>');
+ $widget->eventAdd('<<Save>>' => '<Shift-F12>');
+
+In the B<bind> method, a virtual event can be bound like any other
+builtin event type as follows:
+
+ $entry->bind('Tk::Entry', '<<Paste>>' => sub {
+ $entry->Insert($entry->selectionGet) });
+
+The double angle brackets are used to specify that a virtual event is being
+bound. If the user types Control-y or presses button 2, or if
+a B<E<lt>E<lt>PasteE<gt>E<gt>> virtual event is synthesized with B<eventGenerate>,
+then the B<E<lt>E<lt>PasteE<gt>E<gt>> binding will be invoked.
+
+If a virtual binding has the exact same sequence as a separate
+physical binding, then the physical binding will take precedence.
+Consider the following example:
+
+ $mw->eventAdd('<<Paste>>' => '<Control-y>','<Meta-Control-y>');
+ $mw->bind('Tk::Entry', '<Control-y>' => sub{print 'Control-y'});
+ $mw->bind('Tk::Entry', '<<Paste>>' => sub{print 'Paste'});
+
+When the user types Control-y the B<E<lt>Control-yE<gt>> binding
+will be invoked, because a physical event is considered
+more specific than a virtual event, all other things being equal.
+However, when the user types Meta-Control-y the
+B<E<lt>E<lt>PasteE<gt>E<gt>> binding will be invoked, because the
+B<Meta> modifier in the physical pattern associated with the
+virtual binding is more specific than the B<E<lt>Control-y>E<gt> sequence for
+the physical event.
+
+Bindings on a virtual event may be created before the virtual event exists.
+Indeed, the virtual event never actually needs to be defined, for instance,
+on platforms where the specific virtual event would meaningless or
+ungeneratable.
+
+When a definition of a virtual event changes at run time, all windows
+will respond immediately to the new definition.
+Starting from the preceding example, if the following code is executed:
+
+ $entry->bind(ref($entry), '<Control-y>' => undef);
+ $entry->eventAdd('<<Paste>>' => '<Key-F6>');
+
+the behavior will change such in two ways. First, the shadowed
+B<E<lt>E<lt>PasteE<gt>E<gt>> binding will emerge.
+Typing Control-y will no longer invoke the B<E<lt>Control-yE<gt>> binding,
+but instead invoke the virtual event B<E<lt>E<lt>PasteE<gt>E<gt>>. Second,
+pressing the F6 key will now also invoke the B<E<lt>E<lt>PasteE<gt>E<gt>> binding.
+
+=head1 SEE ALSO
+
+L<Tk::bind|Tk::bind>
+L<Tk::callbacks|Tk::callbacks>
+
+=head1 KEYWORDS
+
+event, binding, define, handle, virtual event
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/exit.pod b/Master/tlpkg/tlperl.straw/lib/Tk/exit.pod
new file mode 100755
index 00000000000..bb564cd0b82
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/exit.pod
@@ -0,0 +1,42 @@
+# Copyright (c) 1993 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::exit - End the application
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+ use Tk qw(exit);
+ ...
+ B<exit>?(I<returnCode>)?;
+
+=head1 DESCRIPTION
+
+Terminate the process, returning I<returnCode> to the
+system as the exit status.
+If I<returnCode> isn't specified then it defaults
+to 0.
+
+If calling C<exit> from code invoked via a Tk callback then
+this Tk version of C<exit> cleans up more reliably than using
+the perl C<exit>.
+
+=head1 CAVEATS
+
+Using C<exit> from a forked process will terminate both the child
+process B<and> the parent process. As C<Tk::exit> is imported by
+default one should use C<CORE::exit> in the forked process instead.
+
+=head1 KEYWORDS
+
+exit, process
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/file.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/file.xbm
new file mode 100755
index 00000000000..7bf12bb4c9f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/file.xbm
@@ -0,0 +1,5 @@
+#define file_width 12
+#define file_height 12
+static unsigned char file_bits[] = {
+ 0xfe, 0x00, 0x02, 0x03, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02,
+ 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0xfe, 0x03};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/file.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/file.xpm
new file mode 100755
index 00000000000..10cc24f9a1e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/file.xpm
@@ -0,0 +1,18 @@
+/* XPM */
+static char * file_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c #000000000000",
+"X c white",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .......... "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/fileevent.pod b/Master/tlpkg/tlperl.straw/lib/Tk/fileevent.pod
new file mode 100755
index 00000000000..1a98cfd6b71
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/fileevent.pod
@@ -0,0 +1,112 @@
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::fileevent - Execute a callback when a filehandle becomes readable or writable
+
+=for category Binding Events and Callbacks
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<fileevent>(I<fileHandle>,B<readable>?,I<callback>?)
+
+I<$widget>-E<gt>B<fileevent>(I<fileHandle>,B<writable>?,I<callback>?)
+
+=head1 DESCRIPTION
+
+This command is used to create I<file event handlers>. A file event
+handler is a binding between a filehandle and a callback, such that the callback
+is evaluated whenever the filehandle becomes readable or writable. File event
+handlers are most commonly used to allow data to be received from another
+process on an event-driven basis, so that the receiver can continue to
+interact with the user while waiting for the data to arrive. If an
+application invokes C<E<lt>E<gt>>, C<sysread> or C<read> on a blocking filehandle when
+there is no input data available, the process will block; until the input
+data arrives, it will not be able to service other events, so it will
+appear to the user to ``freeze up''. With B<fileevent>, the process can
+tell when data is present and only invoke B<gets> or B<read> when
+they won't block.
+
+The I<fileHandle> argument to B<fileevent> refers to an open filehandle,
+such as the return value from a previous B<open> or B<socket>
+command.
+If the I<callback> argument is specified, then B<fileevent>
+creates a new event handler: I<callback> will be evaluated
+whenever the filehandle becomes readable or writable (depending on the
+argument to B<fileevent>).
+In this case B<fileevent> returns an empty string.
+The B<readable> and B<writable> event handlers for a file
+are independent, and may be created and deleted separately.
+However, there may be at most one B<readable> and one B<writable>
+handler for a file at a given time in a given interpreter.
+If B<fileevent> is called when the specified handler already
+exists in the invoking interpreter, the new callback replaces the old one.
+
+If the I<callback> argument is not specified, B<fileevent>
+returns the current callback for I<fileHandle>, or an empty string
+if there is none.
+If the I<callback> argument is specified as an empty string
+then the event handler is deleted, so that no callback will be invoked.
+A file event handler is also deleted automatically whenever
+its filehandle is closed or its interpreter is deleted.
+
+A filehandle is considered to be readable if there is unread data
+available on the underlying device.
+A filehandle is also considered to be readable if an end of file or
+error condition is present on the underlying file or device.
+It is important for I<callback> to check for these conditions
+and handle them appropriately; for example, if there is no special
+check for end of file, an infinite loop may occur where I<callback>
+reads no data, returns, and is immediately invoked again.
+
+A filehandle is considered to be writable if at least one byte of data
+can be written to the underlying file or device without blocking,
+or if an error condition is present on the underlying file or device.
+
+Event-driven I/O works best for filehandles that have been
+placed into nonblocking mode.
+In blocking mode, a C<print> command may block if you give it
+more data than the underlying file or device can accept, and a
+C<E<lt>E<gt>>, C<sysread> or C<read> command will block if you attempt to read
+more data than is ready; no events will be processed while the
+commands block.
+In nonblocking mode C<print>, C<E<lt>E<gt>>, C<sysread> and C<read> never block.
+See the documentation for the individual commands for information
+on how they handle blocking and nonblocking filehandles.
+
+The callback for a file event is executed in the context of I<$widget>
+with which B<fileevent> was invoked.
+If an error occurs while executing the callback then the
+L<Tk::Error> mechanism is used to report the error.
+In addition, the file event handler is deleted if it ever returns
+an error; this is done in order to prevent infinite loops due to
+buggy handlers.
+
+=head1 BUGS
+
+On windows platforms B<fileevent> is limited in the types of filehandles
+that behave correctly. Making filefhandles non-blocking is only implemented
+on a subset of UNIX platforms (see L<Tk::IO>).
+
+=head1 CREDITS
+
+B<fileevent> is based on the B<addinput> command created
+by Mark Diekhans.
+
+=head1 SEE ALSO
+
+L<Tk::IO|Tk::IO>
+L<Tk::callbacks|Tk::callbacks>
+
+=head1 KEYWORDS
+
+asynchronous I/O, blocking, filehandle, event handler, nonblocking, readable,
+callback, writable.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/focus.pod b/Master/tlpkg/tlperl.straw/lib/Tk/focus.pod
new file mode 100755
index 00000000000..5392d8e07bd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/focus.pod
@@ -0,0 +1,166 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+focus - Manage the input focus
+
+=for category User Interaction
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<focus>
+
+S< >I<$widget>-E<gt>B<focus>I<Option>
+
+S< >I<$widget>-E<gt>B<focusNext>
+
+S< >I<$widget>-E<gt>B<focusPrev>
+
+S< >I<$widget>-E<gt>B<focusFollowsMouse>
+
+=head1 DESCRIPTION
+
+The B<focus> methods are used to manage the Tk input focus.
+At any given time, one window on each display is designated as
+the I<focus window>; any key press or key release events for the
+display are sent to that window.
+It is normally up to the window manager to redirect the focus among the
+top-level windows of a display. For example, some window managers
+automatically set the input focus to a top-level window whenever
+the mouse enters it; others redirect the input focus only when
+the user clicks on a window.
+Usually the window manager will set the focus
+only to top-level windows, leaving it up to the application to
+redirect the focus among the children of the top-level.
+
+Tk remembers one focus window for each top-level (the most recent
+descendant of that top-level to receive the focus); when the window
+manager gives the focus
+to a top-level, Tk automatically redirects it to the remembered
+window. Within a top-level Tk uses an I<explicit> focus model
+by default. Moving the mouse within a top-level does not normally
+change the focus; the focus changes only when a widget
+decides explicitly to claim the focus (e.g., because of a button
+click), or when the user types a key such as Tab that moves the
+focus.
+
+The method B<focusFollowsMouse> may be invoked to
+create an I<implicit> focus model: it reconfigures Tk so that
+the focus is set to a window whenever the mouse enters it.
+The methods B<focusNext> and B<focusPrev>
+implement a focus order among the windows of a top-level; they
+are used in the default bindings for Tab and Shift-Tab, among other
+things.
+
+The B<focus> methods can take any of the following forms:
+
+=over 4
+
+=item I<$widget>-E<gt>B<focusCurrent>
+
+Returns the focus window on the display containing
+the I<$widget>, or an empty string if no window in
+this application has the focus on that display.
+
+=item I<$widget>-E<gt>B<focus>
+
+If the application currently has the input focus on I<$widget>'s
+display, this command resets the input focus for I<$widget>'s display
+to I<$widget> and returns an empty string.
+If the application doesn't currently have the input focus on
+I<$widget>'s display, I<$widget> will be remembered as the focus
+for its top-level; the next time the focus arrives at the top-level,
+Tk will redirect it to I<$widget>.
+
+=item I<$widget>-E<gt>B<focusForce>
+
+Sets the focus of I<$widget>'s display to I<$widget>, even if
+the application doesn't currently have the input focus for the display.
+This command should be used sparingly, if at all.
+In normal usage, an application should not claim the focus for
+itself; instead, it should wait for the window manager to give it
+the focus.
+
+=item I<$widget>-E<gt>B<focusLast>
+
+Returns the name of the most recent window to have the input focus
+among all the windows in the same top-level as I<$widget>.
+If no window in that top-level has ever had the input focus, or
+if the most recent focus window has been deleted, then
+the top-level is returned. The return value is the window that
+will receive the input focus the next time the window manager gives
+the focus to the top-level.
+
+=item I<$widget>-E<gt>B<focusNext>
+
+=item I<$widget>-E<gt>B<focusPrev>
+
+B<focusNext> is a utility method used for keyboard traversal, but can be
+useful in other contexts.
+It sets the focus to the ``next'' window after I<$widget> in focus order.
+The focus order is determined by
+the stacking order of windows and the structure of the window hierarchy.
+Among siblings, the focus order is the same as the stacking order, with the
+lowest window being first.
+If a window has children, the window is visited first, followed by
+its children (recursively), followed by its next sibling.
+Top-level windows other than I<$widget> are skipped, so that
+B<focusNext> never returns a window in a different top-level
+from I<$widget>.
+
+After computing the next window, B<focusNext> examines the
+window's B<-takefocus> option to see whether it should be skipped.
+If so, B<focusNext> continues on to the next window in the focus
+order, until it eventually finds a window that will accept the focus
+or returns back to I<$widget>.
+
+B<focusPrev> is similar to B<focusNext> except that it
+sets the focus to the window just before I<$widget> in the focus order.
+
+=item I<$widget>-E<gt>B<focusFollowsMouse>
+
+B<focusFollowsMouse> changes the focus model for the application
+to an implicit one where the window under the mouse gets the focus.
+After this procedure is called, whenever the mouse enters a window
+Tk will automatically give it the input focus.
+The B<focus> command may be used to move the focus to a window
+other than the one under the mouse, but as soon as the mouse moves
+into a new window the focus will jump to that window.
+Note: at present there is no built-in support for returning the
+application to an explicit focus model; to do this you'll have
+to write a script that deletes the bindings created by
+B<focusFollowsMouse>.
+
+=back
+
+=head1 QUIRKS
+
+When an internal window receives the input focus, Tk doesn't actually
+set the X focus to that window; as far as X is concerned, the focus
+will stay on the top-level window containing the window with the focus.
+However, Tk generates FocusIn and FocusOut events just as if the X
+focus were on the internal window. This approach gets around a
+number of problems that would occur if the X focus were actually moved;
+the fact that the X focus is on the top-level is invisible unless
+you use C code to query the X server directly.
+
+=head1 CAVEATS
+
+Note that for the B<Canvas> widget, the call to B<focus> has to be
+fully qualified. This is because there is already a focus method for
+the B<Canvas> widget, which sets the focus on individual canvas tags.
+
+S< >I<$canvas>-E<gt>B<Tk::focus>
+
+
+=head1 KEYWORDS
+
+events, focus, keyboard, top-level, window manager
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/folder.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/folder.xbm
new file mode 100755
index 00000000000..0398f0de777
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/folder.xbm
@@ -0,0 +1,5 @@
+#define folder_width 16
+#define folder_height 10
+static unsigned char folder_bits[] = {
+ 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08,
+ 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0xff, 0x07};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/folder.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/folder.xpm
new file mode 100755
index 00000000000..fda7c15a549
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/folder.xpm
@@ -0,0 +1,21 @@
+/* XPM */
+static char * folder_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 3 1",
+/* colors */
+" s None c None",
+". c black",
+"X c #f0ff80",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+"............. "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/form.pod b/Master/tlpkg/tlperl.straw/lib/Tk/form.pod
new file mode 100755
index 00000000000..64208c8e26e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/form.pod
@@ -0,0 +1,397 @@
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distribution are in the file
+# license.tcl.
+
+=head1 NAME
+
+Tk::form - Geometry manager based on attachment rules
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+S< >I<$widget>->B<form>?(I<args>)?
+
+S< >I<$widget>->B<form>I<Option>?(I<args>)?
+
+=head1 DESCRIPTION
+
+The B<form> method is used to communicate with the
+B<form> Geometry Manager, a geometry manager that arranges the
+geometry of the children in a parent window according to attachment
+rules. The B<form> geometry manager is very flexible and
+powerful; it can be used to emulate all the existing features of the
+Tk packer and placer geometry managers (see L<pack|Tk::pack>,
+L<place|Tk::place>).
+The B<form> method can have any of several forms,
+depending on I<Option>:
+
+=over 4
+
+=item I<$slave>->B<form>?(I<options>)?
+
+Sets or adjusts the attachment values of the slave window
+according to the I<-option>=>I<value> argument pairs.
+
+=over 8
+
+=item B<-b> => I<attachment>
+
+Abbreviation for the B<-bottom> option.
+
+=item B<-bottom> => I<attachment>
+
+Specifies an attachment for the bottom edge of the slave window. The
+attachment must specified according to L<"SPECIFYING ATTACHMENTS"> below.
+
+=item B<-bottomspring> => I<weight>
+
+Specifies the weight of the spring at the bottom edge of the slave
+window. See L<"USING SPRINGS"> below.
+
+=item B<-bp> => I<value>
+
+Abbreviation for the B<-padbottom> option.
+
+=item B<-bs> => I<weight>
+
+Abbreviation for the B<-bottomspring> option.
+
+=item B<-fill> => I<style>
+
+Specifies the fillings when springs are used for this widget. The
+value must be B<x>, B<y>, B<both> or B<none>.
+
+=item B<-in> => I<$master>
+
+Places the slave window into the specified I<$master> window. If the slave
+was originally in another master window, all attachment values with
+respect to the original master window are discarded. Even if the
+attachment values are the same as in the original master window, they
+need to be specified again. The B<-in> flag, when needed, must appear
+as the first flag of I<options>. Otherwise an error is
+generated.
+
+=item B<-l> => I<attachment>
+
+Abbreviation for the B<-left> option.
+
+=item B<-left> => I<attachment>
+
+Specifies an attachment for the left edge of the slave window. The
+attachment must specified according to L<"SPECIFYING ATTACHMENTS"> below.
+
+=item B<-leftspring> => I<weight>
+
+Specifies the weight of the spring at the left edge of the slave
+window. See L<"USING SPRINGS"> below.
+
+=item B<-lp> => I<value>
+
+Abbreviation for the B<-padleft> option.
+
+=item B<-ls> => I<weight>
+
+Abbreviation for the B<-leftspring> option.
+
+=item B<-padbottom> => I<value>
+
+Specifies the amount of external padding to leave on the bottom side
+of the slave. The I<value> may have any of the forms acceptable to
+B<Tk_GetPixels>.
+
+=item B<-padleft> => I<value>
+
+Specifies the amount of external padding to leave on the left side of
+the slave.
+
+=item B<-padright> => I<value>
+
+Specifies the amount of external padding to leave on the right side of
+the slave.
+
+=item B<-padtop> => I<value>
+
+Specifies the amount of external padding to leave on the top side of
+the slave.
+
+=item B<-padx> => I<value>
+
+Specifies the amount of external padding to leave on both the left and
+the right sides of the slave.
+
+=item B<-pady> => I<value>
+
+Specifies the amount of external padding to leave on both the top and
+the bottom sides of the slave.
+
+=item B<-r> => I<attachment>
+
+Abbreviation for the B<-right> option.
+
+=item B<-right> => I<attachment>
+
+Specifies an attachment for the right edge of the slave window. The
+attachment must specified according to L<"SPECIFYING ATTACHMENTS"> below.
+
+=item B<-rightspring> => I<weight>
+
+Specifies the weight of the spring at the right edge of the slave
+window. See L<"USING SPRINGS"> below.
+
+=item B<-rp> => I<value>
+
+Abbreviation for the B<-padright> option.
+
+=item B<-rs> => I<weight>
+
+Abbreviation for the B<-rightspring> option.
+
+=item B<-t> => I<attachment>
+
+Abbreviation for the B<-top> option.
+
+=item B<-top> => I<attachment>
+
+Specifies an attachment for the top edge of the slave window. The
+attachment must specified according to L<"SPECIFYING ATTACHMENTS"> below.
+
+=item B<-topspring> => I<weight>
+
+Specifies the weight of the spring at the top edge of the slave
+window. See L<"USING SPRINGS"> below.
+
+=item B<-tp> => I<value>
+
+Abbreviation for the B<-padtop> option.
+
+=item B<-ts> => I<weight>
+
+Abbreviation for the B<-topspring> option.
+
+=back
+
+=item I<$master>->B<formCheck>
+
+This method checks whether there is circular dependency in the
+attachments of the master's slaves (see L<"CIRCULAR DEPENDENCY"> below).
+It returns the Boolean value B<TRUE> if it
+discover circular dependency and B<FALSE> otherwise.
+
+=item I<$slave>->B<formForget>
+
+Removes the slave from its master and unmaps its window.
+The slave will no longer be managed by form. All attachment values
+with respect to its master window are discarded. If another slave
+is attached to this slave, then the attachment of the other slave will
+be changed to grid attachment based on its geometry.
+
+=item I<$master>->B<formGrid>?(I<x_size, y_size>)?
+
+When I<x_size> and I<y_size> are given, this method returns the
+number of grids of the I<$master> window in a pair of integers of the form
+(I<x_size, y_size>). When both I<x_size> and I<y_size> are
+given, this method changes the number of horizontal and vertical
+grids on the master window.
+
+=item I<$slave>->B<formInfo>?(I<-option)>?
+
+Queries the attachment options of a slave window. I<-option> can be
+any of the options accepted by the B<form> method. If
+I<-option> is given, only the value of that option is returned.
+Otherwise, this method returns a list whose elements are the current
+configuration state of the slave given in the same I<option-value> form
+that might be specified to B<form>. The first two
+elements in this list list are "B<-in>=>I<$master>" where
+I<$master> is the slave's master window.
+
+=item I<$master>->B<formSlaves>
+
+Returns a list of all of the slaves for the master window. The order
+of the slaves in the list is the same as their order in the packing
+order. If master has no slaves then an empty string is returned.
+
+=back
+
+=head1 SPECIFYING ATTACHMENTS
+
+One can specify an attachment for each side of a slave window managed
+by form. An attachment is specified in the the form "-I<side> =>
+[I<anchor_point>, I<offset>]". -I<side> can be one of
+B<-top>, B<-bottom>, B<-left> or B<-right>.
+
+I<Offset> is given in screen units (i.e. any of the forms
+acceptable to B<Tk_GetPixels>). A positive offset indicates
+shifting to a position to the right or bottom of an anchor point. A
+negative offset indicates shifting to a position to the left or top of
+an anchor point.
+
+I<Anchor_point> can be given in one of the
+following forms:
+
+=over 4
+
+=item B<Grid Attachment>
+
+The master window is divided into a number of horizontal and vertical
+grids. By default the master window is divided into 100x100 grids; the
+number of grids can be adjusted by the B<formGrid> method. A
+grid attachment anchor point is given by a B<%> sign followed by an
+integer value. For example, B<'%0'> specifies the first grid
+line (the top or left edge of the master window). B<'%100'> specifies
+the last grid line (the bottom or right edge of the master window).
+
+=item B<Opposite Side Attachment>
+
+Opposite attachment specifies an anchor point located on the
+B<opposite> side of another slave widget, which must be managed by
+form in the same master window. An opposite attachment anchor point
+is given by the name of another widget. For example,
+"I<$b>->B<form>(B<-top>=>[I<$a>,0])" attaches the top side of the widget I<$b> to the
+bottom of the widget I<$a>.
+
+=item B<Parallel Side Attachment>
+
+Opposite attachment specifies an anchor point located on the
+B<same> side of another slave widget, which must be managed by
+form in the same master window. An parallel attachment anchor point
+is given by the sign B<E<amp>> follwed by the name of another widget.
+For example, "I<$b>->B<form>(B<-top>=>['&',I<$a>,0])" attaches the top side of
+the widget I<$b> to the top of the widget I<$a>, making
+the top sides of these two widgets at the same vertical position
+in their parent window.
+
+=item B<No Attachment>
+
+Specifies a side of the slave to be attached to nothing, indicated by
+the keyword B<none>. When the B<none> anchor point is given, the
+offset must be zero (or not present).
+When a side of a slave is attached to B<['none', 0]>, the position
+of this side is calculated by the position of the other side and the
+natural size of the slave. For example, if a the left side of a
+widget is attached to B<['%0', 100]>, its right side attached to
+B<['none', 0]>, and the natural size of the widget is B<50> pixels,
+the right side of the widget will be positioned at pixel
+B<['%0', 149]>.
+When both B<-top> and B<-bottom> are attached to B<none>,
+then by default B<-top> will be attached to B<['%0', 0]>. When both
+B<-left> and B<-right> are attached to none, then by default
+B<-left> will be attached to B<['%0', 0]>.
+
+=back
+
+Shifting effects can be achieved by specifying a non-zero offset with
+an anchor point. In the following example, the top side of
+widget I<\$b> is attached to the bottom of
+I<\$a>; hence I<\$b>
+always appears below I<\$a>. Also, the left edge of I<\$b>
+is attached to the left side of I<\$a> with a 10
+pixel offest. Therefore, the left edge of I<\$b> is always
+shifted 10 pixels to the right of I<\$a>'s left edge:
+
+S< >I<$b>->B<form>(B<-left>=>[I<$a>,10], B<-top>=>[I<$a>,0]);
+
+=head2 ABBREVIATIONS:
+
+Certain abbreviations can be made on the
+attachment specifications: First an offset of zero can be omitted.
+Thus, the following two lines are equivalent:
+
+S< >I<$b>->B<form>(B<-top>=>[I<$a>,0], B<-right>=>['%100',0]);
+
+S< >I<$b>->B<form>(B<-top>=>[I<$a>], B<-right>=>'%100');
+
+In the second case, when the anchor point is omitted, the offset must
+be given. A default anchor point is chosen according to the value of
+the offset. If the anchor point is B<0> or positive, the default
+anchor point %0 is used; thus, "I<$b>->B<form>(B<-top>=>15)" attaches the top
+edge of I<$b> to a position 15 pixels below the top edge of the
+master window. If the anchor point is "B<-0>" or negative, the
+default anchor point B<%100> is used; thus, "I<$a>->B<form>(B<-right>=>-2)"
+attaches the right edge of I<\$a> to a position 2 pixels to
+the left of the master window's right edge. An further example
+below shows a method with its equivalent abbreviation.
+
+S< >I<$b>->B<form>(B<-top>=>['%0',10], B<-bottom>=>['%100',0]);
+
+S< >I<$b>->B<form>(B<-top>=>10, B<-bottom>=>-0);
+
+=head1 USING SPRINGS
+
+To be written.
+
+=head1 ALGORITHM OF FORM
+
+B<form> starts with any slave in the list of slaves of the master
+window. Then it tries to determine the position of each side of the
+slave.
+
+If the attachment of a side of the slave is grid attachment, the
+position of the side is readily determined.
+
+If the attachment of this side is B<none>, then form tries to
+determine the position of the opposite side first, and then use the
+position of the opposite side and the natural size of the slave to
+determine the position of this side.
+
+If the attachment is opposite or parallel widget attachments, then
+form tries to determine the positions of the other widget first,
+and then use the positions of the other widget and the natural size of
+the slave determine the position of this side. This recursive
+algorithmis carried on until the positions of all slaves are
+determined.
+
+=head1 CIRCULAR DEPENDENCY
+
+The algorithm of form will fail if a circular dependency exists in
+the attachments of the slaves. For example:
+
+S< >I<$c>->B<form>(B<-left>=>I<$b>);
+
+S< >I<$b>->B<form>(B<-right>=>I<$c>);
+
+In this example, the position of the left side of I<$b> depends on
+the right side of I<$c>, which in turn depends on the left side of I<$b>.
+
+When a circular dependency is discovered during the execution of the
+form algorithm, form will generate a background error and the
+geometry of the slaves are undefined (and will be arbitrary). Notice
+that form only executes the algorithm when the specification of the
+slaves' attachments is complete. Therefore, it allows intermediate
+states of circular dependency during the specification of the slaves'
+attachments. Also, unlike the Motif Form manager widget, form
+defines circular dependency as
+``I<dependency in the same dimension>''.
+Therefore, the following code fragment will does not
+have circular dependency because the two widgets do not depend on each
+other in the same dimension (I<$b> depends I<$c> in the
+horizontal dimension and I<$c> depends on I<$b> in the vertical
+dimension):
+
+S< >I<$b>->B<form>(B<-left>=>I<$c>);
+
+S< >I<$c>->B<form>(B<-top>=>I<$b>);
+
+=head1 BUGS
+
+Springs have not been fully implemented yet.
+
+=head1 SEE ALSO
+
+L<Tk::grid|Tk::grid>
+L<Tk::pack|Tk::pack>
+L<Tk::place|Tk::place>
+
+=head1 KEYWORDS
+
+geometry manager, form, attachment, spring, propagation, size, pack,
+tix, master, slave
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/getOpenFile.pod b/Master/tlpkg/tlperl.straw/lib/Tk/getOpenFile.pod
new file mode 100755
index 00000000000..56d39422afd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/getOpenFile.pod
@@ -0,0 +1,182 @@
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+=head1 NAME
+
+getOpenFile, getSaveFile - pop up a dialog box for the user to select a file to open or save.
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<getOpenFile>(?I<-option>=E<gt>value, ...>?)
+
+S< >I<$widget>-E<gt>B<getSaveFile>(?I<-option>=E<gt>value, ...>?)
+
+=head1 DESCRIPTION
+
+The methods B<getOpenFile> and B<getSaveFile> pop up a
+dialog box for the user to select a file to open or save.
+
+The B<getOpenFile> method is usually associated with the B<Open>
+command in the B<File> menu. Its purpose is for the user to select an
+existing file I<only>. If the user enters an non-existent file, the
+dialog box gives the user an error prompt and requires the user to give
+an alternative selection. If an application allows the user to create
+new files, it should do so by providing a separate B<New> menu command.
+
+The B<getSaveFile> method is usually associated with the B<Save>
+as command in the B<File> menu. If the user enters a file that
+already exists, the dialog box prompts the user for confirmation
+whether the existing file should be overwritten or not.
+
+If the user selects a file, both B<getOpenFile> and
+B<getSaveFile> return the full pathname of this file. If the
+user cancels the operation, both commands return an undefined value.
+
+The following I<option-value> pairs are possible as command line
+arguments to these two commands:
+
+=over 4
+
+=item B<-defaultextension> =E<gt> I<extension>
+
+Specifies a string that will be appended to the filename if the user
+enters a filename without an extension. The default value is the empty
+string, which means no extension will be appended to the filename in
+any case. This option is ignored on the Macintosh platform, which
+does not require extensions to filenames, and the UNIX implementation
+guesses reasonable values for this from the B<-filetypes>
+option when this is not supplied.
+
+=item B<-filetypes> =E<gt> [I<filePattern> ?, ...?]
+
+If a B<File types> listbox exists in the file dialog on the particular
+platform, this option gives the I<filetype>s in this listbox. When
+the user choose a filetype in the listbox, only the files of that type
+are listed. If this option is unspecified, or if it is set to the
+empty list, or if the B<File types> listbox is not supported by the
+particular platform then all files are listed regardless of their
+types. See L<"SPECIFYING FILE PATTERNS"> below for a
+discussion on the contents of I<filePattern>s.
+
+=item B<-initialdir> =E<gt> I<directory>
+
+Specifies that the files in I<directory> should be displayed
+when the dialog pops up. If this parameter is not specified, then
+the files in the current working directory are displayed. This
+option may not always work on the Macintosh. This is not a bug.
+Rather, the I<General Controls> control panel on the Mac allows the
+end user to override the application default directory.
+
+=item B<-initialfile> =E<gt> I<filename>
+
+Specifies a filename to be displayed in the dialog when it pops
+up. This option is ignored by the B<getOpenFile> method.
+
+=item B<-multiple>
+
+Allows the user to choose multiple files from the Open dialog. On the
+Macintosh, this is only available when Navigation Services are
+installed.
+
+=item B<-message> =E<gt> I<string>
+
+Specifies a message to include in the client area of the dialog. This
+is only available on the Macintosh, and only when Navigation Services
+are installed.
+
+=item B<-title> =E<gt> I<titleString>
+
+Specifies a string to display as the title of the dialog box. If this
+option is not specified, then a default title is displayed. This
+option is ignored on the Macintosh platform.
+
+=back
+
+=head1 SPECIFYING FILE PATTERNS
+
+The I<filePattern>s given by the B<-filetypes> option
+are a list of file patterns. Each file pattern is a list of the
+form
+
+ typeName [extension ?extension ...?] ?[macType ?macType ...?]?
+
+I<typeName> is the name of the file type described by this
+file pattern and is the text string that appears in the B<File types>
+listbox. I<extension> is a file extension for this file pattern.
+I<macType> is a four-character Macintosh file type. The list of
+I<macType>s is optional and may be omitted for applications that do
+not need to execute on the Macintosh platform.
+
+Several file patterns may have the same I<typeName,> in which case
+they refer to the same file type and share the same entry in the
+listbox. When the user selects an entry in the listbox, all the files
+that match at least one of the file patterns corresponding
+to that entry are listed. Usually, each file pattern corresponds to a
+distinct type of file. The use of more than one file patterns for one
+type of file is necessary on the Macintosh platform only.
+
+On the Macintosh platform, a file matches a file pattern if its
+name matches at least one of the I<extension>(s) AND it
+belongs to at least one of the I<macType>(s) of the
+file pattern. For example, the B<C Source Files> file pattern in the
+sample code matches with files that have a B<\.c> extension AND
+belong to the I<macType> B<TEXT>. To use the OR rule instead,
+you can use two file patterns, one with the I<extensions> only and
+the other with the I<macType> only. The B<GIF Files> file type
+in the sample code matches files that EITHER have a B<\.gif>
+extension OR belong to the I<macType> B<GIFF>.
+
+On the Unix and Windows platforms, a file matches a file pattern
+if its name matches at at least one of the I<extension>(s) of
+the file pattern. The I<macType>s are ignored.
+
+=head1 SPECIFYING EXTENSIONS
+
+On the Unix and Macintosh platforms, extensions are matched using
+glob-style pattern matching. On the Windows platforms, extensions are
+matched by the underlying operating system. The types of possible
+extensions are: (1) the special extension * matches any
+file; (2) the special extension "" matches any files that
+do not have an extension (i.e., the filename contains no full stop
+character); (3) any character string that does not contain any wild
+card characters (* and ?).
+
+Due to the different pattern matching rules on the various platforms,
+to ensure portability, wild card characters are not allowed in the
+extensions, except as in the special extension *. Extensions
+without a full stop character (e.g, ~) are allowed but may not
+work on all platforms.
+
+=head1 CAVEATS
+
+See L<Tk::chooseDirectory/CAVEATS>.
+
+=head1 EXAMPLE
+
+ my $types = [
+ ['Text Files', ['.txt', '.text']],
+ ['TCL Scripts', '.tcl' ],
+ ['C Source Files', '.c', 'TEXT'],
+ ['GIF Files', '.gif', ],
+ ['GIF Files', '', 'GIFF'],
+ ['All Files', '*', ],
+ ];
+ my $filename = $widget->getOpenFile(-filetypes=>$types);
+
+ if ($filename ne "") {
+ # Open the file ...
+ }
+
+=head1 SEE ALSO
+
+L<Tk::FBox|Tk::FBox>, L<Tk::FileSelect|Tk::FileSelect>
+
+=head1 KEYWORDS
+
+file selection dialog
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/grab.pod b/Master/tlpkg/tlperl.straw/lib/Tk/grab.pod
new file mode 100755
index 00000000000..98a488d09f7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/grab.pod
@@ -0,0 +1,140 @@
+# Copyright (c) 1992 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+grab - Confine pointer and keyboard events to a window sub-tree
+
+=for category User Interaction
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<grab>
+
+I<$widget>-E<gt>B<grab>I<Option>
+
+=head1 DESCRIPTION
+
+This set of methods implement simple pointer and keyboard grabs for Tk.
+Tk's grabs are different than the grabs
+described in the Xlib documentation.
+When a grab is set for a particular window, Tk restricts all pointer
+events to the grab window and its descendants in Tk's window hierarchy.
+Whenever the pointer is within the grab window's subtree, the pointer
+will behave exactly the same as if there had been no grab at all
+and all events will be reported in the normal fashion.
+When the pointer is outside I<$widget>'s tree, button presses and
+releases and
+mouse motion events are reported to I<$widget>, and window entry
+and window exit events are ignored.
+The grab subtree ``owns'' the pointer:
+windows outside the grab subtree will be visible on the screen
+but they will be insensitive until the grab is released.
+The tree of windows underneath the grab window can include top-level
+windows, in which case all of those top-level windows
+and their descendants will continue to receive mouse events
+during the grab.
+
+Two forms of grabs are possible: local and global.
+A local grab affects only the grabbing application: events will
+be reported to other applications as if the grab had never occurred.
+Grabs are local by default.
+A global grab locks out all applications on the screen,
+so that only the given subtree of the grabbing application will be
+sensitive to pointer events (mouse button presses, mouse button releases,
+pointer motions, window entries, and window exits).
+During global grabs the window manager will not receive pointer
+events either.
+
+During local grabs, keyboard events (key presses and key releases)
+are delivered as usual: the window
+manager controls which application receives keyboard events, and
+if they are sent to any window in the grabbing application then they are
+redirected to the focus window.
+During a global grab Tk grabs the keyboard so that all keyboard events
+are always sent to the grabbing application.
+The B<focus> method is still used to determine which window in the
+application receives the keyboard events.
+The keyboard grab is released when the grab is released.
+
+Grabs apply to particular displays. If an application has windows
+on multiple displays then it can establish a separate grab on each
+display.
+The grab on a particular display affects only the windows on
+that display.
+It is possible for different applications on a single display to have
+simultaneous local grabs, but only one application can have a global
+grab on a given display at once.
+
+The B<grab> methods take any of the following forms:
+
+=over 4
+
+=item I<$widget>-E<gt>B<grabCurrent>
+
+Returns the current grab
+window in this application for I<$widget>'s display, or an empty
+string if there is no such window.
+
+=item I<$widget>-E<gt>B<grabs>
+
+Returns a list whose elements
+are all of the windows grabbed by this application for all displays,
+or an empty string if the application has no grabs.
+
+I<Not implemented yet!>
+
+=item I<$widget>-E<gt>B<grabRelease>
+
+Releases the grab on I<$widget> if there is one, otherwise does
+nothing. Returns an empty string.
+
+=item I<$widget>-E<gt>B<grab>
+
+Sets a local grab on I<$widget>.
+If a grab was already in effect for this application on
+I<$widget>'s display then it is automatically released.
+If there is already a local grab on I<$widget>, then the command
+does nothing. Returns an empty string.
+
+=item I<$widget>-E<gt>B<grabGlobal>
+
+Sets a global grab on I<$widget>.
+If a grab was already in effect for this application on
+I<$widget>'s display then it is automatically released.
+If there is already a global grab on I<$widget>,
+then the command does nothing. Returns an empty string.
+
+=item I<$widget>-E<gt>B<grabStatus>
+
+Returns B<none> if no grab is currently set on I<$widget>,
+B<local> if a local grab is set on I<$widget>, and
+B<global> if a global grab is set.
+
+=back
+
+=head1 BUGS
+
+It took an incredibly complex and gross implementation to produce
+the simple grab effect described above.
+Given the current implementation, it isn't safe for applications
+to use the Xlib grab facilities at all except through the Tk grab
+procedures.
+If applications try to manipulate X's grab mechanisms directly,
+things will probably break.
+
+If a single process is managing several different Tk applications,
+only one of those applications can have a local grab for a given
+display at any given time. If the applications are in different
+processes, this restriction doesn't exist.
+
+=head1 KEYWORDS
+
+grab, keyboard events, pointer events, window
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/grid.pod b/Master/tlpkg/tlperl.straw/lib/Tk/grid.pod
new file mode 100755
index 00000000000..8db89587a62
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/grid.pod
@@ -0,0 +1,409 @@
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::grid - Geometry manager that arranges widgets in a grid
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<grid>?(?I<widget> ...,? ?I<arg> ?...>?)?
+
+S< >I<$widget>-E<gt>B<grid>I<Option>?(I<arg> ?,I<arg> ...?)?
+
+=head1 DESCRIPTION
+
+The B<grid> method is used to communicate with the grid
+geometry manager that arranges widgets in rows and columns inside
+of another window, called the geometry master (or master window).
+The B<grid> method can have any of several forms, depending
+on the I<option> argument:
+
+=over 4
+
+=item I<$slave>-E<gt>B<grid>(?I<$slave, ...>??, I<options>?)
+
+The arguments consist of the optional references to more slave windows
+followed by pairs of arguments that specify how to manage the slaves.
+The characters B<->, B<x> and B<^>,
+can be specified instead of a window reference to alter the default
+location of a I<$slave>, as described in L<"RELATIVE PLACEMENT">, below.
+
+If any of the slaves are already managed by the geometry manager
+then any unspecified options for them retain their previous values rather
+than receiving default values.
+
+The following options are supported:
+
+=over 8
+
+=item B<-column> => I<n>
+
+Insert the I<$slave> so that it occupies the I<n>th column in the grid.
+Column numbers start with 0. If this option is not supplied, then the
+I<$slave> is arranged just to the right of previous slave specified on this
+call to B<grid>, or column "0" if it is the first slave. For each
+B<x> that immediately precedes the I<$slave>, the column position
+is incremented by one. Thus the B<x> represents a blank column
+for this row in the grid.
+
+=item B<-columnspan> => I<n>
+
+Insert the slave so that it occupies I<n> columns in the grid.
+The default is one column, unless the window name is followed by a
+B<->, in which case the columnspan is incremented once for each immediately
+following B<->.
+
+=item B<-in> => I<$other>
+
+Insert the slave(s) in the master
+window given by I<$other>. The default is the first slave's
+parent window.
+
+=item B<-ipadx> => I<amount>
+
+The I<amount> specifies how much horizontal internal padding to
+leave on each side of the slave(s). This is space is added
+inside the slave(s) border.
+The I<amount> must be a valid screen distance, such as B<2> or B<'.5c'>.
+It defaults to 0.
+
+=item B<-ipady> => I<amount>
+
+The I<amount> specifies how much vertical internal padding to
+leave on on the top and bottom of the slave(s).
+This space is added inside the slave(s) border.
+The I<amount> defaults to 0.
+
+=item B<-padx> => I<amount>
+
+The I<amount> specifies how much horizontal external padding to
+leave on each side of the slave(s), in screen units.
+The I<amount> defaults to 0.
+This space is added outside the slave(s) border.
+
+=item B<-pady> => I<amount>
+
+The I<amount> specifies how much vertical external padding to
+leave on the top and bottom of the slave(s), in screen units.
+The I<amount> defaults to 0.
+This space is added outside the slave(s) border.
+
+=item B<-row> => I<n>
+
+Insert the slave so that it occupies the I<n>th row in the grid.
+Row numbers start with 0. If this option is not supplied, then the
+slave is arranged on the same row as the previous slave specified on this
+call to B<grid>, or the first unoccupied row if this is the first slave.
+
+=item B<-rowspan> => I<n>
+
+Insert the slave so that it occupies I<n> rows in the grid.
+The default is one row. If the next B<grid> method contains
+B<^> characters instead of I<$slave>s that line up with the columns
+of this I<$slave>, then the B<rowspan> of this I<$slave> is
+extended by one.
+
+=item B<-sticky> => I<style>
+
+If a slave's cell is larger than its requested dimensions, this
+option may be used to position (or stretch) the slave within its cell.
+I<Style> is a string that contains zero or more of the characters
+B<n>, B<s>, B<e> or B<w>.
+The string can optionally contain spaces or
+commas, but they are ignored. Each letter refers to a side (north, south,
+east, or west) that the slave will "stick" to. If both B<n> and B<s> (or
+B<e> and B<w>) are specified, the slave will be stretched to fill the entire
+height (or width) of its cavity. The B<sticky> option subsumes the
+combination of B<-anchor> and B<-fill> that is used by L<pack|Tk::pack>.
+The default is B<''>, which causes the slave to be centered in its cavity,
+at its requested size.
+
+=back
+
+=item I<$master>-E<gt>B<gridBbox>(?I<column, row>,? ?I<column2, row2>?)
+
+With no arguments,
+the bounding box (in pixels) of the grid is returned.
+The return value consists of 4 integers. The first two are the pixel
+offset from the master window (x then y) of the top-left corner of the
+grid, and the second two integers are the width and height of the grid,
+also in pixels. If a single I<column> and I<row> is specified on
+the command line, then the bounding box for that cell is returned, where the
+top left cell is numbered from zero. If both I<column> and I<row>
+arguments are specified, then the bounding box spanning the rows and columns
+indicated is returned.
+
+=item I<$master>-E<gt>B<gridColumnconfigure>(I<index>?, I<-option>=>I<value, ...>?)
+
+Query or set the column properties of the I<index> column of the
+geometry master, I<$master>.
+The valid options are B<-minsize>, B<-weight> and B<-pad>.
+If one or more options are provided, then I<index> may be given as
+a list of column indices to which the configuration options will operate on.
+The B<-minsize> option sets the minimum size, in screen units,
+that will be permitted for this column.
+The B<-weight> option (an integer value)
+sets the relative weight for apportioning
+any extra spaces among
+columns.
+A weight of zero (0) indicates the column will not deviate from its requested
+size. A column whose weight is two will grow at twice the rate as a column
+of weight one when extra space is allocated to the layout.
+The B<-uniform> option, when a
+non-empty value is supplied, places the column in a I<uniform
+group> with other columns that have the same value for B<-uniform>.
+The space for columns belonging to a uniform group is allocated
+so that their sizes are always in strict proportion to their
+B<-weight> values. See I<THE GRID ALGORITHM> below for further
+details.
+The B<-pad> option specifies the number of screen units that will be
+added to the largest window contained completely in that column when the
+grid geometry manager requests a size from the containing window.
+If only an option is specified, with no value,
+the current value of that option is returned.
+If only the master window and index is specified, all the current settings
+are returned in an list of "-option value" pairs.
+
+=item I<$slave>-E<gt>B<gridConfigure>(?I<$slave, ...>?, I<options>?)
+
+The same as B<grid> method.
+
+=item I<$slave>-E<gt>B<gridForget>?(I<$slave, ...>)?
+
+Removes each of the I<$slave>s from grid for its
+master and unmaps their windows.
+The slaves will no longer be managed by the grid geometry manager.
+The configuration options for that window are forgotten, so that if the
+slave is managed once more by the grid geometry manager, the initial
+default settings are used.
+
+=item I<$slave>-E<gt>B<gridInfo>
+
+Returns a list whose elements are the current configuration state of
+the slave given by I<$slave> in the same option-value form that
+might be specified to B<gridConfigure>.
+The first two elements of the list are ``B<-in>=>I<$master>'' where
+I<$master> is the slave's master.
+
+=item I<$master>-E<gt>B<gridLocation>(I<x, y>)
+
+Given I<x> and I<y> values in screen units relative to the master window,
+the column and row number at that I<x> and I<y> location is returned.
+For locations that are above or to the left of the grid, B<-1> is returned.
+
+=item I<$master>-E<gt>B<gridPropagate>?(I<boolean>)?
+
+If I<boolean> has a true boolean value such as B<1> or B<on>
+then propagation is enabled for I<$master>, which must be a window
+name (see L<"GEOMETRY PROPAGATION"> below).
+If I<boolean> has a false boolean value then propagation is
+disabled for I<$master>.
+In either of these cases an empty string is returned.
+If I<boolean> is omitted then the method returns B<0> or
+B<1> to indicate whether propagation is currently enabled
+for I<$master>.
+Propagation is enabled by default.
+
+=item I<$master>-E<gt>B<gridRowconfigure>(I<index>?, I<-option>=>I<value, ...>?)
+
+Query or set the row properties of the I<index> row of the
+geometry master, I<$master>.
+The valid options are B<-minsize>, B<-weight> and B<-pad>.
+If one or more options are provided, then I<index> may be given as
+a list of row indeces to which the configuration options will operate on.
+The B<-minsize> option sets the minimum size, in screen units,
+that will be permitted for this row.
+The B<-weight> option (an integer value)
+sets the relative weight for apportioning
+any extra spaces among
+rows.
+A weight of zero (0) indicates the row will not deviate from its requested
+size. A row whose weight is two will grow at twice the rate as a row
+of weight one when extra space is allocated to the layout.
+The B<-uniform> option, when a non-empty value is supplied, places the
+row in a I<uniform group> with other rows that have the same value
+for B<-uniform>. The space for rows belonging to a uniform group
+is allocated so that their sizes are always in strict proportion
+to their B<-weight> values. See I<THE GRID ALGORITHM> below for
+further details.
+The B<-pad> option specifies the number of screen units that will be
+added to the largest window contained completely in that row when the
+grid geometry manager requests a size from the containing window.
+If only an option is specified, with no value,
+the current value of that option is returned.
+If only the master window and index is specified, all the current settings
+are returned in an list of "option-value" pairs.
+
+=item I<$slave>-E<gt>B<gridRemove>?(I<$slave, ...>)?
+
+Removes each of the I<$slave>s from grid for its
+master and unmaps their windows.
+The slaves will no longer be managed by the grid geometry manager.
+However, the configuration options for that window are remembered,
+so that if the
+slave is managed once more by the grid geometry manager, the previous
+values are retained.
+
+=item I<$master>-E<gt>B<gridSize>
+
+Returns the size of the grid (in columns then rows) for I<$master>.
+The size is determined either by the I<$slave> occupying the largest
+row or column, or the largest column or row with a B<-minsize>,
+B<-weight>, or B<-pad> that is non-zero.
+
+=item I<$master>-E<gt>B<gridSlaves>?(I<-option>=>I<value>)?
+
+If no options are supplied, a list of all of the slaves in I<$master>
+are returned, most recently manages first.
+I<-option> can be either B<-row> or B<-column> which
+causes only the slaves in the row (or column) specified by I<value>
+to be returned.
+
+=back
+
+=head1 RELATIVE PLACEMENT
+
+The B<grid> method contains a limited set of capabilities that
+permit layouts to be created without specifying the row and column
+information for each slave. This permits slaves to be rearranged,
+added, or removed without the need to explicitly specify row and
+column information.
+When no column or row information is specified for a I<$slave>,
+default values are chosen for
+B<-column>, B<-row>, B<-columnspan> and B<-rowspan>
+at the time the I<$slave> is managed. The values are chosen
+based upon the current layout of the grid, the position of the I<$slave>
+relative to other I<$slave>s in the same grid method, and the presence
+of the characters B<->, B<^>, and B<^> in B<grid>
+method where I<$slave> names are normally expected.
+
+=over 4
+
+=item B<->
+
+This increases the columnspan of the I<$slave> to the left. Several
+B<->'s in a row will successively increase the columnspan. A B<->
+may not follow a B<^> or a B<x>.
+
+=item B<x>
+
+This leaves an empty column between the I<$slave> on the left and
+the I<$slave> on the right.
+
+=item B<^>
+
+This extends the B<-rowspan> of the I<$slave> above the B<^>'s
+in the grid. The number of B<^>'s in a row must match the number of
+columns spanned by the I<$slave> above it.
+
+=back
+
+=head1 THE GRID ALGORITHM
+
+The grid geometry manager lays out its slaves in three steps.
+In the first step, the minimum size needed to fit all of the slaves
+is computed, then (if propagation is turned on), a request is made
+of the master window to become that size.
+In the second step, the requested size is compared against the actual size
+of the master. If the sizes are different, then space is added to or taken
+away from the layout as needed.
+For the final step, each slave is positioned in its row(s) and column(s)
+based on the setting of its I<sticky> flag.
+
+To compute the minimum size of a layout, the grid geometry manager
+first looks at all slaves whose columnspan and rowspan values are one,
+and computes the nominal size of each row or column to be either the
+I<minsize> for that row or column, or the sum of the I<pad>ding
+plus the size of the largest slave, whichever is greater. Then the
+slaves whose rowspans or columnspans are greater than one are
+examined. If a group of rows or columns need to be increased in size
+in order to accommodate these slaves, then extra space is added to each
+row or column in the group according to its I<weight>. For each
+group whose weights are all zero, the additional space is apportioned
+equally.
+
+When multiple rows or columns belong to a uniform group, the space
+allocated to them is always in proportion to their weights. (A weight
+of zero is considered to be 1.) In other words, a row or column
+configured with B<-weight 1 -uniform> a will have exactly the same size
+as any other row or column configured with B<-weight 1 -uniform a>. A
+row or column configured with B<-weight 2 -uniform b> will be exactly
+twice as large as one that is configured with B<-weight 1 -uniform b>.
+
+More technically, each row or column in the group will have a size
+equal to I<k*weight> for some constant k. The constant k is chosen so
+that no row or column becomes smaller than its minimum size. For
+example, if all rows or columns in a group have the same weight, then
+each row or column will have the same size as the largest row or
+column in the group.
+
+
+For masters whose size is larger than the requested layout, the additional
+space is apportioned according to the row and column weights. If all of
+the weights are zero, the layout is centered within its master.
+For masters whose size is smaller than the requested layout, space is taken
+away from columns and rows according to their weights. However, once a
+column or row shrinks to its minsize, its weight is taken to be zero.
+If more space needs to be removed from a layout than would be permitted, as
+when all the rows or columns are at there minimum sizes, the layout is
+clipped on the bottom and right.
+
+=head1 GEOMETRY PROPAGATION
+
+The grid geometry manager normally computes how large a master must be to
+just exactly meet the needs of its slaves, and it sets the
+requested width and height of the master to these dimensions.
+This causes geometry information to propagate up through a
+window hierarchy to a top-level window so that the entire
+sub-tree sizes itself to fit the needs of the leaf windows.
+However, the B<gridPropagate> method may be used to
+turn off propagation for one or more masters.
+If propagation is disabled then grid will not set
+the requested width and height of the master window.
+This may be useful if, for example, you wish for a master
+window to have a fixed size that you specify.
+
+=head1 RESTRICTIONS ON MASTER WINDOWS
+
+The master for each slave must either be the slave's parent
+(the default) or a descendant of the slave's parent.
+This restriction is necessary to guarantee that the
+slave can be placed over any part of its master that is
+visible without danger of the slave being clipped by its parent.
+In addition, all slaves in one call to B<grid> must have the same master.
+
+=head1 STACKING ORDER
+
+If the master for a slave is not its parent then you must make sure
+that the slave is higher in the stacking order than the master.
+Otherwise the master will obscure the slave and it will appear as
+if the slave hasn't been managed correctly.
+The easiest way to make sure the slave is higher than the master is
+to create the master window first: the most recently created window
+will be highest in the stacking order.
+
+=head1 CREDITS
+
+The B<grid> method is based on ideas taken from the I<GridBag>
+geometry manager written by Doug. Stein, and the B<blt_table> geometry
+manager, written by George Howlett.
+
+=head1 SEE ALSO
+
+L<Tk::form|Tk::form>
+L<Tk::pack|Tk::pack>
+L<Tk::place|Tk::place>
+
+=head1 KEYWORDS
+
+geometry manager, location, grid, cell, propagation, size, pack,
+master, slave
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/icon.gif b/Master/tlpkg/tlperl.straw/lib/Tk/icon.gif
new file mode 100755
index 00000000000..dfe6b6621f2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/icon.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/install.pm b/Master/tlpkg/tlperl.straw/lib/Tk/install.pm
new file mode 100755
index 00000000000..2392dc84fca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/install.pm
@@ -0,0 +1,37 @@
+package Tk::install;
+require Exporter;
+
+use vars qw($VERSION @EXPORT);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/install.pm#4 $
+
+use base qw(Exporter);
+@EXPORT = qw(installbin);
+
+use Config;
+
+sub installbin
+{
+ my $prog = shift(@ARGV);
+ my $start = $Config{'startperl'};
+ my $perl = $Config{'perl'} || 'perl';
+ $start =~ s/$perl$/$prog/;
+ while (($src,$dst) = splice(@ARGV,0,2))
+ {
+ open(SRC,"<$src") || die "Cannot open $src:$!";
+ my $line = <SRC>;
+ $line =~ s/^#!\s*\S+/$start/;
+ warn $line;
+ chmod(0755,$dst) if (-f $dst);
+ open(DST,">$dst") || die "Cannot open $dst:$!";
+ print "installbin $src => $dst\n";
+ do
+ {
+ print DST $line;
+ } while (defined($line = <SRC>));
+ close(SRC);
+ close(DST);
+ chmod(0555,$dst);
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/license.terms b/Master/tlpkg/tlperl.straw/lib/Tk/license.terms
new file mode 100755
index 00000000000..6a5d3728366
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/license.terms
@@ -0,0 +1,35 @@
+This software is copyrighted by the Regents of the University of
+California, Sun Microsystems, Inc., and other parties. The following
+terms apply to all files associated with the software unless explicitly
+disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+RESTRICTED RIGHTS: Use, duplication or disclosure by the government
+is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
+of the Rights in Technical Data and Computer Software Clause as DFARS
+252.227-7013 and FAR 52.227-19.
+0 in license.terms
+0 in license.terms
+0 in license.terms
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/mega.pod b/Master/tlpkg/tlperl.straw/lib/Tk/mega.pod
new file mode 100755
index 00000000000..76e40e7891f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/mega.pod
@@ -0,0 +1,423 @@
+
+## Author: Achim Bohnet <ach@mpe.mpg.de>
+##
+## Copyright (c) 1997-1998 Achim Bohnet. All rights reserved.
+## You can redistribute this document and/or modify it under the
+## same terms as Perl itself.
+##
+## Update for Tk804.025, Steve Lidie, 2004/01/11.
+
+=head1 NAME
+
+Tk::mega - Perl/Tk support for writing widgets in pure Perl
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+Define the widget's new class name:
+
+S< >B<package Tk::>I<MyNewWidget>;
+
+For composite widget classes:
+
+S< >B<use base qw/ Tk::container />; # where B<container> is I<Frame> or I<Toplevel>
+
+For derived widget classes:
+
+S< >B<use base qw/ Tk::Derived Tk::DerivedWidget /;>
+
+Install the new widget in Tk's namespace and establish class and instance
+constructors.
+
+S< >B<Construct Tk::>I<Widget> I<'MyNewWidget'>;
+
+S< >B<sub ClassInit> { I<my ($self, $args) = @_; ...> }
+
+S< >B<sub Populate> { I<my ($self, $args) = @_; ...> }
+
+=head1 DESCRIPTION
+
+The goal of the mega-widget support of Perl/Tk is to make it
+easy to write mega-widgets that obey the same protocol and
+interface that the Tk core widgets support.
+I<For mega-widget sample code please run the B<widget> demonstration program and go to the section B<Sample Perl Mega-Widgets>.>
+
+There are two kinds of mega-widgets:
+
+=over 4
+
+=item * Composite Widgets
+
+A composite widget is composed with one or more existing widgets.
+The composite widget looks to the user like a simple single widget.
+A well known example is the file selection box.
+
+=item * Derived Widgets
+
+A derived widget adds/modifies/removes properties and methods
+from a single widget (this widget may itself be a mega-widget).
+
+=back
+
+=head1 MEGA-WIDGET SUPPORT
+
+=head2 Advertise
+
+Give a subwidget a symbolic name.
+
+Usage:
+
+S< >I<$self>-E<gt>B<Advertise>(B<name>=E<gt>I<$widget>);
+
+Gives a subwidget I<$widget> of the mega-widget I<$self> the
+name B<name>. One can retrieve the reference of an advertised subwidget
+with the L<Subwidget|"Subwidget"> method.
+
+B<Comment:> Mega-Widget Writers: Please make sure to document the
+advertised widgets that are intended for I<public> use.
+If there are none, document this fact, e.g.:
+
+ =head1 ADVERTISED WIDGETS
+
+ None.
+
+=head2 Callback
+
+Invoke a callback specified with an option.
+
+Usage:
+
+S< >I<$self>-E<gt>B<Callback>(I<-option> ?,I<args> ...?);
+
+B<Callback> executes the L<callback|Tk::callbacks> defined with
+I<$self>-E<gt>B<ConfigSpecs>(I<-option>, [B<CALLBACK>, ...]);
+If I<args> are given they are passed to the callback. If
+I<-option> is not defined it does nothing.
+
+=head2 ClassInit
+
+Initialization of the mega-widget class.
+
+Usage:
+
+S< >B<sub ClassInit> { I<my ($class, $mw) = @_;> ... }
+
+B<ClassInit> is called once for I<each> L<MainWindow|Tk::MainWindow>
+just before the first widget instance of a class is created in
+the widget tree of B<MainWindow>.
+
+B<ClassInit> is often used to define bindings and/or other
+resources shared by all instances, e.g., images.
+
+Examples:
+
+ $mw->bind($class,"<Tab>", sub { my $w = shift; $w->Insert("\t"); $w->focus; $w->break});
+ $mw->bind($class,"<Return>", ['Insert',"\n"]);
+ $mw->bind($class,"<Delete>",'Delete');
+
+Notice that I<$class> is the class name (e.g. B<Tk::MyText>) and I<$mw> is the mainwindow.
+
+Don't forget to call I<$class>-E<gt>B<SUPER::ClassInit($mw)> in
+B<ClassInit>.
+
+=head2 Component
+
+Convenience function to create subwidgets.
+
+Usage:
+
+ $cw->Component('Whatever', 'AdvertisedName',
+ -delegate => ['method1', 'method2', ...],
+ ... more widget options ...,
+ );
+
+B<Component> does several things for you with one call:
+
+=over 4
+
+o Creates the widget
+
+o Advertises it with a given name (overridden by 'Name' option)
+
+o Delegates a set of methods to this widget (optional)
+
+=back
+
+Example:
+
+ $cw->Component('Button', 'quitButton', -command => sub{$mw->'destroy'});
+
+=head2 ConfigSpecs
+
+Defines options and their treatment
+
+Usage:
+
+ $cw->ConfigSpecs(
+ -option => [ where, dbname, dbclass, default],
+ ...,
+ DEFAULT => [where],
+ );
+
+Defines the options of a mega-widget and what actions
+are triggered by configure/cget of an option
+(see L<Tk::ConfigSpecs> and L<Tk::Derived> for details).
+
+=head2 Construct
+
+Make the new mega-widget known to B<Tk>.
+
+Usage:
+
+S< >B<Construct> I<baseclass> B<'Name'>;
+
+B<Construct> declares the new widget class so that your mega-widget
+works like normal Perl/Tk widgets.
+
+Examples:
+
+S< >B<Construct Tk::Widget> I<'Whatever'>;
+S< >B<Construct Tk::Menu> I<'MyItem'>;
+
+First example lets one use I<$widget>-E<gt>B<Whatever> to create
+new B<Whatever> widget.
+
+The second example restricts the usage of the B<MyItem> constructor
+method to widgets that are derived from B<Menu>:
+I<$isamenu>-E<gt>I<MyItem>.
+
+=head2 CreateArgs
+
+Process options before any widget is created:
+
+S< >B<sub CreateArgs> { I<my ($package, $parent, $args) = @_; ...; return @newargs;> }
+
+I<$package> is the package of the mega-widget (e.g., B<Tk::MyText>,
+I<$parent> the parent of the widget to be created and $args the hash
+reference to the options specified in the widget constructor call.
+
+Don't forget to call I<$package>-E<gt>B<SUPER::CreateArgs>(I<$parent>, I<$args>) in
+B<CreateArgs>.
+
+=head2 Delegates
+
+Redirect a method of the mega-widget to a subwidget of
+the composite widget
+
+Usage:
+
+ $cw->Delegates(
+ 'method1' => $subwidget1,
+ 'method2' => 'advertived_name',
+ ...,
+ 'Construct' => $subwidget2,
+ 'DEFAULT' => $subwidget3,
+ );
+
+The B<'Construct'> delegation has a special meaning. After
+'Construct' is delegated all Widget constructors are redirected.
+E.g. after
+
+S< >I<$self>-E<gt>B<Delegates>(B<'Construct'>=E<gt>I<$subframe>);
+
+a I<$self>-E<gt>B<Button> does really a I<$subframe>-E<gt>B<Button>
+so the created button is a child of I<$subframe> and not I<$self>.
+
+B<Comment:> Delegates works only with methods that I<$cw> does
+not have itself.
+
+=head2 InitObject
+
+I<Note: this method should not, in general, be used, as it has been
+superceeded by B<Populate> and specifying B<Tk::Derived> as one of the base
+classes.>
+
+Defines construction and interface of derived widgets.
+
+Usage:
+
+ sub InitObject {
+ my ($derived, $args) = @_;
+ ...
+ }
+
+where I<$derived> is the widget reference of the already created
+baseclass widget and I<$args> is the reference to a hash of
+I<-option-value> pairs.
+
+B<InitObject> is almost identical to L<Populate|"Populate"> method.
+B<Populate> does some more 'magic' things useful for mega-widgets
+with several widgets.
+
+Don't forget to call I<$derived>-E<gt>B<SUPER::InitObject>(I<$args>) in
+B<InitObject>.
+
+=head2 OnDestroy
+
+Define a callback invoked when the mega-widget is destroyed.
+
+Usage:
+
+S< >I<$widget>-E<gt>B<OnDestroy>(I<callback>);
+
+B<OnDestroy> installs a L<callback|Tk::callbacks> that's called
+when a widget is going to to be destroyed. Useful
+for special cleanup actions. It differs from a normal B<destroy>
+in that all the widget's data structures are still intact.
+
+B<Comment:> This method could be used with any widgets not just
+for mega-widgets. It's listed here because of it's usefulness.
+
+=head2 Populate
+
+Defines construction and interface of the composite
+widget.
+
+Usage:
+
+ sub Populate {
+ my ($self, $args) = @_;
+ ...
+ }
+
+where I<$self> is the widget reference of the already created baseclass
+widget and I<$args> is the
+reference to a hash of I<-option-value> pairs.
+
+Most the other support function are normally used inside the B<Populate>
+subroutine.
+
+Don't forget to call I<$cw>-E<gt>B<SUPER::Populate>(I<$args>) in
+B<Populate>.
+
+=head2 privateData
+
+Set/get a private hash of a widget to storage
+composite internal data
+
+Usage:
+
+S< >I<$hashref> = I<$self>-E<gt>B<privateData>();
+
+S< >I<$another> = I<$self>-E<gt>B<privateData>(I<unique_key>|I<package>);
+
+=head2 Subwidget
+
+Get the widget reference of an advertised subwidget.
+
+S< >I<@subwidget> = I<$cw>-E<gt>B<Subwidget>();
+
+S< >I<$subwidget> = I<$cw>-E<gt>B<Subwidget>(I<name>);
+
+S< >I<@subwidget> = I<$cw>-E<gt>B<Subwidget>(I<name> ?,...?);
+
+Returns the widget reference(s) of the subwidget known under the given
+name(s). Without arguments, return all known subwidgets of I<$cw>. See
+L<Advertise|"Advertise"> method how to define I<name> for a subwidget.
+
+B<Comment:> Mega-Widget Users: Use B<Subwidget> to get I<only>
+documented subwidgets.
+
+=head1 PITFALLS
+
+=over 4
+
+=item * Resource DB class name
+
+Some of the standard options use a resource date base class
+that is not equal to the resource database name. E.g.,
+
+ Switch: Name: Class:
+
+ -padx padX Pad
+ -activerelief activeRelief Relief
+ -activebackground activeBackground Foreground
+ -status undef undef
+
+One should do the same when one defines one of these
+options via B<ConfigSpecs>.
+
+=item * Method delegation
+
+Redirecting methods to a subwidget with B<Delegate>
+can only work if the base widget itself does have a
+method with this name. Therefore one can't ``I<delegate>''
+any of the methods listed in L<Tk::Widget|Tk::Widget>.
+A common problematic method is B<bind>. In this case
+one as to explicitely redirect the method.
+
+ sub bind {
+ my $self = shift;
+ my $to = $self->privateData->{'my_bind_target'};
+ $to->bind(@_);
+ }
+
+=item * privateData
+
+Graham Barr wrote: ... It is probably
+more private than most people think. Not all calls to privateData will
+return that same HASH reference. The HASH reference that is returned
+depends on the package it was called from, a different HASH is returned
+for each package. This allows a widget to hold private data, but then
+if it is sub-classed the sub-class will get a different HASH and so not
+cause duplicate name clashes.
+
+But privateData does take an optional argument if you want to
+force which HASH is returned.
+
+=item * Scrolled and Composite
+
+B<Scrolled>(I<Kind>,...) constructor can not be used with B<Composite>.
+One has to use $cw->B<Composite>(B<Scrl>I<Kind> =E<gt> B<'name'>, ...);
+
+=back
+
+=head1 MISSING
+
+Of course Perl/Tk does not define support function for
+all necessities. Here's a short list of things you have to
+handle yourself:
+
+=over 4
+
+=item *
+
+No support to define construction-time only options.
+
+=item *
+
+No support to remove an option that is known to the
+base widget.
+
+=item *
+
+It's hard to define B<undef> as fallback for an widget
+option that is not already B<undef>.
+
+=item *
+
+Frame in Perl/Tk carries magic and overhead not needed
+for composite widget class definition.
+
+=item *
+
+No support methods for bindings that are shared between all
+widgets of a composite widget (makes sense at all?)
+
+=back
+
+=head1 KEYWORDS
+
+mega, composite, derived, widget
+
+=head1 SEE ALSO
+
+L<Tk::composite|Tk::composite>
+L<Tk::ConfigSpecs|Tk::ConfigSpecs>
+L<Tk::option|Tk::option>
+L<Tk::callbacks|Tk::callbacks>
+L<Tk::bind|Tk::bind>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/messageBox.pod b/Master/tlpkg/tlperl.straw/lib/Tk/messageBox.pod
new file mode 100755
index 00000000000..3cae94beb0d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/messageBox.pod
@@ -0,0 +1,67 @@
+=head1 NAME
+
+messageBox - pop up a message window and wait for user response.
+
+=for category Popups and Dialogs
+
+=head1 SYNOPSIS
+
+S< >I<$response> = I<$widget>-E<gt>B<messageBox>(I<-option> =E<gt> I<value>, ... );
+
+=head1 DESCRIPTION
+
+This method uses L<Tk::Dialog|Tk::Dialog> to quickly create several
+common dialog boxes. A dialog widget consists of a message, an icon
+and a set of buttons (see the I<-type> option). After the message
+window is popped up, B<messageBox> waits for the user to select one of
+the buttons and return the button text (note that it's best to check the
+returned value in a case insensitive manner). NOTE: unlike
+B<Tk::Dialog> which creates its widget once and can be used many
+times, the B<messageBox> window is created every time it's used.
+
+The following option/value pairs are supported:
+
+=over 4
+
+=item B<-default>
+
+The case-sensitive symbolic name of the default button
+for this message window ('Ok', 'Cancel' and so
+on). See B<-type> for a list of the symbolic names.
+If the message box has just one button it will
+automatically be made the default, otherwise if
+this option is not specified, there won't be any
+default button.
+
+=item B<-icon>
+
+Specifies an icon to display. On X11 any of the builtin Tk bitmaps can
+specified. On Windows only B<error>, B<info>, B<question> or
+B<warning> are supported.
+
+=item B<-message>
+
+Specifies the message to display.
+
+=item B<-title>
+
+Specifies a string to display as the title.
+
+=item B<-type>
+
+Specifies a predefined set of buttons to be displayed. The following
+values are possible: 'AbortRetryIgnore', 'Ok', 'OkCancel',
+'RetryCancel', 'YesNo' or 'YesNoCancel'.
+
+=back
+
+=head1 EXAMPLE
+
+I<$response> = I<$mw>-E<gt>B<messageBox>(-icon =E<gt> 'question', -message =E<gt> 'Hello World!', -title =E<gt> 'My title', -type =E<gt> 'AbortRetryIgnore', -default =E<gt> 'Retry');
+
+=head1 AUTHOR
+
+Stephen.O.Lidie@Lehigh.EDU. 98/05/25
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/openfile.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/openfile.xbm
new file mode 100755
index 00000000000..859e2e57608
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/openfile.xbm
@@ -0,0 +1,5 @@
+#define openfile_width 16
+#define openfile_height 12
+static unsigned char openfile_bits[] = {
+ 0x00, 0x00, 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0xc1, 0xff, 0xa1, 0xaa,
+ 0x51, 0x55, 0xa9, 0x2a, 0x55, 0x15, 0xab, 0x0a, 0xff, 0x07, 0x00, 0x00};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/openfolder.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/openfolder.xbm
new file mode 100755
index 00000000000..59ee624efd0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/openfolder.xbm
@@ -0,0 +1,5 @@
+#define openfolder_width 16
+#define openfolder_height 10
+static unsigned char openfolder_bits[] = {
+ 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0xc1, 0xff, 0x21, 0x80, 0x11, 0x40,
+ 0x09, 0x20, 0x05, 0x10, 0x03, 0x08, 0xff, 0x07};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/openfolder.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/openfolder.xpm
new file mode 100755
index 00000000000..191fe1e72bc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/openfolder.xpm
@@ -0,0 +1,21 @@
+/* XPM */
+static char * openfolder_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 3 1",
+/* colors */
+" s None c None",
+". c black",
+"X c #f0ff80",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".XXXXXXXXXXX. ",
+".XXX............",
+".XX.XXXXXXXXXXX.",
+".XX.XXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+"..XXXXXXXXXX.. ",
+"............. "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/option.pod b/Master/tlpkg/tlperl.straw/lib/Tk/option.pod
new file mode 100755
index 00000000000..1214357d181
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/option.pod
@@ -0,0 +1,217 @@
+# Copyright (c) 1990 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+option - Using the option database in Perl/Tk
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<widgetClass>(B<Name>=E<gt>I<name>, B<-class>=E<gt>I<class>);
+
+S< >I<$widget>-E<gt>B<PathName>;
+
+S< >I<$widget>-E<gt>B<optionAdd>(I<pattern>=E<gt>I<value > ?,I<priority>?);
+
+S< >I<$widget>-E<gt>B<optionClear>;
+
+S< >I<$widget>-E<gt>B<optionGet>(I<name, class>);
+
+S< >I<$widget>-E<gt>B<optionReadfile>(I<fileName> ?,I<priority>?);
+
+=head1 DESCRIPTION
+
+The option database (also known as the I<resource database> or the
+I<application defaults database>) is a set of rules for applying
+default options to widgets. Users and system administrators can
+set up these rules to customize the appearance of applications
+without changing any application code; for example, a user might
+set up personal foreground and background colors, or a site
+might use fonts associated with visual or language preferences.
+Different window managers (and implementations of them) have implemented
+the database differently, but most Xt-based window managers use the
+I<.Xdefaults> file or the I<xrdb> utility to manage user preferences;
+some use both, and/or implement a more complex set of site, user and
+application databases. Check your site documentation for these topics
+or your window manager's B<RESOURCE_MANAGER> property.
+
+=head2 Being a good citizen
+
+For most applications, the option database "just works." The B<option...>
+methods are for applications that need to do something unusual, such as
+add new rules or test an option's default. Even in such cases, the
+application should provide for user preferences.
+Do not hardcode widget options without a B<very> good reason.
+All users have their own tastes and they are all different.
+They choose a special font in a special size and have often spend a
+lot of time working out a color scheme that they will love until death.
+When you respect their choices they will enjoy working with your
+applications much more. Don't destroy the common look and feel of a
+personal desktop.
+
+=head2 Option rules and widget identification
+
+All widgets in an application are identified hierarchically by I<pathname>,
+starting from the B<MainWindow> and passing through each widget used to create
+the endpoint. The path elements are I<widget names>, much like the elements
+of a file path from the root directory to a file. The rules in the option
+database are patterns that are matched against a widget's I<pathname> to
+determine which defaults apply.
+When a widget is created, the B<Name> option can be
+used to assign the widget's name and thus create a distinctive path
+for widgets in an application. If the B<Name> option isn't given,
+Perl/Tk assigns a default name based on the type of widget; a
+B<MainWindow>'s default name is the B<appname>. These defaults are fine
+for most widgets, so don't feel you need to find a meaningful name for
+every widget you create.
+A widget must have a distinctive name to allow users to tailor its
+options independently of other widgets in an application. For instance,
+to create a B<Text> widget that will
+have special options assigned to it, give it a name such as:
+
+ $text = $mw->Text(Name => 'importantText');
+
+You can then tailor the widget's attributes with a rule in the option
+database such as:
+
+ *importantText*foreground: red
+
+The I<class> attribute identifies groups of widgets, usually within an
+application but also to group similar widgets among different applications.
+One typically assigns a class to a B<TopLevel> or B<Frame> so that the
+class will apply to all of that widget's children. To extend the example,
+we could be more specific about the importantText widget
+by giving its frame a class:
+
+ $frame = $mw->Frame(-class => 'Urgent');
+ $text = $frame->Text(Name => 'importantText');
+
+Then the resource pattern can be specified as so:
+
+ *Urgent*importantText*foreground: red
+
+Similarly, the pattern C<*Urgent*background: cyan> would apply to all
+widgets in the frame.
+
+=head1 METHODS
+
+=over 4
+
+=item I<$widget>-E<gt>B<widgetClass>(B<Name>=E<gt>I<name>, B<-class>=E<gt>I<class>);
+
+Identify a new widget with I<name> and/or I<class>.
+B<Name> specifies the path element for the widget; names generally begin with a
+lowercase letter. B<-class> specifies the class for the widget and its
+children; classes generally begin with an uppercase letter.
+If not specified, Perl/Tk will assign a unique default name to each widget.
+Only B<MainWindow> widgets have a default class, made by uppercasing the
+first letter of the application name.
+
+=item I<$widget>-E<gt>B<PathName>;
+
+The B<PathName> method returns the widget's I<pathname>, which uniquely
+identifies the widget within the application.
+
+=item I<$widget>-E<gt>B<optionAdd>(I<pattern>=E<gt>I<value >?, I<priority>?);
+
+The B<optionAdd> method adds a new option to the database.
+I<Pattern> contains the option being specified, and consists of
+names and/or classes separated by asterisks or dots, in the usual
+X format. I<Value> contains a text string to associate with
+I<pattern>; this is the value that will be returned in calls to
+the B<optionGet> method. If I<priority> is specified, it indicates
+the priority level for this option (see below for legal values);
+it defaults to B<interactive>. This method always returns an empty
+string.
+
+=item I<$widget>-E<gt>B<optionClear>;
+
+The B<optionClear> method clears the option database. Default
+options (from the B<RESOURCE_MANAGER> property or the B<.Xdefaults>
+file) will be reloaded automatically the next time an option is
+added to the database or removed from it. This method always returns
+an empty string.
+
+=item I<$widget>-E<gt>B<optionGet>(I<name,class>);
+
+The B<optionGet> method returns the value of the option specified for
+I<$widget> under I<name> and I<class>. To look up the option,
+B<optionGet> matches the patterns in the resource database against
+I<$widget>'s I<pathname> along with the class of I<$widget>
+(or its parent if I<$widget> has no class specified). The widget's
+class and name are options set when the widget is created (not
+related to class in the sense of L<bless>); the B<MainWindow>'s name
+is the B<appname> and its class is (by default) derived from the name
+of the script.
+
+If several entries in the option database match I<$widget>'s I<pathname>,
+I<name>, and I<class>, then the method returns whichever was created with
+highest I<priority> level. If there are several matching
+entries at the same priority level, then it returns whichever entry
+was I<most recently entered> into the option database. If there are
+no matching entries, then the empty string is returned.
+
+=item I<$widget>-E<gt>B<optionReadfile>(I<fileName>?,I<priority>?);
+
+The B<optionReadfile> method reads I<fileName>, which should have the
+standard format for an X resource database such as B<.Xdefaults>, and
+adds all the options specified in that file to the option database.
+If I<priority> is specified, it indicates the priority level at which
+to enter the options; I<priority> defaults to B<interactive>.
+
+The I<priority> arguments to the B<option> methods are
+normally specified symbolically using one of the following values:
+
+=over 8
+
+=item B<widgetDefault>
+
+Level 20. Used for default values hard-coded into widgets.
+
+=item B<startupFile>
+
+Level 40. Used for options specified in application-specific
+startup files.
+
+=item B<userDefault>
+
+Level 60. Used for options specified in user-specific defaults
+files, such as B<.Xdefaults>, resource databases loaded into
+the X server, or user-specific startup files.
+
+=item B<interactive>
+
+Level 80. Used for options specified interactively after the application
+starts running. If I<priority> isn't specified, it defaults to
+this level.
+
+=back
+
+Any of the above keywords may be abbreviated. In addition, priorities
+may be specified numerically using integers between 0 and 100,
+inclusive. The numeric form is probably a bad idea except for new priority
+levels other than the ones given above.
+
+=back
+
+=head1 BUGS
+
+The priority scheme used by core Tk is not the same as used by normal Xlib
+routines. In particular is assumes that the order of the entries is defined,
+but user commands like B<xrdb -merge> can change the order.
+
+=head1 SEE ALSO
+
+L<Tk::Xrm|Tk::Xrm>
+
+=head1 KEYWORDS
+
+database, option, priority, retrieve
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/options.pod b/Master/tlpkg/tlperl.straw/lib/Tk/options.pod
new file mode 100755
index 00000000000..49d81ddd2b4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/options.pod
@@ -0,0 +1,787 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::options - Standard options supported by widgets and their manipulation
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+S< >I<$value> = I<$widget>-E<gt>B<cget>('I<-option>');
+
+S< >I<$widget>-E<gt>B<configure>(I<-option>=E<gt>I<value> ?,I<-option>=E<gt>I<value> ...?);
+
+S< >I<@list> = I<$widget>-E<gt>B<configure>('I<-option>');
+
+S< >I<@lol> = I<$widget>-E<gt>B<configure>;
+
+=head1 DESCRIPTION
+
+All widgets, and images have a standard mechanism for setting and querying
+attibutes or options. The mechanism is based on two methods B<configure>
+and B<cget>. The behaviour of these methods is as follows:
+
+=over 4
+
+=item I<$widget>-E<gt>B<configure>(I<-option>=E<gt>I<value> ?,I<-option>=E<gt>I<value> ...?);
+
+Sets the values of I<-option> to I<value> for each I<-option>=E<gt>I<value>
+pair. The internal B<new> method does an implicit B<configure> in this
+form with options passed in at widget create time.
+
+=item I<$widget>-E<gt>B<configure>('I<-option>')
+
+In array context returns a list of five or two elements. If I<-option>
+is an alias for another options it return a list consisting of the
+alias option and the name for the option is is an alias for, e.g.,
+C<('-bg', 'background')>. If I<-option> is not an alias the returned
+list has the following five elements:
+
+=over 8
+
+=item I<Option Name>
+
+The value of I<-option>, e.g., B<-background>.
+
+=item I<Name>
+
+The option's name in the option database, e.g., C<background>.
+
+=item I<Class>
+
+The option's class value in the option database, e.g., C<Background>.
+
+=item I<Default>
+
+The default value for the option if not specified or in the option database,
+e.g., C<grey>.
+
+=item I<Value>
+
+The current value (as returned by B<cget>), e.g., C<white>.
+
+=back
+
+=item I<$widget>-E<gt>B<configure>
+
+Returns a list of lists for all the options supported by I<$widget>.
+Each sub-list is in the form returned by B<configure>('I<-option>').
+(This mechanism is used by the B<Tk::Derived> class to determine
+the options available from base class.)
+
+=item I<$widget>-E<gt>B<cget>('I<-option>')
+
+Returns the current value of I<-option> for I<$widget>.
+
+B<cget>('I<-option>') is clumsy with the need for B<''> due to perl's
+parsing rules. Something more subtle using L<tie|perlfunc/tie> might look better.
+
+=back
+
+The following paragraphs describe the common configuration options supported by
+widgets in the Tk toolkit. Every widget does not necessarily support every option
+(see the the documentation entries for individual widgets for a list of the
+standard options supported by that widget), but if a widget does support an option
+with one of the names listed below, then the option has exactly the effect
+described below.
+
+In the descriptions below, ``Name'' refers to the option's name in the option
+database. ``Class'' refers to the option's class value
+in the option database. ``Switch'' refers to the switch used in widget-creation
+and B<configure> widget methods to set this value. For example, if an option's
+configure option is B<-foreground> and there exists a widget I<$widget>, then the
+call:
+
+S< >I<$widget>-E<gt>B<configure>(B<-foreground>=E<gt>B<'black'>)
+
+may be used to specify the value B<black> for the option in the widget I<$widget>.
+Configure options may be abbreviated, as long as the abbreviation is unambiguous
+(abbreviation is deprecated in perl/Tk).
+
+=head2 Creation options: Widget Name and Class
+
+The B<Name> and B<-class> options can only be specified when a widget is
+created, and cannot be changed with B<configure>. These options determine
+the widget's identity and how Tk applies resource values from the
+option database (see L<Tk::option>) and so they
+cannot be assigned by the options database.
+
+=over 4
+
+=item Name: I<name>
+
+=item Switch: B<Name>
+
+Specifies the path element for the widget. Names generally begin with a
+lowercase letter.
+
+Each widget has a unique I<pathname> that follows the hierarchy from the
+B<MainWindow> to the widget itself. Since the widget's B<PathName> is
+used to assign options from the options database, it is important to
+specify a distinctive B<Name> for any widget that will have non-default
+options. See L<Tk::option> for details.
+
+=item Name: I<class>
+
+=item Switch: B<-class>
+
+Specifies a class for the window. Classes generally begin with an
+uppercase letter.
+
+This class will be used when querying the option database for
+the window's other options (see Tk::options), and it will also be used
+later for other purposes such as bindings. One typically assigns a class
+to a B<TopLevel> or B<Frame> so that the class will apply to all of
+that widget's children.
+
+=back
+
+=head2 Reconfigurable options
+
+These options can be set at widget creation or changed later via B<configure>.
+
+=over 4
+
+=item Name: B<activeBackground>
+
+=item Class: B<Foreground>
+
+=item Switch: B<-activebackground>
+
+Specifies background color to use when drawing active elements.
+An element (a widget or portion of a widget) is active if the
+mouse cursor is positioned over the element and pressing a mouse button
+will cause some action to occur.
+If strict Motif compliance has been requested by setting the
+B<$Tk::strictMotif> variable, this option will normally be
+ignored; the normal background color will be used instead.
+For some elements on Windows and Macintosh systems, the active color
+will only be used while mouse button 1 is pressed over the element.
+
+=item Name: B<activeBorderWidth>
+
+=item Class: B<BorderWidth>
+
+=item Switch: B<-activeborderwidth>
+
+Specifies a non-negative value indicating
+the width of the 3-D border drawn around active elements.
+See above for definition of active elements.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+This option is typically only available in widgets displaying more
+than one element at a time (e.g. menus but not buttons).
+
+=item Name: B<activeForeground>
+
+=item Class: B<Background>
+
+=item Switch: B<-activeforeground>
+
+Specifies foreground color to use when drawing active elements.
+See above for definition of active elements.
+
+=item Name: B<activetile>
+
+=item Class: B<Tile>
+
+=item Switch: B<-activetile>
+
+Specifies image used to display inside active elements of the widget.
+See above for definition of active elements.
+
+=item Name: B<anchor>
+
+=item Class: B<Anchor>
+
+=item Switch: B<-anchor>
+
+Specifies how the information in a widget (e.g. text or a bitmap)
+is to be displayed in the widget.
+Must be one of the values B<n>, B<ne>, B<e>, B<se>,
+B<s>, B<sw>, B<w>, B<nw>, or B<center>.
+For example, B<nw> means display the information such that its
+top-left corner is at the top-left corner of the widget.
+
+=item Name: B<background>
+
+=item Class: B<Background>
+
+=item Switch: B<-background>
+
+=item Alias: B<-bg>
+
+Specifies the normal background color to use when displaying the
+widget.
+
+=item Name: B<bitmap>
+
+=item Class: B<Bitmap>
+
+=item Switch: B<-bitmap>
+
+Specifies a bitmap to display in the widget, in any of the forms
+acceptable to B<Tk_GetBitmap>.
+The exact way in which the bitmap is displayed may be affected by
+other options such as B<-anchor> or B<-justify>.
+Typically, if this option is specified then it overrides other
+options that specify a textual value to display in the widget;
+the B<-bitmap> option may be reset to an empty string to re-enable
+a text display.
+In widgets that support both B<-bitmap> and B<-image> options,
+B<-image> will usually override B<-bitmap>.
+
+=item Name: B<borderWidth>
+
+=item Class: B<BorderWidth>
+
+=item Switch: B<-borderwidth>
+
+=item Alias: B<-bd>
+
+Specifies a non-negative value indicating the width
+of the 3-D border to draw around the outside of the widget (if such a
+border is being drawn; the B<relief> option typically determines
+this). The value may also be used when drawing 3-D effects in the
+interior of the widget.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+
+=item Name: B<compound>
+
+=item Class: B<Compound>
+
+=item Switch: B<-compound>
+
+Specifies if the widget should display text and bitmaps/images at the
+same time, and if so, where the bitmap/image should be placed relative
+to the text. Must be one of the values B<none>, B<bottom>, B<top>,
+B<left>, B<right>, or B<center>. For example, the (default) value
+B<none> specifies that the bitmap or image should (if defined) be
+displayed instead of the text, the value B<left> specifies that the
+bitmap or image should be displayed to the left of the text, and the
+value B<center> specifies that the bitmap or image should be displayed on
+top of the text.
+
+=item Name: B<cursor>
+
+=item Class: B<Cursor>
+
+=item Switch: B<-cursor>
+
+Specifies the mouse cursor to be used for the widget.
+The value may have any of the forms acceptable to B<Tk_GetCursor>.
+
+=item Name: B<dash>
+
+=item Class: B<Dash>
+
+=item Switch: B<-dash>
+
+The value may have any of the forms accepted by B<Tk_GetDash>,
+such as B<4>, B<[6,4]>, B<.>, B<->, B<-.>, or B<-..>.
+
+=item Name: B<dashoffset>
+
+=item Class: B<Dashoffset>
+
+=item Switch: B<-dashoffset>
+
+Specifies the offset in the dash list where the drawing starts.
+
+=item Name: B<disabledForeground>
+
+=item Class: B<DisabledForeground>
+
+=item Switch: B<-disabledforeground>
+
+Specifies foreground color to use when drawing a disabled element.
+If the option is specified as an empty string (which is typically the
+case on monochrome displays), disabled elements are drawn with the
+normal foreground color but they are dimmed by drawing them
+with a stippled fill pattern.
+
+=item Name: B<disabledtile>
+
+=item Class: B<Tile>
+
+=item Switch: B<-disabledtile>
+
+Specifies image to use when drawing a disabled element.
+
+=item Name: B<exportSelection>
+
+=item Class: B<ExportSelection>
+
+=item Switch: B<-exportselection>
+
+Specifies whether or not a selection in the widget should also be
+the X selection.
+The value may have any of the forms accepted by B<Tcl_GetBoolean>,
+such as B<true>, B<false>, B<0>, B<1>, B<yes>, or B<no>.
+If the selection is exported, then selecting in the widget deselects
+the current X selection, selecting outside the widget deselects any
+widget selection, and the widget will respond to selection retrieval
+requests when it has a selection. The default is usually for widgets
+to export selections.
+
+=item Name: B<font>
+
+=item Class: B<Font>
+
+=item Switch: B<-font>
+
+Specifies the font to use when drawing text inside the widget.
+
+=item Name: B<foreground>
+
+=item Class: B<Foreground>
+
+=item Switch: B<-foreground>
+
+=item Alias: B<-fg>
+
+Specifies the normal foreground color to use when displaying the widget.
+
+=item Name: B<highlightBackground>
+
+=item Class: B<HighlightBackground>
+
+=item Switch: B<-highlightbackground>
+
+Specifies the color to display in the traversal highlight region when
+the widget does not have the input focus.
+
+=item Name: B<highlightColor>
+
+=item Class: B<HighlightColor>
+
+=item Switch: B<-highlightcolor>
+
+Specifies the color to use for the traversal highlight rectangle that is
+drawn around the widget when it has the input focus.
+
+=item Name: B<highlightThickness>
+
+=item Class: B<HighlightThickness>
+
+=item Switch: B<-highlightthickness>
+
+Specifies a non-negative value indicating the width of the highlight
+rectangle to draw around the outside of the widget when it has the
+input focus.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+If the value is zero, no focus highlight is drawn around the widget.
+
+=item Name: B<image>
+
+=item Class: B<Image>
+
+=item Switch: B<-image>
+
+Specifies an image to display in the widget, which must have been
+created with an image create. (See L<Tk::Image> for details of image creation.)
+Typically, if the B<-image> option is specified then it overrides other
+options that specify a bitmap or textual value to display in the widget;
+the B<-image> option may be reset to an empty string to re-enable
+a bitmap or text display.
+
+=item Name: B<insertBackground>
+
+=item Class: B<Foreground>
+
+=item Switch: B<-insertbackground>
+
+Specifies the color to use as background in the area covered by the
+insertion cursor. This color will normally override either the normal
+background for the widget (or the selection background if the insertion
+cursor happens to fall in the selection).
+
+=item Name: B<insertBorderWidth>
+
+=item Class: B<BorderWidth>
+
+=item Switch: B<-insertborderwidth>
+
+Specifies a non-negative value indicating the width
+of the 3-D border to draw around the insertion cursor.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+
+=item Name: B<insertOffTime>
+
+=item Class: B<OffTime>
+
+=item Switch: B<-insertofftime>
+
+Specifies a non-negative integer value indicating the number of
+milliseconds the insertion cursor should remain ``off'' in each blink cycle.
+If this option is zero then the cursor doesn't blink: it is on
+all the time.
+
+=item Name: B<insertOnTime>
+
+=item Class: B<OnTime>
+
+=item Switch: B<-insertontime>
+
+Specifies a non-negative integer value indicating the number of
+milliseconds the insertion cursor should remain ``on'' in each blink cycle.
+
+=item Name: B<insertWidth>
+
+=item Class: B<InsertWidth>
+
+=item Switch: B<-insertwidth>
+
+Specifies a value indicating the total width of the insertion cursor.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+If a border has been specified for the insertion
+cursor (using the B<insertBorderWidth> option), the border
+will be drawn inside the width specified by the B<insertWidth>
+option.
+
+=item Name: B<jump>
+
+=item Class: B<Jump>
+
+=item Switch: B<-jump>
+
+For widgets with a slider that can be dragged to adjust a value,
+such as scrollbars, this option determines when
+notifications are made about changes in the value.
+The option's value must be a boolean of the form accepted by
+B<Tcl_GetBoolean>.
+If the value is false, updates are made continuously as the
+slider is dragged.
+If the value is true, updates are delayed until the mouse button
+is released to end the drag; at that point a single notification
+is made (the value ``jumps'' rather than changing smoothly).
+
+=item Name: B<justify>
+
+=item Class: B<Justify>
+
+=item Switch: B<-justify>
+
+When there are multiple lines of text displayed in a widget, this
+option determines how the lines line up with each other.
+Must be one of B<left>, B<center>, or B<right>.
+B<Left> means that the lines' left edges all line up, B<center>
+means that the lines' centers are aligned, and B<right> means
+that the lines' right edges line up.
+
+=item Name: B<offset>
+
+=item Class: B<Offset>
+
+=item Switch: B<-offset>
+
+Specifies the offset of tiles (see also B<-tile> option). It can
+have two different formats B<-offset x,y> or B<-offset side>,
+where side can be B<n>, B<ne>, B<e>, B<se>, B<s>,
+B<sw>, B<w>, B<nw>, or B<center>. In the first case
+the origin is the origin of the toplevel of the current window.
+For the canvas itself and canvas objects the origin is the canvas
+origin, but putting B<#> in front of the coordinate pair
+indicates using the toplevel origin in stead. For canvas objects,
+the B<-offset> option is used for stippling as well.
+For the line and polygon canvas items you can also specify
+an index as argument, which connects the stipple or tile
+origin to one of the coordinate points of the line/polygon.
+
+=item Name: B<orient>
+
+=item Class: B<Orient>
+
+=item Switch: B<-orient>
+
+For widgets that can lay themselves out with either a horizontal
+or vertical orientation, such as scrollbars, this option specifies
+which orientation should be used. Must be either B<horizontal>
+or B<vertical> or an abbreviation of one of these.
+
+=item Name: B<padX>
+
+=item Class: B<Pad>
+
+=item Switch: B<-padx>
+
+Specifies a non-negative value indicating how much extra space
+to request for the widget in the X-direction.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+When computing how large a window it needs, the widget will
+add this amount to the width it would normally need (as determined
+by the width of the things displayed in the widget); if the geometry
+manager can satisfy this request, the widget will end up with extra
+internal space to the left and/or right of what it displays inside.
+Most widgets only use this option for padding text: if they are
+displaying a bitmap or image, then they usually ignore padding
+options.
+
+=item Name: B<padY>
+
+=item Class: B<Pad>
+
+=item Switch: B<-pady>
+
+Specifies a non-negative value indicating how much extra space
+to request for the widget in the Y-direction.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+When computing how large a window it needs, the widget will add
+this amount to the height it would normally need (as determined by
+the height of the things displayed in the widget); if the geometry
+manager can satisfy this request, the widget will end up with extra
+internal space above and/or below what it displays inside.
+Most widgets only use this option for padding text: if they are
+displaying a bitmap or image, then they usually ignore padding
+options.
+
+=item Name: B<relief>
+
+=item Class: B<Relief>
+
+=item Switch: B<-relief>
+
+Specifies the 3-D effect desired for the widget. Acceptable
+values are B<raised>, B<sunken>, B<flat>, B<ridge>,
+B<solid>, and B<groove>.
+The value
+indicates how the interior of the widget should appear relative
+to its exterior; for example, B<raised> means the interior of
+the widget should appear to protrude from the screen, relative to
+the exterior of the widget.
+
+=item Name: B<repeatDelay>
+
+=item Class: B<RepeatDelay>
+
+=item Switch: B<-repeatdelay>
+
+Specifies the number of milliseconds a button or key must be held
+down before it begins to auto-repeat. Used, for example, on the
+up- and down-arrows in scrollbars.
+
+=item Name: B<repeatInterval>
+
+=item Class: B<RepeatInterval>
+
+=item Switch: B<-repeatinterval>
+
+Used in conjunction with B<repeatDelay>: once auto-repeat
+begins, this option determines the number of milliseconds between
+auto-repeats.
+
+=item Name: B<selectBackground>
+
+=item Class: B<Foreground>
+
+=item Switch: B<-selectbackground>
+
+Specifies the background color to use when displaying selected
+items.
+
+=item Name: B<selectBorderWidth>
+
+=item Class: B<BorderWidth>
+
+=item Switch: B<-selectborderwidth>
+
+Specifies a non-negative value indicating the width
+of the 3-D border to draw around selected items.
+The value may have any of the forms acceptable to B<Tk_GetPixels>.
+
+=item Name: B<selectForeground>
+
+=item Class: B<Background>
+
+=item Switch: B<-selectforeground>
+
+Specifies the foreground color to use when displaying selected
+items.
+
+=item Name: B<setGrid>
+
+=item Class: B<SetGrid>
+
+=item Switch: B<-setgrid>
+
+Specifies a boolean value that determines whether this widget controls the
+resizing grid for its top-level window.
+This option is typically used in text widgets, where the information
+in the widget has a natural size (the size of a character) and it makes
+sense for the window's dimensions to be integral numbers of these units.
+These natural window sizes form a grid.
+If the B<setGrid> option is set to true then the widget will
+communicate with the window manager so that when the user interactively
+resizes the top-level window that contains the widget, the dimensions of
+the window will be displayed to the user in grid units and the window
+size will be constrained to integral numbers of grid units.
+See L<Tk::Wm/"GRIDDED GEOMETRY MANAGEMENT">
+for more details.
+
+=item Name: B<takeFocus>
+
+=item Class: B<TakeFocus>
+
+=item Switch: B<-takefocus>
+
+Determines whether the window accepts the focus during keyboard
+traversal (e.g., Tab and Shift-Tab).
+Before setting the focus to a window, the traversal scripts
+consult the value of the B<takeFocus> option.
+A value of B<0> means that the window should be skipped entirely
+during keyboard traversal.
+B<1> means that the window should receive the input
+focus as long as it is viewable (it and all of its ancestors are mapped).
+An empty value for the option means that the traversal scripts make
+the decision about whether or not to focus on the window: the current
+algorithm is to skip the window if it is
+disabled, if it has no key bindings, or if it is not viewable.
+If the value has any other form, then the traversal scripts take
+the value, append the name of the window to it (with a separator space),
+and evaluate the resulting string as a Callback.
+The script must return B<0>, B<1>, or an empty string: a
+B<0> or B<1> value specifies whether the window will receive
+the input focus, and an empty string results in the default decision
+described above.
+Note: this interpretation of the option is defined entirely by
+the Callbacks that implement traversal: the widget implementations
+ignore the option entirely, so you can change its meaning if you
+redefine the keyboard traversal scripts.
+
+=item Name: B<text>
+
+=item Class: B<Text>
+
+=item Switch: B<-text>
+
+Specifies a string to be displayed inside the widget. The way in which
+the string is displayed depends on the particular widget and may be
+determined by other options, such as B<anchor> or B<justify>.
+
+=item Name: B<textVariable>
+
+=item Class: B<Variable>
+
+=item Switch: B<-textvariable>
+
+Specifies the name of a variable. The value of the variable is a text
+string to be displayed inside the widget; if the variable value changes
+then the widget will automatically update itself to reflect the new value.
+The way in which the string is displayed in the widget depends on the
+particular widget and may be determined by other options, such as
+B<anchor> or B<justify>.
+
+=item Name: B<tile>
+
+=item Class: B<Tile>
+
+=item Switch: B<-tile>
+
+Specifies image used to display the widget. If image is the empty
+string, then the normal background color is displayed.
+
+=item Name: B<troughColor>
+
+=item Class: B<Background>
+
+=item Switch: B<-troughcolor>
+
+Specifies the color to use for the rectangular trough areas
+in widgets such as scrollbars and scales.
+
+=item Name: B<troughTile>
+
+=item Class: B<Tile>
+
+=item Switch: B<-troughtile>
+
+Specifies image used to display in the rectangular trough areas
+in widgets such as scrollbars and scales.
+
+=item Name: B<underline>
+
+=item Class: B<Underline>
+
+=item Switch: B<-underline>
+
+Specifies the integer index of a character to underline in the widget.
+This option is used by the default bindings to implement keyboard
+traversal for menu buttons and menu entries.
+0 corresponds to the first character of the text displayed in the
+widget, 1 to the next character, and so on.
+
+=item Name: B<wrapLength>
+
+=item Class: B<WrapLength>
+
+=item Switch: B<-wraplength>
+
+For widgets that can perform word-wrapping, this option specifies
+the maximum line length.
+Lines that would exceed this length are wrapped onto the next line,
+so that no line is longer than the specified length.
+The value may be specified in any of the standard forms for
+screen distances.
+If this value is less than or equal to 0 then no wrapping is done: lines
+will break only at newline characters in the text.
+
+=item Name: B<xScrollCommand>
+
+=item Class: B<ScrollCommand>
+
+=item Switch: B<-xscrollcommand>
+
+Specifies a callback used to communicate with horizontal
+scrollbars.
+When the view in the widget's window changes (or
+whenever anything else occurs that could change the display in a
+scrollbar, such as a change in the total size of the widget's
+contents), the widget will
+make a callback passing two numeric arguments in addition to
+any specified in the callback.
+Each of the numbers is a fraction between 0 and 1, which indicates
+a position in the document. 0 indicates the beginning of the document,
+1 indicates the end, .333 indicates a position one third the way through
+the document, and so on.
+The first fraction indicates the first information in the document
+that is visible in the window, and the second fraction indicates
+the information just after the last portion that is visible.
+Typically the
+B<xScrollCommand> option consists of the scrollbar widget object
+and the method ``set'' i.e. [B<set> =E<gt> I<$sb>]:
+this will cause the scrollbar to be updated whenever the view in the window changes.
+If this option is not specified, then no command will be executed.
+
+=item Name: B<yScrollCommand>
+
+=item Class: B<ScrollCommand>
+
+=item Switch: B<-yscrollcommand>
+
+Specifies a calback used to communicate with vertical
+scrollbars. This option is treated in the same way as the
+B<xScrollCommand> option, except that it is used for vertical
+scrollbars and is provided by widgets that support vertical scrolling.
+See the description of B<xScrollCommand> for details
+on how this option is used.
+
+=back
+
+=head1 SEE ALSO
+
+L<Tk::option>
+L<Tk::callbacks>
+L<Tk::ConfigSpecs>
+L<Tk_GetPixels|Tk::pTk::GetPixels>
+
+=head1 KEYWORDS
+
+class, name, standard option, switch
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/overview.pod b/Master/tlpkg/tlperl.straw/lib/Tk/overview.pod
new file mode 100755
index 00000000000..0c9e183b68a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/overview.pod
@@ -0,0 +1,138 @@
+
+=head1 NAME
+
+B<Tk> - An overview of an Object Oriented Tk8 extension for perl5
+
+=for category Introduction
+
+=head1 SYNOPSIS
+
+C<< use Tk; >>
+
+C<< $main = MainWindow-E<gt>new(); >>
+
+C<< $widget = $main-E<gt>I<Widget>(...); >>
+
+C<< $widget-E<gt>pack(...); >>
+
+...
+
+C<< MainLoop; >>
+
+=head1 DESCRIPTION
+
+In writing the perl Tk extension, the goals were to provide a complete
+interface to the latest production version of John Ousterhout's Tk, while providing
+an Object Oriented interface to perl code.
+
+=head1 CONTENTS
+
+The package is composed of three loosely connected parts:
+
+=over 4
+
+=item I<pTk> - Converted Tk source
+
+The I<pTk> sub-directory is a copy of the C code of Tk8.x, modified
+to allow use by languages other than the original Tcl.
+(The pTk can be read as 'perl' Tk or 'portable' Tk, depending on
+your sensibilities.)
+
+=item B<Tk> to Perl 'Glue'
+
+The top level directory provides I<Tk.xs> and I<tkGlue.c>
+which provide the perl-callable interfaces to pTk
+
+=item Perl code for 'Widget' Classes
+
+The I<Tk> sub-directory contains the various perl modules that comprise
+the "Classes" that are visible to Tk applications.
+
+The "major" widgets such as B<Tk::Text> are actually in separate directories
+at the top level (e.g. I<Text/*> for B<Tk::Text>) and are dynamically
+loaded as needed on platforms which support perl5's B<DynaLoader>.
+
+=back
+
+=head1 CLASS HIERARCHY
+
+=over 4
+
+=item B<package Tk;> - the 'base class'
+
+All the "command names" documented in Tcl/Tk are made to look like perl
+sub's and reside in the Tk package. Their names are all lower case.
+Typically there are very few commands at this level which are called
+directly by applications.
+
+=item B<package Tk::Widget;> - the 'Widget class'
+
+There are no actual objects of the B<Tk::Widget> class; however all
+the various Tk window "widgets" inherit from it, and it in turn
+inherits all the core Tk functions from Tk.
+
+B<Tk::Widget> provides various functions and interfaces which are
+common to all Widgets.
+
+A widget is represented to perl as a blessed reference to a hash. There are some
+members of the hash which are private to Tk and its tkGlue code. Keys
+starting with B<'.'> and of the form B</_[A-Z][A-Za-z_]+_/>
+(i.e. starting and ending in _ and with first char after _ being upper case) should be
+considered reserved to B<Tk>.
+
+=item B<Tk::Button>, B<Tk::Entry>, B<Tk::Text> ...
+
+There is one class for each of the "Tk" widget item types.
+Some of them like B<Tk::Frame> do very little indeed, and really
+only exist so that they can be derived from or so that focus or menu
+traversal can discover the "kind" of window being processed.
+
+Other classes, B<Tk::Text> for example, provide a lot of methods
+used with Tk's "bind" to provide a rich keyboard/mouse interface
+to the widgets' data.
+
+These widget classes also include conversions of the Tcl code for
+event bindings, keyboard focus traversal, menu bars, and menu keyboard
+traversal. All the Tcl functions have been converted, but the names have
+changed (systematically) and they have been split up between the various
+classes in what I hope is an appropriate manner.
+Name changes are normally: dropping initial tk_ as the Tk-ness is implicit
+in the B<Tk::> prefix, and similarly dropping say Menu from the name if it
+has been moved the Tk::Menu class.
+Thus 'proc tkMenuNextEntry' becomes 'sub NextEntry' in the Tk::Menu package.
+
+=item B<Tk::Image>
+
+This does for Tk8.x's "images" what B<Tk::Widget> does for widgets.
+Images are new to Tk8.x and the class structure is not mature either.
+
+There are three sub-classes B<Tk::Bitmap>, B<Tk::Pixmap> and B<Tk::Photo>.
+
+It is possible to create dynamic or auto-loaded image types inherited
+from B<Tk::Image> for other image types or photo formats (e.g. support
+for TIFF format).
+
+=item Composite Widgets
+
+A composite is some kind of 'frame' with subwidgets which give it useful behaviour.
+B<Tk::Dialog> is an example of
+a composite widget classes built from the basic B<Tk> ones.
+It is intended that user code should not need to be aware that a particular
+class is a composite, and create and configure such widgets in the same manner
+as any other kind. The B<configure> mechanism and the methods of the
+class manipulate the subwidgets as required.
+
+Composite widgets are implemented via B<Tk::Frame> and multiple inheritance.
+The two 'frame' base classes B<Tk::Frame> and
+B<Tk::Toplevel> include the additional class B<Tk::Derived>
+in their inheritance. B<Tk::Derived> provides methods to allow additional
+B<configure> options to be defined for a widget.
+
+A Composite widget is typically defined as derived
+from B<Tk::Frame> or B<Tk::Toplevel>
+(e.g. B<Tk::Dialog>).
+
+=back
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk.pod b/Master/tlpkg/tlperl.straw/lib/Tk/pTk.pod
new file mode 100755
index 00000000000..6e1a2a04022
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk.pod
@@ -0,0 +1,550 @@
+=head1 NAME
+
+Tk2portableTk - how to make your B<Tk> source portable to other
+interpreted languages.
+
+=for category C Programming
+
+=head1 Author
+
+Ilya Zakharevich <ilya@math.ohio-state.edu> has contributed most of
+this document. Many thanks.
+
+=head1 DESCRIPTION
+
+B<PortableTk> is an attempt to make B<Tk> useful from other
+languages. Currently tk4.0 runs under Perl using this
+approach. Below, I<Lang> is the notation for an external language to
+which B<PortableTk> glues B<Tk> code.
+
+The main problem with using the code developed for B<TCL> with
+different languages is the absence of data types: almost anything is
+C<char*>. It makes automatic translation hopeless. However, if you
+C<typedef> several new symbols to be C<char*>, you can still use your
+code in B<TCL>, I<and> it will make the automatic translation
+possible.
+
+Another problem with the approach that "everything is a string" is
+impossibility to have a result that says "NotApplicable" without
+setting an error. Thus different B<Tk> command return different string
+values that mean "error happened", like C<"">, C<" "> or
+C<"??">. Other languages can be more flexible, so in B<portableTk> you
+should inform the compiler that what you want to return means "error"
+(see L<Setting variables>).
+
+Currently B<PortableTk> uses several different approachs
+to simplify translation: several B<TCL> functions that are especially
+dangerous to use are undefined, so you can easily find places that
+need to be updated to use Language-independent functions based on
+compiler warnings. Eventually a way to use these Language-independent
+functions under proper B<TCL> will be also provided. The end of this
+document provides a starting point for such a project.
+
+=head1 Structure of B<pTk>, porting your code
+
+B<pTk>, that is a port of B<Tk>, is very special with respect to porting
+of other code to B<portableTk>. The problem is that currently there is
+very little hope to merge the modifications back into B<Tk>, so a
+special strategy is needed to maintain this port. Do not use this
+strategy to port your own code.
+
+B<pTk> is produced from B<Tk> via a two-step process: first, some
+manual editing (the result is in the subdirectory C<mTk>), and second,
+automatic conversion by the C<munge> script (written in Perl). Thus the
+subdirectory C<pTk/mTk> contains code with minimal possible difference
+from the virgin B<Tk> code, so it is easier to merge(1) the
+differences between B<Tk> versions into modified code.
+
+It looks like the strategy for a portable code should be exactly
+opposite: starting from B<TCL>-based code, apply C<munge>, and then
+hand-edit the resulting code. Probably it is also possible to target
+your code to B<portableTk> from scratch, since this will make it
+possible to run it under a lot of I<Lang>uages.
+
+The only reason anyone would like to look into contents of C<pTk/mTk>
+directory is to find out which constructs are not supported by
+C<munge>. On the other hand, C<pTk> directory contains code that is
+conformant to B<portableTk>, so you can look there to find example code.
+
+C<munge> is the script that converts most common B<Tk> constructs to
+their C<portableTk> equivalent. For your code to qualify, you should
+follow B<Tk> conventions on indentation and names of variables, in
+particular, the array of arguments for the C<...CmdProc> should be
+called C<argv>.
+
+For details on what C<munge> can do, see
+L<Translation of some TCL functions>.
+
+=head1 B<PortableTk> API
+
+=head2 Checking what you are running under
+
+B<PortableTk> provides a symbol C<????>. If this symbol is defined,
+your source is compiled with it.
+
+=head2 New types of configuration options
+
+B<PortableTk> defines several new types of configuration options:
+
+ TK_CONFIG_CALLBACK
+ TK_CONFIG_LANGARG
+ TK_CONFIG_SCALARVAR
+ TK_CONFIG_HASHVAR
+ TK_CONFIG_ARRAYVAR
+ TK_CONFIG_IMAGE
+
+You should use them instead of TK_CONFIG_STRING whenever
+appropriate. This allows your application to receive a direct
+representation of the corresponding resource instead of the string
+representation, if this is possible under given language.
+
+???? It looks like C<TK_CONFIG_IMAGE> and C<TK_CONFIG_SCALARVAR> set
+variables of type C<char*>.
+
+=head2 Language data
+
+The following data types are defined:
+
+=over 4
+
+=item C<Tcl_Obj *>
+
+is the main datatype of the language. This is a type that your C
+function gets pointers to for arguments when the corresponding I<Lang>
+function is called. The corresponding config type is
+C<TK_CONFIG_LANGARG>.
+
+This is also a type that keeps information about contents of I<Lang>
+variable.
+
+=item C<Var>
+
+Is a substitute for a C<char *> that contains name of variable. In
+I<Lang> it is an object that contains reference to another I<Lang>
+variable.
+
+=item C<LangResultSave>
+
+????
+
+=item C<LangCallback>
+
+C<LangCallback*> a substitute for a C<char *> that contains command to
+call. The corresponding config type is C<TK_CONFIG_CALLBACK>.
+
+=item C<LangFreeProc>
+
+It is the type that the C<Lang_SplitList> sets. Before you call it,
+declare
+
+ Args *args;
+ LangFreeProc *freeProc = NULL;
+ ...
+ code = Lang_SplitList(interp, value,
+ &argc, &args, &freeProc);
+
+After you use the split values, call
+
+ if (args != NULL && freeProc) (*freeProc)(argc,args);
+
+It is not guaranteed that the C<args> can survive deletion of C<value>.
+
+=back
+
+=head2 Conversion
+
+The following macros and functions are used for conversion between
+strings and the additional types:
+
+ LangCallback * LangMakeCallback(Tcl_Obj *)
+ Tcl_Obj * LangCallbackArg(LangCallback *)
+ char * LangString(Tcl_Obj *)
+
+After you use the result of LangCallbackArg(), you should free it with
+C<freeProc> C<LANG_DYNAMIC> (it is not guaranteed that any change of
+C<Tcl_Obj *> will not be reflected in <LangCallback>, so you cannot do
+LangSet...() in between, and you should reset it to C<NULL> if you
+want to do any further assignments to this C<Tcl_Obj *>).
+
+The following function returns the C<Tcl_Obj *> that is a reference to C<Var>:
+
+ Tcl_Obj * LangVarArg(Var)
+
+???? It is very anti-intuitive, I hope the name is changed.
+
+ int LangCmpCallback(LangCallback *a,Tcl_Obj * b)
+
+(currently only a stub), and, at last,
+
+ LangCallback * LangCopyCallback(LangCallback *)
+
+=head2 Callbacks
+
+Above we have seen the new datatype C<LangCallback> and the
+corresponding I<Config option> C<TK_CONFIG_CALLBACK>. The following
+functions are provided for manipulation of C<LangCallback>s:
+
+ void LangFreeCallback(LangCallback *)
+ int LangDoCallback(Tcl_Interp *,LangCallback *,
+ int result,int argc, char *format,...)
+
+The argument C<format> of C<LangDoCallback> should contain a string that is
+suitable for C<sprintf> with optional arguments of C<LangDoCallback>.
+C<result> should be false if result of callback is not needed.
+
+ int LangMethodCall(Tcl_Interp *,Tcl_Obj *,char *method,
+ int result,int argc,...)
+
+????
+
+Conceptually, C<LangCallback*> is a substitute for ubiquitous C<char *>
+in B<TCL>. So you should use C<LangFreeCallback> instead of C<ckfree>
+or C<free> if appropriate.
+
+=head2 Setting variables
+
+ void LangFreeArg (Tcl_Obj *, Tcl_FreeProc *freeProc)
+ Tcl_Obj * LangCopyArg (Tcl_Obj *);
+ void Tcl_AppendArg (Tcl_Interp *interp, Tcl_Obj *)
+ void LangSetString(Tcl_Obj * *, char *s)
+ void LangSetDefault(Tcl_Obj * *, char *s)
+
+These two are equivalent unless s is an empty string. In this case
+C<LangSetDefault> behaves like C<LangSetString> with C<s==NULL>, i.e.,
+it sets the current value of the I<Lang> variable to be false.
+
+ void LangSetInt(Tcl_Obj * *,int)
+ void LangSetDouble(Tcl_Obj * *,double)
+
+The I<Lang> functions separate uninitialized and initialized data
+comparing data with C<NULL>. So the declaration for an C<Tcl_Obj *> should
+look like
+
+ Tcl_Obj * arg = NULL;
+
+if you want to use this C<arg> with the above functions. After you are
+done, you should use C<LangFreeArg> with C<TCL_DYNAMIC> as C<freeProc>.
+
+=head2 Language functions
+
+Use
+
+=over 4
+
+=item C<int LangNull(Tcl_Obj *)>
+
+to check that an object is false;
+
+=item C<int LangStringMatch(char *string, Tcl_Obj * match)>
+
+????
+
+=item C<void LangExit(int)>
+
+to make a proper shutdown;
+
+=item C<int LangEval(Tcl_Interp *interp, char *cmd, int global)>
+
+to call I<Lang> C<eval>;
+
+=item C<void Lang_SetErrorCode(Tcl_Interp *interp,char *code)>
+
+=item C<char *Lang_GetErrorCode(Tcl_Interp *interp)>
+
+=item C<char *Lang_GetErrorInfo(Tcl_Interp *interp)>
+
+=item C<void LangCloseHandler(Tcl_Interp *interp,Tcl_Obj * arg,FILE *f,Lang_FileCloseProc *proc)>
+
+currently stubs only;
+
+=item C<int LangSaveVar(Tcl_Interp *,Tcl_Obj * arg,Var *varPtr,int type)>
+
+to save the structure C<arg> into I<Lang> variable C<*varPtr>;
+
+=item C<void LangFreeVar(Var var)>
+
+to free the result;
+
+=item C<int LangEventCallback(Tcl_Interp *,LangCallback *,XEvent *,KeySym)>
+
+????
+
+=item C<int LangEventHook(int flags)>
+
+=item C<void LangBadFile(int fd)>
+
+=item C<int LangCmpConfig(char *spec, char *arg, size_t length)>
+
+unsupported????;
+
+=item C<void Tcl_AppendArg (Tcl_Interp *interp, Tcl_Obj *)>
+
+=back
+
+Another useful construction is
+
+ Tcl_Obj * variable = LangFindVar(interp, Tk_Window tkwin, char *name);
+
+After using the above function, you should call
+
+ LangFreeVar(Var variable);
+
+???? Note discrepancy in types!
+
+If you want to find the value of a variable (of type C<Tcl_Obj *>) given the
+variable name, use C<Tcl_GetVar(interp, varName, flags)>. If you are
+interested in the string value of this variable, use
+C<LangString(Tcl_GetVar(...))>.
+
+To get a B<C> array of C<Tcl_Obj *> of length C<n>, use
+
+ Tcl_Obj * *args = LangAllocVec(n);
+ ...
+ LangFreeVec(n,args);
+
+You can set the values of the C<Tcl_Obj *>s using C<LangSet...> functions,
+and get string value using C<LangString>.
+
+If you want to merge an array of C<Tcl_Obj *>s into one C<Tcl_Obj *> (that will
+be an array variable), use
+
+ result = Tcl_Merge(listLength, list);
+
+=head2 Translation of some TCL functions
+
+We mark items that can be dealt with by C<munge> by I<Autoconverted>.
+
+=over 4
+
+=item C<Tcl_AppendResult>
+
+does not take C<(char*)NULL>, but C<NULL> as delimiter. I<Autoconverted>.
+
+=item C<Tcl_CreateCommand>, C<Tcl_DeleteCommand>
+
+C<Tk_CreateWidget>, C<Tk_DeleteWidget>, the second argument is the
+window itself, not the pathname. I<Autoconverted>.
+
+=item C<sprintf(interp-E<gt>result, "%d %d %d %d",...)>
+
+C<Tcl_IntResults(interp,4,0,...)>. I<Autoconverted>.
+
+=item C<interp-E<gt>result = "1";>
+
+C<Tcl_SetResult(interp,"1", TCL_STATIC)>. I<Autoconverted>.
+
+=item Reading C<interp-E<gt>result>
+
+C<Tcl_GetResult(interp)>. I<Autoconverted>.
+
+=item C<interp-E<gt>result = Tk_PathName(textPtr-E<gt>tkwin);>
+
+C<Tk_WidgetResult(interp,textPtr-E<gt>tkwin)>. I<Autoconverted>.
+
+=item Sequence C<Tcl_PrintDouble, Tcl_PrintDouble, ..., Tcl_AppendResult>
+
+Use a single command
+
+ void Tcl_DoubleResults(Tcl_Interp *interp, int append,
+ int argc,...);
+
+C<append> governs whether it is required to clear the result first.
+
+A similar command for C<int> arguments is C<Tcl_IntResults>.
+
+=item C<Tcl_SplitList>
+
+Use C<Lang_SplitList> (see the description above).
+
+=back
+
+=head1 Translation back to TCL
+
+To use your B<portableTk> program with B<TCL>, put
+
+ #include "ptcl.h"
+
+I<before> inclusion of C<tk.h>, and link the resulting code with
+C<ptclGlue.c>.
+
+These files currently implement the following:
+
+=over 4
+
+=item Additional config types:
+
+ TK_CONFIG_CALLBACK
+ TK_CONFIG_LANGARG
+ TK_CONFIG_SCALARVAR
+ TK_CONFIG_HASHVAR
+ TK_CONFIG_ARRAYVAR
+ TK_CONFIG_IMAGE
+
+=item Types:
+
+ Var, Tcl_Obj *, LangCallback, LangFreeProc.
+
+=item Functions and macros:
+
+ Lang_SplitList, LangString, LangSetString, LangSetDefault,
+ LangSetInt, LangSetDouble Tcl_ArgResult, LangCallbackArg,
+ LangSaveVar, LangFreeVar,
+ LangFreeSplitProc, LangFreeArg, Tcl_DoubleResults, Tcl_IntResults,
+ LangDoCallback, Tk_WidgetResult, Tcl_CreateCommand,
+ Tcl_DeleteCommand, Tcl_GetResult.
+
+=back
+
+Current implementation contains enough to make it possible to compile
+C<mTk/tkText*.[ch]> with the virgin B<Tk>.
+
+=head2 New types of events ????
+
+PortableTk defines following new types of events:
+
+ TK_EVENTTYPE_NONE
+ TK_EVENTTYPE_STRING
+ TK_EVENTTYPE_NUMBER
+ TK_EVENTTYPE_WINDOW
+ TK_EVENTTYPE_ATOM
+ TK_EVENTTYPE_DISPLAY
+ TK_EVENTTYPE_DATA
+
+and a function
+
+ char * Tk_EventInfo(int letter,
+ Tk_Window tkwin, XEvent *eventPtr,
+ KeySym keySym, int *numPtr, int *isNum, int *type,
+ int num_size, char *numStorage)
+
+=head1 Checking for trouble
+
+If you start with working TCL code, you can start convertion using
+the above hints. Good indication that you are doing is OK is absence
+of C<sprintf> and C<sscanf> in your code (at least in the part that is
+working with interpreter).
+
+=head1 Additional API
+
+What is described here is not included into base B<portableTk>
+distribution. Currently it is coded in B<TCL> and as Perl macros (core
+is coded as functions, so theoretically you can use the same object
+files with different interpreted languages).
+
+=head2 C<ListFactory>
+
+Dynamic arrays in B<TCL> are used for two different purposes: to
+construct strings, and to construct lists. These two usages will have
+separate interfaces in other languages (since list is a different type
+from a string), so you should use a different interface in your code.
+
+The type for construction of dynamic lists is C<ListFactory>. The API
+below is a counterpart of the API for construction of dynamic lists
+in B<TCL>:
+
+ void ListFactoryInit(ListFactory *)
+ void ListFactoryFinish(ListFactory *)
+ void ListFactoryFree(ListFactory *)
+ Tcl_Obj * * ListFactoryArg(ListFactory *)
+ void ListFactoryAppend(ListFactory *, Tcl_Obj * *arg)
+ void ListFactoryAppendCopy(ListFactory *, Tcl_Obj * *arg)
+ ListFactory * ListFactoryNewLevel(ListFactory *)
+ ListFactory * ListFactoryEndLevel(ListFactory *)
+ void ListFactoryResult(Tcl_Interp *, ListFactory *)
+
+The difference is that a call to C<ListFactoryFinish> should precede the
+actual usage of the value of C<ListFactory>, and there are two
+different ways to append an C<Tcl_Obj *> to a C<ListFactory>:
+ListFactoryAppendCopy() guarantees that the value of C<arg> is copied
+to the list, but ListFactoryAppend() may append to the list a
+reference to the current value of C<arg>. If you are not going to change
+the value of C<arg> after appending, the call to ListFactoryAppend may
+be quicker.
+
+As in B<TCL>, the call to ListFactoryFree() does not free the
+C<ListFactory>, only the objects it references.
+
+The functions ListFactoryNewLevel() and ListFactoryEndLevel() return a
+pointer to a C<ListFactory> to fill. The argument of
+ListFactoryEndLevel() cannot be used after a call to this function.
+
+=head2 DStrings
+
+Production of strings are still supported in B<portableTk>.
+
+=head2 Accessing C<Tcl_Obj *>s
+
+The following functions for getting a value of an C<Tcl_Obj *> I<may> be
+provided:
+
+ double LangDouble(Tcl_Obj *)
+ int LangInt(Tcl_Obj *)
+ long LangLong(Tcl_Obj *)
+ int LangIsList(Tcl_Obj * arg)
+
+The function LangIsList() is supported only partially under B<TCL>,
+since there is no data types. It checks whether there is a space
+inside the string C<arg>.
+
+=head2 Assigning numbers to C<Tcl_Obj *>s
+
+While LangSetDouble() and LangSetInt() are supported ways to assign
+numbers to assign an integer value to a variable, for the sake of
+efficiency under B<TCL> it is supposed that the destination of these
+commands was massaged before the call so it contains a long enough
+string to sprintf() the numbers inside it. If you are going to
+immediately use the resulting C<Tcl_Obj *>, the best way to do this is to
+declare a buffer in the beginning of a block by
+
+ dArgBuffer;
+
+and assign this buffer to the C<Tcl_Obj *> by
+
+ void LangSetDefaultBuffer(Tcl_Obj * *)
+
+You can also create the buffer(s) manually and assign them using
+
+ void LangSetBuffer(Tcl_Obj * *, char *)
+
+This is the only choice if you need to assign numeric values to
+several C<Tcl_Obj *>s simultaneously. The advantage of the first approach is
+that the above declarations can be made C<nop>s in different languages.
+
+Note that if you apply C<LangSetDefaultBuffer> to an C<Tcl_Obj *> that
+contains some value, you can create a leak if you do not free that
+C<Tcl_Obj *> first. This is a non-problem in real languages, but can be a
+trouble in C<TCL>, unless you use only the above API.
+
+=head2 Creating new C<Tcl_Obj *>s
+
+The API for creating a new C<Tcl_Obj *> is
+
+ void LangNewArg(Tcl_Obj * *, LangFreeProc *)
+
+The API for creating a new C<Tcl_Obj *> is absent. Just initialize C<Tcl_Obj *> to
+be C<NULL>, and apply one of C<LangSet...> methods.
+
+After you use this C<Tcl_Obj *>, it should be freed thusly:
+
+C<LangFreeArg(arg, freeProc)>.
+
+=head2 Evaluating a list
+
+Use
+
+ int LangArgEval(Tcl_Interp *, Tcl_Obj * arg)
+
+Here C<arg> should be a list to evaluate, in particular, the first
+element should be a C<LangCallback> massaged to be an C<Tcl_Obj *>. The
+arguments can be send to the subroutine by reference or by value in
+different languages.
+
+=head2 Getting result as C<Tcl_Obj *>
+
+Use C<Tcl_ArgResult>. It is not guaranteed that result survives this
+operation, so the C<Tcl_Obj *> you get should be the only mean to access the
+data from this moment on. After you use this C<Tcl_Obj *>, you should free
+it with C<freeProc> C<LANG_DYNAMIC> (you can do LangSet...() in between).
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.h
new file mode 100755
index 00000000000..4598291f872
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.h
@@ -0,0 +1,206 @@
+#ifndef _LANG
+#define _LANG
+
+#define STATIC_BUILD
+
+
+#ifdef bool
+#undef bool
+#endif
+
+#include "tkConfig.h"
+#define TCL_NO_DEPRECATED
+
+#if !defined(WIN32) && defined(USE_XFT_FONTS)
+#ifndef TCL_UTF_MAX
+#define TCL_UTF_MAX 13
+#endif
+#endif
+
+#define USE_TCLALLOC 1
+#define TCL_MEM_DEBUG
+#define USE_COMPAT_CONST
+#include "tcl.h"
+
+#if !defined(__GNUC__) && !defined(_AIX)
+#ifdef __STDC__
+#ifndef STRINGIFY
+#define STRINGIFY(x) STRINGIFY1(x)
+#define STRINGIFY1(x) #x
+#endif /* STRINGIFY */
+#define __FUNCTION__ __FILE__ ":" STRINGIFY(__LINE__)
+#else /* STDC */
+#define __FUNCTION__ ""
+#endif /* STDC */
+#endif /* GNUC or AIX */
+
+EXTERN int Tcl_DStringLength _ANSI_ARGS_((Tcl_DString *dString));
+EXTERN char * Tcl_DStringValue _ANSI_ARGS_((Tcl_DString *dString));
+
+EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
+
+EXTERN Tcl_ObjType * TclObjGetType _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN int TclObjLength _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN void TclObjSetType _ANSI_ARGS_((Tcl_Obj *objPtr,Tcl_ObjType *newType));
+EXTERN Tcl_InternalRep * TclObjInternal _ANSI_ARGS_((Tcl_Obj *objPtr));
+
+#if defined(TCL_EVENT_IMPLEMENT) && !defined(Var)
+#include "mTk/tclGeneric/tclInt.h"
+#endif
+#if !defined(TCL_EVENT_IMPLEMENT) || defined(Var)
+#define _TCLINT
+typedef void *TclHandle;
+extern Tcl_ObjType tclIntType;
+#endif
+
+#ifndef Var
+#define Var Tcl_Obj *
+#endif
+#ifndef LangCallback
+#define LangCallback Tcl_Obj
+#endif
+#define LangStringArg(x) Tcl_NewStringObj(x,-1)
+
+#define XFree_arg_t void
+
+EXTERN void LangSetString _ANSI_ARGS_((Tcl_Obj **,CONST char *));
+EXTERN void LangSetDefault _ANSI_ARGS_((Tcl_Obj **,CONST char *));
+EXTERN void LangSetInt _ANSI_ARGS_((Tcl_Obj **,int));
+EXTERN void LangSetDouble _ANSI_ARGS_((Tcl_Obj **,double));
+EXTERN void LangSetObj _ANSI_ARGS_((Tcl_Obj **,Tcl_Obj *));
+EXTERN void LangSetVar _ANSI_ARGS_((Tcl_Obj **,Var));
+
+EXTERN int LangCmpArg _ANSI_ARGS_((CONST Tcl_Obj *,CONST Tcl_Obj *));
+EXTERN int LangCmpOpt _ANSI_ARGS_((CONST char *opt,CONST char *arg,size_t length));
+
+
+/* FIXME:
+ Tk will set freeProc as for Tcl e.g. NULL for statics & UIDs
+ and to "free" for Tcl_Merge etc.
+ Non Tk users *may* be able to use it as a guide,
+ but it is more likely that they will have to use
+ their own ref counts.
+ Perhaps Tcl_Merge should set freeProc and/or Tcl's
+ LangSetString() deliberately malloc() a copy of the string so we don't need
+ the freeProc
+*/
+EXTERN void LangFreeArg _ANSI_ARGS_((Tcl_Obj *,Tcl_FreeProc *freeProc));
+EXTERN Tcl_Obj *LangCopyArg _ANSI_ARGS_((Tcl_Obj *));
+
+EXTERN int LangNull _ANSI_ARGS_((Tcl_Obj *));
+
+EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
+EXTERN void TclpAsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
+
+EXTERN void Lang_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp,char *code));
+EXTERN char *Lang_GetErrorCode _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN char *Lang_GetErrorInfo _ANSI_ARGS_((Tcl_Interp *interp));
+
+/* Old-config handler for variables */
+EXTERN int LangSaveVar _ANSI_ARGS_((Tcl_Interp *,Tcl_Obj *,Var *,int type));
+EXTERN void LangFreeVar _ANSI_ARGS_((Var));
+
+/* New-config handler for objects, variables and callbacks */
+EXTERN int LangConfigObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj **save,
+ Tcl_Obj *obj, int type));
+
+EXTERN int LangEventHook _ANSI_ARGS_((int flags));
+EXTERN void Lang_BuildInImages _ANSI_ARGS_((void));
+EXTERN void * TclCalloc _ANSI_ARGS_((size_t n,size_t s));
+EXTERN void LangDebug _ANSI_ARGS_((CONST char *fmt,...));
+EXTERN void LangDumpVec _ANSI_ARGS_((CONST char *tag, int argc, Tcl_Obj **vec));
+
+EXTERN void Lang_DeleteObject _ANSI_ARGS_((Tcl_Interp *,Tcl_Command));
+EXTERN Tcl_Command Lang_CreateObject _ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName, Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc));
+
+EXTERN int Lang_CallWithArgs _ANSI_ARGS_ ((Tcl_Interp *interp,
+ char *sub, int argc, Tcl_Obj *CONST *argv));
+
+EXTERN void Tcl_IntResults _ANSI_ARGS_((Tcl_Interp *interp,int,int,...));
+EXTERN void Tcl_DoubleResults _ANSI_ARGS_((Tcl_Interp *interp,int,int,...));
+EXTERN void Tcl_SprintfResult _ANSI_ARGS_((Tcl_Interp *,char *,...));
+
+
+
+EXTERN int LangDoCallback _ANSI_ARGS_((Tcl_Interp *,LangCallback *,int result,int argc,...));
+EXTERN int LangMethodCall _ANSI_ARGS_((Tcl_Interp *,Tcl_Obj *,char *,int result,int argc,...));
+
+EXTERN char *LangLibraryDir _ANSI_ARGS_((void));
+EXTERN void Lang_SetBinaryResult _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, int len, Tcl_FreeProc *freeProc));
+EXTERN Tcl_ObjCmdProc *LangOptionCommand;
+
+typedef char *(Lang_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tcl_Obj *part1, CONST char *part2, int flags));
+
+EXTERN Tcl_Encoding Lang_CreateEncoding _ANSI_ARGS_((
+ CONST char *encodingName,
+ Tcl_EncodingConvertProc *toUtfProc,
+ Tcl_EncodingConvertProc *fromUtfProc,
+ Tcl_EncodingFreeProc *freeProc,
+ ClientData clientData,
+ int nullSize));
+
+EXTERN int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+
+EXTERN int Lang_TraceVar _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *varRef, int flags,
+ Lang_VarTraceProc * proc,
+ ClientData clientData));
+
+EXTERN void Lang_UntraceVar _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * varRef, int flags,
+ Lang_VarTraceProc * proc,
+ ClientData clientData));
+
+EXTERN int Tk_PropertyCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj **objv));
+
+struct TkFontAttributes;
+
+EXTERN unsigned int LangFontRank _ANSI_ARGS_((unsigned int suggested,
+ int ch, CONST char *gotName,
+ CONST char *wantFoundary,
+ CONST struct TkFontAttributes *wantAttrib,
+ CONST char *wantEncoding,
+ CONST char *gotFoundary,
+ CONST struct TkFontAttributes *gotAttrib,
+ CONST char *gotEncoding));
+
+EXTERN void Lang_FreeRegExp _ANSI_ARGS_((Tcl_RegExp re));
+
+EXTERN long Lang_OSHandle _ANSI_ARGS_((int fd));
+#define TK_LIBRARY LangLibraryDir()
+
+#ifdef WIN32
+#ifdef __BORLANDC__
+#pragma warn -par /* "parameter 'foo' is never used" */
+#pragma warn -aus /* "'foo' is assigned a value that is never used" */
+#pragma warn -use /* "'foo' is declared but never used" */
+#endif
+
+#ifdef _MSC_VER
+#pragma warning(disable:4101 4102 4244 4018)
+#pragma warning(disable:4133) /* init incompatible for xlib */
+#endif
+#endif
+
+#ifndef RC_INVOKED
+#include "tkEvent.h"
+#if !defined(TCL_EVENT_IMPLEMENT)
+#include "tkEvent.m"
+#endif
+#endif
+
+#endif /* _LANG */
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.m
new file mode 100755
index 00000000000..a7a43aebd54
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.m
@@ -0,0 +1,192 @@
+#ifndef _LANG_VM
+#define _LANG_VM
+#include "Lang_f.h"
+#ifndef NO_VTABLES
+#define LangOptionCommand (*LangVptr->V_LangOptionCommand)
+#define tclIntType (*LangVptr->V_tclIntType)
+#ifndef LangCmpArg
+# define LangCmpArg (*LangVptr->V_LangCmpArg)
+#endif
+
+#ifndef LangCmpOpt
+# define LangCmpOpt (*LangVptr->V_LangCmpOpt)
+#endif
+
+#ifndef LangConfigObj
+# define LangConfigObj (*LangVptr->V_LangConfigObj)
+#endif
+
+#ifndef LangCopyArg
+# define LangCopyArg (*LangVptr->V_LangCopyArg)
+#endif
+
+#ifndef LangDoCallback
+# define LangDoCallback (*LangVptr->V_LangDoCallback)
+#endif
+
+#ifndef LangDumpVec
+# define LangDumpVec (*LangVptr->V_LangDumpVec)
+#endif
+
+#ifndef LangEventHook
+# define LangEventHook (*LangVptr->V_LangEventHook)
+#endif
+
+#ifndef LangFontRank
+# define LangFontRank (*LangVptr->V_LangFontRank)
+#endif
+
+#ifndef LangFreeArg
+# define LangFreeArg (*LangVptr->V_LangFreeArg)
+#endif
+
+#ifndef LangFreeVar
+# define LangFreeVar (*LangVptr->V_LangFreeVar)
+#endif
+
+#ifndef LangLibraryDir
+# define LangLibraryDir (*LangVptr->V_LangLibraryDir)
+#endif
+
+#ifndef LangMethodCall
+# define LangMethodCall (*LangVptr->V_LangMethodCall)
+#endif
+
+#ifndef LangNull
+# define LangNull (*LangVptr->V_LangNull)
+#endif
+
+#ifndef LangSaveVar
+# define LangSaveVar (*LangVptr->V_LangSaveVar)
+#endif
+
+#ifndef LangSetDefault
+# define LangSetDefault (*LangVptr->V_LangSetDefault)
+#endif
+
+#ifndef LangSetDouble
+# define LangSetDouble (*LangVptr->V_LangSetDouble)
+#endif
+
+#ifndef LangSetInt
+# define LangSetInt (*LangVptr->V_LangSetInt)
+#endif
+
+#ifndef LangSetObj
+# define LangSetObj (*LangVptr->V_LangSetObj)
+#endif
+
+#ifndef LangSetString
+# define LangSetString (*LangVptr->V_LangSetString)
+#endif
+
+#ifndef LangSetVar
+# define LangSetVar (*LangVptr->V_LangSetVar)
+#endif
+
+#ifndef Lang_BuildInImages
+# define Lang_BuildInImages (*LangVptr->V_Lang_BuildInImages)
+#endif
+
+#ifndef Lang_CallWithArgs
+# define Lang_CallWithArgs (*LangVptr->V_Lang_CallWithArgs)
+#endif
+
+#ifndef Lang_CreateEncoding
+# define Lang_CreateEncoding (*LangVptr->V_Lang_CreateEncoding)
+#endif
+
+#ifndef Lang_CreateObject
+# define Lang_CreateObject (*LangVptr->V_Lang_CreateObject)
+#endif
+
+#ifndef Lang_DeleteObject
+# define Lang_DeleteObject (*LangVptr->V_Lang_DeleteObject)
+#endif
+
+#ifndef Lang_FreeRegExp
+# define Lang_FreeRegExp (*LangVptr->V_Lang_FreeRegExp)
+#endif
+
+#ifndef Lang_GetErrorCode
+# define Lang_GetErrorCode (*LangVptr->V_Lang_GetErrorCode)
+#endif
+
+#ifndef Lang_GetErrorInfo
+# define Lang_GetErrorInfo (*LangVptr->V_Lang_GetErrorInfo)
+#endif
+
+#ifndef Lang_SetBinaryResult
+# define Lang_SetBinaryResult (*LangVptr->V_Lang_SetBinaryResult)
+#endif
+
+#ifndef Lang_SetErrorCode
+# define Lang_SetErrorCode (*LangVptr->V_Lang_SetErrorCode)
+#endif
+
+#ifndef Lang_TraceVar
+# define Lang_TraceVar (*LangVptr->V_Lang_TraceVar)
+#endif
+
+#ifndef Lang_UntraceVar
+# define Lang_UntraceVar (*LangVptr->V_Lang_UntraceVar)
+#endif
+
+#ifndef TclObjGetType
+# define TclObjGetType (*LangVptr->V_TclObjGetType)
+#endif
+
+#ifndef TclObjInternal
+# define TclObjInternal (*LangVptr->V_TclObjInternal)
+#endif
+
+#ifndef TclObjLength
+# define TclObjLength (*LangVptr->V_TclObjLength)
+#endif
+
+#ifndef TclObjSetType
+# define TclObjSetType (*LangVptr->V_TclObjSetType)
+#endif
+
+#ifndef Tcl_AfterObjCmd
+# define Tcl_AfterObjCmd (*LangVptr->V_Tcl_AfterObjCmd)
+#endif
+
+#ifndef Tcl_DStringLength
+# define Tcl_DStringLength (*LangVptr->V_Tcl_DStringLength)
+#endif
+
+#ifndef Tcl_DStringValue
+# define Tcl_DStringValue (*LangVptr->V_Tcl_DStringValue)
+#endif
+
+#ifndef Tcl_DecrRefCount
+# define Tcl_DecrRefCount (*LangVptr->V_Tcl_DecrRefCount)
+#endif
+
+#ifndef Tcl_DoubleResults
+# define Tcl_DoubleResults (*LangVptr->V_Tcl_DoubleResults)
+#endif
+
+#ifndef Tcl_IncrRefCount
+# define Tcl_IncrRefCount (*LangVptr->V_Tcl_IncrRefCount)
+#endif
+
+#ifndef Tcl_IntResults
+# define Tcl_IntResults (*LangVptr->V_Tcl_IntResults)
+#endif
+
+#ifndef Tcl_IsShared
+# define Tcl_IsShared (*LangVptr->V_Tcl_IsShared)
+#endif
+
+#ifndef Tcl_SprintfResult
+# define Tcl_SprintfResult (*LangVptr->V_Tcl_SprintfResult)
+#endif
+
+#ifndef Tk_PropertyCmd
+# define Tk_PropertyCmd (*LangVptr->V_Tk_PropertyCmd)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _LANG_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.t
new file mode 100755
index 00000000000..030a20c1174
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang.t
@@ -0,0 +1,217 @@
+#ifdef _LANG
+VVAR(Tcl_ObjCmdProc *,LangOptionCommand,V_LangOptionCommand)
+#if !defined(TCL_EVENT_IMPLEMENT) || defined(Var)
+VVAR(Tcl_ObjType,tclIntType,V_tclIntType)
+#endif /* #if !defined(TCL_EVENT_IMPLEMENT) || defined(Var) */
+#ifndef LangCmpArg
+VFUNC(int,LangCmpArg,V_LangCmpArg,_ANSI_ARGS_((CONST Tcl_Obj *,CONST Tcl_Obj *)))
+#endif /* #ifndef LangCmpArg */
+
+#ifndef LangCmpOpt
+VFUNC(int,LangCmpOpt,V_LangCmpOpt,_ANSI_ARGS_((CONST char *opt,CONST char *arg,size_t length)))
+#endif /* #ifndef LangCmpOpt */
+
+#ifndef LangConfigObj
+VFUNC(int,LangConfigObj,V_LangConfigObj,_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj **save,
+ Tcl_Obj *obj, int type)))
+#endif /* #ifndef LangConfigObj */
+
+#ifndef LangCopyArg
+VFUNC(Tcl_Obj *,LangCopyArg,V_LangCopyArg,_ANSI_ARGS_((Tcl_Obj *)))
+#endif /* #ifndef LangCopyArg */
+
+#ifndef LangDoCallback
+VFUNC(int,LangDoCallback,V_LangDoCallback,_ANSI_ARGS_((Tcl_Interp *,LangCallback *,int result,int argc,...)))
+#endif /* #ifndef LangDoCallback */
+
+#ifndef LangDumpVec
+VFUNC(void,LangDumpVec,V_LangDumpVec,_ANSI_ARGS_((CONST char *tag, int argc, Tcl_Obj **vec)))
+#endif /* #ifndef LangDumpVec */
+
+#ifndef LangEventHook
+VFUNC(int,LangEventHook,V_LangEventHook,_ANSI_ARGS_((int flags)))
+#endif /* #ifndef LangEventHook */
+
+#ifndef LangFontRank
+VFUNC(unsigned int,LangFontRank,V_LangFontRank,_ANSI_ARGS_((unsigned int suggested,
+ int ch, CONST char *gotName,
+ CONST char *wantFoundary,
+ CONST struct TkFontAttributes *wantAttrib,
+ CONST char *wantEncoding,
+ CONST char *gotFoundary,
+ CONST struct TkFontAttributes *gotAttrib,
+ CONST char *gotEncoding)))
+#endif /* #ifndef LangFontRank */
+
+#ifndef LangFreeArg
+VFUNC(void,LangFreeArg,V_LangFreeArg,_ANSI_ARGS_((Tcl_Obj *,Tcl_FreeProc *freeProc)))
+#endif /* #ifndef LangFreeArg */
+
+#ifndef LangFreeVar
+VFUNC(void,LangFreeVar,V_LangFreeVar,_ANSI_ARGS_((Var)))
+#endif /* #ifndef LangFreeVar */
+
+#ifndef LangLibraryDir
+VFUNC(char *,LangLibraryDir,V_LangLibraryDir,_ANSI_ARGS_((void)))
+#endif /* #ifndef LangLibraryDir */
+
+#ifndef LangMethodCall
+VFUNC(int,LangMethodCall,V_LangMethodCall,_ANSI_ARGS_((Tcl_Interp *,Tcl_Obj *,char *,int result,int argc,...)))
+#endif /* #ifndef LangMethodCall */
+
+#ifndef LangNull
+VFUNC(int,LangNull,V_LangNull,_ANSI_ARGS_((Tcl_Obj *)))
+#endif /* #ifndef LangNull */
+
+#ifndef LangSaveVar
+VFUNC(int,LangSaveVar,V_LangSaveVar,_ANSI_ARGS_((Tcl_Interp *,Tcl_Obj *,Var *,int type)))
+#endif /* #ifndef LangSaveVar */
+
+#ifndef LangSetDefault
+VFUNC(void,LangSetDefault,V_LangSetDefault,_ANSI_ARGS_((Tcl_Obj **,CONST char *)))
+#endif /* #ifndef LangSetDefault */
+
+#ifndef LangSetDouble
+VFUNC(void,LangSetDouble,V_LangSetDouble,_ANSI_ARGS_((Tcl_Obj **,double)))
+#endif /* #ifndef LangSetDouble */
+
+#ifndef LangSetInt
+VFUNC(void,LangSetInt,V_LangSetInt,_ANSI_ARGS_((Tcl_Obj **,int)))
+#endif /* #ifndef LangSetInt */
+
+#ifndef LangSetObj
+VFUNC(void,LangSetObj,V_LangSetObj,_ANSI_ARGS_((Tcl_Obj **,Tcl_Obj *)))
+#endif /* #ifndef LangSetObj */
+
+#ifndef LangSetString
+VFUNC(void,LangSetString,V_LangSetString,_ANSI_ARGS_((Tcl_Obj **,CONST char *)))
+#endif /* #ifndef LangSetString */
+
+#ifndef LangSetVar
+VFUNC(void,LangSetVar,V_LangSetVar,_ANSI_ARGS_((Tcl_Obj **,Var)))
+#endif /* #ifndef LangSetVar */
+
+#ifndef Lang_BuildInImages
+VFUNC(void,Lang_BuildInImages,V_Lang_BuildInImages,_ANSI_ARGS_((void)))
+#endif /* #ifndef Lang_BuildInImages */
+
+#ifndef Lang_CallWithArgs
+VFUNC(int,Lang_CallWithArgs,V_Lang_CallWithArgs,_ANSI_ARGS_((Tcl_Interp *interp,
+ char *sub, int argc, Tcl_Obj *CONST *argv)))
+#endif /* #ifndef Lang_CallWithArgs */
+
+#ifndef Lang_CreateEncoding
+VFUNC(Tcl_Encoding,Lang_CreateEncoding,V_Lang_CreateEncoding,_ANSI_ARGS_((
+ CONST char *encodingName,
+ Tcl_EncodingConvertProc *toUtfProc,
+ Tcl_EncodingConvertProc *fromUtfProc,
+ Tcl_EncodingFreeProc *freeProc,
+ ClientData clientData,
+ int nullSize)))
+#endif /* #ifndef Lang_CreateEncoding */
+
+#ifndef Lang_CreateObject
+VFUNC(Tcl_Command,Lang_CreateObject,V_Lang_CreateObject,_ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName, Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc)))
+#endif /* #ifndef Lang_CreateObject */
+
+#ifndef Lang_DeleteObject
+VFUNC(void,Lang_DeleteObject,V_Lang_DeleteObject,_ANSI_ARGS_((Tcl_Interp *,Tcl_Command)))
+#endif /* #ifndef Lang_DeleteObject */
+
+#ifndef Lang_FreeRegExp
+VFUNC(void,Lang_FreeRegExp,V_Lang_FreeRegExp,_ANSI_ARGS_((Tcl_RegExp re)))
+#endif /* #ifndef Lang_FreeRegExp */
+
+#ifndef Lang_GetErrorCode
+VFUNC(char *,Lang_GetErrorCode,V_Lang_GetErrorCode,_ANSI_ARGS_((Tcl_Interp *interp)))
+#endif /* #ifndef Lang_GetErrorCode */
+
+#ifndef Lang_GetErrorInfo
+VFUNC(char *,Lang_GetErrorInfo,V_Lang_GetErrorInfo,_ANSI_ARGS_((Tcl_Interp *interp)))
+#endif /* #ifndef Lang_GetErrorInfo */
+
+#ifndef Lang_SetBinaryResult
+VFUNC(void,Lang_SetBinaryResult,V_Lang_SetBinaryResult,_ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, int len, Tcl_FreeProc *freeProc)))
+#endif /* #ifndef Lang_SetBinaryResult */
+
+#ifndef Lang_SetErrorCode
+VFUNC(void,Lang_SetErrorCode,V_Lang_SetErrorCode,_ANSI_ARGS_((Tcl_Interp *interp,char *code)))
+#endif /* #ifndef Lang_SetErrorCode */
+
+#ifndef Lang_TraceVar
+VFUNC(int,Lang_TraceVar,V_Lang_TraceVar,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *varRef, int flags,
+ Lang_VarTraceProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Lang_TraceVar */
+
+#ifndef Lang_UntraceVar
+VFUNC(void,Lang_UntraceVar,V_Lang_UntraceVar,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * varRef, int flags,
+ Lang_VarTraceProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Lang_UntraceVar */
+
+#ifndef TclObjGetType
+VFUNC(Tcl_ObjType *,TclObjGetType,V_TclObjGetType,_ANSI_ARGS_((Tcl_Obj *objPtr)))
+#endif /* #ifndef TclObjGetType */
+
+#ifndef TclObjInternal
+VFUNC(Tcl_InternalRep *,TclObjInternal,V_TclObjInternal,_ANSI_ARGS_((Tcl_Obj *objPtr)))
+#endif /* #ifndef TclObjInternal */
+
+#ifndef TclObjLength
+VFUNC(int,TclObjLength,V_TclObjLength,_ANSI_ARGS_((Tcl_Obj *objPtr)))
+#endif /* #ifndef TclObjLength */
+
+#ifndef TclObjSetType
+VFUNC(void,TclObjSetType,V_TclObjSetType,_ANSI_ARGS_((Tcl_Obj *objPtr,Tcl_ObjType *newType)))
+#endif /* #ifndef TclObjSetType */
+
+#ifndef Tcl_AfterObjCmd
+VFUNC(int,Tcl_AfterObjCmd,V_Tcl_AfterObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tcl_AfterObjCmd */
+
+#ifndef Tcl_DStringLength
+VFUNC(int,Tcl_DStringLength,V_Tcl_DStringLength,_ANSI_ARGS_((Tcl_DString *dString)))
+#endif /* #ifndef Tcl_DStringLength */
+
+#ifndef Tcl_DStringValue
+VFUNC(char *,Tcl_DStringValue,V_Tcl_DStringValue,_ANSI_ARGS_((Tcl_DString *dString)))
+#endif /* #ifndef Tcl_DStringValue */
+
+#ifndef Tcl_DecrRefCount
+VFUNC(void,Tcl_DecrRefCount,V_Tcl_DecrRefCount,_ANSI_ARGS_((Tcl_Obj *objPtr)))
+#endif /* #ifndef Tcl_DecrRefCount */
+
+#ifndef Tcl_DoubleResults
+VFUNC(void,Tcl_DoubleResults,V_Tcl_DoubleResults,_ANSI_ARGS_((Tcl_Interp *interp,int,int,...)))
+#endif /* #ifndef Tcl_DoubleResults */
+
+#ifndef Tcl_IncrRefCount
+VFUNC(void,Tcl_IncrRefCount,V_Tcl_IncrRefCount,_ANSI_ARGS_((Tcl_Obj *objPtr)))
+#endif /* #ifndef Tcl_IncrRefCount */
+
+#ifndef Tcl_IntResults
+VFUNC(void,Tcl_IntResults,V_Tcl_IntResults,_ANSI_ARGS_((Tcl_Interp *interp,int,int,...)))
+#endif /* #ifndef Tcl_IntResults */
+
+#ifndef Tcl_IsShared
+VFUNC(int,Tcl_IsShared,V_Tcl_IsShared,_ANSI_ARGS_((Tcl_Obj *objPtr)))
+#endif /* #ifndef Tcl_IsShared */
+
+#ifndef Tcl_SprintfResult
+VFUNC(void,Tcl_SprintfResult,V_Tcl_SprintfResult,_ANSI_ARGS_((Tcl_Interp *,char *,...)))
+#endif /* #ifndef Tcl_SprintfResult */
+
+#ifndef Tk_PropertyCmd
+VFUNC(int,Tk_PropertyCmd,V_Tk_PropertyCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj **objv)))
+#endif /* #ifndef Tk_PropertyCmd */
+
+#endif /* _LANG */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang_f.h
new file mode 100755
index 00000000000..37058e76411
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Lang_f.h
@@ -0,0 +1,14 @@
+#ifndef LANG_VT
+#define LANG_VT
+typedef struct LangVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "Lang.t"
+#undef VFUNC
+#undef VVAR
+} LangVtab;
+extern LangVtab *LangVptr;
+extern LangVtab *LangVGet(void);
+#endif /* LANG_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Tcl-pTk b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Tcl-pTk
new file mode 100755
index 00000000000..cc72e16b6c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Tcl-pTk
@@ -0,0 +1,260 @@
+#!/usr/local/bin/perl -w
+use open IO => ':bytes'; # Avoid UTF-8 issues with some perl5.8.0 (RedHat)
+use Carp;
+my $verbose = 0;
+
+$SIG{'__WARN__'} = sub { print STDERR $_; Carp::confess(shift) };
+
+$src = shift;
+$dst = shift;
+
+die "Usage: $0 <src> <dst> \n" unless (defined $src and defined $dst);
+
+chmod(0666, $dst);
+chmod(0666, "$dst~");
+unlink($dst);
+open(DST,">$dst~") || die "Cannot open $dst~: $!";
+select(DST);
+
+my $copyright;
+
+@ARGV = ($src);
+
+undef $undone;
+
+sub getline
+{
+ local $_;
+ if (defined $undone)
+ {
+ $_ = $undone;
+ undef $undone;
+ }
+ else
+ {
+ $_ = <>;
+ }
+ return $_;
+}
+
+sub int_results
+{my $fmt = shift;
+ my $type = shift;
+ my @fmt = split(/\s+/,$fmt);
+ my $cnt = @fmt;
+ # print STDERR "'$fmt' => $cnt\n";
+ return "Tcl_${type}Results(interp,$cnt,0";
+}
+
+sub result
+{my ($interp,$value,$tail) = @_;
+ my $line = &getline;
+ my $kind = "TCL_STATIC";
+ if (defined $line)
+ {
+ if ($line =~ /^\s*$interp\s*->\s*freeProc\s*=\s*(.*)\s*;\s*$/)
+ {
+ $kind = $1;
+ }
+ else
+ {
+ $undone = $line if (defined $line);
+ }
+ }
+ return "Tcl_SetResult($interp,$value,$kind)$tail";
+}
+
+sub complete
+{
+ my $tail = "";
+ until (/;/)
+ {
+ my $line = &getline;
+ last unless defined($line);
+ s/\s*$//;
+ $line =~ s/^\s*//;
+ $_ .= " " . $line;
+ $tail .= "\n";
+ }
+ $_ .= $tail;
+}
+
+#use Carp;
+#$SIG{'INT'} = sub { Carp::confess($_) };
+
+
+PROCESS:
+while ($_ = &getline)
+ {
+ s/^\s*#\s*include\s*[<"]tcl\.h[">]\s*$/#include "Lang.h"\n/;
+
+ s/^\s*#\s*include\s*<((tk|tkInt|tkPort|tix|tixInt)\.h)>\s*$/#include "$1"\n/;
+
+ next if (/^\s*extern.*\bpanic\s*\(/);
+
+ s/\(char\s*\*\)\s*NULL\b/ NULL/g;
+
+ if (/^#(define|ifn?def|endif)\b/)
+ {
+ print;
+ while (/\\$/)
+ {
+ $_ = &getline;
+ print;
+ }
+ next;
+ }
+
+ if (m#^ */\*# && !m#\*/#)
+ {
+ print;
+ while (!m#\*/#)
+ {
+ $_ = &getline;
+ print;
+ }
+ next;
+ }
+
+ s/tclStubs\.t(\w+)/TkeventVptr->V_T$1/;
+
+ s/\bpanic\b/Tcl_Panic/g;
+
+ s/\b(\w+Ptr)->internalRep\./TclObjInternal($1)->/g;
+
+ s/(\w+bjPtr)->typePtr\s*=\s*(.*);/TclObjSetType($1,$2);/g;
+
+ s/\b(\w*bjPtr)->typePtr\b/TclObjGetType($1)/g;
+
+ if (/if\s*\(\(c == '.'\)\s*$/)
+ {
+ my $line = &getline;
+ if (defined($line))
+ {
+ s/\s*$//;
+ $line =~ s/^\s*//;
+ $_ .= " " . $line . "\n";
+ }
+ }
+
+ if (/Tcl_DeleteCommandFromToken/)
+ {
+ if (/Tcl_DeleteCommandFromToken[^;{]*$/)
+ {
+ &complete;
+ redo PROCESS;
+ }
+ s/Tcl_DeleteCommandFromToken(.*imageCmd)/Lang_DeleteObject$1/;
+ s/Tcl_DeleteCommandFromToken(.*widgetCmd)/Lang_DeleteWidget$1/;
+ }
+
+ if (/Tcl_(Create|Delete)Command/)
+ {
+ if (/Tcl_(Create|Delete)Command[^;{]*$/)
+ {
+ &complete;
+ redo PROCESS;
+ }
+ s/Tcl_CreateCommand\s*\(\s*((\w+->)*interp)\s*,\s*Tk_PathName\s*\(([^\)]+)\)/Lang_CreateWidget($1,$3/;
+ s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->(\w+\.style|image)Cmd)\)/Lang_DeleteObject($1,$4/;
+ s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->widgetCmd)\)/Lang_DeleteWidget($1,$4/;
+ }
+
+ s/\(char \*\*\)\s*objv\b/objv/g;
+
+# s/Tcl_Obj\s+\*(CONST\s+)?objv\b/Tcl_Obj *objv/;
+ if (/\bargv\w*\b/)
+ {
+ if (/\bargv\w*\s*\[([^[]*)\]\s*=[^=][^;{]*$/)
+ {
+ &complete;
+ redo PROCESS;
+ }
+ s/Tcl_Obj\s+\*(CONST\s+)?argv\b/Tcl_Obj *objv/;
+ if (/\bchar\b.*\bargv\w*\b/)
+ {
+ # convert char *argv[] to char **argv
+ s/char\s*\*\s*\bargv\s*\[\s*\]/char **argv/;
+ # convert char **argv to Tcl_Obj **objv
+ s/(CONST\s+)?char\s*\*\*\s*\bargv\b/Tcl_Obj *CONST *objv/;
+ # convert char *argv[n] to Tcl_Obj **objv = LangAllocVec(n)
+ s/char\s*\*\s*\bargv\s*\[\s*([^[]+)\]/Tcl_Obj **objv = LangAllocVec($1)/;
+ }
+ else
+ {
+ s/([^*])\*(argv\w*(\[[^[]*\])?)/${1}${2}[0]/g;
+ }
+ s/\(Tcl_Obj\s\*\)\s*argv\b/objv/g;
+ s/\bargv\s*\[([^[]*)\]\s*=([^=].*);\s*$/LangSetString(objv+$1,$2);\n/;
+ s/\bargv\s*\[([^[]*)\]\+\+/objv[$1] = Tcl_NewStringObj(Tcl_GetString(objv[$1])+1,-1)/;
+ s/\bargv\s*\[([^[]*)\]\+([0-9])/Tcl_NewStringObj(Tcl_GetString(objv[$1])+$2,-1)/;
+ if (/Tcl_Get(Boolean|Int|Double)/ || /Tk_Get(Cursor)/)
+ {
+ s/\bargv(\w*)\b/objv$1/g;
+ }
+ s/\bargv\s*(\[[^[]*\])/Tcl_GetString(objv$1)/g;
+ if (/\bargv\b/)
+ {
+ warn "Leak: $_" if ($verbose && !/\bargv\s*\)/);
+ s/\bargv\b/objv/;
+ }
+ }
+ if (/->\s*result\b/)
+ {
+ s/\s*->\s*result\b/->result/g;
+
+ s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%d)+)"/&int_results($1,"Int")/e;
+
+ s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%g)+)"/&int_results($1,"Double")/e;
+
+ s/\bsprintf\s*\(\s*interp->result\b/Tcl_SprintfResult(interp/;
+ if (/\binterp->result\s*=[^;]*$/)
+ {
+ &complete;
+ redo PROCESS;
+ }
+ s/\b((\w+\s*->\s*)*interp)->result\s*=([^;]*);/&result($1,$3,";")/e;
+ s/\b((\w+\s*->\s*)*interp)->result\s*=(.*);\s*$/&result($1,$3,";\n")/e;
+ s/\b((\w+\s*->\s*)*interp)->result/Tcl_GetResult($1)/;
+ }
+
+ if (/\bTcl_SetResult\s*\(/)
+ {
+ if (/Tcl_SetResult\s*\([^;{]*$/)
+ {
+ &complete;
+ redo PROCESS;
+ }
+ s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*"(\d+)",\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1, Tcl_NewIntObj($3))/;
+ s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*Tk_PathName\(([^)]+)\),\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,$3))/;
+ s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*((\w+->)*\w+)->pathName\s*,\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,(Tk_Window)($3)))/;
+ die $_ if /(Tk_PathName|->pathName)/;
+ }
+# 1 2 3 4 5 6
+ s/\(c == '(.)'\)\s*&&\s*(\(?)\(strncmp\(([^,]+),\s*("-\1[^"]*"),\s*(\w+|strlen\(\3\))\s*\)\s*==\s*0\)(\)?)/(c == '$1') && $2 LangCmpOpt($4,$3,$5) == 0 $6/g;
+ s/\(c == '(.)'\)\s*&&\s*\(strcmp\(([^,]+),\s*("-\1[^"]*")\s*\)\s*==\s*0\)/(c == '$1') && LangCmpOpt($3,$2,0) == 0/g;
+
+ if (defined($copyright) && !/^\s\*\s*Copyright/)
+ {
+ print $copyright;
+ undef $copyright;
+ }
+
+ s/[^\S\n]+$//;
+ print;
+
+ if (0 && /^((\s\*)\s*)Copyright/)
+ {
+ $copyright = "$2\n$1Modifications Copyright (c) 1994-2003 Nick Ing-Simmons\n";
+ }
+ }
+
+select(STDOUT);
+close(DST) or die "While writing to $dst~: $!";
+
+rename "$dst~", $dst or die "Could not rename $dst~ to $dst: $!";
+
+chmod(0444,$dst);
+
+exit 0;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.h
new file mode 100755
index 00000000000..1cfc929fc71
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.h
@@ -0,0 +1,149 @@
+#ifndef _XLIB
+#define _XLIB
+#ifndef _XLIB_H_
+extern XFontStruct *XLoadQueryFont _ANSI_ARGS_((Display *, const char *));
+extern XModifierKeymap *XGetModifierMapping _ANSI_ARGS_((Display *));
+extern XImage *XCreateImage _ANSI_ARGS_((Display *, Visual *, unsigned int, int, int, char *, unsigned int, unsigned int, int, int));
+extern XImage *XGetImage _ANSI_ARGS_((Display *, Drawable, int, int, unsigned int, unsigned int, long unsigned int, int));
+extern Display *XOpenDisplay _ANSI_ARGS_((const char *));
+extern char *XGetAtomName _ANSI_ARGS_((Display *, Atom));
+extern char *XKeysymToString _ANSI_ARGS_((KeySym));
+extern Atom XInternAtom _ANSI_ARGS_((Display *, const char *, int));
+extern Colormap XCreateColormap _ANSI_ARGS_((Display *, Window, Visual *, int));
+extern Cursor XCreatePixmapCursor _ANSI_ARGS_((Display *, Pixmap, Pixmap, XColor *, XColor *, unsigned int, unsigned int));
+extern Cursor XCreateGlyphCursor _ANSI_ARGS_((Display *, Font, Font, unsigned int, unsigned int, XColor const *, XColor const *));
+extern Font XLoadFont _ANSI_ARGS_((Display *, const char *));
+extern GC XCreateGC _ANSI_ARGS_((Display *, Drawable, long unsigned int, XGCValues *));
+extern GContext XGContextFromGC _ANSI_ARGS_((GC));
+extern Pixmap XCreateBitmapFromData _ANSI_ARGS_((Display *, Drawable, const char *, unsigned int, unsigned int));
+extern Window XCreateWindow _ANSI_ARGS_((Display *, Window, int, int, unsigned int, unsigned int, unsigned int, int, unsigned int, Visual *, long unsigned int, XSetWindowAttributes *));
+extern Atom *XListProperties _ANSI_ARGS_((Display *, Window, int *));
+extern XHostAddress *XListHosts _ANSI_ARGS_((Display *, int *, int *));
+extern KeySym XKeycodeToKeysym _ANSI_ARGS_((Display *, unsigned int, int));
+extern KeySym XStringToKeysym _ANSI_ARGS_((const char *));
+extern VisualID XVisualIDFromVisual _ANSI_ARGS_((Visual *));
+extern Window XRootWindow _ANSI_ARGS_((Display *, int));
+extern Visual *XDefaultVisual _ANSI_ARGS_((Display *, int));
+extern Colormap XDefaultColormap _ANSI_ARGS_((Display *, int));
+extern XErrorHandler XSetErrorHandler _ANSI_ARGS_((XErrorHandler));
+extern int XIconifyWindow _ANSI_ARGS_((Display *, Window, int));
+extern int XWithdrawWindow _ANSI_ARGS_((Display *, Window, int));
+extern int XGetWMColormapWindows _ANSI_ARGS_((Display *, Window, Window **, int *));
+extern int XSetWMColormapWindows _ANSI_ARGS_((Display *, Window, Window *, int));
+extern int XSetTransientForHint _ANSI_ARGS_((Display *, Window, Window));
+extern int XAllocColor _ANSI_ARGS_((Display *, Colormap, XColor *));
+extern int XAllocNamedColor _ANSI_ARGS_((Display *, Colormap, const char *, XColor *, XColor *));
+extern int XBell _ANSI_ARGS_((Display *, int));
+extern int XChangeProperty _ANSI_ARGS_((Display *, Window, Atom, Atom, int, int, const unsigned char *, int));
+extern int XChangeWindowAttributes _ANSI_ARGS_((Display *, Window, long unsigned int, XSetWindowAttributes *));
+extern int XCheckIfEvent _ANSI_ARGS_((Display *, XEvent *, int (*) (Display *, XEvent *, char *), char *));
+extern int XCheckWindowEvent _ANSI_ARGS_((Display *, Window, long int, XEvent *));
+extern int XClearWindow _ANSI_ARGS_((Display *, Window));
+extern int XConfigureWindow _ANSI_ARGS_((Display *, Window, unsigned int, XWindowChanges *));
+extern int XConvertSelection _ANSI_ARGS_((Display *, Atom, Atom, Atom, Window, Time));
+extern int XCopyArea _ANSI_ARGS_((Display *, Drawable, Drawable, GC, int, int, unsigned int, unsigned int, int, int));
+extern int XCopyPlane _ANSI_ARGS_((Display *, Drawable, Drawable, GC, int, int, unsigned int, unsigned int, int, int, long unsigned int));
+extern int XDefaultDepth _ANSI_ARGS_((Display *, int));
+extern int XDefaultScreen _ANSI_ARGS_((Display *));
+extern int XDefineCursor _ANSI_ARGS_((Display *, Window, Cursor));
+extern int XDeleteProperty _ANSI_ARGS_((Display *, Window, Atom));
+extern int XDestroyWindow _ANSI_ARGS_((Display *, Window));
+extern int XDrawArc _ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int, int, int));
+extern int XDrawLine _ANSI_ARGS_((Display *, Drawable, GC, int, int, int, int));
+extern int XDrawLines _ANSI_ARGS_((Display *, Drawable, GC, XPoint *, int, int));
+extern int XDrawRectangle _ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int));
+extern int XDrawString _ANSI_ARGS_((Display *, Drawable, GC, int, int, const char *, int));
+extern int XEventsQueued _ANSI_ARGS_((Display *, int));
+extern int XFillArc _ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int, int, int));
+extern int XFillPolygon _ANSI_ARGS_((Display *, Drawable, GC, XPoint *, int, int, int));
+extern int XFillRectangle _ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int));
+extern int XFillRectangles _ANSI_ARGS_((Display *, Drawable, GC, XRectangle *, int));
+extern int XFlush _ANSI_ARGS_((Display *));
+extern int XFree _ANSI_ARGS_((XFree_arg_t *));
+extern int XFreeColormap _ANSI_ARGS_((Display *, Colormap));
+extern int XFreeColors _ANSI_ARGS_((Display *, Colormap, long unsigned int *, int, long unsigned int));
+extern int XFreeCursor _ANSI_ARGS_((Display *, Cursor));
+extern int XFreeFont _ANSI_ARGS_((Display *, XFontStruct *));
+extern int XFreeGC _ANSI_ARGS_((Display *, GC));
+extern int XFreeModifiermap _ANSI_ARGS_((XModifierKeymap *));
+extern int XGetFontProperty _ANSI_ARGS_((XFontStruct *, Atom, long unsigned int *));
+extern int XGetGeometry _ANSI_ARGS_((Display *, Drawable, Window *, int *, int *, unsigned int *, unsigned int *, unsigned int *, unsigned int *));
+extern int XGetInputFocus _ANSI_ARGS_((Display *, Window *, int *));
+extern int XGetWindowProperty _ANSI_ARGS_((Display *, Window, Atom, long int, long int, int, Atom, Atom *, int *, long unsigned int *, long unsigned int *, unsigned char **));
+extern int XGetWindowAttributes _ANSI_ARGS_((Display *, Window, XWindowAttributes *));
+extern int XGrabKeyboard _ANSI_ARGS_((Display *, Window, int, int, int, Time));
+extern int XGrabPointer _ANSI_ARGS_((Display *, Window, int, unsigned int, int, int, Window, Cursor, Time));
+extern int XGrabServer _ANSI_ARGS_((Display *));
+extern int XLookupColor _ANSI_ARGS_((Display *, Colormap, const char *, XColor *, XColor *));
+extern int XLowerWindow _ANSI_ARGS_((Display *, Window));
+extern int XMapWindow _ANSI_ARGS_((Display *, Window));
+extern int XMoveResizeWindow _ANSI_ARGS_((Display *, Window, int, int, unsigned int, unsigned int));
+extern int XMoveWindow _ANSI_ARGS_((Display *, Window, int, int));
+extern int XNextEvent _ANSI_ARGS_((Display *, XEvent *));
+extern int XNoOp _ANSI_ARGS_((Display *));
+extern int XParseColor _ANSI_ARGS_((Display *, Colormap, const char *, XColor *));
+extern int XPutBackEvent _ANSI_ARGS_((Display *, XEvent *));
+extern int XPutImage _ANSI_ARGS_((Display *, Drawable, GC, XImage *, int, int, int, int, unsigned int, unsigned int));
+extern int XQueryColors _ANSI_ARGS_((Display *, Colormap, XColor *, int));
+extern int XQueryPointer _ANSI_ARGS_((Display *, Window, Window *, Window *, int *, int *, int *, int *, unsigned int *));
+extern int XQueryTree _ANSI_ARGS_((Display *, Window, Window *, Window *, Window **, unsigned int *));
+extern int XRaiseWindow _ANSI_ARGS_((Display *, Window));
+extern int XReadBitmapFile _ANSI_ARGS_((Display *, Drawable, const char *, unsigned int *, unsigned int *, Pixmap *, int *, int *));
+extern int XRefreshKeyboardMapping _ANSI_ARGS_((XMappingEvent *));
+extern int XResizeWindow _ANSI_ARGS_((Display *, Window, unsigned int, unsigned int));
+extern int XSelectInput _ANSI_ARGS_((Display *, Window, long int));
+extern int XSendEvent _ANSI_ARGS_((Display *, Window, int, long int, XEvent *));
+extern int XSetClipMask _ANSI_ARGS_((Display *, GC, Pixmap));
+extern int XSetClipOrigin _ANSI_ARGS_((Display *, GC, int, int));
+extern int XSetCommand _ANSI_ARGS_((Display *, Window, char **, int));
+extern int XSetDashes _ANSI_ARGS_((Display *, GC, int, const char *, int));
+extern int XSetForeground _ANSI_ARGS_((Display *, GC, long unsigned int));
+extern int XSetIconName _ANSI_ARGS_((Display *, Window, const char *));
+extern int XSetInputFocus _ANSI_ARGS_((Display *, Window, int, Time));
+extern int XSetSelectionOwner _ANSI_ARGS_((Display *, Atom, Window, Time));
+extern int XSetTSOrigin _ANSI_ARGS_((Display *, GC, int, int));
+extern int XSetWindowBackground _ANSI_ARGS_((Display *, Window, long unsigned int));
+extern int XSetWindowBackgroundPixmap _ANSI_ARGS_((Display *, Window, Pixmap));
+extern int XSetWindowBorder _ANSI_ARGS_((Display *, Window, long unsigned int));
+extern int XSetWindowBorderPixmap _ANSI_ARGS_((Display *, Window, Pixmap));
+extern int XSetWindowBorderWidth _ANSI_ARGS_((Display *, Window, unsigned int));
+extern int XSetWindowColormap _ANSI_ARGS_((Display *, Window, Colormap));
+extern int XSync _ANSI_ARGS_((Display *, int));
+extern int XTextExtents _ANSI_ARGS_((XFontStruct *, const char *, int, int *, int *, int *, XCharStruct *));
+extern int XTextWidth _ANSI_ARGS_((XFontStruct *, const char *, int));
+extern int XTranslateCoordinates _ANSI_ARGS_((Display *, Window, Window, int, int, int *, int *, Window *));
+extern int XUngrabKeyboard _ANSI_ARGS_((Display *, Time));
+extern int XUngrabPointer _ANSI_ARGS_((Display *, Time));
+extern int XUngrabServer _ANSI_ARGS_((Display *));
+extern int XUnmapWindow _ANSI_ARGS_((Display *, Window));
+extern int XWindowEvent _ANSI_ARGS_((Display *, Window, long int, XEvent *));
+extern Region XCreateRegion _ANSI_ARGS_((void));
+extern XVisualInfo *XGetVisualInfo _ANSI_ARGS_((Display *, long int, XVisualInfo *, int *));
+extern XSizeHints *XAllocSizeHints _ANSI_ARGS_((void));
+extern XClassHint *XAllocClassHint _ANSI_ARGS_((void));
+extern void XSetWMNormalHints _ANSI_ARGS_((Display *, Window, XSizeHints *));
+extern void XSetWMName _ANSI_ARGS_((Display *, Window, XTextProperty *));
+extern void XSetWMClientMachine _ANSI_ARGS_((Display *, Window, XTextProperty *));
+extern int XStringListToTextProperty _ANSI_ARGS_((char **, int, XTextProperty *));
+extern int XClipBox _ANSI_ARGS_((Region, XRectangle *));
+extern int XDestroyRegion _ANSI_ARGS_((Region));
+extern int XIntersectRegion _ANSI_ARGS_((Region, Region, Region));
+extern int XLookupString _ANSI_ARGS_((XKeyEvent *, char *, int, KeySym *, XComposeStatus *));
+extern int XSetClassHint _ANSI_ARGS_((Display *, Window, XClassHint *));
+extern int XSetWMHints _ANSI_ARGS_((Display *, Window, XWMHints *));
+extern int XSetRegion _ANSI_ARGS_((Display *, GC, Region));
+extern int XUnionRectWithRegion _ANSI_ARGS_((XRectangle *, Region, Region));
+extern int XSetBackground _ANSI_ARGS_((Display *, GC, unsigned long));
+extern int XDrawImageString _ANSI_ARGS_((Display *, Drawable, GC, int, int, const char *, int));
+extern int XWarpPointer _ANSI_ARGS_(( Display *, Window, Window, int, int, unsigned int, unsigned int, int, int ));
+extern int XDrawPoints _ANSI_ARGS_(( Display*, Drawable, GC, XPoint*, int, int));
+extern int XChangeGC _ANSI_ARGS_(( Display*, GC, unsigned long, XGCValues *));
+extern char **XListFonts _ANSI_ARGS_(( Display*, const char *, int, int *));
+extern int XFreeFontNames _ANSI_ARGS_((char **));
+extern Window XGetSelectionOwner _ANSI_ARGS_((Display *, Atom));
+extern int XRectInRegion _ANSI_ARGS_((Region,int,int,unsigned,unsigned));
+extern int XSubtractRegion _ANSI_ARGS_((Region, Region, Region));
+#endif /* _XLIB_H_ */
+extern int _XInitImageFuncPtrs _ANSI_ARGS_((XImage *image));
+#endif /* _XLIB */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.m
new file mode 100755
index 00000000000..81d863e3d63
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.m
@@ -0,0 +1,661 @@
+#ifndef _XLIB_VM
+#define _XLIB_VM
+#include "Xlib_f.h"
+#ifndef NO_VTABLES
+#if (defined(__WIN32__) || defined(__PM__)) && !defined(DO_X_EXCLUDE)
+# define DO_X_EXCLUDE
+#endif
+#ifndef DO_X_EXCLUDE
+#ifndef XAllocClassHint
+# define XAllocClassHint (*XlibVptr->V_XAllocClassHint)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XAllocColor
+# define XAllocColor (*XlibVptr->V_XAllocColor)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XAllocNamedColor
+# define XAllocNamedColor (*XlibVptr->V_XAllocNamedColor)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XAllocSizeHints
+# define XAllocSizeHints (*XlibVptr->V_XAllocSizeHints)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XBell
+# define XBell (*XlibVptr->V_XBell)
+#endif
+
+#ifndef XChangeGC
+# define XChangeGC (*XlibVptr->V_XChangeGC)
+#endif
+
+#ifndef XChangeProperty
+# define XChangeProperty (*XlibVptr->V_XChangeProperty)
+#endif
+
+#ifndef XChangeWindowAttributes
+# define XChangeWindowAttributes (*XlibVptr->V_XChangeWindowAttributes)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCheckIfEvent
+# define XCheckIfEvent (*XlibVptr->V_XCheckIfEvent)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCheckWindowEvent
+# define XCheckWindowEvent (*XlibVptr->V_XCheckWindowEvent)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XClearWindow
+# define XClearWindow (*XlibVptr->V_XClearWindow)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XClipBox
+# define XClipBox (*XlibVptr->V_XClipBox)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XConfigureWindow
+# define XConfigureWindow (*XlibVptr->V_XConfigureWindow)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XConvertSelection
+# define XConvertSelection (*XlibVptr->V_XConvertSelection)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XCopyArea
+# define XCopyArea (*XlibVptr->V_XCopyArea)
+#endif
+
+#ifndef XCopyPlane
+# define XCopyPlane (*XlibVptr->V_XCopyPlane)
+#endif
+
+#ifndef XCreateBitmapFromData
+# define XCreateBitmapFromData (*XlibVptr->V_XCreateBitmapFromData)
+#endif
+
+#ifndef XCreateColormap
+# define XCreateColormap (*XlibVptr->V_XCreateColormap)
+#endif
+
+#ifndef XCreateGC
+# define XCreateGC (*XlibVptr->V_XCreateGC)
+#endif
+
+#ifndef XCreateGlyphCursor
+# define XCreateGlyphCursor (*XlibVptr->V_XCreateGlyphCursor)
+#endif
+
+#ifndef XCreateImage
+# define XCreateImage (*XlibVptr->V_XCreateImage)
+#endif
+
+#ifndef XCreatePixmapCursor
+# define XCreatePixmapCursor (*XlibVptr->V_XCreatePixmapCursor)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCreateRegion
+# define XCreateRegion (*XlibVptr->V_XCreateRegion)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCreateWindow
+# define XCreateWindow (*XlibVptr->V_XCreateWindow)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultColormap
+# define XDefaultColormap (*XlibVptr->V_XDefaultColormap)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultDepth
+# define XDefaultDepth (*XlibVptr->V_XDefaultDepth)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultScreen
+# define XDefaultScreen (*XlibVptr->V_XDefaultScreen)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultVisual
+# define XDefaultVisual (*XlibVptr->V_XDefaultVisual)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XDefineCursor
+# define XDefineCursor (*XlibVptr->V_XDefineCursor)
+#endif
+
+#ifndef XDeleteProperty
+# define XDeleteProperty (*XlibVptr->V_XDeleteProperty)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDestroyRegion
+# define XDestroyRegion (*XlibVptr->V_XDestroyRegion)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XDestroyWindow
+# define XDestroyWindow (*XlibVptr->V_XDestroyWindow)
+#endif
+
+#ifndef XDrawArc
+# define XDrawArc (*XlibVptr->V_XDrawArc)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDrawImageString
+# define XDrawImageString (*XlibVptr->V_XDrawImageString)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XDrawLine
+# define XDrawLine (*XlibVptr->V_XDrawLine)
+#endif
+
+#ifndef XDrawLines
+# define XDrawLines (*XlibVptr->V_XDrawLines)
+#endif
+
+#ifndef XDrawPoints
+# define XDrawPoints (*XlibVptr->V_XDrawPoints)
+#endif
+
+#ifndef XDrawRectangle
+# define XDrawRectangle (*XlibVptr->V_XDrawRectangle)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDrawString
+# define XDrawString (*XlibVptr->V_XDrawString)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XEventsQueued
+# define XEventsQueued (*XlibVptr->V_XEventsQueued)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XFillArc
+# define XFillArc (*XlibVptr->V_XFillArc)
+#endif
+
+#ifndef XFillPolygon
+# define XFillPolygon (*XlibVptr->V_XFillPolygon)
+#endif
+
+#ifndef XFillRectangle
+# define XFillRectangle (*XlibVptr->V_XFillRectangle)
+#endif
+
+#ifndef XFillRectangles
+# define XFillRectangles (*XlibVptr->V_XFillRectangles)
+#endif
+
+#ifndef XFlush
+# define XFlush (*XlibVptr->V_XFlush)
+#endif
+
+#ifndef XFree
+# define XFree (*XlibVptr->V_XFree)
+#endif
+
+#ifndef XFreeColormap
+# define XFreeColormap (*XlibVptr->V_XFreeColormap)
+#endif
+
+#ifndef XFreeColors
+# define XFreeColors (*XlibVptr->V_XFreeColors)
+#endif
+
+#ifndef XFreeCursor
+# define XFreeCursor (*XlibVptr->V_XFreeCursor)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XFreeFont
+# define XFreeFont (*XlibVptr->V_XFreeFont)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XFreeFontNames
+# define XFreeFontNames (*XlibVptr->V_XFreeFontNames)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XFreeGC
+# define XFreeGC (*XlibVptr->V_XFreeGC)
+#endif
+
+#ifndef XFreeModifiermap
+# define XFreeModifiermap (*XlibVptr->V_XFreeModifiermap)
+#endif
+
+#ifndef XGContextFromGC
+# define XGContextFromGC (*XlibVptr->V_XGContextFromGC)
+#endif
+
+#ifndef XGetAtomName
+# define XGetAtomName (*XlibVptr->V_XGetAtomName)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XGetFontProperty
+# define XGetFontProperty (*XlibVptr->V_XGetFontProperty)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XGetGeometry
+# define XGetGeometry (*XlibVptr->V_XGetGeometry)
+#endif
+
+#ifndef XGetImage
+# define XGetImage (*XlibVptr->V_XGetImage)
+#endif
+
+#ifndef XGetInputFocus
+# define XGetInputFocus (*XlibVptr->V_XGetInputFocus)
+#endif
+
+#ifndef XGetModifierMapping
+# define XGetModifierMapping (*XlibVptr->V_XGetModifierMapping)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XGetSelectionOwner
+# define XGetSelectionOwner (*XlibVptr->V_XGetSelectionOwner)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XGetVisualInfo
+# define XGetVisualInfo (*XlibVptr->V_XGetVisualInfo)
+#endif
+
+#ifndef XGetWMColormapWindows
+# define XGetWMColormapWindows (*XlibVptr->V_XGetWMColormapWindows)
+#endif
+
+#ifndef XGetWindowAttributes
+# define XGetWindowAttributes (*XlibVptr->V_XGetWindowAttributes)
+#endif
+
+#ifndef XGetWindowProperty
+# define XGetWindowProperty (*XlibVptr->V_XGetWindowProperty)
+#endif
+
+#ifndef XGrabKeyboard
+# define XGrabKeyboard (*XlibVptr->V_XGrabKeyboard)
+#endif
+
+#ifndef XGrabPointer
+# define XGrabPointer (*XlibVptr->V_XGrabPointer)
+#endif
+
+#ifndef XGrabServer
+# define XGrabServer (*XlibVptr->V_XGrabServer)
+#endif
+
+#ifndef XIconifyWindow
+# define XIconifyWindow (*XlibVptr->V_XIconifyWindow)
+#endif
+
+#ifndef XInternAtom
+# define XInternAtom (*XlibVptr->V_XInternAtom)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XIntersectRegion
+# define XIntersectRegion (*XlibVptr->V_XIntersectRegion)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XKeycodeToKeysym
+# define XKeycodeToKeysym (*XlibVptr->V_XKeycodeToKeysym)
+#endif
+
+#ifndef XKeysymToString
+# define XKeysymToString (*XlibVptr->V_XKeysymToString)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XListFonts
+# define XListFonts (*XlibVptr->V_XListFonts)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XListHosts
+# define XListHosts (*XlibVptr->V_XListHosts)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XListProperties
+# define XListProperties (*XlibVptr->V_XListProperties)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XLoadFont
+# define XLoadFont (*XlibVptr->V_XLoadFont)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XLoadQueryFont
+# define XLoadQueryFont (*XlibVptr->V_XLoadQueryFont)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XLookupColor
+# define XLookupColor (*XlibVptr->V_XLookupColor)
+#endif
+
+#ifndef XLookupString
+# define XLookupString (*XlibVptr->V_XLookupString)
+#endif
+
+#ifndef XLowerWindow
+# define XLowerWindow (*XlibVptr->V_XLowerWindow)
+#endif
+
+#ifndef XMapWindow
+# define XMapWindow (*XlibVptr->V_XMapWindow)
+#endif
+
+#ifndef XMoveResizeWindow
+# define XMoveResizeWindow (*XlibVptr->V_XMoveResizeWindow)
+#endif
+
+#ifndef XMoveWindow
+# define XMoveWindow (*XlibVptr->V_XMoveWindow)
+#endif
+
+#ifndef XNextEvent
+# define XNextEvent (*XlibVptr->V_XNextEvent)
+#endif
+
+#ifndef XNoOp
+# define XNoOp (*XlibVptr->V_XNoOp)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XOpenDisplay
+# define XOpenDisplay (*XlibVptr->V_XOpenDisplay)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XParseColor
+# define XParseColor (*XlibVptr->V_XParseColor)
+#endif
+
+#ifndef XPutBackEvent
+# define XPutBackEvent (*XlibVptr->V_XPutBackEvent)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XPutImage
+# define XPutImage (*XlibVptr->V_XPutImage)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XQueryColors
+# define XQueryColors (*XlibVptr->V_XQueryColors)
+#endif
+
+#ifndef XQueryPointer
+# define XQueryPointer (*XlibVptr->V_XQueryPointer)
+#endif
+
+#ifndef XQueryTree
+# define XQueryTree (*XlibVptr->V_XQueryTree)
+#endif
+
+#ifndef XRaiseWindow
+# define XRaiseWindow (*XlibVptr->V_XRaiseWindow)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XReadBitmapFile
+# define XReadBitmapFile (*XlibVptr->V_XReadBitmapFile)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XRectInRegion
+# define XRectInRegion (*XlibVptr->V_XRectInRegion)
+#endif
+
+#ifndef XRefreshKeyboardMapping
+# define XRefreshKeyboardMapping (*XlibVptr->V_XRefreshKeyboardMapping)
+#endif
+
+#ifndef XResizeWindow
+# define XResizeWindow (*XlibVptr->V_XResizeWindow)
+#endif
+
+#ifndef XRootWindow
+# define XRootWindow (*XlibVptr->V_XRootWindow)
+#endif
+
+#ifndef XSelectInput
+# define XSelectInput (*XlibVptr->V_XSelectInput)
+#endif
+
+#ifndef XSendEvent
+# define XSendEvent (*XlibVptr->V_XSendEvent)
+#endif
+
+#ifndef XSetBackground
+# define XSetBackground (*XlibVptr->V_XSetBackground)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetClassHint
+# define XSetClassHint (*XlibVptr->V_XSetClassHint)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetClipMask
+# define XSetClipMask (*XlibVptr->V_XSetClipMask)
+#endif
+
+#ifndef XSetClipOrigin
+# define XSetClipOrigin (*XlibVptr->V_XSetClipOrigin)
+#endif
+
+#ifndef XSetCommand
+# define XSetCommand (*XlibVptr->V_XSetCommand)
+#endif
+
+#ifndef XSetDashes
+# define XSetDashes (*XlibVptr->V_XSetDashes)
+#endif
+
+#ifndef XSetErrorHandler
+# define XSetErrorHandler (*XlibVptr->V_XSetErrorHandler)
+#endif
+
+#ifndef XSetForeground
+# define XSetForeground (*XlibVptr->V_XSetForeground)
+#endif
+
+#ifndef XSetIconName
+# define XSetIconName (*XlibVptr->V_XSetIconName)
+#endif
+
+#ifndef XSetInputFocus
+# define XSetInputFocus (*XlibVptr->V_XSetInputFocus)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetRegion
+# define XSetRegion (*XlibVptr->V_XSetRegion)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetSelectionOwner
+# define XSetSelectionOwner (*XlibVptr->V_XSetSelectionOwner)
+#endif
+
+#ifndef XSetTSOrigin
+# define XSetTSOrigin (*XlibVptr->V_XSetTSOrigin)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetTransientForHint
+# define XSetTransientForHint (*XlibVptr->V_XSetTransientForHint)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetWMClientMachine
+# define XSetWMClientMachine (*XlibVptr->V_XSetWMClientMachine)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMColormapWindows
+# define XSetWMColormapWindows (*XlibVptr->V_XSetWMColormapWindows)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMHints
+# define XSetWMHints (*XlibVptr->V_XSetWMHints)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMName
+# define XSetWMName (*XlibVptr->V_XSetWMName)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMNormalHints
+# define XSetWMNormalHints (*XlibVptr->V_XSetWMNormalHints)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetWindowBackground
+# define XSetWindowBackground (*XlibVptr->V_XSetWindowBackground)
+#endif
+
+#ifndef XSetWindowBackgroundPixmap
+# define XSetWindowBackgroundPixmap (*XlibVptr->V_XSetWindowBackgroundPixmap)
+#endif
+
+#ifndef XSetWindowBorder
+# define XSetWindowBorder (*XlibVptr->V_XSetWindowBorder)
+#endif
+
+#ifndef XSetWindowBorderPixmap
+# define XSetWindowBorderPixmap (*XlibVptr->V_XSetWindowBorderPixmap)
+#endif
+
+#ifndef XSetWindowBorderWidth
+# define XSetWindowBorderWidth (*XlibVptr->V_XSetWindowBorderWidth)
+#endif
+
+#ifndef XSetWindowColormap
+# define XSetWindowColormap (*XlibVptr->V_XSetWindowColormap)
+#endif
+
+#ifndef XStringListToTextProperty
+# define XStringListToTextProperty (*XlibVptr->V_XStringListToTextProperty)
+#endif
+
+#ifndef XStringToKeysym
+# define XStringToKeysym (*XlibVptr->V_XStringToKeysym)
+#endif
+
+#ifndef XSubtractRegion
+# define XSubtractRegion (*XlibVptr->V_XSubtractRegion)
+#endif
+
+#ifndef XSync
+# define XSync (*XlibVptr->V_XSync)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XTextExtents
+# define XTextExtents (*XlibVptr->V_XTextExtents)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XTextWidth
+# define XTextWidth (*XlibVptr->V_XTextWidth)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XTranslateCoordinates
+# define XTranslateCoordinates (*XlibVptr->V_XTranslateCoordinates)
+#endif
+
+#ifndef XUngrabKeyboard
+# define XUngrabKeyboard (*XlibVptr->V_XUngrabKeyboard)
+#endif
+
+#ifndef XUngrabPointer
+# define XUngrabPointer (*XlibVptr->V_XUngrabPointer)
+#endif
+
+#ifndef XUngrabServer
+# define XUngrabServer (*XlibVptr->V_XUngrabServer)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XUnionRectWithRegion
+# define XUnionRectWithRegion (*XlibVptr->V_XUnionRectWithRegion)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XUnmapWindow
+# define XUnmapWindow (*XlibVptr->V_XUnmapWindow)
+#endif
+
+#ifndef XVisualIDFromVisual
+# define XVisualIDFromVisual (*XlibVptr->V_XVisualIDFromVisual)
+#endif
+
+#ifndef DO_X_EXCLUDE
+#ifndef XWarpPointer
+# define XWarpPointer (*XlibVptr->V_XWarpPointer)
+#endif
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XWindowEvent
+# define XWindowEvent (*XlibVptr->V_XWindowEvent)
+#endif
+
+#ifndef XWithdrawWindow
+# define XWithdrawWindow (*XlibVptr->V_XWithdrawWindow)
+#endif
+
+#ifndef _XInitImageFuncPtrs
+# define _XInitImageFuncPtrs (*XlibVptr->V__XInitImageFuncPtrs)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _XLIB_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.t
new file mode 100755
index 00000000000..a193fc5e3ee
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib.t
@@ -0,0 +1,657 @@
+#ifdef _XLIB
+#if (defined(__WIN32__) || defined(__PM__)) && !defined(DO_X_EXCLUDE)
+# define DO_X_EXCLUDE
+#endif
+#ifndef DO_X_EXCLUDE
+#ifndef XAllocClassHint
+VFUNC(XClassHint *,XAllocClassHint,V_XAllocClassHint,_ANSI_ARGS_((void)))
+#endif /* #ifndef XAllocClassHint */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XAllocColor
+VFUNC(int,XAllocColor,V_XAllocColor,_ANSI_ARGS_((Display *, Colormap, XColor *)))
+#endif /* #ifndef XAllocColor */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XAllocNamedColor
+VFUNC(int,XAllocNamedColor,V_XAllocNamedColor,_ANSI_ARGS_((Display *, Colormap, const char *, XColor *, XColor *)))
+#endif /* #ifndef XAllocNamedColor */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XAllocSizeHints
+VFUNC(XSizeHints *,XAllocSizeHints,V_XAllocSizeHints,_ANSI_ARGS_((void)))
+#endif /* #ifndef XAllocSizeHints */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XBell
+VFUNC(int,XBell,V_XBell,_ANSI_ARGS_((Display *, int)))
+#endif /* #ifndef XBell */
+
+#ifndef XChangeGC
+VFUNC(int,XChangeGC,V_XChangeGC,_ANSI_ARGS_(( Display*, GC, unsigned long, XGCValues *)))
+#endif /* #ifndef XChangeGC */
+
+#ifndef XChangeProperty
+VFUNC(int,XChangeProperty,V_XChangeProperty,_ANSI_ARGS_((Display *, Window, Atom, Atom, int, int, const unsigned char *, int)))
+#endif /* #ifndef XChangeProperty */
+
+#ifndef XChangeWindowAttributes
+VFUNC(int,XChangeWindowAttributes,V_XChangeWindowAttributes,_ANSI_ARGS_((Display *, Window, long unsigned int, XSetWindowAttributes *)))
+#endif /* #ifndef XChangeWindowAttributes */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCheckIfEvent
+VFUNC(int,XCheckIfEvent,V_XCheckIfEvent,_ANSI_ARGS_((Display *, XEvent *, int (*) (Display *, XEvent *, char *), char *)))
+#endif /* #ifndef XCheckIfEvent */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCheckWindowEvent
+VFUNC(int,XCheckWindowEvent,V_XCheckWindowEvent,_ANSI_ARGS_((Display *, Window, long int, XEvent *)))
+#endif /* #ifndef XCheckWindowEvent */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XClearWindow
+VFUNC(int,XClearWindow,V_XClearWindow,_ANSI_ARGS_((Display *, Window)))
+#endif /* #ifndef XClearWindow */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XClipBox
+VFUNC(int,XClipBox,V_XClipBox,_ANSI_ARGS_((Region, XRectangle *)))
+#endif /* #ifndef XClipBox */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XConfigureWindow
+VFUNC(int,XConfigureWindow,V_XConfigureWindow,_ANSI_ARGS_((Display *, Window, unsigned int, XWindowChanges *)))
+#endif /* #ifndef XConfigureWindow */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XConvertSelection
+VFUNC(int,XConvertSelection,V_XConvertSelection,_ANSI_ARGS_((Display *, Atom, Atom, Atom, Window, Time)))
+#endif /* #ifndef XConvertSelection */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XCopyArea
+VFUNC(int,XCopyArea,V_XCopyArea,_ANSI_ARGS_((Display *, Drawable, Drawable, GC, int, int, unsigned int, unsigned int, int, int)))
+#endif /* #ifndef XCopyArea */
+
+#ifndef XCopyPlane
+VFUNC(int,XCopyPlane,V_XCopyPlane,_ANSI_ARGS_((Display *, Drawable, Drawable, GC, int, int, unsigned int, unsigned int, int, int, long unsigned int)))
+#endif /* #ifndef XCopyPlane */
+
+#ifndef XCreateBitmapFromData
+VFUNC(Pixmap,XCreateBitmapFromData,V_XCreateBitmapFromData,_ANSI_ARGS_((Display *, Drawable, const char *, unsigned int, unsigned int)))
+#endif /* #ifndef XCreateBitmapFromData */
+
+#ifndef XCreateColormap
+VFUNC(Colormap,XCreateColormap,V_XCreateColormap,_ANSI_ARGS_((Display *, Window, Visual *, int)))
+#endif /* #ifndef XCreateColormap */
+
+#ifndef XCreateGC
+VFUNC(GC,XCreateGC,V_XCreateGC,_ANSI_ARGS_((Display *, Drawable, long unsigned int, XGCValues *)))
+#endif /* #ifndef XCreateGC */
+
+#ifndef XCreateGlyphCursor
+VFUNC(Cursor,XCreateGlyphCursor,V_XCreateGlyphCursor,_ANSI_ARGS_((Display *, Font, Font, unsigned int, unsigned int, XColor const *, XColor const *)))
+#endif /* #ifndef XCreateGlyphCursor */
+
+#ifndef XCreateImage
+VFUNC(XImage *,XCreateImage,V_XCreateImage,_ANSI_ARGS_((Display *, Visual *, unsigned int, int, int, char *, unsigned int, unsigned int, int, int)))
+#endif /* #ifndef XCreateImage */
+
+#ifndef XCreatePixmapCursor
+VFUNC(Cursor,XCreatePixmapCursor,V_XCreatePixmapCursor,_ANSI_ARGS_((Display *, Pixmap, Pixmap, XColor *, XColor *, unsigned int, unsigned int)))
+#endif /* #ifndef XCreatePixmapCursor */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCreateRegion
+VFUNC(Region,XCreateRegion,V_XCreateRegion,_ANSI_ARGS_((void)))
+#endif /* #ifndef XCreateRegion */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XCreateWindow
+VFUNC(Window,XCreateWindow,V_XCreateWindow,_ANSI_ARGS_((Display *, Window, int, int, unsigned int, unsigned int, unsigned int, int, unsigned int, Visual *, long unsigned int, XSetWindowAttributes *)))
+#endif /* #ifndef XCreateWindow */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultColormap
+VFUNC(Colormap,XDefaultColormap,V_XDefaultColormap,_ANSI_ARGS_((Display *, int)))
+#endif /* #ifndef XDefaultColormap */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultDepth
+VFUNC(int,XDefaultDepth,V_XDefaultDepth,_ANSI_ARGS_((Display *, int)))
+#endif /* #ifndef XDefaultDepth */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultScreen
+VFUNC(int,XDefaultScreen,V_XDefaultScreen,_ANSI_ARGS_((Display *)))
+#endif /* #ifndef XDefaultScreen */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDefaultVisual
+VFUNC(Visual *,XDefaultVisual,V_XDefaultVisual,_ANSI_ARGS_((Display *, int)))
+#endif /* #ifndef XDefaultVisual */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XDefineCursor
+VFUNC(int,XDefineCursor,V_XDefineCursor,_ANSI_ARGS_((Display *, Window, Cursor)))
+#endif /* #ifndef XDefineCursor */
+
+#ifndef XDeleteProperty
+VFUNC(int,XDeleteProperty,V_XDeleteProperty,_ANSI_ARGS_((Display *, Window, Atom)))
+#endif /* #ifndef XDeleteProperty */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDestroyRegion
+VFUNC(int,XDestroyRegion,V_XDestroyRegion,_ANSI_ARGS_((Region)))
+#endif /* #ifndef XDestroyRegion */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XDestroyWindow
+VFUNC(int,XDestroyWindow,V_XDestroyWindow,_ANSI_ARGS_((Display *, Window)))
+#endif /* #ifndef XDestroyWindow */
+
+#ifndef XDrawArc
+VFUNC(int,XDrawArc,V_XDrawArc,_ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int, int, int)))
+#endif /* #ifndef XDrawArc */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDrawImageString
+VFUNC(int,XDrawImageString,V_XDrawImageString,_ANSI_ARGS_((Display *, Drawable, GC, int, int, const char *, int)))
+#endif /* #ifndef XDrawImageString */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XDrawLine
+VFUNC(int,XDrawLine,V_XDrawLine,_ANSI_ARGS_((Display *, Drawable, GC, int, int, int, int)))
+#endif /* #ifndef XDrawLine */
+
+#ifndef XDrawLines
+VFUNC(int,XDrawLines,V_XDrawLines,_ANSI_ARGS_((Display *, Drawable, GC, XPoint *, int, int)))
+#endif /* #ifndef XDrawLines */
+
+#ifndef XDrawPoints
+VFUNC(int,XDrawPoints,V_XDrawPoints,_ANSI_ARGS_(( Display*, Drawable, GC, XPoint*, int, int)))
+#endif /* #ifndef XDrawPoints */
+
+#ifndef XDrawRectangle
+VFUNC(int,XDrawRectangle,V_XDrawRectangle,_ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int)))
+#endif /* #ifndef XDrawRectangle */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XDrawString
+VFUNC(int,XDrawString,V_XDrawString,_ANSI_ARGS_((Display *, Drawable, GC, int, int, const char *, int)))
+#endif /* #ifndef XDrawString */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XEventsQueued
+VFUNC(int,XEventsQueued,V_XEventsQueued,_ANSI_ARGS_((Display *, int)))
+#endif /* #ifndef XEventsQueued */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XFillArc
+VFUNC(int,XFillArc,V_XFillArc,_ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int, int, int)))
+#endif /* #ifndef XFillArc */
+
+#ifndef XFillPolygon
+VFUNC(int,XFillPolygon,V_XFillPolygon,_ANSI_ARGS_((Display *, Drawable, GC, XPoint *, int, int, int)))
+#endif /* #ifndef XFillPolygon */
+
+#ifndef XFillRectangle
+VFUNC(int,XFillRectangle,V_XFillRectangle,_ANSI_ARGS_((Display *, Drawable, GC, int, int, unsigned int, unsigned int)))
+#endif /* #ifndef XFillRectangle */
+
+#ifndef XFillRectangles
+VFUNC(int,XFillRectangles,V_XFillRectangles,_ANSI_ARGS_((Display *, Drawable, GC, XRectangle *, int)))
+#endif /* #ifndef XFillRectangles */
+
+#ifndef XFlush
+VFUNC(int,XFlush,V_XFlush,_ANSI_ARGS_((Display *)))
+#endif /* #ifndef XFlush */
+
+#ifndef XFree
+VFUNC(int,XFree,V_XFree,_ANSI_ARGS_((XFree_arg_t *)))
+#endif /* #ifndef XFree */
+
+#ifndef XFreeColormap
+VFUNC(int,XFreeColormap,V_XFreeColormap,_ANSI_ARGS_((Display *, Colormap)))
+#endif /* #ifndef XFreeColormap */
+
+#ifndef XFreeColors
+VFUNC(int,XFreeColors,V_XFreeColors,_ANSI_ARGS_((Display *, Colormap, long unsigned int *, int, long unsigned int)))
+#endif /* #ifndef XFreeColors */
+
+#ifndef XFreeCursor
+VFUNC(int,XFreeCursor,V_XFreeCursor,_ANSI_ARGS_((Display *, Cursor)))
+#endif /* #ifndef XFreeCursor */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XFreeFont
+VFUNC(int,XFreeFont,V_XFreeFont,_ANSI_ARGS_((Display *, XFontStruct *)))
+#endif /* #ifndef XFreeFont */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XFreeFontNames
+VFUNC(int,XFreeFontNames,V_XFreeFontNames,_ANSI_ARGS_((char **)))
+#endif /* #ifndef XFreeFontNames */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XFreeGC
+VFUNC(int,XFreeGC,V_XFreeGC,_ANSI_ARGS_((Display *, GC)))
+#endif /* #ifndef XFreeGC */
+
+#ifndef XFreeModifiermap
+VFUNC(int,XFreeModifiermap,V_XFreeModifiermap,_ANSI_ARGS_((XModifierKeymap *)))
+#endif /* #ifndef XFreeModifiermap */
+
+#ifndef XGContextFromGC
+VFUNC(GContext,XGContextFromGC,V_XGContextFromGC,_ANSI_ARGS_((GC)))
+#endif /* #ifndef XGContextFromGC */
+
+#ifndef XGetAtomName
+VFUNC(char *,XGetAtomName,V_XGetAtomName,_ANSI_ARGS_((Display *, Atom)))
+#endif /* #ifndef XGetAtomName */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XGetFontProperty
+VFUNC(int,XGetFontProperty,V_XGetFontProperty,_ANSI_ARGS_((XFontStruct *, Atom, long unsigned int *)))
+#endif /* #ifndef XGetFontProperty */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XGetGeometry
+VFUNC(int,XGetGeometry,V_XGetGeometry,_ANSI_ARGS_((Display *, Drawable, Window *, int *, int *, unsigned int *, unsigned int *, unsigned int *, unsigned int *)))
+#endif /* #ifndef XGetGeometry */
+
+#ifndef XGetImage
+VFUNC(XImage *,XGetImage,V_XGetImage,_ANSI_ARGS_((Display *, Drawable, int, int, unsigned int, unsigned int, long unsigned int, int)))
+#endif /* #ifndef XGetImage */
+
+#ifndef XGetInputFocus
+VFUNC(int,XGetInputFocus,V_XGetInputFocus,_ANSI_ARGS_((Display *, Window *, int *)))
+#endif /* #ifndef XGetInputFocus */
+
+#ifndef XGetModifierMapping
+VFUNC(XModifierKeymap *,XGetModifierMapping,V_XGetModifierMapping,_ANSI_ARGS_((Display *)))
+#endif /* #ifndef XGetModifierMapping */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XGetSelectionOwner
+VFUNC(Window,XGetSelectionOwner,V_XGetSelectionOwner,_ANSI_ARGS_((Display *, Atom)))
+#endif /* #ifndef XGetSelectionOwner */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XGetVisualInfo
+VFUNC(XVisualInfo *,XGetVisualInfo,V_XGetVisualInfo,_ANSI_ARGS_((Display *, long int, XVisualInfo *, int *)))
+#endif /* #ifndef XGetVisualInfo */
+
+#ifndef XGetWMColormapWindows
+VFUNC(int,XGetWMColormapWindows,V_XGetWMColormapWindows,_ANSI_ARGS_((Display *, Window, Window **, int *)))
+#endif /* #ifndef XGetWMColormapWindows */
+
+#ifndef XGetWindowAttributes
+VFUNC(int,XGetWindowAttributes,V_XGetWindowAttributes,_ANSI_ARGS_((Display *, Window, XWindowAttributes *)))
+#endif /* #ifndef XGetWindowAttributes */
+
+#ifndef XGetWindowProperty
+VFUNC(int,XGetWindowProperty,V_XGetWindowProperty,_ANSI_ARGS_((Display *, Window, Atom, long int, long int, int, Atom, Atom *, int *, long unsigned int *, long unsigned int *, unsigned char **)))
+#endif /* #ifndef XGetWindowProperty */
+
+#ifndef XGrabKeyboard
+VFUNC(int,XGrabKeyboard,V_XGrabKeyboard,_ANSI_ARGS_((Display *, Window, int, int, int, Time)))
+#endif /* #ifndef XGrabKeyboard */
+
+#ifndef XGrabPointer
+VFUNC(int,XGrabPointer,V_XGrabPointer,_ANSI_ARGS_((Display *, Window, int, unsigned int, int, int, Window, Cursor, Time)))
+#endif /* #ifndef XGrabPointer */
+
+#ifndef XGrabServer
+VFUNC(int,XGrabServer,V_XGrabServer,_ANSI_ARGS_((Display *)))
+#endif /* #ifndef XGrabServer */
+
+#ifndef XIconifyWindow
+VFUNC(int,XIconifyWindow,V_XIconifyWindow,_ANSI_ARGS_((Display *, Window, int)))
+#endif /* #ifndef XIconifyWindow */
+
+#ifndef XInternAtom
+VFUNC(Atom,XInternAtom,V_XInternAtom,_ANSI_ARGS_((Display *, const char *, int)))
+#endif /* #ifndef XInternAtom */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XIntersectRegion
+VFUNC(int,XIntersectRegion,V_XIntersectRegion,_ANSI_ARGS_((Region, Region, Region)))
+#endif /* #ifndef XIntersectRegion */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XKeycodeToKeysym
+VFUNC(KeySym,XKeycodeToKeysym,V_XKeycodeToKeysym,_ANSI_ARGS_((Display *, unsigned int, int)))
+#endif /* #ifndef XKeycodeToKeysym */
+
+#ifndef XKeysymToString
+VFUNC(char *,XKeysymToString,V_XKeysymToString,_ANSI_ARGS_((KeySym)))
+#endif /* #ifndef XKeysymToString */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XListFonts
+VFUNC(char **,XListFonts,V_XListFonts,_ANSI_ARGS_(( Display*, const char *, int, int *)))
+#endif /* #ifndef XListFonts */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XListHosts
+VFUNC(XHostAddress *,XListHosts,V_XListHosts,_ANSI_ARGS_((Display *, int *, int *)))
+#endif /* #ifndef XListHosts */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XListProperties
+VFUNC(Atom *,XListProperties,V_XListProperties,_ANSI_ARGS_((Display *, Window, int *)))
+#endif /* #ifndef XListProperties */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XLoadFont
+VFUNC(Font,XLoadFont,V_XLoadFont,_ANSI_ARGS_((Display *, const char *)))
+#endif /* #ifndef XLoadFont */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XLoadQueryFont
+VFUNC(XFontStruct *,XLoadQueryFont,V_XLoadQueryFont,_ANSI_ARGS_((Display *, const char *)))
+#endif /* #ifndef XLoadQueryFont */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XLookupColor
+VFUNC(int,XLookupColor,V_XLookupColor,_ANSI_ARGS_((Display *, Colormap, const char *, XColor *, XColor *)))
+#endif /* #ifndef XLookupColor */
+
+#ifndef XLookupString
+VFUNC(int,XLookupString,V_XLookupString,_ANSI_ARGS_((XKeyEvent *, char *, int, KeySym *, XComposeStatus *)))
+#endif /* #ifndef XLookupString */
+
+#ifndef XLowerWindow
+VFUNC(int,XLowerWindow,V_XLowerWindow,_ANSI_ARGS_((Display *, Window)))
+#endif /* #ifndef XLowerWindow */
+
+#ifndef XMapWindow
+VFUNC(int,XMapWindow,V_XMapWindow,_ANSI_ARGS_((Display *, Window)))
+#endif /* #ifndef XMapWindow */
+
+#ifndef XMoveResizeWindow
+VFUNC(int,XMoveResizeWindow,V_XMoveResizeWindow,_ANSI_ARGS_((Display *, Window, int, int, unsigned int, unsigned int)))
+#endif /* #ifndef XMoveResizeWindow */
+
+#ifndef XMoveWindow
+VFUNC(int,XMoveWindow,V_XMoveWindow,_ANSI_ARGS_((Display *, Window, int, int)))
+#endif /* #ifndef XMoveWindow */
+
+#ifndef XNextEvent
+VFUNC(int,XNextEvent,V_XNextEvent,_ANSI_ARGS_((Display *, XEvent *)))
+#endif /* #ifndef XNextEvent */
+
+#ifndef XNoOp
+VFUNC(int,XNoOp,V_XNoOp,_ANSI_ARGS_((Display *)))
+#endif /* #ifndef XNoOp */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XOpenDisplay
+VFUNC(Display *,XOpenDisplay,V_XOpenDisplay,_ANSI_ARGS_((const char *)))
+#endif /* #ifndef XOpenDisplay */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XParseColor
+VFUNC(int,XParseColor,V_XParseColor,_ANSI_ARGS_((Display *, Colormap, const char *, XColor *)))
+#endif /* #ifndef XParseColor */
+
+#ifndef XPutBackEvent
+VFUNC(int,XPutBackEvent,V_XPutBackEvent,_ANSI_ARGS_((Display *, XEvent *)))
+#endif /* #ifndef XPutBackEvent */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XPutImage
+VFUNC(int,XPutImage,V_XPutImage,_ANSI_ARGS_((Display *, Drawable, GC, XImage *, int, int, int, int, unsigned int, unsigned int)))
+#endif /* #ifndef XPutImage */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XQueryColors
+VFUNC(int,XQueryColors,V_XQueryColors,_ANSI_ARGS_((Display *, Colormap, XColor *, int)))
+#endif /* #ifndef XQueryColors */
+
+#ifndef XQueryPointer
+VFUNC(int,XQueryPointer,V_XQueryPointer,_ANSI_ARGS_((Display *, Window, Window *, Window *, int *, int *, int *, int *, unsigned int *)))
+#endif /* #ifndef XQueryPointer */
+
+#ifndef XQueryTree
+VFUNC(int,XQueryTree,V_XQueryTree,_ANSI_ARGS_((Display *, Window, Window *, Window *, Window **, unsigned int *)))
+#endif /* #ifndef XQueryTree */
+
+#ifndef XRaiseWindow
+VFUNC(int,XRaiseWindow,V_XRaiseWindow,_ANSI_ARGS_((Display *, Window)))
+#endif /* #ifndef XRaiseWindow */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XReadBitmapFile
+VFUNC(int,XReadBitmapFile,V_XReadBitmapFile,_ANSI_ARGS_((Display *, Drawable, const char *, unsigned int *, unsigned int *, Pixmap *, int *, int *)))
+#endif /* #ifndef XReadBitmapFile */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XRectInRegion
+VFUNC(int,XRectInRegion,V_XRectInRegion,_ANSI_ARGS_((Region,int,int,unsigned,unsigned)))
+#endif /* #ifndef XRectInRegion */
+
+#ifndef XRefreshKeyboardMapping
+VFUNC(int,XRefreshKeyboardMapping,V_XRefreshKeyboardMapping,_ANSI_ARGS_((XMappingEvent *)))
+#endif /* #ifndef XRefreshKeyboardMapping */
+
+#ifndef XResizeWindow
+VFUNC(int,XResizeWindow,V_XResizeWindow,_ANSI_ARGS_((Display *, Window, unsigned int, unsigned int)))
+#endif /* #ifndef XResizeWindow */
+
+#ifndef XRootWindow
+VFUNC(Window,XRootWindow,V_XRootWindow,_ANSI_ARGS_((Display *, int)))
+#endif /* #ifndef XRootWindow */
+
+#ifndef XSelectInput
+VFUNC(int,XSelectInput,V_XSelectInput,_ANSI_ARGS_((Display *, Window, long int)))
+#endif /* #ifndef XSelectInput */
+
+#ifndef XSendEvent
+VFUNC(int,XSendEvent,V_XSendEvent,_ANSI_ARGS_((Display *, Window, int, long int, XEvent *)))
+#endif /* #ifndef XSendEvent */
+
+#ifndef XSetBackground
+VFUNC(int,XSetBackground,V_XSetBackground,_ANSI_ARGS_((Display *, GC, unsigned long)))
+#endif /* #ifndef XSetBackground */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetClassHint
+VFUNC(int,XSetClassHint,V_XSetClassHint,_ANSI_ARGS_((Display *, Window, XClassHint *)))
+#endif /* #ifndef XSetClassHint */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetClipMask
+VFUNC(int,XSetClipMask,V_XSetClipMask,_ANSI_ARGS_((Display *, GC, Pixmap)))
+#endif /* #ifndef XSetClipMask */
+
+#ifndef XSetClipOrigin
+VFUNC(int,XSetClipOrigin,V_XSetClipOrigin,_ANSI_ARGS_((Display *, GC, int, int)))
+#endif /* #ifndef XSetClipOrigin */
+
+#ifndef XSetCommand
+VFUNC(int,XSetCommand,V_XSetCommand,_ANSI_ARGS_((Display *, Window, char **, int)))
+#endif /* #ifndef XSetCommand */
+
+#ifndef XSetDashes
+VFUNC(int,XSetDashes,V_XSetDashes,_ANSI_ARGS_((Display *, GC, int, const char *, int)))
+#endif /* #ifndef XSetDashes */
+
+#ifndef XSetErrorHandler
+VFUNC(XErrorHandler,XSetErrorHandler,V_XSetErrorHandler,_ANSI_ARGS_((XErrorHandler)))
+#endif /* #ifndef XSetErrorHandler */
+
+#ifndef XSetForeground
+VFUNC(int,XSetForeground,V_XSetForeground,_ANSI_ARGS_((Display *, GC, long unsigned int)))
+#endif /* #ifndef XSetForeground */
+
+#ifndef XSetIconName
+VFUNC(int,XSetIconName,V_XSetIconName,_ANSI_ARGS_((Display *, Window, const char *)))
+#endif /* #ifndef XSetIconName */
+
+#ifndef XSetInputFocus
+VFUNC(int,XSetInputFocus,V_XSetInputFocus,_ANSI_ARGS_((Display *, Window, int, Time)))
+#endif /* #ifndef XSetInputFocus */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetRegion
+VFUNC(int,XSetRegion,V_XSetRegion,_ANSI_ARGS_((Display *, GC, Region)))
+#endif /* #ifndef XSetRegion */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetSelectionOwner
+VFUNC(int,XSetSelectionOwner,V_XSetSelectionOwner,_ANSI_ARGS_((Display *, Atom, Window, Time)))
+#endif /* #ifndef XSetSelectionOwner */
+
+#ifndef XSetTSOrigin
+VFUNC(int,XSetTSOrigin,V_XSetTSOrigin,_ANSI_ARGS_((Display *, GC, int, int)))
+#endif /* #ifndef XSetTSOrigin */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetTransientForHint
+VFUNC(int,XSetTransientForHint,V_XSetTransientForHint,_ANSI_ARGS_((Display *, Window, Window)))
+#endif /* #ifndef XSetTransientForHint */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetWMClientMachine
+VFUNC(void,XSetWMClientMachine,V_XSetWMClientMachine,_ANSI_ARGS_((Display *, Window, XTextProperty *)))
+#endif /* #ifndef XSetWMClientMachine */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMColormapWindows
+VFUNC(int,XSetWMColormapWindows,V_XSetWMColormapWindows,_ANSI_ARGS_((Display *, Window, Window *, int)))
+#endif /* #ifndef XSetWMColormapWindows */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMHints
+VFUNC(int,XSetWMHints,V_XSetWMHints,_ANSI_ARGS_((Display *, Window, XWMHints *)))
+#endif /* #ifndef XSetWMHints */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMName
+VFUNC(void,XSetWMName,V_XSetWMName,_ANSI_ARGS_((Display *, Window, XTextProperty *)))
+#endif /* #ifndef XSetWMName */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XSetWMNormalHints
+VFUNC(void,XSetWMNormalHints,V_XSetWMNormalHints,_ANSI_ARGS_((Display *, Window, XSizeHints *)))
+#endif /* #ifndef XSetWMNormalHints */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XSetWindowBackground
+VFUNC(int,XSetWindowBackground,V_XSetWindowBackground,_ANSI_ARGS_((Display *, Window, long unsigned int)))
+#endif /* #ifndef XSetWindowBackground */
+
+#ifndef XSetWindowBackgroundPixmap
+VFUNC(int,XSetWindowBackgroundPixmap,V_XSetWindowBackgroundPixmap,_ANSI_ARGS_((Display *, Window, Pixmap)))
+#endif /* #ifndef XSetWindowBackgroundPixmap */
+
+#ifndef XSetWindowBorder
+VFUNC(int,XSetWindowBorder,V_XSetWindowBorder,_ANSI_ARGS_((Display *, Window, long unsigned int)))
+#endif /* #ifndef XSetWindowBorder */
+
+#ifndef XSetWindowBorderPixmap
+VFUNC(int,XSetWindowBorderPixmap,V_XSetWindowBorderPixmap,_ANSI_ARGS_((Display *, Window, Pixmap)))
+#endif /* #ifndef XSetWindowBorderPixmap */
+
+#ifndef XSetWindowBorderWidth
+VFUNC(int,XSetWindowBorderWidth,V_XSetWindowBorderWidth,_ANSI_ARGS_((Display *, Window, unsigned int)))
+#endif /* #ifndef XSetWindowBorderWidth */
+
+#ifndef XSetWindowColormap
+VFUNC(int,XSetWindowColormap,V_XSetWindowColormap,_ANSI_ARGS_((Display *, Window, Colormap)))
+#endif /* #ifndef XSetWindowColormap */
+
+#ifndef XStringListToTextProperty
+VFUNC(int,XStringListToTextProperty,V_XStringListToTextProperty,_ANSI_ARGS_((char **, int, XTextProperty *)))
+#endif /* #ifndef XStringListToTextProperty */
+
+#ifndef XStringToKeysym
+VFUNC(KeySym,XStringToKeysym,V_XStringToKeysym,_ANSI_ARGS_((const char *)))
+#endif /* #ifndef XStringToKeysym */
+
+#ifndef XSubtractRegion
+VFUNC(int,XSubtractRegion,V_XSubtractRegion,_ANSI_ARGS_((Region, Region, Region)))
+#endif /* #ifndef XSubtractRegion */
+
+#ifndef XSync
+VFUNC(int,XSync,V_XSync,_ANSI_ARGS_((Display *, int)))
+#endif /* #ifndef XSync */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XTextExtents
+VFUNC(int,XTextExtents,V_XTextExtents,_ANSI_ARGS_((XFontStruct *, const char *, int, int *, int *, int *, XCharStruct *)))
+#endif /* #ifndef XTextExtents */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XTextWidth
+VFUNC(int,XTextWidth,V_XTextWidth,_ANSI_ARGS_((XFontStruct *, const char *, int)))
+#endif /* #ifndef XTextWidth */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XTranslateCoordinates
+VFUNC(int,XTranslateCoordinates,V_XTranslateCoordinates,_ANSI_ARGS_((Display *, Window, Window, int, int, int *, int *, Window *)))
+#endif /* #ifndef XTranslateCoordinates */
+
+#ifndef XUngrabKeyboard
+VFUNC(int,XUngrabKeyboard,V_XUngrabKeyboard,_ANSI_ARGS_((Display *, Time)))
+#endif /* #ifndef XUngrabKeyboard */
+
+#ifndef XUngrabPointer
+VFUNC(int,XUngrabPointer,V_XUngrabPointer,_ANSI_ARGS_((Display *, Time)))
+#endif /* #ifndef XUngrabPointer */
+
+#ifndef XUngrabServer
+VFUNC(int,XUngrabServer,V_XUngrabServer,_ANSI_ARGS_((Display *)))
+#endif /* #ifndef XUngrabServer */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XUnionRectWithRegion
+VFUNC(int,XUnionRectWithRegion,V_XUnionRectWithRegion,_ANSI_ARGS_((XRectangle *, Region, Region)))
+#endif /* #ifndef XUnionRectWithRegion */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XUnmapWindow
+VFUNC(int,XUnmapWindow,V_XUnmapWindow,_ANSI_ARGS_((Display *, Window)))
+#endif /* #ifndef XUnmapWindow */
+
+#ifndef XVisualIDFromVisual
+VFUNC(VisualID,XVisualIDFromVisual,V_XVisualIDFromVisual,_ANSI_ARGS_((Visual *)))
+#endif /* #ifndef XVisualIDFromVisual */
+
+#ifndef DO_X_EXCLUDE
+#ifndef XWarpPointer
+VFUNC(int,XWarpPointer,V_XWarpPointer,_ANSI_ARGS_(( Display *, Window, Window, int, int, unsigned int, unsigned int, int, int )))
+#endif /* #ifndef XWarpPointer */
+#endif /* !DO_X_EXCLUDE */
+
+#ifndef XWindowEvent
+VFUNC(int,XWindowEvent,V_XWindowEvent,_ANSI_ARGS_((Display *, Window, long int, XEvent *)))
+#endif /* #ifndef XWindowEvent */
+
+#ifndef XWithdrawWindow
+VFUNC(int,XWithdrawWindow,V_XWithdrawWindow,_ANSI_ARGS_((Display *, Window, int)))
+#endif /* #ifndef XWithdrawWindow */
+
+#ifndef _XInitImageFuncPtrs
+VFUNC(int,_XInitImageFuncPtrs,V__XInitImageFuncPtrs,_ANSI_ARGS_((XImage *image)))
+#endif /* #ifndef _XInitImageFuncPtrs */
+
+#endif /* _XLIB */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib_f.h
new file mode 100755
index 00000000000..6c0c3773961
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/Xlib_f.h
@@ -0,0 +1,14 @@
+#ifndef XLIB_VT
+#define XLIB_VT
+typedef struct XlibVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "Xlib.t"
+#undef VFUNC
+#undef VVAR
+} XlibVtab;
+extern XlibVtab *XlibVptr;
+extern XlibVtab *XlibVGet(void);
+#endif /* XLIB_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/limits.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/limits.h
new file mode 100755
index 00000000000..66eb54256cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/limits.h
@@ -0,0 +1,22 @@
+/*
+ * limits.h --
+ *
+ * This is a dummy header file to #include in Tcl when there
+ * is no limits.h in /usr/include. There are only a few
+ * definitions here; also see tclPort.h, which already
+ * #defines some of the things here if they're not arleady
+ * defined.
+ *
+ * Copyright (c) 1991 The Regents of the University of California.
+ * 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.
+ *
+ * SCCS: @(#) limits.h 1.7 96/02/15 14:43:55
+ */
+
+#define LONG_MIN 0x80000000
+#define LONG_MAX 0x7fffffff
+#define INT_MIN 0x80000000
+#define INT_MAX 0x7fffffff
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/stdlib.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/stdlib.h
new file mode 100755
index 00000000000..548f880a19a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/stdlib.h
@@ -0,0 +1,45 @@
+/*
+ * stdlib.h --
+ *
+ * Declares facilities exported by the "stdlib" portion of
+ * the C library. This file isn't complete in the ANSI-C
+ * sense; it only declares things that are needed by Tcl.
+ * This file is needed even on many systems with their own
+ * stdlib.h (e.g. SunOS) because not all stdlib.h files
+ * declare all the procedures needed here (such as strtod).
+ *
+ * Copyright (c) 1991 The Regents of the University of California.
+ * 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.
+ *
+ * @(#) stdlib.h 1.9 94/12/17 16:26:20
+ */
+
+#ifndef _STDLIB
+#define _STDLIB
+
+#include <Lang.h>
+
+extern void abort _ANSI_ARGS_((void));
+extern double atof _ANSI_ARGS_((CONST char *string));
+extern int atoi _ANSI_ARGS_((CONST char *string));
+extern long atol _ANSI_ARGS_((CONST char *string));
+extern char * calloc _ANSI_ARGS_((unsigned int numElements,
+ unsigned int size));
+extern void exit _ANSI_ARGS_((int status));
+extern int free _ANSI_ARGS_((char *blockPtr));
+extern char * getenv _ANSI_ARGS_((CONST char *name));
+extern char * malloc _ANSI_ARGS_((unsigned int numBytes));
+extern void qsort _ANSI_ARGS_((VOID *base, int n, int size,
+ int (*compar)(CONST VOID *element1, CONST VOID
+ *element2)));
+extern char * realloc _ANSI_ARGS_((char *ptr, unsigned int numBytes));
+extern double strtod _ANSI_ARGS_((CONST char *string, char **endPtr));
+extern long strtol _ANSI_ARGS_((CONST char *string, char **endPtr,
+ int base));
+extern unsigned long strtoul _ANSI_ARGS_((CONST char *string,
+ char **endPtr, int base));
+
+#endif /* _STDLIB */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/unistd.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/unistd.h
new file mode 100755
index 00000000000..47717e0278c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/compat/unistd.h
@@ -0,0 +1,87 @@
+/*
+ * unistd.h --
+ *
+ * Macros, CONSTants and prototypes for Posix conformance.
+ *
+ * Copyright 1989 Regents of the University of California
+ * Permission to use, copy, modify, and distribute this
+ * software and its documentation for any purpose and without
+ * fee is hereby granted, provided that the above copyright
+ * notice appear in all copies. The University of California
+ * makes no representations about the suitability of this
+ * software for any purpose. It is provided "as is" without
+ * express or implied warranty.
+ *
+ * $Header: /home/auspex6/CVSROOT/tcl/compat/unistd.h,v 1.1.1.1 1993/11/29 10:44:47 a904209 Exp $
+ */
+
+#ifndef _UNISTD
+#define _UNISTD
+
+#include <sys/types.h>
+#ifndef _TCL
+# include "../Lang.h"
+#endif
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+#ifndef LSEEK_TYPE
+#define LSEEK_TYPE long
+#endif
+
+/*
+ * Strict POSIX stuff goes here. Extensions go down below, in the
+ * ifndef _POSIX_SOURCE section.
+ */
+
+extern void _exit _ANSI_ARGS_((int status));
+extern int access _ANSI_ARGS_((CONST char *path, int mode));
+extern int chdir _ANSI_ARGS_((CONST char *path));
+extern int chown _ANSI_ARGS_((CONST char *path, uid_t owner, gid_t group));
+extern int close _ANSI_ARGS_((int fd));
+extern int dup _ANSI_ARGS_((int oldfd));
+extern int dup2 _ANSI_ARGS_((int oldfd, int newfd));
+extern int execl _ANSI_ARGS_((CONST char *path, ...));
+extern int execle _ANSI_ARGS_((CONST char *path, ...));
+extern int execlp _ANSI_ARGS_((CONST char *file, ...));
+extern int execv _ANSI_ARGS_((CONST char *path, char **argv));
+extern int execve _ANSI_ARGS_((CONST char *path, char **argv, char **envp));
+extern int execvp _ANSI_ARGS_((CONST char *file, char **argv));
+extern pid_t fork _ANSI_ARGS_((void));
+extern char *getcwd _ANSI_ARGS_((char *buf, size_t size));
+extern gid_t getegid _ANSI_ARGS_((void));
+extern uid_t geteuid _ANSI_ARGS_((void));
+extern gid_t getgid _ANSI_ARGS_((void));
+extern int getgroups _ANSI_ARGS_((int bufSize, int *buffer));
+extern pid_t getpid _ANSI_ARGS_((void));
+extern uid_t getuid _ANSI_ARGS_((void));
+extern int isatty _ANSI_ARGS_((int fd));
+extern long lseek _ANSI_ARGS_((int fd, LSEEK_TYPE offset, int whence));
+extern int pipe _ANSI_ARGS_((int *fildes));
+extern int read _ANSI_ARGS_((int fd, char *buf, size_t size));
+extern int setgid _ANSI_ARGS_((gid_t group));
+extern int setuid _ANSI_ARGS_((uid_t user));
+extern unsigned sleep _ANSI_ARGS_ ((unsigned seconds));
+extern char *ttyname _ANSI_ARGS_((int fd));
+extern int unlink _ANSI_ARGS_((CONST char *path));
+extern int write _ANSI_ARGS_((int fd, CONST char *buf, size_t size));
+
+#ifndef _POSIX_SOURCE
+extern char *crypt _ANSI_ARGS_((CONST char *, CONST char *));
+extern int fchown _ANSI_ARGS_((int fd, uid_t owner, gid_t group));
+extern int flock _ANSI_ARGS_((int fd, int operation));
+extern int ftruncate _ANSI_ARGS_((int fd, unsigned long length));
+extern int readlink _ANSI_ARGS_((CONST char *path, char *buf, int bufsize));
+extern int setegid _ANSI_ARGS_((gid_t group));
+extern int seteuid _ANSI_ARGS_((uid_t user));
+extern int setreuid _ANSI_ARGS_((int ruid, int euid));
+extern int symlink _ANSI_ARGS_((CONST char *, CONST char *));
+extern int ttyslot _ANSI_ARGS_((void));
+extern int truncate _ANSI_ARGS_((CONST char *path, unsigned long length));
+extern int vfork _ANSI_ARGS_((void));
+#endif /* _POSIX_SOURCE */
+
+#endif /* _UNISTD */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/default.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/default.h
new file mode 100755
index 00000000000..5f7f24d546e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/default.h
@@ -0,0 +1,36 @@
+/*
+ * default.h --
+ *
+ * This file defines the defaults for all options for all of
+ * the Tk widgets.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * 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.
+ *
+ * RCS: @(#) $Id: default.h,v 1.4 2002/08/31 06:12:19 das Exp $
+ */
+
+#ifndef _DEFAULT
+#define _DEFAULT
+
+#if defined(__WIN32__) || defined(_WIN32) || \
+ (defined(__CYGWIN__) && !defined(WINARCH_X)) || defined(__MINGW32__)
+# include "tkWinDefault.h"
+#else
+# if defined(MAC_OSX_TK)
+# include "tkMacOSXDefault.h"
+# elif defined(MAC_TCL)
+# include "tkMacDefault.h"
+# else
+# ifdef __PM__
+# include "tkOS2Default.h"
+# else
+# include "tkUnixDefault.h"
+# endif
+# endif
+#endif
+
+#endif /* _DEFAULT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/img.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/img.h
new file mode 100755
index 00000000000..a1b38a7ebd8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/img.h
@@ -0,0 +1,41 @@
+/* img.h */
+
+#ifndef _IMG
+#define _IMG
+
+#include "Lang.h"
+#include "tk.h"
+
+#define IMG_MAJOR_VERSION 1
+#define IMG_MINOR_VERSION 2
+#define IMG_RELEASE_LEVEL 1
+#define IMG_RELEASE_SERIAL 2
+
+#define IMG_VERSION "1.2"
+#define IMG_PATCH_LEVEL "1.2.4"
+
+#ifndef RESOURCE_INCLUDED
+
+#if defined(__WIN32__)
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+# undef WIN32_LEAN_AND_MEAN
+# if defined(_MSC_VER)
+# define EXPORT(a,b) __declspec(dllexport) a b
+# else
+# if defined(__BORLANDC__)
+# define EXPORT(a,b) a _export b
+# else
+# define EXPORT(a,b) a b
+# endif
+# endif
+#else
+# define EXPORT(a,b) a b
+#endif
+
+EXTERN EXPORT(int,Img_Init) _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN EXPORT(int,Img_SafeInit) _ANSI_ARGS_((Tcl_Interp *interp));
+
+#endif /* RESOURCE_INCLUDED */
+
+#endif /* _IMG */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.h
new file mode 100755
index 00000000000..8cca12aa095
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.h
@@ -0,0 +1,75 @@
+/* imgInt.h */
+
+#ifndef _IMGINT
+#define _IMGINT
+
+#include "tkInt.h"
+
+#ifndef RESOURCE_INCLUDED
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+#include "img.h"
+
+typedef struct {
+ Tcl_DString *buffer;/* pointer to dynamical string */
+ char *data; /* mmencoded source string */
+ int c; /* bits left over from previous char */
+ int state; /* decoder state (0-4 or IMG_DONE) */
+ int length; /* length of phisical line already written */
+} MFile;
+
+#define IMG_SPECIAL (1<<8)
+#define IMG_PAD (IMG_SPECIAL+1)
+#define IMG_SPACE (IMG_SPECIAL+2)
+#define IMG_BAD (IMG_SPECIAL+3)
+#define IMG_DONE (IMG_SPECIAL+4)
+#define IMG_CHAN (IMG_SPECIAL+5)
+#define IMG_STRING (IMG_SPECIAL+6)
+
+#define IMG_TCL (1<<9)
+#define IMG_OBJS (1<<10)
+#define IMG_PERL (1<<11)
+#define IMG_UTF (1<<12)
+
+EXTERN int ImgPhotoPutBlock _ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr, int x, int y, int width, int height));
+
+EXTERN int ImgLoadLib _ANSI_ARGS_((Tcl_Interp *interp, CONST char *libName,
+ VOID **handlePtr, char **symbols, int num));
+EXTERN void ImgLoadFailed _ANSI_ARGS_((VOID **handlePtr));
+
+EXTERN int ImgObjInit _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN char *ImgGetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int *lengthPtr));
+EXTERN char *ImgGetByteArrayFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int *lengthPtr));
+EXTERN int ImgListObjGetElements _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *argc, Tcl_Obj ***objv));
+
+EXTERN int ImgGetc _ANSI_ARGS_((MFile *handle));
+EXTERN int ImgRead _ANSI_ARGS_((MFile *handle, char *dst, int count));
+EXTERN int ImgPutc _ANSI_ARGS_((int c, MFile *handle));
+EXTERN int ImgWrite _ANSI_ARGS_((MFile *handle, CONST char *src, int count));
+EXTERN void ImgWriteInit _ANSI_ARGS_((Tcl_DString *buffer, MFile *handle));
+EXTERN int ImgReadInit _ANSI_ARGS_((Tcl_Obj *data, int c, MFile *handle));
+EXTERN Tcl_Channel ImgOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *fileName, int permissions));
+EXTERN void ImgFixChanMatchProc _ANSI_ARGS_((Tcl_Interp **interp, Tcl_Channel *chan,
+ Tcl_Obj **file, Tcl_Obj **format, int **width, int **height));
+EXTERN void ImgFixObjMatchProc _ANSI_ARGS_((Tcl_Interp **interp, Tcl_Obj **data,
+ Tcl_Obj **format, int **width, int **height));
+EXTERN void ImgFixStringWriteProc _ANSI_ARGS_((Tcl_DString *data, Tcl_Interp **interp,
+ Tcl_DString **dataPtr, Tcl_Obj **format, Tk_PhotoImageBlock **blockPtr));
+
+EXTERN int ImgInitTIFFzip _ANSI_ARGS_((VOID *, int));
+EXTERN int ImgInitTIFFjpeg _ANSI_ARGS_((VOID *, int));
+EXTERN int ImgInitTIFFpixar _ANSI_ARGS_((VOID *, int));
+EXTERN int ImgLoadJpegLibrary _ANSI_ARGS_((void));
+
+#endif /* RESOURCE_INCLUDED */
+
+#endif /* _IMGINT */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.m
new file mode 100755
index 00000000000..0ac6a144b4b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.m
@@ -0,0 +1,62 @@
+#ifndef _IMGINT_VM
+#define _IMGINT_VM
+#include "imgInt_f.h"
+#ifndef NO_VTABLES
+#ifndef ImgFixChanMatchProc
+# define ImgFixChanMatchProc (*ImgintVptr->V_ImgFixChanMatchProc)
+#endif
+
+#ifndef ImgFixObjMatchProc
+# define ImgFixObjMatchProc (*ImgintVptr->V_ImgFixObjMatchProc)
+#endif
+
+#ifndef ImgFixStringWriteProc
+# define ImgFixStringWriteProc (*ImgintVptr->V_ImgFixStringWriteProc)
+#endif
+
+#ifndef ImgGetByteArrayFromObj
+# define ImgGetByteArrayFromObj (*ImgintVptr->V_ImgGetByteArrayFromObj)
+#endif
+
+#ifndef ImgGetc
+# define ImgGetc (*ImgintVptr->V_ImgGetc)
+#endif
+
+#ifndef ImgListObjGetElements
+# define ImgListObjGetElements (*ImgintVptr->V_ImgListObjGetElements)
+#endif
+
+#ifndef ImgObjInit
+# define ImgObjInit (*ImgintVptr->V_ImgObjInit)
+#endif
+
+#ifndef ImgOpenFileChannel
+# define ImgOpenFileChannel (*ImgintVptr->V_ImgOpenFileChannel)
+#endif
+
+#ifndef ImgPhotoPutBlock
+# define ImgPhotoPutBlock (*ImgintVptr->V_ImgPhotoPutBlock)
+#endif
+
+#ifndef ImgPutc
+# define ImgPutc (*ImgintVptr->V_ImgPutc)
+#endif
+
+#ifndef ImgRead
+# define ImgRead (*ImgintVptr->V_ImgRead)
+#endif
+
+#ifndef ImgReadInit
+# define ImgReadInit (*ImgintVptr->V_ImgReadInit)
+#endif
+
+#ifndef ImgWrite
+# define ImgWrite (*ImgintVptr->V_ImgWrite)
+#endif
+
+#ifndef ImgWriteInit
+# define ImgWriteInit (*ImgintVptr->V_ImgWriteInit)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _IMGINT_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.t
new file mode 100755
index 00000000000..6f20d9a332b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt.t
@@ -0,0 +1,93 @@
+#ifdef _IMGINT
+#ifndef ImgFixChanMatchProc
+#ifndef RESOURCE_INCLUDED
+VFUNC(void,ImgFixChanMatchProc,V_ImgFixChanMatchProc,_ANSI_ARGS_((Tcl_Interp **interp, Tcl_Channel *chan,
+ Tcl_Obj **file, Tcl_Obj **format, int **width, int **height)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgFixChanMatchProc */
+
+#ifndef ImgFixObjMatchProc
+#ifndef RESOURCE_INCLUDED
+VFUNC(void,ImgFixObjMatchProc,V_ImgFixObjMatchProc,_ANSI_ARGS_((Tcl_Interp **interp, Tcl_Obj **data,
+ Tcl_Obj **format, int **width, int **height)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgFixObjMatchProc */
+
+#ifndef ImgFixStringWriteProc
+#ifndef RESOURCE_INCLUDED
+VFUNC(void,ImgFixStringWriteProc,V_ImgFixStringWriteProc,_ANSI_ARGS_((Tcl_DString *data, Tcl_Interp **interp,
+ Tcl_DString **dataPtr, Tcl_Obj **format, Tk_PhotoImageBlock **blockPtr)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgFixStringWriteProc */
+
+#ifndef ImgGetByteArrayFromObj
+#ifndef RESOURCE_INCLUDED
+VFUNC(char *,ImgGetByteArrayFromObj,V_ImgGetByteArrayFromObj,_ANSI_ARGS_((Tcl_Obj *objPtr,
+ int *lengthPtr)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgGetByteArrayFromObj */
+
+#ifndef ImgGetc
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgGetc,V_ImgGetc,_ANSI_ARGS_((MFile *handle)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgGetc */
+
+#ifndef ImgListObjGetElements
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgListObjGetElements,V_ImgListObjGetElements,_ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *argc, Tcl_Obj ***objv)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgListObjGetElements */
+
+#ifndef ImgObjInit
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgObjInit,V_ImgObjInit,_ANSI_ARGS_((Tcl_Interp *interp)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgObjInit */
+
+#ifndef ImgOpenFileChannel
+#ifndef RESOURCE_INCLUDED
+VFUNC(Tcl_Channel,ImgOpenFileChannel,V_ImgOpenFileChannel,_ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *fileName, int permissions)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgOpenFileChannel */
+
+#ifndef ImgPhotoPutBlock
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgPhotoPutBlock,V_ImgPhotoPutBlock,_ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr, int x, int y, int width, int height)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgPhotoPutBlock */
+
+#ifndef ImgPutc
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgPutc,V_ImgPutc,_ANSI_ARGS_((int c, MFile *handle)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgPutc */
+
+#ifndef ImgRead
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgRead,V_ImgRead,_ANSI_ARGS_((MFile *handle, char *dst, int count)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgRead */
+
+#ifndef ImgReadInit
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgReadInit,V_ImgReadInit,_ANSI_ARGS_((Tcl_Obj *data, int c, MFile *handle)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgReadInit */
+
+#ifndef ImgWrite
+#ifndef RESOURCE_INCLUDED
+VFUNC(int,ImgWrite,V_ImgWrite,_ANSI_ARGS_((MFile *handle, CONST char *src, int count)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgWrite */
+
+#ifndef ImgWriteInit
+#ifndef RESOURCE_INCLUDED
+VFUNC(void,ImgWriteInit,V_ImgWriteInit,_ANSI_ARGS_((Tcl_DString *buffer, MFile *handle)))
+#endif /* #ifndef RESOURCE_INCLUDED */
+#endif /* #ifndef ImgWriteInit */
+
+#endif /* _IMGINT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt_f.h
new file mode 100755
index 00000000000..4e05f81a81c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/imgInt_f.h
@@ -0,0 +1,14 @@
+#ifndef IMGINT_VT
+#define IMGINT_VT
+typedef struct ImgintVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "imgInt.t"
+#undef VFUNC
+#undef VVAR
+} ImgintVtab;
+extern ImgintVtab *ImgintVptr;
+extern ImgintVtab *ImgintVGet(void);
+#endif /* IMGINT_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/ks_names.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/ks_names.h
new file mode 100755
index 00000000000..e0622ae7319
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/ks_names.h
@@ -0,0 +1,925 @@
+/*
+ * This file is generated from $(INCLUDESRC)/keysymdef.h. Do not edit.
+ * RCS: $Id: ks_names.h,v 1.4 2000/04/15 00:33:08 ericm Exp $
+ */
+{ "BackSpace", 0xFF08 },
+{ "Tab", 0xFF09 },
+{ "Linefeed", 0xFF0A },
+{ "Clear", 0xFF0B },
+{ "Return", 0xFF0D },
+{ "Pause", 0xFF13 },
+{ "Scroll_Lock", 0xFF14 },
+{ "Sys_Req", 0xFF15 },
+{ "Escape", 0xFF1B },
+{ "Delete", 0xFFFF },
+{ "Multi_key", 0xFF20 },
+{ "Kanji", 0xFF21 },
+{ "Home", 0xFF50 },
+{ "Left", 0xFF51 },
+{ "Up", 0xFF52 },
+{ "Right", 0xFF53 },
+{ "Down", 0xFF54 },
+{ "Prior", 0xFF55 },
+{ "Next", 0xFF56 },
+{ "End", 0xFF57 },
+{ "Begin", 0xFF58 },
+{ "Win_L", 0xFF5B },
+{ "Win_R", 0xFF5C },
+{ "App", 0xFF5D },
+{ "Select", 0xFF60 },
+{ "Print", 0xFF61 },
+{ "Execute", 0xFF62 },
+{ "Insert", 0xFF63 },
+{ "Undo", 0xFF65 },
+{ "Redo", 0xFF66 },
+{ "Menu", 0xFF67 },
+{ "Find", 0xFF68 },
+{ "Cancel", 0xFF69 },
+{ "Help", 0xFF6A },
+{ "Break", 0xFF6B },
+{ "Mode_switch", 0xFF7E },
+{ "script_switch", 0xFF7E },
+{ "Num_Lock", 0xFF7F },
+{ "KP_Space", 0xFF80 },
+{ "KP_Tab", 0xFF89 },
+{ "KP_Enter", 0xFF8D },
+{ "KP_F1", 0xFF91 },
+{ "KP_F2", 0xFF92 },
+{ "KP_F3", 0xFF93 },
+{ "KP_F4", 0xFF94 },
+{ "KP_Equal", 0xFFBD },
+{ "KP_Multiply", 0xFFAA },
+{ "KP_Add", 0xFFAB },
+{ "KP_Separator", 0xFFAC },
+{ "KP_Subtract", 0xFFAD },
+{ "KP_Decimal", 0xFFAE },
+{ "KP_Divide", 0xFFAF },
+{ "KP_0", 0xFFB0 },
+{ "KP_1", 0xFFB1 },
+{ "KP_2", 0xFFB2 },
+{ "KP_3", 0xFFB3 },
+{ "KP_4", 0xFFB4 },
+{ "KP_5", 0xFFB5 },
+{ "KP_6", 0xFFB6 },
+{ "KP_7", 0xFFB7 },
+{ "KP_8", 0xFFB8 },
+{ "KP_9", 0xFFB9 },
+{ "F1", 0xFFBE },
+{ "F2", 0xFFBF },
+{ "F3", 0xFFC0 },
+{ "F4", 0xFFC1 },
+{ "F5", 0xFFC2 },
+{ "F6", 0xFFC3 },
+{ "F7", 0xFFC4 },
+{ "F8", 0xFFC5 },
+{ "F9", 0xFFC6 },
+{ "F10", 0xFFC7 },
+{ "F11", 0xFFC8 },
+{ "L1", 0xFFC8 },
+{ "F12", 0xFFC9 },
+{ "L2", 0xFFC9 },
+{ "F13", 0xFFCA },
+{ "L3", 0xFFCA },
+{ "F14", 0xFFCB },
+{ "L4", 0xFFCB },
+{ "F15", 0xFFCC },
+{ "L5", 0xFFCC },
+{ "F16", 0xFFCD },
+{ "L6", 0xFFCD },
+{ "F17", 0xFFCE },
+{ "L7", 0xFFCE },
+{ "F18", 0xFFCF },
+{ "L8", 0xFFCF },
+{ "F19", 0xFFD0 },
+{ "L9", 0xFFD0 },
+{ "F20", 0xFFD1 },
+{ "L10", 0xFFD1 },
+{ "F21", 0xFFD2 },
+{ "R1", 0xFFD2 },
+{ "F22", 0xFFD3 },
+{ "R2", 0xFFD3 },
+{ "F23", 0xFFD4 },
+{ "R3", 0xFFD4 },
+{ "F24", 0xFFD5 },
+{ "R4", 0xFFD5 },
+{ "F25", 0xFFD6 },
+{ "R5", 0xFFD6 },
+{ "F26", 0xFFD7 },
+{ "R6", 0xFFD7 },
+{ "F27", 0xFFD8 },
+{ "R7", 0xFFD8 },
+{ "F28", 0xFFD9 },
+{ "R8", 0xFFD9 },
+{ "F29", 0xFFDA },
+{ "R9", 0xFFDA },
+{ "F30", 0xFFDB },
+{ "R10", 0xFFDB },
+{ "F31", 0xFFDC },
+{ "R11", 0xFFDC },
+{ "F32", 0xFFDD },
+{ "R12", 0xFFDD },
+{ "R13", 0xFFDE },
+{ "F33", 0xFFDE },
+{ "F34", 0xFFDF },
+{ "R14", 0xFFDF },
+{ "F35", 0xFFE0 },
+{ "R15", 0xFFE0 },
+{ "Shift_L", 0xFFE1 },
+{ "Shift_R", 0xFFE2 },
+{ "Control_L", 0xFFE3 },
+{ "Control_R", 0xFFE4 },
+{ "Caps_Lock", 0xFFE5 },
+{ "Shift_Lock", 0xFFE6 },
+{ "Meta_L", 0xFFE7 },
+{ "Meta_R", 0xFFE8 },
+{ "Alt_L", 0xFFE9 },
+{ "Alt_R", 0xFFEA },
+{ "Super_L", 0xFFEB },
+{ "Super_R", 0xFFEC },
+{ "Hyper_L", 0xFFED },
+{ "Hyper_R", 0xFFEE },
+{ "space", 0x020 },
+{ "exclam", 0x021 },
+{ "quotedbl", 0x022 },
+{ "numbersign", 0x023 },
+{ "dollar", 0x024 },
+{ "percent", 0x025 },
+{ "ampersand", 0x026 },
+{ "quoteright", 0x027 },
+{ "parenleft", 0x028 },
+{ "parenright", 0x029 },
+{ "asterisk", 0x02a },
+{ "plus", 0x02b },
+{ "comma", 0x02c },
+{ "minus", 0x02d },
+{ "period", 0x02e },
+{ "slash", 0x02f },
+{ "0", 0x030 },
+{ "1", 0x031 },
+{ "2", 0x032 },
+{ "3", 0x033 },
+{ "4", 0x034 },
+{ "5", 0x035 },
+{ "6", 0x036 },
+{ "7", 0x037 },
+{ "8", 0x038 },
+{ "9", 0x039 },
+{ "colon", 0x03a },
+{ "semicolon", 0x03b },
+{ "less", 0x03c },
+{ "equal", 0x03d },
+{ "greater", 0x03e },
+{ "question", 0x03f },
+{ "at", 0x040 },
+{ "A", 0x041 },
+{ "B", 0x042 },
+{ "C", 0x043 },
+{ "D", 0x044 },
+{ "E", 0x045 },
+{ "F", 0x046 },
+{ "G", 0x047 },
+{ "H", 0x048 },
+{ "I", 0x049 },
+{ "J", 0x04a },
+{ "K", 0x04b },
+{ "L", 0x04c },
+{ "M", 0x04d },
+{ "N", 0x04e },
+{ "O", 0x04f },
+{ "P", 0x050 },
+{ "Q", 0x051 },
+{ "R", 0x052 },
+{ "S", 0x053 },
+{ "T", 0x054 },
+{ "U", 0x055 },
+{ "V", 0x056 },
+{ "W", 0x057 },
+{ "X", 0x058 },
+{ "Y", 0x059 },
+{ "Z", 0x05a },
+{ "bracketleft", 0x05b },
+{ "backslash", 0x05c },
+{ "bracketright", 0x05d },
+{ "asciicircum", 0x05e },
+{ "underscore", 0x05f },
+{ "quoteleft", 0x060 },
+{ "a", 0x061 },
+{ "b", 0x062 },
+{ "c", 0x063 },
+{ "d", 0x064 },
+{ "e", 0x065 },
+{ "f", 0x066 },
+{ "g", 0x067 },
+{ "h", 0x068 },
+{ "i", 0x069 },
+{ "j", 0x06a },
+{ "k", 0x06b },
+{ "l", 0x06c },
+{ "m", 0x06d },
+{ "n", 0x06e },
+{ "o", 0x06f },
+{ "p", 0x070 },
+{ "q", 0x071 },
+{ "r", 0x072 },
+{ "s", 0x073 },
+{ "t", 0x074 },
+{ "u", 0x075 },
+{ "v", 0x076 },
+{ "w", 0x077 },
+{ "x", 0x078 },
+{ "y", 0x079 },
+{ "z", 0x07a },
+{ "braceleft", 0x07b },
+{ "bar", 0x07c },
+{ "braceright", 0x07d },
+{ "asciitilde", 0x07e },
+{ "nobreakspace", 0x0a0 },
+{ "exclamdown", 0x0a1 },
+{ "cent", 0x0a2 },
+{ "sterling", 0x0a3 },
+{ "currency", 0x0a4 },
+{ "yen", 0x0a5 },
+{ "brokenbar", 0x0a6 },
+{ "section", 0x0a7 },
+{ "diaeresis", 0x0a8 },
+{ "copyright", 0x0a9 },
+{ "ordfeminine", 0x0aa },
+{ "guillemotleft", 0x0ab },
+{ "notsign", 0x0ac },
+{ "hyphen", 0x0ad },
+{ "registered", 0x0ae },
+{ "macron", 0x0af },
+{ "degree", 0x0b0 },
+{ "plusminus", 0x0b1 },
+{ "twosuperior", 0x0b2 },
+{ "threesuperior", 0x0b3 },
+{ "acute", 0x0b4 },
+{ "mu", 0x0b5 },
+{ "paragraph", 0x0b6 },
+{ "periodcentered", 0x0b7 },
+{ "cedilla", 0x0b8 },
+{ "onesuperior", 0x0b9 },
+{ "masculine", 0x0ba },
+{ "guillemotright", 0x0bb },
+{ "onequarter", 0x0bc },
+{ "onehalf", 0x0bd },
+{ "threequarters", 0x0be },
+{ "questiondown", 0x0bf },
+{ "Agrave", 0x0c0 },
+{ "Aacute", 0x0c1 },
+{ "Acircumflex", 0x0c2 },
+{ "Atilde", 0x0c3 },
+{ "Adiaeresis", 0x0c4 },
+{ "Aring", 0x0c5 },
+{ "AE", 0x0c6 },
+{ "Ccedilla", 0x0c7 },
+{ "Egrave", 0x0c8 },
+{ "Eacute", 0x0c9 },
+{ "Ecircumflex", 0x0ca },
+{ "Ediaeresis", 0x0cb },
+{ "Igrave", 0x0cc },
+{ "Iacute", 0x0cd },
+{ "Icircumflex", 0x0ce },
+{ "Idiaeresis", 0x0cf },
+{ "Eth", 0x0d0 },
+{ "Ntilde", 0x0d1 },
+{ "Ograve", 0x0d2 },
+{ "Oacute", 0x0d3 },
+{ "Ocircumflex", 0x0d4 },
+{ "Otilde", 0x0d5 },
+{ "Odiaeresis", 0x0d6 },
+{ "multiply", 0x0d7 },
+{ "Ooblique", 0x0d8 },
+{ "Ugrave", 0x0d9 },
+{ "Uacute", 0x0da },
+{ "Ucircumflex", 0x0db },
+{ "Udiaeresis", 0x0dc },
+{ "Yacute", 0x0dd },
+{ "Thorn", 0x0de },
+{ "ssharp", 0x0df },
+{ "agrave", 0x0e0 },
+{ "aacute", 0x0e1 },
+{ "acircumflex", 0x0e2 },
+{ "atilde", 0x0e3 },
+{ "adiaeresis", 0x0e4 },
+{ "aring", 0x0e5 },
+{ "ae", 0x0e6 },
+{ "ccedilla", 0x0e7 },
+{ "egrave", 0x0e8 },
+{ "eacute", 0x0e9 },
+{ "ecircumflex", 0x0ea },
+{ "ediaeresis", 0x0eb },
+{ "igrave", 0x0ec },
+{ "iacute", 0x0ed },
+{ "icircumflex", 0x0ee },
+{ "idiaeresis", 0x0ef },
+{ "eth", 0x0f0 },
+{ "ntilde", 0x0f1 },
+{ "ograve", 0x0f2 },
+{ "oacute", 0x0f3 },
+{ "ocircumflex", 0x0f4 },
+{ "otilde", 0x0f5 },
+{ "odiaeresis", 0x0f6 },
+{ "division", 0x0f7 },
+{ "oslash", 0x0f8 },
+{ "ugrave", 0x0f9 },
+{ "uacute", 0x0fa },
+{ "ucircumflex", 0x0fb },
+{ "udiaeresis", 0x0fc },
+{ "yacute", 0x0fd },
+{ "thorn", 0x0fe },
+{ "ydiaeresis", 0x0ff },
+{ "Aogonek", 0x1a1 },
+{ "breve", 0x1a2 },
+{ "Lstroke", 0x1a3 },
+{ "Lcaron", 0x1a5 },
+{ "Sacute", 0x1a6 },
+{ "Scaron", 0x1a9 },
+{ "Scedilla", 0x1aa },
+{ "Tcaron", 0x1ab },
+{ "Zacute", 0x1ac },
+{ "Zcaron", 0x1ae },
+{ "Zabovedot", 0x1af },
+{ "aogonek", 0x1b1 },
+{ "ogonek", 0x1b2 },
+{ "lstroke", 0x1b3 },
+{ "lcaron", 0x1b5 },
+{ "sacute", 0x1b6 },
+{ "caron", 0x1b7 },
+{ "scaron", 0x1b9 },
+{ "scedilla", 0x1ba },
+{ "tcaron", 0x1bb },
+{ "zacute", 0x1bc },
+{ "doubleacute", 0x1bd },
+{ "zcaron", 0x1be },
+{ "zabovedot", 0x1bf },
+{ "Racute", 0x1c0 },
+{ "Abreve", 0x1c3 },
+{ "Cacute", 0x1c6 },
+{ "Ccaron", 0x1c8 },
+{ "Eogonek", 0x1ca },
+{ "Ecaron", 0x1cc },
+{ "Dcaron", 0x1cf },
+{ "Nacute", 0x1d1 },
+{ "Ncaron", 0x1d2 },
+{ "Odoubleacute", 0x1d5 },
+{ "Rcaron", 0x1d8 },
+{ "Uring", 0x1d9 },
+{ "Udoubleacute", 0x1db },
+{ "Tcedilla", 0x1de },
+{ "racute", 0x1e0 },
+{ "abreve", 0x1e3 },
+{ "cacute", 0x1e6 },
+{ "ccaron", 0x1e8 },
+{ "eogonek", 0x1ea },
+{ "ecaron", 0x1ec },
+{ "dcaron", 0x1ef },
+{ "nacute", 0x1f1 },
+{ "ncaron", 0x1f2 },
+{ "odoubleacute", 0x1f5 },
+{ "udoubleacute", 0x1fb },
+{ "rcaron", 0x1f8 },
+{ "uring", 0x1f9 },
+{ "tcedilla", 0x1fe },
+{ "abovedot", 0x1ff },
+{ "Hstroke", 0x2a1 },
+{ "Hcircumflex", 0x2a6 },
+{ "Iabovedot", 0x2a9 },
+{ "Gbreve", 0x2ab },
+{ "Jcircumflex", 0x2ac },
+{ "hstroke", 0x2b1 },
+{ "hcircumflex", 0x2b6 },
+{ "idotless", 0x2b9 },
+{ "gbreve", 0x2bb },
+{ "jcircumflex", 0x2bc },
+{ "Cabovedot", 0x2c5 },
+{ "Ccircumflex", 0x2c6 },
+{ "Gabovedot", 0x2d5 },
+{ "Gcircumflex", 0x2d8 },
+{ "Ubreve", 0x2dd },
+{ "Scircumflex", 0x2de },
+{ "cabovedot", 0x2e5 },
+{ "ccircumflex", 0x2e6 },
+{ "gabovedot", 0x2f5 },
+{ "gcircumflex", 0x2f8 },
+{ "ubreve", 0x2fd },
+{ "scircumflex", 0x2fe },
+{ "kappa", 0x3a2 },
+{ "Rcedilla", 0x3a3 },
+{ "Itilde", 0x3a5 },
+{ "Lcedilla", 0x3a6 },
+{ "Emacron", 0x3aa },
+{ "Gcedilla", 0x3ab },
+{ "Tslash", 0x3ac },
+{ "rcedilla", 0x3b3 },
+{ "itilde", 0x3b5 },
+{ "lcedilla", 0x3b6 },
+{ "emacron", 0x3ba },
+{ "gacute", 0x3bb },
+{ "tslash", 0x3bc },
+{ "ENG", 0x3bd },
+{ "eng", 0x3bf },
+{ "Amacron", 0x3c0 },
+{ "Iogonek", 0x3c7 },
+{ "Eabovedot", 0x3cc },
+{ "Imacron", 0x3cf },
+{ "Ncedilla", 0x3d1 },
+{ "Omacron", 0x3d2 },
+{ "Kcedilla", 0x3d3 },
+{ "Uogonek", 0x3d9 },
+{ "Utilde", 0x3dd },
+{ "Umacron", 0x3de },
+{ "amacron", 0x3e0 },
+{ "iogonek", 0x3e7 },
+{ "eabovedot", 0x3ec },
+{ "imacron", 0x3ef },
+{ "ncedilla", 0x3f1 },
+{ "omacron", 0x3f2 },
+{ "kcedilla", 0x3f3 },
+{ "uogonek", 0x3f9 },
+{ "utilde", 0x3fd },
+{ "umacron", 0x3fe },
+{ "overline", 0x47e },
+{ "kana_fullstop", 0x4a1 },
+{ "kana_openingbracket", 0x4a2 },
+{ "kana_closingbracket", 0x4a3 },
+{ "kana_comma", 0x4a4 },
+{ "kana_middledot", 0x4a5 },
+{ "kana_WO", 0x4a6 },
+{ "kana_a", 0x4a7 },
+{ "kana_i", 0x4a8 },
+{ "kana_u", 0x4a9 },
+{ "kana_e", 0x4aa },
+{ "kana_o", 0x4ab },
+{ "kana_ya", 0x4ac },
+{ "kana_yu", 0x4ad },
+{ "kana_yo", 0x4ae },
+{ "kana_tu", 0x4af },
+{ "prolongedsound", 0x4b0 },
+{ "kana_A", 0x4b1 },
+{ "kana_I", 0x4b2 },
+{ "kana_U", 0x4b3 },
+{ "kana_E", 0x4b4 },
+{ "kana_O", 0x4b5 },
+{ "kana_KA", 0x4b6 },
+{ "kana_KI", 0x4b7 },
+{ "kana_KU", 0x4b8 },
+{ "kana_KE", 0x4b9 },
+{ "kana_KO", 0x4ba },
+{ "kana_SA", 0x4bb },
+{ "kana_SHI", 0x4bc },
+{ "kana_SU", 0x4bd },
+{ "kana_SE", 0x4be },
+{ "kana_SO", 0x4bf },
+{ "kana_TA", 0x4c0 },
+{ "kana_TI", 0x4c1 },
+{ "kana_TU", 0x4c2 },
+{ "kana_TE", 0x4c3 },
+{ "kana_TO", 0x4c4 },
+{ "kana_NA", 0x4c5 },
+{ "kana_NI", 0x4c6 },
+{ "kana_NU", 0x4c7 },
+{ "kana_NE", 0x4c8 },
+{ "kana_NO", 0x4c9 },
+{ "kana_HA", 0x4ca },
+{ "kana_HI", 0x4cb },
+{ "kana_HU", 0x4cc },
+{ "kana_HE", 0x4cd },
+{ "kana_HO", 0x4ce },
+{ "kana_MA", 0x4cf },
+{ "kana_MI", 0x4d0 },
+{ "kana_MU", 0x4d1 },
+{ "kana_ME", 0x4d2 },
+{ "kana_MO", 0x4d3 },
+{ "kana_YA", 0x4d4 },
+{ "kana_YU", 0x4d5 },
+{ "kana_YO", 0x4d6 },
+{ "kana_RA", 0x4d7 },
+{ "kana_RI", 0x4d8 },
+{ "kana_RU", 0x4d9 },
+{ "kana_RE", 0x4da },
+{ "kana_RO", 0x4db },
+{ "kana_WA", 0x4dc },
+{ "kana_N", 0x4dd },
+{ "voicedsound", 0x4de },
+{ "semivoicedsound", 0x4df },
+{ "kana_switch", 0xFF7E },
+{ "Arabic_comma", 0x5ac },
+{ "Arabic_semicolon", 0x5bb },
+{ "Arabic_question_mark", 0x5bf },
+{ "Arabic_hamza", 0x5c1 },
+{ "Arabic_maddaonalef", 0x5c2 },
+{ "Arabic_hamzaonalef", 0x5c3 },
+{ "Arabic_hamzaonwaw", 0x5c4 },
+{ "Arabic_hamzaunderalef", 0x5c5 },
+{ "Arabic_hamzaonyeh", 0x5c6 },
+{ "Arabic_alef", 0x5c7 },
+{ "Arabic_beh", 0x5c8 },
+{ "Arabic_tehmarbuta", 0x5c9 },
+{ "Arabic_teh", 0x5ca },
+{ "Arabic_theh", 0x5cb },
+{ "Arabic_jeem", 0x5cc },
+{ "Arabic_hah", 0x5cd },
+{ "Arabic_khah", 0x5ce },
+{ "Arabic_dal", 0x5cf },
+{ "Arabic_thal", 0x5d0 },
+{ "Arabic_ra", 0x5d1 },
+{ "Arabic_zain", 0x5d2 },
+{ "Arabic_seen", 0x5d3 },
+{ "Arabic_sheen", 0x5d4 },
+{ "Arabic_sad", 0x5d5 },
+{ "Arabic_dad", 0x5d6 },
+{ "Arabic_tah", 0x5d7 },
+{ "Arabic_zah", 0x5d8 },
+{ "Arabic_ain", 0x5d9 },
+{ "Arabic_ghain", 0x5da },
+{ "Arabic_tatweel", 0x5e0 },
+{ "Arabic_feh", 0x5e1 },
+{ "Arabic_qaf", 0x5e2 },
+{ "Arabic_kaf", 0x5e3 },
+{ "Arabic_lam", 0x5e4 },
+{ "Arabic_meem", 0x5e5 },
+{ "Arabic_noon", 0x5e6 },
+{ "Arabic_heh", 0x5e7 },
+{ "Arabic_waw", 0x5e8 },
+{ "Arabic_alefmaksura", 0x5e9 },
+{ "Arabic_yeh", 0x5ea },
+{ "Arabic_fathatan", 0x5eb },
+{ "Arabic_dammatan", 0x5ec },
+{ "Arabic_kasratan", 0x5ed },
+{ "Arabic_fatha", 0x5ee },
+{ "Arabic_damma", 0x5ef },
+{ "Arabic_kasra", 0x5f0 },
+{ "Arabic_shadda", 0x5f1 },
+{ "Arabic_sukun", 0x5f2 },
+{ "Arabic_switch", 0xFF7E },
+{ "Serbian_dje", 0x6a1 },
+{ "Macedonia_gje", 0x6a2 },
+{ "Cyrillic_io", 0x6a3 },
+{ "Ukranian_je", 0x6a4 },
+{ "Macedonia_dse", 0x6a5 },
+{ "Ukranian_i", 0x6a6 },
+{ "Ukranian_yi", 0x6a7 },
+{ "Serbian_je", 0x6a8 },
+{ "Serbian_lje", 0x6a9 },
+{ "Serbian_nje", 0x6aa },
+{ "Serbian_tshe", 0x6ab },
+{ "Macedonia_kje", 0x6ac },
+{ "Byelorussian_shortu", 0x6ae },
+{ "Serbian_dze", 0x6af },
+{ "numerosign", 0x6b0 },
+{ "Serbian_DJE", 0x6b1 },
+{ "Macedonia_GJE", 0x6b2 },
+{ "Cyrillic_IO", 0x6b3 },
+{ "Ukranian_JE", 0x6b4 },
+{ "Macedonia_DSE", 0x6b5 },
+{ "Ukranian_I", 0x6b6 },
+{ "Ukranian_YI", 0x6b7 },
+{ "Serbian_JE", 0x6b8 },
+{ "Serbian_LJE", 0x6b9 },
+{ "Serbian_NJE", 0x6ba },
+{ "Serbian_TSHE", 0x6bb },
+{ "Macedonia_KJE", 0x6bc },
+{ "Byelorussian_SHORTU", 0x6be },
+{ "Serbian_DZE", 0x6bf },
+{ "Cyrillic_yu", 0x6c0 },
+{ "Cyrillic_a", 0x6c1 },
+{ "Cyrillic_be", 0x6c2 },
+{ "Cyrillic_tse", 0x6c3 },
+{ "Cyrillic_de", 0x6c4 },
+{ "Cyrillic_ie", 0x6c5 },
+{ "Cyrillic_ef", 0x6c6 },
+{ "Cyrillic_ghe", 0x6c7 },
+{ "Cyrillic_ha", 0x6c8 },
+{ "Cyrillic_i", 0x6c9 },
+{ "Cyrillic_shorti", 0x6ca },
+{ "Cyrillic_ka", 0x6cb },
+{ "Cyrillic_el", 0x6cc },
+{ "Cyrillic_em", 0x6cd },
+{ "Cyrillic_en", 0x6ce },
+{ "Cyrillic_o", 0x6cf },
+{ "Cyrillic_pe", 0x6d0 },
+{ "Cyrillic_ya", 0x6d1 },
+{ "Cyrillic_er", 0x6d2 },
+{ "Cyrillic_es", 0x6d3 },
+{ "Cyrillic_te", 0x6d4 },
+{ "Cyrillic_u", 0x6d5 },
+{ "Cyrillic_zhe", 0x6d6 },
+{ "Cyrillic_ve", 0x6d7 },
+{ "Cyrillic_softsign", 0x6d8 },
+{ "Cyrillic_yeru", 0x6d9 },
+{ "Cyrillic_ze", 0x6da },
+{ "Cyrillic_sha", 0x6db },
+{ "Cyrillic_e", 0x6dc },
+{ "Cyrillic_shcha", 0x6dd },
+{ "Cyrillic_che", 0x6de },
+{ "Cyrillic_hardsign", 0x6df },
+{ "Cyrillic_YU", 0x6e0 },
+{ "Cyrillic_A", 0x6e1 },
+{ "Cyrillic_BE", 0x6e2 },
+{ "Cyrillic_TSE", 0x6e3 },
+{ "Cyrillic_DE", 0x6e4 },
+{ "Cyrillic_IE", 0x6e5 },
+{ "Cyrillic_EF", 0x6e6 },
+{ "Cyrillic_GHE", 0x6e7 },
+{ "Cyrillic_HA", 0x6e8 },
+{ "Cyrillic_I", 0x6e9 },
+{ "Cyrillic_SHORTI", 0x6ea },
+{ "Cyrillic_KA", 0x6eb },
+{ "Cyrillic_EL", 0x6ec },
+{ "Cyrillic_EM", 0x6ed },
+{ "Cyrillic_EN", 0x6ee },
+{ "Cyrillic_O", 0x6ef },
+{ "Cyrillic_PE", 0x6f0 },
+{ "Cyrillic_YA", 0x6f1 },
+{ "Cyrillic_ER", 0x6f2 },
+{ "Cyrillic_ES", 0x6f3 },
+{ "Cyrillic_TE", 0x6f4 },
+{ "Cyrillic_U", 0x6f5 },
+{ "Cyrillic_ZHE", 0x6f6 },
+{ "Cyrillic_VE", 0x6f7 },
+{ "Cyrillic_SOFTSIGN", 0x6f8 },
+{ "Cyrillic_YERU", 0x6f9 },
+{ "Cyrillic_ZE", 0x6fa },
+{ "Cyrillic_SHA", 0x6fb },
+{ "Cyrillic_E", 0x6fc },
+{ "Cyrillic_SHCHA", 0x6fd },
+{ "Cyrillic_CHE", 0x6fe },
+{ "Cyrillic_HARDSIGN", 0x6ff },
+{ "Greek_ALPHAaccent", 0x7a1 },
+{ "Greek_EPSILONaccent", 0x7a2 },
+{ "Greek_ETAaccent", 0x7a3 },
+{ "Greek_IOTAaccent", 0x7a4 },
+{ "Greek_IOTAdiaeresis", 0x7a5 },
+{ "Greek_IOTAaccentdiaeresis", 0x7a6 },
+{ "Greek_OMICRONaccent", 0x7a7 },
+{ "Greek_UPSILONaccent", 0x7a8 },
+{ "Greek_UPSILONdieresis", 0x7a9 },
+{ "Greek_UPSILONaccentdieresis", 0x7aa },
+{ "Greek_OMEGAaccent", 0x7ab },
+{ "Greek_alphaaccent", 0x7b1 },
+{ "Greek_epsilonaccent", 0x7b2 },
+{ "Greek_etaaccent", 0x7b3 },
+{ "Greek_iotaaccent", 0x7b4 },
+{ "Greek_iotadieresis", 0x7b5 },
+{ "Greek_iotaaccentdieresis", 0x7b6 },
+{ "Greek_omicronaccent", 0x7b7 },
+{ "Greek_upsilonaccent", 0x7b8 },
+{ "Greek_upsilondieresis", 0x7b9 },
+{ "Greek_upsilonaccentdieresis", 0x7ba },
+{ "Greek_omegaaccent", 0x7bb },
+{ "Greek_ALPHA", 0x7c1 },
+{ "Greek_BETA", 0x7c2 },
+{ "Greek_GAMMA", 0x7c3 },
+{ "Greek_DELTA", 0x7c4 },
+{ "Greek_EPSILON", 0x7c5 },
+{ "Greek_ZETA", 0x7c6 },
+{ "Greek_ETA", 0x7c7 },
+{ "Greek_THETA", 0x7c8 },
+{ "Greek_IOTA", 0x7c9 },
+{ "Greek_KAPPA", 0x7ca },
+{ "Greek_LAMBDA", 0x7cb },
+{ "Greek_MU", 0x7cc },
+{ "Greek_NU", 0x7cd },
+{ "Greek_XI", 0x7ce },
+{ "Greek_OMICRON", 0x7cf },
+{ "Greek_PI", 0x7d0 },
+{ "Greek_RHO", 0x7d1 },
+{ "Greek_SIGMA", 0x7d2 },
+{ "Greek_TAU", 0x7d4 },
+{ "Greek_UPSILON", 0x7d5 },
+{ "Greek_PHI", 0x7d6 },
+{ "Greek_CHI", 0x7d7 },
+{ "Greek_PSI", 0x7d8 },
+{ "Greek_OMEGA", 0x7d9 },
+{ "Greek_alpha", 0x7e1 },
+{ "Greek_beta", 0x7e2 },
+{ "Greek_gamma", 0x7e3 },
+{ "Greek_delta", 0x7e4 },
+{ "Greek_epsilon", 0x7e5 },
+{ "Greek_zeta", 0x7e6 },
+{ "Greek_eta", 0x7e7 },
+{ "Greek_theta", 0x7e8 },
+{ "Greek_iota", 0x7e9 },
+{ "Greek_kappa", 0x7ea },
+{ "Greek_lambda", 0x7eb },
+{ "Greek_mu", 0x7ec },
+{ "Greek_nu", 0x7ed },
+{ "Greek_xi", 0x7ee },
+{ "Greek_omicron", 0x7ef },
+{ "Greek_pi", 0x7f0 },
+{ "Greek_rho", 0x7f1 },
+{ "Greek_sigma", 0x7f2 },
+{ "Greek_finalsmallsigma", 0x7f3 },
+{ "Greek_tau", 0x7f4 },
+{ "Greek_upsilon", 0x7f5 },
+{ "Greek_phi", 0x7f6 },
+{ "Greek_chi", 0x7f7 },
+{ "Greek_psi", 0x7f8 },
+{ "Greek_omega", 0x7f9 },
+{ "Greek_switch", 0xFF7E },
+{ "leftradical", 0x8a1 },
+{ "topleftradical", 0x8a2 },
+{ "horizconnector", 0x8a3 },
+{ "topintegral", 0x8a4 },
+{ "botintegral", 0x8a5 },
+{ "vertconnector", 0x8a6 },
+{ "topleftsqbracket", 0x8a7 },
+{ "botleftsqbracket", 0x8a8 },
+{ "toprightsqbracket", 0x8a9 },
+{ "botrightsqbracket", 0x8aa },
+{ "topleftparens", 0x8ab },
+{ "botleftparens", 0x8ac },
+{ "toprightparens", 0x8ad },
+{ "botrightparens", 0x8ae },
+{ "leftmiddlecurlybrace", 0x8af },
+{ "rightmiddlecurlybrace", 0x8b0 },
+{ "topleftsummation", 0x8b1 },
+{ "botleftsummation", 0x8b2 },
+{ "topvertsummationconnector", 0x8b3 },
+{ "botvertsummationconnector", 0x8b4 },
+{ "toprightsummation", 0x8b5 },
+{ "botrightsummation", 0x8b6 },
+{ "rightmiddlesummation", 0x8b7 },
+{ "lessthanequal", 0x8bc },
+{ "notequal", 0x8bd },
+{ "greaterthanequal", 0x8be },
+{ "integral", 0x8bf },
+{ "therefore", 0x8c0 },
+{ "variation", 0x8c1 },
+{ "infinity", 0x8c2 },
+{ "nabla", 0x8c5 },
+{ "approximate", 0x8c8 },
+{ "similarequal", 0x8c9 },
+{ "ifonlyif", 0x8cd },
+{ "implies", 0x8ce },
+{ "identical", 0x8cf },
+{ "radical", 0x8d6 },
+{ "includedin", 0x8da },
+{ "includes", 0x8db },
+{ "intersection", 0x8dc },
+{ "union", 0x8dd },
+{ "logicaland", 0x8de },
+{ "logicalor", 0x8df },
+{ "partialderivative", 0x8ef },
+{ "function", 0x8f6 },
+{ "leftarrow", 0x8fb },
+{ "uparrow", 0x8fc },
+{ "rightarrow", 0x8fd },
+{ "downarrow", 0x8fe },
+{ "blank", 0x9df },
+{ "soliddiamond", 0x9e0 },
+{ "checkerboard", 0x9e1 },
+{ "ht", 0x9e2 },
+{ "ff", 0x9e3 },
+{ "cr", 0x9e4 },
+{ "lf", 0x9e5 },
+{ "nl", 0x9e8 },
+{ "vt", 0x9e9 },
+{ "lowrightcorner", 0x9ea },
+{ "uprightcorner", 0x9eb },
+{ "upleftcorner", 0x9ec },
+{ "lowleftcorner", 0x9ed },
+{ "crossinglines", 0x9ee },
+{ "horizlinescan1", 0x9ef },
+{ "horizlinescan3", 0x9f0 },
+{ "horizlinescan5", 0x9f1 },
+{ "horizlinescan7", 0x9f2 },
+{ "horizlinescan9", 0x9f3 },
+{ "leftt", 0x9f4 },
+{ "rightt", 0x9f5 },
+{ "bott", 0x9f6 },
+{ "topt", 0x9f7 },
+{ "vertbar", 0x9f8 },
+{ "emspace", 0xaa1 },
+{ "enspace", 0xaa2 },
+{ "em3space", 0xaa3 },
+{ "em4space", 0xaa4 },
+{ "digitspace", 0xaa5 },
+{ "punctspace", 0xaa6 },
+{ "thinspace", 0xaa7 },
+{ "hairspace", 0xaa8 },
+{ "emdash", 0xaa9 },
+{ "endash", 0xaaa },
+{ "signifblank", 0xaac },
+{ "ellipsis", 0xaae },
+{ "doubbaselinedot", 0xaaf },
+{ "onethird", 0xab0 },
+{ "twothirds", 0xab1 },
+{ "onefifth", 0xab2 },
+{ "twofifths", 0xab3 },
+{ "threefifths", 0xab4 },
+{ "fourfifths", 0xab5 },
+{ "onesixth", 0xab6 },
+{ "fivesixths", 0xab7 },
+{ "careof", 0xab8 },
+{ "figdash", 0xabb },
+{ "leftanglebracket", 0xabc },
+{ "decimalpoint", 0xabd },
+{ "rightanglebracket", 0xabe },
+{ "marker", 0xabf },
+{ "oneeighth", 0xac3 },
+{ "threeeighths", 0xac4 },
+{ "fiveeighths", 0xac5 },
+{ "seveneighths", 0xac6 },
+{ "trademark", 0xac9 },
+{ "signaturemark", 0xaca },
+{ "trademarkincircle", 0xacb },
+{ "leftopentriangle", 0xacc },
+{ "rightopentriangle", 0xacd },
+{ "emopencircle", 0xace },
+{ "emopenrectangle", 0xacf },
+{ "leftsinglequotemark", 0xad0 },
+{ "rightsinglequotemark", 0xad1 },
+{ "leftdoublequotemark", 0xad2 },
+{ "rightdoublequotemark", 0xad3 },
+{ "prescription", 0xad4 },
+{ "minutes", 0xad6 },
+{ "seconds", 0xad7 },
+{ "latincross", 0xad9 },
+{ "hexagram", 0xada },
+{ "filledrectbullet", 0xadb },
+{ "filledlefttribullet", 0xadc },
+{ "filledrighttribullet", 0xadd },
+{ "emfilledcircle", 0xade },
+{ "emfilledrect", 0xadf },
+{ "enopencircbullet", 0xae0 },
+{ "enopensquarebullet", 0xae1 },
+{ "openrectbullet", 0xae2 },
+{ "opentribulletup", 0xae3 },
+{ "opentribulletdown", 0xae4 },
+{ "openstar", 0xae5 },
+{ "enfilledcircbullet", 0xae6 },
+{ "enfilledsqbullet", 0xae7 },
+{ "filledtribulletup", 0xae8 },
+{ "filledtribulletdown", 0xae9 },
+{ "leftpointer", 0xaea },
+{ "rightpointer", 0xaeb },
+{ "club", 0xaec },
+{ "diamond", 0xaed },
+{ "heart", 0xaee },
+{ "maltesecross", 0xaf0 },
+{ "dagger", 0xaf1 },
+{ "doubledagger", 0xaf2 },
+{ "checkmark", 0xaf3 },
+{ "ballotcross", 0xaf4 },
+{ "musicalsharp", 0xaf5 },
+{ "musicalflat", 0xaf6 },
+{ "malesymbol", 0xaf7 },
+{ "femalesymbol", 0xaf8 },
+{ "telephone", 0xaf9 },
+{ "telephonerecorder", 0xafa },
+{ "phonographcopyright", 0xafb },
+{ "caret", 0xafc },
+{ "singlelowquotemark", 0xafd },
+{ "doublelowquotemark", 0xafe },
+{ "cursor", 0xaff },
+{ "leftcaret", 0xba3 },
+{ "rightcaret", 0xba6 },
+{ "downcaret", 0xba8 },
+{ "upcaret", 0xba9 },
+{ "overbar", 0xbc0 },
+{ "downtack", 0xbc2 },
+{ "upshoe", 0xbc3 },
+{ "downstile", 0xbc4 },
+{ "underbar", 0xbc6 },
+{ "jot", 0xbca },
+{ "quad", 0xbcc },
+{ "uptack", 0xbce },
+{ "circle", 0xbcf },
+{ "upstile", 0xbd3 },
+{ "downshoe", 0xbd6 },
+{ "rightshoe", 0xbd8 },
+{ "leftshoe", 0xbda },
+{ "lefttack", 0xbdc },
+{ "righttack", 0xbfc },
+{ "hebrew_aleph", 0xce0 },
+{ "hebrew_beth", 0xce1 },
+{ "hebrew_gimmel", 0xce2 },
+{ "hebrew_daleth", 0xce3 },
+{ "hebrew_he", 0xce4 },
+{ "hebrew_waw", 0xce5 },
+{ "hebrew_zayin", 0xce6 },
+{ "hebrew_het", 0xce7 },
+{ "hebrew_teth", 0xce8 },
+{ "hebrew_yod", 0xce9 },
+{ "hebrew_finalkaph", 0xcea },
+{ "hebrew_kaph", 0xceb },
+{ "hebrew_lamed", 0xcec },
+{ "hebrew_finalmem", 0xced },
+{ "hebrew_mem", 0xcee },
+{ "hebrew_finalnun", 0xcef },
+{ "hebrew_nun", 0xcf0 },
+{ "hebrew_samekh", 0xcf1 },
+{ "hebrew_ayin", 0xcf2 },
+{ "hebrew_finalpe", 0xcf3 },
+{ "hebrew_pe", 0xcf4 },
+{ "hebrew_finalzadi", 0xcf5 },
+{ "hebrew_zadi", 0xcf6 },
+{ "hebrew_kuf", 0xcf7 },
+{ "hebrew_resh", 0xcf8 },
+{ "hebrew_shin", 0xcf9 },
+{ "hebrew_taf", 0xcfa },
+{ "Hebrew_switch", 0xFF7E },
+{ "ISO_Left_Tab", 0xFE20 },
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/mkVFunc b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/mkVFunc
new file mode 100755
index 00000000000..0a7ddba477c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/mkVFunc
@@ -0,0 +1,427 @@
+#!/usr/local/bin/perl -w
+use strict;
+
+
+my %Ignore;
+my %Ignored;
+my %WinIgnore;
+my %Exclude;
+
+my $oops = 0;
+
+use Getopt::Std;
+my %opt;
+getopts('mt',\%opt);
+my @Files;
+
+sub openRO
+{
+ my ($fh,$file) = @_;
+ if (-f $file && !-w $file)
+ {
+ chmod(0666,$file) || warn "Cannot change permissions on $file:$!";
+ }
+ open($fh,">$file") || return 0;
+ push(@Files,$file);
+ return 1;
+}
+
+END
+ {
+ while (@Files)
+ {
+ my $file = pop(@Files);
+ if (-f $file)
+ {
+ chmod(0444,$file) || warn "Cannot change permissions on $file:$!";
+ }
+ }
+ }
+
+my $win_arch = shift;
+die "Unknown \$win_arch" unless $win_arch eq 'open32'
+ or $win_arch eq 'pm'
+ or $win_arch eq 'x'
+ or $win_arch eq 'MSWin32';
+my $xexcl = <<EOM;
+#if (defined(__WIN32__) || defined(__PM__)) && !defined(DO_X_EXCLUDE)
+# define DO_X_EXCLUDE
+#endif
+EOM
+
+sub Ignore
+{
+ my $cfile = shift;
+ if (open(C,"<$cfile"))
+ {
+ warn "Ignoring from $cfile\n";
+ while (<C>)
+ {
+ if (/^([A-Za-z][A-Za-z0-9_]*)/)
+ {
+ $Ignore{$1} = $cfile;
+ }
+ }
+ close(C);
+ }
+ else
+ {
+ warn "Cannot open $cfile:$!";
+ }
+}
+
+sub WinIgnore
+{
+ my $cfile = shift;
+ if (open(C,"<$cfile"))
+ {
+ warn "WinIgnoring from $cfile\n";
+ while (<C>)
+ {
+ if (/^([A-Za-z][A-Za-z0-9_]*)/)
+ {
+ $WinIgnore{$1} = $cfile;
+ }
+ }
+ close(C);
+ }
+ else
+ {
+ warn "Cannot open $cfile:$!";
+ }
+}
+
+sub Exclude
+{
+ my $cfile = shift;
+ if (open(C,"<$cfile"))
+ {
+ while (<C>)
+ {
+ if (/{\s*\"[^\"]+\"\s*,\s*(\w+)\s*}/)
+ {
+ $Exclude{$1} = $cfile;
+ }
+ }
+ close(C);
+ }
+ else
+ {
+ warn "Cannot open $cfile:$!";
+ }
+}
+
+sub Vfunc
+{
+ my $hfile = shift;
+ my %VFunc = ();
+ my %VVar = ();
+ my %VError= ();
+ my $errors = 0;
+ my @ifdef = ('');
+ open(H,"<$hfile") || die "Cannot open $hfile:$!";
+ my $gard = "\U$hfile";
+ $gard =~ s/\..*$//;
+ $gard =~ s#/#_#g;
+
+ while (<H>)
+ {
+ if (/^\s*#\s*if/)
+ {
+ s#//.*##;
+ s#/\*.*?\*/# #g;
+ s/\s+$//;
+ s/^\s*#\s*ifndef\s+_$gard\b.*//;
+ s/^\s*#\s*ifndef\s+_\w+_H_\b.*//;
+ warn "'$gard' in '$_'" if /$gard/;
+ push(@ifdef,$_);
+ }
+ elsif (/^\s*#\s*else/)
+ {
+ s/\s+$//;
+ #warn "$hfile:$.:$_\n";
+ $ifdef[-1] = $_;
+ }
+ elsif (/^\s*#\s*endif\b/)
+ {
+ pop(@ifdef);
+ }
+ elsif (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s+_ANSI_ARGS_\s*\((TCL_VARARGS)?\(/)
+ {
+ my ($type,$name,$op) = ($2,$3,$4);
+ if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
+ {
+ warn "$1 $name\n";
+ $oops++;
+ $Ignore{$name} = $hfile;
+ }
+ $op = "" unless (defined $op);
+ my $defn = "VFUNC($type,$name,V_$name,_ANSI_ARGS_($op(";
+ $_ = $';
+ until (/\)\);\s*$/)
+ {
+ $defn .= $_;
+ $_ = <H>;
+ if (/^\S/)
+ {
+ chomp($_);
+ die $_;
+ }
+ }
+ s/\)\);\s*$/\)\)\)\n/;
+ $defn .= $_;
+ die "$hfile:$.:$ifdef[-1]\n" if $ifdef[-1] =~ /\belse\b/;
+ if (exists($VFunc{$name}{$ifdef[-1]}) && $defn ne $VFunc{$name}{$ifdef[-1]})
+ {
+ warn "Function (@ifdef) $name is $defn and $VFunc{$name}{$ifdef[-1]}";
+ $errors++;
+ }
+ else
+ {
+ $VFunc{$name}{$ifdef[-1]} = $defn;
+ }
+ }
+ elsif (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s*;/)
+ {
+ my ($type,$name) = ($2,$3);
+ if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
+ {
+ warn "$1 $name\n";
+ $oops++;
+ $Ignore{$name} = $hfile;
+ }
+ my $defn = "VVAR($type,$name,V_$name)\n";
+ die "$hfile:$.:$ifdef[-1]\n" if $ifdef[-1] =~ /\belse\b/;
+ if (exists $VVar{$name}{$ifdef[-1]})
+ {
+ warn "Variable (@ifdef) $name is $defn and $VVar{$name}{$ifdef[-1]}";
+ $errors++;
+ }
+ else
+ {
+ $VVar{$name}{$ifdef[-1]} = $defn;
+ }
+ }
+ elsif (/\b(EXTERN|extern)\s+[\w_]+\s+[\w_]+\[\];$/)
+ {
+
+ }
+ elsif (/\b(EXTERN|extern)\s*"C"\s*\{\s*$/)
+ {
+
+ }
+ elsif (/\b(EXTERN|extern)\b/)
+ {
+ warn "$hfile:$.: $_" unless (/^\s*\#\s*define/);
+ }
+ }
+ close(H);
+ die "Multiple definitions\n" if $errors;
+
+
+ if (keys %VFunc || keys %VVar)
+ {
+ my $name = "\u\L${gard}\UV";
+ my $fdef = $hfile;
+ $fdef =~ s/\..*$/.t/;
+ my $mdef = $hfile;
+ $mdef =~ s/\..*$/.m/;
+
+ $mdef .= 'dmy' unless $opt{'m'};
+ $fdef .= 'dmy' unless $opt{'t'};
+
+ my $htfile = $hfile;
+ $htfile =~ s/\..*$/_f.h/;
+ unless (-r $htfile)
+ {
+ openRO(\*C,$htfile) || die "Cannot open $htfile:$!";
+ print C "#ifndef ${gard}_VT\n";
+ print C "#define ${gard}_VT\n";
+ print C "typedef struct ${name}tab\n{\n";
+ print C " unsigned (*tabSize)(void);\n";
+ print C "#define VFUNC(type,name,mem,args) type (*mem) args;\n";
+ print C "#define VVAR(type,name,mem) type (*mem);\n";
+ print C "#include \"$fdef\"\n";
+ print C "#undef VFUNC\n";
+ print C "#undef VVAR\n";
+ print C "} ${name}tab;\n";
+ print C "extern ${name}tab *${name}ptr;\n";
+ print C "extern ${name}tab *${name}Get(void);\n";
+ print C "#endif /* ${gard}_VT */\n";
+ close(C);
+ }
+
+ my $cfile = $hfile;
+ $cfile =~ s/\..*$/_f.c/;
+ unless (-r $cfile)
+ {
+ openRO(\*C,$cfile) || die "Cannot open $cfile:$!";
+ print C "#include \"$hfile\"\n";
+ print C "#include \"$htfile\"\n";
+ print C "static unsigned ${name}Size(void) { return sizeof(${name}tab);}\n";
+ print C "static ${name}tab ${name}table =\n{\n";
+ print C " ${name}Size,\n";
+ print C "#define VFUNC(type,name,mem,args) name,\n";
+ print C "#define VVAR(type,name,mem) &name,\n";
+ print C "#include \"$fdef\"\n";
+ print C "#undef VFUNC\n";
+ print C "#undef VVAR\n";
+ print C "};\n";
+ print C "${name}tab *${name}ptr;\n";
+ print C "${name}tab *${name}Get() { return ${name}ptr = &${name}table;}\n";
+ close(C);
+ }
+
+ print STDERR "$gard\n";
+ openRO(\*VFUNC,$fdef) || die "Cannot open $fdef:$!";
+ openRO(\*VMACRO,$mdef) || die "Cannot open $mdef:$!";
+ print VFUNC "#ifdef _$gard\n";
+ print VMACRO "#ifndef _${gard}_VM\n";
+ print VMACRO "#define _${gard}_VM\n";
+ print VMACRO "#include \"$htfile\"\n";
+ print VMACRO "#ifndef NO_VTABLES\n";
+ print VMACRO $xexcl if %WinIgnore;
+ print VFUNC $xexcl if %WinIgnore;
+ foreach my $func (sort keys %VVar)
+ {
+ if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
+ {
+ foreach my $ifdef (sort keys %{$VVar{$func}})
+ {
+ print VFUNC "$ifdef\n" if ($ifdef);
+ print VFUNC $VVar{$func}{$ifdef};
+ print VFUNC "#endif /* $ifdef */\n" if ($ifdef);
+ }
+ print VMACRO "#define $func (*${name}ptr->V_$func)\n";
+ }
+ $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
+ }
+ foreach my $func (sort keys %VFunc)
+ {
+ if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
+ {
+ print VFUNC "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
+ print VFUNC "#ifndef $func\n";
+ foreach my $ifdef (sort keys %{$VFunc{$func}})
+ {
+ print VFUNC "$ifdef\n" if ($ifdef);
+ print VFUNC $VFunc{$func}{$ifdef};
+ print VFUNC "#endif /* $ifdef */\n" if ($ifdef);
+ }
+ print VFUNC "#endif /* #ifndef $func */\n";
+ print VFUNC "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
+ print VFUNC "\n";
+
+ print VMACRO "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
+ print VMACRO "#ifndef $func\n";
+ print VMACRO "# define $func (*${name}ptr->V_$func)\n";
+ print VMACRO "#endif\n";
+ print VMACRO "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
+ print VMACRO "\n";
+ }
+ $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
+ }
+ print VMACRO "#endif /* NO_VTABLES */\n";
+ print VMACRO "#endif /* _${gard}_VM */\n";
+ close(VMACRO);
+ print VFUNC "#endif /* _$gard */\n";
+ close(VFUNC); # Close this last - Makefile dependency
+
+ unlink($mdef) unless $opt{'m'};
+ unlink($fdef) unless $opt{'t'};
+ }
+ else
+ {
+ die "No entries in $hfile\n";
+ }
+}
+
+foreach (<tk*Tab.c>)
+ {
+ Exclude($_);
+ }
+
+die "Usage: $0 <some.h>\n" if (@ARGV != 1);
+
+my $h = shift;
+my $x = $h;
+$x =~ s/\.h/.exc/;
+Ignore($x) if (-f $x);
+$x =~ s/\.exc/.excwin/;
+WinIgnore($x) if (-f $x);
+Vfunc($h);
+
+foreach my $s (sort keys %Ignore)
+ {
+ warn "$s is not in $h\n";
+ $oops++;
+ }
+
+if ($oops)
+ {
+ $x = $h;
+ $x =~ s/\.h/.exc/;
+ rename($x,"$x.old") || die "Cannot rename $x to $x.old:$!";
+ open(EXC,">$x") || die "Cannot open $x:$!";
+ foreach my $s (sort keys %Ignored)
+ {
+ print EXC $s,"\n";
+ }
+ close(EXC);
+ }
+
+__END__
+
+=head1 NAME
+
+mkVFunc - Support for "nested" dynamic loading
+
+=head1 SYNOPSIS
+
+ mkVFunc xxx.h
+
+=head1 DESCRIPTION
+
+B<perl/Tk> is designed so that B<Tk> can be dynamically loaded 'on top of'
+perl. That is the easy bit. What it also does is allow Tk::Xxxx to be
+dynamically loaded 'on top of' the B<perl/Tk> composite. Thus when
+you 'require Tk::HList' the shared object F<.../HList.so> needs to be
+able to call functions defined in perl I<and> functions defined in loadable
+.../Tk.so . Now functions in 'base executable' are a well known problem,
+and are solved by DynaLoader. However most of dynamic loading schemes
+cannot handle one loadable calling another loadable.
+
+Thus what Tk does is build a table of functions that should be callable.
+This table is auto-generated from the .h file by looking for
+'extern' (and EXTERN which is #defined to 'extern').
+Thus any function marked as 'extern' is 'referenced' by the table.
+The address of the table is then stored in a perl variable when Tk is loaded.
+When HList is loaded it looks in the perl variable (via functions
+in perl - the 'base executable') to get the address of the table.
+
+The same utility that builds the table also builds a set of #define's.
+HList.c (and any other .c files which comprise HList) #include these
+#define's. So that
+
+ Tk_SomeFunc(x,y,z)
+
+Is actually compiled as
+
+ (*TkVptr->V_Tk_SomeFunc)(x,y,z)
+
+Where Tk_ptr is pointer to the table.
+
+See:
+
+ Tk-b*/pTk/mkVFunc - perl script that produces tables
+ /tk.h - basis from which table is generated
+ /tk.m - #define's to include in sub-extension
+ /tk_f.h - #included both sides.
+ /tk_f.c - Actual table definition.
+ /tk.t - 'shared' set of macros which produce table
+ included in tk_f.c and tk_f.h
+ /tkVMacro.h - Wrapper to include *.m files
+
+In addition to /tk* there are /tkInt*, /Lang* and /tix*
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/moredefs.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/moredefs.h
new file mode 100755
index 00000000000..f81380aea31
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/moredefs.h
@@ -0,0 +1,131 @@
+EXTERN int Tk_BellObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_BindCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_BindtagsCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ButtonCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_CanvasObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_CheckbuttonCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ClipboardCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ChooseColorCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_DestroyCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_EntryCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_EventObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_FrameCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_FocusObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_FontObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_GetOpenFileCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_GetSaveFileCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_GrabCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_GridCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ImageObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_LabelCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ListboxCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_LowerCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_MenuCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_MenubuttonCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_MessageBoxCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_MessageCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_OptionCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_PackCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_PlaceCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_PropertyCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_RadiobuttonCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_RaiseCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ScaleCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ScrollbarCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_SelectionCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_SendCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_TextCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_TkObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_TkwaitCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_ToplevelCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_UpdateCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_WinfoObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_WmCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+
+EXTERN int TkTileParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj * value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj * TkTilePrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkOffsetParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj * value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj * TkOffsetPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkStateParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj * value,
+ char *widgRec, int offset));
+EXTERN Tcl_Obj * TkStatePrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkOrientParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj * value,
+ char *widgRec, int offset));
+EXTERN Tcl_Obj * TkOrientPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkPixelParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj * value,
+ char *widgRec, int offset));
+EXTERN Tcl_Obj * TkPixelPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/port.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/port.h
new file mode 100755
index 00000000000..7a66a7c2751
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/port.h
@@ -0,0 +1,32 @@
+/*
+ * Warning, this file was automatically created by the TIFF configure script
+ * VERSION: v3.5.5
+ * DATE: Sun Jul 16 20:21:17 MET DST 2000
+ * TARGET: i386-unknown-linux
+ * CCOMPILER: /usr/bin/gcc-2.7.2.1
+ */
+#ifndef _PORT_
+#define _PORT_ 1
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include <sys/types.h>
+#define HOST_FILLORDER FILLORDER_LSB2MSB
+#define HOST_BIGENDIAN 0
+#define HAVE_MMAP 1
+#include <stdio.h>
+#include <unistd.h>
+#include <string.h>
+#include <stdlib.h>
+#include <fcntl.h>
+typedef double dblparam_t;
+#ifdef __STRICT_ANSI__
+#define INLINE __inline__
+#else
+#define INLINE inline
+#endif
+#define GLOBALDATA(TYPE,NAME) extern TYPE NAME
+#ifdef __cplusplus
+}
+#endif
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tcl.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tcl.h
new file mode 100755
index 00000000000..2770f572bcc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tcl.h
@@ -0,0 +1,2411 @@
+/*
+ * tcl.h --
+ *
+ * This header file describes the externally-visible facilities
+ * of the Tcl interpreter.
+ *
+ * Copyright (c) 1987-1994 The Regents of the University of California.
+ * Copyright (c) 1993-1996 Lucent Technologies.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tcl.h,v 1.153.2.8 2003/10/22 22:35:46 andreas_kupries Exp $
+ */
+#ifndef _TCL
+#define _TCL
+
+/*
+ * For C++ compilers, use extern "C"
+ */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*
+ * The following defines are used to indicate the various release levels.
+ */
+
+#define TCL_ALPHA_RELEASE 0
+#define TCL_BETA_RELEASE 1
+#define TCL_FINAL_RELEASE 2
+
+/*
+ * When version numbers change here, must also go into the following files
+ * and update the version numbers:
+ *
+ * library/init.tcl (only if Major.minor changes, not patchlevel) 1 LOC
+ * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
+ * win/configure.in (as above)
+ * win/tcl.m4 (not patchlevel)
+ * win/makefile.vc (not patchlevel) 2 LOC
+ * README (sections 0 and 2)
+ * mac/README (2 LOC, not patchlevel)
+ * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 2 LOC
+ * win/README.binary (sections 0-4)
+ * win/README (not patchlevel) (sections 0 and 2)
+ * unix/tcl.spec (2 LOC Major/Minor, 1 LOC patch)
+ * tests/basic.test (1 LOC M/M, not patchlevel)
+ * tools/tcl.hpj.in (not patchlevel, for windows installer)
+ * tools/tcl.wse.in (for windows installer)
+ * tools/tclSplash.bmp (not patchlevel)
+ */
+#define TCL_MAJOR_VERSION 8
+#define TCL_MINOR_VERSION 4
+#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
+#define TCL_RELEASE_SERIAL 5
+
+#define TCL_VERSION "8.4"
+#define TCL_PATCH_LEVEL "8.4.5"
+
+/*
+ * The following definitions set up the proper options for Windows
+ * compilers. We use this method because there is no autoconf equivalent.
+ */
+
+#ifndef __WIN32__
+# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__)
+# define __WIN32__
+# ifndef WIN32
+# define WIN32
+# endif
+# endif
+#endif
+
+/*
+ * STRICT: See MSDN Article Q83456
+ */
+#ifdef __WIN32__
+# ifndef STRICT
+# define STRICT
+# endif
+#endif /* __WIN32__ */
+
+/*
+ * The following definitions set up the proper options for Macintosh
+ * compilers. We use this method because there is no autoconf equivalent.
+ */
+
+#ifdef MAC_TCL
+#include <ConditionalMacros.h>
+# ifndef USE_TCLALLOC
+# define USE_TCLALLOC 1
+# endif
+# ifndef NO_STRERROR
+# define NO_STRERROR 1
+# endif
+# define INLINE
+#endif
+
+
+/*
+ * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
+ * quotation marks), JOIN joins two arguments.
+ */
+#ifndef STRINGIFY
+# define STRINGIFY(x) STRINGIFY1(x)
+# define STRINGIFY1(x) #x
+#endif
+#ifndef JOIN
+# define JOIN(a,b) JOIN1(a,b)
+# define JOIN1(a,b) a##b
+#endif
+
+/*
+ * A special definition used to allow this header file to be included
+ * from windows or mac resource files so that they can obtain version
+ * information. RC_INVOKED is defined by default by the windows RC tool
+ * and manually set for macintosh.
+ *
+ * Resource compilers don't like all the C stuff, like typedefs and
+ * procedure declarations, that occur below, so block them out.
+ */
+
+#ifndef RC_INVOKED
+
+/*
+ * Special macro to define mutexes, that doesn't do anything
+ * if we are not using threads.
+ */
+
+#ifdef TCL_THREADS
+#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
+#else
+#define TCL_DECLARE_MUTEX(name)
+#endif
+
+/*
+ * Macros that eliminate the overhead of the thread synchronization
+ * functions when compiling without thread support.
+ */
+
+#ifndef TCL_THREADS
+#define Tcl_MutexLock(mutexPtr)
+#define Tcl_MutexUnlock(mutexPtr)
+#define Tcl_MutexFinalize(mutexPtr)
+#define Tcl_ConditionNotify(condPtr)
+#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+#define Tcl_ConditionFinalize(condPtr)
+#endif /* TCL_THREADS */
+
+
+#ifndef BUFSIZ
+# include <stdio.h>
+#endif
+
+
+/*
+ * Definitions that allow Tcl functions with variable numbers of
+ * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS
+ * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare
+ * the arguments in a function definiton: it takes the type and name of
+ * the first argument and supplies the appropriate argument declaration
+ * string for use in the function definition. TCL_VARARGS_START
+ * initializes the va_list data structure and returns the first argument.
+ */
+#if !defined(NO_STDARG)
+# include <stdarg.h>
+# define TCL_VARARGS(type, name) (type name, ...)
+# define TCL_VARARGS_DEF(type, name) (type name, ...)
+# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
+#else
+# include <varargs.h>
+# define TCL_VARARGS(type, name) ()
+# define TCL_VARARGS_DEF(type, name) (va_alist)
+# define TCL_VARARGS_START(type, name, list) \
+ (va_start(list), va_arg(list, type))
+#endif
+
+/*
+ * Macros used to declare a function to be exported by a DLL.
+ * Used by Windows, maps to no-op declarations on non-Windows systems.
+ * The default build on windows is for a DLL, which causes the DLLIMPORT
+ * and DLLEXPORT macros to be nonempty. To build a static library, the
+ * macro STATIC_BUILD should be defined.
+ */
+
+#ifdef STATIC_BUILD
+# define DLLIMPORT
+# define DLLEXPORT
+#else
+# if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || (defined(__GNUC__) && defined(__declspec)))) || (defined(MAC_TCL) && FUNCTION_DECLSPEC)
+# define DLLIMPORT __declspec(dllimport)
+# define DLLEXPORT __declspec(dllexport)
+# else
+# define DLLIMPORT
+# define DLLEXPORT
+# endif
+#endif
+
+/*
+ * These macros are used to control whether functions are being declared for
+ * import or export. If a function is being declared while it is being built
+ * to be included in a shared library, then it should have the DLLEXPORT
+ * storage class. If is being declared for use by a module that is going to
+ * link against the shared library, then it should have the DLLIMPORT storage
+ * class. If the symbol is beind declared for a static build or for use from a
+ * stub library, then the storage class should be empty.
+ *
+ * The convention is that a macro called BUILD_xxxx, where xxxx is the
+ * name of a library we are building, is set on the compile line for sources
+ * that are to be placed in the library. When this macro is set, the
+ * storage class will be set to DLLEXPORT. At the end of the header file, the
+ * storage class will be reset to DLLIMPORT.
+ */
+#undef TCL_STORAGE_CLASS
+#ifdef BUILD_tcl
+# define TCL_STORAGE_CLASS DLLEXPORT
+#else
+# ifdef USE_TCL_STUBS
+# define TCL_STORAGE_CLASS
+# else
+# define TCL_STORAGE_CLASS DLLIMPORT
+# endif
+#endif
+
+
+/*
+ * Definitions that allow this header file to be used either with or
+ * without ANSI C features like function prototypes.
+ */
+#undef _ANSI_ARGS_
+#undef CONST
+#ifndef INLINE
+# define INLINE
+#endif
+
+#ifndef NO_CONST
+# define CONST const
+#else
+# define CONST
+#endif
+
+#ifndef NO_PROTOTYPES
+# define _ANSI_ARGS_(x) x
+#else
+# define _ANSI_ARGS_(x) ()
+#endif
+
+#ifdef USE_NON_CONST
+# ifdef USE_COMPAT_CONST
+# error define at most one of USE_NON_CONST and USE_COMPAT_CONST
+# endif
+# define CONST84
+# define CONST84_RETURN
+#else
+# ifdef USE_COMPAT_CONST
+# define CONST84
+# define CONST84_RETURN CONST
+# else
+# define CONST84 CONST
+# define CONST84_RETURN CONST
+# endif
+#endif
+
+
+/*
+ * Make sure EXTERN isn't defined elsewhere
+ */
+#ifdef EXTERN
+# undef EXTERN
+#endif /* EXTERN */
+
+#ifdef __cplusplus
+# define EXTERN extern "C" TCL_STORAGE_CLASS
+#else
+# define EXTERN extern TCL_STORAGE_CLASS
+#endif
+
+
+/*
+ * The following code is copied from winnt.h.
+ * If we don't replicate it here, then <windows.h> can't be included
+ * after tcl.h, since tcl.h also defines VOID.
+ * This block is skipped under Cygwin and Mingw.
+ *
+ *
+ */
+#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID)
+#ifndef VOID
+#define VOID void
+typedef char CHAR;
+typedef short SHORT;
+typedef long LONG;
+#endif
+#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */
+
+/*
+ * Macro to use instead of "void" for arguments that must have
+ * type "void *" in ANSI C; maps them to type "char *" in
+ * non-ANSI systems.
+ */
+
+#ifndef NO_VOID
+# define VOID void
+#else
+# define VOID char
+#endif
+
+/*
+ * Miscellaneous declarations.
+ */
+#ifndef NULL
+# define NULL 0
+#endif
+
+#ifndef _CLIENTDATA
+# ifndef NO_VOID
+ typedef void *ClientData;
+# else
+ typedef int *ClientData;
+# endif
+# define _CLIENTDATA
+#endif
+
+/*
+ * Define Tcl_WideInt to be a type that is (at least) 64-bits wide,
+ * and define Tcl_WideUInt to be the unsigned variant of that type
+ * (assuming that where we have one, we can have the other.)
+ *
+ * Also defines the following macros:
+ * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on
+ * a real 64-bit system.)
+ * Tcl_WideAsLong - forgetful converter from wideInt to long.
+ * Tcl_LongAsWide - sign-extending converter from long to wideInt.
+ * Tcl_WideAsDouble - converter from wideInt to double.
+ * Tcl_DoubleAsWide - converter from double to wideInt.
+ *
+ * The following invariant should hold for any long value 'longVal':
+ * longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal))
+ *
+ * Note on converting between Tcl_WideInt and strings. This
+ * implementation (in tclObj.c) depends on the functions strtoull()
+ * and sprintf(...,"%" TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE
+ * is the length of the modifier string, which is "ll" on most 32-bit
+ * Unix systems. It has to be split up like this to allow for the more
+ * complex formats sometimes needed (e.g. in the format(n) command.)
+ */
+
+#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
+# if defined(__CYGWIN__)
+# define TCL_WIDE_INT_TYPE long long
+# define TCL_LL_MODIFIER "L"
+typedef struct stat Tcl_StatBuf;
+# define TCL_LL_MODIFIER_SIZE 1
+# elif defined(__WIN32__)
+# define TCL_WIDE_INT_TYPE __int64
+# ifdef __BORLANDC__
+typedef struct stati64 Tcl_StatBuf;
+# define TCL_LL_MODIFIER "L"
+# define TCL_LL_MODIFIER_SIZE 1
+# else /* __BORLANDC__ */
+typedef struct _stati64 Tcl_StatBuf;
+# define TCL_LL_MODIFIER "I64"
+# define TCL_LL_MODIFIER_SIZE 3
+# endif /* __BORLANDC__ */
+# else /* __WIN32__ */
+/*
+ * Don't know what platform it is and configure hasn't discovered what
+ * is going on for us. Try to guess...
+ */
+# ifdef NO_LIMITS_H
+# error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG
+# else /* !NO_LIMITS_H */
+# include <limits.h>
+# if (INT_MAX < LONG_MAX)
+# define TCL_WIDE_INT_IS_LONG 1
+# else
+# define TCL_WIDE_INT_TYPE long long
+# endif
+# endif /* NO_LIMITS_H */
+# endif /* __WIN32__ */
+#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
+#ifdef TCL_WIDE_INT_IS_LONG
+# undef TCL_WIDE_INT_TYPE
+# define TCL_WIDE_INT_TYPE long
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
+typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
+
+#ifdef TCL_WIDE_INT_IS_LONG
+typedef struct stat Tcl_StatBuf;
+# define Tcl_WideAsLong(val) ((long)(val))
+# define Tcl_LongAsWide(val) ((long)(val))
+# define Tcl_WideAsDouble(val) ((double)((long)(val)))
+# define Tcl_DoubleAsWide(val) ((long)((double)(val)))
+# ifndef TCL_LL_MODIFIER
+# define TCL_LL_MODIFIER "l"
+# define TCL_LL_MODIFIER_SIZE 1
+# endif /* !TCL_LL_MODIFIER */
+#else /* TCL_WIDE_INT_IS_LONG */
+/*
+ * The next short section of defines are only done when not running on
+ * Windows or some other strange platform.
+ */
+# ifndef TCL_LL_MODIFIER
+# ifdef HAVE_STRUCT_STAT64
+typedef struct stat64 Tcl_StatBuf;
+# else
+typedef struct stat Tcl_StatBuf;
+# endif /* HAVE_STRUCT_STAT64 */
+# define TCL_LL_MODIFIER "ll"
+# define TCL_LL_MODIFIER_SIZE 2
+# endif /* !TCL_LL_MODIFIER */
+# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
+# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
+# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
+# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+
+/*
+ * This flag controls whether binary compatability is maintained with
+ * extensions built against a previous version of Tcl. This is true
+ * by default.
+ */
+#ifndef TCL_PRESERVE_BINARY_COMPATABILITY
+# define TCL_PRESERVE_BINARY_COMPATABILITY 1
+#endif
+
+
+/*
+ * Data structures defined opaquely in this module. The definitions below
+ * just provide dummy types. A few fields are made visible in Tcl_Interp
+ * structures, namely those used for returning a string result from
+ * commands. Direct access to the result field is discouraged in Tcl 8.0.
+ * The interpreter result is either an object or a string, and the two
+ * values are kept consistent unless some C code sets interp->result
+ * directly. Programmers should use either the procedure Tcl_GetObjResult()
+ * or Tcl_GetStringResult() to read the interpreter's result. See the
+ * SetResult man page for details.
+ *
+ * Note: any change to the Tcl_Interp definition below must be mirrored
+ * in the "real" definition in tclInt.h.
+ *
+ * Note: Tcl_ObjCmdProc procedures do not directly set result and freeProc.
+ * Instead, they set a Tcl_Obj member in the "real" structure that can be
+ * accessed with Tcl_GetObjResult() and Tcl_SetObjResult().
+ */
+
+#ifndef Tcl_Interp
+typedef struct Tcl_Interp
+#ifdef USE_TCL_STRUCT
+{
+ char *result; /* If the last command returned a string
+ * result, this points to it. */
+ void (*freeProc) _ANSI_ARGS_((char *blockPtr));
+ /* Zero means the string result is
+ * statically allocated. TCL_DYNAMIC means
+ * it was allocated with ckalloc and should
+ * be freed with ckfree. Other values give
+ * the address of procedure to invoke to
+ * free the result. Tcl_Eval must free it
+ * before executing next command. */
+ int errorLine; /* When TCL_ERROR is returned, this gives
+ * the line number within the command where
+ * the error occurred (1 if first line). */
+}
+#endif
+Tcl_Interp;
+#endif
+
+typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
+#ifndef Tcl_Channel
+typedef struct Tcl_Channel_ *Tcl_Channel;
+#endif
+#ifndef Tcl_Command
+typedef struct Tcl_Command_ *Tcl_Command;
+#endif
+typedef struct Tcl_Condition_ *Tcl_Condition;
+typedef struct Tcl_EncodingState_ *Tcl_EncodingState;
+typedef struct Tcl_Encoding_ *Tcl_Encoding;
+typedef struct Tcl_Event Tcl_Event;
+typedef struct Tcl_Mutex_ *Tcl_Mutex;
+typedef struct Tcl_Pid_ *Tcl_Pid;
+#ifndef Tcl_RegExp
+typedef struct Tcl_RegExp_ *Tcl_RegExp;
+#endif
+typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
+typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
+typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
+typedef struct Tcl_Trace_ *Tcl_Trace;
+typedef struct Tcl_Var_ *Tcl_Var;
+typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
+typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;
+
+/*
+ * Definition of the interface to procedures implementing threads.
+ * A procedure following this definition is given to each call of
+ * 'Tcl_CreateThread' and will be called as the main fuction of
+ * the new thread created by that call.
+ */
+#ifdef MAC_TCL
+typedef pascal void *(Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
+#elif defined __WIN32__
+typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
+#else
+typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
+#endif
+
+
+/*
+ * Threading function return types used for abstracting away platform
+ * differences when writing a Tcl_ThreadCreateProc. See the NewThread
+ * function in generic/tclThreadTest.c for it's usage.
+ */
+#ifdef MAC_TCL
+# define Tcl_ThreadCreateType pascal void *
+# define TCL_THREAD_CREATE_RETURN return NULL
+#elif defined __WIN32__
+# define Tcl_ThreadCreateType unsigned __stdcall
+# define TCL_THREAD_CREATE_RETURN return 0
+#else
+# define Tcl_ThreadCreateType void
+# define TCL_THREAD_CREATE_RETURN
+#endif
+
+
+/*
+ * Definition of values for default stacksize and the possible flags to be
+ * given to Tcl_CreateThread.
+ */
+#define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack */
+#define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */
+#define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */
+
+/*
+ * Flag values passed to Tcl_GetRegExpFromObj.
+ */
+#define TCL_REG_BASIC 000000 /* BREs (convenience) */
+#define TCL_REG_EXTENDED 000001 /* EREs */
+#define TCL_REG_ADVF 000002 /* advanced features in EREs */
+#define TCL_REG_ADVANCED 000003 /* AREs (which are also EREs) */
+#define TCL_REG_QUOTE 000004 /* no special characters, none */
+#define TCL_REG_NOCASE 000010 /* ignore case */
+#define TCL_REG_NOSUB 000020 /* don't care about subexpressions */
+#define TCL_REG_EXPANDED 000040 /* expanded format, white space &
+ * comments */
+#define TCL_REG_NLSTOP 000100 /* \n doesn't match . or [^ ] */
+#define TCL_REG_NLANCH 000200 /* ^ matches after \n, $ before */
+#define TCL_REG_NEWLINE 000300 /* newlines are line terminators */
+#define TCL_REG_CANMATCH 001000 /* report details on partial/limited
+ * matches */
+
+/*
+ * The following flag is experimental and only intended for use by Expect. It
+ * will probably go away in a later release.
+ */
+#define TCL_REG_BOSONLY 002000 /* prepend \A to pattern so it only
+ * matches at the beginning of the
+ * string. */
+
+/*
+ * Flags values passed to Tcl_RegExpExecObj.
+ */
+#define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */
+#define TCL_REG_NOTEOL 0002 /* End of string does not match $. */
+
+/*
+ * Structures filled in by Tcl_RegExpInfo. Note that all offset values are
+ * relative to the start of the match string, not the beginning of the
+ * entire string.
+ */
+typedef struct Tcl_RegExpIndices {
+ long start; /* character offset of first character in match */
+ long end; /* character offset of first character after the
+ * match. */
+} Tcl_RegExpIndices;
+
+typedef struct Tcl_RegExpInfo {
+ int nsubs; /* number of subexpressions in the
+ * compiled expression */
+ Tcl_RegExpIndices *matches; /* array of nsubs match offset
+ * pairs */
+ long extendStart; /* The offset at which a subsequent
+ * match might begin. */
+ long reserved; /* Reserved for later use. */
+} Tcl_RegExpInfo;
+
+/*
+ * Picky compilers complain if this typdef doesn't appear before the
+ * struct's reference in tclDecls.h.
+ */
+typedef Tcl_StatBuf *Tcl_Stat_;
+typedef struct stat *Tcl_OldStat_;
+
+/*
+ * When a TCL command returns, the interpreter contains a result from the
+ * command. Programmers are strongly encouraged to use one of the
+ * procedures Tcl_GetObjResult() or Tcl_GetStringResult() to read the
+ * interpreter's result. See the SetResult man page for details. Besides
+ * this result, the command procedure returns an integer code, which is
+ * one of the following:
+ *
+ * TCL_OK Command completed normally; the interpreter's
+ * result contains the command's result.
+ * TCL_ERROR The command couldn't be completed successfully;
+ * the interpreter's result describes what went wrong.
+ * TCL_RETURN The command requests that the current procedure
+ * return; the interpreter's result contains the
+ * procedure's return value.
+ * TCL_BREAK The command requests that the innermost loop
+ * be exited; the interpreter's result is meaningless.
+ * TCL_CONTINUE Go on to the next iteration of the current loop;
+ * the interpreter's result is meaningless.
+ */
+#define TCL_OK 0
+#define TCL_ERROR 1
+#define TCL_RETURN 2
+#define TCL_BREAK 3
+#define TCL_CONTINUE 4
+
+#define TCL_RESULT_SIZE 200
+
+/*
+ * Flags to control what substitutions are performed by Tcl_SubstObj():
+ */
+#define TCL_SUBST_COMMANDS 001
+#define TCL_SUBST_VARIABLES 002
+#define TCL_SUBST_BACKSLASHES 004
+#define TCL_SUBST_ALL 007
+
+
+/*
+ * Argument descriptors for math function callbacks in expressions:
+ */
+typedef enum {
+ TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
+} Tcl_ValueType;
+typedef struct Tcl_Value {
+ Tcl_ValueType type; /* Indicates intValue or doubleValue is
+ * valid, or both. */
+ long intValue; /* Integer value. */
+ double doubleValue; /* Double-precision floating value. */
+ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
+} Tcl_Value;
+
+/*
+ * Forward declaration of Tcl_Obj to prevent an error when the forward
+ * reference to Tcl_Obj is encountered in the procedure types declared
+ * below.
+ */
+#ifndef Tcl_Obj
+typedef struct Tcl_Obj Tcl_Obj;
+#endif
+
+/*
+ * Procedure types defined by Tcl:
+ */
+
+typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
+typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int code));
+typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
+typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
+typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
+typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, CONST84 char *argv[]));
+typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
+ ClientData cmdClientData, int argc, CONST84 char *argv[]));
+typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int level, CONST char *command,
+ Tcl_Command commandInfo, int objc, Tcl_Obj * CONST * objv));
+typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *dupPtr));
+typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr,
+ char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData));
+typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
+typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
+ int flags));
+typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr,
+ ClientData clientData));
+typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData,
+ int flags));
+typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask));
+typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((Tcl_Obj *objPtr));
+typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
+typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp));
+typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
+typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
+typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj * CONST * objv));
+typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
+typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
+typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
+ Tcl_Channel chan, char *address, int port));
+typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
+typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((Tcl_Obj *objPtr));
+typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, int flags));
+typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
+ int flags));
+typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
+ Tcl_FileProc *proc, ClientData clientData));
+typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
+typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
+typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
+typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));
+
+
+/*
+ * The following structure represents a type of object, which is a
+ * particular internal representation for an object plus a set of
+ * procedures that provide standard operations on objects of that type.
+ */
+
+typedef struct Tcl_ObjType
+{
+ char *name; /* Name of the type, e.g. "int". */
+ Tcl_FreeInternalRepProc *freeIntRepProc;
+ /* Called to free any storage for the type's
+ * internal rep. NULL if the internal rep
+ * does not need freeing. */
+ Tcl_DupInternalRepProc *dupIntRepProc;
+ /* Called to create a new object as a copy
+ * of an existing object. */
+ Tcl_UpdateStringProc *updateStringProc;
+ /* Called to update the string rep from the
+ * type's internal representation. */
+ Tcl_SetFromAnyProc *setFromAnyProc;
+ /* Called to convert the object's internal
+ * rep to this type. Frees the internal rep
+ * of the old type. Returns TCL_ERROR on
+ * failure. */
+}
+Tcl_ObjType;
+
+
+/*
+ * One of the following structures exists for each object in the Tcl
+ * system. An object stores a value as either a string, some internal
+ * representation, or both.
+ */
+
+#ifndef Tcl_Obj
+#ifdef USE_TCL_STRUCT
+struct Tcl_Obj {
+ int refCount; /* When 0 the object will be freed. */
+ char *bytes; /* This points to the first byte of the
+ * object's string representation. The array
+ * must be followed by a null byte (i.e., at
+ * offset length) but may also contain
+ * embedded null characters. The array's
+ * storage is allocated by ckalloc. NULL
+ * means the string rep is invalid and must
+ * be regenerated from the internal rep.
+ * Clients should use Tcl_GetStringFromObj
+ * or Tcl_GetString to get a pointer to the
+ * byte array as a readonly value. */
+ int length; /* The number of bytes at *bytes, not
+ * including the terminating null. */
+ Tcl_ObjType *typePtr; /* Denotes the object's type. Always
+ * corresponds to the type of the object's
+ * internal rep. NULL indicates the object
+ * has no internal rep (has no type). */
+ union { /* The internal representation: */
+ long longValue; /* - an long integer value */
+ double doubleValue; /* - a double-precision floating value */
+ VOID *otherValuePtr; /* - another, type-specific value */
+ Tcl_WideInt wideValue; /* - a long long value */
+ struct { /* - internal rep as two pointers */
+ VOID *ptr1;
+ VOID *ptr2;
+ } twoPtrValue;
+ } internalRep;
+};
+
+#define TclObjInternal(o) (&((o)->internalRep))
+#define TclObjGetType(o) ((o)->typePtr)
+#define TclObjSetType(o,t) ((o)->typePtr = (t))
+#define TclObjLength(o) ((o)->length)
+
+#endif
+#endif
+
+#ifndef USE_TCL_STRUCT
+typedef union { /* The internal representation: */
+ long longValue; /* - an long integer value */
+ double doubleValue; /* - a double-precision floating value */
+ VOID *otherValuePtr; /* - another, type-specific value */
+ struct { /* - internal rep as two pointers */
+ VOID *ptr1;
+ VOID *ptr2;
+ } twoPtrValue;
+} Tcl_InternalRep;
+#endif
+
+#ifndef TclObjGetType
+EXTERN Tcl_ObjType * TclObjGetType _ANSI_ARGS_((Tcl_Obj *objPtr));
+#endif
+#ifndef TclObjLength
+EXTERN int TclObjLength _ANSI_ARGS_((Tcl_Obj *objPtr));
+#endif
+#ifndef TclObjSetType
+EXTERN void TclObjSetType _ANSI_ARGS_((Tcl_Obj *objPtr,Tcl_ObjType *newType));
+#endif
+#ifndef TclObjInternal
+EXTERN Tcl_InternalRep * TclObjInternal _ANSI_ARGS_((Tcl_Obj *objPtr));
+#endif
+
+
+/*
+ * Macros to increment and decrement a Tcl_Obj's reference count, and to
+ * test whether an object is shared (i.e. has reference count > 1).
+ * Note: clients should use Tcl_DecrRefCount() when they are finished using
+ * an object, and should never call TclFreeObj() directly. TclFreeObj() is
+ * only defined and made public in tcl.h to support Tcl_DecrRefCount's macro
+ * definition. Note also that Tcl_DecrRefCount() refers to the parameter
+ * "obj" twice. This means that you should avoid calling it with an
+ * expression that is expensive to compute or has side effects.
+ */
+
+EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
+
+#ifdef USE_TCL_STRUCT
+#ifdef TCL_MEM_DEBUG
+# define Tcl_IncrRefCount(objPtr) \
+ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
+# define Tcl_DecrRefCount(objPtr) \
+ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+# define Tcl_IsShared(objPtr) \
+ Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
+#else
+# define Tcl_IncrRefCount(objPtr) \
+ ++(objPtr)->refCount
+# define Tcl_DecrRefCount(objPtr) \
+ if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
+# define Tcl_IsShared(objPtr) \
+ ((objPtr)->refCount > 1)
+#endif
+#endif
+
+/*
+ * Macros and definitions that help to debug the use of Tcl objects.
+ * When TCL_MEM_DEBUG is defined, the Tcl_New declarations are
+ * overridden to call debugging versions of the object creation procedures.
+ */
+
+#ifndef _LANG
+#ifdef TCL_MEM_DEBUG
+# define Tcl_NewBooleanObj(val) \
+ Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
+# define Tcl_NewByteArrayObj(bytes, len) \
+ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__)
+# define Tcl_NewDoubleObj(val) \
+ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
+# define Tcl_NewIntObj(val) \
+ Tcl_DbNewLongObj(val, __FILE__, __LINE__)
+# define Tcl_NewListObj(objc, objv) \
+ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
+# define Tcl_NewLongObj(val) \
+ Tcl_DbNewLongObj(val, __FILE__, __LINE__)
+# define Tcl_NewObj() \
+ Tcl_DbNewObj(__FILE__, __LINE__)
+# define Tcl_NewStringObj(bytes, len) \
+ Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
+# define Tcl_NewWideIntObj(val) \
+ Tcl_DbNewWideIntObj(val, __FILE__, __LINE__)
+#endif /* TCL_MEM_DEBUG */
+#endif
+
+
+/*
+ * The following structure contains the state needed by
+ * Tcl_SaveResult. No-one outside of Tcl should access any of these
+ * fields. This structure is typically allocated on the stack.
+ */
+typedef struct Tcl_SavedResult
+#ifdef USE_TCL_STRUCT
+{
+ char *result;
+ Tcl_FreeProc *freeProc;
+ Tcl_Obj *objResultPtr;
+ char *appendResult;
+ int appendAvl;
+ int appendUsed;
+ char resultSpace[TCL_RESULT_SIZE+1];
+}
+#endif
+Tcl_SavedResult;
+
+
+/*
+ * The following definitions support Tcl's namespace facility.
+ * Note: the first five fields must match exactly the fields in a
+ * Namespace structure (see tclInt.h).
+ */
+
+typedef struct Tcl_Namespace
+#ifdef USE_TCL_STRUCT
+{
+ char *name; /* The namespace's name within its parent
+ * namespace. This contains no ::'s. The
+ * name of the global namespace is ""
+ * although "::" is an synonym. */
+ char *fullName; /* The namespace's fully qualified name.
+ * This starts with ::. */
+ ClientData clientData; /* Arbitrary value associated with this
+ * namespace. */
+ Tcl_NamespaceDeleteProc* deleteProc;
+ /* Procedure invoked when deleting the
+ * namespace to, e.g., free clientData. */
+ struct Tcl_Namespace* parentPtr;
+ /* Points to the namespace that contains
+ * this one. NULL if this is the global
+ * namespace. */
+}
+#endif
+Tcl_Namespace;
+
+
+/*
+ * The following structure represents a call frame, or activation record.
+ * A call frame defines a naming context for a procedure call: its local
+ * scope (for local variables) and its namespace scope (used for non-local
+ * variables; often the global :: namespace). A call frame can also define
+ * the naming context for a namespace eval or namespace inscope command:
+ * the namespace in which the command's code should execute. The
+ * Tcl_CallFrame structures exist only while procedures or namespace
+ * eval/inscope's are being executed, and provide a Tcl call stack.
+ *
+ * A call frame is initialized and pushed using Tcl_PushCallFrame and
+ * popped using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be
+ * provided by the Tcl_PushCallFrame caller, and callers typically allocate
+ * them on the C call stack for efficiency. For this reason, Tcl_CallFrame
+ * is defined as a structure and not as an opaque token. However, most
+ * Tcl_CallFrame fields are hidden since applications should not access
+ * them directly; others are declared as "dummyX".
+ *
+ * WARNING!! The structure definition must be kept consistent with the
+ * CallFrame structure in tclInt.h. If you change one, change the other.
+ */
+
+typedef struct Tcl_CallFrame
+#ifdef USE_TCL_STRUCT
+{
+ Tcl_Namespace *nsPtr;
+ int dummy1;
+ int dummy2;
+ char *dummy3;
+ char *dummy4;
+ char *dummy5;
+ int dummy6;
+ char *dummy7;
+ char *dummy8;
+ int dummy9;
+ char* dummy10;
+}
+#endif
+Tcl_CallFrame;
+
+
+/*
+ * Information about commands that is returned by Tcl_GetCommandInfo and
+ * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based
+ * command procedure while proc is a traditional Tcl argc/argv
+ * string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand
+ * ensure that both objProc and proc are non-NULL and can be called to
+ * execute the command. However, it may be faster to call one instead of
+ * the other. The member isNativeObjectProc is set to 1 if an
+ * object-based procedure was registered by Tcl_CreateObjCommand, and to
+ * 0 if a string-based procedure was registered by Tcl_CreateCommand.
+ * The other procedure is typically set to a compatibility wrapper that
+ * does string-to-object or object-to-string argument conversions then
+ * calls the other procedure.
+ */
+
+typedef struct Tcl_CmdInfo {
+ int isNativeObjectProc; /* 1 if objProc was registered by a call to
+ * Tcl_CreateObjCommand; 0 otherwise.
+ * Tcl_SetCmdInfo does not modify this
+ * field. */
+ Tcl_ObjCmdProc *objProc; /* Command's object-based procedure. */
+ ClientData objClientData; /* ClientData for object proc. */
+ Tcl_CmdProc *proc; /* Command's string-based procedure. */
+ ClientData clientData; /* ClientData for string proc. */
+ Tcl_CmdDeleteProc *deleteProc;
+ /* Procedure to call when command is
+ * deleted. */
+ ClientData deleteData; /* Value to pass to deleteProc (usually
+ * the same as clientData). */
+ Tcl_Namespace *namespacePtr; /* Points to the namespace that contains
+ * this command. Note that Tcl_SetCmdInfo
+ * will not change a command's namespace;
+ * use Tcl_RenameCommand to do that. */
+
+} Tcl_CmdInfo;
+
+/*
+ * The structure defined below is used to hold dynamic strings. The only
+ * field that clients should use is the string field, accessible via the
+ * macro Tcl_DStringValue.
+ */
+
+#ifndef Tcl_DString
+#define TCL_DSTRING_STATIC_SIZE 200
+#ifdef USE_TCL_STRUCT
+typedef struct Tcl_DString {
+ char *string; /* Points to beginning of string: either
+ * staticSpace below or a malloced array. */
+ int length; /* Number of non-NULL characters in the
+ * string. */
+ int spaceAvl; /* Total number of bytes available for the
+ * string and its terminating NULL char. */
+ char staticSpace[TCL_DSTRING_STATIC_SIZE];
+ /* Space to use in common case where string
+ * is small. */
+} Tcl_DString;
+#else
+typedef Tcl_Obj *Tcl_DString;
+#endif
+#endif
+
+#ifdef USE_TCL_STRUCT
+#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
+#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
+#endif
+#define Tcl_DStringTrunc Tcl_DStringSetLength
+
+/*
+ * Definitions for the maximum number of digits of precision that may
+ * be specified in the "tcl_precision" variable, and the number of
+ * bytes of buffer space required by Tcl_PrintDouble.
+ */
+#define TCL_MAX_PREC 17
+#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)
+
+/*
+ * Definition for a number of bytes of buffer space sufficient to hold the
+ * string representation of an integer in base 10 (assuming the existence
+ * of 64-bit integers).
+ */
+#define TCL_INTEGER_SPACE 24
+
+/*
+ * Flag that may be passed to Tcl_ConvertElement to force it not to
+ * output braces (careful! if you change this flag be sure to change
+ * the definitions at the front of tclUtil.c).
+ */
+#define TCL_DONT_USE_BRACES 1
+
+/*
+ * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
+ * abbreviated strings.
+ */
+#define TCL_EXACT 1
+
+/*
+ * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj.
+ * WARNING: these bit choices must not conflict with the bit choices
+ * for evalFlag bits in tclInt.h!!
+ */
+#define TCL_NO_EVAL 0x10000
+#define TCL_EVAL_GLOBAL 0x20000
+#define TCL_EVAL_DIRECT 0x40000
+#define TCL_EVAL_INVOKE 0x80000
+
+/*
+ * Special freeProc values that may be passed to Tcl_SetResult (see
+ * the man page for details):
+ */
+#define TCL_VOLATILE ((Tcl_FreeProc *) 1)
+#define TCL_STATIC ((Tcl_FreeProc *) 0)
+#define TCL_DYNAMIC ((Tcl_FreeProc *) 3)
+
+/*
+ * Flag values passed to variable-related procedures.
+ */
+#define TCL_GLOBAL_ONLY 1
+#define TCL_NAMESPACE_ONLY 2
+#define TCL_APPEND_VALUE 4
+#define TCL_LIST_ELEMENT 8
+#define TCL_TRACE_READS 0x10
+#define TCL_TRACE_WRITES 0x20
+#define TCL_TRACE_UNSETS 0x40
+#define TCL_TRACE_DESTROYED 0x80
+#define TCL_INTERP_DESTROYED 0x100
+#define TCL_LEAVE_ERR_MSG 0x200
+#define TCL_TRACE_ARRAY 0x800
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+/* Required to support old variable/vdelete/vinfo traces */
+#define TCL_TRACE_OLD_STYLE 0x1000
+#endif
+/* Indicate the semantics of the result of a trace */
+#define TCL_TRACE_RESULT_DYNAMIC 0x8000
+#define TCL_TRACE_RESULT_OBJECT 0x10000
+
+/*
+ * Flag values passed to command-related procedures.
+ */
+
+#define TCL_TRACE_RENAME 0x2000
+#define TCL_TRACE_DELETE 0x4000
+
+#define TCL_ALLOW_INLINE_COMPILATION 0x20000
+
+/*
+ * Flag values passed to Tcl_CreateObjTrace, and used internally
+ * by command execution traces. Slots 4,8,16 and 32 are
+ * used internally by execution traces (see tclCmdMZ.c)
+ */
+#define TCL_TRACE_ENTER_EXEC 1
+#define TCL_TRACE_LEAVE_EXEC 2
+
+/*
+ * The TCL_PARSE_PART1 flag is deprecated and has no effect.
+ * The part1 is now always parsed whenever the part2 is NULL.
+ * (This is to avoid a common error when converting code to
+ * use the new object based APIs and forgetting to give the
+ * flag)
+ */
+#ifndef TCL_NO_DEPRECATED
+# define TCL_PARSE_PART1 0x400
+#endif
+
+
+/*
+ * Types for linked variables:
+ */
+#define TCL_LINK_INT 1
+#define TCL_LINK_DOUBLE 2
+#define TCL_LINK_BOOLEAN 3
+#define TCL_LINK_STRING 4
+#define TCL_LINK_WIDE_INT 5
+#define TCL_LINK_READ_ONLY 0x80
+
+
+/*
+ * Forward declarations of Tcl_HashTable and related types.
+ */
+typedef struct Tcl_HashKeyType Tcl_HashKeyType;
+typedef struct Tcl_HashTable Tcl_HashTable;
+typedef struct Tcl_HashEntry Tcl_HashEntry;
+
+typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr,
+ Tcl_HashEntry *hPtr));
+typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr, VOID *keyPtr));
+typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr));
+
+/*
+ * This flag controls whether the hash table stores the hash of a key, or
+ * recalculates it. There should be no reason for turning this flag off
+ * as it is completely binary and source compatible unless you directly
+ * access the bucketPtr member of the Tcl_HashTableEntry structure. This
+ * member has been removed and the space used to store the hash value.
+ */
+#ifndef TCL_HASH_KEY_STORE_HASH
+# define TCL_HASH_KEY_STORE_HASH 1
+#endif
+
+/*
+ * Structure definition for an entry in a hash table. No-one outside
+ * Tcl should access any of these fields directly; use the macros
+ * defined below.
+ */
+
+struct Tcl_HashEntry {
+ Tcl_HashEntry *nextPtr; /* Pointer to next entry in this
+ * hash bucket, or NULL for end of
+ * chain. */
+ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
+#if TCL_HASH_KEY_STORE_HASH
+# if TCL_PRESERVE_BINARY_COMPATABILITY
+ VOID *hash; /* Hash value, stored as pointer to
+ * ensure that the offsets of the
+ * fields in this structure are not
+ * changed. */
+# else
+ unsigned int hash; /* Hash value. */
+# endif
+#else
+ Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to
+ * first entry in this entry's chain:
+ * used for deleting the entry. */
+#endif
+ ClientData clientData; /* Application stores something here
+ * with Tcl_SetHashValue. */
+ union { /* Key has one of these forms: */
+ char *oneWordValue; /* One-word value for key. */
+ Tcl_Obj *objPtr; /* Tcl_Obj * key value. */
+ int words[1]; /* Multiple integer words for key.
+ * The actual size will be as large
+ * as necessary for this table's
+ * keys. */
+ char string[4]; /* String for key. The actual size
+ * will be as large as needed to hold
+ * the key. */
+ } key; /* MUST BE LAST FIELD IN RECORD!! */
+};
+
+/*
+ * Flags used in Tcl_HashKeyType.
+ *
+ * TCL_HASH_KEY_RANDOMIZE_HASH:
+ * There are some things, pointers for example
+ * which don't hash well because they do not use
+ * the lower bits. If this flag is set then the
+ * hash table will attempt to rectify this by
+ * randomising the bits and then using the upper
+ * N bits as the index into the table.
+ */
+#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
+
+/*
+ * Structure definition for the methods associated with a hash table
+ * key type.
+ */
+#define TCL_HASH_KEY_TYPE_VERSION 1
+struct Tcl_HashKeyType {
+ int version; /* Version of the table. If this structure is
+ * extended in future then the version can be
+ * used to distinguish between different
+ * structures.
+ */
+
+ int flags; /* Flags, see above for details. */
+
+ /* Calculates a hash value for the key. If this is NULL then the pointer
+ * itself is used as a hash value.
+ */
+ Tcl_HashKeyProc *hashKeyProc;
+
+ /* Compares two keys and returns zero if they do not match, and non-zero
+ * if they do. If this is NULL then the pointers are compared.
+ */
+ Tcl_CompareHashKeysProc *compareKeysProc;
+
+ /* Called to allocate memory for a new entry, i.e. if the key is a
+ * string then this could allocate a single block which contains enough
+ * space for both the entry and the string. Only the key field of the
+ * allocated Tcl_HashEntry structure needs to be filled in. If something
+ * else needs to be done to the key, i.e. incrementing a reference count
+ * then that should be done by this function. If this is NULL then Tcl_Alloc
+ * is used to allocate enough space for a Tcl_HashEntry and the key pointer
+ * is assigned to key.oneWordValue.
+ */
+ Tcl_AllocHashEntryProc *allocEntryProc;
+
+ /* Called to free memory associated with an entry. If something else needs
+ * to be done to the key, i.e. decrementing a reference count then that
+ * should be done by this function. If this is NULL then Tcl_Free is used
+ * to free the Tcl_HashEntry.
+ */
+ Tcl_FreeHashEntryProc *freeEntryProc;
+};
+
+/*
+ * Structure definition for a hash table. Must be in tcl.h so clients
+ * can allocate space for these structures, but clients should never
+ * access any fields in this structure.
+ */
+
+#define TCL_SMALL_HASH_TABLE 4
+struct Tcl_HashTable {
+ Tcl_HashEntry **buckets; /* Pointer to bucket array. Each
+ * element points to first entry in
+ * bucket's hash chain, or NULL. */
+ Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
+ /* Bucket array used for small tables
+ * (to avoid mallocs and frees). */
+ int numBuckets; /* Total number of buckets allocated
+ * at **bucketPtr. */
+ int numEntries; /* Total number of entries present
+ * in table. */
+ int rebuildSize; /* Enlarge table when numEntries gets
+ * to be this large. */
+ int downShift; /* Shift count used in hashing
+ * function. Designed to use high-
+ * order bits of randomized keys. */
+ int mask; /* Mask value used in hashing
+ * function. */
+ int keyType; /* Type of keys used in this table.
+ * It's either TCL_CUSTOM_KEYS,
+ * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
+ * or an integer giving the number of
+ * ints that is the size of the key.
+ */
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+ CONST char *key));
+ Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+ CONST char *key, int *newPtr));
+#endif
+ Tcl_HashKeyType *typePtr; /* Type of the keys used in the
+ * Tcl_HashTable. */
+};
+
+/*
+ * Structure definition for information used to keep track of searches
+ * through hash tables:
+ */
+
+typedef struct Tcl_HashSearch {
+ Tcl_HashTable *tablePtr; /* Table being searched. */
+ int nextIndex; /* Index of next bucket to be
+ * enumerated after present one. */
+ Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the
+ * the current bucket. */
+} Tcl_HashSearch;
+
+/*
+ * Acceptable key types for hash tables:
+ *
+ * TCL_STRING_KEYS: The keys are strings, they are copied into
+ * the entry.
+ * TCL_ONE_WORD_KEYS: The keys are pointers, the pointer is stored
+ * in the entry.
+ * TCL_CUSTOM_TYPE_KEYS: The keys are arbitrary types which are copied
+ * into the entry.
+ * TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the
+ * pointer is stored in the entry.
+ *
+ * While maintaining binary compatability the above have to be distinct
+ * values as they are used to differentiate between old versions of the
+ * hash table which don't have a typePtr and new ones which do. Once binary
+ * compatability is discarded in favour of making more wide spread changes
+ * TCL_STRING_KEYS can be the same as TCL_CUSTOM_TYPE_KEYS, and
+ * TCL_ONE_WORD_KEYS can be the same as TCL_CUSTOM_PTR_KEYS because they
+ * simply determine how the key is accessed from the entry and not the
+ * behaviour.
+ */
+
+#define TCL_STRING_KEYS 0
+#define TCL_ONE_WORD_KEYS 1
+
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# define TCL_CUSTOM_TYPE_KEYS -2
+# define TCL_CUSTOM_PTR_KEYS -1
+#else
+# define TCL_CUSTOM_TYPE_KEYS TCL_STRING_KEYS
+# define TCL_CUSTOM_PTR_KEYS TCL_ONE_WORD_KEYS
+#endif
+
+/*
+ * Macros for clients to use to access fields of hash entries:
+ */
+
+#define Tcl_GetHashValue(h) ((h)->clientData)
+#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value))
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# define Tcl_GetHashKey(tablePtr, h) \
+ ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \
+ (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \
+ ? (h)->key.oneWordValue \
+ : (h)->key.string))
+#else
+# define Tcl_GetHashKey(tablePtr, h) \
+ ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \
+ ? (h)->key.oneWordValue \
+ : (h)->key.string))
+#endif
+
+/*
+ * Macros to use for clients to use to invoke find and create procedures
+ * for hash tables:
+ */
+
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# define Tcl_FindHashEntry(tablePtr, key) \
+ (*((tablePtr)->findProc))(tablePtr, key)
+# define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
+ (*((tablePtr)->createProc))(tablePtr, key, newPtr)
+#else /* !TCL_PRESERVE_BINARY_COMPATABILITY */
+/*
+ * Macro to use new extended version of Tcl_InitHashTable.
+ */
+# define Tcl_InitHashTable(tablePtr, keyType) \
+ Tcl_InitHashTableEx(tablePtr, keyType, NULL)
+#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */
+
+
+/*
+ * Flag values to pass to Tcl_DoOneEvent to disable searches
+ * for some kinds of events:
+ */
+#define TCL_DONT_WAIT (1<<1)
+#define TCL_WINDOW_EVENTS (1<<2)
+#define TCL_FILE_EVENTS (1<<3)
+#define TCL_TIMER_EVENTS (1<<4)
+#define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */
+#define TCL_ALL_EVENTS (~TCL_DONT_WAIT)
+
+/*
+ * The following structure defines a generic event for the Tcl event
+ * system. These are the things that are queued in calls to Tcl_QueueEvent
+ * and serviced later by Tcl_DoOneEvent. There can be many different
+ * kinds of events with different fields, corresponding to window events,
+ * timer events, etc. The structure for a particular event consists of
+ * a Tcl_Event header followed by additional information specific to that
+ * event.
+ */
+struct Tcl_Event {
+ Tcl_EventProc *proc; /* Procedure to call to service this event. */
+ struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */
+};
+
+/*
+ * Positions to pass to Tcl_QueueEvent:
+ */
+typedef enum {
+ TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
+} Tcl_QueuePosition;
+
+/*
+ * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
+ * event routines.
+ */
+#define TCL_SERVICE_NONE 0
+#define TCL_SERVICE_ALL 1
+
+
+/*
+ * The following structure keeps is used to hold a time value, either as
+ * an absolute time (the number of seconds from the epoch) or as an
+ * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
+ * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT.
+ */
+typedef struct Tcl_Time {
+ long sec; /* Seconds. */
+ long usec; /* Microseconds. */
+} Tcl_Time;
+
+typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr));
+typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr));
+
+
+/*
+ * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler
+ * to indicate what sorts of events are of interest:
+ */
+#define TCL_READABLE (1<<1)
+#define TCL_WRITABLE (1<<2)
+#define TCL_EXCEPTION (1<<3)
+
+/*
+ * Flag values to pass to Tcl_OpenCommandChannel to indicate the
+ * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR,
+ * are also used in Tcl_GetStdChannel.
+ */
+#define TCL_STDIN (1<<1)
+#define TCL_STDOUT (1<<2)
+#define TCL_STDERR (1<<3)
+#define TCL_ENFORCE_MODE (1<<4)
+
+/*
+ * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel
+ * should be closed.
+ */
+#define TCL_CLOSE_READ (1<<1)
+#define TCL_CLOSE_WRITE (1<<2)
+
+/*
+ * Value to use as the closeProc for a channel that supports the
+ * close2Proc interface.
+ */
+#define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1)
+
+/*
+ * Channel version tag. This was introduced in 8.3.2/8.4.
+ */
+#define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1)
+#define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2)
+#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3)
+
+/*
+ * Typedefs for the various operations in a channel type:
+ */
+typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((
+ ClientData instanceData, int mode));
+typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp));
+typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, int flags));
+typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
+ char *buf, int toRead, int *errorCodePtr));
+typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
+ CONST84 char *buf, int toWrite, int *errorCodePtr));
+typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
+ long offset, int mode, int *errorCodePtr));
+typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_((
+ ClientData instanceData, Tcl_Interp *interp,
+ CONST char *optionName, CONST char *value));
+typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_((
+ ClientData instanceData, Tcl_Interp *interp,
+ CONST84 char *optionName, Tcl_DString *dsPtr));
+typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_((
+ ClientData instanceData, int mask));
+typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_((
+ ClientData instanceData, int direction,
+ ClientData *handlePtr));
+typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_((
+ ClientData instanceData));
+typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_((
+ ClientData instanceData, int interestMask));
+typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_((
+ ClientData instanceData, Tcl_WideInt offset,
+ int mode, int *errorCodePtr));
+
+
+/*
+ * The following declarations either map ckalloc and ckfree to
+ * malloc and free, or they map them to procedures with all sorts
+ * of debugging hooks defined in tclCkalloc.c.
+ */
+#ifdef TCL_MEM_DEBUG
+
+# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
+# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
+# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
+# define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__)
+# define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)
+#else /* !TCL_MEM_DEBUG */
+
+/*
+ * If we are not using the debugging allocator, we should call the
+ * Tcl_Alloc, et al. routines in order to guarantee that every module
+ * is using the same memory allocator both inside and outside of the
+ * Tcl library.
+ */
+# define ckalloc(x) Tcl_Alloc(x)
+# define ckfree(x) Tcl_Free(x)
+# define ckrealloc(x,y) Tcl_Realloc(x,y)
+# define attemptckalloc(x) Tcl_AttemptAlloc(x)
+# define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y)
+# define Tcl_InitMemory(x)
+# define Tcl_DumpActiveMemory(x)
+# define Tcl_ValidateAllMemory(x,y)
+
+#endif /* !TCL_MEM_DEBUG */
+
+/*
+ * struct Tcl_ChannelType:
+ *
+ * One such structure exists for each type (kind) of channel.
+ * It collects together in one place all the functions that are
+ * part of the specific channel type.
+ *
+ * It is recommend that the Tcl_Channel* functions are used to access
+ * elements of this structure, instead of direct accessing.
+ */
+typedef struct Tcl_ChannelType
+#ifdef USE_TCL_STRUCT
+{
+ char *typeName; /* The name of the channel type in Tcl
+ * commands. This storage is owned by
+ * channel type. */
+ Tcl_ChannelTypeVersion version; /* Version of the channel type. */
+ Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the
+ * channel, or TCL_CLOSE2PROC if the
+ * close2Proc should be used
+ * instead. */
+ Tcl_DriverInputProc *inputProc; /* Procedure to call for input
+ * on channel. */
+ Tcl_DriverOutputProc *outputProc; /* Procedure to call for output
+ * on channel. */
+ Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek
+ * on the channel. May be NULL. */
+ Tcl_DriverSetOptionProc *setOptionProc;
+ /* Set an option on a channel. */
+ Tcl_DriverGetOptionProc *getOptionProc;
+ /* Get an option from a channel. */
+ Tcl_DriverWatchProc *watchProc; /* Set up the notifier to watch
+ * for events on this channel. */
+ Tcl_DriverGetHandleProc *getHandleProc;
+ /* Get an OS handle from the channel
+ * or NULL if not supported. */
+ Tcl_DriverClose2Proc *close2Proc; /* Procedure to call to close the
+ * channel if the device supports
+ * closing the read & write sides
+ * independently. */
+ Tcl_DriverBlockModeProc *blockModeProc;
+ /* Set blocking mode for the
+ * raw channel. May be NULL. */
+ /*
+ * Only valid in TCL_CHANNEL_VERSION_2 channels or later
+ */
+ Tcl_DriverFlushProc *flushProc; /* Procedure to call to flush a
+ * channel. May be NULL. */
+ Tcl_DriverHandlerProc *handlerProc; /* Procedure to call to handle a
+ * channel event. This will be passed
+ * up the stacked channel chain. */
+ /*
+ * Only valid in TCL_CHANNEL_VERSION_3 channels or later
+ */
+ Tcl_DriverWideSeekProc *wideSeekProc;
+ /* Procedure to call to seek
+ * on the channel which can
+ * handle 64-bit offsets. May be
+ * NULL, and must be NULL if
+ * seekProc is NULL. */
+}
+#endif
+Tcl_ChannelType;
+
+/*
+ * The following flags determine whether the blockModeProc above should
+ * set the channel into blocking or nonblocking mode. They are passed
+ * as arguments to the blockModeProc procedure in the above structure.
+ */
+#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */
+#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking
+ * mode. */
+
+/*
+ * Enum for different types of file paths.
+ */
+typedef enum Tcl_PathType {
+ TCL_PATH_ABSOLUTE,
+ TCL_PATH_RELATIVE,
+ TCL_PATH_VOLUME_RELATIVE
+} Tcl_PathType;
+
+
+/*
+ * The following structure is used to pass glob type data amongst
+ * the various glob routines and Tcl_FSMatchInDirectory.
+ */
+typedef struct Tcl_GlobTypeData {
+ /* Corresponds to bcdpfls as in 'find -t' */
+ int type;
+ /* Corresponds to file permissions */
+ int perm;
+ /* Acceptable mac type */
+ Tcl_Obj* macType;
+ /* Acceptable mac creator */
+ Tcl_Obj* macCreator;
+} Tcl_GlobTypeData;
+
+/*
+ * type and permission definitions for glob command
+ */
+#define TCL_GLOB_TYPE_BLOCK (1<<0)
+#define TCL_GLOB_TYPE_CHAR (1<<1)
+#define TCL_GLOB_TYPE_DIR (1<<2)
+#define TCL_GLOB_TYPE_PIPE (1<<3)
+#define TCL_GLOB_TYPE_FILE (1<<4)
+#define TCL_GLOB_TYPE_LINK (1<<5)
+#define TCL_GLOB_TYPE_SOCK (1<<6)
+#define TCL_GLOB_TYPE_MOUNT (1<<7)
+
+#define TCL_GLOB_PERM_RONLY (1<<0)
+#define TCL_GLOB_PERM_HIDDEN (1<<1)
+#define TCL_GLOB_PERM_R (1<<2)
+#define TCL_GLOB_PERM_W (1<<3)
+#define TCL_GLOB_PERM_X (1<<4)
+
+
+/*
+ * Typedefs for the various filesystem operations:
+ */
+typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
+typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
+typedef Tcl_Channel (Tcl_FSOpenFileChannelProc)
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ int mode, int permissions));
+typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern,
+ Tcl_GlobTypeData * types));
+typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
+typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_StatBuf *buf));
+typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
+typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ int recursive, Tcl_Obj **errorPtr));
+typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
+typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void));
+/* We have to declare the utime structure here. */
+struct utimbuf;
+typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ struct utimbuf *tval));
+typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int nextCheckpoint));
+typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef));
+typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_Obj** objPtrRef));
+typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj *objPtr));
+typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_Obj *toPtr, int linkType));
+typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *pathPtr,
+ Tcl_LoadHandle *handlePtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr));
+typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr));
+typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc)
+ _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc)
+ _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData));
+typedef ClientData (Tcl_FSDupInternalRepProc)
+ _ANSI_ARGS_((ClientData clientData));
+typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc)
+ _ANSI_ARGS_((ClientData clientData));
+typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+
+typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to hooking into the filesystem
+ *----------------------------------------------------------------
+ */
+
+/*
+ * Filesystem version tag. This was introduced in 8.4.
+ */
+#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1)
+
+/*
+ * struct Tcl_Filesystem:
+ *
+ * One such structure exists for each type (kind) of filesystem.
+ * It collects together in one place all the functions that are
+ * part of the specific filesystem. Tcl always accesses the
+ * filesystem through one of these structures.
+ *
+ * Not all entries need be non-NULL; any which are NULL are simply
+ * ignored. However, a complete filesystem should provide all of
+ * these functions. The explanations in the structure show
+ * the importance of each function.
+ */
+
+typedef struct Tcl_Filesystem {
+ CONST char *typeName; /* The name of the filesystem. */
+ int structureLength; /* Length of this structure, so future
+ * binary compatibility can be assured. */
+ Tcl_FSVersion version;
+ /* Version of the filesystem type. */
+ Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
+ /* Function to check whether a path is in
+ * this filesystem. This is the most
+ * important filesystem procedure. */
+ Tcl_FSDupInternalRepProc *dupInternalRepProc;
+ /* Function to duplicate internal fs rep. May
+ * be NULL (but then fs is less efficient). */
+ Tcl_FSFreeInternalRepProc *freeInternalRepProc;
+ /* Function to free internal fs rep. Must
+ * be implemented, if internal representations
+ * need freeing, otherwise it can be NULL. */
+ Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
+ /* Function to convert internal representation
+ * to a normalized path. Only required if
+ * the fs creates pure path objects with no
+ * string/path representation. */
+ Tcl_FSCreateInternalRepProc *createInternalRepProc;
+ /* Function to create a filesystem-specific
+ * internal representation. May be NULL
+ * if paths have no internal representation,
+ * or if the Tcl_FSPathInFilesystemProc
+ * for this filesystem always immediately
+ * creates an internal representation for
+ * paths it accepts. */
+ Tcl_FSNormalizePathProc *normalizePathProc;
+ /* Function to normalize a path. Should
+ * be implemented for all filesystems
+ * which can have multiple string
+ * representations for the same path
+ * object. */
+ Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
+ /* Function to determine the type of a
+ * path in this filesystem. May be NULL. */
+ Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
+ /* Function to return the separator
+ * character(s) for this filesystem. Must
+ * be implemented. */
+ Tcl_FSStatProc *statProc;
+ /*
+ * Function to process a 'Tcl_FSStat()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tcl_FSAccessProc *accessProc;
+ /*
+ * Function to process a 'Tcl_FSAccess()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tcl_FSOpenFileChannelProc *openFileChannelProc;
+ /*
+ * Function to process a
+ * 'Tcl_FSOpenFileChannel()' call. Must be
+ * implemented for any reasonable
+ * filesystem.
+ */
+ Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSMatchInDirectory()'. If not
+ * implemented, then glob and recursive
+ * copy functionality will be lacking in
+ * the filesystem. */
+ Tcl_FSUtimeProc *utimeProc;
+ /* Function to process a
+ * 'Tcl_FSUtime()' call. Required to
+ * allow setting (not reading) of times
+ * with 'file mtime', 'file atime' and
+ * the open-r/open-w/fcopy implementation
+ * of 'file copy'. */
+ Tcl_FSLinkProc *linkProc;
+ /* Function to process a
+ * 'Tcl_FSLink()' call. Should be
+ * implemented only if the filesystem supports
+ * links (reading or creating). */
+ Tcl_FSListVolumesProc *listVolumesProc;
+ /* Function to list any filesystem volumes
+ * added by this filesystem. Should be
+ * implemented only if the filesystem adds
+ * volumes at the head of the filesystem. */
+ Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
+ /* Function to list all attributes strings
+ * which are valid for this filesystem.
+ * If not implemented the filesystem will
+ * not support the 'file attributes' command.
+ * This allows arbitrary additional information
+ * to be attached to files in the filesystem. */
+ Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
+ /* Function to process a
+ * 'Tcl_FSFileAttrsGet()' call, used by
+ * 'file attributes'. */
+ Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
+ /* Function to process a
+ * 'Tcl_FSFileAttrsSet()' call, used by
+ * 'file attributes'. */
+ Tcl_FSCreateDirectoryProc *createDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSCreateDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSRemoveDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSDeleteFileProc *deleteFileProc;
+ /* Function to process a
+ * 'Tcl_FSDeleteFile()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSCopyFileProc *copyFileProc;
+ /* Function to process a
+ * 'Tcl_FSCopyFile()' call. If not
+ * implemented Tcl will fall back
+ * on open-r, open-w and fcopy as
+ * a copying mechanism, for copying
+ * actions initiated in Tcl (not C). */
+ Tcl_FSRenameFileProc *renameFileProc;
+ /* Function to process a
+ * 'Tcl_FSRenameFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy and delete mechanism, for
+ * rename actions initiated in Tcl (not C). */
+ Tcl_FSCopyDirectoryProc *copyDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSCopyDirectory()' call. If
+ * not implemented, Tcl will fall back
+ * on a recursive create-dir, file copy
+ * mechanism, for copying actions
+ * initiated in Tcl (not C). */
+ Tcl_FSLstatProc *lstatProc;
+ /* Function to process a
+ * 'Tcl_FSLstat()' call. If not implemented,
+ * Tcl will attempt to use the 'statProc'
+ * defined above instead. */
+ Tcl_FSLoadFileProc *loadFileProc;
+ /* Function to process a
+ * 'Tcl_FSLoadFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy to native-temp followed by a
+ * Tcl_FSLoadFile on that temporary copy. */
+ Tcl_FSGetCwdProc *getCwdProc;
+ /*
+ * Function to process a 'Tcl_FSGetCwd()'
+ * call. Most filesystems need not
+ * implement this. It will usually only be
+ * called once, if 'getcwd' is called
+ * before 'chdir'. May be NULL.
+ */
+ Tcl_FSChdirProc *chdirProc;
+ /*
+ * Function to process a 'Tcl_FSChdir()'
+ * call. If filesystems do not implement
+ * this, it will be emulated by a series of
+ * directory access checks. Otherwise,
+ * virtual filesystems which do implement
+ * it need only respond with a positive
+ * return result if the dirName is a valid
+ * directory in their filesystem. They
+ * need not remember the result, since that
+ * will be automatically remembered for use
+ * by GetCwd. Real filesystems should
+ * carry out the correct action (i.e. call
+ * the correct system 'chdir' api). If not
+ * implemented, then 'cd' and 'pwd' will
+ * fail inside the filesystem.
+ */
+} Tcl_Filesystem;
+
+/*
+ * The following definitions are used as values for the 'linkAction' flag
+ * to Tcl_FSLink, or the linkProc of any filesystem. Any combination
+ * of flags can be given. For link creation, the linkProc should create
+ * a link which matches any of the types given.
+ *
+ * TCL_CREATE_SYMBOLIC_LINK: Create a symbolic or soft link.
+ * TCL_CREATE_HARD_LINK: Create a hard link.
+ */
+#define TCL_CREATE_SYMBOLIC_LINK 0x01
+#define TCL_CREATE_HARD_LINK 0x02
+
+/*
+ * The following structure represents the Notifier functions that
+ * you can override with the Tcl_SetNotifier call.
+ */
+typedef struct Tcl_NotifierProcs {
+ Tcl_SetTimerProc *setTimerProc;
+ Tcl_WaitForEventProc *waitForEventProc;
+ Tcl_CreateFileHandlerProc *createFileHandlerProc;
+ Tcl_DeleteFileHandlerProc *deleteFileHandlerProc;
+ Tcl_InitNotifierProc *initNotifierProc;
+ Tcl_FinalizeNotifierProc *finalizeNotifierProc;
+ Tcl_AlertNotifierProc *alertNotifierProc;
+ Tcl_ServiceModeHookProc *serviceModeHookProc;
+} Tcl_NotifierProcs;
+
+
+/*
+ * The following structure represents a user-defined encoding. It collects
+ * together all the functions that are used by the specific encoding.
+ */
+typedef struct Tcl_EncodingType
+#ifdef USE_TCL_STRUCT
+{
+ CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp".
+ * This name is the unique key for this
+ * encoding type. */
+ Tcl_EncodingConvertProc *toUtfProc;
+ /* Procedure to convert from external
+ * encoding into UTF-8. */
+ Tcl_EncodingConvertProc *fromUtfProc;
+ /* Procedure to convert from UTF-8 into
+ * external encoding. */
+ Tcl_EncodingFreeProc *freeProc;
+ /* If non-NULL, procedure to call when this
+ * encoding is deleted. */
+ ClientData clientData; /* Arbitrary value associated with encoding
+ * type. Passed to conversion procedures. */
+ int nullSize; /* Number of zero bytes that signify
+ * end-of-string in this encoding. This
+ * number is used to determine the source
+ * string length when the srcLen argument is
+ * negative. Must be 1 or 2. */
+}
+#endif
+Tcl_EncodingType;
+
+/*
+ * The following definitions are used as values for the conversion control
+ * flags argument when converting text from one character set to another:
+ *
+ * TCL_ENCODING_START: Signifies that the source buffer is the first
+ * block in a (potentially multi-block) input
+ * stream. Tells the conversion procedure to
+ * reset to an initial state and perform any
+ * initialization that needs to occur before the
+ * first byte is converted. If the source
+ * buffer contains the entire input stream to be
+ * converted, this flag should be set.
+ *
+ * TCL_ENCODING_END: Signifies that the source buffer is the last
+ * block in a (potentially multi-block) input
+ * stream. Tells the conversion routine to
+ * perform any finalization that needs to occur
+ * after the last byte is converted and then to
+ * reset to an initial state. If the source
+ * buffer contains the entire input stream to be
+ * converted, this flag should be set.
+ *
+ * TCL_ENCODING_STOPONERROR: If set, then the converter will return
+ * immediately upon encountering an invalid
+ * byte sequence or a source character that has
+ * no mapping in the target encoding. If clear,
+ * then the converter will skip the problem,
+ * substituting one or more "close" characters
+ * in the destination buffer and then continue
+ * to sonvert the source.
+ */
+#define TCL_ENCODING_START 0x01
+#define TCL_ENCODING_END 0x02
+#define TCL_ENCODING_STOPONERROR 0x04
+
+
+/*
+ * The following data structures and declarations are for the new Tcl
+ * parser.
+ */
+
+/*
+ * For each word of a command, and for each piece of a word such as a
+ * variable reference, one of the following structures is created to
+ * describe the token.
+ */
+typedef struct Tcl_Token
+#ifdef USE_TCL_STRUCT
+{
+ int type; /* Type of token, such as TCL_TOKEN_WORD;
+ * see below for valid types. */
+ CONST char *start; /* First character in token. */
+ int size; /* Number of bytes in token. */
+ int numComponents; /* If this token is composed of other
+ * tokens, this field tells how many of
+ * them there are (including components of
+ * components, etc.). The component tokens
+ * immediately follow this one. */
+}
+#endif
+Tcl_Token;
+
+/*
+ * Type values defined for Tcl_Token structures. These values are
+ * defined as mask bits so that it's easy to check for collections of
+ * types.
+ *
+ * TCL_TOKEN_WORD - The token describes one word of a command,
+ * from the first non-blank character of
+ * the word (which may be " or {) up to but
+ * not including the space, semicolon, or
+ * bracket that terminates the word.
+ * NumComponents counts the total number of
+ * sub-tokens that make up the word. This
+ * includes, for example, sub-tokens of
+ * TCL_TOKEN_VARIABLE tokens.
+ * TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD
+ * except that the word is guaranteed to
+ * consist of a single TCL_TOKEN_TEXT
+ * sub-token.
+ * TCL_TOKEN_TEXT - The token describes a range of literal
+ * text that is part of a word.
+ * NumComponents is always 0.
+ * TCL_TOKEN_BS - The token describes a backslash sequence
+ * that must be collapsed. NumComponents
+ * is always 0.
+ * TCL_TOKEN_COMMAND - The token describes a command whose result
+ * must be substituted into the word. The
+ * token includes the enclosing brackets.
+ * NumComponents is always 0.
+ * TCL_TOKEN_VARIABLE - The token describes a variable
+ * substitution, including the dollar sign,
+ * variable name, and array index (if there
+ * is one) up through the right
+ * parentheses. NumComponents tells how
+ * many additional tokens follow to
+ * represent the variable name. The first
+ * token will be a TCL_TOKEN_TEXT token
+ * that describes the variable name. If
+ * the variable is an array reference then
+ * there will be one or more additional
+ * tokens, of type TCL_TOKEN_TEXT,
+ * TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and
+ * TCL_TOKEN_VARIABLE, that describe the
+ * array index; numComponents counts the
+ * total number of nested tokens that make
+ * up the variable reference, including
+ * sub-tokens of TCL_TOKEN_VARIABLE tokens.
+ * TCL_TOKEN_SUB_EXPR - The token describes one subexpression of a
+ * expression, from the first non-blank
+ * character of the subexpression up to but not
+ * including the space, brace, or bracket
+ * that terminates the subexpression.
+ * NumComponents counts the total number of
+ * following subtokens that make up the
+ * subexpression; this includes all subtokens
+ * for any nested TCL_TOKEN_SUB_EXPR tokens.
+ * For example, a numeric value used as a
+ * primitive operand is described by a
+ * TCL_TOKEN_SUB_EXPR token followed by a
+ * TCL_TOKEN_TEXT token. A binary subexpression
+ * is described by a TCL_TOKEN_SUB_EXPR token
+ * followed by the TCL_TOKEN_OPERATOR token
+ * for the operator, then TCL_TOKEN_SUB_EXPR
+ * tokens for the left then the right operands.
+ * TCL_TOKEN_OPERATOR - The token describes one expression operator.
+ * An operator might be the name of a math
+ * function such as "abs". A TCL_TOKEN_OPERATOR
+ * token is always preceeded by one
+ * TCL_TOKEN_SUB_EXPR token for the operator's
+ * subexpression, and is followed by zero or
+ * more TCL_TOKEN_SUB_EXPR tokens for the
+ * operator's operands. NumComponents is
+ * always 0.
+ */
+#define TCL_TOKEN_WORD 1
+#define TCL_TOKEN_SIMPLE_WORD 2
+#define TCL_TOKEN_TEXT 4
+#define TCL_TOKEN_BS 8
+#define TCL_TOKEN_COMMAND 16
+#define TCL_TOKEN_VARIABLE 32
+#define TCL_TOKEN_SUB_EXPR 64
+#define TCL_TOKEN_OPERATOR 128
+
+/*
+ * Parsing error types. On any parsing error, one of these values
+ * will be stored in the error field of the Tcl_Parse structure
+ * defined below.
+ */
+#define TCL_PARSE_SUCCESS 0
+#define TCL_PARSE_QUOTE_EXTRA 1
+#define TCL_PARSE_BRACE_EXTRA 2
+#define TCL_PARSE_MISSING_BRACE 3
+#define TCL_PARSE_MISSING_BRACKET 4
+#define TCL_PARSE_MISSING_PAREN 5
+#define TCL_PARSE_MISSING_QUOTE 6
+#define TCL_PARSE_MISSING_VAR_BRACE 7
+#define TCL_PARSE_SYNTAX 8
+#define TCL_PARSE_BAD_NUMBER 9
+
+/*
+ * A structure of the following type is filled in by Tcl_ParseCommand.
+ * It describes a single command parsed from an input string.
+ */
+#define NUM_STATIC_TOKENS 20
+
+typedef struct Tcl_Parse
+#ifdef USE_TCL_STRUCT
+{
+ CONST char *commentStart; /* Pointer to # that begins the first of
+ * one or more comments preceding the
+ * command. */
+ int commentSize; /* Number of bytes in comments (up through
+ * newline character that terminates the
+ * last comment). If there were no
+ * comments, this field is 0. */
+ CONST char *commandStart; /* First character in first word of command. */
+ int commandSize; /* Number of bytes in command, including
+ * first character of first word, up
+ * through the terminating newline,
+ * close bracket, or semicolon. */
+ int numWords; /* Total number of words in command. May
+ * be 0. */
+ Tcl_Token *tokenPtr; /* Pointer to first token representing
+ * the words of the command. Initially
+ * points to staticTokens, but may change
+ * to point to malloc-ed space if command
+ * exceeds space in staticTokens. */
+ int numTokens; /* Total number of tokens in command. */
+ int tokensAvailable; /* Total number of tokens available at
+ * *tokenPtr. */
+ int errorType; /* One of the parsing error types defined
+ * above. */
+
+ /*
+ * The fields below are intended only for the private use of the
+ * parser. They should not be used by procedures that invoke
+ * Tcl_ParseCommand.
+ */
+
+ CONST char *string; /* The original command string passed to
+ * Tcl_ParseCommand. */
+ CONST char *end; /* Points to the character just after the
+ * last one in the command string. */
+ Tcl_Interp *interp; /* Interpreter to use for error reporting,
+ * or NULL. */
+ CONST char *term; /* Points to character in string that
+ * terminated most recent token. Filled in
+ * by ParseTokens. If an error occurs,
+ * points to beginning of region where the
+ * error occurred (e.g. the open brace if
+ * the close brace is missing). */
+ int incomplete; /* This field is set to 1 by Tcl_ParseCommand
+ * if the command appears to be incomplete.
+ * This information is used by
+ * Tcl_CommandComplete. */
+ Tcl_Token staticTokens[NUM_STATIC_TOKENS];
+ /* Initial space for tokens for command.
+ * This space should be large enough to
+ * accommodate most commands; dynamic
+ * space is allocated for very large
+ * commands that don't fit here. */
+}
+#endif
+Tcl_Parse;
+
+/*
+ * The following definitions are the error codes returned by the conversion
+ * routines:
+ *
+ * TCL_OK: All characters were converted.
+ *
+ * TCL_CONVERT_NOSPACE: The output buffer would not have been large
+ * enough for all of the converted data; as many
+ * characters as could fit were converted though.
+ *
+ * TCL_CONVERT_MULTIBYTE: The last few bytes in the source string were
+ * the beginning of a multibyte sequence, but
+ * more bytes were needed to complete this
+ * sequence. A subsequent call to the conversion
+ * routine should pass the beginning of this
+ * unconverted sequence plus additional bytes
+ * from the source stream to properly convert
+ * the formerly split-up multibyte sequence.
+ *
+ * TCL_CONVERT_SYNTAX: The source stream contained an invalid
+ * character sequence. This may occur if the
+ * input stream has been damaged or if the input
+ * encoding method was misidentified. This error
+ * is reported only if TCL_ENCODING_STOPONERROR
+ * was specified.
+ *
+ * TCL_CONVERT_UNKNOWN: The source string contained a character
+ * that could not be represented in the target
+ * encoding. This error is reported only if
+ * TCL_ENCODING_STOPONERROR was specified.
+ */
+#define TCL_CONVERT_MULTIBYTE -1
+#define TCL_CONVERT_SYNTAX -2
+#define TCL_CONVERT_UNKNOWN -3
+#define TCL_CONVERT_NOSPACE -4
+
+/*
+ * The maximum number of bytes that are necessary to represent a single
+ * Unicode character in UTF-8. The valid values should be 3 or 6 (or
+ * perhaps 1 if we want to support a non-unicode enabled core).
+ * If 3, then Tcl_UniChar must be 2-bytes in size (UCS-2). (default)
+ * If 6, then Tcl_UniChar must be 4-bytes in size (UCS-4).
+ * At this time UCS-2 mode is the default and recommended mode.
+ * UCS-4 is experimental and not recommended. It works for the core,
+ * but most extensions expect UCS-2.
+ */
+#ifndef TCL_UTF_MAX
+#define TCL_UTF_MAX 3
+#endif
+
+/*
+ * This represents a Unicode character. Any changes to this should
+ * also be reflected in regcustom.h.
+ */
+#if TCL_UTF_MAX > 3
+ /*
+ * unsigned int isn't 100% accurate as it should be a strict 4-byte
+ * value (perhaps wchar_t). 64-bit systems may have troubles. The
+ * size of this value must be reflected correctly in regcustom.h.
+ */
+typedef unsigned int Tcl_UniChar;
+#else
+typedef unsigned short Tcl_UniChar;
+#endif
+
+
+/*
+ * Deprecated Tcl procedures:
+ */
+#ifndef TCL_NO_DEPRECATED
+# define Tcl_EvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),0)
+# define Tcl_GlobalEvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
+#endif
+
+
+/*
+ * These function have been renamed. The old names are deprecated, but we
+ * define these macros for backwards compatibilty.
+ */
+#define Tcl_Ckalloc Tcl_Alloc
+#define Tcl_Ckfree Tcl_Free
+#define Tcl_Ckrealloc Tcl_Realloc
+#define Tcl_Return Tcl_SetResult
+#define Tcl_TildeSubst Tcl_TranslateFileName
+#ifndef _LANG
+#define panic Tcl_Panic
+#endif
+#define panicVA Tcl_PanicVA
+
+
+/*
+ * The following constant is used to test for older versions of Tcl
+ * in the stubs tables.
+ *
+ * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different
+ * value since the stubs tables don't match.
+ */
+
+#define TCL_STUB_MAGIC ((int)0xFCA3BACF)
+
+/*
+ * The following function is required to be defined in all stubs aware
+ * extensions. The function is actually implemented in the stub
+ * library, not the main Tcl library, although there is a trivial
+ * implementation in the main library in case an extension is statically
+ * linked into an application.
+ */
+
+EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *version, int exact));
+
+#ifndef USE_TCL_STUBS
+
+/*
+ * When not using stubs, make it a macro.
+ */
+
+#define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgRequire(interp, "Tcl", version, exact)
+
+#endif
+
+
+/*
+ * Include the public function declarations that are accessible via
+ * the stubs table.
+ */
+
+#include "tclDecls.h"
+
+/*
+ * Include platform specific public function declarations that are
+ * accessible via the stubs table.
+ */
+
+/*
+ * tclPlatDecls.h can't be included here on the Mac, as we need
+ * Mac specific headers to define the Mac types used in this file,
+ * but these Mac haders conflict with a number of tk types
+ * and thus can't be included in the globally read tcl.h
+ * This header was originally added here as a fix for bug 5241
+ * (stub link error for symbols in TclPlatStubs table), as a work-
+ * around for the bug on the mac, tclMac.h is included immediately
+ * after tcl.h in the tcl precompiled header (with DLLEXPORT set).
+ */
+
+#if !defined(MAC_TCL)
+#include "tclPlatDecls.h"
+#endif
+
+/*
+ * Public functions that are not accessible via the stubs table.
+ */
+
+EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
+ Tcl_AppInitProc *appInitProc));
+
+/*
+ * Convenience declaration of Tcl_AppInit for backwards compatibility.
+ * This function is not *implemented* by the tcl library, so the storage
+ * class is neither DLLEXPORT nor DLLIMPORT
+ */
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS
+
+EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* RC_INVOKED */
+
+/*
+ * end block for C++
+ */
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _TCL */
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.h
new file mode 100755
index 00000000000..6ae47c1d922
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.h
@@ -0,0 +1,4143 @@
+/*
+ * tclDecls.h --
+ *
+ * Declarations of functions in the platform independent public Tcl API.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclDecls.h,v 1.93.2.1 2003/05/13 09:57:40 mistachkin Exp $
+ */
+
+#ifndef _TCLDECLS
+#define _TCLDECLS
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tcl.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+/* 0 */
+EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp* interp,
+ CONST char* name, CONST char* version,
+ ClientData clientData));
+/* 1 */
+EXTERN CONST84_RETURN char * Tcl_PkgRequireEx _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ CONST char * version, int exact,
+ ClientData * clientDataPtr));
+/* 2 */
+EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
+/* 3 */
+EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size));
+/* 4 */
+EXTERN void Tcl_Free _ANSI_ARGS_((char * ptr));
+/* 5 */
+EXTERN char * Tcl_Realloc _ANSI_ARGS_((char * ptr,
+ unsigned int size));
+/* 6 */
+EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size,
+ CONST char * file, int line));
+/* 7 */
+EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char * ptr,
+ CONST char * file, int line));
+/* 8 */
+EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char * ptr,
+ unsigned int size, CONST char * file,
+ int line));
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 9 */
+EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask,
+ Tcl_FileProc * proc, ClientData clientData));
+#endif /* UNIX */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 10 */
+EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd));
+#endif /* UNIX */
+/* 11 */
+EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time * timePtr));
+/* 12 */
+EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms));
+/* 13 */
+EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time * timePtr));
+/* 14 */
+EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr));
+/* 15 */
+EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr));
+/* 16 */
+EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr,
+ CONST char* bytes, int length));
+/* 17 */
+EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[]));
+/* 18 */
+EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, Tcl_ObjType * typePtr));
+/* 19 */
+EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj * objPtr,
+ CONST char * file, int line));
+/* 20 */
+EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj * objPtr,
+ CONST char * file, int line));
+/* 21 */
+EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj * objPtr,
+ CONST char * file, int line));
+/* 22 */
+EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue,
+ CONST char * file, int line));
+/* 23 */
+EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj _ANSI_ARGS_((
+ CONST unsigned char * bytes, int length,
+ CONST char * file, int line));
+/* 24 */
+EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue,
+ CONST char * file, int line));
+/* 25 */
+EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST * objv, CONST char * file,
+ int line));
+/* 26 */
+EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue,
+ CONST char * file, int line));
+/* 27 */
+EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((CONST char * file,
+ int line));
+/* 28 */
+EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((CONST char * bytes,
+ int length, CONST char * file, int line));
+/* 29 */
+EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 30 */
+EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 31 */
+EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * boolPtr));
+/* 32 */
+EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ int * boolPtr));
+/* 33 */
+EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_((
+ Tcl_Obj * objPtr, int * lengthPtr));
+/* 34 */
+EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, double * doublePtr));
+/* 35 */
+EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ double * doublePtr));
+/* 36 */
+EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, CONST char ** tablePtr,
+ CONST char * msg, int flags, int * indexPtr));
+/* 37 */
+EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * intPtr));
+/* 38 */
+EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int * intPtr));
+/* 39 */
+EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, long * longPtr));
+/* 40 */
+EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((CONST char * typeName));
+/* 41 */
+EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int * lengthPtr));
+/* 42 */
+EXTERN void Tcl_InvalidateStringRep _ANSI_ARGS_((
+ Tcl_Obj * objPtr));
+/* 43 */
+EXTERN int Tcl_ListObjAppendList _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * listPtr,
+ Tcl_Obj * elemListPtr));
+/* 44 */
+EXTERN int Tcl_ListObjAppendElement _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * listPtr,
+ Tcl_Obj * objPtr));
+/* 45 */
+EXTERN int Tcl_ListObjGetElements _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * listPtr,
+ int * objcPtr, Tcl_Obj *** objvPtr));
+/* 46 */
+EXTERN int Tcl_ListObjIndex _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * listPtr, int index,
+ Tcl_Obj ** objPtrPtr));
+/* 47 */
+EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * listPtr, int * lengthPtr));
+/* 48 */
+EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * listPtr, int first, int count,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 49 */
+EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue));
+/* 50 */
+EXTERN Tcl_Obj * Tcl_NewByteArrayObj _ANSI_ARGS_((
+ CONST unsigned char* bytes, int length));
+/* 51 */
+EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue));
+/* 52 */
+EXTERN Tcl_Obj * Tcl_NewIntObj _ANSI_ARGS_((int intValue));
+/* 53 */
+EXTERN Tcl_Obj * Tcl_NewListObj _ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[]));
+/* 54 */
+EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue));
+/* 55 */
+EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void));
+/* 56 */
+EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((CONST char * bytes,
+ int length));
+/* 57 */
+EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int boolValue));
+/* 58 */
+EXTERN unsigned char * Tcl_SetByteArrayLength _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int length));
+/* 59 */
+EXTERN void Tcl_SetByteArrayObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ CONST unsigned char * bytes, int length));
+/* 60 */
+EXTERN void Tcl_SetDoubleObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ double doubleValue));
+/* 61 */
+EXTERN void Tcl_SetIntObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int intValue));
+/* 62 */
+EXTERN void Tcl_SetListObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 63 */
+EXTERN void Tcl_SetLongObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ long longValue));
+/* 64 */
+EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int length));
+/* 65 */
+EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj* objPtr,
+ CONST char* bytes, int length));
+/* 66 */
+EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * message));
+/* 67 */
+EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * message, int length));
+/* 68 */
+EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp));
+/* 69 */
+EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string));
+/* 70 */
+EXTERN void Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
+/* 71 */
+EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc,
+ ClientData clientData));
+/* 72 */
+EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async));
+/* 73 */
+EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp * interp,
+ int code));
+/* 74 */
+EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
+/* 75 */
+EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void));
+/* 76 */
+EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp * interp));
+/* 77 */
+EXTERN char Tcl_Backslash _ANSI_ARGS_((CONST char * src,
+ int * readPtr));
+/* 78 */
+EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * optionName,
+ CONST char * optionList));
+/* 79 */
+EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_InterpDeleteProc * proc,
+ ClientData clientData));
+/* 80 */
+EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((
+ Tcl_IdleProc * idleProc,
+ ClientData clientData));
+/* 81 */
+EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel chan));
+/* 82 */
+EXTERN int Tcl_CommandComplete _ANSI_ARGS_((CONST char * cmd));
+/* 83 */
+EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc,
+ CONST84 char * CONST * objv));
+/* 84 */
+EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char * src,
+ char * dst, int flags));
+/* 85 */
+EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((
+ CONST char * src, int length, char * dst,
+ int flags));
+/* 86 */
+EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp * slave,
+ CONST char * slaveCmd, Tcl_Interp * target,
+ CONST char * targetCmd, int argc,
+ CONST84 char * CONST * objv));
+/* 87 */
+EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp * slave,
+ CONST char * slaveCmd, Tcl_Interp * target,
+ CONST char * targetCmd, int objc,
+ Tcl_Obj *CONST objv[]));
+/* 88 */
+EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_((
+ Tcl_ChannelType * typePtr,
+ CONST char * chanName,
+ ClientData instanceData, int mask));
+/* 89 */
+EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_((
+ Tcl_Channel chan, int mask,
+ Tcl_ChannelProc * proc,
+ ClientData clientData));
+/* 90 */
+EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_CloseProc * proc, ClientData clientData));
+/* 91 */
+EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc));
+
+
+
+/* 92 */
+EXTERN void Tcl_CreateEventSource _ANSI_ARGS_((
+ Tcl_EventSetupProc * setupProc,
+ Tcl_EventCheckProc * checkProc,
+ ClientData clientData));
+/* 93 */
+EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+/* 94 */
+EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void));
+/* 95 */
+EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, int numArgs,
+ Tcl_ValueType * argTypes,
+ Tcl_MathProc * proc, ClientData clientData));
+/* 96 */
+EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * cmdName,
+ Tcl_ObjCmdProc * proc, ClientData clientData,
+ Tcl_CmdDeleteProc * deleteProc));
+/* 97 */
+EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * slaveName, int isSafe));
+/* 98 */
+EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds,
+ Tcl_TimerProc * proc, ClientData clientData));
+/* 99 */
+EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp * interp,
+ int level, Tcl_CmdTraceProc * proc,
+ ClientData clientData));
+/* 100 */
+EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name));
+/* 101 */
+EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_((
+ Tcl_Channel chan, Tcl_ChannelProc * proc,
+ ClientData clientData));
+/* 102 */
+EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_CloseProc * proc, ClientData clientData));
+/* 103 */
+EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName));
+
+/* 104 */
+EXTERN int Tcl_DeleteCommandFromToken _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command command));
+
+/* 105 */
+EXTERN void Tcl_DeleteEvents _ANSI_ARGS_((
+ Tcl_EventDeleteProc * proc,
+ ClientData clientData));
+/* 106 */
+EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_((
+ Tcl_EventSetupProc * setupProc,
+ Tcl_EventCheckProc * checkProc,
+ ClientData clientData));
+/* 107 */
+EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+/* 108 */
+EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_((
+ Tcl_HashEntry * entryPtr));
+/* 109 */
+EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr));
+/* 110 */
+EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp * interp));
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 111 */
+EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids,
+ Tcl_Pid * pidPtr));
+#endif /* UNIX */
+#ifdef __WIN32__
+/* 111 */
+EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids,
+ Tcl_Pid * pidPtr));
+#endif /* __WIN32__ */
+/* 112 */
+EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_((
+ Tcl_TimerToken token));
+/* 113 */
+EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Trace trace));
+/* 114 */
+EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tcl_InterpDeleteProc * proc,
+ ClientData clientData));
+/* 115 */
+EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags));
+/* 116 */
+EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc,
+ ClientData clientData));
+/* 117 */
+EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr,
+ CONST char * str, int length));
+/* 118 */
+EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_((
+ Tcl_DString * dsPtr, CONST char * string));
+/* 119 */
+EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((
+ Tcl_DString * dsPtr));
+/* 120 */
+EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString * dsPtr));
+/* 121 */
+EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_DString * dsPtr));
+/* 122 */
+EXTERN void Tcl_DStringInit _ANSI_ARGS_((Tcl_DString * dsPtr));
+/* 123 */
+EXTERN void Tcl_DStringResult _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_DString * dsPtr));
+/* 124 */
+EXTERN void Tcl_DStringSetLength _ANSI_ARGS_((
+ Tcl_DString * dsPtr, int length));
+/* 125 */
+EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_((
+ Tcl_DString * dsPtr));
+/* 126 */
+EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan));
+/* 127 */
+EXTERN CONST84_RETURN char * Tcl_ErrnoId _ANSI_ARGS_((void));
+/* 128 */
+EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
+/* 129 */
+EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string));
+/* 130 */
+EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * fileName));
+/* 131 */
+EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr));
+/* 132 */
+EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_FreeProc * freeProc));
+/* 133 */
+EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
+/* 134 */
+EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * hiddenCmdToken,
+ CONST char * cmdName));
+/* 135 */
+EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * ptr));
+/* 136 */
+EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int * ptr));
+/* 137 */
+EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, double * ptr));
+/* 138 */
+EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, double * ptr));
+/* 139 */
+EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, long * ptr));
+/* 140 */
+EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, long * ptr));
+/* 141 */
+EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr));
+/* 142 */
+EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string));
+/* 143 */
+EXTERN void Tcl_Finalize _ANSI_ARGS_((void));
+/* 144 */
+EXTERN void Tcl_FindExecutable _ANSI_ARGS_((CONST char * argv0));
+/* 145 */
+EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr,
+ Tcl_HashSearch * searchPtr));
+/* 146 */
+EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan));
+/* 147 */
+EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp * interp));
+/* 148 */
+EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * slaveCmd,
+ Tcl_Interp ** targetInterpPtr,
+ CONST84 char ** targetCmdPtr, int * argcPtr,
+ CONST84 char *** argvPtr));
+/* 149 */
+EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * slaveCmd,
+ Tcl_Interp ** targetInterpPtr,
+ CONST84 char ** targetCmdPtr, int * objcPtr,
+ Tcl_Obj *** objv));
+/* 150 */
+EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name,
+ Tcl_InterpDeleteProc ** procPtr));
+/* 151 */
+EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * chanName, int * modePtr));
+/* 152 */
+EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_((
+ Tcl_Channel chan));
+/* 153 */
+EXTERN int Tcl_GetChannelHandle _ANSI_ARGS_((Tcl_Channel chan,
+ int direction, ClientData * handlePtr));
+/* 154 */
+EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_((
+ Tcl_Channel chan));
+/* 155 */
+EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan));
+/* 156 */
+EXTERN CONST84_RETURN char * Tcl_GetChannelName _ANSI_ARGS_((
+ Tcl_Channel chan));
+/* 157 */
+EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Channel chan,
+ CONST char * optionName, Tcl_DString * dsPtr));
+/* 158 */
+EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
+/* 159 */
+EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * cmdName, Tcl_CmdInfo * infoPtr));
+/* 160 */
+EXTERN CONST84_RETURN char * Tcl_GetCommandName _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Command command));
+/* 161 */
+EXTERN int Tcl_GetErrno _ANSI_ARGS_((void));
+/* 162 */
+EXTERN CONST84_RETURN char * Tcl_GetHostName _ANSI_ARGS_((void));
+/* 163 */
+EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((
+ Tcl_Interp * askInterp,
+ Tcl_Interp * slaveInterp));
+/* 164 */
+EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp * interp));
+/* 165 */
+EXTERN CONST char * Tcl_GetNameOfExecutable _ANSI_ARGS_((void));
+/* 166 */
+EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp));
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 167 */
+EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int forWriting,
+ int checkUsage, ClientData * filePtr));
+#endif /* UNIX */
+/* 168 */
+EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((CONST char * path));
+/* 169 */
+EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_DString * dsPtr));
+/* 170 */
+EXTERN int Tcl_GetsObj _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_Obj * objPtr));
+/* 171 */
+EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void));
+/* 172 */
+EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * slaveName));
+/* 173 */
+EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type));
+/* 174 */
+EXTERN CONST84_RETURN char * Tcl_GetStringResult _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 175 */
+EXTERN CONST84_RETURN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags));
+/* 176 */
+EXTERN CONST84_RETURN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags));
+/* 177 */
+EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * command));
+/* 178 */
+EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr));
+/* 179 */
+EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * cmdName,
+ CONST char * hiddenCmdToken));
+/* 180 */
+EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp * interp));
+/* 181 */
+EXTERN void Tcl_InitHashTable _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, int keyType));
+/* 182 */
+EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan));
+/* 183 */
+EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan));
+/* 184 */
+EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp * interp));
+/* 185 */
+EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp));
+/* 186 */
+EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc,
+ CONST84 char * CONST * objv,
+ Tcl_DString * resultPtr));
+/* 187 */
+EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, char * addr, int type));
+/* Slot 188 is reserved */
+/* 189 */
+EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle,
+ int mode));
+/* 190 */
+EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp * interp));
+/* 191 */
+EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_((
+ ClientData tcpSocket));
+/* 192 */
+EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc,
+ CONST84 char * CONST * objv));
+/* 193 */
+EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_((
+ Tcl_HashSearch * searchPtr));
+/* 194 */
+EXTERN void Tcl_NotifyChannel _ANSI_ARGS_((Tcl_Channel channel,
+ int mask));
+/* 195 */
+EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
+ int flags));
+/* 196 */
+EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
+ Tcl_Obj * newValuePtr, int flags));
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 197 */
+EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_((
+ Tcl_Interp * interp, int argc,
+ CONST84 Tcl_Obj *CONST *objv, int flags));
+#endif /* UNIX */
+#ifdef __WIN32__
+/* 197 */
+EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_((
+ Tcl_Interp * interp, int argc,
+ CONST84 Tcl_Obj *CONST *objv, int flags));
+#endif /* __WIN32__ */
+/* 198 */
+EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * fileName,
+ CONST char * modeString, int permissions));
+/* 199 */
+EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp * interp,
+ int port, CONST char * address,
+ CONST char * myaddr, int myport, int async));
+/* 200 */
+EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp * interp,
+ int port, CONST char * host,
+ Tcl_TcpAcceptProc * acceptProc,
+ ClientData callbackData));
+/* 201 */
+EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data));
+/* 202 */
+EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp,
+ double value, char * dst));
+/* 203 */
+EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * string));
+/* 204 */
+EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp));
+/* 205 */
+EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event * evPtr,
+ Tcl_QueuePosition position));
+/* 206 */
+EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan,
+ char * bufPtr, int toRead));
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 207 */
+EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
+#endif /* UNIX */
+#ifdef __WIN32__
+/* 207 */
+EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
+#endif /* __WIN32__ */
+/* 208 */
+EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * cmd, int flags));
+/* 209 */
+EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * cmdPtr,
+ int flags));
+/* 210 */
+EXTERN void Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel chan));
+/* 211 */
+EXTERN void Tcl_RegisterObjType _ANSI_ARGS_((
+ Tcl_ObjType * typePtr));
+/* 212 */
+EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string));
+/* 213 */
+EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_RegExp regexp, CONST char * str,
+ CONST char * start));
+/* 214 */
+EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, CONST char * pattern));
+/* 215 */
+EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp,
+ int index, CONST84 char ** startPtr,
+ CONST84 char ** endPtr));
+/* 216 */
+EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
+/* 217 */
+EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp * interp));
+/* 218 */
+EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * str,
+ int * flagPtr));
+/* 219 */
+EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char * str,
+ int length, int * flagPtr));
+/* 220 */
+EXTERN int Tcl_SeekOld _ANSI_ARGS_((Tcl_Channel chan,
+ int offset, int mode));
+/* 221 */
+EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void));
+/* 222 */
+EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags));
+/* 223 */
+EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name,
+ Tcl_InterpDeleteProc * proc,
+ ClientData clientData));
+/* 224 */
+EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_((
+ Tcl_Channel chan, int sz));
+/* 225 */
+EXTERN int Tcl_SetChannelOption _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Channel chan,
+ CONST char * optionName,
+ CONST char * newValue));
+/* 226 */
+EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * cmdName,
+ CONST Tcl_CmdInfo * infoPtr));
+/* 227 */
+EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err));
+/* 228 */
+EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
+/* 229 */
+EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr));
+/* 230 */
+EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((
+ Tcl_PanicProc * panicProc));
+/* 231 */
+EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((
+ Tcl_Interp * interp, int depth));
+/* 232 */
+EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp,
+ char * str, Tcl_FreeProc * freeProc));
+/* 233 */
+EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode));
+/* 234 */
+EXTERN void Tcl_SetObjErrorCode _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * errorObjPtr));
+/* 235 */
+EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * resultObjPtr));
+/* 236 */
+EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel,
+ int type));
+/* 237 */
+EXTERN CONST84_RETURN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, CONST char * newValue,
+ int flags));
+/* 238 */
+EXTERN CONST84_RETURN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ CONST char * newValue, int flags));
+/* 239 */
+EXTERN CONST84_RETURN char * Tcl_SignalId _ANSI_ARGS_((int sig));
+/* 240 */
+EXTERN CONST84_RETURN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
+/* 241 */
+EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp));
+/* 242 */
+EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * listStr, int * argcPtr,
+ CONST84 char *** argvPtr));
+/* 243 */
+EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char * path,
+ int * argcPtr, CONST84 char *** argvPtr));
+/* 244 */
+EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * pkgName,
+ Tcl_PackageInitProc * initProc,
+ Tcl_PackageInitProc * safeInitProc));
+/* 245 */
+EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str,
+ CONST char * pattern));
+/* 246 */
+EXTERN int Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan));
+/* 247 */
+EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags,
+ Tcl_VarTraceProc * proc,
+ ClientData clientData));
+/* 248 */
+EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags, Tcl_VarTraceProc * proc,
+ ClientData clientData));
+/* 249 */
+EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ Tcl_DString * bufferPtr));
+/* 250 */
+EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * str, int len, int atHead));
+/* 251 */
+EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName));
+/* 252 */
+EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Channel chan));
+/* 253 */
+EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags));
+/* 254 */
+EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags));
+/* 255 */
+EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags,
+ Tcl_VarTraceProc * proc,
+ ClientData clientData));
+/* 256 */
+EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags, Tcl_VarTraceProc * proc,
+ ClientData clientData));
+/* 257 */
+EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName));
+/* 258 */
+EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * frameName, CONST char * varName,
+ CONST char * localName, int flags));
+/* 259 */
+EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * frameName, CONST char * part1,
+ CONST char * part2, CONST char * localName,
+ int flags));
+/* 260 */
+EXTERN int Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
+/* 261 */
+EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags,
+ Tcl_VarTraceProc * procPtr,
+ ClientData prevClientData));
+/* 262 */
+EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags, Tcl_VarTraceProc * procPtr,
+ ClientData prevClientData));
+/* 263 */
+EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * s, int slen));
+/* 264 */
+EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[],
+ CONST char * message));
+/* 265 */
+EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((
+ CONST char * fileName));
+/* 266 */
+EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((CONST char * file,
+ int line));
+/* 267 */
+EXTERN void Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp,
+ va_list argList));
+/* 268 */
+EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_((
+ Tcl_Obj * objPtr, va_list argList));
+/* 269 */
+EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr));
+/* 270 */
+EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, CONST84 char ** termPtr));
+/* 271 */
+EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, CONST char * version,
+ int exact));
+/* 272 */
+EXTERN CONST84_RETURN char * Tcl_PkgPresentEx _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ CONST char * version, int exact,
+ ClientData * clientDataPtr));
+/* 273 */
+EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, CONST char * version));
+/* 274 */
+EXTERN CONST84_RETURN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, CONST char * version,
+ int exact));
+/* 275 */
+EXTERN void Tcl_SetErrorCodeVA _ANSI_ARGS_((Tcl_Interp * interp,
+ va_list argList));
+/* 276 */
+EXTERN int Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp,
+ va_list argList));
+/* 277 */
+EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int * statPtr,
+ int options));
+/* 278 */
+EXTERN void Tcl_PanicVA _ANSI_ARGS_((CONST char * format,
+ va_list argList));
+/* 279 */
+EXTERN void Tcl_GetVersion _ANSI_ARGS_((int * major, int * minor,
+ int * patchLevel, int * type));
+/* 280 */
+EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp * interp));
+/* 281 */
+EXTERN Tcl_Channel Tcl_StackChannel _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_ChannelType * typePtr,
+ ClientData instanceData, int mask,
+ Tcl_Channel prevChan));
+/* 282 */
+EXTERN int Tcl_UnstackChannel _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel chan));
+/* 283 */
+EXTERN Tcl_Channel Tcl_GetStackedChannel _ANSI_ARGS_((Tcl_Channel chan));
+/* 284 */
+EXTERN void Tcl_SetMainLoop _ANSI_ARGS_((Tcl_MainLoopProc * proc));
+/* Slot 285 is reserved */
+/* 286 */
+EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ Tcl_Obj * appendObjPtr));
+/* 287 */
+EXTERN Tcl_Encoding Tcl_CreateEncoding _ANSI_ARGS_((
+ Tcl_EncodingType * typePtr));
+/* 288 */
+EXTERN void Tcl_CreateThreadExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+/* 289 */
+EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+/* 290 */
+EXTERN void Tcl_DiscardResult _ANSI_ARGS_((
+ Tcl_SavedResult * statePtr));
+/* 291 */
+EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * script, int numBytes, int flags));
+/* 292 */
+EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[], int flags));
+/* 293 */
+EXTERN int Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int flags));
+/* 294 */
+EXTERN void Tcl_ExitThread _ANSI_ARGS_((int status));
+/* 295 */
+EXTERN int Tcl_ExternalToUtf _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, int flags,
+ Tcl_EncodingState * statePtr, char * dst,
+ int dstLen, int * srcReadPtr,
+ int * dstWrotePtr, int * dstCharsPtr));
+/* 296 */
+EXTERN char * Tcl_ExternalToUtfDString _ANSI_ARGS_((
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, Tcl_DString * dsPtr));
+/* 297 */
+EXTERN void Tcl_FinalizeThread _ANSI_ARGS_((void));
+/* 298 */
+EXTERN void Tcl_FinalizeNotifier _ANSI_ARGS_((
+ ClientData clientData));
+/* 299 */
+EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
+/* 300 */
+EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void));
+/* 301 */
+EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name));
+/* 302 */
+EXTERN CONST84_RETURN char * Tcl_GetEncodingName _ANSI_ARGS_((
+ Tcl_Encoding encoding));
+/* 303 */
+EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 304 */
+EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ CONST VOID * tablePtr, int offset,
+ CONST char * msg, int flags, int * indexPtr));
+/* 305 */
+EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_((
+ Tcl_ThreadDataKey * keyPtr, int size));
+/* 306 */
+EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags));
+/* 307 */
+EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void));
+/* 308 */
+EXTERN void Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
+/* 309 */
+EXTERN void Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
+/* 310 */
+EXTERN void Tcl_ConditionNotify _ANSI_ARGS_((
+ Tcl_Condition * condPtr));
+/* 311 */
+EXTERN void Tcl_ConditionWait _ANSI_ARGS_((
+ Tcl_Condition * condPtr,
+ Tcl_Mutex * mutexPtr, Tcl_Time * timePtr));
+/* 312 */
+EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src,
+ int len));
+/* 313 */
+EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel,
+ Tcl_Obj * objPtr, int charsToRead,
+ int appendFlag));
+/* 314 */
+EXTERN void Tcl_RestoreResult _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_SavedResult * statePtr));
+/* 315 */
+EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_SavedResult * statePtr));
+/* 316 */
+EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name));
+/* 317 */
+EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ Tcl_Obj * newValuePtr, int flags));
+/* 318 */
+EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId));
+/* 319 */
+EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_((
+ Tcl_ThreadId threadId, Tcl_Event* evPtr,
+ Tcl_QueuePosition position));
+/* 320 */
+EXTERN Tcl_UniChar Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char * src,
+ int index));
+/* 321 */
+EXTERN Tcl_UniChar Tcl_UniCharToLower _ANSI_ARGS_((int ch));
+/* 322 */
+EXTERN Tcl_UniChar Tcl_UniCharToTitle _ANSI_ARGS_((int ch));
+/* 323 */
+EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch));
+/* 324 */
+EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf));
+/* 325 */
+EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src,
+ int index));
+/* 326 */
+EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src,
+ int len));
+/* 327 */
+EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src,
+ int * readPtr, char * dst));
+/* 328 */
+EXTERN CONST84_RETURN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src,
+ int ch));
+/* 329 */
+EXTERN CONST84_RETURN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src,
+ int ch));
+/* 330 */
+EXTERN CONST84_RETURN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src));
+/* 331 */
+EXTERN CONST84_RETURN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src,
+ CONST char * start));
+/* 332 */
+EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, int flags,
+ Tcl_EncodingState * statePtr, char * dst,
+ int dstLen, int * srcReadPtr,
+ int * dstWrotePtr, int * dstCharsPtr));
+/* 333 */
+EXTERN char * Tcl_UtfToExternalDString _ANSI_ARGS_((
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, Tcl_DString * dsPtr));
+/* 334 */
+EXTERN int Tcl_UtfToLower _ANSI_ARGS_((char * src));
+/* 335 */
+EXTERN int Tcl_UtfToTitle _ANSI_ARGS_((char * src));
+/* 336 */
+EXTERN int Tcl_UtfToUniChar _ANSI_ARGS_((CONST char * src,
+ Tcl_UniChar * chPtr));
+/* 337 */
+EXTERN int Tcl_UtfToUpper _ANSI_ARGS_((char * src));
+/* 338 */
+EXTERN int Tcl_WriteChars _ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * src, int srcLen));
+/* 339 */
+EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_Obj * objPtr));
+/* 340 */
+EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 341 */
+EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
+/* 342 */
+EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((
+ CONST char * path));
+/* 343 */
+EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
+/* 344 */
+EXTERN void Tcl_ServiceModeHook _ANSI_ARGS_((int mode));
+/* 345 */
+EXTERN int Tcl_UniCharIsAlnum _ANSI_ARGS_((int ch));
+/* 346 */
+EXTERN int Tcl_UniCharIsAlpha _ANSI_ARGS_((int ch));
+/* 347 */
+EXTERN int Tcl_UniCharIsDigit _ANSI_ARGS_((int ch));
+/* 348 */
+EXTERN int Tcl_UniCharIsLower _ANSI_ARGS_((int ch));
+/* 349 */
+EXTERN int Tcl_UniCharIsSpace _ANSI_ARGS_((int ch));
+/* 350 */
+EXTERN int Tcl_UniCharIsUpper _ANSI_ARGS_((int ch));
+/* 351 */
+EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch));
+/* 352 */
+EXTERN int Tcl_UniCharLen _ANSI_ARGS_((CONST Tcl_UniChar * str));
+/* 353 */
+EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * cs,
+ CONST Tcl_UniChar * ct, unsigned long n));
+/* 354 */
+EXTERN char * Tcl_UniCharToUtfDString _ANSI_ARGS_((
+ CONST Tcl_UniChar * string, int numChars,
+ Tcl_DString * dsPtr));
+/* 355 */
+EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString _ANSI_ARGS_((
+ CONST char * string, int length,
+ Tcl_DString * dsPtr));
+/* 356 */
+EXTERN Tcl_RegExp Tcl_GetRegExpFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * patObj,
+ int flags));
+/* 357 */
+EXTERN Tcl_Obj * Tcl_EvalTokens _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Token * tokenPtr, int count));
+/* 358 */
+EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr));
+/* 359 */
+EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * script, CONST char * command,
+ int length));
+/* 360 */
+EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string, int numBytes,
+ Tcl_Parse * parsePtr, int append,
+ CONST84 char ** termPtr));
+/* 361 */
+EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string, int numBytes,
+ int nested, Tcl_Parse * parsePtr));
+/* 362 */
+EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string, int numBytes,
+ Tcl_Parse * parsePtr));
+/* 363 */
+EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * string,
+ int numBytes, Tcl_Parse * parsePtr,
+ int append, CONST84 char ** termPtr));
+/* 364 */
+EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string, int numBytes,
+ Tcl_Parse * parsePtr, int append));
+/* 365 */
+EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_DString * cwdPtr));
+/* 366 */
+EXTERN int Tcl_Chdir _ANSI_ARGS_((CONST char * dirName));
+/* 367 */
+EXTERN int Tcl_Access _ANSI_ARGS_((CONST char * path, int mode));
+/* 368 */
+EXTERN int Tcl_Stat _ANSI_ARGS_((CONST char * path,
+ struct stat * bufPtr));
+/* 369 */
+EXTERN int Tcl_UtfNcmp _ANSI_ARGS_((CONST char * s1,
+ CONST char * s2, unsigned long n));
+/* 370 */
+EXTERN int Tcl_UtfNcasecmp _ANSI_ARGS_((CONST char * s1,
+ CONST char * s2, unsigned long n));
+/* 371 */
+EXTERN int Tcl_StringCaseMatch _ANSI_ARGS_((CONST char * str,
+ CONST char * pattern, int nocase));
+/* 372 */
+EXTERN int Tcl_UniCharIsControl _ANSI_ARGS_((int ch));
+/* 373 */
+EXTERN int Tcl_UniCharIsGraph _ANSI_ARGS_((int ch));
+/* 374 */
+EXTERN int Tcl_UniCharIsPrint _ANSI_ARGS_((int ch));
+/* 375 */
+EXTERN int Tcl_UniCharIsPunct _ANSI_ARGS_((int ch));
+/* 376 */
+EXTERN int Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_RegExp regexp, Tcl_Obj * objPtr,
+ int offset, int nmatches, int flags));
+/* 377 */
+EXTERN void Tcl_RegExpGetInfo _ANSI_ARGS_((Tcl_RegExp regexp,
+ Tcl_RegExpInfo * infoPtr));
+/* 378 */
+EXTERN Tcl_Obj * Tcl_NewUnicodeObj _ANSI_ARGS_((
+ CONST Tcl_UniChar * unicode, int numChars));
+/* 379 */
+EXTERN void Tcl_SetUnicodeObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ CONST Tcl_UniChar * unicode, int numChars));
+/* 380 */
+EXTERN int Tcl_GetCharLength _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 381 */
+EXTERN Tcl_UniChar Tcl_GetUniChar _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int index));
+/* 382 */
+EXTERN Tcl_UniChar * Tcl_GetUnicode _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 383 */
+EXTERN Tcl_Obj * Tcl_GetRange _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int first, int last));
+/* 384 */
+EXTERN void Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ CONST Tcl_UniChar * unicode, int length));
+/* 385 */
+EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * stringObj, Tcl_Obj * patternObj));
+/* 386 */
+EXTERN void Tcl_SetNotifier _ANSI_ARGS_((
+ Tcl_NotifierProcs * notifierProcPtr));
+/* 387 */
+EXTERN Tcl_Mutex * Tcl_GetAllocMutex _ANSI_ARGS_((void));
+/* 388 */
+EXTERN int Tcl_GetChannelNames _ANSI_ARGS_((Tcl_Interp * interp));
+/* 389 */
+EXTERN int Tcl_GetChannelNamesEx _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * pattern));
+/* 390 */
+EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, int objc,
+ Tcl_Obj *CONST objv[]));
+/* 391 */
+EXTERN void Tcl_ConditionFinalize _ANSI_ARGS_((
+ Tcl_Condition * condPtr));
+/* 392 */
+EXTERN void Tcl_MutexFinalize _ANSI_ARGS_((Tcl_Mutex * mutex));
+/* 393 */
+EXTERN int Tcl_CreateThread _ANSI_ARGS_((Tcl_ThreadId * idPtr,
+ Tcl_ThreadCreateProc proc,
+ ClientData clientData, int stackSize,
+ int flags));
+/* 394 */
+EXTERN int Tcl_ReadRaw _ANSI_ARGS_((Tcl_Channel chan,
+ char * dst, int bytesToRead));
+/* 395 */
+EXTERN int Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * src, int srcLen));
+/* 396 */
+EXTERN Tcl_Channel Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan));
+/* 397 */
+EXTERN int Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan));
+/* 398 */
+EXTERN CONST84_RETURN char * Tcl_ChannelName _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 399 */
+EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 400 */
+EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 401 */
+EXTERN Tcl_DriverCloseProc * Tcl_ChannelCloseProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 402 */
+EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 403 */
+EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 404 */
+EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 405 */
+EXTERN Tcl_DriverSeekProc * Tcl_ChannelSeekProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 406 */
+EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 407 */
+EXTERN Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 408 */
+EXTERN Tcl_DriverWatchProc * Tcl_ChannelWatchProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 409 */
+EXTERN Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 410 */
+EXTERN Tcl_DriverFlushProc * Tcl_ChannelFlushProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 411 */
+EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+/* 412 */
+EXTERN int Tcl_JoinThread _ANSI_ARGS_((Tcl_ThreadId threadId,
+ int* result));
+/* 413 */
+EXTERN int Tcl_IsChannelShared _ANSI_ARGS_((Tcl_Channel channel));
+/* 414 */
+EXTERN int Tcl_IsChannelRegistered _ANSI_ARGS_((
+ Tcl_Interp* interp, Tcl_Channel channel));
+/* 415 */
+EXTERN void Tcl_CutChannel _ANSI_ARGS_((Tcl_Channel channel));
+/* 416 */
+EXTERN void Tcl_SpliceChannel _ANSI_ARGS_((Tcl_Channel channel));
+/* 417 */
+EXTERN void Tcl_ClearChannelHandlers _ANSI_ARGS_((
+ Tcl_Channel channel));
+/* 418 */
+EXTERN int Tcl_IsChannelExisting _ANSI_ARGS_((
+ CONST char* channelName));
+/* 419 */
+EXTERN int Tcl_UniCharNcasecmp _ANSI_ARGS_((
+ CONST Tcl_UniChar * cs,
+ CONST Tcl_UniChar * ct, unsigned long n));
+/* 420 */
+EXTERN int Tcl_UniCharCaseMatch _ANSI_ARGS_((
+ CONST Tcl_UniChar * ustr,
+ CONST Tcl_UniChar * pattern, int nocase));
+/* 421 */
+EXTERN Tcl_HashEntry * Tcl_FindHashEntry _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, CONST char * key));
+/* 422 */
+EXTERN Tcl_HashEntry * Tcl_CreateHashEntry _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, CONST char * key,
+ int * newPtr));
+/* 423 */
+EXTERN void Tcl_InitCustomHashTable _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, int keyType,
+ Tcl_HashKeyType * typePtr));
+/* 424 */
+EXTERN void Tcl_InitObjHashTable _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr));
+/* 425 */
+EXTERN ClientData Tcl_CommandTraceInfo _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * varName,
+ int flags, Tcl_CommandTraceProc * procPtr,
+ ClientData prevClientData));
+/* 426 */
+EXTERN int Tcl_TraceCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags,
+ Tcl_CommandTraceProc * proc,
+ ClientData clientData));
+/* 427 */
+EXTERN void Tcl_UntraceCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags,
+ Tcl_CommandTraceProc * proc,
+ ClientData clientData));
+/* 428 */
+EXTERN char * Tcl_AttemptAlloc _ANSI_ARGS_((unsigned int size));
+/* 429 */
+EXTERN char * Tcl_AttemptDbCkalloc _ANSI_ARGS_((unsigned int size,
+ CONST char * file, int line));
+/* 430 */
+EXTERN char * Tcl_AttemptRealloc _ANSI_ARGS_((char * ptr,
+ unsigned int size));
+/* 431 */
+EXTERN char * Tcl_AttemptDbCkrealloc _ANSI_ARGS_((char * ptr,
+ unsigned int size, CONST char * file,
+ int line));
+/* 432 */
+EXTERN int Tcl_AttemptSetObjLength _ANSI_ARGS_((
+ Tcl_Obj * objPtr, int length));
+/* 433 */
+EXTERN Tcl_ThreadId Tcl_GetChannelThread _ANSI_ARGS_((
+ Tcl_Channel channel));
+/* 434 */
+EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int * lengthPtr));
+/* 435 */
+EXTERN int Tcl_GetMathFuncInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, int * numArgsPtr,
+ Tcl_ValueType ** argTypesPtr,
+ Tcl_MathProc ** procPtr,
+ ClientData * clientDataPtr));
+/* 436 */
+EXTERN Tcl_Obj * Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * pattern));
+/* 437 */
+EXTERN Tcl_Obj * Tcl_SubstObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int flags));
+/* 438 */
+EXTERN int Tcl_DetachChannel _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Channel channel));
+/* 439 */
+EXTERN int Tcl_IsStandardChannel _ANSI_ARGS_((
+ Tcl_Channel channel));
+/* 440 */
+EXTERN int Tcl_FSCopyFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr,
+ Tcl_Obj * destPathPtr));
+/* 441 */
+EXTERN int Tcl_FSCopyDirectory _ANSI_ARGS_((
+ Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr,
+ Tcl_Obj ** errorPtr));
+/* 442 */
+EXTERN int Tcl_FSCreateDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 443 */
+EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 444 */
+EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * pathPtr, CONST char * sym1,
+ CONST char * sym2,
+ Tcl_PackageInitProc ** proc1Ptr,
+ Tcl_PackageInitProc ** proc2Ptr,
+ Tcl_LoadHandle * handlePtr,
+ Tcl_FSUnloadFileProc ** unloadProcPtr));
+/* 445 */
+EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * result,
+ Tcl_Obj * pathPtr, CONST char * pattern,
+ Tcl_GlobTypeData * types));
+/* 446 */
+EXTERN Tcl_Obj * Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_Obj * toPtr, int linkAction));
+/* 447 */
+EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ int recursive, Tcl_Obj ** errorPtr));
+/* 448 */
+EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr,
+ Tcl_Obj * destPathPtr));
+/* 449 */
+EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_StatBuf * buf));
+/* 450 */
+EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ struct utimbuf * tval));
+/* 451 */
+EXTERN int Tcl_FSFileAttrsGet _ANSI_ARGS_((Tcl_Interp * interp,
+ int index, Tcl_Obj * pathPtr,
+ Tcl_Obj ** objPtrRef));
+/* 452 */
+EXTERN int Tcl_FSFileAttrsSet _ANSI_ARGS_((Tcl_Interp * interp,
+ int index, Tcl_Obj * pathPtr,
+ Tcl_Obj * objPtr));
+/* 453 */
+EXTERN CONST char ** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_Obj ** objPtrRef));
+/* 454 */
+EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_StatBuf * buf));
+/* 455 */
+EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ int mode));
+/* 456 */
+EXTERN Tcl_Channel Tcl_FSOpenFileChannel _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * pathPtr,
+ CONST char * modeString, int permissions));
+/* 457 */
+EXTERN Tcl_Obj* Tcl_FSGetCwd _ANSI_ARGS_((Tcl_Interp * interp));
+/* 458 */
+EXTERN int Tcl_FSChdir _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 459 */
+EXTERN int Tcl_FSConvertToPathType _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * pathPtr));
+/* 460 */
+EXTERN Tcl_Obj* Tcl_FSJoinPath _ANSI_ARGS_((Tcl_Obj * listObj,
+ int elements));
+/* 461 */
+EXTERN Tcl_Obj* Tcl_FSSplitPath _ANSI_ARGS_((Tcl_Obj* pathPtr,
+ int * lenPtr));
+/* 462 */
+EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj* firstPtr,
+ Tcl_Obj* secondPtr));
+/* 463 */
+EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathObjPtr));
+/* 464 */
+EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 465 */
+EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr));
+/* 466 */
+EXTERN Tcl_Obj* Tcl_FSGetTranslatedPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathPtr));
+/* 467 */
+EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * fileName));
+/* 468 */
+EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_((
+ Tcl_Filesystem* fromFilesystem,
+ ClientData clientData));
+/* 469 */
+EXTERN CONST char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+/* 470 */
+EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr));
+/* 471 */
+EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+/* 472 */
+EXTERN Tcl_Obj* Tcl_FSListVolumes _ANSI_ARGS_((void));
+/* 473 */
+EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData,
+ Tcl_Filesystem * fsPtr));
+/* 474 */
+EXTERN int Tcl_FSUnregister _ANSI_ARGS_((Tcl_Filesystem * fsPtr));
+/* 475 */
+EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr));
+/* 476 */
+EXTERN CONST char* Tcl_FSGetTranslatedStringPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathPtr));
+/* 477 */
+EXTERN Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr));
+/* 478 */
+EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathObjPtr));
+/* 479 */
+EXTERN int Tcl_OutputBuffered _ANSI_ARGS_((Tcl_Channel chan));
+/* 480 */
+EXTERN void Tcl_FSMountsChanged _ANSI_ARGS_((
+ Tcl_Filesystem * fsPtr));
+/* 481 */
+EXTERN int Tcl_EvalTokensStandard _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Token * tokenPtr,
+ int count));
+/* 482 */
+EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time* timeBuf));
+/* 483 */
+EXTERN Tcl_Trace Tcl_CreateObjTrace _ANSI_ARGS_((Tcl_Interp* interp,
+ int level, int flags,
+ Tcl_CmdObjTraceProc* objProc,
+ ClientData clientData,
+ Tcl_CmdObjTraceDeleteProc* delProc));
+/* 484 */
+EXTERN int Tcl_GetCommandInfoFromToken _ANSI_ARGS_((
+ Tcl_Command token, Tcl_CmdInfo* infoPtr));
+/* 485 */
+EXTERN int Tcl_SetCommandInfoFromToken _ANSI_ARGS_((
+ Tcl_Command token,
+ CONST Tcl_CmdInfo* infoPtr));
+/* 486 */
+EXTERN Tcl_Obj * Tcl_DbNewWideIntObj _ANSI_ARGS_((
+ Tcl_WideInt wideValue, CONST char * file,
+ int line));
+/* 487 */
+EXTERN int Tcl_GetWideIntFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ Tcl_WideInt * widePtr));
+/* 488 */
+EXTERN Tcl_Obj * Tcl_NewWideIntObj _ANSI_ARGS_((Tcl_WideInt wideValue));
+/* 489 */
+EXTERN void Tcl_SetWideIntObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ Tcl_WideInt wideValue));
+/* 490 */
+EXTERN Tcl_StatBuf * Tcl_AllocStatBuf _ANSI_ARGS_((void));
+/* 491 */
+EXTERN Tcl_WideInt Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_WideInt offset, int mode));
+/* 492 */
+EXTERN Tcl_WideInt Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
+/* 493 */
+EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
+
+typedef struct TclStubHooks {
+ struct TclPlatStubs *tclPlatStubs;
+ struct TclIntStubs *tclIntStubs;
+ struct TclIntPlatStubs *tclIntPlatStubs;
+} TclStubHooks;
+
+typedef struct TclStubs {
+ int magic;
+ struct TclStubHooks *hooks;
+
+ int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
+ CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
+ void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
+ char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
+ void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
+ char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
+ char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
+ int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
+ char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); /* 9 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ void *reserved9;
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved9;
+#endif /* MAC_TCL */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void (*tcl_DeleteFileHandler) _ANSI_ARGS_((int fd)); /* 10 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ void *reserved10;
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved10;
+#endif /* MAC_TCL */
+ void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */
+ void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
+ int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
+ int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
+ void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */
+ void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
+ Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
+ int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
+ void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
+ void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
+ int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
+ Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
+ Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((CONST unsigned char * bytes, int length, CONST char * file, int line)); /* 23 */
+ Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, CONST char * file, int line)); /* 24 */
+ Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST * objv, CONST char * file, int line)); /* 25 */
+ Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char * file, int line)); /* 26 */
+ Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char * file, int line)); /* 27 */
+ Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, CONST char * file, int line)); /* 28 */
+ Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */
+ void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */
+ int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * boolPtr)); /* 31 */
+ int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */
+ unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */
+ int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * doublePtr)); /* 34 */
+ int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */
+ int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); /* 36 */
+ int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * intPtr)); /* 37 */
+ int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */
+ int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */
+ Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char * typeName)); /* 40 */
+ char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 41 */
+ void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 42 */
+ int (*tcl_ListObjAppendList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr)); /* 43 */
+ int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr)); /* 44 */
+ int (*tcl_ListObjGetElements) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * objcPtr, Tcl_Obj *** objvPtr)); /* 45 */
+ int (*tcl_ListObjIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj ** objPtrPtr)); /* 46 */
+ int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * lengthPtr)); /* 47 */
+ int (*tcl_ListObjReplace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[])); /* 48 */
+ Tcl_Obj * (*tcl_NewBooleanObj) _ANSI_ARGS_((int boolValue)); /* 49 */
+ Tcl_Obj * (*tcl_NewByteArrayObj) _ANSI_ARGS_((CONST unsigned char* bytes, int length)); /* 50 */
+ Tcl_Obj * (*tcl_NewDoubleObj) _ANSI_ARGS_((double doubleValue)); /* 51 */
+ Tcl_Obj * (*tcl_NewIntObj) _ANSI_ARGS_((int intValue)); /* 52 */
+ Tcl_Obj * (*tcl_NewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 53 */
+ Tcl_Obj * (*tcl_NewLongObj) _ANSI_ARGS_((long longValue)); /* 54 */
+ Tcl_Obj * (*tcl_NewObj) _ANSI_ARGS_((void)); /* 55 */
+ Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((CONST char * bytes, int length)); /* 56 */
+ void (*tcl_SetBooleanObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int boolValue)); /* 57 */
+ unsigned char * (*tcl_SetByteArrayLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 58 */
+ void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST unsigned char * bytes, int length)); /* 59 */
+ void (*tcl_SetDoubleObj) _ANSI_ARGS_((Tcl_Obj * objPtr, double doubleValue)); /* 60 */
+ void (*tcl_SetIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int intValue)); /* 61 */
+ void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */
+ void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
+ void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
+ void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
+ void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
+ void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
+ void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
+ void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 69 */
+ void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */
+ Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
+ void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
+ int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */
+ void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
+ int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
+ void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
+ char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
+ int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * optionName, CONST char * optionList)); /* 78 */
+ void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 79 */
+ void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc * idleProc, ClientData clientData)); /* 80 */
+ int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 81 */
+ int (*tcl_CommandComplete) _ANSI_ARGS_((CONST char * cmd)); /* 82 */
+ char * (*tcl_Concat) _ANSI_ARGS_((int argc, CONST84 char * CONST * objv)); /* 83 */
+ int (*tcl_ConvertElement) _ANSI_ARGS_((CONST char * src, char * dst, int flags)); /* 84 */
+ int (*tcl_ConvertCountedElement) _ANSI_ARGS_((CONST char * src, int length, char * dst, int flags)); /* 85 */
+ int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int argc, CONST84 char * CONST * objv)); /* 86 */
+ int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */
+ Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, CONST char * chanName, ClientData instanceData, int mask)); /* 88 */
+ void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc * proc, ClientData clientData)); /* 89 */
+ void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 90 */
+ Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
+ void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 92 */
+ void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 93 */
+ Tcl_Interp * (*tcl_CreateInterp) _ANSI_ARGS_((void)); /* 94 */
+ void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 95 */
+ Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 96 */
+ Tcl_Interp * (*tcl_CreateSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName, int isSafe)); /* 97 */
+ Tcl_TimerToken (*tcl_CreateTimerHandler) _ANSI_ARGS_((int milliseconds, Tcl_TimerProc * proc, ClientData clientData)); /* 98 */
+ Tcl_Trace (*tcl_CreateTrace) _ANSI_ARGS_((Tcl_Interp * interp, int level, Tcl_CmdTraceProc * proc, ClientData clientData)); /* 99 */
+ void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 100 */
+ void (*tcl_DeleteChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_ChannelProc * proc, ClientData clientData)); /* 101 */
+ void (*tcl_DeleteCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 102 */
+ int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName)); /* 103 */
+ int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */
+ void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */
+ void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */
+ void (*tcl_DeleteExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 107 */
+ void (*tcl_DeleteHashEntry) _ANSI_ARGS_((Tcl_HashEntry * entryPtr)); /* 108 */
+ void (*tcl_DeleteHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 109 */
+ void (*tcl_DeleteInterp) _ANSI_ARGS_((Tcl_Interp * interp)); /* 110 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved111;
+#endif /* MAC_TCL */
+ void (*tcl_DeleteTimerHandler) _ANSI_ARGS_((Tcl_TimerToken token)); /* 112 */
+ void (*tcl_DeleteTrace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Trace trace)); /* 113 */
+ void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */
+ int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */
+ void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */
+ char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * str, int length)); /* 117 */
+ char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string)); /* 118 */
+ void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */
+ void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */
+ void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 121 */
+ void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 122 */
+ void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 123 */
+ void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */
+ void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */
+ int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
+ CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
+ CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
+ int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 129 */
+ int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */
+ int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
+ void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
+ void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
+ int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
+ int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */
+ int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
+ int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */
+ int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
+ int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */
+ int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
+ int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
+ int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */
+ void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
+ void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
+ Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
+ int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
+ void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
+ int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 148 */
+ int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
+ ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
+ Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanName, int * modePtr)); /* 151 */
+ int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */
+ int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData * handlePtr)); /* 153 */
+ ClientData (*tcl_GetChannelInstanceData) _ANSI_ARGS_((Tcl_Channel chan)); /* 154 */
+ int (*tcl_GetChannelMode) _ANSI_ARGS_((Tcl_Channel chan)); /* 155 */
+ CONST84_RETURN char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
+ int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, Tcl_DString * dsPtr)); /* 157 */
+ Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */
+ int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
+ CONST84_RETURN char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
+ int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
+ CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
+ int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
+ Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */
+ CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
+ Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ void *reserved167;
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved167;
+#endif /* MAC_TCL */
+ Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */
+ int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */
+ int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */
+ int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */
+ Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 172 */
+ Tcl_Channel (*tcl_GetStdChannel) _ANSI_ARGS_((int type)); /* 173 */
+ CONST84_RETURN char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */
+ CONST84_RETURN char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 175 */
+ CONST84_RETURN char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 176 */
+ int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command)); /* 177 */
+ int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 178 */
+ int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); /* 179 */
+ int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 180 */
+ void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType)); /* 181 */
+ int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */
+ int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */
+ int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */
+ int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */
+ char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST84 char * CONST * objv, Tcl_DString * resultPtr)); /* 186 */
+ int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, char * addr, int type)); /* 187 */
+ void *reserved188;
+ Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */
+ int (*tcl_MakeSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 190 */
+ Tcl_Channel (*tcl_MakeTcpClientChannel) _ANSI_ARGS_((ClientData tcpSocket)); /* 191 */
+ char * (*tcl_Merge) _ANSI_ARGS_((int argc, CONST84 char * CONST * objv)); /* 192 */
+ Tcl_HashEntry * (*tcl_NextHashEntry) _ANSI_ARGS_((Tcl_HashSearch * searchPtr)); /* 193 */
+ void (*tcl_NotifyChannel) _ANSI_ARGS_((Tcl_Channel channel, int mask)); /* 194 */
+ Tcl_Obj * (*tcl_ObjGetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 195 */
+ Tcl_Obj * (*tcl_ObjSetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); /* 196 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 Tcl_Obj *CONST *objv, int flags)); /* 197 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 Tcl_Obj *CONST *objv, int flags)); /* 197 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved197;
+#endif /* MAC_TCL */
+ Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */
+ Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */
+ Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
+ void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
+ void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */
+ int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */
+ CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
+ void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */
+ int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved207;
+#endif /* MAC_TCL */
+ int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmd, int flags)); /* 208 */
+ int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags)); /* 209 */
+ void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */
+ void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */
+ Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 212 */
+ int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */
+ int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST char * pattern)); /* 214 */
+ void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); /* 215 */
+ void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */
+ void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */
+ int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */
+ int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */
+ int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
+ int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
+ int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
+ void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
+ void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
+ int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
+ int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
+ void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
+ void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */
+ void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
+ void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
+ int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
+ void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */
+ int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
+ void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
+ void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
+ void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
+ CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */
+ CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */
+ CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
+ CONST84_RETURN char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
+ void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */
+ int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, CONST84 char *** argvPtr)); /* 242 */
+ void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */
+ void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */
+ int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */
+ int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
+ int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */
+ int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */
+ char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 249 */
+ int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, CONST char * str, int len, int atHead)); /* 250 */
+ void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 251 */
+ int (*tcl_UnregisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 252 */
+ int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
+ int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
+ void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
+ void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
+ void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
+ int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
+ int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
+ int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
+ ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
+ ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
+ int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
+ void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
+ int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
+ void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
+ void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
+ void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */
+ CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
+ CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 270 */
+ CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */
+ CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */
+ int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */
+ CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */
+ void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
+ int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
+ Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */
+ void (*tcl_PanicVA) _ANSI_ARGS_((CONST char * format, va_list argList)); /* 278 */
+ void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */
+ void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */
+ Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
+ int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */
+ Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
+ void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */
+ void *reserved285;
+ void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
+ Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
+ void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */
+ void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */
+ void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */
+ int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, int numBytes, int flags)); /* 291 */
+ int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */
+ int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */
+ void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */
+ int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 295 */
+ char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 296 */
+ void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */
+ void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */
+ void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */
+ Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */
+ Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */
+ CONST84_RETURN char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
+ void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */
+ int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST VOID * tablePtr, int offset, CONST char * msg, int flags, int * indexPtr)); /* 304 */
+ VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
+ Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 306 */
+ ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
+ void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
+ void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
+ void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */
+ void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */
+ int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */
+ int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */
+ void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
+ void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
+ int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
+ Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
+ void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
+ void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */
+ Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */
+ Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */
+ Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
+ Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
+ int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */
+ CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
+ int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */
+ int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
+ CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
+ CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
+ CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
+ CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
+ int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
+ char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */
+ int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */
+ int (*tcl_UtfToTitle) _ANSI_ARGS_((char * src)); /* 335 */
+ int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char * src, Tcl_UniChar * chPtr)); /* 336 */
+ int (*tcl_UtfToUpper) _ANSI_ARGS_((char * src)); /* 337 */
+ int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */
+ int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */
+ char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */
+ CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
+ void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((CONST char * path)); /* 342 */
+ void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
+ void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
+ int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
+ int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
+ int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
+ int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
+ int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
+ int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
+ int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
+ int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */
+ int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */
+ char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
+ Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
+ Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
+ Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
+ void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
+ void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */
+ int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */
+ int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
+ int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
+ int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */
+ int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
+ char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
+ int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
+ int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */
+ int (*tcl_Stat) _ANSI_ARGS_((CONST char * path, struct stat * bufPtr)); /* 368 */
+ int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 369 */
+ int (*tcl_UtfNcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 370 */
+ int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern, int nocase)); /* 371 */
+ int (*tcl_UniCharIsControl) _ANSI_ARGS_((int ch)); /* 372 */
+ int (*tcl_UniCharIsGraph) _ANSI_ARGS_((int ch)); /* 373 */
+ int (*tcl_UniCharIsPrint) _ANSI_ARGS_((int ch)); /* 374 */
+ int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */
+ int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * objPtr, int offset, int nmatches, int flags)); /* 376 */
+ void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 377 */
+ Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar * unicode, int numChars)); /* 378 */
+ void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int numChars)); /* 379 */
+ int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 380 */
+ Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj * objPtr, int index)); /* 381 */
+ Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 382 */
+ Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 383 */
+ void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); /* 384 */
+ int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * stringObj, Tcl_Obj * patternObj)); /* 385 */
+ void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */
+ Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */
+ int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */
+ int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 389 */
+ int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */
+ void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
+ void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */
+ int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId * idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */
+ int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 394 */
+ int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 395 */
+ Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */
+ int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */
+ CONST84_RETURN char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */
+ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 399 */
+ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 400 */
+ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 401 */
+ Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 402 */
+ Tcl_DriverInputProc * (*tcl_ChannelInputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 403 */
+ Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 404 */
+ Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 405 */
+ Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 406 */
+ Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 407 */
+ Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 408 */
+ Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 409 */
+ Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 410 */
+ Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 411 */
+ int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId threadId, int* result)); /* 412 */
+ int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */
+ int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */
+ void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */
+ void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */
+ void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */
+ int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */
+ int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 419 */
+ int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * ustr, CONST Tcl_UniChar * pattern, int nocase)); /* 420 */
+ Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key)); /* 421 */
+ Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 422 */
+ void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 423 */
+ void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 424 */
+ ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 425 */
+ int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 426 */
+ void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 427 */
+ char * (*tcl_AttemptAlloc) _ANSI_ARGS_((unsigned int size)); /* 428 */
+ char * (*tcl_AttemptDbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 429 */
+ char * (*tcl_AttemptRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 430 */
+ char * (*tcl_AttemptDbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 431 */
+ int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 432 */
+ Tcl_ThreadId (*tcl_GetChannelThread) _ANSI_ARGS_((Tcl_Channel channel)); /* 433 */
+ Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 434 */
+ int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * numArgsPtr, Tcl_ValueType ** argTypesPtr, Tcl_MathProc ** procPtr, ClientData * clientDataPtr)); /* 435 */
+ Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 436 */
+ Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
+ int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */
+ int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
+ int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */
+ int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */
+ int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */
+ int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */
+ int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, Tcl_LoadHandle * handlePtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */
+ int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */
+ Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr, int linkAction)); /* 446 */
+ int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */
+ int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */
+ int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */
+ int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */
+ int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */
+ int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */
+ CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */
+ int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 454 */
+ int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 455 */
+ Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * modeString, int permissions)); /* 456 */
+ Tcl_Obj* (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 457 */
+ int (*tcl_FSChdir) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 458 */
+ int (*tcl_FSConvertToPathType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr)); /* 459 */
+ Tcl_Obj* (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj * listObj, int elements)); /* 460 */
+ Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
+ int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
+ Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
+ Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
+ ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
+ Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
+ int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
+ Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Filesystem* fromFilesystem, ClientData clientData)); /* 468 */
+ CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */
+ Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */
+ Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */
+ Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */
+ int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */
+ int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
+ ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */
+ CONST char* (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 476 */
+ Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 477 */
+ Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */
+ int (*tcl_OutputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 479 */
+ void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */
+ int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */
+ void (*tcl_GetTime) _ANSI_ARGS_((Tcl_Time* timeBuf)); /* 482 */
+ Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp* interp, int level, int flags, Tcl_CmdObjTraceProc* objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc* delProc)); /* 483 */
+ int (*tcl_GetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, Tcl_CmdInfo* infoPtr)); /* 484 */
+ int (*tcl_SetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, CONST Tcl_CmdInfo* infoPtr)); /* 485 */
+ Tcl_Obj * (*tcl_DbNewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue, CONST char * file, int line)); /* 486 */
+ int (*tcl_GetWideIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_WideInt * widePtr)); /* 487 */
+ Tcl_Obj * (*tcl_NewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue)); /* 488 */
+ void (*tcl_SetWideIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_WideInt wideValue)); /* 489 */
+ Tcl_StatBuf * (*tcl_AllocStatBuf) _ANSI_ARGS_((void)); /* 490 */
+ Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */
+ Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */
+ Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 493 */
+} TclStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TclStubs *tclStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifndef Tcl_PkgProvideEx
+#define Tcl_PkgProvideEx \
+ (tclStubsPtr->tcl_PkgProvideEx) /* 0 */
+#endif
+#ifndef Tcl_PkgRequireEx
+#define Tcl_PkgRequireEx \
+ (tclStubsPtr->tcl_PkgRequireEx) /* 1 */
+#endif
+#ifndef Tcl_Panic
+#define Tcl_Panic \
+ (tclStubsPtr->tcl_Panic) /* 2 */
+#endif
+#ifndef Tcl_Alloc
+#define Tcl_Alloc \
+ (tclStubsPtr->tcl_Alloc) /* 3 */
+#endif
+#ifndef Tcl_Free
+#define Tcl_Free \
+ (tclStubsPtr->tcl_Free) /* 4 */
+#endif
+#ifndef Tcl_Realloc
+#define Tcl_Realloc \
+ (tclStubsPtr->tcl_Realloc) /* 5 */
+#endif
+#ifndef Tcl_DbCkalloc
+#define Tcl_DbCkalloc \
+ (tclStubsPtr->tcl_DbCkalloc) /* 6 */
+#endif
+#ifndef Tcl_DbCkfree
+#define Tcl_DbCkfree \
+ (tclStubsPtr->tcl_DbCkfree) /* 7 */
+#endif
+#ifndef Tcl_DbCkrealloc
+#define Tcl_DbCkrealloc \
+ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */
+#endif
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef Tcl_CreateFileHandler
+#define Tcl_CreateFileHandler \
+ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */
+#endif
+#endif /* UNIX */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef Tcl_DeleteFileHandler
+#define Tcl_DeleteFileHandler \
+ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
+#endif
+#endif /* UNIX */
+#ifndef Tcl_SetTimer
+#define Tcl_SetTimer \
+ (tclStubsPtr->tcl_SetTimer) /* 11 */
+#endif
+#ifndef Tcl_Sleep
+#define Tcl_Sleep \
+ (tclStubsPtr->tcl_Sleep) /* 12 */
+#endif
+#ifndef Tcl_WaitForEvent
+#define Tcl_WaitForEvent \
+ (tclStubsPtr->tcl_WaitForEvent) /* 13 */
+#endif
+#ifndef Tcl_AppendAllObjTypes
+#define Tcl_AppendAllObjTypes \
+ (tclStubsPtr->tcl_AppendAllObjTypes) /* 14 */
+#endif
+#ifndef Tcl_AppendStringsToObj
+#define Tcl_AppendStringsToObj \
+ (tclStubsPtr->tcl_AppendStringsToObj) /* 15 */
+#endif
+#ifndef Tcl_AppendToObj
+#define Tcl_AppendToObj \
+ (tclStubsPtr->tcl_AppendToObj) /* 16 */
+#endif
+#ifndef Tcl_ConcatObj
+#define Tcl_ConcatObj \
+ (tclStubsPtr->tcl_ConcatObj) /* 17 */
+#endif
+#ifndef Tcl_ConvertToType
+#define Tcl_ConvertToType \
+ (tclStubsPtr->tcl_ConvertToType) /* 18 */
+#endif
+#ifndef Tcl_DbDecrRefCount
+#define Tcl_DbDecrRefCount \
+ (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */
+#endif
+#ifndef Tcl_DbIncrRefCount
+#define Tcl_DbIncrRefCount \
+ (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */
+#endif
+#ifndef Tcl_DbIsShared
+#define Tcl_DbIsShared \
+ (tclStubsPtr->tcl_DbIsShared) /* 21 */
+#endif
+#ifndef Tcl_DbNewBooleanObj
+#define Tcl_DbNewBooleanObj \
+ (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */
+#endif
+#ifndef Tcl_DbNewByteArrayObj
+#define Tcl_DbNewByteArrayObj \
+ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */
+#endif
+#ifndef Tcl_DbNewDoubleObj
+#define Tcl_DbNewDoubleObj \
+ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */
+#endif
+#ifndef Tcl_DbNewListObj
+#define Tcl_DbNewListObj \
+ (tclStubsPtr->tcl_DbNewListObj) /* 25 */
+#endif
+#ifndef Tcl_DbNewLongObj
+#define Tcl_DbNewLongObj \
+ (tclStubsPtr->tcl_DbNewLongObj) /* 26 */
+#endif
+#ifndef Tcl_DbNewObj
+#define Tcl_DbNewObj \
+ (tclStubsPtr->tcl_DbNewObj) /* 27 */
+#endif
+#ifndef Tcl_DbNewStringObj
+#define Tcl_DbNewStringObj \
+ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */
+#endif
+#ifndef Tcl_DuplicateObj
+#define Tcl_DuplicateObj \
+ (tclStubsPtr->tcl_DuplicateObj) /* 29 */
+#endif
+#ifndef TclFreeObj
+#define TclFreeObj \
+ (tclStubsPtr->tclFreeObj) /* 30 */
+#endif
+#ifndef Tcl_GetBoolean
+#define Tcl_GetBoolean \
+ (tclStubsPtr->tcl_GetBoolean) /* 31 */
+#endif
+#ifndef Tcl_GetBooleanFromObj
+#define Tcl_GetBooleanFromObj \
+ (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */
+#endif
+#ifndef Tcl_GetByteArrayFromObj
+#define Tcl_GetByteArrayFromObj \
+ (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */
+#endif
+#ifndef Tcl_GetDouble
+#define Tcl_GetDouble \
+ (tclStubsPtr->tcl_GetDouble) /* 34 */
+#endif
+#ifndef Tcl_GetDoubleFromObj
+#define Tcl_GetDoubleFromObj \
+ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */
+#endif
+#ifndef Tcl_GetIndexFromObj
+#define Tcl_GetIndexFromObj \
+ (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */
+#endif
+#ifndef Tcl_GetInt
+#define Tcl_GetInt \
+ (tclStubsPtr->tcl_GetInt) /* 37 */
+#endif
+#ifndef Tcl_GetIntFromObj
+#define Tcl_GetIntFromObj \
+ (tclStubsPtr->tcl_GetIntFromObj) /* 38 */
+#endif
+#ifndef Tcl_GetLongFromObj
+#define Tcl_GetLongFromObj \
+ (tclStubsPtr->tcl_GetLongFromObj) /* 39 */
+#endif
+#ifndef Tcl_GetObjType
+#define Tcl_GetObjType \
+ (tclStubsPtr->tcl_GetObjType) /* 40 */
+#endif
+#ifndef Tcl_GetStringFromObj
+#define Tcl_GetStringFromObj \
+ (tclStubsPtr->tcl_GetStringFromObj) /* 41 */
+#endif
+#ifndef Tcl_InvalidateStringRep
+#define Tcl_InvalidateStringRep \
+ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */
+#endif
+#ifndef Tcl_ListObjAppendList
+#define Tcl_ListObjAppendList \
+ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */
+#endif
+#ifndef Tcl_ListObjAppendElement
+#define Tcl_ListObjAppendElement \
+ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */
+#endif
+#ifndef Tcl_ListObjGetElements
+#define Tcl_ListObjGetElements \
+ (tclStubsPtr->tcl_ListObjGetElements) /* 45 */
+#endif
+#ifndef Tcl_ListObjIndex
+#define Tcl_ListObjIndex \
+ (tclStubsPtr->tcl_ListObjIndex) /* 46 */
+#endif
+#ifndef Tcl_ListObjLength
+#define Tcl_ListObjLength \
+ (tclStubsPtr->tcl_ListObjLength) /* 47 */
+#endif
+#ifndef Tcl_ListObjReplace
+#define Tcl_ListObjReplace \
+ (tclStubsPtr->tcl_ListObjReplace) /* 48 */
+#endif
+#ifndef Tcl_NewBooleanObj
+#define Tcl_NewBooleanObj \
+ (tclStubsPtr->tcl_NewBooleanObj) /* 49 */
+#endif
+#ifndef Tcl_NewByteArrayObj
+#define Tcl_NewByteArrayObj \
+ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */
+#endif
+#ifndef Tcl_NewDoubleObj
+#define Tcl_NewDoubleObj \
+ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */
+#endif
+#ifndef Tcl_NewIntObj
+#define Tcl_NewIntObj \
+ (tclStubsPtr->tcl_NewIntObj) /* 52 */
+#endif
+#ifndef Tcl_NewListObj
+#define Tcl_NewListObj \
+ (tclStubsPtr->tcl_NewListObj) /* 53 */
+#endif
+#ifndef Tcl_NewLongObj
+#define Tcl_NewLongObj \
+ (tclStubsPtr->tcl_NewLongObj) /* 54 */
+#endif
+#ifndef Tcl_NewObj
+#define Tcl_NewObj \
+ (tclStubsPtr->tcl_NewObj) /* 55 */
+#endif
+#ifndef Tcl_NewStringObj
+#define Tcl_NewStringObj \
+ (tclStubsPtr->tcl_NewStringObj) /* 56 */
+#endif
+#ifndef Tcl_SetBooleanObj
+#define Tcl_SetBooleanObj \
+ (tclStubsPtr->tcl_SetBooleanObj) /* 57 */
+#endif
+#ifndef Tcl_SetByteArrayLength
+#define Tcl_SetByteArrayLength \
+ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */
+#endif
+#ifndef Tcl_SetByteArrayObj
+#define Tcl_SetByteArrayObj \
+ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */
+#endif
+#ifndef Tcl_SetDoubleObj
+#define Tcl_SetDoubleObj \
+ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */
+#endif
+#ifndef Tcl_SetIntObj
+#define Tcl_SetIntObj \
+ (tclStubsPtr->tcl_SetIntObj) /* 61 */
+#endif
+#ifndef Tcl_SetListObj
+#define Tcl_SetListObj \
+ (tclStubsPtr->tcl_SetListObj) /* 62 */
+#endif
+#ifndef Tcl_SetLongObj
+#define Tcl_SetLongObj \
+ (tclStubsPtr->tcl_SetLongObj) /* 63 */
+#endif
+#ifndef Tcl_SetObjLength
+#define Tcl_SetObjLength \
+ (tclStubsPtr->tcl_SetObjLength) /* 64 */
+#endif
+#ifndef Tcl_SetStringObj
+#define Tcl_SetStringObj \
+ (tclStubsPtr->tcl_SetStringObj) /* 65 */
+#endif
+#ifndef Tcl_AddErrorInfo
+#define Tcl_AddErrorInfo \
+ (tclStubsPtr->tcl_AddErrorInfo) /* 66 */
+#endif
+#ifndef Tcl_AddObjErrorInfo
+#define Tcl_AddObjErrorInfo \
+ (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */
+#endif
+#ifndef Tcl_AllowExceptions
+#define Tcl_AllowExceptions \
+ (tclStubsPtr->tcl_AllowExceptions) /* 68 */
+#endif
+#ifndef Tcl_AppendElement
+#define Tcl_AppendElement \
+ (tclStubsPtr->tcl_AppendElement) /* 69 */
+#endif
+#ifndef Tcl_AppendResult
+#define Tcl_AppendResult \
+ (tclStubsPtr->tcl_AppendResult) /* 70 */
+#endif
+#ifndef Tcl_AsyncCreate
+#define Tcl_AsyncCreate \
+ (tclStubsPtr->tcl_AsyncCreate) /* 71 */
+#endif
+#ifndef Tcl_AsyncDelete
+#define Tcl_AsyncDelete \
+ (tclStubsPtr->tcl_AsyncDelete) /* 72 */
+#endif
+#ifndef Tcl_AsyncInvoke
+#define Tcl_AsyncInvoke \
+ (tclStubsPtr->tcl_AsyncInvoke) /* 73 */
+#endif
+#ifndef Tcl_AsyncMark
+#define Tcl_AsyncMark \
+ (tclStubsPtr->tcl_AsyncMark) /* 74 */
+#endif
+#ifndef Tcl_AsyncReady
+#define Tcl_AsyncReady \
+ (tclStubsPtr->tcl_AsyncReady) /* 75 */
+#endif
+#ifndef Tcl_BackgroundError
+#define Tcl_BackgroundError \
+ (tclStubsPtr->tcl_BackgroundError) /* 76 */
+#endif
+#ifndef Tcl_Backslash
+#define Tcl_Backslash \
+ (tclStubsPtr->tcl_Backslash) /* 77 */
+#endif
+#ifndef Tcl_BadChannelOption
+#define Tcl_BadChannelOption \
+ (tclStubsPtr->tcl_BadChannelOption) /* 78 */
+#endif
+#ifndef Tcl_CallWhenDeleted
+#define Tcl_CallWhenDeleted \
+ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */
+#endif
+#ifndef Tcl_CancelIdleCall
+#define Tcl_CancelIdleCall \
+ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */
+#endif
+#ifndef Tcl_Close
+#define Tcl_Close \
+ (tclStubsPtr->tcl_Close) /* 81 */
+#endif
+#ifndef Tcl_CommandComplete
+#define Tcl_CommandComplete \
+ (tclStubsPtr->tcl_CommandComplete) /* 82 */
+#endif
+#ifndef Tcl_Concat
+#define Tcl_Concat \
+ (tclStubsPtr->tcl_Concat) /* 83 */
+#endif
+#ifndef Tcl_ConvertElement
+#define Tcl_ConvertElement \
+ (tclStubsPtr->tcl_ConvertElement) /* 84 */
+#endif
+#ifndef Tcl_ConvertCountedElement
+#define Tcl_ConvertCountedElement \
+ (tclStubsPtr->tcl_ConvertCountedElement) /* 85 */
+#endif
+#ifndef Tcl_CreateAlias
+#define Tcl_CreateAlias \
+ (tclStubsPtr->tcl_CreateAlias) /* 86 */
+#endif
+#ifndef Tcl_CreateAliasObj
+#define Tcl_CreateAliasObj \
+ (tclStubsPtr->tcl_CreateAliasObj) /* 87 */
+#endif
+#ifndef Tcl_CreateChannel
+#define Tcl_CreateChannel \
+ (tclStubsPtr->tcl_CreateChannel) /* 88 */
+#endif
+#ifndef Tcl_CreateChannelHandler
+#define Tcl_CreateChannelHandler \
+ (tclStubsPtr->tcl_CreateChannelHandler) /* 89 */
+#endif
+#ifndef Tcl_CreateCloseHandler
+#define Tcl_CreateCloseHandler \
+ (tclStubsPtr->tcl_CreateCloseHandler) /* 90 */
+#endif
+#ifndef Tcl_CreateCommand
+#define Tcl_CreateCommand \
+ (tclStubsPtr->tcl_CreateCommand) /* 91 */
+#endif
+#ifndef Tcl_CreateEventSource
+#define Tcl_CreateEventSource \
+ (tclStubsPtr->tcl_CreateEventSource) /* 92 */
+#endif
+#ifndef Tcl_CreateExitHandler
+#define Tcl_CreateExitHandler \
+ (tclStubsPtr->tcl_CreateExitHandler) /* 93 */
+#endif
+#ifndef Tcl_CreateInterp
+#define Tcl_CreateInterp \
+ (tclStubsPtr->tcl_CreateInterp) /* 94 */
+#endif
+#ifndef Tcl_CreateMathFunc
+#define Tcl_CreateMathFunc \
+ (tclStubsPtr->tcl_CreateMathFunc) /* 95 */
+#endif
+#ifndef Tcl_CreateObjCommand
+#define Tcl_CreateObjCommand \
+ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */
+#endif
+#ifndef Tcl_CreateSlave
+#define Tcl_CreateSlave \
+ (tclStubsPtr->tcl_CreateSlave) /* 97 */
+#endif
+#ifndef Tcl_CreateTimerHandler
+#define Tcl_CreateTimerHandler \
+ (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */
+#endif
+#ifndef Tcl_CreateTrace
+#define Tcl_CreateTrace \
+ (tclStubsPtr->tcl_CreateTrace) /* 99 */
+#endif
+#ifndef Tcl_DeleteAssocData
+#define Tcl_DeleteAssocData \
+ (tclStubsPtr->tcl_DeleteAssocData) /* 100 */
+#endif
+#ifndef Tcl_DeleteChannelHandler
+#define Tcl_DeleteChannelHandler \
+ (tclStubsPtr->tcl_DeleteChannelHandler) /* 101 */
+#endif
+#ifndef Tcl_DeleteCloseHandler
+#define Tcl_DeleteCloseHandler \
+ (tclStubsPtr->tcl_DeleteCloseHandler) /* 102 */
+#endif
+#ifndef Tcl_DeleteCommand
+#define Tcl_DeleteCommand \
+ (tclStubsPtr->tcl_DeleteCommand) /* 103 */
+#endif
+#ifndef Tcl_DeleteCommandFromToken
+#define Tcl_DeleteCommandFromToken \
+ (tclStubsPtr->tcl_DeleteCommandFromToken) /* 104 */
+#endif
+#ifndef Tcl_DeleteEvents
+#define Tcl_DeleteEvents \
+ (tclStubsPtr->tcl_DeleteEvents) /* 105 */
+#endif
+#ifndef Tcl_DeleteEventSource
+#define Tcl_DeleteEventSource \
+ (tclStubsPtr->tcl_DeleteEventSource) /* 106 */
+#endif
+#ifndef Tcl_DeleteExitHandler
+#define Tcl_DeleteExitHandler \
+ (tclStubsPtr->tcl_DeleteExitHandler) /* 107 */
+#endif
+#ifndef Tcl_DeleteHashEntry
+#define Tcl_DeleteHashEntry \
+ (tclStubsPtr->tcl_DeleteHashEntry) /* 108 */
+#endif
+#ifndef Tcl_DeleteHashTable
+#define Tcl_DeleteHashTable \
+ (tclStubsPtr->tcl_DeleteHashTable) /* 109 */
+#endif
+#ifndef Tcl_DeleteInterp
+#define Tcl_DeleteInterp \
+ (tclStubsPtr->tcl_DeleteInterp) /* 110 */
+#endif
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef Tcl_DetachPids
+#define Tcl_DetachPids \
+ (tclStubsPtr->tcl_DetachPids) /* 111 */
+#endif
+#endif /* UNIX */
+#ifdef __WIN32__
+#ifndef Tcl_DetachPids
+#define Tcl_DetachPids \
+ (tclStubsPtr->tcl_DetachPids) /* 111 */
+#endif
+#endif /* __WIN32__ */
+#ifndef Tcl_DeleteTimerHandler
+#define Tcl_DeleteTimerHandler \
+ (tclStubsPtr->tcl_DeleteTimerHandler) /* 112 */
+#endif
+#ifndef Tcl_DeleteTrace
+#define Tcl_DeleteTrace \
+ (tclStubsPtr->tcl_DeleteTrace) /* 113 */
+#endif
+#ifndef Tcl_DontCallWhenDeleted
+#define Tcl_DontCallWhenDeleted \
+ (tclStubsPtr->tcl_DontCallWhenDeleted) /* 114 */
+#endif
+#ifndef Tcl_DoOneEvent
+#define Tcl_DoOneEvent \
+ (tclStubsPtr->tcl_DoOneEvent) /* 115 */
+#endif
+#ifndef Tcl_DoWhenIdle
+#define Tcl_DoWhenIdle \
+ (tclStubsPtr->tcl_DoWhenIdle) /* 116 */
+#endif
+#ifndef Tcl_DStringAppend
+#define Tcl_DStringAppend \
+ (tclStubsPtr->tcl_DStringAppend) /* 117 */
+#endif
+#ifndef Tcl_DStringAppendElement
+#define Tcl_DStringAppendElement \
+ (tclStubsPtr->tcl_DStringAppendElement) /* 118 */
+#endif
+#ifndef Tcl_DStringEndSublist
+#define Tcl_DStringEndSublist \
+ (tclStubsPtr->tcl_DStringEndSublist) /* 119 */
+#endif
+#ifndef Tcl_DStringFree
+#define Tcl_DStringFree \
+ (tclStubsPtr->tcl_DStringFree) /* 120 */
+#endif
+#ifndef Tcl_DStringGetResult
+#define Tcl_DStringGetResult \
+ (tclStubsPtr->tcl_DStringGetResult) /* 121 */
+#endif
+#ifndef Tcl_DStringInit
+#define Tcl_DStringInit \
+ (tclStubsPtr->tcl_DStringInit) /* 122 */
+#endif
+#ifndef Tcl_DStringResult
+#define Tcl_DStringResult \
+ (tclStubsPtr->tcl_DStringResult) /* 123 */
+#endif
+#ifndef Tcl_DStringSetLength
+#define Tcl_DStringSetLength \
+ (tclStubsPtr->tcl_DStringSetLength) /* 124 */
+#endif
+#ifndef Tcl_DStringStartSublist
+#define Tcl_DStringStartSublist \
+ (tclStubsPtr->tcl_DStringStartSublist) /* 125 */
+#endif
+#ifndef Tcl_Eof
+#define Tcl_Eof \
+ (tclStubsPtr->tcl_Eof) /* 126 */
+#endif
+#ifndef Tcl_ErrnoId
+#define Tcl_ErrnoId \
+ (tclStubsPtr->tcl_ErrnoId) /* 127 */
+#endif
+#ifndef Tcl_ErrnoMsg
+#define Tcl_ErrnoMsg \
+ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */
+#endif
+#ifndef Tcl_Eval
+#define Tcl_Eval \
+ (tclStubsPtr->tcl_Eval) /* 129 */
+#endif
+#ifndef Tcl_EvalFile
+#define Tcl_EvalFile \
+ (tclStubsPtr->tcl_EvalFile) /* 130 */
+#endif
+#ifndef Tcl_EvalObj
+#define Tcl_EvalObj \
+ (tclStubsPtr->tcl_EvalObj) /* 131 */
+#endif
+#ifndef Tcl_EventuallyFree
+#define Tcl_EventuallyFree \
+ (tclStubsPtr->tcl_EventuallyFree) /* 132 */
+#endif
+#ifndef Tcl_Exit
+#define Tcl_Exit \
+ (tclStubsPtr->tcl_Exit) /* 133 */
+#endif
+#ifndef Tcl_ExposeCommand
+#define Tcl_ExposeCommand \
+ (tclStubsPtr->tcl_ExposeCommand) /* 134 */
+#endif
+#ifndef Tcl_ExprBoolean
+#define Tcl_ExprBoolean \
+ (tclStubsPtr->tcl_ExprBoolean) /* 135 */
+#endif
+#ifndef Tcl_ExprBooleanObj
+#define Tcl_ExprBooleanObj \
+ (tclStubsPtr->tcl_ExprBooleanObj) /* 136 */
+#endif
+#ifndef Tcl_ExprDouble
+#define Tcl_ExprDouble \
+ (tclStubsPtr->tcl_ExprDouble) /* 137 */
+#endif
+#ifndef Tcl_ExprDoubleObj
+#define Tcl_ExprDoubleObj \
+ (tclStubsPtr->tcl_ExprDoubleObj) /* 138 */
+#endif
+#ifndef Tcl_ExprLong
+#define Tcl_ExprLong \
+ (tclStubsPtr->tcl_ExprLong) /* 139 */
+#endif
+#ifndef Tcl_ExprLongObj
+#define Tcl_ExprLongObj \
+ (tclStubsPtr->tcl_ExprLongObj) /* 140 */
+#endif
+#ifndef Tcl_ExprObj
+#define Tcl_ExprObj \
+ (tclStubsPtr->tcl_ExprObj) /* 141 */
+#endif
+#ifndef Tcl_ExprString
+#define Tcl_ExprString \
+ (tclStubsPtr->tcl_ExprString) /* 142 */
+#endif
+#ifndef Tcl_Finalize
+#define Tcl_Finalize \
+ (tclStubsPtr->tcl_Finalize) /* 143 */
+#endif
+#ifndef Tcl_FindExecutable
+#define Tcl_FindExecutable \
+ (tclStubsPtr->tcl_FindExecutable) /* 144 */
+#endif
+#ifndef Tcl_FirstHashEntry
+#define Tcl_FirstHashEntry \
+ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */
+#endif
+#ifndef Tcl_Flush
+#define Tcl_Flush \
+ (tclStubsPtr->tcl_Flush) /* 146 */
+#endif
+#ifndef Tcl_FreeResult
+#define Tcl_FreeResult \
+ (tclStubsPtr->tcl_FreeResult) /* 147 */
+#endif
+#ifndef Tcl_GetAlias
+#define Tcl_GetAlias \
+ (tclStubsPtr->tcl_GetAlias) /* 148 */
+#endif
+#ifndef Tcl_GetAliasObj
+#define Tcl_GetAliasObj \
+ (tclStubsPtr->tcl_GetAliasObj) /* 149 */
+#endif
+#ifndef Tcl_GetAssocData
+#define Tcl_GetAssocData \
+ (tclStubsPtr->tcl_GetAssocData) /* 150 */
+#endif
+#ifndef Tcl_GetChannel
+#define Tcl_GetChannel \
+ (tclStubsPtr->tcl_GetChannel) /* 151 */
+#endif
+#ifndef Tcl_GetChannelBufferSize
+#define Tcl_GetChannelBufferSize \
+ (tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */
+#endif
+#ifndef Tcl_GetChannelHandle
+#define Tcl_GetChannelHandle \
+ (tclStubsPtr->tcl_GetChannelHandle) /* 153 */
+#endif
+#ifndef Tcl_GetChannelInstanceData
+#define Tcl_GetChannelInstanceData \
+ (tclStubsPtr->tcl_GetChannelInstanceData) /* 154 */
+#endif
+#ifndef Tcl_GetChannelMode
+#define Tcl_GetChannelMode \
+ (tclStubsPtr->tcl_GetChannelMode) /* 155 */
+#endif
+#ifndef Tcl_GetChannelName
+#define Tcl_GetChannelName \
+ (tclStubsPtr->tcl_GetChannelName) /* 156 */
+#endif
+#ifndef Tcl_GetChannelOption
+#define Tcl_GetChannelOption \
+ (tclStubsPtr->tcl_GetChannelOption) /* 157 */
+#endif
+#ifndef Tcl_GetChannelType
+#define Tcl_GetChannelType \
+ (tclStubsPtr->tcl_GetChannelType) /* 158 */
+#endif
+#ifndef Tcl_GetCommandInfo
+#define Tcl_GetCommandInfo \
+ (tclStubsPtr->tcl_GetCommandInfo) /* 159 */
+#endif
+#ifndef Tcl_GetCommandName
+#define Tcl_GetCommandName \
+ (tclStubsPtr->tcl_GetCommandName) /* 160 */
+#endif
+#ifndef Tcl_GetErrno
+#define Tcl_GetErrno \
+ (tclStubsPtr->tcl_GetErrno) /* 161 */
+#endif
+#ifndef Tcl_GetHostName
+#define Tcl_GetHostName \
+ (tclStubsPtr->tcl_GetHostName) /* 162 */
+#endif
+#ifndef Tcl_GetInterpPath
+#define Tcl_GetInterpPath \
+ (tclStubsPtr->tcl_GetInterpPath) /* 163 */
+#endif
+#ifndef Tcl_GetMaster
+#define Tcl_GetMaster \
+ (tclStubsPtr->tcl_GetMaster) /* 164 */
+#endif
+#ifndef Tcl_GetNameOfExecutable
+#define Tcl_GetNameOfExecutable \
+ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
+#endif
+#ifndef Tcl_GetObjResult
+#define Tcl_GetObjResult \
+ (tclStubsPtr->tcl_GetObjResult) /* 166 */
+#endif
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef Tcl_GetOpenFile
+#define Tcl_GetOpenFile \
+ (tclStubsPtr->tcl_GetOpenFile) /* 167 */
+#endif
+#endif /* UNIX */
+#ifndef Tcl_GetPathType
+#define Tcl_GetPathType \
+ (tclStubsPtr->tcl_GetPathType) /* 168 */
+#endif
+#ifndef Tcl_Gets
+#define Tcl_Gets \
+ (tclStubsPtr->tcl_Gets) /* 169 */
+#endif
+#ifndef Tcl_GetsObj
+#define Tcl_GetsObj \
+ (tclStubsPtr->tcl_GetsObj) /* 170 */
+#endif
+#ifndef Tcl_GetServiceMode
+#define Tcl_GetServiceMode \
+ (tclStubsPtr->tcl_GetServiceMode) /* 171 */
+#endif
+#ifndef Tcl_GetSlave
+#define Tcl_GetSlave \
+ (tclStubsPtr->tcl_GetSlave) /* 172 */
+#endif
+#ifndef Tcl_GetStdChannel
+#define Tcl_GetStdChannel \
+ (tclStubsPtr->tcl_GetStdChannel) /* 173 */
+#endif
+#ifndef Tcl_GetStringResult
+#define Tcl_GetStringResult \
+ (tclStubsPtr->tcl_GetStringResult) /* 174 */
+#endif
+#ifndef Tcl_GetVar
+#define Tcl_GetVar \
+ (tclStubsPtr->tcl_GetVar) /* 175 */
+#endif
+#ifndef Tcl_GetVar2
+#define Tcl_GetVar2 \
+ (tclStubsPtr->tcl_GetVar2) /* 176 */
+#endif
+#ifndef Tcl_GlobalEval
+#define Tcl_GlobalEval \
+ (tclStubsPtr->tcl_GlobalEval) /* 177 */
+#endif
+#ifndef Tcl_GlobalEvalObj
+#define Tcl_GlobalEvalObj \
+ (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */
+#endif
+#ifndef Tcl_HideCommand
+#define Tcl_HideCommand \
+ (tclStubsPtr->tcl_HideCommand) /* 179 */
+#endif
+#ifndef Tcl_Init
+#define Tcl_Init \
+ (tclStubsPtr->tcl_Init) /* 180 */
+#endif
+#ifndef Tcl_InitHashTable
+#define Tcl_InitHashTable \
+ (tclStubsPtr->tcl_InitHashTable) /* 181 */
+#endif
+#ifndef Tcl_InputBlocked
+#define Tcl_InputBlocked \
+ (tclStubsPtr->tcl_InputBlocked) /* 182 */
+#endif
+#ifndef Tcl_InputBuffered
+#define Tcl_InputBuffered \
+ (tclStubsPtr->tcl_InputBuffered) /* 183 */
+#endif
+#ifndef Tcl_InterpDeleted
+#define Tcl_InterpDeleted \
+ (tclStubsPtr->tcl_InterpDeleted) /* 184 */
+#endif
+#ifndef Tcl_IsSafe
+#define Tcl_IsSafe \
+ (tclStubsPtr->tcl_IsSafe) /* 185 */
+#endif
+#ifndef Tcl_JoinPath
+#define Tcl_JoinPath \
+ (tclStubsPtr->tcl_JoinPath) /* 186 */
+#endif
+#ifndef Tcl_LinkVar
+#define Tcl_LinkVar \
+ (tclStubsPtr->tcl_LinkVar) /* 187 */
+#endif
+/* Slot 188 is reserved */
+#ifndef Tcl_MakeFileChannel
+#define Tcl_MakeFileChannel \
+ (tclStubsPtr->tcl_MakeFileChannel) /* 189 */
+#endif
+#ifndef Tcl_MakeSafe
+#define Tcl_MakeSafe \
+ (tclStubsPtr->tcl_MakeSafe) /* 190 */
+#endif
+#ifndef Tcl_MakeTcpClientChannel
+#define Tcl_MakeTcpClientChannel \
+ (tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */
+#endif
+#ifndef Tcl_Merge
+#define Tcl_Merge \
+ (tclStubsPtr->tcl_Merge) /* 192 */
+#endif
+#ifndef Tcl_NextHashEntry
+#define Tcl_NextHashEntry \
+ (tclStubsPtr->tcl_NextHashEntry) /* 193 */
+#endif
+#ifndef Tcl_NotifyChannel
+#define Tcl_NotifyChannel \
+ (tclStubsPtr->tcl_NotifyChannel) /* 194 */
+#endif
+#ifndef Tcl_ObjGetVar2
+#define Tcl_ObjGetVar2 \
+ (tclStubsPtr->tcl_ObjGetVar2) /* 195 */
+#endif
+#ifndef Tcl_ObjSetVar2
+#define Tcl_ObjSetVar2 \
+ (tclStubsPtr->tcl_ObjSetVar2) /* 196 */
+#endif
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef Tcl_OpenCommandChannel
+#define Tcl_OpenCommandChannel \
+ (tclStubsPtr->tcl_OpenCommandChannel) /* 197 */
+#endif
+#endif /* UNIX */
+#ifdef __WIN32__
+#ifndef Tcl_OpenCommandChannel
+#define Tcl_OpenCommandChannel \
+ (tclStubsPtr->tcl_OpenCommandChannel) /* 197 */
+#endif
+#endif /* __WIN32__ */
+#ifndef Tcl_OpenFileChannel
+#define Tcl_OpenFileChannel \
+ (tclStubsPtr->tcl_OpenFileChannel) /* 198 */
+#endif
+#ifndef Tcl_OpenTcpClient
+#define Tcl_OpenTcpClient \
+ (tclStubsPtr->tcl_OpenTcpClient) /* 199 */
+#endif
+#ifndef Tcl_OpenTcpServer
+#define Tcl_OpenTcpServer \
+ (tclStubsPtr->tcl_OpenTcpServer) /* 200 */
+#endif
+#ifndef Tcl_Preserve
+#define Tcl_Preserve \
+ (tclStubsPtr->tcl_Preserve) /* 201 */
+#endif
+#ifndef Tcl_PrintDouble
+#define Tcl_PrintDouble \
+ (tclStubsPtr->tcl_PrintDouble) /* 202 */
+#endif
+#ifndef Tcl_PutEnv
+#define Tcl_PutEnv \
+ (tclStubsPtr->tcl_PutEnv) /* 203 */
+#endif
+#ifndef Tcl_PosixError
+#define Tcl_PosixError \
+ (tclStubsPtr->tcl_PosixError) /* 204 */
+#endif
+#ifndef Tcl_QueueEvent
+#define Tcl_QueueEvent \
+ (tclStubsPtr->tcl_QueueEvent) /* 205 */
+#endif
+#ifndef Tcl_Read
+#define Tcl_Read \
+ (tclStubsPtr->tcl_Read) /* 206 */
+#endif
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef Tcl_ReapDetachedProcs
+#define Tcl_ReapDetachedProcs \
+ (tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */
+#endif
+#endif /* UNIX */
+#ifdef __WIN32__
+#ifndef Tcl_ReapDetachedProcs
+#define Tcl_ReapDetachedProcs \
+ (tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */
+#endif
+#endif /* __WIN32__ */
+#ifndef Tcl_RecordAndEval
+#define Tcl_RecordAndEval \
+ (tclStubsPtr->tcl_RecordAndEval) /* 208 */
+#endif
+#ifndef Tcl_RecordAndEvalObj
+#define Tcl_RecordAndEvalObj \
+ (tclStubsPtr->tcl_RecordAndEvalObj) /* 209 */
+#endif
+#ifndef Tcl_RegisterChannel
+#define Tcl_RegisterChannel \
+ (tclStubsPtr->tcl_RegisterChannel) /* 210 */
+#endif
+#ifndef Tcl_RegisterObjType
+#define Tcl_RegisterObjType \
+ (tclStubsPtr->tcl_RegisterObjType) /* 211 */
+#endif
+#ifndef Tcl_RegExpCompile
+#define Tcl_RegExpCompile \
+ (tclStubsPtr->tcl_RegExpCompile) /* 212 */
+#endif
+#ifndef Tcl_RegExpExec
+#define Tcl_RegExpExec \
+ (tclStubsPtr->tcl_RegExpExec) /* 213 */
+#endif
+#ifndef Tcl_RegExpMatch
+#define Tcl_RegExpMatch \
+ (tclStubsPtr->tcl_RegExpMatch) /* 214 */
+#endif
+#ifndef Tcl_RegExpRange
+#define Tcl_RegExpRange \
+ (tclStubsPtr->tcl_RegExpRange) /* 215 */
+#endif
+#ifndef Tcl_Release
+#define Tcl_Release \
+ (tclStubsPtr->tcl_Release) /* 216 */
+#endif
+#ifndef Tcl_ResetResult
+#define Tcl_ResetResult \
+ (tclStubsPtr->tcl_ResetResult) /* 217 */
+#endif
+#ifndef Tcl_ScanElement
+#define Tcl_ScanElement \
+ (tclStubsPtr->tcl_ScanElement) /* 218 */
+#endif
+#ifndef Tcl_ScanCountedElement
+#define Tcl_ScanCountedElement \
+ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */
+#endif
+#ifndef Tcl_SeekOld
+#define Tcl_SeekOld \
+ (tclStubsPtr->tcl_SeekOld) /* 220 */
+#endif
+#ifndef Tcl_ServiceAll
+#define Tcl_ServiceAll \
+ (tclStubsPtr->tcl_ServiceAll) /* 221 */
+#endif
+#ifndef Tcl_ServiceEvent
+#define Tcl_ServiceEvent \
+ (tclStubsPtr->tcl_ServiceEvent) /* 222 */
+#endif
+#ifndef Tcl_SetAssocData
+#define Tcl_SetAssocData \
+ (tclStubsPtr->tcl_SetAssocData) /* 223 */
+#endif
+#ifndef Tcl_SetChannelBufferSize
+#define Tcl_SetChannelBufferSize \
+ (tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */
+#endif
+#ifndef Tcl_SetChannelOption
+#define Tcl_SetChannelOption \
+ (tclStubsPtr->tcl_SetChannelOption) /* 225 */
+#endif
+#ifndef Tcl_SetCommandInfo
+#define Tcl_SetCommandInfo \
+ (tclStubsPtr->tcl_SetCommandInfo) /* 226 */
+#endif
+#ifndef Tcl_SetErrno
+#define Tcl_SetErrno \
+ (tclStubsPtr->tcl_SetErrno) /* 227 */
+#endif
+#ifndef Tcl_SetErrorCode
+#define Tcl_SetErrorCode \
+ (tclStubsPtr->tcl_SetErrorCode) /* 228 */
+#endif
+#ifndef Tcl_SetMaxBlockTime
+#define Tcl_SetMaxBlockTime \
+ (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */
+#endif
+#ifndef Tcl_SetPanicProc
+#define Tcl_SetPanicProc \
+ (tclStubsPtr->tcl_SetPanicProc) /* 230 */
+#endif
+#ifndef Tcl_SetRecursionLimit
+#define Tcl_SetRecursionLimit \
+ (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */
+#endif
+#ifndef Tcl_SetResult
+#define Tcl_SetResult \
+ (tclStubsPtr->tcl_SetResult) /* 232 */
+#endif
+#ifndef Tcl_SetServiceMode
+#define Tcl_SetServiceMode \
+ (tclStubsPtr->tcl_SetServiceMode) /* 233 */
+#endif
+#ifndef Tcl_SetObjErrorCode
+#define Tcl_SetObjErrorCode \
+ (tclStubsPtr->tcl_SetObjErrorCode) /* 234 */
+#endif
+#ifndef Tcl_SetObjResult
+#define Tcl_SetObjResult \
+ (tclStubsPtr->tcl_SetObjResult) /* 235 */
+#endif
+#ifndef Tcl_SetStdChannel
+#define Tcl_SetStdChannel \
+ (tclStubsPtr->tcl_SetStdChannel) /* 236 */
+#endif
+#ifndef Tcl_SetVar
+#define Tcl_SetVar \
+ (tclStubsPtr->tcl_SetVar) /* 237 */
+#endif
+#ifndef Tcl_SetVar2
+#define Tcl_SetVar2 \
+ (tclStubsPtr->tcl_SetVar2) /* 238 */
+#endif
+#ifndef Tcl_SignalId
+#define Tcl_SignalId \
+ (tclStubsPtr->tcl_SignalId) /* 239 */
+#endif
+#ifndef Tcl_SignalMsg
+#define Tcl_SignalMsg \
+ (tclStubsPtr->tcl_SignalMsg) /* 240 */
+#endif
+#ifndef Tcl_SourceRCFile
+#define Tcl_SourceRCFile \
+ (tclStubsPtr->tcl_SourceRCFile) /* 241 */
+#endif
+#ifndef Tcl_SplitList
+#define Tcl_SplitList \
+ (tclStubsPtr->tcl_SplitList) /* 242 */
+#endif
+#ifndef Tcl_SplitPath
+#define Tcl_SplitPath \
+ (tclStubsPtr->tcl_SplitPath) /* 243 */
+#endif
+#ifndef Tcl_StaticPackage
+#define Tcl_StaticPackage \
+ (tclStubsPtr->tcl_StaticPackage) /* 244 */
+#endif
+#ifndef Tcl_StringMatch
+#define Tcl_StringMatch \
+ (tclStubsPtr->tcl_StringMatch) /* 245 */
+#endif
+#ifndef Tcl_TellOld
+#define Tcl_TellOld \
+ (tclStubsPtr->tcl_TellOld) /* 246 */
+#endif
+#ifndef Tcl_TraceVar
+#define Tcl_TraceVar \
+ (tclStubsPtr->tcl_TraceVar) /* 247 */
+#endif
+#ifndef Tcl_TraceVar2
+#define Tcl_TraceVar2 \
+ (tclStubsPtr->tcl_TraceVar2) /* 248 */
+#endif
+#ifndef Tcl_TranslateFileName
+#define Tcl_TranslateFileName \
+ (tclStubsPtr->tcl_TranslateFileName) /* 249 */
+#endif
+#ifndef Tcl_Ungets
+#define Tcl_Ungets \
+ (tclStubsPtr->tcl_Ungets) /* 250 */
+#endif
+#ifndef Tcl_UnlinkVar
+#define Tcl_UnlinkVar \
+ (tclStubsPtr->tcl_UnlinkVar) /* 251 */
+#endif
+#ifndef Tcl_UnregisterChannel
+#define Tcl_UnregisterChannel \
+ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */
+#endif
+#ifndef Tcl_UnsetVar
+#define Tcl_UnsetVar \
+ (tclStubsPtr->tcl_UnsetVar) /* 253 */
+#endif
+#ifndef Tcl_UnsetVar2
+#define Tcl_UnsetVar2 \
+ (tclStubsPtr->tcl_UnsetVar2) /* 254 */
+#endif
+#ifndef Tcl_UntraceVar
+#define Tcl_UntraceVar \
+ (tclStubsPtr->tcl_UntraceVar) /* 255 */
+#endif
+#ifndef Tcl_UntraceVar2
+#define Tcl_UntraceVar2 \
+ (tclStubsPtr->tcl_UntraceVar2) /* 256 */
+#endif
+#ifndef Tcl_UpdateLinkedVar
+#define Tcl_UpdateLinkedVar \
+ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */
+#endif
+#ifndef Tcl_UpVar
+#define Tcl_UpVar \
+ (tclStubsPtr->tcl_UpVar) /* 258 */
+#endif
+#ifndef Tcl_UpVar2
+#define Tcl_UpVar2 \
+ (tclStubsPtr->tcl_UpVar2) /* 259 */
+#endif
+#ifndef Tcl_VarEval
+#define Tcl_VarEval \
+ (tclStubsPtr->tcl_VarEval) /* 260 */
+#endif
+#ifndef Tcl_VarTraceInfo
+#define Tcl_VarTraceInfo \
+ (tclStubsPtr->tcl_VarTraceInfo) /* 261 */
+#endif
+#ifndef Tcl_VarTraceInfo2
+#define Tcl_VarTraceInfo2 \
+ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */
+#endif
+#ifndef Tcl_Write
+#define Tcl_Write \
+ (tclStubsPtr->tcl_Write) /* 263 */
+#endif
+#ifndef Tcl_WrongNumArgs
+#define Tcl_WrongNumArgs \
+ (tclStubsPtr->tcl_WrongNumArgs) /* 264 */
+#endif
+#ifndef Tcl_DumpActiveMemory
+#define Tcl_DumpActiveMemory \
+ (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */
+#endif
+#ifndef Tcl_ValidateAllMemory
+#define Tcl_ValidateAllMemory \
+ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */
+#endif
+#ifndef Tcl_AppendResultVA
+#define Tcl_AppendResultVA \
+ (tclStubsPtr->tcl_AppendResultVA) /* 267 */
+#endif
+#ifndef Tcl_AppendStringsToObjVA
+#define Tcl_AppendStringsToObjVA \
+ (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */
+#endif
+#ifndef Tcl_HashStats
+#define Tcl_HashStats \
+ (tclStubsPtr->tcl_HashStats) /* 269 */
+#endif
+#ifndef Tcl_ParseVar
+#define Tcl_ParseVar \
+ (tclStubsPtr->tcl_ParseVar) /* 270 */
+#endif
+#ifndef Tcl_PkgPresent
+#define Tcl_PkgPresent \
+ (tclStubsPtr->tcl_PkgPresent) /* 271 */
+#endif
+#ifndef Tcl_PkgPresentEx
+#define Tcl_PkgPresentEx \
+ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */
+#endif
+#ifndef Tcl_PkgProvide
+#define Tcl_PkgProvide \
+ (tclStubsPtr->tcl_PkgProvide) /* 273 */
+#endif
+#ifndef Tcl_PkgRequire
+#define Tcl_PkgRequire \
+ (tclStubsPtr->tcl_PkgRequire) /* 274 */
+#endif
+#ifndef Tcl_SetErrorCodeVA
+#define Tcl_SetErrorCodeVA \
+ (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */
+#endif
+#ifndef Tcl_VarEvalVA
+#define Tcl_VarEvalVA \
+ (tclStubsPtr->tcl_VarEvalVA) /* 276 */
+#endif
+#ifndef Tcl_WaitPid
+#define Tcl_WaitPid \
+ (tclStubsPtr->tcl_WaitPid) /* 277 */
+#endif
+#ifndef Tcl_PanicVA
+#define Tcl_PanicVA \
+ (tclStubsPtr->tcl_PanicVA) /* 278 */
+#endif
+#ifndef Tcl_GetVersion
+#define Tcl_GetVersion \
+ (tclStubsPtr->tcl_GetVersion) /* 279 */
+#endif
+#ifndef Tcl_InitMemory
+#define Tcl_InitMemory \
+ (tclStubsPtr->tcl_InitMemory) /* 280 */
+#endif
+#ifndef Tcl_StackChannel
+#define Tcl_StackChannel \
+ (tclStubsPtr->tcl_StackChannel) /* 281 */
+#endif
+#ifndef Tcl_UnstackChannel
+#define Tcl_UnstackChannel \
+ (tclStubsPtr->tcl_UnstackChannel) /* 282 */
+#endif
+#ifndef Tcl_GetStackedChannel
+#define Tcl_GetStackedChannel \
+ (tclStubsPtr->tcl_GetStackedChannel) /* 283 */
+#endif
+#ifndef Tcl_SetMainLoop
+#define Tcl_SetMainLoop \
+ (tclStubsPtr->tcl_SetMainLoop) /* 284 */
+#endif
+/* Slot 285 is reserved */
+#ifndef Tcl_AppendObjToObj
+#define Tcl_AppendObjToObj \
+ (tclStubsPtr->tcl_AppendObjToObj) /* 286 */
+#endif
+#ifndef Tcl_CreateEncoding
+#define Tcl_CreateEncoding \
+ (tclStubsPtr->tcl_CreateEncoding) /* 287 */
+#endif
+#ifndef Tcl_CreateThreadExitHandler
+#define Tcl_CreateThreadExitHandler \
+ (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */
+#endif
+#ifndef Tcl_DeleteThreadExitHandler
+#define Tcl_DeleteThreadExitHandler \
+ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */
+#endif
+#ifndef Tcl_DiscardResult
+#define Tcl_DiscardResult \
+ (tclStubsPtr->tcl_DiscardResult) /* 290 */
+#endif
+#ifndef Tcl_EvalEx
+#define Tcl_EvalEx \
+ (tclStubsPtr->tcl_EvalEx) /* 291 */
+#endif
+#ifndef Tcl_EvalObjv
+#define Tcl_EvalObjv \
+ (tclStubsPtr->tcl_EvalObjv) /* 292 */
+#endif
+#ifndef Tcl_EvalObjEx
+#define Tcl_EvalObjEx \
+ (tclStubsPtr->tcl_EvalObjEx) /* 293 */
+#endif
+#ifndef Tcl_ExitThread
+#define Tcl_ExitThread \
+ (tclStubsPtr->tcl_ExitThread) /* 294 */
+#endif
+#ifndef Tcl_ExternalToUtf
+#define Tcl_ExternalToUtf \
+ (tclStubsPtr->tcl_ExternalToUtf) /* 295 */
+#endif
+#ifndef Tcl_ExternalToUtfDString
+#define Tcl_ExternalToUtfDString \
+ (tclStubsPtr->tcl_ExternalToUtfDString) /* 296 */
+#endif
+#ifndef Tcl_FinalizeThread
+#define Tcl_FinalizeThread \
+ (tclStubsPtr->tcl_FinalizeThread) /* 297 */
+#endif
+#ifndef Tcl_FinalizeNotifier
+#define Tcl_FinalizeNotifier \
+ (tclStubsPtr->tcl_FinalizeNotifier) /* 298 */
+#endif
+#ifndef Tcl_FreeEncoding
+#define Tcl_FreeEncoding \
+ (tclStubsPtr->tcl_FreeEncoding) /* 299 */
+#endif
+#ifndef Tcl_GetCurrentThread
+#define Tcl_GetCurrentThread \
+ (tclStubsPtr->tcl_GetCurrentThread) /* 300 */
+#endif
+#ifndef Tcl_GetEncoding
+#define Tcl_GetEncoding \
+ (tclStubsPtr->tcl_GetEncoding) /* 301 */
+#endif
+#ifndef Tcl_GetEncodingName
+#define Tcl_GetEncodingName \
+ (tclStubsPtr->tcl_GetEncodingName) /* 302 */
+#endif
+#ifndef Tcl_GetEncodingNames
+#define Tcl_GetEncodingNames \
+ (tclStubsPtr->tcl_GetEncodingNames) /* 303 */
+#endif
+#ifndef Tcl_GetIndexFromObjStruct
+#define Tcl_GetIndexFromObjStruct \
+ (tclStubsPtr->tcl_GetIndexFromObjStruct) /* 304 */
+#endif
+#ifndef Tcl_GetThreadData
+#define Tcl_GetThreadData \
+ (tclStubsPtr->tcl_GetThreadData) /* 305 */
+#endif
+#ifndef Tcl_GetVar2Ex
+#define Tcl_GetVar2Ex \
+ (tclStubsPtr->tcl_GetVar2Ex) /* 306 */
+#endif
+#ifndef Tcl_InitNotifier
+#define Tcl_InitNotifier \
+ (tclStubsPtr->tcl_InitNotifier) /* 307 */
+#endif
+#ifndef Tcl_MutexLock
+#define Tcl_MutexLock \
+ (tclStubsPtr->tcl_MutexLock) /* 308 */
+#endif
+#ifndef Tcl_MutexUnlock
+#define Tcl_MutexUnlock \
+ (tclStubsPtr->tcl_MutexUnlock) /* 309 */
+#endif
+#ifndef Tcl_ConditionNotify
+#define Tcl_ConditionNotify \
+ (tclStubsPtr->tcl_ConditionNotify) /* 310 */
+#endif
+#ifndef Tcl_ConditionWait
+#define Tcl_ConditionWait \
+ (tclStubsPtr->tcl_ConditionWait) /* 311 */
+#endif
+#ifndef Tcl_NumUtfChars
+#define Tcl_NumUtfChars \
+ (tclStubsPtr->tcl_NumUtfChars) /* 312 */
+#endif
+#ifndef Tcl_ReadChars
+#define Tcl_ReadChars \
+ (tclStubsPtr->tcl_ReadChars) /* 313 */
+#endif
+#ifndef Tcl_RestoreResult
+#define Tcl_RestoreResult \
+ (tclStubsPtr->tcl_RestoreResult) /* 314 */
+#endif
+#ifndef Tcl_SaveResult
+#define Tcl_SaveResult \
+ (tclStubsPtr->tcl_SaveResult) /* 315 */
+#endif
+#ifndef Tcl_SetSystemEncoding
+#define Tcl_SetSystemEncoding \
+ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */
+#endif
+#ifndef Tcl_SetVar2Ex
+#define Tcl_SetVar2Ex \
+ (tclStubsPtr->tcl_SetVar2Ex) /* 317 */
+#endif
+#ifndef Tcl_ThreadAlert
+#define Tcl_ThreadAlert \
+ (tclStubsPtr->tcl_ThreadAlert) /* 318 */
+#endif
+#ifndef Tcl_ThreadQueueEvent
+#define Tcl_ThreadQueueEvent \
+ (tclStubsPtr->tcl_ThreadQueueEvent) /* 319 */
+#endif
+#ifndef Tcl_UniCharAtIndex
+#define Tcl_UniCharAtIndex \
+ (tclStubsPtr->tcl_UniCharAtIndex) /* 320 */
+#endif
+#ifndef Tcl_UniCharToLower
+#define Tcl_UniCharToLower \
+ (tclStubsPtr->tcl_UniCharToLower) /* 321 */
+#endif
+#ifndef Tcl_UniCharToTitle
+#define Tcl_UniCharToTitle \
+ (tclStubsPtr->tcl_UniCharToTitle) /* 322 */
+#endif
+#ifndef Tcl_UniCharToUpper
+#define Tcl_UniCharToUpper \
+ (tclStubsPtr->tcl_UniCharToUpper) /* 323 */
+#endif
+#ifndef Tcl_UniCharToUtf
+#define Tcl_UniCharToUtf \
+ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */
+#endif
+#ifndef Tcl_UtfAtIndex
+#define Tcl_UtfAtIndex \
+ (tclStubsPtr->tcl_UtfAtIndex) /* 325 */
+#endif
+#ifndef Tcl_UtfCharComplete
+#define Tcl_UtfCharComplete \
+ (tclStubsPtr->tcl_UtfCharComplete) /* 326 */
+#endif
+#ifndef Tcl_UtfBackslash
+#define Tcl_UtfBackslash \
+ (tclStubsPtr->tcl_UtfBackslash) /* 327 */
+#endif
+#ifndef Tcl_UtfFindFirst
+#define Tcl_UtfFindFirst \
+ (tclStubsPtr->tcl_UtfFindFirst) /* 328 */
+#endif
+#ifndef Tcl_UtfFindLast
+#define Tcl_UtfFindLast \
+ (tclStubsPtr->tcl_UtfFindLast) /* 329 */
+#endif
+#ifndef Tcl_UtfNext
+#define Tcl_UtfNext \
+ (tclStubsPtr->tcl_UtfNext) /* 330 */
+#endif
+#ifndef Tcl_UtfPrev
+#define Tcl_UtfPrev \
+ (tclStubsPtr->tcl_UtfPrev) /* 331 */
+#endif
+#ifndef Tcl_UtfToExternal
+#define Tcl_UtfToExternal \
+ (tclStubsPtr->tcl_UtfToExternal) /* 332 */
+#endif
+#ifndef Tcl_UtfToExternalDString
+#define Tcl_UtfToExternalDString \
+ (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */
+#endif
+#ifndef Tcl_UtfToLower
+#define Tcl_UtfToLower \
+ (tclStubsPtr->tcl_UtfToLower) /* 334 */
+#endif
+#ifndef Tcl_UtfToTitle
+#define Tcl_UtfToTitle \
+ (tclStubsPtr->tcl_UtfToTitle) /* 335 */
+#endif
+#ifndef Tcl_UtfToUniChar
+#define Tcl_UtfToUniChar \
+ (tclStubsPtr->tcl_UtfToUniChar) /* 336 */
+#endif
+#ifndef Tcl_UtfToUpper
+#define Tcl_UtfToUpper \
+ (tclStubsPtr->tcl_UtfToUpper) /* 337 */
+#endif
+#ifndef Tcl_WriteChars
+#define Tcl_WriteChars \
+ (tclStubsPtr->tcl_WriteChars) /* 338 */
+#endif
+#ifndef Tcl_WriteObj
+#define Tcl_WriteObj \
+ (tclStubsPtr->tcl_WriteObj) /* 339 */
+#endif
+#ifndef Tcl_GetString
+#define Tcl_GetString \
+ (tclStubsPtr->tcl_GetString) /* 340 */
+#endif
+#ifndef Tcl_GetDefaultEncodingDir
+#define Tcl_GetDefaultEncodingDir \
+ (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */
+#endif
+#ifndef Tcl_SetDefaultEncodingDir
+#define Tcl_SetDefaultEncodingDir \
+ (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */
+#endif
+#ifndef Tcl_AlertNotifier
+#define Tcl_AlertNotifier \
+ (tclStubsPtr->tcl_AlertNotifier) /* 343 */
+#endif
+#ifndef Tcl_ServiceModeHook
+#define Tcl_ServiceModeHook \
+ (tclStubsPtr->tcl_ServiceModeHook) /* 344 */
+#endif
+#ifndef Tcl_UniCharIsAlnum
+#define Tcl_UniCharIsAlnum \
+ (tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */
+#endif
+#ifndef Tcl_UniCharIsAlpha
+#define Tcl_UniCharIsAlpha \
+ (tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */
+#endif
+#ifndef Tcl_UniCharIsDigit
+#define Tcl_UniCharIsDigit \
+ (tclStubsPtr->tcl_UniCharIsDigit) /* 347 */
+#endif
+#ifndef Tcl_UniCharIsLower
+#define Tcl_UniCharIsLower \
+ (tclStubsPtr->tcl_UniCharIsLower) /* 348 */
+#endif
+#ifndef Tcl_UniCharIsSpace
+#define Tcl_UniCharIsSpace \
+ (tclStubsPtr->tcl_UniCharIsSpace) /* 349 */
+#endif
+#ifndef Tcl_UniCharIsUpper
+#define Tcl_UniCharIsUpper \
+ (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */
+#endif
+#ifndef Tcl_UniCharIsWordChar
+#define Tcl_UniCharIsWordChar \
+ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */
+#endif
+#ifndef Tcl_UniCharLen
+#define Tcl_UniCharLen \
+ (tclStubsPtr->tcl_UniCharLen) /* 352 */
+#endif
+#ifndef Tcl_UniCharNcmp
+#define Tcl_UniCharNcmp \
+ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */
+#endif
+#ifndef Tcl_UniCharToUtfDString
+#define Tcl_UniCharToUtfDString \
+ (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */
+#endif
+#ifndef Tcl_UtfToUniCharDString
+#define Tcl_UtfToUniCharDString \
+ (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */
+#endif
+#ifndef Tcl_GetRegExpFromObj
+#define Tcl_GetRegExpFromObj \
+ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */
+#endif
+#ifndef Tcl_EvalTokens
+#define Tcl_EvalTokens \
+ (tclStubsPtr->tcl_EvalTokens) /* 357 */
+#endif
+#ifndef Tcl_FreeParse
+#define Tcl_FreeParse \
+ (tclStubsPtr->tcl_FreeParse) /* 358 */
+#endif
+#ifndef Tcl_LogCommandInfo
+#define Tcl_LogCommandInfo \
+ (tclStubsPtr->tcl_LogCommandInfo) /* 359 */
+#endif
+#ifndef Tcl_ParseBraces
+#define Tcl_ParseBraces \
+ (tclStubsPtr->tcl_ParseBraces) /* 360 */
+#endif
+#ifndef Tcl_ParseCommand
+#define Tcl_ParseCommand \
+ (tclStubsPtr->tcl_ParseCommand) /* 361 */
+#endif
+#ifndef Tcl_ParseExpr
+#define Tcl_ParseExpr \
+ (tclStubsPtr->tcl_ParseExpr) /* 362 */
+#endif
+#ifndef Tcl_ParseQuotedString
+#define Tcl_ParseQuotedString \
+ (tclStubsPtr->tcl_ParseQuotedString) /* 363 */
+#endif
+#ifndef Tcl_ParseVarName
+#define Tcl_ParseVarName \
+ (tclStubsPtr->tcl_ParseVarName) /* 364 */
+#endif
+#ifndef Tcl_GetCwd
+#define Tcl_GetCwd \
+ (tclStubsPtr->tcl_GetCwd) /* 365 */
+#endif
+#ifndef Tcl_Chdir
+#define Tcl_Chdir \
+ (tclStubsPtr->tcl_Chdir) /* 366 */
+#endif
+#ifndef Tcl_Access
+#define Tcl_Access \
+ (tclStubsPtr->tcl_Access) /* 367 */
+#endif
+#ifndef Tcl_Stat
+#define Tcl_Stat \
+ (tclStubsPtr->tcl_Stat) /* 368 */
+#endif
+#ifndef Tcl_UtfNcmp
+#define Tcl_UtfNcmp \
+ (tclStubsPtr->tcl_UtfNcmp) /* 369 */
+#endif
+#ifndef Tcl_UtfNcasecmp
+#define Tcl_UtfNcasecmp \
+ (tclStubsPtr->tcl_UtfNcasecmp) /* 370 */
+#endif
+#ifndef Tcl_StringCaseMatch
+#define Tcl_StringCaseMatch \
+ (tclStubsPtr->tcl_StringCaseMatch) /* 371 */
+#endif
+#ifndef Tcl_UniCharIsControl
+#define Tcl_UniCharIsControl \
+ (tclStubsPtr->tcl_UniCharIsControl) /* 372 */
+#endif
+#ifndef Tcl_UniCharIsGraph
+#define Tcl_UniCharIsGraph \
+ (tclStubsPtr->tcl_UniCharIsGraph) /* 373 */
+#endif
+#ifndef Tcl_UniCharIsPrint
+#define Tcl_UniCharIsPrint \
+ (tclStubsPtr->tcl_UniCharIsPrint) /* 374 */
+#endif
+#ifndef Tcl_UniCharIsPunct
+#define Tcl_UniCharIsPunct \
+ (tclStubsPtr->tcl_UniCharIsPunct) /* 375 */
+#endif
+#ifndef Tcl_RegExpExecObj
+#define Tcl_RegExpExecObj \
+ (tclStubsPtr->tcl_RegExpExecObj) /* 376 */
+#endif
+#ifndef Tcl_RegExpGetInfo
+#define Tcl_RegExpGetInfo \
+ (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */
+#endif
+#ifndef Tcl_NewUnicodeObj
+#define Tcl_NewUnicodeObj \
+ (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */
+#endif
+#ifndef Tcl_SetUnicodeObj
+#define Tcl_SetUnicodeObj \
+ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */
+#endif
+#ifndef Tcl_GetCharLength
+#define Tcl_GetCharLength \
+ (tclStubsPtr->tcl_GetCharLength) /* 380 */
+#endif
+#ifndef Tcl_GetUniChar
+#define Tcl_GetUniChar \
+ (tclStubsPtr->tcl_GetUniChar) /* 381 */
+#endif
+#ifndef Tcl_GetUnicode
+#define Tcl_GetUnicode \
+ (tclStubsPtr->tcl_GetUnicode) /* 382 */
+#endif
+#ifndef Tcl_GetRange
+#define Tcl_GetRange \
+ (tclStubsPtr->tcl_GetRange) /* 383 */
+#endif
+#ifndef Tcl_AppendUnicodeToObj
+#define Tcl_AppendUnicodeToObj \
+ (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */
+#endif
+#ifndef Tcl_RegExpMatchObj
+#define Tcl_RegExpMatchObj \
+ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */
+#endif
+#ifndef Tcl_SetNotifier
+#define Tcl_SetNotifier \
+ (tclStubsPtr->tcl_SetNotifier) /* 386 */
+#endif
+#ifndef Tcl_GetAllocMutex
+#define Tcl_GetAllocMutex \
+ (tclStubsPtr->tcl_GetAllocMutex) /* 387 */
+#endif
+#ifndef Tcl_GetChannelNames
+#define Tcl_GetChannelNames \
+ (tclStubsPtr->tcl_GetChannelNames) /* 388 */
+#endif
+#ifndef Tcl_GetChannelNamesEx
+#define Tcl_GetChannelNamesEx \
+ (tclStubsPtr->tcl_GetChannelNamesEx) /* 389 */
+#endif
+#ifndef Tcl_ProcObjCmd
+#define Tcl_ProcObjCmd \
+ (tclStubsPtr->tcl_ProcObjCmd) /* 390 */
+#endif
+#ifndef Tcl_ConditionFinalize
+#define Tcl_ConditionFinalize \
+ (tclStubsPtr->tcl_ConditionFinalize) /* 391 */
+#endif
+#ifndef Tcl_MutexFinalize
+#define Tcl_MutexFinalize \
+ (tclStubsPtr->tcl_MutexFinalize) /* 392 */
+#endif
+#ifndef Tcl_CreateThread
+#define Tcl_CreateThread \
+ (tclStubsPtr->tcl_CreateThread) /* 393 */
+#endif
+#ifndef Tcl_ReadRaw
+#define Tcl_ReadRaw \
+ (tclStubsPtr->tcl_ReadRaw) /* 394 */
+#endif
+#ifndef Tcl_WriteRaw
+#define Tcl_WriteRaw \
+ (tclStubsPtr->tcl_WriteRaw) /* 395 */
+#endif
+#ifndef Tcl_GetTopChannel
+#define Tcl_GetTopChannel \
+ (tclStubsPtr->tcl_GetTopChannel) /* 396 */
+#endif
+#ifndef Tcl_ChannelBuffered
+#define Tcl_ChannelBuffered \
+ (tclStubsPtr->tcl_ChannelBuffered) /* 397 */
+#endif
+#ifndef Tcl_ChannelName
+#define Tcl_ChannelName \
+ (tclStubsPtr->tcl_ChannelName) /* 398 */
+#endif
+#ifndef Tcl_ChannelVersion
+#define Tcl_ChannelVersion \
+ (tclStubsPtr->tcl_ChannelVersion) /* 399 */
+#endif
+#ifndef Tcl_ChannelBlockModeProc
+#define Tcl_ChannelBlockModeProc \
+ (tclStubsPtr->tcl_ChannelBlockModeProc) /* 400 */
+#endif
+#ifndef Tcl_ChannelCloseProc
+#define Tcl_ChannelCloseProc \
+ (tclStubsPtr->tcl_ChannelCloseProc) /* 401 */
+#endif
+#ifndef Tcl_ChannelClose2Proc
+#define Tcl_ChannelClose2Proc \
+ (tclStubsPtr->tcl_ChannelClose2Proc) /* 402 */
+#endif
+#ifndef Tcl_ChannelInputProc
+#define Tcl_ChannelInputProc \
+ (tclStubsPtr->tcl_ChannelInputProc) /* 403 */
+#endif
+#ifndef Tcl_ChannelOutputProc
+#define Tcl_ChannelOutputProc \
+ (tclStubsPtr->tcl_ChannelOutputProc) /* 404 */
+#endif
+#ifndef Tcl_ChannelSeekProc
+#define Tcl_ChannelSeekProc \
+ (tclStubsPtr->tcl_ChannelSeekProc) /* 405 */
+#endif
+#ifndef Tcl_ChannelSetOptionProc
+#define Tcl_ChannelSetOptionProc \
+ (tclStubsPtr->tcl_ChannelSetOptionProc) /* 406 */
+#endif
+#ifndef Tcl_ChannelGetOptionProc
+#define Tcl_ChannelGetOptionProc \
+ (tclStubsPtr->tcl_ChannelGetOptionProc) /* 407 */
+#endif
+#ifndef Tcl_ChannelWatchProc
+#define Tcl_ChannelWatchProc \
+ (tclStubsPtr->tcl_ChannelWatchProc) /* 408 */
+#endif
+#ifndef Tcl_ChannelGetHandleProc
+#define Tcl_ChannelGetHandleProc \
+ (tclStubsPtr->tcl_ChannelGetHandleProc) /* 409 */
+#endif
+#ifndef Tcl_ChannelFlushProc
+#define Tcl_ChannelFlushProc \
+ (tclStubsPtr->tcl_ChannelFlushProc) /* 410 */
+#endif
+#ifndef Tcl_ChannelHandlerProc
+#define Tcl_ChannelHandlerProc \
+ (tclStubsPtr->tcl_ChannelHandlerProc) /* 411 */
+#endif
+#ifndef Tcl_JoinThread
+#define Tcl_JoinThread \
+ (tclStubsPtr->tcl_JoinThread) /* 412 */
+#endif
+#ifndef Tcl_IsChannelShared
+#define Tcl_IsChannelShared \
+ (tclStubsPtr->tcl_IsChannelShared) /* 413 */
+#endif
+#ifndef Tcl_IsChannelRegistered
+#define Tcl_IsChannelRegistered \
+ (tclStubsPtr->tcl_IsChannelRegistered) /* 414 */
+#endif
+#ifndef Tcl_CutChannel
+#define Tcl_CutChannel \
+ (tclStubsPtr->tcl_CutChannel) /* 415 */
+#endif
+#ifndef Tcl_SpliceChannel
+#define Tcl_SpliceChannel \
+ (tclStubsPtr->tcl_SpliceChannel) /* 416 */
+#endif
+#ifndef Tcl_ClearChannelHandlers
+#define Tcl_ClearChannelHandlers \
+ (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */
+#endif
+#ifndef Tcl_IsChannelExisting
+#define Tcl_IsChannelExisting \
+ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */
+#endif
+#ifndef Tcl_UniCharNcasecmp
+#define Tcl_UniCharNcasecmp \
+ (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */
+#endif
+#ifndef Tcl_UniCharCaseMatch
+#define Tcl_UniCharCaseMatch \
+ (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */
+#endif
+#ifndef Tcl_FindHashEntry
+#define Tcl_FindHashEntry \
+ (tclStubsPtr->tcl_FindHashEntry) /* 421 */
+#endif
+#ifndef Tcl_CreateHashEntry
+#define Tcl_CreateHashEntry \
+ (tclStubsPtr->tcl_CreateHashEntry) /* 422 */
+#endif
+#ifndef Tcl_InitCustomHashTable
+#define Tcl_InitCustomHashTable \
+ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */
+#endif
+#ifndef Tcl_InitObjHashTable
+#define Tcl_InitObjHashTable \
+ (tclStubsPtr->tcl_InitObjHashTable) /* 424 */
+#endif
+#ifndef Tcl_CommandTraceInfo
+#define Tcl_CommandTraceInfo \
+ (tclStubsPtr->tcl_CommandTraceInfo) /* 425 */
+#endif
+#ifndef Tcl_TraceCommand
+#define Tcl_TraceCommand \
+ (tclStubsPtr->tcl_TraceCommand) /* 426 */
+#endif
+#ifndef Tcl_UntraceCommand
+#define Tcl_UntraceCommand \
+ (tclStubsPtr->tcl_UntraceCommand) /* 427 */
+#endif
+#ifndef Tcl_AttemptAlloc
+#define Tcl_AttemptAlloc \
+ (tclStubsPtr->tcl_AttemptAlloc) /* 428 */
+#endif
+#ifndef Tcl_AttemptDbCkalloc
+#define Tcl_AttemptDbCkalloc \
+ (tclStubsPtr->tcl_AttemptDbCkalloc) /* 429 */
+#endif
+#ifndef Tcl_AttemptRealloc
+#define Tcl_AttemptRealloc \
+ (tclStubsPtr->tcl_AttemptRealloc) /* 430 */
+#endif
+#ifndef Tcl_AttemptDbCkrealloc
+#define Tcl_AttemptDbCkrealloc \
+ (tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */
+#endif
+#ifndef Tcl_AttemptSetObjLength
+#define Tcl_AttemptSetObjLength \
+ (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */
+#endif
+#ifndef Tcl_GetChannelThread
+#define Tcl_GetChannelThread \
+ (tclStubsPtr->tcl_GetChannelThread) /* 433 */
+#endif
+#ifndef Tcl_GetUnicodeFromObj
+#define Tcl_GetUnicodeFromObj \
+ (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */
+#endif
+#ifndef Tcl_GetMathFuncInfo
+#define Tcl_GetMathFuncInfo \
+ (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */
+#endif
+#ifndef Tcl_ListMathFuncs
+#define Tcl_ListMathFuncs \
+ (tclStubsPtr->tcl_ListMathFuncs) /* 436 */
+#endif
+#ifndef Tcl_SubstObj
+#define Tcl_SubstObj \
+ (tclStubsPtr->tcl_SubstObj) /* 437 */
+#endif
+#ifndef Tcl_DetachChannel
+#define Tcl_DetachChannel \
+ (tclStubsPtr->tcl_DetachChannel) /* 438 */
+#endif
+#ifndef Tcl_IsStandardChannel
+#define Tcl_IsStandardChannel \
+ (tclStubsPtr->tcl_IsStandardChannel) /* 439 */
+#endif
+#ifndef Tcl_FSCopyFile
+#define Tcl_FSCopyFile \
+ (tclStubsPtr->tcl_FSCopyFile) /* 440 */
+#endif
+#ifndef Tcl_FSCopyDirectory
+#define Tcl_FSCopyDirectory \
+ (tclStubsPtr->tcl_FSCopyDirectory) /* 441 */
+#endif
+#ifndef Tcl_FSCreateDirectory
+#define Tcl_FSCreateDirectory \
+ (tclStubsPtr->tcl_FSCreateDirectory) /* 442 */
+#endif
+#ifndef Tcl_FSDeleteFile
+#define Tcl_FSDeleteFile \
+ (tclStubsPtr->tcl_FSDeleteFile) /* 443 */
+#endif
+#ifndef Tcl_FSLoadFile
+#define Tcl_FSLoadFile \
+ (tclStubsPtr->tcl_FSLoadFile) /* 444 */
+#endif
+#ifndef Tcl_FSMatchInDirectory
+#define Tcl_FSMatchInDirectory \
+ (tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */
+#endif
+#ifndef Tcl_FSLink
+#define Tcl_FSLink \
+ (tclStubsPtr->tcl_FSLink) /* 446 */
+#endif
+#ifndef Tcl_FSRemoveDirectory
+#define Tcl_FSRemoveDirectory \
+ (tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */
+#endif
+#ifndef Tcl_FSRenameFile
+#define Tcl_FSRenameFile \
+ (tclStubsPtr->tcl_FSRenameFile) /* 448 */
+#endif
+#ifndef Tcl_FSLstat
+#define Tcl_FSLstat \
+ (tclStubsPtr->tcl_FSLstat) /* 449 */
+#endif
+#ifndef Tcl_FSUtime
+#define Tcl_FSUtime \
+ (tclStubsPtr->tcl_FSUtime) /* 450 */
+#endif
+#ifndef Tcl_FSFileAttrsGet
+#define Tcl_FSFileAttrsGet \
+ (tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */
+#endif
+#ifndef Tcl_FSFileAttrsSet
+#define Tcl_FSFileAttrsSet \
+ (tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */
+#endif
+#ifndef Tcl_FSFileAttrStrings
+#define Tcl_FSFileAttrStrings \
+ (tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */
+#endif
+#ifndef Tcl_FSStat
+#define Tcl_FSStat \
+ (tclStubsPtr->tcl_FSStat) /* 454 */
+#endif
+#ifndef Tcl_FSAccess
+#define Tcl_FSAccess \
+ (tclStubsPtr->tcl_FSAccess) /* 455 */
+#endif
+#ifndef Tcl_FSOpenFileChannel
+#define Tcl_FSOpenFileChannel \
+ (tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */
+#endif
+#ifndef Tcl_FSGetCwd
+#define Tcl_FSGetCwd \
+ (tclStubsPtr->tcl_FSGetCwd) /* 457 */
+#endif
+#ifndef Tcl_FSChdir
+#define Tcl_FSChdir \
+ (tclStubsPtr->tcl_FSChdir) /* 458 */
+#endif
+#ifndef Tcl_FSConvertToPathType
+#define Tcl_FSConvertToPathType \
+ (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */
+#endif
+#ifndef Tcl_FSJoinPath
+#define Tcl_FSJoinPath \
+ (tclStubsPtr->tcl_FSJoinPath) /* 460 */
+#endif
+#ifndef Tcl_FSSplitPath
+#define Tcl_FSSplitPath \
+ (tclStubsPtr->tcl_FSSplitPath) /* 461 */
+#endif
+#ifndef Tcl_FSEqualPaths
+#define Tcl_FSEqualPaths \
+ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */
+#endif
+#ifndef Tcl_FSGetNormalizedPath
+#define Tcl_FSGetNormalizedPath \
+ (tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */
+#endif
+#ifndef Tcl_FSJoinToPath
+#define Tcl_FSJoinToPath \
+ (tclStubsPtr->tcl_FSJoinToPath) /* 464 */
+#endif
+#ifndef Tcl_FSGetInternalRep
+#define Tcl_FSGetInternalRep \
+ (tclStubsPtr->tcl_FSGetInternalRep) /* 465 */
+#endif
+#ifndef Tcl_FSGetTranslatedPath
+#define Tcl_FSGetTranslatedPath \
+ (tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */
+#endif
+#ifndef Tcl_FSEvalFile
+#define Tcl_FSEvalFile \
+ (tclStubsPtr->tcl_FSEvalFile) /* 467 */
+#endif
+#ifndef Tcl_FSNewNativePath
+#define Tcl_FSNewNativePath \
+ (tclStubsPtr->tcl_FSNewNativePath) /* 468 */
+#endif
+#ifndef Tcl_FSGetNativePath
+#define Tcl_FSGetNativePath \
+ (tclStubsPtr->tcl_FSGetNativePath) /* 469 */
+#endif
+#ifndef Tcl_FSFileSystemInfo
+#define Tcl_FSFileSystemInfo \
+ (tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */
+#endif
+#ifndef Tcl_FSPathSeparator
+#define Tcl_FSPathSeparator \
+ (tclStubsPtr->tcl_FSPathSeparator) /* 471 */
+#endif
+#ifndef Tcl_FSListVolumes
+#define Tcl_FSListVolumes \
+ (tclStubsPtr->tcl_FSListVolumes) /* 472 */
+#endif
+#ifndef Tcl_FSRegister
+#define Tcl_FSRegister \
+ (tclStubsPtr->tcl_FSRegister) /* 473 */
+#endif
+#ifndef Tcl_FSUnregister
+#define Tcl_FSUnregister \
+ (tclStubsPtr->tcl_FSUnregister) /* 474 */
+#endif
+#ifndef Tcl_FSData
+#define Tcl_FSData \
+ (tclStubsPtr->tcl_FSData) /* 475 */
+#endif
+#ifndef Tcl_FSGetTranslatedStringPath
+#define Tcl_FSGetTranslatedStringPath \
+ (tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */
+#endif
+#ifndef Tcl_FSGetFileSystemForPath
+#define Tcl_FSGetFileSystemForPath \
+ (tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */
+#endif
+#ifndef Tcl_FSGetPathType
+#define Tcl_FSGetPathType \
+ (tclStubsPtr->tcl_FSGetPathType) /* 478 */
+#endif
+#ifndef Tcl_OutputBuffered
+#define Tcl_OutputBuffered \
+ (tclStubsPtr->tcl_OutputBuffered) /* 479 */
+#endif
+#ifndef Tcl_FSMountsChanged
+#define Tcl_FSMountsChanged \
+ (tclStubsPtr->tcl_FSMountsChanged) /* 480 */
+#endif
+#ifndef Tcl_EvalTokensStandard
+#define Tcl_EvalTokensStandard \
+ (tclStubsPtr->tcl_EvalTokensStandard) /* 481 */
+#endif
+#ifndef Tcl_GetTime
+#define Tcl_GetTime \
+ (tclStubsPtr->tcl_GetTime) /* 482 */
+#endif
+#ifndef Tcl_CreateObjTrace
+#define Tcl_CreateObjTrace \
+ (tclStubsPtr->tcl_CreateObjTrace) /* 483 */
+#endif
+#ifndef Tcl_GetCommandInfoFromToken
+#define Tcl_GetCommandInfoFromToken \
+ (tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */
+#endif
+#ifndef Tcl_SetCommandInfoFromToken
+#define Tcl_SetCommandInfoFromToken \
+ (tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */
+#endif
+#ifndef Tcl_DbNewWideIntObj
+#define Tcl_DbNewWideIntObj \
+ (tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */
+#endif
+#ifndef Tcl_GetWideIntFromObj
+#define Tcl_GetWideIntFromObj \
+ (tclStubsPtr->tcl_GetWideIntFromObj) /* 487 */
+#endif
+#ifndef Tcl_NewWideIntObj
+#define Tcl_NewWideIntObj \
+ (tclStubsPtr->tcl_NewWideIntObj) /* 488 */
+#endif
+#ifndef Tcl_SetWideIntObj
+#define Tcl_SetWideIntObj \
+ (tclStubsPtr->tcl_SetWideIntObj) /* 489 */
+#endif
+#ifndef Tcl_AllocStatBuf
+#define Tcl_AllocStatBuf \
+ (tclStubsPtr->tcl_AllocStatBuf) /* 490 */
+#endif
+#ifndef Tcl_Seek
+#define Tcl_Seek \
+ (tclStubsPtr->tcl_Seek) /* 491 */
+#endif
+#ifndef Tcl_Tell
+#define Tcl_Tell \
+ (tclStubsPtr->tcl_Tell) /* 492 */
+#endif
+#ifndef Tcl_ChannelWideSeekProc
+#define Tcl_ChannelWideSeekProc \
+ (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */
+#endif
+
+#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#endif /* _TCLDECLS */
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.m
new file mode 100755
index 00000000000..bc3a0953890
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.m
@@ -0,0 +1,538 @@
+#ifndef _TCLDECLS_VM
+#define _TCLDECLS_VM
+#include "tclDecls_f.h"
+#ifndef NO_VTABLES
+#ifndef Tcl_AddErrorInfo
+# define Tcl_AddErrorInfo (*TcldeclsVptr->V_Tcl_AddErrorInfo)
+#endif
+
+#ifndef Tcl_AllowExceptions
+# define Tcl_AllowExceptions (*TcldeclsVptr->V_Tcl_AllowExceptions)
+#endif
+
+#ifndef Tcl_AppendElement
+# define Tcl_AppendElement (*TcldeclsVptr->V_Tcl_AppendElement)
+#endif
+
+#ifndef Tcl_AppendObjToObj
+# define Tcl_AppendObjToObj (*TcldeclsVptr->V_Tcl_AppendObjToObj)
+#endif
+
+#ifndef Tcl_AppendResult
+# define Tcl_AppendResult (*TcldeclsVptr->V_Tcl_AppendResult)
+#endif
+
+#ifndef Tcl_AppendStringsToObj
+# define Tcl_AppendStringsToObj (*TcldeclsVptr->V_Tcl_AppendStringsToObj)
+#endif
+
+#ifndef Tcl_AppendToObj
+# define Tcl_AppendToObj (*TcldeclsVptr->V_Tcl_AppendToObj)
+#endif
+
+#ifndef Tcl_BackgroundError
+# define Tcl_BackgroundError (*TcldeclsVptr->V_Tcl_BackgroundError)
+#endif
+
+#ifndef Tcl_CallWhenDeleted
+# define Tcl_CallWhenDeleted (*TcldeclsVptr->V_Tcl_CallWhenDeleted)
+#endif
+
+#ifndef Tcl_CancelIdleCall
+# define Tcl_CancelIdleCall (*TcldeclsVptr->V_Tcl_CancelIdleCall)
+#endif
+
+#ifndef Tcl_Close
+# define Tcl_Close (*TcldeclsVptr->V_Tcl_Close)
+#endif
+
+#ifndef Tcl_ConcatObj
+# define Tcl_ConcatObj (*TcldeclsVptr->V_Tcl_ConcatObj)
+#endif
+
+#ifndef Tcl_CreateEventSource
+# define Tcl_CreateEventSource (*TcldeclsVptr->V_Tcl_CreateEventSource)
+#endif
+
+#ifndef Tcl_CreateExitHandler
+# define Tcl_CreateExitHandler (*TcldeclsVptr->V_Tcl_CreateExitHandler)
+#endif
+
+#ifndef Tcl_CreateFileHandler
+# define Tcl_CreateFileHandler (*TcldeclsVptr->V_Tcl_CreateFileHandler)
+#endif
+
+#ifndef Tcl_CreateInterp
+# define Tcl_CreateInterp (*TcldeclsVptr->V_Tcl_CreateInterp)
+#endif
+
+#ifndef Tcl_CreateObjCommand
+# define Tcl_CreateObjCommand (*TcldeclsVptr->V_Tcl_CreateObjCommand)
+#endif
+
+#ifndef Tcl_CreateTimerHandler
+# define Tcl_CreateTimerHandler (*TcldeclsVptr->V_Tcl_CreateTimerHandler)
+#endif
+
+#ifndef Tcl_DStringAppend
+# define Tcl_DStringAppend (*TcldeclsVptr->V_Tcl_DStringAppend)
+#endif
+
+#ifndef Tcl_DStringAppendElement
+# define Tcl_DStringAppendElement (*TcldeclsVptr->V_Tcl_DStringAppendElement)
+#endif
+
+#ifndef Tcl_DStringFree
+# define Tcl_DStringFree (*TcldeclsVptr->V_Tcl_DStringFree)
+#endif
+
+#ifndef Tcl_DStringInit
+# define Tcl_DStringInit (*TcldeclsVptr->V_Tcl_DStringInit)
+#endif
+
+#ifndef Tcl_DStringResult
+# define Tcl_DStringResult (*TcldeclsVptr->V_Tcl_DStringResult)
+#endif
+
+#ifndef Tcl_DStringSetLength
+# define Tcl_DStringSetLength (*TcldeclsVptr->V_Tcl_DStringSetLength)
+#endif
+
+#ifndef Tcl_DeleteEventSource
+# define Tcl_DeleteEventSource (*TcldeclsVptr->V_Tcl_DeleteEventSource)
+#endif
+
+#ifndef Tcl_DeleteFileHandler
+# define Tcl_DeleteFileHandler (*TcldeclsVptr->V_Tcl_DeleteFileHandler)
+#endif
+
+#ifndef Tcl_DeleteHashEntry
+# define Tcl_DeleteHashEntry (*TcldeclsVptr->V_Tcl_DeleteHashEntry)
+#endif
+
+#ifndef Tcl_DeleteHashTable
+# define Tcl_DeleteHashTable (*TcldeclsVptr->V_Tcl_DeleteHashTable)
+#endif
+
+#ifndef Tcl_DeleteInterp
+# define Tcl_DeleteInterp (*TcldeclsVptr->V_Tcl_DeleteInterp)
+#endif
+
+#ifndef Tcl_DeleteTimerHandler
+# define Tcl_DeleteTimerHandler (*TcldeclsVptr->V_Tcl_DeleteTimerHandler)
+#endif
+
+#ifndef Tcl_DoOneEvent
+# define Tcl_DoOneEvent (*TcldeclsVptr->V_Tcl_DoOneEvent)
+#endif
+
+#ifndef Tcl_DoWhenIdle
+# define Tcl_DoWhenIdle (*TcldeclsVptr->V_Tcl_DoWhenIdle)
+#endif
+
+#ifndef Tcl_DuplicateObj
+# define Tcl_DuplicateObj (*TcldeclsVptr->V_Tcl_DuplicateObj)
+#endif
+
+#ifndef Tcl_Eof
+# define Tcl_Eof (*TcldeclsVptr->V_Tcl_Eof)
+#endif
+
+#ifndef Tcl_EvalObjEx
+# define Tcl_EvalObjEx (*TcldeclsVptr->V_Tcl_EvalObjEx)
+#endif
+
+#ifndef Tcl_EvalObjv
+# define Tcl_EvalObjv (*TcldeclsVptr->V_Tcl_EvalObjv)
+#endif
+
+#ifndef Tcl_EventuallyFree
+# define Tcl_EventuallyFree (*TcldeclsVptr->V_Tcl_EventuallyFree)
+#endif
+
+#ifndef Tcl_ExternalToUtf
+# define Tcl_ExternalToUtf (*TcldeclsVptr->V_Tcl_ExternalToUtf)
+#endif
+
+#ifndef Tcl_ExternalToUtfDString
+# define Tcl_ExternalToUtfDString (*TcldeclsVptr->V_Tcl_ExternalToUtfDString)
+#endif
+
+#ifndef Tcl_FirstHashEntry
+# define Tcl_FirstHashEntry (*TcldeclsVptr->V_Tcl_FirstHashEntry)
+#endif
+
+#ifndef Tcl_FreeEncoding
+# define Tcl_FreeEncoding (*TcldeclsVptr->V_Tcl_FreeEncoding)
+#endif
+
+#ifndef Tcl_GetAssocData
+# define Tcl_GetAssocData (*TcldeclsVptr->V_Tcl_GetAssocData)
+#endif
+
+#ifndef Tcl_GetBooleanFromObj
+# define Tcl_GetBooleanFromObj (*TcldeclsVptr->V_Tcl_GetBooleanFromObj)
+#endif
+
+#ifndef Tcl_GetChannel
+# define Tcl_GetChannel (*TcldeclsVptr->V_Tcl_GetChannel)
+#endif
+
+#ifndef Tcl_GetCommandInfo
+# define Tcl_GetCommandInfo (*TcldeclsVptr->V_Tcl_GetCommandInfo)
+#endif
+
+#ifndef Tcl_GetDouble
+# define Tcl_GetDouble (*TcldeclsVptr->V_Tcl_GetDouble)
+#endif
+
+#ifndef Tcl_GetDoubleFromObj
+# define Tcl_GetDoubleFromObj (*TcldeclsVptr->V_Tcl_GetDoubleFromObj)
+#endif
+
+#ifndef Tcl_GetEncoding
+# define Tcl_GetEncoding (*TcldeclsVptr->V_Tcl_GetEncoding)
+#endif
+
+#ifndef Tcl_GetEncodingName
+# define Tcl_GetEncodingName (*TcldeclsVptr->V_Tcl_GetEncodingName)
+#endif
+
+#ifndef Tcl_GetIndexFromObj
+# define Tcl_GetIndexFromObj (*TcldeclsVptr->V_Tcl_GetIndexFromObj)
+#endif
+
+#ifndef Tcl_GetInt
+# define Tcl_GetInt (*TcldeclsVptr->V_Tcl_GetInt)
+#endif
+
+#ifndef Tcl_GetIntFromObj
+# define Tcl_GetIntFromObj (*TcldeclsVptr->V_Tcl_GetIntFromObj)
+#endif
+
+#ifndef Tcl_GetLongFromObj
+# define Tcl_GetLongFromObj (*TcldeclsVptr->V_Tcl_GetLongFromObj)
+#endif
+
+#ifndef Tcl_GetObjResult
+# define Tcl_GetObjResult (*TcldeclsVptr->V_Tcl_GetObjResult)
+#endif
+
+#ifndef Tcl_GetObjType
+# define Tcl_GetObjType (*TcldeclsVptr->V_Tcl_GetObjType)
+#endif
+
+#ifndef Tcl_GetRegExpFromObj
+# define Tcl_GetRegExpFromObj (*TcldeclsVptr->V_Tcl_GetRegExpFromObj)
+#endif
+
+#ifndef Tcl_GetStdChannel
+# define Tcl_GetStdChannel (*TcldeclsVptr->V_Tcl_GetStdChannel)
+#endif
+
+#ifndef Tcl_GetString
+# define Tcl_GetString (*TcldeclsVptr->V_Tcl_GetString)
+#endif
+
+#ifndef Tcl_GetStringFromObj
+# define Tcl_GetStringFromObj (*TcldeclsVptr->V_Tcl_GetStringFromObj)
+#endif
+
+#ifndef Tcl_GetStringResult
+# define Tcl_GetStringResult (*TcldeclsVptr->V_Tcl_GetStringResult)
+#endif
+
+#ifndef Tcl_GetThreadData
+# define Tcl_GetThreadData (*TcldeclsVptr->V_Tcl_GetThreadData)
+#endif
+
+#ifndef Tcl_GetTime
+# define Tcl_GetTime (*TcldeclsVptr->V_Tcl_GetTime)
+#endif
+
+#ifndef Tcl_GetVar
+# define Tcl_GetVar (*TcldeclsVptr->V_Tcl_GetVar)
+#endif
+
+#ifndef Tcl_GetVar2
+# define Tcl_GetVar2 (*TcldeclsVptr->V_Tcl_GetVar2)
+#endif
+
+#ifndef Tcl_GetVar2Ex
+# define Tcl_GetVar2Ex (*TcldeclsVptr->V_Tcl_GetVar2Ex)
+#endif
+
+#ifndef Tcl_GlobalEval
+# define Tcl_GlobalEval (*TcldeclsVptr->V_Tcl_GlobalEval)
+#endif
+
+#ifndef Tcl_HideCommand
+# define Tcl_HideCommand (*TcldeclsVptr->V_Tcl_HideCommand)
+#endif
+
+#ifndef Tcl_InitHashTable
+# define Tcl_InitHashTable (*TcldeclsVptr->V_Tcl_InitHashTable)
+#endif
+
+#ifndef Tcl_IsSafe
+# define Tcl_IsSafe (*TcldeclsVptr->V_Tcl_IsSafe)
+#endif
+
+#ifndef Tcl_LinkVar
+# define Tcl_LinkVar (*TcldeclsVptr->V_Tcl_LinkVar)
+#endif
+
+#ifndef Tcl_ListObjAppendElement
+# define Tcl_ListObjAppendElement (*TcldeclsVptr->V_Tcl_ListObjAppendElement)
+#endif
+
+#ifndef Tcl_ListObjGetElements
+# define Tcl_ListObjGetElements (*TcldeclsVptr->V_Tcl_ListObjGetElements)
+#endif
+
+#ifndef Tcl_ListObjIndex
+# define Tcl_ListObjIndex (*TcldeclsVptr->V_Tcl_ListObjIndex)
+#endif
+
+#ifndef Tcl_ListObjLength
+# define Tcl_ListObjLength (*TcldeclsVptr->V_Tcl_ListObjLength)
+#endif
+
+#ifndef Tcl_ListObjReplace
+# define Tcl_ListObjReplace (*TcldeclsVptr->V_Tcl_ListObjReplace)
+#endif
+
+#ifndef Tcl_NewBooleanObj
+# define Tcl_NewBooleanObj (*TcldeclsVptr->V_Tcl_NewBooleanObj)
+#endif
+
+#ifndef Tcl_NewDoubleObj
+# define Tcl_NewDoubleObj (*TcldeclsVptr->V_Tcl_NewDoubleObj)
+#endif
+
+#ifndef Tcl_NewIntObj
+# define Tcl_NewIntObj (*TcldeclsVptr->V_Tcl_NewIntObj)
+#endif
+
+#ifndef Tcl_NewListObj
+# define Tcl_NewListObj (*TcldeclsVptr->V_Tcl_NewListObj)
+#endif
+
+#ifndef Tcl_NewLongObj
+# define Tcl_NewLongObj (*TcldeclsVptr->V_Tcl_NewLongObj)
+#endif
+
+#ifndef Tcl_NewObj
+# define Tcl_NewObj (*TcldeclsVptr->V_Tcl_NewObj)
+#endif
+
+#ifndef Tcl_NewStringObj
+# define Tcl_NewStringObj (*TcldeclsVptr->V_Tcl_NewStringObj)
+#endif
+
+#ifndef Tcl_NextHashEntry
+# define Tcl_NextHashEntry (*TcldeclsVptr->V_Tcl_NextHashEntry)
+#endif
+
+#ifndef Tcl_NumUtfChars
+# define Tcl_NumUtfChars (*TcldeclsVptr->V_Tcl_NumUtfChars)
+#endif
+
+#ifndef Tcl_ObjGetVar2
+# define Tcl_ObjGetVar2 (*TcldeclsVptr->V_Tcl_ObjGetVar2)
+#endif
+
+#ifndef Tcl_ObjSetVar2
+# define Tcl_ObjSetVar2 (*TcldeclsVptr->V_Tcl_ObjSetVar2)
+#endif
+
+#ifndef Tcl_OpenFileChannel
+# define Tcl_OpenFileChannel (*TcldeclsVptr->V_Tcl_OpenFileChannel)
+#endif
+
+#ifndef Tcl_Panic
+# define Tcl_Panic (*TcldeclsVptr->V_Tcl_Panic)
+#endif
+
+#ifndef Tcl_PosixError
+# define Tcl_PosixError (*TcldeclsVptr->V_Tcl_PosixError)
+#endif
+
+#ifndef Tcl_Preserve
+# define Tcl_Preserve (*TcldeclsVptr->V_Tcl_Preserve)
+#endif
+
+#ifndef Tcl_Read
+# define Tcl_Read (*TcldeclsVptr->V_Tcl_Read)
+#endif
+
+#ifndef Tcl_RegExpExec
+# define Tcl_RegExpExec (*TcldeclsVptr->V_Tcl_RegExpExec)
+#endif
+
+#ifndef Tcl_RegExpRange
+# define Tcl_RegExpRange (*TcldeclsVptr->V_Tcl_RegExpRange)
+#endif
+
+#ifndef Tcl_Release
+# define Tcl_Release (*TcldeclsVptr->V_Tcl_Release)
+#endif
+
+#ifndef Tcl_ResetResult
+# define Tcl_ResetResult (*TcldeclsVptr->V_Tcl_ResetResult)
+#endif
+
+#ifndef Tcl_Seek
+# define Tcl_Seek (*TcldeclsVptr->V_Tcl_Seek)
+#endif
+
+#ifndef Tcl_ServiceEvent
+# define Tcl_ServiceEvent (*TcldeclsVptr->V_Tcl_ServiceEvent)
+#endif
+
+#ifndef Tcl_SetAssocData
+# define Tcl_SetAssocData (*TcldeclsVptr->V_Tcl_SetAssocData)
+#endif
+
+#ifndef Tcl_SetBooleanObj
+# define Tcl_SetBooleanObj (*TcldeclsVptr->V_Tcl_SetBooleanObj)
+#endif
+
+#ifndef Tcl_SetChannelOption
+# define Tcl_SetChannelOption (*TcldeclsVptr->V_Tcl_SetChannelOption)
+#endif
+
+#ifndef Tcl_SetCommandInfo
+# define Tcl_SetCommandInfo (*TcldeclsVptr->V_Tcl_SetCommandInfo)
+#endif
+
+#ifndef Tcl_SetDoubleObj
+# define Tcl_SetDoubleObj (*TcldeclsVptr->V_Tcl_SetDoubleObj)
+#endif
+
+#ifndef Tcl_SetIntObj
+# define Tcl_SetIntObj (*TcldeclsVptr->V_Tcl_SetIntObj)
+#endif
+
+#ifndef Tcl_SetListObj
+# define Tcl_SetListObj (*TcldeclsVptr->V_Tcl_SetListObj)
+#endif
+
+#ifndef Tcl_SetLongObj
+# define Tcl_SetLongObj (*TcldeclsVptr->V_Tcl_SetLongObj)
+#endif
+
+#ifndef Tcl_SetMaxBlockTime
+# define Tcl_SetMaxBlockTime (*TcldeclsVptr->V_Tcl_SetMaxBlockTime)
+#endif
+
+#ifndef Tcl_SetObjErrorCode
+# define Tcl_SetObjErrorCode (*TcldeclsVptr->V_Tcl_SetObjErrorCode)
+#endif
+
+#ifndef Tcl_SetObjResult
+# define Tcl_SetObjResult (*TcldeclsVptr->V_Tcl_SetObjResult)
+#endif
+
+#ifndef Tcl_SetResult
+# define Tcl_SetResult (*TcldeclsVptr->V_Tcl_SetResult)
+#endif
+
+#ifndef Tcl_SetStringObj
+# define Tcl_SetStringObj (*TcldeclsVptr->V_Tcl_SetStringObj)
+#endif
+
+#ifndef Tcl_SetVar
+# define Tcl_SetVar (*TcldeclsVptr->V_Tcl_SetVar)
+#endif
+
+#ifndef Tcl_Sleep
+# define Tcl_Sleep (*TcldeclsVptr->V_Tcl_Sleep)
+#endif
+
+#ifndef Tcl_StringMatch
+# define Tcl_StringMatch (*TcldeclsVptr->V_Tcl_StringMatch)
+#endif
+
+#ifndef Tcl_TranslateFileName
+# define Tcl_TranslateFileName (*TcldeclsVptr->V_Tcl_TranslateFileName)
+#endif
+
+#ifndef Tcl_UniCharIsAlpha
+# define Tcl_UniCharIsAlpha (*TcldeclsVptr->V_Tcl_UniCharIsAlpha)
+#endif
+
+#ifndef Tcl_UniCharIsSpace
+# define Tcl_UniCharIsSpace (*TcldeclsVptr->V_Tcl_UniCharIsSpace)
+#endif
+
+#ifndef Tcl_UniCharIsUpper
+# define Tcl_UniCharIsUpper (*TcldeclsVptr->V_Tcl_UniCharIsUpper)
+#endif
+
+#ifndef Tcl_UniCharIsWordChar
+# define Tcl_UniCharIsWordChar (*TcldeclsVptr->V_Tcl_UniCharIsWordChar)
+#endif
+
+#ifndef Tcl_UniCharToLower
+# define Tcl_UniCharToLower (*TcldeclsVptr->V_Tcl_UniCharToLower)
+#endif
+
+#ifndef Tcl_UniCharToUpper
+# define Tcl_UniCharToUpper (*TcldeclsVptr->V_Tcl_UniCharToUpper)
+#endif
+
+#ifndef Tcl_UniCharToUtf
+# define Tcl_UniCharToUtf (*TcldeclsVptr->V_Tcl_UniCharToUtf)
+#endif
+
+#ifndef Tcl_UnlinkVar
+# define Tcl_UnlinkVar (*TcldeclsVptr->V_Tcl_UnlinkVar)
+#endif
+
+#ifndef Tcl_UtfAtIndex
+# define Tcl_UtfAtIndex (*TcldeclsVptr->V_Tcl_UtfAtIndex)
+#endif
+
+#ifndef Tcl_UtfCharComplete
+# define Tcl_UtfCharComplete (*TcldeclsVptr->V_Tcl_UtfCharComplete)
+#endif
+
+#ifndef Tcl_UtfNext
+# define Tcl_UtfNext (*TcldeclsVptr->V_Tcl_UtfNext)
+#endif
+
+#ifndef Tcl_UtfPrev
+# define Tcl_UtfPrev (*TcldeclsVptr->V_Tcl_UtfPrev)
+#endif
+
+#ifndef Tcl_UtfToExternal
+# define Tcl_UtfToExternal (*TcldeclsVptr->V_Tcl_UtfToExternal)
+#endif
+
+#ifndef Tcl_UtfToExternalDString
+# define Tcl_UtfToExternalDString (*TcldeclsVptr->V_Tcl_UtfToExternalDString)
+#endif
+
+#ifndef Tcl_UtfToLower
+# define Tcl_UtfToLower (*TcldeclsVptr->V_Tcl_UtfToLower)
+#endif
+
+#ifndef Tcl_UtfToUniChar
+# define Tcl_UtfToUniChar (*TcldeclsVptr->V_Tcl_UtfToUniChar)
+#endif
+
+#ifndef Tcl_Write
+# define Tcl_Write (*TcldeclsVptr->V_Tcl_Write)
+#endif
+
+#ifndef Tcl_WriteChars
+# define Tcl_WriteChars (*TcldeclsVptr->V_Tcl_WriteChars)
+#endif
+
+#ifndef Tcl_WrongNumArgs
+# define Tcl_WrongNumArgs (*TcldeclsVptr->V_Tcl_WrongNumArgs)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TCLDECLS_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.t
new file mode 100755
index 00000000000..e54ecbb64ed
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls.t
@@ -0,0 +1,675 @@
+#ifdef _TCLDECLS
+#ifndef Tcl_AddErrorInfo
+VFUNC(void,Tcl_AddErrorInfo,V_Tcl_AddErrorInfo,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * message)))
+#endif /* #ifndef Tcl_AddErrorInfo */
+
+#ifndef Tcl_AllowExceptions
+VFUNC(void,Tcl_AllowExceptions,V_Tcl_AllowExceptions,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_AllowExceptions */
+
+#ifndef Tcl_AppendElement
+VFUNC(void,Tcl_AppendElement,V_Tcl_AppendElement,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * string)))
+#endif /* #ifndef Tcl_AppendElement */
+
+#ifndef Tcl_AppendObjToObj
+VFUNC(void,Tcl_AppendObjToObj,V_Tcl_AppendObjToObj,_ANSI_ARGS_((Tcl_Obj * objPtr,
+ Tcl_Obj * appendObjPtr)))
+#endif /* #ifndef Tcl_AppendObjToObj */
+
+#ifndef Tcl_AppendResult
+VFUNC(void,Tcl_AppendResult,V_Tcl_AppendResult,_ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)))
+#endif /* #ifndef Tcl_AppendResult */
+
+#ifndef Tcl_AppendStringsToObj
+VFUNC(void,Tcl_AppendStringsToObj,V_Tcl_AppendStringsToObj,_ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)))
+#endif /* #ifndef Tcl_AppendStringsToObj */
+
+#ifndef Tcl_AppendToObj
+VFUNC(void,Tcl_AppendToObj,V_Tcl_AppendToObj,_ANSI_ARGS_((Tcl_Obj* objPtr,
+ CONST char* bytes, int length)))
+#endif /* #ifndef Tcl_AppendToObj */
+
+#ifndef Tcl_BackgroundError
+VFUNC(void,Tcl_BackgroundError,V_Tcl_BackgroundError,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_BackgroundError */
+
+#ifndef Tcl_CallWhenDeleted
+VFUNC(void,Tcl_CallWhenDeleted,V_Tcl_CallWhenDeleted,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_InterpDeleteProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_CallWhenDeleted */
+
+#ifndef Tcl_CancelIdleCall
+VFUNC(void,Tcl_CancelIdleCall,V_Tcl_CancelIdleCall,_ANSI_ARGS_((
+ Tcl_IdleProc * idleProc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_CancelIdleCall */
+
+#ifndef Tcl_Close
+VFUNC(int,Tcl_Close,V_Tcl_Close,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel chan)))
+#endif /* #ifndef Tcl_Close */
+
+#ifndef Tcl_ConcatObj
+VFUNC(Tcl_Obj *,Tcl_ConcatObj,V_Tcl_ConcatObj,_ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tcl_ConcatObj */
+
+#ifndef Tcl_CreateEventSource
+VFUNC(void,Tcl_CreateEventSource,V_Tcl_CreateEventSource,_ANSI_ARGS_((
+ Tcl_EventSetupProc * setupProc,
+ Tcl_EventCheckProc * checkProc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_CreateEventSource */
+
+#ifndef Tcl_CreateExitHandler
+VFUNC(void,Tcl_CreateExitHandler,V_Tcl_CreateExitHandler,_ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData)))
+#endif /* #ifndef Tcl_CreateExitHandler */
+
+#ifndef Tcl_CreateFileHandler
+#if !defined(__WIN32__) && !defined(MAC_TCL)
+VFUNC(void,Tcl_CreateFileHandler,V_Tcl_CreateFileHandler,_ANSI_ARGS_((int fd, int mask,
+ Tcl_FileProc * proc, ClientData clientData)))
+#endif /* #if !defined(__WIN32__) && !defined(MAC_TCL) */
+#endif /* #ifndef Tcl_CreateFileHandler */
+
+#ifndef Tcl_CreateInterp
+VFUNC(Tcl_Interp *,Tcl_CreateInterp,V_Tcl_CreateInterp,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_CreateInterp */
+
+#ifndef Tcl_CreateObjCommand
+VFUNC(Tcl_Command,Tcl_CreateObjCommand,V_Tcl_CreateObjCommand,_ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * cmdName,
+ Tcl_ObjCmdProc * proc, ClientData clientData,
+ Tcl_CmdDeleteProc * deleteProc)))
+#endif /* #ifndef Tcl_CreateObjCommand */
+
+#ifndef Tcl_CreateTimerHandler
+VFUNC(Tcl_TimerToken,Tcl_CreateTimerHandler,V_Tcl_CreateTimerHandler,_ANSI_ARGS_((int milliseconds,
+ Tcl_TimerProc * proc, ClientData clientData)))
+#endif /* #ifndef Tcl_CreateTimerHandler */
+
+#ifndef Tcl_DStringAppend
+VFUNC(char *,Tcl_DStringAppend,V_Tcl_DStringAppend,_ANSI_ARGS_((Tcl_DString * dsPtr,
+ CONST char * str, int length)))
+#endif /* #ifndef Tcl_DStringAppend */
+
+#ifndef Tcl_DStringAppendElement
+VFUNC(char *,Tcl_DStringAppendElement,V_Tcl_DStringAppendElement,_ANSI_ARGS_((
+ Tcl_DString * dsPtr, CONST char * string)))
+#endif /* #ifndef Tcl_DStringAppendElement */
+
+#ifndef Tcl_DStringFree
+VFUNC(void,Tcl_DStringFree,V_Tcl_DStringFree,_ANSI_ARGS_((Tcl_DString * dsPtr)))
+#endif /* #ifndef Tcl_DStringFree */
+
+#ifndef Tcl_DStringInit
+VFUNC(void,Tcl_DStringInit,V_Tcl_DStringInit,_ANSI_ARGS_((Tcl_DString * dsPtr)))
+#endif /* #ifndef Tcl_DStringInit */
+
+#ifndef Tcl_DStringResult
+VFUNC(void,Tcl_DStringResult,V_Tcl_DStringResult,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_DString * dsPtr)))
+#endif /* #ifndef Tcl_DStringResult */
+
+#ifndef Tcl_DStringSetLength
+VFUNC(void,Tcl_DStringSetLength,V_Tcl_DStringSetLength,_ANSI_ARGS_((
+ Tcl_DString * dsPtr, int length)))
+#endif /* #ifndef Tcl_DStringSetLength */
+
+#ifndef Tcl_DeleteEventSource
+VFUNC(void,Tcl_DeleteEventSource,V_Tcl_DeleteEventSource,_ANSI_ARGS_((
+ Tcl_EventSetupProc * setupProc,
+ Tcl_EventCheckProc * checkProc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_DeleteEventSource */
+
+#ifndef Tcl_DeleteFileHandler
+#if !defined(__WIN32__) && !defined(MAC_TCL)
+VFUNC(void,Tcl_DeleteFileHandler,V_Tcl_DeleteFileHandler,_ANSI_ARGS_((int fd)))
+#endif /* #if !defined(__WIN32__) && !defined(MAC_TCL) */
+#endif /* #ifndef Tcl_DeleteFileHandler */
+
+#ifndef Tcl_DeleteHashEntry
+VFUNC(void,Tcl_DeleteHashEntry,V_Tcl_DeleteHashEntry,_ANSI_ARGS_((
+ Tcl_HashEntry * entryPtr)))
+#endif /* #ifndef Tcl_DeleteHashEntry */
+
+#ifndef Tcl_DeleteHashTable
+VFUNC(void,Tcl_DeleteHashTable,V_Tcl_DeleteHashTable,_ANSI_ARGS_((
+ Tcl_HashTable * tablePtr)))
+#endif /* #ifndef Tcl_DeleteHashTable */
+
+#ifndef Tcl_DeleteInterp
+VFUNC(void,Tcl_DeleteInterp,V_Tcl_DeleteInterp,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_DeleteInterp */
+
+#ifndef Tcl_DeleteTimerHandler
+VFUNC(void,Tcl_DeleteTimerHandler,V_Tcl_DeleteTimerHandler,_ANSI_ARGS_((
+ Tcl_TimerToken token)))
+#endif /* #ifndef Tcl_DeleteTimerHandler */
+
+#ifndef Tcl_DoOneEvent
+VFUNC(int,Tcl_DoOneEvent,V_Tcl_DoOneEvent,_ANSI_ARGS_((int flags)))
+#endif /* #ifndef Tcl_DoOneEvent */
+
+#ifndef Tcl_DoWhenIdle
+VFUNC(void,Tcl_DoWhenIdle,V_Tcl_DoWhenIdle,_ANSI_ARGS_((Tcl_IdleProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_DoWhenIdle */
+
+#ifndef Tcl_DuplicateObj
+VFUNC(Tcl_Obj *,Tcl_DuplicateObj,V_Tcl_DuplicateObj,_ANSI_ARGS_((Tcl_Obj * objPtr)))
+#endif /* #ifndef Tcl_DuplicateObj */
+
+#ifndef Tcl_Eof
+VFUNC(int,Tcl_Eof,V_Tcl_Eof,_ANSI_ARGS_((Tcl_Channel chan)))
+#endif /* #ifndef Tcl_Eof */
+
+#ifndef Tcl_EvalObjEx
+VFUNC(int,Tcl_EvalObjEx,V_Tcl_EvalObjEx,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int flags)))
+#endif /* #ifndef Tcl_EvalObjEx */
+
+#ifndef Tcl_EvalObjv
+VFUNC(int,Tcl_EvalObjv,V_Tcl_EvalObjv,_ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[], int flags)))
+#endif /* #ifndef Tcl_EvalObjv */
+
+#ifndef Tcl_EventuallyFree
+VFUNC(void,Tcl_EventuallyFree,V_Tcl_EventuallyFree,_ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_FreeProc * freeProc)))
+#endif /* #ifndef Tcl_EventuallyFree */
+
+#ifndef Tcl_ExternalToUtf
+VFUNC(int,Tcl_ExternalToUtf,V_Tcl_ExternalToUtf,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, int flags,
+ Tcl_EncodingState * statePtr, char * dst,
+ int dstLen, int * srcReadPtr,
+ int * dstWrotePtr, int * dstCharsPtr)))
+#endif /* #ifndef Tcl_ExternalToUtf */
+
+#ifndef Tcl_ExternalToUtfDString
+VFUNC(char *,Tcl_ExternalToUtfDString,V_Tcl_ExternalToUtfDString,_ANSI_ARGS_((
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, Tcl_DString * dsPtr)))
+#endif /* #ifndef Tcl_ExternalToUtfDString */
+
+#ifndef Tcl_FirstHashEntry
+VFUNC(Tcl_HashEntry *,Tcl_FirstHashEntry,V_Tcl_FirstHashEntry,_ANSI_ARGS_((
+ Tcl_HashTable * tablePtr,
+ Tcl_HashSearch * searchPtr)))
+#endif /* #ifndef Tcl_FirstHashEntry */
+
+#ifndef Tcl_FreeEncoding
+VFUNC(void,Tcl_FreeEncoding,V_Tcl_FreeEncoding,_ANSI_ARGS_((Tcl_Encoding encoding)))
+#endif /* #ifndef Tcl_FreeEncoding */
+
+#ifndef Tcl_GetAssocData
+VFUNC(ClientData,Tcl_GetAssocData,V_Tcl_GetAssocData,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name,
+ Tcl_InterpDeleteProc ** procPtr)))
+#endif /* #ifndef Tcl_GetAssocData */
+
+#ifndef Tcl_GetBooleanFromObj
+VFUNC(int,Tcl_GetBooleanFromObj,V_Tcl_GetBooleanFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ int * boolPtr)))
+#endif /* #ifndef Tcl_GetBooleanFromObj */
+
+#ifndef Tcl_GetChannel
+VFUNC(Tcl_Channel,Tcl_GetChannel,V_Tcl_GetChannel,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * chanName, int * modePtr)))
+#endif /* #ifndef Tcl_GetChannel */
+
+#ifndef Tcl_GetCommandInfo
+VFUNC(int,Tcl_GetCommandInfo,V_Tcl_GetCommandInfo,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * cmdName, Tcl_CmdInfo * infoPtr)))
+#endif /* #ifndef Tcl_GetCommandInfo */
+
+#ifndef Tcl_GetDouble
+VFUNC(int,Tcl_GetDouble,V_Tcl_GetDouble,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, double * doublePtr)))
+#endif /* #ifndef Tcl_GetDouble */
+
+#ifndef Tcl_GetDoubleFromObj
+VFUNC(int,Tcl_GetDoubleFromObj,V_Tcl_GetDoubleFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ double * doublePtr)))
+#endif /* #ifndef Tcl_GetDoubleFromObj */
+
+#ifndef Tcl_GetEncoding
+VFUNC(Tcl_Encoding,Tcl_GetEncoding,V_Tcl_GetEncoding,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name)))
+#endif /* #ifndef Tcl_GetEncoding */
+
+#ifndef Tcl_GetEncodingName
+VFUNC(CONST84_RETURN char *,Tcl_GetEncodingName,V_Tcl_GetEncodingName,_ANSI_ARGS_((
+ Tcl_Encoding encoding)))
+#endif /* #ifndef Tcl_GetEncodingName */
+
+#ifndef Tcl_GetIndexFromObj
+VFUNC(int,Tcl_GetIndexFromObj,V_Tcl_GetIndexFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, CONST char ** tablePtr,
+ CONST char * msg, int flags, int * indexPtr)))
+#endif /* #ifndef Tcl_GetIndexFromObj */
+
+#ifndef Tcl_GetInt
+VFUNC(int,Tcl_GetInt,V_Tcl_GetInt,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * intPtr)))
+#endif /* #ifndef Tcl_GetInt */
+
+#ifndef Tcl_GetIntFromObj
+VFUNC(int,Tcl_GetIntFromObj,V_Tcl_GetIntFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int * intPtr)))
+#endif /* #ifndef Tcl_GetIntFromObj */
+
+#ifndef Tcl_GetLongFromObj
+VFUNC(int,Tcl_GetLongFromObj,V_Tcl_GetLongFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, long * longPtr)))
+#endif /* #ifndef Tcl_GetLongFromObj */
+
+#ifndef Tcl_GetObjResult
+VFUNC(Tcl_Obj *,Tcl_GetObjResult,V_Tcl_GetObjResult,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_GetObjResult */
+
+#ifndef Tcl_GetObjType
+VFUNC(Tcl_ObjType *,Tcl_GetObjType,V_Tcl_GetObjType,_ANSI_ARGS_((CONST char * typeName)))
+#endif /* #ifndef Tcl_GetObjType */
+
+#ifndef Tcl_GetRegExpFromObj
+VFUNC(Tcl_RegExp,Tcl_GetRegExpFromObj,V_Tcl_GetRegExpFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * patObj,
+ int flags)))
+#endif /* #ifndef Tcl_GetRegExpFromObj */
+
+#ifndef Tcl_GetStdChannel
+VFUNC(Tcl_Channel,Tcl_GetStdChannel,V_Tcl_GetStdChannel,_ANSI_ARGS_((int type)))
+#endif /* #ifndef Tcl_GetStdChannel */
+
+#ifndef Tcl_GetString
+VFUNC(char *,Tcl_GetString,V_Tcl_GetString,_ANSI_ARGS_((Tcl_Obj * objPtr)))
+#endif /* #ifndef Tcl_GetString */
+
+#ifndef Tcl_GetStringFromObj
+VFUNC(char *,Tcl_GetStringFromObj,V_Tcl_GetStringFromObj,_ANSI_ARGS_((Tcl_Obj * objPtr,
+ int * lengthPtr)))
+#endif /* #ifndef Tcl_GetStringFromObj */
+
+#ifndef Tcl_GetStringResult
+VFUNC(CONST84_RETURN char *,Tcl_GetStringResult,V_Tcl_GetStringResult,_ANSI_ARGS_((
+ Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_GetStringResult */
+
+#ifndef Tcl_GetThreadData
+VFUNC(VOID *,Tcl_GetThreadData,V_Tcl_GetThreadData,_ANSI_ARGS_((
+ Tcl_ThreadDataKey * keyPtr, int size)))
+#endif /* #ifndef Tcl_GetThreadData */
+
+#ifndef Tcl_GetTime
+VFUNC(void,Tcl_GetTime,V_Tcl_GetTime,_ANSI_ARGS_((Tcl_Time* timeBuf)))
+#endif /* #ifndef Tcl_GetTime */
+
+#ifndef Tcl_GetVar
+VFUNC(CONST84_RETURN char *,Tcl_GetVar,V_Tcl_GetVar,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags)))
+#endif /* #ifndef Tcl_GetVar */
+
+#ifndef Tcl_GetVar2
+VFUNC(CONST84_RETURN char *,Tcl_GetVar2,V_Tcl_GetVar2,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags)))
+#endif /* #ifndef Tcl_GetVar2 */
+
+#ifndef Tcl_GetVar2Ex
+VFUNC(Tcl_Obj *,Tcl_GetVar2Ex,V_Tcl_GetVar2Ex,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags)))
+#endif /* #ifndef Tcl_GetVar2Ex */
+
+#ifndef Tcl_GlobalEval
+VFUNC(int,Tcl_GlobalEval,V_Tcl_GlobalEval,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * command)))
+#endif /* #ifndef Tcl_GlobalEval */
+
+#ifndef Tcl_HideCommand
+VFUNC(int,Tcl_HideCommand,V_Tcl_HideCommand,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * cmdName,
+ CONST char * hiddenCmdToken)))
+#endif /* #ifndef Tcl_HideCommand */
+
+#ifndef Tcl_InitHashTable
+VFUNC(void,Tcl_InitHashTable,V_Tcl_InitHashTable,_ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, int keyType)))
+#endif /* #ifndef Tcl_InitHashTable */
+
+#ifndef Tcl_IsSafe
+VFUNC(int,Tcl_IsSafe,V_Tcl_IsSafe,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_IsSafe */
+
+#ifndef Tcl_LinkVar
+VFUNC(int,Tcl_LinkVar,V_Tcl_LinkVar,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, char * addr, int type)))
+#endif /* #ifndef Tcl_LinkVar */
+
+#ifndef Tcl_ListObjAppendElement
+VFUNC(int,Tcl_ListObjAppendElement,V_Tcl_ListObjAppendElement,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * listPtr,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tcl_ListObjAppendElement */
+
+#ifndef Tcl_ListObjGetElements
+VFUNC(int,Tcl_ListObjGetElements,V_Tcl_ListObjGetElements,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * listPtr,
+ int * objcPtr, Tcl_Obj *** objvPtr)))
+#endif /* #ifndef Tcl_ListObjGetElements */
+
+#ifndef Tcl_ListObjIndex
+VFUNC(int,Tcl_ListObjIndex,V_Tcl_ListObjIndex,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * listPtr, int index,
+ Tcl_Obj ** objPtrPtr)))
+#endif /* #ifndef Tcl_ListObjIndex */
+
+#ifndef Tcl_ListObjLength
+VFUNC(int,Tcl_ListObjLength,V_Tcl_ListObjLength,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * listPtr, int * lengthPtr)))
+#endif /* #ifndef Tcl_ListObjLength */
+
+#ifndef Tcl_ListObjReplace
+VFUNC(int,Tcl_ListObjReplace,V_Tcl_ListObjReplace,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * listPtr, int first, int count,
+ int objc, Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tcl_ListObjReplace */
+
+#ifndef Tcl_NewBooleanObj
+VFUNC(Tcl_Obj *,Tcl_NewBooleanObj,V_Tcl_NewBooleanObj,_ANSI_ARGS_((int boolValue)))
+#endif /* #ifndef Tcl_NewBooleanObj */
+
+#ifndef Tcl_NewDoubleObj
+VFUNC(Tcl_Obj *,Tcl_NewDoubleObj,V_Tcl_NewDoubleObj,_ANSI_ARGS_((double doubleValue)))
+#endif /* #ifndef Tcl_NewDoubleObj */
+
+#ifndef Tcl_NewIntObj
+VFUNC(Tcl_Obj *,Tcl_NewIntObj,V_Tcl_NewIntObj,_ANSI_ARGS_((int intValue)))
+#endif /* #ifndef Tcl_NewIntObj */
+
+#ifndef Tcl_NewListObj
+VFUNC(Tcl_Obj *,Tcl_NewListObj,V_Tcl_NewListObj,_ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tcl_NewListObj */
+
+#ifndef Tcl_NewLongObj
+VFUNC(Tcl_Obj *,Tcl_NewLongObj,V_Tcl_NewLongObj,_ANSI_ARGS_((long longValue)))
+#endif /* #ifndef Tcl_NewLongObj */
+
+#ifndef Tcl_NewObj
+VFUNC(Tcl_Obj *,Tcl_NewObj,V_Tcl_NewObj,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_NewObj */
+
+#ifndef Tcl_NewStringObj
+VFUNC(Tcl_Obj *,Tcl_NewStringObj,V_Tcl_NewStringObj,_ANSI_ARGS_((CONST char * bytes,
+ int length)))
+#endif /* #ifndef Tcl_NewStringObj */
+
+#ifndef Tcl_NextHashEntry
+VFUNC(Tcl_HashEntry *,Tcl_NextHashEntry,V_Tcl_NextHashEntry,_ANSI_ARGS_((
+ Tcl_HashSearch * searchPtr)))
+#endif /* #ifndef Tcl_NextHashEntry */
+
+#ifndef Tcl_NumUtfChars
+VFUNC(int,Tcl_NumUtfChars,V_Tcl_NumUtfChars,_ANSI_ARGS_((CONST char * src,
+ int len)))
+#endif /* #ifndef Tcl_NumUtfChars */
+
+#ifndef Tcl_ObjGetVar2
+VFUNC(Tcl_Obj *,Tcl_ObjGetVar2,V_Tcl_ObjGetVar2,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
+ int flags)))
+#endif /* #ifndef Tcl_ObjGetVar2 */
+
+#ifndef Tcl_ObjSetVar2
+VFUNC(Tcl_Obj *,Tcl_ObjSetVar2,V_Tcl_ObjSetVar2,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
+ Tcl_Obj * newValuePtr, int flags)))
+#endif /* #ifndef Tcl_ObjSetVar2 */
+
+#ifndef Tcl_OpenFileChannel
+VFUNC(Tcl_Channel,Tcl_OpenFileChannel,V_Tcl_OpenFileChannel,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * fileName,
+ CONST char * modeString, int permissions)))
+#endif /* #ifndef Tcl_OpenFileChannel */
+
+#ifndef Tcl_Panic
+VFUNC(void,Tcl_Panic,V_Tcl_Panic,_ANSI_ARGS_(TCL_VARARGS(CONST char *,format)))
+#endif /* #ifndef Tcl_Panic */
+
+#ifndef Tcl_PosixError
+VFUNC(CONST84_RETURN char *,Tcl_PosixError,V_Tcl_PosixError,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_PosixError */
+
+#ifndef Tcl_Preserve
+VFUNC(void,Tcl_Preserve,V_Tcl_Preserve,_ANSI_ARGS_((ClientData data)))
+#endif /* #ifndef Tcl_Preserve */
+
+#ifndef Tcl_Read
+VFUNC(int,Tcl_Read,V_Tcl_Read,_ANSI_ARGS_((Tcl_Channel chan,
+ char * bufPtr, int toRead)))
+#endif /* #ifndef Tcl_Read */
+
+#ifndef Tcl_RegExpExec
+VFUNC(int,Tcl_RegExpExec,V_Tcl_RegExpExec,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_RegExp regexp, CONST char * str,
+ CONST char * start)))
+#endif /* #ifndef Tcl_RegExpExec */
+
+#ifndef Tcl_RegExpRange
+VFUNC(void,Tcl_RegExpRange,V_Tcl_RegExpRange,_ANSI_ARGS_((Tcl_RegExp regexp,
+ int index, CONST84 char ** startPtr,
+ CONST84 char ** endPtr)))
+#endif /* #ifndef Tcl_RegExpRange */
+
+#ifndef Tcl_Release
+VFUNC(void,Tcl_Release,V_Tcl_Release,_ANSI_ARGS_((ClientData clientData)))
+#endif /* #ifndef Tcl_Release */
+
+#ifndef Tcl_ResetResult
+VFUNC(void,Tcl_ResetResult,V_Tcl_ResetResult,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tcl_ResetResult */
+
+#ifndef Tcl_Seek
+VFUNC(Tcl_WideInt,Tcl_Seek,V_Tcl_Seek,_ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_WideInt offset, int mode)))
+#endif /* #ifndef Tcl_Seek */
+
+#ifndef Tcl_ServiceEvent
+VFUNC(int,Tcl_ServiceEvent,V_Tcl_ServiceEvent,_ANSI_ARGS_((int flags)))
+#endif /* #ifndef Tcl_ServiceEvent */
+
+#ifndef Tcl_SetAssocData
+VFUNC(void,Tcl_SetAssocData,V_Tcl_SetAssocData,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name,
+ Tcl_InterpDeleteProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_SetAssocData */
+
+#ifndef Tcl_SetBooleanObj
+VFUNC(void,Tcl_SetBooleanObj,V_Tcl_SetBooleanObj,_ANSI_ARGS_((Tcl_Obj * objPtr,
+ int boolValue)))
+#endif /* #ifndef Tcl_SetBooleanObj */
+
+#ifndef Tcl_SetChannelOption
+VFUNC(int,Tcl_SetChannelOption,V_Tcl_SetChannelOption,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Channel chan,
+ CONST char * optionName,
+ CONST char * newValue)))
+#endif /* #ifndef Tcl_SetChannelOption */
+
+#ifndef Tcl_SetCommandInfo
+VFUNC(int,Tcl_SetCommandInfo,V_Tcl_SetCommandInfo,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * cmdName,
+ CONST Tcl_CmdInfo * infoPtr)))
+#endif /* #ifndef Tcl_SetCommandInfo */
+
+#ifndef Tcl_SetDoubleObj
+VFUNC(void,Tcl_SetDoubleObj,V_Tcl_SetDoubleObj,_ANSI_ARGS_((Tcl_Obj * objPtr,
+ double doubleValue)))
+#endif /* #ifndef Tcl_SetDoubleObj */
+
+#ifndef Tcl_SetIntObj
+VFUNC(void,Tcl_SetIntObj,V_Tcl_SetIntObj,_ANSI_ARGS_((Tcl_Obj * objPtr,
+ int intValue)))
+#endif /* #ifndef Tcl_SetIntObj */
+
+#ifndef Tcl_SetListObj
+VFUNC(void,Tcl_SetListObj,V_Tcl_SetListObj,_ANSI_ARGS_((Tcl_Obj * objPtr,
+ int objc, Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tcl_SetListObj */
+
+#ifndef Tcl_SetLongObj
+VFUNC(void,Tcl_SetLongObj,V_Tcl_SetLongObj,_ANSI_ARGS_((Tcl_Obj * objPtr,
+ long longValue)))
+#endif /* #ifndef Tcl_SetLongObj */
+
+#ifndef Tcl_SetMaxBlockTime
+VFUNC(void,Tcl_SetMaxBlockTime,V_Tcl_SetMaxBlockTime,_ANSI_ARGS_((Tcl_Time * timePtr)))
+#endif /* #ifndef Tcl_SetMaxBlockTime */
+
+#ifndef Tcl_SetObjErrorCode
+VFUNC(void,Tcl_SetObjErrorCode,V_Tcl_SetObjErrorCode,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * errorObjPtr)))
+#endif /* #ifndef Tcl_SetObjErrorCode */
+
+#ifndef Tcl_SetObjResult
+VFUNC(void,Tcl_SetObjResult,V_Tcl_SetObjResult,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * resultObjPtr)))
+#endif /* #ifndef Tcl_SetObjResult */
+
+#ifndef Tcl_SetResult
+VFUNC(void,Tcl_SetResult,V_Tcl_SetResult,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * str, Tcl_FreeProc * freeProc)))
+#endif /* #ifndef Tcl_SetResult */
+
+#ifndef Tcl_SetStringObj
+VFUNC(void,Tcl_SetStringObj,V_Tcl_SetStringObj,_ANSI_ARGS_((Tcl_Obj* objPtr,
+ CONST char* bytes, int length)))
+#endif /* #ifndef Tcl_SetStringObj */
+
+#ifndef Tcl_SetVar
+VFUNC(CONST84_RETURN char *,Tcl_SetVar,V_Tcl_SetVar,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, CONST char * newValue,
+ int flags)))
+#endif /* #ifndef Tcl_SetVar */
+
+#ifndef Tcl_Sleep
+VFUNC(void,Tcl_Sleep,V_Tcl_Sleep,_ANSI_ARGS_((int ms)))
+#endif /* #ifndef Tcl_Sleep */
+
+#ifndef Tcl_StringMatch
+VFUNC(int,Tcl_StringMatch,V_Tcl_StringMatch,_ANSI_ARGS_((CONST char * str,
+ CONST char * pattern)))
+#endif /* #ifndef Tcl_StringMatch */
+
+#ifndef Tcl_TranslateFileName
+VFUNC(char *,Tcl_TranslateFileName,V_Tcl_TranslateFileName,_ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ Tcl_DString * bufferPtr)))
+#endif /* #ifndef Tcl_TranslateFileName */
+
+#ifndef Tcl_UniCharIsAlpha
+VFUNC(int,Tcl_UniCharIsAlpha,V_Tcl_UniCharIsAlpha,_ANSI_ARGS_((int ch)))
+#endif /* #ifndef Tcl_UniCharIsAlpha */
+
+#ifndef Tcl_UniCharIsSpace
+VFUNC(int,Tcl_UniCharIsSpace,V_Tcl_UniCharIsSpace,_ANSI_ARGS_((int ch)))
+#endif /* #ifndef Tcl_UniCharIsSpace */
+
+#ifndef Tcl_UniCharIsUpper
+VFUNC(int,Tcl_UniCharIsUpper,V_Tcl_UniCharIsUpper,_ANSI_ARGS_((int ch)))
+#endif /* #ifndef Tcl_UniCharIsUpper */
+
+#ifndef Tcl_UniCharIsWordChar
+VFUNC(int,Tcl_UniCharIsWordChar,V_Tcl_UniCharIsWordChar,_ANSI_ARGS_((int ch)))
+#endif /* #ifndef Tcl_UniCharIsWordChar */
+
+#ifndef Tcl_UniCharToLower
+VFUNC(Tcl_UniChar,Tcl_UniCharToLower,V_Tcl_UniCharToLower,_ANSI_ARGS_((int ch)))
+#endif /* #ifndef Tcl_UniCharToLower */
+
+#ifndef Tcl_UniCharToUpper
+VFUNC(Tcl_UniChar,Tcl_UniCharToUpper,V_Tcl_UniCharToUpper,_ANSI_ARGS_((int ch)))
+#endif /* #ifndef Tcl_UniCharToUpper */
+
+#ifndef Tcl_UniCharToUtf
+VFUNC(int,Tcl_UniCharToUtf,V_Tcl_UniCharToUtf,_ANSI_ARGS_((int ch, char * buf)))
+#endif /* #ifndef Tcl_UniCharToUtf */
+
+#ifndef Tcl_UnlinkVar
+VFUNC(void,Tcl_UnlinkVar,V_Tcl_UnlinkVar,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName)))
+#endif /* #ifndef Tcl_UnlinkVar */
+
+#ifndef Tcl_UtfAtIndex
+VFUNC(CONST84_RETURN char *,Tcl_UtfAtIndex,V_Tcl_UtfAtIndex,_ANSI_ARGS_((CONST char * src,
+ int index)))
+#endif /* #ifndef Tcl_UtfAtIndex */
+
+#ifndef Tcl_UtfCharComplete
+VFUNC(int,Tcl_UtfCharComplete,V_Tcl_UtfCharComplete,_ANSI_ARGS_((CONST char * src,
+ int len)))
+#endif /* #ifndef Tcl_UtfCharComplete */
+
+#ifndef Tcl_UtfNext
+VFUNC(CONST84_RETURN char *,Tcl_UtfNext,V_Tcl_UtfNext,_ANSI_ARGS_((CONST char * src)))
+#endif /* #ifndef Tcl_UtfNext */
+
+#ifndef Tcl_UtfPrev
+VFUNC(CONST84_RETURN char *,Tcl_UtfPrev,V_Tcl_UtfPrev,_ANSI_ARGS_((CONST char * src,
+ CONST char * start)))
+#endif /* #ifndef Tcl_UtfPrev */
+
+#ifndef Tcl_UtfToExternal
+VFUNC(int,Tcl_UtfToExternal,V_Tcl_UtfToExternal,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, int flags,
+ Tcl_EncodingState * statePtr, char * dst,
+ int dstLen, int * srcReadPtr,
+ int * dstWrotePtr, int * dstCharsPtr)))
+#endif /* #ifndef Tcl_UtfToExternal */
+
+#ifndef Tcl_UtfToExternalDString
+VFUNC(char *,Tcl_UtfToExternalDString,V_Tcl_UtfToExternalDString,_ANSI_ARGS_((
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, Tcl_DString * dsPtr)))
+#endif /* #ifndef Tcl_UtfToExternalDString */
+
+#ifndef Tcl_UtfToLower
+VFUNC(int,Tcl_UtfToLower,V_Tcl_UtfToLower,_ANSI_ARGS_((char * src)))
+#endif /* #ifndef Tcl_UtfToLower */
+
+#ifndef Tcl_UtfToUniChar
+VFUNC(int,Tcl_UtfToUniChar,V_Tcl_UtfToUniChar,_ANSI_ARGS_((CONST char * src,
+ Tcl_UniChar * chPtr)))
+#endif /* #ifndef Tcl_UtfToUniChar */
+
+#ifndef Tcl_Write
+VFUNC(int,Tcl_Write,V_Tcl_Write,_ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * s, int slen)))
+#endif /* #ifndef Tcl_Write */
+
+#ifndef Tcl_WriteChars
+VFUNC(int,Tcl_WriteChars,V_Tcl_WriteChars,_ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * src, int srcLen)))
+#endif /* #ifndef Tcl_WriteChars */
+
+#ifndef Tcl_WrongNumArgs
+VFUNC(void,Tcl_WrongNumArgs,V_Tcl_WrongNumArgs,_ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[],
+ CONST char * message)))
+#endif /* #ifndef Tcl_WrongNumArgs */
+
+#endif /* _TCLDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls_f.h
new file mode 100755
index 00000000000..b150c471937
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclDecls_f.h
@@ -0,0 +1,14 @@
+#ifndef TCLDECLS_VT
+#define TCLDECLS_VT
+typedef struct TcldeclsVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tclDecls.t"
+#undef VFUNC
+#undef VVAR
+} TcldeclsVtab;
+extern TcldeclsVtab *TcldeclsVptr;
+extern TcldeclsVtab *TcldeclsVGet(void);
+#endif /* TCLDECLS_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntDecls.h
new file mode 100755
index 00000000000..4e3c6afd400
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntDecls.h
@@ -0,0 +1,1324 @@
+/*
+ * tclIntDecls.h --
+ *
+ * This file contains the declarations for all unsupported
+ * functions that are exported by the Tcl library. These
+ * interfaces are not guaranteed to remain the same between
+ * versions. Use at your own risk.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.49 2003/02/18 02:25:45 hobbs Exp $
+ */
+
+#ifndef _TCLINTDECLS
+#define _TCLINTDECLS
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tclInt.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+/* Slot 0 is reserved */
+/* 1 */
+EXTERN int TclAccessDeleteProc _ANSI_ARGS_((
+ TclAccessProc_ * proc));
+/* 2 */
+EXTERN int TclAccessInsertProc _ANSI_ARGS_((
+ TclAccessProc_ * proc));
+/* 3 */
+EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void));
+/* Slot 4 is reserved */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 5 */
+EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp,
+ int numPids, Tcl_Pid * pidPtr,
+ Tcl_Channel errorChan));
+#endif /* UNIX */
+#ifdef __WIN32__
+/* 5 */
+EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp,
+ int numPids, Tcl_Pid * pidPtr,
+ Tcl_Channel errorChan));
+#endif /* __WIN32__ */
+/* 6 */
+EXTERN void TclCleanupCommand _ANSI_ARGS_((Command * cmdPtr));
+/* 7 */
+EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count,
+ CONST char * src, char * dst));
+/* 8 */
+EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel inChan, Tcl_Channel outChan,
+ int toRead, Tcl_Obj * cmdPtr));
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 9 */
+EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp,
+ int argc, Tcl_Obj *CONST *objv,
+ Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr,
+ TclFile * outPipePtr, TclFile * errFilePtr));
+#endif /* UNIX */
+#ifdef __WIN32__
+/* 9 */
+EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp,
+ int argc, Tcl_Obj *CONST *objv,
+ Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr,
+ TclFile * outPipePtr, TclFile * errFilePtr));
+#endif /* __WIN32__ */
+/* 10 */
+EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp * interp,
+ Namespace * nsPtr, CONST char * procName,
+ Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr,
+ Proc ** procPtrPtr));
+/* 11 */
+EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_((
+ Interp * iPtr, CallFrame * framePtr));
+/* 12 */
+EXTERN void TclDeleteVars _ANSI_ARGS_((Interp * iPtr,
+ Tcl_HashTable * tablePtr));
+/* 13 */
+EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp,
+ char * separators, Tcl_DString * headPtr,
+ char * tail, Tcl_GlobTypeData * types));
+/* 14 */
+EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile));
+/* Slot 15 is reserved */
+/* 16 */
+EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp,
+ double value));
+/* Slot 17 is reserved */
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+/* Slot 21 is reserved */
+/* 22 */
+EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * listStr, int listLength,
+ CONST char ** elementPtr,
+ CONST char ** nextPtr, int * sizePtr,
+ int * bracePtr));
+/* 23 */
+EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr,
+ CONST char * procName));
+/* 24 */
+EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n));
+/* 25 */
+EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr));
+/* Slot 26 is reserved */
+/* 27 */
+EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now,
+ long zone, unsigned long * timePtr));
+/* 28 */
+EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
+/* Slot 29 is reserved */
+/* Slot 30 is reserved */
+/* 31 */
+EXTERN char * TclGetExtension _ANSI_ARGS_((char * name));
+/* 32 */
+EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, CallFrame ** framePtrPtr));
+/* 33 */
+EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void));
+/* 34 */
+EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int endValue,
+ int * indexPtr));
+/* Slot 35 is reserved */
+/* 36 */
+EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, long * longPtr));
+/* 37 */
+EXTERN int TclGetLoadedPackages _ANSI_ARGS_((
+ Tcl_Interp * interp, char * targetName));
+/* 38 */
+EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * qualName,
+ Namespace * cxtNsPtr, int flags,
+ Namespace ** nsPtrPtr,
+ Namespace ** altNsPtrPtr,
+ Namespace ** actualCxtPtrPtr,
+ CONST char ** simpleNamePtr));
+/* 39 */
+EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
+/* 40 */
+EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * seekFlagPtr));
+/* 41 */
+EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_((
+ Tcl_Command command));
+/* 42 */
+EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char * name,
+ Tcl_DString * bufferPtr));
+/* 43 */
+EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp,
+ int argc, CONST84 Tcl_Obj *CONST *objv, int flags));
+/* 44 */
+EXTERN int TclGuessPackageName _ANSI_ARGS_((
+ CONST char * fileName, Tcl_DString * bufPtr));
+/* 45 */
+EXTERN int TclHideUnsafeCommands _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 46 */
+EXTERN int TclInExit _ANSI_ARGS_((void));
+/* Slot 47 is reserved */
+/* Slot 48 is reserved */
+/* 49 */
+EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
+ long incrAmount, int part1NotParsed));
+/* 50 */
+EXTERN void TclInitCompiledLocals _ANSI_ARGS_((
+ Tcl_Interp * interp, CallFrame * framePtr,
+ Namespace * nsPtr));
+/* 51 */
+EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp * interp));
+/* 52 */
+EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp * interp, int argc,
+ CONST84 Tcl_Obj *CONST *objv, int flags));
+/* 53 */
+EXTERN int TclInvokeObjectCommand _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp * interp,
+ int argc, CONST84 Tcl_Obj *CONST *objv));
+/* 54 */
+EXTERN int TclInvokeStringCommand _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 55 */
+EXTERN Proc * TclIsProc _ANSI_ARGS_((Command * cmdPtr));
+/* Slot 56 is reserved */
+/* Slot 57 is reserved */
+/* 58 */
+EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags, CONST char * msg, int createPart1,
+ int createPart2, Var ** arrayPtrPtr));
+/* Slot 59 is reserved */
+/* 60 */
+EXTERN int TclNeedSpace _ANSI_ARGS_((CONST char * start,
+ CONST char * end));
+/* 61 */
+EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc * procPtr));
+/* 62 */
+EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj * cmdPtr));
+/* 63 */
+EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, int objc,
+ Tcl_Obj *CONST objv[]));
+/* 64 */
+EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[], int flags));
+/* 65 */
+EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[], int flags));
+/* 66 */
+EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_((
+ TclOpenFileChannelProc_ * proc));
+/* 67 */
+EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_((
+ TclOpenFileChannelProc_ * proc));
+/* Slot 68 is reserved */
+/* 69 */
+EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
+/* Slot 70 is reserved */
+/* Slot 71 is reserved */
+/* Slot 72 is reserved */
+/* Slot 73 is reserved */
+/* 74 */
+EXTERN void TclpFree _ANSI_ARGS_((char * ptr));
+/* 75 */
+EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void));
+/* 76 */
+EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void));
+/* 77 */
+EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time * time));
+/* 78 */
+EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
+/* Slot 79 is reserved */
+/* Slot 80 is reserved */
+/* 81 */
+EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr,
+ unsigned int size));
+/* Slot 82 is reserved */
+/* Slot 83 is reserved */
+/* Slot 84 is reserved */
+/* Slot 85 is reserved */
+/* Slot 86 is reserved */
+/* Slot 87 is reserved */
+/* 88 */
+EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, CONST char * name1,
+ CONST char * name2, int flags));
+/* 89 */
+EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Interp * cmdInterp, Tcl_Command cmd));
+/* Slot 90 is reserved */
+/* 91 */
+EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc * procPtr));
+/* 92 */
+EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp * interp,
+ Proc * procPtr, Tcl_Obj * bodyPtr,
+ Namespace * nsPtr, CONST char * description,
+ CONST char * procName));
+/* 93 */
+EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
+/* 94 */
+EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, int argc,
+ CONST84 Tcl_Obj *CONST *objv));
+/* Slot 95 is reserved */
+/* 96 */
+EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ char * oldName, char * newName));
+/* 97 */
+EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_((
+ Tcl_Interp * interp, Command * newCmdPtr));
+/* 98 */
+EXTERN int TclServiceIdle _ANSI_ARGS_((void));
+/* Slot 99 is reserved */
+/* Slot 100 is reserved */
+/* 101 */
+EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string));
+/* 102 */
+EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp));
+/* 103 */
+EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp * interp,
+ char * str, char * proto, int * portPtr));
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 104 */
+EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock,
+ int size));
+#endif /* UNIX */
+#ifdef __WIN32__
+/* 104 */
+EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock,
+ int size));
+#endif /* __WIN32__ */
+/* Slot 105 is reserved */
+/* 106 */
+EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ * proc));
+/* 107 */
+EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ * proc));
+/* 108 */
+EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace * nsPtr));
+/* 109 */
+EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp * iPtr));
+/* Slot 110 is reserved */
+/* 111 */
+EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ Tcl_ResolveCmdProc * cmdProc,
+ Tcl_ResolveVarProc * varProc,
+ Tcl_ResolveCompiledVarProc * compiledVarProc));
+/* 112 */
+EXTERN int Tcl_AppendExportList _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Namespace * nsPtr,
+ Tcl_Obj * objPtr));
+/* 113 */
+EXTERN Tcl_Namespace * Tcl_CreateNamespace _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, ClientData clientData,
+ Tcl_NamespaceDeleteProc * deleteProc));
+/* 114 */
+EXTERN void Tcl_DeleteNamespace _ANSI_ARGS_((
+ Tcl_Namespace * nsPtr));
+/* 115 */
+EXTERN int Tcl_Export _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Namespace * nsPtr, CONST char * pattern,
+ int resetListFirst));
+/* 116 */
+EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name,
+ Tcl_Namespace * contextNsPtr, int flags));
+/* 117 */
+EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name,
+ Tcl_Namespace * contextNsPtr, int flags));
+/* 118 */
+EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ Tcl_ResolverInfo * resInfo));
+/* 119 */
+EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_((
+ Tcl_Namespace * namespacePtr,
+ Tcl_ResolverInfo * resInfo));
+/* 120 */
+EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ Tcl_Namespace * contextNsPtr, int flags));
+/* 121 */
+EXTERN int Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Namespace * nsPtr, CONST char * pattern));
+/* 122 */
+EXTERN Tcl_Command Tcl_GetCommandFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr));
+/* 123 */
+EXTERN void Tcl_GetCommandFullName _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Command command,
+ Tcl_Obj * objPtr));
+/* 124 */
+EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 125 */
+EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 126 */
+EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Var variable,
+ Tcl_Obj * objPtr));
+/* 127 */
+EXTERN int Tcl_Import _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Namespace * nsPtr, CONST char * pattern,
+ int allowOverwrite));
+/* 128 */
+EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp));
+/* 129 */
+EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_CallFrame * framePtr,
+ Tcl_Namespace * nsPtr, int isProcCallFrame));
+/* 130 */
+EXTERN int Tcl_RemoveInterpResolvers _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name));
+/* 131 */
+EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_((
+ Tcl_Namespace * namespacePtr,
+ Tcl_ResolveCmdProc * cmdProc,
+ Tcl_ResolveVarProc * varProc,
+ Tcl_ResolveCompiledVarProc * compiledVarProc));
+/* 132 */
+EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp * interp));
+/* 133 */
+EXTERN struct tm * TclpGetDate _ANSI_ARGS_((TclpTime_t time, int useGMT));
+/* 134 */
+EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize,
+ CONST char * format, CONST struct tm * t,
+ int useGMT));
+/* 135 */
+EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
+/* Slot 136 is reserved */
+/* Slot 137 is reserved */
+/* 138 */
+EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name,
+ Tcl_DString * valuePtr));
+/* Slot 139 is reserved */
+/* 140 */
+EXTERN int TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes,
+ int length));
+/* 141 */
+EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_DString * cwdPtr));
+/* 142 */
+EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ CompileHookProc * hookProc,
+ ClientData clientData));
+/* 143 */
+EXTERN int TclAddLiteralObj _ANSI_ARGS_((
+ struct CompileEnv * envPtr, Tcl_Obj * objPtr,
+ LiteralEntry ** litPtrPtr));
+/* 144 */
+EXTERN void TclHideLiteral _ANSI_ARGS_((Tcl_Interp * interp,
+ struct CompileEnv * envPtr, int index));
+/* 145 */
+EXTERN struct AuxDataType * TclGetAuxDataType _ANSI_ARGS_((char * typeName));
+/* 146 */
+EXTERN TclHandle TclHandleCreate _ANSI_ARGS_((VOID * ptr));
+/* 147 */
+EXTERN void TclHandleFree _ANSI_ARGS_((TclHandle handle));
+/* 148 */
+EXTERN TclHandle TclHandlePreserve _ANSI_ARGS_((TclHandle handle));
+/* 149 */
+EXTERN void TclHandleRelease _ANSI_ARGS_((TclHandle handle));
+/* 150 */
+EXTERN int TclRegAbout _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_RegExp re));
+/* 151 */
+EXTERN void TclRegExpRangeUniChar _ANSI_ARGS_((Tcl_RegExp re,
+ int index, int * startPtr, int * endPtr));
+/* 152 */
+EXTERN void TclSetLibraryPath _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 153 */
+EXTERN Tcl_Obj * TclGetLibraryPath _ANSI_ARGS_((void));
+/* Slot 154 is reserved */
+/* Slot 155 is reserved */
+/* 156 */
+EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * msg, int status));
+/* 157 */
+EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName));
+/* 158 */
+EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_((
+ CONST char * filename));
+/* 159 */
+EXTERN CONST84_RETURN char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
+/* Slot 160 is reserved */
+/* 161 */
+EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel chan, Tcl_Obj * cmdObjPtr));
+/* 162 */
+EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_((
+ ClientData clientData, int flags));
+/* 163 */
+EXTERN void * TclGetInstructionTable _ANSI_ARGS_((void));
+/* 164 */
+EXTERN void TclExpandCodeArray _ANSI_ARGS_((void * envPtr));
+/* 165 */
+EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void));
+/* 166 */
+EXTERN int TclListObjSetElement _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * listPtr,
+ int index, Tcl_Obj * valuePtr));
+/* 167 */
+EXTERN void TclSetStartupScriptPath _ANSI_ARGS_((
+ Tcl_Obj * pathPtr));
+/* 168 */
+EXTERN Tcl_Obj * TclGetStartupScriptPath _ANSI_ARGS_((void));
+/* 169 */
+EXTERN int TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1,
+ CONST char * s2, unsigned long n));
+/* 170 */
+EXTERN int TclCheckInterpTraces _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * command,
+ int numChars, Command * cmdPtr, int result,
+ int traceFlags, int objc,
+ Tcl_Obj *CONST objv[]));
+/* 171 */
+EXTERN int TclCheckExecutionTraces _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * command,
+ int numChars, Command * cmdPtr, int result,
+ int traceFlags, int objc,
+ Tcl_Obj *CONST objv[]));
+/* 172 */
+EXTERN int TclInThreadExit _ANSI_ARGS_((void));
+/* 173 */
+EXTERN int TclUniCharMatch _ANSI_ARGS_((
+ CONST Tcl_UniChar * string, int strLen,
+ CONST Tcl_UniChar * pattern, int ptnLen,
+ int nocase));
+
+typedef struct TclIntStubs {
+ int magic;
+ struct TclIntStubHooks *hooks;
+
+ void *reserved0;
+ int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
+ int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */
+ void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */
+ void *reserved4;
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved5;
+#endif /* MAC_TCL */
+ void (*tclCleanupCommand) _ANSI_ARGS_((Command * cmdPtr)); /* 6 */
+ int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */
+ int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved9;
+#endif /* MAC_TCL */
+ int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
+ void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */
+ void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */
+ int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, Tcl_GlobTypeData * types)); /* 13 */
+ void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */
+ void *reserved15;
+ void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */
+ void *reserved17;
+ void *reserved18;
+ void *reserved19;
+ void *reserved20;
+ void *reserved21;
+ int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
+ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
+ int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
+ void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
+ void *reserved26;
+ int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
+ Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
+ void *reserved29;
+ void *reserved30;
+ char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
+ int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */
+ TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
+ int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
+ void *reserved35;
+ int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 36 */
+ int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
+ int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
+ TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */
+ int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * seekFlagPtr)); /* 40 */
+ Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */
+ char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
+ int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 Tcl_Obj *CONST *objv, int flags)); /* 43 */
+ int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
+ int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
+ int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
+ void *reserved47;
+ void *reserved48;
+ Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
+ void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
+ int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
+ int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 Tcl_Obj *CONST *objv, int flags)); /* 52 */
+ int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 Tcl_Obj *CONST *objv)); /* 53 */
+ int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
+ Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
+ void *reserved56;
+ void *reserved57;
+ Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, CONST char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
+ void *reserved59;
+ int (*tclNeedSpace) _ANSI_ARGS_((CONST char * start, CONST char * end)); /* 60 */
+ Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */
+ int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */
+ int (*tclObjInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 63 */
+ int (*tclObjInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 64 */
+ int (*tclObjInvokeGlobal) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 65 */
+ int (*tclOpenFileChannelDeleteProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 66 */
+ int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */
+ void *reserved68;
+ char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */
+ void *reserved70;
+ void *reserved71;
+ void *reserved72;
+ void *reserved73;
+ void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */
+ unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */
+ unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */
+ void (*tclpGetTime) _ANSI_ARGS_((Tcl_Time * time)); /* 77 */
+ int (*tclpGetTimeZone) _ANSI_ARGS_((unsigned long time)); /* 78 */
+ void *reserved79;
+ void *reserved80;
+ char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
+ void *reserved82;
+ void *reserved83;
+ void *reserved84;
+ void *reserved85;
+ void *reserved86;
+ void *reserved87;
+ char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, CONST char * name1, CONST char * name2, int flags)); /* 88 */
+ int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */
+ void *reserved90;
+ void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */
+ int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */
+ void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
+ int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 Tcl_Obj *CONST *objv)); /* 94 */
+ void *reserved95;
+ int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
+ void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
+ int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
+ void *reserved99;
+ void *reserved100;
+ char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
+ void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */
+ int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void *reserved104;
+#endif /* MAC_TCL */
+ void *reserved105;
+ int (*tclStatDeleteProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 106 */
+ int (*tclStatInsertProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 107 */
+ void (*tclTeardownNamespace) _ANSI_ARGS_((Namespace * nsPtr)); /* 108 */
+ int (*tclUpdateReturnInfo) _ANSI_ARGS_((Interp * iPtr)); /* 109 */
+ void *reserved110;
+ void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */
+ int (*tcl_AppendExportList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, Tcl_Obj * objPtr)); /* 112 */
+ Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
+ void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */
+ int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 115 */
+ Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
+ Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
+ int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
+ int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */
+ Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */
+ int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern)); /* 121 */
+ Tcl_Command (*tcl_GetCommandFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 122 */
+ void (*tcl_GetCommandFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); /* 123 */
+ Tcl_Namespace * (*tcl_GetCurrentNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 124 */
+ Tcl_Namespace * (*tcl_GetGlobalNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 125 */
+ void (*tcl_GetVariableFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr)); /* 126 */
+ int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 127 */
+ void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp* interp)); /* 128 */
+ int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */
+ int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 130 */
+ void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */
+ int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */
+ struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */
+ size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t, int useGMT)); /* 134 */
+ int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */
+ void *reserved136;
+ void *reserved137;
+ CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
+ void *reserved139;
+ int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */
+ CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
+ int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
+ int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
+ void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
+ struct AuxDataType * (*tclGetAuxDataType) _ANSI_ARGS_((char * typeName)); /* 145 */
+ TclHandle (*tclHandleCreate) _ANSI_ARGS_((VOID * ptr)); /* 146 */
+ void (*tclHandleFree) _ANSI_ARGS_((TclHandle handle)); /* 147 */
+ TclHandle (*tclHandlePreserve) _ANSI_ARGS_((TclHandle handle)); /* 148 */
+ void (*tclHandleRelease) _ANSI_ARGS_((TclHandle handle)); /* 149 */
+ int (*tclRegAbout) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp re)); /* 150 */
+ void (*tclRegExpRangeUniChar) _ANSI_ARGS_((Tcl_RegExp re, int index, int * startPtr, int * endPtr)); /* 151 */
+ void (*tclSetLibraryPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 152 */
+ Tcl_Obj * (*tclGetLibraryPath) _ANSI_ARGS_((void)); /* 153 */
+ void *reserved154;
+ void *reserved155;
+ void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 156 */
+ Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 157 */
+ void (*tclSetStartupScriptFileName) _ANSI_ARGS_((CONST char * filename)); /* 158 */
+ CONST84_RETURN char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
+ void *reserved160;
+ int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */
+ void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */
+ void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */
+ void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */
+ void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */
+ int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */
+ void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
+ Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
+ int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */
+ int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */
+ int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
+ int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */
+ int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */
+} TclIntStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TclIntStubs *tclIntStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+/* Slot 0 is reserved */
+#ifndef TclAccessDeleteProc
+#define TclAccessDeleteProc \
+ (tclIntStubsPtr->tclAccessDeleteProc) /* 1 */
+#endif
+#ifndef TclAccessInsertProc
+#define TclAccessInsertProc \
+ (tclIntStubsPtr->tclAccessInsertProc) /* 2 */
+#endif
+#ifndef TclAllocateFreeObjects
+#define TclAllocateFreeObjects \
+ (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */
+#endif
+/* Slot 4 is reserved */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef TclCleanupChildren
+#define TclCleanupChildren \
+ (tclIntStubsPtr->tclCleanupChildren) /* 5 */
+#endif
+#endif /* UNIX */
+#ifdef __WIN32__
+#ifndef TclCleanupChildren
+#define TclCleanupChildren \
+ (tclIntStubsPtr->tclCleanupChildren) /* 5 */
+#endif
+#endif /* __WIN32__ */
+#ifndef TclCleanupCommand
+#define TclCleanupCommand \
+ (tclIntStubsPtr->tclCleanupCommand) /* 6 */
+#endif
+#ifndef TclCopyAndCollapse
+#define TclCopyAndCollapse \
+ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */
+#endif
+#ifndef TclCopyChannel
+#define TclCopyChannel \
+ (tclIntStubsPtr->tclCopyChannel) /* 8 */
+#endif
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef TclCreatePipeline
+#define TclCreatePipeline \
+ (tclIntStubsPtr->tclCreatePipeline) /* 9 */
+#endif
+#endif /* UNIX */
+#ifdef __WIN32__
+#ifndef TclCreatePipeline
+#define TclCreatePipeline \
+ (tclIntStubsPtr->tclCreatePipeline) /* 9 */
+#endif
+#endif /* __WIN32__ */
+#ifndef TclCreateProc
+#define TclCreateProc \
+ (tclIntStubsPtr->tclCreateProc) /* 10 */
+#endif
+#ifndef TclDeleteCompiledLocalVars
+#define TclDeleteCompiledLocalVars \
+ (tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */
+#endif
+#ifndef TclDeleteVars
+#define TclDeleteVars \
+ (tclIntStubsPtr->tclDeleteVars) /* 12 */
+#endif
+#ifndef TclDoGlob
+#define TclDoGlob \
+ (tclIntStubsPtr->tclDoGlob) /* 13 */
+#endif
+#ifndef TclDumpMemoryInfo
+#define TclDumpMemoryInfo \
+ (tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */
+#endif
+/* Slot 15 is reserved */
+#ifndef TclExprFloatError
+#define TclExprFloatError \
+ (tclIntStubsPtr->tclExprFloatError) /* 16 */
+#endif
+/* Slot 17 is reserved */
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+/* Slot 21 is reserved */
+#ifndef TclFindElement
+#define TclFindElement \
+ (tclIntStubsPtr->tclFindElement) /* 22 */
+#endif
+#ifndef TclFindProc
+#define TclFindProc \
+ (tclIntStubsPtr->tclFindProc) /* 23 */
+#endif
+#ifndef TclFormatInt
+#define TclFormatInt \
+ (tclIntStubsPtr->tclFormatInt) /* 24 */
+#endif
+#ifndef TclFreePackageInfo
+#define TclFreePackageInfo \
+ (tclIntStubsPtr->tclFreePackageInfo) /* 25 */
+#endif
+/* Slot 26 is reserved */
+#ifndef TclGetDate
+#define TclGetDate \
+ (tclIntStubsPtr->tclGetDate) /* 27 */
+#endif
+#ifndef TclpGetDefaultStdChannel
+#define TclpGetDefaultStdChannel \
+ (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
+#endif
+/* Slot 29 is reserved */
+/* Slot 30 is reserved */
+#ifndef TclGetExtension
+#define TclGetExtension \
+ (tclIntStubsPtr->tclGetExtension) /* 31 */
+#endif
+#ifndef TclGetFrame
+#define TclGetFrame \
+ (tclIntStubsPtr->tclGetFrame) /* 32 */
+#endif
+#ifndef TclGetInterpProc
+#define TclGetInterpProc \
+ (tclIntStubsPtr->tclGetInterpProc) /* 33 */
+#endif
+#ifndef TclGetIntForIndex
+#define TclGetIntForIndex \
+ (tclIntStubsPtr->tclGetIntForIndex) /* 34 */
+#endif
+/* Slot 35 is reserved */
+#ifndef TclGetLong
+#define TclGetLong \
+ (tclIntStubsPtr->tclGetLong) /* 36 */
+#endif
+#ifndef TclGetLoadedPackages
+#define TclGetLoadedPackages \
+ (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */
+#endif
+#ifndef TclGetNamespaceForQualName
+#define TclGetNamespaceForQualName \
+ (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */
+#endif
+#ifndef TclGetObjInterpProc
+#define TclGetObjInterpProc \
+ (tclIntStubsPtr->tclGetObjInterpProc) /* 39 */
+#endif
+#ifndef TclGetOpenMode
+#define TclGetOpenMode \
+ (tclIntStubsPtr->tclGetOpenMode) /* 40 */
+#endif
+#ifndef TclGetOriginalCommand
+#define TclGetOriginalCommand \
+ (tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
+#endif
+#ifndef TclpGetUserHome
+#define TclpGetUserHome \
+ (tclIntStubsPtr->tclpGetUserHome) /* 42 */
+#endif
+#ifndef TclGlobalInvoke
+#define TclGlobalInvoke \
+ (tclIntStubsPtr->tclGlobalInvoke) /* 43 */
+#endif
+#ifndef TclGuessPackageName
+#define TclGuessPackageName \
+ (tclIntStubsPtr->tclGuessPackageName) /* 44 */
+#endif
+#ifndef TclHideUnsafeCommands
+#define TclHideUnsafeCommands \
+ (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */
+#endif
+#ifndef TclInExit
+#define TclInExit \
+ (tclIntStubsPtr->tclInExit) /* 46 */
+#endif
+/* Slot 47 is reserved */
+/* Slot 48 is reserved */
+#ifndef TclIncrVar2
+#define TclIncrVar2 \
+ (tclIntStubsPtr->tclIncrVar2) /* 49 */
+#endif
+#ifndef TclInitCompiledLocals
+#define TclInitCompiledLocals \
+ (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
+#endif
+#ifndef TclInterpInit
+#define TclInterpInit \
+ (tclIntStubsPtr->tclInterpInit) /* 51 */
+#endif
+#ifndef TclInvoke
+#define TclInvoke \
+ (tclIntStubsPtr->tclInvoke) /* 52 */
+#endif
+#ifndef TclInvokeObjectCommand
+#define TclInvokeObjectCommand \
+ (tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */
+#endif
+#ifndef TclInvokeStringCommand
+#define TclInvokeStringCommand \
+ (tclIntStubsPtr->tclInvokeStringCommand) /* 54 */
+#endif
+#ifndef TclIsProc
+#define TclIsProc \
+ (tclIntStubsPtr->tclIsProc) /* 55 */
+#endif
+/* Slot 56 is reserved */
+/* Slot 57 is reserved */
+#ifndef TclLookupVar
+#define TclLookupVar \
+ (tclIntStubsPtr->tclLookupVar) /* 58 */
+#endif
+/* Slot 59 is reserved */
+#ifndef TclNeedSpace
+#define TclNeedSpace \
+ (tclIntStubsPtr->tclNeedSpace) /* 60 */
+#endif
+#ifndef TclNewProcBodyObj
+#define TclNewProcBodyObj \
+ (tclIntStubsPtr->tclNewProcBodyObj) /* 61 */
+#endif
+#ifndef TclObjCommandComplete
+#define TclObjCommandComplete \
+ (tclIntStubsPtr->tclObjCommandComplete) /* 62 */
+#endif
+#ifndef TclObjInterpProc
+#define TclObjInterpProc \
+ (tclIntStubsPtr->tclObjInterpProc) /* 63 */
+#endif
+#ifndef TclObjInvoke
+#define TclObjInvoke \
+ (tclIntStubsPtr->tclObjInvoke) /* 64 */
+#endif
+#ifndef TclObjInvokeGlobal
+#define TclObjInvokeGlobal \
+ (tclIntStubsPtr->tclObjInvokeGlobal) /* 65 */
+#endif
+#ifndef TclOpenFileChannelDeleteProc
+#define TclOpenFileChannelDeleteProc \
+ (tclIntStubsPtr->tclOpenFileChannelDeleteProc) /* 66 */
+#endif
+#ifndef TclOpenFileChannelInsertProc
+#define TclOpenFileChannelInsertProc \
+ (tclIntStubsPtr->tclOpenFileChannelInsertProc) /* 67 */
+#endif
+/* Slot 68 is reserved */
+#ifndef TclpAlloc
+#define TclpAlloc \
+ (tclIntStubsPtr->tclpAlloc) /* 69 */
+#endif
+/* Slot 70 is reserved */
+/* Slot 71 is reserved */
+/* Slot 72 is reserved */
+/* Slot 73 is reserved */
+#ifndef TclpFree
+#define TclpFree \
+ (tclIntStubsPtr->tclpFree) /* 74 */
+#endif
+#ifndef TclpGetClicks
+#define TclpGetClicks \
+ (tclIntStubsPtr->tclpGetClicks) /* 75 */
+#endif
+#ifndef TclpGetSeconds
+#define TclpGetSeconds \
+ (tclIntStubsPtr->tclpGetSeconds) /* 76 */
+#endif
+#ifndef TclpGetTime
+#define TclpGetTime \
+ (tclIntStubsPtr->tclpGetTime) /* 77 */
+#endif
+#ifndef TclpGetTimeZone
+#define TclpGetTimeZone \
+ (tclIntStubsPtr->tclpGetTimeZone) /* 78 */
+#endif
+/* Slot 79 is reserved */
+/* Slot 80 is reserved */
+#ifndef TclpRealloc
+#define TclpRealloc \
+ (tclIntStubsPtr->tclpRealloc) /* 81 */
+#endif
+/* Slot 82 is reserved */
+/* Slot 83 is reserved */
+/* Slot 84 is reserved */
+/* Slot 85 is reserved */
+/* Slot 86 is reserved */
+/* Slot 87 is reserved */
+#ifndef TclPrecTraceProc
+#define TclPrecTraceProc \
+ (tclIntStubsPtr->tclPrecTraceProc) /* 88 */
+#endif
+#ifndef TclPreventAliasLoop
+#define TclPreventAliasLoop \
+ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */
+#endif
+/* Slot 90 is reserved */
+#ifndef TclProcCleanupProc
+#define TclProcCleanupProc \
+ (tclIntStubsPtr->tclProcCleanupProc) /* 91 */
+#endif
+#ifndef TclProcCompileProc
+#define TclProcCompileProc \
+ (tclIntStubsPtr->tclProcCompileProc) /* 92 */
+#endif
+#ifndef TclProcDeleteProc
+#define TclProcDeleteProc \
+ (tclIntStubsPtr->tclProcDeleteProc) /* 93 */
+#endif
+#ifndef TclProcInterpProc
+#define TclProcInterpProc \
+ (tclIntStubsPtr->tclProcInterpProc) /* 94 */
+#endif
+/* Slot 95 is reserved */
+#ifndef TclRenameCommand
+#define TclRenameCommand \
+ (tclIntStubsPtr->tclRenameCommand) /* 96 */
+#endif
+#ifndef TclResetShadowedCmdRefs
+#define TclResetShadowedCmdRefs \
+ (tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */
+#endif
+#ifndef TclServiceIdle
+#define TclServiceIdle \
+ (tclIntStubsPtr->tclServiceIdle) /* 98 */
+#endif
+/* Slot 99 is reserved */
+/* Slot 100 is reserved */
+#ifndef TclSetPreInitScript
+#define TclSetPreInitScript \
+ (tclIntStubsPtr->tclSetPreInitScript) /* 101 */
+#endif
+#ifndef TclSetupEnv
+#define TclSetupEnv \
+ (tclIntStubsPtr->tclSetupEnv) /* 102 */
+#endif
+#ifndef TclSockGetPort
+#define TclSockGetPort \
+ (tclIntStubsPtr->tclSockGetPort) /* 103 */
+#endif
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef TclSockMinimumBuffers
+#define TclSockMinimumBuffers \
+ (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */
+#endif
+#endif /* UNIX */
+#ifdef __WIN32__
+#ifndef TclSockMinimumBuffers
+#define TclSockMinimumBuffers \
+ (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */
+#endif
+#endif /* __WIN32__ */
+/* Slot 105 is reserved */
+#ifndef TclStatDeleteProc
+#define TclStatDeleteProc \
+ (tclIntStubsPtr->tclStatDeleteProc) /* 106 */
+#endif
+#ifndef TclStatInsertProc
+#define TclStatInsertProc \
+ (tclIntStubsPtr->tclStatInsertProc) /* 107 */
+#endif
+#ifndef TclTeardownNamespace
+#define TclTeardownNamespace \
+ (tclIntStubsPtr->tclTeardownNamespace) /* 108 */
+#endif
+#ifndef TclUpdateReturnInfo
+#define TclUpdateReturnInfo \
+ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */
+#endif
+/* Slot 110 is reserved */
+#ifndef Tcl_AddInterpResolvers
+#define Tcl_AddInterpResolvers \
+ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
+#endif
+#ifndef Tcl_AppendExportList
+#define Tcl_AppendExportList \
+ (tclIntStubsPtr->tcl_AppendExportList) /* 112 */
+#endif
+#ifndef Tcl_CreateNamespace
+#define Tcl_CreateNamespace \
+ (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
+#endif
+#ifndef Tcl_DeleteNamespace
+#define Tcl_DeleteNamespace \
+ (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
+#endif
+#ifndef Tcl_Export
+#define Tcl_Export \
+ (tclIntStubsPtr->tcl_Export) /* 115 */
+#endif
+#ifndef Tcl_FindCommand
+#define Tcl_FindCommand \
+ (tclIntStubsPtr->tcl_FindCommand) /* 116 */
+#endif
+#ifndef Tcl_FindNamespace
+#define Tcl_FindNamespace \
+ (tclIntStubsPtr->tcl_FindNamespace) /* 117 */
+#endif
+#ifndef Tcl_GetInterpResolvers
+#define Tcl_GetInterpResolvers \
+ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
+#endif
+#ifndef Tcl_GetNamespaceResolvers
+#define Tcl_GetNamespaceResolvers \
+ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
+#endif
+#ifndef Tcl_FindNamespaceVar
+#define Tcl_FindNamespaceVar \
+ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
+#endif
+#ifndef Tcl_ForgetImport
+#define Tcl_ForgetImport \
+ (tclIntStubsPtr->tcl_ForgetImport) /* 121 */
+#endif
+#ifndef Tcl_GetCommandFromObj
+#define Tcl_GetCommandFromObj \
+ (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
+#endif
+#ifndef Tcl_GetCommandFullName
+#define Tcl_GetCommandFullName \
+ (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
+#endif
+#ifndef Tcl_GetCurrentNamespace
+#define Tcl_GetCurrentNamespace \
+ (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
+#endif
+#ifndef Tcl_GetGlobalNamespace
+#define Tcl_GetGlobalNamespace \
+ (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
+#endif
+#ifndef Tcl_GetVariableFullName
+#define Tcl_GetVariableFullName \
+ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
+#endif
+#ifndef Tcl_Import
+#define Tcl_Import \
+ (tclIntStubsPtr->tcl_Import) /* 127 */
+#endif
+#ifndef Tcl_PopCallFrame
+#define Tcl_PopCallFrame \
+ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
+#endif
+#ifndef Tcl_PushCallFrame
+#define Tcl_PushCallFrame \
+ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */
+#endif
+#ifndef Tcl_RemoveInterpResolvers
+#define Tcl_RemoveInterpResolvers \
+ (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */
+#endif
+#ifndef Tcl_SetNamespaceResolvers
+#define Tcl_SetNamespaceResolvers \
+ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */
+#endif
+#ifndef TclpHasSockets
+#define TclpHasSockets \
+ (tclIntStubsPtr->tclpHasSockets) /* 132 */
+#endif
+#ifndef TclpGetDate
+#define TclpGetDate \
+ (tclIntStubsPtr->tclpGetDate) /* 133 */
+#endif
+#ifndef TclpStrftime
+#define TclpStrftime \
+ (tclIntStubsPtr->tclpStrftime) /* 134 */
+#endif
+#ifndef TclpCheckStackSpace
+#define TclpCheckStackSpace \
+ (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */
+#endif
+/* Slot 136 is reserved */
+/* Slot 137 is reserved */
+#ifndef TclGetEnv
+#define TclGetEnv \
+ (tclIntStubsPtr->tclGetEnv) /* 138 */
+#endif
+/* Slot 139 is reserved */
+#ifndef TclLooksLikeInt
+#define TclLooksLikeInt \
+ (tclIntStubsPtr->tclLooksLikeInt) /* 140 */
+#endif
+#ifndef TclpGetCwd
+#define TclpGetCwd \
+ (tclIntStubsPtr->tclpGetCwd) /* 141 */
+#endif
+#ifndef TclSetByteCodeFromAny
+#define TclSetByteCodeFromAny \
+ (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */
+#endif
+#ifndef TclAddLiteralObj
+#define TclAddLiteralObj \
+ (tclIntStubsPtr->tclAddLiteralObj) /* 143 */
+#endif
+#ifndef TclHideLiteral
+#define TclHideLiteral \
+ (tclIntStubsPtr->tclHideLiteral) /* 144 */
+#endif
+#ifndef TclGetAuxDataType
+#define TclGetAuxDataType \
+ (tclIntStubsPtr->tclGetAuxDataType) /* 145 */
+#endif
+#ifndef TclHandleCreate
+#define TclHandleCreate \
+ (tclIntStubsPtr->tclHandleCreate) /* 146 */
+#endif
+#ifndef TclHandleFree
+#define TclHandleFree \
+ (tclIntStubsPtr->tclHandleFree) /* 147 */
+#endif
+#ifndef TclHandlePreserve
+#define TclHandlePreserve \
+ (tclIntStubsPtr->tclHandlePreserve) /* 148 */
+#endif
+#ifndef TclHandleRelease
+#define TclHandleRelease \
+ (tclIntStubsPtr->tclHandleRelease) /* 149 */
+#endif
+#ifndef TclRegAbout
+#define TclRegAbout \
+ (tclIntStubsPtr->tclRegAbout) /* 150 */
+#endif
+#ifndef TclRegExpRangeUniChar
+#define TclRegExpRangeUniChar \
+ (tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */
+#endif
+#ifndef TclSetLibraryPath
+#define TclSetLibraryPath \
+ (tclIntStubsPtr->tclSetLibraryPath) /* 152 */
+#endif
+#ifndef TclGetLibraryPath
+#define TclGetLibraryPath \
+ (tclIntStubsPtr->tclGetLibraryPath) /* 153 */
+#endif
+/* Slot 154 is reserved */
+/* Slot 155 is reserved */
+#ifndef TclRegError
+#define TclRegError \
+ (tclIntStubsPtr->tclRegError) /* 156 */
+#endif
+#ifndef TclVarTraceExists
+#define TclVarTraceExists \
+ (tclIntStubsPtr->tclVarTraceExists) /* 157 */
+#endif
+#ifndef TclSetStartupScriptFileName
+#define TclSetStartupScriptFileName \
+ (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */
+#endif
+#ifndef TclGetStartupScriptFileName
+#define TclGetStartupScriptFileName \
+ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
+#endif
+/* Slot 160 is reserved */
+#ifndef TclChannelTransform
+#define TclChannelTransform \
+ (tclIntStubsPtr->tclChannelTransform) /* 161 */
+#endif
+#ifndef TclChannelEventScriptInvoker
+#define TclChannelEventScriptInvoker \
+ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */
+#endif
+#ifndef TclGetInstructionTable
+#define TclGetInstructionTable \
+ (tclIntStubsPtr->tclGetInstructionTable) /* 163 */
+#endif
+#ifndef TclExpandCodeArray
+#define TclExpandCodeArray \
+ (tclIntStubsPtr->tclExpandCodeArray) /* 164 */
+#endif
+#ifndef TclpSetInitialEncodings
+#define TclpSetInitialEncodings \
+ (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */
+#endif
+#ifndef TclListObjSetElement
+#define TclListObjSetElement \
+ (tclIntStubsPtr->tclListObjSetElement) /* 166 */
+#endif
+#ifndef TclSetStartupScriptPath
+#define TclSetStartupScriptPath \
+ (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */
+#endif
+#ifndef TclGetStartupScriptPath
+#define TclGetStartupScriptPath \
+ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
+#endif
+#ifndef TclpUtfNcmp2
+#define TclpUtfNcmp2 \
+ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
+#endif
+#ifndef TclCheckInterpTraces
+#define TclCheckInterpTraces \
+ (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */
+#endif
+#ifndef TclCheckExecutionTraces
+#define TclCheckExecutionTraces \
+ (tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */
+#endif
+#ifndef TclInThreadExit
+#define TclInThreadExit \
+ (tclIntStubsPtr->tclInThreadExit) /* 172 */
+#endif
+#ifndef TclUniCharMatch
+#define TclUniCharMatch \
+ (tclIntStubsPtr->tclUniCharMatch) /* 173 */
+#endif
+
+#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#endif /* _TCLINTDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntPlatDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntPlatDecls.h
new file mode 100755
index 00000000000..d69d3e9eead
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclIntPlatDecls.h
@@ -0,0 +1,585 @@
+/*
+ * tclIntPlatDecls.h --
+ *
+ * This file contains the declarations for all platform dependent
+ * unsupported functions that are exported by the Tcl library. These
+ * interfaces are not guaranteed to remain the same between
+ * versions. Use at your own risk.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * All rights reserved.
+ *
+ * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.19 2002/12/06 23:22:59 hobbs Exp $
+ */
+
+#ifndef _TCLINTPLATDECLS
+#define _TCLINTPLATDECLS
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tclInt.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* 0 */
+EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel chan));
+/* 1 */
+EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file));
+/* 2 */
+EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_((
+ TclFile readFile, TclFile writeFile,
+ TclFile errorFile, int numPids,
+ Tcl_Pid * pidPtr));
+/* 3 */
+EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile * readPipe,
+ TclFile * writePipe));
+/* 4 */
+EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp,
+ int argc, Tcl_Obj *CONST *objv,
+ TclFile inputFile, TclFile outputFile,
+ TclFile errorFile, Tcl_Pid * pidPtr));
+/* Slot 5 is reserved */
+/* 6 */
+EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
+ int direction));
+/* 7 */
+EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname,
+ int mode));
+/* 8 */
+EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask,
+ int timeout));
+/* 9 */
+EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((
+ CONST char * contents));
+/* 10 */
+EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR * dir));
+/* 11 */
+EXTERN struct tm * TclpLocaltime _ANSI_ARGS_((time_t * clock));
+/* 12 */
+EXTERN struct tm * TclpGmtime _ANSI_ARGS_((time_t * clock));
+/* 13 */
+EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr));
+#endif /* UNIX */
+#ifdef __WIN32__
+/* 0 */
+EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode));
+/* 1 */
+EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode));
+/* 2 */
+EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((CONST char * nm,
+ CONST char * proto));
+/* 3 */
+EXTERN int TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level,
+ int optname, char FAR * optval,
+ int FAR * optlen));
+/* 4 */
+EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void));
+/* Slot 5 is reserved */
+/* 6 */
+EXTERN u_short TclWinNToHS _ANSI_ARGS_((u_short ns));
+/* 7 */
+EXTERN int TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level,
+ int optname, CONST char FAR * optval,
+ int optlen));
+/* 8 */
+EXTERN unsigned long TclpGetPid _ANSI_ARGS_((Tcl_Pid pid));
+/* 9 */
+EXTERN int TclWinGetPlatformId _ANSI_ARGS_((void));
+/* Slot 10 is reserved */
+/* 11 */
+EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Channel chan));
+/* 12 */
+EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file));
+/* 13 */
+EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_((
+ TclFile readFile, TclFile writeFile,
+ TclFile errorFile, int numPids,
+ Tcl_Pid * pidPtr));
+/* 14 */
+EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile * readPipe,
+ TclFile * writePipe));
+/* 15 */
+EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp,
+ int argc, Tcl_Obj *CONST *objv,
+ TclFile inputFile, TclFile outputFile,
+ TclFile errorFile, Tcl_Pid * pidPtr));
+/* Slot 16 is reserved */
+/* Slot 17 is reserved */
+/* 18 */
+EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
+ int direction));
+/* 19 */
+EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname,
+ int mode));
+/* 20 */
+EXTERN void TclWinAddProcess _ANSI_ARGS_((HANDLE hProcess,
+ DWORD id));
+/* Slot 21 is reserved */
+/* 22 */
+EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((
+ CONST char * contents));
+/* 23 */
+EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst));
+/* 24 */
+EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path));
+/* 25 */
+EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void));
+/* 26 */
+EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide));
+/* 27 */
+EXTERN void TclWinFlushDirtyChannels _ANSI_ARGS_((void));
+/* 28 */
+EXTERN void TclWinResetInterfaces _ANSI_ARGS_((void));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 0 */
+EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin));
+/* 1 */
+EXTERN void TclpSysFree _ANSI_ARGS_((VOID * ptr));
+/* 2 */
+EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID * cp,
+ unsigned int size));
+/* 3 */
+EXTERN void TclpExit _ANSI_ARGS_((int status));
+/* 4 */
+EXTERN int FSpGetDefaultDir _ANSI_ARGS_((FSSpecPtr theSpec));
+/* 5 */
+EXTERN int FSpSetDefaultDir _ANSI_ARGS_((FSSpecPtr theSpec));
+/* 6 */
+EXTERN OSErr FSpFindFolder _ANSI_ARGS_((short vRefNum,
+ OSType folderType, Boolean createFolder,
+ FSSpec * spec));
+/* 7 */
+EXTERN void GetGlobalMouseTcl _ANSI_ARGS_((Point * mouse));
+/* 8 */
+EXTERN pascal OSErr FSpGetDirectoryIDTcl _ANSI_ARGS_((
+ CONST FSSpec * spec, long * theDirID,
+ Boolean * isDirectory));
+/* 9 */
+EXTERN pascal short FSpOpenResFileCompatTcl _ANSI_ARGS_((
+ CONST FSSpec * spec, SignedByte permission));
+/* 10 */
+EXTERN pascal void FSpCreateResFileCompatTcl _ANSI_ARGS_((
+ CONST FSSpec * spec, OSType creator,
+ OSType fileType, ScriptCode scriptTag));
+/* 11 */
+EXTERN int FSpLocationFromPath _ANSI_ARGS_((int length,
+ CONST char * path, FSSpecPtr theSpec));
+/* 12 */
+EXTERN OSErr FSpPathFromLocation _ANSI_ARGS_((FSSpecPtr theSpec,
+ int * length, Handle * fullPath));
+/* 13 */
+EXTERN void TclMacExitHandler _ANSI_ARGS_((void));
+/* 14 */
+EXTERN void TclMacInitExitToShell _ANSI_ARGS_((int usePatch));
+/* 15 */
+EXTERN OSErr TclMacInstallExitToShellPatch _ANSI_ARGS_((
+ ExitToShellProcPtr newProc));
+/* 16 */
+EXTERN int TclMacOSErrorToPosixError _ANSI_ARGS_((int error));
+/* 17 */
+EXTERN void TclMacRemoveTimer _ANSI_ARGS_((void * timerToken));
+/* 18 */
+EXTERN void * TclMacStartTimer _ANSI_ARGS_((long ms));
+/* 19 */
+EXTERN int TclMacTimerExpired _ANSI_ARGS_((void * timerToken));
+/* 20 */
+EXTERN int TclMacRegisterResourceFork _ANSI_ARGS_((
+ short fileRef, Tcl_Obj * tokenPtr,
+ int insert));
+/* 21 */
+EXTERN short TclMacUnRegisterResourceFork _ANSI_ARGS_((
+ char * tokenPtr, Tcl_Obj * resultPtr));
+/* 22 */
+EXTERN int TclMacCreateEnv _ANSI_ARGS_((void));
+/* 23 */
+EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((CONST char * path,
+ CONST char * mode));
+/* 24 */
+EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst));
+/* 25 */
+EXTERN int TclMacChmod _ANSI_ARGS_((CONST char * path, int mode));
+/* 26 */
+EXTERN int FSpLLocationFromPath _ANSI_ARGS_((int length,
+ CONST char * path, FSSpecPtr theSpec));
+#endif /* MAC_TCL */
+
+typedef struct TclIntPlatStubs {
+ int magic;
+ struct TclIntPlatStubHooks *hooks;
+
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 0 */
+ int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */
+ Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */
+ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */
+ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
+ void *reserved5;
+ TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
+ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */
+ int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
+ TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */
+ Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR * dir)); /* 10 */
+ struct tm * (*tclpLocaltime) _ANSI_ARGS_((time_t * clock)); /* 11 */
+ struct tm * (*tclpGmtime) _ANSI_ARGS_((time_t * clock)); /* 12 */
+ char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 13 */
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */
+ void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */
+ struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char * nm, CONST char * proto)); /* 2 */
+ int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 3 */
+ HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */
+ void *reserved5;
+ u_short (*tclWinNToHS) _ANSI_ARGS_((u_short ns)); /* 6 */
+ int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, CONST char FAR * optval, int optlen)); /* 7 */
+ unsigned long (*tclpGetPid) _ANSI_ARGS_((Tcl_Pid pid)); /* 8 */
+ int (*tclWinGetPlatformId) _ANSI_ARGS_((void)); /* 9 */
+ void *reserved10;
+ void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 11 */
+ int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 12 */
+ Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 13 */
+ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 14 */
+ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */
+ void *reserved16;
+ void *reserved17;
+ TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */
+ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */
+ void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */
+ void *reserved21;
+ TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */
+ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
+ char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */
+ TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */
+ void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */
+ void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */
+ void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */
+ void (*tclpSysFree) _ANSI_ARGS_((VOID * ptr)); /* 1 */
+ VOID * (*tclpSysRealloc) _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 2 */
+ void (*tclpExit) _ANSI_ARGS_((int status)); /* 3 */
+ int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */
+ int (*fSpSetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */
+ OSErr (*fSpFindFolder) _ANSI_ARGS_((short vRefNum, OSType folderType, Boolean createFolder, FSSpec * spec)); /* 6 */
+ void (*getGlobalMouseTcl) _ANSI_ARGS_((Point * mouse)); /* 7 */
+ pascal OSErr (*fSpGetDirectoryIDTcl) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */
+ pascal short (*fSpOpenResFileCompatTcl) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */
+ pascal void (*fSpCreateResFileCompatTcl) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */
+ int (*fSpLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 11 */
+ OSErr (*fSpPathFromLocation) _ANSI_ARGS_((FSSpecPtr theSpec, int * length, Handle * fullPath)); /* 12 */
+ void (*tclMacExitHandler) _ANSI_ARGS_((void)); /* 13 */
+ void (*tclMacInitExitToShell) _ANSI_ARGS_((int usePatch)); /* 14 */
+ OSErr (*tclMacInstallExitToShellPatch) _ANSI_ARGS_((ExitToShellProcPtr newProc)); /* 15 */
+ int (*tclMacOSErrorToPosixError) _ANSI_ARGS_((int error)); /* 16 */
+ void (*tclMacRemoveTimer) _ANSI_ARGS_((void * timerToken)); /* 17 */
+ void * (*tclMacStartTimer) _ANSI_ARGS_((long ms)); /* 18 */
+ int (*tclMacTimerExpired) _ANSI_ARGS_((void * timerToken)); /* 19 */
+ int (*tclMacRegisterResourceFork) _ANSI_ARGS_((short fileRef, Tcl_Obj * tokenPtr, int insert)); /* 20 */
+ short (*tclMacUnRegisterResourceFork) _ANSI_ARGS_((char * tokenPtr, Tcl_Obj * resultPtr)); /* 21 */
+ int (*tclMacCreateEnv) _ANSI_ARGS_((void)); /* 22 */
+ FILE * (*tclMacFOpenHack) _ANSI_ARGS_((CONST char * path, CONST char * mode)); /* 23 */
+ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 24 */
+ int (*tclMacChmod) _ANSI_ARGS_((CONST char * path, int mode)); /* 25 */
+ int (*fSpLLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 26 */
+#endif /* MAC_TCL */
+} TclIntPlatStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TclIntPlatStubs *tclIntPlatStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+#ifndef TclGetAndDetachPids
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
+#endif
+#ifndef TclpCloseFile
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
+#endif
+#ifndef TclpCreateCommandChannel
+#define TclpCreateCommandChannel \
+ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
+#endif
+#ifndef TclpCreatePipe
+#define TclpCreatePipe \
+ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
+#endif
+#ifndef TclpCreateProcess
+#define TclpCreateProcess \
+ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
+#endif
+/* Slot 5 is reserved */
+#ifndef TclpMakeFile
+#define TclpMakeFile \
+ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
+#endif
+#ifndef TclpOpenFile
+#define TclpOpenFile \
+ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
+#endif
+#ifndef TclUnixWaitForFile
+#define TclUnixWaitForFile \
+ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
+#endif
+#ifndef TclpCreateTempFile
+#define TclpCreateTempFile \
+ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
+#endif
+#ifndef TclpReaddir
+#define TclpReaddir \
+ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */
+#endif
+#ifndef TclpLocaltime
+#define TclpLocaltime \
+ (tclIntPlatStubsPtr->tclpLocaltime) /* 11 */
+#endif
+#ifndef TclpGmtime
+#define TclpGmtime \
+ (tclIntPlatStubsPtr->tclpGmtime) /* 12 */
+#endif
+#ifndef TclpInetNtoa
+#define TclpInetNtoa \
+ (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
+#endif
+#endif /* UNIX */
+#ifdef __WIN32__
+#ifndef TclWinConvertError
+#define TclWinConvertError \
+ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
+#endif
+#ifndef TclWinConvertWSAError
+#define TclWinConvertWSAError \
+ (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
+#endif
+#ifndef TclWinGetServByName
+#define TclWinGetServByName \
+ (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */
+#endif
+#ifndef TclWinGetSockOpt
+#define TclWinGetSockOpt \
+ (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */
+#endif
+#ifndef TclWinGetTclInstance
+#define TclWinGetTclInstance \
+ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
+#endif
+/* Slot 5 is reserved */
+#ifndef TclWinNToHS
+#define TclWinNToHS \
+ (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
+#endif
+#ifndef TclWinSetSockOpt
+#define TclWinSetSockOpt \
+ (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
+#endif
+#ifndef TclpGetPid
+#define TclpGetPid \
+ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */
+#endif
+#ifndef TclWinGetPlatformId
+#define TclWinGetPlatformId \
+ (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
+#endif
+/* Slot 10 is reserved */
+#ifndef TclGetAndDetachPids
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
+#endif
+#ifndef TclpCloseFile
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */
+#endif
+#ifndef TclpCreateCommandChannel
+#define TclpCreateCommandChannel \
+ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */
+#endif
+#ifndef TclpCreatePipe
+#define TclpCreatePipe \
+ (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */
+#endif
+#ifndef TclpCreateProcess
+#define TclpCreateProcess \
+ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */
+#endif
+/* Slot 16 is reserved */
+/* Slot 17 is reserved */
+#ifndef TclpMakeFile
+#define TclpMakeFile \
+ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */
+#endif
+#ifndef TclpOpenFile
+#define TclpOpenFile \
+ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */
+#endif
+#ifndef TclWinAddProcess
+#define TclWinAddProcess \
+ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
+#endif
+/* Slot 21 is reserved */
+#ifndef TclpCreateTempFile
+#define TclpCreateTempFile \
+ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
+#endif
+#ifndef TclpGetTZName
+#define TclpGetTZName \
+ (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
+#endif
+#ifndef TclWinNoBackslash
+#define TclWinNoBackslash \
+ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
+#endif
+#ifndef TclWinGetPlatform
+#define TclWinGetPlatform \
+ (tclIntPlatStubsPtr->tclWinGetPlatform) /* 25 */
+#endif
+#ifndef TclWinSetInterfaces
+#define TclWinSetInterfaces \
+ (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
+#endif
+#ifndef TclWinFlushDirtyChannels
+#define TclWinFlushDirtyChannels \
+ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
+#endif
+#ifndef TclWinResetInterfaces
+#define TclWinResetInterfaces \
+ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TclpSysAlloc
+#define TclpSysAlloc \
+ (tclIntPlatStubsPtr->tclpSysAlloc) /* 0 */
+#endif
+#ifndef TclpSysFree
+#define TclpSysFree \
+ (tclIntPlatStubsPtr->tclpSysFree) /* 1 */
+#endif
+#ifndef TclpSysRealloc
+#define TclpSysRealloc \
+ (tclIntPlatStubsPtr->tclpSysRealloc) /* 2 */
+#endif
+#ifndef TclpExit
+#define TclpExit \
+ (tclIntPlatStubsPtr->tclpExit) /* 3 */
+#endif
+#ifndef FSpGetDefaultDir
+#define FSpGetDefaultDir \
+ (tclIntPlatStubsPtr->fSpGetDefaultDir) /* 4 */
+#endif
+#ifndef FSpSetDefaultDir
+#define FSpSetDefaultDir \
+ (tclIntPlatStubsPtr->fSpSetDefaultDir) /* 5 */
+#endif
+#ifndef FSpFindFolder
+#define FSpFindFolder \
+ (tclIntPlatStubsPtr->fSpFindFolder) /* 6 */
+#endif
+#ifndef GetGlobalMouseTcl
+#define GetGlobalMouseTcl \
+ (tclIntPlatStubsPtr->getGlobalMouseTcl) /* 7 */
+#endif
+#ifndef FSpGetDirectoryIDTcl
+#define FSpGetDirectoryIDTcl \
+ (tclIntPlatStubsPtr->fSpGetDirectoryIDTcl) /* 8 */
+#endif
+#ifndef FSpOpenResFileCompatTcl
+#define FSpOpenResFileCompatTcl \
+ (tclIntPlatStubsPtr->fSpOpenResFileCompatTcl) /* 9 */
+#endif
+#ifndef FSpCreateResFileCompatTcl
+#define FSpCreateResFileCompatTcl \
+ (tclIntPlatStubsPtr->fSpCreateResFileCompatTcl) /* 10 */
+#endif
+#ifndef FSpLocationFromPath
+#define FSpLocationFromPath \
+ (tclIntPlatStubsPtr->fSpLocationFromPath) /* 11 */
+#endif
+#ifndef FSpPathFromLocation
+#define FSpPathFromLocation \
+ (tclIntPlatStubsPtr->fSpPathFromLocation) /* 12 */
+#endif
+#ifndef TclMacExitHandler
+#define TclMacExitHandler \
+ (tclIntPlatStubsPtr->tclMacExitHandler) /* 13 */
+#endif
+#ifndef TclMacInitExitToShell
+#define TclMacInitExitToShell \
+ (tclIntPlatStubsPtr->tclMacInitExitToShell) /* 14 */
+#endif
+#ifndef TclMacInstallExitToShellPatch
+#define TclMacInstallExitToShellPatch \
+ (tclIntPlatStubsPtr->tclMacInstallExitToShellPatch) /* 15 */
+#endif
+#ifndef TclMacOSErrorToPosixError
+#define TclMacOSErrorToPosixError \
+ (tclIntPlatStubsPtr->tclMacOSErrorToPosixError) /* 16 */
+#endif
+#ifndef TclMacRemoveTimer
+#define TclMacRemoveTimer \
+ (tclIntPlatStubsPtr->tclMacRemoveTimer) /* 17 */
+#endif
+#ifndef TclMacStartTimer
+#define TclMacStartTimer \
+ (tclIntPlatStubsPtr->tclMacStartTimer) /* 18 */
+#endif
+#ifndef TclMacTimerExpired
+#define TclMacTimerExpired \
+ (tclIntPlatStubsPtr->tclMacTimerExpired) /* 19 */
+#endif
+#ifndef TclMacRegisterResourceFork
+#define TclMacRegisterResourceFork \
+ (tclIntPlatStubsPtr->tclMacRegisterResourceFork) /* 20 */
+#endif
+#ifndef TclMacUnRegisterResourceFork
+#define TclMacUnRegisterResourceFork \
+ (tclIntPlatStubsPtr->tclMacUnRegisterResourceFork) /* 21 */
+#endif
+#ifndef TclMacCreateEnv
+#define TclMacCreateEnv \
+ (tclIntPlatStubsPtr->tclMacCreateEnv) /* 22 */
+#endif
+#ifndef TclMacFOpenHack
+#define TclMacFOpenHack \
+ (tclIntPlatStubsPtr->tclMacFOpenHack) /* 23 */
+#endif
+#ifndef TclpGetTZName
+#define TclpGetTZName \
+ (tclIntPlatStubsPtr->tclpGetTZName) /* 24 */
+#endif
+#ifndef TclMacChmod
+#define TclMacChmod \
+ (tclIntPlatStubsPtr->tclMacChmod) /* 25 */
+#endif
+#ifndef FSpLLocationFromPath
+#define FSpLLocationFromPath \
+ (tclIntPlatStubsPtr->fSpLLocationFromPath) /* 26 */
+#endif
+#endif /* MAC_TCL */
+
+#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#endif /* _TCLINTPLATDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclMath.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclMath.h
new file mode 100755
index 00000000000..ee1a02e375f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclMath.h
@@ -0,0 +1,27 @@
+/*
+ * tclMath.h --
+ *
+ * This file is necessary because of Metrowerks CodeWarrior Pro 1
+ * on the Macintosh. With 8-byte doubles turned on, the definitions of
+ * sin, cos, acos, etc., are screwed up. They are fine as long as
+ * they are used as function calls, but if the function pointers
+ * are passed around and used, they will crash hard on the 68K.
+ *
+ * Copyright (c) 1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclMath.h,v 1.2 1998/09/14 18:40:01 stanton Exp $
+ */
+
+#ifndef _TCLMATH
+#define _TCLMATH
+
+#if defined(MAC_TCL)
+# include "tclMacMath.h"
+#else
+# include <math.h>
+#endif
+
+#endif /* _TCLMATH */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclPlatDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclPlatDecls.h
new file mode 100755
index 00000000000..3b567dbeb95
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclPlatDecls.h
@@ -0,0 +1,197 @@
+/*
+ * tclPlatDecls.h --
+ *
+ * Declarations of platform specific Tcl APIs.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * All rights reserved.
+ *
+ * RCS: @(#) $Id: tclPlatDecls.h,v 1.18.2.1 2003/05/13 08:41:26 das Exp $
+ */
+
+#ifndef _TCLPLATDECLS
+#define _TCLPLATDECLS
+
+/*
+ * Pull in the typedef of TCHAR for windows.
+ */
+#if defined(__CYGWIN__)
+ typedef char TCHAR;
+#elif defined(__WIN32__) && !defined(_TCHAR_DEFINED)
+# include <tchar.h>
+# ifndef _TCHAR_DEFINED
+ /* Borland seems to forget to set this. */
+ typedef _TCHAR TCHAR;
+# define _TCHAR_DEFINED
+# endif
+# if defined(_MSC_VER) && defined(__STDC__)
+ /* MSVC++ misses this. */
+ typedef _TCHAR TCHAR;
+# endif
+#endif
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+#ifdef __WIN32__
+/* 0 */
+EXTERN TCHAR * Tcl_WinUtfToTChar _ANSI_ARGS_((CONST char * str,
+ int len, Tcl_DString * dsPtr));
+/* 1 */
+EXTERN char * Tcl_WinTCharToUtf _ANSI_ARGS_((CONST TCHAR * str,
+ int len, Tcl_DString * dsPtr));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 0 */
+EXTERN void Tcl_MacSetEventProc _ANSI_ARGS_((
+ Tcl_MacConvertEventPtr procPtr));
+/* 1 */
+EXTERN char * Tcl_MacConvertTextResource _ANSI_ARGS_((
+ Handle resource));
+/* 2 */
+EXTERN int Tcl_MacEvalResource _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * resourceName,
+ int resourceNumber, CONST char * fileName));
+/* 3 */
+EXTERN Handle Tcl_MacFindResource _ANSI_ARGS_((Tcl_Interp * interp,
+ long resourceType, CONST char * resourceName,
+ int resourceNumber, CONST char * resFileRef,
+ int * releaseIt));
+/* 4 */
+EXTERN int Tcl_GetOSTypeFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ OSType * osTypePtr));
+/* 5 */
+EXTERN void Tcl_SetOSTypeObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ OSType osType));
+/* 6 */
+EXTERN Tcl_Obj * Tcl_NewOSTypeObj _ANSI_ARGS_((OSType osType));
+/* 7 */
+EXTERN int strncasecmp _ANSI_ARGS_((CONST char * s1,
+ CONST char * s2, size_t n));
+/* 8 */
+EXTERN int strcasecmp _ANSI_ARGS_((CONST char * s1,
+ CONST char * s2));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TCL
+/* 0 */
+EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * bundleName,
+ int hasResourceFile, int maxPathLen,
+ char * libraryPath));
+/* 1 */
+EXTERN int Tcl_MacOSXOpenVersionedBundleResources _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * bundleName,
+ CONST char * bundleVersion,
+ int hasResourceFile, int maxPathLen,
+ char * libraryPath));
+#endif /* MAC_OSX_TCL */
+
+typedef struct TclPlatStubs {
+ int magic;
+ struct TclPlatStubHooks *hooks;
+
+#ifdef __WIN32__
+ TCHAR * (*tcl_WinUtfToTChar) _ANSI_ARGS_((CONST char * str, int len, Tcl_DString * dsPtr)); /* 0 */
+ char * (*tcl_WinTCharToUtf) _ANSI_ARGS_((CONST TCHAR * str, int len, Tcl_DString * dsPtr)); /* 1 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tcl_MacSetEventProc) _ANSI_ARGS_((Tcl_MacConvertEventPtr procPtr)); /* 0 */
+ char * (*tcl_MacConvertTextResource) _ANSI_ARGS_((Handle resource)); /* 1 */
+ int (*tcl_MacEvalResource) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * resourceName, int resourceNumber, CONST char * fileName)); /* 2 */
+ Handle (*tcl_MacFindResource) _ANSI_ARGS_((Tcl_Interp * interp, long resourceType, CONST char * resourceName, int resourceNumber, CONST char * resFileRef, int * releaseIt)); /* 3 */
+ int (*tcl_GetOSTypeFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, OSType * osTypePtr)); /* 4 */
+ void (*tcl_SetOSTypeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, OSType osType)); /* 5 */
+ Tcl_Obj * (*tcl_NewOSTypeObj) _ANSI_ARGS_((OSType osType)); /* 6 */
+ int (*strncasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 7 */
+ int (*strcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2)); /* 8 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TCL
+ int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 0 */
+ int (*tcl_MacOSXOpenVersionedBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, CONST char * bundleVersion, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 1 */
+#endif /* MAC_OSX_TCL */
+} TclPlatStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TclPlatStubs *tclPlatStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifdef __WIN32__
+#ifndef Tcl_WinUtfToTChar
+#define Tcl_WinUtfToTChar \
+ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
+#endif
+#ifndef Tcl_WinTCharToUtf
+#define Tcl_WinTCharToUtf \
+ (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef Tcl_MacSetEventProc
+#define Tcl_MacSetEventProc \
+ (tclPlatStubsPtr->tcl_MacSetEventProc) /* 0 */
+#endif
+#ifndef Tcl_MacConvertTextResource
+#define Tcl_MacConvertTextResource \
+ (tclPlatStubsPtr->tcl_MacConvertTextResource) /* 1 */
+#endif
+#ifndef Tcl_MacEvalResource
+#define Tcl_MacEvalResource \
+ (tclPlatStubsPtr->tcl_MacEvalResource) /* 2 */
+#endif
+#ifndef Tcl_MacFindResource
+#define Tcl_MacFindResource \
+ (tclPlatStubsPtr->tcl_MacFindResource) /* 3 */
+#endif
+#ifndef Tcl_GetOSTypeFromObj
+#define Tcl_GetOSTypeFromObj \
+ (tclPlatStubsPtr->tcl_GetOSTypeFromObj) /* 4 */
+#endif
+#ifndef Tcl_SetOSTypeObj
+#define Tcl_SetOSTypeObj \
+ (tclPlatStubsPtr->tcl_SetOSTypeObj) /* 5 */
+#endif
+#ifndef Tcl_NewOSTypeObj
+#define Tcl_NewOSTypeObj \
+ (tclPlatStubsPtr->tcl_NewOSTypeObj) /* 6 */
+#endif
+#ifndef strncasecmp
+#define strncasecmp \
+ (tclPlatStubsPtr->strncasecmp) /* 7 */
+#endif
+#ifndef strcasecmp
+#define strcasecmp \
+ (tclPlatStubsPtr->strcasecmp) /* 8 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TCL
+#ifndef Tcl_MacOSXOpenBundleResources
+#define Tcl_MacOSXOpenBundleResources \
+ (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
+#endif
+#ifndef Tcl_MacOSXOpenVersionedBundleResources
+#define Tcl_MacOSXOpenVersionedBundleResources \
+ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
+#endif
+#endif /* MAC_OSX_TCL */
+
+#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#endif /* _TCLPLATDECLS */
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclWinInt.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclWinInt.h
new file mode 100755
index 00000000000..3248ac88f27
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tclWinInt.h
@@ -0,0 +1,145 @@
+/*
+ * tclWinInt.h --
+ *
+ * Declarations of Windows-specific shared variables and procedures.
+ *
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclWinInt.h,v 1.20.2.1 2003/04/14 15:46:01 vincentdarley Exp $
+ */
+
+#ifndef _TCLWININT
+#define _TCLWININT
+
+#ifndef _TCLINT
+#include "tclInt.h"
+#endif
+#ifndef _TCLPORT
+#include "tclPort.h"
+#endif
+
+/*
+ * The following specifies how much stack space TclpCheckStackSpace()
+ * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj()
+ * to help avoid overflowing the stack in the case of infinite recursion.
+ */
+
+#define TCL_WIN_STACK_THRESHOLD 0x2000
+
+#ifdef BUILD_tcl
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Some versions of Borland C have a define for the OSVERSIONINFO for
+ * Win32s and for NT, but not for Windows 95.
+ */
+
+#ifndef VER_PLATFORM_WIN32_WINDOWS
+#define VER_PLATFORM_WIN32_WINDOWS 1
+#endif
+
+/*
+ * The following structure keeps track of whether we are using the
+ * multi-byte or the wide-character interfaces to the operating system.
+ * System calls should be made through the following function table.
+ */
+
+typedef union {
+ WIN32_FIND_DATAA a;
+ WIN32_FIND_DATAW w;
+} WIN32_FIND_DATAT;
+
+typedef struct TclWinProcs {
+ int useWide;
+
+ BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB);
+ TCHAR *(WINAPI *charLowerProc)(TCHAR *);
+ BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL);
+ BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES);
+ HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD,
+ LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE);
+ BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *,
+ LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD,
+ LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION);
+ BOOL (WINAPI *deleteFileProc)(CONST TCHAR *);
+ HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *);
+ BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *);
+ BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD);
+ DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *);
+ DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *);
+ DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength,
+ WCHAR *, TCHAR **);
+ DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int);
+ DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD);
+ UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT,
+ WCHAR *);
+ DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *);
+ BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD,
+ LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD);
+ HINSTANCE (WINAPI *loadLibraryProc)(CONST TCHAR *);
+ TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *);
+ BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *);
+ BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
+ DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *,
+ CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
+ BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
+ BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
+ /*
+ * These two function pointers will only be set when
+ * Tcl_FindExecutable is called. If you don't ever call that
+ * function, the application will crash whenever WinTcl tries to call
+ * functions through these null pointers. That is not a bug in Tcl
+ * -- Tcl_FindExecutable is obligatory in recent Tcl releases.
+ */
+ BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *,
+ GET_FILEEX_INFO_LEVELS, LPVOID);
+ BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*,
+ LPSECURITY_ATTRIBUTES);
+
+ INT (__cdecl *utimeProc)(CONST TCHAR*, struct _utimbuf *);
+ /* These two are also NULL at start; see comment above */
+ HANDLE (WINAPI *findFirstFileExProc)(CONST TCHAR*, UINT,
+ LPVOID, UINT,
+ LPVOID, DWORD);
+ BOOL (WINAPI *getVolumeNameForVMPProc)(CONST TCHAR*, TCHAR*, DWORD);
+} TclWinProcs;
+
+EXTERN TclWinProcs *tclWinProcs;
+
+/*
+ * Declarations of functions that are not accessible by way of the
+ * stubs table.
+ */
+
+EXTERN void TclWinEncodingsCleanup();
+EXTERN void TclWinResetInterfaceEncodings();
+EXTERN void TclWinInit(HINSTANCE hInst);
+EXTERN int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal,
+ CONST TCHAR* LinkCopy);
+EXTERN int TclWinSymLinkDelete(CONST TCHAR* LinkOriginal,
+ int linkOnly);
+EXTERN char TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint);
+#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+EXTERN void TclWinFreeAllocCache(void);
+EXTERN void TclFreeAllocCache(void *);
+EXTERN Tcl_Mutex *TclpNewAllocMutex(void);
+EXTERN void *TclpGetAllocCache(void);
+EXTERN void TclpSetAllocCache(void *);
+#endif /* TCL_THREADS */
+
+/* Needed by tclWinFile.c and tclWinFCmd.c */
+#ifndef FILE_ATTRIBUTE_REPARSE_POINT
+#define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400
+#endif
+
+#include "tclIntPlatDecls.h"
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TCLWININT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.h
new file mode 100755
index 00000000000..ce5a411e8f7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.h
@@ -0,0 +1,512 @@
+
+/* $Id: tix.h,v 1.4.2.2 2001/12/09 03:10:49 idiscovery Exp $ */
+
+/*
+ * tix.h --
+ *
+ * This is the standard header file for all tix C code. It
+ * defines many macros and utility functions to make it easier to
+ * write TCL commands and TK widgets in C. No more needs to write
+ * 2000 line functions!
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+#ifndef _TIX_PORT_H_
+#include "tixPort.h"
+#endif
+#ifndef _TIX
+#define _TIX
+#define _TIX_H_
+
+#ifndef TIX_VERSION
+#define TIX_VERSION "8.1"
+#endif
+#define TIX_PATCHLEVEL "8.1.4"
+#define TIX_PATCH_LEVEL TIX_PATCHLEVEL
+
+#define TIX_RELEASE "8.1.4"
+
+#ifndef _TK
+#include "tk.h"
+#endif
+
+
+#if defined(__WIN32__) || defined(_WIN32) || defined (__BORLAND) || defined(_Windows)
+#ifndef _WINDOWS
+#define _WINDOWS
+#endif
+#endif
+
+/*
+ * When building Tix itself, BUILD_tix should be defined by the makefile
+ * so that all EXTERN declarations get DLLEXPORT; when building apps
+ * using Tix, BUILD_tix should NOT be defined so that all EXTERN
+ * declarations get DLLIMPORT as defined in tcl.h
+ *
+ * NOTE: This ifdef MUST appear after the include of tcl.h and tk.h
+ * because the EXTERN declarations in those files need DLLIMPORT.
+ */
+/*
+ * These macros are used to control whether functions are being declared for
+ * import or export. If a function is being declared while it is being built
+ * to be included in a shared library, then it should have the DLLEXPORT
+ * storage class. If is being declared for use by a module that is going to
+ * link against the shared library, then it should have the DLLIMPORT storage
+ * class. If the symbol is beind declared for a static build or for use from a
+ * stub library, then the storage class should be empty.
+ *
+ * The convention is that a macro called BUILD_xxxx, where xxxx is the
+ * name of a library we are building, is set on the compile line for sources
+ * that are to be placed in the library. When this macro is set, the
+ * storage class will be set to DLLEXPORT. At the end of the header file, the
+ * storage class will be reset to DLLIMPORt.
+ */
+
+#undef TCL_STORAGE_CLASS
+#ifdef BUILD_tix
+# define TCL_STORAGE_CLASS DLLEXPORT
+#else
+# ifdef USE_TCL_STUBS
+# define TCL_STORAGE_CLASS
+# else
+# define TCL_STORAGE_CLASS DLLIMPORT
+# endif
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#if (TCL_MAJOR_VERSION > 7)
+# define TCL_7_5_OR_LATER
+#else
+# if ((TCL_MAJOR_VERSION == 7) && (TCL_MINOR_VERSION >= 5))
+# define TCL_7_5_OR_LATER
+# endif
+#endif
+
+
+#if (TK_MAJOR_VERSION > 4)
+# define TK_4_1_OR_LATER
+#else
+# if ((TK_MAJOR_VERSION == 4) && (TK_MINOR_VERSION >= 1))
+# define TK_4_1_OR_LATER
+# endif
+#endif /* TK_MAJOR_VERSION ... */
+
+#if (TK_MAJOR_VERSION >= 8)
+# define TK_8_0_OR_LATER
+#endif
+
+#ifdef TK_4_1_OR_LATER
+ /* TK 4.1 or later */
+# define Tix_FreeProc Tcl_FreeProc
+
+#else
+ /* TK 4.0 */
+# define Tix_FreeProc Tk_FreeProc
+
+ /* These portable features were not defined in previous versions of
+ * TK but are used in Tix. Let's define them here.
+ */
+# define TkPutImage(a, b, c, d, e, f, g, h, i, j, k, l) \
+ XPutImage(c, d, e, f, g, h, i, j, k, l)
+
+# define TkStringToKeysym XStringToKeysym
+
+#endif /* TK_4_1_OR_LATER */
+
+
+#define TIX_STDIN_ALWAYS 0
+#define TIX_STDIN_OPTIONAL 1
+#define TIX_STDIN_NONE 2
+
+typedef struct {
+ char *name; /* Name of command. */
+ int (*cmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv));
+ /* Command procedure. */
+} Tix_TclCmd;
+
+
+/*----------------------------------------------------------------------
+ *
+ *
+ * SUB-COMMAND HANDLING
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+typedef int (*Tix_CmdProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+typedef int (*Tix_SubCmdProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+typedef int (*Tix_CheckArgvProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+
+typedef struct _Tix_CmdInfo {
+ int numSubCmds;
+ int minargc;
+ int maxargc;
+ char * info;
+} Tix_CmdInfo;
+
+typedef struct _Tix_SubCmdInfo {
+ int namelen;
+ char * name;
+ int minargc;
+ int maxargc;
+ Tix_SubCmdProc proc;
+ char * info;
+ Tix_CheckArgvProc checkArgvProc;
+} Tix_SubCmdInfo;
+
+/*
+ * Tix_ArraySize --
+ *
+ * Find out the number of elements inside a C array. The argument "x"
+ * must be a valid C array. Pointers don't work.
+ */
+#define Tix_ArraySize(x) (sizeof(x) / sizeof(x[0]))
+
+/*
+ * This is used for Tix_CmdInfo.maxargc and Tix_SubCmdInfo.maxargc,
+ * indicating that this command takes a variable number of arguments.
+ */
+#define TIX_VAR_ARGS -1
+
+/*
+ * TIX_DEFAULT_LEN --
+ *
+ * Use this for Tix_SubCmdInfo.namelen and Tix_ExecSubCmds() will try to
+ * determine the length of the subcommand name for you.
+ */
+#define TIX_DEFAULT_LEN -1
+
+/*
+ * TIX_DEFAULT_SUB_CMD --
+ *
+ * Use this for Tix_SubCmdInfo.name. This will match any subcommand name,
+ * including the empty string, when Tix_ExecSubCmds() finds a subcommand
+ * to execute.
+ */
+#define TIX_DEFAULT_SUBCMD 0
+
+/*
+ * TIX_DECLARE_CMD --
+ *
+ * This is just a handy macro to declare a C function to use as a
+ * command function.
+ */
+#define TIX_DECLARE_CMD(func) \
+ int func _ANSI_ARGS_((ClientData clientData,\
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]))
+
+/*
+ * TIX_DECLARE_SUBCMD --
+ *
+ * This is just a handy macro to declare a C function to use as a
+ * sub command function.
+ */
+#define TIX_DECLARE_SUBCMD(func) \
+ int func _ANSI_ARGS_((ClientData clientData,\
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]))
+
+/*
+ * TIX_DEFINE_CMD --
+ *
+ * This is just a handy macro to define a C function to use as a
+ * command function.
+ */
+#define TIX_DEFINE_CMD(func) \
+int func(clientData, interp, argc, argv) \
+ ClientData clientData; /* Main window associated with \
+ * interpreter. */ \
+ Tcl_Interp *interp; /* Current interpreter. */ \
+ int argc; /* Number of arguments. */ \
+ Tcl_Obj *objv[]; /* Argument strings. */
+
+
+
+/*----------------------------------------------------------------------
+ * Link-list functions --
+ *
+ * These functions makes it easy to use link lists in C code.
+ *
+ *----------------------------------------------------------------------
+ */
+typedef struct Tix_ListInfo {
+ int nextOffset; /* offset of the "next" pointer in a list
+ * item */
+ int prevOffset; /* offset of the "next" pointer in a list
+ * item */
+} Tix_ListInfo;
+
+
+/* Singly-linked list */
+typedef struct Tix_LinkList {
+ int numItems; /* number of items in this list */
+ char * head; /* (general pointer) head of the list */
+ char * tail; /* (general pointer) tail of the list */
+} Tix_LinkList;
+
+typedef struct Tix_ListIterator {
+ char * last;
+ char * curr;
+ unsigned int started : 1; /* True if the search operation has
+ * already started for this list */
+ unsigned int deleted : 1; /* True if a delete operation has been
+ * performed on the current item (in this
+ * case the curr pointer has already been
+ * adjusted
+ */
+} Tix_ListIterator;
+
+#define Tix_IsLinkListEmpty(list) ((list.numItems) == 0)
+#define TIX_UNIQUE 1
+#define TIX_UNDEFINED -1
+
+/*----------------------------------------------------------------------
+ * General Single Link List --
+ *
+ * The next pointer can be anywhere inside a link.
+ *----------------------------------------------------------------------
+ */
+
+EXTERN void Tix_LinkListInit _ANSI_ARGS_((Tix_LinkList * lPtr));
+EXTERN void Tix_LinkListAppend _ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, char * itemPtr, int flags));
+EXTERN void Tix_LinkListStart _ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr));
+EXTERN void Tix_LinkListNext _ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr));
+EXTERN void Tix_LinkListDelete _ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr));
+EXTERN int Tix_LinkListDeleteRange _ANSI_ARGS_((
+ Tix_ListInfo * infoPtr, Tix_LinkList * lPtr,
+ char * fromPtr, char * toPtr,
+ Tix_ListIterator * liPtr));
+EXTERN int Tix_LinkListFind _ANSI_ARGS_((
+ Tix_ListInfo * infoPtr, Tix_LinkList * lPtr,
+ char * itemPtr, Tix_ListIterator * liPtr));
+EXTERN int Tix_LinkListFindAndDelete _ANSI_ARGS_((
+ Tix_ListInfo * infoPtr, Tix_LinkList * lPtr,
+ char * itemPtr, Tix_ListIterator * liPtr));
+EXTERN void Tix_LinkListInsert _ANSI_ARGS_((
+ Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, char * itemPtr,
+ Tix_ListIterator * liPtr));
+EXTERN void Tix_LinkListIteratorInit _ANSI_ARGS_(( Tix_ListIterator * liPtr));
+
+#define Tix_LinkListDone(liPtr) ((liPtr)->curr == NULL)
+
+
+/*----------------------------------------------------------------------
+ * Simple Single Link List --
+ *
+ * The next pointer is always offset 0 in the link structure.
+ *----------------------------------------------------------------------
+ */
+
+EXTERN void Tix_SimpleListInit _ANSI_ARGS_((Tix_LinkList * lPtr));
+EXTERN void Tix_SimpleListAppend _ANSI_ARGS_((
+ Tix_LinkList * lPtr, char * itemPtr, int flags));
+EXTERN void Tix_SimpleListStart _ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr));
+EXTERN void Tix_SimpleListNext _ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr));
+EXTERN void Tix_SimpleListDelete _ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr));
+EXTERN int Tix_SimpleListDeleteRange _ANSI_ARGS_((
+ Tix_LinkList * lPtr,
+ char * fromPtr, char * toPtr,
+ Tix_ListIterator * liPtr));
+EXTERN int Tix_SimpleListFind _ANSI_ARGS_((
+ Tix_LinkList * lPtr,
+ char * itemPtr, Tix_ListIterator * liPtr));
+EXTERN int Tix_SimpleListFindAndDelete _ANSI_ARGS_((
+ Tix_LinkList * lPtr, char * itemPtr,
+ Tix_ListIterator * liPtr));
+EXTERN void Tix_SimpleListInsert _ANSI_ARGS_((
+ Tix_LinkList * lPtr, char * itemPtr,
+ Tix_ListIterator * liPtr));
+EXTERN void Tix_SimpleListIteratorInit _ANSI_ARGS_((
+ Tix_ListIterator * liPtr));
+
+#define Tix_SimpleListDone(liPtr) ((liPtr)->curr == NULL)
+
+/*----------------------------------------------------------------------
+ *
+ *
+ *
+ * CUSTOM CONFIG OPTIONS
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+#define TIX_RELIEF_RAISED 1
+#define TIX_RELIEF_FLAT 2
+#define TIX_RELIEF_SUNKEN 4
+#define TIX_RELIEF_GROOVE 8
+#define TIX_RELIEF_RIDGE 16
+#define TIX_RELIEF_SOLID 32
+
+typedef int Tix_Relief;
+
+EXTERN Tk_CustomOption tixConfigItemType;
+EXTERN Tk_CustomOption tixConfigItemStyle;
+EXTERN Tk_CustomOption tixConfigRelief;
+
+
+/*
+ * C functions exported by Tix
+ */
+
+EXTERN int Tix_ArgcError _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv, int prefixCount,
+ char *message));
+EXTERN void Tix_CreateCommands _ANSI_ARGS_((
+ Tcl_Interp *interp, Tix_TclCmd *commands,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc));
+EXTERN Tk_Window Tix_CreateSubWindow _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ char * subPath));
+EXTERN int Tix_DefinePixmap _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Uid name, char **data));
+EXTERN void Tix_DrawAnchorLines _ANSI_ARGS_((
+ Display *display, Drawable drawable,
+ GC gc, int x, int y, int w, int h));
+EXTERN int Tix_EvalArgv _ANSI_ARGS_((
+ Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tix_ExistMethod _ANSI_ARGS_((Tcl_Interp *interp,
+ char *context, char *method));
+EXTERN void Tix_Exit _ANSI_ARGS_((Tcl_Interp * interp, int code));
+EXTERN Pixmap Tix_GetRenderBuffer _ANSI_ARGS_((Display *display,
+ Drawable d, int width, int height, int depth));
+
+#ifdef TCL_VARARGS
+/*
+ * The TCL_VARARGS macro is only defined in Tcl 7.5 or later
+ */
+EXTERN int Tix_GlobalVarEval _ANSI_ARGS_(
+ TCL_VARARGS(Tcl_Interp *,interp));
+#else
+EXTERN int Tix_GlobalVarEval _ANSI_ARGS_(
+ VARARGS(Tcl_Interp *interp));
+#endif
+
+EXTERN int Tix_HandleSubCmds _ANSI_ARGS_((
+ Tix_CmdInfo * cmdInfo,
+ Tix_SubCmdInfo * subCmdInfo,
+ ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tix_Init _ANSI_ARGS_((Tcl_Interp *interp));
+
+EXTERN int Tix_LoadTclLibrary _ANSI_ARGS_((
+ Tcl_Interp *interp, char *envName,
+ char *tclName, char *initFile,
+ char *defDir, char * appName));
+EXTERN void Tix_OpenStdin _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN void Tix_SetArgv _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv));
+EXTERN void Tix_SetRcFileName _ANSI_ARGS_((
+ Tcl_Interp * interp, char * rcFileName));
+EXTERN char * TixGetStringFromObj _ANSI_ARGS_((
+ char *objPtr,int *lengthPtr));
+
+/*
+ * Entry points for Tk_CONFIG_CUSTOM stubs to call
+ */
+
+EXTERN int TixDItemParseProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj * value,
+ char *widRec, int offset));
+
+EXTERN Tcl_Obj * TixDItemPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin, char *widRec,
+ int offset, Tcl_FreeProc **freeProcPtr));
+
+EXTERN int TixDItemStyleParseProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj * value,
+ char *widRec, int offset));
+
+EXTERN Tcl_Obj * TixDItemStylePrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin, char *widRec,
+ int offset, Tcl_FreeProc **freeProcPtr));
+
+
+/*
+ * Commands exported by Tix
+ *
+ */
+
+extern TIX_DECLARE_CMD(Tix_CallMethodCmd);
+extern TIX_DECLARE_CMD(Tix_ChainMethodCmd);
+extern TIX_DECLARE_CMD(Tix_ClassCmd);
+extern TIX_DECLARE_CMD(Tix_DoWhenIdleCmd);
+extern TIX_DECLARE_CMD(Tix_DoWhenMappedCmd);
+extern TIX_DECLARE_CMD(Tix_FalseCmd);
+extern TIX_DECLARE_CMD(Tix_FileCmd);
+extern TIX_DECLARE_CMD(Tix_FlushXCmd);
+extern TIX_DECLARE_CMD(Tix_FormCmd);
+extern TIX_DECLARE_CMD(Tix_GridCmd);
+extern TIX_DECLARE_CMD(Tix_GeometryRequestCmd);
+extern TIX_DECLARE_CMD(Tix_Get3DBorderCmd);
+extern TIX_DECLARE_CMD(Tix_GetBooleanCmd);
+extern TIX_DECLARE_CMD(Tix_GetIntCmd);
+extern TIX_DECLARE_CMD(Tix_GetMethodCmd);
+extern TIX_DECLARE_CMD(Tix_HListCmd);
+extern TIX_DECLARE_CMD(Tix_HandleOptionsCmd);
+extern TIX_DECLARE_CMD(Tix_InputOnlyCmd);
+extern TIX_DECLARE_CMD(Tix_ItemStyleCmd);
+extern TIX_DECLARE_CMD(Tix_ManageGeometryCmd);
+extern TIX_DECLARE_CMD(Tix_MapWindowCmd);
+extern TIX_DECLARE_CMD(Tix_MoveResizeWindowCmd);
+extern TIX_DECLARE_CMD(Tix_NoteBookFrameCmd);
+extern TIX_DECLARE_CMD(Tix_RaiseWindowCmd);
+extern TIX_DECLARE_CMD(Tix_ShellInputCmd);
+extern TIX_DECLARE_CMD(Tix_StringSubCmd);
+extern TIX_DECLARE_CMD(Tix_StrEqCmd);
+extern TIX_DECLARE_CMD(Tix_TListCmd);
+extern TIX_DECLARE_CMD(Tix_TmpLineCmd);
+extern TIX_DECLARE_CMD(Tix_TrueCmd);
+extern TIX_DECLARE_CMD(Tix_UnmapWindowCmd);
+extern TIX_DECLARE_CMD(Tix_MwmCmd);
+extern TIX_DECLARE_CMD(Tix_CreateWidgetCmd);
+
+#define SET_RECORD(interp, record, var, value) \
+ Tcl_SetVar2(interp, record, var, value, TCL_GLOBAL_ONLY)
+
+#define GET_RECORD(interp, record, var) \
+ Tcl_GetVar2(interp, record, var, TCL_GLOBAL_ONLY)
+
+
+#define TIX_HASHKEY(k) ((sizeof(k)>sizeof(int))?((char*)&(k)):((char*)(k)))
+
+/*----------------------------------------------------------------------
+ * Compatibility section
+ *---------------------------------------------------------------------- */
+
+
+#ifdef _WINDOWS
+/* This is the way win/tkWinPort.h in tk8.0.5 defines it */
+#ifndef strcasecmp
+#define strcasecmp stricmp
+#endif
+#endif
+
+
+#ifdef __cplusplus
+}
+#endif
+
+
+#endif /* _TIX */
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.m
new file mode 100755
index 00000000000..92b9f74eb3f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.m
@@ -0,0 +1,126 @@
+#ifndef _TIX_VM
+#define _TIX_VM
+#include "tix_f.h"
+#ifndef NO_VTABLES
+#ifndef TixDItemParseProc
+# define TixDItemParseProc (*TixVptr->V_TixDItemParseProc)
+#endif
+
+#ifndef TixDItemPrintProc
+# define TixDItemPrintProc (*TixVptr->V_TixDItemPrintProc)
+#endif
+
+#ifndef TixDItemStyleParseProc
+# define TixDItemStyleParseProc (*TixVptr->V_TixDItemStyleParseProc)
+#endif
+
+#ifndef TixDItemStylePrintProc
+# define TixDItemStylePrintProc (*TixVptr->V_TixDItemStylePrintProc)
+#endif
+
+#ifndef TixGetStringFromObj
+# define TixGetStringFromObj (*TixVptr->V_TixGetStringFromObj)
+#endif
+
+#ifndef Tix_ArgcError
+# define Tix_ArgcError (*TixVptr->V_Tix_ArgcError)
+#endif
+
+#ifndef Tix_CreateSubWindow
+# define Tix_CreateSubWindow (*TixVptr->V_Tix_CreateSubWindow)
+#endif
+
+#ifndef Tix_DrawAnchorLines
+# define Tix_DrawAnchorLines (*TixVptr->V_Tix_DrawAnchorLines)
+#endif
+
+#ifndef Tix_GetRenderBuffer
+# define Tix_GetRenderBuffer (*TixVptr->V_Tix_GetRenderBuffer)
+#endif
+
+#ifndef Tix_HandleSubCmds
+# define Tix_HandleSubCmds (*TixVptr->V_Tix_HandleSubCmds)
+#endif
+
+#ifndef Tix_LinkListAppend
+# define Tix_LinkListAppend (*TixVptr->V_Tix_LinkListAppend)
+#endif
+
+#ifndef Tix_LinkListDelete
+# define Tix_LinkListDelete (*TixVptr->V_Tix_LinkListDelete)
+#endif
+
+#ifndef Tix_LinkListDeleteRange
+# define Tix_LinkListDeleteRange (*TixVptr->V_Tix_LinkListDeleteRange)
+#endif
+
+#ifndef Tix_LinkListFind
+# define Tix_LinkListFind (*TixVptr->V_Tix_LinkListFind)
+#endif
+
+#ifndef Tix_LinkListFindAndDelete
+# define Tix_LinkListFindAndDelete (*TixVptr->V_Tix_LinkListFindAndDelete)
+#endif
+
+#ifndef Tix_LinkListInit
+# define Tix_LinkListInit (*TixVptr->V_Tix_LinkListInit)
+#endif
+
+#ifndef Tix_LinkListInsert
+# define Tix_LinkListInsert (*TixVptr->V_Tix_LinkListInsert)
+#endif
+
+#ifndef Tix_LinkListIteratorInit
+# define Tix_LinkListIteratorInit (*TixVptr->V_Tix_LinkListIteratorInit)
+#endif
+
+#ifndef Tix_LinkListNext
+# define Tix_LinkListNext (*TixVptr->V_Tix_LinkListNext)
+#endif
+
+#ifndef Tix_LinkListStart
+# define Tix_LinkListStart (*TixVptr->V_Tix_LinkListStart)
+#endif
+
+#ifndef Tix_SimpleListAppend
+# define Tix_SimpleListAppend (*TixVptr->V_Tix_SimpleListAppend)
+#endif
+
+#ifndef Tix_SimpleListDelete
+# define Tix_SimpleListDelete (*TixVptr->V_Tix_SimpleListDelete)
+#endif
+
+#ifndef Tix_SimpleListDeleteRange
+# define Tix_SimpleListDeleteRange (*TixVptr->V_Tix_SimpleListDeleteRange)
+#endif
+
+#ifndef Tix_SimpleListFind
+# define Tix_SimpleListFind (*TixVptr->V_Tix_SimpleListFind)
+#endif
+
+#ifndef Tix_SimpleListFindAndDelete
+# define Tix_SimpleListFindAndDelete (*TixVptr->V_Tix_SimpleListFindAndDelete)
+#endif
+
+#ifndef Tix_SimpleListInit
+# define Tix_SimpleListInit (*TixVptr->V_Tix_SimpleListInit)
+#endif
+
+#ifndef Tix_SimpleListInsert
+# define Tix_SimpleListInsert (*TixVptr->V_Tix_SimpleListInsert)
+#endif
+
+#ifndef Tix_SimpleListIteratorInit
+# define Tix_SimpleListIteratorInit (*TixVptr->V_Tix_SimpleListIteratorInit)
+#endif
+
+#ifndef Tix_SimpleListNext
+# define Tix_SimpleListNext (*TixVptr->V_Tix_SimpleListNext)
+#endif
+
+#ifndef Tix_SimpleListStart
+# define Tix_SimpleListStart (*TixVptr->V_Tix_SimpleListStart)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TIX_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.t
new file mode 100755
index 00000000000..08379729f4f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix.t
@@ -0,0 +1,170 @@
+#ifdef _TIX
+#ifndef TixDItemParseProc
+VFUNC(int,TixDItemParseProc,V_TixDItemParseProc,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj * value,
+ char *widRec, int offset)))
+#endif /* #ifndef TixDItemParseProc */
+
+#ifndef TixDItemPrintProc
+VFUNC(Tcl_Obj *,TixDItemPrintProc,V_TixDItemPrintProc,_ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin, char *widRec,
+ int offset, Tcl_FreeProc **freeProcPtr)))
+#endif /* #ifndef TixDItemPrintProc */
+
+#ifndef TixDItemStyleParseProc
+VFUNC(int,TixDItemStyleParseProc,V_TixDItemStyleParseProc,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj * value,
+ char *widRec, int offset)))
+#endif /* #ifndef TixDItemStyleParseProc */
+
+#ifndef TixDItemStylePrintProc
+VFUNC(Tcl_Obj *,TixDItemStylePrintProc,V_TixDItemStylePrintProc,_ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin, char *widRec,
+ int offset, Tcl_FreeProc **freeProcPtr)))
+#endif /* #ifndef TixDItemStylePrintProc */
+
+#ifndef TixGetStringFromObj
+VFUNC(char *,TixGetStringFromObj,V_TixGetStringFromObj,_ANSI_ARGS_((
+ char *objPtr,int *lengthPtr)))
+#endif /* #ifndef TixGetStringFromObj */
+
+#ifndef Tix_ArgcError
+VFUNC(int,Tix_ArgcError,V_Tix_ArgcError,_ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv, int prefixCount,
+ char *message)))
+#endif /* #ifndef Tix_ArgcError */
+
+#ifndef Tix_CreateSubWindow
+VFUNC(Tk_Window,Tix_CreateSubWindow,V_Tix_CreateSubWindow,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ char * subPath)))
+#endif /* #ifndef Tix_CreateSubWindow */
+
+#ifndef Tix_DrawAnchorLines
+VFUNC(void,Tix_DrawAnchorLines,V_Tix_DrawAnchorLines,_ANSI_ARGS_((
+ Display *display, Drawable drawable,
+ GC gc, int x, int y, int w, int h)))
+#endif /* #ifndef Tix_DrawAnchorLines */
+
+#ifndef Tix_GetRenderBuffer
+VFUNC(Pixmap,Tix_GetRenderBuffer,V_Tix_GetRenderBuffer,_ANSI_ARGS_((Display *display,
+ Drawable d, int width, int height, int depth)))
+#endif /* #ifndef Tix_GetRenderBuffer */
+
+#ifndef Tix_HandleSubCmds
+VFUNC(int,Tix_HandleSubCmds,V_Tix_HandleSubCmds,_ANSI_ARGS_((
+ Tix_CmdInfo * cmdInfo,
+ Tix_SubCmdInfo * subCmdInfo,
+ ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv)))
+#endif /* #ifndef Tix_HandleSubCmds */
+
+#ifndef Tix_LinkListAppend
+VFUNC(void,Tix_LinkListAppend,V_Tix_LinkListAppend,_ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, char * itemPtr, int flags)))
+#endif /* #ifndef Tix_LinkListAppend */
+
+#ifndef Tix_LinkListDelete
+VFUNC(void,Tix_LinkListDelete,V_Tix_LinkListDelete,_ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListDelete */
+
+#ifndef Tix_LinkListDeleteRange
+VFUNC(int,Tix_LinkListDeleteRange,V_Tix_LinkListDeleteRange,_ANSI_ARGS_((
+ Tix_ListInfo * infoPtr, Tix_LinkList * lPtr,
+ char * fromPtr, char * toPtr,
+ Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListDeleteRange */
+
+#ifndef Tix_LinkListFind
+VFUNC(int,Tix_LinkListFind,V_Tix_LinkListFind,_ANSI_ARGS_((
+ Tix_ListInfo * infoPtr, Tix_LinkList * lPtr,
+ char * itemPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListFind */
+
+#ifndef Tix_LinkListFindAndDelete
+VFUNC(int,Tix_LinkListFindAndDelete,V_Tix_LinkListFindAndDelete,_ANSI_ARGS_((
+ Tix_ListInfo * infoPtr, Tix_LinkList * lPtr,
+ char * itemPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListFindAndDelete */
+
+#ifndef Tix_LinkListInit
+VFUNC(void,Tix_LinkListInit,V_Tix_LinkListInit,_ANSI_ARGS_((Tix_LinkList * lPtr)))
+#endif /* #ifndef Tix_LinkListInit */
+
+#ifndef Tix_LinkListInsert
+VFUNC(void,Tix_LinkListInsert,V_Tix_LinkListInsert,_ANSI_ARGS_((
+ Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, char * itemPtr,
+ Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListInsert */
+
+#ifndef Tix_LinkListIteratorInit
+VFUNC(void,Tix_LinkListIteratorInit,V_Tix_LinkListIteratorInit,_ANSI_ARGS_(( Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListIteratorInit */
+
+#ifndef Tix_LinkListNext
+VFUNC(void,Tix_LinkListNext,V_Tix_LinkListNext,_ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListNext */
+
+#ifndef Tix_LinkListStart
+VFUNC(void,Tix_LinkListStart,V_Tix_LinkListStart,_ANSI_ARGS_((Tix_ListInfo * infoPtr,
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_LinkListStart */
+
+#ifndef Tix_SimpleListAppend
+VFUNC(void,Tix_SimpleListAppend,V_Tix_SimpleListAppend,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, char * itemPtr, int flags)))
+#endif /* #ifndef Tix_SimpleListAppend */
+
+#ifndef Tix_SimpleListDelete
+VFUNC(void,Tix_SimpleListDelete,V_Tix_SimpleListDelete,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListDelete */
+
+#ifndef Tix_SimpleListDeleteRange
+VFUNC(int,Tix_SimpleListDeleteRange,V_Tix_SimpleListDeleteRange,_ANSI_ARGS_((
+ Tix_LinkList * lPtr,
+ char * fromPtr, char * toPtr,
+ Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListDeleteRange */
+
+#ifndef Tix_SimpleListFind
+VFUNC(int,Tix_SimpleListFind,V_Tix_SimpleListFind,_ANSI_ARGS_((
+ Tix_LinkList * lPtr,
+ char * itemPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListFind */
+
+#ifndef Tix_SimpleListFindAndDelete
+VFUNC(int,Tix_SimpleListFindAndDelete,V_Tix_SimpleListFindAndDelete,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, char * itemPtr,
+ Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListFindAndDelete */
+
+#ifndef Tix_SimpleListInit
+VFUNC(void,Tix_SimpleListInit,V_Tix_SimpleListInit,_ANSI_ARGS_((Tix_LinkList * lPtr)))
+#endif /* #ifndef Tix_SimpleListInit */
+
+#ifndef Tix_SimpleListInsert
+VFUNC(void,Tix_SimpleListInsert,V_Tix_SimpleListInsert,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, char * itemPtr,
+ Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListInsert */
+
+#ifndef Tix_SimpleListIteratorInit
+VFUNC(void,Tix_SimpleListIteratorInit,V_Tix_SimpleListIteratorInit,_ANSI_ARGS_((
+ Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListIteratorInit */
+
+#ifndef Tix_SimpleListNext
+VFUNC(void,Tix_SimpleListNext,V_Tix_SimpleListNext,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListNext */
+
+#ifndef Tix_SimpleListStart
+VFUNC(void,Tix_SimpleListStart,V_Tix_SimpleListStart,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_ListIterator * liPtr)))
+#endif /* #ifndef Tix_SimpleListStart */
+
+#endif /* _TIX */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixBitmaps.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixBitmaps.h
new file mode 100755
index 00000000000..4e9885cb7e8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixBitmaps.h
@@ -0,0 +1,618 @@
+
+/* $Id: tixBitmaps.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+{
+#define maximize_width 15
+#define maximize_height 15
+static UNSIGNED_CHAR maximize_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0xfc, 0x1f, 0x04, 0x10, 0x04, 0x70, 0x04, 0x70,
+ 0x04, 0x70, 0x04, 0x70, 0x04, 0x70, 0x04, 0x70, 0x04, 0x70, 0x04, 0x70,
+ 0xfc, 0x7f, 0xf0, 0x7f, 0xf0, 0x7f};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("maximize"), (char*)maximize_bits, maximize_width, maximize_height);
+}
+{
+#define act_fold_width 16
+#define act_fold_height 10
+static UNSIGNED_CHAR act_fold_bits[] = {
+ 0xfc, 0x00, 0xaa, 0x0f, 0x55, 0x15, 0xeb, 0xff, 0x15, 0x80, 0x0b, 0x40,
+ 0x05, 0x20, 0x03, 0x10, 0x01, 0x08, 0xff, 0x07};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("act_fold"), (char*)act_fold_bits, act_fold_width, act_fold_height);
+}
+{
+/* XPM */
+static char * act_fold_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 4 1",
+/* colors */
+" s None c None",
+". c black",
+"X c yellow",
+"o c #5B5B57574646",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".oXoXoXoXoXo. ",
+".XoX............",
+".oX.XXXXXXXXXXX.",
+".Xo.XXXXXXXXXX. ",
+".o.XXXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+"..XXXXXXXXXX.. ",
+"............. "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("act_fold"), act_fold_xpm);
+}
+{
+#define balarrow_width 6
+#define balarrow_height 6
+static UNSIGNED_CHAR balarrow_bits[] = {
+ 0x1f, 0x07, 0x07, 0x09, 0x11, 0x20};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("balarrow"), (char*)balarrow_bits, balarrow_width, balarrow_height);
+}
+{
+#define cbxarrow_width 11
+#define cbxarrow_height 14
+static UNSIGNED_CHAR cbxarrow_bits[] = {
+ 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00,
+ 0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00,
+ 0xfe, 0x03, 0xfe, 0x03};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("cbxarrow"), (char*)cbxarrow_bits, cbxarrow_width, cbxarrow_height);
+}
+{
+#define ck_def_width 13
+#define ck_def_height 13
+static UNSIGNED_CHAR ck_def_bits[] = {
+ 0xff, 0x1f, 0x01, 0x10, 0x55, 0x15, 0x01, 0x10, 0x55, 0x15, 0x01, 0x10,
+ 0x55, 0x15, 0x01, 0x10, 0x55, 0x15, 0x01, 0x10, 0x55, 0x15, 0x01, 0x10,
+ 0xff, 0x1f};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("ck_def"), (char*)ck_def_bits, ck_def_width, ck_def_height);
+}
+{
+#define ck_off_width 13
+#define ck_off_height 13
+static UNSIGNED_CHAR ck_off_bits[] = {
+ 0xff, 0x1f, 0x01, 0x10, 0x01, 0x10, 0x01, 0x10, 0x01, 0x10, 0x01, 0x10,
+ 0x01, 0x10, 0x01, 0x10, 0x01, 0x10, 0x01, 0x10, 0x01, 0x10, 0x01, 0x10,
+ 0xff, 0x1f};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("ck_off"), (char*)ck_off_bits, ck_off_width, ck_off_height);
+}
+{
+#define ck_on_width 13
+#define ck_on_height 13
+static UNSIGNED_CHAR ck_on_bits[] = {
+ 0xff, 0x1f, 0x01, 0x10, 0x01, 0x10, 0x01, 0x14, 0x01, 0x16, 0x01, 0x17,
+ 0x89, 0x13, 0xdd, 0x11, 0xf9, 0x10, 0x71, 0x10, 0x21, 0x10, 0x01, 0x10,
+ 0xff, 0x1f};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("ck_on"), (char*)ck_on_bits, ck_on_width, ck_on_height);
+}
+{
+#define cross_width 14
+#define cross_height 14
+static UNSIGNED_CHAR cross_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x06, 0x18, 0x0e, 0x1c, 0x1c, 0x0e, 0x38, 0x07,
+ 0xf0, 0x03, 0xe0, 0x01, 0xe0, 0x01, 0xf0, 0x03, 0x38, 0x07, 0x1c, 0x0e,
+ 0x0e, 0x1c, 0x06, 0x18};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("cross"), (char*)cross_bits, cross_width, cross_height);
+}
+{
+#define decr_width 7
+#define decr_height 4
+static UNSIGNED_CHAR decr_bits[] = {
+ 0x7f, 0x3e, 0x1c, 0x08};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("decr"), (char*)decr_bits, decr_width, decr_height);
+}
+{
+#define drop_width 16
+#define drop_height 16
+#define drop_x_hot 6
+#define drop_y_hot 4
+static UNSIGNED_CHAR drop_bits[] = {
+ 0x00, 0x00, 0xfe, 0x07, 0x02, 0x04, 0x02, 0x04, 0x42, 0x04, 0xc2, 0x04,
+ 0xc2, 0x05, 0xc2, 0x07, 0xc2, 0x07, 0xc2, 0x0f, 0xfe, 0x1f, 0xc0, 0x07,
+ 0xc0, 0x06, 0x00, 0x0c, 0x00, 0x1c, 0x00, 0x08};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("drop"), (char*)drop_bits, drop_width, drop_height);
+}
+{
+#define file_width 12
+#define file_height 12
+static UNSIGNED_CHAR file_bits[] = {
+ 0xfe, 0x00, 0x02, 0x03, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02,
+ 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0xfe, 0x03};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("file"), (char*)file_bits, file_width, file_height);
+}
+{
+/* XPM */
+static char * file_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c black",
+"X c #FFFFFFFFF3CE",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .......... "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("file"), file_xpm);
+}
+{
+#define folder_width 16
+#define folder_height 10
+static UNSIGNED_CHAR folder_bits[] = {
+ 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08,
+ 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0xff, 0x07};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("folder"), (char*)folder_bits, folder_width, folder_height);
+}
+{
+/* XPM */
+static char * folder_foo_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 3 1",
+/* colors */
+" s None c None",
+". c black",
+"X c #f0ff80",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+"............. "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("folder"), folder_foo_xpm);
+}
+{
+#define harddisk_width 32
+#define harddisk_height 32
+static UNSIGNED_CHAR harddisk_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0xf8, 0xff, 0xff, 0x1f, 0x08, 0x00, 0x00, 0x18, 0xa8, 0xaa, 0xaa, 0x1a,
+ 0x48, 0x55, 0xd5, 0x1d, 0xa8, 0xaa, 0xaa, 0x1b, 0x48, 0x55, 0x55, 0x1d,
+ 0xa8, 0xfa, 0xaf, 0x1a, 0xc8, 0xff, 0xff, 0x1d, 0xa8, 0xfa, 0xaf, 0x1a,
+ 0x48, 0x55, 0x55, 0x1d, 0xa8, 0xaa, 0xaa, 0x1a, 0x48, 0x55, 0x55, 0x1d,
+ 0xa8, 0xaa, 0xaa, 0x1a, 0xf8, 0xff, 0xff, 0x1f, 0xf8, 0xff, 0xff, 0x1f,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("harddisk"), (char*)harddisk_bits, harddisk_width, harddisk_height);
+}
+{
+#define hourglass_width 32
+#define hourglas_height 32
+#define hourglas_x_hot 16
+#define hourglas_y_hot 15
+static UNSIGNED_CHAR hourglas_bits[] = {
+ 0xfe, 0xff, 0xff, 0xff, 0xfe, 0xff, 0xff, 0xff, 0xfe, 0xff, 0xff, 0xff,
+ 0x7c, 0x00, 0x00, 0x7c, 0x7c, 0x00, 0x00, 0x7c, 0x7c, 0x00, 0x00, 0x7c,
+ 0xfc, 0x00, 0x00, 0x7e, 0xfc, 0x00, 0x00, 0x7e, 0xfc, 0x00, 0x00, 0x7e,
+ 0xbc, 0x01, 0x00, 0x7b, 0xbc, 0xfd, 0x7e, 0x7b, 0x3c, 0xfb, 0xbf, 0x79,
+ 0x3c, 0xe6, 0xcf, 0x78, 0x3c, 0xdc, 0x77, 0x78, 0x3c, 0x38, 0x39, 0x78,
+ 0x3c, 0x60, 0x0d, 0x78, 0x3c, 0x38, 0x38, 0x78, 0x3c, 0x1c, 0x71, 0x78,
+ 0x3c, 0x06, 0xc1, 0x78, 0x3c, 0x03, 0x80, 0x79, 0xbc, 0x01, 0x00, 0x7b,
+ 0xbc, 0x01, 0x00, 0x7b, 0xfc, 0x00, 0x01, 0x7e, 0xfc, 0x00, 0x01, 0x7e,
+ 0xfc, 0x80, 0x03, 0x7e, 0x7c, 0xc0, 0x07, 0x7c, 0x7c, 0xf0, 0x1f, 0x7c,
+ 0x7c, 0xfe, 0xff, 0x7c, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0xff,
+ 0xfe, 0xff, 0xff, 0xff, 0xfe, 0xff, 0xff, 0xff};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("hourglas"), (char*)hourglas_bits, hourglass_width, hourglas_height);
+}
+{
+#define incr_width 7
+#define incr_height 4
+static UNSIGNED_CHAR incr_bits[] = {
+ 0x08, 0x1c, 0x3e, 0x7f};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("incr"), (char*)incr_bits, incr_width, incr_height);
+}
+{
+/* XPM */
+static char * info_xpm[] = {
+"32 32 3 1",
+" s None c None",
+". c #000000000000",
+"X c white",
+" ",
+" ......... ",
+" ...XXXXXXXXX... ",
+" .XXXXXXXXXXXXXXX. ",
+" ..XXXXXXXXXXXXXXXXX.. ",
+" .XXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXX...XXXXXXXXXX. ",
+" .XXXXXXXXX.....XXXXXXXXX. ",
+" .XXXXXXXXX.......XXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+" .XXXXXXXXXXX.....XXXXXXXXXXX. ",
+".XXXXXXXXXXXXX...XXXXXXXXXXXXX. ",
+".XXXXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+".XXXXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+" .XXXXXXXXX.......XXXXXXXXX. ",
+" .XXXXXXXX.......XXXXXXXX. ",
+" .XXXXXXXX.......XXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXX. ",
+" ..XXXXXXXXXXXXXXXXX.. ",
+" .XXXXXXXXXXXXXXX. ",
+" ...XXXXXXXXX... ",
+" ......... "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("info"), info_xpm);
+}
+{
+#define minimize_width 15
+#define minimize_height 15
+static UNSIGNED_CHAR minimize_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x01,
+ 0x20, 0x03, 0x20, 0x03, 0xe0, 0x03, 0xc0, 0x03, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("minimize"), (char*)minimize_bits, minimize_width, minimize_height);
+}
+{
+#define minus_width 9
+#define minus_height 9
+static UNSIGNED_CHAR minus_bits[] = {
+ 0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
+ 0x01, 0x01, 0x01, 0x01, 0xff, 0x01};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("minus"), (char*)minus_bits, minus_width, minus_height);
+}
+{
+/* XPM */
+static char * minus_xpm[] = {
+"9 9 2 1",
+". s None c None",
+" c black",
+" ",
+" ....... ",
+" ....... ",
+" ....... ",
+" . . ",
+" ....... ",
+" ....... ",
+" ....... ",
+" "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("minus"), minus_xpm);
+}
+{
+#define minusarm_width 9
+#define minusarm_height 9
+static UNSIGNED_CHAR minusarm_bits[] = {
+ 0xff, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x7d, 0x01, 0x01, 0x01, 0x7d, 0x01,
+ 0x7d, 0x01, 0x01, 0x01, 0xff, 0x01};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("minusarm"), (char*)minusarm_bits, minusarm_width, minusarm_height);
+}
+{
+/* XPM */
+static char * minusarm_xpm[] = {
+"9 9 3 1",
+" c black",
+". c yellow",
+"X c #808080808080",
+" ",
+" ....... ",
+" ....... ",
+" .XXXXX. ",
+" .X X. ",
+" .XXXXX. ",
+" ....... ",
+" ....... ",
+" "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("minusarm"), minusarm_xpm);
+}
+{
+#define network_width 32
+#define network_height 32
+static UNSIGNED_CHAR network_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfe, 0x7f, 0x00, 0x00, 0x02, 0x40,
+ 0x00, 0x00, 0xfa, 0x5f, 0x00, 0x00, 0x0a, 0x50, 0x00, 0x00, 0x0a, 0x52,
+ 0x00, 0x00, 0x0a, 0x52, 0x00, 0x00, 0x8a, 0x51, 0x00, 0x00, 0x0a, 0x50,
+ 0x00, 0x00, 0x4a, 0x50, 0x00, 0x00, 0x0a, 0x50, 0x00, 0x00, 0x0a, 0x50,
+ 0x00, 0x00, 0xfa, 0x5f, 0x00, 0x00, 0x02, 0x40, 0xfe, 0x7f, 0x52, 0x55,
+ 0x02, 0x40, 0xaa, 0x6a, 0xfa, 0x5f, 0xfe, 0x7f, 0x0a, 0x50, 0xfe, 0x7f,
+ 0x0a, 0x52, 0x80, 0x00, 0x0a, 0x52, 0x80, 0x00, 0x8a, 0x51, 0x80, 0x00,
+ 0x0a, 0x50, 0x80, 0x00, 0x4a, 0x50, 0x80, 0x00, 0x0a, 0x50, 0xe0, 0x03,
+ 0x0a, 0x50, 0x20, 0x02, 0xfa, 0xdf, 0x3f, 0x03, 0x02, 0x40, 0xa0, 0x02,
+ 0x52, 0x55, 0xe0, 0x03, 0xaa, 0x6a, 0x00, 0x00, 0xfe, 0x7f, 0x00, 0x00,
+ 0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("network"), (char*)network_bits, network_width, network_height);
+}
+{
+/* XPM */
+static char * no_entry_xpm[] = {
+"32 32 4 1",
+" s None c None",
+". c #000000000000",
+"X c red",
+"o c yellow",
+" ",
+" ......... ",
+" ...XXXXXXXXX... ",
+" .XXXXXXXXXXXXXXX. ",
+" ..XXXXXXXXXXXXXXXXX.. ",
+" .XXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+".XXXXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+".XXX.......................XXX. ",
+".XXX.ooooooooooooooooooooo.XXX. ",
+".XXX.ooooooooooooooooooooo.XXX. ",
+".XXX.ooooooooooooooooooooo.XXX. ",
+".XXX.ooooooooooooooooooooo.XXX. ",
+".XXX.ooooooooooooooooooooo.XXX. ",
+".XXX.ooooooooooooooooooooo.XXX. ",
+".XXX.......................XXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXX. ",
+" ..XXXXXXXXXXXXXXXXX.. ",
+" .XXXXXXXXXXXXXXX. ",
+" ...XXXXXXXXX... ",
+" ......... "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("no_entry"), no_entry_xpm);
+}
+{
+#define openfile_width 16
+#define openfile_height 10
+static UNSIGNED_CHAR openfile_bits[] = {
+ 0xf8, 0x01, 0x04, 0x06, 0x02, 0x08, 0x02, 0x10, 0xe2, 0xff, 0x52, 0x55,
+ 0xaa, 0x2a, 0x56, 0x15, 0xaa, 0x0a, 0xfe, 0x07};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("openfile"), (char*)openfile_bits, openfile_width, openfile_height);
+}
+{
+#define openfold_width 16
+#define openfold_height 10
+static UNSIGNED_CHAR openfold_bits[] = {
+ 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0xc1, 0xff, 0x21, 0x80, 0x11, 0x40,
+ 0x09, 0x20, 0x05, 0x10, 0x03, 0x08, 0xff, 0x07};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("openfold"), (char*)openfold_bits, openfold_width, openfold_height);
+}
+{
+/* XPM */
+static char * openfolder_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 3 1",
+/* colors */
+" s None c None",
+". c black",
+"X c #f0ff80",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".XXXXXXXXXXX. ",
+".XXX............",
+".XX.XXXXXXXXXXX.",
+".XX.XXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+"..XXXXXXXXXX.. ",
+"............. "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("openfold"), openfolder_xpm);
+}
+{
+#define plus_width 9
+#define plus_height 9
+static UNSIGNED_CHAR plus_bits[] = {
+ 0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
+ 0x11, 0x01, 0x01, 0x01, 0xff, 0x01};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("plus"), (char*)plus_bits, plus_width, plus_height);
+}
+{
+/* XPM */
+static char * plus_xpm[] = {
+"9 9 2 1",
+". s None c None",
+" c black",
+" ",
+" ....... ",
+" ... ... ",
+" ... ... ",
+" . . ",
+" ... ... ",
+" ... ... ",
+" ....... ",
+" "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("plus"), plus_xpm);
+}
+{
+#define plusarm_width 9
+#define plusarm_height 9
+static UNSIGNED_CHAR plusarm_bits[] = {
+ 0xff, 0x01, 0x01, 0x01, 0x6d, 0x01, 0x6d, 0x01, 0x01, 0x01, 0x6d, 0x01,
+ 0x6d, 0x01, 0x01, 0x01, 0xff, 0x01};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("plusarm"), (char*)plusarm_bits, plusarm_width, plusarm_height);
+}
+{
+/* XPM */
+static char * plusarm_xpm[] = {
+"9 9 3 1",
+" c black",
+". c yellow",
+"X c gray40",
+" ",
+" ....... ",
+" ... ... ",
+" ..X X.. ",
+" . X . ",
+" ..X X.. ",
+" ... ... ",
+" ....... ",
+" "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("plusarm"), plusarm_xpm);
+}
+{
+#define resize1_width 13
+#define resize1_height 13
+#define resize1_x_hot 6
+#define resize1_y_hot 6
+static UNSIGNED_CHAR resize1_bits[] = {
+ 0x7f, 0x00, 0x21, 0x00, 0x11, 0x00, 0x31, 0x00, 0x6d, 0x00, 0xdb, 0x00,
+ 0xb1, 0x11, 0x60, 0x1b, 0xc0, 0x16, 0x80, 0x11, 0x00, 0x11, 0x80, 0x10,
+ 0xc0, 0x1f};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("resize1"),(char*) resize1_bits, resize1_width, resize1_height);
+}
+{
+#define resize2_width 13
+#define resize2_height 13
+#define resize2_x_hot 6
+#define resize2_y_hot 6
+static UNSIGNED_CHAR resize2_bits[] = {
+ 0xc0, 0x1f, 0x80, 0x10, 0x00, 0x11, 0x80, 0x11, 0xc0, 0x16, 0x60, 0x1b,
+ 0xb1, 0x11, 0xdb, 0x00, 0x6d, 0x00, 0x31, 0x00, 0x11, 0x00, 0x21, 0x00,
+ 0x7f, 0x00};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("resize2"), (char*)resize2_bits, resize2_width, resize2_height);
+}
+{
+#define restore_width 15
+#define restore_height 15
+static UNSIGNED_CHAR restore_bits[] = {
+ 0x00, 0x00, 0x80, 0x00, 0xc0, 0x01, 0xe0, 0x03, 0xf0, 0x07, 0xf8, 0x0f,
+ 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x1f, 0xf8, 0x0f, 0xf0, 0x07, 0xe0, 0x03,
+ 0xc0, 0x01, 0x80, 0x00, 0x00, 0x00};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("restore"), (char*)restore_bits, restore_width, restore_height);
+}
+{
+#define srcfile_width 12
+#define srcfile_height 12
+static UNSIGNED_CHAR srcfile_bits[] = {
+ 0xfe, 0x01, 0x02, 0x01, 0x02, 0x07, 0x02, 0x04, 0x72, 0x04, 0x8a, 0x04,
+ 0x0a, 0x04, 0x0a, 0x04, 0x8a, 0x04, 0x72, 0x04, 0x02, 0x04, 0xfe, 0x07};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("srcfile"), (char*)srcfile_bits, srcfile_width, srcfile_height);
+}
+{
+/* XPM */
+static char * srcfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c black",
+"X c gray91",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .XXXXXXXX. ",
+" .XX...XXX. ",
+" .X.XXX.XX. ",
+" .X.XXXXXX. ",
+" .X.XXXXXX. ",
+" .X.XXX.XX. ",
+" .XX...XXX. ",
+" .XXXXXXXX. ",
+" .......... "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("srcfile"), srcfile_xpm);
+}
+{
+#define system_width 15
+#define system_height 15
+static UNSIGNED_CHAR system_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfe, 0x3f,
+ 0x02, 0x20, 0x02, 0x20, 0xfe, 0x3f, 0xfe, 0x3f, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("system"), (char*)system_bits, system_width, system_height);
+}
+{
+#define textfile_width 12
+#define textfile_height 12
+static UNSIGNED_CHAR textfile_bits[] = {
+ 0xfe, 0x01, 0x02, 0x01, 0x02, 0x07, 0x7a, 0x04, 0x02, 0x04, 0x3a, 0x04,
+ 0x02, 0x04, 0xfa, 0x04, 0x02, 0x04, 0xfa, 0x04, 0x02, 0x04, 0xfe, 0x07};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("textfile"), (char*)textfile_bits, textfile_width, textfile_height);
+}
+{
+/* XPM */
+static char * textfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c black",
+"X c #FFFFFFFFF3CE",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .X....XXX. ",
+" .XXXXXXXX. ",
+" .X...XXXX. ",
+" .XXXXXXXX. ",
+" .X.....XX. ",
+" .XXXXXXXX. ",
+" .X.....XX. ",
+" .XXXXXXXX. ",
+" .......... "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("textfile"), textfile_xpm);
+}
+{
+#define tick_width 14
+#define tick_height 14
+static UNSIGNED_CHAR tick_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x1c, 0x00, 0x0e,
+ 0x00, 0x07, 0x80, 0x03, 0xc2, 0x01, 0xe7, 0x00, 0x7f, 0x00, 0x3e, 0x00,
+ 0x1c, 0x00, 0x08, 0x00};
+Tk_DefineBitmap(Et_Interp, Tk_GetUid("tick"), (char*)tick_bits, tick_width, tick_height);
+}
+{
+/* XPM */
+static char * warning_xpm[] = {
+"32 32 3 1",
+" s None c None",
+". c #000000000000",
+"X c yellow",
+" ",
+" ......... ",
+" ...XXXXXXXXX... ",
+" .XXXXXXXXXXXXXXX. ",
+" ..XXXXXXXXXXXXXXXXX.. ",
+" .XXXXXXXXX...XXXXXXXXX. ",
+" .XXXXXXXXX.....XXXXXXXXX. ",
+" .XXXXXXXXX.....XXXXXXXXX. ",
+" .XXXXXXXXX.......XXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+" .XXXXXXXXXX.......XXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXX.......XXXXXXXXXXX. ",
+".XXXXXXXXXXXX.....XXXXXXXXXXXX. ",
+".XXXXXXXXXXXX.....XXXXXXXXXXXX. ",
+".XXXXXXXXXXXX.....XXXXXXXXXXXX. ",
+".XXXXXXXXXXXXX...XXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XXXXXXXXXXXX...XXXXXXXXXXXX. ",
+" .XXXXXXXXXXX.....XXXXXXXXXXX. ",
+" .XXXXXXXXX.......XXXXXXXXX. ",
+" .XXXXXXXX.......XXXXXXXX. ",
+" .XXXXXXXX.......XXXXXXXX. ",
+" .XXXXXXXX.....XXXXXXXX. ",
+" ..XXXXXXX...XXXXXXX.. ",
+" .XXXXXXXXXXXXXXX. ",
+" ...XXXXXXXXX... ",
+" ......... "};
+Tix_DefinePixmap(Et_Interp, Tk_GetUid("warning"), warning_xpm);
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixDef.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixDef.h
new file mode 100755
index 00000000000..14b2dbc67e7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixDef.h
@@ -0,0 +1,173 @@
+
+/* $Id: tixDef.h,v 1.2 2000/10/17 16:35:37 idiscovery Exp $ */
+
+/*
+ * tixdef.h --
+ *
+ * This file defines the defaults for all options for all of
+ * the Tix widgets.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef TIX_DEFAULT
+#define TIX_DEFAULT
+
+/*
+ * Include the defaults of the TK distriburion
+ */
+#ifndef _DEFAULT
+#include <default.h>
+#endif
+
+#ifndef CTL_FONT
+#define CTL_FONT "Helvetica -12 bold"
+#endif
+
+#define BORDER_COLOR "gray"
+
+/*
+ * Compound widget
+ */
+#define DEF_CMPIMAGE_BG_COLOR NORMAL_BG
+#define DEF_CMPIMAGE_BG_MONO WHITE
+#define DEF_CMPIMAGE_FG_COLOR BLACK
+#define DEF_CMPIMAGE_FG_MONO BLACK
+#define DEF_CMPIMAGE_FONT CTL_FONT
+
+/*
+ * tixHList widget
+ */
+#define DEF_HLIST_BG_COLOR NORMAL_BG
+#define DEF_HLIST_BG_MONO WHITE
+#define DEF_HLIST_BORDER_WIDTH "2"
+#define DEF_HLIST_BROWSE_COMMAND ""
+#define DEF_HLIST_COMMAND ""
+#define DEF_HLIST_COLUMNS "1"
+#define DEF_HLIST_CURSOR ""
+#define DEF_HLIST_DISPLAY_MODE "tree"
+#define DEF_HLIST_DRAG_COMMAND ""
+#define DEF_HLIST_DRAW_BRANCH "true"
+#define DEF_HLIST_DROP_COMMAND ""
+#define DEF_HLIST_EXPORT_SELECTION "0"
+#define DEF_HLIST_FONT CTL_FONT
+#define DEF_HLIST_FG_COLOR BLACK
+#define DEF_HLIST_FG_MONO BLACK
+#define DEF_HLIST_HEADER "0"
+#define DEF_HLIST_HEIGHT "10"
+#define DEF_HLIST_HIGHLIGHT_COLOR BLACK
+#define DEF_HLIST_HIGHLIGHT_MONO BLACK
+#define DEF_HLIST_HIGHLIGHT_WIDTH "2"
+#define DEF_HLIST_RELIEF "sunken"
+#define DEF_HLIST_ORIENT "vertical"
+#define DEF_HLIST_PADX "2"
+#define DEF_HLIST_PADY "2"
+#define DEF_HLIST_GAP "5"
+#define DEF_HLIST_INDENT "10"
+#define DEF_HLIST_INDICATOR "0"
+#define DEF_HLIST_INDICATOR_CMD ""
+#define DEF_HLIST_ITEM_TYPE "text"
+#define DEF_HLIST_SELECT_BG_COLOR ACTIVE_BG
+#define DEF_HLIST_SELECT_FG_COLOR BLACK
+#define DEF_HLIST_SELECT_BG_MONO BLACK
+#define DEF_HLIST_SELECT_FG_MONO WHITE
+#define DEF_HLIST_SELECT_MODE "browse"
+#define DEF_HLIST_SELECT_BORDERWIDTH "1"
+#define DEF_HLIST_SEPARATOR "."
+#define DEF_HLIST_SIZE_COMMAND ""
+#define DEF_HLIST_TAKE_FOCUS "1"
+#define DEF_HLIST_WIDTH "20"
+#define DEF_HLIST_WIDE_SELECT "true"
+#define DEF_HLIST_Y_SCROLL_COMMAND ""
+#define DEF_HLIST_X_SCROLL_COMMAND ""
+
+/*
+ * HList Entry
+ */
+#define DEF_HLISTENTRY_BITMAP ""
+#define DEF_HLISTENTRY_DATA ""
+#define DEF_HLISTENTRY_GAP "4"
+#define DEF_HLISTENTRY_IMAGE ""
+#define DEF_HLISTENTRY_JUSTIFY "left"
+#define DEF_HLISTENTRY_NAME ""
+#define DEF_HLISTENTRY_PADX "2"
+#define DEF_HLISTENTRY_PADY "2"
+#define DEF_HLISTENTRY_STATE "normal"
+#define DEF_HLISTENTRY_TEXT ""
+#define DEF_HLISTENTRY_UNDERLINE "-1"
+#define DEF_HLISTENTRY_WIDGET ""
+#define DEF_HLISTENTRY_WLENGTH "0"
+
+/*
+ * HList Entry
+ */
+#define DEF_HLISTHEADER_BG_COLOR NORMAL_BG
+#define DEF_HLISTHEADER_BG_MONO WHITE
+#define DEF_HLISTHEADER_BORDER_WIDTH "2"
+#define DEF_HLISTHEADER_RELIEF "raised"
+
+/*
+ * tixNBFrame widget
+ */
+#define DEF_NOTEBOOKFRAME_ACTIVE_BG_COLOR ACTIVE_BG
+#define DEF_NOTEBOOKFRAME_ACTIVE_BG_MONO BLACK
+#define DEF_NOTEBOOKFRAME_INACTIVE_BG_COLOR TROUGH
+#define DEF_NOTEBOOKFRAME_INACTIVE_BG_MONO WHITE
+#define DEF_NOTEBOOKFRAME_BACKPAGE_COLOR NORMAL_BG
+#define DEF_NOTEBOOKFRAME_BACKPAGE_MONO WHITE
+#define DEF_NOTEBOOKFRAME_BG_COLOR NORMAL_BG
+#define DEF_NOTEBOOKFRAME_BG_MONO WHITE
+#define DEF_NOTEBOOKFRAME_DISABLED_FG_COLOR DISABLED
+#define DEF_NOTEBOOKFRAME_DISABLED_FG_MONO ""
+#define DEF_NOTEBOOKFRAME_FOCUS_COLOR BLACK
+#define DEF_NOTEBOOKFRAME_FOCUS_MONO BLACK
+#define DEF_NOTEBOOKFRAME_BORDER_WIDTH "2"
+#define DEF_NOTEBOOKFRAME_CURSOR ""
+#define DEF_NOTEBOOKFRAME_FONT CTL_FONT
+#define DEF_NOTEBOOKFRAME_FG_COLOR BLACK
+#define DEF_NOTEBOOKFRAME_FG_MONO BLACK
+#define DEF_NOTEBOOKFRAME_RELIEF "sunken"
+#define DEF_NOTEBOOKFRAME_SLAVE "1"
+#define DEF_NOTEBOOKFRAME_TAKE_FOCUS "1"
+#define DEF_NOTEBOOKFRAME_WIDTH "10"
+#define DEF_NOTEBOOKFRAME_TABPADX "6"
+#define DEF_NOTEBOOKFRAME_TABPADY "5"
+
+/*
+ * tixTList.h
+ */
+#define DEF_TLIST_BG_COLOR NORMAL_BG
+#define DEF_TLIST_BG_MONO WHITE
+#define DEF_TLIST_BORDER_WIDTH "2"
+#define DEF_TLIST_BROWSE_COMMAND ""
+#define DEF_TLIST_COMMAND ""
+#define DEF_TLIST_CURSOR ""
+#define DEF_TLIST_FONT CTL_FONT
+#define DEF_TLIST_FG_COLOR BLACK
+#define DEF_TLIST_FG_MONO BLACK
+#define DEF_TLIST_HEIGHT "10"
+#define DEF_TLIST_HIGHLIGHT_COLOR BLACK
+#define DEF_TLIST_HIGHLIGHT_MONO BLACK
+#define DEF_TLIST_HIGHLIGHT_WIDTH "2"
+#define DEF_TLIST_ITEM_TYPE "text"
+#define DEF_TLIST_RELIEF "sunken"
+#define DEF_TLIST_ORIENT "vertical"
+#define DEF_TLIST_PADX "2"
+#define DEF_TLIST_PADY "2"
+#define DEF_TLIST_SELECT_BG_COLOR ACTIVE_BG
+#define DEF_TLIST_SELECT_FG_COLOR BLACK
+#define DEF_TLIST_SELECT_BG_MONO BLACK
+#define DEF_TLIST_SELECT_FG_MONO WHITE
+#define DEF_TLIST_SELECT_MODE "browse"
+#define DEF_TLIST_SELECT_BORDERWIDTH "1"
+#define DEF_TLIST_STATE "normal"
+#define DEF_TLIST_SIZE_COMMAND ""
+#define DEF_TLIST_TAKE_FOCUS "1"
+#define DEF_TLIST_WIDTH "20"
+#define DEF_TLIST_Y_SCROLL_COMMAND ""
+#define DEF_TLIST_X_SCROLL_COMMAND ""
+
+#endif /* TIX_DEFAULT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixForm.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixForm.h
new file mode 100755
index 00000000000..8b2dbcd6976
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixForm.h
@@ -0,0 +1,143 @@
+
+/* $Id: tixForm.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixForm.h --
+ *
+ * Declares the internal functions and data types for the Tix Form
+ * geometry manager.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_FORM_H
+#define _TIX_FORM_H
+
+#define SIDE0 0
+#define SIDE1 1
+
+#define NEXT_SIDE(x) (!x)
+
+#define SIDEX 0
+#define SIDEY 1
+
+#define AXIS_X 0
+#define AXIS_Y 1
+
+#define OPPO_SIDE0 1
+#define OPPO_SIDE1 2
+#define OPPO_ALL 3
+
+#define PINNED_SIDE0 4
+#define PINNED_SIDE1 8
+#define PINNED_ALL 12
+
+#define ATT_NONE 0
+#define ATT_GRID 1
+#define ATT_OPPOSITE 2
+#define ATT_PARALLEL 3
+
+/*
+ * The following structures carry information about the client windows
+ */
+typedef union {
+ int grid;
+ struct _FormInfo * widget;
+} Attachment;
+
+typedef struct {
+ int pcnt; /* percentage anchor point */
+ int disp; /* displacement from the percentage anchor point*/
+} Side;
+
+typedef struct _FormInfo {
+ Tk_Window tkwin;
+ struct _MasterInfo* master; /* The master of this window */
+ struct _FormInfo * next;
+
+ int depend; /* used to detect circular dependency*/
+
+ /* These are specified by the user and set by the "tixForm" command
+ */
+ Attachment att[2][2]; /* anchor of attachment */
+ int off[2][2]; /* offset of attachment */
+ char isDefault[2][2];/* Is this side a default attachment*/
+
+ char attType[2][2]; /* type of attachment
+ GRID or PIXEL*/
+ int pad[2][2]; /* value of padding */
+
+ /* These values are calculated by the PinnClient() functions
+ * and are used to calculated the required size of the master
+ * inside CalculateMasterGeometry(), as well as the positions
+ * of the clients inside ArrangeGeometry()
+ */
+ Side side[2][2];
+ int sideFlags[2];
+
+ /* These values are used to place the clients into the clients
+ */
+ int posn[2][2];
+
+ /* These things are for Spring'ing */
+ int spring[2][2];
+ struct _FormInfo * strWidget[2][2];
+ int springFail[2];
+ int fill[2];
+} FormInfo;
+
+
+/*
+ * The following structures carry information about the master windows
+ */
+typedef struct {
+ unsigned int isDeleted : 1;
+ unsigned int repackPending : 1;
+} MasterFlags;
+
+typedef struct _MasterInfo {
+ Tk_Window tkwin;
+ struct _FormInfo * client;
+ struct _FormInfo * client_tail;
+ int numClients;
+ int reqSize[2];
+ int numRequests; /* This is used to detect
+ * whether two geometry managers
+ * are used to manage the same
+ * master window
+ */
+ int grids[2];
+ MasterFlags flags;
+} MasterInfo;
+
+/* tixFormMisc.c */
+
+
+EXTERN int TixFm_Configure _ANSI_ARGS_((FormInfo *clientPtr,
+ Tk_Window topLevel,
+ Tcl_Interp* interp, int argc, Tcl_Obj *CONST *objv));
+
+/* tixForm.c */
+EXTERN FormInfo * TixFm_GetFormInfo _ANSI_ARGS_((Tk_Window tkwin,
+ int create));
+EXTERN void TixFm_StructureProc _ANSI_ARGS_((ClientData clientData,
+ XEvent * eventPtr));
+EXTERN void TixFm_AddToMaster _ANSI_ARGS_((MasterInfo *masterPtr,
+ FormInfo *clientPtr));
+EXTERN void TixFm_DeleteMaster _ANSI_ARGS_((
+ MasterInfo *masterPtr));
+EXTERN void TixFm_FreeMasterInfo _ANSI_ARGS_((
+ char *clientData));
+EXTERN FormInfo * TixFm_FindClientPtrByName _ANSI_ARGS_((
+ Tcl_Interp * interp, char * name,
+ Tk_Window topLevel));
+EXTERN void TixFm_ForgetOneClient _ANSI_ARGS_((
+ FormInfo *clientPtr));
+EXTERN void TixFm_Unlink _ANSI_ARGS_((FormInfo *clientPtr));
+EXTERN void TixFm_UnlinkFromMaster _ANSI_ARGS_((
+ FormInfo *clientPtr));
+#endif /* _TIX_FORM_H */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrData.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrData.h
new file mode 100755
index 00000000000..1db10aaa37b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrData.h
@@ -0,0 +1,88 @@
+
+/* $Id: tixGrData.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixGData.h --
+ *
+ * Defines portable data structure for tixGrid.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_GRID_DATA_H_
+#define _TIX_GRID_DATA_H_
+
+/*
+ * Data structure that stored the cells in a Grid widget. It is optimized
+ * for column/row insertion and deletion.
+ *
+ * - A grid is divideded into a set of rows and columns. Each row and column
+ * is divided into a set of cells.
+ *
+ * - The following discusses the structure of a row. The structure of a
+ * column is the reverse of a row.
+ *
+ * Row y is stored in the hash table TixGridDataSet.index[1] with
+ * the index y. Hence, to search for row y, we use the FindHashEntry
+ * operation:
+ *
+ * row_y = TixGridDataSet.index[1].FindHashEntry(y);
+ *
+ * To locate a cell (x,y), we can first find the row y, and then
+ * locate the cell at column x of this row. Note that the cell is
+ * *not* indexed by its column position (y), but rather by the hash
+ * table of the column y. The following example illustrates how cell
+ * (x,y) can be searched:
+ *
+ * row_y = TixGridDataSet.index[1].FindHashEntry(y);
+ * col_x = TixGridDataSet.index[0].FindHashEntry(x);
+ *
+ * cell_xy = row_x.list.FindHashEntry(&col_x);
+ *
+ * The advantage of this arrangement is it is very efficient to
+ * insert a row into into the grid -- we just have to fix the
+ * indices of the rows table. For example, if, after the insertion,
+ * row_y is now moved to the row y1, we change its index from y to
+ * y1. In general, an insertion operation takes log(n) time in a
+ * grid that contains n items.
+ *
+ */
+typedef struct TixGridDataSet {
+ Tcl_HashTable index[2]; /* the row and column indices */
+ /* index[0] holds the columns
+ * (horizontal index)
+ */
+ int maxIdx[2]; /* the max row/col, or {-1,-1}
+ * if there are no rows/col
+ */
+} TixGridDataSet;
+
+#define TIX_GR_AUTO 0
+#define TIX_GR_DEFAULT 1
+#define TIX_GR_DEFINED_PIXEL 2
+#define TIX_GR_DEFINED_CHAR 3
+
+typedef struct TixGridSize {
+ int sizeType;
+ int sizeValue; /* width or height */
+ int pixels;
+ int pad0, pad1;
+ double charValue;
+} TixGridSize;
+
+typedef struct TixGridRowCol {
+ /* private: */
+ Tcl_HashTable table;
+
+ /* public: */
+ int dispIndex; /* the row or column in which
+ * this TixGridRowCol is displayed */
+ TixGridSize size;
+} TixGridRowCol;
+
+
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrid.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrid.h
new file mode 100755
index 00000000000..b1733b64e18
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixGrid.h
@@ -0,0 +1,458 @@
+
+/* $Id: tixGrid.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixGrid.h --
+ *
+ * Defines main data structures for tixGrid
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_GRID_H_
+#define _TIX_GRID_H_
+#include "tkVMacro.h"
+
+#ifndef _TIX_GRID_DATA_H_
+#include "tixGrData.h"
+#endif
+
+#define TIX_X 0
+#define TIX_Y 1
+
+
+#define TIX_S_MARGIN 0
+#define TIX_X_MARGIN 1
+#define TIX_Y_MARGIN 2
+#define TIX_MAIN 3
+
+#define TIX_SITE_NONE -1
+
+typedef struct TixGrEntry {
+ Tix_DItem * iPtr;
+ Tcl_HashEntry * entryPtr[2]; /* The index of this entry in the
+ * row/col tables */
+} TixGrEntry;
+
+/*----------------------------------------------------------------------
+ * Render Block
+ *
+ * Before the Grid is rendered, information is filled into a pseudo 2D
+ * array of RenderBlockElem's:
+ *
+ * (1) entries are placed in the appropriate (x,y) locations
+ * (2) background and borders are formatted according
+ * (3) highlights are formatted.
+ *
+ * The widget is redrawn using the render-block. This saves reformatting
+ * the next time the widget is exposed.
+ *----------------------------------------------------------------------
+ */
+typedef struct RenderBlockElem {
+ TixGrEntry * chPtr; /* not allocated, don't need to free */
+ int borderW[2][2];
+ int index[2];
+
+ unsigned int selected : 1;
+ unsigned int filled : 1;
+} RenderBlockElem;
+
+
+/* ElmDispSize --
+ *
+ * This structure stores the size information of the visible
+ * rows (RenderBlock.dispSize[0][...]) and columns
+ * (RenderBlock.dispSize[1][...])
+ */
+typedef struct ElmDispSize {
+ int preBorder;
+ int size;
+ int postBorder;
+
+ int total; /* simple the sum of the above */
+} ElmDispSize;
+
+typedef struct RenderBlock {
+ int size[2]; /* num of rows and cols in the render block */
+
+ RenderBlockElem **elms; /* An Malloc'ed pseudo 2D array (you can do
+ * things like elms[0][0]), Used for the
+ * main body of the Grid.
+ */
+ ElmDispSize *dispSize[2]; /* (dispSizes[0][x], dispSizes[1][y])
+ * will be the dimension of the element (x,y)
+ * displayed on the screen (may be bigger
+ * or smaller than its desired size). */
+ int visArea[2]; /* visible area (width times height) of
+ * the visible cells on the screen */
+} RenderBlock;
+
+/*----------------------------------------------------------------------
+ * RenderInfo
+ *
+ * This stores information for rendering from the RB into an X drawable.
+ *
+ *----------------------------------------------------------------------
+ */
+typedef struct RenderInfo {
+ Drawable drawable;
+ int origin[2];
+ int offset[2];
+ int size[2]; /* width and height of the area to draw
+ * (number of pixels starting from the offset)
+ * if offset = (2,2) and size = (5,5) we have
+ * to draw the rectangle ((2,2), (6,6));
+ */
+ struct { /* the current valid grid area for the */
+ int x1, x2, y1, y2; /* "format" command */
+ int whichArea;
+ } fmt;
+} RenderInfo;
+
+typedef struct ExposedArea {
+ int x1, y1, x2, y2;
+} ExposedArea, Rect;
+
+/*----------------------------------------------------------------------
+ * ColorInfo
+ *
+ * These colors are used by the format commands. They must be saved
+ * or otherwise the colormap may be changed ..
+ *----------------------------------------------------------------------
+ */
+typedef struct ColorInfo {
+ struct ColorInfo * next;
+ int counter;
+ int type; /* TK_CONFIG_BORDER or TK_CONFIG_COLOR */
+ long pixel;
+ Tk_3DBorder border;
+ XColor * color;
+} ColorInfo;
+
+/*----------------------------------------------------------------------
+ * SelectBlock
+ *
+ * These structures are arranged in a list and are used to determine
+ * where a cell is selected.
+ *----------------------------------------------------------------------
+ */
+#define TIX_GR_CLEAR 1
+#define TIX_GR_SET 2
+#define TIX_GR_TOGGLE 3
+
+#define TIX_GR_MAX 0x7fffffff
+
+#define TIX_GR_RESIZE 1
+#define TIX_GR_REDRAW 2
+
+
+typedef struct SelectBlock {
+ struct SelectBlock * next;
+ int range[2][2]; /* the top left and bottom right corners */
+ int type; /* TIX_GR_CLEAR, TIX_GR_SET,
+ * TIX_GR_TOGGLE
+ *
+ * If several SelectBlock covers the same
+ * cell, the last block in the wPtr->selList
+ * determines whether this cell is selected
+ * or not */
+} SelectBlock;
+
+/*----------------------------------------------------------------------
+ * GrSortItem
+ *
+ * Used to sort the items in the grid
+ *----------------------------------------------------------------------
+ */
+typedef struct Tix_GrSortItem {
+ Tcl_Obj * data; /* is usually a string, but
+ * can be a pointer to an
+ * arbitrary data in C API */
+ int index; /* row or column */
+} Tix_GrSortItem;
+
+/*----------------------------------------------------------------------
+ * Data structure for iterating the cells inside the grid.
+ *
+ *----------------------------------------------------------------------
+ */
+
+typedef struct Tix_GrDataRowSearch {
+ struct TixGridRowCol * row;
+ Tcl_HashSearch hashSearch;
+ Tcl_HashEntry *hashPtr;
+} Tix_GrDataRowSearch;
+
+typedef struct Tix_GrDataCellSearch {
+ char * data;
+ Tcl_HashSearch hashSearch;
+ Tcl_HashEntry *hashPtr;
+} Tix_GrDataCellSearch;
+
+/*----------------------------------------------------------------------
+ *
+ * Main data structure of the grid widget.
+ *
+ *----------------------------------------------------------------------
+ */
+typedef struct Tix_GridScrollInfo {
+ LangCallback *command;
+
+ int max; /* total size (width or height) of the widget*/
+ int offset; /* The top/left side of the scrolled widget */
+ int unit; /* How much should we scroll when the user */
+
+ double window; /* visible size, percentage of the total */
+}Tix_GridScrollInfo;
+
+
+typedef struct GridStruct {
+ Tix_DispData dispData;
+
+ Tcl_Command widgetCmd; /* Token for button's widget command. */
+
+ /*
+ * Information used when displaying widget:
+ */
+ int reqSize[2]; /* For app programmer to request size */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ /* Border and general drawing */
+ int borderWidth; /* Width of 3-D borders. */
+ int selBorderWidth; /* Width of 3-D borders for selected items */
+ int relief; /* Indicates whether window as a whole is
+ * raised, sunken, or flat. */
+ Tk_3DBorder border; /* Used for drawing the 3d border. */
+ Tk_3DBorder selectBorder; /* Used for selected background. */
+ XColor *normalFg; /* Normal foreground for text. */
+ XColor *normalBg; /* Normal background for text. */
+ XColor *selectFg; /* Color for drawing selected text. */
+
+ Tk_Uid state; /* State can only be normal or disabled. */
+
+ /* GC and stuff */
+ GC backgroundGC; /* GC for drawing background. */
+ GC selectGC; /* GC for drawing selected background. */
+ GC anchorGC; /* GC for drawing dotted anchor highlight. */
+ TixFont font; /* Default font used by the DItems. */
+
+ /* Text drawing */
+ Cursor cursor; /* Current cursor for window, or None. */
+
+ /* For highlights */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ int bdPad; /* = highlightWidth + borderWidth */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ GC highlightGC; /* For drawing traversal highlight. */
+
+ /*
+ * default pad and gap values
+ */
+ int padX, padY;
+
+ Tk_Uid selectMode; /* Selection style: single, browse, multiple,
+ * or extended. This value isn't used in C
+ * code, but the Tcl bindings use it. */
+ Tk_Uid selectUnit; /* Selection unit: cell, row or column.
+ * This value isn't used in C
+ * code, but the Tcl bindings use it. */
+
+ /*
+ * The following three sites are used according to the -selectunit.
+ * if selectunit is: "cell", [0] and [1] are used; "row", only [0]
+ * is used; "column", only [1] is used
+ */
+ int anchor[2]; /* The current anchor unit */
+ int dropSite[2]; /* The current drop site */
+ int dragSite[2]; /* The current drop site */
+
+ /*
+ * Callback commands.
+ */
+ LangCallback *command; /* The command when user double-clicks */
+ LangCallback *browseCmd; /* The command to call when the selection
+ * changes. */
+ LangCallback *editNotifyCmd; /* The command to call to determine whether
+ * a cell is editable. */
+ LangCallback *editDoneCmd; /* The command to call when an entry has
+ * been edited by the user.*/
+ LangCallback *formatCmd; /* The command to call when the Grid widget
+ * needs to be reformatted (e.g, Exposure
+ * events or when contents have been
+ * changed). */
+ LangCallback *sizeCmd; /* The command to call when the size of
+ * the listbox changes. E.g., when the user
+ * add/deletes elements. Useful for auto-
+ * scrollbar geometry managers */
+
+ /*
+ * Info for lay-out
+ */
+ char *takeFocus; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+
+ int serial; /* this number is incremented before each time
+ * the widget is redisplayed */
+
+ TixGridDataSet * dataSet;
+ RenderBlock * mainRB; /* Malloc'ed */
+
+ int hdrSize[2]; /* number of rows (height of x header, index
+ * [0]) and columns (width of y header, index
+ * [1]) */
+ int floatRange[2]; /* Are the num of columns and rows floated?
+ * (if floated, you can scroll past the max
+ * element).*/
+ int gridSize[2]; /* the size of the grid where there is data */
+ Tix_DItemInfo * diTypePtr; /* Default item type */
+ ExposedArea expArea;
+
+ RenderInfo * renderInfo; /* only points to stuff in stack */
+ Tix_GridScrollInfo scrollInfo[2];
+ int fontSize[2]; /* size of the "0" char of the -font option
+ */
+ TixGridSize defSize[2];
+ Tix_LinkList colorInfo;
+ Tix_LinkList selList;
+ Tix_LinkList mappedWindows;
+ int colorInfoCounter;
+
+ unsigned int hasFocus : 1;
+
+ unsigned int idleEvent : 1;
+ unsigned int toResize : 1; /* idle event */
+ unsigned int toRedraw : 1; /* idle event */
+
+ unsigned int toResetRB : 1; /* Do we need to reset the render block */
+ unsigned int toComputeSel : 1;
+ unsigned int toRedrawHighlight : 1;
+} Grid;
+
+typedef Grid WidgetRecord;
+typedef Grid * WidgetPtr;
+
+#define DEF_GRID_BG_COLOR NORMAL_BG
+#define DEF_GRID_BG_MONO WHITE
+#define DEF_GRID_BORDER_WIDTH "2"
+#define DEF_GRID_BROWSE_COMMAND ""
+#define DEF_GRID_COMMAND ""
+#define DEF_GRID_CURSOR ""
+#define DEF_GRID_DEFAULT_WIDTH "40"
+#define DEF_GRID_DEFAULT_HEIGHT "20"
+#define DEF_GRID_EDITDONE_COMMAND ""
+#define DEF_GRID_EDITNOTIFY_COMMAND ""
+#define DEF_GRID_FLOATING_ROWS "0"
+#define DEF_GRID_FLOATING_COLS "0"
+#define DEF_GRID_FONT "Helvetica -12 bold"
+#define DEF_GRID_FG_COLOR BLACK
+#define DEF_GRID_FG_MONO BLACK
+#define DEF_GRID_FORMAT_COMMAND ""
+#define DEF_GRID_HEIGHT "10"
+#define DEF_GRID_HIGHLIGHT_COLOR BLACK
+#define DEF_GRID_HIGHLIGHT_MONO BLACK
+#define DEF_GRID_HIGHLIGHT_WIDTH "2"
+#define DEF_GRID_LEFT_MARGIN "1"
+#define DEF_GRID_ITEM_TYPE "text"
+#define DEF_GRID_RELIEF "sunken"
+#define DEF_GRID_PADX "2"
+#define DEF_GRID_PADY "2"
+#define DEF_GRID_SELECT_BG_COLOR ACTIVE_BG
+#define DEF_GRID_SELECT_FG_COLOR BLACK
+#define DEF_GRID_SELECT_BG_MONO BLACK
+#define DEF_GRID_SELECT_FG_MONO WHITE
+#define DEF_GRID_SELECT_MODE "single"
+#define DEF_GRID_SELECT_UNIT "row"
+#define DEF_GRID_SELECT_BORDERWIDTH "1"
+#define DEF_GRID_STATE "normal"
+#define DEF_GRID_SIZE_COMMAND ""
+#define DEF_GRID_TAKE_FOCUS "1"
+#define DEF_GRID_TOP_MARGIN "1"
+#define DEF_GRID_WIDTH "4"
+#define DEF_GRID_Y_SCROLL_COMMAND ""
+#define DEF_GRID_X_SCROLL_COMMAND ""
+
+/*
+ * common functions
+ */
+
+EXTERN void Tix_GrAddChangedRect _ANSI_ARGS_((
+ WidgetPtr wPtr, int changedRect[2][2],
+ int isSite));
+EXTERN int Tix_GrConfigSize _ANSI_ARGS_((Tcl_Interp *interp,
+ WidgetPtr wPtr, int argc, Tcl_Obj *CONST *objv,
+ TixGridSize *sizePtr, char * argcErrorMsg,
+ int *changed_ret));
+EXTERN void Tix_GrDoWhenIdle _ANSI_ARGS_((WidgetPtr wPtr,
+ int type));
+EXTERN void Tix_GrCancelDoWhenIdle _ANSI_ARGS_((WidgetPtr wPtr));
+EXTERN void Tix_GrFreeElem _ANSI_ARGS_((TixGrEntry * chPtr));
+EXTERN void Tix_GrFreeUnusedColors _ANSI_ARGS_((WidgetPtr wPtr,
+ int freeAll));
+EXTERN void Tix_GrScrollPage _ANSI_ARGS_((WidgetPtr wPtr,
+ int count, int axis));
+
+/*
+ * The dataset functions
+ */
+
+EXTERN int TixGridDataConfigRowColSize _ANSI_ARGS_((
+ Tcl_Interp * interp, WidgetPtr wPtr,
+ TixGridDataSet * dataSet, int which, int index,
+ int argc, Tcl_Obj *CONST *objv, char * argcErrorMsg,
+ int *changed_ret));
+EXTERN char * TixGridDataCreateEntry _ANSI_ARGS_((
+ TixGridDataSet * dataSet, int x, int y,
+ char * defaultEntry));
+EXTERN int TixGridDataDeleteEntry _ANSI_ARGS_((
+ TixGridDataSet * dataSet, int x, int y));
+EXTERN void TixGridDataDeleteRange _ANSI_ARGS_((WidgetPtr wPtr,
+ TixGridDataSet * dataSet, int which,
+ int from, int to));
+EXTERN void TixGridDataDeleteSearchedEntry _ANSI_ARGS_((
+ Tix_GrDataCellSearch * cellSearchPtr));
+EXTERN char * TixGridDataFindEntry _ANSI_ARGS_((
+ TixGridDataSet * dataSet, int x, int y));
+EXTERN int TixGrDataFirstCell _ANSI_ARGS_((
+ Tix_GrDataRowSearch * rowSearchPtr,
+ Tix_GrDataCellSearch * cellSearchPtr));
+EXTERN int TixGrDataFirstRow _ANSI_ARGS_((
+ TixGridDataSet* dataSet,
+ Tix_GrDataRowSearch * rowSearchPtr));
+EXTERN int TixGridDataGetRowColSize _ANSI_ARGS_((
+ WidgetPtr wPtr, TixGridDataSet * dataSet,
+ int which, int index, TixGridSize * defSize,
+ int *pad0, int * pad1));
+EXTERN void TixGridDataGetGridSize _ANSI_ARGS_((
+ TixGridDataSet * dataSet, int *width_ret,
+ int *height_ret));
+EXTERN int TixGridDataGetIndex _ANSI_ARGS_((
+ Tcl_Interp * interp, WidgetPtr wPtr,
+ Tcl_Obj * xStr, Tcl_Obj * yStr, int * xPtr, int * yPtr));
+EXTERN void TixGridDataInsert _ANSI_ARGS_((
+ TixGridDataSet * dataSet,
+ int x, int y, ClientData data));
+EXTERN void TixGridDataMoveRange _ANSI_ARGS_((WidgetPtr wPtr,
+ TixGridDataSet * dataSet, int which,
+ int from, int to, int by));
+EXTERN int TixGrDataNextCell _ANSI_ARGS_((
+ Tix_GrDataCellSearch * cellSearchPtr));
+EXTERN int TixGrDataNextRow _ANSI_ARGS_((
+ Tix_GrDataRowSearch * rowSearchPtr));
+EXTERN TixGridDataSet* TixGridDataSetInit _ANSI_ARGS_((void));
+EXTERN void TixGridDataSetFree _ANSI_ARGS_((
+ TixGridDataSet* dataSet));
+EXTERN int TixGridDataUpdateSort _ANSI_ARGS_((
+ TixGridDataSet * dataSet, int axis,
+ int start, int end, Tix_GrSortItem *items));
+
+#endif /*_TIX_GRID_H_*/
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixHList.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixHList.h
new file mode 100755
index 00000000000..5625f137c15
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixHList.h
@@ -0,0 +1,323 @@
+
+/* $Id: tixHList.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixHList.h --
+ *
+ * Defines the data structures and functions used by the tixHList
+ * widget.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_HLIST_H_
+#define _TIX_HLIST_H_
+
+#ifndef _TIX_INT_H_
+#include "tixInt.h"
+#endif
+
+#include "tkVMacro.h"
+
+#define HLTYPE_COLUMN 1
+#define HLTYPE_HEADER 2
+#define HLTYPE_ENTRY 3
+
+/* This is used to indetify what object has caused a DItemSizeChange
+ * All data structs for objects that manage DItems must have these two
+ * members as the beginning of the struct.
+ */
+typedef struct HLItemTypeInfo {
+ int type;
+ char * self;
+} HLItemTypeInfo;
+
+typedef struct HListColumn {
+ /* generic type info section */
+ int type;
+ char * self;
+ struct _HListElement * chPtr;
+
+ /* other data */
+ Tix_DItem * iPtr;
+ int width;
+} HListColumn;
+
+typedef struct HListHeader {
+ /* generic type info section */
+ int type;
+ char * self;
+
+ struct HListStruct * wPtr;
+ /* other data */
+ Tix_DItem * iPtr;
+ int width;
+
+ Tk_3DBorder background; /* Used for drawing the 3d border. */
+ int relief; /* Indicates whether window as a whole is
+ * raised, sunken, or flat. */
+ int borderWidth;
+} HListHeader;
+
+/*----------------------------------------------------------------------
+ * A HListElement structure contain the information about each element
+ * inside the HList.
+ *
+ */
+typedef struct _HListElement {
+ /* generic type info section */
+ int type;
+ char * self;
+
+ /* other data */
+ struct HListStruct * wPtr;
+ struct _HListElement * parent;
+ struct _HListElement * prev;
+ struct _HListElement * next;
+ struct _HListElement * childHead;
+ struct _HListElement * childTail;
+
+ int numSelectedChild; /* number of childs that has selection(s) in
+ * them (either this child is selected or some
+ * of its descendants are selected */
+ int numCreatedChild; /* this var gets increment by one each
+ * time a child is created */
+ char * pathName; /* Full pathname of this element */
+ char * name; /* Name of this element */
+ int height; /* Height of this element, including padding
+ * and selBorderWidth;
+ */
+ int allHeight; /* Height of all descendants and self */
+ Tk_Uid state; /* State of Tab's for display purposes:
+ * normal or disabled. */
+ Tcl_Obj * data; /* user data field */
+ /* bottom-middle position of the bitmap/image branch (offset from
+ * the top-left corner of the item)
+ */
+ int branchX;
+ int branchY;
+
+ /* offset of the left-middle position of the icon */
+ int iconX;
+ int iconY;
+ /*----------------------------------*/
+ /* Things to display in the element */
+ /*----------------------------------*/
+ HListColumn * col; /* the multi-column display items */
+ HListColumn _oneCol; /* If we have only one column, then this
+ * space is used (pointed to by column).
+ * This will save one Malloc */
+ int indent;
+ Tix_DItem * indicator; /* indicator: little triangle on Mac */
+
+ /*----------------------------------*/
+ /* Flags */
+ /*----------------------------------*/
+ Tix_DItemInfo * diTypePtr;
+
+ unsigned int selected : 1;
+ unsigned int hidden : 1;
+ unsigned int dirty : 1; /* If it is dirty then its geometry needs
+ * be recalculated */
+} Tix_HListElement, HListElement;
+
+/*
+ * A data structure of the following type is kept for each
+ * widget managed by this file:
+ */
+typedef struct HListStruct {
+ Tix_DispData dispData;
+ Tcl_Command widgetCmd; /* Token for button's widget command. */
+
+ /*
+ * Information used when displaying widget:
+ */
+ LangCallback *command; /* Command prefix to use when invoking
+ * scrolling commands. NULL means don't
+ * invoke commands. Malloc'ed. */
+ int width, height; /* For app programmer to request size */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ /* Border and general drawing */
+ int borderWidth; /* Width of 3-D borders. */
+ int selBorderWidth; /* Width of 3-D borders for selected items */
+ int relief; /* Indicates whether window as a whole is
+ * raised, sunken, or flat. */
+ int indent; /* How much should the children be indented
+ * (to the right)?, in pixels */
+ Tk_3DBorder border; /* Used for drawing the 3d border. */
+ Tk_3DBorder selectBorder; /* Used for selected background. */
+ XColor *normalFg; /* Normal foreground for text. */
+ XColor *normalBg; /* Normal bachground for text. */
+ XColor *selectFg; /* Color for drawing selected text. */
+ TixFont font; /* The default font used in the DItems. */
+ GC backgroundGC; /* GC for drawing background. */
+ GC normalGC; /* GC for drawing text in normal mode. */
+ GC selectGC; /* GC for drawing selected background. */
+ GC anchorGC; /* GC for drawing dotted anchor highlight. */
+ GC dropSiteGC; /* GC for drawing dotted anchor highlight. */
+
+ Cursor cursor; /* Current cursor for window, or None. */
+
+ int topPixel; /* Vertical offset */
+ int leftPixel; /* Horizontal offset */
+ int bottomPixel;
+ int wideSelect; /* BOOL: if 1, use a wide selection: the
+ * selection background color covers the whole
+ * widget. If 0, only the "significant" part
+ * of a list entry is highlighted */
+ int selectWidth; /* Width of the selection: takes effect only
+ * if wideSelect == 1 */
+ int exportSelection; /* Do we grab X Selection */
+ /* For highlights */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ GC highlightGC; /* For drawing traversal highlight. */
+
+ /* default pad and gap values */
+ int gap, padX, padY;
+ char * separator;
+
+ Tk_Uid selectMode; /* Selection style: single, browse, multiple,
+ * or extended. This value isn't used in C
+ * code, but the Tcl bindings use it. */
+ int drawBranch; /* Whether to draw the "branch" lines from
+ * parent entry to children */
+ Tcl_HashTable childTable; /* Hash table to translate child names
+ * into (HListElement *) */
+ HListElement * root; /* Mother of all elements */
+ HListElement * anchor; /* The current anchor item */
+ HListElement * dragSite; /* The current drag site */
+ HListElement * dropSite; /* The current drop site */
+
+ LangCallback *yScrollCmd; /* Command prefix for communicating with
+ * vertical scrollbar. NULL means no command
+ * to issue. Malloc'ed. */
+ LangCallback *xScrollCmd; /* Command prefix for communicating with
+ * horizontal scrollbar. NULL means no command
+ * to issue. Malloc'ed. */
+ LangCallback *sizeCmd; /* The command to call when the size of
+ * the listbox changes. E.g., when the user
+ * add/deletes elements. Useful for
+ * auto-scrollbar geometry managers */
+ LangCallback *browseCmd; /* The command to call when the selection
+ * changes. */
+ LangCallback *indicatorCmd; /* The command to call when the user touches
+ * the indicator. */
+ LangCallback *dragCmd; /* The command to call when info about a
+ * drag source is needed */
+ LangCallback *dropCmd; /* The command to call when action at a drop
+ * side needs to be performed */
+ char *takeFocus; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+
+ Tix_LinkList mappedWindows; /* Those windows that are are mapped by this
+ * widget*/
+ int serial; /* this number is incremented before each time
+ * the widget is redisplayed */
+
+ int numColumns; /* number of columns in the tixHList widget,
+ * cannot be changed after the widget's
+ * creation */
+
+ int totalSize[2];
+
+ HListColumn * reqSize; /* Requested column sizes by the user:
+ take precedence */
+ HListColumn * actualSize; /* Actual column sizes, calculated using
+ * the sizes of the ditems */
+
+ HListHeader ** headers; /* Stores all the headers for a HList widget */
+ int useHeader; /* whether headers should be used */
+ int headerHeight; /* required height of the header */
+
+ Tix_DItemInfo * diTypePtr; /* Default item type */
+ Tix_StyleTemplate stTmpl;
+
+ int useIndicator; /* should indicators be displayed */
+ int scrollUnit[2];
+
+ Tk_Window headerWin; /* subwindow, used to draw the headers */
+ char * elmToSee; /* name of element to "see" the next time
+ * this widget is redrawn */
+ unsigned redrawing : 1;
+ unsigned redrawingFrame : 1;
+ unsigned resizing : 1;
+ unsigned hasFocus : 1;
+ unsigned allDirty : 1;
+ unsigned initialized : 1;
+ unsigned headerDirty : 1;
+ unsigned needToRaise : 1; /* The header subwindow needs to be raised
+ * if we add a new window item into the
+ * HList widget (either in the list or
+ * in the header */
+} HList;
+
+#define TIX_X 0
+#define TIX_Y 1
+#define UNINITIALIZED -1
+
+typedef HList WidgetRecord;
+typedef HList * WidgetPtr;
+
+EXTERN TIX_DECLARE_SUBCMD(Tix_HLColumn);
+EXTERN TIX_DECLARE_SUBCMD(Tix_HLItem);
+
+EXTERN HListColumn * Tix_HLAllocColumn _ANSI_ARGS_((
+ WidgetPtr wPtr, HListElement * chPtr));
+EXTERN void Tix_HLCancelResizeWhenIdle _ANSI_ARGS_((
+ WidgetPtr wPtr));
+EXTERN void Tix_HLComputeGeometry _ANSI_ARGS_((
+ ClientData clientData));
+EXTERN HListElement * Tix_HLFindElement _ANSI_ARGS_((Tcl_Interp *interp,
+ WidgetPtr wPtr, char * pathName));
+EXTERN void Tix_HLFreeMappedWindow _ANSI_ARGS_((WidgetPtr wPtr,
+ HListElement * chPtr));
+EXTERN int Tix_HLElementTopOffset _ANSI_ARGS_((
+ WidgetPtr wPtr, HListElement *chPtr));
+EXTERN int Tix_HLElementLeftOffset _ANSI_ARGS_((
+ WidgetPtr wPtr, HListElement *chPtr));
+EXTERN int Tix_HLItemInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ WidgetPtr wPtr, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tix_HLHeader _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tix_HLCreateHeaders _ANSI_ARGS_((
+ Tcl_Interp *interp, WidgetPtr wPtr));
+EXTERN void Tix_HLFreeHeaders _ANSI_ARGS_((
+ Tcl_Interp *interp, WidgetPtr wPtr));
+EXTERN void Tix_HLDrawHeader _ANSI_ARGS_((
+ WidgetPtr wPtr, Pixmap pixmap, GC gc,
+ int hdrX, int hdrY, int hdrW, int hdrH,
+ int xOffset));
+EXTERN void Tix_HLComputeHeaderGeometry _ANSI_ARGS_((
+ WidgetPtr wPtr));
+
+EXTERN void Tix_HLMarkElementDirty _ANSI_ARGS_((WidgetPtr wPtr,
+ HListElement *chPtr));
+EXTERN void Tix_HLResizeWhenIdle _ANSI_ARGS_((WidgetPtr wPtr));
+EXTERN void Tix_HLResizeNow _ANSI_ARGS_((WidgetPtr wPtr));
+EXTERN void Tix_HLComputeGeometry _ANSI_ARGS_((
+ ClientData clientData));
+EXTERN void Tix_HLCancelResizeWhenIdle _ANSI_ARGS_((
+ WidgetPtr wPtr));
+
+
+/* in tixHLCol.c */
+EXTERN TIX_DECLARE_SUBCMD(Tix_HLColumn);
+EXTERN TIX_DECLARE_SUBCMD(Tix_HLItem);
+
+/* in tixHLInd.c */
+EXTERN TIX_DECLARE_SUBCMD(Tix_HLIndicator);
+
+#endif /*_TIX_HLIST_H_ */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.h
new file mode 100755
index 00000000000..deb68ea76e1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.h
@@ -0,0 +1,134 @@
+
+/* $Id: tixImgXpm.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixImgXpm.h --
+ *
+ * Generic header file for the pixmap image type. This is NOT a public
+ * header file!
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_IMG_XPM_H_
+#define _TIX_IMG_XPM_H_
+#define _TIXIMGXPM
+/*
+ * Constants
+ */
+
+#define XPM_MONO 1
+#define XPM_GRAY_4 2
+#define XPM_GRAY 3
+#define XPM_COLOR 4
+#define XPM_SYMBOLIC 5
+#define XPM_UNKNOWN 6
+
+/*
+ * The following data structure represents the master for a pixmap
+ * image:
+ */
+
+typedef struct PixmapMaster {
+ Tk_ImageMaster tkMaster; /* Tk's token for image master. NULL means
+ * the image is being deleted. */
+ Tcl_Interp *interp; /* Interpreter for application that is
+ * using image. */
+ Tcl_Command imageCmd; /* Token for image command (used to delete
+ * it when the image goes away). NULL means
+ * the image command has already been
+ * deleted. */
+ char *fileString; /* Value of -file option (malloc'ed).
+ * valid only if the -file option is specified
+ */
+ char *dataString; /* Value of -data option (malloc'ed).
+ * valid only if the -data option is specified
+ */
+ Tk_Uid id; /* ID's for XPM data already compiled
+ * into the tixwish binary */
+ int size[2]; /* width and height */
+ int ncolors; /* number of colors */
+ int cpp; /* characters per pixel */
+ char ** data; /* The data that defines this pixmap
+ * image (array of strings). It is
+ * converted into an X Pixmap when this
+ * image is instanciated
+ */
+ int isDataAlloced; /* False iff the data is got from
+ * the -id switch */
+ /* First in list of all instances associated
+ * with this master. */
+ struct PixmapInstance *instancePtr;
+} PixmapMaster;
+
+typedef struct ColorStruct {
+ char c; /* This is used if CPP is one */
+ char * cstring; /* This is used if CPP is bigger than one */
+ XColor * colorPtr;
+} ColorStruct;
+
+/*----------------------------------------------------------------------
+ * PixmapInstance --
+ *
+ * Represents all of the instances of an image that lie within a
+ * particular window:
+ *
+ * %% ToDo
+ * Currently one instance is created for each window that uses
+ * this pixmap. This is usually OK because pixmaps are usually
+ * not shared or only shared by a small number of windows. To
+ * improve resource allocation, we can create an instance for
+ * each (Display x Visual x Depth) combo. This will usually
+ * reduce the number of instances to one.
+ *----------------------------------------------------------------------
+ */
+typedef struct PixmapInstance {
+ int refCount; /* Number of instances that share this
+ * data structure. */
+ PixmapMaster *masterPtr; /* Pointer to master for image. */
+ Tk_Window tkwin; /* Window in which the instances will be
+ * displayed. */
+ Pixmap pixmap; /* The pixmap to display. */
+ struct PixmapInstance *nextPtr;
+ /* Next in list of all instance structures
+ * associated with masterPtr (NULL means
+ * end of list).
+ */
+ ColorStruct * colors;
+ ClientData clientData; /* Place holder for platform specific
+ * instance data */
+} PixmapInstance;
+
+
+EXTERN void TixpInitPixmapInstance _ANSI_ARGS_((
+ PixmapMaster *masterPtr,
+ PixmapInstance *instancePtr));
+EXTERN void TixpXpmAllocTmpBuffer _ANSI_ARGS_((
+ PixmapMaster * masterPtr,
+ PixmapInstance * instancePtr,
+ XImage ** imagePtr, XImage ** maskPtr));
+EXTERN void TixpXpmFreeTmpBuffer _ANSI_ARGS_((
+ PixmapMaster * masterPtr,
+ PixmapInstance * instancePtr,
+ XImage * image, XImage * mask));
+EXTERN void TixpXpmSetPixel _ANSI_ARGS_((
+ PixmapInstance * instancePtr, XImage * image,
+ XImage * mask, int x, int y, XColor * colorPtr,
+ int * isTranspPtr));
+EXTERN void TixpXpmRealizePixmap _ANSI_ARGS_((
+ PixmapMaster * masterPtr,
+ PixmapInstance * instancePtr,
+ XImage * image, XImage * mask, int isTransp));
+EXTERN void TixpXpmFreeInstanceData _ANSI_ARGS_((
+ PixmapInstance *instancePtr, int delete,
+ Display *display));
+EXTERN void TixpXpmDisplay _ANSI_ARGS_((ClientData clientData,
+ Display *display, Drawable drawable,
+ int imageX, int imageY, int width, int height,
+ int drawableX, int drawableY));
+
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.m
new file mode 100755
index 00000000000..2e6845bef96
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.m
@@ -0,0 +1,34 @@
+#ifndef _TIXIMGXPM_VM
+#define _TIXIMGXPM_VM
+#include "tixImgXpm_f.h"
+#ifndef NO_VTABLES
+#ifndef TixpInitPixmapInstance
+# define TixpInitPixmapInstance (*TiximgxpmVptr->V_TixpInitPixmapInstance)
+#endif
+
+#ifndef TixpXpmAllocTmpBuffer
+# define TixpXpmAllocTmpBuffer (*TiximgxpmVptr->V_TixpXpmAllocTmpBuffer)
+#endif
+
+#ifndef TixpXpmDisplay
+# define TixpXpmDisplay (*TiximgxpmVptr->V_TixpXpmDisplay)
+#endif
+
+#ifndef TixpXpmFreeInstanceData
+# define TixpXpmFreeInstanceData (*TiximgxpmVptr->V_TixpXpmFreeInstanceData)
+#endif
+
+#ifndef TixpXpmFreeTmpBuffer
+# define TixpXpmFreeTmpBuffer (*TiximgxpmVptr->V_TixpXpmFreeTmpBuffer)
+#endif
+
+#ifndef TixpXpmRealizePixmap
+# define TixpXpmRealizePixmap (*TiximgxpmVptr->V_TixpXpmRealizePixmap)
+#endif
+
+#ifndef TixpXpmSetPixel
+# define TixpXpmSetPixel (*TiximgxpmVptr->V_TixpXpmSetPixel)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TIXIMGXPM_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.t
new file mode 100755
index 00000000000..b52ad2cf398
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm.t
@@ -0,0 +1,49 @@
+#ifdef _TIXIMGXPM
+#ifndef TixpInitPixmapInstance
+VFUNC(void,TixpInitPixmapInstance,V_TixpInitPixmapInstance,_ANSI_ARGS_((
+ PixmapMaster *masterPtr,
+ PixmapInstance *instancePtr)))
+#endif /* #ifndef TixpInitPixmapInstance */
+
+#ifndef TixpXpmAllocTmpBuffer
+VFUNC(void,TixpXpmAllocTmpBuffer,V_TixpXpmAllocTmpBuffer,_ANSI_ARGS_((
+ PixmapMaster * masterPtr,
+ PixmapInstance * instancePtr,
+ XImage ** imagePtr, XImage ** maskPtr)))
+#endif /* #ifndef TixpXpmAllocTmpBuffer */
+
+#ifndef TixpXpmDisplay
+VFUNC(void,TixpXpmDisplay,V_TixpXpmDisplay,_ANSI_ARGS_((ClientData clientData,
+ Display *display, Drawable drawable,
+ int imageX, int imageY, int width, int height,
+ int drawableX, int drawableY)))
+#endif /* #ifndef TixpXpmDisplay */
+
+#ifndef TixpXpmFreeInstanceData
+VFUNC(void,TixpXpmFreeInstanceData,V_TixpXpmFreeInstanceData,_ANSI_ARGS_((
+ PixmapInstance *instancePtr, int delete,
+ Display *display)))
+#endif /* #ifndef TixpXpmFreeInstanceData */
+
+#ifndef TixpXpmFreeTmpBuffer
+VFUNC(void,TixpXpmFreeTmpBuffer,V_TixpXpmFreeTmpBuffer,_ANSI_ARGS_((
+ PixmapMaster * masterPtr,
+ PixmapInstance * instancePtr,
+ XImage * image, XImage * mask)))
+#endif /* #ifndef TixpXpmFreeTmpBuffer */
+
+#ifndef TixpXpmRealizePixmap
+VFUNC(void,TixpXpmRealizePixmap,V_TixpXpmRealizePixmap,_ANSI_ARGS_((
+ PixmapMaster * masterPtr,
+ PixmapInstance * instancePtr,
+ XImage * image, XImage * mask, int isTransp)))
+#endif /* #ifndef TixpXpmRealizePixmap */
+
+#ifndef TixpXpmSetPixel
+VFUNC(void,TixpXpmSetPixel,V_TixpXpmSetPixel,_ANSI_ARGS_((
+ PixmapInstance * instancePtr, XImage * image,
+ XImage * mask, int x, int y, XColor * colorPtr,
+ int * isTranspPtr)))
+#endif /* #ifndef TixpXpmSetPixel */
+
+#endif /* _TIXIMGXPM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm_f.h
new file mode 100755
index 00000000000..909c5bd7737
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixImgXpm_f.h
@@ -0,0 +1,14 @@
+#ifndef TIXIMGXPM_VT
+#define TIXIMGXPM_VT
+typedef struct TiximgxpmVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tixImgXpm.t"
+#undef VFUNC
+#undef VVAR
+} TiximgxpmVtab;
+extern TiximgxpmVtab *TiximgxpmVptr;
+extern TiximgxpmVtab *TiximgxpmVGet(void);
+#endif /* TIXIMGXPM_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.h
new file mode 100755
index 00000000000..d1dad2b88e6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.h
@@ -0,0 +1,886 @@
+
+/* $Id: tixInt.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixInt.h --
+ *
+ * Defines internal data types and functions used by the Tix library.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+#ifndef _TIX
+#include "tix.h"
+#endif
+#ifndef _TIXINT
+#define _TIXINT
+#define _TIX_INT_H_
+
+/*----------------------------------------------------------------------
+ *
+ * Tix Display Item Types
+ *
+ *----------------------------------------------------------------------
+ */
+
+#define TIX_DITEM_NONE 0
+#define TIX_DITEM_TEXT 1
+#define TIX_DITEM_IMAGETEXT 2
+#define TIX_DITEM_WINDOW 3
+#define TIX_DITEM_IMAGE 4
+
+/*
+ * The flags for drawing DItems
+ */
+
+#define TIX_DITEM_NORMAL_BG (0x1 << 0)
+#define TIX_DITEM_ACTIVE_BG (0x1 << 1)
+#define TIX_DITEM_SELECTED_BG (0x1 << 2)
+#define TIX_DITEM_DISABLED_BG (0x1 << 3)
+#define TIX_DITEM_NORMAL_FG (0x1 << 4)
+#define TIX_DITEM_ACTIVE_FG (0x1 << 5)
+#define TIX_DITEM_SELECTED_FG (0x1 << 6)
+#define TIX_DITEM_DISABLED_FG (0x1 << 7)
+#define TIX_DITEM_FONT (0x1 << 8)
+#define TIX_DITEM_PADX (0x1 << 9)
+#define TIX_DITEM_PADY (0x1 << 10)
+
+#define TIX_DONT_CALL_CONFIG TK_CONFIG_USER_BIT
+
+/*
+ * These values are used ONLY for indexing the color array in
+ * Tix_StyleTemplate
+ */
+
+#define TIX_DITEM_NORMAL 0
+#define TIX_DITEM_ACTIVE 1
+#define TIX_DITEM_SELECTED 2
+#define TIX_DITEM_DISABLED 3
+
+/*
+ * Flags for MultiInfo
+ */
+#define TIX_CONFIG_INFO 1
+#define TIX_CONFIG_VALUE 2
+
+typedef union Tix_DItem Tix_DItem;
+typedef union Tix_DItemStyle Tix_DItemStyle;
+typedef struct Tix_DItemInfo Tix_DItemInfo;
+typedef struct Tix_DispData Tix_DispData;
+typedef struct Tix_StyleTemplate Tix_StyleTemplate;
+
+typedef void Tix_DItemCalculateSizeProc _ANSI_ARGS_((
+ Tix_DItem * iPtr));
+typedef char * Tix_DItemComponentProc _ANSI_ARGS_((
+ Tix_DItem * iPtr, int x, int y));
+typedef int Tix_DItemConfigureProc _ANSI_ARGS_((
+ Tix_DItem * iPtr, int argc, Tcl_Obj *CONST *objv,
+ int flags));
+typedef Tix_DItem * Tix_DItemCreateProc _ANSI_ARGS_((
+ Tix_DispData * ddPtr,
+ Tix_DItemInfo * diTypePtr));
+typedef void Tix_DItemDisplayProc _ANSI_ARGS_((
+ Pixmap pixmap, GC gc, Tix_DItem * iPtr,
+ int x, int y, int width, int height, int flag));
+typedef void Tix_DItemFreeProc _ANSI_ARGS_((Tix_DItem * diPtr));
+typedef void Tix_DItemSizeChangedProc _ANSI_ARGS_((
+ Tix_DItem * iPtr));
+
+typedef void Tix_DItemStyleChangedProc _ANSI_ARGS_((
+ Tix_DItem * iPtr));
+typedef void Tix_DItemLostStyleProc _ANSI_ARGS_((
+ Tix_DItem * iPtr));
+typedef int Tix_DItemStyleConfigureProc _ANSI_ARGS_((
+ Tix_DItemStyle* style, int argc, Tcl_Obj *CONST *objv,
+ int flags));
+typedef Tix_DItemStyle* Tix_DItemStyleCreateProc _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tix_DItemInfo * diTypePtr, char * name));
+typedef void Tix_DItemStyleFreeProc _ANSI_ARGS_((
+ Tix_DItemStyle* style));
+typedef void Tix_DItemStyleSetTemplateProc _ANSI_ARGS_((
+ Tix_DItemStyle* style,
+ Tix_StyleTemplate * tmplPtr));
+
+/*
+ * These are debugging routines
+ */
+
+typedef int Tix_DItemRefCountProc _ANSI_ARGS_(());
+typedef int Tix_DItemStyleRefCountProc _ANSI_ARGS_(());
+
+/*----------------------------------------------------------------------
+ * Tix_DItemInfo --
+ *
+ * This structure is used to register a new display item (call
+ * Tix_AddDItemType).
+ *----------------------------------------------------------------------
+ */
+struct Tix_DItemInfo {
+ char * name;
+ int type;
+
+ /*
+ * These procedures communicate with the items
+ */
+ Tix_DItemCreateProc * createProc;
+ Tix_DItemConfigureProc * configureProc;
+ Tix_DItemCalculateSizeProc * calculateSizeProc;
+ Tix_DItemComponentProc * componentProc;
+ Tix_DItemDisplayProc * displayProc;
+ Tix_DItemFreeProc * freeProc;
+ Tix_DItemStyleChangedProc *styleChangedProc;
+ Tix_DItemLostStyleProc * lostStyleProc;
+
+ /*
+ * These procedures communicate with the styles
+ */
+ Tix_DItemStyleCreateProc * styleCreateProc;
+ Tix_DItemStyleConfigureProc * styleConfigureProc;
+ Tix_DItemStyleFreeProc * styleFreeProc;
+ Tix_DItemStyleSetTemplateProc * styleSetTemplateProc;
+
+ Tk_ConfigSpec * itemConfigSpecs;
+ Tk_ConfigSpec * styleConfigSpecs;
+ struct Tix_DItemInfo * next;
+};
+
+/*----------------------------------------------------------------------
+ * Tix_DispData --
+ *
+ * Information needed by the display types to display the item in
+ * an X drawable.
+ *----------------------------------------------------------------------
+ */
+struct Tix_DispData {
+ Display * display;
+ Tcl_Interp * interp;
+ Tk_Window tkwin;
+ Tix_DItemSizeChangedProc * sizeChangedProc;
+};
+
+/*----------------------------------------------------------------------
+ * Tix_StyleTemplate --
+ *
+ * A StyleTemplate is used to set the values of the default styles
+ * associated with a widget
+ *----------------------------------------------------------------------
+ */
+struct Tix_StyleTemplate {
+ int flags; /* determines which field is valid */
+
+ struct {
+ XColor * bg;
+ XColor * fg;
+ } colors[4]; /* colors for the four basic modes*/
+
+ int pad[2];
+#if 0
+ /* %bordercolor not used */
+ XColor * borderColor;
+ Tix_Relief relief;
+ int borderWidth;
+#endif
+ TixFont font;
+};
+
+/*----------------------------------------------------------------------
+ *
+ *
+ * Display Item Types
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+
+/*
+ * Display Styles
+ */
+typedef struct TixBaseStyle TixBaseStyle;
+typedef struct TixImageTextStyle TixImageTextStyle;
+typedef struct TixImageStyle TixImageStyle;
+typedef struct TixTextStyle TixTextStyle;
+typedef struct TixWindowStyle TixWindowStyle;
+
+typedef struct TixBaseItem TixBaseItem;
+typedef struct TixColorStyle TixColorStyle;
+typedef struct TixImageTextItem TixImageTextItem;
+typedef struct TixImageItem TixImageItem;
+typedef struct TixTextItem TixTextItem;
+typedef struct TixWindowItem TixWindowItem;
+
+/*----------------------------------------------------------------------
+ * TixBaseItem --
+ *
+ * This is the abstract base class for all display items. All
+ * display items should have the data members defined in the
+ * BaseItem structure
+ *----------------------------------------------------------------------
+ */
+#define ITEM_COMMON_MEMBERS \
+ Tix_DItemInfo * diTypePtr; \
+ Tix_DispData * ddPtr; \
+ ClientData clientData; \
+ int size[2] /* Size of this element */ \
+
+struct TixBaseItem {
+ ITEM_COMMON_MEMBERS;
+ TixBaseStyle * stylePtr;
+};
+
+/*----------------------------------------------------------------------
+ * TixBaseStyle --
+ *
+ * This is the abstract base class for all display styles. All
+ * display items should have the data members defined in the
+ * BaseStyle structure. The common members are initialized by
+ * tixDiStyle.c
+ *
+ *----------------------------------------------------------------------
+ */
+
+#define STYLE_COMMON_MEMBERS \
+ Tcl_Command styleCmd; /* Token for style's command. */ \
+ Tcl_HashTable items; /* Ditems affected by this style */ \
+ int refCount; /* Number of ditems affected by this style */\
+ int flags; /* Various attributes */ \
+ Tcl_Interp *interp; /* Interpreter associated with style. */ \
+ Tk_Window tkwin; /* Window associated with this style */ \
+ Tix_DItemInfo * diTypePtr; \
+ Tk_Anchor anchor; /* Anchor information */ \
+ char * name; /* Name of this style */ \
+ int pad[2] /* paddings */
+
+
+#if 0
+ Tix_Relief relief
+ /* %bordercolor not used */
+ int borderWidth;
+ XColor * borderColor; /* color of the border when it is displayed
+ * in "flat border" mode
+ */
+ GC borderGC
+#endif
+
+#define STYLE_COLOR_MEMBERS \
+ struct { \
+ XColor * bg; \
+ XColor * fg; \
+ GC foreGC; \
+ GC backGC; \
+ } colors[4] /* colors and GC's for the four basic modes*/
+
+struct TixBaseStyle {
+ STYLE_COMMON_MEMBERS;
+};
+
+#define TIX_STYLE_DELETED 1
+#define TIX_STYLE_DEFAULT 2
+
+/*
+ * Abstract type for all styles that have a color element
+ */
+struct TixColorStyle {
+ STYLE_COMMON_MEMBERS;
+ STYLE_COLOR_MEMBERS;
+};
+
+/*----------------------------------------------------------------------
+ * ImageTextItem --
+ *
+ * Display an image together with a text string
+ *----------------------------------------------------------------------
+ */
+struct TixImageTextItem {
+ ITEM_COMMON_MEMBERS;
+
+ TixImageTextStyle *stylePtr;
+ /*-------------------------*/
+ /* Bitmap */
+ /*-------------------------*/
+ Pixmap bitmap;
+ int bitmapW, bitmapH; /* Size of bitmap */
+
+ /*-------------------------*/
+ /* Image */
+ /*-------------------------*/
+ char *imageString; /* Name of image to display (malloc'ed), or
+ * NULL. If non-NULL, bitmap, text, and
+ * textVarName are ignored. */
+ Tk_Image image;
+ int imageW, imageH; /* Size of image */
+
+ /*-------------------------*/
+ /* Text */
+ /*-------------------------*/
+
+ Tcl_Obj * text; /* Show descriptive text */
+ size_t numChars; /* Size of text */
+ int textW, textH;
+ int wrapLength;
+ Tk_Justify justify; /* Justification to use for multi-line text. */
+ int underline; /* Index of character to underline. < 0 means
+ * don't underline anything. */
+
+ int showImage, showText;
+};
+
+struct TixImageTextStyle {
+ STYLE_COMMON_MEMBERS;
+ STYLE_COLOR_MEMBERS;
+ int wrapLength;
+ Tk_Justify justify; /* Justification to use for multi-line text. */
+ TixFont font;
+ int gap; /* Gap between text and image */
+ Tk_Anchor textanchor; /* Text anchor information */
+};
+
+/*----------------------------------------------------------------------
+ * ImageItem --
+ *
+ * Displays an image
+ *----------------------------------------------------------------------
+ */
+struct TixImageItem {
+ ITEM_COMMON_MEMBERS;
+
+ TixImageStyle *stylePtr;
+
+ /*-------------------------*/
+ /* Image */
+ /*-------------------------*/
+ char *imageString; /* Name of image to display (malloc'ed), or
+ * NULL. If non-NULL, bitmap, text, and
+ * textVarName are ignored. */
+ Tk_Image image;
+ int imageW, imageH; /* Size of image */
+};
+
+struct TixImageStyle {
+ STYLE_COMMON_MEMBERS;
+ STYLE_COLOR_MEMBERS;
+};
+/*----------------------------------------------------------------------
+ * TextItem --
+ *
+ * Displays a text string.
+ *----------------------------------------------------------------------
+ */
+struct TixTextItem {
+ ITEM_COMMON_MEMBERS;
+
+ TixTextStyle *stylePtr;
+ /*-------------------------*/
+ /* Text */
+ /*-------------------------*/
+
+ Tcl_Obj * text; /* Show descriptive text */
+ size_t numChars; /* Size of text */
+ int textW, textH;
+ int underline; /* Index of character to underline. < 0 means
+ * don't underline anything. */
+};
+
+struct TixTextStyle {
+ STYLE_COMMON_MEMBERS;
+ STYLE_COLOR_MEMBERS;
+ int wrapLength;
+ Tk_Justify justify; /* Justification to use for multi-line text. */
+ TixFont font;
+};
+
+/*----------------------------------------------------------------------
+ * WindowItem --
+ *
+ * Displays a window.
+ *----------------------------------------------------------------------
+ */
+struct TixWindowItem {
+ ITEM_COMMON_MEMBERS;
+ TixWindowStyle *stylePtr;
+ Tk_Window tkwin;
+ struct TixWindowItem * next;
+ int serial;
+};
+
+struct TixWindowStyle {
+ STYLE_COMMON_MEMBERS;
+};
+
+/*----------------------------------------------------------------------
+ * Tix_DItem and Tix_DItemStyle --
+ *
+ * These unions just make it easy to address the internals of the
+ * structures of the display items and styles. If you create a new
+ * display item, you will need to do you type casting yourself.
+ *----------------------------------------------------------------------
+ */
+union Tix_DItem {
+ TixBaseItem base;
+ TixImageTextItem imagetext;
+ TixTextItem text;
+ TixWindowItem window;
+ TixImageItem image;
+};
+
+union Tix_DItemStyle {
+ TixBaseStyle base;
+ TixColorStyle color;
+ TixImageTextStyle imagetext;
+ TixTextStyle text;
+ TixWindowStyle window;
+ TixImageStyle image;
+};
+
+#define Tix_DItemType(x) ((x)->base.diTypePtr->type)
+#define Tix_DItemTypeName(x) ((x)->base.diTypePtr->name)
+#define Tix_DItemWidth(x) ((x)->base.size[0])
+#define Tix_DItemHeight(x) ((x)->base.size[1])
+#define Tix_DItemConfigSpecs(x) ((x)->base.diTypePtr->itemConfigSpecs)
+#define Tix_DItemPadX(x) ((x)->base.stylePtr->pad[0])
+#define Tix_DItemPadY(x) ((x)->base.stylePtr->pad[1])
+
+#define TIX_WIDTH 0
+#define TIX_HEIGHT 1
+
+/*----------------------------------------------------------------------
+ * Tix_ArgumentList --
+ *
+ * This data structure is used to split command arguments for
+ * the display item types
+ *----------------------------------------------------------------------
+ */
+#define FIXED_SIZE 4
+typedef struct {
+ int argc;
+ Tcl_Obj **objv;
+} Tix_Argument;
+
+typedef struct {
+ Tix_Argument * arg;
+ int numLists;
+ Tix_Argument preAlloc[FIXED_SIZE];
+} Tix_ArgumentList;
+
+/*----------------------------------------------------------------------
+ * Tix_ScrollInfo --
+ *
+ * This data structure encapsulates all the necessary operations
+ * for scrolling widgets
+ *----------------------------------------------------------------------
+ */
+#define TIX_SCROLL_INT 1
+#define TIX_SCROLL_DOUBLE 2
+
+/* abstract type */
+typedef struct Tix_ScrollInfo {
+ int type; /* TIX_SCROLL_INT or TIX_SCROLL_DOUBLE */
+ LangCallback *command;
+ /* place holder for actual space - double must be mentioned
+ to force alignment for too-clever-by-half compilers
+ */
+ union {
+ int iscroll[4];
+ double dscroll[4];
+ } info;
+} Tix_ScrollInfo;
+
+typedef struct Tix_IntScrollInfo {
+ int type; /* TIX_SCROLL_INT */
+ LangCallback *command;
+
+ int total; /* total size (width or height) of the widget*/
+ int window; /* visible size */
+ int offset; /* The top/left side of the scrolled widget */
+ int unit; /* How much should we scroll when the user
+ * press the arrow on a scrollbar? */
+
+} Tix_IntScrollInfo;
+
+typedef struct Tix_DoubleScrollInfo {
+ int type; /* TIX_SCROLL_DOUBLE */
+ LangCallback *command;
+
+ double total; /* total size (width or height) of the widget*/
+ double window; /* visible size */
+ double offset; /* The top/left side of the scrolled widget */
+ double unit; /* How much should we scroll when the user
+ * press the arrow on a scrollbar? */
+} Tix_DoubleScrollInfo;
+
+/*----------------------------------------------------------------------
+ *
+ * Global variables
+ *
+ * Should be used only in the Tix library. Some systems don't support
+ * exporting of global variables from shared libraries.
+ *
+ *----------------------------------------------------------------------
+ */
+EXTERN Tk_Uid tixNormalUid;
+EXTERN Tk_Uid tixDisabledUid;
+EXTERN Tk_Uid tixCellUid;
+EXTERN Tk_Uid tixRowUid;
+EXTERN Tk_Uid tixColumnUid;
+
+#define FLAG_READONLY 0
+#define FLAG_STATIC 1
+#define FLAG_FORCECALL 2
+
+/*----------------------------------------------------------------------
+ *
+ *
+ * MEGA-WIDGET CONFIG HANDLING
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+typedef struct _TixConfigSpec TixConfigSpec;
+typedef struct _TixConfigAlias TixConfigAlias;
+typedef struct _TixClassRecord TixClassRecord;
+
+struct _TixConfigSpec {
+ unsigned int isAlias : 1;
+ unsigned int readOnly : 1;
+ unsigned int isStatic : 1;
+ unsigned int forceCall : 1;
+
+ char * argvName;
+ char * defValue;
+
+ char * dbName; /* The additional parts of a */
+ char * dbClass; /* TixWidgetConfigSpec structure */
+
+ char *verifyCmd;
+
+ TixConfigSpec * realPtr; /* valid only if this option is an alias */
+};
+
+/*
+ * Controls the access of root widget and subwidget commands and options
+ */
+typedef struct _Tix_ExportSpec {
+ Tix_LinkList exportCmds;
+ Tix_LinkList restrictCmds;
+ Tix_LinkList exportOpts;
+ Tix_LinkList restrictOpts;
+} Tix_ExportSpec;
+
+typedef struct _Tix_SubWidgetSpec {
+ struct _Tix_SubWidgetSpec * next;
+ char * name;
+ Tix_ExportSpec export;
+} Tix_SubWidgetSpec;
+
+typedef struct _Tix_StringLink {
+ struct _Tix_StringLink *next;
+ char * string;
+} Tix_StringLink;
+
+typedef struct _Tix_SubwidgetDef {
+ struct _TixSubwidgetDef * next;
+ char * spec;
+ char * value;
+} Tix_SubwidgetDef;
+
+typedef struct _TixClassParseStruct {
+ char * alias;
+ char * ClassName;
+ char * configSpec;
+ char * def;
+ char * flag;
+ char * forceCall;
+ char * method;
+ char * readOnly;
+ char * isStatic;
+ char * superClass;
+ char * subWidget;
+ char * isVirtual;
+
+ int optArgc;
+ char ** optArgv;
+} TixClassParseStruct;
+
+struct _TixClassRecord {
+ TixClassRecord * next; /* Chains to the next class record in
+ * a superClass's unInitSubCls list */
+ TixClassRecord * superClass; /* The superclass of this class. Is
+ * NULL if this class does not have
+ * a superclass. */
+ unsigned int isWidget; /* TRUE iff this class is created by
+ * the "tixWidgetClass" command */
+ char * className; /* Instiantiation command */
+ char * ClassName; /* used in TK option database */
+
+ int nSpecs;
+ TixConfigSpec ** specs;
+ int nMethods;
+ char ** methods;
+ Tk_Window mainWindow; /* This variable is essentially
+ * a cached variable so that
+ * we can advoid calling
+ * Tk_MainWindow() */
+ int isVirtual; /* is this a virtual base class
+ * (shouldn't be instantiated)*/
+ TixClassParseStruct*parsePtr; /* Information supplied by the
+ * tixClass or tixWidgetClass
+ * commands */
+ Tix_LinkList unInitSubCls; /* The subclasses that have not been
+ * initialized. */
+ int initialized; /* Is this class initialized? A class
+ * is not initialized if it has been
+ * defined but some its superclass
+ * is not initialized.
+ */
+ Tix_LinkList subWDefs; /* the -defaults option */
+#if USE_ACCESS_CONTROL
+ Tix_LinkList subWidgets;
+ Tix_ExportSpec exportSpec; /* controls the export status
+ * of the commands and options
+ * of the root widget */
+#endif
+};
+
+typedef struct _TixInterpState {
+ char * result;
+ char * errorInfo;
+ char * errorCode;
+} TixInterpState;
+
+/*----------------------------------------------------------------------
+ *
+ * Internal procedures
+ *
+ *----------------------------------------------------------------------
+ */
+
+EXTERN int Tix_CallConfigMethod _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord *cPtr,
+ char * widRec, TixConfigSpec *spec, char * value));
+EXTERN int Tix_CallMethod _ANSI_ARGS_((Tcl_Interp *interp,
+ char *context, char *widRec, char *method,
+ int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tix_ChangeOneOption _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord *cPtr,
+ char * widRec, TixConfigSpec *spec, char * value,
+ int isDefault, int isInit));
+EXTERN int Tix_ChangeOptions _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord *cPtr,
+ char * widRec, int argc, Tcl_Obj *CONST *objv));
+EXTERN TixConfigSpec * Tix_FindConfigSpecByName _ANSI_ARGS_((
+ Tcl_Interp * interp,
+ TixClassRecord * cPtr, char * name));
+EXTERN char * Tix_FindMethod _ANSI_ARGS_((Tcl_Interp *interp,
+ char *context, char *method));
+EXTERN char * Tix_FindPublicMethod _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord * cPtr,
+ char * method));
+EXTERN int Tix_GetChars _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, double *doublePtr));
+EXTERN char * Tix_GetConfigSpecFullName _ANSI_ARGS_((char *clasRec,
+ char *flag));
+EXTERN char * Tix_GetContext _ANSI_ARGS_((
+ Tcl_Interp * interp, char * widRec));
+EXTERN char * Tix_GetMethodFullName _ANSI_ARGS_((char *context,
+ char *method));
+EXTERN void Tix_GetPublicMethods _ANSI_ARGS_((Tcl_Interp *interp,
+ char *widRec, int *numMethods,
+ char *** validMethods));
+EXTERN int Tix_GetWidgetOption _ANSI_ARGS_((
+ Tcl_Interp *interp, Tk_Window tkwin,
+ char *argvName, char *dbName, char *dbClass,
+ char *defValue, int argc, Tcl_Obj *CONST *objv,
+ int type, char *ptr));
+EXTERN int Tix_GetVar _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord *cPtr,
+ char * widRec, char * flag));
+EXTERN int Tix_QueryAllOptions _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord * cPtr,
+ char *widRec));
+EXTERN int Tix_QueryOneOption _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord *cPtr,
+ char *widRec, char *flag));
+EXTERN int Tix_SuperClass _ANSI_ARGS_((Tcl_Interp *interp,
+ char *widClass, char ** superClass_ret));
+EXTERN int Tix_UnknownPublicMethodError _ANSI_ARGS_((
+ Tcl_Interp *interp, TixClassRecord * cPtr,
+ char * widRec, char * method));
+EXTERN int Tix_ValueMissingError _ANSI_ARGS_((Tcl_Interp *interp,
+ char *spec));
+EXTERN void Tix_AddDItemType _ANSI_ARGS_((
+ Tix_DItemInfo * diTypePtr));
+EXTERN int Tix_ConfigureInfo2 _ANSI_ARGS_((
+ Tcl_Interp *interp, Tk_Window tkwin,
+ char *entRec, Tk_ConfigSpec *entConfigSpecs,
+ Tix_DItem * iPtr, char *argvName, int flags));
+EXTERN int Tix_ConfigureValue2 _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, char * entRec,
+ Tk_ConfigSpec *entConfigSpecs, Tix_DItem * iPtr,
+ char *argvName, int flags));
+EXTERN void Tix_DItemCalculateSize _ANSI_ARGS_((
+ Tix_DItem * iPtr));
+EXTERN char * Tix_DItemComponent _ANSI_ARGS_((Tix_DItem * diPtr,
+ int x, int y));
+EXTERN int Tix_DItemConfigure _ANSI_ARGS_((
+ Tix_DItem * diPtr, int argc,
+ Tcl_Obj *CONST *objv, int flags));
+EXTERN Tix_DItem * Tix_DItemCreate _ANSI_ARGS_((Tix_DispData * ddPtr,
+ char * type));
+EXTERN void Tix_DItemDrawBackground _ANSI_ARGS_((
+ Pixmap pixmap, GC gc, Tix_DItem * iPtr,
+ int x, int y, int width, int height, int flags));
+EXTERN void Tix_DItemDisplay _ANSI_ARGS_((
+ Pixmap pixmap, GC gc, Tix_DItem * iPtr,
+ int x, int y, int width, int height, int flag));
+EXTERN void Tix_DItemFree _ANSI_ARGS_((
+ Tix_DItem * iPtr));
+EXTERN void TixDItemStyleChanged _ANSI_ARGS_((
+ Tix_DItemInfo * diTypePtr,
+ Tix_DItemStyle * stylePtr));
+EXTERN void TixDItemStyleFree _ANSI_ARGS_((Tix_DItem *iPtr,
+ Tix_DItemStyle * stylePtr));
+EXTERN void TixDItemGetAnchor _ANSI_ARGS_((Tk_Anchor anchor,
+ int x, int y, int cav_w, int cav_h,
+ int width, int height, int * x_ret, int * y_ret));
+EXTERN void Tix_FreeArgumentList _ANSI_ARGS_((
+ Tix_ArgumentList *argListPtr));
+EXTERN void TixGetColorDItemGC _ANSI_ARGS_((
+ Tix_DItem * iPtr, GC * backGC_ret,
+ GC * foreGC_ret, int flags));
+EXTERN Tix_DItemStyle* TixGetDefaultDItemStyle _ANSI_ARGS_((
+ Tix_DispData * ddPtr, Tix_DItemInfo * diTypePtr,
+ Tix_DItem *iPtr, Tix_DItemStyle* oldStylePtr));
+EXTERN Tix_DItemInfo * Tix_GetDItemType _ANSI_ARGS_((
+ Tcl_Interp * interp, char *type));
+EXTERN void Tix_GetScrollFractions _ANSI_ARGS_((
+ Tix_ScrollInfo * siPtr,
+ double * first_ret, double * last_ret));
+EXTERN void Tix_InitScrollInfo _ANSI_ARGS_((
+ Tix_ScrollInfo * siPtr, int type));
+EXTERN int Tix_MultiConfigureInfo _ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec **specsList,
+ int numLists, char **widgRecList, char *argvName,
+ int flags, int request));
+EXTERN void Tix_SetDefaultStyleTemplate _ANSI_ARGS_((
+ Tk_Window tkwin, Tix_StyleTemplate * tmplPtr));
+EXTERN int Tix_SetScrollBarView _ANSI_ARGS_((
+ Tcl_Interp *interp, Tix_ScrollInfo * siPtr,
+ int argc, Tcl_Obj *CONST *objv, int compat));
+EXTERN void Tix_SetWindowItemSerial _ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_DItem * iPtr,
+ int serial));
+EXTERN int Tix_SplitConfig _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec ** specsList,
+ int numLists, int argc, Tcl_Obj *CONST *objv,
+ Tix_ArgumentList * argListPtr));
+EXTERN void Tix_UnmapInvisibleWindowItems _ANSI_ARGS_((
+ Tix_LinkList * lPtr, int serial));
+EXTERN void Tix_UpdateScrollBar _ANSI_ARGS_((
+ Tcl_Interp *interp, Tix_ScrollInfo * siPtr));
+EXTERN int Tix_WidgetConfigure2 _ANSI_ARGS_((
+ Tcl_Interp *interp, Tk_Window tkwin, char * entRec,
+ Tk_ConfigSpec *entConfigSpecs,
+ Tix_DItem * iPtr, int argc, Tcl_Obj *CONST *objv,
+ int flags, int forced, int * sizeChanged_ret));
+EXTERN void Tix_WindowItemListRemove _ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_DItem * iPtr));
+
+typedef struct _TixpSubRegion TixpSubRegion;
+
+struct _TixpSubRegion {
+ Pixmap pixmap;
+ int origX, origY;
+ int x, y;
+ int width, height;
+};
+
+/*
+ * Functions that should be used by Tix only. Functions prefixed by "Tix"
+ * are generic functions that has one implementation for all platforms.
+ * Functions prefixed with "Tixp" requires one implementation on each
+ * platform.
+ */
+
+extern int TixInitSam _ANSI_ARGS_((Tcl_Interp * interp));
+extern int TixLoadLibrary _ANSI_ARGS_((Tcl_Interp * interp));
+extern void TixRestoreInterpState _ANSI_ARGS_((
+ Tcl_Interp * interp, TixInterpState * statePtr));
+extern void TixSaveInterpState _ANSI_ARGS_((Tcl_Interp * interp,
+ TixInterpState * statePtr));
+
+extern void TixpDrawAnchorLines _ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc, int x, int y,
+ int w, int h));
+extern void TixpDrawTmpLine _ANSI_ARGS_((int x1, int y1,
+ int x2, int y2, Tk_Window tkwin));
+extern void TixpEndSubRegionDraw _ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr));
+extern int TixpSetWindowParent _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Window newParent,
+ int parentId));
+extern void TixpStartSubRegionDraw _ANSI_ARGS_((Tix_DispData *ddPtr,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr, int origX,
+ int origY, int x, int y, int width, int height,
+ int needWidth, int needHeight));
+extern void TixpSubRegDisplayText _ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr,
+ TixFont font, char *string,
+ int numChars, int x, int y, int length,
+ Tk_Justify justify, int underline));
+extern void TixpSubRegDrawBitmap _ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr, Pixmap bitmap,
+ int src_x, int src_y, int width, int height,
+ int dest_x, int dest_y, unsigned long plane));
+extern void TixpSubRegDrawImage _ANSI_ARGS_((
+ TixpSubRegion * subRegPtr, Tk_Image image,
+ int imageX, int imageY, int width, int height,
+ Drawable drawable, int drawableX, int drawableY));
+extern void TixpSubRegFillRectangle _ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr, int x, int y,
+ int width, int height));
+
+/* These functions are also, and originaly declared in tixPort.h but
+ * that would mean even more Vtables
+ */
+
+EXTERN void TixComputeTextGeometry _ANSI_ARGS_((
+ TixFont fontStructPtr, char *string,
+ int numChars, int wrapLength, int *widthPtr,
+ int *heightPtr));
+EXTERN void TixDisplayText _ANSI_ARGS_((Display *display,
+ Drawable drawable, TixFont font,
+ char *string, int numChars, int x, int y,
+ int length, Tk_Justify justify, int underline,
+ GC gc));
+EXTERN Tcl_HashTable * TixGetHashTable _ANSI_ARGS_((Tcl_Interp * interp,
+ char * name, Tcl_InterpDeleteProc *deleteProc));
+
+/*
+ * built-in strdup is not compatible with the tcl memory allocator. We
+ * replace all strdup calls with tixStrDup.
+ */
+#define NO_STRDUP 1
+extern char *tixStrDup _ANSI_ARGS_(( CONST char * s));
+
+/*
+ * Console Stuff
+ * (these are declared with the EXTERN in win/winMain.c but without it
+ * in generic/tkConsole.c)
+ */
+EXTERN void TkConsoleCreate _ANSI_ARGS_((void));
+EXTERN int TkConsoleInit _ANSI_ARGS_((Tcl_Interp *interp));
+
+#define TixConsoleCreate(x) TkConsoleCreate()
+#define TixConsoleInit(x) TkConsoleInit(x)
+
+#endif /* _TIXINT */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.m
new file mode 100755
index 00000000000..3c953cbf032
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.m
@@ -0,0 +1,171 @@
+#ifndef _TIXINT_VM
+#define _TIXINT_VM
+#include "tixInt_f.h"
+#ifndef NO_VTABLES
+#define tixCellUid (*TixintVptr->V_tixCellUid)
+#define tixColumnUid (*TixintVptr->V_tixColumnUid)
+#define tixDisabledUid (*TixintVptr->V_tixDisabledUid)
+#define tixNormalUid (*TixintVptr->V_tixNormalUid)
+#define tixRowUid (*TixintVptr->V_tixRowUid)
+#ifndef TixComputeTextGeometry
+# define TixComputeTextGeometry (*TixintVptr->V_TixComputeTextGeometry)
+#endif
+
+#ifndef TixDItemGetAnchor
+# define TixDItemGetAnchor (*TixintVptr->V_TixDItemGetAnchor)
+#endif
+
+#ifndef TixDItemStyleChanged
+# define TixDItemStyleChanged (*TixintVptr->V_TixDItemStyleChanged)
+#endif
+
+#ifndef TixDItemStyleFree
+# define TixDItemStyleFree (*TixintVptr->V_TixDItemStyleFree)
+#endif
+
+#ifndef TixDisplayText
+# define TixDisplayText (*TixintVptr->V_TixDisplayText)
+#endif
+
+#ifndef TixGetColorDItemGC
+# define TixGetColorDItemGC (*TixintVptr->V_TixGetColorDItemGC)
+#endif
+
+#ifndef TixGetDefaultDItemStyle
+# define TixGetDefaultDItemStyle (*TixintVptr->V_TixGetDefaultDItemStyle)
+#endif
+
+#ifndef TixGetHashTable
+# define TixGetHashTable (*TixintVptr->V_TixGetHashTable)
+#endif
+
+#ifndef Tix_AddDItemType
+# define Tix_AddDItemType (*TixintVptr->V_Tix_AddDItemType)
+#endif
+
+#ifndef Tix_ConfigureInfo2
+# define Tix_ConfigureInfo2 (*TixintVptr->V_Tix_ConfigureInfo2)
+#endif
+
+#ifndef Tix_ConfigureValue2
+# define Tix_ConfigureValue2 (*TixintVptr->V_Tix_ConfigureValue2)
+#endif
+
+#ifndef Tix_DItemCalculateSize
+# define Tix_DItemCalculateSize (*TixintVptr->V_Tix_DItemCalculateSize)
+#endif
+
+#ifndef Tix_DItemComponent
+# define Tix_DItemComponent (*TixintVptr->V_Tix_DItemComponent)
+#endif
+
+#ifndef Tix_DItemConfigure
+# define Tix_DItemConfigure (*TixintVptr->V_Tix_DItemConfigure)
+#endif
+
+#ifndef Tix_DItemCreate
+# define Tix_DItemCreate (*TixintVptr->V_Tix_DItemCreate)
+#endif
+
+#ifndef Tix_DItemDisplay
+# define Tix_DItemDisplay (*TixintVptr->V_Tix_DItemDisplay)
+#endif
+
+#ifndef Tix_DItemDrawBackground
+# define Tix_DItemDrawBackground (*TixintVptr->V_Tix_DItemDrawBackground)
+#endif
+
+#ifndef Tix_DItemFree
+# define Tix_DItemFree (*TixintVptr->V_Tix_DItemFree)
+#endif
+
+#ifndef Tix_FreeArgumentList
+# define Tix_FreeArgumentList (*TixintVptr->V_Tix_FreeArgumentList)
+#endif
+
+#ifndef Tix_GetDItemType
+# define Tix_GetDItemType (*TixintVptr->V_Tix_GetDItemType)
+#endif
+
+#ifndef Tix_GetScrollFractions
+# define Tix_GetScrollFractions (*TixintVptr->V_Tix_GetScrollFractions)
+#endif
+
+#ifndef Tix_InitScrollInfo
+# define Tix_InitScrollInfo (*TixintVptr->V_Tix_InitScrollInfo)
+#endif
+
+#ifndef Tix_MultiConfigureInfo
+# define Tix_MultiConfigureInfo (*TixintVptr->V_Tix_MultiConfigureInfo)
+#endif
+
+#ifndef Tix_SetDefaultStyleTemplate
+# define Tix_SetDefaultStyleTemplate (*TixintVptr->V_Tix_SetDefaultStyleTemplate)
+#endif
+
+#ifndef Tix_SetScrollBarView
+# define Tix_SetScrollBarView (*TixintVptr->V_Tix_SetScrollBarView)
+#endif
+
+#ifndef Tix_SetWindowItemSerial
+# define Tix_SetWindowItemSerial (*TixintVptr->V_Tix_SetWindowItemSerial)
+#endif
+
+#ifndef Tix_SplitConfig
+# define Tix_SplitConfig (*TixintVptr->V_Tix_SplitConfig)
+#endif
+
+#ifndef Tix_UnmapInvisibleWindowItems
+# define Tix_UnmapInvisibleWindowItems (*TixintVptr->V_Tix_UnmapInvisibleWindowItems)
+#endif
+
+#ifndef Tix_UpdateScrollBar
+# define Tix_UpdateScrollBar (*TixintVptr->V_Tix_UpdateScrollBar)
+#endif
+
+#ifndef Tix_WidgetConfigure2
+# define Tix_WidgetConfigure2 (*TixintVptr->V_Tix_WidgetConfigure2)
+#endif
+
+#ifndef Tix_WindowItemListRemove
+# define Tix_WindowItemListRemove (*TixintVptr->V_Tix_WindowItemListRemove)
+#endif
+
+#ifndef TixpDrawAnchorLines
+# define TixpDrawAnchorLines (*TixintVptr->V_TixpDrawAnchorLines)
+#endif
+
+#ifndef TixpDrawTmpLine
+# define TixpDrawTmpLine (*TixintVptr->V_TixpDrawTmpLine)
+#endif
+
+#ifndef TixpEndSubRegionDraw
+# define TixpEndSubRegionDraw (*TixintVptr->V_TixpEndSubRegionDraw)
+#endif
+
+#ifndef TixpStartSubRegionDraw
+# define TixpStartSubRegionDraw (*TixintVptr->V_TixpStartSubRegionDraw)
+#endif
+
+#ifndef TixpSubRegDisplayText
+# define TixpSubRegDisplayText (*TixintVptr->V_TixpSubRegDisplayText)
+#endif
+
+#ifndef TixpSubRegDrawBitmap
+# define TixpSubRegDrawBitmap (*TixintVptr->V_TixpSubRegDrawBitmap)
+#endif
+
+#ifndef TixpSubRegDrawImage
+# define TixpSubRegDrawImage (*TixintVptr->V_TixpSubRegDrawImage)
+#endif
+
+#ifndef TixpSubRegFillRectangle
+# define TixpSubRegFillRectangle (*TixintVptr->V_TixpSubRegFillRectangle)
+#endif
+
+#ifndef tixStrDup
+# define tixStrDup (*TixintVptr->V_tixStrDup)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TIXINT_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.t
new file mode 100755
index 00000000000..07e593d2337
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt.t
@@ -0,0 +1,249 @@
+#ifdef _TIXINT
+VVAR(Tk_Uid,tixCellUid,V_tixCellUid)
+VVAR(Tk_Uid,tixColumnUid,V_tixColumnUid)
+VVAR(Tk_Uid,tixDisabledUid,V_tixDisabledUid)
+VVAR(Tk_Uid,tixNormalUid,V_tixNormalUid)
+VVAR(Tk_Uid,tixRowUid,V_tixRowUid)
+#ifndef TixComputeTextGeometry
+VFUNC(void,TixComputeTextGeometry,V_TixComputeTextGeometry,_ANSI_ARGS_((
+ TixFont fontStructPtr, char *string,
+ int numChars, int wrapLength, int *widthPtr,
+ int *heightPtr)))
+#endif /* #ifndef TixComputeTextGeometry */
+
+#ifndef TixDItemGetAnchor
+VFUNC(void,TixDItemGetAnchor,V_TixDItemGetAnchor,_ANSI_ARGS_((Tk_Anchor anchor,
+ int x, int y, int cav_w, int cav_h,
+ int width, int height, int * x_ret, int * y_ret)))
+#endif /* #ifndef TixDItemGetAnchor */
+
+#ifndef TixDItemStyleChanged
+VFUNC(void,TixDItemStyleChanged,V_TixDItemStyleChanged,_ANSI_ARGS_((
+ Tix_DItemInfo * diTypePtr,
+ Tix_DItemStyle * stylePtr)))
+#endif /* #ifndef TixDItemStyleChanged */
+
+#ifndef TixDItemStyleFree
+VFUNC(void,TixDItemStyleFree,V_TixDItemStyleFree,_ANSI_ARGS_((Tix_DItem *iPtr,
+ Tix_DItemStyle * stylePtr)))
+#endif /* #ifndef TixDItemStyleFree */
+
+#ifndef TixDisplayText
+VFUNC(void,TixDisplayText,V_TixDisplayText,_ANSI_ARGS_((Display *display,
+ Drawable drawable, TixFont font,
+ char *string, int numChars, int x, int y,
+ int length, Tk_Justify justify, int underline,
+ GC gc)))
+#endif /* #ifndef TixDisplayText */
+
+#ifndef TixGetColorDItemGC
+VFUNC(void,TixGetColorDItemGC,V_TixGetColorDItemGC,_ANSI_ARGS_((
+ Tix_DItem * iPtr, GC * backGC_ret,
+ GC * foreGC_ret, int flags)))
+#endif /* #ifndef TixGetColorDItemGC */
+
+#ifndef TixGetDefaultDItemStyle
+VFUNC(Tix_DItemStyle*,TixGetDefaultDItemStyle,V_TixGetDefaultDItemStyle,_ANSI_ARGS_((
+ Tix_DispData * ddPtr, Tix_DItemInfo * diTypePtr,
+ Tix_DItem *iPtr, Tix_DItemStyle* oldStylePtr)))
+#endif /* #ifndef TixGetDefaultDItemStyle */
+
+#ifndef TixGetHashTable
+VFUNC(Tcl_HashTable *,TixGetHashTable,V_TixGetHashTable,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * name, Tcl_InterpDeleteProc *deleteProc)))
+#endif /* #ifndef TixGetHashTable */
+
+#ifndef Tix_AddDItemType
+VFUNC(void,Tix_AddDItemType,V_Tix_AddDItemType,_ANSI_ARGS_((
+ Tix_DItemInfo * diTypePtr)))
+#endif /* #ifndef Tix_AddDItemType */
+
+#ifndef Tix_ConfigureInfo2
+VFUNC(int,Tix_ConfigureInfo2,V_Tix_ConfigureInfo2,_ANSI_ARGS_((
+ Tcl_Interp *interp, Tk_Window tkwin,
+ char *entRec, Tk_ConfigSpec *entConfigSpecs,
+ Tix_DItem * iPtr, char *argvName, int flags)))
+#endif /* #ifndef Tix_ConfigureInfo2 */
+
+#ifndef Tix_ConfigureValue2
+VFUNC(int,Tix_ConfigureValue2,V_Tix_ConfigureValue2,_ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, char * entRec,
+ Tk_ConfigSpec *entConfigSpecs, Tix_DItem * iPtr,
+ char *argvName, int flags)))
+#endif /* #ifndef Tix_ConfigureValue2 */
+
+#ifndef Tix_DItemCalculateSize
+VFUNC(void,Tix_DItemCalculateSize,V_Tix_DItemCalculateSize,_ANSI_ARGS_((
+ Tix_DItem * iPtr)))
+#endif /* #ifndef Tix_DItemCalculateSize */
+
+#ifndef Tix_DItemComponent
+VFUNC(char *,Tix_DItemComponent,V_Tix_DItemComponent,_ANSI_ARGS_((Tix_DItem * diPtr,
+ int x, int y)))
+#endif /* #ifndef Tix_DItemComponent */
+
+#ifndef Tix_DItemConfigure
+VFUNC(int,Tix_DItemConfigure,V_Tix_DItemConfigure,_ANSI_ARGS_((
+ Tix_DItem * diPtr, int argc,
+ Tcl_Obj *CONST *objv, int flags)))
+#endif /* #ifndef Tix_DItemConfigure */
+
+#ifndef Tix_DItemCreate
+VFUNC(Tix_DItem *,Tix_DItemCreate,V_Tix_DItemCreate,_ANSI_ARGS_((Tix_DispData * ddPtr,
+ char * type)))
+#endif /* #ifndef Tix_DItemCreate */
+
+#ifndef Tix_DItemDisplay
+VFUNC(void,Tix_DItemDisplay,V_Tix_DItemDisplay,_ANSI_ARGS_((
+ Pixmap pixmap, GC gc, Tix_DItem * iPtr,
+ int x, int y, int width, int height, int flag)))
+#endif /* #ifndef Tix_DItemDisplay */
+
+#ifndef Tix_DItemDrawBackground
+VFUNC(void,Tix_DItemDrawBackground,V_Tix_DItemDrawBackground,_ANSI_ARGS_((
+ Pixmap pixmap, GC gc, Tix_DItem * iPtr,
+ int x, int y, int width, int height, int flags)))
+#endif /* #ifndef Tix_DItemDrawBackground */
+
+#ifndef Tix_DItemFree
+VFUNC(void,Tix_DItemFree,V_Tix_DItemFree,_ANSI_ARGS_((
+ Tix_DItem * iPtr)))
+#endif /* #ifndef Tix_DItemFree */
+
+#ifndef Tix_FreeArgumentList
+VFUNC(void,Tix_FreeArgumentList,V_Tix_FreeArgumentList,_ANSI_ARGS_((
+ Tix_ArgumentList *argListPtr)))
+#endif /* #ifndef Tix_FreeArgumentList */
+
+#ifndef Tix_GetDItemType
+VFUNC(Tix_DItemInfo *,Tix_GetDItemType,V_Tix_GetDItemType,_ANSI_ARGS_((
+ Tcl_Interp * interp, char *type)))
+#endif /* #ifndef Tix_GetDItemType */
+
+#ifndef Tix_GetScrollFractions
+VFUNC(void,Tix_GetScrollFractions,V_Tix_GetScrollFractions,_ANSI_ARGS_((
+ Tix_ScrollInfo * siPtr,
+ double * first_ret, double * last_ret)))
+#endif /* #ifndef Tix_GetScrollFractions */
+
+#ifndef Tix_InitScrollInfo
+VFUNC(void,Tix_InitScrollInfo,V_Tix_InitScrollInfo,_ANSI_ARGS_((
+ Tix_ScrollInfo * siPtr, int type)))
+#endif /* #ifndef Tix_InitScrollInfo */
+
+#ifndef Tix_MultiConfigureInfo
+VFUNC(int,Tix_MultiConfigureInfo,V_Tix_MultiConfigureInfo,_ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec **specsList,
+ int numLists, char **widgRecList, char *argvName,
+ int flags, int request)))
+#endif /* #ifndef Tix_MultiConfigureInfo */
+
+#ifndef Tix_SetDefaultStyleTemplate
+VFUNC(void,Tix_SetDefaultStyleTemplate,V_Tix_SetDefaultStyleTemplate,_ANSI_ARGS_((
+ Tk_Window tkwin, Tix_StyleTemplate * tmplPtr)))
+#endif /* #ifndef Tix_SetDefaultStyleTemplate */
+
+#ifndef Tix_SetScrollBarView
+VFUNC(int,Tix_SetScrollBarView,V_Tix_SetScrollBarView,_ANSI_ARGS_((
+ Tcl_Interp *interp, Tix_ScrollInfo * siPtr,
+ int argc, Tcl_Obj *CONST *objv, int compat)))
+#endif /* #ifndef Tix_SetScrollBarView */
+
+#ifndef Tix_SetWindowItemSerial
+VFUNC(void,Tix_SetWindowItemSerial,V_Tix_SetWindowItemSerial,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_DItem * iPtr,
+ int serial)))
+#endif /* #ifndef Tix_SetWindowItemSerial */
+
+#ifndef Tix_SplitConfig
+VFUNC(int,Tix_SplitConfig,V_Tix_SplitConfig,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec ** specsList,
+ int numLists, int argc, Tcl_Obj *CONST *objv,
+ Tix_ArgumentList * argListPtr)))
+#endif /* #ifndef Tix_SplitConfig */
+
+#ifndef Tix_UnmapInvisibleWindowItems
+VFUNC(void,Tix_UnmapInvisibleWindowItems,V_Tix_UnmapInvisibleWindowItems,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, int serial)))
+#endif /* #ifndef Tix_UnmapInvisibleWindowItems */
+
+#ifndef Tix_UpdateScrollBar
+VFUNC(void,Tix_UpdateScrollBar,V_Tix_UpdateScrollBar,_ANSI_ARGS_((
+ Tcl_Interp *interp, Tix_ScrollInfo * siPtr)))
+#endif /* #ifndef Tix_UpdateScrollBar */
+
+#ifndef Tix_WidgetConfigure2
+VFUNC(int,Tix_WidgetConfigure2,V_Tix_WidgetConfigure2,_ANSI_ARGS_((
+ Tcl_Interp *interp, Tk_Window tkwin, char * entRec,
+ Tk_ConfigSpec *entConfigSpecs,
+ Tix_DItem * iPtr, int argc, Tcl_Obj *CONST *objv,
+ int flags, int forced, int * sizeChanged_ret)))
+#endif /* #ifndef Tix_WidgetConfigure2 */
+
+#ifndef Tix_WindowItemListRemove
+VFUNC(void,Tix_WindowItemListRemove,V_Tix_WindowItemListRemove,_ANSI_ARGS_((
+ Tix_LinkList * lPtr, Tix_DItem * iPtr)))
+#endif /* #ifndef Tix_WindowItemListRemove */
+
+#ifndef TixpDrawAnchorLines
+VFUNC(void,TixpDrawAnchorLines,V_TixpDrawAnchorLines,_ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc, int x, int y,
+ int w, int h)))
+#endif /* #ifndef TixpDrawAnchorLines */
+
+#ifndef TixpDrawTmpLine
+VFUNC(void,TixpDrawTmpLine,V_TixpDrawTmpLine,_ANSI_ARGS_((int x1, int y1,
+ int x2, int y2, Tk_Window tkwin)))
+#endif /* #ifndef TixpDrawTmpLine */
+
+#ifndef TixpEndSubRegionDraw
+VFUNC(void,TixpEndSubRegionDraw,V_TixpEndSubRegionDraw,_ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr)))
+#endif /* #ifndef TixpEndSubRegionDraw */
+
+#ifndef TixpStartSubRegionDraw
+VFUNC(void,TixpStartSubRegionDraw,V_TixpStartSubRegionDraw,_ANSI_ARGS_((Tix_DispData *ddPtr,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr, int origX,
+ int origY, int x, int y, int width, int height,
+ int needWidth, int needHeight)))
+#endif /* #ifndef TixpStartSubRegionDraw */
+
+#ifndef TixpSubRegDisplayText
+VFUNC(void,TixpSubRegDisplayText,V_TixpSubRegDisplayText,_ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr,
+ TixFont font, char *string,
+ int numChars, int x, int y, int length,
+ Tk_Justify justify, int underline)))
+#endif /* #ifndef TixpSubRegDisplayText */
+
+#ifndef TixpSubRegDrawBitmap
+VFUNC(void,TixpSubRegDrawBitmap,V_TixpSubRegDrawBitmap,_ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr, Pixmap bitmap,
+ int src_x, int src_y, int width, int height,
+ int dest_x, int dest_y, unsigned long plane)))
+#endif /* #ifndef TixpSubRegDrawBitmap */
+
+#ifndef TixpSubRegDrawImage
+VFUNC(void,TixpSubRegDrawImage,V_TixpSubRegDrawImage,_ANSI_ARGS_((
+ TixpSubRegion * subRegPtr, Tk_Image image,
+ int imageX, int imageY, int width, int height,
+ Drawable drawable, int drawableX, int drawableY)))
+#endif /* #ifndef TixpSubRegDrawImage */
+
+#ifndef TixpSubRegFillRectangle
+VFUNC(void,TixpSubRegFillRectangle,V_TixpSubRegFillRectangle,_ANSI_ARGS_((Display *display,
+ Drawable drawable, GC gc,
+ TixpSubRegion * subRegPtr, int x, int y,
+ int width, int height)))
+#endif /* #ifndef TixpSubRegFillRectangle */
+
+#ifndef tixStrDup
+VFUNC(char *,tixStrDup,V_tixStrDup,_ANSI_ARGS_(( CONST char * s)))
+#endif /* #ifndef tixStrDup */
+
+#endif /* _TIXINT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt_f.h
new file mode 100755
index 00000000000..f085e2778fc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixInt_f.h
@@ -0,0 +1,14 @@
+#ifndef TIXINT_VT
+#define TIXINT_VT
+typedef struct TixintVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tixInt.t"
+#undef VFUNC
+#undef VVAR
+} TixintVtab;
+extern TixintVtab *TixintVptr;
+extern TixintVtab *TixintVGet(void);
+#endif /* TIXINT_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixPort.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixPort.h
new file mode 100755
index 00000000000..56bffaf4869
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixPort.h
@@ -0,0 +1,110 @@
+
+/* $Id: tixPort.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixPort.h --
+ *
+ * This header file handles porting issues that occur because of
+ * differences between systems. It reads in platform specific
+ * portability files.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+#ifndef _TIX_PORT_H_
+#define _TIX_PORT_H_
+
+#ifndef _TKPORT
+#include "tkPort.h"
+#endif
+
+#ifndef _LANG
+#include "Lang.h"
+#endif
+
+#ifndef _TK
+#include "tk.h"
+#endif
+
+#if (!defined(__WIN32__)) && (!defined(_WIN32)) && (!defined(MAC_TCL)) && (!defined(__PM__))
+ /*
+ * The Tcl/Tk porting stuff is needed only in Unix.
+ */
+#if !defined(_TCLPORT) && !defined(_TKPORT)
+# if defined(_TKINT) || defined(_LANG)
+# include "tkPort.h"
+# else
+# include "tclPort.h"
+# endif
+#endif
+#endif
+
+
+#if defined(WIN32) || defined(_WIN32) || defined(__WIN32__) || defined(__PM__)
+# include "tixWinPort.h"
+#else
+# if defined(MAC_TCL)
+# include "tixMacPort.h"
+# else
+# include "tixUnixPort.h"
+# endif
+#endif
+
+
+EXTERN Tcl_HashTable * TixGetHashTable _ANSI_ARGS_((Tcl_Interp * interp,
+ char * name, Tcl_InterpDeleteProc *deleteProc));
+#define _TixGetHashTable(i,n,p) TixGetHashTable(i,n,p)
+
+#if (TK_MAJOR_VERSION > 4)
+
+/*
+ * The font handling is changed in Tk 8.0 and later
+ */
+
+typedef Tk_Font TixFont;
+#define TixFontId(font) Tk_FontId(font)
+
+EXTERN void TixComputeTextGeometry _ANSI_ARGS_((
+ TixFont fontStructPtr, char *string,
+ int numChars, int wrapLength, int *widthPtr,
+ int *heightPtr));
+EXTERN void TixDisplayText _ANSI_ARGS_((Display *display,
+ Drawable drawable, TixFont font,
+ char *string, int numChars, int x, int y,
+ int length, Tk_Justify justify, int underline,
+ GC gc));
+
+#define TixFreeFont Tk_FreeFont
+#define TixNameOfFont Tk_NameOfFont
+#define TixGetFont Tk_GetFont
+
+#else
+
+typedef XFontStruct* TixFont;
+#define TixFontId(font) ((font)->fid)
+#define TixComputeTextGeometry TkComputeTextGeometry
+#define TixDisplayText TkDisplayText
+#define TixFreeFont Tk_FreeFontStruct
+#define TixNameOfFont Tk_NameOfFontStruct
+#define TixGetFont Tk_GetFontStruct
+
+#ifndef TkDisplayText
+EXTERN void TkDisplayText _ANSI_ARGS_((Display *display,
+ Drawable drawable, XFontStruct *fontStructPtr,
+ char *string, int numChars, int x, int y,
+ int length, Tk_Justify justify, int underline,
+ GC gc));
+#endif
+#ifndef TkComputeTextGeometry
+EXTERN void TkComputeTextGeometry _ANSI_ARGS_((
+ XFontStruct *fontStructPtr, char *string,
+ int numChars, int wrapLength, int *widthPtr,
+ int *heightPtr));
+#endif
+
+#endif
+
+#endif /* _TIX_PORT_H_ */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixTList.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixTList.h
new file mode 100755
index 00000000000..52584a022b8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixTList.h
@@ -0,0 +1,148 @@
+
+/* $Id: tixTList.h,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
+
+/*
+ * tixTList.h --
+ *
+ * This header file defines the data structures used by the tixTList
+ * widget.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_TLIST_H_
+#define _TIX_TLIST_H_
+
+#ifndef _TIX_INT_H_
+#include "tixInt.h"
+#endif
+
+#include "tkVMacro.h"
+
+#define TIX_X 0
+#define TIX_Y 1
+
+typedef struct ListEntry {
+ struct ListEntry * next;
+ Tix_DItem * iPtr;
+ Tk_Uid state;
+ Tcl_Obj * data; /* user data field */
+ int size[2];
+ unsigned int selected : 1;
+} ListEntry;
+
+typedef struct ListRow {
+ ListEntry * chPtr;
+ int size[2];
+ int numEnt;
+} ListRow;
+
+/*
+ * A data structure of the following type is kept for each
+ * widget managed by this file:
+ */
+typedef struct ListStruct {
+ Tix_DispData dispData;
+
+ Tcl_Command widgetCmd; /* Token for button's widget command. */
+
+ /*
+ * Information used when displaying widget:
+ */
+ int width, height; /* For app programmer to request size */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ /* Border and general drawing */
+ int borderWidth; /* Width of 3-D borders. */
+ int selBorderWidth; /* Width of 3-D borders for selected items */
+ int relief; /* Indicates whether window as a whole is
+ * raised, sunken, or flat. */
+ Tk_3DBorder border; /* Used for drawing the 3d border. */
+ Tk_3DBorder selectBorder; /* Used for selected background. */
+ XColor *normalFg; /* Normal foreground for text. */
+ XColor *normalBg; /* Normal background for text. */
+ XColor *selectFg; /* Color for drawing selected text. */
+
+ /* GC and stuff */
+ GC backgroundGC; /* GC for drawing background. */
+ GC selectGC; /* GC for drawing selected background. */
+ GC anchorGC; /* GC for drawing dotted anchor highlight. */
+ TixFont font; /* Default font used by the DItems. */
+
+ /* Text drawing */
+ Cursor cursor; /* Current cursor for window, or None. */
+
+ /* For highlights */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ GC highlightGC; /* For drawing traversal highlight. */
+
+ /* default pad and gap values */
+ int padX, padY;
+
+ Tk_Uid selectMode; /* Selection style: single, browse, multiple,
+ * or extended. This value isn't used in C
+ * code, but the Tcl bindings use it. */
+ Tk_Uid state; /* State can only be normal or disabled. */
+ Tix_LinkList entList;
+
+ int numRowAllocd;
+ int numRow;
+ ListRow * rows;
+
+ ListEntry * seeElemPtr; /* The current item to "see" */
+ ListEntry * anchor; /* The current anchor item */
+ ListEntry * active; /* The current active item */
+ ListEntry * dropSite; /* The current drop site */
+ ListEntry * dragSite; /* The current drop site */
+
+ /*
+ * Commands
+ */
+ LangCallback *command; /* The command when user double-clicks */
+ LangCallback *browseCmd; /* The command to call when the selection
+ * changes. */
+ LangCallback *sizeCmd; /* The command to call when the size of
+ * the listbox changes. E.g., when the user
+ * add/deletes elements. Useful for
+ * auto-scrollbar geometry managers */
+
+ /* These options control how the items are arranged on the list */
+ Tk_Uid orientUid; /* Can be "vertical" or "horizontal" */
+ int packMode[2]; /* is row and column packed */
+ int numMajor[2]; /* num of rows and columns */
+ int itemSize[2]; /* horizontal and vertical size of items, -1
+ * means natural size */
+
+ /* Info for laying out */
+ int maxSize[2]; /* max size of all elements in X and Y, (they
+ * do not need to be the same element, may be
+ * invalid according to mode */
+ char *takeFocus; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+
+ int serial; /* this number is incremented before each time
+ * the widget is redisplayed */
+
+ Tix_DItemInfo * diTypePtr; /* Default item type */
+ Tix_IntScrollInfo scrollInfo[2];
+ unsigned int redrawing : 1;
+ unsigned int resizing : 1;
+ unsigned int hasFocus : 1;
+ unsigned int isVertical : 1;
+} TixTListWidget;
+
+typedef TixTListWidget WidgetRecord;
+typedef TixTListWidget * WidgetPtr;
+
+#endif /* _TIX_TLIST_H_ */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinInt.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinInt.h
new file mode 100755
index 00000000000..092cfddb9fe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinInt.h
@@ -0,0 +1,23 @@
+
+/* $Id: tixWinInt.h,v 1.1.1.1 2000/05/17 11:08:55 idiscovery Exp $ */
+
+/*
+ * tixWinInt.h
+ *
+ * Internal header file for Tix on the Windows platform.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_WIN_INT_H_
+#define _TIX_WIN_INT_H_
+
+#ifndef _TIX_INT_H_
+#include "tixInt.h"
+#endif
+
+#endif /* _TIX_WIN_INT_H_ */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinPort.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinPort.h
new file mode 100755
index 00000000000..6c71160c756
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tixWinPort.h
@@ -0,0 +1,40 @@
+
+/* $Id: tixWinPort.h,v 1.1.1.1 2000/05/17 11:08:55 idiscovery Exp $ */
+
+/*
+ * tixWinPort.h --
+ *
+ * This header file handles porting issues that occur because of
+ * differences between systems. It reads in platform specific
+ * portability files.
+ *
+ * Copyright (c) 1996, Expert Interface Technologies
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#ifndef _TIX_WINPORT_H_
+#define _TIX_WINPORT_H_
+
+#include <stdio.h>
+
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+#include <sys/stat.h>
+#include <sys/timeb.h>
+#include <time.h>
+#include <io.h>
+#include <fcntl.h>
+
+#define WIN32_LEAN_AND_MEAN
+# ifndef __PM__
+# include <windows.h>
+# endif
+#undef WIN32_LEAN_AND_MEAN
+
+typedef unsigned char UNSIGNED_CHAR;
+
+#endif /* _TIX_WINPORT_H_ */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix_f.h
new file mode 100755
index 00000000000..0289ee3f7a3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tix_f.h
@@ -0,0 +1,14 @@
+#ifndef TIX_VT
+#define TIX_VT
+typedef struct TixVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tix.t"
+#undef VFUNC
+#undef VVAR
+} TixVtab;
+extern TixVtab *TixVptr;
+extern TixVtab *TixVGet(void);
+#endif /* TIX_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.h
new file mode 100755
index 00000000000..b195357993a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.h
@@ -0,0 +1,1859 @@
+/*
+ * tk.h --
+ *
+ * Declarations for Tk-related things that are visible
+ * outside of the Tk module itself.
+ *
+ * Copyright (c) 1989-1994 The Regents of the University of California.
+ * Copyright (c) 1994 The Australian National University.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 Ajuba Solutions.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tk.h,v 1.74.2.3 2003/10/03 16:32:39 dgp Exp $
+ */
+
+#ifndef _TK
+#define _TK
+
+/*
+ * For C++ compilers, use extern "C"
+ */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*
+ * When version numbers change here, you must also go into the following files
+ * and update the version numbers:
+ *
+ * library/tk.tcl (only if Major.minor changes, not patchlevel)
+ * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
+ * win/configure.in (as above)
+ * win/makefile.vc (not patchlevel)
+ * README (sections 0 and 1)
+ * mac/README (not patchlevel)
+ * macosx/Wish.pbproj/project.pbxproj
+ * (14 LOC total, 4 LOC patch)
+ * win/README (not patchlevel)
+ * unix/README (not patchlevel)
+ * unix/tk.spec (3 LOC Major/Minor, 2 LOC patch)
+ * win/tcl.m4 (not patchlevel)
+ *
+ * You may also need to update some of these files when the numbers change
+ * for the version of Tcl that this release of Tk is compiled against.
+ */
+
+#define TK_MAJOR_VERSION 8
+#define TK_MINOR_VERSION 4
+#define TK_RELEASE_LEVEL TCL_FINAL_RELEASE
+#define TK_RELEASE_SERIAL 5
+
+#define TK_VERSION "8.4"
+#define TK_PATCH_LEVEL "8.4.5"
+
+/*
+ * The following definitions set up the proper options for Macintosh
+ * compilers. We use this method because there is no autoconf equivalent.
+ */
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# ifndef REDO_KEYSYM_LOOKUP
+# define REDO_KEYSYM_LOOKUP
+# endif
+#endif
+
+
+/*
+ * A special definition used to allow this header file to be included
+ * from windows or mac resource files so that they can obtain version
+ * information. RC_INVOKED is defined by default by the windows RC tool
+ * and manually set for macintosh.
+ *
+ * Resource compilers don't like all the C stuff, like typedefs and
+ * procedure declarations, that occur below, so block them out.
+ */
+
+#ifdef RC_INVOKED
+#include "Lang.h"
+#endif
+
+#ifndef RC_INVOKED
+
+#ifndef _TKPORT
+#include "tkPort.h"
+#endif
+
+#ifndef _XLIB_H
+# if defined (MAC_TCL)
+# include <Xlib.h>
+# include <X.h>
+# elif defined(MAC_OSX_TK)
+# include <X11/Xlib.h>
+# include <X11/X.h>
+# else
+# include <X11/Xlib.h>
+# endif
+#if !defined(_XLIB_H)
+#define _XLIB_H
+#endif
+#endif
+
+
+#ifdef __STDC__
+# include <stddef.h>
+#endif
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Decide whether or not to use input methods.
+ */
+
+#ifdef XNQueryInputStyle
+#define TK_USE_INPUT_METHODS
+#endif
+
+/*
+ * Dummy types that are used by clients:
+ */
+
+typedef struct Tk_BindingTable_ *Tk_BindingTable;
+typedef struct Tk_Canvas_ *Tk_Canvas;
+typedef struct Tk_Cursor_ *Tk_Cursor;
+typedef struct Tk_ErrorHandler_ *Tk_ErrorHandler;
+typedef struct Tk_Font_ *Tk_Font;
+typedef struct Tk_Image__ *Tk_Image;
+typedef struct Tk_ImageMaster_ *Tk_ImageMaster;
+typedef struct Tk_OptionTable_ *Tk_OptionTable;
+typedef struct Tk_PostscriptInfo_ *Tk_PostscriptInfo;
+typedef struct Tk_TextLayout_ *Tk_TextLayout;
+typedef struct Tk_Window_ *Tk_Window;
+typedef struct Tk_3DBorder_ *Tk_3DBorder;
+typedef struct Tk_Style_ *Tk_Style;
+typedef struct Tk_StyleEngine_ *Tk_StyleEngine;
+typedef struct Tk_StyledElement_ *Tk_StyledElement;
+
+/*
+ * Additional types exported to clients.
+ */
+
+typedef CONST char *Tk_Uid;
+
+/*
+ * The enum below defines the valid types for Tk configuration options
+ * as implemented by Tk_InitOptions, Tk_SetOptions, etc.
+ */
+
+typedef enum {
+ TK_OPTION_BOOLEAN,
+ TK_OPTION_INT,
+ TK_OPTION_DOUBLE,
+ TK_OPTION_STRING,
+ TK_OPTION_STRING_TABLE,
+ TK_OPTION_COLOR,
+ TK_OPTION_FONT,
+ TK_OPTION_BITMAP,
+ TK_OPTION_BORDER,
+ TK_OPTION_RELIEF,
+ TK_OPTION_CURSOR,
+ TK_OPTION_JUSTIFY,
+ TK_OPTION_ANCHOR,
+ TK_OPTION_SYNONYM,
+ TK_OPTION_PIXELS,
+ TK_OPTION_WINDOW,
+ TK_OPTION_END,
+ TK_OPTION_CUSTOM,
+ TK_OPTION_STYLE,
+ TK_OPTION_OBJ,
+ TK_OPTION_CALLBACK,
+ TK_OPTION_SCALARVAR,
+ TK_OPTION_HASHVAR,
+ TK_OPTION_ARRAYVAR
+} Tk_OptionType;
+
+/*
+ * Structures of the following type are used by widgets to specify
+ * their configuration options. Typically each widget has a static
+ * array of these structures, where each element of the array describes
+ * a single configuration option. The array is passed to
+ * Tk_CreateOptionTable.
+ */
+
+typedef struct Tk_OptionSpec {
+ Tk_OptionType type; /* Type of option, such as TK_OPTION_COLOR;
+ * see definitions above. Last option in
+ * table must have type TK_OPTION_END. */
+ char *optionName; /* Name used to specify option in Tcl
+ * commands. */
+ char *dbName; /* Name for option in option database. */
+ char *dbClass; /* Class for option in database. */
+ char *defValue; /* Default value for option if not specified
+ * in command line, the option database,
+ * or the system. */
+ int objOffset; /* Where in record to store a Tcl_Obj * that
+ * holds the value of this option, specified
+ * as an offset in bytes from the start of
+ * the record. Use the Tk_Offset macro to
+ * generate values for this. -1 means don't
+ * store the Tcl_Obj in the record. */
+ int internalOffset; /* Where in record to store the internal
+ * representation of the value of this option,
+ * such as an int or XColor *. This field
+ * is specified as an offset in bytes
+ * from the start of the record. Use the
+ * Tk_Offset macro to generate values for it.
+ * -1 means don't store the internal
+ * representation in the record. */
+ int flags; /* Any combination of the values defined
+ * below. */
+ ClientData clientData; /* An alternate place to put option-specific
+ * data. Used for the monochrome default value
+ * for colors, etc. */
+ int typeMask; /* An arbitrary bit mask defined by the
+ * class manager; typically bits correspond
+ * to certain kinds of options such as all
+ * those that require a redisplay when they
+ * change. Tk_SetOptions returns the bit-wise
+ * OR of the typeMasks of all options that
+ * were changed. */
+} Tk_OptionSpec;
+
+/*
+ * Flag values for Tk_OptionSpec structures. These flags are shared by
+ * Tk_ConfigSpec structures, so be sure to coordinate any changes
+ * carefully.
+ */
+
+#define TK_OPTION_NULL_OK (1 << 0)
+#define TK_OPTION_DONT_SET_DEFAULT (1 << 3)
+
+/*
+ * The following structure and function types are used by TK_OPTION_CUSTOM
+ * options; the structure holds pointers to the functions needed by the Tk
+ * option config code to handle a custom option.
+ */
+
+typedef int (Tk_CustomOptionSetProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj **value, char *widgRec,
+ int offset, char *saveInternalPtr, int flags));
+typedef Tcl_Obj *(Tk_CustomOptionGetProc) _ANSI_ARGS_((ClientData clientData,
+ Tk_Window tkwin, char *widgRec, int offset));
+typedef void (Tk_CustomOptionRestoreProc) _ANSI_ARGS_((ClientData clientData,
+ Tk_Window tkwin, char *internalPtr, char *saveInternalPtr));
+typedef void (Tk_CustomOptionFreeProc) _ANSI_ARGS_((ClientData clientData,
+ Tk_Window tkwin, char *internalPtr));
+
+typedef struct Tk_ObjCustomOption {
+ char *name; /* Name of the custom option. */
+ Tk_CustomOptionSetProc *setProc; /* Function to use to set a record's
+ * option value from a Tcl_Obj */
+ Tk_CustomOptionGetProc *getProc; /* Function to use to get a Tcl_Obj
+ * representation from an internal
+ * representation of an option. */
+ Tk_CustomOptionRestoreProc *restoreProc; /* Function to use to restore a
+ * saved value for the internal
+ * representation. */
+ Tk_CustomOptionFreeProc *freeProc; /* Function to use to free the internal
+ * representation of an option. */
+ ClientData clientData; /* Arbitrary one-word value passed to
+ * the handling procs. */
+} Tk_ObjCustomOption;
+
+
+/*
+ * Macro to use to fill in "offset" fields of the Tk_OptionSpec.
+ * struct. Computes number of bytes from beginning of structure
+ * to a given field.
+ */
+
+#ifdef offsetof
+#define Tk_Offset(type, field) ((int) offsetof(type, field))
+#else
+#define Tk_Offset(type, field) ((int) ((char *) &((type *) 0)->field))
+#endif
+
+/*
+ * The following two structures are used for error handling. When
+ * configuration options are being modified, the old values are
+ * saved in a Tk_SavedOptions structure. If an error occurs, then the
+ * contents of the structure can be used to restore all of the old
+ * values. The contents of this structure are for the private use
+ * Tk. No-one outside Tk should ever read or write any of the fields
+ * of these structures.
+ */
+
+typedef struct Tk_SavedOption {
+ struct TkOption *optionPtr; /* Points to information that describes
+ * the option. */
+ Tcl_Obj *valuePtr; /* The old value of the option, in
+ * the form of a Tcl object; may be
+ * NULL if the value wasn't saved as
+ * an object. */
+ double internalForm; /* The old value of the option, in
+ * some internal representation such
+ * as an int or (XColor *). Valid
+ * only if optionPtr->specPtr->objOffset
+ * is < 0. The space must be large
+ * enough to accommodate a double, a
+ * long, or a pointer; right now it
+ * looks like a double is big
+ * enough. Also, using a double
+ * guarantees that the field is
+ * properly aligned for storing large
+ * values. */
+} Tk_SavedOption;
+
+#ifdef TCL_MEM_DEBUG
+# define TK_NUM_SAVED_OPTIONS 2
+#else
+# define TK_NUM_SAVED_OPTIONS 20
+#endif
+
+typedef struct Tk_SavedOptions {
+ char *recordPtr; /* The data structure in which to
+ * restore configuration options. */
+ Tk_Window tkwin; /* Window associated with recordPtr;
+ * needed to restore certain options. */
+ int numItems; /* The number of valid items in
+ * items field. */
+ Tk_SavedOption items[TK_NUM_SAVED_OPTIONS];
+ /* Items used to hold old values. */
+ struct Tk_SavedOptions *nextPtr; /* Points to next structure in list;
+ * needed if too many options changed
+ * to hold all the old values in a
+ * single structure. NULL means no
+ * more structures. */
+} Tk_SavedOptions;
+
+/*
+ * Structure used to describe application-specific configuration
+ * options: indicates procedures to call to parse an option and
+ * to return a text string describing an option. THESE ARE
+ * DEPRECATED; PLEASE USE THE NEW STRUCTURES LISTED ABOVE.
+ */
+
+/*
+ * This is a temporary flag used while tkObjConfig and new widgets
+ * are in development.
+ */
+
+#ifndef __NO_OLD_CONFIG
+
+typedef int (Tk_OptionParseProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+typedef Tcl_Obj *(Tk_OptionPrintProc) _ANSI_ARGS_((ClientData clientData,
+ Tk_Window tkwin, char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+
+typedef struct Tk_CustomOption {
+ Tk_OptionParseProc *parseProc; /* Procedure to call to parse an
+ * option and store it in converted
+ * form. */
+ Tk_OptionPrintProc *printProc; /* Procedure to return a printable
+ * string describing an existing
+ * option. */
+ ClientData clientData; /* Arbitrary one-word value used by
+ * option parser: passed to
+ * parseProc and printProc. */
+} Tk_CustomOption;
+
+/*
+ * Structure used to specify information for Tk_ConfigureWidget. Each
+ * structure gives complete information for one option, including
+ * how the option is specified on the command line, where it appears
+ * in the option database, etc.
+ */
+
+typedef struct Tk_ConfigSpec {
+ int type; /* Type of option, such as TK_CONFIG_COLOR;
+ * see definitions below. Last option in
+ * table must have type TK_CONFIG_END. */
+ char *argvName; /* Switch used to specify option in objv.
+ * NULL means this spec is part of a group. */
+ Tk_Uid dbName; /* Name for option in option database. */
+ Tk_Uid dbClass; /* Class for option in database. */
+ Tk_Uid defValue; /* Default value for option if not
+ * specified in command line or database. */
+ int offset; /* Where in widget record to store value;
+ * use Tk_Offset macro to generate values
+ * for this. */
+ int specFlags; /* Any combination of the values defined
+ * below; other bits are used internally
+ * by tkConfig.c. */
+ Tk_CustomOption *customPtr; /* If type is TK_CONFIG_CUSTOM then this is
+ * a pointer to info about how to parse and
+ * print the option. Otherwise it is
+ * irrelevant. */
+} Tk_ConfigSpec;
+
+/*
+ * Type values for Tk_ConfigSpec structures. See the user
+ * documentation for details.
+ */
+
+
+/*
+ * Macro to use to fill in "offset" fields of Tk_ConfigInfos.
+ * Computes number of bytes from beginning of structure to a
+ * given field.
+ */
+
+#ifdef offsetof
+#define Tk_Offset(type, field) ((int) offsetof(type, field))
+#else
+#define Tk_Offset(type, field) ((int) ((char *) &((type *) 0)->field))
+#endif
+
+typedef enum {
+ TK_CONFIG_BOOLEAN, TK_CONFIG_INT, TK_CONFIG_DOUBLE, TK_CONFIG_STRING,
+ TK_CONFIG_UID, TK_CONFIG_COLOR, TK_CONFIG_FONT, TK_CONFIG_BITMAP,
+ TK_CONFIG_BORDER, TK_CONFIG_RELIEF, TK_CONFIG_CURSOR,
+ TK_CONFIG_ACTIVE_CURSOR, TK_CONFIG_JUSTIFY, TK_CONFIG_ANCHOR,
+ TK_CONFIG_SYNONYM, TK_CONFIG_CAP_STYLE, TK_CONFIG_JOIN_STYLE,
+ TK_CONFIG_PIXELS, TK_CONFIG_MM, TK_CONFIG_WINDOW, TK_CONFIG_CUSTOM,
+ TK_CONFIG_CALLBACK, TK_CONFIG_LANGARG, TK_CONFIG_SCALARVAR,
+ TK_CONFIG_HASHVAR, TK_CONFIG_ARRAYVAR, TK_CONFIG_OBJECT,
+ TK_CONFIG_END
+} Tk_ConfigTypes;
+
+/*
+ * Possible values for flags argument to Tk_ConfigureWidget:
+ */
+
+#define TK_CONFIG_ARGV_ONLY 1
+#define TK_CONFIG_OBJS 0x80
+
+/*
+ * Possible flag values for Tk_ConfigSpec structures. Any bits at
+ * or above TK_CONFIG_USER_BIT may be used by clients for selecting
+ * certain entries. Before changing any values here, coordinate with
+ * tkOldConfig.c (internal-use-only flags are defined there).
+ */
+
+#define TK_CONFIG_NULL_OK (1 << 0)
+#define TK_CONFIG_COLOR_ONLY (1 << 1)
+#define TK_CONFIG_MONO_ONLY (1 << 2)
+#define TK_CONFIG_DONT_SET_DEFAULT (1 << 3)
+#define TK_CONFIG_OPTION_SPECIFIED (1 << 4)
+#define TK_CONFIG_USER_BIT 0x100
+#endif /* __NO_OLD_CONFIG */
+
+/*
+ * Structure used to specify how to handle argv options.
+ */
+
+typedef struct {
+ char *key; /* The key string that flags the option in the
+ * objv array. */
+ int type; /* Indicates option type; see below. */
+ char *src; /* Value to be used in setting dst; usage
+ * depends on type. */
+ char *dst; /* Address of value to be modified; usage
+ * depends on type. */
+ char *help; /* Documentation message describing this option. */
+} Tk_ArgvInfo;
+
+/*
+ * Legal values for the type field of a Tk_ArgvInfo: see the user
+ * documentation for details.
+ */
+
+#define TK_ARGV_CONSTANT 15
+#define TK_ARGV_INT 16
+#define TK_ARGV_STRING 17
+#define TK_ARGV_UID 18
+#define TK_ARGV_REST 19
+#define TK_ARGV_FLOAT 20
+#define TK_ARGV_FUNC 21
+#define TK_ARGV_GENFUNC 22
+#define TK_ARGV_HELP 23
+#define TK_ARGV_CONST_OPTION 24
+#define TK_ARGV_OPTION_VALUE 25
+#define TK_ARGV_OPTION_NAME_VALUE 26
+#define TK_ARGV_END 27
+
+/*
+ * Flag bits for passing to Tk_ParseArgv:
+ */
+
+#define TK_ARGV_NO_DEFAULTS 0x1
+#define TK_ARGV_NO_LEFTOVERS 0x2
+#define TK_ARGV_NO_ABBREV 0x4
+#define TK_ARGV_DONT_SKIP_FIRST_ARG 0x8
+
+/*
+ * Enumerated type for describing actions to be taken in response
+ * to a restrictProc established by Tk_RestrictEvents.
+ */
+
+typedef enum {
+ TK_DEFER_EVENT, TK_PROCESS_EVENT, TK_DISCARD_EVENT
+} Tk_RestrictAction;
+
+/*
+ * Priority levels to pass to Tk_AddOption:
+ */
+
+#define TK_WIDGET_DEFAULT_PRIO 20
+#define TK_STARTUP_FILE_PRIO 40
+#define TK_USER_DEFAULT_PRIO 60
+#define TK_INTERACTIVE_PRIO 80
+#define TK_MAX_PRIO 100
+
+/*
+ * Relief values returned by Tk_GetRelief:
+ */
+
+#define TK_RELIEF_NULL -1
+#define TK_RELIEF_FLAT 0
+#define TK_RELIEF_GROOVE 1
+#define TK_RELIEF_RAISED 2
+#define TK_RELIEF_RIDGE 3
+#define TK_RELIEF_SOLID 4
+#define TK_RELIEF_SUNKEN 5
+
+/*
+ * "Which" argument values for Tk_3DBorderGC:
+ */
+
+#define TK_3D_FLAT_GC 1
+#define TK_3D_LIGHT_GC 2
+#define TK_3D_DARK_GC 3
+
+/*
+ * Special EnterNotify/LeaveNotify "mode" for use in events
+ * generated by tkShare.c. Pick a high enough value that it's
+ * unlikely to conflict with existing values (like NotifyNormal)
+ * or any new values defined in the future.
+ */
+
+#define TK_NOTIFY_SHARE 20
+
+/*
+ * Enumerated type for describing a point by which to anchor something:
+ */
+
+typedef enum {
+ TK_ANCHOR_N, TK_ANCHOR_NE, TK_ANCHOR_E, TK_ANCHOR_SE,
+ TK_ANCHOR_S, TK_ANCHOR_SW, TK_ANCHOR_W, TK_ANCHOR_NW,
+ TK_ANCHOR_CENTER
+} Tk_Anchor;
+
+/*
+ * Enumerated type for describing a style of justification:
+ */
+
+typedef enum {
+ TK_JUSTIFY_LEFT, TK_JUSTIFY_RIGHT, TK_JUSTIFY_CENTER
+} Tk_Justify;
+
+/*
+ * The following structure is used by Tk_GetFontMetrics() to return
+ * information about the properties of a Tk_Font.
+ */
+
+typedef struct Tk_FontMetrics {
+ int ascent; /* The amount in pixels that the tallest
+ * letter sticks up above the baseline, plus
+ * any extra blank space added by the designer
+ * of the font. */
+ int descent; /* The largest amount in pixels that any
+ * letter sticks below the baseline, plus any
+ * extra blank space added by the designer of
+ * the font. */
+ int linespace; /* The sum of the ascent and descent. How
+ * far apart two lines of text in the same
+ * font should be placed so that none of the
+ * characters in one line overlap any of the
+ * characters in the other line. */
+} Tk_FontMetrics;
+
+/*
+ * Flags passed to Tk_MeasureChars:
+ */
+
+#define TK_WHOLE_WORDS 1
+#define TK_AT_LEAST_ONE 2
+#define TK_PARTIAL_OK 4
+
+/*
+ * Flags passed to Tk_ComputeTextLayout:
+ */
+
+#define TK_IGNORE_TABS 8
+#define TK_IGNORE_NEWLINES 16
+
+/*
+ * Widget class procedures used to implement platform specific widget
+ * behavior.
+ */
+
+typedef Window (Tk_ClassCreateProc) _ANSI_ARGS_((Tk_Window tkwin,
+ Window parent, ClientData instanceData));
+typedef void (Tk_ClassWorldChangedProc) _ANSI_ARGS_((ClientData instanceData));
+typedef void (Tk_ClassModalProc) _ANSI_ARGS_((Tk_Window tkwin,
+ XEvent *eventPtr));
+
+typedef struct Tk_ClassProcs {
+ unsigned int size;
+ Tk_ClassWorldChangedProc *worldChangedProc;
+ /* Procedure to invoke when the widget needs to
+ * respond in some way to a change in the
+ * world (font changes, etc.) */
+ Tk_ClassCreateProc *createProc;
+ /* Procedure to invoke when the
+ * platform-dependent window needs to be
+ * created. */
+ Tk_ClassModalProc *modalProc;
+ /* Procedure to invoke after all bindings on a
+ * widget have been triggered in order to
+ * handle a modal loop. */
+} Tk_ClassProcs;
+
+/*
+ * Simple accessor for Tk_ClassProcs structure. Checks that the structure
+ * is not NULL, then checks the size field and returns either the requested
+ * field, if present, or NULL if the structure is too small to have the field
+ * (or NULL if the structure is NULL).
+ *
+ * A more general version of this function may be useful if other
+ * size-versioned structure pop up in the future:
+ *
+ * #define Tk_GetField(name, who, which) \
+ * (((who) == NULL) ? NULL :
+ * (((who)->size <= Tk_Offset(name, which)) ? NULL :(name)->which))
+ */
+
+#define Tk_GetClassProc(procs, which) \
+ (((procs) == NULL) ? NULL : \
+ (((procs)->size <= Tk_Offset(Tk_ClassProcs, which)) ? NULL:(procs)->which))
+
+/*
+ * Each geometry manager (the packer, the placer, etc.) is represented
+ * by a structure of the following form, which indicates procedures
+ * to invoke in the geometry manager to carry out certain functions.
+ */
+
+typedef void (Tk_GeomRequestProc) _ANSI_ARGS_((ClientData clientData,
+ Tk_Window tkwin));
+typedef void (Tk_GeomLostSlaveProc) _ANSI_ARGS_((ClientData clientData,
+ Tk_Window tkwin));
+
+typedef struct Tk_GeomMgr {
+ char *name; /* Name of the geometry manager (command
+ * used to invoke it, or name of widget
+ * class that allows embedded widgets). */
+ Tk_GeomRequestProc *requestProc;
+ /* Procedure to invoke when a slave's
+ * requested geometry changes. */
+ Tk_GeomLostSlaveProc *lostSlaveProc;
+ /* Procedure to invoke when a slave is
+ * taken away from one geometry manager
+ * by another. NULL means geometry manager
+ * doesn't care when slaves are lost. */
+} Tk_GeomMgr;
+
+/*
+ * Result values returned by Tk_GetScrollInfo:
+ */
+
+#define TK_SCROLL_MOVETO 1
+#define TK_SCROLL_PAGES 2
+#define TK_SCROLL_UNITS 3
+#define TK_SCROLL_ERROR 4
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Extensions to the X event set
+ *
+ *---------------------------------------------------------------------------
+ */
+#define VirtualEvent (LASTEvent)
+#define ActivateNotify (LASTEvent + 1)
+#define DeactivateNotify (LASTEvent + 2)
+#define MouseWheelEvent (LASTEvent + 3)
+#define TK_LASTEVENT (LASTEvent + 4)
+
+#define MouseWheelMask (1L << 28)
+
+#define ActivateMask (1L << 29)
+#define VirtualEventMask (1L << 30)
+#define TK_LASTEVENT (LASTEvent + 4)
+
+
+/*
+ * A virtual event shares most of its fields with the XKeyEvent and
+ * XButtonEvent structures. 99% of the time a virtual event will be
+ * an abstraction of a key or button event, so this structure provides
+ * the most information to the user. The only difference is the changing
+ * of the detail field for a virtual event so that it holds the name of the
+ * virtual event being triggered.
+ */
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* True if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event; /* Window on which event was requested. */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ unsigned int state; /* key or button mask */
+ Tk_Uid name; /* Name of virtual event. */
+ Bool same_screen; /* same screen flag */
+} XVirtualEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* True if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* Window in which event occurred. */
+} XActivateDeactivateEvent;
+typedef XActivateDeactivateEvent XActivateEvent;
+typedef XActivateDeactivateEvent XDeactivateEvent;
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Macros for querying Tk_Window structures. See the
+ * manual entries for documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+#define Tk_Display(tkwin) (((Tk_FakeWin *) (tkwin))->display)
+#define Tk_ScreenNumber(tkwin) (((Tk_FakeWin *) (tkwin))->screenNum)
+#define Tk_Screen(tkwin) (ScreenOfDisplay(Tk_Display(tkwin), \
+ Tk_ScreenNumber(tkwin)))
+#define Tk_Depth(tkwin) (((Tk_FakeWin *) (tkwin))->depth)
+#define Tk_Visual(tkwin) (((Tk_FakeWin *) (tkwin))->visual)
+#define Tk_WindowId(tkwin) (((Tk_FakeWin *) (tkwin))->window)
+#define Tk_PathName(tkwin) (((Tk_FakeWin *) (tkwin))->pathName)
+#define Tk_Name(tkwin) (((Tk_FakeWin *) (tkwin))->nameUid)
+#define Tk_Class(tkwin) (((Tk_FakeWin *) (tkwin))->classUid)
+#define Tk_X(tkwin) (((Tk_FakeWin *) (tkwin))->changes.x)
+#define Tk_Y(tkwin) (((Tk_FakeWin *) (tkwin))->changes.y)
+#define Tk_Width(tkwin) (((Tk_FakeWin *) (tkwin))->changes.width)
+#define Tk_Height(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->changes.height)
+#define Tk_Changes(tkwin) (&((Tk_FakeWin *) (tkwin))->changes)
+#define Tk_Attributes(tkwin) (&((Tk_FakeWin *) (tkwin))->atts)
+#define Tk_IsEmbedded(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->flags & TK_EMBEDDED)
+#define Tk_IsContainer(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->flags & TK_CONTAINER)
+#define Tk_IsMapped(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->flags & TK_MAPPED)
+#define Tk_IsTopLevel(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->flags & TK_TOP_LEVEL)
+#define Tk_HasWrapper(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->flags & TK_HAS_WRAPPER)
+#define Tk_WinManaged(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->flags & TK_WIN_MANAGED)
+#define Tk_TopWinHierarchy(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->flags & TK_TOP_HIERARCHY)
+#define Tk_ReqWidth(tkwin) (((Tk_FakeWin *) (tkwin))->reqWidth)
+#define Tk_ReqHeight(tkwin) (((Tk_FakeWin *) (tkwin))->reqHeight)
+/* Tk_InternalBorderWidth is deprecated */
+#define Tk_InternalBorderWidth(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->internalBorderLeft)
+#define Tk_InternalBorderLeft(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->internalBorderLeft)
+#define Tk_InternalBorderRight(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->internalBorderRight)
+#define Tk_InternalBorderTop(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->internalBorderTop)
+#define Tk_InternalBorderBottom(tkwin) \
+ (((Tk_FakeWin *) (tkwin))->internalBorderBottom)
+#define Tk_MinReqWidth(tkwin) (((Tk_FakeWin *) (tkwin))->minReqWidth)
+#define Tk_MinReqHeight(tkwin) (((Tk_FakeWin *) (tkwin))->minReqHeight)
+#define Tk_Parent(tkwin) (((Tk_FakeWin *) (tkwin))->parentPtr)
+#define Tk_Colormap(tkwin) (((Tk_FakeWin *) (tkwin))->atts.colormap)
+
+/*
+ * The structure below is needed by the macros above so that they can
+ * access the fields of a Tk_Window. The fields not needed by the macros
+ * are declared as "dummyX". The structure has its own type in order to
+ * prevent applications from accessing Tk_Window fields except using
+ * official macros. WARNING!! The structure definition must be kept
+ * consistent with the TkWindow structure in tkInt.h. If you change one,
+ * then change the other. See the declaration in tkInt.h for
+ * documentation on what the fields are used for internally.
+ */
+
+typedef struct Tk_FakeWin {
+ Display *display;
+ char *dummy1; /* dispPtr */
+ int screenNum;
+ Visual *visual;
+ int depth;
+ Window window;
+ char *dummy2; /* childList */
+ char *dummy3; /* lastChildPtr */
+ Tk_Window parentPtr; /* parentPtr */
+ char *dummy4; /* nextPtr */
+ char *dummy5; /* mainPtr */
+ char *pathName;
+ Tk_Uid nameUid;
+ Tk_Uid classUid;
+ XWindowChanges changes;
+ unsigned int dummy6; /* dirtyChanges */
+ XSetWindowAttributes atts;
+ unsigned long dummy7; /* dirtyAtts */
+ unsigned int flags;
+ char *dummy8; /* handlerList */
+#ifdef TK_USE_INPUT_METHODS
+ XIC dummy9; /* inputContext */
+#endif /* TK_USE_INPUT_METHODS */
+ ClientData *dummy10; /* tagPtr */
+ int dummy11; /* numTags */
+ int dummy12; /* optionLevel */
+ char *dummy13; /* selHandlerList */
+ char *dummy14; /* geomMgrPtr */
+ ClientData dummy15; /* geomData */
+ int reqWidth, reqHeight;
+ int internalBorderLeft;
+ char *dummy16; /* wmInfoPtr */
+ char *dummy17; /* classProcPtr */
+ ClientData dummy18; /* instanceData */
+ char *dummy19; /* privatePtr */
+ int internalBorderRight;
+ int internalBorderTop;
+ int internalBorderBottom;
+ int minReqWidth;
+ int minReqHeight;
+} Tk_FakeWin;
+
+/*
+ * Flag values for TkWindow (and Tk_FakeWin) structures are:
+ *
+ * TK_MAPPED: 1 means window is currently mapped,
+ * 0 means unmapped.
+ * TK_TOP_LEVEL: 1 means this is a top-level widget.
+ * TK_ALREADY_DEAD: 1 means the window is in the process of
+ * being destroyed already.
+ * TK_NEED_CONFIG_NOTIFY: 1 means that the window has been reconfigured
+ * before it was made to exist. At the time of
+ * making it exist a ConfigureNotify event needs
+ * to be generated.
+ * TK_GRAB_FLAG: Used to manage grabs. See tkGrab.c for
+ * details.
+ * TK_CHECKED_IC: 1 means we've already tried to get an input
+ * context for this window; if the ic field
+ * is NULL it means that there isn't a context
+ * for the field.
+ * TK_DONT_DESTROY_WINDOW: 1 means that Tk_DestroyWindow should not
+ * invoke XDestroyWindow to destroy this widget's
+ * X window. The flag is set when the window
+ * has already been destroyed elsewhere (e.g.
+ * by another application) or when it will be
+ * destroyed later (e.g. by destroying its
+ * parent).
+ * TK_WM_COLORMAP_WINDOW: 1 means that this window has at some time
+ * appeared in the WM_COLORMAP_WINDOWS property
+ * for its toplevel, so we have to remove it
+ * from that property if the window is
+ * deleted and the toplevel isn't.
+ * TK_EMBEDDED: 1 means that this window (which must be a
+ * toplevel) is not a free-standing window but
+ * rather is embedded in some other application.
+ * TK_CONTAINER: 1 means that this window is a container, and
+ * that some other application (either in
+ * this process or elsewhere) may be
+ * embedding itself inside the window.
+ * TK_BOTH_HALVES: 1 means that this window is used for
+ * application embedding (either as
+ * container or embedded application), and
+ * both the containing and embedded halves
+ * are associated with windows in this
+ * particular process.
+ * TK_DEFER_MODAL: 1 means that this window has deferred a modal
+ * loop until all of the bindings for the current
+ * event have been invoked.
+ * TK_WRAPPER: 1 means that this window is the extra
+ * wrapper window created around a toplevel
+ * to hold the menubar under Unix. See
+ * tkUnixWm.c for more information.
+ * TK_REPARENTED: 1 means that this window has been reparented
+ * so that as far as the window system is
+ * concerned it isn't a child of its Tk
+ * parent. Initially this is used only for
+ * special Unix menubar windows.
+ * TK_ANONYMOUS_WINDOW: 1 means that this window has no name, and is
+ * thus not accessible from Tk.
+ * TK_HAS_WRAPPER 1 means that this window has a wrapper window
+ * TK_WIN_MANAGED 1 means that this window is a child of the
+ * root window, and is managed by the window
+ * manager.
+ * TK_TOP_HIERARCHY 1 means this window is at the top of a
+ * physical window hierarchy within this
+ * process, i.e. the window's parent
+ * either doesn't exist or is not owned by
+ * this Tk application.
+ * TK_PROP_PROPCHANGE 1 means that PropertyNotify events in
+ * this window's children should propagate
+ * up to this window.
+ */
+
+
+#define TK_MAPPED 1
+#define TK_TOP_LEVEL 2
+#define TK_ALREADY_DEAD 4
+#define TK_NEED_CONFIG_NOTIFY 8
+#define TK_GRAB_FLAG 0x10
+#define TK_CHECKED_IC 0x20
+#define TK_DONT_DESTROY_WINDOW 0x40
+#define TK_WM_COLORMAP_WINDOW 0x80
+#define TK_EMBEDDED 0x100
+#define TK_CONTAINER 0x200
+#define TK_BOTH_HALVES 0x400
+#define TK_DEFER_MODAL 0x800
+#define TK_WRAPPER 0x1000
+#define TK_REPARENTED 0x2000
+#define TK_ANONYMOUS_WINDOW 0x4000
+#define TK_HAS_WRAPPER 0x8000
+#define TK_WIN_MANAGED 0x10000
+#define TK_TOP_HIERARCHY 0x20000
+#define TK_PROP_PROPCHANGE 0x40000
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Procedure prototypes and structures used for defining new canvas
+ * items:
+ *
+ *--------------------------------------------------------------
+ */
+
+typedef enum {
+ TK_STATE_NULL = -1, TK_STATE_ACTIVE, TK_STATE_DISABLED,
+ TK_STATE_NORMAL, TK_STATE_HIDDEN
+} Tk_State;
+
+typedef struct Tk_SmoothMethod {
+ char *name;
+ int (*coordProc) _ANSI_ARGS_((Tk_Canvas canvas,
+ double *pointPtr, int numPoints, int numSteps,
+ XPoint xPoints[], double dblPoints[]));
+ void (*postscriptProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, double *coordPtr,
+ int numPoints, int numSteps));
+} Tk_SmoothMethod;
+
+/*
+ * For each item in a canvas widget there exists one record with
+ * the following structure. Each actual item is represented by
+ * a record with the following stuff at its beginning, plus additional
+ * type-specific stuff after that.
+ */
+
+#define TK_TAG_SPACE 3
+
+typedef struct Tk_Item {
+ int id; /* Unique identifier for this item
+ * (also serves as first tag for
+ * item). */
+ struct Tk_Item *nextPtr; /* Next in display list of all
+ * items in this canvas. Later items
+ * in list are drawn on top of earlier
+ * ones. */
+ Tk_Uid staticTagSpace[TK_TAG_SPACE];/* Built-in space for limited # of
+ * tags. */
+ Tk_Uid *tagPtr; /* Pointer to array of tags. Usually
+ * points to staticTagSpace, but
+ * may point to malloc-ed space if
+ * there are lots of tags. */
+ int tagSpace; /* Total amount of tag space available
+ * at tagPtr. */
+ int numTags; /* Number of tag slots actually used
+ * at *tagPtr. */
+ struct Tk_ItemType *typePtr; /* Table of procedures that implement
+ * this type of item. */
+ int x1, y1, x2, y2; /* Bounding box for item, in integer
+ * canvas units. Set by item-specific
+ * code and guaranteed to contain every
+ * pixel drawn in item. Item area
+ * includes x1 and y1 but not x2
+ * and y2. */
+ struct Tk_Item *prevPtr; /* Previous in display list of all
+ * items in this canvas. Later items
+ * in list are drawn just below earlier
+ * ones. */
+ Tk_State state; /* state of item */
+ LangCallback *updateCmd; /* for "-updatecommand" option */
+ int redraw_flags; /* some flags used in the canvas */
+ struct Tk_Item *group; /* group item managing this one */
+
+ /*
+ *------------------------------------------------------------------
+ * Starting here is additional type-specific stuff; see the
+ * declarations for individual types to see what is part of
+ * each type. The actual space below is determined by the
+ * "itemInfoSize" of the type's Tk_ItemType record.
+ *------------------------------------------------------------------
+ */
+} Tk_Item;
+
+/*
+ * Flag bits for canvases (redraw_flags):
+ *
+ * TK_ITEM_STATE_DEPENDANT - 1 means that object needs to be
+ * redrawn if the canvas state changes.
+ * TK_ITEM_DONT_REDRAW - 1 means that the object redraw is already
+ * been prepared, so the general canvas code
+ * doesn't need to do that any more.
+ */
+
+#define TK_ITEM_STATE_DEPENDANT 1
+#define TK_ITEM_DONT_REDRAW 2
+
+/*
+ * Structures used for implementing visitors.
+ */
+
+typedef ClientData Tk_VisitorStartProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, int argc, Tcl_Obj *CONST *objv));
+typedef int Tk_VisitorItemProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, ClientData clientData,
+ Tk_Item *itemPtr));
+typedef int Tk_VisitorEndProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, ClientData clientData));
+
+typedef struct Tk_VisitorType {
+ char *name;
+ int typeSize; /* should be sizeof(Tk_VisitorType) */
+ int flags; /* If this flag is non-zero then
+ * the item needs to be redrawn. */
+ Tk_VisitorStartProc *startProc;
+ Tk_VisitorEndProc *endProc;
+ Tk_VisitorItemProc *visitArc; /* The Arc visitor procedure. */
+ Tk_VisitorItemProc *visitBitmap; /* The Bitmap visitor procedure. */
+ Tk_VisitorItemProc *visitImage; /* The Image visitor procedure. */
+ Tk_VisitorItemProc *visitLine; /* The Line visitor procedure. */
+ Tk_VisitorItemProc *visitOval; /* The Oval visitor procedure. */
+ Tk_VisitorItemProc *visitPolygon; /* The Polygon visitor procedure. */
+ Tk_VisitorItemProc *visitRectangle; /* The Rectangle visitor procedure. */
+ Tk_VisitorItemProc *visitText; /* The Text visitor procedure. */
+ Tk_VisitorItemProc *visitWindow; /* The Window visitor procedure. */
+ Tk_VisitorItemProc *visitSticker; /* The Sticker visitor procedure.
+ * from tkSticker*/
+ Tk_VisitorItemProc *visitViewport; /* The Viewport visitor procedure.
+ * from TkSM */
+ Tk_VisitorItemProc *visitBarchart; /* The Barchart visitor procedure.
+ * from Scotty */
+ Tk_VisitorItemProc *visitStripchart;/* The Stripchart visitor procedure.
+ * from Scotty */
+
+ /* ptk extensions */
+ Tk_VisitorItemProc *visitGroup; /* The Group visitor procedure. */
+ Tk_VisitorItemProc *visitGrid; /* The Grid visitor procedure. */
+
+ /*
+ *------------------------------------------------------------------
+ * Starting here is additional item-extension stuff;
+ * you can add extra item types after this plus other information.
+ *------------------------------------------------------------------
+ */
+} Tk_VisitorType;
+
+/*
+ * Records of the following type are used to describe a type of
+ * item (e.g. lines, circles, etc.) that can form part of a
+ * canvas widget.
+ */
+
+#ifdef USE_OLD_CANVAS
+typedef int Tk_ItemCreateProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, int argc,
+ Tcl_Obj *CONST *objv));
+typedef int Tk_ItemConfigureProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, int argc,
+ Tcl_Obj *CONST *objv, int flags));
+typedef int Tk_ItemCoordProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, int argc,
+ Tcl_Obj *CONST *objv));
+#else
+typedef int Tk_ItemCreateProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, int argc,
+ Tcl_Obj *CONST objv[]));
+typedef int Tk_ItemConfigureProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, int argc,
+ CONST84 Tcl_Obj *CONST objv[], int flags));
+typedef int Tk_ItemCoordProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, int argc,
+ Tcl_Obj *CONST objv[]));
+#endif
+typedef void Tk_ItemDeleteProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, Display *display));
+typedef void Tk_ItemDisplayProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, Display *display, Drawable dst,
+ int x, int y, int width, int height));
+typedef double Tk_ItemPointProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, double *pointPtr));
+typedef int Tk_ItemAreaProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, double *rectPtr));
+typedef int Tk_ItemPostscriptProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, int prepass));
+typedef void Tk_ItemScaleProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, double originX, double originY,
+ double scaleX, double scaleY));
+typedef void Tk_ItemTranslateProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, double deltaX, double deltaY));
+typedef int Tk_ItemIndexProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Item *itemPtr, Tcl_Obj *indexString,
+ int *indexPtr));
+typedef void Tk_ItemCursorProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, int index));
+typedef int Tk_ItemSelectionProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, int offset, char *buffer,
+ int maxBytes));
+typedef void Tk_ItemInsertProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, int beforeThis, Tcl_Obj *string));
+typedef void Tk_ItemDCharsProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, int first, int last));
+typedef void Tk_ItemBboxProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr));
+typedef int Tk_ItemGetCoordProc _ANSI_ARGS_((Tk_Item *itemPtr,
+ double **coordsPtr, Tcl_FreeProc *freeProc));
+typedef int Tk_ItemSetCoordProc _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *itemPtr, int num, double *coords));
+
+/*
+ * Some flag values that can be used in the "flags" field in Tk_ItemType.
+ */
+
+#define TK_ITEM_ALWAYS_REDRAW 1
+#define TK_ITEM_VISITOR_SUPPORT 2
+
+/*
+ * Structures used for implementing visitors.
+ */
+#ifndef __NO_OLD_CONFIG
+
+typedef struct Tk_ItemType {
+ char *name; /* The name of this type of item, such
+ * as "line". */
+ int itemSize; /* Total amount of space needed for
+ * item's record. */
+ Tk_ItemCreateProc *createProc; /* Procedure to create a new item of
+ * this type. */
+ Tk_ConfigSpec *configSpecs; /* Pointer to array of configuration
+ * specs for this type. Used for
+ * returning configuration info. */
+ Tk_ItemConfigureProc *configProc; /* Procedure to call to change
+ * configuration options. */
+ Tk_ItemCoordProc *coordProc; /* Procedure to call to get and set
+ * the item's coordinates. */
+ Tk_ItemDeleteProc *deleteProc; /* Procedure to delete existing item of
+ * this type. */
+ Tk_ItemDisplayProc *displayProc; /* Procedure to display items of
+ * this type. */
+ int alwaysRedraw; /* Non-zero means displayProc should
+ * be called even when the item has
+ * been moved off-screen. */
+ Tk_ItemPointProc *pointProc; /* Computes distance from item to
+ * a given point. */
+ Tk_ItemAreaProc *areaProc; /* Computes whether item is inside,
+ * outside, or overlapping an area. */
+ Tk_ItemPostscriptProc *postscriptProc;
+ /* Procedure to write a Postscript
+ * description for items of this
+ * type. */
+ Tk_ItemScaleProc *scaleProc; /* Procedure to rescale items of
+ * this type. */
+ Tk_ItemTranslateProc *translateProc;/* Procedure to translate items of
+ * this type. */
+ Tk_ItemIndexProc *indexProc; /* Procedure to determine index of
+ * indicated character. NULL if
+ * item doesn't support indexing. */
+ Tk_ItemCursorProc *icursorProc; /* Procedure to set insert cursor pos.
+ * to just before a given position. */
+ Tk_ItemSelectionProc *selectionProc;/* Procedure to return selection (in
+ * STRING format) when it is in this
+ * item. */
+ Tk_ItemInsertProc *insertProc; /* Procedure to insert something into
+ * an item. */
+ Tk_ItemDCharsProc *dCharsProc; /* Procedure to delete characters
+ * from an item. */
+ struct Tk_ItemType *nextPtr; /* Used to link types together into
+ * a list. */
+ Tk_ItemBboxProc *bboxProc; /* Reserved for future extension. */
+ int reserved2; /* Carefully compatible with */
+ char *reserved3; /* Jan Nijtmans dash patch */
+ char *reserved4;
+} Tk_ItemType;
+
+#endif
+
+/*
+ * The following structure provides information about the selection and
+ * the insertion cursor. It is needed by only a few items, such as
+ * those that display text. It is shared by the generic canvas code
+ * and the item-specific code, but most of the fields should be written
+ * only by the canvas generic code.
+ */
+
+typedef struct Tk_CanvasTextInfo {
+ Tk_3DBorder selBorder; /* Border and background for selected
+ * characters. Read-only to items.*/
+ int selBorderWidth; /* Width of border around selection.
+ * Read-only to items. */
+ XColor *selFgColorPtr; /* Foreground color for selected text.
+ * Read-only to items. */
+ Tk_Item *selItemPtr; /* Pointer to selected item. NULL means
+ * selection isn't in this canvas.
+ * Writable by items. */
+ int selectFirst; /* Character index of first selected
+ * character. Writable by items. */
+ int selectLast; /* Character index of last selected
+ * character. Writable by items. */
+ Tk_Item *anchorItemPtr; /* Item corresponding to "selectAnchor":
+ * not necessarily selItemPtr. Read-only
+ * to items. */
+ int selectAnchor; /* Character index of fixed end of
+ * selection (i.e. "select to" operation will
+ * use this as one end of the selection).
+ * Writable by items. */
+ Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion
+ * cursor. Read-only to items. */
+ int insertWidth; /* Total width of insertion cursor. Read-only
+ * to items. */
+ int insertBorderWidth; /* Width of 3-D border around insert cursor.
+ * Read-only to items. */
+ Tk_Item *focusItemPtr; /* Item that currently has the input focus,
+ * or NULL if no such item. Read-only to
+ * items. */
+ int gotFocus; /* Non-zero means that the canvas widget has
+ * the input focus. Read-only to items.*/
+ int cursorOn; /* Non-zero means that an insertion cursor
+ * should be displayed in focusItemPtr.
+ * Read-only to items.*/
+} Tk_CanvasTextInfo;
+
+/*
+ * Structures used for Dashing and Outline.
+ */
+
+typedef struct Tk_Dash {
+ int number;
+ union {
+ char *pt;
+ char array[sizeof(char *)];
+ } pattern;
+} Tk_Dash;
+
+typedef struct Tk_TSOffset {
+ int flags; /* flags; see below for possible values */
+ int xoffset; /* x offset */
+ int yoffset; /* y offset */
+} Tk_TSOffset;
+
+/*
+ * Bit fields in Tk_Offset->flags:
+ */
+
+#define TK_OFFSET_INDEX 1
+#define TK_OFFSET_RELATIVE 2
+#define TK_OFFSET_LEFT 4
+#define TK_OFFSET_CENTER 8
+#define TK_OFFSET_RIGHT 16
+#define TK_OFFSET_TOP 32
+#define TK_OFFSET_MIDDLE 64
+#define TK_OFFSET_BOTTOM 128
+
+typedef struct Tk_Tile_ *Tk_Tile; /* Opaque type for tiles */
+
+typedef struct Tk_Outline {
+ GC gc; /* Graphics context. */
+ double width; /* Width of outline. */
+ double activeWidth; /* Width of outline. */
+ double disabledWidth; /* Width of outline. */
+ int offset; /* Dash offset */
+ Tk_Dash dash; /* Dash pattern */
+ Tk_Dash activeDash; /* Dash pattern if state is active*/
+ Tk_Dash disabledDash; /* Dash pattern if state is disabled*/
+ VOID *reserved1; /* reserved for future expansion */
+ VOID *reserved2;
+ VOID *reserved3;
+ Tk_TSOffset tsoffset; /* stipple offset for outline*/
+ XColor *color; /* Outline color. */
+ XColor *activeColor; /* Outline color if state is active. */
+ XColor *disabledColor; /* Outline color if state is disabled. */
+ Pixmap stipple; /* Outline Stipple pattern. */
+ Pixmap activeStipple; /* Outline Stipple pattern if state is active. */
+ Pixmap disabledStipple; /* Outline Stipple pattern if state is disabled. */
+ Tk_Tile tile;
+} Tk_Outline;
+
+
+/*
+ * Some functions handy for Dashing and Outlines (in tkCanvUtil.c).
+ */
+
+EXTERN void Tk_CreateOutline _ANSI_ARGS_((Tk_Outline *outline));
+EXTERN void Tk_DeleteOutline _ANSI_ARGS_((Display *display,
+ Tk_Outline *outline));
+EXTERN int Tk_ConfigOutlineGC _ANSI_ARGS_((XGCValues *gcValues,
+ Tk_Canvas canvas ,Tk_Item *item,
+ Tk_Outline *outline));
+EXTERN int Tk_ChangeOutlineGC _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *item, Tk_Outline *outline));
+EXTERN int Tk_ResetOutlineGC _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *item, Tk_Outline *outline));
+EXTERN int Tk_CanvasPsOutline _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item *item, Tk_Outline *outline));
+
+/*
+ * Some functions handy for Tiling and Stipple/Tile offset.
+ */
+
+typedef void (Tk_TileChangedProc) _ANSI_ARGS_((ClientData clientData,
+ Tk_Tile tile));
+EXTERN Tk_Tile Tk_GetTile _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin,
+ CONST char *imageName));
+EXTERN void Tk_FreeTile _ANSI_ARGS_((Tk_Tile tile));
+EXTERN CONST char * Tk_NameOfTile _ANSI_ARGS_((Tk_Tile tile));
+EXTERN void Tk_SetTileChangedProc _ANSI_ARGS_((Tk_Tile tile,
+ Tk_TileChangedProc * changeProc, ClientData clientData));
+EXTERN Pixmap Tk_PixmapOfTile _ANSI_ARGS_((Tk_Tile tile));
+EXTERN int Tk_PixelParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj *Tk_PixelPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN void Tk_SizeOfTile _ANSI_ARGS_((Tk_Tile tile, int *widthPtr,
+ int *heightPtr));
+EXTERN int Tk_TileParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj *Tk_TilePrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int Tk_OffsetParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj *Tk_OffsetPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int Tk_OrientParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj *Tk_OrientPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Procedure prototypes and structures used for managing images:
+ *
+ *--------------------------------------------------------------
+ */
+
+typedef struct Tk_ImageType Tk_ImageType;
+#ifdef USE_OLD_IMAGE
+typedef int (Tk_ImageCreateProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, int argc, Tcl_Obj *CONST *objv, Tk_ImageType *typePtr,
+ Tk_ImageMaster master, ClientData *masterDataPtr));
+#else
+typedef int (Tk_ImageCreateProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, int objc, Tcl_Obj *CONST objv[], Tk_ImageType *typePtr,
+ Tk_ImageMaster master, ClientData *masterDataPtr));
+#endif
+typedef ClientData (Tk_ImageGetProc) _ANSI_ARGS_((Tk_Window tkwin,
+ ClientData masterData));
+typedef void (Tk_ImageDisplayProc) _ANSI_ARGS_((ClientData instanceData,
+ Display *display, Drawable drawable, int imageX, int imageY,
+ int width, int height, int drawableX, int drawableY));
+typedef void (Tk_ImageFreeProc) _ANSI_ARGS_((ClientData instanceData,
+ Display *display));
+typedef void (Tk_ImageDeleteProc) _ANSI_ARGS_((ClientData masterData));
+typedef void (Tk_ImageChangedProc) _ANSI_ARGS_((ClientData clientData,
+ int x, int y, int width, int height, int imageWidth,
+ int imageHeight));
+typedef int (Tk_ImagePostscriptProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin, Tk_PostscriptInfo psinfo,
+ int x, int y, int width, int height, int prepass));
+
+/*
+ * The following structure represents a particular type of image
+ * (bitmap, xpm image, etc.). It provides information common to
+ * all images of that type, such as the type name and a collection
+ * of procedures in the image manager that respond to various
+ * events. Each image manager is represented by one of these
+ * structures.
+ */
+
+struct Tk_ImageType {
+ char *name; /* Name of image type. */
+ Tk_ImageCreateProc *createProc;
+ /* Procedure to call to create a new image
+ * of this type. */
+ Tk_ImageGetProc *getProc; /* Procedure to call the first time
+ * Tk_GetImage is called in a new way
+ * (new visual or screen). */
+ Tk_ImageDisplayProc *displayProc;
+ /* Call to draw image, in response to
+ * Tk_RedrawImage calls. */
+ Tk_ImageFreeProc *freeProc; /* Procedure to call whenever Tk_FreeImage
+ * is called to release an instance of an
+ * image. */
+ Tk_ImageDeleteProc *deleteProc;
+ /* Procedure to call to delete image. It
+ * will not be called until after freeProc
+ * has been called for each instance of the
+ * image. */
+ Tk_ImagePostscriptProc *postscriptProc;
+ /* Procedure to call to produce postscript
+ * output for the image. */
+ struct Tk_ImageType *nextPtr;
+ /* Next in list of all image types currently
+ * known. Filled in by Tk, not by image
+ * manager. */
+ char *reserved; /* reserved for future expansion */
+};
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Additional definitions used to manage images of type "photo".
+ *
+ *--------------------------------------------------------------
+ */
+
+/*
+ * The following type is used to identify a particular photo image
+ * to be manipulated:
+ */
+
+typedef void *Tk_PhotoHandle;
+
+/*
+ * The following structure describes a block of pixels in memory:
+ */
+
+typedef struct Tk_PhotoImageBlock {
+ unsigned char *pixelPtr; /* Pointer to the first pixel. */
+ int width; /* Width of block, in pixels. */
+ int height; /* Height of block, in pixels. */
+ int pitch; /* Address difference between corresponding
+ * pixels in successive lines. */
+ int pixelSize; /* Address difference between successive
+ * pixels in the same line. */
+ int offset[4]; /* Address differences between the red, green
+ * and blue components of the pixel and the
+ * pixel as a whole. */
+ int reserved; /* Reserved for extensions (dash patch) */
+} Tk_PhotoImageBlock;
+
+/*
+ * The following values control how blocks are combined into photo
+ * images when the alpha component of a pixel is not 255, a.k.a. the
+ * compositing rule.
+ */
+
+#define TK_PHOTO_COMPOSITE_OVERLAY 0
+#define TK_PHOTO_COMPOSITE_SET 1
+
+/*
+ * Procedure prototypes and structures used in reading and
+ * writing photo images:
+ */
+
+typedef struct Tk_PhotoImageFormat Tk_PhotoImageFormat;
+#ifdef USE_OLD_IMAGE
+typedef int (Tk_ImageFileMatchProc) _ANSI_ARGS_((Tcl_Channel chan,
+ char *fileName, char *formatString, int *widthPtr, int *heightPtr));
+typedef int (Tk_ImageStringMatchProc) _ANSI_ARGS_((char *string,
+ char *formatString, int *widthPtr, int *heightPtr));
+typedef int (Tk_ImageFileReadProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan, char *fileName, char *formatString,
+ Tk_PhotoHandle imageHandle, int destX, int destY,
+ int width, int height, int srcX, int srcY));
+typedef int (Tk_ImageStringReadProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *formatString, Tk_PhotoHandle imageHandle,
+ int destX, int destY, int width, int height, int srcX, int srcY));
+typedef int (Tk_ImageFileWriteProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ char *fileName, char *formatString, Tk_PhotoImageBlock *blockPtr));
+typedef int (Tk_ImageStringWriteProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_DString *dataPtr, char *formatString,
+ Tk_PhotoImageBlock *blockPtr));
+#else
+typedef int (Tk_ImageFileMatchProc) _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_Obj *fileName, Tcl_Obj *format, int *widthPtr,
+ int *heightPtr,Tcl_Interp *interp));
+typedef int (Tk_ImageStringMatchProc) _ANSI_ARGS_((Tcl_Obj *dataObj,
+ Tcl_Obj *format, int *widthPtr, int *heightPt, Tcl_Interp *interp));
+typedef int (Tk_ImageFileReadProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan, Tcl_Obj *fileName, Tcl_Obj *format,
+ Tk_PhotoHandle imageHandle, int destX, int destY,
+ int width, int height, int srcX, int srcY));
+typedef int (Tk_ImageStringReadProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *dataObj, Tcl_Obj *format, Tk_PhotoHandle imageHandle,
+ int destX, int destY, int width, int height, int srcX, int srcY));
+typedef int (Tk_ImageFileWriteProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ char *fileName, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr));
+typedef int (Tk_ImageStringWriteProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr));
+#endif
+
+/*
+ * The following structure represents a particular file format for
+ * storing images (e.g., PPM, GIF, JPEG, etc.). It provides information
+ * to allow image files of that format to be recognized and read into
+ * a photo image.
+ */
+
+struct Tk_PhotoImageFormat {
+ char *name; /* Name of image file format */
+ Tk_ImageFileMatchProc *fileMatchProc;
+ /* Procedure to call to determine whether
+ * an image file matches this format. */
+ Tk_ImageStringMatchProc *stringMatchProc;
+ /* Procedure to call to determine whether
+ * the data in a string matches this format. */
+ Tk_ImageFileReadProc *fileReadProc;
+ /* Procedure to call to read data from
+ * an image file into a photo image. */
+ Tk_ImageStringReadProc *stringReadProc;
+ /* Procedure to call to read data from
+ * a string into a photo image. */
+ Tk_ImageFileWriteProc *fileWriteProc;
+ /* Procedure to call to write data from
+ * a photo image to a file. */
+ Tk_ImageStringWriteProc *stringWriteProc;
+ /* Procedure to call to obtain a string
+ * representation of the data in a photo
+ * image.*/
+ struct Tk_PhotoImageFormat *nextPtr;
+ /* Next in list of all photo image formats
+ * currently known. Filled in by Tk, not
+ * by image format handler. */
+};
+
+EXTERN void Tk_CreateOldImageType _ANSI_ARGS_((
+ Tk_ImageType *typePtr));
+EXTERN void Tk_CreateOldPhotoImageFormat _ANSI_ARGS_((
+ Tk_PhotoImageFormat *formatPtr));
+
+#if !defined(USE_TK_STUBS) && defined(USE_OLD_IMAGE)
+#define Tk_CreateImageType Tk_CreateOldImageType
+#define Tk_CreatePhotoImageFormat Tk_CreateOldPhotoImageFormat
+#endif
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Procedure prototypes and structures used for managing styles:
+ *
+ *--------------------------------------------------------------
+ */
+
+/*
+ * Style support version tag.
+ */
+#define TK_STYLE_VERSION_1 0x1
+#define TK_STYLE_VERSION TK_STYLE_VERSION_1
+
+/*
+ * The following structures and prototypes are used as static templates to
+ * declare widget elements.
+ */
+
+typedef void (Tk_GetElementSizeProc) _ANSI_ARGS_((ClientData clientData,
+ char *recordPtr, CONST Tk_OptionSpec **optionsPtr, Tk_Window tkwin,
+ int width, int height, int inner, int *widthPtr, int *heightPtr));
+typedef void (Tk_GetElementBoxProc) _ANSI_ARGS_((ClientData clientData,
+ char *recordPtr, CONST Tk_OptionSpec **optionsPtr, Tk_Window tkwin,
+ int x, int y, int width, int height, int inner, int *xPtr, int *yPtr,
+ int *widthPtr, int *heightPtr));
+typedef int (Tk_GetElementBorderWidthProc) _ANSI_ARGS_((ClientData clientData,
+ char *recordPtr, CONST Tk_OptionSpec **optionsPtr, Tk_Window tkwin));
+typedef void (Tk_DrawElementProc) _ANSI_ARGS_((ClientData clientData,
+ char *recordPtr, CONST Tk_OptionSpec **optionsPtr, Tk_Window tkwin,
+ Drawable d, int x, int y, int width, int height, int state));
+
+typedef struct Tk_ElementOptionSpec {
+ char *name; /* Name of the required option. */
+ Tk_OptionType type; /* Accepted option type. TK_OPTION_END means
+ * any. */
+} Tk_ElementOptionSpec;
+
+typedef struct Tk_ElementSpec {
+ int version; /* Version of the style support. */
+ char *name; /* Name of element. */
+ Tk_ElementOptionSpec *options;
+ /* List of required options. Last one's name
+ * must be NULL. */
+
+ /*
+ * Hooks
+ */
+
+ Tk_GetElementSizeProc *getSize;
+ /* Compute the external (resp. internal) size of
+ * the element from its desired internal (resp.
+ * external) size. */
+ Tk_GetElementBoxProc *getBox;
+ /* Compute the inscribed or bounding boxes
+ * within a given area. */
+ Tk_GetElementBorderWidthProc *getBorderWidth;
+ /* Return the element's internal border width.
+ * Mostly useful for widgets. */
+ Tk_DrawElementProc *draw; /* Draw the element in the given bounding box.*/
+} Tk_ElementSpec;
+
+/*
+ * Element state flags. Can be OR'ed.
+ */
+
+#define TK_ELEMENT_STATE_ACTIVE 1<<0
+#define TK_ELEMENT_STATE_DISABLED 1<<1
+#define TK_ELEMENT_STATE_FOCUS 1<<2
+#define TK_ELEMENT_STATE_PRESSED 1<<3
+
+/*
+ *--------------------------------------------------------------
+ *
+ * The definitions below provide backward compatibility for
+ * functions and types related to event handling that used to
+ * be in Tk but have moved to Tcl.
+ *
+ *--------------------------------------------------------------
+ */
+
+#if 0
+
+#define TK_READABLE TCL_READABLE
+#define TK_WRITABLE TCL_WRITABLE
+#define TK_EXCEPTION TCL_EXCEPTION
+
+#define TK_DONT_WAIT TCL_DONT_WAIT
+#define TK_X_EVENTS TCL_WINDOW_EVENTS
+#define TK_WINDOW_EVENTS TCL_WINDOW_EVENTS
+#define TK_FILE_EVENTS TCL_FILE_EVENTS
+#define TK_TIMER_EVENTS TCL_TIMER_EVENTS
+#define TK_IDLE_EVENTS TCL_IDLE_EVENTS
+#define TK_ALL_EVENTS TCL_ALL_EVENTS
+
+#define Tk_IdleProc Tcl_IdleProc
+#define Tk_FileProc Tcl_FileProc
+#define Tk_TimerProc Tcl_TimerProc
+#define Tk_TimerToken Tcl_TimerToken
+
+#define Tk_BackgroundError Tcl_BackgroundError
+#define Tk_CancelIdleCall Tcl_CancelIdleCall
+#define Tk_CreateFileHandler Tcl_CreateFileHandler
+#define Tk_CreateTimerHandler Tcl_CreateTimerHandler
+#define Tk_DeleteFileHandler Tcl_DeleteFileHandler
+#define Tk_DeleteTimerHandler Tcl_DeleteTimerHandler
+#define Tk_DoOneEvent Tcl_DoOneEvent
+#define Tk_DoWhenIdle Tcl_DoWhenIdle
+#define Tk_Sleep Tcl_Sleep
+
+/* Additional stuff that has moved to Tcl: */
+
+#define Tk_EventuallyFree Tcl_EventuallyFree
+#define Tk_FreeProc Tcl_FreeProc
+#define Tk_Preserve Tcl_Preserve
+#define Tk_Release Tcl_Release
+#define Tk_FileeventCmd Tcl_FileEventCmd
+
+#endif
+
+
+/* Removed Tk_Main, use macro instead */
+#define Tk_Main(argc, argv, proc) \
+ Tk_MainEx(argc, argv, proc, Tcl_CreateInterp())
+
+extern CONST char *Tk_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, char *version, int exact));
+
+#ifndef USE_TK_STUBS
+
+#define Tk_InitStubs(interp, version, exact) \
+ Tcl_PkgRequire(interp, "Tk", version, exact)
+
+#endif
+
+extern void Tk_InitImageArgs _ANSI_ARGS_((Tcl_Interp *interp, int argc, char ***objv));
+
+#if !defined(USE_TK_STUBS) || !defined(USE_OLD_IMAGE)
+
+#define Tk_InitImageArgs(interp, argc, argv) /**/
+
+#endif
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Additional procedure types defined by Tk.
+ *
+ *--------------------------------------------------------------
+ */
+
+#define TK_EVENTTYPE_NONE 0
+#define TK_EVENTTYPE_STRING 1
+#define TK_EVENTTYPE_NUMBER 2
+#define TK_EVENTTYPE_WINDOW 3
+#define TK_EVENTTYPE_ATOM 4
+#define TK_EVENTTYPE_DISPLAY 5
+#define TK_EVENTTYPE_DATA 6
+
+typedef int (Tk_ErrorProc) _ANSI_ARGS_((ClientData clientData,
+ XErrorEvent *errEventPtr));
+typedef void (Tk_EventProc) _ANSI_ARGS_((ClientData clientData,
+ XEvent *eventPtr));
+typedef int (Tk_GenericProc) _ANSI_ARGS_((ClientData clientData,
+ XEvent *eventPtr));
+typedef int (Tk_ClientMessageProc) _ANSI_ARGS_((Tk_Window tkwin,
+ XEvent *eventPtr));
+typedef int (Tk_GetSelProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, char *portion));
+typedef int (Tk_GetXSelProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, long *portion, int numValues,
+ int format, Atom type, Tk_Window tkwin));
+typedef void (Tk_LostSelProc) _ANSI_ARGS_((ClientData clientData));
+typedef Tk_RestrictAction (Tk_RestrictProc) _ANSI_ARGS_((
+ ClientData clientData, XEvent *eventPtr));
+typedef int (Tk_SelectionProc) _ANSI_ARGS_((ClientData clientData,
+ int offset, char *buffer, int maxBytes));
+
+typedef int (Tk_XSelectionProc) _ANSI_ARGS_((ClientData clientData,
+ int offset, long *buffer, int maxBytes,
+ Atom type, Tk_Window tkwin));
+
+
+typedef struct {
+ char *name; /* Name of command. */
+ int (*cmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv));
+ /* Command procedure. */
+} Tk_Cmd;
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Platform independant exported procedures and variables.
+ *
+ *--------------------------------------------------------------
+ */
+
+#include "tkDecls.h"
+
+/*
+ * Allow users to say that they don't want to alter their source to
+ * add the extra argument to Tk_PhotoPutBlock(); DO NOT DEFINE THIS
+ * WHEN BUILDING TK.
+ *
+ * This goes after the inclusion of the stubbed-decls so that the
+ * declarations of what is actually there can be correct.
+ */
+
+#ifdef USE_COMPOSITELESS_PHOTO_PUT_BLOCK
+# ifdef Tk_PhotoPutBlock
+# undef Tk_PhotoPutBlock
+# endif
+# define Tk_PhotoPutBlock Tk_PhotoPutBlock_NoComposite
+# ifdef Tk_PhotoPutZoomedBlock
+# undef Tk_PhotoPutZoomedBlock
+# endif
+# define Tk_PhotoPutZoomedBlock Tk_PhotoPutZoomedBlock_NoComposite
+#endif /* USE_COMPOSITELESS_PHOTO_PUT_BLOCK */
+
+/*
+ * Tcl commands exported by Tk:
+ */
+
+EXTERN Tcl_Command Lang_CreateWidget _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window, Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc));
+
+EXTERN Tcl_Command Lang_CreateImage _ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName, Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc,
+ Tk_ImageType *typePtr));
+
+EXTERN void Lang_DeleteWidget _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Command cmd));
+
+EXTERN void Tk_ChangeScreen _ANSI_ARGS_((Tcl_Interp *interp,
+ char *dispName, int screenIndex));
+
+EXTERN Var LangFindVar _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window, CONST char *name));
+
+EXTERN Tcl_Obj * LangWidgetObj _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window));
+EXTERN Tcl_Obj * LangFontObj _ANSI_ARGS_((Tcl_Interp *interp, Tk_Font font, char *name));
+EXTERN Tcl_Obj * LangObjectObj _ANSI_ARGS_((Tcl_Interp *interp, char *));
+
+#define LangWidgetArg(interp,win) LangObjArg(LangWidgetObj(interp,win),__FILE__,__LINE__)
+#define LangFontArg(interp,font,name) LangObjArg(LangFontObj(interp,font,name),__FILE__,__LINE__)
+#define LangObjectArg(interp,name) LangObjArg(LangObjectObj(interp,name),__FILE__,__LINE__)
+
+
+#ifndef NO_EXTERN
+EXTERN void Lang_DeadMainWindow _ANSI_ARGS_((Tcl_Interp *, Tk_Window));
+EXTERN void Lang_NewMainWindow _ANSI_ARGS_((Tcl_Interp *, Tk_Window));
+EXTERN void LangDeadWindow _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window));
+EXTERN void LangClientMessage _ANSI_ARGS_((Tcl_Interp *interp,Tk_Window, XEvent *));
+EXTERN void LangSelectHook _ANSI_ARGS_((CONST char *what, Tk_Window tkwin,
+ Atom selection, Atom target, Atom type));
+#endif
+
+EXTERN int LangEventCallback _ANSI_ARGS_((ClientData, Tcl_Interp *,XEvent *,Tk_Window,KeySym));
+EXTERN int Tk_GetXSelection _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, Atom selection, Atom target,
+ Tk_GetXSelProc *proc, ClientData clientData));
+EXTERN Tk_Window Tk_EventWindow _ANSI_ARGS_((XEvent *eventPtr));
+EXTERN char * Tk_EventInfo _ANSI_ARGS_((int letter, Tk_Window tkwin, XEvent *eventPtr,
+ KeySym keySym, int *numPtr, int *isNum, int *type,
+ int num_size, char *numStorage));
+
+extern void LangCheckDC _ANSI_ARGS_((const char *file, int line));
+
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* RC_INVOKED */
+
+/*
+ * end block for C++
+ */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _TK */
+
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.m
new file mode 100755
index 00000000000..202863eeef7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.m
@@ -0,0 +1,94 @@
+#ifndef _TK_VM
+#define _TK_VM
+#include "tk_f.h"
+#ifndef NO_VTABLES
+#ifndef LangCheckDC
+# define LangCheckDC (*TkVptr->V_LangCheckDC)
+#endif
+
+#ifndef LangEventCallback
+# define LangEventCallback (*TkVptr->V_LangEventCallback)
+#endif
+
+#ifndef LangFindVar
+# define LangFindVar (*TkVptr->V_LangFindVar)
+#endif
+
+#ifndef LangFontObj
+# define LangFontObj (*TkVptr->V_LangFontObj)
+#endif
+
+#ifndef LangObjectObj
+# define LangObjectObj (*TkVptr->V_LangObjectObj)
+#endif
+
+#ifndef LangSelectHook
+# define LangSelectHook (*TkVptr->V_LangSelectHook)
+#endif
+
+#ifndef LangWidgetObj
+# define LangWidgetObj (*TkVptr->V_LangWidgetObj)
+#endif
+
+#ifndef Lang_CreateImage
+# define Lang_CreateImage (*TkVptr->V_Lang_CreateImage)
+#endif
+
+#ifndef Lang_CreateWidget
+# define Lang_CreateWidget (*TkVptr->V_Lang_CreateWidget)
+#endif
+
+#ifndef Lang_DeleteWidget
+# define Lang_DeleteWidget (*TkVptr->V_Lang_DeleteWidget)
+#endif
+
+#ifndef Tk_ChangeScreen
+# define Tk_ChangeScreen (*TkVptr->V_Tk_ChangeScreen)
+#endif
+
+#ifndef Tk_CreateOldImageType
+# define Tk_CreateOldImageType (*TkVptr->V_Tk_CreateOldImageType)
+#endif
+
+#ifndef Tk_EventInfo
+# define Tk_EventInfo (*TkVptr->V_Tk_EventInfo)
+#endif
+
+#ifndef Tk_EventWindow
+# define Tk_EventWindow (*TkVptr->V_Tk_EventWindow)
+#endif
+
+#ifndef Tk_FreeTile
+# define Tk_FreeTile (*TkVptr->V_Tk_FreeTile)
+#endif
+
+#ifndef Tk_GetTile
+# define Tk_GetTile (*TkVptr->V_Tk_GetTile)
+#endif
+
+#ifndef Tk_GetXSelection
+# define Tk_GetXSelection (*TkVptr->V_Tk_GetXSelection)
+#endif
+
+#ifndef Tk_InitImageArgs
+# define Tk_InitImageArgs (*TkVptr->V_Tk_InitImageArgs)
+#endif
+
+#ifndef Tk_NameOfTile
+# define Tk_NameOfTile (*TkVptr->V_Tk_NameOfTile)
+#endif
+
+#ifndef Tk_PixmapOfTile
+# define Tk_PixmapOfTile (*TkVptr->V_Tk_PixmapOfTile)
+#endif
+
+#ifndef Tk_SetTileChangedProc
+# define Tk_SetTileChangedProc (*TkVptr->V_Tk_SetTileChangedProc)
+#endif
+
+#ifndef Tk_SizeOfTile
+# define Tk_SizeOfTile (*TkVptr->V_Tk_SizeOfTile)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TK_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.t
new file mode 100755
index 00000000000..18c40ef81c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk.t
@@ -0,0 +1,151 @@
+#ifdef _TK
+#ifndef LangCheckDC
+#ifndef RC_INVOKED
+VFUNC(void,LangCheckDC,V_LangCheckDC,_ANSI_ARGS_((const char *file, int line)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef LangCheckDC */
+
+#ifndef LangEventCallback
+#ifndef RC_INVOKED
+VFUNC(int,LangEventCallback,V_LangEventCallback,_ANSI_ARGS_((ClientData, Tcl_Interp *,XEvent *,Tk_Window,KeySym)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef LangEventCallback */
+
+#ifndef LangFindVar
+#ifndef RC_INVOKED
+VFUNC(Var,LangFindVar,V_LangFindVar,_ANSI_ARGS_((Tcl_Interp * interp, Tk_Window, CONST char *name)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef LangFindVar */
+
+#ifndef LangFontObj
+#ifndef RC_INVOKED
+VFUNC(Tcl_Obj *,LangFontObj,V_LangFontObj,_ANSI_ARGS_((Tcl_Interp *interp, Tk_Font font, char *name)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef LangFontObj */
+
+#ifndef LangObjectObj
+#ifndef RC_INVOKED
+VFUNC(Tcl_Obj *,LangObjectObj,V_LangObjectObj,_ANSI_ARGS_((Tcl_Interp *interp, char *)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef LangObjectObj */
+
+#ifndef LangSelectHook
+#ifndef NO_EXTERN
+VFUNC(void,LangSelectHook,V_LangSelectHook,_ANSI_ARGS_((CONST char *what, Tk_Window tkwin,
+ Atom selection, Atom target, Atom type)))
+#endif /* #ifndef NO_EXTERN */
+#endif /* #ifndef LangSelectHook */
+
+#ifndef LangWidgetObj
+#ifndef RC_INVOKED
+VFUNC(Tcl_Obj *,LangWidgetObj,V_LangWidgetObj,_ANSI_ARGS_((Tcl_Interp *interp, Tk_Window)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef LangWidgetObj */
+
+#ifndef Lang_CreateImage
+#ifndef RC_INVOKED
+VFUNC(Tcl_Command,Lang_CreateImage,V_Lang_CreateImage,_ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName, Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc,
+ Tk_ImageType *typePtr)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Lang_CreateImage */
+
+#ifndef Lang_CreateWidget
+#ifndef RC_INVOKED
+VFUNC(Tcl_Command,Lang_CreateWidget,V_Lang_CreateWidget,_ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window, Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Lang_CreateWidget */
+
+#ifndef Lang_DeleteWidget
+#ifndef RC_INVOKED
+VFUNC(void,Lang_DeleteWidget,V_Lang_DeleteWidget,_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Command cmd)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Lang_DeleteWidget */
+
+#ifndef Tk_ChangeScreen
+#ifndef RC_INVOKED
+VFUNC(void,Tk_ChangeScreen,V_Tk_ChangeScreen,_ANSI_ARGS_((Tcl_Interp *interp,
+ char *dispName, int screenIndex)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_ChangeScreen */
+
+#ifndef Tk_CreateOldImageType
+#ifndef RC_INVOKED
+VFUNC(void,Tk_CreateOldImageType,V_Tk_CreateOldImageType,_ANSI_ARGS_((
+ Tk_ImageType *typePtr)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_CreateOldImageType */
+
+#ifndef Tk_EventInfo
+#ifndef RC_INVOKED
+VFUNC(char *,Tk_EventInfo,V_Tk_EventInfo,_ANSI_ARGS_((int letter, Tk_Window tkwin, XEvent *eventPtr,
+ KeySym keySym, int *numPtr, int *isNum, int *type,
+ int num_size, char *numStorage)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_EventInfo */
+
+#ifndef Tk_EventWindow
+#ifndef RC_INVOKED
+VFUNC(Tk_Window,Tk_EventWindow,V_Tk_EventWindow,_ANSI_ARGS_((XEvent *eventPtr)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_EventWindow */
+
+#ifndef Tk_FreeTile
+#ifndef RC_INVOKED
+VFUNC(void,Tk_FreeTile,V_Tk_FreeTile,_ANSI_ARGS_((Tk_Tile tile)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_FreeTile */
+
+#ifndef Tk_GetTile
+#ifndef RC_INVOKED
+VFUNC(Tk_Tile,Tk_GetTile,V_Tk_GetTile,_ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin,
+ CONST char *imageName)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_GetTile */
+
+#ifndef Tk_GetXSelection
+#ifndef RC_INVOKED
+VFUNC(int,Tk_GetXSelection,V_Tk_GetXSelection,_ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, Atom selection, Atom target,
+ Tk_GetXSelProc *proc, ClientData clientData)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_GetXSelection */
+
+#ifndef Tk_InitImageArgs
+#ifndef RC_INVOKED
+VFUNC(void,Tk_InitImageArgs,V_Tk_InitImageArgs,_ANSI_ARGS_((Tcl_Interp *interp, int argc, char ***objv)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_InitImageArgs */
+
+#ifndef Tk_NameOfTile
+#ifndef RC_INVOKED
+VFUNC(CONST char *,Tk_NameOfTile,V_Tk_NameOfTile,_ANSI_ARGS_((Tk_Tile tile)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_NameOfTile */
+
+#ifndef Tk_PixmapOfTile
+#ifndef RC_INVOKED
+VFUNC(Pixmap,Tk_PixmapOfTile,V_Tk_PixmapOfTile,_ANSI_ARGS_((Tk_Tile tile)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_PixmapOfTile */
+
+#ifndef Tk_SetTileChangedProc
+#ifndef RC_INVOKED
+VFUNC(void,Tk_SetTileChangedProc,V_Tk_SetTileChangedProc,_ANSI_ARGS_((Tk_Tile tile,
+ Tk_TileChangedProc * changeProc, ClientData clientData)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_SetTileChangedProc */
+
+#ifndef Tk_SizeOfTile
+#ifndef RC_INVOKED
+VFUNC(void,Tk_SizeOfTile,V_Tk_SizeOfTile,_ANSI_ARGS_((Tk_Tile tile, int *widthPtr,
+ int *heightPtr)))
+#endif /* #ifndef RC_INVOKED */
+#endif /* #ifndef Tk_SizeOfTile */
+
+#endif /* _TK */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk3d.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk3d.h
new file mode 100755
index 00000000000..f7b89114068
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk3d.h
@@ -0,0 +1,102 @@
+/*
+ * tk3d.h --
+ *
+ * Declarations of types and functions shared by the 3d border
+ * module.
+ *
+ * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tk3d.h,v 1.5 1999/04/16 01:51:10 stanton Exp $
+ */
+
+#ifndef _TK3D
+#define _TK3D
+
+#include "tkInt.h"
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * One of the following data structures is allocated for each 3-D border
+ * currently in use. Structures of this type are indexed by
+ * borderTable, so that a single structure can be shared for several
+ * uses.
+ */
+
+typedef struct TkBorder {
+ Screen *screen; /* Screen on which the border will be used. */
+ Visual *visual; /* Visual for all windows and pixmaps using
+ * the border. */
+ int depth; /* Number of bits per pixel of drawables where
+ * the border will be used. */
+ Colormap colormap; /* Colormap out of which pixels are
+ * allocated. */
+ int resourceRefCount; /* Number of active uses of this color (each
+ * active use corresponds to a call to
+ * Tk_Alloc3DBorderFromObj or Tk_Get3DBorder).
+ * If this count is 0, then this structure
+ * is no longer valid and it isn't present
+ * in borderTable: it is being kept around
+ * only because there are objects referring
+ * to it. The structure is freed when
+ * resourceRefCount and objRefCount are
+ * both 0. */
+ int objRefCount; /* The number of Tcl objects that reference
+ * this structure. */
+ XColor *bgColorPtr; /* Background color (intensity
+ * between lightColorPtr and
+ * darkColorPtr). */
+ XColor *darkColorPtr; /* Color for darker areas (must free when
+ * deleting structure). NULL means shadows
+ * haven't been allocated yet.*/
+ XColor *lightColorPtr; /* Color used for lighter areas of border
+ * (must free this when deleting structure).
+ * NULL means shadows haven't been allocated
+ * yet. */
+ Pixmap shadow; /* Stipple pattern to use for drawing
+ * shadows areas. Used for displays with
+ * <= 64 colors or where colormap has filled
+ * up. */
+ GC bgGC; /* Used (if necessary) to draw areas in
+ * the background color. */
+ GC darkGC; /* Used to draw darker parts of the
+ * border. None means the shadow colors
+ * haven't been allocated yet.*/
+ GC lightGC; /* Used to draw lighter parts of
+ * the border. None means the shadow colors
+ * haven't been allocated yet. */
+ Tcl_HashEntry *hashPtr; /* Entry in borderTable (needed in
+ * order to delete structure). */
+ struct TkBorder *nextPtr; /* Points to the next TkBorder structure with
+ * the same color name. Borders with the
+ * same name but different screens or
+ * colormaps are chained together off a
+ * single entry in borderTable. */
+} TkBorder;
+
+
+/*
+ * Maximum intensity for a color:
+ */
+
+#define MAX_INTENSITY 65535
+
+/*
+ * Declarations for platform specific interfaces used by this module.
+ */
+
+EXTERN TkBorder * TkpGetBorder _ANSI_ARGS_((void));
+EXTERN void TkpGetShadows _ANSI_ARGS_((TkBorder *borderPtr,
+ Tk_Window tkwin));
+EXTERN void TkpFreeBorder _ANSI_ARGS_((TkBorder *borderPtr));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TK3D */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkButton.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkButton.h
new file mode 100755
index 00000000000..e75742e6beb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkButton.h
@@ -0,0 +1,320 @@
+/*
+ * tkButton.h --
+ *
+ * Declarations of types and functions used to implement
+ * button-like widgets.
+ *
+ * Copyright (c) 1996-1998 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkButton.h,v 1.9.2.1 2003/04/26 02:53:46 hobbs Exp $
+ */
+
+#ifndef _TKBUTTON
+#define _TKBUTTON
+
+#ifndef _TKINT
+#include "tkInt.h"
+#endif
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Legal values for the "compound" field of TkButton records.
+ */
+
+enum compound {
+ COMPOUND_BOTTOM, COMPOUND_CENTER, COMPOUND_LEFT, COMPOUND_NONE,
+ COMPOUND_RIGHT, COMPOUND_TOP
+};
+
+/*
+ * Legal values for the "state" field of TkButton records.
+ */
+
+enum state {
+ STATE_ACTIVE, STATE_DISABLED, STATE_NORMAL
+};
+
+/*
+ * Legal values for the "defaultState" field of TkButton records.
+ */
+
+enum defaultState {
+ DEFAULT_ACTIVE, DEFAULT_DISABLED, DEFAULT_NORMAL
+};
+
+/*
+ * A data structure of the following type is kept for each
+ * widget managed by this file:
+ */
+
+typedef struct {
+ Tk_Window tkwin; /* Window that embodies the button. NULL
+ * means that the window has been destroyed. */
+ Display *display; /* Display containing widget. Needed to
+ * free up resources after tkwin is gone. */
+ Tcl_Interp *interp; /* Interpreter associated with button. */
+ Tcl_Command widgetCmd; /* Token for button's widget command. */
+ int type; /* Type of widget, such as TYPE_LABEL:
+ * restricts operations that may be performed
+ * on widget. See below for legal values. */
+ Tk_OptionTable optionTable; /* Table that defines configuration options
+ * available for this widget. */
+
+ /*
+ * Information about what's in the button.
+ */
+
+ Tcl_Obj *textPtr; /* Value of -text option: specifies text to
+ * display in button. */
+ int underline; /* Value of -underline option: specifies
+ * index of character to underline. < 0 means
+ * don't underline anything. */
+ Tcl_Obj *textVarNamePtr; /* Value of -textvariable option: specifies
+ * name of variable or NULL. If non-NULL,
+ * button displays the contents of this
+ * variable. */
+ Pixmap bitmap; /* Value of -bitmap option. If not None,
+ * specifies bitmap to display and text and
+ * textVar are ignored. */
+ Tcl_Obj *imagePtr; /* Value of -image option: specifies image
+ * to display in window, or NULL if none.
+ * If non-NULL, bitmap, text, and textVarName
+ * are ignored.*/
+ Tk_Image image; /* Derived from imagePtr by calling
+ * Tk_GetImage, or NULL if imagePtr is NULL. */
+ Tcl_Obj *selectImagePtr; /* Value of -selectimage option: specifies
+ * image to display in window when selected,
+ * or NULL if none. Ignored if imagePtr is
+ * NULL. */
+ Tk_Image selectImage; /* Derived from selectImagePtr by calling
+ * Tk_GetImage, or NULL if selectImagePtr
+ * is NULL. */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ enum state state; /* Value of -state option: specifies
+ * state of button for display purposes.*/
+ Tk_3DBorder normalBorder; /* Value of -background option: specifies
+ * color for background (and border) when
+ * window isn't active. */
+ Tk_3DBorder activeBorder; /* Value of -activebackground option:
+ * this is the color used to draw 3-D border
+ * and background when widget is active. */
+ Tcl_Obj *borderWidthPtr; /* Value of -borderWidth option: specifies
+ * width of border in pixels. */
+ int borderWidth; /* Integer value corresponding to
+ * borderWidthPtr. Always >= 0. */
+ int relief; /* Value of -relief option: specifies 3-d
+ * effect for border, such as
+ * TK_RELIEF_RAISED. */
+ int overRelief; /* Value of -overrelief option: specifies a 3-d
+ * effect for the border, such as
+ * TK_RELIEF_RAISED, to be used when the mouse
+ * is over the button. */
+ int offRelief; /* Value of -offrelief option: specifies a 3-d
+ * effect for the border, such as
+ * TK_RELIEF_RAISED, to be used when a
+ * checkbutton or radiobutton without
+ * indicator is off */
+ Tcl_Obj *highlightWidthPtr; /* Value of -highlightthickness option:
+ * specifies width in pixels of highlight to
+ * draw around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ int highlightWidth; /* Integer value corresponding to
+ * highlightWidthPtr. Always >= 0. */
+ Tk_3DBorder highlightBorder;/* Value of -highlightbackground option:
+ * specifies background with which to draw 3-D
+ * default ring and focus highlight area when
+ * highlight is off. */
+ XColor *highlightColorPtr; /* Value of -highlightcolor option:
+ * specifies color for drawing traversal
+ * highlight. */
+ int inset; /* Total width of all borders, including
+ * traversal highlight and 3-D border.
+ * Indicates how much interior stuff must
+ * be offset from outside edges to leave
+ * room for borders. */
+ Tk_Font tkfont; /* Value of -font option: specifies font
+ * to use for display text. */
+ XColor *normalFg; /* Value of -font option: specifies foreground
+ * color in normal mode. */
+ XColor *activeFg; /* Value of -activeforeground option:
+ * foreground color in active mode. NULL
+ * means use -foreground instead. */
+ XColor *disabledFg; /* Value of -disabledforeground option:
+ * foreground color when disabled. NULL
+ * means use normalFg with a 50% stipple
+ * instead. */
+ GC normalTextGC; /* GC for drawing text in normal mode. Also
+ * used to copy from off-screen pixmap onto
+ * screen. */
+ GC activeTextGC; /* GC for drawing text in active mode (NULL
+ * means use normalTextGC). */
+ GC disabledGC; /* Used to produce disabled effect for text
+ * and check/radio marks. */
+ GC stippleGC; /* Used to produce disabled stipple effect
+ * for images when disabled. */
+ Pixmap gray; /* Pixmap for displaying disabled text if
+ * disabledFg is NULL. */
+ GC copyGC; /* Used for copying information from an
+ * off-screen pixmap to the screen. */
+ Tcl_Obj *widthPtr; /* Value of -width option. */
+ int width; /* Integer value corresponding to widthPtr. */
+ Tcl_Obj *heightPtr; /* Value of -height option. */
+ int height; /* Integer value corresponding to heightPtr. */
+ Tcl_Obj *wrapLengthPtr; /* Value of -wraplength option: specifies
+ * line length (in pixels) at which to wrap
+ * onto next line. <= 0 means don't wrap
+ * except at newlines. */
+ int wrapLength; /* Integer value corresponding to
+ * wrapLengthPtr. */
+ Tcl_Obj *padXPtr; /* Value of -padx option: specifies how many
+ * pixels of extra space to leave on left and
+ * right of text. Ignored for bitmaps and
+ * images. */
+ int padX; /* Integer value corresponding to padXPtr. */
+ Tcl_Obj *padYPtr; /* Value of -padx option: specifies how many
+ * pixels of extra space to leave above and
+ * below text. Ignored for bitmaps and
+ * images. */
+ int padY; /* Integer value corresponding to padYPtr. */
+ Tk_Anchor anchor; /* Value of -anchor option: specifies where
+ * text/bitmap should be displayed inside
+ * button region. */
+ Tk_Justify justify; /* Value of -justify option: specifies how
+ * to align lines of multi-line text. */
+ int indicatorOn; /* Value of -indicatoron option: 1 means
+ * draw indicator in checkbuttons and
+ * radiobuttons, 0 means don't draw it. */
+ Tk_3DBorder selectBorder; /* Value of -selectcolor option: specifies
+ * color for drawing indicator background, or
+ * perhaps widget background, when selected. */
+ int textWidth; /* Width needed to display text as requested,
+ * in pixels. */
+ int textHeight; /* Height needed to display text as requested,
+ * in pixels. */
+ Tk_TextLayout textLayout; /* Saved text layout information. */
+ int indicatorSpace; /* Horizontal space (in pixels) allocated for
+ * display of indicator. */
+ int indicatorDiameter; /* Diameter of indicator, in pixels. */
+ enum defaultState defaultState;
+ /* Value of -default option, such as
+ * DEFAULT_NORMAL: specifies state
+ * of default ring for buttons (normal,
+ * active, or disabled). NULL for other
+ * classes. */
+
+ /*
+ * For check and radio buttons, the fields below are used
+ * to manage the variable indicating the button's state.
+ */
+
+ Tcl_Obj *selVarNamePtr; /* Value of -variable option: specifies name
+ * of variable used to control selected
+ * state of button. */
+ Tcl_Obj *onValuePtr; /* Value of -offvalue option: specifies value
+ * to store in variable when this button is
+ * selected. */
+ Tcl_Obj *offValuePtr; /* Value of -offvalue option: specifies value
+ * to store in variable when this button
+ * isn't selected. Used only by
+ * checkbuttons. */
+
+ /*
+ * Miscellaneous information:
+ */
+
+ Tk_Cursor cursor; /* Value of -cursor option: if not None,
+ * specifies current cursor for window. */
+ Tcl_Obj *takeFocusPtr; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. */
+ Tcl_Obj *commandPtr; /* Value of -command option: specifies script
+ * to execute when button is invoked. If
+ * widget is label or has no command, this
+ * is NULL. */
+ int compound; /* Value of -compound option; specifies whether
+ * the button should show both an image and
+ * text, and, if so, how. */
+ int repeatDelay; /* Value of -repeatdelay option; specifies
+ * the number of ms after which the button will
+ * start to auto-repeat its command. */
+ int repeatInterval; /* Value of -repeatinterval option; specifies
+ * the number of ms between auto-repeat
+ * invocataions of the button command. */
+ int flags; /* Various flags; see below for
+ * definitions. */
+} TkButton;
+
+/*
+ * Possible "type" values for buttons. These are the kinds of
+ * widgets supported by this file. The ordering of the type
+ * numbers is significant: greater means more features and is
+ * used in the code.
+ */
+
+#define TYPE_LABEL 0
+#define TYPE_BUTTON 1
+#define TYPE_CHECK_BUTTON 2
+#define TYPE_RADIO_BUTTON 3
+
+/*
+ * Flag bits for buttons:
+ *
+ * REDRAW_PENDING: Non-zero means a DoWhenIdle handler
+ * has already been queued to redraw
+ * this window.
+ * SELECTED: Non-zero means this button is selected,
+ * so special highlight should be drawn.
+ * GOT_FOCUS: Non-zero means this button currently
+ * has the input focus.
+ * BUTTON_DELETED: Non-zero needs that this button has been
+ * deleted, or is in the process of being
+ * deleted.
+ */
+
+#define REDRAW_PENDING (1 << 0)
+#define SELECTED (1 << 1)
+#define GOT_FOCUS (1 << 2)
+#define BUTTON_DELETED (1 << 3)
+/*
+ * Declaration of variables shared between the files in the button module.
+ */
+
+extern Tk_ClassProcs tkpButtonProcs;
+
+/*
+ * Declaration of procedures used in the implementation of the button
+ * widget.
+ */
+
+#ifndef TkpButtonSetDefaults
+EXTERN void TkpButtonSetDefaults _ANSI_ARGS_((
+ Tk_OptionSpec *specPtr));
+#endif
+EXTERN void TkButtonWorldChanged _ANSI_ARGS_((
+ ClientData instanceData));
+EXTERN void TkpComputeButtonGeometry _ANSI_ARGS_((
+ TkButton *butPtr));
+EXTERN TkButton * TkpCreateButton _ANSI_ARGS_((Tk_Window tkwin));
+#ifndef TkpDestroyButton
+EXTERN void TkpDestroyButton _ANSI_ARGS_((TkButton *butPtr));
+#endif
+#ifndef TkpDisplayButton
+EXTERN void TkpDisplayButton _ANSI_ARGS_((ClientData clientData));
+#endif
+EXTERN int TkInvokeButton _ANSI_ARGS_((TkButton *butPtr));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKBUTTON */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvas.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvas.h
new file mode 100755
index 00000000000..6b033bf63fc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvas.h
@@ -0,0 +1,334 @@
+/*
+ * tkCanvas.h --
+ *
+ * Declarations shared among all the files that implement
+ * canvas widgets.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ * Copyright (c) 1998 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkCanvas.h,v 1.7 2003/01/08 23:02:33 drh Exp $
+ */
+
+#ifndef _TKCANVAS
+#define _TKCANVAS
+
+#ifndef _TK
+#include "tk.h"
+#endif
+
+#ifndef USE_OLD_TAG_SEARCH
+typedef struct TagSearchExpr_s TagSearchExpr;
+
+struct TagSearchExpr_s {
+ TagSearchExpr *next; /* for linked lists of expressions - used in bindings */
+ Tk_Uid uid; /* the uid of the whole expression */
+ Tk_Uid *uids; /* expresion compiled to an array of uids */
+ int allocated; /* available space for array of uids */
+ int length; /* length of expression */
+ int index; /* current position in expression evaluation */
+ int match; /* this expression matches event's item's tags*/
+};
+#endif /* not USE_OLD_TAG_SEARCH */
+
+/*
+ * The record below describes a canvas widget. It is made available
+ * to the item procedures so they can access certain shared fields such
+ * as the overall displacement and scale factor for the canvas.
+ */
+
+typedef struct TkCanvas {
+ Tk_Window tkwin; /* Window that embodies the canvas. NULL
+ * means that the window has been destroyed
+ * but the data structures haven't yet been
+ * cleaned up.*/
+ Display *display; /* Display containing widget; needed, among
+ * other things, to release resources after
+ * tkwin has already gone away. */
+ Tcl_Interp *interp; /* Interpreter associated with canvas. */
+ Tcl_Command widgetCmd; /* Token for canvas's widget command. */
+ Tk_Item *firstItemPtr; /* First in list of all items in canvas,
+ * or NULL if canvas empty. */
+ Tk_Item *lastItemPtr; /* Last in list of all items in canvas,
+ * or NULL if canvas empty. */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ int borderWidth; /* Width of 3-D border around window. */
+ Tk_3DBorder bgBorder; /* Used for canvas background. */
+ int relief; /* Indicates whether window as a whole is
+ * raised, sunken, or flat. */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ XColor *highlightBgColorPtr;
+ /* Color for drawing traversal highlight
+ * area when highlight is off. */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ int inset; /* Total width of all borders, including
+ * traversal highlight and 3-D border.
+ * Indicates how much interior stuff must
+ * be offset from outside edges to leave
+ * room for borders. */
+ GC pixmapGC; /* Used to copy bits from a pixmap to the
+ * screen and also to clear the pixmap. */
+ int width, height; /* Dimensions to request for canvas window,
+ * specified in pixels. */
+ int redrawX1, redrawY1; /* Upper left corner of area to redraw,
+ * in pixel coordinates. Border pixels
+ * are included. Only valid if
+ * REDRAW_PENDING flag is set. */
+ int redrawX2, redrawY2; /* Lower right corner of area to redraw,
+ * in integer canvas coordinates. Border
+ * pixels will *not* be redrawn. */
+ int confine; /* Non-zero means constrain view to keep
+ * as much of canvas visible as possible. */
+
+ /*
+ * Information used to manage the selection and insertion cursor:
+ */
+
+ Tk_CanvasTextInfo textInfo; /* Contains lots of fields; see tk.h for
+ * details. This structure is shared with
+ * the code that implements individual items. */
+ int insertOnTime; /* Number of milliseconds cursor should spend
+ * in "on" state for each blink. */
+ int insertOffTime; /* Number of milliseconds cursor should spend
+ * in "off" state for each blink. */
+ Tcl_TimerToken insertBlinkHandler;
+ /* Timer handler used to blink cursor on and
+ * off. */
+
+ /*
+ * Transformation applied to canvas as a whole: to compute screen
+ * coordinates (X,Y) from canvas coordinates (x,y), do the following:
+ *
+ * X = x - xOrigin;
+ * Y = y - yOrigin;
+ */
+
+ int xOrigin, yOrigin; /* Canvas coordinates corresponding to
+ * upper-left corner of window, given in
+ * canvas pixel units. */
+ int drawableXOrigin, drawableYOrigin;
+ /* During redisplay, these fields give the
+ * canvas coordinates corresponding to
+ * the upper-left corner of the drawable
+ * where items are actually being drawn
+ * (typically a pixmap smaller than the
+ * whole window). */
+
+ /*
+ * Information used for event bindings associated with items.
+ */
+
+ Tk_BindingTable bindingTable;
+ /* Table of all bindings currently defined
+ * for this canvas. NULL means that no
+ * bindings exist, so the table hasn't been
+ * created. Each "object" used for this
+ * table is either a Tk_Uid for a tag or
+ * the address of an item named by id. */
+ Tk_Item *currentItemPtr; /* The item currently containing the mouse
+ * pointer, or NULL if none. */
+ Tk_Item *newCurrentPtr; /* The item that is about to become the
+ * current one, or NULL. This field is
+ * used to detect deletions of the new
+ * current item pointer that occur during
+ * Leave processing of the previous current
+ * item. */
+ double closeEnough; /* The mouse is assumed to be inside an
+ * item if it is this close to it. */
+ XEvent pickEvent; /* The event upon which the current choice
+ * of currentItem is based. Must be saved
+ * so that if the currentItem is deleted,
+ * can pick another. */
+ int state; /* Last known modifier state. Used to
+ * defer picking a new current object
+ * while buttons are down. */
+
+ /*
+ * Information used for managing scrollbars:
+ */
+
+ LangCallback *xScrollCmd; /* Command prefix for communicating with
+ * horizontal scrollbar. NULL means no
+ * horizontal scrollbar. Malloc'ed*/
+ LangCallback *yScrollCmd; /* Command prefix for communicating with
+ * vertical scrollbar. NULL means no
+ * vertical scrollbar. Malloc'ed*/
+ int scrollX1, scrollY1, scrollX2, scrollY2;
+ /* These four coordinates define the region
+ * that is the 100% area for scrolling (i.e.
+ * these numbers determine the size and
+ * location of the sliders on scrollbars).
+ * Units are pixels in canvas coords. */
+ Tcl_Obj * regionArg; /* The option string from which scrollX1
+ * etc. are derived. Malloc'ed. */
+ int xScrollIncrement; /* If >0, defines a grid for horizontal
+ * scrolling. This is the size of the "unit",
+ * and the left edge of the screen will always
+ * lie on an even unit boundary. */
+ int yScrollIncrement; /* If >0, defines a grid for horizontal
+ * scrolling. This is the size of the "unit",
+ * and the left edge of the screen will always
+ * lie on an even unit boundary. */
+
+ /*
+ * Information used for scanning:
+ */
+
+ int scanX; /* X-position at which scan started (e.g.
+ * button was pressed here). */
+ int scanXOrigin; /* Value of xOrigin field when scan started. */
+ int scanY; /* Y-position at which scan started (e.g.
+ * button was pressed here). */
+ int scanYOrigin; /* Value of yOrigin field when scan started. */
+
+ /*
+ * Information used to speed up searches by remembering the last item
+ * created or found with an item id search.
+ */
+
+ Tk_Item *hotPtr; /* Pointer to "hot" item (one that's been
+ * recently used. NULL means there's no
+ * hot item. */
+ Tk_Item *hotPrevPtr; /* Pointer to predecessor to hotPtr (NULL
+ * means item is first in list). This is
+ * only a hint and may not really be hotPtr's
+ * predecessor. */
+
+ /*
+ * Miscellaneous information:
+ */
+
+ Tk_Cursor cursor; /* Current cursor for window, or None. */
+ char *takeFocus; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+ double pixelsPerMM; /* Scale factor between MM and pixels;
+ * used when converting coordinates. */
+ int flags; /* Various flags; see below for
+ * definitions. */
+ int nextId; /* Number to use as id for next item
+ * created in widget. */
+ Tk_PostscriptInfo psInfo;
+ /* Pointer to information used for generating
+ * Postscript for the canvas. NULL means
+ * no Postscript is currently being
+ * generated. */
+ Tcl_HashTable idTable; /* Table of integer indices. */
+ /*
+ * Additional information, added by the 'dash'-patch
+ */
+ Tk_State canvas_state; /* state of canvas */
+ Tk_Tile tile;
+ Tk_Tile disabledTile;
+ Tk_TSOffset tsoffset;
+#ifndef USE_OLD_TAG_SEARCH
+ TagSearchExpr *bindTagExprs; /* linked list of tag expressions used in bindings */
+#endif
+ /* pTk additions */
+ Tk_Item *activeGroup; /* Which group item is active */
+ Tcl_Obj *updateCmds;
+} TkCanvas;
+
+/*
+ * Flag bits for canvases:
+ *
+ * REDRAW_PENDING - 1 means a DoWhenIdle handler has already
+ * been created to redraw some or all of the
+ * canvas.
+ * REDRAW_BORDERS - 1 means that the borders need to be redrawn
+ * during the next redisplay operation.
+ * REPICK_NEEDED - 1 means DisplayCanvas should pick a new
+ * current item before redrawing the canvas.
+ * GOT_FOCUS - 1 means the focus is currently in this
+ * widget, so should draw the insertion cursor
+ * and traversal highlight.
+ * CURSOR_ON - 1 means the insertion cursor is in the "on"
+ * phase of its blink cycle. 0 means either
+ * we don't have the focus or the cursor is in
+ * the "off" phase of its cycle.
+ * UPDATE_SCROLLBARS - 1 means the scrollbars should get updated
+ * as part of the next display operation.
+ * LEFT_GRABBED_ITEM - 1 means that the mouse left the current
+ * item while a grab was in effect, so we
+ * didn't change canvasPtr->currentItemPtr.
+ * REPICK_IN_PROGRESS - 1 means PickCurrentItem is currently
+ * executing. If it should be called recursively,
+ * it should simply return immediately.
+ * BBOX_NOT_EMPTY - 1 means that the bounding box of the area
+ * that should be redrawn is not empty.
+ */
+
+#define REDRAW_PENDING 1
+#define REDRAW_BORDERS 2
+#define REPICK_NEEDED 4
+#define GOT_FOCUS 8
+#define CURSOR_ON 0x10
+#define UPDATE_SCROLLBARS 0x20
+#define LEFT_GRABBED_ITEM 0x40
+#define REPICK_IN_PROGRESS 0x100
+#define BBOX_NOT_EMPTY 0x200
+
+/*
+ * Flag bits for canvas items (redraw_flags):
+ *
+ * FORCE_REDRAW - 1 means that the new coordinates of some
+ * item are not yet registered using
+ * Tk_CanvasEventuallyRedraw(). It should still
+ * be done by the general canvas code.
+ */
+
+#define FORCE_REDRAW 8
+#define NEEDS_DISPLAY 16
+
+/*
+ * Canvas-related procedures that are shared among Tk modules but not
+ * exported to the outside world:
+ */
+
+extern int TkCanvPostscriptCmd _ANSI_ARGS_((TkCanvas *canvasPtr,
+ Tcl_Interp *interp, int argc, CONST84 Tcl_Obj *CONST *objv));
+
+/*
+ * Other procedures that are shared among Tk canvas modules but not exported
+ * to the outside world:
+ */
+extern int TkCanvTranslatePath _ANSI_ARGS_((TkCanvas *canvPtr,
+ int numVertex, double *coordPtr, int closed,
+ XPoint *outPtr));
+
+
+#define Tk_CanvasActiveGroup(canvas) ((TkCanvas *) (canvas))->activeGroup
+
+#define Tk_CanvasGroupHidden(canvas,itemPtr) ( \
+ ( Tk_CanvasActiveGroup(canvas) && \
+ (itemPtr)->group != Tk_CanvasActiveGroup(canvas)) || \
+ ( (itemPtr)->group && \
+ (itemPtr)->group != Tk_CanvasActiveGroup(canvas) && \
+ (itemPtr)->group->state != TK_STATE_ACTIVE ))
+
+#define Tk_GetItemState(canvas,itemPtr) \
+( \
+ (0 && Tk_CanvasGroupHidden(canvas,itemPtr)) \
+ ? TK_STATE_HIDDEN \
+ : (((itemPtr)->state == TK_STATE_NULL) \
+ ? ((TkCanvas *)(canvas))->canvas_state \
+ : (itemPtr)->state \
+ ) \
+)
+
+EXTERN void TkGroupRemoveItem _ANSI_ARGS_((Tk_Item *item));
+
+#endif /* _TKCANVAS */
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvases.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvases.h
new file mode 100755
index 00000000000..14d604e6591
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkCanvases.h
@@ -0,0 +1,81 @@
+#ifndef _TKCANVASES
+#define _TKCANVASES
+
+#ifndef _TKCANVAS
+#include "tkCanvas.h"
+#endif
+
+EXTERN Tk_CustomOption tk_CanvasTagsOption;
+
+
+EXTERN void Tk_CanvasDrawableCoords _ANSI_ARGS_((Tk_Canvas canvas,
+ double x, double y, short *drawableXPtr,
+ short *drawableYPtr));
+EXTERN void Tk_CanvasEventuallyRedraw _ANSI_ARGS_((
+ Tk_Canvas canvas, int x1, int y1, int x2,
+ int y2));
+EXTERN int Tk_CanvasGetCoord _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, CONST char *string,
+ double *doublePtr));
+EXTERN Tk_CanvasTextInfo *Tk_CanvasGetTextInfo _ANSI_ARGS_((Tk_Canvas canvas));
+EXTERN int Tk_CanvasPsBitmap _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Pixmap bitmap, int x, int y,
+ int width, int height));
+EXTERN int Tk_CanvasPsColor _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, XColor *colorPtr));
+EXTERN int Tk_CanvasPsFont _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tk_Font font));
+EXTERN void Tk_CanvasPsPath _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, double *coordPtr, int numPoints));
+EXTERN int Tk_CanvasPsStipple _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Pixmap bitmap));
+EXTERN double Tk_CanvasPsY _ANSI_ARGS_((Tk_Canvas canvas, double y));
+EXTERN void Tk_CanvasSetStippleOrigin _ANSI_ARGS_((
+ Tk_Canvas canvas, GC gc));
+EXTERN Tk_Window Tk_CanvasTkwin _ANSI_ARGS_((Tk_Canvas canvas));
+EXTERN void Tk_CanvasWindowCoords _ANSI_ARGS_((Tk_Canvas canvas,
+ double x, double y, short *screenXPtr,
+ short *screenYPtr));
+EXTERN void Tk_CreateItemType _ANSI_ARGS_((Tk_ItemType *typePtr));
+EXTERN Tk_ItemType * Tk_GetItemTypes _ANSI_ARGS_((void));
+
+/* These are from tkInt.h */
+
+extern void TkBezierPoints _ANSI_ARGS_((double control[],
+ int numSteps, double *coordPtr));
+extern void TkBezierScreenPoints _ANSI_ARGS_((Tk_Canvas canvas,
+ double control[], int numSteps,
+ XPoint *xPointPtr));
+extern void TkFillPolygon _ANSI_ARGS_((Tk_Canvas canvas,
+ double *coordPtr, int numPoints, Display *display,
+ Drawable drawable, GC gc, GC outlineGC));
+extern int TkMakeBezierCurve _ANSI_ARGS_((Tk_Canvas canvas,
+ double *pointPtr, int numPoints, int numSteps,
+ XPoint xPoints[], double dblPoints[]));
+extern void TkMakeBezierPostscript _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, double *pointPtr,
+ int numPoints));
+extern void TkIncludePoint _ANSI_ARGS_((Tk_Item *itemPtr,
+ double *pointPtr));
+extern void TkGetButtPoints _ANSI_ARGS_((double p1[], double p2[],
+ double width, int project, double m1[],
+ double m2[]));
+extern int TkGetMiterPoints _ANSI_ARGS_((double p1[], double p2[],
+ double p3[], double width, double m1[],
+ double m2[]));
+extern int TkLineToArea _ANSI_ARGS_((double end1Ptr[2],
+ double end2Ptr[2], double rectPtr[4]));
+extern double TkLineToPoint _ANSI_ARGS_((double end1Ptr[2],
+ double end2Ptr[2], double pointPtr[2]));
+extern int TkOvalToArea _ANSI_ARGS_((double *ovalPtr,
+ double *rectPtr));
+extern double TkOvalToPoint _ANSI_ARGS_((double ovalPtr[4],
+ double width, int filled, double pointPtr[2]));
+extern int TkPolygonToArea _ANSI_ARGS_((double *polyPtr,
+ int numPoints, double *rectPtr));
+extern double TkPolygonToPoint _ANSI_ARGS_((double *polyPtr,
+ int numPoints, double *pointPtr));
+
+#include "tkVMacro.h"
+#endif
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkColor.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkColor.h
new file mode 100755
index 00000000000..f24df7c8759
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkColor.h
@@ -0,0 +1,89 @@
+/*
+ * tkColor.h --
+ *
+ * Declarations of data types and functions used by the
+ * Tk color module.
+ *
+ * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkColor.h,v 1.6 1999/11/19 22:00:03 hobbs Exp $
+ */
+
+#ifndef _TKCOLOR
+#define _TKCOLOR
+
+#include "tkInt.h"
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * One of the following data structures is used to keep track of
+ * each color that is being used by the application; typically there
+ * is a colormap entry allocated for each of these colors.
+ */
+
+#define TK_COLOR_BY_NAME 1
+#define TK_COLOR_BY_VALUE 2
+
+#define COLOR_MAGIC ((unsigned int) 0x46140277)
+
+typedef struct TkColor {
+ XColor color; /* Information about this color. */
+ unsigned int magic; /* Used for quick integrity check on this
+ * structure. Must always have the
+ * value COLOR_MAGIC. */
+ GC gc; /* Simple gc with this color as foreground
+ * color and all other fields defaulted.
+ * May be None. */
+ Screen *screen; /* Screen where this color is valid. Used
+ * to delete it, and to find its display. */
+ Colormap colormap; /* Colormap from which this entry was
+ * allocated. */
+ Visual *visual; /* Visual associated with colormap. */
+ int resourceRefCount; /* Number of active uses of this color (each
+ * active use corresponds to a call to
+ * Tk_AllocColorFromObj or Tk_GetColor).
+ * If this count is 0, then this TkColor
+ * structure is no longer valid and it isn't
+ * present in a hash table: it is being
+ * kept around only because there are objects
+ * referring to it. The structure is freed
+ * when resourceRefCount and objRefCount
+ * are both 0. */
+ int objRefCount; /* The number of Tcl objects that reference
+ * this structure. */
+ int type; /* TK_COLOR_BY_NAME or TK_COLOR_BY_VALUE */
+ Tcl_HashEntry *hashPtr; /* Pointer to hash table entry for this
+ * structure. (for use in deleting entry). */
+ struct TkColor *nextPtr; /* Points to the next TkColor structure with
+ * the same color name. Colors with the
+ * same name but different screens or
+ * colormaps are chained together off a
+ * single entry in nameTable. For colors in
+ * valueTable (those allocated by
+ * Tk_GetColorByValue) this field is always
+ * NULL. */
+} TkColor;
+
+/*
+ * Common APIs exported from all platform-specific implementations.
+ */
+
+#ifndef TkpFreeColor
+EXTERN void TkpFreeColor _ANSI_ARGS_((TkColor *tkColPtr));
+#endif
+EXTERN TkColor * TkpGetColor _ANSI_ARGS_((Tk_Window tkwin,
+ Tk_Uid name));
+EXTERN TkColor * TkpGetColorByValue _ANSI_ARGS_((Tk_Window tkwin,
+ XColor *colorPtr));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKCOLOR */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkConfig.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkConfig.h
new file mode 100755
index 00000000000..9f35e9d1a57
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkConfig.h
@@ -0,0 +1,11 @@
+#ifndef _TKCONFIG
+#define _TKCONFIG
+#define ANSI_SIGNED_CHAR 1
+#define HAS_STDARG 1
+#define HAVE_LIMITS_H 1
+#define LSEEK_TYPE long long
+#define SELECT_MASK Perl_fd_set
+#define USE_NEWSTYLE_REGEXP_STRUCT 1
+#define USE_PREGCOMP_31027 1
+#define USE_PROTOTYPE 1
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.h
new file mode 100755
index 00000000000..ff6c2333573
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.h
@@ -0,0 +1,2277 @@
+/*
+ * tkDecls.h --
+ *
+ * Declarations of functions in the platform independent public Tcl API.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkDecls.h,v 1.23 2002/08/05 04:30:38 dgp Exp $
+ */
+
+#ifndef _TKDECLS
+#define _TKDECLS
+
+#ifdef BUILD_tk
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tk.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+/* 0 */
+EXTERN void Tk_MainLoop _ANSI_ARGS_((void));
+/* 1 */
+EXTERN XColor * Tk_3DBorderColor _ANSI_ARGS_((Tk_3DBorder border));
+/* 2 */
+EXTERN GC Tk_3DBorderGC _ANSI_ARGS_((Tk_Window tkwin,
+ Tk_3DBorder border, int which));
+/* 3 */
+EXTERN void Tk_3DHorizontalBevel _ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height, int leftIn,
+ int rightIn, int topBevel, int relief));
+/* 4 */
+EXTERN void Tk_3DVerticalBevel _ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height, int leftBevel,
+ int relief));
+/* 5 */
+EXTERN void Tk_AddOption _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name, CONST char * value,
+ int priority));
+/* 6 */
+EXTERN void Tk_BindEvent _ANSI_ARGS_((
+ Tk_BindingTable bindingTable,
+ XEvent * eventPtr, Tk_Window tkwin,
+ int numObjects, ClientData * objectPtr));
+/* 7 */
+EXTERN void Tk_CanvasDrawableCoords _ANSI_ARGS_((
+ Tk_Canvas canvas, double x, double y,
+ short * drawableXPtr, short * drawableYPtr));
+/* 8 */
+EXTERN void Tk_CanvasEventuallyRedraw _ANSI_ARGS_((
+ Tk_Canvas canvas, int x1, int y1, int x2,
+ int y2));
+/* 9 */
+EXTERN int Tk_CanvasGetCoord _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Canvas canvas, CONST char * str,
+ double * doublePtr));
+/* 10 */
+EXTERN Tk_CanvasTextInfo * Tk_CanvasGetTextInfo _ANSI_ARGS_((
+ Tk_Canvas canvas));
+/* 11 */
+EXTERN int Tk_CanvasPsBitmap _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Canvas canvas, Pixmap bitmap, int x,
+ int y, int width, int height));
+/* 12 */
+EXTERN int Tk_CanvasPsColor _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Canvas canvas, XColor * colorPtr));
+/* 13 */
+EXTERN int Tk_CanvasPsFont _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Canvas canvas, Tk_Font font));
+/* 14 */
+EXTERN void Tk_CanvasPsPath _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Canvas canvas, double * coordPtr,
+ int numPoints));
+/* 15 */
+EXTERN int Tk_CanvasPsStipple _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Canvas canvas, Pixmap bitmap));
+/* 16 */
+EXTERN double Tk_CanvasPsY _ANSI_ARGS_((Tk_Canvas canvas, double y));
+/* 17 */
+EXTERN void Tk_CanvasSetStippleOrigin _ANSI_ARGS_((
+ Tk_Canvas canvas, GC gc));
+/* 18 */
+EXTERN int Tk_CanvasTagsParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj *value,
+ char * widgRec, int offset));
+/* 19 */
+EXTERN Tcl_Obj * Tk_CanvasTagsPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char * widgRec, int offset,
+ Tcl_FreeProc ** freeProcPtr));
+/* 20 */
+EXTERN Tk_Window Tk_CanvasTkwin _ANSI_ARGS_((Tk_Canvas canvas));
+/* 21 */
+EXTERN void Tk_CanvasWindowCoords _ANSI_ARGS_((Tk_Canvas canvas,
+ double x, double y, short * screenXPtr,
+ short * screenYPtr));
+/* 22 */
+EXTERN void Tk_ChangeWindowAttributes _ANSI_ARGS_((
+ Tk_Window tkwin, unsigned long valueMask,
+ XSetWindowAttributes * attsPtr));
+/* 23 */
+EXTERN int Tk_CharBbox _ANSI_ARGS_((Tk_TextLayout layout,
+ int index, int * xPtr, int * yPtr,
+ int * widthPtr, int * heightPtr));
+/* 24 */
+EXTERN void Tk_ClearSelection _ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection));
+/* 25 */
+EXTERN int Tk_ClipboardAppend _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Atom target, Atom format,
+ char* buffer));
+/* 26 */
+EXTERN int Tk_ClipboardClear _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin));
+/* 27 */
+EXTERN int Tk_ConfigureInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec * specs,
+ char * widgRec, CONST char * argvName,
+ int flags));
+/* 28 */
+EXTERN int Tk_ConfigureValue _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec * specs,
+ char * widgRec, CONST char * argvName,
+ int flags));
+/* 29 */
+EXTERN int Tk_ConfigureWidget _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec * specs,
+ int argc, CONST84 Tcl_Obj *CONST *objv,
+ char * widgRec, int flags));
+/* 30 */
+EXTERN void Tk_ConfigureWindow _ANSI_ARGS_((Tk_Window tkwin,
+ unsigned int valueMask,
+ XWindowChanges * valuePtr));
+/* 31 */
+EXTERN Tk_TextLayout Tk_ComputeTextLayout _ANSI_ARGS_((Tk_Font font,
+ CONST char * str, int numChars,
+ int wrapLength, Tk_Justify justify,
+ int flags, int * widthPtr, int * heightPtr));
+/* 32 */
+EXTERN Tk_Window Tk_CoordsToWindow _ANSI_ARGS_((int rootX, int rootY,
+ Tk_Window tkwin));
+/* 33 */
+EXTERN unsigned long Tk_CreateBinding _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventStr,
+ Tcl_Obj *command, int append));
+/* 34 */
+EXTERN Tk_BindingTable Tk_CreateBindingTable _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 35 */
+EXTERN Tk_ErrorHandler Tk_CreateErrorHandler _ANSI_ARGS_((Display * display,
+ int errNum, int request, int minorCode,
+ Tk_ErrorProc * errorProc,
+ ClientData clientData));
+/* 36 */
+EXTERN void Tk_CreateEventHandler _ANSI_ARGS_((Tk_Window token,
+ unsigned long mask, Tk_EventProc * proc,
+ ClientData clientData));
+/* 37 */
+EXTERN void Tk_CreateGenericHandler _ANSI_ARGS_((
+ Tk_GenericProc * proc, ClientData clientData));
+/* 38 */
+EXTERN void Tk_CreateImageType _ANSI_ARGS_((
+ Tk_ImageType * typePtr));
+/* 39 */
+EXTERN void Tk_CreateItemType _ANSI_ARGS_((Tk_ItemType * typePtr));
+/* 40 */
+EXTERN void Tk_CreatePhotoImageFormat _ANSI_ARGS_((
+ Tk_PhotoImageFormat * formatPtr));
+/* 41 */
+EXTERN void Tk_CreateSelHandler _ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection, Atom target,
+ Tk_SelectionProc * proc,
+ ClientData clientData, Atom format));
+/* 42 */
+EXTERN Tk_Window Tk_CreateWindow _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window parent, CONST char * name,
+ CONST char * screenName));
+/* 43 */
+EXTERN Tk_Window Tk_CreateWindowFromPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ CONST char * pathName,
+ CONST char * screenName));
+/* 44 */
+EXTERN int Tk_DefineBitmap _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, CONST char * source,
+ int width, int height));
+/* 45 */
+EXTERN void Tk_DefineCursor _ANSI_ARGS_((Tk_Window window,
+ Tk_Cursor cursor));
+/* 46 */
+EXTERN void Tk_DeleteAllBindings _ANSI_ARGS_((
+ Tk_BindingTable bindingTable,
+ ClientData object));
+/* 47 */
+EXTERN int Tk_DeleteBinding _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventStr));
+/* 48 */
+EXTERN void Tk_DeleteBindingTable _ANSI_ARGS_((
+ Tk_BindingTable bindingTable));
+/* 49 */
+EXTERN void Tk_DeleteErrorHandler _ANSI_ARGS_((
+ Tk_ErrorHandler handler));
+/* 50 */
+EXTERN void Tk_DeleteEventHandler _ANSI_ARGS_((Tk_Window token,
+ unsigned long mask, Tk_EventProc * proc,
+ ClientData clientData));
+/* 51 */
+EXTERN void Tk_DeleteGenericHandler _ANSI_ARGS_((
+ Tk_GenericProc * proc, ClientData clientData));
+/* 52 */
+EXTERN void Tk_DeleteImage _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name));
+/* 53 */
+EXTERN void Tk_DeleteSelHandler _ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection, Atom target));
+/* 54 */
+EXTERN void Tk_DestroyWindow _ANSI_ARGS_((Tk_Window tkwin));
+/* 55 */
+EXTERN CONST84_RETURN char * Tk_DisplayName _ANSI_ARGS_((Tk_Window tkwin));
+/* 56 */
+EXTERN int Tk_DistanceToTextLayout _ANSI_ARGS_((
+ Tk_TextLayout layout, int x, int y));
+/* 57 */
+EXTERN void Tk_Draw3DPolygon _ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border,
+ XPoint * pointPtr, int numPoints,
+ int borderWidth, int leftRelief));
+/* 58 */
+EXTERN void Tk_Draw3DRectangle _ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height,
+ int borderWidth, int relief));
+/* 59 */
+EXTERN void Tk_DrawChars _ANSI_ARGS_((Display * display,
+ Drawable drawable, GC gc, Tk_Font tkfont,
+ CONST char * source, int numBytes, int x,
+ int y));
+/* 60 */
+EXTERN void Tk_DrawFocusHighlight _ANSI_ARGS_((Tk_Window tkwin,
+ GC gc, int width, Drawable drawable));
+/* 61 */
+EXTERN void Tk_DrawTextLayout _ANSI_ARGS_((Display * display,
+ Drawable drawable, GC gc,
+ Tk_TextLayout layout, int x, int y,
+ int firstChar, int lastChar));
+/* 62 */
+EXTERN void Tk_Fill3DPolygon _ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border,
+ XPoint * pointPtr, int numPoints,
+ int borderWidth, int leftRelief));
+/* 63 */
+EXTERN void Tk_Fill3DRectangle _ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height,
+ int borderWidth, int relief));
+/* 64 */
+EXTERN Tk_PhotoHandle Tk_FindPhoto _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * imageName));
+/* 65 */
+EXTERN Font Tk_FontId _ANSI_ARGS_((Tk_Font font));
+/* 66 */
+EXTERN void Tk_Free3DBorder _ANSI_ARGS_((Tk_3DBorder border));
+/* 67 */
+EXTERN void Tk_FreeBitmap _ANSI_ARGS_((Display * display,
+ Pixmap bitmap));
+/* 68 */
+EXTERN void Tk_FreeColor _ANSI_ARGS_((XColor * colorPtr));
+/* 69 */
+EXTERN void Tk_FreeColormap _ANSI_ARGS_((Display * display,
+ Colormap colormap));
+/* 70 */
+EXTERN void Tk_FreeCursor _ANSI_ARGS_((Display * display,
+ Tk_Cursor cursor));
+/* 71 */
+EXTERN void Tk_FreeFont _ANSI_ARGS_((Tk_Font f));
+/* 72 */
+EXTERN void Tk_FreeGC _ANSI_ARGS_((Display * display, GC gc));
+/* 73 */
+EXTERN void Tk_FreeImage _ANSI_ARGS_((Tk_Image image));
+/* 74 */
+EXTERN void Tk_FreeOptions _ANSI_ARGS_((Tk_ConfigSpec * specs,
+ char * widgRec, Display * display,
+ int needFlags));
+/* 75 */
+EXTERN void Tk_FreePixmap _ANSI_ARGS_((Display * display,
+ Pixmap pixmap));
+/* 76 */
+EXTERN void Tk_FreeTextLayout _ANSI_ARGS_((
+ Tk_TextLayout textLayout));
+/* 77 */
+EXTERN void Tk_FreeXId _ANSI_ARGS_((Display * display, XID xid));
+/* 78 */
+EXTERN GC Tk_GCForColor _ANSI_ARGS_((XColor * colorPtr,
+ Drawable drawable));
+/* 79 */
+EXTERN void Tk_GeometryRequest _ANSI_ARGS_((Tk_Window tkwin,
+ int reqWidth, int reqHeight));
+/* 80 */
+EXTERN Tk_3DBorder Tk_Get3DBorder _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid colorName));
+/* 81 */
+EXTERN void Tk_GetAllBindings _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object));
+/* 82 */
+EXTERN int Tk_GetAnchor _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, Tk_Anchor * anchorPtr));
+/* 83 */
+EXTERN CONST84_RETURN char * Tk_GetAtomName _ANSI_ARGS_((Tk_Window tkwin,
+ Atom atom));
+/* 84 */
+EXTERN Tcl_Obj * Tk_GetBinding _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventStr));
+/* 85 */
+EXTERN Pixmap Tk_GetBitmap _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str));
+/* 86 */
+EXTERN Pixmap Tk_GetBitmapFromData _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ CONST char * source, int width, int height));
+/* 87 */
+EXTERN int Tk_GetCapStyle _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * capPtr));
+/* 88 */
+EXTERN XColor * Tk_GetColor _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid name));
+/* 89 */
+EXTERN XColor * Tk_GetColorByValue _ANSI_ARGS_((Tk_Window tkwin,
+ XColor * colorPtr));
+/* 90 */
+EXTERN Colormap Tk_GetColormap _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str));
+/* 91 */
+EXTERN Tk_Cursor Tk_GetCursor _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid str));
+/* 92 */
+EXTERN Tk_Cursor Tk_GetCursorFromData _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ CONST char * source, CONST char * mask,
+ int width, int height, int xHot, int yHot,
+ Tk_Uid fg, Tk_Uid bg));
+/* 93 */
+EXTERN Tk_Font Tk_GetFont _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str));
+/* 94 */
+EXTERN Tk_Font Tk_GetFontFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 95 */
+EXTERN void Tk_GetFontMetrics _ANSI_ARGS_((Tk_Font font,
+ Tk_FontMetrics * fmPtr));
+/* 96 */
+EXTERN GC Tk_GetGC _ANSI_ARGS_((Tk_Window tkwin,
+ unsigned long valueMask,
+ XGCValues * valuePtr));
+/* 97 */
+EXTERN Tk_Image Tk_GetImage _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * name,
+ Tk_ImageChangedProc * changeProc,
+ ClientData clientData));
+/* 98 */
+EXTERN ClientData Tk_GetImageMasterData _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ Tk_ImageType ** typePtrPtr));
+/* 99 */
+EXTERN Tk_ItemType * Tk_GetItemTypes _ANSI_ARGS_((void));
+/* 100 */
+EXTERN int Tk_GetJoinStyle _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * joinPtr));
+/* 101 */
+EXTERN int Tk_GetJustify _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, Tk_Justify * justifyPtr));
+/* 102 */
+EXTERN int Tk_GetNumMainWindows _ANSI_ARGS_((void));
+/* 103 */
+EXTERN Tk_Uid Tk_GetOption _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name, CONST char * className));
+/* 104 */
+EXTERN int Tk_GetPixels _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str,
+ int * intPtr));
+/* 105 */
+EXTERN Pixmap Tk_GetPixmap _ANSI_ARGS_((Display * display,
+ Drawable d, int width, int height, int depth));
+/* 106 */
+EXTERN int Tk_GetRelief _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, int * reliefPtr));
+/* 107 */
+EXTERN void Tk_GetRootCoords _ANSI_ARGS_((Tk_Window tkwin,
+ int * xPtr, int * yPtr));
+/* 108 */
+EXTERN int Tk_GetScrollInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ int argc, CONST84 Tcl_Obj *CONST *objv,
+ double * dblPtr, int * intPtr));
+/* 109 */
+EXTERN int Tk_GetScreenMM _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str,
+ double * doublePtr));
+/* 110 */
+EXTERN int Tk_GetSelection _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Atom selection, Atom target,
+ Tk_GetSelProc * proc, ClientData clientData));
+/* 111 */
+EXTERN Tk_Uid Tk_GetUid _ANSI_ARGS_((CONST char * str));
+/* 112 */
+EXTERN Visual * Tk_GetVisual _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj *str,
+ int * depthPtr, Colormap * colormapPtr));
+/* 113 */
+EXTERN void Tk_GetVRootGeometry _ANSI_ARGS_((Tk_Window tkwin,
+ int * xPtr, int * yPtr, int * widthPtr,
+ int * heightPtr));
+/* 114 */
+EXTERN int Tk_Grab _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, int grabGlobal));
+/* 115 */
+EXTERN void Tk_HandleEvent _ANSI_ARGS_((XEvent * eventPtr));
+/* 116 */
+EXTERN Tk_Window Tk_IdToWindow _ANSI_ARGS_((Display * display,
+ Window window));
+/* 117 */
+EXTERN void Tk_ImageChanged _ANSI_ARGS_((Tk_ImageMaster master,
+ int x, int y, int width, int height,
+ int imageWidth, int imageHeight));
+/* 118 */
+EXTERN int Tk_Init _ANSI_ARGS_((Tcl_Interp * interp));
+/* 119 */
+EXTERN Atom Tk_InternAtom _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name));
+/* 120 */
+EXTERN int Tk_IntersectTextLayout _ANSI_ARGS_((
+ Tk_TextLayout layout, int x, int y,
+ int width, int height));
+/* 121 */
+EXTERN void Tk_MaintainGeometry _ANSI_ARGS_((Tk_Window slave,
+ Tk_Window master, int x, int y, int width,
+ int height));
+/* 122 */
+EXTERN Tk_Window Tk_MainWindow _ANSI_ARGS_((Tcl_Interp * interp));
+/* 123 */
+EXTERN void Tk_MakeWindowExist _ANSI_ARGS_((Tk_Window tkwin));
+/* 124 */
+EXTERN void Tk_ManageGeometry _ANSI_ARGS_((Tk_Window tkwin,
+ Tk_GeomMgr * mgrPtr, ClientData clientData));
+/* 125 */
+EXTERN void Tk_MapWindow _ANSI_ARGS_((Tk_Window tkwin));
+/* 126 */
+EXTERN int Tk_MeasureChars _ANSI_ARGS_((Tk_Font tkfont,
+ CONST char * source, int numBytes,
+ int maxPixels, int flags, int * lengthPtr));
+/* 127 */
+EXTERN void Tk_MoveResizeWindow _ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y, int width, int height));
+/* 128 */
+EXTERN void Tk_MoveWindow _ANSI_ARGS_((Tk_Window tkwin, int x,
+ int y));
+/* 129 */
+EXTERN void Tk_MoveToplevelWindow _ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y));
+/* 130 */
+EXTERN CONST84_RETURN char * Tk_NameOf3DBorder _ANSI_ARGS_((
+ Tk_3DBorder border));
+/* 131 */
+EXTERN CONST84_RETURN char * Tk_NameOfAnchor _ANSI_ARGS_((Tk_Anchor anchor));
+/* 132 */
+EXTERN CONST84_RETURN char * Tk_NameOfBitmap _ANSI_ARGS_((Display * display,
+ Pixmap bitmap));
+/* 133 */
+EXTERN CONST84_RETURN char * Tk_NameOfCapStyle _ANSI_ARGS_((int cap));
+/* 134 */
+EXTERN CONST84_RETURN char * Tk_NameOfColor _ANSI_ARGS_((XColor * colorPtr));
+/* 135 */
+EXTERN CONST84_RETURN char * Tk_NameOfCursor _ANSI_ARGS_((Display * display,
+ Tk_Cursor cursor));
+/* 136 */
+EXTERN CONST84_RETURN char * Tk_NameOfFont _ANSI_ARGS_((Tk_Font font));
+/* 137 */
+EXTERN CONST84_RETURN char * Tk_NameOfImage _ANSI_ARGS_((
+ Tk_ImageMaster imageMaster));
+/* 138 */
+EXTERN CONST84_RETURN char * Tk_NameOfJoinStyle _ANSI_ARGS_((int join));
+/* 139 */
+EXTERN CONST84_RETURN char * Tk_NameOfJustify _ANSI_ARGS_((
+ Tk_Justify justify));
+/* 140 */
+EXTERN CONST84_RETURN char * Tk_NameOfRelief _ANSI_ARGS_((int relief));
+/* 141 */
+EXTERN Tk_Window Tk_NameToWindow _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * pathName, Tk_Window tkwin));
+/* 142 */
+EXTERN void Tk_OwnSelection _ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection, Tk_LostSelProc * proc,
+ ClientData clientData));
+/* 143 */
+EXTERN int Tk_ParseArgv _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, int * argcPtr,
+ CONST84 Tcl_Obj *CONST *objv, Tk_ArgvInfo * argTable,
+ int flags));
+/* 144 */
+EXTERN void Tk_PhotoPutBlock_NoComposite _ANSI_ARGS_((
+ Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock * blockPtr, int x, int y,
+ int width, int height));
+/* 145 */
+EXTERN void Tk_PhotoPutZoomedBlock_NoComposite _ANSI_ARGS_((
+ Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock * blockPtr, int x, int y,
+ int width, int height, int zoomX, int zoomY,
+ int subsampleX, int subsampleY));
+/* 146 */
+EXTERN int Tk_PhotoGetImage _ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock * blockPtr));
+/* 147 */
+EXTERN void Tk_PhotoBlank _ANSI_ARGS_((Tk_PhotoHandle handle));
+/* 148 */
+EXTERN void Tk_PhotoExpand _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int width, int height));
+/* 149 */
+EXTERN void Tk_PhotoGetSize _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int * widthPtr, int * heightPtr));
+/* 150 */
+EXTERN void Tk_PhotoSetSize _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int width, int height));
+/* 151 */
+EXTERN int Tk_PointToChar _ANSI_ARGS_((Tk_TextLayout layout,
+ int x, int y));
+/* 152 */
+EXTERN int Tk_PostscriptFontName _ANSI_ARGS_((Tk_Font tkfont,
+ Tcl_DString * dsPtr));
+/* 153 */
+EXTERN void Tk_PreserveColormap _ANSI_ARGS_((Display * display,
+ Colormap colormap));
+/* 154 */
+EXTERN void Tk_QueueWindowEvent _ANSI_ARGS_((XEvent * eventPtr,
+ Tcl_QueuePosition position));
+/* 155 */
+EXTERN void Tk_RedrawImage _ANSI_ARGS_((Tk_Image image,
+ int imageX, int imageY, int width,
+ int height, Drawable drawable, int drawableX,
+ int drawableY));
+/* 156 */
+EXTERN void Tk_ResizeWindow _ANSI_ARGS_((Tk_Window tkwin,
+ int width, int height));
+/* 157 */
+EXTERN int Tk_RestackWindow _ANSI_ARGS_((Tk_Window tkwin,
+ int aboveBelow, Tk_Window other));
+/* 158 */
+EXTERN Tk_RestrictProc * Tk_RestrictEvents _ANSI_ARGS_((
+ Tk_RestrictProc * proc, ClientData arg,
+ ClientData * prevArgPtr));
+/* 159 */
+EXTERN int Tk_SafeInit _ANSI_ARGS_((Tcl_Interp * interp));
+/* 160 */
+EXTERN CONST char * Tk_SetAppName _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name));
+/* 161 */
+EXTERN void Tk_SetBackgroundFromBorder _ANSI_ARGS_((
+ Tk_Window tkwin, Tk_3DBorder border));
+/* 162 */
+EXTERN void Tk_SetClass _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * className));
+/* 163 */
+EXTERN void Tk_SetGrid _ANSI_ARGS_((Tk_Window tkwin,
+ int reqWidth, int reqHeight, int gridWidth,
+ int gridHeight));
+/* 164 */
+EXTERN void Tk_SetInternalBorder _ANSI_ARGS_((Tk_Window tkwin,
+ int width));
+/* 165 */
+EXTERN void Tk_SetWindowBackground _ANSI_ARGS_((Tk_Window tkwin,
+ unsigned long pixel));
+/* 166 */
+EXTERN void Tk_SetWindowBackgroundPixmap _ANSI_ARGS_((
+ Tk_Window tkwin, Pixmap pixmap));
+/* 167 */
+EXTERN void Tk_SetWindowBorder _ANSI_ARGS_((Tk_Window tkwin,
+ unsigned long pixel));
+/* 168 */
+EXTERN void Tk_SetWindowBorderWidth _ANSI_ARGS_((Tk_Window tkwin,
+ int width));
+/* 169 */
+EXTERN void Tk_SetWindowBorderPixmap _ANSI_ARGS_((
+ Tk_Window tkwin, Pixmap pixmap));
+/* 170 */
+EXTERN void Tk_SetWindowColormap _ANSI_ARGS_((Tk_Window tkwin,
+ Colormap colormap));
+/* 171 */
+EXTERN int Tk_SetWindowVisual _ANSI_ARGS_((Tk_Window tkwin,
+ Visual * visual, int depth,
+ Colormap colormap));
+/* 172 */
+EXTERN void Tk_SizeOfBitmap _ANSI_ARGS_((Display * display,
+ Pixmap bitmap, int * widthPtr,
+ int * heightPtr));
+/* 173 */
+EXTERN void Tk_SizeOfImage _ANSI_ARGS_((Tk_Image image,
+ int * widthPtr, int * heightPtr));
+/* 174 */
+EXTERN int Tk_StrictMotif _ANSI_ARGS_((Tk_Window tkwin));
+/* 175 */
+EXTERN void Tk_TextLayoutToPostscript _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_TextLayout layout));
+/* 176 */
+EXTERN int Tk_TextWidth _ANSI_ARGS_((Tk_Font font,
+ CONST char * str, int numBytes));
+/* 177 */
+EXTERN void Tk_UndefineCursor _ANSI_ARGS_((Tk_Window window));
+/* 178 */
+EXTERN void Tk_UnderlineChars _ANSI_ARGS_((Display * display,
+ Drawable drawable, GC gc, Tk_Font tkfont,
+ CONST char * source, int x, int y,
+ int firstByte, int lastByte));
+/* 179 */
+EXTERN void Tk_UnderlineTextLayout _ANSI_ARGS_((
+ Display * display, Drawable drawable, GC gc,
+ Tk_TextLayout layout, int x, int y,
+ int underline));
+/* 180 */
+EXTERN void Tk_Ungrab _ANSI_ARGS_((Tk_Window tkwin));
+/* 181 */
+EXTERN void Tk_UnmaintainGeometry _ANSI_ARGS_((Tk_Window slave,
+ Tk_Window master));
+/* 182 */
+EXTERN void Tk_UnmapWindow _ANSI_ARGS_((Tk_Window tkwin));
+/* 183 */
+EXTERN void Tk_UnsetGrid _ANSI_ARGS_((Tk_Window tkwin));
+/* 184 */
+EXTERN void Tk_UpdatePointer _ANSI_ARGS_((Tk_Window tkwin, int x,
+ int y, int state));
+/* 185 */
+EXTERN Pixmap Tk_AllocBitmapFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 186 */
+EXTERN Tk_3DBorder Tk_Alloc3DBorderFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 187 */
+EXTERN XColor * Tk_AllocColorFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 188 */
+EXTERN Tk_Cursor Tk_AllocCursorFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 189 */
+EXTERN Tk_Font Tk_AllocFontFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr));
+/* 190 */
+EXTERN Tk_OptionTable Tk_CreateOptionTable _ANSI_ARGS_((
+ Tcl_Interp * interp,
+ CONST Tk_OptionSpec * templatePtr));
+/* 191 */
+EXTERN void Tk_DeleteOptionTable _ANSI_ARGS_((
+ Tk_OptionTable optionTable));
+/* 192 */
+EXTERN void Tk_Free3DBorderFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 193 */
+EXTERN void Tk_FreeBitmapFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 194 */
+EXTERN void Tk_FreeColorFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 195 */
+EXTERN void Tk_FreeConfigOptions _ANSI_ARGS_((char * recordPtr,
+ Tk_OptionTable optionToken, Tk_Window tkwin));
+/* 196 */
+EXTERN void Tk_FreeSavedOptions _ANSI_ARGS_((
+ Tk_SavedOptions * savePtr));
+/* 197 */
+EXTERN void Tk_FreeCursorFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 198 */
+EXTERN void Tk_FreeFontFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 199 */
+EXTERN Tk_3DBorder Tk_Get3DBorderFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 200 */
+EXTERN int Tk_GetAnchorFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, Tk_Anchor * anchorPtr));
+/* 201 */
+EXTERN Pixmap Tk_GetBitmapFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 202 */
+EXTERN XColor * Tk_GetColorFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 203 */
+EXTERN Tk_Cursor Tk_GetCursorFromObj _ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr));
+/* 204 */
+EXTERN Tcl_Obj * Tk_GetOptionInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionTable,
+ Tcl_Obj * namePtr, Tk_Window tkwin));
+/* 205 */
+EXTERN Tcl_Obj * Tk_GetOptionValue _ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionTable,
+ Tcl_Obj * namePtr, Tk_Window tkwin));
+/* 206 */
+EXTERN int Tk_GetJustifyFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ Tk_Justify * justifyPtr));
+/* 207 */
+EXTERN int Tk_GetMMFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr,
+ double * doublePtr));
+/* 208 */
+EXTERN int Tk_GetPixelsFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr,
+ int * intPtr));
+/* 209 */
+EXTERN int Tk_GetReliefFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int * resultPtr));
+/* 210 */
+EXTERN int Tk_GetScrollInfoObj _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[],
+ double * dblPtr, int * intPtr));
+/* 211 */
+EXTERN int Tk_InitOptions _ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionToken,
+ Tk_Window tkwin));
+/* 212 */
+EXTERN void Tk_MainEx _ANSI_ARGS_((int argc, Tcl_Obj *CONST *objv,
+ Tcl_AppInitProc * appInitProc,
+ Tcl_Interp * interp));
+/* 213 */
+EXTERN void Tk_RestoreSavedOptions _ANSI_ARGS_((
+ Tk_SavedOptions * savePtr));
+/* 214 */
+EXTERN int Tk_SetOptions _ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionTable,
+ int objc, Tcl_Obj *CONST objv[],
+ Tk_Window tkwin, Tk_SavedOptions * savePtr,
+ int * maskPtr));
+/* 215 */
+EXTERN void Tk_InitConsoleChannels _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 216 */
+EXTERN int Tk_CreateConsoleWindow _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 217 */
+EXTERN void Tk_CreateSmoothMethod _ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tk_SmoothMethod * method));
+/* Slot 218 is reserved */
+/* Slot 219 is reserved */
+/* 220 */
+EXTERN int Tk_GetDash _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *value, Tk_Dash * dash));
+/* 221 */
+EXTERN void Tk_CreateOutline _ANSI_ARGS_((Tk_Outline * outline));
+/* 222 */
+EXTERN void Tk_DeleteOutline _ANSI_ARGS_((Display * display,
+ Tk_Outline * outline));
+/* 223 */
+EXTERN int Tk_ConfigOutlineGC _ANSI_ARGS_((XGCValues * gcValues,
+ Tk_Canvas canvas, Tk_Item * item,
+ Tk_Outline * outline));
+/* 224 */
+EXTERN int Tk_ChangeOutlineGC _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item * item, Tk_Outline * outline));
+/* 225 */
+EXTERN int Tk_ResetOutlineGC _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item * item, Tk_Outline * outline));
+/* 226 */
+EXTERN int Tk_CanvasPsOutline _ANSI_ARGS_((Tk_Canvas canvas,
+ Tk_Item * item, Tk_Outline * outline));
+/* 227 */
+EXTERN void Tk_SetTSOrigin _ANSI_ARGS_((Tk_Window tkwin, GC gc,
+ int x, int y));
+/* 228 */
+EXTERN int Tk_CanvasGetCoordFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Canvas canvas,
+ Tcl_Obj * obj, double * doublePtr));
+/* 229 */
+EXTERN void Tk_CanvasSetOffset _ANSI_ARGS_((Tk_Canvas canvas,
+ GC gc, Tk_TSOffset * offset));
+/* 230 */
+EXTERN void Tk_DitherPhoto _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int x, int y, int width, int height));
+/* 231 */
+EXTERN int Tk_PostscriptBitmap _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_PostscriptInfo psInfo,
+ Pixmap bitmap, int startX, int startY,
+ int width, int height));
+/* 232 */
+EXTERN int Tk_PostscriptColor _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PostscriptInfo psInfo, XColor * colorPtr));
+/* 233 */
+EXTERN int Tk_PostscriptFont _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PostscriptInfo psInfo, Tk_Font font));
+/* 234 */
+EXTERN int Tk_PostscriptImage _ANSI_ARGS_((Tk_Image image,
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tk_PostscriptInfo psinfo, int x, int y,
+ int width, int height, int prepass));
+/* 235 */
+EXTERN void Tk_PostscriptPath _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PostscriptInfo psInfo, double * coordPtr,
+ int numPoints));
+/* 236 */
+EXTERN int Tk_PostscriptStipple _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tk_PostscriptInfo psInfo, Pixmap bitmap));
+/* 237 */
+EXTERN double Tk_PostscriptY _ANSI_ARGS_((double y,
+ Tk_PostscriptInfo psInfo));
+/* 238 */
+EXTERN int Tk_PostscriptPhoto _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PhotoImageBlock * blockPtr,
+ Tk_PostscriptInfo psInfo, int width,
+ int height));
+/* 239 */
+EXTERN void Tk_CreateClientMessageHandler _ANSI_ARGS_((
+ Tk_ClientMessageProc * proc));
+/* 240 */
+EXTERN void Tk_DeleteClientMessageHandler _ANSI_ARGS_((
+ Tk_ClientMessageProc * proc));
+/* 241 */
+EXTERN Tk_Window Tk_CreateAnonymousWindow _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window parent,
+ CONST char * screenName));
+/* 242 */
+EXTERN void Tk_SetClassProcs _ANSI_ARGS_((Tk_Window tkwin,
+ Tk_ClassProcs * procs,
+ ClientData instanceData));
+/* 243 */
+EXTERN void Tk_SetInternalBorderEx _ANSI_ARGS_((Tk_Window tkwin,
+ int left, int right, int top, int bottom));
+/* 244 */
+EXTERN void Tk_SetMinimumRequestSize _ANSI_ARGS_((
+ Tk_Window tkwin, int minWidth, int minHeight));
+/* 245 */
+EXTERN void Tk_SetCaretPos _ANSI_ARGS_((Tk_Window tkwin, int x,
+ int y, int height));
+/* 246 */
+EXTERN void Tk_PhotoPutBlock _ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock * blockPtr, int x, int y,
+ int width, int height, int compRule));
+/* 247 */
+EXTERN void Tk_PhotoPutZoomedBlock _ANSI_ARGS_((
+ Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock * blockPtr, int x, int y,
+ int width, int height, int zoomX, int zoomY,
+ int subsampleX, int subsampleY, int compRule));
+/* 248 */
+EXTERN int Tk_CollapseMotionEvents _ANSI_ARGS_((
+ Display * display, int collapse));
+/* 249 */
+EXTERN Tk_StyleEngine Tk_RegisterStyleEngine _ANSI_ARGS_((
+ CONST char * name, Tk_StyleEngine parent));
+/* 250 */
+EXTERN Tk_StyleEngine Tk_GetStyleEngine _ANSI_ARGS_((CONST char * name));
+/* 251 */
+EXTERN int Tk_RegisterStyledElement _ANSI_ARGS_((
+ Tk_StyleEngine engine,
+ Tk_ElementSpec * templatePtr));
+/* 252 */
+EXTERN int Tk_GetElementId _ANSI_ARGS_((CONST char * name));
+/* 253 */
+EXTERN Tk_Style Tk_CreateStyle _ANSI_ARGS_((CONST char * name,
+ Tk_StyleEngine engine, ClientData clientData));
+/* 254 */
+EXTERN Tk_Style Tk_GetStyle _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name));
+/* 255 */
+EXTERN void Tk_FreeStyle _ANSI_ARGS_((Tk_Style style));
+/* 256 */
+EXTERN CONST char * Tk_NameOfStyle _ANSI_ARGS_((Tk_Style style));
+/* 257 */
+EXTERN Tk_Style Tk_AllocStyleFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr));
+/* 258 */
+EXTERN Tk_Style Tk_GetStyleFromObj _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 259 */
+EXTERN void Tk_FreeStyleFromObj _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 260 */
+EXTERN Tk_StyledElement Tk_GetStyledElement _ANSI_ARGS_((Tk_Style style,
+ int elementId, Tk_OptionTable optionTable));
+/* 261 */
+EXTERN void Tk_GetElementSize _ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin, int width, int height,
+ int inner, int * widthPtr, int * heightPtr));
+/* 262 */
+EXTERN void Tk_GetElementBox _ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin, int x, int y, int width,
+ int height, int inner, int * xPtr,
+ int * yPtr, int * widthPtr, int * heightPtr));
+/* 263 */
+EXTERN int Tk_GetElementBorderWidth _ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin));
+/* 264 */
+EXTERN void Tk_DrawElement _ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin, Drawable d, int x, int y,
+ int width, int height, int state));
+
+typedef struct TkStubHooks {
+ struct TkPlatStubs *tkPlatStubs;
+ struct TkIntStubs *tkIntStubs;
+ struct TkIntPlatStubs *tkIntPlatStubs;
+ struct TkIntXlibStubs *tkIntXlibStubs;
+} TkStubHooks;
+
+typedef struct TkStubs {
+ int magic;
+ struct TkStubHooks *hooks;
+
+ void (*tk_MainLoop) _ANSI_ARGS_((void)); /* 0 */
+ XColor * (*tk_3DBorderColor) _ANSI_ARGS_((Tk_3DBorder border)); /* 1 */
+ GC (*tk_3DBorderGC) _ANSI_ARGS_((Tk_Window tkwin, Tk_3DBorder border, int which)); /* 2 */
+ void (*tk_3DHorizontalBevel) _ANSI_ARGS_((Tk_Window tkwin, Drawable drawable, Tk_3DBorder border, int x, int y, int width, int height, int leftIn, int rightIn, int topBevel, int relief)); /* 3 */
+ void (*tk_3DVerticalBevel) _ANSI_ARGS_((Tk_Window tkwin, Drawable drawable, Tk_3DBorder border, int x, int y, int width, int height, int leftBevel, int relief)); /* 4 */
+ void (*tk_AddOption) _ANSI_ARGS_((Tk_Window tkwin, CONST char * name, CONST char * value, int priority)); /* 5 */
+ void (*tk_BindEvent) _ANSI_ARGS_((Tk_BindingTable bindingTable, XEvent * eventPtr, Tk_Window tkwin, int numObjects, ClientData * objectPtr)); /* 6 */
+ void (*tk_CanvasDrawableCoords) _ANSI_ARGS_((Tk_Canvas canvas, double x, double y, short * drawableXPtr, short * drawableYPtr)); /* 7 */
+ void (*tk_CanvasEventuallyRedraw) _ANSI_ARGS_((Tk_Canvas canvas, int x1, int y1, int x2, int y2)); /* 8 */
+ int (*tk_CanvasGetCoord) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, CONST char * str, double * doublePtr)); /* 9 */
+ Tk_CanvasTextInfo * (*tk_CanvasGetTextInfo) _ANSI_ARGS_((Tk_Canvas canvas)); /* 10 */
+ int (*tk_CanvasPsBitmap) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, Pixmap bitmap, int x, int y, int width, int height)); /* 11 */
+ int (*tk_CanvasPsColor) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, XColor * colorPtr)); /* 12 */
+ int (*tk_CanvasPsFont) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, Tk_Font font)); /* 13 */
+ void (*tk_CanvasPsPath) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, double * coordPtr, int numPoints)); /* 14 */
+ int (*tk_CanvasPsStipple) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, Pixmap bitmap)); /* 15 */
+ double (*tk_CanvasPsY) _ANSI_ARGS_((Tk_Canvas canvas, double y)); /* 16 */
+ void (*tk_CanvasSetStippleOrigin) _ANSI_ARGS_((Tk_Canvas canvas, GC gc)); /* 17 */
+ int (*tk_CanvasTagsParseProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj *value, char * widgRec, int offset)); /* 18 */
+ Tcl_Obj * (*tk_CanvasTagsPrintProc) _ANSI_ARGS_((ClientData clientData, Tk_Window tkwin, char * widgRec, int offset, Tcl_FreeProc ** freeProcPtr)); /* 19 */
+ Tk_Window (*tk_CanvasTkwin) _ANSI_ARGS_((Tk_Canvas canvas)); /* 20 */
+ void (*tk_CanvasWindowCoords) _ANSI_ARGS_((Tk_Canvas canvas, double x, double y, short * screenXPtr, short * screenYPtr)); /* 21 */
+ void (*tk_ChangeWindowAttributes) _ANSI_ARGS_((Tk_Window tkwin, unsigned long valueMask, XSetWindowAttributes * attsPtr)); /* 22 */
+ int (*tk_CharBbox) _ANSI_ARGS_((Tk_TextLayout layout, int index, int * xPtr, int * yPtr, int * widthPtr, int * heightPtr)); /* 23 */
+ void (*tk_ClearSelection) _ANSI_ARGS_((Tk_Window tkwin, Atom selection)); /* 24 */
+ int (*tk_ClipboardAppend) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Atom target, Atom format, char* buffer)); /* 25 */
+ int (*tk_ClipboardClear) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin)); /* 26 */
+ int (*tk_ConfigureInfo) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_ConfigSpec * specs, char * widgRec, CONST char * argvName, int flags)); /* 27 */
+ int (*tk_ConfigureValue) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_ConfigSpec * specs, char * widgRec, CONST char * argvName, int flags)); /* 28 */
+ int (*tk_ConfigureWidget) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_ConfigSpec * specs, int argc, CONST84 Tcl_Obj *CONST *objv, char * widgRec, int flags)); /* 29 */
+ void (*tk_ConfigureWindow) _ANSI_ARGS_((Tk_Window tkwin, unsigned int valueMask, XWindowChanges * valuePtr)); /* 30 */
+ Tk_TextLayout (*tk_ComputeTextLayout) _ANSI_ARGS_((Tk_Font font, CONST char * str, int numChars, int wrapLength, Tk_Justify justify, int flags, int * widthPtr, int * heightPtr)); /* 31 */
+ Tk_Window (*tk_CoordsToWindow) _ANSI_ARGS_((int rootX, int rootY, Tk_Window tkwin)); /* 32 */
+ unsigned long (*tk_CreateBinding) _ANSI_ARGS_((Tcl_Interp * interp, Tk_BindingTable bindingTable, ClientData object, CONST char * eventStr, CONST char * command, int append)); /* 33 */
+ Tk_BindingTable (*tk_CreateBindingTable) _ANSI_ARGS_((Tcl_Interp * interp)); /* 34 */
+ Tk_ErrorHandler (*tk_CreateErrorHandler) _ANSI_ARGS_((Display * display, int errNum, int request, int minorCode, Tk_ErrorProc * errorProc, ClientData clientData)); /* 35 */
+ void (*tk_CreateEventHandler) _ANSI_ARGS_((Tk_Window token, unsigned long mask, Tk_EventProc * proc, ClientData clientData)); /* 36 */
+ void (*tk_CreateGenericHandler) _ANSI_ARGS_((Tk_GenericProc * proc, ClientData clientData)); /* 37 */
+ void (*tk_CreateImageType) _ANSI_ARGS_((Tk_ImageType * typePtr)); /* 38 */
+ void (*tk_CreateItemType) _ANSI_ARGS_((Tk_ItemType * typePtr)); /* 39 */
+ void (*tk_CreatePhotoImageFormat) _ANSI_ARGS_((Tk_PhotoImageFormat * formatPtr)); /* 40 */
+ void (*tk_CreateSelHandler) _ANSI_ARGS_((Tk_Window tkwin, Atom selection, Atom target, Tk_SelectionProc * proc, ClientData clientData, Atom format)); /* 41 */
+ Tk_Window (*tk_CreateWindow) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window parent, CONST char * name, CONST char * screenName)); /* 42 */
+ Tk_Window (*tk_CreateWindowFromPath) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * pathName, CONST char * screenName)); /* 43 */
+ int (*tk_DefineBitmap) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * source, int width, int height)); /* 44 */
+ void (*tk_DefineCursor) _ANSI_ARGS_((Tk_Window window, Tk_Cursor cursor)); /* 45 */
+ void (*tk_DeleteAllBindings) _ANSI_ARGS_((Tk_BindingTable bindingTable, ClientData object)); /* 46 */
+ int (*tk_DeleteBinding) _ANSI_ARGS_((Tcl_Interp * interp, Tk_BindingTable bindingTable, ClientData object, CONST char * eventStr)); /* 47 */
+ void (*tk_DeleteBindingTable) _ANSI_ARGS_((Tk_BindingTable bindingTable)); /* 48 */
+ void (*tk_DeleteErrorHandler) _ANSI_ARGS_((Tk_ErrorHandler handler)); /* 49 */
+ void (*tk_DeleteEventHandler) _ANSI_ARGS_((Tk_Window token, unsigned long mask, Tk_EventProc * proc, ClientData clientData)); /* 50 */
+ void (*tk_DeleteGenericHandler) _ANSI_ARGS_((Tk_GenericProc * proc, ClientData clientData)); /* 51 */
+ void (*tk_DeleteImage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 52 */
+ void (*tk_DeleteSelHandler) _ANSI_ARGS_((Tk_Window tkwin, Atom selection, Atom target)); /* 53 */
+ void (*tk_DestroyWindow) _ANSI_ARGS_((Tk_Window tkwin)); /* 54 */
+ CONST84_RETURN char * (*tk_DisplayName) _ANSI_ARGS_((Tk_Window tkwin)); /* 55 */
+ int (*tk_DistanceToTextLayout) _ANSI_ARGS_((Tk_TextLayout layout, int x, int y)); /* 56 */
+ void (*tk_Draw3DPolygon) _ANSI_ARGS_((Tk_Window tkwin, Drawable drawable, Tk_3DBorder border, XPoint * pointPtr, int numPoints, int borderWidth, int leftRelief)); /* 57 */
+ void (*tk_Draw3DRectangle) _ANSI_ARGS_((Tk_Window tkwin, Drawable drawable, Tk_3DBorder border, int x, int y, int width, int height, int borderWidth, int relief)); /* 58 */
+ void (*tk_DrawChars) _ANSI_ARGS_((Display * display, Drawable drawable, GC gc, Tk_Font tkfont, CONST char * source, int numBytes, int x, int y)); /* 59 */
+ void (*tk_DrawFocusHighlight) _ANSI_ARGS_((Tk_Window tkwin, GC gc, int width, Drawable drawable)); /* 60 */
+ void (*tk_DrawTextLayout) _ANSI_ARGS_((Display * display, Drawable drawable, GC gc, Tk_TextLayout layout, int x, int y, int firstChar, int lastChar)); /* 61 */
+ void (*tk_Fill3DPolygon) _ANSI_ARGS_((Tk_Window tkwin, Drawable drawable, Tk_3DBorder border, XPoint * pointPtr, int numPoints, int borderWidth, int leftRelief)); /* 62 */
+ void (*tk_Fill3DRectangle) _ANSI_ARGS_((Tk_Window tkwin, Drawable drawable, Tk_3DBorder border, int x, int y, int width, int height, int borderWidth, int relief)); /* 63 */
+ Tk_PhotoHandle (*tk_FindPhoto) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * imageName)); /* 64 */
+ Font (*tk_FontId) _ANSI_ARGS_((Tk_Font font)); /* 65 */
+ void (*tk_Free3DBorder) _ANSI_ARGS_((Tk_3DBorder border)); /* 66 */
+ void (*tk_FreeBitmap) _ANSI_ARGS_((Display * display, Pixmap bitmap)); /* 67 */
+ void (*tk_FreeColor) _ANSI_ARGS_((XColor * colorPtr)); /* 68 */
+ void (*tk_FreeColormap) _ANSI_ARGS_((Display * display, Colormap colormap)); /* 69 */
+ void (*tk_FreeCursor) _ANSI_ARGS_((Display * display, Tk_Cursor cursor)); /* 70 */
+ void (*tk_FreeFont) _ANSI_ARGS_((Tk_Font f)); /* 71 */
+ void (*tk_FreeGC) _ANSI_ARGS_((Display * display, GC gc)); /* 72 */
+ void (*tk_FreeImage) _ANSI_ARGS_((Tk_Image image)); /* 73 */
+ void (*tk_FreeOptions) _ANSI_ARGS_((Tk_ConfigSpec * specs, char * widgRec, Display * display, int needFlags)); /* 74 */
+ void (*tk_FreePixmap) _ANSI_ARGS_((Display * display, Pixmap pixmap)); /* 75 */
+ void (*tk_FreeTextLayout) _ANSI_ARGS_((Tk_TextLayout textLayout)); /* 76 */
+ void (*tk_FreeXId) _ANSI_ARGS_((Display * display, XID xid)); /* 77 */
+ GC (*tk_GCForColor) _ANSI_ARGS_((XColor * colorPtr, Drawable drawable)); /* 78 */
+ void (*tk_GeometryRequest) _ANSI_ARGS_((Tk_Window tkwin, int reqWidth, int reqHeight)); /* 79 */
+ Tk_3DBorder (*tk_Get3DBorder) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_Uid colorName)); /* 80 */
+ void (*tk_GetAllBindings) _ANSI_ARGS_((Tcl_Interp * interp, Tk_BindingTable bindingTable, ClientData object)); /* 81 */
+ int (*tk_GetAnchor) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, Tk_Anchor * anchorPtr)); /* 82 */
+ CONST84_RETURN char * (*tk_GetAtomName) _ANSI_ARGS_((Tk_Window tkwin, Atom atom)); /* 83 */
+ CONST84_RETURN char * (*tk_GetBinding) _ANSI_ARGS_((Tcl_Interp * interp, Tk_BindingTable bindingTable, ClientData object, CONST char * eventStr)); /* 84 */
+ Pixmap (*tk_GetBitmap) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * str)); /* 85 */
+ Pixmap (*tk_GetBitmapFromData) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * source, int width, int height)); /* 86 */
+ int (*tk_GetCapStyle) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * capPtr)); /* 87 */
+ XColor * (*tk_GetColor) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_Uid name)); /* 88 */
+ XColor * (*tk_GetColorByValue) _ANSI_ARGS_((Tk_Window tkwin, XColor * colorPtr)); /* 89 */
+ Colormap (*tk_GetColormap) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * str)); /* 90 */
+ Tk_Cursor (*tk_GetCursor) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_Uid str)); /* 91 */
+ Tk_Cursor (*tk_GetCursorFromData) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * source, CONST char * mask, int width, int height, int xHot, int yHot, Tk_Uid fg, Tk_Uid bg)); /* 92 */
+ Tk_Font (*tk_GetFont) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * str)); /* 93 */
+ Tk_Font (*tk_GetFontFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 94 */
+ void (*tk_GetFontMetrics) _ANSI_ARGS_((Tk_Font font, Tk_FontMetrics * fmPtr)); /* 95 */
+ GC (*tk_GetGC) _ANSI_ARGS_((Tk_Window tkwin, unsigned long valueMask, XGCValues * valuePtr)); /* 96 */
+ Tk_Image (*tk_GetImage) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * name, Tk_ImageChangedProc * changeProc, ClientData clientData)); /* 97 */
+ ClientData (*tk_GetImageMasterData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tk_ImageType ** typePtrPtr)); /* 98 */
+ Tk_ItemType * (*tk_GetItemTypes) _ANSI_ARGS_((void)); /* 99 */
+ int (*tk_GetJoinStyle) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * joinPtr)); /* 100 */
+ int (*tk_GetJustify) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, Tk_Justify * justifyPtr)); /* 101 */
+ int (*tk_GetNumMainWindows) _ANSI_ARGS_((void)); /* 102 */
+ Tk_Uid (*tk_GetOption) _ANSI_ARGS_((Tk_Window tkwin, CONST char * name, CONST char * className)); /* 103 */
+ int (*tk_GetPixels) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * str, int * intPtr)); /* 104 */
+ Pixmap (*tk_GetPixmap) _ANSI_ARGS_((Display * display, Drawable d, int width, int height, int depth)); /* 105 */
+ int (*tk_GetRelief) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * reliefPtr)); /* 106 */
+ void (*tk_GetRootCoords) _ANSI_ARGS_((Tk_Window tkwin, int * xPtr, int * yPtr)); /* 107 */
+ int (*tk_GetScrollInfo) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 Tcl_Obj *CONST *objv, double * dblPtr, int * intPtr)); /* 108 */
+ int (*tk_GetScreenMM) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * str, double * doublePtr)); /* 109 */
+ int (*tk_GetSelection) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Atom selection, Atom target, Tk_GetSelProc * proc, ClientData clientData)); /* 110 */
+ Tk_Uid (*tk_GetUid) _ANSI_ARGS_((CONST char * str)); /* 111 */
+ Visual * (*tk_GetVisual) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * str, int * depthPtr, Colormap * colormapPtr)); /* 112 */
+ void (*tk_GetVRootGeometry) _ANSI_ARGS_((Tk_Window tkwin, int * xPtr, int * yPtr, int * widthPtr, int * heightPtr)); /* 113 */
+ int (*tk_Grab) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, int grabGlobal)); /* 114 */
+ void (*tk_HandleEvent) _ANSI_ARGS_((XEvent * eventPtr)); /* 115 */
+ Tk_Window (*tk_IdToWindow) _ANSI_ARGS_((Display * display, Window window)); /* 116 */
+ void (*tk_ImageChanged) _ANSI_ARGS_((Tk_ImageMaster master, int x, int y, int width, int height, int imageWidth, int imageHeight)); /* 117 */
+ int (*tk_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 118 */
+ Atom (*tk_InternAtom) _ANSI_ARGS_((Tk_Window tkwin, CONST char * name)); /* 119 */
+ int (*tk_IntersectTextLayout) _ANSI_ARGS_((Tk_TextLayout layout, int x, int y, int width, int height)); /* 120 */
+ void (*tk_MaintainGeometry) _ANSI_ARGS_((Tk_Window slave, Tk_Window master, int x, int y, int width, int height)); /* 121 */
+ Tk_Window (*tk_MainWindow) _ANSI_ARGS_((Tcl_Interp * interp)); /* 122 */
+ void (*tk_MakeWindowExist) _ANSI_ARGS_((Tk_Window tkwin)); /* 123 */
+ void (*tk_ManageGeometry) _ANSI_ARGS_((Tk_Window tkwin, Tk_GeomMgr * mgrPtr, ClientData clientData)); /* 124 */
+ void (*tk_MapWindow) _ANSI_ARGS_((Tk_Window tkwin)); /* 125 */
+ int (*tk_MeasureChars) _ANSI_ARGS_((Tk_Font tkfont, CONST char * source, int numBytes, int maxPixels, int flags, int * lengthPtr)); /* 126 */
+ void (*tk_MoveResizeWindow) _ANSI_ARGS_((Tk_Window tkwin, int x, int y, int width, int height)); /* 127 */
+ void (*tk_MoveWindow) _ANSI_ARGS_((Tk_Window tkwin, int x, int y)); /* 128 */
+ void (*tk_MoveToplevelWindow) _ANSI_ARGS_((Tk_Window tkwin, int x, int y)); /* 129 */
+ CONST84_RETURN char * (*tk_NameOf3DBorder) _ANSI_ARGS_((Tk_3DBorder border)); /* 130 */
+ CONST84_RETURN char * (*tk_NameOfAnchor) _ANSI_ARGS_((Tk_Anchor anchor)); /* 131 */
+ CONST84_RETURN char * (*tk_NameOfBitmap) _ANSI_ARGS_((Display * display, Pixmap bitmap)); /* 132 */
+ CONST84_RETURN char * (*tk_NameOfCapStyle) _ANSI_ARGS_((int cap)); /* 133 */
+ CONST84_RETURN char * (*tk_NameOfColor) _ANSI_ARGS_((XColor * colorPtr)); /* 134 */
+ CONST84_RETURN char * (*tk_NameOfCursor) _ANSI_ARGS_((Display * display, Tk_Cursor cursor)); /* 135 */
+ CONST84_RETURN char * (*tk_NameOfFont) _ANSI_ARGS_((Tk_Font font)); /* 136 */
+ CONST84_RETURN char * (*tk_NameOfImage) _ANSI_ARGS_((Tk_ImageMaster imageMaster)); /* 137 */
+ CONST84_RETURN char * (*tk_NameOfJoinStyle) _ANSI_ARGS_((int join)); /* 138 */
+ CONST84_RETURN char * (*tk_NameOfJustify) _ANSI_ARGS_((Tk_Justify justify)); /* 139 */
+ CONST84_RETURN char * (*tk_NameOfRelief) _ANSI_ARGS_((int relief)); /* 140 */
+ Tk_Window (*tk_NameToWindow) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pathName, Tk_Window tkwin)); /* 141 */
+ void (*tk_OwnSelection) _ANSI_ARGS_((Tk_Window tkwin, Atom selection, Tk_LostSelProc * proc, ClientData clientData)); /* 142 */
+ int (*tk_ParseArgv) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, int * argcPtr, CONST84 Tcl_Obj *CONST *objv, Tk_ArgvInfo * argTable, int flags)); /* 143 */
+ void (*tk_PhotoPutBlock_NoComposite) _ANSI_ARGS_((Tk_PhotoHandle handle, Tk_PhotoImageBlock * blockPtr, int x, int y, int width, int height)); /* 144 */
+ void (*tk_PhotoPutZoomedBlock_NoComposite) _ANSI_ARGS_((Tk_PhotoHandle handle, Tk_PhotoImageBlock * blockPtr, int x, int y, int width, int height, int zoomX, int zoomY, int subsampleX, int subsampleY)); /* 145 */
+ int (*tk_PhotoGetImage) _ANSI_ARGS_((Tk_PhotoHandle handle, Tk_PhotoImageBlock * blockPtr)); /* 146 */
+ void (*tk_PhotoBlank) _ANSI_ARGS_((Tk_PhotoHandle handle)); /* 147 */
+ void (*tk_PhotoExpand) _ANSI_ARGS_((Tk_PhotoHandle handle, int width, int height)); /* 148 */
+ void (*tk_PhotoGetSize) _ANSI_ARGS_((Tk_PhotoHandle handle, int * widthPtr, int * heightPtr)); /* 149 */
+ void (*tk_PhotoSetSize) _ANSI_ARGS_((Tk_PhotoHandle handle, int width, int height)); /* 150 */
+ int (*tk_PointToChar) _ANSI_ARGS_((Tk_TextLayout layout, int x, int y)); /* 151 */
+ int (*tk_PostscriptFontName) _ANSI_ARGS_((Tk_Font tkfont, Tcl_DString * dsPtr)); /* 152 */
+ void (*tk_PreserveColormap) _ANSI_ARGS_((Display * display, Colormap colormap)); /* 153 */
+ void (*tk_QueueWindowEvent) _ANSI_ARGS_((XEvent * eventPtr, Tcl_QueuePosition position)); /* 154 */
+ void (*tk_RedrawImage) _ANSI_ARGS_((Tk_Image image, int imageX, int imageY, int width, int height, Drawable drawable, int drawableX, int drawableY)); /* 155 */
+ void (*tk_ResizeWindow) _ANSI_ARGS_((Tk_Window tkwin, int width, int height)); /* 156 */
+ int (*tk_RestackWindow) _ANSI_ARGS_((Tk_Window tkwin, int aboveBelow, Tk_Window other)); /* 157 */
+ Tk_RestrictProc * (*tk_RestrictEvents) _ANSI_ARGS_((Tk_RestrictProc * proc, ClientData arg, ClientData * prevArgPtr)); /* 158 */
+ int (*tk_SafeInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 159 */
+ CONST char * (*tk_SetAppName) _ANSI_ARGS_((Tk_Window tkwin, CONST char * name)); /* 160 */
+ void (*tk_SetBackgroundFromBorder) _ANSI_ARGS_((Tk_Window tkwin, Tk_3DBorder border)); /* 161 */
+ void (*tk_SetClass) _ANSI_ARGS_((Tk_Window tkwin, CONST char * className)); /* 162 */
+ void (*tk_SetGrid) _ANSI_ARGS_((Tk_Window tkwin, int reqWidth, int reqHeight, int gridWidth, int gridHeight)); /* 163 */
+ void (*tk_SetInternalBorder) _ANSI_ARGS_((Tk_Window tkwin, int width)); /* 164 */
+ void (*tk_SetWindowBackground) _ANSI_ARGS_((Tk_Window tkwin, unsigned long pixel)); /* 165 */
+ void (*tk_SetWindowBackgroundPixmap) _ANSI_ARGS_((Tk_Window tkwin, Pixmap pixmap)); /* 166 */
+ void (*tk_SetWindowBorder) _ANSI_ARGS_((Tk_Window tkwin, unsigned long pixel)); /* 167 */
+ void (*tk_SetWindowBorderWidth) _ANSI_ARGS_((Tk_Window tkwin, int width)); /* 168 */
+ void (*tk_SetWindowBorderPixmap) _ANSI_ARGS_((Tk_Window tkwin, Pixmap pixmap)); /* 169 */
+ void (*tk_SetWindowColormap) _ANSI_ARGS_((Tk_Window tkwin, Colormap colormap)); /* 170 */
+ int (*tk_SetWindowVisual) _ANSI_ARGS_((Tk_Window tkwin, Visual * visual, int depth, Colormap colormap)); /* 171 */
+ void (*tk_SizeOfBitmap) _ANSI_ARGS_((Display * display, Pixmap bitmap, int * widthPtr, int * heightPtr)); /* 172 */
+ void (*tk_SizeOfImage) _ANSI_ARGS_((Tk_Image image, int * widthPtr, int * heightPtr)); /* 173 */
+ int (*tk_StrictMotif) _ANSI_ARGS_((Tk_Window tkwin)); /* 174 */
+ void (*tk_TextLayoutToPostscript) _ANSI_ARGS_((Tcl_Interp * interp, Tk_TextLayout layout)); /* 175 */
+ int (*tk_TextWidth) _ANSI_ARGS_((Tk_Font font, CONST char * str, int numBytes)); /* 176 */
+ void (*tk_UndefineCursor) _ANSI_ARGS_((Tk_Window window)); /* 177 */
+ void (*tk_UnderlineChars) _ANSI_ARGS_((Display * display, Drawable drawable, GC gc, Tk_Font tkfont, CONST char * source, int x, int y, int firstByte, int lastByte)); /* 178 */
+ void (*tk_UnderlineTextLayout) _ANSI_ARGS_((Display * display, Drawable drawable, GC gc, Tk_TextLayout layout, int x, int y, int underline)); /* 179 */
+ void (*tk_Ungrab) _ANSI_ARGS_((Tk_Window tkwin)); /* 180 */
+ void (*tk_UnmaintainGeometry) _ANSI_ARGS_((Tk_Window slave, Tk_Window master)); /* 181 */
+ void (*tk_UnmapWindow) _ANSI_ARGS_((Tk_Window tkwin)); /* 182 */
+ void (*tk_UnsetGrid) _ANSI_ARGS_((Tk_Window tkwin)); /* 183 */
+ void (*tk_UpdatePointer) _ANSI_ARGS_((Tk_Window tkwin, int x, int y, int state)); /* 184 */
+ Pixmap (*tk_AllocBitmapFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr)); /* 185 */
+ Tk_3DBorder (*tk_Alloc3DBorderFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr)); /* 186 */
+ XColor * (*tk_AllocColorFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr)); /* 187 */
+ Tk_Cursor (*tk_AllocCursorFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr)); /* 188 */
+ Tk_Font (*tk_AllocFontFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr)); /* 189 */
+ Tk_OptionTable (*tk_CreateOptionTable) _ANSI_ARGS_((Tcl_Interp * interp, CONST Tk_OptionSpec * templatePtr)); /* 190 */
+ void (*tk_DeleteOptionTable) _ANSI_ARGS_((Tk_OptionTable optionTable)); /* 191 */
+ void (*tk_Free3DBorderFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 192 */
+ void (*tk_FreeBitmapFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 193 */
+ void (*tk_FreeColorFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 194 */
+ void (*tk_FreeConfigOptions) _ANSI_ARGS_((char * recordPtr, Tk_OptionTable optionToken, Tk_Window tkwin)); /* 195 */
+ void (*tk_FreeSavedOptions) _ANSI_ARGS_((Tk_SavedOptions * savePtr)); /* 196 */
+ void (*tk_FreeCursorFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 197 */
+ void (*tk_FreeFontFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 198 */
+ Tk_3DBorder (*tk_Get3DBorderFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 199 */
+ int (*tk_GetAnchorFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tk_Anchor * anchorPtr)); /* 200 */
+ Pixmap (*tk_GetBitmapFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 201 */
+ XColor * (*tk_GetColorFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 202 */
+ Tk_Cursor (*tk_GetCursorFromObj) _ANSI_ARGS_((Tk_Window tkwin, Tcl_Obj * objPtr)); /* 203 */
+ Tcl_Obj * (*tk_GetOptionInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * recordPtr, Tk_OptionTable optionTable, Tcl_Obj * namePtr, Tk_Window tkwin)); /* 204 */
+ Tcl_Obj * (*tk_GetOptionValue) _ANSI_ARGS_((Tcl_Interp * interp, char * recordPtr, Tk_OptionTable optionTable, Tcl_Obj * namePtr, Tk_Window tkwin)); /* 205 */
+ int (*tk_GetJustifyFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tk_Justify * justifyPtr)); /* 206 */
+ int (*tk_GetMMFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr, double * doublePtr)); /* 207 */
+ int (*tk_GetPixelsFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr, int * intPtr)); /* 208 */
+ int (*tk_GetReliefFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * resultPtr)); /* 209 */
+ int (*tk_GetScrollInfoObj) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], double * dblPtr, int * intPtr)); /* 210 */
+ int (*tk_InitOptions) _ANSI_ARGS_((Tcl_Interp * interp, char * recordPtr, Tk_OptionTable optionToken, Tk_Window tkwin)); /* 211 */
+ void (*tk_MainEx) _ANSI_ARGS_((int argc, Tcl_Obj *CONST *objv, Tcl_AppInitProc * appInitProc, Tcl_Interp * interp)); /* 212 */
+ void (*tk_RestoreSavedOptions) _ANSI_ARGS_((Tk_SavedOptions * savePtr)); /* 213 */
+ int (*tk_SetOptions) _ANSI_ARGS_((Tcl_Interp * interp, char * recordPtr, Tk_OptionTable optionTable, int objc, Tcl_Obj *CONST objv[], Tk_Window tkwin, Tk_SavedOptions * savePtr, int * maskPtr)); /* 214 */
+ void (*tk_InitConsoleChannels) _ANSI_ARGS_((Tcl_Interp * interp)); /* 215 */
+ int (*tk_CreateConsoleWindow) _ANSI_ARGS_((Tcl_Interp * interp)); /* 216 */
+ void (*tk_CreateSmoothMethod) _ANSI_ARGS_((Tcl_Interp * interp, Tk_SmoothMethod * method)); /* 217 */
+ void *reserved218;
+ void *reserved219;
+ int (*tk_GetDash) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * value, Tk_Dash * dash)); /* 220 */
+ void (*tk_CreateOutline) _ANSI_ARGS_((Tk_Outline * outline)); /* 221 */
+ void (*tk_DeleteOutline) _ANSI_ARGS_((Display * display, Tk_Outline * outline)); /* 222 */
+ int (*tk_ConfigOutlineGC) _ANSI_ARGS_((XGCValues * gcValues, Tk_Canvas canvas, Tk_Item * item, Tk_Outline * outline)); /* 223 */
+ int (*tk_ChangeOutlineGC) _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item * item, Tk_Outline * outline)); /* 224 */
+ int (*tk_ResetOutlineGC) _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item * item, Tk_Outline * outline)); /* 225 */
+ int (*tk_CanvasPsOutline) _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item * item, Tk_Outline * outline)); /* 226 */
+ void (*tk_SetTSOrigin) _ANSI_ARGS_((Tk_Window tkwin, GC gc, int x, int y)); /* 227 */
+ int (*tk_CanvasGetCoordFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, Tcl_Obj * obj, double * doublePtr)); /* 228 */
+ void (*tk_CanvasSetOffset) _ANSI_ARGS_((Tk_Canvas canvas, GC gc, Tk_TSOffset * offset)); /* 229 */
+ void (*tk_DitherPhoto) _ANSI_ARGS_((Tk_PhotoHandle handle, int x, int y, int width, int height)); /* 230 */
+ int (*tk_PostscriptBitmap) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_PostscriptInfo psInfo, Pixmap bitmap, int startX, int startY, int width, int height)); /* 231 */
+ int (*tk_PostscriptColor) _ANSI_ARGS_((Tcl_Interp * interp, Tk_PostscriptInfo psInfo, XColor * colorPtr)); /* 232 */
+ int (*tk_PostscriptFont) _ANSI_ARGS_((Tcl_Interp * interp, Tk_PostscriptInfo psInfo, Tk_Font font)); /* 233 */
+ int (*tk_PostscriptImage) _ANSI_ARGS_((Tk_Image image, Tcl_Interp * interp, Tk_Window tkwin, Tk_PostscriptInfo psinfo, int x, int y, int width, int height, int prepass)); /* 234 */
+ void (*tk_PostscriptPath) _ANSI_ARGS_((Tcl_Interp * interp, Tk_PostscriptInfo psInfo, double * coordPtr, int numPoints)); /* 235 */
+ int (*tk_PostscriptStipple) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_PostscriptInfo psInfo, Pixmap bitmap)); /* 236 */
+ double (*tk_PostscriptY) _ANSI_ARGS_((double y, Tk_PostscriptInfo psInfo)); /* 237 */
+ int (*tk_PostscriptPhoto) _ANSI_ARGS_((Tcl_Interp * interp, Tk_PhotoImageBlock * blockPtr, Tk_PostscriptInfo psInfo, int width, int height)); /* 238 */
+ void (*tk_CreateClientMessageHandler) _ANSI_ARGS_((Tk_ClientMessageProc * proc)); /* 239 */
+ void (*tk_DeleteClientMessageHandler) _ANSI_ARGS_((Tk_ClientMessageProc * proc)); /* 240 */
+ Tk_Window (*tk_CreateAnonymousWindow) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window parent, CONST char * screenName)); /* 241 */
+ void (*tk_SetClassProcs) _ANSI_ARGS_((Tk_Window tkwin, Tk_ClassProcs * procs, ClientData instanceData)); /* 242 */
+ void (*tk_SetInternalBorderEx) _ANSI_ARGS_((Tk_Window tkwin, int left, int right, int top, int bottom)); /* 243 */
+ void (*tk_SetMinimumRequestSize) _ANSI_ARGS_((Tk_Window tkwin, int minWidth, int minHeight)); /* 244 */
+ void (*tk_SetCaretPos) _ANSI_ARGS_((Tk_Window tkwin, int x, int y, int height)); /* 245 */
+ void (*tk_PhotoPutBlock) _ANSI_ARGS_((Tk_PhotoHandle handle, Tk_PhotoImageBlock * blockPtr, int x, int y, int width, int height, int compRule)); /* 246 */
+ void (*tk_PhotoPutZoomedBlock) _ANSI_ARGS_((Tk_PhotoHandle handle, Tk_PhotoImageBlock * blockPtr, int x, int y, int width, int height, int zoomX, int zoomY, int subsampleX, int subsampleY, int compRule)); /* 247 */
+ int (*tk_CollapseMotionEvents) _ANSI_ARGS_((Display * display, int collapse)); /* 248 */
+ Tk_StyleEngine (*tk_RegisterStyleEngine) _ANSI_ARGS_((CONST char * name, Tk_StyleEngine parent)); /* 249 */
+ Tk_StyleEngine (*tk_GetStyleEngine) _ANSI_ARGS_((CONST char * name)); /* 250 */
+ int (*tk_RegisterStyledElement) _ANSI_ARGS_((Tk_StyleEngine engine, Tk_ElementSpec * templatePtr)); /* 251 */
+ int (*tk_GetElementId) _ANSI_ARGS_((CONST char * name)); /* 252 */
+ Tk_Style (*tk_CreateStyle) _ANSI_ARGS_((CONST char * name, Tk_StyleEngine engine, ClientData clientData)); /* 253 */
+ Tk_Style (*tk_GetStyle) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 254 */
+ void (*tk_FreeStyle) _ANSI_ARGS_((Tk_Style style)); /* 255 */
+ CONST char * (*tk_NameOfStyle) _ANSI_ARGS_((Tk_Style style)); /* 256 */
+ Tk_Style (*tk_AllocStyleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 257 */
+ Tk_Style (*tk_GetStyleFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 258 */
+ void (*tk_FreeStyleFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 259 */
+ Tk_StyledElement (*tk_GetStyledElement) _ANSI_ARGS_((Tk_Style style, int elementId, Tk_OptionTable optionTable)); /* 260 */
+ void (*tk_GetElementSize) _ANSI_ARGS_((Tk_Style style, Tk_StyledElement element, char * recordPtr, Tk_Window tkwin, int width, int height, int inner, int * widthPtr, int * heightPtr)); /* 261 */
+ void (*tk_GetElementBox) _ANSI_ARGS_((Tk_Style style, Tk_StyledElement element, char * recordPtr, Tk_Window tkwin, int x, int y, int width, int height, int inner, int * xPtr, int * yPtr, int * widthPtr, int * heightPtr)); /* 262 */
+ int (*tk_GetElementBorderWidth) _ANSI_ARGS_((Tk_Style style, Tk_StyledElement element, char * recordPtr, Tk_Window tkwin)); /* 263 */
+ void (*tk_DrawElement) _ANSI_ARGS_((Tk_Style style, Tk_StyledElement element, char * recordPtr, Tk_Window tkwin, Drawable d, int x, int y, int width, int height, int state)); /* 264 */
+} TkStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TkStubs *tkStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifndef Tk_MainLoop
+#define Tk_MainLoop \
+ (tkStubsPtr->tk_MainLoop) /* 0 */
+#endif
+#ifndef Tk_3DBorderColor
+#define Tk_3DBorderColor \
+ (tkStubsPtr->tk_3DBorderColor) /* 1 */
+#endif
+#ifndef Tk_3DBorderGC
+#define Tk_3DBorderGC \
+ (tkStubsPtr->tk_3DBorderGC) /* 2 */
+#endif
+#ifndef Tk_3DHorizontalBevel
+#define Tk_3DHorizontalBevel \
+ (tkStubsPtr->tk_3DHorizontalBevel) /* 3 */
+#endif
+#ifndef Tk_3DVerticalBevel
+#define Tk_3DVerticalBevel \
+ (tkStubsPtr->tk_3DVerticalBevel) /* 4 */
+#endif
+#ifndef Tk_AddOption
+#define Tk_AddOption \
+ (tkStubsPtr->tk_AddOption) /* 5 */
+#endif
+#ifndef Tk_BindEvent
+#define Tk_BindEvent \
+ (tkStubsPtr->tk_BindEvent) /* 6 */
+#endif
+#ifndef Tk_CanvasDrawableCoords
+#define Tk_CanvasDrawableCoords \
+ (tkStubsPtr->tk_CanvasDrawableCoords) /* 7 */
+#endif
+#ifndef Tk_CanvasEventuallyRedraw
+#define Tk_CanvasEventuallyRedraw \
+ (tkStubsPtr->tk_CanvasEventuallyRedraw) /* 8 */
+#endif
+#ifndef Tk_CanvasGetCoord
+#define Tk_CanvasGetCoord \
+ (tkStubsPtr->tk_CanvasGetCoord) /* 9 */
+#endif
+#ifndef Tk_CanvasGetTextInfo
+#define Tk_CanvasGetTextInfo \
+ (tkStubsPtr->tk_CanvasGetTextInfo) /* 10 */
+#endif
+#ifndef Tk_CanvasPsBitmap
+#define Tk_CanvasPsBitmap \
+ (tkStubsPtr->tk_CanvasPsBitmap) /* 11 */
+#endif
+#ifndef Tk_CanvasPsColor
+#define Tk_CanvasPsColor \
+ (tkStubsPtr->tk_CanvasPsColor) /* 12 */
+#endif
+#ifndef Tk_CanvasPsFont
+#define Tk_CanvasPsFont \
+ (tkStubsPtr->tk_CanvasPsFont) /* 13 */
+#endif
+#ifndef Tk_CanvasPsPath
+#define Tk_CanvasPsPath \
+ (tkStubsPtr->tk_CanvasPsPath) /* 14 */
+#endif
+#ifndef Tk_CanvasPsStipple
+#define Tk_CanvasPsStipple \
+ (tkStubsPtr->tk_CanvasPsStipple) /* 15 */
+#endif
+#ifndef Tk_CanvasPsY
+#define Tk_CanvasPsY \
+ (tkStubsPtr->tk_CanvasPsY) /* 16 */
+#endif
+#ifndef Tk_CanvasSetStippleOrigin
+#define Tk_CanvasSetStippleOrigin \
+ (tkStubsPtr->tk_CanvasSetStippleOrigin) /* 17 */
+#endif
+#ifndef Tk_CanvasTagsParseProc
+#define Tk_CanvasTagsParseProc \
+ (tkStubsPtr->tk_CanvasTagsParseProc) /* 18 */
+#endif
+#ifndef Tk_CanvasTagsPrintProc
+#define Tk_CanvasTagsPrintProc \
+ (tkStubsPtr->tk_CanvasTagsPrintProc) /* 19 */
+#endif
+#ifndef Tk_CanvasTkwin
+#define Tk_CanvasTkwin \
+ (tkStubsPtr->tk_CanvasTkwin) /* 20 */
+#endif
+#ifndef Tk_CanvasWindowCoords
+#define Tk_CanvasWindowCoords \
+ (tkStubsPtr->tk_CanvasWindowCoords) /* 21 */
+#endif
+#ifndef Tk_ChangeWindowAttributes
+#define Tk_ChangeWindowAttributes \
+ (tkStubsPtr->tk_ChangeWindowAttributes) /* 22 */
+#endif
+#ifndef Tk_CharBbox
+#define Tk_CharBbox \
+ (tkStubsPtr->tk_CharBbox) /* 23 */
+#endif
+#ifndef Tk_ClearSelection
+#define Tk_ClearSelection \
+ (tkStubsPtr->tk_ClearSelection) /* 24 */
+#endif
+#ifndef Tk_ClipboardAppend
+#define Tk_ClipboardAppend \
+ (tkStubsPtr->tk_ClipboardAppend) /* 25 */
+#endif
+#ifndef Tk_ClipboardClear
+#define Tk_ClipboardClear \
+ (tkStubsPtr->tk_ClipboardClear) /* 26 */
+#endif
+#ifndef Tk_ConfigureInfo
+#define Tk_ConfigureInfo \
+ (tkStubsPtr->tk_ConfigureInfo) /* 27 */
+#endif
+#ifndef Tk_ConfigureValue
+#define Tk_ConfigureValue \
+ (tkStubsPtr->tk_ConfigureValue) /* 28 */
+#endif
+#ifndef Tk_ConfigureWidget
+#define Tk_ConfigureWidget \
+ (tkStubsPtr->tk_ConfigureWidget) /* 29 */
+#endif
+#ifndef Tk_ConfigureWindow
+#define Tk_ConfigureWindow \
+ (tkStubsPtr->tk_ConfigureWindow) /* 30 */
+#endif
+#ifndef Tk_ComputeTextLayout
+#define Tk_ComputeTextLayout \
+ (tkStubsPtr->tk_ComputeTextLayout) /* 31 */
+#endif
+#ifndef Tk_CoordsToWindow
+#define Tk_CoordsToWindow \
+ (tkStubsPtr->tk_CoordsToWindow) /* 32 */
+#endif
+#ifndef Tk_CreateBinding
+#define Tk_CreateBinding \
+ (tkStubsPtr->tk_CreateBinding) /* 33 */
+#endif
+#ifndef Tk_CreateBindingTable
+#define Tk_CreateBindingTable \
+ (tkStubsPtr->tk_CreateBindingTable) /* 34 */
+#endif
+#ifndef Tk_CreateErrorHandler
+#define Tk_CreateErrorHandler \
+ (tkStubsPtr->tk_CreateErrorHandler) /* 35 */
+#endif
+#ifndef Tk_CreateEventHandler
+#define Tk_CreateEventHandler \
+ (tkStubsPtr->tk_CreateEventHandler) /* 36 */
+#endif
+#ifndef Tk_CreateGenericHandler
+#define Tk_CreateGenericHandler \
+ (tkStubsPtr->tk_CreateGenericHandler) /* 37 */
+#endif
+#ifndef Tk_CreateImageType
+#define Tk_CreateImageType \
+ (tkStubsPtr->tk_CreateImageType) /* 38 */
+#endif
+#ifndef Tk_CreateItemType
+#define Tk_CreateItemType \
+ (tkStubsPtr->tk_CreateItemType) /* 39 */
+#endif
+#ifndef Tk_CreatePhotoImageFormat
+#define Tk_CreatePhotoImageFormat \
+ (tkStubsPtr->tk_CreatePhotoImageFormat) /* 40 */
+#endif
+#ifndef Tk_CreateSelHandler
+#define Tk_CreateSelHandler \
+ (tkStubsPtr->tk_CreateSelHandler) /* 41 */
+#endif
+#ifndef Tk_CreateWindow
+#define Tk_CreateWindow \
+ (tkStubsPtr->tk_CreateWindow) /* 42 */
+#endif
+#ifndef Tk_CreateWindowFromPath
+#define Tk_CreateWindowFromPath \
+ (tkStubsPtr->tk_CreateWindowFromPath) /* 43 */
+#endif
+#ifndef Tk_DefineBitmap
+#define Tk_DefineBitmap \
+ (tkStubsPtr->tk_DefineBitmap) /* 44 */
+#endif
+#ifndef Tk_DefineCursor
+#define Tk_DefineCursor \
+ (tkStubsPtr->tk_DefineCursor) /* 45 */
+#endif
+#ifndef Tk_DeleteAllBindings
+#define Tk_DeleteAllBindings \
+ (tkStubsPtr->tk_DeleteAllBindings) /* 46 */
+#endif
+#ifndef Tk_DeleteBinding
+#define Tk_DeleteBinding \
+ (tkStubsPtr->tk_DeleteBinding) /* 47 */
+#endif
+#ifndef Tk_DeleteBindingTable
+#define Tk_DeleteBindingTable \
+ (tkStubsPtr->tk_DeleteBindingTable) /* 48 */
+#endif
+#ifndef Tk_DeleteErrorHandler
+#define Tk_DeleteErrorHandler \
+ (tkStubsPtr->tk_DeleteErrorHandler) /* 49 */
+#endif
+#ifndef Tk_DeleteEventHandler
+#define Tk_DeleteEventHandler \
+ (tkStubsPtr->tk_DeleteEventHandler) /* 50 */
+#endif
+#ifndef Tk_DeleteGenericHandler
+#define Tk_DeleteGenericHandler \
+ (tkStubsPtr->tk_DeleteGenericHandler) /* 51 */
+#endif
+#ifndef Tk_DeleteImage
+#define Tk_DeleteImage \
+ (tkStubsPtr->tk_DeleteImage) /* 52 */
+#endif
+#ifndef Tk_DeleteSelHandler
+#define Tk_DeleteSelHandler \
+ (tkStubsPtr->tk_DeleteSelHandler) /* 53 */
+#endif
+#ifndef Tk_DestroyWindow
+#define Tk_DestroyWindow \
+ (tkStubsPtr->tk_DestroyWindow) /* 54 */
+#endif
+#ifndef Tk_DisplayName
+#define Tk_DisplayName \
+ (tkStubsPtr->tk_DisplayName) /* 55 */
+#endif
+#ifndef Tk_DistanceToTextLayout
+#define Tk_DistanceToTextLayout \
+ (tkStubsPtr->tk_DistanceToTextLayout) /* 56 */
+#endif
+#ifndef Tk_Draw3DPolygon
+#define Tk_Draw3DPolygon \
+ (tkStubsPtr->tk_Draw3DPolygon) /* 57 */
+#endif
+#ifndef Tk_Draw3DRectangle
+#define Tk_Draw3DRectangle \
+ (tkStubsPtr->tk_Draw3DRectangle) /* 58 */
+#endif
+#ifndef Tk_DrawChars
+#define Tk_DrawChars \
+ (tkStubsPtr->tk_DrawChars) /* 59 */
+#endif
+#ifndef Tk_DrawFocusHighlight
+#define Tk_DrawFocusHighlight \
+ (tkStubsPtr->tk_DrawFocusHighlight) /* 60 */
+#endif
+#ifndef Tk_DrawTextLayout
+#define Tk_DrawTextLayout \
+ (tkStubsPtr->tk_DrawTextLayout) /* 61 */
+#endif
+#ifndef Tk_Fill3DPolygon
+#define Tk_Fill3DPolygon \
+ (tkStubsPtr->tk_Fill3DPolygon) /* 62 */
+#endif
+#ifndef Tk_Fill3DRectangle
+#define Tk_Fill3DRectangle \
+ (tkStubsPtr->tk_Fill3DRectangle) /* 63 */
+#endif
+#ifndef Tk_FindPhoto
+#define Tk_FindPhoto \
+ (tkStubsPtr->tk_FindPhoto) /* 64 */
+#endif
+#ifndef Tk_FontId
+#define Tk_FontId \
+ (tkStubsPtr->tk_FontId) /* 65 */
+#endif
+#ifndef Tk_Free3DBorder
+#define Tk_Free3DBorder \
+ (tkStubsPtr->tk_Free3DBorder) /* 66 */
+#endif
+#ifndef Tk_FreeBitmap
+#define Tk_FreeBitmap \
+ (tkStubsPtr->tk_FreeBitmap) /* 67 */
+#endif
+#ifndef Tk_FreeColor
+#define Tk_FreeColor \
+ (tkStubsPtr->tk_FreeColor) /* 68 */
+#endif
+#ifndef Tk_FreeColormap
+#define Tk_FreeColormap \
+ (tkStubsPtr->tk_FreeColormap) /* 69 */
+#endif
+#ifndef Tk_FreeCursor
+#define Tk_FreeCursor \
+ (tkStubsPtr->tk_FreeCursor) /* 70 */
+#endif
+#ifndef Tk_FreeFont
+#define Tk_FreeFont \
+ (tkStubsPtr->tk_FreeFont) /* 71 */
+#endif
+#ifndef Tk_FreeGC
+#define Tk_FreeGC \
+ (tkStubsPtr->tk_FreeGC) /* 72 */
+#endif
+#ifndef Tk_FreeImage
+#define Tk_FreeImage \
+ (tkStubsPtr->tk_FreeImage) /* 73 */
+#endif
+#ifndef Tk_FreeOptions
+#define Tk_FreeOptions \
+ (tkStubsPtr->tk_FreeOptions) /* 74 */
+#endif
+#ifndef Tk_FreePixmap
+#define Tk_FreePixmap \
+ (tkStubsPtr->tk_FreePixmap) /* 75 */
+#endif
+#ifndef Tk_FreeTextLayout
+#define Tk_FreeTextLayout \
+ (tkStubsPtr->tk_FreeTextLayout) /* 76 */
+#endif
+#ifndef Tk_FreeXId
+#define Tk_FreeXId \
+ (tkStubsPtr->tk_FreeXId) /* 77 */
+#endif
+#ifndef Tk_GCForColor
+#define Tk_GCForColor \
+ (tkStubsPtr->tk_GCForColor) /* 78 */
+#endif
+#ifndef Tk_GeometryRequest
+#define Tk_GeometryRequest \
+ (tkStubsPtr->tk_GeometryRequest) /* 79 */
+#endif
+#ifndef Tk_Get3DBorder
+#define Tk_Get3DBorder \
+ (tkStubsPtr->tk_Get3DBorder) /* 80 */
+#endif
+#ifndef Tk_GetAllBindings
+#define Tk_GetAllBindings \
+ (tkStubsPtr->tk_GetAllBindings) /* 81 */
+#endif
+#ifndef Tk_GetAnchor
+#define Tk_GetAnchor \
+ (tkStubsPtr->tk_GetAnchor) /* 82 */
+#endif
+#ifndef Tk_GetAtomName
+#define Tk_GetAtomName \
+ (tkStubsPtr->tk_GetAtomName) /* 83 */
+#endif
+#ifndef Tk_GetBinding
+#define Tk_GetBinding \
+ (tkStubsPtr->tk_GetBinding) /* 84 */
+#endif
+#ifndef Tk_GetBitmap
+#define Tk_GetBitmap \
+ (tkStubsPtr->tk_GetBitmap) /* 85 */
+#endif
+#ifndef Tk_GetBitmapFromData
+#define Tk_GetBitmapFromData \
+ (tkStubsPtr->tk_GetBitmapFromData) /* 86 */
+#endif
+#ifndef Tk_GetCapStyle
+#define Tk_GetCapStyle \
+ (tkStubsPtr->tk_GetCapStyle) /* 87 */
+#endif
+#ifndef Tk_GetColor
+#define Tk_GetColor \
+ (tkStubsPtr->tk_GetColor) /* 88 */
+#endif
+#ifndef Tk_GetColorByValue
+#define Tk_GetColorByValue \
+ (tkStubsPtr->tk_GetColorByValue) /* 89 */
+#endif
+#ifndef Tk_GetColormap
+#define Tk_GetColormap \
+ (tkStubsPtr->tk_GetColormap) /* 90 */
+#endif
+#ifndef Tk_GetCursor
+#define Tk_GetCursor \
+ (tkStubsPtr->tk_GetCursor) /* 91 */
+#endif
+#ifndef Tk_GetCursorFromData
+#define Tk_GetCursorFromData \
+ (tkStubsPtr->tk_GetCursorFromData) /* 92 */
+#endif
+#ifndef Tk_GetFont
+#define Tk_GetFont \
+ (tkStubsPtr->tk_GetFont) /* 93 */
+#endif
+#ifndef Tk_GetFontFromObj
+#define Tk_GetFontFromObj \
+ (tkStubsPtr->tk_GetFontFromObj) /* 94 */
+#endif
+#ifndef Tk_GetFontMetrics
+#define Tk_GetFontMetrics \
+ (tkStubsPtr->tk_GetFontMetrics) /* 95 */
+#endif
+#ifndef Tk_GetGC
+#define Tk_GetGC \
+ (tkStubsPtr->tk_GetGC) /* 96 */
+#endif
+#ifndef Tk_GetImage
+#define Tk_GetImage \
+ (tkStubsPtr->tk_GetImage) /* 97 */
+#endif
+#ifndef Tk_GetImageMasterData
+#define Tk_GetImageMasterData \
+ (tkStubsPtr->tk_GetImageMasterData) /* 98 */
+#endif
+#ifndef Tk_GetItemTypes
+#define Tk_GetItemTypes \
+ (tkStubsPtr->tk_GetItemTypes) /* 99 */
+#endif
+#ifndef Tk_GetJoinStyle
+#define Tk_GetJoinStyle \
+ (tkStubsPtr->tk_GetJoinStyle) /* 100 */
+#endif
+#ifndef Tk_GetJustify
+#define Tk_GetJustify \
+ (tkStubsPtr->tk_GetJustify) /* 101 */
+#endif
+#ifndef Tk_GetNumMainWindows
+#define Tk_GetNumMainWindows \
+ (tkStubsPtr->tk_GetNumMainWindows) /* 102 */
+#endif
+#ifndef Tk_GetOption
+#define Tk_GetOption \
+ (tkStubsPtr->tk_GetOption) /* 103 */
+#endif
+#ifndef Tk_GetPixels
+#define Tk_GetPixels \
+ (tkStubsPtr->tk_GetPixels) /* 104 */
+#endif
+#ifndef Tk_GetPixmap
+#define Tk_GetPixmap \
+ (tkStubsPtr->tk_GetPixmap) /* 105 */
+#endif
+#ifndef Tk_GetRelief
+#define Tk_GetRelief \
+ (tkStubsPtr->tk_GetRelief) /* 106 */
+#endif
+#ifndef Tk_GetRootCoords
+#define Tk_GetRootCoords \
+ (tkStubsPtr->tk_GetRootCoords) /* 107 */
+#endif
+#ifndef Tk_GetScrollInfo
+#define Tk_GetScrollInfo \
+ (tkStubsPtr->tk_GetScrollInfo) /* 108 */
+#endif
+#ifndef Tk_GetScreenMM
+#define Tk_GetScreenMM \
+ (tkStubsPtr->tk_GetScreenMM) /* 109 */
+#endif
+#ifndef Tk_GetSelection
+#define Tk_GetSelection \
+ (tkStubsPtr->tk_GetSelection) /* 110 */
+#endif
+#ifndef Tk_GetUid
+#define Tk_GetUid \
+ (tkStubsPtr->tk_GetUid) /* 111 */
+#endif
+#ifndef Tk_GetVisual
+#define Tk_GetVisual \
+ (tkStubsPtr->tk_GetVisual) /* 112 */
+#endif
+#ifndef Tk_GetVRootGeometry
+#define Tk_GetVRootGeometry \
+ (tkStubsPtr->tk_GetVRootGeometry) /* 113 */
+#endif
+#ifndef Tk_Grab
+#define Tk_Grab \
+ (tkStubsPtr->tk_Grab) /* 114 */
+#endif
+#ifndef Tk_HandleEvent
+#define Tk_HandleEvent \
+ (tkStubsPtr->tk_HandleEvent) /* 115 */
+#endif
+#ifndef Tk_IdToWindow
+#define Tk_IdToWindow \
+ (tkStubsPtr->tk_IdToWindow) /* 116 */
+#endif
+#ifndef Tk_ImageChanged
+#define Tk_ImageChanged \
+ (tkStubsPtr->tk_ImageChanged) /* 117 */
+#endif
+#ifndef Tk_Init
+#define Tk_Init \
+ (tkStubsPtr->tk_Init) /* 118 */
+#endif
+#ifndef Tk_InternAtom
+#define Tk_InternAtom \
+ (tkStubsPtr->tk_InternAtom) /* 119 */
+#endif
+#ifndef Tk_IntersectTextLayout
+#define Tk_IntersectTextLayout \
+ (tkStubsPtr->tk_IntersectTextLayout) /* 120 */
+#endif
+#ifndef Tk_MaintainGeometry
+#define Tk_MaintainGeometry \
+ (tkStubsPtr->tk_MaintainGeometry) /* 121 */
+#endif
+#ifndef Tk_MainWindow
+#define Tk_MainWindow \
+ (tkStubsPtr->tk_MainWindow) /* 122 */
+#endif
+#ifndef Tk_MakeWindowExist
+#define Tk_MakeWindowExist \
+ (tkStubsPtr->tk_MakeWindowExist) /* 123 */
+#endif
+#ifndef Tk_ManageGeometry
+#define Tk_ManageGeometry \
+ (tkStubsPtr->tk_ManageGeometry) /* 124 */
+#endif
+#ifndef Tk_MapWindow
+#define Tk_MapWindow \
+ (tkStubsPtr->tk_MapWindow) /* 125 */
+#endif
+#ifndef Tk_MeasureChars
+#define Tk_MeasureChars \
+ (tkStubsPtr->tk_MeasureChars) /* 126 */
+#endif
+#ifndef Tk_MoveResizeWindow
+#define Tk_MoveResizeWindow \
+ (tkStubsPtr->tk_MoveResizeWindow) /* 127 */
+#endif
+#ifndef Tk_MoveWindow
+#define Tk_MoveWindow \
+ (tkStubsPtr->tk_MoveWindow) /* 128 */
+#endif
+#ifndef Tk_MoveToplevelWindow
+#define Tk_MoveToplevelWindow \
+ (tkStubsPtr->tk_MoveToplevelWindow) /* 129 */
+#endif
+#ifndef Tk_NameOf3DBorder
+#define Tk_NameOf3DBorder \
+ (tkStubsPtr->tk_NameOf3DBorder) /* 130 */
+#endif
+#ifndef Tk_NameOfAnchor
+#define Tk_NameOfAnchor \
+ (tkStubsPtr->tk_NameOfAnchor) /* 131 */
+#endif
+#ifndef Tk_NameOfBitmap
+#define Tk_NameOfBitmap \
+ (tkStubsPtr->tk_NameOfBitmap) /* 132 */
+#endif
+#ifndef Tk_NameOfCapStyle
+#define Tk_NameOfCapStyle \
+ (tkStubsPtr->tk_NameOfCapStyle) /* 133 */
+#endif
+#ifndef Tk_NameOfColor
+#define Tk_NameOfColor \
+ (tkStubsPtr->tk_NameOfColor) /* 134 */
+#endif
+#ifndef Tk_NameOfCursor
+#define Tk_NameOfCursor \
+ (tkStubsPtr->tk_NameOfCursor) /* 135 */
+#endif
+#ifndef Tk_NameOfFont
+#define Tk_NameOfFont \
+ (tkStubsPtr->tk_NameOfFont) /* 136 */
+#endif
+#ifndef Tk_NameOfImage
+#define Tk_NameOfImage \
+ (tkStubsPtr->tk_NameOfImage) /* 137 */
+#endif
+#ifndef Tk_NameOfJoinStyle
+#define Tk_NameOfJoinStyle \
+ (tkStubsPtr->tk_NameOfJoinStyle) /* 138 */
+#endif
+#ifndef Tk_NameOfJustify
+#define Tk_NameOfJustify \
+ (tkStubsPtr->tk_NameOfJustify) /* 139 */
+#endif
+#ifndef Tk_NameOfRelief
+#define Tk_NameOfRelief \
+ (tkStubsPtr->tk_NameOfRelief) /* 140 */
+#endif
+#ifndef Tk_NameToWindow
+#define Tk_NameToWindow \
+ (tkStubsPtr->tk_NameToWindow) /* 141 */
+#endif
+#ifndef Tk_OwnSelection
+#define Tk_OwnSelection \
+ (tkStubsPtr->tk_OwnSelection) /* 142 */
+#endif
+#ifndef Tk_ParseArgv
+#define Tk_ParseArgv \
+ (tkStubsPtr->tk_ParseArgv) /* 143 */
+#endif
+#ifndef Tk_PhotoPutBlock_NoComposite
+#define Tk_PhotoPutBlock_NoComposite \
+ (tkStubsPtr->tk_PhotoPutBlock_NoComposite) /* 144 */
+#endif
+#ifndef Tk_PhotoPutZoomedBlock_NoComposite
+#define Tk_PhotoPutZoomedBlock_NoComposite \
+ (tkStubsPtr->tk_PhotoPutZoomedBlock_NoComposite) /* 145 */
+#endif
+#ifndef Tk_PhotoGetImage
+#define Tk_PhotoGetImage \
+ (tkStubsPtr->tk_PhotoGetImage) /* 146 */
+#endif
+#ifndef Tk_PhotoBlank
+#define Tk_PhotoBlank \
+ (tkStubsPtr->tk_PhotoBlank) /* 147 */
+#endif
+#ifndef Tk_PhotoExpand
+#define Tk_PhotoExpand \
+ (tkStubsPtr->tk_PhotoExpand) /* 148 */
+#endif
+#ifndef Tk_PhotoGetSize
+#define Tk_PhotoGetSize \
+ (tkStubsPtr->tk_PhotoGetSize) /* 149 */
+#endif
+#ifndef Tk_PhotoSetSize
+#define Tk_PhotoSetSize \
+ (tkStubsPtr->tk_PhotoSetSize) /* 150 */
+#endif
+#ifndef Tk_PointToChar
+#define Tk_PointToChar \
+ (tkStubsPtr->tk_PointToChar) /* 151 */
+#endif
+#ifndef Tk_PostscriptFontName
+#define Tk_PostscriptFontName \
+ (tkStubsPtr->tk_PostscriptFontName) /* 152 */
+#endif
+#ifndef Tk_PreserveColormap
+#define Tk_PreserveColormap \
+ (tkStubsPtr->tk_PreserveColormap) /* 153 */
+#endif
+#ifndef Tk_QueueWindowEvent
+#define Tk_QueueWindowEvent \
+ (tkStubsPtr->tk_QueueWindowEvent) /* 154 */
+#endif
+#ifndef Tk_RedrawImage
+#define Tk_RedrawImage \
+ (tkStubsPtr->tk_RedrawImage) /* 155 */
+#endif
+#ifndef Tk_ResizeWindow
+#define Tk_ResizeWindow \
+ (tkStubsPtr->tk_ResizeWindow) /* 156 */
+#endif
+#ifndef Tk_RestackWindow
+#define Tk_RestackWindow \
+ (tkStubsPtr->tk_RestackWindow) /* 157 */
+#endif
+#ifndef Tk_RestrictEvents
+#define Tk_RestrictEvents \
+ (tkStubsPtr->tk_RestrictEvents) /* 158 */
+#endif
+#ifndef Tk_SafeInit
+#define Tk_SafeInit \
+ (tkStubsPtr->tk_SafeInit) /* 159 */
+#endif
+#ifndef Tk_SetAppName
+#define Tk_SetAppName \
+ (tkStubsPtr->tk_SetAppName) /* 160 */
+#endif
+#ifndef Tk_SetBackgroundFromBorder
+#define Tk_SetBackgroundFromBorder \
+ (tkStubsPtr->tk_SetBackgroundFromBorder) /* 161 */
+#endif
+#ifndef Tk_SetClass
+#define Tk_SetClass \
+ (tkStubsPtr->tk_SetClass) /* 162 */
+#endif
+#ifndef Tk_SetGrid
+#define Tk_SetGrid \
+ (tkStubsPtr->tk_SetGrid) /* 163 */
+#endif
+#ifndef Tk_SetInternalBorder
+#define Tk_SetInternalBorder \
+ (tkStubsPtr->tk_SetInternalBorder) /* 164 */
+#endif
+#ifndef Tk_SetWindowBackground
+#define Tk_SetWindowBackground \
+ (tkStubsPtr->tk_SetWindowBackground) /* 165 */
+#endif
+#ifndef Tk_SetWindowBackgroundPixmap
+#define Tk_SetWindowBackgroundPixmap \
+ (tkStubsPtr->tk_SetWindowBackgroundPixmap) /* 166 */
+#endif
+#ifndef Tk_SetWindowBorder
+#define Tk_SetWindowBorder \
+ (tkStubsPtr->tk_SetWindowBorder) /* 167 */
+#endif
+#ifndef Tk_SetWindowBorderWidth
+#define Tk_SetWindowBorderWidth \
+ (tkStubsPtr->tk_SetWindowBorderWidth) /* 168 */
+#endif
+#ifndef Tk_SetWindowBorderPixmap
+#define Tk_SetWindowBorderPixmap \
+ (tkStubsPtr->tk_SetWindowBorderPixmap) /* 169 */
+#endif
+#ifndef Tk_SetWindowColormap
+#define Tk_SetWindowColormap \
+ (tkStubsPtr->tk_SetWindowColormap) /* 170 */
+#endif
+#ifndef Tk_SetWindowVisual
+#define Tk_SetWindowVisual \
+ (tkStubsPtr->tk_SetWindowVisual) /* 171 */
+#endif
+#ifndef Tk_SizeOfBitmap
+#define Tk_SizeOfBitmap \
+ (tkStubsPtr->tk_SizeOfBitmap) /* 172 */
+#endif
+#ifndef Tk_SizeOfImage
+#define Tk_SizeOfImage \
+ (tkStubsPtr->tk_SizeOfImage) /* 173 */
+#endif
+#ifndef Tk_StrictMotif
+#define Tk_StrictMotif \
+ (tkStubsPtr->tk_StrictMotif) /* 174 */
+#endif
+#ifndef Tk_TextLayoutToPostscript
+#define Tk_TextLayoutToPostscript \
+ (tkStubsPtr->tk_TextLayoutToPostscript) /* 175 */
+#endif
+#ifndef Tk_TextWidth
+#define Tk_TextWidth \
+ (tkStubsPtr->tk_TextWidth) /* 176 */
+#endif
+#ifndef Tk_UndefineCursor
+#define Tk_UndefineCursor \
+ (tkStubsPtr->tk_UndefineCursor) /* 177 */
+#endif
+#ifndef Tk_UnderlineChars
+#define Tk_UnderlineChars \
+ (tkStubsPtr->tk_UnderlineChars) /* 178 */
+#endif
+#ifndef Tk_UnderlineTextLayout
+#define Tk_UnderlineTextLayout \
+ (tkStubsPtr->tk_UnderlineTextLayout) /* 179 */
+#endif
+#ifndef Tk_Ungrab
+#define Tk_Ungrab \
+ (tkStubsPtr->tk_Ungrab) /* 180 */
+#endif
+#ifndef Tk_UnmaintainGeometry
+#define Tk_UnmaintainGeometry \
+ (tkStubsPtr->tk_UnmaintainGeometry) /* 181 */
+#endif
+#ifndef Tk_UnmapWindow
+#define Tk_UnmapWindow \
+ (tkStubsPtr->tk_UnmapWindow) /* 182 */
+#endif
+#ifndef Tk_UnsetGrid
+#define Tk_UnsetGrid \
+ (tkStubsPtr->tk_UnsetGrid) /* 183 */
+#endif
+#ifndef Tk_UpdatePointer
+#define Tk_UpdatePointer \
+ (tkStubsPtr->tk_UpdatePointer) /* 184 */
+#endif
+#ifndef Tk_AllocBitmapFromObj
+#define Tk_AllocBitmapFromObj \
+ (tkStubsPtr->tk_AllocBitmapFromObj) /* 185 */
+#endif
+#ifndef Tk_Alloc3DBorderFromObj
+#define Tk_Alloc3DBorderFromObj \
+ (tkStubsPtr->tk_Alloc3DBorderFromObj) /* 186 */
+#endif
+#ifndef Tk_AllocColorFromObj
+#define Tk_AllocColorFromObj \
+ (tkStubsPtr->tk_AllocColorFromObj) /* 187 */
+#endif
+#ifndef Tk_AllocCursorFromObj
+#define Tk_AllocCursorFromObj \
+ (tkStubsPtr->tk_AllocCursorFromObj) /* 188 */
+#endif
+#ifndef Tk_AllocFontFromObj
+#define Tk_AllocFontFromObj \
+ (tkStubsPtr->tk_AllocFontFromObj) /* 189 */
+#endif
+#ifndef Tk_CreateOptionTable
+#define Tk_CreateOptionTable \
+ (tkStubsPtr->tk_CreateOptionTable) /* 190 */
+#endif
+#ifndef Tk_DeleteOptionTable
+#define Tk_DeleteOptionTable \
+ (tkStubsPtr->tk_DeleteOptionTable) /* 191 */
+#endif
+#ifndef Tk_Free3DBorderFromObj
+#define Tk_Free3DBorderFromObj \
+ (tkStubsPtr->tk_Free3DBorderFromObj) /* 192 */
+#endif
+#ifndef Tk_FreeBitmapFromObj
+#define Tk_FreeBitmapFromObj \
+ (tkStubsPtr->tk_FreeBitmapFromObj) /* 193 */
+#endif
+#ifndef Tk_FreeColorFromObj
+#define Tk_FreeColorFromObj \
+ (tkStubsPtr->tk_FreeColorFromObj) /* 194 */
+#endif
+#ifndef Tk_FreeConfigOptions
+#define Tk_FreeConfigOptions \
+ (tkStubsPtr->tk_FreeConfigOptions) /* 195 */
+#endif
+#ifndef Tk_FreeSavedOptions
+#define Tk_FreeSavedOptions \
+ (tkStubsPtr->tk_FreeSavedOptions) /* 196 */
+#endif
+#ifndef Tk_FreeCursorFromObj
+#define Tk_FreeCursorFromObj \
+ (tkStubsPtr->tk_FreeCursorFromObj) /* 197 */
+#endif
+#ifndef Tk_FreeFontFromObj
+#define Tk_FreeFontFromObj \
+ (tkStubsPtr->tk_FreeFontFromObj) /* 198 */
+#endif
+#ifndef Tk_Get3DBorderFromObj
+#define Tk_Get3DBorderFromObj \
+ (tkStubsPtr->tk_Get3DBorderFromObj) /* 199 */
+#endif
+#ifndef Tk_GetAnchorFromObj
+#define Tk_GetAnchorFromObj \
+ (tkStubsPtr->tk_GetAnchorFromObj) /* 200 */
+#endif
+#ifndef Tk_GetBitmapFromObj
+#define Tk_GetBitmapFromObj \
+ (tkStubsPtr->tk_GetBitmapFromObj) /* 201 */
+#endif
+#ifndef Tk_GetColorFromObj
+#define Tk_GetColorFromObj \
+ (tkStubsPtr->tk_GetColorFromObj) /* 202 */
+#endif
+#ifndef Tk_GetCursorFromObj
+#define Tk_GetCursorFromObj \
+ (tkStubsPtr->tk_GetCursorFromObj) /* 203 */
+#endif
+#ifndef Tk_GetOptionInfo
+#define Tk_GetOptionInfo \
+ (tkStubsPtr->tk_GetOptionInfo) /* 204 */
+#endif
+#ifndef Tk_GetOptionValue
+#define Tk_GetOptionValue \
+ (tkStubsPtr->tk_GetOptionValue) /* 205 */
+#endif
+#ifndef Tk_GetJustifyFromObj
+#define Tk_GetJustifyFromObj \
+ (tkStubsPtr->tk_GetJustifyFromObj) /* 206 */
+#endif
+#ifndef Tk_GetMMFromObj
+#define Tk_GetMMFromObj \
+ (tkStubsPtr->tk_GetMMFromObj) /* 207 */
+#endif
+#ifndef Tk_GetPixelsFromObj
+#define Tk_GetPixelsFromObj \
+ (tkStubsPtr->tk_GetPixelsFromObj) /* 208 */
+#endif
+#ifndef Tk_GetReliefFromObj
+#define Tk_GetReliefFromObj \
+ (tkStubsPtr->tk_GetReliefFromObj) /* 209 */
+#endif
+#ifndef Tk_GetScrollInfoObj
+#define Tk_GetScrollInfoObj \
+ (tkStubsPtr->tk_GetScrollInfoObj) /* 210 */
+#endif
+#ifndef Tk_InitOptions
+#define Tk_InitOptions \
+ (tkStubsPtr->tk_InitOptions) /* 211 */
+#endif
+#ifndef Tk_MainEx
+#define Tk_MainEx \
+ (tkStubsPtr->tk_MainEx) /* 212 */
+#endif
+#ifndef Tk_RestoreSavedOptions
+#define Tk_RestoreSavedOptions \
+ (tkStubsPtr->tk_RestoreSavedOptions) /* 213 */
+#endif
+#ifndef Tk_SetOptions
+#define Tk_SetOptions \
+ (tkStubsPtr->tk_SetOptions) /* 214 */
+#endif
+#ifndef Tk_InitConsoleChannels
+#define Tk_InitConsoleChannels \
+ (tkStubsPtr->tk_InitConsoleChannels) /* 215 */
+#endif
+#ifndef Tk_CreateConsoleWindow
+#define Tk_CreateConsoleWindow \
+ (tkStubsPtr->tk_CreateConsoleWindow) /* 216 */
+#endif
+#ifndef Tk_CreateSmoothMethod
+#define Tk_CreateSmoothMethod \
+ (tkStubsPtr->tk_CreateSmoothMethod) /* 217 */
+#endif
+/* Slot 218 is reserved */
+/* Slot 219 is reserved */
+#ifndef Tk_GetDash
+#define Tk_GetDash \
+ (tkStubsPtr->tk_GetDash) /* 220 */
+#endif
+#ifndef Tk_CreateOutline
+#define Tk_CreateOutline \
+ (tkStubsPtr->tk_CreateOutline) /* 221 */
+#endif
+#ifndef Tk_DeleteOutline
+#define Tk_DeleteOutline \
+ (tkStubsPtr->tk_DeleteOutline) /* 222 */
+#endif
+#ifndef Tk_ConfigOutlineGC
+#define Tk_ConfigOutlineGC \
+ (tkStubsPtr->tk_ConfigOutlineGC) /* 223 */
+#endif
+#ifndef Tk_ChangeOutlineGC
+#define Tk_ChangeOutlineGC \
+ (tkStubsPtr->tk_ChangeOutlineGC) /* 224 */
+#endif
+#ifndef Tk_ResetOutlineGC
+#define Tk_ResetOutlineGC \
+ (tkStubsPtr->tk_ResetOutlineGC) /* 225 */
+#endif
+#ifndef Tk_CanvasPsOutline
+#define Tk_CanvasPsOutline \
+ (tkStubsPtr->tk_CanvasPsOutline) /* 226 */
+#endif
+#ifndef Tk_SetTSOrigin
+#define Tk_SetTSOrigin \
+ (tkStubsPtr->tk_SetTSOrigin) /* 227 */
+#endif
+#ifndef Tk_CanvasGetCoordFromObj
+#define Tk_CanvasGetCoordFromObj \
+ (tkStubsPtr->tk_CanvasGetCoordFromObj) /* 228 */
+#endif
+#ifndef Tk_CanvasSetOffset
+#define Tk_CanvasSetOffset \
+ (tkStubsPtr->tk_CanvasSetOffset) /* 229 */
+#endif
+#ifndef Tk_DitherPhoto
+#define Tk_DitherPhoto \
+ (tkStubsPtr->tk_DitherPhoto) /* 230 */
+#endif
+#ifndef Tk_PostscriptBitmap
+#define Tk_PostscriptBitmap \
+ (tkStubsPtr->tk_PostscriptBitmap) /* 231 */
+#endif
+#ifndef Tk_PostscriptColor
+#define Tk_PostscriptColor \
+ (tkStubsPtr->tk_PostscriptColor) /* 232 */
+#endif
+#ifndef Tk_PostscriptFont
+#define Tk_PostscriptFont \
+ (tkStubsPtr->tk_PostscriptFont) /* 233 */
+#endif
+#ifndef Tk_PostscriptImage
+#define Tk_PostscriptImage \
+ (tkStubsPtr->tk_PostscriptImage) /* 234 */
+#endif
+#ifndef Tk_PostscriptPath
+#define Tk_PostscriptPath \
+ (tkStubsPtr->tk_PostscriptPath) /* 235 */
+#endif
+#ifndef Tk_PostscriptStipple
+#define Tk_PostscriptStipple \
+ (tkStubsPtr->tk_PostscriptStipple) /* 236 */
+#endif
+#ifndef Tk_PostscriptY
+#define Tk_PostscriptY \
+ (tkStubsPtr->tk_PostscriptY) /* 237 */
+#endif
+#ifndef Tk_PostscriptPhoto
+#define Tk_PostscriptPhoto \
+ (tkStubsPtr->tk_PostscriptPhoto) /* 238 */
+#endif
+#ifndef Tk_CreateClientMessageHandler
+#define Tk_CreateClientMessageHandler \
+ (tkStubsPtr->tk_CreateClientMessageHandler) /* 239 */
+#endif
+#ifndef Tk_DeleteClientMessageHandler
+#define Tk_DeleteClientMessageHandler \
+ (tkStubsPtr->tk_DeleteClientMessageHandler) /* 240 */
+#endif
+#ifndef Tk_CreateAnonymousWindow
+#define Tk_CreateAnonymousWindow \
+ (tkStubsPtr->tk_CreateAnonymousWindow) /* 241 */
+#endif
+#ifndef Tk_SetClassProcs
+#define Tk_SetClassProcs \
+ (tkStubsPtr->tk_SetClassProcs) /* 242 */
+#endif
+#ifndef Tk_SetInternalBorderEx
+#define Tk_SetInternalBorderEx \
+ (tkStubsPtr->tk_SetInternalBorderEx) /* 243 */
+#endif
+#ifndef Tk_SetMinimumRequestSize
+#define Tk_SetMinimumRequestSize \
+ (tkStubsPtr->tk_SetMinimumRequestSize) /* 244 */
+#endif
+#ifndef Tk_SetCaretPos
+#define Tk_SetCaretPos \
+ (tkStubsPtr->tk_SetCaretPos) /* 245 */
+#endif
+#ifndef Tk_PhotoPutBlock
+#define Tk_PhotoPutBlock \
+ (tkStubsPtr->tk_PhotoPutBlock) /* 246 */
+#endif
+#ifndef Tk_PhotoPutZoomedBlock
+#define Tk_PhotoPutZoomedBlock \
+ (tkStubsPtr->tk_PhotoPutZoomedBlock) /* 247 */
+#endif
+#ifndef Tk_CollapseMotionEvents
+#define Tk_CollapseMotionEvents \
+ (tkStubsPtr->tk_CollapseMotionEvents) /* 248 */
+#endif
+#ifndef Tk_RegisterStyleEngine
+#define Tk_RegisterStyleEngine \
+ (tkStubsPtr->tk_RegisterStyleEngine) /* 249 */
+#endif
+#ifndef Tk_GetStyleEngine
+#define Tk_GetStyleEngine \
+ (tkStubsPtr->tk_GetStyleEngine) /* 250 */
+#endif
+#ifndef Tk_RegisterStyledElement
+#define Tk_RegisterStyledElement \
+ (tkStubsPtr->tk_RegisterStyledElement) /* 251 */
+#endif
+#ifndef Tk_GetElementId
+#define Tk_GetElementId \
+ (tkStubsPtr->tk_GetElementId) /* 252 */
+#endif
+#ifndef Tk_CreateStyle
+#define Tk_CreateStyle \
+ (tkStubsPtr->tk_CreateStyle) /* 253 */
+#endif
+#ifndef Tk_GetStyle
+#define Tk_GetStyle \
+ (tkStubsPtr->tk_GetStyle) /* 254 */
+#endif
+#ifndef Tk_FreeStyle
+#define Tk_FreeStyle \
+ (tkStubsPtr->tk_FreeStyle) /* 255 */
+#endif
+#ifndef Tk_NameOfStyle
+#define Tk_NameOfStyle \
+ (tkStubsPtr->tk_NameOfStyle) /* 256 */
+#endif
+#ifndef Tk_AllocStyleFromObj
+#define Tk_AllocStyleFromObj \
+ (tkStubsPtr->tk_AllocStyleFromObj) /* 257 */
+#endif
+#ifndef Tk_GetStyleFromObj
+#define Tk_GetStyleFromObj \
+ (tkStubsPtr->tk_GetStyleFromObj) /* 258 */
+#endif
+#ifndef Tk_FreeStyleFromObj
+#define Tk_FreeStyleFromObj \
+ (tkStubsPtr->tk_FreeStyleFromObj) /* 259 */
+#endif
+#ifndef Tk_GetStyledElement
+#define Tk_GetStyledElement \
+ (tkStubsPtr->tk_GetStyledElement) /* 260 */
+#endif
+#ifndef Tk_GetElementSize
+#define Tk_GetElementSize \
+ (tkStubsPtr->tk_GetElementSize) /* 261 */
+#endif
+#ifndef Tk_GetElementBox
+#define Tk_GetElementBox \
+ (tkStubsPtr->tk_GetElementBox) /* 262 */
+#endif
+#ifndef Tk_GetElementBorderWidth
+#define Tk_GetElementBorderWidth \
+ (tkStubsPtr->tk_GetElementBorderWidth) /* 263 */
+#endif
+#ifndef Tk_DrawElement
+#define Tk_DrawElement \
+ (tkStubsPtr->tk_DrawElement) /* 264 */
+#endif
+
+#endif /* defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKDECLS */
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.m
new file mode 100755
index 00000000000..02da549ab28
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.m
@@ -0,0 +1,870 @@
+#ifndef _TKDECLS_VM
+#define _TKDECLS_VM
+#include "tkDecls_f.h"
+#ifndef NO_VTABLES
+#ifndef Tk_3DBorderColor
+# define Tk_3DBorderColor (*TkdeclsVptr->V_Tk_3DBorderColor)
+#endif
+
+#ifndef Tk_3DBorderGC
+# define Tk_3DBorderGC (*TkdeclsVptr->V_Tk_3DBorderGC)
+#endif
+
+#ifndef Tk_3DHorizontalBevel
+# define Tk_3DHorizontalBevel (*TkdeclsVptr->V_Tk_3DHorizontalBevel)
+#endif
+
+#ifndef Tk_3DVerticalBevel
+# define Tk_3DVerticalBevel (*TkdeclsVptr->V_Tk_3DVerticalBevel)
+#endif
+
+#ifndef Tk_Alloc3DBorderFromObj
+# define Tk_Alloc3DBorderFromObj (*TkdeclsVptr->V_Tk_Alloc3DBorderFromObj)
+#endif
+
+#ifndef Tk_AllocBitmapFromObj
+# define Tk_AllocBitmapFromObj (*TkdeclsVptr->V_Tk_AllocBitmapFromObj)
+#endif
+
+#ifndef Tk_AllocColorFromObj
+# define Tk_AllocColorFromObj (*TkdeclsVptr->V_Tk_AllocColorFromObj)
+#endif
+
+#ifndef Tk_AllocCursorFromObj
+# define Tk_AllocCursorFromObj (*TkdeclsVptr->V_Tk_AllocCursorFromObj)
+#endif
+
+#ifndef Tk_AllocFontFromObj
+# define Tk_AllocFontFromObj (*TkdeclsVptr->V_Tk_AllocFontFromObj)
+#endif
+
+#ifndef Tk_AllocStyleFromObj
+# define Tk_AllocStyleFromObj (*TkdeclsVptr->V_Tk_AllocStyleFromObj)
+#endif
+
+#ifndef Tk_BindEvent
+# define Tk_BindEvent (*TkdeclsVptr->V_Tk_BindEvent)
+#endif
+
+#ifndef Tk_ChangeWindowAttributes
+# define Tk_ChangeWindowAttributes (*TkdeclsVptr->V_Tk_ChangeWindowAttributes)
+#endif
+
+#ifndef Tk_CharBbox
+# define Tk_CharBbox (*TkdeclsVptr->V_Tk_CharBbox)
+#endif
+
+#ifndef Tk_ClearSelection
+# define Tk_ClearSelection (*TkdeclsVptr->V_Tk_ClearSelection)
+#endif
+
+#ifndef Tk_ClipboardAppend
+# define Tk_ClipboardAppend (*TkdeclsVptr->V_Tk_ClipboardAppend)
+#endif
+
+#ifndef Tk_ClipboardClear
+# define Tk_ClipboardClear (*TkdeclsVptr->V_Tk_ClipboardClear)
+#endif
+
+#ifndef Tk_CollapseMotionEvents
+# define Tk_CollapseMotionEvents (*TkdeclsVptr->V_Tk_CollapseMotionEvents)
+#endif
+
+#ifndef Tk_ComputeTextLayout
+# define Tk_ComputeTextLayout (*TkdeclsVptr->V_Tk_ComputeTextLayout)
+#endif
+
+#ifndef Tk_ConfigureInfo
+# define Tk_ConfigureInfo (*TkdeclsVptr->V_Tk_ConfigureInfo)
+#endif
+
+#ifndef Tk_ConfigureValue
+# define Tk_ConfigureValue (*TkdeclsVptr->V_Tk_ConfigureValue)
+#endif
+
+#ifndef Tk_ConfigureWidget
+# define Tk_ConfigureWidget (*TkdeclsVptr->V_Tk_ConfigureWidget)
+#endif
+
+#ifndef Tk_ConfigureWindow
+# define Tk_ConfigureWindow (*TkdeclsVptr->V_Tk_ConfigureWindow)
+#endif
+
+#ifndef Tk_CoordsToWindow
+# define Tk_CoordsToWindow (*TkdeclsVptr->V_Tk_CoordsToWindow)
+#endif
+
+#ifndef Tk_CreateAnonymousWindow
+# define Tk_CreateAnonymousWindow (*TkdeclsVptr->V_Tk_CreateAnonymousWindow)
+#endif
+
+#ifndef Tk_CreateBinding
+# define Tk_CreateBinding (*TkdeclsVptr->V_Tk_CreateBinding)
+#endif
+
+#ifndef Tk_CreateBindingTable
+# define Tk_CreateBindingTable (*TkdeclsVptr->V_Tk_CreateBindingTable)
+#endif
+
+#ifndef Tk_CreateClientMessageHandler
+# define Tk_CreateClientMessageHandler (*TkdeclsVptr->V_Tk_CreateClientMessageHandler)
+#endif
+
+#ifndef Tk_CreateErrorHandler
+# define Tk_CreateErrorHandler (*TkdeclsVptr->V_Tk_CreateErrorHandler)
+#endif
+
+#ifndef Tk_CreateEventHandler
+# define Tk_CreateEventHandler (*TkdeclsVptr->V_Tk_CreateEventHandler)
+#endif
+
+#ifndef Tk_CreateGenericHandler
+# define Tk_CreateGenericHandler (*TkdeclsVptr->V_Tk_CreateGenericHandler)
+#endif
+
+#ifndef Tk_CreateImageType
+# define Tk_CreateImageType (*TkdeclsVptr->V_Tk_CreateImageType)
+#endif
+
+#ifndef Tk_CreateOptionTable
+# define Tk_CreateOptionTable (*TkdeclsVptr->V_Tk_CreateOptionTable)
+#endif
+
+#ifndef Tk_CreateSelHandler
+# define Tk_CreateSelHandler (*TkdeclsVptr->V_Tk_CreateSelHandler)
+#endif
+
+#ifndef Tk_CreateStyle
+# define Tk_CreateStyle (*TkdeclsVptr->V_Tk_CreateStyle)
+#endif
+
+#ifndef Tk_CreateWindow
+# define Tk_CreateWindow (*TkdeclsVptr->V_Tk_CreateWindow)
+#endif
+
+#ifndef Tk_CreateWindowFromPath
+# define Tk_CreateWindowFromPath (*TkdeclsVptr->V_Tk_CreateWindowFromPath)
+#endif
+
+#ifndef Tk_DefineBitmap
+# define Tk_DefineBitmap (*TkdeclsVptr->V_Tk_DefineBitmap)
+#endif
+
+#ifndef Tk_DefineCursor
+# define Tk_DefineCursor (*TkdeclsVptr->V_Tk_DefineCursor)
+#endif
+
+#ifndef Tk_DeleteAllBindings
+# define Tk_DeleteAllBindings (*TkdeclsVptr->V_Tk_DeleteAllBindings)
+#endif
+
+#ifndef Tk_DeleteBinding
+# define Tk_DeleteBinding (*TkdeclsVptr->V_Tk_DeleteBinding)
+#endif
+
+#ifndef Tk_DeleteBindingTable
+# define Tk_DeleteBindingTable (*TkdeclsVptr->V_Tk_DeleteBindingTable)
+#endif
+
+#ifndef Tk_DeleteClientMessageHandler
+# define Tk_DeleteClientMessageHandler (*TkdeclsVptr->V_Tk_DeleteClientMessageHandler)
+#endif
+
+#ifndef Tk_DeleteErrorHandler
+# define Tk_DeleteErrorHandler (*TkdeclsVptr->V_Tk_DeleteErrorHandler)
+#endif
+
+#ifndef Tk_DeleteEventHandler
+# define Tk_DeleteEventHandler (*TkdeclsVptr->V_Tk_DeleteEventHandler)
+#endif
+
+#ifndef Tk_DeleteGenericHandler
+# define Tk_DeleteGenericHandler (*TkdeclsVptr->V_Tk_DeleteGenericHandler)
+#endif
+
+#ifndef Tk_DeleteImage
+# define Tk_DeleteImage (*TkdeclsVptr->V_Tk_DeleteImage)
+#endif
+
+#ifndef Tk_DeleteOptionTable
+# define Tk_DeleteOptionTable (*TkdeclsVptr->V_Tk_DeleteOptionTable)
+#endif
+
+#ifndef Tk_DeleteSelHandler
+# define Tk_DeleteSelHandler (*TkdeclsVptr->V_Tk_DeleteSelHandler)
+#endif
+
+#ifndef Tk_DestroyWindow
+# define Tk_DestroyWindow (*TkdeclsVptr->V_Tk_DestroyWindow)
+#endif
+
+#ifndef Tk_DisplayName
+# define Tk_DisplayName (*TkdeclsVptr->V_Tk_DisplayName)
+#endif
+
+#ifndef Tk_DistanceToTextLayout
+# define Tk_DistanceToTextLayout (*TkdeclsVptr->V_Tk_DistanceToTextLayout)
+#endif
+
+#ifndef Tk_Draw3DPolygon
+# define Tk_Draw3DPolygon (*TkdeclsVptr->V_Tk_Draw3DPolygon)
+#endif
+
+#ifndef Tk_Draw3DRectangle
+# define Tk_Draw3DRectangle (*TkdeclsVptr->V_Tk_Draw3DRectangle)
+#endif
+
+#ifndef Tk_DrawChars
+# define Tk_DrawChars (*TkdeclsVptr->V_Tk_DrawChars)
+#endif
+
+#ifndef Tk_DrawElement
+# define Tk_DrawElement (*TkdeclsVptr->V_Tk_DrawElement)
+#endif
+
+#ifndef Tk_DrawFocusHighlight
+# define Tk_DrawFocusHighlight (*TkdeclsVptr->V_Tk_DrawFocusHighlight)
+#endif
+
+#ifndef Tk_DrawTextLayout
+# define Tk_DrawTextLayout (*TkdeclsVptr->V_Tk_DrawTextLayout)
+#endif
+
+#ifndef Tk_Fill3DPolygon
+# define Tk_Fill3DPolygon (*TkdeclsVptr->V_Tk_Fill3DPolygon)
+#endif
+
+#ifndef Tk_Fill3DRectangle
+# define Tk_Fill3DRectangle (*TkdeclsVptr->V_Tk_Fill3DRectangle)
+#endif
+
+#ifndef Tk_FontId
+# define Tk_FontId (*TkdeclsVptr->V_Tk_FontId)
+#endif
+
+#ifndef Tk_Free3DBorder
+# define Tk_Free3DBorder (*TkdeclsVptr->V_Tk_Free3DBorder)
+#endif
+
+#ifndef Tk_Free3DBorderFromObj
+# define Tk_Free3DBorderFromObj (*TkdeclsVptr->V_Tk_Free3DBorderFromObj)
+#endif
+
+#ifndef Tk_FreeBitmap
+# define Tk_FreeBitmap (*TkdeclsVptr->V_Tk_FreeBitmap)
+#endif
+
+#ifndef Tk_FreeBitmapFromObj
+# define Tk_FreeBitmapFromObj (*TkdeclsVptr->V_Tk_FreeBitmapFromObj)
+#endif
+
+#ifndef Tk_FreeColor
+# define Tk_FreeColor (*TkdeclsVptr->V_Tk_FreeColor)
+#endif
+
+#ifndef Tk_FreeColorFromObj
+# define Tk_FreeColorFromObj (*TkdeclsVptr->V_Tk_FreeColorFromObj)
+#endif
+
+#ifndef Tk_FreeColormap
+# define Tk_FreeColormap (*TkdeclsVptr->V_Tk_FreeColormap)
+#endif
+
+#ifndef Tk_FreeConfigOptions
+# define Tk_FreeConfigOptions (*TkdeclsVptr->V_Tk_FreeConfigOptions)
+#endif
+
+#ifndef Tk_FreeCursor
+# define Tk_FreeCursor (*TkdeclsVptr->V_Tk_FreeCursor)
+#endif
+
+#ifndef Tk_FreeCursorFromObj
+# define Tk_FreeCursorFromObj (*TkdeclsVptr->V_Tk_FreeCursorFromObj)
+#endif
+
+#ifndef Tk_FreeFont
+# define Tk_FreeFont (*TkdeclsVptr->V_Tk_FreeFont)
+#endif
+
+#ifndef Tk_FreeFontFromObj
+# define Tk_FreeFontFromObj (*TkdeclsVptr->V_Tk_FreeFontFromObj)
+#endif
+
+#ifndef Tk_FreeGC
+# define Tk_FreeGC (*TkdeclsVptr->V_Tk_FreeGC)
+#endif
+
+#ifndef Tk_FreeImage
+# define Tk_FreeImage (*TkdeclsVptr->V_Tk_FreeImage)
+#endif
+
+#ifndef Tk_FreeOptions
+# define Tk_FreeOptions (*TkdeclsVptr->V_Tk_FreeOptions)
+#endif
+
+#ifndef Tk_FreePixmap
+# define Tk_FreePixmap (*TkdeclsVptr->V_Tk_FreePixmap)
+#endif
+
+#ifndef Tk_FreeSavedOptions
+# define Tk_FreeSavedOptions (*TkdeclsVptr->V_Tk_FreeSavedOptions)
+#endif
+
+#ifndef Tk_FreeStyle
+# define Tk_FreeStyle (*TkdeclsVptr->V_Tk_FreeStyle)
+#endif
+
+#ifndef Tk_FreeStyleFromObj
+# define Tk_FreeStyleFromObj (*TkdeclsVptr->V_Tk_FreeStyleFromObj)
+#endif
+
+#ifndef Tk_FreeTextLayout
+# define Tk_FreeTextLayout (*TkdeclsVptr->V_Tk_FreeTextLayout)
+#endif
+
+#ifndef Tk_FreeXId
+# define Tk_FreeXId (*TkdeclsVptr->V_Tk_FreeXId)
+#endif
+
+#ifndef Tk_GCForColor
+# define Tk_GCForColor (*TkdeclsVptr->V_Tk_GCForColor)
+#endif
+
+#ifndef Tk_GeometryRequest
+# define Tk_GeometryRequest (*TkdeclsVptr->V_Tk_GeometryRequest)
+#endif
+
+#ifndef Tk_Get3DBorder
+# define Tk_Get3DBorder (*TkdeclsVptr->V_Tk_Get3DBorder)
+#endif
+
+#ifndef Tk_Get3DBorderFromObj
+# define Tk_Get3DBorderFromObj (*TkdeclsVptr->V_Tk_Get3DBorderFromObj)
+#endif
+
+#ifndef Tk_GetAllBindings
+# define Tk_GetAllBindings (*TkdeclsVptr->V_Tk_GetAllBindings)
+#endif
+
+#ifndef Tk_GetAnchor
+# define Tk_GetAnchor (*TkdeclsVptr->V_Tk_GetAnchor)
+#endif
+
+#ifndef Tk_GetAnchorFromObj
+# define Tk_GetAnchorFromObj (*TkdeclsVptr->V_Tk_GetAnchorFromObj)
+#endif
+
+#ifndef Tk_GetAtomName
+# define Tk_GetAtomName (*TkdeclsVptr->V_Tk_GetAtomName)
+#endif
+
+#ifndef Tk_GetBinding
+# define Tk_GetBinding (*TkdeclsVptr->V_Tk_GetBinding)
+#endif
+
+#ifndef Tk_GetBitmap
+# define Tk_GetBitmap (*TkdeclsVptr->V_Tk_GetBitmap)
+#endif
+
+#ifndef Tk_GetBitmapFromData
+# define Tk_GetBitmapFromData (*TkdeclsVptr->V_Tk_GetBitmapFromData)
+#endif
+
+#ifndef Tk_GetBitmapFromObj
+# define Tk_GetBitmapFromObj (*TkdeclsVptr->V_Tk_GetBitmapFromObj)
+#endif
+
+#ifndef Tk_GetCapStyle
+# define Tk_GetCapStyle (*TkdeclsVptr->V_Tk_GetCapStyle)
+#endif
+
+#ifndef Tk_GetColor
+# define Tk_GetColor (*TkdeclsVptr->V_Tk_GetColor)
+#endif
+
+#ifndef Tk_GetColorByValue
+# define Tk_GetColorByValue (*TkdeclsVptr->V_Tk_GetColorByValue)
+#endif
+
+#ifndef Tk_GetColorFromObj
+# define Tk_GetColorFromObj (*TkdeclsVptr->V_Tk_GetColorFromObj)
+#endif
+
+#ifndef Tk_GetColormap
+# define Tk_GetColormap (*TkdeclsVptr->V_Tk_GetColormap)
+#endif
+
+#ifndef Tk_GetCursor
+# define Tk_GetCursor (*TkdeclsVptr->V_Tk_GetCursor)
+#endif
+
+#ifndef Tk_GetCursorFromData
+# define Tk_GetCursorFromData (*TkdeclsVptr->V_Tk_GetCursorFromData)
+#endif
+
+#ifndef Tk_GetCursorFromObj
+# define Tk_GetCursorFromObj (*TkdeclsVptr->V_Tk_GetCursorFromObj)
+#endif
+
+#ifndef Tk_GetElementBorderWidth
+# define Tk_GetElementBorderWidth (*TkdeclsVptr->V_Tk_GetElementBorderWidth)
+#endif
+
+#ifndef Tk_GetElementBox
+# define Tk_GetElementBox (*TkdeclsVptr->V_Tk_GetElementBox)
+#endif
+
+#ifndef Tk_GetElementId
+# define Tk_GetElementId (*TkdeclsVptr->V_Tk_GetElementId)
+#endif
+
+#ifndef Tk_GetElementSize
+# define Tk_GetElementSize (*TkdeclsVptr->V_Tk_GetElementSize)
+#endif
+
+#ifndef Tk_GetFont
+# define Tk_GetFont (*TkdeclsVptr->V_Tk_GetFont)
+#endif
+
+#ifndef Tk_GetFontFromObj
+# define Tk_GetFontFromObj (*TkdeclsVptr->V_Tk_GetFontFromObj)
+#endif
+
+#ifndef Tk_GetFontMetrics
+# define Tk_GetFontMetrics (*TkdeclsVptr->V_Tk_GetFontMetrics)
+#endif
+
+#ifndef Tk_GetGC
+# define Tk_GetGC (*TkdeclsVptr->V_Tk_GetGC)
+#endif
+
+#ifndef Tk_GetImage
+# define Tk_GetImage (*TkdeclsVptr->V_Tk_GetImage)
+#endif
+
+#ifndef Tk_GetImageMasterData
+# define Tk_GetImageMasterData (*TkdeclsVptr->V_Tk_GetImageMasterData)
+#endif
+
+#ifndef Tk_GetJoinStyle
+# define Tk_GetJoinStyle (*TkdeclsVptr->V_Tk_GetJoinStyle)
+#endif
+
+#ifndef Tk_GetJustify
+# define Tk_GetJustify (*TkdeclsVptr->V_Tk_GetJustify)
+#endif
+
+#ifndef Tk_GetJustifyFromObj
+# define Tk_GetJustifyFromObj (*TkdeclsVptr->V_Tk_GetJustifyFromObj)
+#endif
+
+#ifndef Tk_GetMMFromObj
+# define Tk_GetMMFromObj (*TkdeclsVptr->V_Tk_GetMMFromObj)
+#endif
+
+#ifndef Tk_GetNumMainWindows
+# define Tk_GetNumMainWindows (*TkdeclsVptr->V_Tk_GetNumMainWindows)
+#endif
+
+#ifndef Tk_GetOptionInfo
+# define Tk_GetOptionInfo (*TkdeclsVptr->V_Tk_GetOptionInfo)
+#endif
+
+#ifndef Tk_GetOptionValue
+# define Tk_GetOptionValue (*TkdeclsVptr->V_Tk_GetOptionValue)
+#endif
+
+#ifndef Tk_GetPixels
+# define Tk_GetPixels (*TkdeclsVptr->V_Tk_GetPixels)
+#endif
+
+#ifndef Tk_GetPixelsFromObj
+# define Tk_GetPixelsFromObj (*TkdeclsVptr->V_Tk_GetPixelsFromObj)
+#endif
+
+#ifndef Tk_GetPixmap
+# define Tk_GetPixmap (*TkdeclsVptr->V_Tk_GetPixmap)
+#endif
+
+#ifndef Tk_GetRelief
+# define Tk_GetRelief (*TkdeclsVptr->V_Tk_GetRelief)
+#endif
+
+#ifndef Tk_GetReliefFromObj
+# define Tk_GetReliefFromObj (*TkdeclsVptr->V_Tk_GetReliefFromObj)
+#endif
+
+#ifndef Tk_GetRootCoords
+# define Tk_GetRootCoords (*TkdeclsVptr->V_Tk_GetRootCoords)
+#endif
+
+#ifndef Tk_GetScreenMM
+# define Tk_GetScreenMM (*TkdeclsVptr->V_Tk_GetScreenMM)
+#endif
+
+#ifndef Tk_GetScrollInfo
+# define Tk_GetScrollInfo (*TkdeclsVptr->V_Tk_GetScrollInfo)
+#endif
+
+#ifndef Tk_GetScrollInfoObj
+# define Tk_GetScrollInfoObj (*TkdeclsVptr->V_Tk_GetScrollInfoObj)
+#endif
+
+#ifndef Tk_GetSelection
+# define Tk_GetSelection (*TkdeclsVptr->V_Tk_GetSelection)
+#endif
+
+#ifndef Tk_GetStyle
+# define Tk_GetStyle (*TkdeclsVptr->V_Tk_GetStyle)
+#endif
+
+#ifndef Tk_GetStyleEngine
+# define Tk_GetStyleEngine (*TkdeclsVptr->V_Tk_GetStyleEngine)
+#endif
+
+#ifndef Tk_GetStyleFromObj
+# define Tk_GetStyleFromObj (*TkdeclsVptr->V_Tk_GetStyleFromObj)
+#endif
+
+#ifndef Tk_GetStyledElement
+# define Tk_GetStyledElement (*TkdeclsVptr->V_Tk_GetStyledElement)
+#endif
+
+#ifndef Tk_GetUid
+# define Tk_GetUid (*TkdeclsVptr->V_Tk_GetUid)
+#endif
+
+#ifndef Tk_GetVRootGeometry
+# define Tk_GetVRootGeometry (*TkdeclsVptr->V_Tk_GetVRootGeometry)
+#endif
+
+#ifndef Tk_GetVisual
+# define Tk_GetVisual (*TkdeclsVptr->V_Tk_GetVisual)
+#endif
+
+#ifndef Tk_Grab
+# define Tk_Grab (*TkdeclsVptr->V_Tk_Grab)
+#endif
+
+#ifndef Tk_HandleEvent
+# define Tk_HandleEvent (*TkdeclsVptr->V_Tk_HandleEvent)
+#endif
+
+#ifndef Tk_IdToWindow
+# define Tk_IdToWindow (*TkdeclsVptr->V_Tk_IdToWindow)
+#endif
+
+#ifndef Tk_ImageChanged
+# define Tk_ImageChanged (*TkdeclsVptr->V_Tk_ImageChanged)
+#endif
+
+#ifndef Tk_InitOptions
+# define Tk_InitOptions (*TkdeclsVptr->V_Tk_InitOptions)
+#endif
+
+#ifndef Tk_InternAtom
+# define Tk_InternAtom (*TkdeclsVptr->V_Tk_InternAtom)
+#endif
+
+#ifndef Tk_IntersectTextLayout
+# define Tk_IntersectTextLayout (*TkdeclsVptr->V_Tk_IntersectTextLayout)
+#endif
+
+#ifndef Tk_MainLoop
+# define Tk_MainLoop (*TkdeclsVptr->V_Tk_MainLoop)
+#endif
+
+#ifndef Tk_MainWindow
+# define Tk_MainWindow (*TkdeclsVptr->V_Tk_MainWindow)
+#endif
+
+#ifndef Tk_MaintainGeometry
+# define Tk_MaintainGeometry (*TkdeclsVptr->V_Tk_MaintainGeometry)
+#endif
+
+#ifndef Tk_MakeWindowExist
+# define Tk_MakeWindowExist (*TkdeclsVptr->V_Tk_MakeWindowExist)
+#endif
+
+#ifndef Tk_ManageGeometry
+# define Tk_ManageGeometry (*TkdeclsVptr->V_Tk_ManageGeometry)
+#endif
+
+#ifndef Tk_MapWindow
+# define Tk_MapWindow (*TkdeclsVptr->V_Tk_MapWindow)
+#endif
+
+#ifndef Tk_MeasureChars
+# define Tk_MeasureChars (*TkdeclsVptr->V_Tk_MeasureChars)
+#endif
+
+#ifndef Tk_MoveResizeWindow
+# define Tk_MoveResizeWindow (*TkdeclsVptr->V_Tk_MoveResizeWindow)
+#endif
+
+#ifndef Tk_MoveToplevelWindow
+# define Tk_MoveToplevelWindow (*TkdeclsVptr->V_Tk_MoveToplevelWindow)
+#endif
+
+#ifndef Tk_MoveWindow
+# define Tk_MoveWindow (*TkdeclsVptr->V_Tk_MoveWindow)
+#endif
+
+#ifndef Tk_NameOf3DBorder
+# define Tk_NameOf3DBorder (*TkdeclsVptr->V_Tk_NameOf3DBorder)
+#endif
+
+#ifndef Tk_NameOfAnchor
+# define Tk_NameOfAnchor (*TkdeclsVptr->V_Tk_NameOfAnchor)
+#endif
+
+#ifndef Tk_NameOfBitmap
+# define Tk_NameOfBitmap (*TkdeclsVptr->V_Tk_NameOfBitmap)
+#endif
+
+#ifndef Tk_NameOfCapStyle
+# define Tk_NameOfCapStyle (*TkdeclsVptr->V_Tk_NameOfCapStyle)
+#endif
+
+#ifndef Tk_NameOfColor
+# define Tk_NameOfColor (*TkdeclsVptr->V_Tk_NameOfColor)
+#endif
+
+#ifndef Tk_NameOfCursor
+# define Tk_NameOfCursor (*TkdeclsVptr->V_Tk_NameOfCursor)
+#endif
+
+#ifndef Tk_NameOfFont
+# define Tk_NameOfFont (*TkdeclsVptr->V_Tk_NameOfFont)
+#endif
+
+#ifndef Tk_NameOfImage
+# define Tk_NameOfImage (*TkdeclsVptr->V_Tk_NameOfImage)
+#endif
+
+#ifndef Tk_NameOfJoinStyle
+# define Tk_NameOfJoinStyle (*TkdeclsVptr->V_Tk_NameOfJoinStyle)
+#endif
+
+#ifndef Tk_NameOfJustify
+# define Tk_NameOfJustify (*TkdeclsVptr->V_Tk_NameOfJustify)
+#endif
+
+#ifndef Tk_NameOfRelief
+# define Tk_NameOfRelief (*TkdeclsVptr->V_Tk_NameOfRelief)
+#endif
+
+#ifndef Tk_NameOfStyle
+# define Tk_NameOfStyle (*TkdeclsVptr->V_Tk_NameOfStyle)
+#endif
+
+#ifndef Tk_NameToWindow
+# define Tk_NameToWindow (*TkdeclsVptr->V_Tk_NameToWindow)
+#endif
+
+#ifndef Tk_OwnSelection
+# define Tk_OwnSelection (*TkdeclsVptr->V_Tk_OwnSelection)
+#endif
+
+#ifndef Tk_PointToChar
+# define Tk_PointToChar (*TkdeclsVptr->V_Tk_PointToChar)
+#endif
+
+#ifndef Tk_PostscriptBitmap
+# define Tk_PostscriptBitmap (*TkdeclsVptr->V_Tk_PostscriptBitmap)
+#endif
+
+#ifndef Tk_PostscriptColor
+# define Tk_PostscriptColor (*TkdeclsVptr->V_Tk_PostscriptColor)
+#endif
+
+#ifndef Tk_PostscriptFont
+# define Tk_PostscriptFont (*TkdeclsVptr->V_Tk_PostscriptFont)
+#endif
+
+#ifndef Tk_PostscriptFontName
+# define Tk_PostscriptFontName (*TkdeclsVptr->V_Tk_PostscriptFontName)
+#endif
+
+#ifndef Tk_PostscriptImage
+# define Tk_PostscriptImage (*TkdeclsVptr->V_Tk_PostscriptImage)
+#endif
+
+#ifndef Tk_PostscriptPath
+# define Tk_PostscriptPath (*TkdeclsVptr->V_Tk_PostscriptPath)
+#endif
+
+#ifndef Tk_PostscriptPhoto
+# define Tk_PostscriptPhoto (*TkdeclsVptr->V_Tk_PostscriptPhoto)
+#endif
+
+#ifndef Tk_PostscriptStipple
+# define Tk_PostscriptStipple (*TkdeclsVptr->V_Tk_PostscriptStipple)
+#endif
+
+#ifndef Tk_PostscriptY
+# define Tk_PostscriptY (*TkdeclsVptr->V_Tk_PostscriptY)
+#endif
+
+#ifndef Tk_PreserveColormap
+# define Tk_PreserveColormap (*TkdeclsVptr->V_Tk_PreserveColormap)
+#endif
+
+#ifndef Tk_QueueWindowEvent
+# define Tk_QueueWindowEvent (*TkdeclsVptr->V_Tk_QueueWindowEvent)
+#endif
+
+#ifndef Tk_RedrawImage
+# define Tk_RedrawImage (*TkdeclsVptr->V_Tk_RedrawImage)
+#endif
+
+#ifndef Tk_RegisterStyleEngine
+# define Tk_RegisterStyleEngine (*TkdeclsVptr->V_Tk_RegisterStyleEngine)
+#endif
+
+#ifndef Tk_RegisterStyledElement
+# define Tk_RegisterStyledElement (*TkdeclsVptr->V_Tk_RegisterStyledElement)
+#endif
+
+#ifndef Tk_ResizeWindow
+# define Tk_ResizeWindow (*TkdeclsVptr->V_Tk_ResizeWindow)
+#endif
+
+#ifndef Tk_RestackWindow
+# define Tk_RestackWindow (*TkdeclsVptr->V_Tk_RestackWindow)
+#endif
+
+#ifndef Tk_RestoreSavedOptions
+# define Tk_RestoreSavedOptions (*TkdeclsVptr->V_Tk_RestoreSavedOptions)
+#endif
+
+#ifndef Tk_RestrictEvents
+# define Tk_RestrictEvents (*TkdeclsVptr->V_Tk_RestrictEvents)
+#endif
+
+#ifndef Tk_SetAppName
+# define Tk_SetAppName (*TkdeclsVptr->V_Tk_SetAppName)
+#endif
+
+#ifndef Tk_SetBackgroundFromBorder
+# define Tk_SetBackgroundFromBorder (*TkdeclsVptr->V_Tk_SetBackgroundFromBorder)
+#endif
+
+#ifndef Tk_SetCaretPos
+# define Tk_SetCaretPos (*TkdeclsVptr->V_Tk_SetCaretPos)
+#endif
+
+#ifndef Tk_SetClass
+# define Tk_SetClass (*TkdeclsVptr->V_Tk_SetClass)
+#endif
+
+#ifndef Tk_SetClassProcs
+# define Tk_SetClassProcs (*TkdeclsVptr->V_Tk_SetClassProcs)
+#endif
+
+#ifndef Tk_SetGrid
+# define Tk_SetGrid (*TkdeclsVptr->V_Tk_SetGrid)
+#endif
+
+#ifndef Tk_SetInternalBorder
+# define Tk_SetInternalBorder (*TkdeclsVptr->V_Tk_SetInternalBorder)
+#endif
+
+#ifndef Tk_SetInternalBorderEx
+# define Tk_SetInternalBorderEx (*TkdeclsVptr->V_Tk_SetInternalBorderEx)
+#endif
+
+#ifndef Tk_SetMinimumRequestSize
+# define Tk_SetMinimumRequestSize (*TkdeclsVptr->V_Tk_SetMinimumRequestSize)
+#endif
+
+#ifndef Tk_SetOptions
+# define Tk_SetOptions (*TkdeclsVptr->V_Tk_SetOptions)
+#endif
+
+#ifndef Tk_SetTSOrigin
+# define Tk_SetTSOrigin (*TkdeclsVptr->V_Tk_SetTSOrigin)
+#endif
+
+#ifndef Tk_SetWindowBackground
+# define Tk_SetWindowBackground (*TkdeclsVptr->V_Tk_SetWindowBackground)
+#endif
+
+#ifndef Tk_SetWindowBackgroundPixmap
+# define Tk_SetWindowBackgroundPixmap (*TkdeclsVptr->V_Tk_SetWindowBackgroundPixmap)
+#endif
+
+#ifndef Tk_SetWindowBorder
+# define Tk_SetWindowBorder (*TkdeclsVptr->V_Tk_SetWindowBorder)
+#endif
+
+#ifndef Tk_SetWindowBorderPixmap
+# define Tk_SetWindowBorderPixmap (*TkdeclsVptr->V_Tk_SetWindowBorderPixmap)
+#endif
+
+#ifndef Tk_SetWindowBorderWidth
+# define Tk_SetWindowBorderWidth (*TkdeclsVptr->V_Tk_SetWindowBorderWidth)
+#endif
+
+#ifndef Tk_SetWindowColormap
+# define Tk_SetWindowColormap (*TkdeclsVptr->V_Tk_SetWindowColormap)
+#endif
+
+#ifndef Tk_SetWindowVisual
+# define Tk_SetWindowVisual (*TkdeclsVptr->V_Tk_SetWindowVisual)
+#endif
+
+#ifndef Tk_SizeOfBitmap
+# define Tk_SizeOfBitmap (*TkdeclsVptr->V_Tk_SizeOfBitmap)
+#endif
+
+#ifndef Tk_SizeOfImage
+# define Tk_SizeOfImage (*TkdeclsVptr->V_Tk_SizeOfImage)
+#endif
+
+#ifndef Tk_StrictMotif
+# define Tk_StrictMotif (*TkdeclsVptr->V_Tk_StrictMotif)
+#endif
+
+#ifndef Tk_TextLayoutToPostscript
+# define Tk_TextLayoutToPostscript (*TkdeclsVptr->V_Tk_TextLayoutToPostscript)
+#endif
+
+#ifndef Tk_TextWidth
+# define Tk_TextWidth (*TkdeclsVptr->V_Tk_TextWidth)
+#endif
+
+#ifndef Tk_UndefineCursor
+# define Tk_UndefineCursor (*TkdeclsVptr->V_Tk_UndefineCursor)
+#endif
+
+#ifndef Tk_UnderlineChars
+# define Tk_UnderlineChars (*TkdeclsVptr->V_Tk_UnderlineChars)
+#endif
+
+#ifndef Tk_UnderlineTextLayout
+# define Tk_UnderlineTextLayout (*TkdeclsVptr->V_Tk_UnderlineTextLayout)
+#endif
+
+#ifndef Tk_Ungrab
+# define Tk_Ungrab (*TkdeclsVptr->V_Tk_Ungrab)
+#endif
+
+#ifndef Tk_UnmaintainGeometry
+# define Tk_UnmaintainGeometry (*TkdeclsVptr->V_Tk_UnmaintainGeometry)
+#endif
+
+#ifndef Tk_UnmapWindow
+# define Tk_UnmapWindow (*TkdeclsVptr->V_Tk_UnmapWindow)
+#endif
+
+#ifndef Tk_UnsetGrid
+# define Tk_UnsetGrid (*TkdeclsVptr->V_Tk_UnsetGrid)
+#endif
+
+#ifndef Tk_UpdatePointer
+# define Tk_UpdatePointer (*TkdeclsVptr->V_Tk_UpdatePointer)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKDECLS_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.t
new file mode 100755
index 00000000000..f112ff449de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls.t
@@ -0,0 +1,1158 @@
+#ifdef _TKDECLS
+#ifndef Tk_3DBorderColor
+VFUNC(XColor *,Tk_3DBorderColor,V_Tk_3DBorderColor,_ANSI_ARGS_((Tk_3DBorder border)))
+#endif /* #ifndef Tk_3DBorderColor */
+
+#ifndef Tk_3DBorderGC
+VFUNC(GC,Tk_3DBorderGC,V_Tk_3DBorderGC,_ANSI_ARGS_((Tk_Window tkwin,
+ Tk_3DBorder border, int which)))
+#endif /* #ifndef Tk_3DBorderGC */
+
+#ifndef Tk_3DHorizontalBevel
+VFUNC(void,Tk_3DHorizontalBevel,V_Tk_3DHorizontalBevel,_ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height, int leftIn,
+ int rightIn, int topBevel, int relief)))
+#endif /* #ifndef Tk_3DHorizontalBevel */
+
+#ifndef Tk_3DVerticalBevel
+VFUNC(void,Tk_3DVerticalBevel,V_Tk_3DVerticalBevel,_ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height, int leftBevel,
+ int relief)))
+#endif /* #ifndef Tk_3DVerticalBevel */
+
+#ifndef Tk_Alloc3DBorderFromObj
+VFUNC(Tk_3DBorder,Tk_Alloc3DBorderFromObj,V_Tk_Alloc3DBorderFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_Alloc3DBorderFromObj */
+
+#ifndef Tk_AllocBitmapFromObj
+VFUNC(Pixmap,Tk_AllocBitmapFromObj,V_Tk_AllocBitmapFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_AllocBitmapFromObj */
+
+#ifndef Tk_AllocColorFromObj
+VFUNC(XColor *,Tk_AllocColorFromObj,V_Tk_AllocColorFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_AllocColorFromObj */
+
+#ifndef Tk_AllocCursorFromObj
+VFUNC(Tk_Cursor,Tk_AllocCursorFromObj,V_Tk_AllocCursorFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_AllocCursorFromObj */
+
+#ifndef Tk_AllocFontFromObj
+VFUNC(Tk_Font,Tk_AllocFontFromObj,V_Tk_AllocFontFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_AllocFontFromObj */
+
+#ifndef Tk_AllocStyleFromObj
+VFUNC(Tk_Style,Tk_AllocStyleFromObj,V_Tk_AllocStyleFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_AllocStyleFromObj */
+
+#ifndef Tk_BindEvent
+VFUNC(void,Tk_BindEvent,V_Tk_BindEvent,_ANSI_ARGS_((
+ Tk_BindingTable bindingTable,
+ XEvent * eventPtr, Tk_Window tkwin,
+ int numObjects, ClientData * objectPtr)))
+#endif /* #ifndef Tk_BindEvent */
+
+#ifndef Tk_ChangeWindowAttributes
+VFUNC(void,Tk_ChangeWindowAttributes,V_Tk_ChangeWindowAttributes,_ANSI_ARGS_((
+ Tk_Window tkwin, unsigned long valueMask,
+ XSetWindowAttributes * attsPtr)))
+#endif /* #ifndef Tk_ChangeWindowAttributes */
+
+#ifndef Tk_CharBbox
+VFUNC(int,Tk_CharBbox,V_Tk_CharBbox,_ANSI_ARGS_((Tk_TextLayout layout,
+ int index, int * xPtr, int * yPtr,
+ int * widthPtr, int * heightPtr)))
+#endif /* #ifndef Tk_CharBbox */
+
+#ifndef Tk_ClearSelection
+VFUNC(void,Tk_ClearSelection,V_Tk_ClearSelection,_ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection)))
+#endif /* #ifndef Tk_ClearSelection */
+
+#ifndef Tk_ClipboardAppend
+VFUNC(int,Tk_ClipboardAppend,V_Tk_ClipboardAppend,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Atom target, Atom format,
+ char* buffer)))
+#endif /* #ifndef Tk_ClipboardAppend */
+
+#ifndef Tk_ClipboardClear
+VFUNC(int,Tk_ClipboardClear,V_Tk_ClipboardClear,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin)))
+#endif /* #ifndef Tk_ClipboardClear */
+
+#ifndef Tk_CollapseMotionEvents
+VFUNC(int,Tk_CollapseMotionEvents,V_Tk_CollapseMotionEvents,_ANSI_ARGS_((
+ Display * display, int collapse)))
+#endif /* #ifndef Tk_CollapseMotionEvents */
+
+#ifndef Tk_ComputeTextLayout
+VFUNC(Tk_TextLayout,Tk_ComputeTextLayout,V_Tk_ComputeTextLayout,_ANSI_ARGS_((Tk_Font font,
+ CONST char * str, int numChars,
+ int wrapLength, Tk_Justify justify,
+ int flags, int * widthPtr, int * heightPtr)))
+#endif /* #ifndef Tk_ComputeTextLayout */
+
+#ifndef Tk_ConfigureInfo
+VFUNC(int,Tk_ConfigureInfo,V_Tk_ConfigureInfo,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec * specs,
+ char * widgRec, CONST char * argvName,
+ int flags)))
+#endif /* #ifndef Tk_ConfigureInfo */
+
+#ifndef Tk_ConfigureValue
+VFUNC(int,Tk_ConfigureValue,V_Tk_ConfigureValue,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec * specs,
+ char * widgRec, CONST char * argvName,
+ int flags)))
+#endif /* #ifndef Tk_ConfigureValue */
+
+#ifndef Tk_ConfigureWidget
+VFUNC(int,Tk_ConfigureWidget,V_Tk_ConfigureWidget,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_ConfigSpec * specs,
+ int argc, CONST84 Tcl_Obj *CONST *objv,
+ char * widgRec, int flags)))
+#endif /* #ifndef Tk_ConfigureWidget */
+
+#ifndef Tk_ConfigureWindow
+VFUNC(void,Tk_ConfigureWindow,V_Tk_ConfigureWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ unsigned int valueMask,
+ XWindowChanges * valuePtr)))
+#endif /* #ifndef Tk_ConfigureWindow */
+
+#ifndef Tk_CoordsToWindow
+VFUNC(Tk_Window,Tk_CoordsToWindow,V_Tk_CoordsToWindow,_ANSI_ARGS_((int rootX, int rootY,
+ Tk_Window tkwin)))
+#endif /* #ifndef Tk_CoordsToWindow */
+
+#ifndef Tk_CreateAnonymousWindow
+VFUNC(Tk_Window,Tk_CreateAnonymousWindow,V_Tk_CreateAnonymousWindow,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window parent,
+ CONST char * screenName)))
+#endif /* #ifndef Tk_CreateAnonymousWindow */
+
+#ifndef Tk_CreateBinding
+VFUNC(unsigned long,Tk_CreateBinding,V_Tk_CreateBinding,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventStr,
+ Tcl_Obj *command, int append)))
+#endif /* #ifndef Tk_CreateBinding */
+
+#ifndef Tk_CreateBindingTable
+VFUNC(Tk_BindingTable,Tk_CreateBindingTable,V_Tk_CreateBindingTable,_ANSI_ARGS_((
+ Tcl_Interp * interp)))
+#endif /* #ifndef Tk_CreateBindingTable */
+
+#ifndef Tk_CreateClientMessageHandler
+VFUNC(void,Tk_CreateClientMessageHandler,V_Tk_CreateClientMessageHandler,_ANSI_ARGS_((
+ Tk_ClientMessageProc * proc)))
+#endif /* #ifndef Tk_CreateClientMessageHandler */
+
+#ifndef Tk_CreateErrorHandler
+VFUNC(Tk_ErrorHandler,Tk_CreateErrorHandler,V_Tk_CreateErrorHandler,_ANSI_ARGS_((Display * display,
+ int errNum, int request, int minorCode,
+ Tk_ErrorProc * errorProc,
+ ClientData clientData)))
+#endif /* #ifndef Tk_CreateErrorHandler */
+
+#ifndef Tk_CreateEventHandler
+VFUNC(void,Tk_CreateEventHandler,V_Tk_CreateEventHandler,_ANSI_ARGS_((Tk_Window token,
+ unsigned long mask, Tk_EventProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tk_CreateEventHandler */
+
+#ifndef Tk_CreateGenericHandler
+VFUNC(void,Tk_CreateGenericHandler,V_Tk_CreateGenericHandler,_ANSI_ARGS_((
+ Tk_GenericProc * proc, ClientData clientData)))
+#endif /* #ifndef Tk_CreateGenericHandler */
+
+#ifndef Tk_CreateImageType
+VFUNC(void,Tk_CreateImageType,V_Tk_CreateImageType,_ANSI_ARGS_((
+ Tk_ImageType * typePtr)))
+#endif /* #ifndef Tk_CreateImageType */
+
+#ifndef Tk_CreateOptionTable
+VFUNC(Tk_OptionTable,Tk_CreateOptionTable,V_Tk_CreateOptionTable,_ANSI_ARGS_((
+ Tcl_Interp * interp,
+ CONST Tk_OptionSpec * templatePtr)))
+#endif /* #ifndef Tk_CreateOptionTable */
+
+#ifndef Tk_CreateSelHandler
+VFUNC(void,Tk_CreateSelHandler,V_Tk_CreateSelHandler,_ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection, Atom target,
+ Tk_SelectionProc * proc,
+ ClientData clientData, Atom format)))
+#endif /* #ifndef Tk_CreateSelHandler */
+
+#ifndef Tk_CreateStyle
+VFUNC(Tk_Style,Tk_CreateStyle,V_Tk_CreateStyle,_ANSI_ARGS_((CONST char * name,
+ Tk_StyleEngine engine, ClientData clientData)))
+#endif /* #ifndef Tk_CreateStyle */
+
+#ifndef Tk_CreateWindow
+VFUNC(Tk_Window,Tk_CreateWindow,V_Tk_CreateWindow,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window parent, CONST char * name,
+ CONST char * screenName)))
+#endif /* #ifndef Tk_CreateWindow */
+
+#ifndef Tk_CreateWindowFromPath
+VFUNC(Tk_Window,Tk_CreateWindowFromPath,V_Tk_CreateWindowFromPath,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ CONST char * pathName,
+ CONST char * screenName)))
+#endif /* #ifndef Tk_CreateWindowFromPath */
+
+#ifndef Tk_DefineBitmap
+VFUNC(int,Tk_DefineBitmap,V_Tk_DefineBitmap,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, CONST char * source,
+ int width, int height)))
+#endif /* #ifndef Tk_DefineBitmap */
+
+#ifndef Tk_DefineCursor
+VFUNC(void,Tk_DefineCursor,V_Tk_DefineCursor,_ANSI_ARGS_((Tk_Window window,
+ Tk_Cursor cursor)))
+#endif /* #ifndef Tk_DefineCursor */
+
+#ifndef Tk_DeleteAllBindings
+VFUNC(void,Tk_DeleteAllBindings,V_Tk_DeleteAllBindings,_ANSI_ARGS_((
+ Tk_BindingTable bindingTable,
+ ClientData object)))
+#endif /* #ifndef Tk_DeleteAllBindings */
+
+#ifndef Tk_DeleteBinding
+VFUNC(int,Tk_DeleteBinding,V_Tk_DeleteBinding,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventStr)))
+#endif /* #ifndef Tk_DeleteBinding */
+
+#ifndef Tk_DeleteBindingTable
+VFUNC(void,Tk_DeleteBindingTable,V_Tk_DeleteBindingTable,_ANSI_ARGS_((
+ Tk_BindingTable bindingTable)))
+#endif /* #ifndef Tk_DeleteBindingTable */
+
+#ifndef Tk_DeleteClientMessageHandler
+VFUNC(void,Tk_DeleteClientMessageHandler,V_Tk_DeleteClientMessageHandler,_ANSI_ARGS_((
+ Tk_ClientMessageProc * proc)))
+#endif /* #ifndef Tk_DeleteClientMessageHandler */
+
+#ifndef Tk_DeleteErrorHandler
+VFUNC(void,Tk_DeleteErrorHandler,V_Tk_DeleteErrorHandler,_ANSI_ARGS_((
+ Tk_ErrorHandler handler)))
+#endif /* #ifndef Tk_DeleteErrorHandler */
+
+#ifndef Tk_DeleteEventHandler
+VFUNC(void,Tk_DeleteEventHandler,V_Tk_DeleteEventHandler,_ANSI_ARGS_((Tk_Window token,
+ unsigned long mask, Tk_EventProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tk_DeleteEventHandler */
+
+#ifndef Tk_DeleteGenericHandler
+VFUNC(void,Tk_DeleteGenericHandler,V_Tk_DeleteGenericHandler,_ANSI_ARGS_((
+ Tk_GenericProc * proc, ClientData clientData)))
+#endif /* #ifndef Tk_DeleteGenericHandler */
+
+#ifndef Tk_DeleteImage
+VFUNC(void,Tk_DeleteImage,V_Tk_DeleteImage,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name)))
+#endif /* #ifndef Tk_DeleteImage */
+
+#ifndef Tk_DeleteOptionTable
+VFUNC(void,Tk_DeleteOptionTable,V_Tk_DeleteOptionTable,_ANSI_ARGS_((
+ Tk_OptionTable optionTable)))
+#endif /* #ifndef Tk_DeleteOptionTable */
+
+#ifndef Tk_DeleteSelHandler
+VFUNC(void,Tk_DeleteSelHandler,V_Tk_DeleteSelHandler,_ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection, Atom target)))
+#endif /* #ifndef Tk_DeleteSelHandler */
+
+#ifndef Tk_DestroyWindow
+VFUNC(void,Tk_DestroyWindow,V_Tk_DestroyWindow,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_DestroyWindow */
+
+#ifndef Tk_DisplayName
+VFUNC(CONST84_RETURN char *,Tk_DisplayName,V_Tk_DisplayName,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_DisplayName */
+
+#ifndef Tk_DistanceToTextLayout
+VFUNC(int,Tk_DistanceToTextLayout,V_Tk_DistanceToTextLayout,_ANSI_ARGS_((
+ Tk_TextLayout layout, int x, int y)))
+#endif /* #ifndef Tk_DistanceToTextLayout */
+
+#ifndef Tk_Draw3DPolygon
+VFUNC(void,Tk_Draw3DPolygon,V_Tk_Draw3DPolygon,_ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border,
+ XPoint * pointPtr, int numPoints,
+ int borderWidth, int leftRelief)))
+#endif /* #ifndef Tk_Draw3DPolygon */
+
+#ifndef Tk_Draw3DRectangle
+VFUNC(void,Tk_Draw3DRectangle,V_Tk_Draw3DRectangle,_ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height,
+ int borderWidth, int relief)))
+#endif /* #ifndef Tk_Draw3DRectangle */
+
+#ifndef Tk_DrawChars
+VFUNC(void,Tk_DrawChars,V_Tk_DrawChars,_ANSI_ARGS_((Display * display,
+ Drawable drawable, GC gc, Tk_Font tkfont,
+ CONST char * source, int numBytes, int x,
+ int y)))
+#endif /* #ifndef Tk_DrawChars */
+
+#ifndef Tk_DrawElement
+VFUNC(void,Tk_DrawElement,V_Tk_DrawElement,_ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin, Drawable d, int x, int y,
+ int width, int height, int state)))
+#endif /* #ifndef Tk_DrawElement */
+
+#ifndef Tk_DrawFocusHighlight
+VFUNC(void,Tk_DrawFocusHighlight,V_Tk_DrawFocusHighlight,_ANSI_ARGS_((Tk_Window tkwin,
+ GC gc, int width, Drawable drawable)))
+#endif /* #ifndef Tk_DrawFocusHighlight */
+
+#ifndef Tk_DrawTextLayout
+VFUNC(void,Tk_DrawTextLayout,V_Tk_DrawTextLayout,_ANSI_ARGS_((Display * display,
+ Drawable drawable, GC gc,
+ Tk_TextLayout layout, int x, int y,
+ int firstChar, int lastChar)))
+#endif /* #ifndef Tk_DrawTextLayout */
+
+#ifndef Tk_Fill3DPolygon
+VFUNC(void,Tk_Fill3DPolygon,V_Tk_Fill3DPolygon,_ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border,
+ XPoint * pointPtr, int numPoints,
+ int borderWidth, int leftRelief)))
+#endif /* #ifndef Tk_Fill3DPolygon */
+
+#ifndef Tk_Fill3DRectangle
+VFUNC(void,Tk_Fill3DRectangle,V_Tk_Fill3DRectangle,_ANSI_ARGS_((Tk_Window tkwin,
+ Drawable drawable, Tk_3DBorder border, int x,
+ int y, int width, int height,
+ int borderWidth, int relief)))
+#endif /* #ifndef Tk_Fill3DRectangle */
+
+#ifndef Tk_FontId
+VFUNC(Font,Tk_FontId,V_Tk_FontId,_ANSI_ARGS_((Tk_Font font)))
+#endif /* #ifndef Tk_FontId */
+
+#ifndef Tk_Free3DBorder
+VFUNC(void,Tk_Free3DBorder,V_Tk_Free3DBorder,_ANSI_ARGS_((Tk_3DBorder border)))
+#endif /* #ifndef Tk_Free3DBorder */
+
+#ifndef Tk_Free3DBorderFromObj
+VFUNC(void,Tk_Free3DBorderFromObj,V_Tk_Free3DBorderFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_Free3DBorderFromObj */
+
+#ifndef Tk_FreeBitmap
+VFUNC(void,Tk_FreeBitmap,V_Tk_FreeBitmap,_ANSI_ARGS_((Display * display,
+ Pixmap bitmap)))
+#endif /* #ifndef Tk_FreeBitmap */
+
+#ifndef Tk_FreeBitmapFromObj
+VFUNC(void,Tk_FreeBitmapFromObj,V_Tk_FreeBitmapFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_FreeBitmapFromObj */
+
+#ifndef Tk_FreeColor
+VFUNC(void,Tk_FreeColor,V_Tk_FreeColor,_ANSI_ARGS_((XColor * colorPtr)))
+#endif /* #ifndef Tk_FreeColor */
+
+#ifndef Tk_FreeColorFromObj
+VFUNC(void,Tk_FreeColorFromObj,V_Tk_FreeColorFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_FreeColorFromObj */
+
+#ifndef Tk_FreeColormap
+VFUNC(void,Tk_FreeColormap,V_Tk_FreeColormap,_ANSI_ARGS_((Display * display,
+ Colormap colormap)))
+#endif /* #ifndef Tk_FreeColormap */
+
+#ifndef Tk_FreeConfigOptions
+VFUNC(void,Tk_FreeConfigOptions,V_Tk_FreeConfigOptions,_ANSI_ARGS_((char * recordPtr,
+ Tk_OptionTable optionToken, Tk_Window tkwin)))
+#endif /* #ifndef Tk_FreeConfigOptions */
+
+#ifndef Tk_FreeCursor
+VFUNC(void,Tk_FreeCursor,V_Tk_FreeCursor,_ANSI_ARGS_((Display * display,
+ Tk_Cursor cursor)))
+#endif /* #ifndef Tk_FreeCursor */
+
+#ifndef Tk_FreeCursorFromObj
+VFUNC(void,Tk_FreeCursorFromObj,V_Tk_FreeCursorFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_FreeCursorFromObj */
+
+#ifndef Tk_FreeFont
+VFUNC(void,Tk_FreeFont,V_Tk_FreeFont,_ANSI_ARGS_((Tk_Font f)))
+#endif /* #ifndef Tk_FreeFont */
+
+#ifndef Tk_FreeFontFromObj
+VFUNC(void,Tk_FreeFontFromObj,V_Tk_FreeFontFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_FreeFontFromObj */
+
+#ifndef Tk_FreeGC
+VFUNC(void,Tk_FreeGC,V_Tk_FreeGC,_ANSI_ARGS_((Display * display, GC gc)))
+#endif /* #ifndef Tk_FreeGC */
+
+#ifndef Tk_FreeImage
+VFUNC(void,Tk_FreeImage,V_Tk_FreeImage,_ANSI_ARGS_((Tk_Image image)))
+#endif /* #ifndef Tk_FreeImage */
+
+#ifndef Tk_FreeOptions
+VFUNC(void,Tk_FreeOptions,V_Tk_FreeOptions,_ANSI_ARGS_((Tk_ConfigSpec * specs,
+ char * widgRec, Display * display,
+ int needFlags)))
+#endif /* #ifndef Tk_FreeOptions */
+
+#ifndef Tk_FreePixmap
+VFUNC(void,Tk_FreePixmap,V_Tk_FreePixmap,_ANSI_ARGS_((Display * display,
+ Pixmap pixmap)))
+#endif /* #ifndef Tk_FreePixmap */
+
+#ifndef Tk_FreeSavedOptions
+VFUNC(void,Tk_FreeSavedOptions,V_Tk_FreeSavedOptions,_ANSI_ARGS_((
+ Tk_SavedOptions * savePtr)))
+#endif /* #ifndef Tk_FreeSavedOptions */
+
+#ifndef Tk_FreeStyle
+VFUNC(void,Tk_FreeStyle,V_Tk_FreeStyle,_ANSI_ARGS_((Tk_Style style)))
+#endif /* #ifndef Tk_FreeStyle */
+
+#ifndef Tk_FreeStyleFromObj
+VFUNC(void,Tk_FreeStyleFromObj,V_Tk_FreeStyleFromObj,_ANSI_ARGS_((Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_FreeStyleFromObj */
+
+#ifndef Tk_FreeTextLayout
+VFUNC(void,Tk_FreeTextLayout,V_Tk_FreeTextLayout,_ANSI_ARGS_((
+ Tk_TextLayout textLayout)))
+#endif /* #ifndef Tk_FreeTextLayout */
+
+#ifndef Tk_FreeXId
+VFUNC(void,Tk_FreeXId,V_Tk_FreeXId,_ANSI_ARGS_((Display * display, XID xid)))
+#endif /* #ifndef Tk_FreeXId */
+
+#ifndef Tk_GCForColor
+VFUNC(GC,Tk_GCForColor,V_Tk_GCForColor,_ANSI_ARGS_((XColor * colorPtr,
+ Drawable drawable)))
+#endif /* #ifndef Tk_GCForColor */
+
+#ifndef Tk_GeometryRequest
+VFUNC(void,Tk_GeometryRequest,V_Tk_GeometryRequest,_ANSI_ARGS_((Tk_Window tkwin,
+ int reqWidth, int reqHeight)))
+#endif /* #ifndef Tk_GeometryRequest */
+
+#ifndef Tk_Get3DBorder
+VFUNC(Tk_3DBorder,Tk_Get3DBorder,V_Tk_Get3DBorder,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid colorName)))
+#endif /* #ifndef Tk_Get3DBorder */
+
+#ifndef Tk_Get3DBorderFromObj
+VFUNC(Tk_3DBorder,Tk_Get3DBorderFromObj,V_Tk_Get3DBorderFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_Get3DBorderFromObj */
+
+#ifndef Tk_GetAllBindings
+VFUNC(void,Tk_GetAllBindings,V_Tk_GetAllBindings,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object)))
+#endif /* #ifndef Tk_GetAllBindings */
+
+#ifndef Tk_GetAnchor
+VFUNC(int,Tk_GetAnchor,V_Tk_GetAnchor,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, Tk_Anchor * anchorPtr)))
+#endif /* #ifndef Tk_GetAnchor */
+
+#ifndef Tk_GetAnchorFromObj
+VFUNC(int,Tk_GetAnchorFromObj,V_Tk_GetAnchorFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, Tk_Anchor * anchorPtr)))
+#endif /* #ifndef Tk_GetAnchorFromObj */
+
+#ifndef Tk_GetAtomName
+VFUNC(CONST84_RETURN char *,Tk_GetAtomName,V_Tk_GetAtomName,_ANSI_ARGS_((Tk_Window tkwin,
+ Atom atom)))
+#endif /* #ifndef Tk_GetAtomName */
+
+#ifndef Tk_GetBinding
+VFUNC(Tcl_Obj *,Tk_GetBinding,V_Tk_GetBinding,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventStr)))
+#endif /* #ifndef Tk_GetBinding */
+
+#ifndef Tk_GetBitmap
+VFUNC(Pixmap,Tk_GetBitmap,V_Tk_GetBitmap,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str)))
+#endif /* #ifndef Tk_GetBitmap */
+
+#ifndef Tk_GetBitmapFromData
+VFUNC(Pixmap,Tk_GetBitmapFromData,V_Tk_GetBitmapFromData,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ CONST char * source, int width, int height)))
+#endif /* #ifndef Tk_GetBitmapFromData */
+
+#ifndef Tk_GetBitmapFromObj
+VFUNC(Pixmap,Tk_GetBitmapFromObj,V_Tk_GetBitmapFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_GetBitmapFromObj */
+
+#ifndef Tk_GetCapStyle
+VFUNC(int,Tk_GetCapStyle,V_Tk_GetCapStyle,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * capPtr)))
+#endif /* #ifndef Tk_GetCapStyle */
+
+#ifndef Tk_GetColor
+VFUNC(XColor *,Tk_GetColor,V_Tk_GetColor,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid name)))
+#endif /* #ifndef Tk_GetColor */
+
+#ifndef Tk_GetColorByValue
+VFUNC(XColor *,Tk_GetColorByValue,V_Tk_GetColorByValue,_ANSI_ARGS_((Tk_Window tkwin,
+ XColor * colorPtr)))
+#endif /* #ifndef Tk_GetColorByValue */
+
+#ifndef Tk_GetColorFromObj
+VFUNC(XColor *,Tk_GetColorFromObj,V_Tk_GetColorFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_GetColorFromObj */
+
+#ifndef Tk_GetColormap
+VFUNC(Colormap,Tk_GetColormap,V_Tk_GetColormap,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str)))
+#endif /* #ifndef Tk_GetColormap */
+
+#ifndef Tk_GetCursor
+VFUNC(Tk_Cursor,Tk_GetCursor,V_Tk_GetCursor,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid str)))
+#endif /* #ifndef Tk_GetCursor */
+
+#ifndef Tk_GetCursorFromData
+VFUNC(Tk_Cursor,Tk_GetCursorFromData,V_Tk_GetCursorFromData,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ CONST char * source, CONST char * mask,
+ int width, int height, int xHot, int yHot,
+ Tk_Uid fg, Tk_Uid bg)))
+#endif /* #ifndef Tk_GetCursorFromData */
+
+#ifndef Tk_GetCursorFromObj
+VFUNC(Tk_Cursor,Tk_GetCursorFromObj,V_Tk_GetCursorFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_GetCursorFromObj */
+
+#ifndef Tk_GetElementBorderWidth
+VFUNC(int,Tk_GetElementBorderWidth,V_Tk_GetElementBorderWidth,_ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin)))
+#endif /* #ifndef Tk_GetElementBorderWidth */
+
+#ifndef Tk_GetElementBox
+VFUNC(void,Tk_GetElementBox,V_Tk_GetElementBox,_ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin, int x, int y, int width,
+ int height, int inner, int * xPtr,
+ int * yPtr, int * widthPtr, int * heightPtr)))
+#endif /* #ifndef Tk_GetElementBox */
+
+#ifndef Tk_GetElementId
+VFUNC(int,Tk_GetElementId,V_Tk_GetElementId,_ANSI_ARGS_((CONST char * name)))
+#endif /* #ifndef Tk_GetElementId */
+
+#ifndef Tk_GetElementSize
+VFUNC(void,Tk_GetElementSize,V_Tk_GetElementSize,_ANSI_ARGS_((Tk_Style style,
+ Tk_StyledElement element, char * recordPtr,
+ Tk_Window tkwin, int width, int height,
+ int inner, int * widthPtr, int * heightPtr)))
+#endif /* #ifndef Tk_GetElementSize */
+
+#ifndef Tk_GetFont
+VFUNC(Tk_Font,Tk_GetFont,V_Tk_GetFont,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str)))
+#endif /* #ifndef Tk_GetFont */
+
+#ifndef Tk_GetFontFromObj
+VFUNC(Tk_Font,Tk_GetFontFromObj,V_Tk_GetFontFromObj,_ANSI_ARGS_((Tk_Window tkwin,
+ Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_GetFontFromObj */
+
+#ifndef Tk_GetFontMetrics
+VFUNC(void,Tk_GetFontMetrics,V_Tk_GetFontMetrics,_ANSI_ARGS_((Tk_Font font,
+ Tk_FontMetrics * fmPtr)))
+#endif /* #ifndef Tk_GetFontMetrics */
+
+#ifndef Tk_GetGC
+VFUNC(GC,Tk_GetGC,V_Tk_GetGC,_ANSI_ARGS_((Tk_Window tkwin,
+ unsigned long valueMask,
+ XGCValues * valuePtr)))
+#endif /* #ifndef Tk_GetGC */
+
+#ifndef Tk_GetImage
+VFUNC(Tk_Image,Tk_GetImage,V_Tk_GetImage,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * name,
+ Tk_ImageChangedProc * changeProc,
+ ClientData clientData)))
+#endif /* #ifndef Tk_GetImage */
+
+#ifndef Tk_GetImageMasterData
+VFUNC(ClientData,Tk_GetImageMasterData,V_Tk_GetImageMasterData,_ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ Tk_ImageType ** typePtrPtr)))
+#endif /* #ifndef Tk_GetImageMasterData */
+
+#ifndef Tk_GetJoinStyle
+VFUNC(int,Tk_GetJoinStyle,V_Tk_GetJoinStyle,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, int * joinPtr)))
+#endif /* #ifndef Tk_GetJoinStyle */
+
+#ifndef Tk_GetJustify
+VFUNC(int,Tk_GetJustify,V_Tk_GetJustify,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, Tk_Justify * justifyPtr)))
+#endif /* #ifndef Tk_GetJustify */
+
+#ifndef Tk_GetJustifyFromObj
+VFUNC(int,Tk_GetJustifyFromObj,V_Tk_GetJustifyFromObj,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ Tk_Justify * justifyPtr)))
+#endif /* #ifndef Tk_GetJustifyFromObj */
+
+#ifndef Tk_GetMMFromObj
+VFUNC(int,Tk_GetMMFromObj,V_Tk_GetMMFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr,
+ double * doublePtr)))
+#endif /* #ifndef Tk_GetMMFromObj */
+
+#ifndef Tk_GetNumMainWindows
+VFUNC(int,Tk_GetNumMainWindows,V_Tk_GetNumMainWindows,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tk_GetNumMainWindows */
+
+#ifndef Tk_GetOptionInfo
+VFUNC(Tcl_Obj *,Tk_GetOptionInfo,V_Tk_GetOptionInfo,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionTable,
+ Tcl_Obj * namePtr, Tk_Window tkwin)))
+#endif /* #ifndef Tk_GetOptionInfo */
+
+#ifndef Tk_GetOptionValue
+VFUNC(Tcl_Obj *,Tk_GetOptionValue,V_Tk_GetOptionValue,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionTable,
+ Tcl_Obj * namePtr, Tk_Window tkwin)))
+#endif /* #ifndef Tk_GetOptionValue */
+
+#ifndef Tk_GetPixels
+VFUNC(int,Tk_GetPixels,V_Tk_GetPixels,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str,
+ int * intPtr)))
+#endif /* #ifndef Tk_GetPixels */
+
+#ifndef Tk_GetPixelsFromObj
+VFUNC(int,Tk_GetPixelsFromObj,V_Tk_GetPixelsFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr,
+ int * intPtr)))
+#endif /* #ifndef Tk_GetPixelsFromObj */
+
+#ifndef Tk_GetPixmap
+VFUNC(Pixmap,Tk_GetPixmap,V_Tk_GetPixmap,_ANSI_ARGS_((Display * display,
+ Drawable d, int width, int height, int depth)))
+#endif /* #ifndef Tk_GetPixmap */
+
+#ifndef Tk_GetRelief
+VFUNC(int,Tk_GetRelief,V_Tk_GetRelief,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, int * reliefPtr)))
+#endif /* #ifndef Tk_GetRelief */
+
+#ifndef Tk_GetReliefFromObj
+VFUNC(int,Tk_GetReliefFromObj,V_Tk_GetReliefFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int * resultPtr)))
+#endif /* #ifndef Tk_GetReliefFromObj */
+
+#ifndef Tk_GetRootCoords
+VFUNC(void,Tk_GetRootCoords,V_Tk_GetRootCoords,_ANSI_ARGS_((Tk_Window tkwin,
+ int * xPtr, int * yPtr)))
+#endif /* #ifndef Tk_GetRootCoords */
+
+#ifndef Tk_GetScreenMM
+VFUNC(int,Tk_GetScreenMM,V_Tk_GetScreenMM,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, CONST char * str,
+ double * doublePtr)))
+#endif /* #ifndef Tk_GetScreenMM */
+
+#ifndef Tk_GetScrollInfo
+VFUNC(int,Tk_GetScrollInfo,V_Tk_GetScrollInfo,_ANSI_ARGS_((Tcl_Interp * interp,
+ int argc, CONST84 Tcl_Obj *CONST *objv,
+ double * dblPtr, int * intPtr)))
+#endif /* #ifndef Tk_GetScrollInfo */
+
+#ifndef Tk_GetScrollInfoObj
+VFUNC(int,Tk_GetScrollInfoObj,V_Tk_GetScrollInfoObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[],
+ double * dblPtr, int * intPtr)))
+#endif /* #ifndef Tk_GetScrollInfoObj */
+
+#ifndef Tk_GetSelection
+VFUNC(int,Tk_GetSelection,V_Tk_GetSelection,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Atom selection, Atom target,
+ Tk_GetSelProc * proc, ClientData clientData)))
+#endif /* #ifndef Tk_GetSelection */
+
+#ifndef Tk_GetStyle
+VFUNC(Tk_Style,Tk_GetStyle,V_Tk_GetStyle,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name)))
+#endif /* #ifndef Tk_GetStyle */
+
+#ifndef Tk_GetStyleEngine
+VFUNC(Tk_StyleEngine,Tk_GetStyleEngine,V_Tk_GetStyleEngine,_ANSI_ARGS_((CONST char * name)))
+#endif /* #ifndef Tk_GetStyleEngine */
+
+#ifndef Tk_GetStyleFromObj
+VFUNC(Tk_Style,Tk_GetStyleFromObj,V_Tk_GetStyleFromObj,_ANSI_ARGS_((Tcl_Obj * objPtr)))
+#endif /* #ifndef Tk_GetStyleFromObj */
+
+#ifndef Tk_GetStyledElement
+VFUNC(Tk_StyledElement,Tk_GetStyledElement,V_Tk_GetStyledElement,_ANSI_ARGS_((Tk_Style style,
+ int elementId, Tk_OptionTable optionTable)))
+#endif /* #ifndef Tk_GetStyledElement */
+
+#ifndef Tk_GetUid
+VFUNC(Tk_Uid,Tk_GetUid,V_Tk_GetUid,_ANSI_ARGS_((CONST char * str)))
+#endif /* #ifndef Tk_GetUid */
+
+#ifndef Tk_GetVRootGeometry
+VFUNC(void,Tk_GetVRootGeometry,V_Tk_GetVRootGeometry,_ANSI_ARGS_((Tk_Window tkwin,
+ int * xPtr, int * yPtr, int * widthPtr,
+ int * heightPtr)))
+#endif /* #ifndef Tk_GetVRootGeometry */
+
+#ifndef Tk_GetVisual
+VFUNC(Visual *,Tk_GetVisual,V_Tk_GetVisual,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj *str,
+ int * depthPtr, Colormap * colormapPtr)))
+#endif /* #ifndef Tk_GetVisual */
+
+#ifndef Tk_Grab
+VFUNC(int,Tk_Grab,V_Tk_Grab,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, int grabGlobal)))
+#endif /* #ifndef Tk_Grab */
+
+#ifndef Tk_HandleEvent
+VFUNC(void,Tk_HandleEvent,V_Tk_HandleEvent,_ANSI_ARGS_((XEvent * eventPtr)))
+#endif /* #ifndef Tk_HandleEvent */
+
+#ifndef Tk_IdToWindow
+VFUNC(Tk_Window,Tk_IdToWindow,V_Tk_IdToWindow,_ANSI_ARGS_((Display * display,
+ Window window)))
+#endif /* #ifndef Tk_IdToWindow */
+
+#ifndef Tk_ImageChanged
+VFUNC(void,Tk_ImageChanged,V_Tk_ImageChanged,_ANSI_ARGS_((Tk_ImageMaster master,
+ int x, int y, int width, int height,
+ int imageWidth, int imageHeight)))
+#endif /* #ifndef Tk_ImageChanged */
+
+#ifndef Tk_InitOptions
+VFUNC(int,Tk_InitOptions,V_Tk_InitOptions,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionToken,
+ Tk_Window tkwin)))
+#endif /* #ifndef Tk_InitOptions */
+
+#ifndef Tk_InternAtom
+VFUNC(Atom,Tk_InternAtom,V_Tk_InternAtom,_ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name)))
+#endif /* #ifndef Tk_InternAtom */
+
+#ifndef Tk_IntersectTextLayout
+VFUNC(int,Tk_IntersectTextLayout,V_Tk_IntersectTextLayout,_ANSI_ARGS_((
+ Tk_TextLayout layout, int x, int y,
+ int width, int height)))
+#endif /* #ifndef Tk_IntersectTextLayout */
+
+#ifndef Tk_MainLoop
+VFUNC(void,Tk_MainLoop,V_Tk_MainLoop,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tk_MainLoop */
+
+#ifndef Tk_MainWindow
+VFUNC(Tk_Window,Tk_MainWindow,V_Tk_MainWindow,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifndef Tk_MainWindow */
+
+#ifndef Tk_MaintainGeometry
+VFUNC(void,Tk_MaintainGeometry,V_Tk_MaintainGeometry,_ANSI_ARGS_((Tk_Window slave,
+ Tk_Window master, int x, int y, int width,
+ int height)))
+#endif /* #ifndef Tk_MaintainGeometry */
+
+#ifndef Tk_MakeWindowExist
+VFUNC(void,Tk_MakeWindowExist,V_Tk_MakeWindowExist,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_MakeWindowExist */
+
+#ifndef Tk_ManageGeometry
+VFUNC(void,Tk_ManageGeometry,V_Tk_ManageGeometry,_ANSI_ARGS_((Tk_Window tkwin,
+ Tk_GeomMgr * mgrPtr, ClientData clientData)))
+#endif /* #ifndef Tk_ManageGeometry */
+
+#ifndef Tk_MapWindow
+VFUNC(void,Tk_MapWindow,V_Tk_MapWindow,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_MapWindow */
+
+#ifndef Tk_MeasureChars
+VFUNC(int,Tk_MeasureChars,V_Tk_MeasureChars,_ANSI_ARGS_((Tk_Font tkfont,
+ CONST char * source, int numBytes,
+ int maxPixels, int flags, int * lengthPtr)))
+#endif /* #ifndef Tk_MeasureChars */
+
+#ifndef Tk_MoveResizeWindow
+VFUNC(void,Tk_MoveResizeWindow,V_Tk_MoveResizeWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y, int width, int height)))
+#endif /* #ifndef Tk_MoveResizeWindow */
+
+#ifndef Tk_MoveToplevelWindow
+VFUNC(void,Tk_MoveToplevelWindow,V_Tk_MoveToplevelWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y)))
+#endif /* #ifndef Tk_MoveToplevelWindow */
+
+#ifndef Tk_MoveWindow
+VFUNC(void,Tk_MoveWindow,V_Tk_MoveWindow,_ANSI_ARGS_((Tk_Window tkwin, int x,
+ int y)))
+#endif /* #ifndef Tk_MoveWindow */
+
+#ifndef Tk_NameOf3DBorder
+VFUNC(CONST84_RETURN char *,Tk_NameOf3DBorder,V_Tk_NameOf3DBorder,_ANSI_ARGS_((
+ Tk_3DBorder border)))
+#endif /* #ifndef Tk_NameOf3DBorder */
+
+#ifndef Tk_NameOfAnchor
+VFUNC(CONST84_RETURN char *,Tk_NameOfAnchor,V_Tk_NameOfAnchor,_ANSI_ARGS_((Tk_Anchor anchor)))
+#endif /* #ifndef Tk_NameOfAnchor */
+
+#ifndef Tk_NameOfBitmap
+VFUNC(CONST84_RETURN char *,Tk_NameOfBitmap,V_Tk_NameOfBitmap,_ANSI_ARGS_((Display * display,
+ Pixmap bitmap)))
+#endif /* #ifndef Tk_NameOfBitmap */
+
+#ifndef Tk_NameOfCapStyle
+VFUNC(CONST84_RETURN char *,Tk_NameOfCapStyle,V_Tk_NameOfCapStyle,_ANSI_ARGS_((int cap)))
+#endif /* #ifndef Tk_NameOfCapStyle */
+
+#ifndef Tk_NameOfColor
+VFUNC(CONST84_RETURN char *,Tk_NameOfColor,V_Tk_NameOfColor,_ANSI_ARGS_((XColor * colorPtr)))
+#endif /* #ifndef Tk_NameOfColor */
+
+#ifndef Tk_NameOfCursor
+VFUNC(CONST84_RETURN char *,Tk_NameOfCursor,V_Tk_NameOfCursor,_ANSI_ARGS_((Display * display,
+ Tk_Cursor cursor)))
+#endif /* #ifndef Tk_NameOfCursor */
+
+#ifndef Tk_NameOfFont
+VFUNC(CONST84_RETURN char *,Tk_NameOfFont,V_Tk_NameOfFont,_ANSI_ARGS_((Tk_Font font)))
+#endif /* #ifndef Tk_NameOfFont */
+
+#ifndef Tk_NameOfImage
+VFUNC(CONST84_RETURN char *,Tk_NameOfImage,V_Tk_NameOfImage,_ANSI_ARGS_((
+ Tk_ImageMaster imageMaster)))
+#endif /* #ifndef Tk_NameOfImage */
+
+#ifndef Tk_NameOfJoinStyle
+VFUNC(CONST84_RETURN char *,Tk_NameOfJoinStyle,V_Tk_NameOfJoinStyle,_ANSI_ARGS_((int join)))
+#endif /* #ifndef Tk_NameOfJoinStyle */
+
+#ifndef Tk_NameOfJustify
+VFUNC(CONST84_RETURN char *,Tk_NameOfJustify,V_Tk_NameOfJustify,_ANSI_ARGS_((
+ Tk_Justify justify)))
+#endif /* #ifndef Tk_NameOfJustify */
+
+#ifndef Tk_NameOfRelief
+VFUNC(CONST84_RETURN char *,Tk_NameOfRelief,V_Tk_NameOfRelief,_ANSI_ARGS_((int relief)))
+#endif /* #ifndef Tk_NameOfRelief */
+
+#ifndef Tk_NameOfStyle
+VFUNC(CONST char *,Tk_NameOfStyle,V_Tk_NameOfStyle,_ANSI_ARGS_((Tk_Style style)))
+#endif /* #ifndef Tk_NameOfStyle */
+
+#ifndef Tk_NameToWindow
+VFUNC(Tk_Window,Tk_NameToWindow,V_Tk_NameToWindow,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * pathName, Tk_Window tkwin)))
+#endif /* #ifndef Tk_NameToWindow */
+
+#ifndef Tk_OwnSelection
+VFUNC(void,Tk_OwnSelection,V_Tk_OwnSelection,_ANSI_ARGS_((Tk_Window tkwin,
+ Atom selection, Tk_LostSelProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tk_OwnSelection */
+
+#ifndef Tk_PointToChar
+VFUNC(int,Tk_PointToChar,V_Tk_PointToChar,_ANSI_ARGS_((Tk_TextLayout layout,
+ int x, int y)))
+#endif /* #ifndef Tk_PointToChar */
+
+#ifndef Tk_PostscriptBitmap
+VFUNC(int,Tk_PostscriptBitmap,V_Tk_PostscriptBitmap,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_PostscriptInfo psInfo,
+ Pixmap bitmap, int startX, int startY,
+ int width, int height)))
+#endif /* #ifndef Tk_PostscriptBitmap */
+
+#ifndef Tk_PostscriptColor
+VFUNC(int,Tk_PostscriptColor,V_Tk_PostscriptColor,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PostscriptInfo psInfo, XColor * colorPtr)))
+#endif /* #ifndef Tk_PostscriptColor */
+
+#ifndef Tk_PostscriptFont
+VFUNC(int,Tk_PostscriptFont,V_Tk_PostscriptFont,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PostscriptInfo psInfo, Tk_Font font)))
+#endif /* #ifndef Tk_PostscriptFont */
+
+#ifndef Tk_PostscriptFontName
+VFUNC(int,Tk_PostscriptFontName,V_Tk_PostscriptFontName,_ANSI_ARGS_((Tk_Font tkfont,
+ Tcl_DString * dsPtr)))
+#endif /* #ifndef Tk_PostscriptFontName */
+
+#ifndef Tk_PostscriptImage
+VFUNC(int,Tk_PostscriptImage,V_Tk_PostscriptImage,_ANSI_ARGS_((Tk_Image image,
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tk_PostscriptInfo psinfo, int x, int y,
+ int width, int height, int prepass)))
+#endif /* #ifndef Tk_PostscriptImage */
+
+#ifndef Tk_PostscriptPath
+VFUNC(void,Tk_PostscriptPath,V_Tk_PostscriptPath,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PostscriptInfo psInfo, double * coordPtr,
+ int numPoints)))
+#endif /* #ifndef Tk_PostscriptPath */
+
+#ifndef Tk_PostscriptPhoto
+VFUNC(int,Tk_PostscriptPhoto,V_Tk_PostscriptPhoto,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_PhotoImageBlock * blockPtr,
+ Tk_PostscriptInfo psInfo, int width,
+ int height)))
+#endif /* #ifndef Tk_PostscriptPhoto */
+
+#ifndef Tk_PostscriptStipple
+VFUNC(int,Tk_PostscriptStipple,V_Tk_PostscriptStipple,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Window tkwin,
+ Tk_PostscriptInfo psInfo, Pixmap bitmap)))
+#endif /* #ifndef Tk_PostscriptStipple */
+
+#ifndef Tk_PostscriptY
+VFUNC(double,Tk_PostscriptY,V_Tk_PostscriptY,_ANSI_ARGS_((double y,
+ Tk_PostscriptInfo psInfo)))
+#endif /* #ifndef Tk_PostscriptY */
+
+#ifndef Tk_PreserveColormap
+VFUNC(void,Tk_PreserveColormap,V_Tk_PreserveColormap,_ANSI_ARGS_((Display * display,
+ Colormap colormap)))
+#endif /* #ifndef Tk_PreserveColormap */
+
+#ifndef Tk_QueueWindowEvent
+VFUNC(void,Tk_QueueWindowEvent,V_Tk_QueueWindowEvent,_ANSI_ARGS_((XEvent * eventPtr,
+ Tcl_QueuePosition position)))
+#endif /* #ifndef Tk_QueueWindowEvent */
+
+#ifndef Tk_RedrawImage
+VFUNC(void,Tk_RedrawImage,V_Tk_RedrawImage,_ANSI_ARGS_((Tk_Image image,
+ int imageX, int imageY, int width,
+ int height, Drawable drawable, int drawableX,
+ int drawableY)))
+#endif /* #ifndef Tk_RedrawImage */
+
+#ifndef Tk_RegisterStyleEngine
+VFUNC(Tk_StyleEngine,Tk_RegisterStyleEngine,V_Tk_RegisterStyleEngine,_ANSI_ARGS_((
+ CONST char * name, Tk_StyleEngine parent)))
+#endif /* #ifndef Tk_RegisterStyleEngine */
+
+#ifndef Tk_RegisterStyledElement
+VFUNC(int,Tk_RegisterStyledElement,V_Tk_RegisterStyledElement,_ANSI_ARGS_((
+ Tk_StyleEngine engine,
+ Tk_ElementSpec * templatePtr)))
+#endif /* #ifndef Tk_RegisterStyledElement */
+
+#ifndef Tk_ResizeWindow
+VFUNC(void,Tk_ResizeWindow,V_Tk_ResizeWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ int width, int height)))
+#endif /* #ifndef Tk_ResizeWindow */
+
+#ifndef Tk_RestackWindow
+VFUNC(int,Tk_RestackWindow,V_Tk_RestackWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ int aboveBelow, Tk_Window other)))
+#endif /* #ifndef Tk_RestackWindow */
+
+#ifndef Tk_RestoreSavedOptions
+VFUNC(void,Tk_RestoreSavedOptions,V_Tk_RestoreSavedOptions,_ANSI_ARGS_((
+ Tk_SavedOptions * savePtr)))
+#endif /* #ifndef Tk_RestoreSavedOptions */
+
+#ifndef Tk_RestrictEvents
+VFUNC(Tk_RestrictProc *,Tk_RestrictEvents,V_Tk_RestrictEvents,_ANSI_ARGS_((
+ Tk_RestrictProc * proc, ClientData arg,
+ ClientData * prevArgPtr)))
+#endif /* #ifndef Tk_RestrictEvents */
+
+#ifndef Tk_SetAppName
+VFUNC(CONST char *,Tk_SetAppName,V_Tk_SetAppName,_ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name)))
+#endif /* #ifndef Tk_SetAppName */
+
+#ifndef Tk_SetBackgroundFromBorder
+VFUNC(void,Tk_SetBackgroundFromBorder,V_Tk_SetBackgroundFromBorder,_ANSI_ARGS_((
+ Tk_Window tkwin, Tk_3DBorder border)))
+#endif /* #ifndef Tk_SetBackgroundFromBorder */
+
+#ifndef Tk_SetCaretPos
+VFUNC(void,Tk_SetCaretPos,V_Tk_SetCaretPos,_ANSI_ARGS_((Tk_Window tkwin, int x,
+ int y, int height)))
+#endif /* #ifndef Tk_SetCaretPos */
+
+#ifndef Tk_SetClass
+VFUNC(void,Tk_SetClass,V_Tk_SetClass,_ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * className)))
+#endif /* #ifndef Tk_SetClass */
+
+#ifndef Tk_SetClassProcs
+VFUNC(void,Tk_SetClassProcs,V_Tk_SetClassProcs,_ANSI_ARGS_((Tk_Window tkwin,
+ Tk_ClassProcs * procs,
+ ClientData instanceData)))
+#endif /* #ifndef Tk_SetClassProcs */
+
+#ifndef Tk_SetGrid
+VFUNC(void,Tk_SetGrid,V_Tk_SetGrid,_ANSI_ARGS_((Tk_Window tkwin,
+ int reqWidth, int reqHeight, int gridWidth,
+ int gridHeight)))
+#endif /* #ifndef Tk_SetGrid */
+
+#ifndef Tk_SetInternalBorder
+VFUNC(void,Tk_SetInternalBorder,V_Tk_SetInternalBorder,_ANSI_ARGS_((Tk_Window tkwin,
+ int width)))
+#endif /* #ifndef Tk_SetInternalBorder */
+
+#ifndef Tk_SetInternalBorderEx
+VFUNC(void,Tk_SetInternalBorderEx,V_Tk_SetInternalBorderEx,_ANSI_ARGS_((Tk_Window tkwin,
+ int left, int right, int top, int bottom)))
+#endif /* #ifndef Tk_SetInternalBorderEx */
+
+#ifndef Tk_SetMinimumRequestSize
+VFUNC(void,Tk_SetMinimumRequestSize,V_Tk_SetMinimumRequestSize,_ANSI_ARGS_((
+ Tk_Window tkwin, int minWidth, int minHeight)))
+#endif /* #ifndef Tk_SetMinimumRequestSize */
+
+#ifndef Tk_SetOptions
+VFUNC(int,Tk_SetOptions,V_Tk_SetOptions,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * recordPtr, Tk_OptionTable optionTable,
+ int objc, Tcl_Obj *CONST objv[],
+ Tk_Window tkwin, Tk_SavedOptions * savePtr,
+ int * maskPtr)))
+#endif /* #ifndef Tk_SetOptions */
+
+#ifndef Tk_SetTSOrigin
+VFUNC(void,Tk_SetTSOrigin,V_Tk_SetTSOrigin,_ANSI_ARGS_((Tk_Window tkwin, GC gc,
+ int x, int y)))
+#endif /* #ifndef Tk_SetTSOrigin */
+
+#ifndef Tk_SetWindowBackground
+VFUNC(void,Tk_SetWindowBackground,V_Tk_SetWindowBackground,_ANSI_ARGS_((Tk_Window tkwin,
+ unsigned long pixel)))
+#endif /* #ifndef Tk_SetWindowBackground */
+
+#ifndef Tk_SetWindowBackgroundPixmap
+VFUNC(void,Tk_SetWindowBackgroundPixmap,V_Tk_SetWindowBackgroundPixmap,_ANSI_ARGS_((
+ Tk_Window tkwin, Pixmap pixmap)))
+#endif /* #ifndef Tk_SetWindowBackgroundPixmap */
+
+#ifndef Tk_SetWindowBorder
+VFUNC(void,Tk_SetWindowBorder,V_Tk_SetWindowBorder,_ANSI_ARGS_((Tk_Window tkwin,
+ unsigned long pixel)))
+#endif /* #ifndef Tk_SetWindowBorder */
+
+#ifndef Tk_SetWindowBorderPixmap
+VFUNC(void,Tk_SetWindowBorderPixmap,V_Tk_SetWindowBorderPixmap,_ANSI_ARGS_((
+ Tk_Window tkwin, Pixmap pixmap)))
+#endif /* #ifndef Tk_SetWindowBorderPixmap */
+
+#ifndef Tk_SetWindowBorderWidth
+VFUNC(void,Tk_SetWindowBorderWidth,V_Tk_SetWindowBorderWidth,_ANSI_ARGS_((Tk_Window tkwin,
+ int width)))
+#endif /* #ifndef Tk_SetWindowBorderWidth */
+
+#ifndef Tk_SetWindowColormap
+VFUNC(void,Tk_SetWindowColormap,V_Tk_SetWindowColormap,_ANSI_ARGS_((Tk_Window tkwin,
+ Colormap colormap)))
+#endif /* #ifndef Tk_SetWindowColormap */
+
+#ifndef Tk_SetWindowVisual
+VFUNC(int,Tk_SetWindowVisual,V_Tk_SetWindowVisual,_ANSI_ARGS_((Tk_Window tkwin,
+ Visual * visual, int depth,
+ Colormap colormap)))
+#endif /* #ifndef Tk_SetWindowVisual */
+
+#ifndef Tk_SizeOfBitmap
+VFUNC(void,Tk_SizeOfBitmap,V_Tk_SizeOfBitmap,_ANSI_ARGS_((Display * display,
+ Pixmap bitmap, int * widthPtr,
+ int * heightPtr)))
+#endif /* #ifndef Tk_SizeOfBitmap */
+
+#ifndef Tk_SizeOfImage
+VFUNC(void,Tk_SizeOfImage,V_Tk_SizeOfImage,_ANSI_ARGS_((Tk_Image image,
+ int * widthPtr, int * heightPtr)))
+#endif /* #ifndef Tk_SizeOfImage */
+
+#ifndef Tk_StrictMotif
+VFUNC(int,Tk_StrictMotif,V_Tk_StrictMotif,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_StrictMotif */
+
+#ifndef Tk_TextLayoutToPostscript
+VFUNC(void,Tk_TextLayoutToPostscript,V_Tk_TextLayoutToPostscript,_ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_TextLayout layout)))
+#endif /* #ifndef Tk_TextLayoutToPostscript */
+
+#ifndef Tk_TextWidth
+VFUNC(int,Tk_TextWidth,V_Tk_TextWidth,_ANSI_ARGS_((Tk_Font font,
+ CONST char * str, int numBytes)))
+#endif /* #ifndef Tk_TextWidth */
+
+#ifndef Tk_UndefineCursor
+VFUNC(void,Tk_UndefineCursor,V_Tk_UndefineCursor,_ANSI_ARGS_((Tk_Window window)))
+#endif /* #ifndef Tk_UndefineCursor */
+
+#ifndef Tk_UnderlineChars
+VFUNC(void,Tk_UnderlineChars,V_Tk_UnderlineChars,_ANSI_ARGS_((Display * display,
+ Drawable drawable, GC gc, Tk_Font tkfont,
+ CONST char * source, int x, int y,
+ int firstByte, int lastByte)))
+#endif /* #ifndef Tk_UnderlineChars */
+
+#ifndef Tk_UnderlineTextLayout
+VFUNC(void,Tk_UnderlineTextLayout,V_Tk_UnderlineTextLayout,_ANSI_ARGS_((
+ Display * display, Drawable drawable, GC gc,
+ Tk_TextLayout layout, int x, int y,
+ int underline)))
+#endif /* #ifndef Tk_UnderlineTextLayout */
+
+#ifndef Tk_Ungrab
+VFUNC(void,Tk_Ungrab,V_Tk_Ungrab,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_Ungrab */
+
+#ifndef Tk_UnmaintainGeometry
+VFUNC(void,Tk_UnmaintainGeometry,V_Tk_UnmaintainGeometry,_ANSI_ARGS_((Tk_Window slave,
+ Tk_Window master)))
+#endif /* #ifndef Tk_UnmaintainGeometry */
+
+#ifndef Tk_UnmapWindow
+VFUNC(void,Tk_UnmapWindow,V_Tk_UnmapWindow,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_UnmapWindow */
+
+#ifndef Tk_UnsetGrid
+VFUNC(void,Tk_UnsetGrid,V_Tk_UnsetGrid,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef Tk_UnsetGrid */
+
+#ifndef Tk_UpdatePointer
+VFUNC(void,Tk_UpdatePointer,V_Tk_UpdatePointer,_ANSI_ARGS_((Tk_Window tkwin, int x,
+ int y, int state)))
+#endif /* #ifndef Tk_UpdatePointer */
+
+#endif /* _TKDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls_f.h
new file mode 100755
index 00000000000..262cacb519d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkDecls_f.h
@@ -0,0 +1,14 @@
+#ifndef TKDECLS_VT
+#define TKDECLS_VT
+typedef struct TkdeclsVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkDecls.t"
+#undef VFUNC
+#undef VVAR
+} TkdeclsVtab;
+extern TkdeclsVtab *TkdeclsVptr;
+extern TkdeclsVtab *TkdeclsVGet(void);
+#endif /* TKDECLS_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.h
new file mode 100755
index 00000000000..9787af4425e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.h
@@ -0,0 +1,122 @@
+#ifndef _TKEVENT
+#define _TKEVENT
+
+#define LangCallbackArg(x) LangOldCallbackArg(x,__FILE__,__LINE__)
+
+EXTERN int LangCallCallback _ANSI_ARGS_((LangCallback *cb, int flags));
+EXTERN Tcl_Obj * LangCallbackObj _ANSI_ARGS_((LangCallback *));
+EXTERN int LangCmpCallback _ANSI_ARGS_((LangCallback *a,Tcl_Obj * b));
+EXTERN LangCallback * LangCopyCallback _ANSI_ARGS_((LangCallback *));
+EXTERN void LangDebug _ANSI_ARGS_((CONST char *fmt,...));
+EXTERN void LangAsyncCheck _ANSI_ARGS_((void));
+EXTERN void LangFreeCallback _ANSI_ARGS_((LangCallback *));
+EXTERN LangCallback * LangMakeCallback _ANSI_ARGS_((Tcl_Obj *));
+EXTERN Tcl_Obj * LangOldCallbackArg _ANSI_ARGS_((LangCallback *,char *,int));
+EXTERN void LangPushCallbackArgs _ANSI_ARGS_((LangCallback **svp));
+EXTERN long Lang_OSHandle _ANSI_ARGS_((int fd));
+EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
+EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size));
+EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc,
+ ClientData clientData));
+EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async));
+EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp * interp,
+ int code));
+EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
+EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void));
+EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc,
+ ClientData clientData));
+EXTERN void Tcl_CreateEventSource _ANSI_ARGS_((
+ Tcl_EventSetupProc *setupProc,
+ Tcl_EventCheckProc *checkProc,
+ ClientData clientData));
+EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((
+ int fd, int mask, Tcl_FileProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_CreateThreadExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds,
+ Tcl_TimerProc *proc, ClientData clientData));
+EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size,CONST char *file,int line));
+EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char * ptr, CONST char * file,
+ int line));
+EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr,
+ unsigned int size, CONST char *file,int line));
+EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_((
+ Tcl_EventSetupProc *setupProc,
+ Tcl_EventCheckProc *checkProc,
+ ClientData clientData));
+EXTERN void Tcl_DeleteEvents _ANSI_ARGS_((
+ Tcl_EventDeleteProc * proc,
+ ClientData clientData));
+EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd));
+EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_((
+ Tcl_TimerToken token));
+EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags));
+EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc,
+ ClientData clientData));
+EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((CONST char * fileName));
+EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
+EXTERN void Tcl_Finalize _ANSI_ARGS_((void));
+EXTERN void Tcl_FinalizeNotifier _ANSI_ARGS_((
+ ClientData clientData));
+EXTERN void Tcl_FinalizeThread _ANSI_ARGS_((void));
+EXTERN void Tcl_Free _ANSI_ARGS_((char *ptr));
+EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void));
+EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void));
+EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_((
+ Tcl_ThreadDataKey * keyPtr, int size));
+EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void));
+EXTERN void Tcl_Panic _ANSI_ARGS_((CONST char *,...));
+EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr,
+ Tcl_QueuePosition position));
+EXTERN void Tcl_QueueProcEvent _ANSI_ARGS_((Tcl_EventProc *proc,
+ Tcl_Event *evPtr,
+ Tcl_QueuePosition position));
+EXTERN char * Tcl_Realloc _ANSI_ARGS_((char *ptr,
+ unsigned int size));
+EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void));
+EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags));
+EXTERN void Tcl_ServiceModeHook _ANSI_ARGS_((int mode));
+EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr));
+EXTERN void Tcl_SetNotifier _ANSI_ARGS_((
+ Tcl_NotifierProcs * notifierProcPtr));
+EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode));
+EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time * timePtr));
+EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms));
+EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId));
+EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_((
+ Tcl_ThreadId threadId, Tcl_Event* evPtr,
+ Tcl_QueuePosition position));
+EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((CONST char * file,
+ int line));
+EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time * timePtr));
+EXTERN void TclpAsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
+EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time *time));
+EXTERN void * TkInitTimer _ANSI_ARGS_((void));
+EXTERN void Lang_NoteOwner _ANSI_ARGS_((void *owner,void *packet,
+ CONST char *file, int line));
+EXTERN char * Tcl_AttemptDbCkalloc _ANSI_ARGS_((unsigned int size,
+ CONST char * file, int line));
+EXTERN void TclpExit _ANSI_ARGS_((int status));
+
+#ifdef TCL_MEM_DEBUG
+#define LangNoteOwner(owner,packet) Lang_NoteOwner(owner,packet,__FILE__,__LINE__)
+#else
+#define LangNoteOwner(owner,packet)
+#endif
+
+#ifndef TCL_TSD_INIT
+#define TCL_TSD_INIT(keyPtr) (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
+#endif
+
+
+#endif /* _TKEVENT */
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.m
new file mode 100755
index 00000000000..75219487d2f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.m
@@ -0,0 +1,274 @@
+#ifndef _TKEVENT_VM
+#define _TKEVENT_VM
+#include "tkEvent_f.h"
+#ifndef NO_VTABLES
+#ifndef LangAsyncCheck
+# define LangAsyncCheck (*TkeventVptr->V_LangAsyncCheck)
+#endif
+
+#ifndef LangCallCallback
+# define LangCallCallback (*TkeventVptr->V_LangCallCallback)
+#endif
+
+#ifndef LangCallbackObj
+# define LangCallbackObj (*TkeventVptr->V_LangCallbackObj)
+#endif
+
+#ifndef LangCmpCallback
+# define LangCmpCallback (*TkeventVptr->V_LangCmpCallback)
+#endif
+
+#ifndef LangCopyCallback
+# define LangCopyCallback (*TkeventVptr->V_LangCopyCallback)
+#endif
+
+#ifndef LangDebug
+# define LangDebug (*TkeventVptr->V_LangDebug)
+#endif
+
+#ifndef LangFreeCallback
+# define LangFreeCallback (*TkeventVptr->V_LangFreeCallback)
+#endif
+
+#ifndef LangMakeCallback
+# define LangMakeCallback (*TkeventVptr->V_LangMakeCallback)
+#endif
+
+#ifndef LangOldCallbackArg
+# define LangOldCallbackArg (*TkeventVptr->V_LangOldCallbackArg)
+#endif
+
+#ifndef LangPushCallbackArgs
+# define LangPushCallbackArgs (*TkeventVptr->V_LangPushCallbackArgs)
+#endif
+
+#ifndef Lang_NoteOwner
+# define Lang_NoteOwner (*TkeventVptr->V_Lang_NoteOwner)
+#endif
+
+#ifndef Lang_OSHandle
+# define Lang_OSHandle (*TkeventVptr->V_Lang_OSHandle)
+#endif
+
+#ifndef Tcl_AlertNotifier
+# define Tcl_AlertNotifier (*TkeventVptr->V_Tcl_AlertNotifier)
+#endif
+
+#ifndef Tcl_Alloc
+# define Tcl_Alloc (*TkeventVptr->V_Tcl_Alloc)
+#endif
+
+#ifndef Tcl_AsyncCreate
+# define Tcl_AsyncCreate (*TkeventVptr->V_Tcl_AsyncCreate)
+#endif
+
+#ifndef Tcl_AsyncDelete
+# define Tcl_AsyncDelete (*TkeventVptr->V_Tcl_AsyncDelete)
+#endif
+
+#ifndef Tcl_AsyncInvoke
+# define Tcl_AsyncInvoke (*TkeventVptr->V_Tcl_AsyncInvoke)
+#endif
+
+#ifndef Tcl_AsyncMark
+# define Tcl_AsyncMark (*TkeventVptr->V_Tcl_AsyncMark)
+#endif
+
+#ifndef Tcl_AsyncReady
+# define Tcl_AsyncReady (*TkeventVptr->V_Tcl_AsyncReady)
+#endif
+
+#ifndef Tcl_AttemptDbCkalloc
+# define Tcl_AttemptDbCkalloc (*TkeventVptr->V_Tcl_AttemptDbCkalloc)
+#endif
+
+#ifndef Tcl_CancelIdleCall
+# define Tcl_CancelIdleCall (*TkeventVptr->V_Tcl_CancelIdleCall)
+#endif
+
+#ifndef Tcl_CreateEventSource
+# define Tcl_CreateEventSource (*TkeventVptr->V_Tcl_CreateEventSource)
+#endif
+
+#ifndef Tcl_CreateExitHandler
+# define Tcl_CreateExitHandler (*TkeventVptr->V_Tcl_CreateExitHandler)
+#endif
+
+#ifndef Tcl_CreateFileHandler
+# define Tcl_CreateFileHandler (*TkeventVptr->V_Tcl_CreateFileHandler)
+#endif
+
+#ifndef Tcl_CreateThreadExitHandler
+# define Tcl_CreateThreadExitHandler (*TkeventVptr->V_Tcl_CreateThreadExitHandler)
+#endif
+
+#ifndef Tcl_CreateTimerHandler
+# define Tcl_CreateTimerHandler (*TkeventVptr->V_Tcl_CreateTimerHandler)
+#endif
+
+#ifndef Tcl_DbCkalloc
+# define Tcl_DbCkalloc (*TkeventVptr->V_Tcl_DbCkalloc)
+#endif
+
+#ifndef Tcl_DbCkfree
+# define Tcl_DbCkfree (*TkeventVptr->V_Tcl_DbCkfree)
+#endif
+
+#ifndef Tcl_DbCkrealloc
+# define Tcl_DbCkrealloc (*TkeventVptr->V_Tcl_DbCkrealloc)
+#endif
+
+#ifndef Tcl_DeleteEventSource
+# define Tcl_DeleteEventSource (*TkeventVptr->V_Tcl_DeleteEventSource)
+#endif
+
+#ifndef Tcl_DeleteEvents
+# define Tcl_DeleteEvents (*TkeventVptr->V_Tcl_DeleteEvents)
+#endif
+
+#ifndef Tcl_DeleteExitHandler
+# define Tcl_DeleteExitHandler (*TkeventVptr->V_Tcl_DeleteExitHandler)
+#endif
+
+#ifndef Tcl_DeleteFileHandler
+# define Tcl_DeleteFileHandler (*TkeventVptr->V_Tcl_DeleteFileHandler)
+#endif
+
+#ifndef Tcl_DeleteThreadExitHandler
+# define Tcl_DeleteThreadExitHandler (*TkeventVptr->V_Tcl_DeleteThreadExitHandler)
+#endif
+
+#ifndef Tcl_DeleteTimerHandler
+# define Tcl_DeleteTimerHandler (*TkeventVptr->V_Tcl_DeleteTimerHandler)
+#endif
+
+#ifndef Tcl_DoOneEvent
+# define Tcl_DoOneEvent (*TkeventVptr->V_Tcl_DoOneEvent)
+#endif
+
+#ifndef Tcl_DoWhenIdle
+# define Tcl_DoWhenIdle (*TkeventVptr->V_Tcl_DoWhenIdle)
+#endif
+
+#ifndef Tcl_DumpActiveMemory
+# define Tcl_DumpActiveMemory (*TkeventVptr->V_Tcl_DumpActiveMemory)
+#endif
+
+#ifndef Tcl_Exit
+# define Tcl_Exit (*TkeventVptr->V_Tcl_Exit)
+#endif
+
+#ifndef Tcl_Finalize
+# define Tcl_Finalize (*TkeventVptr->V_Tcl_Finalize)
+#endif
+
+#ifndef Tcl_FinalizeNotifier
+# define Tcl_FinalizeNotifier (*TkeventVptr->V_Tcl_FinalizeNotifier)
+#endif
+
+#ifndef Tcl_FinalizeThread
+# define Tcl_FinalizeThread (*TkeventVptr->V_Tcl_FinalizeThread)
+#endif
+
+#ifndef Tcl_Free
+# define Tcl_Free (*TkeventVptr->V_Tcl_Free)
+#endif
+
+#ifndef Tcl_GetCurrentThread
+# define Tcl_GetCurrentThread (*TkeventVptr->V_Tcl_GetCurrentThread)
+#endif
+
+#ifndef Tcl_GetServiceMode
+# define Tcl_GetServiceMode (*TkeventVptr->V_Tcl_GetServiceMode)
+#endif
+
+#ifndef Tcl_GetThreadData
+# define Tcl_GetThreadData (*TkeventVptr->V_Tcl_GetThreadData)
+#endif
+
+#ifndef Tcl_GetTime
+# define Tcl_GetTime (*TkeventVptr->V_Tcl_GetTime)
+#endif
+
+#ifndef Tcl_InitNotifier
+# define Tcl_InitNotifier (*TkeventVptr->V_Tcl_InitNotifier)
+#endif
+
+#ifndef Tcl_Panic
+# define Tcl_Panic (*TkeventVptr->V_Tcl_Panic)
+#endif
+
+#ifndef Tcl_QueueEvent
+# define Tcl_QueueEvent (*TkeventVptr->V_Tcl_QueueEvent)
+#endif
+
+#ifndef Tcl_QueueProcEvent
+# define Tcl_QueueProcEvent (*TkeventVptr->V_Tcl_QueueProcEvent)
+#endif
+
+#ifndef Tcl_Realloc
+# define Tcl_Realloc (*TkeventVptr->V_Tcl_Realloc)
+#endif
+
+#ifndef Tcl_ServiceAll
+# define Tcl_ServiceAll (*TkeventVptr->V_Tcl_ServiceAll)
+#endif
+
+#ifndef Tcl_ServiceEvent
+# define Tcl_ServiceEvent (*TkeventVptr->V_Tcl_ServiceEvent)
+#endif
+
+#ifndef Tcl_ServiceModeHook
+# define Tcl_ServiceModeHook (*TkeventVptr->V_Tcl_ServiceModeHook)
+#endif
+
+#ifndef Tcl_SetMaxBlockTime
+# define Tcl_SetMaxBlockTime (*TkeventVptr->V_Tcl_SetMaxBlockTime)
+#endif
+
+#ifndef Tcl_SetNotifier
+# define Tcl_SetNotifier (*TkeventVptr->V_Tcl_SetNotifier)
+#endif
+
+#ifndef Tcl_SetServiceMode
+# define Tcl_SetServiceMode (*TkeventVptr->V_Tcl_SetServiceMode)
+#endif
+
+#ifndef Tcl_SetTimer
+# define Tcl_SetTimer (*TkeventVptr->V_Tcl_SetTimer)
+#endif
+
+#ifndef Tcl_Sleep
+# define Tcl_Sleep (*TkeventVptr->V_Tcl_Sleep)
+#endif
+
+#ifndef Tcl_ThreadAlert
+# define Tcl_ThreadAlert (*TkeventVptr->V_Tcl_ThreadAlert)
+#endif
+
+#ifndef Tcl_ThreadQueueEvent
+# define Tcl_ThreadQueueEvent (*TkeventVptr->V_Tcl_ThreadQueueEvent)
+#endif
+
+#ifndef Tcl_ValidateAllMemory
+# define Tcl_ValidateAllMemory (*TkeventVptr->V_Tcl_ValidateAllMemory)
+#endif
+
+#ifndef Tcl_WaitForEvent
+# define Tcl_WaitForEvent (*TkeventVptr->V_Tcl_WaitForEvent)
+#endif
+
+#ifndef TclpAsyncMark
+# define TclpAsyncMark (*TkeventVptr->V_TclpAsyncMark)
+#endif
+
+#ifndef TclpExit
+# define TclpExit (*TkeventVptr->V_TclpExit)
+#endif
+
+#ifndef TkInitTimer
+# define TkInitTimer (*TkeventVptr->V_TkInitTimer)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKEVENT_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.t
new file mode 100755
index 00000000000..c09210729f5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent.t
@@ -0,0 +1,304 @@
+#ifdef _TKEVENT
+#ifndef LangAsyncCheck
+VFUNC(void,LangAsyncCheck,V_LangAsyncCheck,_ANSI_ARGS_((void)))
+#endif /* #ifndef LangAsyncCheck */
+
+#ifndef LangCallCallback
+VFUNC(int,LangCallCallback,V_LangCallCallback,_ANSI_ARGS_((LangCallback *cb, int flags)))
+#endif /* #ifndef LangCallCallback */
+
+#ifndef LangCallbackObj
+VFUNC(Tcl_Obj *,LangCallbackObj,V_LangCallbackObj,_ANSI_ARGS_((LangCallback *)))
+#endif /* #ifndef LangCallbackObj */
+
+#ifndef LangCmpCallback
+VFUNC(int,LangCmpCallback,V_LangCmpCallback,_ANSI_ARGS_((LangCallback *a,Tcl_Obj * b)))
+#endif /* #ifndef LangCmpCallback */
+
+#ifndef LangCopyCallback
+VFUNC(LangCallback *,LangCopyCallback,V_LangCopyCallback,_ANSI_ARGS_((LangCallback *)))
+#endif /* #ifndef LangCopyCallback */
+
+#ifndef LangDebug
+VFUNC(void,LangDebug,V_LangDebug,_ANSI_ARGS_((CONST char *fmt,...)))
+#endif /* #ifndef LangDebug */
+
+#ifndef LangFreeCallback
+VFUNC(void,LangFreeCallback,V_LangFreeCallback,_ANSI_ARGS_((LangCallback *)))
+#endif /* #ifndef LangFreeCallback */
+
+#ifndef LangMakeCallback
+VFUNC(LangCallback *,LangMakeCallback,V_LangMakeCallback,_ANSI_ARGS_((Tcl_Obj *)))
+#endif /* #ifndef LangMakeCallback */
+
+#ifndef LangOldCallbackArg
+VFUNC(Tcl_Obj *,LangOldCallbackArg,V_LangOldCallbackArg,_ANSI_ARGS_((LangCallback *,char *,int)))
+#endif /* #ifndef LangOldCallbackArg */
+
+#ifndef LangPushCallbackArgs
+VFUNC(void,LangPushCallbackArgs,V_LangPushCallbackArgs,_ANSI_ARGS_((LangCallback **svp)))
+#endif /* #ifndef LangPushCallbackArgs */
+
+#ifndef Lang_NoteOwner
+VFUNC(void,Lang_NoteOwner,V_Lang_NoteOwner,_ANSI_ARGS_((void *owner,void *packet,
+ CONST char *file, int line)))
+#endif /* #ifndef Lang_NoteOwner */
+
+#ifndef Lang_OSHandle
+VFUNC(long,Lang_OSHandle,V_Lang_OSHandle,_ANSI_ARGS_((int fd)))
+#endif /* #ifndef Lang_OSHandle */
+
+#ifndef Tcl_AlertNotifier
+VFUNC(void,Tcl_AlertNotifier,V_Tcl_AlertNotifier,_ANSI_ARGS_((ClientData clientData)))
+#endif /* #ifndef Tcl_AlertNotifier */
+
+#ifndef Tcl_Alloc
+VFUNC(char *,Tcl_Alloc,V_Tcl_Alloc,_ANSI_ARGS_((unsigned int size)))
+#endif /* #ifndef Tcl_Alloc */
+
+#ifndef Tcl_AsyncCreate
+VFUNC(Tcl_AsyncHandler,Tcl_AsyncCreate,V_Tcl_AsyncCreate,_ANSI_ARGS_((Tcl_AsyncProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_AsyncCreate */
+
+#ifndef Tcl_AsyncDelete
+VFUNC(void,Tcl_AsyncDelete,V_Tcl_AsyncDelete,_ANSI_ARGS_((Tcl_AsyncHandler async)))
+#endif /* #ifndef Tcl_AsyncDelete */
+
+#ifndef Tcl_AsyncInvoke
+VFUNC(int,Tcl_AsyncInvoke,V_Tcl_AsyncInvoke,_ANSI_ARGS_((Tcl_Interp * interp,
+ int code)))
+#endif /* #ifndef Tcl_AsyncInvoke */
+
+#ifndef Tcl_AsyncMark
+VFUNC(void,Tcl_AsyncMark,V_Tcl_AsyncMark,_ANSI_ARGS_((Tcl_AsyncHandler async)))
+#endif /* #ifndef Tcl_AsyncMark */
+
+#ifndef Tcl_AsyncReady
+VFUNC(int,Tcl_AsyncReady,V_Tcl_AsyncReady,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_AsyncReady */
+
+#ifndef Tcl_AttemptDbCkalloc
+VFUNC(char *,Tcl_AttemptDbCkalloc,V_Tcl_AttemptDbCkalloc,_ANSI_ARGS_((unsigned int size,
+ CONST char * file, int line)))
+#endif /* #ifndef Tcl_AttemptDbCkalloc */
+
+#ifndef Tcl_CancelIdleCall
+VFUNC(void,Tcl_CancelIdleCall,V_Tcl_CancelIdleCall,_ANSI_ARGS_((Tcl_IdleProc *idleProc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_CancelIdleCall */
+
+#ifndef Tcl_CreateEventSource
+VFUNC(void,Tcl_CreateEventSource,V_Tcl_CreateEventSource,_ANSI_ARGS_((
+ Tcl_EventSetupProc *setupProc,
+ Tcl_EventCheckProc *checkProc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_CreateEventSource */
+
+#ifndef Tcl_CreateExitHandler
+VFUNC(void,Tcl_CreateExitHandler,V_Tcl_CreateExitHandler,_ANSI_ARGS_((Tcl_ExitProc *proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_CreateExitHandler */
+
+#ifndef Tcl_CreateFileHandler
+VFUNC(void,Tcl_CreateFileHandler,V_Tcl_CreateFileHandler,_ANSI_ARGS_((
+ int fd, int mask, Tcl_FileProc *proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_CreateFileHandler */
+
+#ifndef Tcl_CreateThreadExitHandler
+VFUNC(void,Tcl_CreateThreadExitHandler,V_Tcl_CreateThreadExitHandler,_ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData)))
+#endif /* #ifndef Tcl_CreateThreadExitHandler */
+
+#ifndef Tcl_CreateTimerHandler
+VFUNC(Tcl_TimerToken,Tcl_CreateTimerHandler,V_Tcl_CreateTimerHandler,_ANSI_ARGS_((int milliseconds,
+ Tcl_TimerProc *proc, ClientData clientData)))
+#endif /* #ifndef Tcl_CreateTimerHandler */
+
+#ifndef Tcl_DbCkalloc
+VFUNC(char *,Tcl_DbCkalloc,V_Tcl_DbCkalloc,_ANSI_ARGS_((unsigned int size,CONST char *file,int line)))
+#endif /* #ifndef Tcl_DbCkalloc */
+
+#ifndef Tcl_DbCkfree
+VFUNC(int,Tcl_DbCkfree,V_Tcl_DbCkfree,_ANSI_ARGS_((char * ptr, CONST char * file,
+ int line)))
+#endif /* #ifndef Tcl_DbCkfree */
+
+#ifndef Tcl_DbCkrealloc
+VFUNC(char *,Tcl_DbCkrealloc,V_Tcl_DbCkrealloc,_ANSI_ARGS_((char *ptr,
+ unsigned int size, CONST char *file,int line)))
+#endif /* #ifndef Tcl_DbCkrealloc */
+
+#ifndef Tcl_DeleteEventSource
+VFUNC(void,Tcl_DeleteEventSource,V_Tcl_DeleteEventSource,_ANSI_ARGS_((
+ Tcl_EventSetupProc *setupProc,
+ Tcl_EventCheckProc *checkProc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_DeleteEventSource */
+
+#ifndef Tcl_DeleteEvents
+VFUNC(void,Tcl_DeleteEvents,V_Tcl_DeleteEvents,_ANSI_ARGS_((
+ Tcl_EventDeleteProc * proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_DeleteEvents */
+
+#ifndef Tcl_DeleteExitHandler
+VFUNC(void,Tcl_DeleteExitHandler,V_Tcl_DeleteExitHandler,_ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData)))
+#endif /* #ifndef Tcl_DeleteExitHandler */
+
+#ifndef Tcl_DeleteFileHandler
+VFUNC(void,Tcl_DeleteFileHandler,V_Tcl_DeleteFileHandler,_ANSI_ARGS_((int fd)))
+#endif /* #ifndef Tcl_DeleteFileHandler */
+
+#ifndef Tcl_DeleteThreadExitHandler
+VFUNC(void,Tcl_DeleteThreadExitHandler,V_Tcl_DeleteThreadExitHandler,_ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData)))
+#endif /* #ifndef Tcl_DeleteThreadExitHandler */
+
+#ifndef Tcl_DeleteTimerHandler
+VFUNC(void,Tcl_DeleteTimerHandler,V_Tcl_DeleteTimerHandler,_ANSI_ARGS_((
+ Tcl_TimerToken token)))
+#endif /* #ifndef Tcl_DeleteTimerHandler */
+
+#ifndef Tcl_DoOneEvent
+VFUNC(int,Tcl_DoOneEvent,V_Tcl_DoOneEvent,_ANSI_ARGS_((int flags)))
+#endif /* #ifndef Tcl_DoOneEvent */
+
+#ifndef Tcl_DoWhenIdle
+VFUNC(void,Tcl_DoWhenIdle,V_Tcl_DoWhenIdle,_ANSI_ARGS_((Tcl_IdleProc *proc,
+ ClientData clientData)))
+#endif /* #ifndef Tcl_DoWhenIdle */
+
+#ifndef Tcl_DumpActiveMemory
+VFUNC(int,Tcl_DumpActiveMemory,V_Tcl_DumpActiveMemory,_ANSI_ARGS_((CONST char * fileName)))
+#endif /* #ifndef Tcl_DumpActiveMemory */
+
+#ifndef Tcl_Exit
+VFUNC(void,Tcl_Exit,V_Tcl_Exit,_ANSI_ARGS_((int status)))
+#endif /* #ifndef Tcl_Exit */
+
+#ifndef Tcl_Finalize
+VFUNC(void,Tcl_Finalize,V_Tcl_Finalize,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_Finalize */
+
+#ifndef Tcl_FinalizeNotifier
+VFUNC(void,Tcl_FinalizeNotifier,V_Tcl_FinalizeNotifier,_ANSI_ARGS_((
+ ClientData clientData)))
+#endif /* #ifndef Tcl_FinalizeNotifier */
+
+#ifndef Tcl_FinalizeThread
+VFUNC(void,Tcl_FinalizeThread,V_Tcl_FinalizeThread,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_FinalizeThread */
+
+#ifndef Tcl_Free
+VFUNC(void,Tcl_Free,V_Tcl_Free,_ANSI_ARGS_((char *ptr)))
+#endif /* #ifndef Tcl_Free */
+
+#ifndef Tcl_GetCurrentThread
+VFUNC(Tcl_ThreadId,Tcl_GetCurrentThread,V_Tcl_GetCurrentThread,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_GetCurrentThread */
+
+#ifndef Tcl_GetServiceMode
+VFUNC(int,Tcl_GetServiceMode,V_Tcl_GetServiceMode,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_GetServiceMode */
+
+#ifndef Tcl_GetThreadData
+VFUNC(VOID *,Tcl_GetThreadData,V_Tcl_GetThreadData,_ANSI_ARGS_((
+ Tcl_ThreadDataKey * keyPtr, int size)))
+#endif /* #ifndef Tcl_GetThreadData */
+
+#ifndef Tcl_GetTime
+VFUNC(void,Tcl_GetTime,V_Tcl_GetTime,_ANSI_ARGS_((Tcl_Time *time)))
+#endif /* #ifndef Tcl_GetTime */
+
+#ifndef Tcl_InitNotifier
+VFUNC(ClientData,Tcl_InitNotifier,V_Tcl_InitNotifier,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_InitNotifier */
+
+#ifndef Tcl_Panic
+VFUNC(void,Tcl_Panic,V_Tcl_Panic,_ANSI_ARGS_((CONST char *,...)))
+#endif /* #ifndef Tcl_Panic */
+
+#ifndef Tcl_QueueEvent
+VFUNC(void,Tcl_QueueEvent,V_Tcl_QueueEvent,_ANSI_ARGS_((Tcl_Event *evPtr,
+ Tcl_QueuePosition position)))
+#endif /* #ifndef Tcl_QueueEvent */
+
+#ifndef Tcl_QueueProcEvent
+VFUNC(void,Tcl_QueueProcEvent,V_Tcl_QueueProcEvent,_ANSI_ARGS_((Tcl_EventProc *proc,
+ Tcl_Event *evPtr,
+ Tcl_QueuePosition position)))
+#endif /* #ifndef Tcl_QueueProcEvent */
+
+#ifndef Tcl_Realloc
+VFUNC(char *,Tcl_Realloc,V_Tcl_Realloc,_ANSI_ARGS_((char *ptr,
+ unsigned int size)))
+#endif /* #ifndef Tcl_Realloc */
+
+#ifndef Tcl_ServiceAll
+VFUNC(int,Tcl_ServiceAll,V_Tcl_ServiceAll,_ANSI_ARGS_((void)))
+#endif /* #ifndef Tcl_ServiceAll */
+
+#ifndef Tcl_ServiceEvent
+VFUNC(int,Tcl_ServiceEvent,V_Tcl_ServiceEvent,_ANSI_ARGS_((int flags)))
+#endif /* #ifndef Tcl_ServiceEvent */
+
+#ifndef Tcl_ServiceModeHook
+VFUNC(void,Tcl_ServiceModeHook,V_Tcl_ServiceModeHook,_ANSI_ARGS_((int mode)))
+#endif /* #ifndef Tcl_ServiceModeHook */
+
+#ifndef Tcl_SetMaxBlockTime
+VFUNC(void,Tcl_SetMaxBlockTime,V_Tcl_SetMaxBlockTime,_ANSI_ARGS_((Tcl_Time *timePtr)))
+#endif /* #ifndef Tcl_SetMaxBlockTime */
+
+#ifndef Tcl_SetNotifier
+VFUNC(void,Tcl_SetNotifier,V_Tcl_SetNotifier,_ANSI_ARGS_((
+ Tcl_NotifierProcs * notifierProcPtr)))
+#endif /* #ifndef Tcl_SetNotifier */
+
+#ifndef Tcl_SetServiceMode
+VFUNC(int,Tcl_SetServiceMode,V_Tcl_SetServiceMode,_ANSI_ARGS_((int mode)))
+#endif /* #ifndef Tcl_SetServiceMode */
+
+#ifndef Tcl_SetTimer
+VFUNC(void,Tcl_SetTimer,V_Tcl_SetTimer,_ANSI_ARGS_((Tcl_Time * timePtr)))
+#endif /* #ifndef Tcl_SetTimer */
+
+#ifndef Tcl_Sleep
+VFUNC(void,Tcl_Sleep,V_Tcl_Sleep,_ANSI_ARGS_((int ms)))
+#endif /* #ifndef Tcl_Sleep */
+
+#ifndef Tcl_ThreadAlert
+VFUNC(void,Tcl_ThreadAlert,V_Tcl_ThreadAlert,_ANSI_ARGS_((Tcl_ThreadId threadId)))
+#endif /* #ifndef Tcl_ThreadAlert */
+
+#ifndef Tcl_ThreadQueueEvent
+VFUNC(void,Tcl_ThreadQueueEvent,V_Tcl_ThreadQueueEvent,_ANSI_ARGS_((
+ Tcl_ThreadId threadId, Tcl_Event* evPtr,
+ Tcl_QueuePosition position)))
+#endif /* #ifndef Tcl_ThreadQueueEvent */
+
+#ifndef Tcl_ValidateAllMemory
+VFUNC(void,Tcl_ValidateAllMemory,V_Tcl_ValidateAllMemory,_ANSI_ARGS_((CONST char * file,
+ int line)))
+#endif /* #ifndef Tcl_ValidateAllMemory */
+
+#ifndef Tcl_WaitForEvent
+VFUNC(int,Tcl_WaitForEvent,V_Tcl_WaitForEvent,_ANSI_ARGS_((Tcl_Time * timePtr)))
+#endif /* #ifndef Tcl_WaitForEvent */
+
+#ifndef TclpAsyncMark
+VFUNC(void,TclpAsyncMark,V_TclpAsyncMark,_ANSI_ARGS_((Tcl_AsyncHandler async)))
+#endif /* #ifndef TclpAsyncMark */
+
+#ifndef TclpExit
+VFUNC(void,TclpExit,V_TclpExit,_ANSI_ARGS_((int status)))
+#endif /* #ifndef TclpExit */
+
+#ifndef TkInitTimer
+VFUNC(void *,TkInitTimer,V_TkInitTimer,_ANSI_ARGS_((void)))
+#endif /* #ifndef TkInitTimer */
+
+#endif /* _TKEVENT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent_f.h
new file mode 100755
index 00000000000..f00d4002b13
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkEvent_f.h
@@ -0,0 +1,14 @@
+#ifndef TKEVENT_VT
+#define TKEVENT_VT
+typedef struct TkeventVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkEvent.t"
+#undef VFUNC
+#undef VVAR
+} TkeventVtab;
+extern TkeventVtab *TkeventVptr;
+extern TkeventVtab *TkeventVGet(void);
+#endif /* TKEVENT_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkFileFilter.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkFileFilter.h
new file mode 100755
index 00000000000..886f1426cf3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkFileFilter.h
@@ -0,0 +1,92 @@
+/*
+ * tkFileFilter.h --
+ *
+ * Declarations for the file filter processing routines needed by
+ * the file selection dialogs.
+ *
+ * Copyright (c) 1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkFileFilter.h,v 1.4 1998/09/14 18:23:10 stanton Exp $
+ *
+ */
+
+#ifndef _TK_FILE_FILTER
+#define _TK_FILE_FILTER
+
+#ifdef MAC_TCL
+#include <StandardFile.h>
+#else
+#define OSType long
+#endif
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+typedef struct GlobPattern {
+ struct GlobPattern * next; /* Chains to the next glob pattern
+ * in a glob pattern list */
+ char * pattern; /* String value of the pattern, such
+ * as "*.txt" or "*.*"
+ */
+} GlobPattern;
+
+typedef struct MacFileType {
+ struct MacFileType * next; /* Chains to the next mac file type
+ * in a mac file type list */
+ OSType type; /* Mac file type, such as 'TEXT' or
+ * 'GIFF' */
+} MacFileType;
+
+typedef struct FileFilterClause {
+ struct FileFilterClause * next; /* Chains to the next clause in
+ * a clause list */
+ GlobPattern * patterns; /* Head of glob pattern type list */
+ GlobPattern * patternsTail; /* Tail of glob pattern type list */
+ MacFileType * macTypes; /* Head of mac file type list */
+ MacFileType * macTypesTail; /* Tail of mac file type list */
+} FileFilterClause;
+
+typedef struct FileFilter {
+ struct FileFilter * next; /* Chains to the next filter
+ * in a filter list */
+ char * name; /* Name of the file filter,
+ * such as "Text Documents" */
+ FileFilterClause * clauses; /* Head of the clauses list */
+ FileFilterClause * clausesTail; /* Tail of the clauses list */
+} FileFilter;
+
+/*----------------------------------------------------------------------
+ * FileFilterList --
+ *
+ * The routine TkGetFileFilters() translates the string value of the
+ * -filefilters option into a FileFilterList structure, which consists
+ * of a list of file filters.
+ *
+ * Each file filter consists of one or more clauses. Each clause has
+ * one or more glob patterns and/or one or more Mac file types
+ *----------------------------------------------------------------------
+ */
+
+typedef struct FileFilterList {
+ FileFilter * filters; /* Head of the filter list */
+ FileFilter * filtersTail; /* Tail of the filter list */
+ int numFilters; /* number of filters in the list */
+} FileFilterList;
+
+EXTERN void TkFreeFileFilters _ANSI_ARGS_((
+ FileFilterList * flistPtr));
+EXTERN void TkInitFileFilters _ANSI_ARGS_((
+ FileFilterList * flistPtr));
+EXTERN int TkGetFileFilters _ANSI_ARGS_ ((Tcl_Interp *interp,
+ FileFilterList * flistPtr, Tcl_Obj * arg,
+ int isWindows));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkFont.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkFont.h
new file mode 100755
index 00000000000..fe633a1d87a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkFont.h
@@ -0,0 +1,226 @@
+/*
+ * tkFont.h --
+ *
+ * Declarations for interfaces between the generic and platform-
+ * specific parts of the font package. This information is not
+ * visible outside of the font package.
+ *
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkFont.h,v 1.5 1999/04/16 01:51:14 stanton Exp $
+ */
+
+#ifndef _TKFONT
+#define _TKFONT
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * The following structure keeps track of the attributes of a font. It can
+ * be used to keep track of either the desired attributes or the actual
+ * attributes gotten when the font was instantiated.
+ */
+
+typedef struct TkFontAttributes {
+ Tk_Uid family; /* Font family, or NULL to represent
+ * plaform-specific default system font. */
+ int size; /* Pointsize of font, 0 for default size, or
+ * negative number meaning pixel size. */
+ int weight; /* Weight flag; see below for def'n. */
+ int slant; /* Slant flag; see below for def'n. */
+ int underline; /* Non-zero for underline font. */
+ int overstrike; /* Non-zero for overstrike font. */
+} TkFontAttributes;
+
+/*
+ * Possible values for the "weight" field in a TkFontAttributes structure.
+ * Weight is a subjective term and depends on what the company that created
+ * the font considers bold.
+ */
+
+#define TK_FW_NORMAL 0
+#define TK_FW_BOLD 1
+
+#define TK_FW_UNKNOWN -1 /* Unknown weight. This value is used for
+ * error checking and is never actually stored
+ * in the weight field. */
+
+/*
+ * Possible values for the "slant" field in a TkFontAttributes structure.
+ */
+
+#define TK_FS_ROMAN 0
+#define TK_FS_ITALIC 1
+#define TK_FS_OBLIQUE 2 /* This value is only used when parsing X
+ * font names to determine the closest
+ * match. It is only stored in the
+ * XLFDAttributes structure, never in the
+ * slant field of the TkFontAttributes. */
+
+#define TK_FS_UNKNOWN -1 /* Unknown slant. This value is used for
+ * error checking and is never actually stored
+ * in the slant field. */
+
+/*
+ * The following structure keeps track of the metrics for an instantiated
+ * font. The metrics are the physical properties of the font itself.
+ */
+
+typedef struct TkFontMetrics {
+ int ascent; /* From baseline to top of font. */
+ int descent; /* From baseline to bottom of font. */
+ int maxWidth; /* Width of widest character in font. */
+ int fixed; /* Non-zero if this is a fixed-width font,
+ * 0 otherwise. */
+} TkFontMetrics;
+
+/*
+ * The following structure is used to keep track of the generic information
+ * about a font. Each platform-specific font is represented by a structure
+ * with the following structure at its beginning, plus any platform-
+ * specific stuff after that.
+ */
+
+typedef struct TkFont {
+ /*
+ * Fields used and maintained exclusively by generic code.
+ */
+
+ int resourceRefCount; /* Number of active uses of this font (each
+ * active use corresponds to a call to
+ * Tk_AllocFontFromTable or Tk_GetFont).
+ * If this count is 0, then this TkFont
+ * structure is no longer valid and it isn't
+ * present in a hash table: it is being
+ * kept around only because there are objects
+ * referring to it. The structure is freed
+ * when resourceRefCount and objRefCount
+ * are both 0. */
+ int objRefCount; /* The number of Tcl objects that reference
+ * this structure. */
+ Tcl_HashEntry *cacheHashPtr;/* Entry in font cache for this structure,
+ * used when deleting it. */
+ Tcl_HashEntry *namedHashPtr;/* Pointer to hash table entry that
+ * corresponds to the named font that the
+ * tkfont was based on, or NULL if the tkfont
+ * was not based on a named font. */
+ Screen *screen; /* The screen where this font is valid. */
+ int tabWidth; /* Width of tabs in this font (pixels). */
+ int underlinePos; /* Offset from baseline to origin of
+ * underline bar (used for drawing underlines
+ * on a non-underlined font). */
+ int underlineHeight; /* Height of underline bar (used for drawing
+ * underlines on a non-underlined font). */
+
+ /*
+ * Fields used in the generic code that are filled in by
+ * platform-specific code.
+ */
+
+ Font fid; /* For backwards compatibility with XGCValues
+ * structures. Remove when TkGCValues is
+ * implemented. */
+ TkFontAttributes fa; /* Actual font attributes obtained when the
+ * the font was created, as opposed to the
+ * desired attributes passed in to
+ * TkpGetFontFromAttributes(). The desired
+ * metrics can be determined from the string
+ * that was used to create this font. */
+ TkFontMetrics fm; /* Font metrics determined when font was
+ * created. */
+ struct TkFont *nextPtr; /* Points to the next TkFont structure with
+ * the same name. All fonts with the
+ * same name (but different displays) are
+ * chained together off a single entry in
+ * a hash table. */
+} TkFont;
+
+/*
+ * The following structure is used to return attributes when parsing an
+ * XLFD. The extra information is of interest to the Unix-specific code
+ * when attempting to find the closest matching font.
+ */
+
+typedef struct TkXLFDAttributes {
+ Tk_Uid foundry; /* The foundry of the font. */
+ int slant; /* The tristate value for the slant, which
+ * is significant under X. */
+ int setwidth; /* The proportionate width, see below for
+ * definition. */
+ Tk_Uid charset; /* The actual charset string. */
+} TkXLFDAttributes;
+
+/*
+ * Possible values for the "setwidth" field in a TkXLFDAttributes structure.
+ * The setwidth is whether characters are considered wider or narrower than
+ * normal.
+ */
+
+#define TK_SW_NORMAL 0
+#define TK_SW_CONDENSE 1
+#define TK_SW_EXPAND 2
+#define TK_SW_UNKNOWN 3 /* Unknown setwidth. This value may be
+ * stored in the setwidth field. */
+
+/*
+ * The following defines specify the meaning of the fields in a fully
+ * qualified XLFD.
+ */
+
+#define XLFD_FOUNDRY 0
+#define XLFD_FAMILY 1
+#define XLFD_WEIGHT 2
+#define XLFD_SLANT 3
+#define XLFD_SETWIDTH 4
+#define XLFD_ADD_STYLE 5
+#define XLFD_PIXEL_SIZE 6
+#define XLFD_POINT_SIZE 7
+#define XLFD_RESOLUTION_X 8
+#define XLFD_RESOLUTION_Y 9
+#define XLFD_SPACING 10
+#define XLFD_AVERAGE_WIDTH 11
+#define XLFD_CHARSET 12
+#define XLFD_NUMFIELDS 13 /* Number of fields in XLFD. */
+
+/*
+ * Low-level API exported by generic code to platform-specific code.
+ */
+
+#define TkInitFontAttributes(fa) memset((fa), 0, sizeof(TkFontAttributes));
+#define TkInitXLFDAttributes(xa) memset((xa), 0, sizeof(TkXLFDAttributes));
+
+EXTERN int TkFontParseXLFD _ANSI_ARGS_((CONST char *string,
+ TkFontAttributes *faPtr, TkXLFDAttributes *xaPtr));
+EXTERN char ** TkFontGetAliasList _ANSI_ARGS_((CONST char *faceName));
+EXTERN char *** TkFontGetFallbacks _ANSI_ARGS_((void));
+EXTERN int TkFontGetPixels _ANSI_ARGS_((Screen *screen,
+ int size));
+EXTERN int TkFontGetPoints _ANSI_ARGS_((Screen *screen,
+ int size));
+EXTERN char ** TkFontGetGlobalClass _ANSI_ARGS_((void));
+EXTERN char ** TkFontGetSymbolClass _ANSI_ARGS_((void));
+
+/*
+ * Low-level API exported by platform-specific code to generic code.
+ */
+
+EXTERN void TkpDeleteFont _ANSI_ARGS_((TkFont *tkFontPtr));
+EXTERN void TkpFontPkgInit _ANSI_ARGS_((TkMainInfo *mainPtr));
+EXTERN TkFont * TkpGetFontFromAttributes _ANSI_ARGS_((
+ TkFont *tkFontPtr, Tk_Window tkwin,
+ CONST TkFontAttributes *faPtr));
+EXTERN void TkpGetFontFamilies _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin));
+EXTERN TkFont * TkpGetNativeFont _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char *name));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKFONT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.h
new file mode 100755
index 00000000000..bb744a46421
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.h
@@ -0,0 +1,36 @@
+#ifndef _TKIMGPHOTO
+#define _TKIMGPHOTO
+
+
+EXTERN void Tk_CreateOldPhotoImageFormat _ANSI_ARGS_((
+ Tk_PhotoImageFormat *formatPtr));
+EXTERN void Tk_CreatePhotoImageFormat _ANSI_ARGS_((
+ Tk_PhotoImageFormat *formatPtr));
+EXTERN void Tk_DitherPhoto _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int x, int y, int width, int height));
+EXTERN Tk_PhotoHandle Tk_FindPhoto _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *imageName));
+EXTERN void Tk_PhotoBlank _ANSI_ARGS_((Tk_PhotoHandle handle));
+EXTERN void Tk_PhotoExpand _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int width, int height ));
+EXTERN char * Tk_PhotoFormatName _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *formatString));
+EXTERN int Tk_PhotoGetImage _ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr));
+EXTERN void Tk_PhotoGetSize _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int *widthPtr, int *heightPtr));
+EXTERN void Tk_PhotoPutBlock _ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr, int x, int y,
+ int width, int height, int compRule));
+EXTERN void Tk_PhotoPutZoomedBlock _ANSI_ARGS_((
+ Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr, int x, int y,
+ int width, int height, int zoomX, int zoomY,
+ int subsampleX, int subsampleY, int compRule));
+EXTERN void Tk_PhotoSetSize _ANSI_ARGS_((Tk_PhotoHandle handle,
+ int width, int height));
+extern Tk_PhotoImageFormat tkImgFmtGIF;
+extern Tk_PhotoImageFormat tkImgFmtPPM;
+#endif /* _TKIMGPHOTO */
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.m
new file mode 100755
index 00000000000..1e1e302a6c6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.m
@@ -0,0 +1,55 @@
+#ifndef _TKIMGPHOTO_VM
+#define _TKIMGPHOTO_VM
+#include "tkImgPhoto_f.h"
+#ifndef NO_VTABLES
+#define tkImgFmtPPM (*TkimgphotoVptr->V_tkImgFmtPPM)
+#ifndef Tk_CreateOldPhotoImageFormat
+# define Tk_CreateOldPhotoImageFormat (*TkimgphotoVptr->V_Tk_CreateOldPhotoImageFormat)
+#endif
+
+#ifndef Tk_CreatePhotoImageFormat
+# define Tk_CreatePhotoImageFormat (*TkimgphotoVptr->V_Tk_CreatePhotoImageFormat)
+#endif
+
+#ifndef Tk_DitherPhoto
+# define Tk_DitherPhoto (*TkimgphotoVptr->V_Tk_DitherPhoto)
+#endif
+
+#ifndef Tk_FindPhoto
+# define Tk_FindPhoto (*TkimgphotoVptr->V_Tk_FindPhoto)
+#endif
+
+#ifndef Tk_PhotoBlank
+# define Tk_PhotoBlank (*TkimgphotoVptr->V_Tk_PhotoBlank)
+#endif
+
+#ifndef Tk_PhotoExpand
+# define Tk_PhotoExpand (*TkimgphotoVptr->V_Tk_PhotoExpand)
+#endif
+
+#ifndef Tk_PhotoFormatName
+# define Tk_PhotoFormatName (*TkimgphotoVptr->V_Tk_PhotoFormatName)
+#endif
+
+#ifndef Tk_PhotoGetImage
+# define Tk_PhotoGetImage (*TkimgphotoVptr->V_Tk_PhotoGetImage)
+#endif
+
+#ifndef Tk_PhotoGetSize
+# define Tk_PhotoGetSize (*TkimgphotoVptr->V_Tk_PhotoGetSize)
+#endif
+
+#ifndef Tk_PhotoPutBlock
+# define Tk_PhotoPutBlock (*TkimgphotoVptr->V_Tk_PhotoPutBlock)
+#endif
+
+#ifndef Tk_PhotoPutZoomedBlock
+# define Tk_PhotoPutZoomedBlock (*TkimgphotoVptr->V_Tk_PhotoPutZoomedBlock)
+#endif
+
+#ifndef Tk_PhotoSetSize
+# define Tk_PhotoSetSize (*TkimgphotoVptr->V_Tk_PhotoSetSize)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKIMGPHOTO_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.t
new file mode 100755
index 00000000000..02bd1b3807e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto.t
@@ -0,0 +1,66 @@
+#ifdef _TKIMGPHOTO
+VVAR(Tk_PhotoImageFormat,tkImgFmtPPM,V_tkImgFmtPPM)
+#ifndef Tk_CreateOldPhotoImageFormat
+VFUNC(void,Tk_CreateOldPhotoImageFormat,V_Tk_CreateOldPhotoImageFormat,_ANSI_ARGS_((
+ Tk_PhotoImageFormat *formatPtr)))
+#endif /* #ifndef Tk_CreateOldPhotoImageFormat */
+
+#ifndef Tk_CreatePhotoImageFormat
+VFUNC(void,Tk_CreatePhotoImageFormat,V_Tk_CreatePhotoImageFormat,_ANSI_ARGS_((
+ Tk_PhotoImageFormat *formatPtr)))
+#endif /* #ifndef Tk_CreatePhotoImageFormat */
+
+#ifndef Tk_DitherPhoto
+VFUNC(void,Tk_DitherPhoto,V_Tk_DitherPhoto,_ANSI_ARGS_((Tk_PhotoHandle handle,
+ int x, int y, int width, int height)))
+#endif /* #ifndef Tk_DitherPhoto */
+
+#ifndef Tk_FindPhoto
+VFUNC(Tk_PhotoHandle,Tk_FindPhoto,V_Tk_FindPhoto,_ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *imageName)))
+#endif /* #ifndef Tk_FindPhoto */
+
+#ifndef Tk_PhotoBlank
+VFUNC(void,Tk_PhotoBlank,V_Tk_PhotoBlank,_ANSI_ARGS_((Tk_PhotoHandle handle)))
+#endif /* #ifndef Tk_PhotoBlank */
+
+#ifndef Tk_PhotoExpand
+VFUNC(void,Tk_PhotoExpand,V_Tk_PhotoExpand,_ANSI_ARGS_((Tk_PhotoHandle handle,
+ int width, int height )))
+#endif /* #ifndef Tk_PhotoExpand */
+
+#ifndef Tk_PhotoFormatName
+VFUNC(char *,Tk_PhotoFormatName,V_Tk_PhotoFormatName,_ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *formatString)))
+#endif /* #ifndef Tk_PhotoFormatName */
+
+#ifndef Tk_PhotoGetImage
+VFUNC(int,Tk_PhotoGetImage,V_Tk_PhotoGetImage,_ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr)))
+#endif /* #ifndef Tk_PhotoGetImage */
+
+#ifndef Tk_PhotoGetSize
+VFUNC(void,Tk_PhotoGetSize,V_Tk_PhotoGetSize,_ANSI_ARGS_((Tk_PhotoHandle handle,
+ int *widthPtr, int *heightPtr)))
+#endif /* #ifndef Tk_PhotoGetSize */
+
+#ifndef Tk_PhotoPutBlock
+VFUNC(void,Tk_PhotoPutBlock,V_Tk_PhotoPutBlock,_ANSI_ARGS_((Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr, int x, int y,
+ int width, int height, int compRule)))
+#endif /* #ifndef Tk_PhotoPutBlock */
+
+#ifndef Tk_PhotoPutZoomedBlock
+VFUNC(void,Tk_PhotoPutZoomedBlock,V_Tk_PhotoPutZoomedBlock,_ANSI_ARGS_((
+ Tk_PhotoHandle handle,
+ Tk_PhotoImageBlock *blockPtr, int x, int y,
+ int width, int height, int zoomX, int zoomY,
+ int subsampleX, int subsampleY, int compRule)))
+#endif /* #ifndef Tk_PhotoPutZoomedBlock */
+
+#ifndef Tk_PhotoSetSize
+VFUNC(void,Tk_PhotoSetSize,V_Tk_PhotoSetSize,_ANSI_ARGS_((Tk_PhotoHandle handle,
+ int width, int height)))
+#endif /* #ifndef Tk_PhotoSetSize */
+
+#endif /* _TKIMGPHOTO */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto_f.h
new file mode 100755
index 00000000000..594cebf81b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkImgPhoto_f.h
@@ -0,0 +1,14 @@
+#ifndef TKIMGPHOTO_VT
+#define TKIMGPHOTO_VT
+typedef struct TkimgphotoVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkImgPhoto.t"
+#undef VFUNC
+#undef VVAR
+} TkimgphotoVtab;
+extern TkimgphotoVtab *TkimgphotoVptr;
+extern TkimgphotoVtab *TkimgphotoVGet(void);
+#endif /* TKIMGPHOTO_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInitScript.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInitScript.h
new file mode 100755
index 00000000000..2e2b2343c32
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInitScript.h
@@ -0,0 +1,58 @@
+/*
+ * tkInitScript.h --
+ *
+ * This file contains Unix & Windows common init script
+ * It is not used on the Mac. (the mac init script is in tkMacInit.c)
+ *
+ * Copyright (c) 1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkInitScript.h,v 1.8 1999/04/16 01:51:15 stanton Exp $
+ */
+
+
+
+/*
+ * In order to find tk.tcl during initialization, the following script
+ * is invoked by Tk_Init(). It looks in several different directories:
+ *
+ * $tk_library - can specify a primary location, if set
+ * no other locations will be checked
+ *
+ * $env(TK_LIBRARY) - highest priority so user can always override
+ * the search path unless the application has
+ * specified an exact directory above
+ *
+ * $tcl_library/../tk$tk_version
+ * - look relative to init.tcl in an installed
+ * lib directory (e.g. /usr/local)
+ *
+ * <executable directory>/../lib/tk$tk_version
+ * - look for a lib/tk<ver> in a sibling of
+ * the bin directory (e.g. /usr/local)
+ *
+ * <executable directory>/../library
+ * - look in Tk build directory
+ *
+ * <executable directory>/../../tk$tk_patchLevel/library
+ * - look for Tk build directory relative
+ * to a parallel build directory
+ *
+ * The first directory on this path that contains a valid tk.tcl script
+ * will be set ast the value of tk_library.
+ *
+ * Note that this entire search mechanism can be bypassed by defining an
+ * alternate tkInit procedure before calling Tk_Init().
+ */
+
+static char initScript[] = "if {[info proc tkInit]==\"\"} {\n\
+ proc tkInit {} {\n\
+ global tk_library tk_version tk_patchLevel\n\
+ rename tkInit {}\n\
+ tcl_findLibrary tk $tk_version $tk_patchLevel tk.tcl TK_LIBRARY tk_library\n\
+ }\n\
+}\n\
+tkInit";
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.h
new file mode 100755
index 00000000000..a1925bdda5d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.h
@@ -0,0 +1,1200 @@
+/*
+ * tkInt.h --
+ *
+ * Declarations for things used internally by the Tk
+ * procedures but not exported outside the module.
+ *
+ * Copyright (c) 1990-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: $Id: tkInt.h,v 1.56.2.1 2003/10/13 03:30:05 hobbs Exp $
+ */
+
+#ifndef _TKINT
+#define _TKINT
+
+#ifndef _TK
+#include "tk.h"
+#endif
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Opaque type declarations:
+ */
+
+typedef struct TkColormap TkColormap;
+typedef struct TkGrabEvent TkGrabEvent;
+typedef struct TkpCursor_ *TkpCursor;
+typedef struct TkRegion_ *TkRegion;
+typedef struct TkStressedCmap TkStressedCmap;
+typedef struct TkBindInfo_ *TkBindInfo;
+
+/*
+ * Procedure types.
+ */
+
+typedef int (TkBindEvalProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, XEvent *eventPtr, Tk_Window tkwin,
+ KeySym keySym));
+typedef void (TkBindFreeProc) _ANSI_ARGS_((ClientData clientData));
+
+/*
+ * One of the following structures is maintained for each cursor in
+ * use in the system. This structure is used by tkCursor.c and the
+ * various system specific cursor files.
+ */
+
+typedef struct TkCursor {
+ Tk_Cursor cursor; /* System specific identifier for cursor. */
+ Display *display; /* Display containing cursor. Needed for
+ * disposal and retrieval of cursors. */
+ int resourceRefCount; /* Number of active uses of this cursor (each
+ * active use corresponds to a call to
+ * Tk_AllocPreserveFromObj or Tk_Preserve).
+ * If this count is 0, then this structure
+ * is no longer valid and it isn't present
+ * in a hash table: it is being kept around
+ * only because there are objects referring
+ * to it. The structure is freed when
+ * resourceRefCount and objRefCount are
+ * both 0. */
+ int objRefCount; /* Number of Tcl objects that reference
+ * this structure.. */
+ Tcl_HashTable *otherTable; /* Second table (other than idTable) used
+ * to index this entry. */
+ Tcl_HashEntry *hashPtr; /* Entry in otherTable for this structure
+ * (needed when deleting). */
+ Tcl_HashEntry *idHashPtr; /* Entry in idTable for this structure
+ * (needed when deleting). */
+ struct TkCursor *nextPtr; /* Points to the next TkCursor structure with
+ * the same name. Cursors with the same
+ * name but different displays are chained
+ * together off a single hash table entry. */
+} TkCursor;
+
+/*
+ * This defines whether we should try to use XIM over-the-spot style
+ * input. Allow users to override it. It is a much more elegant use
+ * of XIM, but uses a bit more memory.
+ */
+
+#ifndef TK_XIM_SPOT
+# define TK_XIM_SPOT 1
+#endif
+
+/*
+ * The following structure is kept one-per-TkDisplay to maintain information
+ * about the caret (cursor location) on this display. This is used to
+ * dictate global focus location (Windows Accessibility guidelines) and to
+ * position the IME or XIM over-the-spot window.
+ */
+
+typedef struct TkCaret {
+ struct TkWindow *winPtr; /* the window on which we requested caret
+ * placement */
+ int x; /* relative x coord of the caret */
+ int y; /* relative y coord of the caret */
+ int height; /* specified height of the window */
+} TkCaret;
+
+/*
+ * One of the following structures is maintained for each display
+ * containing a window managed by Tk. In part, the structure is
+ * used to store thread-specific data, since each thread will have
+ * its own TkDisplay structure.
+ */
+
+typedef struct TkDisplay {
+ Display *display; /* Xlib's info about display. */
+ struct TkDisplay *nextPtr; /* Next in list of all displays. */
+ char *name; /* Name of display (with any screen
+ * identifier removed). Malloc-ed. */
+ Time lastEventTime; /* Time of last event received for this
+ * display. */
+
+ /*
+ * Information used primarily by tk3d.c:
+ */
+
+ int borderInit; /* 0 means borderTable needs initializing. */
+ Tcl_HashTable borderTable; /* Maps from color name to TkBorder
+ * structure. */
+
+ /*
+ * Information used by tkAtom.c only:
+ */
+
+ int atomInit; /* 0 means stuff below hasn't been
+ * initialized yet. */
+ Tcl_HashTable nameTable; /* Maps from names to Atom's. */
+ Tcl_HashTable atomTable; /* Maps from Atom's back to names. */
+
+ /*
+ * Information used primarily by tkBind.c:
+ */
+
+ int bindInfoStale; /* Non-zero means the variables in this
+ * part of the structure are potentially
+ * incorrect and should be recomputed. */
+ unsigned int modeModMask; /* Has one bit set to indicate the modifier
+ * corresponding to "mode shift". If no
+ * such modifier, than this is zero. */
+ unsigned int metaModMask; /* Has one bit set to indicate the modifier
+ * corresponding to the "Meta" key. If no
+ * such modifier, then this is zero. */
+ unsigned int altModMask; /* Has one bit set to indicate the modifier
+ * corresponding to the "Meta" key. If no
+ * such modifier, then this is zero. */
+ enum {LU_IGNORE, LU_CAPS, LU_SHIFT} lockUsage;
+ /* Indicates how to interpret lock modifier. */
+ int numModKeyCodes; /* Number of entries in modKeyCodes array
+ * below. */
+ KeyCode *modKeyCodes; /* Pointer to an array giving keycodes for
+ * all of the keys that have modifiers
+ * associated with them. Malloc'ed, but
+ * may be NULL. */
+
+ /*
+ * Information used by tkBitmap.c only:
+ */
+
+ int bitmapInit; /* 0 means tables above need initializing. */
+ int bitmapAutoNumber; /* Used to number bitmaps. */
+ Tcl_HashTable bitmapNameTable;
+ /* Maps from name of bitmap to the first
+ * TkBitmap record for that name. */
+ Tcl_HashTable bitmapIdTable;/* Maps from bitmap id to the TkBitmap
+ * structure for the bitmap. */
+ Tcl_HashTable bitmapDataTable;
+ /* Used by Tk_GetBitmapFromData to map from
+ * a collection of in-core data about a
+ * bitmap to a reference giving an auto-
+ * matically-generated name for the bitmap. */
+
+ /*
+ * Information used by tkCanvas.c only:
+ */
+
+ int numIdSearches;
+ int numSlowSearches;
+
+ /*
+ * Used by tkColor.c only:
+ */
+
+ int colorInit; /* 0 means color module needs initializing. */
+ TkStressedCmap *stressPtr; /* First in list of colormaps that have
+ * filled up, so we have to pick an
+ * approximate color. */
+ Tcl_HashTable colorNameTable;
+ /* Maps from color name to TkColor structure
+ * for that color. */
+ Tcl_HashTable colorValueTable;
+ /* Maps from integer RGB values to TkColor
+ * structures. */
+
+ /*
+ * Used by tkCursor.c only:
+ */
+
+ int cursorInit; /* 0 means cursor module need initializing. */
+ Tcl_HashTable cursorNameTable;
+ /* Maps from a string name to a cursor to the
+ * TkCursor record for the cursor. */
+ Tcl_HashTable cursorDataTable;
+ /* Maps from a collection of in-core data
+ * about a cursor to a TkCursor structure. */
+ Tcl_HashTable cursorIdTable;
+ /* Maps from a cursor id to the TkCursor
+ * structure for the cursor. */
+ char cursorString[20]; /* Used to store a cursor id string. */
+ Font cursorFont; /* Font to use for standard cursors.
+ * None means font not loaded yet. */
+
+ /*
+ * Information used by tkError.c only:
+ */
+
+ struct TkErrorHandler *errorPtr;
+ /* First in list of error handlers
+ * for this display. NULL means
+ * no handlers exist at present. */
+ int deleteCount; /* Counts # of handlers deleted since
+ * last time inactive handlers were
+ * garbage-collected. When this number
+ * gets big, handlers get cleaned up. */
+
+ /*
+ * Used by tkEvent.c only:
+ */
+
+ struct TkWindowEvent *delayedMotionPtr;
+ /* Points to a malloc-ed motion event
+ * whose processing has been delayed in
+ * the hopes that another motion event
+ * will come along right away and we can
+ * merge the two of them together. NULL
+ * means that there is no delayed motion
+ * event. */
+
+ /*
+ * Information used by tkFocus.c only:
+ */
+
+ int focusDebug; /* 1 means collect focus debugging
+ * statistics. */
+ struct TkWindow *implicitWinPtr;
+ /* If the focus arrived at a toplevel window
+ * implicitly via an Enter event (rather
+ * than via a FocusIn event), this points
+ * to the toplevel window. Otherwise it is
+ * NULL. */
+ struct TkWindow *focusPtr; /* Points to the window on this display that
+ * should be receiving keyboard events. When
+ * multiple applications on the display have
+ * the focus, this will refer to the
+ * innermost window in the innermost
+ * application. This information isn't used
+ * under Unix or Windows, but it's needed on
+ * the Macintosh. */
+
+ /*
+ * Information used by tkGC.c only:
+ */
+
+ Tcl_HashTable gcValueTable; /* Maps from a GC's values to a TkGC structure
+ * describing a GC with those values. */
+ Tcl_HashTable gcIdTable; /* Maps from a GC to a TkGC. */
+ int gcInit; /* 0 means the tables below need
+ * initializing. */
+
+ /*
+ * Information used by tkGeometry.c only:
+ */
+
+ Tcl_HashTable maintainHashTable;
+ /* Hash table that maps from a master's
+ * Tk_Window token to a list of slaves
+ * managed by that master. */
+ int geomInit;
+
+ /*
+ * Information used by tkGet.c only:
+ */
+
+ Tcl_HashTable uidTable; /* Stores all Tk_Uid used in a thread. */
+ int uidInit; /* 0 means uidTable needs initializing. */
+
+ /*
+ * Information used by tkGrab.c only:
+ */
+
+ struct TkWindow *grabWinPtr;
+ /* Window in which the pointer is currently
+ * grabbed, or NULL if none. */
+ struct TkWindow *eventualGrabWinPtr;
+ /* Value that grabWinPtr will have once the
+ * grab event queue (below) has been
+ * completely emptied. */
+ struct TkWindow *buttonWinPtr;
+ /* Window in which first mouse button was
+ * pressed while grab was in effect, or NULL
+ * if no such press in effect. */
+ struct TkWindow *serverWinPtr;
+ /* If no application contains the pointer then
+ * this is NULL. Otherwise it contains the
+ * last window for which we've gotten an
+ * Enter or Leave event from the server (i.e.
+ * the last window known to have contained
+ * the pointer). Doesn't reflect events
+ * that were synthesized in tkGrab.c. */
+ TkGrabEvent *firstGrabEventPtr;
+ /* First in list of enter/leave events
+ * synthesized by grab code. These events
+ * must be processed in order before any other
+ * events are processed. NULL means no such
+ * events. */
+ TkGrabEvent *lastGrabEventPtr;
+ /* Last in list of synthesized events, or NULL
+ * if list is empty. */
+ int grabFlags; /* Miscellaneous flag values. See definitions
+ * in tkGrab.c. */
+
+ /*
+ * Information used by tkGrid.c only:
+ */
+
+ int gridInit; /* 0 means table below needs initializing. */
+ Tcl_HashTable gridHashTable;/* Maps from Tk_Window tokens to
+ * corresponding Grid structures. */
+
+ /*
+ * Information used by tkImage.c only:
+ */
+
+ int imageId; /* Value used to number image ids. */
+
+ /*
+ * Information used by tkMacWinMenu.c only:
+ */
+
+ int postCommandGeneration;
+
+ /*
+ * Information used by tkOption.c only.
+ */
+
+
+
+ /*
+ * Information used by tkPack.c only.
+ */
+
+ int packInit; /* 0 means table below needs initializing. */
+ Tcl_HashTable packerHashTable;
+ /* Maps from Tk_Window tokens to
+ * corresponding Packer structures. */
+
+
+ /*
+ * Information used by tkPlace.c only.
+ */
+
+ int placeInit; /* 0 means tables below need initializing. */
+ Tcl_HashTable masterTable; /* Maps from Tk_Window toke to the Master
+ * structure for the window, if it exists. */
+ Tcl_HashTable slaveTable; /* Maps from Tk_Window toke to the Slave
+ * structure for the window, if it exists. */
+
+ /*
+ * Information used by tkSelect.c and tkClipboard.c only:
+ */
+
+ struct TkSelectionInfo *selectionInfoPtr;
+ /* First in list of selection information
+ * records. Each entry contains information
+ * about the current owner of a particular
+ * selection on this display. */
+ Atom multipleAtom; /* Atom for MULTIPLE. None means
+ * selection stuff isn't initialized. */
+ Atom incrAtom; /* Atom for INCR. */
+ Atom targetsAtom; /* Atom for TARGETS. */
+ Atom timestampAtom; /* Atom for TIMESTAMP. */
+ Atom textAtom; /* Atom for TEXT. */
+ Atom compoundTextAtom; /* Atom for COMPOUND_TEXT. */
+ Atom applicationAtom; /* Atom for TK_APPLICATION. */
+ Atom windowAtom; /* Atom for TK_WINDOW. */
+ Atom clipboardAtom; /* Atom for CLIPBOARD. */
+ Atom utf8Atom; /* Atom for UTF8_STRING. */
+
+ Tk_Window clipWindow; /* Window used for clipboard ownership and to
+ * retrieve selections between processes. NULL
+ * means clipboard info hasn't been
+ * initialized. */
+ int clipboardActive; /* 1 means we currently own the clipboard
+ * selection, 0 means we don't. */
+ struct TkMainInfo *clipboardAppPtr;
+ /* Last application that owned clipboard. */
+ struct TkClipboardTarget *clipTargetPtr;
+ /* First in list of clipboard type information
+ * records. Each entry contains information
+ * about the buffers for a given selection
+ * target. */
+
+ /*
+ * Information used by tkSend.c only:
+ */
+
+ Tk_Window commTkwin; /* Window used for communication
+ * between interpreters during "send"
+ * commands. NULL means send info hasn't
+ * been initialized yet. */
+ Atom commProperty; /* X's name for comm property. */
+ Atom registryProperty; /* X's name for property containing
+ * registry of interpreter names. */
+ Atom appNameProperty; /* X's name for property used to hold the
+ * application name on each comm window. */
+
+ /*
+ * Information used by tkXId.c only:
+ */
+
+ struct TkIdStack *idStackPtr;
+ /* First in list of chunks of free resource
+ * identifiers, or NULL if there are no free
+ * resources. */
+ XID (*defaultAllocProc) _ANSI_ARGS_((Display *display));
+ /* Default resource allocator for display. */
+ struct TkIdStack *windowStackPtr;
+ /* First in list of chunks of window
+ * identifers that can't be reused right
+ * now. */
+ Tcl_TimerToken idCleanupScheduled;
+ /* If set, it means a call to WindowIdCleanup
+ * has already been scheduled, 0 means it
+ * hasn't. */
+
+ /*
+ * Information used by tkUnixWm.c and tkWinWm.c only:
+ */
+
+ struct TkWmInfo *firstWmPtr; /* Points to first top-level window. */
+ struct TkWmInfo *foregroundWmPtr;
+ /* Points to the foreground window. */
+
+ /*
+ * Information maintained by tkWindow.c for use later on by tkXId.c:
+ */
+
+
+ int destroyCount; /* Number of Tk_DestroyWindow operations
+ * in progress. */
+ unsigned long lastDestroyRequest;
+ /* Id of most recent XDestroyWindow request;
+ * can re-use ids in windowStackPtr when
+ * server has seen this request and event
+ * queue is empty. */
+
+ /*
+ * Information used by tkVisual.c only:
+ */
+
+ TkColormap *cmapPtr; /* First in list of all non-default colormaps
+ * allocated for this display. */
+
+ /*
+ * Miscellaneous information:
+ */
+
+#ifdef TK_USE_INPUT_METHODS
+ XIM inputMethod; /* Input method for this display */
+#if TK_XIM_SPOT
+ XFontSet inputXfs; /* XFontSet cached for over-the-spot XIM. */
+#endif
+#endif /* TK_USE_INPUT_METHODS */
+ Tcl_HashTable winTable; /* Maps from X window ids to TkWindow ptrs. */
+
+ int refCount; /* Reference count of how many Tk applications
+ * are using this display. Used to clean up
+ * the display when we no longer have any
+ * Tk applications using it.
+ */
+ /*
+ * The following field were all added for Tk8.3
+ */
+ int mouseButtonState; /* current mouse button state for this
+ * display */
+ Window mouseButtonWindow; /* Window the button state was set in,
+ * added in Tk 8.4. */
+ Window warpWindow;
+ int warpX;
+ int warpY;
+
+ /*
+ * The following field(s) were all added for Tk8.4
+ */
+ unsigned int flags; /* Various flag values: these are all
+ * defined in below. */
+ TkCaret caret; /* information about the caret for this
+ * display. This is not a pointer. */
+ int iconDataSize; /* Size of default iconphoto image data */
+ unsigned char *iconDataPtr; /* Default iconphoto image data, if set */
+} TkDisplay;
+
+/*
+ * Flag values for TkDisplay flags.
+ * TK_DISPLAY_COLLAPSE_MOTION_EVENTS: (default on)
+ * Indicates that we should collapse motion events on this display
+ * TK_DISPLAY_USE_IM: (default on, set via tk.tcl)
+ * Whether to use input methods for this display
+ * TK_DISPLAY_XIM_SPOT: (default off)
+ * Indicates that we should use over-the-spot XIM on this display
+ * TK_DISPLAY_WM_TRACING: (default off)
+ * Whether we should do wm tracing on this display.
+ * TK_DISPLAY_IN_WARP: (default off)
+ * Indicates that we are in a pointer warp
+ */
+
+#define TK_DISPLAY_COLLAPSE_MOTION_EVENTS (1 << 0)
+#define TK_DISPLAY_USE_IM (1 << 1)
+#define TK_DISPLAY_XIM_SPOT (1 << 2)
+#define TK_DISPLAY_WM_TRACING (1 << 3)
+#define TK_DISPLAY_IN_WARP (1 << 4)
+
+/*
+ * One of the following structures exists for each error handler
+ * created by a call to Tk_CreateErrorHandler. The structure
+ * is managed by tkError.c.
+ */
+
+typedef struct TkErrorHandler {
+ TkDisplay *dispPtr; /* Display to which handler applies. */
+ unsigned long firstRequest; /* Only errors with serial numbers
+ * >= to this are considered. */
+ unsigned long lastRequest; /* Only errors with serial numbers
+ * <= to this are considered. This
+ * field is filled in when XUnhandle
+ * is called. -1 means XUnhandle
+ * hasn't been called yet. */
+ int error; /* Consider only errors with this
+ * error_code (-1 means consider
+ * all errors). */
+ int request; /* Consider only errors with this
+ * major request code (-1 means
+ * consider all major codes). */
+ int minorCode; /* Consider only errors with this
+ * minor request code (-1 means
+ * consider all minor codes). */
+ Tk_ErrorProc *errorProc; /* Procedure to invoke when a matching
+ * error occurs. NULL means just ignore
+ * errors. */
+ ClientData clientData; /* Arbitrary value to pass to
+ * errorProc. */
+ struct TkErrorHandler *nextPtr;
+ /* Pointer to next older handler for
+ * this display, or NULL for end of
+ * list. */
+} TkErrorHandler;
+
+
+/*
+ * One of the following structures exists for each event handler
+ * created by calling Tk_CreateEventHandler. This information
+ * is used by tkEvent.c only.
+ */
+
+typedef struct TkEventHandler {
+ unsigned long mask; /* Events for which to invoke
+ * proc. */
+ Tk_EventProc *proc; /* Procedure to invoke when an event
+ * in mask occurs. */
+ ClientData clientData; /* Argument to pass to proc. */
+ struct TkEventHandler *nextPtr;
+ /* Next in list of handlers
+ * associated with window (NULL means
+ * end of list). */
+} TkEventHandler;
+
+/*
+ * Tk keeps one of the following data structures for each main
+ * window (created by a call to TkCreateMainWindow). It stores
+ * information that is shared by all of the windows associated
+ * with a particular main window.
+ */
+
+typedef struct TkMainInfo {
+ int refCount; /* Number of windows whose "mainPtr" fields
+ * point here. When this becomes zero, can
+ * free up the structure (the reference
+ * count is zero because windows can get
+ * deleted in almost any order; the main
+ * window isn't necessarily the last one
+ * deleted). */
+ struct TkWindow *winPtr; /* Pointer to main window. */
+ Tcl_Interp *interp; /* Interpreter associated with application. */
+ Tcl_HashTable nameTable; /* Hash table mapping path names to TkWindow
+ * structs for all windows related to this
+ * main window. Managed by tkWindow.c. */
+ long deletionEpoch; /* Incremented by window deletions */
+ Tk_BindingTable bindingTable;
+ /* Used in conjunction with "bind" command
+ * to bind events to Tcl commands. */
+ TkBindInfo bindInfo; /* Information used by tkBind.c on a per
+ * application basis. */
+ struct TkFontInfo *fontInfoPtr;
+ /* Information used by tkFont.c on a per
+ * application basis. */
+
+ /*
+ * Information used only by tkFocus.c and tk*Embed.c:
+ */
+
+ struct TkToplevelFocusInfo *tlFocusPtr;
+ /* First in list of records containing focus
+ * information for each top-level in the
+ * application. Used only by tkFocus.c. */
+ struct TkDisplayFocusInfo *displayFocusPtr;
+ /* First in list of records containing focus
+ * information for each display that this
+ * application has ever used. Used only
+ * by tkFocus.c. */
+
+ struct ElArray *optionRootPtr;
+ /* Top level of option hierarchy for this
+ * main window. NULL means uninitialized.
+ * Managed by tkOption.c. */
+ Tcl_HashTable imageTable; /* Maps from image names to Tk_ImageMaster
+ * structures. Managed by tkImage.c. */
+ int strictMotif; /* This is linked to the tk_strictMotif
+ * global variable. */
+ struct TkMainInfo *nextPtr; /* Next in list of all main windows managed by
+ * this process. */
+} TkMainInfo;
+
+/*
+ * Tk keeps the following data structure for each of it's builtin
+ * bitmaps. This structure is only used by tkBitmap.c and other
+ * platform specific bitmap files.
+ */
+
+typedef struct {
+ CONST char *source; /* Bits for bitmap. */
+ int width, height; /* Dimensions of bitmap. */
+ int native; /* 0 means generic (X style) bitmap,
+ * 1 means native style bitmap. */
+} TkPredefBitmap;
+
+/*
+ * Tk keeps one of the following structures for each window.
+ * Some of the information (like size and location) is a shadow
+ * of information managed by the X server, and some is special
+ * information used here, such as event and geometry management
+ * information. This information is (mostly) managed by tkWindow.c.
+ * WARNING: the declaration below must be kept consistent with the
+ * Tk_FakeWin structure in tk.h. If you change one, be sure to
+ * change the other!!
+ */
+
+typedef struct TkWindow {
+
+ /*
+ * Structural information:
+ */
+
+ Display *display; /* Display containing window. */
+ TkDisplay *dispPtr; /* Tk's information about display
+ * for window. */
+ int screenNum; /* Index of screen for window, among all
+ * those for dispPtr. */
+ Visual *visual; /* Visual to use for window. If not default,
+ * MUST be set before X window is created. */
+ int depth; /* Number of bits/pixel. */
+ Window window; /* X's id for window. NULL means window
+ * hasn't actually been created yet, or it's
+ * been deleted. */
+ struct TkWindow *childList; /* First in list of child windows,
+ * or NULL if no children. List is in
+ * stacking order, lowest window first.*/
+ struct TkWindow *lastChildPtr;
+ /* Last in list of child windows (highest
+ * in stacking order), or NULL if no
+ * children. */
+ struct TkWindow *parentPtr; /* Pointer to parent window (logical
+ * parent, not necessarily X parent). NULL
+ * means either this is the main window, or
+ * the window's parent has already been
+ * deleted. */
+ struct TkWindow *nextPtr; /* Next higher sibling (in stacking order)
+ * in list of children with same parent. NULL
+ * means end of list. */
+ TkMainInfo *mainPtr; /* Information shared by all windows
+ * associated with a particular main
+ * window. NULL means this window is
+ * a rogue that isn't associated with
+ * any application (at present, this
+ * only happens for the dummy windows
+ * used for "send" communication). */
+
+ /*
+ * Name and type information for the window:
+ */
+
+ char *pathName; /* Path name of window (concatenation
+ * of all names between this window and
+ * its top-level ancestor). This is a
+ * pointer into an entry in
+ * mainPtr->nameTable. NULL means that
+ * the window hasn't been completely
+ * created yet. */
+ Tk_Uid nameUid; /* Name of the window within its parent
+ * (unique within the parent). */
+ Tk_Uid classUid; /* Class of the window. NULL means window
+ * hasn't been given a class yet. */
+
+ /*
+ * Geometry and other attributes of window. This information
+ * may not be updated on the server immediately; stuff that
+ * hasn't been reflected in the server yet is called "dirty".
+ * At present, information can be dirty only if the window
+ * hasn't yet been created.
+ */
+
+ XWindowChanges changes; /* Geometry and other info about
+ * window. */
+ unsigned int dirtyChanges; /* Bits indicate fields of "changes"
+ * that are dirty. */
+ XSetWindowAttributes atts; /* Current attributes of window. */
+ unsigned long dirtyAtts; /* Bits indicate fields of "atts"
+ * that are dirty. */
+
+ unsigned int flags; /* Various flag values: these are all
+ * defined in tk.h (confusing, but they're
+ * needed there for some query macros). */
+
+ /*
+ * Information kept by the event manager (tkEvent.c):
+ */
+
+ TkEventHandler *handlerList;/* First in list of event handlers
+ * declared for this window, or
+ * NULL if none. */
+#ifdef TK_USE_INPUT_METHODS
+ XIC inputContext; /* XIM input context. */
+#endif /* TK_USE_INPUT_METHODS */
+
+ /*
+ * Information used for event bindings (see "bind" and "bindtags"
+ * commands in tkCmds.c):
+ */
+
+ ClientData *tagPtr; /* Points to array of tags used for bindings
+ * on this window. Each tag is a Tk_Uid.
+ * Malloc'ed. NULL means no tags. */
+ int numTags; /* Number of tags at *tagPtr. */
+
+ /*
+ * Information used by tkOption.c to manage options for the
+ * window.
+ */
+
+ int optionLevel; /* -1 means no option information is
+ * currently cached for this window.
+ * Otherwise this gives the level in
+ * the option stack at which info is
+ * cached. */
+ /*
+ * Information used by tkSelect.c to manage the selection.
+ */
+
+ struct TkSelHandler *selHandlerList;
+ /* First in list of handlers for
+ * returning the selection in various
+ * forms. */
+
+ /*
+ * Information used by tkGeometry.c for geometry management.
+ */
+
+ Tk_GeomMgr *geomMgrPtr; /* Information about geometry manager for
+ * this window. */
+ ClientData geomData; /* Argument for geometry manager procedures. */
+ int reqWidth, reqHeight; /* Arguments from last call to
+ * Tk_GeometryRequest, or 0's if
+ * Tk_GeometryRequest hasn't been
+ * called. */
+ int internalBorderLeft; /* Width of internal border of window
+ * (0 means no internal border). Geometry
+ * managers should not normally place children
+ * on top of the border.
+ * Fields for the other three sides are found
+ * below. */
+
+ /*
+ * Information maintained by tkWm.c for window manager communication.
+ */
+
+ struct TkWmInfo *wmInfoPtr; /* For top-level windows (and also
+ * for special Unix menubar and wrapper
+ * windows), points to structure with
+ * wm-related info (see tkWm.c). For
+ * other windows, this is NULL. */
+
+ /*
+ * Information used by widget classes.
+ */
+
+ Tk_ClassProcs *classProcsPtr;
+ ClientData instanceData;
+
+ /*
+ * Platform specific information private to each port.
+ */
+
+ struct TkWindowPrivate *privatePtr;
+
+ /*
+ * More information used by tkGeometry.c for geometry management.
+ */
+
+ /* The remaining fields of internal border. */
+ int internalBorderRight;
+ int internalBorderTop;
+ int internalBorderBottom;
+
+ int minReqWidth; /* Minimum requested width. */
+ int minReqHeight; /* Minimum requested height. */
+} TkWindow;
+
+/*
+ * The following structure is used as a two way map between integers
+ * and strings, usually to map between an internal C representation
+ * and the strings used in Tcl.
+ */
+
+typedef struct TkStateMap {
+ int numKey; /* Integer representation of a value. */
+ char *strKey; /* String representation of a value. */
+} TkStateMap;
+
+/*
+ * This structure is used by the Mac and Window porting layers as
+ * the internal representation of a clip_mask in a GC.
+ */
+
+typedef struct TkpClipMask {
+ int type; /* One of TKP_CLIP_PIXMAP or TKP_CLIP_REGION */
+ union {
+ Pixmap pixmap;
+ TkRegion region;
+ } value;
+} TkpClipMask;
+
+#define TKP_CLIP_PIXMAP 0
+#define TKP_CLIP_REGION 1
+
+/*
+ * Pointer to first entry in list of all displays currently known.
+ */
+
+extern TkDisplay *tkDisplayList;
+
+/*
+ * Return values from TkGrabState:
+ */
+
+#define TK_GRAB_NONE 0
+#define TK_GRAB_IN_TREE 1
+#define TK_GRAB_ANCESTOR 2
+#define TK_GRAB_EXCLUDED 3
+
+/*
+ * The macro below is used to modify a "char" value (e.g. by casting
+ * it to an unsigned character) so that it can be used safely with
+ * macros such as isspace.
+ */
+
+#define UCHAR(c) ((unsigned char) (c))
+
+/*
+ * The following symbol is used in the mode field of FocusIn events
+ * generated by an embedded application to request the input focus from
+ * its container.
+ */
+
+#define EMBEDDED_APP_WANTS_FOCUS (NotifyNormal + 20)
+
+/*
+ * The following special modifier mask bits are defined, to indicate
+ * logical modifiers such as Meta and Alt that may float among the
+ * actual modifier bits.
+ */
+
+#define META_MASK (AnyModifier<<1)
+#define ALT_MASK (AnyModifier<<2)
+
+/*
+ * Object types not declared in tkObj.c need to be mentioned here so
+ * they can be properly registered with Tcl:
+ */
+
+extern Tcl_ObjType tkBorderObjType;
+extern Tcl_ObjType tkBitmapObjType;
+extern Tcl_ObjType tkColorObjType;
+extern Tcl_ObjType tkCursorObjType;
+extern Tcl_ObjType tkFontObjType;
+extern Tcl_ObjType tkOptionObjType;
+extern Tcl_ObjType tkStateKeyObjType;
+
+/*
+ * Miscellaneous variables shared among Tk modules but not exported
+ * to the outside world:
+ */
+typedef void TkDelayedEventProc _ANSI_ARGS_((void));
+typedef void tkHandleEventProc_t _ANSI_ARGS_((XEvent* eventPtr));
+
+extern Tk_SmoothMethod tkBezierSmoothMethod;
+extern Tk_ImageType tkBitmapImageType;
+extern Tk_PhotoImageFormat tkImgFmtGIF;
+extern void (*tkHandleEventProc) _ANSI_ARGS_((
+ XEvent* eventPtr));
+extern Tk_PhotoImageFormat tkImgFmtPPM;
+extern TkMainInfo *tkMainWindowList;
+extern Tk_ImageType tkPhotoImageType;
+extern Tcl_HashTable tkPredefBitmapTable;
+extern int tkSendSerial;
+
+#include "tkIntDecls.h"
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Internal procedures shared among Tk modules but not exported
+ * to the outside world:
+ */
+
+EXTERN int Tk_BellObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_BindObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_BindtagsObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ButtonObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_CanvasObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_CheckbuttonObjCmd _ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ClipboardObjCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ChooseColorObjCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ChooseDirectoryObjCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ChooseFontObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_DestroyObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_EntryObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_EventObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_FileeventCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_FrameObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_FocusObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_FontObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_GetOpenFileObjCmd _ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_GetSaveFileObjCmd _ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_GrabObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_GridObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ImageObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_LabelObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_LabelframeObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ListboxObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_LowerObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_MenubuttonObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_MessageBoxObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_MessageObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_PanedWindowObjCmd _ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_OptionObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_PackObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_PlaceObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_RadiobuttonObjCmd _ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_RaiseObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ScaleObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ScrollbarCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]));
+EXTERN int Tk_SelectionObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_SendCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_SendObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_SpinboxObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_TextCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int Tk_TkObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_TkwaitObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_ToplevelObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_UpdateObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_WinfoObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tk_WmObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+
+EXTERN void TkConsolePrint _ANSI_ARGS_((Tcl_Interp *interp,
+ int devId, CONST char *buffer, long size));
+
+EXTERN void TkEventInit _ANSI_ARGS_((void));
+
+EXTERN void TkRegisterObjTypes _ANSI_ARGS_((void));
+
+EXTERN int TkCreateMenuCmd _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int TkDeadAppCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+
+EXTERN int TkpTestembedCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkCanvasGetCoordObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Canvas canvas, Tcl_Obj *obj,
+ double *doublePtr));
+EXTERN int TkCanvasDashParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj * TkCanvasDashPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkGetDoublePixels _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, CONST char *string,
+ double *doublePtr));
+EXTERN int TkOffsetParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj * TkOffsetPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkOrientParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value,
+ char *widgRec, int offset));
+EXTERN Tcl_Obj * TkOrientPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkPixelParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj * TkPixelPrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkPostscriptImage _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, Tk_PostscriptInfo psInfo,
+ XImage *ximage, int x, int y, int width,
+ int height));
+EXTERN int TkSmoothParseProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tk_Window tkwin,
+ Tcl_Obj *value, char *recordPtr, int offset));
+EXTERN Tcl_Obj * TkSmoothPrintProc _ANSI_ARGS_((ClientData clientData,
+ Tk_Window tkwin, char *recordPtr, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkStateParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value,
+ char *widgRec, int offset));
+EXTERN Tcl_Obj * TkStatePrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int Tk_StateParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value,
+ char *widgRec, int offset));
+EXTERN Tcl_Obj * Tk_StatePrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+EXTERN int TkTileParseProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset));
+EXTERN Tcl_Obj * TkTilePrintProc _ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr));
+
+/*
+ * Unsupported commands.
+ */
+EXTERN int TkUnsupported1Cmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+
+/*
+ * Canvas-related procedures that are shared among Tk modules but not
+ * exported to the outside world:
+ */
+
+struct TkCanvas;
+extern int TkCanvPostscriptCmd _ANSI_ARGS_((struct TkCanvas *canvasPtr,
+ Tcl_Interp *interp, int argc, CONST84 Tcl_Obj *CONST *objv));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKINT */
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.m
new file mode 100755
index 00000000000..4713524528e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.m
@@ -0,0 +1,125 @@
+#ifndef _TKINT_VM
+#define _TKINT_VM
+#include "tkInt_f.h"
+#ifndef NO_VTABLES
+#define tkBitmapObjType (*TkintVptr->V_tkBitmapObjType)
+#define tkBorderObjType (*TkintVptr->V_tkBorderObjType)
+#define tkColorObjType (*TkintVptr->V_tkColorObjType)
+#define tkCursorObjType (*TkintVptr->V_tkCursorObjType)
+#define tkFontObjType (*TkintVptr->V_tkFontObjType)
+#define tkOptionObjType (*TkintVptr->V_tkOptionObjType)
+#define tkStateKeyObjType (*TkintVptr->V_tkStateKeyObjType)
+#ifndef TkCanvPostscriptCmd
+# define TkCanvPostscriptCmd (*TkintVptr->V_TkCanvPostscriptCmd)
+#endif
+
+#ifndef TkCreateMenuCmd
+# define TkCreateMenuCmd (*TkintVptr->V_TkCreateMenuCmd)
+#endif
+
+#ifndef TkEventInit
+# define TkEventInit (*TkintVptr->V_TkEventInit)
+#endif
+
+#ifndef TkGetDoublePixels
+# define TkGetDoublePixels (*TkintVptr->V_TkGetDoublePixels)
+#endif
+
+#ifndef TkOffsetParseProc
+# define TkOffsetParseProc (*TkintVptr->V_TkOffsetParseProc)
+#endif
+
+#ifndef TkOffsetPrintProc
+# define TkOffsetPrintProc (*TkintVptr->V_TkOffsetPrintProc)
+#endif
+
+#ifndef TkOrientParseProc
+# define TkOrientParseProc (*TkintVptr->V_TkOrientParseProc)
+#endif
+
+#ifndef TkOrientPrintProc
+# define TkOrientPrintProc (*TkintVptr->V_TkOrientPrintProc)
+#endif
+
+#ifndef TkPixelParseProc
+# define TkPixelParseProc (*TkintVptr->V_TkPixelParseProc)
+#endif
+
+#ifndef TkPixelPrintProc
+# define TkPixelPrintProc (*TkintVptr->V_TkPixelPrintProc)
+#endif
+
+#ifndef TkPostscriptImage
+# define TkPostscriptImage (*TkintVptr->V_TkPostscriptImage)
+#endif
+
+#ifndef TkRegisterObjTypes
+# define TkRegisterObjTypes (*TkintVptr->V_TkRegisterObjTypes)
+#endif
+
+#ifndef TkTileParseProc
+# define TkTileParseProc (*TkintVptr->V_TkTileParseProc)
+#endif
+
+#ifndef TkTilePrintProc
+# define TkTilePrintProc (*TkintVptr->V_TkTilePrintProc)
+#endif
+
+#ifndef Tk_BindObjCmd
+# define Tk_BindObjCmd (*TkintVptr->V_Tk_BindObjCmd)
+#endif
+
+#ifndef Tk_BindtagsObjCmd
+# define Tk_BindtagsObjCmd (*TkintVptr->V_Tk_BindtagsObjCmd)
+#endif
+
+#ifndef Tk_ClipboardObjCmd
+# define Tk_ClipboardObjCmd (*TkintVptr->V_Tk_ClipboardObjCmd)
+#endif
+
+#ifndef Tk_GrabObjCmd
+# define Tk_GrabObjCmd (*TkintVptr->V_Tk_GrabObjCmd)
+#endif
+
+#ifndef Tk_GridObjCmd
+# define Tk_GridObjCmd (*TkintVptr->V_Tk_GridObjCmd)
+#endif
+
+#ifndef Tk_LabelframeObjCmd
+# define Tk_LabelframeObjCmd (*TkintVptr->V_Tk_LabelframeObjCmd)
+#endif
+
+#ifndef Tk_PackObjCmd
+# define Tk_PackObjCmd (*TkintVptr->V_Tk_PackObjCmd)
+#endif
+
+#ifndef Tk_PanedWindowObjCmd
+# define Tk_PanedWindowObjCmd (*TkintVptr->V_Tk_PanedWindowObjCmd)
+#endif
+
+#ifndef Tk_PlaceObjCmd
+# define Tk_PlaceObjCmd (*TkintVptr->V_Tk_PlaceObjCmd)
+#endif
+
+#ifndef Tk_SelectionObjCmd
+# define Tk_SelectionObjCmd (*TkintVptr->V_Tk_SelectionObjCmd)
+#endif
+
+#ifndef Tk_StateParseProc
+# define Tk_StateParseProc (*TkintVptr->V_Tk_StateParseProc)
+#endif
+
+#ifndef Tk_StatePrintProc
+# define Tk_StatePrintProc (*TkintVptr->V_Tk_StatePrintProc)
+#endif
+
+#ifndef Tk_TkwaitObjCmd
+# define Tk_TkwaitObjCmd (*TkintVptr->V_Tk_TkwaitObjCmd)
+#endif
+
+#ifndef Tk_WmObjCmd
+# define Tk_WmObjCmd (*TkintVptr->V_Tk_WmObjCmd)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKINT_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.t
new file mode 100755
index 00000000000..6e2c9d44089
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt.t
@@ -0,0 +1,182 @@
+#ifdef _TKINT
+VVAR(Tcl_ObjType,tkBitmapObjType,V_tkBitmapObjType)
+VVAR(Tcl_ObjType,tkBorderObjType,V_tkBorderObjType)
+VVAR(Tcl_ObjType,tkColorObjType,V_tkColorObjType)
+VVAR(Tcl_ObjType,tkCursorObjType,V_tkCursorObjType)
+VVAR(Tcl_ObjType,tkFontObjType,V_tkFontObjType)
+VVAR(Tcl_ObjType,tkOptionObjType,V_tkOptionObjType)
+VVAR(Tcl_ObjType,tkStateKeyObjType,V_tkStateKeyObjType)
+#ifndef TkCanvPostscriptCmd
+VFUNC(int,TkCanvPostscriptCmd,V_TkCanvPostscriptCmd,_ANSI_ARGS_((struct TkCanvas *canvasPtr,
+ Tcl_Interp *interp, int argc, CONST84 Tcl_Obj *CONST *objv)))
+#endif /* #ifndef TkCanvPostscriptCmd */
+
+#ifndef TkCreateMenuCmd
+VFUNC(int,TkCreateMenuCmd,V_TkCreateMenuCmd,_ANSI_ARGS_((Tcl_Interp *interp)))
+#endif /* #ifndef TkCreateMenuCmd */
+
+#ifndef TkEventInit
+VFUNC(void,TkEventInit,V_TkEventInit,_ANSI_ARGS_((void)))
+#endif /* #ifndef TkEventInit */
+
+#ifndef TkGetDoublePixels
+VFUNC(int,TkGetDoublePixels,V_TkGetDoublePixels,_ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, CONST char *string,
+ double *doublePtr)))
+#endif /* #ifndef TkGetDoublePixels */
+
+#ifndef TkOffsetParseProc
+VFUNC(int,TkOffsetParseProc,V_TkOffsetParseProc,_ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset)))
+#endif /* #ifndef TkOffsetParseProc */
+
+#ifndef TkOffsetPrintProc
+VFUNC(Tcl_Obj *,TkOffsetPrintProc,V_TkOffsetPrintProc,_ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr)))
+#endif /* #ifndef TkOffsetPrintProc */
+
+#ifndef TkOrientParseProc
+VFUNC(int,TkOrientParseProc,V_TkOrientParseProc,_ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value,
+ char *widgRec, int offset)))
+#endif /* #ifndef TkOrientParseProc */
+
+#ifndef TkOrientPrintProc
+VFUNC(Tcl_Obj *,TkOrientPrintProc,V_TkOrientPrintProc,_ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr)))
+#endif /* #ifndef TkOrientPrintProc */
+
+#ifndef TkPixelParseProc
+VFUNC(int,TkPixelParseProc,V_TkPixelParseProc,_ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset)))
+#endif /* #ifndef TkPixelParseProc */
+
+#ifndef TkPixelPrintProc
+VFUNC(Tcl_Obj *,TkPixelPrintProc,V_TkPixelPrintProc,_ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr)))
+#endif /* #ifndef TkPixelPrintProc */
+
+#ifndef TkPostscriptImage
+VFUNC(int,TkPostscriptImage,V_TkPostscriptImage,_ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, Tk_PostscriptInfo psInfo,
+ XImage *ximage, int x, int y, int width,
+ int height)))
+#endif /* #ifndef TkPostscriptImage */
+
+#ifndef TkRegisterObjTypes
+VFUNC(void,TkRegisterObjTypes,V_TkRegisterObjTypes,_ANSI_ARGS_((void)))
+#endif /* #ifndef TkRegisterObjTypes */
+
+#ifndef TkTileParseProc
+VFUNC(int,TkTileParseProc,V_TkTileParseProc,_ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value, char *widgRec,
+ int offset)))
+#endif /* #ifndef TkTileParseProc */
+
+#ifndef TkTilePrintProc
+VFUNC(Tcl_Obj *,TkTilePrintProc,V_TkTilePrintProc,_ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr)))
+#endif /* #ifndef TkTilePrintProc */
+
+#ifndef Tk_BindObjCmd
+VFUNC(int,Tk_BindObjCmd,V_Tk_BindObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_BindObjCmd */
+
+#ifndef Tk_BindtagsObjCmd
+VFUNC(int,Tk_BindtagsObjCmd,V_Tk_BindtagsObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_BindtagsObjCmd */
+
+#ifndef Tk_ClipboardObjCmd
+VFUNC(int,Tk_ClipboardObjCmd,V_Tk_ClipboardObjCmd,_ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_ClipboardObjCmd */
+
+#ifndef Tk_GrabObjCmd
+VFUNC(int,Tk_GrabObjCmd,V_Tk_GrabObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_GrabObjCmd */
+
+#ifndef Tk_GridObjCmd
+VFUNC(int,Tk_GridObjCmd,V_Tk_GridObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_GridObjCmd */
+
+#ifndef Tk_LabelframeObjCmd
+VFUNC(int,Tk_LabelframeObjCmd,V_Tk_LabelframeObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_LabelframeObjCmd */
+
+#ifndef Tk_PackObjCmd
+VFUNC(int,Tk_PackObjCmd,V_Tk_PackObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_PackObjCmd */
+
+#ifndef Tk_PanedWindowObjCmd
+VFUNC(int,Tk_PanedWindowObjCmd,V_Tk_PanedWindowObjCmd,_ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_PanedWindowObjCmd */
+
+#ifndef Tk_PlaceObjCmd
+VFUNC(int,Tk_PlaceObjCmd,V_Tk_PlaceObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_PlaceObjCmd */
+
+#ifndef Tk_SelectionObjCmd
+VFUNC(int,Tk_SelectionObjCmd,V_Tk_SelectionObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_SelectionObjCmd */
+
+#ifndef Tk_StateParseProc
+VFUNC(int,Tk_StateParseProc,V_Tk_StateParseProc,_ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *value,
+ char *widgRec, int offset)))
+#endif /* #ifndef Tk_StateParseProc */
+
+#ifndef Tk_StatePrintProc
+VFUNC(Tcl_Obj *,Tk_StatePrintProc,V_Tk_StatePrintProc,_ANSI_ARGS_((
+ ClientData clientData, Tk_Window tkwin,
+ char *widgRec, int offset,
+ Tcl_FreeProc **freeProcPtr)))
+#endif /* #ifndef Tk_StatePrintProc */
+
+#ifndef Tk_TkwaitObjCmd
+VFUNC(int,Tk_TkwaitObjCmd,V_Tk_TkwaitObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_TkwaitObjCmd */
+
+#ifndef Tk_WmObjCmd
+VFUNC(int,Tk_WmObjCmd,V_Tk_WmObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[])))
+#endif /* #ifndef Tk_WmObjCmd */
+
+#endif /* _TKINT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.h
new file mode 100755
index 00000000000..4116b2174f1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.h
@@ -0,0 +1,1572 @@
+/*
+ * tkIntDecls.h --
+ *
+ * This file contains the declarations for all unsupported
+ * functions that are exported by the Tk library. These
+ * interfaces are not guaranteed to remain the same between
+ * versions. Use at your own risk.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkIntDecls.h,v 1.22.2.1 2003/10/13 03:30:05 hobbs Exp $
+ */
+
+#ifndef _TKINTDECLS
+#define _TKINTDECLS
+
+#ifdef BUILD_tk
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tkInt.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+/* 0 */
+EXTERN TkWindow * TkAllocWindow _ANSI_ARGS_((TkDisplay * dispPtr,
+ int screenNum, TkWindow * parentPtr));
+/* 1 */
+EXTERN void TkBezierPoints _ANSI_ARGS_((double control[],
+ int numSteps, double * coordPtr));
+/* 2 */
+EXTERN void TkBezierScreenPoints _ANSI_ARGS_((Tk_Canvas canvas,
+ double control[], int numSteps,
+ XPoint * xPointPtr));
+/* 3 */
+EXTERN void TkBindDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 4 */
+EXTERN void TkBindEventProc _ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr));
+/* 5 */
+EXTERN void TkBindFree _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 6 */
+EXTERN void TkBindInit _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 7 */
+EXTERN void TkChangeEventWindow _ANSI_ARGS_((XEvent * eventPtr,
+ TkWindow * winPtr));
+/* 8 */
+EXTERN int TkClipInit _ANSI_ARGS_((Tcl_Interp * interp,
+ TkDisplay * dispPtr));
+/* 9 */
+EXTERN void TkComputeAnchor _ANSI_ARGS_((Tk_Anchor anchor,
+ Tk_Window tkwin, int padX, int padY,
+ int innerWidth, int innerHeight, int * xPtr,
+ int * yPtr));
+/* 10 */
+EXTERN int TkCopyAndGlobalEval _ANSI_ARGS_((Tcl_Interp * interp,
+ char * script));
+/* 11 */
+EXTERN unsigned long TkCreateBindingProcedure _ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventString,
+ TkBindEvalProc * evalProc,
+ TkBindFreeProc * freeProc,
+ ClientData clientData));
+/* 12 */
+EXTERN TkCursor * TkCreateCursorFromData _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * source, CONST char * mask,
+ int width, int height, int xHot, int yHot,
+ XColor fg, XColor bg));
+/* 13 */
+EXTERN int TkCreateFrame _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv,
+ int toplevel, char * appName));
+/* 14 */
+EXTERN Tk_Window TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * screenName, char * baseName));
+/* 15 */
+EXTERN Time TkCurrentTime _ANSI_ARGS_((TkDisplay * dispPtr,
+ int fallbackCurrent));
+/* 16 */
+EXTERN void TkDeleteAllImages _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 17 */
+EXTERN void TkDoConfigureNotify _ANSI_ARGS_((TkWindow * winPtr));
+/* 18 */
+EXTERN void TkDrawInsetFocusHighlight _ANSI_ARGS_((
+ Tk_Window tkwin, GC gc, int width,
+ Drawable drawable, int padding));
+/* 19 */
+EXTERN void TkEventDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 20 */
+EXTERN void TkFillPolygon _ANSI_ARGS_((Tk_Canvas canvas,
+ double * coordPtr, int numPoints,
+ Display * display, Drawable drawable, GC gc,
+ GC outlineGC));
+/* 21 */
+EXTERN int TkFindStateNum _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * option,
+ CONST TkStateMap * mapPtr,
+ CONST char * strKey));
+/* 22 */
+EXTERN char * TkFindStateString _ANSI_ARGS_((
+ CONST TkStateMap * mapPtr, int numKey));
+/* 23 */
+EXTERN void TkFocusDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 24 */
+EXTERN int TkFocusFilterEvent _ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr));
+/* 25 */
+EXTERN TkWindow * TkFocusKeyEvent _ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr));
+/* 26 */
+EXTERN void TkFontPkgInit _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 27 */
+EXTERN void TkFontPkgFree _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 28 */
+EXTERN void TkFreeBindingTags _ANSI_ARGS_((TkWindow * winPtr));
+/* 29 */
+EXTERN void TkpFreeCursor _ANSI_ARGS_((TkCursor * cursorPtr));
+/* 30 */
+EXTERN char * TkGetBitmapData _ANSI_ARGS_((Tcl_Interp * interp,
+ char * string, char * fileName,
+ int * widthPtr, int * heightPtr,
+ int * hotXPtr, int * hotYPtr));
+/* 31 */
+EXTERN void TkGetButtPoints _ANSI_ARGS_((double p1[],
+ double p2[], double width, int project,
+ double m1[], double m2[]));
+/* 32 */
+EXTERN TkCursor * TkGetCursorByName _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid string));
+/* 33 */
+EXTERN CONST84_RETURN char * TkGetDefaultScreenName _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * screenName));
+/* 34 */
+EXTERN TkDisplay * TkGetDisplay _ANSI_ARGS_((Display * display));
+/* 35 */
+EXTERN int TkGetDisplayOf _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[],
+ Tk_Window * tkwinPtr));
+/* 36 */
+EXTERN TkWindow * TkGetFocusWin _ANSI_ARGS_((TkWindow * winPtr));
+/* 37 */
+EXTERN int TkGetInterpNames _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin));
+/* 38 */
+EXTERN int TkGetMiterPoints _ANSI_ARGS_((double p1[],
+ double p2[], double p3[], double width,
+ double m1[], double m2[]));
+/* 39 */
+EXTERN void TkGetPointerCoords _ANSI_ARGS_((Tk_Window tkwin,
+ int * xPtr, int * yPtr));
+/* 40 */
+EXTERN void TkGetServerInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin));
+/* 41 */
+EXTERN void TkGrabDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 42 */
+EXTERN int TkGrabState _ANSI_ARGS_((TkWindow * winPtr));
+/* 43 */
+EXTERN void TkIncludePoint _ANSI_ARGS_((Tk_Item * itemPtr,
+ double * pointPtr));
+/* 44 */
+EXTERN void TkInOutEvents _ANSI_ARGS_((XEvent * eventPtr,
+ TkWindow * sourcePtr, TkWindow * destPtr,
+ int leaveType, int enterType,
+ Tcl_QueuePosition position));
+/* 45 */
+EXTERN void TkInstallFrameMenu _ANSI_ARGS_((Tk_Window tkwin));
+/* 46 */
+EXTERN char * TkKeysymToString _ANSI_ARGS_((KeySym keysym));
+/* 47 */
+EXTERN int TkLineToArea _ANSI_ARGS_((double end1Ptr[],
+ double end2Ptr[], double rectPtr[]));
+/* 48 */
+EXTERN double TkLineToPoint _ANSI_ARGS_((double end1Ptr[],
+ double end2Ptr[], double pointPtr[]));
+/* 49 */
+EXTERN int TkMakeBezierCurve _ANSI_ARGS_((Tk_Canvas canvas,
+ double * pointPtr, int numPoints,
+ int numSteps, XPoint xPoints[],
+ double dblPoints[]));
+/* 50 */
+EXTERN void TkMakeBezierPostscript _ANSI_ARGS_((
+ Tcl_Interp * interp, Tk_Canvas canvas,
+ double * pointPtr, int numPoints));
+/* 51 */
+#ifndef TkOptionClassChanged
+EXTERN void TkOptionClassChanged _ANSI_ARGS_((TkWindow * winPtr));
+#endif
+/* 52 */
+#ifndef TkOptionDeadWindow
+EXTERN void TkOptionDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+#endif
+/* 53 */
+EXTERN int TkOvalToArea _ANSI_ARGS_((double * ovalPtr,
+ double * rectPtr));
+/* 54 */
+EXTERN double TkOvalToPoint _ANSI_ARGS_((double ovalPtr[],
+ double width, int filled, double pointPtr[]));
+/* 55 */
+EXTERN int TkpChangeFocus _ANSI_ARGS_((TkWindow * winPtr,
+ int force));
+/* 56 */
+EXTERN void TkpCloseDisplay _ANSI_ARGS_((TkDisplay * dispPtr));
+/* 57 */
+EXTERN void TkpClaimFocus _ANSI_ARGS_((TkWindow * topLevelPtr,
+ int force));
+/* 58 */
+EXTERN void TkpDisplayWarning _ANSI_ARGS_((CONST char * msg,
+ CONST char * title));
+/* 59 */
+EXTERN void TkpGetAppName _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_DString * name));
+/* 60 */
+EXTERN TkWindow * TkpGetOtherWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 61 */
+EXTERN TkWindow * TkpGetWrapperWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 62 */
+EXTERN int TkpInit _ANSI_ARGS_((Tcl_Interp * interp));
+/* 63 */
+EXTERN void TkpInitializeMenuBindings _ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tk_BindingTable bindingTable));
+/* 64 */
+EXTERN void TkpMakeContainer _ANSI_ARGS_((Tk_Window tkwin));
+/* 65 */
+EXTERN void TkpMakeMenuWindow _ANSI_ARGS_((Tk_Window tkwin,
+ int transient));
+/* 66 */
+EXTERN Window TkpMakeWindow _ANSI_ARGS_((TkWindow * winPtr,
+ Window parent));
+/* 67 */
+EXTERN void TkpMenuNotifyToplevelCreate _ANSI_ARGS_((
+ Tcl_Interp * interp1, char * menuName));
+/* 68 */
+EXTERN TkDisplay * TkpOpenDisplay _ANSI_ARGS_((
+ CONST char * display_name));
+/* 69 */
+EXTERN int TkPointerEvent _ANSI_ARGS_((XEvent * eventPtr,
+ TkWindow * winPtr));
+/* 70 */
+EXTERN int TkPolygonToArea _ANSI_ARGS_((double * polyPtr,
+ int numPoints, double * rectPtr));
+/* 71 */
+EXTERN double TkPolygonToPoint _ANSI_ARGS_((double * polyPtr,
+ int numPoints, double * pointPtr));
+/* 72 */
+EXTERN int TkPositionInTree _ANSI_ARGS_((TkWindow * winPtr,
+ TkWindow * treePtr));
+/* 73 */
+EXTERN void TkpRedirectKeyEvent _ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr));
+/* 74 */
+EXTERN void TkpSetMainMenubar _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, char * menuName));
+/* 75 */
+EXTERN int TkpUseWindow _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj *string));
+/* 76 */
+EXTERN int TkpWindowWasRecentlyDeleted _ANSI_ARGS_((Window win,
+ TkDisplay * dispPtr));
+/* 77 */
+EXTERN void TkQueueEventForAllChildren _ANSI_ARGS_((
+ TkWindow * winPtr, XEvent * eventPtr));
+/* 78 */
+EXTERN int TkReadBitmapFile _ANSI_ARGS_((Tcl_Interp * interp,
+ Display* display,
+ Drawable d, CONST char* filename,
+ unsigned int* width_return,
+ unsigned int* height_return,
+ Pixmap* bitmap_return, int* x_hot_return,
+ int* y_hot_return));
+/* 79 */
+EXTERN int TkScrollWindow _ANSI_ARGS_((Tk_Window tkwin, GC gc,
+ int x, int y, int width, int height, int dx,
+ int dy, TkRegion damageRgn));
+/* 80 */
+EXTERN void TkSelDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 81 */
+EXTERN void TkSelEventProc _ANSI_ARGS_((Tk_Window tkwin,
+ XEvent * eventPtr));
+/* 82 */
+EXTERN void TkSelInit _ANSI_ARGS_((Tk_Window tkwin));
+/* 83 */
+EXTERN void TkSelPropProc _ANSI_ARGS_((XEvent * eventPtr));
+/* Slot 84 is reserved */
+/* 85 */
+EXTERN void TkSetWindowMenuBar _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj *oldMenuName,
+ Tcl_Obj *menuName));
+/* 86 */
+EXTERN KeySym TkStringToKeysym _ANSI_ARGS_((char * name));
+/* 87 */
+EXTERN int TkThickPolyLineToArea _ANSI_ARGS_((double * coordPtr,
+ int numPoints, double width, int capStyle,
+ int joinStyle, double * rectPtr));
+/* 88 */
+EXTERN void TkWmAddToColormapWindows _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 89 */
+EXTERN void TkWmDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 90 */
+EXTERN TkWindow * TkWmFocusToplevel _ANSI_ARGS_((TkWindow * winPtr));
+/* 91 */
+EXTERN void TkWmMapWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 92 */
+EXTERN void TkWmNewWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 93 */
+EXTERN void TkWmProtocolEventProc _ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * evenvPtr));
+/* 94 */
+EXTERN void TkWmRemoveFromColormapWindows _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 95 */
+EXTERN void TkWmRestackToplevel _ANSI_ARGS_((TkWindow * winPtr,
+ int aboveBelow, TkWindow * otherPtr));
+/* 96 */
+EXTERN void TkWmSetClass _ANSI_ARGS_((TkWindow * winPtr));
+/* 97 */
+EXTERN void TkWmUnmapWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 98 */
+EXTERN Tcl_Obj * TkDebugBitmap _ANSI_ARGS_((Tk_Window tkwin,
+ char * name));
+/* 99 */
+EXTERN Tcl_Obj * TkDebugBorder _ANSI_ARGS_((Tk_Window tkwin,
+ char * name));
+/* 100 */
+EXTERN Tcl_Obj * TkDebugCursor _ANSI_ARGS_((Tk_Window tkwin,
+ char * name));
+/* 101 */
+EXTERN Tcl_Obj * TkDebugColor _ANSI_ARGS_((Tk_Window tkwin,
+ char * name));
+/* 102 */
+EXTERN Tcl_Obj * TkDebugConfig _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_OptionTable table));
+/* 103 */
+EXTERN Tcl_Obj * TkDebugFont _ANSI_ARGS_((Tk_Window tkwin,
+ char * name));
+/* 104 */
+EXTERN int TkFindStateNumObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * optionPtr,
+ CONST TkStateMap * mapPtr, Tcl_Obj * keyPtr));
+/* 105 */
+EXTERN Tcl_HashTable * TkGetBitmapPredefTable _ANSI_ARGS_((void));
+/* 106 */
+EXTERN TkDisplay * TkGetDisplayList _ANSI_ARGS_((void));
+/* 107 */
+EXTERN TkMainInfo * TkGetMainInfoList _ANSI_ARGS_((void));
+/* 108 */
+EXTERN int TkGetWindowFromObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr,
+ Tk_Window * windowPtr));
+/* 109 */
+EXTERN char * TkpGetString _ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr, Tcl_DString * dsPtr));
+/* 110 */
+EXTERN void TkpGetSubFonts _ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Font tkfont));
+/* 111 */
+EXTERN Tcl_Obj * TkpGetSystemDefault _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * dbName, CONST char * className));
+/* 112 */
+EXTERN void TkpMenuThreadInit _ANSI_ARGS_((void));
+#ifdef __WIN32__
+/* 113 */
+EXTERN void TkClipBox _ANSI_ARGS_((TkRegion rgn,
+ XRectangle* rect_return));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 113 */
+EXTERN void TkClipBox _ANSI_ARGS_((TkRegion rgn,
+ XRectangle* rect_return));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 113 */
+EXTERN void TkClipBox _ANSI_ARGS_((TkRegion rgn,
+ XRectangle* rect_return));
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+/* 114 */
+EXTERN TkRegion TkCreateRegion _ANSI_ARGS_((void));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 114 */
+EXTERN TkRegion TkCreateRegion _ANSI_ARGS_((void));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 114 */
+EXTERN TkRegion TkCreateRegion _ANSI_ARGS_((void));
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+/* 115 */
+EXTERN void TkDestroyRegion _ANSI_ARGS_((TkRegion rgn));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 115 */
+EXTERN void TkDestroyRegion _ANSI_ARGS_((TkRegion rgn));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 115 */
+EXTERN void TkDestroyRegion _ANSI_ARGS_((TkRegion rgn));
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+/* 116 */
+EXTERN void TkIntersectRegion _ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 116 */
+EXTERN void TkIntersectRegion _ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 116 */
+EXTERN void TkIntersectRegion _ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return));
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+/* 117 */
+EXTERN int TkRectInRegion _ANSI_ARGS_((TkRegion rgn, int x,
+ int y, unsigned int width,
+ unsigned int height));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 117 */
+EXTERN int TkRectInRegion _ANSI_ARGS_((TkRegion rgn, int x,
+ int y, unsigned int width,
+ unsigned int height));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 117 */
+EXTERN int TkRectInRegion _ANSI_ARGS_((TkRegion rgn, int x,
+ int y, unsigned int width,
+ unsigned int height));
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+/* 118 */
+EXTERN void TkSetRegion _ANSI_ARGS_((Display* display, GC gc,
+ TkRegion rgn));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 118 */
+EXTERN void TkSetRegion _ANSI_ARGS_((Display* display, GC gc,
+ TkRegion rgn));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 118 */
+EXTERN void TkSetRegion _ANSI_ARGS_((Display* display, GC gc,
+ TkRegion rgn));
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+/* 119 */
+EXTERN void TkUnionRectWithRegion _ANSI_ARGS_((XRectangle* rect,
+ TkRegion src, TkRegion dr_return));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 119 */
+EXTERN void TkUnionRectWithRegion _ANSI_ARGS_((XRectangle* rect,
+ TkRegion src, TkRegion dr_return));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 119 */
+EXTERN void TkUnionRectWithRegion _ANSI_ARGS_((XRectangle* rect,
+ TkRegion src, TkRegion dr_return));
+#endif /* MAC_OSX_TK */
+/* Slot 120 is reserved */
+#ifdef MAC_TCL
+/* 121 */
+EXTERN Pixmap TkpCreateNativeBitmap _ANSI_ARGS_((Display * display,
+ CONST char * source));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 121 */
+EXTERN Pixmap TkpCreateNativeBitmap _ANSI_ARGS_((Display * display,
+ CONST char * source));
+#endif /* MAC_OSX_TK */
+#ifdef MAC_TCL
+/* 122 */
+EXTERN void TkpDefineNativeBitmaps _ANSI_ARGS_((void));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 122 */
+EXTERN void TkpDefineNativeBitmaps _ANSI_ARGS_((void));
+#endif /* MAC_OSX_TK */
+/* Slot 123 is reserved */
+#ifdef MAC_TCL
+/* 124 */
+EXTERN Pixmap TkpGetNativeAppBitmap _ANSI_ARGS_((Display * display,
+ CONST char * name, int * width, int * height));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 124 */
+EXTERN Pixmap TkpGetNativeAppBitmap _ANSI_ARGS_((Display * display,
+ CONST char * name, int * width, int * height));
+#endif /* MAC_OSX_TK */
+/* Slot 125 is reserved */
+/* Slot 126 is reserved */
+/* Slot 127 is reserved */
+/* Slot 128 is reserved */
+/* Slot 129 is reserved */
+/* Slot 130 is reserved */
+/* Slot 131 is reserved */
+/* Slot 132 is reserved */
+/* Slot 133 is reserved */
+/* Slot 134 is reserved */
+/* 135 */
+EXTERN void TkpDrawHighlightBorder _ANSI_ARGS_((Tk_Window tkwin,
+ GC fgGC, GC bgGC, int highlightWidth,
+ Drawable drawable));
+/* 136 */
+EXTERN void TkSetFocusWin _ANSI_ARGS_((TkWindow * winPtr,
+ int force));
+/* 137 */
+EXTERN void TkpSetKeycodeAndState _ANSI_ARGS_((Tk_Window tkwin,
+ KeySym keySym, XEvent * eventPtr));
+/* 138 */
+EXTERN KeySym TkpGetKeySym _ANSI_ARGS_((TkDisplay * dispPtr,
+ XEvent * eventPtr));
+/* 139 */
+EXTERN void TkpInitKeymapInfo _ANSI_ARGS_((TkDisplay * dispPtr));
+/* 140 */
+EXTERN TkRegion TkPhotoGetValidRegion _ANSI_ARGS_((
+ Tk_PhotoHandle handle));
+/* 141 */
+EXTERN TkWindow ** TkWmStackorderToplevel _ANSI_ARGS_((
+ TkWindow * parentPtr));
+/* 142 */
+EXTERN void TkFocusFree _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 143 */
+EXTERN void TkClipCleanup _ANSI_ARGS_((TkDisplay * dispPtr));
+/* 144 */
+EXTERN void TkGCCleanup _ANSI_ARGS_((TkDisplay * dispPtr));
+#ifdef __WIN32__
+/* 145 */
+EXTERN void TkSubtractRegion _ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 145 */
+EXTERN void TkSubtractRegion _ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 145 */
+EXTERN void TkSubtractRegion _ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return));
+#endif /* MAC_OSX_TK */
+/* 146 */
+EXTERN void TkStylePkgInit _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 147 */
+EXTERN void TkStylePkgFree _ANSI_ARGS_((TkMainInfo * mainPtr));
+/* 148 */
+EXTERN Tk_Window TkToplevelWindowForCommand _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * cmdName));
+/* 149 */
+EXTERN CONST Tk_OptionSpec * TkGetOptionSpec _ANSI_ARGS_((CONST char * name,
+ Tk_OptionTable optionTable));
+
+typedef struct TkIntStubs {
+ int magic;
+ struct TkIntStubHooks *hooks;
+
+ TkWindow * (*tkAllocWindow) _ANSI_ARGS_((TkDisplay * dispPtr, int screenNum, TkWindow * parentPtr)); /* 0 */
+ void (*tkBezierPoints) _ANSI_ARGS_((double control[], int numSteps, double * coordPtr)); /* 1 */
+ void (*tkBezierScreenPoints) _ANSI_ARGS_((Tk_Canvas canvas, double control[], int numSteps, XPoint * xPointPtr)); /* 2 */
+ void (*tkBindDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 3 */
+ void (*tkBindEventProc) _ANSI_ARGS_((TkWindow * winPtr, XEvent * eventPtr)); /* 4 */
+ void (*tkBindFree) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 5 */
+ void (*tkBindInit) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 6 */
+ void (*tkChangeEventWindow) _ANSI_ARGS_((XEvent * eventPtr, TkWindow * winPtr)); /* 7 */
+ int (*tkClipInit) _ANSI_ARGS_((Tcl_Interp * interp, TkDisplay * dispPtr)); /* 8 */
+ void (*tkComputeAnchor) _ANSI_ARGS_((Tk_Anchor anchor, Tk_Window tkwin, int padX, int padY, int innerWidth, int innerHeight, int * xPtr, int * yPtr)); /* 9 */
+ int (*tkCopyAndGlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, char * script)); /* 10 */
+ unsigned long (*tkCreateBindingProcedure) _ANSI_ARGS_((Tcl_Interp * interp, Tk_BindingTable bindingTable, ClientData object, CONST char * eventString, TkBindEvalProc * evalProc, TkBindFreeProc * freeProc, ClientData clientData)); /* 11 */
+ TkCursor * (*tkCreateCursorFromData) _ANSI_ARGS_((Tk_Window tkwin, CONST char * source, CONST char * mask, int width, int height, int xHot, int yHot, XColor fg, XColor bg)); /* 12 */
+ int (*tkCreateFrame) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv, int toplevel, char * appName)); /* 13 */
+ Tk_Window (*tkCreateMainWindow) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * screenName, char * baseName)); /* 14 */
+ Time (*tkCurrentTime) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 15 */
+ void (*tkDeleteAllImages) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 16 */
+ void (*tkDoConfigureNotify) _ANSI_ARGS_((TkWindow * winPtr)); /* 17 */
+ void (*tkDrawInsetFocusHighlight) _ANSI_ARGS_((Tk_Window tkwin, GC gc, int width, Drawable drawable, int padding)); /* 18 */
+ void (*tkEventDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 19 */
+ void (*tkFillPolygon) _ANSI_ARGS_((Tk_Canvas canvas, double * coordPtr, int numPoints, Display * display, Drawable drawable, GC gc, GC outlineGC)); /* 20 */
+ int (*tkFindStateNum) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * option, CONST TkStateMap * mapPtr, CONST char * strKey)); /* 21 */
+ char * (*tkFindStateString) _ANSI_ARGS_((CONST TkStateMap * mapPtr, int numKey)); /* 22 */
+ void (*tkFocusDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 23 */
+ int (*tkFocusFilterEvent) _ANSI_ARGS_((TkWindow * winPtr, XEvent * eventPtr)); /* 24 */
+ TkWindow * (*tkFocusKeyEvent) _ANSI_ARGS_((TkWindow * winPtr, XEvent * eventPtr)); /* 25 */
+ void (*tkFontPkgInit) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 26 */
+ void (*tkFontPkgFree) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 27 */
+ void (*tkFreeBindingTags) _ANSI_ARGS_((TkWindow * winPtr)); /* 28 */
+ void (*tkpFreeCursor) _ANSI_ARGS_((TkCursor * cursorPtr)); /* 29 */
+ char * (*tkGetBitmapData) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char * fileName, int * widthPtr, int * heightPtr, int * hotXPtr, int * hotYPtr)); /* 30 */
+ void (*tkGetButtPoints) _ANSI_ARGS_((double p1[], double p2[], double width, int project, double m1[], double m2[])); /* 31 */
+ TkCursor * (*tkGetCursorByName) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tk_Uid string)); /* 32 */
+ CONST84_RETURN char * (*tkGetDefaultScreenName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * screenName)); /* 33 */
+ TkDisplay * (*tkGetDisplay) _ANSI_ARGS_((Display * display)); /* 34 */
+ int (*tkGetDisplayOf) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], Tk_Window * tkwinPtr)); /* 35 */
+ TkWindow * (*tkGetFocusWin) _ANSI_ARGS_((TkWindow * winPtr)); /* 36 */
+ int (*tkGetInterpNames) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin)); /* 37 */
+ int (*tkGetMiterPoints) _ANSI_ARGS_((double p1[], double p2[], double p3[], double width, double m1[], double m2[])); /* 38 */
+ void (*tkGetPointerCoords) _ANSI_ARGS_((Tk_Window tkwin, int * xPtr, int * yPtr)); /* 39 */
+ void (*tkGetServerInfo) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin)); /* 40 */
+ void (*tkGrabDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 41 */
+ int (*tkGrabState) _ANSI_ARGS_((TkWindow * winPtr)); /* 42 */
+ void (*tkIncludePoint) _ANSI_ARGS_((Tk_Item * itemPtr, double * pointPtr)); /* 43 */
+ void (*tkInOutEvents) _ANSI_ARGS_((XEvent * eventPtr, TkWindow * sourcePtr, TkWindow * destPtr, int leaveType, int enterType, Tcl_QueuePosition position)); /* 44 */
+ void (*tkInstallFrameMenu) _ANSI_ARGS_((Tk_Window tkwin)); /* 45 */
+ char * (*tkKeysymToString) _ANSI_ARGS_((KeySym keysym)); /* 46 */
+ int (*tkLineToArea) _ANSI_ARGS_((double end1Ptr[], double end2Ptr[], double rectPtr[])); /* 47 */
+ double (*tkLineToPoint) _ANSI_ARGS_((double end1Ptr[], double end2Ptr[], double pointPtr[])); /* 48 */
+ int (*tkMakeBezierCurve) _ANSI_ARGS_((Tk_Canvas canvas, double * pointPtr, int numPoints, int numSteps, XPoint xPoints[], double dblPoints[])); /* 49 */
+ void (*tkMakeBezierPostscript) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Canvas canvas, double * pointPtr, int numPoints)); /* 50 */
+ void (*tkOptionClassChanged) _ANSI_ARGS_((TkWindow * winPtr)); /* 51 */
+ void (*tkOptionDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 52 */
+ int (*tkOvalToArea) _ANSI_ARGS_((double * ovalPtr, double * rectPtr)); /* 53 */
+ double (*tkOvalToPoint) _ANSI_ARGS_((double ovalPtr[], double width, int filled, double pointPtr[])); /* 54 */
+ int (*tkpChangeFocus) _ANSI_ARGS_((TkWindow * winPtr, int force)); /* 55 */
+ void (*tkpCloseDisplay) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 56 */
+ void (*tkpClaimFocus) _ANSI_ARGS_((TkWindow * topLevelPtr, int force)); /* 57 */
+ void (*tkpDisplayWarning) _ANSI_ARGS_((CONST char * msg, CONST char * title)); /* 58 */
+ void (*tkpGetAppName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * name)); /* 59 */
+ TkWindow * (*tkpGetOtherWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 60 */
+ TkWindow * (*tkpGetWrapperWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 61 */
+ int (*tkpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 62 */
+ void (*tkpInitializeMenuBindings) _ANSI_ARGS_((Tcl_Interp * interp, Tk_BindingTable bindingTable)); /* 63 */
+ void (*tkpMakeContainer) _ANSI_ARGS_((Tk_Window tkwin)); /* 64 */
+ void (*tkpMakeMenuWindow) _ANSI_ARGS_((Tk_Window tkwin, int transient)); /* 65 */
+ Window (*tkpMakeWindow) _ANSI_ARGS_((TkWindow * winPtr, Window parent)); /* 66 */
+ void (*tkpMenuNotifyToplevelCreate) _ANSI_ARGS_((Tcl_Interp * interp1, char * menuName)); /* 67 */
+ TkDisplay * (*tkpOpenDisplay) _ANSI_ARGS_((CONST char * display_name)); /* 68 */
+ int (*tkPointerEvent) _ANSI_ARGS_((XEvent * eventPtr, TkWindow * winPtr)); /* 69 */
+ int (*tkPolygonToArea) _ANSI_ARGS_((double * polyPtr, int numPoints, double * rectPtr)); /* 70 */
+ double (*tkPolygonToPoint) _ANSI_ARGS_((double * polyPtr, int numPoints, double * pointPtr)); /* 71 */
+ int (*tkPositionInTree) _ANSI_ARGS_((TkWindow * winPtr, TkWindow * treePtr)); /* 72 */
+ void (*tkpRedirectKeyEvent) _ANSI_ARGS_((TkWindow * winPtr, XEvent * eventPtr)); /* 73 */
+ void (*tkpSetMainMenubar) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, char * menuName)); /* 74 */
+ int (*tkpUseWindow) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, CONST char * string)); /* 75 */
+ int (*tkpWindowWasRecentlyDeleted) _ANSI_ARGS_((Window win, TkDisplay * dispPtr)); /* 76 */
+ void (*tkQueueEventForAllChildren) _ANSI_ARGS_((TkWindow * winPtr, XEvent * eventPtr)); /* 77 */
+ int (*tkReadBitmapFile) _ANSI_ARGS_((Display* display, Drawable d, CONST char* filename, unsigned int* width_return, unsigned int* height_return, Pixmap* bitmap_return, int* x_hot_return, int* y_hot_return)); /* 78 */
+ int (*tkScrollWindow) _ANSI_ARGS_((Tk_Window tkwin, GC gc, int x, int y, int width, int height, int dx, int dy, TkRegion damageRgn)); /* 79 */
+ void (*tkSelDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 80 */
+ void (*tkSelEventProc) _ANSI_ARGS_((Tk_Window tkwin, XEvent * eventPtr)); /* 81 */
+ void (*tkSelInit) _ANSI_ARGS_((Tk_Window tkwin)); /* 82 */
+ void (*tkSelPropProc) _ANSI_ARGS_((XEvent * eventPtr)); /* 83 */
+ void *reserved84;
+ void (*tkSetWindowMenuBar) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, char * oldMenuName, char * menuName)); /* 85 */
+ KeySym (*tkStringToKeysym) _ANSI_ARGS_((char * name)); /* 86 */
+ int (*tkThickPolyLineToArea) _ANSI_ARGS_((double * coordPtr, int numPoints, double width, int capStyle, int joinStyle, double * rectPtr)); /* 87 */
+ void (*tkWmAddToColormapWindows) _ANSI_ARGS_((TkWindow * winPtr)); /* 88 */
+ void (*tkWmDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 89 */
+ TkWindow * (*tkWmFocusToplevel) _ANSI_ARGS_((TkWindow * winPtr)); /* 90 */
+ void (*tkWmMapWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 91 */
+ void (*tkWmNewWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 92 */
+ void (*tkWmProtocolEventProc) _ANSI_ARGS_((TkWindow * winPtr, XEvent * evenvPtr)); /* 93 */
+ void (*tkWmRemoveFromColormapWindows) _ANSI_ARGS_((TkWindow * winPtr)); /* 94 */
+ void (*tkWmRestackToplevel) _ANSI_ARGS_((TkWindow * winPtr, int aboveBelow, TkWindow * otherPtr)); /* 95 */
+ void (*tkWmSetClass) _ANSI_ARGS_((TkWindow * winPtr)); /* 96 */
+ void (*tkWmUnmapWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 97 */
+ Tcl_Obj * (*tkDebugBitmap) _ANSI_ARGS_((Tk_Window tkwin, char * name)); /* 98 */
+ Tcl_Obj * (*tkDebugBorder) _ANSI_ARGS_((Tk_Window tkwin, char * name)); /* 99 */
+ Tcl_Obj * (*tkDebugCursor) _ANSI_ARGS_((Tk_Window tkwin, char * name)); /* 100 */
+ Tcl_Obj * (*tkDebugColor) _ANSI_ARGS_((Tk_Window tkwin, char * name)); /* 101 */
+ Tcl_Obj * (*tkDebugConfig) _ANSI_ARGS_((Tcl_Interp * interp, Tk_OptionTable table)); /* 102 */
+ Tcl_Obj * (*tkDebugFont) _ANSI_ARGS_((Tk_Window tkwin, char * name)); /* 103 */
+ int (*tkFindStateNumObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * optionPtr, CONST TkStateMap * mapPtr, Tcl_Obj * keyPtr)); /* 104 */
+ Tcl_HashTable * (*tkGetBitmapPredefTable) _ANSI_ARGS_((void)); /* 105 */
+ TkDisplay * (*tkGetDisplayList) _ANSI_ARGS_((void)); /* 106 */
+ TkMainInfo * (*tkGetMainInfoList) _ANSI_ARGS_((void)); /* 107 */
+ int (*tkGetWindowFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Window tkwin, Tcl_Obj * objPtr, Tk_Window * windowPtr)); /* 108 */
+ char * (*tkpGetString) _ANSI_ARGS_((TkWindow * winPtr, XEvent * eventPtr, Tcl_DString * dsPtr)); /* 109 */
+ void (*tkpGetSubFonts) _ANSI_ARGS_((Tcl_Interp * interp, Tk_Font tkfont)); /* 110 */
+ Tcl_Obj * (*tkpGetSystemDefault) _ANSI_ARGS_((Tk_Window tkwin, CONST char * dbName, CONST char * className)); /* 111 */
+ void (*tkpMenuThreadInit) _ANSI_ARGS_((void)); /* 112 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved113;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tkClipBox) _ANSI_ARGS_((TkRegion rgn, XRectangle* rect_return)); /* 113 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkClipBox) _ANSI_ARGS_((TkRegion rgn, XRectangle* rect_return)); /* 113 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkClipBox) _ANSI_ARGS_((TkRegion rgn, XRectangle* rect_return)); /* 113 */
+#endif /* MAC_OSX_TK */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved114;
+#endif /* UNIX */
+#ifdef __WIN32__
+ TkRegion (*tkCreateRegion) _ANSI_ARGS_((void)); /* 114 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ TkRegion (*tkCreateRegion) _ANSI_ARGS_((void)); /* 114 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ TkRegion (*tkCreateRegion) _ANSI_ARGS_((void)); /* 114 */
+#endif /* MAC_OSX_TK */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved115;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tkDestroyRegion) _ANSI_ARGS_((TkRegion rgn)); /* 115 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkDestroyRegion) _ANSI_ARGS_((TkRegion rgn)); /* 115 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkDestroyRegion) _ANSI_ARGS_((TkRegion rgn)); /* 115 */
+#endif /* MAC_OSX_TK */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved116;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tkIntersectRegion) _ANSI_ARGS_((TkRegion sra, TkRegion srcb, TkRegion dr_return)); /* 116 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkIntersectRegion) _ANSI_ARGS_((TkRegion sra, TkRegion srcb, TkRegion dr_return)); /* 116 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkIntersectRegion) _ANSI_ARGS_((TkRegion sra, TkRegion srcb, TkRegion dr_return)); /* 116 */
+#endif /* MAC_OSX_TK */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved117;
+#endif /* UNIX */
+#ifdef __WIN32__
+ int (*tkRectInRegion) _ANSI_ARGS_((TkRegion rgn, int x, int y, unsigned int width, unsigned int height)); /* 117 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ int (*tkRectInRegion) _ANSI_ARGS_((TkRegion rgn, int x, int y, unsigned int width, unsigned int height)); /* 117 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ int (*tkRectInRegion) _ANSI_ARGS_((TkRegion rgn, int x, int y, unsigned int width, unsigned int height)); /* 117 */
+#endif /* MAC_OSX_TK */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved118;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tkSetRegion) _ANSI_ARGS_((Display* display, GC gc, TkRegion rgn)); /* 118 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkSetRegion) _ANSI_ARGS_((Display* display, GC gc, TkRegion rgn)); /* 118 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkSetRegion) _ANSI_ARGS_((Display* display, GC gc, TkRegion rgn)); /* 118 */
+#endif /* MAC_OSX_TK */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved119;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tkUnionRectWithRegion) _ANSI_ARGS_((XRectangle* rect, TkRegion src, TkRegion dr_return)); /* 119 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkUnionRectWithRegion) _ANSI_ARGS_((XRectangle* rect, TkRegion src, TkRegion dr_return)); /* 119 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkUnionRectWithRegion) _ANSI_ARGS_((XRectangle* rect, TkRegion src, TkRegion dr_return)); /* 119 */
+#endif /* MAC_OSX_TK */
+ void *reserved120;
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved121;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void *reserved121;
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ Pixmap (*tkpCreateNativeBitmap) _ANSI_ARGS_((Display * display, CONST char * source)); /* 121 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ Pixmap (*tkpCreateNativeBitmap) _ANSI_ARGS_((Display * display, CONST char * source)); /* 121 */
+#endif /* MAC_OSX_TK */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved122;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void *reserved122;
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkpDefineNativeBitmaps) _ANSI_ARGS_((void)); /* 122 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkpDefineNativeBitmaps) _ANSI_ARGS_((void)); /* 122 */
+#endif /* MAC_OSX_TK */
+ void *reserved123;
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved124;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void *reserved124;
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ Pixmap (*tkpGetNativeAppBitmap) _ANSI_ARGS_((Display * display, CONST char * name, int * width, int * height)); /* 124 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ Pixmap (*tkpGetNativeAppBitmap) _ANSI_ARGS_((Display * display, CONST char * name, int * width, int * height)); /* 124 */
+#endif /* MAC_OSX_TK */
+ void *reserved125;
+ void *reserved126;
+ void *reserved127;
+ void *reserved128;
+ void *reserved129;
+ void *reserved130;
+ void *reserved131;
+ void *reserved132;
+ void *reserved133;
+ void *reserved134;
+ void (*tkpDrawHighlightBorder) _ANSI_ARGS_((Tk_Window tkwin, GC fgGC, GC bgGC, int highlightWidth, Drawable drawable)); /* 135 */
+ void (*tkSetFocusWin) _ANSI_ARGS_((TkWindow * winPtr, int force)); /* 136 */
+ void (*tkpSetKeycodeAndState) _ANSI_ARGS_((Tk_Window tkwin, KeySym keySym, XEvent * eventPtr)); /* 137 */
+ KeySym (*tkpGetKeySym) _ANSI_ARGS_((TkDisplay * dispPtr, XEvent * eventPtr)); /* 138 */
+ void (*tkpInitKeymapInfo) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 139 */
+ TkRegion (*tkPhotoGetValidRegion) _ANSI_ARGS_((Tk_PhotoHandle handle)); /* 140 */
+ TkWindow ** (*tkWmStackorderToplevel) _ANSI_ARGS_((TkWindow * parentPtr)); /* 141 */
+ void (*tkFocusFree) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 142 */
+ void (*tkClipCleanup) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 143 */
+ void (*tkGCCleanup) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 144 */
+#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ void *reserved145;
+#endif /* UNIX */
+#ifdef __WIN32__
+ void (*tkSubtractRegion) _ANSI_ARGS_((TkRegion sra, TkRegion srcb, TkRegion dr_return)); /* 145 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkSubtractRegion) _ANSI_ARGS_((TkRegion sra, TkRegion srcb, TkRegion dr_return)); /* 145 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkSubtractRegion) _ANSI_ARGS_((TkRegion sra, TkRegion srcb, TkRegion dr_return)); /* 145 */
+#endif /* MAC_OSX_TK */
+ void (*tkStylePkgInit) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 146 */
+ void (*tkStylePkgFree) _ANSI_ARGS_((TkMainInfo * mainPtr)); /* 147 */
+ Tk_Window (*tkToplevelWindowForCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName)); /* 148 */
+ CONST Tk_OptionSpec * (*tkGetOptionSpec) _ANSI_ARGS_((CONST char * name, Tk_OptionTable optionTable)); /* 149 */
+} TkIntStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TkIntStubs *tkIntStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifndef TkAllocWindow
+#define TkAllocWindow \
+ (tkIntStubsPtr->tkAllocWindow) /* 0 */
+#endif
+#ifndef TkBezierPoints
+#define TkBezierPoints \
+ (tkIntStubsPtr->tkBezierPoints) /* 1 */
+#endif
+#ifndef TkBezierScreenPoints
+#define TkBezierScreenPoints \
+ (tkIntStubsPtr->tkBezierScreenPoints) /* 2 */
+#endif
+#ifndef TkBindDeadWindow
+#define TkBindDeadWindow \
+ (tkIntStubsPtr->tkBindDeadWindow) /* 3 */
+#endif
+#ifndef TkBindEventProc
+#define TkBindEventProc \
+ (tkIntStubsPtr->tkBindEventProc) /* 4 */
+#endif
+#ifndef TkBindFree
+#define TkBindFree \
+ (tkIntStubsPtr->tkBindFree) /* 5 */
+#endif
+#ifndef TkBindInit
+#define TkBindInit \
+ (tkIntStubsPtr->tkBindInit) /* 6 */
+#endif
+#ifndef TkChangeEventWindow
+#define TkChangeEventWindow \
+ (tkIntStubsPtr->tkChangeEventWindow) /* 7 */
+#endif
+#ifndef TkClipInit
+#define TkClipInit \
+ (tkIntStubsPtr->tkClipInit) /* 8 */
+#endif
+#ifndef TkComputeAnchor
+#define TkComputeAnchor \
+ (tkIntStubsPtr->tkComputeAnchor) /* 9 */
+#endif
+#ifndef TkCopyAndGlobalEval
+#define TkCopyAndGlobalEval \
+ (tkIntStubsPtr->tkCopyAndGlobalEval) /* 10 */
+#endif
+#ifndef TkCreateBindingProcedure
+#define TkCreateBindingProcedure \
+ (tkIntStubsPtr->tkCreateBindingProcedure) /* 11 */
+#endif
+#ifndef TkCreateCursorFromData
+#define TkCreateCursorFromData \
+ (tkIntStubsPtr->tkCreateCursorFromData) /* 12 */
+#endif
+#ifndef TkCreateFrame
+#define TkCreateFrame \
+ (tkIntStubsPtr->tkCreateFrame) /* 13 */
+#endif
+#ifndef TkCreateMainWindow
+#define TkCreateMainWindow \
+ (tkIntStubsPtr->tkCreateMainWindow) /* 14 */
+#endif
+#ifndef TkCurrentTime
+#define TkCurrentTime \
+ (tkIntStubsPtr->tkCurrentTime) /* 15 */
+#endif
+#ifndef TkDeleteAllImages
+#define TkDeleteAllImages \
+ (tkIntStubsPtr->tkDeleteAllImages) /* 16 */
+#endif
+#ifndef TkDoConfigureNotify
+#define TkDoConfigureNotify \
+ (tkIntStubsPtr->tkDoConfigureNotify) /* 17 */
+#endif
+#ifndef TkDrawInsetFocusHighlight
+#define TkDrawInsetFocusHighlight \
+ (tkIntStubsPtr->tkDrawInsetFocusHighlight) /* 18 */
+#endif
+#ifndef TkEventDeadWindow
+#define TkEventDeadWindow \
+ (tkIntStubsPtr->tkEventDeadWindow) /* 19 */
+#endif
+#ifndef TkFillPolygon
+#define TkFillPolygon \
+ (tkIntStubsPtr->tkFillPolygon) /* 20 */
+#endif
+#ifndef TkFindStateNum
+#define TkFindStateNum \
+ (tkIntStubsPtr->tkFindStateNum) /* 21 */
+#endif
+#ifndef TkFindStateString
+#define TkFindStateString \
+ (tkIntStubsPtr->tkFindStateString) /* 22 */
+#endif
+#ifndef TkFocusDeadWindow
+#define TkFocusDeadWindow \
+ (tkIntStubsPtr->tkFocusDeadWindow) /* 23 */
+#endif
+#ifndef TkFocusFilterEvent
+#define TkFocusFilterEvent \
+ (tkIntStubsPtr->tkFocusFilterEvent) /* 24 */
+#endif
+#ifndef TkFocusKeyEvent
+#define TkFocusKeyEvent \
+ (tkIntStubsPtr->tkFocusKeyEvent) /* 25 */
+#endif
+#ifndef TkFontPkgInit
+#define TkFontPkgInit \
+ (tkIntStubsPtr->tkFontPkgInit) /* 26 */
+#endif
+#ifndef TkFontPkgFree
+#define TkFontPkgFree \
+ (tkIntStubsPtr->tkFontPkgFree) /* 27 */
+#endif
+#ifndef TkFreeBindingTags
+#define TkFreeBindingTags \
+ (tkIntStubsPtr->tkFreeBindingTags) /* 28 */
+#endif
+#ifndef TkpFreeCursor
+#define TkpFreeCursor \
+ (tkIntStubsPtr->tkpFreeCursor) /* 29 */
+#endif
+#ifndef TkGetBitmapData
+#define TkGetBitmapData \
+ (tkIntStubsPtr->tkGetBitmapData) /* 30 */
+#endif
+#ifndef TkGetButtPoints
+#define TkGetButtPoints \
+ (tkIntStubsPtr->tkGetButtPoints) /* 31 */
+#endif
+#ifndef TkGetCursorByName
+#define TkGetCursorByName \
+ (tkIntStubsPtr->tkGetCursorByName) /* 32 */
+#endif
+#ifndef TkGetDefaultScreenName
+#define TkGetDefaultScreenName \
+ (tkIntStubsPtr->tkGetDefaultScreenName) /* 33 */
+#endif
+#ifndef TkGetDisplay
+#define TkGetDisplay \
+ (tkIntStubsPtr->tkGetDisplay) /* 34 */
+#endif
+#ifndef TkGetDisplayOf
+#define TkGetDisplayOf \
+ (tkIntStubsPtr->tkGetDisplayOf) /* 35 */
+#endif
+#ifndef TkGetFocusWin
+#define TkGetFocusWin \
+ (tkIntStubsPtr->tkGetFocusWin) /* 36 */
+#endif
+#ifndef TkGetInterpNames
+#define TkGetInterpNames \
+ (tkIntStubsPtr->tkGetInterpNames) /* 37 */
+#endif
+#ifndef TkGetMiterPoints
+#define TkGetMiterPoints \
+ (tkIntStubsPtr->tkGetMiterPoints) /* 38 */
+#endif
+#ifndef TkGetPointerCoords
+#define TkGetPointerCoords \
+ (tkIntStubsPtr->tkGetPointerCoords) /* 39 */
+#endif
+#ifndef TkGetServerInfo
+#define TkGetServerInfo \
+ (tkIntStubsPtr->tkGetServerInfo) /* 40 */
+#endif
+#ifndef TkGrabDeadWindow
+#define TkGrabDeadWindow \
+ (tkIntStubsPtr->tkGrabDeadWindow) /* 41 */
+#endif
+#ifndef TkGrabState
+#define TkGrabState \
+ (tkIntStubsPtr->tkGrabState) /* 42 */
+#endif
+#ifndef TkIncludePoint
+#define TkIncludePoint \
+ (tkIntStubsPtr->tkIncludePoint) /* 43 */
+#endif
+#ifndef TkInOutEvents
+#define TkInOutEvents \
+ (tkIntStubsPtr->tkInOutEvents) /* 44 */
+#endif
+#ifndef TkInstallFrameMenu
+#define TkInstallFrameMenu \
+ (tkIntStubsPtr->tkInstallFrameMenu) /* 45 */
+#endif
+#ifndef TkKeysymToString
+#define TkKeysymToString \
+ (tkIntStubsPtr->tkKeysymToString) /* 46 */
+#endif
+#ifndef TkLineToArea
+#define TkLineToArea \
+ (tkIntStubsPtr->tkLineToArea) /* 47 */
+#endif
+#ifndef TkLineToPoint
+#define TkLineToPoint \
+ (tkIntStubsPtr->tkLineToPoint) /* 48 */
+#endif
+#ifndef TkMakeBezierCurve
+#define TkMakeBezierCurve \
+ (tkIntStubsPtr->tkMakeBezierCurve) /* 49 */
+#endif
+#ifndef TkMakeBezierPostscript
+#define TkMakeBezierPostscript \
+ (tkIntStubsPtr->tkMakeBezierPostscript) /* 50 */
+#endif
+#ifndef TkOptionClassChanged
+#define TkOptionClassChanged \
+ (tkIntStubsPtr->tkOptionClassChanged) /* 51 */
+#endif
+#ifndef TkOptionDeadWindow
+#define TkOptionDeadWindow \
+ (tkIntStubsPtr->tkOptionDeadWindow) /* 52 */
+#endif
+#ifndef TkOvalToArea
+#define TkOvalToArea \
+ (tkIntStubsPtr->tkOvalToArea) /* 53 */
+#endif
+#ifndef TkOvalToPoint
+#define TkOvalToPoint \
+ (tkIntStubsPtr->tkOvalToPoint) /* 54 */
+#endif
+#ifndef TkpChangeFocus
+#define TkpChangeFocus \
+ (tkIntStubsPtr->tkpChangeFocus) /* 55 */
+#endif
+#ifndef TkpCloseDisplay
+#define TkpCloseDisplay \
+ (tkIntStubsPtr->tkpCloseDisplay) /* 56 */
+#endif
+#ifndef TkpClaimFocus
+#define TkpClaimFocus \
+ (tkIntStubsPtr->tkpClaimFocus) /* 57 */
+#endif
+#ifndef TkpDisplayWarning
+#define TkpDisplayWarning \
+ (tkIntStubsPtr->tkpDisplayWarning) /* 58 */
+#endif
+#ifndef TkpGetAppName
+#define TkpGetAppName \
+ (tkIntStubsPtr->tkpGetAppName) /* 59 */
+#endif
+#ifndef TkpGetOtherWindow
+#define TkpGetOtherWindow \
+ (tkIntStubsPtr->tkpGetOtherWindow) /* 60 */
+#endif
+#ifndef TkpGetWrapperWindow
+#define TkpGetWrapperWindow \
+ (tkIntStubsPtr->tkpGetWrapperWindow) /* 61 */
+#endif
+#ifndef TkpInit
+#define TkpInit \
+ (tkIntStubsPtr->tkpInit) /* 62 */
+#endif
+#ifndef TkpInitializeMenuBindings
+#define TkpInitializeMenuBindings \
+ (tkIntStubsPtr->tkpInitializeMenuBindings) /* 63 */
+#endif
+#ifndef TkpMakeContainer
+#define TkpMakeContainer \
+ (tkIntStubsPtr->tkpMakeContainer) /* 64 */
+#endif
+#ifndef TkpMakeMenuWindow
+#define TkpMakeMenuWindow \
+ (tkIntStubsPtr->tkpMakeMenuWindow) /* 65 */
+#endif
+#ifndef TkpMakeWindow
+#define TkpMakeWindow \
+ (tkIntStubsPtr->tkpMakeWindow) /* 66 */
+#endif
+#ifndef TkpMenuNotifyToplevelCreate
+#define TkpMenuNotifyToplevelCreate \
+ (tkIntStubsPtr->tkpMenuNotifyToplevelCreate) /* 67 */
+#endif
+#ifndef TkpOpenDisplay
+#define TkpOpenDisplay \
+ (tkIntStubsPtr->tkpOpenDisplay) /* 68 */
+#endif
+#ifndef TkPointerEvent
+#define TkPointerEvent \
+ (tkIntStubsPtr->tkPointerEvent) /* 69 */
+#endif
+#ifndef TkPolygonToArea
+#define TkPolygonToArea \
+ (tkIntStubsPtr->tkPolygonToArea) /* 70 */
+#endif
+#ifndef TkPolygonToPoint
+#define TkPolygonToPoint \
+ (tkIntStubsPtr->tkPolygonToPoint) /* 71 */
+#endif
+#ifndef TkPositionInTree
+#define TkPositionInTree \
+ (tkIntStubsPtr->tkPositionInTree) /* 72 */
+#endif
+#ifndef TkpRedirectKeyEvent
+#define TkpRedirectKeyEvent \
+ (tkIntStubsPtr->tkpRedirectKeyEvent) /* 73 */
+#endif
+#ifndef TkpSetMainMenubar
+#define TkpSetMainMenubar \
+ (tkIntStubsPtr->tkpSetMainMenubar) /* 74 */
+#endif
+#ifndef TkpUseWindow
+#define TkpUseWindow \
+ (tkIntStubsPtr->tkpUseWindow) /* 75 */
+#endif
+#ifndef TkpWindowWasRecentlyDeleted
+#define TkpWindowWasRecentlyDeleted \
+ (tkIntStubsPtr->tkpWindowWasRecentlyDeleted) /* 76 */
+#endif
+#ifndef TkQueueEventForAllChildren
+#define TkQueueEventForAllChildren \
+ (tkIntStubsPtr->tkQueueEventForAllChildren) /* 77 */
+#endif
+#ifndef TkReadBitmapFile
+#define TkReadBitmapFile \
+ (tkIntStubsPtr->tkReadBitmapFile) /* 78 */
+#endif
+#ifndef TkScrollWindow
+#define TkScrollWindow \
+ (tkIntStubsPtr->tkScrollWindow) /* 79 */
+#endif
+#ifndef TkSelDeadWindow
+#define TkSelDeadWindow \
+ (tkIntStubsPtr->tkSelDeadWindow) /* 80 */
+#endif
+#ifndef TkSelEventProc
+#define TkSelEventProc \
+ (tkIntStubsPtr->tkSelEventProc) /* 81 */
+#endif
+#ifndef TkSelInit
+#define TkSelInit \
+ (tkIntStubsPtr->tkSelInit) /* 82 */
+#endif
+#ifndef TkSelPropProc
+#define TkSelPropProc \
+ (tkIntStubsPtr->tkSelPropProc) /* 83 */
+#endif
+/* Slot 84 is reserved */
+#ifndef TkSetWindowMenuBar
+#define TkSetWindowMenuBar \
+ (tkIntStubsPtr->tkSetWindowMenuBar) /* 85 */
+#endif
+#ifndef TkStringToKeysym
+#define TkStringToKeysym \
+ (tkIntStubsPtr->tkStringToKeysym) /* 86 */
+#endif
+#ifndef TkThickPolyLineToArea
+#define TkThickPolyLineToArea \
+ (tkIntStubsPtr->tkThickPolyLineToArea) /* 87 */
+#endif
+#ifndef TkWmAddToColormapWindows
+#define TkWmAddToColormapWindows \
+ (tkIntStubsPtr->tkWmAddToColormapWindows) /* 88 */
+#endif
+#ifndef TkWmDeadWindow
+#define TkWmDeadWindow \
+ (tkIntStubsPtr->tkWmDeadWindow) /* 89 */
+#endif
+#ifndef TkWmFocusToplevel
+#define TkWmFocusToplevel \
+ (tkIntStubsPtr->tkWmFocusToplevel) /* 90 */
+#endif
+#ifndef TkWmMapWindow
+#define TkWmMapWindow \
+ (tkIntStubsPtr->tkWmMapWindow) /* 91 */
+#endif
+#ifndef TkWmNewWindow
+#define TkWmNewWindow \
+ (tkIntStubsPtr->tkWmNewWindow) /* 92 */
+#endif
+#ifndef TkWmProtocolEventProc
+#define TkWmProtocolEventProc \
+ (tkIntStubsPtr->tkWmProtocolEventProc) /* 93 */
+#endif
+#ifndef TkWmRemoveFromColormapWindows
+#define TkWmRemoveFromColormapWindows \
+ (tkIntStubsPtr->tkWmRemoveFromColormapWindows) /* 94 */
+#endif
+#ifndef TkWmRestackToplevel
+#define TkWmRestackToplevel \
+ (tkIntStubsPtr->tkWmRestackToplevel) /* 95 */
+#endif
+#ifndef TkWmSetClass
+#define TkWmSetClass \
+ (tkIntStubsPtr->tkWmSetClass) /* 96 */
+#endif
+#ifndef TkWmUnmapWindow
+#define TkWmUnmapWindow \
+ (tkIntStubsPtr->tkWmUnmapWindow) /* 97 */
+#endif
+#ifndef TkDebugBitmap
+#define TkDebugBitmap \
+ (tkIntStubsPtr->tkDebugBitmap) /* 98 */
+#endif
+#ifndef TkDebugBorder
+#define TkDebugBorder \
+ (tkIntStubsPtr->tkDebugBorder) /* 99 */
+#endif
+#ifndef TkDebugCursor
+#define TkDebugCursor \
+ (tkIntStubsPtr->tkDebugCursor) /* 100 */
+#endif
+#ifndef TkDebugColor
+#define TkDebugColor \
+ (tkIntStubsPtr->tkDebugColor) /* 101 */
+#endif
+#ifndef TkDebugConfig
+#define TkDebugConfig \
+ (tkIntStubsPtr->tkDebugConfig) /* 102 */
+#endif
+#ifndef TkDebugFont
+#define TkDebugFont \
+ (tkIntStubsPtr->tkDebugFont) /* 103 */
+#endif
+#ifndef TkFindStateNumObj
+#define TkFindStateNumObj \
+ (tkIntStubsPtr->tkFindStateNumObj) /* 104 */
+#endif
+#ifndef TkGetBitmapPredefTable
+#define TkGetBitmapPredefTable \
+ (tkIntStubsPtr->tkGetBitmapPredefTable) /* 105 */
+#endif
+#ifndef TkGetDisplayList
+#define TkGetDisplayList \
+ (tkIntStubsPtr->tkGetDisplayList) /* 106 */
+#endif
+#ifndef TkGetMainInfoList
+#define TkGetMainInfoList \
+ (tkIntStubsPtr->tkGetMainInfoList) /* 107 */
+#endif
+#ifndef TkGetWindowFromObj
+#define TkGetWindowFromObj \
+ (tkIntStubsPtr->tkGetWindowFromObj) /* 108 */
+#endif
+#ifndef TkpGetString
+#define TkpGetString \
+ (tkIntStubsPtr->tkpGetString) /* 109 */
+#endif
+#ifndef TkpGetSubFonts
+#define TkpGetSubFonts \
+ (tkIntStubsPtr->tkpGetSubFonts) /* 110 */
+#endif
+#ifndef TkpGetSystemDefault
+#define TkpGetSystemDefault \
+ (tkIntStubsPtr->tkpGetSystemDefault) /* 111 */
+#endif
+#ifndef TkpMenuThreadInit
+#define TkpMenuThreadInit \
+ (tkIntStubsPtr->tkpMenuThreadInit) /* 112 */
+#endif
+#ifdef __WIN32__
+#ifndef TkClipBox
+#define TkClipBox \
+ (tkIntStubsPtr->tkClipBox) /* 113 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkClipBox
+#define TkClipBox \
+ (tkIntStubsPtr->tkClipBox) /* 113 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkClipBox
+#define TkClipBox \
+ (tkIntStubsPtr->tkClipBox) /* 113 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+#ifndef TkCreateRegion
+#define TkCreateRegion \
+ (tkIntStubsPtr->tkCreateRegion) /* 114 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkCreateRegion
+#define TkCreateRegion \
+ (tkIntStubsPtr->tkCreateRegion) /* 114 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkCreateRegion
+#define TkCreateRegion \
+ (tkIntStubsPtr->tkCreateRegion) /* 114 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+#ifndef TkDestroyRegion
+#define TkDestroyRegion \
+ (tkIntStubsPtr->tkDestroyRegion) /* 115 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkDestroyRegion
+#define TkDestroyRegion \
+ (tkIntStubsPtr->tkDestroyRegion) /* 115 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkDestroyRegion
+#define TkDestroyRegion \
+ (tkIntStubsPtr->tkDestroyRegion) /* 115 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+#ifndef TkIntersectRegion
+#define TkIntersectRegion \
+ (tkIntStubsPtr->tkIntersectRegion) /* 116 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkIntersectRegion
+#define TkIntersectRegion \
+ (tkIntStubsPtr->tkIntersectRegion) /* 116 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkIntersectRegion
+#define TkIntersectRegion \
+ (tkIntStubsPtr->tkIntersectRegion) /* 116 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+#ifndef TkRectInRegion
+#define TkRectInRegion \
+ (tkIntStubsPtr->tkRectInRegion) /* 117 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkRectInRegion
+#define TkRectInRegion \
+ (tkIntStubsPtr->tkRectInRegion) /* 117 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkRectInRegion
+#define TkRectInRegion \
+ (tkIntStubsPtr->tkRectInRegion) /* 117 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+#ifndef TkSetRegion
+#define TkSetRegion \
+ (tkIntStubsPtr->tkSetRegion) /* 118 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkSetRegion
+#define TkSetRegion \
+ (tkIntStubsPtr->tkSetRegion) /* 118 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkSetRegion
+#define TkSetRegion \
+ (tkIntStubsPtr->tkSetRegion) /* 118 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifdef __WIN32__
+#ifndef TkUnionRectWithRegion
+#define TkUnionRectWithRegion \
+ (tkIntStubsPtr->tkUnionRectWithRegion) /* 119 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkUnionRectWithRegion
+#define TkUnionRectWithRegion \
+ (tkIntStubsPtr->tkUnionRectWithRegion) /* 119 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkUnionRectWithRegion
+#define TkUnionRectWithRegion \
+ (tkIntStubsPtr->tkUnionRectWithRegion) /* 119 */
+#endif
+#endif /* MAC_OSX_TK */
+/* Slot 120 is reserved */
+#ifdef MAC_TCL
+#ifndef TkpCreateNativeBitmap
+#define TkpCreateNativeBitmap \
+ (tkIntStubsPtr->tkpCreateNativeBitmap) /* 121 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkpCreateNativeBitmap
+#define TkpCreateNativeBitmap \
+ (tkIntStubsPtr->tkpCreateNativeBitmap) /* 121 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifdef MAC_TCL
+#ifndef TkpDefineNativeBitmaps
+#define TkpDefineNativeBitmaps \
+ (tkIntStubsPtr->tkpDefineNativeBitmaps) /* 122 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkpDefineNativeBitmaps
+#define TkpDefineNativeBitmaps \
+ (tkIntStubsPtr->tkpDefineNativeBitmaps) /* 122 */
+#endif
+#endif /* MAC_OSX_TK */
+/* Slot 123 is reserved */
+#ifdef MAC_TCL
+#ifndef TkpGetNativeAppBitmap
+#define TkpGetNativeAppBitmap \
+ (tkIntStubsPtr->tkpGetNativeAppBitmap) /* 124 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkpGetNativeAppBitmap
+#define TkpGetNativeAppBitmap \
+ (tkIntStubsPtr->tkpGetNativeAppBitmap) /* 124 */
+#endif
+#endif /* MAC_OSX_TK */
+/* Slot 125 is reserved */
+/* Slot 126 is reserved */
+/* Slot 127 is reserved */
+/* Slot 128 is reserved */
+/* Slot 129 is reserved */
+/* Slot 130 is reserved */
+/* Slot 131 is reserved */
+/* Slot 132 is reserved */
+/* Slot 133 is reserved */
+/* Slot 134 is reserved */
+#ifndef TkpDrawHighlightBorder
+#define TkpDrawHighlightBorder \
+ (tkIntStubsPtr->tkpDrawHighlightBorder) /* 135 */
+#endif
+#ifndef TkSetFocusWin
+#define TkSetFocusWin \
+ (tkIntStubsPtr->tkSetFocusWin) /* 136 */
+#endif
+#ifndef TkpSetKeycodeAndState
+#define TkpSetKeycodeAndState \
+ (tkIntStubsPtr->tkpSetKeycodeAndState) /* 137 */
+#endif
+#ifndef TkpGetKeySym
+#define TkpGetKeySym \
+ (tkIntStubsPtr->tkpGetKeySym) /* 138 */
+#endif
+#ifndef TkpInitKeymapInfo
+#define TkpInitKeymapInfo \
+ (tkIntStubsPtr->tkpInitKeymapInfo) /* 139 */
+#endif
+#ifndef TkPhotoGetValidRegion
+#define TkPhotoGetValidRegion \
+ (tkIntStubsPtr->tkPhotoGetValidRegion) /* 140 */
+#endif
+#ifndef TkWmStackorderToplevel
+#define TkWmStackorderToplevel \
+ (tkIntStubsPtr->tkWmStackorderToplevel) /* 141 */
+#endif
+#ifndef TkFocusFree
+#define TkFocusFree \
+ (tkIntStubsPtr->tkFocusFree) /* 142 */
+#endif
+#ifndef TkClipCleanup
+#define TkClipCleanup \
+ (tkIntStubsPtr->tkClipCleanup) /* 143 */
+#endif
+#ifndef TkGCCleanup
+#define TkGCCleanup \
+ (tkIntStubsPtr->tkGCCleanup) /* 144 */
+#endif
+#ifdef __WIN32__
+#ifndef TkSubtractRegion
+#define TkSubtractRegion \
+ (tkIntStubsPtr->tkSubtractRegion) /* 145 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkSubtractRegion
+#define TkSubtractRegion \
+ (tkIntStubsPtr->tkSubtractRegion) /* 145 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkSubtractRegion
+#define TkSubtractRegion \
+ (tkIntStubsPtr->tkSubtractRegion) /* 145 */
+#endif
+#endif /* MAC_OSX_TK */
+#ifndef TkStylePkgInit
+#define TkStylePkgInit \
+ (tkIntStubsPtr->tkStylePkgInit) /* 146 */
+#endif
+#ifndef TkStylePkgFree
+#define TkStylePkgFree \
+ (tkIntStubsPtr->tkStylePkgFree) /* 147 */
+#endif
+#ifndef TkToplevelWindowForCommand
+#define TkToplevelWindowForCommand \
+ (tkIntStubsPtr->tkToplevelWindowForCommand) /* 148 */
+#endif
+#ifndef TkGetOptionSpec
+#define TkGetOptionSpec \
+ (tkIntStubsPtr->tkGetOptionSpec) /* 149 */
+#endif
+
+#endif /* defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKINTDECLS */
+
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.m
new file mode 100755
index 00000000000..61e31a2f65b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.m
@@ -0,0 +1,466 @@
+#ifndef _TKINTDECLS_VM
+#define _TKINTDECLS_VM
+#include "tkIntDecls_f.h"
+#ifndef NO_VTABLES
+#ifndef TkAllocWindow
+# define TkAllocWindow (*TkintdeclsVptr->V_TkAllocWindow)
+#endif
+
+#ifndef TkBindDeadWindow
+# define TkBindDeadWindow (*TkintdeclsVptr->V_TkBindDeadWindow)
+#endif
+
+#ifndef TkBindEventProc
+# define TkBindEventProc (*TkintdeclsVptr->V_TkBindEventProc)
+#endif
+
+#ifndef TkBindFree
+# define TkBindFree (*TkintdeclsVptr->V_TkBindFree)
+#endif
+
+#ifndef TkBindInit
+# define TkBindInit (*TkintdeclsVptr->V_TkBindInit)
+#endif
+
+#ifndef TkChangeEventWindow
+# define TkChangeEventWindow (*TkintdeclsVptr->V_TkChangeEventWindow)
+#endif
+
+#ifndef TkClipBox
+# define TkClipBox (*TkintdeclsVptr->V_TkClipBox)
+#endif
+
+#ifndef TkClipCleanup
+# define TkClipCleanup (*TkintdeclsVptr->V_TkClipCleanup)
+#endif
+
+#ifndef TkClipInit
+# define TkClipInit (*TkintdeclsVptr->V_TkClipInit)
+#endif
+
+#ifndef TkComputeAnchor
+# define TkComputeAnchor (*TkintdeclsVptr->V_TkComputeAnchor)
+#endif
+
+#ifndef TkCopyAndGlobalEval
+# define TkCopyAndGlobalEval (*TkintdeclsVptr->V_TkCopyAndGlobalEval)
+#endif
+
+#ifndef TkCreateBindingProcedure
+# define TkCreateBindingProcedure (*TkintdeclsVptr->V_TkCreateBindingProcedure)
+#endif
+
+#ifndef TkCreateCursorFromData
+# define TkCreateCursorFromData (*TkintdeclsVptr->V_TkCreateCursorFromData)
+#endif
+
+#ifndef TkCreateFrame
+# define TkCreateFrame (*TkintdeclsVptr->V_TkCreateFrame)
+#endif
+
+#ifndef TkCreateMainWindow
+# define TkCreateMainWindow (*TkintdeclsVptr->V_TkCreateMainWindow)
+#endif
+
+#ifndef TkCreateRegion
+# define TkCreateRegion (*TkintdeclsVptr->V_TkCreateRegion)
+#endif
+
+#ifndef TkCurrentTime
+# define TkCurrentTime (*TkintdeclsVptr->V_TkCurrentTime)
+#endif
+
+#ifndef TkDebugBitmap
+# define TkDebugBitmap (*TkintdeclsVptr->V_TkDebugBitmap)
+#endif
+
+#ifndef TkDebugBorder
+# define TkDebugBorder (*TkintdeclsVptr->V_TkDebugBorder)
+#endif
+
+#ifndef TkDebugColor
+# define TkDebugColor (*TkintdeclsVptr->V_TkDebugColor)
+#endif
+
+#ifndef TkDebugConfig
+# define TkDebugConfig (*TkintdeclsVptr->V_TkDebugConfig)
+#endif
+
+#ifndef TkDebugCursor
+# define TkDebugCursor (*TkintdeclsVptr->V_TkDebugCursor)
+#endif
+
+#ifndef TkDebugFont
+# define TkDebugFont (*TkintdeclsVptr->V_TkDebugFont)
+#endif
+
+#ifndef TkDeleteAllImages
+# define TkDeleteAllImages (*TkintdeclsVptr->V_TkDeleteAllImages)
+#endif
+
+#ifndef TkDestroyRegion
+# define TkDestroyRegion (*TkintdeclsVptr->V_TkDestroyRegion)
+#endif
+
+#ifndef TkDoConfigureNotify
+# define TkDoConfigureNotify (*TkintdeclsVptr->V_TkDoConfigureNotify)
+#endif
+
+#ifndef TkDrawInsetFocusHighlight
+# define TkDrawInsetFocusHighlight (*TkintdeclsVptr->V_TkDrawInsetFocusHighlight)
+#endif
+
+#ifndef TkEventDeadWindow
+# define TkEventDeadWindow (*TkintdeclsVptr->V_TkEventDeadWindow)
+#endif
+
+#ifndef TkFindStateNum
+# define TkFindStateNum (*TkintdeclsVptr->V_TkFindStateNum)
+#endif
+
+#ifndef TkFindStateNumObj
+# define TkFindStateNumObj (*TkintdeclsVptr->V_TkFindStateNumObj)
+#endif
+
+#ifndef TkFindStateString
+# define TkFindStateString (*TkintdeclsVptr->V_TkFindStateString)
+#endif
+
+#ifndef TkFocusDeadWindow
+# define TkFocusDeadWindow (*TkintdeclsVptr->V_TkFocusDeadWindow)
+#endif
+
+#ifndef TkFocusFilterEvent
+# define TkFocusFilterEvent (*TkintdeclsVptr->V_TkFocusFilterEvent)
+#endif
+
+#ifndef TkFocusFree
+# define TkFocusFree (*TkintdeclsVptr->V_TkFocusFree)
+#endif
+
+#ifndef TkFocusKeyEvent
+# define TkFocusKeyEvent (*TkintdeclsVptr->V_TkFocusKeyEvent)
+#endif
+
+#ifndef TkFontPkgFree
+# define TkFontPkgFree (*TkintdeclsVptr->V_TkFontPkgFree)
+#endif
+
+#ifndef TkFontPkgInit
+# define TkFontPkgInit (*TkintdeclsVptr->V_TkFontPkgInit)
+#endif
+
+#ifndef TkFreeBindingTags
+# define TkFreeBindingTags (*TkintdeclsVptr->V_TkFreeBindingTags)
+#endif
+
+#ifndef TkGCCleanup
+# define TkGCCleanup (*TkintdeclsVptr->V_TkGCCleanup)
+#endif
+
+#ifndef TkGetBitmapData
+# define TkGetBitmapData (*TkintdeclsVptr->V_TkGetBitmapData)
+#endif
+
+#ifndef TkGetBitmapPredefTable
+# define TkGetBitmapPredefTable (*TkintdeclsVptr->V_TkGetBitmapPredefTable)
+#endif
+
+#ifndef TkGetCursorByName
+# define TkGetCursorByName (*TkintdeclsVptr->V_TkGetCursorByName)
+#endif
+
+#ifndef TkGetDefaultScreenName
+# define TkGetDefaultScreenName (*TkintdeclsVptr->V_TkGetDefaultScreenName)
+#endif
+
+#ifndef TkGetDisplay
+# define TkGetDisplay (*TkintdeclsVptr->V_TkGetDisplay)
+#endif
+
+#ifndef TkGetDisplayList
+# define TkGetDisplayList (*TkintdeclsVptr->V_TkGetDisplayList)
+#endif
+
+#ifndef TkGetDisplayOf
+# define TkGetDisplayOf (*TkintdeclsVptr->V_TkGetDisplayOf)
+#endif
+
+#ifndef TkGetFocusWin
+# define TkGetFocusWin (*TkintdeclsVptr->V_TkGetFocusWin)
+#endif
+
+#ifndef TkGetInterpNames
+# define TkGetInterpNames (*TkintdeclsVptr->V_TkGetInterpNames)
+#endif
+
+#ifndef TkGetMainInfoList
+# define TkGetMainInfoList (*TkintdeclsVptr->V_TkGetMainInfoList)
+#endif
+
+#ifndef TkGetOptionSpec
+# define TkGetOptionSpec (*TkintdeclsVptr->V_TkGetOptionSpec)
+#endif
+
+#ifndef TkGetPointerCoords
+# define TkGetPointerCoords (*TkintdeclsVptr->V_TkGetPointerCoords)
+#endif
+
+#ifndef TkGetServerInfo
+# define TkGetServerInfo (*TkintdeclsVptr->V_TkGetServerInfo)
+#endif
+
+#ifndef TkGetWindowFromObj
+# define TkGetWindowFromObj (*TkintdeclsVptr->V_TkGetWindowFromObj)
+#endif
+
+#ifndef TkGrabDeadWindow
+# define TkGrabDeadWindow (*TkintdeclsVptr->V_TkGrabDeadWindow)
+#endif
+
+#ifndef TkGrabState
+# define TkGrabState (*TkintdeclsVptr->V_TkGrabState)
+#endif
+
+#ifndef TkInOutEvents
+# define TkInOutEvents (*TkintdeclsVptr->V_TkInOutEvents)
+#endif
+
+#ifndef TkInstallFrameMenu
+# define TkInstallFrameMenu (*TkintdeclsVptr->V_TkInstallFrameMenu)
+#endif
+
+#ifndef TkIntersectRegion
+# define TkIntersectRegion (*TkintdeclsVptr->V_TkIntersectRegion)
+#endif
+
+#ifndef TkKeysymToString
+# define TkKeysymToString (*TkintdeclsVptr->V_TkKeysymToString)
+#endif
+
+#ifndef TkPhotoGetValidRegion
+# define TkPhotoGetValidRegion (*TkintdeclsVptr->V_TkPhotoGetValidRegion)
+#endif
+
+#ifndef TkPointerEvent
+# define TkPointerEvent (*TkintdeclsVptr->V_TkPointerEvent)
+#endif
+
+#ifndef TkPositionInTree
+# define TkPositionInTree (*TkintdeclsVptr->V_TkPositionInTree)
+#endif
+
+#ifndef TkQueueEventForAllChildren
+# define TkQueueEventForAllChildren (*TkintdeclsVptr->V_TkQueueEventForAllChildren)
+#endif
+
+#ifndef TkReadBitmapFile
+# define TkReadBitmapFile (*TkintdeclsVptr->V_TkReadBitmapFile)
+#endif
+
+#ifndef TkRectInRegion
+# define TkRectInRegion (*TkintdeclsVptr->V_TkRectInRegion)
+#endif
+
+#ifndef TkScrollWindow
+# define TkScrollWindow (*TkintdeclsVptr->V_TkScrollWindow)
+#endif
+
+#ifndef TkSelDeadWindow
+# define TkSelDeadWindow (*TkintdeclsVptr->V_TkSelDeadWindow)
+#endif
+
+#ifndef TkSelEventProc
+# define TkSelEventProc (*TkintdeclsVptr->V_TkSelEventProc)
+#endif
+
+#ifndef TkSelInit
+# define TkSelInit (*TkintdeclsVptr->V_TkSelInit)
+#endif
+
+#ifndef TkSelPropProc
+# define TkSelPropProc (*TkintdeclsVptr->V_TkSelPropProc)
+#endif
+
+#ifndef TkSetFocusWin
+# define TkSetFocusWin (*TkintdeclsVptr->V_TkSetFocusWin)
+#endif
+
+#ifndef TkSetRegion
+# define TkSetRegion (*TkintdeclsVptr->V_TkSetRegion)
+#endif
+
+#ifndef TkSetWindowMenuBar
+# define TkSetWindowMenuBar (*TkintdeclsVptr->V_TkSetWindowMenuBar)
+#endif
+
+#ifndef TkStringToKeysym
+# define TkStringToKeysym (*TkintdeclsVptr->V_TkStringToKeysym)
+#endif
+
+#ifndef TkStylePkgFree
+# define TkStylePkgFree (*TkintdeclsVptr->V_TkStylePkgFree)
+#endif
+
+#ifndef TkStylePkgInit
+# define TkStylePkgInit (*TkintdeclsVptr->V_TkStylePkgInit)
+#endif
+
+#ifndef TkSubtractRegion
+# define TkSubtractRegion (*TkintdeclsVptr->V_TkSubtractRegion)
+#endif
+
+#ifndef TkToplevelWindowForCommand
+# define TkToplevelWindowForCommand (*TkintdeclsVptr->V_TkToplevelWindowForCommand)
+#endif
+
+#ifndef TkUnionRectWithRegion
+# define TkUnionRectWithRegion (*TkintdeclsVptr->V_TkUnionRectWithRegion)
+#endif
+
+#ifndef TkWmAddToColormapWindows
+# define TkWmAddToColormapWindows (*TkintdeclsVptr->V_TkWmAddToColormapWindows)
+#endif
+
+#ifndef TkWmDeadWindow
+# define TkWmDeadWindow (*TkintdeclsVptr->V_TkWmDeadWindow)
+#endif
+
+#ifndef TkWmFocusToplevel
+# define TkWmFocusToplevel (*TkintdeclsVptr->V_TkWmFocusToplevel)
+#endif
+
+#ifndef TkWmMapWindow
+# define TkWmMapWindow (*TkintdeclsVptr->V_TkWmMapWindow)
+#endif
+
+#ifndef TkWmNewWindow
+# define TkWmNewWindow (*TkintdeclsVptr->V_TkWmNewWindow)
+#endif
+
+#ifndef TkWmProtocolEventProc
+# define TkWmProtocolEventProc (*TkintdeclsVptr->V_TkWmProtocolEventProc)
+#endif
+
+#ifndef TkWmRemoveFromColormapWindows
+# define TkWmRemoveFromColormapWindows (*TkintdeclsVptr->V_TkWmRemoveFromColormapWindows)
+#endif
+
+#ifndef TkWmRestackToplevel
+# define TkWmRestackToplevel (*TkintdeclsVptr->V_TkWmRestackToplevel)
+#endif
+
+#ifndef TkWmSetClass
+# define TkWmSetClass (*TkintdeclsVptr->V_TkWmSetClass)
+#endif
+
+#ifndef TkWmStackorderToplevel
+# define TkWmStackorderToplevel (*TkintdeclsVptr->V_TkWmStackorderToplevel)
+#endif
+
+#ifndef TkWmUnmapWindow
+# define TkWmUnmapWindow (*TkintdeclsVptr->V_TkWmUnmapWindow)
+#endif
+
+#ifndef TkpChangeFocus
+# define TkpChangeFocus (*TkintdeclsVptr->V_TkpChangeFocus)
+#endif
+
+#ifndef TkpClaimFocus
+# define TkpClaimFocus (*TkintdeclsVptr->V_TkpClaimFocus)
+#endif
+
+#ifndef TkpCloseDisplay
+# define TkpCloseDisplay (*TkintdeclsVptr->V_TkpCloseDisplay)
+#endif
+
+#ifndef TkpDisplayWarning
+# define TkpDisplayWarning (*TkintdeclsVptr->V_TkpDisplayWarning)
+#endif
+
+#ifndef TkpDrawHighlightBorder
+# define TkpDrawHighlightBorder (*TkintdeclsVptr->V_TkpDrawHighlightBorder)
+#endif
+
+#ifndef TkpFreeCursor
+# define TkpFreeCursor (*TkintdeclsVptr->V_TkpFreeCursor)
+#endif
+
+#ifndef TkpGetKeySym
+# define TkpGetKeySym (*TkintdeclsVptr->V_TkpGetKeySym)
+#endif
+
+#ifndef TkpGetOtherWindow
+# define TkpGetOtherWindow (*TkintdeclsVptr->V_TkpGetOtherWindow)
+#endif
+
+#ifndef TkpGetString
+# define TkpGetString (*TkintdeclsVptr->V_TkpGetString)
+#endif
+
+#ifndef TkpGetSubFonts
+# define TkpGetSubFonts (*TkintdeclsVptr->V_TkpGetSubFonts)
+#endif
+
+#ifndef TkpGetSystemDefault
+# define TkpGetSystemDefault (*TkintdeclsVptr->V_TkpGetSystemDefault)
+#endif
+
+#ifndef TkpGetWrapperWindow
+# define TkpGetWrapperWindow (*TkintdeclsVptr->V_TkpGetWrapperWindow)
+#endif
+
+#ifndef TkpInitKeymapInfo
+# define TkpInitKeymapInfo (*TkintdeclsVptr->V_TkpInitKeymapInfo)
+#endif
+
+#ifndef TkpInitializeMenuBindings
+# define TkpInitializeMenuBindings (*TkintdeclsVptr->V_TkpInitializeMenuBindings)
+#endif
+
+#ifndef TkpMakeContainer
+# define TkpMakeContainer (*TkintdeclsVptr->V_TkpMakeContainer)
+#endif
+
+#ifndef TkpMakeMenuWindow
+# define TkpMakeMenuWindow (*TkintdeclsVptr->V_TkpMakeMenuWindow)
+#endif
+
+#ifndef TkpMakeWindow
+# define TkpMakeWindow (*TkintdeclsVptr->V_TkpMakeWindow)
+#endif
+
+#ifndef TkpMenuNotifyToplevelCreate
+# define TkpMenuNotifyToplevelCreate (*TkintdeclsVptr->V_TkpMenuNotifyToplevelCreate)
+#endif
+
+#ifndef TkpMenuThreadInit
+# define TkpMenuThreadInit (*TkintdeclsVptr->V_TkpMenuThreadInit)
+#endif
+
+#ifndef TkpOpenDisplay
+# define TkpOpenDisplay (*TkintdeclsVptr->V_TkpOpenDisplay)
+#endif
+
+#ifndef TkpRedirectKeyEvent
+# define TkpRedirectKeyEvent (*TkintdeclsVptr->V_TkpRedirectKeyEvent)
+#endif
+
+#ifndef TkpSetKeycodeAndState
+# define TkpSetKeycodeAndState (*TkintdeclsVptr->V_TkpSetKeycodeAndState)
+#endif
+
+#ifndef TkpSetMainMenubar
+# define TkpSetMainMenubar (*TkintdeclsVptr->V_TkpSetMainMenubar)
+#endif
+
+#ifndef TkpUseWindow
+# define TkpUseWindow (*TkintdeclsVptr->V_TkpUseWindow)
+#endif
+
+#ifndef TkpWindowWasRecentlyDeleted
+# define TkpWindowWasRecentlyDeleted (*TkintdeclsVptr->V_TkpWindowWasRecentlyDeleted)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKINTDECLS_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.t
new file mode 100755
index 00000000000..b2a83a8f4fb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls.t
@@ -0,0 +1,642 @@
+#ifdef _TKINTDECLS
+#ifndef TkAllocWindow
+VFUNC(TkWindow *,TkAllocWindow,V_TkAllocWindow,_ANSI_ARGS_((TkDisplay * dispPtr,
+ int screenNum, TkWindow * parentPtr)))
+#endif /* #ifndef TkAllocWindow */
+
+#ifndef TkBindDeadWindow
+VFUNC(void,TkBindDeadWindow,V_TkBindDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkBindDeadWindow */
+
+#ifndef TkBindEventProc
+VFUNC(void,TkBindEventProc,V_TkBindEventProc,_ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr)))
+#endif /* #ifndef TkBindEventProc */
+
+#ifndef TkBindFree
+VFUNC(void,TkBindFree,V_TkBindFree,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkBindFree */
+
+#ifndef TkBindInit
+VFUNC(void,TkBindInit,V_TkBindInit,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkBindInit */
+
+#ifndef TkChangeEventWindow
+VFUNC(void,TkChangeEventWindow,V_TkChangeEventWindow,_ANSI_ARGS_((XEvent * eventPtr,
+ TkWindow * winPtr)))
+#endif /* #ifndef TkChangeEventWindow */
+
+#ifndef TkClipBox
+#ifdef MAC_OSX_TK
+VFUNC(void,TkClipBox,V_TkClipBox,_ANSI_ARGS_((TkRegion rgn,
+ XRectangle* rect_return)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkClipBox,V_TkClipBox,_ANSI_ARGS_((TkRegion rgn,
+ XRectangle* rect_return)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkClipBox,V_TkClipBox,_ANSI_ARGS_((TkRegion rgn,
+ XRectangle* rect_return)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkClipBox */
+
+#ifndef TkClipCleanup
+VFUNC(void,TkClipCleanup,V_TkClipCleanup,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #ifndef TkClipCleanup */
+
+#ifndef TkClipInit
+VFUNC(int,TkClipInit,V_TkClipInit,_ANSI_ARGS_((Tcl_Interp * interp,
+ TkDisplay * dispPtr)))
+#endif /* #ifndef TkClipInit */
+
+#ifndef TkComputeAnchor
+VFUNC(void,TkComputeAnchor,V_TkComputeAnchor,_ANSI_ARGS_((Tk_Anchor anchor,
+ Tk_Window tkwin, int padX, int padY,
+ int innerWidth, int innerHeight, int * xPtr,
+ int * yPtr)))
+#endif /* #ifndef TkComputeAnchor */
+
+#ifndef TkCopyAndGlobalEval
+VFUNC(int,TkCopyAndGlobalEval,V_TkCopyAndGlobalEval,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * script)))
+#endif /* #ifndef TkCopyAndGlobalEval */
+
+#ifndef TkCreateBindingProcedure
+VFUNC(unsigned long,TkCreateBindingProcedure,V_TkCreateBindingProcedure,_ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tk_BindingTable bindingTable,
+ ClientData object, CONST char * eventString,
+ TkBindEvalProc * evalProc,
+ TkBindFreeProc * freeProc,
+ ClientData clientData)))
+#endif /* #ifndef TkCreateBindingProcedure */
+
+#ifndef TkCreateCursorFromData
+VFUNC(TkCursor *,TkCreateCursorFromData,V_TkCreateCursorFromData,_ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * source, CONST char * mask,
+ int width, int height, int xHot, int yHot,
+ XColor fg, XColor bg)))
+#endif /* #ifndef TkCreateCursorFromData */
+
+#ifndef TkCreateFrame
+VFUNC(int,TkCreateFrame,V_TkCreateFrame,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, int argc, Tcl_Obj *CONST *objv,
+ int toplevel, char * appName)))
+#endif /* #ifndef TkCreateFrame */
+
+#ifndef TkCreateMainWindow
+VFUNC(Tk_Window,TkCreateMainWindow,V_TkCreateMainWindow,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * screenName, char * baseName)))
+#endif /* #ifndef TkCreateMainWindow */
+
+#ifndef TkCreateRegion
+#ifdef MAC_OSX_TK
+VFUNC(TkRegion,TkCreateRegion,V_TkCreateRegion,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(TkRegion,TkCreateRegion,V_TkCreateRegion,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(TkRegion,TkCreateRegion,V_TkCreateRegion,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkCreateRegion */
+
+#ifndef TkCurrentTime
+VFUNC(Time,TkCurrentTime,V_TkCurrentTime,_ANSI_ARGS_((TkDisplay * dispPtr,
+ int fallbackCurrent)))
+#endif /* #ifndef TkCurrentTime */
+
+#ifndef TkDebugBitmap
+VFUNC(Tcl_Obj *,TkDebugBitmap,V_TkDebugBitmap,_ANSI_ARGS_((Tk_Window tkwin,
+ char * name)))
+#endif /* #ifndef TkDebugBitmap */
+
+#ifndef TkDebugBorder
+VFUNC(Tcl_Obj *,TkDebugBorder,V_TkDebugBorder,_ANSI_ARGS_((Tk_Window tkwin,
+ char * name)))
+#endif /* #ifndef TkDebugBorder */
+
+#ifndef TkDebugColor
+VFUNC(Tcl_Obj *,TkDebugColor,V_TkDebugColor,_ANSI_ARGS_((Tk_Window tkwin,
+ char * name)))
+#endif /* #ifndef TkDebugColor */
+
+#ifndef TkDebugConfig
+VFUNC(Tcl_Obj *,TkDebugConfig,V_TkDebugConfig,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_OptionTable table)))
+#endif /* #ifndef TkDebugConfig */
+
+#ifndef TkDebugCursor
+VFUNC(Tcl_Obj *,TkDebugCursor,V_TkDebugCursor,_ANSI_ARGS_((Tk_Window tkwin,
+ char * name)))
+#endif /* #ifndef TkDebugCursor */
+
+#ifndef TkDebugFont
+VFUNC(Tcl_Obj *,TkDebugFont,V_TkDebugFont,_ANSI_ARGS_((Tk_Window tkwin,
+ char * name)))
+#endif /* #ifndef TkDebugFont */
+
+#ifndef TkDeleteAllImages
+VFUNC(void,TkDeleteAllImages,V_TkDeleteAllImages,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkDeleteAllImages */
+
+#ifndef TkDestroyRegion
+#ifdef MAC_OSX_TK
+VFUNC(void,TkDestroyRegion,V_TkDestroyRegion,_ANSI_ARGS_((TkRegion rgn)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkDestroyRegion,V_TkDestroyRegion,_ANSI_ARGS_((TkRegion rgn)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkDestroyRegion,V_TkDestroyRegion,_ANSI_ARGS_((TkRegion rgn)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkDestroyRegion */
+
+#ifndef TkDoConfigureNotify
+VFUNC(void,TkDoConfigureNotify,V_TkDoConfigureNotify,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkDoConfigureNotify */
+
+#ifndef TkDrawInsetFocusHighlight
+VFUNC(void,TkDrawInsetFocusHighlight,V_TkDrawInsetFocusHighlight,_ANSI_ARGS_((
+ Tk_Window tkwin, GC gc, int width,
+ Drawable drawable, int padding)))
+#endif /* #ifndef TkDrawInsetFocusHighlight */
+
+#ifndef TkEventDeadWindow
+VFUNC(void,TkEventDeadWindow,V_TkEventDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkEventDeadWindow */
+
+#ifndef TkFindStateNum
+VFUNC(int,TkFindStateNum,V_TkFindStateNum,_ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * option,
+ CONST TkStateMap * mapPtr,
+ CONST char * strKey)))
+#endif /* #ifndef TkFindStateNum */
+
+#ifndef TkFindStateNumObj
+VFUNC(int,TkFindStateNumObj,V_TkFindStateNumObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * optionPtr,
+ CONST TkStateMap * mapPtr, Tcl_Obj * keyPtr)))
+#endif /* #ifndef TkFindStateNumObj */
+
+#ifndef TkFindStateString
+VFUNC(char *,TkFindStateString,V_TkFindStateString,_ANSI_ARGS_((
+ CONST TkStateMap * mapPtr, int numKey)))
+#endif /* #ifndef TkFindStateString */
+
+#ifndef TkFocusDeadWindow
+VFUNC(void,TkFocusDeadWindow,V_TkFocusDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkFocusDeadWindow */
+
+#ifndef TkFocusFilterEvent
+VFUNC(int,TkFocusFilterEvent,V_TkFocusFilterEvent,_ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr)))
+#endif /* #ifndef TkFocusFilterEvent */
+
+#ifndef TkFocusFree
+VFUNC(void,TkFocusFree,V_TkFocusFree,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkFocusFree */
+
+#ifndef TkFocusKeyEvent
+VFUNC(TkWindow *,TkFocusKeyEvent,V_TkFocusKeyEvent,_ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr)))
+#endif /* #ifndef TkFocusKeyEvent */
+
+#ifndef TkFontPkgFree
+VFUNC(void,TkFontPkgFree,V_TkFontPkgFree,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkFontPkgFree */
+
+#ifndef TkFontPkgInit
+VFUNC(void,TkFontPkgInit,V_TkFontPkgInit,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkFontPkgInit */
+
+#ifndef TkFreeBindingTags
+VFUNC(void,TkFreeBindingTags,V_TkFreeBindingTags,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkFreeBindingTags */
+
+#ifndef TkGCCleanup
+VFUNC(void,TkGCCleanup,V_TkGCCleanup,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #ifndef TkGCCleanup */
+
+#ifndef TkGetBitmapData
+VFUNC(char *,TkGetBitmapData,V_TkGetBitmapData,_ANSI_ARGS_((Tcl_Interp * interp,
+ char * string, char * fileName,
+ int * widthPtr, int * heightPtr,
+ int * hotXPtr, int * hotYPtr)))
+#endif /* #ifndef TkGetBitmapData */
+
+#ifndef TkGetBitmapPredefTable
+VFUNC(Tcl_HashTable *,TkGetBitmapPredefTable,V_TkGetBitmapPredefTable,_ANSI_ARGS_((void)))
+#endif /* #ifndef TkGetBitmapPredefTable */
+
+#ifndef TkGetCursorByName
+VFUNC(TkCursor *,TkGetCursorByName,V_TkGetCursorByName,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tk_Uid string)))
+#endif /* #ifndef TkGetCursorByName */
+
+#ifndef TkGetDefaultScreenName
+VFUNC(CONST84_RETURN char *,TkGetDefaultScreenName,V_TkGetDefaultScreenName,_ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * screenName)))
+#endif /* #ifndef TkGetDefaultScreenName */
+
+#ifndef TkGetDisplay
+VFUNC(TkDisplay *,TkGetDisplay,V_TkGetDisplay,_ANSI_ARGS_((Display * display)))
+#endif /* #ifndef TkGetDisplay */
+
+#ifndef TkGetDisplayList
+VFUNC(TkDisplay *,TkGetDisplayList,V_TkGetDisplayList,_ANSI_ARGS_((void)))
+#endif /* #ifndef TkGetDisplayList */
+
+#ifndef TkGetDisplayOf
+VFUNC(int,TkGetDisplayOf,V_TkGetDisplayOf,_ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[],
+ Tk_Window * tkwinPtr)))
+#endif /* #ifndef TkGetDisplayOf */
+
+#ifndef TkGetFocusWin
+VFUNC(TkWindow *,TkGetFocusWin,V_TkGetFocusWin,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkGetFocusWin */
+
+#ifndef TkGetInterpNames
+VFUNC(int,TkGetInterpNames,V_TkGetInterpNames,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin)))
+#endif /* #ifndef TkGetInterpNames */
+
+#ifndef TkGetMainInfoList
+VFUNC(TkMainInfo *,TkGetMainInfoList,V_TkGetMainInfoList,_ANSI_ARGS_((void)))
+#endif /* #ifndef TkGetMainInfoList */
+
+#ifndef TkGetOptionSpec
+VFUNC(CONST Tk_OptionSpec *,TkGetOptionSpec,V_TkGetOptionSpec,_ANSI_ARGS_((CONST char * name,
+ Tk_OptionTable optionTable)))
+#endif /* #ifndef TkGetOptionSpec */
+
+#ifndef TkGetPointerCoords
+VFUNC(void,TkGetPointerCoords,V_TkGetPointerCoords,_ANSI_ARGS_((Tk_Window tkwin,
+ int * xPtr, int * yPtr)))
+#endif /* #ifndef TkGetPointerCoords */
+
+#ifndef TkGetServerInfo
+VFUNC(void,TkGetServerInfo,V_TkGetServerInfo,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin)))
+#endif /* #ifndef TkGetServerInfo */
+
+#ifndef TkGetWindowFromObj
+VFUNC(int,TkGetWindowFromObj,V_TkGetWindowFromObj,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj * objPtr,
+ Tk_Window * windowPtr)))
+#endif /* #ifndef TkGetWindowFromObj */
+
+#ifndef TkGrabDeadWindow
+VFUNC(void,TkGrabDeadWindow,V_TkGrabDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkGrabDeadWindow */
+
+#ifndef TkGrabState
+VFUNC(int,TkGrabState,V_TkGrabState,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkGrabState */
+
+#ifndef TkInOutEvents
+VFUNC(void,TkInOutEvents,V_TkInOutEvents,_ANSI_ARGS_((XEvent * eventPtr,
+ TkWindow * sourcePtr, TkWindow * destPtr,
+ int leaveType, int enterType,
+ Tcl_QueuePosition position)))
+#endif /* #ifndef TkInOutEvents */
+
+#ifndef TkInstallFrameMenu
+VFUNC(void,TkInstallFrameMenu,V_TkInstallFrameMenu,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef TkInstallFrameMenu */
+
+#ifndef TkIntersectRegion
+#ifdef MAC_OSX_TK
+VFUNC(void,TkIntersectRegion,V_TkIntersectRegion,_ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkIntersectRegion,V_TkIntersectRegion,_ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkIntersectRegion,V_TkIntersectRegion,_ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkIntersectRegion */
+
+#ifndef TkKeysymToString
+VFUNC(char *,TkKeysymToString,V_TkKeysymToString,_ANSI_ARGS_((KeySym keysym)))
+#endif /* #ifndef TkKeysymToString */
+
+#ifndef TkPhotoGetValidRegion
+VFUNC(TkRegion,TkPhotoGetValidRegion,V_TkPhotoGetValidRegion,_ANSI_ARGS_((
+ Tk_PhotoHandle handle)))
+#endif /* #ifndef TkPhotoGetValidRegion */
+
+#ifndef TkPointerEvent
+VFUNC(int,TkPointerEvent,V_TkPointerEvent,_ANSI_ARGS_((XEvent * eventPtr,
+ TkWindow * winPtr)))
+#endif /* #ifndef TkPointerEvent */
+
+#ifndef TkPositionInTree
+VFUNC(int,TkPositionInTree,V_TkPositionInTree,_ANSI_ARGS_((TkWindow * winPtr,
+ TkWindow * treePtr)))
+#endif /* #ifndef TkPositionInTree */
+
+#ifndef TkQueueEventForAllChildren
+VFUNC(void,TkQueueEventForAllChildren,V_TkQueueEventForAllChildren,_ANSI_ARGS_((
+ TkWindow * winPtr, XEvent * eventPtr)))
+#endif /* #ifndef TkQueueEventForAllChildren */
+
+#ifndef TkReadBitmapFile
+VFUNC(int,TkReadBitmapFile,V_TkReadBitmapFile,_ANSI_ARGS_((Tcl_Interp * interp,
+ Display* display,
+ Drawable d, CONST char* filename,
+ unsigned int* width_return,
+ unsigned int* height_return,
+ Pixmap* bitmap_return, int* x_hot_return,
+ int* y_hot_return)))
+#endif /* #ifndef TkReadBitmapFile */
+
+#ifndef TkRectInRegion
+#ifdef MAC_OSX_TK
+VFUNC(int,TkRectInRegion,V_TkRectInRegion,_ANSI_ARGS_((TkRegion rgn, int x,
+ int y, unsigned int width,
+ unsigned int height)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,TkRectInRegion,V_TkRectInRegion,_ANSI_ARGS_((TkRegion rgn, int x,
+ int y, unsigned int width,
+ unsigned int height)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(int,TkRectInRegion,V_TkRectInRegion,_ANSI_ARGS_((TkRegion rgn, int x,
+ int y, unsigned int width,
+ unsigned int height)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkRectInRegion */
+
+#ifndef TkScrollWindow
+VFUNC(int,TkScrollWindow,V_TkScrollWindow,_ANSI_ARGS_((Tk_Window tkwin, GC gc,
+ int x, int y, int width, int height, int dx,
+ int dy, TkRegion damageRgn)))
+#endif /* #ifndef TkScrollWindow */
+
+#ifndef TkSelDeadWindow
+VFUNC(void,TkSelDeadWindow,V_TkSelDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkSelDeadWindow */
+
+#ifndef TkSelEventProc
+VFUNC(void,TkSelEventProc,V_TkSelEventProc,_ANSI_ARGS_((Tk_Window tkwin,
+ XEvent * eventPtr)))
+#endif /* #ifndef TkSelEventProc */
+
+#ifndef TkSelInit
+VFUNC(void,TkSelInit,V_TkSelInit,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef TkSelInit */
+
+#ifndef TkSelPropProc
+VFUNC(void,TkSelPropProc,V_TkSelPropProc,_ANSI_ARGS_((XEvent * eventPtr)))
+#endif /* #ifndef TkSelPropProc */
+
+#ifndef TkSetFocusWin
+VFUNC(void,TkSetFocusWin,V_TkSetFocusWin,_ANSI_ARGS_((TkWindow * winPtr,
+ int force)))
+#endif /* #ifndef TkSetFocusWin */
+
+#ifndef TkSetRegion
+#ifdef MAC_OSX_TK
+VFUNC(void,TkSetRegion,V_TkSetRegion,_ANSI_ARGS_((Display* display, GC gc,
+ TkRegion rgn)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkSetRegion,V_TkSetRegion,_ANSI_ARGS_((Display* display, GC gc,
+ TkRegion rgn)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkSetRegion,V_TkSetRegion,_ANSI_ARGS_((Display* display, GC gc,
+ TkRegion rgn)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkSetRegion */
+
+#ifndef TkSetWindowMenuBar
+VFUNC(void,TkSetWindowMenuBar,V_TkSetWindowMenuBar,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj *oldMenuName,
+ Tcl_Obj *menuName)))
+#endif /* #ifndef TkSetWindowMenuBar */
+
+#ifndef TkStringToKeysym
+VFUNC(KeySym,TkStringToKeysym,V_TkStringToKeysym,_ANSI_ARGS_((char * name)))
+#endif /* #ifndef TkStringToKeysym */
+
+#ifndef TkStylePkgFree
+VFUNC(void,TkStylePkgFree,V_TkStylePkgFree,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkStylePkgFree */
+
+#ifndef TkStylePkgInit
+VFUNC(void,TkStylePkgInit,V_TkStylePkgInit,_ANSI_ARGS_((TkMainInfo * mainPtr)))
+#endif /* #ifndef TkStylePkgInit */
+
+#ifndef TkSubtractRegion
+#ifdef MAC_OSX_TK
+VFUNC(void,TkSubtractRegion,V_TkSubtractRegion,_ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkSubtractRegion,V_TkSubtractRegion,_ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkSubtractRegion,V_TkSubtractRegion,_ANSI_ARGS_((TkRegion sra,
+ TkRegion srcb, TkRegion dr_return)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkSubtractRegion */
+
+#ifndef TkToplevelWindowForCommand
+VFUNC(Tk_Window,TkToplevelWindowForCommand,V_TkToplevelWindowForCommand,_ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * cmdName)))
+#endif /* #ifndef TkToplevelWindowForCommand */
+
+#ifndef TkUnionRectWithRegion
+#ifdef MAC_OSX_TK
+VFUNC(void,TkUnionRectWithRegion,V_TkUnionRectWithRegion,_ANSI_ARGS_((XRectangle* rect,
+ TkRegion src, TkRegion dr_return)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkUnionRectWithRegion,V_TkUnionRectWithRegion,_ANSI_ARGS_((XRectangle* rect,
+ TkRegion src, TkRegion dr_return)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkUnionRectWithRegion,V_TkUnionRectWithRegion,_ANSI_ARGS_((XRectangle* rect,
+ TkRegion src, TkRegion dr_return)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkUnionRectWithRegion */
+
+#ifndef TkWmAddToColormapWindows
+VFUNC(void,TkWmAddToColormapWindows,V_TkWmAddToColormapWindows,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifndef TkWmAddToColormapWindows */
+
+#ifndef TkWmDeadWindow
+VFUNC(void,TkWmDeadWindow,V_TkWmDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkWmDeadWindow */
+
+#ifndef TkWmFocusToplevel
+VFUNC(TkWindow *,TkWmFocusToplevel,V_TkWmFocusToplevel,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkWmFocusToplevel */
+
+#ifndef TkWmMapWindow
+VFUNC(void,TkWmMapWindow,V_TkWmMapWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkWmMapWindow */
+
+#ifndef TkWmNewWindow
+VFUNC(void,TkWmNewWindow,V_TkWmNewWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkWmNewWindow */
+
+#ifndef TkWmProtocolEventProc
+VFUNC(void,TkWmProtocolEventProc,V_TkWmProtocolEventProc,_ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * evenvPtr)))
+#endif /* #ifndef TkWmProtocolEventProc */
+
+#ifndef TkWmRemoveFromColormapWindows
+VFUNC(void,TkWmRemoveFromColormapWindows,V_TkWmRemoveFromColormapWindows,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifndef TkWmRemoveFromColormapWindows */
+
+#ifndef TkWmRestackToplevel
+VFUNC(void,TkWmRestackToplevel,V_TkWmRestackToplevel,_ANSI_ARGS_((TkWindow * winPtr,
+ int aboveBelow, TkWindow * otherPtr)))
+#endif /* #ifndef TkWmRestackToplevel */
+
+#ifndef TkWmSetClass
+VFUNC(void,TkWmSetClass,V_TkWmSetClass,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkWmSetClass */
+
+#ifndef TkWmStackorderToplevel
+VFUNC(TkWindow **,TkWmStackorderToplevel,V_TkWmStackorderToplevel,_ANSI_ARGS_((
+ TkWindow * parentPtr)))
+#endif /* #ifndef TkWmStackorderToplevel */
+
+#ifndef TkWmUnmapWindow
+VFUNC(void,TkWmUnmapWindow,V_TkWmUnmapWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkWmUnmapWindow */
+
+#ifndef TkpChangeFocus
+VFUNC(int,TkpChangeFocus,V_TkpChangeFocus,_ANSI_ARGS_((TkWindow * winPtr,
+ int force)))
+#endif /* #ifndef TkpChangeFocus */
+
+#ifndef TkpClaimFocus
+VFUNC(void,TkpClaimFocus,V_TkpClaimFocus,_ANSI_ARGS_((TkWindow * topLevelPtr,
+ int force)))
+#endif /* #ifndef TkpClaimFocus */
+
+#ifndef TkpCloseDisplay
+VFUNC(void,TkpCloseDisplay,V_TkpCloseDisplay,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #ifndef TkpCloseDisplay */
+
+#ifndef TkpDisplayWarning
+VFUNC(void,TkpDisplayWarning,V_TkpDisplayWarning,_ANSI_ARGS_((CONST char * msg,
+ CONST char * title)))
+#endif /* #ifndef TkpDisplayWarning */
+
+#ifndef TkpDrawHighlightBorder
+VFUNC(void,TkpDrawHighlightBorder,V_TkpDrawHighlightBorder,_ANSI_ARGS_((Tk_Window tkwin,
+ GC fgGC, GC bgGC, int highlightWidth,
+ Drawable drawable)))
+#endif /* #ifndef TkpDrawHighlightBorder */
+
+#ifndef TkpFreeCursor
+VFUNC(void,TkpFreeCursor,V_TkpFreeCursor,_ANSI_ARGS_((TkCursor * cursorPtr)))
+#endif /* #ifndef TkpFreeCursor */
+
+#ifndef TkpGetKeySym
+VFUNC(KeySym,TkpGetKeySym,V_TkpGetKeySym,_ANSI_ARGS_((TkDisplay * dispPtr,
+ XEvent * eventPtr)))
+#endif /* #ifndef TkpGetKeySym */
+
+#ifndef TkpGetOtherWindow
+VFUNC(TkWindow *,TkpGetOtherWindow,V_TkpGetOtherWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkpGetOtherWindow */
+
+#ifndef TkpGetString
+VFUNC(char *,TkpGetString,V_TkpGetString,_ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr, Tcl_DString * dsPtr)))
+#endif /* #ifndef TkpGetString */
+
+#ifndef TkpGetSubFonts
+VFUNC(void,TkpGetSubFonts,V_TkpGetSubFonts,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Font tkfont)))
+#endif /* #ifndef TkpGetSubFonts */
+
+#ifndef TkpGetSystemDefault
+VFUNC(Tcl_Obj *,TkpGetSystemDefault,V_TkpGetSystemDefault,_ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * dbName, CONST char * className)))
+#endif /* #ifndef TkpGetSystemDefault */
+
+#ifndef TkpGetWrapperWindow
+VFUNC(TkWindow *,TkpGetWrapperWindow,V_TkpGetWrapperWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifndef TkpGetWrapperWindow */
+
+#ifndef TkpInitKeymapInfo
+VFUNC(void,TkpInitKeymapInfo,V_TkpInitKeymapInfo,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #ifndef TkpInitKeymapInfo */
+
+#ifndef TkpInitializeMenuBindings
+VFUNC(void,TkpInitializeMenuBindings,V_TkpInitializeMenuBindings,_ANSI_ARGS_((
+ Tcl_Interp * interp,
+ Tk_BindingTable bindingTable)))
+#endif /* #ifndef TkpInitializeMenuBindings */
+
+#ifndef TkpMakeContainer
+VFUNC(void,TkpMakeContainer,V_TkpMakeContainer,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef TkpMakeContainer */
+
+#ifndef TkpMakeMenuWindow
+VFUNC(void,TkpMakeMenuWindow,V_TkpMakeMenuWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ int transient)))
+#endif /* #ifndef TkpMakeMenuWindow */
+
+#ifndef TkpMakeWindow
+VFUNC(Window,TkpMakeWindow,V_TkpMakeWindow,_ANSI_ARGS_((TkWindow * winPtr,
+ Window parent)))
+#endif /* #ifndef TkpMakeWindow */
+
+#ifndef TkpMenuNotifyToplevelCreate
+VFUNC(void,TkpMenuNotifyToplevelCreate,V_TkpMenuNotifyToplevelCreate,_ANSI_ARGS_((
+ Tcl_Interp * interp1, char * menuName)))
+#endif /* #ifndef TkpMenuNotifyToplevelCreate */
+
+#ifndef TkpMenuThreadInit
+VFUNC(void,TkpMenuThreadInit,V_TkpMenuThreadInit,_ANSI_ARGS_((void)))
+#endif /* #ifndef TkpMenuThreadInit */
+
+#ifndef TkpOpenDisplay
+VFUNC(TkDisplay *,TkpOpenDisplay,V_TkpOpenDisplay,_ANSI_ARGS_((
+ CONST char * display_name)))
+#endif /* #ifndef TkpOpenDisplay */
+
+#ifndef TkpRedirectKeyEvent
+VFUNC(void,TkpRedirectKeyEvent,V_TkpRedirectKeyEvent,_ANSI_ARGS_((TkWindow * winPtr,
+ XEvent * eventPtr)))
+#endif /* #ifndef TkpRedirectKeyEvent */
+
+#ifndef TkpSetKeycodeAndState
+VFUNC(void,TkpSetKeycodeAndState,V_TkpSetKeycodeAndState,_ANSI_ARGS_((Tk_Window tkwin,
+ KeySym keySym, XEvent * eventPtr)))
+#endif /* #ifndef TkpSetKeycodeAndState */
+
+#ifndef TkpSetMainMenubar
+VFUNC(void,TkpSetMainMenubar,V_TkpSetMainMenubar,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, char * menuName)))
+#endif /* #ifndef TkpSetMainMenubar */
+
+#ifndef TkpUseWindow
+VFUNC(int,TkpUseWindow,V_TkpUseWindow,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tk_Window tkwin, Tcl_Obj *string)))
+#endif /* #ifndef TkpUseWindow */
+
+#ifndef TkpWindowWasRecentlyDeleted
+VFUNC(int,TkpWindowWasRecentlyDeleted,V_TkpWindowWasRecentlyDeleted,_ANSI_ARGS_((Window win,
+ TkDisplay * dispPtr)))
+#endif /* #ifndef TkpWindowWasRecentlyDeleted */
+
+#endif /* _TKINTDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls_f.h
new file mode 100755
index 00000000000..3300cb56427
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntDecls_f.h
@@ -0,0 +1,14 @@
+#ifndef TKINTDECLS_VT
+#define TKINTDECLS_VT
+typedef struct TkintdeclsVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkIntDecls.t"
+#undef VFUNC
+#undef VVAR
+} TkintdeclsVtab;
+extern TkintdeclsVtab *TkintdeclsVptr;
+extern TkintdeclsVtab *TkintdeclsVGet(void);
+#endif /* TKINTDECLS_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.h
new file mode 100755
index 00000000000..9636f05867b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.h
@@ -0,0 +1,1227 @@
+/*
+ * tkIntPlatDecls.h --
+ *
+ * This file contains the declarations for all platform dependent
+ * unsupported functions that are exported by the Tk library. These
+ * interfaces are not guaranteed to remain the same between
+ * versions. Use at your own risk.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * All rights reserved.
+ *
+ * RCS: @(#) $Id: tkIntPlatDecls.h,v 1.15 2002/12/08 00:46:51 hobbs Exp $
+ */
+
+#ifndef _TKINTPLATDECLS
+#define _TKINTPLATDECLS
+
+#ifdef BUILD_tk
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tkInt.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+#ifdef __WIN32__
+/* 0 */
+EXTERN char * TkAlignImageData _ANSI_ARGS_((XImage * image,
+ int alignment, int bitOrder));
+/* Slot 1 is reserved */
+/* 2 */
+EXTERN void TkGenerateActivateEvents _ANSI_ARGS_((
+ TkWindow * winPtr, int active));
+/* 3 */
+EXTERN unsigned long TkpGetMS _ANSI_ARGS_((void));
+/* 4 */
+EXTERN void TkPointerDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 5 */
+EXTERN void TkpPrintWindowId _ANSI_ARGS_((char * buf,
+ Window window));
+/* 6 */
+EXTERN int TkpScanWindowId _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * string, Window * idPtr));
+/* 7 */
+EXTERN void TkpSetCapture _ANSI_ARGS_((TkWindow * winPtr));
+/* 8 */
+EXTERN void TkpSetCursor _ANSI_ARGS_((TkpCursor cursor));
+/* 9 */
+EXTERN void TkpWmSetState _ANSI_ARGS_((TkWindow * winPtr,
+ int state));
+/* 10 */
+EXTERN void TkSetPixmapColormap _ANSI_ARGS_((Pixmap pixmap,
+ Colormap colormap));
+/* 11 */
+EXTERN void TkWinCancelMouseTimer _ANSI_ARGS_((void));
+/* 12 */
+EXTERN void TkWinClipboardRender _ANSI_ARGS_((
+ TkDisplay * dispPtr, UINT format));
+/* 13 */
+EXTERN LRESULT TkWinEmbeddedEventProc _ANSI_ARGS_((HWND hwnd,
+ UINT message, WPARAM wParam, LPARAM lParam));
+/* 14 */
+EXTERN void TkWinFillRect _ANSI_ARGS_((HDC dc, int x, int y,
+ int width, int height, int pixel));
+/* 15 */
+EXTERN COLORREF TkWinGetBorderPixels _ANSI_ARGS_((Tk_Window tkwin,
+ Tk_3DBorder border, int which));
+/* 16 */
+EXTERN HDC TkWinGetDrawableDC _ANSI_ARGS_((Display * display,
+ Drawable d, TkWinDCState* state));
+/* 17 */
+EXTERN int TkWinGetModifierState _ANSI_ARGS_((void));
+/* 18 */
+EXTERN HPALETTE TkWinGetSystemPalette _ANSI_ARGS_((void));
+/* 19 */
+EXTERN HWND TkWinGetWrapperWindow _ANSI_ARGS_((Tk_Window tkwin));
+/* 20 */
+EXTERN int TkWinHandleMenuEvent _ANSI_ARGS_((HWND * phwnd,
+ UINT * pMessage, WPARAM * pwParam,
+ LPARAM * plParam, LRESULT * plResult));
+/* 21 */
+EXTERN int TkWinIndexOfColor _ANSI_ARGS_((XColor * colorPtr));
+/* 22 */
+EXTERN void TkWinReleaseDrawableDC _ANSI_ARGS_((Drawable d,
+ HDC hdc, TkWinDCState* state));
+/* 23 */
+EXTERN LRESULT TkWinResendEvent _ANSI_ARGS_((WNDPROC wndproc,
+ HWND hwnd, XEvent * eventPtr));
+/* 24 */
+EXTERN HPALETTE TkWinSelectPalette _ANSI_ARGS_((HDC dc,
+ Colormap colormap));
+/* 25 */
+EXTERN void TkWinSetMenu _ANSI_ARGS_((Tk_Window tkwin,
+ HMENU hMenu));
+/* 26 */
+EXTERN void TkWinSetWindowPos _ANSI_ARGS_((HWND hwnd,
+ HWND siblingHwnd, int pos));
+/* 27 */
+EXTERN void TkWinWmCleanup _ANSI_ARGS_((HINSTANCE hInstance));
+/* 28 */
+EXTERN void TkWinXCleanup _ANSI_ARGS_((HINSTANCE hInstance));
+/* 29 */
+EXTERN void TkWinXInit _ANSI_ARGS_((HINSTANCE hInstance));
+/* 30 */
+EXTERN void TkWinSetForegroundWindow _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 31 */
+EXTERN void TkWinDialogDebug _ANSI_ARGS_((int debug));
+/* 32 */
+EXTERN Tcl_Obj * TkWinGetMenuSystemDefault _ANSI_ARGS_((
+ Tk_Window tkwin, CONST char * dbName,
+ CONST char * className));
+/* 33 */
+EXTERN int TkWinGetPlatformId _ANSI_ARGS_((void));
+/* 34 */
+EXTERN void TkWinSetHINSTANCE _ANSI_ARGS_((HINSTANCE hInstance));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 0 */
+EXTERN void TkGenerateActivateEvents _ANSI_ARGS_((
+ TkWindow * winPtr, int active));
+/* Slot 1 is reserved */
+/* Slot 2 is reserved */
+/* 3 */
+EXTERN unsigned long TkpGetMS _ANSI_ARGS_((void));
+/* Slot 4 is reserved */
+/* 5 */
+EXTERN void TkPointerDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 6 */
+EXTERN void TkpSetCapture _ANSI_ARGS_((TkWindow * winPtr));
+/* 7 */
+EXTERN void TkpSetCursor _ANSI_ARGS_((TkpCursor cursor));
+/* 8 */
+EXTERN void TkpWmSetState _ANSI_ARGS_((TkWindow * winPtr,
+ int state));
+/* Slot 9 is reserved */
+/* 10 */
+EXTERN void TkAboutDlg _ANSI_ARGS_((void));
+/* Slot 11 is reserved */
+/* Slot 12 is reserved */
+/* 13 */
+EXTERN Window TkGetTransientMaster _ANSI_ARGS_((TkWindow * winPtr));
+/* 14 */
+EXTERN int TkGenerateButtonEvent _ANSI_ARGS_((int x, int y,
+ Window window, unsigned int state));
+/* Slot 15 is reserved */
+/* 16 */
+EXTERN void TkGenWMDestroyEvent _ANSI_ARGS_((Tk_Window tkwin));
+/* Slot 17 is reserved */
+/* 18 */
+EXTERN unsigned int TkMacButtonKeyState _ANSI_ARGS_((void));
+/* 19 */
+EXTERN void TkMacClearMenubarActive _ANSI_ARGS_((void));
+/* Slot 20 is reserved */
+/* 21 */
+EXTERN int TkMacDispatchMenuEvent _ANSI_ARGS_((int menuID,
+ int index));
+/* 22 */
+EXTERN void TkMacInstallCursor _ANSI_ARGS_((int resizeOverride));
+/* Slot 23 is reserved */
+/* 24 */
+EXTERN void TkMacHandleTearoffMenu _ANSI_ARGS_((void));
+/* Slot 25 is reserved */
+/* Slot 26 is reserved */
+/* 27 */
+EXTERN void TkMacDoHLEvent _ANSI_ARGS_((EventRecord * theEvent));
+/* Slot 28 is reserved */
+/* 29 */
+EXTERN Time TkMacGenerateTime _ANSI_ARGS_((void));
+/* Slot 30 is reserved */
+/* 31 */
+EXTERN TkWindow * TkMacGetScrollbarGrowWindow _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 32 */
+EXTERN Window TkMacGetXWindow _ANSI_ARGS_((WindowRef macWinPtr));
+/* 33 */
+EXTERN int TkMacGrowToplevel _ANSI_ARGS_((WindowRef whichWindow,
+ Point start));
+/* 34 */
+EXTERN void TkMacHandleMenuSelect _ANSI_ARGS_((long mResult,
+ int optionKeyPressed));
+/* Slot 35 is reserved */
+/* Slot 36 is reserved */
+/* Slot 37 is reserved */
+/* 38 */
+EXTERN void TkMacInvalidateWindow _ANSI_ARGS_((
+ MacDrawable * macWin, int flag));
+/* 39 */
+EXTERN int TkMacIsCharacterMissing _ANSI_ARGS_((Tk_Font tkfont,
+ unsigned int searchChar));
+/* 40 */
+EXTERN void TkMacMakeRealWindowExist _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 41 */
+EXTERN BitMapPtr TkMacMakeStippleMap _ANSI_ARGS_((Drawable d1,
+ Drawable d2));
+/* 42 */
+EXTERN void TkMacMenuClick _ANSI_ARGS_((void));
+/* 43 */
+EXTERN void TkMacRegisterOffScreenWindow _ANSI_ARGS_((
+ Window window, GWorldPtr portPtr));
+/* 44 */
+EXTERN int TkMacResizable _ANSI_ARGS_((TkWindow * winPtr));
+/* Slot 45 is reserved */
+/* 46 */
+EXTERN void TkMacSetHelpMenuItemCount _ANSI_ARGS_((void));
+/* 47 */
+EXTERN void TkMacSetScrollbarGrow _ANSI_ARGS_((TkWindow * winPtr,
+ int flag));
+/* 48 */
+EXTERN void TkMacSetUpClippingRgn _ANSI_ARGS_((Drawable drawable));
+/* 49 */
+EXTERN void TkMacSetUpGraphicsPort _ANSI_ARGS_((GC gc));
+/* 50 */
+EXTERN void TkMacUpdateClipRgn _ANSI_ARGS_((TkWindow * winPtr));
+/* 51 */
+EXTERN void TkMacUnregisterMacWindow _ANSI_ARGS_((
+ GWorldPtr portPtr));
+/* 52 */
+EXTERN int TkMacUseMenuID _ANSI_ARGS_((short macID));
+/* 53 */
+EXTERN RgnHandle TkMacVisableClipRgn _ANSI_ARGS_((TkWindow * winPtr));
+/* 54 */
+EXTERN void TkMacWinBounds _ANSI_ARGS_((TkWindow * winPtr,
+ Rect * geometry));
+/* 55 */
+EXTERN void TkMacWindowOffset _ANSI_ARGS_((WindowRef wRef,
+ int * xOffset, int * yOffset));
+/* Slot 56 is reserved */
+/* 57 */
+EXTERN int TkSetMacColor _ANSI_ARGS_((unsigned long pixel,
+ RGBColor * macColor));
+/* 58 */
+EXTERN void TkSetWMName _ANSI_ARGS_((TkWindow * winPtr,
+ Tk_Uid titleUid));
+/* 59 */
+EXTERN void TkSuspendClipboard _ANSI_ARGS_((void));
+/* Slot 60 is reserved */
+/* 61 */
+EXTERN int TkMacZoomToplevel _ANSI_ARGS_((WindowPtr whichWindow,
+ Point where, short zoomPart));
+/* 62 */
+EXTERN Tk_Window Tk_TopCoordsToWindow _ANSI_ARGS_((Tk_Window tkwin,
+ int rootX, int rootY, int * newX, int * newY));
+/* 63 */
+EXTERN MacDrawable * TkMacContainerId _ANSI_ARGS_((TkWindow * winPtr));
+/* 64 */
+EXTERN MacDrawable * TkMacGetHostToplevel _ANSI_ARGS_((TkWindow * winPtr));
+/* 65 */
+EXTERN void TkMacPreprocessMenu _ANSI_ARGS_((void));
+/* 66 */
+EXTERN int TkpIsWindowFloating _ANSI_ARGS_((WindowRef window));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 0 */
+EXTERN void TkGenerateActivateEvents _ANSI_ARGS_((
+ TkWindow * winPtr, int active));
+/* Slot 1 is reserved */
+/* Slot 2 is reserved */
+/* 3 */
+EXTERN void TkPointerDeadWindow _ANSI_ARGS_((TkWindow * winPtr));
+/* 4 */
+EXTERN void TkpSetCapture _ANSI_ARGS_((TkWindow * winPtr));
+/* 5 */
+EXTERN void TkpSetCursor _ANSI_ARGS_((TkpCursor cursor));
+/* 6 */
+EXTERN void TkpWmSetState _ANSI_ARGS_((TkWindow * winPtr,
+ int state));
+/* 7 */
+EXTERN void TkAboutDlg _ANSI_ARGS_((void));
+/* 8 */
+EXTERN unsigned int TkMacOSXButtonKeyState _ANSI_ARGS_((void));
+/* 9 */
+EXTERN void TkMacOSXClearMenubarActive _ANSI_ARGS_((void));
+/* 10 */
+EXTERN int TkMacOSXDispatchMenuEvent _ANSI_ARGS_((int menuID,
+ int index));
+/* 11 */
+EXTERN void TkMacOSXInstallCursor _ANSI_ARGS_((
+ int resizeOverride));
+/* 12 */
+EXTERN void TkMacOSXHandleTearoffMenu _ANSI_ARGS_((void));
+/* Slot 13 is reserved */
+/* 14 */
+EXTERN int TkMacOSXDoHLEvent _ANSI_ARGS_((
+ EventRecord * theEvent));
+/* Slot 15 is reserved */
+/* 16 */
+EXTERN Window TkMacOSXGetXWindow _ANSI_ARGS_((WindowRef macWinPtr));
+/* 17 */
+EXTERN int TkMacOSXGrowToplevel _ANSI_ARGS_((
+ WindowRef whichWindow, Point start));
+/* 18 */
+EXTERN void TkMacOSXHandleMenuSelect _ANSI_ARGS_((long mResult,
+ int optionKeyPressed));
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+/* 21 */
+EXTERN void TkMacOSXInvalidateWindow _ANSI_ARGS_((
+ MacDrawable * macWin, int flag));
+/* 22 */
+EXTERN int TkMacOSXIsCharacterMissing _ANSI_ARGS_((
+ Tk_Font tkfont, unsigned int searchChar));
+/* 23 */
+EXTERN void TkMacOSXMakeRealWindowExist _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 24 */
+EXTERN BitMapPtr TkMacOSXMakeStippleMap _ANSI_ARGS_((Drawable d1,
+ Drawable d2));
+/* 25 */
+EXTERN void TkMacOSXMenuClick _ANSI_ARGS_((void));
+/* 26 */
+EXTERN void TkMacOSXRegisterOffScreenWindow _ANSI_ARGS_((
+ Window window, GWorldPtr portPtr));
+/* 27 */
+EXTERN int TkMacOSXResizable _ANSI_ARGS_((TkWindow * winPtr));
+/* 28 */
+EXTERN void TkMacOSXSetHelpMenuItemCount _ANSI_ARGS_((void));
+/* 29 */
+EXTERN void TkMacOSXSetScrollbarGrow _ANSI_ARGS_((
+ TkWindow * winPtr, int flag));
+/* 30 */
+EXTERN void TkMacOSXSetUpClippingRgn _ANSI_ARGS_((
+ Drawable drawable));
+/* 31 */
+EXTERN void TkMacOSXSetUpGraphicsPort _ANSI_ARGS_((GC gc,
+ GWorldPtr destPort));
+/* 32 */
+EXTERN void TkMacOSXUpdateClipRgn _ANSI_ARGS_((TkWindow * winPtr));
+/* 33 */
+EXTERN void TkMacOSXUnregisterMacWindow _ANSI_ARGS_((
+ WindowRef portPtr));
+/* 34 */
+EXTERN int TkMacOSXUseMenuID _ANSI_ARGS_((short macID));
+/* 35 */
+EXTERN RgnHandle TkMacOSXVisableClipRgn _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 36 */
+EXTERN void TkMacOSXWinBounds _ANSI_ARGS_((TkWindow * winPtr,
+ Rect * geometry));
+/* 37 */
+EXTERN void TkMacOSXWindowOffset _ANSI_ARGS_((WindowRef wRef,
+ int * xOffset, int * yOffset));
+/* 38 */
+EXTERN int TkSetMacColor _ANSI_ARGS_((unsigned long pixel,
+ RGBColor * macColor));
+/* 39 */
+EXTERN void TkSetWMName _ANSI_ARGS_((TkWindow * winPtr,
+ Tk_Uid titleUid));
+/* 40 */
+EXTERN void TkSuspendClipboard _ANSI_ARGS_((void));
+/* 41 */
+EXTERN int TkMacOSXZoomToplevel _ANSI_ARGS_((
+ WindowPtr whichWindow, Point where,
+ short zoomPart));
+/* 42 */
+EXTERN Tk_Window Tk_TopCoordsToWindow _ANSI_ARGS_((Tk_Window tkwin,
+ int rootX, int rootY, int * newX, int * newY));
+/* 43 */
+EXTERN MacDrawable * TkMacOSXContainerId _ANSI_ARGS_((TkWindow * winPtr));
+/* 44 */
+EXTERN MacDrawable * TkMacOSXGetHostToplevel _ANSI_ARGS_((
+ TkWindow * winPtr));
+/* 45 */
+EXTERN void TkMacOSXPreprocessMenu _ANSI_ARGS_((void));
+/* 46 */
+EXTERN int TkpIsWindowFloating _ANSI_ARGS_((WindowRef window));
+/* 47 */
+EXTERN Tk_Window TkMacOSXGetCapture _ANSI_ARGS_((void));
+/* Slot 48 is reserved */
+/* 49 */
+EXTERN Window TkGetTransientMaster _ANSI_ARGS_((TkWindow * winPtr));
+/* 50 */
+EXTERN int TkGenerateButtonEvent _ANSI_ARGS_((int x, int y,
+ Window window, unsigned int state));
+/* 51 */
+EXTERN void TkGenWMDestroyEvent _ANSI_ARGS_((Tk_Window tkwin));
+/* Slot 52 is reserved */
+/* 53 */
+EXTERN unsigned long TkpGetMS _ANSI_ARGS_((void));
+#endif /* MAC_OSX_TK */
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */
+/* 0 */
+EXTERN void TkCreateXEventSource _ANSI_ARGS_((void));
+/* 1 */
+EXTERN void TkFreeWindowId _ANSI_ARGS_((TkDisplay * dispPtr,
+ Window w));
+/* 2 */
+EXTERN void TkInitXId _ANSI_ARGS_((TkDisplay * dispPtr));
+/* 3 */
+EXTERN int TkpCmapStressed _ANSI_ARGS_((Tk_Window tkwin,
+ Colormap colormap));
+/* 4 */
+EXTERN void TkpSync _ANSI_ARGS_((Display * display));
+/* 5 */
+EXTERN Window TkUnixContainerId _ANSI_ARGS_((TkWindow * winPtr));
+/* 6 */
+EXTERN int TkUnixDoOneXEvent _ANSI_ARGS_((Tcl_Time * timePtr));
+/* 7 */
+EXTERN void TkUnixSetMenubar _ANSI_ARGS_((Tk_Window tkwin,
+ Tk_Window menubar));
+/* 8 */
+EXTERN int TkpScanWindowId _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *string, Window * idPtr));
+/* 9 */
+EXTERN void TkWmCleanup _ANSI_ARGS_((TkDisplay * dispPtr));
+/* 10 */
+EXTERN void TkSendCleanup _ANSI_ARGS_((TkDisplay * dispPtr));
+/* 11 */
+EXTERN void TkFreeXId _ANSI_ARGS_((TkDisplay * dispPtr));
+/* 12 */
+EXTERN int TkpWmSetState _ANSI_ARGS_((TkWindow * winPtr,
+ int state));
+#endif /* X11 */
+
+typedef struct TkIntPlatStubs {
+ int magic;
+ struct TkIntPlatStubHooks *hooks;
+
+#ifdef __WIN32__
+ char * (*tkAlignImageData) _ANSI_ARGS_((XImage * image, int alignment, int bitOrder)); /* 0 */
+ void *reserved1;
+ void (*tkGenerateActivateEvents) _ANSI_ARGS_((TkWindow * winPtr, int active)); /* 2 */
+ unsigned long (*tkpGetMS) _ANSI_ARGS_((void)); /* 3 */
+ void (*tkPointerDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 4 */
+ void (*tkpPrintWindowId) _ANSI_ARGS_((char * buf, Window window)); /* 5 */
+ int (*tkpScanWindowId) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, Window * idPtr)); /* 6 */
+ void (*tkpSetCapture) _ANSI_ARGS_((TkWindow * winPtr)); /* 7 */
+ void (*tkpSetCursor) _ANSI_ARGS_((TkpCursor cursor)); /* 8 */
+ void (*tkpWmSetState) _ANSI_ARGS_((TkWindow * winPtr, int state)); /* 9 */
+ void (*tkSetPixmapColormap) _ANSI_ARGS_((Pixmap pixmap, Colormap colormap)); /* 10 */
+ void (*tkWinCancelMouseTimer) _ANSI_ARGS_((void)); /* 11 */
+ void (*tkWinClipboardRender) _ANSI_ARGS_((TkDisplay * dispPtr, UINT format)); /* 12 */
+ LRESULT (*tkWinEmbeddedEventProc) _ANSI_ARGS_((HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)); /* 13 */
+ void (*tkWinFillRect) _ANSI_ARGS_((HDC dc, int x, int y, int width, int height, int pixel)); /* 14 */
+ COLORREF (*tkWinGetBorderPixels) _ANSI_ARGS_((Tk_Window tkwin, Tk_3DBorder border, int which)); /* 15 */
+ HDC (*tkWinGetDrawableDC) _ANSI_ARGS_((Display * display, Drawable d, TkWinDCState* state)); /* 16 */
+ int (*tkWinGetModifierState) _ANSI_ARGS_((void)); /* 17 */
+ HPALETTE (*tkWinGetSystemPalette) _ANSI_ARGS_((void)); /* 18 */
+ HWND (*tkWinGetWrapperWindow) _ANSI_ARGS_((Tk_Window tkwin)); /* 19 */
+ int (*tkWinHandleMenuEvent) _ANSI_ARGS_((HWND * phwnd, UINT * pMessage, WPARAM * pwParam, LPARAM * plParam, LRESULT * plResult)); /* 20 */
+ int (*tkWinIndexOfColor) _ANSI_ARGS_((XColor * colorPtr)); /* 21 */
+ void (*tkWinReleaseDrawableDC) _ANSI_ARGS_((Drawable d, HDC hdc, TkWinDCState* state)); /* 22 */
+ LRESULT (*tkWinResendEvent) _ANSI_ARGS_((WNDPROC wndproc, HWND hwnd, XEvent * eventPtr)); /* 23 */
+ HPALETTE (*tkWinSelectPalette) _ANSI_ARGS_((HDC dc, Colormap colormap)); /* 24 */
+ void (*tkWinSetMenu) _ANSI_ARGS_((Tk_Window tkwin, HMENU hMenu)); /* 25 */
+ void (*tkWinSetWindowPos) _ANSI_ARGS_((HWND hwnd, HWND siblingHwnd, int pos)); /* 26 */
+ void (*tkWinWmCleanup) _ANSI_ARGS_((HINSTANCE hInstance)); /* 27 */
+ void (*tkWinXCleanup) _ANSI_ARGS_((HINSTANCE hInstance)); /* 28 */
+ void (*tkWinXInit) _ANSI_ARGS_((HINSTANCE hInstance)); /* 29 */
+ void (*tkWinSetForegroundWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 30 */
+ void (*tkWinDialogDebug) _ANSI_ARGS_((int debug)); /* 31 */
+ Tcl_Obj * (*tkWinGetMenuSystemDefault) _ANSI_ARGS_((Tk_Window tkwin, CONST char * dbName, CONST char * className)); /* 32 */
+ int (*tkWinGetPlatformId) _ANSI_ARGS_((void)); /* 33 */
+ void (*tkWinSetHINSTANCE) _ANSI_ARGS_((HINSTANCE hInstance)); /* 34 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tkGenerateActivateEvents) _ANSI_ARGS_((TkWindow * winPtr, int active)); /* 0 */
+ void *reserved1;
+ void *reserved2;
+ unsigned long (*tkpGetMS) _ANSI_ARGS_((void)); /* 3 */
+ void *reserved4;
+ void (*tkPointerDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 5 */
+ void (*tkpSetCapture) _ANSI_ARGS_((TkWindow * winPtr)); /* 6 */
+ void (*tkpSetCursor) _ANSI_ARGS_((TkpCursor cursor)); /* 7 */
+ void (*tkpWmSetState) _ANSI_ARGS_((TkWindow * winPtr, int state)); /* 8 */
+ void *reserved9;
+ void (*tkAboutDlg) _ANSI_ARGS_((void)); /* 10 */
+ void *reserved11;
+ void *reserved12;
+ Window (*tkGetTransientMaster) _ANSI_ARGS_((TkWindow * winPtr)); /* 13 */
+ int (*tkGenerateButtonEvent) _ANSI_ARGS_((int x, int y, Window window, unsigned int state)); /* 14 */
+ void *reserved15;
+ void (*tkGenWMDestroyEvent) _ANSI_ARGS_((Tk_Window tkwin)); /* 16 */
+ void *reserved17;
+ unsigned int (*tkMacButtonKeyState) _ANSI_ARGS_((void)); /* 18 */
+ void (*tkMacClearMenubarActive) _ANSI_ARGS_((void)); /* 19 */
+ void *reserved20;
+ int (*tkMacDispatchMenuEvent) _ANSI_ARGS_((int menuID, int index)); /* 21 */
+ void (*tkMacInstallCursor) _ANSI_ARGS_((int resizeOverride)); /* 22 */
+ void *reserved23;
+ void (*tkMacHandleTearoffMenu) _ANSI_ARGS_((void)); /* 24 */
+ void *reserved25;
+ void *reserved26;
+ void (*tkMacDoHLEvent) _ANSI_ARGS_((EventRecord * theEvent)); /* 27 */
+ void *reserved28;
+ Time (*tkMacGenerateTime) _ANSI_ARGS_((void)); /* 29 */
+ void *reserved30;
+ TkWindow * (*tkMacGetScrollbarGrowWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 31 */
+ Window (*tkMacGetXWindow) _ANSI_ARGS_((WindowRef macWinPtr)); /* 32 */
+ int (*tkMacGrowToplevel) _ANSI_ARGS_((WindowRef whichWindow, Point start)); /* 33 */
+ void (*tkMacHandleMenuSelect) _ANSI_ARGS_((long mResult, int optionKeyPressed)); /* 34 */
+ void *reserved35;
+ void *reserved36;
+ void *reserved37;
+ void (*tkMacInvalidateWindow) _ANSI_ARGS_((MacDrawable * macWin, int flag)); /* 38 */
+ int (*tkMacIsCharacterMissing) _ANSI_ARGS_((Tk_Font tkfont, unsigned int searchChar)); /* 39 */
+ void (*tkMacMakeRealWindowExist) _ANSI_ARGS_((TkWindow * winPtr)); /* 40 */
+ BitMapPtr (*tkMacMakeStippleMap) _ANSI_ARGS_((Drawable d1, Drawable d2)); /* 41 */
+ void (*tkMacMenuClick) _ANSI_ARGS_((void)); /* 42 */
+ void (*tkMacRegisterOffScreenWindow) _ANSI_ARGS_((Window window, GWorldPtr portPtr)); /* 43 */
+ int (*tkMacResizable) _ANSI_ARGS_((TkWindow * winPtr)); /* 44 */
+ void *reserved45;
+ void (*tkMacSetHelpMenuItemCount) _ANSI_ARGS_((void)); /* 46 */
+ void (*tkMacSetScrollbarGrow) _ANSI_ARGS_((TkWindow * winPtr, int flag)); /* 47 */
+ void (*tkMacSetUpClippingRgn) _ANSI_ARGS_((Drawable drawable)); /* 48 */
+ void (*tkMacSetUpGraphicsPort) _ANSI_ARGS_((GC gc)); /* 49 */
+ void (*tkMacUpdateClipRgn) _ANSI_ARGS_((TkWindow * winPtr)); /* 50 */
+ void (*tkMacUnregisterMacWindow) _ANSI_ARGS_((GWorldPtr portPtr)); /* 51 */
+ int (*tkMacUseMenuID) _ANSI_ARGS_((short macID)); /* 52 */
+ RgnHandle (*tkMacVisableClipRgn) _ANSI_ARGS_((TkWindow * winPtr)); /* 53 */
+ void (*tkMacWinBounds) _ANSI_ARGS_((TkWindow * winPtr, Rect * geometry)); /* 54 */
+ void (*tkMacWindowOffset) _ANSI_ARGS_((WindowRef wRef, int * xOffset, int * yOffset)); /* 55 */
+ void *reserved56;
+ int (*tkSetMacColor) _ANSI_ARGS_((unsigned long pixel, RGBColor * macColor)); /* 57 */
+ void (*tkSetWMName) _ANSI_ARGS_((TkWindow * winPtr, Tk_Uid titleUid)); /* 58 */
+ void (*tkSuspendClipboard) _ANSI_ARGS_((void)); /* 59 */
+ void *reserved60;
+ int (*tkMacZoomToplevel) _ANSI_ARGS_((WindowPtr whichWindow, Point where, short zoomPart)); /* 61 */
+ Tk_Window (*tk_TopCoordsToWindow) _ANSI_ARGS_((Tk_Window tkwin, int rootX, int rootY, int * newX, int * newY)); /* 62 */
+ MacDrawable * (*tkMacContainerId) _ANSI_ARGS_((TkWindow * winPtr)); /* 63 */
+ MacDrawable * (*tkMacGetHostToplevel) _ANSI_ARGS_((TkWindow * winPtr)); /* 64 */
+ void (*tkMacPreprocessMenu) _ANSI_ARGS_((void)); /* 65 */
+ int (*tkpIsWindowFloating) _ANSI_ARGS_((WindowRef window)); /* 66 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tkGenerateActivateEvents) _ANSI_ARGS_((TkWindow * winPtr, int active)); /* 0 */
+ void *reserved1;
+ void *reserved2;
+ void (*tkPointerDeadWindow) _ANSI_ARGS_((TkWindow * winPtr)); /* 3 */
+ void (*tkpSetCapture) _ANSI_ARGS_((TkWindow * winPtr)); /* 4 */
+ void (*tkpSetCursor) _ANSI_ARGS_((TkpCursor cursor)); /* 5 */
+ void (*tkpWmSetState) _ANSI_ARGS_((TkWindow * winPtr, int state)); /* 6 */
+ void (*tkAboutDlg) _ANSI_ARGS_((void)); /* 7 */
+ unsigned int (*tkMacOSXButtonKeyState) _ANSI_ARGS_((void)); /* 8 */
+ void (*tkMacOSXClearMenubarActive) _ANSI_ARGS_((void)); /* 9 */
+ int (*tkMacOSXDispatchMenuEvent) _ANSI_ARGS_((int menuID, int index)); /* 10 */
+ void (*tkMacOSXInstallCursor) _ANSI_ARGS_((int resizeOverride)); /* 11 */
+ void (*tkMacOSXHandleTearoffMenu) _ANSI_ARGS_((void)); /* 12 */
+ void *reserved13;
+ int (*tkMacOSXDoHLEvent) _ANSI_ARGS_((EventRecord * theEvent)); /* 14 */
+ void *reserved15;
+ Window (*tkMacOSXGetXWindow) _ANSI_ARGS_((WindowRef macWinPtr)); /* 16 */
+ int (*tkMacOSXGrowToplevel) _ANSI_ARGS_((WindowRef whichWindow, Point start)); /* 17 */
+ void (*tkMacOSXHandleMenuSelect) _ANSI_ARGS_((long mResult, int optionKeyPressed)); /* 18 */
+ void *reserved19;
+ void *reserved20;
+ void (*tkMacOSXInvalidateWindow) _ANSI_ARGS_((MacDrawable * macWin, int flag)); /* 21 */
+ int (*tkMacOSXIsCharacterMissing) _ANSI_ARGS_((Tk_Font tkfont, unsigned int searchChar)); /* 22 */
+ void (*tkMacOSXMakeRealWindowExist) _ANSI_ARGS_((TkWindow * winPtr)); /* 23 */
+ BitMapPtr (*tkMacOSXMakeStippleMap) _ANSI_ARGS_((Drawable d1, Drawable d2)); /* 24 */
+ void (*tkMacOSXMenuClick) _ANSI_ARGS_((void)); /* 25 */
+ void (*tkMacOSXRegisterOffScreenWindow) _ANSI_ARGS_((Window window, GWorldPtr portPtr)); /* 26 */
+ int (*tkMacOSXResizable) _ANSI_ARGS_((TkWindow * winPtr)); /* 27 */
+ void (*tkMacOSXSetHelpMenuItemCount) _ANSI_ARGS_((void)); /* 28 */
+ void (*tkMacOSXSetScrollbarGrow) _ANSI_ARGS_((TkWindow * winPtr, int flag)); /* 29 */
+ void (*tkMacOSXSetUpClippingRgn) _ANSI_ARGS_((Drawable drawable)); /* 30 */
+ void (*tkMacOSXSetUpGraphicsPort) _ANSI_ARGS_((GC gc, GWorldPtr destPort)); /* 31 */
+ void (*tkMacOSXUpdateClipRgn) _ANSI_ARGS_((TkWindow * winPtr)); /* 32 */
+ void (*tkMacOSXUnregisterMacWindow) _ANSI_ARGS_((WindowRef portPtr)); /* 33 */
+ int (*tkMacOSXUseMenuID) _ANSI_ARGS_((short macID)); /* 34 */
+ RgnHandle (*tkMacOSXVisableClipRgn) _ANSI_ARGS_((TkWindow * winPtr)); /* 35 */
+ void (*tkMacOSXWinBounds) _ANSI_ARGS_((TkWindow * winPtr, Rect * geometry)); /* 36 */
+ void (*tkMacOSXWindowOffset) _ANSI_ARGS_((WindowRef wRef, int * xOffset, int * yOffset)); /* 37 */
+ int (*tkSetMacColor) _ANSI_ARGS_((unsigned long pixel, RGBColor * macColor)); /* 38 */
+ void (*tkSetWMName) _ANSI_ARGS_((TkWindow * winPtr, Tk_Uid titleUid)); /* 39 */
+ void (*tkSuspendClipboard) _ANSI_ARGS_((void)); /* 40 */
+ int (*tkMacOSXZoomToplevel) _ANSI_ARGS_((WindowPtr whichWindow, Point where, short zoomPart)); /* 41 */
+ Tk_Window (*tk_TopCoordsToWindow) _ANSI_ARGS_((Tk_Window tkwin, int rootX, int rootY, int * newX, int * newY)); /* 42 */
+ MacDrawable * (*tkMacOSXContainerId) _ANSI_ARGS_((TkWindow * winPtr)); /* 43 */
+ MacDrawable * (*tkMacOSXGetHostToplevel) _ANSI_ARGS_((TkWindow * winPtr)); /* 44 */
+ void (*tkMacOSXPreprocessMenu) _ANSI_ARGS_((void)); /* 45 */
+ int (*tkpIsWindowFloating) _ANSI_ARGS_((WindowRef window)); /* 46 */
+ Tk_Window (*tkMacOSXGetCapture) _ANSI_ARGS_((void)); /* 47 */
+ void *reserved48;
+ Window (*tkGetTransientMaster) _ANSI_ARGS_((TkWindow * winPtr)); /* 49 */
+ int (*tkGenerateButtonEvent) _ANSI_ARGS_((int x, int y, Window window, unsigned int state)); /* 50 */
+ void (*tkGenWMDestroyEvent) _ANSI_ARGS_((Tk_Window tkwin)); /* 51 */
+ void *reserved52;
+ unsigned long (*tkpGetMS) _ANSI_ARGS_((void)); /* 53 */
+#endif /* MAC_OSX_TK */
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */
+ void (*tkCreateXEventSource) _ANSI_ARGS_((void)); /* 0 */
+ void (*tkFreeWindowId) _ANSI_ARGS_((TkDisplay * dispPtr, Window w)); /* 1 */
+ void (*tkInitXId) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 2 */
+ int (*tkpCmapStressed) _ANSI_ARGS_((Tk_Window tkwin, Colormap colormap)); /* 3 */
+ void (*tkpSync) _ANSI_ARGS_((Display * display)); /* 4 */
+ Window (*tkUnixContainerId) _ANSI_ARGS_((TkWindow * winPtr)); /* 5 */
+ int (*tkUnixDoOneXEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 6 */
+ void (*tkUnixSetMenubar) _ANSI_ARGS_((Tk_Window tkwin, Tk_Window menubar)); /* 7 */
+ int (*tkpScanWindowId) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, Window * idPtr)); /* 8 */
+ void (*tkWmCleanup) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 9 */
+ void (*tkSendCleanup) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 10 */
+ void (*tkFreeXId) _ANSI_ARGS_((TkDisplay * dispPtr)); /* 11 */
+ int (*tkpWmSetState) _ANSI_ARGS_((TkWindow * winPtr, int state)); /* 12 */
+#endif /* X11 */
+} TkIntPlatStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TkIntPlatStubs *tkIntPlatStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifdef __WIN32__
+#ifndef TkAlignImageData
+#define TkAlignImageData \
+ (tkIntPlatStubsPtr->tkAlignImageData) /* 0 */
+#endif
+/* Slot 1 is reserved */
+#ifndef TkGenerateActivateEvents
+#define TkGenerateActivateEvents \
+ (tkIntPlatStubsPtr->tkGenerateActivateEvents) /* 2 */
+#endif
+#ifndef TkpGetMS
+#define TkpGetMS \
+ (tkIntPlatStubsPtr->tkpGetMS) /* 3 */
+#endif
+#ifndef TkPointerDeadWindow
+#define TkPointerDeadWindow \
+ (tkIntPlatStubsPtr->tkPointerDeadWindow) /* 4 */
+#endif
+#ifndef TkpPrintWindowId
+#define TkpPrintWindowId \
+ (tkIntPlatStubsPtr->tkpPrintWindowId) /* 5 */
+#endif
+#ifndef TkpScanWindowId
+#define TkpScanWindowId \
+ (tkIntPlatStubsPtr->tkpScanWindowId) /* 6 */
+#endif
+#ifndef TkpSetCapture
+#define TkpSetCapture \
+ (tkIntPlatStubsPtr->tkpSetCapture) /* 7 */
+#endif
+#ifndef TkpSetCursor
+#define TkpSetCursor \
+ (tkIntPlatStubsPtr->tkpSetCursor) /* 8 */
+#endif
+#ifndef TkpWmSetState
+#define TkpWmSetState \
+ (tkIntPlatStubsPtr->tkpWmSetState) /* 9 */
+#endif
+#ifndef TkSetPixmapColormap
+#define TkSetPixmapColormap \
+ (tkIntPlatStubsPtr->tkSetPixmapColormap) /* 10 */
+#endif
+#ifndef TkWinCancelMouseTimer
+#define TkWinCancelMouseTimer \
+ (tkIntPlatStubsPtr->tkWinCancelMouseTimer) /* 11 */
+#endif
+#ifndef TkWinClipboardRender
+#define TkWinClipboardRender \
+ (tkIntPlatStubsPtr->tkWinClipboardRender) /* 12 */
+#endif
+#ifndef TkWinEmbeddedEventProc
+#define TkWinEmbeddedEventProc \
+ (tkIntPlatStubsPtr->tkWinEmbeddedEventProc) /* 13 */
+#endif
+#ifndef TkWinFillRect
+#define TkWinFillRect \
+ (tkIntPlatStubsPtr->tkWinFillRect) /* 14 */
+#endif
+#ifndef TkWinGetBorderPixels
+#define TkWinGetBorderPixels \
+ (tkIntPlatStubsPtr->tkWinGetBorderPixels) /* 15 */
+#endif
+#ifndef TkWinGetDrawableDC
+#define TkWinGetDrawableDC \
+ (tkIntPlatStubsPtr->tkWinGetDrawableDC) /* 16 */
+#endif
+#ifndef TkWinGetModifierState
+#define TkWinGetModifierState \
+ (tkIntPlatStubsPtr->tkWinGetModifierState) /* 17 */
+#endif
+#ifndef TkWinGetSystemPalette
+#define TkWinGetSystemPalette \
+ (tkIntPlatStubsPtr->tkWinGetSystemPalette) /* 18 */
+#endif
+#ifndef TkWinGetWrapperWindow
+#define TkWinGetWrapperWindow \
+ (tkIntPlatStubsPtr->tkWinGetWrapperWindow) /* 19 */
+#endif
+#ifndef TkWinHandleMenuEvent
+#define TkWinHandleMenuEvent \
+ (tkIntPlatStubsPtr->tkWinHandleMenuEvent) /* 20 */
+#endif
+#ifndef TkWinIndexOfColor
+#define TkWinIndexOfColor \
+ (tkIntPlatStubsPtr->tkWinIndexOfColor) /* 21 */
+#endif
+#ifndef TkWinReleaseDrawableDC
+#define TkWinReleaseDrawableDC \
+ (tkIntPlatStubsPtr->tkWinReleaseDrawableDC) /* 22 */
+#endif
+#ifndef TkWinResendEvent
+#define TkWinResendEvent \
+ (tkIntPlatStubsPtr->tkWinResendEvent) /* 23 */
+#endif
+#ifndef TkWinSelectPalette
+#define TkWinSelectPalette \
+ (tkIntPlatStubsPtr->tkWinSelectPalette) /* 24 */
+#endif
+#ifndef TkWinSetMenu
+#define TkWinSetMenu \
+ (tkIntPlatStubsPtr->tkWinSetMenu) /* 25 */
+#endif
+#ifndef TkWinSetWindowPos
+#define TkWinSetWindowPos \
+ (tkIntPlatStubsPtr->tkWinSetWindowPos) /* 26 */
+#endif
+#ifndef TkWinWmCleanup
+#define TkWinWmCleanup \
+ (tkIntPlatStubsPtr->tkWinWmCleanup) /* 27 */
+#endif
+#ifndef TkWinXCleanup
+#define TkWinXCleanup \
+ (tkIntPlatStubsPtr->tkWinXCleanup) /* 28 */
+#endif
+#ifndef TkWinXInit
+#define TkWinXInit \
+ (tkIntPlatStubsPtr->tkWinXInit) /* 29 */
+#endif
+#ifndef TkWinSetForegroundWindow
+#define TkWinSetForegroundWindow \
+ (tkIntPlatStubsPtr->tkWinSetForegroundWindow) /* 30 */
+#endif
+#ifndef TkWinDialogDebug
+#define TkWinDialogDebug \
+ (tkIntPlatStubsPtr->tkWinDialogDebug) /* 31 */
+#endif
+#ifndef TkWinGetMenuSystemDefault
+#define TkWinGetMenuSystemDefault \
+ (tkIntPlatStubsPtr->tkWinGetMenuSystemDefault) /* 32 */
+#endif
+#ifndef TkWinGetPlatformId
+#define TkWinGetPlatformId \
+ (tkIntPlatStubsPtr->tkWinGetPlatformId) /* 33 */
+#endif
+#ifndef TkWinSetHINSTANCE
+#define TkWinSetHINSTANCE \
+ (tkIntPlatStubsPtr->tkWinSetHINSTANCE) /* 34 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef TkGenerateActivateEvents
+#define TkGenerateActivateEvents \
+ (tkIntPlatStubsPtr->tkGenerateActivateEvents) /* 0 */
+#endif
+/* Slot 1 is reserved */
+/* Slot 2 is reserved */
+#ifndef TkpGetMS
+#define TkpGetMS \
+ (tkIntPlatStubsPtr->tkpGetMS) /* 3 */
+#endif
+/* Slot 4 is reserved */
+#ifndef TkPointerDeadWindow
+#define TkPointerDeadWindow \
+ (tkIntPlatStubsPtr->tkPointerDeadWindow) /* 5 */
+#endif
+#ifndef TkpSetCapture
+#define TkpSetCapture \
+ (tkIntPlatStubsPtr->tkpSetCapture) /* 6 */
+#endif
+#ifndef TkpSetCursor
+#define TkpSetCursor \
+ (tkIntPlatStubsPtr->tkpSetCursor) /* 7 */
+#endif
+#ifndef TkpWmSetState
+#define TkpWmSetState \
+ (tkIntPlatStubsPtr->tkpWmSetState) /* 8 */
+#endif
+/* Slot 9 is reserved */
+#ifndef TkAboutDlg
+#define TkAboutDlg \
+ (tkIntPlatStubsPtr->tkAboutDlg) /* 10 */
+#endif
+/* Slot 11 is reserved */
+/* Slot 12 is reserved */
+#ifndef TkGetTransientMaster
+#define TkGetTransientMaster \
+ (tkIntPlatStubsPtr->tkGetTransientMaster) /* 13 */
+#endif
+#ifndef TkGenerateButtonEvent
+#define TkGenerateButtonEvent \
+ (tkIntPlatStubsPtr->tkGenerateButtonEvent) /* 14 */
+#endif
+/* Slot 15 is reserved */
+#ifndef TkGenWMDestroyEvent
+#define TkGenWMDestroyEvent \
+ (tkIntPlatStubsPtr->tkGenWMDestroyEvent) /* 16 */
+#endif
+/* Slot 17 is reserved */
+#ifndef TkMacButtonKeyState
+#define TkMacButtonKeyState \
+ (tkIntPlatStubsPtr->tkMacButtonKeyState) /* 18 */
+#endif
+#ifndef TkMacClearMenubarActive
+#define TkMacClearMenubarActive \
+ (tkIntPlatStubsPtr->tkMacClearMenubarActive) /* 19 */
+#endif
+/* Slot 20 is reserved */
+#ifndef TkMacDispatchMenuEvent
+#define TkMacDispatchMenuEvent \
+ (tkIntPlatStubsPtr->tkMacDispatchMenuEvent) /* 21 */
+#endif
+#ifndef TkMacInstallCursor
+#define TkMacInstallCursor \
+ (tkIntPlatStubsPtr->tkMacInstallCursor) /* 22 */
+#endif
+/* Slot 23 is reserved */
+#ifndef TkMacHandleTearoffMenu
+#define TkMacHandleTearoffMenu \
+ (tkIntPlatStubsPtr->tkMacHandleTearoffMenu) /* 24 */
+#endif
+/* Slot 25 is reserved */
+/* Slot 26 is reserved */
+#ifndef TkMacDoHLEvent
+#define TkMacDoHLEvent \
+ (tkIntPlatStubsPtr->tkMacDoHLEvent) /* 27 */
+#endif
+/* Slot 28 is reserved */
+#ifndef TkMacGenerateTime
+#define TkMacGenerateTime \
+ (tkIntPlatStubsPtr->tkMacGenerateTime) /* 29 */
+#endif
+/* Slot 30 is reserved */
+#ifndef TkMacGetScrollbarGrowWindow
+#define TkMacGetScrollbarGrowWindow \
+ (tkIntPlatStubsPtr->tkMacGetScrollbarGrowWindow) /* 31 */
+#endif
+#ifndef TkMacGetXWindow
+#define TkMacGetXWindow \
+ (tkIntPlatStubsPtr->tkMacGetXWindow) /* 32 */
+#endif
+#ifndef TkMacGrowToplevel
+#define TkMacGrowToplevel \
+ (tkIntPlatStubsPtr->tkMacGrowToplevel) /* 33 */
+#endif
+#ifndef TkMacHandleMenuSelect
+#define TkMacHandleMenuSelect \
+ (tkIntPlatStubsPtr->tkMacHandleMenuSelect) /* 34 */
+#endif
+/* Slot 35 is reserved */
+/* Slot 36 is reserved */
+/* Slot 37 is reserved */
+#ifndef TkMacInvalidateWindow
+#define TkMacInvalidateWindow \
+ (tkIntPlatStubsPtr->tkMacInvalidateWindow) /* 38 */
+#endif
+#ifndef TkMacIsCharacterMissing
+#define TkMacIsCharacterMissing \
+ (tkIntPlatStubsPtr->tkMacIsCharacterMissing) /* 39 */
+#endif
+#ifndef TkMacMakeRealWindowExist
+#define TkMacMakeRealWindowExist \
+ (tkIntPlatStubsPtr->tkMacMakeRealWindowExist) /* 40 */
+#endif
+#ifndef TkMacMakeStippleMap
+#define TkMacMakeStippleMap \
+ (tkIntPlatStubsPtr->tkMacMakeStippleMap) /* 41 */
+#endif
+#ifndef TkMacMenuClick
+#define TkMacMenuClick \
+ (tkIntPlatStubsPtr->tkMacMenuClick) /* 42 */
+#endif
+#ifndef TkMacRegisterOffScreenWindow
+#define TkMacRegisterOffScreenWindow \
+ (tkIntPlatStubsPtr->tkMacRegisterOffScreenWindow) /* 43 */
+#endif
+#ifndef TkMacResizable
+#define TkMacResizable \
+ (tkIntPlatStubsPtr->tkMacResizable) /* 44 */
+#endif
+/* Slot 45 is reserved */
+#ifndef TkMacSetHelpMenuItemCount
+#define TkMacSetHelpMenuItemCount \
+ (tkIntPlatStubsPtr->tkMacSetHelpMenuItemCount) /* 46 */
+#endif
+#ifndef TkMacSetScrollbarGrow
+#define TkMacSetScrollbarGrow \
+ (tkIntPlatStubsPtr->tkMacSetScrollbarGrow) /* 47 */
+#endif
+#ifndef TkMacSetUpClippingRgn
+#define TkMacSetUpClippingRgn \
+ (tkIntPlatStubsPtr->tkMacSetUpClippingRgn) /* 48 */
+#endif
+#ifndef TkMacSetUpGraphicsPort
+#define TkMacSetUpGraphicsPort \
+ (tkIntPlatStubsPtr->tkMacSetUpGraphicsPort) /* 49 */
+#endif
+#ifndef TkMacUpdateClipRgn
+#define TkMacUpdateClipRgn \
+ (tkIntPlatStubsPtr->tkMacUpdateClipRgn) /* 50 */
+#endif
+#ifndef TkMacUnregisterMacWindow
+#define TkMacUnregisterMacWindow \
+ (tkIntPlatStubsPtr->tkMacUnregisterMacWindow) /* 51 */
+#endif
+#ifndef TkMacUseMenuID
+#define TkMacUseMenuID \
+ (tkIntPlatStubsPtr->tkMacUseMenuID) /* 52 */
+#endif
+#ifndef TkMacVisableClipRgn
+#define TkMacVisableClipRgn \
+ (tkIntPlatStubsPtr->tkMacVisableClipRgn) /* 53 */
+#endif
+#ifndef TkMacWinBounds
+#define TkMacWinBounds \
+ (tkIntPlatStubsPtr->tkMacWinBounds) /* 54 */
+#endif
+#ifndef TkMacWindowOffset
+#define TkMacWindowOffset \
+ (tkIntPlatStubsPtr->tkMacWindowOffset) /* 55 */
+#endif
+/* Slot 56 is reserved */
+#ifndef TkSetMacColor
+#define TkSetMacColor \
+ (tkIntPlatStubsPtr->tkSetMacColor) /* 57 */
+#endif
+#ifndef TkSetWMName
+#define TkSetWMName \
+ (tkIntPlatStubsPtr->tkSetWMName) /* 58 */
+#endif
+#ifndef TkSuspendClipboard
+#define TkSuspendClipboard \
+ (tkIntPlatStubsPtr->tkSuspendClipboard) /* 59 */
+#endif
+/* Slot 60 is reserved */
+#ifndef TkMacZoomToplevel
+#define TkMacZoomToplevel \
+ (tkIntPlatStubsPtr->tkMacZoomToplevel) /* 61 */
+#endif
+#ifndef Tk_TopCoordsToWindow
+#define Tk_TopCoordsToWindow \
+ (tkIntPlatStubsPtr->tk_TopCoordsToWindow) /* 62 */
+#endif
+#ifndef TkMacContainerId
+#define TkMacContainerId \
+ (tkIntPlatStubsPtr->tkMacContainerId) /* 63 */
+#endif
+#ifndef TkMacGetHostToplevel
+#define TkMacGetHostToplevel \
+ (tkIntPlatStubsPtr->tkMacGetHostToplevel) /* 64 */
+#endif
+#ifndef TkMacPreprocessMenu
+#define TkMacPreprocessMenu \
+ (tkIntPlatStubsPtr->tkMacPreprocessMenu) /* 65 */
+#endif
+#ifndef TkpIsWindowFloating
+#define TkpIsWindowFloating \
+ (tkIntPlatStubsPtr->tkpIsWindowFloating) /* 66 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef TkGenerateActivateEvents
+#define TkGenerateActivateEvents \
+ (tkIntPlatStubsPtr->tkGenerateActivateEvents) /* 0 */
+#endif
+/* Slot 1 is reserved */
+/* Slot 2 is reserved */
+#ifndef TkPointerDeadWindow
+#define TkPointerDeadWindow \
+ (tkIntPlatStubsPtr->tkPointerDeadWindow) /* 3 */
+#endif
+#ifndef TkpSetCapture
+#define TkpSetCapture \
+ (tkIntPlatStubsPtr->tkpSetCapture) /* 4 */
+#endif
+#ifndef TkpSetCursor
+#define TkpSetCursor \
+ (tkIntPlatStubsPtr->tkpSetCursor) /* 5 */
+#endif
+#ifndef TkpWmSetState
+#define TkpWmSetState \
+ (tkIntPlatStubsPtr->tkpWmSetState) /* 6 */
+#endif
+#ifndef TkAboutDlg
+#define TkAboutDlg \
+ (tkIntPlatStubsPtr->tkAboutDlg) /* 7 */
+#endif
+#ifndef TkMacOSXButtonKeyState
+#define TkMacOSXButtonKeyState \
+ (tkIntPlatStubsPtr->tkMacOSXButtonKeyState) /* 8 */
+#endif
+#ifndef TkMacOSXClearMenubarActive
+#define TkMacOSXClearMenubarActive \
+ (tkIntPlatStubsPtr->tkMacOSXClearMenubarActive) /* 9 */
+#endif
+#ifndef TkMacOSXDispatchMenuEvent
+#define TkMacOSXDispatchMenuEvent \
+ (tkIntPlatStubsPtr->tkMacOSXDispatchMenuEvent) /* 10 */
+#endif
+#ifndef TkMacOSXInstallCursor
+#define TkMacOSXInstallCursor \
+ (tkIntPlatStubsPtr->tkMacOSXInstallCursor) /* 11 */
+#endif
+#ifndef TkMacOSXHandleTearoffMenu
+#define TkMacOSXHandleTearoffMenu \
+ (tkIntPlatStubsPtr->tkMacOSXHandleTearoffMenu) /* 12 */
+#endif
+/* Slot 13 is reserved */
+#ifndef TkMacOSXDoHLEvent
+#define TkMacOSXDoHLEvent \
+ (tkIntPlatStubsPtr->tkMacOSXDoHLEvent) /* 14 */
+#endif
+/* Slot 15 is reserved */
+#ifndef TkMacOSXGetXWindow
+#define TkMacOSXGetXWindow \
+ (tkIntPlatStubsPtr->tkMacOSXGetXWindow) /* 16 */
+#endif
+#ifndef TkMacOSXGrowToplevel
+#define TkMacOSXGrowToplevel \
+ (tkIntPlatStubsPtr->tkMacOSXGrowToplevel) /* 17 */
+#endif
+#ifndef TkMacOSXHandleMenuSelect
+#define TkMacOSXHandleMenuSelect \
+ (tkIntPlatStubsPtr->tkMacOSXHandleMenuSelect) /* 18 */
+#endif
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+#ifndef TkMacOSXInvalidateWindow
+#define TkMacOSXInvalidateWindow \
+ (tkIntPlatStubsPtr->tkMacOSXInvalidateWindow) /* 21 */
+#endif
+#ifndef TkMacOSXIsCharacterMissing
+#define TkMacOSXIsCharacterMissing \
+ (tkIntPlatStubsPtr->tkMacOSXIsCharacterMissing) /* 22 */
+#endif
+#ifndef TkMacOSXMakeRealWindowExist
+#define TkMacOSXMakeRealWindowExist \
+ (tkIntPlatStubsPtr->tkMacOSXMakeRealWindowExist) /* 23 */
+#endif
+#ifndef TkMacOSXMakeStippleMap
+#define TkMacOSXMakeStippleMap \
+ (tkIntPlatStubsPtr->tkMacOSXMakeStippleMap) /* 24 */
+#endif
+#ifndef TkMacOSXMenuClick
+#define TkMacOSXMenuClick \
+ (tkIntPlatStubsPtr->tkMacOSXMenuClick) /* 25 */
+#endif
+#ifndef TkMacOSXRegisterOffScreenWindow
+#define TkMacOSXRegisterOffScreenWindow \
+ (tkIntPlatStubsPtr->tkMacOSXRegisterOffScreenWindow) /* 26 */
+#endif
+#ifndef TkMacOSXResizable
+#define TkMacOSXResizable \
+ (tkIntPlatStubsPtr->tkMacOSXResizable) /* 27 */
+#endif
+#ifndef TkMacOSXSetHelpMenuItemCount
+#define TkMacOSXSetHelpMenuItemCount \
+ (tkIntPlatStubsPtr->tkMacOSXSetHelpMenuItemCount) /* 28 */
+#endif
+#ifndef TkMacOSXSetScrollbarGrow
+#define TkMacOSXSetScrollbarGrow \
+ (tkIntPlatStubsPtr->tkMacOSXSetScrollbarGrow) /* 29 */
+#endif
+#ifndef TkMacOSXSetUpClippingRgn
+#define TkMacOSXSetUpClippingRgn \
+ (tkIntPlatStubsPtr->tkMacOSXSetUpClippingRgn) /* 30 */
+#endif
+#ifndef TkMacOSXSetUpGraphicsPort
+#define TkMacOSXSetUpGraphicsPort \
+ (tkIntPlatStubsPtr->tkMacOSXSetUpGraphicsPort) /* 31 */
+#endif
+#ifndef TkMacOSXUpdateClipRgn
+#define TkMacOSXUpdateClipRgn \
+ (tkIntPlatStubsPtr->tkMacOSXUpdateClipRgn) /* 32 */
+#endif
+#ifndef TkMacOSXUnregisterMacWindow
+#define TkMacOSXUnregisterMacWindow \
+ (tkIntPlatStubsPtr->tkMacOSXUnregisterMacWindow) /* 33 */
+#endif
+#ifndef TkMacOSXUseMenuID
+#define TkMacOSXUseMenuID \
+ (tkIntPlatStubsPtr->tkMacOSXUseMenuID) /* 34 */
+#endif
+#ifndef TkMacOSXVisableClipRgn
+#define TkMacOSXVisableClipRgn \
+ (tkIntPlatStubsPtr->tkMacOSXVisableClipRgn) /* 35 */
+#endif
+#ifndef TkMacOSXWinBounds
+#define TkMacOSXWinBounds \
+ (tkIntPlatStubsPtr->tkMacOSXWinBounds) /* 36 */
+#endif
+#ifndef TkMacOSXWindowOffset
+#define TkMacOSXWindowOffset \
+ (tkIntPlatStubsPtr->tkMacOSXWindowOffset) /* 37 */
+#endif
+#ifndef TkSetMacColor
+#define TkSetMacColor \
+ (tkIntPlatStubsPtr->tkSetMacColor) /* 38 */
+#endif
+#ifndef TkSetWMName
+#define TkSetWMName \
+ (tkIntPlatStubsPtr->tkSetWMName) /* 39 */
+#endif
+#ifndef TkSuspendClipboard
+#define TkSuspendClipboard \
+ (tkIntPlatStubsPtr->tkSuspendClipboard) /* 40 */
+#endif
+#ifndef TkMacOSXZoomToplevel
+#define TkMacOSXZoomToplevel \
+ (tkIntPlatStubsPtr->tkMacOSXZoomToplevel) /* 41 */
+#endif
+#ifndef Tk_TopCoordsToWindow
+#define Tk_TopCoordsToWindow \
+ (tkIntPlatStubsPtr->tk_TopCoordsToWindow) /* 42 */
+#endif
+#ifndef TkMacOSXContainerId
+#define TkMacOSXContainerId \
+ (tkIntPlatStubsPtr->tkMacOSXContainerId) /* 43 */
+#endif
+#ifndef TkMacOSXGetHostToplevel
+#define TkMacOSXGetHostToplevel \
+ (tkIntPlatStubsPtr->tkMacOSXGetHostToplevel) /* 44 */
+#endif
+#ifndef TkMacOSXPreprocessMenu
+#define TkMacOSXPreprocessMenu \
+ (tkIntPlatStubsPtr->tkMacOSXPreprocessMenu) /* 45 */
+#endif
+#ifndef TkpIsWindowFloating
+#define TkpIsWindowFloating \
+ (tkIntPlatStubsPtr->tkpIsWindowFloating) /* 46 */
+#endif
+#ifndef TkMacOSXGetCapture
+#define TkMacOSXGetCapture \
+ (tkIntPlatStubsPtr->tkMacOSXGetCapture) /* 47 */
+#endif
+/* Slot 48 is reserved */
+#ifndef TkGetTransientMaster
+#define TkGetTransientMaster \
+ (tkIntPlatStubsPtr->tkGetTransientMaster) /* 49 */
+#endif
+#ifndef TkGenerateButtonEvent
+#define TkGenerateButtonEvent \
+ (tkIntPlatStubsPtr->tkGenerateButtonEvent) /* 50 */
+#endif
+#ifndef TkGenWMDestroyEvent
+#define TkGenWMDestroyEvent \
+ (tkIntPlatStubsPtr->tkGenWMDestroyEvent) /* 51 */
+#endif
+/* Slot 52 is reserved */
+#ifndef TkpGetMS
+#define TkpGetMS \
+ (tkIntPlatStubsPtr->tkpGetMS) /* 53 */
+#endif
+#endif /* MAC_OSX_TK */
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */
+#ifndef TkCreateXEventSource
+#define TkCreateXEventSource \
+ (tkIntPlatStubsPtr->tkCreateXEventSource) /* 0 */
+#endif
+#ifndef TkFreeWindowId
+#define TkFreeWindowId \
+ (tkIntPlatStubsPtr->tkFreeWindowId) /* 1 */
+#endif
+#ifndef TkInitXId
+#define TkInitXId \
+ (tkIntPlatStubsPtr->tkInitXId) /* 2 */
+#endif
+#ifndef TkpCmapStressed
+#define TkpCmapStressed \
+ (tkIntPlatStubsPtr->tkpCmapStressed) /* 3 */
+#endif
+#ifndef TkpSync
+#define TkpSync \
+ (tkIntPlatStubsPtr->tkpSync) /* 4 */
+#endif
+#ifndef TkUnixContainerId
+#define TkUnixContainerId \
+ (tkIntPlatStubsPtr->tkUnixContainerId) /* 5 */
+#endif
+#ifndef TkUnixDoOneXEvent
+#define TkUnixDoOneXEvent \
+ (tkIntPlatStubsPtr->tkUnixDoOneXEvent) /* 6 */
+#endif
+#ifndef TkUnixSetMenubar
+#define TkUnixSetMenubar \
+ (tkIntPlatStubsPtr->tkUnixSetMenubar) /* 7 */
+#endif
+#ifndef TkpScanWindowId
+#define TkpScanWindowId \
+ (tkIntPlatStubsPtr->tkpScanWindowId) /* 8 */
+#endif
+#ifndef TkWmCleanup
+#define TkWmCleanup \
+ (tkIntPlatStubsPtr->tkWmCleanup) /* 9 */
+#endif
+#ifndef TkSendCleanup
+#define TkSendCleanup \
+ (tkIntPlatStubsPtr->tkSendCleanup) /* 10 */
+#endif
+#ifndef TkFreeXId
+#define TkFreeXId \
+ (tkIntPlatStubsPtr->tkFreeXId) /* 11 */
+#endif
+#ifndef TkpWmSetState
+#define TkpWmSetState \
+ (tkIntPlatStubsPtr->tkpWmSetState) /* 12 */
+#endif
+#endif /* X11 */
+
+#endif /* defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKINTPLATDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.m
new file mode 100755
index 00000000000..203f4d83724
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.m
@@ -0,0 +1,474 @@
+#ifndef _TKINTPLATDECLS_VM
+#define _TKINTPLATDECLS_VM
+#include "tkIntPlatDecls_f.h"
+#ifndef NO_VTABLES
+#ifndef TkAboutDlg
+# define TkAboutDlg (*TkintplatdeclsVptr->V_TkAboutDlg)
+#endif
+
+#ifndef TkAlignImageData
+# define TkAlignImageData (*TkintplatdeclsVptr->V_TkAlignImageData)
+#endif
+
+#ifndef TkCreateXEventSource
+# define TkCreateXEventSource (*TkintplatdeclsVptr->V_TkCreateXEventSource)
+#endif
+
+#ifndef TkFreeWindowId
+# define TkFreeWindowId (*TkintplatdeclsVptr->V_TkFreeWindowId)
+#endif
+
+#ifndef TkFreeXId
+# define TkFreeXId (*TkintplatdeclsVptr->V_TkFreeXId)
+#endif
+
+#ifndef TkGenWMDestroyEvent
+# define TkGenWMDestroyEvent (*TkintplatdeclsVptr->V_TkGenWMDestroyEvent)
+#endif
+
+#ifndef TkGenerateActivateEvents
+# define TkGenerateActivateEvents (*TkintplatdeclsVptr->V_TkGenerateActivateEvents)
+#endif
+
+#ifndef TkGenerateButtonEvent
+# define TkGenerateButtonEvent (*TkintplatdeclsVptr->V_TkGenerateButtonEvent)
+#endif
+
+#ifndef TkGetTransientMaster
+# define TkGetTransientMaster (*TkintplatdeclsVptr->V_TkGetTransientMaster)
+#endif
+
+#ifndef TkInitXId
+# define TkInitXId (*TkintplatdeclsVptr->V_TkInitXId)
+#endif
+
+#ifndef TkMacButtonKeyState
+# define TkMacButtonKeyState (*TkintplatdeclsVptr->V_TkMacButtonKeyState)
+#endif
+
+#ifndef TkMacClearMenubarActive
+# define TkMacClearMenubarActive (*TkintplatdeclsVptr->V_TkMacClearMenubarActive)
+#endif
+
+#ifndef TkMacContainerId
+# define TkMacContainerId (*TkintplatdeclsVptr->V_TkMacContainerId)
+#endif
+
+#ifndef TkMacDispatchMenuEvent
+# define TkMacDispatchMenuEvent (*TkintplatdeclsVptr->V_TkMacDispatchMenuEvent)
+#endif
+
+#ifndef TkMacDoHLEvent
+# define TkMacDoHLEvent (*TkintplatdeclsVptr->V_TkMacDoHLEvent)
+#endif
+
+#ifndef TkMacGenerateTime
+# define TkMacGenerateTime (*TkintplatdeclsVptr->V_TkMacGenerateTime)
+#endif
+
+#ifndef TkMacGetHostToplevel
+# define TkMacGetHostToplevel (*TkintplatdeclsVptr->V_TkMacGetHostToplevel)
+#endif
+
+#ifndef TkMacGetScrollbarGrowWindow
+# define TkMacGetScrollbarGrowWindow (*TkintplatdeclsVptr->V_TkMacGetScrollbarGrowWindow)
+#endif
+
+#ifndef TkMacGetXWindow
+# define TkMacGetXWindow (*TkintplatdeclsVptr->V_TkMacGetXWindow)
+#endif
+
+#ifndef TkMacGrowToplevel
+# define TkMacGrowToplevel (*TkintplatdeclsVptr->V_TkMacGrowToplevel)
+#endif
+
+#ifndef TkMacHandleMenuSelect
+# define TkMacHandleMenuSelect (*TkintplatdeclsVptr->V_TkMacHandleMenuSelect)
+#endif
+
+#ifndef TkMacHandleTearoffMenu
+# define TkMacHandleTearoffMenu (*TkintplatdeclsVptr->V_TkMacHandleTearoffMenu)
+#endif
+
+#ifndef TkMacInstallCursor
+# define TkMacInstallCursor (*TkintplatdeclsVptr->V_TkMacInstallCursor)
+#endif
+
+#ifndef TkMacInvalidateWindow
+# define TkMacInvalidateWindow (*TkintplatdeclsVptr->V_TkMacInvalidateWindow)
+#endif
+
+#ifndef TkMacIsCharacterMissing
+# define TkMacIsCharacterMissing (*TkintplatdeclsVptr->V_TkMacIsCharacterMissing)
+#endif
+
+#ifndef TkMacMakeRealWindowExist
+# define TkMacMakeRealWindowExist (*TkintplatdeclsVptr->V_TkMacMakeRealWindowExist)
+#endif
+
+#ifndef TkMacMakeStippleMap
+# define TkMacMakeStippleMap (*TkintplatdeclsVptr->V_TkMacMakeStippleMap)
+#endif
+
+#ifndef TkMacMenuClick
+# define TkMacMenuClick (*TkintplatdeclsVptr->V_TkMacMenuClick)
+#endif
+
+#ifndef TkMacOSXButtonKeyState
+# define TkMacOSXButtonKeyState (*TkintplatdeclsVptr->V_TkMacOSXButtonKeyState)
+#endif
+
+#ifndef TkMacOSXClearMenubarActive
+# define TkMacOSXClearMenubarActive (*TkintplatdeclsVptr->V_TkMacOSXClearMenubarActive)
+#endif
+
+#ifndef TkMacOSXContainerId
+# define TkMacOSXContainerId (*TkintplatdeclsVptr->V_TkMacOSXContainerId)
+#endif
+
+#ifndef TkMacOSXDispatchMenuEvent
+# define TkMacOSXDispatchMenuEvent (*TkintplatdeclsVptr->V_TkMacOSXDispatchMenuEvent)
+#endif
+
+#ifndef TkMacOSXDoHLEvent
+# define TkMacOSXDoHLEvent (*TkintplatdeclsVptr->V_TkMacOSXDoHLEvent)
+#endif
+
+#ifndef TkMacOSXGetCapture
+# define TkMacOSXGetCapture (*TkintplatdeclsVptr->V_TkMacOSXGetCapture)
+#endif
+
+#ifndef TkMacOSXGetHostToplevel
+# define TkMacOSXGetHostToplevel (*TkintplatdeclsVptr->V_TkMacOSXGetHostToplevel)
+#endif
+
+#ifndef TkMacOSXGetXWindow
+# define TkMacOSXGetXWindow (*TkintplatdeclsVptr->V_TkMacOSXGetXWindow)
+#endif
+
+#ifndef TkMacOSXGrowToplevel
+# define TkMacOSXGrowToplevel (*TkintplatdeclsVptr->V_TkMacOSXGrowToplevel)
+#endif
+
+#ifndef TkMacOSXHandleMenuSelect
+# define TkMacOSXHandleMenuSelect (*TkintplatdeclsVptr->V_TkMacOSXHandleMenuSelect)
+#endif
+
+#ifndef TkMacOSXHandleTearoffMenu
+# define TkMacOSXHandleTearoffMenu (*TkintplatdeclsVptr->V_TkMacOSXHandleTearoffMenu)
+#endif
+
+#ifndef TkMacOSXInstallCursor
+# define TkMacOSXInstallCursor (*TkintplatdeclsVptr->V_TkMacOSXInstallCursor)
+#endif
+
+#ifndef TkMacOSXInvalidateWindow
+# define TkMacOSXInvalidateWindow (*TkintplatdeclsVptr->V_TkMacOSXInvalidateWindow)
+#endif
+
+#ifndef TkMacOSXIsCharacterMissing
+# define TkMacOSXIsCharacterMissing (*TkintplatdeclsVptr->V_TkMacOSXIsCharacterMissing)
+#endif
+
+#ifndef TkMacOSXMakeRealWindowExist
+# define TkMacOSXMakeRealWindowExist (*TkintplatdeclsVptr->V_TkMacOSXMakeRealWindowExist)
+#endif
+
+#ifndef TkMacOSXMakeStippleMap
+# define TkMacOSXMakeStippleMap (*TkintplatdeclsVptr->V_TkMacOSXMakeStippleMap)
+#endif
+
+#ifndef TkMacOSXMenuClick
+# define TkMacOSXMenuClick (*TkintplatdeclsVptr->V_TkMacOSXMenuClick)
+#endif
+
+#ifndef TkMacOSXPreprocessMenu
+# define TkMacOSXPreprocessMenu (*TkintplatdeclsVptr->V_TkMacOSXPreprocessMenu)
+#endif
+
+#ifndef TkMacOSXRegisterOffScreenWindow
+# define TkMacOSXRegisterOffScreenWindow (*TkintplatdeclsVptr->V_TkMacOSXRegisterOffScreenWindow)
+#endif
+
+#ifndef TkMacOSXResizable
+# define TkMacOSXResizable (*TkintplatdeclsVptr->V_TkMacOSXResizable)
+#endif
+
+#ifndef TkMacOSXSetHelpMenuItemCount
+# define TkMacOSXSetHelpMenuItemCount (*TkintplatdeclsVptr->V_TkMacOSXSetHelpMenuItemCount)
+#endif
+
+#ifndef TkMacOSXSetScrollbarGrow
+# define TkMacOSXSetScrollbarGrow (*TkintplatdeclsVptr->V_TkMacOSXSetScrollbarGrow)
+#endif
+
+#ifndef TkMacOSXSetUpClippingRgn
+# define TkMacOSXSetUpClippingRgn (*TkintplatdeclsVptr->V_TkMacOSXSetUpClippingRgn)
+#endif
+
+#ifndef TkMacOSXSetUpGraphicsPort
+# define TkMacOSXSetUpGraphicsPort (*TkintplatdeclsVptr->V_TkMacOSXSetUpGraphicsPort)
+#endif
+
+#ifndef TkMacOSXUnregisterMacWindow
+# define TkMacOSXUnregisterMacWindow (*TkintplatdeclsVptr->V_TkMacOSXUnregisterMacWindow)
+#endif
+
+#ifndef TkMacOSXUpdateClipRgn
+# define TkMacOSXUpdateClipRgn (*TkintplatdeclsVptr->V_TkMacOSXUpdateClipRgn)
+#endif
+
+#ifndef TkMacOSXUseMenuID
+# define TkMacOSXUseMenuID (*TkintplatdeclsVptr->V_TkMacOSXUseMenuID)
+#endif
+
+#ifndef TkMacOSXVisableClipRgn
+# define TkMacOSXVisableClipRgn (*TkintplatdeclsVptr->V_TkMacOSXVisableClipRgn)
+#endif
+
+#ifndef TkMacOSXWinBounds
+# define TkMacOSXWinBounds (*TkintplatdeclsVptr->V_TkMacOSXWinBounds)
+#endif
+
+#ifndef TkMacOSXWindowOffset
+# define TkMacOSXWindowOffset (*TkintplatdeclsVptr->V_TkMacOSXWindowOffset)
+#endif
+
+#ifndef TkMacOSXZoomToplevel
+# define TkMacOSXZoomToplevel (*TkintplatdeclsVptr->V_TkMacOSXZoomToplevel)
+#endif
+
+#ifndef TkMacPreprocessMenu
+# define TkMacPreprocessMenu (*TkintplatdeclsVptr->V_TkMacPreprocessMenu)
+#endif
+
+#ifndef TkMacRegisterOffScreenWindow
+# define TkMacRegisterOffScreenWindow (*TkintplatdeclsVptr->V_TkMacRegisterOffScreenWindow)
+#endif
+
+#ifndef TkMacResizable
+# define TkMacResizable (*TkintplatdeclsVptr->V_TkMacResizable)
+#endif
+
+#ifndef TkMacSetHelpMenuItemCount
+# define TkMacSetHelpMenuItemCount (*TkintplatdeclsVptr->V_TkMacSetHelpMenuItemCount)
+#endif
+
+#ifndef TkMacSetScrollbarGrow
+# define TkMacSetScrollbarGrow (*TkintplatdeclsVptr->V_TkMacSetScrollbarGrow)
+#endif
+
+#ifndef TkMacSetUpClippingRgn
+# define TkMacSetUpClippingRgn (*TkintplatdeclsVptr->V_TkMacSetUpClippingRgn)
+#endif
+
+#ifndef TkMacSetUpGraphicsPort
+# define TkMacSetUpGraphicsPort (*TkintplatdeclsVptr->V_TkMacSetUpGraphicsPort)
+#endif
+
+#ifndef TkMacUnregisterMacWindow
+# define TkMacUnregisterMacWindow (*TkintplatdeclsVptr->V_TkMacUnregisterMacWindow)
+#endif
+
+#ifndef TkMacUpdateClipRgn
+# define TkMacUpdateClipRgn (*TkintplatdeclsVptr->V_TkMacUpdateClipRgn)
+#endif
+
+#ifndef TkMacUseMenuID
+# define TkMacUseMenuID (*TkintplatdeclsVptr->V_TkMacUseMenuID)
+#endif
+
+#ifndef TkMacVisableClipRgn
+# define TkMacVisableClipRgn (*TkintplatdeclsVptr->V_TkMacVisableClipRgn)
+#endif
+
+#ifndef TkMacWinBounds
+# define TkMacWinBounds (*TkintplatdeclsVptr->V_TkMacWinBounds)
+#endif
+
+#ifndef TkMacWindowOffset
+# define TkMacWindowOffset (*TkintplatdeclsVptr->V_TkMacWindowOffset)
+#endif
+
+#ifndef TkMacZoomToplevel
+# define TkMacZoomToplevel (*TkintplatdeclsVptr->V_TkMacZoomToplevel)
+#endif
+
+#ifndef TkPointerDeadWindow
+# define TkPointerDeadWindow (*TkintplatdeclsVptr->V_TkPointerDeadWindow)
+#endif
+
+#ifndef TkSendCleanup
+# define TkSendCleanup (*TkintplatdeclsVptr->V_TkSendCleanup)
+#endif
+
+#ifndef TkSetMacColor
+# define TkSetMacColor (*TkintplatdeclsVptr->V_TkSetMacColor)
+#endif
+
+#ifndef TkSetPixmapColormap
+# define TkSetPixmapColormap (*TkintplatdeclsVptr->V_TkSetPixmapColormap)
+#endif
+
+#ifndef TkSetWMName
+# define TkSetWMName (*TkintplatdeclsVptr->V_TkSetWMName)
+#endif
+
+#ifndef TkSuspendClipboard
+# define TkSuspendClipboard (*TkintplatdeclsVptr->V_TkSuspendClipboard)
+#endif
+
+#ifndef TkUnixContainerId
+# define TkUnixContainerId (*TkintplatdeclsVptr->V_TkUnixContainerId)
+#endif
+
+#ifndef TkUnixDoOneXEvent
+# define TkUnixDoOneXEvent (*TkintplatdeclsVptr->V_TkUnixDoOneXEvent)
+#endif
+
+#ifndef TkUnixSetMenubar
+# define TkUnixSetMenubar (*TkintplatdeclsVptr->V_TkUnixSetMenubar)
+#endif
+
+#ifndef TkWinCancelMouseTimer
+# define TkWinCancelMouseTimer (*TkintplatdeclsVptr->V_TkWinCancelMouseTimer)
+#endif
+
+#ifndef TkWinClipboardRender
+# define TkWinClipboardRender (*TkintplatdeclsVptr->V_TkWinClipboardRender)
+#endif
+
+#ifndef TkWinDialogDebug
+# define TkWinDialogDebug (*TkintplatdeclsVptr->V_TkWinDialogDebug)
+#endif
+
+#ifndef TkWinEmbeddedEventProc
+# define TkWinEmbeddedEventProc (*TkintplatdeclsVptr->V_TkWinEmbeddedEventProc)
+#endif
+
+#ifndef TkWinFillRect
+# define TkWinFillRect (*TkintplatdeclsVptr->V_TkWinFillRect)
+#endif
+
+#ifndef TkWinGetBorderPixels
+# define TkWinGetBorderPixels (*TkintplatdeclsVptr->V_TkWinGetBorderPixels)
+#endif
+
+#ifndef TkWinGetDrawableDC
+# define TkWinGetDrawableDC (*TkintplatdeclsVptr->V_TkWinGetDrawableDC)
+#endif
+
+#ifndef TkWinGetMenuSystemDefault
+# define TkWinGetMenuSystemDefault (*TkintplatdeclsVptr->V_TkWinGetMenuSystemDefault)
+#endif
+
+#ifndef TkWinGetModifierState
+# define TkWinGetModifierState (*TkintplatdeclsVptr->V_TkWinGetModifierState)
+#endif
+
+#ifndef TkWinGetPlatformId
+# define TkWinGetPlatformId (*TkintplatdeclsVptr->V_TkWinGetPlatformId)
+#endif
+
+#ifndef TkWinGetSystemPalette
+# define TkWinGetSystemPalette (*TkintplatdeclsVptr->V_TkWinGetSystemPalette)
+#endif
+
+#ifndef TkWinGetWrapperWindow
+# define TkWinGetWrapperWindow (*TkintplatdeclsVptr->V_TkWinGetWrapperWindow)
+#endif
+
+#ifndef TkWinHandleMenuEvent
+# define TkWinHandleMenuEvent (*TkintplatdeclsVptr->V_TkWinHandleMenuEvent)
+#endif
+
+#ifndef TkWinIndexOfColor
+# define TkWinIndexOfColor (*TkintplatdeclsVptr->V_TkWinIndexOfColor)
+#endif
+
+#ifndef TkWinReleaseDrawableDC
+# define TkWinReleaseDrawableDC (*TkintplatdeclsVptr->V_TkWinReleaseDrawableDC)
+#endif
+
+#ifndef TkWinResendEvent
+# define TkWinResendEvent (*TkintplatdeclsVptr->V_TkWinResendEvent)
+#endif
+
+#ifndef TkWinSelectPalette
+# define TkWinSelectPalette (*TkintplatdeclsVptr->V_TkWinSelectPalette)
+#endif
+
+#ifndef TkWinSetForegroundWindow
+# define TkWinSetForegroundWindow (*TkintplatdeclsVptr->V_TkWinSetForegroundWindow)
+#endif
+
+#ifndef TkWinSetHINSTANCE
+# define TkWinSetHINSTANCE (*TkintplatdeclsVptr->V_TkWinSetHINSTANCE)
+#endif
+
+#ifndef TkWinSetMenu
+# define TkWinSetMenu (*TkintplatdeclsVptr->V_TkWinSetMenu)
+#endif
+
+#ifndef TkWinSetWindowPos
+# define TkWinSetWindowPos (*TkintplatdeclsVptr->V_TkWinSetWindowPos)
+#endif
+
+#ifndef TkWinWmCleanup
+# define TkWinWmCleanup (*TkintplatdeclsVptr->V_TkWinWmCleanup)
+#endif
+
+#ifndef TkWinXCleanup
+# define TkWinXCleanup (*TkintplatdeclsVptr->V_TkWinXCleanup)
+#endif
+
+#ifndef TkWinXInit
+# define TkWinXInit (*TkintplatdeclsVptr->V_TkWinXInit)
+#endif
+
+#ifndef TkWmCleanup
+# define TkWmCleanup (*TkintplatdeclsVptr->V_TkWmCleanup)
+#endif
+
+#ifndef Tk_TopCoordsToWindow
+# define Tk_TopCoordsToWindow (*TkintplatdeclsVptr->V_Tk_TopCoordsToWindow)
+#endif
+
+#ifndef TkpCmapStressed
+# define TkpCmapStressed (*TkintplatdeclsVptr->V_TkpCmapStressed)
+#endif
+
+#ifndef TkpGetMS
+# define TkpGetMS (*TkintplatdeclsVptr->V_TkpGetMS)
+#endif
+
+#ifndef TkpIsWindowFloating
+# define TkpIsWindowFloating (*TkintplatdeclsVptr->V_TkpIsWindowFloating)
+#endif
+
+#ifndef TkpPrintWindowId
+# define TkpPrintWindowId (*TkintplatdeclsVptr->V_TkpPrintWindowId)
+#endif
+
+#ifndef TkpScanWindowId
+# define TkpScanWindowId (*TkintplatdeclsVptr->V_TkpScanWindowId)
+#endif
+
+#ifndef TkpSetCapture
+# define TkpSetCapture (*TkintplatdeclsVptr->V_TkpSetCapture)
+#endif
+
+#ifndef TkpSetCursor
+# define TkpSetCursor (*TkintplatdeclsVptr->V_TkpSetCursor)
+#endif
+
+#ifndef TkpSync
+# define TkpSync (*TkintplatdeclsVptr->V_TkpSync)
+#endif
+
+#ifndef TkpWmSetState
+# define TkpWmSetState (*TkintplatdeclsVptr->V_TkpWmSetState)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKINTPLATDECLS_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.t
new file mode 100755
index 00000000000..72bcbc0977e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls.t
@@ -0,0 +1,845 @@
+#ifdef _TKINTPLATDECLS
+#ifndef TkAboutDlg
+#ifdef MAC_OSX_TK
+VFUNC(void,TkAboutDlg,V_TkAboutDlg,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkAboutDlg,V_TkAboutDlg,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkAboutDlg */
+
+#ifndef TkAlignImageData
+#ifdef __WIN32__
+VFUNC(char *,TkAlignImageData,V_TkAlignImageData,_ANSI_ARGS_((XImage * image,
+ int alignment, int bitOrder)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkAlignImageData */
+
+#ifndef TkCreateXEventSource
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkCreateXEventSource,V_TkCreateXEventSource,_ANSI_ARGS_((void)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkCreateXEventSource */
+
+#ifndef TkFreeWindowId
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkFreeWindowId,V_TkFreeWindowId,_ANSI_ARGS_((TkDisplay * dispPtr,
+ Window w)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkFreeWindowId */
+
+#ifndef TkFreeXId
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkFreeXId,V_TkFreeXId,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkFreeXId */
+
+#ifndef TkGenWMDestroyEvent
+#ifdef MAC_OSX_TK
+VFUNC(void,TkGenWMDestroyEvent,V_TkGenWMDestroyEvent,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkGenWMDestroyEvent,V_TkGenWMDestroyEvent,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkGenWMDestroyEvent */
+
+#ifndef TkGenerateActivateEvents
+#ifdef MAC_OSX_TK
+VFUNC(void,TkGenerateActivateEvents,V_TkGenerateActivateEvents,_ANSI_ARGS_((
+ TkWindow * winPtr, int active)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkGenerateActivateEvents,V_TkGenerateActivateEvents,_ANSI_ARGS_((
+ TkWindow * winPtr, int active)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkGenerateActivateEvents,V_TkGenerateActivateEvents,_ANSI_ARGS_((
+ TkWindow * winPtr, int active)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkGenerateActivateEvents */
+
+#ifndef TkGenerateButtonEvent
+#ifdef MAC_OSX_TK
+VFUNC(int,TkGenerateButtonEvent,V_TkGenerateButtonEvent,_ANSI_ARGS_((int x, int y,
+ Window window, unsigned int state)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,TkGenerateButtonEvent,V_TkGenerateButtonEvent,_ANSI_ARGS_((int x, int y,
+ Window window, unsigned int state)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkGenerateButtonEvent */
+
+#ifndef TkGetTransientMaster
+#ifdef MAC_OSX_TK
+VFUNC(Window,TkGetTransientMaster,V_TkGetTransientMaster,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Window,TkGetTransientMaster,V_TkGetTransientMaster,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkGetTransientMaster */
+
+#ifndef TkInitXId
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkInitXId,V_TkInitXId,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkInitXId */
+
+#ifndef TkMacButtonKeyState
+#ifdef MAC_TCL
+VFUNC(unsigned int,TkMacButtonKeyState,V_TkMacButtonKeyState,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacButtonKeyState */
+
+#ifndef TkMacClearMenubarActive
+#ifdef MAC_TCL
+VFUNC(void,TkMacClearMenubarActive,V_TkMacClearMenubarActive,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacClearMenubarActive */
+
+#ifndef TkMacContainerId
+#ifdef MAC_TCL
+VFUNC(MacDrawable *,TkMacContainerId,V_TkMacContainerId,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacContainerId */
+
+#ifndef TkMacDispatchMenuEvent
+#ifdef MAC_TCL
+VFUNC(int,TkMacDispatchMenuEvent,V_TkMacDispatchMenuEvent,_ANSI_ARGS_((int menuID,
+ int index)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacDispatchMenuEvent */
+
+#ifndef TkMacDoHLEvent
+#ifdef MAC_TCL
+VFUNC(void,TkMacDoHLEvent,V_TkMacDoHLEvent,_ANSI_ARGS_((EventRecord * theEvent)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacDoHLEvent */
+
+#ifndef TkMacGenerateTime
+#ifdef MAC_TCL
+VFUNC(Time,TkMacGenerateTime,V_TkMacGenerateTime,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacGenerateTime */
+
+#ifndef TkMacGetHostToplevel
+#ifdef MAC_TCL
+VFUNC(MacDrawable *,TkMacGetHostToplevel,V_TkMacGetHostToplevel,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacGetHostToplevel */
+
+#ifndef TkMacGetScrollbarGrowWindow
+#ifdef MAC_TCL
+VFUNC(TkWindow *,TkMacGetScrollbarGrowWindow,V_TkMacGetScrollbarGrowWindow,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacGetScrollbarGrowWindow */
+
+#ifndef TkMacGetXWindow
+#ifdef MAC_TCL
+VFUNC(Window,TkMacGetXWindow,V_TkMacGetXWindow,_ANSI_ARGS_((WindowRef macWinPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacGetXWindow */
+
+#ifndef TkMacGrowToplevel
+#ifdef MAC_TCL
+VFUNC(int,TkMacGrowToplevel,V_TkMacGrowToplevel,_ANSI_ARGS_((WindowRef whichWindow,
+ Point start)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacGrowToplevel */
+
+#ifndef TkMacHandleMenuSelect
+#ifdef MAC_TCL
+VFUNC(void,TkMacHandleMenuSelect,V_TkMacHandleMenuSelect,_ANSI_ARGS_((long mResult,
+ int optionKeyPressed)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacHandleMenuSelect */
+
+#ifndef TkMacHandleTearoffMenu
+#ifdef MAC_TCL
+VFUNC(void,TkMacHandleTearoffMenu,V_TkMacHandleTearoffMenu,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacHandleTearoffMenu */
+
+#ifndef TkMacInstallCursor
+#ifdef MAC_TCL
+VFUNC(void,TkMacInstallCursor,V_TkMacInstallCursor,_ANSI_ARGS_((int resizeOverride)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacInstallCursor */
+
+#ifndef TkMacInvalidateWindow
+#ifdef MAC_TCL
+VFUNC(void,TkMacInvalidateWindow,V_TkMacInvalidateWindow,_ANSI_ARGS_((
+ MacDrawable * macWin, int flag)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacInvalidateWindow */
+
+#ifndef TkMacIsCharacterMissing
+#ifdef MAC_TCL
+VFUNC(int,TkMacIsCharacterMissing,V_TkMacIsCharacterMissing,_ANSI_ARGS_((Tk_Font tkfont,
+ unsigned int searchChar)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacIsCharacterMissing */
+
+#ifndef TkMacMakeRealWindowExist
+#ifdef MAC_TCL
+VFUNC(void,TkMacMakeRealWindowExist,V_TkMacMakeRealWindowExist,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacMakeRealWindowExist */
+
+#ifndef TkMacMakeStippleMap
+#ifdef MAC_TCL
+VFUNC(BitMapPtr,TkMacMakeStippleMap,V_TkMacMakeStippleMap,_ANSI_ARGS_((Drawable d1,
+ Drawable d2)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacMakeStippleMap */
+
+#ifndef TkMacMenuClick
+#ifdef MAC_TCL
+VFUNC(void,TkMacMenuClick,V_TkMacMenuClick,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacMenuClick */
+
+#ifndef TkMacOSXButtonKeyState
+#ifdef MAC_OSX_TK
+VFUNC(unsigned int,TkMacOSXButtonKeyState,V_TkMacOSXButtonKeyState,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXButtonKeyState */
+
+#ifndef TkMacOSXClearMenubarActive
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXClearMenubarActive,V_TkMacOSXClearMenubarActive,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXClearMenubarActive */
+
+#ifndef TkMacOSXContainerId
+#ifdef MAC_OSX_TK
+VFUNC(MacDrawable *,TkMacOSXContainerId,V_TkMacOSXContainerId,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXContainerId */
+
+#ifndef TkMacOSXDispatchMenuEvent
+#ifdef MAC_OSX_TK
+VFUNC(int,TkMacOSXDispatchMenuEvent,V_TkMacOSXDispatchMenuEvent,_ANSI_ARGS_((int menuID,
+ int index)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXDispatchMenuEvent */
+
+#ifndef TkMacOSXDoHLEvent
+#ifdef MAC_OSX_TK
+VFUNC(int,TkMacOSXDoHLEvent,V_TkMacOSXDoHLEvent,_ANSI_ARGS_((
+ EventRecord * theEvent)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXDoHLEvent */
+
+#ifndef TkMacOSXGetCapture
+#ifdef MAC_OSX_TK
+VFUNC(Tk_Window,TkMacOSXGetCapture,V_TkMacOSXGetCapture,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXGetCapture */
+
+#ifndef TkMacOSXGetHostToplevel
+#ifdef MAC_OSX_TK
+VFUNC(MacDrawable *,TkMacOSXGetHostToplevel,V_TkMacOSXGetHostToplevel,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXGetHostToplevel */
+
+#ifndef TkMacOSXGetXWindow
+#ifdef MAC_OSX_TK
+VFUNC(Window,TkMacOSXGetXWindow,V_TkMacOSXGetXWindow,_ANSI_ARGS_((WindowRef macWinPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXGetXWindow */
+
+#ifndef TkMacOSXGrowToplevel
+#ifdef MAC_OSX_TK
+VFUNC(int,TkMacOSXGrowToplevel,V_TkMacOSXGrowToplevel,_ANSI_ARGS_((
+ WindowRef whichWindow, Point start)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXGrowToplevel */
+
+#ifndef TkMacOSXHandleMenuSelect
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXHandleMenuSelect,V_TkMacOSXHandleMenuSelect,_ANSI_ARGS_((long mResult,
+ int optionKeyPressed)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXHandleMenuSelect */
+
+#ifndef TkMacOSXHandleTearoffMenu
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXHandleTearoffMenu,V_TkMacOSXHandleTearoffMenu,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXHandleTearoffMenu */
+
+#ifndef TkMacOSXInstallCursor
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXInstallCursor,V_TkMacOSXInstallCursor,_ANSI_ARGS_((
+ int resizeOverride)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXInstallCursor */
+
+#ifndef TkMacOSXInvalidateWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXInvalidateWindow,V_TkMacOSXInvalidateWindow,_ANSI_ARGS_((
+ MacDrawable * macWin, int flag)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXInvalidateWindow */
+
+#ifndef TkMacOSXIsCharacterMissing
+#ifdef MAC_OSX_TK
+VFUNC(int,TkMacOSXIsCharacterMissing,V_TkMacOSXIsCharacterMissing,_ANSI_ARGS_((
+ Tk_Font tkfont, unsigned int searchChar)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXIsCharacterMissing */
+
+#ifndef TkMacOSXMakeRealWindowExist
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXMakeRealWindowExist,V_TkMacOSXMakeRealWindowExist,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXMakeRealWindowExist */
+
+#ifndef TkMacOSXMakeStippleMap
+#ifdef MAC_OSX_TK
+VFUNC(BitMapPtr,TkMacOSXMakeStippleMap,V_TkMacOSXMakeStippleMap,_ANSI_ARGS_((Drawable d1,
+ Drawable d2)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXMakeStippleMap */
+
+#ifndef TkMacOSXMenuClick
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXMenuClick,V_TkMacOSXMenuClick,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXMenuClick */
+
+#ifndef TkMacOSXPreprocessMenu
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXPreprocessMenu,V_TkMacOSXPreprocessMenu,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXPreprocessMenu */
+
+#ifndef TkMacOSXRegisterOffScreenWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXRegisterOffScreenWindow,V_TkMacOSXRegisterOffScreenWindow,_ANSI_ARGS_((
+ Window window, GWorldPtr portPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXRegisterOffScreenWindow */
+
+#ifndef TkMacOSXResizable
+#ifdef MAC_OSX_TK
+VFUNC(int,TkMacOSXResizable,V_TkMacOSXResizable,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXResizable */
+
+#ifndef TkMacOSXSetHelpMenuItemCount
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXSetHelpMenuItemCount,V_TkMacOSXSetHelpMenuItemCount,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXSetHelpMenuItemCount */
+
+#ifndef TkMacOSXSetScrollbarGrow
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXSetScrollbarGrow,V_TkMacOSXSetScrollbarGrow,_ANSI_ARGS_((
+ TkWindow * winPtr, int flag)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXSetScrollbarGrow */
+
+#ifndef TkMacOSXSetUpClippingRgn
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXSetUpClippingRgn,V_TkMacOSXSetUpClippingRgn,_ANSI_ARGS_((
+ Drawable drawable)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXSetUpClippingRgn */
+
+#ifndef TkMacOSXSetUpGraphicsPort
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXSetUpGraphicsPort,V_TkMacOSXSetUpGraphicsPort,_ANSI_ARGS_((GC gc,
+ GWorldPtr destPort)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXSetUpGraphicsPort */
+
+#ifndef TkMacOSXUnregisterMacWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXUnregisterMacWindow,V_TkMacOSXUnregisterMacWindow,_ANSI_ARGS_((
+ WindowRef portPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXUnregisterMacWindow */
+
+#ifndef TkMacOSXUpdateClipRgn
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXUpdateClipRgn,V_TkMacOSXUpdateClipRgn,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXUpdateClipRgn */
+
+#ifndef TkMacOSXUseMenuID
+#ifdef MAC_OSX_TK
+VFUNC(int,TkMacOSXUseMenuID,V_TkMacOSXUseMenuID,_ANSI_ARGS_((short macID)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXUseMenuID */
+
+#ifndef TkMacOSXVisableClipRgn
+#ifdef MAC_OSX_TK
+VFUNC(RgnHandle,TkMacOSXVisableClipRgn,V_TkMacOSXVisableClipRgn,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXVisableClipRgn */
+
+#ifndef TkMacOSXWinBounds
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXWinBounds,V_TkMacOSXWinBounds,_ANSI_ARGS_((TkWindow * winPtr,
+ Rect * geometry)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXWinBounds */
+
+#ifndef TkMacOSXWindowOffset
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXWindowOffset,V_TkMacOSXWindowOffset,_ANSI_ARGS_((WindowRef wRef,
+ int * xOffset, int * yOffset)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXWindowOffset */
+
+#ifndef TkMacOSXZoomToplevel
+#ifdef MAC_OSX_TK
+VFUNC(int,TkMacOSXZoomToplevel,V_TkMacOSXZoomToplevel,_ANSI_ARGS_((
+ WindowPtr whichWindow, Point where,
+ short zoomPart)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXZoomToplevel */
+
+#ifndef TkMacPreprocessMenu
+#ifdef MAC_TCL
+VFUNC(void,TkMacPreprocessMenu,V_TkMacPreprocessMenu,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacPreprocessMenu */
+
+#ifndef TkMacRegisterOffScreenWindow
+#ifdef MAC_TCL
+VFUNC(void,TkMacRegisterOffScreenWindow,V_TkMacRegisterOffScreenWindow,_ANSI_ARGS_((
+ Window window, GWorldPtr portPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacRegisterOffScreenWindow */
+
+#ifndef TkMacResizable
+#ifdef MAC_TCL
+VFUNC(int,TkMacResizable,V_TkMacResizable,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacResizable */
+
+#ifndef TkMacSetHelpMenuItemCount
+#ifdef MAC_TCL
+VFUNC(void,TkMacSetHelpMenuItemCount,V_TkMacSetHelpMenuItemCount,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacSetHelpMenuItemCount */
+
+#ifndef TkMacSetScrollbarGrow
+#ifdef MAC_TCL
+VFUNC(void,TkMacSetScrollbarGrow,V_TkMacSetScrollbarGrow,_ANSI_ARGS_((TkWindow * winPtr,
+ int flag)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacSetScrollbarGrow */
+
+#ifndef TkMacSetUpClippingRgn
+#ifdef MAC_TCL
+VFUNC(void,TkMacSetUpClippingRgn,V_TkMacSetUpClippingRgn,_ANSI_ARGS_((Drawable drawable)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacSetUpClippingRgn */
+
+#ifndef TkMacSetUpGraphicsPort
+#ifdef MAC_TCL
+VFUNC(void,TkMacSetUpGraphicsPort,V_TkMacSetUpGraphicsPort,_ANSI_ARGS_((GC gc)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacSetUpGraphicsPort */
+
+#ifndef TkMacUnregisterMacWindow
+#ifdef MAC_TCL
+VFUNC(void,TkMacUnregisterMacWindow,V_TkMacUnregisterMacWindow,_ANSI_ARGS_((
+ GWorldPtr portPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacUnregisterMacWindow */
+
+#ifndef TkMacUpdateClipRgn
+#ifdef MAC_TCL
+VFUNC(void,TkMacUpdateClipRgn,V_TkMacUpdateClipRgn,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacUpdateClipRgn */
+
+#ifndef TkMacUseMenuID
+#ifdef MAC_TCL
+VFUNC(int,TkMacUseMenuID,V_TkMacUseMenuID,_ANSI_ARGS_((short macID)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacUseMenuID */
+
+#ifndef TkMacVisableClipRgn
+#ifdef MAC_TCL
+VFUNC(RgnHandle,TkMacVisableClipRgn,V_TkMacVisableClipRgn,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacVisableClipRgn */
+
+#ifndef TkMacWinBounds
+#ifdef MAC_TCL
+VFUNC(void,TkMacWinBounds,V_TkMacWinBounds,_ANSI_ARGS_((TkWindow * winPtr,
+ Rect * geometry)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacWinBounds */
+
+#ifndef TkMacWindowOffset
+#ifdef MAC_TCL
+VFUNC(void,TkMacWindowOffset,V_TkMacWindowOffset,_ANSI_ARGS_((WindowRef wRef,
+ int * xOffset, int * yOffset)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacWindowOffset */
+
+#ifndef TkMacZoomToplevel
+#ifdef MAC_TCL
+VFUNC(int,TkMacZoomToplevel,V_TkMacZoomToplevel,_ANSI_ARGS_((WindowPtr whichWindow,
+ Point where, short zoomPart)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacZoomToplevel */
+
+#ifndef TkPointerDeadWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,TkPointerDeadWindow,V_TkPointerDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkPointerDeadWindow,V_TkPointerDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkPointerDeadWindow,V_TkPointerDeadWindow,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkPointerDeadWindow */
+
+#ifndef TkSendCleanup
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkSendCleanup,V_TkSendCleanup,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkSendCleanup */
+
+#ifndef TkSetMacColor
+#ifdef MAC_OSX_TK
+VFUNC(int,TkSetMacColor,V_TkSetMacColor,_ANSI_ARGS_((unsigned long pixel,
+ RGBColor * macColor)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,TkSetMacColor,V_TkSetMacColor,_ANSI_ARGS_((unsigned long pixel,
+ RGBColor * macColor)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkSetMacColor */
+
+#ifndef TkSetPixmapColormap
+#ifdef __WIN32__
+VFUNC(void,TkSetPixmapColormap,V_TkSetPixmapColormap,_ANSI_ARGS_((Pixmap pixmap,
+ Colormap colormap)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkSetPixmapColormap */
+
+#ifndef TkSetWMName
+#ifdef MAC_OSX_TK
+VFUNC(void,TkSetWMName,V_TkSetWMName,_ANSI_ARGS_((TkWindow * winPtr,
+ Tk_Uid titleUid)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkSetWMName,V_TkSetWMName,_ANSI_ARGS_((TkWindow * winPtr,
+ Tk_Uid titleUid)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkSetWMName */
+
+#ifndef TkSuspendClipboard
+#ifdef MAC_OSX_TK
+VFUNC(void,TkSuspendClipboard,V_TkSuspendClipboard,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkSuspendClipboard,V_TkSuspendClipboard,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkSuspendClipboard */
+
+#ifndef TkUnixContainerId
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(Window,TkUnixContainerId,V_TkUnixContainerId,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkUnixContainerId */
+
+#ifndef TkUnixDoOneXEvent
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(int,TkUnixDoOneXEvent,V_TkUnixDoOneXEvent,_ANSI_ARGS_((Tcl_Time * timePtr)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkUnixDoOneXEvent */
+
+#ifndef TkUnixSetMenubar
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkUnixSetMenubar,V_TkUnixSetMenubar,_ANSI_ARGS_((Tk_Window tkwin,
+ Tk_Window menubar)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkUnixSetMenubar */
+
+#ifndef TkWinCancelMouseTimer
+#ifdef __WIN32__
+VFUNC(void,TkWinCancelMouseTimer,V_TkWinCancelMouseTimer,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinCancelMouseTimer */
+
+#ifndef TkWinClipboardRender
+#ifdef __WIN32__
+VFUNC(void,TkWinClipboardRender,V_TkWinClipboardRender,_ANSI_ARGS_((
+ TkDisplay * dispPtr, UINT format)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinClipboardRender */
+
+#ifndef TkWinDialogDebug
+#ifdef __WIN32__
+VFUNC(void,TkWinDialogDebug,V_TkWinDialogDebug,_ANSI_ARGS_((int debug)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinDialogDebug */
+
+#ifndef TkWinEmbeddedEventProc
+#ifdef __WIN32__
+VFUNC(LRESULT,TkWinEmbeddedEventProc,V_TkWinEmbeddedEventProc,_ANSI_ARGS_((HWND hwnd,
+ UINT message, WPARAM wParam, LPARAM lParam)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinEmbeddedEventProc */
+
+#ifndef TkWinFillRect
+#ifdef __WIN32__
+VFUNC(void,TkWinFillRect,V_TkWinFillRect,_ANSI_ARGS_((HDC dc, int x, int y,
+ int width, int height, int pixel)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinFillRect */
+
+#ifndef TkWinGetBorderPixels
+#ifdef __WIN32__
+VFUNC(COLORREF,TkWinGetBorderPixels,V_TkWinGetBorderPixels,_ANSI_ARGS_((Tk_Window tkwin,
+ Tk_3DBorder border, int which)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinGetBorderPixels */
+
+#ifndef TkWinGetDrawableDC
+#ifdef __WIN32__
+VFUNC(HDC,TkWinGetDrawableDC,V_TkWinGetDrawableDC,_ANSI_ARGS_((Display * display,
+ Drawable d, TkWinDCState* state)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinGetDrawableDC */
+
+#ifndef TkWinGetMenuSystemDefault
+#ifdef __WIN32__
+VFUNC(Tcl_Obj *,TkWinGetMenuSystemDefault,V_TkWinGetMenuSystemDefault,_ANSI_ARGS_((
+ Tk_Window tkwin, CONST char * dbName,
+ CONST char * className)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinGetMenuSystemDefault */
+
+#ifndef TkWinGetModifierState
+#ifdef __WIN32__
+VFUNC(int,TkWinGetModifierState,V_TkWinGetModifierState,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinGetModifierState */
+
+#ifndef TkWinGetPlatformId
+#ifdef __WIN32__
+VFUNC(int,TkWinGetPlatformId,V_TkWinGetPlatformId,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinGetPlatformId */
+
+#ifndef TkWinGetSystemPalette
+#ifdef __WIN32__
+VFUNC(HPALETTE,TkWinGetSystemPalette,V_TkWinGetSystemPalette,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinGetSystemPalette */
+
+#ifndef TkWinGetWrapperWindow
+#ifdef __WIN32__
+VFUNC(HWND,TkWinGetWrapperWindow,V_TkWinGetWrapperWindow,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinGetWrapperWindow */
+
+#ifndef TkWinHandleMenuEvent
+#ifdef __WIN32__
+VFUNC(int,TkWinHandleMenuEvent,V_TkWinHandleMenuEvent,_ANSI_ARGS_((HWND * phwnd,
+ UINT * pMessage, WPARAM * pwParam,
+ LPARAM * plParam, LRESULT * plResult)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinHandleMenuEvent */
+
+#ifndef TkWinIndexOfColor
+#ifdef __WIN32__
+VFUNC(int,TkWinIndexOfColor,V_TkWinIndexOfColor,_ANSI_ARGS_((XColor * colorPtr)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinIndexOfColor */
+
+#ifndef TkWinReleaseDrawableDC
+#ifdef __WIN32__
+VFUNC(void,TkWinReleaseDrawableDC,V_TkWinReleaseDrawableDC,_ANSI_ARGS_((Drawable d,
+ HDC hdc, TkWinDCState* state)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinReleaseDrawableDC */
+
+#ifndef TkWinResendEvent
+#ifdef __WIN32__
+VFUNC(LRESULT,TkWinResendEvent,V_TkWinResendEvent,_ANSI_ARGS_((WNDPROC wndproc,
+ HWND hwnd, XEvent * eventPtr)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinResendEvent */
+
+#ifndef TkWinSelectPalette
+#ifdef __WIN32__
+VFUNC(HPALETTE,TkWinSelectPalette,V_TkWinSelectPalette,_ANSI_ARGS_((HDC dc,
+ Colormap colormap)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinSelectPalette */
+
+#ifndef TkWinSetForegroundWindow
+#ifdef __WIN32__
+VFUNC(void,TkWinSetForegroundWindow,V_TkWinSetForegroundWindow,_ANSI_ARGS_((
+ TkWindow * winPtr)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinSetForegroundWindow */
+
+#ifndef TkWinSetHINSTANCE
+#ifdef __WIN32__
+VFUNC(void,TkWinSetHINSTANCE,V_TkWinSetHINSTANCE,_ANSI_ARGS_((HINSTANCE hInstance)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinSetHINSTANCE */
+
+#ifndef TkWinSetMenu
+#ifdef __WIN32__
+VFUNC(void,TkWinSetMenu,V_TkWinSetMenu,_ANSI_ARGS_((Tk_Window tkwin,
+ HMENU hMenu)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinSetMenu */
+
+#ifndef TkWinSetWindowPos
+#ifdef __WIN32__
+VFUNC(void,TkWinSetWindowPos,V_TkWinSetWindowPos,_ANSI_ARGS_((HWND hwnd,
+ HWND siblingHwnd, int pos)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinSetWindowPos */
+
+#ifndef TkWinWmCleanup
+#ifdef __WIN32__
+VFUNC(void,TkWinWmCleanup,V_TkWinWmCleanup,_ANSI_ARGS_((HINSTANCE hInstance)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinWmCleanup */
+
+#ifndef TkWinXCleanup
+#ifdef __WIN32__
+VFUNC(void,TkWinXCleanup,V_TkWinXCleanup,_ANSI_ARGS_((HINSTANCE hInstance)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinXCleanup */
+
+#ifndef TkWinXInit
+#ifdef __WIN32__
+VFUNC(void,TkWinXInit,V_TkWinXInit,_ANSI_ARGS_((HINSTANCE hInstance)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkWinXInit */
+
+#ifndef TkWmCleanup
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkWmCleanup,V_TkWmCleanup,_ANSI_ARGS_((TkDisplay * dispPtr)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkWmCleanup */
+
+#ifndef Tk_TopCoordsToWindow
+#ifdef MAC_OSX_TK
+VFUNC(Tk_Window,Tk_TopCoordsToWindow,V_Tk_TopCoordsToWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ int rootX, int rootY, int * newX, int * newY)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Tk_Window,Tk_TopCoordsToWindow,V_Tk_TopCoordsToWindow,_ANSI_ARGS_((Tk_Window tkwin,
+ int rootX, int rootY, int * newX, int * newY)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef Tk_TopCoordsToWindow */
+
+#ifndef TkpCmapStressed
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(int,TkpCmapStressed,V_TkpCmapStressed,_ANSI_ARGS_((Tk_Window tkwin,
+ Colormap colormap)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkpCmapStressed */
+
+#ifndef TkpGetMS
+#ifdef MAC_OSX_TK
+VFUNC(unsigned long,TkpGetMS,V_TkpGetMS,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(unsigned long,TkpGetMS,V_TkpGetMS,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(unsigned long,TkpGetMS,V_TkpGetMS,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkpGetMS */
+
+#ifndef TkpIsWindowFloating
+#ifdef MAC_OSX_TK
+VFUNC(int,TkpIsWindowFloating,V_TkpIsWindowFloating,_ANSI_ARGS_((WindowRef window)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,TkpIsWindowFloating,V_TkpIsWindowFloating,_ANSI_ARGS_((WindowRef window)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkpIsWindowFloating */
+
+#ifndef TkpPrintWindowId
+#ifdef __WIN32__
+VFUNC(void,TkpPrintWindowId,V_TkpPrintWindowId,_ANSI_ARGS_((char * buf,
+ Window window)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkpPrintWindowId */
+
+#ifndef TkpScanWindowId
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(int,TkpScanWindowId,V_TkpScanWindowId,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *string, Window * idPtr)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#ifdef __WIN32__
+VFUNC(int,TkpScanWindowId,V_TkpScanWindowId,_ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * string, Window * idPtr)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkpScanWindowId */
+
+#ifndef TkpSetCapture
+#ifdef MAC_OSX_TK
+VFUNC(void,TkpSetCapture,V_TkpSetCapture,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkpSetCapture,V_TkpSetCapture,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkpSetCapture,V_TkpSetCapture,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkpSetCapture */
+
+#ifndef TkpSetCursor
+#ifdef MAC_OSX_TK
+VFUNC(void,TkpSetCursor,V_TkpSetCursor,_ANSI_ARGS_((TkpCursor cursor)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkpSetCursor,V_TkpSetCursor,_ANSI_ARGS_((TkpCursor cursor)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkpSetCursor,V_TkpSetCursor,_ANSI_ARGS_((TkpCursor cursor)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkpSetCursor */
+
+#ifndef TkpSync
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(void,TkpSync,V_TkpSync,_ANSI_ARGS_((Display * display)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#endif /* #ifndef TkpSync */
+
+#ifndef TkpWmSetState
+#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))
+VFUNC(int,TkpWmSetState,V_TkpWmSetState,_ANSI_ARGS_((TkWindow * winPtr,
+ int state)))
+#endif /* #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) */
+#ifdef MAC_OSX_TK
+VFUNC(void,TkpWmSetState,V_TkpWmSetState,_ANSI_ARGS_((TkWindow * winPtr,
+ int state)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkpWmSetState,V_TkpWmSetState,_ANSI_ARGS_((TkWindow * winPtr,
+ int state)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkpWmSetState,V_TkpWmSetState,_ANSI_ARGS_((TkWindow * winPtr,
+ int state)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkpWmSetState */
+
+#endif /* _TKINTPLATDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls_f.h
new file mode 100755
index 00000000000..8eef38bdcb1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntPlatDecls_f.h
@@ -0,0 +1,14 @@
+#ifndef TKINTPLATDECLS_VT
+#define TKINTPLATDECLS_VT
+typedef struct TkintplatdeclsVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkIntPlatDecls.t"
+#undef VFUNC
+#undef VVAR
+} TkintplatdeclsVtab;
+extern TkintplatdeclsVtab *TkintplatdeclsVptr;
+extern TkintplatdeclsVtab *TkintplatdeclsVGet(void);
+#endif /* TKINTPLATDECLS_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.h
new file mode 100755
index 00000000000..052c5ba9737
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.h
@@ -0,0 +1,2436 @@
+/*
+ * tkIntXlibDecls.h --
+ *
+ * This file contains the declarations for all platform dependent
+ * unsupported functions that are exported by the Tk library. These
+ * interfaces are not guaranteed to remain the same between
+ * versions. Use at your own risk.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * All rights reserved.
+ *
+ * RCS: @(#) $Id: tkIntXlibDecls.h,v 1.16 2002/10/09 11:56:33 das Exp $
+ */
+
+#ifndef _TKINTXLIBDECLS
+#define _TKINTXLIBDECLS
+
+#include <X11/Xlib.h>
+
+#ifdef MAC_TCL
+#include "Xutil.h"
+#else
+#include "X11/Xutil.h"
+#endif
+
+#include "Lang.h"
+
+#ifdef BUILD_tk
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tkInt.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+#ifdef __WIN32__
+/* 0 */
+EXTERN void XSetDashes _ANSI_ARGS_((Display* display, GC gc,
+ int dash_offset, _Xconst char* dash_list,
+ int n));
+/* 1 */
+EXTERN XModifierKeymap* XGetModifierMapping _ANSI_ARGS_((Display* d));
+/* 2 */
+EXTERN XImage * XCreateImage _ANSI_ARGS_((Display* d, Visual* v,
+ unsigned int ui1, int i1, int i2, char* cp,
+ unsigned int ui2, unsigned int ui3, int i3,
+ int i4));
+/* 3 */
+EXTERN XImage * XGetImage _ANSI_ARGS_((Display* d, Drawable dr,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, unsigned long ul, int i3));
+/* 4 */
+EXTERN char * XGetAtomName _ANSI_ARGS_((Display* d, Atom a));
+/* 5 */
+EXTERN char * XKeysymToString _ANSI_ARGS_((KeySym k));
+/* 6 */
+EXTERN Colormap XCreateColormap _ANSI_ARGS_((Display* d, Window w,
+ Visual* v, int i));
+/* 7 */
+EXTERN Cursor XCreatePixmapCursor _ANSI_ARGS_((Display* d,
+ Pixmap p1, Pixmap p2, XColor* x1, XColor* x2,
+ unsigned int ui1, unsigned int ui2));
+/* 8 */
+EXTERN Cursor XCreateGlyphCursor _ANSI_ARGS_((Display* d, Font f1,
+ Font f2, unsigned int ui1, unsigned int ui2,
+ XColor* x1, XColor* x2));
+/* 9 */
+EXTERN GContext XGContextFromGC _ANSI_ARGS_((GC g));
+/* 10 */
+EXTERN XHostAddress * XListHosts _ANSI_ARGS_((Display* d, int* i, Bool* b));
+/* 11 */
+EXTERN KeySym XKeycodeToKeysym _ANSI_ARGS_((Display* d,
+ unsigned int k, int i));
+/* 12 */
+EXTERN KeySym XStringToKeysym _ANSI_ARGS_((_Xconst char* c));
+/* 13 */
+EXTERN Window XRootWindow _ANSI_ARGS_((Display* d, int i));
+/* 14 */
+EXTERN XErrorHandler XSetErrorHandler _ANSI_ARGS_((XErrorHandler x));
+/* 15 */
+EXTERN Status XIconifyWindow _ANSI_ARGS_((Display* d, Window w,
+ int i));
+/* 16 */
+EXTERN Status XWithdrawWindow _ANSI_ARGS_((Display* d, Window w,
+ int i));
+/* 17 */
+EXTERN Status XGetWMColormapWindows _ANSI_ARGS_((Display* d,
+ Window w, Window** wpp, int* ip));
+/* 18 */
+EXTERN Status XAllocColor _ANSI_ARGS_((Display* d, Colormap c,
+ XColor* xp));
+/* 19 */
+EXTERN void XBell _ANSI_ARGS_((Display* d, int i));
+/* 20 */
+EXTERN void XChangeProperty _ANSI_ARGS_((Display* d, Window w,
+ Atom a1, Atom a2, int i1, int i2,
+ _Xconst unsigned char* c, int i3));
+/* 21 */
+EXTERN void XChangeWindowAttributes _ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul,
+ XSetWindowAttributes* x));
+/* 22 */
+EXTERN void XClearWindow _ANSI_ARGS_((Display* d, Window w));
+/* 23 */
+EXTERN void XConfigureWindow _ANSI_ARGS_((Display* d, Window w,
+ unsigned int i, XWindowChanges* x));
+/* 24 */
+EXTERN void XCopyArea _ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4));
+/* 25 */
+EXTERN void XCopyPlane _ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4, unsigned long ul));
+/* 26 */
+EXTERN Pixmap XCreateBitmapFromData _ANSI_ARGS_((Display* display,
+ Drawable d, _Xconst char* data,
+ unsigned int width, unsigned int height));
+/* 27 */
+EXTERN void XDefineCursor _ANSI_ARGS_((Display* d, Window w,
+ Cursor c));
+/* 28 */
+EXTERN void XDeleteProperty _ANSI_ARGS_((Display* d, Window w,
+ Atom a));
+/* 29 */
+EXTERN void XDestroyWindow _ANSI_ARGS_((Display* d, Window w));
+/* 30 */
+EXTERN void XDrawArc _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4));
+/* 31 */
+EXTERN void XDrawLines _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2));
+/* 32 */
+EXTERN void XDrawRectangle _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, int i1, int i2, unsigned int ui1,
+ unsigned int ui2));
+/* 33 */
+EXTERN void XFillArc _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4));
+/* 34 */
+EXTERN void XFillPolygon _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2, int i3));
+/* 35 */
+EXTERN void XFillRectangles _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XRectangle* x, int i));
+/* 36 */
+EXTERN void XForceScreenSaver _ANSI_ARGS_((Display* d, int i));
+/* 37 */
+EXTERN void XFreeColormap _ANSI_ARGS_((Display* d, Colormap c));
+/* 38 */
+EXTERN void XFreeColors _ANSI_ARGS_((Display* d, Colormap c,
+ unsigned long* ulp, int i, unsigned long ul));
+/* 39 */
+EXTERN void XFreeCursor _ANSI_ARGS_((Display* d, Cursor c));
+/* 40 */
+EXTERN void XFreeModifiermap _ANSI_ARGS_((XModifierKeymap* x));
+/* 41 */
+EXTERN Status XGetGeometry _ANSI_ARGS_((Display* d, Drawable dr,
+ Window* w, int* i1, int* i2,
+ unsigned int* ui1, unsigned int* ui2,
+ unsigned int* ui3, unsigned int* ui4));
+/* 42 */
+EXTERN void XGetInputFocus _ANSI_ARGS_((Display* d, Window* w,
+ int* i));
+/* 43 */
+EXTERN int XGetWindowProperty _ANSI_ARGS_((Display* d, Window w,
+ Atom a1, long l1, long l2, Bool b, Atom a2,
+ Atom* ap, int* ip, unsigned long* ulp1,
+ unsigned long* ulp2, unsigned char** cpp));
+/* 44 */
+EXTERN Status XGetWindowAttributes _ANSI_ARGS_((Display* d,
+ Window w, XWindowAttributes* x));
+/* 45 */
+EXTERN int XGrabKeyboard _ANSI_ARGS_((Display* d, Window w,
+ Bool b, int i1, int i2, Time t));
+/* 46 */
+EXTERN int XGrabPointer _ANSI_ARGS_((Display* d, Window w1,
+ Bool b, unsigned int ui, int i1, int i2,
+ Window w2, Cursor c, Time t));
+/* 47 */
+EXTERN KeyCode XKeysymToKeycode _ANSI_ARGS_((Display* d, KeySym k));
+/* 48 */
+EXTERN Status XLookupColor _ANSI_ARGS_((Display* d, Colormap c1,
+ _Xconst char* c2, XColor* x1, XColor* x2));
+/* 49 */
+EXTERN void XMapWindow _ANSI_ARGS_((Display* d, Window w));
+/* 50 */
+EXTERN void XMoveResizeWindow _ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2));
+/* 51 */
+EXTERN void XMoveWindow _ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2));
+/* 52 */
+EXTERN void XNextEvent _ANSI_ARGS_((Display* d, XEvent* x));
+/* 53 */
+EXTERN void XPutBackEvent _ANSI_ARGS_((Display* d, XEvent* x));
+/* 54 */
+EXTERN void XQueryColors _ANSI_ARGS_((Display* d, Colormap c,
+ XColor* x, int i));
+/* 55 */
+EXTERN Bool XQueryPointer _ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, int* i1, int* i2,
+ int* i3, int* i4, unsigned int* ui));
+/* 56 */
+EXTERN Status XQueryTree _ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, Window** w4,
+ unsigned int* ui));
+/* 57 */
+EXTERN void XRaiseWindow _ANSI_ARGS_((Display* d, Window w));
+/* 58 */
+EXTERN void XRefreshKeyboardMapping _ANSI_ARGS_((
+ XMappingEvent* x));
+/* 59 */
+EXTERN void XResizeWindow _ANSI_ARGS_((Display* d, Window w,
+ unsigned int ui1, unsigned int ui2));
+/* 60 */
+EXTERN void XSelectInput _ANSI_ARGS_((Display* d, Window w,
+ long l));
+/* 61 */
+EXTERN Status XSendEvent _ANSI_ARGS_((Display* d, Window w, Bool b,
+ long l, XEvent* x));
+/* 62 */
+EXTERN void XSetCommand _ANSI_ARGS_((Display* d, Window w,
+ CONST char** c, int i));
+/* 63 */
+EXTERN void XSetIconName _ANSI_ARGS_((Display* d, Window w,
+ _Xconst char* c));
+/* 64 */
+EXTERN void XSetInputFocus _ANSI_ARGS_((Display* d, Window w,
+ int i, Time t));
+/* 65 */
+EXTERN void XSetSelectionOwner _ANSI_ARGS_((Display* d, Atom a,
+ Window w, Time t));
+/* 66 */
+EXTERN void XSetWindowBackground _ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul));
+/* 67 */
+EXTERN void XSetWindowBackgroundPixmap _ANSI_ARGS_((Display* d,
+ Window w, Pixmap p));
+/* 68 */
+EXTERN void XSetWindowBorder _ANSI_ARGS_((Display* d, Window w,
+ unsigned long ul));
+/* 69 */
+EXTERN void XSetWindowBorderPixmap _ANSI_ARGS_((Display* d,
+ Window w, Pixmap p));
+/* 70 */
+EXTERN void XSetWindowBorderWidth _ANSI_ARGS_((Display* d,
+ Window w, unsigned int ui));
+/* 71 */
+EXTERN void XSetWindowColormap _ANSI_ARGS_((Display* d, Window w,
+ Colormap c));
+/* 72 */
+EXTERN Bool XTranslateCoordinates _ANSI_ARGS_((Display* d,
+ Window w1, Window w2, int i1, int i2,
+ int* i3, int* i4, Window* w3));
+/* 73 */
+EXTERN void XUngrabKeyboard _ANSI_ARGS_((Display* d, Time t));
+/* 74 */
+EXTERN void XUngrabPointer _ANSI_ARGS_((Display* d, Time t));
+/* 75 */
+EXTERN void XUnmapWindow _ANSI_ARGS_((Display* d, Window w));
+/* 76 */
+EXTERN void XWindowEvent _ANSI_ARGS_((Display* d, Window w,
+ long l, XEvent* x));
+/* 77 */
+EXTERN void XDestroyIC _ANSI_ARGS_((XIC x));
+/* 78 */
+EXTERN Bool XFilterEvent _ANSI_ARGS_((XEvent* x, Window w));
+/* 79 */
+EXTERN int XmbLookupString _ANSI_ARGS_((XIC xi,
+ XKeyPressedEvent* xk, char* c, int i,
+ KeySym* k, Status* s));
+/* 80 */
+EXTERN void TkPutImage _ANSI_ARGS_((unsigned long * colors,
+ int ncolors, Display* display, Drawable d,
+ GC gc, XImage* image, int src_x, int src_y,
+ int dest_x, int dest_y, unsigned int width,
+ unsigned int height));
+/* Slot 81 is reserved */
+/* 82 */
+EXTERN Status XParseColor _ANSI_ARGS_((Display * display,
+ Colormap map, _Xconst char* spec,
+ XColor * colorPtr));
+/* 83 */
+EXTERN GC XCreateGC _ANSI_ARGS_((Display* display, Drawable d,
+ unsigned long valuemask, XGCValues* values));
+/* 84 */
+EXTERN void XFreeGC _ANSI_ARGS_((Display* display, GC gc));
+/* 85 */
+EXTERN Atom XInternAtom _ANSI_ARGS_((Display* display,
+ _Xconst char* atom_name, Bool only_if_exists));
+/* 86 */
+EXTERN void XSetBackground _ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground));
+/* 87 */
+EXTERN void XSetForeground _ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground));
+/* 88 */
+EXTERN void XSetClipMask _ANSI_ARGS_((Display* display, GC gc,
+ Pixmap pixmap));
+/* 89 */
+EXTERN void XSetClipOrigin _ANSI_ARGS_((Display* display, GC gc,
+ int clip_x_origin, int clip_y_origin));
+/* 90 */
+EXTERN void XSetTSOrigin _ANSI_ARGS_((Display* display, GC gc,
+ int ts_x_origin, int ts_y_origin));
+/* 91 */
+EXTERN void XChangeGC _ANSI_ARGS_((Display * d, GC gc,
+ unsigned long mask, XGCValues * values));
+/* 92 */
+EXTERN void XSetFont _ANSI_ARGS_((Display * display, GC gc,
+ Font font));
+/* 93 */
+EXTERN void XSetArcMode _ANSI_ARGS_((Display * display, GC gc,
+ int arc_mode));
+/* 94 */
+EXTERN void XSetStipple _ANSI_ARGS_((Display * display, GC gc,
+ Pixmap stipple));
+/* 95 */
+EXTERN void XSetFillRule _ANSI_ARGS_((Display * display, GC gc,
+ int fill_rule));
+/* 96 */
+EXTERN void XSetFillStyle _ANSI_ARGS_((Display * display, GC gc,
+ int fill_style));
+/* 97 */
+EXTERN void XSetFunction _ANSI_ARGS_((Display * display, GC gc,
+ int function));
+/* 98 */
+EXTERN void XSetLineAttributes _ANSI_ARGS_((Display * display,
+ GC gc, unsigned int line_width,
+ int line_style, int cap_style,
+ int join_style));
+/* 99 */
+EXTERN int _XInitImageFuncPtrs _ANSI_ARGS_((XImage * image));
+/* 100 */
+EXTERN XIC XCreateIC _ANSI_ARGS_((void));
+/* 101 */
+EXTERN XVisualInfo * XGetVisualInfo _ANSI_ARGS_((Display* display,
+ long vinfo_mask, XVisualInfo* vinfo_template,
+ int* nitems_return));
+/* 102 */
+EXTERN void XSetWMClientMachine _ANSI_ARGS_((Display* display,
+ Window w, XTextProperty* text_prop));
+/* 103 */
+EXTERN Status XStringListToTextProperty _ANSI_ARGS_((char** list,
+ int count, XTextProperty* text_prop_return));
+/* 104 */
+EXTERN void XDrawLine _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int x1, int y1, int x2, int y2));
+/* 105 */
+EXTERN void XWarpPointer _ANSI_ARGS_((Display* d, Window s,
+ Window dw, int sx, int sy, unsigned int sw,
+ unsigned int sh, int dx, int dy));
+/* 106 */
+EXTERN void XFillRectangle _ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, int x, int y,
+ unsigned int width, unsigned int height));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 0 */
+EXTERN void XSetDashes _ANSI_ARGS_((Display* display, GC gc,
+ int dash_offset, _Xconst char* dash_list,
+ int n));
+/* 1 */
+EXTERN XModifierKeymap* XGetModifierMapping _ANSI_ARGS_((Display* d));
+/* 2 */
+EXTERN XImage * XCreateImage _ANSI_ARGS_((Display* d, Visual* v,
+ unsigned int ui1, int i1, int i2, char* cp,
+ unsigned int ui2, unsigned int ui3, int i3,
+ int i4));
+/* 3 */
+EXTERN XImage * XGetImage _ANSI_ARGS_((Display* d, Drawable dr,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, unsigned long ul, int i3));
+/* 4 */
+EXTERN char * XGetAtomName _ANSI_ARGS_((Display* d, Atom a));
+/* 5 */
+EXTERN char * XKeysymToString _ANSI_ARGS_((KeySym k));
+/* 6 */
+EXTERN Colormap XCreateColormap _ANSI_ARGS_((Display* d, Window w,
+ Visual* v, int i));
+/* 7 */
+EXTERN GContext XGContextFromGC _ANSI_ARGS_((GC g));
+/* 8 */
+EXTERN KeySym XKeycodeToKeysym _ANSI_ARGS_((Display* d, KeyCode k,
+ int i));
+/* 9 */
+EXTERN KeySym XStringToKeysym _ANSI_ARGS_((_Xconst char* c));
+/* 10 */
+EXTERN Window XRootWindow _ANSI_ARGS_((Display* d, int i));
+/* 11 */
+EXTERN XErrorHandler XSetErrorHandler _ANSI_ARGS_((XErrorHandler x));
+/* 12 */
+EXTERN Status XAllocColor _ANSI_ARGS_((Display* d, Colormap c,
+ XColor* xp));
+/* 13 */
+EXTERN void XBell _ANSI_ARGS_((Display* d, int i));
+/* 14 */
+EXTERN void XChangeProperty _ANSI_ARGS_((Display* d, Window w,
+ Atom a1, Atom a2, int i1, int i2,
+ _Xconst unsigned char* c, int i3));
+/* 15 */
+EXTERN void XChangeWindowAttributes _ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul,
+ XSetWindowAttributes* x));
+/* 16 */
+EXTERN void XConfigureWindow _ANSI_ARGS_((Display* d, Window w,
+ unsigned int i, XWindowChanges* x));
+/* 17 */
+EXTERN void XCopyArea _ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4));
+/* 18 */
+EXTERN void XCopyPlane _ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4, unsigned long ul));
+/* 19 */
+EXTERN Pixmap XCreateBitmapFromData _ANSI_ARGS_((Display* display,
+ Drawable d, _Xconst char* data,
+ unsigned int width, unsigned int height));
+/* 20 */
+EXTERN void XDefineCursor _ANSI_ARGS_((Display* d, Window w,
+ Cursor c));
+/* 21 */
+EXTERN void XDestroyWindow _ANSI_ARGS_((Display* d, Window w));
+/* 22 */
+EXTERN void XDrawArc _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4));
+/* 23 */
+EXTERN void XDrawLines _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2));
+/* 24 */
+EXTERN void XDrawRectangle _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, int i1, int i2, unsigned int ui1,
+ unsigned int ui2));
+/* 25 */
+EXTERN void XFillArc _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4));
+/* 26 */
+EXTERN void XFillPolygon _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2, int i3));
+/* 27 */
+EXTERN void XFillRectangles _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XRectangle* x, int i));
+/* 28 */
+EXTERN void XFreeColormap _ANSI_ARGS_((Display* d, Colormap c));
+/* 29 */
+EXTERN void XFreeColors _ANSI_ARGS_((Display* d, Colormap c,
+ unsigned long* ulp, int i, unsigned long ul));
+/* 30 */
+EXTERN void XFreeModifiermap _ANSI_ARGS_((XModifierKeymap* x));
+/* 31 */
+EXTERN Status XGetGeometry _ANSI_ARGS_((Display* d, Drawable dr,
+ Window* w, int* i1, int* i2,
+ unsigned int* ui1, unsigned int* ui2,
+ unsigned int* ui3, unsigned int* ui4));
+/* 32 */
+EXTERN int XGetWindowProperty _ANSI_ARGS_((Display* d, Window w,
+ Atom a1, long l1, long l2, Bool b, Atom a2,
+ Atom* ap, int* ip, unsigned long* ulp1,
+ unsigned long* ulp2, unsigned char** cpp));
+/* 33 */
+EXTERN int XGrabKeyboard _ANSI_ARGS_((Display* d, Window w,
+ Bool b, int i1, int i2, Time t));
+/* 34 */
+EXTERN int XGrabPointer _ANSI_ARGS_((Display* d, Window w1,
+ Bool b, unsigned int ui, int i1, int i2,
+ Window w2, Cursor c, Time t));
+/* 35 */
+EXTERN KeyCode XKeysymToKeycode _ANSI_ARGS_((Display* d, KeySym k));
+/* 36 */
+EXTERN void XMapWindow _ANSI_ARGS_((Display* d, Window w));
+/* 37 */
+EXTERN void XMoveResizeWindow _ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2));
+/* 38 */
+EXTERN void XMoveWindow _ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2));
+/* 39 */
+EXTERN Bool XQueryPointer _ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, int* i1, int* i2,
+ int* i3, int* i4, unsigned int* ui));
+/* 40 */
+EXTERN void XRaiseWindow _ANSI_ARGS_((Display* d, Window w));
+/* 41 */
+EXTERN void XRefreshKeyboardMapping _ANSI_ARGS_((
+ XMappingEvent* x));
+/* 42 */
+EXTERN void XResizeWindow _ANSI_ARGS_((Display* d, Window w,
+ unsigned int ui1, unsigned int ui2));
+/* 43 */
+EXTERN void XSelectInput _ANSI_ARGS_((Display* d, Window w,
+ long l));
+/* 44 */
+EXTERN Status XSendEvent _ANSI_ARGS_((Display* d, Window w, Bool b,
+ long l, XEvent* x));
+/* 45 */
+EXTERN void XSetIconName _ANSI_ARGS_((Display* d, Window w,
+ _Xconst char* c));
+/* 46 */
+EXTERN void XSetInputFocus _ANSI_ARGS_((Display* d, Window w,
+ int i, Time t));
+/* 47 */
+EXTERN void XSetSelectionOwner _ANSI_ARGS_((Display* d, Atom a,
+ Window w, Time t));
+/* 48 */
+EXTERN void XSetWindowBackground _ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul));
+/* 49 */
+EXTERN void XSetWindowBackgroundPixmap _ANSI_ARGS_((Display* d,
+ Window w, Pixmap p));
+/* 50 */
+EXTERN void XSetWindowBorder _ANSI_ARGS_((Display* d, Window w,
+ unsigned long ul));
+/* 51 */
+EXTERN void XSetWindowBorderPixmap _ANSI_ARGS_((Display* d,
+ Window w, Pixmap p));
+/* 52 */
+EXTERN void XSetWindowBorderWidth _ANSI_ARGS_((Display* d,
+ Window w, unsigned int ui));
+/* 53 */
+EXTERN void XSetWindowColormap _ANSI_ARGS_((Display* d, Window w,
+ Colormap c));
+/* 54 */
+EXTERN void XUngrabKeyboard _ANSI_ARGS_((Display* d, Time t));
+/* 55 */
+EXTERN void XUngrabPointer _ANSI_ARGS_((Display* d, Time t));
+/* 56 */
+EXTERN void XUnmapWindow _ANSI_ARGS_((Display* d, Window w));
+/* 57 */
+EXTERN void TkPutImage _ANSI_ARGS_((unsigned long * colors,
+ int ncolors, Display* display, Drawable d,
+ GC gc, XImage* image, int src_x, int src_y,
+ int dest_x, int dest_y, unsigned int width,
+ unsigned int height));
+/* 58 */
+EXTERN Status XParseColor _ANSI_ARGS_((Display * display,
+ Colormap map, _Xconst char* spec,
+ XColor * colorPtr));
+/* 59 */
+EXTERN GC XCreateGC _ANSI_ARGS_((Display* display, Drawable d,
+ unsigned long valuemask, XGCValues* values));
+/* 60 */
+EXTERN void XFreeGC _ANSI_ARGS_((Display* display, GC gc));
+/* 61 */
+EXTERN Atom XInternAtom _ANSI_ARGS_((Display* display,
+ _Xconst char* atom_name, Bool only_if_exists));
+/* 62 */
+EXTERN void XSetBackground _ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground));
+/* 63 */
+EXTERN void XSetForeground _ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground));
+/* 64 */
+EXTERN void XSetClipMask _ANSI_ARGS_((Display* display, GC gc,
+ Pixmap pixmap));
+/* 65 */
+EXTERN void XSetClipOrigin _ANSI_ARGS_((Display* display, GC gc,
+ int clip_x_origin, int clip_y_origin));
+/* 66 */
+EXTERN void XSetTSOrigin _ANSI_ARGS_((Display* display, GC gc,
+ int ts_x_origin, int ts_y_origin));
+/* 67 */
+EXTERN void XChangeGC _ANSI_ARGS_((Display * d, GC gc,
+ unsigned long mask, XGCValues * values));
+/* 68 */
+EXTERN void XSetFont _ANSI_ARGS_((Display * display, GC gc,
+ Font font));
+/* 69 */
+EXTERN void XSetArcMode _ANSI_ARGS_((Display * display, GC gc,
+ int arc_mode));
+/* 70 */
+EXTERN void XSetStipple _ANSI_ARGS_((Display * display, GC gc,
+ Pixmap stipple));
+/* 71 */
+EXTERN void XSetFillRule _ANSI_ARGS_((Display * display, GC gc,
+ int fill_rule));
+/* 72 */
+EXTERN void XSetFillStyle _ANSI_ARGS_((Display * display, GC gc,
+ int fill_style));
+/* 73 */
+EXTERN void XSetFunction _ANSI_ARGS_((Display * display, GC gc,
+ int function));
+/* 74 */
+EXTERN void XSetLineAttributes _ANSI_ARGS_((Display * display,
+ GC gc, unsigned int line_width,
+ int line_style, int cap_style,
+ int join_style));
+/* 75 */
+EXTERN int _XInitImageFuncPtrs _ANSI_ARGS_((XImage * image));
+/* 76 */
+EXTERN XIC XCreateIC _ANSI_ARGS_((void));
+/* 77 */
+EXTERN XVisualInfo * XGetVisualInfo _ANSI_ARGS_((Display* display,
+ long vinfo_mask, XVisualInfo* vinfo_template,
+ int* nitems_return));
+/* 78 */
+EXTERN void XSetWMClientMachine _ANSI_ARGS_((Display* display,
+ Window w, XTextProperty* text_prop));
+/* 79 */
+EXTERN Status XStringListToTextProperty _ANSI_ARGS_((char** list,
+ int count, XTextProperty* text_prop_return));
+/* 80 */
+EXTERN void XDrawSegments _ANSI_ARGS_((Display * display,
+ Drawable d, GC gc, XSegment * segments,
+ int nsegments));
+/* 81 */
+EXTERN void XForceScreenSaver _ANSI_ARGS_((Display* display,
+ int mode));
+/* 82 */
+EXTERN void XDrawLine _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int x1, int y1, int x2, int y2));
+/* 83 */
+EXTERN void XFillRectangle _ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, int x, int y,
+ unsigned int width, unsigned int height));
+/* 84 */
+EXTERN void XClearWindow _ANSI_ARGS_((Display* d, Window w));
+/* 85 */
+EXTERN void XDrawPoint _ANSI_ARGS_((Display* display, Drawable d,
+ GC gc, int x, int y));
+/* 86 */
+EXTERN void XDrawPoints _ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, XPoint * points,
+ int npoints, int mode));
+/* 87 */
+EXTERN void XWarpPointer _ANSI_ARGS_((Display* display,
+ Window src_w, Window dest_w, int src_x,
+ int src_y, unsigned int src_width,
+ unsigned int src_height, int dest_x,
+ int dest_y));
+/* 88 */
+EXTERN void XQueryColor _ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * def_in_out));
+/* 89 */
+EXTERN void XQueryColors _ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * defs_in_out,
+ int ncolors));
+/* 90 */
+EXTERN Status XQueryTree _ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, Window** w4,
+ unsigned int* ui));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 0 */
+EXTERN void XSetDashes _ANSI_ARGS_((Display* display, GC gc,
+ int dash_offset, _Xconst char* dash_list,
+ int n));
+/* 1 */
+EXTERN XModifierKeymap* XGetModifierMapping _ANSI_ARGS_((Display* d));
+/* 2 */
+EXTERN XImage * XCreateImage _ANSI_ARGS_((Display* d, Visual* v,
+ unsigned int ui1, int i1, int i2, char* cp,
+ unsigned int ui2, unsigned int ui3, int i3,
+ int i4));
+/* 3 */
+EXTERN XImage * XGetImage _ANSI_ARGS_((Display* d, Drawable dr,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, unsigned long ul, int i3));
+/* 4 */
+EXTERN char * XGetAtomName _ANSI_ARGS_((Display* d, Atom a));
+/* 5 */
+EXTERN char * XKeysymToString _ANSI_ARGS_((KeySym k));
+/* 6 */
+EXTERN Colormap XCreateColormap _ANSI_ARGS_((Display* d, Window w,
+ Visual* v, int i));
+/* 7 */
+EXTERN GContext XGContextFromGC _ANSI_ARGS_((GC g));
+/* 8 */
+EXTERN KeySym XKeycodeToKeysym _ANSI_ARGS_((Display* d, KeyCode k,
+ int i));
+/* 9 */
+EXTERN KeySym XStringToKeysym _ANSI_ARGS_((_Xconst char* c));
+/* 10 */
+EXTERN Window XRootWindow _ANSI_ARGS_((Display* d, int i));
+/* 11 */
+EXTERN XErrorHandler XSetErrorHandler _ANSI_ARGS_((XErrorHandler x));
+/* 12 */
+EXTERN Status XAllocColor _ANSI_ARGS_((Display* d, Colormap c,
+ XColor* xp));
+/* 13 */
+EXTERN void XBell _ANSI_ARGS_((Display* d, int i));
+/* 14 */
+EXTERN void XChangeProperty _ANSI_ARGS_((Display* d, Window w,
+ Atom a1, Atom a2, int i1, int i2,
+ _Xconst unsigned char* c, int i3));
+/* 15 */
+EXTERN void XChangeWindowAttributes _ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul,
+ XSetWindowAttributes* x));
+/* 16 */
+EXTERN void XConfigureWindow _ANSI_ARGS_((Display* d, Window w,
+ unsigned int i, XWindowChanges* x));
+/* 17 */
+EXTERN void XCopyArea _ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4));
+/* 18 */
+EXTERN void XCopyPlane _ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4, unsigned long ul));
+/* 19 */
+EXTERN Pixmap XCreateBitmapFromData _ANSI_ARGS_((Display* display,
+ Drawable d, _Xconst char* data,
+ unsigned int width, unsigned int height));
+/* 20 */
+EXTERN void XDefineCursor _ANSI_ARGS_((Display* d, Window w,
+ Cursor c));
+/* 21 */
+EXTERN void XDestroyWindow _ANSI_ARGS_((Display* d, Window w));
+/* 22 */
+EXTERN void XDrawArc _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4));
+/* 23 */
+EXTERN void XDrawLines _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2));
+/* 24 */
+EXTERN void XDrawRectangle _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, int i1, int i2, unsigned int ui1,
+ unsigned int ui2));
+/* 25 */
+EXTERN void XFillArc _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4));
+/* 26 */
+EXTERN void XFillPolygon _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2, int i3));
+/* 27 */
+EXTERN void XFillRectangles _ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XRectangle* x, int i));
+/* 28 */
+EXTERN void XFreeColormap _ANSI_ARGS_((Display* d, Colormap c));
+/* 29 */
+EXTERN void XFreeColors _ANSI_ARGS_((Display* d, Colormap c,
+ unsigned long* ulp, int i, unsigned long ul));
+/* 30 */
+EXTERN void XFreeModifiermap _ANSI_ARGS_((XModifierKeymap* x));
+/* 31 */
+EXTERN Status XGetGeometry _ANSI_ARGS_((Display* d, Drawable dr,
+ Window* w, int* i1, int* i2,
+ unsigned int* ui1, unsigned int* ui2,
+ unsigned int* ui3, unsigned int* ui4));
+/* 32 */
+EXTERN int XGetWindowProperty _ANSI_ARGS_((Display* d, Window w,
+ Atom a1, long l1, long l2, Bool b, Atom a2,
+ Atom* ap, int* ip, unsigned long* ulp1,
+ unsigned long* ulp2, unsigned char** cpp));
+/* 33 */
+EXTERN int XGrabKeyboard _ANSI_ARGS_((Display* d, Window w,
+ Bool b, int i1, int i2, Time t));
+/* 34 */
+EXTERN int XGrabPointer _ANSI_ARGS_((Display* d, Window w1,
+ Bool b, unsigned int ui, int i1, int i2,
+ Window w2, Cursor c, Time t));
+/* 35 */
+EXTERN KeyCode XKeysymToKeycode _ANSI_ARGS_((Display* d, KeySym k));
+/* 36 */
+EXTERN void XMapWindow _ANSI_ARGS_((Display* d, Window w));
+/* 37 */
+EXTERN void XMoveResizeWindow _ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2));
+/* 38 */
+EXTERN void XMoveWindow _ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2));
+/* 39 */
+EXTERN Bool XQueryPointer _ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, int* i1, int* i2,
+ int* i3, int* i4, unsigned int* ui));
+/* 40 */
+EXTERN void XRaiseWindow _ANSI_ARGS_((Display* d, Window w));
+/* 41 */
+EXTERN void XRefreshKeyboardMapping _ANSI_ARGS_((
+ XMappingEvent* x));
+/* 42 */
+EXTERN void XResizeWindow _ANSI_ARGS_((Display* d, Window w,
+ unsigned int ui1, unsigned int ui2));
+/* 43 */
+EXTERN void XSelectInput _ANSI_ARGS_((Display* d, Window w,
+ long l));
+/* 44 */
+EXTERN Status XSendEvent _ANSI_ARGS_((Display* d, Window w, Bool b,
+ long l, XEvent* x));
+/* 45 */
+EXTERN void XSetIconName _ANSI_ARGS_((Display* d, Window w,
+ _Xconst char* c));
+/* 46 */
+EXTERN void XSetInputFocus _ANSI_ARGS_((Display* d, Window w,
+ int i, Time t));
+/* 47 */
+EXTERN void XSetSelectionOwner _ANSI_ARGS_((Display* d, Atom a,
+ Window w, Time t));
+/* 48 */
+EXTERN void XSetWindowBackground _ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul));
+/* 49 */
+EXTERN void XSetWindowBackgroundPixmap _ANSI_ARGS_((Display* d,
+ Window w, Pixmap p));
+/* 50 */
+EXTERN void XSetWindowBorder _ANSI_ARGS_((Display* d, Window w,
+ unsigned long ul));
+/* 51 */
+EXTERN void XSetWindowBorderPixmap _ANSI_ARGS_((Display* d,
+ Window w, Pixmap p));
+/* 52 */
+EXTERN void XSetWindowBorderWidth _ANSI_ARGS_((Display* d,
+ Window w, unsigned int ui));
+/* 53 */
+EXTERN void XSetWindowColormap _ANSI_ARGS_((Display* d, Window w,
+ Colormap c));
+/* 54 */
+EXTERN void XUngrabKeyboard _ANSI_ARGS_((Display* d, Time t));
+/* 55 */
+EXTERN void XUngrabPointer _ANSI_ARGS_((Display* d, Time t));
+/* 56 */
+EXTERN void XUnmapWindow _ANSI_ARGS_((Display* d, Window w));
+/* 57 */
+EXTERN void TkPutImage _ANSI_ARGS_((unsigned long * colors,
+ int ncolors, Display* display, Drawable d,
+ GC gc, XImage* image, int src_x, int src_y,
+ int dest_x, int dest_y, unsigned int width,
+ unsigned int height));
+/* 58 */
+EXTERN Status XParseColor _ANSI_ARGS_((Display * display,
+ Colormap map, _Xconst char* spec,
+ XColor * colorPtr));
+/* 59 */
+EXTERN GC XCreateGC _ANSI_ARGS_((Display* display, Drawable d,
+ unsigned long valuemask, XGCValues* values));
+/* 60 */
+EXTERN void XFreeGC _ANSI_ARGS_((Display* display, GC gc));
+/* 61 */
+EXTERN Atom XInternAtom _ANSI_ARGS_((Display* display,
+ _Xconst char* atom_name, Bool only_if_exists));
+/* 62 */
+EXTERN void XSetBackground _ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground));
+/* 63 */
+EXTERN void XSetForeground _ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground));
+/* 64 */
+EXTERN void XSetClipMask _ANSI_ARGS_((Display* display, GC gc,
+ Pixmap pixmap));
+/* 65 */
+EXTERN void XSetClipOrigin _ANSI_ARGS_((Display* display, GC gc,
+ int clip_x_origin, int clip_y_origin));
+/* 66 */
+EXTERN void XSetTSOrigin _ANSI_ARGS_((Display* display, GC gc,
+ int ts_x_origin, int ts_y_origin));
+/* 67 */
+EXTERN void XChangeGC _ANSI_ARGS_((Display * d, GC gc,
+ unsigned long mask, XGCValues * values));
+/* 68 */
+EXTERN void XSetFont _ANSI_ARGS_((Display * display, GC gc,
+ Font font));
+/* 69 */
+EXTERN void XSetArcMode _ANSI_ARGS_((Display * display, GC gc,
+ int arc_mode));
+/* 70 */
+EXTERN void XSetStipple _ANSI_ARGS_((Display * display, GC gc,
+ Pixmap stipple));
+/* 71 */
+EXTERN void XSetFillRule _ANSI_ARGS_((Display * display, GC gc,
+ int fill_rule));
+/* 72 */
+EXTERN void XSetFillStyle _ANSI_ARGS_((Display * display, GC gc,
+ int fill_style));
+/* 73 */
+EXTERN void XSetFunction _ANSI_ARGS_((Display * display, GC gc,
+ int function));
+/* 74 */
+EXTERN void XSetLineAttributes _ANSI_ARGS_((Display * display,
+ GC gc, unsigned int line_width,
+ int line_style, int cap_style,
+ int join_style));
+/* 75 */
+EXTERN int _XInitImageFuncPtrs _ANSI_ARGS_((XImage * image));
+/* 76 */
+EXTERN XIC XCreateIC _ANSI_ARGS_((void));
+/* 77 */
+EXTERN XVisualInfo * XGetVisualInfo _ANSI_ARGS_((Display* display,
+ long vinfo_mask, XVisualInfo* vinfo_template,
+ int* nitems_return));
+/* 78 */
+EXTERN void XSetWMClientMachine _ANSI_ARGS_((Display* display,
+ Window w, XTextProperty* text_prop));
+/* 79 */
+EXTERN Status XStringListToTextProperty _ANSI_ARGS_((char** list,
+ int count, XTextProperty* text_prop_return));
+/* 80 */
+EXTERN void XDrawSegments _ANSI_ARGS_((Display * display,
+ Drawable d, GC gc, XSegment * segments,
+ int nsegments));
+/* 81 */
+EXTERN void XForceScreenSaver _ANSI_ARGS_((Display* display,
+ int mode));
+/* 82 */
+EXTERN void XDrawLine _ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int x1, int y1, int x2, int y2));
+/* 83 */
+EXTERN void XFillRectangle _ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, int x, int y,
+ unsigned int width, unsigned int height));
+/* 84 */
+EXTERN void XClearWindow _ANSI_ARGS_((Display* d, Window w));
+/* 85 */
+EXTERN void XDrawPoint _ANSI_ARGS_((Display* display, Drawable d,
+ GC gc, int x, int y));
+/* 86 */
+EXTERN void XDrawPoints _ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, XPoint * points,
+ int npoints, int mode));
+/* 87 */
+EXTERN void XWarpPointer _ANSI_ARGS_((Display* display,
+ Window src_w, Window dest_w, int src_x,
+ int src_y, unsigned int src_width,
+ unsigned int src_height, int dest_x,
+ int dest_y));
+/* 88 */
+EXTERN void XQueryColor _ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * def_in_out));
+/* 89 */
+EXTERN void XQueryColors _ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * defs_in_out,
+ int ncolors));
+/* 90 */
+EXTERN Status XQueryTree _ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, Window** w4,
+ unsigned int* ui));
+#endif /* MAC_OSX_TK */
+
+typedef struct TkIntXlibStubs {
+ int magic;
+ struct TkIntXlibStubHooks *hooks;
+
+#ifdef __WIN32__
+ void (*xSetDashes) _ANSI_ARGS_((Display* display, GC gc, int dash_offset, _Xconst char* dash_list, int n)); /* 0 */
+ XModifierKeymap* (*xGetModifierMapping) _ANSI_ARGS_((Display* d)); /* 1 */
+ XImage * (*xCreateImage) _ANSI_ARGS_((Display* d, Visual* v, unsigned int ui1, int i1, int i2, char* cp, unsigned int ui2, unsigned int ui3, int i3, int i4)); /* 2 */
+ XImage * (*xGetImage) _ANSI_ARGS_((Display* d, Drawable dr, int i1, int i2, unsigned int ui1, unsigned int ui2, unsigned long ul, int i3)); /* 3 */
+ char * (*xGetAtomName) _ANSI_ARGS_((Display* d, Atom a)); /* 4 */
+ char * (*xKeysymToString) _ANSI_ARGS_((KeySym k)); /* 5 */
+ Colormap (*xCreateColormap) _ANSI_ARGS_((Display* d, Window w, Visual* v, int i)); /* 6 */
+ Cursor (*xCreatePixmapCursor) _ANSI_ARGS_((Display* d, Pixmap p1, Pixmap p2, XColor* x1, XColor* x2, unsigned int ui1, unsigned int ui2)); /* 7 */
+ Cursor (*xCreateGlyphCursor) _ANSI_ARGS_((Display* d, Font f1, Font f2, unsigned int ui1, unsigned int ui2, XColor* x1, XColor* x2)); /* 8 */
+ GContext (*xGContextFromGC) _ANSI_ARGS_((GC g)); /* 9 */
+ XHostAddress * (*xListHosts) _ANSI_ARGS_((Display* d, int* i, Bool* b)); /* 10 */
+ KeySym (*xKeycodeToKeysym) _ANSI_ARGS_((Display* d, unsigned int k, int i)); /* 11 */
+ KeySym (*xStringToKeysym) _ANSI_ARGS_((_Xconst char* c)); /* 12 */
+ Window (*xRootWindow) _ANSI_ARGS_((Display* d, int i)); /* 13 */
+ XErrorHandler (*xSetErrorHandler) _ANSI_ARGS_((XErrorHandler x)); /* 14 */
+ Status (*xIconifyWindow) _ANSI_ARGS_((Display* d, Window w, int i)); /* 15 */
+ Status (*xWithdrawWindow) _ANSI_ARGS_((Display* d, Window w, int i)); /* 16 */
+ Status (*xGetWMColormapWindows) _ANSI_ARGS_((Display* d, Window w, Window** wpp, int* ip)); /* 17 */
+ Status (*xAllocColor) _ANSI_ARGS_((Display* d, Colormap c, XColor* xp)); /* 18 */
+ void (*xBell) _ANSI_ARGS_((Display* d, int i)); /* 19 */
+ void (*xChangeProperty) _ANSI_ARGS_((Display* d, Window w, Atom a1, Atom a2, int i1, int i2, _Xconst unsigned char* c, int i3)); /* 20 */
+ void (*xChangeWindowAttributes) _ANSI_ARGS_((Display* d, Window w, unsigned long ul, XSetWindowAttributes* x)); /* 21 */
+ void (*xClearWindow) _ANSI_ARGS_((Display* d, Window w)); /* 22 */
+ void (*xConfigureWindow) _ANSI_ARGS_((Display* d, Window w, unsigned int i, XWindowChanges* x)); /* 23 */
+ void (*xCopyArea) _ANSI_ARGS_((Display* d, Drawable dr1, Drawable dr2, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 24 */
+ void (*xCopyPlane) _ANSI_ARGS_((Display* d, Drawable dr1, Drawable dr2, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4, unsigned long ul)); /* 25 */
+ Pixmap (*xCreateBitmapFromData) _ANSI_ARGS_((Display* display, Drawable d, _Xconst char* data, unsigned int width, unsigned int height)); /* 26 */
+ void (*xDefineCursor) _ANSI_ARGS_((Display* d, Window w, Cursor c)); /* 27 */
+ void (*xDeleteProperty) _ANSI_ARGS_((Display* d, Window w, Atom a)); /* 28 */
+ void (*xDestroyWindow) _ANSI_ARGS_((Display* d, Window w)); /* 29 */
+ void (*xDrawArc) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 30 */
+ void (*xDrawLines) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XPoint* x, int i1, int i2)); /* 31 */
+ void (*xDrawRectangle) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2)); /* 32 */
+ void (*xFillArc) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 33 */
+ void (*xFillPolygon) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XPoint* x, int i1, int i2, int i3)); /* 34 */
+ void (*xFillRectangles) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XRectangle* x, int i)); /* 35 */
+ void (*xForceScreenSaver) _ANSI_ARGS_((Display* d, int i)); /* 36 */
+ void (*xFreeColormap) _ANSI_ARGS_((Display* d, Colormap c)); /* 37 */
+ void (*xFreeColors) _ANSI_ARGS_((Display* d, Colormap c, unsigned long* ulp, int i, unsigned long ul)); /* 38 */
+ void (*xFreeCursor) _ANSI_ARGS_((Display* d, Cursor c)); /* 39 */
+ void (*xFreeModifiermap) _ANSI_ARGS_((XModifierKeymap* x)); /* 40 */
+ Status (*xGetGeometry) _ANSI_ARGS_((Display* d, Drawable dr, Window* w, int* i1, int* i2, unsigned int* ui1, unsigned int* ui2, unsigned int* ui3, unsigned int* ui4)); /* 41 */
+ void (*xGetInputFocus) _ANSI_ARGS_((Display* d, Window* w, int* i)); /* 42 */
+ int (*xGetWindowProperty) _ANSI_ARGS_((Display* d, Window w, Atom a1, long l1, long l2, Bool b, Atom a2, Atom* ap, int* ip, unsigned long* ulp1, unsigned long* ulp2, unsigned char** cpp)); /* 43 */
+ Status (*xGetWindowAttributes) _ANSI_ARGS_((Display* d, Window w, XWindowAttributes* x)); /* 44 */
+ int (*xGrabKeyboard) _ANSI_ARGS_((Display* d, Window w, Bool b, int i1, int i2, Time t)); /* 45 */
+ int (*xGrabPointer) _ANSI_ARGS_((Display* d, Window w1, Bool b, unsigned int ui, int i1, int i2, Window w2, Cursor c, Time t)); /* 46 */
+ KeyCode (*xKeysymToKeycode) _ANSI_ARGS_((Display* d, KeySym k)); /* 47 */
+ Status (*xLookupColor) _ANSI_ARGS_((Display* d, Colormap c1, _Xconst char* c2, XColor* x1, XColor* x2)); /* 48 */
+ void (*xMapWindow) _ANSI_ARGS_((Display* d, Window w)); /* 49 */
+ void (*xMoveResizeWindow) _ANSI_ARGS_((Display* d, Window w, int i1, int i2, unsigned int ui1, unsigned int ui2)); /* 50 */
+ void (*xMoveWindow) _ANSI_ARGS_((Display* d, Window w, int i1, int i2)); /* 51 */
+ void (*xNextEvent) _ANSI_ARGS_((Display* d, XEvent* x)); /* 52 */
+ void (*xPutBackEvent) _ANSI_ARGS_((Display* d, XEvent* x)); /* 53 */
+ void (*xQueryColors) _ANSI_ARGS_((Display* d, Colormap c, XColor* x, int i)); /* 54 */
+ Bool (*xQueryPointer) _ANSI_ARGS_((Display* d, Window w1, Window* w2, Window* w3, int* i1, int* i2, int* i3, int* i4, unsigned int* ui)); /* 55 */
+ Status (*xQueryTree) _ANSI_ARGS_((Display* d, Window w1, Window* w2, Window* w3, Window** w4, unsigned int* ui)); /* 56 */
+ void (*xRaiseWindow) _ANSI_ARGS_((Display* d, Window w)); /* 57 */
+ void (*xRefreshKeyboardMapping) _ANSI_ARGS_((XMappingEvent* x)); /* 58 */
+ void (*xResizeWindow) _ANSI_ARGS_((Display* d, Window w, unsigned int ui1, unsigned int ui2)); /* 59 */
+ void (*xSelectInput) _ANSI_ARGS_((Display* d, Window w, long l)); /* 60 */
+ Status (*xSendEvent) _ANSI_ARGS_((Display* d, Window w, Bool b, long l, XEvent* x)); /* 61 */
+ void (*xSetCommand) _ANSI_ARGS_((Display* d, Window w, CONST char** c, int i)); /* 62 */
+ void (*xSetIconName) _ANSI_ARGS_((Display* d, Window w, _Xconst char* c)); /* 63 */
+ void (*xSetInputFocus) _ANSI_ARGS_((Display* d, Window w, int i, Time t)); /* 64 */
+ void (*xSetSelectionOwner) _ANSI_ARGS_((Display* d, Atom a, Window w, Time t)); /* 65 */
+ void (*xSetWindowBackground) _ANSI_ARGS_((Display* d, Window w, unsigned long ul)); /* 66 */
+ void (*xSetWindowBackgroundPixmap) _ANSI_ARGS_((Display* d, Window w, Pixmap p)); /* 67 */
+ void (*xSetWindowBorder) _ANSI_ARGS_((Display* d, Window w, unsigned long ul)); /* 68 */
+ void (*xSetWindowBorderPixmap) _ANSI_ARGS_((Display* d, Window w, Pixmap p)); /* 69 */
+ void (*xSetWindowBorderWidth) _ANSI_ARGS_((Display* d, Window w, unsigned int ui)); /* 70 */
+ void (*xSetWindowColormap) _ANSI_ARGS_((Display* d, Window w, Colormap c)); /* 71 */
+ Bool (*xTranslateCoordinates) _ANSI_ARGS_((Display* d, Window w1, Window w2, int i1, int i2, int* i3, int* i4, Window* w3)); /* 72 */
+ void (*xUngrabKeyboard) _ANSI_ARGS_((Display* d, Time t)); /* 73 */
+ void (*xUngrabPointer) _ANSI_ARGS_((Display* d, Time t)); /* 74 */
+ void (*xUnmapWindow) _ANSI_ARGS_((Display* d, Window w)); /* 75 */
+ void (*xWindowEvent) _ANSI_ARGS_((Display* d, Window w, long l, XEvent* x)); /* 76 */
+ void (*xDestroyIC) _ANSI_ARGS_((XIC x)); /* 77 */
+ Bool (*xFilterEvent) _ANSI_ARGS_((XEvent* x, Window w)); /* 78 */
+ int (*xmbLookupString) _ANSI_ARGS_((XIC xi, XKeyPressedEvent* xk, char* c, int i, KeySym* k, Status* s)); /* 79 */
+ void (*tkPutImage) _ANSI_ARGS_((unsigned long * colors, int ncolors, Display* display, Drawable d, GC gc, XImage* image, int src_x, int src_y, int dest_x, int dest_y, unsigned int width, unsigned int height)); /* 80 */
+ void *reserved81;
+ Status (*xParseColor) _ANSI_ARGS_((Display * display, Colormap map, _Xconst char* spec, XColor * colorPtr)); /* 82 */
+ GC (*xCreateGC) _ANSI_ARGS_((Display* display, Drawable d, unsigned long valuemask, XGCValues* values)); /* 83 */
+ void (*xFreeGC) _ANSI_ARGS_((Display* display, GC gc)); /* 84 */
+ Atom (*xInternAtom) _ANSI_ARGS_((Display* display, _Xconst char* atom_name, Bool only_if_exists)); /* 85 */
+ void (*xSetBackground) _ANSI_ARGS_((Display* display, GC gc, unsigned long foreground)); /* 86 */
+ void (*xSetForeground) _ANSI_ARGS_((Display* display, GC gc, unsigned long foreground)); /* 87 */
+ void (*xSetClipMask) _ANSI_ARGS_((Display* display, GC gc, Pixmap pixmap)); /* 88 */
+ void (*xSetClipOrigin) _ANSI_ARGS_((Display* display, GC gc, int clip_x_origin, int clip_y_origin)); /* 89 */
+ void (*xSetTSOrigin) _ANSI_ARGS_((Display* display, GC gc, int ts_x_origin, int ts_y_origin)); /* 90 */
+ void (*xChangeGC) _ANSI_ARGS_((Display * d, GC gc, unsigned long mask, XGCValues * values)); /* 91 */
+ void (*xSetFont) _ANSI_ARGS_((Display * display, GC gc, Font font)); /* 92 */
+ void (*xSetArcMode) _ANSI_ARGS_((Display * display, GC gc, int arc_mode)); /* 93 */
+ void (*xSetStipple) _ANSI_ARGS_((Display * display, GC gc, Pixmap stipple)); /* 94 */
+ void (*xSetFillRule) _ANSI_ARGS_((Display * display, GC gc, int fill_rule)); /* 95 */
+ void (*xSetFillStyle) _ANSI_ARGS_((Display * display, GC gc, int fill_style)); /* 96 */
+ void (*xSetFunction) _ANSI_ARGS_((Display * display, GC gc, int function)); /* 97 */
+ void (*xSetLineAttributes) _ANSI_ARGS_((Display * display, GC gc, unsigned int line_width, int line_style, int cap_style, int join_style)); /* 98 */
+ int (*_XInitImageFuncPtrs) _ANSI_ARGS_((XImage * image)); /* 99 */
+ XIC (*xCreateIC) _ANSI_ARGS_((void)); /* 100 */
+ XVisualInfo * (*xGetVisualInfo) _ANSI_ARGS_((Display* display, long vinfo_mask, XVisualInfo* vinfo_template, int* nitems_return)); /* 101 */
+ void (*xSetWMClientMachine) _ANSI_ARGS_((Display* display, Window w, XTextProperty* text_prop)); /* 102 */
+ Status (*xStringListToTextProperty) _ANSI_ARGS_((char** list, int count, XTextProperty* text_prop_return)); /* 103 */
+ void (*xDrawLine) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int x1, int y1, int x2, int y2)); /* 104 */
+ void (*xWarpPointer) _ANSI_ARGS_((Display* d, Window s, Window dw, int sx, int sy, unsigned int sw, unsigned int sh, int dx, int dy)); /* 105 */
+ void (*xFillRectangle) _ANSI_ARGS_((Display* display, Drawable d, GC gc, int x, int y, unsigned int width, unsigned int height)); /* 106 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*xSetDashes) _ANSI_ARGS_((Display* display, GC gc, int dash_offset, _Xconst char* dash_list, int n)); /* 0 */
+ XModifierKeymap* (*xGetModifierMapping) _ANSI_ARGS_((Display* d)); /* 1 */
+ XImage * (*xCreateImage) _ANSI_ARGS_((Display* d, Visual* v, unsigned int ui1, int i1, int i2, char* cp, unsigned int ui2, unsigned int ui3, int i3, int i4)); /* 2 */
+ XImage * (*xGetImage) _ANSI_ARGS_((Display* d, Drawable dr, int i1, int i2, unsigned int ui1, unsigned int ui2, unsigned long ul, int i3)); /* 3 */
+ char * (*xGetAtomName) _ANSI_ARGS_((Display* d, Atom a)); /* 4 */
+ char * (*xKeysymToString) _ANSI_ARGS_((KeySym k)); /* 5 */
+ Colormap (*xCreateColormap) _ANSI_ARGS_((Display* d, Window w, Visual* v, int i)); /* 6 */
+ GContext (*xGContextFromGC) _ANSI_ARGS_((GC g)); /* 7 */
+ KeySym (*xKeycodeToKeysym) _ANSI_ARGS_((Display* d, KeyCode k, int i)); /* 8 */
+ KeySym (*xStringToKeysym) _ANSI_ARGS_((_Xconst char* c)); /* 9 */
+ Window (*xRootWindow) _ANSI_ARGS_((Display* d, int i)); /* 10 */
+ XErrorHandler (*xSetErrorHandler) _ANSI_ARGS_((XErrorHandler x)); /* 11 */
+ Status (*xAllocColor) _ANSI_ARGS_((Display* d, Colormap c, XColor* xp)); /* 12 */
+ void (*xBell) _ANSI_ARGS_((Display* d, int i)); /* 13 */
+ void (*xChangeProperty) _ANSI_ARGS_((Display* d, Window w, Atom a1, Atom a2, int i1, int i2, _Xconst unsigned char* c, int i3)); /* 14 */
+ void (*xChangeWindowAttributes) _ANSI_ARGS_((Display* d, Window w, unsigned long ul, XSetWindowAttributes* x)); /* 15 */
+ void (*xConfigureWindow) _ANSI_ARGS_((Display* d, Window w, unsigned int i, XWindowChanges* x)); /* 16 */
+ void (*xCopyArea) _ANSI_ARGS_((Display* d, Drawable dr1, Drawable dr2, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 17 */
+ void (*xCopyPlane) _ANSI_ARGS_((Display* d, Drawable dr1, Drawable dr2, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4, unsigned long ul)); /* 18 */
+ Pixmap (*xCreateBitmapFromData) _ANSI_ARGS_((Display* display, Drawable d, _Xconst char* data, unsigned int width, unsigned int height)); /* 19 */
+ void (*xDefineCursor) _ANSI_ARGS_((Display* d, Window w, Cursor c)); /* 20 */
+ void (*xDestroyWindow) _ANSI_ARGS_((Display* d, Window w)); /* 21 */
+ void (*xDrawArc) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 22 */
+ void (*xDrawLines) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XPoint* x, int i1, int i2)); /* 23 */
+ void (*xDrawRectangle) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2)); /* 24 */
+ void (*xFillArc) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 25 */
+ void (*xFillPolygon) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XPoint* x, int i1, int i2, int i3)); /* 26 */
+ void (*xFillRectangles) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XRectangle* x, int i)); /* 27 */
+ void (*xFreeColormap) _ANSI_ARGS_((Display* d, Colormap c)); /* 28 */
+ void (*xFreeColors) _ANSI_ARGS_((Display* d, Colormap c, unsigned long* ulp, int i, unsigned long ul)); /* 29 */
+ void (*xFreeModifiermap) _ANSI_ARGS_((XModifierKeymap* x)); /* 30 */
+ Status (*xGetGeometry) _ANSI_ARGS_((Display* d, Drawable dr, Window* w, int* i1, int* i2, unsigned int* ui1, unsigned int* ui2, unsigned int* ui3, unsigned int* ui4)); /* 31 */
+ int (*xGetWindowProperty) _ANSI_ARGS_((Display* d, Window w, Atom a1, long l1, long l2, Bool b, Atom a2, Atom* ap, int* ip, unsigned long* ulp1, unsigned long* ulp2, unsigned char** cpp)); /* 32 */
+ int (*xGrabKeyboard) _ANSI_ARGS_((Display* d, Window w, Bool b, int i1, int i2, Time t)); /* 33 */
+ int (*xGrabPointer) _ANSI_ARGS_((Display* d, Window w1, Bool b, unsigned int ui, int i1, int i2, Window w2, Cursor c, Time t)); /* 34 */
+ KeyCode (*xKeysymToKeycode) _ANSI_ARGS_((Display* d, KeySym k)); /* 35 */
+ void (*xMapWindow) _ANSI_ARGS_((Display* d, Window w)); /* 36 */
+ void (*xMoveResizeWindow) _ANSI_ARGS_((Display* d, Window w, int i1, int i2, unsigned int ui1, unsigned int ui2)); /* 37 */
+ void (*xMoveWindow) _ANSI_ARGS_((Display* d, Window w, int i1, int i2)); /* 38 */
+ Bool (*xQueryPointer) _ANSI_ARGS_((Display* d, Window w1, Window* w2, Window* w3, int* i1, int* i2, int* i3, int* i4, unsigned int* ui)); /* 39 */
+ void (*xRaiseWindow) _ANSI_ARGS_((Display* d, Window w)); /* 40 */
+ void (*xRefreshKeyboardMapping) _ANSI_ARGS_((XMappingEvent* x)); /* 41 */
+ void (*xResizeWindow) _ANSI_ARGS_((Display* d, Window w, unsigned int ui1, unsigned int ui2)); /* 42 */
+ void (*xSelectInput) _ANSI_ARGS_((Display* d, Window w, long l)); /* 43 */
+ Status (*xSendEvent) _ANSI_ARGS_((Display* d, Window w, Bool b, long l, XEvent* x)); /* 44 */
+ void (*xSetIconName) _ANSI_ARGS_((Display* d, Window w, _Xconst char* c)); /* 45 */
+ void (*xSetInputFocus) _ANSI_ARGS_((Display* d, Window w, int i, Time t)); /* 46 */
+ void (*xSetSelectionOwner) _ANSI_ARGS_((Display* d, Atom a, Window w, Time t)); /* 47 */
+ void (*xSetWindowBackground) _ANSI_ARGS_((Display* d, Window w, unsigned long ul)); /* 48 */
+ void (*xSetWindowBackgroundPixmap) _ANSI_ARGS_((Display* d, Window w, Pixmap p)); /* 49 */
+ void (*xSetWindowBorder) _ANSI_ARGS_((Display* d, Window w, unsigned long ul)); /* 50 */
+ void (*xSetWindowBorderPixmap) _ANSI_ARGS_((Display* d, Window w, Pixmap p)); /* 51 */
+ void (*xSetWindowBorderWidth) _ANSI_ARGS_((Display* d, Window w, unsigned int ui)); /* 52 */
+ void (*xSetWindowColormap) _ANSI_ARGS_((Display* d, Window w, Colormap c)); /* 53 */
+ void (*xUngrabKeyboard) _ANSI_ARGS_((Display* d, Time t)); /* 54 */
+ void (*xUngrabPointer) _ANSI_ARGS_((Display* d, Time t)); /* 55 */
+ void (*xUnmapWindow) _ANSI_ARGS_((Display* d, Window w)); /* 56 */
+ void (*tkPutImage) _ANSI_ARGS_((unsigned long * colors, int ncolors, Display* display, Drawable d, GC gc, XImage* image, int src_x, int src_y, int dest_x, int dest_y, unsigned int width, unsigned int height)); /* 57 */
+ Status (*xParseColor) _ANSI_ARGS_((Display * display, Colormap map, _Xconst char* spec, XColor * colorPtr)); /* 58 */
+ GC (*xCreateGC) _ANSI_ARGS_((Display* display, Drawable d, unsigned long valuemask, XGCValues* values)); /* 59 */
+ void (*xFreeGC) _ANSI_ARGS_((Display* display, GC gc)); /* 60 */
+ Atom (*xInternAtom) _ANSI_ARGS_((Display* display, _Xconst char* atom_name, Bool only_if_exists)); /* 61 */
+ void (*xSetBackground) _ANSI_ARGS_((Display* display, GC gc, unsigned long foreground)); /* 62 */
+ void (*xSetForeground) _ANSI_ARGS_((Display* display, GC gc, unsigned long foreground)); /* 63 */
+ void (*xSetClipMask) _ANSI_ARGS_((Display* display, GC gc, Pixmap pixmap)); /* 64 */
+ void (*xSetClipOrigin) _ANSI_ARGS_((Display* display, GC gc, int clip_x_origin, int clip_y_origin)); /* 65 */
+ void (*xSetTSOrigin) _ANSI_ARGS_((Display* display, GC gc, int ts_x_origin, int ts_y_origin)); /* 66 */
+ void (*xChangeGC) _ANSI_ARGS_((Display * d, GC gc, unsigned long mask, XGCValues * values)); /* 67 */
+ void (*xSetFont) _ANSI_ARGS_((Display * display, GC gc, Font font)); /* 68 */
+ void (*xSetArcMode) _ANSI_ARGS_((Display * display, GC gc, int arc_mode)); /* 69 */
+ void (*xSetStipple) _ANSI_ARGS_((Display * display, GC gc, Pixmap stipple)); /* 70 */
+ void (*xSetFillRule) _ANSI_ARGS_((Display * display, GC gc, int fill_rule)); /* 71 */
+ void (*xSetFillStyle) _ANSI_ARGS_((Display * display, GC gc, int fill_style)); /* 72 */
+ void (*xSetFunction) _ANSI_ARGS_((Display * display, GC gc, int function)); /* 73 */
+ void (*xSetLineAttributes) _ANSI_ARGS_((Display * display, GC gc, unsigned int line_width, int line_style, int cap_style, int join_style)); /* 74 */
+ int (*_XInitImageFuncPtrs) _ANSI_ARGS_((XImage * image)); /* 75 */
+ XIC (*xCreateIC) _ANSI_ARGS_((void)); /* 76 */
+ XVisualInfo * (*xGetVisualInfo) _ANSI_ARGS_((Display* display, long vinfo_mask, XVisualInfo* vinfo_template, int* nitems_return)); /* 77 */
+ void (*xSetWMClientMachine) _ANSI_ARGS_((Display* display, Window w, XTextProperty* text_prop)); /* 78 */
+ Status (*xStringListToTextProperty) _ANSI_ARGS_((char** list, int count, XTextProperty* text_prop_return)); /* 79 */
+ void (*xDrawSegments) _ANSI_ARGS_((Display * display, Drawable d, GC gc, XSegment * segments, int nsegments)); /* 80 */
+ void (*xForceScreenSaver) _ANSI_ARGS_((Display* display, int mode)); /* 81 */
+ void (*xDrawLine) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int x1, int y1, int x2, int y2)); /* 82 */
+ void (*xFillRectangle) _ANSI_ARGS_((Display* display, Drawable d, GC gc, int x, int y, unsigned int width, unsigned int height)); /* 83 */
+ void (*xClearWindow) _ANSI_ARGS_((Display* d, Window w)); /* 84 */
+ void (*xDrawPoint) _ANSI_ARGS_((Display* display, Drawable d, GC gc, int x, int y)); /* 85 */
+ void (*xDrawPoints) _ANSI_ARGS_((Display* display, Drawable d, GC gc, XPoint * points, int npoints, int mode)); /* 86 */
+ void (*xWarpPointer) _ANSI_ARGS_((Display* display, Window src_w, Window dest_w, int src_x, int src_y, unsigned int src_width, unsigned int src_height, int dest_x, int dest_y)); /* 87 */
+ void (*xQueryColor) _ANSI_ARGS_((Display * display, Colormap colormap, XColor * def_in_out)); /* 88 */
+ void (*xQueryColors) _ANSI_ARGS_((Display * display, Colormap colormap, XColor * defs_in_out, int ncolors)); /* 89 */
+ Status (*xQueryTree) _ANSI_ARGS_((Display* d, Window w1, Window* w2, Window* w3, Window** w4, unsigned int* ui)); /* 90 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*xSetDashes) _ANSI_ARGS_((Display* display, GC gc, int dash_offset, _Xconst char* dash_list, int n)); /* 0 */
+ XModifierKeymap* (*xGetModifierMapping) _ANSI_ARGS_((Display* d)); /* 1 */
+ XImage * (*xCreateImage) _ANSI_ARGS_((Display* d, Visual* v, unsigned int ui1, int i1, int i2, char* cp, unsigned int ui2, unsigned int ui3, int i3, int i4)); /* 2 */
+ XImage * (*xGetImage) _ANSI_ARGS_((Display* d, Drawable dr, int i1, int i2, unsigned int ui1, unsigned int ui2, unsigned long ul, int i3)); /* 3 */
+ char * (*xGetAtomName) _ANSI_ARGS_((Display* d, Atom a)); /* 4 */
+ char * (*xKeysymToString) _ANSI_ARGS_((KeySym k)); /* 5 */
+ Colormap (*xCreateColormap) _ANSI_ARGS_((Display* d, Window w, Visual* v, int i)); /* 6 */
+ GContext (*xGContextFromGC) _ANSI_ARGS_((GC g)); /* 7 */
+ KeySym (*xKeycodeToKeysym) _ANSI_ARGS_((Display* d, KeyCode k, int i)); /* 8 */
+ KeySym (*xStringToKeysym) _ANSI_ARGS_((_Xconst char* c)); /* 9 */
+ Window (*xRootWindow) _ANSI_ARGS_((Display* d, int i)); /* 10 */
+ XErrorHandler (*xSetErrorHandler) _ANSI_ARGS_((XErrorHandler x)); /* 11 */
+ Status (*xAllocColor) _ANSI_ARGS_((Display* d, Colormap c, XColor* xp)); /* 12 */
+ void (*xBell) _ANSI_ARGS_((Display* d, int i)); /* 13 */
+ void (*xChangeProperty) _ANSI_ARGS_((Display* d, Window w, Atom a1, Atom a2, int i1, int i2, _Xconst unsigned char* c, int i3)); /* 14 */
+ void (*xChangeWindowAttributes) _ANSI_ARGS_((Display* d, Window w, unsigned long ul, XSetWindowAttributes* x)); /* 15 */
+ void (*xConfigureWindow) _ANSI_ARGS_((Display* d, Window w, unsigned int i, XWindowChanges* x)); /* 16 */
+ void (*xCopyArea) _ANSI_ARGS_((Display* d, Drawable dr1, Drawable dr2, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 17 */
+ void (*xCopyPlane) _ANSI_ARGS_((Display* d, Drawable dr1, Drawable dr2, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4, unsigned long ul)); /* 18 */
+ Pixmap (*xCreateBitmapFromData) _ANSI_ARGS_((Display* display, Drawable d, _Xconst char* data, unsigned int width, unsigned int height)); /* 19 */
+ void (*xDefineCursor) _ANSI_ARGS_((Display* d, Window w, Cursor c)); /* 20 */
+ void (*xDestroyWindow) _ANSI_ARGS_((Display* d, Window w)); /* 21 */
+ void (*xDrawArc) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 22 */
+ void (*xDrawLines) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XPoint* x, int i1, int i2)); /* 23 */
+ void (*xDrawRectangle) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2)); /* 24 */
+ void (*xFillArc) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int i1, int i2, unsigned int ui1, unsigned int ui2, int i3, int i4)); /* 25 */
+ void (*xFillPolygon) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XPoint* x, int i1, int i2, int i3)); /* 26 */
+ void (*xFillRectangles) _ANSI_ARGS_((Display* d, Drawable dr, GC g, XRectangle* x, int i)); /* 27 */
+ void (*xFreeColormap) _ANSI_ARGS_((Display* d, Colormap c)); /* 28 */
+ void (*xFreeColors) _ANSI_ARGS_((Display* d, Colormap c, unsigned long* ulp, int i, unsigned long ul)); /* 29 */
+ void (*xFreeModifiermap) _ANSI_ARGS_((XModifierKeymap* x)); /* 30 */
+ Status (*xGetGeometry) _ANSI_ARGS_((Display* d, Drawable dr, Window* w, int* i1, int* i2, unsigned int* ui1, unsigned int* ui2, unsigned int* ui3, unsigned int* ui4)); /* 31 */
+ int (*xGetWindowProperty) _ANSI_ARGS_((Display* d, Window w, Atom a1, long l1, long l2, Bool b, Atom a2, Atom* ap, int* ip, unsigned long* ulp1, unsigned long* ulp2, unsigned char** cpp)); /* 32 */
+ int (*xGrabKeyboard) _ANSI_ARGS_((Display* d, Window w, Bool b, int i1, int i2, Time t)); /* 33 */
+ int (*xGrabPointer) _ANSI_ARGS_((Display* d, Window w1, Bool b, unsigned int ui, int i1, int i2, Window w2, Cursor c, Time t)); /* 34 */
+ KeyCode (*xKeysymToKeycode) _ANSI_ARGS_((Display* d, KeySym k)); /* 35 */
+ void (*xMapWindow) _ANSI_ARGS_((Display* d, Window w)); /* 36 */
+ void (*xMoveResizeWindow) _ANSI_ARGS_((Display* d, Window w, int i1, int i2, unsigned int ui1, unsigned int ui2)); /* 37 */
+ void (*xMoveWindow) _ANSI_ARGS_((Display* d, Window w, int i1, int i2)); /* 38 */
+ Bool (*xQueryPointer) _ANSI_ARGS_((Display* d, Window w1, Window* w2, Window* w3, int* i1, int* i2, int* i3, int* i4, unsigned int* ui)); /* 39 */
+ void (*xRaiseWindow) _ANSI_ARGS_((Display* d, Window w)); /* 40 */
+ void (*xRefreshKeyboardMapping) _ANSI_ARGS_((XMappingEvent* x)); /* 41 */
+ void (*xResizeWindow) _ANSI_ARGS_((Display* d, Window w, unsigned int ui1, unsigned int ui2)); /* 42 */
+ void (*xSelectInput) _ANSI_ARGS_((Display* d, Window w, long l)); /* 43 */
+ Status (*xSendEvent) _ANSI_ARGS_((Display* d, Window w, Bool b, long l, XEvent* x)); /* 44 */
+ void (*xSetIconName) _ANSI_ARGS_((Display* d, Window w, _Xconst char* c)); /* 45 */
+ void (*xSetInputFocus) _ANSI_ARGS_((Display* d, Window w, int i, Time t)); /* 46 */
+ void (*xSetSelectionOwner) _ANSI_ARGS_((Display* d, Atom a, Window w, Time t)); /* 47 */
+ void (*xSetWindowBackground) _ANSI_ARGS_((Display* d, Window w, unsigned long ul)); /* 48 */
+ void (*xSetWindowBackgroundPixmap) _ANSI_ARGS_((Display* d, Window w, Pixmap p)); /* 49 */
+ void (*xSetWindowBorder) _ANSI_ARGS_((Display* d, Window w, unsigned long ul)); /* 50 */
+ void (*xSetWindowBorderPixmap) _ANSI_ARGS_((Display* d, Window w, Pixmap p)); /* 51 */
+ void (*xSetWindowBorderWidth) _ANSI_ARGS_((Display* d, Window w, unsigned int ui)); /* 52 */
+ void (*xSetWindowColormap) _ANSI_ARGS_((Display* d, Window w, Colormap c)); /* 53 */
+ void (*xUngrabKeyboard) _ANSI_ARGS_((Display* d, Time t)); /* 54 */
+ void (*xUngrabPointer) _ANSI_ARGS_((Display* d, Time t)); /* 55 */
+ void (*xUnmapWindow) _ANSI_ARGS_((Display* d, Window w)); /* 56 */
+ void (*tkPutImage) _ANSI_ARGS_((unsigned long * colors, int ncolors, Display* display, Drawable d, GC gc, XImage* image, int src_x, int src_y, int dest_x, int dest_y, unsigned int width, unsigned int height)); /* 57 */
+ Status (*xParseColor) _ANSI_ARGS_((Display * display, Colormap map, _Xconst char* spec, XColor * colorPtr)); /* 58 */
+ GC (*xCreateGC) _ANSI_ARGS_((Display* display, Drawable d, unsigned long valuemask, XGCValues* values)); /* 59 */
+ void (*xFreeGC) _ANSI_ARGS_((Display* display, GC gc)); /* 60 */
+ Atom (*xInternAtom) _ANSI_ARGS_((Display* display, _Xconst char* atom_name, Bool only_if_exists)); /* 61 */
+ void (*xSetBackground) _ANSI_ARGS_((Display* display, GC gc, unsigned long foreground)); /* 62 */
+ void (*xSetForeground) _ANSI_ARGS_((Display* display, GC gc, unsigned long foreground)); /* 63 */
+ void (*xSetClipMask) _ANSI_ARGS_((Display* display, GC gc, Pixmap pixmap)); /* 64 */
+ void (*xSetClipOrigin) _ANSI_ARGS_((Display* display, GC gc, int clip_x_origin, int clip_y_origin)); /* 65 */
+ void (*xSetTSOrigin) _ANSI_ARGS_((Display* display, GC gc, int ts_x_origin, int ts_y_origin)); /* 66 */
+ void (*xChangeGC) _ANSI_ARGS_((Display * d, GC gc, unsigned long mask, XGCValues * values)); /* 67 */
+ void (*xSetFont) _ANSI_ARGS_((Display * display, GC gc, Font font)); /* 68 */
+ void (*xSetArcMode) _ANSI_ARGS_((Display * display, GC gc, int arc_mode)); /* 69 */
+ void (*xSetStipple) _ANSI_ARGS_((Display * display, GC gc, Pixmap stipple)); /* 70 */
+ void (*xSetFillRule) _ANSI_ARGS_((Display * display, GC gc, int fill_rule)); /* 71 */
+ void (*xSetFillStyle) _ANSI_ARGS_((Display * display, GC gc, int fill_style)); /* 72 */
+ void (*xSetFunction) _ANSI_ARGS_((Display * display, GC gc, int function)); /* 73 */
+ void (*xSetLineAttributes) _ANSI_ARGS_((Display * display, GC gc, unsigned int line_width, int line_style, int cap_style, int join_style)); /* 74 */
+ int (*_XInitImageFuncPtrs) _ANSI_ARGS_((XImage * image)); /* 75 */
+ XIC (*xCreateIC) _ANSI_ARGS_((void)); /* 76 */
+ XVisualInfo * (*xGetVisualInfo) _ANSI_ARGS_((Display* display, long vinfo_mask, XVisualInfo* vinfo_template, int* nitems_return)); /* 77 */
+ void (*xSetWMClientMachine) _ANSI_ARGS_((Display* display, Window w, XTextProperty* text_prop)); /* 78 */
+ Status (*xStringListToTextProperty) _ANSI_ARGS_((char** list, int count, XTextProperty* text_prop_return)); /* 79 */
+ void (*xDrawSegments) _ANSI_ARGS_((Display * display, Drawable d, GC gc, XSegment * segments, int nsegments)); /* 80 */
+ void (*xForceScreenSaver) _ANSI_ARGS_((Display* display, int mode)); /* 81 */
+ void (*xDrawLine) _ANSI_ARGS_((Display* d, Drawable dr, GC g, int x1, int y1, int x2, int y2)); /* 82 */
+ void (*xFillRectangle) _ANSI_ARGS_((Display* display, Drawable d, GC gc, int x, int y, unsigned int width, unsigned int height)); /* 83 */
+ void (*xClearWindow) _ANSI_ARGS_((Display* d, Window w)); /* 84 */
+ void (*xDrawPoint) _ANSI_ARGS_((Display* display, Drawable d, GC gc, int x, int y)); /* 85 */
+ void (*xDrawPoints) _ANSI_ARGS_((Display* display, Drawable d, GC gc, XPoint * points, int npoints, int mode)); /* 86 */
+ void (*xWarpPointer) _ANSI_ARGS_((Display* display, Window src_w, Window dest_w, int src_x, int src_y, unsigned int src_width, unsigned int src_height, int dest_x, int dest_y)); /* 87 */
+ void (*xQueryColor) _ANSI_ARGS_((Display * display, Colormap colormap, XColor * def_in_out)); /* 88 */
+ void (*xQueryColors) _ANSI_ARGS_((Display * display, Colormap colormap, XColor * defs_in_out, int ncolors)); /* 89 */
+ Status (*xQueryTree) _ANSI_ARGS_((Display* d, Window w1, Window* w2, Window* w3, Window** w4, unsigned int* ui)); /* 90 */
+#endif /* MAC_OSX_TK */
+} TkIntXlibStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TkIntXlibStubs *tkIntXlibStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifdef __WIN32__
+#ifndef XSetDashes
+#define XSetDashes \
+ (tkIntXlibStubsPtr->xSetDashes) /* 0 */
+#endif
+#ifndef XGetModifierMapping
+#define XGetModifierMapping \
+ (tkIntXlibStubsPtr->xGetModifierMapping) /* 1 */
+#endif
+#ifndef XCreateImage
+#define XCreateImage \
+ (tkIntXlibStubsPtr->xCreateImage) /* 2 */
+#endif
+#ifndef XGetImage
+#define XGetImage \
+ (tkIntXlibStubsPtr->xGetImage) /* 3 */
+#endif
+#ifndef XGetAtomName
+#define XGetAtomName \
+ (tkIntXlibStubsPtr->xGetAtomName) /* 4 */
+#endif
+#ifndef XKeysymToString
+#define XKeysymToString \
+ (tkIntXlibStubsPtr->xKeysymToString) /* 5 */
+#endif
+#ifndef XCreateColormap
+#define XCreateColormap \
+ (tkIntXlibStubsPtr->xCreateColormap) /* 6 */
+#endif
+#ifndef XCreatePixmapCursor
+#define XCreatePixmapCursor \
+ (tkIntXlibStubsPtr->xCreatePixmapCursor) /* 7 */
+#endif
+#ifndef XCreateGlyphCursor
+#define XCreateGlyphCursor \
+ (tkIntXlibStubsPtr->xCreateGlyphCursor) /* 8 */
+#endif
+#ifndef XGContextFromGC
+#define XGContextFromGC \
+ (tkIntXlibStubsPtr->xGContextFromGC) /* 9 */
+#endif
+#ifndef XListHosts
+#define XListHosts \
+ (tkIntXlibStubsPtr->xListHosts) /* 10 */
+#endif
+#ifndef XKeycodeToKeysym
+#define XKeycodeToKeysym \
+ (tkIntXlibStubsPtr->xKeycodeToKeysym) /* 11 */
+#endif
+#ifndef XStringToKeysym
+#define XStringToKeysym \
+ (tkIntXlibStubsPtr->xStringToKeysym) /* 12 */
+#endif
+#ifndef XRootWindow
+#define XRootWindow \
+ (tkIntXlibStubsPtr->xRootWindow) /* 13 */
+#endif
+#ifndef XSetErrorHandler
+#define XSetErrorHandler \
+ (tkIntXlibStubsPtr->xSetErrorHandler) /* 14 */
+#endif
+#ifndef XIconifyWindow
+#define XIconifyWindow \
+ (tkIntXlibStubsPtr->xIconifyWindow) /* 15 */
+#endif
+#ifndef XWithdrawWindow
+#define XWithdrawWindow \
+ (tkIntXlibStubsPtr->xWithdrawWindow) /* 16 */
+#endif
+#ifndef XGetWMColormapWindows
+#define XGetWMColormapWindows \
+ (tkIntXlibStubsPtr->xGetWMColormapWindows) /* 17 */
+#endif
+#ifndef XAllocColor
+#define XAllocColor \
+ (tkIntXlibStubsPtr->xAllocColor) /* 18 */
+#endif
+#ifndef XBell
+#define XBell \
+ (tkIntXlibStubsPtr->xBell) /* 19 */
+#endif
+#ifndef XChangeProperty
+#define XChangeProperty \
+ (tkIntXlibStubsPtr->xChangeProperty) /* 20 */
+#endif
+#ifndef XChangeWindowAttributes
+#define XChangeWindowAttributes \
+ (tkIntXlibStubsPtr->xChangeWindowAttributes) /* 21 */
+#endif
+#ifndef XClearWindow
+#define XClearWindow \
+ (tkIntXlibStubsPtr->xClearWindow) /* 22 */
+#endif
+#ifndef XConfigureWindow
+#define XConfigureWindow \
+ (tkIntXlibStubsPtr->xConfigureWindow) /* 23 */
+#endif
+#ifndef XCopyArea
+#define XCopyArea \
+ (tkIntXlibStubsPtr->xCopyArea) /* 24 */
+#endif
+#ifndef XCopyPlane
+#define XCopyPlane \
+ (tkIntXlibStubsPtr->xCopyPlane) /* 25 */
+#endif
+#ifndef XCreateBitmapFromData
+#define XCreateBitmapFromData \
+ (tkIntXlibStubsPtr->xCreateBitmapFromData) /* 26 */
+#endif
+#ifndef XDefineCursor
+#define XDefineCursor \
+ (tkIntXlibStubsPtr->xDefineCursor) /* 27 */
+#endif
+#ifndef XDeleteProperty
+#define XDeleteProperty \
+ (tkIntXlibStubsPtr->xDeleteProperty) /* 28 */
+#endif
+#ifndef XDestroyWindow
+#define XDestroyWindow \
+ (tkIntXlibStubsPtr->xDestroyWindow) /* 29 */
+#endif
+#ifndef XDrawArc
+#define XDrawArc \
+ (tkIntXlibStubsPtr->xDrawArc) /* 30 */
+#endif
+#ifndef XDrawLines
+#define XDrawLines \
+ (tkIntXlibStubsPtr->xDrawLines) /* 31 */
+#endif
+#ifndef XDrawRectangle
+#define XDrawRectangle \
+ (tkIntXlibStubsPtr->xDrawRectangle) /* 32 */
+#endif
+#ifndef XFillArc
+#define XFillArc \
+ (tkIntXlibStubsPtr->xFillArc) /* 33 */
+#endif
+#ifndef XFillPolygon
+#define XFillPolygon \
+ (tkIntXlibStubsPtr->xFillPolygon) /* 34 */
+#endif
+#ifndef XFillRectangles
+#define XFillRectangles \
+ (tkIntXlibStubsPtr->xFillRectangles) /* 35 */
+#endif
+#ifndef XForceScreenSaver
+#define XForceScreenSaver \
+ (tkIntXlibStubsPtr->xForceScreenSaver) /* 36 */
+#endif
+#ifndef XFreeColormap
+#define XFreeColormap \
+ (tkIntXlibStubsPtr->xFreeColormap) /* 37 */
+#endif
+#ifndef XFreeColors
+#define XFreeColors \
+ (tkIntXlibStubsPtr->xFreeColors) /* 38 */
+#endif
+#ifndef XFreeCursor
+#define XFreeCursor \
+ (tkIntXlibStubsPtr->xFreeCursor) /* 39 */
+#endif
+#ifndef XFreeModifiermap
+#define XFreeModifiermap \
+ (tkIntXlibStubsPtr->xFreeModifiermap) /* 40 */
+#endif
+#ifndef XGetGeometry
+#define XGetGeometry \
+ (tkIntXlibStubsPtr->xGetGeometry) /* 41 */
+#endif
+#ifndef XGetInputFocus
+#define XGetInputFocus \
+ (tkIntXlibStubsPtr->xGetInputFocus) /* 42 */
+#endif
+#ifndef XGetWindowProperty
+#define XGetWindowProperty \
+ (tkIntXlibStubsPtr->xGetWindowProperty) /* 43 */
+#endif
+#ifndef XGetWindowAttributes
+#define XGetWindowAttributes \
+ (tkIntXlibStubsPtr->xGetWindowAttributes) /* 44 */
+#endif
+#ifndef XGrabKeyboard
+#define XGrabKeyboard \
+ (tkIntXlibStubsPtr->xGrabKeyboard) /* 45 */
+#endif
+#ifndef XGrabPointer
+#define XGrabPointer \
+ (tkIntXlibStubsPtr->xGrabPointer) /* 46 */
+#endif
+#ifndef XKeysymToKeycode
+#define XKeysymToKeycode \
+ (tkIntXlibStubsPtr->xKeysymToKeycode) /* 47 */
+#endif
+#ifndef XLookupColor
+#define XLookupColor \
+ (tkIntXlibStubsPtr->xLookupColor) /* 48 */
+#endif
+#ifndef XMapWindow
+#define XMapWindow \
+ (tkIntXlibStubsPtr->xMapWindow) /* 49 */
+#endif
+#ifndef XMoveResizeWindow
+#define XMoveResizeWindow \
+ (tkIntXlibStubsPtr->xMoveResizeWindow) /* 50 */
+#endif
+#ifndef XMoveWindow
+#define XMoveWindow \
+ (tkIntXlibStubsPtr->xMoveWindow) /* 51 */
+#endif
+#ifndef XNextEvent
+#define XNextEvent \
+ (tkIntXlibStubsPtr->xNextEvent) /* 52 */
+#endif
+#ifndef XPutBackEvent
+#define XPutBackEvent \
+ (tkIntXlibStubsPtr->xPutBackEvent) /* 53 */
+#endif
+#ifndef XQueryColors
+#define XQueryColors \
+ (tkIntXlibStubsPtr->xQueryColors) /* 54 */
+#endif
+#ifndef XQueryPointer
+#define XQueryPointer \
+ (tkIntXlibStubsPtr->xQueryPointer) /* 55 */
+#endif
+#ifndef XQueryTree
+#define XQueryTree \
+ (tkIntXlibStubsPtr->xQueryTree) /* 56 */
+#endif
+#ifndef XRaiseWindow
+#define XRaiseWindow \
+ (tkIntXlibStubsPtr->xRaiseWindow) /* 57 */
+#endif
+#ifndef XRefreshKeyboardMapping
+#define XRefreshKeyboardMapping \
+ (tkIntXlibStubsPtr->xRefreshKeyboardMapping) /* 58 */
+#endif
+#ifndef XResizeWindow
+#define XResizeWindow \
+ (tkIntXlibStubsPtr->xResizeWindow) /* 59 */
+#endif
+#ifndef XSelectInput
+#define XSelectInput \
+ (tkIntXlibStubsPtr->xSelectInput) /* 60 */
+#endif
+#ifndef XSendEvent
+#define XSendEvent \
+ (tkIntXlibStubsPtr->xSendEvent) /* 61 */
+#endif
+#ifndef XSetCommand
+#define XSetCommand \
+ (tkIntXlibStubsPtr->xSetCommand) /* 62 */
+#endif
+#ifndef XSetIconName
+#define XSetIconName \
+ (tkIntXlibStubsPtr->xSetIconName) /* 63 */
+#endif
+#ifndef XSetInputFocus
+#define XSetInputFocus \
+ (tkIntXlibStubsPtr->xSetInputFocus) /* 64 */
+#endif
+#ifndef XSetSelectionOwner
+#define XSetSelectionOwner \
+ (tkIntXlibStubsPtr->xSetSelectionOwner) /* 65 */
+#endif
+#ifndef XSetWindowBackground
+#define XSetWindowBackground \
+ (tkIntXlibStubsPtr->xSetWindowBackground) /* 66 */
+#endif
+#ifndef XSetWindowBackgroundPixmap
+#define XSetWindowBackgroundPixmap \
+ (tkIntXlibStubsPtr->xSetWindowBackgroundPixmap) /* 67 */
+#endif
+#ifndef XSetWindowBorder
+#define XSetWindowBorder \
+ (tkIntXlibStubsPtr->xSetWindowBorder) /* 68 */
+#endif
+#ifndef XSetWindowBorderPixmap
+#define XSetWindowBorderPixmap \
+ (tkIntXlibStubsPtr->xSetWindowBorderPixmap) /* 69 */
+#endif
+#ifndef XSetWindowBorderWidth
+#define XSetWindowBorderWidth \
+ (tkIntXlibStubsPtr->xSetWindowBorderWidth) /* 70 */
+#endif
+#ifndef XSetWindowColormap
+#define XSetWindowColormap \
+ (tkIntXlibStubsPtr->xSetWindowColormap) /* 71 */
+#endif
+#ifndef XTranslateCoordinates
+#define XTranslateCoordinates \
+ (tkIntXlibStubsPtr->xTranslateCoordinates) /* 72 */
+#endif
+#ifndef XUngrabKeyboard
+#define XUngrabKeyboard \
+ (tkIntXlibStubsPtr->xUngrabKeyboard) /* 73 */
+#endif
+#ifndef XUngrabPointer
+#define XUngrabPointer \
+ (tkIntXlibStubsPtr->xUngrabPointer) /* 74 */
+#endif
+#ifndef XUnmapWindow
+#define XUnmapWindow \
+ (tkIntXlibStubsPtr->xUnmapWindow) /* 75 */
+#endif
+#ifndef XWindowEvent
+#define XWindowEvent \
+ (tkIntXlibStubsPtr->xWindowEvent) /* 76 */
+#endif
+#ifndef XDestroyIC
+#define XDestroyIC \
+ (tkIntXlibStubsPtr->xDestroyIC) /* 77 */
+#endif
+#ifndef XFilterEvent
+#define XFilterEvent \
+ (tkIntXlibStubsPtr->xFilterEvent) /* 78 */
+#endif
+#ifndef XmbLookupString
+#define XmbLookupString \
+ (tkIntXlibStubsPtr->xmbLookupString) /* 79 */
+#endif
+#ifndef TkPutImage
+#define TkPutImage \
+ (tkIntXlibStubsPtr->tkPutImage) /* 80 */
+#endif
+/* Slot 81 is reserved */
+#ifndef XParseColor
+#define XParseColor \
+ (tkIntXlibStubsPtr->xParseColor) /* 82 */
+#endif
+#ifndef XCreateGC
+#define XCreateGC \
+ (tkIntXlibStubsPtr->xCreateGC) /* 83 */
+#endif
+#ifndef XFreeGC
+#define XFreeGC \
+ (tkIntXlibStubsPtr->xFreeGC) /* 84 */
+#endif
+#ifndef XInternAtom
+#define XInternAtom \
+ (tkIntXlibStubsPtr->xInternAtom) /* 85 */
+#endif
+#ifndef XSetBackground
+#define XSetBackground \
+ (tkIntXlibStubsPtr->xSetBackground) /* 86 */
+#endif
+#ifndef XSetForeground
+#define XSetForeground \
+ (tkIntXlibStubsPtr->xSetForeground) /* 87 */
+#endif
+#ifndef XSetClipMask
+#define XSetClipMask \
+ (tkIntXlibStubsPtr->xSetClipMask) /* 88 */
+#endif
+#ifndef XSetClipOrigin
+#define XSetClipOrigin \
+ (tkIntXlibStubsPtr->xSetClipOrigin) /* 89 */
+#endif
+#ifndef XSetTSOrigin
+#define XSetTSOrigin \
+ (tkIntXlibStubsPtr->xSetTSOrigin) /* 90 */
+#endif
+#ifndef XChangeGC
+#define XChangeGC \
+ (tkIntXlibStubsPtr->xChangeGC) /* 91 */
+#endif
+#ifndef XSetFont
+#define XSetFont \
+ (tkIntXlibStubsPtr->xSetFont) /* 92 */
+#endif
+#ifndef XSetArcMode
+#define XSetArcMode \
+ (tkIntXlibStubsPtr->xSetArcMode) /* 93 */
+#endif
+#ifndef XSetStipple
+#define XSetStipple \
+ (tkIntXlibStubsPtr->xSetStipple) /* 94 */
+#endif
+#ifndef XSetFillRule
+#define XSetFillRule \
+ (tkIntXlibStubsPtr->xSetFillRule) /* 95 */
+#endif
+#ifndef XSetFillStyle
+#define XSetFillStyle \
+ (tkIntXlibStubsPtr->xSetFillStyle) /* 96 */
+#endif
+#ifndef XSetFunction
+#define XSetFunction \
+ (tkIntXlibStubsPtr->xSetFunction) /* 97 */
+#endif
+#ifndef XSetLineAttributes
+#define XSetLineAttributes \
+ (tkIntXlibStubsPtr->xSetLineAttributes) /* 98 */
+#endif
+#ifndef _XInitImageFuncPtrs
+#define _XInitImageFuncPtrs \
+ (tkIntXlibStubsPtr->_XInitImageFuncPtrs) /* 99 */
+#endif
+#ifndef XCreateIC
+#define XCreateIC \
+ (tkIntXlibStubsPtr->xCreateIC) /* 100 */
+#endif
+#ifndef XGetVisualInfo
+#define XGetVisualInfo \
+ (tkIntXlibStubsPtr->xGetVisualInfo) /* 101 */
+#endif
+#ifndef XSetWMClientMachine
+#define XSetWMClientMachine \
+ (tkIntXlibStubsPtr->xSetWMClientMachine) /* 102 */
+#endif
+#ifndef XStringListToTextProperty
+#define XStringListToTextProperty \
+ (tkIntXlibStubsPtr->xStringListToTextProperty) /* 103 */
+#endif
+#ifndef XDrawLine
+#define XDrawLine \
+ (tkIntXlibStubsPtr->xDrawLine) /* 104 */
+#endif
+#ifndef XWarpPointer
+#define XWarpPointer \
+ (tkIntXlibStubsPtr->xWarpPointer) /* 105 */
+#endif
+#ifndef XFillRectangle
+#define XFillRectangle \
+ (tkIntXlibStubsPtr->xFillRectangle) /* 106 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef XSetDashes
+#define XSetDashes \
+ (tkIntXlibStubsPtr->xSetDashes) /* 0 */
+#endif
+#ifndef XGetModifierMapping
+#define XGetModifierMapping \
+ (tkIntXlibStubsPtr->xGetModifierMapping) /* 1 */
+#endif
+#ifndef XCreateImage
+#define XCreateImage \
+ (tkIntXlibStubsPtr->xCreateImage) /* 2 */
+#endif
+#ifndef XGetImage
+#define XGetImage \
+ (tkIntXlibStubsPtr->xGetImage) /* 3 */
+#endif
+#ifndef XGetAtomName
+#define XGetAtomName \
+ (tkIntXlibStubsPtr->xGetAtomName) /* 4 */
+#endif
+#ifndef XKeysymToString
+#define XKeysymToString \
+ (tkIntXlibStubsPtr->xKeysymToString) /* 5 */
+#endif
+#ifndef XCreateColormap
+#define XCreateColormap \
+ (tkIntXlibStubsPtr->xCreateColormap) /* 6 */
+#endif
+#ifndef XGContextFromGC
+#define XGContextFromGC \
+ (tkIntXlibStubsPtr->xGContextFromGC) /* 7 */
+#endif
+#ifndef XKeycodeToKeysym
+#define XKeycodeToKeysym \
+ (tkIntXlibStubsPtr->xKeycodeToKeysym) /* 8 */
+#endif
+#ifndef XStringToKeysym
+#define XStringToKeysym \
+ (tkIntXlibStubsPtr->xStringToKeysym) /* 9 */
+#endif
+#ifndef XRootWindow
+#define XRootWindow \
+ (tkIntXlibStubsPtr->xRootWindow) /* 10 */
+#endif
+#ifndef XSetErrorHandler
+#define XSetErrorHandler \
+ (tkIntXlibStubsPtr->xSetErrorHandler) /* 11 */
+#endif
+#ifndef XAllocColor
+#define XAllocColor \
+ (tkIntXlibStubsPtr->xAllocColor) /* 12 */
+#endif
+#ifndef XBell
+#define XBell \
+ (tkIntXlibStubsPtr->xBell) /* 13 */
+#endif
+#ifndef XChangeProperty
+#define XChangeProperty \
+ (tkIntXlibStubsPtr->xChangeProperty) /* 14 */
+#endif
+#ifndef XChangeWindowAttributes
+#define XChangeWindowAttributes \
+ (tkIntXlibStubsPtr->xChangeWindowAttributes) /* 15 */
+#endif
+#ifndef XConfigureWindow
+#define XConfigureWindow \
+ (tkIntXlibStubsPtr->xConfigureWindow) /* 16 */
+#endif
+#ifndef XCopyArea
+#define XCopyArea \
+ (tkIntXlibStubsPtr->xCopyArea) /* 17 */
+#endif
+#ifndef XCopyPlane
+#define XCopyPlane \
+ (tkIntXlibStubsPtr->xCopyPlane) /* 18 */
+#endif
+#ifndef XCreateBitmapFromData
+#define XCreateBitmapFromData \
+ (tkIntXlibStubsPtr->xCreateBitmapFromData) /* 19 */
+#endif
+#ifndef XDefineCursor
+#define XDefineCursor \
+ (tkIntXlibStubsPtr->xDefineCursor) /* 20 */
+#endif
+#ifndef XDestroyWindow
+#define XDestroyWindow \
+ (tkIntXlibStubsPtr->xDestroyWindow) /* 21 */
+#endif
+#ifndef XDrawArc
+#define XDrawArc \
+ (tkIntXlibStubsPtr->xDrawArc) /* 22 */
+#endif
+#ifndef XDrawLines
+#define XDrawLines \
+ (tkIntXlibStubsPtr->xDrawLines) /* 23 */
+#endif
+#ifndef XDrawRectangle
+#define XDrawRectangle \
+ (tkIntXlibStubsPtr->xDrawRectangle) /* 24 */
+#endif
+#ifndef XFillArc
+#define XFillArc \
+ (tkIntXlibStubsPtr->xFillArc) /* 25 */
+#endif
+#ifndef XFillPolygon
+#define XFillPolygon \
+ (tkIntXlibStubsPtr->xFillPolygon) /* 26 */
+#endif
+#ifndef XFillRectangles
+#define XFillRectangles \
+ (tkIntXlibStubsPtr->xFillRectangles) /* 27 */
+#endif
+#ifndef XFreeColormap
+#define XFreeColormap \
+ (tkIntXlibStubsPtr->xFreeColormap) /* 28 */
+#endif
+#ifndef XFreeColors
+#define XFreeColors \
+ (tkIntXlibStubsPtr->xFreeColors) /* 29 */
+#endif
+#ifndef XFreeModifiermap
+#define XFreeModifiermap \
+ (tkIntXlibStubsPtr->xFreeModifiermap) /* 30 */
+#endif
+#ifndef XGetGeometry
+#define XGetGeometry \
+ (tkIntXlibStubsPtr->xGetGeometry) /* 31 */
+#endif
+#ifndef XGetWindowProperty
+#define XGetWindowProperty \
+ (tkIntXlibStubsPtr->xGetWindowProperty) /* 32 */
+#endif
+#ifndef XGrabKeyboard
+#define XGrabKeyboard \
+ (tkIntXlibStubsPtr->xGrabKeyboard) /* 33 */
+#endif
+#ifndef XGrabPointer
+#define XGrabPointer \
+ (tkIntXlibStubsPtr->xGrabPointer) /* 34 */
+#endif
+#ifndef XKeysymToKeycode
+#define XKeysymToKeycode \
+ (tkIntXlibStubsPtr->xKeysymToKeycode) /* 35 */
+#endif
+#ifndef XMapWindow
+#define XMapWindow \
+ (tkIntXlibStubsPtr->xMapWindow) /* 36 */
+#endif
+#ifndef XMoveResizeWindow
+#define XMoveResizeWindow \
+ (tkIntXlibStubsPtr->xMoveResizeWindow) /* 37 */
+#endif
+#ifndef XMoveWindow
+#define XMoveWindow \
+ (tkIntXlibStubsPtr->xMoveWindow) /* 38 */
+#endif
+#ifndef XQueryPointer
+#define XQueryPointer \
+ (tkIntXlibStubsPtr->xQueryPointer) /* 39 */
+#endif
+#ifndef XRaiseWindow
+#define XRaiseWindow \
+ (tkIntXlibStubsPtr->xRaiseWindow) /* 40 */
+#endif
+#ifndef XRefreshKeyboardMapping
+#define XRefreshKeyboardMapping \
+ (tkIntXlibStubsPtr->xRefreshKeyboardMapping) /* 41 */
+#endif
+#ifndef XResizeWindow
+#define XResizeWindow \
+ (tkIntXlibStubsPtr->xResizeWindow) /* 42 */
+#endif
+#ifndef XSelectInput
+#define XSelectInput \
+ (tkIntXlibStubsPtr->xSelectInput) /* 43 */
+#endif
+#ifndef XSendEvent
+#define XSendEvent \
+ (tkIntXlibStubsPtr->xSendEvent) /* 44 */
+#endif
+#ifndef XSetIconName
+#define XSetIconName \
+ (tkIntXlibStubsPtr->xSetIconName) /* 45 */
+#endif
+#ifndef XSetInputFocus
+#define XSetInputFocus \
+ (tkIntXlibStubsPtr->xSetInputFocus) /* 46 */
+#endif
+#ifndef XSetSelectionOwner
+#define XSetSelectionOwner \
+ (tkIntXlibStubsPtr->xSetSelectionOwner) /* 47 */
+#endif
+#ifndef XSetWindowBackground
+#define XSetWindowBackground \
+ (tkIntXlibStubsPtr->xSetWindowBackground) /* 48 */
+#endif
+#ifndef XSetWindowBackgroundPixmap
+#define XSetWindowBackgroundPixmap \
+ (tkIntXlibStubsPtr->xSetWindowBackgroundPixmap) /* 49 */
+#endif
+#ifndef XSetWindowBorder
+#define XSetWindowBorder \
+ (tkIntXlibStubsPtr->xSetWindowBorder) /* 50 */
+#endif
+#ifndef XSetWindowBorderPixmap
+#define XSetWindowBorderPixmap \
+ (tkIntXlibStubsPtr->xSetWindowBorderPixmap) /* 51 */
+#endif
+#ifndef XSetWindowBorderWidth
+#define XSetWindowBorderWidth \
+ (tkIntXlibStubsPtr->xSetWindowBorderWidth) /* 52 */
+#endif
+#ifndef XSetWindowColormap
+#define XSetWindowColormap \
+ (tkIntXlibStubsPtr->xSetWindowColormap) /* 53 */
+#endif
+#ifndef XUngrabKeyboard
+#define XUngrabKeyboard \
+ (tkIntXlibStubsPtr->xUngrabKeyboard) /* 54 */
+#endif
+#ifndef XUngrabPointer
+#define XUngrabPointer \
+ (tkIntXlibStubsPtr->xUngrabPointer) /* 55 */
+#endif
+#ifndef XUnmapWindow
+#define XUnmapWindow \
+ (tkIntXlibStubsPtr->xUnmapWindow) /* 56 */
+#endif
+#ifndef TkPutImage
+#define TkPutImage \
+ (tkIntXlibStubsPtr->tkPutImage) /* 57 */
+#endif
+#ifndef XParseColor
+#define XParseColor \
+ (tkIntXlibStubsPtr->xParseColor) /* 58 */
+#endif
+#ifndef XCreateGC
+#define XCreateGC \
+ (tkIntXlibStubsPtr->xCreateGC) /* 59 */
+#endif
+#ifndef XFreeGC
+#define XFreeGC \
+ (tkIntXlibStubsPtr->xFreeGC) /* 60 */
+#endif
+#ifndef XInternAtom
+#define XInternAtom \
+ (tkIntXlibStubsPtr->xInternAtom) /* 61 */
+#endif
+#ifndef XSetBackground
+#define XSetBackground \
+ (tkIntXlibStubsPtr->xSetBackground) /* 62 */
+#endif
+#ifndef XSetForeground
+#define XSetForeground \
+ (tkIntXlibStubsPtr->xSetForeground) /* 63 */
+#endif
+#ifndef XSetClipMask
+#define XSetClipMask \
+ (tkIntXlibStubsPtr->xSetClipMask) /* 64 */
+#endif
+#ifndef XSetClipOrigin
+#define XSetClipOrigin \
+ (tkIntXlibStubsPtr->xSetClipOrigin) /* 65 */
+#endif
+#ifndef XSetTSOrigin
+#define XSetTSOrigin \
+ (tkIntXlibStubsPtr->xSetTSOrigin) /* 66 */
+#endif
+#ifndef XChangeGC
+#define XChangeGC \
+ (tkIntXlibStubsPtr->xChangeGC) /* 67 */
+#endif
+#ifndef XSetFont
+#define XSetFont \
+ (tkIntXlibStubsPtr->xSetFont) /* 68 */
+#endif
+#ifndef XSetArcMode
+#define XSetArcMode \
+ (tkIntXlibStubsPtr->xSetArcMode) /* 69 */
+#endif
+#ifndef XSetStipple
+#define XSetStipple \
+ (tkIntXlibStubsPtr->xSetStipple) /* 70 */
+#endif
+#ifndef XSetFillRule
+#define XSetFillRule \
+ (tkIntXlibStubsPtr->xSetFillRule) /* 71 */
+#endif
+#ifndef XSetFillStyle
+#define XSetFillStyle \
+ (tkIntXlibStubsPtr->xSetFillStyle) /* 72 */
+#endif
+#ifndef XSetFunction
+#define XSetFunction \
+ (tkIntXlibStubsPtr->xSetFunction) /* 73 */
+#endif
+#ifndef XSetLineAttributes
+#define XSetLineAttributes \
+ (tkIntXlibStubsPtr->xSetLineAttributes) /* 74 */
+#endif
+#ifndef _XInitImageFuncPtrs
+#define _XInitImageFuncPtrs \
+ (tkIntXlibStubsPtr->_XInitImageFuncPtrs) /* 75 */
+#endif
+#ifndef XCreateIC
+#define XCreateIC \
+ (tkIntXlibStubsPtr->xCreateIC) /* 76 */
+#endif
+#ifndef XGetVisualInfo
+#define XGetVisualInfo \
+ (tkIntXlibStubsPtr->xGetVisualInfo) /* 77 */
+#endif
+#ifndef XSetWMClientMachine
+#define XSetWMClientMachine \
+ (tkIntXlibStubsPtr->xSetWMClientMachine) /* 78 */
+#endif
+#ifndef XStringListToTextProperty
+#define XStringListToTextProperty \
+ (tkIntXlibStubsPtr->xStringListToTextProperty) /* 79 */
+#endif
+#ifndef XDrawSegments
+#define XDrawSegments \
+ (tkIntXlibStubsPtr->xDrawSegments) /* 80 */
+#endif
+#ifndef XForceScreenSaver
+#define XForceScreenSaver \
+ (tkIntXlibStubsPtr->xForceScreenSaver) /* 81 */
+#endif
+#ifndef XDrawLine
+#define XDrawLine \
+ (tkIntXlibStubsPtr->xDrawLine) /* 82 */
+#endif
+#ifndef XFillRectangle
+#define XFillRectangle \
+ (tkIntXlibStubsPtr->xFillRectangle) /* 83 */
+#endif
+#ifndef XClearWindow
+#define XClearWindow \
+ (tkIntXlibStubsPtr->xClearWindow) /* 84 */
+#endif
+#ifndef XDrawPoint
+#define XDrawPoint \
+ (tkIntXlibStubsPtr->xDrawPoint) /* 85 */
+#endif
+#ifndef XDrawPoints
+#define XDrawPoints \
+ (tkIntXlibStubsPtr->xDrawPoints) /* 86 */
+#endif
+#ifndef XWarpPointer
+#define XWarpPointer \
+ (tkIntXlibStubsPtr->xWarpPointer) /* 87 */
+#endif
+#ifndef XQueryColor
+#define XQueryColor \
+ (tkIntXlibStubsPtr->xQueryColor) /* 88 */
+#endif
+#ifndef XQueryColors
+#define XQueryColors \
+ (tkIntXlibStubsPtr->xQueryColors) /* 89 */
+#endif
+#ifndef XQueryTree
+#define XQueryTree \
+ (tkIntXlibStubsPtr->xQueryTree) /* 90 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef XSetDashes
+#define XSetDashes \
+ (tkIntXlibStubsPtr->xSetDashes) /* 0 */
+#endif
+#ifndef XGetModifierMapping
+#define XGetModifierMapping \
+ (tkIntXlibStubsPtr->xGetModifierMapping) /* 1 */
+#endif
+#ifndef XCreateImage
+#define XCreateImage \
+ (tkIntXlibStubsPtr->xCreateImage) /* 2 */
+#endif
+#ifndef XGetImage
+#define XGetImage \
+ (tkIntXlibStubsPtr->xGetImage) /* 3 */
+#endif
+#ifndef XGetAtomName
+#define XGetAtomName \
+ (tkIntXlibStubsPtr->xGetAtomName) /* 4 */
+#endif
+#ifndef XKeysymToString
+#define XKeysymToString \
+ (tkIntXlibStubsPtr->xKeysymToString) /* 5 */
+#endif
+#ifndef XCreateColormap
+#define XCreateColormap \
+ (tkIntXlibStubsPtr->xCreateColormap) /* 6 */
+#endif
+#ifndef XGContextFromGC
+#define XGContextFromGC \
+ (tkIntXlibStubsPtr->xGContextFromGC) /* 7 */
+#endif
+#ifndef XKeycodeToKeysym
+#define XKeycodeToKeysym \
+ (tkIntXlibStubsPtr->xKeycodeToKeysym) /* 8 */
+#endif
+#ifndef XStringToKeysym
+#define XStringToKeysym \
+ (tkIntXlibStubsPtr->xStringToKeysym) /* 9 */
+#endif
+#ifndef XRootWindow
+#define XRootWindow \
+ (tkIntXlibStubsPtr->xRootWindow) /* 10 */
+#endif
+#ifndef XSetErrorHandler
+#define XSetErrorHandler \
+ (tkIntXlibStubsPtr->xSetErrorHandler) /* 11 */
+#endif
+#ifndef XAllocColor
+#define XAllocColor \
+ (tkIntXlibStubsPtr->xAllocColor) /* 12 */
+#endif
+#ifndef XBell
+#define XBell \
+ (tkIntXlibStubsPtr->xBell) /* 13 */
+#endif
+#ifndef XChangeProperty
+#define XChangeProperty \
+ (tkIntXlibStubsPtr->xChangeProperty) /* 14 */
+#endif
+#ifndef XChangeWindowAttributes
+#define XChangeWindowAttributes \
+ (tkIntXlibStubsPtr->xChangeWindowAttributes) /* 15 */
+#endif
+#ifndef XConfigureWindow
+#define XConfigureWindow \
+ (tkIntXlibStubsPtr->xConfigureWindow) /* 16 */
+#endif
+#ifndef XCopyArea
+#define XCopyArea \
+ (tkIntXlibStubsPtr->xCopyArea) /* 17 */
+#endif
+#ifndef XCopyPlane
+#define XCopyPlane \
+ (tkIntXlibStubsPtr->xCopyPlane) /* 18 */
+#endif
+#ifndef XCreateBitmapFromData
+#define XCreateBitmapFromData \
+ (tkIntXlibStubsPtr->xCreateBitmapFromData) /* 19 */
+#endif
+#ifndef XDefineCursor
+#define XDefineCursor \
+ (tkIntXlibStubsPtr->xDefineCursor) /* 20 */
+#endif
+#ifndef XDestroyWindow
+#define XDestroyWindow \
+ (tkIntXlibStubsPtr->xDestroyWindow) /* 21 */
+#endif
+#ifndef XDrawArc
+#define XDrawArc \
+ (tkIntXlibStubsPtr->xDrawArc) /* 22 */
+#endif
+#ifndef XDrawLines
+#define XDrawLines \
+ (tkIntXlibStubsPtr->xDrawLines) /* 23 */
+#endif
+#ifndef XDrawRectangle
+#define XDrawRectangle \
+ (tkIntXlibStubsPtr->xDrawRectangle) /* 24 */
+#endif
+#ifndef XFillArc
+#define XFillArc \
+ (tkIntXlibStubsPtr->xFillArc) /* 25 */
+#endif
+#ifndef XFillPolygon
+#define XFillPolygon \
+ (tkIntXlibStubsPtr->xFillPolygon) /* 26 */
+#endif
+#ifndef XFillRectangles
+#define XFillRectangles \
+ (tkIntXlibStubsPtr->xFillRectangles) /* 27 */
+#endif
+#ifndef XFreeColormap
+#define XFreeColormap \
+ (tkIntXlibStubsPtr->xFreeColormap) /* 28 */
+#endif
+#ifndef XFreeColors
+#define XFreeColors \
+ (tkIntXlibStubsPtr->xFreeColors) /* 29 */
+#endif
+#ifndef XFreeModifiermap
+#define XFreeModifiermap \
+ (tkIntXlibStubsPtr->xFreeModifiermap) /* 30 */
+#endif
+#ifndef XGetGeometry
+#define XGetGeometry \
+ (tkIntXlibStubsPtr->xGetGeometry) /* 31 */
+#endif
+#ifndef XGetWindowProperty
+#define XGetWindowProperty \
+ (tkIntXlibStubsPtr->xGetWindowProperty) /* 32 */
+#endif
+#ifndef XGrabKeyboard
+#define XGrabKeyboard \
+ (tkIntXlibStubsPtr->xGrabKeyboard) /* 33 */
+#endif
+#ifndef XGrabPointer
+#define XGrabPointer \
+ (tkIntXlibStubsPtr->xGrabPointer) /* 34 */
+#endif
+#ifndef XKeysymToKeycode
+#define XKeysymToKeycode \
+ (tkIntXlibStubsPtr->xKeysymToKeycode) /* 35 */
+#endif
+#ifndef XMapWindow
+#define XMapWindow \
+ (tkIntXlibStubsPtr->xMapWindow) /* 36 */
+#endif
+#ifndef XMoveResizeWindow
+#define XMoveResizeWindow \
+ (tkIntXlibStubsPtr->xMoveResizeWindow) /* 37 */
+#endif
+#ifndef XMoveWindow
+#define XMoveWindow \
+ (tkIntXlibStubsPtr->xMoveWindow) /* 38 */
+#endif
+#ifndef XQueryPointer
+#define XQueryPointer \
+ (tkIntXlibStubsPtr->xQueryPointer) /* 39 */
+#endif
+#ifndef XRaiseWindow
+#define XRaiseWindow \
+ (tkIntXlibStubsPtr->xRaiseWindow) /* 40 */
+#endif
+#ifndef XRefreshKeyboardMapping
+#define XRefreshKeyboardMapping \
+ (tkIntXlibStubsPtr->xRefreshKeyboardMapping) /* 41 */
+#endif
+#ifndef XResizeWindow
+#define XResizeWindow \
+ (tkIntXlibStubsPtr->xResizeWindow) /* 42 */
+#endif
+#ifndef XSelectInput
+#define XSelectInput \
+ (tkIntXlibStubsPtr->xSelectInput) /* 43 */
+#endif
+#ifndef XSendEvent
+#define XSendEvent \
+ (tkIntXlibStubsPtr->xSendEvent) /* 44 */
+#endif
+#ifndef XSetIconName
+#define XSetIconName \
+ (tkIntXlibStubsPtr->xSetIconName) /* 45 */
+#endif
+#ifndef XSetInputFocus
+#define XSetInputFocus \
+ (tkIntXlibStubsPtr->xSetInputFocus) /* 46 */
+#endif
+#ifndef XSetSelectionOwner
+#define XSetSelectionOwner \
+ (tkIntXlibStubsPtr->xSetSelectionOwner) /* 47 */
+#endif
+#ifndef XSetWindowBackground
+#define XSetWindowBackground \
+ (tkIntXlibStubsPtr->xSetWindowBackground) /* 48 */
+#endif
+#ifndef XSetWindowBackgroundPixmap
+#define XSetWindowBackgroundPixmap \
+ (tkIntXlibStubsPtr->xSetWindowBackgroundPixmap) /* 49 */
+#endif
+#ifndef XSetWindowBorder
+#define XSetWindowBorder \
+ (tkIntXlibStubsPtr->xSetWindowBorder) /* 50 */
+#endif
+#ifndef XSetWindowBorderPixmap
+#define XSetWindowBorderPixmap \
+ (tkIntXlibStubsPtr->xSetWindowBorderPixmap) /* 51 */
+#endif
+#ifndef XSetWindowBorderWidth
+#define XSetWindowBorderWidth \
+ (tkIntXlibStubsPtr->xSetWindowBorderWidth) /* 52 */
+#endif
+#ifndef XSetWindowColormap
+#define XSetWindowColormap \
+ (tkIntXlibStubsPtr->xSetWindowColormap) /* 53 */
+#endif
+#ifndef XUngrabKeyboard
+#define XUngrabKeyboard \
+ (tkIntXlibStubsPtr->xUngrabKeyboard) /* 54 */
+#endif
+#ifndef XUngrabPointer
+#define XUngrabPointer \
+ (tkIntXlibStubsPtr->xUngrabPointer) /* 55 */
+#endif
+#ifndef XUnmapWindow
+#define XUnmapWindow \
+ (tkIntXlibStubsPtr->xUnmapWindow) /* 56 */
+#endif
+#ifndef TkPutImage
+#define TkPutImage \
+ (tkIntXlibStubsPtr->tkPutImage) /* 57 */
+#endif
+#ifndef XParseColor
+#define XParseColor \
+ (tkIntXlibStubsPtr->xParseColor) /* 58 */
+#endif
+#ifndef XCreateGC
+#define XCreateGC \
+ (tkIntXlibStubsPtr->xCreateGC) /* 59 */
+#endif
+#ifndef XFreeGC
+#define XFreeGC \
+ (tkIntXlibStubsPtr->xFreeGC) /* 60 */
+#endif
+#ifndef XInternAtom
+#define XInternAtom \
+ (tkIntXlibStubsPtr->xInternAtom) /* 61 */
+#endif
+#ifndef XSetBackground
+#define XSetBackground \
+ (tkIntXlibStubsPtr->xSetBackground) /* 62 */
+#endif
+#ifndef XSetForeground
+#define XSetForeground \
+ (tkIntXlibStubsPtr->xSetForeground) /* 63 */
+#endif
+#ifndef XSetClipMask
+#define XSetClipMask \
+ (tkIntXlibStubsPtr->xSetClipMask) /* 64 */
+#endif
+#ifndef XSetClipOrigin
+#define XSetClipOrigin \
+ (tkIntXlibStubsPtr->xSetClipOrigin) /* 65 */
+#endif
+#ifndef XSetTSOrigin
+#define XSetTSOrigin \
+ (tkIntXlibStubsPtr->xSetTSOrigin) /* 66 */
+#endif
+#ifndef XChangeGC
+#define XChangeGC \
+ (tkIntXlibStubsPtr->xChangeGC) /* 67 */
+#endif
+#ifndef XSetFont
+#define XSetFont \
+ (tkIntXlibStubsPtr->xSetFont) /* 68 */
+#endif
+#ifndef XSetArcMode
+#define XSetArcMode \
+ (tkIntXlibStubsPtr->xSetArcMode) /* 69 */
+#endif
+#ifndef XSetStipple
+#define XSetStipple \
+ (tkIntXlibStubsPtr->xSetStipple) /* 70 */
+#endif
+#ifndef XSetFillRule
+#define XSetFillRule \
+ (tkIntXlibStubsPtr->xSetFillRule) /* 71 */
+#endif
+#ifndef XSetFillStyle
+#define XSetFillStyle \
+ (tkIntXlibStubsPtr->xSetFillStyle) /* 72 */
+#endif
+#ifndef XSetFunction
+#define XSetFunction \
+ (tkIntXlibStubsPtr->xSetFunction) /* 73 */
+#endif
+#ifndef XSetLineAttributes
+#define XSetLineAttributes \
+ (tkIntXlibStubsPtr->xSetLineAttributes) /* 74 */
+#endif
+#ifndef _XInitImageFuncPtrs
+#define _XInitImageFuncPtrs \
+ (tkIntXlibStubsPtr->_XInitImageFuncPtrs) /* 75 */
+#endif
+#ifndef XCreateIC
+#define XCreateIC \
+ (tkIntXlibStubsPtr->xCreateIC) /* 76 */
+#endif
+#ifndef XGetVisualInfo
+#define XGetVisualInfo \
+ (tkIntXlibStubsPtr->xGetVisualInfo) /* 77 */
+#endif
+#ifndef XSetWMClientMachine
+#define XSetWMClientMachine \
+ (tkIntXlibStubsPtr->xSetWMClientMachine) /* 78 */
+#endif
+#ifndef XStringListToTextProperty
+#define XStringListToTextProperty \
+ (tkIntXlibStubsPtr->xStringListToTextProperty) /* 79 */
+#endif
+#ifndef XDrawSegments
+#define XDrawSegments \
+ (tkIntXlibStubsPtr->xDrawSegments) /* 80 */
+#endif
+#ifndef XForceScreenSaver
+#define XForceScreenSaver \
+ (tkIntXlibStubsPtr->xForceScreenSaver) /* 81 */
+#endif
+#ifndef XDrawLine
+#define XDrawLine \
+ (tkIntXlibStubsPtr->xDrawLine) /* 82 */
+#endif
+#ifndef XFillRectangle
+#define XFillRectangle \
+ (tkIntXlibStubsPtr->xFillRectangle) /* 83 */
+#endif
+#ifndef XClearWindow
+#define XClearWindow \
+ (tkIntXlibStubsPtr->xClearWindow) /* 84 */
+#endif
+#ifndef XDrawPoint
+#define XDrawPoint \
+ (tkIntXlibStubsPtr->xDrawPoint) /* 85 */
+#endif
+#ifndef XDrawPoints
+#define XDrawPoints \
+ (tkIntXlibStubsPtr->xDrawPoints) /* 86 */
+#endif
+#ifndef XWarpPointer
+#define XWarpPointer \
+ (tkIntXlibStubsPtr->xWarpPointer) /* 87 */
+#endif
+#ifndef XQueryColor
+#define XQueryColor \
+ (tkIntXlibStubsPtr->xQueryColor) /* 88 */
+#endif
+#ifndef XQueryColors
+#define XQueryColors \
+ (tkIntXlibStubsPtr->xQueryColors) /* 89 */
+#endif
+#ifndef XQueryTree
+#define XQueryTree \
+ (tkIntXlibStubsPtr->xQueryTree) /* 90 */
+#endif
+#endif /* MAC_OSX_TK */
+
+#endif /* defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKINTXLIBDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.m
new file mode 100755
index 00000000000..8671ce54721
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.m
@@ -0,0 +1,446 @@
+#ifndef _TKINTXLIBDECLS_VM
+#define _TKINTXLIBDECLS_VM
+#include "tkIntXlibDecls_f.h"
+#ifndef NO_VTABLES
+#ifndef TkPutImage
+# define TkPutImage (*TkintxlibdeclsVptr->V_TkPutImage)
+#endif
+
+#ifndef XAllocColor
+# define XAllocColor (*TkintxlibdeclsVptr->V_XAllocColor)
+#endif
+
+#ifndef XBell
+# define XBell (*TkintxlibdeclsVptr->V_XBell)
+#endif
+
+#ifndef XChangeGC
+# define XChangeGC (*TkintxlibdeclsVptr->V_XChangeGC)
+#endif
+
+#ifndef XChangeProperty
+# define XChangeProperty (*TkintxlibdeclsVptr->V_XChangeProperty)
+#endif
+
+#ifndef XChangeWindowAttributes
+# define XChangeWindowAttributes (*TkintxlibdeclsVptr->V_XChangeWindowAttributes)
+#endif
+
+#ifndef XClearWindow
+# define XClearWindow (*TkintxlibdeclsVptr->V_XClearWindow)
+#endif
+
+#ifndef XConfigureWindow
+# define XConfigureWindow (*TkintxlibdeclsVptr->V_XConfigureWindow)
+#endif
+
+#ifndef XCopyArea
+# define XCopyArea (*TkintxlibdeclsVptr->V_XCopyArea)
+#endif
+
+#ifndef XCopyPlane
+# define XCopyPlane (*TkintxlibdeclsVptr->V_XCopyPlane)
+#endif
+
+#ifndef XCreateBitmapFromData
+# define XCreateBitmapFromData (*TkintxlibdeclsVptr->V_XCreateBitmapFromData)
+#endif
+
+#ifndef XCreateColormap
+# define XCreateColormap (*TkintxlibdeclsVptr->V_XCreateColormap)
+#endif
+
+#ifndef XCreateGC
+# define XCreateGC (*TkintxlibdeclsVptr->V_XCreateGC)
+#endif
+
+#ifndef XCreateGlyphCursor
+# define XCreateGlyphCursor (*TkintxlibdeclsVptr->V_XCreateGlyphCursor)
+#endif
+
+#ifndef XCreateIC
+# define XCreateIC (*TkintxlibdeclsVptr->V_XCreateIC)
+#endif
+
+#ifndef XCreateImage
+# define XCreateImage (*TkintxlibdeclsVptr->V_XCreateImage)
+#endif
+
+#ifndef XCreatePixmapCursor
+# define XCreatePixmapCursor (*TkintxlibdeclsVptr->V_XCreatePixmapCursor)
+#endif
+
+#ifndef XDefineCursor
+# define XDefineCursor (*TkintxlibdeclsVptr->V_XDefineCursor)
+#endif
+
+#ifndef XDeleteProperty
+# define XDeleteProperty (*TkintxlibdeclsVptr->V_XDeleteProperty)
+#endif
+
+#ifndef XDestroyIC
+# define XDestroyIC (*TkintxlibdeclsVptr->V_XDestroyIC)
+#endif
+
+#ifndef XDestroyWindow
+# define XDestroyWindow (*TkintxlibdeclsVptr->V_XDestroyWindow)
+#endif
+
+#ifndef XDrawArc
+# define XDrawArc (*TkintxlibdeclsVptr->V_XDrawArc)
+#endif
+
+#ifndef XDrawLine
+# define XDrawLine (*TkintxlibdeclsVptr->V_XDrawLine)
+#endif
+
+#ifndef XDrawLines
+# define XDrawLines (*TkintxlibdeclsVptr->V_XDrawLines)
+#endif
+
+#ifndef XDrawPoint
+# define XDrawPoint (*TkintxlibdeclsVptr->V_XDrawPoint)
+#endif
+
+#ifndef XDrawPoints
+# define XDrawPoints (*TkintxlibdeclsVptr->V_XDrawPoints)
+#endif
+
+#ifndef XDrawRectangle
+# define XDrawRectangle (*TkintxlibdeclsVptr->V_XDrawRectangle)
+#endif
+
+#ifndef XDrawSegments
+# define XDrawSegments (*TkintxlibdeclsVptr->V_XDrawSegments)
+#endif
+
+#ifndef XFillArc
+# define XFillArc (*TkintxlibdeclsVptr->V_XFillArc)
+#endif
+
+#ifndef XFillPolygon
+# define XFillPolygon (*TkintxlibdeclsVptr->V_XFillPolygon)
+#endif
+
+#ifndef XFillRectangle
+# define XFillRectangle (*TkintxlibdeclsVptr->V_XFillRectangle)
+#endif
+
+#ifndef XFillRectangles
+# define XFillRectangles (*TkintxlibdeclsVptr->V_XFillRectangles)
+#endif
+
+#ifndef XFilterEvent
+# define XFilterEvent (*TkintxlibdeclsVptr->V_XFilterEvent)
+#endif
+
+#ifndef XForceScreenSaver
+# define XForceScreenSaver (*TkintxlibdeclsVptr->V_XForceScreenSaver)
+#endif
+
+#ifndef XFreeColormap
+# define XFreeColormap (*TkintxlibdeclsVptr->V_XFreeColormap)
+#endif
+
+#ifndef XFreeColors
+# define XFreeColors (*TkintxlibdeclsVptr->V_XFreeColors)
+#endif
+
+#ifndef XFreeCursor
+# define XFreeCursor (*TkintxlibdeclsVptr->V_XFreeCursor)
+#endif
+
+#ifndef XFreeGC
+# define XFreeGC (*TkintxlibdeclsVptr->V_XFreeGC)
+#endif
+
+#ifndef XFreeModifiermap
+# define XFreeModifiermap (*TkintxlibdeclsVptr->V_XFreeModifiermap)
+#endif
+
+#ifndef XGContextFromGC
+# define XGContextFromGC (*TkintxlibdeclsVptr->V_XGContextFromGC)
+#endif
+
+#ifndef XGetAtomName
+# define XGetAtomName (*TkintxlibdeclsVptr->V_XGetAtomName)
+#endif
+
+#ifndef XGetGeometry
+# define XGetGeometry (*TkintxlibdeclsVptr->V_XGetGeometry)
+#endif
+
+#ifndef XGetImage
+# define XGetImage (*TkintxlibdeclsVptr->V_XGetImage)
+#endif
+
+#ifndef XGetInputFocus
+# define XGetInputFocus (*TkintxlibdeclsVptr->V_XGetInputFocus)
+#endif
+
+#ifndef XGetModifierMapping
+# define XGetModifierMapping (*TkintxlibdeclsVptr->V_XGetModifierMapping)
+#endif
+
+#ifndef XGetVisualInfo
+# define XGetVisualInfo (*TkintxlibdeclsVptr->V_XGetVisualInfo)
+#endif
+
+#ifndef XGetWMColormapWindows
+# define XGetWMColormapWindows (*TkintxlibdeclsVptr->V_XGetWMColormapWindows)
+#endif
+
+#ifndef XGetWindowAttributes
+# define XGetWindowAttributes (*TkintxlibdeclsVptr->V_XGetWindowAttributes)
+#endif
+
+#ifndef XGetWindowProperty
+# define XGetWindowProperty (*TkintxlibdeclsVptr->V_XGetWindowProperty)
+#endif
+
+#ifndef XGrabKeyboard
+# define XGrabKeyboard (*TkintxlibdeclsVptr->V_XGrabKeyboard)
+#endif
+
+#ifndef XGrabPointer
+# define XGrabPointer (*TkintxlibdeclsVptr->V_XGrabPointer)
+#endif
+
+#ifndef XIconifyWindow
+# define XIconifyWindow (*TkintxlibdeclsVptr->V_XIconifyWindow)
+#endif
+
+#ifndef XInternAtom
+# define XInternAtom (*TkintxlibdeclsVptr->V_XInternAtom)
+#endif
+
+#ifndef XKeycodeToKeysym
+# define XKeycodeToKeysym (*TkintxlibdeclsVptr->V_XKeycodeToKeysym)
+#endif
+
+#ifndef XKeysymToKeycode
+# define XKeysymToKeycode (*TkintxlibdeclsVptr->V_XKeysymToKeycode)
+#endif
+
+#ifndef XKeysymToString
+# define XKeysymToString (*TkintxlibdeclsVptr->V_XKeysymToString)
+#endif
+
+#ifndef XListHosts
+# define XListHosts (*TkintxlibdeclsVptr->V_XListHosts)
+#endif
+
+#ifndef XLookupColor
+# define XLookupColor (*TkintxlibdeclsVptr->V_XLookupColor)
+#endif
+
+#ifndef XMapWindow
+# define XMapWindow (*TkintxlibdeclsVptr->V_XMapWindow)
+#endif
+
+#ifndef XMoveResizeWindow
+# define XMoveResizeWindow (*TkintxlibdeclsVptr->V_XMoveResizeWindow)
+#endif
+
+#ifndef XMoveWindow
+# define XMoveWindow (*TkintxlibdeclsVptr->V_XMoveWindow)
+#endif
+
+#ifndef XNextEvent
+# define XNextEvent (*TkintxlibdeclsVptr->V_XNextEvent)
+#endif
+
+#ifndef XParseColor
+# define XParseColor (*TkintxlibdeclsVptr->V_XParseColor)
+#endif
+
+#ifndef XPutBackEvent
+# define XPutBackEvent (*TkintxlibdeclsVptr->V_XPutBackEvent)
+#endif
+
+#ifndef XQueryColor
+# define XQueryColor (*TkintxlibdeclsVptr->V_XQueryColor)
+#endif
+
+#ifndef XQueryColors
+# define XQueryColors (*TkintxlibdeclsVptr->V_XQueryColors)
+#endif
+
+#ifndef XQueryPointer
+# define XQueryPointer (*TkintxlibdeclsVptr->V_XQueryPointer)
+#endif
+
+#ifndef XQueryTree
+# define XQueryTree (*TkintxlibdeclsVptr->V_XQueryTree)
+#endif
+
+#ifndef XRaiseWindow
+# define XRaiseWindow (*TkintxlibdeclsVptr->V_XRaiseWindow)
+#endif
+
+#ifndef XRefreshKeyboardMapping
+# define XRefreshKeyboardMapping (*TkintxlibdeclsVptr->V_XRefreshKeyboardMapping)
+#endif
+
+#ifndef XResizeWindow
+# define XResizeWindow (*TkintxlibdeclsVptr->V_XResizeWindow)
+#endif
+
+#ifndef XRootWindow
+# define XRootWindow (*TkintxlibdeclsVptr->V_XRootWindow)
+#endif
+
+#ifndef XSelectInput
+# define XSelectInput (*TkintxlibdeclsVptr->V_XSelectInput)
+#endif
+
+#ifndef XSendEvent
+# define XSendEvent (*TkintxlibdeclsVptr->V_XSendEvent)
+#endif
+
+#ifndef XSetArcMode
+# define XSetArcMode (*TkintxlibdeclsVptr->V_XSetArcMode)
+#endif
+
+#ifndef XSetBackground
+# define XSetBackground (*TkintxlibdeclsVptr->V_XSetBackground)
+#endif
+
+#ifndef XSetClipMask
+# define XSetClipMask (*TkintxlibdeclsVptr->V_XSetClipMask)
+#endif
+
+#ifndef XSetClipOrigin
+# define XSetClipOrigin (*TkintxlibdeclsVptr->V_XSetClipOrigin)
+#endif
+
+#ifndef XSetCommand
+# define XSetCommand (*TkintxlibdeclsVptr->V_XSetCommand)
+#endif
+
+#ifndef XSetDashes
+# define XSetDashes (*TkintxlibdeclsVptr->V_XSetDashes)
+#endif
+
+#ifndef XSetErrorHandler
+# define XSetErrorHandler (*TkintxlibdeclsVptr->V_XSetErrorHandler)
+#endif
+
+#ifndef XSetFillRule
+# define XSetFillRule (*TkintxlibdeclsVptr->V_XSetFillRule)
+#endif
+
+#ifndef XSetFillStyle
+# define XSetFillStyle (*TkintxlibdeclsVptr->V_XSetFillStyle)
+#endif
+
+#ifndef XSetFont
+# define XSetFont (*TkintxlibdeclsVptr->V_XSetFont)
+#endif
+
+#ifndef XSetForeground
+# define XSetForeground (*TkintxlibdeclsVptr->V_XSetForeground)
+#endif
+
+#ifndef XSetFunction
+# define XSetFunction (*TkintxlibdeclsVptr->V_XSetFunction)
+#endif
+
+#ifndef XSetIconName
+# define XSetIconName (*TkintxlibdeclsVptr->V_XSetIconName)
+#endif
+
+#ifndef XSetInputFocus
+# define XSetInputFocus (*TkintxlibdeclsVptr->V_XSetInputFocus)
+#endif
+
+#ifndef XSetLineAttributes
+# define XSetLineAttributes (*TkintxlibdeclsVptr->V_XSetLineAttributes)
+#endif
+
+#ifndef XSetSelectionOwner
+# define XSetSelectionOwner (*TkintxlibdeclsVptr->V_XSetSelectionOwner)
+#endif
+
+#ifndef XSetStipple
+# define XSetStipple (*TkintxlibdeclsVptr->V_XSetStipple)
+#endif
+
+#ifndef XSetTSOrigin
+# define XSetTSOrigin (*TkintxlibdeclsVptr->V_XSetTSOrigin)
+#endif
+
+#ifndef XSetWMClientMachine
+# define XSetWMClientMachine (*TkintxlibdeclsVptr->V_XSetWMClientMachine)
+#endif
+
+#ifndef XSetWindowBackground
+# define XSetWindowBackground (*TkintxlibdeclsVptr->V_XSetWindowBackground)
+#endif
+
+#ifndef XSetWindowBackgroundPixmap
+# define XSetWindowBackgroundPixmap (*TkintxlibdeclsVptr->V_XSetWindowBackgroundPixmap)
+#endif
+
+#ifndef XSetWindowBorder
+# define XSetWindowBorder (*TkintxlibdeclsVptr->V_XSetWindowBorder)
+#endif
+
+#ifndef XSetWindowBorderPixmap
+# define XSetWindowBorderPixmap (*TkintxlibdeclsVptr->V_XSetWindowBorderPixmap)
+#endif
+
+#ifndef XSetWindowBorderWidth
+# define XSetWindowBorderWidth (*TkintxlibdeclsVptr->V_XSetWindowBorderWidth)
+#endif
+
+#ifndef XSetWindowColormap
+# define XSetWindowColormap (*TkintxlibdeclsVptr->V_XSetWindowColormap)
+#endif
+
+#ifndef XStringListToTextProperty
+# define XStringListToTextProperty (*TkintxlibdeclsVptr->V_XStringListToTextProperty)
+#endif
+
+#ifndef XStringToKeysym
+# define XStringToKeysym (*TkintxlibdeclsVptr->V_XStringToKeysym)
+#endif
+
+#ifndef XTranslateCoordinates
+# define XTranslateCoordinates (*TkintxlibdeclsVptr->V_XTranslateCoordinates)
+#endif
+
+#ifndef XUngrabKeyboard
+# define XUngrabKeyboard (*TkintxlibdeclsVptr->V_XUngrabKeyboard)
+#endif
+
+#ifndef XUngrabPointer
+# define XUngrabPointer (*TkintxlibdeclsVptr->V_XUngrabPointer)
+#endif
+
+#ifndef XUnmapWindow
+# define XUnmapWindow (*TkintxlibdeclsVptr->V_XUnmapWindow)
+#endif
+
+#ifndef XWarpPointer
+# define XWarpPointer (*TkintxlibdeclsVptr->V_XWarpPointer)
+#endif
+
+#ifndef XWindowEvent
+# define XWindowEvent (*TkintxlibdeclsVptr->V_XWindowEvent)
+#endif
+
+#ifndef XWithdrawWindow
+# define XWithdrawWindow (*TkintxlibdeclsVptr->V_XWithdrawWindow)
+#endif
+
+#ifndef XmbLookupString
+# define XmbLookupString (*TkintxlibdeclsVptr->V_XmbLookupString)
+#endif
+
+#ifndef _XInitImageFuncPtrs
+# define _XInitImageFuncPtrs (*TkintxlibdeclsVptr->V__XInitImageFuncPtrs)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKINTXLIBDECLS_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.t
new file mode 100755
index 00000000000..fe7722315d0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls.t
@@ -0,0 +1,1521 @@
+#ifdef _TKINTXLIBDECLS
+#ifndef TkPutImage
+#ifdef MAC_OSX_TK
+VFUNC(void,TkPutImage,V_TkPutImage,_ANSI_ARGS_((unsigned long * colors,
+ int ncolors, Display* display, Drawable d,
+ GC gc, XImage* image, int src_x, int src_y,
+ int dest_x, int dest_y, unsigned int width,
+ unsigned int height)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkPutImage,V_TkPutImage,_ANSI_ARGS_((unsigned long * colors,
+ int ncolors, Display* display, Drawable d,
+ GC gc, XImage* image, int src_x, int src_y,
+ int dest_x, int dest_y, unsigned int width,
+ unsigned int height)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,TkPutImage,V_TkPutImage,_ANSI_ARGS_((unsigned long * colors,
+ int ncolors, Display* display, Drawable d,
+ GC gc, XImage* image, int src_x, int src_y,
+ int dest_x, int dest_y, unsigned int width,
+ unsigned int height)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef TkPutImage */
+
+#ifndef XAllocColor
+#ifdef MAC_OSX_TK
+VFUNC(Status,XAllocColor,V_XAllocColor,_ANSI_ARGS_((Display* d, Colormap c,
+ XColor* xp)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Status,XAllocColor,V_XAllocColor,_ANSI_ARGS_((Display* d, Colormap c,
+ XColor* xp)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Status,XAllocColor,V_XAllocColor,_ANSI_ARGS_((Display* d, Colormap c,
+ XColor* xp)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XAllocColor */
+
+#ifndef XBell
+#ifdef MAC_OSX_TK
+VFUNC(void,XBell,V_XBell,_ANSI_ARGS_((Display* d, int i)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XBell,V_XBell,_ANSI_ARGS_((Display* d, int i)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XBell,V_XBell,_ANSI_ARGS_((Display* d, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XBell */
+
+#ifndef XChangeGC
+#ifdef MAC_OSX_TK
+VFUNC(void,XChangeGC,V_XChangeGC,_ANSI_ARGS_((Display * d, GC gc,
+ unsigned long mask, XGCValues * values)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XChangeGC,V_XChangeGC,_ANSI_ARGS_((Display * d, GC gc,
+ unsigned long mask, XGCValues * values)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XChangeGC,V_XChangeGC,_ANSI_ARGS_((Display * d, GC gc,
+ unsigned long mask, XGCValues * values)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XChangeGC */
+
+#ifndef XChangeProperty
+#ifdef MAC_OSX_TK
+VFUNC(void,XChangeProperty,V_XChangeProperty,_ANSI_ARGS_((Display* d, Window w,
+ Atom a1, Atom a2, int i1, int i2,
+ _Xconst unsigned char* c, int i3)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XChangeProperty,V_XChangeProperty,_ANSI_ARGS_((Display* d, Window w,
+ Atom a1, Atom a2, int i1, int i2,
+ _Xconst unsigned char* c, int i3)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XChangeProperty,V_XChangeProperty,_ANSI_ARGS_((Display* d, Window w,
+ Atom a1, Atom a2, int i1, int i2,
+ _Xconst unsigned char* c, int i3)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XChangeProperty */
+
+#ifndef XChangeWindowAttributes
+#ifdef MAC_OSX_TK
+VFUNC(void,XChangeWindowAttributes,V_XChangeWindowAttributes,_ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul,
+ XSetWindowAttributes* x)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XChangeWindowAttributes,V_XChangeWindowAttributes,_ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul,
+ XSetWindowAttributes* x)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XChangeWindowAttributes,V_XChangeWindowAttributes,_ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul,
+ XSetWindowAttributes* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XChangeWindowAttributes */
+
+#ifndef XClearWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XClearWindow,V_XClearWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XClearWindow,V_XClearWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XClearWindow,V_XClearWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XClearWindow */
+
+#ifndef XConfigureWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XConfigureWindow,V_XConfigureWindow,_ANSI_ARGS_((Display* d, Window w,
+ unsigned int i, XWindowChanges* x)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XConfigureWindow,V_XConfigureWindow,_ANSI_ARGS_((Display* d, Window w,
+ unsigned int i, XWindowChanges* x)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XConfigureWindow,V_XConfigureWindow,_ANSI_ARGS_((Display* d, Window w,
+ unsigned int i, XWindowChanges* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XConfigureWindow */
+
+#ifndef XCopyArea
+#ifdef MAC_OSX_TK
+VFUNC(void,XCopyArea,V_XCopyArea,_ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XCopyArea,V_XCopyArea,_ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XCopyArea,V_XCopyArea,_ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCopyArea */
+
+#ifndef XCopyPlane
+#ifdef MAC_OSX_TK
+VFUNC(void,XCopyPlane,V_XCopyPlane,_ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4, unsigned long ul)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XCopyPlane,V_XCopyPlane,_ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4, unsigned long ul)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XCopyPlane,V_XCopyPlane,_ANSI_ARGS_((Display* d, Drawable dr1,
+ Drawable dr2, GC g, int i1, int i2,
+ unsigned int ui1, unsigned int ui2, int i3,
+ int i4, unsigned long ul)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCopyPlane */
+
+#ifndef XCreateBitmapFromData
+#ifdef MAC_OSX_TK
+VFUNC(Pixmap,XCreateBitmapFromData,V_XCreateBitmapFromData,_ANSI_ARGS_((Display* display,
+ Drawable d, _Xconst char* data,
+ unsigned int width, unsigned int height)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Pixmap,XCreateBitmapFromData,V_XCreateBitmapFromData,_ANSI_ARGS_((Display* display,
+ Drawable d, _Xconst char* data,
+ unsigned int width, unsigned int height)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Pixmap,XCreateBitmapFromData,V_XCreateBitmapFromData,_ANSI_ARGS_((Display* display,
+ Drawable d, _Xconst char* data,
+ unsigned int width, unsigned int height)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCreateBitmapFromData */
+
+#ifndef XCreateColormap
+#ifdef MAC_OSX_TK
+VFUNC(Colormap,XCreateColormap,V_XCreateColormap,_ANSI_ARGS_((Display* d, Window w,
+ Visual* v, int i)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Colormap,XCreateColormap,V_XCreateColormap,_ANSI_ARGS_((Display* d, Window w,
+ Visual* v, int i)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Colormap,XCreateColormap,V_XCreateColormap,_ANSI_ARGS_((Display* d, Window w,
+ Visual* v, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCreateColormap */
+
+#ifndef XCreateGC
+#ifdef MAC_OSX_TK
+VFUNC(GC,XCreateGC,V_XCreateGC,_ANSI_ARGS_((Display* display, Drawable d,
+ unsigned long valuemask, XGCValues* values)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(GC,XCreateGC,V_XCreateGC,_ANSI_ARGS_((Display* display, Drawable d,
+ unsigned long valuemask, XGCValues* values)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(GC,XCreateGC,V_XCreateGC,_ANSI_ARGS_((Display* display, Drawable d,
+ unsigned long valuemask, XGCValues* values)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCreateGC */
+
+#ifndef XCreateGlyphCursor
+#ifdef __WIN32__
+VFUNC(Cursor,XCreateGlyphCursor,V_XCreateGlyphCursor,_ANSI_ARGS_((Display* d, Font f1,
+ Font f2, unsigned int ui1, unsigned int ui2,
+ XColor* x1, XColor* x2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCreateGlyphCursor */
+
+#ifndef XCreateIC
+#ifdef MAC_OSX_TK
+VFUNC(XIC,XCreateIC,V_XCreateIC,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(XIC,XCreateIC,V_XCreateIC,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(XIC,XCreateIC,V_XCreateIC,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCreateIC */
+
+#ifndef XCreateImage
+#ifdef MAC_OSX_TK
+VFUNC(XImage *,XCreateImage,V_XCreateImage,_ANSI_ARGS_((Display* d, Visual* v,
+ unsigned int ui1, int i1, int i2, char* cp,
+ unsigned int ui2, unsigned int ui3, int i3,
+ int i4)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(XImage *,XCreateImage,V_XCreateImage,_ANSI_ARGS_((Display* d, Visual* v,
+ unsigned int ui1, int i1, int i2, char* cp,
+ unsigned int ui2, unsigned int ui3, int i3,
+ int i4)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(XImage *,XCreateImage,V_XCreateImage,_ANSI_ARGS_((Display* d, Visual* v,
+ unsigned int ui1, int i1, int i2, char* cp,
+ unsigned int ui2, unsigned int ui3, int i3,
+ int i4)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCreateImage */
+
+#ifndef XCreatePixmapCursor
+#ifdef __WIN32__
+VFUNC(Cursor,XCreatePixmapCursor,V_XCreatePixmapCursor,_ANSI_ARGS_((Display* d,
+ Pixmap p1, Pixmap p2, XColor* x1, XColor* x2,
+ unsigned int ui1, unsigned int ui2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XCreatePixmapCursor */
+
+#ifndef XDefineCursor
+#ifdef MAC_OSX_TK
+VFUNC(void,XDefineCursor,V_XDefineCursor,_ANSI_ARGS_((Display* d, Window w,
+ Cursor c)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDefineCursor,V_XDefineCursor,_ANSI_ARGS_((Display* d, Window w,
+ Cursor c)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XDefineCursor,V_XDefineCursor,_ANSI_ARGS_((Display* d, Window w,
+ Cursor c)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDefineCursor */
+
+#ifndef XDeleteProperty
+#ifdef __WIN32__
+VFUNC(void,XDeleteProperty,V_XDeleteProperty,_ANSI_ARGS_((Display* d, Window w,
+ Atom a)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDeleteProperty */
+
+#ifndef XDestroyIC
+#ifdef __WIN32__
+VFUNC(void,XDestroyIC,V_XDestroyIC,_ANSI_ARGS_((XIC x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDestroyIC */
+
+#ifndef XDestroyWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XDestroyWindow,V_XDestroyWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDestroyWindow,V_XDestroyWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XDestroyWindow,V_XDestroyWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDestroyWindow */
+
+#ifndef XDrawArc
+#ifdef MAC_OSX_TK
+VFUNC(void,XDrawArc,V_XDrawArc,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDrawArc,V_XDrawArc,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XDrawArc,V_XDrawArc,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDrawArc */
+
+#ifndef XDrawLine
+#ifdef MAC_OSX_TK
+VFUNC(void,XDrawLine,V_XDrawLine,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int x1, int y1, int x2, int y2)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDrawLine,V_XDrawLine,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int x1, int y1, int x2, int y2)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XDrawLine,V_XDrawLine,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int x1, int y1, int x2, int y2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDrawLine */
+
+#ifndef XDrawLines
+#ifdef MAC_OSX_TK
+VFUNC(void,XDrawLines,V_XDrawLines,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDrawLines,V_XDrawLines,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XDrawLines,V_XDrawLines,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDrawLines */
+
+#ifndef XDrawPoint
+#ifdef MAC_OSX_TK
+VFUNC(void,XDrawPoint,V_XDrawPoint,_ANSI_ARGS_((Display* display, Drawable d,
+ GC gc, int x, int y)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDrawPoint,V_XDrawPoint,_ANSI_ARGS_((Display* display, Drawable d,
+ GC gc, int x, int y)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef XDrawPoint */
+
+#ifndef XDrawPoints
+#ifdef MAC_OSX_TK
+VFUNC(void,XDrawPoints,V_XDrawPoints,_ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, XPoint * points,
+ int npoints, int mode)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDrawPoints,V_XDrawPoints,_ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, XPoint * points,
+ int npoints, int mode)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef XDrawPoints */
+
+#ifndef XDrawRectangle
+#ifdef MAC_OSX_TK
+VFUNC(void,XDrawRectangle,V_XDrawRectangle,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, int i1, int i2, unsigned int ui1,
+ unsigned int ui2)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDrawRectangle,V_XDrawRectangle,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, int i1, int i2, unsigned int ui1,
+ unsigned int ui2)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XDrawRectangle,V_XDrawRectangle,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, int i1, int i2, unsigned int ui1,
+ unsigned int ui2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XDrawRectangle */
+
+#ifndef XDrawSegments
+#ifdef MAC_OSX_TK
+VFUNC(void,XDrawSegments,V_XDrawSegments,_ANSI_ARGS_((Display * display,
+ Drawable d, GC gc, XSegment * segments,
+ int nsegments)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XDrawSegments,V_XDrawSegments,_ANSI_ARGS_((Display * display,
+ Drawable d, GC gc, XSegment * segments,
+ int nsegments)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef XDrawSegments */
+
+#ifndef XFillArc
+#ifdef MAC_OSX_TK
+VFUNC(void,XFillArc,V_XFillArc,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFillArc,V_XFillArc,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFillArc,V_XFillArc,_ANSI_ARGS_((Display* d, Drawable dr, GC g,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, int i3, int i4)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFillArc */
+
+#ifndef XFillPolygon
+#ifdef MAC_OSX_TK
+VFUNC(void,XFillPolygon,V_XFillPolygon,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2, int i3)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFillPolygon,V_XFillPolygon,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2, int i3)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFillPolygon,V_XFillPolygon,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XPoint* x, int i1, int i2, int i3)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFillPolygon */
+
+#ifndef XFillRectangle
+#ifdef MAC_OSX_TK
+VFUNC(void,XFillRectangle,V_XFillRectangle,_ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, int x, int y,
+ unsigned int width, unsigned int height)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFillRectangle,V_XFillRectangle,_ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, int x, int y,
+ unsigned int width, unsigned int height)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFillRectangle,V_XFillRectangle,_ANSI_ARGS_((Display* display,
+ Drawable d, GC gc, int x, int y,
+ unsigned int width, unsigned int height)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFillRectangle */
+
+#ifndef XFillRectangles
+#ifdef MAC_OSX_TK
+VFUNC(void,XFillRectangles,V_XFillRectangles,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XRectangle* x, int i)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFillRectangles,V_XFillRectangles,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XRectangle* x, int i)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFillRectangles,V_XFillRectangles,_ANSI_ARGS_((Display* d, Drawable dr,
+ GC g, XRectangle* x, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFillRectangles */
+
+#ifndef XFilterEvent
+#ifdef __WIN32__
+VFUNC(Bool,XFilterEvent,V_XFilterEvent,_ANSI_ARGS_((XEvent* x, Window w)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFilterEvent */
+
+#ifndef XForceScreenSaver
+#ifdef MAC_OSX_TK
+VFUNC(void,XForceScreenSaver,V_XForceScreenSaver,_ANSI_ARGS_((Display* display,
+ int mode)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XForceScreenSaver,V_XForceScreenSaver,_ANSI_ARGS_((Display* display,
+ int mode)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XForceScreenSaver,V_XForceScreenSaver,_ANSI_ARGS_((Display* d, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XForceScreenSaver */
+
+#ifndef XFreeColormap
+#ifdef MAC_OSX_TK
+VFUNC(void,XFreeColormap,V_XFreeColormap,_ANSI_ARGS_((Display* d, Colormap c)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFreeColormap,V_XFreeColormap,_ANSI_ARGS_((Display* d, Colormap c)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFreeColormap,V_XFreeColormap,_ANSI_ARGS_((Display* d, Colormap c)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFreeColormap */
+
+#ifndef XFreeColors
+#ifdef MAC_OSX_TK
+VFUNC(void,XFreeColors,V_XFreeColors,_ANSI_ARGS_((Display* d, Colormap c,
+ unsigned long* ulp, int i, unsigned long ul)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFreeColors,V_XFreeColors,_ANSI_ARGS_((Display* d, Colormap c,
+ unsigned long* ulp, int i, unsigned long ul)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFreeColors,V_XFreeColors,_ANSI_ARGS_((Display* d, Colormap c,
+ unsigned long* ulp, int i, unsigned long ul)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFreeColors */
+
+#ifndef XFreeCursor
+#ifdef __WIN32__
+VFUNC(void,XFreeCursor,V_XFreeCursor,_ANSI_ARGS_((Display* d, Cursor c)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFreeCursor */
+
+#ifndef XFreeGC
+#ifdef MAC_OSX_TK
+VFUNC(void,XFreeGC,V_XFreeGC,_ANSI_ARGS_((Display* display, GC gc)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFreeGC,V_XFreeGC,_ANSI_ARGS_((Display* display, GC gc)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFreeGC,V_XFreeGC,_ANSI_ARGS_((Display* display, GC gc)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFreeGC */
+
+#ifndef XFreeModifiermap
+#ifdef MAC_OSX_TK
+VFUNC(void,XFreeModifiermap,V_XFreeModifiermap,_ANSI_ARGS_((XModifierKeymap* x)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XFreeModifiermap,V_XFreeModifiermap,_ANSI_ARGS_((XModifierKeymap* x)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XFreeModifiermap,V_XFreeModifiermap,_ANSI_ARGS_((XModifierKeymap* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XFreeModifiermap */
+
+#ifndef XGContextFromGC
+#ifdef MAC_OSX_TK
+VFUNC(GContext,XGContextFromGC,V_XGContextFromGC,_ANSI_ARGS_((GC g)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(GContext,XGContextFromGC,V_XGContextFromGC,_ANSI_ARGS_((GC g)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(GContext,XGContextFromGC,V_XGContextFromGC,_ANSI_ARGS_((GC g)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGContextFromGC */
+
+#ifndef XGetAtomName
+#ifdef MAC_OSX_TK
+VFUNC(char *,XGetAtomName,V_XGetAtomName,_ANSI_ARGS_((Display* d, Atom a)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(char *,XGetAtomName,V_XGetAtomName,_ANSI_ARGS_((Display* d, Atom a)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(char *,XGetAtomName,V_XGetAtomName,_ANSI_ARGS_((Display* d, Atom a)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetAtomName */
+
+#ifndef XGetGeometry
+#ifdef MAC_OSX_TK
+VFUNC(Status,XGetGeometry,V_XGetGeometry,_ANSI_ARGS_((Display* d, Drawable dr,
+ Window* w, int* i1, int* i2,
+ unsigned int* ui1, unsigned int* ui2,
+ unsigned int* ui3, unsigned int* ui4)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Status,XGetGeometry,V_XGetGeometry,_ANSI_ARGS_((Display* d, Drawable dr,
+ Window* w, int* i1, int* i2,
+ unsigned int* ui1, unsigned int* ui2,
+ unsigned int* ui3, unsigned int* ui4)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Status,XGetGeometry,V_XGetGeometry,_ANSI_ARGS_((Display* d, Drawable dr,
+ Window* w, int* i1, int* i2,
+ unsigned int* ui1, unsigned int* ui2,
+ unsigned int* ui3, unsigned int* ui4)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetGeometry */
+
+#ifndef XGetImage
+#ifdef MAC_OSX_TK
+VFUNC(XImage *,XGetImage,V_XGetImage,_ANSI_ARGS_((Display* d, Drawable dr,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, unsigned long ul, int i3)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(XImage *,XGetImage,V_XGetImage,_ANSI_ARGS_((Display* d, Drawable dr,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, unsigned long ul, int i3)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(XImage *,XGetImage,V_XGetImage,_ANSI_ARGS_((Display* d, Drawable dr,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2, unsigned long ul, int i3)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetImage */
+
+#ifndef XGetInputFocus
+#ifdef __WIN32__
+VFUNC(void,XGetInputFocus,V_XGetInputFocus,_ANSI_ARGS_((Display* d, Window* w,
+ int* i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetInputFocus */
+
+#ifndef XGetModifierMapping
+#ifdef MAC_OSX_TK
+VFUNC(XModifierKeymap*,XGetModifierMapping,V_XGetModifierMapping,_ANSI_ARGS_((Display* d)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(XModifierKeymap*,XGetModifierMapping,V_XGetModifierMapping,_ANSI_ARGS_((Display* d)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(XModifierKeymap*,XGetModifierMapping,V_XGetModifierMapping,_ANSI_ARGS_((Display* d)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetModifierMapping */
+
+#ifndef XGetVisualInfo
+#ifdef MAC_OSX_TK
+VFUNC(XVisualInfo *,XGetVisualInfo,V_XGetVisualInfo,_ANSI_ARGS_((Display* display,
+ long vinfo_mask, XVisualInfo* vinfo_template,
+ int* nitems_return)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(XVisualInfo *,XGetVisualInfo,V_XGetVisualInfo,_ANSI_ARGS_((Display* display,
+ long vinfo_mask, XVisualInfo* vinfo_template,
+ int* nitems_return)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(XVisualInfo *,XGetVisualInfo,V_XGetVisualInfo,_ANSI_ARGS_((Display* display,
+ long vinfo_mask, XVisualInfo* vinfo_template,
+ int* nitems_return)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetVisualInfo */
+
+#ifndef XGetWMColormapWindows
+#ifdef __WIN32__
+VFUNC(Status,XGetWMColormapWindows,V_XGetWMColormapWindows,_ANSI_ARGS_((Display* d,
+ Window w, Window** wpp, int* ip)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetWMColormapWindows */
+
+#ifndef XGetWindowAttributes
+#ifdef __WIN32__
+VFUNC(Status,XGetWindowAttributes,V_XGetWindowAttributes,_ANSI_ARGS_((Display* d,
+ Window w, XWindowAttributes* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetWindowAttributes */
+
+#ifndef XGetWindowProperty
+#ifdef MAC_OSX_TK
+VFUNC(int,XGetWindowProperty,V_XGetWindowProperty,_ANSI_ARGS_((Display* d, Window w,
+ Atom a1, long l1, long l2, Bool b, Atom a2,
+ Atom* ap, int* ip, unsigned long* ulp1,
+ unsigned long* ulp2, unsigned char** cpp)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,XGetWindowProperty,V_XGetWindowProperty,_ANSI_ARGS_((Display* d, Window w,
+ Atom a1, long l1, long l2, Bool b, Atom a2,
+ Atom* ap, int* ip, unsigned long* ulp1,
+ unsigned long* ulp2, unsigned char** cpp)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(int,XGetWindowProperty,V_XGetWindowProperty,_ANSI_ARGS_((Display* d, Window w,
+ Atom a1, long l1, long l2, Bool b, Atom a2,
+ Atom* ap, int* ip, unsigned long* ulp1,
+ unsigned long* ulp2, unsigned char** cpp)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGetWindowProperty */
+
+#ifndef XGrabKeyboard
+#ifdef MAC_OSX_TK
+VFUNC(int,XGrabKeyboard,V_XGrabKeyboard,_ANSI_ARGS_((Display* d, Window w,
+ Bool b, int i1, int i2, Time t)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,XGrabKeyboard,V_XGrabKeyboard,_ANSI_ARGS_((Display* d, Window w,
+ Bool b, int i1, int i2, Time t)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(int,XGrabKeyboard,V_XGrabKeyboard,_ANSI_ARGS_((Display* d, Window w,
+ Bool b, int i1, int i2, Time t)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGrabKeyboard */
+
+#ifndef XGrabPointer
+#ifdef MAC_OSX_TK
+VFUNC(int,XGrabPointer,V_XGrabPointer,_ANSI_ARGS_((Display* d, Window w1,
+ Bool b, unsigned int ui, int i1, int i2,
+ Window w2, Cursor c, Time t)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,XGrabPointer,V_XGrabPointer,_ANSI_ARGS_((Display* d, Window w1,
+ Bool b, unsigned int ui, int i1, int i2,
+ Window w2, Cursor c, Time t)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(int,XGrabPointer,V_XGrabPointer,_ANSI_ARGS_((Display* d, Window w1,
+ Bool b, unsigned int ui, int i1, int i2,
+ Window w2, Cursor c, Time t)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XGrabPointer */
+
+#ifndef XIconifyWindow
+#ifdef __WIN32__
+VFUNC(Status,XIconifyWindow,V_XIconifyWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XIconifyWindow */
+
+#ifndef XInternAtom
+#ifdef MAC_OSX_TK
+VFUNC(Atom,XInternAtom,V_XInternAtom,_ANSI_ARGS_((Display* display,
+ _Xconst char* atom_name, Bool only_if_exists)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Atom,XInternAtom,V_XInternAtom,_ANSI_ARGS_((Display* display,
+ _Xconst char* atom_name, Bool only_if_exists)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Atom,XInternAtom,V_XInternAtom,_ANSI_ARGS_((Display* display,
+ _Xconst char* atom_name, Bool only_if_exists)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XInternAtom */
+
+#ifndef XKeycodeToKeysym
+#ifdef MAC_OSX_TK
+VFUNC(KeySym,XKeycodeToKeysym,V_XKeycodeToKeysym,_ANSI_ARGS_((Display* d, KeyCode k,
+ int i)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(KeySym,XKeycodeToKeysym,V_XKeycodeToKeysym,_ANSI_ARGS_((Display* d, KeyCode k,
+ int i)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(KeySym,XKeycodeToKeysym,V_XKeycodeToKeysym,_ANSI_ARGS_((Display* d,
+ unsigned int k, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XKeycodeToKeysym */
+
+#ifndef XKeysymToKeycode
+#ifdef MAC_OSX_TK
+VFUNC(KeyCode,XKeysymToKeycode,V_XKeysymToKeycode,_ANSI_ARGS_((Display* d, KeySym k)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(KeyCode,XKeysymToKeycode,V_XKeysymToKeycode,_ANSI_ARGS_((Display* d, KeySym k)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(KeyCode,XKeysymToKeycode,V_XKeysymToKeycode,_ANSI_ARGS_((Display* d, KeySym k)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XKeysymToKeycode */
+
+#ifndef XKeysymToString
+#ifdef MAC_OSX_TK
+VFUNC(char *,XKeysymToString,V_XKeysymToString,_ANSI_ARGS_((KeySym k)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(char *,XKeysymToString,V_XKeysymToString,_ANSI_ARGS_((KeySym k)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(char *,XKeysymToString,V_XKeysymToString,_ANSI_ARGS_((KeySym k)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XKeysymToString */
+
+#ifndef XListHosts
+#ifdef __WIN32__
+VFUNC(XHostAddress *,XListHosts,V_XListHosts,_ANSI_ARGS_((Display* d, int* i, Bool* b)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XListHosts */
+
+#ifndef XLookupColor
+#ifdef __WIN32__
+VFUNC(Status,XLookupColor,V_XLookupColor,_ANSI_ARGS_((Display* d, Colormap c1,
+ _Xconst char* c2, XColor* x1, XColor* x2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XLookupColor */
+
+#ifndef XMapWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XMapWindow,V_XMapWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XMapWindow,V_XMapWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XMapWindow,V_XMapWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XMapWindow */
+
+#ifndef XMoveResizeWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XMoveResizeWindow,V_XMoveResizeWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XMoveResizeWindow,V_XMoveResizeWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XMoveResizeWindow,V_XMoveResizeWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2, unsigned int ui1,
+ unsigned int ui2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XMoveResizeWindow */
+
+#ifndef XMoveWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XMoveWindow,V_XMoveWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XMoveWindow,V_XMoveWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XMoveWindow,V_XMoveWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i1, int i2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XMoveWindow */
+
+#ifndef XNextEvent
+#ifdef __WIN32__
+VFUNC(void,XNextEvent,V_XNextEvent,_ANSI_ARGS_((Display* d, XEvent* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XNextEvent */
+
+#ifndef XParseColor
+#ifdef MAC_OSX_TK
+VFUNC(Status,XParseColor,V_XParseColor,_ANSI_ARGS_((Display * display,
+ Colormap map, _Xconst char* spec,
+ XColor * colorPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Status,XParseColor,V_XParseColor,_ANSI_ARGS_((Display * display,
+ Colormap map, _Xconst char* spec,
+ XColor * colorPtr)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Status,XParseColor,V_XParseColor,_ANSI_ARGS_((Display * display,
+ Colormap map, _Xconst char* spec,
+ XColor * colorPtr)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XParseColor */
+
+#ifndef XPutBackEvent
+#ifdef __WIN32__
+VFUNC(void,XPutBackEvent,V_XPutBackEvent,_ANSI_ARGS_((Display* d, XEvent* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XPutBackEvent */
+
+#ifndef XQueryColor
+#ifdef MAC_OSX_TK
+VFUNC(void,XQueryColor,V_XQueryColor,_ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * def_in_out)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XQueryColor,V_XQueryColor,_ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * def_in_out)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef XQueryColor */
+
+#ifndef XQueryColors
+#ifdef MAC_OSX_TK
+VFUNC(void,XQueryColors,V_XQueryColors,_ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * defs_in_out,
+ int ncolors)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XQueryColors,V_XQueryColors,_ANSI_ARGS_((Display * display,
+ Colormap colormap, XColor * defs_in_out,
+ int ncolors)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XQueryColors,V_XQueryColors,_ANSI_ARGS_((Display* d, Colormap c,
+ XColor* x, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XQueryColors */
+
+#ifndef XQueryPointer
+#ifdef MAC_OSX_TK
+VFUNC(Bool,XQueryPointer,V_XQueryPointer,_ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, int* i1, int* i2,
+ int* i3, int* i4, unsigned int* ui)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Bool,XQueryPointer,V_XQueryPointer,_ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, int* i1, int* i2,
+ int* i3, int* i4, unsigned int* ui)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Bool,XQueryPointer,V_XQueryPointer,_ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, int* i1, int* i2,
+ int* i3, int* i4, unsigned int* ui)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XQueryPointer */
+
+#ifndef XQueryTree
+#ifdef MAC_OSX_TK
+VFUNC(Status,XQueryTree,V_XQueryTree,_ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, Window** w4,
+ unsigned int* ui)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Status,XQueryTree,V_XQueryTree,_ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, Window** w4,
+ unsigned int* ui)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Status,XQueryTree,V_XQueryTree,_ANSI_ARGS_((Display* d, Window w1,
+ Window* w2, Window* w3, Window** w4,
+ unsigned int* ui)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XQueryTree */
+
+#ifndef XRaiseWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XRaiseWindow,V_XRaiseWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XRaiseWindow,V_XRaiseWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XRaiseWindow,V_XRaiseWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XRaiseWindow */
+
+#ifndef XRefreshKeyboardMapping
+#ifdef MAC_OSX_TK
+VFUNC(void,XRefreshKeyboardMapping,V_XRefreshKeyboardMapping,_ANSI_ARGS_((
+ XMappingEvent* x)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XRefreshKeyboardMapping,V_XRefreshKeyboardMapping,_ANSI_ARGS_((
+ XMappingEvent* x)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XRefreshKeyboardMapping,V_XRefreshKeyboardMapping,_ANSI_ARGS_((
+ XMappingEvent* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XRefreshKeyboardMapping */
+
+#ifndef XResizeWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XResizeWindow,V_XResizeWindow,_ANSI_ARGS_((Display* d, Window w,
+ unsigned int ui1, unsigned int ui2)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XResizeWindow,V_XResizeWindow,_ANSI_ARGS_((Display* d, Window w,
+ unsigned int ui1, unsigned int ui2)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XResizeWindow,V_XResizeWindow,_ANSI_ARGS_((Display* d, Window w,
+ unsigned int ui1, unsigned int ui2)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XResizeWindow */
+
+#ifndef XRootWindow
+#ifdef MAC_OSX_TK
+VFUNC(Window,XRootWindow,V_XRootWindow,_ANSI_ARGS_((Display* d, int i)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Window,XRootWindow,V_XRootWindow,_ANSI_ARGS_((Display* d, int i)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Window,XRootWindow,V_XRootWindow,_ANSI_ARGS_((Display* d, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XRootWindow */
+
+#ifndef XSelectInput
+#ifdef MAC_OSX_TK
+VFUNC(void,XSelectInput,V_XSelectInput,_ANSI_ARGS_((Display* d, Window w,
+ long l)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSelectInput,V_XSelectInput,_ANSI_ARGS_((Display* d, Window w,
+ long l)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSelectInput,V_XSelectInput,_ANSI_ARGS_((Display* d, Window w,
+ long l)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSelectInput */
+
+#ifndef XSendEvent
+#ifdef MAC_OSX_TK
+VFUNC(Status,XSendEvent,V_XSendEvent,_ANSI_ARGS_((Display* d, Window w, Bool b,
+ long l, XEvent* x)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Status,XSendEvent,V_XSendEvent,_ANSI_ARGS_((Display* d, Window w, Bool b,
+ long l, XEvent* x)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Status,XSendEvent,V_XSendEvent,_ANSI_ARGS_((Display* d, Window w, Bool b,
+ long l, XEvent* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSendEvent */
+
+#ifndef XSetArcMode
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetArcMode,V_XSetArcMode,_ANSI_ARGS_((Display * display, GC gc,
+ int arc_mode)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetArcMode,V_XSetArcMode,_ANSI_ARGS_((Display * display, GC gc,
+ int arc_mode)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetArcMode,V_XSetArcMode,_ANSI_ARGS_((Display * display, GC gc,
+ int arc_mode)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetArcMode */
+
+#ifndef XSetBackground
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetBackground,V_XSetBackground,_ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetBackground,V_XSetBackground,_ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetBackground,V_XSetBackground,_ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetBackground */
+
+#ifndef XSetClipMask
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetClipMask,V_XSetClipMask,_ANSI_ARGS_((Display* display, GC gc,
+ Pixmap pixmap)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetClipMask,V_XSetClipMask,_ANSI_ARGS_((Display* display, GC gc,
+ Pixmap pixmap)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetClipMask,V_XSetClipMask,_ANSI_ARGS_((Display* display, GC gc,
+ Pixmap pixmap)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetClipMask */
+
+#ifndef XSetClipOrigin
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetClipOrigin,V_XSetClipOrigin,_ANSI_ARGS_((Display* display, GC gc,
+ int clip_x_origin, int clip_y_origin)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetClipOrigin,V_XSetClipOrigin,_ANSI_ARGS_((Display* display, GC gc,
+ int clip_x_origin, int clip_y_origin)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetClipOrigin,V_XSetClipOrigin,_ANSI_ARGS_((Display* display, GC gc,
+ int clip_x_origin, int clip_y_origin)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetClipOrigin */
+
+#ifndef XSetCommand
+#ifdef __WIN32__
+VFUNC(void,XSetCommand,V_XSetCommand,_ANSI_ARGS_((Display* d, Window w,
+ CONST char** c, int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetCommand */
+
+#ifndef XSetDashes
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetDashes,V_XSetDashes,_ANSI_ARGS_((Display* display, GC gc,
+ int dash_offset, _Xconst char* dash_list,
+ int n)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetDashes,V_XSetDashes,_ANSI_ARGS_((Display* display, GC gc,
+ int dash_offset, _Xconst char* dash_list,
+ int n)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetDashes,V_XSetDashes,_ANSI_ARGS_((Display* display, GC gc,
+ int dash_offset, _Xconst char* dash_list,
+ int n)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetDashes */
+
+#ifndef XSetErrorHandler
+#ifdef MAC_OSX_TK
+VFUNC(XErrorHandler,XSetErrorHandler,V_XSetErrorHandler,_ANSI_ARGS_((XErrorHandler x)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(XErrorHandler,XSetErrorHandler,V_XSetErrorHandler,_ANSI_ARGS_((XErrorHandler x)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(XErrorHandler,XSetErrorHandler,V_XSetErrorHandler,_ANSI_ARGS_((XErrorHandler x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetErrorHandler */
+
+#ifndef XSetFillRule
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetFillRule,V_XSetFillRule,_ANSI_ARGS_((Display * display, GC gc,
+ int fill_rule)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetFillRule,V_XSetFillRule,_ANSI_ARGS_((Display * display, GC gc,
+ int fill_rule)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetFillRule,V_XSetFillRule,_ANSI_ARGS_((Display * display, GC gc,
+ int fill_rule)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetFillRule */
+
+#ifndef XSetFillStyle
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetFillStyle,V_XSetFillStyle,_ANSI_ARGS_((Display * display, GC gc,
+ int fill_style)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetFillStyle,V_XSetFillStyle,_ANSI_ARGS_((Display * display, GC gc,
+ int fill_style)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetFillStyle,V_XSetFillStyle,_ANSI_ARGS_((Display * display, GC gc,
+ int fill_style)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetFillStyle */
+
+#ifndef XSetFont
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetFont,V_XSetFont,_ANSI_ARGS_((Display * display, GC gc,
+ Font font)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetFont,V_XSetFont,_ANSI_ARGS_((Display * display, GC gc,
+ Font font)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetFont,V_XSetFont,_ANSI_ARGS_((Display * display, GC gc,
+ Font font)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetFont */
+
+#ifndef XSetForeground
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetForeground,V_XSetForeground,_ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetForeground,V_XSetForeground,_ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetForeground,V_XSetForeground,_ANSI_ARGS_((Display* display, GC gc,
+ unsigned long foreground)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetForeground */
+
+#ifndef XSetFunction
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetFunction,V_XSetFunction,_ANSI_ARGS_((Display * display, GC gc,
+ int function)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetFunction,V_XSetFunction,_ANSI_ARGS_((Display * display, GC gc,
+ int function)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetFunction,V_XSetFunction,_ANSI_ARGS_((Display * display, GC gc,
+ int function)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetFunction */
+
+#ifndef XSetIconName
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetIconName,V_XSetIconName,_ANSI_ARGS_((Display* d, Window w,
+ _Xconst char* c)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetIconName,V_XSetIconName,_ANSI_ARGS_((Display* d, Window w,
+ _Xconst char* c)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetIconName,V_XSetIconName,_ANSI_ARGS_((Display* d, Window w,
+ _Xconst char* c)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetIconName */
+
+#ifndef XSetInputFocus
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetInputFocus,V_XSetInputFocus,_ANSI_ARGS_((Display* d, Window w,
+ int i, Time t)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetInputFocus,V_XSetInputFocus,_ANSI_ARGS_((Display* d, Window w,
+ int i, Time t)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetInputFocus,V_XSetInputFocus,_ANSI_ARGS_((Display* d, Window w,
+ int i, Time t)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetInputFocus */
+
+#ifndef XSetLineAttributes
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetLineAttributes,V_XSetLineAttributes,_ANSI_ARGS_((Display * display,
+ GC gc, unsigned int line_width,
+ int line_style, int cap_style,
+ int join_style)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetLineAttributes,V_XSetLineAttributes,_ANSI_ARGS_((Display * display,
+ GC gc, unsigned int line_width,
+ int line_style, int cap_style,
+ int join_style)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetLineAttributes,V_XSetLineAttributes,_ANSI_ARGS_((Display * display,
+ GC gc, unsigned int line_width,
+ int line_style, int cap_style,
+ int join_style)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetLineAttributes */
+
+#ifndef XSetSelectionOwner
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetSelectionOwner,V_XSetSelectionOwner,_ANSI_ARGS_((Display* d, Atom a,
+ Window w, Time t)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetSelectionOwner,V_XSetSelectionOwner,_ANSI_ARGS_((Display* d, Atom a,
+ Window w, Time t)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetSelectionOwner,V_XSetSelectionOwner,_ANSI_ARGS_((Display* d, Atom a,
+ Window w, Time t)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetSelectionOwner */
+
+#ifndef XSetStipple
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetStipple,V_XSetStipple,_ANSI_ARGS_((Display * display, GC gc,
+ Pixmap stipple)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetStipple,V_XSetStipple,_ANSI_ARGS_((Display * display, GC gc,
+ Pixmap stipple)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetStipple,V_XSetStipple,_ANSI_ARGS_((Display * display, GC gc,
+ Pixmap stipple)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetStipple */
+
+#ifndef XSetTSOrigin
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetTSOrigin,V_XSetTSOrigin,_ANSI_ARGS_((Display* display, GC gc,
+ int ts_x_origin, int ts_y_origin)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetTSOrigin,V_XSetTSOrigin,_ANSI_ARGS_((Display* display, GC gc,
+ int ts_x_origin, int ts_y_origin)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetTSOrigin,V_XSetTSOrigin,_ANSI_ARGS_((Display* display, GC gc,
+ int ts_x_origin, int ts_y_origin)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetTSOrigin */
+
+#ifndef XSetWMClientMachine
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetWMClientMachine,V_XSetWMClientMachine,_ANSI_ARGS_((Display* display,
+ Window w, XTextProperty* text_prop)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetWMClientMachine,V_XSetWMClientMachine,_ANSI_ARGS_((Display* display,
+ Window w, XTextProperty* text_prop)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetWMClientMachine,V_XSetWMClientMachine,_ANSI_ARGS_((Display* display,
+ Window w, XTextProperty* text_prop)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetWMClientMachine */
+
+#ifndef XSetWindowBackground
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetWindowBackground,V_XSetWindowBackground,_ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetWindowBackground,V_XSetWindowBackground,_ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetWindowBackground,V_XSetWindowBackground,_ANSI_ARGS_((Display* d,
+ Window w, unsigned long ul)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetWindowBackground */
+
+#ifndef XSetWindowBackgroundPixmap
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetWindowBackgroundPixmap,V_XSetWindowBackgroundPixmap,_ANSI_ARGS_((Display* d,
+ Window w, Pixmap p)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetWindowBackgroundPixmap,V_XSetWindowBackgroundPixmap,_ANSI_ARGS_((Display* d,
+ Window w, Pixmap p)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetWindowBackgroundPixmap,V_XSetWindowBackgroundPixmap,_ANSI_ARGS_((Display* d,
+ Window w, Pixmap p)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetWindowBackgroundPixmap */
+
+#ifndef XSetWindowBorder
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetWindowBorder,V_XSetWindowBorder,_ANSI_ARGS_((Display* d, Window w,
+ unsigned long ul)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetWindowBorder,V_XSetWindowBorder,_ANSI_ARGS_((Display* d, Window w,
+ unsigned long ul)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetWindowBorder,V_XSetWindowBorder,_ANSI_ARGS_((Display* d, Window w,
+ unsigned long ul)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetWindowBorder */
+
+#ifndef XSetWindowBorderPixmap
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetWindowBorderPixmap,V_XSetWindowBorderPixmap,_ANSI_ARGS_((Display* d,
+ Window w, Pixmap p)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetWindowBorderPixmap,V_XSetWindowBorderPixmap,_ANSI_ARGS_((Display* d,
+ Window w, Pixmap p)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetWindowBorderPixmap,V_XSetWindowBorderPixmap,_ANSI_ARGS_((Display* d,
+ Window w, Pixmap p)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetWindowBorderPixmap */
+
+#ifndef XSetWindowBorderWidth
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetWindowBorderWidth,V_XSetWindowBorderWidth,_ANSI_ARGS_((Display* d,
+ Window w, unsigned int ui)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetWindowBorderWidth,V_XSetWindowBorderWidth,_ANSI_ARGS_((Display* d,
+ Window w, unsigned int ui)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetWindowBorderWidth,V_XSetWindowBorderWidth,_ANSI_ARGS_((Display* d,
+ Window w, unsigned int ui)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetWindowBorderWidth */
+
+#ifndef XSetWindowColormap
+#ifdef MAC_OSX_TK
+VFUNC(void,XSetWindowColormap,V_XSetWindowColormap,_ANSI_ARGS_((Display* d, Window w,
+ Colormap c)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XSetWindowColormap,V_XSetWindowColormap,_ANSI_ARGS_((Display* d, Window w,
+ Colormap c)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XSetWindowColormap,V_XSetWindowColormap,_ANSI_ARGS_((Display* d, Window w,
+ Colormap c)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XSetWindowColormap */
+
+#ifndef XStringListToTextProperty
+#ifdef MAC_OSX_TK
+VFUNC(Status,XStringListToTextProperty,V_XStringListToTextProperty,_ANSI_ARGS_((char** list,
+ int count, XTextProperty* text_prop_return)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(Status,XStringListToTextProperty,V_XStringListToTextProperty,_ANSI_ARGS_((char** list,
+ int count, XTextProperty* text_prop_return)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(Status,XStringListToTextProperty,V_XStringListToTextProperty,_ANSI_ARGS_((char** list,
+ int count, XTextProperty* text_prop_return)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XStringListToTextProperty */
+
+#ifndef XStringToKeysym
+#ifdef MAC_OSX_TK
+VFUNC(KeySym,XStringToKeysym,V_XStringToKeysym,_ANSI_ARGS_((_Xconst char* c)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(KeySym,XStringToKeysym,V_XStringToKeysym,_ANSI_ARGS_((_Xconst char* c)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(KeySym,XStringToKeysym,V_XStringToKeysym,_ANSI_ARGS_((_Xconst char* c)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XStringToKeysym */
+
+#ifndef XTranslateCoordinates
+#ifdef __WIN32__
+VFUNC(Bool,XTranslateCoordinates,V_XTranslateCoordinates,_ANSI_ARGS_((Display* d,
+ Window w1, Window w2, int i1, int i2,
+ int* i3, int* i4, Window* w3)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XTranslateCoordinates */
+
+#ifndef XUngrabKeyboard
+#ifdef MAC_OSX_TK
+VFUNC(void,XUngrabKeyboard,V_XUngrabKeyboard,_ANSI_ARGS_((Display* d, Time t)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XUngrabKeyboard,V_XUngrabKeyboard,_ANSI_ARGS_((Display* d, Time t)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XUngrabKeyboard,V_XUngrabKeyboard,_ANSI_ARGS_((Display* d, Time t)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XUngrabKeyboard */
+
+#ifndef XUngrabPointer
+#ifdef MAC_OSX_TK
+VFUNC(void,XUngrabPointer,V_XUngrabPointer,_ANSI_ARGS_((Display* d, Time t)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XUngrabPointer,V_XUngrabPointer,_ANSI_ARGS_((Display* d, Time t)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XUngrabPointer,V_XUngrabPointer,_ANSI_ARGS_((Display* d, Time t)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XUngrabPointer */
+
+#ifndef XUnmapWindow
+#ifdef MAC_OSX_TK
+VFUNC(void,XUnmapWindow,V_XUnmapWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XUnmapWindow,V_XUnmapWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XUnmapWindow,V_XUnmapWindow,_ANSI_ARGS_((Display* d, Window w)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XUnmapWindow */
+
+#ifndef XWarpPointer
+#ifdef MAC_OSX_TK
+VFUNC(void,XWarpPointer,V_XWarpPointer,_ANSI_ARGS_((Display* display,
+ Window src_w, Window dest_w, int src_x,
+ int src_y, unsigned int src_width,
+ unsigned int src_height, int dest_x,
+ int dest_y)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,XWarpPointer,V_XWarpPointer,_ANSI_ARGS_((Display* display,
+ Window src_w, Window dest_w, int src_x,
+ int src_y, unsigned int src_width,
+ unsigned int src_height, int dest_x,
+ int dest_y)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(void,XWarpPointer,V_XWarpPointer,_ANSI_ARGS_((Display* d, Window s,
+ Window dw, int sx, int sy, unsigned int sw,
+ unsigned int sh, int dx, int dy)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XWarpPointer */
+
+#ifndef XWindowEvent
+#ifdef __WIN32__
+VFUNC(void,XWindowEvent,V_XWindowEvent,_ANSI_ARGS_((Display* d, Window w,
+ long l, XEvent* x)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XWindowEvent */
+
+#ifndef XWithdrawWindow
+#ifdef __WIN32__
+VFUNC(Status,XWithdrawWindow,V_XWithdrawWindow,_ANSI_ARGS_((Display* d, Window w,
+ int i)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XWithdrawWindow */
+
+#ifndef XmbLookupString
+#ifdef __WIN32__
+VFUNC(int,XmbLookupString,V_XmbLookupString,_ANSI_ARGS_((XIC xi,
+ XKeyPressedEvent* xk, char* c, int i,
+ KeySym* k, Status* s)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef XmbLookupString */
+
+#ifndef _XInitImageFuncPtrs
+#ifdef MAC_OSX_TK
+VFUNC(int,_XInitImageFuncPtrs,V__XInitImageFuncPtrs,_ANSI_ARGS_((XImage * image)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(int,_XInitImageFuncPtrs,V__XInitImageFuncPtrs,_ANSI_ARGS_((XImage * image)))
+#endif /* #ifdef MAC_TCL */
+#ifdef __WIN32__
+VFUNC(int,_XInitImageFuncPtrs,V__XInitImageFuncPtrs,_ANSI_ARGS_((XImage * image)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef _XInitImageFuncPtrs */
+
+#endif /* _TKINTXLIBDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls_f.h
new file mode 100755
index 00000000000..cf6fe23a3eb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkIntXlibDecls_f.h
@@ -0,0 +1,14 @@
+#ifndef TKINTXLIBDECLS_VT
+#define TKINTXLIBDECLS_VT
+typedef struct TkintxlibdeclsVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkIntXlibDecls.t"
+#undef VFUNC
+#undef VVAR
+} TkintxlibdeclsVtab;
+extern TkintxlibdeclsVtab *TkintxlibdeclsVptr;
+extern TkintxlibdeclsVtab *TkintxlibdeclsVGet(void);
+#endif /* TKINTXLIBDECLS_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt_f.h
new file mode 100755
index 00000000000..b8da3f6470e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkInt_f.h
@@ -0,0 +1,14 @@
+#ifndef TKINT_VT
+#define TKINT_VT
+typedef struct TkintVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkInt.t"
+#undef VFUNC
+#undef VVAR
+} TkintVtab;
+extern TkintVtab *TkintVptr;
+extern TkintVtab *TkintVGet(void);
+#endif /* TKINT_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenu.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenu.h
new file mode 100755
index 00000000000..0b341acd87b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenu.h
@@ -0,0 +1,588 @@
+/*
+ * tkMenu.h --
+ *
+ * Declarations shared among all of the files that implement menu widgets.
+ *
+ * Copyright (c) 1996-1998 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkMenu.h,v 1.6.4.1 2003/07/15 13:59:06 vincentdarley Exp $
+ */
+
+#ifndef _TKMENU
+#define _TKMENU
+
+#ifndef _TK
+#include "tk.h"
+#endif
+
+#ifndef _TKINT
+#include "tkInt.h"
+#endif
+
+#ifndef _DEFAULT
+#include "default.h"
+#endif
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Dummy types used by the platform menu code.
+ */
+
+typedef struct TkMenuPlatformData_ *TkMenuPlatformData;
+typedef struct TkMenuPlatformEntryData_ *TkMenuPlatformEntryData;
+
+/*
+ * Legal values for the "compound" field of TkMenuEntry and TkMenuButton records.
+ */
+
+enum compound {
+ COMPOUND_BOTTOM, COMPOUND_CENTER, COMPOUND_LEFT, COMPOUND_NONE,
+ COMPOUND_RIGHT, COMPOUND_TOP
+};
+
+/*
+ * One of the following data structures is kept for each entry of each
+ * menu managed by this file:
+ */
+
+typedef struct TkMenuEntry {
+ int type; /* Type of menu entry; see below for
+ * valid types. */
+ struct TkMenu *menuPtr; /* Menu with which this entry is associated. */
+ Tk_OptionTable optionTable; /* Option table for this menu entry. */
+ Tcl_Obj *labelPtr; /* Main text label displayed in entry (NULL
+ * if no label). */
+ int labelLength; /* Number of non-NULL characters in label. */
+ int state; /* State of button for display purposes:
+ * normal, active, or disabled. */
+ int underline; /* Value of -underline option: specifies index
+ * of character to underline (<0 means don't
+ * underline anything). */
+ Tcl_Obj *underlinePtr; /* Index of character to underline. */
+ Tcl_Obj *bitmapPtr; /* Bitmap to display in menu entry, or None.
+ * If not None then label is ignored. */
+ Tcl_Obj *imagePtr; /* Name of image to display, or
+ * NULL. If non-NULL, bitmap, text, and
+ * textVarName are ignored. */
+ Tk_Image image; /* Image to display in menu entry, or NULL if
+ * none. */
+ Tcl_Obj *selectImagePtr; /* Name of image to display when selected, or
+ * NULL. */
+ Tk_Image selectImage; /* Image to display in entry when selected,
+ * or NULL if none. Ignored if image is
+ * NULL. */
+ Tcl_Obj *accelPtr; /* Accelerator string displayed at right
+ * of menu entry. NULL means no such
+ * accelerator. Malloc'ed. */
+ int accelLength; /* Number of non-NULL characters in
+ * accelerator. */
+ int indicatorOn; /* True means draw indicator, false means
+ * don't draw it. This field is ignored unless
+ * the entry is a radio or check button. */
+ /*
+ * Display attributes
+ */
+
+ Tcl_Obj *borderPtr; /* Structure used to draw background for
+ * entry. NULL means use overall border
+ * for menu. */
+ Tcl_Obj *fgPtr; /* Foreground color to use for entry. NULL
+ * means use foreground color from menu. */
+ Tcl_Obj *activeBorderPtr; /* Used to draw background and border when
+ * element is active. NULL means use
+ * activeBorder from menu. */
+ Tcl_Obj *activeFgPtr; /* Foreground color to use when entry is
+ * active. NULL means use active foreground
+ * from menu. */
+ Tcl_Obj *indicatorFgPtr; /* Color for indicators in radio and check
+ * button entries. NULL means use indicatorFg
+ * GC from menu. */
+ Tcl_Obj *fontPtr; /* Text font for menu entries. NULL means
+ * use overall font for menu. */
+ int columnBreak; /* If this is 0, this item appears below
+ * the item in front of it. If this is
+ * 1, this item starts a new column. This
+ * field is always 0 for tearoff and separator
+ * entries. */
+ int hideMargin; /* If this is 0, then the item has enough
+ * margin to accomodate a standard check mark
+ * and a default right margin. If this is 1,
+ * then the item has no such margins. and
+ * checkbuttons and radiobuttons with this set
+ * will have a rectangle drawn in the indicator
+ * around the item if the item is checked. This
+ * is useful for palette menus. This field is
+ * ignored for separators and tearoffs. */
+ int indicatorSpace; /* The width of the indicator space for this
+ * entry. */
+ int labelWidth; /* Number of pixels to allow for displaying
+ * labels in menu entries. */
+ int compound; /* Value of -compound option; specifies whether
+ * the entry should show both an image and
+ * text, and, if so, how. */
+
+ /*
+ * Information used to implement this entry's action:
+ */
+
+ Tcl_Obj *commandPtr; /* Command to invoke when entry is invoked.
+ * Malloc'ed. */
+ Tcl_Obj *namePtr; /* Name of variable (for check buttons and
+ * radio buttons) or menu (for cascade
+ * entries). Malloc'ed.*/
+ Tcl_Obj *onValuePtr; /* Value to store in variable when selected
+ * (only for radio and check buttons).
+ * Malloc'ed. */
+ Tcl_Obj *offValuePtr; /* Value to store in variable when not
+ * selected (only for check buttons).
+ * Malloc'ed. */
+
+ /*
+ * Information used for drawing this menu entry.
+ */
+
+ int width; /* Number of pixels occupied by entry in
+ * horizontal dimension. Not used except
+ * in menubars. The width of norma menus
+ * is dependent on the rest of the menu. */
+ int x; /* X-coordinate of leftmost pixel in entry */
+ int height; /* Number of pixels occupied by entry in
+ * vertical dimension, including raised
+ * border drawn around entry when active. */
+ int y; /* Y-coordinate of topmost pixel in entry. */
+ GC textGC; /* GC for drawing text in entry. NULL means
+ * use overall textGC for menu. */
+ GC activeGC; /* GC for drawing text in entry when active.
+ * NULL means use overall activeGC for
+ * menu. */
+ GC disabledGC; /* Used to produce disabled effect for entry.
+ * NULL means use overall disabledGC from
+ * menu structure. See comments for
+ * disabledFg in menu structure for more
+ * information. */
+ GC indicatorGC; /* For drawing indicators. None means use
+ * GC from menu. */
+
+ /*
+ * Miscellaneous fields.
+ */
+
+ int entryFlags; /* Various flags. See below for
+ definitions. */
+ int index; /* Need to know which index we are. This
+ * is zero-based. This is the top-left entry
+ * of the menu. */
+
+ /*
+ * Bookeeping for master menus and cascade menus.
+ */
+
+ struct TkMenuReferences *childMenuRefPtr;
+ /* A pointer to the hash table entry for
+ * the child menu. Stored here when the menu
+ * entry is configured so that a hash lookup
+ * is not necessary later.*/
+ struct TkMenuEntry *nextCascadePtr;
+ /* The next cascade entry that is a parent of
+ * this entry's child cascade menu. NULL
+ * end of list, this is not a cascade entry,
+ * or the menu that this entry point to
+ * does not yet exist. */
+ TkMenuPlatformEntryData platformEntryData;
+ /* The data for the specific type of menu.
+ * Depends on platform and menu type what
+ * kind of options are in this structure.
+ */
+} TkMenuEntry;
+
+/*
+ * Flag values defined for menu entries:
+ *
+ * ENTRY_SELECTED: Non-zero means this is a radio or check
+ * button and that it should be drawn in
+ * the "selected" state.
+ * ENTRY_NEEDS_REDISPLAY: Non-zero means the entry should be redisplayed.
+ * ENTRY_LAST_COLUMN: Used by the drawing code. If the entry is in
+ * the last column, the space to its right needs
+ * to be filled.
+ * ENTRY_PLATFORM_FLAG1 - 4 These flags are reserved for use by the
+ * platform-dependent implementation of menus
+ * and should not be used by anything else.
+ */
+
+#define ENTRY_SELECTED 1
+#define ENTRY_NEEDS_REDISPLAY 2
+#define ENTRY_LAST_COLUMN 4
+#define ENTRY_PLATFORM_FLAG1 (1 << 30)
+#define ENTRY_PLATFORM_FLAG2 (1 << 29)
+#define ENTRY_PLATFORM_FLAG3 (1 << 28)
+#define ENTRY_PLATFORM_FLAG4 (1 << 27)
+
+/*
+ * Types defined for MenuEntries:
+ */
+
+#define CASCADE_ENTRY 0
+#define CHECK_BUTTON_ENTRY 1
+#define COMMAND_ENTRY 2
+#define RADIO_BUTTON_ENTRY 3
+#define SEPARATOR_ENTRY 4
+#define TEAROFF_ENTRY 5
+
+/*
+ * Menu states
+ */
+
+EXTERN char *tkMenuStateStrings[];
+
+#define ENTRY_ACTIVE 0
+#define ENTRY_NORMAL 1
+#define ENTRY_DISABLED 2
+
+/*
+ * A data structure of the following type is kept for each
+ * menu widget:
+ */
+
+typedef struct TkMenu {
+ Tk_Window tkwin; /* Window that embodies the pane. NULL
+ * means that the window has been destroyed
+ * but the data structures haven't yet been
+ * cleaned up.*/
+ Display *display; /* Display containing widget. Needed, among
+ * other things, so that resources can be
+ * freed up even after tkwin has gone away. */
+ Tcl_Interp *interp; /* Interpreter associated with menu. */
+ Tcl_Command widgetCmd; /* Token for menu's widget command. */
+ TkMenuEntry **entries; /* Array of pointers to all the entries
+ * in the menu. NULL means no entries. */
+ int numEntries; /* Number of elements in entries. */
+ int active; /* Index of active entry. -1 means
+ * nothing active. */
+ int menuType; /* MASTER_MENU, TEAROFF_MENU, or MENUBAR.
+ * See below for definitions. */
+ Tcl_Obj *menuTypePtr; /* Used to control whether created tkwin
+ * is a toplevel or not. "normal", "menubar",
+ * or "toplevel" */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ Tcl_Obj *borderPtr; /* Structure used to draw 3-D
+ * border and background for menu. */
+ Tcl_Obj *borderWidthPtr; /* Width of border around whole menu. */
+ Tcl_Obj *activeBorderPtr; /* Used to draw background and border for
+ * active element (if any). */
+ Tcl_Obj *activeBorderWidthPtr;
+ /* Width of border around active element. */
+ Tcl_Obj *reliefPtr; /* 3-d effect: TK_RELIEF_RAISED, etc. */
+ Tcl_Obj *fontPtr; /* Text font for menu entries. */
+ Tcl_Obj *fgPtr; /* Foreground color for entries. */
+ Tcl_Obj *disabledFgPtr; /* Foreground color when disabled. NULL
+ * means use normalFg with a 50% stipple
+ * instead. */
+ Tcl_Obj *activeFgPtr; /* Foreground color for active entry. */
+ Tcl_Obj *indicatorFgPtr; /* Color for indicators in radio and check
+ * button entries. */
+ Pixmap gray; /* Bitmap for drawing disabled entries in
+ * a stippled fashion. None means not
+ * allocated yet. */
+ GC textGC; /* GC for drawing text and other features
+ * of menu entries. */
+ GC disabledGC; /* Used to produce disabled effect. If
+ * disabledFg isn't NULL, this GC is used to
+ * draw text and icons for disabled entries.
+ * Otherwise text and icons are drawn with
+ * normalGC and this GC is used to stipple
+ * background across them. */
+ GC activeGC; /* GC for drawing active entry. */
+ GC indicatorGC; /* For drawing indicators. */
+ GC disabledImageGC; /* Used for drawing disabled images. They
+ * have to be stippled. This is created
+ * when the image is about to be drawn the
+ * first time. */
+
+ /*
+ * Information about geometry of menu.
+ */
+
+ int totalWidth; /* Width of entire menu */
+ int totalHeight; /* Height of entire menu */
+
+ /*
+ * Miscellaneous information:
+ */
+
+ int tearoff; /* 1 means this menu can be torn off. On some
+ * platforms, the user can drag an outline
+ * of the menu by just dragging outside of
+ * the menu, and the tearoff is created where
+ * the mouse is released. On others, an
+ * indicator (such as a dashed stripe) is
+ * drawn, and when the menu is selected, the
+ * tearoff is created. */
+ Tcl_Obj *titlePtr; /* The title to use when this menu is torn
+ * off. If this is NULL, a default scheme
+ * will be used to generate a title for
+ * tearoff. */
+ Tcl_Obj *tearoffCommandPtr; /* If non-NULL, points to a command to
+ * run whenever the menu is torn-off. */
+ Tcl_Obj *takeFocusPtr; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+ Tcl_Obj *cursorPtr; /* Current cursor for window, or None. */
+ Tcl_Obj *postCommandPtr; /* Used to detect cycles in cascade hierarchy
+ * trees when preprocessing postcommands
+ * on some platforms. See PostMenu for
+ * more details. */
+ int postCommandGeneration; /* Need to do pre-invocation post command
+ * traversal */
+ int menuFlags; /* Flags for use by X; see below for
+ definition */
+ TkMenuEntry *postedCascade; /* Points to menu entry for cascaded submenu
+ * that is currently posted or NULL if no
+ * submenu posted. */
+ struct TkMenu *nextInstancePtr;
+ /* The next instance of this menu in the
+ * chain. */
+ struct TkMenu *masterMenuPtr;
+ /* A pointer to the original menu for this
+ * clone chain. Points back to this structure
+ * if this menu is a master menu. */
+ struct TkMenuOptionTables *optionTablesPtr;
+ /* A pointer to the collection of option tables
+ * that work with menus and menu entries. */
+ Tk_Window parentTopLevelPtr;/* If this menu is a menubar, this is the
+ * toplevel that owns the menu. Only applicable
+ * for menubar clones.
+ */
+ struct TkMenuReferences *menuRefPtr;
+ /* Each menu is hashed into a table with the
+ * name of the menu's window as the key.
+ * The information in this hash table includes
+ * a pointer to the menu (so that cascades
+ * can find this menu), a pointer to the
+ * list of toplevel widgets that have this
+ * menu as its menubar, and a list of menu
+ * entries that have this menu specified
+ * as a cascade. */
+ TkMenuPlatformData platformData;
+ /* The data for the specific type of menu.
+ * Depends on platform and menu type what
+ * kind of options are in this structure.
+ */
+ Tk_OptionSpec *extensionPtr;
+ /* Needed by the configuration package for
+ * this widget to be extended. */
+ Tk_SavedOptions *errorStructPtr;
+ /* We actually have to allocate these because
+ * multiple menus get changed during one
+ * ConfigureMenu call. */
+} TkMenu;
+
+/*
+ * When the toplevel configure -menu command is executed, the menu may not
+ * exist yet. We need to keep a linked list of windows that reference
+ * a particular menu.
+ */
+
+typedef struct TkMenuTopLevelList {
+ struct TkMenuTopLevelList *nextPtr;
+ /* The next window in the list */
+ Tk_Window tkwin; /* The window that has this menu as its
+ * menubar. */
+} TkMenuTopLevelList;
+
+/*
+ * The following structure is used to keep track of things which
+ * reference a menu. It is created when:
+ * - a menu is created.
+ * - a cascade entry is added to a menu with a non-null name
+ * - the "-menu" configuration option is used on a toplevel widget
+ * with a non-null parameter.
+ *
+ * One of these three fields must be non-NULL, but any of the fields may
+ * be NULL. This structure makes it easy to determine whether or not
+ * anything like recalculating platform data or geometry is necessary
+ * when one of the three actions above is performed.
+ */
+
+typedef struct TkMenuReferences {
+ struct TkMenu *menuPtr; /* The menu data structure. This is NULL
+ * if the menu does not exist. */
+ TkMenuTopLevelList *topLevelListPtr;
+ /* First in the list of all toplevels that
+ * have this menu as its menubar. NULL if no
+ * toplevel widgets have this menu as its
+ * menubar. */
+ TkMenuEntry *parentEntryPtr;/* First in the list of all cascade menu
+ * entries that have this menu as their child.
+ * NULL means no cascade entries. */
+ Tcl_HashEntry *hashEntryPtr;/* This is needed because the pathname of the
+ * window (which is what we hash on) may not
+ * be around when we are deleting.
+ */
+} TkMenuReferences;
+
+/*
+ * This structure contains all of the option tables that are needed
+ * by menus.
+ */
+
+typedef struct TkMenuOptionTables {
+ Tk_OptionTable menuOptionTable; /* The option table for menus. */
+ Tk_OptionTable entryOptionTables[6];/* The tables for menu entries. */
+} TkMenuOptionTables;
+
+/*
+ * Flag bits for menus:
+ *
+ * REDRAW_PENDING: Non-zero means a DoWhenIdle handler
+ * has already been queued to redraw
+ * this window.
+ * RESIZE_PENDING: Non-zero means a call to ComputeMenuGeometry
+ * has already been scheduled.
+ * MENU_DELETION_PENDING Non-zero means that we are currently destroying
+ * this menu's internal structures. This is useful
+ * when we are in the middle of cleaning
+ * this master menu's chain of menus up when
+ * TkDestroyMenu was called again on this
+ * menu (via a destroy binding or somesuch).
+ * MENU_WIN_DESTRUCTION_PENDING Non-zero means we are in the middle of
+ * destroying this menu's Tk_Window.
+ * MENU_PLATFORM_FLAG1... Reserved for use by the platform-specific menu
+ * code.
+ */
+
+#define REDRAW_PENDING 1
+#define RESIZE_PENDING 2
+#define MENU_DELETION_PENDING 4
+#define MENU_WIN_DESTRUCTION_PENDING 8
+#define MENU_PLATFORM_FLAG1 (1 << 30)
+#define MENU_PLATFORM_FLAG2 (1 << 29)
+#define MENU_PLATFORM_FLAG3 (1 << 28)
+
+/*
+ * Each menu created by the user is a MASTER_MENU. When a menu is torn off,
+ * a TEAROFF_MENU instance is created. When a menu is assigned to a toplevel
+ * as a menu bar, a MENUBAR instance is created. All instances have the same
+ * configuration information. If the master instance is deleted, all instances
+ * are deleted. If one of the other instances is deleted, only that instance
+ * is deleted.
+ */
+
+#define UNKNOWN_TYPE -1
+#define MASTER_MENU 0
+#define TEAROFF_MENU 1
+#define MENUBAR 2
+
+/*
+ * Various geometry definitions:
+ */
+
+#define CASCADE_ARROW_HEIGHT 10
+#define CASCADE_ARROW_WIDTH 8
+#define DECORATION_BORDER_WIDTH 2
+
+/*
+ * Menu-related procedures that are shared among Tk modules but not exported
+ * to the outside world:
+ */
+
+EXTERN int TkActivateMenuEntry _ANSI_ARGS_((TkMenu *menuPtr,
+ int index));
+EXTERN void TkBindMenu _ANSI_ARGS_((
+ Tk_Window tkwin, TkMenu *menuPtr));
+EXTERN TkMenuReferences *
+ TkCreateMenuReferences _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name));
+EXTERN void TkDestroyMenu _ANSI_ARGS_((TkMenu *menuPtr));
+EXTERN void TkEventuallyRecomputeMenu _ANSI_ARGS_((
+ TkMenu *menuPtr));
+EXTERN void TkEventuallyRedrawMenu _ANSI_ARGS_((
+ TkMenu *menuPtr, TkMenuEntry *mePtr));
+EXTERN TkMenuReferences *
+ TkFindMenuReferences _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name));
+EXTERN TkMenuReferences *
+ TkFindMenuReferencesObj _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *namePtr));
+EXTERN int TkFreeMenuReferences _ANSI_ARGS_((
+ TkMenuReferences *menuRefPtr));
+EXTERN Tcl_HashTable * TkGetMenuHashTable _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int TkGetMenuIndex _ANSI_ARGS_((Tcl_Interp *interp,
+ TkMenu *menuPtr, Tcl_Obj *objPtr, int lastOK,
+ int *indexPtr));
+EXTERN void TkMenuInitializeDrawingFields _ANSI_ARGS_((
+ TkMenu *menuPtr));
+EXTERN void TkMenuInitializeEntryDrawingFields _ANSI_ARGS_((
+ TkMenuEntry *mePtr));
+EXTERN int TkInvokeMenu _ANSI_ARGS_((Tcl_Interp *interp,
+ TkMenu *menuPtr, int index));
+EXTERN void TkMenuConfigureDrawOptions _ANSI_ARGS_((
+ TkMenu *menuPtr));
+EXTERN int TkMenuConfigureEntryDrawOptions _ANSI_ARGS_((
+ TkMenuEntry *mePtr, int index));
+EXTERN void TkMenuFreeDrawOptions _ANSI_ARGS_((TkMenu *menuPtr));
+EXTERN void TkMenuEntryFreeDrawOptions _ANSI_ARGS_((
+ TkMenuEntry *mePtr));
+EXTERN void TkMenuEventProc _ANSI_ARGS_((ClientData clientData,
+ XEvent *eventPtr));
+EXTERN void TkMenuImageProc _ANSI_ARGS_((
+ ClientData clientData, int x, int y, int width,
+ int height, int imgWidth, int imgHeight));
+EXTERN void TkMenuInit _ANSI_ARGS_((void));
+EXTERN void TkMenuSelectImageProc _ANSI_ARGS_
+ ((ClientData clientData, int x, int y,
+ int width, int height, int imgWidth,
+ int imgHeight));
+EXTERN Tcl_Obj * TkNewMenuName _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *parentNamePtr, TkMenu *menuPtr));
+EXTERN int TkPostCommand _ANSI_ARGS_((TkMenu *menuPtr));
+EXTERN int TkPostSubmenu _ANSI_ARGS_((Tcl_Interp *interp,
+ TkMenu *menuPtr, TkMenuEntry *mePtr));
+EXTERN int TkPostTearoffMenu _ANSI_ARGS_((Tcl_Interp *interp,
+ TkMenu *menuPtr, int x, int y));
+EXTERN int TkPreprocessMenu _ANSI_ARGS_((TkMenu *menuPtr));
+EXTERN void TkRecomputeMenu _ANSI_ARGS_((TkMenu *menuPtr));
+
+/*
+ * These routines are the platform-dependent routines called by the
+ * common code.
+ */
+
+EXTERN void TkpComputeMenubarGeometry _ANSI_ARGS_((
+ TkMenu *menuPtr));
+EXTERN void TkpComputeStandardMenuGeometry _ANSI_ARGS_
+ ((TkMenu *menuPtr));
+EXTERN int TkpConfigureMenuEntry
+ _ANSI_ARGS_((TkMenuEntry *mePtr));
+EXTERN void TkpDestroyMenu _ANSI_ARGS_((TkMenu *menuPtr));
+EXTERN void TkpDestroyMenuEntry
+ _ANSI_ARGS_((TkMenuEntry *mEntryPtr));
+EXTERN void TkpDrawMenuEntry _ANSI_ARGS_((TkMenuEntry *mePtr,
+ Drawable d, Tk_Font tkfont,
+ CONST Tk_FontMetrics *menuMetricsPtr, int x,
+ int y, int width, int height, int strictMotif,
+ int drawArrow));
+EXTERN void TkpMenuInit _ANSI_ARGS_((void));
+EXTERN int TkpMenuNewEntry _ANSI_ARGS_((TkMenuEntry *mePtr));
+EXTERN int TkpNewMenu _ANSI_ARGS_((TkMenu *menuPtr));
+EXTERN int TkpPostMenu _ANSI_ARGS_((Tcl_Interp *interp,
+ TkMenu *menuPtr, int x, int y));
+EXTERN void TkpSetWindowMenuBar _ANSI_ARGS_((Tk_Window tkwin,
+ TkMenu *menuPtr));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKMENU */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenubutton.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenubutton.h
new file mode 100755
index 00000000000..30ae1beba58
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkMenubutton.h
@@ -0,0 +1,240 @@
+/*
+ * tkMenubutton.h --
+ *
+ * Declarations of types and functions used to implement
+ * the menubutton widget.
+ *
+ * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkMenubutton.h,v 1.8.4.1 2003/11/17 23:29:36 hobbs Exp $
+ */
+
+#ifndef _TKMENUBUTTON
+#define _TKMENUBUTTON
+
+#ifndef _TKINT
+#include "tkInt.h"
+#endif
+#include "tkVMacro.h"
+
+#ifndef _TKMENU
+#include "tkMenu.h"
+#endif
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Legal values for the "orient" field of TkMenubutton records.
+ */
+
+enum direction {
+ DIRECTION_ABOVE, DIRECTION_BELOW, DIRECTION_FLUSH,
+ DIRECTION_LEFT, DIRECTION_RIGHT
+};
+
+/*
+ * Legal values for the "state" field of TkMenubutton records.
+ */
+
+enum state {
+ STATE_ACTIVE, STATE_DISABLED, STATE_NORMAL
+};
+
+/*
+ * A data structure of the following type is kept for each
+ * widget managed by this file:
+ */
+
+typedef struct {
+ Tk_Window tkwin; /* Window that embodies the widget. NULL
+ * means that the window has been destroyed
+ * but the data structures haven't yet been
+ * cleaned up.*/
+ Display *display; /* Display containing widget. Needed, among
+ * other things, so that resources can bee
+ * freed up even after tkwin has gone away. */
+ Tcl_Interp *interp; /* Interpreter associated with menubutton. */
+ Tcl_Command widgetCmd; /* Token for menubutton's widget command. */
+ Tk_OptionTable optionTable; /* Table that defines configuration options
+ * available for this widget. */
+ Tk_Window menuName; /* Name of menu associated with widget.
+ * Malloc-ed. */
+
+ /*
+ * Information about what's displayed in the menu button:
+ */
+
+ char *text; /* Text to display in button (malloc'ed)
+ * or NULL. */
+ int underline; /* Index of character to underline. */
+ Tcl_Obj *textVarName; /* Name of variable (malloc'ed) or NULL.
+ * If non-NULL, button displays the contents
+ * of this variable. */
+ Pixmap bitmap; /* Bitmap to display or None. If not None
+ * then text and textVar and underline
+ * are ignored. */
+ char *imageString; /* Name of image to display (malloc'ed), or
+ * NULL. If non-NULL, bitmap, text, and
+ * textVarName are ignored. */
+ Tk_Image image; /* Image to display in window, or NULL if
+ * none. */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ enum state state; /* State of button for display purposes:
+ * normal, active, or disabled. */
+ Tk_3DBorder normalBorder; /* Structure used to draw 3-D
+ * border and background when window
+ * isn't active. NULL means no such
+ * border exists. */
+ Tk_3DBorder activeBorder; /* Structure used to draw 3-D
+ * border and background when window
+ * is active. NULL means no such
+ * border exists. */
+ int borderWidth; /* Width of border. */
+ int relief; /* 3-d effect: TK_RELIEF_RAISED, etc. */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ XColor *highlightBgColorPtr;
+ /* Color for drawing traversal highlight
+ * area when highlight is off. */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ int inset; /* Total width of all borders, including
+ * traversal highlight and 3-D border.
+ * Indicates how much interior stuff must
+ * be offset from outside edges to leave
+ * room for borders. */
+ Tk_Font tkfont; /* Information about text font, or NULL. */
+ XColor *normalFg; /* Foreground color in normal mode. */
+ XColor *activeFg; /* Foreground color in active mode. NULL
+ * means use normalFg instead. */
+ XColor *disabledFg; /* Foreground color when disabled. NULL
+ * means use normalFg with a 50% stipple
+ * instead. */
+ GC normalTextGC; /* GC for drawing text in normal mode. */
+ GC activeTextGC; /* GC for drawing text in active mode (NULL
+ * means use normalTextGC). */
+ Pixmap gray; /* Pixmap for displaying disabled text/icon if
+ * disabledFg is NULL. */
+ GC disabledGC; /* Used to produce disabled effect for text. */
+ GC stippleGC; /* Used to produce disabled stipple effect
+ * for images when disabled. */
+ int leftBearing; /* Distance from text origin to leftmost drawn
+ * pixel (positive means to right). */
+ int rightBearing; /* Amount text sticks right from its origin. */
+ Tcl_Obj *widthString; /* Value of -width option. Malloc'ed. */
+ Tcl_Obj *heightString; /* Value of -height option. Malloc'ed. */
+ int width, height; /* If > 0, these specify dimensions to request
+ * for window, in characters for text and in
+ * pixels for bitmaps. In this case the actual
+ * size of the text string or bitmap is
+ * ignored in computing desired window size. */
+ int wrapLength; /* Line length (in pixels) at which to wrap
+ * onto next line. <= 0 means don't wrap
+ * except at newlines. */
+ int padX, padY; /* Extra space around text or bitmap (pixels
+ * on each side). */
+ Tk_Anchor anchor; /* Where text/bitmap should be displayed
+ * inside window region. */
+ Tk_Justify justify; /* Justification to use for multi-line text. */
+ int textWidth; /* Width needed to display text as requested,
+ * in pixels. */
+ int textHeight; /* Height needed to display text as requested,
+ * in pixels. */
+ Tk_TextLayout textLayout; /* Saved text layout information. */
+ int indicatorOn; /* Non-zero means display indicator; 0 means
+ * don't display. */
+ int indicatorHeight; /* Height of indicator in pixels. This same
+ * amount of extra space is also left on each
+ * side of the indicator. 0 if no indicator. */
+ int indicatorWidth; /* Width of indicator in pixels, including
+ * indicatorHeight in padding on each side.
+ * 0 if no indicator. */
+
+ /*
+ * Miscellaneous information:
+ */
+
+ int compound; /* Value of -compound option; specifies whether
+ * the menubutton should show both an image and
+ * text, and, if so, how. */
+
+ enum direction direction; /* Direction for where to pop the menu.
+ * Valid directions are "above", "below",
+ * "left", "right", and "flush". "flush"
+ * means that the upper left corner of the
+ * menubutton is where the menu pops up.
+ * "above" and "below" will attempt to pop
+ * the menu compleletly above or below
+ * the menu respectively.
+ * "left" and "right" will pop the menu
+ * left or right, and the active item
+ * will be next to the button. */
+ Tk_Cursor cursor; /* Current cursor for window, or None. */
+ char *takeFocus; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+ int flags; /* Various flags; see below for
+ * definitions. */
+} TkMenuButton;
+
+/*
+ * Flag bits for buttons:
+ *
+ * REDRAW_PENDING: Non-zero means a DoWhenIdle handler
+ * has already been queued to redraw
+ * this window.
+ * POSTED: Non-zero means that the menu associated
+ * with this button has been posted (typically
+ * because of an active button press).
+ * GOT_FOCUS: Non-zero means this button currently
+ * has the input focus.
+ */
+
+#define REDRAW_PENDING 1
+#define POSTED 2
+#define GOT_FOCUS 4
+
+/*
+ * The following constants define the dimensions of the cascade indicator,
+ * which is displayed if the "-indicatoron" option is true. The units for
+ * these options are 1/10 millimeters.
+ */
+
+#define INDICATOR_WIDTH 40
+#define INDICATOR_HEIGHT 17
+
+/*
+ * Declaration of variables shared between the files in the button module.
+ */
+
+extern Tk_ClassProcs tkpMenubuttonClass;
+
+/*
+ * Declaration of procedures used in the implementation of the button
+ * widget.
+ */
+
+EXTERN void TkpComputeMenuButtonGeometry _ANSI_ARGS_((
+ TkMenuButton *mbPtr));
+EXTERN TkMenuButton * TkpCreateMenuButton _ANSI_ARGS_((Tk_Window tkwin));
+EXTERN void TkpDisplayMenuButton _ANSI_ARGS_((
+ ClientData clientData));
+EXTERN void TkpDestroyMenuButton _ANSI_ARGS_((
+ TkMenuButton *mbPtr));
+EXTERN void TkMenuButtonWorldChanged _ANSI_ARGS_((
+ ClientData instanceData));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKMENUBUTTON */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.h
new file mode 100755
index 00000000000..db21505cf68
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.h
@@ -0,0 +1,17 @@
+#ifndef _TKOPTION
+#define _TKOPTION
+EXTERN void Tk_AddOption _ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name, CONST char * value,
+ int priority));
+EXTERN Tk_Uid Tk_GetOption _ANSI_ARGS_((Tk_Window tkwin, CONST char *name,
+ CONST char *className));
+EXTERN int Tk_OptionObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *args));
+#ifndef _TKINT
+struct TkWindow;
+#endif
+EXTERN void TkOptionClassChanged _ANSI_ARGS_((struct TkWindow *winPtr));
+EXTERN void TkOptionDeadWindow _ANSI_ARGS_((struct TkWindow *winPtr));
+#endif /* _TKOPTION */
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.m
new file mode 100755
index 00000000000..9486a5da573
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.m
@@ -0,0 +1,26 @@
+#ifndef _TKOPTION_VM
+#define _TKOPTION_VM
+#include "tkOption_f.h"
+#ifndef NO_VTABLES
+#ifndef TkOptionClassChanged
+# define TkOptionClassChanged (*TkoptionVptr->V_TkOptionClassChanged)
+#endif
+
+#ifndef TkOptionDeadWindow
+# define TkOptionDeadWindow (*TkoptionVptr->V_TkOptionDeadWindow)
+#endif
+
+#ifndef Tk_AddOption
+# define Tk_AddOption (*TkoptionVptr->V_Tk_AddOption)
+#endif
+
+#ifndef Tk_GetOption
+# define Tk_GetOption (*TkoptionVptr->V_Tk_GetOption)
+#endif
+
+#ifndef Tk_OptionObjCmd
+# define Tk_OptionObjCmd (*TkoptionVptr->V_Tk_OptionObjCmd)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKOPTION_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.t
new file mode 100755
index 00000000000..c782fae5cf4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption.t
@@ -0,0 +1,26 @@
+#ifdef _TKOPTION
+#ifndef TkOptionClassChanged
+VFUNC(void,TkOptionClassChanged,V_TkOptionClassChanged,_ANSI_ARGS_((struct TkWindow *winPtr)))
+#endif /* #ifndef TkOptionClassChanged */
+
+#ifndef TkOptionDeadWindow
+VFUNC(void,TkOptionDeadWindow,V_TkOptionDeadWindow,_ANSI_ARGS_((struct TkWindow *winPtr)))
+#endif /* #ifndef TkOptionDeadWindow */
+
+#ifndef Tk_AddOption
+VFUNC(void,Tk_AddOption,V_Tk_AddOption,_ANSI_ARGS_((Tk_Window tkwin,
+ CONST char * name, CONST char * value,
+ int priority)))
+#endif /* #ifndef Tk_AddOption */
+
+#ifndef Tk_GetOption
+VFUNC(Tk_Uid,Tk_GetOption,V_Tk_GetOption,_ANSI_ARGS_((Tk_Window tkwin, CONST char *name,
+ CONST char *className)))
+#endif /* #ifndef Tk_GetOption */
+
+#ifndef Tk_OptionObjCmd
+VFUNC(int,Tk_OptionObjCmd,V_Tk_OptionObjCmd,_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *args)))
+#endif /* #ifndef Tk_OptionObjCmd */
+
+#endif /* _TKOPTION */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption_f.h
new file mode 100755
index 00000000000..9a3f10cd919
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkOption_f.h
@@ -0,0 +1,14 @@
+#ifndef TKOPTION_VT
+#define TKOPTION_VT
+typedef struct TkoptionVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkOption.t"
+#undef VFUNC
+#undef VVAR
+} TkoptionVtab;
+extern TkoptionVtab *TkoptionVptr;
+extern TkoptionVtab *TkoptionVGet(void);
+#endif /* TKOPTION_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.h
new file mode 100755
index 00000000000..1ac6485307b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.h
@@ -0,0 +1,300 @@
+/*
+ * tkPlatDecls.h --
+ *
+ * Declarations of functions in the platform-specific public Tcl API.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkPlatDecls.h,v 1.7 2002/08/31 06:12:23 das Exp $
+ */
+
+#ifndef _TKPLATDECLS
+#define _TKPLATDECLS
+
+#ifdef BUILD_tk
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tk.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+#ifdef __WIN32__
+/* 0 */
+EXTERN Window Tk_AttachHWND _ANSI_ARGS_((Tk_Window tkwin,
+ HWND hwnd));
+/* 1 */
+EXTERN HINSTANCE Tk_GetHINSTANCE _ANSI_ARGS_((void));
+/* 2 */
+EXTERN HWND Tk_GetHWND _ANSI_ARGS_((Window window));
+/* 3 */
+EXTERN Tk_Window Tk_HWNDToWindow _ANSI_ARGS_((HWND hwnd));
+/* 4 */
+EXTERN void Tk_PointerEvent _ANSI_ARGS_((HWND hwnd, int x, int y));
+/* 5 */
+EXTERN int Tk_TranslateWinEvent _ANSI_ARGS_((HWND hwnd,
+ UINT message, WPARAM wParam, LPARAM lParam,
+ LRESULT * result));
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+/* 0 */
+EXTERN void Tk_MacSetEmbedHandler _ANSI_ARGS_((
+ Tk_MacEmbedRegisterWinProc * registerWinProcPtr,
+ Tk_MacEmbedGetGrafPortProc * getPortProcPtr,
+ Tk_MacEmbedMakeContainerExistProc * containerExistProcPtr,
+ Tk_MacEmbedGetClipProc * getClipProc,
+ Tk_MacEmbedGetOffsetInParentProc * getOffsetProc));
+/* 1 */
+EXTERN void Tk_MacTurnOffMenus _ANSI_ARGS_((void));
+/* 2 */
+EXTERN void Tk_MacTkOwnsCursor _ANSI_ARGS_((int tkOwnsIt));
+/* 3 */
+EXTERN void TkMacInitMenus _ANSI_ARGS_((Tcl_Interp * interp));
+/* 4 */
+EXTERN void TkMacInitAppleEvents _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 5 */
+EXTERN int TkMacConvertEvent _ANSI_ARGS_((
+ EventRecord * eventPtr));
+/* 6 */
+EXTERN int TkMacConvertTkEvent _ANSI_ARGS_((
+ EventRecord * eventPtr, Window window));
+/* 7 */
+EXTERN void TkGenWMConfigureEvent _ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y, int width, int height,
+ int flags));
+/* 8 */
+EXTERN void TkMacInvalClipRgns _ANSI_ARGS_((TkWindow * winPtr));
+/* 9 */
+EXTERN int TkMacHaveAppearance _ANSI_ARGS_((void));
+/* 10 */
+EXTERN GWorldPtr TkMacGetDrawablePort _ANSI_ARGS_((Drawable drawable));
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+/* 0 */
+EXTERN void Tk_MacOSXSetEmbedHandler _ANSI_ARGS_((
+ Tk_MacOSXEmbedRegisterWinProc * registerWinProcPtr,
+ Tk_MacOSXEmbedGetGrafPortProc * getPortProcPtr,
+ Tk_MacOSXEmbedMakeContainerExistProc * containerExistProcPtr,
+ Tk_MacOSXEmbedGetClipProc * getClipProc,
+ Tk_MacOSXEmbedGetOffsetInParentProc * getOffsetProc));
+/* 1 */
+EXTERN void Tk_MacOSXTurnOffMenus _ANSI_ARGS_((void));
+/* 2 */
+EXTERN void Tk_MacOSXTkOwnsCursor _ANSI_ARGS_((int tkOwnsIt));
+/* 3 */
+EXTERN void TkMacOSXInitMenus _ANSI_ARGS_((Tcl_Interp * interp));
+/* 4 */
+EXTERN void TkMacOSXInitAppleEvents _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 5 */
+EXTERN void TkGenWMConfigureEvent _ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y, int width, int height,
+ int flags));
+/* 6 */
+EXTERN void TkMacOSXInvalClipRgns _ANSI_ARGS_((TkWindow * winPtr));
+/* 7 */
+EXTERN GWorldPtr TkMacOSXGetDrawablePort _ANSI_ARGS_((
+ Drawable drawable));
+/* 8 */
+EXTERN ControlRef TkMacOSXGetRootControl _ANSI_ARGS_((
+ Drawable drawable));
+/* 9 */
+EXTERN void Tk_MacOSXSetupTkNotifier _ANSI_ARGS_((void));
+/* 10 */
+EXTERN int Tk_MacOSXIsAppInFront _ANSI_ARGS_((void));
+#endif /* MAC_OSX_TK */
+
+typedef struct TkPlatStubs {
+ int magic;
+ struct TkPlatStubHooks *hooks;
+
+#ifdef __WIN32__
+ Window (*tk_AttachHWND) _ANSI_ARGS_((Tk_Window tkwin, HWND hwnd)); /* 0 */
+ HINSTANCE (*tk_GetHINSTANCE) _ANSI_ARGS_((void)); /* 1 */
+ HWND (*tk_GetHWND) _ANSI_ARGS_((Window window)); /* 2 */
+ Tk_Window (*tk_HWNDToWindow) _ANSI_ARGS_((HWND hwnd)); /* 3 */
+ void (*tk_PointerEvent) _ANSI_ARGS_((HWND hwnd, int x, int y)); /* 4 */
+ int (*tk_TranslateWinEvent) _ANSI_ARGS_((HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam, LRESULT * result)); /* 5 */
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+ void (*tk_MacSetEmbedHandler) _ANSI_ARGS_((Tk_MacEmbedRegisterWinProc * registerWinProcPtr, Tk_MacEmbedGetGrafPortProc * getPortProcPtr, Tk_MacEmbedMakeContainerExistProc * containerExistProcPtr, Tk_MacEmbedGetClipProc * getClipProc, Tk_MacEmbedGetOffsetInParentProc * getOffsetProc)); /* 0 */
+ void (*tk_MacTurnOffMenus) _ANSI_ARGS_((void)); /* 1 */
+ void (*tk_MacTkOwnsCursor) _ANSI_ARGS_((int tkOwnsIt)); /* 2 */
+ void (*tkMacInitMenus) _ANSI_ARGS_((Tcl_Interp * interp)); /* 3 */
+ void (*tkMacInitAppleEvents) _ANSI_ARGS_((Tcl_Interp * interp)); /* 4 */
+ int (*tkMacConvertEvent) _ANSI_ARGS_((EventRecord * eventPtr)); /* 5 */
+ int (*tkMacConvertTkEvent) _ANSI_ARGS_((EventRecord * eventPtr, Window window)); /* 6 */
+ void (*tkGenWMConfigureEvent) _ANSI_ARGS_((Tk_Window tkwin, int x, int y, int width, int height, int flags)); /* 7 */
+ void (*tkMacInvalClipRgns) _ANSI_ARGS_((TkWindow * winPtr)); /* 8 */
+ int (*tkMacHaveAppearance) _ANSI_ARGS_((void)); /* 9 */
+ GWorldPtr (*tkMacGetDrawablePort) _ANSI_ARGS_((Drawable drawable)); /* 10 */
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+ void (*tk_MacOSXSetEmbedHandler) _ANSI_ARGS_((Tk_MacOSXEmbedRegisterWinProc * registerWinProcPtr, Tk_MacOSXEmbedGetGrafPortProc * getPortProcPtr, Tk_MacOSXEmbedMakeContainerExistProc * containerExistProcPtr, Tk_MacOSXEmbedGetClipProc * getClipProc, Tk_MacOSXEmbedGetOffsetInParentProc * getOffsetProc)); /* 0 */
+ void (*tk_MacOSXTurnOffMenus) _ANSI_ARGS_((void)); /* 1 */
+ void (*tk_MacOSXTkOwnsCursor) _ANSI_ARGS_((int tkOwnsIt)); /* 2 */
+ void (*tkMacOSXInitMenus) _ANSI_ARGS_((Tcl_Interp * interp)); /* 3 */
+ void (*tkMacOSXInitAppleEvents) _ANSI_ARGS_((Tcl_Interp * interp)); /* 4 */
+ void (*tkGenWMConfigureEvent) _ANSI_ARGS_((Tk_Window tkwin, int x, int y, int width, int height, int flags)); /* 5 */
+ void (*tkMacOSXInvalClipRgns) _ANSI_ARGS_((TkWindow * winPtr)); /* 6 */
+ GWorldPtr (*tkMacOSXGetDrawablePort) _ANSI_ARGS_((Drawable drawable)); /* 7 */
+ ControlRef (*tkMacOSXGetRootControl) _ANSI_ARGS_((Drawable drawable)); /* 8 */
+ void (*tk_MacOSXSetupTkNotifier) _ANSI_ARGS_((void)); /* 9 */
+ int (*tk_MacOSXIsAppInFront) _ANSI_ARGS_((void)); /* 10 */
+#endif /* MAC_OSX_TK */
+} TkPlatStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern TkPlatStubs *tkPlatStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifdef __WIN32__
+#ifndef Tk_AttachHWND
+#define Tk_AttachHWND \
+ (tkPlatStubsPtr->tk_AttachHWND) /* 0 */
+#endif
+#ifndef Tk_GetHINSTANCE
+#define Tk_GetHINSTANCE \
+ (tkPlatStubsPtr->tk_GetHINSTANCE) /* 1 */
+#endif
+#ifndef Tk_GetHWND
+#define Tk_GetHWND \
+ (tkPlatStubsPtr->tk_GetHWND) /* 2 */
+#endif
+#ifndef Tk_HWNDToWindow
+#define Tk_HWNDToWindow \
+ (tkPlatStubsPtr->tk_HWNDToWindow) /* 3 */
+#endif
+#ifndef Tk_PointerEvent
+#define Tk_PointerEvent \
+ (tkPlatStubsPtr->tk_PointerEvent) /* 4 */
+#endif
+#ifndef Tk_TranslateWinEvent
+#define Tk_TranslateWinEvent \
+ (tkPlatStubsPtr->tk_TranslateWinEvent) /* 5 */
+#endif
+#endif /* __WIN32__ */
+#ifdef MAC_TCL
+#ifndef Tk_MacSetEmbedHandler
+#define Tk_MacSetEmbedHandler \
+ (tkPlatStubsPtr->tk_MacSetEmbedHandler) /* 0 */
+#endif
+#ifndef Tk_MacTurnOffMenus
+#define Tk_MacTurnOffMenus \
+ (tkPlatStubsPtr->tk_MacTurnOffMenus) /* 1 */
+#endif
+#ifndef Tk_MacTkOwnsCursor
+#define Tk_MacTkOwnsCursor \
+ (tkPlatStubsPtr->tk_MacTkOwnsCursor) /* 2 */
+#endif
+#ifndef TkMacInitMenus
+#define TkMacInitMenus \
+ (tkPlatStubsPtr->tkMacInitMenus) /* 3 */
+#endif
+#ifndef TkMacInitAppleEvents
+#define TkMacInitAppleEvents \
+ (tkPlatStubsPtr->tkMacInitAppleEvents) /* 4 */
+#endif
+#ifndef TkMacConvertEvent
+#define TkMacConvertEvent \
+ (tkPlatStubsPtr->tkMacConvertEvent) /* 5 */
+#endif
+#ifndef TkMacConvertTkEvent
+#define TkMacConvertTkEvent \
+ (tkPlatStubsPtr->tkMacConvertTkEvent) /* 6 */
+#endif
+#ifndef TkGenWMConfigureEvent
+#define TkGenWMConfigureEvent \
+ (tkPlatStubsPtr->tkGenWMConfigureEvent) /* 7 */
+#endif
+#ifndef TkMacInvalClipRgns
+#define TkMacInvalClipRgns \
+ (tkPlatStubsPtr->tkMacInvalClipRgns) /* 8 */
+#endif
+#ifndef TkMacHaveAppearance
+#define TkMacHaveAppearance \
+ (tkPlatStubsPtr->tkMacHaveAppearance) /* 9 */
+#endif
+#ifndef TkMacGetDrawablePort
+#define TkMacGetDrawablePort \
+ (tkPlatStubsPtr->tkMacGetDrawablePort) /* 10 */
+#endif
+#endif /* MAC_TCL */
+#ifdef MAC_OSX_TK
+#ifndef Tk_MacOSXSetEmbedHandler
+#define Tk_MacOSXSetEmbedHandler \
+ (tkPlatStubsPtr->tk_MacOSXSetEmbedHandler) /* 0 */
+#endif
+#ifndef Tk_MacOSXTurnOffMenus
+#define Tk_MacOSXTurnOffMenus \
+ (tkPlatStubsPtr->tk_MacOSXTurnOffMenus) /* 1 */
+#endif
+#ifndef Tk_MacOSXTkOwnsCursor
+#define Tk_MacOSXTkOwnsCursor \
+ (tkPlatStubsPtr->tk_MacOSXTkOwnsCursor) /* 2 */
+#endif
+#ifndef TkMacOSXInitMenus
+#define TkMacOSXInitMenus \
+ (tkPlatStubsPtr->tkMacOSXInitMenus) /* 3 */
+#endif
+#ifndef TkMacOSXInitAppleEvents
+#define TkMacOSXInitAppleEvents \
+ (tkPlatStubsPtr->tkMacOSXInitAppleEvents) /* 4 */
+#endif
+#ifndef TkGenWMConfigureEvent
+#define TkGenWMConfigureEvent \
+ (tkPlatStubsPtr->tkGenWMConfigureEvent) /* 5 */
+#endif
+#ifndef TkMacOSXInvalClipRgns
+#define TkMacOSXInvalClipRgns \
+ (tkPlatStubsPtr->tkMacOSXInvalClipRgns) /* 6 */
+#endif
+#ifndef TkMacOSXGetDrawablePort
+#define TkMacOSXGetDrawablePort \
+ (tkPlatStubsPtr->tkMacOSXGetDrawablePort) /* 7 */
+#endif
+#ifndef TkMacOSXGetRootControl
+#define TkMacOSXGetRootControl \
+ (tkPlatStubsPtr->tkMacOSXGetRootControl) /* 8 */
+#endif
+#ifndef Tk_MacOSXSetupTkNotifier
+#define Tk_MacOSXSetupTkNotifier \
+ (tkPlatStubsPtr->tk_MacOSXSetupTkNotifier) /* 9 */
+#endif
+#ifndef Tk_MacOSXIsAppInFront
+#define Tk_MacOSXIsAppInFront \
+ (tkPlatStubsPtr->tk_MacOSXIsAppInFront) /* 10 */
+#endif
+#endif /* MAC_OSX_TK */
+
+#endif /* defined(USE_TK_STUBS) && !defined(USE_TK_STUB_PROCS) */
+
+/* !END!: Do not edit above this line. */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKPLATDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.m b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.m
new file mode 100755
index 00000000000..41dfafb4998
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.m
@@ -0,0 +1,114 @@
+#ifndef _TKPLATDECLS_VM
+#define _TKPLATDECLS_VM
+#include "tkPlatDecls_f.h"
+#ifndef NO_VTABLES
+#ifndef TkGenWMConfigureEvent
+# define TkGenWMConfigureEvent (*TkplatdeclsVptr->V_TkGenWMConfigureEvent)
+#endif
+
+#ifndef TkMacConvertEvent
+# define TkMacConvertEvent (*TkplatdeclsVptr->V_TkMacConvertEvent)
+#endif
+
+#ifndef TkMacConvertTkEvent
+# define TkMacConvertTkEvent (*TkplatdeclsVptr->V_TkMacConvertTkEvent)
+#endif
+
+#ifndef TkMacGetDrawablePort
+# define TkMacGetDrawablePort (*TkplatdeclsVptr->V_TkMacGetDrawablePort)
+#endif
+
+#ifndef TkMacHaveAppearance
+# define TkMacHaveAppearance (*TkplatdeclsVptr->V_TkMacHaveAppearance)
+#endif
+
+#ifndef TkMacInitAppleEvents
+# define TkMacInitAppleEvents (*TkplatdeclsVptr->V_TkMacInitAppleEvents)
+#endif
+
+#ifndef TkMacInitMenus
+# define TkMacInitMenus (*TkplatdeclsVptr->V_TkMacInitMenus)
+#endif
+
+#ifndef TkMacInvalClipRgns
+# define TkMacInvalClipRgns (*TkplatdeclsVptr->V_TkMacInvalClipRgns)
+#endif
+
+#ifndef TkMacOSXGetDrawablePort
+# define TkMacOSXGetDrawablePort (*TkplatdeclsVptr->V_TkMacOSXGetDrawablePort)
+#endif
+
+#ifndef TkMacOSXGetRootControl
+# define TkMacOSXGetRootControl (*TkplatdeclsVptr->V_TkMacOSXGetRootControl)
+#endif
+
+#ifndef TkMacOSXInitAppleEvents
+# define TkMacOSXInitAppleEvents (*TkplatdeclsVptr->V_TkMacOSXInitAppleEvents)
+#endif
+
+#ifndef TkMacOSXInitMenus
+# define TkMacOSXInitMenus (*TkplatdeclsVptr->V_TkMacOSXInitMenus)
+#endif
+
+#ifndef TkMacOSXInvalClipRgns
+# define TkMacOSXInvalClipRgns (*TkplatdeclsVptr->V_TkMacOSXInvalClipRgns)
+#endif
+
+#ifndef Tk_AttachHWND
+# define Tk_AttachHWND (*TkplatdeclsVptr->V_Tk_AttachHWND)
+#endif
+
+#ifndef Tk_GetHINSTANCE
+# define Tk_GetHINSTANCE (*TkplatdeclsVptr->V_Tk_GetHINSTANCE)
+#endif
+
+#ifndef Tk_GetHWND
+# define Tk_GetHWND (*TkplatdeclsVptr->V_Tk_GetHWND)
+#endif
+
+#ifndef Tk_HWNDToWindow
+# define Tk_HWNDToWindow (*TkplatdeclsVptr->V_Tk_HWNDToWindow)
+#endif
+
+#ifndef Tk_MacOSXIsAppInFront
+# define Tk_MacOSXIsAppInFront (*TkplatdeclsVptr->V_Tk_MacOSXIsAppInFront)
+#endif
+
+#ifndef Tk_MacOSXSetEmbedHandler
+# define Tk_MacOSXSetEmbedHandler (*TkplatdeclsVptr->V_Tk_MacOSXSetEmbedHandler)
+#endif
+
+#ifndef Tk_MacOSXSetupTkNotifier
+# define Tk_MacOSXSetupTkNotifier (*TkplatdeclsVptr->V_Tk_MacOSXSetupTkNotifier)
+#endif
+
+#ifndef Tk_MacOSXTkOwnsCursor
+# define Tk_MacOSXTkOwnsCursor (*TkplatdeclsVptr->V_Tk_MacOSXTkOwnsCursor)
+#endif
+
+#ifndef Tk_MacOSXTurnOffMenus
+# define Tk_MacOSXTurnOffMenus (*TkplatdeclsVptr->V_Tk_MacOSXTurnOffMenus)
+#endif
+
+#ifndef Tk_MacSetEmbedHandler
+# define Tk_MacSetEmbedHandler (*TkplatdeclsVptr->V_Tk_MacSetEmbedHandler)
+#endif
+
+#ifndef Tk_MacTkOwnsCursor
+# define Tk_MacTkOwnsCursor (*TkplatdeclsVptr->V_Tk_MacTkOwnsCursor)
+#endif
+
+#ifndef Tk_MacTurnOffMenus
+# define Tk_MacTurnOffMenus (*TkplatdeclsVptr->V_Tk_MacTurnOffMenus)
+#endif
+
+#ifndef Tk_PointerEvent
+# define Tk_PointerEvent (*TkplatdeclsVptr->V_Tk_PointerEvent)
+#endif
+
+#ifndef Tk_TranslateWinEvent
+# define Tk_TranslateWinEvent (*TkplatdeclsVptr->V_Tk_TranslateWinEvent)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKPLATDECLS_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.t b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.t
new file mode 100755
index 00000000000..162ddc59545
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls.t
@@ -0,0 +1,190 @@
+#ifdef _TKPLATDECLS
+#ifndef TkGenWMConfigureEvent
+#ifdef MAC_OSX_TK
+VFUNC(void,TkGenWMConfigureEvent,V_TkGenWMConfigureEvent,_ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y, int width, int height,
+ int flags)))
+#endif /* #ifdef MAC_OSX_TK */
+#ifdef MAC_TCL
+VFUNC(void,TkGenWMConfigureEvent,V_TkGenWMConfigureEvent,_ANSI_ARGS_((Tk_Window tkwin,
+ int x, int y, int width, int height,
+ int flags)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkGenWMConfigureEvent */
+
+#ifndef TkMacConvertEvent
+#ifdef MAC_TCL
+VFUNC(int,TkMacConvertEvent,V_TkMacConvertEvent,_ANSI_ARGS_((
+ EventRecord * eventPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacConvertEvent */
+
+#ifndef TkMacConvertTkEvent
+#ifdef MAC_TCL
+VFUNC(int,TkMacConvertTkEvent,V_TkMacConvertTkEvent,_ANSI_ARGS_((
+ EventRecord * eventPtr, Window window)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacConvertTkEvent */
+
+#ifndef TkMacGetDrawablePort
+#ifdef MAC_TCL
+VFUNC(GWorldPtr,TkMacGetDrawablePort,V_TkMacGetDrawablePort,_ANSI_ARGS_((Drawable drawable)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacGetDrawablePort */
+
+#ifndef TkMacHaveAppearance
+#ifdef MAC_TCL
+VFUNC(int,TkMacHaveAppearance,V_TkMacHaveAppearance,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacHaveAppearance */
+
+#ifndef TkMacInitAppleEvents
+#ifdef MAC_TCL
+VFUNC(void,TkMacInitAppleEvents,V_TkMacInitAppleEvents,_ANSI_ARGS_((
+ Tcl_Interp * interp)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacInitAppleEvents */
+
+#ifndef TkMacInitMenus
+#ifdef MAC_TCL
+VFUNC(void,TkMacInitMenus,V_TkMacInitMenus,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacInitMenus */
+
+#ifndef TkMacInvalClipRgns
+#ifdef MAC_TCL
+VFUNC(void,TkMacInvalClipRgns,V_TkMacInvalClipRgns,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef TkMacInvalClipRgns */
+
+#ifndef TkMacOSXGetDrawablePort
+#ifdef MAC_OSX_TK
+VFUNC(GWorldPtr,TkMacOSXGetDrawablePort,V_TkMacOSXGetDrawablePort,_ANSI_ARGS_((
+ Drawable drawable)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXGetDrawablePort */
+
+#ifndef TkMacOSXGetRootControl
+#ifdef MAC_OSX_TK
+VFUNC(ControlRef,TkMacOSXGetRootControl,V_TkMacOSXGetRootControl,_ANSI_ARGS_((
+ Drawable drawable)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXGetRootControl */
+
+#ifndef TkMacOSXInitAppleEvents
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXInitAppleEvents,V_TkMacOSXInitAppleEvents,_ANSI_ARGS_((
+ Tcl_Interp * interp)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXInitAppleEvents */
+
+#ifndef TkMacOSXInitMenus
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXInitMenus,V_TkMacOSXInitMenus,_ANSI_ARGS_((Tcl_Interp * interp)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXInitMenus */
+
+#ifndef TkMacOSXInvalClipRgns
+#ifdef MAC_OSX_TK
+VFUNC(void,TkMacOSXInvalClipRgns,V_TkMacOSXInvalClipRgns,_ANSI_ARGS_((TkWindow * winPtr)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef TkMacOSXInvalClipRgns */
+
+#ifndef Tk_AttachHWND
+#ifdef __WIN32__
+VFUNC(Window,Tk_AttachHWND,V_Tk_AttachHWND,_ANSI_ARGS_((Tk_Window tkwin,
+ HWND hwnd)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef Tk_AttachHWND */
+
+#ifndef Tk_GetHINSTANCE
+#ifdef __WIN32__
+VFUNC(HINSTANCE,Tk_GetHINSTANCE,V_Tk_GetHINSTANCE,_ANSI_ARGS_((void)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef Tk_GetHINSTANCE */
+
+#ifndef Tk_GetHWND
+#ifdef __WIN32__
+VFUNC(HWND,Tk_GetHWND,V_Tk_GetHWND,_ANSI_ARGS_((Window window)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef Tk_GetHWND */
+
+#ifndef Tk_HWNDToWindow
+#ifdef __WIN32__
+VFUNC(Tk_Window,Tk_HWNDToWindow,V_Tk_HWNDToWindow,_ANSI_ARGS_((HWND hwnd)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef Tk_HWNDToWindow */
+
+#ifndef Tk_MacOSXIsAppInFront
+#ifdef MAC_OSX_TK
+VFUNC(int,Tk_MacOSXIsAppInFront,V_Tk_MacOSXIsAppInFront,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef Tk_MacOSXIsAppInFront */
+
+#ifndef Tk_MacOSXSetEmbedHandler
+#ifdef MAC_OSX_TK
+VFUNC(void,Tk_MacOSXSetEmbedHandler,V_Tk_MacOSXSetEmbedHandler,_ANSI_ARGS_((
+ Tk_MacOSXEmbedRegisterWinProc * registerWinProcPtr,
+ Tk_MacOSXEmbedGetGrafPortProc * getPortProcPtr,
+ Tk_MacOSXEmbedMakeContainerExistProc * containerExistProcPtr,
+ Tk_MacOSXEmbedGetClipProc * getClipProc,
+ Tk_MacOSXEmbedGetOffsetInParentProc * getOffsetProc)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef Tk_MacOSXSetEmbedHandler */
+
+#ifndef Tk_MacOSXSetupTkNotifier
+#ifdef MAC_OSX_TK
+VFUNC(void,Tk_MacOSXSetupTkNotifier,V_Tk_MacOSXSetupTkNotifier,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef Tk_MacOSXSetupTkNotifier */
+
+#ifndef Tk_MacOSXTkOwnsCursor
+#ifdef MAC_OSX_TK
+VFUNC(void,Tk_MacOSXTkOwnsCursor,V_Tk_MacOSXTkOwnsCursor,_ANSI_ARGS_((int tkOwnsIt)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef Tk_MacOSXTkOwnsCursor */
+
+#ifndef Tk_MacOSXTurnOffMenus
+#ifdef MAC_OSX_TK
+VFUNC(void,Tk_MacOSXTurnOffMenus,V_Tk_MacOSXTurnOffMenus,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_OSX_TK */
+#endif /* #ifndef Tk_MacOSXTurnOffMenus */
+
+#ifndef Tk_MacSetEmbedHandler
+#ifdef MAC_TCL
+VFUNC(void,Tk_MacSetEmbedHandler,V_Tk_MacSetEmbedHandler,_ANSI_ARGS_((
+ Tk_MacEmbedRegisterWinProc * registerWinProcPtr,
+ Tk_MacEmbedGetGrafPortProc * getPortProcPtr,
+ Tk_MacEmbedMakeContainerExistProc * containerExistProcPtr,
+ Tk_MacEmbedGetClipProc * getClipProc,
+ Tk_MacEmbedGetOffsetInParentProc * getOffsetProc)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef Tk_MacSetEmbedHandler */
+
+#ifndef Tk_MacTkOwnsCursor
+#ifdef MAC_TCL
+VFUNC(void,Tk_MacTkOwnsCursor,V_Tk_MacTkOwnsCursor,_ANSI_ARGS_((int tkOwnsIt)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef Tk_MacTkOwnsCursor */
+
+#ifndef Tk_MacTurnOffMenus
+#ifdef MAC_TCL
+VFUNC(void,Tk_MacTurnOffMenus,V_Tk_MacTurnOffMenus,_ANSI_ARGS_((void)))
+#endif /* #ifdef MAC_TCL */
+#endif /* #ifndef Tk_MacTurnOffMenus */
+
+#ifndef Tk_PointerEvent
+#ifdef __WIN32__
+VFUNC(void,Tk_PointerEvent,V_Tk_PointerEvent,_ANSI_ARGS_((HWND hwnd, int x, int y)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef Tk_PointerEvent */
+
+#ifndef Tk_TranslateWinEvent
+#ifdef __WIN32__
+VFUNC(int,Tk_TranslateWinEvent,V_Tk_TranslateWinEvent,_ANSI_ARGS_((HWND hwnd,
+ UINT message, WPARAM wParam, LPARAM lParam,
+ LRESULT * result)))
+#endif /* #ifdef __WIN32__ */
+#endif /* #ifndef Tk_TranslateWinEvent */
+
+#endif /* _TKPLATDECLS */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls_f.h
new file mode 100755
index 00000000000..8608bfb276f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPlatDecls_f.h
@@ -0,0 +1,15 @@
+#ifndef TKPLATDECLS_VT
+#define TKPLATDECLS_VT
+#include "tkPlatDecls.h"
+typedef struct TkplatdeclsVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkPlatDecls.t"
+#undef VFUNC
+#undef VVAR
+} TkplatdeclsVtab;
+extern TkplatdeclsVtab *TkplatdeclsVptr;
+extern TkplatdeclsVtab *TkplatdeclsVGet(void);
+#endif /* TKPLATDECLS_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPort.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPort.h
new file mode 100755
index 00000000000..273c8f71e2a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkPort.h
@@ -0,0 +1,49 @@
+/*
+ * tkPort.h --
+ *
+ * This header file handles porting issues that occur because of
+ * differences between systems. It reads in platform specific
+ * portability files.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkPort.h,v 1.3 2002/08/31 06:12:26 das Exp $
+ */
+
+#ifndef _TKPORT
+#define _TKPORT
+
+#if defined(__WIN32__) || defined(_WIN32)
+#define NEED_REAL_STDIO
+#endif
+
+#ifndef _Lang
+#include "Lang.h"
+#endif
+
+#if defined(__WIN32__) || defined(_WIN32)
+# include "tkWinPort.h"
+# ifndef strcasecmp
+# define strcasecmp(a,b) stricmp(a,b)
+# endif
+# ifdef __CYGWIN__
+# undef strcasecmp
+# endif
+#else
+# if defined(MAC_TCL)
+# include "tkMacPort.h"
+# elif defined(MAC_OSX_TK)
+# include "../macosx/tkMacOSXPort.h"
+# else
+# ifdef __PM__
+# include "tkOS2Port.h"
+# else
+# include "tkUnixPort.h"
+# endif
+# endif
+#endif
+
+#endif /* _TKPORT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkScale.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkScale.h
new file mode 100755
index 00000000000..7936adfb18c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkScale.h
@@ -0,0 +1,257 @@
+/*
+ * tkScale.h --
+ *
+ * Declarations of types and functions used to implement
+ * the scale widget.
+ *
+ * Copyright (c) 1996 by Sun Microsystems, Inc.
+ * Copyright (c) 1999-2000 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkScale.h,v 1.8 2000/04/14 08:33:16 hobbs Exp $
+ */
+
+#ifndef _TKSCALE
+#define _TKSCALE
+
+#ifndef _TK
+#include "tk.h"
+#endif
+#include "tkVMacro.h"
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Legal values for the "orient" field of TkScale records.
+ */
+
+enum orient {
+ ORIENT_HORIZONTAL, ORIENT_VERTICAL
+};
+
+/*
+ * Legal values for the "state" field of TkScale records.
+ */
+
+enum state {
+ STATE_ACTIVE, STATE_DISABLED, STATE_NORMAL
+};
+
+/*
+ * A data structure of the following type is kept for each scale
+ * widget managed by this file:
+ */
+
+typedef struct TkScale {
+ Tk_Window tkwin; /* Window that embodies the scale. NULL
+ * means that the window has been destroyed
+ * but the data structures haven't yet been
+ * cleaned up.*/
+ Display *display; /* Display containing widget. Used, among
+ * other things, so that resources can be
+ * freed even after tkwin has gone away. */
+ Tcl_Interp *interp; /* Interpreter associated with scale. */
+ Tcl_Command widgetCmd; /* Token for scale's widget command. */
+ Tk_OptionTable optionTable; /* Table that defines configuration options
+ * available for this widget. */
+ enum orient orient; /* Orientation for window (vertical or
+ * horizontal). */
+ int width; /* Desired narrow dimension of scale,
+ * in pixels. */
+ int length; /* Desired long dimension of scale,
+ * in pixels. */
+ double value; /* Current value of scale. */
+ Tcl_Obj *varNamePtr; /* Name of variable or NULL.
+ * If non-NULL, scale's value tracks
+ * the contents of this variable and
+ * vice versa. */
+ double fromValue; /* Value corresponding to left or top of
+ * scale. */
+ double toValue; /* Value corresponding to right or bottom
+ * of scale. */
+ double tickInterval; /* Distance between tick marks;
+ * 0 means don't display any tick marks. */
+ double resolution; /* If > 0, all values are rounded to an
+ * even multiple of this value. */
+ int digits; /* Number of significant digits to print
+ * in values. 0 means we get to choose the
+ * number based on resolution and/or the
+ * range of the scale. */
+ char format[10]; /* Sprintf conversion specifier computed from
+ * digits and other information. */
+ double bigIncrement; /* Amount to use for large increments to
+ * scale value. (0 means we pick a value). */
+ Tcl_Obj *command; /* Command prefix to use when invoking Tcl
+ * commands because the scale value changed.
+ * NULL means don't invoke commands. */
+ int repeatDelay; /* How long to wait before auto-repeating
+ * on scrolling actions (in ms). */
+ int repeatInterval; /* Interval between autorepeats (in ms). */
+ char *label; /* Label to display above or to right of
+ * scale; NULL means don't display a label. */
+ int labelLength; /* Number of non-NULL chars. in label. */
+ enum state state; /* Values are active, normal, or disabled.
+ * Value of scale cannot be changed when
+ * disabled. */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ int borderWidth; /* Width of 3-D border around window. */
+ Tk_3DBorder bgBorder; /* Used for drawing slider and other
+ * background areas. */
+ Tk_3DBorder activeBorder; /* For drawing the slider when active. */
+ int sliderRelief; /* Is slider to be drawn raised, sunken,
+ * etc. */
+ XColor *troughColorPtr; /* Color for drawing trough. */
+ GC troughGC; /* For drawing trough. */
+ GC copyGC; /* Used for copying from pixmap onto screen. */
+ Tk_Font tkfont; /* Information about text font, or NULL. */
+ XColor *textColorPtr; /* Color for drawing text. */
+ GC textGC; /* GC for drawing text in normal mode. */
+ int relief; /* Indicates whether window as a whole is
+ * raised, sunken, or flat. */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ Tk_3DBorder highlightBorder;/* Value of -highlightbackground option:
+ * specifies background with which to draw 3-D
+ * default ring and focus highlight area when
+ * highlight is off. */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ int inset; /* Total width of all borders, including
+ * traversal highlight and 3-D border.
+ * Indicates how much interior stuff must
+ * be offset from outside edges to leave
+ * room for borders. */
+ int sliderLength; /* Length of slider, measured in pixels along
+ * long dimension of scale. */
+ int showValue; /* Non-zero means to display the scale value
+ * below or to the left of the slider; zero
+ * means don't display the value. */
+
+ /*
+ * Layout information for horizontal scales, assuming that window
+ * gets the size it requested:
+ */
+
+ int horizLabelY; /* Y-coord at which to draw label. */
+ int horizValueY; /* Y-coord at which to draw value text. */
+ int horizTroughY; /* Y-coord of top of slider trough. */
+ int horizTickY; /* Y-coord at which to draw tick text. */
+ /*
+ * Layout information for vertical scales, assuming that window
+ * gets the size it requested:
+ */
+
+ int vertTickRightX; /* X-location of right side of tick-marks. */
+ int vertValueRightX; /* X-location of right side of value string. */
+ int vertTroughX; /* X-location of scale's slider trough. */
+ int vertLabelX; /* X-location of origin of label. */
+
+ /*
+ * Miscellaneous information:
+ */
+
+ int fontHeight; /* Height of scale font. */
+ Tk_Cursor cursor; /* Current cursor for window, or None. */
+ Tcl_Obj *takeFocusPtr; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. May be NULL. */
+ int flags; /* Various flags; see below for
+ * definitions. */
+} TkScale;
+
+/*
+ * Flag bits for scales:
+ *
+ * REDRAW_SLIDER - 1 means slider (and numerical readout) need
+ * to be redrawn.
+ * REDRAW_OTHER - 1 means other stuff besides slider and value
+ * need to be redrawn.
+ * REDRAW_ALL - 1 means the entire widget needs to be redrawn.
+ * REDRAW_PENDING - 1 means any sort of redraw is pending
+ * ACTIVE - 1 means the widget is active (the mouse is
+ * in its window).
+ * INVOKE_COMMAND - 1 means the scale's command needs to be
+ * invoked during the next redisplay (the
+ * value of the scale has changed since the
+ * last time the command was invoked).
+ * SETTING_VAR - 1 means that the associated variable is
+ * being set by us, so there's no need for
+ * ScaleVarProc to do anything.
+ * NEVER_SET - 1 means that the scale's value has never
+ * been set before (so must invoke -command and
+ * set associated variable even if the value
+ * doesn't appear to have changed).
+ * GOT_FOCUS - 1 means that the focus is currently in
+ * this widget.
+ * SCALE_DELETED - 1 means the scale widget is being deleted
+ */
+
+#define REDRAW_SLIDER (1<<0)
+#define REDRAW_OTHER (1<<1)
+#define REDRAW_ALL (REDRAW_OTHER|REDRAW_SLIDER)
+#define REDRAW_PENDING (1<<2)
+#define ACTIVE (1<<3)
+#define INVOKE_COMMAND (1<<4)
+#define SETTING_VAR (1<<5)
+#define NEVER_SET (1<<6)
+#define GOT_FOCUS (1<<7)
+#define SCALE_DELETED (1<<8)
+
+/*
+ * Symbolic values for the active parts of a slider. These are
+ * the values that may be returned by the ScaleElement procedure.
+ */
+
+#define OTHER 0
+#define TROUGH1 1
+#define SLIDER 2
+#define TROUGH2 3
+
+/*
+ * Space to leave between scale area and text, and between text and
+ * edge of window.
+ */
+
+#define SPACING 2
+
+/*
+ * How many characters of space to provide when formatting the
+ * scale's value:
+ */
+
+#define PRINT_CHARS 150
+
+/*
+ * Declaration of procedures used in the implementation of the scale
+ * widget.
+ */
+
+EXTERN void TkEventuallyRedrawScale _ANSI_ARGS_((TkScale *scalePtr,
+ int what));
+EXTERN double TkRoundToResolution _ANSI_ARGS_((TkScale *scalePtr,
+ double value));
+EXTERN TkScale * TkpCreateScale _ANSI_ARGS_((Tk_Window tkwin));
+EXTERN void TkpDestroyScale _ANSI_ARGS_((TkScale *scalePtr));
+EXTERN void TkpDisplayScale _ANSI_ARGS_((ClientData clientData));
+EXTERN int TkpScaleElement _ANSI_ARGS_((TkScale *scalePtr,
+ int x, int y));
+EXTERN void TkScaleSetValue _ANSI_ARGS_((TkScale *scalePtr,
+ double value, int setVar, int invokeCommand));
+EXTERN double TkScalePixelToValue _ANSI_ARGS_((TkScale *scalePtr,
+ int x, int y));
+EXTERN int TkScaleValueToPixel _ANSI_ARGS_((TkScale *scalePtr,
+ double value));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKSCALE */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkScrollbar.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkScrollbar.h
new file mode 100755
index 00000000000..bf2472fad06
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkScrollbar.h
@@ -0,0 +1,209 @@
+/*
+ * tkScrollbar.h --
+ *
+ * Declarations of types and functions used to implement
+ * the scrollbar widget.
+ *
+ * Copyright (c) 1996 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkScrollbar.h,v 1.6 2000/11/22 01:49:38 ericm Exp $
+ */
+
+#ifndef _TKSCROLLBAR
+#define _TKSCROLLBAR
+
+#ifndef _TKINT
+#include "tkInt.h"
+#endif
+#include "tkVMacro.h"
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * A data structure of the following type is kept for each scrollbar
+ * widget.
+ */
+
+typedef struct TkScrollbar {
+ Tk_Window tkwin; /* Window that embodies the scrollbar. NULL
+ * means that the window has been destroyed
+ * but the data structures haven't yet been
+ * cleaned up.*/
+ Display *display; /* Display containing widget. Used, among
+ * other things, so that resources can be
+ * freed even after tkwin has gone away. */
+ Tcl_Interp *interp; /* Interpreter associated with scrollbar. */
+ Tcl_Command widgetCmd; /* Token for scrollbar's widget command. */
+ int vertical; /* Non-zero means vertical orientation
+ * requested, zero means horizontal. */
+ int width; /* Desired narrow dimension of scrollbar,
+ * in pixels. */
+ LangCallback *command; /* Command prefix to use when invoking
+ * scrolling commands. NULL means don't
+ * invoke commands. Malloc'ed. */
+#if 0
+ int commandSize; /* Number of non-NULL bytes in command. */
+#endif
+ int repeatDelay; /* How long to wait before auto-repeating
+ * on scrolling actions (in ms). */
+ int repeatInterval; /* Interval between autorepeats (in ms). */
+ int jump; /* Value of -jump option. */
+
+ /*
+ * Information used when displaying widget:
+ */
+
+ int borderWidth; /* Width of 3-D borders. */
+ Tk_3DBorder bgBorder; /* Used for drawing background (all flat
+ * surfaces except for trough). */
+ Tk_3DBorder activeBorder; /* For drawing backgrounds when active (i.e.
+ * when mouse is positioned over element). */
+ XColor *troughColorPtr; /* Color for drawing trough. */
+ int relief; /* Indicates whether window as a whole is
+ * raised, sunken, or flat. */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ XColor *highlightBgColorPtr;
+ /* Color for drawing traversal highlight
+ * area when highlight is off. */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ int inset; /* Total width of all borders, including
+ * traversal highlight and 3-D border.
+ * Indicates how much interior stuff must
+ * be offset from outside edges to leave
+ * room for borders. */
+ int elementBorderWidth; /* Width of border to draw around elements
+ * inside scrollbar (arrows and slider).
+ * -1 means use borderWidth. */
+ int arrowLength; /* Length of arrows along long dimension of
+ * scrollbar, including space for a small gap
+ * between the arrow and the slider.
+ * Recomputed on window size changes. */
+ int sliderFirst; /* Pixel coordinate of top or left edge
+ * of slider area, including border. */
+ int sliderLast; /* Coordinate of pixel just after bottom
+ * or right edge of slider area, including
+ * border. */
+ int activeField; /* Names field to be displayed in active
+ * colors, such as TOP_ARROW, or 0 for
+ * no field. */
+ int activeRelief; /* Value of -activeRelief option: relief
+ * to use for active element. */
+
+ /*
+ * Information describing the application related to the scrollbar.
+ * This information is provided by the application by invoking the
+ * "set" widget command. This information can now be provided in
+ * two ways: the "old" form (totalUnits, windowUnits, firstUnit,
+ * and lastUnit), or the "new" form (firstFraction and lastFraction).
+ * FirstFraction and lastFraction will always be valid, but
+ * the old-style information is only valid if the NEW_STYLE_COMMANDS
+ * flag is 0.
+ */
+
+ int totalUnits; /* Total dimension of application, in
+ * units. Valid only if the NEW_STYLE_COMMANDS
+ * flag isn't set. */
+ int windowUnits; /* Maximum number of units that can be
+ * displayed in the window at once. Valid
+ * only if the NEW_STYLE_COMMANDS flag isn't
+ * set. */
+ int firstUnit; /* Number of last unit visible in
+ * application's window. Valid only if the
+ * NEW_STYLE_COMMANDS flag isn't set. */
+ int lastUnit; /* Index of last unit visible in window.
+ * Valid only if the NEW_STYLE_COMMANDS
+ * flag isn't set. */
+ double firstFraction; /* Position of first visible thing in window,
+ * specified as a fraction between 0 and
+ * 1.0. */
+ double lastFraction; /* Position of last visible thing in window,
+ * specified as a fraction between 0 and
+ * 1.0. */
+
+ /*
+ * Miscellaneous information:
+ */
+
+ Tk_Cursor cursor; /* Current cursor for window, or None. */
+ char *takeFocus; /* Value of -takefocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+ int flags; /* Various flags; see below for
+ * definitions. */
+} TkScrollbar;
+
+/*
+ * Legal values for "activeField" field of Scrollbar structures. These
+ * are also the return values from the ScrollbarPosition procedure.
+ */
+
+#define OUTSIDE 0
+#define TOP_ARROW 1
+#define TOP_GAP 2
+#define SLIDER 3
+#define BOTTOM_GAP 4
+#define BOTTOM_ARROW 5
+
+/*
+ * Flag bits for scrollbars:
+ *
+ * REDRAW_PENDING: Non-zero means a DoWhenIdle handler
+ * has already been queued to redraw
+ * this window.
+ * NEW_STYLE_COMMANDS: Non-zero means the new style of commands
+ * should be used to communicate with the
+ * widget: ".t yview scroll 2 lines", instead
+ * of ".t yview 40", for example.
+ * GOT_FOCUS: Non-zero means this window has the input
+ * focus.
+ */
+
+#define REDRAW_PENDING 1
+#define NEW_STYLE_COMMANDS 2
+#define GOT_FOCUS 4
+
+/*
+ * Declaration of scrollbar class procedures structure.
+ */
+
+extern Tk_ClassProcs tkpScrollbarProcs;
+
+/*
+ * Declaration of scrollbar configuration options.
+ */
+
+extern Tk_ConfigSpec tkpScrollbarConfigSpecs[];
+
+/*
+ * Declaration of procedures used in the implementation of the scrollbar
+ * widget.
+ */
+
+EXTERN void TkScrollbarEventProc _ANSI_ARGS_((
+ ClientData clientData, XEvent *eventPtr));
+EXTERN void TkScrollbarEventuallyRedraw _ANSI_ARGS_((
+ TkScrollbar *scrollPtr));
+EXTERN void TkpComputeScrollbarGeometry _ANSI_ARGS_((
+ TkScrollbar *scrollPtr));
+EXTERN TkScrollbar * TkpCreateScrollbar _ANSI_ARGS_((Tk_Window tkwin));
+EXTERN void TkpDestroyScrollbar _ANSI_ARGS_((
+ TkScrollbar *scrollPtr));
+EXTERN void TkpDisplayScrollbar _ANSI_ARGS_((
+ ClientData clientData));
+EXTERN void TkpConfigureScrollbar _ANSI_ARGS_((
+ TkScrollbar *scrollPtr));
+EXTERN int TkpScrollbarPosition _ANSI_ARGS_((
+ TkScrollbar *scrollPtr, int x, int y));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKSCROLLBAR */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkSelect.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkSelect.h
new file mode 100755
index 00000000000..7ea06bb84bb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkSelect.h
@@ -0,0 +1,187 @@
+/*
+ * tkSelect.h --
+ *
+ * Declarations of types shared among the files that implement
+ * selection support.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkSelect.h,v 1.4 1999/05/25 20:40:54 stanton Exp $
+ */
+
+#ifndef _TKSELECT
+#define _TKSELECT
+
+/*
+ * When a selection is owned by a window on a given display, one of the
+ * following structures is present on a list of current selections in the
+ * display structure. The structure is used to record the current owner of
+ * a selection for use in later retrieval requests. There is a list of
+ * such structures because a display can have multiple different selections
+ * active at the same time.
+ */
+
+typedef struct TkSelectionInfo {
+ Atom selection; /* Selection name, e.g. XA_PRIMARY. */
+ Tk_Window owner; /* Current owner of this selection. */
+ int serial; /* Serial number of last XSelectionSetOwner
+ * request made to server for this
+ * selection (used to filter out redundant
+ * SelectionClear events). */
+ Time time; /* Timestamp used to acquire selection. */
+ Tk_LostSelProc *clearProc; /* Procedure to call when owner loses
+ * selection. */
+ ClientData clearData; /* Info to pass to clearProc. */
+ struct TkSelectionInfo *nextPtr;
+ /* Next in list of current selections on
+ * this display. NULL means end of list */
+} TkSelectionInfo;
+
+/*
+ * One of the following structures exists for each selection handler
+ * created for a window by calling Tk_CreateSelHandler. The handlers
+ * are linked in a list rooted in the TkWindow structure.
+ */
+
+typedef struct TkSelHandler {
+ Atom selection; /* Selection name, e.g. XA_PRIMARY */
+ Atom target; /* Target type for selection
+ * conversion, such as TARGETS or
+ * STRING. */
+ Atom format; /* Format in which selection
+ * info will be returned, such
+ * as STRING or ATOM. */
+ Tk_XSelectionProc *proc; /* Procedure to generate selection
+ * in this format. */
+ ClientData clientData; /* Argument to pass to proc. */
+ int size; /* Size of units returned by proc
+ * (8 for STRING, 32 for almost
+ * anything else). */
+ struct TkSelHandler *nextPtr;
+ /* Next selection handler associated
+ * with same window (NULL for end of
+ * list). */
+} TkSelHandler;
+
+/*
+ * When the selection is being retrieved, one of the following
+ * structures is present on a list of pending selection retrievals.
+ * The structure is used to communicate between the background
+ * procedure that requests the selection and the foreground
+ * event handler that processes the events in which the selection
+ * is returned. There is a list of such structures so that there
+ * can be multiple simultaneous selection retrievals (e.g. on
+ * different displays).
+ */
+
+typedef struct TkSelRetrievalInfo {
+ Tcl_Interp *interp; /* Interpreter for error reporting. */
+ TkWindow *winPtr; /* Window used as requestor for
+ * selection. */
+ Atom selection; /* Selection being requested. */
+ Atom property; /* Property where selection will appear. */
+ Atom target; /* Desired form for selection. */
+ Tk_GetXSelProc *proc; /* Procedure to call to handle pieces
+ * of selection. */
+ ClientData clientData; /* Argument for proc. */
+ int result; /* Initially -1. Set to a Tcl
+ * return value once the selection
+ * has been retrieved. */
+ Tcl_TimerToken timeout; /* Token for current timeout procedure. */
+ int idleTime; /* Number of seconds that have gone by
+ * without hearing anything from the
+ * selection owner. */
+ Tcl_EncodingState encState; /* Holds intermediate state during translations
+ * of data that cross buffer boundaries. */
+ int encFlags; /* Encoding translation state flags. */
+ Tcl_DString buf; /* Buffer to hold translation data. */
+ struct TkSelRetrievalInfo *nextPtr;
+ /* Next in list of all pending
+ * selection retrievals. NULL means
+ * end of list. */
+} TkSelRetrievalInfo;
+
+/*
+ * The clipboard contains a list of buffers of various types and formats.
+ * All of the buffers of a given type will be returned in sequence when the
+ * CLIPBOARD selection is retrieved. All buffers of a given type on the
+ * same clipboard must have the same format. The TkClipboardTarget structure
+ * is used to record the information about a chain of buffers of the same
+ * type.
+ */
+
+typedef struct TkClipboardBuffer {
+ char *buffer; /* Null terminated data buffer. */
+ long length; /* Length of string in buffer. */
+ struct TkClipboardBuffer *nextPtr; /* Next in list of buffers. NULL
+ * means end of list . */
+} TkClipboardBuffer;
+
+typedef struct TkClipboardTarget {
+ Atom type; /* Type conversion supported. */
+ Atom format; /* Representation used for data. */
+ TkClipboardBuffer *firstBufferPtr; /* First in list of data buffers. */
+ TkClipboardBuffer *lastBufferPtr; /* Last in list of clipboard buffers.
+ * Used to speed up appends. */
+ struct TkClipboardTarget *nextPtr; /* Next in list of targets on
+ * clipboard. NULL means end of
+ * list. */
+} TkClipboardTarget;
+
+/*
+ * It is possible for a Tk_SelectionProc to delete the handler that it
+ * represents. If this happens, the code that is retrieving the selection
+ * needs to know about it so it doesn't use the now-defunct handler
+ * structure. One structure of the following form is created for each
+ * retrieval in progress, so that the retriever can find out if its
+ * handler is deleted. All of the pending retrievals (if there are more
+ * than one) are linked into a list.
+ */
+
+typedef struct TkSelInProgress {
+ TkSelHandler *selPtr; /* Handler being executed. If this handler
+ * is deleted, the field is set to NULL. */
+ struct TkSelInProgress *nextPtr;
+ /* Next higher nested search. */
+} TkSelInProgress;
+
+/*
+ * Chunk size for retrieving selection. It's defined both in
+ * words and in bytes; the word size is used to allocate
+ * buffer space that's guaranteed to be word-aligned and that
+ * has an extra character for the terminating NULL.
+ */
+
+#define TK_SEL_BYTES_AT_ONCE 4000
+#define TK_SEL_WORDS_AT_ONCE 1001
+
+/*
+ * Declarations for procedures that are used by the selection-related files
+ * but shouldn't be used anywhere else in Tk (or by Tk clients):
+ */
+
+extern TkSelInProgress *
+ TkSelGetInProgress _ANSI_ARGS_((void));
+extern void TkSelSetInProgress _ANSI_ARGS_((
+ TkSelInProgress *pendingPtr));
+
+extern void TkSelClearSelection _ANSI_ARGS_((Tk_Window tkwin,
+ XEvent *eventPtr));
+extern int TkSelDefaultSelection _ANSI_ARGS_((
+ TkSelectionInfo *infoPtr, Atom target,
+ long *lbuffer, int maxBytes, Atom *typePtr, int *formatPtr));
+extern int TkSelGetSelection _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, Atom selection, Atom target,
+ Tk_GetXSelProc *proc, ClientData clientData));
+char * TkSelCvtFromX _ANSI_ARGS_((long *propPtr, int numValues,
+ Atom type, Tk_Window tkwin));
+int TkSelCvtToX _ANSI_ARGS_((long *buffer, char *string, Atom type,
+ Tk_Window tkwin, int maxBytes));
+#ifndef TkSelUpdateClipboard
+extern void TkSelUpdateClipboard _ANSI_ARGS_((TkWindow *winPtr,
+ TkClipboardTarget *targetPtr));
+#endif
+#endif /* _TKSELECT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkText.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkText.h
new file mode 100755
index 00000000000..0c715b6986e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkText.h
@@ -0,0 +1,927 @@
+/*
+ * tkText.h --
+ *
+ * Declarations shared among the files that implement text
+ * widgets.
+ *
+ * Copyright (c) 1992-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkText.h,v 1.13 2002/12/27 23:43:38 davygrvy Exp $
+ */
+
+#ifndef _TKTEXT
+#define _TKTEXT
+
+#ifndef _TK
+#include "tk.h"
+#endif
+
+#ifndef _TKUNDO
+#include "tkUndo.h"
+#endif
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * Opaque types for structures whose guts are only needed by a single
+ * file:
+ */
+
+typedef struct TkTextBTree_ *TkTextBTree;
+
+/*
+ * The data structure below defines a single line of text (from newline
+ * to newline, not necessarily what appears on one line of the screen).
+ */
+
+typedef struct TkTextLine {
+ struct Node *parentPtr; /* Pointer to parent node containing
+ * line. */
+ struct TkTextLine *nextPtr; /* Next in linked list of lines with
+ * same parent node in B-tree. NULL
+ * means end of list. */
+ struct TkTextSegment *segPtr; /* First in ordered list of segments
+ * that make up the line. */
+} TkTextLine;
+
+/*
+ * -----------------------------------------------------------------------
+ * Segments: each line is divided into one or more segments, where each
+ * segment is one of several things, such as a group of characters, a
+ * tag toggle, a mark, or an embedded widget. Each segment starts with
+ * a standard header followed by a body that varies from type to type.
+ * -----------------------------------------------------------------------
+ */
+
+/*
+ * The data structure below defines the body of a segment that represents
+ * a tag toggle. There is one of these structures at both the beginning
+ * and end of each tagged range.
+ */
+
+typedef struct TkTextToggle {
+ struct TkTextTag *tagPtr; /* Tag that starts or ends here. */
+ int inNodeCounts; /* 1 means this toggle has been
+ * accounted for in node toggle
+ * counts; 0 means it hasn't, yet. */
+} TkTextToggle;
+
+/*
+ * The data structure below defines line segments that represent
+ * marks. There is one of these for each mark in the text.
+ */
+
+typedef struct TkTextMark {
+ struct TkText *textPtr; /* Overall information about text
+ * widget. */
+ TkTextLine *linePtr; /* Line structure that contains the
+ * segment. */
+ Tcl_HashEntry *hPtr; /* Pointer to hash table entry for mark
+ * (in textPtr->markTable). */
+} TkTextMark;
+
+/*
+ * A structure of the following type holds information for each window
+ * embedded in a text widget. This information is only used by the
+ * file tkTextWind.c
+ */
+
+typedef struct TkTextEmbWindow {
+ struct TkText *textPtr; /* Information about the overall text
+ * widget. */
+ TkTextLine *linePtr; /* Line structure that contains this
+ * window. */
+ Tk_Window tkwin; /* Window for this segment. NULL
+ * means that the window hasn't
+ * been created yet. */
+ LangCallback *create; /* Script to create window on-demand.
+ * NULL means no such script.
+ * Malloc-ed. */
+ int align; /* How to align window in vertical
+ * space. See definitions in
+ * tkTextWind.c. */
+ int padX, padY; /* Padding to leave around each side
+ * of window, in pixels. */
+ int stretch; /* Should window stretch to fill
+ * vertical space of line (except for
+ * pady)? 0 or 1. */
+ int chunkCount; /* Number of display chunks that
+ * refer to this window. */
+ int displayed; /* Non-zero means that the window
+ * has been displayed on the screen
+ * recently. */
+} TkTextEmbWindow;
+
+/*
+ * A structure of the following type holds information for each image
+ * embedded in a text widget. This information is only used by the
+ * file tkTextImage.c
+ */
+
+typedef struct TkTextEmbImage {
+ struct TkText *textPtr; /* Information about the overall text
+ * widget. */
+ TkTextLine *linePtr; /* Line structure that contains this
+ * image. */
+ char *imageString; /* Name of the image for this segment */
+ char *imageName; /* Name used by text widget to identify
+ * this image. May be unique-ified */
+ char *name; /* Name used in the hash table.
+ * used by "image names" to identify
+ * this instance of the image */
+ Tk_Image image; /* Image for this segment. NULL
+ * means that the image hasn't
+ * been created yet. */
+ int align; /* How to align image in vertical
+ * space. See definitions in
+ * tkTextImage.c. */
+ int padX, padY; /* Padding to leave around each side
+ * of image, in pixels. */
+ int chunkCount; /* Number of display chunks that
+ * refer to this image. */
+} TkTextEmbImage;
+
+/*
+ * The data structure below defines line segments.
+ */
+
+typedef struct TkTextSegment {
+ struct Tk_SegType *typePtr; /* Pointer to record describing
+ * segment's type. */
+ struct TkTextSegment *nextPtr; /* Next in list of segments for this
+ * line, or NULL for end of list. */
+ int size; /* Size of this segment (# of bytes
+ * of index space it occupies). */
+ union {
+ char chars[4]; /* Characters that make up character
+ * info. Actual length varies to
+ * hold as many characters as needed.*/
+ TkTextToggle toggle; /* Information about tag toggle. */
+ TkTextMark mark; /* Information about mark. */
+ TkTextEmbWindow ew; /* Information about embedded
+ * window. */
+ TkTextEmbImage ei; /* Information about embedded
+ * image. */
+ } body;
+} TkTextSegment;
+
+/*
+ * Data structures of the type defined below are used during the
+ * execution of Tcl commands to keep track of various interesting
+ * places in a text. An index is only valid up until the next
+ * modification to the character structure of the b-tree so they
+ * can't be retained across Tcl commands. However, mods to marks
+ * or tags don't invalidate indices.
+ */
+
+typedef struct TkTextIndex {
+ TkTextBTree tree; /* Tree containing desired position. */
+ TkTextLine *linePtr; /* Pointer to line containing position
+ * of interest. */
+ int byteIndex; /* Index within line of desired
+ * character (0 means first one). */
+} TkTextIndex;
+
+/*
+ * Types for procedure pointers stored in TkTextDispChunk strutures:
+ */
+
+typedef struct TkTextDispChunk TkTextDispChunk;
+
+typedef void Tk_ChunkDisplayProc _ANSI_ARGS_((
+ TkTextDispChunk *chunkPtr, int x, int y,
+ int height, int baseline, Display *display,
+ Drawable dst, int screenY));
+typedef void Tk_ChunkUndisplayProc _ANSI_ARGS_((
+ struct TkText *textPtr,
+ TkTextDispChunk *chunkPtr));
+typedef int Tk_ChunkMeasureProc _ANSI_ARGS_((
+ TkTextDispChunk *chunkPtr, int x));
+typedef void Tk_ChunkBboxProc _ANSI_ARGS_((
+ TkTextDispChunk *chunkPtr, int index, int y,
+ int lineHeight, int baseline, int *xPtr,
+ int *yPtr, int *widthPtr, int *heightPtr));
+
+/*
+ * The structure below represents a chunk of stuff that is displayed
+ * together on the screen. This structure is allocated and freed by
+ * generic display code but most of its fields are filled in by
+ * segment-type-specific code.
+ */
+
+struct TkTextDispChunk {
+ /*
+ * The fields below are set by the type-independent code before
+ * calling the segment-type-specific layoutProc. They should not
+ * be modified by segment-type-specific code.
+ */
+
+ int x; /* X position of chunk, in pixels.
+ * This position is measured from the
+ * left edge of the logical line,
+ * not from the left edge of the
+ * window (i.e. it doesn't change
+ * under horizontal scrolling). */
+ struct TkTextDispChunk *nextPtr; /* Next chunk in the display line
+ * or NULL for the end of the list. */
+ struct TextStyle *stylePtr; /* Display information, known only
+ * to tkTextDisp.c. */
+
+ /*
+ * The fields below are set by the layoutProc that creates the
+ * chunk.
+ */
+
+ Tk_ChunkDisplayProc *displayProc; /* Procedure to invoke to draw this
+ * chunk on the display or an
+ * off-screen pixmap. */
+ Tk_ChunkUndisplayProc *undisplayProc;
+ /* Procedure to invoke when segment
+ * ceases to be displayed on screen
+ * anymore. */
+ Tk_ChunkMeasureProc *measureProc; /* Procedure to find character under
+ * a given x-location. */
+ Tk_ChunkBboxProc *bboxProc; /* Procedure to find bounding box
+ * of character in chunk. */
+ int numBytes; /* Number of bytes that will be
+ * displayed in the chunk. */
+ int minAscent; /* Minimum space above the baseline
+ * needed by this chunk. */
+ int minDescent; /* Minimum space below the baseline
+ * needed by this chunk. */
+ int minHeight; /* Minimum total line height needed
+ * by this chunk. */
+ int width; /* Width of this chunk, in pixels.
+ * Initially set by chunk-specific
+ * code, but may be increased to
+ * include tab or extra space at end
+ * of line. */
+ int breakIndex; /* Index within chunk of last
+ * acceptable position for a line
+ * (break just before this byte index).
+ * <= 0 means don't break during or
+ * immediately after this chunk. */
+ ClientData clientData; /* Additional information for use
+ * of displayProc and undisplayProc. */
+};
+
+/*
+ * One data structure of the following type is used for each tag in a
+ * text widget. These structures are kept in textPtr->tagTable and
+ * referred to in other structures.
+ */
+
+typedef enum { TEXT_WRAPMODE_NULL, TEXT_WRAPMODE_NONE,
+ TEXT_WRAPMODE_CHAR, TEXT_WRAPMODE_WORD
+} TkWrapMode;
+
+EXTERN Tk_CustomOption textWrapModeOption;
+
+typedef struct TkTextTag {
+ char *name; /* Name of this tag. This field is actually
+ * a pointer to the key from the entry in
+ * textPtr->tagTable, so it needn't be freed
+ * explicitly. */
+ int priority; /* Priority of this tag within widget. 0
+ * means lowest priority. Exactly one tag
+ * has each integer value between 0 and
+ * numTags-1. */
+ struct Node *tagRootPtr; /* Pointer into the B-Tree at the lowest
+ * node that completely dominates the ranges
+ * of text occupied by the tag. At this
+ * node there is no information about the
+ * tag. One or more children of the node
+ * do contain information about the tag. */
+ int toggleCount; /* Total number of tag toggles */
+
+ /*
+ * Information for displaying text with this tag. The information
+ * belows acts as an override on information specified by lower-priority
+ * tags. If no value is specified, then the next-lower-priority tag
+ * on the text determins the value. The text widget itself provides
+ * defaults if no tag specifies an override.
+ */
+
+ Tk_3DBorder border; /* Used for drawing background. NULL means
+ * no value specified here. */
+ char *bdString; /* -borderwidth option string (malloc-ed).
+ * NULL means option not specified. */
+ int borderWidth; /* Width of 3-D border for background. */
+ char *reliefString; /* -relief option string (malloc-ed).
+ * NULL means option not specified. */
+ int relief; /* 3-D relief for background. */
+ Pixmap bgStipple; /* Stipple bitmap for background. None
+ * means no value specified here. */
+ XColor *fgColor; /* Foreground color for text. NULL means
+ * no value specified here. */
+ Tk_Font tkfont; /* Font for displaying text. NULL means
+ * no value specified here. */
+ Pixmap fgStipple; /* Stipple bitmap for text and other
+ * foreground stuff. None means no value
+ * specified here.*/
+ char *justifyString; /* -justify option string (malloc-ed).
+ * NULL means option not specified. */
+ Tk_Justify justify; /* How to justify text: TK_JUSTIFY_LEFT,
+ * TK_JUSTIFY_RIGHT, or TK_JUSTIFY_CENTER.
+ * Only valid if justifyString is non-NULL. */
+ char *lMargin1String; /* -lmargin1 option string (malloc-ed).
+ * NULL means option not specified. */
+ int lMargin1; /* Left margin for first display line of
+ * each text line, in pixels. Only valid
+ * if lMargin1String is non-NULL. */
+ char *lMargin2String; /* -lmargin2 option string (malloc-ed).
+ * NULL means option not specified. */
+ int lMargin2; /* Left margin for second and later display
+ * lines of each text line, in pixels. Only
+ * valid if lMargin2String is non-NULL. */
+ char *offsetString; /* -offset option string (malloc-ed).
+ * NULL means option not specified. */
+ int offset; /* Vertical offset of text's baseline from
+ * baseline of line. Used for superscripts
+ * and subscripts. Only valid if
+ * offsetString is non-NULL. */
+ Tcl_Obj * overstrikeString; /* -overstrike option string (malloc-ed).
+ * NULL means option not specified. */
+ int overstrike; /* Non-zero means draw horizontal line through
+ * middle of text. Only valid if
+ * overstrikeString is non-NULL. */
+ char *rMarginString; /* -rmargin option string (malloc-ed).
+ * NULL means option not specified. */
+ int rMargin; /* Right margin for text, in pixels. Only
+ * valid if rMarginString is non-NULL. */
+ char *spacing1String; /* -spacing1 option string (malloc-ed).
+ * NULL means option not specified. */
+ int spacing1; /* Extra spacing above first display
+ * line for text line. Only valid if
+ * spacing1String is non-NULL. */
+ char *spacing2String; /* -spacing2 option string (malloc-ed).
+ * NULL means option not specified. */
+ int spacing2; /* Extra spacing between display
+ * lines for the same text line. Only valid
+ * if spacing2String is non-NULL. */
+ char *spacing3String; /* -spacing2 option string (malloc-ed).
+ * NULL means option not specified. */
+ int spacing3; /* Extra spacing below last display
+ * line for text line. Only valid if
+ * spacing3String is non-NULL. */
+ Tcl_Obj * tabString; /* -tabs option string (malloc-ed).
+ * NULL means option not specified. */
+ struct TkTextTabArray *tabArrayPtr;
+ /* Info about tabs for tag (malloc-ed)
+ * or NULL. Corresponds to tabString. */
+ Tcl_Obj * underlineString; /* -underline option string (malloc-ed).
+ * NULL means option not specified. */
+ int underline; /* Non-zero means draw underline underneath
+ * text. Only valid if underlineString is
+ * non-NULL. */
+ TkWrapMode wrapMode; /* How to handle wrap-around for this tag.
+ * Must be TEXT_WRAPMODE_CHAR,
+ * TEXT_WRAPMODE_NONE, TEXT_WRAPMODE_WORD,
+ * or TEXT_WRAPMODE_NULL to use wrapmode for
+ * whole widget. */
+ Tcl_Obj * elideString; /* -elide option string (malloc-ed).
+ * NULL means option not specified. */
+ int elide; /* Non-zero means that data under this tag
+ * should not be displayed. */
+ int affectsDisplay; /* Non-zero means that this tag affects the
+ * way information is displayed on the screen
+ * (so need to redisplay if tag changes). */
+ Tcl_Obj * userData; /* arbitary user data */
+} TkTextTag;
+
+#define TK_TAG_AFFECTS_DISPLAY 0x1
+#define TK_TAG_UNDERLINE 0x2
+#define TK_TAG_JUSTIFY 0x4
+#define TK_TAG_OFFSET 0x10
+
+/*
+ * The data structure below is used for searching a B-tree for transitions
+ * on a single tag (or for all tag transitions). No code outside of
+ * tkTextBTree.c should ever modify any of the fields in these structures,
+ * but it's OK to use them for read-only information.
+ */
+
+typedef struct TkTextSearch {
+ TkTextIndex curIndex; /* Position of last tag transition
+ * returned by TkBTreeNextTag, or
+ * index of start of segment
+ * containing starting position for
+ * search if TkBTreeNextTag hasn't
+ * been called yet, or same as
+ * stopIndex if search is over. */
+ TkTextSegment *segPtr; /* Actual tag segment returned by last
+ * call to TkBTreeNextTag, or NULL if
+ * TkBTreeNextTag hasn't returned
+ * anything yet. */
+ TkTextSegment *nextPtr; /* Where to resume search in next
+ * call to TkBTreeNextTag. */
+ TkTextSegment *lastPtr; /* Stop search before just before
+ * considering this segment. */
+ TkTextTag *tagPtr; /* Tag to search for (or tag found, if
+ * allTags is non-zero). */
+ int linesLeft; /* Lines left to search (including
+ * curIndex and stopIndex). When
+ * this becomes <= 0 the search is
+ * over. */
+ int allTags; /* Non-zero means ignore tag check:
+ * search for transitions on all
+ * tags. */
+} TkTextSearch;
+
+/*
+ * The following data structure describes a single tab stop.
+ */
+
+typedef enum {LEFT, RIGHT, CENTER, NUMERIC} TkTextTabAlign;
+
+typedef struct TkTextTab {
+ int location; /* Offset in pixels of this tab stop
+ * from the left margin (lmargin2) of
+ * the text. */
+ TkTextTabAlign alignment; /* Where the tab stop appears relative
+ * to the text. */
+} TkTextTab;
+
+typedef struct TkTextTabArray {
+ int numTabs; /* Number of tab stops. */
+ TkTextTab tabs[1]; /* Array of tabs. The actual size
+ * will be numTabs. THIS FIELD MUST
+ * BE THE LAST IN THE STRUCTURE. */
+} TkTextTabArray;
+
+/* enum definining the edit modes of */
+
+typedef enum {
+ TK_TEXT_EDIT_INSERT, /* insert mode */
+ TK_TEXT_EDIT_DELETE, /* delete mode */
+ TK_TEXT_EDIT_OTHER /* none of the above */
+} TkTextEditMode;
+
+/*
+ * A data structure of the following type is kept for each text widget that
+ * currently exists for this process:
+ */
+
+typedef struct TkText {
+ Tk_Window tkwin; /* Window that embodies the text. NULL
+ * means that the window has been destroyed
+ * but the data structures haven't yet been
+ * cleaned up.*/
+ Display *display; /* Display for widget. Needed, among other
+ * things, to allow resources to be freed
+ * even after tkwin has gone away. */
+ Tcl_Interp *interp; /* Interpreter associated with widget. Used
+ * to delete widget command. */
+ Tcl_Command widgetCmd; /* Token for text's widget command. */
+ TkTextBTree tree; /* B-tree representation of text and tags for
+ * widget. */
+ Tcl_HashTable tagTable; /* Hash table that maps from tag names to
+ * pointers to TkTextTag structures. */
+ int numTags; /* Number of tags currently defined for
+ * widget; needed to keep track of
+ * priorities. */
+ Tcl_HashTable markTable; /* Hash table that maps from mark names to
+ * pointers to mark segments. */
+ Tcl_HashTable windowTable; /* Hash table that maps from window names
+ * to pointers to window segments. If a
+ * window segment doesn't yet have an
+ * associated window, there is no entry for
+ * it here. */
+ Tcl_HashTable imageTable; /* Hash table that maps from image names
+ * to pointers to image segments. If an
+ * image segment doesn't yet have an
+ * associated image, there is no entry for
+ * it here. */
+ int state; /* Either STATE_NORMAL or STATE_DISABLED. A
+ * text widget is read-only when disabled. */
+
+ /*
+ * Default information for displaying (may be overridden by tags
+ * applied to ranges of characters).
+ */
+
+ Tk_3DBorder border; /* Structure used to draw 3-D border and
+ * default background. */
+ int borderWidth; /* Width of 3-D border to draw around entire
+ * widget. */
+ int padX, padY; /* Padding between text and window border. */
+ int relief; /* 3-d effect for border around entire
+ * widget: TK_RELIEF_RAISED etc. */
+ int highlightWidth; /* Width in pixels of highlight to draw
+ * around widget when it has the focus.
+ * <= 0 means don't draw a highlight. */
+ XColor *highlightBgColorPtr;
+ /* Color for drawing traversal highlight
+ * area when highlight is off. */
+ XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
+ Tk_Cursor cursor; /* Current cursor for window, or None. */
+ XColor *fgColor; /* Default foreground color for text. */
+ Tk_Font tkfont; /* Default font for displaying text. */
+ int charWidth; /* Width of average character in default
+ * font. */
+ int spacing1; /* Default extra spacing above first display
+ * line for each text line. */
+ int spacing2; /* Default extra spacing between display lines
+ * for the same text line. */
+ int spacing3; /* Default extra spacing below last display
+ * line for each text line. */
+ Tcl_Obj * tabOptionString; /* Value of -tabs option string (malloc'ed). */
+ TkTextTabArray *tabArrayPtr;
+ /* Information about tab stops (malloc'ed).
+ * NULL means perform default tabbing
+ * behavior. */
+
+ /*
+ * Additional information used for displaying:
+ */
+
+ TkWrapMode wrapMode; /* How to handle wrap-around. Must be
+ * TEXT_WRAPMODE_CHAR, TEXT_WRAPMODE_NONE, or
+ * TEXT_WRAPMODE_WORD. */
+ int width, height; /* Desired dimensions for window, measured
+ * in characters. */
+ int setGrid; /* Non-zero means pass gridding information
+ * to window manager. */
+ int prevWidth, prevHeight; /* Last known dimensions of window; used to
+ * detect changes in size. */
+ TkTextIndex topIndex; /* Identifies first character in top display
+ * line of window. */
+ struct TextDInfo *dInfoPtr; /* Information maintained by tkTextDisp.c. */
+
+ /*
+ * Information related to selection.
+ */
+
+ TkTextTag *selTagPtr; /* Pointer to "sel" tag. Used to tell when
+ * a new selection has been made. */
+ Tk_3DBorder selBorder; /* Border and background for selected
+ * characters. This is a copy of information
+ * in *cursorTagPtr, so it shouldn't be
+ * explicitly freed. */
+ char *selBdString; /* Value of -selectborderwidth option, or NULL
+ * if not specified (malloc'ed). */
+ XColor *selFgColorPtr; /* Foreground color for selected text.
+ * This is a copy of information in
+ * *cursorTagPtr, so it shouldn't be
+ * explicitly freed. */
+ int exportSelection; /* Non-zero means tie "sel" tag to X
+ * selection. */
+ TkTextIndex selIndex; /* Used during multi-pass selection retrievals.
+ * This index identifies the next character
+ * to be returned from the selection. */
+ int abortSelections; /* Set to 1 whenever the text is modified
+ * in a way that interferes with selection
+ * retrieval: used to abort incremental
+ * selection retrievals. */
+ int selOffset; /* Offset in selection corresponding to
+ * selLine and selCh. -1 means neither
+ * this information nor selIndex is of any
+ * use. */
+
+ /*
+ * Information related to insertion cursor:
+ */
+
+ TkTextSegment *insertMarkPtr;
+ /* Points to segment for "insert" mark. */
+ Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion
+ * cursor. */
+ int insertWidth; /* Total width of insert cursor. */
+ int insertBorderWidth; /* Width of 3-D border around insert cursor. */
+ int insertOnTime; /* Number of milliseconds cursor should spend
+ * in "on" state for each blink. */
+ int insertOffTime; /* Number of milliseconds cursor should spend
+ * in "off" state for each blink. */
+ Tcl_TimerToken insertBlinkHandler;
+ /* Timer handler used to blink cursor on and
+ * off. */
+
+ /*
+ * Information used for event bindings associated with tags:
+ */
+
+ Tk_BindingTable bindingTable;
+ /* Table of all bindings currently defined
+ * for this widget. NULL means that no
+ * bindings exist, so the table hasn't been
+ * created. Each "object" used for this
+ * table is the address of a tag. */
+ TkTextSegment *currentMarkPtr;
+ /* Pointer to segment for "current" mark,
+ * or NULL if none. */
+ XEvent pickEvent; /* The event from which the current character
+ * was chosen. Must be saved so that we
+ * can repick after modifications to the
+ * text. */
+ int numCurTags; /* Number of tags associated with character
+ * at current mark. */
+ TkTextTag **curTagArrayPtr; /* Pointer to array of tags for current
+ * mark, or NULL if none. */
+
+ /*
+ * Miscellaneous additional information:
+ */
+
+ char *takeFocus; /* Value of -takeFocus option; not used in
+ * the C code, but used by keyboard traversal
+ * scripts. Malloc'ed, but may be NULL. */
+ LangCallback *xScrollCmd; /* Prefix of command to issue to update
+ * horizontal scrollbar when view changes. */
+ LangCallback *yScrollCmd; /* Prefix of command to issue to update
+ * vertical scrollbar when view changes. */
+ int flags; /* Miscellaneous flags; see below for
+ * definitions. */
+
+ /*
+ * Information related to the undo/redo functonality
+ */
+
+ TkUndoRedoStack * undoStack; /* The undo/redo stack */
+
+ int undo; /* non zero means the undo/redo behaviour is
+ * enabled */
+
+ int maxUndo; /* The maximum depth of the undo stack expressed
+ * as the maximum number of compound statements */
+
+ int autoSeparators; /* non zero means the separatorss will be
+ * inserted automatically */
+
+ int modifiedSet; /* Flag indicating that the 'dirtynesss' of
+ * the text widget has been expplicitly set.
+ */
+
+ int isDirty; /* Flag indicating the 'dirtynesss' of the text
+ * widget. If the flag is not zero, unsaved
+ * modifications have been applied to the
+ * text widget */
+
+ int isDirtyIncrement; /* Amount with which the isDirty flag is
+ * incremented every edit action
+ */
+
+ TkTextEditMode lastEditMode; /* Keeps track of what the last edit mode was
+ */
+
+} TkText;
+
+/*
+ * Flag values for TkText records:
+ *
+ * GOT_SELECTION: Non-zero means we've already claimed the
+ * selection.
+ * INSERT_ON: Non-zero means insertion cursor should be
+ * displayed on screen.
+ * GOT_FOCUS: Non-zero means this window has the input
+ * focus.
+ * BUTTON_DOWN: 1 means that a mouse button is currently
+ * down; this is used to implement grabs
+ * for the duration of button presses.
+ * UPDATE_SCROLLBARS: Non-zero means scrollbar(s) should be updated
+ * during next redisplay operation.
+ */
+
+#define GOT_SELECTION 1
+#define INSERT_ON 2
+#define GOT_FOCUS 4
+#define BUTTON_DOWN 8
+#define UPDATE_SCROLLBARS 0x10
+#define NEED_REPICK 0x20
+
+/*
+ * Records of the following type define segment types in terms of
+ * a collection of procedures that may be called to manipulate
+ * segments of that type.
+ */
+
+typedef TkTextSegment * Tk_SegSplitProc _ANSI_ARGS_((
+ struct TkTextSegment *segPtr, int index));
+typedef int Tk_SegDeleteProc _ANSI_ARGS_((
+ struct TkTextSegment *segPtr,
+ TkTextLine *linePtr, int treeGone));
+typedef TkTextSegment * Tk_SegCleanupProc _ANSI_ARGS_((
+ struct TkTextSegment *segPtr, TkTextLine *linePtr));
+typedef void Tk_SegLineChangeProc _ANSI_ARGS_((
+ struct TkTextSegment *segPtr, TkTextLine *linePtr));
+typedef int Tk_SegLayoutProc _ANSI_ARGS_((struct TkText *textPtr,
+ struct TkTextIndex *indexPtr, TkTextSegment *segPtr,
+ int offset, int maxX, int maxChars,
+ int noCharsYet, TkWrapMode wrapMode,
+ struct TkTextDispChunk *chunkPtr));
+typedef void Tk_SegCheckProc _ANSI_ARGS_((TkTextSegment *segPtr,
+ TkTextLine *linePtr));
+
+typedef struct Tk_SegType {
+ char *name; /* Name of this kind of segment. */
+ int leftGravity; /* If a segment has zero size (e.g. a
+ * mark or tag toggle), does it
+ * attach to character to its left
+ * or right? 1 means left, 0 means
+ * right. */
+ Tk_SegSplitProc *splitProc; /* Procedure to split large segment
+ * into two smaller ones. */
+ Tk_SegDeleteProc *deleteProc; /* Procedure to call to delete
+ * segment. */
+ Tk_SegCleanupProc *cleanupProc; /* After any change to a line, this
+ * procedure is invoked for all
+ * segments left in the line to
+ * perform any cleanup they wish
+ * (e.g. joining neighboring
+ * segments). */
+ Tk_SegLineChangeProc *lineChangeProc;
+ /* Invoked when a segment is about
+ * to be moved from its current line
+ * to an earlier line because of
+ * a deletion. The linePtr is that
+ * for the segment's old line.
+ * CleanupProc will be invoked after
+ * the deletion is finished. */
+ Tk_SegLayoutProc *layoutProc; /* Returns size information when
+ * figuring out what to display in
+ * window. */
+ Tk_SegCheckProc *checkProc; /* Called during consistency checks
+ * to check internal consistency of
+ * segment. */
+} Tk_SegType;
+
+/*
+ * The constant below is used to specify a line when what is really
+ * wanted is the entire text. For now, just use a very big number.
+ */
+
+#define TK_END_OF_TEXT 1000000
+
+/*
+ * The following definition specifies the maximum number of characters
+ * needed in a string to hold a position specifier.
+ */
+
+#define TK_POS_CHARS 30
+
+/*
+ * Declarations for variables shared among the text-related files:
+ */
+
+EXTERN int tkBTreeDebug;
+EXTERN int tkTextDebug;
+EXTERN Tk_SegType tkTextCharType;
+EXTERN Tk_SegType tkTextLeftMarkType;
+EXTERN Tk_SegType tkTextRightMarkType;
+EXTERN Tk_SegType tkTextToggleOnType;
+EXTERN Tk_SegType tkTextToggleOffType;
+
+/*
+ * Declarations for procedures that are used by the text-related files
+ * but shouldn't be used anywhere else in Tk (or by Tk clients):
+ */
+
+EXTERN int TkBTreeCharTagged _ANSI_ARGS_((TkTextIndex *indexPtr,
+ TkTextTag *tagPtr));
+EXTERN void TkBTreeCheck _ANSI_ARGS_((TkTextBTree tree));
+EXTERN int TkBTreeCharsInLine _ANSI_ARGS_((TkTextLine *linePtr));
+EXTERN int TkBTreeBytesInLine _ANSI_ARGS_((TkTextLine *linePtr));
+EXTERN TkTextBTree TkBTreeCreate _ANSI_ARGS_((TkText *textPtr));
+EXTERN void TkBTreeDestroy _ANSI_ARGS_((TkTextBTree tree));
+EXTERN void TkBTreeDeleteChars _ANSI_ARGS_((TkTextIndex *index1Ptr,
+ TkTextIndex *index2Ptr));
+EXTERN TkTextLine * TkBTreeFindLine _ANSI_ARGS_((TkTextBTree tree,
+ int line));
+EXTERN TkTextTag ** TkBTreeGetTags _ANSI_ARGS_((TkTextIndex *indexPtr,
+ int *numTagsPtr));
+EXTERN void TkBTreeInsertChars _ANSI_ARGS_((TkTextIndex *indexPtr,
+ CONST char *string));
+EXTERN int TkBTreeLineIndex _ANSI_ARGS_((TkTextLine *linePtr));
+EXTERN void TkBTreeLinkSegment _ANSI_ARGS_((TkTextSegment *segPtr,
+ TkTextIndex *indexPtr));
+EXTERN TkTextLine * TkBTreeNextLine _ANSI_ARGS_((TkTextLine *linePtr));
+EXTERN int TkBTreeNextTag _ANSI_ARGS_((TkTextSearch *searchPtr));
+EXTERN int TkBTreeNumLines _ANSI_ARGS_((TkTextBTree tree));
+EXTERN TkTextLine * TkBTreePreviousLine _ANSI_ARGS_((TkTextLine *linePtr));
+EXTERN int TkBTreePrevTag _ANSI_ARGS_((TkTextSearch *searchPtr));
+EXTERN void TkBTreeStartSearch _ANSI_ARGS_((TkTextIndex *index1Ptr,
+ TkTextIndex *index2Ptr, TkTextTag *tagPtr,
+ TkTextSearch *searchPtr));
+EXTERN void TkBTreeStartSearchBack _ANSI_ARGS_((TkTextIndex *index1Ptr,
+ TkTextIndex *index2Ptr, TkTextTag *tagPtr,
+ TkTextSearch *searchPtr));
+EXTERN void TkBTreeTag _ANSI_ARGS_((TkTextIndex *index1Ptr,
+ TkTextIndex *index2Ptr, TkTextTag *tagPtr,
+ int add));
+EXTERN void TkBTreeUnlinkSegment _ANSI_ARGS_((TkTextBTree tree,
+ TkTextSegment *segPtr, TkTextLine *linePtr));
+EXTERN void TkTextBindProc _ANSI_ARGS_((ClientData clientData,
+ XEvent *eventPtr));
+EXTERN void TkTextChanged _ANSI_ARGS_((TkText *textPtr,
+ TkTextIndex *index1Ptr, TkTextIndex *index2Ptr));
+EXTERN int TkTextCharBbox _ANSI_ARGS_((TkText *textPtr,
+ TkTextIndex *indexPtr, int *xPtr, int *yPtr,
+ int *widthPtr, int *heightPtr));
+EXTERN int TkTextCharLayoutProc _ANSI_ARGS_((TkText *textPtr,
+ TkTextIndex *indexPtr, TkTextSegment *segPtr,
+ int offset, int maxX, int maxChars, int noBreakYet,
+ TkWrapMode wrapMode, TkTextDispChunk *chunkPtr));
+EXTERN void TkTextCreateDInfo _ANSI_ARGS_((TkText *textPtr));
+EXTERN int TkTextDLineInfo _ANSI_ARGS_((TkText *textPtr,
+ TkTextIndex *indexPtr, int *xPtr, int *yPtr,
+ int *widthPtr, int *heightPtr, int *basePtr));
+EXTERN TkTextTag * TkTextCreateTag _ANSI_ARGS_((TkText *textPtr,
+ CONST char *tagName));
+EXTERN void TkTextFreeDInfo _ANSI_ARGS_((TkText *textPtr));
+EXTERN void TkTextFreeTag _ANSI_ARGS_((TkText *textPtr,
+ TkTextTag *tagPtr));
+EXTERN int TkTextGetIndex _ANSI_ARGS_((Tcl_Interp *interp,
+ TkText *textPtr, CONST char *string,
+ TkTextIndex *indexPtr));
+EXTERN TkTextTabArray * TkTextGetTabs _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window tkwin, Tcl_Obj *string));
+EXTERN void TkTextIndexBackBytes _ANSI_ARGS_((
+ CONST TkTextIndex *srcPtr, int count,
+ TkTextIndex *dstPtr));
+EXTERN void TkTextIndexBackChars _ANSI_ARGS_((
+ CONST TkTextIndex *srcPtr, int count,
+ TkTextIndex *dstPtr));
+EXTERN int TkTextIndexCmp _ANSI_ARGS_((
+ CONST TkTextIndex *index1Ptr,
+ CONST TkTextIndex *index2Ptr));
+EXTERN void TkTextIndexForwBytes _ANSI_ARGS_((
+ CONST TkTextIndex *srcPtr, int count,
+ TkTextIndex *dstPtr));
+EXTERN void TkTextIndexForwChars _ANSI_ARGS_((
+ CONST TkTextIndex *srcPtr, int count,
+ TkTextIndex *dstPtr));
+EXTERN TkTextSegment * TkTextIndexToSeg _ANSI_ARGS_((
+ CONST TkTextIndex *indexPtr, int *offsetPtr));
+EXTERN void TkTextInsertDisplayProc _ANSI_ARGS_((
+ TkTextDispChunk *chunkPtr, int x, int y, int height,
+ int baseline, Display *display, Drawable dst,
+ int screenY));
+EXTERN void TkTextLostSelection _ANSI_ARGS_((
+ ClientData clientData));
+EXTERN TkTextIndex * TkTextMakeCharIndex _ANSI_ARGS_((TkTextBTree tree,
+ int lineIndex, int charIndex,
+ TkTextIndex *indexPtr));
+EXTERN int TkTextIsElided _ANSI_ARGS_((TkText *textPtr,
+ TkTextIndex *indexPtr));
+EXTERN TkTextIndex * TkTextMakeByteIndex _ANSI_ARGS_((TkTextBTree tree,
+ int lineIndex, int byteIndex,
+ TkTextIndex *indexPtr));
+EXTERN int TkTextMarkCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkTextMarkNameToIndex _ANSI_ARGS_((TkText *textPtr,
+ CONST char *name, TkTextIndex *indexPtr));
+EXTERN void TkTextMarkSegToIndex _ANSI_ARGS_((TkText *textPtr,
+ TkTextSegment *markPtr, TkTextIndex *indexPtr));
+EXTERN void TkTextEventuallyRepick _ANSI_ARGS_((TkText *textPtr));
+EXTERN void TkTextPickCurrent _ANSI_ARGS_((TkText *textPtr,
+ XEvent *eventPtr));
+EXTERN void TkTextPixelIndex _ANSI_ARGS_((TkText *textPtr,
+ int x, int y, TkTextIndex *indexPtr));
+EXTERN void TkTextPrintIndex _ANSI_ARGS_((
+ CONST TkTextIndex *indexPtr, char *string));
+EXTERN void TkTextRedrawRegion _ANSI_ARGS_((TkText *textPtr,
+ int x, int y, int width, int height));
+EXTERN void TkTextRedrawTag _ANSI_ARGS_((TkText *textPtr,
+ TkTextIndex *index1Ptr, TkTextIndex *index2Ptr,
+ TkTextTag *tagPtr, int withTag));
+EXTERN void TkTextRelayoutWindow _ANSI_ARGS_((TkText *textPtr));
+EXTERN int TkTextScanCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkTextSeeCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkTextSegToOffset _ANSI_ARGS_((
+ CONST TkTextSegment *segPtr,
+ CONST TkTextLine *linePtr));
+EXTERN TkTextSegment * TkTextSetMark _ANSI_ARGS_((TkText *textPtr,
+ CONST char *name, TkTextIndex *indexPtr));
+EXTERN void TkTextSetYView _ANSI_ARGS_((TkText *textPtr,
+ TkTextIndex *indexPtr, int pickPlace));
+EXTERN int TkTextTagCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkTextImageCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkTextImageIndex _ANSI_ARGS_((TkText *textPtr,
+ CONST char *name, TkTextIndex *indexPtr));
+EXTERN int TkTextWindowCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkTextWindowIndex _ANSI_ARGS_((TkText *textPtr,
+ CONST char *name, TkTextIndex *indexPtr));
+EXTERN int TkTextXviewCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+EXTERN int TkTextYviewCmd _ANSI_ARGS_((TkText *textPtr,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+
+#include "tkPort.h"
+#include "tkVMacro.h"
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKTEXT */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkUndo.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkUndo.h
new file mode 100755
index 00000000000..96a0c5bace8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkUndo.h
@@ -0,0 +1,90 @@
+/*
+ * tkUndo.h --
+ *
+ * Declarations shared among the files that implement an undo
+ * stack.
+ *
+ * Copyright (c) 2002 Ludwig Callewaert.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkUndo.h,v 1.1 2002/06/21 23:09:55 hobbs Exp $
+ */
+
+#ifndef _TKUNDO
+#define _TKUNDO
+
+#ifndef _TK
+#include "tk.h"
+#endif
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/* enum definining the types used in an undo stack */
+
+typedef enum {
+ TK_UNDO_SEPARATOR, /* Marker */
+ TK_UNDO_ACTION /* Command */
+} TkUndoAtomType;
+
+/* struct defining the basic undo/redo stack element */
+
+typedef struct TkUndoAtom {
+ TkUndoAtomType type; /* The type that will trigger the
+ * required action*/
+ Tcl_Obj * apply; /* Command to apply the action that was taken */
+ Tcl_Obj * revert; /* The command to undo the action */
+ struct TkUndoAtom * next; /* Pointer to the next element in the
+ * stack */
+} TkUndoAtom;
+
+/* struct defining the basic undo/redo stack element */
+
+typedef struct TkUndoRedoStack {
+ TkUndoAtom * undoStack; /* The undo stack */
+ TkUndoAtom * redoStack; /* The redo stack */
+ Tcl_Interp * interp ; /* The interpreter in which to execute the revert and apply scripts */
+ int maxdepth;
+ int depth;
+} TkUndoRedoStack;
+
+/* basic functions */
+
+EXTERN void TkUndoPushStack _ANSI_ARGS_((TkUndoAtom ** stack,
+ TkUndoAtom * elem));
+
+EXTERN TkUndoAtom * TkUndoPopStack _ANSI_ARGS_((TkUndoAtom ** stack));
+
+EXTERN int TkUndoInsertSeparator _ANSI_ARGS_((TkUndoAtom ** stack));
+
+EXTERN void TkUndoClearStack _ANSI_ARGS_((TkUndoAtom ** stack));
+
+/* functions working on an undo/redo stack */
+
+EXTERN TkUndoRedoStack * TkUndoInitStack _ANSI_ARGS_((Tcl_Interp * interp,
+ int maxdepth));
+
+EXTERN void TkUndoSetDepth _ANSI_ARGS_((TkUndoRedoStack * stack,
+ int maxdepth));
+
+EXTERN void TkUndoClearStacks _ANSI_ARGS_((TkUndoRedoStack * stack));
+
+EXTERN void TkUndoFreeStack _ANSI_ARGS_((TkUndoRedoStack * stack));
+
+EXTERN void TkUndoInsertUndoSeparator _ANSI_ARGS_((TkUndoRedoStack * stack));
+
+EXTERN void TkUndoPushAction _ANSI_ARGS_((TkUndoRedoStack * stack,
+ Tcl_DString * actionScript, Tcl_DString * revertScript));
+
+EXTERN int TkUndoRevert _ANSI_ARGS_((TkUndoRedoStack * stack));
+
+EXTERN int TkUndoApply _ANSI_ARGS_((TkUndoRedoStack * stack));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKUNDO */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkVMacro.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkVMacro.h
new file mode 100755
index 00000000000..7ba57d8154a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkVMacro.h
@@ -0,0 +1,69 @@
+#ifdef _LANG
+#include "Lang.m"
+#endif
+
+#if defined(_TK)
+#include "tk.m"
+#endif
+
+#if defined(_TK) || defined(_XLIB_H_)
+# if !defined(_XLIB) && !defined(_XLIB_H_)
+# include <X11/Xlib.h>
+# endif
+# ifdef _TKINTXLIBDECLS
+# include "tkIntXlibDecls.m"
+# else
+# if defined(_XLIB_H) && !defined(_XLIB)
+# define _XLIB
+# endif
+# include "Xlib.m"
+# endif
+#endif
+
+#ifdef _TKINT
+#include "tkInt.m"
+#endif
+#ifdef _TKIMGPHOTO
+#include "tkImgPhoto.m"
+#endif
+#ifdef _TIX
+#include "tix.m"
+#endif
+#ifdef _TIXINT
+#include "tixInt.m"
+#endif
+#ifdef _TKOPTION
+#include "tkOption.m"
+#endif
+#ifdef _TIXIMGXPM
+#include "tixImgXpm.m"
+#endif
+#ifdef _IMGINT
+#include "imgInt.m"
+#endif
+
+#ifdef _TCLDECLS
+#include "tclDecls.m"
+#endif
+
+#ifdef _TKDECLS
+#include "tkDecls.m"
+#endif
+
+#ifdef _TKPLATDECLS
+#include "tkPlatDecls.m"
+#endif
+
+#ifdef _TKINTDECLS
+#include "tkIntDecls.m"
+#endif
+
+#ifdef _TKINTPLATDECLS
+#include "tkIntPlatDecls.m"
+#endif
+
+#ifdef _TKEVENT
+#include "tkEvent.m"
+#endif
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWin.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWin.h
new file mode 100755
index 00000000000..ab1046deb33
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWin.h
@@ -0,0 +1,60 @@
+/*
+ * tkWin.h --
+ *
+ * Declarations of public types and interfaces that are only
+ * available under Windows.
+ *
+ * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkWin.h,v 1.6 1999/04/16 01:51:48 stanton Exp $
+ */
+
+#ifndef _TKWIN
+#define _TKWIN
+
+#ifndef _TK
+#include "tk.h"
+#endif
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+#ifdef BUILD_tk
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+/*
+ * The following messages are use to communicate between a Tk toplevel
+ * and its container window.
+ */
+
+#define TK_CLAIMFOCUS (WM_USER)
+#define TK_GEOMETRYREQ (WM_USER+1)
+#define TK_ATTACHWINDOW (WM_USER+2)
+#define TK_DETACHWINDOW (WM_USER+3)
+
+
+typedef void Tcl_HandleProc (ClientData, HANDLE);
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Exported procedures defined for the Windows platform only.
+ *
+ *--------------------------------------------------------------
+ */
+
+#include "tkPlatDecls.h"
+
+extern HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
+
+#endif /* _TKWIN */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinDefault.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinDefault.h
new file mode 100755
index 00000000000..c66a8525ed2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinDefault.h
@@ -0,0 +1,525 @@
+/*
+ * tkWinDefault.h --
+ *
+ * This file defines the defaults for all options for all of
+ * the Tk widgets.
+ *
+ * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkWinDefault.h,v 1.16 2002/06/21 23:09:54 hobbs Exp $
+ */
+
+#ifndef _TKWINDEFAULT
+#define _TKWINDEFAULT
+
+/*
+ * The definitions below provide symbolic names for the default colors.
+ * NORMAL_BG - Normal background color.
+ * ACTIVE_BG - Background color when widget is active.
+ * SELECT_BG - Background color for selected text.
+ * TROUGH - Background color for troughs in scales and scrollbars.
+ * INDICATOR - Color for indicator when button is selected.
+ * DISABLED - Foreground color when widget is disabled.
+ */
+
+#define BLACK "Black"
+#define WHITE "White"
+
+#define CTL_FONT "{MS Sans Serif} 8"
+#define FIXED_FONT "{Courier New} 8"
+#define NORMAL_BG "SystemButtonFace"
+#define NORMAL_FG "SystemButtonText"
+#define ACTIVE_BG NORMAL_BG
+#define TEXT_FG "SystemWindowText"
+#define SELECT_BG "SystemHighlight"
+#define SELECT_FG "SystemHighlightText"
+#define TROUGH "SystemScrollbar"
+#define INDICATOR "SystemWindow"
+#define DISABLED "SystemDisabledText"
+#define MENU_BG "SystemMenu"
+#define MENU_FG "SystemMenuText"
+#define HIGHLIGHT "SystemWindowFrame"
+
+/*
+ * Defaults for labels, buttons, checkbuttons, and radiobuttons:
+ */
+
+#define DEF_BUTTON_ANCHOR "center"
+#define DEF_BUTTON_ACTIVE_BG_COLOR NORMAL_BG
+#define DEF_BUTTON_ACTIVE_BG_MONO BLACK
+#define DEF_BUTTON_ACTIVE_FG_COLOR NORMAL_FG
+#define DEF_CHKRAD_ACTIVE_FG_COLOR TEXT_FG
+#define DEF_BUTTON_ACTIVE_FG_MONO WHITE
+#define DEF_BUTTON_BG_COLOR NORMAL_BG
+#define DEF_BUTTON_BG_MONO WHITE
+#define DEF_BUTTON_BITMAP ""
+#define DEF_BUTTON_BORDER_WIDTH "2"
+#define DEF_BUTTON_CURSOR ""
+#define DEF_BUTTON_COMMAND ""
+#define DEF_BUTTON_COMPOUND "none"
+#define DEF_BUTTON_DEFAULT "disabled"
+#define DEF_BUTTON_DISABLED_FG_COLOR DISABLED
+#define DEF_BUTTON_DISABLED_FG_MONO ""
+#define DEF_BUTTON_FG NORMAL_FG
+#define DEF_CHKRAD_FG TEXT_FG
+#define DEF_BUTTON_FONT CTL_FONT
+#define DEF_BUTTON_HEIGHT "0"
+#define DEF_BUTTON_HIGHLIGHT_BG_COLOR DEF_BUTTON_BG_COLOR
+#define DEF_BUTTON_HIGHLIGHT_BG_MONO DEF_BUTTON_BG_MONO
+#define DEF_BUTTON_HIGHLIGHT HIGHLIGHT
+#define DEF_LABEL_HIGHLIGHT_WIDTH "0"
+#define DEF_BUTTON_HIGHLIGHT_WIDTH "1"
+#define DEF_BUTTON_IMAGE NULL
+#define DEF_BUTTON_INDICATOR "1"
+#define DEF_BUTTON_JUSTIFY "center"
+#define DEF_BUTTON_OFF_VALUE "0"
+#define DEF_BUTTON_ON_VALUE "1"
+#define DEF_BUTTON_OVER_RELIEF ""
+#define DEF_BUTTON_PADX "1"
+#define DEF_LABCHKRAD_PADX "1"
+#define DEF_BUTTON_PADY "1"
+#define DEF_LABCHKRAD_PADY "1"
+#define DEF_BUTTON_RELIEF "raised"
+#define DEF_LABCHKRAD_RELIEF "flat"
+#define DEF_BUTTON_REPEAT_DELAY "0"
+#define DEF_BUTTON_REPEAT_INTERVAL "0"
+#define DEF_BUTTON_SELECT_COLOR INDICATOR
+#define DEF_BUTTON_SELECT_MONO BLACK
+#define DEF_BUTTON_SELECT_IMAGE NULL
+#define DEF_BUTTON_STATE "normal"
+#define DEF_LABEL_TAKE_FOCUS "0"
+#define DEF_BUTTON_TAKE_FOCUS NULL
+#define DEF_BUTTON_TEXT ""
+#define DEF_BUTTON_TEXT_VARIABLE ""
+#define DEF_BUTTON_UNDERLINE "-1"
+#define DEF_BUTTON_VALUE ""
+#define DEF_BUTTON_WIDTH "0"
+#define DEF_BUTTON_WRAP_LENGTH "0"
+#define DEF_RADIOBUTTON_VARIABLE "selectedButton"
+#define DEF_CHECKBUTTON_VARIABLE ""
+
+/*
+ * Defaults for canvases:
+ */
+
+#define DEF_CANVAS_BG_COLOR NORMAL_BG
+#define DEF_CANVAS_BG_MONO WHITE
+#define DEF_CANVAS_BORDER_WIDTH "0"
+#define DEF_CANVAS_CLOSE_ENOUGH "1"
+#define DEF_CANVAS_CONFINE "1"
+#define DEF_CANVAS_CURSOR ""
+#define DEF_CANVAS_HEIGHT "7c"
+#define DEF_CANVAS_HIGHLIGHT_BG NORMAL_BG
+#define DEF_CANVAS_HIGHLIGHT HIGHLIGHT
+#define DEF_CANVAS_HIGHLIGHT_WIDTH "2"
+#define DEF_CANVAS_INSERT_BG NORMAL_FG
+#define DEF_CANVAS_INSERT_BD_COLOR "0"
+#define DEF_CANVAS_INSERT_BD_MONO "0"
+#define DEF_CANVAS_INSERT_OFF_TIME "300"
+#define DEF_CANVAS_INSERT_ON_TIME "600"
+#define DEF_CANVAS_INSERT_WIDTH "2"
+#define DEF_CANVAS_RELIEF "flat"
+#define DEF_CANVAS_SCROLL_REGION ""
+#define DEF_CANVAS_SELECT_COLOR SELECT_BG
+#define DEF_CANVAS_SELECT_MONO BLACK
+#define DEF_CANVAS_SELECT_BD_COLOR "1"
+#define DEF_CANVAS_SELECT_BD_MONO "0"
+#define DEF_CANVAS_SELECT_FG_COLOR SELECT_FG
+#define DEF_CANVAS_SELECT_FG_MONO WHITE
+#define DEF_CANVAS_TAKE_FOCUS NULL
+#define DEF_CANVAS_WIDTH "10c"
+#define DEF_CANVAS_X_SCROLL_CMD ""
+#define DEF_CANVAS_X_SCROLL_INCREMENT "0"
+#define DEF_CANVAS_Y_SCROLL_CMD ""
+#define DEF_CANVAS_Y_SCROLL_INCREMENT "0"
+
+/*
+ * Defaults for entries:
+ */
+
+#define DEF_ENTRY_BG_COLOR "SystemWindow"
+#define DEF_ENTRY_BG_MONO WHITE
+#define DEF_ENTRY_BORDER_WIDTH "2"
+#define DEF_ENTRY_CURSOR "xterm"
+#define DEF_ENTRY_DISABLED_BG_COLOR "SystemButtonFace"
+#define DEF_ENTRY_DISABLED_BG_MONO WHITE
+#define DEF_ENTRY_DISABLED_FG DISABLED
+#define DEF_ENTRY_EXPORT_SELECTION "1"
+#define DEF_ENTRY_FONT CTL_FONT
+#define DEF_ENTRY_FG TEXT_FG
+#define DEF_ENTRY_HIGHLIGHT_BG NORMAL_BG
+#define DEF_ENTRY_HIGHLIGHT HIGHLIGHT
+#define DEF_ENTRY_HIGHLIGHT_WIDTH "0"
+#define DEF_ENTRY_INSERT_BG TEXT_FG
+#define DEF_ENTRY_INSERT_BD_COLOR "0"
+#define DEF_ENTRY_INSERT_BD_MONO "0"
+#define DEF_ENTRY_INSERT_OFF_TIME "300"
+#define DEF_ENTRY_INSERT_ON_TIME "600"
+#define DEF_ENTRY_INSERT_WIDTH "2"
+#define DEF_ENTRY_JUSTIFY "left"
+#define DEF_ENTRY_READONLY_BG_COLOR "SystemButtonFace"
+#define DEF_ENTRY_READONLY_BG_MONO WHITE
+#define DEF_ENTRY_RELIEF "sunken"
+#define DEF_ENTRY_SCROLL_COMMAND ""
+#define DEF_ENTRY_SELECT_COLOR SELECT_BG
+#define DEF_ENTRY_SELECT_MONO BLACK
+#define DEF_ENTRY_SELECT_BD_COLOR "0"
+#define DEF_ENTRY_SELECT_BD_MONO "0"
+#define DEF_ENTRY_SELECT_FG_COLOR SELECT_FG
+#define DEF_ENTRY_SELECT_FG_MONO WHITE
+#define DEF_ENTRY_SHOW NULL
+#define DEF_ENTRY_STATE "normal"
+#define DEF_ENTRY_TAKE_FOCUS NULL
+#define DEF_ENTRY_TEXT_VARIABLE ""
+#define DEF_ENTRY_WIDTH "20"
+
+/*
+ * Defaults for frames:
+ */
+
+#define DEF_FRAME_BG_COLOR NORMAL_BG
+#define DEF_FRAME_BG_MONO WHITE
+#define DEF_FRAME_BORDER_WIDTH "0"
+#define DEF_FRAME_CLASS "Frame"
+#define DEF_FRAME_COLORMAP ""
+#define DEF_FRAME_CONTAINER "0"
+#define DEF_FRAME_CURSOR ""
+#define DEF_FRAME_HEIGHT "0"
+#define DEF_FRAME_HIGHLIGHT_BG NORMAL_BG
+#define DEF_FRAME_HIGHLIGHT HIGHLIGHT
+#define DEF_FRAME_HIGHLIGHT_WIDTH "0"
+#define DEF_FRAME_PADX "0"
+#define DEF_FRAME_PADY "0"
+#define DEF_FRAME_RELIEF "flat"
+#define DEF_FRAME_TAKE_FOCUS "0"
+#define DEF_FRAME_VISUAL ""
+#define DEF_FRAME_WIDTH "0"
+
+/*
+ * Defaults for labelframes:
+ */
+
+#define DEF_LABELFRAME_BORDER_WIDTH "2"
+#define DEF_LABELFRAME_CLASS "Labelframe"
+#define DEF_LABELFRAME_RELIEF "groove"
+#define DEF_LABELFRAME_FG NORMAL_FG
+#define DEF_LABELFRAME_FONT CTL_FONT
+#define DEF_LABELFRAME_TEXT ""
+#define DEF_LABELFRAME_LABELANCHOR "nw"
+
+/*
+ * Defaults for listboxes:
+ */
+
+#define DEF_LISTBOX_ACTIVE_STYLE "underline"
+#define DEF_LISTBOX_BG_COLOR "SystemWindow"
+#define DEF_LISTBOX_BG_MONO WHITE
+#define DEF_LISTBOX_BORDER_WIDTH "2"
+#define DEF_LISTBOX_CURSOR ""
+#define DEF_LISTBOX_DISABLED_FG DISABLED
+#define DEF_LISTBOX_EXPORT_SELECTION "1"
+#define DEF_LISTBOX_FONT CTL_FONT
+#define DEF_LISTBOX_FG NORMAL_FG
+#define DEF_LISTBOX_HEIGHT "10"
+#define DEF_LISTBOX_HIGHLIGHT_BG NORMAL_BG
+#define DEF_LISTBOX_HIGHLIGHT HIGHLIGHT
+#define DEF_LISTBOX_HIGHLIGHT_WIDTH "1"
+#define DEF_LISTBOX_RELIEF "sunken"
+#define DEF_LISTBOX_SCROLL_COMMAND ""
+#define DEF_LISTBOX_LIST_VARIABLE ""
+#define DEF_LISTBOX_SELECT_COLOR SELECT_BG
+#define DEF_LISTBOX_SELECT_MONO BLACK
+#define DEF_LISTBOX_SELECT_BD "0"
+#define DEF_LISTBOX_SELECT_FG_COLOR SELECT_FG
+#define DEF_LISTBOX_SELECT_FG_MONO WHITE
+#define DEF_LISTBOX_SELECT_MODE "browse"
+#define DEF_LISTBOX_SET_GRID "0"
+#define DEF_LISTBOX_STATE "normal"
+#define DEF_LISTBOX_TAKE_FOCUS NULL
+#define DEF_LISTBOX_WIDTH "20"
+
+/*
+ * Defaults for individual entries of menus:
+ */
+
+#define DEF_MENU_ENTRY_ACTIVE_BG NULL
+#define DEF_MENU_ENTRY_ACTIVE_FG NULL
+#define DEF_MENU_ENTRY_ACCELERATOR NULL
+#define DEF_MENU_ENTRY_BG NULL
+#define DEF_MENU_ENTRY_BITMAP None
+#define DEF_MENU_ENTRY_COLUMN_BREAK "0"
+#define DEF_MENU_ENTRY_COMMAND NULL
+#define DEF_MENU_ENTRY_COMPOUND "none"
+#define DEF_MENU_ENTRY_FG NULL
+#define DEF_MENU_ENTRY_FONT NULL
+#define DEF_MENU_ENTRY_HIDE_MARGIN "0"
+#define DEF_MENU_ENTRY_IMAGE NULL
+#define DEF_MENU_ENTRY_INDICATOR "1"
+#define DEF_MENU_ENTRY_LABEL NULL
+#define DEF_MENU_ENTRY_MENU NULL
+#define DEF_MENU_ENTRY_OFF_VALUE "0"
+#define DEF_MENU_ENTRY_ON_VALUE "1"
+#define DEF_MENU_ENTRY_SELECT_IMAGE NULL
+#define DEF_MENU_ENTRY_STATE "normal"
+#define DEF_MENU_ENTRY_VALUE NULL
+#define DEF_MENU_ENTRY_CHECK_VARIABLE NULL
+#define DEF_MENU_ENTRY_RADIO_VARIABLE "selectedButton"
+#define DEF_MENU_ENTRY_SELECT NULL
+#define DEF_MENU_ENTRY_UNDERLINE "-1"
+
+/*
+ * Defaults for menus overall:
+ */
+
+#define DEF_MENU_ACTIVE_BG_COLOR SELECT_BG
+#define DEF_MENU_ACTIVE_BG_MONO BLACK
+#define DEF_MENU_ACTIVE_BORDER_WIDTH "0"
+#define DEF_MENU_ACTIVE_FG_COLOR SELECT_FG
+#define DEF_MENU_ACTIVE_FG_MONO WHITE
+#define DEF_MENU_BG_COLOR MENU_BG
+#define DEF_MENU_BG_MONO WHITE
+#define DEF_MENU_BORDER_WIDTH "0"
+#define DEF_MENU_CURSOR "arrow"
+#define DEF_MENU_DISABLED_FG_COLOR DISABLED
+#define DEF_MENU_DISABLED_FG_MONO ""
+#define DEF_MENU_FONT CTL_FONT
+#define DEF_MENU_FG MENU_FG
+#define DEF_MENU_POST_COMMAND ""
+#define DEF_MENU_RELIEF "flat"
+#define DEF_MENU_SELECT_COLOR MENU_FG
+#define DEF_MENU_SELECT_MONO BLACK
+#define DEF_MENU_TAKE_FOCUS "0"
+#define DEF_MENU_TEAROFF "1"
+#define DEF_MENU_TEAROFF_CMD NULL
+#define DEF_MENU_TITLE ""
+#define DEF_MENU_TYPE "normal"
+
+/*
+ * Defaults for menubuttons:
+ */
+
+#define DEF_MENUBUTTON_ANCHOR "center"
+#define DEF_MENUBUTTON_ACTIVE_BG_COLOR ACTIVE_BG
+#define DEF_MENUBUTTON_ACTIVE_BG_MONO BLACK
+#define DEF_MENUBUTTON_ACTIVE_FG_COLOR NORMAL_FG
+#define DEF_MENUBUTTON_ACTIVE_FG_MONO WHITE
+#define DEF_MENUBUTTON_BG_COLOR NORMAL_BG
+#define DEF_MENUBUTTON_BG_MONO WHITE
+#define DEF_MENUBUTTON_BITMAP ""
+#define DEF_MENUBUTTON_BORDER_WIDTH "2"
+#define DEF_MENUBUTTON_CURSOR ""
+#define DEF_MENUBUTTON_DIRECTION "below"
+#define DEF_MENUBUTTON_DISABLED_FG_COLOR DISABLED
+#define DEF_MENUBUTTON_DISABLED_FG_MONO ""
+#define DEF_MENUBUTTON_FONT CTL_FONT
+#define DEF_MENUBUTTON_FG NORMAL_FG
+#define DEF_MENUBUTTON_HEIGHT "0"
+#define DEF_MENUBUTTON_HIGHLIGHT_BG_COLOR DEF_MENUBUTTON_BG_COLOR
+#define DEF_MENUBUTTON_HIGHLIGHT_BG_MONO DEF_MENUBUTTON_BG_MONO
+#define DEF_MENUBUTTON_HIGHLIGHT HIGHLIGHT
+#define DEF_MENUBUTTON_HIGHLIGHT_WIDTH "0"
+#define DEF_MENUBUTTON_IMAGE NULL
+#define DEF_MENUBUTTON_INDICATOR "0"
+#define DEF_MENUBUTTON_JUSTIFY "center"
+#define DEF_MENUBUTTON_MENU ""
+#define DEF_MENUBUTTON_PADX "4p"
+#define DEF_MENUBUTTON_PADY "3p"
+#define DEF_MENUBUTTON_RELIEF "flat"
+#define DEF_MENUBUTTON_STATE "normal"
+#define DEF_MENUBUTTON_TAKE_FOCUS "0"
+#define DEF_MENUBUTTON_TEXT ""
+#define DEF_MENUBUTTON_TEXT_VARIABLE ""
+#define DEF_MENUBUTTON_UNDERLINE "-1"
+#define DEF_MENUBUTTON_WIDTH "0"
+#define DEF_MENUBUTTON_WRAP_LENGTH "0"
+
+/*
+ * Defaults for messages:
+ */
+
+#define DEF_MESSAGE_ANCHOR "center"
+#define DEF_MESSAGE_ASPECT "150"
+#define DEF_MESSAGE_BG_COLOR NORMAL_BG
+#define DEF_MESSAGE_BG_MONO WHITE
+#define DEF_MESSAGE_BORDER_WIDTH "2"
+#define DEF_MESSAGE_CURSOR ""
+#define DEF_MESSAGE_FG NORMAL_FG
+#define DEF_MESSAGE_FONT CTL_FONT
+#define DEF_MESSAGE_HIGHLIGHT_BG NORMAL_BG
+#define DEF_MESSAGE_HIGHLIGHT HIGHLIGHT
+#define DEF_MESSAGE_HIGHLIGHT_WIDTH "0"
+#define DEF_MESSAGE_JUSTIFY "left"
+#define DEF_MESSAGE_PADX "-1"
+#define DEF_MESSAGE_PADY "-1"
+#define DEF_MESSAGE_RELIEF "flat"
+#define DEF_MESSAGE_TAKE_FOCUS "0"
+#define DEF_MESSAGE_TEXT ""
+#define DEF_MESSAGE_TEXT_VARIABLE ""
+#define DEF_MESSAGE_WIDTH "0"
+
+/*
+ * Defaults for panedwindows
+ */
+
+#define DEF_PANEDWINDOW_BG_COLOR NORMAL_BG
+#define DEF_PANEDWINDOW_BG_MONO WHITE
+#define DEF_PANEDWINDOW_BORDERWIDTH "2"
+#define DEF_PANEDWINDOW_CURSOR ""
+#define DEF_PANEDWINDOW_HANDLEPAD "8"
+#define DEF_PANEDWINDOW_HANDLESIZE "8"
+#define DEF_PANEDWINDOW_HEIGHT ""
+#define DEF_PANEDWINDOW_OPAQUERESIZE "0"
+#define DEF_PANEDWINDOW_ORIENT "horizontal"
+#define DEF_PANEDWINDOW_RELIEF "flat"
+#define DEF_PANEDWINDOW_SASHCURSOR ""
+#define DEF_PANEDWINDOW_SASHPAD "2"
+#define DEF_PANEDWINDOW_SASHRELIEF "raised"
+#define DEF_PANEDWINDOW_SASHWIDTH "2"
+#define DEF_PANEDWINDOW_SHOWHANDLE "0"
+#define DEF_PANEDWINDOW_WIDTH ""
+
+/*
+ * Defaults for panedwindow panes
+ */
+
+#define DEF_PANEDWINDOW_PANE_AFTER ""
+#define DEF_PANEDWINDOW_PANE_BEFORE ""
+#define DEF_PANEDWINDOW_PANE_HEIGHT ""
+#define DEF_PANEDWINDOW_PANE_MINSIZE "0"
+#define DEF_PANEDWINDOW_PANE_PADX "0"
+#define DEF_PANEDWINDOW_PANE_PADY "0"
+#define DEF_PANEDWINDOW_PANE_STICKY "nsew"
+#define DEF_PANEDWINDOW_PANE_WIDTH ""
+
+/*
+ * Defaults for scales:
+ */
+
+#define DEF_SCALE_ACTIVE_BG_COLOR ACTIVE_BG
+#define DEF_SCALE_ACTIVE_BG_MONO BLACK
+#define DEF_SCALE_BG_COLOR NORMAL_BG
+#define DEF_SCALE_BG_MONO WHITE
+#define DEF_SCALE_BIG_INCREMENT "0"
+#define DEF_SCALE_BORDER_WIDTH "2"
+#define DEF_SCALE_COMMAND ""
+#define DEF_SCALE_CURSOR ""
+#define DEF_SCALE_DIGITS "0"
+#define DEF_SCALE_FONT CTL_FONT
+#define DEF_SCALE_FG_COLOR NORMAL_FG
+#define DEF_SCALE_FG_MONO BLACK
+#define DEF_SCALE_FROM "0"
+#define DEF_SCALE_HIGHLIGHT_BG_COLOR DEF_SCALE_BG_COLOR
+#define DEF_SCALE_HIGHLIGHT_BG_MONO DEF_SCALE_BG_MONO
+#define DEF_SCALE_HIGHLIGHT HIGHLIGHT
+#define DEF_SCALE_HIGHLIGHT_WIDTH "2"
+#define DEF_SCALE_LABEL ""
+#define DEF_SCALE_LENGTH "100"
+#define DEF_SCALE_ORIENT "vertical"
+#define DEF_SCALE_RELIEF "flat"
+#define DEF_SCALE_REPEAT_DELAY "300"
+#define DEF_SCALE_REPEAT_INTERVAL "100"
+#define DEF_SCALE_RESOLUTION "1"
+#define DEF_SCALE_TROUGH_COLOR TROUGH
+#define DEF_SCALE_TROUGH_MONO WHITE
+#define DEF_SCALE_SHOW_VALUE "1"
+#define DEF_SCALE_SLIDER_LENGTH "10m"
+#define DEF_SCALE_SLIDER_RELIEF "raised"
+#define DEF_SCALE_STATE "normal"
+#define DEF_SCALE_TAKE_FOCUS NULL
+#define DEF_SCALE_TICK_INTERVAL "0"
+#define DEF_SCALE_TO "100"
+#define DEF_SCALE_VARIABLE ""
+#define DEF_SCALE_WIDTH "5m"
+
+/*
+ * Defaults for scrollbars:
+ */
+
+#define DEF_SCROLLBAR_ACTIVE_BG_COLOR ACTIVE_BG
+#define DEF_SCROLLBAR_ACTIVE_BG_MONO BLACK
+#define DEF_SCROLLBAR_ACTIVE_RELIEF "raised"
+#define DEF_SCROLLBAR_BG_COLOR NORMAL_BG
+#define DEF_SCROLLBAR_BG_MONO WHITE
+#define DEF_SCROLLBAR_BORDER_WIDTH "0"
+#define DEF_SCROLLBAR_COMMAND ""
+#define DEF_SCROLLBAR_CURSOR ""
+#define DEF_SCROLLBAR_EL_BORDER_WIDTH "-1"
+#define DEF_SCROLLBAR_HIGHLIGHT_BG NORMAL_BG
+#define DEF_SCROLLBAR_HIGHLIGHT HIGHLIGHT
+#define DEF_SCROLLBAR_HIGHLIGHT_WIDTH "0"
+#define DEF_SCROLLBAR_JUMP "0"
+#define DEF_SCROLLBAR_ORIENT "vertical"
+#define DEF_SCROLLBAR_RELIEF "sunken"
+#define DEF_SCROLLBAR_REPEAT_DELAY "300"
+#define DEF_SCROLLBAR_REPEAT_INTERVAL "100"
+#define DEF_SCROLLBAR_TAKE_FOCUS NULL
+#define DEF_SCROLLBAR_TROUGH_COLOR TROUGH
+#define DEF_SCROLLBAR_TROUGH_MONO WHITE
+#define DEF_SCROLLBAR_WIDTH "4m"
+
+/*
+ * Defaults for texts:
+ */
+
+#define DEF_TEXT_AUTO_SEPARATORS "1"
+#define DEF_TEXT_BG_COLOR "SystemWindow"
+#define DEF_TEXT_BG_MONO WHITE
+#define DEF_TEXT_BORDER_WIDTH "2"
+#define DEF_TEXT_CURSOR "xterm"
+#define DEF_TEXT_FG TEXT_FG
+#define DEF_TEXT_EXPORT_SELECTION "1"
+#define DEF_TEXT_FONT FIXED_FONT
+#define DEF_TEXT_HEIGHT "24"
+#define DEF_TEXT_HIGHLIGHT_BG NORMAL_BG
+#define DEF_TEXT_HIGHLIGHT HIGHLIGHT
+#define DEF_TEXT_HIGHLIGHT_WIDTH "0"
+#define DEF_TEXT_INSERT_BG TEXT_FG
+#define DEF_TEXT_INSERT_BD_COLOR "0"
+#define DEF_TEXT_INSERT_BD_MONO "0"
+#define DEF_TEXT_INSERT_OFF_TIME "300"
+#define DEF_TEXT_INSERT_ON_TIME "600"
+#define DEF_TEXT_INSERT_WIDTH "2"
+#define DEF_TEXT_MAX_UNDO "0"
+#define DEF_TEXT_PADX "1"
+#define DEF_TEXT_PADY "1"
+#define DEF_TEXT_RELIEF "sunken"
+#define DEF_TEXT_SELECT_COLOR SELECT_BG
+#define DEF_TEXT_SELECT_MONO BLACK
+#define DEF_TEXT_SELECT_BD_COLOR "0"
+#define DEF_TEXT_SELECT_BD_MONO "0"
+#define DEF_TEXT_SELECT_FG_COLOR SELECT_FG
+#define DEF_TEXT_SELECT_FG_MONO WHITE
+#define DEF_TEXT_SELECT_RELIEF "flat"
+#define DEF_TEXT_SET_GRID "0"
+#define DEF_TEXT_SPACING1 "0"
+#define DEF_TEXT_SPACING2 "0"
+#define DEF_TEXT_SPACING3 "0"
+#define DEF_TEXT_STATE "normal"
+#define DEF_TEXT_TABS ""
+#define DEF_TEXT_TAKE_FOCUS NULL
+#define DEF_TEXT_UNDO "0"
+#define DEF_TEXT_WIDTH "80"
+#define DEF_TEXT_WRAP "char"
+#define DEF_TEXT_XSCROLL_COMMAND ""
+#define DEF_TEXT_YSCROLL_COMMAND ""
+
+/*
+ * Defaults for canvas text:
+ */
+
+#define DEF_CANVTEXT_FONT CTL_FONT
+
+/*
+ * Defaults for toplevels (most of the defaults for frames also apply
+ * to toplevels):
+ */
+
+#define DEF_TOPLEVEL_CLASS "Toplevel"
+#define DEF_TOPLEVEL_MENU ""
+#define DEF_TOPLEVEL_SCREEN ""
+#define DEF_TOPLEVEL_USE ""
+
+#endif /* _TKWINDEFAULT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinInt.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinInt.h
new file mode 100755
index 00000000000..d099158a7d1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinInt.h
@@ -0,0 +1,209 @@
+/*
+ * tkWinInt.h --
+ *
+ * This file contains declarations that are shared among the
+ * Windows-specific parts of Tk, but aren't used by the rest of
+ * Tk.
+ *
+ * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkWinInt.h,v 1.14 2003/02/26 02:47:05 hobbs Exp $
+ */
+
+#ifndef _TKWININT
+#define _TKWININT
+
+/*
+ * Include platform specific public interfaces.
+ */
+
+#ifndef _TKINT
+#include "tkInt.h"
+#endif
+
+#ifndef _TKWIN
+#include "tkWin.h"
+#endif
+
+#ifndef _TKPORT
+#include "tkPort.h"
+#endif
+
+
+/*
+ * Define constants missing from older Win32 SDK header files.
+ */
+
+#ifndef WS_EX_TOOLWINDOW
+#define WS_EX_TOOLWINDOW 0x00000080L
+#endif
+
+/*
+ * The TkWinDCState is used to save the state of a device context
+ * so that it can be restored later.
+ */
+
+typedef struct TkWinDCState {
+ HPALETTE palette;
+ int bkmode;
+} TkWinDCState;
+
+/*
+ * The TkWinDrawable is the internal implementation of an X Drawable (either
+ * a Window or a Pixmap). The following constants define the valid Drawable
+ * types.
+ */
+
+#define TWD_BITMAP 1
+#define TWD_WINDOW 2
+#define TWD_WINDC 3
+
+typedef struct {
+ int type;
+ HWND handle;
+ TkWindow *winPtr;
+} TkWinWindow;
+
+typedef struct {
+ int type;
+ HBITMAP handle;
+ Colormap colormap;
+ int depth;
+} TkWinBitmap;
+
+typedef struct {
+ int type;
+ HDC hdc;
+}TkWinDC;
+
+typedef union {
+ int type;
+ TkWinWindow window;
+ TkWinBitmap bitmap;
+ TkWinDC winDC;
+} TkWinDrawable;
+
+/*
+ * The following macros are used to retrieve internal values from a Drawable.
+ */
+
+#define TkWinGetHWND(w) (((TkWinDrawable *) w)->window.handle)
+#define TkWinGetWinPtr(w) (((TkWinDrawable *) w)->window.winPtr)
+#define TkWinGetHBITMAP(w) (((TkWinDrawable *) w)->bitmap.handle)
+#define TkWinGetColormap(w) (((TkWinDrawable *) w)->bitmap.colormap)
+#define TkWinGetHDC(w) (((TkWinDrawable *) w)->winDC.hdc)
+
+/*
+ * The following structure is used to encapsulate palette information.
+ */
+
+typedef struct {
+ HPALETTE palette; /* Palette handle used when drawing. */
+ UINT size; /* Number of entries in the palette. */
+ int stale; /* 1 if palette needs to be realized,
+ * otherwise 0. If the palette is stale,
+ * then an idle handler is scheduled to
+ * realize the palette. */
+ Tcl_HashTable refCounts; /* Hash table of palette entry reference counts
+ * indexed by pixel value. */
+} TkWinColormap;
+
+/*
+ * The following macro retrieves the Win32 palette from a colormap.
+ */
+
+#define TkWinGetPalette(colormap) (((TkWinColormap *) colormap)->palette)
+
+/*
+ * The following macros define the class names for Tk Window types.
+ */
+
+#define TK_WIN_TOPLEVEL_CLASS_NAME "TkTopLevel"
+#define TK_WIN_CHILD_CLASS_NAME "TkChild"
+#define TK_WIN_OWNDC_CLASS_NAME "TkOwnDC"
+
+/*
+ * The following variable is a translation table between X gc functions and
+ * Win32 raster and BitBlt op modes.
+ */
+
+extern int tkpWinRopModes[];
+extern int tkpWinBltModes[];
+
+/*
+ * The following defines are used with TkWinGetBorderPixels to get the
+ * extra 2 border colors from a Tk_3DBorder.
+ */
+
+#define TK_3D_LIGHT2 TK_3D_DARK_GC+1
+#define TK_3D_DARK2 TK_3D_DARK_GC+2
+
+/*
+ * Internal procedures used by more than one source file.
+ */
+
+#include "tkIntPlatDecls.h"
+
+/*
+ * We need to specially add the TkWinChildProc because of the special
+ * prototype it has (doesn't fit into stubs schema)
+ */
+#ifdef BUILD_tk
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
+EXTERN LRESULT CALLBACK TkWinChildProc _ANSI_ARGS_((HWND hwnd, UINT message,
+ WPARAM wParam, LPARAM lParam));
+
+/*
+ * Special proc needed as tsd accessor function between
+ * tkWinX.c:GenerateXEvent and tkWinClipboard.c:UpdateClipboard
+ */
+EXTERN void TkWinUpdatingClipboard(int mode);
+
+/*
+ * The following structure keeps track of whether we are using the
+ * multi-byte or the wide-character interfaces to the operating system.
+ * System calls should be made through the following function table.
+ *
+ * While some system calls need to use this A/W jump-table, it is not
+ * necessary for all calls to do it, which is why you won't see this
+ * used throughout the Tk code, but only in key areas. -- hobbs
+ */
+
+typedef struct TkWinProcs {
+ int useWide;
+ LRESULT (WINAPI *callWindowProc)(WNDPROC lpPrevWndFunc, HWND hWnd,
+ UINT Msg, WPARAM wParam, LPARAM lParam);
+ LRESULT (WINAPI *defWindowProc)(HWND hWnd, UINT Msg, WPARAM wParam,
+ LPARAM lParam);
+ ATOM (WINAPI *registerClass)(CONST WNDCLASS *lpWndClass);
+ BOOL (WINAPI *setWindowText)(HWND hWnd, LPCTSTR lpString);
+ HWND (WINAPI *createWindowEx)(DWORD dwExStyle, LPCTSTR lpClassName,
+ LPCTSTR lpWindowName, DWORD dwStyle, int x, int y,
+ int nWidth, int nHeight, HWND hWndParent, HMENU hMenu,
+ HINSTANCE hInstance, LPVOID lpParam);
+} TkWinProcs;
+
+EXTERN TkWinProcs *tkWinProcs;
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+/*
+ * The following allows us to cache these encoding for multiple functions.
+ */
+
+
+extern Tcl_Encoding TkWinGetKeyInputEncoding _ANSI_ARGS_((void));
+extern Tcl_Encoding TkWinGetUnicodeEncoding _ANSI_ARGS_((void));
+
+extern void LangNoteDC _ANSI_ARGS_((HDC dc,int inc));
+
+#endif /* _TKWININT */
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinPort.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinPort.h
new file mode 100755
index 00000000000..3c95b5d5d10
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkWinPort.h
@@ -0,0 +1,156 @@
+/*
+ * tkWinPort.h --
+ *
+ * This header file handles porting issues that occur because of
+ * differences between Windows and Unix. It should be the only
+ * file that contains #ifdefs to handle different flavors of OS.
+ *
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkWinPort.h,v 1.9 2002/10/19 02:10:20 hobbs Exp $
+ */
+
+#ifndef _WINPORT
+#define _WINPORT
+#define NEED_REAL_STDIO
+#include <X11/Xlib.h>
+#include <X11/cursorfont.h>
+#include <X11/keysym.h>
+#include <X11/Xatom.h>
+#include <X11/Xutil.h>
+
+#include <errno.h>
+#include <ctype.h>
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <fcntl.h>
+#include <io.h>
+#ifdef __EMX__
+# include <sys/types.h>
+#endif
+
+/*
+ * Need to block out this include for building extensions with MetroWerks
+ * compiler for Win32.
+ */
+
+#ifndef __MWERKS__
+#include <sys/stat.h>
+#endif
+
+#include <time.h>
+#ifdef __CYGWIN__
+# define _T(x) L##x
+#else
+# include <tchar.h>
+#endif
+
+#ifdef _MSC_VER
+# define hypot _hypot
+#else /* _MSC_VER */
+# ifdef __EMX__
+# define strncasecmp strnicmp
+# endif
+#endif /* _MSC_VER */
+
+#ifndef __GNUC__
+# define strncasecmp strnicmp
+# define strcasecmp stricmp
+#endif
+
+#define NBBY 8
+
+#ifndef OPEN_MAX
+#define OPEN_MAX 32
+#endif
+
+/*
+ * The following define causes Tk to use its internal keysym hash table
+ */
+
+#define REDO_KEYSYM_LOOKUP
+
+/*
+ * The following macro checks to see whether there is buffered
+ * input data available for a stdio FILE.
+ */
+
+#ifdef _MSC_VER
+# define TK_READ_DATA_PENDING(f) ((f)->_cnt > 0)
+#else /* _MSC_VER */
+# define TK_READ_DATA_PENDING(f) ((f)->level > 0)
+#endif /* _MSC_VER */
+
+/*
+ * The following stubs implement various calls that don't do anything
+ * under Windows.
+ */
+
+#define TkFreeWindowId(dispPtr,w)
+#define TkInitXId(dispPtr)
+#define TkpCmapStressed(tkwin,colormap) (0)
+#define XFlush(display)
+#define XGrabServer(display)
+#define XUngrabServer(display)
+#define TkpSync(display)
+
+/*
+ * The following functions are implemented as macros under Windows.
+ */
+
+#define XFree(data) {if ((data) != NULL) ckfree((char *) (data));}
+#define XNoOp(display) {display->request++;}
+#define XSynchronize(display, bool) {display->request++;}
+#define XSync(display, bool) {display->request++;}
+#define XVisualIDFromVisual(visual) (visual->visualid)
+
+/* Additional translations needed for Tk extensions (Pixmap). */
+
+#define XPutImage(display, dr, gc, i, a, b, c, d, e, f) \
+ TkPutImage(NULL, 0, display, dr, gc, i, a, b, c, d, e, f)
+#define XDefaultVisual(display, screen) ((screen)->root_visual)
+#define XDefaultScreen(display) ((display)->screens)
+#define XDefaultColormap(display, screen) ((screen)->cmap)
+#define XDefaultDepth(display, screen) ((screen)->root_depth)
+
+/*
+ * The following Tk functions are implemented as macros under Windows.
+ */
+
+#define TkpGetPixel(p) (((((p)->red >> 8) & 0xff) \
+ | ((p)->green & 0xff00) | (((p)->blue << 8) & 0xff0000)) | 0x20000000)
+
+/*
+ * These calls implement native bitmaps which are not currently
+ * supported under Windows. The macros eliminate the calls.
+ */
+
+#define TkpDefineNativeBitmaps()
+#define TkpCreateNativeBitmap(display, source) None
+#define TkpGetNativeAppBitmap(display, name, w, h) None
+
+/*
+ * Define timezone for gettimeofday.
+ */
+#if 0
+struct timezone {
+ int tz_minuteswest;
+ int tz_dsttime;
+};
+#else
+#undef timezone
+struct timezone;
+struct timeval;
+#endif
+
+#ifndef _TCLINT
+#include <tclInt.h>
+#endif
+
+
+#endif /* _WINPORT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkXrm.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkXrm.h
new file mode 100755
index 00000000000..041d67b400d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tkXrm.h
@@ -0,0 +1,12 @@
+EXTERN void Xrm_AddOption _ANSI_ARGS_((Tk_Window tkwin, CONST char *name,
+ CONST char *value, int priority));
+EXTERN Tk_Uid Xrm_GetOption _ANSI_ARGS_((Tk_Window tkwin, CONST char *name,
+ CONST char *className));
+EXTERN int Xrm_OptionCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST args[]));
+EXTERN void XrmOptionClassChanged _ANSI_ARGS_((TkWindow *winPtr));
+EXTERN void XrmOptionDeadWindow _ANSI_ARGS_((TkWindow *winPtr));
+EXTERN void Xrm_import _ANSI_ARGS_((char *class));
+
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk_f.h
new file mode 100755
index 00000000000..603919b64f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/tk_f.h
@@ -0,0 +1,14 @@
+#ifndef TK_VT
+#define TK_VT
+typedef struct TkVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tk.t"
+#undef VFUNC
+#undef VVAR
+} TkVtab;
+extern TkVtab *TkVptr;
+extern TkVtab *TkVGet(void);
+#endif /* TK_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pTk/xbytes.h b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/xbytes.h
new file mode 100755
index 00000000000..46be124d92d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pTk/xbytes.h
@@ -0,0 +1,58 @@
+/*
+ * xbytes.h --
+ *
+ * Declaration of table to reverse bit order of bytes.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: xbytes.h,v 1.2 1998/09/14 18:24:02 stanton Exp $
+ */
+
+#ifndef _XBYTES
+#define _XBYTES
+
+/*
+ * The bits in a byte can be reversed so the least significant becomes
+ * the most significant by indexing xBitReverseTable with the byte
+ * to be reversed.
+ */
+
+static unsigned char xBitReverseTable[256] = {
+ 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0,
+ 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0,
+ 0x08, 0x88, 0x48, 0xc8, 0x28, 0xa8, 0x68, 0xe8,
+ 0x18, 0x98, 0x58, 0xd8, 0x38, 0xb8, 0x78, 0xf8,
+ 0x04, 0x84, 0x44, 0xc4, 0x24, 0xa4, 0x64, 0xe4,
+ 0x14, 0x94, 0x54, 0xd4, 0x34, 0xb4, 0x74, 0xf4,
+ 0x0c, 0x8c, 0x4c, 0xcc, 0x2c, 0xac, 0x6c, 0xec,
+ 0x1c, 0x9c, 0x5c, 0xdc, 0x3c, 0xbc, 0x7c, 0xfc,
+ 0x02, 0x82, 0x42, 0xc2, 0x22, 0xa2, 0x62, 0xe2,
+ 0x12, 0x92, 0x52, 0xd2, 0x32, 0xb2, 0x72, 0xf2,
+ 0x0a, 0x8a, 0x4a, 0xca, 0x2a, 0xaa, 0x6a, 0xea,
+ 0x1a, 0x9a, 0x5a, 0xda, 0x3a, 0xba, 0x7a, 0xfa,
+ 0x06, 0x86, 0x46, 0xc6, 0x26, 0xa6, 0x66, 0xe6,
+ 0x16, 0x96, 0x56, 0xd6, 0x36, 0xb6, 0x76, 0xf6,
+ 0x0e, 0x8e, 0x4e, 0xce, 0x2e, 0xae, 0x6e, 0xee,
+ 0x1e, 0x9e, 0x5e, 0xde, 0x3e, 0xbe, 0x7e, 0xfe,
+ 0x01, 0x81, 0x41, 0xc1, 0x21, 0xa1, 0x61, 0xe1,
+ 0x11, 0x91, 0x51, 0xd1, 0x31, 0xb1, 0x71, 0xf1,
+ 0x09, 0x89, 0x49, 0xc9, 0x29, 0xa9, 0x69, 0xe9,
+ 0x19, 0x99, 0x59, 0xd9, 0x39, 0xb9, 0x79, 0xf9,
+ 0x05, 0x85, 0x45, 0xc5, 0x25, 0xa5, 0x65, 0xe5,
+ 0x15, 0x95, 0x55, 0xd5, 0x35, 0xb5, 0x75, 0xf5,
+ 0x0d, 0x8d, 0x4d, 0xcd, 0x2d, 0xad, 0x6d, 0xed,
+ 0x1d, 0x9d, 0x5d, 0xdd, 0x3d, 0xbd, 0x7d, 0xfd,
+ 0x03, 0x83, 0x43, 0xc3, 0x23, 0xa3, 0x63, 0xe3,
+ 0x13, 0x93, 0x53, 0xd3, 0x33, 0xb3, 0x73, 0xf3,
+ 0x0b, 0x8b, 0x4b, 0xcb, 0x2b, 0xab, 0x6b, 0xeb,
+ 0x1b, 0x9b, 0x5b, 0xdb, 0x3b, 0xbb, 0x7b, 0xfb,
+ 0x07, 0x87, 0x47, 0xc7, 0x27, 0xa7, 0x67, 0xe7,
+ 0x17, 0x97, 0x57, 0xd7, 0x37, 0xb7, 0x77, 0xf7,
+ 0x0f, 0x8f, 0x4f, 0xcf, 0x2f, 0xaf, 0x6f, 0xef,
+ 0x1f, 0x9f, 0x5f, 0xdf, 0x3f, 0xbf, 0x7f, 0xff,
+};
+
+#endif /* _XBYTES */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/pack.pod b/Master/tlpkg/tlperl.straw/lib/Tk/pack.pod
new file mode 100755
index 00000000000..0449556265c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/pack.pod
@@ -0,0 +1,324 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::pack - Geometry manager that packs around edges of cavity
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<pack>?(I<args>)?
+
+S< >I<$widget>-E<gt>B<pack>I<Option>?(I<args>)?
+
+=head1 DESCRIPTION
+
+The B<pack> method is used to communicate with the packer,
+a geometry manager that arranges the children of a parent by
+packing them in order around the edges of the parent.
+
+In this B<perl> port of Tk it is normal to pack widgets one-at-a-time
+using the widget object to be packed to invoke a method call.
+This is a slight distortion of underlying Tk interface (which
+can handle lists of windows to one pack method call) but has proven
+effective in practice.
+
+The B<pack> method can have any of several forms, depending
+on I<Option>:
+
+=over 4
+
+=item I<$slave>-E<gt>B<pack>?(I<options>)?
+
+The options consist of pairs of arguments that specify how
+to manage the slave.
+See L<"THE PACKER ALGORITHM"> below for details on how the options
+are used by the packer.
+The following options are supported:
+
+=over 8
+
+=item B<-after> =E<gt> I<$other>
+
+I<$other> must be another window.
+Use its master as the master for the slave, and insert
+the slave just after I<$other> in the packing order.
+
+=item B<-anchor> =E<gt> I<anchor>
+
+I<Anchor> must be a valid anchor position such as B<n>
+or B<sw>; it specifies where to position each slave in its
+parcel.
+Defaults to B<center>.
+
+=item B<-before> =E<gt> I<$other>
+
+I<$other> must be another window.
+Use its master as the master for the slave, and insert
+the slave just before I<$other> in the packing order.
+
+=item B<-expand> =E<gt> I<boolean>
+
+Specifies whether the slave should be expanded to consume
+extra space in their master.
+I<Boolean> may have any proper boolean value, such as B<1>
+or B<no>.
+Defaults to 0.
+
+=item B<-fill> =E<gt> I<style>
+
+If a slave's parcel is larger than its requested dimensions, this
+option may be used to stretch the slave.
+I<Style> must have one of the following values:
+
+=over 12
+
+=item B<none>
+
+Give the slave its requested dimensions plus any internal padding
+requested with B<-ipadx> or B<-ipady>. This is the default.
+
+=item B<x>
+
+Stretch the slave horizontally to fill the entire width of its
+parcel (except leave external padding as specified by B<-padx>).
+
+=item B<y>
+
+Stretch the slave vertically to fill the entire height of its
+parcel (except leave external padding as specified by B<-pady>).
+
+=item B<both>
+
+Stretch the slave both horizontally and vertically.
+
+=back
+
+=item B<-in> =E<gt> I<$master>
+
+Insert the slave(s) at the end of the packing order for the master
+window given by I<$master>.
+
+=item B<-ipadx> =E<gt> I<amount>
+
+I<Amount> specifies how much horizontal internal padding to
+leave on each side of the slave(s).
+I<Amount> must be a valid screen distance, such as B<2> or B<.5c>.
+It defaults to 0.
+
+=item B<-ipady> =E<gt> I<amount>
+
+I<Amount> specifies how much vertical internal padding to
+leave on each side of the slave(s).
+I<Amount> defaults to 0.
+
+=item B<-padx> =E<gt> I<amount>
+
+I<Amount> specifies how much horizontal external padding to
+leave on each side of the slave(s).
+I<Amount> defaults to 0.
+
+=item B<-pady> =E<gt> I<amount>
+
+I<Amount> specifies how much vertical external padding to
+leave on each side of the slave(s).
+I<Amount> defaults to 0.
+
+=item B<-side> =E<gt> I<side>
+
+Specifies which side of the master the slave(s) will be packed against.
+Must be B<left>, B<right>, B<top>, or B<bottom>.
+Defaults to B<top>.
+
+=back
+
+=back
+
+If no B<-in>, B<-after> or B<-before> option is specified
+then slave will be inserted at the end of the packing list
+for its parent unless it is already managed by the packer (in which
+case it will be left where it is).
+If one of these options is specified then slave will be
+inserted at the specified point.
+If the slave are already managed by the geometry manager
+then any unspecified options for them retain their previous values rather
+than receiving default values.
+
+=over 4
+
+=item I<$slave>-E<gt>B<packConfigure>?(I<options>)?
+
+Same as B<pack>.
+
+=item I<$slave>-E<gt>B<packForget>
+
+Removes I<slave> from the packing order for its
+master and unmaps its window.
+The slave will no longer be managed by the packer.
+
+=item I<$slave>-E<gt>B<packInfo>
+
+Returns a list whose elements are the current configuration state of
+the slave given by I<$slave> in the same option-value form that
+might be specified to B<packConfigure>.
+The first two elements of the list are ``B<-in>=E<gt>I<$master>'' where
+I<$master> is the slave's master.
+
+=item I<$master>-E<gt>B<packPropagate>?(I<boolean>)?
+
+If I<boolean> has a true boolean value such as B<1> or B<on>
+then propagation is enabled for I<$master>,
+(see L<"GEOMETRY PROPAGATION"> below).
+If I<boolean> has a false boolean value then propagation is
+disabled for I<$master>.
+In either of these cases an empty string is returned.
+If I<boolean> is omitted then the method returns B<0> or
+B<1> to indicate whether propagation is currently enabled
+for I<$master>.
+Propagation is enabled by default.
+
+=item I<$master>-E<gt>B<packSlaves>
+
+Returns a list of all of the slaves in the packing order for I<$master>.
+The order of the slaves in the list is the same as their order in
+the packing order.
+If I<$master> has no slaves then an empty list/string is returned in
+array/scalar context, respectively
+
+=back
+
+=head1 THE PACKER ALGORITHM
+
+For each master the packer maintains an ordered list of slaves
+called the I<packing list>.
+The B<-in>, B<-after>, and B<-before> configuration
+options are used to specify the master for each slave and the slave's
+position in the packing list.
+If none of these options is given for a slave then the slave
+is added to the end of the packing list for its parent.
+
+The packer arranges the slaves for a master by scanning the
+packing list in order.
+At the time it processes each slave, a rectangular area within
+the master is still unallocated.
+This area is called the I<cavity>; for the first slave it
+is the entire area of the master.
+
+For each slave the packer carries out the following steps:
+
+=over 4
+
+=item [1]
+
+The packer allocates a rectangular I<parcel> for the slave
+along the side of the cavity given by the slave's B<-side> option.
+If the side is top or bottom then the width of the parcel is
+the width of the cavity and its height is the requested height
+of the slave plus the B<-ipady> and B<-pady> options.
+For the left or right side the height of the parcel is
+the height of the cavity and the width is the requested width
+of the slave plus the B<-ipadx> and B<-padx> options.
+The parcel may be enlarged further because of the B<-expand>
+option (see L<"EXPANSION"> below)
+
+=item [2]
+
+The packer chooses the dimensions of the slave.
+The width will normally be the slave's requested width plus
+twice its B<-ipadx> option and the height will normally be
+the slave's requested height plus twice its B<-ipady>
+option.
+However, if the B<-fill> option is B<x> or B<both>
+then the width of the slave is expanded to fill the width of the parcel,
+minus twice the B<-padx> option.
+If the B<-fill> option is B<y> or B<both>
+then the height of the slave is expanded to fill the width of the parcel,
+minus twice the B<-pady> option.
+
+=item [3]
+
+The packer positions the slave over its parcel.
+If the slave is smaller than the parcel then the B<-anchor>
+option determines where in the parcel the slave will be placed.
+If B<-padx> or B<-pady> is non-zero, then the given
+amount of external padding will always be left between the
+slave and the edges of the parcel.
+
+Once a given slave has been packed, the area of its parcel
+is subtracted from the cavity, leaving a smaller rectangular
+cavity for the next slave.
+If a slave doesn't use all of its parcel, the unused space
+in the parcel will not be used by subsequent slaves.
+If the cavity should become too small to meet the needs of
+a slave then the slave will be given whatever space is
+left in the cavity.
+If the cavity shrinks to zero size, then all remaining slaves
+on the packing list will be unmapped from the screen until
+the master window becomes large enough to hold them again.
+
+=back
+
+=head1 EXPANSION
+
+If a master window is so large that there will be extra space
+left over after all of its slaves have been packed, then the
+extra space is distributed uniformly among all of the slaves
+for which the B<-expand> option is set.
+Extra horizontal space is distributed among the expandable
+slaves whose B<-side> is B<left> or B<right>,
+and extra vertical space is distributed among the expandable
+slaves whose B<-side> is B<top> or B<bottom>.
+
+=head1 GEOMETRY PROPAGATION
+
+The packer normally computes how large a master must be to
+just exactly meet the needs of its slaves, and it sets the
+requested width and height of the master to these dimensions.
+This causes geometry information to propagate up through a
+window hierarchy to a top-level window so that the entire
+sub-tree sizes itself to fit the needs of the leaf windows.
+However, the B<packPropagate> method may be used to
+turn off propagation for one or more masters.
+If propagation is disabled then the packer will not set
+the requested width and height of the packer.
+This may be useful if, for example, you wish for a master
+window to have a fixed size that you specify.
+
+=head1 RESTRICTIONS ON MASTER WINDOWS
+
+The master for each slave must either be the slave's parent
+(the default) or a descendant of the slave's parent.
+This restriction is necessary to guarantee that the
+slave can be placed over any part of its master that is
+visible without danger of the slave being clipped by its parent.
+
+=head1 PACKING ORDER
+
+If the master for a slave is not its parent then you must make sure
+that the slave is higher in the stacking order than the master.
+Otherwise the master will obscure the slave and it will appear as
+if the slave hasn't been packed correctly.
+The easiest way to make sure the slave is higher than the master is
+to create the master window first: the most recently created window
+will be highest in the stacking order.
+Or, you can use the B<raise> and B<lower> methods to change
+the stacking order of either the master or the slave.
+
+=head1 SEE ALSO
+
+L<Tk::form|Tk::form>
+L<Tk::grid|Tk::grid>
+L<Tk::place|Tk::place>
+
+=head1 KEYWORDS
+
+geometry manager, location, packer, parcel, propagation, size
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/palette.pod b/Master/tlpkg/tlperl.straw/lib/Tk/palette.pod
new file mode 100755
index 00000000000..40a6914fd5c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/palette.pod
@@ -0,0 +1,89 @@
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+setPalette, bisque - Modify the Tk color palette
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<setPalette>(I<background>)
+
+I<$widget>-E<gt>B<setPalette(>I<name>=E<gt>I<value>?,I<name>=E<gt>I<value ...>?)
+
+I<$widget>-E<gt>B<bisque>
+
+=head1 DESCRIPTION
+
+The B<setPalette> method changes the color scheme for Tk.
+It does this by modifying the colors of existing widgets and by changing
+the option database so that future widgets will use the new color scheme.
+If B<setPalette> is invoked with a single argument, the
+argument is the name of a color to use as the normal background
+color; B<setPalette> will compute a complete color palette
+from this background color.
+Alternatively, the arguments to B<setPalette> may consist of any number
+of I<name>-I<value> pairs, where the first argument of the pair
+is the name of an option in the Tk option database and the second
+argument is the new value to use for that option. The following
+database names are currently supported:
+
+ activeBackground foreground selectColor
+ activeForeground highlightBackground selectBackground
+ background highlightColor selectForeground
+ disabledForeground insertBackground troughColor
+
+B<setPalette> tries to compute reasonable defaults for any
+options that you don't specify. You can specify options other
+than the above ones and Tk will change those options on widgets as
+well. This feature may be useful if you are using custom widgets with
+additional color options.
+
+Once it has computed the new value to use for each of the color options,
+B<setPalette> scans the widget hierarchy to modify the options
+of all existing widgets. For each widget, it checks to see if any
+of the above options is defined for the widget. If so, and if the
+option's current value is the default, then the value is changed; if
+the option has a value other than the default, B<setPalette>
+will not change it. The default for an option is the one provided by
+the widget (B<($w-E<gt>configure('option'))[3]>) unless
+B<setPalette> has been run previously, in which case it is the
+value specified in the previous invocation of B<setPalette>.
+
+After modifying all the widgets in the application, B<setPalette>
+adds options to the option database to change the defaults for
+widgets created in the future. The new options are added at
+priority B<widgetDefault>, so they will be overridden by options
+from the .Xdefaults file or options specified on the command-line
+that creates a widget.
+
+The method B<bisque> is provided for backward compatibility:
+it restores the application's colors to the light brown (``bisque'')
+color scheme used in Tk 3.6 and earlier versions.
+
+=head1 BUGS
+
+The use of option database names rather than the configure names is
+understandable given the mechanism (copied from Tcl/Tk), but
+is potentially confusing.
+
+The interpolation of different 'shades' of color used for 3D effects
+in 'RGB' space can lead to undesirable changes in 'hue'.
+Interpolation in 'HSV' (as used in B<Tk::ColorEditor>) would be more
+robust and X11R5's color support probably even more so.
+
+=head1 SEE ALSO
+
+L<Tk::options|Tk::options>
+
+=head1 KEYWORDS
+
+bisque, color, palette
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/place.pod b/Master/tlpkg/tlperl.straw/lib/Tk/place.pod
new file mode 100755
index 00000000000..8b3bff9816c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/place.pod
@@ -0,0 +1,271 @@
+# Copyright (c) 1992 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::place - Geometry manager for fixed or rubber-sheet placement
+
+=for category Tk Geometry Management
+
+=head1 SYNOPSIS
+
+S< >I<$widget>->B<place>?(I<-option>=>I<value>?, I<-option>=>I<value>, ...)?
+
+S< >I<$widget>->B<placeForget>
+
+S< >I<$widget>->B<placeInfo>
+
+S< >I<$master>->B<placeSlaves>
+
+=head1 DESCRIPTION
+
+The placer is a geometry manager for Tk.
+It provides simple fixed placement of windows, where you specify
+the exact size and location of one window, called the I<slave>,
+within another window, called the I<$master>.
+The placer also provides rubber-sheet placement, where you specify the
+size and location of the slave in terms of the dimensions of
+the master, so that the slave changes size and location
+in response to changes in the size of the master.
+Lastly, the placer allows you to mix these styles of placement so
+that, for example, the slave has a fixed width and height but is
+centered inside the master.
+
+=over 4
+
+=item I<$slave>->B<place>?(I<-option>=>I<value>?, I<-option>=>I<value>, ...?)?
+
+The B<place> method arranges for the placer
+to manage the geometry of I<$slave>.
+The remaining arguments consist of one or more I<-option>=>I<value>
+pairs that specify the way in which I<$slave>'s
+geometry is managed.
+If the placer is already managing I<$slave>, then the
+I<-option>=>I<value> pairs modify the configuration for I<$slave>.
+The B<place> method returns an empty string as result.
+The following I<-option>=>I<value> pairs are supported:
+
+=over 8
+
+=item B<-in> => I<$master>
+
+I<$master> is the reference to the window relative
+to which I<$slave> is to be placed.
+I<$master> must either be I<$slave>'s parent or a descendant
+of I<$slave>'s parent.
+In addition, I<$master> and I<$slave> must both be descendants
+of the same top-level window.
+These restrictions are necessary to guarantee
+that I<$slave> is visible whenever I<$master> is visible.
+If this option isn't specified then the master defaults to
+I<$slave>'s parent.
+
+=item B<-x> => I<location>
+
+I<Location> specifies the x-coordinate within the master window
+of the anchor point for I<$slave> widget.
+The location is specified in screen units (i.e. any of the forms
+accepted by B<Tk_GetPixels>) and need not lie within the bounds
+of the master window.
+
+=item B<-relx> => I<location>
+
+I<Location> specifies the x-coordinate within the master window
+of the anchor point for I<$slave> widget.
+In this case the location is specified in a relative fashion
+as a floating-point number: 0.0 corresponds to the left edge
+of the master and 1.0 corresponds to the right edge of the master.
+I<Location> need not be in the range 0.0-1.0.
+If both B<-x> and B<-relx> are specified for a slave
+then their values are summed. For example, "B<-relx>=>0.5, B<-x>=-2"
+positions the left edge of the slave 2 pixels to the left of the
+center of its master.
+
+=item B<-y> => I<location>
+
+I<Location> specifies the y-coordinate within the master window
+of the anchor point for I<$slave> widget.
+The location is specified in screen units (i.e. any of the forms
+accepted by B<Tk_GetPixels>) and need not lie within the bounds
+of the master window.
+
+=item B<-rely> => I<location>
+
+I<Location> specifies the y-coordinate within the master window
+of the anchor point for I<$slave> widget.
+In this case the value is specified in a relative fashion
+as a floating-point number: 0.0 corresponds to the top edge
+of the master and 1.0 corresponds to the bottom edge of the master.
+I<Location> need not be in the range 0.0-1.0.
+If both B<-y> and B<-rely> are specified for a slave
+then their values are summed. For example, B<-rely>=>0.5, B<-x>=>3
+positions the top edge of the slave 3 pixels below the
+center of its master.
+
+=item B<-anchor> => I<where>
+
+I<Where> specifies which point of I<$slave> is to be positioned
+at the (x,y) location selected by the B<-x>, B<-y>,
+B<-relx>, and B<-rely> options.
+The anchor point is in terms of the outer area of I<$slave>
+including its border, if any.
+Thus if I<where> is B<se> then the lower-right corner of
+I<$slave>'s border will appear at the given (x,y) location
+in the master.
+The anchor position defaults to B<nw>.
+
+=item B<-width> => I<size>
+
+I<Size> specifies the width for I<$slave> in screen units
+(i.e. any of the forms accepted by B<Tk_GetPixels>).
+The width will be the outer width of I<$slave> including its
+border, if any.
+If I<size> is an empty string, or if no B<-width>
+or B<-relwidth> option is specified, then the width requested
+internally by the window will be used.
+
+=item B<-relwidth> => I<size>
+
+I<Size> specifies the width for I<$slave>.
+In this case the width is specified as a floating-point number
+relative to the width of the master: 0.5 means I<$slave> will
+be half as wide as the master, 1.0 means I<$slave> will have
+the same width as the master, and so on.
+If both B<-width> and B<-relwidth> are specified for a slave,
+their values are summed. For example, B<-relwidth>=>1.0, B<-width>=>5
+makes the slave 5 pixels wider than the master.
+
+=item B<-height> => I<size>
+
+I<Size> specifies the height for I<$slave> in screen units
+(i.e. any of the forms accepted by B<Tk_GetPixels>).
+The height will be the outer dimension of I<$slave> including its
+border, if any.
+If I<size> is an empty string, or if no B<-height> or
+B<-relheight> option is specified, then the height requested
+internally by the window will be used.
+
+=item B<-relheight> => I<size>
+
+I<Size> specifies the height for I<$slave>.
+In this case the height is specified as a floating-point number
+relative to the height of the master: 0.5 means I<$slave> will
+be half as high as the master, 1.0 means I<$slave> will have
+the same height as the master, and so on.
+If both B<-height> and B<-relheight> are specified for a slave,
+their values are summed. For example, B<-relheight>=>1.0, B<-height>=>-2
+makes the slave 2 pixels shorter than the master.
+
+=item B<-bordermode> => I<mode>
+
+I<Mode> determines the degree to which borders within the
+master are used in determining the placement of the slave.
+The default and most common value is B<inside>.
+In this case the placer considers the area of the master to
+be the innermost area of the master, inside any border:
+an option of B<-x>=>B<0> corresponds to an x-coordinate just
+inside the border and an option of B<-relwidth>=>1.0
+means I<$slave> will fill the area inside the master's
+border.
+If I<mode> is B<outside> then the placer considers
+the area of the master to include its border;
+this mode is typically used when placing I<$slave>
+outside its master, as with the options
+B<-x>=>B<0>, B<-y>=>B<0>, B<-anchor>=>B<ne>.
+Lastly, I<mode> may be specified as B<ignore>, in which
+case borders are ignored: the area of the master is considered
+to be its official X area, which includes any internal border but
+no external border. A bordermode of B<ignore> is probably
+not very useful.
+
+If the same value is specified separately with
+two different options, such as B<-x> and B<-relx>, then
+the most recent option is used and the older one is ignored.
+
+=back
+
+=item I<$slave>->B<placeSlaves>
+
+The B<placeSlaves> method returns a list of all the slave
+windows for which I<$master> is the master.
+If there are no slaves for I<$master> then an empty list is
+returned.
+
+=item I<$slave>->B<placeForget>
+
+The B<placeForget> method causes the placer to stop managing
+the geometry of I<$slave>. As a side effect of this method call
+I<$slave> will be unmapped so that it doesn't appear on the
+screen.
+If I<$slave> isn't currently managed by the placer then the
+method call has no effect.
+B<placeForget> returns an empty string as result.
+
+=item I<$slave>->B<placeInfo>
+
+The B<placeInfo> method returns a list giving the current
+configuration of I<$slave>.
+The list consists of I<-option>=>I<value> pairs in exactly the
+same form as might be specified to the B<place>
+method.
+If the configuration of a window has been retrieved with
+B<placeInfo>, that configuration can be restored later by
+first using B<placeForget> to erase any existing information
+for the window and then invoking B<place> with
+the saved information.
+
+=back
+
+=head1 FINE POINTS
+
+It is not necessary for the master window to be the parent
+of the slave window.
+This feature is useful in at least two situations.
+First, for complex window layouts it means you can create a
+hierarchy of subwindows whose only purpose
+is to assist in the layout of the parent.
+The ``I<real children>'' of the parent (i.e. the windows that
+are significant for the application's user interface) can be
+children of the parent yet be placed inside the windows
+of the geometry-management hierarchy.
+This means that the path names of the ``I<real children>''
+don't reflect the geometry-management hierarchy and users
+can specify options for the real children
+without being aware of the structure of the geometry-management
+hierarchy.
+
+A second reason for having a master different than the slave's
+parent is to tie two siblings together.
+For example, the placer can be used to force a window always to
+be positioned centered just below one of its
+siblings by specifying the configuration
+
+S< >B<-in>=>I<$sibling>, B<-relx>=>0.5, B<-rely>=>1.0,
+B<-anchor>=>'n', B<-bordermode>=>'outside'
+
+Whenever the I<$sibling> widget is repositioned in the future, the slave
+will be repositioned as well.
+
+Unlike many other geometry managers (such as the packer)
+the placer does not make any attempt to manipulate the geometry of
+the master windows or the parents of slave windows (i.e. it doesn't
+set their requested sizes).
+To control the sizes of these windows, make them windows like
+frames and canvases that provide configuration options for this purpose.
+
+=head1 SEE ALSO
+
+L<Tk::form|Tk::form>
+L<Tk::grid|Tk::grid>
+L<Tk::pack|Tk::pack>
+
+=head1 KEYWORDS
+
+geometry manager, height, location, master, place, rubber sheet, slave, width
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/prolog.ps b/Master/tlpkg/tlperl.straw/lib/Tk/prolog.ps
new file mode 100755
index 00000000000..409e06a65a0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/prolog.ps
@@ -0,0 +1,284 @@
+%%BeginProlog
+50 dict begin
+
+% This is a standard prolog for Postscript generated by Tk's canvas
+% widget.
+% SCCS: @(#) prolog.ps 1.5 96/02/17 17:45:11
+
+% The definitions below just define all of the variables used in
+% any of the procedures here. This is needed for obscure reasons
+% explained on p. 716 of the Postscript manual (Section H.2.7,
+% "Initializing Variables," in the section on Encapsulated Postscript).
+
+/baseline 0 def
+/stipimage 0 def
+/height 0 def
+/justify 0 def
+/lineLength 0 def
+/spacing 0 def
+/stipple 0 def
+/strings 0 def
+/xoffset 0 def
+/yoffset 0 def
+/tmpstip null def
+
+% Define the array ISOLatin1Encoding (which specifies how characters are
+% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript
+% level 2 is supposed to define it, but level 1 doesn't).
+
+systemdict /ISOLatin1Encoding known not {
+ /ISOLatin1Encoding [
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /space /exclam /quotedbl /numbersign /dollar /percent /ampersand
+ /quoteright
+ /parenleft /parenright /asterisk /plus /comma /minus /period /slash
+ /zero /one /two /three /four /five /six /seven
+ /eight /nine /colon /semicolon /less /equal /greater /question
+ /at /A /B /C /D /E /F /G
+ /H /I /J /K /L /M /N /O
+ /P /Q /R /S /T /U /V /W
+ /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore
+ /quoteleft /a /b /c /d /e /f /g
+ /h /i /j /k /l /m /n /o
+ /p /q /r /s /t /u /v /w
+ /x /y /z /braceleft /bar /braceright /asciitilde /space
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
+ /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron
+ /space /exclamdown /cent /sterling /currency /yen /brokenbar /section
+ /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen
+ /registered /macron
+ /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph
+ /periodcentered
+ /cedillar /onesuperior /ordmasculine /guillemotright /onequarter
+ /onehalf /threequarters /questiondown
+ /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla
+ /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex
+ /Idieresis
+ /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply
+ /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn
+ /germandbls
+ /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla
+ /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex
+ /idieresis
+ /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide
+ /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn
+ /ydieresis
+ ] def
+} if
+
+% font ISOEncode font
+% This procedure changes the encoding of a font from the default
+% Postscript encoding to ISOLatin1. It's typically invoked just
+% before invoking "setfont". The body of this procedure comes from
+% Section 5.6.1 of the Postscript book.
+
+/ISOEncode {
+ dup length dict begin
+ {1 index /FID ne {def} {pop pop} ifelse} forall
+ /Encoding ISOLatin1Encoding def
+ currentdict
+ end
+
+ % I'm not sure why it's necessary to use "definefont" on this new
+ % font, but it seems to be important; just use the name "Temporary"
+ % for the font.
+
+ /Temporary exch definefont
+} bind def
+
+% StrokeClip
+%
+% This procedure converts the current path into a clip area under
+% the assumption of stroking. It's a bit tricky because some Postscript
+% interpreters get errors during strokepath for dashed lines. If
+% this happens then turn off dashes and try again.
+
+/StrokeClip {
+ {strokepath} stopped {
+ (This Postscript printer gets limitcheck overflows when) =
+ (stippling dashed lines; lines will be printed solid instead.) =
+ [] 0 setdash strokepath} if
+ clip
+} bind def
+
+% desiredSize EvenPixels closestSize
+%
+% The procedure below is used for stippling. Given the optimal size
+% of a dot in a stipple pattern in the current user coordinate system,
+% compute the closest size that is an exact multiple of the device's
+% pixel size. This allows stipple patterns to be displayed without
+% aliasing effects.
+
+/EvenPixels {
+ % Compute exact number of device pixels per stipple dot.
+ dup 0 matrix currentmatrix dtransform
+ dup mul exch dup mul add sqrt
+
+ % Round to an integer, make sure the number is at least 1, and compute
+ % user coord distance corresponding to this.
+ dup round dup 1 lt {pop 1} if
+ exch div mul
+} bind def
+
+% width height string StippleFill --
+%
+% Given a path already set up and a clipping region generated from
+% it, this procedure will fill the clipping region with a stipple
+% pattern. "String" contains a proper image description of the
+% stipple pattern and "width" and "height" give its dimensions. Each
+% stipple dot is assumed to be about one unit across in the current
+% user coordinate system. This procedure trashes the graphics state.
+
+/StippleFill {
+ % The following code is needed to work around a NeWSprint bug.
+
+ /tmpstip 1 index def
+
+ % Change the scaling so that one user unit in user coordinates
+ % corresponds to the size of one stipple dot.
+ 1 EvenPixels dup scale
+
+ % Compute the bounding box occupied by the path (which is now
+ % the clipping region), and round the lower coordinates down
+ % to the nearest starting point for the stipple pattern. Be
+ % careful about negative numbers, since the rounding works
+ % differently on them.
+
+ pathbbox
+ 4 2 roll
+ 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll
+ 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll
+
+ % Stack now: width height string y1 y2 x1 x2
+ % Below is a doubly-nested for loop to iterate across this area
+ % in units of the stipple pattern size, going up columns then
+ % across rows, blasting out a stipple-pattern-sized rectangle at
+ % each position
+
+ 6 index exch {
+ 2 index 5 index 3 index {
+ % Stack now: width height string y1 y2 x y
+
+ gsave
+ 1 index exch translate
+ 5 index 5 index true matrix tmpstip imagemask
+ grestore
+ } for
+ pop
+ } for
+ pop pop pop pop pop
+} bind def
+
+% -- AdjustColor --
+% Given a color value already set for output by the caller, adjusts
+% that value to a grayscale or mono value if requested by the CL
+% variable.
+
+/AdjustColor {
+ CL 2 lt {
+ currentgray
+ CL 0 eq {
+ .5 lt {0} {1} ifelse
+ } if
+ setgray
+ } if
+} bind def
+
+% x y strings spacing xoffset yoffset justify stipple DrawText --
+% This procedure does all of the real work of drawing text. The
+% color and font must already have been set by the caller, and the
+% following arguments must be on the stack:
+%
+% x, y - Coordinates at which to draw text.
+% strings - An array of strings, one for each line of the text item,
+% in order from top to bottom.
+% spacing - Spacing between lines.
+% xoffset - Horizontal offset for text bbox relative to x and y: 0 for
+% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.
+% yoffset - Vertical offset for text bbox relative to x and y: 0 for
+% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.
+% justify - 0 for left justification, 0.5 for center, 1 for right justify.
+% stipple - Boolean value indicating whether or not text is to be
+% drawn in stippled fashion. If text is stippled,
+% procedure StippleText must have been defined to call
+% StippleFill in the right way.
+%
+% Also, when this procedure is invoked, the color and font must already
+% have been set for the text.
+
+/DrawText {
+ /stipple exch def
+ /justify exch def
+ /yoffset exch def
+ /xoffset exch def
+ /spacing exch def
+ /strings exch def
+
+ % First scan through all of the text to find the widest line.
+
+ /lineLength 0 def
+ strings {
+ stringwidth pop
+ dup lineLength gt {/lineLength exch def} {pop} ifelse
+ newpath
+ } forall
+
+ % Compute the baseline offset and the actual font height.
+
+ 0 0 moveto (TXygqPZ) false charpath
+ pathbbox dup /baseline exch def
+ exch pop exch sub /height exch def pop
+ newpath
+
+ % Translate coordinates first so that the origin is at the upper-left
+ % corner of the text's bounding box. Remember that x and y for
+ % positioning are still on the stack.
+
+ translate
+ lineLength xoffset mul
+ strings length 1 sub spacing mul height add yoffset mul translate
+
+ % Now use the baseline and justification information to translate so
+ % that the origin is at the baseline and positioning point for the
+ % first line of text.
+
+ justify lineLength mul baseline neg translate
+
+ % Iterate over each of the lines to output it. For each line,
+ % compute its width again so it can be properly justified, then
+ % display it.
+
+ strings {
+ dup stringwidth pop
+ justify neg mul 0 moveto
+ stipple {
+
+ % The text is stippled, so turn it into a path and print
+ % by calling StippledText, which in turn calls StippleFill.
+ % Unfortunately, many Postscript interpreters will get
+ % overflow errors if we try to do the whole string at
+ % once, so do it a character at a time.
+
+ gsave
+ /char (X) def
+ {
+ char 0 3 -1 roll put
+ currentpoint
+ gsave
+ char true charpath clip StippleText
+ grestore
+ char stringwidth translate
+ moveto
+ } forall
+ grestore
+ } {show} ifelse
+ 0 spacing neg translate
+ } forall
+} bind def
+
+%%EndProlog
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/reindex.pl b/Master/tlpkg/tlperl.straw/lib/Tk/reindex.pl
new file mode 100755
index 00000000000..7af5cc1d13f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/reindex.pl
@@ -0,0 +1,33 @@
+#!/bin/perl
+
+use lib qw(/home1/gbartels/textlist);
+use Tk;
+
+use Tk::TextReindex qw(Tk::ROText ROTextReindex);
+
+$mw=new MainWindow;
+
+my $idx;
+
+$w=$mw->ROTextReindex()->pack(-side => "top");
+$t=$mw->Label(-textvariable => \$idx)->pack(-side => "bottom");
+
+$w->bind('<Key>',sub{$idx=$w->index("insert")});
+
+$w->insert('end',"abcd\n");
+$w->insert('end',"efgh\n");
+$w->insert('end',"mnop\n");
+$w->insert('end',"qrst\n");
+$w->insert('end',"uvwx\n");
+
+$w->insert('2.0',"ijkl\n");
+
+my $string = $w->get('4.0');
+
+
+my $result = "reading index 4.0 : expect string to equal >q<, actual value is $string \n";
+$w->insert('end',$result);
+
+print $result;
+
+MainLoop;
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/selection.pod b/Master/tlpkg/tlperl.straw/lib/Tk/selection.pod
new file mode 100755
index 00000000000..f8a3ce54856
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/selection.pod
@@ -0,0 +1,159 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+Tk::Selection - Manipulate the X selection
+
+=for category User Interaction
+
+=head1 SYNOPSIS
+
+I<$widget>-E<gt>B<Selection>I<Option>?(I<args>)?
+
+=head1 DESCRIPTION
+
+This command provides an interface to the X selection mechanism and
+implements the full selection functionality described in the
+X Inter-Client Communication Conventions Manual (ICCCM).
+
+The widget object used to invoke the methods below determines which
+display is used to access the selection.
+In order to avoid conflicts with B<selection> methods of widget classes
+(e.g. B<Text>) this set of methods uses the prefix B<Selection>.
+The following methods are currently supported:
+
+=over 4
+
+=item I<$widget>-E<gt>B<SelectionClear>?(B<-selection>=E<gt>I<selection>)?
+
+If I<selection> exists anywhere on I<$widget>'s display, clear it
+so that no window owns the selection anymore. I<Selection>
+specifies the X selection that should be cleared, and should be an
+atom name such as PRIMARY or CLIPBOARD; see the Inter-Client
+Communication Conventions Manual for complete details.
+I<Selection> defaults to PRIMARY.
+Returns an empty string.
+
+=item I<$widget>-E<gt>B<SelectionGet>?(?B<-selection>=E<gt>I<selection>?,?B<-type>=E<gt>I<type>?)?
+
+Retrieves the value of I<selection> from I<$widget>'s display and
+returns it as a result. I<Selection> defaults to PRIMARY.
+
+I<Type> specifies the form in which the selection is to be returned
+(the desired ``target'' for conversion, in ICCCM terminology), and
+should be an atom name such as STRING or FILE_NAME; see the
+Inter-Client Communication Conventions Manual for complete details.
+I<Type> defaults to STRING. The selection owner may choose to
+return the selection in any of several different representation
+formats, such as STRING, ATOM, INTEGER, etc. (this format is different
+than the selection type; see the ICCCM for all the confusing details).
+
+If I<format> is not STRING then things get messy, the following
+description is from the Tcl/Tk man page as yet incompetely translated for
+the perl version - it is misleading at best.
+
+If the selection is returned in a non-string format, such as INTEGER
+or ATOM, the B<SelectionGet> converts it to a list of perl
+values: atoms are converted to their
+textual names, and anything else is converted integers.
+
+A goal of the perl port is to provide better handling of different
+formats than Tcl/Tk does, which should be possible given perl's
+wider range of ``types''. Although some thought went into this
+in very early days of perl/Tk what exactly happens is still
+"not quite right" and subject to change.
+
+=item I<$widget>-E<gt>B<SelectionHandle>(?B<-selection>=E<gt>I<selection>?,?B<-type>=E<gt>I<type>?,?B<-format>=E<gt>I<format>? I<callback>)
+
+Creates a handler for selection requests, such that I<callback> will
+be executed whenever I<selection> is owned by I<$widget> and
+someone attempts to retrieve it in the form given by I<type>
+(e.g. I<type> is specified in the B<selection get> command).
+I<Selection> defaults to PRIMARY, I<type> defaults to STRING, and
+I<format> defaults to STRING. If I<callback> is an empty string
+then any existing handler for I<$widget>, I<type>, and
+I<selection> is removed.
+
+When I<selection> is requested, I<$widget> is the selection owner,
+and I<type> is the requested type, I<callback> will be executed
+with two additional arguments.
+The two additional arguments
+are I<offset> and I<maxBytes>: I<offset> specifies a starting
+character position in the selection and I<maxBytes> gives the maximum
+number of bytes to retrieve. The command should return a value consisting
+of at most I<maxBytes> of the selection, starting at position
+I<offset>. For very large selections (larger than I<maxBytes>)
+the selection will be retrieved using several invocations of I<callback>
+with increasing I<offset> values. If I<callback> returns a string
+whose length is less than I<maxBytes>, the return value is assumed to
+include all of the remainder of the selection; if the length of
+I<callback>'s result is equal to I<maxBytes> then
+I<callback> will be invoked again, until it eventually
+returns a result shorter than I<maxBytes>. The value of I<maxBytes>
+will always be relatively large (thousands of bytes).
+
+If I<callback> returns an error (e.g. via B<die>)
+then the selection retrieval is rejected
+just as if the selection didn't exist at all.
+
+The I<format> argument specifies the representation that should be
+used to transmit the selection to the requester (the second column of
+Table 2 of the ICCCM), and defaults to STRING. If I<format> is
+STRING, the selection is transmitted as 8-bit ASCII characters (i.e.
+just in the form returned by I<command>).
+
+If I<format> is not STRING then things get messy, the following
+description is from the Tcl/Tk man page as yet untranslated for
+the perl version - it is misleading at best.
+
+If I<format> is
+ATOM, then the return value from I<command> is divided into fields
+separated by white space; each field is converted to its atom value,
+and the 32-bit atom value is transmitted instead of the atom name.
+For any other I<format>, the return value from I<command> is
+divided into fields separated by white space and each field is
+converted to a 32-bit integer; an array of integers is transmitted
+to the selection requester.
+
+The I<format> argument is needed only for compatibility with
+many selection requesters, except Tcl/Tk. If Tcl/Tk is being
+used to retrieve the selection then the value is converted back to
+a string at the requesting end, so I<format> is
+irrelevant.
+
+A goal of the perl port is to provide better handling of different
+formats than Tcl/Tk does, which should be possible given perl's
+wider range of ``types''. Although some thought went into this
+in very early days of perl/Tk what exactly happens is still
+"not quite right" and subject to change.
+
+=item I<$widget>-E<gt>B<SelectionOwner>?(B<-selection>=E<gt>I<selection>)?
+
+B<SelectionOwner> returns the
+window in this application that owns I<selection> on the display
+containing I<$widget>, or an empty string if no window in this
+application owns the selection. I<Selection> defaults to PRIMARY.
+
+=item I<$widget>-E<gt>B<SelectionOwn>?(?B<-command>=E<gt>I<callback>?,?B<-selection>=E<gt>I<selection>?)?
+
+B<SelectionOwn> causes I<$widget> to become
+the new owner of I<selection> on I<$widget>'s display, returning
+an empty string as result. The existing owner, if any, is notified
+that it has lost the selection.
+If I<callback> is specified, it will be executed when
+some other window claims ownership of the selection away from
+I<$widget>. I<Selection> defaults to PRIMARY.
+
+=back
+
+=head1 KEYWORDS
+
+clear, format, handler, ICCCM, own, selection, target, type
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/send.pod b/Master/tlpkg/tlperl.straw/lib/Tk/send.pod
new file mode 100755
index 00000000000..40382f2422d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/send.pod
@@ -0,0 +1,118 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+send - Execute a command in a different application
+
+=for category Tk Generic Methods
+
+=head1 SYNOPSIS
+
+S< >I<$result> = I<$widget>-E<gt>B<send>(?I<options>,?I<app>=E<gt>I<cmd>?I<arg arg ...>?)
+
+=head1 DESCRIPTION
+
+This method arranges for I<cmd> (and I<arg>s) to be 'sent' to the
+application named by I<app>. It returns the result or
+an error (hence above should probably be 'wrapped' in B<eval{}> and $@ tested).
+I<App> may be the name of any application whose main window is
+on the display containing the sender's main window; it need not
+be within the same process.
+If no I<arg> arguments are present, then the string to be sent
+is contained entirely within the I<cmd> argument. If one or
+more I<arg>s are present, they are concatenated separated by white space to
+form the string to be sent.
+
+If the initial arguments of the call begin with ``-''
+they are treated as options. The following options are
+currently defined:
+
+=over 4
+
+=item B<-async>
+
+Requests asynchronous invocation. In this case the B<send>
+command will complete immediately without waiting for I<cmd>
+to complete in the target application; no result will be available
+and errors in the sent command will be ignored.
+If the target application is in the same process as the sending
+application then the B<-async> option is ignored.
+
+=item B<-->
+
+Serves no purpose except to terminate the list of options. This
+option is needed only if I<app> could contain a leading ``-''
+character.
+
+=back
+
+=head1 APPLICATION NAMES
+
+The name of an application is set initially from the name of the
+program or script that created the application.
+You can query and change the name of an application with the
+B<appname> method.
+
+=head1 WHAT IS A SEND
+
+The B<send> mechanism was designed to allow Tcl/Tk applications
+to send Tcl Scripts to each other. This does not map very well onto perl/Tk.
+Perl/Tk "sends" a string to I<app>, what happens as a result of this
+depends on the receiving application. If the other application is a Tcl/Tk4.*
+application it will be treated as a Tcl Script. If the "other" application is
+perl/Tk application (including sends to self) then the string is
+passed as an argument to a method call of the following form:
+
+I<$mainwindow>-E<gt>B<Receive(>I<string>);
+
+There is a default (AutoLoaded) B<Tk::Receive> which returns an error to the
+sending application. A particular application may define its own
+B<Receive> method in any class in B<MainWindow>'s inheritance tree
+to do whatever it sees fit. For example it could B<eval> the string,
+possibly in a B<Safe> "compartment".
+
+If a Tcl/Tk application "sends" anything to a perl/Tk application
+then the perl/Tk application would have to attempt to interpret the
+incoming string as a Tcl Script. Simple cases are should not be too hard to
+emulate (split on white space and treat first element as "command" and other
+elements as arguments).
+
+=head1 SECURITY
+
+The B<send> command is potentially a serious security loophole,
+since any application that can connect to your X server can send
+scripts to your applications. Hence the default behaviour outlined above.
+(With the availability of B<Safe> it may make sense to relax default behaviour
+a little.)
+
+Unmonitored B<eval>'ing of these incoming "scripts" can cause perl to
+read and write files and invoke subprocesses under your name.
+Host-based access control such as that provided by B<xhost>
+is particularly insecure, since it allows anyone with an account
+on particular hosts to connect to your server, and if disabled it
+allows anyone anywhere to connect to your server.
+In order to provide at least a small amount of
+security, core Tk checks the access control being used by the server
+and rejects incoming sends unless (a) B<xhost>-style access control
+is enabled (i.e. only certain hosts can establish connections) and (b) the
+list of enabled hosts is empty.
+This means that applications cannot connect to your server unless
+they use some other form of authorization
+such as that provide by B<xauth>.
+
+=head1 SEE ALSO
+
+L<perlfunc/eval>, L<Safe>,
+system's administrator/corporate security guidelines etc.
+
+=head1 KEYWORDS
+
+application, name, remote execution, security, send
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/srcfile.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/srcfile.xpm
new file mode 100755
index 00000000000..06a40a96c84
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/srcfile.xpm
@@ -0,0 +1,18 @@
+/* XPM */
+static char * srcfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c #000000000000",
+"X c gray91",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .XXXXXXXX. ",
+" .XX...XXX. ",
+" .X.XXX.XX. ",
+" .X.XXXXXX. ",
+" .X.XXXXXX. ",
+" .XX....XX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .......... "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/textfile.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/textfile.xpm
new file mode 100755
index 00000000000..8fa8d2f9032
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/textfile.xpm
@@ -0,0 +1,18 @@
+/* XPM */
+static char * textfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c #000000000000",
+"X c #E0E0FFFFE0E0",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .X....XXX. ",
+" .XXXXXXXX. ",
+" .X...XXXX. ",
+" .XXXXXXXX. ",
+" .X.....XX. ",
+" .XXXXXXXX. ",
+" .X.....XX. ",
+" .XXXXXXXX. ",
+" .......... "};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tixWm.pod b/Master/tlpkg/tlperl.straw/lib/Tk/tixWm.pod
new file mode 100755
index 00000000000..9bdd02d461c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tixWm.pod
@@ -0,0 +1,73 @@
+
+
+=head1 NAME
+
+Tk::tixWm - Tix's addition to the standard TK wm command.
+
+=for category Tix Extensions
+
+=head1 SYNOPSIS
+
+S< >I<$widget>-E<gt>B<wmCapture>
+
+S< >I<$widget>-E<gt>B<wmRelease>
+
+=head1 DESCRIPTION
+
+The B<wmCapture> and the B<wmRelease> methods change the
+toplevel attribute of Tk widgets.
+
+=head1 METHODS
+
+=over 4
+
+=item I<$widget>-E<gt>B<wmCapture>
+
+Converts the toplevel window specified by I<$widget> into a non-toplevel
+widget. Normally this command is called to convert a L<Toplevel|Tk::Toplevel> widget
+into a L<Frame|Tk::Frame> widget. The newly-converted frame widget is
+un-mapped from the screen. To make it appear inside its parent, you
+must call a geometry manager (e.g. grid or pack) explictly.
+
+=item I<$widget>-E<gt>B<wmRelease>
+
+Makes the non-toplevel window specified by I<$widget> into a toplevel
+widget. Normally this command is called to convert a L<Frame|Tk::Frame> widget
+into a L<Toplevel|Tk::Toplevel> widget, but it can also be used on any
+non-toplevel widget (e.g, label). The newly-converted toplevel window
+is in a B<withdrawn> state. To make it appear on the screen, you must call
+B<deiconify> after calling B<wmRelease>.
+
+Any data associated with I<$widget> via B<wm> methods (icon, protocol,
+command etc.) are released, and must be re-established if window is later
+re-captured.
+
+=back
+
+=head1 BUGS
+
+B<wmCapture> does not exist in the Win32 window manager code.
+
+How these methods interact with perl/Tk's class hierarchy is not yet clear.
+In particular a B<wmRelease>d window will not automatically ``I<inherit>''
+the B<Tk::Wm> methods, however a B<wmCapture>d window still will.
+(A B<release>d B<Label> might make a good candidate for an B<Icon>.)
+
+=head1 AUTHORS
+
+Ioi Kim Lam - ioi@graphics.cis.upenn.edu wrote original Tix version.
+Updated for tk8.0, Win32 and perl by Nick Ing-Simmons.
+
+=head1 SEE ALSO
+
+L<Tk::Wm|Tk::Wm>
+L<Tk::Mwm|Tk::Mwm>
+L<Tk::Frame|Tk::Frame>
+L<Tk::Toplevel|Tk::Toplevel>
+
+=head1 KEYWORDS
+
+window manager, wm, TIX
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.def b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.def
new file mode 100755
index 00000000000..2f1662c71c2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.def
@@ -0,0 +1,130 @@
+#ifdef CAN_PROTOTYPE
+#define XSdec(x) XS(x)
+#else
+#define XSdec(x) void x()
+#endif
+
+#define TKXSRETURN(off) \
+ STMT_START { \
+ IV ptkAdj = (off); \
+ XSRETURN(ptkAdj); \
+ } STMT_END
+
+#ifndef PATCHLEVEL
+#include <patchlevel.h>
+#endif
+
+#if defined(PATCHLEVEL) && (PATCHLEVEL < 5)
+#define PL_sv_undef sv_undef
+#define PL_tainting tainting
+#define PL_tainted tainted
+#define PL_stack_base stack_base
+#define PL_stack_sp stack_sp
+#define PL_curcop curcop
+#endif
+
+#ifndef CopSTASH
+#define CopSTASH(c) c->cop_stash
+#define CopSTASH_set(c,h) (CopSTASH(c) = h)
+#endif
+
+#ifndef dTHX
+#define dTHR int maybeTHR
+#endif
+
+#ifndef dTHXs
+#ifdef PERL_IMPLICIT_SYS
+#define dTHXs dTHX
+#else
+#define dTHR int maybeTHR
+#endif
+#endif
+
+#ifndef ERRSV
+#define ERRSV GvSV(errgv)
+#endif
+
+#ifndef aTHX_
+#define aTHX_
+#endif
+
+#ifndef pTHX_
+#define pTHX_
+#endif
+
+#ifdef dirty
+#undef dirty
+#endif
+#ifdef bufptr
+#undef bufptr
+#endif
+#ifdef colors
+#undef colors
+#endif
+#ifdef JOIN
+#undef JOIN
+#endif
+
+#ifdef na
+#if PATCHLEVEL >= 5
+#undef na
+#endif
+#endif
+
+
+#define Tcl_Interp HV
+#define LangCallback SV
+#define Var SV *
+#define LangResultSave AV
+struct Lang_CmdInfo;
+#define Tcl_Command struct Lang_CmdInfo *
+struct WrappedRegExp;
+#define Tcl_RegExp struct WrappedRegExp *
+#define Tcl_Obj SV
+#define Tcl_DString SV *
+
+#ifndef PerlIO
+#define PerlIO FILE
+#define PerlIO_stderr() stderr
+#define PerlIO_printf fprintf
+#define PerlIO_flush(f) Fflush(f)
+#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a)
+#define PerlIO_putc(f,c) fputc(c,f)
+#define PerlIO_fileno(f) fileno(f)
+
+/* Now our interface to Configure's FILE_xxx macros */
+
+#ifdef USE_STDIO_PTR
+#define PerlIO_has_cntptr(f) 1
+#define PerlIO_get_ptr(f) FILE_ptr(f)
+#define PerlIO_get_cnt(f) FILE_cnt(f)
+
+#ifdef FILE_CNT_LVALUE
+#define PerlIO_canset_cnt(f) 1
+#ifdef FILE_PTR_LVALUE
+#define PerlIO_fast_gets(f) 1
+#endif
+#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c))
+#else
+#define PerlIO_canset_cnt(f) 0
+#define PerlIO_set_cnt(f,c) abort()
+#endif
+
+#ifdef FILE_PTR_LVALUE
+#define PerlIO_set_ptrcnt(f,p,c) (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c))
+#else
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+#endif
+
+#else /* USE_STDIO_PTR */
+
+#define PerlIO_has_cntptr(f) 0
+#define PerlIO_get_cnt(f) (abort(),0)
+#define PerlIO_get_ptr(f) (abort(),0)
+#define PerlIO_set_cnt(f,c) abort()
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+
+#endif /* USE_STDIO_PTR */
+
+#endif
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.h b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.h
new file mode 100755
index 00000000000..31a7f861700
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.h
@@ -0,0 +1,79 @@
+#ifndef _TKGLUE
+#define _TKGLUE
+
+#ifndef BASEEXT
+#define BASEEXT "Tk"
+#endif
+
+#ifndef _TKOPTION
+#include "pTk/tkOption.h"
+#include "pTk/tkOption_f.h"
+#endif
+
+typedef struct EventAndKeySym
+ {XEvent event;
+ KeySym keySym;
+ Tcl_Interp *interp;
+ Tk_Window tkwin;
+ SV *window;
+ } EventAndKeySym;
+
+typedef struct Lang_CmdInfo
+ {Tcl_CmdInfo Tk;
+ Tcl_Interp *interp;
+ Tk_Window tkwin;
+ SV *image;
+ Tk_Font tkfont;
+ } Lang_CmdInfo;
+
+#include "vtab.def"
+
+
+#define VTABLE_INIT() IMPORT_VTABLES
+
+extern Lang_CmdInfo *WindowCommand _ANSI_ARGS_((SV *win,HV **hptr, int moan));
+extern Tk_Window SVtoWindow _ANSI_ARGS_((SV *win));
+extern Tk_Font SVtoFont _ANSI_ARGS_((SV *win));
+extern int Call_Tk _ANSI_ARGS_((Lang_CmdInfo *info,int argc, SV **args));
+extern HV *InterpHv _ANSI_ARGS_((Tcl_Interp *interp,int fatal));
+extern SV *WidgetRef _ANSI_ARGS_((Tcl_Interp *interp, char *path));
+extern SV *ObjectRef _ANSI_ARGS_((Tcl_Interp *interp, char *path));
+extern SV *TkToWidget _ANSI_ARGS_((Tk_Window tkwin,Tcl_Interp **pinterp));
+extern SV *FindTkVarName _ANSI_ARGS_((CONST char *varName,int flags));
+extern void EnterWidgetMethods _ANSI_ARGS_((char *package, ...));
+extern SV *MakeReference _ANSI_ARGS_((SV * sv));
+extern Tk_Window TkToMainWindow _ANSI_ARGS_((Tk_Window tkwin));
+extern void Lang_TkSubCommand _ANSI_ARGS_ ((char *name, Tcl_ObjCmdProc *proc));
+extern void Lang_TkCommand _ANSI_ARGS_ ((char *name, Tcl_ObjCmdProc *proc));
+extern SV *XEvent_Info _((EventAndKeySym *obj,char *s));
+extern EventAndKeySym *SVtoEventAndKeySym _((SV *arg));
+extern int XSTkCommand _ANSI_ARGS_((CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args));
+
+extern XS(XStoWidget);
+
+EXTERN void ClearErrorInfo _ANSI_ARGS_((SV *interp));
+EXTERN Tk_Window mainWindow;
+EXTERN void DumpStack _ANSI_ARGS_((CONST char *who));
+EXTERN void Boot_Glue (pTHX);
+EXTERN void Boot_Tix (pTHX);
+EXTERN void install_vtab _ANSI_ARGS_((char *name, void *table, size_t size));
+extern SV *TagIt _((SV *sv, char *type));
+extern void Font_DESTROY _((SV *sv));
+struct pTkCheckChain;
+extern void Tk_CheckHash _((SV *sv,struct pTkCheckChain *chain));
+
+extern int has_highbit(CONST char *s,int l);
+extern SV * sv_maybe_utf8(SV *sv);
+extern SV * Lang_SystemEncoding(void);
+
+#ifndef WIN32
+#define HWND void *
+#endif
+EXTERN HWND SVtoHWND _ANSI_ARGS_((SV *win));
+
+#ifdef WIN32
+#include "pTk/tkWinInt.h"
+#endif
+
+#endif
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.m b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.m
new file mode 100755
index 00000000000..922d1426a55
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.m
@@ -0,0 +1,74 @@
+#ifndef _TKGLUE_VM
+#define _TKGLUE_VM
+#include "tkGlue_f.h"
+#ifndef NO_VTABLES
+#ifndef Call_Tk
+# define Call_Tk (*TkglueVptr->V_Call_Tk)
+#endif
+
+#ifndef EnterWidgetMethods
+# define EnterWidgetMethods (*TkglueVptr->V_EnterWidgetMethods)
+#endif
+
+#ifndef FindTkVarName
+# define FindTkVarName (*TkglueVptr->V_FindTkVarName)
+#endif
+
+#ifndef InterpHv
+# define InterpHv (*TkglueVptr->V_InterpHv)
+#endif
+
+#ifndef Lang_TkCommand
+# define Lang_TkCommand (*TkglueVptr->V_Lang_TkCommand)
+#endif
+
+#ifndef Lang_TkSubCommand
+# define Lang_TkSubCommand (*TkglueVptr->V_Lang_TkSubCommand)
+#endif
+
+#ifndef MakeReference
+# define MakeReference (*TkglueVptr->V_MakeReference)
+#endif
+
+#ifndef ObjectRef
+# define ObjectRef (*TkglueVptr->V_ObjectRef)
+#endif
+
+#ifndef SVtoFont
+# define SVtoFont (*TkglueVptr->V_SVtoFont)
+#endif
+
+#ifndef SVtoHWND
+# define SVtoHWND (*TkglueVptr->V_SVtoHWND)
+#endif
+
+#ifndef SVtoWindow
+# define SVtoWindow (*TkglueVptr->V_SVtoWindow)
+#endif
+
+#ifndef TkToMainWindow
+# define TkToMainWindow (*TkglueVptr->V_TkToMainWindow)
+#endif
+
+#ifndef TkToWidget
+# define TkToWidget (*TkglueVptr->V_TkToWidget)
+#endif
+
+#ifndef WidgetRef
+# define WidgetRef (*TkglueVptr->V_WidgetRef)
+#endif
+
+#ifndef WindowCommand
+# define WindowCommand (*TkglueVptr->V_WindowCommand)
+#endif
+
+#ifndef XSTkCommand
+# define XSTkCommand (*TkglueVptr->V_XSTkCommand)
+#endif
+
+#ifndef install_vtab
+# define install_vtab (*TkglueVptr->V_install_vtab)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKGLUE_VM */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.t b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.t
new file mode 100755
index 00000000000..ff689ff5539
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue.t
@@ -0,0 +1,70 @@
+#ifdef _TKGLUE
+#ifndef Call_Tk
+VFUNC(int,Call_Tk,V_Call_Tk,_ANSI_ARGS_((Lang_CmdInfo *info,int argc, SV **args)))
+#endif /* #ifndef Call_Tk */
+
+#ifndef EnterWidgetMethods
+VFUNC(void,EnterWidgetMethods,V_EnterWidgetMethods,_ANSI_ARGS_((char *package, ...)))
+#endif /* #ifndef EnterWidgetMethods */
+
+#ifndef FindTkVarName
+VFUNC(SV *,FindTkVarName,V_FindTkVarName,_ANSI_ARGS_((CONST char *varName,int flags)))
+#endif /* #ifndef FindTkVarName */
+
+#ifndef InterpHv
+VFUNC(HV *,InterpHv,V_InterpHv,_ANSI_ARGS_((Tcl_Interp *interp,int fatal)))
+#endif /* #ifndef InterpHv */
+
+#ifndef Lang_TkCommand
+VFUNC(void,Lang_TkCommand,V_Lang_TkCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc)))
+#endif /* #ifndef Lang_TkCommand */
+
+#ifndef Lang_TkSubCommand
+VFUNC(void,Lang_TkSubCommand,V_Lang_TkSubCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc)))
+#endif /* #ifndef Lang_TkSubCommand */
+
+#ifndef MakeReference
+VFUNC(SV *,MakeReference,V_MakeReference,_ANSI_ARGS_((SV * sv)))
+#endif /* #ifndef MakeReference */
+
+#ifndef ObjectRef
+VFUNC(SV *,ObjectRef,V_ObjectRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path)))
+#endif /* #ifndef ObjectRef */
+
+#ifndef SVtoFont
+VFUNC(Tk_Font,SVtoFont,V_SVtoFont,_ANSI_ARGS_((SV *win)))
+#endif /* #ifndef SVtoFont */
+
+#ifndef SVtoHWND
+VFUNC(HWND,SVtoHWND,V_SVtoHWND,_ANSI_ARGS_((SV *win)))
+#endif /* #ifndef SVtoHWND */
+
+#ifndef SVtoWindow
+VFUNC(Tk_Window,SVtoWindow,V_SVtoWindow,_ANSI_ARGS_((SV *win)))
+#endif /* #ifndef SVtoWindow */
+
+#ifndef TkToMainWindow
+VFUNC(Tk_Window,TkToMainWindow,V_TkToMainWindow,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef TkToMainWindow */
+
+#ifndef TkToWidget
+VFUNC(SV *,TkToWidget,V_TkToWidget,_ANSI_ARGS_((Tk_Window tkwin,Tcl_Interp **pinterp)))
+#endif /* #ifndef TkToWidget */
+
+#ifndef WidgetRef
+VFUNC(SV *,WidgetRef,V_WidgetRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path)))
+#endif /* #ifndef WidgetRef */
+
+#ifndef WindowCommand
+VFUNC(Lang_CmdInfo *,WindowCommand,V_WindowCommand,_ANSI_ARGS_((SV *win,HV **hptr, int moan)))
+#endif /* #ifndef WindowCommand */
+
+#ifndef XSTkCommand
+VFUNC(int,XSTkCommand,V_XSTkCommand,_ANSI_ARGS_((CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args)))
+#endif /* #ifndef XSTkCommand */
+
+#ifndef install_vtab
+VFUNC(void,install_vtab,V_install_vtab,_ANSI_ARGS_((char *name, void *table, size_t size)))
+#endif /* #ifndef install_vtab */
+
+#endif /* _TKGLUE */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue_f.h b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue_f.h
new file mode 100755
index 00000000000..8255c08dc3f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tkGlue_f.h
@@ -0,0 +1,14 @@
+#ifndef TKGLUE_VT
+#define TKGLUE_VT
+typedef struct TkglueVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkGlue.t"
+#undef VFUNC
+#undef VVAR
+} TkglueVtab;
+extern TkglueVtab *TkglueVptr;
+extern TkglueVtab *TkglueVGet(void);
+#endif /* TKGLUE_VT */
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tkvars.pod b/Master/tlpkg/tlperl.straw/lib/Tk/tkvars.pod
new file mode 100755
index 00000000000..5ae8ac477ef
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tkvars.pod
@@ -0,0 +1,107 @@
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+=head1 NAME
+
+tkvars - Variables used or set by Tk
+
+=for category Tk Generic Methods
+
+=head1 DESCRIPTION
+
+The following perl variables are either set or used by Tk at various times
+in its execution. (For a list of variables used by perl see L<perlvar>.)
+
+=over 4
+
+=item B<$Tk::library>
+
+This variable holds the file name for a directory containing the modules
+related to Tk. These modules include an initialization
+file that is normally processed whenever a Tk application starts up,
+plus other files containing procedures that implement default behaviors
+for widgets.
+The initial value of B<$Tk::library> is set when Tk is added to
+an interpreter; this is done by searching searching for a directory
+named Tk in the directory where the file F<Tk.pm>, or the first
+directory F<Tk> in C<@INC>.
+
+The B<TK_LIBRARY> environment variable used by Tcl/Tk is not
+supported by perl/Tk. Please use L<@INC|perlvar/@INC> to change where modules
+are searched.
+
+B<Note:> This is Tcl remnant. With perl it makes more sense to
+use C<@INC> and C<%INC>).
+
+=item B<$Tk::patchLevel>
+
+Contains a decimal integer giving the current patch level for Tk.
+The patch level is incremented for each new release or patch, and
+it uniquely identifies an official version of Tk.
+
+B<Note:> this is Tcl remnant. With perl it makes more sense to
+use B<$Tk::VERSION> described below.
+
+=item B<$Tk::strictMotif>
+
+This variable is set to zero by default.
+If an application sets it to one, then Tk attempts to adhere as
+closely as possible to Motif look-and-feel standards.
+For example, active elements such as buttons and scrollbar
+sliders will not change color when the pointer passes over them.
+
+=item B<$Tk::VERSION>
+
+The variable holds the current version number of the perl/Tk
+release in the form I<major>.I<minor>. I<Major> and
+I<minor> are integers.
+
+The I<major> version number shows on which
+Tcl/Tk release perl/Tk is based. E.g., B<402> means based on
+Tcls Tk 4.2. (Patchlevel of Tcls Tk are not incorporated because
+perl/Tk tended to be ``I<ahead>'' of them on some fixes and behind on
+others. The first digest of the major version number increases in
+any Tk release that includes changes that are not backward compatible
+(i.e. whenever existing perl/Tk applications and scripts may have to change to
+work with the new release).
+
+The I<minor> version depends on perl/Tk only. It uses the
+'even'='stable', 'odd'='experimental' scheme that linux uses:
+
+ .0xx - inherently 'alpha'
+ .1xx - experimental 'beta'
+ .2xx - stable
+ .3xx - experimental
+ .4xx - stable
+ ...
+
+The minor version number increases with
+each new release of Tk, except that it resets to zero whenever the
+major version number changes.
+
+=item B<$Tk::version>
+
+The variable holds the current version number of the Tk
+library in the form I<major>.I<minor>. I<Major> and
+I<minor> are integers. The major version number increases in
+any Tk release that includes changes that are not backward compatible
+(i.e. whenever existing Tk applications and scripts may have to change to
+work with the new release). The minor version number increases with
+each new release of Tk, except that it resets to zero whenever the
+major version number changes.
+
+B<Note:> this is Tcl remnant. With perl it makes more sense to
+use B<$Tk::VERSION> described above.
+
+=back
+
+=head1 KEYWORDS
+
+variables, version
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/tranicon.gif b/Master/tlpkg/tlperl.straw/lib/Tk/tranicon.gif
new file mode 100755
index 00000000000..dc7d494c572
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/tranicon.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/typemap b/Master/tlpkg/tlperl.straw/lib/Tk/typemap
new file mode 100755
index 00000000000..29138850ab3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/typemap
@@ -0,0 +1,96 @@
+TYPEMAP
+Tk_Window T_TK_WINDOW
+Tk_Image T_TK_IMAGE
+TkWindow * T_TKWINDOW
+Display * T_IVOBJ
+Screen * T_IVOBJ
+Visual * T_IVOBJ
+Window T_IVOBJ
+Colormap T_IVOBJ
+GC T_IVOBJ
+Font T_IVOBJ
+Atom T_IV
+HANDLE T_IV
+BOOL T_IV
+HWND T_TK_HWND
+FILE * T_NIO
+hash_ptr * T_PTR
+Tk_3DBorder T_IVOBJ
+Tk_Uid T_TK_UID
+Tcl_Interp * T_TK_INTERP
+Tk_Font T_TK_FONT
+EventAndKeySym * T_TK_XEVENT
+LangCallback * T_TK_CALLBACK
+LangFontInfo * T_PVOBJ
+const char * T_PV
+
+INPUT
+T_PVOBJ
+ if (sv_isobject($arg)) {
+ STRLEN sz;
+ $var = ($type) SvPV((SV*)SvRV($arg),sz);
+ if (sz != sizeof(*$var))
+ croak(\"$arg too small (%d) for $var $type (%d)\",sz,sizeof(*$var));
+ }
+ else
+ croak(\"$var is not an object\")
+
+T_TK_WINDOW
+ $var = SVtoWindow($arg)
+
+T_TK_CALLBACK
+ $var = LangMakeCallback($arg)
+
+
+T_TK_HWND
+ $var = SVtoHWND($arg)
+
+T_TK_XEVENT
+ $var = SVtoEventAndKeySym($arg)
+
+T_TK_FONT
+ $var = SVtoFont($arg)
+
+T_TK_IMAGE
+ $var = SVtoImage($arg)
+
+T_TKWINDOW
+ $var = (TkWindow *) SVtoWindow($arg)
+
+T_TK_INTERP
+ $var = WindowCommand($arg,NULL,1)->interp
+
+T_TK_UID
+ $var = Tk_GetUid(SvPV($arg,na))
+
+T_IVOBJ
+ if (sv_isa($arg, \"${ntype}\")) {
+ $var = INT2PTR($type, SvIV(SvRV($arg)));
+ }
+ else {
+ $var = ($type) NULL;
+ croak(\"$var is not of type ${ntype}\");
+ }
+
+T_NIO
+ if (sv_isa($arg, \"${Package}\")) {
+ $var = IoIFP(sv_2io(SvRV($arg)));
+ }
+ else
+ croak(\"$var is not of type ${Package}\")
+
+
+OUTPUT
+T_IVOBJ
+ sv_setref_iv($arg, \"${ntype}\", PTR2IV($var));
+
+T_TK_UID
+ sv_setpv($arg,$var);
+
+T_TK_WINDOW
+ SvSetMagicSV($arg,TkToWidget($var,NULL));
+
+T_TKWINDOW
+ SvSetMagicSV($arg,TkToWidget((Tk_Window) $var,NULL));
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/vtab.def b/Master/tlpkg/tlperl.straw/lib/Tk/vtab.def
new file mode 100755
index 00000000000..7663df7d6f4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/vtab.def
@@ -0,0 +1,90 @@
+#define IMPORT_VTABLE(ptr,type,name) do { \
+ ptr = INT2PTR(type *,SvIV(get_sv(name,GV_ADDWARN|GV_ADD))); \
+ if ((*ptr->tabSize)() != sizeof(type)) { \
+ Perl_warn(aTHX_ "%s wrong size for %s",name,#type); \
+ } \
+ } while (0)
+
+#ifdef WIN32
+#define DECLARE_VTABLES \
+LangVtab *LangVptr; \
+TcldeclsVtab *TcldeclsVptr; \
+TkVtab *TkVptr; \
+TkdeclsVtab *TkdeclsVptr; \
+TkeventVtab *TkeventVptr; \
+TkglueVtab *TkglueVptr; \
+TkintVtab *TkintVptr; \
+TkintdeclsVtab *TkintdeclsVptr; \
+TkintplatdeclsVtab *TkintplatdeclsVptr;\
+TkintxlibdeclsVtab *TkintxlibdeclsVptr;\
+TkoptionVtab *TkoptionVptr; \
+TkplatdeclsVtab *TkplatdeclsVptr
+
+#define IMPORT_VTABLES do { \
+IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \
+IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \
+IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \
+IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \
+IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \
+IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \
+IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \
+IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \
+IMPORT_VTABLE(TkintplatdeclsVptr,TkintplatdeclsVtab,"Tk::TkintplatdeclsVtab"); \
+IMPORT_VTABLE(TkintxlibdeclsVptr,TkintxlibdeclsVtab,"Tk::TkintxlibdeclsVtab"); \
+IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \
+IMPORT_VTABLE(TkplatdeclsVptr , TkplatdeclsVtab,"Tk::TkplatdeclsVtab"); \
+} while (0)
+#else
+#define DECLARE_VTABLES \
+LangVtab *LangVptr; \
+TcldeclsVtab *TcldeclsVptr; \
+TkVtab *TkVptr; \
+TkdeclsVtab *TkdeclsVptr; \
+TkeventVtab *TkeventVptr; \
+TkglueVtab *TkglueVptr; \
+TkintVtab *TkintVptr; \
+TkintdeclsVtab *TkintdeclsVptr; \
+TkoptionVtab *TkoptionVptr; \
+XlibVtab *XlibVptr
+
+#define IMPORT_VTABLES do { \
+IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \
+IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \
+IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \
+IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \
+IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \
+IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \
+IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \
+IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \
+IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \
+IMPORT_VTABLE(XlibVptr , XlibVtab,"Tk::XlibVtab"); \
+} while (0)
+#endif
+#define DECLARE_TIX \
+TixVtab *TixVptr; \
+TixintVtab *TixintVptr
+
+#define IMPORT_TIX do { \
+IMPORT_VTABLE(TixVptr , TixVtab,"Tk::TixVtab"); \
+IMPORT_VTABLE(TixintVptr , TixintVtab,"Tk::TixintVtab"); \
+} while (0)
+#define DECLARE_PHOTO \
+ImgintVtab *ImgintVptr; \
+TkimgphotoVtab *TkimgphotoVptr
+
+#define IMPORT_PHOTO do { \
+IMPORT_VTABLE(ImgintVptr , ImgintVtab,"Tk::ImgintVtab"); \
+IMPORT_VTABLE(TkimgphotoVptr , TkimgphotoVtab,"Tk::TkimgphotoVtab"); \
+} while (0)
+#define DECLARE_EVENT \
+TkeventVtab *TkeventVptr
+
+#define IMPORT_EVENT do { \
+IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \
+} while (0)
+#define DECLARE_TIXXPM \
+TiximgxpmVtab *TiximgxpmVptr
+
+#define IMPORT_TIXXPM do { \
+IMPORT_VTABLE(TiximgxpmVptr , TiximgxpmVtab,"Tk::TiximgxpmVtab"); \
+} while (0)
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/widgets.pm b/Master/tlpkg/tlperl.straw/lib/Tk/widgets.pm
new file mode 100755
index 00000000000..fe1deea12ef
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/widgets.pm
@@ -0,0 +1,20 @@
+package Tk::widgets;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tk/widgets.pm#4 $
+
+sub import
+{
+ my $class = shift;
+ foreach (@_)
+ {
+ local $SIG{__DIE__} = \&Carp::croak;
+ # carp "$_ already loaded" if (exists $INC{"Tk/$_.pm"});
+ require "Tk/$_.pm";
+ }
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/widgets.pod b/Master/tlpkg/tlperl.straw/lib/Tk/widgets.pod
new file mode 100755
index 00000000000..114f52505d7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/widgets.pod
@@ -0,0 +1,20 @@
+
+=head1 NAME
+
+Tk::widgets - preload widget classes
+
+=for pm Tk/widgets.pm
+
+=for category Implementation
+
+=head1 SYNOPSIS
+
+ use Tk::widgets qw(Button Label Frame);
+
+=head1 DESCRIPTION
+
+Does a 'require Tk::Foo' for each 'Foo' in the list.
+May speed startup by avoiding AUTOLOADs.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/win.xbm b/Master/tlpkg/tlperl.straw/lib/Tk/win.xbm
new file mode 100755
index 00000000000..13c05e8c2d7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/win.xbm
@@ -0,0 +1,6 @@
+#define win.xbm_width 16
+#define win.xbm_height 16
+static char win.xbm_bits[] = {
+ 0xff, 0xff, 0x0d, 0xb0, 0xff, 0xff, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80,
+ 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80,
+ 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0xff, 0xff};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/winfolder.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/winfolder.xpm
new file mode 100755
index 00000000000..73fe734c6d0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/winfolder.xpm
@@ -0,0 +1,39 @@
+/* XPM */
+static char *winfolder[] = {
+/* width height num_colors chars_per_pixel */
+" 17 15 17 1",
+/* colors */
+" c none",
+". c #000000",
+"# c #808080",
+"a c #800000",
+"b c #808000",
+"c c #008000",
+"d c #008080",
+"e c #000080",
+"f c #800080",
+"g c #ffffff",
+"h c #c0c0c0",
+"i c #ff0000",
+"j c #ffff00",
+"k c #00ff00",
+"l c #00ffff",
+"m c #0000ff",
+"n c #ff00ff",
+/* pixels */
+" ",
+" ##### ",
+" #hjhjh# ",
+" #hjhjhjh###### ",
+" #gggggggggggg#. ",
+" #gjhjhjhjhjhj#. ",
+" #ghjhjhjhjhjh#. ",
+" #gjhjhjhjhjhj#. ",
+" #ghjhjhjhjhjh#. ",
+" #gjhjhjhjhjhj#. ",
+" #ghjhjhjhjhjh#. ",
+" #gjhjhjhjhjhj#. ",
+" ##############. ",
+" .............. ",
+" ",
+};
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/wintext.xpm b/Master/tlpkg/tlperl.straw/lib/Tk/wintext.xpm
new file mode 100755
index 00000000000..50b2d5587dd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tk/wintext.xpm
@@ -0,0 +1,42 @@
+/* XPM */
+static char *wintext[] = {
+/* width height num_colors chars_per_pixel */
+" 15 18 17 1",
+/* colors */
+" c None",
+". c #000000",
+"# c #808080",
+"a c #800000",
+"b c #808000",
+"c c #008000",
+"d c #008080",
+"e c #000080",
+"f c #800080",
+"g c #ffffff",
+"h c #c0c0c0",
+"i c #ff0000",
+"j c #ffff00",
+"k c #00ff00",
+"l c #00ffff",
+"m c #0000ff",
+"n c #ff00ff",
+/* pixels */
+" ",
+" . . . . . ",
+" .g#g#g#g#g. ",
+" #g.g.g.g.g.g. ",
+" #ggggggggggh. ",
+" #ggggggggggh. ",
+" #gg...g..ggh. ",
+" #ggggggggggh. ",
+" #gg......ggh. ",
+" #ggggggggggh. ",
+" #gg......ggh. ",
+" #ggggggggggh. ",
+" #gg......ggh. ",
+" #ggggggggggh. ",
+" #ggggggggggh. ",
+" #hhhhhhhhhhh. ",
+" ........... ",
+" "
+};
diff --git a/Master/tlpkg/tlperl.straw/lib/URI.pm b/Master/tlpkg/tlperl.straw/lib/URI.pm
new file mode 100755
index 00000000000..20504a78dda
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/URI.pm
@@ -0,0 +1,1102 @@
+package URI;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "1.52";
+
+use vars qw($ABS_REMOTE_LEADING_DOTS $ABS_ALLOW_RELATIVE_SCHEME $DEFAULT_QUERY_FORM_DELIMITER);
+
+my %implements; # mapping from scheme to implementor class
+
+# Some "official" character classes
+
+use vars qw($reserved $mark $unreserved $uric $scheme_re);
+$reserved = q(;/?:@&=+$,[]);
+$mark = q(-_.!~*'()); #'; emacs
+$unreserved = "A-Za-z0-9\Q$mark\E";
+$uric = quotemeta($reserved) . $unreserved . "%";
+
+$scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
+
+use Carp ();
+use URI::Escape ();
+
+use overload ('""' => sub { ${$_[0]} },
+ '==' => sub { _obj_eq(@_) },
+ '!=' => sub { !_obj_eq(@_) },
+ fallback => 1,
+ );
+
+# Check if two objects are the same object
+sub _obj_eq {
+ return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
+}
+
+sub new
+{
+ my($class, $uri, $scheme) = @_;
+
+ $uri = defined ($uri) ? "$uri" : ""; # stringify
+ # Get rid of potential wrapping
+ $uri =~ s/^<(?:URL:)?(.*)>$/$1/; #
+ $uri =~ s/^"(.*)"$/$1/;
+ $uri =~ s/^\s+//;
+ $uri =~ s/\s+$//;
+
+ my $impclass;
+ if ($uri =~ m/^($scheme_re):/so) {
+ $scheme = $1;
+ }
+ else {
+ if (($impclass = ref($scheme))) {
+ $scheme = $scheme->scheme;
+ }
+ elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
+ $scheme = $1;
+ }
+ }
+ $impclass ||= implementor($scheme) ||
+ do {
+ require URI::_foreign;
+ $impclass = 'URI::_foreign';
+ };
+
+ return $impclass->_init($uri, $scheme);
+}
+
+
+sub new_abs
+{
+ my($class, $uri, $base) = @_;
+ $uri = $class->new($uri, $base);
+ $uri->abs($base);
+}
+
+
+sub _init
+{
+ my $class = shift;
+ my($str, $scheme) = @_;
+ # find all funny characters and encode the bytes.
+ $str = $class->_uric_escape($str);
+ $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
+ $class->_no_scheme_ok;
+ my $self = bless \$str, $class;
+ $self;
+}
+
+
+sub _uric_escape
+{
+ my($class, $str) = @_;
+ $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
+ return $str;
+}
+
+
+sub implementor
+{
+ my($scheme, $impclass) = @_;
+ if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
+ require URI::_generic;
+ return "URI::_generic";
+ }
+
+ $scheme = lc($scheme);
+
+ if ($impclass) {
+ # Set the implementor class for a given scheme
+ my $old = $implements{$scheme};
+ $impclass->_init_implementor($scheme);
+ $implements{$scheme} = $impclass;
+ return $old;
+ }
+
+ my $ic = $implements{$scheme};
+ return $ic if $ic;
+
+ # scheme not yet known, look for internal or
+ # preloaded (with 'use') implementation
+ $ic = "URI::$scheme"; # default location
+
+ # turn scheme into a valid perl identifier by a simple transformation...
+ $ic =~ s/\+/_P/g;
+ $ic =~ s/\./_O/g;
+ $ic =~ s/\-/_/g;
+
+ no strict 'refs';
+ # check we actually have one for the scheme:
+ unless (@{"${ic}::ISA"}) {
+ # Try to load it
+ eval "require $ic";
+ die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
+ return unless @{"${ic}::ISA"};
+ }
+
+ $ic->_init_implementor($scheme);
+ $implements{$scheme} = $ic;
+ $ic;
+}
+
+
+sub _init_implementor
+{
+ my($class, $scheme) = @_;
+ # Remember that one implementor class may actually
+ # serve to implement several URI schemes.
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $other = $$self;
+ bless \$other, ref $self;
+}
+
+
+sub _no_scheme_ok { 0 }
+
+sub _scheme
+{
+ my $self = shift;
+
+ unless (@_) {
+ return unless $$self =~ /^($scheme_re):/o;
+ return $1;
+ }
+
+ my $old;
+ my $new = shift;
+ if (defined($new) && length($new)) {
+ Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ my $newself = URI->new("$new:$$self");
+ $$self = $$newself;
+ bless $self, ref($newself);
+ }
+ else {
+ if ($self->_no_scheme_ok) {
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ Carp::carp("Oops, opaque part now look like scheme")
+ if $^W && $$self =~ m/^$scheme_re:/o
+ }
+ else {
+ $old = $1 if $$self =~ m/^($scheme_re):/o;
+ }
+ }
+
+ return $old;
+}
+
+sub scheme
+{
+ my $scheme = shift->_scheme(@_);
+ return unless defined $scheme;
+ lc($scheme);
+}
+
+
+sub opaque
+{
+ my $self = shift;
+
+ unless (@_) {
+ $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
+ return $1;
+ }
+
+ $$self =~ /^($scheme_re:)? # optional scheme
+ ([^\#]*) # opaque
+ (\#.*)? # optional fragment
+ $/sx or die;
+
+ my $old_scheme = $1;
+ my $old_opaque = $2;
+ my $old_frag = $3;
+
+ my $new_opaque = shift;
+ $new_opaque = "" unless defined $new_opaque;
+ $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
+
+ $$self = defined($old_scheme) ? $old_scheme : "";
+ $$self .= $new_opaque;
+ $$self .= $old_frag if defined $old_frag;
+
+ $old_opaque;
+}
+
+*path = \&opaque; # alias
+
+
+sub fragment
+{
+ my $self = shift;
+ unless (@_) {
+ return unless $$self =~ /\#(.*)/s;
+ return $1;
+ }
+
+ my $old;
+ $old = $1 if $$self =~ s/\#(.*)//s;
+
+ my $new_frag = shift;
+ if (defined $new_frag) {
+ $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
+ $$self .= "#$new_frag";
+ }
+ $old;
+}
+
+
+sub as_string
+{
+ my $self = shift;
+ $$self;
+}
+
+
+sub as_iri
+{
+ my $self = shift;
+ my $str = $$self;
+ if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
+ # All this crap because the more obvious:
+ #
+ # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
+ #
+ # doesn't work before Encode 2.39. Wait for a standard release
+ # to bundle that version.
+
+ require Encode;
+ my $enc = Encode::find_encoding("UTF-8");
+ my $u = "";
+ while (length $str) {
+ $u .= $enc->decode($str, Encode::FB_QUIET());
+ if (length $str) {
+ # escape next char
+ $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
+ }
+ }
+ $str = $u;
+ }
+ return $str;
+}
+
+
+sub canonical
+{
+ # Make sure scheme is lowercased, that we don't escape unreserved chars,
+ # and that we use upcase escape sequences.
+
+ my $self = shift;
+ my $scheme = $self->_scheme || "";
+ my $uc_scheme = $scheme =~ /[A-Z]/;
+ my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
+ return $self unless $uc_scheme || $esc;
+
+ my $other = $self->clone;
+ if ($uc_scheme) {
+ $other->_scheme(lc $scheme);
+ }
+ if ($esc) {
+ $$other =~ s{%([0-9a-fA-F]{2})}
+ { my $a = chr(hex($1));
+ $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
+ }ge;
+ }
+ return $other;
+}
+
+# Compare two URIs, subclasses will provide a more correct implementation
+sub eq {
+ my($self, $other) = @_;
+ $self = URI->new($self, $other) unless ref $self;
+ $other = URI->new($other, $self) unless ref $other;
+ ref($self) eq ref($other) && # same class
+ $self->canonical->as_string eq $other->canonical->as_string;
+}
+
+# generic-URI transformation methods
+sub abs { $_[0]; }
+sub rel { $_[0]; }
+
+# help out Storable
+sub STORABLE_freeze {
+ my($self, $cloning) = @_;
+ return $$self;
+}
+
+sub STORABLE_thaw {
+ my($self, $cloning, $str) = @_;
+ $$self = $str;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI - Uniform Resource Identifiers (absolute and relative)
+
+=head1 SYNOPSIS
+
+ $u1 = URI->new("http://www.perl.com");
+ $u2 = URI->new("foo", "http");
+ $u3 = $u2->abs($u1);
+ $u4 = $u3->clone;
+ $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical;
+
+ $str = $u->as_string;
+ $str = "$u";
+
+ $scheme = $u->scheme;
+ $opaque = $u->opaque;
+ $path = $u->path;
+ $frag = $u->fragment;
+
+ $u->scheme("ftp");
+ $u->host("ftp.perl.com");
+ $u->path("cpan/");
+
+=head1 DESCRIPTION
+
+This module implements the C<URI> class. Objects of this class
+represent "Uniform Resource Identifier references" as specified in RFC
+2396 (and updated by RFC 2732).
+
+A Uniform Resource Identifier is a compact string of characters that
+identifies an abstract or physical resource. A Uniform Resource
+Identifier can be further classified as either a Uniform Resource Locator
+(URL) or a Uniform Resource Name (URN). The distinction between URL
+and URN does not matter to the C<URI> class interface. A
+"URI-reference" is a URI that may have additional information attached
+in the form of a fragment identifier.
+
+An absolute URI reference consists of three parts: a I<scheme>, a
+I<scheme-specific part> and a I<fragment> identifier. A subset of URI
+references share a common syntax for hierarchical namespaces. For
+these, the scheme-specific part is further broken down into
+I<authority>, I<path> and I<query> components. These URIs can also
+take the form of relative URI references, where the scheme (and
+usually also the authority) component is missing, but implied by the
+context of the URI reference. The three forms of URI reference
+syntax are summarized as follows:
+
+ <scheme>:<scheme-specific-part>#<fragment>
+ <scheme>://<authority><path>?<query>#<fragment>
+ <path>?<query>#<fragment>
+
+The components into which a URI reference can be divided depend on the
+I<scheme>. The C<URI> class provides methods to get and set the
+individual components. The methods available for a specific
+C<URI> object depend on the scheme.
+
+=head1 CONSTRUCTORS
+
+The following methods construct new C<URI> objects:
+
+=over 4
+
+=item $uri = URI->new( $str )
+
+=item $uri = URI->new( $str, $scheme )
+
+Constructs a new URI object. The string
+representation of a URI is given as argument, together with an optional
+scheme specification. Common URI wrappers like "" and <>, as well as
+leading and trailing white space, are automatically removed from
+the $str argument before it is processed further.
+
+The constructor determines the scheme, maps this to an appropriate
+URI subclass, constructs a new object of that class and returns it.
+
+The $scheme argument is only used when $str is a
+relative URI. It can be either a simple string that
+denotes the scheme, a string containing an absolute URI reference, or
+an absolute C<URI> object. If no $scheme is specified for a relative
+URI $str, then $str is simply treated as a generic URI (no scheme-specific
+methods available).
+
+The set of characters available for building URI references is
+restricted (see L<URI::Escape>). Characters outside this set are
+automatically escaped by the URI constructor.
+
+=item $uri = URI->new_abs( $str, $base_uri )
+
+Constructs a new absolute URI object. The $str argument can
+denote a relative or absolute URI. If relative, then it is
+absolutized using $base_uri as base. The $base_uri must be an absolute
+URI.
+
+=item $uri = URI::file->new( $filename )
+
+=item $uri = URI::file->new( $filename, $os )
+
+Constructs a new I<file> URI from a file name. See L<URI::file>.
+
+=item $uri = URI::file->new_abs( $filename )
+
+=item $uri = URI::file->new_abs( $filename, $os )
+
+Constructs a new absolute I<file> URI from a file name. See
+L<URI::file>.
+
+=item $uri = URI::file->cwd
+
+Returns the current working directory as a I<file> URI. See
+L<URI::file>.
+
+=item $uri->clone
+
+Returns a copy of the $uri.
+
+=back
+
+=head1 COMMON METHODS
+
+The methods described in this section are available for all C<URI>
+objects.
+
+Methods that give access to components of a URI always return the
+old value of the component. The value returned is C<undef> if the
+component was not present. There is generally a difference between a
+component that is empty (represented as C<"">) and a component that is
+missing (represented as C<undef>). If an accessor method is given an
+argument, it updates the corresponding component in addition to
+returning the old value of the component. Passing an undefined
+argument removes the component (if possible). The description of
+each accessor method indicates whether the component is passed as
+an escaped or an unescaped string. A component that can be further
+divided into sub-parts are usually passed escaped, as unescaping might
+change its semantics.
+
+The common methods available for all URI are:
+
+=over 4
+
+=item $uri->scheme
+
+=item $uri->scheme( $new_scheme )
+
+Sets and returns the scheme part of the $uri. If the $uri is
+relative, then $uri->scheme returns C<undef>. If called with an
+argument, it updates the scheme of $uri, possibly changing the
+class of $uri, and returns the old scheme value. The method croaks
+if the new scheme name is illegal; a scheme name must begin with a
+letter and must consist of only US-ASCII letters, numbers, and a few
+special marks: ".", "+", "-". This restriction effectively means
+that the scheme must be passed unescaped. Passing an undefined
+argument to the scheme method makes the URI relative (if possible).
+
+Letter case does not matter for scheme names. The string
+returned by $uri->scheme is always lowercase. If you want the scheme
+just as it was written in the URI in its original case,
+you can use the $uri->_scheme method instead.
+
+=item $uri->opaque
+
+=item $uri->opaque( $new_opaque )
+
+Sets and returns the scheme-specific part of the $uri
+(everything between the scheme and the fragment)
+as an escaped string.
+
+=item $uri->path
+
+=item $uri->path( $new_path )
+
+Sets and returns the same value as $uri->opaque unless the URI
+supports the generic syntax for hierarchical namespaces.
+In that case the generic method is overridden to set and return
+the part of the URI between the I<host name> and the I<fragment>.
+
+=item $uri->fragment
+
+=item $uri->fragment( $new_frag )
+
+Returns the fragment identifier of a URI reference
+as an escaped string.
+
+=item $uri->as_string
+
+Returns a URI object to a plain ASCII string. URI objects are
+also converted to plain strings automatically by overloading. This
+means that $uri objects can be used as plain strings in most Perl
+constructs.
+
+=item $uri->as_iri
+
+Returns a Unicode string representing the URI. Escaped UTF-8 sequences
+representing non-ASCII characters are turned into their corresponding Unicode
+code point.
+
+=item $uri->canonical
+
+Returns a normalized version of the URI. The rules
+for normalization are scheme-dependent. They usually involve
+lowercasing the scheme and Internet host name components,
+removing the explicit port specification if it matches the default port,
+uppercasing all escape sequences, and unescaping octets that can be
+better represented as plain characters.
+
+For efficiency reasons, if the $uri is already in normalized form,
+then a reference to it is returned instead of a copy.
+
+=item $uri->eq( $other_uri )
+
+=item URI::eq( $first_uri, $other_uri )
+
+Tests whether two URI references are equal. URI references
+that normalize to the same string are considered equal. The method
+can also be used as a plain function which can also test two string
+arguments.
+
+If you need to test whether two C<URI> object references denote the
+same object, use the '==' operator.
+
+=item $uri->abs( $base_uri )
+
+Returns an absolute URI reference. If $uri is already
+absolute, then a reference to it is simply returned. If the $uri
+is relative, then a new absolute URI is constructed by combining the
+$uri and the $base_uri, and returned.
+
+=item $uri->rel( $base_uri )
+
+Returns a relative URI reference if it is possible to
+make one that denotes the same resource relative to $base_uri.
+If not, then $uri is simply returned.
+
+=back
+
+=head1 GENERIC METHODS
+
+The following methods are available to schemes that use the
+common/generic syntax for hierarchical namespaces. The descriptions of
+schemes below indicate which these are. Unknown schemes are
+assumed to support the generic syntax, and therefore the following
+methods:
+
+=over 4
+
+=item $uri->authority
+
+=item $uri->authority( $new_authority )
+
+Sets and returns the escaped authority component
+of the $uri.
+
+=item $uri->path
+
+=item $uri->path( $new_path )
+
+Sets and returns the escaped path component of
+the $uri (the part between the host name and the query or fragment).
+The path can never be undefined, but it can be the empty string.
+
+=item $uri->path_query
+
+=item $uri->path_query( $new_path_query )
+
+Sets and returns the escaped path and query
+components as a single entity. The path and the query are
+separated by a "?" character, but the query can itself contain "?".
+
+=item $uri->path_segments
+
+=item $uri->path_segments( $segment, ... )
+
+Sets and returns the path. In a scalar context, it returns
+the same value as $uri->path. In a list context, it returns the
+unescaped path segments that make up the path. Path segments that
+have parameters are returned as an anonymous array. The first element
+is the unescaped path segment proper; subsequent elements are escaped
+parameter strings. Such an anonymous array uses overloading so it can
+be treated as a string too, but this string does not include the
+parameters.
+
+Note that absolute paths have the empty string as their first
+I<path_segment>, i.e. the I<path> C</foo/bar> have 3
+I<path_segments>; "", "foo" and "bar".
+
+=item $uri->query
+
+=item $uri->query( $new_query )
+
+Sets and returns the escaped query component of
+the $uri.
+
+=item $uri->query_form
+
+=item $uri->query_form( $key1 => $val1, $key2 => $val2, ... )
+
+=item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim )
+
+=item $uri->query_form( \@key_value_pairs )
+
+=item $uri->query_form( \@key_value_pairs, $delim )
+
+=item $uri->query_form( \%hash )
+
+=item $uri->query_form( \%hash, $delim )
+
+Sets and returns query components that use the
+I<application/x-www-form-urlencoded> format. Key/value pairs are
+separated by "&", and the key is separated from the value by a "="
+character.
+
+The form can be set either by passing separate key/value pairs, or via
+an array or hash reference. Passing an empty array or an empty hash
+removes the query component, whereas passing no arguments at all leaves
+the component unchanged. The order of keys is undefined if a hash
+reference is passed. The old value is always returned as a list of
+separate key/value pairs. Assigning this list to a hash is unwise as
+the keys returned might repeat.
+
+The values passed when setting the form can be plain strings or
+references to arrays of strings. Passing an array of values has the
+same effect as passing the key repeatedly with one value at a time.
+All the following statements have the same effect:
+
+ $uri->query_form(foo => 1, foo => 2);
+ $uri->query_form(foo => [1, 2]);
+ $uri->query_form([ foo => 1, foo => 2 ]);
+ $uri->query_form([ foo => [1, 2] ]);
+ $uri->query_form({ foo => [1, 2] });
+
+The $delim parameter can be passed as ";" to force the key/value pairs
+to be delimited by ";" instead of "&" in the query string. This
+practice is often recommended for URLs embedded in HTML or XML
+documents as this avoids the trouble of escaping the "&" character.
+You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to
+";" for the same global effect.
+
+The C<URI::QueryParam> module can be loaded to add further methods to
+manipulate the form of a URI. See L<URI::QueryParam> for details.
+
+=item $uri->query_keywords
+
+=item $uri->query_keywords( $keywords, ... )
+
+=item $uri->query_keywords( \@keywords )
+
+Sets and returns query components that use the
+keywords separated by "+" format.
+
+The keywords can be set either by passing separate keywords directly
+or by passing a reference to an array of keywords. Passing an empty
+array removes the query component, whereas passing no arguments at
+all leaves the component unchanged. The old value is always returned
+as a list of separate words.
+
+=back
+
+=head1 SERVER METHODS
+
+For schemes where the I<authority> component denotes an Internet host,
+the following methods are available in addition to the generic
+methods.
+
+=over 4
+
+=item $uri->userinfo
+
+=item $uri->userinfo( $new_userinfo )
+
+Sets and returns the escaped userinfo part of the
+authority component.
+
+For some schemes this is a user name and a password separated by
+a colon. This practice is not recommended. Embedding passwords in
+clear text (such as URI) has proven to be a security risk in almost
+every case where it has been used.
+
+=item $uri->host
+
+=item $uri->host( $new_host )
+
+Sets and returns the unescaped hostname.
+
+If the $new_host string ends with a colon and a number, then this
+number also sets the port.
+
+For IPv6 addresses the brackets around the raw address is removed in the return
+value from $uri->host. When setting the host attribute to an IPv6 address you
+can use a raw address or one enclosed in brackets. The address needs to be
+enclosed in brackets if you want to pass in a new port value as well.
+
+=item $uri->ihost
+
+Returns the host in Unicode form. Any IDNA A-labels are turned into U-labels.
+
+=item $uri->port
+
+=item $uri->port( $new_port )
+
+Sets and returns the port. The port is a simple integer
+that should be greater than 0.
+
+If a port is not specified explicitly in the URI, then the URI scheme's default port
+is returned. If you don't want the default port
+substituted, then you can use the $uri->_port method instead.
+
+=item $uri->host_port
+
+=item $uri->host_port( $new_host_port )
+
+Sets and returns the host and port as a single
+unit. The returned value includes a port, even if it matches the
+default port. The host part and the port part are separated by a
+colon: ":".
+
+For IPv6 addresses the bracketing is preserved; thus
+URI->new("http://[::1]/")->host_port returns "[::1]:80". Contrast this with
+$uri->host which will remove the brackets.
+
+=item $uri->default_port
+
+Returns the default port of the URI scheme to which $uri
+belongs. For I<http> this is the number 80, for I<ftp> this
+is the number 21, etc. The default port for a scheme can not be
+changed.
+
+=back
+
+=head1 SCHEME-SPECIFIC SUPPORT
+
+Scheme-specific support is provided for the following URI schemes. For C<URI>
+objects that do not belong to one of these, you can only use the common and
+generic methods.
+
+=over 4
+
+=item B<data>:
+
+The I<data> URI scheme is specified in RFC 2397. It allows inclusion
+of small data items as "immediate" data, as if it had been included
+externally.
+
+C<URI> objects belonging to the data scheme support the common methods
+and two new methods to access their scheme-specific components:
+$uri->media_type and $uri->data. See L<URI::data> for details.
+
+=item B<file>:
+
+An old specification of the I<file> URI scheme is found in RFC 1738.
+A new RFC 2396 based specification in not available yet, but file URI
+references are in common use.
+
+C<URI> objects belonging to the file scheme support the common and
+generic methods. In addition, they provide two methods for mapping file URIs
+back to local file names; $uri->file and $uri->dir. See L<URI::file>
+for details.
+
+=item B<ftp>:
+
+An old specification of the I<ftp> URI scheme is found in RFC 1738. A
+new RFC 2396 based specification in not available yet, but ftp URI
+references are in common use.
+
+C<URI> objects belonging to the ftp scheme support the common,
+generic and server methods. In addition, they provide two methods for
+accessing the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<gopher>:
+
+The I<gopher> URI scheme is specified in
+<draft-murali-url-gopher-1996-12-04> and will hopefully be available
+as a RFC 2396 based specification.
+
+C<URI> objects belonging to the gopher scheme support the common,
+generic and server methods. In addition, they support some methods for
+accessing gopher-specific path components: $uri->gopher_type,
+$uri->selector, $uri->search, $uri->string.
+
+=item B<http>:
+
+The I<http> URI scheme is specified in RFC 2616.
+The scheme is used to reference resources hosted by HTTP servers.
+
+C<URI> objects belonging to the http scheme support the common,
+generic and server methods.
+
+=item B<https>:
+
+The I<https> URI scheme is a Netscape invention which is commonly
+implemented. The scheme is used to reference HTTP servers through SSL
+connections. Its syntax is the same as http, but the default
+port is different.
+
+=item B<ldap>:
+
+The I<ldap> URI scheme is specified in RFC 2255. LDAP is the
+Lightweight Directory Access Protocol. An ldap URI describes an LDAP
+search operation to perform to retrieve information from an LDAP
+directory.
+
+C<URI> objects belonging to the ldap scheme support the common,
+generic and server methods as well as ldap-specific methods: $uri->dn,
+$uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See
+L<URI::ldap> for details.
+
+=item B<ldapi>:
+
+Like the I<ldap> URI scheme, but uses a UNIX domain socket. The
+server methods are not supported, and the local socket path is
+available as $uri->un_path. The I<ldapi> scheme is used by the
+OpenLDAP package. There is no real specification for it, but it is
+mentioned in various OpenLDAP manual pages.
+
+=item B<ldaps>:
+
+Like the I<ldap> URI scheme, but uses an SSL connection. This
+scheme is deprecated, as the preferred way is to use the I<start_tls>
+mechanism.
+
+=item B<mailto>:
+
+The I<mailto> URI scheme is specified in RFC 2368. The scheme was
+originally used to designate the Internet mailing address of an
+individual or service. It has (in RFC 2368) been extended to allow
+setting of other mail header fields and the message body.
+
+C<URI> objects belonging to the mailto scheme support the common
+methods and the generic query methods. In addition, they support the
+following mailto-specific methods: $uri->to, $uri->headers.
+
+Note that the "foo@example.com" part of a mailto is I<not> the
+C<userinfo> and C<host> but instead the C<path>. This allowed a
+mailto to contain multiple comma-seperated email addresses.
+
+=item B<mms>:
+
+The I<mms> URL specification can be found at L<http://sdp.ppona.com/>
+C<URI> objects belonging to the mms scheme support the common,
+generic, and server methods, with the exception of userinfo and
+query-related sub-components.
+
+=item B<news>:
+
+The I<news>, I<nntp> and I<snews> URI schemes are specified in
+<draft-gilman-news-url-01> and will hopefully be available as an RFC
+2396 based specification soon.
+
+C<URI> objects belonging to the news scheme support the common,
+generic and server methods. In addition, they provide some methods to
+access the path: $uri->group and $uri->message.
+
+=item B<nntp>:
+
+See I<news> scheme.
+
+=item B<pop>:
+
+The I<pop> URI scheme is specified in RFC 2384. The scheme is used to
+reference a POP3 mailbox.
+
+C<URI> objects belonging to the pop scheme support the common, generic
+and server methods. In addition, they provide two methods to access the
+userinfo components: $uri->user and $uri->auth
+
+=item B<rlogin>:
+
+An old specification of the I<rlogin> URI scheme is found in RFC
+1738. C<URI> objects belonging to the rlogin scheme support the
+common, generic and server methods.
+
+=item B<rtsp>:
+
+The I<rtsp> URL specification can be found in section 3.2 of RFC 2326.
+C<URI> objects belonging to the rtsp scheme support the common,
+generic, and server methods, with the exception of userinfo and
+query-related sub-components.
+
+=item B<rtspu>:
+
+The I<rtspu> URI scheme is used to talk to RTSP servers over UDP
+instead of TCP. The syntax is the same as rtsp.
+
+=item B<rsync>:
+
+Information about rsync is available from http://rsync.samba.org.
+C<URI> objects belonging to the rsync scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<sip>:
+
+The I<sip> URI specification is described in sections 19.1 and 25
+of RFC 3261. C<URI> objects belonging to the sip scheme support the
+common, generic, and server methods with the exception of path related
+sub-components. In addition, they provide two methods to get and set
+I<sip> parameters: $uri->params_form and $uri->params.
+
+=item B<sips>:
+
+See I<sip> scheme. Its syntax is the same as sip, but the default
+port is different.
+
+=item B<snews>:
+
+See I<news> scheme. Its syntax is the same as news, but the default
+port is different.
+
+=item B<telnet>:
+
+An old specification of the I<telnet> URI scheme is found in RFC
+1738. C<URI> objects belonging to the telnet scheme support the
+common, generic and server methods.
+
+=item B<tn3270>:
+
+These URIs are used like I<telnet> URIs but for connections to IBM
+mainframes. C<URI> objects belonging to the tn3270 scheme support the
+common, generic and server methods.
+
+=item B<ssh>:
+
+Information about ssh is available at http://www.openssh.com/.
+C<URI> objects belonging to the ssh scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<urn>:
+
+The syntax of Uniform Resource Names is specified in RFC 2141. C<URI>
+objects belonging to the urn scheme provide the common methods, and also the
+methods $uri->nid and $uri->nss, which return the Namespace Identifier
+and the Namespace-Specific String respectively.
+
+The Namespace Identifier basically works like the Scheme identifier of
+URIs, and further divides the URN namespace. Namespace Identifier
+assignments are maintained at
+<http://www.iana.org/assignments/urn-namespaces>.
+
+Letter case is not significant for the Namespace Identifier. It is
+always returned in lower case by the $uri->nid method. The $uri->_nid
+method can be used if you want it in its original case.
+
+=item B<urn>:B<isbn>:
+
+The C<urn:isbn:> namespace contains International Standard Book
+Numbers (ISBNs) and is described in RFC 3187. A C<URI> object belonging
+to this namespace has the following extra methods (if the
+Business::ISBN module is available): $uri->isbn,
+$uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code,
+which is still supported by issues a deprecation warning), $uri->isbn_as_ean.
+
+=item B<urn>:B<oid>:
+
+The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is
+described in RFC 3061. An object identifier consists of sequences of digits
+separated by dots. A C<URI> object belonging to this namespace has an
+additional method called $uri->oid that can be used to get/set the oid
+value. In a list context, oid numbers are returned as separate elements.
+
+=back
+
+=head1 CONFIGURATION VARIABLES
+
+The following configuration variables influence how the class and its
+methods behave:
+
+=over 4
+
+=item $URI::ABS_ALLOW_RELATIVE_SCHEME
+
+Some older parsers used to allow the scheme name to be present in the
+relative URL if it was the same as the base URL scheme. RFC 2396 says
+that this should be avoided, but you can enable this old behaviour by
+setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value.
+The difference is demonstrated by the following examples:
+
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:foo"
+
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:/host/a/foo"
+
+
+=item $URI::ABS_REMOTE_LEADING_DOTS
+
+You can also have the abs() method ignore excess ".."
+segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS
+to a TRUE value. The difference is demonstrated by the following
+examples:
+
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/../../foo"
+
+ local $URI::ABS_REMOTE_LEADING_DOTS = 1;
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/foo"
+
+=item $URI::DEFAULT_QUERY_FORM_DELIMITER
+
+This value can be set to ";" to have the query form C<key=value> pairs
+delimited by ";" instead of "&" which is the default.
+
+=back
+
+=head1 BUGS
+
+Using regexp variables like $1 directly as arguments to the URI methods
+does not work too well with current perl implementations. I would argue
+that this is actually a bug in perl. The workaround is to quote
+them. Example:
+
+ /(...)/ || die;
+ $u->query("$1");
+
+=head1 PARSING URIs WITH REGEXP
+
+As an alternative to this module, the following (official) regular
+expression can be used to decode a URI:
+
+ my($scheme, $authority, $path, $query, $fragment) =
+ $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
+
+The C<URI::Split> module provides the function uri_split() as a
+readable alternative.
+
+=head1 SEE ALSO
+
+L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>,
+L<URI::Split>, L<URI::Heuristic>
+
+RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax",
+Berners-Lee, Fielding, Masinter, August 1998.
+
+http://www.iana.org/assignments/uri-schemes
+
+http://www.iana.org/assignments/urn-namespaces
+
+http://www.w3.org/Addressing/
+
+=head1 COPYRIGHT
+
+Copyright 1995-2009 Gisle Aas.
+
+Copyright 1995 Martijn Koster.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHORS / ACKNOWLEDGMENTS
+
+This module is based on the C<URI::URL> module, which in turn was
+(distantly) based on the C<wwwurl.pl> code in the libwww-perl for
+perl4 developed by Roy Fielding, as part of the Arcadia project at the
+University of California, Irvine, with contributions from Brooks
+Cutter.
+
+C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and
+Martijn Koster with input from other people on the libwww-perl mailing
+list.
+
+C<URI> and related subclasses was developed by Gisle Aas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/User/grent.pm b/Master/tlpkg/tlperl.straw/lib/User/grent.pm
new file mode 100755
index 00000000000..ce6ee5ea447
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/User/grent.pm
@@ -0,0 +1,95 @@
+package User::grent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.01';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getgrent getgrgid getgrnam getgr);
+ @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members);
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'User::grent' => [
+ name => '$',
+ passwd => '$',
+ gid => '$',
+ members => '@',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $gob = new();
+ ($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2];
+ @gr_members = @{$gob->[3]} = split ' ', $_[3];
+ return $gob;
+}
+
+sub getgrent ( ) { populate(CORE::getgrent()) }
+sub getgrnam ($) { populate(CORE::getgrnam(shift)) }
+sub getgrgid ($) { populate(CORE::getgrgid(shift)) }
+sub getgr ($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam }
+
+1;
+__END__
+
+=head1 NAME
+
+User::grent - by-name interface to Perl's built-in getgr*() functions
+
+=head1 SYNOPSIS
+
+ use User::grent;
+ $gr = getgrgid(0) or die "No group zero";
+ if ( $gr->name eq 'wheel' && @{$gr->members} > 1 ) {
+ print "gid zero name wheel, with other members";
+ }
+
+ use User::grent qw(:FIELDS);
+ getgrgid(0) or die "No group zero";
+ if ( $gr_name eq 'wheel' && @gr_members > 1 ) {
+ print "gid zero name wheel, with other members";
+ }
+
+ $gr = getgr($whoever);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getgrent(), getgruid(),
+and getgrnam() functions, replacing them with versions that return
+"User::grent" objects. This object has methods that return the similarly
+named structure field name from the C's passwd structure from F<grp.h>;
+namely name, passwd, gid, and members (not mem). The first three
+return scalars, the last an array reference.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<gr_>. Thus, C<$group_obj-E<gt>gid()> corresponds
+to $gr_gid if you import the fields. Array references are available as
+regular array variables, so C<@{ $group_obj-E<gt>members() }> would be
+simply @gr_members.
+
+The getpw() function is a simple front-end that forwards
+a numeric argument to getpwuid() and the rest to getpwnam().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl.straw/lib/User/pwent.pm b/Master/tlpkg/tlperl.straw/lib/User/pwent.pm
new file mode 100755
index 00000000000..91d23bd3f68
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/User/pwent.pm
@@ -0,0 +1,298 @@
+package User::pwent;
+
+use 5.006;
+our $VERSION = '1.00';
+
+use strict;
+use warnings;
+
+use Config;
+use Carp;
+
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getpwent getpwuid getpwnam getpw);
+ @EXPORT_OK = qw(
+ pw_has
+
+ $pw_name $pw_passwd $pw_uid $pw_gid
+ $pw_gecos $pw_dir $pw_shell
+ $pw_expire $pw_change $pw_class
+ $pw_age
+ $pw_quota $pw_comment
+ $pw_expire
+
+ );
+ %EXPORT_TAGS = (
+ FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ],
+ ALL => [ @EXPORT, @EXPORT_OK ],
+ );
+}
+use vars grep /^\$pw_/, @EXPORT_OK;
+
+#
+# XXX: these mean somebody hacked this module's source
+# without understanding the underlying assumptions.
+#
+my $IE = "[INTERNAL ERROR]";
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'User::pwent' => [
+ name => '$', # pwent[0]
+ passwd => '$', # pwent[1]
+ uid => '$', # pwent[2]
+ gid => '$', # pwent[3]
+
+ # you'll only have one/none of these three
+ change => '$', # pwent[4]
+ age => '$', # pwent[4]
+ quota => '$', # pwent[4]
+
+ # you'll only have one/none of these two
+ comment => '$', # pwent[5]
+ class => '$', # pwent[5]
+
+ # you might not have this one
+ gecos => '$', # pwent[6]
+
+ dir => '$', # pwent[7]
+ shell => '$', # pwent[8]
+
+ # you might not have this one
+ expire => '$', # pwent[9]
+
+];
+
+
+# init our groks hash to be true if the built platform knew how
+# to do each struct pwd field that perl can ever under any circumstances
+# know about. we do not use /^pw_?/, but just the tails.
+sub _feature_init {
+ our %Groks; # whether build system knew how to do this feature
+ for my $feep ( qw{
+ pwage pwchange pwclass pwcomment
+ pwexpire pwgecos pwpasswd pwquota
+ }
+ )
+ {
+ my $short = $feep =~ /^pw(.*)/
+ ? $1
+ : do {
+ # not cluck, as we know we called ourselves,
+ # and a confession is probably imminent anyway
+ warn("$IE $feep is a funny struct pwd field");
+ $feep;
+ };
+
+ exists $Config{ "d_" . $feep }
+ || confess("$IE Configure doesn't d_$feep");
+ $Groks{$short} = defined $Config{ "d_" . $feep };
+ }
+ # assume that any that are left are always there
+ for my $feep (grep /^\$pw_/s, @EXPORT_OK) {
+ $feep =~ /^\$pw_(.*)/;
+ $Groks{$1} = 1 unless defined $Groks{$1};
+ }
+}
+
+# With arguments, reports whether one or more fields are all implemented
+# in the build machine's struct pwd pw_*. May be whitespace separated.
+# We do not use /^pw_?/, just the tails.
+#
+# Without arguments, returns the list of fields implemented on build
+# machine, space separated in scalar context.
+#
+# Takes exception to being asked whether this machine's struct pwd has
+# a field that Perl never knows how to provide under any circumstances.
+# If the module does this idiocy to itself, the explosion is noisier.
+#
+sub pw_has {
+ our %Groks; # whether build system knew how to do this feature
+ my $cando = 1;
+ my $sploder = caller() ne __PACKAGE__
+ ? \&croak
+ : sub { confess("$IE @_") };
+ if (@_ == 0) {
+ my @valid = sort grep { $Groks{$_} } keys %Groks;
+ return wantarray ? @valid : "@valid";
+ }
+ for my $feep (map { split } @_) {
+ defined $Groks{$feep}
+ || $sploder->("$feep is never a valid struct pwd field");
+ $cando &&= $Groks{$feep};
+ }
+ return $cando;
+}
+
+sub _populate (@) {
+ return unless @_;
+ my $pwob = new();
+
+ # Any that haven't been pw_had are assumed on "all" platforms of
+ # course, this may not be so, but you can't get here otherwise,
+ # since the underlying core call already took exception to your
+ # impudence.
+
+ $pw_name = $pwob->name ( $_[0] );
+ $pw_passwd = $pwob->passwd ( $_[1] ) if pw_has("passwd");
+ $pw_uid = $pwob->uid ( $_[2] );
+ $pw_gid = $pwob->gid ( $_[3] );
+
+ if (pw_has("change")) {
+ $pw_change = $pwob->change ( $_[4] );
+ }
+ elsif (pw_has("age")) {
+ $pw_age = $pwob->age ( $_[4] );
+ }
+ elsif (pw_has("quota")) {
+ $pw_quota = $pwob->quota ( $_[4] );
+ }
+
+ if (pw_has("class")) {
+ $pw_class = $pwob->class ( $_[5] );
+ }
+ elsif (pw_has("comment")) {
+ $pw_comment = $pwob->comment( $_[5] );
+ }
+
+ $pw_gecos = $pwob->gecos ( $_[6] ) if pw_has("gecos");
+
+ $pw_dir = $pwob->dir ( $_[7] );
+ $pw_shell = $pwob->shell ( $_[8] );
+
+ $pw_expire = $pwob->expire ( $_[9] ) if pw_has("expire");
+
+ return $pwob;
+}
+
+sub getpwent ( ) { _populate(CORE::getpwent()) }
+sub getpwnam ($) { _populate(CORE::getpwnam(shift)) }
+sub getpwuid ($) { _populate(CORE::getpwuid(shift)) }
+sub getpw ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam }
+
+_feature_init();
+
+1;
+__END__
+
+=head1 NAME
+
+User::pwent - by-name interface to Perl's built-in getpw*() functions
+
+=head1 SYNOPSIS
+
+ use User::pwent;
+ $pw = getpwnam('daemon') || die "No daemon user";
+ if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) {
+ print "gid 1 on root dir";
+ }
+
+ $real_shell = $pw->shell || '/bin/sh';
+
+ for (($fullname, $office, $workphone, $homephone) =
+ split /\s*,\s*/, $pw->gecos)
+ {
+ s/&/ucfirst(lc($pw->name))/ge;
+ }
+
+ use User::pwent qw(:FIELDS);
+ getpwnam('daemon') || die "No daemon user";
+ if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) {
+ print "gid 1 on root dir";
+ }
+
+ $pw = getpw($whoever);
+
+ use User::pwent qw/:DEFAULT pw_has/;
+ if (pw_has(qw[gecos expire quota])) { .... }
+ if (pw_has("name uid gid passwd")) { .... }
+ print "Your struct pwd has: ", scalar pw_has(), "\n";
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getpwent(), getpwuid(),
+and getpwnam() functions, replacing them with versions that return
+C<User::pwent> objects. This object has methods that return the
+similarly named structure field name from the C's passwd structure
+from F<pwd.h>, stripped of their leading "pw_" parts, namely C<name>,
+C<passwd>, C<uid>, C<gid>, C<change>, C<age>, C<quota>, C<comment>,
+C<class>, C<gecos>, C<dir>, C<shell>, and C<expire>. The C<passwd>,
+C<gecos>, and C<shell> fields are tainted when running in taint mode.
+
+You may also import all the structure fields directly into your
+namespace as regular variables using the :FIELDS import tag. (Note
+that this still overrides your core functions.) Access these fields
+as variables named with a preceding C<pw_> in front their method
+names. Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell
+if you import the fields.
+
+The getpw() function is a simple front-end that forwards
+a numeric argument to getpwuid() and the rest to getpwnam().
+
+To access this functionality without the core overrides, pass the
+C<use> an empty import list, and then access function functions
+with their full qualified names. The built-ins are always still
+available via the C<CORE::> pseudo-package.
+
+=head2 System Specifics
+
+Perl believes that no machine ever has more than one of C<change>,
+C<age>, or C<quota> implemented, nor more than one of either
+C<comment> or C<class>. Some machines do not support C<expire>,
+C<gecos>, or allegedly, C<passwd>. You may call these methods
+no matter what machine you're on, but they return C<undef> if
+unimplemented.
+
+You may ask whether one of these was implemented on the system Perl
+was built on by asking the importable C<pw_has> function about them.
+This function returns true if all parameters are supported fields
+on the build platform, false if one or more were not, and raises
+an exception if you asked about a field that Perl never knows how
+to provide. Parameters may be in a space-separated string, or as
+separate arguments. If you pass no parameters, the function returns
+the list of C<struct pwd> fields supported by your build platform's
+C library, as a list in list context, or a space-separated string
+in scalar context. Note that just because your C library had
+a field doesn't necessarily mean that it's fully implemented on
+that system.
+
+Interpretation of the C<gecos> field varies between systems, but
+traditionally holds 4 comma-separated fields containing the user's
+full name, office location, work phone number, and home phone number.
+An C<&> in the gecos field should be replaced by the user's properly
+capitalized login C<name>. The C<shell> field, if blank, must be
+assumed to be F</bin/sh>. Perl does not do this for you. The
+C<passwd> is one-way hashed garble, not clear text, and may not be
+unhashed save by brute-force guessing. Secure systems use more a
+more secure hashing than DES. On systems supporting shadow password
+systems, Perl automatically returns the shadow password entry when
+called by a suitably empowered user, even if your underlying
+vendor-provided C library was too short-sighted to realize it should
+do this.
+
+See passwd(5) and getpwent(3) for details.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
+
+=head1 HISTORY
+
+=over 4
+
+=item March 18th, 2000
+
+Reworked internals to support better interface to dodgey fields
+than normal Perl function provides. Added pw_has() field. Improved
+documentation.
+
+=back
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32.pm b/Master/tlpkg/tlperl.straw/lib/Win32.pm
new file mode 100755
index 00000000000..4015eac841c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/Win32/API.pm b/Master/tlpkg/tlperl.straw/lib/Win32/API.pm
new file mode 100755
index 00000000000..365ce6b46c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/API.pm
@@ -0,0 +1,778 @@
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API - Perl Win32 API Import Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
+# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
+#
+# $Id: API.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
+#
+#######################################################################
+
+package Win32::API;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( $DEBUG );
+$DEBUG = 0;
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API::Type;
+use Win32::API::Struct;
+use File::Basename ();
+
+#######################################################################
+# STATIC OBJECT PROPERTIES
+#
+$VERSION = '0.59';
+
+#### some package-global hash to
+#### keep track of the imported
+#### libraries and procedures
+my %Libraries = ();
+my %Procedures = ();
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ my $hdll;
+ my $self = {};
+
+ if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
+ # need to convert $dll to win32 path
+ # isn't there an API for this?
+ my $newdll = `cygpath -w "$dll"`;
+ chomp $newdll;
+ DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
+ $dll = $newdll;
+ }
+
+ #### avoid loading a library more than once
+ if(exists($Libraries{$dll})) {
+ DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
+ $hdll = $Libraries{$dll};
+ } else {
+ DEBUG "Win32::API::new: Loading library '$dll'\n";
+ $hdll = Win32::API::LoadLibrary($dll);
+# $Libraries{$dll} = $hdll;
+ }
+
+ #### if the dll can't be loaded, set $! to Win32's GetLastError()
+ if(!$hdll) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED Loading library '$dll': $!\n";
+ delete $Libraries{$dll};
+ return undef;
+ }
+
+ #### determine if we have a prototype or not
+ if( (not defined $in) and (not defined $out) ) {
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}, $self->{cdecl}) = parse_prototype( $proc );
+ return undef unless $proc;
+ $self->{proto} = 1;
+ } else {
+ $self->{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ }
+ $self->{out} = type_to_num($out);
+ $self->{cdecl} = calltype_to_num($callconvention);
+ }
+
+ #### first try to import the function of given name...
+ my $hproc = Win32::API::GetProcAddress($hdll, $proc);
+
+ #### ...then try appending either A or W (for ASCII or Unicode)
+ if(!$hproc) {
+ my $tproc = $proc;
+ $tproc .= (IsUnicode() ? "W" : "A");
+ # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
+ $hproc = Win32::API::GetProcAddress($hdll, $tproc);
+ }
+
+ #### ...if all that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
+ return undef;
+ }
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n";
+
+ #### ok, let's stuff the object
+ $self->{procname} = $proc;
+ $self->{dll} = $hdll;
+ $self->{dllname} = $dll;
+ $self->{proc} = $hproc;
+
+ #### keep track of the imported function
+ $Libraries{$dll} = $hdll;
+ $Procedures{$dll}++;
+
+ DEBUG "Object blessed!\n";
+
+ #### cast the spell
+ bless($self, $class);
+ return $self;
+}
+
+sub Import {
+ my($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention) or return 0;
+ my $P = (caller)[0];
+ eval qq(
+ sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
+ );
+ return $@ ? 0 : 1;
+}
+
+#######################################################################
+# PRIVATE METHODS
+#
+sub DESTROY {
+ my($self) = @_;
+
+ #### decrease this library's procedures reference count
+ $Procedures{$self->{dllname}}--;
+
+ #### once it reaches 0, free it
+ if($Procedures{$self->{dllname}} == 0) {
+ DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
+ Win32::API::FreeLibrary($Libraries{$self->{dllname}});
+ delete($Libraries{$self->{dllname}});
+ }
+}
+
+# Convert calling convention string (_cdecl|__stdcall)
+# to an integer (1|0). Unknown counts as __stdcall
+#
+sub calltype_to_num {
+ my $type = shift;
+
+ if (!$type || $type eq "__stdcall") {
+ return 0;
+ }
+ elsif ($type eq "_cdecl") {
+ return 1;
+ }
+ else {
+ warn "unknown calling convention: '$type'";
+ return 0;
+ }
+}
+
+sub type_to_num {
+ my $type = shift;
+ my $out = shift;
+ my $num;
+
+ if( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L'
+ ) {
+ $num = 1;
+ } elsif($type eq 'P'
+ or $type eq 'p'
+ ) {
+ $num = 2;
+ } elsif($type eq 'I'
+ or $type eq 'i'
+ ) {
+ $num = 3;
+ } elsif($type eq 'f'
+ or $type eq 'F'
+ ) {
+ $num = 4;
+ } elsif($type eq 'D'
+ or $type eq 'd'
+ ) {
+ $num = 5;
+ } elsif($type eq 'c'
+ or $type eq 'C'
+ ) {
+ $num = 6;
+ } else {
+ $num = 0;
+ }
+ unless(defined $out) {
+ if( $type eq 's'
+ or $type eq 'S'
+ ) {
+ $num = 51;
+ } elsif($type eq 'b'
+ or $type eq 'B'
+ ) {
+ $num = 22;
+ } elsif($type eq 'k'
+ or $type eq 'K'
+ ) {
+ $num = 101;
+ }
+ }
+ return $num;
+}
+
+sub parse_prototype {
+ my($proto) = @_;
+
+ my @in_params = ();
+ my @in_types = ();
+ if($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) {
+ my $ret = $1;
+ my $callconvention= $2;
+ my $proc = $3;
+ my $params = $4;
+
+ $params =~ s/^\s+//;
+ $params =~ s/\s+$//;
+
+ DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
+ DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
+
+ foreach my $param (split(/\s*,\s*/, $params)) {
+ my($type, $name);
+ if($param =~ /(\S+)\s+(\S+)/) {
+ ($type, $name) = ($1, $2);
+ }
+
+ if(Win32::API::Type::is_known($type)) {
+ if(Win32::API::Type::is_pointer($type)) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num('P');
+ push(@in_params, type_to_num('P'));
+ } else {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num( Win32::API::Type->packing( $type ) );
+ push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
+ }
+ } elsif( Win32::API::Struct::is_known( $type ) ) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type, 'S', type_to_num('S');
+ push(@in_params, type_to_num('S'));
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
+ push(@in_params, type_to_num('I'));
+ }
+ push(@in_types, $type);
+
+ }
+ DEBUG "parse_prototype: IN=[ @in_params ]\n";
+
+
+
+ if(Win32::API::Type::is_known($ret)) {
+ if(Win32::API::Type::is_pointer($ret)) {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num('P');
+ return ( $proc, \@in_params, \@in_types, type_to_num('P'), calltype_to_num($callconvention) );
+ } else {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num( Win32::API::Type->packing( $ret ) );
+ return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)), calltype_to_num($callconvention) );
+ }
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ( $proc, \@in_params, \@in_types, type_to_num('I'), calltype_to_num($callconvention) );
+ }
+
+ } else {
+ warn "Win32::API::parse_prototype: bad prototype '$proto'";
+ return undef;
+ }
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API - Perl Win32 API Import Facility
+
+=head1 SYNOPSIS
+
+ #### Method 1: with prototype
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll, 'int sum_integers(int a, int b)',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 2: with parameter list
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll', 'sum_integers', 'II', 'I',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 3: with Import
+
+ use Win32::API;
+ Win32::API->Import(
+ 'mydll', 'int sum_integers(int a, int b)',
+ );
+ $return = sum_integers(3, 2);
+
+
+=for LATER-UNIMPLEMENTED
+ #### or
+ use Win32::API mydll => 'int sum_integers(int a, int b)';
+ $return = sum_integers(3, 2);
+
+
+=head1 ABSTRACT
+
+With this module you can import and call arbitrary functions
+from Win32's Dynamic Link Libraries (DLL), without having
+to write an XS extension. Note, however, that this module
+can't do everything. In fact, parameters input and output is
+limited to simpler cases.
+
+A regular B<XS> extension is always safer and faster anyway.
+
+The current version of Win32::API is always available at your
+nearest CPAN mirror:
+
+ http://search.cpan.org/dist/Win32-API/
+
+A short example of how you can use this module (it just gets the PID of
+the current process, eg. same as Perl's internal C<$$>):
+
+ use Win32::API;
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+The possibilities are nearly infinite (but not all are good :-).
+Enjoy it.
+
+=head1 DESCRIPTION
+
+To use this module put the following line at the beginning of your script:
+
+ use Win32::API;
+
+You can now use the C<new()> function of the Win32::API module to create a
+new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the
+C<Call()> method on this object to perform a call to the imported API
+(see L<CALLING AN IMPORTED FUNCTION>).
+
+Starting from version 0.40, you can also avoid creating a Win32::API object
+and instead automatically define a Perl sub with the same name of the API
+function you're importing. The details of the API definitions are the same,
+just the call is different:
+
+ my $GetCurrentProcessId = Win32::API->new(
+ "kernel32", "int GetCurrentProcessId()"
+ );
+ my $PID = $GetCurrentProcessId->Call();
+
+ #### vs.
+
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+Note that C<Import> returns 1 on success and 0 on failure (in which case you
+can check the content of C<$^E>).
+
+=head2 IMPORTING A FUNCTION
+
+You can import a function from a 32 bit Dynamic Link Library (DLL) file
+with the C<new()> function. This will create a Perl object that contains the
+reference to that function, which you can later C<Call()>.
+
+What you need to know is the prototype of the function you're going to import
+(eg. the definition of the function expressed in C syntax).
+
+Starting from version 0.40, there are 2 different approaches for this step:
+(the preferred) one uses the prototype directly, while the other (now deprecated)
+one uses Win32::API's internal representation for parameters.
+
+=head2 IMPORTING A FUNCTION BY PROTOTYPE
+
+You need to pass 2 parameters:
+
+=over 4
+
+=item 1.
+
+The name of the library from which you want to import the function.
+
+=item 2.
+
+The C prototype of the function.
+
+=back
+
+When calling a function imported with a prototype, if you pass an
+undefined Perl scalar to one of its arguments, it will be
+automatically turned into a C C<NULL> value.
+
+See L<Win32::API::Type> for a list of the known parameter types and
+L<Win32::API::Struct> for information on how to define a structure.
+
+=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
+
+You need to pass 4 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The name of the function (as exported by the library).
+
+=item 3.
+The number and types of the arguments the function expects as input.
+
+=item 4.
+The type of the value returned by the function.
+
+=item 5.
+And optionally you can specify the calling convention, this defaults to
+'__stdcall', alternatively you can specify '_cdecl'.
+
+=back
+
+To better explain their meaning, let's suppose that we
+want to import and call the Win32 API C<GetTempPath()>.
+This function is defined in C as:
+
+ DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer );
+
+This is documented in the B<Win32 SDK Reference>; you can look
+for it on the Microsoft's WWW site, or in your C compiler's
+documentation, if you own one.
+
+=over 4
+
+=item B<1.>
+
+The first parameter is the name of the library file that
+exports this function; our function resides in the F<KERNEL32.DLL>
+system file.
+
+When specifying this name as parameter, the F<.DLL> extension
+is implicit, and if no path is given, the file is searched through
+a couple of directories, including:
+
+=over 4
+
+=item 1. The directory from which the application loaded.
+
+=item 2. The current directory.
+
+=item 3. The Windows system directory (eg. c:\windows\system or system32).
+
+=item 4. The Windows directory (eg. c:\windows).
+
+=item 5. The directories that are listed in the PATH environment variable.
+
+=back
+
+So, you don't have to write F<C:\windows\system\kernel32.dll>;
+only F<kernel32> is enough:
+
+ $GetTempPath = new Win32::API('kernel32', ...
+
+=item B<2.>
+
+Now for the second parameter: the name of the function.
+It must be written exactly as it is exported
+by the library (case is significant here).
+If you are using Windows 95 or NT 4.0, you can use the B<Quick View>
+command on the DLL file to see the function it exports.
+Remember that you can only import functions from 32 bit DLLs:
+in Quick View, the file's characteristics should report
+somewhere "32 bit word machine"; as a rule of thumb,
+when you see that all the exported functions are in upper case,
+the DLL is a 16 bit one and you can't use it.
+If their capitalization looks correct, then it's probably a 32 bit
+DLL.
+
+Also note that many Win32 APIs are exported twice, with the addition of
+a final B<A> or B<W> to their name, for - respectively - the ASCII
+and the Unicode version.
+When a function name is not found, Win32::API will actually append
+an B<A> to the name and try again; if the extension is built on a
+Unicode system, then it will try with the B<W> instead.
+So our function name will be:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ...
+
+In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
+
+=item B<3.>
+
+The third parameter, the input parameter list, specifies how many
+arguments the function wants, and their types. It can be passed as
+a single string, in which each character represents one parameter,
+or as a list reference. The following forms are valid:
+
+ "abcd"
+ [a, b, c, d]
+ \@LIST
+
+But those are not:
+
+ (a, b, c, d)
+ @LIST
+
+The number of characters, or elements in the list, specifies the number
+of parameters, and each character or element specifies the type of an
+argument; allowed types are:
+
+=over 4
+
+=item C<I>:
+value is an integer (int)
+
+=item C<N>:
+value is a number (long)
+
+=item C<F>:
+value is a floating point number (float)
+
+=item C<D>:
+value is a double precision number (double)
+
+=item C<C>:
+value is a char (char)
+
+=item C<P>:
+value is a pointer (to a string, structure, etc...)
+
+=item C<S>:
+value is a Win32::API::Struct object (see below)
+
+=item C<K>:
+value is a Win32::API::Callback object (see L<Win32::API::Callback>)
+
+=back
+
+Our function needs two parameters: a number (C<DWORD>) and a pointer to a
+string (C<LPSTR>):
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ...
+
+=item B<4.>
+
+The fourth and final parameter is the type of the value returned by the
+function. It can be one of the types seen above, plus another type named B<V>
+(for C<void>), used for functions that do not return a value.
+In our example the value returned by GetTempPath() is a C<DWORD>, so
+our return type will be B<N>:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+
+Now the line is complete, and the GetTempPath() API is ready to be used
+in Perl. Before calling it, you should test that $GetTempPath is
+C<defined>, otherwise either the function or the library could not be
+loaded; in this case, C<$!> will be set to the error message reported
+by Windows.
+Our definition, with error checking added, should then look like this:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+ if(not defined $GetTempPath) {
+ die "Can't import API GetTempPath: $!\n";
+ }
+
+=back
+
+=head2 CALLING AN IMPORTED FUNCTION
+
+To effectively make a call to an imported function you must use the
+Call() method on the Win32::API object you created.
+Continuing with the example from the previous paragraph,
+the GetTempPath() API can be called using the method:
+
+ $GetTempPath->Call(...
+
+Of course, parameters have to be passed as defined in the import phase.
+In particular, if the number of parameters does not match (in the example,
+if GetTempPath() is called with more or less than two parameters),
+Perl will C<croak> an error message and C<die>.
+
+The two parameters needed here are the length of the buffer
+that will hold the returned temporary path, and a pointer to the
+buffer itself.
+For numerical parameters, you can use either a constant expression
+or a variable, while B<for pointers you must use a variable name> (no
+Perl references, just a plain variable name).
+Also note that B<memory must be allocated before calling the function>,
+just like in C.
+For example, to pass a buffer of 80 characters to GetTempPath(),
+it must be initialized before with:
+
+ $lpBuffer = " " x 80;
+
+This allocates a string of 80 characters. If you don't do so, you'll
+probably get C<Runtime exception> errors, and generally nothing will
+work. The call should therefore include:
+
+ $lpBuffer = " " x 80;
+ $GetTempPath->Call(80, $lpBuffer);
+
+And the result will be stored in the $lpBuffer variable.
+Note that you don't need to pass a reference to the variable
+(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set
+by the function.
+
+A little problem here is that Perl does not trim the variable,
+so $lpBuffer will still contain 80 characters in return; the exceeding
+characters will be spaces, because we said C<" " x 80>.
+
+In this case we're lucky enough, because the value returned by
+the GetTempPath() function is the length of the string, so to get
+the actual temporary path we can write:
+
+ $lpBuffer = " " x 80;
+ $return = $GetTempPath->Call(80, $lpBuffer);
+ $TempPath = substr($lpBuffer, 0, $return);
+
+If you don't know the length of the string, you can usually
+cut it at the C<\0> (ASCII zero) character, which is the string
+delimiter in C:
+
+ $TempPath = ((split(/\0/, $lpBuffer))[0];
+ # or
+ $lpBuffer =~ s/\0.*$//;
+
+=head2 USING STRUCTURES
+
+Starting from version 0.40, Win32::API comes with a support package
+named Win32::API::Struct. The package is loaded automatically with
+Win32::API, so you don't need to use it explicitly.
+
+With this module you can conveniently define structures and use
+them as parameters to Win32::API functions. A short example follows:
+
+
+ # the 'POINT' structure is defined in C as:
+ # typedef struct {
+ # LONG x;
+ # LONG y;
+ # } POINT;
+
+
+ #### define the structure
+ Win32::API::Struct->typedef( POINT => qw{
+ LONG x;
+ LONG y;
+ });
+
+ #### import an API that uses this structure
+ Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)');
+
+ #### create a 'POINT' object
+ my $pt = Win32::API::Struct->new('POINT');
+
+ #### call the function passing our structure object
+ GetCursorPos($pt);
+
+ #### and now, access its members
+ print "The cursor is at: $pt->{x}, $pt->{y}\n";
+
+Note that this works only when the function wants a
+B<pointer to a structure>: as you can see, our structure is named
+'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at
+the beginning of the structure name when feeding it to a Win32::API
+call.
+
+For more information, see also L<Win32::API::Struct>.
+
+If you don't want (or can't) use the C<Win32::API::Struct> facility,
+you can still use the low-level approach to use structures:
+
+=over 4
+
+=item 1.
+
+you have to pack() the required elements in a variable:
+
+ $lpPoint = pack('LL', 0, 0); # store two LONGs
+
+=item 2.
+
+to access the values stored in a structure, unpack() it as required:
+
+ ($x, $y) = unpack('LL', $lpPoint); # get the actual values
+
+=back
+
+The rest is left as an exercise to the reader...
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=head1 LICENSE
+
+To finally clarify this, C<Win32::API> is OSI-approved free software;
+you can redistribute it and/or modify it under the same terms as Perl
+itself.
+
+See L<http://dev.perl.org/licenses/artistic.html>
+
+=head1 CREDITS
+
+All the credits go to Andrea Frosini for the neat assembler trick
+that makes this thing work. I've also used some work by Dave Roth
+for the prototyping stuff. A big thank you also to Gurusamy Sarathy
+for his unvaluable help in XS development, and to all the Perl
+community for being what it is.
+
+Cosimo also wants to personally thank everyone that contributed
+to Win32::API with complaints, emails, patches, RT bug reports
+and so on.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl.straw/lib/Win32/API/Callback.pm
new file mode 100755
index 00000000000..df15786591b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/API/Callback.pm
@@ -0,0 +1,174 @@
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Callback - Perl Win32 API Import Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Callback.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
+#
+#######################################################################
+
+package Win32::API::Callback;
+
+$VERSION = '0.59';
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+sub DEBUG {
+ if ($WIN32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API;
+use Win32::API::Type;
+use Win32::API::Struct;
+
+#######################################################################
+# This AUTOLOAD is used to 'autoload' constants from the constant()
+# XS function. If a constant is not found then control is passed
+# to the AUTOLOAD in AutoLoader.
+#
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ $!=0;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ } else {
+ ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line.";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API::Callback;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $proc, $in, $out) = @_;
+ my %self = ();
+
+ # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
+
+ $self{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self{in} }, Win32::API::type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self{in} }, Win32::API::type_to_num($_));
+ }
+ }
+ $self{out} = Win32::API::type_to_num($out);
+ $self{sub} = $proc;
+ my $self = bless \%self, $class;
+
+ DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n";
+ my $hproc = CallbackCreate($self);
+
+ DEBUG "(PM)Callback::new: hproc=$hproc\n";
+
+ #### ...if that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ return undef;
+ }
+
+ #### ok, let's stuff the object
+ $self->{code} = $hproc;
+ $self->{sub} = $proc;
+
+ #### cast the spell
+ return $self;
+}
+
+sub MakeStruct {
+ my($self, $n, $addr) = @_;
+ DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n";
+ my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);
+ $struct->FromMemory($addr);
+ return $struct;
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Callback - Callback support for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+ use Win32::API::Callback;
+
+ my $callback = Win32::API::Callback->new(
+ sub { my($a, $b) = @_; return $a+$b; },
+ "NN", "N",
+ );
+
+ Win32::API->Import(
+ 'mydll', 'two_integers_cb', 'KNN', 'N',
+ );
+
+ $sum = two_integers_cb( $callback, 3, 2 );
+
+
+=head1 FOREWORDS
+
+=over 4
+
+=item *
+Support for this module is B<highly experimental> at this point.
+
+=item *
+I won't be surprised if it doesn't work for you.
+
+=item *
+Feedback is very appreciated.
+
+=item *
+Documentation is in the work. Either see the SYNOPSIS above
+or the samples in the F<samples> directory.
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl.straw/lib/Win32/API/Struct.pm
new file mode 100755
index 00000000000..9f706671a77
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/API/Struct.pm
@@ -0,0 +1,532 @@
+package Win32::API::Struct;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Struct - Perl Win32 API struct Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Struct.pm 438 2008-10-02 22:51:55Z cosimo.streppone $
+#######################################################################
+
+$VERSION = '0.50';
+
+use Win32::API::Type;
+
+use Carp;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+my %Known = ();
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub typedef {
+ my $class = shift;
+ my $struct = shift;
+ my($type, $name);
+ my $self = {
+ align => undef,
+ typedef => [],
+ };
+ while(defined($type = shift)) {
+ $name = shift;
+ $name =~ s/;$//;
+ push( @{ $self->{typedef} }, [ recognize($type, $name) ] );
+ }
+
+ $Known{$struct} = $self;
+ return 1;
+}
+
+
+sub recognize {
+ my($type, $name) = @_;
+ my($size, $packing);
+ if(exists $Known{$type}) {
+ $packing = ">";
+ return $name, $packing, $type;
+ } else {
+ $packing = Win32::API::Type::packing($type);
+ return undef unless defined $packing;
+ if($name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $packing."*".$size;
+ }
+ DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n";
+ return $name, $packing, $type;
+ }
+}
+
+sub new {
+ my $class = shift;
+ my($type, $name);
+ my $self = {
+ typedef => [],
+ };
+ if($#_ == 0) {
+ if(exists $Known{$_[0]}) {
+ DEBUG "(PM)Struct::new: got '$_[0]'\n";
+ $self->{typedef} = $Known{$_[0]}->{typedef};
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $packing, $type) = @$member;
+ if($packing eq '>') {
+ $self->{$name} = Win32::API::Struct->new($type);
+ }
+ }
+ $self->{__typedef__} = $_[0];
+ } else {
+ carp "Unknown Win32::API::Struct '$_[0]'";
+ return undef;
+ }
+ } else {
+ while(defined($type = shift)) {
+ $name = shift;
+ # print "new: found member $name ($type)\n";
+ if(not exists $Win32::API::Type::Known{$type}) {
+ warn "Unknown Win32::API::Struct type '$type'";
+ return undef;
+ } else {
+ push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] );
+ }
+ }
+ }
+ return bless $self;
+}
+
+sub members {
+ my $self = shift;
+ return map {$_->[0]} @{ $self->{typedef} };
+}
+
+sub sizeof {
+ my $self = shift;
+ my $size = 0;
+ my $align = 0;
+ my $first = undef;
+ foreach my $member (@{ $self->{typedef} }) {
+ my($name, $packing, $type) = @$member;
+
+ if(ref( $self->{$name} ) eq "Win32::API::Struct") {
+ $size += $self->{$name}->sizeof();
+ # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align;
+ } else {
+ if($packing =~ /\w\*(\d+)/) {
+ $size += Win32::API::Type::sizeof($type) * $1;
+ $first = Win32::API::Type::sizeof($type) * $1 unless defined $first;
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
+ } else {
+ $size += Win32::API::Type::sizeof($type);
+ $first = Win32::API::Type::sizeof($type) unless defined $first;
+ $align = Win32::API::Type::sizeof($type)
+ if Win32::API::Type::sizeof($type) > $align;
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
+ }
+ }
+ }
+ DEBUG "(PM)Struct::sizeof first=$first align=$align\n";
+ #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align;
+ #return $first + (scalar(@{ $self->{typedef} })-1) * $align;
+ DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align;
+ if(defined $align and $align > 0) {
+ return scalar(@{ $self->{typedef} }) * $align;
+ } else {
+ return $size;
+ }
+ return $size;
+}
+
+sub align {
+ my $self = shift;
+ my $align = shift;
+
+ if(not defined $align) {
+ return $self->{align} unless $self->{align} eq 'auto';
+ $align = 0;
+ foreach my $member (@{ $self->{typedef} }) {
+ my($name, $packing, $type) = @$member;
+
+ if(ref( $self->{$name} ) eq "Win32::API::Struct") {
+ #### ????
+ } else {
+ if($packing =~ /\w\*(\d+)/) {
+ #### ????
+ } else {
+ $align = Win32::API::Type::sizeof($type)
+ if Win32::API::Type::sizeof($type) > $align;
+ }
+ }
+ }
+ return $align;
+ } else {
+ $self->{align} = $align;
+
+ }
+}
+
+sub getPack {
+ my $self = shift;
+ my $packing = "";
+ my($type, $name);
+ my @items = ();
+ my @recipients = ();
+
+ my $align = $self->align();
+
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $type, $orig) = @$member;
+ if($type eq '>') {
+ my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack();
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n";
+
+ $packing .= $subpacking;
+ push(@items, @$subitems);
+ push(@recipients, @$subrecipients);
+ } else {
+ if($type =~ /\w\*(\d+)/) {
+ my $size = $1;
+ $type = "a$size";
+ }
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n";
+
+ if($type eq 'p') {
+ $type = "L";
+ push(@items, Win32::API::PointerTo($self->{$name}));
+ } else {
+ push(@items, $self->{$name});
+ }
+ $packing .= $type;
+
+ if($Win32::API::Type::PackSize{$type} < $align) {
+ $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ }
+
+ push(@recipients, $self);
+ }
+ }
+ DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n";
+ return($packing, [@items], [@recipients]);
+}
+
+
+sub Pack {
+ my $self = shift;
+ my($packing, $items, $recipients) = $self->getPack();
+ DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n";
+ $self->{buffer} = pack($packing, @$items);
+ if(DEBUG) {
+ for my $i (0..$self->sizeof-1) {
+ printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1));
+ }
+ }
+ $self->{buffer_recipients} = $recipients
+}
+
+sub getUnpack {
+ my $self = shift;
+ my $packing = "";
+ my($type, $name);
+ my @items = ();
+ my $align = $self->align();
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $type, $orig) = @$member;
+ if($type eq '>') {
+ my($subpacking, @subitems) = $self->{$name}->getUnpack();
+
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n";
+ $packing .= $subpacking;
+
+
+ push(@items, @subitems);
+ } else {
+ if($type =~ /\w\*(\d+)/) {
+ my $size = $1;
+ $type = "Z$size";
+ }
+
+ #if($type eq 'p') {
+ # $packing .= 'Z*';
+ # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n";
+ #} else {
+ $packing .= $type;
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n";
+ #}
+ if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) {
+ DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n",
+ $type, $Win32::API::Type::PackSize{$type}, $align
+ ;
+ $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ }
+
+ push(@items, $name);
+ }
+ }
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n";
+ return($packing, @items);
+}
+
+sub Unpack {
+ my $self = shift;
+ my($packing, @items) = $self->getUnpack();
+ my @itemvalue = unpack($packing, $self->{buffer});
+ DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n";
+ foreach my $i (0..$#items) {
+ my $recipient = $self->{buffer_recipients}->[$i];
+ DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n",
+ $recipient->{__typedef__},
+ $items[$i],
+ $itemvalue[$i],
+ $itemvalue[$i],
+ ;
+ $recipient->{$items[$i]} = $itemvalue[$i];
+ DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n";
+ }
+}
+
+sub FromMemory {
+ my($self, $addr) = @_;
+ DEBUG "(PM)Struct::FromMemory: doing Pack\n";
+ $self->Pack();
+ DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof;
+ $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof );
+ $self->Unpack();
+ DEBUG "(PM)Struct::FromMemory: doing Unpack\n";
+ DEBUG "(PM)Struct::FromMemory: structure is now:\n";
+ $self->Dump() if DEBUG;
+ DEBUG "\n";
+}
+
+sub Dump {
+ my $self = shift;
+ my $prefix = shift;
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $packing, $type) = @$member;
+ if( ref($self->{$name}) ) {
+ $self->{$name}->Dump($name);
+ } else {
+ printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name};
+ }
+ }
+}
+
+
+sub is_known {
+ my $name = shift;
+ if(exists $Known{ $name }) {
+ return 1;
+ } else {
+ if($name =~ s/^LP//) {
+ return exists $Known{ $name };
+ }
+ return 0;
+ }
+}
+
+sub TIEHASH {
+ return Win32::API::Struct::new(@_);
+}
+
+sub EXISTS {
+
+}
+
+sub FETCH {
+ my $self = shift;
+ my $key = shift;
+
+ if($key eq 'sizeof') {
+ return $self->sizeof;
+ }
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ if(grep(/^\Q$key\E$/, @members)) {
+ return $self->{$key};
+ } else {
+ warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
+ }
+}
+
+sub STORE {
+ my $self = shift;
+ my($key, $val) = @_;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ if(grep(/^\Q$key\E$/, @members)) {
+ $self->{$key} = $val;
+ } else {
+ warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
+ }
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ return $members[0];
+}
+
+sub NEXTKEY {
+ my $self = shift;
+ my $key = shift;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ for my $i (0..$#members-1) {
+ return $members[$i+1] if $members[$i] eq $key;
+ }
+ return undef;
+}
+
+1;
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Struct - C struct support package for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+
+ Win32::API::Struct->typedef( 'POINT', qw(
+ LONG x;
+ LONG y;
+ ));
+
+ my $Point = Win32::API::Struct->new( 'POINT' );
+ $Point->{x} = 1024;
+ $Point->{y} = 768;
+
+ #### alternatively
+
+ tie %Point, 'Win32::API::Struct', 'POINT';
+ $Point{x} = 1024;
+ $Point{y} = 768;
+
+
+=head1 ABSTRACT
+
+This module enables you to define C structs for use with
+Win32::API.
+
+See L<Win32::API> for more info about its usage.
+
+=head1 DESCRIPTION
+
+This module is automatically imported by Win32::API, so you don't
+need to 'use' it explicitly. The main methods are C<typedef> and
+C<new>, which are documented below.
+
+=over 4
+
+=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...>
+
+This method defines a structure named C<NAME>. The definition consists
+of types and member names, just like in C. In fact, most of the
+times you can cut the C definition for a structure and paste it
+verbatim to your script, enclosing it in a C<qw()> block. The
+function takes care of removing the semicolon after the member
+name.
+
+The synopsis example could be written like this:
+
+ Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y');
+
+But it could also be written like this (note the indirect object
+syntax), which is pretty cool:
+
+ typedef Win32::API::Struct POINT => qw{
+ LONG x;
+ LONG y;
+ };
+
+Also note that C<typedef> automatically defines an 'LPNAME' type,
+which holds a pointer to your structure. In the example above,
+'LPPOINT' is also defined and can be used in a call to a
+Win32::API (in fact, this is what you're really going to use when
+doing API calls).
+
+=item C<new NAME>
+
+This creates a structure (a Win32::API::Struct object) of the
+type C<NAME> (it must have been defined with C<typedef>). In Perl,
+when you create a structure, all the members are undefined. But
+when you use that structure in C (eg. a Win32::API call), you
+can safely assume that they will be treated as zero (or NULL).
+
+=item C<sizeof>
+
+This returns the size, in bytes, of the structure. Acts just like
+the C function of the same name. It is particularly useful for
+structures that need a member to be initialized to the structure's
+own size.
+
+=item C<align [SIZE]>
+
+Sets or returns the structure alignment (eg. how the structure is
+stored in memory). This is a very advanced option, and you normally
+don't need to mess with it.
+All structures in the Win32 Platform SDK should work without it.
+But if you define your own structure, you may need to give it an
+explicit alignment. In most cases, passing a C<SIZE> of 'auto'
+should keep the world happy.
+
+=back
+
+=head2 THE C<tie> INTERFACE
+
+Instead of creating an object with the C<new> method, you can
+tie a hash, which will hold the desired structure, using the
+C<tie> builtin function:
+
+ tie %structure, Win32::API::Struct => 'NAME';
+
+The differences between the tied and non-tied approaches are:
+
+=over 4
+
+=item *
+with tied structures, you can access members directly as
+hash lookups, eg.
+
+ # tied # non-tied
+ $Point{x} vs. $Point->{x}
+
+=item *
+with tied structures, when you try to fetch or store a
+member that is not part of the structure, it will result
+in a warning, eg.
+
+ print $Point{z};
+ # this will warn: 'z' is not a member of Win32::API::Struct POINT
+
+=item *
+when you pass a tied structure as a Win32::API parameter,
+remember to backslash it, eg.
+
+ # tied # non-tied
+ GetCursorPos( \%Point ) vs. GetCursorPos( $Point )
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/API/Test.pm b/Master/tlpkg/tlperl.straw/lib/Win32/API/Test.pm
new file mode 100755
index 00000000000..0b21ced6927
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/API/Test.pm
@@ -0,0 +1,111 @@
+#
+# Win32::API::Test - Test helper package for Win32::API
+#
+# Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Test.pm 438 2008-10-02 22:51:55Z cosimo.streppone $
+
+package Win32::API::Test;
+
+sub compiler_name () {
+ use Config;
+ my $cc = $Config{ccname};
+ if($cc eq 'cl' || $cc eq 'cl.exe')
+ {
+ $cc = 'cl';
+ }
+ return($cc);
+}
+
+sub compiler_version () {
+ use Config;
+ my $ver = $Config{ccversion} || 0;
+ if( $ver =~ /^(\d+\.\d+)/ )
+ {
+ $ver = 0 + $1;
+ }
+ return($ver);
+}
+
+#
+# Run the compiler and get version from there...
+# User might be running a compiler different from
+# that used to build perl.
+# For example, Cosimo does. For testing, of course.
+#
+sub compiler_version_from_shell () {
+ my $cc = compiler_name();
+ my $ver;
+ # MSVC
+ if($cc eq 'cl')
+ {
+ my @ver = `$cc 2>&1`; # Interesting output in STDERR
+ $ver = join('',@ver);
+ #print 'VER:'.$ver.':'."\n";
+ if($ver =~ /Version (\d[\d\.]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ # GCC
+ elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' )
+ {
+ $ver = join('', `$cc --version`);
+ if($ver =~ /gcc.*(\d[\d+]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ # Borland C
+ elsif($cc eq 'bcc32' || $cc eq 'bcc')
+ {
+ $ver = join('', `$cc 2>&1`);
+ if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ return($ver);
+}
+
+sub find_test_dll () {
+ require File::Spec;
+ my $dll_name = $_[0];
+ my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll);
+ while(my $path = shift @paths)
+ {
+ $dll = File::Spec->catfile($path, $dll_name);
+ return $dll if -s $dll;
+ }
+ return(undef);
+}
+
+1;
+
+__END__
+
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Test - Test helper package for Win32::API
+
+=head1 SYNOPSIS
+
+ my $test_dll = Win32::API::Test::find_test_dll('API_test.dll');
+
+Check the t/*.t test scripts for more details.
+
+=head1 DESCRIPTION
+
+Simple package to hold Win32::API test suite helper functions.
+No more, no less.
+
+=head1 AUTHOR
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl.straw/lib/Win32/API/Type.pm
new file mode 100755
index 00000000000..48f0ce1a32f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/API/Type.pm
@@ -0,0 +1,453 @@
+package Win32::API::Type;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Type - Perl Win32 API type definitions
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Type.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
+#
+#######################################################################
+
+$VERSION = '0.59';
+
+use Carp;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( %Known %PackSize %Modifier %Pointer );
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+%Known = ();
+%PackSize = ();
+%Modifier = ();
+%Pointer = ();
+
+# Initialize data structures at startup.
+# Aldo wants to keep the <DATA> approach.
+#
+my $section = 'nothing';
+foreach (<DATA>) {
+ next if /^\s*#/ or /^\s*$/;
+ chomp;
+ if( /\[(.+)\]/) {
+ $section = $1;
+ next;
+ }
+ if($section eq 'TYPE') {
+ my($name, $packing) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n";
+ $Known{$name} = $packing;
+ } elsif($section eq 'PACKSIZE') {
+ my($packing, $size) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n";
+ $PackSize{$packing} = $size;
+ } elsif($section eq 'MODIFIER') {
+ my($modifier, $mapto) = split(/\s+/, $_, 2);
+ my %maps = ();
+ foreach my $item (split(/\s+/, $mapto)) {
+ my($k, $v) = split(/=/, $item);
+ $maps{$k} = $v;
+ }
+ # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n";
+ $Modifier{$modifier} = { %maps };
+ } elsif($section eq 'POINTER') {
+ my($pointer, $pointto) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n";
+ $Pointer{$pointer} = $pointto;
+ }
+}
+close(DATA);
+
+sub new {
+ my $class = shift;
+ my($type) = @_;
+ my $packing = packing($type);
+ my $size = sizeof($type);
+ my $self = {
+ type => $type,
+ packing => $packing,
+ size => $size,
+ };
+ return bless $self;
+}
+
+sub typedef {
+ my $class = shift;
+ my($name, $type) = @_;
+ my $packing = packing($type, $name);
+ DEBUG "(PM)Type::typedef: packing='$packing'\n";
+ my $size = sizeof($type);
+ $Known{$name} = $packing;
+ return 1;
+}
+
+
+sub is_known {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return 1;
+ } else {
+ return defined packing($type);
+ }
+}
+
+sub sizeof {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return $self->{size};
+ } else {
+ my $packing = packing($type);
+ if($packing =~ /(\w)\*(\d+)/) {
+ return $PackSize{ $1 } * $2;
+ } else {
+ return $PackSize{ $packing };
+ }
+ }
+}
+
+sub packing {
+ # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n";
+ my $self = shift;
+ my $is_pointer = 0;
+ if(ref($self) =~ /Win32::API::Type/) {
+ # DEBUG "(PM)Type::packing: got an object\n";
+ return $self->{packing};
+ }
+ my $type = ($self eq 'Win32::API::Type') ? shift : $self;
+ my $name = shift;
+
+ # DEBUG "(PM)Type::packing: got '$type', '$name'\n";
+ my($modifier, $size, $packing);
+ if(exists $Pointer{$type}) {
+ # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n";
+ $type = $Pointer{$type};
+ $is_pointer = 1;
+ } elsif($type =~ /(\w+)\s+(\w+)/) {
+ $modifier = $1;
+ $type = $2;
+ # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n";
+ }
+
+ $type =~ s/\*$//;
+
+ if(exists $Known{$type}) {
+ if(defined $name and $name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $Known{$type}[0]."*".$size;
+ # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n";
+ } else {
+ $packing = $Known{$type};
+ if($is_pointer and $packing eq 'c') {
+ $packing = "p";
+ }
+ # DEBUG "(PM)Type::packing: simple packing: '$packing'\n";
+ }
+ if(defined $modifier and exists $Modifier{$modifier}->{$type}) {
+ # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n";
+ $packing = $Modifier{$modifier}->{$type};
+ }
+ return $packing;
+ } else {
+ # DEBUG "(PM)Type::packing: NOT FOUND\n";
+ return undef;
+ }
+}
+
+
+sub is_pointer {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return 1;
+ } else {
+ if($type =~ /\*$/) {
+ return 1;
+ } else {
+ return exists $Pointer{$type};
+ }
+ }
+}
+
+sub Pack {
+ my ($type, $arg) = @_;
+
+ my $pack_type = packing($type);
+
+ if($pack_type eq 'p') {
+ $pack_type = 'Z*';
+ }
+
+ $arg = pack($pack_type, $arg);
+
+ return $arg;
+}
+
+sub Unpack {
+ my ($type, $arg) = @_;
+
+ my $pack_type = packing($type);
+
+ if($pack_type eq 'p') {
+ DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n";
+ $pack_type = 'Z*';
+ }
+
+ DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$arg'\n";
+ $arg = unpack($pack_type, $arg);
+ DEBUG "(PM)Type::Unpack: returning '" . ($arg || '') . "'\n";
+ return $arg;
+}
+
+1;
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Type - C type support package for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+
+ Win32::API::Type->typedef( 'my_number', 'LONG' );
+
+
+=head1 ABSTRACT
+
+This module is a support package for Win32::API that implements
+C types for the import with prototype functionality.
+
+See L<Win32::API> for more info about its usage.
+
+=head1 DESCRIPTION
+
+This module is automatically imported by Win32::API, so you don't
+need to 'use' it explicitly. These are the methods of this package:
+
+=over 4
+
+=item C<typedef NAME, TYPE>
+
+This method defines a new type named C<NAME>. This actually just
+creates an alias for the already-defined type C<TYPE>, which you
+can use as a parameter in a Win32::API call.
+
+=item C<sizeof TYPE>
+
+This returns the size, in bytes, of C<TYPE>. Acts just like
+the C function of the same name.
+
+=item C<is_known TYPE>
+
+Returns true if C<TYPE> is known by Win32::API::Type, false
+otherwise.
+
+=back
+
+=head2 SUPPORTED TYPES
+
+This module should recognize all the types defined in the
+Win32 Platform SDK header files.
+Please see the source for this module, in the C<__DATA__> section,
+for the full list.
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
+
+
+__DATA__
+
+[TYPE]
+ATOM s
+BOOL L
+BOOLEAN c
+BYTE C
+CHAR c
+COLORREF L
+DWORD L
+DWORD32 L
+DWORD64 Q
+FLOAT f
+HACCEL L
+HANDLE L
+HBITMAP L
+HBRUSH L
+HCOLORSPACE L
+HCONV L
+HCONVLIST L
+HCURSOR L
+HDC L
+HDDEDATA L
+HDESK L
+HDROP L
+HDWP L
+HENHMETAFILE L
+HFILE L
+HFONT L
+HGDIOBJ L
+HGLOBAL L
+HHOOK L
+HICON L
+HIMC L
+HINSTANCE L
+HKEY L
+HKL L
+HLOCAL L
+HMENU L
+HMETAFILE L
+HMODULE L
+HPALETTE L
+HPEN L
+HRGN L
+HRSRC L
+HSZ L
+HWINSTA L
+HWND L
+INT i
+INT32 i
+INT64 q
+LANGID s
+LCID L
+LCSCSTYPE L
+LCSGAMUTMATCH L
+LCTYPE L
+LONG l
+LONG32 l
+LONG64 q
+LONGLONG q
+LPARAM L
+LRESULT L
+REGSAM L
+SC_HANDLE L
+SC_LOCK L
+SERVICE_STATUS_HANDLE L
+SHORT s
+SIZE_T L
+SSIZE_T L
+TBYTE c
+TCHAR C
+UCHAR C
+UINT I
+UINT_PTR L
+UINT32 I
+UINT64 Q
+ULONG L
+ULONG32 L
+ULONG64 Q
+ULONGLONG Q
+USHORT S
+WCHAR S
+WORD S
+WPARAM L
+VOID c
+
+int i
+long l
+float f
+double d
+char c
+
+#CRITICAL_SECTION 24 -- a structure
+#LUID ? 8 -- a structure
+#VOID 0
+#CONST 4
+#FILE_SEGMENT_ELEMENT 8 -- a structure
+
+[PACKSIZE]
+c 1
+C 1
+d 8
+f 4
+i 4
+I 4
+l 4
+L 4
+q 8
+Q 8
+s 2
+S 2
+p 4
+
+[MODIFIER]
+unsigned int=I long=L short=S char=C
+
+[POINTER]
+INT_PTR INT
+LPBOOL BOOL
+LPBYTE BYTE
+LPCOLORREF COLORREF
+LPCSTR CHAR
+#LPCTSTR CHAR or WCHAR
+LPCTSTR CHAR
+LPCVOID any
+LPCWSTR WCHAR
+LPDOUBLE double
+LPDWORD DWORD
+LPHANDLE HANDLE
+LPINT INT
+LPLONG LONG
+LPSTR CHAR
+#LPTSTR CHAR or WCHAR
+LPTSTR CHAR
+LPVOID VOID
+LPWORD WORD
+LPWSTR WCHAR
+
+PBOOL BOOL
+PBOOLEAN BOOL
+PBYTE BYTE
+PCHAR CHAR
+PCSTR CSTR
+PCWCH CWCH
+PCWSTR CWSTR
+PDWORD DWORD
+PFLOAT FLOAT
+PHANDLE HANDLE
+PHKEY HKEY
+PINT INT
+PLCID LCID
+PLONG LONG
+PSHORT SHORT
+PSTR CHAR
+#PTBYTE TBYTE --
+#PTCHAR TCHAR --
+#PTSTR CHAR or WCHAR
+PTSTR CHAR
+PUCHAR UCHAR
+PUINT UINT
+PULONG ULONG
+PUSHORT USHORT
+PVOID VOID
+PWCHAR WCHAR
+PWORD WORD
+PWSTR WCHAR
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/DBIODBC.pm b/Master/tlpkg/tlperl.straw/lib/Win32/DBIODBC.pm
new file mode 100755
index 00000000000..e3262c09d99
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/DBIODBC.pm
@@ -0,0 +1,248 @@
+package # hide this package from CPAN indexer
+ Win32::ODBC;
+
+#use strict;
+
+use DBI;
+
+# once we've been loaded we don't want perl to load the real Win32::ODBC
+$INC{'Win32/ODBC.pm'} = $INC{'Win32/DBIODBC.pm'} || 1;
+
+#my $db = new Win32::ODBC("DSN=$self->{'DSN'};UID=$self->{'UID'};PWD=$self->{'PWD'};");
+
+#EMU --- my $db = new Win32::ODBC("DSN=$DSN;UID=$login;PWD=$password;");
+sub new
+{
+ shift;
+ my $connect_line= shift;
+
+# [R] self-hack to allow empty UID and PWD
+ my $temp_connect_line;
+ $connect_line=~/DSN=\w+/;
+ $temp_connect_line="$&;";
+ if ($connect_line=~/UID=\w?/)
+ {$temp_connect_line.="$&;";}
+ else {$temp_connect_line.="UID=;";};
+ if ($connect_line=~/PWD=\w?/)
+ {$temp_connect_line.="$&;";}
+ else {$temp_connect_line.="PWD=;";};
+ $connect_line=$temp_connect_line;
+# -[R]-
+
+ my $self= {};
+
+
+ $_=$connect_line;
+ /^(DSN=)(.*)(;UID=)(.*)(;PWD=)(.*)(;)$/;
+
+ #---- DBI CONNECTION VARIABLES
+
+ $self->{ODBC_DSN}=$2;
+ $self->{ODBC_UID}=$4;
+ $self->{ODBC_PWD}=$6;
+
+
+ #---- DBI CONNECTION VARIABLES
+ $self->{DBI_DBNAME}=$self->{ODBC_DSN};
+ $self->{DBI_USER}=$self->{ODBC_UID};
+ $self->{DBI_PASSWORD}=$self->{ODBC_PWD};
+ $self->{DBI_DBD}='ODBC';
+
+ #---- DBI CONNECTION
+ $self->{'DBI_DBH'}=DBI->connect($self->{'DBI_DBNAME'},
+ $self->{'DBI_USER'},$self->{'DBI_PASSWORD'},$self->{'DBI_DBD'});
+
+ warn "Error($DBI::err) : $DBI::errstr\n" if ! $self->{'DBI_DBH'};
+
+
+ #---- RETURN
+
+ bless $self;
+}
+
+
+#EMU --- $db->Sql('SELECT * FROM DUAL');
+sub Sql
+{
+ my $self= shift;
+ my $SQL_statment=shift;
+
+ # print " SQL : $SQL_statment \n";
+
+ $self->{'DBI_SQL_STATMENT'}=$SQL_statment;
+
+ my $dbh=$self->{'DBI_DBH'};
+
+ # print " DBH : $dbh \n";
+
+ my $sth=$dbh->prepare("$SQL_statment");
+
+ # print " STH : $sth \n";
+
+ $self->{'DBI_STH'}=$sth;
+
+ if ($sth)
+ {
+ $sth->execute();
+ }
+
+ #--- GET ERROR MESSAGES
+ $self->{DBI_ERR}=$DBI::err;
+ $self->{DBI_ERRSTR}=$DBI::errstr;
+
+ if ($sth)
+ {
+ #--- GET COLUMNS NAMES
+ $self->{'DBI_NAME'} = $sth->{NAME};
+ }
+
+# [R] provide compatibility with Win32::ODBC's way of identifying erraneous SQL statements
+ return ($self->{'DBI_ERR'})?1:undef;
+# -[R]-
+}
+
+
+#EMU --- $db->FetchRow())
+sub FetchRow
+{
+ my $self= shift;
+
+ my $sth=$self->{'DBI_STH'};
+ if ($sth)
+ {
+ my @row=$sth->fetchrow_array;
+ $self->{'DBI_ROW'}=\@row;
+
+ if (scalar(@row)>0)
+ {
+ #-- the row of result is not nul
+ #-- return somthing nothing will be return else
+ return 1;
+ }
+ }
+ return undef;
+}
+
+# [R] provide compatibility with Win32::ODBC's Data() method.
+sub Data
+{
+ my $self=shift;
+ my @array=@{$self->{'DBI_ROW'}};
+ foreach my $element (@array)
+ {
+ # remove padding of spaces by DBI
+ $element=~s/(\s*$)//;
+ };
+ return (wantarray())?@array:join('', @array);
+};
+# -[R]-
+
+#EMU --- %record = $db->DataHash;
+sub DataHash
+{
+ my $self= shift;
+
+ my $p_name=$self->{'DBI_NAME'};
+ my $p_row=$self->{'DBI_ROW'};
+
+ my @name=@$p_name;
+ my @row=@$p_row;
+
+ my %DataHash;
+#print @name; print "\n"; print @row;
+# [R] new code that seems to work consistent with Win32::ODBC
+ while (@name)
+ {
+ my $name=shift(@name);
+ my $value=shift(@row);
+
+ # remove padding of spaces by DBI
+ $name=~s/(\s*$)//;
+ $value=~s/(\s*$)//;
+
+ $DataHash{$name}=$value;
+ };
+# -[R]-
+
+# [R] old code that didn't appear to work
+# foreach my $name (@name)
+# {
+# $name=~s/(^\s*)|(\s*$)//;
+# my @arr=@$name;
+# foreach (@arr)
+# {
+# print "lot $name name col $_ or ROW= 0 $row[0] 1 $row[1] 2 $row[2] \n ";
+# $DataHash{$name}=shift(@row);
+# }
+# }
+# -[R]-
+
+ #--- Return Hash
+ return %DataHash;
+}
+
+
+#EMU --- $db->Error()
+sub Error
+{
+ my $self= shift;
+
+ if ($self->{'DBI_ERR'} ne '')
+ {
+ #--- Return error message
+ $self->{'DBI_ERRSTR'};
+ }
+
+ #-- else good no error message
+
+}
+
+# [R] provide compatibility with Win32::ODBC's Close() method.
+sub Close
+{
+ my $self=shift;
+
+ my $dbh=$self->{'DBI_DBH'};
+ $dbh->disconnect;
+}
+# -[R]-
+
+1;
+
+__END__
+
+# [R] to -[R]- indicate sections edited by me, Roy Lee
+
+=head1 NAME
+
+Win32::DBIODBC - Win32::ODBC emulation layer for the DBI
+
+=head1 SYNOPSIS
+
+ use Win32::DBIODBC; # instead of use Win32::ODBC
+
+=head1 DESCRIPTION
+
+This is a I<very> basic I<very> alpha quality Win32::ODBC emulation
+for the DBI. To use it just replace
+
+ use Win32::ODBC;
+
+in your scripts with
+
+ use Win32::DBIODBC;
+
+or, while experimenting, you can pre-load this module without changing your
+scripts by doing
+
+ perl -MWin32::DBIODBC your_script_name
+
+=head1 TO DO
+
+Error handling is virtually non-existant.
+
+=head1 AUTHOR
+
+Tom Horen <tho@melexis.com>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/EventLog.pm b/Master/tlpkg/tlperl.straw/lib/Win32/EventLog.pm
new file mode 100755
index 00000000000..bf840723a6a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/EventLog.pm
@@ -0,0 +1,471 @@
+#
+# EventLog.pm
+#
+# Creates an object oriented interface to the Windows NT Evenlog
+# Written by Jesse Dougherty
+#
+
+package Win32::EventLog;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD @ISA @EXPORT $GetMessageText);
+$VERSION = '0.076';
+
+require Exporter;
+require DynaLoader;
+
+die "The Win32::Eventlog module works only on Windows NT"
+ unless Win32::IsWinNT();
+
+@ISA= qw(Exporter DynaLoader);
+@EXPORT = qw(
+ EVENTLOG_AUDIT_FAILURE
+ EVENTLOG_AUDIT_SUCCESS
+ EVENTLOG_BACKWARDS_READ
+ EVENTLOG_END_ALL_PAIRED_EVENTS
+ EVENTLOG_END_PAIRED_EVENT
+ EVENTLOG_ERROR_TYPE
+ EVENTLOG_FORWARDS_READ
+ EVENTLOG_INFORMATION_TYPE
+ EVENTLOG_PAIRED_EVENT_ACTIVE
+ EVENTLOG_PAIRED_EVENT_INACTIVE
+ EVENTLOG_SEEK_READ
+ EVENTLOG_SEQUENTIAL_READ
+ EVENTLOG_START_PAIRED_EVENT
+ EVENTLOG_SUCCESS
+ EVENTLOG_WARNING_TYPE
+);
+
+$GetMessageText=0;
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ # reset $! to zero to reset any current errors.
+ local $! = 0;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($!) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ my ($pack,$file,$line) = caller;
+ die "Unknown Win32::EventLog macro $constname, at $file line $line.\n";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+#
+# new()
+#
+# Win32::EventLog->new("source name", "ServerName");
+#
+sub new {
+ die "usage: PACKAGE->new(SOURCENAME[, SERVERNAME])\n" unless @_ > 1;
+ my ($class,$source,$server) = @_;
+ my $handle;
+
+ # Create new handle
+ if ($source !~ /\\/) {
+ OpenEventLog($handle, $server, $source);
+ }
+ else {
+ OpenBackupEventLog($handle, $server, $source);
+ }
+ return bless {handle => $handle,
+ Source => $source,
+ Computer => $server} => $class;
+}
+
+sub DESTROY {shift->Close}
+
+#
+# Open (the rather braindead old way)
+# A variable initialized to empty must be supplied as the first
+# arg, followed by whatever new() takes
+#
+sub Open {
+ $_[0] = Win32::EventLog->new($_[1],$_[2]);
+}
+
+sub OpenBackup {
+ my ($class,$source,$server) = @_;
+ OpenBackupEventLog(my $handle, $server, $source);
+ return bless {handle => $handle,
+ Source => $source,
+ Computer => $server} => $class;
+}
+
+sub Backup {
+ die " usage: OBJECT->Backup(FILENAME)\n" unless @_ == 2;
+ my ($self,$file) = @_;
+ return BackupEventLog($self->{handle}, $file);
+}
+
+sub Close {
+ my $self = shift;
+ CloseEventLog($self->{handle});
+ $self->{handle} = 0;
+}
+
+# Read
+# Note: the EventInfo arguement requires a hash reference.
+sub Read {
+ my $self = shift;
+
+ die "usage: OBJECT->Read(FLAGS, RECORDOFFSET, HASHREF)\n" unless @_ == 3;
+
+ my ($readflags,$recordoffset) = @_;
+ # The following is stolen shamelessly from Wyt's tests for the registry.
+ my $result = ReadEventLog($self->{handle}, $readflags, $recordoffset,
+ my $header, my $source, my $computer, my $sid,
+ my $data, my $strings);
+ my ($length,
+ $reserved,
+ $recordnumber,
+ $timegenerated,
+ $timewritten,
+ $eventid,
+ $eventtype,
+ $numstrings,
+ $eventcategory,
+ $reservedflags,
+ $closingrecordnumber,
+ $stringoffset,
+ $usersidlength,
+ $usersidoffset,
+ $datalength,
+ $dataoffset) = unpack('l6s4l6', $header);
+
+ # make a hash out of the values returned from ReadEventLog.
+ my %h = ( Source => $source,
+ Computer => $computer,
+ Length => $datalength,
+ Category => $eventcategory,
+ RecordNumber => $recordnumber,
+ TimeGenerated => $timegenerated,
+ Timewritten => $timewritten,
+ EventID => $eventid,
+ EventType => $eventtype,
+ ClosingRecordNumber => $closingrecordnumber,
+ User => $sid,
+ Strings => $strings,
+ Data => $data,
+ );
+
+ # get the text message here
+ if ($result and $GetMessageText) {
+ GetEventLogText($source, $eventid, $strings, $numstrings, my $message);
+ $h{Message} = $message;
+ }
+
+ if (ref($_[2]) eq 'HASH') {
+ %{$_[2]} = %h; # this needed for Read(...,\%foo) case
+ }
+ else {
+ $_[2] = \%h;
+ }
+ return $result;
+}
+
+sub GetMessageText {
+ my $self = shift;
+ local $^W;
+ GetEventLogText($self->{Source},
+ $self->{EventID},
+ $self->{Strings},
+ $self->{Strings} =~ tr/\0/\0/,
+ my $message);
+
+ $self->{Message} = $message;
+ return $message;
+}
+
+sub Report {
+ die "usage: OBJECT->Report( HASHREF )\n" unless @_ == 2;
+ my ($self,$EventInfo) = @_;
+
+ die "Win32::EventLog::Report requires a hash reference as arg 2\n"
+ unless ref($EventInfo) eq "HASH";
+
+ my $computer = $EventInfo->{Computer} ? $EventInfo->{Computer}
+ : $self->{Computer};
+ my $source = exists($EventInfo->{Source}) ? $EventInfo->{Source}
+ : $self->{Source};
+
+ return WriteEventLog($computer, $source, $EventInfo->{EventType},
+ $EventInfo->{Category}, $EventInfo->{EventID}, 0,
+ $EventInfo->{Data}, split(/\0/, $EventInfo->{Strings}));
+
+}
+
+sub GetOldest {
+ my $self = shift;
+ die "usage: OBJECT->GetOldest( SCALAREF )\n" unless @_ == 1;
+ return GetOldestEventLogRecord($self->{handle},$_[0]);
+}
+
+sub GetNumber {
+ my $self = shift;
+ die "usage: OBJECT->GetNumber( SCALARREF )\n" unless @_ == 1;
+ return GetNumberOfEventLogRecords($self->{handle}, $_[0]);
+}
+
+sub Clear {
+ my ($self,$file) = @_;
+ die "usage: OBJECT->Clear( FILENAME )\n" unless @_ == 2;
+ return ClearEventLog($self->{handle}, $file);
+}
+
+bootstrap Win32::EventLog;
+
+1;
+__END__
+
+=head1 NAME
+
+Win32::EventLog - Process Win32 Event Logs from Perl
+
+=head1 SYNOPSIS
+
+ use Win32::EventLog
+ $handle=Win32::EventLog->new("Application");
+
+=head1 DESCRIPTION
+
+This module implements most of the functionality available from the
+Win32 API for accessing and manipulating Win32 Event Logs. The access
+to the EventLog routines is divided into those that relate to an
+EventLog object and its associated methods and those that relate other
+EventLog tasks (like adding an EventLog record).
+
+=head1 The EventLog Object and its Methods
+
+The following methods are available to open, read, close and backup
+EventLogs.
+
+=over 4
+
+=item Win32::EventLog->new(SOURCENAME [,SERVERNAME]);
+
+The new() method creates a new EventLog object and returns a handle
+to it. This hande is then used to call the methods below.
+
+The method is overloaded in that if the supplied SOURCENAME
+argument contains one or more literal '\' characters (an illegal
+character in a SOURCENAME), it assumes that you are trying to open
+a backup eventlog and uses SOURCENAME as the backup eventlog to
+open. Note that when opening a backup eventlog, the SERVERNAME
+argument is ignored (as it is in the underlying Win32 API). For
+EventLogs on remote machines, the SOURCENAME parameter must
+therefore be specified as a UNC path.
+
+=item $handle->Backup(FILENAME);
+
+The Backup() method backs up the EventLog represented by $handle. It
+takes a single arguemt, FILENAME. When $handle represents an
+EventLog on a remote machine, FILENAME is filename on the remote
+machine and cannot be a UNC path (i.e you must use F<C:\TEMP\App.EVT>).
+The method will fail if the log file already exists.
+
+=item $handle->Read(FLAGS, OFFSET, HASHREF);
+
+The Read() method read an EventLog entry from the EventLog represented
+by $handle.
+
+=item $handle->Close();
+
+The Close() method closes the EventLog represented by $handle. After
+Close() has been called, any further attempt to use the EventLog
+represented by $handle will fail.
+
+=item $handle->GetOldest(SCALARREF);
+
+The GetOldest() method number of the the oldest EventLog record in
+the EventLog represented by $handle. This is required to correctly
+compute the OFFSET required by the Read() method.
+
+=item $handle->GetNumber(SCALARREF);
+
+The GetNumber() method returns the number of EventLog records in
+the EventLog represented by $handle. The number of the most recent
+record in the EventLog is therefore computed by
+
+ $handle->GetOldest($oldest);
+ $handle->GetNumber($lastRec);
+ $lastRecOffset=$oldest+$lastRec;
+
+=item $handle->Clear(FILENAME);
+
+The Clear() method clears the EventLog represented by $handle. If
+you provide a non-null FILENAME, the EventLog will be backed up
+into FILENAME before the EventLog is cleared. The method will fail
+if FILENAME is specified and the file refered to exists. Note also
+that FILENAME specifies a file local to the machine on which the
+EventLog resides and cannot be specified as a UNC name.
+
+=item $handle->Report(HASHREF);
+
+The Report() method generates an EventLog entry. The HASHREF should
+contain the following keys:
+
+=over 4
+
+=item C<Computer>
+
+The C<Computer> field specfies which computer you want the EventLog
+entry recorded. If this key doesn't exist, the server name used to
+create the $handle is used.
+
+=item C<Source>
+
+The C<Source> field specifies the source that generated the EventLog
+entry. If this key doesn't exist, the source name used to create the
+$handle is used.
+
+=item C<EventType>
+
+The C<EventType> field should be one of the constants
+
+=over 4
+
+=item C<EVENTLOG_ERROR_TYPE>
+
+An Error event is being logged.
+
+=item C<EVENTLOG_WARNING_TYPE>
+
+A Warning event is being logged.
+
+=item C<EVENTLOG_INFORMATION_TYPE>
+
+An Information event is being logged.
+
+=item C<EVENTLOG_AUDIT_SUCCESS>
+
+A Success Audit event is being logged (typically in the Security
+EventLog).
+
+=item C<EVENTLOG_AUDIT_FAILURE>
+
+A Failure Audit event is being logged (typically in the Security
+EventLog).
+
+=back
+
+These constants are exported into the main namespace by default.
+
+=item C<Category>
+
+The C<Category> field can have any value you want. It is specific to
+the particular Source.
+
+=item C<EventID>
+
+The C<EventID> field should contain the ID of the message that this
+event pertains too. This assumes that you have an associated message
+file (indirectly referenced by the field C<Source>).
+
+=item C<Data>
+
+The C<Data> field contains raw data associated with this event.
+
+=item C<Strings>
+
+The C<Strings> field contains the single string that itself contains
+NUL terminated sub-strings. This are used with the EventID to generate
+the message as seen from (for example) the Event Viewer application.
+
+=back
+
+=back
+
+=head1 Other Win32::EventLog functions.
+
+The following functions are part of the Win32::EventLog package but
+are not callable from an EventLog object.
+
+=over 4
+
+=item GetMessageText(HASHREF);
+
+The GetMessageText() function assumes that HASHREF was obtained by
+a call to C<$handle-E<gt>Read()>. It returns the formatted string that
+represents the fully resolved text of the EventLog message (such as
+would be seen in the Windows NT Event Viewer). For convenience, the
+key 'Message' in the supplied HASHREF is also set to the return value
+of this function.
+
+If you set the variable $Win32::EventLog::GetMessageText to 1 then
+each call to C<$handle-E<gt>Read()> will call this function automatically.
+
+=back
+
+=head1 Example 1
+
+The following example illustrates the way in which the EventLog module
+can be used. It opens the System EventLog and reads through it from
+oldest to newest records. For each record from the B<Source> EventLog
+it extracts the full text of the Entry and prints the EventLog message
+text out.
+
+ use Win32::EventLog;
+
+ $handle=Win32::EventLog->new("System", $ENV{ComputerName})
+ or die "Can't open Application EventLog\n";
+ $handle->GetNumber($recs)
+ or die "Can't get number of EventLog records\n";
+ $handle->GetOldest($base)
+ or die "Can't get number of oldest EventLog record\n";
+
+ while ($x < $recs) {
+ $handle->Read(EVENTLOG_FORWARDS_READ|EVENTLOG_SEEK_READ,
+ $base+$x,
+ $hashRef)
+ or die "Can't read EventLog entry #$x\n";
+ if ($hashRef->{Source} eq "EventLog") {
+ Win32::EventLog::GetMessageText($hashRef);
+ print "Entry $x: $hashRef->{Message}\n";
+ }
+ $x++;
+ }
+
+=head1 Example 2
+
+To backup and clear the EventLogs on a remote machine, do the following :-
+
+ use Win32::EventLog;
+
+ $myServer="\\\\my-server"; # your servername here.
+ my($date)=join("-", ((split(/\s+/, scalar(localtime)))[0,1,2,4]));
+ my($dest);
+
+ for my $eventLog ("Application", "System", "Security") {
+ $handle=Win32::EventLog->new($eventLog, $myServer)
+ or die "Can't open Application EventLog on $myServer\n";
+
+ $dest="C:\\BackupEventLogs\\$eventLog\\$date.evt";
+ $handle->Backup($dest)
+ or warn "Could not backup and clear the $eventLog EventLog on $myServer ($^E)\n";
+
+ $handle->Close;
+ }
+
+Note that only the Clear method is required. Note also that if the
+file $dest exists, the function will fail.
+
+=head1 BUGS
+
+None currently known.
+
+The test script for 'make test' should be re-written to use the
+EventLog object.
+
+=head1 AUTHOR
+
+Original code by Jesse Dougherty for HiP Communications. Additional
+fixes and updates attributed to Martin Pauley
+<martin.pauley@ulsterbank.ltd.uk>) and Bret Giddings (bret@essex.ac.uk).
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe.pm
new file mode 100755
index 00000000000..023946025c7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe.pm
@@ -0,0 +1,308 @@
+package Win32::Exe;
+$Win32::Exe::VERSION = '0.11';
+
+=head1 NAME
+
+Win32::Exe - Manipulate Win32 executable files
+
+=head1 VERSION
+
+This document describes version 0.10 of Win32::Exe, released
+January 14, 2007.
+
+=head1 SYNOPSIS
+
+ use Win32::Exe;
+ my $exe = Win32::Exe->new('c:/windows/notepad.exe');
+
+ # Get version information
+ print $exe->version_info->get('FileDescription'), ": ",
+ $exe->version_info->get('LegalCopyright'), "\n";
+
+ # Dump icons in an executable
+ foreach my $icon ($exe->icons) {
+ printf "Icon: %s x %s (%s colors)\n",
+ $icon->Width, $icon->Height, 2 ** $icon->BitCount;
+ }
+
+ # Import icons from a .exe or .ico file and writes back the file
+ $exe->update( icon => '/c/windows/taskman.exe' );
+
+ # Change it to a console application, then save to another .exe
+ $exe->SetSubsystem('console');
+ $exe->write('c:/windows/another.exe');
+
+ # Add a manifest section
+ $exe->update( manifest => $mymanifestxml );
+ # or a default
+ $exe->update( defaultmanifest => 1 );
+
+
+=head1 DESCRIPTION
+
+This module parses and manipulating Win32 PE/COFF executable headers,
+including version information, icons and other resources.
+
+More documentation will be provided in due time. For now, please look
+at the test files in the source distributions F<t/> directory for examples
+of using this module.
+
+=cut
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Magic => 'a2', # "MZ"
+ _ => 'a58',
+ PosPE => 'V',
+ _ => 'a{($PosPE > 64) ? $PosPE - 64 : "*"}',
+ PESig => 'a4',
+ Data => 'a*',
+);
+use constant DELEGATE_SUBS => (
+ 'IconFile' => [ 'dump_iconfile', 'write_iconfile' ],
+);
+use constant DISPATCH_FIELD => 'PESig';
+use constant DISPATCH_TABLE => (
+ "PE\0\0" => "PE",
+ '*' => sub { die "Incorrect PE header -- not a valid .exe file" },
+);
+use constant DEBUG_INDEX => 6;
+use constant DEBUG_ENTRY_SIZE => 28;
+
+use File::Basename ();
+use Win32::Exe::IconFile;
+use Win32::Exe::DebugTable;
+
+sub resource_section {
+ my ($self) = @_;
+ $self->first_member('Resources');
+}
+
+sub sections {
+ my ($self) = @_;
+ my $method = (wantarray ? 'members' : 'first_member');
+ return $self->members('Section');
+}
+
+sub data_directories {
+ my ($self) = @_;
+ return $self->members('DataDirectory');
+}
+
+sub update_debug_directory {
+ my ($self, $boundary, $extra) = @_;
+
+ $self->SetSymbolTable( $self->SymbolTable + $extra )
+ if ($boundary <= $self->SymbolTable);
+
+ my @dirs = $self->data_directories;
+ return if DEBUG_INDEX > $#dirs;
+
+ my $dir = $dirs[DEBUG_INDEX] or return;
+ my $size = $dir->Size;
+ my $addr = $dir->VirtualAddress;
+
+ return unless $size or $addr;
+
+ my $count = $size / DEBUG_ENTRY_SIZE or return;
+
+ (($size % DEBUG_ENTRY_SIZE) == 0) or return;
+
+ foreach my $section ($self->sections) {
+ my $offset = $section->FileOffset;
+ my $f_size = $section->FileSize;
+ my $v_addr = $section->VirtualAddress;
+
+ next unless $v_addr <= $addr;
+ next unless $addr < ($v_addr + $f_size);
+ next unless ($addr + $size) < ($v_addr + $f_size);
+
+ $offset += $addr - $v_addr;
+ my $data = $self->substr($offset, $size);
+
+ my $table = Win32::Exe::DebugTable->new(\$data);
+
+ foreach my $dir ($table->members) {
+ next unless $boundary <= $dir->Offset;
+
+ $dir->SetOffset($dir->Offset + $extra);
+ $dir->SetVirtualAddress($dir->VirtualAddress + $extra)
+ if $dir->VirtualAddress > 0;
+ }
+
+ $self->substr($offset, $size, $table->dump);
+ last;
+ }
+}
+
+sub default_info {
+ my $self = shift;
+
+ my $filename = File::Basename::basename($self->filename);
+
+ return join(';',
+ "CompanyName=",
+ "FileDescription=",
+ "FileVersion=0.0.0.0",
+ "InternalName=$filename",
+ "LegalCopyright=",
+ "LegalTrademarks=",
+ "OriginalFilename=$filename",
+ "ProductName=",
+ "ProductVersion=0.0.0.0",
+ );
+}
+
+sub update {
+ my ($self, %args) = @_;
+
+ if ($args{defaultmanifest}) {
+ $self->add_default_manifest();
+ }
+
+ if (my $manifest = $args{manifest}) {
+ $self->set_manifest($manifest);
+ }
+
+ if (my $icon = $args{icon}) {
+ my @icons = Win32::Exe::IconFile->new($icon)->icons;
+ $self->set_icons(\@icons) if @icons;
+ }
+
+ if (my $info = $args{info}) {
+ my @info = ($self->default_info, @$info);
+
+ my @pairs;
+ foreach my $pairs (map split(/\s*;\s*(?=[\w\\\/]+\s*=)/, $_), @info) {
+ my ($key, $val) = split(/\s*=\s*/, $pairs, 2);
+ next if $key =~ /language/i;
+
+ if ($key =~ /^(product|file)version$/i) {
+ $key = "\u$1Version";
+ $val =~ /^(?:\d+\.)+\d+$/ or die "$key cannot be '$val'";
+ $val .= '.0' while $val =~ y/.,// < 3;
+
+ push(@pairs,
+ [ $key => $val ],
+ [ "/StringFileInfo/#1/$key", $val ]);
+ }
+ else {
+ push(@pairs, [ $key => $val ]);
+ }
+ }
+
+ $self->set_version_info(\@pairs) if @pairs;
+ }
+
+ die "'gui' and 'console' cannot both be true"
+ if $args{gui} and $args{console};
+
+ $self->SetSubsystem("windows") if $args{gui};
+ $self->SetSubsystem("console") if $args{console};
+ $self->write;
+}
+
+sub icons {
+ my ($self) = @_;
+ my $rsrc = $self->resource_section or return;
+ my @icons = map $_->members, $rsrc->objects('GroupIcon');
+ wantarray ? @icons : \@icons;
+}
+
+sub set_icons {
+ my ($self, $icons) = @_;
+
+ my $rsrc = $self->resource_section;
+ my $name = eval { $rsrc->first_object('GroupIcon')->PathName }
+ || '/#RT_GROUP_ICON/#1/#0';
+
+ $rsrc->remove('/#RT_GROUP_ICON');
+ $rsrc->remove('/#RT_ICON');
+
+ my $group = $self->require_class('Resource::GroupIcon')->new;
+ $group->SetPathName($name);
+ $group->set_parent($rsrc);
+ $rsrc->insert($group->PathName, $group);
+
+ $group->set_icons($icons);
+ $group->refresh;
+}
+
+sub version_info {
+ my ($self) = @_;
+ my $rsrc = $self->resource_section or return;
+
+ # XXX - return a hash in list context?
+
+ return $rsrc->first_object('Version');
+}
+
+sub set_version_info {
+ my ($self, $pairs) = @_;
+ my $rsrc = $self->resource_section or return;
+ my $version = $rsrc->first_object('Version');
+ $version->set(@$_) for @$pairs;
+ $version->refresh;
+}
+
+sub manifest {
+ my ($self) = @_;
+ my $rsrc = $self->resource_section or return;
+ if( my $obj = $rsrc->first_object('Manifest') ) {
+ return $obj;
+ } else {
+ return $self->require_class('Resource::Manifest')->new;
+ }
+}
+
+sub set_manifest {
+ my ($self, $xml) = @_;
+ my $rsrc = $self->resource_section;
+ my $name = eval { $rsrc->first_object('Manifest')->PathName } || '/#RT_MANIFEST/#1/#0';
+ $rsrc->remove( $name );
+ my $manifest = $self->require_class('Resource::Manifest')->new;
+ $manifest->SetPathName( $name );
+ $manifest->set_parent( $rsrc );
+ $manifest->update_manifest( $xml );
+ $rsrc->insert($manifest->PathName, $manifest);
+ $rsrc->refresh;
+}
+
+sub add_default_manifest {
+ my ($self) = @_;
+ my $rsrc = $self->resource_section;
+ my $name = eval { $rsrc->first_object('Manifest')->PathName } || '/#RT_MANIFEST/#1/#0';
+ $rsrc->remove( $name );
+ my $manifest = $self->require_class('Resource::Manifest')->new;
+ my $xml = $manifest->default_manifest;
+ $manifest->SetPathName( $name );
+ $manifest->set_parent( $rsrc );
+ $manifest->update_manifest( $xml );
+ $rsrc->insert($manifest->PathName, $manifest);
+ $rsrc->refresh;
+ $self->write;
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+Mark Dootson
+
+Steffen Mueller E<lt>smueller@cpan.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004-2007 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm
new file mode 100755
index 00000000000..a90ec19c451
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm
@@ -0,0 +1,35 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Base.pm $ $Author: autrijus $
+# $Revision: #8 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Base;
+
+use strict;
+use base 'Parse::Binary';
+use constant BASE_CLASS => 'Win32::Exe';
+use constant FORMAT => (
+ Data => 'a',
+);
+
+sub align {
+ my ($self, $value, $boundary) = @_;
+ my $n = ($value % $boundary) or return $value;
+ return($value + $boundary - $n);
+}
+
+sub pad {
+ my ($self, $value, $bounary) = @_;
+ my $x = length($value) % $bounary or return '';
+ return "\0" x ($bounary - $x);
+}
+
+sub decode_ucs2 {
+ my ($self, $string) = @_;
+ return join('', map chr($_), unpack("v*", $string));
+}
+
+sub encode_ucs2 {
+ my ($self, $string) = @_;
+ return pack("v*", map ord($_), split(//, $string));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm
new file mode 100755
index 00000000000..e544ed372a3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm
@@ -0,0 +1,13 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DataDirectory.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::DataDirectory;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ VirtualAddress => 'V',
+ Size => 'V',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm
new file mode 100755
index 00000000000..f87cc0062be
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm
@@ -0,0 +1,19 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DebugDirectory.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::DebugDirectory;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Flags => 'V',
+ TimeStamp => 'V',
+ VersionMajor => 'v',
+ VersionMinor => 'v',
+ Type => 'V',
+ Size => 'V',
+ VirtualAddress => 'V',
+ Offset => 'V',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm
new file mode 100755
index 00000000000..c861ee2397b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm
@@ -0,0 +1,12 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DebugTable.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::DebugTable;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ 'DebugDirectory' => [ 'a28', '*', 1 ],
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm
new file mode 100755
index 00000000000..8c24160951d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm
@@ -0,0 +1,60 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/IconFile.pm $ $Author: autrijus $
+# $Revision: #9 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::IconFile;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Magic => 'a2',
+ Type => 'v',
+ Count => 'v',
+ 'Resource::Icon' => [ 'a16', '{$Count}', 1 ],
+ Data => 'a*',
+);
+use constant DEFAULT_ARGS => (
+ Magic => "\0\0",
+ Type => 1,
+ Count => 0,
+ Data => '',
+);
+use constant DISPATCH_FIELD => 'Magic';
+use constant DISPATCH_TABLE => (
+ "\0\0" => '',
+ "MZ" => '__BASE__',
+ '*' => sub { die "Invalid icon file header: $_[1]" },
+);
+
+sub icons {
+ my $self = shift;
+ $self->members(@_);
+}
+
+sub set_icons {
+ my ($self, $icons) = @_;
+ $self->SetCount(scalar @$icons);
+ $self->set_members('Resource::Icon' => $icons);
+ $self->refresh;
+
+ foreach my $idx (0 .. $#{$icons}) {
+ $self->icons->[$idx]->SetImageOffset(length($self->dump));
+ $self->SetData( $self->Data . $icons->[$idx]->Data );
+ }
+
+ $self->refresh;
+}
+
+sub dump_iconfile {
+ my $self = shift;
+ my @icons = $self->icons;
+ my $obj = $self->require_class('IconFile')->new;
+ $obj->set_icons(\@icons);
+ return $obj->dump;
+}
+
+sub write_iconfile {
+ my ($self, $filename) = @_;
+ $self->write_file($filename, $self->dump_iconfile);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm
new file mode 100755
index 00000000000..55251562786
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm
@@ -0,0 +1,24 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::PE;
+
+use strict;
+use base 'Win32::Exe';
+use constant SUBFORMAT => (
+ Machine => 'v',
+ NumSections => 'v',
+ TimeStamp => 'V',
+ SymbolTable => 'V',
+ _ => 'a4',
+ OptHeaderSize => 'v',
+ Characteristics => 'v',
+ Data => 'a*',
+);
+use constant DISPATCH_FIELD => 'OptHeaderSize';
+use constant DISPATCH_TABLE => (
+ '0' => '',
+ '*' => 'PE::Header',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm
new file mode 100755
index 00000000000..03888fedbd8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm
@@ -0,0 +1,26 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE/Header.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::PE::Header;
+
+use strict;
+use base 'Win32::Exe::PE';
+use constant SUBFORMAT => (
+ Magic2 => 'v',
+ LMajor => 'C',
+ LMinor => 'C',
+ CodeSize => 'V',
+ IDataSize => 'V',
+ UDataSize => 'V',
+ EntryPointRVA => 'V',
+ BaseOfCode => 'V',
+ Data => 'a*',
+);
+use constant MEMBER_CLASS => 'Data';
+use constant DISPATCH_FIELD => 'Magic2';
+use constant DISPATCH_TABLE => (
+ 0x20b => 'PE::Header::PE32Plus',
+ '*' => 'PE::Header::PE32',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm
new file mode 100755
index 00000000000..ad8e641f40b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm
@@ -0,0 +1,69 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE/Header/PE32.pm $ $Author: autrijus $
+# $Revision: #8 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::PE::Header::PE32;
+
+use strict;
+use base 'Win32::Exe::PE::Header';
+use constant SUBFORMAT => (
+ BaseOfData => 'V',
+ ImageBase => 'V',
+ SectionAlign => 'V',
+ FileAlign => 'V',
+ OSMajor => 'v',
+ OSMinor => 'v',
+ UserMajor => 'v',
+ UserMinor => 'v',
+ SubsysMajor => 'v',
+ SubsysMinor => 'v',
+ _ => 'a4',
+ ImageSize => 'V',
+ HeaderSize => 'V',
+ FileChecksum => 'V',
+ SubsystemTypeId => 'v',
+ DLLFlags => 'v',
+ StackReserve => 'V',
+ StackCommit => 'V',
+ HeapReserve => 'V',
+ HeapCommit => 'V',
+ LoaderFlags => 'V',
+ NumDataDirs => 'V',
+ 'DataDirectory' => [
+ 'a8', '{$NumDataDirs}', 1
+ ],
+ 'Section' => [
+ 'a40', '{$NumSections}', 1
+ ],
+ Data => 'a*',
+);
+use constant SUBSYSTEM_TYPES => [qw(
+ _ native windows console _
+ _ _ posix _ windowsce
+)];
+use constant ST_TO_ID => {
+ map { (SUBSYSTEM_TYPES->[$_] => $_) } (0 .. $#{+SUBSYSTEM_TYPES})
+};
+use constant ID_TO_ST => { reverse %{+ST_TO_ID} };
+
+sub st_to_id {
+ my ($self, $name) = @_;
+ return $name unless $name =~ /\D/;
+ return(+ST_TO_ID->{lc($name)} || die "No such type: $name");
+}
+
+sub id_to_st {
+ my ($self, $id) = @_;
+ return(+ID_TO_ST->{$id} || $id);
+}
+
+sub Subsystem {
+ my ($self) = @_;
+ return $self->id_to_st($self->SubsystemTypeId);
+}
+
+sub SetSubsystem {
+ my ($self, $type) = @_;
+ $self->SetSubsystemTypeId($self->st_to_id($type));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm
new file mode 100755
index 00000000000..433be495ea6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm
@@ -0,0 +1,38 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource.pm $ $Author: autrijus $
+# $Revision: #7 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Resource;
+
+use strict;
+use base 'Win32::Exe::Base';
+
+sub object {
+ my ($self) = @_;
+ return $self;
+}
+
+sub path {
+ my ($self) = @_;
+ return $self->parent->path;
+}
+
+sub CodePage {
+ return 1252;
+}
+
+sub PathName {
+ my ($self) = @_;
+ return $self->{pathname} || $self->first_parent('ResourceEntry')->PathName;
+}
+
+sub SetPathName {
+ my ($self, $value) = @_;
+ $self->{pathname} = $value;
+}
+
+sub Data {
+ my ($self) = @_;
+ return $self->dump;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm
new file mode 100755
index 00000000000..c2349ec7383
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm
@@ -0,0 +1,57 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/GroupIcon.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Resource::GroupIcon;
+
+use strict;
+use base 'Win32::Exe::Resource';
+use constant FORMAT => (
+ Magic => 'a2',
+ Type => 'v',
+ Count => 'v',
+ 'Resource::Icon' => [ 'a14', '{$Count}', 1 ],
+);
+use constant DEFAULT_ARGS => (
+ Magic => "\0\0",
+ Type => 1,
+ Count => 0,
+);
+use constant DELEGATE_SUBS => (
+ 'IconFile' => [ 'dump_iconfile', 'write_iconfile' ],
+);
+
+sub icons {
+ my $self = shift;
+ $self->members(@_);
+}
+
+sub set_icons {
+ my ($self, $icons) = @_;
+
+ $self->SetCount(scalar @$icons);
+ $self->set_members('Resource::Icon' => $icons);
+
+ my $rsrc = $self->first_parent('Resources') or return;
+
+ foreach my $idx (0 .. $#{$icons}) {
+ my $icon = $self->icons->[$idx];
+ $icon->SetId($idx+1);
+ $rsrc->insert($self->icon_name($icon->Id), $icons->[$idx]);
+ }
+}
+
+sub substr {
+ my ($self, $id) = @_;
+ my $section = $self->first_parent('Resources');
+ return $section->res_data($self->icon_name($id));
+}
+
+sub icon_name {
+ my ($self, $id) = @_;
+ my @icon_name = split("/", $self->PathName, -1);
+ $icon_name[1] = "#RT_ICON";
+ $icon_name[2] = "#$id";
+ return join("/", @icon_name);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm
new file mode 100755
index 00000000000..a6b5348acbf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm
@@ -0,0 +1,54 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/Icon.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Resource::Icon;
+
+use strict;
+use base 'Win32::Exe::Resource';
+use constant FORMAT => (
+ Width => 'C',
+ Height => 'C',
+ ColorCount => 'C',
+ _ => 'C',
+ Planes => 'v',
+ BitCount => 'v',
+ ImageSize => 'V',
+ I_RVA1 => 'v',
+ I_RVA2 => 'v',
+);
+
+sub Id {
+ my ($self) = @_;
+ return $self->I_RVA1;
+}
+
+sub SetId {
+ my ($self, $value) = @_;
+ return $self->SetI_RVA1($value);
+}
+
+sub ImageOffset {
+ my ($self) = @_;
+ return $self->I_RVA1 + (($self->I_RVA2 || 0) * 65536);
+}
+
+sub SetImageOffset {
+ my ($self, $value) = @_;
+ $self->SetI_RVA1($value % 65536);
+ $self->SetI_RVA2(int($value / 65536));
+}
+
+sub Data {
+ my ($self) = @_;
+ return $self->parent->substr($self->ImageOffset, $self->ImageSize);
+}
+
+sub dump {
+ my ($self) = @_;
+ my $parent = $self->parent;
+ my $dump = $self->SUPER::dump;
+ substr($dump, -2, 2, '') unless $parent->is_type('IconFile');
+ return $dump;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm
new file mode 100755
index 00000000000..28d6ecaeff4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm
@@ -0,0 +1,60 @@
+package Win32::Exe::Resource::Manifest;
+
+use strict;
+use base 'Win32::Exe::Resource';
+use constant FORMAT => (
+ Data => 'a*',
+);
+
+sub get_manifest {
+ my ($self ) = @_;
+ return $self->dump;
+}
+
+sub set_manifest {
+ my ( $self, $xmltext ) = @_;
+ $self->SetData( $self->encode_manifest($xmltext) );
+ my $rsrc = $self->first_parent('Resources');
+ $rsrc->remove("/#RT_MANIFEST");
+ $rsrc->insert("/#RT_MANIFEST/#1/#0" => $self);
+ $rsrc->refresh;
+}
+
+sub update_manifest {
+ my ( $self, $xmltext ) = @_;
+ $self->SetData( $self->encode_manifest($xmltext) );
+}
+
+sub encode_manifest {
+ my ($self, $string) = @_;
+ return pack("a*", $string);
+}
+
+sub default_manifest {
+ my ( $self ) = @_;
+ my $defman = <<'W32EXEDEFAULTMANIFEST'
+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
+<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
+ <assemblyIdentity processorArchitecture="x86" version="0.0.0.0" type="win32" name="Win32.Exe.Application" />
+ <description>Win32.Exe.Application</description>
+ <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
+ <security>
+ <requestedPrivileges>
+ <requestedExecutionLevel level="asInvoker" uiAccess="false" />
+ </requestedPrivileges>
+ </security>
+ </trustInfo>
+ <dependency>
+ <dependentAssembly>
+ <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" publicKeyToken="6595b64144ccf1df" language="*" processorArchitecture="x86" />
+ </dependentAssembly>
+ </dependency>
+</assembly>
+W32EXEDEFAULTMANIFEST
+;
+
+
+ return $defman;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Version.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Version.pm
new file mode 100755
index 00000000000..98adfbb9b22
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Version.pm
@@ -0,0 +1,364 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/Version.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Resource::Version;
+
+use strict;
+use base 'Win32::Exe::Resource';
+use constant FORMAT => (
+ Data => 'a*',
+);
+use constant FIXED_INFO => [qw(
+ Signature StrucVersion FileVersionMS FileVersionLS
+ ProductVersionMS ProductVersionLS FileFlagsMask FileFlags
+ FileOS FileType FileSubtype FileDateMS FileDateLS
+)];
+use constant STRING_INFO => [qw(
+ Comments CompanyName FileDescription FileVersion InternalName
+ LegalCopyright LegalTrademarks OriginalFilename PrivateBuild
+ ProductName ProductVersion SpecialBuild FileNumber ProductNumber
+)];
+use constant FI_TO_ID => {
+ map { (FIXED_INFO->[$_] => $_) } (0 .. $#{+FIXED_INFO})
+};
+use constant LC_TO_SI => {
+ (map { (lc($_) => $_) } @{+STRING_INFO}, keys %{+FI_TO_ID}),
+ (map { (lc($_) => $_) } map { /^(.+)MS$/ ? $1 : () } keys %{+FI_TO_ID}),
+};
+
+sub fi_to_id {
+ my ($self, $name) = @_;
+ return(+FI_TO_ID->{$name});
+}
+
+sub lc_to_si {
+ my ($self, $name) = @_;
+ return(+LC_TO_SI->{lc($name)} || $name);
+}
+
+sub info {
+ my ($self) = @_;
+ return $self->{info};
+}
+
+sub set_info {
+ my ($self, $info) = @_;
+ $self->{info} = $info;
+}
+
+sub initialize {
+ my ($self) = @_;
+ $self->set_info($self->decode_info($self->Data));
+ die 'Invalid structure' unless $self->check;
+}
+
+sub refresh {
+ my ($self) = @_;
+ $self->SetData($self->encode_info($self->info));
+ my $rsrc = $self->first_parent('Resources');
+ $rsrc->remove("/#RT_VERSION");
+ $rsrc->insert("/#RT_VERSION/#1/#0" => $self);
+ $rsrc->refresh;
+ $self->initialize;
+}
+
+sub encode_info {
+ my ($self, $info) = @_;
+
+ my $key = shift(@$info);
+ $key = $self->encode_ucs2("$key\0");
+
+ my $val = shift(@$info);
+ my ($type, $vallen);
+
+ if (ref $val) {
+ $type = 0; # binary
+ $val = pack('V*', @$val);
+ $vallen = length($val);
+ }
+ elsif (length $val) {
+ $type = 1; # text;
+ $val = $self->encode_ucs2("$val\0");
+ $vallen = length($val) / 2;
+ }
+ else {
+ $type = 1;
+ $vallen = 0;
+ }
+
+ my @sub_objects;
+ foreach my $sub_info (@$info) {
+ my $obj = $self->encode_info($sub_info);
+ push(@sub_objects, $obj);
+ }
+
+ my $buf = pack('v3', 0, $vallen, $type) . $key;
+ $buf .= $self->pad($buf, 4);
+ $buf .= $val;
+
+ foreach my $sub_object (@sub_objects) {
+ $buf .= $self->pad($buf, 4);
+ $buf .= $sub_object;
+ }
+
+ substr($buf, 0, 2, pack('v', length($buf)));
+ return $buf;
+}
+
+sub decode_info {
+ my $self = shift;
+ my $level = $_[1] || 1;
+
+ my ($len, $vallen, $type) = unpack('v3', $_[0]);
+ die 'No record length' unless $len;
+ die 'Long length' if $len > length($_[0]);
+
+ my $buf = substr($_[0], 0, $len);
+ substr($_[0], 0, $self->align($len, 4)) = '';
+
+ my $endkey = index($buf, "\0\0", 6);
+ while ($endkey > 0 and ($endkey % 2)) {
+ $endkey = index($buf, "\0\0", $endkey + 1);
+ }
+
+ die 'Invalid endkey' if $endkey < 6 or $endkey > $len - $vallen;;
+
+ my $key = substr($buf, 6, $endkey - 6);
+ my $u8_key = $self->decode_ucs2($key);
+
+ my @res = ($u8_key);
+ $endkey = $self->align($endkey + 2, 4);
+ substr($buf, 0, $endkey, '');
+
+ if ($vallen) {
+ $vallen *= 2 if $level == 4; # only for strings
+ my $val = substr($buf, 0, $vallen);
+ if ($type) {
+ $val = $self->decode_ucs2($val);
+ $val =~ s/\0\z//;
+ }
+ else {
+ $val = [ unpack('V*', $val) ];
+ }
+ push(@res, $val);
+ $vallen = $self->align($vallen, 4);
+
+ substr($buf, 0, $vallen) = '';
+ }
+ else {
+ push(@res, '');
+ }
+
+ while (length $buf) {
+ push(@res, $self->decode_info($buf, $level + 1));
+ }
+
+ return \@res;
+}
+
+sub empty_info {
+ [ 'VS_VERSION_INFO', [ 0xFEEF04BD, 1 << 16, (0) x 11 ] ];
+}
+
+sub check_info {
+ my ($self, $info) = @_;
+ return 0 unless $info->[0] eq 'VS_VERSION_INFO';
+ return 0 unless ref($info->[1]);
+ return 0 unless $info->[1][0] == 0xFEEF04BD;
+ return 0 unless $self->check_sub_info($info);
+ return 1;
+}
+
+sub check_sub_info {
+ my ($self, $info) = @_;
+ return unless UNIVERSAL::isa($info, 'ARRAY');
+ return if @$info < 2;
+ return unless defined($info->[0]) and defined($info->[1]);
+ return unless !ref($info->[0]) and length($info->[0]);
+ return unless !ref($info->[1]) or UNIVERSAL::isa($info->[1], 'ARRAY');
+ foreach my $idx (2 .. @$info - 1) {
+ return 0 unless $self->check_sub_info($info->[$idx]);
+ }
+ return 1;
+}
+
+sub get {
+ my ($self, $name) = @_;
+ $name =~ s!\\!/!g;
+ $name = $self->lc_to_si($name);
+ my $info = $self->info;
+
+ if ($name eq '/') {
+ return undef unless ref $info->[1];
+ return $info->[1];
+ }
+
+ my $fixed = $self->fi_to_id($name);
+ if (defined $fixed) {
+ my $struct = $info->[1];
+ return undef unless $struct && ref($struct);
+ return $struct->[$fixed];
+ }
+
+ $fixed = $self->fi_to_id($name.'MS');
+ if (defined $fixed) {
+ my $struct = $info->[1];
+ return undef unless $struct && ref($struct);
+ my $ms = $struct->[$fixed];
+ my $ls = $struct->[ $self->fi_to_id($name.'LS') ];
+ return join(',', $self->split_dword($ms), $self->split_dword($ls));
+ }
+
+ my $s;
+ if ($name =~ s!^/!!) {
+ $s = $info;
+ while ($name =~ s!^([^/]+)/!!) {
+ $s = $self->find_info($s, $1) or return undef;
+ }
+ }
+ else {
+ $s = $self->find_info($info, 'StringFileInfo') or return undef;
+ if (my $cur_trans = $self->{cur_trans}) {
+ $s = $self->find_info($s, $cur_trans, 1) or return undef;
+ }
+ else {
+ $s = $s->[2] or return undef;
+ $self->{cur_trans} = $s->[0];
+ }
+ }
+
+ $s = $self->find_info($s, $name) or return undef;
+ return $s->[1];
+}
+
+sub set {
+ my ($self, $name, $value) = @_;
+ $name =~ s!\\!/!g;
+ $name = $self->lc_to_si($name);
+ my $info = $self->info;
+
+ if ($name eq '/') {
+ if (!defined $value) {
+ $info->[1] = '';
+ }
+ elsif (UNIVERSAL::isa($value, 'ARRAY') and @$value == 13) {
+ $info->[1] = $value;
+ }
+ else {
+ die 'Invalid array assigned';
+ }
+ }
+
+ my $fixed = $self->fi_to_id($name);
+ if (defined $fixed) {
+ $value = oct($value) if $value =~ /^0/;
+ $info->[1][$fixed] = $value;
+ return;
+ }
+
+ $fixed = $self->fi_to_id($name.'MS');
+ if (defined $fixed) {
+ my @value = split(/[,.]/, $value, -1);
+ if (@value == 4) {
+ $value[0] = ($value[0] << 16) | $value[1];
+ $value[1] = ($value[2] << 16) | $value[3];
+ splice(@value, 2);
+ }
+
+ die 'Invalid MS/LS value' if @value != 2;
+ $info->[1][$fixed] = $value[0] || 0;
+ $info->[1][$self->fi_to_id($name.'LS')] = $value[1] || 0;
+ return;
+ }
+
+ my $container = $info;
+
+ if ($name =~ s!^/!!) {
+ while ($name =~ s!^([^/]+)/!!) {
+ my $n = $1;
+ my $s = $self->find_info($container, $n);
+ unless ($s) {
+ $s = [ $n => '' ];
+ push(@$container, $s);
+ }
+ $container = $s;
+ }
+ }
+ else {
+ my $s = $self->find_info($container, 'StringFileInfo');
+ unless ($s) {
+ $s = [ StringFileInfo => '' ];
+ push(@$container, $s);
+ }
+ $container = $s;
+
+ my $cur_trans = $self->{cur_trans};
+ unless ($cur_trans) {
+ if (@$container > 2) {
+ $cur_trans = $container->[2][0];
+ }
+ else {
+ $cur_trans = '000004B0'; # Language Neutral && CP 1200 = Unicode
+ }
+ $self->{cur_trans} = $cur_trans;
+ }
+
+ $s = $self->find_info($container, $cur_trans, 1);
+ unless ($s) {
+ $s = [ $cur_trans => '' ];
+ push(@$container, $s);
+ }
+ $container = $s;
+ }
+
+ my ($kv, $kv_index) = $self->find_info($container, $name);
+ unless ($kv) {
+ push(@$container, [ $name => $value ]) if defined $value;
+ return;
+ }
+
+ if (defined $value) {
+ $kv->[1] = $value;
+ }
+ else {
+ splice(@$container, $kv_index, 1);
+ }
+}
+
+sub check {
+ my $self = shift;
+ return $self->check_info($self->info);
+}
+
+sub find_info {
+ my ($self, $info, $name, $ignore) = @_;
+ my $index;
+
+ if ($name =~ /^#(\d+)$/) {
+ $index = $1 - 1 + 2;
+ $index = undef if $index < 2 || $index >= @$info;
+ }
+ else {
+ for (2 .. @$info - 1) {
+ my $e = $info->[$_];
+ if ($e->[0] eq $name or $ignore && lc($e->[0]) eq lc($name)) {
+ $index = $_;
+ last;
+ }
+ }
+ }
+ if ($index) {
+ return $info->[$index] unless wantarray;
+ return ($info->[$index], $index);
+ }
+
+ return undef unless wantarray;
+ return (undef, undef);
+}
+
+sub split_dword {
+ my ($self, $dword) = @_;
+ return ($dword >> 16), ($dword & 0xFFFF);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm
new file mode 100755
index 00000000000..b33647d519c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm
@@ -0,0 +1,58 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceData.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceData;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ VirtualAddress => 'V',
+ Size => 'V',
+ CodePage => 'V',
+);
+
+sub Data {
+ my ($self) = @_;
+ return $self->{data} if defined $self->{data};
+
+ my $section = $self->first_parent('Resources');
+ my $addr = $self->VirtualAddress or return;
+ return $section->substr(
+ $addr - $section->VirtualAddress,
+ $self->Size
+ );
+}
+
+sub SetData {
+ my ($self, $data) = @_;
+ $self->{data} = $data;
+}
+
+sub object {
+ my ($self) = @_;
+ return $self->{object};
+}
+
+sub path {
+ my ($self) = @_;
+ return $self->parent->path;
+}
+
+sub initialize {
+ my ($self) = @_;
+
+ my ($base) = $self->path or return;
+ $base =~ /^#RT_(?!ICON$)(\w+)$/ or return;
+ $self->VirtualAddress or return;
+
+ my $data = $self->Data;
+ my $class = ucfirst(lc($1));
+ $class =~ s/_(\w)/\U$1/g;
+ $class = $self->require_class("Resource::$class") or return;
+
+ my $obj = $class->new(\$data, { parent => $self });
+ $obj->initialize;
+ $self->{object} = $obj;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm
new file mode 100755
index 00000000000..a44a65daf3d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm
@@ -0,0 +1,69 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry.pm $ $Author: autrijus $
+# $Revision: #7 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceEntry;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Data => 'V',
+ E_RVA => 'V',
+);
+use constant HIGH_BIT => 0x80_00_00_00;
+use Win32::Exe::ResourceData;
+
+sub high_bit {
+ my ($self) = @_;
+ return +HIGH_BIT;
+}
+
+sub path {
+ my ($self) = @_;
+ return $self->parent->path;
+}
+
+sub PathName {
+ my ($self) = @_;
+ return join('/', '', $self->path, $self->Name);
+}
+
+sub VirtualAddress {
+ my ($self) = @_;
+ $self->E_RVA & ~($self->high_bit);
+}
+
+sub SetVirtualAddress {
+ my ($self, $data) = @_;
+ $self->SetE_RVA($data | $self->IsDirectory);
+}
+
+sub IsDirectory {
+ my ($self) = @_;
+ $self->E_RVA & ($self->high_bit);
+}
+
+sub initialize {
+ my ($self) = @_;
+ my $section = $self->first_parent('Resources');
+ my $data = $section->substr($self->VirtualAddress, 12);
+ my $res_data = Win32::Exe::ResourceData->new(\$data, { parent => $self });
+ $res_data->initialize;
+ $self->{res_data} = $res_data;
+}
+
+sub Data {
+ my ($self) = @_;
+ return $self->{res_data}->Data;
+}
+
+sub CodePage {
+ my ($self) = @_;
+ return $self->{res_data}->CodePage;
+}
+
+sub object {
+ my ($self) = @_;
+ return $self->{res_data}->object;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm
new file mode 100755
index 00000000000..39e35b4000d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm
@@ -0,0 +1,47 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry/Id.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceEntry::Id;
+
+use strict;
+use base 'Win32::Exe::ResourceEntry';
+use constant SUBFORMAT => (
+ Id => 'V',
+);
+use constant RESOURCE_TYPES => [qw(
+ _ CURSOR BITMAP ICON MENU
+ DIALOG STRING FONTDIR FONT ACCELERATOR
+ RCDATA MESSAGETABLE GROUP_CURSOR _ GROUP_ICON
+ _ VERSION DLGINCLUDE _ PLUGPLAY
+ VXD ANICURSOR ANIICON HTML MANIFEST
+)];
+use constant RT_TO_ID => {
+ map { ('RT_'.RESOURCE_TYPES->[$_] => $_) }
+ (0 .. $#{+RESOURCE_TYPES})
+};
+use constant ID_TO_RT => { reverse %{+RT_TO_ID} };
+
+sub Name {
+ my ($self) = @_;
+ my $id = $_[0]->Id;
+ $id = $self->id_to_rt($id) if $self->parent->depth < 1;
+ return "#$id";
+}
+
+sub SetName {
+ my ($self, $name) = @_;
+ $name =~ s/^#//;
+ $self->SetId( $self->rt_to_id($name) );
+}
+
+sub id_to_rt {
+ my ($self, $id) = @_;
+ return(+ID_TO_RT->{$id} || $id);
+}
+
+sub rt_to_id {
+ my ($self, $rt) = @_;
+ return(+RT_TO_ID->{$rt} || $rt);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm
new file mode 100755
index 00000000000..8f6cd1d8784
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm
@@ -0,0 +1,42 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry/Name.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceEntry::Name;
+
+use strict;
+use base 'Win32::Exe::ResourceEntry';
+use constant SUBFORMAT => (
+ N_RVA => 'V',
+);
+
+sub NameAddress {
+ my ($self) = @_;
+ $self->N_RVA & ~($self->high_bit);
+}
+
+sub SetNameAddress {
+ my ($self, $data) = @_;
+ $self->SetN_RVA($data | $self->IsDirectory);
+}
+
+sub IsEscaped {
+ my ($self) = @_;
+ $self->N_RVA & ($self->high_bit);
+}
+
+sub Name {
+ my ($self) = @_;
+ my $section = $self->first_parent('Resources');
+ my $addr = $self->NameAddress;
+ my $size = unpack('v', $section->substr($addr, 2));
+ my $ustr = $section->substr($addr + 2, $size * 2);
+ my $name = $self->decode_ucs2($ustr);
+ $name =~ s{([%#/])}{sprintf('%%%02X', ord($1))}eg;
+ return $name;
+}
+
+sub SetName {
+ die "XXX unimplemented";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm
new file mode 100755
index 00000000000..7fe9fa1d5dd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm
@@ -0,0 +1,35 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceTable.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceTable;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ DebugDirectory => 'V',
+ TimeStamp => 'V',
+ VersionMajor => 'v',
+ VersionMinor => 'v',
+ NumNameEntry => 'v',
+ NumIdEntry => 'v',
+ 'ResourceEntry::Name' => [ 'a8', '{$NumNameEntry}', 1 ],
+ 'ResourceEntry::Id' => [ 'a8', '{$NumIdEntry}', 1 ],
+);
+
+sub set_path {
+ my ($self, $path) = @_;
+ $self->{path} = $path;
+}
+
+sub path {
+ my ($self) = @_;
+ wantarray ? @{$self->{path}} : $self->{path};
+}
+
+sub depth {
+ my ($self) = @_;
+ scalar @{$self->{path}};
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm
new file mode 100755
index 00000000000..d08f91590f7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm
@@ -0,0 +1,154 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section.pm $ $Author: autrijus $
+# $Revision: #9 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Name => 'Z8',
+ VirtualSize => 'V',
+ VirtualAddress => 'V',
+ FileSize => 'V',
+ FileOffset => 'V',
+ RelocOffset => 'V',
+ LineNumOffset => 'V',
+ NumReloc => 'v',
+ NumLineNum => 'v',
+ Flags => 'V',
+);
+use constant DISPATCH_FIELD => 'Name';
+use constant DISPATCH_TABLE => (
+ '.text' => 'Section::Code',
+ '.debug' => 'Section::Debug',
+ '.data' => 'Section::Data',
+ '.rdata' => 'Section::Data',
+ '.bss' => 'Section::Data',
+ '.edata' => 'Section::Exports',
+ '.idata' => 'Section::Imports',
+ '.rsrc' => 'Section::Resources',
+);
+
+use constant CONTAINS_CODE => 0x20;
+use constant CONTAINS_IDATA => 0x40;
+use constant CONTAINS_UDATA => 0x80;
+
+sub Data {
+ my ($self) = @_;
+ $self->{data} ||= do {
+ my $v_size = $self->VirtualSize;
+ my $f_size = $self->FileSize or return("\0" x $v_size);
+
+ $f_size = $v_size if $v_size < $f_size;
+
+ my $data = $self->parent->substr($self->FileOffset, $f_size);
+ $data .= ("\x0" x ($v_size - length($data)));
+ $data;
+ }
+}
+
+sub SetData {
+ my ($self, $data) = @_;
+ my $pad_size = length($1) if $data =~ s/(\0*)\z//;
+
+ my $exe = $self->parent;
+ $exe->OptHeaderSize == 224 or die "Unsupported binary format";
+
+ my $index = $self->sibling_index;
+ my $data_size = length($data);
+
+ my $f_size = $self->align($data_size, $exe->FileAlign);
+ my $v_size = $self->align($data_size, $exe->SectionAlign);
+ my $f_extra = $f_size - $self->FileSize;
+ my $v_extra = $v_size - $self->align($self->VirtualSize, $exe->SectionAlign);
+
+ $self->pad_data($f_extra, $v_extra) if $f_extra;
+
+ $self->SetVirtualSize($data_size + $pad_size);
+ $data .= ("\0" x ($self->FileSize - $data_size));
+
+ $exe->substr($self->FileOffset, length($data), $data);
+ $self->update_size;
+}
+
+sub update_size {
+ my ($self) = @_;
+
+ my $exe = $self->parent;
+ my $v_addr = $self->VirtualAddress;
+ my $v_size = $self->VirtualSize;
+
+ foreach my $dir ($exe->data_directories) {
+ next unless $dir->VirtualAddress == $v_addr;
+ $dir->SetSize($v_size);
+ $dir->refresh;
+ }
+}
+
+sub pad_data {
+ my ($self, $f_extra, $v_extra) = @_;
+
+ my $exe = $self->parent;
+ my $offset = $self->FileOffset + $self->FileSize;
+
+ $exe->update_debug_directory($offset, $f_extra);
+
+ my $exe_size = $exe->size;
+ if ($exe_size > $offset) {
+ my $buf = $exe->substr($offset, ($exe_size - $offset));
+ $exe->substr($offset + $f_extra, length($buf), $buf);
+ }
+
+ $exe->set_size($exe_size + $f_extra);
+ if ($f_extra > 0) {
+ $exe->SetData($exe->Data . ("\0" x $f_extra));
+ }
+ else {
+ $exe->SetData(substr($exe->Data, 0, $f_extra));
+ }
+
+ my $index = $self->sibling_index;
+ foreach my $section (@{$self->siblings}) {
+ next if $section->sibling_index <= $index;
+ $section->update_offset($f_extra, $v_extra);
+ }
+
+ $self->SetFileSize($self->FileSize + $f_extra);
+ $exe->SetImageSize($exe->ImageSize + $v_extra);
+
+ my $flags = $self->Flags;
+ $exe->SetCodeSize($exe->CodeSize + $f_extra) if $flags & CONTAINS_CODE;
+ $exe->SetIDataSize($exe->IDataSize + $f_extra) if $flags & CONTAINS_IDATA;
+ $exe->SetUDataSize($exe->UDataSize + $f_extra) if $flags & CONTAINS_UDATA;
+}
+
+sub update_offset {
+ my ($self, $f_extra, $v_extra) = @_;
+ return unless $f_extra > 0;
+
+ my $exe = $self->parent;
+ my $v_addr = $self->VirtualAddress;
+
+ $self->SetVirtualAddress( $v_addr + $v_extra );
+ $self->SetFileOffset( $self->FileOffset + $f_extra );
+
+ foreach my $dir ($exe->data_directories) {
+ next unless $dir->VirtualAddress == $v_addr;
+ $dir->SetVirtualAddress($self->VirtualAddress);
+ }
+}
+
+sub substr {
+ my $self = shift;
+ my $data = $self->Data;
+ my $offset = shift;
+ my $length = @_ ? shift(@_) : (length($data) - $offset);
+ my $replace = shift;
+
+ return substr($data, $offset, $length) if !defined $replace;
+
+ substr($data, $offset, $length, $replace);
+ $self->SetData($data);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm
new file mode 100755
index 00000000000..726707c3064
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Code.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Code;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm
new file mode 100755
index 00000000000..033d8f504e3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Data.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Data;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm
new file mode 100755
index 00000000000..e59ac4b3287
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Debug.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Debug;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm
new file mode 100755
index 00000000000..9d1d5117555
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Exports.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Exports;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm
new file mode 100755
index 00000000000..e736a043f15
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Imports.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Imports;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm
new file mode 100755
index 00000000000..afbc41e7309
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm
@@ -0,0 +1,260 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Resources.pm $ $Author: autrijus $
+# $Revision: #10 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Resources;
+
+use strict;
+use base 'Win32::Exe::Section';
+use constant DELEGATE_SUBS => (
+ 'ResourceEntry' => [ 'high_bit' ],
+ 'ResourceEntry::Id' => [ 'rt_to_id', 'id_to_rt' ],
+);
+
+sub initialize {
+ my $self = shift;
+ $self->make_table(0);
+ return $self;
+}
+
+sub table {
+ my $self = shift;
+ return $self->{table};
+}
+
+sub make_table {
+ my ($self, $offset, @path) = @_;
+ my $image = $self->substr($offset);
+ my $table = $self->require_class('ResourceTable')->new(
+ \$image, {
+ parent => $self,
+ path => \@path
+ },
+ );
+
+ foreach my $entry ($table->members) {
+ if ($entry->IsDirectory) {
+ $self->make_table($entry->VirtualAddress, @path, $entry->Name);
+ }
+ else {
+ $self->{table}{$entry->PathName} = $entry;
+ }
+ }
+}
+
+sub names {
+ my ($self) = @_;
+ my @rv = sort keys %{$self->{table}};
+ wantarray ? @rv : \@rv;
+}
+
+sub resources {
+ my ($self, $name) = @_;
+ my @rv = map $self->{table}{$_}, $self->names;
+ wantarray ? @rv : \@rv;
+}
+
+sub remove {
+ my ($self, $name) = @_;
+ delete $self->{table}{$_} for grep /^\Q$name\E/, $self->names;
+}
+
+sub insert {
+ my ($self, $name, $res) = @_;
+ $self->{table}{$name} = $res;
+}
+
+sub res {
+ my ($self, $name) = @_;
+ return $self->{table}{$name};
+}
+
+sub res_data {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ return $res->Data;
+}
+
+sub res_codepage {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ return $res->CodePage;
+}
+
+sub res_object {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ return $res->object;
+}
+
+sub res_image {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ my $object = $res->object or return $res->Data;
+ return $object->dump;
+}
+
+sub first_object {
+ my ($self, $type) = @_;
+ foreach my $object (grep $_, map $_->object, $self->resources) {
+ return $object if !$type or $object->is_type($type);
+ }
+ return undef;
+}
+
+sub objects {
+ my ($self, $type) = @_;
+ return grep { $type ? $_->is_type($type) : 1 }
+ grep { $_ } map { $_->object } $self->resources;
+}
+
+sub refresh {
+ my $self = shift;
+
+ my $res_num = @{$self->resources} or return pack('V*', (0) x 4);
+ my $entry_size = $self->entry_size(scalar $self->names);
+ my $data_entry_size = 16 * $res_num;
+
+ my %str_addr;
+ my $str_image = '';
+ my $str_offset = $entry_size + $data_entry_size;
+
+ foreach my $name ($self->names) {
+ $name =~ s!^/!!;
+ foreach my $chunk (split("/", $name, -1)) {
+ $chunk =~ /^#/ and next;
+ $chunk =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ next if exists $str_addr{$chunk};
+
+ die "String too long" if length($chunk) > 0xFFFF;
+
+ my $addr = length($str_image);
+ my $str = $self->encode_ucs2($chunk);
+ $str_image .= pack('v', length($str) / 2) . $str;
+
+ $str_addr{$chunk} = $addr + $str_offset;
+ }
+ }
+ $str_image .= $self->pad($str_image, 8);
+
+ my %data_entry_addr;
+ my $data_entry_image = '';
+ my $data_image = '';
+ my $data_offset = $str_offset + length($str_image);
+
+ foreach my $name ($self->names) {
+ $data_entry_addr{$name} = $entry_size + length($data_entry_image);
+
+ my $data_addr = $data_offset + length($data_image) + $self->VirtualAddress;
+ $data_entry_image .= pack(
+ 'V4',
+ $data_addr,
+ length($self->res_data($name)),
+ $self->res_codepage($name),
+ 0,
+ );
+ $data_image .= $self->res_data($name);
+ $data_image .= $self->pad($data_image, 8);
+ }
+
+ my $entry_image = '';
+ $self->make_entry(
+ \$entry_image,
+ '',
+ [$self->names],
+ \%str_addr,
+ \%data_entry_addr,
+ );
+
+ length($entry_image) == $entry_size or die "Wrong size";
+
+ $self->SetData(
+ join('', $entry_image, $data_entry_image, $str_image, $data_image)
+ );
+}
+
+sub entry_size {
+ my ($self, $names) = @_;
+
+ my %entries;
+ foreach my $name (grep length, @$names) {
+ $name =~ m!^/([^/]*)(.*)! or next;
+ push(@{ $entries{$1} }, $2);
+ }
+
+ my $count = keys %entries or return 0;
+ my $size = 8 * ($count + 2);
+ $size += $self->entry_size($_) for values %entries;
+ return $size;
+}
+
+sub make_entry {
+ my ($self, $image_ref, $prefix, $names, $str_addr, $data_entry_addr) = @_;
+
+ if (@$names == 1 and !length($names->[0])) {
+ return $data_entry_addr->{$prefix};
+ }
+
+ my %entries;
+ foreach my $name (@$names) {
+ $name =~ m!^/([^/]*)(.*)! or next;
+ my ($path, $name) = ($1, $2);
+ my $type = ($path =~ /^#/) ? 'id' : 'name';
+ push(@{ $entries{$type}{$path} }, $name);
+ }
+
+ my $addr = length($$image_ref);
+ my $num_name = keys %{ $entries{name} };
+ my $num_id = keys %{ $entries{id} };
+ $$image_ref .= pack('V3vv', 0, 0, 0, $num_name, $num_id);
+
+ my $entry_offset = length($$image_ref);
+ $$image_ref .= pack('V*', (0) x (($num_name + $num_id) * 2));
+
+ foreach my $entry ($self->sort_entry(\%entries)) {
+ my ($type, $name) = @$entry;
+ my $id;
+ if ($type eq 'id') {
+ $id = $name;
+ $id =~ s/^#//;
+ $id = $self->rt_to_id($id);
+ }
+ else {
+ (my $n = $name) =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ $id = $str_addr->{$n} | $self->high_bit;
+ }
+
+ my $rva = $self->make_entry(
+ $image_ref,
+ "$prefix/$name",
+ $entries{$type}{$name},
+ $str_addr,
+ $data_entry_addr,
+ );
+
+ substr($$image_ref, $entry_offset, 8) = pack('VV', $id, $rva);
+ $entry_offset += 8;
+ }
+
+ return ($addr | $self->high_bit);
+}
+
+sub sort_entry {
+ my ($self, $entries) = @_;
+
+ my @names = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map {
+ my $name = lc($_);
+ $name =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ [ $name => $_ ];
+ } keys %{ $entries->{name} };
+
+ my @ids = map "#$_", sort {
+ $self->rt_to_id($a) <=> $self->rt_to_id($b)
+ } map substr($_, 1), keys %{ $entries->{id} };
+
+ return(
+ (map [ name => $_ ], @names),
+ (map [ id => $_ ], @ids),
+ );
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/File.pm b/Master/tlpkg/tlperl.straw/lib/Win32/File.pm
new file mode 100755
index 00000000000..811e3ccb114
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/File.pm
@@ -0,0 +1,118 @@
+package Win32::File;
+
+#
+# File.pm
+# Written by Douglas_Lankshear@ActiveWare.com
+#
+# subsequent hacks:
+# Gurusamy Sarathy
+#
+
+$VERSION = '0.06';
+
+require Exporter;
+require DynaLoader;
+
+@ISA= qw( Exporter DynaLoader );
+@EXPORT = qw(
+ ARCHIVE
+ COMPRESSED
+ DIRECTORY
+ HIDDEN
+ NORMAL
+ OFFLINE
+ READONLY
+ SYSTEM
+ TEMPORARY
+ );
+@EXPORT_OK = qw(GetAttributes SetAttributes);
+
+=head1 NAME
+
+Win32::File - Manage file attributes in perl
+
+=head1 SYNOPSIS
+
+ use Win32::File;
+
+=head1 DESCRIPTION
+
+This module offers the retrieval and setting of file attributes.
+
+=head1 Functions
+
+=head2 NOTE
+
+All of the functions return FALSE (0) if they fail, unless otherwise noted.
+The function names are exported into the caller's namespace by request.
+
+=over 10
+
+=item GetAttributes(filename, returnedAttributes)
+
+Gets the attributes of a file or directory. returnedAttributes will be set
+to the OR-ed combination of the filename attributes.
+
+=item SetAttributes(filename, newAttributes)
+
+Sets the attributes of a file or directory. newAttributes must be an OR-ed
+combination of the attributes.
+
+=back
+
+=head1 Constants
+
+The following constants are exported by default.
+
+=over 10
+
+=item ARCHIVE
+
+=item COMPRESSED
+
+=item DIRECTORY
+
+=item HIDDEN
+
+=item NORMAL
+
+=item OFFLINE
+
+=item READONLY
+
+=item SYSTEM
+
+=item TEMPORARY
+
+=back
+
+=cut
+
+sub AUTOLOAD
+{
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ local $! = 0;
+ my $val = constant($constname);
+ if($! != 0)
+ {
+ if($! =~ /Invalid/)
+ {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else
+ {
+ ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Win32::File macro $constname, used in $file at line $line.";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap Win32::File;
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/File/Object.pm b/Master/tlpkg/tlperl.straw/lib/Win32/File/Object.pm
new file mode 100755
index 00000000000..bb4aa90ecdc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/File/Object.pm
@@ -0,0 +1,450 @@
+package Win32::File::Object;
+
+=pod
+
+=head1 NAME
+
+Win32::File::Object - Simplified object abstraction over Win32::File
+
+=head1 SYNOPSIS
+
+ # Get a handle for the file.
+ my $object = Win32::File::Object->new( $filename, $autowrite );
+
+ # Read a property flag for the file.
+ my $readonly = $object->readonly;
+
+ # Set a propertly flag for the file.
+ $object->readonly(1);
+
+ # If autowrite is false, write the changes to the file.
+ $object->write;
+
+=head1 DESCRIPTION
+
+L<Win32::File> is an interface to the Win32 API for file
+attributes.
+
+Unfortunately it is a B<direct> interface to the underlying Win32 API,
+with a completely non-Perlish interface involving CamelCase function
+names, bit-field flags and return-by-param.
+
+B<Win32::File::Object> is a straight-forward object-oriented Perlish
+wrapper around the raw underlying API wrapper.
+
+=head1 METHODS
+
+=cut
+
+use 5.006;
+use strict;
+use Carp ();
+use Win32::File ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '0.02';
+}
+
+
+
+
+
+#####################################################################
+# Constructor
+
+=pod
+
+=head2 new
+
+ my $file = Win32::File::Object->new( $path, $autowrite );
+
+The C<new> constructor creates a new handle to the Win32 filesystem
+attributes of an existing file or directory.
+
+The compulsory C<$filename> parameter is the name of the file or
+directory to create the handle on.
+
+The optional C<$autowrite> parameter, if true, indicates that the
+object should write the filesystem attributes to the file every
+time the method is called to set the property.
+
+If the C<$autowrite> param is false or not provided, you will
+need to call an explicit C<write> method in order to apply the
+changes to the file.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $path = shift;
+ my $autowrite = !! shift;
+ unless ( $path ) {
+ Carp::croak("Did not provide a file name");
+ }
+ unless ( -f $path ) {
+ Carp::croak("File '$path' does not exist");
+ }
+
+ # Create the object
+ my $self = bless {
+ path => $path,
+ autowrite => $autowrite,
+ rollback => ! 1,
+ }, $class;
+
+ # Get the attributes
+ $self->read;
+
+ return $self;
+}
+
+=pod
+
+=head2 path
+
+The C<path> accessor returns the original file path as provided to
+the constructor as a string.
+
+=cut
+
+sub path {
+ $_[0]->{path};
+}
+
+=pod
+
+=head2 autowrite
+
+The C<autowrite> accessor returns true if the object will
+automatically write changes to the filesystem, or false if
+not.
+
+=cut
+
+sub autowrite {
+ $_[0]->{autowrite};
+}
+
+
+
+
+
+#####################################################################
+# Main Methods
+
+=pod
+
+=head2 read
+
+the C<read> method reads (updates) the filesystem attributes, in case
+they have been updated since the object was originally created.
+
+Returns true on success or throws an exception (dies) on error.
+
+=cut
+
+sub read {
+ my $self = shift;
+
+ # Read the bitfield
+ my $bits;
+ my $path = $self->path;
+ unless ( Win32::File::GetAttributes( $self->path => $bits ) ) {
+ Carp::croak("GetAttributes failed for '$path'");
+ }
+
+ # Read the flags
+ $self->{archive} = ( $bits & Win32::File::ARCHIVE() ) ? 1 : 0;
+ $self->{compressed} = ( $bits & Win32::File::COMPRESSED() ) ? 1 : 0;
+ $self->{directory} = ( $bits & Win32::File::DIRECTORY() ) ? 1 : 0;
+ $self->{hidden} = ( $bits & Win32::File::HIDDEN() ) ? 1 : 0;
+ $self->{normal} = ( $bits & Win32::File::NORMAL() ) ? 1 : 0;
+ $self->{offline} = ( $bits & Win32::File::OFFLINE() ) ? 1 : 0;
+ $self->{readonly} = ( $bits & Win32::File::READONLY() ) ? 1 : 0;
+ $self->{system} = ( $bits & Win32::File::SYSTEM() ) ? 1 : 0;
+ $self->{temporary} = ( $bits & Win32::File::TEMPORARY() ) ? 1 : 0;
+
+ return 1;
+}
+
+=pod
+
+=head2 write
+
+the C<write> method writes the object attributes back to the filesystem.
+
+Returns true on success or throws an exception (dies) on error.
+
+=cut
+
+sub write {
+ my $self = shift;
+
+ # Generate the bitfield from the attributes
+ my $bits = 0;
+ if ( $self->archive ) {
+ $bits += Win32::File::ARCHIVE();
+ }
+ if ( $self->compressed ) {
+ $bits += Win32::File::COMPRESSED();
+ }
+ if ( $self->directory ) {
+ $bits += Win32::File::DIRECTORY();
+ }
+ if ( $self->hidden ) {
+ $bits += Win32::File::HIDDEN();
+ }
+ if ( $self->normal ) {
+ $bits += Win32::File::NORMAL();
+ }
+ if ( $self->offline ) {
+ $bits += Win32::File::OFFLINE();
+ }
+ if ( $self->readonly ) {
+ $bits += Win32::File::READONLY();
+ }
+ if ( $self->system ) {
+ $bits += Win32::File::SYSTEM();
+ }
+ if ( $self->temporary ) {
+ $bits += Win32::File::TEMPORARY();
+ }
+
+ # Apply the attributes to the file
+ my $path = $self->path;
+ unless ( Win32::File::SetAttributes( $path, $bits ) ) {
+ Carp::croak("SetAttributes failed for '$path'");
+ }
+
+ return 1;
+}
+
+
+
+
+
+#####################################################################
+# Attribute Methods
+
+=pod
+
+=head2 archive
+
+ # Get the value
+ my $archive = $file->archive;
+
+ # Set the value
+ $file->archive(1);
+
+The C<archive> accessor gets or set the Win32 "archive" status for
+the file.
+
+=cut
+
+sub archive {
+ shift->_attr( archive => @_ );
+}
+
+=pod
+
+=head2 compressed
+
+ # Get the value
+ my $compressed = $file->compressed;
+
+ # Set the value
+ $file->compressed(1);
+
+The C<compressed> accessor gets or set the Win32 "compressed" status
+for the file.
+
+=cut
+
+sub compressed {
+ shift->_attr( compressed => @_ );
+}
+
+=pod
+
+=head2 directory
+
+ # Get the value
+ my $directory = $file->directory;
+
+ # Set the value
+ $file->directory(1);
+
+The C<directory> accessor gets or set the Win32 "directory" status for
+the file.
+
+=cut
+
+sub directory {
+ shift->_attr( directory => @_ );
+}
+
+=pod
+
+=head2 hidden
+
+ # Get the value
+ my $hidden = $file->hidden;
+
+ # Set the value
+ $file->hidden(1);
+
+The C<hidden> accessor gets or set the Win32 "hidden" status for
+the file.
+
+=cut
+
+sub hidden {
+ shift->_attr( hidden => @_ );
+}
+
+=pod
+
+=head2 normal
+
+ # Get the value
+ my $normal = $file->normal;
+
+ # Set the value
+ $file->normal(1);
+
+The C<normal> accessor gets or set the Win32 "normal" status for
+the file.
+
+=cut
+
+sub normal {
+ shift->_attr( normal => @_ );
+}
+
+=pod
+
+=head2 offline
+
+ # Get the value
+ my $offline = $file->offline;
+
+ # Set the value
+ $file->offline(1);
+
+The C<offline> accessor gets or set the Win32 "offline" status for
+the file.
+
+=cut
+
+sub offline {
+ shift->_attr( offline => @_ );
+}
+
+=pod
+
+=head2 readonly
+
+ # Get the value
+ my $readonly = $file->readonly;
+
+ # Set the value
+ $file->readonly(1);
+
+The C<readonly> accessor gets or set the Win32 "readonly" status for
+the file.
+
+=cut
+
+sub readonly {
+ shift->_attr( readonly => @_ );
+}
+
+=pod
+
+=head2 system
+
+ # Get the value
+ my $system = $file->system;
+
+ # Set the value
+ $file->system(1);
+
+The C<system> accessor gets or set the Win32 "system" status for
+the file.
+
+=cut
+
+sub system {
+ shift->_attr( system => @_ );
+}
+
+=pod
+
+=head2 temporary
+
+ # Get the value
+ my $temporary = $file->temporary;
+
+ # Set the value
+ $file->temporary(1);
+
+The C<temporary> accessor gets or set the Win32 "temporary" status for
+the file.
+
+=cut
+
+sub temporary {
+ shift->_attr( temporary => @_ );
+}
+
+sub _attr {
+ my $self = shift;
+ my $name = shift;
+ my $new = $_[0] ? 1 : 0;
+ return $self->{$name} unless @_;
+ return $self->{$name} if $new == $self->{$name};
+
+ # Set the rollback if needed
+ if ( $self->{rollback} and ! exists $self->{rollback}->{$name} ) {
+ $self->{rollback}->{$name} = $new;
+ }
+
+ # Set the new value
+ $self->{$name} = $new;
+ $self->write if $self->autowrite;
+
+ return $self->{$name};
+}
+
+1;
+
+=pod
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Win32-File-Object>
+
+For other issues, or commercial enhancement or support, contact the author.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<Win32::File>
+
+=head1 COPYRIGHT
+
+Copyright 2008 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Process.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Process.pm
new file mode 100755
index 00000000000..24c017a94a4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Process.pm
@@ -0,0 +1,219 @@
+package Win32::Process;
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+
+$VERSION = '0.14';
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ CREATE_DEFAULT_ERROR_MODE
+ CREATE_NEW_CONSOLE
+ CREATE_NEW_PROCESS_GROUP
+ CREATE_NO_WINDOW
+ CREATE_SEPARATE_WOW_VDM
+ CREATE_SUSPENDED
+ CREATE_UNICODE_ENVIRONMENT
+ DEBUG_ONLY_THIS_PROCESS
+ DEBUG_PROCESS
+ DETACHED_PROCESS
+ HIGH_PRIORITY_CLASS
+ IDLE_PRIORITY_CLASS
+ INFINITE
+ NORMAL_PRIORITY_CLASS
+ REALTIME_PRIORITY_CLASS
+ THREAD_PRIORITY_ABOVE_NORMAL
+ THREAD_PRIORITY_BELOW_NORMAL
+ THREAD_PRIORITY_ERROR_RETURN
+ THREAD_PRIORITY_HIGHEST
+ THREAD_PRIORITY_IDLE
+ THREAD_PRIORITY_LOWEST
+ THREAD_PRIORITY_NORMAL
+ THREAD_PRIORITY_TIME_CRITICAL
+);
+
+@EXPORT_OK = qw(
+ STILL_ACTIVE
+ ABOVE_NORMAL_PRIORITY_CLASS
+ BELOW_NORMAL_PRIORITY_CLASS
+);
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function.
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ local $! = 0;
+ my $val = constant($constname);
+ if ($! != 0) {
+ my ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Win32::Process macro $constname, used at $file line $line.";
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+} # end AUTOLOAD
+
+bootstrap Win32::Process;
+
+# Win32::IPC > 1.02 uses the get_Win32_IPC_HANDLE method:
+*get_Win32_IPC_HANDLE = \&get_process_handle;
+
+1;
+__END__
+
+=head1 NAME
+
+Win32::Process - Create and manipulate processes.
+
+=head1 SYNOPSIS
+
+ use Win32::Process;
+ use Win32;
+
+ sub ErrorReport{
+ print Win32::FormatMessage( Win32::GetLastError() );
+ }
+
+ Win32::Process::Create($ProcessObj,
+ "C:\\winnt\\system32\\notepad.exe",
+ "notepad temp.txt",
+ 0,
+ NORMAL_PRIORITY_CLASS,
+ ".")|| die ErrorReport();
+
+ $ProcessObj->Suspend();
+ $ProcessObj->Resume();
+ $ProcessObj->Wait(INFINITE);
+
+=head1 DESCRIPTION
+
+This module provides access to the process control functions in the
+Win32 API.
+
+=head1 METHODS
+
+=over 8
+
+=item Win32::Process::Create($obj,$appname,$cmdline,$iflags,$cflags,$curdir)
+
+Creates a new process.
+
+ Args:
+
+ $obj container for process object
+ $appname full path name of executable module
+ $cmdline command line args
+ $iflags flag: inherit calling processes handles or not
+ $cflags flags for creation (see exported vars below)
+ $curdir working dir of new process
+
+Returns non-zero on success, 0 on failure.
+
+=item Win32::Process::Open($obj,$pid,$iflags)
+
+Creates a handle Perl can use to an existing process as identified by $pid.
+The $iflags is the inherit flag that is passed to OpenProcess. Currently
+Win32::Process objects created using Win32::Process::Open cannot Suspend
+or Resume the process. All other calls should work.
+
+Win32::Process::Open returns non-zero on success, 0 on failure.
+
+=item Win32::Process::KillProcess($pid, $exitcode)
+
+Terminates any process identified by $pid. $exitcode will be set to
+the exit code of the process.
+
+=item $ProcessObj->Suspend()
+
+Suspend the process associated with the $ProcessObj.
+
+=item $ProcessObj->Resume()
+
+Resume a suspended process.
+
+=item $ProcessObj->Kill($exitcode)
+
+Kill the associated process, have it terminate with exit code $ExitCode.
+
+=item $ProcessObj->GetPriorityClass($class)
+
+Get the priority class of the process.
+
+=item $ProcessObj->SetPriorityClass($class)
+
+Set the priority class of the process (see exported values below for
+options). Note that the ABOVE_NORMAL_PRIORITY_CLASS and
+BELOW_NORMAL_PRIORITY_CLASS classes only work on Windows 2000
+and later.
+
+=item $ProcessObj->GetProcessAffinityMask($processAffinityMask, $systemAffinityMask)
+
+Get the process affinity mask. This is a bitvector in which each bit
+represents the processors that a process is allowed to run on.
+
+=item $ProcessObj->SetProcessAffinityMask($processAffinityMask)
+
+Set the process affinity mask. Only available on Windows NT.
+
+=item $ProcessObj->GetExitCode($exitcode)
+
+Retrieve the exitcode of the process. Will return STILL_ACTIVE if the
+process is still running. The STILL_ACTIVE constant is only exported
+by explicit request.
+
+=item $ProcessObj->Wait($timeout)
+
+Wait for the process to die. $timeout should be specified in milliseconds.
+To wait forever, specify the constant C<INFINITE>.
+
+=item $ProcessObj->GetProcessID()
+
+Returns the Process ID.
+
+=item Win32::Process::GetCurrentProcessID()
+
+Returns the current process ID, which is the same as $$. But not on cygwin,
+where $$ is the cygwin-internal PID and not the windows PID.
+On cygwin GetCurrentProcessID() returns the windows PID as needed for all
+the Win32::Process functions.
+
+=back
+
+=head1 EXPORTS
+
+The following constants are exported by default:
+
+ CREATE_DEFAULT_ERROR_MODE
+ CREATE_NEW_CONSOLE
+ CREATE_NEW_PROCESS_GROUP
+ CREATE_NO_WINDOW
+ CREATE_SEPARATE_WOW_VDM
+ CREATE_SUSPENDED
+ CREATE_UNICODE_ENVIRONMENT
+ DEBUG_ONLY_THIS_PROCESS
+ DEBUG_PROCESS
+ DETACHED_PROCESS
+ HIGH_PRIORITY_CLASS
+ IDLE_PRIORITY_CLASS
+ INFINITE
+ NORMAL_PRIORITY_CLASS
+ REALTIME_PRIORITY_CLASS
+ THREAD_PRIORITY_ABOVE_NORMAL
+ THREAD_PRIORITY_BELOW_NORMAL
+ THREAD_PRIORITY_ERROR_RETURN
+ THREAD_PRIORITY_HIGHEST
+ THREAD_PRIORITY_IDLE
+ THREAD_PRIORITY_LOWEST
+ THREAD_PRIORITY_NORMAL
+ THREAD_PRIORITY_TIME_CRITICAL
+
+The following additional constants are exported by request only:
+
+ ABOVE_NORMAL_PRIORITY_CLASS
+ BELOW_NORMAL_PRIORITY_CLASS
+ STILL_ACTIVE
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Shortcut.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Shortcut.pm
new file mode 100755
index 00000000000..00200dead1f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Shortcut.pm
@@ -0,0 +1,752 @@
+package Win32::Shortcut;
+#######################################################################
+#
+# Win32::Shortcut - Perl Module for Shell Link Interface
+# ^^^^^^^^^^^^^^^
+# This module creates an object oriented interface to the Win32
+# Shell Links (IShellLink interface).
+#
+#######################################################################
+
+$VERSION = "0.07";
+
+require Exporter;
+require DynaLoader;
+
+@ISA= qw( Exporter DynaLoader );
+@EXPORT = qw(
+ SW_SHOWMAXIMIZED
+ SW_SHOWMINNOACTIVE
+ SW_SHOWNORMAL
+);
+
+
+#######################################################################
+# This AUTOLOAD is used to 'autoload' constants from the constant()
+# XS function. If a constant is not found then control is passed
+# to the AUTOLOAD in AutoLoader.
+#
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ local $!;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($!) {
+ my(undef, $file, $line) = caller;
+ die "Win32::Shortcut::$constname is not defined, used at $file line $line.";
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# PUBLIC METHODS
+#
+
+#========
+sub new {
+#========
+ my($class, $file) = @_;
+ my($ilink, $ifile) = _Instance();
+ return unless $ilink && $ifile;
+
+ my $self = bless {
+ ilink => $ilink,
+ ifile => $ifile,
+ File => "",
+ Path => "",
+ Arguments => "",
+ WorkingDirectory => "",
+ Description => "",
+ ShowCmd => 0,
+ Hotkey => 0,
+ IconLocation => "",
+ IconNumber => 0,
+ };
+
+
+ if ($file) {
+ $self->{File} = $file;
+ $self->Load($file);
+ }
+
+ return $self;
+}
+
+#=========
+sub Load {
+#=========
+ my($self, $file) = @_;
+ return undef unless ref($self);
+
+ my $result = _Load($self->{'ilink'}, $self->{'ifile'}, $file);
+
+ if ($result) {
+
+ # fill the properties of $self
+ $self->{'File'} = $file;
+ $self->{'Path'} = _GetPath($self->{'ilink'}, $self->{'ifile'},0);
+ $self->{'ShortPath'} = _GetPath($self->{'ilink'}, $self->{'ifile'},1);
+ $self->{'Arguments'} = _GetArguments($self->{'ilink'}, $self->{'ifile'});
+ $self->{'WorkingDirectory'} = _GetWorkingDirectory($self->{'ilink'}, $self->{'ifile'});
+ $self->{'Description'} = _GetDescription($self->{'ilink'}, $self->{'ifile'});
+ $self->{'ShowCmd'} = _GetShowCmd($self->{'ilink'}, $self->{'ifile'});
+ $self->{'Hotkey'} = _GetHotkey($self->{'ilink'}, $self->{'ifile'});
+ ($self->{'IconLocation'},
+ $self->{'IconNumber'}) = _GetIconLocation($self->{'ilink'}, $self->{'ifile'});
+ }
+ return $result;
+}
+
+
+#========
+sub Set {
+#========
+ my($self, $path, $arguments, $dir, $description, $show, $hotkey,
+ $iconlocation, $iconnumber) = @_;
+ return undef unless ref($self);
+
+ $self->{'Path'} = $path;
+ $self->{'Arguments'} = $arguments;
+ $self->{'WorkingDirectory'} = $dir;
+ $self->{'Description'} = $description;
+ $self->{'ShowCmd'} = $show;
+ $self->{'Hotkey'} = $hotkey;
+ $self->{'IconLocation'} = $iconlocation;
+ $self->{'IconNumber'} = $iconnumber;
+ return 1;
+}
+
+
+#=========
+sub Save {
+#=========
+ my($self, $file) = @_;
+ return unless ref($self);
+
+ $file = $self->{'File'} unless $file;
+ return unless $file;
+
+ require Win32 unless defined &Win32::GetFullPathName;
+ $file = Win32::GetFullPathName($file);
+
+ _SetPath($self->{'ilink'}, $self->{'ifile'}, $self->{'Path'});
+ _SetArguments($self->{'ilink'}, $self->{'ifile'}, $self->{'Arguments'});
+ _SetWorkingDirectory($self->{'ilink'}, $self->{'ifile'}, $self->{'WorkingDirectory'});
+ _SetDescription($self->{'ilink'}, $self->{'ifile'}, $self->{'Description'});
+ _SetShowCmd($self->{'ilink'}, $self->{'ifile'}, $self->{'ShowCmd'});
+ _SetHotkey($self->{'ilink'}, $self->{'ifile'}, $self->{'Hotkey'});
+ _SetIconLocation($self->{'ilink'}, $self->{'ifile'},
+ $self->{'IconLocation'}, $self->{'IconNumber'});
+
+ my $result = _Save($self->{'ilink'}, $self->{'ifile'}, $file);
+ if ($result) {
+ $self->{'File'} = $file unless $self->{'File'};
+ }
+ return $result;
+}
+
+#============
+sub Resolve {
+#============
+ my($self, $flags) = @_;
+ return undef unless ref($self);
+ $flags = 1 unless defined($flags);
+ my $result = _Resolve($self->{'ilink'}, $self->{'ifile'}, $flags);
+ return $result;
+}
+
+
+#==========
+sub Close {
+#==========
+ my($self) = @_;
+ return undef unless ref($self);
+
+ my $result = _Release($self->{'ilink'}, $self->{'ifile'});
+ $self->{'released'} = 1;
+ return $result;
+}
+
+#=========
+sub Path {
+#=========
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Path'};
+ } else {
+ $self->{'Path'} = $value;
+ }
+ return $self->{'Path'};
+}
+
+#==============
+sub ShortPath {
+#==============
+ my($self) = @_;
+ return undef unless ref($self);
+ return $self->{'ShortPath'};
+}
+
+#==============
+sub Arguments {
+#==============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Arguments'};
+ } else {
+ $self->{'Arguments'} = $value;
+ }
+ return $self->{'Arguments'};
+}
+
+#=====================
+sub WorkingDirectory {
+#=====================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'WorkingDirectory'};
+ } else {
+ $self->{'WorkingDirectory'} = $value;
+ }
+ return $self->{'WorkingDirectory'};
+}
+
+
+#================
+sub Description {
+#================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Description'};
+ } else {
+ $self->{'Description'} = $value;
+ }
+ return $self->{'Description'};
+}
+
+#============
+sub ShowCmd {
+#============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'ShowCmd'};
+ } else {
+ $self->{'ShowCmd'} = $value;
+ }
+ return $self->{'ShowCmd'};
+}
+
+#===========
+sub Hotkey {
+#===========
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Hotkey'};
+ } else {
+ $self->{'Hotkey'} = $value;
+ }
+ return $self->{'Hotkey'};
+}
+
+#=================
+sub IconLocation {
+#=================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'IconLocation'};
+ } else {
+ $self->{'IconLocation'} = $value;
+ }
+ return $self->{'IconLocation'};
+}
+
+#===============
+sub IconNumber {
+#===============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'IconNumber'};
+ } else {
+ $self->{'IconNumber'} = $value;
+ }
+ return $self->{'IconNumber'};
+}
+
+#============
+sub Version {
+#============
+ # [dada] to get rid of the "used only once" warning...
+ return $VERSION;
+}
+
+
+#######################################################################
+# PRIVATE METHODS
+#
+
+#============
+sub DESTROY {
+#============
+ my($self) = @_;
+
+ if (not $self->{'released'}) {
+ _Release($self->{'ilink'}, $self->{'ifile'});
+ $self->{'released'} = 1;
+ }
+}
+
+bootstrap Win32::Shortcut;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::Shortcut - Perl Module to deal with Windows Shortcuts
+
+=head1 SYNOPSIS
+
+This module implements the Win32 IShellLink Interface to allow
+management of shortcut files from Perl.
+
+ use Win32::Shortcut;
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->{'Path'} = "C:\\Directory\\Target.exe";
+ $LINK->{'Description'} = "Target executable";
+ $LINK->Save("Target.lnk");
+ $LINK->Close();
+
+=head1 REFERENCE
+
+=head2 General Usage
+
+To use this module, first add the following line at the beginning of
+your script:
+
+ use Win32::Shortcut;
+
+Then, use this command to create a shortcut object:
+
+ $LINK = Win32::Shortcut->new();
+
+This function will create a C<$LINK> object on which you can apply the
+Methods and Properties explained later.
+
+The object is not yet a shortcut file; it is just the definition of a
+shortcut. Basically, you can do 2 things:
+
+=over
+
+=item 1. Load a shortcut file into the object.
+
+=item 2. Save the object into a shortcut file.
+
+=back
+
+For the rest, the object can be accessed as it were a normal
+associative array reference. It has the following keys (here referred
+as properties):
+
+ $LINK->{'File'}
+ $LINK->{'Path'} $LINK->Path()
+ $LINK->{'ShortPath'}
+ $LINK->{'WorkingDirectory'} $LINK->WorkingDirectory()
+ $LINK->{'Arguments'} $LINK->Arguments()
+ $LINK->{'Description'} $LINK->Description()
+ $LINK->{'ShowCmd'} $LINK->ShowCmd()
+ $LINK->{'Hotkey'} $LINK->Hotkey()
+ $LINK->{'IconLocation'} $LINK->IconLocation()
+ $LINK->{'IconNumber'} $LINK->IconNumber()
+
+Thus, assuming you have a shortcut file named C<test.lnk> in your
+current directory, this simple script will tell you where this shortcut
+points to:
+
+ use Win32::Shortcut;
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+ print "Shortcut to: $LINK->{'Path'} $LINK->{'Arguments'} \n";
+ $LINK->Close();
+
+But you can also modify its values:
+
+ use Win32::Shortcut;
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+ $LINK->{'Path'} =~ s/C:/D:/i; # move the target from C: to D:
+ $LINK->{'ShowCmd'} = SW_NORMAL; # runs in a normal window
+
+and then you can save your changes to the shortcut file with this
+command:
+
+ $LINK->Save();
+ $LINK->Close();
+
+or you can save it with another name, creating a new shortcut file:
+
+ $LINK->Save("test2.lnk");
+ $LINK->Close();
+
+Finally, you can create a completely new shortcut:
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->{'Path'} = "C:\\PERL5\\BIN\\PERL.EXE";
+ $LINK->{'Arguments'} = "-v";
+ $LINK->{'WorkingDirectory'} = "C:\PERL5\\BIN";
+ $LINK->{'Description'} = "Prints out the version of Perl";
+ $LINK->{'ShowCmd'} = SW_SHOWMAXIMIZED;
+ $LINK->Save("Perl Version Info.lnk");
+ $LINK->Close();
+
+Note also that in the examples above the two lines:
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+
+can be collapsed to:
+
+ $LINK = Win32::Shortcut->new("test.lnk");
+
+
+=head2 Methods
+
+=over
+
+=item B<Close>
+
+Closes a shortcut object. Note that it is not "strictly" required to
+close the objects you created, since the Win32::Shortcut objects are
+automatically closed when the program ends (or when you elsehow destroy
+such an object).
+
+Note also that a shortcut is not automatically saved when it is closed,
+even if you modified it. You have to call Save in order to apply
+modifications to a shortcut file.
+
+Example:
+
+ $LINK->Close();
+
+=item B<Load> I<file>
+
+Loads the content of the shortcut file named I<file> in a shortcut
+object and fill the properties of the object with its values. Will
+return B<undef> on errors, or a true value if everything was
+successful.
+
+Example:
+
+ $LINK->Load("test.lnk") or print "test.lnk not found!";
+
+ print join("\n", $LINK->Path,
+ $LINK->ShortPath,
+ $LINK->Arguments,
+ $LINK->WorkingDirectory,
+ $LINK->Description,
+ $LINK->ShowCmd,
+ $LINK->Hotkey,
+ $LINK->IconLocation,
+ $LINK->IconNumber);
+ }
+
+=item B<new Win32::Shortcut> I<[file]>
+
+Creates a new shortcut object. If a filename is passed in I<file>,
+automatically Loads this file also. Returns the object created or
+B<undef> on errors.
+
+Example:
+
+ $LINK = Win32::Shortcut->new();
+
+ $RegEdit = Win32::Shortcut->new("Registry Editor.lnk");
+ die "File not found" if not $RegEdit;
+
+=item B<Resolve> I<[flag]>
+
+Attempts to automatically resolve a shortcut and returns the resolved
+path, or B<undef> on errors; in case no resolution was made, the path
+is returned unchanged. Note that the path is automatically updated in
+the Path property of the shortcut.
+
+By default this method acts quietly, but if you pass a value of 0
+(zero) in the I<flag> parameter, it will eventually post a dialog box
+prompting the user for more information.
+
+Example:
+
+ # if the target doesn't exist...
+ if(! -f $LINK->Path) {
+ # save the actual target for comparison
+ $oldpath = $LINK->Path;
+
+ # try to resolve it (with dialog box)
+ $newpath = $LINK->Resolve(0);
+
+ die "Not resolved..." if $newpath == $oldpath;
+ }
+
+=item B<Save> I<[file]>
+
+Saves the content of the shortcut object into the file named I<file>.
+If I<file> is omitted, it is taken from the File property of the object
+(which, if not changed, is the name of the last Loaded file).
+
+If no file was loaded and the File property doesn't contain a valid
+filename, the method will return B<undef>, which will also be returned
+on errors. A true value will be returned if everything was successful.
+
+Example:
+
+ $LINK->Save();
+ $LINK->Save("Copy of " . $LINK->{'File'});
+
+=item B<Set> I<path, arguments, workingdirectory, description, showcmd,
+hotkey, iconlocation, iconnumber>
+
+Sets all the properties of the shortcut object with a single command.
+This method is supplied for convenience only, you can also set those
+values changing the values of the properties.
+
+Example:
+
+ $LINK->Set("C:\\PERL5\\BIN\\PERL.EXE",
+ "-v",
+ "C:\\PERL5\\BIN",
+ "Prints out the version of Perl",
+ SW_SHOWMAXIMIZED,
+ hex('0x0337'),
+ "C:\\WINDOWS\\SYSTEM\\COOL.DLL",
+ 1);
+
+ # it is the same of...
+ $LINK->Path("C:\\PERL5\\BIN\\PERL.EXE");
+ $LINK->Arguments("-v");
+ $LINK->WorkingDirectory("C:\\PERL5\\BIN");
+ $LINK->Description("Prints out the version of Perl");
+ $LINK->ShowCmd(SW_SHOWMAXIMIZED);
+ $LINK->Hotkey(hex('0x0337'));
+ $LINK->IconLocation("C:\\WINDOWS\\SYSTEM\\COOL.DLL");
+ $LINK->IconNumber(1);
+
+=back
+
+=head2 Properties
+
+The properties of a shortcut object can be accessed as:
+
+ $OBJECT->{'property'}
+
+Eg., assuming that you have created a shortcut object with:
+
+ $LINK=new Win32::Shortcut();
+
+you can for example see its description with:
+
+ print $LINK->{'Description'};
+
+You can of course also set it:
+
+ $LINK->{'Description'}="This is a description";
+
+From version 0.02, those properties have also a corresponding method
+(subroutine), so you can write the 2 lines above using this syntax too:
+
+ print $LINK->Description;
+ $LINK->Description("This is a description");
+
+The properties of a shortcut reflect the content of the Shortcut
+Properties Dialog Box, which can be obtained by clicking the third
+mouse button on a shortcut file in the Windows 95 (or NT 4.0) Explorer
+and choosing "Properties" (well, I hope you already knew :).
+
+The fields corresponding to the single properties are marked in B<bold>
+in the following list.
+
+=over
+
+=item B<Arguments>
+
+The arguments associated with the shell link object. They will be
+passed to the targeted program (see Path) when it gets executed. In
+fact, joined with Path, this parameter forms the "B<Target>" field of a
+Shortcut Properties Dialog Box.
+
+=item B<Description>
+
+An optional description given to the shortcut. Seems to be missing in
+the Shortcut Properties Dialog Box (not yet implemented?).
+
+=item B<File>
+
+The filename of the shortcut file opened with Load, and/or the filename
+under which the shortcut will be saved with Save (if the I<file>
+argument is not specified).
+
+=item B<Hotkey>
+
+The hotkey associated to the shortcut, in the form of a 2-byte number
+of which the first byte identifies the modifiers (Ctrl, Alt, Shift...
+but I didn't find out how it works) and the second is the ASCII code of
+the character key. Correspond to the "B<Shortcut key>" field of a
+Shortcut Properties Dialog Box.
+
+=item B<IconLocation>
+
+The file that contain the icon for the shortcut. Seems actually to
+always return nothing (YMMV, I hope...).
+
+=item B<IconNumber>
+
+The number of the icon for the shortcut in the file pointed by
+IconLocation, in case more that one icon is contained in that file (I
+suppose this, documentation isn't so clear at this point).
+
+=item B<Path>
+
+The target of the shortcut. This is (joined with Arguments) the content
+of the "B<Target>" field in a Shortcut Properties Dialog Box.
+
+=item B<ShortPath>
+
+Same as Path, but expressed in a DOS-readable format (8.3 characters
+filenames). It is available as read-only (well, you can change it, but
+it has no effect on the shortcut; change Path instead) once you Load a
+shortcut file.
+
+=item B<ShowCmd>
+
+The condition of the window in which the program will be executed (can
+be Normal, Minimized or Maximized). Correspond to the "B<Run>" field of
+a Shortcut Properties Dialog Box.
+
+Allowed values are:
+
+B<Value> B<Meaning> B<Constant>
+
+ 1 Normal Window SW_SHOWNORMAL
+ 3 Maximized SW_SHOWMAXIMIZED
+ 7 Minimized SW_SHOWMINNOACTIVE
+
+Any other value (theoretically should) result in a Normal Window
+display.
+
+=item B<WorkingDirectory>
+
+The directory in which the targeted program will be executed.
+Correspond to the "B<Start in>" field of a Shortcut Properties Dialog
+Box.
+
+=back
+
+=head2 Constants
+
+The following constants are exported in the main namespace of your
+script using Win32::Shortcut:
+
+=over
+
+=item * SW_SHOWNORMAL
+
+=item * SW_SHOWMAXIMIZED
+
+=item * SW_SHOWMINNOACTIVE
+
+=back
+
+Those constants are the allowed values for the ShowCmd property.
+
+
+
+=head1 VERSION HISTORY
+
+B<0.03 (07 Apr 1997)>
+
+=over
+
+=item * The PLL file now comes in 2 versions, one for Perl version
+5.001 (build 110) and one for Perl version 5.003 (build 300 and higher,
+EXCEPT 304).
+
+=item * Added an installation program which will automatically copy the
+right files in the right place.
+
+=back
+
+B<0.02 (21 Jan 1997)>
+
+=over
+
+=item * Added methods matching properties to reduce typing overhead
+(eg. Alt-123 and 125...).
+
+=back
+
+B<0.01 (15 Jan 1997)>
+
+=over
+
+=item *
+
+First public release.
+
+=item *
+
+Added "Set" and "Resolve" and the properties "Hotkey", "IconLocation"
+and "IconNumber".
+
+=back
+
+B<0.01a (10 Jan 1997)>
+
+=over
+
+=item *
+
+First implementation of the IShellLink interface (wow, it works!); can
+"Load", "Save", and modify properties of shortcut files.
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini L<dada@perl.it>
+
+=head1 CREDITS
+
+Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the
+Perl-Win32-Users community.
+
+=head1 DISCLAIMER
+
+I<This program is FREE; you can redistribute, modify, disassemble, or
+even reverse engineer this software at your will. Keep in mind,
+however, that NOTHING IS GUARANTEED to work and everything you do is AT
+YOUR OWN RISK - I will not take responsability for any damage, loss of
+money and/or health that may arise from the use of this program!>
+
+This is distributed under the terms of Larry Wall's Artistic License.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/TieRegistry.pm b/Master/tlpkg/tlperl.straw/lib/Win32/TieRegistry.pm
new file mode 100755
index 00000000000..19f9fdf4ae5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/TieRegistry.pm
@@ -0,0 +1,3809 @@
+package Win32::TieRegistry;
+
+# Win32/TieRegistry.pm -- Perl module to easily use a Registry
+# (on Win32 systems so far).
+# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/.
+
+#
+# Skip to "=head" line for user documentation.
+#
+use 5.006;
+use strict;
+use Carp;
+use Tie::Hash ();
+
+use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK );
+BEGIN {
+ $PACK = 'Win32::TieRegistry';
+ $VERSION = '0.26';
+ @ISA = 'Tie::Hash';
+}
+
+# Required other modules:
+use Win32API::Registry 0.24 qw( :KEY_ :HKEY_ :REG_ );
+
+#Optional other modules:
+use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar );
+
+if ( eval { require Win32::WinError } ) {
+ $_NoMoreItems = Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0);
+ $_FileNotFound = Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0);
+ $_TooSmall = Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0);
+ $_MoreData = Win32::WinError::constant("ERROR_MORE_DATA",0);
+} else {
+ $_NoMoreItems = "^No more data";
+ $_FileNotFound = "cannot find the file";
+ $_TooSmall = " data area passed to ";
+ $_MoreData = "^more data is avail";
+}
+if ( $_SetDualVar = eval { require SetDualVar } ) {
+ import SetDualVar;
+}
+
+#Implementation details:
+# When opened:
+# HANDLE long; actual handle value
+# MACHINE string; name of remote machine ("" if local)
+# PATH list ref; machine-relative full path for this key:
+# ["LMachine","System","Disk"]
+# ["HKEY_LOCAL_MACHINE","System","Disk"]
+# DELIM char; delimiter used to separate subkeys (def="\\")
+# OS_DELIM char; always "\\" for Win32
+# ACCESS long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc.
+# ROOTS string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map
+# FLAGS int; bits to control certain options
+# Often:
+# VALUES ref to list of value names (data/type never cached)
+# SUBKEYS ref to list of subkey names
+# SUBCLASSES ref to list of subkey classes
+# SUBTIMES ref to list of subkey write times
+# MEMBERS ref to list of subkey_name.DELIM's, DELIM.value_name's
+# MEMBHASH hash ref to with MEMBERS as keys and 1's as values
+# Once Key "Info" requested:
+# Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen
+# MaxValNameLen MaxValDataLen SecurityLen LastWrite
+# If is tied to a hash and iterating over key values:
+# PREVIDX int; index of last MEMBERS element return
+# If is the key object returned by Load():
+# UNLOADME list ref; information about Load()ed key
+# If is a subkey of a "loaded" key other than the one returned by Load():
+# DEPENDON obj ref; object that can't be destroyed before us
+
+
+#Package-local variables:
+
+# Option flag bits:
+use vars qw(
+ $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin
+ $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls
+);
+BEGIN {
+ $Flag_ArrVal = 0x0001;
+ $Flag_TieVal = 0x0002;
+ $Flag_FastDel = 0x0004;
+ $Flag_HexDWord = 0x0008;
+ $Flag_Split = 0x0010;
+ $Flag_DualTyp = 0x0020;
+ $Flag_DualBin = 0x0040;
+ $Flag_FixNulls = 0x0080;
+}
+
+use vars qw( $RegObj %_Roots %RegHash $Registry );
+
+# Short-hand for HKEY_* constants:
+%_Roots= (
+ "Classes" => HKEY_CLASSES_ROOT,
+ "CUser" => HKEY_CURRENT_USER,
+ "LMachine" => HKEY_LOCAL_MACHINE,
+ "Users" => HKEY_USERS,
+ "PerfData" => HKEY_PERFORMANCE_DATA, # Too picky to be useful
+ "CConfig" => HKEY_CURRENT_CONFIG,
+ "DynData" => HKEY_DYN_DATA, # Too picky to be useful
+);
+
+# Basic master Registry object:
+$RegObj= {};
+@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= (
+ "NONE", "", [], "\\", "\\",
+ KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" );
+$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin if $_SetDualVar;
+bless $RegObj;
+
+# Fill cache for master Registry object:
+@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= (
+ [], [ keys(%_Roots) ], [], [] );
+grep( s#$#$RegObj->{DELIM}#,
+ @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } );
+@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen
+ MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}=
+ ( "", 0, 0, 0, 0, 0, 0, 0, 0 );
+
+# Create master Registry tied hash:
+$RegObj->Tie( \%RegHash );
+
+# Create master Registry combination object and tied hash reference:
+$Registry= \%RegHash;
+bless $Registry;
+
+
+# Preloaded methods go here.
+
+
+# Map option names to name of subroutine that controls that option:
+use vars qw( @_opt_subs %_opt_subs );
+@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex
+ FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave );
+@_opt_subs{@_opt_subs}= @_opt_subs;
+
+sub import
+{
+ my $pkg = shift(@_);
+ my $level = $Exporter::ExportLevel;
+ my $expto = caller($level);
+ my @export = ();
+ my @consts = ();
+ my $registry = $Registry->Clone;
+ local( $_ );
+ while( @_ ) {
+ $_= shift(@_);
+ if( /^\$(\w+::)*\w+$/ ) {
+ push( @export, "ObjVar" ) if /^\$RegObj$/;
+ push( @export, $_ );
+ } elsif( /^\%(\w+::)*\w+$/ ) {
+ push( @export, $_ );
+ } elsif( /^[$%]/ ) {
+ croak "${PACK}->import: Invalid variable name ($_)";
+ } elsif( /^:/ || /^(H?KEY|REG)_/ ) {
+ push( @consts, $_ );
+ } elsif( ! @_ ) {
+ croak "${PACK}->import: Missing argument after option ($_)";
+ } elsif( exists $_opt_subs{$_} ) {
+ $_= $_opt_subs{$_};
+ $registry->$_( shift(@_) );
+ } elsif( /^TiedRef$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) {
+ $_= '$'.$_ unless '$' eq $1;
+ } elsif( "SCALAR" ne ref($_) ) {
+ croak "${PACK}->import: Invalid var after TiedRef ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^TiedHash$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\%?)(\w+::)*\w+$/ ) {
+ $_= '%'.$_ unless '%' eq $1;
+ } elsif( "HASH" ne ref($_) ) {
+ croak "${PACK}->import: Invalid var after TiedHash ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^ObjectRef$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) {
+ push( @export, "ObjVar" );
+ $_= '$'.$_ unless '$' eq $1;
+ } elsif( "SCALAR" eq ref($_) ) {
+ push( @export, "ObjRef" );
+ } else {
+ croak "${PACK}->import: Invalid var after ObjectRef ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^ExportLevel$/ ) {
+ $level= shift(@_);
+ $expto= caller($level);
+ } elsif( /^ExportTo$/ ) {
+ undef $level;
+ $expto= caller($level);
+ } else {
+ croak "${PACK}->import: Invalid option ($_)";
+ }
+ }
+ Win32API::Registry->export( $expto, @consts ) if @consts;
+ @export= ('$Registry') unless @export;
+ while( @export ) {
+ $_= shift( @export );
+ if( /^\$((?:\w+::)*)(\w+)$/ ) {
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \${"${pack}::$sym"};
+ ${"${pack}::$sym"}= $registry;
+ } elsif( /^\%((?:\w+::)*)(\w+)$/ ) {
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \%{"${pack}::$sym"};
+ $registry->Tie( \%{"${pack}::$sym"} );
+ } elsif( "SCALAR" eq ref($_) ) {
+ $$_= $registry;
+ } elsif( "HASH" eq ref($_) ) {
+ $registry->Tie( $_ );
+ } elsif( /^ObjVar$/ ) {
+ $_= shift( @_ );
+ /^\$((?:\w+::)*)(\w+)$/;
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \${"${pack}::$sym"};
+ ${"${pack}::$sym"}= $registry->ObjectRef;
+ } elsif( /^ObjRef$/ ) {
+ ${shift(@_)}= $registry->ObjectRef;
+ } else {
+ die "Impossible var to export ($_)";
+ }
+ }
+}
+
+
+use vars qw( @_new_Opts %_new_Opts );
+@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON );
+@_new_Opts{@_new_Opts}= (1) x @_new_Opts;
+
+sub _new
+{
+ my $this= shift( @_ );
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $class= ref($this) || $this;
+ my $self= {};
+ my( $handle, $rpath, $opts )= @_;
+ if( @_ < 2 || "ARRAY" ne ref($rpath) || 3 < @_
+ || 3 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n",
+ " options: @_new_Opts\nCalled";
+ }
+ @$self{qw( HANDLE PATH )}= ( $handle, $rpath );
+ @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}=
+ ( $this->Machine, $this->Access, $this->Delimiter,
+ $this->OS_Delimiter, $this->_Roots, $this->_Flags );
+ if( ref($opts) ) {
+ my @err= grep( ! $_new_Opts{$_}, keys(%$opts) );
+ @err and croak "${PACK}->_new: Invalid options (@err)";
+ @$self{ keys(%$opts) }= values(%$opts);
+ }
+ bless $self, $class;
+ return $self;
+}
+
+
+sub _split
+{
+ my $self= shift( @_ );
+ $self= tied(%$self) if tied(%$self);
+ my $path= shift( @_ );
+ my $delim= @_ ? shift(@_) : $self->Delimiter;
+ my $list= [ split( /\Q$delim/, $path ) ];
+ return $list;
+}
+
+
+sub _rootKey
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $keyPath= shift(@_);
+ my $delim= @_ ? shift(@_) : $self->Delimiter;
+ my( $root, $subPath );
+ if( "ARRAY" eq ref($keyPath) ) {
+ $subPath= $keyPath;
+ } else {
+ $subPath= $self->_split( $keyPath, $delim );
+ }
+ $root= shift( @$subPath );
+ if( $root =~ /^HKEY_/ ) {
+ my $handle= Win32API::Registry::constant($root,0);
+ $handle or croak "Invalid HKEY_ constant ($root): $!";
+ return( $self->_new( $handle, [$root], {DELIM=>$delim} ),
+ $subPath );
+ } elsif( $root =~ /^([-+]|0x)?\d/ ) {
+ return( $self->_new( $root, [sprintf("0x%lX",$root)],
+ {DELIM=>$delim} ),
+ $subPath );
+ } else {
+ my $roots= $self->Roots;
+ if( $roots->{$root} ) {
+ return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ),
+ $subPath );
+ }
+ croak "No such root key ($root)";
+ }
+}
+
+
+sub _open
+{
+ my $this = shift(@_);
+ $this = tied(%$this) if ref($this) && tied(%$this);
+ my $subPath = shift(@_);
+ my $sam = @_ ? shift(@_) : $this->Access;
+ my $subKey = join( $this->OS_Delimiter, @$subPath );
+ my $handle = 0;
+ $this->RegOpenKeyEx( $subKey, 0, $sam, $handle ) or return ();
+ return $this->_new( $handle, [ @{$this->_Path}, @$subPath ],
+ { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this)
+ : defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () )
+ } );
+}
+
+
+sub ObjectRef
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self;
+}
+
+
+sub _constant
+{
+ my( $name, $desc )= @_;
+ my $value= Win32API::Registry::constant( $name, 0 );
+ my $func= (caller(1))[3];
+ if( 0 == $value ) {
+ if( $! =~ /invalid/i ) {
+ croak "$func: Invalid $desc ($name)";
+ } elsif( 0 != $! ) {
+ croak "$func: \u$desc ($name) not support on this platform";
+ }
+ }
+ return $value;
+}
+
+
+sub _connect
+{
+ my $this= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $subPath= pop(@_);
+ $subPath= $this->_split( $subPath ) unless ref($subPath);
+ my $machine= @_ ? shift(@_) : shift(@$subPath);
+ my $handle= 0;
+ my( $temp )= $this->_rootKey( [@$subPath] );
+ $temp->RegConnectRegistry( $machine, $temp->Handle, $handle )
+ or return ();
+ my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} );
+ return( $self, $subPath );
+}
+
+
+use vars qw( @Connect_Opts %Connect_Opts );
+@Connect_Opts= qw(Access Delimiter);
+@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts;
+
+sub Connect
+{
+ my $this= shift(@_);
+ my $tied= ref($this) && tied(%$this);
+ $this= tied(%$this) if $tied;
+ my( $machine, $key, $opts )= @_;
+ my $delim= "";
+ my $sam;
+ my $subPath;
+ if( @_ < 2 || 3 < @_
+ || 3 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$obj= ${PACK}->Connect(",
+ " \$Machine, \$subKey, { OPT=>VAL,... } );\n",
+ " options: @Connect_Opts\nCalled";
+ }
+ if( ref($opts) ) {
+ my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) );
+ @err and croak "${PACK}->Connect: Invalid options (@err)";
+ }
+ $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter});
+ $delim= $this->Delimiter if "" eq $delim;
+ $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access;
+ $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/;
+ ( $this, $subPath )= $this->_connect( $machine, $key );
+ return () unless defined($this);
+ my $self= $this->_open( $subPath, $sam );
+ return () unless defined($self);
+ $self->Delimiter( $delim );
+ $self= $self->TiedRef if $tied;
+ return $self;
+}
+
+
+my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES
+ Class SecurityLen LastWrite CntValues CntSubKeys
+ MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen );
+
+sub _newVirtual
+{
+ my $self= shift(@_);
+ my( $rPath, $root, $opts )= @_;
+ my $new= $self->_new( "NONE", $rPath, $opts )
+ or return ();
+ @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys};
+ return $new;
+}
+
+
+#$key= new Win32::TieRegistry "LMachine/System/Disk";
+#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk";
+#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} );
+#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} );
+#$key->new( ... );
+
+use vars qw( @new_Opts %new_Opts );
+@new_Opts= qw(Access Delimiter);
+@new_Opts{@new_Opts}= (1) x @new_Opts;
+
+sub new
+{
+ my $this= shift( @_ );
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ if( ! ref($this) ) {
+ no strict "refs";
+ my $self= ${"${this}::Registry"};
+ croak "${this}->new failed since ${PACK}::new sees that ",
+ "\$${this}::Registry is not an object."
+ if ! ref($self);
+ $this= $self->Clone;
+ }
+ my( $subKey, $opts )= @_;
+ my $delim= "";
+ my $dlen;
+ my $sam;
+ my $subPath;
+ if( @_ < 1 || 2 < @_
+ || 2 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$obj= ${PACK}->new( \$subKey, { OPT=>VAL,... } );\n",
+ " options: @new_Opts\nCalled";
+ }
+ if( defined($opts) ) {
+ my @err= grep( ! $new_Opts{$_}, keys(%$opts) );
+ @err and die "${PACK}->new: Invalid options (@err)";
+ }
+ $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter});
+ $delim= $this->Delimiter if "" eq $delim;
+ $dlen= length($delim);
+ $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access;
+ $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/;
+ if( "ARRAY" eq ref($subKey) ) {
+ $subPath= $subKey;
+ if( "NONE" eq $this->Handle && @$subPath ) {
+ ( $this, $subPath )= $this->_rootKey( $subPath );
+ }
+ } elsif( $delim x 2 eq substr($subKey,0,2*$dlen) ) {
+ my $path= $this->_split( substr($subKey,2*$dlen), $delim );
+ my $mach= shift(@$path);
+ if( ! @$path ) {
+ return $this->_newVirtual( $path, $Registry,
+ {MACHINE=>$mach,DELIM=>$delim,ACCESS=>$sam} );
+ }
+ ( $this, $subPath )= $this->_connect( $mach, $path );
+ return () if ! defined($this);
+ if( 0 == @$subPath ) {
+ $this->Delimiter( $delim );
+ return $this;
+ }
+ } elsif( $delim eq substr($subKey,0,$dlen) ) {
+ ( $this, $subPath )= $this->_rootKey( substr($subKey,$dlen), $delim );
+ } elsif( "NONE" eq $this->Handle && "" ne $subKey ) {
+ my( $mach )= $this->Machine;
+ if( $mach ) {
+ ( $this, $subPath )= $this->_connect( $mach, $subKey );
+ } else {
+ ( $this, $subPath )= $this->_rootKey( $subKey, $delim );
+ }
+ } else {
+ $subPath= $this->_split( $subKey, $delim );
+ }
+ return () unless defined($this);
+ if( 0 == @$subPath && "NONE" eq $this->Handle ) {
+ return $this->_newVirtual( $this->_Path, $this,
+ { DELIM=>$delim, ACCESS=>$sam } );
+ }
+ my $self= $this->_open( $subPath, $sam );
+ return () unless defined($self);
+ $self->Delimiter( $delim );
+ return $self;
+}
+
+
+sub Open
+{
+ my $self= shift(@_);
+ my $tied= ref($self) && tied(%$self);
+ $self= tied(%$self) if $tied;
+ $self= $self->new( @_ );
+ $self= $self->TiedRef if defined($self) && $tied;
+ return $self;
+}
+
+
+sub Clone
+{
+ my $self= shift( @_ );
+ my $new= $self->Open("");
+ return $new;
+}
+
+
+{ my @flush;
+ sub Flush
+ {
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $flush )= @_;
+ @_ and croak "Usage: \$key->Flush( \$bFlush );";
+ return 0 if "NONE" eq $self->Handle;
+ @flush= qw( VALUES SUBKEYS SUBCLASSES SUBTIMES MEMBERS Class
+ CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen
+ MaxValNameLen MaxValDataLen SecurityLen LastWrite PREVIDX )
+ unless @flush;
+ delete( @$self{@flush} );
+ if( defined($flush) && $flush ) {
+ return $self->RegFlushKey();
+ } else {
+ return 1;
+ }
+ }
+}
+
+
+sub _DualVal
+{
+ my( $hRef, $num )= @_;
+ if( $_SetDualVar && $$hRef{$num} ) {
+ &SetDualVar( $num, "$$hRef{$num}", 0+$num );
+ }
+ return $num;
+}
+
+
+use vars qw( @_RegDataTypes %_RegDataTypes );
+@_RegDataTypes= qw( REG_SZ REG_EXPAND_SZ REG_BINARY REG_LINK REG_MULTI_SZ
+ REG_DWORD_LITTLE_ENDIAN REG_DWORD_BIG_ENDIAN REG_DWORD
+ REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR
+ REG_RESOURCE_REQUIREMENTS_LIST REG_NONE );
+# Make sure that REG_DWORD appears _after_ other REG_DWORD_*
+# items above and that REG_NONE appears _last_.
+foreach( @_RegDataTypes ) {
+ $_RegDataTypes{Win32API::Registry::constant($_,0)}= $_;
+}
+
+sub GetValue
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ 1 == @_ or croak "Usage: (\$data,\$type)= \$key->GetValue('ValName');";
+ my( $valName )= @_;
+ my( $valType, $valData, $dLen )= (0,"",0);
+ return () if "NONE" eq $self->Handle;
+ $self->RegQueryValueEx( $valName, [], $valType, $valData,
+ $dLen= ( defined($self->{MaxValDataLen}) ? $self->{MaxValDataLen} : 0 )
+ ) or return ();
+ if( REG_DWORD == $valType ) {
+ my $val= unpack("L",$valData);
+ $valData= sprintf "0x%08.8lX", $val if $self->DWordsToHex;
+ &SetDualVar( $valData, $valData, $val ) if $self->DualBinVals
+ } elsif( REG_BINARY == $valType && length($valData) <= 4 ) {
+ &SetDualVar( $valData, $valData, hex reverse unpack("h*",$valData) )
+ if $self->DualBinVals;
+ } elsif( ( REG_SZ == $valType || REG_EXPAND_SZ == $valType )
+ && $self->FixSzNulls ) {
+ substr($valData,-1)= "" if "\0" eq substr($valData,-1);
+ } elsif( REG_MULTI_SZ == $valType && $self->SplitMultis ) {
+ ## $valData =~ s/\0\0$//; # Why does this often fail??
+ substr($valData,-2)= "" if "\0\0" eq substr($valData,-2);
+ $valData= [ split( /\0/, $valData, -1 ) ]
+ }
+ if( ! wantarray ) {
+ return $valData;
+ } elsif( ! $self->DualTypes ) {
+ return( $valData, $valType );
+ } else {
+ return( $valData, _DualVal( \%_RegDataTypes, $valType ) );
+ }
+}
+
+
+sub _ErrNum
+{
+ # return $^E;
+ return Win32::GetLastError();
+}
+
+
+sub _ErrMsg
+{
+ # return $^E;
+ return Win32::FormatMessage( Win32::GetLastError() );
+}
+
+sub _Err
+{
+ my $err;
+ # return $^E;
+ return _ErrMsg if ! $_SetDualVar;
+ return &SetDualVar( $err, _ErrMsg, _ErrNum );
+}
+
+sub _NoMoreItems
+{
+ return
+ $_NoMoreItems =~ /^\d/
+ ? _ErrNum == $_NoMoreItems
+ : _ErrMsg =~ /$_NoMoreItems/io;
+}
+
+
+sub _FileNotFound
+{
+ return
+ $_FileNotFound =~ /^\d/
+ ? _ErrNum == $_FileNotFound
+ : _ErrMsg =~ /$_FileNotFound/io;
+}
+
+
+sub _TooSmall
+{
+ return
+ $_TooSmall =~ /^\d/
+ ? _ErrNum == $_TooSmall
+ : _ErrMsg =~ /$_TooSmall/io;
+}
+
+
+sub _MoreData
+{
+ return
+ $_MoreData =~ /^\d/
+ ? _ErrNum == $_MoreData
+ : _ErrMsg =~ /$_MoreData/io;
+}
+
+
+sub _enumValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( @names )= ();
+ my $pos= 0;
+ my $name= "";
+ my $nlen= 1+$self->Information("MaxValNameLen");
+ while( $self->RegEnumValue($pos++,$name,$nlen,[],[],[],[]) ) {
+ push( @names, $name );
+ }
+ if( ! _NoMoreItems() ) {
+ return ();
+ }
+ $self->{VALUES}= \@names;
+ return 1;
+}
+
+
+sub ValueNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@names= \$key->ValueNames;";
+ $self->_enumValues unless $self->{VALUES};
+ return @{$self->{VALUES}};
+}
+
+
+sub _enumSubKeys
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( @subkeys, @classes, @times )= ();
+ my $pos= 0;
+ my( $subkey, $class, $time )= ("","","");
+ my( $namSiz, $clsSiz )= $self->Information(
+ qw( MaxSubKeyLen MaxSubClassLen ));
+ $namSiz++; $clsSiz++;
+ while( $self->RegEnumKeyEx(
+ $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) {
+ push( @subkeys, $subkey );
+ push( @classes, $class );
+ push( @times, $time );
+ }
+ if( ! _NoMoreItems() ) {
+ return ();
+ }
+ $self->{SUBKEYS}= \@subkeys;
+ $self->{SUBCLASSES}= \@classes;
+ $self->{SUBTIMES}= \@times;
+ return 1;
+}
+
+
+sub SubKeyNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@names= \$key->SubKeyNames;";
+ $self->_enumSubKeys unless $self->{SUBKEYS};
+ return @{$self->{SUBKEYS}};
+}
+
+
+sub SubKeyClasses
+{
+ my $self= shift(@_);
+ @_ and croak "Usage: \@classes= \$key->SubKeyClasses;";
+ $self->_enumSubKeys unless $self->{SUBCLASSES};
+ return @{$self->{SUBCLASSES}};
+}
+
+
+sub SubKeyTimes
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@times= \$key->SubKeyTimes;";
+ $self->_enumSubKeys unless $self->{SUBTIMES};
+ return @{$self->{SUBTIMES}};
+}
+
+
+sub _MemberNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;";
+ if( ! $self->{MEMBERS} ) {
+ $self->_enumValues unless $self->{VALUES};
+ $self->_enumSubKeys unless $self->{SUBKEYS};
+ my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ),
+ map( $self->{DELIM}.$_, @{$self->{VALUES}} ) );
+ $self->{MEMBERS}= \@members;
+ }
+ return $self->{MEMBERS};
+}
+
+
+sub _MembersHash
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$hashRef= \$key->_MembersHash;";
+ if( ! $self->{MEMBHASH} ) {
+ my $aRef= $self->_MemberNames;
+ $self->{MEMBHASH}= {};
+ @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef;
+ }
+ return $self->{MEMBHASH};
+}
+
+
+sub MemberNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@members= \$key->MemberNames;";
+ return @{$self->_MemberNames};
+}
+
+
+sub Information
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )=
+ ("",0,0,0,0,0,0,0);
+ my $clen= 8;
+ if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls,
+ $nvals, $xname, $xdata, $xsec, $time ) ) {
+ return ();
+ }
+ if( defined($self->{Class}) ) {
+ $clen= length($self->{Class});
+ } else {
+ $self->{Class}= "";
+ }
+ while( ! $self->RegQueryInfoKey( $self->{Class}, $clen,
+ [],[],[],[],[],[],[],[],[])
+ && _MoreData ) {
+ $clen *= 2;
+ }
+ my( %info );
+ @info{ qw( LastWrite CntSubKeys CntValues SecurityLen
+ MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen )
+ }= ( $time, $nkeys, $nvals, $xsec,
+ $xdata, $xkey, $xcls, $xname );
+ if( @_ ) {
+ my( %check );
+ @check{keys(%info)}= keys(%info);
+ my( @err )= grep( ! $check{$_}, @_ );
+ if( @err ) {
+ croak "${PACK}::Information- Invalid info requested (@err)";
+ }
+ return @info{@_};
+ } else {
+ return %info;
+ }
+}
+
+
+sub Delimiter
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ $self= $RegObj unless ref($self);
+ my( $oldDelim )= $self->{DELIM};
+ if( 1 == @_ && "" ne "$_[0]" ) {
+ delete $self->{MEMBERS};
+ delete $self->{MEMBHASH};
+ $self->{DELIM}= "$_[0]";
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);";
+ }
+ return $oldDelim;
+}
+
+
+sub Handle
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$handle= \$key->Handle;";
+ $self= $RegObj unless ref($self);
+ return $self->{HANDLE};
+}
+
+
+sub Path
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$path= \$key->Path;";
+ my $delim= $self->{DELIM};
+ $self= $RegObj unless ref($self);
+ if( "" eq $self->{MACHINE} ) {
+ return( $delim . join( $delim, @{$self->{PATH}} ) . $delim );
+ } else {
+ return( $delim x 2
+ . join( $delim, $self->{MACHINE}, @{$self->{PATH}} )
+ . $delim );
+ }
+}
+
+
+sub _Path
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$arrRef= \$key->_Path;";
+ $self= $RegObj unless ref($self);
+ return $self->{PATH};
+}
+
+
+sub Machine
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$machine= \$key->Machine;";
+ $self= $RegObj unless ref($self);
+ return $self->{MACHINE};
+}
+
+
+sub Access
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$access= \$key->Access;";
+ $self= $RegObj unless ref($self);
+ return $self->{ACCESS};
+}
+
+
+sub OS_Delimiter
+{
+ my $self= shift(@_);
+ @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;";
+ return $self->{OS_DELIM};
+}
+
+
+sub _Roots
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if ref($self) && tied(%$self);
+ @_ and croak "Usage: \$varName= \$key->_Roots;";
+ $self= $RegObj unless ref($self);
+ return $self->{ROOTS};
+}
+
+
+sub Roots
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if ref($self) && tied(%$self);
+ @_ and croak "Usage: \$hashRef= \$key->Roots;";
+ $self= $RegObj unless ref($self);
+ return eval "\\%$self->{ROOTS}";
+}
+
+
+sub TIEHASH
+{
+ my( $this )= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my( $key )= @_;
+ if( 1 == @_ && ref($key) && "$key" =~ /=/ ) {
+ return $key; # $key is already an object (blessed reference).
+ }
+ return $this->new( @_ );
+}
+
+
+sub Tie
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $hRef )= @_;
+ if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) {
+ croak "Usage: \$key->Tie(\\\%hash);";
+ }
+ return tie %$hRef, ref($self), $self;
+}
+
+
+sub TiedRef
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $hRef= @_ ? shift(@_) : {};
+ return () if ! defined($self);
+ $self->Tie($hRef);
+ bless $hRef, ref($self);
+ return $hRef;
+}
+
+
+sub _Flags
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlags= $self->{FLAGS};
+ if( 1 == @_ ) {
+ $self->{FLAGS}= shift(@_);
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBits= \$key->_Flags(\$newBits);";
+ }
+ return $oldFlags;
+}
+
+
+sub ArrayValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_ArrVal;
+ } else {
+ $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal );
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub TieValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->TieValues cannot be enabled with this version";
+ $self->{FLAGS} |= $Flag_TieVal;
+ } else {
+ $self->{FLAGS} &= ~$Flag_TieVal;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->TieValues(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub FastDelete
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_FastDel;
+ } else {
+ $self->{FLAGS} &= ~$Flag_FastDel;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub SplitMultis
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_Split;
+ } else {
+ $self->{FLAGS} &= ~$Flag_Split;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DWordsToHex
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_HexDWord;
+ } else {
+ $self->{FLAGS} &= ~$Flag_HexDWord;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub FixSzNulls
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_FixNulls;
+ } else {
+ $self->{FLAGS} &= ~$Flag_FixNulls;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DualTypes
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->DualTypes cannot be enabled since ",
+ "SetDualVar module not installed"
+ unless $_SetDualVar;
+ $self->{FLAGS} |= $Flag_DualTyp;
+ } else {
+ $self->{FLAGS} &= ~$Flag_DualTyp;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DualBinVals
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->DualBinVals cannot be enabled since ",
+ "SetDualVar module not installed"
+ unless $_SetDualVar;
+ $self->{FLAGS} |= $Flag_DualBin;
+ } else {
+ $self->{FLAGS} &= ~$Flag_DualBin;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub GetOptions
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $opt, $meth );
+ if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) {
+ my $href= @_ ? $_[0] : {};
+ foreach $opt ( grep !/^Allow/, @_opt_subs ) {
+ $meth= $_opt_subs{$opt};
+ $href->{$opt}= $self->$meth();
+ }
+ return @_ ? $self : $href;
+ }
+ my @old;
+ foreach $opt ( @_ ) {
+ $meth= $_opt_subs{$opt};
+ if( defined $meth ) {
+ if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) {
+ croak "${PACK}->GetOptions: Getting current setting of $opt ",
+ "not supported in this release";
+ }
+ push( @old, $self->$meth() );
+ } else {
+ croak "${PACK}->GetOptions: Invalid option ($opt) ",
+ "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )";
+ }
+ }
+ return wantarray ? @old : $old[-1];
+}
+
+
+sub SetOptions
+{
+ my $self= shift(@_);
+ # Don't get object if hash ref so "ref" returns original ref.
+ my( $opt, $meth, @old );
+ while( @_ ) {
+ $opt= shift(@_);
+ $meth= $_opt_subs{$opt};
+ if( ! @_ ) {
+ croak "${PACK}->SetOptions: Option value missing ",
+ "after option name ($opt)";
+ } elsif( defined $meth ) {
+ push( @old, $self->$meth( shift(@_) ) );
+ } elsif( $opt eq substr("reference",0,length($opt)) ) {
+ shift(@_) if @_;
+ push( @old, $self );
+ } else {
+ croak "${PACK}->SetOptions: Invalid option ($opt) ",
+ "not one of ( @_opt_subs )";
+ }
+ }
+ return wantarray ? @old : $old[-1];
+}
+
+
+sub _parseTiedEnt
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $ent= shift(@_);
+ my $delim= shift(@_);
+ my $dlen= length( $delim );
+ my $parent= @_ ? shift(@_) : 0;
+ my $off;
+ if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) {
+ if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) {
+ return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) );
+ } elsif( $delim eq substr($ent,-$dlen) ) {
+ return( substr($ent,0,-$dlen) );
+ } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) {
+ return( substr( $ent, 0, $off ),
+ undef, substr( $ent, $dlen+$off ) );
+ } elsif( $parent ) {
+ return();
+ } else {
+ return( $ent );
+ }
+ } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) {
+ return( undef, substr($ent,$dlen) );
+ } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) {
+ return( substr($ent,0,-$dlen) );
+ } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) {
+ return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) );
+ } elsif( $delim eq substr($ent,-$dlen) ) {
+ if( $parent
+ && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) {
+ return( substr($ent,0,$off),
+ undef, undef, substr($ent,$dlen+$off,-$dlen) );
+ } else {
+ return( substr($ent,0,-$dlen) );
+ }
+ } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) {
+ return(
+ substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) );
+ } else {
+ return( undef, undef, $ent );
+ }
+}
+
+
+sub _FetchValue
+{
+ my $self= shift( @_ );
+ my( $val, $createKey )= @_;
+ my( $data, $type );
+ if( ( $data, $type )= $self->GetValue( $val ) ) {
+ return $self->ArrayValues ? [ $data, $type ]
+ : wantarray ? ( $data, $type )
+ : $data;
+ } elsif( $createKey and $data= $self->new($val) ) {
+ return $data->TiedRef;
+ } else {
+ return ();
+ }
+}
+
+
+sub FETCH
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 );
+ my $sub;
+ if( defined($key) ) {
+ if( defined($self->{MEMBHASH})
+ && $self->{MEMBHASH}->{$key.$delim}
+ && 0 <= index($key,$delim) ) {
+ return ()
+ unless $sub= $self->new( $key,
+ {"Delimiter"=>$self->OS_Delimiter} );
+ $sub->Delimiter($delim);
+ } else {
+ return ()
+ unless $sub= $self->new( $key );
+ }
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ return $sub->_FetchValue( $val );
+ } elsif( ! defined($ambig) ) {
+ return $sub->TiedRef;
+ } elsif( defined($key) ) {
+ return $sub->FETCH( $ambig );
+ } else {
+ return $sub->_FetchValue( $ambig, "" ne $ambig );
+ }
+}
+
+
+sub _FetchOld
+{
+ my( $self, $key )= @_;
+ my $old= $self->FETCH($key);
+ if( $old ) {
+ my $copy= {};
+ %$copy= %$old;
+ return $copy;
+ }
+ # return $^E;
+ return _Err;
+}
+
+
+sub DELETE
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
+ my $sub;
+ my $fast= defined(wantarray) ? $self->FastDelete : 2;
+ my $old= 1; # Value returned if FastDelete is set.
+ if( defined($key)
+ && ( defined($val) || defined($ambig) || defined($subkey) ) ) {
+ return ()
+ unless $sub= $self->new( $key );
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ $old= $sub->GetValue($val) || _Err unless 2 <= $fast;
+ $sub->RegDeleteValue( $val );
+ } elsif( defined($subkey) ) {
+ $old= $sub->_FetchOld( $subkey.$delim ) unless $fast;
+ $sub->RegDeleteKey( $subkey );
+ } elsif( defined($ambig) ) {
+ if( defined($key) ) {
+ $old= $sub->DELETE($ambig);
+ } else {
+ $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast;
+ if( defined( $old ) ) {
+ $sub->RegDeleteValue( $ambig );
+ } else {
+ $old= $sub->_FetchOld( $ambig.$delim ) unless $fast;
+ $sub->RegDeleteKey( $ambig );
+ }
+ }
+ } elsif( defined($key) ) {
+ $old= $sub->_FetchOld( $key.$delim ) unless $fast;
+ $sub->RegDeleteKey( $key );
+ } else {
+ croak "${PACK}->DELETE: Key ($ent) can never be deleted";
+ }
+ return $old;
+}
+
+
+sub SetValue
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $name= shift(@_);
+ my $data= shift(@_);
+ my( $type )= @_;
+ my $size;
+ if( ! defined($type) ) {
+ if( "ARRAY" eq ref($data) ) {
+ croak "${PACK}->SetValue: Value is array reference but ",
+ "no data type given"
+ unless 2 == @$data;
+ ( $data, $type )= @$data;
+ } else {
+ $type= REG_SZ;
+ }
+ }
+ $type= _constant($type,"registry value data type") if $type =~ /^REG_/;
+ if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) {
+ $data= join( "\0", @$data ) . "\0\0";
+ ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) );
+ } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type )
+ && $self->FixSzNulls ) {
+ $data .= "\0" unless "\0" eq substr($data,0,-1);
+ } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) {
+ $data= pack( "L", hex($data) );
+ # We could to $data=pack("L",$data) for REG_DWORD but I see
+ # no nice way to always destinguish when to do this or not.
+ }
+ return $self->RegSetValueEx( $name, 0, $type, $data, length($data) );
+}
+
+
+sub StoreKey
+{
+ my $this= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $subKey= shift(@_);
+ my $data= shift(@_);
+ my $ent;
+ my $self;
+ if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) {
+ croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n",
+ " subkey data must be a HASH reference";
+ }
+ if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) {
+ $self= $this->CreateKey( $subKey, delete $$data{""} );
+ } else {
+ $self= $this->CreateKey( $subKey );
+ }
+ return () if ! defined($self);
+ foreach $ent ( keys(%$data) ) {
+ return ()
+ unless $self->STORE( $ent, $$data{$ent} );
+ }
+ return $self;
+}
+
+
+# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key
+# = "string" creates a new REG_SZ value
+# = [ data, type ] creates a new value
+sub STORE
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $data= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
+ my $sub;
+ if( defined($key)
+ && ( defined($val) || defined($ambig) || defined($subkey) ) ) {
+ return ()
+ unless $sub= $self->new( $key );
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n",
+ " value data cannot be a HASH reference"
+ if ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->SetValue( $val, $data );
+ } elsif( defined($subkey) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n",
+ " subkey data must be a HASH reference"
+ unless ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->StoreKey( $subkey, $data );
+ } elsif( defined($ambig) ) {
+ if( ref($data) && "$data" =~ /(^|=)HASH/ ) {
+ $sub->StoreKey( $ambig, $data );
+ } else {
+ $sub->SetValue( $ambig, $data );
+ }
+ } elsif( defined($key) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n",
+ " subkey data must be a HASH reference"
+ unless ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->StoreKey( $key, $data );
+ } else {
+ croak "${PACK}->STORE: Key ($ent) can never be created nor set";
+ }
+}
+
+
+sub EXISTS
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ return defined( $self->FETCH($ent) );
+}
+
+
+sub FIRSTKEY
+{
+ my $self= shift(@_);
+ my $members= $self->_MemberNames;
+ $self->{PREVIDX}= 0;
+ return @{$members} ? $members->[0] : undef;
+}
+
+
+sub NEXTKEY
+{
+ my $self= shift(@_);
+ my $prev= shift(@_);
+ my $idx= $self->{PREVIDX};
+ my $members= $self->_MemberNames;
+ if( ! defined($idx) || $prev ne $members->[$idx] ) {
+ $idx= 0;
+ while( $idx < @$members && $prev ne $members->[$idx] ) {
+ $idx++;
+ }
+ }
+ $self->{PREVIDX}= ++$idx;
+ return $members->[$idx];
+}
+
+
+sub DESTROY
+{
+ my $self= shift(@_);
+ return if tied(%$self);
+ my $unload;
+ eval { $unload= $self->{UNLOADME}; 1 }
+ or return;
+ my $debug= $ENV{DEBUG_TIE_REGISTRY};
+ if( defined($debug) ) {
+ if( 1 < $debug ) {
+ my $hand= $self->Handle;
+ my $dep= $self->{DEPENDON};
+ carp "${PACK} destroying ", $self->Path, " (",
+ "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")",
+ defined($dep) ? (" [depends on ",$dep->Path,"]") : ();
+ } else {
+ warn "${PACK} destroying ", $self->Path, ".\n";
+ }
+ }
+ $self->RegCloseKey
+ unless "NONE" eq $self->Handle;
+ if( defined($unload) ) {
+ if( defined($debug) && 1 < $debug ) {
+ my( $obj, $subKey, $file )= @$unload;
+ warn "Unloading ", $self->Path,
+ " (from ", $obj->Path, ", $subKey)...\n";
+ }
+ $self->UnLoad
+ || warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n";
+ ## carp "Never unloaded ${PACK}::Load($$unload[2])";
+ }
+ #delete $self->{DEPENDON};
+}
+
+
+use vars qw( @CreateKey_Opts %CreateKey_Opts %_KeyDispNames );
+@CreateKey_Opts= qw( Access Class Options Delimiter
+ Disposition Security Volatile Backup );
+@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts;
+%_KeyDispNames= ( REG_CREATED_NEW_KEY() => "REG_CREATED_NEW_KEY",
+ REG_OPENED_EXISTING_KEY() => "REG_OPENED_EXISTING_KEY" );
+
+sub CreateKey
+{
+ my $self= shift(@_);
+ my $tied= tied(%$self);
+ $self= tied(%$self) if $tied;
+ my( $subKey, $opts )= @_;
+ my( $sam )= $self->Access;
+ my( $delim )= $self->Delimiter;
+ my( $class )= "";
+ my( $flags )= 0;
+ my( $secure )= [];
+ my( $garb )= [];
+ my( $result )= \$garb;
+ my( $handle )= 0;
+ if( @_ < 1 || 2 < @_
+ || 2 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n",
+ " options: @CreateKey_Opts\nCalled";
+ }
+ if( defined($opts) ) {
+ $sam= $opts->{"Access"} if defined($opts->{"Access"});
+ $class= $opts->{Class} if defined($opts->{Class});
+ $flags= $opts->{Options} if defined($opts->{Options});
+ $delim= $opts->{"Delimiter"} if defined($opts->{"Delimiter"});
+ $secure= $opts->{Security} if defined($opts->{Security});
+ if( defined($opts->{Disposition}) ) {
+ "SCALAR" eq ref($opts->{Disposition})
+ or croak "${PACK}->CreateKey option `Disposition'",
+ " must provide a scalar reference";
+ $result= $opts->{Disposition};
+ }
+ if( 0 == $flags ) {
+ $flags |= REG_OPTION_VOLATILE
+ if defined($opts->{Volatile}) && $opts->{Volatile};
+ $flags |= REG_OPTION_BACKUP_RESTORE
+ if defined($opts->{Backup}) && $opts->{Backup};
+ }
+ }
+ my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim);
+ $subKey= join( $self->OS_Delimiter, @$subPath );
+ $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam,
+ $secure, $handle, $$result )
+ or return ();
+ if( ! ref($$result) && $self->DualTypes ) {
+ $$result= _DualVal( \%_KeyDispNames, $$result );
+ }
+ my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] );
+ $new->{ACCESS}= $sam;
+ $new->{DELIM}= $delim;
+ $new= $new->TiedRef if $tied;
+ return $new;
+}
+
+
+use vars qw( $Load_Cnt @Load_Opts %Load_Opts );
+$Load_Cnt= 0;
+@Load_Opts= qw(NewSubKey);
+@Load_Opts{@Load_Opts}= (1) x @Load_Opts;
+
+sub Load
+{
+ my $this= shift(@_);
+ my $tied= ref($this) && tied(%$this);
+ $this= tied(%$this) if $tied;
+ my( $file, $subKey, $opts )= @_;
+ if( 2 == @_ && "HASH" eq ref($subKey) ) {
+ $opts= $subKey;
+ undef $subKey;
+ }
+ @_ < 1 || 3 < @_ || defined($opts) && "HASH" ne ref($opts)
+ and croak "Usage: \$key= ",
+ "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n",
+ " options: @Load_Opts @new_Opts\nCalled";
+ if( defined($opts) && exists($opts->{NewSubKey}) ) {
+ $subKey= delete $opts->{NewSubKey};
+ }
+ if( ! defined( $subKey ) ) {
+ if( "" ne $this->Machine ) {
+ ( $this )= $this->_connect( [$this->Machine,"LMachine"] );
+ } else {
+ ( $this )= $this->_rootKey( "LMachine" ); # Could also be "Users"
+ }
+ $subKey= "PerlTie:$$." . ++$Load_Cnt;
+ }
+ $this->RegLoadKey( $subKey, $file )
+ or return ();
+ my $self= $this->new( $subKey, defined($opts) ? $opts : () );
+ if( ! defined( $self ) ) {
+ { my $err= Win32::GetLastError();
+ #{ local( $^E ); #}
+ $this->RegUnLoadKey( $subKey ) or carp
+ "Can't unload $subKey from ", $this->Path, ": ", _ErrMsg, "\n";
+ Win32::SetLastError($err);
+ }
+ return ();
+ }
+ $self->{UNLOADME}= [ $this, $subKey, $file ];
+ $self= $self->TiedRef if $tied;
+ return $self;
+}
+
+
+sub UnLoad
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$key->UnLoad;";
+ my $unload= $self->{UNLOADME};
+ "ARRAY" eq ref($unload)
+ or croak "${PACK}->UnLoad called on a key which was not Load()ed";
+ my( $obj, $subKey, $file )= @$unload;
+ $self->RegCloseKey;
+ return Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey );
+}
+
+
+sub AllowSave
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self->AllowPriv( "SeBackupPrivilege", @_ );
+}
+
+
+sub AllowLoad
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self->AllowPriv( "SeRestorePrivilege", @_ );
+}
+
+
+# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync )
+
+
+sub RegCloseKey { my $self= shift(@_);
+ Win32API::Registry::RegCloseKey $self->Handle, @_; }
+sub RegConnectRegistry { my $self= shift(@_);
+ Win32API::Registry::RegConnectRegistry @_; }
+sub RegCreateKey { my $self= shift(@_);
+ Win32API::Registry::RegCreateKey $self->Handle, @_; }
+sub RegCreateKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegCreateKeyEx $self->Handle, @_; }
+sub RegDeleteKey { my $self= shift(@_);
+ Win32API::Registry::RegDeleteKey $self->Handle, @_; }
+sub RegDeleteValue { my $self= shift(@_);
+ Win32API::Registry::RegDeleteValue $self->Handle, @_; }
+sub RegEnumKey { my $self= shift(@_);
+ Win32API::Registry::RegEnumKey $self->Handle, @_; }
+sub RegEnumKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegEnumKeyEx $self->Handle, @_; }
+sub RegEnumValue { my $self= shift(@_);
+ Win32API::Registry::RegEnumValue $self->Handle, @_; }
+sub RegFlushKey { my $self= shift(@_);
+ Win32API::Registry::RegFlushKey $self->Handle, @_; }
+sub RegGetKeySecurity { my $self= shift(@_);
+ Win32API::Registry::RegGetKeySecurity $self->Handle, @_; }
+sub RegLoadKey { my $self= shift(@_);
+ Win32API::Registry::RegLoadKey $self->Handle, @_; }
+sub RegNotifyChangeKeyValue { my $self= shift(@_);
+ Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; }
+sub RegOpenKey { my $self= shift(@_);
+ Win32API::Registry::RegOpenKey $self->Handle, @_; }
+sub RegOpenKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegOpenKeyEx $self->Handle, @_; }
+sub RegQueryInfoKey { my $self= shift(@_);
+ Win32API::Registry::RegQueryInfoKey $self->Handle, @_; }
+sub RegQueryMultipleValues { my $self= shift(@_);
+ Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; }
+sub RegQueryValue { my $self= shift(@_);
+ Win32API::Registry::RegQueryValue $self->Handle, @_; }
+sub RegQueryValueEx { my $self= shift(@_);
+ Win32API::Registry::RegQueryValueEx $self->Handle, @_; }
+sub RegReplaceKey { my $self= shift(@_);
+ Win32API::Registry::RegReplaceKey $self->Handle, @_; }
+sub RegRestoreKey { my $self= shift(@_);
+ Win32API::Registry::RegRestoreKey $self->Handle, @_; }
+sub RegSaveKey { my $self= shift(@_);
+ Win32API::Registry::RegSaveKey $self->Handle, @_; }
+sub RegSetKeySecurity { my $self= shift(@_);
+ Win32API::Registry::RegSetKeySecurity $self->Handle, @_; }
+sub RegSetValue { my $self= shift(@_);
+ Win32API::Registry::RegSetValue $self->Handle, @_; }
+sub RegSetValueEx { my $self= shift(@_);
+ Win32API::Registry::RegSetValueEx $self->Handle, @_; }
+sub RegUnLoadKey { my $self= shift(@_);
+ Win32API::Registry::RegUnLoadKey $self->Handle, @_; }
+sub AllowPriv { my $self= shift(@_);
+ Win32API::Registry::AllowPriv @_; }
+
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Win32::TieRegistry - Manipulate the Win32 Registry
+
+=head1 SYNOPSIS
+
+ use Win32::TieRegistry 0.20 ( UseOptionName=>UseOptionValue[,...] );
+
+ $Registry->SomeMethodCall(arg1,...);
+
+ $subKey= $Registry->{"Key\\SubKey\\"};
+ $valueData= $Registry->{"Key\\SubKey\\\\ValueName"};
+ $Registry->{"Key\\SubKey\\"}= { "NewSubKey" => {...} };
+ $Registry->{"Key\\SubKey\\\\ValueName"}= "NewValueData";
+ $Registry->{"\\ValueName"}= [ pack("fmt",$data), REG_DATATYPE ];
+
+=head1 EXAMPLES
+
+ use Win32::TieRegistry( Delimiter=>"#", ArrayValues=>0 );
+ $pound= $Registry->Delimiter("/");
+ $diskKey= $Registry->{"LMachine/System/Disk/"}
+ or die "Can't read LMachine/System/Disk key: $^E\n";
+ $data= $key->{"/Information"}
+ or die "Can't read LMachine/System/Disk//Information value: $^E\n";
+ $remoteKey= $Registry->{"//ServerA/LMachine/System/"}
+ or die "Can't read //ServerA/LMachine/System/ key: $^E\n";
+ $remoteData= $remoteKey->{"Disk//Information"}
+ or die "Can't read ServerA's System/Disk//Information value: $^E\n";
+ foreach $entry ( keys(%$diskKey) ) {
+ ...
+ }
+ foreach $subKey ( $diskKey->SubKeyNames ) {
+ ...
+ }
+ $diskKey->AllowSave( 1 );
+ $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] );
+
+=head1 DESCRIPTION
+
+The I<Win32::TieRegistry> module lets you manipulate the Registry
+via objects [as in "object oriented"] or via tied hashes. But
+you will probably mostly use a combination reference, that is, a
+reference to a tied hash that has also been made an object so that
+you can mix both access methods [as shown above].
+
+If you did not get this module as part of L<libwin32>, you might
+want to get a recent version of L<libwin32> from CPAN which should
+include this module and the I<Win32API::Registry> module that it
+uses.
+
+Skip to the L<SUMMARY> section if you just want to dive in and start
+using the Registry from Perl.
+
+Accessing and manipulating the registry is extremely simple using
+I<Win32::TieRegistry>. A single, simple expression can return
+you almost any bit of information stored in the Registry.
+I<Win32::TieRegistry> also gives you full access to the "raw"
+underlying API calls so that you can do anything with the Registry
+in Perl that you could do in C. But the "simple" interface has
+been carefully designed to handle almost all operations itself
+without imposing arbitrary limits while providing sensible
+defaults so you can list only the parameters you care about.
+
+But first, an overview of the Registry itself.
+
+=head2 The Registry
+
+The Registry is a forest: a collection of several tree structures.
+The root of each tree is a key. These root keys are identified by
+predefined constants whose names start with "HKEY_". Although all
+keys have a few attributes associated with each [a class, a time
+stamp, and security information], the most important aspect of keys
+is that each can contain subkeys and can contain values.
+
+Each subkey has a name: a string which cannot be blank and cannot
+contain the delimiter character [backslash: C<'\\'>] nor nul
+[C<'\0'>]. Each subkey is also a key and so can contain subkeys
+and values [and has a class, time stamp, and security information].
+
+Each value has a name: a string which B<can> be blank and B<can>
+contain the delimiter character [backslash: C<'\\'>] and any
+character except for null, C<'\0'>. Each value also has data
+associated with it. Each value's data is a contiguous chunk of
+bytes, which is exactly what a Perl string value is so Perl
+strings will usually be used to represent value data.
+
+Each value also has a data type which says how to interpret the
+value data. The primary data types are:
+
+=over
+
+=item REG_SZ
+
+A null-terminated string.
+
+=item REG_EXPAND_SZ
+
+A null-terminated string which contains substrings consisting of a
+percent sign [C<'%'>], an environment variable name, then a percent
+sign, that should be replaced with the value associate with that
+environment variable. The system does I<not> automatically do this
+substitution.
+
+=item REG_BINARY
+
+Some arbitrary binary value. You can think of these as being
+"packed" into a string.
+
+If your system has the L<SetDualVar> module installed,
+the C<DualBinVals()> option wasn't turned off, and you
+fetch a C<REG_BINARY> value of 4 bytes or fewer, then
+you can use the returned value in a numeric context to
+get at the "unpacked" numeric value. See C<GetValue()>
+for more information.
+
+=item REG_MULTI_SZ
+
+Several null-terminated strings concatenated together with an
+extra trailing C<'\0'> at the end of the list. Note that the list
+can include empty strings so use the value's length to determine
+the end of the list, not the first occurrence of C<'\0\0'>.
+It is best to set the C<SplitMultis()> option so I<Win32::TieRegistry>
+will split these values into an array of strings for you.
+
+=item REG_DWORD
+
+A long [4-byte] integer value. These values are expected either
+packed into a 4-character string or as a hex string of B<more than>
+4 characters [but I<not> as a numeric value, unfortunately, as there is
+no sure way to tell a numeric value from a packed 4-byte string that
+just happens to be a string containing a valid numeric value].
+
+How such values are returned depends on the C<DualBinVals()> and
+C<DWordsToHex()> options. See C<GetValue()> for details.
+
+=back
+
+In the underlying Registry calls, most places which take a
+subkey name also allow you to pass in a subkey "path" -- a
+string of several subkey names separated by the delimiter
+character, backslash [C<'\\'>]. For example, doing
+C<RegOpenKeyEx(HKEY_LOCAL_MACHINE,"SYSTEM\\DISK",...)> is much
+like opening the C<"SYSTEM"> subkey of C<HKEY_LOCAL_MACHINE>,
+then opening its C<"DISK"> subkey, then closing the C<"SYSTEM">
+subkey.
+
+All of the I<Win32::TieRegistry> features allow you to use your
+own delimiter in place of the system's delimiter, [C<'\\'>]. In
+most of our examples we will use a forward slash [C<'/'>] as our
+delimiter as it is easier to read and less error prone to use when
+writing Perl code since you have to type two backslashes for each
+backslash you want in a string. Note that this is true even when
+using single quotes -- C<'\\HostName\LMachine\'> is an invalid
+string and must be written as C<'\\\\HostName\\LMachine\\'>.
+
+You can also connect to the registry of other computers on your
+network. This will be discussed more later.
+
+Although the Registry does not have a single root key, the
+I<Win32::TieRegistry> module creates a virtual root key for you
+which has all of the I<HKEY_*> keys as subkeys.
+
+=head2 Tied Hashes Documentation
+
+Before you can use a tied hash, you must create one. One way to
+do that is via:
+
+ use Win32::TieRegistry ( TiedHash => '%RegHash' );
+
+which exports a C<%RegHash> variable into your package and ties it
+to the virtual root key of the Registry. An alternate method is:
+
+ my %RegHash;
+ use Win32::TieRegistry ( TiedHash => \%RegHash );
+
+There are also several ways you can tie a hash variable to any
+other key of the Registry, which are discussed later.
+
+Note that you will most likely use C<$Registry> instead of using
+a tied hash. C<$Registry> is a reference to a hash that has
+been tied to the virtual root of your computer's Registry [as if,
+C<$Registry= \%RegHash>]. So you would use C<$Registry-E<gt>{Key}>
+rather than C<$RegHash{Key}> and use C<keys %{$Registry}> rather
+than C<keys %RegHash>, for example.
+
+For each hash which has been tied to a Registry key, the Perl
+C<keys> function will return a list containing the name of each
+of the key's subkeys with a delimiter character appended to it and
+containing the name of each of the key's values with a delimiter
+prepended to it. For example:
+
+ keys( %{ $Registry->{"HKEY_CLASSES_ROOT\\batfile\\"} } )
+
+might yield the following list value:
+
+ ( "DefaultIcon\\", # The subkey named "DefaultIcon"
+ "shell\\", # The subkey named "shell"
+ "shellex\\", # The subkey named "shellex"
+ "\\", # The default value [named ""]
+ "\\EditFlags" ) # The value named "EditFlags"
+
+For the virtual root key, short-hand subkey names are used as
+shown below. You can use the short-hand name, the regular
+I<HKEY_*> name, or any numeric value to access these keys, but
+the short-hand names are all that will be returned by the C<keys>
+function.
+
+=over
+
+=item "Classes" for HKEY_CLASSES_ROOT
+
+Contains mappings between file name extensions and the uses
+for such files along with configuration information for COM
+[MicroSoft's Common Object Model] objects. Usually a link to
+the C<"SOFTWARE\\Classes"> subkey of the C<HKEY_LOCAL_MACHINE>
+key.
+
+=item "CUser" for HKEY_CURRENT_USER
+
+Contains information specific to the currently logged-in user.
+Mostly software configuration information. Usually a link to
+a subkey of the C<HKEY_USERS> key.
+
+=item "LMachine" for HKEY_LOCAL_MACHINE
+
+Contains all manner of information about the computer.
+
+=item "Users" for HKEY_USERS
+
+Contains one subkey, C<".DEFAULT">, which gets copied to a new
+subkey whenever a new user is added. Also contains a subkey for
+each user of the system, though only those for active users
+[usually only one] are loaded at any given time.
+
+=item "PerfData" for HKEY_PERFORMANCE_DATA
+
+Used to access data about system performance. Access via this key
+is "special" and all but the most carefully constructed calls will
+fail, usually with C<ERROR_INSUFFICIENT_BUFFER>. For example, you
+can't enumerate key names without also enumerating values which
+require huge buffers but the exact buffer size required cannot be
+determined beforehand because C<RegQueryInfoKey()> B<always> fails
+with C<ERROR_INSUFFICIENT_BUFFER> for C<HKEY_PERFORMANCE_DATA> no
+matter how it is called. So it is currently not very useful to
+tie a hash to this key. You can use it to create an object to use
+for making carefully constructed calls to the underlying Reg*()
+routines.
+
+=item "CConfig" for HKEY_CURRENT_CONFIG
+
+Contains minimal information about the computer's current
+configuration that is required very early in the boot process.
+For example, setting for the display adapter such as screen
+resolution and refresh rate are found in here.
+
+=item "DynData" for HKEY_DYN_DATA
+
+Dynamic data. We have found no documentation for this key.
+
+=back
+
+A tied hash is much like a regular hash variable in Perl -- you give
+it a key string inside braces, [C<{> and C<}>], and it gives you
+back a value [or lets you set a value]. For I<Win32::TieRegistry>
+hashes, there are two types of values that will be returned.
+
+=over
+
+=item SubKeys
+
+If you give it a string which represents a subkey, then it will
+give you back a reference to a hash which has been tied to that
+subkey. It can't return the hash itself, so it returns a
+reference to it. It also blesses that reference so that it is
+also an object so you can use it to call method functions.
+
+=item Values
+
+If you give it a string which is a value name, then it will give
+you back a string which is the data for that value. Alternately,
+you can request that it give you both the data value string and
+the data value type [we discuss how to request this later]. In
+this case, it would return a reference to an array where the value
+data string is element C<[0]> and the value data type is element
+C<[1]>.
+
+=back
+
+The key string which you use in the tied hash must be interpreted
+to determine whether it is a value name or a key name or a path
+that combines several of these or even other things. There are
+two simple rules that make this interpretation easy and
+unambiguous:
+
+ Put a delimiter after each key name.
+ Put a delimiter in front of each value name.
+
+Exactly how the key string will be intepreted is governed by the
+following cases, in the order listed. These cases are designed
+to "do what you mean". Most of the time you won't have to think
+about them, especially if you follow the two simple rules above.
+After the list of cases we give several examples which should be
+clear enough so feel free to skip to them unless you are worried
+about the details.
+
+=over
+
+=item Remote machines
+
+If the hash is tied to the virtual root of the registry [or the
+virtual root of a remote machine's registry], then we treat hash
+key strings which start with the delimiter character specially.
+
+If the hash key string starts with two delimiters in a row, then
+those should be immediately followed by the name of a remote
+machine whose registry we wish to connect to. That can be
+followed by a delimiter and more subkey names, etc. If the
+machine name is not following by anything, then a virtual root
+for the remote machine's registry is created, a hash is tied to
+it, and a reference to that hash it is returned.
+
+=item Hash key string starts with the delimiter
+
+If the hash is tied to a virtual root key, then the leading
+delimiter is ignored. It should be followed by a valid Registry
+root key name [either a short-hand name like C<"LMachine">, an
+I<HKEY_*> value, or a numeric value]. This alternate notation is
+allowed in order to be more consistant with the C<Open()> method
+function.
+
+For all other Registry keys, the leading delimiter indicates
+that the rest of the string is a value name. The leading
+delimiter is stripped and the rest of the string [which can
+be empty and can contain more delimiters] is used as a value
+name with no further parsing.
+
+=item Exact match with direct subkey name followed by delimiter
+
+If you have already called the Perl C<keys> function on the tied
+hash [or have already called C<MemberNames> on the object] and the
+hash key string exactly matches one of the strings returned, then
+no further parsing is done. In other words, if the key string
+exactly matches the name of a direct subkey with a delimiter
+appended, then a reference to a hash tied to that subkey is
+returned [but only if C<keys> or C<MemberNames> has already
+been called for that tied hash].
+
+This is only important if you have selected a delimiter other than
+the system default delimiter and one of the subkey names contains
+the delimiter you have chosen. This rule allows you to deal with
+subkeys which contain your chosen delimiter in their name as long
+as you only traverse subkeys one level at a time and always
+enumerate the list of members before doing so.
+
+The main advantage of this is that Perl code which recursively
+traverses a hash will work on hashes tied to Registry keys even if
+a non-default delimiter has been selected.
+
+=item Hash key string contains two delimiters in a row
+
+If the hash key string contains two [or more] delimiters in a row,
+then the string is split between the first pair of delimiters.
+The first part is interpreted as a subkey name or a path of subkey
+names separated by delimiters and with a trailing delimiter. The
+second part is interpreted as a value name with one leading
+delimiter [any extra delimiters are considered part of the value
+name].
+
+=item Hash key string ends with a delimiter
+
+If the key string ends with a delimiter, then it is treated
+as a subkey name or path of subkey names separated by delimiters.
+
+=item Hash key string contains a delimiter
+
+If the key string contains a delimiter, then it is split after
+the last delimiter. The first part is treated as a subkey name or
+path of subkey names separated by delimiters. The second part
+is ambiguous and is treated as outlined in the next item.
+
+=item Hash key string contains no delimiters
+
+If the hash key string contains no delimiters, then it is ambiguous.
+
+If you are reading from the hash [fetching], then we first use the
+key string as a value name. If there is a value with a matching
+name in the Registry key which the hash is tied to, then the value
+data string [and possibly the value data type] is returned.
+Otherwise, we retry by using the hash key string as a subkey name.
+If there is a subkey with a matching name, then we return a
+reference to a hash tied to that subkey. Otherwise we return
+C<undef>.
+
+If you are writing to the hash [storing], then we use the key
+string as a subkey name only if the value you are storing is a
+reference to a hash value. Otherwise we use the key string as
+a value name.
+
+=back
+
+=head3 Examples
+
+Here are some examples showing different ways of accessing Registry
+information using references to tied hashes:
+
+=over
+
+=item Canonical value fetch
+
+ $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\"
+ . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'};
+
+Should return the text of important tip number 18. Note that two
+backslashes, C<"\\">, are required to get a single backslash into
+a Perl double-quoted or single-qouted string. Note that C<"\\">
+is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through
+C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">.
+
+=item Changing your delimiter
+
+ $Registry->Delimiter("/");
+ $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/"
+ . 'Windows/CurrentVersion/Explorer/Tips//18'};
+
+This usually makes things easier to read when working in Perl.
+All remaining examples will assume the delimiter has been changed
+as above.
+
+=item Using intermediate keys
+
+ $ms= $Registry->{"LMachine/Software/Microsoft/"};
+ $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"};
+ $tip18= $winlogon->{"/18"};
+
+Same as above but opens more keys into the Registry which lets you
+efficiently re-access those intermediate keys. This is slightly
+less efficient if you never reuse those intermediate keys.
+
+=item Chaining in a single statement
+
+ $tip18= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"};
+
+Like above, this creates intermediate key objects then uses
+them to access other data. Once this statement finishes, the
+intermediate key objects are destroyed. Several handles into
+the Registry are opened and closed by this statement so it is
+less efficient but there are times when this will be useful.
+
+=item Even less efficient example of chaining
+
+ $tip18= $Registry->{"LMachine/Software/Microsoft"}->
+ {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"};
+
+Because we left off the trailing delimiters, I<Win32::TieRegistry>
+doesn't know whether final names, C<"Microsoft"> and C<"Tips">,
+are subkey names or value names. So this statement ends up
+executing the same code as the next one.
+
+=item What the above really does
+
+ $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}->
+ {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"};
+
+With more chains to go through, more temporary objects are created
+and later destroyed than in our first chaining example. Also,
+when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first
+tries to open it as a value and fails then tries it as a subkey.
+The same is true for when it looks up C<"Tips">.
+
+=item Getting all of the tips
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ foreach( keys %$tips ) {
+ print "$_: ", $tips->{$_}, "\n";
+ }
+
+First notice that we actually check for failure for the first
+time. We are assuming that the C<"Tips"> key contains no subkeys.
+Otherwise the C<print> statement would show something like
+C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey.
+
+The output from the above code will start something like:
+
+ /0: If you don't know how to do something,[...]
+
+=back
+
+=head3 Deleting items
+
+You can use the Perl C<delete> function to delete a value from a
+Registry key or to delete a subkey as long that subkey contains
+no subkeys of its own. See L<More Examples>, below, for more
+information.
+
+=head3 Storing items
+
+You can use the Perl assignment operator [C<=>] to create new
+keys, create new values, or replace values. The values you store
+should be in the same format as the values you would fetch from a
+tied hash. For example, you can use a single assignment statement
+to copy an entire Registry tree. The following statement:
+
+ $Registry->{"LMachine/Software/Classes/Tie_Registry/"}=
+ $Registry->{"LMachine/Software/Classes/batfile/"};
+
+creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes">
+subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it
+with copies of all of the subkeys and values in the C<"batfile">
+subkey and all of its subkeys. Note that you need to have
+called C<$Registry-E<gt>ArrayValues(1)> for the proper value data
+type information to be copied. Note also that this release of
+I<Win32::TieRegistry> does not copy key attributes such as class
+name and security information [this is planned for a future release].
+
+The following statement creates a whole subtree in the Registry:
+
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Version" => "4.032",
+ "Startup/" => {
+ "/Title" => "Foo Writer Deluxe ][",
+ "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ],
+ "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ],
+ },
+ "Compatibility/" => {
+ "/AutoConvert" => "Always",
+ "/Default Palette" => "Windows Colors",
+ },
+ },
+ "/License", => "0123-9C8EF1-09-FC",
+ };
+
+Note that all but the last Registry key used on the left-hand
+side of the assignment [that is, "LMachine/Software/" but not
+"FooCorp/"] must already exist for this statement to succeed.
+
+By using the leading a trailing delimiters on each subkey name and
+value name, I<Win32::TieRegistry> will tell you if you try to assign
+subkey information to a value or visa-versa.
+
+=head3 More examples
+
+=over
+
+=item Adding a new tip
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ $tips{'/186'}= "Be very careful when making changes to the Registry!";
+
+=item Deleting our new tip
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ $tip186= delete $tips{'/186'};
+
+Note that Perl's C<delete> function returns the value that was deleted.
+
+=item Adding a new tip differently
+
+ $Registry->{"LMachine/Software/Microsoft/" .
+ "Windows/CurrentVersion/Explorer/Tips//186"}=
+ "Be very careful when making changes to the Registry!";
+
+=item Deleting differently
+
+ $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips//186"};
+
+Note that this only deletes the tail of what we looked up, the
+C<"186"> value, not any of the keys listed.
+
+=item Deleting a key
+
+WARNING: The following code will delete all information about the
+current user's tip preferences. Actually executing this command
+would probably cause the user to see the Welcome screen the next
+time they log in and may cause more serious problems. This
+statement is shown as an example only and should not be used when
+experimenting.
+
+ $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"};
+
+This deletes the C<"Tips"> key and the values it contains. The
+C<delete> function will return a reference to a hash [not a tied
+hash] containing the value names and value data that were deleted.
+
+The information to be returned is copied from the Registry into a
+regular Perl hash before the key is deleted. If the key has many
+subkeys, this copying could take a significant amount of memory
+and/or processor time. So you can disable this process by calling
+the C<FastDelete> member function:
+
+ $prevSetting= $regKey->FastDelete(1);
+
+which will cause all subsequent delete operations via C<$regKey>
+to simply return a true value if they succeed. This optimization
+is automatically done if you use C<delete> in a void context.
+
+=item Technical notes on deleting
+
+If you use C<delete> to delete a Registry key or value and use
+the return value, then I<Win32::TieRegistry> usually looks up the
+current contents of that key or value so they can be returned if
+the deletion is successful. If the deletion succeeds but the
+attempt to lookup the old contents failed, then the return value
+of C<delete> will be C<$^E> from the failed part of the operation.
+
+=item Undeleting a key
+
+ $Registry->{"LMachine/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"}= $tips;
+
+This adds back what we just deleted. Note that this version of
+I<Win32::TieRegistry> will use defaults for the key attributes
+[such as class name and security] and will not restore the
+previous attributes.
+
+=item Not deleting a key
+
+WARNING: Actually executing the following code could cause
+serious problems. This statement is shown as an example only and
+should not be used when experimenting.
+
+ $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"}
+ defined($res) || die "Can't delete URL key: $^E\n";
+
+Since the "Windows" key should contain subkeys, that C<delete>
+statement should make no changes to the Registry, return C<undef>,
+and set C<$^E> to "Access is denied".
+
+=item Not deleting again
+
+ $tips= $Registry->{"CUser/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"};
+ delete $tips;
+
+The Perl C<delete> function requires that its argument be an
+expression that ends in a hash element lookup [or hash slice],
+which is not the case here. The C<delete> function doesn't
+know which hash $tips came from and so can't delete it.
+
+=back
+
+=head2 Objects Documentation
+
+The following member functions are defined for use on
+I<Win32::TieRegistry> objects:
+
+=over
+
+=item new
+
+The C<new> method creates a new I<Win32::TieRegistry> object.
+C<new> is mostly a synonym for C<Open()> so see C<Open()> below for
+information on what arguments to pass in. Examples:
+
+ $machKey= new Win32::TieRegistry "LMachine"
+ or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n";
+ $userKey= Win32::TieRegistry->new("CUser")
+ or die "Can't access HKEY_CURRENT_USER key: $^E\n";
+
+Note that calling C<new> via a reference to a tied hash returns
+a simple object, not a reference to a tied hash.
+
+=item Open
+
+=item $subKey= $key->Open( $sSubKey, $rhOptions )
+
+The C<Open> method opens a Registry key and returns a new
+I<Win32::TieRegistry> object associated with that Registry key.
+If C<Open> is called via a reference to a tied hash, then C<Open>
+returns another reference to a tied hash. Otherwise C<Open>
+returns a simple object and you should then use C<TiedRef> to get
+a reference to a tied hash.
+
+C<$sSubKey> is a string specifying a subkey to be opened.
+Alternately C<$sSubKey> can be a reference to an array value
+containing the list of increasingly deep subkeys specifying the
+path to the subkey to be opened.
+
+C<$rhOptions> is an optional reference to a hash containing extra
+options. The C<Open> method supports two options, C<"Delimiter">
+and C<"Access">, and C<$rhOptions> should have only have zero or
+more of these strings as keys. See the "Examples" section below
+for more information.
+
+The C<"Delimiter"> option specifies what string [usually a single
+character] will be used as the delimiter to be appended to subkey
+names and prepended to value names. If this option is not specified,
+the new key [C<$subKey>] inherits the delimiter of the old key
+[C<$key>].
+
+The C<"Access"> option specifies what level of access to the
+Registry key you wish to have once it has been opened. If this
+option is not specified, the new key [C<$subKey>] is opened with
+the same access level used when the old key [C<$key>] was opened.
+The virtual root of the Registry pretends it was opened with
+access C<KEY_READ()|KEY_WRITE()> so this is the default access when
+opening keys directory via C<$Registry>. If you don't plan on
+modifying a key, you should open it with C<KEY_READ> access as
+you may not have C<KEY_WRITE> access to it or some of its subkeys.
+
+If the C<"Access"> option value is a string that starts with
+C<"KEY_">, then it should match B<one> of the predefined access
+levels [probably C<"KEY_READ">, C<"KEY_WRITE">, or
+C<"KEY_ALL_ACCESS">] exported by the I<Win32API::Registry> module.
+Otherwise, a numeric value is expected. For maximum flexibility,
+include C<use Win32::TieRegistry qw(:KEY_);>, for example, near
+the top of your script so you can specify more complicated access
+levels such as C<KEY_READ()|KEY_WRITE()>.
+
+If C<$sSubKey> does not begin with the delimiter [or C<$sSubKey>
+is an array reference], then the path to the subkey to be opened
+will be relative to the path of the original key [C<$key>]. If
+C<$sSubKey> begins with a single delimiter, then the path to the
+subkey to be opened will be relative to the virtual root of the
+Registry on whichever machine the original key resides. If
+C<$sSubKey> begins with two consectutive delimiters, then those
+must be followed by a machine name which causes the C<Connect()>
+method function to be called.
+
+Examples:
+
+ $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} )
+ or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n";
+ $swKey= $machKey->Open( "Software" );
+ $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" );
+ $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] );
+ $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) );
+
+ $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} )
+ or die "Can't connect to HostA or can't open subkey: $^E\n";
+
+=item Clone
+
+=item $copy= $key->Clone
+
+Creates a new object that is associated with the same Registry key
+as the invoking object.
+
+=item Connect
+
+=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions )
+
+The C<Connect> method connects to the Registry of a remote machine,
+and opens a key within it, then returns a new I<Win32::TieRegistry>
+object associated with that remote Registry key. If C<Connect>
+was called using a reference to a tied hash, then the return value
+will also be a reference to a tied hash [or C<undef>]. Otherwise,
+if you wish to use the returned object as a tied hash [not just as
+an object], then use the C<TiedRef> method function after C<Connect>.
+
+C<$sMachineName> is the name of the remote machine. You don't have
+to preceed the machine name with two delimiter characters.
+
+C<$sKeyPath> is a string specifying the remote key to be opened.
+Alternately C<$sKeyPath> can be a reference to an array value
+containing the list of increasingly deep keys specifying the path
+to the key to be opened.
+
+C<$rhOptions> is an optional reference to a hash containing extra
+options. The C<Connect> method supports two options, C<"Delimiter">
+and C<"Access">. See the C<Open> method documentation for more
+information on these options.
+
+C<$sKeyPath> is already relative to the virtual root of the Registry
+of the remote machine. A single leading delimiter on C<sKeyPath>
+will be ignored and is not required.
+
+C<$sKeyPath> can be empty in which case C<Connect> will return an
+object representing the virtual root key of the remote Registry.
+Each subsequent use of C<Open> on this virtual root key will call
+the system C<RegConnectRegistry> function.
+
+The C<Connect> method can be called via any I<Win32::TieRegistry>
+object, not just C<$Registry>. Attributes such as the desired
+level of access and the delimiter will be inherited from the
+object used but the C<$sKeyPath> will always be relative to the
+virtual root of the remote machine's registry.
+
+Examples:
+
+ $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} )
+ or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n";
+
+ $remVersKey= $remMachKey->Connect( "www.microsoft.com",
+ "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/",
+ { Access=>KEY_READ, Delimiter=>"/" } )
+ or die "Can't check what version of IIS Microsoft is running: $^E\n";
+
+ $remVersKey= $remMachKey->Connect( "www",
+ qw(LMachine Software Microsoft Inetsrv CurrentVersion) )
+ or die "Can't check what version of IIS we are running: $^E\n";
+
+=item ObjectRef
+
+=item $object_ref= $obj_or_hash_ref->ObjectRef
+
+For a simple object, just returns itself [C<$obj == $obj->ObjectRef>].
+
+For a reference to a tied hash [if it is also an object], C<ObjectRef>
+returns the simple object that the hash is tied to.
+
+This is primarilly useful when debugging since typing C<x $Registry>
+will try to display your I<entire> registry contents to your screen.
+But the debugger command C<x $Registry->ObjectRef> will just dump
+the implementation details of the underlying object to your screen.
+
+=item Flush( $bFlush )
+
+Flushes all cached information about the Registry key so that future
+uses will get fresh data from the Registry.
+
+If the optional C<$bFlush> is specified and a true value, then
+C<RegFlushKey()> will be called, which is almost never necessary.
+
+=item GetValue
+
+=item $ValueData= $key->GetValue( $sValueName )
+
+=item ($ValueData,$ValueType)= $key->GetValue( $sValueName )
+
+Gets a Registry value's data and data type.
+
+C<$ValueData> is usually just a Perl string that contains the
+value data [packed into it]. For certain types of data, however,
+C<$ValueData> may be processed as described below.
+
+C<$ValueType> is the C<REG_*> constant describing the type of value
+data stored in C<$ValueData>. If the C<DualTypes()> option is on,
+then C<$ValueType> will be a dual value. That is, when used in a
+numeric context, C<$ValueType> will give the numeric value of a
+C<REG_*> constant. However, when used in a non-numeric context,
+C<$ValueType> will return the name of the C<REG_*> constant, for
+example C<"REG_SZ"> [note the quotes]. So both of the following
+can be true at the same time:
+
+ $ValueType == REG_SZ()
+ $ValueType eq "REG_SZ"
+
+=over
+
+=item REG_SZ and REG_EXPAND_SZ
+
+If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be
+stripped [unless there isn't one] before values of type C<REG_SZ>
+and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add
+a trailing C<'\0'> under similar circumstances.
+
+=item REG_MULTI_SZ
+
+If the C<SplitMultis()> option is on, then values of this type are
+returned as a reference to an array containing the strings. For
+example, a value that, with C<SplitMultis()> off, would be returned as:
+
+ "Value1\000Value2\000\000"
+
+would be returned, with C<SplitMultis()> on, as:
+
+ [ "Value1", "Value2" ]
+
+=item REG_DWORD
+
+If the C<DualBinVals()> option is on, then the value is returned
+as a scalar containing both a string and a number [much like
+the C<$!> variable -- see the L<SetDualVar> module for more
+information] where the number part is the "unpacked" value.
+Use the returned value in a numeric context to access this part
+of the value. For example:
+
+ $num= 0 + $Registry->{"CUser/Console//ColorTable01"};
+
+If the C<DWordsToHex()> option is off, the string part of the
+returned value is a packed, 4-byte string [use C<unpack("L",$value)>
+to get the numeric value.
+
+If C<DWordsToHex()> is on, the string part of the returned value is
+a 10-character hex strings [with leading "0x"]. You can use
+C<hex($value)> to get the numeric value.
+
+Note that C<SetValue()> will properly understand each of these
+returned value formats no matter how C<DualBinVals()> is set.
+
+=back
+
+=item ValueNames
+
+=item @names= $key->ValueNames
+
+Returns the list of value names stored directly in a Registry key.
+Note that the names returned do I<not> have a delimiter prepended
+to them like with C<MemberNames()> and tied hashes.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item SubKeyNames
+
+=item @key_names= $key->SubKeyNames
+
+Returns the list of subkey names stored directly in a Registry key.
+Note that the names returned do I<not> have a delimiter appended
+to them like with C<MemberNames()> and tied hashes.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item SubKeyClasses
+
+=item @classes= $key->SubKeyClasses
+
+Returns the list of classes for subkeys stored directly in a
+Registry key. The classes are returned in the same order as
+the subkey names returned by C<SubKeyNames()>.
+
+=item SubKeyTimes
+
+=item @times= $key->SubKeyTimes
+
+Returns the list of last-modified times for subkeys stored
+directly in a Registry key. The times are returned in the same
+order as the subkey names returned by C<SubKeyNames()>. Each
+time is a C<FILETIME> structure packed into a Perl string.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item MemberNames
+
+=item @members= $key->MemberNames
+
+Returns the list of subkey names and value names stored directly
+in a Registry key. Subkey names have a delimiter appended to the
+end and value names have a delimiter prepended to the front.
+
+Note that a value name could end in a delimiter [or could be C<"">
+so that the member name returned is just a delimiter] so the
+presence or absence of the leading delimiter is what should be
+used to determine whether a particular name is for a subkey or a
+value, not the presence or absence of a trailing delimiter.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item Information
+
+=item %info= $key->Information
+
+=item @items= $key->Information( @itemNames );
+
+Returns the following information about a Registry key:
+
+=over
+
+=item LastWrite
+
+A C<FILETIME> structure indicating when the key was last modified
+and packed into a Perl string.
+
+=item CntSubKeys
+
+The number of subkeys stored directly in this key.
+
+=item CntValues
+
+The number of values stored directly in this key.
+
+=item SecurityLen
+
+The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR>
+associated with the Registry key.
+
+=item MaxValDataLen
+
+The length [in bytes] of the longest value data associated with
+a value stored in this key.
+
+=item MaxSubKeyLen
+
+The length [in chars] of the longest subkey name associated with
+a subkey stored in this key.
+
+=item MaxSubClassLen
+
+The length [in chars] of the longest class name associated with
+a subkey stored directly in this key.
+
+=item MaxValNameLen
+
+The length [in chars] of the longest value name associated with
+a value stored in this key.
+
+=back
+
+With no arguments, returns a hash [not a reference to a hash] where
+the keys are the names for the items given above and the values
+are the information describe above. For example:
+
+ %info= ( "CntValues" => 25, # Key contains 25 values.
+ "MaxValNameLen" => 20, # One of which has a 20-char name.
+ "MaxValDataLen" => 42, # One of which has a 42-byte value.
+ "CntSubKeys" => 1, # Key has 1 immediate subkey.
+ "MaxSubKeyLen" => 13, # One of which has a 12-char name.
+ "MaxSubClassLen" => 0, # All of which have class names of "".
+ "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes.
+ "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA"
+ # Key was last modifed 1998/06/01 16:29:32 GMT
+ );
+
+With arguments, each one must be the name of a item given above.
+The return value is the information associated with the listed
+names. In other words:
+
+ return $key->Information( @names );
+
+returns the same list as:
+
+ %info= $key->Information;
+ return @info{@names};
+
+=item Delimiter
+
+=item $oldDelim= $key->Delimiter
+
+=item $oldDelim= $key->Delimiter( $newDelim )
+
+Gets and possibly changes the delimiter used for this object. The
+delimiter is appended to subkey names and prepended to value names
+in many return values. It is also used when parsing keys passed
+to tied hashes.
+
+The delimiter defaults to backslash (C<'\\'>) but is inherited from
+the object used to create a new object and can be specified by an
+option when a new object is created.
+
+=item Handle
+
+=item $handle= $key->Handle
+
+Returns the raw C<HKEY> handle for the associated Registry key as
+an integer value. This value can then be used to Reg*() calls
+from I<Win32API::Registry>. However, it is usually easier to just
+call the I<Win32API::Registry> calls directly via:
+
+ $key->RegNotifyChangeKeyValue( ... );
+
+For the virtual root of the local or a remote Registry,
+C<Handle()> return C<"NONE">.
+
+=item Path
+
+=item $path= $key->Path
+
+Returns a string describing the path of key names to this
+Registry key. The string is built so that if it were passed
+to C<$Registry->Open()>, it would reopen the same Registry key
+[except in the rare case where one of the key names contains
+C<$key->Delimiter>].
+
+=item Machine
+
+=item $computerName= $key->Machine
+
+Returns the name of the computer [or "machine"] on which this Registry
+key resides. Returns C<""> for local Registry keys.
+
+=item Access
+
+Returns the numeric value of the bit mask used to specify the
+types of access requested when this Registry key was opened. Can
+be compared to C<KEY_*> values.
+
+=item OS_Delimiter
+
+Returns the delimiter used by the operating system's RegOpenKeyEx()
+call. For Win32, this is always backslash (C<"\\">).
+
+=item Roots
+
+Returns the mapping from root key names like C<"LMachine"> to their
+associated C<HKEY_*> constants. Primarily for internal use and
+subject to change.
+
+=item Tie
+
+=item $key->Tie( \%hash );
+
+Ties the referenced hash to that Registry key. Pretty much the
+same as
+
+ tie %hash, ref($key), $key;
+
+Since C<ref($key)> is the class [package] to tie the hash to and
+C<TIEHASH()> just returns its argument, C<$key>, [without calling
+C<new()>] when it sees that it is already a blessed object.
+
+=item TiedRef
+
+=item $TiedHashRef= $hash_or_obj_ref->TiedRef
+
+For a simple object, returns a reference to a hash tied to the
+object. Used to promote a simple object into a combined object
+and hash ref.
+
+If already a reference to a tied hash [that is also an object],
+it just returns itself [C<$ref == $ref->TiedRef>].
+
+Mostly used internally.
+
+=item ArrayValues
+
+=item $oldBool= $key->ArrayValues
+
+=item $oldBool= $key->ArrayValues( $newBool )
+
+Gets the current setting of the C<ArrayValues> option and possibly
+turns it on or off.
+
+When off, Registry values fetched via a tied hash are returned as
+just a value scalar [the same as C<GetValue()> in a scalar context].
+When on, they are returned as a reference to an array containing
+the value data as the C<[0]> element and the data type as the C<[1]>
+element.
+
+=item TieValues
+
+=item $oldBool= TieValues
+
+=item $oldBool= TieValues( $newBool )
+
+Gets the current setting of the C<TieValues> option and possibly
+turns it on or off.
+
+Turning this option on is not yet supported in this release of
+I<Win32::TieRegistry>. In a future release, turning this option
+on will cause Registry values returned from a tied hash to be
+a tied array that you can use to modify the value in the Registry.
+
+=item FastDelete
+
+=item $oldBool= $key->FastDelete
+
+=item $oldBool= $key->FastDelete( $newBool )
+
+Gets the current setting of the C<FastDelete> option and possibly
+turns it on or off.
+
+When on, successfully deleting a Registry key [via a tied hash]
+simply returns C<1>.
+
+When off, successfully deleting a Registry key [via a tied hash
+and not in a void context] returns a reference to a hash that
+contains the values present in the key when it was deleted. This
+hash is just like that returned when referencing the key before it
+was deleted except that it is an ordinary hash, not one tied to
+the I<Win32::TieRegistry> package.
+
+Note that deleting either a Registry key or value via a tied hash
+I<in a void context> prevents any overhead in trying to build an
+appropriate return value.
+
+Note that deleting a Registry I<value> via a tied hash [not in
+a void context] returns the value data even if <FastDelete> is on.
+
+=item SplitMultis
+
+=item $oldBool= $key->SplitMultis
+
+=item $oldBool= $key->SplitMultis( $newBool )
+
+Gets the current setting of the C<SplitMultis> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_MULTI_SZ> are returned as
+a reference to an array of strings. See C<GetValue()> for more
+information.
+
+=item DWordsToHex
+
+=item $oldBool= $key->DWordsToHex
+
+=item $oldBool= $key->DWordsToHex( $newBool )
+
+Gets the current setting of the C<DWordsToHex> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_DWORD> are returned as a hex
+string with leading C<"0x"> and longer than 4 characters. See
+C<GetValue()> for more information.
+
+=item FixSzNulls
+
+=item $oldBool= $key->FixSzNulls
+
+=item $oldBool= $key->FixSzNulls( $newBool )
+
+Gets the current setting of the C<FixSzNulls> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have
+trailing C<'\0'>s added before they are set and stripped before
+they are returned. See C<GetValue()> and C<SetValue()> for more
+information.
+
+=item DualTypes
+
+=item $oldBool= $key->DualTypes
+
+=item $oldBool= $key->DualTypes( $newBool )
+
+Gets the current setting of the C<DualTypes> option and possibly
+turns it on or off.
+
+If on, data types are returned as a combined numeric/string value
+holding both the numeric value of a C<REG_*> constant and the
+string value of the constant's name. See C<GetValue()> for
+more information.
+
+=item DualBinVals
+
+=item $oldBool= $key->DualBinVals
+
+=item $oldBool= $key->DualBinVals( $newBool )
+
+Gets the current setting of the C<DualBinVals> option and possibly
+turns it on or off.
+
+If on, Registry value data of type C<REG_BINARY> and no more than
+4 bytes long and Registry values of type C<REG_DWORD> are returned
+as a combined numeric/string value where the numeric value is the
+"unpacked" binary value as returned by:
+
+ hex reverse unpack( "h*", $valData )
+
+on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)>
+on a "big-endian" computer if this module is ever ported to one.]
+
+See C<GetValue()> for more information.
+
+=item GetOptions
+
+=item @oldOptValues= $key->GetOptions( @optionNames )
+
+=item $refHashOfOldOpts= $key->GetOptions()
+
+=item $key->GetOptions( \%hashForOldOpts )
+
+Returns the current setting of any of the following options:
+
+ Delimiter FixSzNulls DWordsToHex
+ ArrayValues SplitMultis DualBinVals
+ TieValues FastDelete DualTypes
+
+Pass in one or more of the above names (as strings) to get back
+an array of the corresponding current settings in the same order:
+
+ my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter");
+
+Pass in no arguments to get back a reference to a hash where
+the above option names are the keys and the values are
+the corresponding current settings for each option:
+
+ my $href= $key->GetOptions();
+ my $delim= $href->{Delimiter};
+
+Pass in a single reference to a hash to have the above key/value
+pairs I<added> to the referenced hash. For this case, the
+return value is the original object so further methods can be
+chained after the call to GetOptions:
+
+ my %oldOpts;
+ $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" );
+
+=item SetOptions
+
+=item @oldOpts= $key->SetOptions( optNames=>$optValue,... )
+
+Changes the current setting of any of the following options,
+returning the previous setting(s):
+
+ Delimiter FixSzNulls DWordsToHex AllowLoad
+ ArrayValues SplitMultis DualBinVals AllowSave
+ TieValues FastDelete DualTypes
+
+For C<AllowLoad> and C<AllowSave>, instead of the previous
+setting, C<SetOptions> returns whether or not the change was
+successful.
+
+In a scalar context, returns only the last item. The last
+option can also be specified as C<"ref"> or C<"r"> [which doesn't
+need to be followed by a value] to allow chaining:
+
+ $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...)
+
+=item SetValue
+
+=item $okay= $key->SetValue( $ValueName, $ValueData );
+
+=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType );
+
+Adds or replaces a Registry value. Returns a true value if
+successfully, false otherwise.
+
+C<$ValueName> is the name of the value to add or replace and
+should I<not> have a delimiter prepended to it. Case is ignored.
+
+C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise,
+it should be one the C<REG_*> constants.
+
+C<$ValueData> is the data to be stored in the value, probably packed
+into a Perl string. Other supported formats for value data are
+listed below for each posible C<$ValueType>.
+
+=over
+
+=item REG_SZ or REG_EXPAND_SZ
+
+The only special processing for these values is the addition of
+the required trailing C<'\0'> if it is missing. This can be
+turned off by disabling the C<FixSzNulls> option.
+
+=item REG_MULTI_SZ
+
+These values can also be specified as a reference to a list of
+strings. For example, the following two lines are equivalent:
+
+ $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" );
+ $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" );
+
+Note that if the required two trailing nulls (C<"\000\000">) are
+missing, then this release of C<SetValue()> will I<not> add them.
+
+=item REG_DWORD
+
+These values can also be specified as a hex value with the leading
+C<"0x"> included and totaling I<more than> 4 bytes. These will be
+packed into a 4-byte string via:
+
+ $data= pack( "L", hex($data) );
+
+=item REG_BINARY
+
+This value type is listed just to emphasize that no alternate
+format is supported for it. In particular, you should I<not> pass
+in a numeric value for this type of data. C<SetValue()> cannot
+distinguish such from a packed string that just happens to match
+a numeric value and so will treat it as a packed string.
+
+=back
+
+An alternate calling format:
+
+ $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] );
+
+[two arguments, the second of which is a reference to an array
+containing the value data and value type] is supported to ease
+using tied hashes with C<SetValue()>.
+
+=item CreateKey
+
+=item $newKey= $key->CreateKey( $subKey );
+
+=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } );
+
+Creates a Registry key or just updates attributes of one. Calls
+C<RegCreateKeyEx()> then, if it succeeded, creates an object
+associated with the [possibly new] subkey.
+
+C<$subKey> is the name of a subkey [or a path to one] to be
+created or updated. It can also be a reference to an array
+containing a list of subkey names.
+
+The second argument, if it exists, should be a reference to a
+hash specifying options either to be passed to C<RegCreateKeyEx()>
+or to be used when creating the associated object. The following
+items are the supported keys for this options hash:
+
+=over
+
+=item Delimiter
+
+Specifies the delimiter to be used to parse C<$subKey> and to be
+used in the new object. Defaults to C<$key->Delimiter>.
+
+=item Access
+
+Specifies the types of access requested when the subkey is opened.
+Should be a numeric bit mask that combines one or more C<KEY_*>
+constant values.
+
+=item Class
+
+The name to assign as the class of the new or updated subkey.
+Defaults to C<""> as we have never seen a use for this information.
+
+=item Disposition
+
+Lets you specify a reference to a scalar where, upon success, will be
+stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()>
+depending on whether a new key was created or an existing key was
+opened.
+
+If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)>
+then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric
+value stored in the referenced scalar.
+
+If the C<DualTypes> option is enabled, then in addition to the
+numeric value described above, the referenced scalar will also
+have a string value equal to either C<"REG_CREATED_NEW_KEY"> or
+C<"REG_OPENED_EXISTING_KEY">, as appropriate.
+
+=item Security
+
+Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a
+Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more
+information.
+
+=item Volatile
+
+If true, specifies that the new key should be volatile, that is,
+stored only in memory and not backed by a hive file [and not saved
+if the computer is rebooted]. This option is ignored under
+Windows 95. Specifying C<Volatile=E<gt>1> is the same as
+specifying C<Options=E<gt>REG_OPTION_VOLATILE>.
+
+=item Backup
+
+If true, specifies that the new key should be opened for
+backup/restore access. The C<Access> option is ignored. If the
+calling process has enabled C<"SeBackupPrivilege">, then the
+subkey is opened with C<KEY_READ> access as the C<"LocalSystem">
+user which should have access to all subkeys. If the calling
+process has enabled C<"SeRestorePrivilege">, then the subkey is
+opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which
+should have access to all subkeys.
+
+This option is ignored under Windows 95. Specifying C<Backup=E<gt>1>
+is the same as specifying C<Options=E<gt>REG_OPTION_BACKUP_RESTORE>.
+
+=item Options
+
+Lets you specify options to the C<RegOpenKeyEx()> call. The value
+for this option should be a numeric value combining zero or more
+of the C<REG_OPTION_*> bit masks. You may with to used the
+C<Volatile> and/or C<Backup> options instead of this one.
+
+=back
+
+=item StoreKey
+
+=item $newKey= $key->StoreKey( $subKey, \%Contents );
+
+Primarily for internal use.
+
+Used to create or update a Registry key and any number of subkeys
+or values under it or its subkeys.
+
+C<$subKey> is the name of a subkey to be created [or a path of
+subkey names separated by delimiters]. If that subkey already
+exists, then it is updated.
+
+C<\%Contents> is a reference to a hash containing pairs of
+value names with value data and/or subkey names with hash
+references similar to C<\%Contents>. Each of these cause
+a value or subkey of C<$subKey> to be created or updated.
+
+If C<$Contents{""}> exists and is a reference to a hash, then
+it used as the options argument when C<CreateKey()> is called
+for C<$subKey>. This allows you to specify ...
+
+ if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) {
+ $self= $this->CreateKey( $subKey, delete $$data{""} );
+
+=item Load
+
+=item $newKey= $key->Load( $file )
+
+=item $newKey= $key->Load( $file, $newSubKey )
+
+=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } )
+
+=item $newKey= $key->Load( $file, { Option=>OptVal... } )
+
+Loads a hive file into a Registry. That is, creates a new subkey
+and associates a hive file with it.
+
+C<$file> is a hive file, that is a file created by calling
+C<RegSaveKey()>. The C<$file> path is interpreted relative to
+C<%SystemRoot%/System32/config> on the machine where C<$key>
+resides.
+
+C<$newSubKey> is the name to be given to the new subkey. If
+C<$newSubKey> is specified, then C<$key> must be
+C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer
+or a remote computer and C<$newSubKey> should not contain any
+occurrences of either the delimiter or the OS delimiter.
+
+If C<$newSubKey> is not specified, then it is as if C<$key>
+was C<$Registry-E<gt>{LMachine}> and C<$newSubKey> is
+C<"PerlTie:999"> where C<"999"> is actually a sequence number
+incremented each time this process calls C<Load()>.
+
+You can specify as the last argument a reference to a hash
+containing options. You can specify the same options that you
+can specify to C<Open()>. See C<Open()> for more information on
+those. In addition, you can specify the option C<"NewSubKey">.
+The value of this option is interpretted exactly as if it was
+specified as the C<$newSubKey> parameter and overrides the
+C<$newSubKey> if one was specified.
+
+The hive is automatically unloaded when the returned object
+[C<$newKey>] is destroyed. Registry key objects opened within
+the hive will keep a reference to the C<$newKey> object so that
+it will not be destroyed before these keys are closed.
+
+=item UnLoad
+
+=item $okay= $key->UnLoad
+
+Unloads a hive that was loaded via C<Load()>. Cannot unload other
+hives. C<$key> must be the return from a previous call to C<Load()>.
+C<$key> is closed and then the hive is unloaded.
+
+=item AllowSave
+
+=item $okay= AllowSave( $bool )
+
+Enables or disables the C<"ReBackupPrivilege"> privilege for the
+current process. You will probably have to enable this privilege
+before you can use C<RegSaveKey()>.
+
+The return value indicates whether the operation succeeded, not
+whether the privilege was previously enabled.
+
+=item AllowLoad
+
+=item $okay= AllowLoad( $bool )
+
+Enables or disables the C<"ReRestorePrivilege"> privilege for the
+current process. You will probably have to enable this privilege
+before you can use C<RegLoadKey()>, C<RegUnLoadKey()>,
+C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and
+C<UnLoad()>.
+
+The return value indicates whether the operation succeeded, not
+whether the privilege was previously enabled.
+
+=back
+
+=head2 Exports [C<use> and C<import()>]
+
+To have nothing imported into your package, use something like:
+
+ use Win32::TieRegistry 0.20 ();
+
+which would verify that you have at least version 0.20 but wouldn't
+call C<import()>. The F<Changes> file can be useful in figuring out
+which, if any, prior versions of I<Win32::TieRegistry> you want to
+support in your script.
+
+The code
+
+ use Win32::TieRegistry;
+
+imports the variable C<$Registry> into your package and sets it
+to be a reference to a hash tied to a copy of the master Registry
+virtual root object with the default options. One disadvantage
+to this "default" usage is that Perl does not support checking
+the module version when you use it.
+
+Alternately, you can specify a list of arguments on the C<use>
+line that will be passed to the C<Win32::TieRegistry->import()>
+method to control what items to import into your package. These
+arguments fall into the following broad categories:
+
+=over
+
+=item Import a reference to a hash tied to a Registry virtual root
+
+You can request that a scalar variable be imported (possibly)
+and set to be a reference to a hash tied to a Registry virtual root
+using any of the following types of arguments or argument pairs:
+
+=over
+
+=item "TiedRef", '$scalar'
+
+=item "TiedRef", '$pack::scalar'
+
+=item "TiedRef", 'scalar'
+
+=item "TiedRef", 'pack::scalar'
+
+All of the above import a scalar named C<$scalar> into your package
+(or the package named "pack") and then sets it.
+
+=item '$scalar'
+
+=item '$pack::scalar'
+
+These are equivalent to the previous items to support a more
+traditional appearance to the list of exports. Note that the
+scalar name cannot be "RegObj" here.
+
+=item "TiedRef", \$scalar
+
+=item \$scalar
+
+These versions don't import anything but set the referenced C<$scalar>.
+
+=back
+
+=item Import a hash tied to the Registry virtual root
+
+You can request that a hash variable be imported (possibly)
+and tied to a Registry virtual root using any of the following
+types of arguments or argument pairs:
+
+=over
+
+=item "TiedHash", '%hash'
+
+=item "TiedHash", '%pack::hash'
+
+=item "TiedHash", 'hash'
+
+=item "TiedHash", 'pack::hash'
+
+All of the above import a hash named C<%hash> into your package
+(or the package named "pack") and then sets it.
+
+=item '%hash'
+
+=item '%pack::hash'
+
+These are equivalent to the previous items to support a more
+traditional appearance to the list of exports.
+
+=item "TiedHash", \%hash
+
+=item \%hash
+
+These versions don't import anything but set the referenced C<%hash>.
+
+=back
+
+=item Import a Registry virtual root object
+
+You can request that a scalar variable be imported (possibly)
+and set to be a Registry virtual root object using any of the
+following types of arguments or argument pairs:
+
+=over
+
+=item "ObjectRef", '$scalar'
+
+=item "ObjectRef", '$pack::scalar'
+
+=item "ObjectRef", 'scalar'
+
+=item "ObjectRef", 'pack::scalar'
+
+All of the above import a scalar named C<$scalar> into your package
+(or the package named "pack") and then sets it.
+
+=item '$RegObj'
+
+This is equivalent to the previous items for backward compatibility.
+
+=item "ObjectRef", \$scalar
+
+This version doesn't import anything but sets the referenced C<$scalar>.
+
+=back
+
+=item Import constant(s) exported by I<Win32API::Registry>
+
+You can list any constants that are exported by I<Win32API::Registry>
+to have them imported into your package. These constants have names
+starting with "KEY_" or "REG_" (or even "HKEY_").
+
+You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to
+import a whole set of constants.
+
+See I<Win32API::Registry> documentation for more information.
+
+=item Options
+
+You can list any option names that can be listed in the C<SetOptions()>
+method call, each folowed by the value to use for that option.
+A Registry virtual root object is created, all of these options are
+set for it, then each variable to be imported/set is associated with
+this object.
+
+In addition, the following special options are supported:
+
+=over
+
+=item ExportLevel
+
+Whether to import variables into your package or some
+package that uses your package. Defaults to the value of
+C<$Exporter::ExportLevel> and has the same meaning. See
+the L<Exporter> module for more information.
+
+=item ExportTo
+
+The name of the package to import variables and constants into.
+Overrides I<ExportLevel>.
+
+=back
+
+=back
+
+=head3 Specifying constants in your Perl code
+
+This module was written with a strong emphasis on the convenience of
+the module user. Therefore, most places where you can specify a
+constant like C<REG_SZ()> also allow you to specify a string
+containing the name of the constant, C<"REG_SZ">. This is convenient
+because you may not have imported that symbolic constant.
+
+Perl also emphasizes programmer convenience so the code C<REG_SZ>
+can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal.
+Note that using C<&REG_SZ> (as we've seen in much Win32 Perl code)
+is not a good idea since it passes the current C<@_> to the
+C<constant()> routine of the module which, at the least, can give
+you a warning under B<-w>.
+
+Although greatly a matter of style, the "safest" practice is probably
+to specifically list all constants in the C<use Win32::TieRegistry>
+statement, specify C<use strict> [or at least C<use strict qw(subs)>],
+and use bare constant names when you want the numeric value. This will
+detect mispelled constant names at compile time.
+
+ use strict;
+ my $Registry;
+ use Win32::TieRegistry 0.20 (
+ TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1,
+ SplitMultis => 1, AllowLoad => 1,
+ qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ
+ KEY_READ KEY_WRITE KEY_ALL_ACCESS ),
+ );
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ],
+ "/WindowSize" => [ pack("LL",24,80), REG_BINARY ],
+ "/TaskBarIcon" => [ "0x0001", REG_DWORD ],
+ },
+ } or die "Can't create Software/FooCorp/: $^E\n";
+
+If you don't want to C<use strict qw(subs)>, the second safest practice
+is similar to the above but use the C<REG_SZ()> form for constants
+when possible and quoted constant names when required. Note that
+C<qw()> is a form of quoting.
+
+ use Win32::TieRegistry 0.20 qw(
+ TiedRef $Registry
+ Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1
+ REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ
+ KEY_READ KEY_WRITE KEY_ALL_ACCESS
+ );
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ],
+ "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ],
+ "/TaskBarIcon" => [ "0x0001", REG_DWORD() ],
+ },
+ } or die "Can't create Software/FooCorp/: $^E\n";
+
+The examples in this document mostly use quoted constant names
+(C<"REG_SZ">) since that works regardless of which constants
+you imported and whether or not you have C<use strict> in your
+script. It is not the best choice for you to use for real
+scripts (vs. examples) because it is less efficient and is not
+supported by most other similar modules.
+
+=head1 SUMMARY
+
+Most things can be done most easily via tied hashes. Skip down to the
+the L<Tied Hashes Summary> to get started quickly.
+
+=head2 Objects Summary
+
+Here are quick examples that document the most common functionality
+of all of the method functions [except for a few almost useless ones].
+
+ # Just another way of saying Open():
+ $key= new Win32::TieRegistry "LMachine\\Software\\",
+ { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" };
+
+ # Open a Registry key:
+ $subKey= $key->Open( "SubKey/SubSubKey/",
+ { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } );
+
+ # Connect to a remote Registry key:
+ $remKey= $Registry->Connect( "MachineName", "LMachine/",
+ { Access=>KEY_READ, Delimiter=>"/" } );
+
+ # Get value data:
+ $valueString= $key->GetValue("ValueName");
+ ( $valueString, $valueType )= $key->GetValue("ValueName");
+
+ # Get list of value names:
+ @valueNames= $key->ValueNames;
+
+ # Get list of subkey names:
+ @subKeyNames= $key->SubKeyNames;
+
+ # Get combined list of value names (with leading delimiters)
+ # and subkey names (with trailing delimiters):
+ @memberNames= $key->MemberNames;
+
+ # Get all information about a key:
+ %keyInfo= $key->Information;
+ # keys(%keyInfo)= qw( Class LastWrite SecurityLen
+ # CntSubKeys MaxSubKeyLen MaxSubClassLen
+ # CntValues MaxValNameLen MaxValDataLen );
+
+ # Get selected information about a key:
+ ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" );
+
+ # Get and/or set delimiter:
+ $delim= $key->Delimiter;
+ $oldDelim= $key->Delimiter( $newDelim );
+
+ # Get "path" for an open key:
+ $path= $key->Path;
+ # For example, "/CUser/Control Panel/Mouse/"
+ # or "//HostName/LMachine/System/DISK/".
+
+ # Get name of machine where key is from:
+ $mach= $key->Machine;
+ # Will usually be "" indicating key is on local machine.
+
+ # Control different options (see main documentation for descriptions):
+ $oldBool= $key->ArrayValues( $newBool );
+ $oldBool= $key->FastDelete( $newBool );
+ $oldBool= $key->FixSzNulls( $newBool );
+ $oldBool= $key->SplitMultis( $newBool );
+ $oldBool= $key->DWordsToHex( $newBool );
+ $oldBool= $key->DualBinVals( $newBool );
+ $oldBool= $key->DualTypes( $newBool );
+ @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0,
+ Delimiter=>"/", AllowLoad=>1, AllowSave=>1 );
+ @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls );
+
+ # Add or set a value:
+ $key->SetValue( "ValueName", $valueDataString );
+ $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" );
+
+ # Add or set a key:
+ $key->CreateKey( "SubKeyName" );
+ $key->CreateKey( "SubKeyName",
+ { Access=>"KEY_ALL_ACCESS", Class=>"ClassName",
+ Delimiter=>"/", Volatile=>1, Backup=>1 } );
+
+ # Load an off-line Registry hive file into the on-line Registry:
+ $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" );
+ $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName",
+ { Access=>"KEY_READ" } );
+ # Unload a Registry hive file loaded via the Load() method:
+ $newKey->UnLoad;
+
+ # (Dis)Allow yourself to load Registry hive files:
+ $success= $Registry->AllowLoad( $bool );
+
+ # (Dis)Allow yourself to save a Registry key to a hive file:
+ $success= $Registry->AllowSave( $bool );
+
+ # Save a Registry key to a new hive file:
+ $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] );
+
+=head3 Other Useful Methods
+
+See I<Win32API::Registry> for more information on these methods.
+These methods are provided for coding convenience and are
+identical to the I<Win32API::Registry> functions except that these
+don't take a handle to a Registry key, instead getting the handle
+from the invoking object [C<$key>].
+
+ $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc );
+ $key->RegLoadKey( $sSubKeyName, $sPathToFile );
+ $key->RegNotifyChangeKeyValue(
+ $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync );
+ $key->RegQueryMultipleValues(
+ $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer );
+ $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile );
+ $key->RegRestoreKey( $sPathToFile, $iFlags );
+ $key->RegSetKeySecurity( $iSecInfo, $sSecDesc );
+ $key->RegUnLoadKey( $sSubKeyName );
+
+=head2 Tied Hashes Summary
+
+For fast learners, this may be the only section you need to read.
+Always append one delimiter to the end of each Registry key name
+and prepend one delimiter to the front of each Registry value name.
+
+=head3 Opening keys
+
+ use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 );
+ $Registry->Delimiter("/"); # Set delimiter to "/".
+ $swKey= $Registry->{"LMachine/Software/"};
+ $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"};
+ $userKey= $Registry->
+ {"CUser/Software/Microsoft/Windows/CurrentVersion/"};
+ $remoteKey= $Registry->{"//HostName/LMachine/"};
+
+=head3 Reading values
+
+ $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files"
+ $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21.
+
+ $winKey->ArrayValues(1);
+ ( $devPath, $type )= $winKey->{"/DevicePath"};
+ # $devPath eq "%SystemRoot%\\inf"
+ # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed]
+ # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>]
+
+=head3 Setting values
+
+ $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows";
+ # Simple. Assumes data type of REG_SZ.
+
+ $winKey->{"Setup//Installation Sources"}=
+ [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ];
+ # "\x00" and "\0" used to mark ends of each string and end of list.
+
+ $winKey->{"Setup//Installation Sources"}=
+ [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ];
+ # Alternate method that is easier to read.
+
+ $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}=
+ [ pack("L",0), "REG_DWORD" ];
+ $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ];
+ $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ];
+
+=head3 Adding keys
+
+ $swKey->{"FooCorp/"}= {
+ "FooWriter/" => {
+ "/Version" => "4.032",
+ "Startup/" => {
+ "/Title" => "Foo Writer Deluxe ][",
+ "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ],
+ "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ],
+ },
+ "Compatibility/" => {
+ "/AutoConvert" => "Always",
+ "/Default Palette" => "Windows Colors",
+ },
+ },
+ "/License", => "0123-9C8EF1-09-FC",
+ };
+
+=head3 Listing all subkeys and values
+
+ @members= keys( %{$swKey} );
+ @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) );
+ # @subKeys= ( "/", "/EditFlags" );
+ @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) );
+ # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" );
+
+=head3 Deleting values or keys with no subkeys
+
+ $oldValue= delete $userKey->{"Explorer/Tips//Next"};
+
+ $oldValues= delete $userKey->{"Explorer/Tips/"};
+ # $oldValues will be reference to hash containing deleted keys values.
+
+=head3 Closing keys
+
+ undef $swKey; # Explicit way to close a key.
+ $winKey= "Anything else"; # Implicitly closes a key.
+ exit 0; # Implicitly closes all keys.
+
+=head2 Tie::Registry
+
+This module was originally called I<Tie::Registry>. Changing code
+that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial
+as the module name should only be mentioned once, in the C<use>
+line. However, finding all of the places that used I<Tie::Registry>
+may not be completely trivial so we have included F<Tie/Registry.pm>
+which you can install to provide backward compatibility.
+
+=head1 AUTHOR
+
+Tye McQueen. See http://www.metronet.com/~tye/ or e-mail
+tye@metronet.com with bug reports.
+
+=head1 SEE ALSO
+
+I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>,
+C<KEY_*>, C<REG_*> [required].
+
+I<Win32::WinError> - Defines C<ERROR_*> values [optional].
+
+L<SetDualVar> - For returning C<REG_*> values as combined
+string/integer values [optional].
+
+=head1 BUGS
+
+Perl5.004_02 has bugs that make I<Win32::TieRegistry> fail in
+strange and subtle ways.
+
+Using I<Win32::TieRegistry> with versions of Perl prior to 5.005
+can be tricky or impossible. Most notes about this have been
+removed from the documentation (they get rather complicated
+and confusing). This includes references to C<$^E> perhaps not
+being meaningful.
+
+Because Perl hashes are case sensitive, certain lookups are also
+case sensistive. In particular, the root keys ("Classes", "CUser",
+"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*)
+must always be entered without changing between upper and lower
+case letters. Also, the special rule for matching subkey names
+that contain the user-selected delimiter only works if case is
+matched. All other key name and value name lookups should be case
+insensitive because the underlying Reg*() calls ignore case.
+
+Information about each key is cached when using a tied hash.
+This cache is not flushed nor updated when changes are made,
+I<even when the same tied hash is used> to make the changes.
+
+Current implementations of Perl's "global destruction" phase can
+cause objects returned by C<Load()> to be destroyed while keys
+within the hive are still open, if the objects still exist when
+the script starts to exit. When this happens, the automatic
+C<UnLoad()> will report a failure and the hive will remain loaded
+in the Registry.
+
+Trying to C<Load()> a hive file that is located on a remote network
+share may silently delete all data from the hive. This is a bug
+in the Win32 APIs, not any Perl code or modules. This module does
+not try to protect you from this bug.
+
+There is no test suite.
+
+=head1 FUTURE DIRECTIONS
+
+The following items are desired by the author and may appear in a
+future release of this module.
+
+=over
+
+=item TieValues option
+
+Currently described in main documentation but no yet implemented.
+
+=item AutoRefresh option
+
+Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash
+caches up-to-date even when other programs make changes.
+
+=item Error options
+
+Allow the user to have unchecked calls (calls in a "void context")
+to automatically report errors via C<warn> or C<die>.
+
+For complex operations, such a copying an entire subtree, provide
+access to detailed information about errors (and perhaps some
+warnings) that were encountered. Let the user control whether
+the complex operation continues in spite of errors.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 1999 - 2006 Tye McQueen.
+
+Some parts copyright 2007 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Autoload not currently supported by Perl under Windows.
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/WinError.pm b/Master/tlpkg/tlperl.straw/lib/Win32/WinError.pm
new file mode 100755
index 00000000000..4ea0091685d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/WinError.pm
@@ -0,0 +1,1017 @@
+package Win32::WinError;
+
+require Exporter;
+require DynaLoader;
+
+$VERSION = '0.03';
+
+@ISA = qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ GetLastError
+ CACHE_E_FIRST
+ CACHE_E_LAST
+ CACHE_E_NOCACHE_UPDATED
+ CACHE_S_FIRST
+ CACHE_S_FORMATETC_NOTSUPPORTED
+ CACHE_S_LAST
+ CACHE_S_SAMECACHE
+ CACHE_S_SOMECACHES_NOTUPDATED
+ CLASSFACTORY_E_FIRST
+ CLASSFACTORY_E_LAST
+ CLASSFACTORY_S_FIRST
+ CLASSFACTORY_S_LAST
+ CLASS_E_CLASSNOTAVAILABLE
+ CLASS_E_NOAGGREGATION
+ CLIENTSITE_E_FIRST
+ CLIENTSITE_E_LAST
+ CLIENTSITE_S_FIRST
+ CLIENTSITE_S_LAST
+ CLIPBRD_E_BAD_DATA
+ CLIPBRD_E_CANT_CLOSE
+ CLIPBRD_E_CANT_EMPTY
+ CLIPBRD_E_CANT_OPEN
+ CLIPBRD_E_CANT_SET
+ CLIPBRD_E_FIRST
+ CLIPBRD_E_LAST
+ CLIPBRD_S_FIRST
+ CLIPBRD_S_LAST
+ CONVERT10_E_FIRST
+ CONVERT10_E_LAST
+ CONVERT10_E_OLESTREAM_BITMAP_TO_DIB
+ CONVERT10_E_OLESTREAM_FMT
+ CONVERT10_E_OLESTREAM_GET
+ CONVERT10_E_OLESTREAM_PUT
+ CONVERT10_E_STG_DIB_TO_BITMAP
+ CONVERT10_E_STG_FMT
+ CONVERT10_E_STG_NO_STD_STREAM
+ CONVERT10_S_FIRST
+ CONVERT10_S_LAST
+ CONVERT10_S_NO_PRESENTATION
+ CO_E_ALREADYINITIALIZED
+ CO_E_APPDIDNTREG
+ CO_E_APPNOTFOUND
+ CO_E_APPSINGLEUSE
+ CO_E_BAD_PATH
+ CO_E_CANTDETERMINECLASS
+ CO_E_CLASSSTRING
+ CO_E_CLASS_CREATE_FAILED
+ CO_E_DLLNOTFOUND
+ CO_E_ERRORINAPP
+ CO_E_ERRORINDLL
+ CO_E_FIRST
+ CO_E_IIDSTRING
+ CO_E_INIT_CLASS_CACHE
+ CO_E_INIT_MEMORY_ALLOCATOR
+ CO_E_INIT_ONLY_SINGLE_THREADED
+ CO_E_INIT_RPC_CHANNEL
+ CO_E_INIT_SCM_EXEC_FAILURE
+ CO_E_INIT_SCM_FILE_MAPPING_EXISTS
+ CO_E_INIT_SCM_MAP_VIEW_OF_FILE
+ CO_E_INIT_SCM_MUTEX_EXISTS
+ CO_E_INIT_SHARED_ALLOCATOR
+ CO_E_INIT_TLS
+ CO_E_INIT_TLS_CHANNEL_CONTROL
+ CO_E_INIT_TLS_SET_CHANNEL_CONTROL
+ CO_E_INIT_UNACCEPTED_USER_ALLOCATOR
+ CO_E_LAST
+ CO_E_NOTINITIALIZED
+ CO_E_OBJISREG
+ CO_E_OBJNOTCONNECTED
+ CO_E_OBJNOTREG
+ CO_E_OBJSRV_RPC_FAILURE
+ CO_E_RELEASED
+ CO_E_SCM_ERROR
+ CO_E_SCM_RPC_FAILURE
+ CO_E_SERVER_EXEC_FAILURE
+ CO_E_SERVER_STOPPING
+ CO_E_WRONGOSFORAPP
+ CO_S_FIRST
+ CO_S_LAST
+ DATA_E_FIRST
+ DATA_E_LAST
+ DATA_S_FIRST
+ DATA_S_LAST
+ DATA_S_SAMEFORMATETC
+ DISP_E_ARRAYISLOCKED
+ DISP_E_BADCALLEE
+ DISP_E_BADINDEX
+ DISP_E_BADPARAMCOUNT
+ DISP_E_BADVARTYPE
+ DISP_E_EXCEPTION
+ DISP_E_MEMBERNOTFOUND
+ DISP_E_NONAMEDARGS
+ DISP_E_NOTACOLLECTION
+ DISP_E_OVERFLOW
+ DISP_E_PARAMNOTFOUND
+ DISP_E_PARAMNOTOPTIONAL
+ DISP_E_TYPEMISMATCH
+ DISP_E_UNKNOWNINTERFACE
+ DISP_E_UNKNOWNLCID
+ DISP_E_UNKNOWNNAME
+ DRAGDROP_E_ALREADYREGISTERED
+ DRAGDROP_E_FIRST
+ DRAGDROP_E_INVALIDHWND
+ DRAGDROP_E_LAST
+ DRAGDROP_E_NOTREGISTERED
+ DRAGDROP_S_CANCEL
+ DRAGDROP_S_DROP
+ DRAGDROP_S_FIRST
+ DRAGDROP_S_LAST
+ DRAGDROP_S_USEDEFAULTCURSORS
+ DV_E_CLIPFORMAT
+ DV_E_DVASPECT
+ DV_E_DVTARGETDEVICE
+ DV_E_DVTARGETDEVICE_SIZE
+ DV_E_FORMATETC
+ DV_E_LINDEX
+ DV_E_NOIVIEWOBJECT
+ DV_E_STATDATA
+ DV_E_STGMEDIUM
+ DV_E_TYMED
+ ENUM_E_FIRST
+ ENUM_E_LAST
+ ENUM_S_FIRST
+ ENUM_S_LAST
+ EPT_S_CANT_CREATE
+ EPT_S_CANT_PERFORM_OP
+ EPT_S_INVALID_ENTRY
+ EPT_S_NOT_REGISTERED
+ ERROR_ACCESS_DENIED
+ ERROR_ACCOUNT_DISABLED
+ ERROR_ACCOUNT_EXPIRED
+ ERROR_ACCOUNT_LOCKED_OUT
+ ERROR_ACCOUNT_RESTRICTION
+ ERROR_ACTIVE_CONNECTIONS
+ ERROR_ADAP_HDW_ERR
+ ERROR_ADDRESS_ALREADY_ASSOCIATED
+ ERROR_ADDRESS_NOT_ASSOCIATED
+ ERROR_ALIAS_EXISTS
+ ERROR_ALLOTTED_SPACE_EXCEEDED
+ ERROR_ALREADY_ASSIGNED
+ ERROR_ALREADY_EXISTS
+ ERROR_ALREADY_REGISTERED
+ ERROR_ALREADY_RUNNING_LKG
+ ERROR_ALREADY_WAITING
+ ERROR_ARENA_TRASHED
+ ERROR_ARITHMETIC_OVERFLOW
+ ERROR_ATOMIC_LOCKS_NOT_SUPPORTED
+ ERROR_AUTODATASEG_EXCEEDS_64k
+ ERROR_BADDB
+ ERROR_BADKEY
+ ERROR_BAD_ARGUMENTS
+ ERROR_BAD_COMMAND
+ ERROR_BAD_DESCRIPTOR_FORMAT
+ ERROR_BAD_DEVICE
+ ERROR_BAD_DEV_TYPE
+ ERROR_BAD_DRIVER
+ ERROR_BAD_DRIVER_LEVEL
+ ERROR_BAD_ENVIRONMENT
+ ERROR_BAD_EXE_FORMAT
+ ERROR_BAD_FORMAT
+ ERROR_BAD_IMPERSONATION_LEVEL
+ ERROR_BAD_INHERITANCE_ACL
+ ERROR_BAD_LENGTH
+ ERROR_BAD_LOGON_SESSION_STATE
+ ERROR_BAD_NETPATH
+ ERROR_BAD_NET_NAME
+ ERROR_BAD_NET_RESP
+ ERROR_BAD_PATHNAME
+ ERROR_BAD_PIPE
+ ERROR_BAD_PROFILE
+ ERROR_BAD_PROVIDER
+ ERROR_BAD_REM_ADAP
+ ERROR_BAD_THREADID_ADDR
+ ERROR_BAD_TOKEN_TYPE
+ ERROR_BAD_UNIT
+ ERROR_BAD_USERNAME
+ ERROR_BAD_VALIDATION_CLASS
+ ERROR_BEGINNING_OF_MEDIA
+ ERROR_BOOT_ALREADY_ACCEPTED
+ ERROR_BROKEN_PIPE
+ ERROR_BUFFER_OVERFLOW
+ ERROR_BUSY
+ ERROR_BUSY_DRIVE
+ ERROR_BUS_RESET
+ ERROR_CALL_NOT_IMPLEMENTED
+ ERROR_CANCELLED
+ ERROR_CANCEL_VIOLATION
+ ERROR_CANNOT_COPY
+ ERROR_CANNOT_FIND_WND_CLASS
+ ERROR_CANNOT_IMPERSONATE
+ ERROR_CANNOT_MAKE
+ ERROR_CANNOT_OPEN_PROFILE
+ ERROR_CANTOPEN
+ ERROR_CANTREAD
+ ERROR_CANTWRITE
+ ERROR_CANT_ACCESS_DOMAIN_INFO
+ ERROR_CANT_DISABLE_MANDATORY
+ ERROR_CANT_OPEN_ANONYMOUS
+ ERROR_CAN_NOT_COMPLETE
+ ERROR_CAN_NOT_DEL_LOCAL_WINS
+ ERROR_CHILD_MUST_BE_VOLATILE
+ ERROR_CHILD_NOT_COMPLETE
+ ERROR_CHILD_WINDOW_MENU
+ ERROR_CIRCULAR_DEPENDENCY
+ ERROR_CLASS_ALREADY_EXISTS
+ ERROR_CLASS_DOES_NOT_EXIST
+ ERROR_CLASS_HAS_WINDOWS
+ ERROR_CLIPBOARD_NOT_OPEN
+ ERROR_CLIPPING_NOT_SUPPORTED
+ ERROR_CONNECTION_ABORTED
+ ERROR_CONNECTION_ACTIVE
+ ERROR_CONNECTION_COUNT_LIMIT
+ ERROR_CONNECTION_INVALID
+ ERROR_CONNECTION_REFUSED
+ ERROR_CONNECTION_UNAVAIL
+ ERROR_CONTROL_ID_NOT_FOUND
+ ERROR_COUNTER_TIMEOUT
+ ERROR_CRC
+ ERROR_CURRENT_DIRECTORY
+ ERROR_DATABASE_DOES_NOT_EXIST
+ ERROR_DC_NOT_FOUND
+ ERROR_DEPENDENT_SERVICES_RUNNING
+ ERROR_DESTROY_OBJECT_OF_OTHER_THREAD
+ ERROR_DEVICE_ALREADY_REMEMBERED
+ ERROR_DEVICE_IN_USE
+ ERROR_DEVICE_NOT_PARTITIONED
+ ERROR_DEV_NOT_EXIST
+ ERROR_DIRECTORY
+ ERROR_DIRECT_ACCESS_HANDLE
+ ERROR_DIR_NOT_EMPTY
+ ERROR_DIR_NOT_ROOT
+ ERROR_DISCARDED
+ ERROR_DISK_CHANGE
+ ERROR_DISK_CORRUPT
+ ERROR_DISK_FULL
+ ERROR_DISK_OPERATION_FAILED
+ ERROR_DISK_RECALIBRATE_FAILED
+ ERROR_DISK_RESET_FAILED
+ ERROR_DLL_INIT_FAILED
+ ERROR_DOMAIN_CONTROLLER_NOT_FOUND
+ ERROR_DOMAIN_EXISTS
+ ERROR_DOMAIN_LIMIT_EXCEEDED
+ ERROR_DOMAIN_TRUST_INCONSISTENT
+ ERROR_DRIVE_LOCKED
+ ERROR_DUPLICATE_SERVICE_NAME
+ ERROR_DUP_DOMAINNAME
+ ERROR_DUP_NAME
+ ERROR_DYNLINK_FROM_INVALID_RING
+ ERROR_EAS_DIDNT_FIT
+ ERROR_EAS_NOT_SUPPORTED
+ ERROR_EA_ACCESS_DENIED
+ ERROR_EA_FILE_CORRUPT
+ ERROR_EA_LIST_INCONSISTENT
+ ERROR_EA_TABLE_FULL
+ ERROR_END_OF_MEDIA
+ ERROR_ENVVAR_NOT_FOUND
+ ERROR_EOM_OVERFLOW
+ ERROR_EVENTLOG_CANT_START
+ ERROR_EVENTLOG_FILE_CHANGED
+ ERROR_EVENTLOG_FILE_CORRUPT
+ ERROR_EXCEPTION_IN_SERVICE
+ ERROR_EXCL_SEM_ALREADY_OWNED
+ ERROR_EXE_MARKED_INVALID
+ ERROR_EXTENDED_ERROR
+ ERROR_FAILED_SERVICE_CONTROLLER_CONNECT
+ ERROR_FAIL_I24
+ ERROR_FILEMARK_DETECTED
+ ERROR_FILENAME_EXCED_RANGE
+ ERROR_FILE_CORRUPT
+ ERROR_FILE_EXISTS
+ ERROR_FILE_INVALID
+ ERROR_FILE_NOT_FOUND
+ ERROR_FLOPPY_BAD_REGISTERS
+ ERROR_FLOPPY_ID_MARK_NOT_FOUND
+ ERROR_FLOPPY_UNKNOWN_ERROR
+ ERROR_FLOPPY_WRONG_CYLINDER
+ ERROR_FULLSCREEN_MODE
+ ERROR_FULL_BACKUP
+ ERROR_GENERIC_NOT_MAPPED
+ ERROR_GEN_FAILURE
+ ERROR_GLOBAL_ONLY_HOOK
+ ERROR_GRACEFUL_DISCONNECT
+ ERROR_GROUP_EXISTS
+ ERROR_HANDLE_DISK_FULL
+ ERROR_HANDLE_EOF
+ ERROR_HOOK_NEEDS_HMOD
+ ERROR_HOOK_NOT_INSTALLED
+ ERROR_HOST_UNREACHABLE
+ ERROR_HOTKEY_ALREADY_REGISTERED
+ ERROR_HOTKEY_NOT_REGISTERED
+ ERROR_HWNDS_HAVE_DIFF_PARENT
+ ERROR_ILL_FORMED_PASSWORD
+ ERROR_INCORRECT_ADDRESS
+ ERROR_INC_BACKUP
+ ERROR_INFLOOP_IN_RELOC_CHAIN
+ ERROR_INSUFFICIENT_BUFFER
+ ERROR_INTERNAL_DB_CORRUPTION
+ ERROR_INTERNAL_DB_ERROR
+ ERROR_INTERNAL_ERROR
+ ERROR_INVALID_ACCEL_HANDLE
+ ERROR_INVALID_ACCESS
+ ERROR_INVALID_ACCOUNT_NAME
+ ERROR_INVALID_ACL
+ ERROR_INVALID_ADDRESS
+ ERROR_INVALID_AT_INTERRUPT_TIME
+ ERROR_INVALID_BLOCK
+ ERROR_INVALID_BLOCK_LENGTH
+ ERROR_INVALID_CATEGORY
+ ERROR_INVALID_COMBOBOX_MESSAGE
+ ERROR_INVALID_COMPUTERNAME
+ ERROR_INVALID_CURSOR_HANDLE
+ ERROR_INVALID_DATA
+ ERROR_INVALID_DATATYPE
+ ERROR_INVALID_DOMAINNAME
+ ERROR_INVALID_DOMAIN_ROLE
+ ERROR_INVALID_DOMAIN_STATE
+ ERROR_INVALID_DRIVE
+ ERROR_INVALID_DWP_HANDLE
+ ERROR_INVALID_EA_HANDLE
+ ERROR_INVALID_EA_NAME
+ ERROR_INVALID_EDIT_HEIGHT
+ ERROR_INVALID_ENVIRONMENT
+ ERROR_INVALID_EVENTNAME
+ ERROR_INVALID_EVENT_COUNT
+ ERROR_INVALID_EXE_SIGNATURE
+ ERROR_INVALID_FILTER_PROC
+ ERROR_INVALID_FLAGS
+ ERROR_INVALID_FLAG_NUMBER
+ ERROR_INVALID_FORM_NAME
+ ERROR_INVALID_FORM_SIZE
+ ERROR_INVALID_FUNCTION
+ ERROR_INVALID_GROUPNAME
+ ERROR_INVALID_GROUP_ATTRIBUTES
+ ERROR_INVALID_GW_COMMAND
+ ERROR_INVALID_HANDLE
+ ERROR_INVALID_HOOK_FILTER
+ ERROR_INVALID_HOOK_HANDLE
+ ERROR_INVALID_ICON_HANDLE
+ ERROR_INVALID_ID_AUTHORITY
+ ERROR_INVALID_INDEX
+ ERROR_INVALID_LB_MESSAGE
+ ERROR_INVALID_LEVEL
+ ERROR_INVALID_LIST_FORMAT
+ ERROR_INVALID_LOGON_HOURS
+ ERROR_INVALID_LOGON_TYPE
+ ERROR_INVALID_MEMBER
+ ERROR_INVALID_MENU_HANDLE
+ ERROR_INVALID_MESSAGE
+ ERROR_INVALID_MESSAGEDEST
+ ERROR_INVALID_MESSAGENAME
+ ERROR_INVALID_MINALLOCSIZE
+ ERROR_INVALID_MODULETYPE
+ ERROR_INVALID_MSGBOX_STYLE
+ ERROR_INVALID_NAME
+ ERROR_INVALID_NETNAME
+ ERROR_INVALID_ORDINAL
+ ERROR_INVALID_OWNER
+ ERROR_INVALID_PARAMETER
+ ERROR_INVALID_PASSWORD
+ ERROR_INVALID_PASSWORDNAME
+ ERROR_INVALID_PIXEL_FORMAT
+ ERROR_INVALID_PRIMARY_GROUP
+ ERROR_INVALID_PRINTER_COMMAND
+ ERROR_INVALID_PRINTER_NAME
+ ERROR_INVALID_PRINTER_STATE
+ ERROR_INVALID_PRIORITY
+ ERROR_INVALID_SCROLLBAR_RANGE
+ ERROR_INVALID_SECURITY_DESCR
+ ERROR_INVALID_SEGDPL
+ ERROR_INVALID_SEGMENT_NUMBER
+ ERROR_INVALID_SEPARATOR_FILE
+ ERROR_INVALID_SERVER_STATE
+ ERROR_INVALID_SERVICENAME
+ ERROR_INVALID_SERVICE_ACCOUNT
+ ERROR_INVALID_SERVICE_CONTROL
+ ERROR_INVALID_SERVICE_LOCK
+ ERROR_INVALID_SHARENAME
+ ERROR_INVALID_SHOWWIN_COMMAND
+ ERROR_INVALID_SID
+ ERROR_INVALID_SIGNAL_NUMBER
+ ERROR_INVALID_SPI_VALUE
+ ERROR_INVALID_STACKSEG
+ ERROR_INVALID_STARTING_CODESEG
+ ERROR_INVALID_SUB_AUTHORITY
+ ERROR_INVALID_TARGET_HANDLE
+ ERROR_INVALID_THREAD_ID
+ ERROR_INVALID_TIME
+ ERROR_INVALID_USER_BUFFER
+ ERROR_INVALID_VERIFY_SWITCH
+ ERROR_INVALID_WINDOW_HANDLE
+ ERROR_INVALID_WINDOW_STYLE
+ ERROR_INVALID_WORKSTATION
+ ERROR_IOPL_NOT_ENABLED
+ ERROR_IO_DEVICE
+ ERROR_IO_INCOMPLETE
+ ERROR_IO_PENDING
+ ERROR_IRQ_BUSY
+ ERROR_IS_JOINED
+ ERROR_IS_JOIN_PATH
+ ERROR_IS_JOIN_TARGET
+ ERROR_IS_SUBSTED
+ ERROR_IS_SUBST_PATH
+ ERROR_IS_SUBST_TARGET
+ ERROR_ITERATED_DATA_EXCEEDS_64k
+ ERROR_JOIN_TO_JOIN
+ ERROR_JOIN_TO_SUBST
+ ERROR_JOURNAL_HOOK_SET
+ ERROR_KEY_DELETED
+ ERROR_KEY_HAS_CHILDREN
+ ERROR_LABEL_TOO_LONG
+ ERROR_LAST_ADMIN
+ ERROR_LB_WITHOUT_TABSTOPS
+ ERROR_LISTBOX_ID_NOT_FOUND
+ ERROR_LM_CROSS_ENCRYPTION_REQUIRED
+ ERROR_LOCAL_USER_SESSION_KEY
+ ERROR_LOCKED
+ ERROR_LOCK_FAILED
+ ERROR_LOCK_VIOLATION
+ ERROR_LOGIN_TIME_RESTRICTION
+ ERROR_LOGIN_WKSTA_RESTRICTION
+ ERROR_LOGON_FAILURE
+ ERROR_LOGON_NOT_GRANTED
+ ERROR_LOGON_SESSION_COLLISION
+ ERROR_LOGON_SESSION_EXISTS
+ ERROR_LOGON_TYPE_NOT_GRANTED
+ ERROR_LOG_FILE_FULL
+ ERROR_LUIDS_EXHAUSTED
+ ERROR_MAPPED_ALIGNMENT
+ ERROR_MAX_THRDS_REACHED
+ ERROR_MEDIA_CHANGED
+ ERROR_MEMBERS_PRIMARY_GROUP
+ ERROR_MEMBER_IN_ALIAS
+ ERROR_MEMBER_IN_GROUP
+ ERROR_MEMBER_NOT_IN_ALIAS
+ ERROR_MEMBER_NOT_IN_GROUP
+ ERROR_METAFILE_NOT_SUPPORTED
+ ERROR_META_EXPANSION_TOO_LONG
+ ERROR_MOD_NOT_FOUND
+ ERROR_MORE_DATA
+ ERROR_MORE_WRITES
+ ERROR_MR_MID_NOT_FOUND
+ ERROR_NEGATIVE_SEEK
+ ERROR_NESTING_NOT_ALLOWED
+ ERROR_NETLOGON_NOT_STARTED
+ ERROR_NETNAME_DELETED
+ ERROR_NETWORK_ACCESS_DENIED
+ ERROR_NETWORK_BUSY
+ ERROR_NETWORK_UNREACHABLE
+ ERROR_NET_WRITE_FAULT
+ ERROR_NOACCESS
+ ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT
+ ERROR_NOLOGON_SERVER_TRUST_ACCOUNT
+ ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT
+ ERROR_NONE_MAPPED
+ ERROR_NON_MDICHILD_WINDOW
+ ERROR_NOTIFY_ENUM_DIR
+ ERROR_NOT_ALL_ASSIGNED
+ ERROR_NOT_CHILD_WINDOW
+ ERROR_NOT_CONNECTED
+ ERROR_NOT_CONTAINER
+ ERROR_NOT_DOS_DISK
+ ERROR_NOT_ENOUGH_MEMORY
+ ERROR_NOT_ENOUGH_QUOTA
+ ERROR_NOT_ENOUGH_SERVER_MEMORY
+ ERROR_NOT_JOINED
+ ERROR_NOT_LOCKED
+ ERROR_NOT_LOGON_PROCESS
+ ERROR_NOT_OWNER
+ ERROR_NOT_READY
+ ERROR_NOT_REGISTRY_FILE
+ ERROR_NOT_SAME_DEVICE
+ ERROR_NOT_SUBSTED
+ ERROR_NOT_SUPPORTED
+ ERROR_NO_BROWSER_SERVERS_FOUND
+ ERROR_NO_DATA
+ ERROR_NO_DATA_DETECTED
+ ERROR_NO_IMPERSONATION_TOKEN
+ ERROR_NO_INHERITANCE
+ ERROR_NO_LOGON_SERVERS
+ ERROR_NO_LOG_SPACE
+ ERROR_NO_MEDIA_IN_DRIVE
+ ERROR_NO_MORE_FILES
+ ERROR_NO_MORE_ITEMS
+ ERROR_NO_MORE_SEARCH_HANDLES
+ ERROR_NO_NETWORK
+ ERROR_NO_NET_OR_BAD_PATH
+ ERROR_NO_PROC_SLOTS
+ ERROR_NO_QUOTAS_FOR_ACCOUNT
+ ERROR_NO_SCROLLBARS
+ ERROR_NO_SECURITY_ON_OBJECT
+ ERROR_NO_SHUTDOWN_IN_PROGRESS
+ ERROR_NO_SIGNAL_SENT
+ ERROR_NO_SPOOL_SPACE
+ ERROR_NO_SUCH_ALIAS
+ ERROR_NO_SUCH_DOMAIN
+ ERROR_NO_SUCH_GROUP
+ ERROR_NO_SUCH_LOGON_SESSION
+ ERROR_NO_SUCH_MEMBER
+ ERROR_NO_SUCH_PACKAGE
+ ERROR_NO_SUCH_PRIVILEGE
+ ERROR_NO_SUCH_USER
+ ERROR_NO_SYSTEM_MENU
+ ERROR_NO_TOKEN
+ ERROR_NO_TRUST_LSA_SECRET
+ ERROR_NO_TRUST_SAM_ACCOUNT
+ ERROR_NO_UNICODE_TRANSLATION
+ ERROR_NO_USER_SESSION_KEY
+ ERROR_NO_VOLUME_LABEL
+ ERROR_NO_WILDCARD_CHARACTERS
+ ERROR_NT_CROSS_ENCRYPTION_REQUIRED
+ ERROR_NULL_LM_PASSWORD
+ ERROR_OPEN_FAILED
+ ERROR_OPEN_FILES
+ ERROR_OPERATION_ABORTED
+ ERROR_OUTOFMEMORY
+ ERROR_OUT_OF_PAPER
+ ERROR_OUT_OF_STRUCTURES
+ ERROR_PARTIAL_COPY
+ ERROR_PARTITION_FAILURE
+ ERROR_PASSWORD_EXPIRED
+ ERROR_PASSWORD_MUST_CHANGE
+ ERROR_PASSWORD_RESTRICTION
+ ERROR_PATH_BUSY
+ ERROR_PATH_NOT_FOUND
+ ERROR_PIPE_BUSY
+ ERROR_PIPE_CONNECTED
+ ERROR_PIPE_LISTENING
+ ERROR_PIPE_NOT_CONNECTED
+ ERROR_POPUP_ALREADY_ACTIVE
+ ERROR_PORT_UNREACHABLE
+ ERROR_POSSIBLE_DEADLOCK
+ ERROR_PRINTER_ALREADY_EXISTS
+ ERROR_PRINTER_DELETED
+ ERROR_PRINTER_DRIVER_ALREADY_INSTALLED
+ ERROR_PRINTER_DRIVER_IN_USE
+ ERROR_PRINTQ_FULL
+ ERROR_PRINT_CANCELLED
+ ERROR_PRINT_MONITOR_ALREADY_INSTALLED
+ ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED
+ ERROR_PRIVATE_DIALOG_INDEX
+ ERROR_PRIVILEGE_NOT_HELD
+ ERROR_PROCESS_ABORTED
+ ERROR_PROC_NOT_FOUND
+ ERROR_PROTOCOL_UNREACHABLE
+ ERROR_READ_FAULT
+ ERROR_REC_NON_EXISTENT
+ ERROR_REDIRECTOR_HAS_OPEN_HANDLES
+ ERROR_REDIR_PAUSED
+ ERROR_REGISTRY_CORRUPT
+ ERROR_REGISTRY_IO_FAILED
+ ERROR_REGISTRY_RECOVERED
+ ERROR_RELOC_CHAIN_XEEDS_SEGLIM
+ ERROR_REMOTE_SESSION_LIMIT_EXCEEDED
+ ERROR_REM_NOT_LIST
+ ERROR_REQUEST_ABORTED
+ ERROR_REQ_NOT_ACCEP
+ ERROR_RESOURCE_DATA_NOT_FOUND
+ ERROR_RESOURCE_LANG_NOT_FOUND
+ ERROR_RESOURCE_NAME_NOT_FOUND
+ ERROR_RESOURCE_TYPE_NOT_FOUND
+ ERROR_RETRY
+ ERROR_REVISION_MISMATCH
+ ERROR_RING2SEG_MUST_BE_MOVABLE
+ ERROR_RING2_STACK_IN_USE
+ ERROR_RPL_NOT_ALLOWED
+ ERROR_RXACT_COMMIT_FAILURE
+ ERROR_RXACT_INVALID_STATE
+ ERROR_SAME_DRIVE
+ ERROR_SCREEN_ALREADY_LOCKED
+ ERROR_SECRET_TOO_LONG
+ ERROR_SECTOR_NOT_FOUND
+ ERROR_SEEK
+ ERROR_SEEK_ON_DEVICE
+ ERROR_SEM_IS_SET
+ ERROR_SEM_NOT_FOUND
+ ERROR_SEM_OWNER_DIED
+ ERROR_SEM_TIMEOUT
+ ERROR_SEM_USER_LIMIT
+ ERROR_SERIAL_NO_DEVICE
+ ERROR_SERVER_DISABLED
+ ERROR_SERVER_HAS_OPEN_HANDLES
+ ERROR_SERVER_NOT_DISABLED
+ ERROR_SERVICE_ALREADY_RUNNING
+ ERROR_SERVICE_CANNOT_ACCEPT_CTRL
+ ERROR_SERVICE_DATABASE_LOCKED
+ ERROR_SERVICE_DEPENDENCY_DELETED
+ ERROR_SERVICE_DEPENDENCY_FAIL
+ ERROR_SERVICE_DISABLED
+ ERROR_SERVICE_DOES_NOT_EXIST
+ ERROR_SERVICE_EXISTS
+ ERROR_SERVICE_LOGON_FAILED
+ ERROR_SERVICE_MARKED_FOR_DELETE
+ ERROR_SERVICE_NEVER_STARTED
+ ERROR_SERVICE_NOT_ACTIVE
+ ERROR_SERVICE_NOT_FOUND
+ ERROR_SERVICE_NO_THREAD
+ ERROR_SERVICE_REQUEST_TIMEOUT
+ ERROR_SERVICE_SPECIFIC_ERROR
+ ERROR_SERVICE_START_HANG
+ ERROR_SESSION_CREDENTIAL_CONFLICT
+ ERROR_SETCOUNT_ON_BAD_LB
+ ERROR_SETMARK_DETECTED
+ ERROR_SHARING_BUFFER_EXCEEDED
+ ERROR_SHARING_PAUSED
+ ERROR_SHARING_VIOLATION
+ ERROR_SHUTDOWN_IN_PROGRESS
+ ERROR_SIGNAL_PENDING
+ ERROR_SIGNAL_REFUSED
+ ERROR_SOME_NOT_MAPPED
+ ERROR_SPECIAL_ACCOUNT
+ ERROR_SPECIAL_GROUP
+ ERROR_SPECIAL_USER
+ ERROR_SPL_NO_ADDJOB
+ ERROR_SPL_NO_STARTDOC
+ ERROR_SPOOL_FILE_NOT_FOUND
+ ERROR_STACK_OVERFLOW
+ ERROR_STATIC_INIT
+ ERROR_SUBST_TO_JOIN
+ ERROR_SUBST_TO_SUBST
+ ERROR_SUCCESS
+ ERROR_SWAPERROR
+ ERROR_SYSTEM_TRACE
+ ERROR_THREAD_1_INACTIVE
+ ERROR_TLW_WITH_WSCHILD
+ ERROR_TOKEN_ALREADY_IN_USE
+ ERROR_TOO_MANY_CMDS
+ ERROR_TOO_MANY_CONTEXT_IDS
+ ERROR_TOO_MANY_LUIDS_REQUESTED
+ ERROR_TOO_MANY_MODULES
+ ERROR_TOO_MANY_MUXWAITERS
+ ERROR_TOO_MANY_NAMES
+ ERROR_TOO_MANY_OPEN_FILES
+ ERROR_TOO_MANY_POSTS
+ ERROR_TOO_MANY_SECRETS
+ ERROR_TOO_MANY_SEMAPHORES
+ ERROR_TOO_MANY_SEM_REQUESTS
+ ERROR_TOO_MANY_SESS
+ ERROR_TOO_MANY_SIDS
+ ERROR_TOO_MANY_TCBS
+ ERROR_TRANSFORM_NOT_SUPPORTED
+ ERROR_TRUSTED_DOMAIN_FAILURE
+ ERROR_TRUSTED_RELATIONSHIP_FAILURE
+ ERROR_TRUST_FAILURE
+ ERROR_UNABLE_TO_LOCK_MEDIA
+ ERROR_UNABLE_TO_UNLOAD_MEDIA
+ ERROR_UNEXP_NET_ERR
+ ERROR_UNKNOWN_PORT
+ ERROR_UNKNOWN_PRINTER_DRIVER
+ ERROR_UNKNOWN_PRINTPROCESSOR
+ ERROR_UNKNOWN_PRINT_MONITOR
+ ERROR_UNKNOWN_REVISION
+ ERROR_UNRECOGNIZED_MEDIA
+ ERROR_UNRECOGNIZED_VOLUME
+ ERROR_USER_EXISTS
+ ERROR_USER_MAPPED_FILE
+ ERROR_VC_DISCONNECTED
+ ERROR_WAIT_NO_CHILDREN
+ ERROR_WINDOW_NOT_COMBOBOX
+ ERROR_WINDOW_NOT_DIALOG
+ ERROR_WINDOW_OF_OTHER_THREAD
+ ERROR_WINS_INTERNAL
+ ERROR_WRITE_FAULT
+ ERROR_WRITE_PROTECT
+ ERROR_WRONG_DISK
+ ERROR_WRONG_PASSWORD
+ E_ABORT
+ E_ACCESSDENIED
+ E_FAIL
+ E_HANDLE
+ E_INVALIDARG
+ E_NOINTERFACE
+ E_NOTIMPL
+ E_OUTOFMEMORY
+ E_POINTER
+ E_UNEXPECTED
+ FACILITY_CONTROL
+ FACILITY_DISPATCH
+ FACILITY_ITF
+ FACILITY_NT_BIT
+ FACILITY_NULL
+ FACILITY_RPC
+ FACILITY_STORAGE
+ FACILITY_WIN32
+ FACILITY_WINDOWS
+ INPLACE_E_FIRST
+ INPLACE_E_LAST
+ INPLACE_E_NOTOOLSPACE
+ INPLACE_E_NOTUNDOABLE
+ INPLACE_S_FIRST
+ INPLACE_S_LAST
+ INPLACE_S_TRUNCATED
+ MARSHAL_E_FIRST
+ MARSHAL_E_LAST
+ MARSHAL_S_FIRST
+ MARSHAL_S_LAST
+ MEM_E_INVALID_LINK
+ MEM_E_INVALID_ROOT
+ MEM_E_INVALID_SIZE
+ MK_E_CANTOPENFILE
+ MK_E_CONNECTMANUALLY
+ MK_E_ENUMERATION_FAILED
+ MK_E_EXCEEDEDDEADLINE
+ MK_E_FIRST
+ MK_E_INTERMEDIATEINTERFACENOTSUPPORTED
+ MK_E_INVALIDEXTENSION
+ MK_E_LAST
+ MK_E_MUSTBOTHERUSER
+ MK_E_NEEDGENERIC
+ MK_E_NOINVERSE
+ MK_E_NOOBJECT
+ MK_E_NOPREFIX
+ MK_E_NOSTORAGE
+ MK_E_NOTBINDABLE
+ MK_E_NOTBOUND
+ MK_E_NO_NORMALIZED
+ MK_E_SYNTAX
+ MK_E_UNAVAILABLE
+ MK_S_FIRST
+ MK_S_HIM
+ MK_S_LAST
+ MK_S_ME
+ MK_S_MONIKERALREADYREGISTERED
+ MK_S_REDUCED_TO_SELF
+ MK_S_US
+ NOERROR
+ NO_ERROR
+ OLEOBJ_E_FIRST
+ OLEOBJ_E_INVALIDVERB
+ OLEOBJ_E_LAST
+ OLEOBJ_E_NOVERBS
+ OLEOBJ_S_CANNOT_DOVERB_NOW
+ OLEOBJ_S_FIRST
+ OLEOBJ_S_INVALIDHWND
+ OLEOBJ_S_INVALIDVERB
+ OLEOBJ_S_LAST
+ OLE_E_ADVF
+ OLE_E_ADVISENOTSUPPORTED
+ OLE_E_BLANK
+ OLE_E_CANTCONVERT
+ OLE_E_CANT_BINDTOSOURCE
+ OLE_E_CANT_GETMONIKER
+ OLE_E_CLASSDIFF
+ OLE_E_ENUM_NOMORE
+ OLE_E_FIRST
+ OLE_E_INVALIDHWND
+ OLE_E_INVALIDRECT
+ OLE_E_LAST
+ OLE_E_NOCACHE
+ OLE_E_NOCONNECTION
+ OLE_E_NOSTORAGE
+ OLE_E_NOTRUNNING
+ OLE_E_NOT_INPLACEACTIVE
+ OLE_E_OLEVERB
+ OLE_E_PROMPTSAVECANCELLED
+ OLE_E_STATIC
+ OLE_E_WRONGCOMPOBJ
+ OLE_S_FIRST
+ OLE_S_LAST
+ OLE_S_MAC_CLIPFORMAT
+ OLE_S_STATIC
+ OLE_S_USEREG
+ REGDB_E_CLASSNOTREG
+ REGDB_E_FIRST
+ REGDB_E_IIDNOTREG
+ REGDB_E_INVALIDVALUE
+ REGDB_E_KEYMISSING
+ REGDB_E_LAST
+ REGDB_E_READREGDB
+ REGDB_E_WRITEREGDB
+ REGDB_S_FIRST
+ REGDB_S_LAST
+ RPC_E_ATTEMPTED_MULTITHREAD
+ RPC_E_CALL_CANCELED
+ RPC_E_CALL_REJECTED
+ RPC_E_CANTCALLOUT_AGAIN
+ RPC_E_CANTCALLOUT_INASYNCCALL
+ RPC_E_CANTCALLOUT_INEXTERNALCALL
+ RPC_E_CANTCALLOUT_ININPUTSYNCCALL
+ RPC_E_CANTPOST_INSENDCALL
+ RPC_E_CANTTRANSMIT_CALL
+ RPC_E_CHANGED_MODE
+ RPC_E_CLIENT_CANTMARSHAL_DATA
+ RPC_E_CLIENT_CANTUNMARSHAL_DATA
+ RPC_E_CLIENT_DIED
+ RPC_E_CONNECTION_TERMINATED
+ RPC_E_DISCONNECTED
+ RPC_E_FAULT
+ RPC_E_INVALIDMETHOD
+ RPC_E_INVALID_CALLDATA
+ RPC_E_INVALID_DATA
+ RPC_E_INVALID_DATAPACKET
+ RPC_E_INVALID_PARAMETER
+ RPC_E_NOT_REGISTERED
+ RPC_E_OUT_OF_RESOURCES
+ RPC_E_RETRY
+ RPC_E_SERVERCALL_REJECTED
+ RPC_E_SERVERCALL_RETRYLATER
+ RPC_E_SERVERFAULT
+ RPC_E_SERVER_CANTMARSHAL_DATA
+ RPC_E_SERVER_CANTUNMARSHAL_DATA
+ RPC_E_SERVER_DIED
+ RPC_E_SERVER_DIED_DNE
+ RPC_E_SYS_CALL_FAILED
+ RPC_E_THREAD_NOT_INIT
+ RPC_E_UNEXPECTED
+ RPC_E_WRONG_THREAD
+ RPC_S_ADDRESS_ERROR
+ RPC_S_ALREADY_LISTENING
+ RPC_S_ALREADY_REGISTERED
+ RPC_S_BINDING_HAS_NO_AUTH
+ RPC_S_BINDING_INCOMPLETE
+ RPC_S_CALL_CANCELLED
+ RPC_S_CALL_FAILED
+ RPC_S_CALL_FAILED_DNE
+ RPC_S_CALL_IN_PROGRESS
+ RPC_S_CANNOT_SUPPORT
+ RPC_S_CANT_CREATE_ENDPOINT
+ RPC_S_COMM_FAILURE
+ RPC_S_DUPLICATE_ENDPOINT
+ RPC_S_ENTRY_ALREADY_EXISTS
+ RPC_S_ENTRY_NOT_FOUND
+ RPC_S_FP_DIV_ZERO
+ RPC_S_FP_OVERFLOW
+ RPC_S_FP_UNDERFLOW
+ RPC_S_GROUP_MEMBER_NOT_FOUND
+ RPC_S_INCOMPLETE_NAME
+ RPC_S_INTERFACE_NOT_FOUND
+ RPC_S_INTERNAL_ERROR
+ RPC_S_INVALID_AUTH_IDENTITY
+ RPC_S_INVALID_BINDING
+ RPC_S_INVALID_BOUND
+ RPC_S_INVALID_ENDPOINT_FORMAT
+ RPC_S_INVALID_NAF_ID
+ RPC_S_INVALID_NAME_SYNTAX
+ RPC_S_INVALID_NETWORK_OPTIONS
+ RPC_S_INVALID_NET_ADDR
+ RPC_S_INVALID_OBJECT
+ RPC_S_INVALID_RPC_PROTSEQ
+ RPC_S_INVALID_STRING_BINDING
+ RPC_S_INVALID_STRING_UUID
+ RPC_S_INVALID_TAG
+ RPC_S_INVALID_TIMEOUT
+ RPC_S_INVALID_VERS_OPTION
+ RPC_S_MAX_CALLS_TOO_SMALL
+ RPC_S_NAME_SERVICE_UNAVAILABLE
+ RPC_S_NOTHING_TO_EXPORT
+ RPC_S_NOT_ALL_OBJS_UNEXPORTED
+ RPC_S_NOT_CANCELLED
+ RPC_S_NOT_LISTENING
+ RPC_S_NOT_RPC_ERROR
+ RPC_S_NO_BINDINGS
+ RPC_S_NO_CALL_ACTIVE
+ RPC_S_NO_CONTEXT_AVAILABLE
+ RPC_S_NO_ENDPOINT_FOUND
+ RPC_S_NO_ENTRY_NAME
+ RPC_S_NO_INTERFACES
+ RPC_S_NO_MORE_BINDINGS
+ RPC_S_NO_MORE_MEMBERS
+ RPC_S_NO_PRINC_NAME
+ RPC_S_NO_PROTSEQS
+ RPC_S_NO_PROTSEQS_REGISTERED
+ RPC_S_OBJECT_NOT_FOUND
+ RPC_S_OUT_OF_RESOURCES
+ RPC_S_PROCNUM_OUT_OF_RANGE
+ RPC_S_PROTOCOL_ERROR
+ RPC_S_PROTSEQ_NOT_FOUND
+ RPC_S_PROTSEQ_NOT_SUPPORTED
+ RPC_S_SEC_PKG_ERROR
+ RPC_S_SERVER_TOO_BUSY
+ RPC_S_SERVER_UNAVAILABLE
+ RPC_S_STRING_TOO_LONG
+ RPC_S_TYPE_ALREADY_REGISTERED
+ RPC_S_UNKNOWN_AUTHN_LEVEL
+ RPC_S_UNKNOWN_AUTHN_SERVICE
+ RPC_S_UNKNOWN_AUTHN_TYPE
+ RPC_S_UNKNOWN_AUTHZ_SERVICE
+ RPC_S_UNKNOWN_IF
+ RPC_S_UNKNOWN_MGR_TYPE
+ RPC_S_UNSUPPORTED_AUTHN_LEVEL
+ RPC_S_UNSUPPORTED_NAME_SYNTAX
+ RPC_S_UNSUPPORTED_TRANS_SYN
+ RPC_S_UNSUPPORTED_TYPE
+ RPC_S_UUID_LOCAL_ONLY
+ RPC_S_UUID_NO_ADDRESS
+ RPC_S_WRONG_KIND_OF_BINDING
+ RPC_S_ZERO_DIVIDE
+ RPC_X_BAD_STUB_DATA
+ RPC_X_BYTE_COUNT_TOO_SMALL
+ RPC_X_ENUM_VALUE_OUT_OF_RANGE
+ RPC_X_INVALID_ES_ACTION
+ RPC_X_NO_MORE_ENTRIES
+ RPC_X_NULL_REF_POINTER
+ RPC_X_SS_CANNOT_GET_CALL_HANDLE
+ RPC_X_SS_CHAR_TRANS_OPEN_FAIL
+ RPC_X_SS_CHAR_TRANS_SHORT_FILE
+ RPC_X_SS_CONTEXT_DAMAGED
+ RPC_X_SS_HANDLES_MISMATCH
+ RPC_X_SS_IN_NULL_CONTEXT
+ RPC_X_WRONG_ES_VERSION
+ RPC_X_WRONG_STUB_VERSION
+ SEVERITY_ERROR
+ SEVERITY_SUCCESS
+ STG_E_ABNORMALAPIEXIT
+ STG_E_ACCESSDENIED
+ STG_E_CANTSAVE
+ STG_E_DISKISWRITEPROTECTED
+ STG_E_EXTANTMARSHALLINGS
+ STG_E_FILEALREADYEXISTS
+ STG_E_FILENOTFOUND
+ STG_E_INSUFFICIENTMEMORY
+ STG_E_INUSE
+ STG_E_INVALIDFLAG
+ STG_E_INVALIDFUNCTION
+ STG_E_INVALIDHANDLE
+ STG_E_INVALIDHEADER
+ STG_E_INVALIDNAME
+ STG_E_INVALIDPARAMETER
+ STG_E_INVALIDPOINTER
+ STG_E_LOCKVIOLATION
+ STG_E_MEDIUMFULL
+ STG_E_NOMOREFILES
+ STG_E_NOTCURRENT
+ STG_E_NOTFILEBASEDSTORAGE
+ STG_E_OLDDLL
+ STG_E_OLDFORMAT
+ STG_E_PATHNOTFOUND
+ STG_E_READFAULT
+ STG_E_REVERTED
+ STG_E_SEEKERROR
+ STG_E_SHAREREQUIRED
+ STG_E_SHAREVIOLATION
+ STG_E_TOOMANYOPENFILES
+ STG_E_UNIMPLEMENTEDFUNCTION
+ STG_E_UNKNOWN
+ STG_E_WRITEFAULT
+ STG_S_CONVERTED
+ S_FALSE
+ S_OK
+ TYPE_E_AMBIGUOUSNAME
+ TYPE_E_BADMODULEKIND
+ TYPE_E_BUFFERTOOSMALL
+ TYPE_E_CANTCREATETMPFILE
+ TYPE_E_CANTLOADLIBRARY
+ TYPE_E_CIRCULARTYPE
+ TYPE_E_DLLFUNCTIONNOTFOUND
+ TYPE_E_DUPLICATEID
+ TYPE_E_ELEMENTNOTFOUND
+ TYPE_E_INCONSISTENTPROPFUNCS
+ TYPE_E_INVALIDID
+ TYPE_E_INVALIDSTATE
+ TYPE_E_INVDATAREAD
+ TYPE_E_IOERROR
+ TYPE_E_LIBNOTREGISTERED
+ TYPE_E_NAMECONFLICT
+ TYPE_E_OUTOFBOUNDS
+ TYPE_E_QUALIFIEDNAMEDISALLOWED
+ TYPE_E_REGISTRYACCESS
+ TYPE_E_SIZETOOBIG
+ TYPE_E_TYPEMISMATCH
+ TYPE_E_UNDEFINEDTYPE
+ TYPE_E_UNKNOWNLCID
+ TYPE_E_UNSUPFORMAT
+ TYPE_E_WRONGTYPEKIND
+ VIEW_E_DRAW
+ VIEW_E_FIRST
+ VIEW_E_LAST
+ VIEW_S_ALREADY_FROZEN
+ VIEW_S_FIRST
+ VIEW_S_LAST
+);
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function. If a constant is not found then control is passed
+ # to the AUTOLOAD in AutoLoader.
+
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ local $! = 0;
+ local $^E = 0;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Win32::WinError macro $constname, used at $file line $line.";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap Win32::WinError;
+
+# Preloaded methods go here.
+
+# Autoload methods go after __END__, and are processed by the autosplit program.
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32API/File.pm b/Master/tlpkg/tlperl.straw/lib/Win32API/File.pm
new file mode 100755
index 00000000000..a6473520ae0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32API/File.pm
@@ -0,0 +1,3035 @@
+# File.pm -- Low-level access to Win32 file/dir functions/constants.
+
+package Win32API::File;
+
+use strict;
+use integer;
+use Carp;
+use Config qw( %Config );
+use Fcntl qw( O_RDONLY O_RDWR O_WRONLY O_APPEND O_BINARY O_TEXT );
+use vars qw( $VERSION @ISA );
+use vars qw( @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS );
+
+$VERSION= '0.1101';
+
+use base qw( Exporter DynaLoader Tie::Handle IO::File );
+
+# Math::BigInt optimizations courtesy of Tels
+my $_64BITINT;
+BEGIN {
+ $_64BITINT = defined($Config{use64bitint}) &&
+ ($Config{use64bitint} eq 'define');
+
+ require Math::BigInt unless $_64BITINT;
+}
+
+my $THIRTY_TWO = $_64BITINT ? 32 : Math::BigInt->new(32);
+
+my $FFFFFFFF = $_64BITINT ? 0xFFFFFFFF : Math::BigInt->new(0xFFFFFFFF);
+
+@EXPORT= qw();
+%EXPORT_TAGS= (
+ Func => [qw( attrLetsToBits createFile
+ fileConstant fileLastError getLogicalDrives
+ CloseHandle CopyFile CreateFile
+ DefineDosDevice DeleteFile DeviceIoControl
+ FdGetOsFHandle GetDriveType GetFileAttributes GetFileType
+ GetHandleInformation GetLogicalDrives GetLogicalDriveStrings
+ GetOsFHandle GetVolumeInformation IsRecognizedPartition
+ IsContainerPartition MoveFile MoveFileEx
+ OsFHandleOpen OsFHandleOpenFd QueryDosDevice
+ ReadFile SetErrorMode SetFilePointer
+ SetHandleInformation WriteFile GetFileSize
+ getFileSize setFilePointer GetOverlappedResult)],
+ FuncA => [qw(
+ CopyFileA CreateFileA DefineDosDeviceA
+ DeleteFileA GetDriveTypeA GetFileAttributesA GetLogicalDriveStringsA
+ GetVolumeInformationA MoveFileA MoveFileExA
+ QueryDosDeviceA )],
+ FuncW => [qw(
+ CopyFileW CreateFileW DefineDosDeviceW
+ DeleteFileW GetDriveTypeW GetFileAttributesW GetLogicalDriveStringsW
+ GetVolumeInformationW MoveFileW MoveFileExW
+ QueryDosDeviceW )],
+ Misc => [qw(
+ CREATE_ALWAYS CREATE_NEW FILE_BEGIN
+ FILE_CURRENT FILE_END INVALID_HANDLE_VALUE
+ OPEN_ALWAYS OPEN_EXISTING TRUNCATE_EXISTING )],
+ DDD_ => [qw(
+ DDD_EXACT_MATCH_ON_REMOVE DDD_RAW_TARGET_PATH
+ DDD_REMOVE_DEFINITION )],
+ DRIVE_ => [qw(
+ DRIVE_UNKNOWN DRIVE_NO_ROOT_DIR DRIVE_REMOVABLE
+ DRIVE_FIXED DRIVE_REMOTE DRIVE_CDROM
+ DRIVE_RAMDISK )],
+ FILE_ => [qw(
+ FILE_READ_DATA FILE_LIST_DIRECTORY
+ FILE_WRITE_DATA FILE_ADD_FILE
+ FILE_APPEND_DATA FILE_ADD_SUBDIRECTORY
+ FILE_CREATE_PIPE_INSTANCE FILE_READ_EA
+ FILE_WRITE_EA FILE_EXECUTE
+ FILE_TRAVERSE FILE_DELETE_CHILD
+ FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES
+ FILE_ALL_ACCESS FILE_GENERIC_READ
+ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE )],
+ FILE_ATTRIBUTE_ => [qw(
+ INVALID_FILE_ATTRIBUTES
+ FILE_ATTRIBUTE_DEVICE FILE_ATTRIBUTE_DIRECTORY
+ FILE_ATTRIBUTE_ENCRYPTED FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
+ FILE_ATTRIBUTE_REPARSE_POINT FILE_ATTRIBUTE_SPARSE_FILE
+ FILE_ATTRIBUTE_ARCHIVE FILE_ATTRIBUTE_COMPRESSED
+ FILE_ATTRIBUTE_HIDDEN FILE_ATTRIBUTE_NORMAL
+ FILE_ATTRIBUTE_OFFLINE FILE_ATTRIBUTE_READONLY
+ FILE_ATTRIBUTE_SYSTEM FILE_ATTRIBUTE_TEMPORARY )],
+ FILE_FLAG_ => [qw(
+ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_DELETE_ON_CLOSE
+ FILE_FLAG_NO_BUFFERING FILE_FLAG_OVERLAPPED
+ FILE_FLAG_POSIX_SEMANTICS FILE_FLAG_RANDOM_ACCESS
+ FILE_FLAG_SEQUENTIAL_SCAN FILE_FLAG_WRITE_THROUGH
+ FILE_FLAG_OPEN_REPARSE_POINT )],
+ FILE_SHARE_ => [qw(
+ FILE_SHARE_DELETE FILE_SHARE_READ FILE_SHARE_WRITE )],
+ FILE_TYPE_ => [qw(
+ FILE_TYPE_CHAR FILE_TYPE_DISK FILE_TYPE_PIPE
+ FILE_TYPE_UNKNOWN )],
+ FS_ => [qw(
+ FS_CASE_IS_PRESERVED FS_CASE_SENSITIVE
+ FS_UNICODE_STORED_ON_DISK FS_PERSISTENT_ACLS
+ FS_FILE_COMPRESSION FS_VOL_IS_COMPRESSED )],
+ FSCTL_ => [qw(
+ FSCTL_SET_REPARSE_POINT FSCTL_GET_REPARSE_POINT
+ FSCTL_DELETE_REPARSE_POINT )],
+ HANDLE_FLAG_ => [qw(
+ HANDLE_FLAG_INHERIT HANDLE_FLAG_PROTECT_FROM_CLOSE )],
+ IOCTL_STORAGE_ => [qw(
+ IOCTL_STORAGE_CHECK_VERIFY IOCTL_STORAGE_MEDIA_REMOVAL
+ IOCTL_STORAGE_EJECT_MEDIA IOCTL_STORAGE_LOAD_MEDIA
+ IOCTL_STORAGE_RESERVE IOCTL_STORAGE_RELEASE
+ IOCTL_STORAGE_FIND_NEW_DEVICES IOCTL_STORAGE_GET_MEDIA_TYPES
+ )],
+ IOCTL_DISK_ => [qw(
+ IOCTL_DISK_FORMAT_TRACKS IOCTL_DISK_FORMAT_TRACKS_EX
+ IOCTL_DISK_GET_DRIVE_GEOMETRY IOCTL_DISK_GET_DRIVE_LAYOUT
+ IOCTL_DISK_GET_MEDIA_TYPES IOCTL_DISK_GET_PARTITION_INFO
+ IOCTL_DISK_HISTOGRAM_DATA IOCTL_DISK_HISTOGRAM_RESET
+ IOCTL_DISK_HISTOGRAM_STRUCTURE IOCTL_DISK_IS_WRITABLE
+ IOCTL_DISK_LOGGING IOCTL_DISK_PERFORMANCE
+ IOCTL_DISK_REASSIGN_BLOCKS IOCTL_DISK_REQUEST_DATA
+ IOCTL_DISK_REQUEST_STRUCTURE IOCTL_DISK_SET_DRIVE_LAYOUT
+ IOCTL_DISK_SET_PARTITION_INFO IOCTL_DISK_VERIFY )],
+ GENERIC_ => [qw(
+ GENERIC_ALL GENERIC_EXECUTE
+ GENERIC_READ GENERIC_WRITE )],
+ MEDIA_TYPE => [qw(
+ Unknown F5_1Pt2_512 F3_1Pt44_512
+ F3_2Pt88_512 F3_20Pt8_512 F3_720_512
+ F5_360_512 F5_320_512 F5_320_1024
+ F5_180_512 F5_160_512 RemovableMedia
+ FixedMedia F3_120M_512 )],
+ MOVEFILE_ => [qw(
+ MOVEFILE_COPY_ALLOWED MOVEFILE_DELAY_UNTIL_REBOOT
+ MOVEFILE_REPLACE_EXISTING MOVEFILE_WRITE_THROUGH )],
+ SECURITY_ => [qw(
+ SECURITY_ANONYMOUS SECURITY_CONTEXT_TRACKING
+ SECURITY_DELEGATION SECURITY_EFFECTIVE_ONLY
+ SECURITY_IDENTIFICATION SECURITY_IMPERSONATION
+ SECURITY_SQOS_PRESENT )],
+ SEM_ => [qw(
+ SEM_FAILCRITICALERRORS SEM_NOGPFAULTERRORBOX
+ SEM_NOALIGNMENTFAULTEXCEPT SEM_NOOPENFILEERRORBOX )],
+ PARTITION_ => [qw(
+ PARTITION_ENTRY_UNUSED PARTITION_FAT_12
+ PARTITION_XENIX_1 PARTITION_XENIX_2
+ PARTITION_FAT_16 PARTITION_EXTENDED
+ PARTITION_HUGE PARTITION_IFS
+ PARTITION_FAT32 PARTITION_FAT32_XINT13
+ PARTITION_XINT13 PARTITION_XINT13_EXTENDED
+ PARTITION_PREP PARTITION_UNIX
+ VALID_NTFT PARTITION_NTFT )],
+);
+@EXPORT_OK= ();
+{
+ my $key;
+ foreach $key ( keys(%EXPORT_TAGS) ) {
+ push( @EXPORT_OK, @{$EXPORT_TAGS{$key}} );
+ #push( @EXPORT_FAIL, @{$EXPORT_TAGS{$key}} ) unless $key =~ /^Func/;
+ }
+}
+$EXPORT_TAGS{ALL}= \@EXPORT_OK;
+
+bootstrap Win32API::File $VERSION;
+
+# Preloaded methods go here.
+
+# To convert C constants to Perl code in cFile.pc
+# [instead of C or C++ code in cFile.h]:
+# * Modify F<Makefile.PL> to add WriteMakeFile() =>
+# CONST2PERL/postamble => [[ "Win32API::File" => ]] WRITE_PERL => 1.
+# * Either comment out C<#include "cFile.h"> from F<File.xs>
+# or make F<cFile.h> an empty file.
+# * Make sure the following C<if> block is not commented out.
+# * "nmake clean", "perl Makefile.PL", "nmake"
+
+if( ! defined &GENERIC_READ ) {
+ require "Win32API/File/cFile.pc";
+}
+
+sub fileConstant
+{
+ my( $name )= @_;
+ if( 1 != @_ || ! $name || $name =~ /\W/ ) {
+ require Carp;
+ Carp::croak( 'Usage: ',__PACKAGE__,'::fileConstant("CONST_NAME")' );
+ }
+ my $proto= prototype $name;
+ if( defined \&$name
+ && defined $proto
+ && "" eq $proto ) {
+ no strict 'refs';
+ return &$name;
+ }
+ return undef;
+}
+
+# We provide this for backwards compatibility:
+sub constant
+{
+ my( $name )= @_;
+ my $value= fileConstant( $name );
+ if( defined $value ) {
+ $!= 0;
+ return $value;
+ }
+ $!= 11; # EINVAL
+ return 0;
+}
+
+# BEGIN {
+# my $code= 'return _fileLastError(@_)';
+# local( $!, $^E )= ( 1, 1 );
+# if( $! ne $^E ) {
+# $code= '
+# local( $^E )= _fileLastError(@_);
+# my $ret= $^E;
+# return $ret;
+# ';
+# }
+# eval "sub fileLastError { $code }";
+# die "$@" if $@;
+# }
+
+package Win32API::File::_error;
+
+use overload
+ '""' => sub {
+ require Win32 unless defined &Win32::FormatMessage;
+ $_ = Win32::FormatMessage(Win32API::File::_fileLastError());
+ tr/\r\n//d;
+ return $_;
+ },
+ '0+' => sub { Win32API::File::_fileLastError() },
+ 'fallback' => 1;
+
+sub new { return bless {}, shift }
+sub set { Win32API::File::_fileLastError($_[1]); return $_[0] }
+
+package Win32API::File;
+
+my $_error = Win32API::File::_error->new();
+
+sub fileLastError {
+ croak 'Usage: ',__PACKAGE__,'::fileLastError( [$setWin32ErrCode] )' if @_ > 1;
+ $_error->set($_[0]) if defined $_[0];
+ return $_error;
+}
+
+# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we
+# need this next chunk to prevent Win32API::File->nonesuch() from
+# looking for "nonesuch.al" and producing confusing error messages:
+use vars qw($AUTOLOAD);
+sub AUTOLOAD {
+ require Carp;
+ Carp::croak(
+ "Can't locate method $AUTOLOAD via package Win32API::File" );
+}
+
+# Replace "&rout;" with "goto &rout;" when that is supported on Win32.
+
+# Aliases for non-Unicode functions:
+sub CopyFile { &CopyFileA; }
+sub CreateFile { &CreateFileA; }
+sub DefineDosDevice { &DefineDosDeviceA; }
+sub DeleteFile { &DeleteFileA; }
+sub GetDriveType { &GetDriveTypeA; }
+sub GetFileAttributes { &GetFileAttributesA; }
+sub GetLogicalDriveStrings { &GetLogicalDriveStringsA; }
+sub GetVolumeInformation { &GetVolumeInformationA; }
+sub MoveFile { &MoveFileA; }
+sub MoveFileEx { &MoveFileExA; }
+sub QueryDosDevice { &QueryDosDeviceA; }
+
+sub OsFHandleOpen {
+ if( 3 != @_ ) {
+ croak 'Win32API::File Usage: ',
+ 'OsFHandleOpen(FILE,$hNativeHandle,"rwatb")';
+ }
+ my( $fh, $osfh, $access )= @_;
+ if( ! ref($fh) ) {
+ if( $fh !~ /('|::)/ ) {
+ $fh= caller() . "::" . $fh;
+ }
+ no strict "refs";
+ $fh= \*{$fh};
+ }
+ my( $mode, $pref );
+ if( $access =~ /r/i ) {
+ if( $access =~ /w/i ) {
+ $mode= O_RDWR;
+ $pref= "+<";
+ } else {
+ $mode= O_RDONLY;
+ $pref= "<";
+ }
+ } else {
+ if( $access =~ /w/i ) {
+ $mode= O_WRONLY;
+ $pref= ">";
+ } else {
+ # croak qq<Win32API::File::OsFHandleOpen(): >,
+ # qq<Access ($access) missing both "r" and "w">;
+ $mode= O_RDONLY;
+ $pref= "<";
+ }
+ }
+ $mode |= O_APPEND if $access =~ /a/i;
+ #$mode |= O_TEXT if $access =~ /t/i;
+ # Some versions of the Fcntl module are broken and won't autoload O_TEXT:
+ if( $access =~ /t/i ) {
+ my $o_text= eval "O_TEXT";
+ $o_text= 0x4000 if $@;
+ $mode |= $o_text;
+ }
+ $mode |= O_BINARY if $access =~ /b/i;
+ my $fd = eval { OsFHandleOpenFd( $osfh, $mode ) };
+ if ($@) {
+ return tie *{$fh}, __PACKAGE__, $osfh;
+ }
+ return undef if $fd < 0;
+ return open( $fh, $pref."&=".$fd );
+}
+
+sub GetOsFHandle {
+ if( 1 != @_ ) {
+ croak 'Win32API::File Usage: $OsFHandle= GetOsFHandle(FILE)';
+ }
+ my( $file )= @_;
+ if( ! ref($file) ) {
+ if( $file !~ /('|::)/ ) {
+ $file= caller() . "::" . $file;
+ }
+ no strict "refs";
+ # The eval "" is necessary in Perl 5.6, avoid it otherwise.
+ my $tied = !defined($^]) || $^] < 5.008
+ ? eval "tied *{$file}"
+ : tied *{$file};
+
+ if (UNIVERSAL::isa($tied => __PACKAGE__)) {
+ return $tied->win32_handle;
+ }
+
+ $file= *{$file};
+ }
+ my( $fd )= fileno($file);
+ if( ! defined( $fd ) ) {
+ if( $file =~ /^\d+\Z/ ) {
+ $fd= $file;
+ } else {
+ return (); # $! should be set by fileno().
+ }
+ }
+ my $h= FdGetOsFHandle( $fd );
+ if( INVALID_HANDLE_VALUE() == $h ) {
+ $h= "";
+ } elsif( "0" eq $h ) {
+ $h= "0 but true";
+ }
+ return $h;
+}
+
+sub getFileSize {
+ croak 'Win32API::File Usage: $size= getFileSize($hNativeHandle)'
+ if @_ != 1;
+
+ my $handle = shift;
+ my $high_size = 0;
+
+ my $low_size = GetFileSize($handle, $high_size);
+
+ my $retval = $_64BITINT ? $high_size : Math::BigInt->new($high_size);
+
+ $retval <<= $THIRTY_TWO;
+ $retval += $low_size;
+
+ return $retval;
+}
+
+sub setFilePointer {
+ croak 'Win32API::File Usage: $pos= setFilePointer($hNativeHandle, $posl, $from_where)'
+ if @_ != 3;
+
+ my ($handle, $pos, $from_where) = @_;
+
+ my ($pos_low, $pos_high) = ($pos, 0);
+
+ if ($_64BITINT) {
+ $pos_low = ($pos & $FFFFFFFF);
+ $pos_high = (($pos >> $THIRTY_TWO) & $FFFFFFFF);
+ }
+ elsif (UNIVERSAL::isa($pos => 'Math::BigInt')) {
+ $pos_low = ($pos & $FFFFFFFF)->numify();
+ $pos_high = (($pos >> $THIRTY_TWO) & $FFFFFFFF)->numify();
+ }
+
+ my $retval = SetFilePointer($handle, $pos_low, $pos_high, $from_where);
+
+ if (defined $pos_high && $pos_high != 0) {
+ if (! $_64BITINT) {
+ $retval = Math::BigInt->new($retval);
+ $pos_high = Math::BigInt->new($pos_high);
+ }
+
+ $retval += $pos_high << $THIRTY_TWO;
+ }
+
+ return $retval;
+}
+
+sub attrLetsToBits
+{
+ my( $lets )= @_;
+ my( %a )= (
+ "a"=>FILE_ATTRIBUTE_ARCHIVE(), "c"=>FILE_ATTRIBUTE_COMPRESSED(),
+ "h"=>FILE_ATTRIBUTE_HIDDEN(), "o"=>FILE_ATTRIBUTE_OFFLINE(),
+ "r"=>FILE_ATTRIBUTE_READONLY(), "s"=>FILE_ATTRIBUTE_SYSTEM(),
+ "t"=>FILE_ATTRIBUTE_TEMPORARY() );
+ my( $bits )= 0;
+ foreach( split(//,$lets) ) {
+ croak "Win32API::File::attrLetsToBits: Unknown attribute letter ($_)"
+ unless exists $a{$_};
+ $bits |= $a{$_};
+ }
+ return $bits;
+}
+
+use vars qw( @_createFile_Opts %_createFile_Opts );
+@_createFile_Opts= qw( Access Create Share Attributes
+ Flags Security Model );
+@_createFile_Opts{@_createFile_Opts}= (1) x @_createFile_Opts;
+
+sub createFile
+{
+ my $opts= "";
+ if( 2 <= @_ && "HASH" eq ref($_[$#_]) ) {
+ $opts= pop( @_ );
+ }
+ my( $sPath, $svAccess, $svShare )= @_;
+ if( @_ < 1 || 3 < @_ ) {
+ croak "Win32API::File::createFile() usage: \$hObject= createFile(\n",
+ " \$sPath, [\$svAccess_qrw_ktn_ce,[\$svShare_rwd,]]",
+ " [{Option=>\$Value}] )\n",
+ " options: @_createFile_Opts\nCalled";
+ }
+ my( $create, $flags, $sec, $model )= ( "", 0, [], 0 );
+ if( ref($opts) ) {
+ my @err= grep( ! $_createFile_Opts{$_}, keys(%$opts) );
+ @err and croak "_createFile: Invalid options (@err)";
+ $flags= $opts->{Flags} if exists( $opts->{Flags} );
+ $flags |= attrLetsToBits( $opts->{Attributes} )
+ if exists( $opts->{Attributes} );
+ $sec= $opts->{Security} if exists( $opts->{Security} );
+ $model= $opts->{Model} if exists( $opts->{Model} );
+ $svAccess= $opts->{Access} if exists( $opts->{Access} );
+ $create= $opts->{Create} if exists( $opts->{Create} );
+ $svShare= $opts->{Share} if exists( $opts->{Share} );
+ }
+ $svAccess= "r" unless defined($svAccess);
+ $svShare= "rw" unless defined($svShare);
+ if( $svAccess =~ /^[qrw ktn ce]*$/i ) {
+ ( my $c= $svAccess ) =~ tr/qrw QRW//d;
+ $create= $c if "" ne $c && "" eq $create;
+ local( $_ )= $svAccess;
+ $svAccess= 0;
+ $svAccess |= GENERIC_READ() if /r/i;
+ $svAccess |= GENERIC_WRITE() if /w/i;
+ } elsif( "?" eq $svAccess ) {
+ croak
+ "Win32API::File::createFile: \$svAccess can use the following:\n",
+ " One or more of the following:\n",
+ "\tq -- Query access (same as 0)\n",
+ "\tr -- Read access (GENERIC_READ)\n",
+ "\tw -- Write access (GENERIC_WRITE)\n",
+ " At most one of the following:\n",
+ "\tk -- Keep if exists\n",
+ "\tt -- Truncate if exists\n",
+ "\tn -- New file only (fail if file already exists)\n",
+ " At most one of the following:\n",
+ "\tc -- Create if doesn't exist\n",
+ "\te -- Existing file only (fail if doesn't exist)\n",
+ " '' is the same as 'q k e'\n",
+ " 'r' is the same as 'r k e'\n",
+ " 'w' is the same as 'w t c'\n",
+ " 'rw' is the same as 'rw k c'\n",
+ " 'rt' or 'rn' implies 'c'.\n",
+ " Or \$svAccess can be numeric.\n", "Called from";
+ } elsif( $svAccess == 0 && $svAccess !~ /^[-+.]*0/ ) {
+ croak "Win32API::File::createFile: Invalid \$svAccess ($svAccess)";
+ }
+ if( $create =~ /^[ktn ce]*$/ ) {
+ local( $_ )= $create;
+ my( $k, $t, $n, $c, $e )= ( scalar(/k/i), scalar(/t/i),
+ scalar(/n/i), scalar(/c/i), scalar(/e/i) );
+ if( 1 < $k + $t + $n ) {
+ croak "Win32API::File::createFile: \$create must not use ",
+ qq<more than one of "k", "t", and "n" ($create)>;
+ }
+ if( $c && $e ) {
+ croak "Win32API::File::createFile: \$create must not use ",
+ qq<both "c" and "e" ($create)>;
+ }
+ my $r= ( $svAccess & GENERIC_READ() ) == GENERIC_READ();
+ my $w= ( $svAccess & GENERIC_WRITE() ) == GENERIC_WRITE();
+ if( ! $k && ! $t && ! $n ) {
+ if( $w && ! $r ) { $t= 1;
+ } else { $k= 1; }
+ }
+ if( $k ) {
+ if( $c || $w && ! $e ) { $create= OPEN_ALWAYS();
+ } else { $create= OPEN_EXISTING(); }
+ } elsif( $t ) {
+ if( $e ) { $create= TRUNCATE_EXISTING();
+ } else { $create= CREATE_ALWAYS(); }
+ } else { # $n
+ if( ! $e ) { $create= CREATE_NEW();
+ } else {
+ croak "Win32API::File::createFile: \$create must not use ",
+ qq<both "n" and "e" ($create)>;
+ }
+ }
+ } elsif( "?" eq $create ) {
+ croak 'Win32API::File::createFile: $create !~ /^[ktn ce]*$/;',
+ ' pass $svAccess as "?" for more information.';
+ } elsif( $create == 0 && $create ne "0" ) {
+ croak "Win32API::File::createFile: Invalid \$create ($create)";
+ }
+ if( $svShare =~ /^[drw]*$/ ) {
+ my %s= ( "d"=>FILE_SHARE_DELETE(), "r"=>FILE_SHARE_READ(),
+ "w"=>FILE_SHARE_WRITE() );
+ my @s= split(//,$svShare);
+ $svShare= 0;
+ foreach( @s ) {
+ $svShare |= $s{$_};
+ }
+ } elsif( $svShare == 0 && $svShare !~ /^[-+.]*0/ ) {
+ croak "Win32API::File::createFile: Invalid \$svShare ($svShare)";
+ }
+ return CreateFileA(
+ $sPath, $svAccess, $svShare, $sec, $create, $flags, $model );
+}
+
+
+sub getLogicalDrives
+{
+ my( $ref )= @_;
+ my $s= "";
+ if( ! GetLogicalDriveStringsA( 256, $s ) ) {
+ return undef;
+ }
+ if( ! defined($ref) ) {
+ return split( /\0/, $s );
+ } elsif( "ARRAY" ne ref($ref) ) {
+ croak 'Usage: C<@arr= getLogicalDrives()> ',
+ 'or C<getLogicalDrives(\\@arr)>', "\n";
+ }
+ @$ref= split( /\0/, $s );
+ return $ref;
+}
+
+###############################################################################
+# Experimental Tied Handle and Object Oriented interface. #
+###############################################################################
+
+sub new {
+ my $class = shift;
+ $class = ref $class || $class;
+
+ my $self = IO::File::new($class);
+ tie *$self, __PACKAGE__;
+
+ $self->open(@_) if @_;
+
+ return $self;
+}
+
+sub TIEHANDLE {
+ my ($class, $win32_handle) = @_;
+ $class = ref $class || $class;
+
+ return bless {
+ _win32_handle => $win32_handle,
+ _binmode => 0,
+ _buffered => 0,
+ _buffer => '',
+ _eof => 0,
+ _fileno => undef,
+ _access => 'r',
+ _append => 0,
+ }, $class;
+}
+
+# This is called for getting the tied object from hard refs to glob refs in
+# some cases, for reasons I don't quite grok.
+
+sub FETCH { return $_[0] }
+
+# Public accessors
+
+sub win32_handle{ $_[0]->{_win32_handle}||= $_[1] }
+
+# Protected accessors
+
+sub _buffer { $_[0]->{_buffer} ||= $_[1] }
+sub _binmode { $_[0]->{_binmode} ||= $_[1] }
+sub _fileno { $_[0]->{_fileno} ||= $_[1] }
+sub _access { $_[0]->{_access} ||= $_[1] }
+sub _append { $_[0]->{_append} ||= $_[1] }
+
+# Tie interface
+
+sub OPEN {
+ my $self = shift;
+ my $expr = shift;
+ croak "Only the two argument form of open is supported at this time" if @_;
+# FIXME: this needs to parse the full Perl open syntax in $expr
+
+ my ($mixed, $mode, $path) =
+ ($expr =~ /^\s* (\+)? \s* (<|>|>>)? \s* (.*?) \s*$/x);
+
+ croak "Unsupported open mode" if not $path;
+
+ my $access = 'r';
+ my $append = $mode eq '>>' ? 1 : 0;
+
+ if ($mixed) {
+ $access = 'rw';
+ } elsif($mode eq '>') {
+ $access = 'w';
+ }
+
+ my $w32_handle = createFile($path, $access);
+
+ $self->win32_handle($w32_handle);
+
+ $self->seek(1,2) if $append;
+
+ $self->_access($access);
+ $self->_append($append);
+
+ return 1;
+}
+
+sub BINMODE {
+ $_[0]->_binmode(1);
+}
+
+sub WRITE {
+ my ($self, $buf, $len, $offset, $overlap) = @_;
+
+ if ($offset) {
+ $buf = substr($buf, $offset);
+ $len = length($buf);
+ }
+
+ $len = length($buf) if not defined $len;
+
+ $overlap = [] if not defined $overlap;;
+
+ my $bytes_written = 0;
+
+ WriteFile (
+ $self->win32_handle, $buf, $len,
+ $bytes_written, $overlap
+ );
+
+ return $bytes_written;
+}
+
+sub PRINT {
+ my $self = shift;
+
+ my $buf = join defined $, ? $, : "" => @_;
+
+ $buf =~ s/\012/\015\012/sg unless $self->_binmode();
+
+ $buf .= $\ if defined $\;
+
+ $self->WRITE($buf, length($buf), 0);
+}
+
+sub READ {
+ my $self = shift;
+ my $into = \$_[0]; shift;
+ my ($len, $offset, $overlap) = @_;
+
+ my $buffer = defined $self->_buffer ? $self->_buffer : "";
+ my $buf_length = length($buffer);
+ my $bytes_read = 0;
+ my $data;
+ $offset = 0 if not defined $offset;
+
+ if ($buf_length >= $len) {
+ $data = substr($buffer, 0, $len => "");
+ $bytes_read = $len;
+ $self->_buffer($buffer);
+ } else {
+ if ($buf_length > 0) {
+ $len -= $buf_length;
+ substr($$into, $offset) = $buffer;
+ $offset += $buf_length;
+ }
+
+ $overlap ||= [];
+
+ ReadFile (
+ $self->win32_handle, $data, $len,
+ $bytes_read, $overlap
+ );
+ }
+
+ $$into = "" if not defined $$into;
+
+ substr($$into, $offset) = $data;
+
+ return $bytes_read;
+}
+
+sub READLINE {
+ my $self = shift;
+ my $line = "";
+
+ while ((index $line, $/) == $[-1) { # read until end of line marker
+ my $char = $self->GETC();
+
+ last if !defined $char || $char eq '';
+
+ $line .= $char;
+ }
+
+ return undef if $line eq '';
+
+ return $line;
+}
+
+
+sub FILENO {
+ my $self = shift;
+
+ return $self->_fileno() if defined $self->_fileno();
+
+ return -1 if $^O eq 'cygwin';
+
+# FIXME: We don't always open the handle, better to query the handle or to set
+# the right access info at TIEHANDLE time.
+
+ my $access = $self->_access();
+ my $mode = $access eq 'rw' ? O_RDWR :
+ $access eq 'w' ? O_WRONLY : O_RDONLY;
+
+ $mode |= O_APPEND if $self->_append();
+
+ $mode |= O_TEXT if not $self->_binmode();
+
+ return $self->_fileno ( OsfHandleOpenFd (
+ $self->win32_handle, $mode
+ ));
+}
+
+sub SEEK {
+ my ($self, $pos, $whence) = @_;
+
+ $whence = 0 if not defined $whence;
+ my @file_consts = map {
+ fileConstant($_)
+ } qw(FILE_BEGIN FILE_CURRENT FILE_END);
+
+ my $from_where = $file_consts[$whence];
+
+ return setFilePointer($self->win32_handle, $pos, $from_where);
+}
+
+sub TELL {
+# SetFilePointer with position 0 at FILE_CURRENT will return position.
+ return $_[0]->SEEK(0, 1);
+}
+
+sub EOF {
+ my $self = shift;
+
+ my $current = $self->TELL() + 0;
+ my $end = getFileSize($self->win32_handle) + 0;
+
+ return $current == $end;
+}
+
+sub CLOSE {
+ my $self = shift;
+
+ my $retval = 1;
+
+ if (defined $self->win32_handle) {
+ $retval = CloseHandle($self->win32_handle);
+
+ $self->win32_handle(undef);
+ }
+
+ return $retval;
+}
+
+# Only close the handle on explicit close, too many problems otherwise.
+sub UNTIE {}
+
+sub DESTROY {}
+
+# End of Tie/OO Interface
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+Win32API::File - Low-level access to Win32 system API calls for files/dirs.
+
+=head1 SYNOPSIS
+
+ use Win32API::File 0.08 qw( :ALL );
+
+ MoveFile( $Source, $Destination )
+ or die "Can't move $Source to $Destination: ",fileLastError(),"\n";
+ MoveFileEx( $Source, $Destination, MOVEFILE_REPLACE_EXISTING() )
+ or die "Can't move $Source to $Destination: ",fileLastError(),"\n";
+ [...]
+
+=head1 DESCRIPTION
+
+This provides fairly low-level access to the Win32 System API
+calls dealing with files and directories.
+
+To pass in C<NULL> as the pointer to an optional buffer, pass in
+an empty list reference, C<[]>.
+
+Beyond raw access to the API calls and related constants, this module
+handles smart buffer allocation and translation of return codes.
+
+All functions, unless otherwise noted, return a true value for success
+and a false value for failure and set C<$^E> on failure.
+
+=head2 Object Oriented/Tied Handle Interface
+
+WARNING: this is new code, use at your own risk.
+
+This version of C<Win32API::File> can be used like an C<IO::File> object:
+
+ my $file = Win32API::File->new("+> foo");
+ binmode $file;
+ print $file "hello there\n";
+ seek $file, 0, 0;
+ my $line = <$file>;
+ $file->close;
+
+It also supports tying via a win32 handle (for example, from C<createFile()>):
+
+ tie FILE, 'Win32API::File', $win32_handle;
+ print FILE "...";
+
+It has not been extensively tested yet and buffered I/O is not yet implemented.
+
+=head2 Exports
+
+Nothing is exported by default. The following tags can be used to
+have large sets of symbols exported: C<":Func">, C<":FuncA">,
+C<":FuncW">, C<":Misc">, C<":DDD_">, C<":DRIVE_">, C<":FILE_">,
+C<":FILE_ATTRIBUTE_">, C<":FILE_FLAG_">, C<":FILE_SHARE_">,
+C<":FILE_TYPE_">, C<":FS_">, C<":FSCTL_">, C<":HANDLE_FLAG_">,
+C<":IOCTL_STORAGE_">, C<":IOCTL_DISK_">, C<":GENERIC_">,
+C<":MEDIA_TYPE">, C<":MOVEFILE_">, C<":SECURITY_">, C<":SEM_">,
+and C<":PARTITION_">.
+
+=over
+
+=item C<":Func">
+
+The basic function names: C<attrLetsToBits>, C<createFile>,
+C<fileConstant>, C<fileLastError>, C<getLogicalDrives>,
+C<setFilePointer>, C<getFileSize>,
+C<CloseHandle>, C<CopyFile>, C<CreateFile>,
+C<DefineDosDevice>, C<DeleteFile>, C<DeviceIoControl>,
+C<FdGetOsFHandle>, C<GetDriveType>, C<GetFileAttributes>,
+C<GetFileSize>, C<GetFileType>, C<GetHandleInformation>,
+C<GetLogicalDrives>, C<GetLogicalDriveStrings>, C<GetOsFHandle>,
+C<GetOverlappedResult>, C<GetVolumeInformation>, C<IsContainerPartition>,
+C<IsRecognizedPartition>, C<MoveFile>, C<MoveFileEx>,
+C<OsFHandleOpen>, C<OsFHandleOpenFd>, C<QueryDosDevice>,
+C<ReadFile>, C<SetErrorMode>, C<SetFilePointer>,
+C<SetHandleInformation>, and C<WriteFile>.
+
+=over
+
+=item attrLetsToBits
+
+=item C<$uBits= attrLetsToBits( $sAttributeLetters )>
+
+Converts a string of file attribute letters into an unsigned value with
+the corresponding bits set. C<$sAttributeLetters> should contain zero
+or more letters from C<"achorst">:
+
+=over
+
+=item C<"a">
+
+C<FILE_ATTRIBUTE_ARCHIVE>
+
+=item C<"c">
+
+C<FILE_ATTRIBUTE_COMPRESSED>
+
+=item C<"h">
+
+C<FILE_ATTRIBUTE_HIDDEN>
+
+=item C<"o">
+
+C<FILE_ATTRIBUTE_OFFLINE>
+
+=item C<"r">
+
+C<FILE_ATTRIBUTE_READONLY>
+
+=item C<"s">
+
+C<FILE_ATTRIBUTE_SYSTEM>
+
+=item C<"t">
+
+C<FILE_ATTRIBUTE_TEMPORARY>
+
+=back
+
+=item createFile
+
+=item C<$hObject= createFile( $sPath )>
+
+=item C<$hObject= createFile( $sPath, $rvhvOptions )>
+
+=item C<$hObject= createFile( $sPath, $svAccess )>
+
+=item C<$hObject= createFile( $sPath, $svAccess, $rvhvOptions )>
+
+=item C<$hObject= createFile( $sPath, $svAccess, $svShare )>
+
+=item C<$hObject= createFile( $sPath, $svAccess, $svShare, $rvhvOptions )>
+
+This is a Perl-friendly wrapper around C<CreateFile>.
+
+On failure, C<$hObject> gets set to a false value and C<regLastError()>
+and C<$^E> are set to the reason for the failure. Otherwise,
+C<$hObject> gets set to a Win32 native file handle which is alwasy
+a true value [returns C<"0 but true"> in the impossible(?) case of
+the handle having a value of C<0>].
+
+C<$sPath> is the path to the file [or device, etc.] to be opened. See
+C<CreateFile> for more information on possible special values for
+C<$sPath>.
+
+C<$svAccess> can be a number containing the bit mask representing
+the specific type(s) of access to the file that you desire. See the
+C<$uAccess> parameter to C<CreateFile> for more information on these
+values.
+
+More likely, C<$svAccess> is a string describing the generic type of
+access you desire and possibly the file creation options to use. In
+this case, C<$svAccess> should contain zero or more characters from
+C<"qrw"> [access desired], zero or one character each from C<"ktn">
+and C<"ce">, and optional white space. These letters stand for,
+respectively, "Query access", "Read access", "Write access", "Keep if
+exists", "Truncate if exists", "New file only", "Create if none", and
+"Existing file only". Case is ignored.
+
+You can pass in C<"?"> for C<$svAccess> to have an error message
+displayed summarizing its possible values. This is very handy when
+doing on-the-fly programming using the Perl debugger:
+
+ Win32API::File::createFile: $svAccess can use the following:
+ One or more of the following:
+ q -- Query access (same as 0)
+ r -- Read access (GENERIC_READ)
+ w -- Write access (GENERIC_WRITE)
+ At most one of the following:
+ k -- Keep if exists
+ t -- Truncate if exists
+ n -- New file only (fail if file already exists)
+ At most one of the following:
+ c -- Create if doesn't exist
+ e -- Existing file only (fail if doesn't exist)
+ '' is the same as 'q k e'
+ 'r' is the same as 'r k e'
+ 'w' is the same as 'w t c'
+ 'rw' is the same as 'rw k c'
+ 'rt' or 'rn' implies 'c'.
+ Or $access can be numeric.
+
+C<$svAccess> is designed to be "do what I mean", so you can skip
+the rest of its explanation unless you are interested in the complex
+details. Note that, if you want write access to a device, you need
+to specify C<"k"> [and perhaps C<"e">, as in C<"w ke"> or C<"rw ke">]
+since Win32 suggests C<OPEN_EXISTING> be used when opening a device.
+
+=over
+
+=item C<"q">
+
+Stands for "Query access". This is really a no-op since you always have
+query access when you open a file. You can specify C<"q"> to document
+that you plan to query the file [or device, etc.]. This is especially
+helpful when you don't want read nor write access since something like
+C<"q"> or C<"q ke"> may be easier to understand than just C<""> or C<"ke">.
+
+=item C<"r">
+
+Stands for "Read access". Sets the C<GENERIC_READ> bit(s) in the
+C<$uAccess> that is passed to C<CreateFile>. This is the default
+access if the C<$svAccess> parameter is missing [or if it is C<undef>
+and C<$rvhvOptions> doesn't specify an C<"Access"> option].
+
+=item C<"w">
+
+Stands for "Write access". Sets the C<GENERIC_WRITE> bit(s) in the
+C<$uAccess> that is passed to C<CreateFile>.
+
+=item C<"k">
+
+Stands for "Keep if exists". If the requested file exists, then it is
+opened. This is the default unless C<GENERIC_WRITE> access has been
+requested but C<GENERIC_READ> access has not been requested. Contrast
+with C<"t"> and C<"n">.
+
+=item C<"t">
+
+Stands for "Truncate if exists". If the requested file exists, then
+it is truncated to zero length and then opened. This is the default if
+C<GENERIC_WRITE> access has been requested and C<GENERIC_READ> access
+has not been requested. Contrast with C<"k"> and C<"n">.
+
+=item C<"n">
+
+Stands for "New file only". If the requested file exists, then it is
+not opened and the C<createFile> call fails. Contrast with C<"k"> and
+C<"t">. Can't be used with C<"e">.
+
+=item C<"c">
+
+Stands for "Create if none". If the requested file does not
+exist, then it is created and then opened. This is the default
+if C<GENERIC_WRITE> access has been requested or if C<"t"> or
+C<"n"> was specified. Contrast with C<"e">.
+
+=item C<"e">
+
+Stands for "Existing file only". If the requested file does not
+exist, then nothing is opened and the C<createFile> call fails. This
+is the default unless C<GENERIC_WRITE> access has been requested or
+C<"t"> or C<"n"> was specified. Contrast with C<"c">. Can't be
+used with C<"n">.
+
+=back
+
+The characters from C<"ktn"> and C<"ce"> are combined to determine the
+what value for C<$uCreate> to pass to C<CreateFile> [unless overridden
+by C<$rvhvOptions>]:
+
+=over
+
+=item C<"kc">
+
+C<OPEN_ALWAYS>
+
+=item C<"ke">
+
+C<OPEN_EXISTING>
+
+=item C<"tc">
+
+C<TRUNCATE_EXISTING>
+
+=item C<"te">
+
+C<CREATE_ALWAYS>
+
+=item C<"nc">
+
+C<CREATE_NEW>
+
+=item C<"ne">
+
+Illegal.
+
+=back
+
+C<$svShare> controls how the file is shared, that is, whether other
+processes can have read, write, and/or delete access to the file while
+we have it opened. C<$svShare> will usually be a string containing zero
+or more characters from C<"rwd"> but can also be a numeric bit mask.
+
+C<"r"> sets the C<FILE_SHARE_READ> bit which allows other processes to have
+read access to the file. C<"w"> sets the C<FILE_SHARE_WRITE> bit which
+allows other processes to have write access to the file. C<"d"> sets the
+C<FILE_SHARE_DELETE> bit which allows other processes to have delete access
+to the file [ignored under Windows 95].
+
+The default for C<$svShare> is C<"rw"> which provides the same sharing as
+using regular perl C<open()>.
+
+If another process currently has read, write, and/or delete access to
+the file and you don't allow that level of sharing, then your call to
+C<createFile> will fail. If you requested read, write, and/or delete
+access and another process already has the file open but doesn't allow
+that level of sharing, then your call to C<createFile> will fail. Once
+you have the file open, if another process tries to open it with read,
+write, and/or delete access and you don't allow that level of sharing,
+then that process won't be allowed to open the file.
+
+C<$rvhvOptions> is a reference to a hash where any keys must be from
+the list C<qw( Access Create Share Attributes Flags Security Model )>.
+The meaning of the value depends on the key name, as described below.
+Any option values in C<$rvhvOptions> override the settings from
+C<$svAccess> and C<$svShare> if they conflict.
+
+=over
+
+=item Flags => $uFlags
+
+C<$uFlags> is an unsigned value having any of the C<FILE_FLAG_*> or
+C<FILE_ATTRIBUTE_*> bits set. Any C<FILE_ATTRIBUTE_*> bits set via the
+C<Attributes> option are logically C<or>ed with these bits. Defaults
+to C<0>.
+
+If opening the client side of a named pipe, then you can also specify
+C<SECURITY_SQOS_PRESENT> along with one of the other C<SECURITY_*>
+constants to specify the security quality of service to be used.
+
+=item Attributes => $sAttributes
+
+A string of zero or more characters from C<"achorst"> [see C<attrLetsToBits>
+for more information] which are converted to C<FILE_ATTRIBUTE_*> bits to
+be set in the C<$uFlags> argument passed to C<CreateFile>.
+
+=item Security => $pSecurityAttributes
+
+C<$pSecurityAttributes> should contain a C<SECURITY_ATTRIBUTES> structure
+packed into a string or C<[]> [the default].
+
+=item Model => $hModelFile
+
+C<$hModelFile> should contain a handle opened with C<GENERIC_READ>
+access to a model file from which file attributes and extended attributes
+are to be copied. Or C<$hModelFile> can be C<0> [the default].
+
+=item Access => $sAccess
+
+=item Access => $uAccess
+
+C<$sAccess> should be a string of zero or more characters from
+C<"qrw"> specifying the type of access desired: "query" or C<0>,
+"read" or C<GENERIC_READ> [the default], or "write" or
+C<GENERIC_WRITE>.
+
+C<$uAccess> should be an unsigned value containing bits set to
+indicate the type of access desired. C<GENERIC_READ> is the default.
+
+=item Create => $sCreate
+
+=item Create => $uCreate
+
+C<$sCreate> should be a string constaing zero or one character from
+C<"ktn"> and zero or one character from C<"ce">. These stand for
+"Keep if exists", "Truncate if exists", "New file only", "Create if
+none", and "Existing file only". These are translated into a
+C<$uCreate> value.
+
+C<$uCreate> should be one of C<OPEN_ALWAYS>, C<OPEN_EXISTING>,
+C<TRUNCATE_EXISTING>, C<CREATE_ALWAYS>, or C<CREATE_NEW>.
+
+=item Share => $sShare
+
+=item Share => $uShare
+
+C<$sShare> should be a string with zero or more characters from
+C<"rwd"> that is translated into a C<$uShare> value. C<"rw"> is
+the default.
+
+C<$uShare> should be an unsigned value having zero or more of the
+following bits set: C<FILE_SHARE_READ>, C<FILE_SHARE_WRITE>, and
+C<FILE_SHARE_DELETE>. C<FILE_SHARE_READ|FILE_SHARE_WRITE> is the
+default.
+
+=back
+
+Examples:
+
+ $hFlop= createFile( "//./A:", "r", "r" )
+ or die "Can't prevent others from writing to floppy: $^E\n";
+ $hDisk= createFile( "//./C:", "rw ke", "" )
+ or die "Can't get exclusive access to C: $^E\n";
+ $hDisk= createFile( $sFilePath, "ke",
+ { Access=>FILE_READ_ATTRIBUTES } )
+ or die "Can't read attributes of $sFilePath: $^E\n";
+ $hTemp= createFile( "$ENV{Temp}/temp.$$", "wn", "",
+ { Attributes=>"hst", Flags=>FILE_FLAG_DELETE_ON_CLOSE() } )
+ or die "Can't create temporary file, temp.$$: $^E\n";
+
+=item getLogicalDrives
+
+=item C<@roots= getLogicalDrives()>
+
+Returns the paths to the root directories of all logical drives
+currently defined. This includes all types of drive lettters, such
+as floppies, CD-ROMs, hard disks, and network shares. A typical
+return value on a poorly equipped computer would be C<("A:\\","C:\\")>.
+
+=item CloseHandle
+
+=item C<CloseHandle( $hObject )>
+
+Closes a Win32 native handle, such as one opened via C<CreateFile>.
+Like most routines, returns a true value if successful and a false
+value [and sets C<$^E> and C<regLastError()>] on failure.
+
+=item CopyFile
+
+=item C<CopyFile( $sOldFileName, $sNewFileName, $bFailIfExists )>
+
+C<$sOldFileName> is the path to the file to be copied.
+C<$sNewFileName> is the path to where the file should be copied.
+Note that you can B<NOT> just specify a path to a directory in
+C<$sNewFileName> to copy the file to that directory using the
+same file name.
+
+If C<$bFailIfExists> is true and C<$sNewFileName> is the path to
+a file that already exists, then C<CopyFile> will fail. If
+C<$bFailIfExists> is falsea, then the copy of the C<$sOldFileNmae>
+file will overwrite the C<$sNewFileName> file if it already exists.
+
+Like most routines, returns a true value if successful and a false
+value [and sets C<$^E> and C<regLastError()>] on failure.
+
+=item CreateFile
+
+=item C<$hObject= CreateFile( $sPath, $uAccess, $uShare, $pSecAttr, $uCreate, $uFlags, $hModel )>
+
+On failure, C<$hObject> gets set to a false value and C<$^E> and
+C<fileLastError()> are set to the reason for the failure. Otherwise,
+C<$hObject> gets set to a Win32 native file handle which is always a
+true value [returns C<"0 but true"> in the impossible(?) case of the
+handle having a value of C<0>].
+
+C<$sPath> is the path to the file [or device, etc.] to be opened.
+
+C<$sPath> can use C<"/"> or C<"\\"> as path delimiters and can even
+mix the two. We will usually only use C<"/"> in our examples since
+using C<"\\"> is usually harder to read.
+
+Under Windows NT, C<$sPath> can start with C<"//?/"> to allow the use
+of paths longer than C<MAX_PATH> [for UNC paths, replace the leading
+C<"//"> with C<"//?/UNC/">, as in C<"//?/UNC/Server/Share/Dir/File.Ext">].
+
+C<$sPath> can start with C<"//./"> to indicate that the rest of the
+path is the name of a "DOS device." You can use C<QueryDosDevice>
+to list all current DOS devices and can add or delete them with
+C<DefineDosDevice>. If you get the source-code distribution of this
+module from CPAN, then it includes an example script, F<ex/ListDevs.plx>
+that will list all current DOS devices and their "native" definition.
+Again, note that this doesn't work under Win95 nor Win98.
+
+The most common such DOS devices include:
+
+=over
+
+=item C<"//./PhysicalDrive0">
+
+Your entire first hard disk. Doesn't work under Windows 95. This
+allows you to read or write raw sectors of your hard disk and to use
+C<DeviceIoControl> to perform miscellaneous queries and operations
+to the hard disk. Writing raw sectors and certain other operations
+can seriously damage your files or the function of your computer.
+
+Locking this for exclusive access [by specifying C<0> for C<$uShare>]
+doesn't prevent access to the partitions on the disk nor their file
+systems. So other processes can still access any raw sectors within
+a partition and can use the file system on the disk as usual.
+
+=item C<"//./C:">
+
+Your F<C:> partition. Doesn't work under Windows 95. This allows
+you to read or write raw sectors of that partition and to use
+C<DeviceIoControl> to perform miscellaneous queries and operations
+to the partition. Writing raw sectors and certain other operations
+can seriously damage your files or the function of your computer.
+
+Locking this for exclusive access doesn't prevent access to the
+physical drive that the partition is on so other processes can
+still access the raw sectors that way. Locking this for exclusive
+access B<does> prevent other processes from opening the same raw
+partition and B<does> prevent access to the file system on it. It
+even prevents the current process from accessing the file system
+on that partition.
+
+=item C<"//./A:">
+
+The raw floppy disk. Doesn't work under Windows 95. This allows
+you to read or write raw sectors of the floppy disk and to use
+C<DeviceIoControl> to perform miscellaneous queries and operations
+to the floopy disk or drive.
+
+Locking this for exclusive access prevents all access to the floppy.
+
+=item C<"//./PIPE/PipeName">
+
+A named pipe, created via C<CreateNamedPipe>.
+
+=back
+
+C<$uAccess> is an unsigned value with bits set indicating the
+type of access desired. Usually either C<0> ["query" access],
+C<GENERIC_READ>, C<GENERIC_WRITE>, C<GENERIC_READ|GENERIC_WRITE>,
+or C<GENERIC_ALL>. More specific types of access can be specified,
+such as C<FILE_APPEND_DATA> or C<FILE_READ_EA>.
+
+C<$uShare> controls how the file is shared, that is, whether other
+processes can have read, write, and/or delete access to the file while
+we have it opened. C<$uShare> is an unsigned value with zero or more
+of these bits set: C<FILE_SHARE_READ>, C<FILE_SHARE_WRITE>, and
+C<FILE_SHARE_DELETE>.
+
+If another process currently has read, write, and/or delete access to
+the file and you don't allow that level of sharing, then your call to
+C<CreateFile> will fail. If you requested read, write, and/or delete
+access and another process already has the file open but doesn't allow
+that level of sharing, thenn your call to C<createFile> will fail. Once
+you have the file open, if another process tries to open it with read,
+write, and/or delete access and you don't allow that level of sharing,
+then that process won't be allowed to open the file.
+
+C<$pSecAttr> should either be C<[]> [for C<NULL>] or a
+C<SECURITY_ATTRIBUTES> data structure packed into a string.
+For example, if C<$pSecDesc> contains a C<SECURITY_DESCRIPTOR>
+structure packed into a string, perhaps via:
+
+ RegGetKeySecurity( $key, 4, $pSecDesc, 1024 );
+
+then you can set C<$pSecAttr> via:
+
+ $pSecAttr= pack( "L P i", 12, $pSecDesc, $bInheritHandle );
+
+C<$uCreate> is one of the following values: C<OPEN_ALWAYS>,
+C<OPEN_EXISTING>, C<TRUNCATE_EXISTING>, C<CREATE_ALWAYS>, and
+C<CREATE_NEW>.
+
+C<$uFlags> is an unsigned value with zero or more bits set indicating
+attributes to associate with the file [C<FILE_ATTRIBUTE_*> values] or
+special options [C<FILE_FLAG_*> values].
+
+If opening the client side of a named pipe, then you can also set
+C<$uFlags> to include C<SECURITY_SQOS_PRESENT> along with one of the
+other C<SECURITY_*> constants to specify the security quality of
+service to be used.
+
+C<$hModel> is C<0> [or C<[]>, both of which mean C<NULL>] or a Win32
+native handle opened with C<GENERIC_READ> access to a model file from
+which file attributes and extended attributes are to be copied if a
+new file gets created.
+
+Examples:
+
+ $hFlop= CreateFile( "//./A:", GENERIC_READ(),
+ FILE_SHARE_READ(), [], OPEN_EXISTING(), 0, [] )
+ or die "Can't prevent others from writing to floppy: $^E\n";
+ $hDisk= CreateFile( $sFilePath, FILE_READ_ATTRIBUTES(),
+ FILE_SHARE_READ()|FILE_SHARE_WRITE(), [], OPEN_EXISTING(), 0, [] )
+ or die "Can't read attributes of $sFilePath: $^E\n";
+ $hTemp= CreateFile( "$ENV{Temp}/temp.$$", GENERIC_WRITE(), 0,
+ CREATE_NEW(), FILE_FLAG_DELETE_ON_CLOSE()|attrLetsToBits("hst"), [] )
+ or die "Can't create temporary file, temp.$$: $^E\n";
+
+=item DefineDosDevice
+
+=item C<DefineDosDevice( $uFlags, $sDosDeviceName, $sTargetPath )>
+
+Defines a new DOS device, overrides the current definition of a DOS
+device, or deletes a definition of a DOS device. Like most routines,
+returns a true value if successful and a false value [and sets C<$^E>
+and C<regLastError()>] on failure.
+
+C<$sDosDeviceName> is the name of a DOS device for which we'd like
+to add or delete a definition.
+
+C<$uFlags> is an unsigned value with zero or more of the following
+bits set:
+
+=over
+
+=item C<DDD_RAW_TARGET_PATH>
+
+Indicates that C<$sTargetPath> will be a raw Windows NT object name.
+This usually means that C<$sTargetPath> starts with C<"\\Device\\">.
+Note that you cannot use C<"/"> in place of C<"\\"> in raw target path
+names.
+
+=item C<DDD_REMOVE_DEFINITION>
+
+Requests that a definition be deleted. If C<$sTargetPath> is
+C<[]> [for C<NULL>], then the most recently added definition for
+C<$sDosDeviceName> is removed. Otherwise the most recently added
+definition matching C<$sTargetPath> is removed.
+
+If the last definition is removed, then the DOS device name is
+also deleted.
+
+=item C<DDD_EXACT_MATCH_ON_REMOVE>
+
+When deleting a definition, this bit causes each C<$sTargetPath> to
+be compared to the full-length definition when searching for the most
+recently added match. If this bit is not set, then C<$sTargetPath>
+only needs to match a prefix of the definition.
+
+=back
+
+C<$sTargetPath> is the DOS device's specific definition that you
+wish to add or delete. For C<DDD_RAW_TARGET_PATH>, these usually
+start with C<"\\Device\\">. If the C<DDD_RAW_TARGET_PATH> bit is
+not set, then C<$sTargetPath> is just an ordinary path to some file
+or directory, providing the functionality of the B<subst> command.
+
+=item DeleteFile
+
+=item C<DeleteFile( $sFileName )>
+
+Deletes the named file. Compared to Perl's C<unlink>, C<DeleteFile>
+has the advantage of not deleting read-only files. For B<some>
+versions of Perl, C<unlink> silently calls C<chmod> whether it needs
+to or not before deleting the file so that files that you have
+protected by marking them as read-only are not always protected from
+Perl's C<unlink>.
+
+Like most routines, returns a true value if successful and a false
+value [and sets C<$^E> and C<regLastError()>] on failure.
+
+=item DeviceIoControl
+
+=item C<DeviceIoControl( $hDevice, $uIoControlCode, $pInBuf, $lInBuf, $opOutBuf, $lOutBuf, $olRetBytes, $pOverlapped )>
+
+Requests a special operation on an I/O [input/output] device, such
+as ejecting a tape or formatting a disk. Like most routines, returns
+a true value if successful and a false value [and sets C<$^E> and
+C<regLastError()>] on failure.
+
+C<$hDevice> is a Win32 native file handle to a device [return value
+from C<CreateFile>].
+
+C<$uIoControlCode> is an unsigned value [a C<IOCTL_*> or C<FSCTL_*>
+constant] indicating the type query or other operation to be performed.
+
+C<$pInBuf> is C<[]> [for C<NULL>] or a data structure packed into a
+string. The type of data structure depends on the C<$uIoControlCode>
+value. C<$lInBuf> is C<0> or the length of the structure in
+C<$pInBuf>. If C<$pInBuf> is not C<[]> and C<$lInBuf> is C<0>, then
+C<$lInBuf> will automatically be set to C<length($pInBuf)> for you.
+
+C<$opOutBuf> is C<[]> [for C<NULL>] or will be set to contain a
+returned data structure packed into a string. C<$lOutBuf> indicates
+how much space to allocate in C<$opOutBuf> for C<DeviceIoControl> to
+store the data structure. If C<$lOutBuf> is a number and C<$opOutBuf>
+already has a buffer allocated for it that is larger than C<$lOutBuf>
+bytes, then this larger buffer size will be passed to C<DeviceIoControl>.
+However, you can force a specific buffer size to be passed to
+C<DeviceIoControl> by prepending a C<"="> to the front of C<$lOutBuf>.
+
+C<$olRetBytes> is C<[]> or is a scalar to receive the number of bytes
+written to C<$opOutBuf>. Even when C<$olRetBytes> is C<[]>, a valid
+pointer to a C<DWORD> [and not C<NULL>] is passed to C<DeviceIoControl>.
+In this case, C<[]> just means that you don't care about the value
+that might be written to C<$olRetBytes>, which is usually the case
+since you can usually use C<length($opOutBuf)> instead.
+
+C<$pOverlapped> is C<[]> or is a C<OVERLAPPED> structure packed into
+a string. This is only useful if C<$hDevice> was opened with the
+C<FILE_FLAG_OVERLAPPED> flag set.
+
+=item FdGetOsFHandle
+
+=item C<$hNativeHandle= FdGetOsFHandle( $ivFd )>
+
+C<FdGetOsFHandle> simply calls C<_get_osfhandle()>. It was renamed
+to better fit in with the rest the function names of this module,
+in particular to distinguish it from C<GetOsFHandle>. It takes an
+integer file descriptor [as from Perl's C<fileno>] and returns the
+Win32 native file handle associated with that file descriptor or
+C<INVALID_HANDLE_VALUE> if C<$ivFd> is not an open file descriptor.
+
+When you call Perl's C<open> to set a Perl file handle [like C<STDOUT>],
+Perl calls C's C<fopen> to set a stdio C<FILE *>. C's C<fopen> calls
+something like Unix's C<open>, that is, Win32's C<_sopen>, to get an
+integer file descriptor [where 0 is for C<STDIN>, 1 for C<STDOUT>, etc.].
+Win32's C<_sopen> calls C<CreateFile> to set a C<HANDLE>, a Win32 native
+file handle. So every Perl file handle [like C<STDOUT>] has an integer
+file descriptor associated with it that you can get via C<fileno>. And,
+under Win32, every file descriptor has a Win32 native file handle
+associated with it. C<FdGetOsFHandle> lets you get access to that.
+
+C<$hNativeHandle> is set to C<INVALID_HANDLE_VALUE> [and
+C<lastFileError()> and C<$^E> are set] if C<FdGetOsFHandle> fails.
+See also C<GetOsFHandle> which provides a friendlier interface.
+
+=item fileConstant
+
+=item C<$value= fileConstant( $sConstantName )>
+
+Fetch the value of a constant. Returns C<undef> if C<$sConstantName>
+is not the name of a constant supported by this module. Never sets
+C<$!> nor C<$^E>.
+
+This function is rarely used since you will usually get the value of a
+constant by having that constant imported into your package by listing
+the constant name in the C<use Win32API::File> statement and then
+simply using the constant name in your code [perhaps followed by
+C<()>]. This function is useful for verifying constant names not in
+Perl code, for example, after prompting a user to type in a constant
+name.
+
+=item fileLastError
+
+=item C<$svError= fileLastError();>
+
+=item C<fileLastError( $uError );>
+
+Returns the last error encountered by a routine from this module.
+It is just like C<$^E> except it isn't changed by anything except
+routines from this module. Ideally you could just use C<$^E>, but
+current versions of Perl often overwrite C<$^E> before you get a
+chance to check it and really old versions of Perl don't really
+support C<$^E> under Win32.
+
+Just like C<$^E>, in a numeric context C<fileLastError()> returns
+the numeric error value while in a string context it returns a
+text description of the error [actually it returns a Perl scalar
+that contains both values so C<$x= fileLastError()> causes C<$x>
+to give different values in string vs. numeric contexts].
+
+The last form sets the error returned by future calls to
+C<fileLastError()> and should not be used often. C<$uError> must
+be a numeric error code. Also returns the dual-valued version
+of C<$uError>.
+
+=item GetDriveType
+
+=item C<$uDriveType= GetDriveType( $sRootPath )>
+
+Takes a string giving the path to the root directory of a file system
+[called a "drive" because every file system is assigned a "drive letter"]
+and returns an unsigned value indicating the type of drive the file
+system is on. The return value should be one of:
+
+=over
+
+=item C<DRIVE_UNKNOWN>
+
+None of the following.
+
+=item C<DRIVE_NO_ROOT_DIR>
+
+A "drive" that does not have a file system. This can be a drive letter
+that hasn't been defined or a drive letter assigned to a partition
+that hasn't been formatted yet.
+
+=item C<DRIVE_REMOVABLE>
+
+A floppy diskette drive or other removable media drive, but not a CD-ROM
+drive.
+
+=item C<DRIVE_FIXED>
+
+An ordinary hard disk partition.
+
+=item C<DRIVE_REMOTE>
+
+A network share.
+
+=item C<DRIVE_CDROM>
+
+A CD-ROM drive.
+
+=item C<DRIVE_RAMDISK>
+
+A "ram disk" or memory-resident virtual file system used for high-speed
+access to small amounts of temporary file space.
+
+=back
+
+=item GetFileAttributes
+
+=item C<$uAttrs = GetFileAttributes( $sPath )>
+
+Takes a path string and returns an unsigned value with attribute flags.
+If it fails, it returns INVALID_FILE_ATTRIBUTES, otherwise it can be
+one or more of the following values:
+
+=over
+
+=item C<FILE_ATTRIBUTE_ARCHIVE>
+
+The file or directory is an archive file or directory. Applications use
+this attribute to mark files for backup or removal.
+
+=item C<FILE_ATTRIBUTE_COMPRESSED>
+
+The file or directory is compressed. For a file, this means that all of
+the data in the file is compressed. For a directory, this means that
+compression is the default for newly created files and subdirectories.
+
+=item C<FILE_ATTRIBUTE_DEVICE>
+
+Reserved; do not use.
+
+=item C<FILE_ATTRIBUTE_DIRECTORY>
+
+The handle identifies a directory.
+
+=item C<FILE_ATTRIBUTE_ENCRYPTED>
+
+The file or directory is encrypted. For a file, this means that all data
+streams in the file are encrypted. For a directory, this means that
+encryption is the default for newly created files and subdirectories.
+
+=item C<FILE_ATTRIBUTE_HIDDEN>
+
+The file or directory is hidden. It is not included in an ordinary directory
+listing.
+
+=item C<FILE_ATTRIBUTE_NORMAL>
+
+The file or directory has no other attributes set. This attribute is valid
+only if used alone.
+
+=item C<FILE_ATTRIBUTE_NOT_CONTENT_INDEXED>
+
+The file will not be indexed by the content indexing service.
+
+=item C<FILE_ATTRIBUTE_OFFLINE>
+
+The data of the file is not immediately available. This attribute indicates
+that the file data has been physically moved to offline storage. This
+attribute is used by Remote Storage, the hierarchical storage management
+software. Applications should not arbitrarily change this attribute.
+
+=item C<FILE_ATTRIBUTE_READONLY>
+
+The file or directory is read-only. Applications can read the file but cannot
+write to it or delete it. In the case of a directory, applications cannot
+delete it.
+
+=item C<FILE_ATTRIBUTE_REPARSE_POINT>
+
+The file or directory has an associated reparse point.
+
+=item C<FILE_ATTRIBUTE_SPARSE_FILE>
+
+The file is a sparse file.
+
+=item C<FILE_ATTRIBUTE_SYSTEM>
+
+The file or directory is part of, or is used exclusively by, the operating
+system.
+
+=item C<FILE_ATTRIBUTE_TEMPORARY>
+
+The file is being used for temporary storage. File systems avoid writing
+data back to mass storage if sufficient cache memory is available, because
+often the application deletes the temporary file shortly after the handle is
+closed. In that case, the system can entirely avoid writing the data.
+Otherwise, the data will be written after the handle is closed.
+
+=back
+
+=item GetFileType
+
+=item C<$uFileType= GetFileType( $hFile )>
+
+Takes a Win32 native file handle and returns a C<FILE_TYPE_*> constant
+indicating the type of the file opened on that handle:
+
+=over
+
+=item C<FILE_TYPE_UNKNOWN>
+
+None of the below. Often a special device.
+
+=item C<FILE_TYPE_DISK>
+
+An ordinary disk file.
+
+=item C<FILE_TYPE_CHAR>
+
+What Unix would call a "character special file", that is, a device that
+works on character streams such as a printer port or a console.
+
+=item C<FILE_TYPE_PIPE>
+
+Either a named or anonymous pipe.
+
+=back
+
+=item getFileSize
+
+=item C<$size= getFileSize( $hFile )>
+
+This is a Perl-friendly wrapper for the C<GetFileSize> (below) API call.
+
+It takes a Win32 native file handle and returns the size in bytes. Since the
+size can be a 64 bit value, on non 64 bit integer Perls the value returned will
+be an object of type C<Math::BigInt>.
+
+=item GetFileSize
+
+=item C<$iSizeLow= GetFileSize($win32Handle, $iSizeHigh)>
+
+Returns the size of a file pointed to by C<$win32Handle>, optionally storing
+the high order 32 bits into C<$iSizeHigh> if it is not C<[]>. If $iSizeHigh is
+C<[]>, a non-zero value indicates success. Otherwise, on failure the return
+value will be C<0xffffffff> and C<fileLastError()> will not be C<NO_ERROR>.
+
+=item GetOverlappedResult
+
+=item C<$bRetval= GetOverlappedResult( $win32Handle, $pOverlapped,
+ $numBytesTransferred, $bWait )>
+
+Used for asynchronous IO in Win32 to get the result of a pending IO operation,
+such as when a file operation returns C<ERROR_IO_PENDING>. Returns a false
+value on failure. The C<$overlapped> structure and C<$numBytesTransferred>
+will be modified with the results of the operation.
+
+As far as creating the C<$pOverlapped> structure, you are currently on your own.
+
+See L<http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/getoverlappedresult.asp> for more information.
+
+=item GetLogicalDrives
+
+=item C<$uDriveBits= GetLogicalDrives()>
+
+Returns an unsigned value with one bit set for each drive letter currently
+defined. If "A:" is currently a valid drive letter, then the C<1> bit
+will be set in C<$uDriveBits>. If "B:" is valid, then the C<2> bit will
+be set. If "Z:" is valid, then the C<2**26> [C<0x4000000>] bit will be
+set.
+
+=item GetLogicalDriveStrings
+
+=item C<$olOutLength= GetLogicalDriveStrings( $lBufSize, $osBuffer )>
+
+For each currently defined drive letter, a C<'\0'>-terminated string
+of the path to the root of its file system is constructed. All of
+these strings are concatenated into a single larger string and an
+extra terminating C<'\0'> is added. This larger string is returned
+in C<$osBuffer>. Note that this includes drive letters that have
+been defined but that have no file system, such as drive letters
+assigned to unformatted partitions.
+
+C<$lBufSize> is the size of the buffer to allocate to store this
+list of strings. C<26*4+1> is always sufficient and should usually
+be used.
+
+C<$osBuffer> is a scalar to be set to contain the constructed string.
+
+C<$olOutLength> is the number of bytes actually written to C<$osBuffer>
+but C<length($osBuffer)> can also be used to determine this.
+
+For example, on a poorly equipped computer,
+
+ GetLogicalDriveStrings( 4*26+1, $osBuffer );
+
+might set C<$osBuffer> to the 9-character string, C<"A:\\\0C:\\\0\0">.
+
+=item GetHandleInformation
+
+=item C<GetHandleInformation( $hObject, $ouFlags )>
+
+Retrieves the flags associated with a Win32 native file handle or object
+handle.
+
+C<$hObject> is an open Win32 native file handle or an open Win32 native
+handle to some other type of object.
+
+C<$ouFlags> will be set to an unsigned value having zero or more of
+the bits C<HANDLE_FLAG_INHERIT> and C<HANDLE_FLAG_PROTECT_FROM_CLOSE>
+set. See the C<":HANDLE_FLAG_"> export class for the meanings of these
+bits.
+
+=item GetOsFHandle
+
+=item C<$hNativeHandle= GetOsFHandle( FILE )>
+
+Takes a Perl file handle [like C<STDIN>] and returns the Win32 native
+file handle associated with it. See C<FdGetOsFHandle> for more
+information about Win32 native file handles.
+
+C<$hNativeHandle> is set to a false value [and C<lastFileError()> and
+C<$^E> are set] if C<GetOsFHandle> fails. C<GetOsFHandle> returns
+C<"0 but true"> in the impossible(?) case of the handle having a value
+of C<0>.
+
+=item GetVolumeInformation
+
+=item C<GetVolumeInformation( $sRootPath, $osVolName, $lVolName, $ouSerialNum, $ouMaxNameLen, $ouFsFlags, $osFsType, $lFsType )>
+
+Gets information about a file system volume, returning a true
+value if successful. On failure, returns a false value and sets
+C<fileLastError()> and C<$^E>.
+
+C<$sRootPath> is a string specifying the path to the root of the file system,
+for example, C<"C:/">.
+
+C<$osVolName> is a scalar to be set to the string representing the
+volume name, also called the file system label. C<$lVolName> is the
+number of bytes to allocate for the C<$osVolName> buffer [see
+L<Buffer Sizes> for more information].
+
+C<$ouSerialNum> is C<[]> [for C<NULL>] or will be set to the numeric
+value of the volume's serial number.
+
+C<$ouMaxNameLen> is C<[]> [for C<NULL>] or will be set to the maximum
+length allowed for a file name or directory name within the file system.
+
+C<$osFsType> is a scalar to be set to the string representing the
+file system type, such as C<"FAT"> or C<"NTFS">. C<$lFsType> is the
+number of bytes to allocate for the C<$osFsType> buffer [see
+L<Buffer Sizes> for more information].
+
+C<$ouFsFlags> is C<[]> [for C<NULL>] or will be set to an unsigned integer
+with bits set indicating properties of the file system:
+
+=over
+
+=item C<FS_CASE_IS_PRESERVED>
+
+The file system preserves the case of file names [usually true].
+That is, it doesn't change the case of file names such as forcing
+them to upper- or lower-case.
+
+=item C<FS_CASE_SENSITIVE>
+
+The file system supports the ability to not ignore the case of file
+names [but might ignore case the way you are using it]. That is, the
+file system has the ability to force you to get the letter case of a
+file's name exactly right to be able to open it. This is true for
+"NTFS" file systems, even though case in file names is usually still
+ignored.
+
+=item C<FS_UNICODE_STORED_ON_DISK>
+
+The file system preserves Unicode in file names [true for "NTFS"].
+
+=item C<FS_PERSISTENT_ACLS>
+
+The file system supports setting Access Control Lists on files [true
+for "NTFS"].
+
+=item C<FS_FILE_COMPRESSION>
+
+The file system supports compression on a per-file basis [true for
+"NTFS"].
+
+=item C<FS_VOL_IS_COMPRESSED>
+
+The entire file system is compressed such as via "DoubleSpace".
+
+=back
+
+=item IsRecognizedPartition
+
+=item C<IsRecognizedPartition( $ivPartitionType )>
+
+Takes a partition type and returns whether that partition type is
+supported under Win32. C<$ivPartitonType> is an integer value as from
+the operating system byte of a hard disk's DOS-compatible partition
+table [that is, a partition table for x86-based Win32, not, for
+example, one used with Windows NT for Alpha processors]. For example,
+the C<PartitionType> member of the C<PARTITION_INFORMATION> structure.
+
+Common values for C<$ivPartitionType> include C<PARTITION_FAT_12==1>,
+C<PARTITION_FAT_16==4>, C<PARTITION_EXTENDED==5>, C<PARTITION_FAT32==0xB>.
+
+=item IsContainerPartition
+
+=item C<IsContainerPartition( $ivPartitionType )>
+
+Takes a partition type and returns whether that partition is a
+"container" partition that is supported under Win32, that is, whether
+it is an "extended" partition that can contain "logical" partitions.
+C<$ivPartitonType> is as for C<IsRecognizedPartition>.
+
+=item MoveFile
+
+=item C<MoveFile( $sOldName, $sNewName )>
+
+Renames a file or directory. C<$sOldName> is the name of the existing
+file or directory that is to be renamed. C<$sNewName> is the new name
+to give the file or directory. Returns a true value if the move
+succeeds. For failure, returns a false value and sets
+C<fileLastErorr()> and C<$^E> to the reason for the failure.
+
+Files can be "renamed" between file systems and the file contents and
+some attributes will be moved. Directories can only be renamed within
+one file system. If there is already a file or directory named
+C<$sNewName>, then C<MoveFile> will fail.
+
+=item MoveFileEx
+
+=item C<MoveFileEx( $sOldName, $sNewName, $uFlags )>
+
+Renames a file or directory. C<$sOldName> is the name of the existing
+file or directory that is to be renamed. C<$sNewName> is the new name
+to give the file or directory. Returns a true value if the move
+succeeds. For failure, returns a false value and sets
+C<fileLastErorr()> and C<$^E> to the reason for the failure.
+
+C<$uFlags> is an unsigned value with zero or more of the following bits set:
+
+=over
+
+=item C<MOVEFILE_REPLACE_EXISTING>
+
+If this bit is set and a file [but not a directory] named C<$sNewName>
+already exists, then it will be replaced by C<$sOldName>. If this bit
+is not set then C<MoveFileEx> will fail rather than replace an existing
+C<$sNewName>.
+
+=item C<MOVEFILE_COPY_ALLOWED>
+
+Allows files [but not directories] to be moved between file systems
+by copying the C<$sOldName> file data and some attributes to
+C<$sNewName> and then deleting C<$sOldName>. If this bit is not set
+[or if C<$sOldName> denotes a directory] and C<$sNewName> refers to a
+different file system than C<$sOldName>, then C<MoveFileEx> will fail.
+
+=item C<MOVEFILE_DELAY_UNTIL_REBOOT>
+
+Preliminary verifications are made and then an entry is added to the
+Registry to cause the rename [or delete] operation to be done the
+next time this copy of the operating system is booted [right after
+any automatic file system checks have completed]. This is not
+supported under Windows 95.
+
+When this bit is set, C<$sNewName> can be C<[]> [for C<NULL>] to
+indicate that C<$sOldName> should be deleted during the next boot
+rather than renamed.
+
+Setting both the C<MOVEFILE_COPY_ALLOWED> and
+C<MOVEFILE_DELAY_UNTIL_REBOOT> bits will cause C<MoveFileEx> to fail.
+
+=item C<MOVEFILE_WRITE_THROUGH>
+
+Ensures that C<MoveFileEx> won't return until the operation has
+finished and been flushed to disk. This is not supported under
+Windows 95. Only affects file renames to another file system,
+forcing a buffer flush at the end of the copy operation.
+
+=back
+
+=item OsFHandleOpen
+
+=item C<OsFHandleOpen( FILE, $hNativeHandle, $sMode )>
+
+Opens a Perl file handle based on an already open Win32 native
+file handle [much like C's C<fdopen()> does with a file descriptor].
+Returns a true value if the open operation succeeded. For failure,
+returns a false value and sets C<$!> [and possibly C<fileLastError()>
+and C<$^E>] to the reason for the failure.
+
+C<FILE> is a Perl file handle [in any of the supported forms, a
+bareword, a string, a typeglob, or a reference to a typeglob] that
+will be opened. If C<FILE> is already open, it will automatically
+be closed before it is reopened.
+
+C<$hNativeHandle> is an open Win32 native file handle, probably the
+return value from C<CreateFile> or C<createFile>.
+
+C<$sMode> is string of zero or more letters from C<"rwatb">. These
+are translated into a combination C<O_RDONLY> [C<"r">], C<O_WRONLY>
+[C<"w">], C<O_RDWR> [C<"rw">], C<O_APPEND> [C<"a">], C<O_TEXT>
+[C<"t">], and C<O_BINARY> [C<"b">] flags [see the L<Fcntl> module]
+that is passed to C<OsFHandleOpenFd>. Currently only C<O_APPEND>
+and C<O_TEXT> have any significance.
+
+Also, a C<"r"> and/or C<"w"> in C<$sMode> is used to decide how the
+file descriptor is converted into a Perl file handle, even though this
+doesn't appear to make a difference. One of the following is used:
+
+ open( FILE, "<&=".$ivFd ) # "r" w/o "w"
+ open( FILE, ">&=".$ivFd ) # "w" w/o "r"
+ open( FILE, "+<&=".$ivFd ) # both "r" and "w"
+
+C<OsFHandleOpen> eventually calls the Win32-specific C routine
+C<_open_osfhandle()> or Perl's "improved" version called
+C<win32_open_osfhandle()>. Prior to Perl5.005, C's
+C<_open_osfhandle()> is called which will fail if
+C<GetFileType($hNativeHandle)> would return C<FILE_TYPE_UNKNOWN>. For
+Perl5.005 and later, C<OsFHandleOpen> calls C<win32_open_osfhandle()>
+from the Perl DLL which doesn't have this restriction.
+
+=item OsFHandleOpenFd
+
+=item C<$ivFD= OsFHandleOpenFd( $hNativeHandle, $uMode )>
+
+Opens a file descriptor [C<$ivFD>] based on an already open Win32
+native file handle, C<$hNativeHandle>. This just calls the
+Win32-specific C routine C<_open_osfhandle()> or Perl's "improved"
+version called C<win32_open_osfhandle()>. Prior to Perl5.005 and in Cygwin
+Perl, C's C<_open_osfhandle()> is called which will fail if
+C<GetFileType($hNativeHandle)> would return C<FILE_TYPE_UNKNOWN>. For
+Perl5.005 and later, C<OsFHandleOpenFd> calls C<win32_open_osfhandle()> from
+the Perl DLL which doesn't have this restriction.
+
+C<$uMode> the logical combination of zero or more C<O_*> constants
+exported by the C<Fcntl> module. Currently only C<O_APPEND> and
+C<O_TEXT> have any significance.
+
+C<$ivFD> will be non-negative if the open operation was successful.
+For failure, C<-1> is returned and C<$!> [and possibly
+C<fileLastError()> and C<$^E>] is set to the reason for the failure.
+
+=item QueryDosDevice
+
+=item C<$olTargetLen= QueryDosDevice( $sDosDeviceName, $osTargetPath, $lTargetBuf )>
+
+Looks up the definition of a given "DOS" device name, yielding the
+active Windows NT native device name along with any currently dormant
+definitions.
+
+C<$sDosDeviceName> is the name of the "DOS" device whose definitions
+we want. For example, C<"C:">, C<"COM1">, or C<"PhysicalDrive0">.
+If C<$sDosDeviceName> is C<[]> [for C<NULL>], the list of all DOS
+device names is returned instead.
+
+C<$osTargetPath> will be assigned a string containing the list of
+definitions. The definitions are each C<'\0'>-terminate and are
+concatenated into the string, most recent first, with an extra C<'\0'>
+at the end of the whole string [see C<GetLogicalDriveStrings> for
+a sample of this format].
+
+C<$lTargetBuf> is the size [in bytes] of the buffer to allocate for
+C<$osTargetPath>. See L<Buffer Sizes> for more information.
+
+C<$olTargetLen> is set to the number of bytes written to
+C<$osTargetPath> but you can also use C<length($osTargetPath)>
+to determine this.
+
+For failure, C<0> is returned and C<fileLastError()> and C<$^E> are
+set to the reason for the failure.
+
+=item ReadFile
+
+=item C<ReadFile( $hFile, $opBuffer, $lBytes, $olBytesRead, $pOverlapped )>
+
+Reads bytes from a file or file-like device. Returns a true value if
+the read operation was successful. For failure, returns a false value
+and sets C<fileLastError()> and C<$^E> for the reason for the failure.
+
+C<$hFile> is a Win32 native file handle that is already open to the
+file or device to read from.
+
+C<$opBuffer> will be set to a string containing the bytes read.
+
+C<$lBytes> is the number of bytes you would like to read.
+C<$opBuffer> is automatically initialized to have a buffer large
+enough to hold that many bytes. Unlike other buffer sizes, C<$lBytes>
+does not need to have a C<"="> prepended to it to prevent a larger
+value to be passed to the underlying Win32 C<ReadFile> API. However,
+a leading C<"="> will be silently ignored, even if Perl warnings are
+enabled.
+
+If C<$olBytesRead> is not C<[]>, it will be set to the actual number
+of bytes read, though C<length($opBuffer)> can also be used to
+determine this.
+
+C<$pOverlapped> is C<[]> or is a C<OVERLAPPED> structure packed
+into a string. This is only useful if C<$hFile> was opened with
+the C<FILE_FLAG_OVERLAPPED> flag set.
+
+=item SetErrorMode
+
+=item C<$uOldMode= SetErrorMode( $uNewMode )>
+
+Sets the mode controlling system error handling B<and> returns the
+previous mode value. Both C<$uOldMode> and C<$uNewMode> will have
+zero or more of the following bits set:
+
+=over
+
+=item C<SEM_FAILCRITICALERRORS>
+
+If set, indicates that when a critical error is encountered, the call
+that triggered the error fails immediately. Normally this bit is not
+set, which means that a critical error causes a dialogue box to appear
+notifying the desktop user that some application has triggered a
+critical error. The dialogue box allows the desktop user to decide
+whether the critical error is returned to the process, is ignored, or
+the offending operation is retried.
+
+This affects the C<CreateFile> and C<GetVolumeInformation> calls.
+
+Setting this bit is useful for allowing you to check whether a floppy
+diskette is in the floppy drive.
+
+=item C<SEM_NOALIGNMENTFAULTEXCEPT>
+
+If set, this causes memory access misalignment faults to be
+automatically fixed in a manner invisible to the process. This flag
+is ignored on x86-based versions of Windows NT. This flag is not
+supported on Windows 95.
+
+=item C<SEM_NOGPFAULTERRORBOX>
+
+If set, general protection faults do not generate a dialogue box but
+can instead be handled by the process via an exception handler. This
+bit should not be set by programs that don't know how to handle such
+faults.
+
+=item C<SEM_NOOPENFILEERRORBOX>
+
+If set, then when an attempt to continue reading from or writing to
+an already open file [usually on a removable medium like a floppy
+diskette] finds the file no longer available, the call will
+immediately fail. Normally this bit is not set, which means that
+instead a dialogue box will appear notifying the desktop user that
+some application has run into this problem. The dialogue box allows
+the desktop user to decide whether the failure is returned to the
+process, is ignored, or the offending operation is retried.
+
+This affects the C<ReadFile> and C<WriteFile> calls.
+
+=back
+
+=item setFilePointer
+
+=item C<$uNewPos = setFilePointer( $hFile, $ivOffset, $uFromWhere )>
+
+This is a perl-friendly wrapper for the SetFilePointer API (below).
+C<$ivOffset> can be a 64 bit integer or C<Math::BigInt> object if your Perl
+doesn't have 64 bit integers. The return value is the new offset and will
+likewise be a 64 bit integer or a C<Math::BigInt> object.
+
+=item SetFilePointer
+
+=item C<$uNewPos = SetFilePointer( $hFile, $ivOffset, $ioivOffsetHigh, $uFromWhere )>
+
+The native Win32 version of C<seek()>. C<SetFilePointer> sets the
+position within a file where the next read or write operation will
+start from.
+
+C<$hFile> is a Win32 native file handle.
+
+C<$uFromWhere> is either C<FILE_BEGIN>, C<FILE_CURRENT>, or
+C<FILE_END>, indicating that the new file position is being specified
+relative to the beginning of the file, the current file pointer, or
+the end of the file, respectively.
+
+C<$ivOffset> is [if C<$ioivOffsetHigh> is C<[]>] the offset [in bytes]
+to the new file position from the position specified via
+C<$uFromWhere>. If C<$ioivOffsetHigh> is not C<[]>, then C<$ivOffset>
+is converted to an unsigned value to be used as the low-order 4 bytes
+of the offset.
+
+C<$ioivOffsetHigh> can be C<[]> [for C<NULL>] to indicate that you are
+only specifying a 4-byte offset and the resulting file position will
+be 0xFFFFFFFE or less [just under 4GB]. Otherwise C<$ioivOfffsetHigh>
+starts out with the high-order 4 bytes [signed] of the offset and gets
+set to the [unsigned] high-order 4 bytes of the resulting file position.
+
+The underlying C<SetFilePointer> returns C<0xFFFFFFFF> to indicate
+failure, but if C<$ioivOffsetHigh> is not C<[]>, you would also have
+to check C<$^E> to determine whether C<0xFFFFFFFF> indicates an error
+or not. C<Win32API::File::SetFilePointer> does this checking for you
+and returns a false value if and only if the underlying
+C<SetFilePointer> failed. For this reason, C<$uNewPos> is set to
+C<"0 but true"> if you set the file pointer to the beginning of the
+file [or any position with 0 for the low-order 4 bytes].
+
+So the return value will be true if the seek operation was successful.
+For failure, a false value is returned and C<fileLastError()> and
+C<$^E> are set to the reason for the failure.
+
+=item SetHandleInformation
+
+=item C<SetHandleInformation( $hObject, $uMask, $uFlags )>
+
+Sets the flags associated with a Win32 native file handle or object
+handle. Returns a true value if the operation was successful. For
+failure, returns a false value and sets C<fileLastError()> and C<$^E>
+for the reason for the failure.
+
+C<$hObject> is an open Win32 native file handle or an open Win32 native
+handle to some other type of object.
+
+C<$uMask> is an unsigned value having one or more of the bits
+C<HANDLE_FLAG_INHERIT> and C<HANDLE_FLAG_PROTECT_FROM_CLOSE> set.
+Only bits set in C<$uMask> will be modified by C<SetHandleInformation>.
+
+C<$uFlags> is an unsigned value having zero or more of the bits
+C<HANDLE_FLAG_INHERIT> and C<HANDLE_FLAG_PROTECT_FROM_CLOSE> set.
+For each bit set in C<$uMask>, the cooresponding bit in the handle's
+flags is set to the value of the cooresponding bit in C<$uFlags>.
+
+If C<$uOldFlags> were the value of the handle's flags before the
+call to C<SetHandleInformation>, then the value of the handle's
+flags afterward would be:
+
+ ( $uOldFlags & ~$uMask ) | ( $uFlags & $uMask )
+
+[at least as far as the C<HANDLE_FLAG_INHERIT> and
+C<HANDLE_FLAG_PROTECT_FROM_CLOSE> bits are concerned.]
+
+See the C<":HANDLE_FLAG_"> export class for the meanings of these bits.
+
+=item WriteFile
+
+=item C<WriteFile( $hFile, $pBuffer, $lBytes, $ouBytesWritten, $pOverlapped )>
+
+Write bytes to a file or file-like device. Returns a true value if
+the operation was successful. For failure, returns a false value and
+sets C<fileLastError()> and C<$^E> for the reason for the failure.
+
+C<$hFile> is a Win32 native file handle that is already open to the
+file or device to be written to.
+
+C<$pBuffer> is a string containing the bytes to be written.
+
+C<$lBytes> is the number of bytes you would like to write. If
+C<$pBuffer> is not at least C<$lBytes> long, C<WriteFile> croaks. You
+can specify C<0> for C<$lBytes> to write C<length($pBuffer)> bytes.
+A leading C<"="> on C<$lBytes> will be silently ignored, even if Perl
+warnings are enabled.
+
+C<$ouBytesWritten> will be set to the actual number of bytes written
+unless you specify it as C<[]>.
+
+C<$pOverlapped> is C<[]> or is an C<OVERLAPPED> structure packed
+into a string. This is only useful if C<$hFile> was opened with
+the C<FILE_FLAG_OVERLAPPED> flag set.
+
+=back
+
+=item C<":FuncA">
+
+The ASCII-specific functions. Each of these is just the same as the
+version without the trailing "A".
+
+ CopyFileA
+ CreateFileA
+ DefineDosDeviceA
+ DeleteFileA
+ GetDriveTypeA
+ GetFileAttributesA
+ GetLogicalDriveStringsA
+ GetVolumeInformationA
+ MoveFileA
+ MoveFileExA
+ QueryDosDeviceA
+
+=item C<":FuncW">
+
+The wide-character-specific (Unicode) functions. Each of these is
+just the same as the version without the trailing "W" except that
+strings are expected in Unicode and some lengths are measured as
+number of C<WCHAR>s instead of number of bytes, as indicated below.
+
+=over
+
+=item CopyFileW
+
+=item C<CopyFileW( $swOldFileName, $swNewFileName, $bFailIfExists )>
+
+C<$swOldFileName> and C<$swNewFileName> are Unicode strings.
+
+=item CreateFileW
+
+=item C<$hObject= CreateFileW( $swPath, $uAccess, $uShare, $pSecAttr, $uCreate, $uFlags, $hModel )>
+
+C<$swPath> is Unicode.
+
+=item DefineDosDeviceW
+
+=item C<DefineDosDeviceW( $uFlags, $swDosDeviceName, $swTargetPath )>
+
+C<$swDosDeviceName> and C<$swTargetPath> are Unicode.
+
+=item DeleteFileW
+
+=item C<DeleteFileW( $swFileName )>
+
+C<$swFileName> is Unicode.
+
+=item GetDriveTypeW
+
+=item C<$uDriveType= GetDriveTypeW( $swRootPath )>
+
+C<$swRootPath> is Unicode.
+
+=item GetFileAttributesW
+
+=item C<$uAttrs= GetFileAttributesW( $swPath )>
+
+C<$swPath> is Unicode.
+
+=item GetLogicalDriveStringsW
+
+=item C<$olwOutLength= GetLogicalDriveStringsW( $lwBufSize, $oswBuffer )>
+
+Unicode is stored in C<$oswBuffer>. C<$lwBufSize> and C<$olwOutLength>
+are measured as number of C<WCHAR>s.
+
+=item GetVolumeInformationW
+
+=item C<GetVolumeInformationW( $swRootPath, $oswVolName, $lwVolName, $ouSerialNum, $ouMaxNameLen, $ouFsFlags, $oswFsType, $lwFsType )>
+
+C<$swRootPath> is Unicode and Unicode is written to C<$oswVolName> and
+C<$oswFsType>. C<$lwVolName> and C<$lwFsType> are measures as number
+of C<WCHAR>s.
+
+=item MoveFileW
+
+=item C<MoveFileW( $swOldName, $swNewName )>
+
+C<$swOldName> and C<$swNewName> are Unicode.
+
+=item MoveFileExW
+
+=item C<MoveFileExW( $swOldName, $swNewName, $uFlags )>
+
+C<$swOldName> and C<$swNewName> are Unicode.
+
+=item QueryDosDeviceW
+
+=item C<$olwTargetLen= QueryDosDeviceW( $swDeviceName, $oswTargetPath, $lwTargetBuf )>
+
+C<$swDeviceName> is Unicode and Unicode is written to
+C<$oswTargetPath>. C<$lwTargetBuf> and C<$olwTargetLen> are measured
+as number of C<WCHAR>s.
+
+=back
+
+=item C<":Misc">
+
+Miscellaneous constants. Used for the C<$uCreate> argument of
+C<CreateFile> or the C<$uFromWhere> argument of C<SetFilePointer>.
+Plus C<INVALID_HANDLE_VALUE>, which you usually won't need to check
+for since most routines translate it into a false value.
+
+ CREATE_ALWAYS CREATE_NEW OPEN_ALWAYS
+ OPEN_EXISTING TRUNCATE_EXISTING INVALID_HANDLE_VALUE
+ FILE_BEGIN FILE_CURRENT FILE_END
+
+=item C<":DDD_">
+
+Constants for the C<$uFlags> argument of C<DefineDosDevice>.
+
+ DDD_EXACT_MATCH_ON_REMOVE
+ DDD_RAW_TARGET_PATH
+ DDD_REMOVE_DEFINITION
+
+=item C<":DRIVE_">
+
+Constants returned by C<GetDriveType>.
+
+ DRIVE_UNKNOWN DRIVE_NO_ROOT_DIR DRIVE_REMOVABLE
+ DRIVE_FIXED DRIVE_REMOTE DRIVE_CDROM
+ DRIVE_RAMDISK
+
+=item C<":FILE_">
+
+Specific types of access to files that can be requested via the
+C<$uAccess> argument to C<CreateFile>.
+
+ FILE_READ_DATA FILE_LIST_DIRECTORY
+ FILE_WRITE_DATA FILE_ADD_FILE
+ FILE_APPEND_DATA FILE_ADD_SUBDIRECTORY
+ FILE_CREATE_PIPE_INSTANCE FILE_READ_EA
+ FILE_WRITE_EA FILE_EXECUTE
+ FILE_TRAVERSE FILE_DELETE_CHILD
+ FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES
+ FILE_ALL_ACCESS FILE_GENERIC_READ
+ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE )],
+
+=item C<":FILE_ATTRIBUTE_">
+
+File attribute constants. Returned by C<attrLetsToBits> and used in
+the C<$uFlags> argument to C<CreateFile>.
+
+ FILE_ATTRIBUTE_ARCHIVE FILE_ATTRIBUTE_COMPRESSED
+ FILE_ATTRIBUTE_HIDDEN FILE_ATTRIBUTE_NORMAL
+ FILE_ATTRIBUTE_OFFLINE FILE_ATTRIBUTE_READONLY
+ FILE_ATTRIBUTE_SYSTEM FILE_ATTRIBUTE_TEMPORARY
+
+In addition, C<GetFileAttributes> can return these constants (or
+INVALID_FILE_ATTRIBUTES in case of an error).
+
+ FILE_ATTRIBUTE_DEVICE FILE_ATTRIBUTE_DIRECTORY
+ FILE_ATTRIBUTE_ENCRYPTED FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
+ FILE_ATTRIBUTE_REPARSE_POINT FILE_ATTRIBUTE_SPARSE_FILE
+
+=item C<":FILE_FLAG_">
+
+File option flag constants. Used in the C<$uFlags> argument to
+C<CreateFile>.
+
+ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_DELETE_ON_CLOSE
+ FILE_FLAG_NO_BUFFERING FILE_FLAG_OVERLAPPED
+ FILE_FLAG_POSIX_SEMANTICS FILE_FLAG_RANDOM_ACCESS
+ FILE_FLAG_SEQUENTIAL_SCAN FILE_FLAG_WRITE_THROUGH
+ FILE_FLAG_OPEN_REPARSE_POINT
+
+=item C<":FILE_SHARE_">
+
+File sharing constants. Used in the C<$uShare> argument to
+C<CreateFile>.
+
+ FILE_SHARE_DELETE FILE_SHARE_READ FILE_SHARE_WRITE
+
+=item C<":FILE_TYPE_">
+
+File type constants. Returned by C<GetFileType>.
+
+ FILE_TYPE_CHAR FILE_TYPE_DISK
+ FILE_TYPE_PIPE FILE_TYPE_UNKNOWN
+
+=item C<":FS_">
+
+File system characteristics constants. Placed in the C<$ouFsFlags>
+argument to C<GetVolumeInformation>.
+
+ FS_CASE_IS_PRESERVED FS_CASE_SENSITIVE
+ FS_UNICODE_STORED_ON_DISK FS_PERSISTENT_ACLS
+ FS_FILE_COMPRESSION FS_VOL_IS_COMPRESSED
+
+=item C<":HANDLE_FLAG_">
+
+Flag bits modifying the behavior of an object handle and accessed via
+C<GetHandleInformation> and C<SetHandleInformation>.
+
+=over
+
+=item HANDLE_FLAG_INHERIT
+
+If this bit is set, then children of this process who inherit handles
+[that is, processes created by calls to the Win32 C<CreateProcess> API
+with the C<bInheritHandles> parameter specified as C<TRUE>], will inherit
+this particular object handle.
+
+=item HANDLE_FLAG_PROTECT_FROM_CLOSE
+
+If this bit is set, then calls to C<CloseHandle> against this handle
+will be ignored, leaving the handle open and usable.
+
+=back
+
+=item C<":IOCTL_STORAGE_">
+
+I/O control operations for generic storage devices. Used in the
+C<$uIoControlCode> argument to C<DeviceIoControl>. Includes
+C<IOCTL_STORAGE_CHECK_VERIFY>, C<IOCTL_STORAGE_MEDIA_REMOVAL>,
+C<IOCTL_STORAGE_EJECT_MEDIA>, C<IOCTL_STORAGE_LOAD_MEDIA>,
+C<IOCTL_STORAGE_RESERVE>, C<IOCTL_STORAGE_RELEASE>,
+C<IOCTL_STORAGE_FIND_NEW_DEVICES>, and
+C<IOCTL_STORAGE_GET_MEDIA_TYPES>.
+
+=over
+
+=item C<IOCTL_STORAGE_CHECK_VERIFY>
+
+Verify that a device's media is accessible. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>. If C<DeviceIoControl> returns a true value, then
+the media is currently accessible.
+
+=item C<IOCTL_STORAGE_MEDIA_REMOVAL>
+
+Allows the device's media to be locked or unlocked. C<$opOutBuf> should
+be C<[]>. C<$pInBuf> should be a C<PREVENT_MEDIA_REMOVAL> data structure,
+which is simply an interger containing a boolean value:
+
+ $pInBuf= pack( "i", $bPreventMediaRemoval );
+
+=item C<IOCTL_STORAGE_EJECT_MEDIA>
+
+Requests that the device eject the media. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_LOAD_MEDIA>
+
+Requests that the device load the media. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_RESERVE>
+
+Requests that the device be reserved. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_RELEASE>
+
+Releases a previous device reservation. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_FIND_NEW_DEVICES>
+
+No documentation on this IOCTL operation was found.
+
+=item C<IOCTL_STORAGE_GET_MEDIA_TYPES>
+
+Requests information about the type of media supported by the device.
+C<$pInBuf> should be C<[]>. C<$opOutBuf> will be set to contain a
+vector of C<DISK_GEOMETRY> data structures, which can be decoded via:
+
+ # Calculate the number of DISK_GEOMETRY structures returned:
+ my $cStructs= length($opOutBuf)/(4+4+4+4+4+4);
+ my @fields= unpack( "L l I L L L" x $cStructs, $opOutBuf )
+ my( @ucCylsLow, @ivcCylsHigh, @uMediaType, @uTracksPerCyl,
+ @uSectsPerTrack, @uBytesPerSect )= ();
+ while( @fields ) {
+ push( @ucCylsLow, unshift @fields );
+ push( @ivcCylsHigh, unshift @fields );
+ push( @uMediaType, unshift @fields );
+ push( @uTracksPerCyl, unshift @fields );
+ push( @uSectsPerTrack, unshift @fields );
+ push( @uBytesPerSect, unshift @fields );
+ }
+
+For the C<$i>th type of supported media, the following variables will
+contain the following data.
+
+=over
+
+=item C<$ucCylsLow[$i]>
+
+The low-order 4 bytes of the total number of cylinders.
+
+=item C<$ivcCylsHigh[$i]>
+
+The high-order 4 bytes of the total number of cylinders.
+
+=item C<$uMediaType[$i]>
+
+A code for the type of media. See the C<":MEDIA_TYPE"> export class.
+
+=item C<$uTracksPerCyl[$i]>
+
+The number of tracks in each cylinder.
+
+=item C<$uSectsPerTrack[$i]>
+
+The number of sectors in each track.
+
+=item C<$uBytesPerSect[$i]>
+
+The number of bytes in each sector.
+
+=back
+
+=back
+
+=item C<":IOCTL_DISK_">
+
+I/O control operations for disk devices. Used in the C<$uIoControlCode>
+argument to C<DeviceIoControl>. Most of these are to be used on
+physical drive devices like C<"//./PhysicalDrive0">. However,
+C<IOCTL_DISK_GET_PARTITION_INFO> and C<IOCTL_DISK_SET_PARTITION_INFO>
+should only be used on a single-partition device like C<"//./C:">. Also,
+C<IOCTL_DISK_GET_MEDIA_TYPES> is documented as having been superceded but
+is still useful when used on a floppy device like C<"//./A:">.
+
+Includes C<IOCTL_DISK_FORMAT_TRACKS>, C<IOCTL_DISK_FORMAT_TRACKS_EX>,
+C<IOCTL_DISK_GET_DRIVE_GEOMETRY>, C<IOCTL_DISK_GET_DRIVE_LAYOUT>,
+C<IOCTL_DISK_GET_MEDIA_TYPES>, C<IOCTL_DISK_GET_PARTITION_INFO>,
+C<IOCTL_DISK_HISTOGRAM_DATA>, C<IOCTL_DISK_HISTOGRAM_RESET>,
+C<IOCTL_DISK_HISTOGRAM_STRUCTURE>, C<IOCTL_DISK_IS_WRITABLE>,
+C<IOCTL_DISK_LOGGING>, C<IOCTL_DISK_PERFORMANCE>,
+C<IOCTL_DISK_REASSIGN_BLOCKS>, C<IOCTL_DISK_REQUEST_DATA>,
+C<IOCTL_DISK_REQUEST_STRUCTURE>, C<IOCTL_DISK_SET_DRIVE_LAYOUT>,
+C<IOCTL_DISK_SET_PARTITION_INFO>, and C<IOCTL_DISK_VERIFY>.
+
+=over
+
+=item C<IOCTL_DISK_GET_DRIVE_GEOMETRY>
+
+Request information about the size and geometry of the disk. C<$pInBuf>
+should be C<[]>. C<$opOutBuf> will be set to a C<DISK_GEOMETRY> data
+structure which can be decode via:
+
+ ( $ucCylsLow, $ivcCylsHigh, $uMediaType, $uTracksPerCyl,
+ $uSectsPerTrack, $uBytesPerSect )= unpack( "L l I L L L", $opOutBuf );
+
+=over
+
+=item C<$ucCylsLow>
+
+The low-order 4 bytes of the total number of cylinders.
+
+=item C<$ivcCylsHigh>
+
+The high-order 4 bytes of the total number of cylinders.
+
+=item C<$uMediaType>
+
+A code for the type of media. See the C<":MEDIA_TYPE"> export class.
+
+=item C<$uTracksPerCyl>
+
+The number of tracks in each cylinder.
+
+=item C<$uSectsPerTrack>
+
+The number of sectors in each track.
+
+=item C<$uBytesPerSect>
+
+The number of bytes in each sector.
+
+=back
+
+=item C<IOCTL_DISK_GET_PARTITION_INFO>
+
+Request information about the size and geometry of the partition.
+C<$pInBuf> should be C<[]>. C<$opOutBuf> will be set to a
+C<PARTITION_INFORMATION> data structure which can be decode via:
+
+ ( $uStartLow, $ivStartHigh, $ucHiddenSects, $uPartitionSeqNumber,
+ $uPartitionType, $bActive, $bRecognized, $bToRewrite )=
+ unpack( "L l L L C c c c", $opOutBuf );
+
+=over
+
+=item C<$uStartLow> and C<$ivStartHigh>
+
+The low-order and high-order [respectively] 4 bytes of the starting
+offset of the partition, measured in bytes.
+
+=item C<$ucHiddenSects>
+
+The number of "hidden" sectors for this partition. Actually this is
+the number of sectors found prior to this partiton, that is, the
+starting offset [as found in C<$uStartLow> and C<$ivStartHigh>]
+divided by the number of bytes per sector.
+
+=item C<$uPartitionSeqNumber>
+
+The sequence number of this partition. Partitions are numbered
+starting as C<1> [with "partition 0" meaning the entire disk].
+Sometimes this field may be C<0> and you'll have to infer the
+partition sequence number from how many partitions preceed it on
+the disk.
+
+=item C<$uPartitionType>
+
+The type of partition. See the C<":PARTITION_"> export class for a
+list of known types. See also C<IsRecognizedPartition> and
+C<IsContainerPartition>.
+
+=item C<$bActive>
+
+C<1> for the active [boot] partition, C<0> otherwise.
+
+=item C<$bRecognized>
+
+Whether this type of partition is support under Win32.
+
+=item C<$bToRewrite>
+
+Whether to update this partition information. This field is not used
+by C<IOCTL_DISK_GET_PARTITION_INFO>. For
+C<IOCTL_DISK_SET_DRIVE_LAYOUT>, you must set this field to a true
+value for any partitions you wish to have changed, added, or deleted.
+
+=back
+
+=item C<IOCTL_DISK_SET_PARTITION_INFO>
+
+Change the type of the partition. C<$opOutBuf> should be C<[]>.
+C<$pInBuf> should be a C<SET_PARTITION_INFORMATION> data structure
+which is just a single byte containing the new parition type [see
+the C<":PARTITION_"> export class for a list of known types]:
+
+ $pInBuf= pack( "C", $uPartitionType );
+
+=item C<IOCTL_DISK_GET_DRIVE_LAYOUT>
+
+Request information about the disk layout. C<$pInBuf> should be C<[]>.
+C<$opOutBuf> will be set to contain C<DRIVE_LAYOUT_INFORMATION>
+structure including several C<PARTITION_INFORMATION> structures:
+
+ my( $cPartitions, $uDiskSignature )= unpack( "L L", $opOutBuf );
+ my @fields= unpack( "x8" . ( "L l L L C c c c" x $cPartitions ),
+ $opOutBuf );
+ my( @uStartLow, @ivStartHigh, @ucHiddenSects,
+ @uPartitionSeqNumber, @uPartitionType, @bActive,
+ @bRecognized, @bToRewrite )= ();
+ for( 1..$cPartition ) {
+ push( @uStartLow, unshift @fields );
+ push( @ivStartHigh, unshift @fields );
+ push( @ucHiddenSects, unshift @fields );
+ push( @uPartitionSeqNumber, unshift @fields );
+ push( @uPartitionType, unshift @fields );
+ push( @bActive, unshift @fields );
+ push( @bRecognized, unshift @fields );
+ push( @bToRewrite, unshift @fields );
+ }
+
+=over
+
+=item C<$cPartitions>
+
+If the number of partitions on the disk.
+
+=item C<$uDiskSignature>
+
+Is the disk signature, a unique number assigned by Disk Administrator
+[F<WinDisk.exe>] and used to identify the disk. This allows drive
+letters for partitions on that disk to remain constant even if the
+SCSI Target ID of the disk gets changed.
+
+=back
+
+See C<IOCTL_DISK_GET_PARTITION_INFORMATION> for information on the
+remaining these fields.
+
+=item C<IOCTL_DISK_GET_MEDIA_TYPES>
+
+Is supposed to be superseded by C<IOCTL_STORAGE_GET_MEDIA_TYPES> but
+is still useful for determining the types of floppy diskette formats
+that can be produced by a given floppy drive. See
+F<ex/FormatFloppy.plx> for an example.
+
+=item C<IOCTL_DISK_SET_DRIVE_LAYOUT>
+
+Change the partition layout of the disk. C<$pOutBuf> should be C<[]>.
+C<$pInBuf> should be a C<DISK_LAYOUT_INFORMATION> data structure
+including several C<PARTITION_INFORMATION> data structures.
+
+ # Already set: $cPartitions, $uDiskSignature, @uStartLow, @ivStartHigh,
+ # @ucHiddenSects, @uPartitionSeqNumber, @uPartitionType, @bActive,
+ # @bRecognized, and @bToRewrite.
+ my( @fields, $prtn )= ();
+ for $prtn ( 1..$cPartition ) {
+ push( @fields, $uStartLow[$prtn-1], $ivStartHigh[$prtn-1],
+ $ucHiddenSects[$prtn-1], $uPartitionSeqNumber[$prtn-1],
+ $uPartitionType[$prtn-1], $bActive[$prtn-1],
+ $bRecognized[$prtn-1], $bToRewrite[$prtn-1] );
+ }
+ $pInBuf= pack( "L L" . ( "L l L L C c c c" x $cPartitions ),
+ $cPartitions, $uDiskSignature, @fields );
+
+To delete a partition, zero out all fields except for C<$bToRewrite>
+which should be set to C<1>. To add a partition, increment
+C<$cPartitions> and add the information for the new partition
+into the arrays, making sure that you insert C<1> into @bToRewrite.
+
+See C<IOCTL_DISK_GET_DRIVE_LAYOUT> and
+C<IOCTL_DISK_GET_PARITITON_INFORMATION> for descriptions of the
+fields.
+
+=item C<IOCTL_DISK_VERIFY>
+
+Performs a logical format of [part of] the disk. C<$opOutBuf> should
+be C<[]>. C<$pInBuf> should contain a C<VERIFY_INFORMATION> data
+structure:
+
+ $pInBuf= pack( "L l L",
+ $uStartOffsetLow, $ivStartOffsetHigh, $uLength );
+
+=over
+
+=item C<$uStartOffsetLow> and C<$ivStartOffsetHigh>
+
+The low-order and high-order [respectively] 4 bytes of the offset [in
+bytes] where the formatting should begin.
+
+=item C<$uLength>
+
+The length [in bytes] of the section to be formatted.
+
+=back
+
+=item C<IOCTL_DISK_FORMAT_TRACKS>
+
+Format a range of tracks on the disk. C<$opOutBuf> should be C<[]>.
+C<$pInBuf> should contain a C<FORMAT_PARAMETERS> data structure:
+
+ $pInBuf= pack( "L L L L L", $uMediaType,
+ $uStartCyl, $uEndCyl, $uStartHead, $uEndHead );
+
+C<$uMediaType> if the type of media to be formatted. Mostly used to
+specify the density to use when formatting a floppy diskette. See the
+C<":MEDIA_TYPE"> export class for more information.
+
+The remaining fields specify the starting and ending cylinder and
+head of the range of tracks to be formatted.
+
+=item C<IOCTL_DISK_REASSIGN_BLOCKS>
+
+Reassign a list of disk blocks to the disk's spare-block pool.
+C<$opOutBuf> should be C<[]>. C<$pInBuf> should be a
+C<REASSIGN_BLOCKS> data structure:
+
+ $pInBuf= pack( "S S L*", 0, $cBlocks, @uBlockNumbers );
+
+=item C<IOCTL_DISK_PERFORMANCE>
+
+Request information about disk performance. C<$pInBuf> should be C<[]>.
+C<$opOutBuf> will be set to contain a C<DISK_PERFORMANCE> data structure:
+
+ my( $ucBytesReadLow, $ivcBytesReadHigh,
+ $ucBytesWrittenLow, $ivcBytesWrittenHigh,
+ $uReadTimeLow, $ivReadTimeHigh,
+ $uWriteTimeLow, $ivWriteTimeHigh,
+ $ucReads, $ucWrites, $uQueueDepth )=
+ unpack( "L l L l L l L l L L L", $opOutBuf );
+
+=item C<IOCTL_DISK_IS_WRITABLE>
+
+No documentation on this IOCTL operation was found.
+
+=item C<IOCTL_DISK_LOGGING>
+
+Control disk logging. Little documentation for this IOCTL operation
+was found. It makes use of a C<DISK_LOGGING> data structure:
+
+=over
+
+=item DISK_LOGGING_START
+
+Start logging each disk request in a buffer internal to the disk device
+driver of size C<$uLogBufferSize>:
+
+ $pInBuf= pack( "C L L", 0, 0, $uLogBufferSize );
+
+=item DISK_LOGGING_STOP
+
+Stop loggin each disk request:
+
+ $pInBuf= pack( "C L L", 1, 0, 0 );
+
+=item DISK_LOGGING_DUMP
+
+Copy the interal log into the supplied buffer:
+
+ $pLogBuffer= ' ' x $uLogBufferSize
+ $pInBuf= pack( "C P L", 2, $pLogBuffer, $uLogBufferSize );
+
+ ( $uByteOffsetLow[$i], $ivByteOffsetHigh[$i],
+ $uStartTimeLow[$i], $ivStartTimeHigh[$i],
+ $uEndTimeLog[$i], $ivEndTimeHigh[$i],
+ $hVirtualAddress[$i], $ucBytes[$i],
+ $uDeviceNumber[$i], $bWasReading[$i] )=
+ unpack( "x".(8+8+8+4+4+1+1+2)." L l L l L l L L C c x2", $pLogBuffer );
+
+=item DISK_LOGGING_BINNING
+
+Keep statics grouped into bins based on request sizes.
+
+ $pInBuf= pack( "C P L", 3, $pUnknown, $uUnknownSize );
+
+=back
+
+=item C<IOCTL_DISK_FORMAT_TRACKS_EX>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_HISTOGRAM_STRUCTURE>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_HISTOGRAM_DATA>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_HISTOGRAM_RESET>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_REQUEST_STRUCTURE>
+
+No documentation on this IOCTL operation was found.
+
+=item C<IOCTL_DISK_REQUEST_DATA>
+
+No documentation on this IOCTL operation was found.
+
+=back
+
+=item C<":FSCTL_">
+
+File system control operations. Used in the C<$uIoControlCode>
+argument to C<DeviceIoControl>.
+
+Includes C<FSCTL_SET_REPARSE_POINT>, C<FSCTL_GET_REPARSE_POINT>,
+C<FSCTL_DELETE_REPARSE_POINT>.
+
+=over
+
+=item C<FSCTL_SET_REPARSE_POINT>
+
+Sets reparse point data to be associated with $hDevice.
+
+=item C<FSCTL_GET_REPARSE_POINT>
+
+Retrieves the reparse point data associated with $hDevice.
+
+=item C<FSCTL_DELETE_REPARSE_POINT>
+
+Deletes the reparse point data associated with $hDevice.
+
+=back
+
+=item C<":GENERIC_">
+
+Constants specifying generic access permissions that are not specific
+to one type of object.
+
+ GENERIC_ALL GENERIC_EXECUTE
+ GENERIC_READ GENERIC_WRITE
+
+=item C<":MEDIA_TYPE">
+
+Different classes of media that a device can support. Used in the
+C<$uMediaType> field of a C<DISK_GEOMETRY> structure.
+
+=over
+
+=item C<Unknown>
+
+Format is unknown.
+
+=item C<F5_1Pt2_512>
+
+5.25" floppy, 1.2MB [really 1,200KB] total space, 512 bytes/sector.
+
+=item C<F3_1Pt44_512>
+
+3.5" floppy, 1.44MB [really 1,440KB] total space, 512 bytes/sector.
+
+=item C<F3_2Pt88_512>
+
+3.5" floppy, 2.88MB [really 2,880KB] total space, 512 bytes/sector.
+
+=item C<F3_20Pt8_512>
+
+3.5" floppy, 20.8MB total space, 512 bytes/sector.
+
+=item C<F3_720_512>
+
+3.5" floppy, 720KB total space, 512 bytes/sector.
+
+=item C<F5_360_512>
+
+5.25" floppy, 360KB total space, 512 bytes/sector.
+
+=item C<F5_320_512>
+
+5.25" floppy, 320KB total space, 512 bytes/sector.
+
+=item C<F5_320_1024>
+
+5.25" floppy, 320KB total space, 1024 bytes/sector.
+
+=item C<F5_180_512>
+
+5.25" floppy, 180KB total space, 512 bytes/sector.
+
+=item C<F5_160_512>
+
+5.25" floppy, 160KB total space, 512 bytes/sector.
+
+=item C<RemovableMedia>
+
+Some type of removable media other than a floppy diskette.
+
+=item C<FixedMedia>
+
+A fixed hard disk.
+
+=item C<F3_120M_512>
+
+3.5" floppy, 120MB total space.
+
+=back
+
+=item C<":MOVEFILE_">
+
+Constants for use in C<$uFlags> arguments to C<MoveFileEx>.
+
+ MOVEFILE_COPY_ALLOWED MOVEFILE_DELAY_UNTIL_REBOOT
+ MOVEFILE_REPLACE_EXISTING MOVEFILE_WRITE_THROUGH
+
+=item C<":SECURITY_">
+
+Security quality of service values that can be used in the C<$uFlags>
+argument to C<CreateFile> if opening the client side of a named pipe.
+
+ SECURITY_ANONYMOUS SECURITY_CONTEXT_TRACKING
+ SECURITY_DELEGATION SECURITY_EFFECTIVE_ONLY
+ SECURITY_IDENTIFICATION SECURITY_IMPERSONATION
+ SECURITY_SQOS_PRESENT
+
+=item C<":SEM_">
+
+Constants to be used with C<SetErrorMode>.
+
+ SEM_FAILCRITICALERRORS SEM_NOGPFAULTERRORBOX
+ SEM_NOALIGNMENTFAULTEXCEPT SEM_NOOPENFILEERRORBOX
+
+=item C<":PARTITION_">
+
+Constants describing partition types.
+
+ PARTITION_ENTRY_UNUSED PARTITION_FAT_12
+ PARTITION_XENIX_1 PARTITION_XENIX_2
+ PARTITION_FAT_16 PARTITION_EXTENDED
+ PARTITION_HUGE PARTITION_IFS
+ PARTITION_FAT32 PARTITION_FAT32_XINT13
+ PARTITION_XINT13 PARTITION_XINT13_EXTENDED
+ PARTITION_PREP PARTITION_UNIX
+ VALID_NTFT PARTITION_NTFT
+
+=item C<":ALL">
+
+All of the above.
+
+=back
+
+=head1 BUGS
+
+None known at this time.
+
+=head1 AUTHOR
+
+Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
+
+=head1 SEE ALSO
+
+The pyramids.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32API/File/cFile.pc b/Master/tlpkg/tlperl.straw/lib/Win32API/File/cFile.pc
new file mode 100755
index 00000000000..da00f413aa2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32API/File/cFile.pc
@@ -0,0 +1,165 @@
+# Generated by cFile_pc.cxx.
+# Package Win32API::File with options:
+# CPLUSPLUS => q[1]
+# IFDEF => q[!/[a-z\d]/]
+# IMPORT_LIST => [q[/._/], q[!/[a-z]/], q[:MEDIA_TYPE]]
+# WRITE_PERL => q[1]
+# Perl files eval'd:
+# File.pm => last if /^\s*(bootstrap|XSLoader::load)\b/
+# C files included:
+# File.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b#
+sub CREATE_ALWAYS () { 2 }
+sub CREATE_NEW () { 1 }
+sub DDD_EXACT_MATCH_ON_REMOVE () { 4 }
+sub DDD_RAW_TARGET_PATH () { 1 }
+sub DDD_REMOVE_DEFINITION () { 2 }
+sub DRIVE_CDROM () { 5 }
+sub DRIVE_FIXED () { 3 }
+sub DRIVE_NO_ROOT_DIR () { 1 }
+sub DRIVE_RAMDISK () { 6 }
+sub DRIVE_REMOTE () { 4 }
+sub DRIVE_REMOVABLE () { 2 }
+sub DRIVE_UNKNOWN () { 0 }
+sub F3_120M_512 () { 13 }
+sub F3_1Pt44_512 () { 2 }
+sub F3_20Pt8_512 () { 4 }
+sub F3_2Pt88_512 () { 3 }
+sub F3_720_512 () { 5 }
+sub F5_160_512 () { 10 }
+sub F5_180_512 () { 9 }
+sub F5_1Pt2_512 () { 1 }
+sub F5_320_1024 () { 8 }
+sub F5_320_512 () { 7 }
+sub F5_360_512 () { 6 }
+sub FILE_ADD_FILE () { 2 }
+sub FILE_ADD_SUBDIRECTORY () { 4 }
+sub FILE_ALL_ACCESS () { 2032127 }
+sub FILE_APPEND_DATA () { 4 }
+sub FILE_ATTRIBUTE_ARCHIVE () { 32 }
+sub FILE_ATTRIBUTE_COMPRESSED () { 2048 }
+sub FILE_ATTRIBUTE_DEVICE () { 0x00000040 }
+sub FILE_ATTRIBUTE_DIRECTORY () { 0x00000010 }
+sub FILE_ATTRIBUTE_ENCRYPTED () { 0x00004000 }
+sub FILE_ATTRIBUTE_HIDDEN () { 2 }
+sub FILE_ATTRIBUTE_NORMAL () { 128 }
+sub FILE_ATTRIBUTE_NOT_CONTENT_INDEXED () { 0x00002000 }
+sub FILE_ATTRIBUTE_OFFLINE () { 4096 }
+sub FILE_ATTRIBUTE_READONLY () { 1 }
+sub FILE_ATTRIBUTE_REPARSE_POINT () { 0x00000400 }
+sub FILE_ATTRIBUTE_SPARSE_FILE () { 0x00000200 }
+sub FILE_ATTRIBUTE_SYSTEM () { 4 }
+sub FILE_ATTRIBUTE_TEMPORARY () { 256 }
+sub FILE_BEGIN () { 0 }
+sub FILE_CREATE_PIPE_INSTANCE () { 4 }
+sub FILE_CURRENT () { 1 }
+sub FILE_DELETE_CHILD () { 64 }
+sub FILE_END () { 2 }
+sub FILE_EXECUTE () { 32 }
+sub FILE_FLAG_BACKUP_SEMANTICS () { 33554432 }
+sub FILE_FLAG_DELETE_ON_CLOSE () { 67108864 }
+sub FILE_FLAG_NO_BUFFERING () { 536870912 }
+sub FILE_FLAG_OPEN_REPARSE_POINT () { 0x200000 }
+sub FILE_FLAG_OVERLAPPED () { 1073741824 }
+sub FILE_FLAG_POSIX_SEMANTICS () { 16777216 }
+sub FILE_FLAG_RANDOM_ACCESS () { 268435456 }
+sub FILE_FLAG_SEQUENTIAL_SCAN () { 134217728 }
+sub FILE_FLAG_WRITE_THROUGH () { 0x80000000 }
+sub FILE_GENERIC_EXECUTE () { 1179808 }
+sub FILE_GENERIC_READ () { 1179785 }
+sub FILE_GENERIC_WRITE () { 1179926 }
+sub FILE_LIST_DIRECTORY () { 1 }
+sub FILE_READ_ATTRIBUTES () { 128 }
+sub FILE_READ_DATA () { 1 }
+sub FILE_READ_EA () { 8 }
+sub FILE_SHARE_DELETE () { 4 }
+sub FILE_SHARE_READ () { 1 }
+sub FILE_SHARE_WRITE () { 2 }
+sub FILE_TRAVERSE () { 32 }
+sub FILE_TYPE_CHAR () { 2 }
+sub FILE_TYPE_DISK () { 1 }
+sub FILE_TYPE_PIPE () { 3 }
+sub FILE_TYPE_UNKNOWN () { 0 }
+sub FILE_WRITE_ATTRIBUTES () { 256 }
+sub FILE_WRITE_DATA () { 2 }
+sub FILE_WRITE_EA () { 16 }
+sub FS_CASE_IS_PRESERVED () { 2 }
+sub FS_CASE_SENSITIVE () { 1 }
+sub FS_FILE_COMPRESSION () { 16 }
+sub FS_PERSISTENT_ACLS () { 8 }
+sub FS_UNICODE_STORED_ON_DISK () { 4 }
+sub FS_VOL_IS_COMPRESSED () { 32768 }
+sub FSCTL_SET_REPARSE_POINT () { (9 << 16 | 0 << 14 | 41 << 2 | 0) }
+sub FSCTL_GET_REPARSE_POINT () { (9 << 16 | 0 << 14 | 42 << 2 | 0) }
+sub FSCTL_DELETE_REPARSE_POINT () { (9 << 16 | 0 << 14 | 43 << 2 | 0) }
+sub FixedMedia () { 12 }
+sub GENERIC_ALL () { 268435456 }
+sub GENERIC_EXECUTE () { 536870912 }
+sub GENERIC_READ () { 0x80000000 }
+sub GENERIC_WRITE () { 1073741824 }
+sub HANDLE_FLAG_INHERIT () { 1 }
+sub HANDLE_FLAG_PROTECT_FROM_CLOSE () { 2 }
+sub INVALID_FILE_ATTRIBUTES () { 0xFFFFFFFF }
+sub INVALID_HANDLE_VALUE () { 0xffffffff }
+sub IOCTL_DISK_FORMAT_TRACKS () { 507928 }
+sub IOCTL_DISK_FORMAT_TRACKS_EX () { 507948 }
+sub IOCTL_DISK_GET_DRIVE_GEOMETRY () { 458752 }
+sub IOCTL_DISK_GET_DRIVE_LAYOUT () { 475148 }
+sub IOCTL_DISK_GET_MEDIA_TYPES () { 461824 }
+sub IOCTL_DISK_GET_PARTITION_INFO () { 475140 }
+sub IOCTL_DISK_HISTOGRAM_DATA () { 458804 }
+sub IOCTL_DISK_HISTOGRAM_RESET () { 458808 }
+sub IOCTL_DISK_HISTOGRAM_STRUCTURE () { 458800 }
+sub IOCTL_DISK_IS_WRITABLE () { 458788 }
+sub IOCTL_DISK_LOGGING () { 458792 }
+sub IOCTL_DISK_PERFORMANCE () { 458784 }
+sub IOCTL_DISK_REASSIGN_BLOCKS () { 507932 }
+sub IOCTL_DISK_REQUEST_DATA () { 458816 }
+sub IOCTL_DISK_REQUEST_STRUCTURE () { 458812 }
+sub IOCTL_DISK_SET_DRIVE_LAYOUT () { 507920 }
+sub IOCTL_DISK_SET_PARTITION_INFO () { 507912 }
+sub IOCTL_DISK_VERIFY () { 458772 }
+sub IOCTL_STORAGE_CHECK_VERIFY () { 2967552 }
+sub IOCTL_STORAGE_EJECT_MEDIA () { 2967560 }
+sub IOCTL_STORAGE_FIND_NEW_DEVICES () { 2967576 }
+sub IOCTL_STORAGE_GET_MEDIA_TYPES () { 2952192 }
+sub IOCTL_STORAGE_LOAD_MEDIA () { 2967564 }
+sub IOCTL_STORAGE_MEDIA_REMOVAL () { 2967556 }
+sub IOCTL_STORAGE_RELEASE () { 2967572 }
+sub IOCTL_STORAGE_RESERVE () { 2967568 }
+sub MOVEFILE_COPY_ALLOWED () { 2 }
+sub MOVEFILE_DELAY_UNTIL_REBOOT () { 4 }
+sub MOVEFILE_REPLACE_EXISTING () { 1 }
+sub MOVEFILE_WRITE_THROUGH () { 8 }
+sub OPEN_ALWAYS () { 4 }
+sub OPEN_EXISTING () { 3 }
+sub PARTITION_ENTRY_UNUSED () { 0 }
+sub PARTITION_EXTENDED () { 5 }
+sub PARTITION_FAT32 () { 11 }
+sub PARTITION_FAT32_XINT13 () { 12 }
+sub PARTITION_FAT_12 () { 1 }
+sub PARTITION_FAT_16 () { 4 }
+sub PARTITION_HUGE () { 6 }
+sub PARTITION_IFS () { 7 }
+sub PARTITION_NTFT () { 128 }
+sub PARTITION_PREP () { 65 }
+sub PARTITION_UNIX () { 99 }
+sub PARTITION_XENIX_1 () { 2 }
+sub PARTITION_XENIX_2 () { 3 }
+sub PARTITION_XINT13 () { 14 }
+sub PARTITION_XINT13_EXTENDED () { 15 }
+sub RemovableMedia () { 11 }
+sub SECURITY_ANONYMOUS () { 0 }
+sub SECURITY_CONTEXT_TRACKING () { 262144 }
+sub SECURITY_DELEGATION () { 196608 }
+sub SECURITY_EFFECTIVE_ONLY () { 524288 }
+sub SECURITY_IDENTIFICATION () { 65536 }
+sub SECURITY_IMPERSONATION () { 131072 }
+sub SECURITY_SQOS_PRESENT () { 1048576 }
+sub SEM_FAILCRITICALERRORS () { 1 }
+sub SEM_NOALIGNMENTFAULTEXCEPT () { 4 }
+sub SEM_NOGPFAULTERRORBOX () { 2 }
+sub SEM_NOOPENFILEERRORBOX () { 32768 }
+sub TRUNCATE_EXISTING () { 5 }
+sub Unknown () { 0 }
+sub VALID_NTFT () { 192 }
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32API/Registry.pm b/Master/tlpkg/tlperl.straw/lib/Win32API/Registry.pm
new file mode 100755
index 00000000000..e02f8bb530d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32API/Registry.pm
@@ -0,0 +1,1772 @@
+# Registry.pm -- Low-level access to functions/constants from WINREG.h
+
+package Win32API::Registry;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); #@EXPORT_FAIL);
+$VERSION= '0.30';
+
+require Exporter;
+require DynaLoader;
+@ISA= qw(Exporter DynaLoader);
+
+@EXPORT= qw();
+%EXPORT_TAGS= (
+ Func => [qw( regConstant regLastError
+ AllowPriv AbortSystemShutdown InitiateSystemShutdown
+ RegCloseKey RegConnectRegistry RegCreateKey
+ RegCreateKeyEx RegDeleteKey RegDeleteValue
+ RegEnumKey RegEnumKeyEx RegEnumValue
+ RegFlushKey RegGetKeySecurity RegLoadKey
+ RegNotifyChangeKeyValue RegOpenKey RegOpenKeyEx
+ RegQueryInfoKey RegQueryMultipleValues RegQueryValue
+ RegQueryValueEx RegReplaceKey RegRestoreKey
+ RegSaveKey RegSetKeySecurity RegSetValue
+ RegSetValueEx RegUnLoadKey )],
+ FuncA => [qw(
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA )],
+ FuncW => [qw(
+ AbortSystemShutdownW InitiateSystemShutdownW
+ RegConnectRegistryW RegCreateKeyW RegCreateKeyExW
+ RegDeleteKeyW RegDeleteValueW RegEnumKeyW
+ RegEnumKeyExW RegEnumValueW RegLoadKeyW
+ RegOpenKeyW RegOpenKeyExW RegQueryInfoKeyW
+ RegQueryMultipleValuesW RegQueryValueW RegQueryValueExW
+ RegReplaceKeyW RegRestoreKeyW RegSaveKeyW
+ RegSetValueW RegSetValueExW RegUnLoadKeyW )],
+ HKEY_ => [qw(
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS )],
+ KEY_ => [qw(
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS),
+ 'KEY_DELETE', # DELETE (0x00010000L)
+ 'KEY_READ_CONTROL', # READ_CONTROL (0x00020000L)
+ 'KEY_WRITE_DAC', # WRITE_DAC (0x00040000L)
+ 'KEY_WRITE_OWNER', # WRITE_OWNER (0x00080000L)
+ 'KEY_SYNCHRONIZE', # SYNCHRONIZE (0x00100000L) (not used)
+ ],
+ REG_ => [qw(
+ REG_OPTION_RESERVED REG_OPTION_NON_VOLATILE REG_OPTION_VOLATILE
+ REG_OPTION_CREATE_LINK REG_OPTION_BACKUP_RESTORE
+ REG_OPTION_OPEN_LINK REG_LEGAL_OPTION REG_CREATED_NEW_KEY
+ REG_OPENED_EXISTING_KEY REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_CHANGE_FILTER
+ REG_NONE REG_SZ REG_EXPAND_SZ
+ REG_BINARY REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK REG_MULTI_SZ
+ REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR
+ REG_RESOURCE_REQUIREMENTS_LIST )],
+ SE_ => [qw(
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME )],
+);
+@EXPORT_OK= ();
+{ my $ref;
+ foreach $ref ( values(%EXPORT_TAGS) ) {
+ push( @EXPORT_OK, @$ref ) unless $ref->[0] =~ /^SE_/;
+ }
+}
+$EXPORT_TAGS{ALL}= [ @EXPORT_OK ]; # \@EXPORT_OK once SE_* settles down.
+# push( @EXPORT_OK, "JHEREG_TACOSALAD" ); # Used to test Mkconst2perl
+push( @EXPORT_OK, @{$EXPORT_TAGS{SE_}} );
+
+bootstrap Win32API::Registry $VERSION;
+
+# Preloaded methods go here.
+
+# To convert C constants to Perl code in cRegistry.pc
+# [instead of C or C++ code in cRegistry.h]:
+# * Modify F<Makefile.PL> to add WriteMakeFile() =>
+# CONST2PERL/postamble => [[ "Win32API::Registry" => ]] WRITE_PERL => 1.
+# * Either comment out C<#include "cRegistry.h"> from F<Registry.xs>
+# or make F<cRegistry.h> an empty file.
+# * Make sure the following C<if> block is not commented out.
+# * "nmake clean", "perl Makefile.PL", "nmake"
+
+if( ! defined &REG_NONE ) {
+ require "Win32API/Registry/cRegistry.pc";
+}
+
+# This would be convenient but inconsistant and hard to explain:
+#push( @{$EXPORT_TAGS{ALL}}, @{$EXPORT_TAGS{SE_}} )
+# if defined &SE_TCB_NAME;
+
+sub regConstant
+{
+ my( $name )= @_;
+ if( 1 != @_ || ! $name || $name =~ /\W/ ) {
+ require Carp;
+ Carp::croak( 'Usage: ',__PACKAGE__,'::regConstant("CONST_NAME")' );
+ }
+ my $proto= prototype $name;
+ if( defined \&$name
+ && defined $proto
+ && "" eq $proto ) {
+ no strict 'refs';
+ return &$name;
+ }
+ return undef;
+}
+
+# We provide this for backwards compatibility:
+sub constant
+{
+ my( $name )= @_;
+ my $value= regConstant( $name );
+ if( defined $value ) {
+ $!= 0;
+ return $value;
+ }
+ $!= 11; # EINVAL
+ return 0;
+}
+
+BEGIN {
+ my $code= 'return _regLastError(@_)';
+ local( $!, $^E )= ( 1, 1 );
+ if( $! ne $^E ) {
+ $code= '
+ local( $^E )= _regLastError(@_);
+ my $ret= $^E;
+ return $ret;
+ ';
+ }
+ eval "sub regLastError { $code }";
+ die "$@" if $@;
+}
+
+# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we
+# need this next chunk to prevent Win32API::Registry->nonesuch() from
+# looking for "nonesuch.al" and producing confusing error messages:
+use vars qw($AUTOLOAD);
+sub AUTOLOAD {
+ require Carp;
+ Carp::croak(
+ "Can't locate method $AUTOLOAD via package Win32API::Registry" );
+}
+
+# Replace "&rout;" with "goto &rout;" when that is supported on Win32.
+
+# Let user omit all buffer sizes:
+sub RegEnumKeyExA {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExA;
+}
+sub RegEnumKeyExW {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExW;
+}
+sub RegEnumValueA {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueA;
+}
+sub RegEnumValueW {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueW;
+}
+sub RegQueryInfoKeyA {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyA;
+}
+sub RegQueryInfoKeyW {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyW;
+}
+
+sub RegEnumKeyA {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyA;
+}
+sub RegEnumKeyW {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyW;
+}
+sub RegGetKeySecurity {
+ push(@_,[]) if 3 == @_;
+ &_RegGetKeySecurity;
+}
+sub RegQueryMultipleValuesA {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesA;
+}
+sub RegQueryMultipleValuesW {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesW;
+}
+sub RegQueryValueA {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueA;
+}
+sub RegQueryValueW {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueW;
+}
+sub RegQueryValueExA {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExA;
+}
+sub RegQueryValueExW {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExW;
+}
+sub RegSetValueA {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueA;
+}
+sub RegSetValueW {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueW;
+}
+sub RegSetValueExA {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExA;
+}
+sub RegSetValueExW {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExW;
+}
+
+# Aliases for non-Unicode functions:
+sub AbortSystemShutdown { &AbortSystemShutdownA; }
+sub InitiateSystemShutdown { &InitiateSystemShutdownA; }
+sub RegConnectRegistry { &RegConnectRegistryA; }
+sub RegCreateKey { &RegCreateKeyA; }
+sub RegCreateKeyEx { &RegCreateKeyExA; }
+sub RegDeleteKey { &RegDeleteKeyA; }
+sub RegDeleteValue { &RegDeleteValueA; }
+sub RegEnumKey { &RegEnumKeyA; }
+sub RegEnumKeyEx { &RegEnumKeyExA; }
+sub RegEnumValue { &RegEnumValueA; }
+sub RegLoadKey { &RegLoadKeyA; }
+sub RegOpenKey { &RegOpenKeyA; }
+sub RegOpenKeyEx { &RegOpenKeyExA; }
+sub RegQueryInfoKey { &RegQueryInfoKeyA; }
+sub RegQueryMultipleValues { &RegQueryMultipleValuesA; }
+sub RegQueryValue { &RegQueryValueA; }
+sub RegQueryValueEx { &RegQueryValueExA; }
+sub RegReplaceKey { &RegReplaceKeyA; }
+sub RegRestoreKey { &RegRestoreKeyA; }
+sub RegSaveKey { &RegSaveKeyA; }
+sub RegSetValue { &RegSetValueA; }
+sub RegSetValueEx { &RegSetValueExA; }
+sub RegUnLoadKey { &RegUnLoadKeyA; }
+
+1;
+__END__
+
+=head1 NAME
+
+Win32API::Registry - Low-level access to Win32 system API calls from WINREG.H
+
+=head1 SYNOPSIS
+
+ use Win32API::Registry 0.21 qw( :ALL );
+
+ RegOpenKeyEx( HKEY_LOCAL_MACHINE, "SYSTEM\\Disk", 0, KEY_READ, $key );
+ or die "Can't open HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+ RegQueryValueEx( $key, "Information", [], $type, $data, [] );
+ or die "Can't read HKEY_L*MACHINE\\SYSTEM\\Disk\\Information: ",
+ regLastError(),"\n";
+ [...]
+ RegCloseKey( $key )
+ or die "Can't close HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+
+=head1 DESCRIPTION
+
+This provides fairly low-level access to the Win32 System API
+calls dealing with the Registry [mostly from WINREG.H]. This
+is mostly intended to be used by other modules such as
+C<Win32::TieRegistry> [which provides an extremely Perl-friendly
+method for using the Registry].
+
+For a description of the logical structure of the Registry, see
+the documentation for the C<Win32::TieRegistry> module.
+
+To pass in C<NULL> as the pointer to an optional buffer, pass in
+an empty list reference, C<[]>.
+
+Beyond raw access to the API calls and related constants, this module
+handles smart buffer allocation and translation of return codes.
+
+All calls return a true value for success and a false value for
+failure. After any failure, C<$^E> should automatically be set
+to indicate the reason. However, current versions of Perl often
+overwrite C<$^E> too quickly, so you can use C<regLastError()>
+instead, which is only set by Win32API::Registry routines.
+C<regLastError()> is also good if you have a really old version
+of Perl that does not connect C<$^E> to C<GetLastError()> on
+Win32.
+
+Note that C<$!> is not set by these routines except by
+C<Win32API::Registry::constant()> when a constant is not defined.
+
+=head2 Exports
+
+Nothing is exported by default. The following tags can be used to
+have sets of symbols exported.
+
+[Note that much of the following documentation refers to the
+behavior of the underlying API calls which may vary in current
+and future versions of the Win32 API without any changes to this
+module. Therefore you should check the Win32 API documentation
+directly when needed.]
+
+=over
+
+=item :Func
+
+The basic function names:
+
+=over
+
+=item AllowPriv
+
+=item C<AllowPriv( $sPrivName, $bEnable )>
+
+Not a Win32 API call. Enables or disables a specific privilege for
+the current process. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure. This routine
+does not provide a way to tell if a privilege is currently enabled.
+
+C<$sPrivname> is a Win32 privilege name [see L</:SE_>]. For example,
+C<"SeBackupPrivilege"> [a.k.a. C<SE_BACKUP_NAME>] controls whether
+you can use C<RegSaveKey()> and C<"SeRestorePrivilege"> [a.k.a.
+C<SE_RESTORE_NAME>] controls whether you can use C<RegLoadKey()>.
+
+If C<$bEnable> is true, then C<AllowPriv()> tries to enable the
+privilege. Otherwise it tries to disable the privilege.
+
+=item AbortSystemShutdown
+
+=item C<AbortSystemShutdown( $sComputerName )>
+
+Tries to abort a remote shutdown request previously made via
+C<InitiateSystemShutdown()>. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+=item InitiateSystemShutdown
+
+=item C<InitiateSystemShutdown( $sComputer, $sMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+Requests that a [remote] computer be shutdown or rebooted.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of the computer to be
+shutdown or rebooted. You can use C<[]> [for C<NULL>] or C<"">
+to indicate the local computer.
+
+C<$sMessage> is the message to be displayed in a pop-up window
+on the desktop of the computer to be shutdown or rebooted until
+the timeout expires or the shutdown is aborted via
+C<AbortSystemShutdown()>. With C<$iTimeoutSecs == 0>, the
+message will never be visible.
+
+C<$iTimeoutSecs> is the number of seconds to wait before starting
+the shutdown.
+
+If C<$bForce> is false, then any applications running on the remote
+computer get a chance to prompt the remote user whether they want
+to save changes. Also, for any applications that do not exit quickly
+enough, the operating system will prompt the user whether they wish
+to wait longer for the application to exit or force it to exit now.
+At any of these prompts the user can press B<CANCEL> to abort the
+shutdown but if no applications have unsaved data, they will likely
+all exit quickly and the shutdown will progress with the remote user
+having no option to cancel the shutdown.
+
+If C<$bForce> is true, all applications are told to exit immediately
+and so will not prompt the user even if there is unsaved data. Any
+applications that take too long to exit will be forcibly killed after
+a short time. The only way to abort the shutdown is to call
+C<AbortSystemShutdown()> before the timeout expires and there is no
+way to abort the shutdown once it has begun.
+
+If C<$bReboot> is true, the computer will automatically reboot once
+the shutdown is complete. If C<$bReboot> is false, then when the
+shutdown is complete the computer will halt at a screen indicating
+that the shutdown is complete and offering a way for the user to
+start to boot the computer.
+
+You must have the C<"SeRemoteShutdownPrivilege"> privilege
+on the remote computer for this call to succeed. If shutting
+down the local computer, then the calling process must have
+the C<"SeShutdownPrivilege"> privilege and have it enabled.
+
+=item RegCloseKey
+
+=item C<RegCloseKey( $hKey )>
+
+Closes the handle to a Registry key returned by C<RegOpenKeyEx()>,
+C<RegConnectRegistry()>, C<RegCreateKeyEx()>, or a few other
+routines. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+=item RegConnectRegistry
+
+=item C<RegConnectRegistry( $sComputer, $hRootKey, $ohKey )>
+
+Connects to one of the root Registry keys of a remote computer.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of a remote computer
+whose Registry you wish to access.
+
+C<$hKey> must be either C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS>
+and specifies which root Registry key on the remote computer
+you wish to have access to.
+
+C<$phKey> will be set to the handle to be used to access the
+remote Registry key if the call succeeds.
+
+=item regConstant
+
+=item C<$value= regConstant( $sConstantName )>
+
+Fetch the value of a constant. Returns C<undef> if C<$sConstantName>
+is not the name of a constant supported by this module. Never sets
+C<$!> nor C<$^E>.
+
+This function is rarely used since you will usually get the value of a
+constant by having that constant imported into your package by listing
+the constant name in the C<use Win32API::Registry> statement and then
+simply using the constant name in your code [perhaps followed by
+C<()>]. This function is useful for verifying constant names not in
+Perl code, for example, after prompting a user to type in a constant
+name.
+
+=item RegCreateKey
+
+=item C<RegCreateKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegCreateKeyEx()> instead.
+
+=item RegCreateKeyEx
+
+=item C<RegCreateKeyEx( $hKey, $sSubKey, $uZero, $sClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+Creates a new Registry subkey. Returns a true value if successful and
+a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the new subkey to be created.
+
+C<$iZero> is reserved for future use and should always be specified
+as C<0>.
+
+C<$sClass> is a string to be used as the class for the new
+subkey. We are not aware of any current use for Registry key
+class information so the empty string, C<"">, should usually
+be used here.
+
+C<$iOpts> is a numeric value containing bits that control options
+used while creating the new subkey. C<REG_OPTION_NON_VOLATILE>
+is the default. C<REG_OPTION_VOLATILE> [which is ignored on
+Windows 95] means the data stored under this key is not kept
+in a file and will not be preserved when the system reboots.
+C<REG_OPTION_BACKUP_RESTORE> [also ignored on Windows 95] means
+ignore the C<$iAccess> parameter and try to open the new key with
+the access required to backup or restore the key.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. See C<RegOpenKeyEx()>.
+
+C<$pSecAttr> is a C<SECURITY_ATTRIBUTES> structure packed into
+a Perl string which controls whether the returned handle can be
+inherited by child processes. Normally you would pass C<[]> for
+this parameter to have C<NULL> passed to the underlying API
+indicating that the handle cannot be inherited. If not under
+Windows95, then C<$pSecAttr> also allows you to specify
+C<SECURITY_DESCRIPTOR> that controls which users will have
+what type of access to the new key -- otherwise the new key
+inherits its security from its parent key.
+
+C<$phKey> will be set to the handle to be used to access the new
+subkey if the call succeeds.
+
+C<$piDisp> will be set to either C<REG_CREATED_NEW_KEY> or
+C<REG_OPENED_EXISTING_KEY> to indicate for which reason the
+call succeeded. Can be specified as C<[]> if you don't care.
+
+If C<$phKey> and C<$piDisp> start out as integers, then they will
+probably remain unchanged if the call fails.
+
+=item RegDeleteKey
+
+=item C<RegDeleteKey( $hKey, $sSubKey )>
+
+Deletes a subkey of an open Registry key provided that the subkey
+contains no subkeys of its own [but the subkey may contain values].
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the subkey to be deleted.
+
+=item RegDeleteValue
+
+=item C<RegDeleteValue( $hKey, $sValueName )>
+
+Deletes a value from an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueKey> is the name of the value to be deleted.
+
+=item RegEnumKey
+
+=item C<RegEnumKey( $hKey, $uIndex, $osName, $ilNameSize )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegEnumKeyEx()> instead.
+
+=item RegEnumKeyEx
+
+=item C<RegEnumKeyEx( $hKey, $uIndex, $osName, $iolName, $pNull, $osClass, $iolClass, $opftLastWrite )>
+
+Lets you enumerate the names of all of the subkeys directly under
+an open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the immediate subkey that
+you want information on. Start with this value as C<0> then
+repeat the call incrementing this value each time until the
+call fails with C<$^E>/C<regLastError()> numerically equal to
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sName> will be set to the name of the subkey. Can be C<[]> if
+you don't care about the name.
+
+C<$plName> initially specifies the [minimum] buffer size to be
+allocated for C<$sName>. Will be set to the length of the subkey
+name if the requested subkey exists even if C<$sName> isn't
+successfully set to the subkey name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$sClass> will be set to the class name for the subkey. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+subkey class name if the requested subkey exists. See L<Buffer
+sizes> for more information.
+
+C<$pftLastWrite> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when the subkey was last changed.
+Can be C<[]>.
+
+You may omit both C<$plName> and C<$plClass> to get the same effect
+as passing in C<[]> for each of them.
+
+=item RegEnumValue
+
+=item C<RegEnumValue( $hKey, $uIndex, $osValName, $iolValName, $pNull, $ouType, $opValData, $iolValData )>
+
+Lets you enumerate the names of all of the values contained in an
+open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the value that you want
+information on. Start with this value as C<0> then repeat the
+call incrementing this value each time until the call fails with
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sValName> will be set to the name of the value. Can be C<[]>
+if you don't care about the name.
+
+C<$plValName> initially specifies the [minimum] buffer size to be
+allocated for C<$sValName>. Will be set to the length of the value
+name if the requested value exists even if C<$sValName> isn't
+successfully set to the value name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$piType> will be set to the type of data stored in the value data.
+If the call succeeds, it will be set to a C<REG_*> value unless
+passed in as C<[]>.
+
+C<$pValData> will be set to the data [packed into a Perl string]
+that is stored in the requested value. Can be C<[]> if you don't
+care about the value data.
+
+C<$plValData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValData> and will be set to the length of the
+value data if the requested value exists. See L<Buffer sizes> for
+more information.
+
+You may omit both C<$plValName> and C<$plValData> to get the same
+effect as passing in C<[]> for each of them.
+
+=item RegFlushKey
+
+=item C<RegFlushKey( $hKey )>
+
+Forces the data stored under an open Registry key to be flushed
+to the disk file where the data is preserved between reboots.
+Forced flushing is not guaranteed to be efficient so this routine
+should almost never be called. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+=item RegGetKeySecurity
+
+=item C<RegGetKeySecurity( $hKey, $uSecInfo, $opSecDesc, $iolSecDesc )>
+
+Retrieves one of the C<SECURITY_DESCRIPTOR> structures describing
+part of the security for an open Registry key. Returns a true value
+if successful and a false value [and sets C<$^E>/C<regLastError()>]
+on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which parts of the C<SECURITY_DESCRIPTOR> structure
+to retrieve. Should be C<OWNER_SECURITY_INFORMATION>,
+C<GROUP_SECURITY_INFORMATION>, C<DACL_SECURITY_INFORMATION>, or
+or C<SACL_SECURITY_INFORMATION> or two or more of these bits
+combined using C<|>.
+
+C<$pSecDesc> will be set to the requested C<SECURITY_DESCRIPTOR>
+structure [packed into a Perl string].
+
+C<$plSecDesc> initially specifies the [minimum] buffer size to be
+allocated for C<$sSecDesc> and will be set to the length of the
+security descriptor. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+=item regLastError
+
+=item C<$svError= regLastError();>
+
+=item C<regLastError( $uError );>
+
+Returns the last error encountered by a routine from this module.
+It is just like C<$^E> except it isn't changed by anything except
+routines from this module. Ideally you could just use C<$^E>, but
+current versions of Perl often overwrite C<$^E> before you get a
+chance to check it and really old versions of Perl don't really
+support C<$^E> under Win32.
+
+Just like C<$^E>, in a numeric context C<regLastError()> returns
+the numeric error value while in a string context it returns a
+text description of the error [actually it returns a Perl scalar
+that contains both values so C<$x= regLastError()> causes C<$x>
+to give different values in string vs. numeric contexts]. On old
+versions of Perl where C<$^E> isn't tied to C<GetLastError()>,
+C<regLastError> simply returns the number of the error and you'll
+need to use <Win32::FormatMessage> to get the error string.
+
+The last form sets the error returned by future calls to
+C<regLastError()> and should not be used often. C<$uError> must
+be a numeric error code. Also returns the dual-valued version
+of C<$uError>.
+
+=item RegLoadKey
+
+=item C<RegLoadKey( $hKey, $sSubKey, $sFileName )>
+
+Loads a hive file. That is, it creates a new subkey in the
+Registry and associates that subkey with a disk file that contains
+a Registry hive so that the new subkey can be used to access the
+keys and values stored in that hive. Hives are usually created
+via C<RegSaveKey()>. Returns a true value if successful and a
+false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that can have hives
+loaded to it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the new subkey to created and associated
+with the hive file.
+
+C<$sFileName> is the name of the hive file to be loaded. This
+file name is interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file
+system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+WARNING: Loading of hive files via a network share may silently
+corrupt the hive and so should not be attempted [this is a problem
+in at least some versions of the underlying API which this module
+does not try to fix or avoid]. To access a hive file located on a
+remote computer, connect to the remote computer's Registry and load
+the hive via that.
+
+=item RegNotifyChangeKeyValue
+
+=item C<RegNotifyChangeKeyValue( $hKey, $bWatchSubtree, $uNotifyFilter, $hEvent, $bAsync )>
+
+Arranges for your process to be notified when part of the Registry
+is changed. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call] for which you wish to be notified when any changes
+are made to it.
+
+If C<$bWatchSubtree> is true, then changes to any subkey or
+descendant of C<$hKey> are also reported.
+
+C<$iNotifyFilter> controllers what types of changes are reported. It
+is a numeric value containing one or more of the following bit masks:
+
+=over
+
+=item C<REG_NOTIFY_CHANGE_NAME>
+
+Notify if a subkey is added or deleted to a monitored key.
+
+=item C<REG_NOTIFY_CHANGE_LAST_SET>
+
+Notify if a value in a monitored key is added, deleted, or modified.
+
+=item C<REG_NOTIFY_CHANGE_SECURITY>
+
+Notify if a security descriptor of a monitored key is changed.
+
+=item C<REG_NOTIFY_CHANGE_ATTRIBUTES>
+
+Notify if any attributes of a monitored key are changed [class
+name or security descriptors].
+
+=back
+
+C<$hEvent> is ignored unless C<$bAsync> is true. Otherwise, C<$hEvent>
+is a handle to a Win32 I<event> that will be signaled when changes are
+to be reported.
+
+If C<$bAsync> is true, then C<RegNotifyChangeKeyValue()> returns
+immediately and uses C<$hEvent> to notify your process of changes.
+If C<$bAsync> is false, then C<RegNotifyChangeKeyValue()> does
+not return until there is a change to be notified of.
+
+This routine does not work with Registry keys on remote computers.
+
+=item RegOpenKey
+
+=item C<RegOpenKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegOpenKeyEx()> instead.
+
+=item RegOpenKeyEx
+
+=item C<RegOpenKeyEx( $hKey, $sSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+Opens an existing Registry key. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of an existing subkey to be opened.
+Can be C<""> or C<[]> to open an additional handle to the
+key specified by C<$hKey>.
+
+C<$iOptions> is a numeric value containing bits that control options
+used while opening the subkey. There are currently no supported
+options so this parameter should be specified as C<0>.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. Should be a
+combination of one or more of the following bit masks:
+
+=over
+
+=item C<KEY_ALL_ACCESS>
+
+ KEY_READ | KEY_WRITE | KEY_CREATE_LINK
+
+=item C<KEY_READ>
+
+ KEY_QUERY_VALUE | KEY_ENUMERATE_SUBKEYS | KEY_NOTIFY | STANDARD_RIGHTS_READ
+
+=item C<KEY_WRITE>
+
+ KEY_SET_VALUE | KEY_CREATE_SUB_KEY | STANDARD_RIGHTS_WRITE
+
+=item C<KEY_QUERY_VALUE>
+
+=item C<KEY_SET_VALUE>
+
+=item C<KEY_ENUMERATE_SUB_KEYS>
+
+=item C<KEY_CREATE_SUB_KEY>
+
+=item C<KEY_NOTIFY>
+
+Allows you to use C<RegNotifyChangeKeyValue()> on the opened key.
+
+=item C<KEY_EXECUTE>
+
+Same as C<KEY_READ>.
+
+=item C<KEY_CREATE_LINK>
+
+Gives you permission to create a symbolic link like
+C<HKEY_CLASSES_ROOT> and C<HKEY_CURRENT_USER>, though the method for
+doing so is not documented [and probably requires use of the mostly
+undocumented "native" routines, C<Nt*()> a.k.a. C<Zw*()>].
+
+=back
+
+C<$phKey> will be set to the handle to be used to access the new subkey
+if the call succeeds.
+
+=item RegQueryInfoKey
+
+=item C<RegQueryInfoKey( $hKey, $osClass, $iolClass, $pNull, $ocSubKeys, $olSubKey, $olSubClass, $ocValues, $olValName, $olValData, $olSecDesc, $opftTime )>
+
+Gets miscellaneous information about an open Registry key.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sClass> will be set to the class name for the key. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+key's class name. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+C<$pNull> is reserved for future use and should be passed as C<[]>.
+
+C<$pcSubKeys> will be set to the count of the number of subkeys
+directly under this key. Can be C<[]>.
+
+C<$plSubKey> will be set to the length of the longest subkey name.
+Can be C<[]>.
+
+C<$plSubClass> will be set to the length of the longest class name
+used with an immediate subkey of this key. Can be C<[]>.
+
+C<$pcValues> will be set to the count of the number of values in
+this key. Can be C<[]>.
+
+C<$plValName> will be set to the length of the longest value name
+in this key. Can be C<[]>.
+
+C<$plValData> will be set to the length of the longest value data
+in this key. Can be C<[]>.
+
+C<$plSecDesc> will be set to the length of this key's full security
+descriptor.
+
+C<$pftTime> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when this key was last changed.
+Can be C<[]>.
+
+=item RegQueryMultipleValues
+
+=item C<RegQueryMultipleValues( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+Allows you to use a single call to query several values from a single
+open Registry key to maximize efficiency. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$pValueEnts> should contain a list of C<VALENT> structures packed
+into a single Perl string. Each C<VALENT> structure should have
+the C<ve_valuename> entry [the first 4 bytes] pointing to a string
+containing the name of a value stored in this key. The remaining
+fields are set if the function succeeds.
+
+C<$cValueEnts> should contain the count of the number of C<VALENT>
+structures contained in C<$pValueEnts>.
+
+C<$pBuffer> will be set to the data from all of the requested values
+concatenated into a single Perl string.
+
+C<$plBuffer> initially specifies the [minimum] buffer size to be
+allocated for C<$sBuffer> and will be set to the total length of
+the data to be written to C<$sBuffer>. See L<Buffer sizes> for
+more information. You may omit this parameter to get the same
+effect as passing in C<[]> for it.
+
+Here is sample code to populate C<$pValueEnts>:
+
+ # @ValueNames= ...list of value name strings...;
+ $cValueEnts= @ValueNames;
+ $pValueEnts= pack( " p x4 x4 x4 " x $cValueEnts, @ValueNames );
+
+Here is sample code to retrieve the data type and data length
+returned in C<$pValueEnts>:
+
+ @Lengths= unpack( " x4 L x4 x4 " x $cValueEnts, $pValueEnts );
+ @Types= unpack( " x4 x4 x4 L " x $cValueEnts, $pValueEnts );
+
+Given the above, and assuming you haven't modified C<$sBuffer> since
+the call, you can also extract the value data strings from C<$sBuffer>
+by using the pointers returned in C<$pValueEnts>:
+
+ @Data= unpack( join( "", map {" x4 x4 P$_ x4 "} @Lengths ),
+ $pValueEnts );
+
+Much better is to use the lengths and extract directly from
+C<$sBuffer> using C<unpack()> [or C<substr()>]:
+
+ @Data= unpack( join("",map("P$_",@Lengths)), $sBuffer );
+
+=item RegQueryValue
+
+=item C<RegQueryValue( $hKey, $sSubKey, $osValueData, $iolValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegQueryValueEx()> instead. This routine can only
+query unamed values [a.k.a. "default values"], that is, values with
+a name of C<"">.
+
+=item RegQueryValueEx
+
+=item C<RegQueryValueEx( $hKey, $sValueName, $pNull, $ouType, $opValueData, $iolValueData )>
+
+Lets you look up value data stored in an open Registry key by
+specifying the value name. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueName> is the name of the value whose data you wish to
+retrieve.
+
+C<$pNull> this parameter is reserved for future use and should be
+specified as C<[]>.
+
+C<$piType> will be set to indicate what type of data is stored in
+the named value. Will be set to a C<REG_*> value if the function
+succeeds.
+
+C<$pValueData> will be set to the value data [packed into a Perl
+string] that is stored in the named value. Can be C<[]> if you
+don't care about the value data.
+
+C<$plValueData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValueData> and will be set to the size [always
+in bytes] of the data to be written to C<$sValueData>, even if
+C<$sValueData> is not successfully written to. See L<Buffer sizes>
+for more information.
+
+=item RegReplaceKey
+
+=item C<RegReplaceKey( $hKey, $sSubKey, $sNewFile, $sOldFile )>
+
+Lets you replace an entire hive when the system is next booted.
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hive(s)
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>,
+C<HKEY_USERS>, or a remote version of one of these from
+a call to C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey of C<$hKey> whose hive
+you wish to have replaced on the next reboot.
+
+C<$sNewFile> is the name of a file that will replace the existing
+hive file when the system reboots.
+
+C<$sOldFile> is the file name to save the current hive file to
+when the system reboots.
+
+C<$sNewFile> and C<$sOldFile> are interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides [I think]. If either file is [would be]
+on a FAT file system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegRestoreKey
+
+=item C<RegRestoreKey( $hKey, $sFileName, $uFlags )>
+
+Reads in a hive file and copies its contents over an existing
+Registry tree. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the hive file to be read. For each
+value and subkey in this file, a value or subkey will be added
+or replaced in C<$hKey>.
+
+C<$uFlags> is usally C<0>. It can also be C<REG_WHOLE_HIVE_VOLATILE>
+which, rather than copying the hive over the existing key,
+replaces the existing key with a temporary, memory-only Registry
+key and then copies the hive contents into it. This option only
+works if C<$hKey> is C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, or a
+remote version of one of these from a call to C<RegConnectRegistry()>.
+
+C<RegRestoreKey> does I<not> delete values nor keys from the
+existing Registry tree when there is no corresponding value/key
+in the hive file.
+
+=item RegSaveKey
+
+=item C<RegSaveKey( $hKey, $sFileName, $pSecAttr )>
+
+Dumps any open Registry key and all of its subkeys and values into
+a new hive file. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the file that the Registry tree
+should be saved to. It is interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file system,
+then it must not have an extension.
+
+C<$pSecAttr> contains a C<SECURITY_ATTRIBUTES> structure that specifies
+the permissions to be set on the new file that is created. This can
+be C<[]>.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegSetKeySecurity
+
+=item C<RegSetKeySecurity( $hKey, $uSecInfo, $pSecDesc )>
+
+Sets [part of] the C<SECURITY_DESCRIPTOR> structure describing part
+of the security for an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$uSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which C<SECURITY_DESCRIPTOR> structure to set. Should
+be C<OWNER_SECURITY_INFORMATION>, C<GROUP_SECURITY_INFORMATION>,
+C<DACL_SECURITY_INFORMATION>, or C<SACL_SECURITY_INFORMATION>
+or two or more of these bits combined using C<|>.
+
+C<$pSecDesc> contains the new C<SECURITY_DESCRIPTOR> structure
+packed into a Perl string.
+
+=item RegSetValue
+
+=item C<RegSetValue( $hKey, $sSubKey, $uType, $sValueData, $lValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegSetValueEx()> instead. This routine can only
+set unamed values [a.k.a. "default values"].
+
+=item RegSetValueEx
+
+=item C<RegSetValueEx( $hKey, $sName, $uZero, $uType, $pData, $lData )>
+
+Adds or replaces a value in an open Registry key. Returns
+a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sName> is the name of the value to be set.
+
+C<$uZero> is reserved for future use and should be specified as C<0>.
+
+C<$uType> is the type of data stored in C<$pData>. It should
+be a C<REG_*> value.
+
+C<$pData> is the value data packed into a Perl string.
+
+C<$lData> is the length of the value data that is stored in C<$pData>.
+You will usually omit this parameter or pass in C<0> to have
+C<length($pData)> used. In both of these cases, if C<$iType> is
+C<REG_SZ> or C<REG_EXPAND_SZ>, C<RegSetValueEx()> will append a
+trailing C<'\0'> to the end of C<$pData> [unless there is already
+one].
+
+=item RegUnLoadKey
+
+=item C<RegUnLoadKey( $hKey, $sSubKey )>
+
+Unloads a previously loaded hive file. That is, closes the
+hive file then deletes the subkey that was providing access
+to it. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hives
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey whose hive you wish to
+have unloaded.
+
+=item :FuncA
+
+The ASCII-specific function names.
+
+Each of these is identical to the version listed above without the
+trailing "A":
+
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA
+
+=item :FuncW
+
+The UNICODE-specific function names. These are the same as the
+versions listed above without the trailing "W" except that string
+parameters are UNICODE strings rather than ASCII strings, as
+indicated.
+
+=item AbortSystemShutdownW
+
+=item C<AbortSystemShutdownW( $swComputerName )>
+
+C<$swComputerName> is UNICODE.
+
+=item InitiateSystemShutdownW
+
+=item C<InitiateSystemShutdownW( $swComputer, $swMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+C<$swComputer> and C<$swMessage> are UNICODE.
+
+=item RegConnectRegistryW
+
+=item C<RegConnectRegistryW( $swComputer, $hRootKey, $ohKey )>
+
+C<$swComputer> is UNICODE.
+
+=item RegCreateKeyW
+
+=item C<RegCreateKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegCreateKeyExW
+
+=item C<RegCreateKeyExW( $hKey, $swSubKey, $uZero, $swClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+C<$swSubKey> and C<$swClass> are UNICODE.
+
+=item RegDeleteKeyW
+
+=item C<RegDeleteKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegDeleteValueW
+
+=item C<RegDeleteValueW( $hKey, $swValueName )>
+
+C<$swValueName> is UNICODE.
+
+=item RegEnumKeyW
+
+=item C<RegEnumKeyW( $hKey, $uIndex, $oswName, $ilwNameSize )>
+
+C<$oswName> is UNICODE and C<$ilwNameSize> is measured as number of
+C<WCHAR>s.
+
+=item RegEnumKeyExW
+
+=item C<RegEnumKeyExW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $oswClass, $iolwClass, $opftLastWrite )>
+
+C<$swName> and C<$swClass> are UNICODE and C<$iolwName> and C<$iolwClass>
+are measured as number of C<WCHAR>s.
+
+=item RegEnumValueW
+
+=item C<RegEnumValueW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $ouType, $opData, $iolData )>
+
+C<$oswName> is UNICODE and C<$iolwName> is measured as number
+of C<WCHAR>s.
+
+C<$opData> is UNICODE if C<$piType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number
+of bytes even in these cases.
+
+=item RegLoadKeyW
+
+=item C<RegLoadKeyW( $hKey, $swSubKey, $swFileName )>
+
+C<$swSubKey> and C<$swFileName> are UNICODE.
+
+=item RegOpenKeyW
+
+=item C<RegOpenKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegOpenKeyExW
+
+=item C<RegOpenKeyExW( $hKey, $swSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegQueryInfoKeyW
+
+=item C<RegQueryInfoKeyW( $hKey, $oswClass, $iolwClass, $pNull, $ocSubKeys, $olwSubKey, $olwSubClass, $ocValues, $olwValName, $olValData, $olSecDesc, $opftTime )>
+
+C<$swClass> is UNICODE. C<$iolwClass>, C<$olwSubKey>, C<$olwSubClass>,
+and C<$olwValName> are measured as number of C<WCHAR>s. Note that
+C<$olValData> is measured as number of bytes.
+
+=item RegQueryMultipleValuesW
+
+=item C<RegQueryMultipleValuesW( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+The C<ve_valuename> fields of the C<VALENT> [actually C<VALENTW>]
+structures in C<$ioarValueEnts> are UNICODE. Values of type C<REG_SZ>,
+C<REG_EXPAND_SZ>, and C<REG_MULTI_SZ> are written to C<$opBuffer>
+in UNICODE. Note that C<$iolBuffer> and the C<ve_valuelen> fields
+of the C<VALENT> [C<VALENTW>] structures are measured as number of
+bytes.
+
+=item RegQueryValueW
+
+=item C<RegQueryValueW( $hKey, $swSubKey, $oswValueData, $iolValueData )>
+
+C<$swSubKey> and C<$oswValueData> are UNICODE. Note that
+C<$iolValueData> is measured as number of bytes.
+
+=item RegQueryValueExW
+
+=item C<RegQueryValueExW( $hKey, $swName, $pNull, $ouType, $opData, $iolData )>
+
+C<$swName> is UNICODE.
+
+C<$opData> is UNICODE if C<$ouType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number of
+bytes even in these cases.
+
+=item RegReplaceKeyW
+
+=item C<RegReplaceKeyW( $hKey, $swSubKey, $swNewFile, $swOldFile )>
+
+C<$swSubKey>, C<$swNewFile>, and C<$swOldFile> are UNICODE.
+
+=item RegRestoreKeyW
+
+=item C<RegRestoreKeyW( $hKey, $swFileName, $uFlags )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSaveKeyW
+
+=item C<RegSaveKeyW( $hKey, $swFileName, $pSecAttr )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSetValueW
+
+=item C<RegSetValueW( $hKey, $swSubKey, $uType, $swValueData, $lValueData )>
+
+C<$swSubKey> and C<$swValueData> are UNICODE. Note that
+C<$lValueData> is measured as number of bytes even though
+C<$swValueData> is always UNICODE.
+
+=item RegSetValueExW
+
+=item C<RegSetValueExW( $hKey, $swName, $uZero, $uType, $pData, $lData )>
+
+C<$swName> is UNICODE.
+
+C<$pData> is UNICODE if C<$uType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$lData> is measured as number of
+bytes even in these cases.
+
+=item RegUnLoadKeyW
+
+=item C<RegUnLoadKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item :HKEY_
+
+All C<HKEY_*> constants:
+
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS
+
+=item :KEY_
+
+All C<KEY_*> constants:
+
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS
+
+=item :REG_
+
+All C<REG_*> constants:
+
+ REG_CREATED_NEW_KEY REG_OPENED_EXISTING_KEY
+
+ REG_LEGAL_CHANGE_FILTER REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_OPTION
+
+ REG_OPTION_BACKUP_RESTORE REG_OPTION_CREATE_LINK
+ REG_OPTION_NON_VOLATILE REG_OPTION_OPEN_LINK
+ REG_OPTION_RESERVED REG_OPTION_VOLATILE
+
+ REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH
+
+ REG_NONE REG_SZ
+ REG_EXPAND_SZ REG_BINARY
+ REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK
+ REG_MULTI_SZ REG_RESOURCE_LIST
+ REG_FULL_RESOURCE_DESCRIPTOR REG_RESOURCE_REQUIREMENTS_LIST
+
+=item :ALL
+
+All of the above.
+
+=item :SE_
+
+The strings for the following privilege names:
+
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME
+
+It can be difficult to successfully build this module in a way
+that makes these constants available. So some builds of this
+module may not make them available. For such builds, trying
+to export any of these constants will cause a fatal error.
+For this reason, none of these symbols are currently included
+in the C<":ALL"> grouping.
+
+=back
+
+=head2 The Win32API:: heirarchy
+
+This and the other Win32API:: modules are meant to expose the
+nearly raw API calls so they can be used from Perl code in any
+way they might be used from C code. This provides the following
+advantages:
+
+=over
+
+=item Many modules can be written by people that don't have a C compiler.
+
+=item Encourages more module code to be written in Perl [not C].
+
+Perl code is often much easier to inspect, debug, customize, and
+enhance than XS code.
+
+=item Allows those already familiar with the Win32 API to get
+off to a quick start.
+
+=item Provides an interactive tool for exploring even obscure
+details of the Win32 API.
+
+It can be very useful to interactively explore ad-hoc calls into
+parts of the Win32 API using:
+
+ perl -de 0
+
+=item Ensures that native Win32 data structures can be used.
+
+This allows maximum efficiency. It also allows data from one
+module [for example, time or security information from the
+C<Win32API::Registry> or C<Win32API::File> modules] to be used
+with other modules [for example, C<Win32API::Time> and
+C<Win32API::SecDesc>].
+
+=item Provides a single version of the XS interface to each API
+call where improvements can be collected.
+
+=back
+
+=head2 Buffer sizes
+
+For each parameter that specifies a buffer size, a value of C<0>
+can be passed. For parameter that are pointers to buffer sizes,
+you can also pass in C<NULL> by specifying an empty list reference,
+C<[]>. Both of these cases will ensure that the variable has
+I<some> buffer space allocated to it and pass in that buffer's
+allocated size. Many of the calls indicate, via C<ERROR_MORE_DATA>,
+that the buffer size was not sufficient and the F<Registry.xs>
+code will automatically enlarge the buffer to the required size
+and repeat the call.
+
+Numeric buffer sizes are used as minimum initial sizes for the
+buffers. The larger of this size and the size of space already
+allocated to the scalar will be passed to the underlying routine.
+If that size was insufficient, and the underlying call provides
+an easy method for determining the needed buffer size, then the
+buffer will be enlarged and the call repeated as above.
+
+The underlying calls define buffer size parameter as unsigned, so
+negative buffer sizes are treated as very large positive buffer
+sizes which usually cause C<malloc()> to fail.
+
+To force the F<Registry.xs> code to pass in a specific value for
+a buffer size, preceed the size with an equals sign via C<"=".>.
+Buffer sizes that are passed in as strings starting with an equals
+sign will have the equal sign stripped and the remainder of the string
+interpretted as a number [via C's C<strtoul()> using only base 10]
+which will be passed to the underlying routine [even if the allocated
+buffer is actually larger]. The F<Registry.xs> code will enlarge the
+buffer to the specified size, if needed, but will not enlarge the
+buffer based on the underlying routine requesting more space.
+
+Some Reg*() calls may not currently set the buffer size when they
+return C<ERROR_MORE_DATA>. But some that are not documented as
+doing so, currently do so anyway. So the code assumes that any
+routine I<might> do this and resizes any buffers and repeats the
+call. We hope that eventually all routines will provide this
+feature.
+
+When you use C<[]> for a buffer size, you can still find the
+length of the data returned by using C<length($buffer)>. Note
+that this length will be in bytes while a few of the buffer
+sizes would have been in units of wide characters.
+
+Note that the RegQueryValueEx*() and RegEnumValue*() calls
+will trim the trailing C<'\0'> [if present] from the returned data
+values of type C<REG_SZ> or C<REG_EXPAND_SZ> but only if the
+value data length parameter is omitted [or specified as C<[]>].
+
+The RegSetValueEx*() calls will add a trailing C<'\0'> [if
+missing] to the supplied data values of type C<REG_SZ> and
+C<REG_EXPAND_SZ> but only if the value data length parameter
+is omitted [or specified as C<0>].
+
+=head2 Hungarian Notation
+
+The following abbreviations are used at the start of each parameter
+name to hint at aspects of how the parameter is used. The prefix
+is always in lower case and followed by a capital letter that starts
+the descriptive part of the parameter name. Several of the following
+abbreviations can be combined into a single prefix.
+
+Probably not all of these prefix notations are used by this module.
+This document section may be included in any C<Win32API> module and
+so covers some notations not used by this specific module.
+
+=over
+
+=item s
+
+A string. In C, a C<'\0'>-terminated C<char *>. In Perl, just a
+string except that it will be truncated at the first C<"\0">, if
+it contains one.
+
+=item sw
+
+A wide [UNICODE] string. In C, a C<L'\0'>-terminated C<WCHAR *>.
+In Perl, a string that contains UNICODE data. You can convert a
+string to UNICODE in Perl via:
+
+ $string= "This is an example string";
+ $unicode= pack( "S*", unpack("C*",$string), 0 );
+
+Note how C<, 0> above causes an explicit C<L'\0'> to be added since
+Perl's implicit C<'\0'> that it puts after each of its strings is not
+wide enough to terminate a UNICODE string. So UNICODE strings are
+different than regular strings in that the Perl version of a regular
+string will not include the trialing C<'\0'> while the Perl version
+of a UNICODE string must include the trailing C<L'\0'>.
+
+If a UNICODE string contains no non-ASCII characters, then you
+can convert it back into a normal string via:
+
+ $string= pack( "C*", unpack("S*",$unicode) );
+ $string =~ s/\0$//;
+
+=item p
+
+A pointer to some buffer [usually containing some C<struct>]. In C,
+a C<void *> or some other pointer type. In Perl, a string that is
+usually manipulated using C<pack> and C<unpack>. The "p" is usually
+followed by more prefix character(s) to indicate what type of data is
+stored in the bufffer.
+
+=item a
+
+A packed array. In C, an array [usually of C<struct>s]. In Perl, a
+string containing the packed data. The "a" is usually followed by
+more prefix character(s) to indicate the data type of the elements.
+
+These packed arrays are also called "vectors" in places to avoid
+confusion with Perl arrays.
+
+=item n
+
+A generic number. In C, any of the integer or floating point data
+types. In Perl, a number; either an integer, unsigned, or double
+[IV, UV, or NV, respectively]. Usually an integer.
+
+=item iv
+
+A signed integral value. In C, any of the signed integer data types.
+In Perl, an integer [IV].
+
+=item u
+
+An unsigned integral value. In C, any of the unsigned integer data
+types. In Perl, an unsigned integer [UV].
+
+=item d
+
+A floating-point number. In C, a C<float> or C<double> or, perhaps,
+a C<long double>. In Perl, a double-precision floating-point number
+[NV].
+
+=item b
+
+A Boolean value. In C, any integer data type, though usually via
+a type alias of C<bool> or C<BOOL>, containing either a 0 [false] or
+non-zero [true] value. In Perl, a scalar containing a Boolean value
+[C<0>, C<"">, or C<undef> for "false" and anything else for "true"].
+
+=item c
+
+A count of items. In C, any integer data type. In Perl, an unsigned
+integer [UV]. Usually used in conjunction with a "vector" parameter
+[see L</a> above] to indicate the number of elements.
+
+=item l
+
+A length [in bytes]. In C, any integer data type. In Perl, an
+unsigned integer [UV]. Usually used in conjunction with a "string"
+or "pointer" parameter [see L</s> and L</p> above] to indicate the
+buffer size or the size of the value stored in the buffer.
+
+For strings, there is no general rule as to whether the trailing
+C<'\0'> is included in such sizes. For this reason, the C<Win32API>
+modules follow the Perl rule of always allocating one extra byte
+and reporting buffer sizes as being one smaller than allocated in
+case the C<'\0'> is not included in the size.
+
+=item lw
+
+A length measured as number of UNICODE characters. In C, a count
+of C<WCHAR>s. In Perl, an unsigned integer [UV] counting "shorts"
+[see "s" and "S" in C<pack> and C<unpack>].
+
+For UNICODE strings, the trailing C<L'\0'> may or may not be
+included in a length so, again, we always allocate extra room
+for one and don't report that extra space.
+
+=item h
+
+A handle. In C, a C<HANDLE> or more-specific handle data type.
+In Perl, an unsigned integer [UV]. In C, these handles are often
+actually some type of pointer, but Perl just treats them as opaque
+numbers, as it should. This prefix is also used for other pointers
+that are treated as integers in Perl code.
+
+=item r
+
+A record. In C, almost always a C<struct> or perhaps C<union>. Note
+that C C<struct>s are rarely passed by value so the "r" is almost
+always preceeded by a "p" or "a" [see L</p> and L</a> above]. For
+the very rare unadorned "r", Perl stores the record in the same way
+as a "pr", that is, in a string. For the very rare case where Perl
+explicitly stores a pointer to the C<struct> rather than storing the
+C<struct> directly in a Perl string, the prefix "pp" or "ppr" or even
+"par" is used.
+
+=item sv
+
+=item rv
+
+=item hv
+
+=item av
+
+=item cv
+
+A Perl data type. Respectively, a scalar value [SV], a reference
+[RV] [usually to a scalar], a hash [HV], a Perl array [AV], or a Perl
+code reference [PVCV]. For the "hv", "av", and "cv" prefixes, a
+leading "rv" is usually assumed. For a parameter to an XS subroutine,
+a prefix of "sv" means the parameter is a scalar and so may be a string
+or a number [or C<undef>] or even both at the same time. So "sv"
+doesn't imply a leading "rv".
+
+=item Input or Output
+
+Whether a parameter is for input data, output data, or both is usually
+not reflected by the data type prefix. In cases where this is not
+obvious nor reflected in the parameter name proper, we may use the
+following in front of the data type prefix.
+
+=over
+
+=item i
+
+An input parameter given to the API [usually omitted].
+
+=item o
+
+An output-only parameter taken from the API. You should not get a
+warning if such a parameter is C<undef> when you pass it into the
+function. You should get an error if such a parameter is read-only.
+You can [usually] pass in C<[]> for such a parameter to have the
+parameter silently ignored.
+
+The output may be written directly into the Perl variable passed
+to the subroutine, the same way the buffer parameter to Perl's
+C<sysread()>. This method is often avoided in Perl because
+the call then lacks any visual cue that some parameters are being
+overwritten. But this method closely matches the C API which is
+what we are trying to do.
+
+=item io
+
+Input given to the API then overwritten with output taken from the
+API. You should get a warning [if B<-w> is in effect] if such a
+parameter is C<undef> when you pass it into the function [unless it
+is a buffer or buffer length parameter]. If the value is read-only,
+then [for most parameters] the output is silently not written. This
+is because it is often convenient to pass in read-only constants for
+many such parameters. You can also usually pass in C<[]> for such
+parameters.
+
+=back
+
+=item pp
+
+=item ppr
+
+=item par
+
+=item pap
+
+These are just unusual combinations of prefix characters described above.
+
+For each, a pointer is stored in a [4-byte] Perl string. You can
+usually use C<unpack "P"> to access the real data from Perl.
+
+For "ppr" [and often for "pp"], the pointer points directly at a
+C C<struct>. For "par", the pointer points to the first element
+of a C [packed] array of C<struct>s. For "pap", the pointer points
+to a C [packed] array of pointers to other things.
+
+=item ap
+
+Here we have a list of pointers packed into a single Perl string.
+
+=back
+
+=head1 BUGS
+
+The old ActiveState ports of Perl for Win32 [but not, ActivePerl, the
+ActiveState distributions of standard Perl 5.004 and beyond] do not support
+the tools for building extensions and so do not support this extension.
+
+No routines are provided for using the data returned in the C<FILETIME>
+buffers. Those are in the C<Win32API::Time> module.
+
+No routines are provided for dealing with UNICODE data effectively.
+See L</:FuncW> above for some simple-minded UNICODE methods.
+
+Parts of the module test will fail if used on a version of Perl
+that does not yet set C<$^E> based on C<GetLastError()>.
+
+On NT 4.0 [at least], the RegEnum*() calls do not set the required
+buffer sizes when returning C<ERROR_MORE_DATA> so this module will
+not grow the buffers in such cases. C<Win32::TieRegistry> overcomes
+this by using values from C<RegQueryInfoKey()> for buffer sizes in
+RegEnum* calls.
+
+On NT 4.0 [at least], C<RegQueryInfoKey()> on C<HKEY_PERFORMANCE_DATA>
+never succeeds. Also, C<RegQueryValueEx()> on C<HKEY_PERFORMANCE_DATA>
+never returns the required buffer size. To access C<HKEY_PERFORMANCE_DATA>
+you will need to keep growing the data buffer until the call succeeds.
+
+Because C<goto &subroutine> seems to be buggy under Win32 Perl,
+it is not used in the stubs in F<Registry.pm>.
+
+=head1 AUTHOR
+
+Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Win32::TieRegistry>
+
+=item L<Win32::Registry>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32API/Registry/cRegistry.pc b/Master/tlpkg/tlperl.straw/lib/Win32API/Registry/cRegistry.pc
new file mode 100755
index 00000000000..9659d0c4361
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32API/Registry/cRegistry.pc
@@ -0,0 +1,87 @@
+# Generated by cRegistry_pc.cxx.
+# Package Win32API::Registry with options:
+# CPLUSPLUS => q[1]
+# IFDEF => q[ /^SE_/ ? '__cplusplus' : /REG_/ ]
+# IMPORT_LIST => [q[/._/], q[!/[a-z]/]]
+# VALUES => { KEY_DELETE=>q[DELETE], KEY_READ_CONTROL=>q[READ_CONTROL], KEY_WRITE_OWNER=>q[WRITE_OWNER], KEY_SYNCHRONIZE=>q[SYNCHRONIZE], KEY_WRITE_DAC=>q[WRITE_DAC] }
+# WRITE_PERL => q[1]
+# Perl files eval'd:
+# Registry.pm => last if /^\s*(bootstrap|XSLoader::load)\b/
+# C files included:
+# Registry.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b#
+sub HKEY_CLASSES_ROOT () { 0x80000000 }
+sub HKEY_CURRENT_CONFIG () { 0x80000005 }
+sub HKEY_CURRENT_USER () { 0x80000001 }
+sub HKEY_DYN_DATA () { 0x80000006 }
+sub HKEY_LOCAL_MACHINE () { 0x80000002 }
+sub HKEY_PERFORMANCE_DATA () { 0x80000004 }
+sub HKEY_USERS () { 0x80000003 }
+sub KEY_ALL_ACCESS () { 983103 }
+sub KEY_CREATE_LINK () { 32 }
+sub KEY_CREATE_SUB_KEY () { 4 }
+sub KEY_DELETE () { 65536 }
+sub KEY_ENUMERATE_SUB_KEYS () { 8 }
+sub KEY_EXECUTE () { 131097 }
+sub KEY_NOTIFY () { 16 }
+sub KEY_QUERY_VALUE () { 1 }
+sub KEY_READ () { 131097 }
+sub KEY_READ_CONTROL () { 131072 }
+sub KEY_SET_VALUE () { 2 }
+sub KEY_SYNCHRONIZE () { 1048576 }
+sub KEY_WRITE () { 131078 }
+sub KEY_WRITE_DAC () { 262144 }
+sub KEY_WRITE_OWNER () { 524288 }
+sub REG_BINARY () { 3 }
+sub REG_CREATED_NEW_KEY () { 1 }
+sub REG_DWORD () { 4 }
+sub REG_DWORD_BIG_ENDIAN () { 5 }
+sub REG_DWORD_LITTLE_ENDIAN () { 4 }
+sub REG_EXPAND_SZ () { 2 }
+sub REG_FULL_RESOURCE_DESCRIPTOR () { 9 }
+sub REG_LEGAL_CHANGE_FILTER () { 15 }
+sub REG_LEGAL_OPTION () { 15 }
+sub REG_LINK () { 6 }
+sub REG_MULTI_SZ () { 7 }
+sub REG_NONE () { 0 }
+sub REG_NOTIFY_CHANGE_ATTRIBUTES () { 2 }
+sub REG_NOTIFY_CHANGE_LAST_SET () { 4 }
+sub REG_NOTIFY_CHANGE_NAME () { 1 }
+sub REG_NOTIFY_CHANGE_SECURITY () { 8 }
+sub REG_NO_LAZY_FLUSH () { 4 }
+sub REG_OPENED_EXISTING_KEY () { 2 }
+sub REG_OPTION_BACKUP_RESTORE () { 4 }
+sub REG_OPTION_CREATE_LINK () { 2 }
+sub REG_OPTION_NON_VOLATILE () { 0 }
+sub REG_OPTION_OPEN_LINK () { 8 }
+sub REG_OPTION_RESERVED () { 0 }
+sub REG_OPTION_VOLATILE () { 1 }
+sub REG_REFRESH_HIVE () { 2 }
+sub REG_RESOURCE_LIST () { 8 }
+sub REG_RESOURCE_REQUIREMENTS_LIST () { 10 }
+sub REG_SZ () { 1 }
+sub REG_WHOLE_HIVE_VOLATILE () { 1 }
+sub SE_ASSIGNPRIMARYTOKEN_NAME () { 'SeAssignPrimaryTokenPrivilege' }
+sub SE_AUDIT_NAME () { 'SeAuditPrivilege' }
+sub SE_BACKUP_NAME () { 'SeBackupPrivilege' }
+sub SE_CHANGE_NOTIFY_NAME () { 'SeChangeNotifyPrivilege' }
+sub SE_CREATE_PAGEFILE_NAME () { 'SeCreatePagefilePrivilege' }
+sub SE_CREATE_PERMANENT_NAME () { 'SeCreatePermanentPrivilege' }
+sub SE_CREATE_TOKEN_NAME () { 'SeCreateTokenPrivilege' }
+sub SE_DEBUG_NAME () { 'SeDebugPrivilege' }
+sub SE_INCREASE_QUOTA_NAME () { 'SeIncreaseQuotaPrivilege' }
+sub SE_INC_BASE_PRIORITY_NAME () { 'SeIncreaseBasePriorityPrivilege' }
+sub SE_LOAD_DRIVER_NAME () { 'SeLoadDriverPrivilege' }
+sub SE_LOCK_MEMORY_NAME () { 'SeLockMemoryPrivilege' }
+sub SE_MACHINE_ACCOUNT_NAME () { 'SeMachineAccountPrivilege' }
+sub SE_PROF_SINGLE_PROCESS_NAME () { 'SeProfileSingleProcessPrivilege' }
+sub SE_REMOTE_SHUTDOWN_NAME () { 'SeRemoteShutdownPrivilege' }
+sub SE_RESTORE_NAME () { 'SeRestorePrivilege' }
+sub SE_SECURITY_NAME () { 'SeSecurityPrivilege' }
+sub SE_SHUTDOWN_NAME () { 'SeShutdownPrivilege' }
+sub SE_SYSTEMTIME_NAME () { 'SeSystemtimePrivilege' }
+sub SE_SYSTEM_ENVIRONMENT_NAME () { 'SeSystemEnvironmentPrivilege' }
+sub SE_SYSTEM_PROFILE_NAME () { 'SeSystemProfilePrivilege' }
+sub SE_TAKE_OWNERSHIP_NAME () { 'SeTakeOwnershipPrivilege' }
+sub SE_TCB_NAME () { 'SeTcbPrivilege' }
+sub SE_UNSOLICITED_INPUT_NAME () { 'SeUnsolicitedInputPrivilege' }
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32CORE.pm b/Master/tlpkg/tlperl.straw/lib/Win32CORE.pm
new file mode 100755
index 00000000000..0e5d20bb908
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/XML/LibXML.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML.pm
new file mode 100755
index 00000000000..37600cdaf93
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML.pm
@@ -0,0 +1,2238 @@
+# $Id: LibXML.pm 809 2009-10-04 21:17:41Z pajas $
+#
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML;
+
+use strict;
+use vars qw($VERSION $ABI_VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
+ $skipDTD $skipXMLDeclaration $setTagCompression
+ $MatchCB $ReadCB $OpenCB $CloseCB %PARSER_FLAGS
+ );
+use Carp;
+
+use constant XML_XMLNS_NS => 'http://www.w3.org/2000/xmlns/';
+use constant XML_XML_NS => 'http://www.w3.org/XML/1998/namespace';
+
+use XML::LibXML::Error;
+use XML::LibXML::NodeList;
+use XML::LibXML::XPathContext;
+use IO::Handle; # for FH reads called as methods
+
+BEGIN {
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+$ABI_VERSION = 2;
+require Exporter;
+require DynaLoader;
+@ISA = qw(DynaLoader Exporter);
+
+use vars qw($__PROXY_NODE_REGISTRY $__threads_shared $__PROXY_NODE_REGISTRY_MUTEX $__loaded);
+
+sub VERSION {
+ my $class = shift;
+ my ($caller) = caller;
+ my $req_abi = $ABI_VERSION;
+ if (UNIVERSAL::can($caller,'REQUIRE_XML_LIBXML_ABI_VERSION')) {
+ $req_abi = $caller->REQUIRE_XML_LIBXML_ABI_VERSION();
+ } elsif ($caller eq 'XML::LibXSLT') {
+ # XML::LibXSLT without REQUIRE_XML_LIBXML_ABI_VERSION is an old and incompatible version
+ $req_abi = 1;
+ }
+ unless ($req_abi == $ABI_VERSION) {
+ my $ver = @_ ? ' '.$_[0] : '';
+ die ("This version of $caller requires XML::LibXML$ver (ABI $req_abi), which is incompatible with currently installed XML::LibXML $VERSION (ABI $ABI_VERSION). Please upgrade $caller, XML::LibXML, or both!");
+ }
+ return $class->UNIVERSAL::VERSION(@_)
+}
+
+#-------------------------------------------------------------------------#
+# export information #
+#-------------------------------------------------------------------------#
+%EXPORT_TAGS = (
+ all => [qw(
+ XML_ELEMENT_NODE
+ XML_ATTRIBUTE_NODE
+ XML_TEXT_NODE
+ XML_CDATA_SECTION_NODE
+ XML_ENTITY_REF_NODE
+ XML_ENTITY_NODE
+ XML_PI_NODE
+ XML_COMMENT_NODE
+ XML_DOCUMENT_NODE
+ XML_DOCUMENT_TYPE_NODE
+ XML_DOCUMENT_FRAG_NODE
+ XML_NOTATION_NODE
+ XML_HTML_DOCUMENT_NODE
+ XML_DTD_NODE
+ XML_ELEMENT_DECL
+ XML_ATTRIBUTE_DECL
+ XML_ENTITY_DECL
+ XML_NAMESPACE_DECL
+ XML_XINCLUDE_END
+ XML_XINCLUDE_START
+ encodeToUTF8
+ decodeFromUTF8
+ XML_XMLNS_NS
+ XML_XML_NS
+ )],
+ libxml => [qw(
+ XML_ELEMENT_NODE
+ XML_ATTRIBUTE_NODE
+ XML_TEXT_NODE
+ XML_CDATA_SECTION_NODE
+ XML_ENTITY_REF_NODE
+ XML_ENTITY_NODE
+ XML_PI_NODE
+ XML_COMMENT_NODE
+ XML_DOCUMENT_NODE
+ XML_DOCUMENT_TYPE_NODE
+ XML_DOCUMENT_FRAG_NODE
+ XML_NOTATION_NODE
+ XML_HTML_DOCUMENT_NODE
+ XML_DTD_NODE
+ XML_ELEMENT_DECL
+ XML_ATTRIBUTE_DECL
+ XML_ENTITY_DECL
+ XML_NAMESPACE_DECL
+ XML_XINCLUDE_END
+ XML_XINCLUDE_START
+ )],
+ encoding => [qw(
+ encodeToUTF8
+ decodeFromUTF8
+ )],
+ ns => [qw(
+ XML_XMLNS_NS
+ XML_XML_NS
+ )],
+ );
+
+@EXPORT_OK = (
+ @{$EXPORT_TAGS{all}},
+ );
+
+@EXPORT = (
+ @{$EXPORT_TAGS{all}},
+ );
+
+#-------------------------------------------------------------------------#
+# initialization of the global variables #
+#-------------------------------------------------------------------------#
+$skipDTD = 0;
+$skipXMLDeclaration = 0;
+$setTagCompression = 0;
+
+$MatchCB = undef;
+$ReadCB = undef;
+$OpenCB = undef;
+$CloseCB = undef;
+
+# if ($threads::threads) {
+# our $__THREADS_TID = 0;
+# eval q{
+# use threads::shared;
+# our $__PROXY_NODE_REGISTRY_MUTEX :shared = 0;
+# };
+# die $@ if $@;
+# }
+#-------------------------------------------------------------------------#
+# bootstrapping #
+#-------------------------------------------------------------------------#
+bootstrap XML::LibXML $VERSION;
+undef &AUTOLOAD;
+
+*encodeToUTF8 = \&XML::LibXML::Common::encodeToUTF8;
+*decodeFromUTF8 = \&XML::LibXML::Common::decodeFromUTF8;
+
+} # BEGIN
+
+
+#-------------------------------------------------------------------------#
+# libxml2 node names (see also XML::LibXML::Common #
+#-------------------------------------------------------------------------#
+use constant XML_ELEMENT_NODE => 1;
+use constant XML_ATTRIBUTE_NODE => 2;
+use constant XML_TEXT_NODE => 3;
+use constant XML_CDATA_SECTION_NODE => 4;
+use constant XML_ENTITY_REF_NODE => 5;
+use constant XML_ENTITY_NODE => 6;
+use constant XML_PI_NODE => 7;
+use constant XML_COMMENT_NODE => 8;
+use constant XML_DOCUMENT_NODE => 9;
+use constant XML_DOCUMENT_TYPE_NODE => 10;
+use constant XML_DOCUMENT_FRAG_NODE => 11;
+use constant XML_NOTATION_NODE => 12;
+use constant XML_HTML_DOCUMENT_NODE => 13;
+use constant XML_DTD_NODE => 14;
+use constant XML_ELEMENT_DECL => 15;
+use constant XML_ATTRIBUTE_DECL => 16;
+use constant XML_ENTITY_DECL => 17;
+use constant XML_NAMESPACE_DECL => 18;
+use constant XML_XINCLUDE_START => 19;
+use constant XML_XINCLUDE_END => 20;
+
+
+sub import {
+ my $package=shift;
+ if (grep /^:threads_shared$/, @_) {
+ require threads;
+ if (!defined($__threads_shared)) {
+ if (INIT_THREAD_SUPPORT()) {
+ eval q{
+ use threads::shared;
+ share($__PROXY_NODE_REGISTRY_MUTEX);
+ };
+ if ($@) { # something went wrong
+ DISABLE_THREAD_SUPPORT(); # leave the library in a usable state
+ die $@; # and die
+ }
+ $__PROXY_NODE_REGISTRY = XML::LibXML::HashTable->new();
+ $__threads_shared=1;
+ } else {
+ croak("XML::LibXML or Perl compiled without ithread support!");
+ }
+ } elsif (!$__threads_shared) {
+ croak("XML::LibXML already loaded without thread support. Too late to enable thread support!");
+ }
+ } elsif (defined $XML::LibXML::__loaded) {
+ $__threads_shared=0 if not defined $__threads_shared;
+ }
+ __PACKAGE__->export_to_level(1,$package,grep !/^:threads(_shared)?$/,@_);
+}
+
+sub threads_shared_enabled {
+ return $__threads_shared ? 1 : 0;
+}
+
+# if ($threads::threads) {
+# our $__PROXY_NODE_REGISTRY = XML::LibXML::HashTable->new();
+# }
+
+#-------------------------------------------------------------------------#
+# test exact version (up to patch-level) #
+#-------------------------------------------------------------------------#
+{
+ my ($runtime_version) = LIBXML_RUNTIME_VERSION() =~ /^(\d+)/;
+ if ( $runtime_version < LIBXML_VERSION ) {
+ warn "Warning: XML::LibXML compiled against libxml2 ".LIBXML_VERSION.
+ ", but runtime libxml2 is older $runtime_version\n";
+ }
+}
+
+
+#-------------------------------------------------------------------------#
+# parser flags #
+#-------------------------------------------------------------------------#
+
+# Copied directly from http://xmlsoft.org/html/libxml-parser.html#xmlParserOption
+use constant {
+ XML_PARSE_RECOVER => 1, # recover on errors
+ XML_PARSE_NOENT => 2, # substitute entities
+ XML_PARSE_DTDLOAD => 4, # load the external subset
+ XML_PARSE_DTDATTR => 8, # default DTD attributes
+ XML_PARSE_DTDVALID => 16, # validate with the DTD
+ XML_PARSE_NOERROR => 32, # suppress error reports
+ XML_PARSE_NOWARNING => 64, # suppress warning reports
+ XML_PARSE_PEDANTIC => 128, # pedantic error reporting
+ XML_PARSE_NOBLANKS => 256, # remove blank nodes
+ XML_PARSE_SAX1 => 512, # use the SAX1 interface internally
+ XML_PARSE_XINCLUDE => 1024, # Implement XInclude substitition
+ XML_PARSE_NONET => 2048, # Forbid network access
+ XML_PARSE_NODICT => 4096, # Do not reuse the context dictionnary
+ XML_PARSE_NSCLEAN => 8192, # remove redundant namespaces declarations
+ XML_PARSE_NOCDATA => 16384, # merge CDATA as text nodes
+ XML_PARSE_NOXINCNODE => 32768, # do not generate XINCLUDE START/END nodes
+ XML_PARSE_COMPACT => 65536, # compact small text nodes; no modification of the tree allowed afterwards
+ # (will possibly crash if you try to modify the tree)
+ XML_PARSE_OLD10 => 131072, # parse using XML-1.0 before update 5
+ XML_PARSE_NOBASEFIX => 262144, # do not fixup XINCLUDE xml#base uris
+ XML_PARSE_HUGE => 524288, # relax any hardcoded limit from the parser
+ XML_PARSE_OLDSAX => 1048576, # parse using SAX2 interface from before 2.7.0
+};
+
+use constant XML_LIBXML_PARSE_DEFAULTS => ( XML_PARSE_NODICT | XML_PARSE_HUGE | XML_PARSE_DTDLOAD | XML_PARSE_NOENT );
+
+# this hash is made global so that applications can add names for new
+# libxml2 parser flags as temporary workaround
+
+%PARSER_FLAGS = (
+ recover => XML_PARSE_RECOVER,
+ expand_entities => XML_PARSE_NOENT,
+ load_ext_dtd => XML_PARSE_DTDLOAD,
+ complete_attributes => XML_PARSE_DTDATTR,
+ validation => XML_PARSE_DTDVALID,
+ suppress_errors => XML_PARSE_NOERROR,
+ suppress_warnings => XML_PARSE_NOWARNING,
+ pedantic_parser => XML_PARSE_PEDANTIC,
+ no_blanks => XML_PARSE_NOBLANKS,
+ expand_xinclude => XML_PARSE_XINCLUDE,
+ xinclude => XML_PARSE_XINCLUDE,
+ no_network => XML_PARSE_NONET,
+ clean_namespaces => XML_PARSE_NSCLEAN,
+ no_cdata => XML_PARSE_NOCDATA,
+ no_xinclude_nodes => XML_PARSE_NOXINCNODE,
+ old10 => XML_PARSE_OLD10,
+ no_base_fix => XML_PARSE_NOBASEFIX,
+ huge => XML_PARSE_HUGE,
+ oldsax => XML_PARSE_OLDSAX,
+);
+
+my %OUR_FLAGS = (
+ recover => 'XML_LIBXML_RECOVER',
+ line_numbers => 'XML_LIBXML_LINENUMBERS',
+ URI => 'XML_LIBXML_BASE_URI',
+ base_uri => 'XML_LIBXML_BASE_URI',
+ gdome => 'XML_LIBXML_GDOME',
+ ext_ent_handler => 'ext_ent_handler',
+);
+
+sub _parser_options {
+ my ($self, $opts) = @_;
+
+ # currently dictionaries break XML::LibXML memory management
+
+ my $flags;
+
+ if (ref($self)) {
+ $flags = ($self->{XML_LIBXML_PARSER_OPTIONS}||0);
+ } else {
+ $flags = XML_LIBXML_PARSE_DEFAULTS; # safety precaution
+ }
+
+ my ($key, $value);
+ while (($key,$value) = each %$opts) {
+ my $f = $PARSER_FLAGS{ $key };
+ if (defined $f) {
+ if ($value) {
+ $flags |= $f
+ } else {
+ $flags &= ~$f;
+ }
+ } elsif ($key eq 'set_parser_flags') { # this can be used to pass flags XML::LibXML does not yet know about
+ $flags |= $value;
+ } elsif ($key eq 'unset_parser_flags') {
+ $flags &= ~$value;
+ }
+
+ }
+ return $flags;
+}
+
+my %compatibility_flags = (
+ XML_LIBXML_VALIDATION => 'validation',
+ XML_LIBXML_EXPAND_ENTITIES => 'expand_entities',
+ XML_LIBXML_PEDANTIC => 'pedantic_parser',
+ XML_LIBXML_NONET => 'no_network',
+ XML_LIBXML_EXT_DTD => 'load_ext_dtd',
+ XML_LIBXML_COMPLETE_ATTR => 'complete_attributes',
+ XML_LIBXML_EXPAND_XINCLUDE => 'expand_xinclude',
+ XML_LIBXML_NSCLEAN => 'clean_namespaces',
+ XML_LIBXML_KEEP_BLANKS => 'keep_blanks',
+ XML_LIBXML_LINENUMBERS => 'line_numbers',
+);
+
+#-------------------------------------------------------------------------#
+# parser constructor #
+#-------------------------------------------------------------------------#
+
+
+sub new {
+ my $class = shift;
+ my $self = bless {
+ }, $class;
+ if (@_) {
+ my %opts = ();
+ if (ref($_[0]) eq 'HASH') {
+ %opts = %{$_[0]};
+ } else {
+ # old interface
+ my %args = @_;
+ %opts=(
+ map {
+ (($compatibility_flags{ $_ }||$_) => $args{ $_ })
+ } keys %args
+ );
+ }
+ # parser flags
+ $opts{no_blanks} = !$opts{keep_blanks} if exists($opts{keep_blanks}) and !exists($opts{no_blanks});
+
+ for (keys %OUR_FLAGS) {
+ $self->{$OUR_FLAGS{$_}} = delete $opts{$_};
+ }
+ $class->load_catalog(delete($opts{catalog})) if $opts{catalog};
+
+ $self->{XML_LIBXML_PARSER_OPTIONS} = XML::LibXML->_parser_options(\%opts);
+
+ # store remaining unknown options directly in $self
+ for (keys %opts) {
+ $self->{$_}=$opts{$_} unless exists $PARSER_FLAGS{$_};
+ }
+ } else {
+ $self->{XML_LIBXML_PARSER_OPTIONS} = XML_LIBXML_PARSE_DEFAULTS;
+ }
+ if ( defined $self->{Handler} ) {
+ $self->set_handler( $self->{Handler} );
+ }
+
+ $self->{_State_} = 0;
+ return $self;
+}
+
+sub _clone {
+ my ($self)=@_;
+ my $new = ref($self)->new({
+ recover => $self->{XML_LIBXML_RECOVER},
+ line_nubers => $self->{XML_LIBXML_LINENUMBERS},
+ base_uri => $self->{XML_LIBXML_BASE_URI},
+ gdome => $self->{XML_LIBXML_GDOME},
+ set_parser_flags => $self->{XML_LIBXML_PARSER_OPTIONS},
+ });
+ return $new;
+}
+
+#-------------------------------------------------------------------------#
+# Threads support methods #
+#-------------------------------------------------------------------------#
+
+# threads doc says CLONE's API may change in future, which would break
+# an XS method prototype
+sub CLONE {
+ if ($XML::LibXML::__threads_shared) {
+ XML::LibXML::_CLONE( $_[0] );
+ }
+}
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+sub __proxy_registry {
+ my ($class)=caller;
+ die "This version of $class uses API of XML::LibXML 1.66 which is not compatible with XML::LibXML $VERSION. Please upgrade $class!\n";
+}
+
+#-------------------------------------------------------------------------#
+# DOM Level 2 document constructor #
+#-------------------------------------------------------------------------#
+
+sub createDocument {
+ my $self = shift;
+ if (!@_ or $_[0] =~ m/^\d\.\d$/) {
+ # for backward compatibility
+ return XML::LibXML::Document->new(@_);
+ }
+ else {
+ # DOM API: createDocument(namespaceURI, qualifiedName, doctype?)
+ my $doc = XML::LibXML::Document-> new;
+ my $el = $doc->createElementNS(shift, shift);
+ $doc->setDocumentElement($el);
+ $doc->setExternalSubset(shift) if @_;
+ return $doc;
+ }
+}
+
+#-------------------------------------------------------------------------#
+# callback functions #
+#-------------------------------------------------------------------------#
+
+sub input_callbacks {
+ my $self = shift;
+ my $icbclass = shift;
+
+ if ( defined $icbclass ) {
+ $self->{XML_LIBXML_CALLBACK_STACK} = $icbclass;
+ }
+ return $self->{XML_LIBXML_CALLBACK_STACK};
+}
+
+sub match_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXML_MATCH_CB} = shift;
+ $self->{XML_LIBXML_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXML_MATCH_CB};
+ }
+ else {
+ $MatchCB = shift if scalar @_;
+ return $MatchCB;
+ }
+}
+
+sub read_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXML_READ_CB} = shift;
+ $self->{XML_LIBXML_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXML_READ_CB};
+ }
+ else {
+ $ReadCB = shift if scalar @_;
+ return $ReadCB;
+ }
+}
+
+sub close_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXML_CLOSE_CB} = shift;
+ $self->{XML_LIBXML_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXML_CLOSE_CB};
+ }
+ else {
+ $CloseCB = shift if scalar @_;
+ return $CloseCB;
+ }
+}
+
+sub open_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXML_OPEN_CB} = shift;
+ $self->{XML_LIBXML_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXML_OPEN_CB};
+ }
+ else {
+ $OpenCB = shift if scalar @_;
+ return $OpenCB;
+ }
+}
+
+sub callbacks {
+ my $self = shift;
+ if ( ref $self ) {
+ if (@_) {
+ my ($match, $open, $read, $close) = @_;
+ @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)} = ($match, $open, $read, $close);
+ $self->{XML_LIBXML_CALLBACK_STACK} = undef;
+ }
+ else {
+ return @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)};
+ }
+ }
+ else {
+ if (@_) {
+ ( $MatchCB, $OpenCB, $ReadCB, $CloseCB ) = @_;
+ }
+ else {
+ return ( $MatchCB, $OpenCB, $ReadCB, $CloseCB );
+ }
+ }
+}
+
+#-------------------------------------------------------------------------#
+# internal member variable manipulation #
+#-------------------------------------------------------------------------#
+sub __parser_option {
+ my ($self, $opt) = @_;
+ if (@_>2) {
+ if ($_[2]) {
+ $self->{XML_LIBXML_PARSER_OPTIONS} |= $opt;
+ return 1;
+ } else {
+ $self->{XML_LIBXML_PARSER_OPTIONS} &= ~$opt;
+ return 0;
+ }
+ } else {
+ return ($self->{XML_LIBXML_PARSER_OPTIONS} & $opt) ? 1 : 0;
+ }
+}
+
+sub option_exists {
+ my ($self,$name)=@_;
+ return ($PARSER_FLAGS{$name} || $OUR_FLAGS{$name}) ? 1 : 0;
+}
+sub get_option {
+ my ($self,$name)=@_;
+ my $flag = $OUR_FLAGS{$name};
+ return $self->{$flag} if $flag;
+ $flag = $PARSER_FLAGS{$name};
+ return $self->__parser_option($flag) if $flag;
+ warn "XML::LibXML::get_option: unknown parser option $name\n";
+ return undef;
+}
+sub set_option {
+ my ($self,$name,$value)=@_;
+ my $flag = $OUR_FLAGS{$name};
+ return ($self->{$flag}=$value) if $flag;
+ $flag = $PARSER_FLAGS{$name};
+ return $self->__parser_option($flag,$value) if $flag;
+ warn "XML::LibXML::get_option: unknown parser option $name\n";
+ return undef;
+}
+sub set_options {
+ my $self=shift;
+ my $opts;
+ if (@_==1 and ref($_[0]) eq 'HASH') {
+ $opts = $_[0];
+ } elsif (@_ % 2 == 0) {
+ $opts={@_};
+ } else {
+ croak("Odd number of elements passed to set_options");
+ }
+ $self->set_option($_=>$opts->{$_}) foreach keys %$opts;
+ return;
+}
+
+sub validation {
+ my $self = shift;
+ return $self->__parser_option(XML_PARSE_DTDVALID,@_);
+}
+
+sub recover {
+ my $self = shift;
+ if (scalar @_) {
+ $self->{XML_LIBXML_RECOVER} = $_[0];
+ $self->__parser_option(XML_PARSE_RECOVER,@_);
+ }
+ return $self->{XML_LIBXML_RECOVER};
+}
+
+sub recover_silently {
+ my $self = shift;
+ my $arg = shift;
+ (($arg == 1) ? $self->recover(2) : $self->recover($arg)) if defined($arg);
+ return (($self->recover()||0) == 2) ? 1 : 0;
+}
+
+sub expand_entities {
+ my $self = shift;
+ if (scalar(@_) and $_[0]) {
+ return $self->__parser_option(XML_PARSE_NOENT | XML_PARSE_DTDLOAD,1);
+ }
+ return $self->__parser_option(XML_PARSE_NOENT,@_);
+}
+
+sub keep_blanks {
+ my $self = shift;
+ my @args; # we have to negate the argument and return negated value, since
+ # the actual flag is no_blanks
+ if (scalar @_) {
+ @args=($_[0] ? 0 : 1);
+ }
+ return $self->__parser_option(XML_PARSE_NOBLANKS,@args) ? 0 : 1;
+}
+
+sub pedantic_parser {
+ my $self = shift;
+ return $self->__parser_option(XML_PARSE_PEDANTIC,@_);
+}
+
+sub line_numbers {
+ my $self = shift;
+ $self->{XML_LIBXML_LINENUMBERS} = shift if scalar @_;
+ return $self->{XML_LIBXML_LINENUMBERS};
+}
+
+sub no_network {
+ my $self = shift;
+ return $self->__parser_option(XML_PARSE_NONET,@_);
+}
+
+sub load_ext_dtd {
+ my $self = shift;
+ return $self->__parser_option(XML_PARSE_DTDLOAD,@_);
+}
+
+sub complete_attributes {
+ my $self = shift;
+ return $self->__parser_option(XML_PARSE_DTDATTR,@_);
+}
+
+sub expand_xinclude {
+ my $self = shift;
+ return $self->__parser_option(XML_PARSE_XINCLUDE,@_);
+}
+
+sub base_uri {
+ my $self = shift;
+ $self->{XML_LIBXML_BASE_URI} = shift if scalar @_;
+ return $self->{XML_LIBXML_BASE_URI};
+}
+
+sub gdome_dom {
+ my $self = shift;
+ $self->{XML_LIBXML_GDOME} = shift if scalar @_;
+ return $self->{XML_LIBXML_GDOME};
+}
+
+sub clean_namespaces {
+ my $self = shift;
+ return $self->__parser_option(XML_PARSE_NSCLEAN,@_);
+}
+
+#-------------------------------------------------------------------------#
+# set the optional SAX(2) handler #
+#-------------------------------------------------------------------------#
+sub set_handler {
+ my $self = shift;
+ if ( defined $_[0] ) {
+ $self->{HANDLER} = $_[0];
+
+ $self->{SAX_ELSTACK} = [];
+ $self->{SAX} = {State => 0};
+ }
+ else {
+ # undef SAX handling
+ $self->{SAX_ELSTACK} = [];
+ delete $self->{HANDLER};
+ delete $self->{SAX};
+ }
+}
+
+#-------------------------------------------------------------------------#
+# helper functions #
+#-------------------------------------------------------------------------#
+sub _auto_expand {
+ my ( $self, $result, $uri ) = @_;
+
+ $result->setBaseURI( $uri ) if defined $uri;
+
+ if ( $self->expand_xinclude ) {
+ $self->{_State_} = 1;
+ eval { $self->processXIncludes($result); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ $self->_cleanup_callbacks();
+ $result = undef;
+ croak $err;
+ }
+ }
+ return $result;
+}
+
+sub _init_callbacks {
+ my $self = shift;
+ my $icb = $self->{XML_LIBXML_CALLBACK_STACK};
+ unless ( defined $icb ) {
+ $self->{XML_LIBXML_CALLBACK_STACK} = XML::LibXML::InputCallback->new();
+ $icb = $self->{XML_LIBXML_CALLBACK_STACK};
+ }
+
+ my $mcb = $self->match_callback();
+ my $ocb = $self->open_callback();
+ my $rcb = $self->read_callback();
+ my $ccb = $self->close_callback();
+
+ if ( defined $mcb and defined $ocb and defined $rcb and defined $ccb ) {
+ $icb->register_callbacks( [$mcb, $ocb, $rcb, $ccb] );
+ }
+ $icb->init_callbacks();
+}
+
+sub _cleanup_callbacks {
+ my $self = shift;
+ $self->{XML_LIBXML_CALLBACK_STACK}->cleanup_callbacks();
+ my $mcb = $self->match_callback();
+ $self->{XML_LIBXML_CALLBACK_STACK}->unregister_callbacks( [$mcb] );
+}
+
+sub __read {
+ read($_[0], $_[1], $_[2]);
+}
+
+sub __write {
+ if ( ref( $_[0] ) ) {
+ $_[0]->write( $_[1], $_[2] );
+ }
+ else {
+ $_[0]->write( $_[1] );
+ }
+}
+
+sub load_xml {
+ my ($class_or_self) = shift;
+ my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_;
+ my $URI = delete($args{URI});
+ $URI = "$URI" if defined $URI; # stringify in case it is an URI object
+ my $parser;
+ if (ref($class_or_self)) {
+ $parser = $class_or_self->_clone();
+ $parser->{XML_LIBXML_PARSER_OPTIONS} = $parser->_parser_options(\%args);
+ } else {
+ $parser = $class_or_self->new(\%args);
+ }
+ my $dom;
+ if ( defined $args{location} ) {
+ $dom = $parser->parse_file( "$args{location}" );
+ }
+ elsif ( defined $args{string} ) {
+ $dom = $parser->parse_string( $args{string}, $URI );
+ }
+ elsif ( defined $args{IO} ) {
+ $dom = $parser->parse_fh( $args{IO}, $URI );
+ }
+ else {
+ croak("XML::LibXML->load: specify location, string, or IO");
+ }
+ return $dom;
+}
+
+sub load_html {
+ my ($class_or_self) = shift;
+ my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_;
+ my $URI = delete($args{URI});
+ $URI = "$URI" if defined $URI; # stringify in case it is an URI object
+ my $parser;
+ if (ref($class_or_self)) {
+ $parser = $class_or_self->_clone();
+ } else {
+ $parser = $class_or_self->new();
+ }
+ my $dom;
+ if ( defined $args{location} ) {
+ $dom = $parser->parse_html_file( "$args{location}", \%args );
+ }
+ elsif ( defined $args{string} ) {
+ $dom = $parser->parse_html_string( $args{string}, \%args );
+ }
+ elsif ( defined $args{IO} ) {
+ $dom = $parser->parse_html_fh( $args{IO}, \%args );
+ }
+ else {
+ croak("XML::LibXML->load: specify location, string, or IO");
+ }
+ return $dom;
+}
+
+#-------------------------------------------------------------------------#
+# parsing functions #
+#-------------------------------------------------------------------------#
+# all parsing functions handle normal as SAX parsing at the same time.
+# note that SAX parsing is handled incomplete! use XML::LibXML::SAX for
+# complete parsing sequences
+#-------------------------------------------------------------------------#
+sub parse_string {
+ my $self = shift;
+ croak("parse_string is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
+ croak("parse already in progress") if $self->{_State_};
+
+ unless ( defined $_[0] and length $_[0] ) {
+ croak("Empty String");
+ }
+
+ $self->{_State_} = 1;
+ my $result;
+
+ $self->_init_callbacks();
+
+ if ( defined $self->{SAX} ) {
+ my $string = shift;
+ $self->{SAX_ELSTACK} = [];
+ eval { $result = $self->_parse_sax_string($string); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+ }
+ else {
+ eval { $result = $self->_parse_string( @_ ); };
+
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+
+ $result = $self->_auto_expand( $result, $self->{XML_LIBXML_BASE_URI} );
+ }
+ $self->_cleanup_callbacks();
+
+ return $result;
+}
+
+sub parse_fh {
+ my $self = shift;
+ croak("parse_fh is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
+ croak("parse already in progress") if $self->{_State_};
+ $self->{_State_} = 1;
+ my $result;
+
+ $self->_init_callbacks();
+
+ if ( defined $self->{SAX} ) {
+ $self->{SAX_ELSTACK} = [];
+ eval { $self->_parse_sax_fh( @_ ); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+ }
+ else {
+ eval { $result = $self->_parse_fh( @_ ); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+
+ $result = $self->_auto_expand( $result, $self->{XML_LIBXML_BASE_URI} );
+ }
+
+ $self->_cleanup_callbacks();
+
+ return $result;
+}
+
+sub parse_file {
+ my $self = shift;
+ croak("parse_file is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
+ croak("parse already in progress") if $self->{_State_};
+
+ $self->{_State_} = 1;
+ my $result;
+
+ $self->_init_callbacks();
+
+ if ( defined $self->{SAX} ) {
+ $self->{SAX_ELSTACK} = [];
+ eval { $self->_parse_sax_file( @_ ); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+ }
+ else {
+ eval { $result = $self->_parse_file(@_); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+
+ $result = $self->_auto_expand( $result );
+ }
+ $self->_cleanup_callbacks();
+
+ return $result;
+}
+
+sub parse_xml_chunk {
+ my $self = shift;
+ # max 2 parameter:
+ # 1: the chunk
+ # 2: the encoding of the string
+ croak("parse_xml_chunk is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
+ croak("parse already in progress") if $self->{_State_}; my $result;
+
+ unless ( defined $_[0] and length $_[0] ) {
+ croak("Empty String");
+ }
+
+ $self->{_State_} = 1;
+
+ $self->_init_callbacks();
+
+ if ( defined $self->{SAX} ) {
+ eval {
+ $self->_parse_sax_xml_chunk( @_ );
+
+ # this is required for XML::GenericChunk.
+ # in normal case is_filter is not defined, an thus the parsing
+ # will be terminated. in case of a SAX filter the parsing is not
+ # finished at that state. therefore we must not reset the parsing
+ unless ( $self->{IS_FILTER} ) {
+ $result = $self->{HANDLER}->end_document();
+ }
+ };
+ }
+ else {
+ eval { $result = $self->_parse_xml_chunk( @_ ); };
+ }
+
+ $self->_cleanup_callbacks();
+
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ croak $err;
+ }
+
+ return $result;
+}
+
+sub parse_balanced_chunk {
+ my $self = shift;
+ $self->_init_callbacks();
+ my $rv;
+ eval {
+ $rv = $self->parse_xml_chunk( @_ );
+ };
+ my $err = $@;
+ $self->_cleanup_callbacks();
+ if ( $err ) {
+ chomp $err unless ref $err;
+ croak $err;
+ }
+ return $rv
+}
+
+# java style
+sub processXIncludes {
+ my $self = shift;
+ my $doc = shift;
+ my $opts = shift;
+ my $options = $self->_parser_options($opts);
+ if ( $self->{_State_} != 1 ) {
+ $self->_init_callbacks();
+ }
+ my $rv;
+ eval {
+ $rv = $self->_processXIncludes($doc || " ", $options);
+ };
+ my $err = $@;
+ if ( $self->{_State_} != 1 ) {
+ $self->_cleanup_callbacks();
+ }
+
+ if ( $err ) {
+ chomp $err unless ref $err;
+ croak $err;
+ }
+ return $rv;
+}
+
+# perl style
+sub process_xincludes {
+ my $self = shift;
+ my $doc = shift;
+ my $opts = shift;
+ my $options = $self->_parser_options($opts);
+
+ my $rv;
+ $self->_init_callbacks();
+ eval {
+ $rv = $self->_processXIncludes($doc || " ", $options);
+ };
+ my $err = $@;
+ $self->_cleanup_callbacks();
+ if ( $err ) {
+ chomp $err unless ref $err;
+ croak $@;
+ }
+ return $rv;
+}
+
+#-------------------------------------------------------------------------#
+# HTML parsing functions #
+#-------------------------------------------------------------------------#
+
+sub _html_options {
+ my ($self,$opts)=@_;
+ $opts = {} unless ref $opts;
+ # return (undef,undef) unless ref $opts;
+ my $flags = 0;
+ $flags |= 1 if exists $opts->{recover} ? $opts->{recover} : $self->recover;
+ $flags |= 32 if $opts->{suppress_errors};
+ $flags |= 64 if $opts->{suppress_warnings};
+ $flags |= 128 if exists $opts->{pedantic_parser} ? $opts->{pedantic_parser} : $self->pedantic_parser;
+ $flags |= 256 if exists $opts->{no_blanks} ? $opts->{no_blanks} : !$self->keep_blanks;
+ $flags |= 2048 if exists $opts->{no_network} ? $opts->{no_network} : !$self->no_network;
+ $flags |= 16384 if $opts->{no_cdata};
+ $flags |= 65536 if $opts->{compact}; # compact small text nodes; no modification
+ # of the tree allowed afterwards
+ # (WILL possibly CRASH IF YOU try to MODIFY THE TREE)
+ $flags |= 524288 if $opts->{huge}; # relax any hardcoded limit from the parser
+ $flags |= 1048576 if $opts->{oldsax}; # parse using SAX2 interface from before 2.7.0
+
+ return ($opts->{URI},$opts->{encoding},$flags);
+}
+
+sub parse_html_string {
+ my ($self,$str,$opts) = @_;
+ croak("parse_html_string is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
+ croak("parse already in progress") if $self->{_State_};
+
+ unless ( defined $str and length $str ) {
+ croak("Empty String");
+ }
+ $self->{_State_} = 1;
+ my $result;
+
+ $self->_init_callbacks();
+ eval {
+ $result = $self->_parse_html_string( $str,
+ $self->_html_options($opts)
+ );
+ };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+
+ $self->_cleanup_callbacks();
+
+ return $result;
+}
+
+sub parse_html_file {
+ my ($self,$file,$opts) = @_;
+ croak("parse_html_file is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
+ croak("parse already in progress") if $self->{_State_};
+ $self->{_State_} = 1;
+ my $result;
+
+ $self->_init_callbacks();
+ eval { $result = $self->_parse_html_file($file,
+ $self->_html_options($opts)
+ ); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+
+ $self->_cleanup_callbacks();
+
+ return $result;
+}
+
+sub parse_html_fh {
+ my ($self,$fh,$opts) = @_;
+ croak("parse_html_fh is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
+ croak("parse already in progress") if $self->{_State_};
+ $self->{_State_} = 1;
+
+ my $result;
+ $self->_init_callbacks();
+ eval { $result = $self->_parse_html_fh( $fh,
+ $self->_html_options($opts)
+ ); };
+ my $err = $@;
+ $self->{_State_} = 0;
+ if ($err) {
+ chomp $err unless ref $err;
+ $self->_cleanup_callbacks();
+ croak $err;
+ }
+ $self->_cleanup_callbacks();
+
+ return $result;
+}
+
+#-------------------------------------------------------------------------#
+# push parser interface #
+#-------------------------------------------------------------------------#
+sub init_push {
+ my $self = shift;
+
+ if ( defined $self->{CONTEXT} ) {
+ delete $self->{CONTEXT};
+ }
+
+ if ( defined $self->{SAX} ) {
+ $self->{CONTEXT} = $self->_start_push(1);
+ }
+ else {
+ $self->{CONTEXT} = $self->_start_push(0);
+ }
+}
+
+sub push {
+ my $self = shift;
+
+ $self->_init_callbacks();
+
+ if ( not defined $self->{CONTEXT} ) {
+ $self->init_push();
+ }
+
+ eval {
+ foreach ( @_ ) {
+ $self->_push( $self->{CONTEXT}, $_ );
+ }
+ };
+ my $err = $@;
+ $self->_cleanup_callbacks();
+ if ( $err ) {
+ chomp $err unless ref $err;
+ croak $err;
+ }
+}
+
+# this function should be promoted!
+# the reason is because libxml2 uses xmlParseChunk() for this purpose!
+sub parse_chunk {
+ my $self = shift;
+ my $chunk = shift;
+ my $terminate = shift;
+
+ if ( not defined $self->{CONTEXT} ) {
+ $self->init_push();
+ }
+
+ if ( defined $chunk and length $chunk ) {
+ $self->_push( $self->{CONTEXT}, $chunk );
+ }
+
+ if ( $terminate ) {
+ return $self->finish_push();
+ }
+}
+
+
+sub finish_push {
+ my $self = shift;
+ my $restore = shift || 0;
+ return undef unless defined $self->{CONTEXT};
+
+ my $retval;
+
+ if ( defined $self->{SAX} ) {
+ eval {
+ $self->_end_sax_push( $self->{CONTEXT} );
+ $retval = $self->{HANDLER}->end_document( {} );
+ };
+ }
+ else {
+ eval { $retval = $self->_end_push( $self->{CONTEXT}, $restore ); };
+ }
+ my $err = $@;
+ delete $self->{CONTEXT};
+ if ( $err ) {
+ chomp $err unless ref $err;
+ croak( $err );
+ }
+ return $retval;
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Node Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::Node;
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+sub isSupported {
+ my $self = shift;
+ my $feature = shift;
+ return $self->can($feature) ? 1 : 0;
+}
+
+sub getChildNodes { my $self = shift; return $self->childNodes(); }
+
+sub childNodes {
+ my $self = shift;
+ my @children = $self->_childNodes(0);
+ return wantarray ? @children : XML::LibXML::NodeList->new_from_ref(\@children , 1);
+}
+
+sub nonBlankChildNodes {
+ my $self = shift;
+ my @children = $self->_childNodes(1);
+ return wantarray ? @children : XML::LibXML::NodeList->new_from_ref(\@children , 1);
+}
+
+sub attributes {
+ my $self = shift;
+ my @attr = $self->_attributes();
+ return wantarray ? @attr : XML::LibXML::NamedNodeMap->new( @attr );
+}
+
+
+sub findnodes {
+ my ($node, $xpath) = @_;
+ my @nodes = $node->_findnodes($xpath);
+ if (wantarray) {
+ return @nodes;
+ }
+ else {
+ return XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+ }
+}
+
+sub exists {
+ my ($node, $xpath) = @_;
+ my (undef, $value) = $node->_find($xpath,1);
+ return $value;
+}
+
+sub findvalue {
+ my ($node, $xpath) = @_;
+ my $res;
+ $res = $node->find($xpath);
+ return $res->to_literal->value;
+}
+
+sub findbool {
+ my ($node, $xpath) = @_;
+ my ($type, @params) = $node->_find($xpath,1);
+ if ($type) {
+ return $type->new(@params);
+ }
+ return undef;
+}
+
+sub find {
+ my ($node, $xpath) = @_;
+ my ($type, @params) = $node->_find($xpath,0);
+ if ($type) {
+ return $type->new(@params);
+ }
+ return undef;
+}
+
+sub setOwnerDocument {
+ my ( $self, $doc ) = @_;
+ $doc->adoptNode( $self );
+}
+
+sub toStringC14N {
+ my ($self, $comments, $xpath, $xpc) = @_;
+ return $self->_toStringC14N( $comments || 0,
+ (defined $xpath ? $xpath : undef),
+ 0,
+ undef,
+ (defined $xpc ? $xpc : undef)
+ );
+}
+sub toStringEC14N {
+ my ($self, $comments, $xpath, $xpc, $inc_prefix_list) = @_;
+ unless (UNIVERSAL::isa($xpc,'XML::LibXML::XPathContext')) {
+ if ($inc_prefix_list) {
+ croak("toStringEC14N: 3rd argument is not an XML::LibXML::XPathContext");
+ } else {
+ $inc_prefix_list=$xpc;
+ $xpc=undef;
+ }
+ }
+ if (defined($inc_prefix_list) and !UNIVERSAL::isa($inc_prefix_list,'ARRAY')) {
+ croak("toStringEC14N: inclusive_prefix_list must be undefined or ARRAY");
+ }
+ return $self->_toStringC14N( $comments || 0,
+ (defined $xpath ? $xpath : undef),
+ 1,
+ (defined $inc_prefix_list ? $inc_prefix_list : undef),
+ (defined $xpc ? $xpc : undef)
+ );
+}
+
+*serialize_c14n = \&toStringC14N;
+*serialize_exc_c14n = \&toStringEC14N;
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Document Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::Document;
+
+use vars qw(@ISA);
+@ISA = ('XML::LibXML::Node');
+
+sub actualEncoding {
+ my $doc = shift;
+ my $enc = $doc->encoding;
+ return (defined $enc and length $enc) ? $enc : 'UTF-8';
+}
+
+sub setDocumentElement {
+ my $doc = shift;
+ my $element = shift;
+
+ my $oldelem = $doc->documentElement;
+ if ( defined $oldelem ) {
+ $doc->removeChild($oldelem);
+ }
+
+ $doc->_setDocumentElement($element);
+}
+
+sub toString {
+ my $self = shift;
+ my $flag = shift;
+
+ my $retval = "";
+
+ if ( defined $XML::LibXML::skipXMLDeclaration
+ and $XML::LibXML::skipXMLDeclaration == 1 ) {
+ foreach ( $self->childNodes ){
+ next if $_->nodeType == XML::LibXML::XML_DTD_NODE()
+ and $XML::LibXML::skipDTD;
+ $retval .= $_->toString;
+ }
+ }
+ else {
+ $flag ||= 0 unless defined $flag;
+ $retval = $self->_toString($flag);
+ }
+
+ return $retval;
+}
+
+sub serialize {
+ my $self = shift;
+ return $self->toString( @_ );
+}
+
+#-------------------------------------------------------------------------#
+# bad style xinclude processing #
+#-------------------------------------------------------------------------#
+sub process_xinclude {
+ my $self = shift;
+ my $opts = shift;
+ XML::LibXML->new->processXIncludes( $self, $opts );
+}
+
+sub insertProcessingInstruction {
+ my $self = shift;
+ my $target = shift;
+ my $data = shift;
+
+ my $pi = $self->createPI( $target, $data );
+ my $root = $self->documentElement;
+
+ if ( defined $root ) {
+ # this is actually not correct, but i guess it's what the user
+ # intends
+ $self->insertBefore( $pi, $root );
+ }
+ else {
+ # if no documentElement was found we just append the PI
+ $self->appendChild( $pi );
+ }
+}
+
+sub insertPI {
+ my $self = shift;
+ $self->insertProcessingInstruction( @_ );
+}
+
+#-------------------------------------------------------------------------#
+# DOM L3 Document functions.
+# added after robins implicit feature requst
+#-------------------------------------------------------------------------#
+*getElementsByTagName = \&XML::LibXML::Element::getElementsByTagName;
+*getElementsByTagNameNS = \&XML::LibXML::Element::getElementsByTagNameNS;
+*getElementsByLocalName = \&XML::LibXML::Element::getElementsByLocalName;
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::DocumentFragment Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::DocumentFragment;
+
+use vars qw(@ISA);
+@ISA = ('XML::LibXML::Node');
+
+sub toString {
+ my $self = shift;
+ my $retval = "";
+ if ( $self->hasChildNodes() ) {
+ foreach my $n ( $self->childNodes() ) {
+ $retval .= $n->toString(@_);
+ }
+ }
+ return $retval;
+}
+
+*serialize = \&toString;
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Element Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::Element;
+
+use vars qw(@ISA);
+@ISA = ('XML::LibXML::Node');
+use XML::LibXML qw(:ns :libxml);
+use Carp;
+
+sub setNamespace {
+ my $self = shift;
+ my $n = $self->nodeName;
+ if ( $self->_setNamespace(@_) ){
+ if ( scalar @_ < 3 || $_[2] == 1 ){
+ $self->setNodeName( $n );
+ }
+ return 1;
+ }
+ return 0;
+}
+
+sub getAttribute {
+ my $self = shift;
+ my $name = $_[0];
+ if ( $name =~ /^xmlns(?::|$)/ ) {
+ # user wants to get a namespace ...
+ (my $prefix = $name )=~s/^xmlns:?//;
+ $self->_getNamespaceDeclURI($prefix);
+ }
+ else {
+ $self->_getAttribute(@_);
+ }
+}
+
+sub setAttribute {
+ my ( $self, $name, $value ) = @_;
+ if ( $name =~ /^xmlns(?::|$)/ ) {
+ # user wants to set the special attribute for declaring XML namespace ...
+
+ # this is fine but not exactly DOM conformant behavior, btw (according to DOM we should
+ # probably declare an attribute which looks like XML namespace declaration
+ # but isn't)
+ (my $nsprefix = $name )=~s/^xmlns:?//;
+ my $nn = $self->nodeName;
+ if ( $nn =~ /^\Q${nsprefix}\E:/ ) {
+ # the element has the same prefix
+ $self->setNamespaceDeclURI($nsprefix,$value) ||
+ $self->setNamespace($value,$nsprefix,1);
+ ##
+ ## We set the namespace here.
+ ## This is helpful, as in:
+ ##
+ ## | $e = XML::LibXML::Element->new('foo:bar');
+ ## | $e->setAttribute('xmlns:foo','http://yoyodine')
+ ##
+ }
+ else {
+ # just modify the namespace
+ $self->setNamespaceDeclURI($nsprefix, $value) ||
+ $self->setNamespace($value,$nsprefix,0);
+ }
+ }
+ else {
+ $self->_setAttribute($name, $value);
+ }
+}
+
+sub getAttributeNS {
+ my $self = shift;
+ my ($nsURI, $name) = @_;
+ croak("invalid attribute name") if !defined($name) or $name eq q{};
+ if ( defined($nsURI) and $nsURI eq XML_XMLNS_NS ) {
+ $self->_getNamespaceDeclURI($name eq 'xmlns' ? undef : $name);
+ }
+ else {
+ $self->_getAttributeNS(@_);
+ }
+}
+
+sub setAttributeNS {
+ my ($self, $nsURI, $qname, $value)=@_;
+ unless (defined $qname and length $qname) {
+ croak("bad name");
+ }
+ if (defined($nsURI) and $nsURI eq XML_XMLNS_NS) {
+ if ($qname !~ /^xmlns(?::|$)/) {
+ croak("NAMESPACE ERROR: Namespace declartions must have the prefix 'xmlns'");
+ }
+ $self->setAttribute($qname,$value); # see implementation above
+ return;
+ }
+ if ($qname=~/:/ and not (defined($nsURI) and length($nsURI))) {
+ croak("NAMESPACE ERROR: Attribute without a prefix cannot be in a namespace");
+ }
+ if ($qname=~/^xmlns(?:$|:)/) {
+ croak("NAMESPACE ERROR: 'xmlns' prefix and qualified-name are reserved for the namespace ".XML_XMLNS_NS);
+ }
+ if ($qname=~/^xml:/ and not (defined $nsURI and $nsURI eq XML_XML_NS)) {
+ croak("NAMESPACE ERROR: 'xml' prefix is reserved for the namespace ".XML_XML_NS);
+ }
+ $self->_setAttributeNS( defined $nsURI ? $nsURI : undef, $qname, $value );
+}
+
+sub getElementsByTagName {
+ my ( $node , $name ) = @_;
+ my $xpath = $name eq '*' ? "descendant::*" : "descendant::*[name()='$name']";
+ my @nodes = $node->_findnodes($xpath);
+ return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+}
+
+sub getElementsByTagNameNS {
+ my ( $node, $nsURI, $name ) = @_;
+ my $xpath;
+ if ( $name eq '*' ) {
+ if ( $nsURI eq '*' ) {
+ $xpath = "descendant::*";
+ } else {
+ $xpath = "descendant::*[namespace-uri()='$nsURI']";
+ }
+ } elsif ( $nsURI eq '*' ) {
+ $xpath = "descendant::*[local-name()='$name']";
+ } else {
+ $xpath = "descendant::*[local-name()='$name' and namespace-uri()='$nsURI']";
+ }
+ my @nodes = $node->_findnodes($xpath);
+ return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+}
+
+sub getElementsByLocalName {
+ my ( $node,$name ) = @_;
+ my $xpath;
+ if ($name eq '*') {
+ $xpath = "descendant::*";
+ } else {
+ $xpath = "descendant::*[local-name()='$name']";
+ }
+ my @nodes = $node->_findnodes($xpath);
+ return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+}
+
+sub getChildrenByTagName {
+ my ( $node, $name ) = @_;
+ my @nodes;
+ if ($name eq '*') {
+ @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() }
+ $node->childNodes();
+ } else {
+ @nodes = grep { $_->nodeName eq $name } $node->childNodes();
+ }
+ return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+}
+
+sub getChildrenByLocalName {
+ my ( $node, $name ) = @_;
+ # my @nodes;
+ # if ($name eq '*') {
+ # @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() }
+ # $node->childNodes();
+ # } else {
+ # @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() and
+ # $_->localName eq $name } $node->childNodes();
+ # }
+ # return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+ my @nodes = $node->_getChildrenByTagNameNS('*',$name);
+ return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+}
+
+sub getChildrenByTagNameNS {
+ my ( $node, $nsURI, $name ) = @_;
+ my @nodes = $node->_getChildrenByTagNameNS($nsURI,$name);
+ return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
+}
+
+sub appendWellBalancedChunk {
+ my ( $self, $chunk ) = @_;
+
+ my $local_parser = XML::LibXML->new();
+ my $frag = $local_parser->parse_xml_chunk( $chunk );
+
+ $self->appendChild( $frag );
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Text Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::Text;
+
+use vars qw(@ISA);
+@ISA = ('XML::LibXML::Node');
+
+sub attributes { return undef; }
+
+sub deleteDataString {
+ my $node = shift;
+ my $string = shift;
+ my $all = shift;
+ my $data = $node->nodeValue();
+ $string =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g;
+ if ( $all ) {
+ $data =~ s/$string//g;
+ }
+ else {
+ $data =~ s/$string//;
+ }
+ $node->setData( $data );
+}
+
+sub replaceDataString {
+ my ( $node, $left, $right,$all ) = @_;
+
+ #ashure we exchange the strings and not expressions!
+ $left =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g;
+ my $datastr = $node->nodeValue();
+ if ( $all ) {
+ $datastr =~ s/$left/$right/g;
+ }
+ else{
+ $datastr =~ s/$left/$right/;
+ }
+ $node->setData( $datastr );
+}
+
+sub replaceDataRegEx {
+ my ( $node, $leftre, $rightre, $flags ) = @_;
+ return unless defined $leftre;
+ $rightre ||= "";
+
+ my $datastr = $node->nodeValue();
+ my $restr = "s/" . $leftre . "/" . $rightre . "/";
+ $restr .= $flags if defined $flags;
+
+ eval '$datastr =~ '. $restr;
+
+ $node->setData( $datastr );
+}
+
+1;
+
+package XML::LibXML::Comment;
+
+use vars qw(@ISA);
+@ISA = ('XML::LibXML::Text');
+
+1;
+
+package XML::LibXML::CDATASection;
+
+use vars qw(@ISA);
+@ISA = ('XML::LibXML::Text');
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Attribute Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::Attr;
+use vars qw( @ISA ) ;
+@ISA = ('XML::LibXML::Node') ;
+
+sub setNamespace {
+ my ($self,$href,$prefix) = @_;
+ my $n = $self->nodeName;
+ if ( $self->_setNamespace($href,$prefix) ) {
+ $self->setNodeName($n);
+ return 1;
+ }
+
+ return 0;
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Dtd Interface #
+#-------------------------------------------------------------------------#
+# this is still under construction
+#
+package XML::LibXML::Dtd;
+use vars qw( @ISA );
+@ISA = ('XML::LibXML::Node');
+
+# at least DESTROY and CLONE_SKIP must be inherited
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::PI Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::PI;
+use vars qw( @ISA );
+@ISA = ('XML::LibXML::Node');
+
+sub setData {
+ my $pi = shift;
+
+ my $string = "";
+ if ( scalar @_ == 1 ) {
+ $string = shift;
+ }
+ else {
+ my %h = @_;
+ $string = join " ", map {$_.'="'.$h{$_}.'"'} keys %h;
+ }
+
+ # the spec says any char but "?>" [17]
+ $pi->_setData( $string ) unless $string =~ /\?>/;
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Namespace Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::Namespace;
+
+sub CLONE_SKIP { 1 }
+
+# this is infact not a node!
+sub prefix { return "xmlns"; }
+sub getPrefix { return "xmlns"; }
+sub getNamespaceURI { return "http://www.w3.org/2000/xmlns/" };
+
+sub getNamespaces { return (); }
+
+sub nodeName {
+ my $self = shift;
+ my $nsP = $self->localname;
+ return ( defined($nsP) && length($nsP) ) ? "xmlns:$nsP" : "xmlns";
+}
+sub name { goto &nodeName }
+sub getName { goto &nodeName }
+
+sub isEqualNode {
+ my ( $self, $ref ) = @_;
+ if ( ref($ref) eq "XML::LibXML::Namespace" ) {
+ return $self->_isEqual($ref);
+ }
+ return 0;
+}
+
+sub isSameNode {
+ my ( $self, $ref ) = @_;
+ if ( $$self == $$ref ){
+ return 1;
+ }
+ return 0;
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::NamedNodeMap Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::NamedNodeMap;
+
+use XML::LibXML qw(:libxml);
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+sub new {
+ my $class = shift;
+ my $self = bless { Nodes => [@_] }, $class;
+ $self->{NodeMap} = { map { $_->nodeName => $_ } @_ };
+ return $self;
+}
+
+sub length { return scalar( @{$_[0]->{Nodes}} ); }
+sub nodes { return $_[0]->{Nodes}; }
+sub item { $_[0]->{Nodes}->[$_[1]]; }
+
+sub getNamedItem {
+ my $self = shift;
+ my $name = shift;
+
+ return $self->{NodeMap}->{$name};
+}
+
+sub setNamedItem {
+ my $self = shift;
+ my $node = shift;
+
+ my $retval;
+ if ( defined $node ) {
+ if ( scalar @{$self->{Nodes}} ) {
+ my $name = $node->nodeName();
+ if ( $node->nodeType() == XML_NAMESPACE_DECL ) {
+ return;
+ }
+ if ( defined $self->{NodeMap}->{$name} ) {
+ if ( $node->isSameNode( $self->{NodeMap}->{$name} ) ) {
+ return;
+ }
+ $retval = $self->{NodeMap}->{$name}->replaceNode( $node );
+ }
+ else {
+ $self->{Nodes}->[0]->addSibling($node);
+ }
+
+ $self->{NodeMap}->{$name} = $node;
+ push @{$self->{Nodes}}, $node;
+ }
+ else {
+ # not done yet
+ # can this be properly be done???
+ warn "not done yet\n";
+ }
+ }
+ return $retval;
+}
+
+sub removeNamedItem {
+ my $self = shift;
+ my $name = shift;
+ my $retval;
+ if ( $name =~ /^xmlns/ ) {
+ warn "not done yet\n";
+ }
+ elsif ( exists $self->{NodeMap}->{$name} ) {
+ $retval = $self->{NodeMap}->{$name};
+ $retval->unbindNode;
+ delete $self->{NodeMap}->{$name};
+ $self->{Nodes} = [grep {not($retval->isSameNode($_))} @{$self->{Nodes}}];
+ }
+
+ return $retval;
+}
+
+sub getNamedItemNS {
+ my $self = shift;
+ my $nsURI = shift;
+ my $name = shift;
+ return undef;
+}
+
+sub setNamedItemNS {
+ my $self = shift;
+ my $nsURI = shift;
+ my $node = shift;
+ return undef;
+}
+
+sub removeNamedItemNS {
+ my $self = shift;
+ my $nsURI = shift;
+ my $name = shift;
+ return undef;
+}
+
+1;
+
+package XML::LibXML::_SAXParser;
+
+# this is pseudo class!!! and it will be removed as soon all functions
+# moved to XS level
+
+use XML::SAX::Exception;
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+# these functions will use SAX exceptions as soon i know how things really work
+sub warning {
+ my ( $parser, $message, $line, $col ) = @_;
+ my $error = XML::SAX::Exception::Parse->new( LineNumber => $line,
+ ColumnNumber => $col,
+ Message => $message, );
+ $parser->{HANDLER}->warning( $error );
+}
+
+sub error {
+ my ( $parser, $message, $line, $col ) = @_;
+
+ my $error = XML::SAX::Exception::Parse->new( LineNumber => $line,
+ ColumnNumber => $col,
+ Message => $message, );
+ $parser->{HANDLER}->error( $error );
+}
+
+sub fatal_error {
+ my ( $parser, $message, $line, $col ) = @_;
+ my $error = XML::SAX::Exception::Parse->new( LineNumber => $line,
+ ColumnNumber => $col,
+ Message => $message, );
+ $parser->{HANDLER}->fatal_error( $error );
+}
+
+1;
+
+package XML::LibXML::RelaxNG;
+
+sub CLONE_SKIP { 1 }
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ my $self = undef;
+ if ( defined $args{location} ) {
+ $self = $class->parse_location( $args{location} );
+ }
+ elsif ( defined $args{string} ) {
+ $self = $class->parse_buffer( $args{string} );
+ }
+ elsif ( defined $args{DOM} ) {
+ $self = $class->parse_document( $args{DOM} );
+ }
+
+ return $self;
+}
+
+1;
+
+package XML::LibXML::Schema;
+
+sub CLONE_SKIP { 1 }
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ my $self = undef;
+ if ( defined $args{location} ) {
+ $self = $class->parse_location( $args{location} );
+ }
+ elsif ( defined $args{string} ) {
+ $self = $class->parse_buffer( $args{string} );
+ }
+
+ return $self;
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::Pattern Interface #
+#-------------------------------------------------------------------------#
+
+package XML::LibXML::Pattern;
+
+sub CLONE_SKIP { 1 }
+
+sub new {
+ my $class = shift;
+ my ($pattern,$ns_map)=@_;
+ my $self = undef;
+
+ unless (UNIVERSAL::can($class,'_compilePattern')) {
+ croak("Cannot create XML::LibXML::Pattern - ".
+ "your libxml2 is compiled without pattern support!");
+ }
+
+ if (ref($ns_map) eq 'HASH') {
+ # translate prefix=>URL hash to a (URL,prefix) list
+ $self = $class->_compilePattern($pattern,0,[reverse %$ns_map]);
+ } else {
+ $self = $class->_compilePattern($pattern,0);
+ }
+ return $self;
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::RegExp Interface #
+#-------------------------------------------------------------------------#
+
+package XML::LibXML::RegExp;
+
+sub CLONE_SKIP { 1 }
+
+sub new {
+ my $class = shift;
+ my ($regexp)=@_;
+ unless (UNIVERSAL::can($class,'_compile')) {
+ croak("Cannot create XML::LibXML::RegExp - ".
+ "your libxml2 is compiled without regexp support!");
+ }
+ return $class->_compile($regexp);
+}
+
+1;
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::XPathExpression Interface #
+#-------------------------------------------------------------------------#
+
+package XML::LibXML::XPathExpression;
+
+sub CLONE_SKIP { 1 }
+
+1;
+
+
+#-------------------------------------------------------------------------#
+# XML::LibXML::InputCallback Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXML::InputCallback;
+
+use vars qw($_CUR_CB @_GLOBAL_CALLBACKS @_CB_STACK);
+
+BEGIN {
+ $_CUR_CB = undef;
+ @_GLOBAL_CALLBACKS = ();
+ @_CB_STACK = ();
+}
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+#-------------------------------------------------------------------------#
+# global callbacks #
+#-------------------------------------------------------------------------#
+sub _callback_match {
+ my $uri = shift;
+ my $retval = 0;
+
+ # loop through the callbacks and and find the first matching
+ # The callbacks are stored in execution order (reverse stack order)
+ # any new global callbacks are shifted to the callback stack.
+ foreach my $cb ( @_GLOBAL_CALLBACKS ) {
+
+ # callbacks have to return 1, 0 or undef, while 0 and undef
+ # are handled the same way.
+ # in fact, if callbacks return other values, the global match
+ # assumes silently that the callback failed.
+
+ $retval = $cb->[0]->($uri);
+
+ if ( defined $retval and $retval == 1 ) {
+ # make the other callbacks use this callback
+ $_CUR_CB = $cb;
+ unshift @_CB_STACK, $cb;
+ last;
+ }
+ }
+
+ return $retval;
+}
+
+sub _callback_open {
+ my $uri = shift;
+ my $retval = undef;
+
+ # the open callback has to return a defined value.
+ # if one works on files this can be a file handle. But
+ # depending on the needs of the callback it also can be a
+ # database handle or a integer labeling a certain dataset.
+
+ if ( defined $_CUR_CB ) {
+ $retval = $_CUR_CB->[1]->( $uri );
+
+ # reset the callbacks, if one callback cannot open an uri
+ if ( not defined $retval or $retval == 0 ) {
+ shift @_CB_STACK;
+ $_CUR_CB = $_CB_STACK[0];
+ }
+ }
+
+ return $retval;
+}
+
+sub _callback_read {
+ my $fh = shift;
+ my $buflen = shift;
+
+ my $retval = undef;
+
+ if ( defined $_CUR_CB ) {
+ $retval = $_CUR_CB->[2]->( $fh, $buflen );
+ }
+
+ return $retval;
+}
+
+sub _callback_close {
+ my $fh = shift;
+ my $retval = 0;
+
+ if ( defined $_CUR_CB ) {
+ $retval = $_CUR_CB->[3]->( $fh );
+ shift @_CB_STACK;
+ $_CUR_CB = $_CB_STACK[0];
+ }
+
+ return $retval;
+}
+
+#-------------------------------------------------------------------------#
+# member functions and methods #
+#-------------------------------------------------------------------------#
+
+sub new {
+ my $CLASS = shift;
+ return bless {'_CALLBACKS' => []}, $CLASS;
+}
+
+# add a callback set to the callback stack
+# synopsis: $icb->register_callbacks( [$match_cb, $open_cb, $read_cb, $close_cb] );
+sub register_callbacks {
+ my $self = shift;
+ my $cbset = shift;
+
+ # test if callback set is complete
+ if ( ref $cbset eq "ARRAY" and scalar( @$cbset ) == 4 ) {
+ unshift @{$self->{_CALLBACKS}}, $cbset;
+ }
+}
+
+# remove a callback set to the callback stack
+# if a callback set is passed, this function will check for the match function
+sub unregister_callbacks {
+ my $self = shift;
+ my $cbset = shift;
+ if ( ref $cbset eq "ARRAY" and scalar( @$cbset ) == 4 ) {
+ $self->{_CALLBACKS} = [grep { $_->[0] != $cbset->[0] } @{$self->{_CALLBACKS}}];
+ }
+ else {
+ shift @{$self->{_CALLBACKS}};
+ }
+}
+
+# make libxml2 use the callbacks
+sub init_callbacks {
+ my $self = shift;
+
+ $_CUR_CB = undef;
+ @_CB_STACK = ();
+
+ @_GLOBAL_CALLBACKS = @{ $self->{_CALLBACKS} };
+
+ if ( defined $XML::LibXML::match_cb and
+ defined $XML::LibXML::open_cb and
+ defined $XML::LibXML::read_cb and
+ defined $XML::LibXML::close_cb ) {
+ push @_GLOBAL_CALLBACKS, [$XML::LibXML::match_cb,
+ $XML::LibXML::open_cb,
+ $XML::LibXML::read_cb,
+ $XML::LibXML::close_cb];
+ }
+
+ $self->lib_init_callbacks();
+}
+
+# reset libxml2's callbacks
+sub cleanup_callbacks {
+ my $self = shift;
+
+ $_CUR_CB = undef;
+ @_GLOBAL_CALLBACKS = ();
+ @_CB_STACK = ();
+
+ $self->lib_cleanup_callbacks();
+}
+
+$XML::LibXML::__loaded=1;
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML.pod
new file mode 100755
index 00000000000..73bf58b69f5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML.pod
@@ -0,0 +1,515 @@
+=head1 NAME
+
+XML::LibXML - Perl Binding for libxml2
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ my $dom = XML::LibXML->load_xml(string => <<'EOT');
+ <some-xml/>
+ EOT
+
+ $Version_String = XML::LibXML::LIBXML_DOTTED_VERSION;
+ $Version_ID = XML::LibXML::LIBXML_VERSION;
+ $DLL_Version = XML::LibXML::LIBXML_RUNTIME_VERSION;
+ $libxmlnode = XML::LibXML->import_GDOME( $node, $deep );
+ $gdomenode = XML::LibXML->export_GDOME( $node, $deep );
+
+=head1 DESCRIPTION
+
+This module is an interface to libxml2, providing XML and HTML parsers with
+DOM, SAX and XMLReader interfaces, a large subset of DOM Layer 3 interface and
+a XML::XPath-like interface to XPath API of libxml2. The module is split into
+several packages which are not described in this section; unless stated
+otherwise, you only need to C<<<<<< use XML::LibXML; >>>>>> in your programs.
+
+For further information, please check the following documentation:
+
+=over 4
+
+=item L<<<<<< XML::LibXML::Parser >>>>>>
+
+Parsing XML files with XML::LibXML
+
+
+=item L<<<<<< XML::LibXML::DOM >>>>>>
+
+XML::LibXML Document Object Model (DOM) Implementation
+
+
+=item L<<<<<< XML::LibXML::SAX >>>>>>
+
+XML::LibXML direct SAX parser
+
+
+=item L<<<<<< XML::LibXML::Reader >>>>>>
+
+Reading XML with a pull-parser
+
+
+=item L<<<<<< XML::LibXML::Dtd >>>>>>
+
+XML::LibXML frontend for DTD validation
+
+
+=item L<<<<<< XML::LibXML::RelaxNG >>>>>>
+
+XML::LibXML frontend for RelaxNG schema validation
+
+
+=item L<<<<<< XML::LibXML::Schema >>>>>>
+
+XML::LibXML frontend for W3C Schema schema validation
+
+
+=item L<<<<<< XML::LibXML::XPathContext >>>>>>
+
+API for evaluating XPath expressions with enhanced support for the evaluation
+context
+
+
+=item L<<<<<< XML::LibXML::InputCallback >>>>>>
+
+Implementing custom URI Resolver and input callbacks
+
+
+=item L<<<<<< XML::LibXML::Common >>>>>>
+
+Common functions for XML::LibXML related Classes
+
+
+
+=back
+
+The nodes in the Document Object Model (DOM) are represented by the following
+classes (most of which "inherit" from L<<<<<< XML::LibXML::Node >>>>>>):
+
+=over 4
+
+=item L<<<<<< XML::LibXML::Document >>>>>>
+
+XML::LibXML class for DOM document nodes
+
+
+=item L<<<<<< XML::LibXML::Node >>>>>>
+
+Abstract base class for XML::LibXML DOM nodes
+
+
+=item L<<<<<< XML::LibXML::Element >>>>>>
+
+XML::LibXML class for DOM element nodes
+
+
+=item L<<<<<< XML::LibXML::Text >>>>>>
+
+XML::LibXML class for DOM text nodes
+
+
+=item L<<<<<< XML::LibXML::Comment >>>>>>
+
+XML::LibXML class for comment DOM nodes
+
+
+=item L<<<<<< XML::LibXML::CDATASection >>>>>>
+
+XML::LibXML class for DOM CDATA sections
+
+
+=item L<<<<<< XML::LibXML::Attr >>>>>>
+
+XML::LibXML DOM attribute class
+
+
+=item L<<<<<< XML::LibXML::DocumentFragment >>>>>>
+
+XML::LibXML's DOM L2 Document Fragment implementation
+
+
+=item L<<<<<< XML::LibXML::Namespace >>>>>>
+
+XML::LibXML DOM namespace nodes
+
+
+=item L<<<<<< XML::LibXML::PI >>>>>>
+
+XML::LibXML DOM processing instruction nodes
+
+
+
+=back
+
+
+=head1 ENCODINGS SUPPORT IN XML::LIBXML
+
+Recall that since version 5.6.1, Perl distinguishes between character strings
+(internally encoded in UTF-8) and so called binary data and, accordingly,
+applies either character or byte semantics to them. A scalar representing a
+character string is distinguished from a byte string by special flag (UTF8).
+Please refer to I<<<<<< perlunicode >>>>>> for details.
+
+XML::LibXML's API is designed to deal with many encodings of XML documents
+completely transparently, so that the application using XML::LibXML can be
+completely ignorant about the encoding of the XML documents it works with. On
+the other hand, functions like C<<<<<< XML::LibXML::Document->setEncoding >>>>>> give the user control over the document encoding.
+
+To ensure the aforementioned transparency and uniformity, most functions of
+XML::LibXML that work with in-memory trees accept and return data as character
+strings (i.e. UTF-8 encoded with the UTF8 flag on) regardless of the original
+document encoding; however, the functions related to I/O operations (i.e.
+parsing and saving) operate with binary data (in the original document
+encoding) obeying the encoding declaration of the XML documents.
+
+Below we summarize basic rules and principles regarding encoding:
+
+
+=over 4
+
+=item 1.
+
+Do NOT apply any encoding-related PerlIO layers (C<<<<<< :utf8 >>>>>> or C<<<<<< :encoding(...) >>>>>>) to file handles that are an input for the parses or an output for a
+serializer of (full) XML documents. This is because the conversion of the data
+to/from the internal character representation is provided by libxml2 itself
+which must be able to enforce the encoding specified by the C<<<<<< <?xml version="1.0" encoding="..."?> >>>>>> declaration. Here is an example to follow:
+
+ use XML::LibXML;
+ open my $fh, "file.xml";
+ binmode $fh; # drop all PerlIO layers possibly created by a use open pragma
+ $doc = XML::LibXML->load_xml(IO => $fh);
+ open my $out, "out.xml";
+ binmode $fh; # as above
+ $doc->toFh($fh);
+ # or
+ print $fh $doc->toString();
+
+
+
+
+
+=item 2.
+
+All functions working with DOM accept and return character strings (UTF-8
+encoded with UTF8 flag on). E.g.
+
+ my $doc = XML::LibXML:Document->new('1.0',$some_encoding);
+ my $element = $doc->createElement($name);
+ $element->appendText($text);
+ $xml_fragment = $element->toString(); # returns a character string
+ $xml_document = $doc->toString(); # returns a byte string
+
+where C<<<<<< $some_encoding >>>>>> is the document encoding that will be used when saving the document, and C<<<<<< $name >>>>>> and C<<<<<< $text >>>>>> contain character strings (UTF-8 encoded with UTF8 flag on). Note that the
+method C<<<<<< toString >>>>>> returns XML as a character string if applied to other node than the Document
+node and a byte string containing the apropriate
+
+ <?xml version="1.0" encoding="..."?>
+
+declaration if applied to a L<<<<<< XML::LibXML::Document >>>>>>.
+
+
+
+=item 3.
+
+DOM methods also accept binary strings in the original encoding of the document
+to which the node belongs (UTF-8 is assumed if the node is not attached to any
+document). Exploiting this feature is NOT RECOMMENDED since it is considered a
+bad practice.
+
+
+
+ my $doc = XML::LibXML:Document->new('1.0','iso-8859-2');
+ my $text = $doc->createTextNode($some_latin2_encoded_byte_string);
+ # WORKS, BUT NOT RECOMMENDED!
+
+
+
+=back
+
+I<<<<<< NOTE: >>>>>> libxml2 support for many encodings is based on the iconv library. The actual
+list of supported encodings may vary from platform to platform. To test if your
+platform works correctly with your language encoding, build a simple document
+in the particular encoding and try to parse it with XML::LibXML to see if the
+parser produces any errors. Occasional crashes were reported on rare platforms
+that ship with a broken version of iconv.
+
+
+=head1 THREAD SUPPORT
+
+XML::LibXML since 1.67 partially supports Perl threads in Perl >= 5.8.8.
+XML::LibXML can be used with threads in two ways:
+
+By default, all XML::LibXML classes use CLONE_SKIP class method to prevent Perl
+from copying XML::LibXML::* objects when a new thread is spawn. In this mode,
+all XML::LibXML::* objects are thread specific. This is the safest way to work
+with XML::LibXML in threads.
+
+Alternatively, one may use
+
+
+
+ use threads;
+ use XML::LibXML qw(:threads_shared);
+
+to indicate, that all XML::LibXML node and parser objects should be shared
+between the main thread and any thread spawn from there. For example, in
+
+
+
+ my $doc = XML::LibXML->load_xml(location => $filename);
+ my $thr = threads->new(sub{
+ # code working with $doc
+ 1;
+ });
+ $thr->join;
+
+the variable C<<<<<< $doc >>>>>> refers to the exact same XML::LibXML::Document in the spawned thread as in the
+main thread.
+
+Without using mutex locks, oaralel threads may read the same document (i.e. any
+node that belongs to the document), parse files, and modify different
+documents.
+
+However, if there is a chance that some of the threads will attempt to modify a
+document ( or even create new nodes based on that document, e.g. with C<<<<<< $doc->createElement >>>>>>) that other threads may be reading at the same time, the user is responsible
+for creating a mutex lock and using it in I<<<<<< both >>>>>> in the thread that modifies and the thread that reads:
+
+
+
+ my $doc = XML::LibXML->load_xml(location => $filename);
+ my $mutex : shared;
+ my $thr = threads->new(sub{
+ lock $mutex;
+ my $el = $doc->createElement('foo');
+ # ...
+ 1;
+ });
+ {
+ lock $mutex;
+ my $root = $doc->documentElement;
+ say $root->name;
+ }
+ $thr->join;
+
+Note that libxml2 uses dictionaries to store short strings and these
+dicionaries are kept on a document node. Without mutex locks, it could happen
+in the previous example that the thread modifies the dictionary while other
+threads attempt to read from it, which could easily lead to a crash.
+
+
+=head1 VERSION INFORMATION
+
+Sometimes it is useful to figure out, for which version XML::LibXML was
+compiled for. In most cases this is for debugging or to check if a given
+installation meets all functionality for the package. The functions
+XML::LibXML::LIBXML_DOTTED_VERSION and XML::LibXML::LIBXML_VERSION provide this
+version information. Both functions simply pass through the values of the
+similar named macros of libxml2. Similarly, XML::LibXML::LIBXML_RUNTIME_VERSION
+returns the version of the (usually dynamically) linked libxml2.
+
+=over 4
+
+=item XML::LibXML::LIBXML_DOTTED_VERSION
+
+ $Version_String = XML::LibXML::LIBXML_DOTTED_VERSION;
+
+Returns the version string of the libxml2 version XML::LibXML was compiled for.
+This will be "2.6.2" for "libxml2 2.6.2".
+
+
+=item XML::LibXML::LIBXML_VERSION
+
+ $Version_ID = XML::LibXML::LIBXML_VERSION;
+
+Returns the version id of the libxml2 version XML::LibXML was compiled for.
+This will be "20602" for "libxml2 2.6.2". Don't mix this version id with
+$XML::LibXML::VERSION. The latter contains the version of XML::LibXML itself
+while the first contains the version of libxml2 XML::LibXML was compiled for.
+
+
+=item XML::LibXML::LIBXML_RUNTIME_VERSION
+
+ $DLL_Version = XML::LibXML::LIBXML_RUNTIME_VERSION;
+
+Returns a version string of the libxml2 which is (usually dynamically) linked
+by XML::LibXML. This will be "20602" for libxml2 released as "2.6.2" and
+something like "20602-CVS2032" for a CVS build of libxml2.
+
+XML::LibXML issues a warning if the version of libxml2 dynamically linked to it
+is less than the version of libxml2 which it was compiled against.
+
+
+
+=back
+
+
+=head1 EXPORTS
+
+By default the module exports all constants and functions listed in the :all
+tag, described below.
+
+
+=head1 EXPORT TAGS
+
+=over 4
+
+=item C<<<<<< :all >>>>>>
+
+Includes the tags C<<<<<< :libxml >>>>>>, C<<<<<< :encoding >>>>>>, and C<<<<<< :ns >>>>>> described below.
+
+
+=item C<<<<<< :libxml >>>>>>
+
+Exports integer constants for DOM node types.
+
+
+
+ XML_ELEMENT_NODE => 1
+ XML_ATTRIBUTE_NODE => 2
+ XML_TEXT_NODE => 3
+ XML_CDATA_SECTION_NODE => 4
+ XML_ENTITY_REF_NODE => 5
+ XML_ENTITY_NODE => 6
+ XML_PI_NODE => 7
+ XML_COMMENT_NODE => 8
+ XML_DOCUMENT_NODE => 9
+ XML_DOCUMENT_TYPE_NODE => 10
+ XML_DOCUMENT_FRAG_NODE => 11
+ XML_NOTATION_NODE => 12
+ XML_HTML_DOCUMENT_NODE => 13
+ XML_DTD_NODE => 14
+ XML_ELEMENT_DECL => 15
+ XML_ATTRIBUTE_DECL => 16
+ XML_ENTITY_DECL => 17
+ XML_NAMESPACE_DECL => 18
+ XML_XINCLUDE_START => 19
+ XML_XINCLUDE_END => 20
+
+
+=item C<<<<<< :encoding >>>>>>
+
+Exports two encoding conversion functions from XML::LibXML::Common.
+
+
+
+ encodeToUTF8()
+ decodeFromUTF8()
+
+
+=item C<<<<<< :ns >>>>>>
+
+Exports two convenience constants: the implicit namespace of the reserved C<<<<<< xml: >>>>>> prefix, and the implicit namespace for the reserved C<<<<<< xmlns: >>>>>> prefix.
+
+
+
+ XML_XML_NS => 'http://www.w3.org/XML/1998/namespace'
+ XML_XMLNS_NS => 'http://www.w3.org/2000/xmlns/'
+
+
+
+=back
+
+
+=head1 RELATED MODULES
+
+The modules described in this section are not part of the XML::LibXML package
+itself. As they support some additional features, they are mentioned here.
+
+=over 4
+
+=item L<<<<<< XML::LibXSLT >>>>>>
+
+XSLT 1.0 Processor using libxslt and XML::LibXML
+
+
+=item L<<<<<< XML::LibXML::Iterator >>>>>>
+
+XML::LibXML Implementation of the DOM Traversal Specification
+
+
+=item L<<<<<< XML::CompactTree::XS >>>>>>
+
+Uses XML::LibXML::Reader to very efficiently to parse XML document or element
+into native Perl data structures, which are less flexible but significantly
+faster to process then DOM.
+
+
+
+=back
+
+
+=head1 XML::LIBXML AND XML::GDOME
+
+Note: I<<<<<< THE FUNCTIONS DESCRIBED HERE ARE STILL EXPERIMENTAL >>>>>>
+
+Although both modules make use of libxml2's XML capabilities, the DOM
+implementation of both modules are not compatible. But still it is possible to
+exchange nodes from one DOM to the other. The concept of this exchange is
+pretty similar to the function cloneNode(): The particular node is copied on
+the low-level to the opposite DOM implementation.
+
+Since the DOM implementations cannot coexist within one document, one is forced
+to copy each node that should be used. Because you are always keeping two nodes
+this may cause quite an impact on a machines memory usage.
+
+XML::LibXML provides two functions to export or import GDOME nodes:
+import_GDOME() and export_GDOME(). Both function have two parameters: the node
+and a flag for recursive import. The flag works as in cloneNode().
+
+The two functions allow to export and import XML::GDOME nodes explicitly,
+however, XML::LibXML allows also the transparent import of XML::GDOME nodes in
+functions such as appendChild(), insertAfter() and so on. While native nodes
+are automatically adopted in most functions XML::GDOME nodes are always cloned
+in advance. Thus if the original node is modified after the operation, the node
+in the XML::LibXML document will not have this information.
+
+=over 4
+
+=item import_GDOME
+
+ $libxmlnode = XML::LibXML->import_GDOME( $node, $deep );
+
+This clones an XML::GDOME node to a XML::LibXML node explicitly.
+
+
+=item export_GDOME
+
+ $gdomenode = XML::LibXML->export_GDOME( $node, $deep );
+
+Allows to clone an XML::LibXML node into a XML::GDOME node.
+
+
+
+=back
+
+
+=head1 CONTACTS
+
+For bug reports, please use the CPAN request tracker on
+http://rt.cpan.org/NoAuth/Bugs.html?Dist=XML-LibXML
+
+For suggestions etc., and other issues related to XML::LibXML you may use the
+perl XML mailing list (C<<<<<< perl-xml@listserv.ActiveState.com >>>>>>), where most XML-related Perl modules are discussed. In case of problems you
+should check the archives of that list first. Many problems are already
+discussed there. You can find the list's archives and subscription options at L<<<<<< http://aspn.activestate.com/ASPN/Mail/Browse/Threaded/perl-xml >>>>>>.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Attr.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Attr.pod
new file mode 100755
index 00000000000..eeb2678ecb6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Attr.pod
@@ -0,0 +1,134 @@
+=head1 NAME
+
+XML::LibXML::Attr - XML::LibXML Attribute Class
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to Attribute nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ $attr = XML::LibXML::Attr->new($name [,$value]);
+ $string = $attr->getValue();
+ $string = $attr->value;
+ $attr->setValue( $string );
+ $node = $attr->getOwnerElement();
+ $attr->setNamespace($nsURI, $prefix);
+ $bool = $attr->isId;
+ $string = $attr->serializeContent;
+
+=head1 DESCRIPTION
+
+This is the interface to handle Attributes like ordinary nodes. The naming of
+the class relies on the W3C DOM documentation.
+
+
+=head1 METHODS
+
+The class inherits from L<<<<<< XML::LibXML::Node >>>>>>. The documentation for Inherited methods is not listed here.
+
+Many functions listed here are extensively documented in the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>). Please refer to the specification for extensive documentation.
+
+=over 4
+
+=item new
+
+ $attr = XML::LibXML::Attr->new($name [,$value]);
+
+Class constructor. If you need to work with ISO encoded strings, you should I<<<<<< always >>>>>> use the C<<<<<< createAttrbute >>>>>> of L<<<<<< XML::LibXML::Document >>>>>>.
+
+
+=item getValue
+
+ $string = $attr->getValue();
+
+Returns the value stored for the attribute. If undef is returned, the attribute
+has no value, which is different of being C<<<<<< not specified >>>>>>.
+
+
+=item value
+
+ $string = $attr->value;
+
+Alias for I<<<<<< getValue() >>>>>>
+
+
+=item setValue
+
+ $attr->setValue( $string );
+
+This is needed to set a new attribute value. If ISO encoded strings are passed
+as parameter, the node has to be bound to a document, otherwise the encoding
+might be done incorrectly.
+
+
+=item getOwnerElement
+
+ $node = $attr->getOwnerElement();
+
+returns the node the attribute belongs to. If the attribute is not bound to a
+node, undef will be returned. Overwriting the underlying implementation, the I<<<<<< parentNode >>>>>> function will return undef, instead of the owner element.
+
+
+=item setNamespace
+
+ $attr->setNamespace($nsURI, $prefix);
+
+This function tries to bound the attribute to a given namespace. If C<<<<<< $nsURI >>>>>> is undefined or empty, the function discards any previous association of the
+attribute with a namespace. If the namespace was not previously declared in the
+context of the attribute, this function will fail. In this case you may wish to
+call setNamespace() on the ownerElement. If the namespace URI is non-empty and
+declared in the context of the attribute, but only with a different (non-empty)
+prefix, then the attribute is still bound to the namespace but gets a different
+prefix than C<<<<<< $prefix >>>>>>. The function also fails if the prefix is empty but the namespace URI is not
+(because unprefixed attributes should by definition belong to no namespace).
+This function returns 1 on success, 0 otherwise.
+
+
+=item isId
+
+ $bool = $attr->isId;
+
+Determine whether an attribute is of type ID. For documents with a DTD, this
+information is only available if DTD loading/validation has been requested. For
+HTML documents parsed with the HTML parser ID detection is done automatically.
+In XML documents, all "xml:id" attributes are considered to be of type ID.
+
+
+=item serializeContent($docencoding)
+
+ $string = $attr->serializeContent;
+
+This function is not part of DOM API. It returns attribute content in the form
+in which it serializes into XML, that is with all meta-characters properly
+quoted and with raw entity references (except for entities expanded during
+parse time). Setting the optional $docencoding flag to 1 enforces document
+encoding for the output string (which is then passed to Perl as a byte string).
+Otherwise the string is passed to Perl as (UTF-8 encoded) characters.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Boolean.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Boolean.pm
new file mode 100755
index 00000000000..03db16788e7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Boolean.pm
@@ -0,0 +1,92 @@
+# $Id: Boolean.pm 785 2009-07-16 14:17:46Z pajas $
+#
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::Boolean;
+use XML::LibXML::Number;
+use XML::LibXML::Literal;
+use strict;
+
+use vars qw ($VERSION);
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use overload
+ '""' => \&value,
+ '<=>' => \&cmp;
+
+sub new {
+ my $class = shift;
+ my ($param) = @_;
+ my $val = $param ? 1 : 0;
+ bless \$val, $class;
+}
+
+sub True {
+ my $class = shift;
+ my $val = 1;
+ bless \$val, $class;
+}
+
+sub False {
+ my $class = shift;
+ my $val = 0;
+ bless \$val, $class;
+}
+
+sub value {
+ my $self = shift;
+ $$self;
+}
+
+sub cmp {
+ my $self = shift;
+ my ($other, $swap) = @_;
+ if ($swap) {
+ return $other <=> $$self;
+ }
+ return $$self <=> $other;
+}
+
+sub to_number { XML::LibXML::Number->new($_[0]->value); }
+sub to_boolean { $_[0]; }
+sub to_literal { XML::LibXML::Literal->new($_[0]->value ? "true" : "false"); }
+
+sub string_value { return $_[0]->to_literal->value; }
+
+1;
+__END__
+
+=head1 NAME
+
+XML::LibXML::Boolean - Boolean true/false values
+
+=head1 DESCRIPTION
+
+XML::LibXML::Boolean objects implement simple boolean true/false objects.
+
+=head1 API
+
+=head2 XML::LibXML::Boolean->True
+
+Creates a new Boolean object with a true value.
+
+=head2 XML::LibXML::Boolean->False
+
+Creates a new Boolean object with a false value.
+
+=head2 value()
+
+Returns true or false.
+
+=head2 to_literal()
+
+Returns the string "true" or "false".
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/CDATASection.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/CDATASection.pod
new file mode 100755
index 00000000000..c1f1b0996c3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/CDATASection.pod
@@ -0,0 +1,58 @@
+=head1 NAME
+
+XML::LibXML::CDATASection - XML::LibXML Class for CDATA Sections
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to CDATA nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ $node = XML::LibXML::CDATASection( $content );
+
+=head1 DESCRIPTION
+
+This class provides all functions of L<<<<<< XML::LibXML::Text >>>>>>, but for CDATA nodes.
+
+
+=head1 METHODS
+
+The class inherits from L<<<<<< XML::LibXML::Node >>>>>>. The documentation for Inherited methods is not listed here.
+
+Many functions listed here are extensively documented in the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>). Please refer to the specification for extensive documentation.
+
+=over 4
+
+=item new
+
+ $node = XML::LibXML::CDATASection( $content );
+
+The constructor is the only provided function for this package. It is required,
+because I<<<<<< libxml2 >>>>>> treats the different text node types slightly differently.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Comment.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Comment.pod
new file mode 100755
index 00000000000..f5e0829af01
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Comment.pod
@@ -0,0 +1,59 @@
+=head1 NAME
+
+XML::LibXML::Comment - XML::LibXML Comment Class
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to Comment nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ $node = XML::LibXML::Comment( $content );
+
+=head1 DESCRIPTION
+
+This class provides all functions of L<<<<<< XML::LibXML::Text >>>>>>, but for comment nodes. This can be done, since only the output of the node
+types is different, but not the data structure. :-)
+
+
+=head1 METHODS
+
+The class inherits from L<<<<<< XML::LibXML::Node >>>>>>. The documentation for Inherited methods is not listed here.
+
+Many functions listed here are extensively documented in the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>). Please refer to the specification for extensive documentation.
+
+=over 4
+
+=item new
+
+ $node = XML::LibXML::Comment( $content );
+
+The constructor is the only provided function for this package. It is required,
+because I<<<<<< libxml2 >>>>>> treats text nodes and comment nodes slightly differently.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pm
new file mode 100755
index 00000000000..2050c8af363
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pm
@@ -0,0 +1,203 @@
+#-------------------------------------------------------------------------#
+# $Id: Common.pm,v 1.5 2003/02/27 18:32:59 phish108 Exp $
+#
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+#-------------------------------------------------------------------------#
+package XML::LibXML::Common;
+
+
+#-------------------------------------------------------------------------#
+# global blur #
+#-------------------------------------------------------------------------#
+use strict;
+
+require Exporter;
+require DynaLoader;
+use vars qw( @ISA $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+@ISA = qw(Exporter);
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use XML::LibXML qw(:libxml);
+
+#-------------------------------------------------------------------------#
+# export information #
+#-------------------------------------------------------------------------#
+%EXPORT_TAGS = (
+ all => [qw(
+ ELEMENT_NODE
+ ATTRIBUTE_NODE
+ TEXT_NODE
+ CDATA_SECTION_NODE
+ ENTITY_REFERENCE_NODE
+ ENTITY_NODE
+ PI_NODE
+ PROCESSING_INSTRUCTION_NODE
+ COMMENT_NODE
+ DOCUMENT_NODE
+ DOCUMENT_TYPE_NODE
+ DOCUMENT_FRAG_NODE
+ DOCUMENT_FRAGMENT_NODE
+ NOTATION_NODE
+ HTML_DOCUMENT_NODE
+ DTD_NODE
+ ELEMENT_DECLARATION
+ ATTRIBUTE_DECLARATION
+ ENTITY_DECLARATION
+ NAMESPACE_DECLARATION
+ XINCLUDE_END
+ XINCLUDE_START
+ encodeToUTF8
+ decodeFromUTF8
+ )],
+ w3c => [qw(
+ ELEMENT_NODE
+ ATTRIBUTE_NODE
+ TEXT_NODE
+ CDATA_SECTION_NODE
+ ENTITY_REFERENCE_NODE
+ ENTITY_NODE
+ PI_NODE
+ PROCESSING_INSTRUCTION_NODE
+ COMMENT_NODE
+ DOCUMENT_NODE
+ DOCUMENT_TYPE_NODE
+ DOCUMENT_FRAG_NODE
+ DOCUMENT_FRAGMENT_NODE
+ NOTATION_NODE
+ HTML_DOCUMENT_NODE
+ DTD_NODE
+ ELEMENT_DECLARATION
+ ATTRIBUTE_DECLARATION
+ ENTITY_DECLARATION
+ NAMESPACE_DECLARATION
+ XINCLUDE_END
+ XINCLUDE_START
+ )],
+ libxml => [qw(
+ XML_ELEMENT_NODE
+ XML_ATTRIBUTE_NODE
+ XML_TEXT_NODE
+ XML_CDATA_SECTION_NODE
+ XML_ENTITY_REF_NODE
+ XML_ENTITY_NODE
+ XML_PI_NODE
+ XML_COMMENT_NODE
+ XML_DOCUMENT_NODE
+ XML_DOCUMENT_TYPE_NODE
+ XML_DOCUMENT_FRAG_NODE
+ XML_NOTATION_NODE
+ XML_HTML_DOCUMENT_NODE
+ XML_DTD_NODE
+ XML_ELEMENT_DECL
+ XML_ATTRIBUTE_DECL
+ XML_ENTITY_DECL
+ XML_NAMESPACE_DECL
+ XML_XINCLUDE_END
+ XML_XINCLUDE_START
+ )],
+ gdome => [qw(
+ GDOME_ELEMENT_NODE
+ GDOME_ATTRIBUTE_NODE
+ GDOME_TEXT_NODE
+ GDOME_CDATA_SECTION_NODE
+ GDOME_ENTITY_REF_NODE
+ GDOME_ENTITY_NODE
+ GDOME_PI_NODE
+ GDOME_COMMENT_NODE
+ GDOME_DOCUMENT_NODE
+ GDOME_DOCUMENT_TYPE_NODE
+ GDOME_DOCUMENT_FRAG_NODE
+ GDOME_NOTATION_NODE
+ GDOME_HTML_DOCUMENT_NODE
+ GDOME_DTD_NODE
+ GDOME_ELEMENT_DECL
+ GDOME_ATTRIBUTE_DECL
+ GDOME_ENTITY_DECL
+ GDOME_NAMESPACE_DECL
+ GDOME_XINCLUDE_END
+ GDOME_XINCLUDE_START
+ )],
+ encoding => [qw(
+ encodeToUTF8
+ decodeFromUTF8
+ )],
+ );
+
+@EXPORT_OK = (
+ @{$EXPORT_TAGS{encoding}},
+ @{$EXPORT_TAGS{w3c}},
+ @{$EXPORT_TAGS{libxml}},
+ @{$EXPORT_TAGS{gdome}},
+ );
+
+@EXPORT = (
+ @{$EXPORT_TAGS{encoding}},
+ @{$EXPORT_TAGS{w3c}},
+ );
+
+#-------------------------------------------------------------------------#
+# W3 conform node types #
+#-------------------------------------------------------------------------#
+use constant ELEMENT_NODE => 1;
+use constant ATTRIBUTE_NODE => 2;
+use constant TEXT_NODE => 3;
+use constant CDATA_SECTION_NODE => 4;
+use constant ENTITY_REFERENCE_NODE => 5;
+use constant ENTITY_NODE => 6;
+use constant PROCESSING_INSTRUCTION_NODE => 7;
+use constant COMMENT_NODE => 8;
+use constant DOCUMENT_NODE => 9;
+use constant DOCUMENT_TYPE_NODE => 10;
+use constant DOCUMENT_FRAGMENT_NODE => 11;
+use constant NOTATION_NODE => 12;
+use constant HTML_DOCUMENT_NODE => 13;
+use constant DTD_NODE => 14;
+use constant ELEMENT_DECLARATION => 15;
+use constant ATTRIBUTE_DECLARATION => 16;
+use constant ENTITY_DECLARATION => 17;
+use constant NAMESPACE_DECLARATION => 18;
+
+#-------------------------------------------------------------------------#
+# some extras for the W3 spec
+#-------------------------------------------------------------------------#
+use constant PI_NODE => 7;
+use constant DOCUMENT_FRAG_NODE => 11;
+use constant XINCLUDE_END => 19;
+use constant XINCLUDE_START => 20;
+
+#-------------------------------------------------------------------------#
+# libgdome compat names #
+#-------------------------------------------------------------------------#
+use constant GDOME_ELEMENT_NODE => 1;
+use constant GDOME_ATTRIBUTE_NODE => 2;
+use constant GDOME_TEXT_NODE => 3;
+use constant GDOME_CDATA_SECTION_NODE => 4;
+use constant GDOME_ENTITY_REF_NODE => 5;
+use constant GDOME_ENTITY_NODE => 6;
+use constant GDOME_PI_NODE => 7;
+use constant GDOME_COMMENT_NODE => 8;
+use constant GDOME_DOCUMENT_NODE => 9;
+use constant GDOME_DOCUMENT_TYPE_NODE => 10;
+use constant GDOME_DOCUMENT_FRAG_NODE => 11;
+use constant GDOME_NOTATION_NODE => 12;
+use constant GDOME_HTML_DOCUMENT_NODE => 13;
+use constant GDOME_DTD_NODE => 14;
+use constant GDOME_ELEMENT_DECL => 15;
+use constant GDOME_ATTRIBUTE_DECL => 16;
+use constant GDOME_ENTITY_DECL => 17;
+use constant GDOME_NAMESPACE_DECL => 18;
+use constant GDOME_XINCLUDE_START => 19;
+use constant GDOME_XINCLUDE_END => 20;
+
+1;
+#-------------------------------------------------------------------------#
+__END__
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pod
new file mode 100755
index 00000000000..6097399b7e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Common.pod
@@ -0,0 +1,129 @@
+=head1 NAME
+
+XML::LibXML::Common - Constants and Character Encoding Routines
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML::Common;
+
+ $encodedstring = encodeToUTF8( $name_of_encoding, $sting_to_encode );
+ $decodedstring = decodeFromUTF8($name_of_encoding, $string_to_decode );
+
+=head1 DESCRIPTION
+
+XML::LibXML::Common defines constants for all node types and provides interface
+to libxml2 charset conversion functions.
+
+Since XML::LibXML use their own node type definitions, one may want to use
+XML::LibXML::Common in its compatibility mode:
+
+
+=head2 Exporter TAGS
+
+
+
+ use XML::LibXML::Common qw(:libxml);
+
+C<<<<<< :libxml >>>>>> tag will use the XML::LibXML Compatibility mode, which defines the old 'XML_'
+node-type definitions.
+
+
+
+ use XML::LibXML::Common qw(:gdome);
+
+C<<<<<< :gdome >>>>>> tag will use the XML::GDOME Compatibility mode, which defines the old 'GDOME_'
+node-type definitions.
+
+
+
+ use XML::LibXML::Common qw(:w3c);
+
+This uses the nodetype definition names as specified for DOM.
+
+
+
+ use XML::LibXML::Common qw(:encoding);
+
+This tag can be used to export only the charset encoding functions of
+XML::LibXML::Common.
+
+
+=head2 Exports
+
+By default the W3 definitions as defined in the DOM specifications and the
+encoding functions are exported by XML::LibXML::Common.
+
+
+=head2 Encoding functions
+
+To encode or decode a string to or from UTF-8, XML::LibXML::Common exports two
+functions, which provide interfact to the encoding support in C<<<<<< libxml2 >>>>>>. Which encodings are supported by these functions depends on how C<<<<<< libxml2 >>>>>> was compiled. UTF-16 is always supported and on most installations, ISO
+encodings are supported as well.
+
+This interface was useful for older versions of Perl. Since Perl >= 5.8
+provides similar funcions via the C<<<<<< Encode >>>>>> module, it is probably a good idea to use those instead.
+
+=over 4
+
+=item encodeToUTF8
+
+ $encodedstring = encodeToUTF8( $name_of_encoding, $sting_to_encode );
+
+The function will convert a byte string from the specified encoding to an UTF-8
+encoded character string.
+
+
+=item decodeToUTF8
+
+ $decodedstring = decodeFromUTF8($name_of_encoding, $string_to_decode );
+
+This function converts an UTF-8 encoded character string to a specified
+encoding. Note that the conversion can raise an error if the given string
+contains characters that cannot be represented in the target encoding.
+
+
+
+=back
+
+Both these functions report their errors on the standard error. If an error
+occours the function will croak(). To catch the error information it is
+required to call the encoding function from within an eval block in order to
+prevent the entire script from being stopped on encoding error.
+
+
+=head2 A note on history
+
+Before XML::LibXML 1.70, this class was available as a separate CPAN
+distribution, intended to provide functionality shared between XML::LibXML,
+XML::GDOME, and possibly other modules. Since there seems to be no progress in
+this direction, we decided to merge XML::LibXML::Common 0.13 and XML::LibXML
+1.70 to one CPAN distribution.
+
+The merge also naturally eliminates a practical and urgent problem experienced
+by many XML::LibXML users on certain platforms, namely misterious misbehavior
+of XML::LibXML occurring if the installed (often pre-packaged) version of
+XML::LibXML::Common was compiled against an older version of libxml2 than
+XML::LibXML.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/DOM.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/DOM.pod
new file mode 100755
index 00000000000..27fd92c6d59
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/DOM.pod
@@ -0,0 +1,142 @@
+=head1 NAME
+
+XML::LibXML::DOM - XML::LibXML DOM Implementation
+
+=head1 DESCRIPTION
+
+XML::LibXML provides an light-wight interface to I<<<<<< modify >>>>>> a node of the document tree generated by the XML::LibXML parser. This interface
+follows as far as possible the DOM Level 3 specification. Additionally to the
+specified functions the XML::LibXML supports some functions that are more handy
+to use in the perl environment.
+
+One also has to remember, that XML::LibXML is an interface to libxml2 nodes
+which actually reside on the C-Level of XML::LibXML. This means each node is a
+reference to a structure different than a perl hash or array. The only way to
+access these structure's values is through the DOM interface provided by
+XML::LibXML. This also means, that one I<<<<<< can't >>>>>> simply inherit a XML::LibXML node and add new member variables as they were
+hash keys.
+
+The DOM interface of XML::LibXML does not intend to implement a full DOM
+interface as it is done by XML::GDOME and used for full featured application.
+Moreover, it offers an simple way to build or modify documents that are created
+by XML::LibXML's parser.
+
+Another target of the XML::LibXML interface is to make the interfaces of
+libxml2 available to the perl community. This includes also some workarounds to
+some features where libxml2 assumes more control over the C-Level that most
+perl users don't have.
+
+One of the most important parts of the XML::LibXML DOM interface is, that the
+interfaces try do follow the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>) rather strictly. This means the interface functions are named as the DOM
+specification says and not what widespread Java interfaces claim to be
+standard. Although there are several functions that have only a singular
+interface that conforms to the DOM spec XML::LibXML provides an additional Java
+style alias interface.
+
+Also there are some function interfaces left over from early stages of
+XML::LibXML for compatibility reasons. These interfaces are for compatibility
+reasons I<<<<<< only >>>>>>. They might disappear in one of the future versions of XML::LibXML, so a user
+is requested to switch over to the official functions.
+
+
+=head2 Encodings and XML::LibXML's DOM implementation
+
+See the section on Encodings in the I<<<<<< XML::LibXML >>>>>> manual page.
+
+
+=head2 Namespaces and XML::LibXML's DOM implementation
+
+XML::LibXML's DOM implementation is limited by the DOM implementation of
+libxml2 which treats namespaces slightly differently than required by the DOM
+Level 2 specification.
+
+According to the DOM Level 2 specification, namespaces of elements and
+attributes should be persistent, and nodes should be permanently bound to
+namespace URIs as they get created; it should be possible to manipulate the
+special attributes used for declaring XML namespaces just as other attributes
+without affecting the namespaces of other nodes. In DOM Level 2, the
+application is responsible for creating the special attributes consistently
+and/or for correct serialization of the document.
+
+This is both inconvenient, causes problems in serialization of DOM to XML, and
+most importantly, seems almost impossible to implement over libxml2.
+
+In libxml2, namespace URI and prefix of a node is provided by a pointer to a
+namespace declaration (appearing as a special xmlns attribute in the XML
+document). If the prefix or namespace URI of the declaration changes, the
+prefix and namespace URI of all nodes that point to it changes as well.
+Moreover, in contrast to DOM, a node (element or attribute) can only be bound
+to a namespace URI if there is some namespace declaration in the document to
+point to.
+
+Therefore current DOM implementation in XML::LibXML tries to treat namespace
+declarations in a compromise between reason, common sense, limitations of
+libxml2, and the DOM Level 2 specification.
+
+In XML::LibXML, special attributes declaring XML namespaces are often created
+automatically, usually when a namespaced node is attached to a document and no
+existing declaration of the namespace and prefix is in the scope to be reused.
+In this respect, XML::LibXML DOM implementation differs from the DOM Level 2
+specification according to which special attributes for declaring the
+apropriate XML namespaces should not be added when a node with a namespace
+prefix and namespace URI is created.
+
+Namespace declarations are also created when L<<<<<< XML::LibXML::Document >>>>>>'s createElementNS() or createAttributeNS() function are used. If the a
+namespace is not declared on the documentElement, the namespace will be locally
+declared for the newly created node. In case of Attributes this may look a bit
+confusing, since these nodes cannot have namespace declarations itself. In this
+case the namespace is internally applied to the attribute and later declared on
+the node the attribute is appended to (if required).
+
+The following example may explain this a bit:
+
+
+
+ my $doc = XML::LibXML->createDocument;
+ my $root = $doc->createElementNS( "", "foo" );
+ $doc->setDocumentElement( $root );
+
+ my $attr = $doc->createAttributeNS( "bar", "bar:foo", "test" );
+ $root->setAttributeNodeNS( $attr );
+
+This piece of code will result in the following document:
+
+
+
+ <?xml version="1.0"?>
+ <foo xmlns:bar="bar" bar:foo="test"/>
+
+The namespace is declared on the document element during the
+setAttributeNodeNS() call.
+
+Namespaces can be also declared explicitly by the use of XML::LibXML:Element's
+setNamespace() function. Since 1.61, they can also be manipulated with
+functions setNamespaceDeclPrefix() and setNamespaceDeclURI() (not available in
+DOM). Changing an URI or prefix of an existing namespace declaration affects
+the namespace URI and prefix of all nodes which point to it (that is the nodes
+in its scope).
+
+It is also important to repeat the specification: While working with namespaces
+you should use the namespace aware functions instead of the simplified
+versions. For example you should I<<<<<< never >>>>>> use setAttribute() but setAttributeNS().
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Document.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Document.pod
new file mode 100755
index 00000000000..a4769d992db
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Document.pod
@@ -0,0 +1,696 @@
+=head1 NAME
+
+XML::LibXML::Document - XML::LibXML DOM Document Class
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to Document nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ $dom = XML::LibXML::Document->new( $version, $encoding );
+ $dom = XML::LibXML::Document->createDocument( $version, $encoding );
+ $strURI = $doc->URI();
+ $doc->setURI($strURI);
+ $strEncoding = $doc->encoding();
+ $strEncoding = $doc->actualEncoding();
+ $doc->setEncoding($new_encoding);
+ $strVersion = $doc->version();
+ $doc->standalone
+ $doc->setStandalone($numvalue);
+ my $compression = $doc->compression;
+ $doc->setCompression($ziplevel);
+ $docstring = $dom->toString($format);
+ $c14nstr = $doc->toStringC14N($comment_flag, $xpath [, $xpath_context ]);
+ $ec14nstr = $doc->toStringEC14N($comment_flag, $xpath [, $xpath_context ], $inclusive_prefix_list);
+ $str = $doc->serialize($format);
+ $state = $doc->toFile($filename, $format);
+ $state = $doc->toFH($fh, $format);
+ $str = $document->toStringHTML();
+ $str = $document->serialize_html();
+ $bool = $dom->is_valid();
+ $dom->validate();
+ $root = $dom->documentElement();
+ $dom->setDocumentElement( $root );
+ $element = $dom->createElement( $nodename );
+ $element = $dom->createElementNS( $namespaceURI, $qname );
+ $text = $dom->createTextNode( $content_text );
+ $comment = $dom->createComment( $comment_text );
+ $attrnode = $doc->createAttribute($name [,$value]);
+ $attrnode = $doc->createAttributeNS( namespaceURI, $name [,$value] );
+ $fragment = $doc->createDocumentFragment();
+ $cdata = $dom->create( $cdata_content );
+ my $pi = $doc->createProcessingInstruction( $target, $data );
+ my $entref = $doc->createEntityReference($refname);
+ $dtd = $document->createInternalSubset( $rootnode, $public, $system);
+ $dtd = $document->createExternalSubset( $rootnode_name, $publicId, $systemId);
+ $document->importNode( $node );
+ $document->adoptNode( $node );
+ my $dtd = $doc->externalSubset;
+ my $dtd = $doc->internalSubset;
+ $doc->setExternalSubset($dtd);
+ $doc->setInternalSubset($dtd);
+ my $dtd = $doc->removeExternalSubset();
+ my $dtd = $doc->removeInternalSubset();
+ my @nodelist = $doc->getElementsByTagName($tagname);
+ my @nodelist = $doc->getElementsByTagNameNS($nsURI,$tagname);
+ my @nodelist = $doc->getElementsByLocalName($localname);
+ my $node = $doc->getElementById($id);
+ $dom->indexElements();
+
+=head1 DESCRIPTION
+
+The Document Class is in most cases the result of a parsing process. But
+sometimes it is necessary to create a Document from scratch. The DOM Document
+Class provides functions that conform to the DOM Core naming style.
+
+It inherits all functions from L<<<<<< XML::LibXML::Node >>>>>> as specified in the DOM specification. This enables access to the nodes besides
+the root element on document level - a C<<<<<< DTD >>>>>> for example. The support for these nodes is limited at the moment.
+
+While generally nodes are bound to a document in the DOM concept it is
+suggested that one should always create a node not bound to any document. There
+is no need of really including the node to the document, but once the node is
+bound to a document, it is quite safe that all strings have the correct
+encoding. If an unbound text node with an ISO encoded string is created (e.g.
+with $CLASS->new()), the C<<<<<< toString >>>>>> function may not return the expected result.
+
+To prevent such problems, it is recommended to pass all data to XML::LibXML
+methods as character strings (i.e. UTF-8 encoded, with the UTF8 flag on).
+
+
+=head1 METHODS
+
+Many functions listed here are extensively documented in the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>). Please refer to the specification for extensive documentation.
+
+=over 4
+
+=item new
+
+ $dom = XML::LibXML::Document->new( $version, $encoding );
+
+alias for createDocument()
+
+
+=item createDocument
+
+ $dom = XML::LibXML::Document->createDocument( $version, $encoding );
+
+The constructor for the document class. As Parameter it takes the version
+string and (optionally) the encoding string. Simply calling I<<<<<< createDocument >>>>>>() will create the document:
+
+
+
+ <?xml version="your version" encoding="your encoding"?>
+
+Both parameter are optional. The default value for I<<<<<< $version >>>>>> is C<<<<<< 1.0 >>>>>>, of course. If the I<<<<<< $encoding >>>>>> parameter is not set, the encoding will be left unset, which means UTF-8 is
+implied.
+
+The call of I<<<<<< createDocument >>>>>>() without any parameter will result the following code:
+
+
+
+ <?xml version="1.0"?>
+
+Alternatively one can call this constructor directly from the XML::LibXML class
+level, to avoid some typing. This will not have any effect on the class
+instance, which is always XML::LibXML::Document.
+
+
+
+ my $document = XML::LibXML->createDocument( "1.0", "UTF-8" );
+
+is therefore a shortcut for
+
+
+
+ my $document = XML::LibXML::Document->createDocument( "1.0", "UTF-8" );
+
+
+=item URI
+
+ $strURI = $doc->URI();
+
+Returns the URI (or filename) of the original document. For documents obtained
+by parsing a string of a FH without using the URI parsing argument of the
+corresponding C<<<<<< parse_* >>>>>> function, the result is a generated string unknown-XYZ where XYZ is some
+number; for documents created with the constructor C<<<<<< new >>>>>>, the URI is undefined.
+
+The value can be modified by calling C<<<<<< setURI >>>>>> method on the document node.
+
+
+=item setURI
+
+ $doc->setURI($strURI);
+
+Sets the URI of the document reported by the method URI (see also the URI
+argument to the various C<<<<<< parse_* >>>>>> functions).
+
+
+=item encoding
+
+ $strEncoding = $doc->encoding();
+
+returns the encoding string of the document.
+
+
+
+ my $doc = XML::LibXML->createDocument( "1.0", "ISO-8859-15" );
+ print $doc->encoding; # prints ISO-8859-15
+
+
+=item actualEncoding
+
+ $strEncoding = $doc->actualEncoding();
+
+returns the encoding in which the XML will be returned by $doc->toString().
+This is usually the original encoding of the document as declared in the XML
+declaration and returned by $doc->encoding. If the original encoding is not
+known (e.g. if created in memory or parsed from a XML without a declared
+encoding), 'UTF-8' is returned.
+
+
+
+ my $doc = XML::LibXML->createDocument( "1.0", "ISO-8859-15" );
+ print $doc->encoding; # prints ISO-8859-15
+
+
+=item setEncoding
+
+ $doc->setEncoding($new_encoding);
+
+This method allows to change the declaration of encoding in the XML declaration
+of the document. The value also affects the encoding in which the document is
+serialized to XML by $doc->toString(). Use setEncoding() to remove the encoding
+declaration.
+
+
+=item version
+
+ $strVersion = $doc->version();
+
+returns the version string of the document
+
+I<<<<<< getVersion() >>>>>> is an alternative form of this function.
+
+
+=item standalone
+
+ $doc->standalone
+
+This function returns the Numerical value of a documents XML declarations
+standalone attribute. It returns I<<<<<< 1 >>>>>> if standalone="yes" was found, I<<<<<< 0 >>>>>> if standalone="no" was found and I<<<<<< -1 >>>>>> if standalone was not specified (default on creation).
+
+
+=item setStandalone
+
+ $doc->setStandalone($numvalue);
+
+Through this method it is possible to alter the value of a documents standalone
+attribute. Set it to I<<<<<< 1 >>>>>> to set standalone="yes", to I<<<<<< 0 >>>>>> to set standalone="no" or set it to I<<<<<< -1 >>>>>> to remove the standalone attribute from the XML declaration.
+
+
+=item compression
+
+ my $compression = $doc->compression;
+
+libxml2 allows reading of documents directly from gzipped files. In this case
+the compression variable is set to the compression level of that file (0-8). If
+XML::LibXML parsed a different source or the file wasn't compressed, the
+returned value will be I<<<<<< -1 >>>>>>.
+
+
+=item setCompression
+
+ $doc->setCompression($ziplevel);
+
+If one intends to write the document directly to a file, it is possible to set
+the compression level for a given document. This level can be in the range from
+0 to 8. If XML::LibXML should not try to compress use I<<<<<< -1 >>>>>> (default).
+
+Note that this feature will I<<<<<< only >>>>>> work if libxml2 is compiled with zlib support and toFile() is used for output.
+
+
+=item toString
+
+ $docstring = $dom->toString($format);
+
+I<<<<<< toString >>>>>> is a DOM serializing function, so the DOM Tree is serialized into a XML string,
+ready for output.
+
+IMPORTANT: unlike toString for other nodes, on document nodes this function
+returns the XML as a byte string in the original encoding of the document (see
+the actualEncoding() method)! This means you can simply do:
+
+
+
+ open OUT, $file;
+ print OUT $doc->toString;
+
+regardless of the actual encoding of the document. See the section on encodings
+in L<<<<<< XML::LibXML >>>>>> for more details.
+
+The optional I<<<<<< $format >>>>>> parameter sets the indenting of the output. This parameter is expected to be an C<<<<<< integer >>>>>> value, that specifies that indentation should be used. The format parameter can
+have three different values if it is used:
+
+If $format is 0, than the document is dumped as it was originally parsed
+
+If $format is 1, libxml2 will add ignorable white spaces, so the nodes content
+is easier to read. Existing text nodes will not be altered
+
+If $format is 2 (or higher), libxml2 will act as $format == 1 but it add a
+leading and a trailing line break to each text node.
+
+libxml2 uses a hard-coded indentation of 2 space characters per indentation
+level. This value can not be altered on run-time.
+
+
+=item toStringC14N
+
+ $c14nstr = $doc->toStringC14N($comment_flag, $xpath [, $xpath_context ]);
+
+See the documentation in L<<<<<< XML::LibXML::Node >>>>>>.
+
+
+=item toStringEC14N
+
+ $ec14nstr = $doc->toStringEC14N($comment_flag, $xpath [, $xpath_context ], $inclusive_prefix_list);
+
+See the documentation in L<<<<<< XML::LibXML::Node >>>>>>.
+
+
+=item serialize
+
+ $str = $doc->serialize($format);
+
+An alias for toString(). This function was name added to be more consistent
+with libxml2.
+
+
+=item serialize_c14n
+
+An alias for toStringC14N().
+
+
+=item serialize_exc_c14n
+
+An alias for toStringEC14N().
+
+
+=item toFile
+
+ $state = $doc->toFile($filename, $format);
+
+This function is similar to toString(), but it writes the document directly
+into a filesystem. This function is very useful, if one needs to store large
+documents.
+
+The format parameter has the same behaviour as in toString().
+
+
+=item toFH
+
+ $state = $doc->toFH($fh, $format);
+
+This function is similar to toString(), but it writes the document directly to
+a filehandle or a stream. A byte stream in the document encoding is passed to
+the file handle. Do NOT apply any C<<<<<< :encoding(...) >>>>>> or C<<<<<< :utf8 >>>>>> PerlIO layer to the filehandle! See the section on encodings in L<<<<<< XML::LibXML >>>>>> for more details.
+
+The format parameter has the same behaviour as in toString().
+
+
+=item toStringHTML
+
+ $str = $document->toStringHTML();
+
+I<<<<<< toStringHTML >>>>>> serialize the tree to a byte string in the document encoding as HTML. With this
+method indenting is automatic and managed by libxml2 internally.
+
+
+=item serialize_html
+
+ $str = $document->serialize_html();
+
+An alias for toStringHTML().
+
+
+=item is_valid
+
+ $bool = $dom->is_valid();
+
+Returns either TRUE or FALSE depending on whether the DOM Tree is a valid
+Document or not.
+
+You may also pass in a L<<<<<< XML::LibXML::Dtd >>>>>> object, to validate against an external DTD:
+
+
+
+ if (!$dom->is_valid($dtd)) {
+ warn("document is not valid!");
+ }
+
+
+=item validate
+
+ $dom->validate();
+
+This is an exception throwing equivalent of is_valid. If the document is not
+valid it will throw an exception containing the error. This allows you much
+better error reporting than simply is_valid or not.
+
+Again, you may pass in a DTD object
+
+
+=item documentElement
+
+ $root = $dom->documentElement();
+
+Returns the root element of the Document. A document can have just one root
+element to contain the documents data.
+
+Optionally one can use I<<<<<< getDocumentElement >>>>>>.
+
+
+=item setDocumentElement
+
+ $dom->setDocumentElement( $root );
+
+This function enables you to set the root element for a document. The function
+supports the import of a node from a different document tree, but does not
+support a document fragment as $root.
+
+
+=item createElement
+
+ $element = $dom->createElement( $nodename );
+
+This function creates a new Element Node bound to the DOM with the name C<<<<<< $nodename >>>>>>.
+
+
+=item createElementNS
+
+ $element = $dom->createElementNS( $namespaceURI, $qname );
+
+This function creates a new Element Node bound to the DOM with the name C<<<<<< $nodename >>>>>> and placed in the given namespace.
+
+
+=item createTextNode
+
+ $text = $dom->createTextNode( $content_text );
+
+As an equivalent of I<<<<<< createElement >>>>>>, but it creates a I<<<<<< Text Node >>>>>> bound to the DOM.
+
+
+=item createComment
+
+ $comment = $dom->createComment( $comment_text );
+
+As an equivalent of I<<<<<< createElement >>>>>>, but it creates a I<<<<<< Comment Node >>>>>> bound to the DOM.
+
+
+=item createAttribute
+
+ $attrnode = $doc->createAttribute($name [,$value]);
+
+Creates a new Attribute node.
+
+
+=item createAttributeNS
+
+ $attrnode = $doc->createAttributeNS( namespaceURI, $name [,$value] );
+
+Creates an Attribute bound to a namespace.
+
+
+=item createDocumentFragment
+
+ $fragment = $doc->createDocumentFragment();
+
+This function creates a DocumentFragment.
+
+
+=item createCDATASection
+
+ $cdata = $dom->create( $cdata_content );
+
+Similar to createTextNode and createComment, this function creates a
+CDataSection bound to the current DOM.
+
+
+=item createProcessingInstruction
+
+ my $pi = $doc->createProcessingInstruction( $target, $data );
+
+create a processing instruction node.
+
+Since this method is quite long one may use its short form I<<<<<< createPI() >>>>>>.
+
+
+=item createEntityReference
+
+ my $entref = $doc->createEntityReference($refname);
+
+If a document has a DTD specified, one can create entity references by using
+this function. If one wants to add a entity reference to the document, this
+reference has to be created by this function.
+
+An entity reference is unique to a document and cannot be passed to other
+documents as other nodes can be passed.
+
+I<<<<<< NOTE: >>>>>> A text content containing something that looks like an entity reference, will
+not be expanded to a real entity reference unless it is a predefined entity
+
+
+
+ my $string = "&foo;";
+ $some_element->appendText( $string );
+ print $some_element->textContent; # prints "&amp;foo;"
+
+
+=item createInternalSubset
+
+ $dtd = $document->createInternalSubset( $rootnode, $public, $system);
+
+This function creates and adds an internal subset to the given document.
+Because the function automatically adds the DTD to the document there is no
+need to add the created node explicitly to the document.
+
+
+
+ my $document = XML::LibXML::Document->new();
+ my $dtd = $document->createInternalSubset( "foo", undef, "foo.dtd" );
+
+will result in the following XML document:
+
+
+
+ <?xml version="1.0"?>
+ <!DOCTYPE foo SYSTEM "foo.dtd">
+
+By setting the public parameter it is possible to set PUBLIC DTDs to a given
+document. So
+
+
+
+ my $document = XML::LibXML::Document->new();
+ my $dtd = $document->createInternalSubset( "foo", "-//FOO//DTD FOO 0.1//EN", undef );
+
+will cause the following declaration to be created on the document:
+
+
+
+ <?xml version="1.0"?>
+ <!DOCTYPE foo PUBLIC "-//FOO//DTD FOO 0.1//EN">
+
+
+=item createExternalSubset
+
+ $dtd = $document->createExternalSubset( $rootnode_name, $publicId, $systemId);
+
+This function is similar to C<<<<<< createInternalSubset() >>>>>> but this DTD is considered to be external and is therefore not added to the
+document itself. Nevertheless it can be used for validation purposes.
+
+
+=item importNode
+
+ $document->importNode( $node );
+
+If a node is not part of a document, it can be imported to another document. As
+specified in DOM Level 2 Specification the Node will not be altered or removed
+from its original document (C<<<<<< $node->cloneNode(1) >>>>>> will get called implicitly).
+
+I<<<<<< NOTE: >>>>>> Don't try to use importNode() to import sub-trees that contain an entity
+reference - even if the entity reference is the root node of the sub-tree. This
+will cause serious problems to your program. This is a limitation of libxml2
+and not of XML::LibXML itself.
+
+
+=item adoptNode
+
+ $document->adoptNode( $node );
+
+If a node is not part of a document, it can be imported to another document. As
+specified in DOM Level 3 Specification the Node will not be altered but it will
+removed from its original document.
+
+After a document adopted a node, the node, its attributes and all its
+descendants belong to the new document. Because the node does not belong to the
+old document, it will be unlinked from its old location first.
+
+I<<<<<< NOTE: >>>>>> Don't try to adoptNode() to import sub-trees that contain entity references -
+even if the entity reference is the root node of the sub-tree. This will cause
+serious problems to your program. This is a limitation of libxml2 and not of
+XML::LibXML itself.
+
+
+=item externalSubset
+
+ my $dtd = $doc->externalSubset;
+
+If a document has an external subset defined it will be returned by this
+function.
+
+I<<<<<< NOTE >>>>>> Dtd nodes are no ordinary nodes in libxml2. The support for these nodes in
+XML::LibXML is still limited. In particular one may not want use common node
+function on doctype declaration nodes!
+
+
+=item internalSubset
+
+ my $dtd = $doc->internalSubset;
+
+If a document has an internal subset defined it will be returned by this
+function.
+
+I<<<<<< NOTE >>>>>> Dtd nodes are no ordinary nodes in libxml2. The support for these nodes in
+XML::LibXML is still limited. In particular one may not want use common node
+function on doctype declaration nodes!
+
+
+=item setExternalSubset
+
+ $doc->setExternalSubset($dtd);
+
+I<<<<<< EXPERIMENTAL! >>>>>>
+
+This method sets a DTD node as an external subset of the given document.
+
+
+=item setInternalSubset
+
+ $doc->setInternalSubset($dtd);
+
+I<<<<<< EXPERIMENTAL! >>>>>>
+
+This method sets a DTD node as an internal subset of the given document.
+
+
+=item removeExternalSubset
+
+ my $dtd = $doc->removeExternalSubset();
+
+I<<<<<< EXPERIMENTAL! >>>>>>
+
+If a document has an external subset defined it can be removed from the
+document by using this function. The removed dtd node will be returned.
+
+
+=item removeInternalSubset
+
+ my $dtd = $doc->removeInternalSubset();
+
+I<<<<<< EXPERIMENTAL! >>>>>>
+
+If a document has an internal subset defined it can be removed from the
+document by using this function. The removed dtd node will be returned.
+
+
+=item getElementsByTagName
+
+ my @nodelist = $doc->getElementsByTagName($tagname);
+
+Implements the DOM Level 2 function
+
+In SCALAR context this function returns a L<<<<<< XML::LibXML::NodeList >>>>>> object.
+
+
+=item getElementsByTagNameNS
+
+ my @nodelist = $doc->getElementsByTagNameNS($nsURI,$tagname);
+
+Implements the DOM Level 2 function
+
+In SCALAR context this function returns a L<<<<<< XML::LibXML::NodeList >>>>>> object.
+
+
+=item getElementsByLocalName
+
+ my @nodelist = $doc->getElementsByLocalName($localname);
+
+This allows the fetching of all nodes from a given document with the given
+Localname.
+
+In SCALAR context this function returns a L<<<<<< XML::LibXML::NodeList >>>>>> object.
+
+
+=item getElementById
+
+ my $node = $doc->getElementById($id);
+
+Returns the element that has an ID attribute with the given value. If no such
+element exists, this returns undef.
+
+Note: the ID of an element may change while manipulating the document. For
+documents with a DTD, the information about ID attributes is only available if
+DTD loading/validation has been requested. For HTML documents parsed with the
+HTML parser ID detection is done automatically. In XML documents, all "xml:id"
+attributes are considered to be of type ID. You can test ID-ness of an
+attribute node with $attr->isId().
+
+In versions 1.59 and earlier this method was called getElementsById() (plural)
+by mistake. Starting from 1.60 this name is maintained as an alias only for
+backward compatibility.
+
+
+=item indexElements
+
+ $dom->indexElements();
+
+This function causes libxml2 to stamp all elements in a document with their
+document position index which considerably speeds up XPath queries for large
+documents. It should only be used with static documents that won't be further
+changed by any DOM methods, because once a document is indexed, XPath will
+always prefer the index to other methods of determining the document order of
+nodes. XPath could therefore return improperly ordered node-lists when applied
+on a document that has been changed after being indexed. It is of course
+possible to use this method to re-index a modified document before using it
+with XPath again. This function is not a part of the DOM specification.
+
+This function returns number of elements indexed, -1 if error occurred, or -2
+if this feature is not available in the running libxml2.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/DocumentFragment.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/DocumentFragment.pod
new file mode 100755
index 00000000000..fb21235c117
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/DocumentFragment.pod
@@ -0,0 +1,40 @@
+=head1 NAME
+
+XML::LibXML::DocumentFragment - XML::LibXML's DOM L2 Document Fragment Implementation
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+
+
+=head1 DESCRIPTION
+
+This class is a helper class as described in the DOM Level 2 Specification. It
+is implemented as a node without name. All adding, inserting or replacing
+functions are aware of document fragments now.
+
+As well I<<<<<< all >>>>>> unbound nodes (all nodes that do not belong to any document sub-tree) are
+implicit members of document fragments.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Dtd.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Dtd.pod
new file mode 100755
index 00000000000..d0b29904c23
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Dtd.pod
@@ -0,0 +1,102 @@
+=head1 NAME
+
+XML::LibXML::Dtd - XML::LibXML DTD Handling
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+
+ $dtd = XML::LibXML::Dtd->new($public_id, $system_id);
+ $dtd = XML::LibXML::Dtd->parse_string($dtd_str);
+ $publicId = $dtd->getName();
+ $publicId = $dtd->publicId();
+ $systemId = $dtd->systemId();
+
+=head1 DESCRIPTION
+
+This class holds a DTD. You may parse a DTD from either a string, or from an
+external SYSTEM identifier.
+
+No support is available as yet for parsing from a filehandle.
+
+XML::LibXML::Dtd is a sub-class of L<<<<<< XML::LibXML::Node >>>>>>, so all the methods available to nodes (particularly toString()) are available
+to Dtd objects.
+
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ $dtd = XML::LibXML::Dtd->new($public_id, $system_id);
+
+Parse a DTD from the system identifier, and return a DTD object that you can
+pass to $doc->is_valid() or $doc->validate().
+
+
+
+ my $dtd = XML::LibXML::Dtd->new(
+ "SOME // Public / ID / 1.0",
+ "test.dtd"
+ );
+ my $doc = XML::LibXML->new->parse_file("test.xml");
+ $doc->validate($dtd);
+
+
+=item parse_string
+
+ $dtd = XML::LibXML::Dtd->parse_string($dtd_str);
+
+The same as new() above, except you can parse a DTD from a string. Note that
+parsing from string may fail if the DTD contains external parametric-entity
+references with relative URLs.
+
+
+=item getName
+
+ $publicId = $dtd->getName();
+
+Returns the name of DTD; i.e., the name immediately following the DOCTYPE
+keyword.
+
+
+=item publicId
+
+ $publicId = $dtd->publicId();
+
+Returns the public identifier of the external subset.
+
+
+=item systemId
+
+ $systemId = $dtd->systemId();
+
+Returns the system identifier of the external subset.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Element.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Element.pod
new file mode 100755
index 00000000000..b938c25d78c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Element.pod
@@ -0,0 +1,384 @@
+=head1 NAME
+
+XML::LibXML::Element - XML::LibXML Class for Element Nodes
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to Element nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ $node = XML::LibXML::Element->new( $name );
+ $node->setAttribute( $aname, $avalue );
+ $node->setAttributeNS( $nsURI, $aname, $avalue );
+ $avalue = $node->getAttribute( $aname );
+ $avalue = $node->setAttributeNS( $nsURI, $aname );
+ $attrnode = $node->getAttributeNode( $aname );
+ $attrnode = $node->getAttributeNodeNS( $namespaceURI, $aname );
+ $node->removeAttribute( $aname );
+ $node->removeAttributeNS( $nsURI, $aname );
+ $boolean = $node->hasAttribute( $aname );
+ $boolean = $node->hasAttributeNS( $nsURI, $aname );
+ @nodes = $node->getChildrenByTagName($tagname);
+ @nodes = $node->getChildrenByTagNameNS($nsURI,$tagname);
+ @nodes = $node->getChildrenByLocalName($localname);
+ @nodes = $node->getElementsByTagName($tagname);
+ @nodes = $node->getElementsByTagNameNS($nsURI,$localname);
+ @nodes = $node->getElementsByLocalName($localname);
+ $node->appendWellBalancedChunk( $chunk );
+ $node->appendText( $PCDATA );
+ $node->appendTextNode( $PCDATA );
+ $node->appendTextChild( $childname , $PCDATA );
+ $node->setNamespace( $nsURI , $nsPrefix, $activate );
+ $node->setNamespaceDeclURI( $nsPrefix, $newURI );
+ $node->setNamespaceDeclPrefix( $oldPrefix, $newPrefix );
+
+=head1 METHODS
+
+The class inherits from L<<<<<< XML::LibXML::Node >>>>>>. The documentation for Inherited methods is not listed here.
+
+Many functions listed here are extensively documented in the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>). Please refer to the specification for extensive documentation.
+
+=over 4
+
+=item new
+
+ $node = XML::LibXML::Element->new( $name );
+
+This function creates a new node unbound to any DOM.
+
+
+=item setAttribute
+
+ $node->setAttribute( $aname, $avalue );
+
+This method sets or replaces the node's attribute C<<<<<< $aname >>>>>> to the value C<<<<<< $avalue >>>>>>
+
+
+=item setAttributeNS
+
+ $node->setAttributeNS( $nsURI, $aname, $avalue );
+
+Namespace-aware version of C<<<<<< setAttribute >>>>>>, where C<<<<<< $nsURI >>>>>> is a namespace URI, C<<<<<< $aname >>>>>> is a qualified name, and C<<<<<< $avalue >>>>>> is the value. The namespace URI may be null (empty or undefined) in order to
+create an attribute which has no namespace.
+
+The current implementation differs from DOM in the following aspects
+
+If an attribute with the same local name and namespace URI already exists on
+the element, but its prefix differs from the prefix of C<<<<<< $aname >>>>>>, then this function is supposed to change the prefix (regardless of namespace
+declarations and possible collisions). However, the current implementation does
+rather the opposite. If a prefix is declared for the namespace URI in the scope
+of the attribute, then the already declared prefix is used, disregarding the
+prefix specified in C<<<<<< $aname >>>>>>. If no prefix is declared for the namespace, the function tries to declare the
+prefix specified in C<<<<<< $aname >>>>>> and dies if the prefix is already taken by some other namespace.
+
+According to DOM Level 2 specification, this method can also be used to create
+or modify special attributes used for declaring XML namespaces (which belong to
+the namespace "http://www.w3.org/2000/xmlns/" and have prefix or name "xmlns").
+This should work since version 1.61, but again the implementation differs from
+DOM specification in the following: if a declaration of the same namespace
+prefix already exists on the element, then changing its value via this method
+automatically changes the namespace of all elements and attributes in its
+scope. This is because in libxml2 the namespace URI of an element is not static
+but is computed from a pointer to a namespace declaration attribute.
+
+
+=item getAttribute
+
+ $avalue = $node->getAttribute( $aname );
+
+If C<<<<<< $node >>>>>> has an attribute with the name C<<<<<< $aname >>>>>>, the value of this attribute will get returned.
+
+
+=item getAttributeNS
+
+ $avalue = $node->setAttributeNS( $nsURI, $aname );
+
+Retrieves an attribute value by local name and namespace URI.
+
+
+=item getAttributeNode
+
+ $attrnode = $node->getAttributeNode( $aname );
+
+Retrieve an attribute node by name. If no attribute with a given name exists, C<<<<<< undef >>>>>> is returned.
+
+
+=item getAttributeNodeNS
+
+ $attrnode = $node->getAttributeNodeNS( $namespaceURI, $aname );
+
+Retrieves an attribute node by local name and namespace URI. If no attribute
+with a given localname and namespace exists, C<<<<<< undef >>>>>> is returned.
+
+
+=item removeAttribute
+
+ $node->removeAttribute( $aname );
+
+The method removes the attribute C<<<<<< $aname >>>>>> from the node's attribute list, if the attribute can be found.
+
+
+=item removeAttributeNS
+
+ $node->removeAttributeNS( $nsURI, $aname );
+
+Namespace version of C<<<<<< removeAttribute >>>>>>
+
+
+=item hasAttribute
+
+ $boolean = $node->hasAttribute( $aname );
+
+This function tests if the named attribute is set for the node. If the
+attribute is specified, TRUE (1) will be returned, otherwise the return value
+is FALSE (0).
+
+
+=item hasAttributeNS
+
+ $boolean = $node->hasAttributeNS( $nsURI, $aname );
+
+namespace version of C<<<<<< hasAttribute >>>>>>
+
+
+=item getChildrenByTagName
+
+ @nodes = $node->getChildrenByTagName($tagname);
+
+The function gives direct access to all child elements of the current node with
+a given tagname, where tagname is a qualified name, that is, in case of
+namespace usage it may consist of a prefix and local name. This function makes
+things a lot easier if one needs to handle big data sets. A special tagname '*'
+can be used to match any name.
+
+If this function is called in SCALAR context, it returns the number of elements
+found.
+
+
+=item getChildrenByTagNameNS
+
+ @nodes = $node->getChildrenByTagNameNS($nsURI,$tagname);
+
+Namespace version of C<<<<<< getChildrenByTagName >>>>>>. A special nsURI '*' matches any namespace URI, in which case the function
+behaves just like C<<<<<< getChildrenByLocalName >>>>>>.
+
+If this function is called in SCALAR context, it returns the number of elements
+found.
+
+
+=item getChildrenByLocalName
+
+ @nodes = $node->getChildrenByLocalName($localname);
+
+The function gives direct access to all child elements of the current node with
+a given local name. It makes things a lot easier if one needs to handle big
+data sets. A special C<<<<<< localname >>>>>> '*' can be used to match any local name.
+
+If this function is called in SCALAR context, it returns the number of elements
+found.
+
+
+=item getElementsByTagName
+
+ @nodes = $node->getElementsByTagName($tagname);
+
+This function is part of the spec. It fetches all descendants of a node with a
+given tagname, where C<<<<<< tagname >>>>>> is a qualified name, that is, in case of namespace usage it may consist of a
+prefix and local name. A special C<<<<<< tagname >>>>>> '*' can be used to match any tag name.
+
+In SCALAR context this function returns a L<<<<<< XML::LibXML::NodeList >>>>>> object.
+
+
+=item getElementsByTagNameNS
+
+ @nodes = $node->getElementsByTagNameNS($nsURI,$localname);
+
+Namespace version of C<<<<<< getElementsByTagName >>>>>> as found in the DOM spec. A special C<<<<<< localname >>>>>> '*' can be used to match any local name and C<<<<<< nsURI >>>>>> '*' can be used to match any namespace URI.
+
+In SCALAR context this function returns a L<<<<<< XML::LibXML::NodeList >>>>>> object.
+
+
+=item getElementsByLocalName
+
+ @nodes = $node->getElementsByLocalName($localname);
+
+This function is not found in the DOM specification. It is a mix of
+getElementsByTagName and getElementsByTagNameNS. It will fetch all tags
+matching the given local-name. This allows one to select tags with the same
+local name across namespace borders.
+
+In SCALAR context this function returns a L<<<<<< XML::LibXML::NodeList >>>>>> object.
+
+
+=item appendWellBalancedChunk
+
+ $node->appendWellBalancedChunk( $chunk );
+
+Sometimes it is necessary to append a string coded XML Tree to a node. I<<<<<< appendWellBalancedChunk >>>>>> will do the trick for you. But this is only done if the String is C<<<<<< well-balanced >>>>>>.
+
+I<<<<<< Note that appendWellBalancedChunk() is only left for compatibility reasons >>>>>>. Implicitly it uses
+
+
+
+ my $fragment = $parser->parse_xml_chunk( $chunk );
+ $node->appendChild( $fragment );
+
+This form is more explicit and makes it easier to control the flow of a script.
+
+
+=item appendText
+
+ $node->appendText( $PCDATA );
+
+alias for appendTextNode().
+
+
+=item appendTextNode
+
+ $node->appendTextNode( $PCDATA );
+
+This wrapper function lets you add a string directly to an element node.
+
+
+=item appendTextChild
+
+ $node->appendTextChild( $childname , $PCDATA );
+
+Somewhat similar with C<<<<<< appendTextNode >>>>>>: It lets you set an Element, that contains only a C<<<<<< text node >>>>>> directly by specifying the name and the text content.
+
+
+=item setNamespace
+
+ $node->setNamespace( $nsURI , $nsPrefix, $activate );
+
+setNamespace() allows one to apply a namespace to an element. The function
+takes three parameters: 1. the namespace URI, which is required and the two
+optional values prefix, which is the namespace prefix, as it should be used in
+child elements or attributes as well as the additional activate parameter. If
+prefix is not given, undefined or empty, this function tries to create a
+declaration of the default namespace.
+
+The activate parameter is most useful: If this parameter is set to FALSE (0), a
+new namespace declaration is simply added to the element while the element's
+namespace itself is not altered. Nevertheless, activate is set to TRUE (1) on
+default. In this case the namespace is used as the node's effective namespace.
+This means the namespace prefix is added to the node name and if there was a
+namespace already active for the node, it will be replaced (but its declaration
+is not removed from the document). A new namespace declaration is only created
+if necessary (that is, if the element is already in the scope of a namespace
+declaration associating the prefix with the namespace URI, then this
+declaration is reused).
+
+The following example may clarify this:
+
+
+
+ my $e1 = $doc->createElement("bar");
+ $e1->setNamespace("http://foobar.org", "foo")
+
+results
+
+
+
+ <foo:bar xmlns:foo="http://foobar.org"/>
+
+while
+
+
+
+ my $e2 = $doc->createElement("bar");
+ $e2->setNamespace("http://foobar.org", "foo",0)
+
+results only
+
+
+
+ <bar xmlns:foo="http://foobar.org"/>
+
+By using $activate == 0 it is possible to create multiple namespace
+declarations on a single element.
+
+The function fails if it is required to create a declaration associating the
+prefix with the namespace URI but the element already carries a declaration
+with the same prefix but different namespace URI.
+
+
+=item setNamespaceDeclURI
+
+ $node->setNamespaceDeclURI( $nsPrefix, $newURI );
+
+EXPERIMENTAL IN 1.61 !
+
+This function manipulates directly with an existing namespace declaration on an
+element. It takes two parameters: the prefix by which it looks up the namespace
+declaration and a new namespace URI which replaces its previous value.
+
+It returns 1 if the namespace declaration was found and changed, 0 otherwise.
+
+All elements and attributes (even those previously unbound from the document)
+for which the namespace declaration determines their namespace belong to the
+new namespace after the change.
+
+If the new URI is undef or empty, the nodes have no namespace and no prefix
+after the change. Namespace declarations once nulled in this way do not further
+appear in the serialized output (but do remain in the document for internal
+integrity of libxml2 data structures).
+
+This function is NOT part of any DOM API.
+
+
+=item setNamespaceDeclPrefix
+
+ $node->setNamespaceDeclPrefix( $oldPrefix, $newPrefix );
+
+EXPERIMENTAL IN 1.61 !
+
+This function manipulates directly with an existing namespace declaration on an
+element. It takes two parameters: the old prefix by which it looks up the
+namespace declaration and a new prefix which is to replace the old one.
+
+The function dies with an error if the element is in the scope of another
+declaration whose prefix equals to the new prefix, or if the change should
+result in a declaration with a non-empty prefix but empty namespace URI.
+Otherwise, it returns 1 if the namespace declaration was found and changed and
+0 if not found.
+
+All elements and attributes (even those previously unbound from the document)
+for which the namespace declaration determines their namespace change their
+prefix to the new value.
+
+If the new prefix is undef or empty, the namespace declaration becomes a
+declaration of a default namespace. The corresponding nodes drop their
+namespace prefix (but remain in the, now default, namespace). In this case the
+function fails, if the containing element is in the scope of another default
+namespace declaration.
+
+This function is NOT part of any DOM API.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pm
new file mode 100755
index 00000000000..0e120ab8abe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pm
@@ -0,0 +1,500 @@
+# $Id: ErrNo.pm,v 1.1.2.1 2004/04/20 20:09:48 pajas Exp $
+#
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::ErrNo;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use constant ERR_OK => 0;
+use constant ERR_INTERNAL_ERROR => 1;
+use constant ERR_NO_MEMORY => 2;
+use constant ERR_DOCUMENT_START => 3;
+use constant ERR_DOCUMENT_EMPTY => 4;
+use constant ERR_DOCUMENT_END => 5;
+use constant ERR_INVALID_HEX_CHARREF => 6;
+use constant ERR_INVALID_DEC_CHARREF => 7;
+use constant ERR_INVALID_CHARREF => 8;
+use constant ERR_INVALID_CHAR => 9;
+use constant ERR_CHARREF_AT_EOF => 10;
+use constant ERR_CHARREF_IN_PROLOG => 11;
+use constant ERR_CHARREF_IN_EPILOG => 12;
+use constant ERR_CHARREF_IN_DTD => 13;
+use constant ERR_ENTITYREF_AT_EOF => 14;
+use constant ERR_ENTITYREF_IN_PROLOG => 15;
+use constant ERR_ENTITYREF_IN_EPILOG => 16;
+use constant ERR_ENTITYREF_IN_DTD => 17;
+use constant ERR_PEREF_AT_EOF => 18;
+use constant ERR_PEREF_IN_PROLOG => 19;
+use constant ERR_PEREF_IN_EPILOG => 20;
+use constant ERR_PEREF_IN_INT_SUBSET => 21;
+use constant ERR_ENTITYREF_NO_NAME => 22;
+use constant ERR_ENTITYREF_SEMICOL_MISSING => 23;
+use constant ERR_PEREF_NO_NAME => 24;
+use constant ERR_PEREF_SEMICOL_MISSING => 25;
+use constant ERR_UNDECLARED_ENTITY => 26;
+use constant WAR_UNDECLARED_ENTITY => 27;
+use constant ERR_UNPARSED_ENTITY => 28;
+use constant ERR_ENTITY_IS_EXTERNAL => 29;
+use constant ERR_ENTITY_IS_PARAMETER => 30;
+use constant ERR_UNKNOWN_ENCODING => 31;
+use constant ERR_UNSUPPORTED_ENCODING => 32;
+use constant ERR_STRING_NOT_STARTED => 33;
+use constant ERR_STRING_NOT_CLOSED => 34;
+use constant ERR_NS_DECL_ERROR => 35;
+use constant ERR_ENTITY_NOT_STARTED => 36;
+use constant ERR_ENTITY_NOT_FINISHED => 37;
+use constant ERR_LT_IN_ATTRIBUTE => 38;
+use constant ERR_ATTRIBUTE_NOT_STARTED => 39;
+use constant ERR_ATTRIBUTE_NOT_FINISHED => 40;
+use constant ERR_ATTRIBUTE_WITHOUT_VALUE => 41;
+use constant ERR_ATTRIBUTE_REDEFINED => 42;
+use constant ERR_LITERAL_NOT_STARTED => 43;
+use constant ERR_LITERAL_NOT_FINISHED => 44;
+use constant ERR_COMMENT_NOT_FINISHED => 45;
+use constant ERR_PI_NOT_STARTED => 46;
+use constant ERR_PI_NOT_FINISHED => 47;
+use constant ERR_NOTATION_NOT_STARTED => 48;
+use constant ERR_NOTATION_NOT_FINISHED => 49;
+use constant ERR_ATTLIST_NOT_STARTED => 50;
+use constant ERR_ATTLIST_NOT_FINISHED => 51;
+use constant ERR_MIXED_NOT_STARTED => 52;
+use constant ERR_MIXED_NOT_FINISHED => 53;
+use constant ERR_ELEMCONTENT_NOT_STARTED => 54;
+use constant ERR_ELEMCONTENT_NOT_FINISHED => 55;
+use constant ERR_XMLDECL_NOT_STARTED => 56;
+use constant ERR_XMLDECL_NOT_FINISHED => 57;
+use constant ERR_CONDSEC_NOT_STARTED => 58;
+use constant ERR_CONDSEC_NOT_FINISHED => 59;
+use constant ERR_EXT_SUBSET_NOT_FINISHED => 60;
+use constant ERR_DOCTYPE_NOT_FINISHED => 61;
+use constant ERR_MISPLACED_CDATA_END => 62;
+use constant ERR_CDATA_NOT_FINISHED => 63;
+use constant ERR_RESERVED_XML_NAME => 64;
+use constant ERR_SPACE_REQUIRED => 65;
+use constant ERR_SEPARATOR_REQUIRED => 66;
+use constant ERR_NMTOKEN_REQUIRED => 67;
+use constant ERR_NAME_REQUIRED => 68;
+use constant ERR_PCDATA_REQUIRED => 69;
+use constant ERR_URI_REQUIRED => 70;
+use constant ERR_PUBID_REQUIRED => 71;
+use constant ERR_LT_REQUIRED => 72;
+use constant ERR_GT_REQUIRED => 73;
+use constant ERR_LTSLASH_REQUIRED => 74;
+use constant ERR_EQUAL_REQUIRED => 75;
+use constant ERR_TAG_NAME_MISMATCH => 76;
+use constant ERR_TAG_NOT_FINISHED => 77;
+use constant ERR_STANDALONE_VALUE => 78;
+use constant ERR_ENCODING_NAME => 79;
+use constant ERR_HYPHEN_IN_COMMENT => 80;
+use constant ERR_INVALID_ENCODING => 81;
+use constant ERR_EXT_ENTITY_STANDALONE => 82;
+use constant ERR_CONDSEC_INVALID => 83;
+use constant ERR_VALUE_REQUIRED => 84;
+use constant ERR_NOT_WELL_BALANCED => 85;
+use constant ERR_EXTRA_CONTENT => 86;
+use constant ERR_ENTITY_CHAR_ERROR => 87;
+use constant ERR_ENTITY_PE_INTERNAL => 88;
+use constant ERR_ENTITY_LOOP => 89;
+use constant ERR_ENTITY_BOUNDARY => 90;
+use constant ERR_INVALID_URI => 91;
+use constant ERR_URI_FRAGMENT => 92;
+use constant WAR_CATALOG_PI => 93;
+use constant ERR_NO_DTD => 94;
+use constant ERR_CONDSEC_INVALID_KEYWORD => 95;
+use constant ERR_VERSION_MISSING => 96;
+use constant WAR_UNKNOWN_VERSION => 97;
+use constant WAR_LANG_VALUE => 98;
+use constant WAR_NS_URI => 99;
+use constant WAR_NS_URI_RELATIVE => 100;
+use constant NS_ERR_XML_NAMESPACE => 200;
+use constant NS_ERR_UNDEFINED_NAMESPACE => 201;
+use constant NS_ERR_QNAME => 202;
+use constant NS_ERR_ATTRIBUTE_REDEFINED => 203;
+use constant DTD_ATTRIBUTE_DEFAULT => 500;
+use constant DTD_ATTRIBUTE_REDEFINED => 501;
+use constant DTD_ATTRIBUTE_VALUE => 502;
+use constant DTD_CONTENT_ERROR => 503;
+use constant DTD_CONTENT_MODEL => 504;
+use constant DTD_CONTENT_NOT_DETERMINIST => 505;
+use constant DTD_DIFFERENT_PREFIX => 506;
+use constant DTD_ELEM_DEFAULT_NAMESPACE => 507;
+use constant DTD_ELEM_NAMESPACE => 508;
+use constant DTD_ELEM_REDEFINED => 509;
+use constant DTD_EMPTY_NOTATION => 510;
+use constant DTD_ENTITY_TYPE => 511;
+use constant DTD_ID_FIXED => 512;
+use constant DTD_ID_REDEFINED => 513;
+use constant DTD_ID_SUBSET => 514;
+use constant DTD_INVALID_CHILD => 515;
+use constant DTD_INVALID_DEFAULT => 516;
+use constant DTD_LOAD_ERROR => 517;
+use constant DTD_MISSING_ATTRIBUTE => 518;
+use constant DTD_MIXED_CORRUPT => 519;
+use constant DTD_MULTIPLE_ID => 520;
+use constant DTD_NO_DOC => 521;
+use constant DTD_NO_DTD => 522;
+use constant DTD_NO_ELEM_NAME => 523;
+use constant DTD_NO_PREFIX => 524;
+use constant DTD_NO_ROOT => 525;
+use constant DTD_NOTATION_REDEFINED => 526;
+use constant DTD_NOTATION_VALUE => 527;
+use constant DTD_NOT_EMPTY => 528;
+use constant DTD_NOT_PCDATA => 529;
+use constant DTD_NOT_STANDALONE => 530;
+use constant DTD_ROOT_NAME => 531;
+use constant DTD_STANDALONE_WHITE_SPACE => 532;
+use constant DTD_UNKNOWN_ATTRIBUTE => 533;
+use constant DTD_UNKNOWN_ELEM => 534;
+use constant DTD_UNKNOWN_ENTITY => 535;
+use constant DTD_UNKNOWN_ID => 536;
+use constant DTD_UNKNOWN_NOTATION => 537;
+use constant HTML_STRUCURE_ERROR => 800;
+use constant HTML_UNKNOWN_TAG => 801;
+use constant RNGP_ANYNAME_ATTR_ANCESTOR => 1000;
+use constant RNGP_ATTR_CONFLICT => 1001;
+use constant RNGP_ATTRIBUTE_CHILDREN => 1002;
+use constant RNGP_ATTRIBUTE_CONTENT => 1003;
+use constant RNGP_ATTRIBUTE_EMPTY => 1004;
+use constant RNGP_ATTRIBUTE_NOOP => 1005;
+use constant RNGP_CHOICE_CONTENT => 1006;
+use constant RNGP_CHOICE_EMPTY => 1007;
+use constant RNGP_CREATE_FAILURE => 1008;
+use constant RNGP_DATA_CONTENT => 1009;
+use constant RNGP_DEF_CHOICE_AND_INTERLEAVE => 1010;
+use constant RNGP_DEFINE_CREATE_FAILED => 1011;
+use constant RNGP_DEFINE_EMPTY => 1012;
+use constant RNGP_DEFINE_MISSING => 1013;
+use constant RNGP_DEFINE_NAME_MISSING => 1014;
+use constant RNGP_ELEM_CONTENT_EMPTY => 1015;
+use constant RNGP_ELEM_CONTENT_ERROR => 1016;
+use constant RNGP_ELEMENT_EMPTY => 1017;
+use constant RNGP_ELEMENT_CONTENT => 1018;
+use constant RNGP_ELEMENT_NAME => 1019;
+use constant RNGP_ELEMENT_NO_CONTENT => 1020;
+use constant RNGP_ELEM_TEXT_CONFLICT => 1021;
+use constant RNGP_EMPTY => 1022;
+use constant RNGP_EMPTY_CONSTRUCT => 1023;
+use constant RNGP_EMPTY_CONTENT => 1024;
+use constant RNGP_EMPTY_NOT_EMPTY => 1025;
+use constant RNGP_ERROR_TYPE_LIB => 1026;
+use constant RNGP_EXCEPT_EMPTY => 1027;
+use constant RNGP_EXCEPT_MISSING => 1028;
+use constant RNGP_EXCEPT_MULTIPLE => 1029;
+use constant RNGP_EXCEPT_NO_CONTENT => 1030;
+use constant RNGP_EXTERNALREF_EMTPY => 1031;
+use constant RNGP_EXTERNAL_REF_FAILURE => 1032;
+use constant RNGP_EXTERNALREF_RECURSE => 1033;
+use constant RNGP_FORBIDDEN_ATTRIBUTE => 1034;
+use constant RNGP_FOREIGN_ELEMENT => 1035;
+use constant RNGP_GRAMMAR_CONTENT => 1036;
+use constant RNGP_GRAMMAR_EMPTY => 1037;
+use constant RNGP_GRAMMAR_MISSING => 1038;
+use constant RNGP_GRAMMAR_NO_START => 1039;
+use constant RNGP_GROUP_ATTR_CONFLICT => 1040;
+use constant RNGP_HREF_ERROR => 1041;
+use constant RNGP_INCLUDE_EMPTY => 1042;
+use constant RNGP_INCLUDE_FAILURE => 1043;
+use constant RNGP_INCLUDE_RECURSE => 1044;
+use constant RNGP_INTERLEAVE_ADD => 1045;
+use constant RNGP_INTERLEAVE_CREATE_FAILED => 1046;
+use constant RNGP_INTERLEAVE_EMPTY => 1047;
+use constant RNGP_INTERLEAVE_NO_CONTENT => 1048;
+use constant RNGP_INVALID_DEFINE_NAME => 1049;
+use constant RNGP_INVALID_URI => 1050;
+use constant RNGP_INVALID_VALUE => 1051;
+use constant RNGP_MISSING_HREF => 1052;
+use constant RNGP_NAME_MISSING => 1053;
+use constant RNGP_NEED_COMBINE => 1054;
+use constant RNGP_NOTALLOWED_NOT_EMPTY => 1055;
+use constant RNGP_NSNAME_ATTR_ANCESTOR => 1056;
+use constant RNGP_NSNAME_NO_NS => 1057;
+use constant RNGP_PARAM_FORBIDDEN => 1058;
+use constant RNGP_PARAM_NAME_MISSING => 1059;
+use constant RNGP_PARENTREF_CREATE_FAILED => 1060;
+use constant RNGP_PARENTREF_NAME_INVALID => 1061;
+use constant RNGP_PARENTREF_NO_NAME => 1062;
+use constant RNGP_PARENTREF_NO_PARENT => 1063;
+use constant RNGP_PARENTREF_NOT_EMPTY => 1064;
+use constant RNGP_PARSE_ERROR => 1065;
+use constant RNGP_PAT_ANYNAME_EXCEPT_ANYNAME => 1066;
+use constant RNGP_PAT_ATTR_ATTR => 1067;
+use constant RNGP_PAT_ATTR_ELEM => 1068;
+use constant RNGP_PAT_DATA_EXCEPT_ATTR => 1069;
+use constant RNGP_PAT_DATA_EXCEPT_ELEM => 1070;
+use constant RNGP_PAT_DATA_EXCEPT_EMPTY => 1071;
+use constant RNGP_PAT_DATA_EXCEPT_GROUP => 1072;
+use constant RNGP_PAT_DATA_EXCEPT_INTERLEAVE => 1073;
+use constant RNGP_PAT_DATA_EXCEPT_LIST => 1074;
+use constant RNGP_PAT_DATA_EXCEPT_ONEMORE => 1075;
+use constant RNGP_PAT_DATA_EXCEPT_REF => 1076;
+use constant RNGP_PAT_DATA_EXCEPT_TEXT => 1077;
+use constant RNGP_PAT_LIST_ATTR => 1078;
+use constant RNGP_PAT_LIST_ELEM => 1079;
+use constant RNGP_PAT_LIST_INTERLEAVE => 1080;
+use constant RNGP_PAT_LIST_LIST => 1081;
+use constant RNGP_PAT_LIST_REF => 1082;
+use constant RNGP_PAT_LIST_TEXT => 1083;
+use constant RNGP_PAT_NSNAME_EXCEPT_ANYNAME => 1084;
+use constant RNGP_PAT_NSNAME_EXCEPT_NSNAME => 1085;
+use constant RNGP_PAT_ONEMORE_GROUP_ATTR => 1086;
+use constant RNGP_PAT_ONEMORE_INTERLEAVE_ATTR => 1087;
+use constant RNGP_PAT_START_ATTR => 1088;
+use constant RNGP_PAT_START_DATA => 1089;
+use constant RNGP_PAT_START_EMPTY => 1090;
+use constant RNGP_PAT_START_GROUP => 1091;
+use constant RNGP_PAT_START_INTERLEAVE => 1092;
+use constant RNGP_PAT_START_LIST => 1093;
+use constant RNGP_PAT_START_ONEMORE => 1094;
+use constant RNGP_PAT_START_TEXT => 1095;
+use constant RNGP_PAT_START_VALUE => 1096;
+use constant RNGP_PREFIX_UNDEFINED => 1097;
+use constant RNGP_REF_CREATE_FAILED => 1098;
+use constant RNGP_REF_CYCLE => 1099;
+use constant RNGP_REF_NAME_INVALID => 1100;
+use constant RNGP_REF_NO_DEF => 1101;
+use constant RNGP_REF_NO_NAME => 1102;
+use constant RNGP_REF_NOT_EMPTY => 1103;
+use constant RNGP_START_CHOICE_AND_INTERLEAVE => 1104;
+use constant RNGP_START_CONTENT => 1105;
+use constant RNGP_START_EMPTY => 1106;
+use constant RNGP_START_MISSING => 1107;
+use constant RNGP_TEXT_EXPECTED => 1108;
+use constant RNGP_TEXT_HAS_CHILD => 1109;
+use constant RNGP_TYPE_MISSING => 1110;
+use constant RNGP_TYPE_NOT_FOUND => 1111;
+use constant RNGP_TYPE_VALUE => 1112;
+use constant RNGP_UNKNOWN_ATTRIBUTE => 1113;
+use constant RNGP_UNKNOWN_COMBINE => 1114;
+use constant RNGP_UNKNOWN_CONSTRUCT => 1115;
+use constant RNGP_UNKNOWN_TYPE_LIB => 1116;
+use constant RNGP_URI_FRAGMENT => 1117;
+use constant RNGP_URI_NOT_ABSOLUTE => 1118;
+use constant RNGP_VALUE_EMPTY => 1119;
+use constant RNGP_VALUE_NO_CONTENT => 1120;
+use constant RNGP_XMLNS_NAME => 1121;
+use constant RNGP_XML_NS => 1122;
+use constant XPATH_EXPRESSION_OK => 1200;
+use constant XPATH_NUMBER_ERROR => 1201;
+use constant XPATH_UNFINISHED_LITERAL_ERROR => 1202;
+use constant XPATH_START_LITERAL_ERROR => 1203;
+use constant XPATH_VARIABLE_REF_ERROR => 1204;
+use constant XPATH_UNDEF_VARIABLE_ERROR => 1205;
+use constant XPATH_INVALID_PREDICATE_ERROR => 1206;
+use constant XPATH_EXPR_ERROR => 1207;
+use constant XPATH_UNCLOSED_ERROR => 1208;
+use constant XPATH_UNKNOWN_FUNC_ERROR => 1209;
+use constant XPATH_INVALID_OPERAND => 1210;
+use constant XPATH_INVALID_TYPE => 1211;
+use constant XPATH_INVALID_ARITY => 1212;
+use constant XPATH_INVALID_CTXT_SIZE => 1213;
+use constant XPATH_INVALID_CTXT_POSITION => 1214;
+use constant XPATH_MEMORY_ERROR => 1215;
+use constant XPTR_SYNTAX_ERROR => 1216;
+use constant XPTR_RESOURCE_ERROR => 1217;
+use constant XPTR_SUB_RESOURCE_ERROR => 1218;
+use constant XPATH_UNDEF_PREFIX_ERROR => 1219;
+use constant XPATH_ENCODING_ERROR => 1220;
+use constant XPATH_INVALID_CHAR_ERROR => 1221;
+use constant TREE_INVALID_HEX => 1300;
+use constant TREE_INVALID_DEC => 1301;
+use constant TREE_UNTERMINATED_ENTITY => 1302;
+use constant SAVE_NOT_UTF8 => 1400;
+use constant SAVE_CHAR_INVALID => 1401;
+use constant SAVE_NO_DOCTYPE => 1402;
+use constant SAVE_UNKNOWN_ENCODING => 1403;
+use constant REGEXP_COMPILE_ERROR => 1450;
+use constant IO_UNKNOWN => 1500;
+use constant IO_EACCES => 1501;
+use constant IO_EAGAIN => 1502;
+use constant IO_EBADF => 1503;
+use constant IO_EBADMSG => 1504;
+use constant IO_EBUSY => 1505;
+use constant IO_ECANCELED => 1506;
+use constant IO_ECHILD => 1507;
+use constant IO_EDEADLK => 1508;
+use constant IO_EDOM => 1509;
+use constant IO_EEXIST => 1510;
+use constant IO_EFAULT => 1511;
+use constant IO_EFBIG => 1512;
+use constant IO_EINPROGRESS => 1513;
+use constant IO_EINTR => 1514;
+use constant IO_EINVAL => 1515;
+use constant IO_EIO => 1516;
+use constant IO_EISDIR => 1517;
+use constant IO_EMFILE => 1518;
+use constant IO_EMLINK => 1519;
+use constant IO_EMSGSIZE => 1520;
+use constant IO_ENAMETOOLONG => 1521;
+use constant IO_ENFILE => 1522;
+use constant IO_ENODEV => 1523;
+use constant IO_ENOENT => 1524;
+use constant IO_ENOEXEC => 1525;
+use constant IO_ENOLCK => 1526;
+use constant IO_ENOMEM => 1527;
+use constant IO_ENOSPC => 1528;
+use constant IO_ENOSYS => 1529;
+use constant IO_ENOTDIR => 1530;
+use constant IO_ENOTEMPTY => 1531;
+use constant IO_ENOTSUP => 1532;
+use constant IO_ENOTTY => 1533;
+use constant IO_ENXIO => 1534;
+use constant IO_EPERM => 1535;
+use constant IO_EPIPE => 1536;
+use constant IO_ERANGE => 1537;
+use constant IO_EROFS => 1538;
+use constant IO_ESPIPE => 1539;
+use constant IO_ESRCH => 1540;
+use constant IO_ETIMEDOUT => 1541;
+use constant IO_EXDEV => 1542;
+use constant IO_NETWORK_ATTEMPT => 1543;
+use constant IO_ENCODER => 1544;
+use constant IO_FLUSH => 1545;
+use constant IO_WRITE => 1546;
+use constant IO_NO_INPUT => 1547;
+use constant IO_BUFFER_FULL => 1548;
+use constant IO_LOAD_ERROR => 1549;
+use constant IO_ENOTSOCK => 1550;
+use constant IO_EISCONN => 1551;
+use constant IO_ECONNREFUSED => 1552;
+use constant IO_ENETUNREACH => 1553;
+use constant IO_EADDRINUSE => 1554;
+use constant IO_EALREADY => 1555;
+use constant IO_EAFNOSUPPORT => 1556;
+use constant XINCLUDE_RECURSION => 1600;
+use constant XINCLUDE_PARSE_VALUE => 1601;
+use constant XINCLUDE_ENTITY_DEF_MISMATCH => 1602;
+use constant XINCLUDE_NO_HREF => 1603;
+use constant XINCLUDE_NO_FALLBACK => 1604;
+use constant XINCLUDE_HREF_URI => 1605;
+use constant XINCLUDE_TEXT_FRAGMENT => 1606;
+use constant XINCLUDE_TEXT_DOCUMENT => 1607;
+use constant XINCLUDE_INVALID_CHAR => 1608;
+use constant XINCLUDE_BUILD_FAILED => 1609;
+use constant XINCLUDE_UNKNOWN_ENCODING => 1610;
+use constant XINCLUDE_MULTIPLE_ROOT => 1611;
+use constant XINCLUDE_XPTR_FAILED => 1612;
+use constant XINCLUDE_XPTR_RESULT => 1613;
+use constant XINCLUDE_INCLUDE_IN_INCLUDE => 1614;
+use constant XINCLUDE_FALLBACKS_IN_INCLUDE => 1615;
+use constant XINCLUDE_FALLBACK_NOT_IN_INCLUDE => 1616;
+use constant CATALOG_MISSING_ATTR => 1650;
+use constant CATALOG_ENTRY_BROKEN => 1651;
+use constant CATALOG_PREFER_VALUE => 1652;
+use constant CATALOG_NOT_CATALOG => 1653;
+use constant CATALOG_RECURSION => 1654;
+use constant SCHEMAP_PREFIX_UNDEFINED => 1700;
+use constant SCHEMAP_ATTRFORMDEFAULT_VALUE => 1701;
+use constant SCHEMAP_ATTRGRP_NONAME_NOREF => 1702;
+use constant SCHEMAP_ATTR_NONAME_NOREF => 1703;
+use constant SCHEMAP_COMPLEXTYPE_NONAME_NOREF => 1704;
+use constant SCHEMAP_ELEMFORMDEFAULT_VALUE => 1705;
+use constant SCHEMAP_ELEM_NONAME_NOREF => 1706;
+use constant SCHEMAP_EXTENSION_NO_BASE => 1707;
+use constant SCHEMAP_FACET_NO_VALUE => 1708;
+use constant SCHEMAP_FAILED_BUILD_IMPORT => 1709;
+use constant SCHEMAP_GROUP_NONAME_NOREF => 1710;
+use constant SCHEMAP_IMPORT_NAMESPACE_NOT_URI => 1711;
+use constant SCHEMAP_IMPORT_REDEFINE_NSNAME => 1712;
+use constant SCHEMAP_IMPORT_SCHEMA_NOT_URI => 1713;
+use constant SCHEMAP_INVALID_BOOLEAN => 1714;
+use constant SCHEMAP_INVALID_ENUM => 1715;
+use constant SCHEMAP_INVALID_FACET => 1716;
+use constant SCHEMAP_INVALID_FACET_VALUE => 1717;
+use constant SCHEMAP_INVALID_MAXOCCURS => 1718;
+use constant SCHEMAP_INVALID_MINOCCURS => 1719;
+use constant SCHEMAP_INVALID_REF_AND_SUBTYPE => 1720;
+use constant SCHEMAP_INVALID_WHITE_SPACE => 1721;
+use constant SCHEMAP_NOATTR_NOREF => 1722;
+use constant SCHEMAP_NOTATION_NO_NAME => 1723;
+use constant SCHEMAP_NOTYPE_NOREF => 1724;
+use constant SCHEMAP_REF_AND_SUBTYPE => 1725;
+use constant SCHEMAP_RESTRICTION_NONAME_NOREF => 1726;
+use constant SCHEMAP_SIMPLETYPE_NONAME => 1727;
+use constant SCHEMAP_TYPE_AND_SUBTYPE => 1728;
+use constant SCHEMAP_UNKNOWN_ALL_CHILD => 1729;
+use constant SCHEMAP_UNKNOWN_ANYATTRIBUTE_CHILD => 1730;
+use constant SCHEMAP_UNKNOWN_ATTR_CHILD => 1731;
+use constant SCHEMAP_UNKNOWN_ATTRGRP_CHILD => 1732;
+use constant SCHEMAP_UNKNOWN_ATTRIBUTE_GROUP => 1733;
+use constant SCHEMAP_UNKNOWN_BASE_TYPE => 1734;
+use constant SCHEMAP_UNKNOWN_CHOICE_CHILD => 1735;
+use constant SCHEMAP_UNKNOWN_COMPLEXCONTENT_CHILD => 1736;
+use constant SCHEMAP_UNKNOWN_COMPLEXTYPE_CHILD => 1737;
+use constant SCHEMAP_UNKNOWN_ELEM_CHILD => 1738;
+use constant SCHEMAP_UNKNOWN_EXTENSION_CHILD => 1739;
+use constant SCHEMAP_UNKNOWN_FACET_CHILD => 1740;
+use constant SCHEMAP_UNKNOWN_FACET_TYPE => 1741;
+use constant SCHEMAP_UNKNOWN_GROUP_CHILD => 1742;
+use constant SCHEMAP_UNKNOWN_IMPORT_CHILD => 1743;
+use constant SCHEMAP_UNKNOWN_LIST_CHILD => 1744;
+use constant SCHEMAP_UNKNOWN_NOTATION_CHILD => 1745;
+use constant SCHEMAP_UNKNOWN_PROCESSCONTENT_CHILD => 1746;
+use constant SCHEMAP_UNKNOWN_REF => 1747;
+use constant SCHEMAP_UNKNOWN_RESTRICTION_CHILD => 1748;
+use constant SCHEMAP_UNKNOWN_SCHEMAS_CHILD => 1749;
+use constant SCHEMAP_UNKNOWN_SEQUENCE_CHILD => 1750;
+use constant SCHEMAP_UNKNOWN_SIMPLECONTENT_CHILD => 1751;
+use constant SCHEMAP_UNKNOWN_SIMPLETYPE_CHILD => 1752;
+use constant SCHEMAP_UNKNOWN_TYPE => 1753;
+use constant SCHEMAP_UNKNOWN_UNION_CHILD => 1754;
+use constant SCHEMAP_ELEM_DEFAULT_FIXED => 1755;
+use constant SCHEMAP_REGEXP_INVALID => 1756;
+use constant SCHEMAP_FAILED_LOAD => 1756;
+use constant SCHEMAP_NOTHING_TO_PARSE => 1757;
+use constant SCHEMAP_NOROOT => 1758;
+use constant SCHEMAP_REDEFINED_GROUP => 1759;
+use constant SCHEMAP_REDEFINED_TYPE => 1760;
+use constant SCHEMAP_REDEFINED_ELEMENT => 1761;
+use constant SCHEMAP_REDEFINED_ATTRGROUP => 1762;
+use constant SCHEMAP_REDEFINED_ATTR => 1763;
+use constant SCHEMAP_REDEFINED_NOTATION => 1764;
+use constant SCHEMAP_FAILED_PARSE => 1765;
+use constant SCHEMAV_NOROOT => 1800;
+use constant SCHEMAV_UNDECLAREDELEM => 1801;
+use constant SCHEMAV_NOTTOPLEVEL => 1802;
+use constant SCHEMAV_MISSING => 1803;
+use constant SCHEMAV_WRONGELEM => 1804;
+use constant SCHEMAV_NOTYPE => 1805;
+use constant SCHEMAV_NOROLLBACK => 1806;
+use constant SCHEMAV_ISABSTRACT => 1807;
+use constant SCHEMAV_NOTEMPTY => 1808;
+use constant SCHEMAV_ELEMCONT => 1809;
+use constant SCHEMAV_HAVEDEFAULT => 1810;
+use constant SCHEMAV_NOTNILLABLE => 1811;
+use constant SCHEMAV_EXTRACONTENT => 1812;
+use constant SCHEMAV_INVALIDATTR => 1813;
+use constant SCHEMAV_INVALIDELEM => 1814;
+use constant SCHEMAV_NOTDETERMINIST => 1815;
+use constant SCHEMAV_CONSTRUCT => 1816;
+use constant SCHEMAV_INTERNAL => 1817;
+use constant SCHEMAV_NOTSIMPLE => 1818;
+use constant SCHEMAV_ATTRUNKNOWN => 1819;
+use constant SCHEMAV_ATTRINVALID => 1820;
+use constant SCHEMAV_VALUE => 1821;
+use constant SCHEMAV_FACET => 1822;
+use constant XPTR_UNKNOWN_SCHEME => 1900;
+use constant XPTR_CHILDSEQ_START => 1901;
+use constant XPTR_EVAL_FAILED => 1902;
+use constant XPTR_EXTRA_OBJECTS => 1903;
+use constant C14N_CREATE_CTXT => 1950;
+use constant C14N_REQUIRES_UTF8 => 1951;
+use constant C14N_CREATE_STACK => 1952;
+use constant C14N_INVALID_NODE => 1953;
+use constant FTP_PASV_ANSWER => 2000;
+use constant FTP_EPSV_ANSWER => 2001;
+use constant FTP_ACCNT => 2002;
+use constant HTTP_URL_SYNTAX => 2020;
+use constant HTTP_USE_IP => 2021;
+use constant HTTP_UNKNOWN_HOST => 2022;
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pod
new file mode 100755
index 00000000000..39b5cf432c3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/ErrNo.pod
@@ -0,0 +1,27 @@
+=head1 NAME
+
+XML::LibXML::ErrNo - Structured Errors
+This module is based on xmlerror.h libxml2 C header file. It defines symbolic
+constants for all libxml2 error codes. Currently libxml2 uses over 480
+different error codes. See also XML::LibXML::Error.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pm
new file mode 100755
index 00000000000..b60d6cf2e9e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pm
@@ -0,0 +1,229 @@
+# $Id: Error.pm,v 1.1.2.1 2004/04/20 20:09:48 pajas Exp $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+package XML::LibXML::Error;
+
+use strict;
+use vars qw($AUTOLOAD @error_domains $VERSION $WARNINGS);
+use Carp;
+use overload
+ '""' => \&as_string,
+ 'eq' => sub {
+ ("$_[0]" eq "$_[1]")
+ },
+ 'cmp' => sub {
+ ("$_[0]" cmp "$_[1]")
+ },
+ fallback => 1;
+
+$WARNINGS = 0; # 0: supress, 1: report via warn, 2: report via die
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use constant XML_ERR_NONE => 0;
+use constant XML_ERR_WARNING => 1; # A simple warning
+use constant XML_ERR_ERROR => 2; # A recoverable error
+use constant XML_ERR_FATAL => 3; # A fatal error
+
+use constant XML_ERR_FROM_NONE => 0;
+use constant XML_ERR_FROM_PARSER => 1; # The XML parser
+use constant XML_ERR_FROM_TREE => 2; # The tree module
+use constant XML_ERR_FROM_NAMESPACE => 3; # The XML Namespace module
+use constant XML_ERR_FROM_DTD => 4; # The XML DTD validation
+use constant XML_ERR_FROM_HTML => 5; # The HTML parser
+use constant XML_ERR_FROM_MEMORY => 6; # The memory allocator
+use constant XML_ERR_FROM_OUTPUT => 7; # The serialization code
+use constant XML_ERR_FROM_IO => 8; # The Input/Output stack
+use constant XML_ERR_FROM_FTP => 9; # The FTP module
+use constant XML_ERR_FROM_HTTP => 10; # The FTP module
+use constant XML_ERR_FROM_XINCLUDE => 11; # The XInclude processing
+use constant XML_ERR_FROM_XPATH => 12; # The XPath module
+use constant XML_ERR_FROM_XPOINTER => 13; # The XPointer module
+use constant XML_ERR_FROM_REGEXP => 14; # The regular expressions module
+use constant XML_ERR_FROM_DATATYPE => 15; # The W3C XML Schemas Datatype module
+use constant XML_ERR_FROM_SCHEMASP => 16; # The W3C XML Schemas parser module
+use constant XML_ERR_FROM_SCHEMASV => 17; # The W3C XML Schemas validation module
+use constant XML_ERR_FROM_RELAXNGP => 18; # The Relax-NG parser module
+use constant XML_ERR_FROM_RELAXNGV => 19; # The Relax-NG validator module
+use constant XML_ERR_FROM_CATALOG => 20; # The Catalog module
+use constant XML_ERR_FROM_C14N => 21; # The Canonicalization module
+use constant XML_ERR_FROM_XSLT => 22; # The XSLT engine from libxslt
+use constant XML_ERR_FROM_VALID => 23; # The validaton module
+
+@error_domains = ("", "parser", "tree", "namespace", "validity",
+ "HTML parser", "memory", "output", "I/O", "ftp",
+ "http", "XInclude", "XPath", "xpointer", "regexp",
+ "Schemas datatype", "Schemas parser", "Schemas validity",
+ "Relax-NG parser", "Relax-NG validity",
+ "Catalog", "C14N", "XSLT", "validity");
+
+{
+
+ sub new {
+ my ($class,$xE) = @_;
+ my $terr;
+ if (ref($xE)) {
+ my ($context,$column) = $xE->context_and_column();
+ $terr =bless {
+ domain => $xE->domain(),
+ level => $xE->level(),
+ code => $xE->code(),
+ message => $xE->message(),
+ file => $xE->file(),
+ line => $xE->line(),
+ str1 => $xE->str1(),
+ str2 => $xE->str2(),
+ str3 => $xE->str3(),
+ num1 => $xE->num1(),
+ num2 => $xE->num2(),
+ (defined($context) ?
+ (
+ context => $context,
+ column => $column,
+ ) : ()),
+ }, $class;
+ } else {
+ # !!!! problem : got a flat error
+ # warn("PROBLEM: GOT A FLAT ERROR $xE\n");
+ $terr =bless {
+ domain => 0,
+ level => 2,
+ code => -1,
+ message => $xE,
+ file => undef,
+ line => undef,
+ str1 => undef,
+ str2 => undef,
+ str3 => undef,
+ num1 => undef,
+ num2 => undef,
+ }, $class;
+ }
+ return $terr;
+ }
+
+ sub _callback_error {
+ #print "CALLBACK\n";
+ my ($xE,$prev) = @_;
+ my $terr;
+ $terr=XML::LibXML::Error->new($xE);
+ if ($terr->{level} == XML_ERR_WARNING and $WARNINGS!=2) {
+ warn $terr if $WARNINGS;
+ return $prev;
+ }
+ #unless ( defined $terr->{file} and length $terr->{file} ) {
+ # this would make it easier to recognize parsed strings
+ # but it breaks old implementations
+ # [CG] $terr->{file} = 'string()';
+ #}
+ #warn "Saving the error ",$terr->dump;
+ $terr->{_prev} = ref($prev) ? $prev :
+ defined($prev) && length($prev) ? XML::LibXML::Error->new($prev) : undef;
+ return $terr;
+ }
+ sub _instant_error_callback {
+ my $xE = shift;
+ my $terr= XML::LibXML::Error->new($xE);
+ print "Reporting an instanteous error ",$terr->dump;
+ die $terr;
+ }
+ sub _report_warning {
+ my ($saved_error) = @_;
+ #print "CALLBACK WARN\n";
+ if ( defined $saved_error ) {
+ #print "reporting a warning ",$saved_error->dump;
+ warn $saved_error;
+ }
+ }
+ sub _report_error {
+ my ($saved_error) = @_;
+ #print "CALLBACK ERROR: $saved_error\n";
+ if ( defined $saved_error ) {
+ die $saved_error;
+ }
+ }
+}
+
+
+sub AUTOLOAD {
+ my $self=shift;
+ return undef unless ref($self);
+ my $sub = $AUTOLOAD;
+ $sub =~ s/.*:://;
+ if ($sub=~/^(?:code|_prev|level|file|line|domain|nodename|message|column|context|str[123]|num[12])$/) {
+ return $self->{$sub};
+ } else {
+ croak("Unknown error field $sub");
+ }
+}
+
+# backward compatibility
+sub int1 { $_[0]->num1 }
+sub int2 { $_[0]->num2 }
+
+sub DESTROY {}
+
+sub domain {
+ my ($self)=@_;
+ return undef unless ref($self);
+ return $error_domains[$self->{domain}];
+}
+
+sub as_string {
+ my ($self)=@_;
+ my $msg = "";
+ my $level;
+
+ if (defined($self->{_prev})) {
+ $msg = $self->{_prev}->as_string;
+ }
+
+ if ($self->{level} == XML_ERR_NONE) {
+ $level = "";
+ } elsif ($self->{level} == XML_ERR_WARNING) {
+ $level = "warning";
+ } elsif ($self->{level} == XML_ERR_ERROR ||
+ $self->{level} == XML_ERR_FATAL) {
+ $level = "error";
+ }
+ my $where="";
+ if (defined($self->{file})) {
+ $where="$self->{file}:$self->{line}";
+ } elsif (($self->{domain} == XML_ERR_FROM_PARSER)
+ and
+ $self->{line}) {
+ $where="Entity: line $self->{line}";
+ }
+ if ($self->{nodename}) {
+ $where.=": element ".$self->{nodename};
+ }
+ $msg.=$where.": " if $where ne "";
+ $msg.=$error_domains[$self->{domain}]." ".$level." :";
+ my $str=$self->{message}||"";
+ chomp($str);
+ $msg.=" ".$str."\n";
+ if (($self->{domain} == XML_ERR_FROM_XPATH) and
+ defined($self->{str1})) {
+ $msg.=$self->{str1}."\n";
+ $msg.=(" " x $self->{num1})."^\n";
+ } elsif (defined $self->{context}) {
+ my $context = $self->{context};
+ $msg.=$context."\n";
+ $context = substr($context,0,$self->{column});
+ $context=~s/[^\t]/ /g;
+ $msg.=$context."^\n";
+ }
+ return $msg;
+}
+
+sub dump {
+ my ($self)=@_;
+ use Data::Dumper;
+ return Data::Dumper->new([$self],['error'])->Dump;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pod
new file mode 100755
index 00000000000..9583ba5b76f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Error.pod
@@ -0,0 +1,254 @@
+=head1 NAME
+
+XML::LibXML::Error - Structured Errors
+
+=head1 SYNOPSIS
+
+
+
+ eval { ... };
+ if (ref($@)) {
+ # handle a structured error (XML::LibXML::Error object)
+ } elsif ($@) {
+ # error, but not an XML::LibXML::Error object
+ } else {
+ # no error
+ }
+
+ $XML::LibXML::Error::WARNINGS=1;
+ $message = $@->as_string();
+ print $@->dump();
+ $error_domain = $@->domain();
+ $error_code = $@->code();
+ $error_message = $@->message();
+ $error_level = $@->level();
+ $filename = $@->file();
+ $line = $@->line();
+ $nodename = $@->nodename();
+ $error_str1 = $@->str1();
+ $error_str2 = $@->str2();
+ $error_str3 = $@->str3();
+ $error_num1 = $@->num1();
+ $error_num2 = $@->num2();
+ $string = $@->context();
+ $offset = $@->column();
+ $previous_error = $@->_prev();
+
+=head1 DESCRIPTION
+
+The XML::LibXML::Error class is a tiny frontend to I<<<<<< libxml2 >>>>>>'s structured error support. If XML::LibXML is compied with structured error
+support, all errors reported by libxml2 are transformed to XML::LibXML:Error
+objects. These objects automatically serialize to the corresponding error
+messages when printed or used in a string operation, but as objects, can also
+be used to get a detailed and structured information about the error that
+occurred.
+
+Unlike most other XML::LibXML objects, XML::LibXML::Error doesn't wrap an
+underlying I<<<<<< libxml2 >>>>>> structure directly, but rather transforms it to a blessed Perl hash reference
+containing the individual fields of the structured error information as hash
+key-value pairs. Individual items (fields) of a structured error can either be
+obtained directly as $@->{field}, or using autoloaded methods such as as
+$@->field() (where field is the field name). XML::LibXML::Error objects have
+the following fields: domain, code, level, file, line, nodename, message, str1,
+str2, str3, num1, num2, and _prev (some of them may be undefined).
+
+=over 4
+
+=item $XML::LibXML::Error::WARNINGS
+
+ $XML::LibXML::Error::WARNINGS=1;
+
+Traditionally, XML::LibXML was supressing parser warnings by setting libxml2's
+global variable xmlGetWarningsDefaultValue to 0. Since 1.70 we do not change
+libxml2's global variables anymore; for backward compatibility, XML::LibXML
+suppresses warnings. This variable can be set to 1 to enable reporting of these
+warnings via Perl C<<<<<< warn >>>>>> and to 2 to report hem via C<<<<<< die >>>>>>.
+
+ $message = $@->as_string();
+
+This functions takes serializes a XML::LibXML::Error object to a string
+containing the full error message close to the message produced by I<<<<<< libxml2 >>>>>> default error handlers and tools like xmllint. This method is also used to
+overload "" operator on XML::LibXML::Error, so it is automatically called
+whenever XML::LibXML::Error object is treated as a string (e.g. in print $@).
+
+
+=item dump
+
+ print $@->dump();
+
+This function serializes a XML::LibXML::Error to a string displaying all fields
+of the error structure individually on separate lines of the form 'name' =>
+'value'.
+
+
+=item domain
+
+ $error_domain = $@->domain();
+
+Returns string containing information about what part of the library raised the
+error. Can be one of: "parser", "tree", "namespace", "validity", "HTML parser",
+"memory", "output", "I/O", "ftp", "http", "XInclude", "XPath", "xpointer",
+"regexp", "Schemas datatype", "Schemas parser", "Schemas validity", "Relax-NG
+parser", "Relax-NG validity", "Catalog", "C14N", "XSLT", "validity".
+
+
+=item code
+
+ $error_code = $@->code();
+
+Returns the actual libxml2 error code. The XML::LibXML::ErrNo module defines
+constants for individual error codes. Currently libxml2 uses over 480 different
+error codes.
+
+
+=item message
+
+ $error_message = $@->message();
+
+Returns a human-readable informative error message.
+
+
+=item level
+
+ $error_level = $@->level();
+
+Returns an integer value describing how consequent is the error.
+XML::LibXML::Error defines the following constants:
+
+
+=over 4
+
+=item *
+
+XML_ERR_NONE = 0
+
+
+
+=item *
+
+XML_ERR_WARNING = 1 : A simple warning.
+
+
+
+=item *
+
+XML_ERR_ERROR = 2 : A recoverable error.
+
+
+
+=item *
+
+XML_ERR_FATAL = 3 : A fatal error.
+
+
+
+=back
+
+
+=item file
+
+ $filename = $@->file();
+
+Returns the filename of the file being processed while the error occurred.
+
+
+=item line
+
+ $line = $@->line();
+
+The line number, if available.
+
+
+=item nodename
+
+ $nodename = $@->nodename();
+
+Name of the node where error occurred, if available. When this field is
+non-empty, libxml2 actually returned a physical pointer to the specified node.
+Due to memory management issues, it is very difficult to implement a way to
+expose the pointer to the Perl level as a XML::LibXML::Node. For this reason,
+XML::LibXML::Error currently only exposes the name the node.
+
+
+=item str1
+
+ $error_str1 = $@->str1();
+
+Error specific. Extra string information.
+
+
+=item str2
+
+ $error_str2 = $@->str2();
+
+Error specific. Extra string information.
+
+
+=item str3
+
+ $error_str3 = $@->str3();
+
+Error specific. Extra string information.
+
+
+=item num1
+
+ $error_num1 = $@->num1();
+
+Error specific. Extra numeric information.
+
+
+=item num2
+
+ $error_num2 = $@->num2();
+
+In recent libxml2 versions, this value contains a column number of the error or
+0 if N/A.
+
+
+=item context
+
+ $string = $@->context();
+
+For parsing errors, this field contains about 80 characters of the XML near the
+place where the error occurred. The field C<<<<<< $@->column() >>>>>> contains the corresponding offset. Where N/A, the field is undefined.
+
+
+=item column
+
+ $offset = $@->column();
+
+See C<<<<<< $@->column() >>>>>> above.
+
+
+=item _prev
+
+ $previous_error = $@->_prev();
+
+This field can possibly hold a reference to another XML::LibXML::Error object
+representing an error which occurred just before this error.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/InputCallback.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/InputCallback.pod
new file mode 100755
index 00000000000..d3766162629
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/InputCallback.pod
@@ -0,0 +1,292 @@
+=head1 NAME
+
+XML::LibXML::InputCallback - XML::LibXML Class for Input Callbacks
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+
+
+=head1 DESCRIPTION
+
+You may get unexpected results if you are trying to load external documents
+during libxml2 parsing if the location of the resource is not a HTTP, FTP or
+relative location but a absolute path for example. To get around this
+limitation, you may add your own input handler to open, read and close
+particular types of locations or URI classes. Using this input callback
+handlers, you can handle your own custom URI schemes for example.
+
+The input callbacks are used whenever LibXML has to get something other than
+externally parsed entities from somewhere. They are implemented using a
+callback stack on the Perl layer in analogy to libxml2's native callback stack.
+
+The XML::LibXML::InputCallback class transparently registers the input
+callbacks for the libxml2's parser processes.
+
+
+=head2 How does XML::LibXML::InputCallback work?
+
+The libxml2 library offers a callback implementation as global functions only.
+To work-around the troubles resulting in having only global callbacks - for
+example, if the same global callback stack is manipulated by different
+applications running together in a single Apache Web-server environment -,
+XML::LibXML::InputCallback comes with a object-oriented and a function-oriented
+part.
+
+Using the function-oriented part the global callback stack of libxml2 can be
+manipulated. Those functions can be used as interface to the callbacks on the
+C- and XS Layer. At the object-oriented part, operations for working with the
+"pseudo-localized" callback stack are implemented. Currently, you can register
+and de-register callbacks on the Perl layer and initialize them on a per parser
+basis.
+
+
+=head3 Callback Groups
+
+The libxml2 input callbacks come in groups. One group contains a URI matcher (I<<<<<< match >>>>>>), a data stream constructor (I<<<<<< open >>>>>>), a data stream reader (I<<<<<< read >>>>>>), and a data stream destructor (I<<<<<< close >>>>>>). The callbacks can be manipulated on a per group basis only.
+
+
+=head3 The Parser Process
+
+The parser process work on a XML data stream, along which, links to other
+resources can be embedded. This can be links to external DTDs or XIncludes for
+example. Those resources are identified by URIs. The callback implementation of
+libxml2 assumes that one callback group can handle a certain amount of URIs and
+a certain URI scheme. Per default, callback handlers for I<<<<<< file://* >>>>>>, I<<<<<< file:://*.gz >>>>>>, I<<<<<< http://* >>>>>> and I<<<<<< ftp://* >>>>>> are registered.
+
+Callback groups in the callback stack are processed from top to bottom, meaning
+that callback groups registered later will be processed before the earlier
+registered ones.
+
+While parsing the data stream, the libxml2 parser checks if a registered
+callback group will handle a URI - if they will not, the URI will be
+interpreted as I<<<<<< file://URI >>>>>>. To handle a URI, the I<<<<<< match >>>>>> callback will have to return '1'. If that happens, the handling of the URI will
+be passed to that callback group. Next, the URI will be passed to the I<<<<<< open >>>>>> callback, which should return a I<<<<<< reference >>>>>> to the data stream if it successfully opened the file, '0' otherwise. If
+opening the stream was successful, the I<<<<<< read >>>>>> callback will be called repeatedly until it returns an empty string. After the
+read callback, the I<<<<<< close >>>>>> callback will be called to close the stream.
+
+
+=head3 Organisation of callback groups in XML::LibXML::InputCallback
+
+Callback groups are implemented as a stack (Array), each entry holds a
+reference to an array of the callbacks. For the libxml2 library, the
+XML::LibXML::InputCallback callback implementation appears as one single
+callback group. The Perl implementation however allows to manage different
+callback stacks on a per libxml2-parser basis.
+
+
+=head2 Using XML::LibXML::InputCallback
+
+After object instantiation using the parameter-less constructor, you can
+register callback groups.
+
+
+
+ my $input_callbacks = XML::LibXML::InputCallback->new();
+ $input_callbacks->register_callbacks([ $match_cb1, $open_cb1,
+ $read_cb1, $close_cb1 ] );
+ $input_callbacks->register_callbacks([ $match_cb2, $open_cb2,
+ $read_cb2, $close_cb2 ] );
+ $input_callbacks->register_callbacks( [ $match_cb3, $open_cb3,
+ $read_cb3, $close_cb3 ] );
+
+ $parser->input_callbacks( $input_callbacks );
+ $parser->parse_file( $some_xml_file );
+
+
+=head2 What about the old callback system prior to XML::LibXML::InputCallback?
+
+In XML::LibXML versions prior to 1.59 - i.e. without the
+XML::LibXML::InputCallback module - you could define your callbacks either
+using globally or locally. You still can do that using
+XML::LibXML::InputCallback, and in addition to that you can define the
+callbacks on a per parser basis!
+
+If you use the old callback interface through global callbacks,
+XML::LibXML::InputCallback will treat them with a lower priority as the ones
+registered using the new interface. The global callbacks will not override the
+callback groups registered using the new interface. Local callbacks are
+attached to a specific parser instance, therefore they are treated with highest
+priority. If the I<<<<<< match >>>>>> callback of the callback group registered as local variable is identical to one
+of the callback groups registered using the new interface, that callback group
+will be replaced.
+
+Users of the old callback implementation whose I<<<<<< open >>>>>> callback returned a plain string, will have to adapt their code to return a
+reference to that string after upgrading to version >= 1.59. The new callback
+system can only deal with the I<<<<<< open >>>>>> callback returning a reference!
+
+
+=head1 INTERFACE DESCRIPTION
+
+
+=head2 Global Variables
+
+=over 4
+
+=item $_CUR_CB
+
+Stores the current callback and can be used as shortcut to access the callback
+stack.
+
+
+=item @_GLOBAL_CALLBACKS
+
+Stores all callback groups for the current parser process.
+
+
+=item @_CB_STACK
+
+Stores the currently used callback group. Used to prevent parser errors when
+dealing with nested XML data.
+
+
+
+=back
+
+
+=head2 Global Callbacks
+
+=over 4
+
+=item _callback_match
+
+Implements the interface for the I<<<<<< match >>>>>> callback at C-level and for the selection of the callback group from the
+callbacks defined at the Perl-level.
+
+
+=item _callback_open
+
+Forwards the I<<<<<< open >>>>>> callback from libxml2 to the corresponding callback function at the Perl-level.
+
+
+=item _callback_read
+
+Forwards the read request to the corresponding callback function at the
+Perl-level and returns the result to libxml2.
+
+
+=item _callback_close
+
+Forwards the I<<<<<< close >>>>>> callback from libxml2 to the corresponding callback function at the
+Perl-level..
+
+
+
+=back
+
+
+=head2 Class methods
+
+=over 4
+
+=item new()
+
+A simple constructor.
+
+
+=item register_callbacks( [ $match_cb, $open_cb, $read_cb, $close_cb ])
+
+The four callbacks I<<<<<< have >>>>>> to be given as array reference in the above order I<<<<<< match >>>>>>, I<<<<<< open >>>>>>, I<<<<<< read >>>>>>, I<<<<<< close >>>>>>!
+
+
+=item unregister_callbacks( [ $match_cb, $open_cb, $read_cb, $close_cb ])
+
+With no arguments given, C<<<<<< unregister_callbacks() >>>>>> will delete the last registered callback group from the stack. If four
+callbacks are passed as array reference, the callback group to unregister will
+be identified by the I<<<<<< match >>>>>> callback and deleted from the callback stack. Note that if several identical I<<<<<< match >>>>>> callbacks are defined in different callback groups, ALL of them will be deleted
+from the stack.
+
+
+=item init_callbacks()
+
+Initializes the callback system before a parsing process.
+
+
+=item cleanup_callbacks()
+
+Resets global variables and the libxml2 callback stack.
+
+
+=item lib_init_callbacks()
+
+Used internally for callback registration at C-level.
+
+
+=item lib_cleanup_callbacks()
+
+Used internally for callback resetting at the C-level.
+
+
+
+=back
+
+
+
+
+=head1 EXAMPLE CALLBACKS
+
+The following example is a purely fictitious example that uses a
+MyScheme::Handler object that responds to methods similar to an IO::Handle.
+
+
+
+ # Define the four callback functions
+ sub match_uri {
+ my $uri = shift;
+ return $uri =~ /^myscheme:/; # trigger our callback group at a 'myscheme' URIs
+ }
+
+ sub open_uri {
+ my $uri = shift;
+ my $handler = MyScheme::Handler->new($uri);
+ return $handler;
+ }
+
+ # The returned $buffer will be parsed by the libxml2 parser
+ sub read_uri {
+ my $handler = shift;
+ my $length = shift;
+ my $buffer;
+ read($handler, $buffer, $length);
+ return $buffer; # $buffer will be an empty string '' if read() is done
+ }
+
+ # Close the handle associated with the resource.
+ sub close_uri {
+ my $handler = shift;
+ close($handler);
+ }
+
+ # Register them with a instance of XML::LibXML::InputCallback
+ my $input_callbacks = XML::LibXML::InputCallback->new();
+ $input_callbacks->register_callbacks([ \&match_uri, \&open_uri,
+ \&read_uri, \&close_uri ] );
+
+ # Register the callback group at a parser instance
+ $parser->input_callbacks( $input_callbacks );
+
+ # $some_xml_file will be parsed using our callbacks
+ $parser->parse_file( $some_xml_file );
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Literal.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Literal.pm
new file mode 100755
index 00000000000..d3b34ec2f81
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Literal.pm
@@ -0,0 +1,109 @@
+# $Id: Literal.pm 785 2009-07-16 14:17:46Z pajas $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::Literal;
+use XML::LibXML::Boolean;
+use XML::LibXML::Number;
+use strict;
+
+use vars qw ($VERSION);
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use overload
+ '""' => \&value,
+ 'cmp' => \&cmp;
+
+sub new {
+ my $class = shift;
+ my ($string) = @_;
+
+# $string =~ s/&quot;/"/g;
+# $string =~ s/&apos;/'/g;
+
+ bless \$string, $class;
+}
+
+sub as_string {
+ my $self = shift;
+ my $string = $$self;
+ $string =~ s/'/&apos;/g;
+ return "'$string'";
+}
+
+sub as_xml {
+ my $self = shift;
+ my $string = $$self;
+ return "<Literal>$string</Literal>\n";
+}
+
+sub value {
+ my $self = shift;
+ $$self;
+}
+
+sub cmp {
+ my $self = shift;
+ my ($cmp, $swap) = @_;
+ if ($swap) {
+ return $cmp cmp $$self;
+ }
+ return $$self cmp $cmp;
+}
+
+sub evaluate {
+ my $self = shift;
+ $self;
+}
+
+sub to_boolean {
+ my $self = shift;
+ return (length($$self) > 0) ? XML::LibXML::Boolean->True : XML::LibXML::Boolean->False;
+}
+
+sub to_number { return XML::LibXML::Number->new($_[0]->value); }
+sub to_literal { return $_[0]; }
+
+sub string_value { return $_[0]->value; }
+
+1;
+__END__
+
+=head1 NAME
+
+XML::LibXML::Literal - Simple string values.
+
+=head1 DESCRIPTION
+
+In XPath terms a Literal is what we know as a string.
+
+=head1 API
+
+=head2 new($string)
+
+Create a new Literal object with the value in $string. Note that &quot; and
+&apos; will be converted to " and ' respectively. That is not part of the XPath
+specification, but I consider it useful. Note though that you have to go
+to extraordinary lengths in an XML template file (be it XSLT or whatever) to
+make use of this:
+
+ <xsl:value-of select="&quot;I'm feeling &amp;quot;sad&amp;quot;&quot;"/>
+
+Which produces a Literal of:
+
+ I'm feeling "sad"
+
+=head2 value()
+
+Also overloaded as stringification, simply returns the literal string value.
+
+=head2 cmp($literal)
+
+Returns the equivalent of perl's cmp operator against the given $literal.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Namespace.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Namespace.pod
new file mode 100755
index 00000000000..f8fca958d99
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Namespace.pod
@@ -0,0 +1,143 @@
+=head1 NAME
+
+XML::LibXML::Namespace - XML::LibXML Namespace Implementation
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to Namespace nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ my $ns = XML::LibXML::Namespace->new($nsURI);
+ print $ns->nodeName();
+ print $ns->name();
+ $localname = $ns->getLocalName();
+ print $ns->getData();
+ print $ns->getValue();
+ print $ns->value();
+ $known_uri = $ns->getNamespaceURI();
+ $known_prefix = $ns->getPrefix();
+
+=head1 DESCRIPTION
+
+Namespace nodes are returned by both $element->findnodes('namespace::foo') or
+by $node->getNamespaces().
+
+The namespace node API is not part of any current DOM API, and so it is quite
+minimal. It should be noted that namespace nodes are I<<<<<< not >>>>>> a sub class of L<<<<<< XML::LibXML::Node >>>>>>, however Namespace nodes act a lot like attribute nodes, and similarly named
+methods will return what you would expect if you treated the namespace node as
+an attribute. Note that in order to fix several inconsistencies between the API
+and the documentation, the behavior of some functions have been changed in
+1.64.
+
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ my $ns = XML::LibXML::Namespace->new($nsURI);
+
+Creates a new Namespace node. Note that this is not a 'node' as an attribute or
+an element node. Therefore you can't do call all L<<<<<< XML::LibXML::Node >>>>>> Functions. All functions available for this node are listed below.
+
+Optionally you can pass the prefix to the namespace constructor. If this second
+parameter is omitted you will create a so called default namespace. Note, the
+newly created namespace is not bound to any document or node, therefore you
+should not expect it to be available in an existing document.
+
+
+=item declaredURI
+
+Returns the URI for this namespace.
+
+
+=item declaredPrefix
+
+Returns the prefix for this namespace.
+
+
+=item nodeName
+
+ print $ns->nodeName();
+
+Returns "xmlns:prefix", where prefix is the prefix for this namespace.
+
+
+=item name
+
+ print $ns->name();
+
+Alias for nodeName()
+
+
+=item getLocalName
+
+ $localname = $ns->getLocalName();
+
+Returns the local name of this node as if it were an attribute, that is, the
+prefix associated with the namespace.
+
+
+=item getData
+
+ print $ns->getData();
+
+Returns the URI of the namespace, i.e. the value of this node as if it were an
+attribute.
+
+
+=item getValue
+
+ print $ns->getValue();
+
+Alias for getData()
+
+
+=item value
+
+ print $ns->value();
+
+Alias for getData()
+
+
+=item getNamespaceURI
+
+ $known_uri = $ns->getNamespaceURI();
+
+Returns the string "http://www.w3.org/2000/xmlns/"
+
+
+=item getPrefix
+
+ $known_prefix = $ns->getPrefix();
+
+Returns the string "xmlns"
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Node.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Node.pod
new file mode 100755
index 00000000000..5af4f0fe22b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Node.pod
@@ -0,0 +1,752 @@
+=head1 NAME
+
+XML::LibXML::Node - Abstract Base Class of XML::LibXML Nodes
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+
+ $name = $node->nodeName;
+ $node->setNodeName( $newName );
+ $bool = $node->isSameNode( $other_node );
+ $bool = $node->isEqual( $other_node );
+ $content = $node->nodeValue;
+ $content = $node->textContent;
+ $type = $node->nodeType;
+ $node->unbindNode();
+ $childnode = $node->removeChild( $childnode );
+ $oldnode = $node->replaceChild( $newNode, $oldNode );
+ $node->replaceNode($newNode);
+ $childnode = $node->appendChild( $childnode );
+ $childnode = $node->addChild( $chilnode );
+ $node = $parent->addNewChild( $nsURI, $name );
+ $node->addSibling($newNode);
+ $newnode =$node->cloneNode( $deep );
+ $parentnode = $node->parentNode;
+ $nextnode = $node->nextSibling();
+ $nextnode = $node->nextNonBlankSibling();
+ $prevnode = $node->previousSibling();
+ $prevnode = $node->previousNonBlankSibling();
+ $boolean = $node->hasChildNodes();
+ $childnode = $node->firstChild;
+ $childnode = $node->lastChild;
+ $documentnode = $node->ownerDocument;
+ $node = $node->getOwner;
+ $node->setOwnerDocument( $doc );
+ $node->insertBefore( $newNode, $refNode );
+ $node->insertAfter( $newNode, $refNode );
+ @nodes = $node->findnodes( $xpath_expression );
+ $result = $node->find( $xpath );
+ print $node->findvalue( $xpath );
+ $bool = $node->exists( $xpath_expression );
+ @childnodes = $node->childNodes();
+ @childnodes = $node->nonBlankChildNodes();
+ $xmlstring = $node->toString($format,$docencoding);
+ $c14nstring = $node->toStringC14N();
+ $c14nstring = $node->toStringC14N($with_comments, $xpath_expression , $xpath_context);
+ $ec14nstring = $node->toStringEC14N();
+ $ec14nstring = $node->toStringEC14N($with_comments, $xpath_expression, $inclusive_prefix_list);
+ $ec14nstring = $node->toStringEC14N($with_comments, $xpath_expression, $xpath_context, $inclusive_prefix_list);
+ $str = $doc->serialize($format);
+ $localname = $node->localname;
+ $nameprefix = $node->prefix;
+ $uri = $node->namespaceURI();
+ $boolean = $node->hasAttributes();
+ @attributelist = $node->attributes();
+ $URI = $node->lookupNamespaceURI( $prefix );
+ $prefix = $node->lookupNamespacePrefix( $URI );
+ $node->normalize;
+ @nslist = $node->getNamespaces;
+ $node->removeChildNodes();
+ $strURI = $node->baseURI();
+ $node->setBaseURI($strURI);
+ $node->nodePath();
+ $lineno = $node->line_number();
+
+=head1 DESCRIPTION
+
+XML::LibXML::Node defines functions that are common to all Node Types. A
+LibXML::Node should never be created standalone, but as an instance of a high
+level class such as LibXML::Element or LibXML::Text. The class itself should
+provide only common functionality. In XML::LibXML each node is part either of a
+document or a document-fragment. Because of this there is no node without a
+parent. This may causes confusion with "unbound" nodes.
+
+
+=head1 METHODS
+
+Many functions listed here are extensively documented in the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>). Please refer to the specification for extensive documentation.
+
+=over 4
+
+=item nodeName
+
+ $name = $node->nodeName;
+
+Returns the node's name. This function is aware of namespaces and returns the
+full name of the current node (C<<<<<< prefix:localname >>>>>>).
+
+Since 1.62 this function also returns the correct DOM names for node types with
+constant names, namely: #text, #cdata-section, #comment, #document,
+#document-fragment.
+
+
+=item setNodeName
+
+ $node->setNodeName( $newName );
+
+In very limited situations, it is useful to change a nodes name. In the DOM
+specification this should throw an error. This Function is aware of namespaces.
+
+
+=item isSameNode
+
+ $bool = $node->isSameNode( $other_node );
+
+returns TRUE (1) if the given nodes refer to the same node structure, otherwise
+FALSE (0) is returned.
+
+
+=item isEqual
+
+ $bool = $node->isEqual( $other_node );
+
+deprecated version of isSameNode().
+
+I<<<<<< NOTE >>>>>> isEqual will change behaviour to follow the DOM specification
+
+
+=item nodeValue
+
+ $content = $node->nodeValue;
+
+If the node has any content (such as stored in a C<<<<<< text node >>>>>>) it can get requested through this function.
+
+I<<<<<< NOTE: >>>>>> Element Nodes have no content per definition. To get the text value of an
+Element use textContent() instead!
+
+
+=item textContent
+
+ $content = $node->textContent;
+
+this function returns the content of all text nodes in the descendants of the
+given node as specified in DOM.
+
+
+=item nodeType
+
+ $type = $node->nodeType;
+
+Return a numeric value representing the node type of this node. The module
+XML::LibXML by default exports constants for the node types (see the EXPORT
+section in the L<<<<<< XML::LibXML >>>>>> manual page).
+
+
+=item unbindNode
+
+ $node->unbindNode();
+
+Unbinds the Node from its siblings and Parent, but not from the Document it
+belongs to. If the node is not inserted into the DOM afterwards it will be lost
+after the program terminated. From a low level view, the unbound node is
+stripped from the context it is and inserted into a (hidden) document-fragment.
+
+
+=item removeChild
+
+ $childnode = $node->removeChild( $childnode );
+
+This will unbind the Child Node from its parent C<<<<<< $node >>>>>>. The function returns the unbound node. If C<<<<<< oldNode >>>>>> is not a child of the given Node the function will fail.
+
+
+=item replaceChild
+
+ $oldnode = $node->replaceChild( $newNode, $oldNode );
+
+Replaces the C<<<<<< $oldNode >>>>>> with the C<<<<<< $newNode >>>>>>. The C<<<<<< $oldNode >>>>>> will be unbound from the Node. This function differs from the DOM L2
+specification, in the case, if the new node is not part of the document, the
+node will be imported first.
+
+
+=item replaceNode
+
+ $node->replaceNode($newNode);
+
+This function is very similar to replaceChild(), but it replaces the node
+itself rather than a childnode. This is useful if a node found by any XPath
+function, should be replaced.
+
+
+=item appendChild
+
+ $childnode = $node->appendChild( $childnode );
+
+The function will add the C<<<<<< $childnode >>>>>> to the end of C<<<<<< $node >>>>>>'s children. The function should fail, if the new childnode is already a child
+of C<<<<<< $node >>>>>>. This function differs from the DOM L2 specification, in the case, if the new
+node is not part of the document, the node will be imported first.
+
+
+=item addChild
+
+ $childnode = $node->addChild( $chilnode );
+
+As an alternative to appendChild() one can use the addChild() function. This
+function is a bit faster, because it avoids all DOM conformity checks.
+Therefore this function is quite useful if one builds XML documents in memory
+where the order and ownership (C<<<<<< ownerDocument >>>>>>) is assured.
+
+addChild() uses libxml2's own xmlAddChild() function. Thus it has to be used
+with extra care: If a text node is added to a node and the node itself or its
+last childnode is as well a text node, the node to add will be merged with the
+one already available. The current node will be removed from memory after this
+action. Because perl is not aware of this action, the perl instance is still
+available. XML::LibXML will catch the loss of a node and refuse to run any
+function called on that node.
+
+
+
+ my $t1 = $doc->createTextNode( "foo" );
+ my $t2 = $doc->createTextNode( "bar" );
+ $t1->addChild( $t2 ); # is OK
+ my $val = $t2->nodeValue(); # will fail, script dies
+
+Also addChild() will not check if the added node belongs to the same document
+as the node it will be added to. This could lead to inconsistent documents and
+in more worse cases even to memory violations, if one does not keep track of
+this issue.
+
+Although this sounds like a lot of trouble, addChild() is useful if a document
+is built from a stream, such as happens sometimes in SAX handlers or filters.
+
+If you are not sure about the source of your nodes, you better stay with
+appendChild(), because this function is more user friendly in the sense of
+being more error tolerant.
+
+
+=item addNewChild
+
+ $node = $parent->addNewChild( $nsURI, $name );
+
+Similar to C<<<<<< addChild() >>>>>>, this function uses low level libxml2 functionality to provide faster
+interface for DOM building. I<<<<<< addNewChild() >>>>>> uses C<<<<<< xmlNewChild() >>>>>> to create a new node on a given parent element.
+
+addNewChild() has two parameters $nsURI and $name, where $nsURI is an
+(optional) namespace URI. $name is the fully qualified element name;
+addNewChild() will determine the correct prefix if necessary.
+
+The function returns the newly created node.
+
+This function is very useful for DOM building, where a created node can be
+directly associated with its parent. I<<<<<< NOTE >>>>>> this function is not part of the DOM specification and its use will limit your
+code to XML::LibXML.
+
+
+=item addSibling
+
+ $node->addSibling($newNode);
+
+addSibling() allows adding an additional node to the end of a nodelist, defined
+by the given node.
+
+
+=item cloneNode
+
+ $newnode =$node->cloneNode( $deep );
+
+I<<<<<< cloneNode >>>>>> creates a copy of C<<<<<< $node >>>>>>. When $deep is set to 1 (true) the function will copy all childnodes as well.
+If $deep is 0 only the current node will be copied. Note that in case of
+element, attributes are copied even if $deep is 0.
+
+Note that the behavior of this function for $deep=0 has changed in 1.62 in
+order to be consistent with the DOM spec (in older versions attributes and
+namespace information was not copied for elements).
+
+
+=item parentNode
+
+ $parentnode = $node->parentNode;
+
+Returns simply the Parent Node of the current node.
+
+
+=item nextSibling
+
+ $nextnode = $node->nextSibling();
+
+Returns the next sibling if any .
+
+
+=item nextNonBlankSibling
+
+ $nextnode = $node->nextNonBlankSibling();
+
+Returns the next non-blank sibling if any (a node is blank if it is a Text or
+CDATA node consisting of whitespace only). This method is not defined by DOM.
+
+
+=item previousSibling
+
+ $prevnode = $node->previousSibling();
+
+Analogous to I<<<<<< getNextSibling >>>>>> the function returns the previous sibling if any.
+
+
+=item previousNonBlankSibling
+
+ $prevnode = $node->previousNonBlankSibling();
+
+Returns the previous non-blank sibling if any (a node is blank if it is a Text
+or CDATA node consisting of whitespace only). This method is not defined by
+DOM.
+
+
+=item hasChildNodes
+
+ $boolean = $node->hasChildNodes();
+
+If the current node has Childnodes this function returns TRUE (1), otherwise it
+returns FALSE (0, not undef).
+
+
+=item firstChild
+
+ $childnode = $node->firstChild;
+
+If a node has childnodes this function will return the first node in the
+childlist.
+
+
+=item lastChild
+
+ $childnode = $node->lastChild;
+
+If the C<<<<<< $node >>>>>> has childnodes this function returns the last child node.
+
+
+=item ownerDocument
+
+ $documentnode = $node->ownerDocument;
+
+Through this function it is always possible to access the document the current
+node is bound to.
+
+
+=item getOwner
+
+ $node = $node->getOwner;
+
+This function returns the node the current node is associated with. In most
+cases this will be a document node or a document fragment node.
+
+
+=item setOwnerDocument
+
+ $node->setOwnerDocument( $doc );
+
+This function binds a node to another DOM. This method unbinds the node first,
+if it is already bound to another document.
+
+This function is the opposite calling of L<<<<<< XML::LibXML::Document >>>>>>'s adoptNode() function. Because of this it has the same limitations with
+Entity References as adoptNode().
+
+
+=item insertBefore
+
+ $node->insertBefore( $newNode, $refNode );
+
+The method inserts C<<<<<< $newNode >>>>>> before C<<<<<< $refNode >>>>>>. If C<<<<<< $refNode >>>>>> is undefined, the newNode will be set as the new last child of the parent node.
+This function differs from the DOM L2 specification, in the case, if the new
+node is not part of the document, the node will be imported first,
+automatically.
+
+$refNode has to be passed to the function even if it is undefined:
+
+
+
+ $node->insertBefore( $newNode, undef ); # the same as $node->appendChild( $newNode );
+ $node->insertBefore( $newNode ); # wrong
+
+Note, that the reference node has to be a direct child of the node the function
+is called on. Also, $newChild is not allowed to be an ancestor of the new
+parent node.
+
+
+=item insertAfter
+
+ $node->insertAfter( $newNode, $refNode );
+
+The method inserts C<<<<<< $newNode >>>>>> after C<<<<<< $refNode >>>>>>. If C<<<<<< $refNode >>>>>> is undefined, the newNode will be set as the new last child of the parent node.
+
+Note, that $refNode has to be passed explicitly even if it is undef.
+
+
+=item findnodes
+
+ @nodes = $node->findnodes( $xpath_expression );
+
+I<<<<<< findnodes >>>>>> evaluates the xpath expression (XPath 1.0) on the current node and returns the
+resulting node set as an array. In scalar context returns a L<<<<<< XML::LibXML::NodeList >>>>>> object.
+
+The xpath expression can be passed either as a string or or as a L<<<<<< XML::LibXML::XPathExpression >>>>>> object.
+
+I<<<<<< NOTE ON NAMESPACES AND XPATH >>>>>>:
+
+A common mistake about XPath is to assume that node tests consisting of an
+element name with no prefix match elements in the default namespace. This
+assumption is wrong - by XPath specification, such node tests can only match
+elements that are in no (i.e. null) namespace.
+
+So, for example, one cannot match the root element of an XHTML document with C<<<<<< $node->find('/html') >>>>>> since C<<<<<< '/html' >>>>>> would only match if the root element C<<<<<< <html> >>>>>> had no namespace, but all XHTML elements belong to the namespace
+http://www.w3.org/1999/xhtml. (Note that C<<<<<< xmlns="..." >>>>>> namespace declarations can also be specified in a DTD, which makes the
+situation even worse, since the XML document looks as if there was no default
+namespace).
+
+There are several possible ways to deal with namespaces in XPath:
+
+
+=over 4
+
+=item *
+
+The recommended way is to use the L<<<<<< XML::LibXML::XPathContext >>>>>> module to define an explicit context for XPath evaluation, in which a document
+independent prefix-to-namespace mapping can be defined. For example:
+
+
+
+ my $xpc = XML::LibXML::XPathContext->new;
+ $xpc->registerNs('x', 'http://www.w3.org/1999/xhtml');
+ $xpc->find('/x:html',$node);
+
+
+
+=item *
+
+Another possibility is to use prefixes declared in the queried document (if
+known). If the document declares a prefix for the namespace in question (and
+the context node is in the scope of the declaration), C<<<<<< XML::LibXML >>>>>> allows you to use the prefix in the XPath expression, e.g.:
+
+
+
+ $node->find('/x:html');
+
+
+
+=back
+
+See also XML::LibXML::XPathContext->findnodes.
+
+
+=item find
+
+ $result = $node->find( $xpath );
+
+I<<<<<< find >>>>>> evaluates the XPath 1.0 expression using the current node as the context of the
+expression, and returns the result depending on what type of result the XPath
+expression had. For example, the XPath "1 * 3 + 52" results in a L<<<<<< XML::LibXML::Number >>>>>> object being returned. Other expressions might return a L<<<<<< XML::LibXML::Boolean >>>>>> object, or a L<<<<<< XML::LibXML::Literal >>>>>> object (a string). Each of those objects uses Perl's overload feature to "do
+the right thing" in different contexts.
+
+The xpath expression can be passed either as a string or or as a L<<<<<< XML::LibXML::XPathExpression >>>>>> object.
+
+See also L<<<<<< XML::LibXML::XPathContext >>>>>>->find.
+
+
+=item findvalue
+
+ print $node->findvalue( $xpath );
+
+I<<<<<< findvalue >>>>>> is exactly equivalent to:
+
+
+
+ $node->find( $xpath )->to_literal;
+
+That is, it returns the literal value of the results. This enables you to
+ensure that you get a string back from your search, allowing certain shortcuts.
+This could be used as the equivalent of XSLT's <xsl:value-of
+select="some_xpath"/>.
+
+See also L<<<<<< XML::LibXML::XPathContext >>>>>>->findvalue.
+
+The xpath expression can be passed either as a string or or as a L<<<<<< XML::LibXML::XPathExpression >>>>>> object.
+
+
+=item exists
+
+ $bool = $node->exists( $xpath_expression );
+
+This method behaves like I<<<<<< findnodes >>>>>>, except that it only returns a boolean value (1 if the expression matches a
+node, 0 otherwise) and may be faster than I<<<<<< findnodes >>>>>>, because the XPath evaluation may stop early on the first match (this is true
+for libxml2 >= 2.6.27).
+
+For XPath expressions that do not return node-set, the method returns true if
+the returned value is a non-zero number or a non-empty string.
+
+
+=item childNodes
+
+ @childnodes = $node->childNodes();
+
+I<<<<<< childNodes >>>>>> implements a more intuitive interface to the childnodes of the current node. It
+enables you to pass all children directly to a C<<<<<< map >>>>>> or C<<<<<< grep >>>>>>. If this function is called in scalar context, a L<<<<<< XML::LibXML::NodeList >>>>>> object will be returned.
+
+
+=item nonBlankChildNodes
+
+ @childnodes = $node->nonBlankChildNodes();
+
+This is like I<<<<<< childNodes >>>>>>, but returns only non-blank nodes (where a node is blank if it is a Text or
+CDATA node consisting of whitespace only). This method is not defined by DOM.
+
+
+=item toString
+
+ $xmlstring = $node->toString($format,$docencoding);
+
+This method is similar to the method C<<<<<< toString >>>>>> of a L<<<<<< XML::LibXML::Document >>>>>> but for a single node. It returns a string consisting of XML serialization of
+the given node and all its descendants. Unlike C<<<<<< XML::LibXML::Document::toString >>>>>>, in this case the resulting string is by default a character string (UTF-8
+encoded with UTF8 flag on). An optional flag $format controls indentation, as
+in C<<<<<< XML::LibXML::Document::toString >>>>>>. If the second optional $docencoding flag is true, the result will be a byte
+string in the document encoding (see C<<<<<< XML::LibXML::Document::actualEncoding >>>>>>).
+
+
+=item toStringC14N
+
+ $c14nstring = $node->toStringC14N();
+ $c14nstring = $node->toStringC14N($with_comments, $xpath_expression , $xpath_context);
+
+The function is similar to toString(). Instead of simply serializing the
+document tree, it transforms it as it is specified in the XML-C14N
+Specification (see L<<<<<< http://www.w3.org/TR/xml-c14n >>>>>>). Such transformation is known as canonization.
+
+If $with_comments is 0 or not defined, the result-document will not contain any
+comments that exist in the original document. To include comments into the
+canonized document, $with_comments has to be set to 1.
+
+The parameter $xpath_expression defines the nodeset of nodes that should be
+visible in the resulting document. This can be used to filter out some nodes.
+One has to note, that only the nodes that are part of the nodeset, will be
+included into the result-document. Their child-nodes will not exist in the
+resulting document, unless they are part of the nodeset defined by the xpath
+expression.
+
+If $xpath_expression is omitted or empty, toStringC14N() will include all nodes
+in the given sub-tree, using the following XPath expressions: with comments
+
+ (. | .//node() | .//@* | .//namespace::*)
+
+and without comments
+
+ (. | .//node() | .//@* | .//namespace::*)[not(self::comment())]
+
+
+
+An optional parameter $xpath_context can be used to pass an L<<<<<< XML::LibXML::XPathContext >>>>>> object defining the context for evaluation of $xpath_expression. This is useful
+for mapping namespace prefixes used in the XPath expression to namespace URIs.
+Note, however, that $node will be used as the context node for the evaluation,
+not the context node of $xpath_context!
+
+
+=item toStringEC14N
+
+ $ec14nstring = $node->toStringEC14N();
+ $ec14nstring = $node->toStringEC14N($with_comments, $xpath_expression, $inclusive_prefix_list);
+ $ec14nstring = $node->toStringEC14N($with_comments, $xpath_expression, $xpath_context, $inclusive_prefix_list);
+
+The function is similar to toStringC14N() but follows the XML-EXC-C14N
+Specification (see L<<<<<< http://www.w3.org/TR/xml-exc-c14n >>>>>>) for exclusive canonization of XML.
+
+The arguments $with_comments, $xpath_expression, $xpath_context are as in
+toStringC14N(). An ARRAY reference can be passed as the last argument
+$inclusive_prefix_list, listing namespace prefixes that are to be handled in
+the manner described by the Canonical XML Recommendation (i.e. preserved in the
+output even if the namespace is not used). C.f. the spec for details.
+
+
+=item serialize
+
+ $str = $doc->serialize($format);
+
+An alias for toString(). This function was name added to be more consistent
+with libxml2.
+
+
+=item serialize_c14n
+
+An alias for toStringC14N().
+
+
+=item serialize_exc_c14n
+
+An alias for toStringEC14N().
+
+
+=item localname
+
+ $localname = $node->localname;
+
+Returns the local name of a tag. This is the part behind the colon.
+
+
+=item prefix
+
+ $nameprefix = $node->prefix;
+
+Returns the prefix of a tag. This is the part before the colon.
+
+
+=item namespaceURI
+
+ $uri = $node->namespaceURI();
+
+returns the URI of the current namespace.
+
+
+=item hasAttributes
+
+ $boolean = $node->hasAttributes();
+
+returns 1 (TRUE) if the current node has any attributes set, otherwise 0
+(FALSE) is returned.
+
+
+=item attributes
+
+ @attributelist = $node->attributes();
+
+This function returns all attributes and namespace declarations assigned to the
+given node.
+
+Because XML::LibXML does not implement namespace declarations and attributes
+the same way, it is required to test what kind of node is handled while
+accessing the functions result.
+
+If this function is called in array context the attribute nodes are returned as
+an array. In scalar context the function will return a L<<<<<< XML::LibXML::NamedNodeMap >>>>>> object.
+
+
+=item lookupNamespaceURI
+
+ $URI = $node->lookupNamespaceURI( $prefix );
+
+Find a namespace URI by its prefix starting at the current node.
+
+
+=item lookupNamespacePrefix
+
+ $prefix = $node->lookupNamespacePrefix( $URI );
+
+Find a namespace prefix by its URI starting at the current node.
+
+I<<<<<< NOTE >>>>>> Only the namespace URIs are meant to be unique. The prefix is only document
+related. Also the document might have more than a single prefix defined for a
+namespace.
+
+
+=item normalize
+
+ $node->normalize;
+
+This function normalizes adjacent text nodes. This function is not as strict as
+libxml2's xmlTextMerge() function, since it will not free a node that is still
+referenced by the perl layer.
+
+
+=item getNamespaces
+
+ @nslist = $node->getNamespaces;
+
+If a node has any namespaces defined, this function will return these
+namespaces. Note, that this will not return all namespaces that are in scope,
+but only the ones declared explicitly for that node.
+
+Although getNamespaces is available for all nodes, it only makes sense if used
+with element nodes.
+
+
+=item removeChildNodes
+
+ $node->removeChildNodes();
+
+This function is not specified for any DOM level: It removes all childnodes
+from a node in a single step. Other than the libxml2 function itself
+(xmlFreeNodeList), this function will not immediately remove the nodes from the
+memory. This saves one from getting memory violations, if there are nodes still
+referred to from the Perl level.
+
+
+=item baseURI ()
+
+ $strURI = $node->baseURI();
+
+Searches for the base URL of the node. The method should work on both XML and
+HTML documents even if base mechanisms for these are completely different. It
+returns the base as defined in RFC 2396 sections "5.1.1. Base URI within
+Document Content" and "5.1.2. Base URI from the Encapsulating Entity". However
+it does not return the document base (5.1.3), use method C<<<<<< URI >>>>>> of C<<<<<< XML::LibXML::Document >>>>>> for this.
+
+
+=item setBaseURI ($strURI)
+
+ $node->setBaseURI($strURI);
+
+This method only does something useful for an element node in a XML document.
+It sets the xml:base attribute on the node to $strURI, which effectively sets
+the base URI of the node to the same value.
+
+Note: For HTML documents this behaves as if the document was XML which may not
+be desired, since it does not effectively set the base URI of the node. See RFC
+2396 appendix D for an example of how base URI can be specified in HTML.
+
+
+=item nodePath
+
+ $node->nodePath();
+
+This function is not specified for any DOM level: It returns a canonical
+structure based XPath for a given node.
+
+
+=item line_number
+
+ $lineno = $node->line_number();
+
+This function returns the line number where the tag was found during parsing.
+If a node is added to the document the line number is 0. Problems may occur, if
+a node from one document is passed to another one.
+
+IMPORTANT: Due to limitations in the libxml2 library line numbers greater than
+65535 will be returned as 65535. Please see L<<<<<< http://bugzilla.gnome.org/show_bug.cgi?id=325533 >>>>>> for more details.
+
+Note: line_number() is special to XML::LibXML and not part of the DOM
+specification.
+
+If the line_numbers flag of the parser was not activated before parsing,
+line_number() will always return 0.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/NodeList.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/NodeList.pm
new file mode 100755
index 00000000000..336740803a2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/NodeList.pm
@@ -0,0 +1,198 @@
+# $Id: NodeList.pm 785 2009-07-16 14:17:46Z pajas $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::NodeList;
+use strict;
+use XML::LibXML::Boolean;
+use XML::LibXML::Literal;
+use XML::LibXML::Number;
+
+use vars qw ($VERSION);
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use overload
+ '""' => \&to_literal,
+ 'bool' => \&to_boolean,
+ ;
+
+sub new {
+ my $class = shift;
+ bless [@_], $class;
+}
+
+sub new_from_ref {
+ my ($class,$array_ref,$reuse) = @_;
+ return bless $reuse ? $array_ref : [@$array_ref], $class;
+}
+
+sub pop {
+ my $self = CORE::shift;
+ CORE::pop @$self;
+}
+
+sub push {
+ my $self = CORE::shift;
+ CORE::push @$self, @_;
+}
+
+sub append {
+ my $self = CORE::shift;
+ my ($nodelist) = @_;
+ CORE::push @$self, $nodelist->get_nodelist;
+}
+
+sub shift {
+ my $self = CORE::shift;
+ CORE::shift @$self;
+}
+
+sub unshift {
+ my $self = CORE::shift;
+ CORE::unshift @$self, @_;
+}
+
+sub prepend {
+ my $self = CORE::shift;
+ my ($nodelist) = @_;
+ CORE::unshift @$self, $nodelist->get_nodelist;
+}
+
+sub size {
+ my $self = CORE::shift;
+ scalar @$self;
+}
+
+sub get_node {
+ # uses array index starting at 1, not 0
+ # this is mainly because of XPath.
+ my $self = CORE::shift;
+ my ($pos) = @_;
+ $self->[$pos - 1];
+}
+
+*item = \&get_node;
+
+sub get_nodelist {
+ my $self = CORE::shift;
+ @$self;
+}
+
+sub to_boolean {
+ my $self = CORE::shift;
+ return (@$self > 0) ? XML::LibXML::Boolean->True : XML::LibXML::Boolean->False;
+}
+
+# string-value of a nodelist is the string-value of the first node
+sub string_value {
+ my $self = CORE::shift;
+ return '' unless @$self;
+ return $self->[0]->string_value;
+}
+
+sub to_literal {
+ my $self = CORE::shift;
+ return XML::LibXML::Literal->new(
+ join('', grep {defined $_} map { $_->string_value } @$self)
+ );
+}
+
+sub to_number {
+ my $self = CORE::shift;
+ return XML::LibXML::Number->new(
+ $self->to_literal
+ );
+}
+
+sub iterator {
+ warn "this function is obsolete!\nIt was disabled in version 1.54\n";
+ return undef;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::LibXML::NodeList - a list of XML document nodes
+
+=head1 DESCRIPTION
+
+An XML::LibXML::NodeList object contains an ordered list of nodes, as
+detailed by the W3C DOM documentation of Node Lists.
+
+=head1 SYNOPSIS
+
+ my $results = $dom->findnodes('//somepath');
+ foreach my $context ($results->get_nodelist) {
+ my $newresults = $context->findnodes('./other/element');
+ ...
+ }
+
+=head1 API
+
+=head2 new()
+
+You will almost never have to create a new NodeSet object, as it is all
+done for you by XPath.
+
+=head2 get_nodelist()
+
+Returns a list of nodes, the contents of the node list, as a perl list.
+
+=head2 string_value()
+
+Returns the string-value of the first node in the list.
+See the XPath specification for what "string-value" means.
+
+=head2 to_literal()
+
+Returns the concatenation of all the string-values of all
+the nodes in the list.
+
+=head2 get_node($pos)
+
+Returns the node at $pos. The node position in XPath is based at 1, not 0.
+
+=head2 size()
+
+Returns the number of nodes in the NodeSet.
+
+=head2 pop()
+
+Equivalent to perl's pop function.
+
+=head2 push(@nodes)
+
+Equivalent to perl's push function.
+
+=head2 append($nodelist)
+
+Given a nodelist, appends the list of nodes in $nodelist to the end of the
+current list.
+
+=head2 shift()
+
+Equivalent to perl's shift function.
+
+=head2 unshift(@nodes)
+
+Equivalent to perl's unshift function.
+
+=head2 prepend($nodeset)
+
+Given a nodelist, prepends the list of nodes in $nodelist to the front of
+the current list.
+
+=head2 iterator()
+
+Will return a new nodelist iterator for the current nodelist. A
+nodelist iterator is usefull if more complex nodelist processing is
+needed.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Number.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Number.pm
new file mode 100755
index 00000000000..5538d33e70a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Number.pm
@@ -0,0 +1,97 @@
+# $Id: Number.pm 785 2009-07-16 14:17:46Z pajas $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::Number;
+use XML::LibXML::Boolean;
+use XML::LibXML::Literal;
+use strict;
+
+use vars qw ($VERSION);
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use overload
+ '""' => \&value,
+ '0+' => \&value,
+ '<=>' => \&cmp;
+
+sub new {
+ my $class = shift;
+ my $number = shift;
+ if ($number !~ /^\s*(-\s*)?(\d+(\.\d*)?|\.\d+)\s*$/) {
+ $number = undef;
+ }
+ else {
+ $number =~ s/\s+//g;
+ }
+ bless \$number, $class;
+}
+
+sub as_string {
+ my $self = shift;
+ defined $$self ? $$self : 'NaN';
+}
+
+sub as_xml {
+ my $self = shift;
+ return "<Number>" . (defined($$self) ? $$self : 'NaN') . "</Number>\n";
+}
+
+sub value {
+ my $self = shift;
+ $$self;
+}
+
+sub cmp {
+ my $self = shift;
+ my ($other, $swap) = @_;
+ if ($swap) {
+ return $other <=> $$self;
+ }
+ return $$self <=> $other;
+}
+
+sub evaluate {
+ my $self = shift;
+ $self;
+}
+
+sub to_boolean {
+ my $self = shift;
+ return $$self ? XML::LibXML::Boolean->True : XML::LibXML::Boolean->False;
+}
+
+sub to_literal { XML::LibXML::Literal->new($_[0]->as_string); }
+sub to_number { $_[0]; }
+
+sub string_value { return $_[0]->value }
+
+1;
+__END__
+
+=head1 NAME
+
+XML::LibXML::Number - Simple numeric values.
+
+=head1 DESCRIPTION
+
+This class holds simple numeric values. It doesn't support -0, +/- Infinity,
+or NaN, as the XPath spec says it should, but I'm not hurting anyone I don't think.
+
+=head1 API
+
+=head2 new($num)
+
+Creates a new XML::LibXML::Number object, with the value in $num. Does some
+rudimentary numeric checking on $num to ensure it actually is a number.
+
+=head2 value()
+
+Also as overloaded stringification. Returns the numeric value held.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/PI.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/PI.pod
new file mode 100755
index 00000000000..1c08a8ab3b1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/PI.pod
@@ -0,0 +1,87 @@
+=head1 NAME
+
+XML::LibXML::PI - XML::LibXML Processing Instructions
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to Processing Instruction nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ $pinode->setData( $data_string );
+ $pinode->setData( name=>string_value [...] );
+
+=head1 DESCRIPTION
+
+Processing instructions are implemented with XML::LibXML with read and write
+access. The PI data is the PI without the PI target (as specified in XML 1.0
+[17]) as a string. This string can be accessed with getData as implemented in L<<<<<< XML::LibXML::Node >>>>>>.
+
+The write access is aware about the fact, that many processing instructions
+have attribute like data. Therefore setData() provides besides the DOM spec
+conform Interface to pass a set of named parameter. So the code segment
+
+
+
+ my $pi = $dom->createProcessingInstruction("abc");
+ $pi->setData(foo=>'bar', foobar=>'foobar');
+ $dom->appendChild( $pi );
+
+will result the following PI in the DOM:
+
+
+
+ <?abc foo="bar" foobar="foobar"?>
+
+Which is how it is specified in the DOM specification. This three step
+interface creates temporary a node in perl space. This can be avoided while
+using the insertProcessingInstruction() method. Instead of the three calls
+described above, the call
+
+
+
+ $dom->insertProcessingInstruction("abc",'foo="bar" foobar="foobar"');
+
+will have the same result as above.
+
+L<<<<<< XML::LibXML::PI >>>>>>'s implementation of setData() documented below differs a bit from the the
+standard version as available in L<<<<<< XML::LibXML::Node >>>>>>:
+
+=over 4
+
+=item setData
+
+ $pinode->setData( $data_string );
+ $pinode->setData( name=>string_value [...] );
+
+This method allows to change the content data of a PI. Additionally to the
+interface specified for DOM Level2, the method provides a named parameter
+interface to set the data. This parameter list is converted into a string
+before it is appended to the PI.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Parser.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Parser.pod
new file mode 100755
index 00000000000..1bf6b48d527
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Parser.pod
@@ -0,0 +1,966 @@
+=head1 NAME
+
+XML::LibXML::Parser - Parsing XML Data with XML::LibXML
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML 1.70;
+
+ # Parser constructor
+
+ $parser = XML::LibXML->new();
+ $parser = XML::LibXML->new(option=>value, ...);
+ $parser = XML::LibXML->new({option=>value, ...});
+
+ # Parsing XML
+
+ $dom = XML::LibXML->load_xml(
+ location => $file_or_url
+ # parser options ...
+ );
+ $dom = XML::LibXML->load_xml(
+ string => $xml_string
+ # parser options ...
+ );
+ $dom = XML::LibXML->load_xml({
+ IO => $perl_file_handle
+ # parser options ...
+ );
+ $dom = $parser->load_xml(...);
+
+ # Parsing HTML
+
+ $dom = XML::LibXML->load_html(...);
+ $dom = $parser->load_html(...);
+
+ # Parsing well-balanced XML chunks
+
+ $fragment = $parser->parse_balanced_chunk( $wbxmlstring, $encoding );
+
+ # Processing XInclude
+
+ $parser->process_xincludes( $doc );
+ $parser->processXIncludes( $doc );
+
+ # Old-style parser interfaces
+
+ $doc = $parser->parse_file( $xmlfilename );
+ $doc = $parser->parse_fh( $io_fh );
+ $doc = $parser->parse_string( $xmlstring);
+ $doc = $parser->parse_html_file( $htmlfile, \%opts );
+ $doc = $parser->parse_html_fh( $io_fh, \%opts );
+ $doc = $parser->parse_html_string( $htmlstring, \%opts );
+
+ # Push parser
+
+ $parser->parse_chunk($string, $terminate);
+ $parser->init_push();
+ $parser->push(@data);
+ $doc = $parser->finish_push( $recover );
+
+ # Set/query parser options
+
+ $parser->option_exists($name);
+ $parser->get_option($name);
+ $parser->set_option($name,$value);
+ $parser->set_options({$name=>$value,...});
+
+ # XML catalogs
+
+ $parser->load_catalog( $catalog_file );
+
+=head1 PARSING
+
+A XML document is read into a data structure such as a DOM tree by a piece of
+software, called a parser. XML::LibXML currently provides four different parser
+interfaces:
+
+
+=over 4
+
+=item *
+
+A DOM Pull-Parser
+
+
+
+=item *
+
+A DOM Push-Parser
+
+
+
+=item *
+
+A SAX Parser
+
+
+
+=item *
+
+A DOM based SAX Parser.
+
+
+
+=back
+
+
+=head2 Creating a Parser Instance
+
+XML::LibXML provides an OO interface to the libxml2 parser functions. Thus you
+have to create a parser instance before you can parse any XML data.
+
+=over 4
+
+=item new
+
+
+ $parser = XML::LibXML->new();
+ $parser = XML::LibXML->new(option=>value, ...);
+ $parser = XML::LibXML->new({option=>value, ...});
+
+Create a new XML and HTML parser instance. Each parser instance holds default
+values for various parser options. Optionally, one can pass a hash reference or
+a list of option => value pairs to set a different default set of options.
+Unless specified otherwise, the options C<<<<<< load_ext_dtd >>>>>>, C<<<<<< expand_entities >>>>>>, and C<<<<<< huge >>>>>> are set to 1. See L<<<<<< Parser Options >>>>>> for a list of libxml2 parser's options.
+
+
+
+=back
+
+
+=head2 DOM Parser
+
+One of the common parser interfaces of XML::LibXML is the DOM parser. This
+parser reads XML data into a DOM like data structure, so each tag can get
+accessed and transformed.
+
+XML::LibXML's DOM parser is not only capable to parse XML data, but also
+(strict) HTML files. There are three ways to parse documents - as a string, as
+a Perl filehandle, or as a filename/URL. The return value from each is a L<<<<<< XML::LibXML::Document >>>>>> object, which is a DOM object.
+
+All of the functions listed below will throw an exception if the document is
+invalid. To prevent this causing your program exiting, wrap the call in an
+eval{} block
+
+=over 4
+
+=item load_xml
+
+
+ $dom = XML::LibXML->load_xml(
+ location => $file_or_url
+ # parser options ...
+ );
+ $dom = XML::LibXML->load_xml(
+ string => $xml_string
+ # parser options ...
+ );
+ $dom = XML::LibXML->load_xml({
+ IO => $perl_file_handle
+ # parser options ...
+ );
+ $dom = $parser->load_xml(...);
+
+
+This function is available since XML::LibXML 1.70. It provides easy to use
+interface to the XML parser that parses given file (or URL), string, or input
+stream to a DOM tree. The arguments can be passed in a HASH reference or as
+name => value pairs. The function can be called as a class method or an object
+method. In both cases it internally creates a new parser instance passing the
+specified parser options; if called as an object method, it clones the original
+parser (preserving its settings) and additionally applies the specified options
+to the new parser. See the constructor C<<<<<< new >>>>>> and L<<<<<< Parser Options >>>>>> for more information.
+
+
+=item load_xml
+
+
+ $dom = XML::LibXML->load_html(...);
+ $dom = $parser->load_html(...);
+
+
+This function is available since XML::LibXML 1.70. It has the same usage as C<<<<<< load_xml >>>>>>, providing interface to the HTML parser. See C<<<<<< load_xml >>>>>> for more information.
+
+
+Parsing HTML may cause problems, especially if the ampersand ('&') is used.
+This is a common problem if HTML code is parsed that contains links to
+CGI-scripts. Such links cause the parser to throw errors. In such cases libxml2
+still parses the entire document as there was no error, but the error causes
+XML::LibXML to stop the parsing process. However, the document is not lost.
+Such HTML documents should be parsed using the I<<<<<< recover >>>>>> flag. By default recovering is deactivated.
+
+The functions described above are implemented to parse well formed documents.
+In some cases a program gets well balanced XML instead of well formed documents
+(e.g. a XML fragment from a Database). With XML::LibXML it is not required to
+wrap such fragments in the code, because XML::LibXML is capable even to parse
+well balanced XML fragments.
+
+=over 4
+
+=item parse_balanced_chunk
+
+ $fragment = $parser->parse_balanced_chunk( $wbxmlstring, $encoding );
+
+This function parses a well balanced XML string into a L<<<<<< XML::LibXML::DocumentFragment >>>>>>. The first arguments contains the input string, the optional second argument
+can be used to specify character encoding of the input (UTF-8 is assumed by
+default).
+
+
+=item parse_xml_chunk
+
+This is the old name of parse_balanced_chunk(). Because it may causes confusion
+with the push parser interface, this function should not be used anymore.
+
+
+
+=back
+
+By default XML::LibXML does not process XInclude tags within a XML Document
+(see options section below). XML::LibXML allows to post process a document to
+expand XInclude tags.
+
+=over 4
+
+=item process_xincludes
+
+ $parser->process_xincludes( $doc );
+
+After a document is parsed into a DOM structure, you may want to expand the
+documents XInclude tags. This function processes the given document structure
+and expands all XInclude tags (or throws an error) by using the flags and
+callbacks of the given parser instance.
+
+Note that the resulting Tree contains some extra nodes (of type
+XML_XINCLUDE_START and XML_XINCLUDE_END) after successfully processing the
+document. These nodes indicate where data was included into the original tree.
+if the document is serialized, these extra nodes will not show up.
+
+Remember: A Document with processed XIncludes differs from the original
+document after serialization, because the original XInclude tags will not get
+restored!
+
+If the parser flag "expand_xincludes" is set to 1, you need not to post process
+the parsed document.
+
+
+=item processXIncludes
+
+ $parser->processXIncludes( $doc );
+
+This is an alias to process_xincludes, but through a JAVA like function name.
+
+
+=item parse_file
+
+ $doc = $parser->parse_file( $xmlfilename );
+
+This function parses an XML document from a file or network; $xmlfilename can
+be either a filename or an URL. Note that for parsing files, this function is
+the fastest choice, about 6-8 times faster then parse_fh().
+
+
+=item parse_fh
+
+ $doc = $parser->parse_fh( $io_fh );
+
+parse_fh() parses a IOREF or a subclass of IO::Handle.
+
+Because the data comes from an open handle, libxml2's parser does not know
+about the base URI of the document. To set the base URI one should use
+parse_fh() as follows:
+
+
+
+ my $doc = $parser->parse_fh( $io_fh, $baseuri );
+
+
+=item parse_string
+
+ $doc = $parser->parse_string( $xmlstring);
+
+This function is similar to parse_fh(), but it parses a XML document that is
+available as a single string in memory. Again, you can pass an optional base
+URI to the function.
+
+
+
+ my $doc = $parser->parse_string( $xmlstring, $baseuri );
+
+
+=item parse_html_file
+
+ $doc = $parser->parse_html_file( $htmlfile, \%opts );
+
+Similar to parse_file() but parses HTML (strict) documents; $htmlfile can be
+filename or URL.
+
+An optional second argument can be used to pass some options to the HTML parser
+as a HASH reference. See options labeled with HTML in L<<<<<< Parser Options >>>>>>.
+
+
+=item parse_html_fh
+
+ $doc = $parser->parse_html_fh( $io_fh, \%opts );
+
+Similar to parse_fh() but parses HTML (strict) streams.
+
+An optional second argument can be used to pass some options to the HTML parser
+as a HASH reference. See options labeled with HTML in L<<<<<< Parser Options >>>>>>.
+
+Note: encoding option may not work correctly with this function in libxml2 <
+2.6.27 if the HTML file declares charset using a META tag.
+
+
+=item parse_html_string
+
+ $doc = $parser->parse_html_string( $htmlstring, \%opts );
+
+Similar to parse_string() but parses HTML (strict) strings.
+
+An optional second argument can be used to pass some options to the HTML parser
+as a HASH reference. See options labeled with HTML in L<<<<<< Parser Options >>>>>>.
+
+
+
+=back
+
+
+=back
+
+
+=head2 Push Parser
+
+XML::LibXML provides a push parser interface. Rather than pulling the data from
+a given source the push parser waits for the data to be pushed into it.
+
+This allows one to parse large documents without waiting for the parser to
+finish. The interface is especially useful if a program needs to pre-process
+the incoming pieces of XML (e.g. to detect document boundaries).
+
+While XML::LibXML parse_*() functions force the data to be a well-formed XML,
+the push parser will take any arbitrary string that contains some XML data. The
+only requirement is that all the pushed strings are together a well formed
+document. With the push parser interface a program can interrupt the parsing
+process as required, where the parse_*() functions give not enough flexibility.
+
+Different to the pull parser implemented in parse_fh() or parse_file(), the
+push parser is not able to find out about the documents end itself. Thus the
+calling program needs to indicate explicitly when the parsing is done.
+
+In XML::LibXML this is done by a single function:
+
+=over 4
+
+=item parse_chunk
+
+ $parser->parse_chunk($string, $terminate);
+
+parse_chunk() tries to parse a given chunk of data, which isn't necessarily
+well balanced data. The function takes two parameters: The chunk of data as a
+string and optional a termination flag. If the termination flag is set to a
+true value (e.g. 1), the parsing will be stopped and the resulting document
+will be returned as the following example describes:
+
+
+
+ my $parser = XML::LibXML->new;
+ for my $string ( "<", "foo", ' bar="hello world"', "/>") {
+ $parser->parse_chunk( $string );
+ }
+ my $doc = $parser->parse_chunk("", 1); # terminate the parsing
+
+
+
+=back
+
+Internally XML::LibXML provides three functions that control the push parser
+process:
+
+=over 4
+
+=item init_push
+
+ $parser->init_push();
+
+Initializes the push parser.
+
+
+=item push
+
+ $parser->push(@data);
+
+This function pushes the data stored inside the array to libxml2's parser. Each
+entry in @data must be a normal scalar! This method can be called repeatedly.
+
+
+=item finish_push
+
+ $doc = $parser->finish_push( $recover );
+
+This function returns the result of the parsing process. If this function is
+called without a parameter it will complain about non well-formed documents. If
+$restore is 1, the push parser can be used to restore broken or non well formed
+(XML) documents as the following example shows:
+
+
+
+ eval {
+ $parser->push( "<foo>", "bar" );
+ $doc = $parser->finish_push(); # will report broken XML
+ };
+ if ( $@ ) {
+ # ...
+ }
+
+This can be annoying if the closing tag is missed by accident. The following
+code will restore the document:
+
+
+
+ eval {
+ $parser->push( "<foo>", "bar" );
+ $doc = $parser->finish_push(1); # will return the data parsed
+ # unless an error happened
+ };
+
+ print $doc->toString(); # returns "<foo>bar</foo>"
+
+Of course finish_push() will return nothing if there was no data pushed to the
+parser before.
+
+
+
+=back
+
+
+=head2 Pull Parser (Reader)
+
+XML::LibXML also provides a pull-parser interface similar to the XmlReader
+interface in .NET. This interface is almost streaming, and is usually faster
+and simpler to use than SAX. See L<<<<<< XML::LibXML::Reader >>>>>>.
+
+
+=head2 Direct SAX Parser
+
+XML::LibXML provides a direct SAX parser in the L<<<<<< XML::LibXML::SAX >>>>>> module.
+
+
+=head2 DOM based SAX Parser
+
+XML::LibXML also provides a DOM based SAX parser. The SAX parser is defined in
+the module XML::LibXML::SAX::Parser. As it is not a stream based parser, it
+parses documents into a DOM and traverses the DOM tree instead.
+
+The API of this parser is exactly the same as any other Perl SAX2 parser. See
+XML::SAX::Intro for details.
+
+Aside from the regular parsing methods, you can access the DOM tree traverser
+directly, using the generate() method:
+
+
+
+ my $doc = build_yourself_a_document();
+ my $saxparser = $XML::LibXML::SAX::Parser->new( ... );
+ $parser->generate( $doc );
+
+This is useful for serializing DOM trees, for example that you might have done
+prior processing on, or that you have as a result of XSLT processing.
+
+I<<<<<< WARNING >>>>>>
+
+This is NOT a streaming SAX parser. As I said above, this parser reads the
+entire document into a DOM and serialises it. Some people couldn't read that in
+the paragraph above so I've added this warning. If you want a streaming SAX
+parser look at the L<<<<<< XML::LibXML::SAX >>>>>> man page
+
+
+=head1 SERIALIZATION
+
+XML::LibXML provides some functions to serialize nodes and documents. The
+serialization functions are described on the L<<<<<< XML::LibXML::Node >>>>>> manpage or the L<<<<<< XML::LibXML::Document >>>>>> manpage. XML::LibXML checks three global flags that alter the serialization
+process:
+
+
+=over 4
+
+=item *
+
+skipXMLDeclaration
+
+
+
+=item *
+
+skipDTD
+
+
+
+=item *
+
+setTagCompression
+
+
+
+=back
+
+of that three functions only setTagCompression is available for all
+serialization functions.
+
+Because XML::LibXML does these flags not itself, one has to define them locally
+as the following example shows:
+
+
+
+ local $XML::LibXML::skipXMLDeclaration = 1;
+ local $XML::LibXML::skipDTD = 1;
+ local $XML::LibXML::setTagCompression = 1;
+
+If skipXMLDeclaration is defined and not '0', the XML declaration is omitted
+during serialization.
+
+If skipDTD is defined and not '0', an existing DTD would not be serialized with
+the document.
+
+If setTagCompression is defined and not '0' empty tags are displayed as open
+and closing tags rather than the shortcut. For example the empty tag I<<<<<< foo >>>>>> will be rendered as I<<<<<< <foo></foo> >>>>>> rather than I<<<<<< <foo/> >>>>>>.
+
+
+=head1 PARSER OPTIONS
+
+Handling of libxml2 parser options has been unified and improved in XML::LibXML
+1.70. You can now set default options for a particular parser instance by
+passing them to the constructor as C<<<<<< XML::LibXML->new({name=>value, ...}) >>>>>> or C<<<<<< XML::LibXML->new(name=>value,...) >>>>>>. The options can be queried and changed using the following methods (pre-1.70
+interfaces such as C<<<<<< $parser->load_ext_dtd(0) >>>>>> also exist, see below):
+
+=over 4
+
+=item option_exists
+
+ $parser->option_exists($name);
+
+Returns 1 if the current XML::LibXML version supports the option C<<<<<< $name >>>>>>, otherwise returns 0 (note that this does not necessarily mean that the option
+is supported by the underlying libxml2 library).
+
+
+=item get_option
+
+ $parser->get_option($name);
+
+Returns the current value of the parser option C<<<<<< $name >>>>>>.
+
+
+=item set_option
+
+ $parser->set_option($name,$value);
+
+Sets option C<<<<<< $name >>>>>> to value C<<<<<< $value >>>>>>.
+
+
+=item set_options
+
+ $parser->set_options({$name=>$value,...});
+
+Sets multiple parsing options at once.
+
+
+
+=back
+
+IMPORTANT NOTE: This documentation reflects the parser flags available in
+libxml2 2.7.3. Some options have no effect if an older version of libxml2 is
+used.
+
+Each of the flags listed below is labeled labeled
+
+=over 4
+
+=item /parser/
+
+if it can be used with a C<<<<<< XML::LibXML >>>>>> parser object (i.e. passed to C<<<<<< XML::LibXML->new >>>>>>, C<<<<<< XML::LibXML->set_option >>>>>>, etc.)
+
+
+=item /html/
+
+if it can be used passed to the C<<<<<< parse_html_* >>>>>> methods
+
+
+=item /reader/
+
+if it can be used with the C<<<<<< XML::LibXML::Reader >>>>>>.
+
+
+
+=back
+
+Unless specified otherwise, the default for boolean valued options is 0
+(false).
+
+The available options are:
+
+=over 4
+
+=item URI
+
+/parser, html, reader/
+
+In case of parsing strings or file handles, XML::LibXML doesn't know about the
+base uri of the document. To make relative references such as XIncludes work,
+one has to set a base URI, that is then used for the parsed document.
+
+
+=item line_numbers
+
+/parser, html, reader/
+
+If this option is activated, libxml2 will store the line number of each element
+node in the parsed document. The line number can be obtained using the C<<<<<< line_number() >>>>>> method of the C<<<<<< XML::LibXML::Node >>>>>> class (for non-element nodes this may report the line number of the containing
+element). The line numbers are also used for reporting positions of validation
+errors.
+
+IMPORTANT: Due to limitations in the libxml2 library line numbers greater than
+65535 will be returned as 65535. Unfortunatelly, this is a long and sad story,
+please see L<<<<<< http://bugzilla.gnome.org/show_bug.cgi?id=325533 >>>>>> for more details.
+
+
+=item encoding
+
+/html/
+
+character encoding of the input
+
+
+=item recover
+
+/parser, html, reader/
+
+recover from errors; possible values are 0, 1, and 2
+
+A true value turns on recovery mode which allows one to parse broken XML or
+HTML data. The recovery mode allows the parser to return the successfully
+parsed portion of the input document. This is useful for almost well-formed
+documents, where for example a closing tag is missing somewhere. Still,
+XML::LibXML will only parse until the first fatal (non-recoverable) error
+occurs, reporting recoverable parsing errors as warnings. To suppress even
+these warnings, use recover=>2.
+
+Note that validation is switched off automatically in recovery mode.
+
+
+=item expand_entities
+
+/parser, reader/
+
+substitute entities; possible values are 0 and 1; default is 1
+
+Note that although this flag disables entity substitution, it does not prevent
+the parser from loading external entities; when substitution of an external
+entity is disabled, the entity will be represented in the document tree by a
+XML_ENTITY_REF_NODE node whose subtree will be the content obtained by parsing
+the external resource; Although this is level of nesting is visible from the
+DOM it is transparent to XPath data model, so it is possible to match nodes in
+an unexpanded entity by the same XPath expression as if the entity was
+expanded. See also ext_ent_handler.
+
+
+=item ext_ent_handler
+
+/parser/
+
+Provide a custom external entity handler to be used when expand_entities is set
+to 1. Possible value is a subroutine reference.
+
+This feature does not work properly in libxml2 < 2.6.27!
+
+The subroutine provided is called whenever the parser needs to retrieve the
+content of an external entity. It is called with two arguments: the system ID
+(URI) and the public ID. The value returned by the subroutine is parsed as the
+content of the entity.
+
+This method can be used to completely disable entity loading, e.g. to prevent
+exploits of the type described at (L<<<<<< http://searchsecuritychannel.techtarget.com/generic/0,295582,sid97_gci1304703,00.html >>>>>>), where a service is tricked to expose its private data by letting it parse a
+remote file (RSS feed) that contains an entity reference to a local file (e.g. C<<<<<< /etc/fstab >>>>>>).
+
+A more granular solution to this problem, however, is provided by custom URL
+resolvers, as in
+
+ my $c = XML::LibXML::InputCallback->new();
+ sub match { # accept file:/ URIs except for XML catalogs in /etc/xml/
+ my ($uri) = @_;
+ return ($uri=~m{^file:/}
+ and $uri !~ m{^file:///etc/xml/})
+ ? 1 : 0;
+ }
+ $c->register_callbacks([ \&match, sub{}, sub{}, sub{} ]);
+ $parser->input_callbacks($c);
+
+
+
+
+=item load_ext_dtd
+
+/parser, reader/
+
+load the external DTD subset while parsing; possible values are 0 and 1. Unless
+specified, XML::LibXML sets this option to 1.
+
+This flag is also required for DTD Validation, to provide complete attribute,
+and to expand entities, regardless if the document has an internal subset. Thus
+switching off external DTD loading, will disable entity expansion, validation,
+and complete attributes on internal subsets as well.
+
+
+=item complete_attributes
+
+/parser, reader/
+
+create default DTD attributes; possible values are 0 and 1
+
+
+=item validation
+
+/parser, reader/
+
+validate with the DTD; possible values are 0 and 1
+
+
+=item suppress_errors
+
+/parser, html, reader/
+
+suppress error reports; possible values are 0 and 1
+
+
+=item suppress_warnings
+
+/parser, html, reader/
+
+suppress warning reports; possible values are 0 and 1
+
+
+=item pedantic_parser
+
+/parser, html, reader/
+
+pedantic error reporting; possible values are 0 and 1
+
+
+=item no_blanks
+
+/parser, html, reader/
+
+remove blank nodes; possible values are 0 and 1
+
+
+=item expand_xinclude or xinclude
+
+/parser, reader/
+
+Implement XInclude substitution; possible values are 0 and 1
+
+Expands XIinclude tags immediately while parsing the document. Note that the
+parser will use the URI resolvers installed via C<<<<<< XML::LibXML::InputCallback >>>>>> to parse the included document (if any).
+
+
+=item no_xinclude_nodes
+
+/parser, reader/
+
+do not generate XINCLUDE START/END nodes; possible values are 0 and 1
+
+
+=item no_network
+
+/parser, html, reader/
+
+Forbid network access; possible values are 0 and 1
+
+If set to true, all attempts to fetch non-local resources (such as DTD or
+external entities) will fail (unless custom callbacks are defined).
+
+It may be necessary to use the flag C<<<<<< recover >>>>>> for processing documents requiring such resources while networking is off.
+
+
+=item clean_namespaces
+
+/parser, reader/
+
+remove redundant namespaces declarations during parsing; possible values are 0
+and 1.
+
+
+=item no_cdata
+
+/parser, html, reader/
+
+merge CDATA as text nodes; possible values are 0 and 1
+
+
+=item no_basefix
+
+/parser, reader/
+
+not fixup XINCLUDE xml#base URIS; possible values are 0 and 1
+
+
+=item huge
+
+/parser, html, reader/
+
+relax any hardcoded limit from the parser; possible values are 0 and 1. Unless
+specified, XML::LibXML sets this option to 1.
+
+
+=item gdome
+
+/parser/
+
+THIS OPTION IS EXPERIMENTAL!
+
+Although quite powerful, XML:LibXML's DOM implementation is incomplete with
+respect to the DOM level 2 or level 3 specifications. XML::GDOME is based on
+libxml2 as well and and provides a rather complete DOM implementation by
+wrapping libgdome. This flag allows you to make use of XML::LibXML's full
+parser options and XML::GDOME's DOM implementation at the same time.
+
+To make use of this function, one has to install libgdome and configure
+XML::LibXML to use this library. For this you need to rebuild XML::LibXML!
+
+Note: this feature was not seriously tested in recent XML::LibXML releases.
+
+
+
+=back
+
+For compatibility with XML::LibXML versions prior to 1.70, the following
+methods are also supported for querying and setting the corresponding parser
+options (if called without arguments, the methods return the current value of
+the corresponding parser options; with an argument sets the option to a given
+value):
+
+
+
+ $parser->validation();
+ $parser->recover();
+ $parser->pedantic_parser();
+ $parser->line_numbers();
+ $parser->load_ext_dtd();
+ $parser->complete_attributes();
+ $parser->expand_xinclude();
+ $parser->gdome_dom();
+ $parser->clean_namespaces();
+ $parser->no_network();
+
+The following obsolete methods trigger parser options in some special way:
+
+=over 4
+
+=item recover_silently
+
+
+
+ $parser->recover_silently(1);;
+
+If called without an argument, returns true if the current value of the C<<<<<< recover >>>>>> parser option is 2 and returns false otherwise. With a true argument sets the C<<<<<< recover >>>>>> parser option to 2; with a false argument sets the C<<<<<< recover >>>>>> parser option to 0.
+
+
+=item expand_entities
+
+
+
+ $parser->expand_entities(0);
+
+Get/set the C<<<<<< expand_entities >>>>>> option. If called with a true argument, also turns the C<<<<<< load_ext_dtd >>>>>> option to 1.
+
+
+=item keep_blanks
+
+
+
+ $parser->keep_blanks(0);
+
+This is actually an oposite of the C<<<<<< no_blanks >>>>>> parser option. If used without an argument retrieves negated value of C<<<<<< no_blanks >>>>>>. If used with an argument sets C<<<<<< no_blanks >>>>>> to the oposite value.
+
+
+=item base_uri
+
+
+
+ $parser->base_uri( $your_base_uri );
+
+Get/set the C<<<<<< URI >>>>>> option.
+
+
+
+=back
+
+
+=head1 XML CATALOGS
+
+C<<<<<< libxml2 >>>>>> supports XML catalogs. Catalogs are used to map remote resources to their local
+copies. Using catalogs can speed up parsing processes if many external
+resources from remote addresses are loaded into the parsed documents (such as
+DTDs or XIncludes).
+
+Note that libxml2 has a global pool of loaded catalogs, so if you apply the
+method C<<<<<< load_catalog >>>>>> to one parser instance, all parser instances will start using the catalog (in
+addition to other previously loaded catalogs).
+
+Note also that catalogs are not used when a custom external entity handler is
+specified. At the current state it is not possible to make use of both types of
+resolving systems at the same time.
+
+=over 4
+
+=item load_catalog
+
+ $parser->load_catalog( $catalog_file );
+
+Loads the XML catalog file $catalog_file.
+
+
+
+=back
+
+
+=head1 ERROR REPORTING
+
+XML::LibXML throws exceptions during parsing, validation or XPath processing
+(and some other occasions). These errors can be caught by using I<<<<<< eval >>>>>> blocks. The error is stored in I<<<<<< $@ >>>>>>. There are two implementations: the old one throws $@ which is just a message
+string, in the new one $@ is an object from the class XML::LibXML::Error; this
+class overrides the operator "" so that when printed, the object flattens to
+the usual error message.
+
+XML::LibXML throws errors as they occur. This is a very common misunderstanding
+in the use of XML::LibXML. If the eval is omitted, XML::LibXML will always halt
+your script by "croaking" (see Carp man page for details).
+
+Also note that an increasing number of functions throw errors if bad data is
+passed as arguments. If you cannot assure valid data passed to XML::LibXML you
+should eval these functions.
+
+Note: since version 1.59, get_last_error() is no longer available in
+XML::LibXML for thread-safety reasons.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Pattern.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Pattern.pod
new file mode 100755
index 00000000000..f8a05c67b91
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Pattern.pod
@@ -0,0 +1,107 @@
+=head1 NAME
+
+XML::LibXML::Pattern - XML::LibXML::Pattern - interface to libxml2 XPath patterns
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ my $pattern = new XML::LibXML::Pattern('/x:html/x:body//x:div', { 'x' => 'http://www.w3.org/1999/xhtml' });
+ # test a match on a XML::LibXML::Node $node
+
+ if ($pattern->matchesNode($node)) { ... }
+
+ # or on a XML::LibXML::Reader
+
+ if ($reader->matchesPattern($pattern)) { ... }
+
+ # or skip reading all nodes that do not match
+
+ print $reader->nodePath while $reader->nextPatternMatch($pattern);
+
+ $pattern = XML::LibXML::Pattern->new( pattern, { prefix => namespace_URI, ... } );
+ $bool = $pattern->matchesNode($node);
+
+=head1 DESCRIPTION
+
+This is a perl interface to libxml2's pattern matching support I<<<<<< http://xmlsoft.org/html/libxml-pattern.html >>>>>>. This feature requires recent versions of libxml2.
+
+Patterns are a small subset of XPath language, which is limitted to
+(disjunctions of) location paths involving the child and descendant axes in
+abbreviated form as described by the extended BNF given below:
+
+
+
+ Selector ::= Path ( '|' Path )*
+ Path ::= ('.//' | '//' | '/' )? Step ( '/' Step )*
+ Step ::= '.' | NameTest
+ NameTest ::= QName | '*' | NCName ':' '*'
+
+For readability, whitespace may be used in selector XPath expressions even
+though not explicitly allowed by the grammar: whitespace may be freely added
+within patterns before or after any token, where
+
+
+
+ token ::= '.' | '/' | '//' | '|' | NameTest
+
+Note that no predicates or attribute tests are allowed.
+
+Patterns are particularly useful for stream parsing provided via the C<<<<<< XML::LibXML::Reader >>>>>> interface.
+
+=over 4
+
+=item new()
+
+ $pattern = XML::LibXML::Pattern->new( pattern, { prefix => namespace_URI, ... } );
+
+The constructor of a pattern takes a pattern expression (as described by the
+BNF grammar above) and an optional HASH reference mapping prefixes to namespace
+URIs. The method returns a compiled pattern object.
+
+Note that if the document has a default namespace, it must still be given an
+prefix in order to be matched (as demanded by the XPath 1.0 specification). For
+example, to match an element C<<<<<< <a xmlns="http://foo.bar"</a> >>>>>>, one should use a pattern like this:
+
+
+
+ $pattern = XML::LibXML::Pattern->new( 'foo:a', { foo => 'http://foo.bar' });
+
+
+=item matchesNode($node)
+
+ $bool = $pattern->matchesNode($node);
+
+Given a XML::LibXML::Node object, returns a true value if the node is matched
+by the compiled pattern expression.
+
+
+
+=back
+
+
+=head1 SEE ALSO
+
+L<<<<<< XML::LibXML::Reader >>>>>> for other methods involving compiled patterns.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pm
new file mode 100755
index 00000000000..ec7b54451ab
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pm
@@ -0,0 +1,212 @@
+# $Id: Reader.pm,v 1.1.2.1 2004/04/20 20:09:48 pajas Exp $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+package XML::LibXML::Reader;
+
+use XML::LibXML;
+use Carp;
+use strict;
+use warnings;
+
+use vars qw ($VERSION);
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use 5.008_000;
+
+BEGIN {
+ UNIVERSAL::can('XML::LibXML::Reader','_newForFile') or
+ croak("Cannot use XML::LibXML::Reader module - ".
+ "your libxml2 is compiled without reader support!");
+}
+
+use base qw(Exporter);
+use constant {
+ XML_READER_TYPE_NONE => 0,
+ XML_READER_TYPE_ELEMENT => 1,
+ XML_READER_TYPE_ATTRIBUTE => 2,
+ XML_READER_TYPE_TEXT => 3,
+ XML_READER_TYPE_CDATA => 4,
+ XML_READER_TYPE_ENTITY_REFERENCE => 5,
+ XML_READER_TYPE_ENTITY => 6,
+ XML_READER_TYPE_PROCESSING_INSTRUCTION => 7,
+ XML_READER_TYPE_COMMENT => 8,
+ XML_READER_TYPE_DOCUMENT => 9,
+ XML_READER_TYPE_DOCUMENT_TYPE => 10,
+ XML_READER_TYPE_DOCUMENT_FRAGMENT => 11,
+ XML_READER_TYPE_NOTATION => 12,
+ XML_READER_TYPE_WHITESPACE => 13,
+ XML_READER_TYPE_SIGNIFICANT_WHITESPACE => 14,
+ XML_READER_TYPE_END_ELEMENT => 15,
+ XML_READER_TYPE_END_ENTITY => 16,
+ XML_READER_TYPE_XML_DECLARATION => 17,
+
+ XML_READER_NONE => -1,
+ XML_READER_START => 0,
+ XML_READER_ELEMENT => 1,
+ XML_READER_END => 2,
+ XML_READER_EMPTY => 3,
+ XML_READER_BACKTRACK => 4,
+ XML_READER_DONE => 5,
+ XML_READER_ERROR => 6
+};
+use vars qw( @EXPORT @EXPORT_OK %EXPORT_TAGS );
+
+sub CLONE_SKIP { 1 }
+
+BEGIN {
+
+%EXPORT_TAGS = (
+ types =>
+ [qw(
+ XML_READER_TYPE_NONE
+ XML_READER_TYPE_ELEMENT
+ XML_READER_TYPE_ATTRIBUTE
+ XML_READER_TYPE_TEXT
+ XML_READER_TYPE_CDATA
+ XML_READER_TYPE_ENTITY_REFERENCE
+ XML_READER_TYPE_ENTITY
+ XML_READER_TYPE_PROCESSING_INSTRUCTION
+ XML_READER_TYPE_COMMENT
+ XML_READER_TYPE_DOCUMENT
+ XML_READER_TYPE_DOCUMENT_TYPE
+ XML_READER_TYPE_DOCUMENT_FRAGMENT
+ XML_READER_TYPE_NOTATION
+ XML_READER_TYPE_WHITESPACE
+ XML_READER_TYPE_SIGNIFICANT_WHITESPACE
+ XML_READER_TYPE_END_ELEMENT
+ XML_READER_TYPE_END_ENTITY
+ XML_READER_TYPE_XML_DECLARATION
+ )],
+ states =>
+ [qw(
+ XML_READER_NONE
+ XML_READER_START
+ XML_READER_ELEMENT
+ XML_READER_END
+ XML_READER_EMPTY
+ XML_READER_BACKTRACK
+ XML_READER_DONE
+ XML_READER_ERROR
+ )]
+);
+@EXPORT = (@{$EXPORT_TAGS{types}},@{$EXPORT_TAGS{states}});
+@EXPORT_OK = @EXPORT;
+$EXPORT_TAGS{all}=\@EXPORT_OK;
+}
+
+{
+ my %props = (
+ load_ext_dtd => 1, # load the external subset
+ complete_attributes => 2, # default DTD attributes
+ validation => 3, # validate with the DTD
+ expand_entities => 4, # substitute entities
+ );
+ sub getParserProp {
+ my ($self, $name) = @_;
+ my $prop = $props{$name};
+ return undef unless defined $prop;
+ return $self->_getParserProp($prop);
+ }
+ sub setParserProp {
+ my $self = shift;
+ my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_;
+ my ($key, $value);
+ while (($key,$value) = each %args) {
+ my $prop = $props{ $key };
+ $self->_setParserProp($prop,$value);
+ }
+ return;
+ }
+
+ my (%string_pool,%rng_pool,%xsd_pool); # used to preserve data passed to the reader
+ sub new {
+ my ($class) = shift;
+ my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_;
+ my $encoding = $args{encoding};
+ my $URI = $args{URI};
+ $URI="$URI" if defined $URI; # stringify in case it is an URI object
+ my $options = XML::LibXML->_parser_options(\%args);
+
+ my $self = undef;
+ if ( defined $args{location} ) {
+ $self = $class->_newForFile( $args{location}, $encoding, $options );
+ }
+ elsif ( defined $args{string} ) {
+ $self = $class->_newForString( $args{string}, $URI, $encoding, $options );
+ $string_pool{$self} = \$args{string};
+ }
+ elsif ( defined $args{IO} ) {
+ $self = $class->_newForIO( $args{IO}, $URI, $encoding, $options );
+ }
+ elsif ( defined $args{DOM} ) {
+ croak("DOM must be a XML::LibXML::Document node")
+ unless UNIVERSAL::isa($args{DOM}, 'XML::LibXML::Document');
+ $self = $class->_newForDOM( $args{DOM} );
+ }
+ elsif ( defined $args{FD} ) {
+ my $fd = fileno($args{FD});
+ $self = $class->_newForFd( $fd, $URI, $encoding, $options );
+ }
+ else {
+ croak("XML::LibXML::Reader->new: specify location, string, IO, DOM, or FD");
+ }
+ if ($args{RelaxNG}) {
+ if (ref($args{RelaxNG})) {
+ $rng_pool{$self} = \$args{RelaxNG};
+ $self->_setRelaxNG($args{RelaxNG});
+ } else {
+ $self->_setRelaxNGFile($args{RelaxNG});
+ }
+ }
+ if ($args{Schema}) {
+ if (ref($args{Schema})) {
+ $xsd_pool{$self} = \$args{Schema};
+ $self->_setXSD($args{Schema});
+ } else {
+ $self->_setXSDFile($args{Schema});
+ }
+ }
+ return $self;
+ }
+ sub DESTROY {
+ my $self = shift;
+ delete $string_pool{$self};
+ delete $rng_pool{$self};
+ delete $xsd_pool{$self};
+ $self->_DESTROY;
+ }
+}
+sub close {
+ my ($reader) = @_;
+ # _close return -1 on failure, 0 on success
+ # perl close returns 0 on failure, 1 on success
+ return $reader->_close == 0 ? 1 : 0;
+}
+
+sub preservePattern {
+ my $reader=shift;
+ my ($pattern,$ns_map)=@_;
+ if (ref($ns_map) eq 'HASH') {
+ # translate prefix=>URL hash to a (URL,prefix) list
+ $reader->_preservePattern($pattern,[reverse %$ns_map]);
+ } else {
+ $reader->_preservePattern(@_);
+ }
+}
+
+sub nodePath {
+ my $reader=shift;
+ my $path = $reader->_nodePath;
+ $path=~s/\[\d+\]//g; # make /foo[1]/bar[1] just /foo/bar, since
+ # sibling count in the buffered fragment is
+ # basically random and generally misleading
+ return $path;
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pod
new file mode 100755
index 00000000000..5c787ba3b30
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Reader.pod
@@ -0,0 +1,669 @@
+=head1 NAME
+
+XML::LibXML::Reader - XML::LibXML::Reader - interface to libxml2 pull parser
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML::Reader;
+
+
+
+ my $reader = new XML::LibXML::Reader(location => "file.xml")
+ or die "cannot read file.xml\n";
+ while ($reader->read) {
+ processNode($reader);
+ }
+
+
+
+ sub processNode {
+ $reader = shift;
+ printf "%d %d %s %d\n", ($reader->depth,
+ $reader->nodeType,
+ $reader->name,
+ $reader->isEmptyElement);
+ }
+
+or
+
+
+
+ $reader = new XML::LibXML::Reader(location => "file.xml")
+ or die "cannot read file.xml\n";
+ $reader->preservePattern('//table/tr');
+ $reader->finish;
+ print $reader->document->toString(1);
+
+
+=head1 DESCRIPTION
+
+This is a perl interface to libxml2's pull-parser implementation xmlTextReader I<<<<<< http://xmlsoft.org/html/libxml-xmlreader.html >>>>>>. This feature requires at least libxml2-2.6.21. Pull-parser (StAX in Java,
+XmlReader in C#) use an iterator approach to parse a xml-file. They are easier
+to program than event-based parser (SAX) and much more lightweight than
+tree-based parser (DOM), which load the complete tree into memory.
+
+The Reader acts as a cursor going forward on the document stream and stopping
+at each node in the way. At every point DOM-like methods of the Reader object
+allow to examine the current node (name, namespace, attributes, etc.)
+
+The user's code keeps control of the progress and simply calls the C<<<<<< read() >>>>>> function repeatedly to progress to the next node in the document order. Other
+functions provide means for skipping complete sub-trees, or nodes until a
+specific element, etc.
+
+At every time, only a very limited portion of the document is kept in the
+memory, which makes the API more memory-efficient than using DOM. However, it
+is also possible to mix Reader with DOM. At every point the user may copy the
+current node (optionally expanded into a complete sub-tree) from the processed
+document to another DOM tree, or to instruct the Reader to collect sub-document
+in form of a DOM tree consisting of selected nodes.
+
+Reader API also supports namespaces, xml:base, entity handling, and DTD
+validation. Schema and RelaxNG validation support will probably be added in
+some later revision of the Perl interface.
+
+The naming of methods compared to libxml2 and C# XmlTextReader has been changed
+slightly to match the conventions of XML::LibXML. Some functions have been
+changed or added with respect to the C interface.
+
+
+=head1 CONSTRUCTOR
+
+Depending on the XML source, the Reader object can be created with either of:
+
+
+
+ my $reader = XML::LibXML::Reader->new( location => "file.xml", ... );
+ my $reader = XML::LibXML::Reader->new( string => $xml_string, ... );
+ my $reader = XML::LibXML::Reader->new( IO => $file_handle, ... );
+ my $reader = XML::LibXML::Reader->new( FD => fileno(STDIN), ... );
+ my $reader = XML::LibXML::Reader->new( DOM => $dom, ... );
+
+where ... are (optional) reader options described below in L<<<<<< Reader options >>>>>> or various parser options described in L<<<<<< XML::LibXML::Parser >>>>>>. The constructor recognizes the following XML sources:
+
+
+=head2 Source specification
+
+=over 4
+
+=item location
+
+Read XML from a local file or URL.
+
+
+=item string
+
+Read XML from a string.
+
+
+=item IO
+
+Read XML a Perl IO filehandle.
+
+
+=item FD
+
+Read XML from a file descriptor (bypasses Perl I/O layer, only applicable to
+filehandles for regular files or pipes). Possibly faster than IO.
+
+
+=item DOM
+
+Use reader API to walk through a pre-parsed L<<<<<< XML::LibXML::Document >>>>>>.
+
+
+
+=back
+
+
+=head2 Reader options
+
+=over 4
+
+=item encoding => $encoding
+
+override document encoding.
+
+
+=item RelaxNG => $rng_schema
+
+can be used to pass either a L<<<<<< XML::LibXML::RelaxNG >>>>>> object or a filename or URL of a RelaxNG schema to the constructor. The schema
+is then used to validate the document as it is processed.
+
+
+=item Schema => $xsd_schema
+
+can be used to pass either a L<<<<<< XML::LibXML::Schema >>>>>> object or a filename or URL of a W3C XSD schema to the constructor. The schema
+is then used to validate the document as it is processed.
+
+
+=item ...
+
+the reader further supports various parser options described in L<<<<<< XML::LibXML::Parser >>>>>> (specificly those labeled by /reader/).
+
+
+
+=back
+
+
+=head1 METHODS CONTROLLING PARSING PROGRESS
+
+=over 4
+
+=item read ()
+
+Moves the position to the next node in the stream, exposing its properties.
+
+Returns 1 if the node was read successfully, 0 if there is no more nodes to
+read, or -1 in case of error
+
+
+=item readAttributeValue ()
+
+Parses an attribute value into one or more Text and EntityReference nodes.
+
+Returns 1 in case of success, 0 if the reader was not positioned on an
+attribute node or all the attribute values have been read, or -1 in case of
+error.
+
+
+=item readState ()
+
+Gets the read state of the reader. Returns the state value, or -1 in case of
+error. The module exports constants for the Reader states, see STATES below.
+
+
+=item depth ()
+
+The depth of the node in the tree, starts at 0 for the root node.
+
+
+=item next ()
+
+Skip to the node following the current one in the document order while avoiding
+the sub-tree if any. Returns 1 if the node was read successfully, 0 if there is
+no more nodes to read, or -1 in case of error.
+
+
+=item nextElement (localname?,nsURI?)
+
+Skip nodes following the current one in the document order until a specific
+element is reached. The element's name must be equal to a given localname if
+defined, and its namespace must equal to a given nsURI if defined. Either of
+the arguments can be undefined (or omitted, in case of the latter or both).
+
+Returns 1 if the element was found, 0 if there is no more nodes to read, or -1
+in case of error.
+
+
+=item nextPatternMatch (compiled_pattern)
+
+Skip nodes following the current one in the document order until an element
+matching a given compiled pattern is reached. See L<<<<<< XML::LibXML::Pattern >>>>>> for information on compiled patterns. See also the C<<<<<< matchesPattern >>>>>> method.
+
+Returns 1 if the element was found, 0 if there is no more nodes to read, or -1
+in case of error.
+
+
+=item skipSiblings ()
+
+Skip all nodes on the same or lower level until the first node on a higher
+level is reached. In particular, if the current node occurs in an element, the
+reader stops at the end tag of the parent element, otherwise it stops at a node
+immediately following the parent node.
+
+Returns 1 if successful, 0 if end of the document is reached, or -1 in case of
+error.
+
+
+=item nextSibling ()
+
+It skips to the node following the current one in the document order while
+avoiding the sub-tree if any.
+
+Returns 1 if the node was read successfully, 0 if there is no more nodes to
+read, or -1 in case of error
+
+
+=item nextSiblingElement (name?,nsURI?)
+
+Like nextElement but only processes sibling elements of the current node
+(moving forward using C<<<<<< nextSibling () >>>>>> rather than C<<<<<< read () >>>>>>, internally).
+
+Returns 1 if the element was found, 0 if there is no more sibling nodes, or -1
+in case of error.
+
+
+=item finish ()
+
+Skip all remaining nodes in the document, reaching end of the document.
+
+Returns 1 if successful, 0 in case of error.
+
+
+=item close ()
+
+This method releases any resources allocated by the current instance and closes
+any underlying input. It returns 0 on failure and 1 on success. This method is
+automatically called by the destructor when the reader is forgotten, therefore
+you do not have to call it directly.
+
+
+
+=back
+
+
+=head1 METHODS EXTRACTING INFORMATION
+
+=over 4
+
+=item name ()
+
+Returns the qualified name of the current node, equal to (Prefix:)LocalName.
+
+
+=item nodeType ()
+
+Returns the type of the current node. See NODE TYPES below.
+
+
+=item localName ()
+
+Returns the local name of the node.
+
+
+=item prefix ()
+
+Returns the prefix of the namespace associated with the node.
+
+
+=item namespaceURI ()
+
+Returns the URI defining the namespace associated with the node.
+
+
+=item isEmptyElement ()
+
+Check if the current node is empty, this is a bit bizarre in the sense that
+<a/> will be considered empty while <a></a> will not.
+
+
+=item hasValue ()
+
+Returns true if the node can have a text value.
+
+
+=item value ()
+
+Provides the text value of the node if present or undef if not available.
+
+
+=item readInnerXml ()
+
+Reads the contents of the current node, including child nodes and markup.
+Returns a string containing the XML of the node's content, or undef if the
+current node is neither an element nor attribute, or has no child nodes.
+
+
+=item readOuterXml ()
+
+Reads the contents of the current node, including child nodes and markup.
+
+Returns a string containing the XML of the node including its content, or undef
+if the current node is neither an element nor attribute.
+
+
+=item nodePath()
+
+Returns a cannonical location path to the current element from the root node to
+the current node. Namespaced elements are matched by '*', because there is no
+way to declare prefixes within XPath patterns. Unlike C<<<<<< XML::LibXML::Node::nodePath() >>>>>>, this function does not provide sibling counts (i.e. instead of e.g. '/a/b[1]'
+and '/a/b[2]' you get '/a/b' for both matches).
+
+
+=item matchesPattern(compiled_pattern)
+
+Returns a true value if the current node matches a compiled pattern. See L<<<<<< XML::LibXML::Pattern >>>>>> for information on compiled patterns. See also the C<<<<<< nextPatternMatch >>>>>> method.
+
+
+
+=back
+
+
+=head1 METHODS EXTRACTING DOM NODES
+
+=over 4
+
+=item document ()
+
+Provides access to the document tree built by the reader. This function can be
+used to collect the preserved nodes (see C<<<<<< preserveNode() >>>>>> and preservePattern).
+
+CAUTION: Never use this function to modify the tree unless reading of the whole
+document is completed!
+
+
+=item copyCurrentNode (deep)
+
+This function is similar a DOM function C<<<<<< copyNode() >>>>>>. It returns a copy of the currently processed node as a corresponding DOM
+object. Use deep = 1 to obtain the full sub-tree.
+
+
+=item preserveNode ()
+
+This tells the XML Reader to preserve the current node in the document tree. A
+document tree consisting of the preserved nodes and their content can be
+obtained using the method C<<<<<< document() >>>>>> once parsing is finished.
+
+Returns the node or NULL in case of error.
+
+
+=item preservePattern (pattern,\%ns_map)
+
+This tells the XML Reader to preserve all nodes matched by the pattern (which
+is a streaming XPath subset). A document tree consisting of the preserved nodes
+and their content can be obtained using the method C<<<<<< document() >>>>>> once parsing is finished.
+
+An optional second argument can be used to provide a HASH reference mapping
+prefixes used by the XPath to namespace URIs.
+
+The XPath subset available with this function is described at
+
+
+
+ http://www.w3.org/TR/xmlschema-1/#Selector
+
+and matches the production
+
+
+
+ Path ::= ('.//')? ( Step '/' )* ( Step | '@' NameTest )
+
+Returns a positive number in case of success and -1 in case of error
+
+
+
+=back
+
+
+=head1 METHODS PROCESSING ATTRIBUTES
+
+=over 4
+
+=item attributeCount ()
+
+Provides the number of attributes of the current node.
+
+
+=item hasAttributes ()
+
+Whether the node has attributes.
+
+
+=item getAttribute (name)
+
+Provides the value of the attribute with the specified qualified name.
+
+Returns a string containing the value of the specified attribute, or undef in
+case of error.
+
+
+=item getAttributeNs (localName, namespaceURI)
+
+Provides the value of the specified attribute.
+
+Returns a string containing the value of the specified attribute, or undef in
+case of error.
+
+
+=item getAttributeNo (no)
+
+Provides the value of the attribute with the specified index relative to the
+containing element.
+
+Returns a string containing the value of the specified attribute, or undef in
+case of error.
+
+
+=item isDefault ()
+
+Returns true if the current attribute node was generated from the default value
+defined in the DTD.
+
+
+=item moveToAttribute (name)
+
+Moves the position to the attribute with the specified local name and namespace
+URI.
+
+Returns 1 in case of success, -1 in case of error, 0 if not found
+
+
+=item moveToAttributeNo (no)
+
+Moves the position to the attribute with the specified index relative to the
+containing element.
+
+Returns 1 in case of success, -1 in case of error, 0 if not found
+
+
+=item moveToAttributeNs (localName,namespaceURI)
+
+Moves the position to the attribute with the specified local name and namespace
+URI.
+
+Returns 1 in case of success, -1 in case of error, 0 if not found
+
+
+=item moveToFirstAttribute ()
+
+Moves the position to the first attribute associated with the current node.
+
+Returns 1 in case of success, -1 in case of error, 0 if not found
+
+
+=item moveToNextAttribute ()
+
+Moves the position to the next attribute associated with the current node.
+
+Returns 1 in case of success, -1 in case of error, 0 if not found
+
+
+=item moveToElement ()
+
+Moves the position to the node that contains the current attribute node.
+
+Returns 1 in case of success, -1 in case of error, 0 if not moved
+
+
+=item isNamespaceDecl ()
+
+Determine whether the current node is a namespace declaration rather than a
+regular attribute.
+
+Returns 1 if the current node is a namespace declaration, 0 if it is a regular
+attribute or other type of node, or -1 in case of error.
+
+
+
+=back
+
+
+=head1 OTHER METHODS
+
+=over 4
+
+=item lookupNamespace (prefix)
+
+Resolves a namespace prefix in the scope of the current element.
+
+Returns a string containing the namespace URI to which the prefix maps or undef
+in case of error.
+
+
+=item encoding ()
+
+Returns a string containing the encoding of the document or undef in case of
+error.
+
+
+=item standalone ()
+
+Determine the standalone status of the document being read. Returns 1 if the
+document was declared to be standalone, 0 if it was declared to be not
+standalone, or -1 if the document did not specify its standalone status or in
+case of error.
+
+
+=item xmlVersion ()
+
+Determine the XML version of the document being read. Returns a string
+containing the XML version of the document or undef in case of error.
+
+
+=item baseURI ()
+
+Returns the base URI of a given node.
+
+
+=item isValid ()
+
+Retrieve the validity status from the parser.
+
+Returns 1 if valid, 0 if no, and -1 in case of error.
+
+
+=item xmlLang ()
+
+The xml:lang scope within which the node resides.
+
+
+=item lineNumber ()
+
+Provide the line number of the current parsing point.
+
+
+=item columnNumber ()
+
+Provide the column number of the current parsing point.
+
+
+=item byteConsumed ()
+
+This function provides the current index of the parser relative to the start of
+the current entity. This function is computed in bytes from the beginning
+starting at zero and finishing at the size in bytes of the file if parsing a
+file. The function is of constant cost if the input is UTF-8 but can be costly
+if run on non-UTF-8 input.
+
+
+=item setParserProp (prop => value, ...)
+
+Change the parser processing behaviour by changing some of its internal
+properties. The following properties are available with this function:
+``load_ext_dtd'', ``complete_attributes'', ``validation'', ``expand_entities''.
+
+Since some of the properties can only be changed before any read has been done,
+it is best to set the parsing properties at the constructor.
+
+Returns 0 if the call was successful, or -1 in case of error
+
+
+=item getParserProp (prop)
+
+Get value of an parser internal property. The following property names can be
+used: ``load_ext_dtd'', ``complete_attributes'', ``validation'',
+``expand_entities''.
+
+Returns the value, usually 0 or 1, or -1 in case of error.
+
+
+
+=back
+
+
+=head1 DESTRUCTION
+
+XML::LibXML takes care of the reader object destruction when the last reference
+to the reader object goes out of scope. The document tree is preserved, though,
+if either of $reader->document or $reader->preserveNode was used and references
+to the document tree exist.
+
+
+=head1 NODE TYPES
+
+The reader interface provides the following constants for node types (the
+constant symbols are exported by default or if tag C<<<<<< :types >>>>>> is used).
+
+
+
+ XML_READER_TYPE_NONE => 0
+ XML_READER_TYPE_ELEMENT => 1
+ XML_READER_TYPE_ATTRIBUTE => 2
+ XML_READER_TYPE_TEXT => 3
+ XML_READER_TYPE_CDATA => 4
+ XML_READER_TYPE_ENTITY_REFERENCE => 5
+ XML_READER_TYPE_ENTITY => 6
+ XML_READER_TYPE_PROCESSING_INSTRUCTION => 7
+ XML_READER_TYPE_COMMENT => 8
+ XML_READER_TYPE_DOCUMENT => 9
+ XML_READER_TYPE_DOCUMENT_TYPE => 10
+ XML_READER_TYPE_DOCUMENT_FRAGMENT => 11
+ XML_READER_TYPE_NOTATION => 12
+ XML_READER_TYPE_WHITESPACE => 13
+ XML_READER_TYPE_SIGNIFICANT_WHITESPACE => 14
+ XML_READER_TYPE_END_ELEMENT => 15
+ XML_READER_TYPE_END_ENTITY => 16
+ XML_READER_TYPE_XML_DECLARATION => 17
+
+
+=head1 STATES
+
+The following constants represent the values returned by C<<<<<< readState() >>>>>>. They are exported by default, or if tag C<<<<<< :states >>>>>> is used:
+
+
+
+ XML_READER_NONE => -1
+ XML_READER_START => 0
+ XML_READER_ELEMENT => 1
+ XML_READER_END => 2
+ XML_READER_EMPTY => 3
+ XML_READER_BACKTRACK => 4
+ XML_READER_DONE => 5
+ XML_READER_ERROR => 6
+
+
+=head1 SEE ALSO
+
+L<<<<<< XML::LibXML::Pattern >>>>>> for information about compiled patterns.
+
+http://xmlsoft.org/html/libxml-xmlreader.html
+
+http://dotgnu.org/pnetlib-doc/System/Xml/XmlTextReader.html
+
+
+=head1 ORIGINAL IMPLEMENTATION
+
+Heiko Klein, <H.Klein@gmx.net<gt> and Petr Pajas
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/RegExp.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/RegExp.pod
new file mode 100755
index 00000000000..509de9f5ffd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/RegExp.pod
@@ -0,0 +1,71 @@
+=head1 NAME
+
+XML::LibXML::RegExp - XML::LibXML::RegExp - interface to libxml2 regular expressions
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ my $compiled_re = new XML::LibXML::RegExp('[0-9]{5}(-[0-9]{4})?');
+ if ($compiled_re->isDeterministic()) { ... }
+ if ($compiled_re->matches($string)) { ... }
+
+ $compiled_re = XML::LibXML::RegExp->new( $regexp_str );
+ $bool = $compiled_re->matches($string);
+ $bool = $compiled_re->isDeterministic();
+
+=head1 DESCRIPTION
+
+This is a perl interface to libxml2's implementation of regular expressions,
+which are used e.g. for validation of XML Schema simple types (pattern facet).
+
+=over 4
+
+=item new()
+
+ $compiled_re = XML::LibXML::RegExp->new( $regexp_str );
+
+The constructor takes a string containing a regular expression and returns a
+compiled regexp object.
+
+
+=item matches($string)
+
+ $bool = $compiled_re->matches($string);
+
+Given a string value, returns a true value if the value is matched by the
+compiled regular expression.
+
+
+=item isDeterministic()
+
+ $bool = $compiled_re->isDeterministic();
+
+Returns a true value if the regular expression is deterministic; returns false
+otherwise. (See the definition of determinism in the XML spec (L<<<<<< http://www.w3.org/TR/REC-xml/#determinism >>>>>>))
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/RelaxNG.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/RelaxNG.pod
new file mode 100755
index 00000000000..7c2e530aadb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/RelaxNG.pod
@@ -0,0 +1,81 @@
+=head1 NAME
+
+XML::LibXML::RelaxNG - RelaxNG Schema Validation
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ $doc = XML::LibXML->new->parse_file($url);
+
+ $rngschema = XML::LibXML::RelaxNG->new( location => $filename_or_url );
+ $rngschema = XML::LibXML::RelaxNG->new( string => $xmlschemastring );
+ $rngschema = XML::LibXML::RelaxNG->new( DOM => $doc );
+ eval { $rngschema->validate( $doc ); };
+
+=head1 DESCRIPTION
+
+The XML::LibXML::RelaxNG class is a tiny frontend to libxml2's RelaxNG
+implementation. Currently it supports only schema parsing and document
+validation.
+
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ $rngschema = XML::LibXML::RelaxNG->new( location => $filename_or_url );
+ $rngschema = XML::LibXML::RelaxNG->new( string => $xmlschemastring );
+ $rngschema = XML::LibXML::RelaxNG->new( DOM => $doc );
+
+The constructor of XML::LibXML::RelaxNG may get called with either one of three
+parameters. The parameter tells the class from which source it should generate
+a validation schema. It is important, that each schema only have a single
+source.
+
+The location parameter allows to parse a schema from the filesystem or a URL.
+
+The string parameter will parse the schema from the given XML string.
+
+The DOM parameter allows to parse the schema from a pre-parsed L<<<<<< XML::LibXML::Document >>>>>>.
+
+Note that the constructor will die() if the schema does not meed the
+constraints of the RelaxNG specification.
+
+
+=item validate
+
+ eval { $rngschema->validate( $doc ); };
+
+This function allows to validate a (parsed) document against the given RelaxNG
+schema. The argument of this function should be a XML::LibXML::Document object.
+If this function succeeds, it will return 0, otherwise it will die() and report
+the errors found. Because of this validate() should be always evaluated.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pm
new file mode 100755
index 00000000000..8877240b5e6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pm
@@ -0,0 +1,97 @@
+# $Id: SAX.pm 785 2009-07-16 14:17:46Z pajas $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::SAX;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+use XML::LibXML;
+use XML::SAX::Base;
+
+use base qw(XML::SAX::Base);
+
+use Carp;
+use IO::File;
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+sub _parse_characterstream {
+ my ( $self, $fh ) = @_;
+ # this my catch the xml decl, so the parser won't get confused about
+ # a possibly wrong encoding.
+ croak( "not implemented yet" );
+}
+
+sub _parse_bytestream {
+ my ( $self, $fh ) = @_;
+ $self->{ParserOptions}{LibParser} = XML::LibXML->new;
+ $self->{ParserOptions}{ParseFunc} = \&XML::LibXML::parse_fh;
+ $self->{ParserOptions}{ParseFuncParam} = $fh;
+ $self->_parse;
+ return $self->end_document({});
+}
+
+sub _parse_string {
+ my ( $self, $string ) = @_;
+# $self->{ParserOptions}{LibParser} = XML::LibXML->new;
+ $self->{ParserOptions}{LibParser} = XML::LibXML->new() unless defined $self->{ParserOptions}{LibParser};
+ $self->{ParserOptions}{ParseFunc} = \&XML::LibXML::parse_string;
+ $self->{ParserOptions}{ParseFuncParam} = $string;
+ $self->_parse;
+ return $self->end_document({});
+}
+
+sub _parse_systemid {
+ my $self = shift;
+ $self->{ParserOptions}{LibParser} = XML::LibXML->new;
+ $self->{ParserOptions}{ParseFunc} = \&XML::LibXML::parse_file;
+ $self->{ParserOptions}{ParseFuncParam} = shift;
+ $self->_parse;
+ return $self->end_document({});
+}
+
+sub parse_chunk {
+ my ( $self, $chunk ) = @_;
+ $self->{ParserOptions}{LibParser} = XML::LibXML->new;
+ $self->{ParserOptions}{ParseFunc} = \&XML::LibXML::parse_xml_chunk;
+ $self->{ParserOptions}{LibParser}->{IS_FILTER}=1; # a hack to prevent parse_xml_chunk from issuing end_document
+ $self->{ParserOptions}{ParseFuncParam} = $chunk;
+ $self->_parse;
+ return;
+}
+
+sub _parse {
+ my $self = shift;
+ my $args = bless $self->{ParserOptions}, ref($self);
+
+ $args->{LibParser}->set_handler( $self );
+ eval {
+ $args->{ParseFunc}->($args->{LibParser}, $args->{ParseFuncParam});
+ };
+
+ if ( $args->{LibParser}->{SAX}->{State} == 1 ) {
+ croak( "SAX Exception not implemented, yet; Data ended before document ended\n" );
+ }
+
+ # break a possible circular reference
+ $args->{LibParser}->set_handler( undef );
+ if ( $@ ) {
+ croak $@;
+ }
+ return;
+}
+
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pod
new file mode 100755
index 00000000000..0a892598f00
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX.pod
@@ -0,0 +1,49 @@
+=head1 NAME
+
+XML::LibXML::SAX - XML::LibXML direct SAX parser
+
+=head1 DESCRIPTION
+
+XML::LibXML provides an interface to libxml2 direct SAX interface. Through this
+interface it is possible to generate SAX events directly while parsing a
+document. While using the SAX parser XML::LibXML will not create a DOM Document
+tree.
+
+Such an interface is useful if very large XML documents have to be processed
+and no DOM functions are required. By using this interface it is possible to
+read data stored within a XML document directly into the application data
+structures without loading the document into memory.
+
+The SAX interface of XML::LibXML is based on the famous XML::SAX interface. It
+uses the generic interface as provided by XML::SAX::Base.
+
+Additionally to the generic functions, which are only able to process entire
+documents, XML::LibXML::SAX provides I<<<<<< parse_chunk() >>>>>>. This method generates SAX events from well balanced data such as is often
+provided by databases.
+
+I<<<<<< NOTE: >>>>>> At the moment XML::LibXML provides only an incomplete interface to libxml2's
+native SAX implementation. The current implementation is not tested in
+production environment. It may causes significant memory problems or shows
+wrong behaviour. If you run into specific problems using this part of
+XML::LibXML, let me know.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pm
new file mode 100755
index 00000000000..8ebd042ddd0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pm
@@ -0,0 +1,332 @@
+# $Id: Builder.pm 785 2009-07-16 14:17:46Z pajas $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::SAX::Builder;
+
+use XML::LibXML;
+use XML::NamespaceSupport;
+
+use vars qw ($VERSION);
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+sub new {
+ my $class = shift;
+ return bless {@_}, $class;
+}
+
+sub result { $_[0]->{LAST_DOM}; }
+
+sub done {
+ my ($self) = @_;
+ my $dom = $self->{DOM};
+ $dom = $self->{Parent} unless defined $dom; # this is for parsing document chunks
+
+ delete $self->{NamespaceStack};
+ delete $self->{Parent};
+ delete $self->{DOM};
+
+ $self->{LAST_DOM} = $dom;
+
+ return $dom;
+}
+
+sub set_document_locator {
+}
+
+sub start_dtd {
+ my ($self, $dtd) = @_;
+ if (defined $dtd->{Name} and
+ (defined $dtd->{SystemId} or defined $dtd->{PublicId})) {
+ $self->{DOM}->createExternalSubset($dtd->{Name},$dtd->{PublicId},$dtd->{SystemId});
+ }
+}
+
+sub end_dtd {
+}
+
+sub start_document {
+ my ($self, $doc) = @_;
+ $self->{DOM} = XML::LibXML::Document->createDocument();
+
+ if ( defined $self->{Encoding} ) {
+ $self->xml_decl({Version => ($self->{Version} || '1.0') , Encoding => $self->{Encoding}});
+ }
+
+ $self->{NamespaceStack} = XML::NamespaceSupport->new;
+ $self->{NamespaceStack}->push_context;
+ $self->{Parent} = undef;
+ return ();
+}
+
+sub xml_decl {
+ my $self = shift;
+ my $decl = shift;
+
+ if ( defined $decl->{Version} ) {
+ $self->{DOM}->setVersion( $decl->{Version} );
+ }
+ if ( defined $decl->{Encoding} ) {
+ $self->{DOM}->setEncoding( $decl->{Encoding} );
+ }
+ return ();
+}
+
+sub end_document {
+ my ($self, $doc) = @_;
+ my $d = $self->done();
+ return $d;
+}
+
+sub start_prefix_mapping {
+ my $self = shift;
+ my $ns = shift;
+
+ unless ( defined $self->{DOM} or defined $self->{Parent} ) {
+ $self->{Parent} = XML::LibXML::DocumentFragment->new();
+ $self->{NamespaceStack} = XML::NamespaceSupport->new;
+ $self->{NamespaceStack}->push_context;
+ }
+
+ $self->{USENAMESPACESTACK} = 1;
+
+ $self->{NamespaceStack}->declare_prefix( $ns->{Prefix}, $ns->{NamespaceURI} );
+ return ();
+}
+
+
+sub end_prefix_mapping {
+ my $self = shift;
+ my $ns = shift;
+ $self->{NamespaceStack}->undeclare_prefix( $ns->{Prefix} );
+ return ();
+}
+
+
+sub start_element {
+ my ($self, $el) = @_;
+ my $node;
+
+ unless ( defined $self->{DOM} or defined $self->{Parent} ) {
+ $self->{Parent} = XML::LibXML::DocumentFragment->new();
+ $self->{NamespaceStack} = XML::NamespaceSupport->new;
+ $self->{NamespaceStack}->push_context;
+ }
+
+ if ( defined $self->{Parent} ) {
+ $el->{NamespaceURI} ||= "";
+ $node = $self->{Parent}->addNewChild( $el->{NamespaceURI},
+ $el->{Name} );
+ }
+ else {
+ if ($el->{NamespaceURI}) {
+ if ( defined $self->{DOM} ) {
+ $node = $self->{DOM}->createRawElementNS($el->{NamespaceURI},
+ $el->{Name});
+ }
+ else {
+ $node = XML::LibXML::Element->new( $el->{Name} );
+ $node->setNamespace( $el->{NamespaceURI},
+ $el->{Prefix} , 1 );
+ }
+ }
+ else {
+ if ( defined $self->{DOM} ) {
+ $node = $self->{DOM}->createRawElement($el->{Name});
+ }
+ else {
+ $node = XML::LibXML::Element->new( $el->{Name} );
+ }
+ }
+
+ $self->{DOM}->setDocumentElement($node);
+ }
+
+ # build namespaces
+ my $skip_ns= 0;
+ foreach my $p ( $self->{NamespaceStack}->get_declared_prefixes() ) {
+ $skip_ns= 1;
+ my $uri = $self->{NamespaceStack}->get_uri($p);
+ my $nodeflag = 0;
+ if ( defined $uri
+ and defined $el->{NamespaceURI}
+ and $uri eq $el->{NamespaceURI} ) {
+ # $nodeflag = 1;
+ next;
+ }
+ $node->setNamespace($uri, $p, 0 );
+ }
+
+ $self->{Parent} = $node;
+
+ $self->{NamespaceStack}->push_context;
+
+ # do attributes
+ foreach my $key (keys %{$el->{Attributes}}) {
+ my $attr = $el->{Attributes}->{$key};
+ if (ref($attr)) {
+ # catch broken name/value pairs
+ next unless $attr->{Name} ;
+ next if $self->{USENAMESPACESTACK}
+ and ( $attr->{Name} eq "xmlns"
+ or ( defined $attr->{Prefix}
+ and $attr->{Prefix} eq "xmlns" ) );
+
+
+ if ( defined $attr->{Prefix}
+ and $attr->{Prefix} eq "xmlns" and $skip_ns == 0 ) {
+ # ok, the generator does not set namespaces correctly!
+ my $uri = $attr->{Value};
+ $node->setNamespace($uri,
+ $attr->{Localname},
+ $uri eq $el->{NamespaceURI} ? 1 : 0 );
+ }
+ else {
+ $node->setAttributeNS($attr->{NamespaceURI} || "",
+ $attr->{Name}, $attr->{Value});
+ }
+ }
+ else {
+ $node->setAttribute($key => $attr);
+ }
+ }
+ return ();
+}
+
+sub end_element {
+ my ($self, $el) = @_;
+ return unless $self->{Parent};
+
+ $self->{NamespaceStack}->pop_context;
+ $self->{Parent} = $self->{Parent}->parentNode();
+ return ();
+}
+
+sub start_cdata {
+ my $self = shift;
+ $self->{IN_CDATA} = 1;
+ return ();
+}
+
+sub end_cdata {
+ my $self = shift;
+ $self->{IN_CDATA} = 0;
+ return ();
+}
+
+sub characters {
+ my ($self, $chars) = @_;
+ if ( not defined $self->{DOM} and not defined $self->{Parent} ) {
+ $self->{Parent} = XML::LibXML::DocumentFragment->new();
+ $self->{NamespaceStack} = XML::NamespaceSupport->new;
+ $self->{NamespaceStack}->push_context;
+ }
+ return unless $self->{Parent};
+ my $node;
+
+ unless ( defined $chars and defined $chars->{Data} ) {
+ return;
+ }
+
+ if ( defined $self->{DOM} ) {
+ if ( defined $self->{IN_CDATA} and $self->{IN_CDATA} == 1 ) {
+ $node = $self->{DOM}->createCDATASection($chars->{Data});
+ }
+ else {
+ $node = $self->{Parent}->appendText($chars->{Data});
+ return;
+ }
+ }
+ elsif ( defined $self->{IN_CDATA} and $self->{IN_CDATA} == 1 ) {
+ $node = XML::LibXML::CDATASection->new($chars->{Data});
+ }
+ else {
+ $node = XML::LibXML::Text->new($chars->{Data});
+ }
+
+ $self->{Parent}->addChild($node);
+ return ();
+}
+
+sub comment {
+ my ($self, $chars) = @_;
+ my $comment;
+ if ( not defined $self->{DOM} and not defined $self->{Parent} ) {
+ $self->{Parent} = XML::LibXML::DocumentFragment->new();
+ $self->{NamespaceStack} = XML::NamespaceSupport->new;
+ $self->{NamespaceStack}->push_context;
+ }
+
+ unless ( defined $chars and defined $chars->{Data} ) {
+ return;
+ }
+
+ if ( defined $self->{DOM} ) {
+ $comment = $self->{DOM}->createComment( $chars->{Data} );
+ }
+ else {
+ $comment = XML::LibXML::Comment->new( $chars->{Data} );
+ }
+
+ if ( defined $self->{Parent} ) {
+ $self->{Parent}->addChild($comment);
+ }
+ else {
+ $self->{DOM}->addChild($comment);
+ }
+ return ();
+}
+
+sub processing_instruction {
+ my ( $self, $pi ) = @_;
+ my $PI;
+ return unless defined $self->{DOM};
+ $PI = $self->{DOM}->createPI( $pi->{Target}, $pi->{Data} );
+
+ if ( defined $self->{Parent} ) {
+ $self->{Parent}->addChild( $PI );
+ }
+ else {
+ $self->{DOM}->addChild( $PI );
+ }
+ return ();
+}
+
+sub warning {
+ my $self = shift;
+ my $error = shift;
+ # fill $@ but do not die seriously
+ eval { $error->throw; };
+}
+
+sub error {
+ my $self = shift;
+ my $error = shift;
+ delete $self->{NamespaceStack};
+ delete $self->{Parent};
+ delete $self->{DOM};
+ $error->throw;
+}
+
+sub fatal_error {
+ my $self = shift;
+ my $error = shift;
+ delete $self->{NamespaceStack};
+ delete $self->{Parent};
+ delete $self->{DOM};
+ $error->throw;
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pod
new file mode 100755
index 00000000000..4d327a76ec3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Builder.pod
@@ -0,0 +1,51 @@
+=head1 NAME
+
+XML::LibXML::SAX::Builder - Building DOM trees from SAX events.
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML::SAX::Builder;
+ my $builder = XML::LibXML::SAX::Builder->new();
+
+ my $gen = XML::Generator::DBI->new(Handler => $builder, dbh => $dbh);
+ $gen->execute("SELECT * FROM Users");
+
+ my $doc = $builder->result();
+
+
+=head1 DESCRIPTION
+
+This is a SAX handler that generates a DOM tree from SAX events. Usage is as
+above. Input is accepted from any SAX1 or SAX2 event generator.
+
+Building DOM trees from SAX events is quite easy with
+XML::LibXML::SAX::Builder. The class is designed as a SAX2 final handler not as
+a filter!
+
+Since SAX is strictly stream oriented, you should not expect anything to return
+from a generator. Instead you have to ask the builder instance directly to get
+the document built. XML::LibXML::SAX::Builder's result() function holds the
+document generated from the last SAX stream.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Generator.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Generator.pm
new file mode 100755
index 00000000000..337b0277734
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Generator.pm
@@ -0,0 +1,157 @@
+# $Id: Generator.pm 772 2009-01-23 21:42:09Z pajas
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::SAX::Generator;
+
+use strict;
+
+use XML::LibXML;
+use vars qw ($VERSION);
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+warn("This class (", __PACKAGE__, ") is deprecated!");
+
+sub new {
+ my $class = shift;
+ unshift @_, 'Handler' unless @_ != 1;
+ my %p = @_;
+ return bless \%p, $class;
+}
+
+sub generate {
+ my $self = shift;
+ my ($node) = @_;
+
+ my $document = { Parent => undef };
+ $self->{Handler}->start_document($document);
+
+ process_node($self->{Handler}, $node);
+
+ $self->{Handler}->end_document($document);
+}
+
+sub process_node {
+ my ($handler, $node) = @_;
+
+ my $node_type = $node->getType();
+ if ($node_type == XML_COMMENT_NODE) {
+ $handler->comment( { Data => $node->getData } );
+ }
+ elsif ($node_type == XML_TEXT_NODE || $node_type == XML_CDATA_SECTION_NODE) {
+ # warn($node->getData . "\n");
+ $handler->characters( { Data => $node->getData } );
+ }
+ elsif ($node_type == XML_ELEMENT_NODE) {
+ # warn("<" . $node->getName . ">\n");
+ process_element($handler, $node);
+ # warn("</" . $node->getName . ">\n");
+ }
+ elsif ($node_type == XML_ENTITY_REF_NODE) {
+ foreach my $kid ($node->getChildnodes) {
+ # warn("child of entity ref: " . $kid->getType() . " called: " . $kid->getName . "\n");
+ process_node($handler, $kid);
+ }
+ }
+ elsif ($node_type == XML_DOCUMENT_NODE) {
+ # just get root element. Ignore other cruft.
+ foreach my $kid ($node->getChildnodes) {
+ if ($kid->getType() == XML_ELEMENT_NODE) {
+ process_element($handler, $kid);
+ last;
+ }
+ }
+ }
+ else {
+ warn("unknown node type: $node_type");
+ }
+}
+
+sub process_element {
+ my ($handler, $element) = @_;
+
+ my @attr;
+
+ foreach my $attr ($element->getAttributes) {
+ push @attr, XML::LibXML::SAX::AttributeNode->new(
+ Name => $attr->getName,
+ Value => $attr->getData,
+ NamespaceURI => $attr->getNamespaceURI,
+ Prefix => $attr->getPrefix,
+ LocalName => $attr->getLocalName,
+ );
+ }
+
+ my $node = {
+ Name => $element->getName,
+ Attributes => { map { $_->{Name} => $_ } @attr },
+ NamespaceURI => $element->getNamespaceURI,
+ Prefix => $element->getPrefix,
+ LocalName => $element->getLocalName,
+ };
+
+ $handler->start_element($node);
+
+ foreach my $child ($element->getChildnodes) {
+ process_node($handler, $child);
+ }
+
+ $handler->end_element($node);
+}
+
+package XML::LibXML::SAX::AttributeNode;
+
+use overload '""' => "stringify";
+
+sub new {
+ my $class = shift;
+ my %p = @_;
+ return bless \%p, $class;
+}
+
+sub stringify {
+ my $self = shift;
+ return $self->{Value};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::LibXML::SAX::Generator - Generate SAX events from a LibXML tree
+
+=head1 SYNOPSIS
+
+ my $handler = MySAXHandler->new();
+ my $generator = XML::LibXML::SAX::Generator->new(Handler => $handler);
+ my $dom = XML::LibXML->new->parse_file("foo.xml");
+
+ $generator->generate($dom);
+
+=head1 DESCRIPTION
+
+THIS CLASS IS DEPRACED! Use XML::LibXML::SAX::Parser instead!
+
+This helper class allows you to generate SAX events from any XML::LibXML
+node, and all it's sub-nodes. This basically gives you interop from
+XML::LibXML to other modules that may implement SAX.
+
+It uses SAX2 style, but should be compatible with anything SAX1, by use
+of stringification overloading.
+
+There is nothing to really know about, beyond the synopsis above, and
+a general knowledge of how to use SAX, which is beyond the scope here.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Parser.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Parser.pm
new file mode 100755
index 00000000000..086997970d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/SAX/Parser.pm
@@ -0,0 +1,265 @@
+# $Id: Parser.pm 785 2009-07-16 14:17:46Z pajas $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::SAX::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use XML::LibXML;
+use XML::LibXML::Common qw(:libxml);
+use XML::SAX::Base;
+use XML::SAX::DocumentLocator;
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+@ISA = ('XML::SAX::Base');
+
+sub CLONE_SKIP {
+ return $XML::LibXML::__threads_shared ? 0 : 1;
+}
+
+sub _parse_characterstream {
+ my ($self, $fh, $options) = @_;
+ die "parsing a characterstream is not supported at this time";
+}
+
+sub _parse_bytestream {
+ my ($self, $fh, $options) = @_;
+ my $parser = XML::LibXML->new();
+ my $doc = exists($options->{Source}{SystemId}) ? $parser->parse_fh($fh, $options->{Source}{SystemId}) : $parser->parse_fh($fh);
+ $self->generate($doc);
+}
+
+sub _parse_string {
+ my ($self, $str, $options) = @_;
+ my $parser = XML::LibXML->new();
+ my $doc = exists($options->{Source}{SystemId}) ? $parser->parse_string($str, $options->{Source}{SystemId}) : $parser->parse_string($str);
+ $self->generate($doc);
+}
+
+sub _parse_systemid {
+ my ($self, $sysid, $options) = @_;
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_file($sysid);
+ $self->generate($doc);
+}
+
+sub generate {
+ my $self = shift;
+ my ($node) = @_;
+
+ my $doc = $node->ownerDocument();
+ {
+ # precompute some DocumentLocator values
+ my %locator = (
+ PublicId => undef,
+ SystemId => undef,
+ Encoding => undef,
+ XMLVersion => undef,
+ );
+ my $dtd = defined $doc ? $doc->externalSubset() : undef;
+ if (defined $dtd) {
+ $locator{PublicId} = $dtd->publicId();
+ $locator{SystemId} = $dtd->systemId();
+ }
+ if (defined $doc) {
+ $locator{Encoding} = $doc->encoding();
+ $locator{XMLVersion} = $doc->version();
+ }
+ $self->set_document_locator(
+ XML::SAX::DocumentLocator->new(
+ sub { $locator{PublicId} },
+ sub { $locator{SystemId} },
+ sub { defined($self->{current_node}) ? $self->{current_node}->line_number() : undef },
+ sub { 1 },
+ sub { $locator{Encoding} },
+ sub { $locator{XMLVersion} },
+ ),
+ );
+ }
+
+ if ( $node->nodeType() == XML_DOCUMENT_NODE
+ || $node->nodeType == XML_HTML_DOCUMENT_NODE ) {
+ $self->start_document({});
+ $self->xml_decl({Version => $node->getVersion, Encoding => $node->getEncoding});
+ $self->process_node($node);
+ $self->end_document({});
+ }
+}
+
+sub process_node {
+ my ($self, $node) = @_;
+
+ local $self->{current_node} = $node;
+
+ my $node_type = $node->nodeType();
+ if ($node_type == XML_COMMENT_NODE) {
+ $self->comment( { Data => $node->getData } );
+ }
+ elsif ($node_type == XML_TEXT_NODE
+ || $node_type == XML_CDATA_SECTION_NODE) {
+ # warn($node->getData . "\n");
+ $self->characters( { Data => $node->nodeValue } );
+ }
+ elsif ($node_type == XML_ELEMENT_NODE) {
+ # warn("<" . $node->getName . ">\n");
+ $self->process_element($node);
+ # warn("</" . $node->getName . ">\n");
+ }
+ elsif ($node_type == XML_ENTITY_REF_NODE) {
+ foreach my $kid ($node->childNodes) {
+ # warn("child of entity ref: " . $kid->getType() . " called: " . $kid->getName . "\n");
+ $self->process_node($kid);
+ }
+ }
+ elsif ($node_type == XML_DOCUMENT_NODE
+ || $node_type == XML_HTML_DOCUMENT_NODE
+ || $node_type == XML_DOCUMENT_FRAG_NODE) {
+ # some times it is just usefull to generate SAX events from
+ # a document fragment (very good with filters).
+ foreach my $kid ($node->childNodes) {
+ $self->process_node($kid);
+ }
+ }
+ elsif ($node_type == XML_PI_NODE) {
+ $self->processing_instruction( { Target => $node->getName, Data => $node->getData } );
+ }
+ elsif ($node_type == XML_COMMENT_NODE) {
+ $self->comment( { Data => $node->getData } );
+ }
+ elsif ( $node_type == XML_XINCLUDE_START
+ || $node_type == XML_XINCLUDE_END ) {
+ # ignore!
+ # i may want to handle this one day, dunno yet
+ }
+ elsif ($node_type == XML_DTD_NODE ) {
+ # ignore!
+ # i will support DTDs, but had no time yet.
+ }
+ else {
+ # warn("unsupported node type: $node_type");
+ }
+
+}
+
+sub process_element {
+ my ($self, $element) = @_;
+
+ my $attribs = {};
+ my @ns_maps = $element->getNamespaces;
+
+ foreach my $ns (@ns_maps) {
+ $self->start_prefix_mapping(
+ {
+ NamespaceURI => $ns->href,
+ Prefix => ( defined $ns->localname ? $ns->localname : ''),
+ }
+ );
+ }
+
+ foreach my $attr ($element->attributes) {
+ my $key;
+ # warn("Attr: $attr -> ", $attr->getName, " = ", $attr->getData, "\n");
+ # this isa dump thing...
+ if ($attr->isa('XML::LibXML::Namespace')) {
+ # TODO This needs fixing modulo agreeing on what
+ # is the right thing to do here.
+ unless ( defined $attr->name ) {
+ ## It's an atter like "xmlns='foo'"
+ $attribs->{"{}xmlns"} =
+ {
+ Name => "xmlns",
+ LocalName => "xmlns",
+ Prefix => "",
+ Value => $attr->href,
+ NamespaceURI => "",
+ };
+ }
+ else {
+ my $prefix = "xmlns";
+ my $localname = $attr->localname;
+ my $key = "{http://www.w3.org/2000/xmlns/}";
+ my $name = "xmlns";
+
+ if ( defined $localname ) {
+ $key .= $localname;
+ $name.= ":".$localname;
+ }
+
+ $attribs->{$key} =
+ {
+ Name => $name,
+ Value => $attr->href,
+ NamespaceURI => "http://www.w3.org/2000/xmlns/",
+ Prefix => $prefix,
+ LocalName => $localname,
+ };
+ }
+ }
+ else {
+ my $ns = $attr->namespaceURI;
+
+ $ns = '' unless defined $ns;
+ $key = "{$ns}".$attr->localname;
+ ## Not sure why, but $attr->name is coming through stripped
+ ## of its prefix, so we need to hand-assemble a real name.
+ my $name = $attr->name;
+ $name = "" unless defined $name;
+
+ my $prefix = $attr->prefix;
+ $prefix = "" unless defined $prefix;
+ $name = "$prefix:$name"
+ if index( $name, ":" ) < 0 && length $prefix;
+
+ $attribs->{$key} =
+ {
+ Name => $name,
+ Value => $attr->value,
+ NamespaceURI => $ns,
+ Prefix => $prefix,
+ LocalName => $attr->localname,
+ };
+ }
+ # use Data::Dumper;
+ # warn("Attr made: ", Dumper($attribs->{$key}), "\n");
+ }
+
+ my $node = {
+ Name => $element->nodeName,
+ Attributes => $attribs,
+ NamespaceURI => $element->namespaceURI,
+ Prefix => $element->prefix || "",
+ LocalName => $element->localname,
+ };
+
+ $self->start_element($node);
+
+ foreach my $child ($element->childNodes) {
+ $self->process_node($child);
+ }
+
+ my $end_node = { %$node };
+
+ delete $end_node->{Attributes};
+
+ $self->end_element($end_node);
+
+ foreach my $ns (@ns_maps) {
+ $self->end_prefix_mapping(
+ {
+ NamespaceURI => $ns->href,
+ Prefix => ( defined $ns->localname ? $ns->localname : ''),
+ }
+ );
+ }
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Schema.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Schema.pod
new file mode 100755
index 00000000000..2697ccc9c54
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Schema.pod
@@ -0,0 +1,78 @@
+=head1 NAME
+
+XML::LibXML::Schema - XML Schema Validation
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ $doc = XML::LibXML->new->parse_file($url);
+
+ $xmlschema = XML::LibXML::Schema->new( location => $filename_or_url );
+ $xmlschema = XML::LibXML::Schema->new( string => $xmlschemastring );
+ eval { $xmlschema->validate( $doc ); };
+
+=head1 DESCRIPTION
+
+The XML::LibXML::Schema class is a tiny frontend to libxml2's XML Schema
+implementation. Currently it supports only schema parsing and document
+validation. As of 2.6.32, libxml2 only supports decimal types up to 24 digits
+(the standard requires at least 18).
+
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ $xmlschema = XML::LibXML::Schema->new( location => $filename_or_url );
+ $xmlschema = XML::LibXML::Schema->new( string => $xmlschemastring );
+
+The constructor of XML::LibXML::Schema may get called with either one of two
+parameters. The parameter tells the class from which source it should generate
+a validation schema. It is important, that each schema only have a single
+source.
+
+The location parameter allows to parse a schema from the filesystem or a URL.
+
+The string parameter will parse the schema from the given XML string.
+
+Note that the constructor will die() if the schema does not meed the
+constraints of the XML Schema specification.
+
+
+=item validate
+
+ eval { $xmlschema->validate( $doc ); };
+
+This function allows to validate a (parsed) document against the given XML
+Schema. The argument of this function should be a L<<<<<< XML::LibXML::Document >>>>>> object. If this function succeeds, it will return 0, otherwise it will die()
+and report the errors found. Because of this validate() should be always
+evaluated.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Text.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Text.pod
new file mode 100755
index 00000000000..f29b2fd100f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/Text.pod
@@ -0,0 +1,183 @@
+=head1 NAME
+
+XML::LibXML::Text - XML::LibXML Class for Text Nodes
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ # Only methods specific to Text nodes are listed here,
+ # see XML::LibXML::Node manpage for other methods
+
+ $text = XML::LibXML::Text->new( $content );
+ $nodedata = $text->data;
+ $text->setData( $text_content );
+ $text->substringData($offset, $length);
+ $text->appendData( $somedata );
+ $text->insertData($offset, $string);
+ $text->deleteData($offset, $length);
+ $text->deleteDataString($remstring, $all);
+ $text->replaceData($offset, $length, $string);
+ $text->replaceDataString($old, $new, $flag);
+ $text->replaceDataRegEx( $search_cond, $replace_cond, $reflags );
+
+=head1 DESCRIPTION
+
+Unlike the DOM specification, XML::LibXML implements the text node as the base
+class of all character data node. Therefor there exists no CharacterData class.
+This allows one to apply methods of text nodes also to Comments and
+CDATA-sections.
+
+
+=head1 METHODS
+
+The class inherits from L<<<<<< XML::LibXML::Node >>>>>>. The documentation for Inherited methods is not listed here.
+
+Many functions listed here are extensively documented in the DOM Level 3 specification (L<<<<<< http://www.w3.org/TR/DOM-Level-3-Core/ >>>>>>). Please refer to the specification for extensive documentation.
+
+=over 4
+
+=item new
+
+ $text = XML::LibXML::Text->new( $content );
+
+The constructor of the class. It creates an unbound text node.
+
+
+=item data
+
+ $nodedata = $text->data;
+
+Although there exists the C<<<<<< nodeValue >>>>>> attribute in the Node class, the DOM specification defines data as a separate
+attribute. C<<<<<< XML::LibXML >>>>>> implements these two attributes not as different attributes, but as aliases,
+such as C<<<<<< libxml2 >>>>>> does. Therefore
+
+
+
+ $text->data;
+
+and
+
+
+
+ $text->nodeValue;
+
+will have the same result and are not different entities.
+
+
+=item setData($string)
+
+ $text->setData( $text_content );
+
+This function sets or replaces text content to a node. The node has to be of
+the type "text", "cdata" or "comment".
+
+
+=item substringData($offset,$length)
+
+ $text->substringData($offset, $length);
+
+Extracts a range of data from the node. (DOM Spec) This function takes the two
+parameters $offset and $length and returns the sub-string, if available.
+
+If the node contains no data or $offset refers to an non-existing string index,
+this function will return I<<<<<< undef >>>>>>. If $length is out of range C<<<<<< substringData >>>>>> will return the data starting at $offset instead of causing an error.
+
+
+=item appendData($string)
+
+ $text->appendData( $somedata );
+
+Appends a string to the end of the existing data. If the current text node
+contains no data, this function has the same effect as C<<<<<< setData >>>>>>.
+
+
+=item insertData($offset,$string)
+
+ $text->insertData($offset, $string);
+
+Inserts the parameter $string at the given $offset of the existing data of the
+node. This operation will not remove existing data, but change the order of the
+existing data.
+
+The $offset has to be a positive value. If $offset is out of range, C<<<<<< insertData >>>>>> will have the same behaviour as C<<<<<< appendData >>>>>>.
+
+
+=item deleteData($offset, $length)
+
+ $text->deleteData($offset, $length);
+
+This method removes a chunk from the existing node data at the given offset.
+The $length parameter tells, how many characters should be removed from the
+string.
+
+
+=item deleteDataString($string, [$all])
+
+ $text->deleteDataString($remstring, $all);
+
+This method removes a chunk from the existing node data. Since the DOM spec is
+quite unhandy if you already know C<<<<<< which >>>>>> string to remove from a text node, this method allows more perlish code :)
+
+The functions takes two parameters: I<<<<<< $string >>>>>> and optional the I<<<<<< $all >>>>>> flag. If $all is not set, I<<<<<< undef >>>>>> or I<<<<<< 0 >>>>>>, C<<<<<< deleteDataString >>>>>> will remove only the first occurrence of $string. If $all is I<<<<<< TRUE >>>>>>C<<<<<< deleteDataString >>>>>> will remove all occurrences of I<<<<<< $string >>>>>> from the node data.
+
+
+=item replaceData($offset, $length, $string)
+
+ $text->replaceData($offset, $length, $string);
+
+The DOM style version to replace node data.
+
+
+=item replaceDataString($oldstring, $newstring, [$all])
+
+ $text->replaceDataString($old, $new, $flag);
+
+The more programmer friendly version of replaceData() :)
+
+Instead of giving offsets and length one can specify the exact string (I<<<<<< $oldstring >>>>>>) to be replaced. Additionally the I<<<<<< $all >>>>>> flag allows to replace all occurrences of I<<<<<< $oldstring >>>>>>.
+
+
+=item replaceDataRegEx( $search_cond, $replace_cond, $reflags )
+
+ $text->replaceDataRegEx( $search_cond, $replace_cond, $reflags );
+
+This method replaces the node's data by a C<<<<<< simple >>>>>> regular expression. Optional, this function allows to pass some flags that will
+be added as flag to the replace statement.
+
+I<<<<<< NOTE: >>>>>> This is a shortcut for
+
+
+
+ my $datastr = $node->getData();
+ $datastr =~ s/somecond/replacement/g; # 'g' is just an example for any flag
+ $node->setData( $datastr );
+
+This function can make things easier to read for simple replacements. For more
+complex variants it is recommended to use the code snippet above.
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pm
new file mode 100755
index 00000000000..81408dbd84d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pm
@@ -0,0 +1,146 @@
+# $Id: XPathContext.pm 422 2002-11-08 17:10:30Z phish $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+#
+#
+
+package XML::LibXML::XPathContext;
+
+use strict;
+use vars qw($VERSION @ISA $USE_LIBXML_DATA_TYPES);
+
+use Carp;
+use XML::LibXML;
+use XML::LibXML::NodeList;
+
+$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
+
+# should LibXML XPath data types be used for simple objects
+# when passing parameters to extension functions (default: no)
+$USE_LIBXML_DATA_TYPES = 0;
+
+sub CLONE_SKIP { 1 }
+
+sub findnodes {
+ my ($self, $xpath, $node) = @_;
+
+ my @nodes = $self->_guarded_find_call('_findnodes', $node, $xpath);
+
+ if (wantarray) {
+ return @nodes;
+ }
+ else {
+ return XML::LibXML::NodeList->new(@nodes);
+ }
+}
+
+sub find {
+ my ($self, $xpath, $node) = @_;
+
+ my ($type, @params) = $self->_guarded_find_call('_find', $node, $xpath,0);
+
+ if ($type) {
+ return $type->new(@params);
+ }
+ return undef;
+}
+
+sub exists {
+ my ($self, $xpath, $node) = @_;
+ my (undef, $value) = $self->_guarded_find_call('_find', $node, $xpath,1);
+ return $value;
+}
+
+sub findvalue {
+ my $self = shift;
+ return $self->find(@_)->to_literal->value;
+}
+
+sub _guarded_find_call {
+ my ($self, $method, $node)=(shift,shift,shift);
+
+ my $prev_node;
+ if (ref($node)) {
+ $prev_node = $self->getContextNode();
+ $self->setContextNode($node);
+ }
+ my @ret;
+ eval {
+ @ret = $self->$method(@_);
+ };
+ $self->_free_node_pool;
+ $self->setContextNode($prev_node) if ref($node);
+
+ if ($@) {
+ my $err = $@;
+ chomp $err;
+ croak $err;
+ }
+
+ return @ret;
+}
+
+sub registerFunction {
+ my ($self, $name, $sub) = @_;
+ $self->registerFunctionNS($name, undef, $sub);
+ return;
+}
+
+sub unregisterNs {
+ my ($self, $prefix) = @_;
+ $self->registerNs($prefix, undef);
+ return;
+}
+
+sub unregisterFunction {
+ my ($self, $name) = @_;
+ $self->registerFunctionNS($name, undef, undef);
+ return;
+}
+
+sub unregisterFunctionNS {
+ my ($self, $name, $ns) = @_;
+ $self->registerFunctionNS($name, $ns, undef);
+ return;
+}
+
+sub unregisterVarLookupFunc {
+ my ($self) = @_;
+ $self->registerVarLookupFunc(undef, undef);
+ return;
+}
+
+# extension function perl dispatcher
+# borrowed from XML::LibXSLT
+
+sub _perl_dispatcher {
+ my $func = shift;
+ my @params = @_;
+ my @perlParams;
+
+ my $i = 0;
+ while (@params) {
+ my $type = shift(@params);
+ if ($type eq 'XML::LibXML::Literal' or
+ $type eq 'XML::LibXML::Number' or
+ $type eq 'XML::LibXML::Boolean')
+ {
+ my $val = shift(@params);
+ unshift(@perlParams, $USE_LIBXML_DATA_TYPES ? $type->new($val) : $val);
+ }
+ elsif ($type eq 'XML::LibXML::NodeList') {
+ my $node_count = shift(@params);
+ unshift(@perlParams, $type->new(splice(@params, 0, $node_count)));
+ }
+ }
+
+ $func = "main::$func" unless ref($func) || $func =~ /(.+)::/;
+ no strict 'refs';
+ my $res = $func->(@perlParams);
+ return $res;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pod
new file mode 100755
index 00000000000..80ceff6435e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathContext.pod
@@ -0,0 +1,372 @@
+=head1 NAME
+
+XML::LibXML::XPathContext - XPath Evaluation
+
+=head1 SYNOPSIS
+
+ my $xpc = XML::LibXML::XPathContext->new();
+ my $xpc = XML::LibXML::XPathContext->new($node);
+ $xpc->registerNs($prefix, $namespace_uri)
+ $xpc->unregisterNs($prefix)
+ $uri = $xpc->lookupNs($prefix)
+ $xpc->registerVarLookupFunc($callback, $data)
+ $data = $xpc->getVarLookupData();
+ $callback = $xpc->getVarLookupFunc();
+ $xpc->unregisterVarLookupFunc($name);
+ $xpc->registerFunctionNS($name, $uri, $callback)
+ $xpc->unregisterFunctionNS($name, $uri)
+ $xpc->registerFunction($name, $callback)
+ $xpc->unregisterFunction($name)
+ @nodes = $xpc->findnodes($xpath)
+ @nodes = $xpc->findnodes($xpath, $context_node )
+ $nodelist = $xpc->findnodes($xpath, $context_node )
+ $object = $xpc->find($xpath )
+ $object = $xpc->find($xpath, $context_node )
+ $value = $xpc->findvalue($xpath )
+ $value = $xpc->findvalue($xpath, $context_node )
+ $bool = $xpc->exists( $xpath_expression, $context_node );
+ $xpc->setContextNode($node)
+ my $node = $xpc->getContextNode;
+ $xpc->setContextPosition($position)
+ my $position = $xpc->getContextPosition;
+ $xpc->setContextSize($size)
+ my $size = $xpc->getContextSize;
+ $xpc->setContextNode($node)
+The XML::LibXML::XPathContext class provides an almost complete interface to
+libxml2's XPath implementation. With XML::LibXML::XPathContext is is possible
+to evaluate XPath expressions in the context of arbitrary node, context size,
+and context position, with a user-defined namespace-prefix mapping, custom
+XPath functions written in Perl, and even a custom XPath variable resolver.
+
+
+=head1 EXAMPLES
+
+
+=head2 Namespaces
+
+This example demonstrates C<<<<<< registerNs() >>>>>> method. It finds all paragraph nodes in an XHTML document.
+
+
+
+ my $xc = XML::LibXML::XPathContext->new($xhtml_doc);
+ $xc->registerNs('xhtml', 'http://www.w3.org/1999/xhtml');
+ my @nodes = $xc->findnodes('//xhtml:p');
+
+
+=head2 Custom XPath functions
+
+This example demonstrates C<<<<<< registerFunction() >>>>>> method by defining a function filtering nodes based on a Perl regular
+expression:
+
+
+
+ sub grep_nodes {
+ my ($nodelist,$regexp) = @_;
+ my $result = XML::LibXML::NodeList->new;
+ for my $node ($nodelist->get_nodelist()) {
+ $result->push($node) if $node->textContent =~ $regexp;
+ }
+ return $result;
+ };
+
+ my $xc = XML::LibXML::XPathContext->new($node);
+ $xc->registerFunction('grep_nodes', \&grep_nodes);
+ my @nodes = $xc->findnodes('//section[grep_nodes(para,"\bsearch(ing|es)?\b")]');
+
+
+=head2 Variables
+
+This example demonstrates C<<<<<< registerVarLookup() >>>>>> method. We use XPath variables to recycle results of previous evaluations:
+
+
+
+ sub var_lookup {
+ my ($varname,$ns,$data)=@_;
+ return $data->{$varname};
+ }
+
+ my $areas = XML::LibXML->new->parse_file('areas.xml');
+ my $empl = XML::LibXML->new->parse_file('employees.xml');
+
+ my $xc = XML::LibXML::XPathContext->new($empl);
+
+ my %variables = (
+ A => $xc->find('/employees/employee[@salary>10000]'),
+ B => $areas->find('/areas/area[district='Brooklyn']/street'),
+ );
+
+ # get names of employees from $A working in an area listed in $B
+ $xc->registerVarLookupFunc(\&var_lookup, \%variables);
+ my @nodes = $xc->findnodes('$A[work_area/street = $B]/name');
+
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ my $xpc = XML::LibXML::XPathContext->new();
+
+Creates a new XML::LibXML::XPathContext object without a context node.
+
+ my $xpc = XML::LibXML::XPathContext->new($node);
+
+Creates a new XML::LibXML::XPathContext object with the context node set to C<<<<<< $node >>>>>>.
+
+
+=item registerNs
+
+ $xpc->registerNs($prefix, $namespace_uri)
+
+Registers namespace C<<<<<< $prefix >>>>>> to C<<<<<< $namespace_uri >>>>>>.
+
+
+=item unregisterNs
+
+ $xpc->unregisterNs($prefix)
+
+Unregisters namespace C<<<<<< $prefix >>>>>>.
+
+
+=item lookupNs
+
+ $uri = $xpc->lookupNs($prefix)
+
+Returns namespace URI registered with C<<<<<< $prefix >>>>>>. If C<<<<<< $prefix >>>>>> is not registered to any namespace URI returns C<<<<<< undef >>>>>>.
+
+
+=item registerVarLookupFunc
+
+ $xpc->registerVarLookupFunc($callback, $data)
+
+Registers variable lookup function C<<<<<< $prefix >>>>>>. The registered function is executed by the XPath engine each time an XPath
+variable is evaluated. It takes three arguments: C<<<<<< $data >>>>>>, variable name, and variable ns-URI and must return one value: a number or
+string or any C<<<<<< XML::LibXML:: >>>>>> object that can be a result of findnodes: Boolean, Literal, Number, Node (e.g.
+Document, Element, etc.), or NodeList. For convenience, simple (non-blessed)
+array references containing only L<<<<<< XML::LibXML::Node >>>>>> objects can be used instead of a L<<<<<< XML::LibXML::NodeList >>>>>>.
+
+
+=item getVarLookupData
+
+ $data = $xpc->getVarLookupData();
+
+Returns the data that have been associated with a variable lookup function
+during a previous call to C<<<<<< registerVarLookupFunc >>>>>>.
+
+
+=item getVarLookupFunc
+
+ $callback = $xpc->getVarLookupFunc();
+
+Returns the variable lookup function previously registered with C<<<<<< registerVarLookupFunc >>>>>>.
+
+
+=item unregisterVarLookupFunc
+
+ $xpc->unregisterVarLookupFunc($name);
+
+Unregisters variable lookup function and the associated lookup data.
+
+
+=item registerFunctionNS
+
+ $xpc->registerFunctionNS($name, $uri, $callback)
+
+Registers an extension function C<<<<<< $name >>>>>> in C<<<<<< $uri >>>>>> namespace. C<<<<<< $callback >>>>>> must be a CODE reference. The arguments of the callback function are either
+simple scalars or C<<<<<< XML::LibXML::* >>>>>> objects depending on the XPath argument types. The function is responsible for
+checking the argument number and types. Result of the callback code must be a
+single value of the following types: a simple scalar (number, string) or an
+arbitrary C<<<<<< XML::LibXML::* >>>>>> object that can be a result of findnodes: Boolean, Literal, Number, Node (e.g.
+Document, Element, etc.), or NodeList. For convenience, simple (non-blessed)
+array references containing only L<<<<<< XML::LibXML::Node >>>>>> objects can be used instead of a L<<<<<< XML::LibXML::NodeList >>>>>>.
+
+
+=item unregisterFunctionNS
+
+ $xpc->unregisterFunctionNS($name, $uri)
+
+Unregisters extension function C<<<<<< $name >>>>>> in C<<<<<< $uri >>>>>> namespace. Has the same effect as passing C<<<<<< undef >>>>>> as C<<<<<< $callback >>>>>> to registerFunctionNS.
+
+
+=item registerFunction
+
+ $xpc->registerFunction($name, $callback)
+
+Same as C<<<<<< registerFunctionNS >>>>>> but without a namespace.
+
+
+=item unregisterFunction
+
+ $xpc->unregisterFunction($name)
+
+Same as C<<<<<< unregisterFunctionNS >>>>>> but without a namespace.
+
+
+=item findnodes
+
+ @nodes = $xpc->findnodes($xpath)
+
+ @nodes = $xpc->findnodes($xpath, $context_node )
+
+ $nodelist = $xpc->findnodes($xpath, $context_node )
+
+Performs the xpath statement on the current node and returns the result as an
+array. In scalar context returns a L<<<<<< XML::LibXML::NodeList >>>>>> object. Optionally, a node may be passed as a second argument to set the
+context node for the query.
+
+The xpath expression can be passed either as a string or or as a L<<<<<< XML::LibXML::XPathExpression >>>>>> object.
+
+
+=item find
+
+ $object = $xpc->find($xpath )
+
+ $object = $xpc->find($xpath, $context_node )
+
+Performs the xpath expression using the current node as the context of the
+expression, and returns the result depending on what type of result the XPath
+expression had. For example, the XPath C<<<<<< 1 * 3 + 52 >>>>>> results in a L<<<<<< XML::LibXML::Number >>>>>> object being returned. Other expressions might return a L<<<<<< XML::LibXML::Boolean >>>>>> object, or a L<<<<<< XML::LibXML::Literal >>>>>> object (a string). Each of those objects uses Perl's overload feature to ``do
+the right thing'' in different contexts. Optionally, a node may be passed as a
+second argument to set the context node for the query.
+
+The xpath expression can be passed either as a string or or as a L<<<<<< XML::LibXML::XPathExpression >>>>>> object.
+
+
+=item findvalue
+
+ $value = $xpc->findvalue($xpath )
+
+ $value = $xpc->findvalue($xpath, $context_node )
+
+Is exactly equivalent to:
+
+
+
+ $xpc->find( $xpath, $context_node )->to_literal;
+
+That is, it returns the literal value of the results. This enables you to
+ensure that you get a string back from your search, allowing certain shortcuts.
+This could be used as the equivalent of <xsl:value-of select=``some_xpath''/>.
+Optionally, a node may be passed in the second argument to set the context node
+for the query.
+
+The xpath expression can be passed either as a string or or as a L<<<<<< XML::LibXML::XPathExpression >>>>>> object.
+
+
+=item exists
+
+ $bool = $xpc->exists( $xpath_expression, $context_node );
+
+This method behaves like I<<<<<< findnodes >>>>>>, except that it only returns a boolean value (1 if the expression matches a
+node, 0 otherwise) and may be faster than I<<<<<< findnodes >>>>>>, because the XPath evaluation may stop early on the first match (this is true
+for libxml2 >= 2.6.27).
+
+For XPath expressions that do not return node-set, the method returns true if
+the returned value is a non-zero number or a non-empty string.
+
+
+=item setContextNode
+
+ $xpc->setContextNode($node)
+
+Set the current context node.
+
+
+=item getContextNode
+
+ my $node = $xpc->getContextNode;
+
+Get the current context node.
+
+
+=item setContextPosition
+
+ $xpc->setContextPosition($position)
+
+Set the current context position. By default, this value is -1 (and evaluating
+XPath function C<<<<<< position() >>>>>> in the initial context raises an XPath error), but can be set to any value up
+to context size. This usually only serves to cheat the XPath engine to return
+given position when C<<<<<< position() >>>>>> XPath function is called. Setting this value to -1 restores the default
+behavior.
+
+
+=item getContextPosition
+
+ my $position = $xpc->getContextPosition;
+
+Get the current context position.
+
+
+=item setContextSize
+
+ $xpc->setContextSize($size)
+
+Set the current context size. By default, this value is -1 (and evaluating
+XPath function C<<<<<< last() >>>>>> in the initial context raises an XPath error), but can be set to any
+non-negative value. This usually only serves to cheat the XPath engine to
+return the given value when C<<<<<< last() >>>>>> XPath function is called. If context size is set to 0, position is
+automatically also set to 0. If context size is positive, position is
+automatically set to 1. Setting context size to -1 restores the default
+behavior.
+
+
+=item getContextSize
+
+ my $size = $xpc->getContextSize;
+
+Get the current context size.
+
+
+=item setContextNode
+
+ $xpc->setContextNode($node)
+
+Set the current context node.
+
+
+
+=back
+
+
+=head1 BUGS AND CAVEATS
+
+XML::LibXML::XPathContext objects I<<<<<< are >>>>>> reentrant, meaning that you can call methods of an XML::LibXML::XPathContext
+even from XPath extension functions registered with the same object or from a
+variable lookup function. On the other hand, you should rather avoid
+registering new extension functions, namespaces and a variable lookup function
+from within extension functions and a variable lookup function, unless you want
+to experience untested behavior.
+
+
+=head1 AUTHORS
+
+Ilya Martynov and Petr Pajas, based on XML::LibXML and XML::LibXSLT code by
+Matt Sergeant and Christian Glahn.
+
+
+=head1 HISTORICAL REMARK
+
+Prior to XML::LibXML 1.61 this module was distributed separately for
+maintenance reasons.
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathExpression.pod b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathExpression.pod
new file mode 100755
index 00000000000..742b8747450
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXML/XPathExpression.pod
@@ -0,0 +1,65 @@
+=head1 NAME
+
+XML::LibXML::XPathExpression - XML::LibXML::XPathExpression - interface to libxml2 pre-compiled XPath expressions
+
+=head1 SYNOPSIS
+
+
+
+ use XML::LibXML;
+ my $compiled_xpath = new XML::LibXML::XPathExpression('//foo[@bar="baz"][position()<4]');
+
+ # interface from XML::LibXML::Node
+
+ my $result = $node->find($compiled_xpath);
+ my @nodes = $node->findnodes($compiled_xpath);
+ my $value = $node->findvalue($compiled_xpath);
+
+ # interface from XML::LibXML::XPathContext
+
+ my $result = $xpc->find($compiled_xpath,$node);
+ my @nodes = $xpc->findnodes($compiled_xpath,$node);
+ my $value = $xpc->findvalue($compiled_xpath,$node);
+
+ $compiled = XML::LibXML::XPathExpression->new( xpath_string );
+
+=head1 DESCRIPTION
+
+This is a perl interface to libxml2's pre-compiled XPath expressions.
+Pre-compiling an XPath expression can give in some performance benefit if the
+same XPath query is evaluated many times. C<<<<<< XML::LibXML::XPathExpression >>>>>> objects can be passed to all C<<<<<< find... >>>>>> functions C<<<<<< XML::LibXML >>>>>> that expect an XPath expression.
+
+=over 4
+
+=item new()
+
+ $compiled = XML::LibXML::XPathExpression->new( xpath_string );
+
+The constructor takes an XPath 1.0 expression as a string and returns an object
+representing the pre-compiled expressions (the actual data structure is
+internal to libxml2).
+
+
+
+=back
+
+=head1 AUTHORS
+
+Matt Sergeant,
+Christian Glahn,
+Petr Pajas
+
+
+=head1 VERSION
+
+1.70
+
+=head1 COPYRIGHT
+
+2001-2007, AxKit.com Ltd.
+
+2002-2006, Christian Glahn.
+
+2006-2009, Petr Pajas.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/LibXSLT.pm b/Master/tlpkg/tlperl.straw/lib/XML/LibXSLT.pm
new file mode 100755
index 00000000000..034f52a180d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/LibXSLT.pm
@@ -0,0 +1,1008 @@
+# $Id: LibXSLT.pm 228 2009-10-07 12:25:23Z pajas $
+#
+# This is free software, you may use it and distribute it under the same terms as
+# Perl itself.
+#
+# Copyright 2001-2009 AxKit.com Ltd.
+#
+#
+package XML::LibXSLT;
+
+use strict;
+use vars qw($VERSION @ISA $USE_LIBXML_DATA_TYPES $MatchCB $ReadCB $OpenCB $CloseCB);
+
+sub REQUIRE_XML_LIBXML_ABI_VERSION { 2 }
+
+use XML::LibXML 1.70;
+use XML::LibXML::Literal;
+use XML::LibXML::Boolean;
+use XML::LibXML::Number;
+use XML::LibXML::NodeList;
+
+
+BEGIN {
+use Carp;
+
+require Exporter;
+
+$VERSION = "1.70";
+
+require DynaLoader;
+
+@ISA = qw(DynaLoader);
+
+# avoid possible shared library name conflict on Win32
+# not using this trick on 5.10.0 (suffering from DynaLoader bug)
+local $DynaLoader::dl_dlext = "xs.$DynaLoader::dl_dlext" if (($^O eq 'MSWin32') && ($] ne '5.010000'));
+
+bootstrap XML::LibXSLT $VERSION;
+
+# the following magic lets XML::LibXSLT internals know
+# where to register XML::LibXML proxy nodes
+INIT_THREAD_SUPPORT() if XML::LibXML::threads_shared_enabled();
+$USE_LIBXML_DATA_TYPES = 0;
+}
+
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+ my $self = bless \%options, $class;
+ return $self;
+}
+
+# ido - perl dispatcher
+sub perl_dispatcher {
+ my $func = shift;
+ my @params = @_;
+ my @perlParams;
+
+ my $i = 0;
+ while (@params) {
+ my $type = shift(@params);
+ if ($type eq 'XML::LibXML::Literal' or
+ $type eq 'XML::LibXML::Number' or
+ $type eq 'XML::LibXML::Boolean')
+ {
+ my $val = shift(@params);
+ unshift(@perlParams, $USE_LIBXML_DATA_TYPES ? $type->new($val) : $val);
+ }
+ elsif ($type eq 'XML::LibXML::NodeList') {
+ my $node_count = shift(@params);
+ my @nodes = splice(@params, 0, $node_count);
+ # warn($_->getName) for @nodes;
+ unshift(@perlParams, $type->new(@nodes));
+ }
+ }
+
+ $func = "main::$func" unless ref($func) || $func =~ /(.+)::/;
+ no strict 'refs';
+ my $res = $func->(@perlParams);
+ return $res;
+}
+
+
+sub xpath_to_string {
+ my @results;
+ while (@_) {
+ my $value = shift(@_); $value = '' unless defined $value;
+ push @results, $value;
+ if (@results % 2) {
+ # key
+ $results[-1] =~ s/:/_/g; # XSLT doesn't like names with colons
+ }
+ else {
+ if ($value =~ s/'/', "'", '/g) {
+ $results[-1] = "concat('$value')";
+ }
+ else {
+ $results[-1] = "'$results[-1]'";
+ }
+ }
+ }
+ return @results;
+}
+
+#-------------------------------------------------------------------------#
+# callback functions #
+#-------------------------------------------------------------------------#
+
+sub security_callbacks {
+ my $self = shift;
+ my $scbclass = shift;
+
+ if ( defined $scbclass ) {
+ $self->{XML_LIBXSLT_SECPREFS} = $scbclass;
+ }
+ return $self->{XML_LIBXSLT_SECPREFS};
+}
+
+sub input_callbacks {
+ my $self = shift;
+ my $icbclass = shift;
+
+ if ( defined $icbclass ) {
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = $icbclass;
+ }
+ return $self->{XML_LIBXSLT_CALLBACK_STACK};
+}
+
+sub match_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_MATCH_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_MATCH_CB};
+ }
+ else {
+ $MatchCB = shift if scalar @_;
+ return $MatchCB;
+ }
+}
+
+sub read_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_READ_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_READ_CB};
+ }
+ else {
+ $ReadCB = shift if scalar @_;
+ return $ReadCB;
+ }
+}
+
+sub close_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_CLOSE_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_CLOSE_CB};
+ }
+ else {
+ $CloseCB = shift if scalar @_;
+ return $CloseCB;
+ }
+}
+
+sub open_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_OPEN_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_OPEN_CB};
+ }
+ else {
+ $OpenCB = shift if scalar @_;
+ return $OpenCB;
+ }
+}
+
+sub callbacks {
+ my $self = shift;
+ if ( ref $self ) {
+ if (@_) {
+ my ($match, $open, $read, $close) = @_;
+ @{$self}{qw(XML_LIBXSLT_MATCH_CB XML_LIBXSLT_OPEN_CB XML_LIBXSLT_READ_CB XML_LIBXSLT_CLOSE_CB)} = ($match, $open, $read, $close);
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ else {
+ return @{$self}{qw(XML_LIBXSLT_MATCH_CB XML_LIBXSLT_OPEN_CB XML_LIBXSLT_READ_CB XML_LIBXSLT_CLOSE_CB)};
+ }
+ }
+ else {
+ if (@_) {
+ ( $MatchCB, $OpenCB, $ReadCB, $CloseCB ) = @_;
+ }
+ else {
+ return ( $MatchCB, $OpenCB, $ReadCB, $CloseCB );
+ }
+ }
+}
+
+sub _init_callbacks{
+ my $self = shift;
+ my $icb = $self->{XML_LIBXSLT_CALLBACK_STACK};
+
+ unless ( defined $icb ) {
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = XML::LibXML::InputCallback->new();
+ $icb = $self->{XML_LIBXSLT_CALLBACK_STACK};
+ }
+
+ my $mcb = $self->match_callback();
+ my $ocb = $self->open_callback();
+ my $rcb = $self->read_callback();
+ my $ccb = $self->close_callback();
+
+ if ( defined $mcb and defined $ocb and defined $rcb and defined $ccb ) {
+ $icb->register_callbacks( [$mcb, $ocb, $rcb, $ccb] );
+ }
+
+ $self->lib_init_callbacks();
+ $icb->init_callbacks();
+}
+
+sub _cleanup_callbacks {
+ my $self = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK}->cleanup_callbacks();
+ my $mcb = $self->match_callback();
+ if ( defined $mcb ) {
+ $self->{XML_LIBXSLT_CALLBACK_STACK}->unregister_callbacks( [$mcb] );
+ }
+}
+
+sub parse_stylesheet {
+ my $self = shift;
+
+ $self->_init_callbacks();
+
+ my $stylesheet;
+ eval { $stylesheet = $self->_parse_stylesheet(@_); };
+
+ $self->_cleanup_callbacks();
+
+ my $err = $@;
+ if ($err) {
+ croak $err;
+ }
+
+ my $rv = {
+ XML_LIBXSLT_STYLESHEET => $stylesheet,
+ XML_LIBXSLT_CALLBACK_STACK => $self->{XML_LIBXSLT_CALLBACK_STACK},
+ XML_LIBXSLT_MATCH_CB => $self->{XML_LIBXSLT_MATCH_CB},
+ XML_LIBXSLT_OPEN_CB => $self->{XML_LIBXSLT_OPEN_CB},
+ XML_LIBXSLT_READ_CB => $self->{XML_LIBXSLT_READ_CB},
+ XML_LIBXSLT_CLOSE_CB => $self->{XML_LIBXSLT_CLOSE_CB},
+ XML_LIBXSLT_SECPREFS => $self->{XML_LIBXSLT_SECPREFS},
+ };
+
+ return bless $rv, "XML::LibXSLT::StylesheetWrapper";
+}
+
+sub parse_stylesheet_file {
+ my $self = shift;
+
+ $self->_init_callbacks();
+
+ my $stylesheet;
+ eval { $stylesheet = $self->_parse_stylesheet_file(@_); };
+
+ $self->_cleanup_callbacks();
+
+ my $err = $@;
+ if ($err) {
+ croak $err;
+ }
+
+ my $rv = {
+ XML_LIBXSLT_STYLESHEET => $stylesheet,
+ XML_LIBXSLT_CALLBACK_STACK => $self->{XML_LIBXSLT_CALLBACK_STACK},
+ XML_LIBXSLT_MATCH_CB => $self->{XML_LIBXSLT_MATCH_CB},
+ XML_LIBXSLT_OPEN_CB => $self->{XML_LIBXSLT_OPEN_CB},
+ XML_LIBXSLT_READ_CB => $self->{XML_LIBXSLT_READ_CB},
+ XML_LIBXSLT_CLOSE_CB => $self->{XML_LIBXSLT_CLOSE_CB},
+ XML_LIBXSLT_SECPREFS => $self->{XML_LIBXSLT_SECPREFS},
+ };
+
+ return bless $rv, "XML::LibXSLT::StylesheetWrapper";
+}
+
+sub register_xslt_module {
+ my $self = shift;
+ my $module = shift;
+ # Not implemented
+}
+
+1;
+
+package XML::LibXSLT::StylesheetWrapper;
+
+use strict;
+use vars qw($MatchCB $ReadCB $OpenCB $CloseCB);
+
+use XML::LibXML;
+use Carp;
+
+sub security_callbacks {
+ my $self = shift;
+ my $scbclass = shift;
+
+ if ( defined $scbclass ) {
+ $self->{XML_LIBXSLT_SECPREFS} = $scbclass;
+ }
+ return $self->{XML_LIBXSLT_SECPREFS};
+}
+
+sub input_callbacks {
+ my $self = shift;
+ my $icbclass = shift;
+
+ if ( defined $icbclass ) {
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = $icbclass;
+ }
+ return $self->{XML_LIBXSLT_CALLBACK_STACK};
+}
+
+sub match_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_MATCH_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_MATCH_CB};
+ }
+ else {
+ $MatchCB = shift if scalar @_;
+ return $MatchCB;
+ }
+}
+
+sub read_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_READ_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_READ_CB};
+ }
+ else {
+ $ReadCB = shift if scalar @_;
+ return $ReadCB;
+ }
+}
+
+sub close_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_CLOSE_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_CLOSE_CB};
+ }
+ else {
+ $CloseCB = shift if scalar @_;
+ return $CloseCB;
+ }
+}
+
+sub open_callback {
+ my $self = shift;
+ if ( ref $self ) {
+ if ( scalar @_ ) {
+ $self->{XML_LIBXSLT_OPEN_CB} = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ return $self->{XML_LIBXSLT_OPEN_CB};
+ }
+ else {
+ $OpenCB = shift if scalar @_;
+ return $OpenCB;
+ }
+}
+
+sub callbacks {
+ my $self = shift;
+ if ( ref $self ) {
+ if (@_) {
+ my ($match, $open, $read, $close) = @_;
+ @{$self}{qw(XML_LIBXSLT_MATCH_CB XML_LIBXSLT_OPEN_CB XML_LIBXSLT_READ_CB XML_LIBXSLT_CLOSE_CB)} = ($match, $open, $read, $close);
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = undef;
+ }
+ else {
+ return @{$self}{qw(XML_LIBXSLT_MATCH_CB XML_LIBXSLT_OPEN_CB XML_LIBXSLT_READ_CB XML_LIBXSLT_CLOSE_CB)};
+ }
+ }
+ else {
+ if (@_) {
+ ( $MatchCB, $OpenCB, $ReadCB, $CloseCB ) = @_;
+ }
+ else {
+ return ( $MatchCB, $OpenCB, $ReadCB, $CloseCB );
+ }
+ }
+}
+
+sub _init_callbacks {
+ my $self = shift;
+ my $icb = $self->{XML_LIBXSLT_CALLBACK_STACK};
+
+ unless ( defined $icb ) {
+ $self->{XML_LIBXSLT_CALLBACK_STACK} = XML::LibXML::InputCallback->new();
+ $icb = $self->{XML_LIBXSLT_CALLBACK_STACK};
+ }
+
+ my $mcb = $self->match_callback();
+ my $ocb = $self->open_callback();
+ my $rcb = $self->read_callback();
+ my $ccb = $self->close_callback();
+
+ if ( defined $mcb and defined $ocb and defined $rcb and defined $ccb ) {
+ $icb->register_callbacks( [$mcb, $ocb, $rcb, $ccb] );
+ }
+ $self->XML::LibXSLT::lib_init_callbacks();
+ $icb->init_callbacks();
+
+ my $scb = $self->{XML_LIBXSLT_SECPREFS};
+ if ( $scb ) {
+ $scb->init_callbacks();
+ }
+}
+
+sub _cleanup_callbacks {
+ my $self = shift;
+ $self->{XML_LIBXSLT_CALLBACK_STACK}->cleanup_callbacks();
+ my $mcb = $self->match_callback();
+ if ( defined $mcb ) {
+ $self->{XML_LIBXSLT_CALLBACK_STACK}->unregister_callbacks( [$mcb] );
+ }
+
+ my $scb = $self->{XML_LIBXSLT_SECPREFS};
+ if ( $scb ) {
+ $scb->cleanup_callbacks();
+ }
+}
+
+sub transform {
+ my $self = shift;
+ my $doc;
+
+ $self->_init_callbacks();
+ eval { $doc = $self->{XML_LIBXSLT_STYLESHEET}->transform($self,@_); };
+ $self->_cleanup_callbacks();
+
+ my $err = $@;
+ if ($err) {
+ croak $err;
+ }
+
+ return $doc;
+}
+
+sub transform_file {
+ my $self = shift;
+ my $doc;
+
+ $self->_init_callbacks();
+ eval { $doc = $self->{XML_LIBXSLT_STYLESHEET}->transform_file($self,@_); };
+ $self->_cleanup_callbacks();
+
+ my $err = $@;
+ if ($err) {
+ croak $err;
+ }
+
+ return $doc;
+}
+
+sub output_string { shift->{XML_LIBXSLT_STYLESHEET}->_output_string($_[0],0) }
+sub output_as_bytes { shift->{XML_LIBXSLT_STYLESHEET}->_output_string($_[0],1) }
+sub output_as_chars { shift->{XML_LIBXSLT_STYLESHEET}->_output_string($_[0],2) }
+sub output_fh { shift->{XML_LIBXSLT_STYLESHEET}->output_fh(@_) }
+sub output_file { shift->{XML_LIBXSLT_STYLESHEET}->output_file(@_) }
+sub media_type { shift->{XML_LIBXSLT_STYLESHEET}->media_type(@_) }
+sub output_encoding { shift->{XML_LIBXSLT_STYLESHEET}->output_encoding(@_) }
+
+1;
+
+# XML::LibXSLT::Security Interface #
+#-------------------------------------------------------------------------#
+package XML::LibXSLT::Security;
+
+use strict;
+use Carp;
+
+use vars qw(%OPTION_MAP %_GLOBAL_CALLBACKS);
+
+# Maps the option names used in the perl interface to the numeric values
+# used by libxslt.
+my %OPTION_MAP = (
+ read_file => 1,
+ write_file => 2,
+ create_dir => 3,
+ read_net => 4,
+ write_net => 5,
+);
+
+%_GLOBAL_CALLBACKS = ();
+
+
+#-------------------------------------------------------------------------#
+# global callback #
+#-------------------------------------------------------------------------#
+sub _security_check {
+ my $option = shift;
+ my $retval = 1;
+
+ if ($option == 3) {
+ $retval = 0; # Default create_dir to no access
+ }
+
+ if (exists $_GLOBAL_CALLBACKS{$option}) {
+ $retval = $_GLOBAL_CALLBACKS{$option}->(@_);
+ }
+
+ return $retval;
+}
+
+#-------------------------------------------------------------------------#
+# member functions and methods #
+#-------------------------------------------------------------------------#
+
+sub new {
+ my $class = shift;
+ return bless {'_CALLBACKS' => {}}, $class;
+}
+
+# Add a callback for the given security option (read_file, write_file,
+# create_dir, read_net, write_net).
+#
+# To register a callback that handle network read requests:
+# $scb->register_callback( read_net => \&callback );
+sub register_callback {
+ my $self = shift;
+ my $option = shift;
+ my $callback = shift;
+
+ unless ( exists $OPTION_MAP{$option} ) {
+ croak "Invalid security option '$option'. Must be one of: " .
+ join(', ', keys %OPTION_MAP) . ".";
+ }
+
+ if ( ref $callback eq 'CODE' ) {
+ $self->{_CALLBACKS}{ $OPTION_MAP{$option} } = $callback;
+ }
+ else {
+ croak "Invalid argument. The callback must be a reference to a subroutine";
+ }
+}
+
+# Removes the callback for the given security option. Causes the given option
+# to use the default security handler (which always allows the action).
+sub unregister_callback {
+ my $self = shift;
+ my $option = shift;
+
+ unless ( exists $OPTION_MAP{$option} ) {
+ croak "Invalid security option '$option'. Must be one of: " .
+ join(', ', keys %OPTION_MAP) . ".";
+ }
+
+ delete $self->{_CALLBACKS}{ $OPTION_MAP{$option} };
+}
+
+
+# make it so libxslt can use the callbacks
+sub init_callbacks {
+ my $self = shift;
+
+ %_GLOBAL_CALLBACKS = %{ $self->{_CALLBACKS} };
+}
+
+# reset libxslt callbacks
+sub cleanup_callbacks {
+ my $self = shift;
+
+ %_GLOBAL_CALLBACKS = ();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::LibXSLT - Interface to the gnome libxslt library
+
+=head1 SYNOPSIS
+
+ use XML::LibXSLT;
+ use XML::LibXML;
+
+ my $xslt = XML::LibXSLT->new();
+
+ my $source = XML::LibXML->load_xml(location => 'foo.xml');
+ my $style_doc = XML::LibXML->load_xml(location=>'bar.xsl', no_cdata=>1);
+
+ my $stylesheet = $xslt->parse_stylesheet($style_doc);
+
+ my $results = $stylesheet->transform($source);
+
+ print $stylesheet->output_as_bytes($results);
+
+=head1 DESCRIPTION
+
+This module is an interface to the gnome project's libxslt. This is an
+extremely good XSLT engine, highly compliant and also very fast. I have
+tests showing this to be more than twice as fast as Sablotron.
+
+=head1 OPTIONS
+
+XML::LibXSLT has some global options. Note that these are probably not
+thread or even fork safe - so only set them once per process. Each one
+of these options can be called either as class methods, or as instance
+methods. However either way you call them, it still sets global options.
+
+Each of the option methods returns its previous value, and can be called
+without a parameter to retrieve the current value.
+
+=over
+
+=item max_depth
+
+ XML::LibXSLT->max_depth(1000);
+
+This option sets the maximum recursion depth for a stylesheet. See the
+very end of section 5.4 of the XSLT specification for more details on
+recursion and detecting it. If your stylesheet or XML file requires
+seriously deep recursion, this is the way to set it. Default value is
+250.
+
+=item debug_callback
+
+ XML::LibXSLT->debug_callback($subref);
+
+Sets a callback to be used for debug messages. If you don't set this,
+debug messages will be ignored.
+
+=item register_function
+
+ XML::LibXSLT->register_function($uri, $name, $subref);
+
+Registers an XSLT extension function mapped to the given URI. For example:
+
+ XML::LibXSLT->register_function("urn:foo", "bar",
+ sub { scalar localtime });
+
+Will register a C<bar> function in the C<urn:foo> namespace (which you
+have to define in your XSLT using C<xmlns:...>) that will return the
+current date and time as a string:
+
+ <xsl:stylesheet version="1.0"
+ xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ xmlns:foo="urn:foo">
+ <xsl:template match="/">
+ The time is: <xsl:value-of select="foo:bar()"/>
+ </xsl:template>
+ </xsl:stylesheet>
+
+Parameters can be in whatever format you like. If you pass in a nodelist
+it will be a XML::LibXML::NodeList object in your perl code, but ordinary
+values (strings, numbers and booleans) will be ordinary perl scalars. If
+you wish them to be C<XML::LibXML::Literal>, C<XML::LibXML::Number> and
+C<XML::LibXML::Number> values respectively then set the variable
+C<$XML::LibXSLT::USE_LIBXML_DATA_TYPES> to a true value. Return values can
+be a nodelist or a plain value - the code will just do the right thing.
+But only a single return value is supported (a list is not converted to
+a nodelist).
+
+=back
+
+=head1 API
+
+The following methods are available on the new XML::LibXSLT object:
+
+=over
+
+=item parse_stylesheet($stylesheet_doc)
+
+C<$stylesheet_doc> here is an XML::LibXML::Document object (see L<XML::LibXML>)
+representing an XSLT file. This method will return a
+XML::LibXSLT::Stylesheet object, or undef on failure. If the XSLT is
+invalid, an exception will be thrown, so wrap the call to
+parse_stylesheet in an eval{} block to trap this.
+
+IMPORTANT: C<$stylesheet_doc> should not contain CDATA sections,
+otherwise libxslt may misbehave. The best way to assure this is to
+load the stylesheet with no_cdata flag, e.g.
+
+ my $stylesheet_doc = XML::LibXML->load_xml(location=>"some.xsl", no_cdata=>1);
+
+=item parse_stylesheet_file($filename)
+
+Exactly the same as the above, but parses the given filename directly.
+
+=back
+
+=head1 Input Callbacks
+
+To define XML::LibXSLT or XML::LibXSLT::Stylesheet specific input
+callbacks, reuse the XML::LibXML input callback API as described in
+L<XML::LibXML::InputCallback(3)>.
+
+=head1 Security Callbacks
+
+To create security preferences for the transformation see
+L<XML::LibXSLT::Security>. Once the security preferences have been defined you
+can apply them to an XML::LibXSLT or XML::LibXSLT::Stylesheet instance using
+the C<security_callbacks()> method.
+
+=head1 XML::LibXSLT::Stylesheet
+
+The main API is on the stylesheet, though it is fairly minimal.
+
+One of the main advantages of XML::LibXSLT is that you have a generic
+stylesheet object which you call the transform() method passing in a
+document to transform. This allows you to have multiple transformations
+happen with one stylesheet without requiring a reparse.
+
+=over
+
+=item transform(doc, %params)
+
+ my $results = $stylesheet->transform($doc, foo => "value);
+ print $stylesheet->output_as_bytes($results);
+
+Transforms the passed in XML::LibXML::Document object, and returns a
+new XML::LibXML::Document. Extra hash entries are used as parameters.
+See output_string
+
+=item transform_file(filename, %params)
+
+ my $results = $stylesheet->transform_file($filename, bar => "value");
+
+=item output_as_bytes(result)
+
+Returns a scalar that is the XSLT rendering of the
+XML::LibXML::Document object using the desired output format
+(specified in the xsl:output tag in the stylesheet). Note that you can
+also call $result->toString, but that will *always* output the
+document in XML format which may not be what you asked for in the
+xsl:output tag. The scalar is a byte string encoded in the output
+encoding specified in the stylesheet.
+
+=item output_as_chars(result)
+
+Like C<output_as_bytes(result)>, but always return the output as (UTF-8
+encoded) string of characters.
+
+=item output_string(result)
+
+DEPRECATED: This method is something between
+C<output_as_bytes(result)> and C<output_as_bytes(result)>: The scalar
+returned by this function appears to Perl as characters (UTF8 flag is
+on) if the output encoding specified in the XSLT stylesheet was UTF-8
+and as bytes if no output encoding was specified or if the output
+encoding was other than UTF-8. Since the behavior of this function
+depends on the particular stylesheet, it is deprecated in favor of
+C<output_as_bytes(result)> and C<output_as_chars(result)>.
+
+=item output_fh(result, fh)
+
+Outputs the result to the filehandle given in C<$fh>.
+
+=item output_file(result, filename)
+
+Outputs the result to the file named in C<$filename>.
+
+=item output_encoding()
+
+Returns the output encoding of the results. Defaults to "UTF-8".
+
+=item media_type()
+
+Returns the output media_type of the results. Defaults to "text/html".
+
+=back
+
+=head1 Parameters
+
+LibXSLT expects parameters in XPath format. That is, if you wish to pass
+a string to the XSLT engine, you actually have to pass it as a quoted
+string:
+
+ $stylesheet->transform($doc, param => "'string'");
+
+Note the quotes within quotes there!
+
+Obviously this isn't much fun, so you can make it easy on yourself:
+
+ $stylesheet->transform($doc, XML::LibXSLT::xpath_to_string(
+ param => "string"
+ ));
+
+The utility function does the right thing with respect to strings in XPath,
+including when you have quotes already embedded within your string.
+
+
+=head1 XML::LibXSLT::Security
+
+Provides an interface to the libxslt security framework by allowing callbacks
+to be defined that can restrict access to various resources (files or URLs)
+during a transformation.
+
+The libxslt security framework allows callbacks to be defined for certain
+actions that a stylesheet may attempt during a transformation. It may be
+desirable to restrict some of these actions (for example, writing a new file
+using exsl:document). The actions that may be restricted are:
+
+=over
+
+=item read_file
+
+Called when the stylesheet attempts to open a local file (ie: when using the
+document() function).
+
+=item write_file
+
+Called when an attempt is made to write a local file (ie: when using the
+exsl:document element).
+
+=item create_dir
+
+Called when a directory needs to be created in order to write a file.
+
+NOTE: By default, create_dir is not allowed. To enable it a callback must be
+registered.
+
+=item read_net
+
+Called when the stylesheet attempts to read from the network.
+
+=item write_net
+
+Called when the stylesheet attempts to write to the network.
+
+=back
+
+=head2 Using XML::LibXSLT::Security
+
+The interface for this module is similar to XML::LibXML::InputCallback. After
+creating a new instance you may register callbacks for each of the security
+options listed above. Then you apply the security preferences to the
+XML::LibXSLT or XML::LibXSLT::Stylesheet object using C<security_callbacks()>.
+
+ my $security = XML::LibXSLT::Security->new();
+ $security->register_callback( read_file => $read_cb );
+ $security->register_callback( write_file => $write_cb );
+ $security->register_callback( create_dir => $create_cb );
+ $security->register_callback( read_net => $read_net_cb );
+ $security->register_callback( write_net => $write_net_cb );
+
+ $xslt->security_callbacks( $security );
+ -OR-
+ $stylesheet->security_callbacks( $security );
+
+
+The registered callback functions are called when access to a resource is
+requested. If the access should be allowed the callback should return 1, if
+not it should return 0. The callback functions should accept the following
+arguments:
+
+=over
+
+=item $tctxt
+
+This is the transform context (XML::LibXSLT::TransformContext). You can use
+this to get the current XML::LibXSLT::Stylesheet object by calling
+C<stylesheet()>.
+
+ my $stylesheet = $tctxt->stylesheet();
+
+The stylesheet object can then be used to share contextual information between
+different calls to the security callbacks.
+
+=item $value
+
+This is the name of the resource (file or URI) that has been requested.
+
+=back
+
+If a particular option (except for C<create_dir>) doesn't have a registered
+callback, then the stylesheet will have full access for that action.
+
+=head2 Interface
+
+=over
+
+=item new()
+
+Creates a new XML::LibXSLT::Security object.
+
+=item register_callback( $option, $callback )
+
+Registers a callback function for the given security option (listed above).
+
+=item unregister_callback( $option )
+
+Removes the callback for the given option. This has the effect of allowing all
+access for the given option (except for C<create_dir>).
+
+=back
+
+=head1 BENCHMARK
+
+Included in the distribution is a simple benchmark script, which has two
+drivers - one for LibXSLT and one for Sablotron. The benchmark requires
+the testcases files from the XSLTMark distribution which you can find
+at http://www.datapower.com/XSLTMark/
+
+Put the testcases directory in the directory created by this distribution,
+and then run:
+
+ perl benchmark.pl -h
+
+to get a list of options.
+
+The benchmark requires XML::XPath at the moment, but I hope to factor that
+out of the equation fairly soon. It also requires Time::HiRes, which I
+could be persuaded to factor out, replacing it with Benchmark.pm, but I
+haven't done so yet.
+
+I would love to get drivers for XML::XSLT and XML::Transformiix, if you
+would like to contribute them. Also if you get this running on Win32, I'd
+love to get a driver for MSXSLT via OLE, to see what we can do against
+those Redmond boys!
+
+=head1 LIBRARY VERSIONS
+
+For debugging purposes, XML::LibXSLT provides version information
+about the libxslt C library (but do not confuse it with the version
+number of XML::LibXSLT module itself, i.e. with
+C<$XML::LibXSLT::VERSION>). XML::LibXSLT issues a warning if the
+runtime version of the library is less then the compile-time version.
+
+=over
+
+=item XML::LibXSLT::LIBXSLT_VERSION()
+
+Returns version number of libxslt library which was used to compile
+XML::LibXSLT as an integer. For example, for libxslt-1.1.18, it will
+return 10118.
+
+=item XML::LibXSLT::LIBXSLT_DOTTED_VERSION()
+
+Returns version number of libxslt library which was used to compile
+XML::LibXSLT as a string, e.g. "1.1.18".
+
+=item XML::LibXSLT::LIBXSLT_RUNTIME_VERSION()
+
+Returns version number of libxslt library to which XML::LibXSLT is
+linked at runtime (either dynamically or statically). For example, for
+example, for libxslt.so.1.1.18, it will return 10118.
+
+=item XML::LibXSLT::HAVE_EXLT()
+
+Returns 1 if the module was compiled with libexslt, 0 otherwised.
+
+=back
+
+=head1 LICENSE
+
+This is free software, you may use it and distribute it under the same terms as
+Perl itself.
+
+Copyright 2001-2009, AxKit.com Ltd.
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org
+
+Security callbacks implementation contributed by Shane Corgatelli.
+
+=head1 MAINTAINER
+
+Petr Pajas , pajas@matfyz.org
+
+=head1 BUGS
+
+Please report bugs via
+
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=XML-LibXSLT
+
+=head1 SEE ALSO
+
+XML::LibXML
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/NamespaceSupport.pm b/Master/tlpkg/tlperl.straw/lib/XML/NamespaceSupport.pm
new file mode 100755
index 00000000000..0f57a578397
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/NamespaceSupport.pm
@@ -0,0 +1,583 @@
+
+###
+# XML::NamespaceSupport - a simple generic namespace processor
+# Robin Berjon <robin@knowscape.com>
+###
+
+package XML::NamespaceSupport;
+use strict;
+use constant FATALS => 0; # root object
+use constant NSMAP => 1;
+use constant UNKNOWN_PREF => 2;
+use constant AUTO_PREFIX => 3;
+use constant XMLNS_11 => 4;
+use constant DEFAULT => 0; # maps
+use constant PREFIX_MAP => 1;
+use constant DECLARATIONS => 2;
+
+use vars qw($VERSION $NS_XMLNS $NS_XML);
+$VERSION = '1.10';
+$NS_XMLNS = 'http://www.w3.org/2000/xmlns/';
+$NS_XML = 'http://www.w3.org/XML/1998/namespace';
+
+
+# add the ns stuff that baud wants based on Java's xml-writer
+
+
+#-------------------------------------------------------------------#
+# constructor
+#-------------------------------------------------------------------#
+sub new {
+ my $class = ref($_[0]) ? ref(shift) : shift;
+ my $options = shift;
+ my $self = [
+ 1, # FATALS
+ [[ # NSMAP
+ undef, # DEFAULT
+ { xml => $NS_XML }, # PREFIX_MAP
+ undef, # DECLARATIONS
+ ]],
+ 'aaa', # UNKNOWN_PREF
+ 0, # AUTO_PREFIX
+ 1, # XML_11
+ ];
+ $self->[NSMAP]->[0]->[PREFIX_MAP]->{xmlns} = $NS_XMLNS if $options->{xmlns};
+ $self->[FATALS] = $options->{fatal_errors} if defined $options->{fatal_errors};
+ $self->[AUTO_PREFIX] = $options->{auto_prefix} if defined $options->{auto_prefix};
+ $self->[XMLNS_11] = $options->{xmlns_11} if defined $options->{xmlns_11};
+ return bless $self, $class;
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# reset() - return to the original state (for reuse)
+#-------------------------------------------------------------------#
+sub reset {
+ my $self = shift;
+ $#{$self->[NSMAP]} = 0;
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# push_context() - add a new empty context to the stack
+#-------------------------------------------------------------------#
+sub push_context {
+ my $self = shift;
+ push @{$self->[NSMAP]}, [
+ $self->[NSMAP]->[-1]->[DEFAULT],
+ { %{$self->[NSMAP]->[-1]->[PREFIX_MAP]} },
+ [],
+ ];
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# pop_context() - remove the topmost context fromt the stack
+#-------------------------------------------------------------------#
+sub pop_context {
+ my $self = shift;
+ die 'Trying to pop context without push context' unless @{$self->[NSMAP]} > 1;
+ pop @{$self->[NSMAP]};
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# declare_prefix() - declare a prefix in the current scope
+#-------------------------------------------------------------------#
+sub declare_prefix {
+ my $self = shift;
+ my $prefix = shift;
+ my $value = shift;
+
+ warn <<' EOWARN' unless defined $prefix or $self->[AUTO_PREFIX];
+ Prefix was undefined.
+ If you wish to set the default namespace, use the empty string ''.
+ If you wish to autogenerate prefixes, set the auto_prefix option
+ to a true value.
+ EOWARN
+
+ no warnings 'uninitialized';
+ if ($prefix eq 'xml' and $value ne $NS_XML) {
+ die "The xml prefix can only be bound to the $NS_XML namespace."
+ }
+ elsif ($value eq $NS_XML and $prefix ne 'xml') {
+ die "the $NS_XML namespace can only be bound to the xml prefix.";
+ }
+ elsif ($value eq $NS_XML and $prefix eq 'xml') {
+ return 1;
+ }
+ return 0 if index(lc($prefix), 'xml') == 0;
+ use warnings 'uninitialized';
+
+ if (defined $prefix and $prefix eq '') {
+ $self->[NSMAP]->[-1]->[DEFAULT] = $value;
+ }
+ else {
+ die "Cannot undeclare prefix $prefix" if $value eq '' and not $self->[XMLNS_11];
+ if (not defined $prefix and $self->[AUTO_PREFIX]) {
+ while (1) {
+ $prefix = $self->[UNKNOWN_PREF]++;
+ last if not exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix};
+ }
+ }
+ elsif (not defined $prefix and not $self->[AUTO_PREFIX]) {
+ return 0;
+ }
+ $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix} = $value;
+ }
+ push @{$self->[NSMAP]->[-1]->[DECLARATIONS]}, $prefix;
+ return 1;
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# declare_prefixes() - declare several prefixes in the current scope
+#-------------------------------------------------------------------#
+sub declare_prefixes {
+ my $self = shift;
+ my %prefixes = @_;
+ while (my ($k,$v) = each %prefixes) {
+ $self->declare_prefix($k,$v);
+ }
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# undeclare_prefix
+#-------------------------------------------------------------------#
+sub undeclare_prefix {
+ my $self = shift;
+ my $prefix = shift;
+ return unless not defined $prefix or $prefix eq '';
+ return unless exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix};
+
+ my ( $tfix ) = grep { $_ eq $prefix } @{$self->[NSMAP]->[-1]->[DECLARATIONS]};
+ if ( not defined $tfix ) {
+ die "prefix $prefix not declared in this context\n";
+ }
+
+ @{$self->[NSMAP]->[-1]->[DECLARATIONS]} = grep { $_ ne $prefix } @{$self->[NSMAP]->[-1]->[DECLARATIONS]};
+ delete $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix};
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_prefix() - get a (random) prefix for a given URI
+#-------------------------------------------------------------------#
+sub get_prefix {
+ my $self = shift;
+ my $uri = shift;
+
+ # we have to iterate over the whole hash here because if we don't
+ # the iterator isn't reset and the next pass will fail
+ my $pref;
+ while (my ($k, $v) = each %{$self->[NSMAP]->[-1]->[PREFIX_MAP]}) {
+ $pref = $k if $v eq $uri;
+ }
+ return $pref;
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_prefixes() - get all the prefixes for a given URI
+#-------------------------------------------------------------------#
+sub get_prefixes {
+ my $self = shift;
+ my $uri = shift;
+
+ return keys %{$self->[NSMAP]->[-1]->[PREFIX_MAP]} unless defined $uri;
+ return grep { $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$_} eq $uri } keys %{$self->[NSMAP]->[-1]->[PREFIX_MAP]};
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_declared_prefixes() - get all prefixes declared in the last context
+#-------------------------------------------------------------------#
+sub get_declared_prefixes {
+ return @{$_[0]->[NSMAP]->[-1]->[DECLARATIONS]};
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_uri() - get an URI given a prefix
+#-------------------------------------------------------------------#
+sub get_uri {
+ my $self = shift;
+ my $prefix = shift;
+
+ warn "Prefix must not be undef in get_uri(). The emtpy prefix must be ''" unless defined $prefix;
+
+ return $self->[NSMAP]->[-1]->[DEFAULT] if $prefix eq '';
+ return $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix} if exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix};
+ return undef;
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# process_name() - provide details on a name
+#-------------------------------------------------------------------#
+sub process_name {
+ my $self = shift;
+ my $qname = shift;
+ my $aflag = shift;
+
+ if ($self->[FATALS]) {
+ return( ($self->_get_ns_details($qname, $aflag))[0,2], $qname );
+ }
+ else {
+ eval { return( ($self->_get_ns_details($qname, $aflag))[0,2], $qname ); }
+ }
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# process_element_name() - provide details on a element's name
+#-------------------------------------------------------------------#
+sub process_element_name {
+ my $self = shift;
+ my $qname = shift;
+
+ if ($self->[FATALS]) {
+ return $self->_get_ns_details($qname, 0);
+ }
+ else {
+ eval { return $self->_get_ns_details($qname, 0); }
+ }
+}
+#-------------------------------------------------------------------#
+
+
+#-------------------------------------------------------------------#
+# process_attribute_name() - provide details on a attribute's name
+#-------------------------------------------------------------------#
+sub process_attribute_name {
+ my $self = shift;
+ my $qname = shift;
+
+ if ($self->[FATALS]) {
+ return $self->_get_ns_details($qname, 1);
+ }
+ else {
+ eval { return $self->_get_ns_details($qname, 1); }
+ }
+}
+#-------------------------------------------------------------------#
+
+
+#-------------------------------------------------------------------#
+# ($ns, $prefix, $lname) = $self->_get_ns_details($qname, $f_attr)
+# returns ns, prefix, and lname for a given attribute name
+# >> the $f_attr flag, if set to one, will work for an attribute
+#-------------------------------------------------------------------#
+sub _get_ns_details {
+ my $self = shift;
+ my $qname = shift;
+ my $aflag = shift;
+
+ my ($ns, $prefix, $lname);
+ (my ($tmp_prefix, $tmp_lname) = split /:/, $qname, 3)
+ < 3 or die "Invalid QName: $qname";
+
+ # no prefix
+ my $cur_map = $self->[NSMAP]->[-1];
+ if (not defined($tmp_lname)) {
+ $prefix = undef;
+ $lname = $qname;
+ # attr don't have a default namespace
+ $ns = ($aflag) ? undef : $cur_map->[DEFAULT];
+ }
+
+ # prefix
+ else {
+ if (exists $cur_map->[PREFIX_MAP]->{$tmp_prefix}) {
+ $prefix = $tmp_prefix;
+ $lname = $tmp_lname;
+ $ns = $cur_map->[PREFIX_MAP]->{$prefix}
+ }
+ else { # no ns -> lname == name, all rest undef
+ die "Undeclared prefix: $tmp_prefix";
+ }
+ }
+
+ return ($ns, $prefix, $lname);
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# parse_jclark_notation() - parse the Clarkian notation
+#-------------------------------------------------------------------#
+sub parse_jclark_notation {
+ shift;
+ my $jc = shift;
+ $jc =~ m/^\{(.*)\}([^}]+)$/;
+ return $1, $2;
+}
+#-------------------------------------------------------------------#
+
+
+#-------------------------------------------------------------------#
+# Java names mapping
+#-------------------------------------------------------------------#
+*XML::NamespaceSupport::pushContext = \&push_context;
+*XML::NamespaceSupport::popContext = \&pop_context;
+*XML::NamespaceSupport::declarePrefix = \&declare_prefix;
+*XML::NamespaceSupport::declarePrefixes = \&declare_prefixes;
+*XML::NamespaceSupport::getPrefix = \&get_prefix;
+*XML::NamespaceSupport::getPrefixes = \&get_prefixes;
+*XML::NamespaceSupport::getDeclaredPrefixes = \&get_declared_prefixes;
+*XML::NamespaceSupport::getURI = \&get_uri;
+*XML::NamespaceSupport::processName = \&process_name;
+*XML::NamespaceSupport::processElementName = \&process_element_name;
+*XML::NamespaceSupport::processAttributeName = \&process_attribute_name;
+*XML::NamespaceSupport::parseJClarkNotation = \&parse_jclark_notation;
+*XML::NamespaceSupport::undeclarePrefix = \&undeclare_prefix;
+#-------------------------------------------------------------------#
+
+
+1;
+#,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,#
+#`,`, Documentation `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,#
+#```````````````````````````````````````````````````````````````````#
+
+=pod
+
+=head1 NAME
+
+XML::NamespaceSupport - a simple generic namespace support class
+
+=head1 SYNOPSIS
+
+ use XML::NamespaceSupport;
+ my $nsup = XML::NamespaceSupport->new;
+
+ # add a new empty context
+ $nsup->push_context;
+ # declare a few prefixes
+ $nsup->declare_prefix($prefix1, $uri1);
+ $nsup->declare_prefix($prefix2, $uri2);
+ # the same shorter
+ $nsup->declare_prefixes($prefix1 => $uri1, $prefix2 => $uri2);
+
+ # get a single prefix for a URI (randomly)
+ $prefix = $nsup->get_prefix($uri);
+ # get all prefixes for a URI (probably better)
+ @prefixes = $nsup->get_prefixes($uri);
+ # get all prefixes in scope
+ @prefixes = $nsup->get_prefixes();
+ # get all prefixes that were declared for the current scope
+ @prefixes = $nsup->get_declared_prefixes;
+ # get a URI for a given prefix
+ $uri = $nsup->get_uri($prefix);
+
+ # get info on a qname (java-ish way, it's a bit weird)
+ ($ns_uri, $local_name, $qname) = $nsup->process_name($qname, $is_attr);
+ # the same, more perlish
+ ($ns_uri, $prefix, $local_name) = $nsup->process_element_name($qname);
+ ($ns_uri, $prefix, $local_name) = $nsup->process_attribute_name($qname);
+
+ # remove the current context
+ $nsup->pop_context;
+
+ # reset the object for reuse in another document
+ $nsup->reset;
+
+ # a simple helper to process Clarkian Notation
+ my ($ns, $lname) = $nsup->parse_jclark_notation('{http://foo}bar');
+ # or (given that it doesn't care about the object
+ my ($ns, $lname) = XML::NamespaceSupport->parse_jclark_notation('{http://foo}bar');
+
+
+=head1 DESCRIPTION
+
+This module offers a simple to process namespaced XML names (unames)
+from within any application that may need them. It also helps maintain
+a prefix to namespace URI map, and provides a number of basic checks.
+
+The model for this module is SAX2's NamespaceSupport class, readable at
+http://www.megginson.com/SAX/Java/javadoc/org/xml/sax/helpers/NamespaceSupport.html.
+It adds a few perlisations where we thought it appropriate.
+
+=head1 METHODS
+
+=over 4
+
+=item * XML::NamespaceSupport->new(\%options)
+
+A simple constructor.
+
+The options are C<xmlns>, C<fatal_errors>, and C<auto_prefix>
+
+If C<xmlns> is turned on (it is off by default) the mapping from the
+xmlns prefix to the URI defined for it in DOM level 2 is added to the
+list of predefined mappings (which normally only contains the xml
+prefix mapping).
+
+If C<fatal_errors> is turned off (it is on by default) a number of
+validity errors will simply be flagged as failures, instead of
+die()ing.
+
+If C<auto_prefix> is turned on (it is off by default) when one
+provides a prefix of C<undef> to C<declare_prefix> it will generate a
+random prefix mapped to that namespace. Otherwise an undef prefix will
+trigger a warning (you should probably know what you're doing if you
+turn this option on).
+
+If C<xmlns_11> us turned off, it becomes illegal to undeclare namespace
+prefixes. It is on by default. This behaviour is compliant with Namespaces
+in XML 1.1, turning it off reverts you to version 1.0.
+
+=item * $nsup->push_context
+
+Adds a new empty context to the stack. You can then populate it with
+new prefixes defined at this level.
+
+=item * $nsup->pop_context
+
+Removes the topmost context in the stack and reverts to the previous
+one. It will die() if you try to pop more than you have pushed.
+
+=item * $nsup->declare_prefix($prefix, $uri)
+
+Declares a mapping of $prefix to $uri, at the current level.
+
+Note that with C<auto_prefix> turned on, if you declare a prefix
+mapping in which $prefix is undef(), you will get an automatic prefix
+selected for you. If it is off you will get a warning.
+
+This is useful when you deal with code that hasn't kept prefixes around
+and need to reserialize the nodes. It also means that if you want to
+set the default namespace (ie with an empty prefix) you must use the
+empty string instead of undef. This behaviour is consistent with the
+SAX 2.0 specification.
+
+=item * $nsup->declare_prefixes(%prefixes2uris)
+
+Declares a mapping of several prefixes to URIs, at the current level.
+
+=item * $nsup->get_prefix($uri)
+
+Returns a prefix given an URI. Note that as several prefixes may be
+mapped to the same URI, it returns an arbitrary one. It'll return
+undef on failure.
+
+=item * $nsup->get_prefixes($uri)
+
+Returns an array of prefixes given an URI. It'll return all the
+prefixes if the uri is undef.
+
+=item * $nsup->get_declared_prefixes
+
+Returns an array of all the prefixes that have been declared within
+this context, ie those that were declared on the last element, not
+those that were declared above and are simply in scope.
+
+=item * $nsup->get_uri($prefix)
+
+Returns a URI for a given prefix. Returns undef on failure.
+
+=item * $nsup->process_name($qname, $is_attr)
+
+Given a qualified name and a boolean indicating whether this is an
+attribute or another type of name (those are differently affected by
+default namespaces), it returns a namespace URI, local name, qualified
+name tuple. I know that that is a rather abnormal list to return, but
+it is so for compatibility with the Java spec. See below for more
+Perlish alternatives.
+
+If the prefix is not declared, or if the name is not valid, it'll
+either die or return undef depending on the current setting of
+C<fatal_errors>.
+
+=item * $nsup->undeclare_prefix($prefix);
+
+Removes a namespace prefix from the current context. This function may
+be used in SAX's end_prefix_mapping when there is fear that a namespace
+declaration might be available outside their scope (which shouldn't
+normally happen, but you never know ;). This may be needed in order to
+properly support Namespace 1.1.
+
+=item * $nsup->process_element_name($qname)
+
+Given a qualified name, it returns a namespace URI, prefix, and local
+name tuple. This method applies to element names.
+
+If the prefix is not declared, or if the name is not valid, it'll
+either die or return undef depending on the current setting of
+C<fatal_errors>.
+
+=item * $nsup->process_attribute_name($qname)
+
+Given a qualified name, it returns a namespace URI, prefix, and local
+name tuple. This method applies to attribute names.
+
+If the prefix is not declared, or if the name is not valid, it'll
+either die or return undef depending on the current setting of
+C<fatal_errors>.
+
+=item * $nsup->reset
+
+Resets the object so that it can be reused on another document.
+
+=back
+
+All methods of the interface have an alias that is the name used in
+the original Java specification. You can use either name
+interchangeably. Here is the mapping:
+
+ Java name Perl name
+ ---------------------------------------------------
+ pushContext push_context
+ popContext pop_context
+ declarePrefix declare_prefix
+ declarePrefixes declare_prefixes
+ getPrefix get_prefix
+ getPrefixes get_prefixes
+ getDeclaredPrefixes get_declared_prefixes
+ getURI get_uri
+ processName process_name
+ processElementName process_element_name
+ processAttributeName process_attribute_name
+ parseJClarkNotation parse_jclark_notation
+ undeclarePrefix undeclare_prefix
+
+=head1 VARIABLES
+
+Two global variables are made available to you. They used to be constants but
+simple scalars are easier to use in a number of contexts. They are not
+exported but can easily be accessed from any package, or copied into it.
+
+=over 4
+
+=item * C<$NS_XMLNS>
+
+The namespace for xmlns prefixes, http://www.w3.org/2000/xmlns/.
+
+=item * C<$NS_XML>
+
+The namespace for xml prefixes, http://www.w3.org/XML/1998/namespace.
+
+=back
+
+=head1 TODO
+
+ - add more tests
+ - optimise here and there
+
+=head1 AUTHOR
+
+Robin Berjon, robin@knowscape.com, with lots of it having been done
+by Duncan Cameron, and a number of suggestions from the perl-xml
+list.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2005 Robin Berjon. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=head1 SEE ALSO
+
+XML::Parser::PerlSAX
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser.pm b/Master/tlpkg/tlperl.straw/lib/XML/Parser.pm
new file mode 100755
index 00000000000..064b021ec5b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser.pm
@@ -0,0 +1,840 @@
+# XML::Parser
+#
+# Copyright (c) 1998-2000 Larry Wall and Clark Cooper
+# All rights reserved.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package XML::Parser;
+
+use Carp;
+
+BEGIN {
+ require XML::Parser::Expat;
+ $VERSION = '2.36';
+ die "Parser.pm and Expat.pm versions don't match"
+ unless $VERSION eq $XML::Parser::Expat::VERSION;
+}
+
+use strict;
+
+use vars qw($VERSION $LWP_load_failed);
+
+$LWP_load_failed = 0;
+
+sub new {
+ my ($class, %args) = @_;
+ my $style = $args{Style};
+
+ my $nonexopt = $args{Non_Expat_Options} ||= {};
+
+ $nonexopt->{Style} = 1;
+ $nonexopt->{Non_Expat_Options} = 1;
+ $nonexopt->{Handlers} = 1;
+ $nonexopt->{_HNDL_TYPES} = 1;
+ $nonexopt->{NoLWP} = 1;
+
+ $args{_HNDL_TYPES} = {%XML::Parser::Expat::Handler_Setters};
+ $args{_HNDL_TYPES}->{Init} = 1;
+ $args{_HNDL_TYPES}->{Final} = 1;
+
+ $args{Handlers} ||= {};
+ my $handlers = $args{Handlers};
+
+ if (defined($style)) {
+ my $stylepkg = $style;
+
+ if ($stylepkg !~ /::/) {
+ $stylepkg = "\u$style";
+
+ eval {
+ my $fullpkg = 'XML::Parser::Style::' . $stylepkg;
+ my $stylefile = $fullpkg;
+ $stylefile =~ s/::/\//g;
+ require "$stylefile.pm";
+ $stylepkg = $fullpkg;
+ };
+ if ($@) {
+ # fallback to old behaviour
+ $stylepkg = 'XML::Parser::' . $stylepkg;
+ }
+ }
+
+ my $htype;
+ foreach $htype (keys %{$args{_HNDL_TYPES}}) {
+ # Handlers explicity given override
+ # handlers from the Style package
+ unless (defined($handlers->{$htype})) {
+
+ # A handler in the style package must either have
+ # exactly the right case as the type name or a
+ # completely lower case version of it.
+
+ my $hname = "${stylepkg}::$htype";
+ if (defined(&$hname)) {
+ $handlers->{$htype} = \&$hname;
+ next;
+ }
+
+ $hname = "${stylepkg}::\L$htype";
+ if (defined(&$hname)) {
+ $handlers->{$htype} = \&$hname;
+ next;
+ }
+ }
+ }
+ }
+
+ unless (defined($handlers->{ExternEnt})
+ or defined ($handlers->{ExternEntFin})) {
+
+ if ($args{NoLWP} or $LWP_load_failed) {
+ $handlers->{ExternEnt} = \&file_ext_ent_handler;
+ $handlers->{ExternEntFin} = \&file_ext_ent_cleanup;
+ }
+ else {
+ # The following just bootstraps the real LWP external entity
+ # handler
+
+ $handlers->{ExternEnt} = \&initial_ext_ent_handler;
+
+ # No cleanup function available until LWPExternEnt.pl loaded
+ }
+ }
+
+ $args{Pkg} ||= caller;
+ bless \%args, $class;
+} # End of new
+
+sub setHandlers {
+ my ($self, @handler_pairs) = @_;
+
+ croak("Uneven number of arguments to setHandlers method")
+ if (int(@handler_pairs) & 1);
+
+ my @ret;
+ while (@handler_pairs) {
+ my $type = shift @handler_pairs;
+ my $handler = shift @handler_pairs;
+ unless (defined($self->{_HNDL_TYPES}->{$type})) {
+ my @types = sort keys %{$self->{_HNDL_TYPES}};
+
+ croak("Unknown Parser handler type: $type\n Valid types: @types");
+ }
+ push(@ret, $type, $self->{Handlers}->{$type});
+ $self->{Handlers}->{$type} = $handler;
+ }
+
+ return @ret;
+}
+
+sub parse_start {
+ my $self = shift;
+ my @expat_options = ();
+
+ my ($key, $val);
+ while (($key, $val) = each %{$self}) {
+ push (@expat_options, $key, $val)
+ unless exists $self->{Non_Expat_Options}->{$key};
+ }
+
+ my %handlers = %{$self->{Handlers}};
+ my $init = delete $handlers{Init};
+ my $final = delete $handlers{Final};
+
+ my $expatnb = new XML::Parser::ExpatNB(@expat_options, @_);
+ $expatnb->setHandlers(%handlers);
+
+ &$init($expatnb)
+ if defined($init);
+
+ $expatnb->{_State_} = 1;
+
+ $expatnb->{FinalHandler} = $final
+ if defined($final);
+
+ return $expatnb;
+}
+
+sub parse {
+ my $self = shift;
+ my $arg = shift;
+ my @expat_options = ();
+ my ($key, $val);
+ while (($key, $val) = each %{$self}) {
+ push(@expat_options, $key, $val)
+ unless exists $self->{Non_Expat_Options}->{$key};
+ }
+
+ my $expat = new XML::Parser::Expat(@expat_options, @_);
+ my %handlers = %{$self->{Handlers}};
+ my $init = delete $handlers{Init};
+ my $final = delete $handlers{Final};
+
+ $expat->setHandlers(%handlers);
+
+ if ($self->{Base}) {
+ $expat->base($self->{Base});
+ }
+
+ &$init($expat)
+ if defined($init);
+
+ my @result = ();
+ my $result;
+ eval {
+ $result = $expat->parse($arg);
+ };
+ my $err = $@;
+ if ($err) {
+ $expat->release;
+ die $err;
+ }
+
+ if ($result and defined($final)) {
+ if (wantarray) {
+ @result = &$final($expat);
+ }
+ else {
+ $result = &$final($expat);
+ }
+ }
+
+ $expat->release;
+
+ return unless defined wantarray;
+ return wantarray ? @result : $result;
+}
+
+sub parsestring {
+ my $self = shift;
+ $self->parse(@_);
+}
+
+sub parsefile {
+ my $self = shift;
+ my $file = shift;
+ local(*FILE);
+ open(FILE, $file) or croak "Couldn't open $file:\n$!";
+ binmode(FILE);
+ my @ret;
+ my $ret;
+
+ $self->{Base} = $file;
+
+ if (wantarray) {
+ eval {
+ @ret = $self->parse(*FILE, @_);
+ };
+ }
+ else {
+ eval {
+ $ret = $self->parse(*FILE, @_);
+ };
+ }
+ my $err = $@;
+ close(FILE);
+ die $err if $err;
+
+ return unless defined wantarray;
+ return wantarray ? @ret : $ret;
+}
+
+sub initial_ext_ent_handler {
+ # This just bootstraps in the real lwp_ext_ent_handler which
+ # also loads the URI and LWP modules.
+
+ unless ($LWP_load_failed) {
+ local($^W) = 0;
+
+ my $stat =
+ eval {
+ require('XML/Parser/LWPExternEnt.pl');
+ };
+
+ if ($stat) {
+ $_[0]->setHandlers(ExternEnt => \&lwp_ext_ent_handler,
+ ExternEntFin => \&lwp_ext_ent_cleanup);
+
+ goto &lwp_ext_ent_handler;
+ }
+
+ # Failed to load lwp handler, act as if NoLWP
+
+ $LWP_load_failed = 1;
+
+ my $cmsg = "Couldn't load LWP based external entity handler\n";
+ $cmsg .= "Switching to file-based external entity handler\n";
+ $cmsg .= " (To avoid this message, use NoLWP option to XML::Parser)\n";
+ warn($cmsg);
+ }
+
+ $_[0]->setHandlers(ExternEnt => \&file_ext_ent_handler,
+ ExternEntFin => \&file_ext_ent_cleanup);
+ goto &file_ext_ent_handler;
+
+}
+
+sub file_ext_ent_handler {
+ my ($xp, $base, $path) = @_;
+
+ # Prepend base only for relative paths
+
+ if (defined($base)
+ and not ($path =~ m!^(?:[\\/]|\w+:)!))
+ {
+ my $newpath = $base;
+ $newpath =~ s![^\\/:]*$!$path!;
+ $path = $newpath;
+ }
+
+ if ($path =~ /^\s*[|>+]/
+ or $path =~ /\|\s*$/) {
+ $xp->{ErrorMessage}
+ .= "System ID ($path) contains Perl IO control characters";
+ return undef;
+ }
+
+ require IO::File;
+ my $fh = new IO::File($path);
+ unless (defined $fh) {
+ $xp->{ErrorMessage}
+ .= "Failed to open $path:\n$!";
+ return undef;
+ }
+
+ $xp->{_BaseStack} ||= [];
+ $xp->{_FhStack} ||= [];
+
+ push(@{$xp->{_BaseStack}}, $base);
+ push(@{$xp->{_FhStack}}, $fh);
+
+ $xp->base($path);
+
+ return $fh;
+}
+
+sub file_ext_ent_cleanup {
+ my ($xp) = @_;
+
+ my $fh = pop(@{$xp->{_FhStack}});
+ $fh->close;
+
+ my $base = pop(@{$xp->{_BaseStack}});
+ $xp->base($base);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::Parser - A perl module for parsing XML documents
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+
+ $p1 = new XML::Parser(Style => 'Debug');
+ $p1->parsefile('REC-xml-19980210.xml');
+ $p1->parse('<foo id="me">Hello World</foo>');
+
+ # Alternative
+ $p2 = new XML::Parser(Handlers => {Start => \&handle_start,
+ End => \&handle_end,
+ Char => \&handle_char});
+ $p2->parse($socket);
+
+ # Another alternative
+ $p3 = new XML::Parser(ErrorContext => 2);
+
+ $p3->setHandlers(Char => \&text,
+ Default => \&other);
+
+ open(FOO, 'xmlgenerator |');
+ $p3->parse(*FOO, ProtocolEncoding => 'ISO-8859-1');
+ close(FOO);
+
+ $p3->parsefile('junk.xml', ErrorContext => 3);
+
+=begin man
+.ds PI PI
+
+=end man
+
+=head1 DESCRIPTION
+
+This module provides ways to parse XML documents. It is built on top of
+L<XML::Parser::Expat>, which is a lower level interface to James Clark's
+expat library. Each call to one of the parsing methods creates a new
+instance of XML::Parser::Expat which is then used to parse the document.
+Expat options may be provided when the XML::Parser object is created.
+These options are then passed on to the Expat object on each parse call.
+They can also be given as extra arguments to the parse methods, in which
+case they override options given at XML::Parser creation time.
+
+The behavior of the parser is controlled either by C<L</Style>> and/or
+C<L</Handlers>> options, or by L</setHandlers> method. These all provide
+mechanisms for XML::Parser to set the handlers needed by XML::Parser::Expat.
+If neither C<Style> nor C<Handlers> are specified, then parsing just
+checks the document for being well-formed.
+
+When underlying handlers get called, they receive as their first parameter
+the I<Expat> object, not the Parser object.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+This is a class method, the constructor for XML::Parser. Options are passed
+as keyword value pairs. Recognized options are:
+
+=over 4
+
+=item * Style
+
+This option provides an easy way to create a given style of parser. The
+built in styles are: L<"Debug">, L<"Subs">, L<"Tree">, L<"Objects">,
+and L<"Stream">. These are all defined in separate packages under
+C<XML::Parser::Style::*>, and you can find further documentation for
+each style both below, and in those packages.
+
+Custom styles can be provided by giving a full package name containing
+at least one '::'. This package should then have subs defined for each
+handler it wishes to have installed. See L<"STYLES"> below
+for a discussion of each built in style.
+
+=item * Handlers
+
+When provided, this option should be an anonymous hash containing as
+keys the type of handler and as values a sub reference to handle that
+type of event. All the handlers get passed as their 1st parameter the
+instance of expat that is parsing the document. Further details on
+handlers can be found in L<"HANDLERS">. Any handler set here
+overrides the corresponding handler set with the Style option.
+
+=item * Pkg
+
+Some styles will refer to subs defined in this package. If not provided,
+it defaults to the package which called the constructor.
+
+=item * ErrorContext
+
+This is an Expat option. When this option is defined, errors are reported
+in context. The value should be the number of lines to show on either side
+of the line in which the error occurred.
+
+=item * ProtocolEncoding
+
+This is an Expat option. This sets the protocol encoding name. It defaults
+to none. The built-in encodings are: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and
+C<US-ASCII>. Other encodings may be used if they have encoding maps in one
+of the directories in the @Encoding_Path list. Check L<"ENCODINGS"> for
+more information on encoding maps. Setting the protocol encoding overrides
+any encoding in the XML declaration.
+
+=item * Namespaces
+
+This is an Expat option. If this is set to a true value, then namespace
+processing is done during the parse. See L<XML::Parser::Expat/"Namespaces">
+for further discussion of namespace processing.
+
+=item * NoExpand
+
+This is an Expat option. Normally, the parser will try to expand references
+to entities defined in the internal subset. If this option is set to a true
+value, and a default handler is also set, then the default handler will be
+called when an entity reference is seen in text. This has no effect if a
+default handler has not been registered, and it has no effect on the expansion
+of entity references inside attribute values.
+
+=item * Stream_Delimiter
+
+This is an Expat option. It takes a string value. When this string is found
+alone on a line while parsing from a stream, then the parse is ended as if it
+saw an end of file. The intended use is with a stream of xml documents in a
+MIME multipart format. The string should not contain a trailing newline.
+
+=item * ParseParamEnt
+
+This is an Expat option. Unless standalone is set to "yes" in the XML
+declaration, setting this to a true value allows the external DTD to be read,
+and parameter entities to be parsed and expanded.
+
+=item * NoLWP
+
+This option has no effect if the ExternEnt or ExternEntFin handlers are
+directly set. Otherwise, if true, it forces the use of a file based external
+entity handler.
+
+=item * Non-Expat-Options
+
+If provided, this should be an anonymous hash whose keys are options that
+shouldn't be passed to Expat. This should only be of concern to those
+subclassing XML::Parser.
+
+=back
+
+=item setHandlers(TYPE, HANDLER [, TYPE, HANDLER [...]])
+
+This method registers handlers for various parser events. It overrides any
+previous handlers registered through the Style or Handler options or through
+earlier calls to setHandlers. By providing a false or undefined value as
+the handler, the existing handler can be unset.
+
+This method returns a list of type, handler pairs corresponding to the
+input. The handlers returned are the ones that were in effect prior to
+the call.
+
+See a description of the handler types in L<"HANDLERS">.
+
+=item parse(SOURCE [, OPT => OPT_VALUE [...]])
+
+The SOURCE parameter should either be a string containing the whole XML
+document, or it should be an open IO::Handle. Constructor options to
+XML::Parser::Expat given as keyword-value pairs may follow the SOURCE
+parameter. These override, for this call, any options or attributes passed
+through from the XML::Parser instance.
+
+A die call is thrown if a parse error occurs. Otherwise it will return 1
+or whatever is returned from the B<Final> handler, if one is installed.
+In other words, what parse may return depends on the style.
+
+=item parsestring
+
+This is just an alias for parse for backwards compatibility.
+
+=item parsefile(FILE [, OPT => OPT_VALUE [...]])
+
+Open FILE for reading, then call parse with the open handle. The file
+is closed no matter how parse returns. Returns what parse returns.
+
+=item parse_start([ OPT => OPT_VALUE [...]])
+
+Create and return a new instance of XML::Parser::ExpatNB. Constructor
+options may be provided. If an init handler has been provided, it is
+called before returning the ExpatNB object. Documents are parsed by
+making incremental calls to the parse_more method of this object, which
+takes a string. A single call to the parse_done method of this object,
+which takes no arguments, indicates that the document is finished.
+
+If there is a final handler installed, it is executed by the parse_done
+method before returning and the parse_done method returns whatever is
+returned by the final handler.
+
+=back
+
+=head1 HANDLERS
+
+Expat is an event based parser. As the parser recognizes parts of the
+document (say the start or end tag for an XML element), then any handlers
+registered for that type of an event are called with suitable parameters.
+All handlers receive an instance of XML::Parser::Expat as their first
+argument. See L<XML::Parser::Expat/"METHODS"> for a discussion of the
+methods that can be called on this object.
+
+=head2 Init (Expat)
+
+This is called just before the parsing of the document starts.
+
+=head2 Final (Expat)
+
+This is called just after parsing has finished, but only if no errors
+occurred during the parse. Parse returns what this returns.
+
+=head2 Start (Expat, Element [, Attr, Val [,...]])
+
+This event is generated when an XML start tag is recognized. Element is the
+name of the XML element type that is opened with the start tag. The Attr &
+Val pairs are generated for each attribute in the start tag.
+
+=head2 End (Expat, Element)
+
+This event is generated when an XML end tag is recognized. Note that
+an XML empty tag (<foo/>) generates both a start and an end event.
+
+=head2 Char (Expat, String)
+
+This event is generated when non-markup is recognized. The non-markup
+sequence of characters is in String. A single non-markup sequence of
+characters may generate multiple calls to this handler. Whatever the
+encoding of the string in the original document, this is given to the
+handler in UTF-8.
+
+=head2 Proc (Expat, Target, Data)
+
+This event is generated when a processing instruction is recognized.
+
+=head2 Comment (Expat, Data)
+
+This event is generated when a comment is recognized.
+
+=head2 CdataStart (Expat)
+
+This is called at the start of a CDATA section.
+
+=head2 CdataEnd (Expat)
+
+This is called at the end of a CDATA section.
+
+=head2 Default (Expat, String)
+
+This is called for any characters that don't have a registered handler.
+This includes both characters that are part of markup for which no
+events are generated (markup declarations) and characters that
+could generate events, but for which no handler has been registered.
+
+Whatever the encoding in the original document, the string is returned to
+the handler in UTF-8.
+
+=head2 Unparsed (Expat, Entity, Base, Sysid, Pubid, Notation)
+
+This is called for a declaration of an unparsed entity. Entity is the name
+of the entity. Base is the base to be used for resolving a relative URI.
+Sysid is the system id. Pubid is the public id. Notation is the notation
+name. Base and Pubid may be undefined.
+
+=head2 Notation (Expat, Notation, Base, Sysid, Pubid)
+
+This is called for a declaration of notation. Notation is the notation name.
+Base is the base to be used for resolving a relative URI. Sysid is the system
+id. Pubid is the public id. Base, Sysid, and Pubid may all be undefined.
+
+=head2 ExternEnt (Expat, Base, Sysid, Pubid)
+
+This is called when an external entity is referenced. Base is the base to be
+used for resolving a relative URI. Sysid is the system id. Pubid is the public
+id. Base, and Pubid may be undefined.
+
+This handler should either return a string, which represents the contents of
+the external entity, or return an open filehandle that can be read to obtain
+the contents of the external entity, or return undef, which indicates the
+external entity couldn't be found and will generate a parse error.
+
+If an open filehandle is returned, it must be returned as either a glob
+(*FOO) or as a reference to a glob (e.g. an instance of IO::Handle).
+
+A default handler is installed for this event. The default handler is
+XML::Parser::lwp_ext_ent_handler unless the NoLWP option was provided with
+a true value, otherwise XML::Parser::file_ext_ent_handler is the default
+handler for external entities. Even without the NoLWP option, if the
+URI or LWP modules are missing, the file based handler ends up being used
+after giving a warning on the first external entity reference.
+
+The LWP external entity handler will use proxies defined in the environment
+(http_proxy, ftp_proxy, etc.).
+
+Please note that the LWP external entity handler reads the entire
+entity into a string and returns it, where as the file handler opens a
+filehandle.
+
+Also note that the file external entity handler will likely choke on
+absolute URIs or file names that don't fit the conventions of the local
+operating system.
+
+The expat base method can be used to set a basename for
+relative pathnames. If no basename is given, or if the basename is itself
+a relative name, then it is relative to the current working directory.
+
+=head2 ExternEntFin (Expat)
+
+This is called after parsing an external entity. It's not called unless
+an ExternEnt handler is also set. There is a default handler installed
+that pairs with the default ExternEnt handler.
+
+If you're going to install your own ExternEnt handler, then you should
+set (or unset) this handler too.
+
+=head2 Entity (Expat, Name, Val, Sysid, Pubid, Ndata, IsParam)
+
+This is called when an entity is declared. For internal entities, the Val
+parameter will contain the value and the remaining three parameters will be
+undefined. For external entities, the Val parameter will be undefined, the
+Sysid parameter will have the system id, the Pubid parameter will have the
+public id if it was provided (it will be undefined otherwise), the Ndata
+parameter will contain the notation for unparsed entities. If this is a
+parameter entity declaration, then the IsParam parameter is true.
+
+Note that this handler and the Unparsed handler above overlap. If both are
+set, then this handler will not be called for unparsed entities.
+
+=head2 Element (Expat, Name, Model)
+
+The element handler is called when an element declaration is found. Name
+is the element name, and Model is the content model as an XML::Parser::Content
+object. See L<XML::Parser::Expat/"XML::Parser::ContentModel Methods">
+for methods available for this class.
+
+=head2 Attlist (Expat, Elname, Attname, Type, Default, Fixed)
+
+This handler is called for each attribute in an ATTLIST declaration.
+So an ATTLIST declaration that has multiple attributes will generate multiple
+calls to this handler. The Elname parameter is the name of the element with
+which the attribute is being associated. The Attname parameter is the name
+of the attribute. Type is the attribute type, given as a string. Default is
+the default value, which will either be "#REQUIRED", "#IMPLIED" or a quoted
+string (i.e. the returned string will begin and end with a quote character).
+If Fixed is true, then this is a fixed attribute.
+
+=head2 Doctype (Expat, Name, Sysid, Pubid, Internal)
+
+This handler is called for DOCTYPE declarations. Name is the document type
+name. Sysid is the system id of the document type, if it was provided,
+otherwise it's undefined. Pubid is the public id of the document type,
+which will be undefined if no public id was given. Internal is the internal
+subset, given as a string. If there was no internal subset, it will be
+undefined. Internal will contain all whitespace, comments, processing
+instructions, and declarations seen in the internal subset. The declarations
+will be there whether or not they have been processed by another handler
+(except for unparsed entities processed by the Unparsed handler). However,
+comments and processing instructions will not appear if they've been processed
+by their respective handlers.
+
+=head2 * DoctypeFin (Parser)
+
+This handler is called after parsing of the DOCTYPE declaration has finished,
+including any internal or external DTD declarations.
+
+=head2 XMLDecl (Expat, Version, Encoding, Standalone)
+
+This handler is called for xml declarations. Version is a string containg
+the version. Encoding is either undefined or contains an encoding string.
+Standalone will be either true, false, or undefined if the standalone attribute
+is yes, no, or not made respectively.
+
+=head1 STYLES
+
+=head2 Debug
+
+This just prints out the document in outline form. Nothing special is
+returned by parse.
+
+=head2 Subs
+
+Each time an element starts, a sub by that name in the package specified
+by the Pkg option is called with the same parameters that the Start
+handler gets called with.
+
+Each time an element ends, a sub with that name appended with an underscore
+("_"), is called with the same parameters that the End handler gets called
+with.
+
+Nothing special is returned by parse.
+
+=head2 Tree
+
+Parse will return a parse tree for the document. Each node in the tree
+takes the form of a tag, content pair. Text nodes are represented with
+a pseudo-tag of "0" and the string that is their content. For elements,
+the content is an array reference. The first item in the array is a
+(possibly empty) hash reference containing attributes. The remainder of
+the array is a sequence of tag-content pairs representing the content
+of the element.
+
+So for example the result of parsing:
+
+ <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
+
+would be:
+
+ Tag Content
+ ==================================================================
+ [foo, [{}, head, [{id => "a"}, 0, "Hello ", em, [{}, 0, "there"]],
+ bar, [ {}, 0, "Howdy", ref, [{}]],
+ 0, "do"
+ ]
+ ]
+
+The root document "foo", has 3 children: a "head" element, a "bar"
+element and the text "do". After the empty attribute hash, these are
+represented in it's contents by 3 tag-content pairs.
+
+=head2 Objects
+
+This is similar to the Tree style, except that a hash object is created for
+each element. The corresponding object will be in the class whose name
+is created by appending "::" and the element name to the package set with
+the Pkg option. Non-markup text will be in the ::Characters class. The
+contents of the corresponding object will be in an anonymous array that
+is the value of the Kids property for that object.
+
+=head2 Stream
+
+This style also uses the Pkg package. If none of the subs that this
+style looks for is there, then the effect of parsing with this style is
+to print a canonical copy of the document without comments or declarations.
+All the subs receive as their 1st parameter the Expat instance for the
+document they're parsing.
+
+It looks for the following routines:
+
+=over 4
+
+=item * StartDocument
+
+Called at the start of the parse .
+
+=item * StartTag
+
+Called for every start tag with a second parameter of the element type. The $_
+variable will contain a copy of the tag and the %_ variable will contain
+attribute values supplied for that element.
+
+=item * EndTag
+
+Called for every end tag with a second parameter of the element type. The $_
+variable will contain a copy of the end tag.
+
+=item * Text
+
+Called just before start or end tags with accumulated non-markup text in
+the $_ variable.
+
+=item * PI
+
+Called for processing instructions. The $_ variable will contain a copy of
+the PI and the target and data are sent as 2nd and 3rd parameters
+respectively.
+
+=item * EndDocument
+
+Called at conclusion of the parse.
+
+=back
+
+=head1 ENCODINGS
+
+XML documents may be encoded in character sets other than Unicode as
+long as they may be mapped into the Unicode character set. Expat has
+further restrictions on encodings. Read the xmlparse.h header file in
+the expat distribution to see details on these restrictions.
+
+Expat has built-in encodings for: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and
+C<US-ASCII>. Encodings are set either through the XML declaration
+encoding attribute or through the ProtocolEncoding option to XML::Parser
+or XML::Parser::Expat.
+
+For encodings other than the built-ins, expat calls the function
+load_encoding in the Expat package with the encoding name. This function
+looks for a file in the path list @XML::Parser::Expat::Encoding_Path, that
+matches the lower-cased name with a '.enc' extension. The first one it
+finds, it loads.
+
+If you wish to build your own encoding maps, check out the XML::Encoding
+module from CPAN.
+
+=head1 AUTHORS
+
+Larry Wall <F<larry@wall.org>> wrote version 1.0.
+
+Clark Cooper <F<coopercc@netheaven.com>> picked up support, changed the API
+for this version (2.x), provided documentation,
+and added some standard package features.
+
+Matt Sergeant <F<matt@sergeant.org>> is now maintaining XML::Parser
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser/Expat.pm b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Expat.pm
new file mode 100755
index 00000000000..9413d80a843
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Expat.pm
@@ -0,0 +1,1230 @@
+package XML::Parser::Expat;
+
+require 5.004;
+
+use strict;
+use vars qw($VERSION @ISA %Handler_Setters %Encoding_Table @Encoding_Path
+ $have_File_Spec);
+use Carp;
+
+require DynaLoader;
+
+@ISA = qw(DynaLoader);
+$VERSION = "2.36" ;
+
+$have_File_Spec = $INC{'File/Spec.pm'} || do 'File/Spec.pm';
+
+%Encoding_Table = ();
+if ($have_File_Spec) {
+ @Encoding_Path = (grep(-d $_,
+ map(File::Spec->catdir($_, qw(XML Parser Encodings)),
+ @INC)),
+ File::Spec->curdir);
+}
+else {
+ @Encoding_Path = (grep(-d $_, map($_ . '/XML/Parser/Encodings', @INC)), '.');
+}
+
+
+bootstrap XML::Parser::Expat $VERSION;
+
+%Handler_Setters = (
+ Start => \&SetStartElementHandler,
+ End => \&SetEndElementHandler,
+ Char => \&SetCharacterDataHandler,
+ Proc => \&SetProcessingInstructionHandler,
+ Comment => \&SetCommentHandler,
+ CdataStart => \&SetStartCdataHandler,
+ CdataEnd => \&SetEndCdataHandler,
+ Default => \&SetDefaultHandler,
+ Unparsed => \&SetUnparsedEntityDeclHandler,
+ Notation => \&SetNotationDeclHandler,
+ ExternEnt => \&SetExternalEntityRefHandler,
+ ExternEntFin => \&SetExtEntFinishHandler,
+ Entity => \&SetEntityDeclHandler,
+ Element => \&SetElementDeclHandler,
+ Attlist => \&SetAttListDeclHandler,
+ Doctype => \&SetDoctypeHandler,
+ DoctypeFin => \&SetEndDoctypeHandler,
+ XMLDecl => \&SetXMLDeclHandler
+ );
+
+sub new {
+ my ($class, %args) = @_;
+ my $self = bless \%args, $_[0];
+ $args{_State_} = 0;
+ $args{Context} = [];
+ $args{Namespaces} ||= 0;
+ $args{ErrorMessage} ||= '';
+ if ($args{Namespaces}) {
+ $args{Namespace_Table} = {};
+ $args{Namespace_List} = [undef];
+ $args{Prefix_Table} = {};
+ $args{New_Prefixes} = [];
+ }
+ $args{_Setters} = \%Handler_Setters;
+ $args{Parser} = ParserCreate($self, $args{ProtocolEncoding},
+ $args{Namespaces});
+ $self;
+}
+
+sub load_encoding {
+ my ($file) = @_;
+
+ $file =~ s!([^/]+)$!\L$1\E!;
+ $file .= '.enc' unless $file =~ /\.enc$/;
+ unless ($file =~ m!^/!) {
+ foreach (@Encoding_Path) {
+ my $tmp = ($have_File_Spec
+ ? File::Spec->catfile($_, $file)
+ : "$_/$file");
+ if (-e $tmp) {
+ $file = $tmp;
+ last;
+ }
+ }
+ }
+
+ local(*ENC);
+ open(ENC, $file) or croak("Couldn't open encmap $file:\n$!\n");
+ binmode(ENC);
+ my $data;
+ my $br = sysread(ENC, $data, -s $file);
+ croak("Trouble reading $file:\n$!\n")
+ unless defined($br);
+ close(ENC);
+
+ my $name = LoadEncoding($data, $br);
+ croak("$file isn't an encmap file")
+ unless defined($name);
+
+ $name;
+} # End load_encoding
+
+sub setHandlers {
+ my ($self, @handler_pairs) = @_;
+
+ croak("Uneven number of arguments to setHandlers method")
+ if (int(@handler_pairs) & 1);
+
+ my @ret;
+
+ while (@handler_pairs) {
+ my $type = shift @handler_pairs;
+ my $handler = shift @handler_pairs;
+ croak "Handler for $type not a Code ref"
+ unless (! defined($handler) or ! $handler or ref($handler) eq 'CODE');
+
+ my $hndl = $self->{_Setters}->{$type};
+
+ unless (defined($hndl)) {
+ my @types = sort keys %{$self->{_Setters}};
+ croak("Unknown Expat handler type: $type\n Valid types: @types");
+ }
+
+ my $old = &$hndl($self->{Parser}, $handler);
+ push (@ret, $type, $old);
+ }
+
+ return @ret;
+}
+
+sub xpcroak
+ {
+ my ($self, $message) = @_;
+
+ my $eclines = $self->{ErrorContext};
+ my $line = GetCurrentLineNumber($_[0]->{Parser});
+ $message .= " at line $line";
+ $message .= ":\n" . $self->position_in_context($eclines)
+ if defined($eclines);
+ croak $message;
+}
+
+sub xpcarp {
+ my ($self, $message) = @_;
+
+ my $eclines = $self->{ErrorContext};
+ my $line = GetCurrentLineNumber($_[0]->{Parser});
+ $message .= " at line $line";
+ $message .= ":\n" . $self->position_in_context($eclines)
+ if defined($eclines);
+ carp $message;
+}
+
+sub default_current {
+ my $self = shift;
+ if ($self->{_State_} == 1) {
+ return DefaultCurrent($self->{Parser});
+ }
+}
+
+sub recognized_string {
+ my $self = shift;
+ if ($self->{_State_} == 1) {
+ return RecognizedString($self->{Parser});
+ }
+}
+
+sub original_string {
+ my $self = shift;
+ if ($self->{_State_} == 1) {
+ return OriginalString($self->{Parser});
+ }
+}
+
+sub current_line {
+ my $self = shift;
+ if ($self->{_State_} == 1) {
+ return GetCurrentLineNumber($self->{Parser});
+ }
+}
+
+sub current_column {
+ my $self = shift;
+ if ($self->{_State_} == 1) {
+ return GetCurrentColumnNumber($self->{Parser});
+ }
+}
+
+sub current_byte {
+ my $self = shift;
+ if ($self->{_State_} == 1) {
+ return GetCurrentByteIndex($self->{Parser});
+ }
+}
+
+sub base {
+ my ($self, $newbase) = @_;
+ my $p = $self->{Parser};
+ my $oldbase = GetBase($p);
+ SetBase($p, $newbase) if @_ > 1;
+ return $oldbase;
+}
+
+sub context {
+ my $ctx = $_[0]->{Context};
+ @$ctx;
+}
+
+sub current_element {
+ my ($self) = @_;
+ @{$self->{Context}} ? $self->{Context}->[-1] : undef;
+}
+
+sub in_element {
+ my ($self, $element) = @_;
+ @{$self->{Context}} ? $self->eq_name($self->{Context}->[-1], $element)
+ : undef;
+}
+
+sub within_element {
+ my ($self, $element) = @_;
+ my $cnt = 0;
+ foreach (@{$self->{Context}}) {
+ $cnt++ if $self->eq_name($_, $element);
+ }
+ return $cnt;
+}
+
+sub depth {
+ my ($self) = @_;
+ int(@{$self->{Context}});
+}
+
+sub element_index {
+ my ($self) = @_;
+
+ if ($self->{_State_} == 1) {
+ return ElementIndex($self->{Parser});
+ }
+}
+
+################
+# Namespace methods
+
+sub namespace {
+ my ($self, $name) = @_;
+ local($^W) = 0;
+ $self->{Namespace_List}->[int($name)];
+}
+
+sub eq_name {
+ my ($self, $nm1, $nm2) = @_;
+ local($^W) = 0;
+
+ int($nm1) == int($nm2) and $nm1 eq $nm2;
+}
+
+sub generate_ns_name {
+ my ($self, $name, $namespace) = @_;
+
+ $namespace ?
+ GenerateNSName($name, $namespace, $self->{Namespace_Table},
+ $self->{Namespace_List})
+ : $name;
+}
+
+sub new_ns_prefixes {
+ my ($self) = @_;
+ if ($self->{Namespaces}) {
+ return @{$self->{New_Prefixes}};
+ }
+ return ();
+}
+
+sub expand_ns_prefix {
+ my ($self, $prefix) = @_;
+
+ if ($self->{Namespaces}) {
+ my $stack = $self->{Prefix_Table}->{$prefix};
+ return (defined($stack) and @$stack) ? $stack->[-1] : undef;
+ }
+
+ return undef;
+}
+
+sub current_ns_prefixes {
+ my ($self) = @_;
+
+ if ($self->{Namespaces}) {
+ my %set = %{$self->{Prefix_Table}};
+
+ if (exists $set{'#default'} and not defined($set{'#default'}->[-1])) {
+ delete $set{'#default'};
+ }
+
+ return keys %set;
+ }
+
+ return ();
+}
+
+
+################################################################
+# Namespace declaration handlers
+#
+
+sub NamespaceStart {
+ my ($self, $prefix, $uri) = @_;
+
+ $prefix = '#default' unless defined $prefix;
+ my $stack = $self->{Prefix_Table}->{$prefix};
+
+ if (defined $stack) {
+ push(@$stack, $uri);
+ }
+ else {
+ $self->{Prefix_Table}->{$prefix} = [$uri];
+ }
+
+ # The New_Prefixes list gets emptied at end of startElement function
+ # in Expat.xs
+
+ push(@{$self->{New_Prefixes}}, $prefix);
+}
+
+sub NamespaceEnd {
+ my ($self, $prefix) = @_;
+
+ $prefix = '#default' unless defined $prefix;
+
+ my $stack = $self->{Prefix_Table}->{$prefix};
+ if (@$stack > 1) {
+ pop(@$stack);
+ }
+ else {
+ delete $self->{Prefix_Table}->{$prefix};
+ }
+}
+
+################
+
+sub specified_attr {
+ my $self = shift;
+
+ if ($self->{_State_} == 1) {
+ return GetSpecifiedAttributeCount($self->{Parser});
+ }
+}
+
+sub finish {
+ my ($self) = @_;
+ if ($self->{_State_} == 1) {
+ my $parser = $self->{Parser};
+ UnsetAllHandlers($parser);
+ }
+}
+
+sub position_in_context {
+ my ($self, $lines) = @_;
+ if ($self->{_State_} == 1) {
+ my $parser = $self->{Parser};
+ my ($string, $linepos) = PositionContext($parser, $lines);
+
+ return '' unless defined($string);
+
+ my $col = GetCurrentColumnNumber($parser);
+ my $ptr = ('=' x ($col - 1)) . '^' . "\n";
+ my $ret;
+ my $dosplit = $linepos < length($string);
+
+ $string .= "\n" unless $string =~ /\n$/;
+
+ if ($dosplit) {
+ $ret = substr($string, 0, $linepos) . $ptr
+ . substr($string, $linepos);
+ } else {
+ $ret = $string . $ptr;
+ }
+
+ return $ret;
+ }
+}
+
+sub xml_escape {
+ my $self = shift;
+ my $text = shift;
+
+ study $text;
+ $text =~ s/\&/\&amp;/g;
+ $text =~ s/</\&lt;/g;
+ foreach (@_) {
+ croak "xml_escape: '$_' isn't a single character" if length($_) > 1;
+
+ if ($_ eq '>') {
+ $text =~ s/>/\&gt;/g;
+ }
+ elsif ($_ eq '"') {
+ $text =~ s/\"/\&quot;/;
+ }
+ elsif ($_ eq "'") {
+ $text =~ s/\'/\&apos;/;
+ }
+ else {
+ my $rep = '&#' . sprintf('x%X', ord($_)) . ';';
+ if (/\W/) {
+ my $ptrn = "\\$_";
+ $text =~ s/$ptrn/$rep/g;
+ }
+ else {
+ $text =~ s/$_/$rep/g;
+ }
+ }
+ }
+ $text;
+}
+
+sub skip_until {
+ my $self = shift;
+ if ($self->{_State_} <= 1) {
+ SkipUntil($self->{Parser}, $_[0]);
+ }
+}
+
+sub release {
+ my $self = shift;
+ ParserRelease($self->{Parser});
+}
+
+sub DESTROY {
+ my $self = shift;
+ ParserFree($self->{Parser});
+}
+
+sub parse {
+ my $self = shift;
+ my $arg = shift;
+ croak "Parse already in progress (Expat)" if $self->{_State_};
+ $self->{_State_} = 1;
+ my $parser = $self->{Parser};
+ my $ioref;
+ my $result = 0;
+
+ if (defined $arg) {
+ if (ref($arg) and UNIVERSAL::isa($arg, 'IO::Handle')) {
+ $ioref = $arg;
+ } elsif (tied($arg)) {
+ my $class = ref($arg);
+ no strict 'refs';
+ $ioref = $arg if defined &{"${class}::TIEHANDLE"};
+ }
+ else {
+ require IO::Handle;
+ eval {
+ no strict 'refs';
+ $ioref = *{$arg}{IO} if defined *{$arg};
+ };
+ undef $@;
+ }
+ }
+
+ if (defined($ioref)) {
+ my $delim = $self->{Stream_Delimiter};
+ my $prev_rs;
+
+ $prev_rs = ref($ioref)->input_record_separator("\n$delim\n")
+ if defined($delim);
+
+ $result = ParseStream($parser, $ioref, $delim);
+
+ ref($ioref)->input_record_separator($prev_rs)
+ if defined($delim);
+ } else {
+ $result = ParseString($parser, $arg);
+ }
+
+ $self->{_State_} = 2;
+ $result or croak $self->{ErrorMessage};
+}
+
+sub parsestring {
+ my $self = shift;
+ $self->parse(@_);
+}
+
+sub parsefile {
+ my $self = shift;
+ croak "Parser has already been used" if $self->{_State_};
+ local(*FILE);
+ open(FILE, $_[0]) or croak "Couldn't open $_[0]:\n$!";
+ binmode(FILE);
+ my $ret = $self->parse(*FILE);
+ close(FILE);
+ $ret;
+}
+
+################################################################
+package XML::Parser::ContentModel;
+use overload '""' => \&asString, 'eq' => \&thiseq;
+
+sub EMPTY () {1}
+sub ANY () {2}
+sub MIXED () {3}
+sub NAME () {4}
+sub CHOICE () {5}
+sub SEQ () {6}
+
+
+sub isempty {
+ return $_[0]->{Type} == EMPTY;
+}
+
+sub isany {
+ return $_[0]->{Type} == ANY;
+}
+
+sub ismixed {
+ return $_[0]->{Type} == MIXED;
+}
+
+sub isname {
+ return $_[0]->{Type} == NAME;
+}
+
+sub name {
+ return $_[0]->{Tag};
+}
+
+sub ischoice {
+ return $_[0]->{Type} == CHOICE;
+}
+
+sub isseq {
+ return $_[0]->{Type} == SEQ;
+}
+
+sub quant {
+ return $_[0]->{Quant};
+}
+
+sub children {
+ my $children = $_[0]->{Children};
+ if (defined $children) {
+ return @$children;
+ }
+ return undef;
+}
+
+sub asString {
+ my ($self) = @_;
+ my $ret;
+
+ if ($self->{Type} == NAME) {
+ $ret = $self->{Tag};
+ }
+ elsif ($self->{Type} == EMPTY) {
+ return "EMPTY";
+ }
+ elsif ($self->{Type} == ANY) {
+ return "ANY";
+ }
+ elsif ($self->{Type} == MIXED) {
+ $ret = '(#PCDATA';
+ foreach (@{$self->{Children}}) {
+ $ret .= '|' . $_;
+ }
+ $ret .= ')';
+ }
+ else {
+ my $sep = $self->{Type} == CHOICE ? '|' : ',';
+ $ret = '(' . join($sep, map { $_->asString } @{$self->{Children}}) . ')';
+ }
+
+ $ret .= $self->{Quant} if $self->{Quant};
+ return $ret;
+}
+
+sub thiseq {
+ my $self = shift;
+
+ return $self->asString eq $_[0];
+}
+
+################################################################
+package XML::Parser::ExpatNB;
+
+use vars qw(@ISA);
+use Carp;
+
+@ISA = qw(XML::Parser::Expat);
+
+sub parse {
+ my $self = shift;
+ my $class = ref($self);
+ croak "parse method not supported in $class";
+}
+
+sub parsestring {
+ my $self = shift;
+ my $class = ref($self);
+ croak "parsestring method not supported in $class";
+}
+
+sub parsefile {
+ my $self = shift;
+ my $class = ref($self);
+ croak "parsefile method not supported in $class";
+}
+
+sub parse_more {
+ my ($self, $data) = @_;
+
+ $self->{_State_} = 1;
+ my $ret = XML::Parser::Expat::ParsePartial($self->{Parser}, $data);
+
+ croak $self->{ErrorMessage} unless $ret;
+}
+
+sub parse_done {
+ my $self = shift;
+
+ my $ret = XML::Parser::Expat::ParseDone($self->{Parser});
+ unless ($ret) {
+ my $msg = $self->{ErrorMessage};
+ $self->release;
+ croak $msg;
+ }
+
+ $self->{_State_} = 2;
+
+ my $result = $ret;
+ my @result = ();
+ my $final = $self->{FinalHandler};
+ if (defined $final) {
+ if (wantarray) {
+ @result = &$final($self);
+ }
+ else {
+ $result = &$final($self);
+ }
+ }
+
+ $self->release;
+
+ return unless defined wantarray;
+ return wantarray ? @result : $result;
+}
+
+################################################################
+
+package XML::Parser::Encinfo;
+
+sub DESTROY {
+ my $self = shift;
+ XML::Parser::Expat::FreeEncoding($self);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::Parser::Expat - Lowlevel access to James Clark's expat XML parser
+
+=head1 SYNOPSIS
+
+ use XML::Parser::Expat;
+
+ $parser = new XML::Parser::Expat;
+ $parser->setHandlers('Start' => \&sh,
+ 'End' => \&eh,
+ 'Char' => \&ch);
+ open(FOO, 'info.xml') or die "Couldn't open";
+ $parser->parse(*FOO);
+ close(FOO);
+ # $parser->parse('<foo id="me"> here <em>we</em> go </foo>');
+
+ sub sh
+ {
+ my ($p, $el, %atts) = @_;
+ $p->setHandlers('Char' => \&spec)
+ if ($el eq 'special');
+ ...
+ }
+
+ sub eh
+ {
+ my ($p, $el) = @_;
+ $p->setHandlers('Char' => \&ch) # Special elements won't contain
+ if ($el eq 'special'); # other special elements
+ ...
+ }
+
+=head1 DESCRIPTION
+
+This module provides an interface to James Clark's XML parser, expat. As in
+expat, a single instance of the parser can only parse one document. Calls
+to parsestring after the first for a given instance will die.
+
+Expat (and XML::Parser::Expat) are event based. As the parser recognizes
+parts of the document (say the start or end of an XML element), then any
+handlers registered for that type of an event are called with suitable
+parameters.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+This is a class method, the constructor for XML::Parser::Expat. Options are
+passed as keyword value pairs. The recognized options are:
+
+=over 4
+
+=item * ProtocolEncoding
+
+The protocol encoding name. The default is none. The expat built-in
+encodings are: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and C<US-ASCII>.
+Other encodings may be used if they have encoding maps in one of the
+directories in the @Encoding_Path list. Setting the protocol encoding
+overrides any encoding in the XML declaration.
+
+=item * Namespaces
+
+When this option is given with a true value, then the parser does namespace
+processing. By default, namespace processing is turned off. When it is
+turned on, the parser consumes I<xmlns> attributes and strips off prefixes
+from element and attributes names where those prefixes have a defined
+namespace. A name's namespace can be found using the L<"namespace"> method
+and two names can be checked for absolute equality with the L<"eq_name">
+method.
+
+=item * NoExpand
+
+Normally, the parser will try to expand references to entities defined in
+the internal subset. If this option is set to a true value, and a default
+handler is also set, then the default handler will be called when an
+entity reference is seen in text. This has no effect if a default handler
+has not been registered, and it has no effect on the expansion of entity
+references inside attribute values.
+
+=item * Stream_Delimiter
+
+This option takes a string value. When this string is found alone on a line
+while parsing from a stream, then the parse is ended as if it saw an end of
+file. The intended use is with a stream of xml documents in a MIME multipart
+format. The string should not contain a trailing newline.
+
+=item * ErrorContext
+
+When this option is defined, errors are reported in context. The value
+of ErrorContext should be the number of lines to show on either side of
+the line in which the error occurred.
+
+=item * ParseParamEnt
+
+Unless standalone is set to "yes" in the XML declaration, setting this to
+a true value allows the external DTD to be read, and parameter entities
+to be parsed and expanded.
+
+=item * Base
+
+The base to use for relative pathnames or URLs. This can also be done by
+using the base method.
+
+=back
+
+=item setHandlers(TYPE, HANDLER [, TYPE, HANDLER [...]])
+
+This method registers handlers for the various events. If no handlers are
+registered, then a call to parsestring or parsefile will only determine if
+the corresponding XML document is well formed (by returning without error.)
+This may be called from within a handler, after the parse has started.
+
+Setting a handler to something that evaluates to false unsets that
+handler.
+
+This method returns a list of type, handler pairs corresponding to the
+input. The handlers returned are the ones that were in effect before the
+call to setHandlers.
+
+The recognized events and the parameters passed to the corresponding
+handlers are:
+
+=over 4
+
+=item * Start (Parser, Element [, Attr, Val [,...]])
+
+This event is generated when an XML start tag is recognized. Parser is
+an XML::Parser::Expat instance. Element is the name of the XML element that
+is opened with the start tag. The Attr & Val pairs are generated for each
+attribute in the start tag.
+
+=item * End (Parser, Element)
+
+This event is generated when an XML end tag is recognized. Note that
+an XML empty tag (<foo/>) generates both a start and an end event.
+
+There is always a lower level start and end handler installed that wrap
+the corresponding callbacks. This is to handle the context mechanism.
+A consequence of this is that the default handler (see below) will not
+see a start tag or end tag unless the default_current method is called.
+
+=item * Char (Parser, String)
+
+This event is generated when non-markup is recognized. The non-markup
+sequence of characters is in String. A single non-markup sequence of
+characters may generate multiple calls to this handler. Whatever the
+encoding of the string in the original document, this is given to the
+handler in UTF-8.
+
+=item * Proc (Parser, Target, Data)
+
+This event is generated when a processing instruction is recognized.
+
+=item * Comment (Parser, String)
+
+This event is generated when a comment is recognized.
+
+=item * CdataStart (Parser)
+
+This is called at the start of a CDATA section.
+
+=item * CdataEnd (Parser)
+
+This is called at the end of a CDATA section.
+
+=item * Default (Parser, String)
+
+This is called for any characters that don't have a registered handler.
+This includes both characters that are part of markup for which no
+events are generated (markup declarations) and characters that
+could generate events, but for which no handler has been registered.
+
+Whatever the encoding in the original document, the string is returned to
+the handler in UTF-8.
+
+=item * Unparsed (Parser, Entity, Base, Sysid, Pubid, Notation)
+
+This is called for a declaration of an unparsed entity. Entity is the name
+of the entity. Base is the base to be used for resolving a relative URI.
+Sysid is the system id. Pubid is the public id. Notation is the notation
+name. Base and Pubid may be undefined.
+
+=item * Notation (Parser, Notation, Base, Sysid, Pubid)
+
+This is called for a declaration of notation. Notation is the notation name.
+Base is the base to be used for resolving a relative URI. Sysid is the system
+id. Pubid is the public id. Base, Sysid, and Pubid may all be undefined.
+
+=item * ExternEnt (Parser, Base, Sysid, Pubid)
+
+This is called when an external entity is referenced. Base is the base to be
+used for resolving a relative URI. Sysid is the system id. Pubid is the public
+id. Base, and Pubid may be undefined.
+
+This handler should either return a string, which represents the contents of
+the external entity, or return an open filehandle that can be read to obtain
+the contents of the external entity, or return undef, which indicates the
+external entity couldn't be found and will generate a parse error.
+
+If an open filehandle is returned, it must be returned as either a glob
+(*FOO) or as a reference to a glob (e.g. an instance of IO::Handle).
+
+=item * ExternEntFin (Parser)
+
+This is called after an external entity has been parsed. It allows
+applications to perform cleanup on actions performed in the above
+ExternEnt handler.
+
+=item * Entity (Parser, Name, Val, Sysid, Pubid, Ndata, IsParam)
+
+This is called when an entity is declared. For internal entities, the Val
+parameter will contain the value and the remaining three parameters will
+be undefined. For external entities, the Val parameter
+will be undefined, the Sysid parameter will have the system id, the Pubid
+parameter will have the public id if it was provided (it will be undefined
+otherwise), the Ndata parameter will contain the notation for unparsed
+entities. If this is a parameter entity declaration, then the IsParam
+parameter is true.
+
+Note that this handler and the Unparsed handler above overlap. If both are
+set, then this handler will not be called for unparsed entities.
+
+=item * Element (Parser, Name, Model)
+
+The element handler is called when an element declaration is found. Name is
+the element name, and Model is the content model as an
+XML::Parser::ContentModel object. See L<"XML::Parser::ContentModel Methods">
+for methods available for this class.
+
+=item * Attlist (Parser, Elname, Attname, Type, Default, Fixed)
+
+This handler is called for each attribute in an ATTLIST declaration.
+So an ATTLIST declaration that has multiple attributes
+will generate multiple calls to this handler. The Elname parameter is the
+name of the element with which the attribute is being associated. The Attname
+parameter is the name of the attribute. Type is the attribute type, given as
+a string. Default is the default value, which will either be "#REQUIRED",
+"#IMPLIED" or a quoted string (i.e. the returned string will begin and end
+with a quote character). If Fixed is true, then this is a fixed attribute.
+
+=item * Doctype (Parser, Name, Sysid, Pubid, Internal)
+
+This handler is called for DOCTYPE declarations. Name is the document type
+name. Sysid is the system id of the document type, if it was provided,
+otherwise it's undefined. Pubid is the public id of the document type,
+which will be undefined if no public id was given. Internal will be
+true or false, indicating whether or not the doctype declaration contains
+an internal subset.
+
+=item * DoctypeFin (Parser)
+
+This handler is called after parsing of the DOCTYPE declaration has finished,
+including any internal or external DTD declarations.
+
+=item * XMLDecl (Parser, Version, Encoding, Standalone)
+
+This handler is called for XML declarations. Version is a string containg
+the version. Encoding is either undefined or contains an encoding string.
+Standalone is either undefined, or true or false. Undefined indicates
+that no standalone parameter was given in the XML declaration. True or
+false indicates "yes" or "no" respectively.
+
+=back
+
+=item namespace(name)
+
+Return the URI of the namespace that the name belongs to. If the name doesn't
+belong to any namespace, an undef is returned. This is only valid on names
+received through the Start or End handlers from a single document, or through
+a call to the generate_ns_name method. In other words, don't use names
+generated from one instance of XML::Parser::Expat with other instances.
+
+=item eq_name(name1, name2)
+
+Return true if name1 and name2 are identical (i.e. same name and from
+the same namespace.) This is only meaningful if both names were obtained
+through the Start or End handlers from a single document, or through
+a call to the generate_ns_name method.
+
+=item generate_ns_name(name, namespace)
+
+Return a name, associated with a given namespace, good for using with the
+above 2 methods. The namespace argument should be the namespace URI, not
+a prefix.
+
+=item new_ns_prefixes
+
+When called from a start tag handler, returns namespace prefixes declared
+with this start tag. If called elsewere (or if there were no namespace
+prefixes declared), it returns an empty list. Setting of the default
+namespace is indicated with '#default' as a prefix.
+
+=item expand_ns_prefix(prefix)
+
+Return the uri to which the given prefix is currently bound. Returns
+undef if the prefix isn't currently bound. Use '#default' to find the
+current binding of the default namespace (if any).
+
+=item current_ns_prefixes
+
+Return a list of currently bound namespace prefixes. The order of the
+the prefixes in the list has no meaning. If the default namespace is
+currently bound, '#default' appears in the list.
+
+=item recognized_string
+
+Returns the string from the document that was recognized in order to call
+the current handler. For instance, when called from a start handler, it
+will give us the the start-tag string. The string is encoded in UTF-8.
+This method doesn't return a meaningful string inside declaration handlers.
+
+=item original_string
+
+Returns the verbatim string from the document that was recognized in
+order to call the current handler. The string is in the original document
+encoding. This method doesn't return a meaningful string inside declaration
+handlers.
+
+=item default_current
+
+When called from a handler, causes the sequence of characters that generated
+the corresponding event to be sent to the default handler (if one is
+registered). Use of this method is deprecated in favor the recognized_string
+method, which you can use without installing a default handler. This
+method doesn't deliver a meaningful string to the default handler when
+called from inside declaration handlers.
+
+=item xpcroak(message)
+
+Concatenate onto the given message the current line number within the
+XML document plus the message implied by ErrorContext. Then croak with
+the formed message.
+
+=item xpcarp(message)
+
+Concatenate onto the given message the current line number within the
+XML document plus the message implied by ErrorContext. Then carp with
+the formed message.
+
+=item current_line
+
+Returns the line number of the current position of the parse.
+
+=item current_column
+
+Returns the column number of the current position of the parse.
+
+=item current_byte
+
+Returns the current position of the parse.
+
+=item base([NEWBASE]);
+
+Returns the current value of the base for resolving relative URIs. If
+NEWBASE is supplied, changes the base to that value.
+
+=item context
+
+Returns a list of element names that represent open elements, with the
+last one being the innermost. Inside start and end tag handlers, this
+will be the tag of the parent element.
+
+=item current_element
+
+Returns the name of the innermost currently opened element. Inside
+start or end handlers, returns the parent of the element associated
+with those tags.
+
+=item in_element(NAME)
+
+Returns true if NAME is equal to the name of the innermost currently opened
+element. If namespace processing is being used and you want to check
+against a name that may be in a namespace, then use the generate_ns_name
+method to create the NAME argument.
+
+=item within_element(NAME)
+
+Returns the number of times the given name appears in the context list.
+If namespace processing is being used and you want to check
+against a name that may be in a namespace, then use the generate_ns_name
+method to create the NAME argument.
+
+=item depth
+
+Returns the size of the context list.
+
+=item element_index
+
+Returns an integer that is the depth-first visit order of the current
+element. This will be zero outside of the root element. For example,
+this will return 1 when called from the start handler for the root element
+start tag.
+
+=item skip_until(INDEX)
+
+INDEX is an integer that represents an element index. When this method
+is called, all handlers are suspended until the start tag for an element
+that has an index number equal to INDEX is seen. If a start handler has
+been set, then this is the first tag that the start handler will see
+after skip_until has been called.
+
+
+=item position_in_context(LINES)
+
+Returns a string that shows the current parse position. LINES should be
+an integer >= 0 that represents the number of lines on either side of the
+current parse line to place into the returned string.
+
+=item xml_escape(TEXT [, CHAR [, CHAR ...]])
+
+Returns TEXT with markup characters turned into character entities. Any
+additional characters provided as arguments are also turned into character
+references where found in TEXT.
+
+=item parse (SOURCE)
+
+The SOURCE parameter should either be a string containing the whole XML
+document, or it should be an open IO::Handle. Only a single document
+may be parsed for a given instance of XML::Parser::Expat, so this will croak
+if it's been called previously for this instance.
+
+=item parsestring(XML_DOC_STRING)
+
+Parses the given string as an XML document. Only a single document may be
+parsed for a given instance of XML::Parser::Expat, so this will die if either
+parsestring or parsefile has been called for this instance previously.
+
+This method is deprecated in favor of the parse method.
+
+=item parsefile(FILENAME)
+
+Parses the XML document in the given file. Will die if parsestring or
+parsefile has been called previously for this instance.
+
+=item is_defaulted(ATTNAME)
+
+NO LONGER WORKS. To find out if an attribute is defaulted please use
+the specified_attr method.
+
+=item specified_attr
+
+When the start handler receives lists of attributes and values, the
+non-defaulted (i.e. explicitly specified) attributes occur in the list
+first. This method returns the number of specified items in the list.
+So if this number is equal to the length of the list, there were no
+defaulted values. Otherwise the number points to the index of the
+first defaulted attribute name.
+
+=item finish
+
+Unsets all handlers (including internal ones that set context), but expat
+continues parsing to the end of the document or until it finds an error.
+It should finish up a lot faster than with the handlers set.
+
+=item release
+
+There are data structures used by XML::Parser::Expat that have circular
+references. This means that these structures will never be garbage
+collected unless these references are explicitly broken. Calling this
+method breaks those references (and makes the instance unusable.)
+
+Normally, higher level calls handle this for you, but if you are using
+XML::Parser::Expat directly, then it's your responsibility to call it.
+
+=back
+
+=head2 XML::Parser::ContentModel Methods
+
+The element declaration handlers are passed objects of this class as the
+content model of the element declaration. They also represent content
+particles, components of a content model.
+
+When referred to as a string, these objects are automagicly converted to a
+string representation of the model (or content particle).
+
+=over 4
+
+=item isempty
+
+This method returns true if the object is "EMPTY", false otherwise.
+
+=item isany
+
+This method returns true if the object is "ANY", false otherwise.
+
+=item ismixed
+
+This method returns true if the object is "(#PCDATA)" or "(#PCDATA|...)*",
+false otherwise.
+
+=item isname
+
+This method returns if the object is an element name.
+
+=item ischoice
+
+This method returns true if the object is a choice of content particles.
+
+
+=item isseq
+
+This method returns true if the object is a sequence of content particles.
+
+=item quant
+
+This method returns undef or a string representing the quantifier
+('?', '*', '+') associated with the model or particle.
+
+=item children
+
+This method returns undef or (for mixed, choice, and sequence types)
+an array of component content particles. There will always be at least
+one component for choices and sequences, but for a mixed content model
+of pure PCDATA, "(#PCDATA)", then an undef is returned.
+
+=back
+
+=head2 XML::Parser::ExpatNB Methods
+
+The class XML::Parser::ExpatNB is a subclass of XML::Parser::Expat used
+for non-blocking access to the expat library. It does not support the parse,
+parsestring, or parsefile methods, but it does have these additional methods:
+
+=over 4
+
+=item parse_more(DATA)
+
+Feed expat more text to munch on.
+
+=item parse_done
+
+Tell expat that it's gotten the whole document.
+
+=back
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item XML::Parser::Expat::load_encoding(ENCODING)
+
+Load an external encoding. ENCODING is either the name of an encoding or
+the name of a file. The basename is converted to lowercase and a '.enc'
+extension is appended unless there's one already there. Then, unless
+it's an absolute pathname (i.e. begins with '/'), the first file by that
+name discovered in the @Encoding_Path path list is used.
+
+The encoding in the file is loaded and kept in the %Encoding_Table
+table. Earlier encodings of the same name are replaced.
+
+This function is automaticly called by expat when it encounters an encoding
+it doesn't know about. Expat shouldn't call this twice for the same
+encoding name. The only reason users should use this function is to
+explicitly load an encoding not contained in the @Encoding_Path list.
+
+=back
+
+=head1 AUTHORS
+
+Larry Wall <F<larry@wall.org>> wrote version 1.0.
+
+Clark Cooper <F<coopercc@netheaven.com>> picked up support, changed the API
+for this version (2.x), provided documentation, and added some standard
+package features.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser/LWPExternEnt.pl b/Master/tlpkg/tlperl.straw/lib/XML/Parser/LWPExternEnt.pl
new file mode 100755
index 00000000000..d0c940b1ac5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser/LWPExternEnt.pl
@@ -0,0 +1,71 @@
+# LWPExternEnt.pl
+#
+# Copyright (c) 2000 Clark Cooper
+# All rights reserved.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package XML::Parser;
+
+use URI;
+use URI::file;
+use LWP;
+
+##
+## Note that this external entity handler reads the entire entity into
+## memory, so it will choke on huge ones. It would be really nice if
+## LWP::UserAgent optionally returned us an IO::Handle.
+##
+
+sub lwp_ext_ent_handler {
+ my ($xp, $base, $sys) = @_; # We don't use public id
+
+ my $uri;
+
+ if (defined $base) {
+ # Base may have been set by parsefile, which is agnostic about
+ # whether its a file or URI.
+ my $base_uri = new URI($base);
+ unless (defined $base_uri->scheme) {
+ $base_uri = URI->new_abs($base_uri, URI::file->cwd);
+ }
+
+ $uri = URI->new_abs($sys, $base_uri);
+ }
+ else {
+ $uri = new URI($sys);
+ unless (defined $uri->scheme) {
+ $uri = URI->new_abs($uri, URI::file->cwd);
+ }
+ }
+
+ my $ua = $xp->{_lwpagent};
+ unless (defined $ua) {
+ $ua = $xp->{_lwpagent} = new LWP::UserAgent();
+ $ua->env_proxy();
+ }
+
+ my $req = new HTTP::Request('GET', $uri);
+
+ my $res = $ua->request($req);
+ if ($res->is_error) {
+ $xp->{ErrorMessage} .= "\n" . $res->status_line . " $uri";
+ return undef;
+ }
+
+ $xp->{_BaseStack} ||= [];
+ push(@{$xp->{_BaseStack}}, $base);
+
+ $xp->base($uri);
+
+ return $res->content;
+} # End lwp_ext_ent_handler
+
+sub lwp_ext_ent_cleanup {
+ my ($xp) = @_;
+
+ $xp->base(pop(@{$xp->{_BaseStack}}));
+} # End lwp_ext_ent_cleanup
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Debug.pm b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Debug.pm
new file mode 100755
index 00000000000..89fcd8b248b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Debug.pm
@@ -0,0 +1,52 @@
+# $Id: Debug.pm,v 1.1 2003/07/27 16:07:49 matt Exp $
+
+package XML::Parser::Style::Debug;
+use strict;
+
+sub Start {
+ my $expat = shift;
+ my $tag = shift;
+ print STDERR "@{$expat->{Context}} \\\\ (@_)\n";
+}
+
+sub End {
+ my $expat = shift;
+ my $tag = shift;
+ print STDERR "@{$expat->{Context}} //\n";
+}
+
+sub Char {
+ my $expat = shift;
+ my $text = shift;
+ $text =~ s/([\x80-\xff])/sprintf "#x%X;", ord $1/eg;
+ $text =~ s/([\t\n])/sprintf "#%d;", ord $1/eg;
+ print STDERR "@{$expat->{Context}} || $text\n";
+}
+
+sub Proc {
+ my $expat = shift;
+ my $target = shift;
+ my $text = shift;
+ my @foo = @{$expat->{Context}};
+ print STDERR "@foo $target($text)\n";
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::Parser::Style::Debug - Debug style for XML::Parser
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+ my $p = XML::Parser->new(Style => 'Debug');
+ $p->parsefile('foo.xml');
+
+=head1 DESCRIPTION
+
+This just prints out the document in outline form to STDERR. Nothing special is
+returned by parse.
+
+=cut \ No newline at end of file
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Objects.pm b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Objects.pm
new file mode 100755
index 00000000000..8603db05a39
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Objects.pm
@@ -0,0 +1,78 @@
+# $Id: Objects.pm,v 1.1 2003/08/18 20:20:51 matt Exp $
+
+package XML::Parser::Style::Objects;
+use strict;
+
+sub Init {
+ my $expat = shift;
+ $expat->{Lists} = [];
+ $expat->{Curlist} = $expat->{Tree} = [];
+}
+
+sub Start {
+ my $expat = shift;
+ my $tag = shift;
+ my $newlist = [ ];
+ my $class = "${$expat}{Pkg}::$tag";
+ my $newobj = bless { @_, Kids => $newlist }, $class;
+ push @{ $expat->{Lists} }, $expat->{Curlist};
+ push @{ $expat->{Curlist} }, $newobj;
+ $expat->{Curlist} = $newlist;
+}
+
+sub End {
+ my $expat = shift;
+ my $tag = shift;
+ $expat->{Curlist} = pop @{ $expat->{Lists} };
+}
+
+sub Char {
+ my $expat = shift;
+ my $text = shift;
+ my $class = "${$expat}{Pkg}::Characters";
+ my $clist = $expat->{Curlist};
+ my $pos = $#$clist;
+
+ if ($pos >= 0 and ref($clist->[$pos]) eq $class) {
+ $clist->[$pos]->{Text} .= $text;
+ } else {
+ push @$clist, bless { Text => $text }, $class;
+ }
+}
+
+sub Final {
+ my $expat = shift;
+ delete $expat->{Curlist};
+ delete $expat->{Lists};
+ $expat->{Tree};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::Parser::Style::Objects
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+ my $p = XML::Parser->new(Style => 'Objects', Pkg => 'MyNode');
+ my $tree = $p->parsefile('foo.xml');
+
+=head1 DESCRIPTION
+
+This module implements XML::Parser's Objects style parser.
+
+This is similar to the Tree style, except that a hash object is created for
+each element. The corresponding object will be in the class whose name
+is created by appending "::" and the element name to the package set with
+the Pkg option. Non-markup text will be in the ::Characters class. The
+contents of the corresponding object will be in an anonymous array that
+is the value of the Kids property for that object.
+
+=head1 SEE ALSO
+
+L<XML::Parser::Style::Tree>
+
+=cut \ No newline at end of file
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Stream.pm b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Stream.pm
new file mode 100755
index 00000000000..1e2e3f7183d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Stream.pm
@@ -0,0 +1,184 @@
+# $Id: Stream.pm,v 1.1 2003/07/27 16:07:49 matt Exp $
+
+package XML::Parser::Style::Stream;
+use strict;
+
+# This style invented by Tim Bray <tbray@textuality.com>
+
+sub Init {
+ no strict 'refs';
+ my $expat = shift;
+ $expat->{Text} = '';
+ my $sub = $expat->{Pkg} ."::StartDocument";
+ &$sub($expat)
+ if defined(&$sub);
+}
+
+sub Start {
+ no strict 'refs';
+ my $expat = shift;
+ my $type = shift;
+
+ doText($expat);
+ $_ = "<$type";
+
+ %_ = @_;
+ while (@_) {
+ $_ .= ' ' . shift() . '="' . shift() . '"';
+ }
+ $_ .= '>';
+
+ my $sub = $expat->{Pkg} . "::StartTag";
+ if (defined(&$sub)) {
+ &$sub($expat, $type);
+ } else {
+ print;
+ }
+}
+
+sub End {
+ no strict 'refs';
+ my $expat = shift;
+ my $type = shift;
+
+ # Set right context for Text handler
+ push(@{$expat->{Context}}, $type);
+ doText($expat);
+ pop(@{$expat->{Context}});
+
+ $_ = "</$type>";
+
+ my $sub = $expat->{Pkg} . "::EndTag";
+ if (defined(&$sub)) {
+ &$sub($expat, $type);
+ } else {
+ print;
+ }
+}
+
+sub Char {
+ my $expat = shift;
+ $expat->{Text} .= shift;
+}
+
+sub Proc {
+ no strict 'refs';
+ my $expat = shift;
+ my $target = shift;
+ my $text = shift;
+
+ doText($expat);
+
+ $_ = "<?$target $text?>";
+
+ my $sub = $expat->{Pkg} . "::PI";
+ if (defined(&$sub)) {
+ &$sub($expat, $target, $text);
+ } else {
+ print;
+ }
+}
+
+sub Final {
+ no strict 'refs';
+ my $expat = shift;
+ my $sub = $expat->{Pkg} . "::EndDocument";
+ &$sub($expat)
+ if defined(&$sub);
+}
+
+sub doText {
+ no strict 'refs';
+ my $expat = shift;
+ $_ = $expat->{Text};
+
+ if (length($_)) {
+ my $sub = $expat->{Pkg} . "::Text";
+ if (defined(&$sub)) {
+ &$sub($expat);
+ } else {
+ print;
+ }
+
+ $expat->{Text} = '';
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::Parser::Style::Stream - Stream style for XML::Parser
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+ my $p = XML::Parser->new(Style => 'Stream', Pkg => 'MySubs');
+ $p->parsefile('foo.xml');
+
+ {
+ package MySubs;
+
+ sub StartTag {
+ my ($e, $name) = @_;
+ # do something with start tags
+ }
+
+ sub EndTag {
+ my ($e, $name) = @_;
+ # do something with end tags
+ }
+
+ sub Characters {
+ my ($e, $data) = @_;
+ # do something with text nodes
+ }
+ }
+
+=head1 DESCRIPTION
+
+This style uses the Pkg option to find subs in a given package to call for each event.
+If none of the subs that this
+style looks for is there, then the effect of parsing with this style is
+to print a canonical copy of the document without comments or declarations.
+All the subs receive as their 1st parameter the Expat instance for the
+document they're parsing.
+
+It looks for the following routines:
+
+=over 4
+
+=item * StartDocument
+
+Called at the start of the parse .
+
+=item * StartTag
+
+Called for every start tag with a second parameter of the element type. The $_
+variable will contain a copy of the tag and the %_ variable will contain
+attribute values supplied for that element.
+
+=item * EndTag
+
+Called for every end tag with a second parameter of the element type. The $_
+variable will contain a copy of the end tag.
+
+=item * Text
+
+Called just before start or end tags with accumulated non-markup text in
+the $_ variable.
+
+=item * PI
+
+Called for processing instructions. The $_ variable will contain a copy of
+the PI and the target and data are sent as 2nd and 3rd parameters
+respectively.
+
+=item * EndDocument
+
+Called at conclusion of the parse.
+
+=back
+
+=cut \ No newline at end of file
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Subs.pm b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Subs.pm
new file mode 100755
index 00000000000..15a21439e8e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Subs.pm
@@ -0,0 +1,58 @@
+# $Id: Subs.pm,v 1.1 2003/07/27 16:07:49 matt Exp $
+
+package XML::Parser::Style::Subs;
+
+sub Start {
+ no strict 'refs';
+ my $expat = shift;
+ my $tag = shift;
+ my $sub = $expat->{Pkg} . "::$tag";
+ eval { &$sub($expat, $tag, @_) };
+}
+
+sub End {
+ no strict 'refs';
+ my $expat = shift;
+ my $tag = shift;
+ my $sub = $expat->{Pkg} . "::${tag}_";
+ eval { &$sub($expat, $tag) };
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::Parser::Style::Subs
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+ my $p = XML::Parser->new(Style => 'Subs', Pkg => 'MySubs');
+ $p->parsefile('foo.xml');
+
+ {
+ package MySubs;
+
+ sub foo {
+ # start of foo tag
+ }
+
+ sub foo_ {
+ # end of foo tag
+ }
+ }
+
+=head1 DESCRIPTION
+
+Each time an element starts, a sub by that name in the package specified
+by the Pkg option is called with the same parameters that the Start
+handler gets called with.
+
+Each time an element ends, a sub with that name appended with an underscore
+("_"), is called with the same parameters that the End handler gets called
+with.
+
+Nothing special is returned by parse.
+
+=cut \ No newline at end of file
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Tree.pm b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Tree.pm
new file mode 100755
index 00000000000..c0e69f131ce
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/Parser/Style/Tree.pm
@@ -0,0 +1,90 @@
+# $Id: Tree.pm,v 1.2 2003/07/31 07:54:51 matt Exp $
+
+package XML::Parser::Style::Tree;
+$XML::Parser::Built_In_Styles{Tree} = 1;
+
+sub Init {
+ my $expat = shift;
+ $expat->{Lists} = [];
+ $expat->{Curlist} = $expat->{Tree} = [];
+}
+
+sub Start {
+ my $expat = shift;
+ my $tag = shift;
+ my $newlist = [ { @_ } ];
+ push @{ $expat->{Lists} }, $expat->{Curlist};
+ push @{ $expat->{Curlist} }, $tag => $newlist;
+ $expat->{Curlist} = $newlist;
+}
+
+sub End {
+ my $expat = shift;
+ my $tag = shift;
+ $expat->{Curlist} = pop @{ $expat->{Lists} };
+}
+
+sub Char {
+ my $expat = shift;
+ my $text = shift;
+ my $clist = $expat->{Curlist};
+ my $pos = $#$clist;
+
+ if ($pos > 0 and $clist->[$pos - 1] eq '0') {
+ $clist->[$pos] .= $text;
+ } else {
+ push @$clist, 0 => $text;
+ }
+}
+
+sub Final {
+ my $expat = shift;
+ delete $expat->{Curlist};
+ delete $expat->{Lists};
+ $expat->{Tree};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::Parser::Style::Tree
+
+=head1 SYNOPSIS
+
+ use XML::Parser;
+ my $p = XML::Parser->new(Style => 'Tree');
+ my $tree = $p->parsefile('foo.xml');
+
+=head1 DESCRIPTION
+
+This module implements XML::Parser's Tree style parser.
+
+When parsing a document, C<parse()> will return a parse tree for the
+document. Each node in the tree
+takes the form of a tag, content pair. Text nodes are represented with
+a pseudo-tag of "0" and the string that is their content. For elements,
+the content is an array reference. The first item in the array is a
+(possibly empty) hash reference containing attributes. The remainder of
+the array is a sequence of tag-content pairs representing the content
+of the element.
+
+So for example the result of parsing:
+
+ <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
+
+would be:
+ Tag Content
+ ==================================================================
+ [foo, [{}, head, [{id => "a"}, 0, "Hello ", em, [{}, 0, "there"]],
+ bar, [ {}, 0, "Howdy", ref, [{}]],
+ 0, "do"
+ ]
+ ]
+
+The root document "foo", has 3 children: a "head" element, a "bar"
+element and the text "do". After the empty attribute hash, these are
+represented in it's contents by 3 tag-content pairs.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX.pm
new file mode 100755
index 00000000000..2dbe8b79c21
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX.pm
@@ -0,0 +1,379 @@
+# $Id: SAX.pm,v 1.31 2008-08-05 12:36:24 grant Exp $
+
+package XML::SAX;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = '0.96';
+
+use Exporter ();
+@ISA = ('Exporter');
+
+@EXPORT_OK = qw(Namespaces Validation);
+
+use File::Basename qw(dirname);
+use File::Spec ();
+use Symbol qw(gensym);
+use XML::SAX::ParserFactory (); # loaded for simplicity
+
+use constant PARSER_DETAILS => "ParserDetails.ini";
+
+use constant Namespaces => "http://xml.org/sax/features/namespaces";
+use constant Validation => "http://xml.org/sax/features/validation";
+
+my $known_parsers = undef;
+
+# load_parsers takes the ParserDetails.ini file out of the same directory
+# that XML::SAX is in, and looks at it. Format in POD below
+
+=begin EXAMPLE
+
+[XML::SAX::PurePerl]
+http://xml.org/sax/features/namespaces = 1
+http://xml.org/sax/features/validation = 0
+# a comment
+
+# blank lines ignored
+
+[XML::SAX::AnotherParser]
+http://xml.org/sax/features/namespaces = 0
+http://xml.org/sax/features/validation = 1
+
+=end EXAMPLE
+
+=cut
+
+sub load_parsers {
+ my $class = shift;
+ my $dir = shift;
+
+ # reset parsers
+ $known_parsers = [];
+
+ # get directory from wherever XML::SAX is installed
+ if (!$dir) {
+ $dir = $INC{'XML/SAX.pm'};
+ $dir = dirname($dir);
+ }
+
+ my $fh = gensym();
+ if (!open($fh, File::Spec->catfile($dir, "SAX", PARSER_DETAILS))) {
+ XML::SAX->do_warn("could not find " . PARSER_DETAILS . " in $dir/SAX\n");
+ return $class;
+ }
+
+ $known_parsers = $class->_parse_ini_file($fh);
+
+ return $class;
+}
+
+sub _parse_ini_file {
+ my $class = shift;
+ my ($fh) = @_;
+
+ my @config;
+
+ my $lineno = 0;
+ while (defined(my $line = <$fh>)) {
+ $lineno++;
+ my $original = $line;
+ # strip whitespace
+ $line =~ s/\s*$//m;
+ $line =~ s/^\s*//m;
+ # strip comments
+ $line =~ s/[#;].*$//m;
+ # ignore blanks
+ next if $line =~ /^$/m;
+
+ # heading
+ if ($line =~ /^\[\s*(.*)\s*\]$/m) {
+ push @config, { Name => $1 };
+ next;
+ }
+
+ # instruction
+ elsif ($line =~ /^(.*?)\s*?=\s*(.*)$/) {
+ unless(@config) {
+ push @config, { Name => '' };
+ }
+ $config[-1]{Features}{$1} = $2;
+ }
+
+ # not whitespace, comment, or instruction
+ else {
+ die "Invalid line in ini: $lineno\n>>> $original\n";
+ }
+ }
+
+ return \@config;
+}
+
+sub parsers {
+ my $class = shift;
+ if (!$known_parsers) {
+ $class->load_parsers();
+ }
+ return $known_parsers;
+}
+
+sub remove_parser {
+ my $class = shift;
+ my ($parser_module) = @_;
+
+ if (!$known_parsers) {
+ $class->load_parsers();
+ }
+
+ @$known_parsers = grep { $_->{Name} ne $parser_module } @$known_parsers;
+
+ return $class;
+}
+
+sub add_parser {
+ my $class = shift;
+ my ($parser_module) = @_;
+
+ if (!$known_parsers) {
+ $class->load_parsers();
+ }
+
+ # first load module, then query features, then push onto known_parsers,
+
+ my $parser_file = $parser_module;
+ $parser_file =~ s/::/\//g;
+ $parser_file .= ".pm";
+
+ require $parser_file;
+
+ my @features = $parser_module->supported_features();
+
+ my $new = { Name => $parser_module };
+ foreach my $feature (@features) {
+ $new->{Features}{$feature} = 1;
+ }
+
+ # If exists in list already, move to end.
+ my $done = 0;
+ my $pos = undef;
+ for (my $i = 0; $i < @$known_parsers; $i++) {
+ my $p = $known_parsers->[$i];
+ if ($p->{Name} eq $parser_module) {
+ $pos = $i;
+ }
+ }
+ if (defined $pos) {
+ splice(@$known_parsers, $pos, 1);
+ push @$known_parsers, $new;
+ $done++;
+ }
+
+ # Otherwise (not in list), add at end of list.
+ if (!$done) {
+ push @$known_parsers, $new;
+ }
+
+ return $class;
+}
+
+sub save_parsers {
+ my $class = shift;
+
+ # get directory from wherever XML::SAX is installed
+ my $dir = $INC{'XML/SAX.pm'};
+ $dir = dirname($dir);
+
+ my $file = File::Spec->catfile($dir, "SAX", PARSER_DETAILS);
+ chmod 0644, $file;
+ unlink($file);
+
+ my $fh = gensym();
+ open($fh, ">$file") ||
+ die "Cannot write to $file: $!";
+
+ foreach my $p (@$known_parsers) {
+ print $fh "[$p->{Name}]\n";
+ foreach my $key (keys %{$p->{Features}}) {
+ print $fh "$key = $p->{Features}{$key}\n";
+ }
+ print $fh "\n";
+ }
+
+ print $fh "\n";
+
+ close $fh;
+
+ return $class;
+}
+
+sub do_warn {
+ my $class = shift;
+ # Don't output warnings if running under Test::Harness
+ warn(@_) unless $ENV{HARNESS_ACTIVE};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::SAX - Simple API for XML
+
+=head1 SYNOPSIS
+
+ use XML::SAX;
+
+ # get a list of known parsers
+ my $parsers = XML::SAX->parsers();
+
+ # add/update a parser
+ XML::SAX->add_parser(q(XML::SAX::PurePerl));
+
+ # remove parser
+ XML::SAX->remove_parser(q(XML::SAX::Foodelberry));
+
+ # save parsers
+ XML::SAX->save_parsers();
+
+=head1 DESCRIPTION
+
+XML::SAX is a SAX parser access API for Perl. It includes classes
+and APIs required for implementing SAX drivers, along with a factory
+class for returning any SAX parser installed on the user's system.
+
+=head1 USING A SAX2 PARSER
+
+The factory class is XML::SAX::ParserFactory. Please see the
+documentation of that module for how to instantiate a SAX parser:
+L<XML::SAX::ParserFactory>. However if you don't want to load up
+another manual page, here's a short synopsis:
+
+ use XML::SAX::ParserFactory;
+ use XML::SAX::XYZHandler;
+ my $handler = XML::SAX::XYZHandler->new();
+ my $p = XML::SAX::ParserFactory->parser(Handler => $handler);
+ $p->parse_uri("foo.xml");
+ # or $p->parse_string("<foo/>") or $p->parse_file($fh);
+
+This will automatically load a SAX2 parser (defaulting to
+XML::SAX::PurePerl if no others are found) and return it to you.
+
+In order to learn how to use SAX to parse XML, you will need to read
+L<XML::SAX::Intro> and for reference, L<XML::SAX::Specification>.
+
+=head1 WRITING A SAX2 PARSER
+
+The first thing to remember in writing a SAX2 parser is to subclass
+XML::SAX::Base. This will make your life infinitely easier, by providing
+a number of methods automagically for you. See L<XML::SAX::Base> for more
+details.
+
+When writing a SAX2 parser that is compatible with XML::SAX, you need
+to inform XML::SAX of the presence of that driver when you install it.
+In order to do that, XML::SAX contains methods for saving the fact that
+the parser exists on your system to a "INI" file, which is then loaded
+to determine which parsers are installed.
+
+The best way to do this is to follow these rules:
+
+=over 4
+
+=item * Add XML::SAX as a prerequisite in Makefile.PL:
+
+ WriteMakefile(
+ ...
+ PREREQ_PM => { 'XML::SAX' => 0 },
+ ...
+ );
+
+Alternatively you may wish to check for it in other ways that will
+cause more than just a warning.
+
+=item * Add the following code snippet to your Makefile.PL:
+
+ sub MY::install {
+ package MY;
+ my $script = shift->SUPER::install(@_);
+ if (ExtUtils::MakeMaker::prompt(
+ "Do you want to modify ParserDetails.ini?", 'Y')
+ =~ /^y/i) {
+ $script =~ s/install :: (.*)$/install :: $1 install_sax_driver/m;
+ $script .= <<"INSTALL";
+
+ install_sax_driver :
+ \t\@\$(PERL) -MXML::SAX -e "XML::SAX->add_parser(q(\$(NAME)))->save_parsers()"
+
+ INSTALL
+ }
+ return $script;
+ }
+
+Note that you should check the output of this - \$(NAME) will use the name of
+your distribution, which may not be exactly what you want. For example XML::LibXML
+has a driver called XML::LibXML::SAX::Generator, which is used in place of
+\$(NAME) in the above.
+
+=item * Add an XML::SAX test:
+
+A test file should be added to your t/ directory containing something like the
+following:
+
+ use Test;
+ BEGIN { plan tests => 3 }
+ use XML::SAX;
+ use XML::SAX::PurePerl::DebugHandler;
+ XML::SAX->add_parser(q(XML::SAX::MyDriver));
+ local $XML::SAX::ParserPackage = 'XML::SAX::MyDriver';
+ eval {
+ my $handler = XML::SAX::PurePerl::DebugHandler->new();
+ ok($handler);
+ my $parser = XML::SAX::ParserFactory->parser(Handler => $handler);
+ ok($parser);
+ ok($parser->isa('XML::SAX::MyDriver');
+ $parser->parse_string("<tag/>");
+ ok($handler->{seen}{start_element});
+ };
+
+=back
+
+=head1 EXPORTS
+
+By default, XML::SAX exports nothing into the caller's namespace. However you
+can request the symbols C<Namespaces> and C<Validation> which are the
+URIs for those features, allowing an easier way to request those features
+via ParserFactory:
+
+ use XML::SAX qw(Namespaces Validation);
+ my $factory = XML::SAX::ParserFactory->new();
+ $factory->require_feature(Namespaces);
+ $factory->require_feature(Validation);
+ my $parser = $factory->parser();
+
+=head1 AUTHOR
+
+Current maintainer: Grant McLean, grantm@cpan.org
+
+Originally written by:
+
+Matt Sergeant, matt@sergeant.org
+
+Kip Hampton, khampton@totalcinema.com
+
+Robin Berjon, robin@knowscape.com
+
+=head1 LICENSE
+
+This is free software, you may use it and distribute it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<XML::SAX::Base> for writing SAX Filters and Parsers
+
+L<XML::SAX::PurePerl> for an XML parser written in 100%
+pure perl.
+
+L<XML::SAX::Exception> for details on exception handling
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/Base.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/Base.pm
new file mode 100755
index 00000000000..5de3f5ce783
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/Base.pm
@@ -0,0 +1,3164 @@
+package XML::SAX::Base;
+
+# version 0.10 - Kip Hampton <khampton@totalcinema.com>
+# version 0.13 - Robin Berjon <robin@knowscape.com>
+# version 0.15 - Kip Hampton <khampton@totalcinema.com>
+# version 0.17 - Kip Hampton <khampton@totalcinema.com>
+# version 0.19 - Kip Hampton <khampton@totalcinema.com>
+# version 0.21 - Kip Hampton <khampton@totalcinema.com>
+# version 0.22 - Robin Berjon <robin@knowscape.com>
+# version 0.23 - Matt Sergeant <matt@sergeant.org>
+# version 0.24 - Robin Berjon <robin@knowscape.com>
+# version 0.25 - Kip Hampton <khampton@totalcinema.com>
+# version 1.00 - Kip Hampton <khampton@totalcinema.com>
+# version 1.01 - Kip Hampton <khampton@totalcinema.com>
+# version 1.02 - Robin Berjon <robin@knowscape.com>
+# version 1.03 - Matt Sergeant <matt@sergeant.org>
+# version 1.04 - Kip Hampton <khampton@totalcinema.com>
+
+#-----------------------------------------------------#
+# STOP!!!!!
+#
+# This file is generated by the 'Makefile.PL' file
+# that ships with the XML::SAX distribution.
+# If you need to make changes, patch that file NOT
+# this one.
+#-----------------------------------------------------#
+
+use strict;
+use vars qw($VERSION);
+use XML::SAX::Exception qw();
+
+$VERSION = '1.04';
+
+sub end_prefix_mapping {
+ my $self = shift;
+ if (defined $self->{Methods}->{'end_prefix_mapping'}) {
+ $self->{Methods}->{'end_prefix_mapping'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_prefix_mapping') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'end_prefix_mapping'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_prefix_mapping') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_prefix_mapping'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->end_prefix_mapping(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'end_prefix_mapping'} = sub { $handler->end_prefix_mapping(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->end_prefix_mapping(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_prefix_mapping'} = sub { $handler->end_prefix_mapping(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'end_prefix_mapping'} = sub { };
+ }
+ }
+
+}
+
+sub internal_entity_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'internal_entity_decl'}) {
+ $self->{Methods}->{'internal_entity_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('internal_entity_decl') ) {
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'internal_entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('internal_entity_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'internal_entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DeclHandler'}
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DeclHandler'}->internal_entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'internal_entity_decl'} = sub { $handler->internal_entity_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->internal_entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'internal_entity_decl'} = sub { $handler->internal_entity_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'internal_entity_decl'} = sub { };
+ }
+ }
+
+}
+
+sub characters {
+ my $self = shift;
+ if (defined $self->{Methods}->{'characters'}) {
+ $self->{Methods}->{'characters'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('characters') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'characters'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('characters') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'characters'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('characters') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'characters'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->characters(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'characters'} = sub { $handler->characters(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->characters(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'characters'} = sub { $handler->characters(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->characters(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'characters'} = sub { $handler->characters(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'characters'} = sub { };
+ }
+ }
+
+}
+
+sub start_element {
+ my $self = shift;
+ if (defined $self->{Methods}->{'start_element'}) {
+ $self->{Methods}->{'start_element'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_element') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_element') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_element') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->start_element(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->start_element(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->start_element(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'start_element'} = sub { };
+ }
+ }
+
+}
+
+sub external_entity_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'external_entity_decl'}) {
+ $self->{Methods}->{'external_entity_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('external_entity_decl') ) {
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'external_entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('external_entity_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'external_entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DeclHandler'}
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DeclHandler'}->external_entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'external_entity_decl'} = sub { $handler->external_entity_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->external_entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'external_entity_decl'} = sub { $handler->external_entity_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'external_entity_decl'} = sub { };
+ }
+ }
+
+}
+
+sub xml_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'xml_decl'}) {
+ $self->{Methods}->{'xml_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('xml_decl') ) {
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'xml_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('xml_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'xml_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DTDHandler'}
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DTDHandler'}->xml_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'xml_decl'} = sub { $handler->xml_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->xml_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'xml_decl'} = sub { $handler->xml_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'xml_decl'} = sub { };
+ }
+ }
+
+}
+
+sub entity_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'entity_decl'}) {
+ $self->{Methods}->{'entity_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('entity_decl') ) {
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('entity_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DTDHandler'}
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DTDHandler'}->entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'entity_decl'} = sub { $handler->entity_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'entity_decl'} = sub { $handler->entity_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'entity_decl'} = sub { };
+ }
+ }
+
+}
+
+sub end_dtd {
+ my $self = shift;
+ if (defined $self->{Methods}->{'end_dtd'}) {
+ $self->{Methods}->{'end_dtd'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_dtd') ) {
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'end_dtd'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_dtd') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_dtd'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'LexicalHandler'}
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD')
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'LexicalHandler'}->end_dtd(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'end_dtd'} = sub { $handler->end_dtd(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->end_dtd(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_dtd'} = sub { $handler->end_dtd(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'end_dtd'} = sub { };
+ }
+ }
+
+}
+
+sub unparsed_entity_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'unparsed_entity_decl'}) {
+ $self->{Methods}->{'unparsed_entity_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('unparsed_entity_decl') ) {
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'unparsed_entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('unparsed_entity_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'unparsed_entity_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DTDHandler'}
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DTDHandler'}->unparsed_entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'unparsed_entity_decl'} = sub { $handler->unparsed_entity_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->unparsed_entity_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'unparsed_entity_decl'} = sub { $handler->unparsed_entity_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'unparsed_entity_decl'} = sub { };
+ }
+ }
+
+}
+
+sub processing_instruction {
+ my $self = shift;
+ if (defined $self->{Methods}->{'processing_instruction'}) {
+ $self->{Methods}->{'processing_instruction'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('processing_instruction') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('processing_instruction') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('processing_instruction') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->processing_instruction(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->processing_instruction(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->processing_instruction(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'processing_instruction'} = sub { };
+ }
+ }
+
+}
+
+sub attribute_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'attribute_decl'}) {
+ $self->{Methods}->{'attribute_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('attribute_decl') ) {
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'attribute_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('attribute_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'attribute_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DeclHandler'}
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DeclHandler'}->attribute_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'attribute_decl'} = sub { $handler->attribute_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->attribute_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'attribute_decl'} = sub { $handler->attribute_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'attribute_decl'} = sub { };
+ }
+ }
+
+}
+
+sub fatal_error {
+ my $self = shift;
+ if (defined $self->{Methods}->{'fatal_error'}) {
+ $self->{Methods}->{'fatal_error'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('fatal_error') ) {
+ my $handler = $callbacks->{'ErrorHandler'};
+ $self->{Methods}->{'fatal_error'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('fatal_error') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'fatal_error'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ErrorHandler'}
+ and $callbacks->{'ErrorHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ErrorHandler'}->fatal_error(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ErrorHandler'};
+ $self->{Methods}->{'fatal_error'} = sub { $handler->fatal_error(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->fatal_error(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'fatal_error'} = sub { $handler->fatal_error(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'fatal_error'} = sub { };
+ }
+ }
+
+}
+
+sub end_cdata {
+ my $self = shift;
+ if (defined $self->{Methods}->{'end_cdata'}) {
+ $self->{Methods}->{'end_cdata'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_cdata') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_cdata') ) {
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_cdata') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->end_cdata(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'LexicalHandler'}
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD')
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'LexicalHandler'}->end_cdata(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->end_cdata(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'end_cdata'} = sub { };
+ }
+ }
+
+}
+
+sub start_entity {
+ my $self = shift;
+ if (defined $self->{Methods}->{'start_entity'}) {
+ $self->{Methods}->{'start_entity'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_entity') ) {
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'start_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_entity') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'LexicalHandler'}
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD')
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'LexicalHandler'}->start_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'start_entity'} = sub { $handler->start_entity(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->start_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_entity'} = sub { $handler->start_entity(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'start_entity'} = sub { };
+ }
+ }
+
+}
+
+sub start_prefix_mapping {
+ my $self = shift;
+ if (defined $self->{Methods}->{'start_prefix_mapping'}) {
+ $self->{Methods}->{'start_prefix_mapping'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_prefix_mapping') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'start_prefix_mapping'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_prefix_mapping') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_prefix_mapping'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->start_prefix_mapping(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'start_prefix_mapping'} = sub { $handler->start_prefix_mapping(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->start_prefix_mapping(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_prefix_mapping'} = sub { $handler->start_prefix_mapping(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'start_prefix_mapping'} = sub { };
+ }
+ }
+
+}
+
+sub error {
+ my $self = shift;
+ if (defined $self->{Methods}->{'error'}) {
+ $self->{Methods}->{'error'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('error') ) {
+ my $handler = $callbacks->{'ErrorHandler'};
+ $self->{Methods}->{'error'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('error') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'error'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ErrorHandler'}
+ and $callbacks->{'ErrorHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ErrorHandler'}->error(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ErrorHandler'};
+ $self->{Methods}->{'error'} = sub { $handler->error(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->error(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'error'} = sub { $handler->error(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'error'} = sub { };
+ }
+ }
+
+}
+
+sub start_document {
+ my $self = shift;
+ if (defined $self->{Methods}->{'start_document'}) {
+ $self->{Methods}->{'start_document'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_document') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_document') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_document') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->start_document(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->start_document(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->start_document(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'start_document'} = sub { };
+ }
+ }
+
+}
+
+sub ignorable_whitespace {
+ my $self = shift;
+ if (defined $self->{Methods}->{'ignorable_whitespace'}) {
+ $self->{Methods}->{'ignorable_whitespace'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('ignorable_whitespace') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('ignorable_whitespace') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('ignorable_whitespace') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->ignorable_whitespace(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->ignorable_whitespace(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->ignorable_whitespace(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'ignorable_whitespace'} = sub { };
+ }
+ }
+
+}
+
+sub end_document {
+ my $self = shift;
+ if (defined $self->{Methods}->{'end_document'}) {
+ $self->{Methods}->{'end_document'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_document') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_document') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_document') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->end_document(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->end_document(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->end_document(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'end_document'} = sub { };
+ }
+ }
+
+}
+
+sub start_cdata {
+ my $self = shift;
+ if (defined $self->{Methods}->{'start_cdata'}) {
+ $self->{Methods}->{'start_cdata'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_cdata') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_cdata') ) {
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_cdata') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->start_cdata(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'LexicalHandler'}
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD')
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'LexicalHandler'}->start_cdata(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->start_cdata(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'start_cdata'} = sub { };
+ }
+ }
+
+}
+
+sub set_document_locator {
+ my $self = shift;
+ if (defined $self->{Methods}->{'set_document_locator'}) {
+ $self->{Methods}->{'set_document_locator'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('set_document_locator') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('set_document_locator') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('set_document_locator') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->set_document_locator(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->set_document_locator(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->set_document_locator(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'set_document_locator'} = sub { };
+ }
+ }
+
+}
+
+sub attlist_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'attlist_decl'}) {
+ $self->{Methods}->{'attlist_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('attlist_decl') ) {
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'attlist_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('attlist_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'attlist_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DTDHandler'}
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DTDHandler'}->attlist_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'attlist_decl'} = sub { $handler->attlist_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->attlist_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'attlist_decl'} = sub { $handler->attlist_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'attlist_decl'} = sub { };
+ }
+ }
+
+}
+
+sub start_dtd {
+ my $self = shift;
+ if (defined $self->{Methods}->{'start_dtd'}) {
+ $self->{Methods}->{'start_dtd'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_dtd') ) {
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'start_dtd'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_dtd') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_dtd'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'LexicalHandler'}
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD')
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'LexicalHandler'}->start_dtd(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'start_dtd'} = sub { $handler->start_dtd(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->start_dtd(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'start_dtd'} = sub { $handler->start_dtd(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'start_dtd'} = sub { };
+ }
+ }
+
+}
+
+sub resolve_entity {
+ my $self = shift;
+ if (defined $self->{Methods}->{'resolve_entity'}) {
+ $self->{Methods}->{'resolve_entity'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'EntityResolver'} and $method = $callbacks->{'EntityResolver'}->can('resolve_entity') ) {
+ my $handler = $callbacks->{'EntityResolver'};
+ $self->{Methods}->{'resolve_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('resolve_entity') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'resolve_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'EntityResolver'}
+ and $callbacks->{'EntityResolver'}->can('AUTOLOAD')
+ and $callbacks->{'EntityResolver'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'EntityResolver'}->resolve_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'EntityResolver'};
+ $self->{Methods}->{'resolve_entity'} = sub { $handler->resolve_entity(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->resolve_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'resolve_entity'} = sub { $handler->resolve_entity(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'resolve_entity'} = sub { };
+ }
+ }
+
+}
+
+sub entity_reference {
+ my $self = shift;
+ if (defined $self->{Methods}->{'entity_reference'}) {
+ $self->{Methods}->{'entity_reference'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('entity_reference') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'entity_reference'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('entity_reference') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'entity_reference'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->entity_reference(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'entity_reference'} = sub { $handler->entity_reference(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->entity_reference(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'entity_reference'} = sub { $handler->entity_reference(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'entity_reference'} = sub { };
+ }
+ }
+
+}
+
+sub element_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'element_decl'}) {
+ $self->{Methods}->{'element_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('element_decl') ) {
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'element_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('element_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'element_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DeclHandler'}
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DeclHandler'}->element_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DeclHandler'};
+ $self->{Methods}->{'element_decl'} = sub { $handler->element_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->element_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'element_decl'} = sub { $handler->element_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'element_decl'} = sub { };
+ }
+ }
+
+}
+
+sub notation_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'notation_decl'}) {
+ $self->{Methods}->{'notation_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('notation_decl') ) {
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'notation_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('notation_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'notation_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DTDHandler'}
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DTDHandler'}->notation_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'notation_decl'} = sub { $handler->notation_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->notation_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'notation_decl'} = sub { $handler->notation_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'notation_decl'} = sub { };
+ }
+ }
+
+}
+
+sub skipped_entity {
+ my $self = shift;
+ if (defined $self->{Methods}->{'skipped_entity'}) {
+ $self->{Methods}->{'skipped_entity'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('skipped_entity') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'skipped_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('skipped_entity') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'skipped_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->skipped_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'skipped_entity'} = sub { $handler->skipped_entity(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->skipped_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'skipped_entity'} = sub { $handler->skipped_entity(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'skipped_entity'} = sub { };
+ }
+ }
+
+}
+
+sub end_element {
+ my $self = shift;
+ if (defined $self->{Methods}->{'end_element'}) {
+ $self->{Methods}->{'end_element'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_element') ) {
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_element') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_element') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ContentHandler'}
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ContentHandler'}->end_element(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ContentHandler'};
+ $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->end_element(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->end_element(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'end_element'} = sub { };
+ }
+ }
+
+}
+
+sub doctype_decl {
+ my $self = shift;
+ if (defined $self->{Methods}->{'doctype_decl'}) {
+ $self->{Methods}->{'doctype_decl'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('doctype_decl') ) {
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'doctype_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('doctype_decl') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'doctype_decl'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DTDHandler'}
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DTDHandler'}->doctype_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DTDHandler'};
+ $self->{Methods}->{'doctype_decl'} = sub { $handler->doctype_decl(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->doctype_decl(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'doctype_decl'} = sub { $handler->doctype_decl(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'doctype_decl'} = sub { };
+ }
+ }
+
+}
+
+sub comment {
+ my $self = shift;
+ if (defined $self->{Methods}->{'comment'}) {
+ $self->{Methods}->{'comment'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('comment') ) {
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'comment'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('comment') ) {
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'comment'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('comment') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'comment'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'DocumentHandler'}
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD')
+ and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'DocumentHandler'}->comment(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'DocumentHandler'};
+ $self->{Methods}->{'comment'} = sub { $handler->comment(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'LexicalHandler'}
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD')
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'LexicalHandler'}->comment(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'comment'} = sub { $handler->comment(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->comment(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'comment'} = sub { $handler->comment(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'comment'} = sub { };
+ }
+ }
+
+}
+
+sub end_entity {
+ my $self = shift;
+ if (defined $self->{Methods}->{'end_entity'}) {
+ $self->{Methods}->{'end_entity'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_entity') ) {
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'end_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_entity') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_entity'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'LexicalHandler'}
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD')
+ and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'LexicalHandler'}->end_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'LexicalHandler'};
+ $self->{Methods}->{'end_entity'} = sub { $handler->end_entity(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->end_entity(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'end_entity'} = sub { $handler->end_entity(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'end_entity'} = sub { };
+ }
+ }
+
+}
+
+sub warning {
+ my $self = shift;
+ if (defined $self->{Methods}->{'warning'}) {
+ $self->{Methods}->{'warning'}->(@_);
+ }
+ else {
+ my $method;
+ my $callbacks;
+ if (exists $self->{ParseOptions}) {
+ $callbacks = $self->{ParseOptions};
+ }
+ else {
+ $callbacks = $self;
+ }
+ if (0) { # dummy to make elsif's below compile
+ }
+ elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('warning') ) {
+ my $handler = $callbacks->{'ErrorHandler'};
+ $self->{Methods}->{'warning'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('warning') ) {
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'warning'} = sub { $method->($handler, @_) };
+ return $method->($handler, @_);
+ }
+ elsif (defined $callbacks->{'ErrorHandler'}
+ and $callbacks->{'ErrorHandler'}->can('AUTOLOAD')
+ and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'ErrorHandler'}->warning(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'ErrorHandler'};
+ $self->{Methods}->{'warning'} = sub { $handler->warning(@_) };
+ }
+ return $res;
+ }
+ elsif (defined $callbacks->{'Handler'}
+ and $callbacks->{'Handler'}->can('AUTOLOAD')
+ and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '')
+ )
+ {
+ my $res = eval { $callbacks->{'Handler'}->warning(@_) };
+ if ($@) {
+ die $@;
+ }
+ else {
+ # I think there's a buggette here...
+ # if the first call throws an exception, we don't set it up right.
+ # Not fatal, but we might want to address it.
+ my $handler = $callbacks->{'Handler'};
+ $self->{Methods}->{'warning'} = sub { $handler->warning(@_) };
+ }
+ return $res;
+ }
+ else {
+ $self->{Methods}->{'warning'} = sub { };
+ }
+ }
+
+}
+
+#-------------------------------------------------------------------#
+# Class->new(%options)
+#-------------------------------------------------------------------#
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $options = ($#_ == 0) ? shift : { @_ };
+
+ unless ( defined( $options->{Handler} ) or
+ defined( $options->{ContentHandler} ) or
+ defined( $options->{DTDHandler} ) or
+ defined( $options->{DocumentHandler} ) or
+ defined( $options->{LexicalHandler} ) or
+ defined( $options->{ErrorHandler} ) or
+ defined( $options->{DeclHandler} ) ) {
+
+ $options->{Handler} = XML::SAX::Base::NoHandler->new;
+ }
+
+ my $self = bless $options, $class;
+ # turn NS processing on by default
+ $self->set_feature('http://xml.org/sax/features/namespaces', 1);
+ return $self;
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# $p->parse(%options)
+#-------------------------------------------------------------------#
+sub parse {
+ my $self = shift;
+ my $parse_options = $self->get_options(@_);
+ local $self->{ParseOptions} = $parse_options;
+ if ($self->{Parent}) { # calling parse on a filter for some reason
+ return $self->{Parent}->parse($parse_options);
+ }
+ else {
+ my $method;
+ if (defined $parse_options->{Source}{CharacterStream} and $method = $self->can('_parse_characterstream')) {
+ warn("parse charstream???\n");
+ return $method->($self, $parse_options->{Source}{CharacterStream});
+ }
+ elsif (defined $parse_options->{Source}{ByteStream} and $method = $self->can('_parse_bytestream')) {
+ return $method->($self, $parse_options->{Source}{ByteStream});
+ }
+ elsif (defined $parse_options->{Source}{String} and $method = $self->can('_parse_string')) {
+ return $method->($self, $parse_options->{Source}{String});
+ }
+ elsif (defined $parse_options->{Source}{SystemId} and $method = $self->can('_parse_systemid')) {
+ return $method->($self, $parse_options->{Source}{SystemId});
+ }
+ else {
+ die "No _parse_* routine defined on this driver (If it is a filter, remember to set the Parent property. If you call the parse() method, make sure to set a Source. You may want to call parse_uri, parse_string or parse_file instead.) [$self]";
+ }
+ }
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# $p->parse_file(%options)
+#-------------------------------------------------------------------#
+sub parse_file {
+ my $self = shift;
+ my $file = shift;
+ return $self->parse_uri($file, @_) if ref(\$file) eq 'SCALAR';
+ my $parse_options = $self->get_options(@_);
+ $parse_options->{Source}{ByteStream} = $file;
+ return $self->parse($parse_options);
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# $p->parse_uri(%options)
+#-------------------------------------------------------------------#
+sub parse_uri {
+ my $self = shift;
+ my $file = shift;
+ my $parse_options = $self->get_options(@_);
+ $parse_options->{Source}{SystemId} = $file;
+ return $self->parse($parse_options);
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# $p->parse_string(%options)
+#-------------------------------------------------------------------#
+sub parse_string {
+ my $self = shift;
+ my $string = shift;
+ my $parse_options = $self->get_options(@_);
+ $parse_options->{Source}{String} = $string;
+ return $self->parse($parse_options);
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_options
+#-------------------------------------------------------------------#
+sub get_options {
+ my $self = shift;
+
+ if (@_ == 1) {
+ return { %$self, %{$_[0]} };
+ } else {
+ return { %$self, @_ };
+ }
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_features
+#-------------------------------------------------------------------#
+sub get_features {
+ return (
+ 'http://xml.org/sax/features/external-general-entities' => undef,
+ 'http://xml.org/sax/features/external-parameter-entities' => undef,
+ 'http://xml.org/sax/features/is-standalone' => undef,
+ 'http://xml.org/sax/features/lexical-handler' => undef,
+ 'http://xml.org/sax/features/parameter-entities' => undef,
+ 'http://xml.org/sax/features/namespaces' => 1,
+ 'http://xml.org/sax/features/namespace-prefixes' => 0,
+ 'http://xml.org/sax/features/string-interning' => undef,
+ 'http://xml.org/sax/features/use-attributes2' => undef,
+ 'http://xml.org/sax/features/use-locator2' => undef,
+ 'http://xml.org/sax/features/validation' => undef,
+
+ 'http://xml.org/sax/properties/dom-node' => undef,
+ 'http://xml.org/sax/properties/xml-string' => undef,
+ );
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_feature
+#-------------------------------------------------------------------#
+sub get_feature {
+ my $self = shift;
+ my $feat = shift;
+
+ # check %FEATURES to see if it's there, and return it if so
+ # throw XML::SAX::Exception::NotRecognized if it's not there
+ # throw XML::SAX::Exception::NotSupported if it's there but we
+ # don't support it
+
+ my %features = $self->get_features();
+ if (exists $features{$feat}) {
+ my %supported = map { $_ => 1 } $self->supported_features();
+ if ($supported{$feat}) {
+ return $self->{__PACKAGE__ . "::Features"}{$feat};
+ }
+ throw XML::SAX::Exception::NotSupported(
+ Message => "The feature '$feat' is not supported by " . ref($self),
+ Exception => undef,
+ );
+ }
+ throw XML::SAX::Exception::NotRecognized(
+ Message => "The feature '$feat' is not recognized by " . ref($self),
+ Exception => undef,
+ );
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# set_feature
+#-------------------------------------------------------------------#
+sub set_feature {
+ my $self = shift;
+ my $feat = shift;
+ my $value = shift;
+ # check %FEATURES to see if it's there, and set it if so
+ # throw XML::SAX::Exception::NotRecognized if it's not there
+ # throw XML::SAX::Exception::NotSupported if it's there but we
+ # don't support it
+
+ my %features = $self->get_features();
+ if (exists $features{$feat}) {
+ my %supported = map { $_ => 1 } $self->supported_features();
+ if ($supported{$feat}) {
+ return $self->{__PACKAGE__ . "::Features"}{$feat} = $value;
+ }
+ throw XML::SAX::Exception::NotSupported(
+ Message => "The feature '$feat' is not supported by " . ref($self),
+ Exception => undef,
+ );
+ }
+ throw XML::SAX::Exception::NotRecognized(
+ Message => "The feature '$feat' is not recognized by " . ref($self),
+ Exception => undef,
+ );
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# get_handler and friends
+#-------------------------------------------------------------------#
+sub get_handler {
+ my $self = shift;
+ my $handler_type = shift;
+ $handler_type ||= 'Handler';
+ return defined( $self->{$handler_type} ) ? $self->{$handler_type} : undef;
+}
+
+sub get_document_handler {
+ my $self = shift;
+ return $self->get_handler('DocumentHandler', @_);
+}
+
+sub get_content_handler {
+ my $self = shift;
+ return $self->get_handler('ContentHandler', @_);
+}
+
+sub get_dtd_handler {
+ my $self = shift;
+ return $self->get_handler('DTDHandler', @_);
+}
+
+sub get_lexical_handler {
+ my $self = shift;
+ return $self->get_handler('LexicalHandler', @_);
+}
+
+sub get_decl_handler {
+ my $self = shift;
+ return $self->get_handler('DeclHandler', @_);
+}
+
+sub get_error_handler {
+ my $self = shift;
+ return $self->get_handler('ErrorHandler', @_);
+}
+
+sub get_entity_resolver {
+ my $self = shift;
+ return $self->get_handler('EntityResolver', @_);
+}
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# set_handler and friends
+#-------------------------------------------------------------------#
+sub set_handler {
+ my $self = shift;
+ my ($new_handler, $handler_type) = reverse @_;
+ $handler_type ||= 'Handler';
+ $self->{Methods} = {} if $self->{Methods};
+ $self->{$handler_type} = $new_handler;
+ $self->{ParseOptions}->{$handler_type} = $new_handler;
+ return 1;
+}
+
+sub set_document_handler {
+ my $self = shift;
+ return $self->set_handler('DocumentHandler', @_);
+}
+
+sub set_content_handler {
+ my $self = shift;
+ return $self->set_handler('ContentHandler', @_);
+}
+sub set_dtd_handler {
+ my $self = shift;
+ return $self->set_handler('DTDHandler', @_);
+}
+sub set_lexical_handler {
+ my $self = shift;
+ return $self->set_handler('LexicalHandler', @_);
+}
+sub set_decl_handler {
+ my $self = shift;
+ return $self->set_handler('DeclHandler', @_);
+}
+sub set_error_handler {
+ my $self = shift;
+ return $self->set_handler('ErrorHandler', @_);
+}
+sub set_entity_resolver {
+ my $self = shift;
+ return $self->set_handler('EntityResolver', @_);
+}
+
+#-------------------------------------------------------------------#
+
+#-------------------------------------------------------------------#
+# supported_features
+#-------------------------------------------------------------------#
+sub supported_features {
+ my $self = shift;
+ # Only namespaces are required by all parsers
+ return (
+ 'http://xml.org/sax/features/namespaces',
+ );
+}
+#-------------------------------------------------------------------#
+
+sub no_op {
+ # this space intentionally blank
+}
+
+
+package XML::SAX::Base::NoHandler;
+
+# we need a fake handler that doesn't implement anything, this
+# simplifies the code a lot (though given the recent changes,
+# it may be better to do without)
+sub new {
+ #warn "no handler called\n";
+ return bless {};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::SAX::Base - Base class SAX Drivers and Filters
+
+=head1 SYNOPSIS
+
+ package MyFilter;
+ use XML::SAX::Base;
+ @ISA = ('XML::SAX::Base');
+
+=head1 DESCRIPTION
+
+This module has a very simple task - to be a base class for PerlSAX
+drivers and filters. It's default behaviour is to pass the input directly
+to the output unchanged. It can be useful to use this module as a base class
+so you don't have to, for example, implement the characters() callback.
+
+The main advantages that it provides are easy dispatching of events the right
+way (ie it takes care for you of checking that the handler has implemented
+that method, or has defined an AUTOLOAD), and the guarantee that filters
+will pass along events that they aren't implementing to handlers downstream
+that might nevertheless be interested in them.
+
+=head1 WRITING SAX DRIVERS AND FILTERS
+
+Writing SAX Filters is tremendously easy: all you need to do is
+inherit from this module, and define the events you want to handle. A
+more detailed explanation can be found at
+http://www.xml.com/pub/a/2001/10/10/sax-filters.html.
+
+Writing Drivers is equally simple. The one thing you need to pay
+attention to is B<NOT> to call events yourself (this applies to Filters
+as well). For instance:
+
+ package MyFilter;
+ use base qw(XML::SAX::Base);
+
+ sub start_element {
+ my $self = shift;
+ my $data = shift;
+ # do something
+ $self->{Handler}->start_element($data); # BAD
+ }
+
+The above example works well as precisely that: an example. But it has
+several faults: 1) it doesn't test to see whether the handler defines
+start_element. Perhaps it doesn't want to see that event, in which
+case you shouldn't throw it (otherwise it'll die). 2) it doesn't check
+ContentHandler and then Handler (ie it doesn't look to see that the
+user hasn't requested events on a specific handler, and if not on the
+default one), 3) if it did check all that, not only would the code be
+cumbersome (see this module's source to get an idea) but it would also
+probably have to check for a DocumentHandler (in case this were SAX1)
+and for AUTOLOADs potentially defined in all these packages. As you can
+tell, that would be fairly painful. Instead of going through that,
+simply remember to use code similar to the following instead:
+
+ package MyFilter;
+ use base qw(XML::SAX::Base);
+
+ sub start_element {
+ my $self = shift;
+ my $data = shift;
+ # do something to filter
+ $self->SUPER::start_element($data); # GOOD (and easy) !
+ }
+
+This way, once you've done your job you hand the ball back to
+XML::SAX::Base and it takes care of all those problems for you!
+
+Note that the above example doesn't apply to filters only, drivers
+will benefit from the exact same feature.
+
+=head1 METHODS
+
+A number of methods are defined within this class for the purpose of
+inheritance. Some probably don't need to be overridden (eg parse_file)
+but some clearly should be (eg parse). Options for these methods are
+described in the PerlSAX2 specification available from
+http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/~checkout~/perl-xml/libxml-perl/doc/sax-2.0.html?rev=HEAD&content-type=text/html.
+
+=over 4
+
+=item * parse
+
+The parse method is the main entry point to parsing documents. Internally
+the parse method will detect what type of "thing" you are parsing, and
+call the appropriate method in your implementation class. Here is the
+mapping table of what is in the Source options (see the Perl SAX 2.0
+specification for the meaning of these values):
+
+ Source Contains parse() calls
+ =============== =============
+ CharacterStream (*) _parse_characterstream($stream, $options)
+ ByteStream _parse_bytestream($stream, $options)
+ String _parse_string($string, $options)
+ SystemId _parse_systemid($string, $options)
+
+However note that these methods may not be sensible if your driver class
+is not for parsing XML. An example might be a DBI driver that generates
+XML/SAX from a database table. If that is the case, you likely want to
+write your own parse() method.
+
+Also note that the Source may contain both a PublicId entry, and an
+Encoding entry. To get at these, examine $options->{Source} as passed
+to your method.
+
+(*) A CharacterStream is a filehandle that does not need any encoding
+translation done on it. This is implemented as a regular filehandle
+and only works under Perl 5.7.2 or higher using PerlIO. To get a single
+character, or number of characters from it, use the perl core read()
+function. To get a single byte from it (or number of bytes), you can
+use sysread(). The encoding of the stream should be in the Encoding
+entry for the Source.
+
+=item * parse_file, parse_uri, parse_string
+
+These are all convenience variations on parse(), and in fact simply
+set up the options before calling it. You probably don't need to
+override these.
+
+=item * get_options
+
+This is a convenience method to get options in SAX2 style, or more
+generically either as hashes or as hashrefs (it returns a hashref).
+You will probably want to use this method in your own implementations
+of parse() and of new().
+
+=item * get_feature, set_feature
+
+These simply get and set features, and throw the
+appropriate exceptions defined in the specification if need be.
+
+If your subclass defines features not defined in this one,
+then you should override these methods in such a way that they check for
+your features first, and then call the base class's methods
+for features not defined by your class. An example would be:
+
+ sub get_feature {
+ my $self = shift;
+ my $feat = shift;
+ if (exists $MY_FEATURES{$feat}) {
+ # handle the feature in various ways
+ }
+ else {
+ return $self->SUPER::get_feature($feat);
+ }
+ }
+
+Currently this part is unimplemented.
+
+
+=item * set_handler
+
+This method takes a handler type (Handler, ContentHandler, etc.) and a
+handler object as arguments, and changes the current handler for that
+handler type, while taking care of resetting the internal state that
+needs to be reset. This allows one to change a handler during parse
+without running into problems (changing it on the parser object
+directly will most likely cause trouble).
+
+=item * set_document_handler, set_content_handler, set_dtd_handler, set_lexical_handler, set_decl_handler, set_error_handler, set_entity_resolver
+
+These are just simple wrappers around the former method, and take a
+handler object as their argument. Internally they simply call
+set_handler with the correct arguments.
+
+=item * get_handler
+
+The inverse of set_handler, this method takes a an optional string containing a handler type (DTDHandler,
+ContentHandler, etc. 'Handler' is used if no type is passed). It returns a reference to the object that implements
+that that class, or undef if that handler type is not set for the current driver/filter.
+
+=item * get_document_handler, get_content_handler, get_dtd_handler, get_lexical_handler, get_decl_handler,
+get_error_handler, get_entity_resolver
+
+These are just simple wrappers around the get_handler() method, and take no arguments. Internally
+they simply call get_handler with the correct handler type name.
+
+=back
+
+It would be rather useless to describe all the methods that this
+module implements here. They are all the methods supported in SAX1 and
+SAX2. In case your memory is a little short, here is a list. The
+apparent duplicates are there so that both versions of SAX can be
+supported.
+
+=over 4
+
+=item * start_document
+
+=item * end_document
+
+=item * start_element
+
+=item * start_document
+
+=item * end_document
+
+=item * start_element
+
+=item * end_element
+
+=item * characters
+
+=item * processing_instruction
+
+=item * ignorable_whitespace
+
+=item * set_document_locator
+
+=item * start_prefix_mapping
+
+=item * end_prefix_mapping
+
+=item * skipped_entity
+
+=item * start_cdata
+
+=item * end_cdata
+
+=item * comment
+
+=item * entity_reference
+
+=item * notation_decl
+
+=item * unparsed_entity_decl
+
+=item * element_decl
+
+=item * attlist_decl
+
+=item * doctype_decl
+
+=item * xml_decl
+
+=item * entity_decl
+
+=item * attribute_decl
+
+=item * internal_entity_decl
+
+=item * external_entity_decl
+
+=item * resolve_entity
+
+=item * start_dtd
+
+=item * end_dtd
+
+=item * start_entity
+
+=item * end_entity
+
+=item * warning
+
+=item * error
+
+=item * fatal_error
+
+=back
+
+=head1 TODO
+
+ - more tests
+ - conform to the "SAX Filters" and "Java and DOM compatibility"
+ sections of the SAX2 document.
+
+=head1 AUTHOR
+
+Kip Hampton (khampton@totalcinema.com) did most of the work, after porting
+it from XML::Filter::Base.
+
+Robin Berjon (robin@knowscape.com) pitched in with patches to make it
+usable as a base for drivers as well as filters, along with other patches.
+
+Matt Sergeant (matt@sergeant.org) wrote the original XML::Filter::Base,
+and patched a few things here and there, and imported it into
+the XML::SAX distribution.
+
+=head1 SEE ALSO
+
+L<XML::SAX>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/DocumentLocator.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/DocumentLocator.pm
new file mode 100755
index 00000000000..2d4811b12ba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/DocumentLocator.pm
@@ -0,0 +1,134 @@
+# $Id: DocumentLocator.pm,v 1.3 2005-10-14 20:31:20 matt Exp $
+
+package XML::SAX::DocumentLocator;
+use strict;
+
+sub new {
+ my $class = shift;
+ my %object;
+ tie %object, $class, @_;
+
+ return bless \%object, $class;
+}
+
+sub TIEHASH {
+ my $class = shift;
+ my ($pubmeth, $sysmeth, $linemeth, $colmeth, $encmeth, $xmlvmeth) = @_;
+ return bless {
+ pubmeth => $pubmeth,
+ sysmeth => $sysmeth,
+ linemeth => $linemeth,
+ colmeth => $colmeth,
+ encmeth => $encmeth,
+ xmlvmeth => $xmlvmeth,
+ }, $class;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ my $method;
+ if ($key eq 'PublicId') {
+ $method = $self->{pubmeth};
+ }
+ elsif ($key eq 'SystemId') {
+ $method = $self->{sysmeth};
+ }
+ elsif ($key eq 'LineNumber') {
+ $method = $self->{linemeth};
+ }
+ elsif ($key eq 'ColumnNumber') {
+ $method = $self->{colmeth};
+ }
+ elsif ($key eq 'Encoding') {
+ $method = $self->{encmeth};
+ }
+ elsif ($key eq 'XMLVersion') {
+ $method = $self->{xmlvmeth};
+ }
+ if ($method) {
+ my $value = $method->($key);
+ return $value;
+ }
+ return undef;
+}
+
+sub EXISTS {
+ my ($self, $key) = @_;
+ if ($key =~ /^(PublicId|SystemId|LineNumber|ColumnNumber|Encoding|XMLVersion)$/) {
+ return 1;
+ }
+ return 0;
+}
+
+sub STORE {
+ my ($self, $key, $value) = @_;
+}
+
+sub DELETE {
+ my ($self, $key) = @_;
+}
+
+sub CLEAR {
+ my ($self) = @_;
+}
+
+sub FIRSTKEY {
+ my ($self) = @_;
+ # assignment resets.
+ $self->{keys} = {
+ PublicId => 1,
+ SystemId => 1,
+ LineNumber => 1,
+ ColumnNumber => 1,
+ Encoding => 1,
+ XMLVersion => 1,
+ };
+ return each %{$self->{keys}};
+}
+
+sub NEXTKEY {
+ my ($self, $lastkey) = @_;
+ return each %{$self->{keys}};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::SAX::DocumentLocator - Helper class for document locators
+
+=head1 SYNOPSIS
+
+ my $locator = XML::SAX::DocumentLocator->new(
+ sub { $object->get_public_id },
+ sub { $object->get_system_id },
+ sub { $reader->current_line },
+ sub { $reader->current_column },
+ sub { $reader->get_encoding },
+ sub { $reader->get_xml_version },
+ );
+
+=head1 DESCRIPTION
+
+This module gives you a tied hash reference that calls the
+specified closures when asked for PublicId, SystemId,
+LineNumber and ColumnNumber.
+
+It is useful for writing SAX Parsers so that you don't have
+to constantly update the line numbers in a hash reference on
+the object you pass to set_document_locator(). See the source
+code for XML::SAX::PurePerl for a usage example.
+
+=head1 API
+
+There is only 1 method: C<new>. Simply pass it a list of
+closures that when called will return the PublicId, the
+SystemId, the LineNumber, the ColumnNumber, the Encoding
+and the XMLVersion respectively.
+
+The closures are passed a single parameter, the key being
+requested. But you're free to ignore that.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/Exception.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/Exception.pm
new file mode 100755
index 00000000000..79910205804
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/Exception.pm
@@ -0,0 +1,126 @@
+package XML::SAX::Exception;
+
+use strict;
+
+use overload '""' => "stringify",
+ 'fallback' => 1;
+
+use vars qw/$StackTrace $VERSION/;
+$VERSION = '1.01';
+use Carp;
+
+$StackTrace = $ENV{XML_DEBUG} || 0;
+
+# Other exception classes:
+
+@XML::SAX::Exception::NotRecognized::ISA = ('XML::SAX::Exception');
+@XML::SAX::Exception::NotSupported::ISA = ('XML::SAX::Exception');
+@XML::SAX::Exception::Parse::ISA = ('XML::SAX::Exception');
+
+
+sub throw {
+ my $class = shift;
+ if (ref($class)) {
+ die $class;
+ }
+ die $class->new(@_);
+}
+
+sub new {
+ my $class = shift;
+ my %opts = @_;
+ confess "Invalid options: " . join(', ', keys %opts) unless exists $opts{Message};
+
+ bless { ($StackTrace ? (StackTrace => stacktrace()) : ()), %opts },
+ $class;
+}
+
+sub stringify {
+ my $self = shift;
+ local $^W;
+ my $error;
+ if (exists $self->{LineNumber}) {
+ $error = $self->{Message} . " [Ln: " . $self->{LineNumber} .
+ ", Col: " . $self->{ColumnNumber} . "]";
+ }
+ else {
+ $error = $self->{Message};
+ }
+ if ($StackTrace) {
+ $error .= stackstring($self->{StackTrace});
+ }
+ $error .= "\n";
+ return $error;
+}
+
+sub stacktrace {
+ my $i = 2;
+ my @fulltrace;
+ while (my @trace = caller($i++)) {
+ my %hash;
+ @hash{qw(Package Filename Line)} = @trace[0..2];
+ push @fulltrace, \%hash;
+ }
+ return \@fulltrace;
+}
+
+sub stackstring {
+ my $stacktrace = shift;
+ my $string = "\nFrom:\n";
+ foreach my $current (@$stacktrace) {
+ $string .= $current->{Filename} . " Line: " . $current->{Line} . "\n";
+ }
+ return $string;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::SAX::Exception - Exception classes for XML::SAX
+
+=head1 SYNOPSIS
+
+ throw XML::SAX::Exception::NotSupported(
+ Message => "The foo feature is not supported",
+ );
+
+=head1 DESCRIPTION
+
+This module is the base class for all SAX Exceptions, those defined in
+the spec as well as those that one may create for one's own SAX errors.
+
+There are three subclasses included, corresponding to those of the SAX
+spec:
+
+ XML::SAX::Exception::NotSupported
+ XML::SAX::Exception::NotRecognized
+ XML::SAX::Exception::Parse
+
+Use them wherever you want, and as much as possible when you encounter
+such errors. SAX is meant to use exceptions as much as possible to
+flag problems.
+
+=head1 CREATING NEW EXCEPTION CLASSES
+
+All you need to do to create a new exception class is:
+
+ @XML::SAX::Exception::MyException::ISA = ('XML::SAX::Exception')
+
+The given package doesn't need to exist, it'll behave correctly this
+way. If your exception refines an existing exception class, then you
+may also inherit from that instead of from the base class.
+
+=head1 THROWING EXCEPTIONS
+
+This is as simple as exemplified in the SYNOPSIS. In fact, there's
+nothing more to know. All you have to do is:
+
+ throw XML::SAX::Exception::MyException( Message => 'Something went wrong' );
+
+and voila, you've thrown an exception which can be caught in an eval block.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/Intro.pod b/Master/tlpkg/tlperl.straw/lib/XML/SAX/Intro.pod
new file mode 100755
index 00000000000..dea71cf7103
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/Intro.pod
@@ -0,0 +1,407 @@
+=head1 NAME
+
+XML::SAX::Intro - An Introduction to SAX Parsing with Perl
+
+=head1 Introduction
+
+XML::SAX is a new way to work with XML Parsers in Perl. In this article
+we'll discuss why you should be using SAX, why you should be using
+XML::SAX, and we'll see some of the finer implementation details. The
+text below assumes some familiarity with callback, or push based
+parsing, but if you are unfamiliar with these techniques then a good
+place to start is Kip Hampton's excellent series of articles on XML.com.
+
+=head1 Replacing XML::Parser
+
+The de-facto way of parsing XML under perl is to use Larry Wall and
+Clark Cooper's XML::Parser. This module is a Perl and XS wrapper around
+the expat XML parser library by James Clark. It has been a hugely
+successful project, but suffers from a couple of rather major flaws.
+Firstly it is a proprietary API, designed before the SAX API was
+conceived, which means that it is not easily replaceable by other
+streaming parsers. Secondly it's callbacks are subrefs. This doesn't
+sound like much of an issue, but unfortunately leads to code like:
+
+ sub handle_start {
+ my ($e, $el, %attrs) = @_;
+ if ($el eq 'foo') {
+ $e->{inside_foo}++; # BAD! $e is an XML::Parser::Expat object.
+ }
+ }
+
+As you can see, we're using the $e object to hold our state
+information, which is a bad idea because we don't own that object - we
+didn't create it. It's an internal object of XML::Parser, that happens
+to be a hashref. We could all too easily overwrite XML::Parser internal
+state variables by using this, or Clark could change it to an array ref
+(not that he would, because it would break so much code, but he could).
+
+The only way currently with XML::Parser to safely maintain state is to
+use a closure:
+
+ my $state = MyState->new();
+ $parser->setHandlers(Start => sub { handle_start($state, @_) });
+
+This closure traps the $state variable, which now gets passed as the
+first parameter to your callback. Unfortunately very few people use
+this technique, as it is not documented in the XML::Parser POD files.
+
+Another reason you might not want to use XML::Parser is because you
+need some feature that it doesn't provide (such as validation), or you
+might need to use a library that doesn't use expat, due to it not being
+installed on your system, or due to having a restrictive ISP. Using SAX
+allows you to work around these restrictions.
+
+=head1 Introducing SAX
+
+SAX stands for the Simple API for XML. And simple it really is.
+Constructing a SAX parser and passing events to handlers is done as
+simply as:
+
+ use XML::SAX;
+ use MySAXHandler;
+
+ my $parser = XML::SAX::ParserFactory->parser(
+ Handler => MySAXHandler->new
+ );
+
+ $parser->parse_uri("foo.xml");
+
+The important concept to grasp here is that SAX uses a factory class
+called XML::SAX::ParserFactory to create a new parser instance. The
+reason for this is so that you can support other underlying
+parser implementations for different feature sets. This is one thing
+that XML::Parser has always sorely lacked.
+
+In the code above we see the parse_uri method used, but we could
+have equally well
+called parse_file, parse_string, or parse(). Please see XML::SAX::Base
+for what these methods take as parameters, but don't be fooled into
+believing parse_file takes a filename. No, it takes a file handle, a
+glob, or a subclass of IO::Handle. Beware.
+
+SAX works very similarly to XML::Parser's default callback method,
+except it has one major difference: rather than setting individual
+callbacks, you create a new class in which to recieve the callbacks.
+Each callback is called as a method call on an instance of that handler
+class. An example will best demonstrate this:
+
+ package MySAXHandler;
+ use base qw(XML::SAX::Base);
+
+ sub start_document {
+ my ($self, $doc) = @_;
+ # process document start event
+ }
+
+ sub start_element {
+ my ($self, $el) = @_;
+ # process element start event
+ }
+
+Now, when we instantiate this as above, and parse some XML with this as
+the handler, the methods start_document and start_element will be
+called as method calls, so this would be the equivalent of directly
+calling:
+
+ $object->start_element($el);
+
+Notice how this is different to XML::Parser's calling style, which
+calls:
+
+ start_element($e, $name, %attribs);
+
+It's the difference between function calling and method calling which
+allows you to subclass SAX handlers which contributes to SAX being a
+powerful solution.
+
+As you can see, unlike XML::Parser, we have to define a new package in
+which to do our processing (there are hacks you can do to make this
+uneccessary, but I'll leave figuring those out to the experts). The
+biggest benefit of this is that you maintain your own state variable
+($self in the above example) thus freeing you of the concerns listed
+above. It is also an improvement in maintainability - you can place the
+code in a separate file if you wish to, and your callback methods are
+always called the same thing, rather than having to choose a suitable
+name for them as you had to with XML::Parser. This is an obvious win.
+
+SAX parsers are also very flexible in how you pass a handler to them.
+You can use a constructor parameter as we saw above, or we can pass the
+handler directly in the call to one of the parse methods:
+
+ $parser->parse(Handler => $handler,
+ Source => { SystemId => "foo.xml" });
+ # or...
+ $parser->parse_file($fh, Handler => $handler);
+
+This flexibility allows for one parser to be used in many different
+scenarios throughout your script (though one shouldn't feel pressure to
+use this method, as parser construction is generally not a time
+consuming process).
+
+=head1 Callback Parameters
+
+The only other thing you need to know to understand basic SAX is the
+structure of the parameters passed to each of the callbacks. In
+XML::Parser, all parameters are passed as multiple options to the
+callbacks, so for example the Start callback would be called as
+my_start($e, $name, %attributes), and the PI callback would be called
+as my_processing_instruction($e, $target, $data). In SAX, every
+callback is passed a hash reference, containing entries that define our
+"node". The key callbacks and the structures they receive are:
+
+=head2 start_element
+
+The start_element handler is called whenever a parser sees an opening
+tag. It is passed an element structure consisting of:
+
+=over 4
+
+=item LocalName
+
+The name of the element minus any namespace prefix it may
+have come with in the document.
+
+=item NamespaceURI
+
+The URI of the namespace associated with this element,
+or the empty string for none.
+
+=item Attributes
+
+A set of attributes as described below.
+
+=item Name
+
+The name of the element as it was seen in the document (i.e.
+including any prefix associated with it)
+
+=item Prefix
+
+The prefix used to qualify this element's namespace, or the
+empty string if none.
+
+=back
+
+The B<Attributes> are a hash reference, keyed by what we have called
+"James Clark" notation. This means that the attribute name has been
+expanded to include any associated namespace URI, and put together as
+{ns}name, where "ns" is the expanded namespace URI of the attribute if
+and only if the attribute had a prefix, and "name" is the LocalName of
+the attribute.
+
+The value of each entry in the attributes hash is another hash
+structure consisting of:
+
+=over 4
+
+=item LocalName
+
+The name of the attribute minus any namespace prefix it may have
+come with in the document.
+
+=item NamespaceURI
+
+The URI of the namespace associated with this attribute. If the
+attribute had no prefix, then this consists of just the empty string.
+
+=item Name
+
+The attribute's name as it appeared in the document, including any
+namespace prefix.
+
+=item Prefix
+
+The prefix used to qualify this attribute's namepace, or the
+empty string if none.
+
+=item Value
+
+The value of the attribute.
+
+=back
+
+So a full example, as output by Data::Dumper might be:
+
+ ....
+
+=head2 end_element
+
+The end_element handler is called either when a parser sees a closing
+tag, or after start_element has been called for an empty element (do
+note however that a parser may if it is so inclined call characters
+with an empty string when it sees an empty element. There is no simple
+way in SAX to determine if the parser in fact saw an empty element, a
+start and end element with no content..
+
+The end_element handler receives exactly the same structure as
+start_element, minus the Attributes entry. One must note though that it
+should not be a reference to the same data as start_element receives,
+so you may change the values in start_element but this will not affect
+the values later seen by end_element.
+
+=head2 characters
+
+The characters callback may be called in serveral circumstances. The
+most obvious one is when seeing ordinary character data in the markup.
+But it is also called for text in a CDATA section, and is also called
+in other situations. A SAX parser has to make no guarantees whatsoever
+about how many times it may call characters for a stretch of text in an
+XML document - it may call once, or it may call once for every
+character in the text. In order to work around this it is often
+important for the SAX developer to use a bundling technique, where text
+is gathered up and processed in one of the other callbacks. This is not
+always necessary, but it is a worthwhile technique to learn, which we
+will cover in XML::SAX::Advanced (when I get around to writing it).
+
+The characters handler is called with a very simple structure - a hash
+reference consisting of just one entry:
+
+=over 4
+
+=item Data
+
+The text data that was received.
+
+=back
+
+=head2 comment
+
+The comment callback is called for comment text. Unlike with
+C<characters()>, the comment callback *must* be invoked just once for an
+entire comment string. It receives a single simple structure - a hash
+reference containing just one entry:
+
+=over 4
+
+=item Data
+
+The text of the comment.
+
+=back
+
+=head2 processing_instruction
+
+The processing instruction handler is called for all processing
+instructions in the document. Note that these processing instructions
+may appear before the document root element, or after it, or anywhere
+where text and elements would normally appear within the document,
+according to the XML specification.
+
+The handler is passed a structure containing just two entries:
+
+=over 4
+
+=item Target
+
+The target of the processing instrcution
+
+=item Data
+
+The text data in the processing instruction. Can be an empty
+string for a processing instruction that has no data element.
+For example E<lt>?wiggle?E<gt> is a perfectly valid processing instruction.
+
+=back
+
+=head1 Tip of the iceberg
+
+What we have discussed above is really the tip of the SAX iceberg. And
+so far it looks like there's not much of interest to SAX beyond what we
+have seen with XML::Parser. But it does go much further than that, I
+promise.
+
+People who hate Object Oriented code for the sake of it may be thinking
+here that creating a new package just to parse something is a waste
+when they've been parsing things just fine up to now using procedural
+code. But there's reason to all this madness. And that reason is SAX
+Filters.
+
+As you saw right at the very start, to let the parser know about our
+class, we pass it an instance of our class as the Handler to the
+parser. But now imagine what would happen if our class could also take
+a Handler option, and simply do some processing and pass on our data
+further down the line? That in a nutshell is how SAX filters work. It's
+Unix pipes for the 21st century!
+
+There are two downsides to this. Number 1 - writing SAX filters can be
+tricky. If you look into the future and read the advanced tutorial I'm
+writing, you'll see that Handler can come in several shapes and sizes.
+So making sure your filter does the right thing can be tricky.
+Secondly, constructing complex filter chains can be difficult, and
+simple thinking tells us that we only get one pass at our document,
+when often we'll need more than that.
+
+Luckily though, those downsides have been fixed by the release of two
+very cool modules. What's even better is that I didn't write either of
+them!
+
+The first module is XML::SAX::Base. This is a VITAL SAX module that
+acts as a base class for all SAX parsers and filters. It provides an
+abstraction away from calling the handler methods, that makes sure your
+filter or parser does the right thing, and it does it FAST. So, if you
+ever need to write a SAX filter, which if you're processing XML -> XML,
+or XML -> HTML, then you probably do, then you need to be writing it as
+a subclass of XML::SAX::Base. Really - this is advice not to ignore
+lightly. I will not go into the details of writing a SAX filter here.
+Kip Hampton, the author of XML::SAX::Base has covered this nicely in
+his article on XML.com here <URI>.
+
+To construct SAX pipelines, Barrie Slaymaker, a long time Perl hacker
+whose modules you will probably have heard of or used, wrote a very
+clever module called XML::SAX::Machines. This combines some really
+clever SAX filter-type modules, with a construction toolkit for filters
+that makes building pipelines easy. But before we see how it makes
+things easy, first lets see how tricky it looks to build complex SAX
+filter pipelines.
+
+ use XML::SAX::ParserFactory;
+ use XML::Filter::Filter1;
+ use XML::Filter::Filter2;
+ use XML::SAX::Writer;
+
+ my $output_string;
+ my $writer = XML::SAX::Writer->new(Output => \$output_string);
+ my $filter2 = XML::SAX::Filter2->new(Handler => $writer);
+ my $filter1 = XML::SAX::Filter1->new(Handler => $filter2);
+ my $parser = XML::SAX::ParserFactory->parser(Handler => $filter1);
+
+ $parser->parse_uri("foo.xml");
+
+This is a lot easier with XML::SAX::Machines:
+
+ use XML::SAX::Machines qw(Pipeline);
+
+ my $output_string;
+ my $parser = Pipeline(
+ XML::SAX::Filter1 => XML::SAX::Filter2 => \$output_string
+ );
+
+ $parser->parse_uri("foo.xml");
+
+One of the main benefits of XML::SAX::Machines is that the pipelines
+are constructed in natural order, rather than the reverse order we saw
+with manual pipeline construction. XML::SAX::Machines takes care of all
+the internals of pipe construction, providing you at the end with just
+a parser you can use (and you can re-use the same parser as many times
+as you need to).
+
+Just a final tip. If you ever get stuck and are confused about what is
+being passed from one SAX filter or parser to the next, then
+Devel::TraceSAX will come to your rescue. This perl debugger plugin
+will allow you to dump the SAX stream of events as it goes by. Usage is
+really very simple just call your perl script that uses SAX as follows:
+
+ $ perl -d:TraceSAX <scriptname>
+
+And preferably pipe the output to a pager of some sort, such as more or
+less. The output is extremely verbose, but should help clear some
+issues up.
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org
+
+$Id: Intro.pod,v 1.4 2008-08-04 10:28:01 grant Exp $
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/ParserDetails.ini b/Master/tlpkg/tlperl.straw/lib/XML/SAX/ParserDetails.ini
new file mode 100755
index 00000000000..b2812ed6c96
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/ParserDetails.ini
@@ -0,0 +1,10 @@
+[XML::SAX::PurePerl]
+http://xml.org/sax/features/namespaces = 1
+
+[XML::LibXML::SAX::Parser]
+http://xml.org/sax/features/namespaces = 1
+
+[XML::LibXML::SAX]
+http://xml.org/sax/features/namespaces = 1
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/ParserFactory.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/ParserFactory.pm
new file mode 100755
index 00000000000..f4325b41797
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/ParserFactory.pm
@@ -0,0 +1,230 @@
+# $Id: ParserFactory.pm,v 1.14 2008-08-04 04:51:29 grant Exp $
+
+package XML::SAX::ParserFactory;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = '1.01';
+
+use Symbol qw(gensym);
+use XML::SAX;
+use XML::SAX::Exception;
+
+sub new {
+ my $class = shift;
+ my %params = @_; # TODO : Fix this in spec.
+ my $self = bless \%params, $class;
+ $self->{KnownParsers} = XML::SAX->parsers();
+ return $self;
+}
+
+sub parser {
+ my $self = shift;
+ my @parser_params = @_;
+ if (!ref($self)) {
+ $self = $self->new();
+ }
+
+ my $parser_class = $self->_parser_class();
+
+ my $version = '';
+ if ($parser_class =~ s/\s*\(([\d\.]+)\)\s*$//) {
+ $version = " $1";
+ }
+
+ if (!$parser_class->can('new')) {
+ eval "require $parser_class $version;";
+ die $@ if $@;
+ }
+
+ return $parser_class->new(@parser_params);
+}
+
+sub require_feature {
+ my $self = shift;
+ my ($feature) = @_;
+ $self->{RequiredFeatures}{$feature}++;
+ return $self;
+}
+
+sub _parser_class {
+ my $self = shift;
+
+ # First try ParserPackage
+ if ($XML::SAX::ParserPackage) {
+ return $XML::SAX::ParserPackage;
+ }
+
+ # Now check if required/preferred is there
+ if ($self->{RequiredFeatures}) {
+ my %required = %{$self->{RequiredFeatures}};
+ # note - we never go onto the next try (ParserDetails.ini),
+ # because if we can't provide the requested feature
+ # we need to throw an exception.
+ PARSER:
+ foreach my $parser (reverse @{$self->{KnownParsers}}) {
+ foreach my $feature (keys %required) {
+ if (!exists $parser->{Features}{$feature}) {
+ next PARSER;
+ }
+ }
+ # got here - all features must exist!
+ return $parser->{Name};
+ }
+ # TODO : should this be NotSupported() ?
+ throw XML::SAX::Exception (
+ Message => "Unable to provide required features",
+ );
+ }
+
+ # Next try SAX.ini
+ for my $dir (@INC) {
+ my $fh = gensym();
+ if (open($fh, "$dir/SAX.ini")) {
+ my $param_list = XML::SAX->_parse_ini_file($fh);
+ my $params = $param_list->[0]->{Features};
+ if ($params->{ParserPackage}) {
+ return $params->{ParserPackage};
+ }
+ else {
+ # we have required features (or nothing?)
+ PARSER:
+ foreach my $parser (reverse @{$self->{KnownParsers}}) {
+ foreach my $feature (keys %$params) {
+ if (!exists $parser->{Features}{$feature}) {
+ next PARSER;
+ }
+ }
+ return $parser->{Name};
+ }
+ XML::SAX->do_warn("Unable to provide SAX.ini required features. Using fallback\n");
+ }
+ last; # stop after first INI found
+ }
+ }
+
+ if (@{$self->{KnownParsers}}) {
+ return $self->{KnownParsers}[-1]{Name};
+ }
+ else {
+ return "XML::SAX::PurePerl"; # backup plan!
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::SAX::ParserFactory - Obtain a SAX parser
+
+=head1 SYNOPSIS
+
+ use XML::SAX::ParserFactory;
+ use XML::SAX::XYZHandler;
+ my $handler = XML::SAX::XYZHandler->new();
+ my $p = XML::SAX::ParserFactory->parser(Handler => $handler);
+ $p->parse_uri("foo.xml");
+ # or $p->parse_string("<foo/>") or $p->parse_file($fh);
+
+=head1 DESCRIPTION
+
+XML::SAX::ParserFactory is a factory class for providing an application
+with a Perl SAX2 XML parser. It is akin to DBI - a front end for other
+parser classes. Each new SAX2 parser installed will register itself
+with XML::SAX, and then it will become available to all applications
+that use XML::SAX::ParserFactory to obtain a SAX parser.
+
+Unlike DBI however, XML/SAX parsers almost all work alike (especially
+if they subclass XML::SAX::Base, as they should), so rather than
+specifying the parser you want in the call to C<parser()>, XML::SAX
+has several ways to automatically choose which parser to use:
+
+=over 4
+
+=item * $XML::SAX::ParserPackage
+
+If this package variable is set, then this package is C<require()>d
+and an instance of this package is returned by calling the C<new()>
+class method in that package. If it cannot be loaded or there is
+an error, an exception will be thrown. The variable can also contain
+a version number:
+
+ $XML::SAX::ParserPackage = "XML::SAX::Expat (0.72)";
+
+And the number will be treated as a minimum version number.
+
+=item * Required features
+
+It is possible to require features from the parsers. For example, you
+may wish for a parser that supports validation via a DTD. To do that,
+use the following code:
+
+ use XML::SAX::ParserFactory;
+ my $factory = XML::SAX::ParserFactory->new();
+ $factory->require_feature('http://xml.org/sax/features/validation');
+ my $parser = $factory->parser(...);
+
+Alternatively, specify the required features in the call to the
+ParserFactory constructor:
+
+ my $factory = XML::SAX::ParserFactory->new(
+ RequiredFeatures => {
+ 'http://xml.org/sax/features/validation' => 1,
+ }
+ );
+
+If the features you have asked for are unavailable (for example the
+user might not have a validating parser installed), then an
+exception will be thrown.
+
+The list of known parsers is searched in reverse order, so it will
+always return the last installed parser that supports all of your
+requested features (Note: this is subject to change if someone
+comes up with a better way of making this work).
+
+=item * SAX.ini
+
+ParserFactory will search @INC for a file called SAX.ini, which
+is in a simple format:
+
+ # a comment looks like this,
+ ; or like this, and are stripped anywhere in the file
+ key = value # SAX.in contains key/value pairs.
+
+All whitespace is non-significant.
+
+This file can contain either a line:
+
+ ParserPackage = MyParserModule (1.02)
+
+Where MyParserModule is the module to load and use for the parser,
+and the number in brackets is a minimum version to load.
+
+Or you can list required features:
+
+ http://xml.org/sax/features/validation = 1
+
+And each feature with a true value will be required.
+
+=item * Fallback
+
+If none of the above works, the last parser installed on the user's
+system will be used. The XML::SAX package ships with a pure perl
+XML parser, XML::SAX::PurePerl, so that there will always be a
+fallback parser.
+
+=back
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org
+
+=head1 LICENSE
+
+This is free software, you may use it and distribute it under the same
+terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl.pm
new file mode 100755
index 00000000000..40e71485f20
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl.pm
@@ -0,0 +1,751 @@
+# $Id: PurePerl.pm,v 1.28 2008-08-05 12:36:51 grant Exp $
+
+package XML::SAX::PurePerl;
+
+use strict;
+use vars qw/$VERSION/;
+
+$VERSION = '0.96';
+
+use XML::SAX::PurePerl::Productions qw($NameChar $SingleChar);
+use XML::SAX::PurePerl::Reader;
+use XML::SAX::PurePerl::EncodingDetect ();
+use XML::SAX::Exception;
+use XML::SAX::PurePerl::DocType ();
+use XML::SAX::PurePerl::DTDDecls ();
+use XML::SAX::PurePerl::XMLDecl ();
+use XML::SAX::DocumentLocator ();
+use XML::SAX::Base ();
+use XML::SAX qw(Namespaces);
+use XML::NamespaceSupport ();
+use IO::File;
+
+if ($] < 5.006) {
+ require XML::SAX::PurePerl::NoUnicodeExt;
+}
+else {
+ require XML::SAX::PurePerl::UnicodeExt;
+}
+
+use vars qw(@ISA);
+@ISA = ('XML::SAX::Base');
+
+my %int_ents = (
+ amp => '&',
+ lt => '<',
+ gt => '>',
+ quot => '"',
+ apos => "'",
+ );
+
+my $xmlns_ns = "http://www.w3.org/2000/xmlns/";
+my $xml_ns = "http://www.w3.org/XML/1998/namespace";
+
+use Carp;
+sub _parse_characterstream {
+ my $self = shift;
+ my ($fh) = @_;
+ confess("CharacterStream is not yet correctly implemented");
+ my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh);
+ return $self->_parse($reader);
+}
+
+sub _parse_bytestream {
+ my $self = shift;
+ my ($fh) = @_;
+ my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh);
+ return $self->_parse($reader);
+}
+
+sub _parse_string {
+ my $self = shift;
+ my ($str) = @_;
+ my $reader = XML::SAX::PurePerl::Reader::String->new($str);
+ return $self->_parse($reader);
+}
+
+sub _parse_systemid {
+ my $self = shift;
+ my ($uri) = @_;
+ my $reader = XML::SAX::PurePerl::Reader::URI->new($uri);
+ return $self->_parse($reader);
+}
+
+sub _parse {
+ my ($self, $reader) = @_;
+
+ $reader->public_id($self->{ParseOptions}{Source}{PublicId});
+ $reader->system_id($self->{ParseOptions}{Source}{SystemId});
+
+ $self->{NSHelper} = XML::NamespaceSupport->new({xmlns => 1});
+
+ $self->set_document_locator(
+ XML::SAX::DocumentLocator->new(
+ sub { $reader->public_id },
+ sub { $reader->system_id },
+ sub { $reader->line },
+ sub { $reader->column },
+ sub { $reader->get_encoding },
+ sub { $reader->get_xml_version },
+ ),
+ );
+
+ $self->start_document({});
+
+ if (defined $self->{ParseOptions}{Source}{Encoding}) {
+ $reader->set_encoding($self->{ParseOptions}{Source}{Encoding});
+ }
+ else {
+ $self->encoding_detect($reader);
+ }
+
+ # parse a document
+ $self->document($reader);
+
+ return $self->end_document({});
+}
+
+sub parser_error {
+ my $self = shift;
+ my ($error, $reader) = @_;
+
+# warn("parser error: $error from ", $reader->line, " : ", $reader->column, "\n");
+ my $exception = XML::SAX::Exception::Parse->new(
+ Message => $error,
+ ColumnNumber => $reader->column,
+ LineNumber => $reader->line,
+ PublicId => $reader->public_id,
+ SystemId => $reader->system_id,
+ );
+
+ $self->fatal_error($exception);
+ $exception->throw;
+}
+
+sub document {
+ my ($self, $reader) = @_;
+
+ # document ::= prolog element Misc*
+
+ $self->prolog($reader);
+ $self->element($reader) ||
+ $self->parser_error("Document requires an element", $reader);
+
+ while(length($reader->data)) {
+ $self->Misc($reader) ||
+ $self->parser_error("Only Comments, PIs and whitespace allowed at end of document", $reader);
+ }
+}
+
+sub prolog {
+ my ($self, $reader) = @_;
+
+ $self->XMLDecl($reader);
+
+ # consume all misc bits
+ 1 while($self->Misc($reader));
+
+ if ($self->doctypedecl($reader)) {
+ while (length($reader->data)) {
+ $self->Misc($reader) || last;
+ }
+ }
+}
+
+sub element {
+ my ($self, $reader) = @_;
+
+ return 0 unless $reader->match('<');
+
+ my $name = $self->Name($reader) || $self->parser_error("Invalid element name", $reader);
+
+ my %attribs;
+
+ while( my ($k, $v) = $self->Attribute($reader) ) {
+ $attribs{$k} = $v;
+ }
+
+ my $have_namespaces = $self->get_feature(Namespaces);
+
+ # Namespace processing
+ $self->{NSHelper}->push_context;
+ my @new_ns;
+# my %attrs = @attribs;
+# while (my ($k,$v) = each %attrs) {
+ if ($have_namespaces) {
+ while ( my ($k, $v) = each %attribs ) {
+ if ($k =~ m/^xmlns(:(.*))?$/) {
+ my $prefix = $2 || '';
+ $self->{NSHelper}->declare_prefix($prefix, $v);
+ my $ns =
+ {
+ Prefix => $prefix,
+ NamespaceURI => $v,
+ };
+ push @new_ns, $ns;
+ $self->SUPER::start_prefix_mapping($ns);
+ }
+ }
+ }
+
+ # Create element object and fire event
+ my %attrib_hash;
+ while (my ($name, $value) = each %attribs ) {
+ # TODO normalise value here
+ my ($ns, $prefix, $lname);
+ if ($have_namespaces) {
+ ($ns, $prefix, $lname) = $self->{NSHelper}->process_attribute_name($name);
+ }
+ $ns ||= ''; $prefix ||= ''; $lname ||= '';
+ $attrib_hash{"{$ns}$lname"} = {
+ Name => $name,
+ LocalName => $lname,
+ Prefix => $prefix,
+ NamespaceURI => $ns,
+ Value => $value,
+ };
+ }
+
+ %attribs = (); # lose the memory since we recurse deep
+
+ my ($ns, $prefix, $lname);
+ if ($self->get_feature(Namespaces)) {
+ ($ns, $prefix, $lname) = $self->{NSHelper}->process_element_name($name);
+ }
+ else {
+ $lname = $name;
+ }
+ $ns ||= ''; $prefix ||= ''; $lname ||= '';
+
+ # Process remainder of start_element
+ $self->skip_whitespace($reader);
+ my $have_content;
+ my $data = $reader->data(2);
+ if ($data =~ /^\/>/) {
+ $reader->move_along(2);
+ }
+ else {
+ $data =~ /^>/ or $self->parser_error("No close element tag", $reader);
+ $reader->move_along(1);
+ $have_content++;
+ }
+
+ my $el =
+ {
+ Name => $name,
+ LocalName => $lname,
+ Prefix => $prefix,
+ NamespaceURI => $ns,
+ Attributes => \%attrib_hash,
+ };
+ $self->start_element($el);
+
+ # warn("($name\n");
+
+ if ($have_content) {
+ $self->content($reader);
+
+ my $data = $reader->data(2);
+ $data =~ /^<\// or $self->parser_error("No close tag marker", $reader);
+ $reader->move_along(2);
+ my $end_name = $self->Name($reader);
+ $end_name eq $name || $self->parser_error("End tag mismatch ($end_name != $name)", $reader);
+ $self->skip_whitespace($reader);
+ $reader->match('>') or $self->parser_error("No close '>' on end tag", $reader);
+ }
+
+ my %end_el = %$el;
+ delete $end_el{Attributes};
+ $self->end_element(\%end_el);
+
+ for my $ns (@new_ns) {
+ $self->end_prefix_mapping($ns);
+ }
+ $self->{NSHelper}->pop_context;
+
+ return 1;
+}
+
+sub content {
+ my ($self, $reader) = @_;
+
+ while (1) {
+ $self->CharData($reader);
+
+ my $data = $reader->data(2);
+
+ if ($data =~ /^<\//) {
+ return 1;
+ }
+ elsif ($data =~ /^&/) {
+ $self->Reference($reader) or $self->parser_error("bare & not allowed in content", $reader);
+ next;
+ }
+ elsif ($data =~ /^<!/) {
+ ($self->CDSect($reader)
+ or
+ $self->Comment($reader))
+ and next;
+ }
+ elsif ($data =~ /^<\?/) {
+ $self->PI($reader) and next;
+ }
+ elsif ($data =~ /^</) {
+ $self->element($reader) and next;
+ }
+ last;
+ }
+
+ return 1;
+}
+
+sub CDSect {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(9);
+ return 0 unless $data =~ /^<!\[CDATA\[/;
+ $reader->move_along(9);
+
+ $self->start_cdata({});
+
+ $data = $reader->data;
+ while (1) {
+ $self->parser_error("EOF looking for CDATA section end", $reader)
+ unless length($data);
+
+ if ($data =~ /^(.*?)\]\]>/s) {
+ my $chars = $1;
+ $reader->move_along(length($chars) + 3);
+ $self->characters({Data => $chars});
+ last;
+ }
+ else {
+ $self->characters({Data => $data});
+ $reader->move_along(length($data));
+ $data = $reader->data;
+ }
+ }
+ $self->end_cdata({});
+ return 1;
+}
+
+sub CharData {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data;
+
+ while (1) {
+ return unless length($data);
+
+ if ($data =~ /^([^<&]*)[<&]/s) {
+ my $chars = $1;
+ $self->parser_error("String ']]>' not allowed in character data", $reader)
+ if $chars =~ /\]\]>/;
+ $reader->move_along(length($chars));
+ $self->characters({Data => $chars}) if length($chars);
+ last;
+ }
+ else {
+ $self->characters({Data => $data});
+ $reader->move_along(length($data));
+ $data = $reader->data;
+ }
+ }
+}
+
+sub Misc {
+ my ($self, $reader) = @_;
+ if ($self->Comment($reader)) {
+ return 1;
+ }
+ elsif ($self->PI($reader)) {
+ return 1;
+ }
+ elsif ($self->skip_whitespace($reader)) {
+ return 1;
+ }
+
+ return 0;
+}
+
+sub Reference {
+ my ($self, $reader) = @_;
+
+ return 0 unless $reader->match('&');
+
+ my $data = $reader->data;
+
+ # Fetch more data if we have an incomplete numeric reference
+ if ($data =~ /^(#\d*|#x[0-9a-fA-F]*)$/) {
+ $data = $reader->data(length($data) + 6);
+ }
+
+ if ($data =~ /^#x([0-9a-fA-F]+);/) {
+ my $ref = $1;
+ $reader->move_along(length($ref) + 3);
+ my $char = chr_ref(hex($ref));
+ $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader)
+ unless $char =~ /$SingleChar/o;
+ $self->characters({ Data => $char });
+ return 1;
+ }
+ elsif ($data =~ /^#([0-9]+);/) {
+ my $ref = $1;
+ $reader->move_along(length($ref) + 2);
+ my $char = chr_ref($ref);
+ $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader)
+ unless $char =~ /$SingleChar/o;
+ $self->characters({ Data => $char });
+ return 1;
+ }
+ else {
+ # EntityRef
+ my $name = $self->Name($reader)
+ || $self->parser_error("Invalid name in entity", $reader);
+ $reader->match(';') or $self->parser_error("No semi-colon found after entity name", $reader);
+
+ # warn("got entity: \&$name;\n");
+
+ # expand it
+ if ($self->_is_entity($name)) {
+
+ if ($self->_is_external($name)) {
+ my $value = $self->_get_entity($name);
+ my $ent_reader = XML::SAX::PurePerl::Reader::URI->new($value);
+ $self->encoding_detect($ent_reader);
+ $self->extParsedEnt($ent_reader);
+ }
+ else {
+ my $value = $self->_stringify_entity($name);
+ my $ent_reader = XML::SAX::PurePerl::Reader::String->new($value);
+ $self->content($ent_reader);
+ }
+ return 1;
+ }
+ elsif ($name =~ /^(?:amp|gt|lt|quot|apos)$/) {
+ $self->characters({ Data => $int_ents{$name} });
+ return 1;
+ }
+ else {
+ $self->parser_error("Undeclared entity", $reader);
+ }
+ }
+}
+
+sub AttReference {
+ my ($self, $name, $reader) = @_;
+ if ($name =~ /^#x([0-9a-fA-F]+)$/) {
+ my $chr = chr_ref(hex($1));
+ $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader);
+ return $chr;
+ }
+ elsif ($name =~ /^#([0-9]+)$/) {
+ my $chr = chr_ref($1);
+ $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader);
+ return $chr;
+ }
+ else {
+ if ($self->_is_entity($name)) {
+ if ($self->_is_external($name)) {
+ $self->parser_error("No external entity references allowed in attribute values", $reader);
+ }
+ else {
+ my $value = $self->_stringify_entity($name);
+ return $value;
+ }
+ }
+ elsif ($name =~ /^(?:amp|lt|gt|quot|apos)$/) {
+ return $int_ents{$name};
+ }
+ else {
+ $self->parser_error("Undeclared entity '$name'", $reader);
+ }
+ }
+}
+
+sub extParsedEnt {
+ my ($self, $reader) = @_;
+
+ $self->TextDecl($reader);
+ $self->content($reader);
+}
+
+sub _is_external {
+ my ($self, $name) = @_;
+# TODO: Fix this to use $reader to store the entities perhaps.
+ if ($self->{ParseOptions}{external_entities}{$name}) {
+ return 1;
+ }
+ return ;
+}
+
+sub _is_entity {
+ my ($self, $name) = @_;
+# TODO: ditto above
+ if (exists $self->{ParseOptions}{entities}{$name}) {
+ return 1;
+ }
+ return 0;
+}
+
+sub _stringify_entity {
+ my ($self, $name) = @_;
+# TODO: ditto above
+ if (exists $self->{ParseOptions}{expanded_entity}{$name}) {
+ return $self->{ParseOptions}{expanded_entity}{$name};
+ }
+ # expand
+ my $reader = XML::SAX::PurePerl::Reader::URI->new($self->{ParseOptions}{entities}{$name});
+ my $ent = '';
+ while(1) {
+ my $data = $reader->data;
+ $ent .= $data;
+ $reader->move_along(length($data)) or last;
+ }
+ return $self->{ParseOptions}{expanded_entity}{$name} = $ent;
+}
+
+sub _get_entity {
+ my ($self, $name) = @_;
+# TODO: ditto above
+ return $self->{ParseOptions}{entities}{$name};
+}
+
+sub skip_whitespace {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data;
+
+ my $found = 0;
+ while ($data =~ s/^([\x20\x0A\x0D\x09]*)//) {
+ last unless length($1);
+ $found++;
+ $reader->move_along(length($1));
+ $data = $reader->data;
+ }
+
+ return $found;
+}
+
+sub Attribute {
+ my ($self, $reader) = @_;
+
+ $self->skip_whitespace($reader) || return;
+
+ my $data = $reader->data(2);
+ return if $data =~ /^\/?>/;
+
+ if (my $name = $self->Name($reader)) {
+ $self->skip_whitespace($reader);
+ $reader->match('=') or $self->parser_error("No '=' in Attribute", $reader);
+ $self->skip_whitespace($reader);
+ my $value = $self->AttValue($reader);
+
+ if (!$self->cdata_attrib($name)) {
+ $value =~ s/^\x20*//; # discard leading spaces
+ $value =~ s/\x20*$//; # discard trailing spaces
+ $value =~ s/ {1,}/ /g; # all >1 space to single space
+ }
+
+ return $name, $value;
+ }
+
+ return;
+}
+
+sub cdata_attrib {
+ # TODO implement this!
+ return 1;
+}
+
+sub AttValue {
+ my ($self, $reader) = @_;
+
+ my $quote = $self->quote($reader);
+
+ my $value = '';
+
+ while (1) {
+ my $data = $reader->data;
+ $self->parser_error("EOF found while looking for the end of attribute value", $reader)
+ unless length($data);
+ if ($data =~ /^([^$quote]*)$quote/) {
+ $reader->move_along(length($1) + 1);
+ $value .= $1;
+ last;
+ }
+ else {
+ $value .= $data;
+ $reader->move_along(length($data));
+ }
+ }
+
+ if ($value =~ /</) {
+ $self->parser_error("< character not allowed in attribute values", $reader);
+ }
+
+ $value =~ s/[\x09\x0A\x0D]/\x20/g;
+ $value =~ s/&(#(x[0-9a-fA-F]+)|#([0-9]+)|\w+);/$self->AttReference($1, $reader)/geo;
+
+ return $value;
+}
+
+sub Comment {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(4);
+ if ($data =~ /^<!--/) {
+ $reader->move_along(4);
+ my $comment_str = '';
+ while (1) {
+ my $data = $reader->data;
+ $self->parser_error("End of data seen while looking for close comment marker", $reader)
+ unless length($data);
+ if ($data =~ /^(.*?)-->/s) {
+ $comment_str .= $1;
+ $self->parser_error("Invalid comment (dash)", $reader) if $comment_str =~ /-$/;
+ $reader->move_along(length($1) + 3);
+ last;
+ }
+ else {
+ $comment_str .= $data;
+ $reader->move_along(length($data));
+ }
+ }
+
+ $self->comment({ Data => $comment_str });
+
+ return 1;
+ }
+ return 0;
+}
+
+sub PI {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(2);
+
+ if ($data =~ /^<\?/) {
+ $reader->move_along(2);
+ my ($target);
+ $target = $self->Name($reader) ||
+ $self->parser_error("PI has no target", $reader);
+
+ my $pi_data = '';
+ if ($self->skip_whitespace($reader)) {
+ while (1) {
+ my $data = $reader->data;
+ $self->parser_error("End of data seen while looking for close PI marker", $reader)
+ unless length($data);
+ if ($data =~ /^(.*?)\?>/s) {
+ $pi_data .= $1;
+ $reader->move_along(length($1) + 2);
+ last;
+ }
+ else {
+ $pi_data .= $data;
+ $reader->move_along(length($data));
+ }
+ }
+ }
+ else {
+ my $data = $reader->data(2);
+ $data =~ /^\?>/ or $self->parser_error("PI closing sequence not found", $reader);
+ $reader->move_along(2);
+ }
+
+ $self->processing_instruction({ Target => $target, Data => $pi_data });
+
+ return 1;
+ }
+ return 0;
+}
+
+sub Name {
+ my ($self, $reader) = @_;
+
+ my $name = '';
+ while(1) {
+ my $data = $reader->data;
+ return unless length($data);
+ $data =~ /^([^\s>\/&\?;=<\)\(\[\],\%\#\!\*\|]*)/ or return;
+ $name .= $1;
+ my $len = length($1);
+ $reader->move_along($len);
+ last if ($len != length($data));
+ }
+
+ return unless length($name);
+
+ $name =~ /$NameChar/o or $self->parser_error("Name <$name> does not match NameChar production", $reader);
+
+ return $name;
+}
+
+sub quote {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data;
+
+ $data =~ /^(['"])/ or $self->parser_error("Invalid quote token", $reader);
+ $reader->move_along(1);
+ return $1;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::SAX::PurePerl - Pure Perl XML Parser with SAX2 interface
+
+=head1 SYNOPSIS
+
+ use XML::Handler::Foo;
+ use XML::SAX::PurePerl;
+ my $handler = XML::Handler::Foo->new();
+ my $parser = XML::SAX::PurePerl->new(Handler => $handler);
+ $parser->parse_uri("myfile.xml");
+
+=head1 DESCRIPTION
+
+This module implements an XML parser in pure perl. It is written around the
+upcoming perl 5.8's unicode support and support for multiple document
+encodings (using the PerlIO layer), however it has been ported to work with
+ASCII/UTF8 documents under lower perl versions.
+
+The SAX2 API is described in detail at http://sourceforge.net/projects/perl-xml/, in
+the CVS archive, under libxml-perl/docs. Hopefully those documents will be in a
+better location soon.
+
+Please refer to the SAX2 documentation for how to use this module - it is merely a
+front end to SAX2, and implements nothing that is not in that spec (or at least tries
+not to - please email me if you find errors in this implementation).
+
+=head1 BUGS
+
+XML::SAX::PurePerl is B<slow>. Very slow. I suggest you use something else
+in fact. However it is great as a fallback parser for XML::SAX, where the
+user might not be able to install an XS based parser or C library.
+
+Currently lots, probably. At the moment the weakest area is parsing DOCTYPE declarations,
+though the code is in place to start doing this. Also parsing parameter entity
+references is causing me much confusion, since it's not exactly what I would call
+trivial, or well documented in the XML grammar. XML documents with internal subsets
+are likely to fail.
+
+I am however trying to work towards full conformance using the Oasis test suite.
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org. Copyright 2001.
+
+Please report all bugs to the Perl-XML mailing list at perl-xml@listserv.activestate.com.
+
+=head1 LICENSE
+
+This is free software. You may use it or redistribute it under the same terms as
+Perl 5.7.2 itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DTDDecls.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DTDDecls.pm
new file mode 100755
index 00000000000..9e496b47f4c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DTDDecls.pm
@@ -0,0 +1,603 @@
+# $Id: DTDDecls.pm,v 1.9 2008-08-05 12:37:13 grant Exp $
+
+package XML::SAX::PurePerl;
+
+use strict;
+use XML::SAX::PurePerl::Productions qw($SingleChar);
+
+sub elementdecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(9);
+ return 0 unless $data =~ /^<!ELEMENT/;
+ $reader->move_along(9);
+
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after ELEMENT declaration", $reader);
+
+ my $name = $self->Name($reader);
+
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after ELEMENT's name", $reader);
+
+ $self->contentspec($reader, $name);
+
+ $self->skip_whitespace($reader);
+
+ $reader->match('>') or $self->parser_error("Closing angle bracket not found on ELEMENT declaration", $reader);
+
+ return 1;
+}
+
+sub contentspec {
+ my ($self, $reader, $name) = @_;
+
+ my $data = $reader->data(5);
+
+ my $model;
+ if ($data =~ /^EMPTY/) {
+ $reader->move_along(5);
+ $model = 'EMPTY';
+ }
+ elsif ($data =~ /^ANY/) {
+ $reader->move_along(3);
+ $model = 'ANY';
+ }
+ else {
+ $model = $self->Mixed_or_children($reader);
+ }
+
+ if ($model) {
+ # call SAX callback now.
+ $self->element_decl({Name => $name, Model => $model});
+ return 1;
+ }
+
+ $self->parser_error("contentspec not found in ELEMENT declaration", $reader);
+}
+
+sub Mixed_or_children {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(8);
+ $data =~ /^\(/ or return; # $self->parser_error("No opening bracket in Mixed or children", $reader);
+
+ if ($data =~ /^\(\s*\#PCDATA/) {
+ $reader->match('(');
+ $self->skip_whitespace($reader);
+ $reader->move_along(7);
+ my $model = $self->Mixed($reader);
+ return $model;
+ }
+
+ # not matched - must be Children
+ return $self->children($reader);
+}
+
+# Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' '*' )
+# | ( '(' S* PCDATA S* ')' )
+sub Mixed {
+ my ($self, $reader) = @_;
+
+ # Mixed_or_children already matched '(' S* '#PCDATA'
+
+ my $model = '(#PCDATA';
+
+ $self->skip_whitespace($reader);
+
+ my %seen;
+
+ while (1) {
+ last unless $reader->match('|');
+ $self->skip_whitespace($reader);
+
+ my $name = $self->Name($reader) ||
+ $self->parser_error("No 'Name' after Mixed content '|'", $reader);
+
+ if ($seen{$name}) {
+ $self->parser_error("Element '$name' has already appeared in this group", $reader);
+ }
+ $seen{$name}++;
+
+ $model .= "|$name";
+
+ $self->skip_whitespace($reader);
+ }
+
+ $reader->match(')') || $self->parser_error("no closing bracket on mixed content", $reader);
+
+ $model .= ")";
+
+ if ($reader->match('*')) {
+ $model .= "*";
+ }
+
+ return $model;
+}
+
+# [[47]] Children ::= ChoiceOrSeq Cardinality?
+# [[48]] Cp ::= ( QName | ChoiceOrSeq ) Cardinality?
+# ChoiceOrSeq ::= '(' S* Cp ( Choice | Seq )? S* ')'
+# [[49]] Choice ::= ( S* '|' S* Cp )+
+# [[50]] Seq ::= ( S* ',' S* Cp )+
+# // Children ::= (Choice | Seq) Cardinality?
+# // Cp ::= ( QName | Choice | Seq) Cardinality?
+# // Choice ::= '(' S* Cp ( S* '|' S* Cp )+ S* ')'
+# // Seq ::= '(' S* Cp ( S* ',' S* Cp )* S* ')'
+# [[51]] Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' MixedCardinality )
+# | ( '(' S* PCDATA S* ')' )
+# Cardinality ::= '?' | '+' | '*'
+# MixedCardinality ::= '*'
+sub children {
+ my ($self, $reader) = @_;
+
+ return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader);
+}
+
+sub ChoiceOrSeq {
+ my ($self, $reader) = @_;
+
+ $reader->match('(') or $self->parser_error("choice/seq contains no opening bracket", $reader);
+
+ my $model = '(';
+
+ $self->skip_whitespace($reader);
+
+ $model .= $self->Cp($reader);
+
+ if (my $choice = $self->Choice($reader)) {
+ $model .= $choice;
+ }
+ else {
+ $model .= $self->Seq($reader);
+ }
+
+ $self->skip_whitespace($reader);
+
+ $reader->match(')') or $self->parser_error("choice/seq contains no closing bracket", $reader);
+
+ $model .= ')';
+
+ return $model;
+}
+
+sub Cardinality {
+ my ($self, $reader) = @_;
+ # cardinality is always optional
+ my $data = $reader->data;
+ if ($data =~ /^([\?\+\*])/) {
+ $reader->move_along(1);
+ return $1;
+ }
+ return '';
+}
+
+sub Cp {
+ my ($self, $reader) = @_;
+
+ my $model;
+ my $name = eval
+ {
+ if (my $name = $self->Name($reader)) {
+ return $name . $self->Cardinality($reader);
+ }
+ };
+ return $name if defined $name;
+ return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader);
+}
+
+sub Choice {
+ my ($self, $reader) = @_;
+
+ my $model = '';
+ $self->skip_whitespace($reader);
+
+ while ($reader->match('|')) {
+ $self->skip_whitespace($reader);
+ $model .= '|';
+ $model .= $self->Cp($reader);
+ $self->skip_whitespace($reader);
+ }
+
+ return $model;
+}
+
+sub Seq {
+ my ($self, $reader) = @_;
+
+ my $model = '';
+ $self->skip_whitespace($reader);
+
+ while ($reader->match(',')) {
+ $self->skip_whitespace($reader);
+ my $cp = $self->Cp($reader);
+ if ($cp) {
+ $model .= ',';
+ $model .= $cp;
+ }
+ $self->skip_whitespace($reader);
+ }
+
+ return $model;
+}
+
+sub AttlistDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(9);
+ if ($data =~ /^<!ATTLIST/) {
+ # It's an attlist
+
+ $reader->move_along(9);
+
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after ATTLIST declaration", $reader);
+ my $name = $self->Name($reader);
+
+ $self->AttDefList($reader, $name);
+
+ $self->skip_whitespace($reader);
+
+ $reader->match('>') or $self->parser_error("Closing angle bracket not found on ATTLIST declaration", $reader);
+
+ return 1;
+ }
+
+ return 0;
+}
+
+sub AttDefList {
+ my ($self, $reader, $name) = @_;
+
+ 1 while $self->AttDef($reader, $name);
+}
+
+sub AttDef {
+ my ($self, $reader, $el_name) = @_;
+
+ $self->skip_whitespace($reader) || return 0;
+ my $att_name = $self->Name($reader) || return 0;
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after Name in attribute definition", $reader);
+ my $att_type = $self->AttType($reader);
+
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after AttType in attribute definition", $reader);
+ my ($mode, $value) = $self->DefaultDecl($reader);
+
+ # fire SAX event here!
+ $self->attribute_decl({
+ eName => $el_name,
+ aName => $att_name,
+ Type => $att_type,
+ Mode => $mode,
+ Value => $value,
+ });
+ return 1;
+}
+
+sub AttType {
+ my ($self, $reader) = @_;
+
+ return $self->StringType($reader) ||
+ $self->TokenizedType($reader) ||
+ $self->EnumeratedType($reader) ||
+ $self->parser_error("Can't match AttType", $reader);
+}
+
+sub StringType {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(5);
+ return unless $data =~ /^CDATA/;
+ $reader->move_along(5);
+ return 'CDATA';
+}
+
+sub TokenizedType {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(8);
+ if ($data =~ /^(IDREFS?|ID|ENTITIES|ENTITY|NMTOKENS?)/) {
+ $reader->move_along(length($1));
+ return $1;
+ }
+ return;
+}
+
+sub EnumeratedType {
+ my ($self, $reader) = @_;
+ return $self->NotationType($reader) || $self->Enumeration($reader);
+}
+
+sub NotationType {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(8);
+ return unless $data =~ /^NOTATION/;
+ $reader->move_along(8);
+
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after NOTATION", $reader);
+ $reader->match('(') or $self->parser_error("No opening bracket in notation section", $reader);
+
+ $self->skip_whitespace($reader);
+ my $model = 'NOTATION (';
+ my $name = $self->Name($reader) ||
+ $self->parser_error("No name in notation section", $reader);
+ $model .= $name;
+ $self->skip_whitespace($reader);
+ $data = $reader->data;
+ while ($data =~ /^\|/) {
+ $reader->move_along(1);
+ $model .= '|';
+ $self->skip_whitespace($reader);
+ my $name = $self->Name($reader) ||
+ $self->parser_error("No name in notation section", $reader);
+ $model .= $name;
+ $self->skip_whitespace($reader);
+ $data = $reader->data;
+ }
+ $data =~ /^\)/ or $self->parser_error("No closing bracket in notation section", $reader);
+ $reader->move_along(1);
+
+ $model .= ')';
+
+ return $model;
+}
+
+sub Enumeration {
+ my ($self, $reader) = @_;
+
+ return unless $reader->match('(');
+
+ $self->skip_whitespace($reader);
+ my $model = '(';
+ my $nmtoken = $self->Nmtoken($reader) ||
+ $self->parser_error("No Nmtoken in enumerated declaration", $reader);
+ $model .= $nmtoken;
+ $self->skip_whitespace($reader);
+ my $data = $reader->data;
+ while ($data =~ /^\|/) {
+ $model .= '|';
+ $reader->move_along(1);
+ $self->skip_whitespace($reader);
+ my $nmtoken = $self->Nmtoken($reader) ||
+ $self->parser_error("No Nmtoken in enumerated declaration", $reader);
+ $model .= $nmtoken;
+ $self->skip_whitespace($reader);
+ $data = $reader->data;
+ }
+ $data =~ /^\)/ or $self->parser_error("No closing bracket in enumerated declaration", $reader);
+ $reader->move_along(1);
+
+ $model .= ')';
+
+ return $model;
+}
+
+sub Nmtoken {
+ my ($self, $reader) = @_;
+ return $self->Name($reader);
+}
+
+sub DefaultDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(9);
+ if ($data =~ /^(\#REQUIRED|\#IMPLIED)/) {
+ $reader->move_along(length($1));
+ return $1;
+ }
+ my $model = '';
+ if ($data =~ /^\#FIXED/) {
+ $reader->move_along(6);
+ $self->skip_whitespace($reader) || $self->parser_error(
+ "no whitespace after FIXED specifier", $reader);
+ my $value = $self->AttValue($reader);
+ return "#FIXED", $value;
+ }
+ my $value = $self->AttValue($reader);
+ return undef, $value;
+}
+
+sub EntityDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(8);
+ return 0 unless $data =~ /^<!ENTITY/;
+ $reader->move_along(8);
+
+ $self->skip_whitespace($reader) || $self->parser_error(
+ "No whitespace after ENTITY declaration", $reader);
+
+ $self->PEDecl($reader) || $self->GEDecl($reader);
+
+ $self->skip_whitespace($reader);
+
+ $reader->match('>') or $self->parser_error("No closing '>' in entity definition", $reader);
+
+ return 1;
+}
+
+sub GEDecl {
+ my ($self, $reader) = @_;
+
+ my $name = $self->Name($reader) || $self->parser_error("No entity name given", $reader);
+ $self->skip_whitespace($reader) || $self->parser_error("No whitespace after entity name", $reader);
+
+ # TODO: ExternalID calls lexhandler method. Wrong place for it.
+ my $value;
+ if ($value = $self->ExternalID($reader)) {
+ $value .= $self->NDataDecl($reader);
+ }
+ else {
+ $value = $self->EntityValue($reader);
+ }
+
+ if ($self->{ParseOptions}{entities}{$name}) {
+ warn("entity $name already exists\n");
+ } else {
+ $self->{ParseOptions}{entities}{$name} = 1;
+ $self->{ParseOptions}{expanded_entity}{$name} = $value; # ???
+ }
+ # do callback?
+ return 1;
+}
+
+sub PEDecl {
+ my ($self, $reader) = @_;
+
+ return 0 unless $reader->match('%');
+
+ $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity marker", $reader);
+ my $name = $self->Name($reader) || $self->parser_error("No parameter entity name given", $reader);
+ $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity name", $reader);
+ my $value = $self->ExternalID($reader) ||
+ $self->EntityValue($reader) ||
+ $self->parser_error("PE is not a value or an external resource", $reader);
+ # do callback?
+ return 1;
+}
+
+my $quotre = qr/[^%&\"]/;
+my $aposre = qr/[^%&\']/;
+
+sub EntityValue {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data;
+ my $quote = '"';
+ my $re = $quotre;
+ if ($data !~ /^"/) {
+ $data =~ /^'/ or $self->parser_error("Not a quote character", $reader);
+ $quote = "'";
+ $re = $aposre;
+ }
+ $reader->move_along(1);
+
+ my $value = '';
+
+ while (1) {
+ my $data = $reader->data;
+
+ $self->parser_error("EOF found while reading entity value", $reader)
+ unless length($data);
+
+ if ($data =~ /^($re+)/) {
+ my $match = $1;
+ $value .= $match;
+ $reader->move_along(length($match));
+ }
+ elsif ($reader->match('&')) {
+ # if it's a char ref, expand now:
+ if ($reader->match('#')) {
+ my $char;
+ my $ref = '';
+ if ($reader->match('x')) {
+ my $data = $reader->data;
+ while (1) {
+ $self->parser_error("EOF looking for reference end", $reader)
+ unless length($data);
+ if ($data !~ /^([0-9a-fA-F]*)/) {
+ last;
+ }
+ $ref .= $1;
+ $reader->move_along(length($1));
+ if (length($1) == length($data)) {
+ $data = $reader->data;
+ }
+ else {
+ last;
+ }
+ }
+ $char = chr_ref(hex($ref));
+ $ref = "x$ref";
+ }
+ else {
+ my $data = $reader->data;
+ while (1) {
+ $self->parser_error("EOF looking for reference end", $reader)
+ unless length($data);
+ if ($data !~ /^([0-9]*)/) {
+ last;
+ }
+ $ref .= $1;
+ $reader->move_along(length($1));
+ if (length($1) == length($data)) {
+ $data = $reader->data;
+ }
+ else {
+ last;
+ }
+ }
+ $char = chr($ref);
+ }
+ $reader->match(';') ||
+ $self->parser_error("No semi-colon found after character reference", $reader);
+ if ($char !~ $SingleChar) { # match a single character
+ $self->parser_error("Character reference '&#$ref;' refers to an illegal XML character ($char)", $reader);
+ }
+ $value .= $char;
+ }
+ else {
+ # entity refs in entities get expanded later, so don't parse now.
+ $value .= '&';
+ }
+ }
+ elsif ($reader->match('%')) {
+ $value .= $self->PEReference($reader);
+ }
+ elsif ($reader->match($quote)) {
+ # end of attrib
+ last;
+ }
+ else {
+ $self->parser_error("Invalid character in attribute value: " . substr($reader->data, 0, 1), $reader);
+ }
+ }
+
+ return $value;
+}
+
+sub NDataDecl {
+ my ($self, $reader) = @_;
+ $self->skip_whitespace($reader) || return '';
+ my $data = $reader->data(5);
+ return '' unless $data =~ /^NDATA/;
+ $reader->move_along(5);
+ $self->skip_whitespace($reader) || $self->parser_error("No whitespace after NDATA declaration", $reader);
+ my $name = $self->Name($reader) || $self->parser_error("NDATA declaration lacks a proper Name", $reader);
+ return " NDATA $name";
+}
+
+sub NotationDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(10);
+ return 0 unless $data =~ /^<!NOTATION/;
+ $reader->move_along(10);
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after NOTATION declaration", $reader);
+ $data = $reader->data;
+ my $value = '';
+ while(1) {
+ $self->parser_error("EOF found while looking for end of NotationDecl", $reader)
+ unless length($data);
+
+ if ($data =~ /^([^>]*)>/) {
+ $value .= $1;
+ $reader->move_along(length($1) + 1);
+ $self->notation_decl({Name => "FIXME", SystemId => "FIXME", PublicId => "FIXME" });
+ last;
+ }
+ else {
+ $value .= $data;
+ $reader->move_along(length($data));
+ $data = $reader->data;
+ }
+ }
+ return 1;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DebugHandler.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DebugHandler.pm
new file mode 100755
index 00000000000..1afcec28547
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DebugHandler.pm
@@ -0,0 +1,95 @@
+# $Id: DebugHandler.pm,v 1.3 2001-11-24 17:47:53 matt Exp $
+
+package XML::SAX::PurePerl::DebugHandler;
+
+use strict;
+
+sub new {
+ my $class = shift;
+ my %opts = @_;
+ return bless \%opts, $class;
+}
+
+# DocumentHandler
+
+sub set_document_locator {
+ my $self = shift;
+ print "set_document_locator\n" if $ENV{DEBUG_XML};
+ $self->{seen}{set_document_locator}++;
+}
+
+sub start_document {
+ my $self = shift;
+ print "start_document\n" if $ENV{DEBUG_XML};
+ $self->{seen}{start_document}++;
+}
+
+sub end_document {
+ my $self = shift;
+ print "end_document\n" if $ENV{DEBUG_XML};
+ $self->{seen}{end_document}++;
+}
+
+sub start_element {
+ my $self = shift;
+ print "start_element\n" if $ENV{DEBUG_XML};
+ $self->{seen}{start_element}++;
+}
+
+sub end_element {
+ my $self = shift;
+ print "end_element\n" if $ENV{DEBUG_XML};
+ $self->{seen}{end_element}++;
+}
+
+sub characters {
+ my $self = shift;
+ print "characters\n" if $ENV{DEBUG_XML};
+# warn "Char: ", $_[0]->{Data}, "\n";
+ $self->{seen}{characters}++;
+}
+
+sub processing_instruction {
+ my $self = shift;
+ print "processing_instruction\n" if $ENV{DEBUG_XML};
+ $self->{seen}{processing_instruction}++;
+}
+
+sub ignorable_whitespace {
+ my $self = shift;
+ print "ignorable_whitespace\n" if $ENV{DEBUG_XML};
+ $self->{seen}{ignorable_whitespace}++;
+}
+
+# LexHandler
+
+sub comment {
+ my $self = shift;
+ print "comment\n" if $ENV{DEBUG_XML};
+ $self->{seen}{comment}++;
+}
+
+# DTDHandler
+
+sub notation_decl {
+ my $self = shift;
+ print "notation_decl\n" if $ENV{DEBUG_XML};
+ $self->{seen}{notation_decl}++;
+}
+
+sub unparsed_entity_decl {
+ my $self = shift;
+ print "unparsed_entity_decl\n" if $ENV{DEBUG_XML};
+ $self->{seen}{entity_decl}++;
+}
+
+# EntityResolver
+
+sub resolve_entity {
+ my $self = shift;
+ print "resolve_entity\n" if $ENV{DEBUG_XML};
+ $self->{seen}{resolve_entity}++;
+ return '';
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DocType.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DocType.pm
new file mode 100755
index 00000000000..7ec7c9e38bb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/DocType.pm
@@ -0,0 +1,180 @@
+# $Id: DocType.pm,v 1.3 2003-07-30 13:39:22 matt Exp $
+
+package XML::SAX::PurePerl;
+
+use strict;
+use XML::SAX::PurePerl::Productions qw($PubidChar);
+
+sub doctypedecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(9);
+ if ($data =~ /^<!DOCTYPE/) {
+ $reader->move_along(9);
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after doctype declaration", $reader);
+
+ my $root_name = $self->Name($reader) ||
+ $self->parser_error("Doctype declaration has no root element name", $reader);
+
+ if ($self->skip_whitespace($reader)) {
+ # might be externalid...
+ my %dtd = $self->ExternalID($reader);
+ # TODO: Call SAX event
+ }
+
+ $self->skip_whitespace($reader);
+
+ $self->InternalSubset($reader);
+
+ $reader->match('>') or $self->parser_error("Doctype not closed", $reader);
+
+ return 1;
+ }
+
+ return 0;
+}
+
+sub ExternalID {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(6);
+
+ if ($data =~ /^SYSTEM/) {
+ $reader->move_along(6);
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after SYSTEM identifier", $reader);
+ return (SYSTEM => $self->SystemLiteral($reader));
+ }
+ elsif ($data =~ /^PUBLIC/) {
+ $reader->move_along(6);
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("No whitespace after PUBLIC identifier", $reader);
+
+ my $quote = $self->quote($reader) ||
+ $self->parser_error("Not a quote character in PUBLIC identifier", $reader);
+
+ my $data = $reader->data;
+ my $pubid = '';
+ while(1) {
+ $self->parser_error("EOF while looking for end of PUBLIC identifiier", $reader)
+ unless length($data);
+
+ if ($data =~ /^([^$quote]*)$quote/) {
+ $pubid .= $1;
+ $reader->move_along(length($1) + 1);
+ last;
+ }
+ else {
+ $pubid .= $data;
+ $reader->move_along(length($data));
+ $data = $reader->data;
+ }
+ }
+
+ if ($pubid !~ /^($PubidChar)+$/) {
+ $self->parser_error("Invalid characters in PUBLIC identifier", $reader);
+ }
+
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("Not whitespace after PUBLIC ID in DOCTYPE", $reader);
+
+ return (PUBLIC => $pubid,
+ SYSTEM => $self->SystemLiteral($reader));
+ }
+ else {
+ return;
+ }
+
+ return 1;
+}
+
+sub SystemLiteral {
+ my ($self, $reader) = @_;
+
+ my $quote = $self->quote($reader);
+
+ my $data = $reader->data;
+ my $systemid = '';
+ while (1) {
+ $self->parser_error("EOF found while looking for end of Sytem Literal", $reader)
+ unless length($data);
+ if ($data =~ /^([^$quote]*)$quote/) {
+ $systemid .= $1;
+ $reader->move_along(length($1) + 1);
+ return $systemid;
+ }
+ else {
+ $systemid .= $data;
+ $reader->move_along(length($data));
+ $data = $reader->data;
+ }
+ }
+}
+
+sub InternalSubset {
+ my ($self, $reader) = @_;
+
+ return 0 unless $reader->match('[');
+
+ 1 while $self->IntSubsetDecl($reader);
+
+ $reader->match(']') or $self->parser_error("No close bracket on internal subset (found: " . $reader->data, $reader);
+ $self->skip_whitespace($reader);
+ return 1;
+}
+
+sub IntSubsetDecl {
+ my ($self, $reader) = @_;
+
+ return $self->DeclSep($reader) || $self->markupdecl($reader);
+}
+
+sub DeclSep {
+ my ($self, $reader) = @_;
+
+ if ($self->skip_whitespace($reader)) {
+ return 1;
+ }
+
+ if ($self->PEReference($reader)) {
+ return 1;
+ }
+
+# if ($self->ParsedExtSubset($reader)) {
+# return 1;
+# }
+
+ return 0;
+}
+
+sub PEReference {
+ my ($self, $reader) = @_;
+
+ return 0 unless $reader->match('%');
+
+ my $peref = $self->Name($reader) ||
+ $self->parser_error("PEReference did not find a Name", $reader);
+ # TODO - load/parse the peref
+
+ $reader->match(';') or $self->parser_error("Invalid token in PEReference", $reader);
+ return 1;
+}
+
+sub markupdecl {
+ my ($self, $reader) = @_;
+
+ if ($self->elementdecl($reader) ||
+ $self->AttlistDecl($reader) ||
+ $self->EntityDecl($reader) ||
+ $self->NotationDecl($reader) ||
+ $self->PI($reader) ||
+ $self->Comment($reader))
+ {
+ return 1;
+ }
+
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/EncodingDetect.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/EncodingDetect.pm
new file mode 100755
index 00000000000..6f1c8eadcbd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/EncodingDetect.pm
@@ -0,0 +1,105 @@
+# $Id: EncodingDetect.pm,v 1.6 2007-02-07 09:33:50 grant Exp $
+
+package XML::SAX::PurePerl; # NB, not ::EncodingDetect!
+
+use strict;
+
+sub encoding_detect {
+ my ($parser, $reader) = @_;
+
+ my $error = "Invalid byte sequence at start of file";
+
+ my $data = $reader->data;
+ if ($data =~ /^\x00\x00\xFE\xFF/) {
+ # BO-UCS4-be
+ $reader->move_along(4);
+ $reader->set_encoding('UCS-4BE');
+ return;
+ }
+ elsif ($data =~ /^\x00\x00\xFF\xFE/) {
+ # BO-UCS-4-2143
+ $reader->move_along(4);
+ $reader->set_encoding('UCS-4-2143');
+ return;
+ }
+ elsif ($data =~ /^\x00\x00\x00\x3C/) {
+ $reader->set_encoding('UCS-4BE');
+ return;
+ }
+ elsif ($data =~ /^\x00\x00\x3C\x00/) {
+ $reader->set_encoding('UCS-4-2143');
+ return;
+ }
+ elsif ($data =~ /^\x00\x3C\x00\x00/) {
+ $reader->set_encoding('UCS-4-3412');
+ return;
+ }
+ elsif ($data =~ /^\x00\x3C\x00\x3F/) {
+ $reader->set_encoding('UTF-16BE');
+ return;
+ }
+ elsif ($data =~ /^\xFF\xFE\x00\x00/) {
+ # BO-UCS-4LE
+ $reader->move_along(4);
+ $reader->set_encoding('UCS-4LE');
+ return;
+ }
+ elsif ($data =~ /^\xFF\xFE/) {
+ $reader->move_along(2);
+ $reader->set_encoding('UTF-16LE');
+ return;
+ }
+ elsif ($data =~ /^\xFE\xFF\x00\x00/) {
+ $reader->move_along(4);
+ $reader->set_encoding('UCS-4-3412');
+ return;
+ }
+ elsif ($data =~ /^\xFE\xFF/) {
+ $reader->move_along(2);
+ $reader->set_encoding('UTF-16BE');
+ return;
+ }
+ elsif ($data =~ /^\xEF\xBB\xBF/) { # UTF-8 BOM
+ $reader->move_along(3);
+ $reader->set_encoding('UTF-8');
+ return;
+ }
+ elsif ($data =~ /^\x3C\x00\x00\x00/) {
+ $reader->set_encoding('UCS-4LE');
+ return;
+ }
+ elsif ($data =~ /^\x3C\x00\x3F\x00/) {
+ $reader->set_encoding('UTF-16LE');
+ return;
+ }
+ elsif ($data =~ /^\x3C\x3F\x78\x6D/) {
+ # $reader->set_encoding('UTF-8');
+ return;
+ }
+ elsif ($data =~ /^\x3C\x3F\x78/) {
+ # $reader->set_encoding('UTF-8');
+ return;
+ }
+ elsif ($data =~ /^\x3C\x3F/) {
+ # $reader->set_encoding('UTF-8');
+ return;
+ }
+ elsif ($data =~ /^\x3C/) {
+ # $reader->set_encoding('UTF-8');
+ return;
+ }
+ elsif ($data =~ /^[\x20\x09\x0A\x0D]+\x3C[^\x3F]/) {
+ # $reader->set_encoding('UTF-8');
+ return;
+ }
+ elsif ($data =~ /^\x4C\x6F\xA7\x94/) {
+ $reader->set_encoding('EBCDIC');
+ return;
+ }
+
+ warn("Unable to recognise encoding of this document");
+ return;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Exception.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Exception.pm
new file mode 100755
index 00000000000..6a0d1b6b524
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Exception.pm
@@ -0,0 +1,67 @@
+# $Id: Exception.pm,v 1.2 2001-11-14 11:07:25 matt Exp $
+
+package XML::SAX::PurePerl::Exception;
+
+use strict;
+
+use overload '""' => "stringify";
+
+use vars qw/$StackTrace/;
+
+$StackTrace = $ENV{XML_DEBUG} || 0;
+
+sub throw {
+ my $class = shift;
+ die $class->new(@_);
+}
+
+sub new {
+ my $class = shift;
+ my %opts = @_;
+ die "Invalid options" unless exists $opts{Message};
+
+ if ($opts{reader}) {
+ return bless { Message => $opts{Message},
+ Exception => undef, # not sure what this is for!!!
+ ColumnNumber => $opts{reader}->column,
+ LineNumber => $opts{reader}->line,
+ PublicId => $opts{reader}->public_id,
+ SystemId => $opts{reader}->system_id,
+ $StackTrace ? (StackTrace => stacktrace()) : (),
+ }, $class;
+ }
+ return bless { Message => $opts{Message},
+ Exception => undef, # not sure what this is for!!!
+ }, $class;
+}
+
+sub stringify {
+ my $self = shift;
+ local $^W;
+ return $self->{Message} . " [Ln: " . $self->{LineNumber} .
+ ", Col: " . $self->{ColumnNumber} . "]" .
+ ($StackTrace ? stackstring($self->{StackTrace}) : "") . "\n";
+}
+
+sub stacktrace {
+ my $i = 2;
+ my @fulltrace;
+ while (my @trace = caller($i++)) {
+ my %hash;
+ @hash{qw(Package Filename Line)} = @trace[0..2];
+ push @fulltrace, \%hash;
+ }
+ return \@fulltrace;
+}
+
+sub stackstring {
+ my $stacktrace = shift;
+ my $string = "\nFrom:\n";
+ foreach my $current (@$stacktrace) {
+ $string .= $current->{Filename} . " Line: " . $current->{Line} . "\n";
+ }
+ return $string;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/NoUnicodeExt.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/NoUnicodeExt.pm
new file mode 100755
index 00000000000..334e52bee76
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/NoUnicodeExt.pm
@@ -0,0 +1,28 @@
+# $Id: NoUnicodeExt.pm,v 1.1 2002-01-30 17:35:21 matt Exp $
+
+package XML::SAX::PurePerl;
+use strict;
+
+sub chr_ref {
+ my $n = shift;
+ if ($n < 0x80) {
+ return chr ($n);
+ }
+ elsif ($n < 0x800) {
+ return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));
+ }
+ elsif ($n < 0x10000) {
+ return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),
+ (($n & 0x3f) | 0x80));
+ }
+ elsif ($n < 0x110000)
+ {
+ return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),
+ ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));
+ }
+ else {
+ return undef;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Productions.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Productions.pm
new file mode 100755
index 00000000000..3060960b79f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Productions.pm
@@ -0,0 +1,147 @@
+# $Id: Productions.pm,v 1.13 2008-08-05 12:37:13 grant Exp $
+
+package XML::SAX::PurePerl::Productions;
+
+use Exporter;
+@ISA = ('Exporter');
+@EXPORT_OK = qw($S $Char $VersionNum $BaseChar $Ideographic
+ $Extender $Digit $CombiningChar $EncNameStart $EncNameEnd $NameChar $CharMinusDash
+ $PubidChar $Any $SingleChar);
+
+### WARNING!!! All productions here must *only* match a *single* character!!! ###
+
+BEGIN {
+$S = qr/[\x20\x09\x0D\x0A]/;
+
+$CharMinusDash = qr/[^-]/x;
+
+$Any = qr/ . /xms;
+
+$VersionNum = qr/ [a-zA-Z0-9_.:-]+ /x;
+
+$EncNameStart = qr/ [A-Za-z] /x;
+$EncNameEnd = qr/ [A-Za-z0-9\._-] /x;
+
+$PubidChar = qr/ [\x20\x0D\x0Aa-zA-Z0-9'()\+,.\/:=\?;!*\#@\$_\%-] /x;
+
+if ($] < 5.006) {
+ eval <<' PERL';
+ $Char = qr/^ [\x09\x0A\x0D\x20-\x7F]|([\xC0-\xFD][\x80-\xBF]+) $/x;
+
+ $SingleChar = qr/^$Char$/;
+
+ $BaseChar = qr/ [\x41-\x5A\x61-\x7A]|([\xC0-\xFD][\x80-\xBF]+) /x;
+
+ $Extender = qr/ \xB7 /x;
+
+ $Digit = qr/ [\x30-\x39] /x;
+
+ # can't do this one without unicode
+ # $CombiningChar = qr/^$/msx;
+
+ $NameChar = qr/^ (?: $BaseChar | $Digit | [._:-] | $Extender )+ $/x;
+ PERL
+ die $@ if $@;
+}
+else {
+ eval <<' PERL';
+
+ use utf8; # for 5.6
+
+ $Char = qr/^ [\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}] $/x;
+
+ $SingleChar = qr/^$Char$/;
+
+ $BaseChar = qr/
+[\x{0041}-\x{005A}\x{0061}-\x{007A}\x{00C0}-\x{00D6}\x{00D8}-\x{00F6}] |
+[\x{00F8}-\x{00FF}\x{0100}-\x{0131}\x{0134}-\x{013E}\x{0141}-\x{0148}] |
+[\x{014A}-\x{017E}\x{0180}-\x{01C3}\x{01CD}-\x{01F0}\x{01F4}-\x{01F5}] |
+[\x{01FA}-\x{0217}\x{0250}-\x{02A8}\x{02BB}-\x{02C1}\x{0386}\x{0388}-\x{038A}] |
+[\x{038C}\x{038E}-\x{03A1}\x{03A3}-\x{03CE}\x{03D0}-\x{03D6}\x{03DA}] |
+[\x{03DC}\x{03DE}\x{03E0}\x{03E2}-\x{03F3}\x{0401}-\x{040C}\x{040E}-\x{044F}] |
+[\x{0451}-\x{045C}\x{045E}-\x{0481}\x{0490}-\x{04C4}\x{04C7}-\x{04C8}] |
+[\x{04CB}-\x{04CC}\x{04D0}-\x{04EB}\x{04EE}-\x{04F5}\x{04F8}-\x{04F9}] |
+[\x{0531}-\x{0556}\x{0559}\x{0561}-\x{0586}\x{05D0}-\x{05EA}\x{05F0}-\x{05F2}] |
+[\x{0621}-\x{063A}\x{0641}-\x{064A}\x{0671}-\x{06B7}\x{06BA}-\x{06BE}] |
+[\x{06C0}-\x{06CE}\x{06D0}-\x{06D3}\x{06D5}\x{06E5}-\x{06E6}\x{0905}-\x{0939}] |
+[\x{093D}\x{0958}-\x{0961}\x{0985}-\x{098C}\x{098F}-\x{0990}] |
+[\x{0993}-\x{09A8}\x{09AA}-\x{09B0}\x{09B2}\x{09B6}-\x{09B9}\x{09DC}-\x{09DD}] |
+[\x{09DF}-\x{09E1}\x{09F0}-\x{09F1}\x{0A05}-\x{0A0A}\x{0A0F}-\x{0A10}] |
+[\x{0A13}-\x{0A28}\x{0A2A}-\x{0A30}\x{0A32}-\x{0A33}\x{0A35}-\x{0A36}] |
+[\x{0A38}-\x{0A39}\x{0A59}-\x{0A5C}\x{0A5E}\x{0A72}-\x{0A74}\x{0A85}-\x{0A8B}] |
+[\x{0A8D}\x{0A8F}-\x{0A91}\x{0A93}-\x{0AA8}\x{0AAA}-\x{0AB0}] |
+[\x{0AB2}-\x{0AB3}\x{0AB5}-\x{0AB9}\x{0ABD}\x{0AE0}\x{0B05}-\x{0B0C}] |
+[\x{0B0F}-\x{0B10}\x{0B13}-\x{0B28}\x{0B2A}-\x{0B30}\x{0B32}-\x{0B33}] |
+[\x{0B36}-\x{0B39}\x{0B3D}\x{0B5C}-\x{0B5D}\x{0B5F}-\x{0B61}\x{0B85}-\x{0B8A}] |
+[\x{0B8E}-\x{0B90}\x{0B92}-\x{0B95}\x{0B99}-\x{0B9A}\x{0B9C}] |
+[\x{0B9E}-\x{0B9F}\x{0BA3}-\x{0BA4}\x{0BA8}-\x{0BAA}\x{0BAE}-\x{0BB5}] |
+[\x{0BB7}-\x{0BB9}\x{0C05}-\x{0C0C}\x{0C0E}-\x{0C10}\x{0C12}-\x{0C28}] |
+[\x{0C2A}-\x{0C33}\x{0C35}-\x{0C39}\x{0C60}-\x{0C61}\x{0C85}-\x{0C8C}] |
+[\x{0C8E}-\x{0C90}\x{0C92}-\x{0CA8}\x{0CAA}-\x{0CB3}\x{0CB5}-\x{0CB9}\x{0CDE}] |
+[\x{0CE0}-\x{0CE1}\x{0D05}-\x{0D0C}\x{0D0E}-\x{0D10}\x{0D12}-\x{0D28}] |
+[\x{0D2A}-\x{0D39}\x{0D60}-\x{0D61}\x{0E01}-\x{0E2E}\x{0E30}\x{0E32}-\x{0E33}] |
+[\x{0E40}-\x{0E45}\x{0E81}-\x{0E82}\x{0E84}\x{0E87}-\x{0E88}\x{0E8A}] |
+[\x{0E8D}\x{0E94}-\x{0E97}\x{0E99}-\x{0E9F}\x{0EA1}-\x{0EA3}\x{0EA5}\x{0EA7}] |
+[\x{0EAA}-\x{0EAB}\x{0EAD}-\x{0EAE}\x{0EB0}\x{0EB2}-\x{0EB3}\x{0EBD}] |
+[\x{0EC0}-\x{0EC4}\x{0F40}-\x{0F47}\x{0F49}-\x{0F69}\x{10A0}-\x{10C5}] |
+[\x{10D0}-\x{10F6}\x{1100}\x{1102}-\x{1103}\x{1105}-\x{1107}\x{1109}] |
+[\x{110B}-\x{110C}\x{110E}-\x{1112}\x{113C}\x{113E}\x{1140}\x{114C}\x{114E}] |
+[\x{1150}\x{1154}-\x{1155}\x{1159}\x{115F}-\x{1161}\x{1163}\x{1165}] |
+[\x{1167}\x{1169}\x{116D}-\x{116E}\x{1172}-\x{1173}\x{1175}\x{119E}\x{11A8}] |
+[\x{11AB}\x{11AE}-\x{11AF}\x{11B7}-\x{11B8}\x{11BA}\x{11BC}-\x{11C2}] |
+[\x{11EB}\x{11F0}\x{11F9}\x{1E00}-\x{1E9B}\x{1EA0}-\x{1EF9}\x{1F00}-\x{1F15}] |
+[\x{1F18}-\x{1F1D}\x{1F20}-\x{1F45}\x{1F48}-\x{1F4D}\x{1F50}-\x{1F57}] |
+[\x{1F59}\x{1F5B}\x{1F5D}\x{1F5F}-\x{1F7D}\x{1F80}-\x{1FB4}\x{1FB6}-\x{1FBC}] |
+[\x{1FBE}\x{1FC2}-\x{1FC4}\x{1FC6}-\x{1FCC}\x{1FD0}-\x{1FD3}] |
+[\x{1FD6}-\x{1FDB}\x{1FE0}-\x{1FEC}\x{1FF2}-\x{1FF4}\x{1FF6}-\x{1FFC}] |
+[\x{2126}\x{212A}-\x{212B}\x{212E}\x{2180}-\x{2182}\x{3041}-\x{3094}] |
+[\x{30A1}-\x{30FA}\x{3105}-\x{312C}\x{AC00}-\x{D7A3}]
+ /x;
+
+ $Extender = qr/
+[\x{00B7}\x{02D0}\x{02D1}\x{0387}\x{0640}\x{0E46}\x{0EC6}\x{3005}\x{3031}-\x{3035}\x{309D}-\x{309E}\x{30FC}-\x{30FE}]
+/x;
+
+ $Digit = qr/
+[\x{0030}-\x{0039}\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{0966}-\x{096F}] |
+[\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}] |
+[\x{0BE7}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}] |
+[\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}]
+/x;
+
+ $CombiningChar = qr/
+[\x{0300}-\x{0345}\x{0360}-\x{0361}\x{0483}-\x{0486}\x{0591}-\x{05A1}] |
+[\x{05A3}-\x{05B9}\x{05BB}-\x{05BD}\x{05BF}\x{05C1}-\x{05C2}\x{05C4}] |
+[\x{064B}-\x{0652}\x{0670}\x{06D6}-\x{06DC}\x{06DD}-\x{06DF}\x{06E0}-\x{06E4}] |
+[\x{06E7}-\x{06E8}\x{06EA}-\x{06ED}\x{0901}-\x{0903}\x{093C}] |
+[\x{093E}-\x{094C}\x{094D}\x{0951}-\x{0954}\x{0962}-\x{0963}\x{0981}-\x{0983}] |
+[\x{09BC}\x{09BE}\x{09BF}\x{09C0}-\x{09C4}\x{09C7}-\x{09C8}] |
+[\x{09CB}-\x{09CD}\x{09D7}\x{09E2}-\x{09E3}\x{0A02}\x{0A3C}\x{0A3E}\x{0A3F}] |
+[\x{0A40}-\x{0A42}\x{0A47}-\x{0A48}\x{0A4B}-\x{0A4D}\x{0A70}-\x{0A71}] |
+[\x{0A81}-\x{0A83}\x{0ABC}\x{0ABE}-\x{0AC5}\x{0AC7}-\x{0AC9}\x{0ACB}-\x{0ACD}] |
+[\x{0B01}-\x{0B03}\x{0B3C}\x{0B3E}-\x{0B43}\x{0B47}-\x{0B48}] |
+[\x{0B4B}-\x{0B4D}\x{0B56}-\x{0B57}\x{0B82}-\x{0B83}\x{0BBE}-\x{0BC2}] |
+[\x{0BC6}-\x{0BC8}\x{0BCA}-\x{0BCD}\x{0BD7}\x{0C01}-\x{0C03}\x{0C3E}-\x{0C44}] |
+[\x{0C46}-\x{0C48}\x{0C4A}-\x{0C4D}\x{0C55}-\x{0C56}\x{0C82}-\x{0C83}] |
+[\x{0CBE}-\x{0CC4}\x{0CC6}-\x{0CC8}\x{0CCA}-\x{0CCD}\x{0CD5}-\x{0CD6}] |
+[\x{0D02}-\x{0D03}\x{0D3E}-\x{0D43}\x{0D46}-\x{0D48}\x{0D4A}-\x{0D4D}\x{0D57}] |
+[\x{0E31}\x{0E34}-\x{0E3A}\x{0E47}-\x{0E4E}\x{0EB1}\x{0EB4}-\x{0EB9}] |
+[\x{0EBB}-\x{0EBC}\x{0EC8}-\x{0ECD}\x{0F18}-\x{0F19}\x{0F35}\x{0F37}\x{0F39}] |
+[\x{0F3E}\x{0F3F}\x{0F71}-\x{0F84}\x{0F86}-\x{0F8B}\x{0F90}-\x{0F95}] |
+[\x{0F97}\x{0F99}-\x{0FAD}\x{0FB1}-\x{0FB7}\x{0FB9}\x{20D0}-\x{20DC}\x{20E1}] |
+[\x{302A}-\x{302F}\x{3099}\x{309A}]
+/x;
+
+ $Ideographic = qr/
+[\x{4E00}-\x{9FA5}\x{3007}\x{3021}-\x{3029}]
+/x;
+
+ $NameChar = qr/^ (?: $BaseChar | $Ideographic | $Digit | [._:-] | $CombiningChar | $Extender )+ $/x;
+ PERL
+
+ die $@ if $@;
+}
+
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader.pm
new file mode 100755
index 00000000000..d901e7d2f50
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader.pm
@@ -0,0 +1,136 @@
+# $Id: Reader.pm,v 1.13 2008-08-05 12:37:13 grant Exp $
+
+package XML::SAX::PurePerl::Reader;
+
+use strict;
+use XML::SAX::PurePerl::Reader::URI;
+use Exporter ();
+
+use vars qw(@ISA @EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(
+ EOF
+ BUFFER
+ LINE
+ COLUMN
+ ENCODING
+ XML_VERSION
+);
+
+use constant EOF => 0;
+use constant BUFFER => 1;
+use constant LINE => 2;
+use constant COLUMN => 3;
+use constant ENCODING => 4;
+use constant SYSTEM_ID => 5;
+use constant PUBLIC_ID => 6;
+use constant XML_VERSION => 7;
+
+require XML::SAX::PurePerl::Reader::Stream;
+require XML::SAX::PurePerl::Reader::String;
+
+if ($] >= 5.007002) {
+ require XML::SAX::PurePerl::Reader::UnicodeExt;
+}
+else {
+ require XML::SAX::PurePerl::Reader::NoUnicodeExt;
+}
+
+sub new {
+ my $class = shift;
+ my $thing = shift;
+
+ # try to figure if this $thing is a handle of some sort
+ if (ref($thing) && UNIVERSAL::isa($thing, 'IO::Handle')) {
+ return XML::SAX::PurePerl::Reader::Stream->new($thing)->init;
+ }
+ my $ioref;
+ if (tied($thing)) {
+ my $class = ref($thing);
+ no strict 'refs';
+ $ioref = $thing if defined &{"${class}::TIEHANDLE"};
+ }
+ else {
+ eval {
+ $ioref = *{$thing}{IO};
+ };
+ undef $@;
+ }
+ if ($ioref) {
+ return XML::SAX::PurePerl::Reader::Stream->new($thing)->init;
+ }
+
+ if ($thing =~ /</) {
+ # assume it's a string
+ return XML::SAX::PurePerl::Reader::String->new($thing)->init;
+ }
+
+ # assume it is a uri
+ return XML::SAX::PurePerl::Reader::URI->new($thing)->init;
+}
+
+sub init {
+ my $self = shift;
+ $self->[LINE] = 1;
+ $self->[COLUMN] = 1;
+ $self->read_more;
+ return $self;
+}
+
+sub data {
+ my ($self, $min_length) = (@_, 1);
+ if (length($self->[BUFFER]) < $min_length) {
+ $self->read_more;
+ }
+ return $self->[BUFFER];
+}
+
+sub match {
+ my ($self, $char) = @_;
+ my $data = $self->data;
+ if (substr($data, 0, 1) eq $char) {
+ $self->move_along(1);
+ return 1;
+ }
+ return 0;
+}
+
+sub public_id {
+ my $self = shift;
+ @_ and $self->[PUBLIC_ID] = shift;
+ $self->[PUBLIC_ID];
+}
+
+sub system_id {
+ my $self = shift;
+ @_ and $self->[SYSTEM_ID] = shift;
+ $self->[SYSTEM_ID];
+}
+
+sub line {
+ shift->[LINE];
+}
+
+sub column {
+ shift->[COLUMN];
+}
+
+sub get_encoding {
+ my $self = shift;
+ return $self->[ENCODING];
+}
+
+sub get_xml_version {
+ my $self = shift;
+ return $self->[XML_VERSION];
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::Parser::PurePerl::Reader - Abstract Reader factory class
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm
new file mode 100755
index 00000000000..d551710d0d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm
@@ -0,0 +1,25 @@
+# $Id: NoUnicodeExt.pm,v 1.3 2003-07-30 13:39:23 matt Exp $
+
+package XML::SAX::PurePerl::Reader;
+use strict;
+
+sub set_raw_stream {
+ # no-op
+}
+
+sub switch_encoding_stream {
+ my ($fh, $encoding) = @_;
+ throw XML::SAX::Exception::Parse (
+ Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding",
+ ) if $encoding !~ /(ASCII|UTF\-?8)/i;
+}
+
+sub switch_encoding_string {
+ my (undef, $encoding) = @_;
+ throw XML::SAX::Exception::Parse (
+ Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding",
+ ) if $encoding !~ /(ASCII|UTF\-?8)/i;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/Stream.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/Stream.pm
new file mode 100755
index 00000000000..794aac4d4d1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/Stream.pm
@@ -0,0 +1,84 @@
+# $Id: Stream.pm,v 1.7 2005-10-14 20:31:20 matt Exp $
+
+package XML::SAX::PurePerl::Reader::Stream;
+
+use strict;
+use vars qw(@ISA);
+
+use XML::SAX::PurePerl::Reader qw(
+ EOF
+ BUFFER
+ LINE
+ COLUMN
+ ENCODING
+ XML_VERSION
+);
+use XML::SAX::Exception;
+
+@ISA = ('XML::SAX::PurePerl::Reader');
+
+# subclassed by adding 1 to last element
+use constant FH => 8;
+use constant BUFFER_SIZE => 4096;
+
+sub new {
+ my $class = shift;
+ my $ioref = shift;
+ XML::SAX::PurePerl::Reader::set_raw_stream($ioref);
+ my @parts;
+ @parts[FH, LINE, COLUMN, BUFFER, EOF, XML_VERSION] =
+ ($ioref, 1, 0, '', 0, '1.0');
+ return bless \@parts, $class;
+}
+
+sub read_more {
+ my $self = shift;
+ my $buf;
+ my $bytesread = read($self->[FH], $buf, BUFFER_SIZE);
+ if ($bytesread) {
+ $self->[BUFFER] .= $buf;
+ return 1;
+ }
+ elsif (defined($bytesread)) {
+ $self->[EOF]++;
+ return 0;
+ }
+ else {
+ throw XML::SAX::Exception::Parse(
+ Message => "Error reading from filehandle: $!",
+ );
+ }
+}
+
+sub move_along {
+ my $self = shift;
+ my $discarded = substr($self->[BUFFER], 0, $_[0], '');
+
+ # Wish I could skip this lot - tells us where we are in the file
+ my $lines = $discarded =~ tr/\n//;
+ $self->[LINE] += $lines;
+ if ($lines) {
+ $discarded =~ /\n([^\n]*)$/;
+ $self->[COLUMN] = length($1);
+ }
+ else {
+ $self->[COLUMN] += $_[0];
+ }
+}
+
+sub set_encoding {
+ my $self = shift;
+ my ($encoding) = @_;
+ # warn("set encoding to: $encoding\n");
+ XML::SAX::PurePerl::Reader::switch_encoding_stream($self->[FH], $encoding);
+ XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding);
+ $self->[ENCODING] = $encoding;
+}
+
+sub bytepos {
+ my $self = shift;
+ tell($self->[FH]);
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/String.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/String.pm
new file mode 100755
index 00000000000..62b5d0bfb0f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/String.pm
@@ -0,0 +1,78 @@
+# $Id: String.pm,v 1.6 2008-08-04 03:35:44 grant Exp $
+
+package XML::SAX::PurePerl::Reader::String;
+
+use strict;
+use vars qw(@ISA);
+
+use XML::SAX::PurePerl::Reader qw(
+ LINE
+ COLUMN
+ BUFFER
+ ENCODING
+ EOF
+);
+
+@ISA = ('XML::SAX::PurePerl::Reader');
+
+use constant DISCARDED => 8;
+use constant STRING => 9;
+use constant USED => 10;
+use constant CHUNK_SIZE => 2048;
+
+sub new {
+ my $class = shift;
+ my $string = shift;
+ my @parts;
+ @parts[BUFFER, EOF, LINE, COLUMN, DISCARDED, STRING, USED] =
+ ('', 0, 1, 0, 0, $string, 0);
+ return bless \@parts, $class;
+}
+
+sub read_more () {
+ my $self = shift;
+ if ($self->[USED] >= length($self->[STRING])) {
+ $self->[EOF]++;
+ return 0;
+ }
+ my $bytes = CHUNK_SIZE;
+ if ($bytes > (length($self->[STRING]) - $self->[USED])) {
+ $bytes = (length($self->[STRING]) - $self->[USED]);
+ }
+ $self->[BUFFER] .= substr($self->[STRING], $self->[USED], $bytes);
+ $self->[USED] += $bytes;
+ return 1;
+ }
+
+
+sub move_along {
+ my($self, $bytes) = @_;
+ my $discarded = substr($self->[BUFFER], 0, $bytes, '');
+ $self->[DISCARDED] += length($discarded);
+
+ # Wish I could skip this lot - tells us where we are in the file
+ my $lines = $discarded =~ tr/\n//;
+ $self->[LINE] += $lines;
+ if ($lines) {
+ $discarded =~ /\n([^\n]*)$/;
+ $self->[COLUMN] = length($1);
+ }
+ else {
+ $self->[COLUMN] += $_[0];
+ }
+}
+
+sub set_encoding {
+ my $self = shift;
+ my ($encoding) = @_;
+
+ XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding, "utf-8");
+ $self->[ENCODING] = $encoding;
+}
+
+sub bytepos {
+ my $self = shift;
+ $self->[DISCARDED];
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/URI.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/URI.pm
new file mode 100755
index 00000000000..20c92d6c627
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/URI.pm
@@ -0,0 +1,57 @@
+# $Id: URI.pm,v 1.1 2001-11-11 18:41:51 matt Exp $
+
+package XML::SAX::PurePerl::Reader::URI;
+
+use strict;
+
+use XML::SAX::PurePerl::Reader;
+use File::Temp qw(tempfile);
+use Symbol;
+
+## NOTE: This is *not* a subclass of Reader. It just returns Stream or String
+## Reader objects depending on what it's capabilities are.
+
+sub new {
+ my $class = shift;
+ my $uri = shift;
+ # request the URI
+ if (-e $uri && -f _) {
+ my $fh = gensym;
+ open($fh, $uri) || die "Cannot open file $uri : $!";
+ return XML::SAX::PurePerl::Reader::Stream->new($fh);
+ }
+ elsif ($uri =~ /^file:(.*)$/ && -e $1 && -f _) {
+ my $file = $1;
+ my $fh = gensym;
+ open($fh, $file) || die "Cannot open file $file : $!";
+ return XML::SAX::PurePerl::Reader::Stream->new($fh);
+ }
+ else {
+ # request URI, return String reader
+ require LWP::UserAgent;
+ my $ua = LWP::UserAgent->new;
+ $ua->agent("Perl/XML/SAX/PurePerl/1.0 " . $ua->agent);
+
+ my $req = HTTP::Request->new(GET => $uri);
+
+ my $fh = tempfile();
+
+ my $callback = sub {
+ my ($data, $response, $protocol) = @_;
+ print $fh $data;
+ };
+
+ my $res = $ua->request($req, $callback, 4096);
+
+ if ($res->is_success) {
+ seek($fh, 0, 0);
+ return XML::SAX::PurePerl::Reader::Stream->new($fh);
+ }
+ else {
+ die "LWP Request Failed";
+ }
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/UnicodeExt.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/UnicodeExt.pm
new file mode 100755
index 00000000000..07510683712
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/Reader/UnicodeExt.pm
@@ -0,0 +1,23 @@
+# $Id: UnicodeExt.pm,v 1.5 2008-08-04 10:04:54 grant Exp $
+
+package XML::SAX::PurePerl::Reader;
+use strict;
+
+use Encode ();
+
+sub set_raw_stream {
+ my ($fh) = @_;
+ binmode($fh, ":bytes");
+}
+
+sub switch_encoding_stream {
+ my ($fh, $encoding) = @_;
+ binmode($fh, ":encoding($encoding)");
+}
+
+sub switch_encoding_string {
+ $_[0] = Encode::decode($_[1], $_[0]);
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/UnicodeExt.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/UnicodeExt.pm
new file mode 100755
index 00000000000..cbfe4e83f49
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/UnicodeExt.pm
@@ -0,0 +1,22 @@
+# $Id: UnicodeExt.pm,v 1.1 2002-01-30 17:35:21 matt Exp $
+
+package XML::SAX::PurePerl;
+use strict;
+
+no warnings 'utf8';
+
+sub chr_ref {
+ return chr(shift);
+}
+
+if ($] >= 5.007002) {
+ require Encode;
+
+ Encode::define_alias( "UTF-16" => "UCS-2" );
+ Encode::define_alias( "UTF-16BE" => "UCS-2" );
+ Encode::define_alias( "UTF-16LE" => "ucs-2le" );
+ Encode::define_alias( "UTF16LE" => "ucs-2le" );
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/XMLDecl.pm b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/XMLDecl.pm
new file mode 100755
index 00000000000..4672c20a757
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/PurePerl/XMLDecl.pm
@@ -0,0 +1,129 @@
+# $Id: XMLDecl.pm,v 1.3 2003-07-30 13:39:22 matt Exp $
+
+package XML::SAX::PurePerl;
+
+use strict;
+use XML::SAX::PurePerl::Productions qw($S $VersionNum $EncNameStart $EncNameEnd);
+
+sub XMLDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(5);
+ # warn("Looking for xmldecl in: $data");
+ if ($data =~ /^<\?xml$S/o) {
+ $reader->move_along(5);
+ $self->skip_whitespace($reader);
+
+ # get version attribute
+ $self->VersionInfo($reader) ||
+ $self->parser_error("XML Declaration lacks required version attribute, or version attribute does not match XML specification", $reader);
+
+ if (!$self->skip_whitespace($reader)) {
+ my $data = $reader->data(2);
+ $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
+ $reader->move_along(2);
+ return;
+ }
+
+ if ($self->EncodingDecl($reader)) {
+ if (!$self->skip_whitespace($reader)) {
+ my $data = $reader->data(2);
+ $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
+ $reader->move_along(2);
+ return;
+ }
+ }
+
+ $self->SDDecl($reader);
+
+ $self->skip_whitespace($reader);
+
+ my $data = $reader->data(2);
+ $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
+ $reader->move_along(2);
+ }
+ else {
+ # warn("first 5 bytes: ", join(',', unpack("CCCCC", $data)), "\n");
+ # no xml decl
+ if (!$reader->get_encoding) {
+ $reader->set_encoding("UTF-8");
+ }
+ }
+}
+
+sub VersionInfo {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(11);
+
+ # warn("Looking for version in $data");
+
+ $data =~ /^(version$S*=$S*(["'])($VersionNum)\2)/o or return 0;
+ $reader->move_along(length($1));
+ my $vernum = $3;
+
+ if ($vernum ne "1.0") {
+ $self->parser_error("Only XML version 1.0 supported. Saw: '$vernum'", $reader);
+ }
+
+ return 1;
+}
+
+sub SDDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(15);
+
+ $data =~ /^(standalone$S*=$S*(["'])(yes|no)\2)/o or return 0;
+ $reader->move_along(length($1));
+ my $yesno = $3;
+
+ if ($yesno eq 'yes') {
+ $self->{standalone} = 1;
+ }
+ else {
+ $self->{standalone} = 0;
+ }
+
+ return 1;
+}
+
+sub EncodingDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(12);
+
+ $data =~ /^(encoding$S*=$S*(["'])($EncNameStart$EncNameEnd*)\2)/o or return 0;
+ $reader->move_along(length($1));
+ my $encoding = $3;
+
+ $reader->set_encoding($encoding);
+
+ return 1;
+}
+
+sub TextDecl {
+ my ($self, $reader) = @_;
+
+ my $data = $reader->data(6);
+ $data =~ /^<\?xml$S+/ or return;
+ $reader->move_along(5);
+ $self->skip_whitespace($reader);
+
+ if ($self->VersionInfo($reader)) {
+ $self->skip_whitespace($reader) ||
+ $self->parser_error("Lack of whitespace after version attribute in text declaration", $reader);
+ }
+
+ $self->EncodingDecl($reader) ||
+ $self->parser_error("Encoding declaration missing from external entity text declaration", $reader);
+
+ $self->skip_whitespace($reader);
+
+ $data = $reader->data(2);
+ $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
+
+ return 1;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/SAX/placeholder.pl b/Master/tlpkg/tlperl.straw/lib/XML/SAX/placeholder.pl
new file mode 100755
index 00000000000..6db59025607
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/SAX/placeholder.pl
@@ -0,0 +1 @@
+# ignore me
diff --git a/Master/tlpkg/tlperl.straw/lib/XML/benchmark.pl b/Master/tlpkg/tlperl.straw/lib/XML/benchmark.pl
new file mode 100755
index 00000000000..0435116055c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/XML/benchmark.pl
@@ -0,0 +1,268 @@
+use Benchmark;
+use Getopt::Long;
+use File::Basename;
+use XML::XPath;
+use strict;
+
+$|++;
+
+my @default_drivers = qw(
+ LibXSLT
+ Sablotron
+ );
+
+use vars qw(
+ $component $iter $ms $kb_in $kb_out $kb_sec $result $ref_size
+ );
+
+my @getopt_args = (
+ 'c=s', # config file
+ 'n=i', # number of benchmark times
+ 'd=s@', # drivers
+ 't', # only 1 iteration per test
+ 'v', # verbose
+ 'h', # help
+ 'x', # XSLTMark emulation
+ );
+
+my %options;
+
+Getopt::Long::config("bundling");
+
+unless (GetOptions(\%options, @getopt_args)) {
+ usage();
+}
+
+usage() if $options{h};
+
+$options{c} ||= 'testcases/default.conf';
+
+my $basedir = dirname($options{c});
+
+$options{d} ||= [@default_drivers];
+
+$options{n} ||= 1;
+
+# load drivers
+for my $driver (@{$options{d}}) {
+ warn "Loading $driver Driver\n" if $options{v};
+ require "Driver/$driver.pm";
+}
+
+# load config
+my @config;
+open(CONFIG, $options{c}) || die "Can't open config file '$options{c}' : $!";
+my $current = {};
+while(my $line = <CONFIG>) {
+ if ($line =~ /^\s*$/m && %$current) {
+ push @config, $current;
+ $current = {};
+ }
+
+ # ignore comments and full line comments
+ $line =~ s/#.*$//;
+ next unless $line =~ /\S/;
+
+ if ($line =~ /^\s*\[(.*)\]\s*$/) {
+ $current->{component} = $1;
+ }
+ elsif ($line =~ /^(.*?)\s*=\s*(.*)$/) {
+ $current->{$1} = $2;
+ }
+}
+
+for my $driver (@{$options{d}}) {
+ my $pkg = "Driver::${driver}";
+
+ $pkg->can('init')->(verbose => $options{v});
+
+ $pkg->can('chdir')->($basedir);
+
+ print "Testing: $driver\n\n";
+
+ print_header();
+
+ my %totals;
+
+ COMPONENT:
+ for my $cmp (@config) {
+ warn "Running test: $cmp->{component}\n" if $options{v};
+ for (1..$options{n}) {
+ $component = $cmp->{component};
+ $iter = $ms = $kb_in = $kb_out = $kb_sec = $ref_size = 0;
+
+ if ($cmp->{skipdriver} =~ /\b\Q$driver\E\b/) {
+ $result = 'SKIPPED';
+ print_output() unless $cmp->{written};
+ $cmp->{written}++;
+ next COMPONENT;
+ }
+
+ eval {
+ $pkg->can('load_stylesheet')->($cmp->{stylesheet});
+ $pkg->can('load_input')->($cmp->{input});
+
+ $iter = $cmp->{iterations};
+ $iter = 1 if $options{t};
+
+
+ my $bench = timeit($iter, sub {
+ $pkg->can('run_transform')->($cmp->{output});
+ });
+
+ my $str = timestr($bench, 'all', '5.4f');
+
+ if ($str =~ /\((\d+\.\d+)/) {
+ $ms = $1;
+ $ms *= 1000;
+ }
+
+ $kb_in = (stat($cmp->{input}))[7];
+
+ if ($options{x}) {
+ $kb_in /= 1000;
+ }
+ else {
+ $kb_in += (stat($cmp->{stylesheet}))[7];
+ $kb_in /= 1024;
+ }
+
+ $kb_in *= $iter;
+
+ $kb_out = (stat($cmp->{output}))[7];
+ $kb_out /= 1024;
+ $kb_out *= $iter;
+
+ die "failed - no output\n" unless $kb_out > 0;
+
+ $kb_sec = ($kb_in + $kb_out) /
+ ( $ms / 500 );
+
+ if ($cmp->{reference}) {
+ $ref_size = (stat($cmp->{reference}))[7];
+ $ref_size /= 1024;
+
+ open(REFERENCE, $cmp->{reference}) || die "Can't open reference '$cmp->{reference}' : $!";
+ open(NEW, $cmp->{output}) || die "Can't open transform output '$cmp->{output}' : $!";
+ local $/;
+ my $ref = <REFERENCE>;
+ my $new = <NEW>;
+ close REFERENCE;
+ close NEW;
+ $new =~ s/\A<\?xml.*?\?>\s*//;
+ $new =~ s/\A<!DOCTYPE.*?>\s*//;
+
+ if (!length($new)) {
+ die "output length failed\n";
+ }
+ if ($new eq $ref) {
+ $result = 'OK';
+ }
+ else {
+ $result = 'CHECK OUTPUT';
+ eval {
+ my $rpp = XML::XPath->new(xml => $ref);
+ my $ppp = XML::XPath::XMLParser->new(xml => $new);
+ my $npp;
+ eval {
+ $npp = $ppp->parse;
+ };
+ if ($@) {
+ $npp = $ppp->parse("<norm>$new</norm>");
+ }
+ my @rnodes = $rpp->findnodes('//*');
+ my @nnodes = $npp->findnodes('//*');
+# warn "ref nodes: ", scalar(@rnodes), "\n";
+# warn "new nodes: ", scalar(@nnodes), "\n";
+ if (@rnodes == @nnodes) {
+ $result = 'COUNT OK';
+ }
+ };
+ if ($@) {
+ warn $@ if $options{v};
+ }
+ }
+ }
+ else {
+ $result = 'NO REFERENCE';
+ }
+ };
+ if ($@) {
+ warn "$component failed: $@" if $options{v};
+ $result = 'ERROR';
+ }
+
+ if (($result =~ /OK/) || ($result eq 'NO REFERENCE')) {
+ $totals{iter} += $iter;
+ $totals{ms} += $ms;
+ $totals{kb_in} += $kb_in;
+ $totals{kb_out} += $kb_out;
+ }
+
+ print_output() unless $cmp->{written};
+ $cmp->{written}++;
+ } # $options{n} loop
+
+ delete $cmp->{written};
+ } # each component
+
+ $pkg->can('shutdown')->();
+
+ $component = 'total';
+ $iter = $totals{iter};
+ $ms = $totals{ms};
+ $kb_in = $totals{kb_in};
+ $kb_out = $totals{kb_out};
+ $kb_sec = ($kb_in + $kb_out) /
+ ( $ms / 500 );
+ $ref_size = 0;
+ $result = '';
+ print_output();
+}
+
+sub usage {
+ print <<EOT;
+usage: $0 [options]
+
+ options:
+
+ -c <file> load configuration from <file>
+ defaults to testcases/default.conf
+
+ -n <num> run each test case <num> times. Default = 1.
+
+ -t only one iteration per test case (note this
+ is different to -n 1)
+
+ -d <Driver> test <Driver>. Use multiple -d options to test
+ more than one driver. Defaults are set in this
+ script (the \@default_drivers variable).
+
+ -x XSLTMark emulation. Infuriatingly XSLTMark thinks
+ there are 1000 bytes in a Kilobyte. Someone please
+ tell them some basic computer science...
+
+ Without this option, this benchmark also includes
+ the size of the stylesheet in the KB In figure.
+
+ -v be verbose.
+
+Copyright 2001 AxKit.com Ltd. This is free software, you may use it and
+distribute it under either the GNU GPL Version 2, or under the Perl
+Artistic License.
+
+EOT
+ exit(0);
+}
+
+sub print_header {
+ print STDOUT <<'EOF';
+Test Component Iter ms KB In KB Out KB/s Result
+==========================================================================
+EOF
+}
+
+sub print_output {
+ printf STDOUT "%-15.15s %5.0d %5.0d %7.0f %7.0f %9.2f %-15.15s\n",
+ $component, $iter, $ms, $kb_in, $kb_out, $kb_sec, $result;
+}
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML.pm b/Master/tlpkg/tlperl.straw/lib/YAML.pm
new file mode 100755
index 00000000000..4032a30d634
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML.pm
@@ -0,0 +1,817 @@
+package YAML;
+
+use 5.008001;
+use strict;
+use warnings;
+use YAML::Base;
+use YAML::Node; # XXX This is a temp fix for Module::Build
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Base';
+our @EXPORT = qw{ Dump Load };
+our @EXPORT_OK = qw{ freeze thaw DumpFile LoadFile Bless Blessed };
+
+# XXX This VALUE nonsense needs to go.
+use constant VALUE => "\x07YAML\x07VALUE\x07";
+
+# YAML Object Properties
+field dumper_class => 'YAML::Dumper';
+field loader_class => 'YAML::Loader';
+field dumper_object =>
+ -init => '$self->init_action_object("dumper")';
+field loader_object =>
+ -init => '$self->init_action_object("loader")';
+
+sub Dump {
+ my $yaml = YAML->new;
+ $yaml->dumper_class($YAML::DumperClass)
+ if $YAML::DumperClass;
+ return $yaml->dumper_object->dump(@_);
+}
+
+sub Load {
+ my $yaml = YAML->new;
+ $yaml->loader_class($YAML::LoaderClass)
+ if $YAML::LoaderClass;
+ return $yaml->loader_object->load(@_);
+}
+
+{
+ no warnings 'once';
+ # freeze/thaw is the API for Storable string serialization. Some
+ # modules make use of serializing packages on if they use freeze/thaw.
+ *freeze = \ &Dump;
+ *thaw = \ &Load;
+}
+
+sub DumpFile {
+ my $OUT;
+ my $filename = shift;
+ if (ref $filename eq 'GLOB') {
+ $OUT = $filename;
+ }
+ else {
+ my $mode = '>';
+ if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
+ ($mode, $filename) = ($1, $2);
+ }
+ open $OUT, $mode, $filename
+ or YAML::Base->die('YAML_DUMP_ERR_FILE_OUTPUT', $filename, $!);
+ }
+ binmode $OUT, ':utf8'; # if $Config{useperlio} eq 'define';
+ local $/ = "\n"; # reset special to "sane"
+ print $OUT Dump(@_);
+}
+
+sub LoadFile {
+ my $IN;
+ my $filename = shift;
+ if (ref $filename eq 'GLOB') {
+ $IN = $filename;
+ }
+ else {
+ open $IN, '<', $filename
+ or YAML::Base->die('YAML_LOAD_ERR_FILE_INPUT', $filename, $!);
+ }
+ binmode $IN, ':utf8'; # if $Config{useperlio} eq 'define';
+ return Load(do { local $/; <$IN> });
+}
+
+sub init_action_object {
+ my $self = shift;
+ my $object_class = (shift) . '_class';
+ my $module_name = $self->$object_class;
+ eval "require $module_name";
+ $self->die("Error in require $module_name - $@")
+ if $@ and "$@" !~ /Can't locate/;
+ my $object = $self->$object_class->new;
+ $object->set_global_options;
+ return $object;
+}
+
+my $global = {};
+sub Bless {
+ require YAML::Dumper::Base;
+ YAML::Dumper::Base::bless($global, @_)
+}
+sub Blessed {
+ require YAML::Dumper::Base;
+ YAML::Dumper::Base::blessed($global, @_)
+}
+sub global_object { $global }
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+YAML - YAML Ain't Markup Language (tm)
+
+=head1 NOTE
+
+This module has been released to CPAN as YAML::Old, and soon YAML.pm
+will be changed to just be a frontend interface module for all the
+various Perl YAML implementation modules, including YAML::Old.
+
+If you want robust and fast YAML processing using the normal Dump/Load
+API, please consider switching to YAML::XS. It is by far the best Perl
+module for YAML at this time. It requires that you have a C compiler,
+since it is written in C.
+
+If you really need to use this version of YAML.pm it will always be
+available as YAML::Old.
+
+If you don't care which YAML module use, as long as it's the best one
+installed on your system, use YAML::Any.
+
+The rest of this documentation is left unchanged, until YAML.pm is
+switched over to the new UI-only version.
+
+=head1 SYNOPSIS
+
+ use YAML;
+
+ # Load a YAML stream of 3 YAML documents into Perl data structures.
+ my ($hashref, $arrayref, $string) = Load(<<'...');
+ ---
+ name: ingy
+ age: old
+ weight: heavy
+ # I should comment that I also like pink, but don't tell anybody.
+ favorite colors:
+ - red
+ - green
+ - blue
+ ---
+ - Clark Evans
+ - Oren Ben-Kiki
+ - Ingy döt Net
+ --- >
+ You probably think YAML stands for "Yet Another Markup Language". It
+ ain't! YAML is really a data serialization language. But if you want
+ to think of it as a markup, that's OK with me. A lot of people try
+ to use XML as a serialization format.
+
+ "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!"
+ ...
+
+ # Dump the Perl data structures back into YAML.
+ print Dump($string, $arrayref, $hashref);
+
+ # YAML::Dump is used the same way you'd use Data::Dumper::Dumper
+ use Data::Dumper;
+ print Dumper($string, $arrayref, $hashref);
+
+=head1 DESCRIPTION
+
+The YAML.pm module implements a YAML Loader and Dumper based on the YAML
+1.0 specification. L<http://www.yaml.org/spec/>
+
+YAML is a generic data serialization language that is optimized for
+human readability. It can be used to express the data structures of most
+modern programming languages. (Including Perl!!!)
+
+For information on the YAML syntax, please refer to the YAML
+specification.
+
+=head1 WHY YAML IS COOL
+
+=over 4
+
+=item YAML is readable for people.
+
+It makes clear sense out of complex data structures. You should find
+that YAML is an exceptional data dumping tool. Structure is shown
+through indentation, YAML supports recursive data, and hash keys are
+sorted by default. In addition, YAML supports several styles of scalar
+formatting for different types of data.
+
+=item YAML is editable.
+
+YAML was designed from the ground up to be an excellent syntax for
+configuration files. Almost all programs need configuration files, so
+why invent a new syntax for each one? And why subject users to the
+complexities of XML or native Perl code?
+
+=item YAML is multilingual.
+
+Yes, YAML supports Unicode. But I'm actually referring to programming
+languages. YAML was designed to meet the serialization needs of Perl,
+Python, Ruby, Tcl, PHP, Javascript and Java. It was also designed to be
+interoperable between those languages. That means YAML serializations
+produced by Perl can be processed by Python.
+
+=item YAML is taint safe.
+
+Using modules like Data::Dumper for serialization is fine as long as you
+can be sure that nobody can tamper with your data files or
+transmissions. That's because you need to use Perl's C<eval()> built-in
+to deserialize the data. Somebody could add a snippet of Perl to erase
+your files.
+
+YAML's parser does not need to eval anything.
+
+=item YAML is full featured.
+
+YAML can accurately serialize all of the common Perl data structures and
+deserialize them again without losing data relationships. Although it is
+not 100% perfect (no serializer is or can be perfect), it fares as well
+as the popular current modules: Data::Dumper, Storable, XML::Dumper and
+Data::Denter.
+
+YAML.pm also has the ability to handle code (subroutine) references and
+typeglobs. (Still experimental) These features are not found in Perl's
+other serialization modules.
+
+=item YAML is extensible.
+
+The YAML language has been designed to be flexible enough to solve it's
+own problems. The markup itself has 3 basic construct which resemble
+Perl's hash, array and scalar. By default, these map to their Perl
+equivalents. But each YAML node also supports a tagging mechanism (type
+system) which can cause that node to be interpreted in a completely
+different manner. That's how YAML can support object serialization and
+oddball structures like Perl's typeglob.
+
+=back
+
+=head1 YAML IMPLEMENTATIONS IN PERL
+
+This module, YAML.pm, is really just the interface module for YAML
+modules written in Perl. The basic interface for YAML consists of two
+functions: C<Dump> and C<Load>. The real work is done by the modules
+YAML::Dumper and YAML::Loader.
+
+Different YAML module distributions can be created by subclassing
+YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple
+consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple.
+
+Why would there be more than one implementation of YAML? Well, despite
+YAML's offering of being a simple data format, YAML is actually very
+deep and complex. Implementing the entirety of the YAML specification is
+a daunting task.
+
+For this reason I am currently working on 3 different YAML implementations.
+
+=over
+
+=item YAML
+
+The main YAML distribution will keeping evolving to support the entire
+YAML specification in pure Perl. This may not be the fastest or most
+stable module though. Currently, YAML.pm has lots of known bugs. It is
+mostly a great tool for dumping Perl data structures to a readable form.
+
+=item YAML::Tiny
+
+The point of YAML::Tiny is to strip YAML down to the 90% that people
+use most and offer that in a small, fast, stable, pure Perl form.
+YAML::Tiny will simply die when it is asked to do something it can't.
+
+=item YAML::Syck
+
+C<libsyck> is the C based YAML processing library used by the Ruby
+programming language (and also Python, PHP and Pugs). YAML::Syck is the
+Perl binding to C<libsyck>. It should be very fast, but may have
+problems of its own. It will also require C compilation.
+
+NOTE: Audrey Tang has actually completed this module and it works great
+ and is 10 times faster than YAML.pm.
+
+=back
+
+In the future, there will likely be even more YAML modules. Remember,
+people other than Ingy are allowed to write YAML modules!
+
+=head1 FUNCTIONAL USAGE
+
+YAML is completely OO under the hood. Still it exports a few useful top
+level functions so that it is dead simple to use. These functions just
+do the OO stuff for you. If you want direct access to the OO API see the
+documentation for YAML::Dumper and YAML::Loader.
+
+=head2 Exported Functions
+
+The following functions are exported by YAML.pm by default. The reason
+they are exported is so that YAML works much like Data::Dumper. If you
+don't want functions to be imported, just use YAML with an empty
+import list:
+
+ use YAML ();
+
+=over 4
+
+=item Dump(list-of-Perl-data-structures)
+
+Turn Perl data into YAML. This function works very much like
+Data::Dumper::Dumper(). It takes a list of Perl data strucures and
+dumps them into a serialized form. It returns a string containing the
+YAML stream. The structures can be references or plain scalars.
+
+=item Load(string-containing-a-YAML-stream)
+
+Turn YAML into Perl data. This is the opposite of Dump. Just like
+Storable's thaw() function or the eval() function in relation to
+Data::Dumper. It parses a string containing a valid YAML stream into a
+list of Perl data structures.
+
+=back
+
+=head2 Exportable Functions
+
+These functions are not exported by default but you can request them in
+an import list like this:
+
+ use YAML qw'freeze thaw Bless';
+
+=over 4
+
+=item freeze() and thaw()
+
+Aliases to Dump() and Load() for Storable fans. This will also allow
+YAML.pm to be plugged directly into modules like POE.pm, that use the
+freeze/thaw API for internal serialization.
+
+=item DumpFile(filepath, list)
+
+Writes the YAML stream to a file instead of just returning a string.
+
+=item LoadFile(filepath)
+
+Reads the YAML stream from a file instead of a string.
+
+=item Bless(perl-node, [yaml-node | class-name])
+
+Associate a normal Perl node, with a yaml node. A yaml node is an object
+tied to the YAML::Node class. The second argument is either a yaml node
+that you've already created or a class (package) name that supports a
+yaml_dump() function. A yaml_dump() function should take a perl node and
+return a yaml node. If no second argument is provided, Bless will create
+a yaml node. This node is not returned, but can be retrieved with the
+Blessed() function.
+
+Here's an example of how to use Bless. Say you have a hash containing
+three keys, but you only want to dump two of them. Furthermore the keys
+must be dumped in a certain order. Here's how you do that:
+
+ use YAML qw(Dump Bless);
+ $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'};
+ print Dump $hash;
+ Bless($hash)->keys(['banana', 'apple']);
+ print Dump $hash;
+
+produces:
+
+ ---
+ apple: good
+ banana: bad
+ cauliflower: ugly
+ ---
+ banana: bad
+ apple: good
+
+Bless returns the tied part of a yaml-node, so that you can call the
+YAML::Node methods. This is the same thing that YAML::Node::ynode()
+returns. So another way to do the above example is:
+
+ use YAML qw(Dump Bless);
+ use YAML::Node;
+ $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'};
+ print Dump $hash;
+ Bless($hash);
+ $ynode = ynode(Blessed($hash));
+ $ynode->keys(['banana', 'apple']);
+ print Dump $hash;
+
+Note that Blessing a Perl data structure does not change it anyway. The
+extra information is stored separately and looked up by the Blessed
+node's memory address.
+
+=item Blessed(perl-node)
+
+Returns the yaml node that a particular perl node is associated with
+(see above). Returns undef if the node is not (YAML) Blessed.
+
+=back
+
+=head1 GLOBAL OPTIONS
+
+YAML options are set using a group of global variables in the YAML
+namespace. This is similar to how Data::Dumper works.
+
+For example, to change the indentation width, do something like:
+
+ local $YAML::Indent = 3;
+
+The current options are:
+
+=over 4
+
+=item DumperClass
+
+You can override which module/class YAML uses for Dumping data.
+
+=item LoaderClass
+
+You can override which module/class YAML uses for Loading data.
+
+=item Indent
+
+This is the number of space characters to use for each indentation level
+when doing a Dump(). The default is 2.
+
+By the way, YAML can use any number of characters for indentation at any
+level. So if you are editing YAML by hand feel free to do it anyway that
+looks pleasing to you; just be consistent for a given level.
+
+=item SortKeys
+
+Default is 1. (true)
+
+Tells YAML.pm whether or not to sort hash keys when storing a document.
+
+YAML::Node objects can have their own sort order, which is usually what
+you want. To override the YAML::Node order and sort the keys anyway, set
+SortKeys to 2.
+
+=item Stringify
+
+Default is 0. (false)
+
+Objects with string overloading should honor the overloading and dump the
+stringification of themselves, rather than the actual object's guts.
+
+=item UseHeader
+
+Default is 1. (true)
+
+This tells YAML.pm whether to use a separator string for a Dump
+operation. This only applies to the first document in a stream.
+Subsequent documents must have a YAML header by definition.
+
+=item UseVersion
+
+Default is 0. (false)
+
+Tells YAML.pm whether to include the YAML version on the
+separator/header.
+
+ --- %YAML:1.0
+
+=item AnchorPrefix
+
+Default is ''.
+
+Anchor names are normally numeric. YAML.pm simply starts with '1' and
+increases by one for each new anchor. This option allows you to specify a
+string to be prepended to each anchor number.
+
+=item UseCode
+
+Setting the UseCode option is a shortcut to set both the DumpCode and
+LoadCode options at once. Setting UseCode to '1' tells YAML.pm to dump
+Perl code references as Perl (using B::Deparse) and to load them back
+into memory using eval(). The reason this has to be an option is that
+using eval() to parse untrusted code is, well, untrustworthy.
+
+=item DumpCode
+
+Determines if and how YAML.pm should serialize Perl code references. By
+default YAML.pm will dump code references as dummy placeholders (much
+like Data::Dumper). If DumpCode is set to '1' or 'deparse', code
+references will be dumped as actual Perl code.
+
+DumpCode can also be set to a subroutine reference so that you can
+write your own serializing routine. YAML.pm passes you the code ref. You
+pass back the serialization (as a string) and a format indicator. The
+format indicator is a simple string like: 'deparse' or 'bytecode'.
+
+=item LoadCode
+
+LoadCode is the opposite of DumpCode. It tells YAML if and how to
+deserialize code references. When set to '1' or 'deparse' it will use
+C<eval()>. Since this is potentially risky, only use this option if you
+know where your YAML has been.
+
+LoadCode can also be set to a subroutine reference so that you can write
+your own deserializing routine. YAML.pm passes the serialization (as a
+string) and a format indicator. You pass back the code reference.
+
+=item UseBlock
+
+YAML.pm uses heuristics to guess which scalar style is best for a given
+node. Sometimes you'll want all multiline scalars to use the 'block'
+style. If so, set this option to 1.
+
+NOTE: YAML's block style is akin to Perl's here-document.
+
+=item UseFold
+
+If you want to force YAML to use the 'folded' style for all multiline
+scalars, then set $UseFold to 1.
+
+NOTE: YAML's folded style is akin to the way HTML folds text,
+ except smarter.
+
+=item UseAliases
+
+YAML has an alias mechanism such that any given structure in memory gets
+serialized once. Any other references to that structure are serialized
+only as alias markers. This is how YAML can serialize duplicate and
+recursive structures.
+
+Sometimes, when you KNOW that your data is nonrecursive in nature, you
+may want to serialize such that every node is expressed in full. (ie as
+a copy of the original). Setting $YAML::UseAliases to 0 will allow you
+to do this. This also may result in faster processing because the lookup
+overhead is by bypassed.
+
+THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this option
+*will* cause Dump() to run in an endless loop, chewing up your computers
+memory. You have been warned.
+
+=item CompressSeries
+
+Default is 1.
+
+Compresses the formatting of arrays of hashes:
+
+ -
+ foo: bar
+ -
+ bar: foo
+
+becomes:
+
+ - foo: bar
+ - bar: foo
+
+Since this output is usually more desirable, this option is turned on by
+default.
+
+=back
+
+=head1 YAML TERMINOLOGY
+
+YAML is a full featured data serialization language, and thus has its
+own terminology.
+
+It is important to remember that although YAML is heavily influenced by
+Perl and Python, it is a language in its own right, not merely just a
+representation of Perl structures.
+
+YAML has three constructs that are conspicuously similar to Perl's hash,
+array, and scalar. They are called mapping, sequence, and string
+respectively. By default, they do what you would expect. But each
+instance may have an explicit or implicit tag (type) that makes it
+behave differently. In this manner, YAML can be extended to represent
+Perl's Glob or Python's tuple, or Ruby's Bigint.
+
+=over 4
+
+=item stream
+
+A YAML stream is the full sequence of unicode characters that a YAML
+parser would read or a YAML emitter would write. A stream may contain
+one or more YAML documents separated by YAML headers.
+
+ ---
+ a: mapping
+ foo: bar
+ ---
+ - a
+ - sequence
+
+=item document
+
+A YAML document is an independent data structure representation within a
+stream. It is a top level node. Each document in a YAML stream must
+begin with a YAML header line. Actually the header is optional on the
+first document.
+
+ ---
+ This: top level mapping
+ is:
+ - a
+ - YAML
+ - document
+
+=item header
+
+A YAML header is a line that begins a YAML document. It consists of
+three dashes, possibly followed by more info. Another purpose of the
+header line is that it serves as a place to put top level tag and anchor
+information.
+
+ --- !recursive-sequence &001
+ - * 001
+ - * 001
+
+=item node
+
+A YAML node is the representation of a particular data stucture. Nodes
+may contain other nodes. (In Perl terms, nodes are like scalars.
+Strings, arrayrefs and hashrefs. But this refers to the serialized
+format, not the in-memory structure.)
+
+=item tag
+
+This is similar to a type. It indicates how a particular YAML node
+serialization should be transferred into or out of memory. For instance
+a Foo::Bar object would use the tag 'perl/Foo::Bar':
+
+ - !perl/Foo::Bar
+ foo: 42
+ bar: stool
+
+=item collection
+
+A collection is the generic term for a YAML data grouping. YAML has two
+types of collections: mappings and sequences. (Similar to hashes and arrays)
+
+=item mapping
+
+A mapping is a YAML collection defined by unordered key/value pairs with
+unique keys. By default YAML mappings are loaded into Perl hashes.
+
+ a mapping:
+ foo: bar
+ two: times two is 4
+
+=item sequence
+
+A sequence is a YAML collection defined by an ordered list of elements. By
+default YAML sequences are loaded into Perl arrays.
+
+ a sequence:
+ - one bourbon
+ - one scotch
+ - one beer
+
+=item scalar
+
+A scalar is a YAML node that is a single value. By default YAML scalars
+are loaded into Perl scalars.
+
+ a scalar key: a scalar value
+
+YAML has many styles for representing scalars. This is important because
+varying data will have varying formatting requirements to retain the
+optimum human readability.
+
+=item plain scalar
+
+A plain sclar is unquoted. All plain scalars are automatic candidates
+for "implicit tagging". This means that their tag may be determined
+automatically by examination. The typical uses for this are plain alpha
+strings, integers, real numbers, dates, times and currency.
+
+ - a plain string
+ - -42
+ - 3.1415
+ - 12:34
+ - 123 this is an error
+
+=item single quoted scalar
+
+This is similar to Perl's use of single quotes. It means no escaping
+except for single quotes which are escaped by using two adjacent
+single quotes.
+
+ - 'When I say ''\n'' I mean "backslash en"'
+
+=item double quoted scalar
+
+This is similar to Perl's use of double quotes. Character escaping can
+be used.
+
+ - "This scalar\nhas two lines, and a bell -->\a"
+
+=item folded scalar
+
+This is a multiline scalar which begins on the next line. It is
+indicated by a single right angle bracket. It is unescaped like the
+single quoted scalar. Line folding is also performed.
+
+ - >
+ This is a multiline scalar which begins on
+ the next line. It is indicated by a single
+ carat. It is unescaped like the single
+ quoted scalar. Line folding is also
+ performed.
+
+=item block scalar
+
+This final multiline form is akin to Perl's here-document except that
+(as in all YAML data) scope is indicated by indentation. Therefore, no
+ending marker is required. The data is verbatim. No line folding.
+
+ - |
+ QTY DESC PRICE TOTAL
+ --- ---- ----- -----
+ 1 Foo Fighters $19.95 $19.95
+ 2 Bar Belles $29.95 $59.90
+
+=item parser
+
+A YAML processor has four stages: parse, load, dump, emit.
+
+A parser parses a YAML stream. YAML.pm's Load() function contains a
+parser.
+
+=item loader
+
+The other half of the Load() function is a loader. This takes the
+information from the parser and loads it into a Perl data structure.
+
+=item dumper
+
+The Dump() function consists of a dumper and an emitter. The dumper
+walks through each Perl data structure and gives info to the emitter.
+
+=item emitter
+
+The emitter takes info from the dumper and turns it into a YAML stream.
+
+NOTE:
+In YAML.pm the parser/loader and the dumper/emitter code are currently
+very closely tied together. In the future they may be broken into
+separate stages.
+
+=back
+
+For more information please refer to the immensely helpful YAML
+specification available at L<http://www.yaml.org/spec/>.
+
+=head1 ysh - The YAML Shell
+
+The YAML distribution ships with a script called 'ysh', the YAML shell.
+ysh provides a simple, interactive way to play with YAML. If you type in
+Perl code, it displays the result in YAML. If you type in YAML it turns
+it into Perl code.
+
+To run ysh, (assuming you installed it along with YAML.pm) simply type:
+
+ ysh [options]
+
+Please read the C<ysh> documentation for the full details. There are
+lots of options.
+
+=head1 BUGS & DEFICIENCIES
+
+If you find a bug in YAML, please try to recreate it in the YAML Shell
+with logging turned on ('ysh -L'). When you have successfully reproduced
+the bug, please mail the LOG file to the author (ingy@cpan.org).
+
+WARNING: This is still *ALPHA* code. Well, most of this code has been
+around for years...
+
+BIGGER WARNING: YAML.pm has been slow in the making, but I am committed
+to having top notch YAML tools in the Perl world. The YAML team is close
+to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of
+a very old pre 1.0 spec. In actuality there isn't a ton of difference,
+and this YAML.pm is still fairly useful. Things will get much better in
+the future.
+
+=head1 RESOURCES
+
+L<http://lists.sourceforge.net/lists/listinfo/yaml-core> is the mailing
+list. This is where the language is discussed and designed.
+
+L<http://www.yaml.org> is the official YAML website.
+
+L<http://www.yaml.org/spec/> is the YAML 1.0 specification.
+
+L<http://yaml.kwiki.org> is the official YAML wiki.
+
+=head1 SEE ALSO
+
+See YAML::Syck. Fast!
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+is resonsible for YAML.pm.
+
+The YAML serialization language is the result of years of collaboration
+between Oren Ben-Kiki, Clark Evans and Ingy dE<ouml>t Net. Several others
+have added help along the way.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005, 2006, 2008. Ingy dE<ouml>t Net.
+
+Copyright (c) 2001, 2002, 2005. Brian Ingerson.
+
+Some parts copyright (c) 2009 - 2010 Adam Kennedy
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Any.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Any.pm
new file mode 100755
index 00000000000..ad8f496fa68
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Any.pm
@@ -0,0 +1,202 @@
+package YAML::Any;
+
+use 5.005003;
+use strict;
+use Exporter ();
+
+$YAML::Any::VERSION = '0.71';
+@YAML::Any::ISA = 'Exporter';
+@YAML::Any::EXPORT = qw(Dump Load);
+@YAML::Any::EXPORT_OK = qw(DumpFile LoadFile);
+
+my @dump_options = qw(
+ UseCode
+ DumpCode
+ SpecVersion
+ Indent
+ UseHeader
+ UseVersion
+ SortKeys
+ AnchorPrefix
+ UseBlock
+ UseFold
+ CompressSeries
+ InlineSeries
+ UseAliases
+ Purity
+ Stringify
+);
+
+my @load_options = qw(
+ UseCode
+ LoadCode
+);
+
+my @implementations = qw(
+ YAML::XS
+ YAML::Syck
+ YAML::Old
+ YAML
+ YAML::Tiny
+);
+
+sub import {
+ __PACKAGE__->implementation;
+ goto &Exporter::import;
+}
+
+sub Dump {
+ no strict 'refs';
+ my $implementation = __PACKAGE__->implementation;
+ for my $option (@dump_options) {
+ my $var = "$implementation\::$option";
+ my $value = $$var;
+ local $$var;
+ $$var = defined $value ? $value : ${"YAML::$option"};
+ }
+ return &{"$implementation\::Dump"}(@_);
+}
+
+sub DumpFile {
+ no strict 'refs';
+ my $implementation = __PACKAGE__->implementation;
+ for my $option (@dump_options) {
+ my $var = "$implementation\::$option";
+ my $value = $$var;
+ local $$var;
+ $$var = defined $value ? $value : ${"YAML::$option"};
+ }
+ return &{"$implementation\::DumpFile"}(@_);
+}
+
+sub Load {
+ no strict 'refs';
+ my $implementation = __PACKAGE__->implementation;
+ for my $option (@load_options) {
+ my $var = "$implementation\::$option";
+ my $value = $$var;
+ local $$var;
+ $$var = defined $value ? $value : ${"YAML::$option"};
+ }
+ return &{"$implementation\::Load"}(@_);
+}
+
+sub LoadFile {
+ no strict 'refs';
+ my $implementation = __PACKAGE__->implementation;
+ for my $option (@load_options) {
+ my $var = "$implementation\::$option";
+ my $value = $$var;
+ local $$var;
+ $$var = defined $value ? $value : ${"YAML::$option"};
+ }
+ return &{"$implementation\::LoadFile"}(@_);
+}
+
+sub order {
+ return @YAML::Any::_TEST_ORDER
+ if defined @YAML::Any::_TEST_ORDER;
+ return @implementations;
+}
+
+sub implementation {
+ my @order = __PACKAGE__->order;
+ for my $module (@order) {
+ my $path = $module;
+ $path =~ s/::/\//g;
+ $path .= '.pm';
+ return $module if exists $INC{$path};
+ eval "require $module; 1" and return $module;
+ }
+ croak("YAML::Any couldn't find any of these YAML implementations: @order");
+}
+
+sub croak {
+ require Carp;
+ Carp::Croak(@_);
+}
+
+1;
+
+=head1 NAME
+
+YAML::Any - Pick a YAML implementation and use it.
+
+=head1 SYNOPSIS
+
+ use YAML::Any;
+ $YAML::Indent = 3;
+ my $yaml = Dump(@objects);
+
+=head1 DESCRIPTION
+
+There are several YAML implementations that support the Dump/Load API.
+This module selects the best one available and uses it.
+
+=head1 ORDER
+
+Currently, YAML::Any will choose the first one of these YAML
+implementations that is installed on your system:
+
+ YAML::XS
+ YAML::Syck
+ YAML::Old
+ YAML
+ YAML::Tiny
+
+=head1 OPTIONS
+
+If you specify an option like:
+
+ $YAML::Indent = 4;
+
+And YAML::Any is using YAML::XS, it will use the proper variable:
+$YAML::XS::Indent.
+
+=head1 SUBROUTINES
+
+Like all the YAML modules that YAML::Any uses, the following subroutines
+are exported by default:
+
+ Dump
+ Load
+
+and the following subroutines are exportable by request:
+
+ DumpFile
+ LoadFile
+
+=head1 METHODS
+
+YAML::Any provides the following class methods.
+
+=over
+
+=item YAML::Any->order;
+
+This method returns a list of the current possible implementations that
+YAML::Any will search for.
+
+=item YAML::Any->implementation;
+
+This method returns the implementation the YAML::Any will use. This
+result is obtained by finding the first member of YAML::Any->order that
+is either already loaded in C<%INC> or that can be loaded using
+C<require>. If no implementation is found, an error will be thrown.
+
+=back
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008. Ingy döt Net.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Base.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Base.pm
new file mode 100755
index 00000000000..2899f87238f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Base.pm
@@ -0,0 +1,204 @@
+package YAML::Base;
+
+use strict;
+use warnings;
+use Exporter ();
+
+our $VERSION = '0.71';
+our @ISA = 'Exporter';
+our @EXPORT = qw(field XXX);
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $self = bless {}, $class;
+ while (@_) {
+ my $method = shift;
+ $self->$method(shift);
+ }
+ return $self;
+}
+
+# Use lexical subs to reduce pollution of private methods by base class.
+my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code);
+
+sub XXX {
+ require Data::Dumper;
+ CORE::die(Data::Dumper::Dumper(@_));
+}
+
+my %code = (
+ sub_start =>
+ "sub {\n",
+ set_default =>
+ " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
+ init =>
+ " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
+ " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
+ return_if_get =>
+ " return \$_[0]->{%s} unless \$#_ > 0;\n",
+ set =>
+ " \$_[0]->{%s} = \$_[1];\n",
+ sub_end =>
+ " return \$_[0]->{%s};\n}\n",
+);
+
+sub field {
+ my $package = caller;
+ my ($args, @values) = &$parse_arguments(
+ [ qw(-package -init) ],
+ @_,
+ );
+ my ($field, $default) = @values;
+ $package = $args->{-package} if defined $args->{-package};
+ return if defined &{"${package}::$field"};
+ my $default_string =
+ ( ref($default) eq 'ARRAY' and not @$default )
+ ? '[]'
+ : (ref($default) eq 'HASH' and not keys %$default )
+ ? '{}'
+ : &$default_as_code($default);
+
+ my $code = $code{sub_start};
+ if ($args->{-init}) {
+ my $fragment = $code{init};
+ $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
+ }
+ $code .= sprintf $code{set_default}, $field, $default_string, $field
+ if defined $default;
+ $code .= sprintf $code{return_if_get}, $field;
+ $code .= sprintf $code{set}, $field;
+ $code .= sprintf $code{sub_end}, $field;
+
+ my $sub = eval $code;
+ die $@ if $@;
+ no strict 'refs';
+ *{"${package}::$field"} = $sub;
+ return $code if defined wantarray;
+}
+
+sub die {
+ my $self = shift;
+ my $error = $self->$_new_error(@_);
+ $error->type('Error');
+ Carp::croak($error->format_message);
+}
+
+sub warn {
+ my $self = shift;
+ return unless $^W;
+ my $error = $self->$_new_error(@_);
+ $error->type('Warning');
+ Carp::cluck($error->format_message);
+}
+
+# This code needs to be refactored to be simpler and more precise, and no,
+# Scalar::Util doesn't DWIM.
+#
+# Can't handle:
+# * blessed regexp
+sub node_info {
+ my $self = shift;
+ my $stringify = $_[1] || 0;
+ my ($class, $type, $id) =
+ ref($_[0])
+ ? $stringify
+ ? &$_info("$_[0]")
+ : do {
+ require overload;
+ my @info = &$_info(overload::StrVal($_[0]));
+ if (ref($_[0]) eq 'Regexp') {
+ @info[0, 1] = (undef, 'REGEXP');
+ }
+ @info;
+ }
+ : &$_scalar_info($_[0]);
+ ($class, $type, $id) = &$_scalar_info("$_[0]")
+ unless $id;
+ return wantarray ? ($class, $type, $id) : $id;
+}
+
+#-------------------------------------------------------------------------------
+$_info = sub {
+ return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o);
+};
+
+$_scalar_info = sub {
+ my $id = 'undef';
+ if (defined $_[0]) {
+ \$_[0] =~ /\((\w+)\)$/o or CORE::die();
+ $id = "$1-S";
+ }
+ return (undef, undef, $id);
+};
+
+$_new_error = sub {
+ require Carp;
+ my $self = shift;
+ require YAML::Error;
+
+ my $code = shift || 'unknown error';
+ my $error = YAML::Error->new(code => $code);
+ $error->line($self->line) if $self->can('line');
+ $error->document($self->document) if $self->can('document');
+ $error->arguments([@_]);
+ return $error;
+};
+
+$parse_arguments = sub {
+ my $paired_arguments = shift || [];
+ my ($args, @values) = ({}, ());
+ my %pairs = map { ($_, 1) } @$paired_arguments;
+ while (@_) {
+ my $elem = shift;
+ if (defined $elem and defined $pairs{$elem} and @_) {
+ $args->{$elem} = shift;
+ }
+ else {
+ push @values, $elem;
+ }
+ }
+ return wantarray ? ($args, @values) : $args;
+};
+
+$default_as_code = sub {
+ no warnings 'once';
+ require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
+ my $code = Data::Dumper::Dumper(shift);
+ $code =~ s/^\$VAR1 = //;
+ $code =~ s/;$//;
+ return $code;
+};
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Base - Base class for YAML classes
+
+=head1 SYNOPSIS
+
+ package YAML::Something;
+ use YAML::Base -base;
+
+=head1 DESCRIPTION
+
+YAML::Base is the parent of all YAML classes.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Dumper.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper.pm
new file mode 100755
index 00000000000..8ece98931d2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper.pm
@@ -0,0 +1,591 @@
+package YAML::Dumper;
+
+use strict;
+use warnings;
+use YAML::Base;
+use YAML::Dumper::Base;
+use YAML::Node;
+use YAML::Types;
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Dumper::Base';
+
+# Context constants
+use constant KEY => 3;
+use constant BLESSED => 4;
+use constant FROMARRAY => 5;
+use constant VALUE => "\x07YAML\x07VALUE\x07";
+
+# Common YAML character sets
+my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
+my $LIT_CHAR = '|';
+
+#==============================================================================
+# OO version of Dump. YAML->new->dump($foo);
+sub dump {
+ my $self = shift;
+ $self->stream('');
+ $self->document(0);
+ for my $document (@_) {
+ $self->{document}++;
+ $self->transferred({});
+ $self->id_refcnt({});
+ $self->id_anchor({});
+ $self->anchor(1);
+ $self->level(0);
+ $self->offset->[0] = 0 - $self->indent_width;
+ $self->_prewalk($document);
+ $self->_emit_header($document);
+ $self->_emit_node($document);
+ }
+ return $self->stream;
+}
+
+# Every YAML document in the stream must begin with a YAML header, unless
+# there is only a single document and the user requests "no header".
+sub _emit_header {
+ my $self = shift;
+ my ($node) = @_;
+ if (not $self->use_header and
+ $self->document == 1
+ ) {
+ $self->die('YAML_DUMP_ERR_NO_HEADER')
+ unless ref($node) =~ /^(HASH|ARRAY)$/;
+ $self->die('YAML_DUMP_ERR_NO_HEADER')
+ if ref($node) eq 'HASH' and keys(%$node) == 0;
+ $self->die('YAML_DUMP_ERR_NO_HEADER')
+ if ref($node) eq 'ARRAY' and @$node == 0;
+ # XXX Also croak if aliased, blessed, or ynode
+ $self->headless(1);
+ return;
+ }
+ $self->{stream} .= '---';
+# XXX Consider switching to 1.1 style
+ if ($self->use_version) {
+# $self->{stream} .= " #YAML:1.0";
+ }
+}
+
+# Walk the tree to be dumped and keep track of its reference counts.
+# This function is where the Dumper does all its work. All type
+# transfers happen here.
+sub _prewalk {
+ my $self = shift;
+ my $stringify = $self->stringify;
+ my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
+
+ # Handle typeglobs
+ if ($type eq 'GLOB') {
+ $self->transferred->{$node_id} =
+ YAML::Type::glob->yaml_dump($_[0]);
+ $self->_prewalk($self->transferred->{$node_id});
+ return;
+ }
+
+ # Handle regexps
+ if (ref($_[0]) eq 'Regexp') {
+ return;
+ }
+
+ # Handle Purity for scalars.
+ # XXX can't find a use case yet. Might be YAGNI.
+ if (not ref $_[0]) {
+ $self->{id_refcnt}{$node_id}++ if $self->purity;
+ return;
+ }
+
+ # Make a copy of original
+ my $value = $_[0];
+ ($class, $type, $node_id) = $self->node_info($value, $stringify);
+
+ # Must be a stringified object.
+ return if (ref($value) and not $type);
+
+ # Look for things already transferred.
+ if ($self->transferred->{$node_id}) {
+ (undef, undef, $node_id) = (ref $self->transferred->{$node_id})
+ ? $self->node_info($self->transferred->{$node_id}, $stringify)
+ : $self->node_info(\ $self->transferred->{$node_id}, $stringify);
+ $self->{id_refcnt}{$node_id}++;
+ return;
+ }
+
+ # Handle code refs
+ if ($type eq 'CODE') {
+ $self->transferred->{$node_id} = 'placeholder';
+ YAML::Type::code->yaml_dump(
+ $self->dump_code,
+ $_[0],
+ $self->transferred->{$node_id}
+ );
+ ($class, $type, $node_id) =
+ $self->node_info(\ $self->transferred->{$node_id}, $stringify);
+ $self->{id_refcnt}{$node_id}++;
+ return;
+ }
+
+ # Handle blessed things
+ if (defined $class) {
+ if ($value->can('yaml_dump')) {
+ $value = $value->yaml_dump;
+ }
+ elsif ($type eq 'SCALAR') {
+ $self->transferred->{$node_id} = 'placeholder';
+ YAML::Type::blessed->yaml_dump
+ ($_[0], $self->transferred->{$node_id});
+ ($class, $type, $node_id) =
+ $self->node_info(\ $self->transferred->{$node_id}, $stringify);
+ $self->{id_refcnt}{$node_id}++;
+ return;
+ }
+ else {
+ $value = YAML::Type::blessed->yaml_dump($value);
+ }
+ $self->transferred->{$node_id} = $value;
+ (undef, $type, $node_id) = $self->node_info($value, $stringify);
+ }
+
+ # Handle YAML Blessed things
+ if (defined YAML->global_object()->{blessed_map}{$node_id}) {
+ $value = YAML->global_object()->{blessed_map}{$node_id};
+ $self->transferred->{$node_id} = $value;
+ ($class, $type, $node_id) = $self->node_info($value, $stringify);
+ $self->_prewalk($value);
+ return;
+ }
+
+ # Handle hard refs
+ if ($type eq 'REF' or $type eq 'SCALAR') {
+ $value = YAML::Type::ref->yaml_dump($value);
+ $self->transferred->{$node_id} = $value;
+ (undef, $type, $node_id) = $self->node_info($value, $stringify);
+ }
+
+ # Handle ref-to-glob's
+ elsif ($type eq 'GLOB') {
+ my $ref_ynode = $self->transferred->{$node_id} =
+ YAML::Type::ref->yaml_dump($value);
+
+ my $glob_ynode = $ref_ynode->{&VALUE} =
+ YAML::Type::glob->yaml_dump($$value);
+
+ (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify);
+ $self->transferred->{$node_id} = $glob_ynode;
+ $self->_prewalk($glob_ynode);
+ return;
+ }
+
+ # Increment ref count for node
+ return if ++($self->{id_refcnt}{$node_id}) > 1;
+
+ # Keep on walking
+ if ($type eq 'HASH') {
+ $self->_prewalk($value->{$_})
+ for keys %{$value};
+ return;
+ }
+ elsif ($type eq 'ARRAY') {
+ $self->_prewalk($_)
+ for @{$value};
+ return;
+ }
+
+ # Unknown type. Need to know about it.
+ $self->warn(<<"...");
+YAML::Dumper can't handle dumping this type of data.
+Please report this to the author.
+
+id: $node_id
+type: $type
+class: $class
+value: $value
+
+...
+
+ return;
+}
+
+# Every data element and sub data element is a node.
+# Everything emitted goes through this function.
+sub _emit_node {
+ my $self = shift;
+ my ($type, $node_id);
+ my $ref = ref($_[0]);
+ if ($ref) {
+ if ($ref eq 'Regexp') {
+ $self->_emit(' !!perl/regexp');
+ $self->_emit_str("$_[0]");
+ return;
+ }
+ (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify);
+ }
+ else {
+ $type = $ref || 'SCALAR';
+ (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify);
+ }
+
+ my ($ynode, $tag) = ('') x 2;
+ my ($value, $context) = (@_, 0);
+
+ if (defined $self->transferred->{$node_id}) {
+ $value = $self->transferred->{$node_id};
+ $ynode = ynode($value);
+ if (ref $value) {
+ $tag = defined $ynode ? $ynode->tag->short : '';
+ (undef, $type, $node_id) =
+ $self->node_info($value, $self->stringify);
+ }
+ else {
+ $ynode = ynode($self->transferred->{$node_id});
+ $tag = defined $ynode ? $ynode->tag->short : '';
+ $type = 'SCALAR';
+ (undef, undef, $node_id) =
+ $self->node_info(
+ \ $self->transferred->{$node_id},
+ $self->stringify
+ );
+ }
+ }
+ elsif ($ynode = ynode($value)) {
+ $tag = $ynode->tag->short;
+ }
+
+ if ($self->use_aliases) {
+ $self->{id_refcnt}{$node_id} ||= 0;
+ if ($self->{id_refcnt}{$node_id} > 1) {
+ if (defined $self->{id_anchor}{$node_id}) {
+ $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n";
+ return;
+ }
+ my $anchor = $self->anchor_prefix . $self->{anchor}++;
+ $self->{stream} .= ' &' . $anchor;
+ $self->{id_anchor}{$node_id} = $anchor;
+ }
+ }
+
+ return $self->_emit_str("$value") # Stringified object
+ if ref($value) and not $type;
+ return $self->_emit_scalar($value, $tag)
+ if $type eq 'SCALAR' and $tag;
+ return $self->_emit_str($value)
+ if $type eq 'SCALAR';
+ return $self->_emit_mapping($value, $tag, $node_id, $context)
+ if $type eq 'HASH';
+ return $self->_emit_sequence($value, $tag)
+ if $type eq 'ARRAY';
+ $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type);
+ return $self->_emit_str("$value");
+}
+
+# A YAML mapping is akin to a Perl hash.
+sub _emit_mapping {
+ my $self = shift;
+ my ($value, $tag, $node_id, $context) = @_;
+ $self->{stream} .= " !$tag" if $tag;
+
+ # Sometimes 'keys' fails. Like on a bad tie implementation.
+ my $empty_hash = not(eval {keys %$value});
+ $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@;
+ return ($self->{stream} .= " {}\n") if $empty_hash;
+
+ # If CompressSeries is on (default) and legal is this context, then
+ # use it and make the indent level be 2 for this node.
+ if ($context == FROMARRAY and
+ $self->compress_series and
+ not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash)
+ ) {
+ $self->{stream} .= ' ';
+ $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2;
+ }
+ else {
+ $context = 0;
+ $self->{stream} .= "\n"
+ unless $self->headless && not($self->headless(0));
+ $self->offset->[$self->level+1] =
+ $self->offset->[$self->level] + $self->indent_width;
+ }
+
+ $self->{level}++;
+ my @keys;
+ if ($self->sort_keys == 1) {
+ if (ynode($value)) {
+ @keys = keys %$value;
+ }
+ else {
+ @keys = sort keys %$value;
+ }
+ }
+ elsif ($self->sort_keys == 2) {
+ @keys = sort keys %$value;
+ }
+ # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
+ elsif (ref($self->sort_keys) eq 'ARRAY') {
+ my $i = 1;
+ my %order = map { ($_, $i++) } @{$self->sort_keys};
+ @keys = sort {
+ (defined $order{$a} and defined $order{$b})
+ ? ($order{$a} <=> $order{$b})
+ : ($a cmp $b);
+ } keys %$value;
+ }
+ else {
+ @keys = keys %$value;
+ }
+ # Force the YAML::VALUE ('=') key to sort last.
+ if (exists $value->{&VALUE}) {
+ for (my $i = 0; $i < @keys; $i++) {
+ if ($keys[$i] eq &VALUE) {
+ splice(@keys, $i, 1);
+ push @keys, &VALUE;
+ last;
+ }
+ }
+ }
+
+ for my $key (@keys) {
+ $self->_emit_key($key, $context);
+ $context = 0;
+ $self->{stream} .= ':';
+ $self->_emit_node($value->{$key});
+ }
+ $self->{level}--;
+}
+
+# A YAML series is akin to a Perl array.
+sub _emit_sequence {
+ my $self = shift;
+ my ($value, $tag) = @_;
+ $self->{stream} .= " !$tag" if $tag;
+
+ return ($self->{stream} .= " []\n") if @$value == 0;
+
+ $self->{stream} .= "\n"
+ unless $self->headless && not($self->headless(0));
+
+ # XXX Really crufty feature. Better implemented by ynodes.
+ if ($self->inline_series and
+ @$value <= $self->inline_series and
+ not (scalar grep {ref or /\n/} @$value)
+ ) {
+ $self->{stream} =~ s/\n\Z/ /;
+ $self->{stream} .= '[';
+ for (my $i = 0; $i < @$value; $i++) {
+ $self->_emit_str($value->[$i], KEY);
+ last if $i == $#{$value};
+ $self->{stream} .= ', ';
+ }
+ $self->{stream} .= "]\n";
+ return;
+ }
+
+ $self->offset->[$self->level + 1] =
+ $self->offset->[$self->level] + $self->indent_width;
+ $self->{level}++;
+ for my $val (@$value) {
+ $self->{stream} .= ' ' x $self->offset->[$self->level];
+ $self->{stream} .= '-';
+ $self->_emit_node($val, FROMARRAY);
+ }
+ $self->{level}--;
+}
+
+# Emit a mapping key
+sub _emit_key {
+ my $self = shift;
+ my ($value, $context) = @_;
+ $self->{stream} .= ' ' x $self->offset->[$self->level]
+ unless $context == FROMARRAY;
+ $self->_emit_str($value, KEY);
+}
+
+# Emit a blessed SCALAR
+sub _emit_scalar {
+ my $self = shift;
+ my ($value, $tag) = @_;
+ $self->{stream} .= " !$tag";
+ $self->_emit_str($value, BLESSED);
+}
+
+sub _emit {
+ my $self = shift;
+ $self->{stream} .= join '', @_;
+}
+
+# Emit a string value. YAML has many scalar styles. This routine attempts to
+# guess the best style for the text.
+sub _emit_str {
+ my $self = shift;
+ my $type = $_[1] || 0;
+
+ # Use heuristics to find the best scalar emission style.
+ $self->offset->[$self->level + 1] =
+ $self->offset->[$self->level] + $self->indent_width;
+ $self->{level}++;
+
+ my $sf = $type == KEY ? '' : ' ';
+ my $sb = $type == KEY ? '? ' : ' ';
+ my $ef = $type == KEY ? '' : "\n";
+ my $eb = "\n";
+
+ while (1) {
+ $self->_emit($sf),
+ $self->_emit_plain($_[0]),
+ $self->_emit($ef), last
+ if not defined $_[0];
+ $self->_emit($sf, '=', $ef), last
+ if $_[0] eq VALUE;
+ $self->_emit($sf),
+ $self->_emit_double($_[0]),
+ $self->_emit($ef), last
+ if $_[0] =~ /$ESCAPE_CHAR/;
+ if ($_[0] =~ /\n/) {
+ $self->_emit($sb),
+ $self->_emit_block($LIT_CHAR, $_[0]),
+ $self->_emit($eb), last
+ if $self->use_block;
+ Carp::cluck "[YAML] \$UseFold is no longer supported"
+ if $self->use_fold;
+ $self->_emit($sf),
+ $self->_emit_double($_[0]),
+ $self->_emit($ef), last
+ if length $_[0] <= 30;
+ $self->_emit($sf),
+ $self->_emit_double($_[0]),
+ $self->_emit($ef), last
+ if $_[0] !~ /\n\s*\S/;
+ $self->_emit($sb),
+ $self->_emit_block($LIT_CHAR, $_[0]),
+ $self->_emit($eb), last;
+ }
+ $self->_emit($sf),
+ $self->_emit_plain($_[0]),
+ $self->_emit($ef), last
+ if $self->is_valid_plain($_[0]);
+ $self->_emit($sf),
+ $self->_emit_double($_[0]),
+ $self->_emit($ef), last
+ if $_[0] =~ /'/;
+ $self->_emit($sf),
+ $self->_emit_single($_[0]),
+ $self->_emit($ef);
+ last;
+ }
+
+ $self->{level}--;
+
+ return;
+}
+
+# Check whether or not a scalar should be emitted as an plain scalar.
+sub is_valid_plain {
+ my $self = shift;
+ return 0 unless length $_[0];
+ # refer to YAML::Loader::parse_inline_simple()
+ return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/;
+ return 0 if $_[0] =~ /[\{\[\]\},]/;
+ return 0 if $_[0] =~ /[:\-\?]\s/;
+ return 0 if $_[0] =~ /\s#/;
+ return 0 if $_[0] =~ /\:(\s|$)/;
+ return 0 if $_[0] =~ /[\s\|\>]$/;
+ return 1;
+}
+
+sub _emit_block {
+ my $self = shift;
+ my ($indicator, $value) = @_;
+ $self->{stream} .= $indicator;
+ $value =~ /(\n*)\Z/;
+ my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
+ $value = '~' if not defined $value;
+ $self->{stream} .= $chomp;
+ $self->{stream} .= $self->indent_width if $value =~ /^\s/;
+ $self->{stream} .= $self->indent($value);
+}
+
+# Plain means that the scalar is unquoted.
+sub _emit_plain {
+ my $self = shift;
+ $self->{stream} .= defined $_[0] ? $_[0] : '~';
+}
+
+# Double quoting is for single lined escaped strings.
+sub _emit_double {
+ my $self = shift;
+ (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
+ $self->{stream} .= qq{"$escaped"};
+}
+
+# Single quoting is for single lined unescaped strings.
+sub _emit_single {
+ my $self = shift;
+ my $item = shift;
+ $item =~ s{'}{''}g;
+ $self->{stream} .= "'$item'";
+}
+
+#==============================================================================
+# Utility subroutines.
+#==============================================================================
+
+# Indent a scalar to the current indentation level.
+sub indent {
+ my $self = shift;
+ my ($text) = @_;
+ return $text unless length $text;
+ $text =~ s/\n\Z//;
+ my $indent = ' ' x $self->offset->[$self->level];
+ $text =~ s/^/$indent/gm;
+ $text = "\n$text";
+ return $text;
+}
+
+# Escapes for unprintable characters
+my @escapes = qw(\0 \x01 \x02 \x03 \x04 \x05 \x06 \a
+ \x08 \t \n \v \f \r \x0e \x0f
+ \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
+ \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f
+ );
+
+# Escape the unprintable characters
+sub escape {
+ my $self = shift;
+ my ($text) = @_;
+ $text =~ s/\\/\\\\/g;
+ $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
+ return $text;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Dumper - YAML class for dumping Perl objects to YAML
+
+=head1 SYNOPSIS
+
+ use YAML::Dumper;
+ my $dumper = YAML::Dumper->new;
+ $dumper->indent_width(4);
+ print $dumper->dump({foo => 'bar'});
+
+=head1 DESCRIPTION
+
+YAML::Dumper is the module that YAML.pm used to serialize Perl objects to
+YAML. It is fully object oriented and usable on its own.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Dumper/Base.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper/Base.pm
new file mode 100755
index 00000000000..70b1e587a3a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper/Base.pm
@@ -0,0 +1,142 @@
+package YAML::Dumper::Base;
+
+use strict;
+use warnings;
+use YAML::Base;
+use YAML::Node;
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Base';
+
+# YAML Dumping options
+field spec_version => '1.0';
+field indent_width => 2;
+field use_header => 1;
+field use_version => 0;
+field sort_keys => 1;
+field anchor_prefix => '';
+field dump_code => 0;
+field use_block => 0;
+field use_fold => 0;
+field compress_series => 1;
+field inline_series => 0;
+field use_aliases => 1;
+field purity => 0;
+field stringify => 0;
+
+# Properties
+field stream => '';
+field document => 0;
+field transferred => {};
+field id_refcnt => {};
+field id_anchor => {};
+field anchor => 1;
+field level => 0;
+field offset => [];
+field headless => 0;
+field blessed_map => {};
+
+# Global Options are an idea taken from Data::Dumper. Really they are just
+# sugar on top of real OO properties. They make the simple Dump/Load API
+# easy to configure.
+sub set_global_options {
+ my $self = shift;
+ $self->spec_version($YAML::SpecVersion)
+ if defined $YAML::SpecVersion;
+ $self->indent_width($YAML::Indent)
+ if defined $YAML::Indent;
+ $self->use_header($YAML::UseHeader)
+ if defined $YAML::UseHeader;
+ $self->use_version($YAML::UseVersion)
+ if defined $YAML::UseVersion;
+ $self->sort_keys($YAML::SortKeys)
+ if defined $YAML::SortKeys;
+ $self->anchor_prefix($YAML::AnchorPrefix)
+ if defined $YAML::AnchorPrefix;
+ $self->dump_code($YAML::DumpCode || $YAML::UseCode)
+ if defined $YAML::DumpCode or defined $YAML::UseCode;
+ $self->use_block($YAML::UseBlock)
+ if defined $YAML::UseBlock;
+ $self->use_fold($YAML::UseFold)
+ if defined $YAML::UseFold;
+ $self->compress_series($YAML::CompressSeries)
+ if defined $YAML::CompressSeries;
+ $self->inline_series($YAML::InlineSeries)
+ if defined $YAML::InlineSeries;
+ $self->use_aliases($YAML::UseAliases)
+ if defined $YAML::UseAliases;
+ $self->purity($YAML::Purity)
+ if defined $YAML::Purity;
+ $self->stringify($YAML::Stringify)
+ if defined $YAML::Stringify;
+}
+
+sub dump {
+ my $self = shift;
+ $self->die('dump() not implemented in this class.');
+}
+
+sub blessed {
+ my $self = shift;
+ my ($ref) = @_;
+ $ref = \$_[0] unless ref $ref;
+ my (undef, undef, $node_id) = YAML::Base->node_info($ref);
+ $self->{blessed_map}->{$node_id};
+}
+
+sub bless {
+ my $self = shift;
+ my ($ref, $blessing) = @_;
+ my $ynode;
+ $ref = \$_[0] unless ref $ref;
+ my (undef, undef, $node_id) = YAML::Base->node_info($ref);
+ if (not defined $blessing) {
+ $ynode = YAML::Node->new($ref);
+ }
+ elsif (ref $blessing) {
+ $self->die() unless ynode($blessing);
+ $ynode = $blessing;
+ }
+ else {
+ no strict 'refs';
+ my $transfer = $blessing . "::yaml_dump";
+ $self->die() unless defined &{$transfer};
+ $ynode = &{$transfer}($ref);
+ $self->die() unless ynode($ynode);
+ }
+ $self->{blessed_map}->{$node_id} = $ynode;
+ my $object = ynode($ynode) or $self->die();
+ return $object;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Dumper::Base - Base class for YAML Dumper classes
+
+=head1 SYNOPSIS
+
+ package YAML::Dumper::Something;
+ use YAML::Dumper::Base -base;
+
+=head1 DESCRIPTION
+
+YAML::Dumper::Base is a base class for creating YAML dumper classes.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Error.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Error.pm
new file mode 100755
index 00000000000..eb2a4be531d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Error.pm
@@ -0,0 +1,226 @@
+package YAML::Error;
+
+use strict;
+use warnings;
+use YAML::Base;
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Base';
+
+field 'code';
+field 'type' => 'Error';
+field 'line';
+field 'document';
+field 'arguments' => [];
+
+my ($error_messages, %line_adjust);
+
+sub format_message {
+ my $self = shift;
+ my $output = 'YAML ' . $self->type . ': ';
+ my $code = $self->code;
+ if ($error_messages->{$code}) {
+ $code = sprintf($error_messages->{$code}, @{$self->arguments});
+ }
+ $output .= $code . "\n";
+
+ $output .= ' Code: ' . $self->code . "\n"
+ if defined $self->code;
+ $output .= ' Line: ' . $self->line . "\n"
+ if defined $self->line;
+ $output .= ' Document: ' . $self->document . "\n"
+ if defined $self->document;
+ return $output;
+}
+
+sub error_messages {
+ $error_messages;
+}
+
+%$error_messages = map {s/^\s+//;$_} split "\n", <<'...';
+YAML_PARSE_ERR_BAD_CHARS
+ Invalid characters in stream. This parser only supports printable ASCII
+YAML_PARSE_ERR_NO_FINAL_NEWLINE
+ Stream does not end with newline character
+YAML_PARSE_ERR_BAD_MAJOR_VERSION
+ Can't parse a %s document with a 1.0 parser
+YAML_PARSE_WARN_BAD_MINOR_VERSION
+ Parsing a %s document with a 1.0 parser
+YAML_PARSE_WARN_MULTIPLE_DIRECTIVES
+ '%s directive used more than once'
+YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
+ No text allowed after indicator
+YAML_PARSE_ERR_NO_ANCHOR
+ No anchor for alias '*%s'
+YAML_PARSE_ERR_NO_SEPARATOR
+ Expected separator '---'
+YAML_PARSE_ERR_SINGLE_LINE
+ Couldn't parse single line value
+YAML_PARSE_ERR_BAD_ANCHOR
+ Invalid anchor
+YAML_DUMP_ERR_INVALID_INDENT
+ Invalid Indent width specified: '%s'
+YAML_LOAD_USAGE
+ usage: YAML::Load($yaml_stream_scalar)
+YAML_PARSE_ERR_BAD_NODE
+ Can't parse node
+YAML_PARSE_ERR_BAD_EXPLICIT
+ Unsupported explicit transfer: '%s'
+YAML_DUMP_USAGE_DUMPCODE
+ Invalid value for DumpCode: '%s'
+YAML_LOAD_ERR_FILE_INPUT
+ Couldn't open %s for input:\n%s
+YAML_DUMP_ERR_FILE_CONCATENATE
+ Can't concatenate to YAML file %s
+YAML_DUMP_ERR_FILE_OUTPUT
+ Couldn't open %s for output:\n%s
+YAML_DUMP_ERR_NO_HEADER
+ With UseHeader=0, the node must be a plain hash or array
+YAML_DUMP_WARN_BAD_NODE_TYPE
+ Can't perform serialization for node type: '%s'
+YAML_EMIT_WARN_KEYS
+ Encountered a problem with 'keys':\n%s
+YAML_DUMP_WARN_DEPARSE_FAILED
+ Deparse failed for CODE reference
+YAML_DUMP_WARN_CODE_DUMMY
+ Emitting dummy subroutine for CODE reference
+YAML_PARSE_ERR_MANY_EXPLICIT
+ More than one explicit transfer
+YAML_PARSE_ERR_MANY_IMPLICIT
+ More than one implicit request
+YAML_PARSE_ERR_MANY_ANCHOR
+ More than one anchor
+YAML_PARSE_ERR_ANCHOR_ALIAS
+ Can't define both an anchor and an alias
+YAML_PARSE_ERR_BAD_ALIAS
+ Invalid alias
+YAML_PARSE_ERR_MANY_ALIAS
+ More than one alias
+YAML_LOAD_ERR_NO_CONVERT
+ Can't convert implicit '%s' node to explicit '%s' node
+YAML_LOAD_ERR_NO_DEFAULT_VALUE
+ No default value for '%s' explicit transfer
+YAML_LOAD_ERR_NON_EMPTY_STRING
+ Only the empty string can be converted to a '%s'
+YAML_LOAD_ERR_BAD_MAP_TO_SEQ
+ Can't transfer map as sequence. Non numeric key '%s' encountered.
+YAML_DUMP_ERR_BAD_GLOB
+ '%s' is an invalid value for Perl glob
+YAML_DUMP_ERR_BAD_REGEXP
+ '%s' is an invalid value for Perl Regexp
+YAML_LOAD_ERR_BAD_MAP_ELEMENT
+ Invalid element in map
+YAML_LOAD_WARN_DUPLICATE_KEY
+ Duplicate map key found. Ignoring.
+YAML_LOAD_ERR_BAD_SEQ_ELEMENT
+ Invalid element in sequence
+YAML_PARSE_ERR_INLINE_MAP
+ Can't parse inline map
+YAML_PARSE_ERR_INLINE_SEQUENCE
+ Can't parse inline sequence
+YAML_PARSE_ERR_BAD_DOUBLE
+ Can't parse double quoted string
+YAML_PARSE_ERR_BAD_SINGLE
+ Can't parse single quoted string
+YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
+ Can't parse inline implicit value '%s'
+YAML_PARSE_ERR_BAD_IMPLICIT
+ Unrecognized implicit value '%s'
+YAML_PARSE_ERR_INDENTATION
+ Error. Invalid indentation level
+YAML_PARSE_ERR_INCONSISTENT_INDENTATION
+ Inconsistent indentation level
+YAML_LOAD_WARN_UNRESOLVED_ALIAS
+ Can't resolve alias *%s
+YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
+ No 'REGEXP' element for Perl regexp
+YAML_LOAD_WARN_BAD_REGEXP_ELEM
+ Unknown element '%s' in Perl regexp
+YAML_LOAD_WARN_GLOB_NAME
+ No 'NAME' element for Perl glob
+YAML_LOAD_WARN_PARSE_CODE
+ Couldn't parse Perl code scalar: %s
+YAML_LOAD_WARN_CODE_DEPARSE
+ Won't parse Perl code unless $YAML::LoadCode is set
+YAML_EMIT_ERR_BAD_LEVEL
+ Internal Error: Bad level detected
+YAML_PARSE_WARN_AMBIGUOUS_TAB
+ Amibiguous tab converted to spaces
+YAML_LOAD_WARN_BAD_GLOB_ELEM
+ Unknown element '%s' in Perl glob
+YAML_PARSE_ERR_ZERO_INDENT
+ Can't use zero as an indentation width
+YAML_LOAD_WARN_GLOB_IO
+ Can't load an IO filehandle. Yet!!!
+...
+
+%line_adjust = map {($_, 1)}
+ qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION
+ YAML_PARSE_WARN_BAD_MINOR_VERSION
+ YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
+ YAML_PARSE_ERR_NO_ANCHOR
+ YAML_PARSE_ERR_MANY_EXPLICIT
+ YAML_PARSE_ERR_MANY_IMPLICIT
+ YAML_PARSE_ERR_MANY_ANCHOR
+ YAML_PARSE_ERR_ANCHOR_ALIAS
+ YAML_PARSE_ERR_BAD_ALIAS
+ YAML_PARSE_ERR_MANY_ALIAS
+ YAML_LOAD_ERR_NO_CONVERT
+ YAML_LOAD_ERR_NO_DEFAULT_VALUE
+ YAML_LOAD_ERR_NON_EMPTY_STRING
+ YAML_LOAD_ERR_BAD_MAP_TO_SEQ
+ YAML_LOAD_ERR_BAD_STR_TO_INT
+ YAML_LOAD_ERR_BAD_STR_TO_DATE
+ YAML_LOAD_ERR_BAD_STR_TO_TIME
+ YAML_LOAD_WARN_DUPLICATE_KEY
+ YAML_PARSE_ERR_INLINE_MAP
+ YAML_PARSE_ERR_INLINE_SEQUENCE
+ YAML_PARSE_ERR_BAD_DOUBLE
+ YAML_PARSE_ERR_BAD_SINGLE
+ YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
+ YAML_PARSE_ERR_BAD_IMPLICIT
+ YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
+ YAML_LOAD_WARN_BAD_REGEXP_ELEM
+ YAML_LOAD_WARN_REGEXP_CREATE
+ YAML_LOAD_WARN_GLOB_NAME
+ YAML_LOAD_WARN_PARSE_CODE
+ YAML_LOAD_WARN_CODE_DEPARSE
+ YAML_LOAD_WARN_BAD_GLOB_ELEM
+ YAML_PARSE_ERR_ZERO_INDENT
+ );
+
+package YAML::Warning;
+
+our @ISA = 'YAML::Error';
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Error - Error formatting class for YAML modules
+
+=head1 SYNOPSIS
+
+ $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias);
+ $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
+
+=head1 DESCRIPTION
+
+This module provides a C<die> and a C<warn> facility.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Loader.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Loader.pm
new file mode 100755
index 00000000000..258ddd50335
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Loader.pm
@@ -0,0 +1,790 @@
+package YAML::Loader;
+
+use strict;
+use warnings;
+use YAML::Base;
+use YAML::Loader::Base;
+use YAML::Types;
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Loader::Base';
+
+# Context constants
+use constant LEAF => 1;
+use constant COLLECTION => 2;
+use constant VALUE => "\x07YAML\x07VALUE\x07";
+use constant COMMENT => "\x07YAML\x07COMMENT\x07";
+
+# Common YAML character sets
+my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
+my $FOLD_CHAR = '>';
+my $LIT_CHAR = '|';
+my $LIT_CHAR_RX = "\\$LIT_CHAR";
+
+sub load {
+ my $self = shift;
+ $self->stream($_[0] || '');
+ return $self->_parse();
+}
+
+# Top level function for parsing. Parse each document in order and
+# handle processing for YAML headers.
+sub _parse {
+ my $self = shift;
+ my (%directives, $preface);
+ $self->{stream} =~ s|\015\012|\012|g;
+ $self->{stream} =~ s|\015|\012|g;
+ $self->line(0);
+ $self->die('YAML_PARSE_ERR_BAD_CHARS')
+ if $self->stream =~ /$ESCAPE_CHAR/;
+ $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
+ if length($self->stream) and
+ $self->{stream} !~ s/(.)\n\Z/$1/s;
+ $self->lines([split /\x0a/, $self->stream, -1]);
+ $self->line(1);
+ # Throw away any comments or blanks before the header (or start of
+ # content for headerless streams)
+ $self->_parse_throwaway_comments();
+ $self->document(0);
+ $self->documents([]);
+ # Add an "assumed" header if there is no header and the stream is
+ # not empty (after initial throwaways).
+ if (not $self->eos) {
+ if ($self->lines->[0] !~ /^---(\s|$)/) {
+ unshift @{$self->lines}, '---';
+ $self->{line}--;
+ }
+ }
+
+ # Main Loop. Parse out all the top level nodes and return them.
+ while (not $self->eos) {
+ $self->anchor2node({});
+ $self->{document}++;
+ $self->done(0);
+ $self->level(0);
+ $self->offset->[0] = -1;
+
+ if ($self->lines->[0] =~ /^---\s*(.*)$/) {
+ my @words = split /\s+/, $1;
+ %directives = ();
+ while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) {
+ my ($key, $value) = ($1, $2);
+ shift(@words);
+ if (defined $directives{$key}) {
+ $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES',
+ $key, $self->document);
+ next;
+ }
+ $directives{$key} = $value;
+ }
+ $self->preface(join ' ', @words);
+ }
+ else {
+ $self->die('YAML_PARSE_ERR_NO_SEPARATOR');
+ }
+
+ if (not $self->done) {
+ $self->_parse_next_line(COLLECTION);
+ }
+ if ($self->done) {
+ $self->{indent} = -1;
+ $self->content('');
+ }
+
+ $directives{YAML} ||= '1.0';
+ $directives{TAB} ||= 'NONE';
+ ($self->{major_version}, $self->{minor_version}) =
+ split /\./, $directives{YAML}, 2;
+ $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML})
+ if $self->major_version ne '1';
+ $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML})
+ if $self->minor_version ne '0';
+ $self->die('Unrecognized TAB policy')
+ unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/;
+
+ push @{$self->documents}, $self->_parse_node();
+ }
+ return wantarray ? @{$self->documents} : $self->documents->[-1];
+}
+
+# This function is the dispatcher for parsing each node. Every node
+# recurses back through here. (Inlines are an exception as they have
+# their own sub-parser.)
+sub _parse_node {
+ my $self = shift;
+ my $preface = $self->preface;
+ $self->preface('');
+ my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
+ my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
+ ($anchor, $alias, $explicit, $implicit, $preface) =
+ $self->_parse_qualifiers($preface);
+ if ($anchor) {
+ $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
+ }
+ $self->inline('');
+ while (length $preface) {
+ my $line = $self->line - 1;
+ if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
+ $indicator = $1;
+ $chomp = $2 if defined($2);
+ }
+ else {
+ $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator;
+ $self->inline($preface);
+ $preface = '';
+ }
+ }
+ if ($alias) {
+ $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
+ unless defined $self->anchor2node->{$alias};
+ if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
+ $node = $self->anchor2node->{$alias};
+ }
+ else {
+ $node = do {my $sv = "*$alias"};
+ push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
+ }
+ }
+ elsif (length $self->inline) {
+ $node = $self->_parse_inline(1, $implicit, $explicit);
+ if (length $self->inline) {
+ $self->die('YAML_PARSE_ERR_SINGLE_LINE');
+ }
+ }
+ elsif ($indicator eq $LIT_CHAR) {
+ $self->{level}++;
+ $node = $self->_parse_block($chomp);
+ $node = $self->_parse_implicit($node) if $implicit;
+ $self->{level}--;
+ }
+ elsif ($indicator eq $FOLD_CHAR) {
+ $self->{level}++;
+ $node = $self->_parse_unfold($chomp);
+ $node = $self->_parse_implicit($node) if $implicit;
+ $self->{level}--;
+ }
+ else {
+ $self->{level}++;
+ $self->offset->[$self->level] ||= 0;
+ if ($self->indent == $self->offset->[$self->level]) {
+ if ($self->content =~ /^-( |$)/) {
+ $node = $self->_parse_seq($anchor);
+ }
+ elsif ($self->content =~ /(^\?|\:( |$))/) {
+ $node = $self->_parse_mapping($anchor);
+ }
+ elsif ($preface =~ /^\s*$/) {
+ $node = $self->_parse_implicit('');
+ }
+ else {
+ $self->die('YAML_PARSE_ERR_BAD_NODE');
+ }
+ }
+ else {
+ $node = undef;
+ }
+ $self->{level}--;
+ }
+ $#{$self->offset} = $self->level;
+
+ if ($explicit) {
+ if ($class) {
+ if (not ref $node) {
+ my $copy = $node;
+ undef $node;
+ $node = \$copy;
+ }
+ CORE::bless $node, $class;
+ }
+ else {
+ $node = $self->_parse_explicit($node, $explicit);
+ }
+ }
+ if ($anchor) {
+ if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
+ # XXX Can't remember what this code actually does
+ for my $ref (@{$self->anchor2node->{$anchor}}) {
+ ${$ref->[0]} = $node;
+ $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
+ $anchor, $ref->[1]);
+ }
+ }
+ $self->anchor2node->{$anchor} = $node;
+ }
+ return $node;
+}
+
+# Preprocess the qualifiers that may be attached to any node.
+sub _parse_qualifiers {
+ my $self = shift;
+ my ($preface) = @_;
+ my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5;
+ $self->inline('');
+ while ($preface =~ /^[&*!]/) {
+ my $line = $self->line - 1;
+ if ($preface =~ s/^\!(\S+)\s*//) {
+ $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit;
+ $explicit = $1;
+ }
+ elsif ($preface =~ s/^\!\s*//) {
+ $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit;
+ $implicit = 1;
+ }
+ elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
+ $token = $1;
+ $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
+ unless $token =~ /^[a-zA-Z0-9]+$/;
+ $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor;
+ $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias;
+ $anchor = $token;
+ }
+ elsif ($preface =~ s/^\*([^ ,:]+)\s*//) {
+ $token = $1;
+ $self->die('YAML_PARSE_ERR_BAD_ALIAS')
+ unless $token =~ /^[a-zA-Z0-9]+$/;
+ $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias;
+ $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor;
+ $alias = $token;
+ }
+ }
+ return ($anchor, $alias, $explicit, $implicit, $preface);
+}
+
+# Morph a node to it's explicit type
+sub _parse_explicit {
+ my $self = shift;
+ my ($node, $explicit) = @_;
+ my ($type, $class);
+ if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) {
+ ($type, $class) = (($1 || ''), ($2 || ''));
+
+ # FIXME # die unless uc($type) eq ref($node) ?
+
+ if ( $type eq "ref" ) {
+ $self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit)
+ unless exists $node->{VALUE()} and scalar(keys %$node) == 1;
+
+ my $value = $node->{VALUE()};
+ $node = \$value;
+ }
+
+ if ( $type eq "scalar" and length($class) and !ref($node) ) {
+ my $value = $node;
+ $node = \$value;
+ }
+
+ if ( length($class) ) {
+ CORE::bless($node, $class);
+ }
+
+ return $node;
+ }
+ if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) {
+ ($type, $class) = (($1 || ''), ($2 || ''));
+ my $type_class = "YAML::Type::$type";
+ no strict 'refs';
+ if ($type_class->can('yaml_load')) {
+ return $type_class->yaml_load($node, $class, $self);
+ }
+ else {
+ $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit);
+ }
+ }
+ # This !perl/@Foo and !perl/$Foo are deprecated but still parsed
+ elsif ($YAML::TagClass->{$explicit} ||
+ $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$}
+ ) {
+ $class = $YAML::TagClass->{$explicit} || $2;
+ if ($class->can('yaml_load')) {
+ require YAML::Node;
+ return $class->yaml_load(YAML::Node->new($node, $explicit));
+ }
+ else {
+ if (ref $node) {
+ return CORE::bless $node, $class;
+ }
+ else {
+ return CORE::bless \$node, $class;
+ }
+ }
+ }
+ elsif (ref $node) {
+ require YAML::Node;
+ return YAML::Node->new($node, $explicit);
+ }
+ else {
+ # XXX This is likely wrong. Failing test:
+ # --- !unknown 'scalar value'
+ return $node;
+ }
+}
+
+# Parse a YAML mapping into a Perl hash
+sub _parse_mapping {
+ my $self = shift;
+ my ($anchor) = @_;
+ my $mapping = {};
+ $self->anchor2node->{$anchor} = $mapping;
+ my $key;
+ while (not $self->done and $self->indent == $self->offset->[$self->level]) {
+ # If structured key:
+ if ($self->{content} =~ s/^\?\s*//) {
+ $self->preface($self->content);
+ $self->_parse_next_line(COLLECTION);
+ $key = $self->_parse_node();
+ $key = "$key";
+ }
+ # If "default" key (equals sign)
+ elsif ($self->{content} =~ s/^\=\s*//) {
+ $key = VALUE;
+ }
+ # If "comment" key (slash slash)
+ elsif ($self->{content} =~ s/^\=\s*//) {
+ $key = COMMENT;
+ }
+ # Regular scalar key:
+ else {
+ $self->inline($self->content);
+ $key = $self->_parse_inline();
+ $key = "$key";
+ $self->content($self->inline);
+ $self->inline('');
+ }
+
+ unless ($self->{content} =~ s/^:\s*//) {
+ $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
+ }
+ $self->preface($self->content);
+ my $line = $self->line;
+ $self->_parse_next_line(COLLECTION);
+ my $value = $self->_parse_node();
+ if (exists $mapping->{$key}) {
+ $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
+ }
+ else {
+ $mapping->{$key} = $value;
+ }
+ }
+ return $mapping;
+}
+
+# Parse a YAML sequence into a Perl array
+sub _parse_seq {
+ my $self = shift;
+ my ($anchor) = @_;
+ my $seq = [];
+ $self->anchor2node->{$anchor} = $seq;
+ while (not $self->done and $self->indent == $self->offset->[$self->level]) {
+ if ($self->content =~ /^-(?: (.*))?$/) {
+ $self->preface(defined($1) ? $1 : '');
+ }
+ else {
+ $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT');
+ }
+ if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) {
+ $self->indent($self->offset->[$self->level] + 2 + length($1));
+ $self->content($2);
+ $self->level($self->level + 1);
+ $self->offset->[$self->level] = $self->indent;
+ $self->preface('');
+ push @$seq, $self->_parse_mapping('');
+ $self->{level}--;
+ $#{$self->offset} = $self->level;
+ }
+ else {
+ $self->_parse_next_line(COLLECTION);
+ push @$seq, $self->_parse_node();
+ }
+ }
+ return $seq;
+}
+
+# Parse an inline value. Since YAML supports inline collections, this is
+# the top level of a sub parsing.
+sub _parse_inline {
+ my $self = shift;
+ my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
+ $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
+ my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
+ ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
+ $self->_parse_qualifiers($self->inline);
+ if ($anchor) {
+ $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
+ }
+ $implicit ||= $top_implicit;
+ $explicit ||= $top_explicit;
+ ($top_implicit, $top_explicit) = ('', '');
+ if ($alias) {
+ $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
+ unless defined $self->anchor2node->{$alias};
+ if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
+ $node = $self->anchor2node->{$alias};
+ }
+ else {
+ $node = do {my $sv = "*$alias"};
+ push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
+ }
+ }
+ elsif ($self->inline =~ /^\{/) {
+ $node = $self->_parse_inline_mapping($anchor);
+ }
+ elsif ($self->inline =~ /^\[/) {
+ $node = $self->_parse_inline_seq($anchor);
+ }
+ elsif ($self->inline =~ /^"/) {
+ $node = $self->_parse_inline_double_quoted();
+ $node = $self->_unescape($node);
+ $node = $self->_parse_implicit($node) if $implicit;
+ }
+ elsif ($self->inline =~ /^'/) {
+ $node = $self->_parse_inline_single_quoted();
+ $node = $self->_parse_implicit($node) if $implicit;
+ }
+ else {
+ if ($top) {
+ $node = $self->inline;
+ $self->inline('');
+ }
+ else {
+ $node = $self->_parse_inline_simple();
+ }
+ $node = $self->_parse_implicit($node) unless $explicit;
+ }
+ if ($explicit) {
+ $node = $self->_parse_explicit($node, $explicit);
+ }
+ if ($anchor) {
+ if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
+ for my $ref (@{$self->anchor2node->{$anchor}}) {
+ ${$ref->[0]} = $node;
+ $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
+ $anchor, $ref->[1]);
+ }
+ }
+ $self->anchor2node->{$anchor} = $node;
+ }
+ return $node;
+}
+
+# Parse the inline YAML mapping into a Perl hash
+sub _parse_inline_mapping {
+ my $self = shift;
+ my ($anchor) = @_;
+ my $node = {};
+ $self->anchor2node->{$anchor} = $node;
+
+ $self->die('YAML_PARSE_ERR_INLINE_MAP')
+ unless $self->{inline} =~ s/^\{\s*//;
+ while (not $self->{inline} =~ s/^\s*\}//) {
+ my $key = $self->_parse_inline();
+ $self->die('YAML_PARSE_ERR_INLINE_MAP')
+ unless $self->{inline} =~ s/^\: \s*//;
+ my $value = $self->_parse_inline();
+ if (exists $node->{$key}) {
+ $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
+ }
+ else {
+ $node->{$key} = $value;
+ }
+ next if $self->inline =~ /^\s*\}/;
+ $self->die('YAML_PARSE_ERR_INLINE_MAP')
+ unless $self->{inline} =~ s/^\,\s*//;
+ }
+ return $node;
+}
+
+# Parse the inline YAML sequence into a Perl array
+sub _parse_inline_seq {
+ my $self = shift;
+ my ($anchor) = @_;
+ my $node = [];
+ $self->anchor2node->{$anchor} = $node;
+
+ $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
+ unless $self->{inline} =~ s/^\[\s*//;
+ while (not $self->{inline} =~ s/^\s*\]//) {
+ my $value = $self->_parse_inline();
+ push @$node, $value;
+ next if $self->inline =~ /^\s*\]/;
+ $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
+ unless $self->{inline} =~ s/^\,\s*//;
+ }
+ return $node;
+}
+
+# Parse the inline double quoted string.
+sub _parse_inline_double_quoted {
+ my $self = shift;
+ my $node;
+ if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) {
+ $node = $1;
+ $self->inline($2);
+ $node =~ s/\\"/"/g;
+ }
+ else {
+ $self->die('YAML_PARSE_ERR_BAD_DOUBLE');
+ }
+ return $node;
+}
+
+
+# Parse the inline single quoted string.
+sub _parse_inline_single_quoted {
+ my $self = shift;
+ my $node;
+ if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) {
+ $node = $1;
+ $self->inline($2);
+ $node =~ s/''/'/g;
+ }
+ else {
+ $self->die('YAML_PARSE_ERR_BAD_SINGLE');
+ }
+ return $node;
+}
+
+# Parse the inline unquoted string and do implicit typing.
+sub _parse_inline_simple {
+ my $self = shift;
+ my $value;
+ if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) {
+ $value = $1;
+ substr($self->{inline}, 0, length($1)) = '';
+ }
+ else {
+ $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value);
+ }
+ return $value;
+}
+
+sub _parse_implicit {
+ my $self = shift;
+ my ($value) = @_;
+ $value =~ s/\s*$//;
+ return $value if $value eq '';
+ return undef if $value =~ /^~$/;
+ return $value
+ unless $value =~ /^[\@\`\^]/ or
+ $value =~ /^[\-\?]\s/;
+ $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value);
+}
+
+# Unfold a YAML multiline scalar into a single string.
+sub _parse_unfold {
+ my $self = shift;
+ my ($chomp) = @_;
+ my $node = '';
+ my $space = 0;
+ while (not $self->done and $self->indent == $self->offset->[$self->level]) {
+ $node .= $self->content. "\n";
+ $self->_parse_next_line(LEAF);
+ }
+ $node =~ s/^(\S.*)\n(?=\S)/$1 /gm;
+ $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm;
+ $node =~ s/\n*\Z// unless $chomp eq '+';
+ $node .= "\n" unless $chomp;
+ return $node;
+}
+
+# Parse a YAML block style scalar. This is like a Perl here-document.
+sub _parse_block {
+ my $self = shift;
+ my ($chomp) = @_;
+ my $node = '';
+ while (not $self->done and $self->indent == $self->offset->[$self->level]) {
+ $node .= $self->content . "\n";
+ $self->_parse_next_line(LEAF);
+ }
+ return $node if '+' eq $chomp;
+ $node =~ s/\n*\Z/\n/;
+ $node =~ s/\n\Z// if $chomp eq '-';
+ return $node;
+}
+
+# Handle Perl style '#' comments. Comments must be at the same indentation
+# level as the collection line following them.
+sub _parse_throwaway_comments {
+ my $self = shift;
+ while (@{$self->lines} and
+ $self->lines->[0] =~ m{^\s*(\#|$)}
+ ) {
+ shift @{$self->lines};
+ $self->{line}++;
+ }
+ $self->eos($self->{done} = not @{$self->lines});
+}
+
+# This is the routine that controls what line is being parsed. It gets called
+# once for each line in the YAML stream.
+#
+# This routine must:
+# 1) Skip past the current line
+# 2) Determine the indentation offset for a new level
+# 3) Find the next _content_ line
+# A) Skip over any throwaways (Comments/blanks)
+# B) Set $self->indent, $self->content, $self->line
+# 4) Expand tabs appropriately
+sub _parse_next_line {
+ my $self = shift;
+ my ($type) = @_;
+ my $level = $self->level;
+ my $offset = $self->offset->[$level];
+ $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset;
+ shift @{$self->lines};
+ $self->eos($self->{done} = not @{$self->lines});
+ return if $self->eos;
+ $self->{line}++;
+
+ # Determine the offset for a new leaf node
+ if ($self->preface =~
+ qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/
+ ) {
+ $self->die('YAML_PARSE_ERR_ZERO_INDENT')
+ if length($1) and $1 == 0;
+ $type = LEAF;
+ if (length($1)) {
+ $self->offset->[$level + 1] = $offset + $1;
+ }
+ else {
+ # First get rid of any comments.
+ while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) {
+ $self->lines->[0] =~ /^( *)/ or die;
+ last unless length($1) <= $offset;
+ shift @{$self->lines};
+ $self->{line}++;
+ }
+ $self->eos($self->{done} = not @{$self->lines});
+ return if $self->eos;
+ if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) {
+ $self->offset->[$level+1] = length($1);
+ }
+ else {
+ $self->offset->[$level+1] = $offset + 1;
+ }
+ }
+ $offset = $self->offset->[++$level];
+ }
+ # Determine the offset for a new collection level
+ elsif ($type == COLLECTION and
+ $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
+ $self->_parse_throwaway_comments();
+ if ($self->eos) {
+ $self->offset->[$level+1] = $offset + 1;
+ return;
+ }
+ else {
+ $self->lines->[0] =~ /^( *)\S/ or die;
+ if (length($1) > $offset) {
+ $self->offset->[$level+1] = length($1);
+ }
+ else {
+ $self->offset->[$level+1] = $offset + 1;
+ }
+ }
+ $offset = $self->offset->[++$level];
+ }
+
+ if ($type == LEAF) {
+ while (@{$self->lines} and
+ $self->lines->[0] =~ m{^( *)(\#)} and
+ length($1) < $offset
+ ) {
+ shift @{$self->lines};
+ $self->{line}++;
+ }
+ $self->eos($self->{done} = not @{$self->lines});
+ }
+ else {
+ $self->_parse_throwaway_comments();
+ }
+ return if $self->eos;
+
+ if ($self->lines->[0] =~ /^---(\s|$)/) {
+ $self->done(1);
+ return;
+ }
+ if ($type == LEAF and
+ $self->lines->[0] =~ /^ {$offset}(.*)$/
+ ) {
+ $self->indent($offset);
+ $self->content($1);
+ }
+ elsif ($self->lines->[0] =~ /^\s*$/) {
+ $self->indent($offset);
+ $self->content('');
+ }
+ else {
+ $self->lines->[0] =~ /^( *)(\S.*)$/;
+ while ($self->offset->[$level] > length($1)) {
+ $level--;
+ }
+ $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
+ if $self->offset->[$level] != length($1);
+ $self->indent(length($1));
+ $self->content($2);
+ }
+ $self->die('YAML_PARSE_ERR_INDENTATION')
+ if $self->indent - $offset > 1;
+}
+
+#==============================================================================
+# Utility subroutines.
+#==============================================================================
+
+# Printable characters for escapes
+my %unescapes = (
+ 0 => "\x00",
+ a => "\x07",
+ t => "\x09",
+ n => "\x0a",
+ 'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted
+ f => "\x0c",
+ r => "\x0d",
+ e => "\x1b",
+ '\\' => '\\',
+ );
+
+# Transform all the backslash style escape characters to their literal meaning
+sub _unescape {
+ my $self = shift;
+ my ($node) = @_;
+ $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
+ (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
+ return $node;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Loader - YAML class for loading Perl objects to YAML
+
+=head1 SYNOPSIS
+
+ use YAML::Loader;
+ my $loader = YAML::Loader->new;
+ my $hash = $loader->load(<<'...');
+ foo: bar
+ ...
+
+=head1 DESCRIPTION
+
+YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl
+objects. It is fully object oriented and usable on its own.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Loader/Base.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Loader/Base.pm
new file mode 100755
index 00000000000..6733ad6e313
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Loader/Base.pm
@@ -0,0 +1,68 @@
+package YAML::Loader::Base;
+
+use strict;
+use warnings;
+use YAML::Base;
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Base';
+
+field load_code => 0;
+field stream => '';
+field document => 0;
+field line => 0;
+field documents => [];
+field lines => [];
+field eos => 0;
+field done => 0;
+field anchor2node => {};
+field level => 0;
+field offset => [];
+field preface => '';
+field content => '';
+field indent => 0;
+field major_version => 0;
+field minor_version => 0;
+field inline => '';
+
+sub set_global_options {
+ my $self = shift;
+ $self->load_code($YAML::LoadCode || $YAML::UseCode)
+ if defined $YAML::LoadCode or defined $YAML::UseCode;
+}
+
+sub load {
+ die 'load() not implemented in this class.';
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Loader::Base - Base class for YAML Loader classes
+
+=head1 SYNOPSIS
+
+ package YAML::Loader::Something;
+ use YAML::Loader::Base -base;
+
+=head1 DESCRIPTION
+
+YAML::Loader::Base is a base class for creating YAML loader classes.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Marshall.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Marshall.pm
new file mode 100755
index 00000000000..1986f58df61
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Marshall.pm
@@ -0,0 +1,81 @@
+package YAML::Marshall;
+
+use strict;
+use warnings;
+use YAML::Node ();
+
+our $VERSION = '0.71';
+
+sub import {
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller;
+ unless (grep { $_ eq $class} @{$package . '::ISA'}) {
+ push @{$package . '::ISA'}, $class;
+ }
+
+ my $tag = shift;
+ if ( $tag ) {
+ no warnings 'once';
+ $YAML::TagClass->{$tag} = $package;
+ ${$package . "::YamlTag"} = $tag;
+ }
+}
+
+sub yaml_dump {
+ my $self = shift;
+ no strict 'refs';
+ my $tag = ${ref($self) . "::YamlTag"} || 'perl/' . ref($self);
+ $self->yaml_node($self, $tag);
+}
+
+sub yaml_load {
+ my ($class, $node) = @_;
+ if (my $ynode = $class->yaml_ynode($node)) {
+ $node = $ynode->{NODE};
+ }
+ bless $node, $class;
+}
+
+sub yaml_node {
+ shift;
+ YAML::Node->new(@_);
+}
+
+sub yaml_ynode {
+ shift;
+ YAML::Node::ynode(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Marshall - YAML marshalling class you can mixin to your classes
+
+=head1 SYNOPSIS
+
+ package Bar;
+ use Foo -base;
+ use YAML::Marshall -mixin;
+
+=head1 DESCRIPTION
+
+For classes that want to handle their own YAML serialization.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Node.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Node.pm
new file mode 100755
index 00000000000..afb11870310
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Node.pm
@@ -0,0 +1,305 @@
+package YAML::Node;
+
+use strict;
+use warnings;
+
+use YAML::Base;
+use YAML::Tag;
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Base';
+our @EXPORT = qw(ynode);
+
+sub ynode {
+ my $self;
+ if (ref($_[0]) eq 'HASH') {
+ $self = tied(%{$_[0]});
+ }
+ elsif (ref($_[0]) eq 'ARRAY') {
+ $self = tied(@{$_[0]});
+ }
+ else {
+ $self = tied($_[0]);
+ }
+ return (ref($self) =~ /^yaml_/) ? $self : undef;
+}
+
+sub new {
+ my ($class, $node, $tag) = @_;
+ my $self;
+ $self->{NODE} = $node;
+ my (undef, $type) = $class->node_info($node);
+ $self->{KIND} = (not defined $type) ? 'scalar' :
+ ($type eq 'ARRAY') ? 'sequence' :
+ ($type eq 'HASH') ? 'mapping' :
+ $class->die("Can't create YAML::Node from '$type'");
+ tag($self, ($tag || ''));
+ if ($self->{KIND} eq 'scalar') {
+ yaml_scalar->new($self, $_[1]);
+ return \ $_[1];
+ }
+ my $package = "yaml_" . $self->{KIND};
+ $package->new($self)
+}
+
+sub node { $_->{NODE} }
+sub kind { $_->{KIND} }
+sub tag {
+ my ($self, $value) = @_;
+ if (defined $value) {
+ $self->{TAG} = YAML::Tag->new($value);
+ return $self;
+ }
+ else {
+ return $self->{TAG};
+ }
+}
+sub keys {
+ my ($self, $value) = @_;
+ if (defined $value) {
+ $self->{KEYS} = $value;
+ return $self;
+ }
+ else {
+ return $self->{KEYS};
+ }
+}
+
+#==============================================================================
+package yaml_scalar;
+
+@yaml_scalar::ISA = qw(YAML::Node);
+
+sub new {
+ my ($class, $self) = @_;
+ tie $_[2], $class, $self;
+}
+
+sub TIESCALAR {
+ my ($class, $self) = @_;
+ bless $self, $class;
+ $self
+}
+
+sub FETCH {
+ my ($self) = @_;
+ $self->{NODE}
+}
+
+sub STORE {
+ my ($self, $value) = @_;
+ $self->{NODE} = $value
+}
+
+#==============================================================================
+package yaml_sequence;
+
+@yaml_sequence::ISA = qw(YAML::Node);
+
+sub new {
+ my ($class, $self) = @_;
+ my $new;
+ tie @$new, $class, $self;
+ $new
+}
+
+sub TIEARRAY {
+ my ($class, $self) = @_;
+ bless $self, $class
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+ scalar @{$self->{NODE}};
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ $self->{NODE}[$index]
+}
+
+sub STORE {
+ my ($self, $index, $value) = @_;
+ $self->{NODE}[$index] = $value
+}
+
+sub undone {
+ die "Not implemented yet"; # XXX
+}
+
+*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
+*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
+*undone; # XXX Must implement before release
+
+#==============================================================================
+package yaml_mapping;
+
+@yaml_mapping::ISA = qw(YAML::Node);
+
+sub new {
+ my ($class, $self) = @_;
+ @{$self->{KEYS}} = sort keys %{$self->{NODE}};
+ my $new;
+ tie %$new, $class, $self;
+ $new
+}
+
+sub TIEHASH {
+ my ($class, $self) = @_;
+ bless $self, $class
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ if (exists $self->{NODE}{$key}) {
+ return (grep {$_ eq $key} @{$self->{KEYS}})
+ ? $self->{NODE}{$key} : undef;
+ }
+ return $self->{HASH}{$key};
+}
+
+sub STORE {
+ my ($self, $key, $value) = @_;
+ if (exists $self->{NODE}{$key}) {
+ $self->{NODE}{$key} = $value;
+ }
+ elsif (exists $self->{HASH}{$key}) {
+ $self->{HASH}{$key} = $value;
+ }
+ else {
+ if (not grep {$_ eq $key} @{$self->{KEYS}}) {
+ push(@{$self->{KEYS}}, $key);
+ }
+ $self->{HASH}{$key} = $value;
+ }
+ $value
+}
+
+sub DELETE {
+ my ($self, $key) = @_;
+ my $return;
+ if (exists $self->{NODE}{$key}) {
+ $return = $self->{NODE}{$key};
+ }
+ elsif (exists $self->{HASH}{$key}) {
+ $return = delete $self->{NODE}{$key};
+ }
+ for (my $i = 0; $i < @{$self->{KEYS}}; $i++) {
+ if ($self->{KEYS}[$i] eq $key) {
+ splice(@{$self->{KEYS}}, $i, 1);
+ }
+ }
+ return $return;
+}
+
+sub CLEAR {
+ my ($self) = @_;
+ @{$self->{KEYS}} = ();
+ %{$self->{HASH}} = ();
+}
+
+sub FIRSTKEY {
+ my ($self) = @_;
+ $self->{ITER} = 0;
+ $self->{KEYS}[0]
+}
+
+sub NEXTKEY {
+ my ($self) = @_;
+ $self->{KEYS}[++$self->{ITER}]
+}
+
+sub EXISTS {
+ my ($self, $key) = @_;
+ exists $self->{NODE}{$key}
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Node - A generic data node that encapsulates YAML information
+
+=head1 SYNOPSIS
+
+ use YAML;
+ use YAML::Node;
+
+ my $ynode = YAML::Node->new({}, 'ingerson.com/fruit');
+ %$ynode = qw(orange orange apple red grape green);
+ print Dump $ynode;
+
+yields:
+
+ --- !ingerson.com/fruit
+ orange: orange
+ apple: red
+ grape: green
+
+=head1 DESCRIPTION
+
+A generic node in YAML is similar to a plain hash, array, or scalar node
+in Perl except that it must also keep track of its type. The type is a
+URI called the YAML type tag.
+
+YAML::Node is a class for generating and manipulating these containers.
+A YAML node (or ynode) is a tied hash, array or scalar. In most ways it
+behaves just like the plain thing. But you can assign and retrieve and
+YAML type tag URI to it. For the hash flavor, you can also assign the
+order that the keys will be retrieved in. By default a ynode will offer
+its keys in the same order that they were assigned.
+
+YAML::Node has a class method call new() that will return a ynode. You
+pass it a regular node and an optional type tag. After that you can
+use it like a normal Perl node, but when you YAML::Dump it, the magical
+properties will be honored.
+
+This is how you can control the sort order of hash keys during a YAML
+serialization. By default, YAML sorts keys alphabetically. But notice
+in the above example that the keys were Dumped in the same order they
+were assigned.
+
+YAML::Node exports a function called ynode(). This function returns the tied object so that you can call special methods on it like ->keys().
+
+keys() works like this:
+
+ use YAML;
+ use YAML::Node;
+
+ %$node = qw(orange orange apple red grape green);
+ $ynode = YAML::Node->new($node);
+ ynode($ynode)->keys(['grape', 'apple']);
+ print Dump $ynode;
+
+produces:
+
+ ---
+ grape: green
+ apple: red
+
+It tells the ynode which keys and what order to use.
+
+ynodes will play a very important role in how programs use YAML. They
+are the foundation of how a Perl class can marshall the Loading and
+Dumping of its objects.
+
+The upcoming versions of YAML.pm will have much more information on this.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+Copyright (c) 2002. Brian Ingerson. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Tag.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Tag.pm
new file mode 100755
index 00000000000..8a598a867e0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Tag.pm
@@ -0,0 +1,52 @@
+package YAML::Tag;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.71';
+
+use overload '""' => sub { ${$_[0]} };
+
+sub new {
+ my ($class, $self) = @_;
+ bless \$self, $class
+}
+
+sub short {
+ ${$_[0]}
+}
+
+sub canonical {
+ ${$_[0]}
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Tag - Tag URI object class for YAML
+
+=head1 SYNOPSIS
+
+ use YAML::Tag;
+
+=head1 DESCRIPTION
+
+Used by YAML::Node.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Tiny.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Tiny.pm
new file mode 100755
index 00000000000..a3f36c67687
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Tiny.pm
@@ -0,0 +1,1132 @@
+package YAML::Tiny;
+
+use strict;
+use Carp 'croak';
+
+# UTF Support?
+sub HAVE_UTF8 () { $] >= 5.007003 }
+BEGIN {
+ if ( HAVE_UTF8 ) {
+ # The string eval helps hide this from Test::MinimumVersion
+ eval "require utf8;";
+ die "Failed to load UTF-8 support" if $@;
+ }
+
+ # Class structure
+ require 5.004;
+ require Exporter;
+ $YAML::Tiny::VERSION = '1.41';
+ @YAML::Tiny::ISA = qw{ Exporter };
+ @YAML::Tiny::EXPORT = qw{ Load Dump };
+ @YAML::Tiny::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
+
+ # Error storage
+ $YAML::Tiny::errstr = '';
+}
+
+# The character class of all characters we need to escape
+# NOTE: Inlined, since it's only used once
+# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
+
+# Printed form of the unprintable characters in the lowest range
+# of ASCII characters, listed by ASCII ordinal position.
+my @UNPRINTABLE = qw(
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1a e x1c x1d x1e x1f
+);
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+# Special magic boolean words
+my %QUOTE = map { $_ => 1 } qw{
+ null Null NULL
+ y Y yes Yes YES n N no No NO
+ true True TRUE false False FALSE
+ on On ON off Off OFF
+};
+
+
+
+
+
+#####################################################################
+# Implementation
+
+# Create an empty YAML::Tiny object
+sub new {
+ my $class = shift;
+ bless [ @_ ], $class;
+}
+
+# Create an object from a file
+sub read {
+ my $class = ref $_[0] ? ref shift : shift;
+
+ # Check the file
+ my $file = shift or return $class->_error( 'You did not specify a file name' );
+ return $class->_error( "File '$file' does not exist" ) unless -e $file;
+ return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
+ return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
+
+ # Slurp in the file
+ local $/ = undef;
+ local *CFG;
+ unless ( open(CFG, $file) ) {
+ return $class->_error("Failed to open file '$file': $!");
+ }
+ my $contents = <CFG>;
+ unless ( close(CFG) ) {
+ return $class->_error("Failed to close file '$file': $!");
+ }
+
+ $class->read_string( $contents );
+}
+
+# Create an object from a string
+sub read_string {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless [], $class;
+ my $string = $_[0];
+ unless ( defined $string ) {
+ return $self->_error("Did not provide a string to load");
+ }
+
+ # Byte order marks
+ # NOTE: Keeping this here to educate maintainers
+ # my %BOM = (
+ # "\357\273\277" => 'UTF-8',
+ # "\376\377" => 'UTF-16BE',
+ # "\377\376" => 'UTF-16LE',
+ # "\377\376\0\0" => 'UTF-32LE'
+ # "\0\0\376\377" => 'UTF-32BE',
+ # );
+ if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
+ return $self->_error("Stream has a non UTF-8 BOM");
+ } else {
+ # Strip UTF-8 bom if found, we'll just ignore it
+ $string =~ s/^\357\273\277//;
+ }
+
+ # Try to decode as utf8
+ utf8::decode($string) if HAVE_UTF8;
+
+ # Check for some special cases
+ return $self unless length $string;
+ unless ( $string =~ /[\012\015]+\z/ ) {
+ return $self->_error("Stream does not end with newline character");
+ }
+
+ # Split the file into lines
+ my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
+ split /(?:\015{1,2}\012|\015|\012)/, $string;
+
+ # Strip the initial YAML header
+ @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
+
+ # A nibbling parser
+ while ( @lines ) {
+ # Do we have a document header?
+ if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
+ # Handle scalar documents
+ shift @lines;
+ if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
+ push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
+ next;
+ }
+ }
+
+ if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
+ # A naked document
+ push @$self, undef;
+ while ( @lines and $lines[0] !~ /^---/ ) {
+ shift @lines;
+ }
+
+ } elsif ( $lines[0] =~ /^\s*\-/ ) {
+ # An array at the root
+ my $document = [ ];
+ push @$self, $document;
+ $self->_read_array( $document, [ 0 ], \@lines );
+
+ } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
+ # A hash at the root
+ my $document = { };
+ push @$self, $document;
+ $self->_read_hash( $document, [ length($1) ], \@lines );
+
+ } else {
+ croak("YAML::Tiny failed to classify the line '$lines[0]'");
+ }
+ }
+
+ $self;
+}
+
+# Deparse a scalar string to the actual scalar
+sub _read_scalar {
+ my ($self, $string, $indent, $lines) = @_;
+
+ # Trim trailing whitespace
+ $string =~ s/\s*\z//;
+
+ # Explitic null/undef
+ return undef if $string eq '~';
+
+ # Single quote
+ if ( $string =~ /^\'(.*?)\'\z/ ) {
+ return '' unless defined $1;
+ $string = $1;
+ $string =~ s/\'\'/\'/g;
+ return $string;
+ }
+
+ # Double quote.
+ # The commented out form is simpler, but overloaded the Perl regex
+ # engine due to recursion and backtracking problems on strings
+ # larger than 32,000ish characters. Keep it for reference purposes.
+ # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
+ if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"\z/ ) {
+ # Reusing the variable is a little ugly,
+ # but avoids a new variable and a string copy.
+ $string = $1;
+ $string =~ s/\\"/"/g;
+ $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
+ return $string;
+ }
+
+ # Special cases
+ if ( $string =~ /^[\'\"!&]/ ) {
+ croak("YAML::Tiny does not support a feature in line '$lines->[0]'");
+ }
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ # Regular unquoted string
+ return $string unless $string =~ /^[>|]/;
+
+ # Error
+ croak("YAML::Tiny failed to find multi-line scalar content") unless @$lines;
+
+ # Check the indent depth
+ $lines->[0] =~ /^(\s*)/;
+ $indent->[-1] = length("$1");
+ if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
+ croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
+ }
+
+ # Pull the lines
+ my @multiline = ();
+ while ( @$lines ) {
+ $lines->[0] =~ /^(\s*)/;
+ last unless length($1) >= $indent->[-1];
+ push @multiline, substr(shift(@$lines), length($1));
+ }
+
+ my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
+ my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
+ return join( $j, @multiline ) . $t;
+}
+
+# Parse an array
+sub _read_array {
+ my ($self, $array, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
+ }
+
+ if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
+ # Inline nested hash
+ my $indent2 = length("$1");
+ $lines->[0] =~ s/-/ /;
+ push @$array, { };
+ $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
+ shift @$lines;
+ unless ( @$lines ) {
+ push @$array, undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)\-/ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] == $indent2 ) {
+ # Null array entry
+ push @$array, undef;
+ } else {
+ # Naked indenter
+ push @$array, [ ];
+ $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
+ }
+
+ } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
+ push @$array, { };
+ $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
+
+ } else {
+ croak("YAML::Tiny failed to classify line '$lines->[0]'");
+ }
+
+ } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
+ # This is probably a structure like the following...
+ # ---
+ # foo:
+ # - list
+ # bar: value
+ #
+ # ... so lets return and let the hash parser handle it
+ return 1;
+
+ } else {
+ croak("YAML::Tiny failed to classify line '$lines->[0]'");
+ }
+ }
+
+ return 1;
+}
+
+# Parse an array
+sub _read_hash {
+ my ($self, $hash, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
+ }
+
+ # Get the key
+ unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
+ if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
+ croak("YAML::Tiny does not support a feature in line '$lines->[0]'");
+ }
+ croak("YAML::Tiny failed to classify line '$lines->[0]'");
+ }
+ my $key = $1;
+
+ # Do we have a value?
+ if ( length $lines->[0] ) {
+ # Yes
+ $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
+ } else {
+ # An indent
+ shift @$lines;
+ unless ( @$lines ) {
+ $hash->{$key} = undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)-/ ) {
+ $hash->{$key} = [];
+ $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ } elsif ( $lines->[0] =~ /^(\s*)./ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] >= $indent2 ) {
+ # Null hash entry
+ $hash->{$key} = undef;
+ } else {
+ $hash->{$key} = {};
+ $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ }
+ }
+ }
+ }
+
+ return 1;
+}
+
+# Save an object to a file
+sub write {
+ my $self = shift;
+ my $file = shift or return $self->_error('No file name provided');
+
+ # Write it to the file
+ open( CFG, '>' . $file ) or return $self->_error(
+ "Failed to open file '$file' for writing: $!"
+ );
+ print CFG $self->write_string;
+ close CFG;
+
+ return 1;
+}
+
+# Save an object to a string
+sub write_string {
+ my $self = shift;
+ return '' unless @$self;
+
+ # Iterate over the documents
+ my $indent = 0;
+ my @lines = ();
+ foreach my $cursor ( @$self ) {
+ push @lines, '---';
+
+ # An empty document
+ if ( ! defined $cursor ) {
+ # Do nothing
+
+ # A scalar document
+ } elsif ( ! ref $cursor ) {
+ $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
+
+ # A list at the root
+ } elsif ( ref $cursor eq 'ARRAY' ) {
+ unless ( @$cursor ) {
+ $lines[-1] .= ' []';
+ next;
+ }
+ push @lines, $self->_write_array( $cursor, $indent, {} );
+
+ # A hash at the root
+ } elsif ( ref $cursor eq 'HASH' ) {
+ unless ( %$cursor ) {
+ $lines[-1] .= ' {}';
+ next;
+ }
+ push @lines, $self->_write_hash( $cursor, $indent, {} );
+
+ } else {
+ croak("Cannot serialize " . ref($cursor));
+ }
+ }
+
+ join '', map { "$_\n" } @lines;
+}
+
+sub _write_scalar {
+ my $string = $_[1];
+ return '~' unless defined $string;
+ return "''" unless length $string;
+ if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
+ $string =~ s/\\/\\\\/g;
+ $string =~ s/"/\\"/g;
+ $string =~ s/\n/\\n/g;
+ $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
+ return qq|"$string"|;
+ }
+ if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) {
+ return "'$string'";
+ }
+ return $string;
+}
+
+sub _write_array {
+ my ($self, $array, $indent, $seen) = @_;
+ if ( $seen->{refaddr($array)}++ ) {
+ die "YAML::Tiny does not support circular references";
+ }
+ my @lines = ();
+ foreach my $el ( @$array ) {
+ my $line = (' ' x $indent) . '-';
+ my $type = ref $el;
+ if ( ! $type ) {
+ $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_write_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_write_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ die "YAML::Tiny does not support $type references";
+ }
+ }
+
+ @lines;
+}
+
+sub _write_hash {
+ my ($self, $hash, $indent, $seen) = @_;
+ if ( $seen->{refaddr($hash)}++ ) {
+ die "YAML::Tiny does not support circular references";
+ }
+ my @lines = ();
+ foreach my $name ( sort keys %$hash ) {
+ my $el = $hash->{$name};
+ my $line = (' ' x $indent) . "$name:";
+ my $type = ref $el;
+ if ( ! $type ) {
+ $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_write_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_write_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ die "YAML::Tiny does not support $type references";
+ }
+ }
+
+ @lines;
+}
+
+# Set error
+sub _error {
+ $YAML::Tiny::errstr = $_[1];
+ undef;
+}
+
+# Retrieve error
+sub errstr {
+ $YAML::Tiny::errstr;
+}
+
+
+
+
+
+#####################################################################
+# YAML Compatibility
+
+sub Dump {
+ YAML::Tiny->new(@_)->write_string;
+}
+
+sub Load {
+ my $self = YAML::Tiny->read_string(@_);
+ unless ( $self ) {
+ croak("Failed to load YAML document from string");
+ }
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # To match YAML.pm, return the last document
+ return $self->[-1];
+ }
+}
+
+BEGIN {
+ *freeze = *Dump;
+ *thaw = *Load;
+}
+
+sub DumpFile {
+ my $file = shift;
+ YAML::Tiny->new(@_)->write($file);
+}
+
+sub LoadFile {
+ my $self = YAML::Tiny->read($_[0]);
+ unless ( $self ) {
+ croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
+ }
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # Return only the last document to match YAML.pm,
+ return $self->[-1];
+ }
+}
+
+
+
+
+
+#####################################################################
+# Use Scalar::Util if possible, otherwise emulate it
+
+BEGIN {
+ eval {
+ require Scalar::Util;
+ };
+ if ( $@ ) {
+ # Failed to load Scalar::Util
+ eval <<'END_PERL';
+sub refaddr {
+ my $pkg = ref($_[0]) or return undef;
+ if (!!UNIVERSAL::can($_[0], 'can')) {
+ bless $_[0], 'Scalar::Util::Fake';
+ } else {
+ $pkg = undef;
+ }
+ "$_[0]" =~ /0x(\w+)/;
+ my $i = do { local $^W; hex $1 };
+ bless $_[0], $pkg if defined $pkg;
+ $i;
+}
+END_PERL
+ } else {
+ Scalar::Util->import('refaddr');
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+YAML::Tiny - Read/Write YAML files with as little code as possible
+
+=head1 PREAMBLE
+
+The YAML specification is huge. Really, B<really> huge. It contains all the
+functionality of XML, except with flexibility and choice, which makes it
+easier to read, but with a formal specification that is more complex than
+XML.
+
+The original pure-Perl implementation L<YAML> costs just over 4 megabytes of
+memory to load. Just like with Windows .ini files (3 meg to load) and CSS
+(3.5 meg to load) the situation is just asking for a B<YAML::Tiny> module, an
+incomplete but correct and usable subset of the functionality, in as little
+code as possible.
+
+Like the other C<::Tiny> modules, YAML::Tiny will have no non-core
+dependencies, not require a compiler, and be back-compatible to at least
+perl 5.005_03, and ideally 5.004.
+
+=head1 SYNOPSIS
+
+ #############################################
+ # In your file
+
+ ---
+ rootproperty: blah
+ section:
+ one: two
+ three: four
+ Foo: Bar
+ empty: ~
+
+
+
+ #############################################
+ # In your program
+
+ use YAML::Tiny;
+
+ # Create a YAML file
+ my $yaml = YAML::Tiny->new;
+
+ # Open the config
+ $yaml = YAML::Tiny->read( 'file.yml' );
+
+ # Reading properties
+ my $root = $yaml->[0]->{rootproperty};
+ my $one = $yaml->[0]->{section}->{one};
+ my $Foo = $yaml->[0]->{section}->{Foo};
+
+ # Changing data
+ $yaml->[0]->{newsection} = { this => 'that' }; # Add a section
+ $yaml->[0]->{section}->{Foo} = 'Not Bar!'; # Change a value
+ delete $yaml->[0]->{section}; # Delete a value or section
+
+ # Add an entire document
+ $yaml->[1] = [ 'foo', 'bar', 'baz' ];
+
+ # Save the file
+ $yaml->write( 'file.conf' );
+
+=head1 DESCRIPTION
+
+B<YAML::Tiny> is a perl class for reading and writing YAML-style files,
+written with as little code as possible, reducing load time and memory
+overhead.
+
+Most of the time it is accepted that Perl applications use a lot
+of memory and modules. The B<::Tiny> family of modules is specifically
+intended to provide an ultralight and zero-dependency alternative to
+many more-thorough standard modules.
+
+This module is primarily for reading human-written files (like simple
+config files) and generating very simple human-readable files. Note that
+I said B<human-readable> and not B<geek-readable>. The sort of files that
+your average manager or secretary should be able to look at and make
+sense of.
+
+L<YAML::Tiny> does not generate comments, it won't necesarily preserve the
+order of your hashes, and it will normalise if reading in and writing out
+again.
+
+It only supports a very basic subset of the full YAML specification.
+
+Usage is targetted at files like Perl's META.yml, for which a small and
+easily-embeddable module is extremely attractive.
+
+Features will only be added if they are human readable, and can be written
+in a few lines of code. Please don't be offended if your request is
+refused. Someone has to draw the line, and for YAML::Tiny that someone is me.
+
+If you need something with more power move up to L<YAML> (4 megabytes of
+memory overhead) or L<YAML::Syck> (275k, but requires libsyck and a C
+compiler).
+
+To restate, L<YAML::Tiny> does B<not> preserve your comments, whitespace, or
+the order of your YAML data. But it should round-trip from Perl structure
+to file and back again just fine.
+
+=head1 YAML TINY SPECIFICATION
+
+This section of the documentation provides a specification for "YAML Tiny",
+a subset of the YAML specification.
+
+It is based on and described comparatively to the YAML 1.1 Working Draft
+2004-12-28 specification, located at L<http://yaml.org/spec/current.html>.
+
+Terminology and chapter numbers are based on that specification.
+
+=head2 1. Introduction and Goals
+
+The purpose of the YAML Tiny specification is to describe a useful subset of
+the YAML specification that can be used for typical document-oriented
+uses such as configuration files and simple data structure dumps.
+
+Many specification elements that add flexibility or extensibility are
+intentionally removed, as is support for complex datastructures, class
+and object-orientation.
+
+In general, YAML Tiny targets only those data structures available in
+JSON, with the additional limitation that only simple keys are supported.
+
+As a result, all possible YAML Tiny documents should be able to be
+transformed into an equivalent JSON document, although the reverse is
+not necesarily true (but will be true in simple cases).
+
+As a result of these simplifications the YAML Tiny specification should
+be implementable in a relatively small amount of code in any language
+that supports Perl Compatible Regular Expressions (PCRE).
+
+=head2 2. Introduction
+
+YAML Tiny supports three data structures. These are scalars (in a variety
+of forms), block-form sequences and block-form mappings. Flow-style
+sequences and mappings are not supported, with some minor exceptions
+detailed later.
+
+The use of three dashes "---" to indicate the start of a new document is
+supported, and multiple documents per file/stream is allowed.
+
+Both line and inline comments are supported.
+
+Scalars are supported via the plain style, single quote and double quote,
+as well as literal-style and folded-style multi-line scalars.
+
+The use of tags is not supported.
+
+The use of anchors and aliases is not supported.
+
+The use of directives is supported only for the %YAML directive.
+
+=head2 3. Processing YAML Tiny Information
+
+B<Processes>
+
+The YAML specification dictates three-phase serialization and three-phase
+deserialization.
+
+The YAML Tiny specification does not mandate any particular methodology
+or mechanism for parsing.
+
+Any compliant parser is only required to parse a single document at a
+time. The ability to support streaming documents is optional and most
+likely non-typical.
+
+Because anchors and aliases are not supported, the resulting representation
+graph is thus directed but (unlike the main YAML specification) B<acyclic>.
+
+Circular references/pointers are not possible, and any YAML Tiny serializer
+detecting a circulars should error with an appropriate message.
+
+B<Presentation Stream>
+
+YAML Tiny is notionally unicode, but support for unicode is required if the
+underlying language or system being used to implement a parser does not
+support Unicode. If unicode is encountered in this case an error should be
+returned.
+
+B<Loading Failure Points>
+
+YAML Tiny parsers and emitters are not expected to recover from adapt to
+errors. The specific error modality of any implementation is not dictated
+(return codes, exceptions, etc) but is expected to be consistant.
+
+=head2 4. Syntax
+
+B<Character Set>
+
+YAML Tiny streams are implemented primarily using the ASCII character set,
+although the use of Unicode inside strings is allowed if support by the
+implementation.
+
+Specific YAML Tiny encoded document types aiming for maximum compatibility
+should restrict themselves to ASCII.
+
+The escaping and unescaping of the 8-bit YAML escapes is required.
+
+The escaping and unescaping of 16-bit and 32-bit YAML escapes is not
+required.
+
+B<Indicator Characters>
+
+Support for the "~" null/undefined indicator is required.
+
+Implementations may represent this as appropriate for the underlying
+language.
+
+Support for the "-" block sequence indicator is required.
+
+Support for the "?" mapping key indicator is B<not> required.
+
+Support for the ":" mapping value indicator is required.
+
+Support for the "," flow collection indicator is B<not> required.
+
+Support for the "[" flow sequence indicator is B<not> required, with
+one exception (detailed below).
+
+Support for the "]" flow sequence indicator is B<not> required, with
+one exception (detailed below).
+
+Support for the "{" flow mapping indicator is B<not> required, with
+one exception (detailed below).
+
+Support for the "}" flow mapping indicator is B<not> required, with
+one exception (detailed below).
+
+Support for the "#" comment indicator is required.
+
+Support for the "&" anchor indicator is B<not> required.
+
+Support for the "*" alias indicator is B<not> required.
+
+Support for the "!" tag indicator is B<not> required.
+
+Support for the "|" literal block indicator is required.
+
+Support for the ">" folded block indicator is required.
+
+Support for the "'" single quote indicator is required.
+
+Support for the """ double quote indicator is required.
+
+Support for the "%" directive indicator is required, but only
+for the special case of a %YAML version directive before the
+"---" document header, or on the same line as the document header.
+
+For example:
+
+ %YAML 1.1
+ ---
+ - A sequence with a single element
+
+Special Exception:
+
+To provide the ability to support empty sequences
+and mappings, support for the constructs [] (empty sequence) and {}
+(empty mapping) are required.
+
+For example,
+
+ %YAML 1.1
+ # A document consisting of only an empty mapping
+ --- {}
+ # A document consisting of only an empty sequence
+ --- []
+ # A document consisting of an empty mapping within a sequence
+ - foo
+ - {}
+ - bar
+
+B<Syntax Primitives>
+
+Other than the empty sequence and mapping cases described above, YAML Tiny
+supports only the indentation-based block-style group of contexts.
+
+All five scalar contexts are supported.
+
+Indentation spaces work as per the YAML specification in all cases.
+
+Comments work as per the YAML specification in all simple cases.
+Support for indented multi-line comments is B<not> required.
+
+Seperation spaces work as per the YAML specification in all cases.
+
+B<YAML Tiny Character Stream>
+
+The only directive supported by the YAML Tiny specification is the
+%YAML language/version identifier. Although detected, this directive
+will have no control over the parsing itself.
+
+The parser must recognise both the YAML 1.0 and YAML 1.1+ formatting
+of this directive (as well as the commented form, although no explicit
+code should be needed to deal with this case, being a comment anyway)
+
+That is, all of the following should be supported.
+
+ --- #YAML:1.0
+ - foo
+
+ %YAML:1.0
+ ---
+ - foo
+
+ % YAML 1.1
+ ---
+ - foo
+
+Support for the %TAG directive is B<not> required.
+
+Support for additional directives is B<not> required.
+
+Support for the document boundary marker "---" is required.
+
+Support for the document boundary market "..." is B<not> required.
+
+If necesary, a document boundary should simply by indicated with a
+"---" marker, with not preceding "..." marker.
+
+Support for empty streams (containing no documents) is required.
+
+Support for implicit document starts is required.
+
+That is, the following must be equivalent.
+
+ # Full form
+ %YAML 1.1
+ ---
+ foo: bar
+
+ # Implicit form
+ foo: bar
+
+B<Nodes>
+
+Support for nodes optional anchor and tag properties are B<not> required.
+
+Support for node anchors is B<not> required.
+
+Supprot for node tags is B<not> required.
+
+Support for alias nodes is B<not> required.
+
+Support for flow nodes is B<not> required.
+
+Support for block nodes is required.
+
+B<Scalar Styles>
+
+Support for all five scalar styles are required as per the YAML
+specification, although support for quoted scalars spanning more
+than one line is B<not> required.
+
+Support for the chomping indicators on multi-line scalar styles
+is required.
+
+B<Collection Styles>
+
+Support for block-style sequences is required.
+
+Support for flow-style sequences is B<not> required.
+
+Support for block-style mappings is required.
+
+Support for flow-style mappings is B<not> required.
+
+Both sequences and mappings should be able to be arbitrarily
+nested.
+
+Support for plain-style mapping keys is required.
+
+Support for quoted keys in mappings is B<not> required.
+
+Support for "?"-indicated explicit keys is B<not> required.
+
+Here endeth the specification.
+
+=head2 Additional Perl-Specific Notes
+
+For some Perl applications, it's important to know if you really have a
+number and not a string.
+
+That is, in some contexts is important that 3 the number is distinctive
+from "3" the string.
+
+Because even Perl itself is not trivially able to understand the difference
+(certainly without XS-based modules) Perl implementations of the YAML Tiny
+specification are not required to retain the distinctiveness of 3 vs "3".
+
+=head1 METHODS
+
+=head2 new
+
+The constructor C<new> creates and returns an empty C<YAML::Tiny> object.
+
+=head2 read $filename
+
+The C<read> constructor reads a YAML file, and returns a new
+C<YAML::Tiny> object containing the contents of the file.
+
+Returns the object on success, or C<undef> on error.
+
+When C<read> fails, C<YAML::Tiny> sets an error message internally
+you can recover via C<YAML::Tiny-E<gt>errstr>. Although in B<some>
+cases a failed C<read> will also set the operating system error
+variable C<$!>, not all errors do and you should not rely on using
+the C<$!> variable.
+
+=head2 read_string $string;
+
+The C<read_string> method takes as argument the contents of a YAML file
+(a YAML document) as a string and returns the C<YAML::Tiny> object for
+it.
+
+=head2 write $filename
+
+The C<write> method generates the file content for the properties, and
+writes it to disk to the filename specified.
+
+Returns true on success or C<undef> on error.
+
+=head2 write_string
+
+Generates the file content for the object and returns it as a string.
+
+=head2 errstr
+
+When an error occurs, you can retrieve the error message either from the
+C<$YAML::Tiny::errstr> variable, or using the C<errstr()> method.
+
+=head1 FUNCTIONS
+
+YAML::Tiny implements a number of functions to add compatibility with
+the L<YAML> API. These should be a drop-in replacement, except that
+YAML::Tiny will B<not> export functions by default, and so you will need
+to explicitly import the functions.
+
+=head2 Dump
+
+ my $string = Dump(list-of-Perl-data-structures);
+
+Turn Perl data into YAML. This function works very much like Data::Dumper::Dumper().
+
+It takes a list of Perl data strucures and dumps them into a serialized form.
+
+It returns a string containing the YAML stream.
+
+The structures can be references or plain scalars.
+
+=head2 Load
+
+ my @documents = Load(string-containing-a-YAML-stream);
+
+Turn YAML into Perl data. This is the opposite of Dump.
+
+Just like L<Storable>'s thaw() function or the eval() function in relation
+to L<Data::Dumper>.
+
+It parses a string containing a valid YAML stream into a list of Perl data
+structures.
+
+=head2 freeze() and thaw()
+
+Aliases to Dump() and Load() for L<Storable> fans. This will also allow
+YAML::Tiny to be plugged directly into modules like POE.pm, that use the
+freeze/thaw API for internal serialization.
+
+=head2 DumpFile(filepath, list)
+
+Writes the YAML stream to a file instead of just returning a string.
+
+=head2 LoadFile(filepath)
+
+Reads the YAML stream from a file instead of a string.
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=YAML-Tiny>
+
+=begin html
+
+For other issues, or commercial enhancement or support, please contact
+<a href="http://ali.as/">Adam Kennedy</a> directly.
+
+=end html
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>, L<http://ali.as/>
+
+=head1 COPYRIGHT
+
+Copyright 2006 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Types.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Types.pm
new file mode 100755
index 00000000000..16cbaccadaa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/YAML/Types.pm
@@ -0,0 +1,265 @@
+package YAML::Types;
+
+use strict;
+use warnings;
+use YAML::Base;
+use YAML::Node;
+
+our $VERSION = '0.71';
+our @ISA = 'YAML::Base';
+
+# XXX These classes and their APIs could still use some refactoring,
+# but at least they work for now.
+#-------------------------------------------------------------------------------
+package YAML::Type::blessed;
+
+use YAML::Base; # XXX
+
+sub yaml_dump {
+ my $self = shift;
+ my ($value) = @_;
+ my ($class, $type) = YAML::Base->node_info($value);
+ no strict 'refs';
+ my $kind = lc($type) . ':';
+ my $tag = ${$class . '::ClassTag'} ||
+ "!perl/$kind$class";
+ if ($type eq 'REF') {
+ YAML::Node->new(
+ {(&YAML::VALUE, ${$_[0]})}, $tag
+ );
+ }
+ elsif ($type eq 'SCALAR') {
+ $_[1] = $$value;
+ YAML::Node->new($_[1], $tag);
+ } else {
+ YAML::Node->new($value, $tag);
+ }
+}
+
+#-------------------------------------------------------------------------------
+package YAML::Type::undef;
+
+sub yaml_dump {
+ my $self = shift;
+}
+
+sub yaml_load {
+ my $self = shift;
+}
+
+#-------------------------------------------------------------------------------
+package YAML::Type::glob;
+
+sub yaml_dump {
+ my $self = shift;
+ my $ynode = YAML::Node->new({}, '!perl/glob:');
+ for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
+ my $value = *{$_[0]}{$type};
+ $value = $$value if $type eq 'SCALAR';
+ if (defined $value) {
+ if ($type eq 'IO') {
+ my @stats = qw(device inode mode links uid gid rdev size
+ atime mtime ctime blksize blocks);
+ undef $value;
+ $value->{stat} = YAML::Node->new({});
+ map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
+ $value->{fileno} = fileno(*{$_[0]});
+ {
+ local $^W;
+ $value->{tell} = tell(*{$_[0]});
+ }
+ }
+ $ynode->{$type} = $value;
+ }
+ }
+ return $ynode;
+}
+
+sub yaml_load {
+ my $self = shift;
+ my ($node, $class, $loader) = @_;
+ my ($name, $package);
+ if (defined $node->{NAME}) {
+ $name = $node->{NAME};
+ delete $node->{NAME};
+ }
+ else {
+ $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
+ return undef;
+ }
+ if (defined $node->{PACKAGE}) {
+ $package = $node->{PACKAGE};
+ delete $node->{PACKAGE};
+ }
+ else {
+ $package = 'main';
+ }
+ no strict 'refs';
+ if (exists $node->{SCALAR}) {
+ *{"${package}::$name"} = \$node->{SCALAR};
+ delete $node->{SCALAR};
+ }
+ for my $elem (qw(ARRAY HASH CODE IO)) {
+ if (exists $node->{$elem}) {
+ if ($elem eq 'IO') {
+ $loader->warn('YAML_LOAD_WARN_GLOB_IO');
+ delete $node->{IO};
+ next;
+ }
+ *{"${package}::$name"} = $node->{$elem};
+ delete $node->{$elem};
+ }
+ }
+ for my $elem (sort keys %$node) {
+ $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
+ }
+ return *{"${package}::$name"};
+}
+
+#-------------------------------------------------------------------------------
+package YAML::Type::code;
+
+my $dummy_warned = 0;
+my $default = '{ "DUMMY" }';
+
+sub yaml_dump {
+ my $self = shift;
+ my $code;
+ my ($dumpflag, $value) = @_;
+ my ($class, $type) = YAML::Base->node_info($value);
+ my $tag = "!perl/code";
+ $tag .= ":$class" if defined $class;
+ if (not $dumpflag) {
+ $code = $default;
+ }
+ else {
+ bless $value, "CODE" if $class;
+ eval { use B::Deparse };
+ return if $@;
+ my $deparse = B::Deparse->new();
+ eval {
+ local $^W = 0;
+ $code = $deparse->coderef2text($value);
+ };
+ if ($@) {
+ warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
+ $code = $default;
+ }
+ bless $value, $class if $class;
+ chomp $code;
+ $code .= "\n";
+ }
+ $_[2] = $code;
+ YAML::Node->new($_[2], $tag);
+}
+
+sub yaml_load {
+ my $self = shift;
+ my ($node, $class, $loader) = @_;
+ if ($loader->load_code) {
+ my $code = eval "package main; sub $node";
+ if ($@) {
+ $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
+ return sub {};
+ }
+ else {
+ CORE::bless $code, $class if $class;
+ return $code;
+ }
+ }
+ else {
+ return CORE::bless sub {}, $class if $class;
+ return sub {};
+ }
+}
+
+#-------------------------------------------------------------------------------
+package YAML::Type::ref;
+
+sub yaml_dump {
+ my $self = shift;
+ YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')
+}
+
+sub yaml_load {
+ my $self = shift;
+ my ($node, $class, $loader) = @_;
+ $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
+ unless exists $node->{&YAML::VALUE};
+ return \$node->{&YAML::VALUE};
+}
+
+#-------------------------------------------------------------------------------
+package YAML::Type::regexp;
+
+# XXX Be sure to handle blessed regexps (if possible)
+sub yaml_dump {
+ die "YAML::Type::regexp::yaml_dump not currently implemented";
+}
+
+use constant _QR_TYPES => {
+ '' => sub { qr{$_[0]} },
+ x => sub { qr{$_[0]}x },
+ i => sub { qr{$_[0]}i },
+ s => sub { qr{$_[0]}s },
+ m => sub { qr{$_[0]}m },
+ ix => sub { qr{$_[0]}ix },
+ sx => sub { qr{$_[0]}sx },
+ mx => sub { qr{$_[0]}mx },
+ si => sub { qr{$_[0]}si },
+ mi => sub { qr{$_[0]}mi },
+ ms => sub { qr{$_[0]}sm },
+ six => sub { qr{$_[0]}six },
+ mix => sub { qr{$_[0]}mix },
+ msx => sub { qr{$_[0]}msx },
+ msi => sub { qr{$_[0]}msi },
+ msix => sub { qr{$_[0]}msix },
+};
+
+sub yaml_load {
+ my $self = shift;
+ my ($node, $class) = @_;
+ return qr{$node} unless $node =~ /^\(\?([\-xism]*):(.*)\)\z/s;
+ my ($flags, $re) = ($1, $2);
+ $flags =~ s/-.*//;
+ my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
+ my $qr = &$sub($re);
+ bless $qr, $class if length $class;
+ return $qr;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Types - Marshall Perl internal data types to/from YAML
+
+=head1 SYNOPSIS
+
+ $::foo = 42;
+ print YAML::Dump(*::foo);
+
+ print YAML::Dump(qr{match me});
+
+=head1 DESCRIPTION
+
+This module has the helper classes for transferring objects,
+subroutines, references, globs, regexps and file handles to and
+from YAML.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/assert.pl b/Master/tlpkg/tlperl.straw/lib/assert.pl
new file mode 100755
index 00000000000..4c9ebf20a0d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/assert.pl
@@ -0,0 +1,55 @@
+# 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.straw/lib/attributes.pm b/Master/tlpkg/tlperl.straw/lib/attributes.pm
new file mode 100755
index 00000000000..aa532c2facf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/attributes.pm
@@ -0,0 +1,495 @@
+package attributes;
+
+our $VERSION = 0.09;
+
+@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;
+}
+
+## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{}
+#sub reftype ($) ;
+#sub _fetch_attrs ($) ;
+#sub _guess_stash ($) ;
+#sub _modify_attrs ;
+#
+# The extra trips through newATTRSUB in the interpreter wipe out any savings
+# from avoiding the BEGIN block. Just do the bootstrap now.
+BEGIN { bootstrap attributes }
+
+sub import {
+ @_ > 2 && ref $_[2] or do {
+ require Exporter;
+ goto &Exporter::import;
+ };
+ my (undef,$home_stash,$svref,@attrs) = @_;
+
+ my $svtype = uc reftype($svref);
+ my $pkgmeth;
+ $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
+ if defined $home_stash && $home_stash ne '';
+ my @badattrs;
+ if ($pkgmeth) {
+ my @pkgattrs = _modify_attrs($svref, @attrs);
+ @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
+ if (!@badattrs && @pkgattrs) {
+ require warnings;
+ return unless warnings::enabled('reserved');
+ @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
+ if (@pkgattrs) {
+ for my $attr (@pkgattrs) {
+ $attr =~ s/\(.+\z//s;
+ }
+ my $s = ((@pkgattrs == 1) ? '' : 's');
+ carp "$svtype package attribute$s " .
+ "may clash with future reserved word$s: " .
+ join(' : ' , @pkgattrs);
+ }
+ }
+ }
+ else {
+ @badattrs = _modify_attrs($svref, @attrs);
+ }
+ if (@badattrs) {
+ croak "Invalid $svtype attribute" .
+ (( @badattrs == 1 ) ? '' : 's') .
+ ": " .
+ join(' : ', @badattrs);
+ }
+}
+
+sub get ($) {
+ @_ == 1 && ref $_[0] or
+ croak 'Usage: '.__PACKAGE__.'::get $ref';
+ my $svref = shift;
+ my $svtype = uc reftype $svref;
+ my $stash = _guess_stash $svref;
+ $stash = caller unless defined $stash;
+ my $pkgmeth;
+ $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
+ if defined $stash && $stash ne '';
+ return $pkgmeth ?
+ (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
+ (_fetch_attrs($svref))
+ ;
+}
+
+sub require_version { goto &UNIVERSAL::VERSION }
+
+1;
+__END__
+#The POD goes here
+
+=head1 NAME
+
+attributes - get/set subroutine or variable attributes
+
+=head1 SYNOPSIS
+
+ sub foo : method ;
+ my ($x,@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 locked
+
+B<5.005 threads only! The use of the "locked" attribute currently
+only makes sense if you are using the deprecated "Perl 5.005 threads"
+implementation of threads.>
+
+Setting this attribute is only meaningful when the subroutine or
+method is to be called by multiple threads. When set on a method
+subroutine (i.e., one marked with the B<method> attribute below),
+Perl ensures that any invocation of it implicitly locks its first
+argument before execution. When set on a non-method subroutine,
+Perl ensures that a lock is taken on the subroutine itself before
+execution. The semantics of the lock are exactly those of one
+explicitly taken with the C<lock> operator immediately after the
+subroutine is entered.
+
+=item method
+
+Indicates that the referenced subroutine is a method.
+This has a meaning when taken together with the B<locked> attribute,
+as described there. It also means that a subroutine so marked
+will not trigger the "Ambiguous call resolved as CORE::%s" warning.
+
+=item lvalue
+
+Indicates that the referenced subroutine is a valid lvalue and can
+be assigned to. The subroutine must return a modifiable value such
+as a scalar variable, as described in L<perlsub>.
+
+=back
+
+For global variables there is C<unique> attribute: see L<perlfunc/our>.
+
+=head2 Available Subroutines
+
+The following subroutines are available for general use once this module
+has been loaded:
+
+=over 4
+
+=item get
+
+This routine expects a single parameter--a reference to a
+subroutine or variable. It returns a list of attributes, which may be
+empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>)
+to raise a fatal exception. If it can find an appropriate package name
+for a class method lookup, it will include the results from a
+C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in
+L<"Package-specific Attribute Handling"> below.
+Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned.
+
+=item reftype
+
+This routine expects a single parameter--a reference to a subroutine or
+variable. It returns the built-in type of the referenced variable,
+ignoring any package into which it might have been blessed.
+This can be useful for determining the I<type> value which forms part of
+the method names described in L<"Package-specific Attribute Handling"> below.
+
+=back
+
+Note that these routines are I<not> exported by default.
+
+=head2 Package-specific Attribute Handling
+
+B<WARNING>: the mechanisms described here are still experimental. Do not
+rely on the current implementation. In particular, there is no provision
+for applying package attributes to 'cloned' copies of subroutines used as
+closures. (See L<perlref/"Making References"> for information on closures.)
+Package-specific attribute handling may change incompatibly in a future
+release.
+
+When an attribute list is present in a declaration, a check is made to see
+whether an attribute 'modify' handler is present in the appropriate package
+(or its @ISA inheritance tree). Similarly, when C<attributes::get> is
+called on a valid reference, a check is made for an appropriate attribute
+'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package"
+determination works.
+
+The handler names are based on the underlying type of the variable being
+declared or of the reference passed. Because these attributes are
+associated with subroutine or variable declarations, this deliberately
+ignores any possibility of being blessed into some package. Thus, a
+subroutine declaration uses "CODE" as its I<type>, and even a blessed
+hash reference uses "HASH" as its I<type>.
+
+The class methods invoked for modifying and fetching are these:
+
+=over 4
+
+=item FETCH_I<type>_ATTRIBUTES
+
+This method is called with two arguments: the relevant package name,
+and a reference to a variable or subroutine for which package-defined
+attributes are desired. The expected return value is a list of
+associated attributes. This list may be empty.
+
+=item MODIFY_I<type>_ATTRIBUTES
+
+This method is called with two fixed arguments, followed by the list of
+attributes from the relevant declaration. The two fixed arguments are
+the relevant package name and a reference to the declared subroutine or
+variable. The expected return value is a list of attributes which were
+not recognized by this handler. Note that this allows for a derived class
+to delegate a call to its base class, and then only examine the attributes
+which the base class didn't already handle for it.
+
+The call to this method is currently made I<during> the processing of the
+declaration. In particular, this means that a subroutine reference will
+probably be for an undefined subroutine, even if this declaration is
+actually part of the definition.
+
+=back
+
+Calling C<attributes::get()> from within the scope of a null package
+declaration C<package ;> for an unblessed variable reference will
+not provide any starting package name for the 'fetch' method lookup.
+Thus, this circumstance will not result in a method call for package-defined
+attributes. A named subroutine knows to which symbol table entry it belongs
+(or originally belonged), and it will use the corresponding package.
+An anonymous subroutine knows the package name into which it was compiled
+(unless it was also compiled with a null package declaration), and so it
+will use that package name.
+
+=head2 Syntax of Attribute Lists
+
+An attribute list is a sequence of attribute specifications, separated by
+whitespace or a colon (with optional whitespace).
+Each attribute specification is a simple
+name, optionally followed by a parenthesised parameter list.
+If such a parameter list is present, it is scanned past as for the rules
+for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.)
+The parameter list is passed as it was found, however, and not as per C<q()>.
+
+Some examples of syntactically valid attribute lists:
+
+ switch(10,foo(7,3)) : expensive
+ Ugly('\(") :Bad
+ _5x5
+ locked method
+
+Some examples of syntactically invalid attribute lists (with annotation):
+
+ switch(10,foo() # ()-string not balanced
+ Ugly('(') # ()-string not balanced
+ 5x5 # "5x5" not a valid identifier
+ Y2::north # "Y2::north" not a simple identifier
+ foo + bar # "+" neither a colon nor whitespace
+
+=head1 EXPORTS
+
+=head2 Default exports
+
+None.
+
+=head2 Available exports
+
+The routines C<get> and C<reftype> are exportable.
+
+=head2 Export tags defined
+
+The C<:ALL> tag will get all of the above exports.
+
+=head1 EXAMPLES
+
+Here are some samples of syntactically valid declarations, with annotation
+as to how they resolve internally into C<use attributes> invocations by
+perl. These examples are primarily useful to see how the "appropriate
+package" is found for the possible method lookups for package-defined
+attributes.
+
+=over 4
+
+=item 1.
+
+Code:
+
+ package Canine;
+ package Dog;
+ my Canine $spot : Watchful ;
+
+Effect:
+
+ use attributes ();
+ attributes::->import(Canine => \$spot, "Watchful");
+
+=item 2.
+
+Code:
+
+ package Felis;
+ my $cat : Nervous;
+
+Effect:
+
+ use attributes ();
+ attributes::->import(Felis => \$cat, "Nervous");
+
+=item 3.
+
+Code:
+
+ package X;
+ sub foo : locked ;
+
+Effect:
+
+ use attributes X => \&foo, "locked";
+
+=item 4.
+
+Code:
+
+ package X;
+ sub Y::x : locked { 1 }
+
+Effect:
+
+ use attributes Y => \&Y::x, "locked";
+
+=item 5.
+
+Code:
+
+ package X;
+ sub foo { 1 }
+
+ package Y;
+ BEGIN { *bar = \&X::foo; }
+
+ package Z;
+ sub Y::bar : locked ;
+
+Effect:
+
+ use attributes X => \&X::foo, "locked";
+
+=back
+
+This last example is purely for purposes of completeness. You should not
+be trying to mess with the attributes of something in a package that's
+not your own.
+
+=head1 MORE EXAMPLES
+
+=over 4
+
+=item 1.
+
+ sub MODIFY_CODE_ATTRIBUTES {
+ my ($class,$code,@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<attrs> for the obsolescent form of subroutine attribute specification
+which this module replaces;
+L<perlfunc/use> for details on the normal invocation mechanism.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Algorithm/Diff/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Algorithm/Diff/.packlist
new file mode 100755
index 00000000000..ab95cb95058
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Algorithm/Diff/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\vendor\lib\Algorithm\Diff.pm
+C:\strawberry\perl\vendor\lib\Algorithm\DiffOld.pm
+C:\strawberry\perl\vendor\lib\Algorithm\cdiff.pl
+C:\strawberry\perl\vendor\lib\Algorithm\diff.pl
+C:\strawberry\perl\vendor\lib\Algorithm\diffnew.pl
+C:\strawberry\perl\vendor\lib\Algorithm\htmldiff.pl
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Archive/Extract/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Archive/Extract/.packlist
new file mode 100755
index 00000000000..afd2a6f663f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Archive/Extract/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Archive\Extract.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Archive/Tar/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Archive/Tar/.packlist
new file mode 100755
index 00000000000..eb062581884
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Archive/Tar/.packlist
@@ -0,0 +1,7 @@
+C:\strawberry\perl\bin\ptar
+C:\strawberry\perl\bin\ptar.bat
+C:\strawberry\perl\bin\ptardiff
+C:\strawberry\perl\bin\ptardiff.bat
+C:\strawberry\perl\lib\Archive\Tar.pm
+C:\strawberry\perl\lib\Archive\Tar\Constant.pm
+C:\strawberry\perl\lib\Archive\Tar\File.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Archive/Zip/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Archive/Zip/.packlist
new file mode 100755
index 00000000000..101ffc23eb4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Archive/Zip/.packlist
@@ -0,0 +1,15 @@
+C:\strawberry\perl\bin\crc32
+C:\strawberry\perl\bin\crc32.bat
+C:\strawberry\perl\vendor\lib\Archive\Zip.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\Archive.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\BufferedFileHandle.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\DirectoryMember.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\FAQ.pod
+C:\strawberry\perl\vendor\lib\Archive\Zip\FileMember.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\Member.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\MemberRead.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\MockFileHandle.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\NewFileMember.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\StringMember.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\Tree.pm
+C:\strawberry\perl\vendor\lib\Archive\Zip\ZipFileMember.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Attribute/Handlers/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Attribute/Handlers/.packlist
new file mode 100755
index 00000000000..f7c66532956
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Attribute/Handlers/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Attribute\Handlers.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/AutoLoader/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/AutoLoader/.packlist
new file mode 100755
index 00000000000..4ad64c3dac5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/AutoLoader/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\lib\AutoLoader.pm
+C:\strawberry\perl\lib\AutoSplit.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/B/B.dll b/Master/tlpkg/tlperl.straw/lib/auto/B/B.dll
new file mode 100755
index 00000000000..b1e3e67e501
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/B/B.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/.packlist
new file mode 100755
index 00000000000..2691f89a5cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/.packlist
@@ -0,0 +1,7 @@
+C:\strawberry\perl\vendor\lib\BerkeleyDB.pm
+C:\strawberry\perl\vendor\lib\BerkeleyDB.pod
+C:\strawberry\perl\vendor\lib\BerkeleyDB\Btree.pm
+C:\strawberry\perl\vendor\lib\BerkeleyDB\Hash.pm
+C:\strawberry\perl\vendor\lib\auto\BerkeleyDB\BerkeleyDB.bs
+C:\strawberry\perl\vendor\lib\auto\BerkeleyDB\BerkeleyDB.dll
+C:\strawberry\perl\vendor\lib\auto\BerkeleyDB\autosplit.ix
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.bs b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.dll b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.dll
new file mode 100755
index 00000000000..4c7ada7f687
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/BerkeleyDB.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/autosplit.ix
new file mode 100755
index 00000000000..651e60bc181
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/BerkeleyDB/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\BerkeleyDB.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CGI/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CGI/.packlist
new file mode 100755
index 00000000000..d952f7acdfe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CGI/.packlist
@@ -0,0 +1,9 @@
+C:\strawberry\perl\lib\CGI.pm
+C:\strawberry\perl\lib\CGI\Apache.pm
+C:\strawberry\perl\lib\CGI\Carp.pm
+C:\strawberry\perl\lib\CGI\Cookie.pm
+C:\strawberry\perl\lib\CGI\Fast.pm
+C:\strawberry\perl\lib\CGI\Pretty.pm
+C:\strawberry\perl\lib\CGI\Push.pm
+C:\strawberry\perl\lib\CGI\Switch.pm
+C:\strawberry\perl\lib\CGI\Util.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CPAN/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/.packlist
new file mode 100755
index 00000000000..f04aa552a84
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/.packlist
@@ -0,0 +1,37 @@
+C:\strawberry\perl\bin\cpan
+C:\strawberry\perl\bin\cpan.bat
+C:\strawberry\perl\lib\App\Cpan.pm
+C:\strawberry\perl\lib\CPAN.pm
+C:\strawberry\perl\lib\CPAN\API\HOWTO.pod
+C:\strawberry\perl\lib\CPAN\Admin.pm
+C:\strawberry\perl\lib\CPAN\Author.pm
+C:\strawberry\perl\lib\CPAN\Bundle.pm
+C:\strawberry\perl\lib\CPAN\CacheMgr.pm
+C:\strawberry\perl\lib\CPAN\Complete.pm
+C:\strawberry\perl\lib\CPAN\Debug.pm
+C:\strawberry\perl\lib\CPAN\DeferredCode.pm
+C:\strawberry\perl\lib\CPAN\Distribution.pm
+C:\strawberry\perl\lib\CPAN\Distroprefs.pm
+C:\strawberry\perl\lib\CPAN\Distrostatus.pm
+C:\strawberry\perl\lib\CPAN\Exception\RecursiveDependency.pm
+C:\strawberry\perl\lib\CPAN\Exception\blocked_urllist.pm
+C:\strawberry\perl\lib\CPAN\Exception\yaml_not_installed.pm
+C:\strawberry\perl\lib\CPAN\FTP.pm
+C:\strawberry\perl\lib\CPAN\FTP\netrc.pm
+C:\strawberry\perl\lib\CPAN\FirstTime.pm
+C:\strawberry\perl\lib\CPAN\HandleConfig.pm
+C:\strawberry\perl\lib\CPAN\Index.pm
+C:\strawberry\perl\lib\CPAN\InfoObj.pm
+C:\strawberry\perl\lib\CPAN\Kwalify.pm
+C:\strawberry\perl\lib\CPAN\Kwalify\distroprefs.dd
+C:\strawberry\perl\lib\CPAN\Kwalify\distroprefs.yml
+C:\strawberry\perl\lib\CPAN\LWP\UserAgent.pm
+C:\strawberry\perl\lib\CPAN\Mirrors.pm
+C:\strawberry\perl\lib\CPAN\Module.pm
+C:\strawberry\perl\lib\CPAN\Nox.pm
+C:\strawberry\perl\lib\CPAN\Prompt.pm
+C:\strawberry\perl\lib\CPAN\Queue.pm
+C:\strawberry\perl\lib\CPAN\Shell.pm
+C:\strawberry\perl\lib\CPAN\Tarzip.pm
+C:\strawberry\perl\lib\CPAN\URL.pm
+C:\strawberry\perl\lib\CPAN\Version.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CPAN/Checksums/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/Checksums/.packlist
new file mode 100755
index 00000000000..bdc402976a5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/Checksums/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\CPAN\Checksums.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CPAN/DistnameInfo/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/DistnameInfo/.packlist
new file mode 100755
index 00000000000..4f7c0615226
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/DistnameInfo/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\CPAN\DistnameInfo.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CPAN/Inject/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/Inject/.packlist
new file mode 100755
index 00000000000..1e45407105b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/Inject/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\cpaninject
+C:\strawberry\perl\bin\cpaninject.bat
+C:\strawberry\perl\vendor\lib\CPAN\Inject.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CPAN/SQLite/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/SQLite/.packlist
new file mode 100755
index 00000000000..69911e61400
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CPAN/SQLite/.packlist
@@ -0,0 +1,13 @@
+C:\strawberry\perl\bin\cpandb
+C:\strawberry\perl\bin\cpandb.bat
+C:\strawberry\perl\vendor\lib\CPAN\SQLite.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\DBI.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\DBI\Index.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\DBI\Search.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\Index.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\Info.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\META.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\Populate.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\Search.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\State.pm
+C:\strawberry\perl\vendor\lib\CPAN\SQLite\Util.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CPANPLUS/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CPANPLUS/.packlist
new file mode 100755
index 00000000000..8db17f2197b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CPANPLUS/.packlist
@@ -0,0 +1,47 @@
+C:\strawberry\perl\bin\cpan2dist
+C:\strawberry\perl\bin\cpan2dist.bat
+C:\strawberry\perl\bin\cpanp
+C:\strawberry\perl\bin\cpanp-run-perl
+C:\strawberry\perl\bin\cpanp-run-perl.bat
+C:\strawberry\perl\bin\cpanp.bat
+C:\strawberry\perl\lib\CPANPLUS.pm
+C:\strawberry\perl\lib\CPANPLUS\Backend.pm
+C:\strawberry\perl\lib\CPANPLUS\Backend\RV.pm
+C:\strawberry\perl\lib\CPANPLUS\Config.pm
+C:\strawberry\perl\lib\CPANPLUS\Configure.pm
+C:\strawberry\perl\lib\CPANPLUS\Configure\Setup.pm
+C:\strawberry\perl\lib\CPANPLUS\Dist.pm
+C:\strawberry\perl\lib\CPANPLUS\Dist\Autobundle.pm
+C:\strawberry\perl\lib\CPANPLUS\Dist\Base.pm
+C:\strawberry\perl\lib\CPANPLUS\Dist\MM.pm
+C:\strawberry\perl\lib\CPANPLUS\Dist\Sample.pm
+C:\strawberry\perl\lib\CPANPLUS\Error.pm
+C:\strawberry\perl\lib\CPANPLUS\FAQ.pod
+C:\strawberry\perl\lib\CPANPLUS\Hacking.pod
+C:\strawberry\perl\lib\CPANPLUS\Internals.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Constants.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Constants\Report.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Extract.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Fetch.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Report.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Search.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Source.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Source\Memory.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Source\SQLite.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Source\SQLite\Tie.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Utils.pm
+C:\strawberry\perl\lib\CPANPLUS\Internals\Utils\Autoflush.pm
+C:\strawberry\perl\lib\CPANPLUS\Module.pm
+C:\strawberry\perl\lib\CPANPLUS\Module\Author.pm
+C:\strawberry\perl\lib\CPANPLUS\Module\Author\Fake.pm
+C:\strawberry\perl\lib\CPANPLUS\Module\Checksums.pm
+C:\strawberry\perl\lib\CPANPLUS\Module\Fake.pm
+C:\strawberry\perl\lib\CPANPLUS\Module\Signature.pm
+C:\strawberry\perl\lib\CPANPLUS\Selfupdate.pm
+C:\strawberry\perl\lib\CPANPLUS\Shell.pm
+C:\strawberry\perl\lib\CPANPLUS\Shell\Classic.pm
+C:\strawberry\perl\lib\CPANPLUS\Shell\Default.pm
+C:\strawberry\perl\lib\CPANPLUS\Shell\Default\Plugins\CustomSource.pm
+C:\strawberry\perl\lib\CPANPLUS\Shell\Default\Plugins\HOWTO.pod
+C:\strawberry\perl\lib\CPANPLUS\Shell\Default\Plugins\Remote.pm
+C:\strawberry\perl\lib\CPANPLUS\Shell\Default\Plugins\Source.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/CPANPLUS/Dist/Build/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/CPANPLUS/Dist/Build/.packlist
new file mode 100755
index 00000000000..30780e235a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/CPANPLUS/Dist/Build/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\lib\CPANPLUS\Dist\Build.pm
+C:\strawberry\perl\lib\CPANPLUS\Dist\Build\Constants.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Class/ErrorHandler/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Class/ErrorHandler/.packlist
new file mode 100755
index 00000000000..ea13985a6d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Class/ErrorHandler/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Class\ErrorHandler.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Class/ISA/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Class/ISA/.packlist
new file mode 100755
index 00000000000..0f7d2f81d07
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Class/ISA/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Class\ISA.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Class/Loader/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Class/Loader/.packlist
new file mode 100755
index 00000000000..e036c49ade7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Class/Loader/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\Class\Loader.pm
+C:\strawberry\perl\vendor\lib\Class\LoaderTest.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/.packlist
new file mode 100755
index 00000000000..1f93b32249d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\Compress\Bzip2.pm
+C:\strawberry\perl\vendor\lib\auto\Compress\Bzip2\Bzip2.bs
+C:\strawberry\perl\vendor\lib\auto\Compress\Bzip2\Bzip2.dll
+C:\strawberry\perl\vendor\lib\auto\Compress\Bzip2\autosplit.ix
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.bs b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.dll b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.dll
new file mode 100755
index 00000000000..89eee8a506f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/Bzip2.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/autosplit.ix
new file mode 100755
index 00000000000..0faf0b863de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Bzip2/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Compress\Bzip2.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/.packlist
new file mode 100755
index 00000000000..01459ed27d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\lib\Compress\Raw\Bzip2.pm
+C:\strawberry\perl\lib\auto\Compress\Raw\Bzip2\Bzip2.bs
+C:\strawberry\perl\lib\auto\Compress\Raw\Bzip2\Bzip2.dll
+C:\strawberry\perl\lib\auto\Compress\Raw\Bzip2\autosplit.ix
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.bs b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.dll b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.dll
new file mode 100755
index 00000000000..2e184a7450a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/Bzip2.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/autosplit.ix
new file mode 100755
index 00000000000..dcc49033693
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Bzip2/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Compress\Raw\Bzip2.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/.packlist
new file mode 100755
index 00000000000..531f3bf6ea2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\lib\Compress\Raw\Zlib.pm
+C:\strawberry\perl\lib\auto\Compress\Raw\Zlib\Zlib.bs
+C:\strawberry\perl\lib\auto\Compress\Raw\Zlib\Zlib.dll
+C:\strawberry\perl\lib\auto\Compress\Raw\Zlib\autosplit.ix
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.bs b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.dll b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.dll
new file mode 100755
index 00000000000..a430eb0f79e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/Zlib.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/autosplit.ix
new file mode 100755
index 00000000000..bcf12323af3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Raw/Zlib/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Compress\Raw\Zlib.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/Zlib/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Zlib/autosplit.ix
new file mode 100755
index 00000000000..f4098e4a8c7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/Zlib/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Compress\Zlib.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/.packlist
new file mode 100755
index 00000000000..dfc9d7169d8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Compress\unLZMA.pm
+C:\strawberry\perl\vendor\lib\auto\Compress\unLZMA\unLZMA.bs
+C:\strawberry\perl\vendor\lib\auto\Compress\unLZMA\unLZMA.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.bs b/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.dll b/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.dll
new file mode 100755
index 00000000000..3ba33d63875
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Compress/unLZMA/unLZMA.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Convert/ASCII/Armour/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Convert/ASCII/Armour/.packlist
new file mode 100755
index 00000000000..d671eb43b8a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Convert/ASCII/Armour/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\Convert\ASCII\Armor.pm
+C:\strawberry\perl\vendor\lib\Convert\ASCII\Armour.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Convert/ASN1/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Convert/ASN1/.packlist
new file mode 100755
index 00000000000..b412c340aee
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Convert/ASN1/.packlist
@@ -0,0 +1,7 @@
+C:\strawberry\perl\vendor\lib\Convert\ASN1.pm
+C:\strawberry\perl\vendor\lib\Convert\ASN1.pod
+C:\strawberry\perl\vendor\lib\Convert\ASN1\Debug.pm
+C:\strawberry\perl\vendor\lib\Convert\ASN1\IO.pm
+C:\strawberry\perl\vendor\lib\Convert\ASN1\_decode.pm
+C:\strawberry\perl\vendor\lib\Convert\ASN1\_encode.pm
+C:\strawberry\perl\vendor\lib\Convert\ASN1\parser.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Convert/PEM/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Convert/PEM/.packlist
new file mode 100755
index 00000000000..2b0b8d4792d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Convert/PEM/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\Convert\PEM.pm
+C:\strawberry\perl\vendor\lib\Convert\PEM\CBC.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/.packlist
new file mode 100755
index 00000000000..72450144d0c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Crypt\Blowfish.pm
+C:\strawberry\perl\vendor\lib\auto\Crypt\Blowfish\Blowfish.bs
+C:\strawberry\perl\vendor\lib\auto\Crypt\Blowfish\Blowfish.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.bs b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.dll b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.dll
new file mode 100755
index 00000000000..3bdbeaf040b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Blowfish/Blowfish.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/.packlist
new file mode 100755
index 00000000000..aac4209938b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\vendor\lib\Crypt\CAST5_PP.pm
+C:\strawberry\perl\vendor\lib\Crypt\CAST5_PP\Tables.pm
+C:\strawberry\perl\vendor\lib\auto\Crypt\CAST5_PP\autosplit.ix
+C:\strawberry\perl\vendor\lib\auto\Crypt\CAST5_PP\decrypt.al
+C:\strawberry\perl\vendor\lib\auto\Crypt\CAST5_PP\encrypt.al
+C:\strawberry\perl\vendor\lib\auto\Crypt\CAST5_PP\init.al
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/autosplit.ix
new file mode 100755
index 00000000000..da2bd7977c2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/autosplit.ix
@@ -0,0 +1,7 @@
+# Index created by AutoSplit for blib\lib\Crypt\CAST5_PP.pm
+# (file acts as timestamp)
+package Crypt::CAST5_PP;
+sub init ;
+sub encrypt ;
+sub decrypt ;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/decrypt.al b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/decrypt.al
new file mode 100755
index 00000000000..7afcede8922
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/decrypt.al
@@ -0,0 +1,47 @@
+# NOTE: Derived from blib\lib\Crypt\CAST5_PP.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Crypt::CAST5_PP;
+
+#line 223 "blib\lib\Crypt\CAST5_PP.pm (autosplit into blib\lib\auto\Crypt\CAST5_PP\decrypt.al)"
+sub decrypt {
+ use strict;
+ use integer;
+ my ($cast5, $block) = @_;
+ croak "Block size must be 8" if length($block) != 8;
+
+ my $decrypt = $cast5->{decrypt};
+ unless ($decrypt) {
+ my $key = $cast5->{key} or croak "Call init() first";
+ my $rounds = $cast5->{rounds};
+ my $f = 'sub{my($r,$l,$i)=unpack"N2",$_[0];';
+
+ my ($l, $r) = qw( $r $l );
+ my ($op1, $op2, $op3) = qw( - + ^ );
+ foreach (1 .. $rounds%3) { ($op1, $op2, $op3) = ($op2, $op3, $op1) }
+ foreach my $round (1 .. $rounds) {
+ my $km = $key->[$rounds-$round];
+ my $kr = $key->[$rounds-$round+16];
+
+ my $rot = "";
+ if ($kr) {
+ my $mask = ~(~0<<$kr) & 0xffffffff;
+ my $kr2 = 32-$kr;
+ $rot = "\$i=\$i<<$kr|\$i>>$kr2&$mask;"
+ }
+
+ $f .= "\$i=$km$op1$r;$rot$l^=((\$s1[\$i>>24&255]$op2\$s2[\$i>>16&255])$op3\$s3[\$i>>8&255])$op1\$s4[\$i&255];";
+ ($l, $r) = ($r, $l);
+ ($op1, $op2, $op3) = ($op3, $op1, $op2);
+ }
+
+ $f .= 'pack"N2",$l&0xffffffff,$r&0xffffffff}';
+ $cast5->{decrypt} = $decrypt = eval $f;
+ }
+
+ return $decrypt->($block);
+} # decrypt
+
+# end CAST5_PP.pm
+1;
+# end of Crypt::CAST5_PP::decrypt
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/encrypt.al b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/encrypt.al
new file mode 100755
index 00000000000..1041e4955d0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/encrypt.al
@@ -0,0 +1,44 @@
+# NOTE: Derived from blib\lib\Crypt\CAST5_PP.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Crypt::CAST5_PP;
+
+#line 187 "blib\lib\Crypt\CAST5_PP.pm (autosplit into blib\lib\auto\Crypt\CAST5_PP\encrypt.al)"
+sub encrypt {
+ use strict;
+ use integer;
+ my ($cast5, $block) = @_;
+ croak "Block size must be 8" if length($block) != 8;
+
+ my $encrypt = $cast5->{encrypt};
+ unless ($encrypt) {
+ my $key = $cast5->{key} or croak "Call init() first";
+ my $f = 'sub{my($l,$r,$i)=unpack"N2",$_[0];';
+
+ my ($l, $r) = qw( $l $r );
+ my ($op1, $op2, $op3) = qw( + ^ - );
+ foreach my $round (0 .. $cast5->{rounds}-1) {
+ my $km = $key->[$round];
+ my $kr = $key->[$round+16];
+
+ my $rot = "";
+ if ($kr) {
+ my $mask = ~(~0<<$kr) & 0xffffffff;
+ my $kr2 = 32-$kr;
+ $rot = "\$i=\$i<<$kr|\$i>>$kr2&$mask;"
+ }
+
+ $f .= "\$i=$km$op1$r;$rot$l^=((\$s1[\$i>>24&255]$op2\$s2[\$i>>16&255])$op3\$s3[\$i>>8&255])$op1\$s4[\$i&255];";
+ ($l, $r) = ($r, $l);
+ ($op1, $op2, $op3) = ($op2, $op3, $op1);
+ }
+
+ $f .= 'pack"N2",$r&0xffffffff,$l&0xffffffff}';
+ $cast5->{encrypt} = $encrypt = eval $f;
+ }
+
+ return $encrypt->($block);
+} # encrypt
+
+# end of Crypt::CAST5_PP::encrypt
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/init.al b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/init.al
new file mode 100755
index 00000000000..ae273c61b33
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CAST5_PP/init.al
@@ -0,0 +1,69 @@
+# NOTE: Derived from blib\lib\Crypt\CAST5_PP.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Crypt::CAST5_PP;
+
+#line 126 "blib\lib\Crypt\CAST5_PP.pm (autosplit into blib\lib\auto\Crypt\CAST5_PP\init.al)"
+sub init {
+ use strict;
+ use integer;
+ my ($cast5, $key) = @_;
+ croak "Key length must be 40 to 128 bits"
+ if length($key) < 5 || length($key) > 16;
+ require Crypt::CAST5_PP::Tables;
+
+ # untaint the key. this keeps the evals from blowing up later.
+ # arguably, a tainted key should result in tainted output. oh well.
+ $key =~ /^(.*)$/s and $key = $1;
+
+ # null-pad the key to 16 bytes, and then split it into 32-bit chunks
+ my ($s, $t, $u, $v) = unpack "N4", pack "a16", $key;
+
+ # compute the key schedule
+ # don't try to read this -- it's generated by mkschedule
+ my ($w, $x, $y, $z, @k);
+ for (1..2) {
+ $w=$s^$s5[$v>>16&255]^$s6[$v&255]^$s7[$v>>24&255]^$s8[$v>>8&255]^$s7[$u>>24&255];
+ $x=$u^$s5[$w>>24&255]^$s6[$w>>8&255]^$s7[$w>>16&255]^$s8[$w&255]^$s8[$u>>8&255];
+ $y=$v^$s5[$x&255]^$s6[$x>>8&255]^$s7[$x>>16&255]^$s8[$x>>24&255]^$s5[$u>>16&255];
+ $z=$t^$s5[$y>>8&255]^$s6[$y>>16&255]^$s7[$y&255]^$s8[$y>>24&255]^$s6[$u&255];
+ push@k,$s5[$y>>24&255]^$s6[$y>>16&255]^$s7[$x&255]^$s8[$x>>8&255]^$s5[$w>>8&255];
+ push@k,$s5[$y>>8&255]^$s6[$y&255]^$s7[$x>>16&255]^$s8[$x>>24&255]^$s6[$x>>8&255];
+ push@k,$s5[$z>>24&255]^$s6[$z>>16&255]^$s7[$w&255]^$s8[$w>>8&255]^$s7[$y>>16&255];
+ push@k,$s5[$z>>8&255]^$s6[$z&255]^$s7[$w>>16&255]^$s8[$w>>24&255]^$s8[$z>>24&255];
+ $s=$y^$s5[$x>>16&255]^$s6[$x&255]^$s7[$x>>24&255]^$s8[$x>>8&255]^$s7[$w>>24&255];
+ $t=$w^$s5[$s>>24&255]^$s6[$s>>8&255]^$s7[$s>>16&255]^$s8[$s&255]^$s8[$w>>8&255];
+ $u=$x^$s5[$t&255]^$s6[$t>>8&255]^$s7[$t>>16&255]^$s8[$t>>24&255]^$s5[$w>>16&255];
+ $v=$z^$s5[$u>>8&255]^$s6[$u>>16&255]^$s7[$u&255]^$s8[$u>>24&255]^$s6[$w&255];
+ push@k,$s5[$s&255]^$s6[$s>>8&255]^$s7[$v>>24&255]^$s8[$v>>16&255]^$s5[$u>>24&255];
+ push@k,$s5[$s>>16&255]^$s6[$s>>24&255]^$s7[$v>>8&255]^$s8[$v&255]^$s6[$v>>16&255];
+ push@k,$s5[$t&255]^$s6[$t>>8&255]^$s7[$u>>24&255]^$s8[$u>>16&255]^$s7[$s&255];
+ push@k,$s5[$t>>16&255]^$s6[$t>>24&255]^$s7[$u>>8&255]^$s8[$u&255]^$s8[$t&255];
+ $w=$s^$s5[$v>>16&255]^$s6[$v&255]^$s7[$v>>24&255]^$s8[$v>>8&255]^$s7[$u>>24&255];
+ $x=$u^$s5[$w>>24&255]^$s6[$w>>8&255]^$s7[$w>>16&255]^$s8[$w&255]^$s8[$u>>8&255];
+ $y=$v^$s5[$x&255]^$s6[$x>>8&255]^$s7[$x>>16&255]^$s8[$x>>24&255]^$s5[$u>>16&255];
+ $z=$t^$s5[$y>>8&255]^$s6[$y>>16&255]^$s7[$y&255]^$s8[$y>>24&255]^$s6[$u&255];
+ push@k,$s5[$w&255]^$s6[$w>>8&255]^$s7[$z>>24&255]^$s8[$z>>16&255]^$s5[$y>>16&255];
+ push@k,$s5[$w>>16&255]^$s6[$w>>24&255]^$s7[$z>>8&255]^$s8[$z&255]^$s6[$z>>24&255];
+ push@k,$s5[$x&255]^$s6[$x>>8&255]^$s7[$y>>24&255]^$s8[$y>>16&255]^$s7[$w>>8&255];
+ push@k,$s5[$x>>16&255]^$s6[$x>>24&255]^$s7[$y>>8&255]^$s8[$y&255]^$s8[$x>>8&255];
+ $s=$y^$s5[$x>>16&255]^$s6[$x&255]^$s7[$x>>24&255]^$s8[$x>>8&255]^$s7[$w>>24&255];
+ $t=$w^$s5[$s>>24&255]^$s6[$s>>8&255]^$s7[$s>>16&255]^$s8[$s&255]^$s8[$w>>8&255];
+ $u=$x^$s5[$t&255]^$s6[$t>>8&255]^$s7[$t>>16&255]^$s8[$t>>24&255]^$s5[$w>>16&255];
+ $v=$z^$s5[$u>>8&255]^$s6[$u>>16&255]^$s7[$u&255]^$s8[$u>>24&255]^$s6[$w&255];
+ push@k,$s5[$u>>24&255]^$s6[$u>>16&255]^$s7[$t&255]^$s8[$t>>8&255]^$s5[$s&255];
+ push@k,$s5[$u>>8&255]^$s6[$u&255]^$s7[$t>>16&255]^$s8[$t>>24&255]^$s6[$t&255];
+ push@k,$s5[$v>>24&255]^$s6[$v>>16&255]^$s7[$s&255]^$s8[$s>>8&255]^$s7[$u>>24&255];
+ push@k,$s5[$v>>8&255]^$s6[$v&255]^$s7[$s>>16&255]^$s8[$s>>24&255]^$s8[$v>>16&255];
+ }
+
+ for (16..31) { $k[$_] &= 31 }
+ delete $cast5->{encrypt};
+ delete $cast5->{decrypt};
+ $cast5->{rounds} = length($key) <= 10 ? 12 : 16;
+ $cast5->{key} = \@k;
+ return $cast5;
+} # init
+
+# end of Crypt::CAST5_PP::init
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CBC/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CBC/.packlist
new file mode 100755
index 00000000000..9e4bb73b0e7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/CBC/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Crypt\CBC.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/.packlist
new file mode 100755
index 00000000000..4db5877d52c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Crypt\DES.pm
+C:\strawberry\perl\vendor\lib\auto\Crypt\DES\DES.bs
+C:\strawberry\perl\vendor\lib\auto\Crypt\DES\DES.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.bs b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.dll b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.dll
new file mode 100755
index 00000000000..f043487558a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES/DES.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES_EDE3/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES_EDE3/.packlist
new file mode 100755
index 00000000000..1de2b0c6ad1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DES_EDE3/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Crypt\DES_EDE3.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DH/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DH/.packlist
new file mode 100755
index 00000000000..bc0a0aa4640
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DH/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Crypt\DH.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DSA/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DSA/.packlist
new file mode 100755
index 00000000000..2970863abf7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/DSA/.packlist
@@ -0,0 +1,7 @@
+C:\strawberry\perl\vendor\lib\Crypt\DSA.pm
+C:\strawberry\perl\vendor\lib\Crypt\DSA\Key.pm
+C:\strawberry\perl\vendor\lib\Crypt\DSA\KeyChain.pm
+C:\strawberry\perl\vendor\lib\Crypt\DSA\Key\PEM.pm
+C:\strawberry\perl\vendor\lib\Crypt\DSA\Key\SSH2.pm
+C:\strawberry\perl\vendor\lib\Crypt\DSA\Signature.pm
+C:\strawberry\perl\vendor\lib\Crypt\DSA\Util.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/.packlist
new file mode 100755
index 00000000000..f0f778620c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/.packlist
@@ -0,0 +1,5 @@
+C:\strawberry\perl\vendor\lib\Crypt\._test.pl
+C:\strawberry\perl\vendor\lib\Crypt\IDEA.pm
+C:\strawberry\perl\vendor\lib\Crypt\IDEA.pod
+C:\strawberry\perl\vendor\lib\auto\Crypt\IDEA\IDEA.bs
+C:\strawberry\perl\vendor\lib\auto\Crypt\IDEA\IDEA.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.bs b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.dll b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.dll
new file mode 100755
index 00000000000..c3182c0f1ac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/IDEA/IDEA.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/OpenPGP/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/OpenPGP/.packlist
new file mode 100755
index 00000000000..511e24203c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/OpenPGP/.packlist
@@ -0,0 +1,39 @@
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Armour.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Buffer.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\CFB.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Certificate.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Cipher.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Ciphertext.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Compressed.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Config.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Constants.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Digest.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\ErrorHandler.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\KeyBlock.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\KeyRing.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\KeyServer.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Public.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Public\DSA.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Public\ElGamal.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Public\RSA.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Secret.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Secret\DSA.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Secret\ElGamal.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Key\Secret\RSA.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\MDC.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Marker.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Message.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\OnePassSig.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\PacketFactory.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Plaintext.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\S2k.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\SKSessionKey.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\SessionKey.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Signature.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Signature\SubPacket.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Trust.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\UserID.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Util.pm
+C:\strawberry\perl\vendor\lib\Crypt\OpenPGP\Words.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Primes/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Primes/.packlist
new file mode 100755
index 00000000000..4f3fa5cc0fa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Primes/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\largeprimes
+C:\strawberry\perl\bin\largeprimes.bat
+C:\strawberry\perl\vendor\lib\Crypt\Primes.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/.packlist
new file mode 100755
index 00000000000..cff4348dcf0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/.packlist
@@ -0,0 +1,5 @@
+C:\strawberry\perl\vendor\lib\Crypt\RIPEMD160.pm
+C:\strawberry\perl\vendor\lib\Crypt\RIPEMD160\MAC.pm
+C:\strawberry\perl\vendor\lib\auto\Crypt\RIPEMD160\RIPEMD160.bs
+C:\strawberry\perl\vendor\lib\auto\Crypt\RIPEMD160\RIPEMD160.dll
+C:\strawberry\perl\vendor\lib\auto\Crypt\RIPEMD160\autosplit.ix
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.bs b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.dll b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.dll
new file mode 100755
index 00000000000..e1abdc5453c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/RIPEMD160.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/autosplit.ix
new file mode 100755
index 00000000000..a083199e4d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RIPEMD160/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Crypt\RIPEMD160.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RSA/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RSA/.packlist
new file mode 100755
index 00000000000..55887e7f42a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/RSA/.packlist
@@ -0,0 +1,14 @@
+C:\strawberry\perl\vendor\lib\Crypt\RSA.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\DataFormat.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Debug.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\ES\OAEP.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\ES\PKCS1v15.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Errorhandler.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Key.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Key\Private.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Key\Private\SSH.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Key\Public.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Key\Public\SSH.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\Primitives.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\SS\PKCS1v15.pm
+C:\strawberry\perl\vendor\lib\Crypt\RSA\SS\PSS.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Random/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Random/.packlist
new file mode 100755
index 00000000000..23e48886660
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Random/.packlist
@@ -0,0 +1,9 @@
+C:\strawberry\perl\bin\makerandom
+C:\strawberry\perl\bin\makerandom.bat
+C:\strawberry\perl\vendor\lib\Crypt\Random.pm
+C:\strawberry\perl\vendor\lib\Crypt\Random\Generator.pm
+C:\strawberry\perl\vendor\lib\Crypt\Random\Provider\File.pm
+C:\strawberry\perl\vendor\lib\Crypt\Random\Provider\devrandom.pm
+C:\strawberry\perl\vendor\lib\Crypt\Random\Provider\devurandom.pm
+C:\strawberry\perl\vendor\lib\Crypt\Random\Provider\egd.pm
+C:\strawberry\perl\vendor\lib\Crypt\Random\Provider\rand.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/.packlist
new file mode 100755
index 00000000000..bde3d0220ff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Crypt\Rijndael.pm
+C:\strawberry\perl\vendor\lib\auto\Crypt\Rijndael\Rijndael.bs
+C:\strawberry\perl\vendor\lib\auto\Crypt\Rijndael\Rijndael.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.bs b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.dll b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.dll
new file mode 100755
index 00000000000..2c6d205c728
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Rijndael/Rijndael.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/.packlist
new file mode 100755
index 00000000000..da8330ad9cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/.packlist
@@ -0,0 +1,9 @@
+C:\strawberry\perl\vendor\lib\Crypt\SSLeay.pm
+C:\strawberry\perl\vendor\lib\Crypt\SSLeay\CTX.pm
+C:\strawberry\perl\vendor\lib\Crypt\SSLeay\Conn.pm
+C:\strawberry\perl\vendor\lib\Crypt\SSLeay\Err.pm
+C:\strawberry\perl\vendor\lib\Crypt\SSLeay\MainContext.pm
+C:\strawberry\perl\vendor\lib\Crypt\SSLeay\X509.pm
+C:\strawberry\perl\vendor\lib\Net\SSL.pm
+C:\strawberry\perl\vendor\lib\auto\Crypt\SSLeay\SSLeay.bs
+C:\strawberry\perl\vendor\lib\auto\Crypt\SSLeay\SSLeay.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.bs b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.dll b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.dll
new file mode 100755
index 00000000000..2079b5cd1b7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/SSLeay/SSLeay.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/.packlist
new file mode 100755
index 00000000000..67dbca98338
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Crypt\Twofish.pm
+C:\strawberry\perl\vendor\lib\auto\Crypt\Twofish\Twofish.bs
+C:\strawberry\perl\vendor\lib\auto\Crypt\Twofish\Twofish.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.bs b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.dll b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.dll
new file mode 100755
index 00000000000..323e51db070
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Crypt/Twofish/Twofish.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Cwd/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Cwd/.packlist
new file mode 100755
index 00000000000..0d5c260a6d6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Cwd/.packlist
@@ -0,0 +1,12 @@
+C:\strawberry\perl\lib\Cwd.pm
+C:\strawberry\perl\lib\File\Spec.pm
+C:\strawberry\perl\lib\File\Spec\Cygwin.pm
+C:\strawberry\perl\lib\File\Spec\Epoc.pm
+C:\strawberry\perl\lib\File\Spec\Functions.pm
+C:\strawberry\perl\lib\File\Spec\Mac.pm
+C:\strawberry\perl\lib\File\Spec\OS2.pm
+C:\strawberry\perl\lib\File\Spec\Unix.pm
+C:\strawberry\perl\lib\File\Spec\VMS.pm
+C:\strawberry\perl\lib\File\Spec\Win32.pm
+C:\strawberry\perl\lib\auto\Cwd\Cwd.bs
+C:\strawberry\perl\lib\auto\Cwd\Cwd.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.bs b/Master/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.dll b/Master/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.dll
new file mode 100755
index 00000000000..0841fc80cee
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Cwd/Cwd.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/.packlist
new file mode 100755
index 00000000000..dd2a88fa28e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/.packlist
@@ -0,0 +1,5 @@
+C:\strawberry\perl\vendor\lib\DBD\ODBC.pm
+C:\strawberry\perl\vendor\lib\DBD\ODBC\Changes.pm
+C:\strawberry\perl\vendor\lib\DBD\ODBC\FAQ.pm
+C:\strawberry\perl\vendor\lib\auto\DBD\ODBC\ODBC.bs
+C:\strawberry\perl\vendor\lib\auto\DBD\ODBC\ODBC.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.bs b/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.dll b/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.dll
new file mode 100755
index 00000000000..056716e17e6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/ODBC/ODBC.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/.packlist
new file mode 100755
index 00000000000..86f5b168e0d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\Bundle\DBD\Pg.pm
+C:\strawberry\perl\vendor\lib\DBD\Pg.pm
+C:\strawberry\perl\vendor\lib\auto\DBD\Pg\Pg.bs
+C:\strawberry\perl\vendor\lib\auto\DBD\Pg\Pg.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.bs b/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.dll b/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.dll
new file mode 100755
index 00000000000..528aa161bc4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/Pg/Pg.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/.packlist
new file mode 100755
index 00000000000..aae5b9ae406
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\DBD\SQLite.pm
+C:\strawberry\perl\vendor\lib\DBD\SQLite\Cookbook.pod
+C:\strawberry\perl\vendor\lib\auto\DBD\SQLite\SQLite.bs
+C:\strawberry\perl\vendor\lib\auto\DBD\SQLite\SQLite.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.bs b/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.dll b/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.dll
new file mode 100755
index 00000000000..aa4c8a8c880
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/SQLite/SQLite.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/.packlist
new file mode 100755
index 00000000000..9953af53d94
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\vendor\lib\Bundle\DBD\mysql.pm
+C:\strawberry\perl\vendor\lib\DBD\mysql.pm
+C:\strawberry\perl\vendor\lib\DBD\mysql\GetInfo.pm
+C:\strawberry\perl\vendor\lib\DBD\mysql\INSTALL.pod
+C:\strawberry\perl\vendor\lib\auto\DBD\mysql\mysql.bs
+C:\strawberry\perl\vendor\lib\auto\DBD\mysql\mysql.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/libmysql.dll b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/libmysql.dll
new file mode 100755
index 00000000000..2f240f1e3a4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/libmysql.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.bs b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.dll b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.dll
new file mode 100755
index 00000000000..14393ecffcb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBD/mysql/mysql.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DBI/.packlist
new file mode 100755
index 00000000000..bbca50fb4ef
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/.packlist
@@ -0,0 +1,66 @@
+C:\strawberry\perl\bin\dbilogstrip
+C:\strawberry\perl\bin\dbilogstrip.bat
+C:\strawberry\perl\bin\dbiprof
+C:\strawberry\perl\bin\dbiprof.bat
+C:\strawberry\perl\bin\dbiproxy
+C:\strawberry\perl\bin\dbiproxy.bat
+C:\strawberry\perl\vendor\lib\Bundle\DBI.pm
+C:\strawberry\perl\vendor\lib\DBD\DBM.pm
+C:\strawberry\perl\vendor\lib\DBD\ExampleP.pm
+C:\strawberry\perl\vendor\lib\DBD\File.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Policy\Base.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Policy\classic.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Policy\pedantic.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Policy\rush.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Transport\Base.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Transport\null.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Transport\pipeone.pm
+C:\strawberry\perl\vendor\lib\DBD\Gofer\Transport\stream.pm
+C:\strawberry\perl\vendor\lib\DBD\NullP.pm
+C:\strawberry\perl\vendor\lib\DBD\Proxy.pm
+C:\strawberry\perl\vendor\lib\DBD\Sponge.pm
+C:\strawberry\perl\vendor\lib\DBI.pm
+C:\strawberry\perl\vendor\lib\DBI\Changes.pm
+C:\strawberry\perl\vendor\lib\DBI\Const\GetInfoReturn.pm
+C:\strawberry\perl\vendor\lib\DBI\Const\GetInfoType.pm
+C:\strawberry\perl\vendor\lib\DBI\Const\GetInfo\ANSI.pm
+C:\strawberry\perl\vendor\lib\DBI\Const\GetInfo\ODBC.pm
+C:\strawberry\perl\vendor\lib\DBI\DBD.pm
+C:\strawberry\perl\vendor\lib\DBI\DBD\Metadata.pm
+C:\strawberry\perl\vendor\lib\DBI\FAQ.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Execute.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Request.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Response.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Serializer\Base.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Serializer\DataDumper.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Serializer\Storable.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Transport\Base.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Transport\pipeone.pm
+C:\strawberry\perl\vendor\lib\DBI\Gofer\Transport\stream.pm
+C:\strawberry\perl\vendor\lib\DBI\Profile.pm
+C:\strawberry\perl\vendor\lib\DBI\ProfileData.pm
+C:\strawberry\perl\vendor\lib\DBI\ProfileDumper.pm
+C:\strawberry\perl\vendor\lib\DBI\ProfileDumper\Apache.pm
+C:\strawberry\perl\vendor\lib\DBI\ProfileSubs.pm
+C:\strawberry\perl\vendor\lib\DBI\ProxyServer.pm
+C:\strawberry\perl\vendor\lib\DBI\PurePerl.pm
+C:\strawberry\perl\vendor\lib\DBI\Roadmap.pm
+C:\strawberry\perl\vendor\lib\DBI\SQL\Nano.pm
+C:\strawberry\perl\vendor\lib\DBI\Util\CacheMemory.pm
+C:\strawberry\perl\vendor\lib\DBI\Util\_accessor.pm
+C:\strawberry\perl\vendor\lib\DBI\W32ODBC.pm
+C:\strawberry\perl\vendor\lib\Roadmap.pod
+C:\strawberry\perl\vendor\lib\TASKS.pod
+C:\strawberry\perl\vendor\lib\Win32\DBIODBC.pm
+C:\strawberry\perl\vendor\lib\auto\DBI\DBI.bs
+C:\strawberry\perl\vendor\lib\auto\DBI\DBI.dll
+C:\strawberry\perl\vendor\lib\auto\DBI\DBIXS.h
+C:\strawberry\perl\vendor\lib\auto\DBI\Driver.xst
+C:\strawberry\perl\vendor\lib\auto\DBI\Driver_xst.h
+C:\strawberry\perl\vendor\lib\auto\DBI\dbd_xsh.h
+C:\strawberry\perl\vendor\lib\auto\DBI\dbi_sql.h
+C:\strawberry\perl\vendor\lib\auto\DBI\dbipport.h
+C:\strawberry\perl\vendor\lib\auto\DBI\dbivport.h
+C:\strawberry\perl\vendor\lib\auto\DBI\dbixs_rev.h
+C:\strawberry\perl\vendor\lib\dbixs_rev.pl
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBI.bs b/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBI.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBI.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBI.dll b/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBI.dll
new file mode 100755
index 00000000000..0879692039f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBI.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBIXS.h b/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBIXS.h
new file mode 100755
index 00000000000..a371bf8d855
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/DBIXS.h
@@ -0,0 +1,519 @@
+/* $Id: DBIXS.h 12559 2009-03-02 11:14:07Z timbo $
+ *
+ * Copyright (c) 1994-2002 Tim Bunce Ireland
+ *
+ * See COPYRIGHT section in DBI.pm for usage and distribution rights.
+ */
+
+/* DBI Interface Definitions for DBD Modules */
+
+#ifndef DBIXS_VERSION /* prevent multiple inclusion */
+
+#ifndef DBIS
+#define DBIS dbis /* default name for dbistate_t variable */
+#endif
+
+/* first pull in the standard Perl header files for extensions */
+#define PERL_POLLUTE
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+
+#ifdef debug /* causes problems with DBIS->debug */
+#undef debug
+#endif
+
+#ifdef std /* causes problems with STLport <tscheresky@micron.com> */
+#undef std
+#endif
+
+/* define DBIXS_REVISION */
+#include "dbixs_rev.h"
+
+/* Perl backwards compatibility definitions */
+#include "dbipport.h"
+
+/* DBI SQL_* type definitions */
+#include "dbi_sql.h"
+
+
+/* The DBIXS_VERSION value will be incremented whenever new code is
+ * added to the interface (this file) or significant changes are made.
+ * It's primary goal is to allow newer drivers to compile against an
+ * older installed DBI. This is mainly an issue whilst the API grows
+ * and learns from the needs of various drivers. See also the
+ * DBISTATE_VERSION macro below. You can think of DBIXS_VERSION as
+ * being a compile time check and DBISTATE_VERSION as a runtime check.
+ * By contract, DBIXS_REVISION is a driver source compatibility tool.
+ */
+#define DBIXS_VERSION 93
+
+#ifdef NEED_DBIXS_VERSION
+#if NEED_DBIXS_VERSION > DBIXS_VERSION
+error You_need_to_upgrade_your_DBI_module_before_building_this_driver
+#endif
+#else
+#define NEED_DBIXS_VERSION DBIXS_VERSION
+#endif
+
+
+#define DBI_LOCK
+#define DBI_UNLOCK
+
+#ifndef DBI_NO_THREADS
+#ifdef USE_ITHREADS
+#define DBI_USE_THREADS
+#endif /* USE_ITHREADS */
+#endif /* DBI_NO_THREADS */
+
+
+/* forward struct declarations */
+
+typedef struct dbistate_st dbistate_t;
+/* implementor needs to define actual struct { dbih_??c_t com; ... }*/
+typedef struct imp_drh_st imp_drh_t; /* driver */
+typedef struct imp_dbh_st imp_dbh_t; /* database */
+typedef struct imp_sth_st imp_sth_t; /* statement */
+typedef struct imp_fdh_st imp_fdh_t; /* field descriptor */
+typedef struct imp_xxh_st imp_xxh_t; /* any (defined below) */
+#define DBI_imp_data_ imp_xxh_t /* friendly for take_imp_data */
+
+
+
+/* --- DBI Handle Common Data Structure (all handles have one) --- */
+
+/* Handle types. Code currently assumes child = parent + 1. */
+#define DBIt_DR 1
+#define DBIt_DB 2
+#define DBIt_ST 3
+#define DBIt_FD 4
+
+/* component structures */
+
+typedef struct dbih_com_std_st {
+ U32 flags;
+ int call_depth; /* used by DBI to track nested calls (int) */
+ U16 type; /* DBIt_DR, DBIt_DB, DBIt_ST */
+ HV *my_h; /* copy of outer handle HV (not refcounted) */
+ SV *parent_h; /* parent inner handle (ref to hv) (r.c.inc) */
+ imp_xxh_t *parent_com; /* parent com struct shortcut */
+ PerlInterpreter * thr_user; /* thread that owns the handle */
+
+ HV *imp_stash; /* who is the implementor for this handle */
+ SV *imp_data; /* optional implementors data (for perl imp's) */
+
+ I32 kids; /* count of db's for dr's, st's for db's etc */
+ I32 active_kids; /* kids which are currently DBIc_ACTIVE */
+ U32 pad; /* keep binary compat */
+ dbistate_t *dbistate;
+} dbih_com_std_t;
+
+typedef struct dbih_com_attr_st {
+ /* These are copies of the Hash values (ref.cnt.inc'd) */
+ /* Many of the hash values are themselves references */
+ SV *TraceLevel;
+ SV *State; /* Standard SQLSTATE, 5 char string */
+ SV *Err; /* Native engine error code */
+ SV *Errstr; /* Native engine error message */
+ UV ErrCount;
+ U32 LongReadLen; /* auto read length for long/blob types */
+ SV *FetchHashKeyName; /* for fetchrow_hashref */
+ /* (NEW FIELDS?... DON'T FORGET TO UPDATE dbih_clearcom()!) */
+} dbih_com_attr_t;
+
+
+struct dbih_com_st { /* complete core structure (typedef'd above) */
+ dbih_com_std_t std;
+ dbih_com_attr_t attr;
+};
+
+/* This 'implementors' type the DBI defines by default as a way to */
+/* refer to the imp_??h data of a handle without considering its type. */
+struct imp_xxh_st { struct dbih_com_st com; };
+
+/* Define handle-type specific structures for implementors to include */
+/* at the start of their private structures. */
+
+typedef struct { /* -- DRIVER -- */
+ dbih_com_std_t std;
+ dbih_com_attr_t attr;
+ HV *_old_cached_kids; /* not used, here for binary compat */
+} dbih_drc_t;
+
+typedef struct { /* -- DATABASE -- */
+ dbih_com_std_t std; /* \__ standard structure */
+ dbih_com_attr_t attr; /* / plus... (nothing else right now) */
+ HV *_old_cached_kids; /* not used, here for binary compat */
+} dbih_dbc_t;
+
+typedef struct { /* -- STATEMENT -- */
+ dbih_com_std_t std; /* \__ standard structure */
+ dbih_com_attr_t attr; /* / plus ... */
+
+ int num_params; /* number of placeholders */
+ int num_fields; /* NUM_OF_FIELDS, must be set */
+ AV *fields_svav; /* special row buffer (inc bind_cols) */
+ IV row_count; /* incremented by get_fbav() */
+
+ AV *fields_fdav; /* not used yet, may change */
+
+ I32 spare1;
+ void *spare2;
+} dbih_stc_t;
+
+
+/* XXX THIS STRUCTURE SHOULD NOT BE USED */
+typedef struct { /* -- FIELD DESCRIPTOR -- */
+ dbih_com_std_t std; /* standard structure (not fully setup) */
+
+ /* core attributes (from DescribeCol in ODBC) */
+ char *col_name; /* see dbih_make_fdsv */
+ I16 col_name_len;
+ I16 col_sql_type;
+ I16 col_precision;
+ I16 col_scale;
+ I16 col_nullable;
+
+ /* additional attributes (from ColAttributes in ODBC) */
+ I32 col_length;
+ I32 col_disp_size;
+
+ I32 spare1;
+ void *spare2;
+} dbih_fdc_t;
+
+
+#define _imp2com(p,f) ((p)->com.f)
+
+#define DBIc_FLAGS(imp) _imp2com(imp, std.flags)
+#define DBIc_TYPE(imp) _imp2com(imp, std.type)
+#define DBIc_CALL_DEPTH(imp) _imp2com(imp, std.call_depth)
+#define DBIc_MY_H(imp) _imp2com(imp, std.my_h)
+#define DBIc_PARENT_H(imp) _imp2com(imp, std.parent_h)
+#define DBIc_PARENT_COM(imp) _imp2com(imp, std.parent_com)
+#define DBIc_THR_COND(imp) _imp2com(imp, std.thr_cond)
+#define DBIc_THR_USER(imp) _imp2com(imp, std.thr_user)
+#define DBIc_THR_USER_NONE (0xFFFF)
+#define DBIc_IMP_STASH(imp) _imp2com(imp, std.imp_stash)
+#define DBIc_IMP_DATA(imp) _imp2com(imp, std.imp_data)
+#define DBIc_DBISTATE(imp) _imp2com(imp, std.dbistate)
+#define DBIc_LOGPIO(imp) DBIc_DBISTATE(imp)->logfp
+#define DBIc_KIDS(imp) _imp2com(imp, std.kids)
+#define DBIc_ACTIVE_KIDS(imp) _imp2com(imp, std.active_kids)
+#define DBIc_LAST_METHOD(imp) _imp2com(imp, std.last_method)
+
+#define DBIc_TRACE_LEVEL_MASK 0x0000000F
+#define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00
+#define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug)
+#define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK)
+#define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK)
+/* DBIc_TRACE_MATCHES(this, crnt): true if this 'matches' (is within) crnt
+ DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp))
+*/
+#define DBIc_TRACE_MATCHES(this, crnt) \
+ ( ((crnt & DBIc_TRACE_LEVEL_MASK) >= (this & DBIc_TRACE_LEVEL_MASK)) \
+ || ((crnt & DBIc_TRACE_FLAGS_MASK) & (this & DBIc_TRACE_FLAGS_MASK)) )
+/* DBIc_TRACE: true if flags match & DBI level>=flaglevel, or if DBI level>level
+ This is the main trace testing macro to be used by drivers.
+ (Drivers should define their own DBDtf_* macros for the top 8 bits: 0xFF000000)
+ DBIc_TRACE(imp, 0, 0, 4) = if level >= 4
+ DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4
+ DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level
+*/
+#define DBIc_TRACE(imp, flags, flaglevel, level) \
+ ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \
+ || (level && DBIc_TRACE_LEVEL(imp) >= level) )
+
+#define DBIc_DEBUG(imp) (_imp2com(imp, attr.TraceLevel)) /* deprecated */
+#define DBIc_DEBUGIV(imp) SvIV(DBIc_DEBUG(imp)) /* deprecated */
+#define DBIc_STATE(imp) SvRV(_imp2com(imp, attr.State))
+#define DBIc_ERR(imp) SvRV(_imp2com(imp, attr.Err))
+#define DBIc_ERRSTR(imp) SvRV(_imp2com(imp, attr.Errstr))
+#define DBIc_ErrCount(imp) _imp2com(imp, attr.ErrCount)
+#define DBIc_LongReadLen(imp) _imp2com(imp, attr.LongReadLen)
+#define DBIc_LongReadLen_init 80 /* may change */
+#define DBIc_FetchHashKeyName(imp) (_imp2com(imp, attr.FetchHashKeyName))
+
+/* handle sub-type specific fields */
+/* dbh & drh */
+#define DBIc_CACHED_KIDS(imp) Nullhv /* no longer used, here for src compat */
+/* sth */
+#define DBIc_NUM_FIELDS(imp) _imp2com(imp, num_fields)
+#define DBIc_NUM_PARAMS(imp) _imp2com(imp, num_params)
+#define DBIc_NUM_PARAMS_AT_EXECUTE -9 /* see Driver.xst */
+#define DBIc_ROW_COUNT(imp) _imp2com(imp, row_count)
+#define DBIc_FIELDS_AV(imp) _imp2com(imp, fields_svav)
+#define DBIc_FDESC_AV(imp) _imp2com(imp, fields_fdav)
+#define DBIc_FDESC(imp, i) ((imp_fdh_t*)(void*)SvPVX(AvARRAY(DBIc_FDESC_AV(imp))[i]))
+
+/* XXX --- DO NOT CHANGE THESE VALUES AS THEY ARE COMPILED INTO DRIVERS --- XXX */
+#define DBIcf_COMSET 0x000001 /* needs to be clear'd before free'd */
+#define DBIcf_IMPSET 0x000002 /* has implementor data to be clear'd */
+#define DBIcf_ACTIVE 0x000004 /* needs finish/disconnect before clear */
+#define DBIcf_IADESTROY 0x000008 /* do DBIc_ACTIVE_off before DESTROY */
+#define DBIcf_WARN 0x000010 /* warn about poor practice etc */
+#define DBIcf_COMPAT 0x000020 /* compat/emulation mode (eg oraperl) */
+#define DBIcf_ChopBlanks 0x000040 /* rtrim spaces from fetch char columns */
+#define DBIcf_RaiseError 0x000080 /* throw exception (croak) on error */
+#define DBIcf_PrintError 0x000100 /* warn() on error */
+#define DBIcf_AutoCommit 0x000200 /* dbh only. used by drivers */
+#define DBIcf_LongTruncOk 0x000400 /* truncation to LongReadLen is okay */
+#define DBIcf_MultiThread 0x000800 /* allow multiple threads to enter */
+#define DBIcf_HandleSetErr 0x001000 /* has coderef HandleSetErr attribute */
+#define DBIcf_ShowErrorStatement 0x002000 /* include Statement in error */
+#define DBIcf_BegunWork 0x004000 /* between begin_work & commit/rollback */
+#define DBIcf_HandleError 0x008000 /* has coderef in HandleError attribute */
+#define DBIcf_Profile 0x010000 /* profile activity on this handle */
+#define DBIcf_TaintIn 0x020000 /* check inputs for taintedness */
+#define DBIcf_TaintOut 0x040000 /* taint outgoing data */
+#define DBIcf_Executed 0x080000 /* do/execute called since commit/rollb */
+#define DBIcf_PrintWarn 0x100000 /* warn() on warning (err="0") */
+#define DBIcf_Callbacks 0x200000 /* has Callbacks attribute hash */
+/* NOTE: new flags may require clone() to be updated */
+
+#define DBIcf_INHERITMASK /* what NOT to pass on to children */ \
+ (U32)( DBIcf_COMSET | DBIcf_IMPSET | DBIcf_ACTIVE | DBIcf_IADESTROY \
+ | DBIcf_AutoCommit | DBIcf_BegunWork | DBIcf_Executed | DBIcf_Callbacks )
+
+/* general purpose bit setting and testing macros */
+#define DBIbf_is( bitset,flag) ((bitset) & (flag))
+#define DBIbf_has(bitset,flag) DBIbf_is(bitset, flag) /* alias for _is */
+#define DBIbf_on( bitset,flag) ((bitset) |= (flag))
+#define DBIbf_off(bitset,flag) ((bitset) &= ~(flag))
+#define DBIbf_set(bitset,flag,on) ((on) ? DBIbf_on(bitset, flag) : DBIbf_off(bitset,flag))
+
+/* as above, but specifically for DBIc_FLAGS imp flags (except ACTIVE) */
+#define DBIc_is(imp, flag) DBIbf_is( DBIc_FLAGS(imp), flag)
+#define DBIc_has(imp,flag) DBIc_is(imp, flag) /* alias for DBIc_is */
+#define DBIc_on(imp, flag) DBIbf_on( DBIc_FLAGS(imp), flag)
+#define DBIc_off(imp,flag) DBIbf_off(DBIc_FLAGS(imp), flag)
+#define DBIc_set(imp,flag,on) DBIbf_set(DBIc_FLAGS(imp), flag, on)
+
+#define DBIc_COMSET(imp) DBIc_is(imp, DBIcf_COMSET)
+#define DBIc_COMSET_on(imp) DBIc_on(imp, DBIcf_COMSET)
+#define DBIc_COMSET_off(imp) DBIc_off(imp,DBIcf_COMSET)
+
+#define DBIc_IMPSET(imp) DBIc_is(imp, DBIcf_IMPSET)
+#define DBIc_IMPSET_on(imp) DBIc_on(imp, DBIcf_IMPSET)
+#define DBIc_IMPSET_off(imp) DBIc_off(imp,DBIcf_IMPSET)
+
+#define DBIc_ACTIVE(imp) (DBIc_FLAGS(imp) & DBIcf_ACTIVE)
+#define DBIc_ACTIVE_on(imp) /* adjust parent's active kid count */ \
+ do { \
+ imp_xxh_t *ph_com = DBIc_PARENT_COM(imp); \
+ if (!DBIc_ACTIVE(imp) && ph_com && !dirty \
+ && ++DBIc_ACTIVE_KIDS(ph_com) > DBIc_KIDS(ph_com)) \
+ croak("panic: DBI active kids (%ld) > kids (%ld)", \
+ (long)DBIc_ACTIVE_KIDS(ph_com), \
+ (long)DBIc_KIDS(ph_com)); \
+ DBIc_FLAGS(imp) |= DBIcf_ACTIVE; \
+ } while(0)
+#define DBIc_ACTIVE_off(imp) /* adjust parent's active kid count */ \
+ do { \
+ imp_xxh_t *ph_com = DBIc_PARENT_COM(imp); \
+ if (DBIc_ACTIVE(imp) && ph_com && !dirty \
+ && (--DBIc_ACTIVE_KIDS(ph_com) > DBIc_KIDS(ph_com) \
+ || DBIc_ACTIVE_KIDS(ph_com) < 0) ) \
+ croak("panic: DBI active kids (%ld) < 0 or > kids (%ld)", \
+ (long)DBIc_ACTIVE_KIDS(ph_com), \
+ (long)DBIc_KIDS(ph_com)); \
+ DBIc_FLAGS(imp) &= ~DBIcf_ACTIVE; \
+ } while(0)
+
+#define DBIc_IADESTROY(imp) (DBIc_FLAGS(imp) & DBIcf_IADESTROY)
+#define DBIc_IADESTROY_on(imp) (DBIc_FLAGS(imp) |= DBIcf_IADESTROY)
+#define DBIc_IADESTROY_off(imp) (DBIc_FLAGS(imp) &= ~DBIcf_IADESTROY)
+
+#define DBIc_WARN(imp) (DBIc_FLAGS(imp) & DBIcf_WARN)
+#define DBIc_WARN_on(imp) (DBIc_FLAGS(imp) |= DBIcf_WARN)
+#define DBIc_WARN_off(imp) (DBIc_FLAGS(imp) &= ~DBIcf_WARN)
+
+#define DBIc_COMPAT(imp) (DBIc_FLAGS(imp) & DBIcf_COMPAT)
+#define DBIc_COMPAT_on(imp) (DBIc_FLAGS(imp) |= DBIcf_COMPAT)
+#define DBIc_COMPAT_off(imp) (DBIc_FLAGS(imp) &= ~DBIcf_COMPAT)
+
+
+#ifdef IN_DBI_XS /* get Handle Common Data Structure */
+#define DBIh_COM(h) (dbih_getcom2(aTHX_ h, 0))
+#else
+#define DBIh_COM(h) (DBIS->getcom(h))
+#define neatsvpv(sv,len) (DBIS->neat_svpv(sv,len))
+#endif
+
+
+/* --- Implementors Private Data Support --- */
+
+#define D_impdata(name,type,h) type *name = (type*)(DBIh_COM(h))
+#define D_imp_drh(h) D_impdata(imp_drh, imp_drh_t, h)
+#define D_imp_dbh(h) D_impdata(imp_dbh, imp_dbh_t, h)
+#define D_imp_sth(h) D_impdata(imp_sth, imp_sth_t, h)
+#define D_imp_xxh(h) D_impdata(imp_xxh, imp_xxh_t, h)
+
+#define D_imp_from_child(name,type,child) \
+ type *name = (type*)(DBIc_PARENT_COM(child))
+#define D_imp_drh_from_dbh D_imp_from_child(imp_drh, imp_drh_t, imp_dbh)
+#define D_imp_dbh_from_sth D_imp_from_child(imp_dbh, imp_dbh_t, imp_sth)
+
+#define DBI_IMP_SIZE(n,s) sv_setiv(perl_get_sv((n), GV_ADDMULTI), (s)) /* XXX */
+
+
+
+/* --- Event Support (VERY LIABLE TO CHANGE) --- */
+
+#define DBIh_EVENTx(h,t,a1,a2) /* deprecated XXX */ &PL_sv_no
+#define DBIh_EVENT0(h,t) DBIh_EVENTx((h), (t), &PL_sv_undef, &PL_sv_undef)
+#define DBIh_EVENT1(h,t, a1) DBIh_EVENTx((h), (t), (a1), &PL_sv_undef)
+#define DBIh_EVENT2(h,t, a1,a2) DBIh_EVENTx((h), (t), (a1), (a2))
+
+#define ERROR_event "ERROR"
+#define WARN_event "WARN"
+#define MSG_event "MESSAGE"
+#define DBEVENT_event "DBEVENT"
+#define UNKNOWN_event "UNKNOWN"
+
+#define DBIh_SET_ERR_SV(h,i, err, errstr, state, method) \
+ (DBIc_DBISTATE(i)->set_err_sv(h,i, err, errstr, state, method))
+#define DBIh_SET_ERR_CHAR(h,i, err_c, err_i, errstr, state, method) \
+ (DBIc_DBISTATE(i)->set_err_char(h,i, err_c, err_i, errstr, state, method))
+
+
+/* --- Handy Macros --- */
+
+#define DBIh_CLEAR_ERROR(imp_xxh) (void)( \
+ (void)SvOK_off(DBIc_ERR(imp_xxh)), \
+ (void)SvOK_off(DBIc_ERRSTR(imp_xxh)), \
+ (void)SvOK_off(DBIc_STATE(imp_xxh)) \
+ )
+
+
+/* --- DBI State Structure --- */
+
+struct dbistate_st {
+
+#define DBISTATE_VERSION 94 /* Must change whenever dbistate_t does */
+
+ /* this must be the first member in structure */
+ void (*check_version) _((const char *name,
+ int dbis_cv, int dbis_cs, int need_dbixs_cv,
+ int drc_s, int dbc_s, int stc_s, int fdc_s));
+
+ /* version and size are used to check for DBI/DBD version mis-match */
+ U16 version; /* version of this structure */
+ U16 size;
+ U16 xs_version; /* version of the overall DBIXS / DBD interface */
+ U16 spare_pad;
+
+ I32 debug;
+ PerlIO *logfp;
+
+ /* pointers to DBI functions which the DBD's will want to use */
+ char * (*neat_svpv) _((SV *sv, STRLEN maxlen));
+ imp_xxh_t * (*getcom) _((SV *h)); /* see DBIh_COM macro */
+ void (*clearcom) _((imp_xxh_t *imp_xxh));
+ SV * (*event) _((SV *h, const char *name, SV*, SV*));
+ int (*set_attr_k) _((SV *h, SV *keysv, int dbikey, SV *valuesv));
+ SV * (*get_attr_k) _((SV *h, SV *keysv, int dbikey));
+ AV * (*get_fbav) _((imp_sth_t *imp_sth));
+ SV * (*make_fdsv) _((SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name));
+ int (*bind_as_num) _((int sql_type, int p, int s, int *t, void *v));
+ I32 (*hash) _((const char *string, long i));
+ SV * (*preparse) _((SV *sth, char *statement, IV ps_return, IV ps_accept, void *foo));
+
+ SV *neatsvpvlen; /* only show dbgpvlen chars when debugging pv's */
+
+ PerlInterpreter * thr_owner; /* thread that owns this dbistate */
+
+ int (*logmsg) _((imp_xxh_t *imp_xxh, const char *fmt, ...));
+ int (*set_err_sv) _((SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method));
+ int (*set_err_char) _((SV *h, imp_xxh_t *imp_xxh, const char *err, IV err_i, const char *errstr, const char *state, const char *method));
+ int (*bind_col) _((SV *sth, SV *col, SV *ref, SV *attribs));
+
+ IO *logfp_ref; /* DAA keep ptr to filehandle for refcounting */
+
+ /* WARNING: Only add new structure members here, and reduce pad2 to keep */
+ /* the memory footprint exactly the same */
+ void *pad2[4];
+};
+
+/* macros for backwards compatibility */
+#define set_attr(h, k, v) set_attr_k(h, k, 0, v)
+#define get_attr(h, k) get_attr_k(h, k, 0)
+
+#define DBISTATE_PERLNAME "DBI::_dbistate"
+#define DBISTATE_ADDRSV (perl_get_sv(DBISTATE_PERLNAME, 0x05))
+#define DBILOGFP (DBIS->logfp)
+#ifdef IN_DBI_XS
+#define DBILOGMSG (dbih_logmsg)
+#else
+#define DBILOGMSG (DBIS->logmsg)
+#endif
+
+
+/* --- perl object (ActiveState) / multiplicity hooks and hoops --- */
+/* note that USE_ITHREADS implies MULTIPLICITY */
+#define DBIS_PUBLISHED_LVALUE (*(INT2PTR(dbistate_t**, &SvIVX(DBISTATE_ADDRSV))))
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
+
+# define DBISTATE_DECLARE typedef int dummy_dbistate /* keep semicolon from feeling lonely */
+# define DBISTATE_INIT_DBIS typedef int dummy_dbistate2; /* keep semicolon from feeling lonely */
+# undef DBIS
+# define DBIS DBIS_PUBLISHED_LVALUE
+# define dbis DBIS_PUBLISHED_LVALUE /* temp for old drivers using 'dbis' instead of 'DBIS' */
+
+#else /* plain and simple non perl object / multiplicity case */
+
+# define DBISTATE_DECLARE static dbistate_t *DBIS
+# define DBISTATE_INIT_DBIS (DBIS = DBIS_PUBLISHED_LVALUE)
+#endif
+
+# define DBISTATE_INIT { /* typically use in BOOT: of XS file */ \
+ DBISTATE_INIT_DBIS; \
+ if (DBIS == NULL) \
+ croak("Unable to get DBI state from %s at %p. DBI not loaded.", DBISTATE_PERLNAME, (void*)DBISTATE_ADDRSV); \
+ DBIS->check_version(__FILE__, DBISTATE_VERSION, sizeof(*DBIS), NEED_DBIXS_VERSION, \
+ sizeof(dbih_drc_t), sizeof(dbih_dbc_t), sizeof(dbih_stc_t), sizeof(dbih_fdc_t) \
+ ); \
+}
+
+
+/* --- Assorted Utility Macros --- */
+
+#define DBD_ATTRIB_OK(attribs) /* is this a usable attrib value */ \
+ (attribs && SvROK(attribs) && SvTYPE(SvRV(attribs))==SVt_PVHV)
+
+/* If attribs value supplied then croak if it's not a hash ref. */
+/* Also map undef to Null. Should always be called to pre-process the */
+/* attribs value. One day we may add some extra magic in here. */
+#define DBD_ATTRIBS_CHECK(func, h, attribs) \
+ if ((attribs) && SvOK(attribs)) { \
+ if (!SvROK(attribs) || SvTYPE(SvRV(attribs))!=SVt_PVHV) \
+ croak("%s->%s(...): attribute parameter '%s' is not a hash ref", \
+ SvPV_nolen(h), func, SvPV_nolen(attribs)); \
+ } else (attribs) = Nullsv
+
+#define DBD_ATTRIB_GET_SVP(attribs, key,klen) \
+ (DBD_ATTRIB_OK(attribs) \
+ ? hv_fetch((HV*)SvRV(attribs), key,klen, 0) \
+ : (SV **)Nullsv)
+
+#define DBD_ATTRIB_GET_IV(attribs, key,klen, svp, var) \
+ if ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \
+ var = SvIV(*svp)
+
+#define DBD_ATTRIB_GET_BOOL(attribs, key,klen, svp, var) \
+ if ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \
+ var = SvTRUE(*svp)
+
+#define DBD_ATTRIB_TRUE(attribs, key,klen, svp) \
+ ( ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \
+ ? SvTRUE(*svp) : 0 )
+
+#define DBD_ATTRIB_GET_PV(attribs, key,klen, svp, dflt) \
+ (((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \
+ ? SvPV_nolen(*svp) : (dflt))
+
+#define DBD_ATTRIB_DELETE(attribs, key, klen) \
+ hv_delete((HV*)SvRV(attribs), key, klen, G_DISCARD)
+
+#endif /* DBIXS_VERSION */
+/* end of DBIXS.h */
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/Driver.xst b/Master/tlpkg/tlperl.straw/lib/auto/DBI/Driver.xst
new file mode 100755
index 00000000000..f4527560925
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/Driver.xst
@@ -0,0 +1,775 @@
+# $Id: Driver.xst 12816 2009-06-08 10:07:26Z timbo $
+# Copyright (c) 1997-2002 Tim Bunce Ireland
+# Copyright (c) 2002 Jonathan Leffler
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+
+#include "Driver_xst.h"
+
+
+MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~
+
+REQUIRE: 1.929
+PROTOTYPES: DISABLE
+
+BOOT:
+ items = 0; /* avoid 'unused variable' warning */
+ DBISTATE_INIT;
+ /* XXX this interface will change: */
+ DBI_IMP_SIZE("DBD::~DRIVER~::dr::imp_data_size", sizeof(imp_drh_t));
+ DBI_IMP_SIZE("DBD::~DRIVER~::db::imp_data_size", sizeof(imp_dbh_t));
+ DBI_IMP_SIZE("DBD::~DRIVER~::st::imp_data_size", sizeof(imp_sth_t));
+ dbd_init(DBIS);
+
+
+# ------------------------------------------------------------
+# driver level interface
+# ------------------------------------------------------------
+MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::dr
+
+
+void
+dbixs_revision(...)
+ PPCODE:
+ ST(0) = sv_2mortal(newSViv(DBIXS_REVISION));
+
+
+#ifdef dbd_discon_all
+
+# disconnect_all renamed and ALIAS'd to avoid length clash on VMS :-(
+void
+discon_all_(drh)
+ SV * drh
+ ALIAS:
+ disconnect_all = 1
+ CODE:
+ D_imp_drh(drh);
+ if (0) ix = ix; /* avoid unused variable warning */
+ ST(0) = dbd_discon_all(drh, imp_drh) ? &sv_yes : &sv_no;
+
+#endif /* dbd_discon_all */
+
+
+#ifdef dbd_dr_data_sources
+
+void
+data_sources(drh, attr = Nullsv)
+ SV *drh
+ SV *attr
+ PPCODE:
+ {
+ D_imp_drh(drh);
+ AV *av = dbd_dr_data_sources(drh, imp_drh, attr);
+ if (av) {
+ int i;
+ int n = AvFILL(av)+1;
+ EXTEND(sp, n);
+ for (i = 0; i < n; ++i) {
+ PUSHs(AvARRAY(av)[i]);
+ }
+ }
+ }
+
+#endif
+
+
+# ------------------------------------------------------------
+# database level interface
+# ------------------------------------------------------------
+MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::db
+
+
+void
+_login(dbh, dbname, username, password, attribs=Nullsv)
+ SV * dbh
+ SV * dbname
+ SV * username
+ SV * password
+ SV * attribs
+ CODE:
+ {
+ STRLEN lna;
+ D_imp_dbh(dbh);
+ char *u = (SvOK(username)) ? SvPV(username,lna) : "";
+ char *p = (SvOK(password)) ? SvPV(password,lna) : "";
+#ifdef dbd_db_login6_sv
+ ST(0) = dbd_db_login6_sv(dbh, imp_dbh, dbname, username, password, attribs) ? &sv_yes : &sv_no;
+#elif defined(dbd_db_login6)
+ ST(0) = dbd_db_login6(dbh, imp_dbh, SvPV_nolen(dbname), u, p, attribs) ? &sv_yes : &sv_no;
+#else
+ ST(0) = dbd_db_login( dbh, imp_dbh, SvPV_nolen(dbname), u, p) ? &sv_yes : &sv_no;
+#endif
+ }
+
+
+void
+selectall_arrayref(...)
+ PREINIT:
+ SV *sth;
+ SV **maxrows_svp;
+ SV **tmp_svp;
+ SV *attr = &PL_sv_undef;
+ imp_sth_t *imp_sth;
+ CODE:
+ if (items > 2) {
+ attr = ST(2);
+ if (SvROK(attr) &&
+ (DBD_ATTRIB_TRUE(attr,"Slice",5,tmp_svp) || DBD_ATTRIB_TRUE(attr,"Columns",7,tmp_svp))
+ ) {
+ /* fallback to perl implementation */
+ SV *tmp =dbixst_bounce_method("DBD::~DRIVER~::db::SUPER::selectall_arrayref", items);
+ SPAGAIN;
+ ST(0) = tmp;
+ XSRETURN(1);
+ }
+ }
+ /* --- prepare --- */
+ if (SvROK(ST(1))) {
+ MAGIC *mg;
+ sth = ST(1);
+ /* switch to inner handle if not already */
+ if ( (mg = mg_find(SvRV(sth),'P')) )
+ sth = mg->mg_obj;
+ }
+ else {
+ sth = dbixst_bounce_method("prepare", 3);
+ SPAGAIN; SP -= items; /* because stack might have been realloc'd */
+ if (!SvROK(sth))
+ XSRETURN_UNDEF;
+ /* switch to inner handle */
+ sth = mg_find(SvRV(sth),'P')->mg_obj;
+ }
+ imp_sth = (imp_sth_t*)(DBIh_COM(sth));
+ /* --- bind_param --- */
+ if (items > 3) { /* need to bind params before execute */
+ if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2) ) {
+ XSRETURN_UNDEF;
+ }
+ }
+ /* --- execute --- */
+ DBIc_ROW_COUNT(imp_sth) = 0;
+ if ( dbd_st_execute(sth, imp_sth) <= -2 ) { /* -2 == error */
+ XSRETURN_UNDEF;
+ }
+ /* --- fetchall --- */
+ maxrows_svp = DBD_ATTRIB_GET_SVP(attr, "MaxRows", 7);
+ ST(0) = dbdxst_fetchall_arrayref(sth, &PL_sv_undef, (maxrows_svp) ? *maxrows_svp : &PL_sv_undef);
+
+
+void
+selectrow_arrayref(...)
+ ALIAS:
+ selectrow_array = 1
+ PREINIT:
+ int is_selectrow_array = (ix == 1);
+ imp_sth_t *imp_sth;
+ SV *sth;
+ AV *row_av;
+ PPCODE:
+ if (SvROK(ST(1))) {
+ MAGIC *mg;
+ sth = ST(1);
+ /* switch to inner handle if not already */
+ if ( (mg = mg_find(SvRV(sth),'P')) )
+ sth = mg->mg_obj;
+ }
+ else {
+ /* --- prepare --- */
+ sth = dbixst_bounce_method("prepare", 3);
+ SPAGAIN; SP -= items; /* because stack might have been realloc'd */
+ if (!SvROK(sth)) {
+ if (is_selectrow_array) { XSRETURN_EMPTY; } else { XSRETURN_UNDEF; }
+ }
+ /* switch to inner handle */
+ sth = mg_find(SvRV(sth),'P')->mg_obj;
+ }
+ imp_sth = (imp_sth_t*)(DBIh_COM(sth));
+ /* --- bind_param --- */
+ if (items > 3) { /* need to bind params before execute */
+ if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2) ) {
+ if (is_selectrow_array) { XSRETURN_EMPTY; } else { XSRETURN_UNDEF; }
+ }
+ }
+ /* --- execute --- */
+ DBIc_ROW_COUNT(imp_sth) = 0;
+ if ( dbd_st_execute(sth, imp_sth) <= -2 ) { /* -2 == error */
+ if (is_selectrow_array) { XSRETURN_EMPTY; } else { XSRETURN_UNDEF; }
+ }
+ /* --- fetchrow_arrayref --- */
+ row_av = dbd_st_fetch(sth, imp_sth);
+ if (!row_av) {
+ if (GIMME == G_SCALAR)
+ PUSHs(&PL_sv_undef);
+ }
+ else if (is_selectrow_array) {
+ int i;
+ int num_fields = AvFILL(row_av)+1;
+ if (GIMME == G_SCALAR)
+ num_fields = 1; /* return just first field */
+ EXTEND(sp, num_fields);
+ for(i=0; i < num_fields; ++i) {
+ PUSHs(AvARRAY(row_av)[i]);
+ }
+ }
+ else {
+ PUSHs( sv_2mortal(newRV((SV *)row_av)) );
+ }
+ /* --- finish --- */
+#ifdef dbd_st_finish3
+ dbd_st_finish3(sth, imp_sth, 0);
+#else
+ dbd_st_finish(sth, imp_sth);
+#endif
+
+
+#ifdef dbd_db_do4 /* deebeedee-deebee-doo, deebee-doobee-dah? */
+
+void
+do(dbh, statement, params = Nullsv)
+ SV * dbh
+ char * statement
+ SV * params
+ CODE:
+ {
+ D_imp_dbh(dbh);
+ IV retval;
+ retval = dbd_db_do4(dbh, imp_dbh, statement, params);
+ /* remember that dbd_db_do4 must return <= -2 for error */
+ if (retval == 0) /* ok with no rows affected */
+ XST_mPV(0, "0E0"); /* (true but zero) */
+ else if (retval < -1) /* -1 == unknown number of rows */
+ XST_mUNDEF(0); /* <= -2 means error */
+ else
+ XST_mIV(0, retval); /* typically 1, rowcount or -1 */
+ }
+
+#endif
+
+
+#ifdef dbd_db_last_insert_id
+
+void
+last_insert_id(dbh, catalog, schema, table, field, attr=Nullsv)
+ SV * dbh
+ SV * catalog
+ SV * schema
+ SV * table
+ SV * field
+ SV * attr
+ CODE:
+ {
+ D_imp_dbh(dbh);
+ ST(0) = dbd_db_last_insert_id(dbh, imp_dbh, catalog, schema, table, field, attr);
+ }
+
+#endif
+
+
+void
+commit(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+ if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh))
+ warn("commit ineffective with AutoCommit enabled");
+ ST(0) = dbd_db_commit(dbh, imp_dbh) ? &sv_yes : &sv_no;
+
+
+void
+rollback(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+ if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh))
+ warn("rollback ineffective with AutoCommit enabled");
+ ST(0) = dbd_db_rollback(dbh, imp_dbh) ? &sv_yes : &sv_no;
+
+
+void
+disconnect(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+ if ( !DBIc_ACTIVE(imp_dbh) ) {
+ XSRETURN_YES;
+ }
+ /* Check for disconnect() being called whilst refs to cursors */
+ /* still exists. This possibly needs some more thought. */
+ if (DBIc_ACTIVE_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !dirty) {
+ STRLEN lna;
+ char *plural = (DBIc_ACTIVE_KIDS(imp_dbh)==1) ? "" : "s";
+ warn("%s->disconnect invalidates %d active statement handle%s %s",
+ SvPV(dbh,lna), (int)DBIc_ACTIVE_KIDS(imp_dbh), plural,
+ "(either destroy statement handles or call finish on them before disconnecting)");
+ }
+ ST(0) = dbd_db_disconnect(dbh, imp_dbh) ? &sv_yes : &sv_no;
+ DBIc_ACTIVE_off(imp_dbh); /* ensure it's off, regardless */
+
+
+void
+STORE(dbh, keysv, valuesv)
+ SV * dbh
+ SV * keysv
+ SV * valuesv
+ CODE:
+ D_imp_dbh(dbh);
+ if (SvGMAGICAL(valuesv))
+ mg_get(valuesv);
+ ST(0) = &sv_yes;
+ if (!dbd_db_STORE_attrib(dbh, imp_dbh, keysv, valuesv))
+ if (!DBIc_DBISTATE(imp_dbh)->set_attr(dbh, keysv, valuesv))
+ ST(0) = &sv_no;
+
+
+void
+FETCH(dbh, keysv)
+ SV * dbh
+ SV * keysv
+ CODE:
+ D_imp_dbh(dbh);
+ SV *valuesv = dbd_db_FETCH_attrib(dbh, imp_dbh, keysv);
+ if (!valuesv)
+ valuesv = DBIc_DBISTATE(imp_dbh)->get_attr(dbh, keysv);
+ ST(0) = valuesv; /* dbd_db_FETCH_attrib did sv_2mortal */
+
+
+void
+DESTROY(dbh)
+ SV * dbh
+ PPCODE:
+ /* keep in sync with default DESTROY in DBI.xs */
+ D_imp_dbh(dbh);
+ ST(0) = &sv_yes;
+ if (!DBIc_IMPSET(imp_dbh)) { /* was never fully set up */
+ STRLEN lna;
+ if (DBIc_WARN(imp_dbh) && !dirty && DBIc_DBISTATE(imp_dbh)->debug >= 2)
+ PerlIO_printf(DBIc_LOGPIO(imp_dbh),
+ " DESTROY for %s ignored - handle not initialised\n",
+ SvPV(dbh,lna));
+ }
+ else {
+ if (DBIc_IADESTROY(imp_dbh)) { /* want's ineffective destroy */
+ DBIc_ACTIVE_off(imp_dbh);
+ if (DBIc_DBISTATE(imp_dbh)->debug)
+ PerlIO_printf(DBIc_LOGPIO(imp_dbh), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(dbh));
+ }
+ if (DBIc_ACTIVE(imp_dbh)) {
+ if (!DBIc_has(imp_dbh,DBIcf_AutoCommit)) {
+ /* Application is using transactions and hasn't explicitly disconnected.
+ Some databases will automatically commit on graceful disconnect.
+ Since we're about to gracefully disconnect as part of the DESTROY
+ we want to be sure we're not about to implicitly commit changes
+ that are incomplete and should be rolled back. (The DESTROY may
+ be due to a RaiseError, for example.) So we rollback here.
+ This will be harmless if the application has issued a commit,
+ XXX Could add an attribute flag to indicate that the driver
+ doesn't have this problem. Patches welcome.
+ */
+ if (DBIc_WARN(imp_dbh)
+ && DBIc_is(imp_dbh, DBIcf_Executed) /* has not just called commit/rollback */
+ && (!dirty || DBIc_DBISTATE(imp_dbh)->debug >= 3)
+ ) {
+ warn("Issuing rollback() due to DESTROY without explicit disconnect() of %s handle %s",
+ SvPV_nolen(*hv_fetch((HV*)SvRV(dbh), "ImplementorClass", 16, 1)),
+ SvPV_nolen(*hv_fetch((HV*)SvRV(dbh), "Name", 4, 1))
+ );
+ }
+ dbd_db_rollback(dbh, imp_dbh); /* ROLLBACK! */
+ }
+ dbd_db_disconnect(dbh, imp_dbh);
+ DBIc_ACTIVE_off(imp_dbh); /* ensure it's off, regardless */
+ }
+ dbd_db_destroy(dbh, imp_dbh);
+ }
+
+
+#ifdef dbd_take_imp_data
+
+void
+take_imp_data(h)
+ SV * h
+ CODE:
+ D_imp_xxh(h);
+ /* dbd_take_imp_data() returns &sv_no (or other defined but false value)
+ * to indicate "preparations complete, now call SUPER::take_imp_data" for me.
+ * Anything else is returned to the caller via sv_2mortal(sv), typically that
+ * would be &sv_undef for error or an SV holding the imp_data.
+ */
+ SV *sv = dbd_take_imp_data(h, imp_xxh, NULL);
+ if (SvOK(sv) && !SvTRUE(sv)) {
+ SV *tmp = dbixst_bounce_method("DBD::~DRIVER~::db::SUPER::take_imp_data", items);
+ SPAGAIN;
+ ST(0) = tmp;
+ } else {
+ ST(0) = sv_2mortal(sv);
+ }
+
+#endif
+
+#ifdef dbd_db_data_sources
+
+void
+data_sources(dbh, attr = Nullsv)
+ SV *dbh
+ SV *attr
+ PPCODE:
+ {
+ D_imp_dbh(dbh);
+ AV *av = dbd_db_data_sources(dbh, imp_dbh, attr);
+ if (av) {
+ int i;
+ int n = AvFILL(av)+1;
+ EXTEND(sp, n);
+ for (i = 0; i < n; ++i) {
+ PUSHs(AvARRAY(av)[i]);
+ }
+ }
+ }
+
+#endif
+
+# -- end of DBD::~DRIVER~::db
+
+# ------------------------------------------------------------
+# statement interface
+# ------------------------------------------------------------
+MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::st
+
+
+void
+_prepare(sth, statement, attribs=Nullsv)
+ SV * sth
+ SV * statement
+ SV * attribs
+ CODE:
+ {
+ D_imp_sth(sth);
+ DBD_ATTRIBS_CHECK("_prepare", sth, attribs);
+#ifdef dbd_st_prepare_sv
+ ST(0) = dbd_st_prepare_sv(sth, imp_sth, statement, attribs) ? &sv_yes : &sv_no;
+#else
+ ST(0) = dbd_st_prepare(sth, imp_sth, SvPV_nolen(statement), attribs) ? &sv_yes : &sv_no;
+#endif
+ }
+
+
+#ifdef dbd_st_rows
+
+void
+rows(sth)
+ SV * sth
+ CODE:
+ D_imp_sth(sth);
+ XST_mIV(0, dbd_st_rows(sth, imp_sth));
+
+#endif /* dbd_st_rows */
+
+
+#ifdef dbd_st_bind_col
+
+void
+bind_col(sth, col, ref, attribs=Nullsv)
+ SV * sth
+ SV * col
+ SV * ref
+ SV * attribs
+ CODE:
+ {
+ IV sql_type = 0;
+ D_imp_sth(sth);
+ if (SvGMAGICAL(ref))
+ mg_get(ref);
+ if (attribs) {
+ if (SvNIOK(attribs)) {
+ sql_type = SvIV(attribs);
+ attribs = Nullsv;
+ }
+ else {
+ SV **svp;
+ DBD_ATTRIBS_CHECK("bind_col", sth, attribs);
+ /* XXX we should perhaps complain if TYPE is not SvNIOK */
+ DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type);
+ }
+ }
+ switch(dbd_st_bind_col(sth, imp_sth, col, ref, sql_type, attribs)) {
+ case 2: ST(0) = &sv_yes; /* job done completely */
+ break;
+ case 1: /* fallback to DBI default */
+ ST(0) = (DBIc_DBISTATE(imp_sth)->bind_col(sth, col, ref, attribs))
+ ? &sv_yes : &sv_no;
+ break;
+ default: ST(0) = &sv_no; /* dbd_st_bind_col has called set_err */
+ break;
+ }
+ }
+
+#endif /* dbd_st_bind_col */
+
+void
+bind_param(sth, param, value, attribs=Nullsv)
+ SV * sth
+ SV * param
+ SV * value
+ SV * attribs
+ CODE:
+ {
+ IV sql_type = 0;
+ D_imp_sth(sth);
+ if (SvGMAGICAL(value))
+ mg_get(value);
+ if (attribs) {
+ if (SvNIOK(attribs)) {
+ sql_type = SvIV(attribs);
+ attribs = Nullsv;
+ }
+ else {
+ SV **svp;
+ DBD_ATTRIBS_CHECK("bind_param", sth, attribs);
+ /* XXX we should perhaps complain if TYPE is not SvNIOK */
+ DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type);
+ }
+ }
+ ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, FALSE, 0)
+ ? &sv_yes : &sv_no;
+ }
+
+
+void
+bind_param_inout(sth, param, value_ref, maxlen, attribs=Nullsv)
+ SV * sth
+ SV * param
+ SV * value_ref
+ IV maxlen
+ SV * attribs
+ CODE:
+ {
+ IV sql_type = 0;
+ D_imp_sth(sth);
+ SV *value;
+ if (!SvROK(value_ref) || SvTYPE(SvRV(value_ref)) > SVt_PVMG)
+ croak("bind_param_inout needs a reference to a scalar value");
+ value = SvRV(value_ref);
+ if (SvREADONLY(value))
+ croak("Modification of a read-only value attempted");
+ if (SvGMAGICAL(value))
+ mg_get(value);
+ if (attribs) {
+ if (SvNIOK(attribs)) {
+ sql_type = SvIV(attribs);
+ attribs = Nullsv;
+ }
+ else {
+ SV **svp;
+ DBD_ATTRIBS_CHECK("bind_param", sth, attribs);
+ DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type);
+ }
+ }
+ ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, TRUE, maxlen)
+ ? &sv_yes : &sv_no;
+ }
+
+
+void
+execute(sth, ...)
+ SV * sth
+ CODE:
+ D_imp_sth(sth);
+ int retval;
+ if (items > 1) { /* need to bind params */
+ if (!dbdxst_bind_params(sth, imp_sth, items, ax) ) {
+ XSRETURN_UNDEF;
+ }
+ }
+ /* XXX this code is duplicated in selectrow_arrayref above */
+ if (DBIc_ROW_COUNT(imp_sth) > 0) /* reset for re-execute */
+ DBIc_ROW_COUNT(imp_sth) = 0;
+ retval = dbd_st_execute(sth, imp_sth);
+ /* remember that dbd_st_execute must return <= -2 for error */
+ if (retval == 0) /* ok with no rows affected */
+ XST_mPV(0, "0E0"); /* (true but zero) */
+ else if (retval < -1) /* -1 == unknown number of rows */
+ XST_mUNDEF(0); /* <= -2 means error */
+ else
+ XST_mIV(0, retval); /* typically 1, rowcount or -1 */
+
+
+#ifdef dbd_st_execute_for_fetch
+
+void
+execute_for_fetch(sth, fetch_tuple_sub, tuple_status = Nullsv)
+ SV * sth
+ SV * fetch_tuple_sub
+ SV * tuple_status
+ CODE:
+ {
+ D_imp_sth(sth);
+ ST(0) = dbd_st_execute_for_fetch(sth, imp_sth, fetch_tuple_sub, tuple_status);
+ }
+
+#endif
+
+
+
+void
+fetchrow_arrayref(sth)
+ SV * sth
+ ALIAS:
+ fetch = 1
+ CODE:
+ D_imp_sth(sth);
+ AV *av;
+ if (0) ix = ix; /* avoid unused variable warning */
+ av = dbd_st_fetch(sth, imp_sth);
+ ST(0) = (av) ? sv_2mortal(newRV((SV *)av)) : &PL_sv_undef;
+
+
+void
+fetchrow_array(sth)
+ SV * sth
+ ALIAS:
+ fetchrow = 1
+ PPCODE:
+ D_imp_sth(sth);
+ AV *av;
+ av = dbd_st_fetch(sth, imp_sth);
+ if (av) {
+ int i;
+ int num_fields = AvFILL(av)+1;
+ EXTEND(sp, num_fields);
+ for(i=0; i < num_fields; ++i) {
+ PUSHs(AvARRAY(av)[i]);
+ }
+ if (0) ix = ix; /* avoid unused variable warning */
+ }
+
+
+void
+fetchall_arrayref(sth, slice=&PL_sv_undef, batch_row_count=&PL_sv_undef)
+ SV * sth
+ SV * slice
+ SV * batch_row_count
+ CODE:
+ if (SvOK(slice)) { /* fallback to perl implementation */
+ SV *tmp = dbixst_bounce_method("DBD::~DRIVER~::st::SUPER::fetchall_arrayref", 3);
+ SPAGAIN;
+ ST(0) = tmp;
+ }
+ else {
+ ST(0) = dbdxst_fetchall_arrayref(sth, slice, batch_row_count);
+ }
+
+
+void
+finish(sth)
+ SV * sth
+ CODE:
+ D_imp_sth(sth);
+ D_imp_dbh_from_sth;
+ if (!DBIc_ACTIVE(imp_sth)) {
+ /* No active statement to finish */
+ XSRETURN_YES;
+ }
+ if (!DBIc_ACTIVE(imp_dbh)) {
+ /* Either an explicit disconnect() or global destruction */
+ /* has disconnected us from the database. Finish is meaningless */
+ DBIc_ACTIVE_off(imp_sth);
+ XSRETURN_YES;
+ }
+#ifdef dbd_st_finish3
+ ST(0) = dbd_st_finish3(sth, imp_sth, 0) ? &sv_yes : &sv_no;
+#else
+ ST(0) = dbd_st_finish(sth, imp_sth) ? &sv_yes : &sv_no;
+#endif
+
+
+void
+blob_read(sth, field, offset, len, destrv=Nullsv, destoffset=0)
+ SV * sth
+ int field
+ long offset
+ long len
+ SV * destrv
+ long destoffset
+ CODE:
+ {
+ D_imp_sth(sth);
+ if (!destrv)
+ destrv = sv_2mortal(newRV(sv_2mortal(newSV(0))));
+ if (dbd_st_blob_read(sth, imp_sth, field, offset, len, destrv, destoffset))
+ ST(0) = SvRV(destrv);
+ else ST(0) = &PL_sv_undef;
+ }
+
+
+void
+STORE(sth, keysv, valuesv)
+ SV * sth
+ SV * keysv
+ SV * valuesv
+ CODE:
+ D_imp_sth(sth);
+ if (SvGMAGICAL(valuesv))
+ mg_get(valuesv);
+ ST(0) = &sv_yes;
+ if (!dbd_st_STORE_attrib(sth, imp_sth, keysv, valuesv))
+ if (!DBIc_DBISTATE(imp_sth)->set_attr(sth, keysv, valuesv))
+ ST(0) = &sv_no;
+
+
+# FETCH renamed and ALIAS'd to avoid case clash on VMS :-(
+void
+FETCH_attrib(sth, keysv)
+ SV * sth
+ SV * keysv
+ ALIAS:
+ FETCH = 1
+ CODE:
+ D_imp_sth(sth);
+ SV *valuesv;
+ if (0) ix = ix; /* avoid unused variable warning */
+ valuesv = dbd_st_FETCH_attrib(sth, imp_sth, keysv);
+ if (!valuesv)
+ valuesv = DBIc_DBISTATE(imp_sth)->get_attr(sth, keysv);
+ ST(0) = valuesv; /* dbd_st_FETCH_attrib did sv_2mortal */
+
+
+void
+DESTROY(sth)
+ SV * sth
+ PPCODE:
+ /* keep in sync with default DESTROY in DBI.xs */
+ D_imp_sth(sth);
+ ST(0) = &sv_yes;
+ if (!DBIc_IMPSET(imp_sth)) { /* was never fully set up */
+ STRLEN lna;
+ if (DBIc_WARN(imp_sth) && !dirty && DBIc_DBISTATE(imp_sth)->debug >= 2)
+ PerlIO_printf(DBIc_LOGPIO(imp_sth),
+ " DESTROY for %s ignored - handle not initialised\n",
+ SvPV(sth,lna));
+ }
+ else {
+ if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */
+ DBIc_ACTIVE_off(imp_sth);
+ if (DBIc_DBISTATE(imp_sth)->debug)
+ PerlIO_printf(DBIc_LOGPIO(imp_sth), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(sth));
+ }
+ if (DBIc_ACTIVE(imp_sth)) {
+ D_imp_dbh_from_sth;
+ if (!dirty && DBIc_ACTIVE(imp_dbh)) {
+#ifdef dbd_st_finish3
+ dbd_st_finish3(sth, imp_sth, 1);
+#else
+ dbd_st_finish(sth, imp_sth);
+#endif
+ }
+ else {
+ DBIc_ACTIVE_off(imp_sth);
+ }
+ }
+ dbd_st_destroy(sth, imp_sth);
+ }
+
+# end of ~DRIVER~.xst
+# vim:ts=8:sw=4:et
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/Driver_xst.h b/Master/tlpkg/tlperl.straw/lib/auto/DBI/Driver_xst.h
new file mode 100755
index 00000000000..d3965f13eac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/Driver_xst.h
@@ -0,0 +1,118 @@
+/*
+# $Id: Driver_xst.h 10378 2007-12-06 10:48:17Z timbo $
+# Copyright (c) 2002 Tim Bunce Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+*/
+
+
+/* This is really just a workaround for SUPER:: not working right for XS code.
+ * It would be better if we setup perl's context so SUPER:: did the right thing
+ * (borrowing the relevant magic from pp_entersub in perl pp_hot.c).
+ * Then we could just use call_method("SUPER::foo") instead.
+ * XXX remember to call SPAGAIN in the calling code after calling this!
+ */
+static SV *
+dbixst_bounce_method(char *methname, int params)
+{
+ dTHX;
+ /* XXX this 'magic' undoes the dMARK embedded in the dXSARGS of our caller */
+ /* so that the dXSARGS below can set things up as they were for our caller */
+ void *xxx = PL_markstack_ptr++;
+ dXSARGS; /* declares sp, ax, mark, items */
+ int i;
+ SV *sv;
+ int debug = 0;
+ D_imp_xxh(ST(0));
+ if (debug >= 3) {
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh),
+ " -> %s (trampoline call with %d (%ld) params)\n", methname, params, (long)items);
+ xxx = xxx; /* avoid unused var warning */
+ }
+ EXTEND(SP, params);
+ PUSHMARK(SP);
+ for (i=0; i < params; ++i) {
+ sv = (i >= items) ? &sv_undef : ST(i);
+ PUSHs(sv);
+ }
+ PUTBACK;
+ i = perl_call_method(methname, G_SCALAR);
+ SPAGAIN;
+ sv = (i) ? POPs : &sv_undef;
+ PUTBACK;
+ if (debug >= 3)
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh),
+ " <- %s= %s (trampoline call return)\n", methname, neatsvpv(sv,0));
+ return sv;
+}
+
+
+static int
+dbdxst_bind_params(SV *sth, imp_sth_t *imp_sth, I32 items, I32 ax)
+{
+ /* Handle binding supplied values to placeholders. */
+ /* items = one greater than the number of params */
+ /* ax = ax from calling sub, maybe adjusted to match items */
+ dTHX;
+ int i;
+ SV *idx;
+ if (items-1 != DBIc_NUM_PARAMS(imp_sth)
+ && DBIc_NUM_PARAMS(imp_sth) != DBIc_NUM_PARAMS_AT_EXECUTE
+ ) {
+ char errmsg[99];
+ sprintf(errmsg,"called with %d bind variables when %d are needed",
+ (int)items-1, DBIc_NUM_PARAMS(imp_sth));
+ sv_setpv(DBIc_ERRSTR(imp_sth), errmsg);
+ sv_setiv(DBIc_ERR(imp_sth), (IV)-1);
+ return 0;
+ }
+ idx = sv_2mortal(newSViv(0));
+ for(i=1; i < items ; ++i) {
+ SV* value = ST(i);
+ if (SvGMAGICAL(value))
+ mg_get(value); /* trigger magic to FETCH the value */
+ sv_setiv(idx, i);
+ if (!dbd_bind_ph(sth, imp_sth, idx, value, 0, Nullsv, FALSE, 0)) {
+ return 0; /* dbd_bind_ph already registered error */
+ }
+ }
+ return 1;
+}
+
+#ifndef dbd_fetchall_arrayref
+static SV *
+dbdxst_fetchall_arrayref(SV *sth, SV *slice, SV *batch_row_count)
+{
+ dTHX;
+ D_imp_sth(sth);
+ SV *rows_rvav;
+ if (SvOK(slice)) { /* should never get here */
+ char errmsg[99];
+ sprintf(errmsg,"slice param not supported by XS version of fetchall_arrayref");
+ sv_setpv(DBIc_ERRSTR(imp_sth), errmsg);
+ sv_setiv(DBIc_ERR(imp_sth), (IV)-1);
+ return &sv_undef;
+ }
+ else {
+ IV maxrows = SvOK(batch_row_count) ? SvIV(batch_row_count) : -1;
+ AV *fetched_av;
+ AV *rows_av = newAV();
+ if ( !DBIc_ACTIVE(imp_sth) && maxrows>0 ) {
+ /* to simplify application logic we return undef without an error */
+ /* if we've fetched all the rows and called with a batch_row_count */
+ return &sv_undef;
+ }
+ av_extend(rows_av, (maxrows>0) ? maxrows : 31);
+ while ( (maxrows < 0 || maxrows-- > 0)
+ && (fetched_av = dbd_st_fetch(sth, imp_sth))
+ ) {
+ AV *copy_row_av = av_make(AvFILL(fetched_av)+1, AvARRAY(fetched_av));
+ av_push(rows_av, newRV_noinc((SV*)copy_row_av));
+ }
+ rows_rvav = sv_2mortal(newRV_noinc((SV *)rows_av));
+ }
+ return rows_rvav;
+}
+#endif
+
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbd_xsh.h b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbd_xsh.h
new file mode 100755
index 00000000000..f238bb5e2f6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbd_xsh.h
@@ -0,0 +1,58 @@
+/* @(#)$Id: dbd_xsh.h 11724 2008-09-02 13:34:31Z mjevans $
+ *
+ * Copyright 2000-2002 Tim Bunce
+ * Copyright 2002 Jonathan Leffler
+ *
+ * These prototypes are for dbdimp.c funcs used in the XS file.
+ * These names are #defined to driver specific names by the
+ * dbdimp.h file in the driver source.
+ */
+
+#ifndef DBI_DBD_XSH_H
+#define DBI_DBD_XSH_H
+
+void dbd_init _((dbistate_t *dbistate));
+
+int dbd_discon_all _((SV *drh, imp_drh_t *imp_drh));
+SV *dbd_take_imp_data _((SV *h, imp_xxh_t *imp_xxh, void *foo));
+
+/* Support for dbd_dr_data_sources and dbd_db_do added to Driver.xst in DBI v1.33 */
+/* dbd_dr_data_sources: optional: defined by a driver that calls a C */
+/* function to get the list of data sources */
+AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attrs);
+
+int dbd_db_login6_sv _((SV *dbh, imp_dbh_t *imp_dbh, SV *dbname, SV *uid, SV *pwd, SV*attribs));
+int dbd_db_login6 _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd, SV*attribs));
+int dbd_db_login _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd)); /* deprecated */
+/* Note: interface of dbd_db_do changed in v1.33 */
+/* Old prototype: dbd_db_do _((SV *sv, char *statement)); */
+/* dbd_db_do: optional: defined by a driver if the DBI default version is too slow */
+int dbd_db_do4 _((SV *dbh, imp_dbh_t *imp_dbh, char *statement, SV *params));
+int dbd_db_commit _((SV *dbh, imp_dbh_t *imp_dbh));
+int dbd_db_rollback _((SV *dbh, imp_dbh_t *imp_dbh));
+int dbd_db_disconnect _((SV *dbh, imp_dbh_t *imp_dbh));
+void dbd_db_destroy _((SV *dbh, imp_dbh_t *imp_dbh));
+int dbd_db_STORE_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv));
+SV *dbd_db_FETCH_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv));
+SV *dbd_db_last_insert_id _((SV *dbh, imp_dbh_t *imp_dbh, SV *catalog, SV *schema, SV *table, SV *field, SV *attr));
+AV *dbd_db_data_sources _((SV *dbh, imp_dbh_t *imp_dbh, SV *attr));
+
+int dbd_st_prepare _((SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs));
+int dbd_st_prepare_sv _((SV *sth, imp_sth_t *imp_sth, SV *statement, SV *attribs));
+int dbd_st_rows _((SV *sth, imp_sth_t *imp_sth));
+int dbd_st_execute _((SV *sth, imp_sth_t *imp_sth));
+AV *dbd_st_fetch _((SV *sth, imp_sth_t *imp_sth));
+int dbd_st_finish3 _((SV *sth, imp_sth_t *imp_sth, int from_destroy));
+int dbd_st_finish _((SV *sth, imp_sth_t *imp_sth)); /* deprecated */
+void dbd_st_destroy _((SV *sth, imp_sth_t *imp_sth));
+int dbd_st_blob_read _((SV *sth, imp_sth_t *imp_sth,
+ int field, long offset, long len, SV *destrv, long destoffset));
+int dbd_st_STORE_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv));
+SV *dbd_st_FETCH_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv));
+SV *dbd_st_execute_for_fetch _((SV *sth, imp_sth_t *imp_sth, SV *fetch_tuple_sub, SV *tuple_status));
+
+int dbd_bind_ph _((SV *sth, imp_sth_t *imp_sth,
+ SV *param, SV *value, IV sql_type, SV *attribs,
+ int is_inout, IV maxlen));
+
+#endif /* end of dbd_xsh.h */
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbi_sql.h b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbi_sql.h
new file mode 100755
index 00000000000..1d7869d467a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbi_sql.h
@@ -0,0 +1,96 @@
+/* $Id: dbi_sql.h 2488 2006-02-07 22:24:43Z timbo $
+ *
+ * Copyright (c) 1997,1998,1999 Tim Bunce England
+ *
+ * See COPYRIGHT section in DBI.pm for usage and distribution rights.
+ */
+
+
+/* Some core SQL CLI standard (ODBC) declarations */
+#ifndef SQL_SUCCESS /* don't clash with ODBC based drivers */
+
+/* SQL datatype codes */
+#define SQL_GUID (-11)
+#define SQL_WLONGVARCHAR (-10)
+#define SQL_WVARCHAR (-9)
+#define SQL_WCHAR (-8)
+#define SQL_BIT (-7)
+#define SQL_TINYINT (-6)
+#define SQL_BIGINT (-5)
+#define SQL_LONGVARBINARY (-4)
+#define SQL_VARBINARY (-3)
+#define SQL_BINARY (-2)
+#define SQL_LONGVARCHAR (-1)
+#define SQL_UNKNOWN_TYPE 0
+#define SQL_ALL_TYPES 0
+#define SQL_CHAR 1
+#define SQL_NUMERIC 2
+#define SQL_DECIMAL 3
+#define SQL_INTEGER 4
+#define SQL_SMALLINT 5
+#define SQL_FLOAT 6
+#define SQL_REAL 7
+#define SQL_DOUBLE 8
+#define SQL_DATETIME 9
+#define SQL_DATE 9
+#define SQL_INTERVAL 10
+#define SQL_TIME 10
+#define SQL_TIMESTAMP 11
+#define SQL_VARCHAR 12
+#define SQL_BOOLEAN 16
+#define SQL_UDT 17
+#define SQL_UDT_LOCATOR 18
+#define SQL_ROW 19
+#define SQL_REF 20
+#define SQL_BLOB 30
+#define SQL_BLOB_LOCATOR 31
+#define SQL_CLOB 40
+#define SQL_CLOB_LOCATOR 41
+#define SQL_ARRAY 50
+#define SQL_ARRAY_LOCATOR 51
+#define SQL_MULTISET 55
+#define SQL_MULTISET_LOCATOR 56
+#define SQL_TYPE_DATE 91
+#define SQL_TYPE_TIME 92
+#define SQL_TYPE_TIMESTAMP 93
+#define SQL_TYPE_TIME_WITH_TIMEZONE 94
+#define SQL_TYPE_TIMESTAMP_WITH_TIMEZONE 95
+#define SQL_INTERVAL_YEAR 101
+#define SQL_INTERVAL_MONTH 102
+#define SQL_INTERVAL_DAY 103
+#define SQL_INTERVAL_HOUR 104
+#define SQL_INTERVAL_MINUTE 105
+#define SQL_INTERVAL_SECOND 106
+#define SQL_INTERVAL_YEAR_TO_MONTH 107
+#define SQL_INTERVAL_DAY_TO_HOUR 108
+#define SQL_INTERVAL_DAY_TO_MINUTE 109
+#define SQL_INTERVAL_DAY_TO_SECOND 110
+#define SQL_INTERVAL_HOUR_TO_MINUTE 111
+#define SQL_INTERVAL_HOUR_TO_SECOND 112
+#define SQL_INTERVAL_MINUTE_TO_SECOND 113
+
+
+/* Main return codes */
+#define SQL_ERROR (-1)
+#define SQL_SUCCESS 0
+#define SQL_SUCCESS_WITH_INFO 1
+#define SQL_NO_DATA_FOUND 100
+
+/*
+ * for ODBC SQL Cursor Types
+ */
+#define SQL_CURSOR_FORWARD_ONLY 0UL
+#define SQL_CURSOR_KEYSET_DRIVEN 1UL
+#define SQL_CURSOR_DYNAMIC 2UL
+#define SQL_CURSOR_STATIC 3UL
+#define SQL_CURSOR_TYPE_DEFAULT SQL_CURSOR_FORWARD_ONLY
+
+#endif /* SQL_SUCCESS */
+
+/* Handy macro for testing for success and success with info. */
+/* BEWARE that this macro can have side effects since rc appears twice! */
+/* So DONT use it as if(SQL_ok(func(...))) { ... } */
+#define SQL_ok(rc) ((rc)==SQL_SUCCESS || (rc)==SQL_SUCCESS_WITH_INFO)
+
+
+/* end of dbi_sql.h */
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbipport.h b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbipport.h
new file mode 100755
index 00000000000..8a9c47c0aed
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbipport.h
@@ -0,0 +1,4954 @@
+#if 0
+<<'SKIP';
+#endif
+/*
+----------------------------------------------------------------------
+
+ ppport.h -- Perl/Pollution/Portability Version 3.06_01
+
+ Automatically created by Devel::PPPort running under
+ perl 5.008008 on Wed Apr 26 01:39:44 2006.
+
+ Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
+ includes in parts/inc/ instead.
+
+ Use 'perldoc ppport.h' to view the documentation below.
+
+----------------------------------------------------------------------
+
+SKIP
+
+=pod
+
+=head1 NAME
+
+ppport.h - Perl/Pollution/Portability version 3.06_01
+
+=head1 SYNOPSIS
+
+ perl ppport.h [options] [source files]
+
+ Searches current directory for files if no [source files] are given
+
+ --help show short help
+
+ --patch=file write one patch file with changes
+ --copy=suffix write changed copies with suffix
+ --diff=program use diff program and options
+
+ --compat-version=version provide compatibility with Perl version
+ --cplusplus accept C++ comments
+
+ --quiet don't output anything except fatal errors
+ --nodiag don't show diagnostics
+ --nohints don't show hints
+ --nochanges don't suggest changes
+ --nofilter don't filter input files
+
+ --list-provided list provided API
+ --list-unsupported list unsupported API
+ --api-info=name show Perl API portability information
+
+=head1 COMPATIBILITY
+
+This version of F<ppport.h> is designed to support operation with Perl
+installations back to 5.003, and has been tested up to 5.9.3.
+
+=head1 OPTIONS
+
+=head2 --help
+
+Display a brief usage summary.
+
+=head2 --patch=I<file>
+
+If this option is given, a single patch file will be created if
+any changes are suggested. This requires a working diff program
+to be installed on your system.
+
+=head2 --copy=I<suffix>
+
+If this option is given, a copy of each file will be saved with
+the given suffix that contains the suggested changes. This does
+not require any external programs.
+
+If neither C<--patch> or C<--copy> are given, the default is to
+simply print the diffs for each file. This requires either
+C<Text::Diff> or a C<diff> program to be installed.
+
+=head2 --diff=I<program>
+
+Manually set the diff program and options to use. The default
+is to use C<Text::Diff>, when installed, and output unified
+context diffs.
+
+=head2 --compat-version=I<version>
+
+Tell F<ppport.h> to check for compatibility with the given
+Perl version. The default is to check for compatibility with Perl
+version 5.003. You can use this option to reduce the output
+of F<ppport.h> if you intend to be backward compatible only
+up to a certain Perl version.
+
+=head2 --cplusplus
+
+Usually, F<ppport.h> will detect C++ style comments and
+replace them with C style comments for portability reasons.
+Using this option instructs F<ppport.h> to leave C++
+comments untouched.
+
+=head2 --quiet
+
+Be quiet. Don't print anything except fatal errors.
+
+=head2 --nodiag
+
+Don't output any diagnostic messages. Only portability
+alerts will be printed.
+
+=head2 --nohints
+
+Don't output any hints. Hints often contain useful portability
+notes.
+
+=head2 --nochanges
+
+Don't suggest any changes. Only give diagnostic output and hints
+unless these are also deactivated.
+
+=head2 --nofilter
+
+Don't filter the list of input files. By default, files not looking
+like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
+
+=head2 --list-provided
+
+Lists the API elements for which compatibility is provided by
+F<ppport.h>. Also lists if it must be explicitly requested,
+if it has dependencies, and if there are hints for it.
+
+=head2 --list-unsupported
+
+Lists the API elements that are known not to be supported by
+F<ppport.h> and below which version of Perl they probably
+won't be available or work.
+
+=head2 --api-info=I<name>
+
+Show portability information for API elements matching I<name>.
+If I<name> is surrounded by slashes, it is interpreted as a regular
+expression.
+
+=head1 DESCRIPTION
+
+In order for a Perl extension (XS) module to be as portable as possible
+across differing versions of Perl itself, certain steps need to be taken.
+
+=over 4
+
+=item *
+
+Including this header is the first major one. This alone will give you
+access to a large part of the Perl API that hasn't been available in
+earlier Perl releases. Use
+
+ perl ppport.h --list-provided
+
+to see which API elements are provided by ppport.h.
+
+=item *
+
+You should avoid using deprecated parts of the API. For example, using
+global Perl variables without the C<PL_> prefix is deprecated. Also,
+some API functions used to have a C<perl_> prefix. Using this form is
+also deprecated. You can safely use the supported API, as F<ppport.h>
+will provide wrappers for older Perl versions.
+
+=item *
+
+If you use one of a few functions that were not present in earlier
+versions of Perl, and that can't be provided using a macro, you have
+to explicitly request support for these functions by adding one or
+more C<#define>s in your source code before the inclusion of F<ppport.h>.
+
+These functions will be marked C<explicit> in the list shown by
+C<--list-provided>.
+
+Depending on whether you module has a single or multiple files that
+use such functions, you want either C<static> or global variants.
+
+For a C<static> function, use:
+
+ #define NEED_function
+
+For a global function, use:
+
+ #define NEED_function_GLOBAL
+
+Note that you mustn't have more than one global request for one
+function in your project.
+
+ Function Static Request Global Request
+ -----------------------------------------------------------------------------------------
+ eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
+ grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
+ grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
+ grok_number() NEED_grok_number NEED_grok_number_GLOBAL
+ grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
+ grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
+ newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+ newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
+ sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
+ sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
+ sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
+ sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
+ sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
+ sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
+ vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
+
+To avoid namespace conflicts, you can change the namespace of the
+explicitly exported functions using the C<DPPP_NAMESPACE> macro.
+Just C<#define> the macro before including C<ppport.h>:
+
+ #define DPPP_NAMESPACE MyOwnNamespace_
+ #include "ppport.h"
+
+The default namespace is C<DPPP_>.
+
+=back
+
+The good thing is that most of the above can be checked by running
+F<ppport.h> on your source code. See the next section for
+details.
+
+=head1 EXAMPLES
+
+To verify whether F<ppport.h> is needed for your module, whether you
+should make any changes to your code, and whether any special defines
+should be used, F<ppport.h> can be run as a Perl script to check your
+source code. Simply say:
+
+ perl ppport.h
+
+The result will usually be a list of patches suggesting changes
+that should at least be acceptable, if not necessarily the most
+efficient solution, or a fix for all possible problems.
+
+If you know that your XS module uses features only available in
+newer Perl releases, if you're aware that it uses C++ comments,
+and if you want all suggestions as a single patch file, you could
+use something like this:
+
+ perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
+
+If you only want your code to be scanned without any suggestions
+for changes, use:
+
+ perl ppport.h --nochanges
+
+You can specify a different C<diff> program or options, using
+the C<--diff> option:
+
+ perl ppport.h --diff='diff -C 10'
+
+This would output context diffs with 10 lines of context.
+
+To display portability information for the C<newSVpvn> function,
+use:
+
+ perl ppport.h --api-info=newSVpvn
+
+Since the argument to C<--api-info> can be a regular expression,
+you can use
+
+ perl ppport.h --api-info=/_nomg$/
+
+to display portability information for all C<_nomg> functions or
+
+ perl ppport.h --api-info=/./
+
+to display information for all known API elements.
+
+=head1 BUGS
+
+If this version of F<ppport.h> is causing failure during
+the compilation of this module, please check if newer versions
+of either this module or C<Devel::PPPort> are available on CPAN
+before sending a bug report.
+
+If F<ppport.h> was generated using the latest version of
+C<Devel::PPPort> and is causing failure of this module, please
+file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
+
+Please include the following information:
+
+=over 4
+
+=item 1.
+
+The complete output from running "perl -V"
+
+=item 2.
+
+This file.
+
+=item 3.
+
+The name and version of the module you were trying to build.
+
+=item 4.
+
+A full log of the build that failed.
+
+=item 5.
+
+Any other information that you think could be relevant.
+
+=back
+
+For the latest version of this code, please get the C<Devel::PPPort>
+module from CPAN.
+
+=head1 COPYRIGHT
+
+Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz.
+
+Version 2.x, Copyright (C) 2001, Paul Marquess.
+
+Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+See L<Devel::PPPort>.
+
+=cut
+
+use strict;
+
+my %opt = (
+ quiet => 0,
+ diag => 1,
+ hints => 1,
+ changes => 1,
+ cplusplus => 0,
+ filter => 1,
+);
+
+my($ppport) = $0 =~ /([\w.]+)$/;
+my $LF = '(?:\r\n|[\r\n])'; # line feed
+my $HS = "[ \t]"; # horizontal whitespace
+
+eval {
+ require Getopt::Long;
+ Getopt::Long::GetOptions(\%opt, qw(
+ help quiet diag! filter! hints! changes! cplusplus
+ patch=s copy=s diff=s compat-version=s
+ list-provided list-unsupported api-info=s
+ )) or usage();
+};
+
+if ($@ and grep /^-/, @ARGV) {
+ usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
+ die "Getopt::Long not found. Please don't use any options.\n";
+}
+
+usage() if $opt{help};
+
+if (exists $opt{'compat-version'}) {
+ my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
+ if ($@) {
+ die "Invalid version number format: '$opt{'compat-version'}'\n";
+ }
+ die "Only Perl 5 is supported\n" if $r != 5;
+ die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
+ $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
+}
+else {
+ $opt{'compat-version'} = 5;
+}
+
+# Never use C comments in this file!!!!!
+my $ccs = '/'.'*';
+my $cce = '*'.'/';
+my $rccs = quotemeta $ccs;
+my $rcce = quotemeta $cce;
+
+my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
+ ? ( $1 => {
+ ($2 ? ( base => $2 ) : ()),
+ ($3 ? ( todo => $3 ) : ()),
+ (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
+ (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
+ (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
+ } )
+ : die "invalid spec: $_" } qw(
+AvFILLp|5.004050||p
+AvFILL|||
+CLASS|||n
+CX_CURPAD_SAVE|||
+CX_CURPAD_SV|||
+CopFILEAV|5.006000||p
+CopFILEGV_set|5.006000||p
+CopFILEGV|5.006000||p
+CopFILESV|5.006000||p
+CopFILE_set|5.006000||p
+CopFILE|5.006000||p
+CopSTASHPV_set|5.006000||p
+CopSTASHPV|5.006000||p
+CopSTASH_eq|5.006000||p
+CopSTASH_set|5.006000||p
+CopSTASH|5.006000||p
+CopyD|5.009002||p
+Copy|||
+CvPADLIST|||
+CvSTASH|||
+CvWEAKOUTSIDE|||
+DEFSV|5.004050||p
+END_EXTERN_C|5.005000||p
+ENTER|||
+ERRSV|5.004050||p
+EXTEND|||
+EXTERN_C|5.005000||p
+FREETMPS|||
+GIMME_V||5.004000|n
+GIMME|||n
+GROK_NUMERIC_RADIX|5.007002||p
+G_ARRAY|||
+G_DISCARD|||
+G_EVAL|||
+G_NOARGS|||
+G_SCALAR|||
+G_VOID||5.004000|
+GetVars|||
+GvSV|||
+Gv_AMupdate|||
+HEf_SVKEY||5.004000|
+HeHASH||5.004000|
+HeKEY||5.004000|
+HeKLEN||5.004000|
+HePV||5.004000|
+HeSVKEY_force||5.004000|
+HeSVKEY_set||5.004000|
+HeSVKEY||5.004000|
+HeVAL||5.004000|
+HvNAME|||
+INT2PTR|5.006000||p
+IN_LOCALE_COMPILETIME|5.007002||p
+IN_LOCALE_RUNTIME|5.007002||p
+IN_LOCALE|5.007002||p
+IN_PERL_COMPILETIME|5.008001||p
+IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
+IS_NUMBER_INFINITY|5.007002||p
+IS_NUMBER_IN_UV|5.007002||p
+IS_NUMBER_NAN|5.007003||p
+IS_NUMBER_NEG|5.007002||p
+IS_NUMBER_NOT_INT|5.007002||p
+IVSIZE|5.006000||p
+IVTYPE|5.006000||p
+IVdf|5.006000||p
+LEAVE|||
+LVRET|||
+MARK|||
+MY_CXT_CLONE|5.009002||p
+MY_CXT_INIT|5.007003||p
+MY_CXT|5.007003||p
+MoveD|5.009002||p
+Move|||
+NEWSV|||
+NOOP|5.005000||p
+NUM2PTR|5.006000||p
+NVTYPE|5.006000||p
+NVef|5.006001||p
+NVff|5.006001||p
+NVgf|5.006001||p
+Newc|||
+Newz|||
+New|||
+Nullav|||
+Nullch|||
+Nullcv|||
+Nullhv|||
+Nullsv|||
+ORIGMARK|||
+PAD_BASE_SV|||
+PAD_CLONE_VARS|||
+PAD_COMPNAME_FLAGS|||
+PAD_COMPNAME_GEN_set|||
+PAD_COMPNAME_GEN|||
+PAD_COMPNAME_OURSTASH|||
+PAD_COMPNAME_PV|||
+PAD_COMPNAME_TYPE|||
+PAD_RESTORE_LOCAL|||
+PAD_SAVE_LOCAL|||
+PAD_SAVE_SETNULLPAD|||
+PAD_SETSV|||
+PAD_SET_CUR_NOSAVE|||
+PAD_SET_CUR|||
+PAD_SVl|||
+PAD_SV|||
+PERL_BCDVERSION|5.009003||p
+PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
+PERL_INT_MAX|5.004000||p
+PERL_INT_MIN|5.004000||p
+PERL_LONG_MAX|5.004000||p
+PERL_LONG_MIN|5.004000||p
+PERL_MAGIC_arylen|5.007002||p
+PERL_MAGIC_backref|5.007002||p
+PERL_MAGIC_bm|5.007002||p
+PERL_MAGIC_collxfrm|5.007002||p
+PERL_MAGIC_dbfile|5.007002||p
+PERL_MAGIC_dbline|5.007002||p
+PERL_MAGIC_defelem|5.007002||p
+PERL_MAGIC_envelem|5.007002||p
+PERL_MAGIC_env|5.007002||p
+PERL_MAGIC_ext|5.007002||p
+PERL_MAGIC_fm|5.007002||p
+PERL_MAGIC_glob|5.007002||p
+PERL_MAGIC_isaelem|5.007002||p
+PERL_MAGIC_isa|5.007002||p
+PERL_MAGIC_mutex|5.007002||p
+PERL_MAGIC_nkeys|5.007002||p
+PERL_MAGIC_overload_elem|5.007002||p
+PERL_MAGIC_overload_table|5.007002||p
+PERL_MAGIC_overload|5.007002||p
+PERL_MAGIC_pos|5.007002||p
+PERL_MAGIC_qr|5.007002||p
+PERL_MAGIC_regdata|5.007002||p
+PERL_MAGIC_regdatum|5.007002||p
+PERL_MAGIC_regex_global|5.007002||p
+PERL_MAGIC_shared_scalar|5.007003||p
+PERL_MAGIC_shared|5.007003||p
+PERL_MAGIC_sigelem|5.007002||p
+PERL_MAGIC_sig|5.007002||p
+PERL_MAGIC_substr|5.007002||p
+PERL_MAGIC_sv|5.007002||p
+PERL_MAGIC_taint|5.007002||p
+PERL_MAGIC_tiedelem|5.007002||p
+PERL_MAGIC_tiedscalar|5.007002||p
+PERL_MAGIC_tied|5.007002||p
+PERL_MAGIC_utf8|5.008001||p
+PERL_MAGIC_uvar_elem|5.007003||p
+PERL_MAGIC_uvar|5.007002||p
+PERL_MAGIC_vec|5.007002||p
+PERL_MAGIC_vstring|5.008001||p
+PERL_QUAD_MAX|5.004000||p
+PERL_QUAD_MIN|5.004000||p
+PERL_REVISION|5.006000||p
+PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
+PERL_SCAN_DISALLOW_PREFIX|5.007003||p
+PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
+PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
+PERL_SHORT_MAX|5.004000||p
+PERL_SHORT_MIN|5.004000||p
+PERL_SUBVERSION|5.006000||p
+PERL_UCHAR_MAX|5.004000||p
+PERL_UCHAR_MIN|5.004000||p
+PERL_UINT_MAX|5.004000||p
+PERL_UINT_MIN|5.004000||p
+PERL_ULONG_MAX|5.004000||p
+PERL_ULONG_MIN|5.004000||p
+PERL_UNUSED_DECL|5.007002||p
+PERL_UQUAD_MAX|5.004000||p
+PERL_UQUAD_MIN|5.004000||p
+PERL_USHORT_MAX|5.004000||p
+PERL_USHORT_MIN|5.004000||p
+PERL_VERSION|5.006000||p
+PL_DBsingle|||pn
+PL_DBsub|||pn
+PL_DBtrace|||n
+PL_Sv|5.005000||p
+PL_compiling|5.004050||p
+PL_copline|5.005000||p
+PL_curcop|5.004050||p
+PL_curstash|5.004050||p
+PL_debstash|5.004050||p
+PL_defgv|5.004050||p
+PL_diehook|5.004050||p
+PL_dirty|5.004050||p
+PL_dowarn|||pn
+PL_errgv|5.004050||p
+PL_hexdigit|5.005000||p
+PL_hints|5.005000||p
+PL_last_in_gv|||n
+PL_modglobal||5.005000|n
+PL_na|5.004050||pn
+PL_no_modify|5.006000||p
+PL_ofs_sv|||n
+PL_perl_destruct_level|5.004050||p
+PL_perldb|5.004050||p
+PL_ppaddr|5.006000||p
+PL_rsfp_filters|5.004050||p
+PL_rsfp|5.004050||p
+PL_rs|||n
+PL_stack_base|5.004050||p
+PL_stack_sp|5.004050||p
+PL_stdingv|5.004050||p
+PL_sv_arenaroot|5.004050||p
+PL_sv_no|5.004050||pn
+PL_sv_undef|5.004050||pn
+PL_sv_yes|5.004050||pn
+PL_tainted|5.004050||p
+PL_tainting|5.004050||p
+POPi|||n
+POPl|||n
+POPn|||n
+POPpbytex||5.007001|n
+POPpx||5.005030|n
+POPp|||n
+POPs|||n
+PTR2IV|5.006000||p
+PTR2NV|5.006000||p
+PTR2UV|5.006000||p
+PTR2ul|5.007001||p
+PTRV|5.006000||p
+PUSHMARK|||
+PUSHi|||
+PUSHmortal|5.009002||p
+PUSHn|||
+PUSHp|||
+PUSHs|||
+PUSHu|5.004000||p
+PUTBACK|||
+PerlIO_clearerr||5.007003|
+PerlIO_close||5.007003|
+PerlIO_eof||5.007003|
+PerlIO_error||5.007003|
+PerlIO_fileno||5.007003|
+PerlIO_fill||5.007003|
+PerlIO_flush||5.007003|
+PerlIO_get_base||5.007003|
+PerlIO_get_bufsiz||5.007003|
+PerlIO_get_cnt||5.007003|
+PerlIO_get_ptr||5.007003|
+PerlIO_read||5.007003|
+PerlIO_seek||5.007003|
+PerlIO_set_cnt||5.007003|
+PerlIO_set_ptrcnt||5.007003|
+PerlIO_setlinebuf||5.007003|
+PerlIO_stderr||5.007003|
+PerlIO_stdin||5.007003|
+PerlIO_stdout||5.007003|
+PerlIO_tell||5.007003|
+PerlIO_unread||5.007003|
+PerlIO_write||5.007003|
+Poison|5.008000||p
+RETVAL|||n
+Renewc|||
+Renew|||
+SAVECLEARSV|||
+SAVECOMPPAD|||
+SAVEPADSV|||
+SAVETMPS|||
+SAVE_DEFSV|5.004050||p
+SPAGAIN|||
+SP|||
+START_EXTERN_C|5.005000||p
+START_MY_CXT|5.007003||p
+STMT_END|||p
+STMT_START|||p
+ST|||
+SVt_IV|||
+SVt_NV|||
+SVt_PVAV|||
+SVt_PVCV|||
+SVt_PVHV|||
+SVt_PVMG|||
+SVt_PV|||
+Safefree|||
+Slab_Alloc|||
+Slab_Free|||
+StructCopy|||
+SvCUR_set|||
+SvCUR|||
+SvEND|||
+SvGETMAGIC|5.004050||p
+SvGROW|||
+SvIOK_UV||5.006000|
+SvIOK_notUV||5.006000|
+SvIOK_off|||
+SvIOK_only_UV||5.006000|
+SvIOK_only|||
+SvIOK_on|||
+SvIOKp|||
+SvIOK|||
+SvIVX|||
+SvIV_nomg|5.009001||p
+SvIV_set|||
+SvIVx|||
+SvIV|||
+SvIsCOW_shared_hash||5.008003|
+SvIsCOW||5.008003|
+SvLEN_set|||
+SvLEN|||
+SvLOCK||5.007003|
+SvMAGIC_set||5.009003|
+SvNIOK_off|||
+SvNIOKp|||
+SvNIOK|||
+SvNOK_off|||
+SvNOK_only|||
+SvNOK_on|||
+SvNOKp|||
+SvNOK|||
+SvNVX|||
+SvNV_set|||
+SvNVx|||
+SvNV|||
+SvOK|||
+SvOOK|||
+SvPOK_off|||
+SvPOK_only_UTF8||5.006000|
+SvPOK_only|||
+SvPOK_on|||
+SvPOKp|||
+SvPOK|||
+SvPVX|||
+SvPV_force_nomg|5.007002||p
+SvPV_force|||
+SvPV_nolen|5.006000||p
+SvPV_nomg|5.007002||p
+SvPV_set|||
+SvPVbyte_force||5.009002|
+SvPVbyte_nolen||5.006000|
+SvPVbytex_force||5.006000|
+SvPVbytex||5.006000|
+SvPVbyte|5.006000||p
+SvPVutf8_force||5.006000|
+SvPVutf8_nolen||5.006000|
+SvPVutf8x_force||5.006000|
+SvPVutf8x||5.006000|
+SvPVutf8||5.006000|
+SvPVx|||
+SvPV|||
+SvREFCNT_dec|||
+SvREFCNT_inc|||
+SvREFCNT|||
+SvROK_off|||
+SvROK_on|||
+SvROK|||
+SvRV_set||5.009003|
+SvRV|||
+SvSETMAGIC|||
+SvSHARE||5.007003|
+SvSTASH_set||5.009003|
+SvSTASH|||
+SvSetMagicSV_nosteal||5.004000|
+SvSetMagicSV||5.004000|
+SvSetSV_nosteal||5.004000|
+SvSetSV|||
+SvTAINTED_off||5.004000|
+SvTAINTED_on||5.004000|
+SvTAINTED||5.004000|
+SvTAINT|||
+SvTRUE|||
+SvTYPE|||
+SvUNLOCK||5.007003|
+SvUOK||5.007001|
+SvUPGRADE|||
+SvUTF8_off||5.006000|
+SvUTF8_on||5.006000|
+SvUTF8||5.006000|
+SvUVXx|5.004000||p
+SvUVX|5.004000||p
+SvUV_nomg|5.009001||p
+SvUV_set||5.009003|
+SvUVx|5.004000||p
+SvUV|5.004000||p
+SvVOK||5.008001|
+THIS|||n
+UNDERBAR|5.009002||p
+UVSIZE|5.006000||p
+UVTYPE|5.006000||p
+UVXf|5.007001||p
+UVof|5.006000||p
+UVuf|5.006000||p
+UVxf|5.006000||p
+XCPT_CATCH|5.009002||p
+XCPT_RETHROW|5.009002||p
+XCPT_TRY_END|5.009002||p
+XCPT_TRY_START|5.009002||p
+XPUSHi|||
+XPUSHmortal|5.009002||p
+XPUSHn|||
+XPUSHp|||
+XPUSHs|||
+XPUSHu|5.004000||p
+XSRETURN_EMPTY|||
+XSRETURN_IV|||
+XSRETURN_NO|||
+XSRETURN_NV|||
+XSRETURN_PV|||
+XSRETURN_UNDEF|||
+XSRETURN_UV|5.008001||p
+XSRETURN_YES|||
+XSRETURN|||
+XST_mIV|||
+XST_mNO|||
+XST_mNV|||
+XST_mPV|||
+XST_mUNDEF|||
+XST_mUV|5.008001||p
+XST_mYES|||
+XS_VERSION_BOOTCHECK|||
+XS_VERSION|||
+XS|||
+ZeroD|5.009002||p
+Zero|||
+_aMY_CXT|5.007003||p
+_pMY_CXT|5.007003||p
+aMY_CXT_|5.007003||p
+aMY_CXT|5.007003||p
+aTHX_|5.006000||p
+aTHX|5.006000||p
+add_data|||
+allocmy|||
+amagic_call|||
+any_dup|||
+ao|||
+append_elem|||
+append_list|||
+apply_attrs_my|||
+apply_attrs_string||5.006001|
+apply_attrs|||
+apply|||
+asIV|||
+asUV|||
+atfork_lock||5.007003|n
+atfork_unlock||5.007003|n
+av_arylen_p||5.009003|
+av_clear|||
+av_delete||5.006000|
+av_exists||5.006000|
+av_extend|||
+av_fake|||
+av_fetch|||
+av_fill|||
+av_len|||
+av_make|||
+av_pop|||
+av_push|||
+av_reify|||
+av_shift|||
+av_store|||
+av_undef|||
+av_unshift|||
+ax|||n
+bad_type|||
+bind_match|||
+block_end|||
+block_gimme||5.004000|
+block_start|||
+boolSV|5.004000||p
+boot_core_PerlIO|||
+boot_core_UNIVERSAL|||
+boot_core_xsutils|||
+bytes_from_utf8||5.007001|
+bytes_to_utf8||5.006001|
+cache_re|||
+call_argv|5.006000||p
+call_atexit||5.006000|
+call_body|||
+call_list_body|||
+call_list||5.004000|
+call_method|5.006000||p
+call_pv|5.006000||p
+call_sv|5.006000||p
+calloc||5.007002|n
+cando|||
+cast_i32||5.006000|
+cast_iv||5.006000|
+cast_ulong||5.006000|
+cast_uv||5.006000|
+check_uni|||
+checkcomma|||
+checkposixcc|||
+ck_anoncode|||
+ck_bitop|||
+ck_concat|||
+ck_defined|||
+ck_delete|||
+ck_die|||
+ck_eof|||
+ck_eval|||
+ck_exec|||
+ck_exists|||
+ck_exit|||
+ck_ftst|||
+ck_fun|||
+ck_glob|||
+ck_grep|||
+ck_index|||
+ck_join|||
+ck_lengthconst|||
+ck_lfun|||
+ck_listiob|||
+ck_match|||
+ck_method|||
+ck_null|||
+ck_open|||
+ck_repeat|||
+ck_require|||
+ck_retarget|||
+ck_return|||
+ck_rfun|||
+ck_rvconst|||
+ck_sassign|||
+ck_select|||
+ck_shift|||
+ck_sort|||
+ck_spair|||
+ck_split|||
+ck_subr|||
+ck_substr|||
+ck_svconst|||
+ck_trunc|||
+ck_unpack|||
+cl_and|||
+cl_anything|||
+cl_init_zero|||
+cl_init|||
+cl_is_anything|||
+cl_or|||
+closest_cop|||
+convert|||
+cop_free|||
+cr_textfilter|||
+croak_nocontext|||vn
+croak|||v
+csighandler||5.007001|n
+custom_op_desc||5.007003|
+custom_op_name||5.007003|
+cv_ckproto|||
+cv_clone|||
+cv_const_sv||5.004000|
+cv_dump|||
+cv_undef|||
+cx_dump||5.005000|
+cx_dup|||
+cxinc|||
+dAXMARK||5.009003|
+dAX|5.007002||p
+dITEMS|5.007002||p
+dMARK|||
+dMY_CXT_SV|5.007003||p
+dMY_CXT|5.007003||p
+dNOOP|5.006000||p
+dORIGMARK|||
+dSP|||
+dTHR|5.004050||p
+dTHXa|5.006000||p
+dTHXoa|5.006000||p
+dTHX|5.006000||p
+dUNDERBAR|5.009002||p
+dXCPT|5.009002||p
+dXSARGS|||
+dXSI32|||
+dXSTARG|5.006000||p
+deb_curcv|||
+deb_nocontext|||vn
+deb_stack_all|||
+deb_stack_n|||
+debop||5.005000|
+debprofdump||5.005000|
+debprof|||
+debstackptrs||5.007003|
+debstack||5.007003|
+deb||5.007003|v
+del_he|||
+del_sv|||
+delimcpy||5.004000|
+depcom|||
+deprecate_old|||
+deprecate|||
+despatch_signals||5.007001|
+die_nocontext|||vn
+die_where|||
+die|||v
+dirp_dup|||
+div128|||
+djSP|||
+do_aexec5|||
+do_aexec|||
+do_aspawn|||
+do_binmode||5.004050|
+do_chomp|||
+do_chop|||
+do_close|||
+do_dump_pad|||
+do_eof|||
+do_exec3|||
+do_execfree|||
+do_exec|||
+do_gv_dump||5.006000|
+do_gvgv_dump||5.006000|
+do_hv_dump||5.006000|
+do_ipcctl|||
+do_ipcget|||
+do_join|||
+do_kv|||
+do_magic_dump||5.006000|
+do_msgrcv|||
+do_msgsnd|||
+do_oddball|||
+do_op_dump||5.006000|
+do_open9||5.006000|
+do_openn||5.007001|
+do_open||5.004000|
+do_pipe|||
+do_pmop_dump||5.006000|
+do_print|||
+do_readline|||
+do_seek|||
+do_semop|||
+do_shmio|||
+do_spawn_nowait|||
+do_spawn|||
+do_sprintf|||
+do_sv_dump||5.006000|
+do_sysseek|||
+do_tell|||
+do_trans_complex_utf8|||
+do_trans_complex|||
+do_trans_count_utf8|||
+do_trans_count|||
+do_trans_simple_utf8|||
+do_trans_simple|||
+do_trans|||
+do_vecget|||
+do_vecset|||
+do_vop|||
+docatch_body|||
+docatch|||
+doeval|||
+dofile|||
+dofindlabel|||
+doform|||
+doing_taint||5.008001|n
+dooneliner|||
+doopen_pm|||
+doparseform|||
+dopoptoeval|||
+dopoptolabel|||
+dopoptoloop|||
+dopoptosub_at|||
+dopoptosub|||
+dounwind|||
+dowantarray|||
+dump_all||5.006000|
+dump_eval||5.006000|
+dump_fds|||
+dump_form||5.006000|
+dump_indent||5.006000|v
+dump_mstats|||
+dump_packsubs||5.006000|
+dump_sub||5.006000|
+dump_vindent||5.006000|
+dumpuntil|||
+dup_attrlist|||
+emulate_eaccess|||
+eval_pv|5.006000||p
+eval_sv|5.006000||p
+expect_number|||
+fbm_compile||5.005000|
+fbm_instr||5.005000|
+fd_on_nosuid_fs|||
+filter_add|||
+filter_del|||
+filter_gets|||
+filter_read|||
+find_beginning|||
+find_byclass|||
+find_in_my_stash|||
+find_runcv|||
+find_rundefsvoffset||5.009002|
+find_script|||
+find_uninit_var|||
+fold_constants|||
+forbid_setid|||
+force_ident|||
+force_list|||
+force_next|||
+force_version|||
+force_word|||
+form_nocontext|||vn
+form||5.004000|v
+fp_dup|||
+fprintf_nocontext|||vn
+free_global_struct|||
+free_tied_hv_pool|||
+free_tmps|||
+gen_constant_list|||
+get_av|5.006000||p
+get_context||5.006000|n
+get_cv|5.006000||p
+get_db_sub|||
+get_debug_opts|||
+get_hash_seed|||
+get_hv|5.006000||p
+get_mstats|||
+get_no_modify|||
+get_num|||
+get_op_descs||5.005000|
+get_op_names||5.005000|
+get_opargs|||
+get_ppaddr||5.006000|
+get_sv|5.006000||p
+get_vtbl||5.005030|
+getcwd_sv||5.007002|
+getenv_len|||
+gp_dup|||
+gp_free|||
+gp_ref|||
+grok_bin|5.007003||p
+grok_hex|5.007003||p
+grok_number|5.007002||p
+grok_numeric_radix|5.007002||p
+grok_oct|5.007003||p
+group_end|||
+gv_AVadd|||
+gv_HVadd|||
+gv_IOadd|||
+gv_autoload4||5.004000|
+gv_check|||
+gv_dump||5.006000|
+gv_efullname3||5.004000|
+gv_efullname4||5.006001|
+gv_efullname|||
+gv_ename|||
+gv_fetchfile|||
+gv_fetchmeth_autoload||5.007003|
+gv_fetchmethod_autoload||5.004000|
+gv_fetchmethod|||
+gv_fetchmeth|||
+gv_fetchpvn_flags||5.009002|
+gv_fetchpv|||
+gv_fetchsv||5.009002|
+gv_fullname3||5.004000|
+gv_fullname4||5.006001|
+gv_fullname|||
+gv_handler||5.007001|
+gv_init_sv|||
+gv_init|||
+gv_share|||
+gv_stashpvn|5.006000||p
+gv_stashpv|||
+gv_stashsv|||
+he_dup|||
+hek_dup|||
+hfreeentries|||
+hsplit|||
+hv_assert||5.009001|
+hv_auxinit|||
+hv_clear_placeholders||5.009001|
+hv_clear|||
+hv_delayfree_ent||5.004000|
+hv_delete_common|||
+hv_delete_ent||5.004000|
+hv_delete|||
+hv_eiter_p||5.009003|
+hv_eiter_set||5.009003|
+hv_exists_ent||5.004000|
+hv_exists|||
+hv_fetch_common|||
+hv_fetch_ent||5.004000|
+hv_fetch|||
+hv_free_ent||5.004000|
+hv_iterinit|||
+hv_iterkeysv||5.004000|
+hv_iterkey|||
+hv_iternext_flags||5.008000|
+hv_iternextsv|||
+hv_iternext|||
+hv_iterval|||
+hv_ksplit||5.004000|
+hv_magic_check|||
+hv_magic|||
+hv_name_set||5.009003|
+hv_notallowed|||
+hv_placeholders_get||5.009003|
+hv_placeholders_p||5.009003|
+hv_placeholders_set||5.009003|
+hv_riter_p||5.009003|
+hv_riter_set||5.009003|
+hv_scalar||5.009001|
+hv_store_ent||5.004000|
+hv_store_flags||5.008000|
+hv_store|||
+hv_undef|||
+ibcmp_locale||5.004000|
+ibcmp_utf8||5.007003|
+ibcmp|||
+incl_perldb|||
+incline|||
+incpush|||
+ingroup|||
+init_argv_symbols|||
+init_debugger|||
+init_global_struct|||
+init_i18nl10n||5.006000|
+init_i18nl14n||5.006000|
+init_ids|||
+init_interp|||
+init_lexer|||
+init_main_stash|||
+init_perllib|||
+init_postdump_symbols|||
+init_predump_symbols|||
+init_stacks||5.005000|
+init_tm||5.007002|
+instr|||
+intro_my|||
+intuit_method|||
+intuit_more|||
+invert|||
+io_close|||
+isALNUM|||
+isALPHA|||
+isDIGIT|||
+isLOWER|||
+isSPACE|||
+isUPPER|||
+is_an_int|||
+is_gv_magical_sv|||
+is_gv_magical|||
+is_handle_constructor|||
+is_list_assignment|||
+is_lvalue_sub||5.007001|
+is_uni_alnum_lc||5.006000|
+is_uni_alnumc_lc||5.006000|
+is_uni_alnumc||5.006000|
+is_uni_alnum||5.006000|
+is_uni_alpha_lc||5.006000|
+is_uni_alpha||5.006000|
+is_uni_ascii_lc||5.006000|
+is_uni_ascii||5.006000|
+is_uni_cntrl_lc||5.006000|
+is_uni_cntrl||5.006000|
+is_uni_digit_lc||5.006000|
+is_uni_digit||5.006000|
+is_uni_graph_lc||5.006000|
+is_uni_graph||5.006000|
+is_uni_idfirst_lc||5.006000|
+is_uni_idfirst||5.006000|
+is_uni_lower_lc||5.006000|
+is_uni_lower||5.006000|
+is_uni_print_lc||5.006000|
+is_uni_print||5.006000|
+is_uni_punct_lc||5.006000|
+is_uni_punct||5.006000|
+is_uni_space_lc||5.006000|
+is_uni_space||5.006000|
+is_uni_upper_lc||5.006000|
+is_uni_upper||5.006000|
+is_uni_xdigit_lc||5.006000|
+is_uni_xdigit||5.006000|
+is_utf8_alnumc||5.006000|
+is_utf8_alnum||5.006000|
+is_utf8_alpha||5.006000|
+is_utf8_ascii||5.006000|
+is_utf8_char_slow|||
+is_utf8_char||5.006000|
+is_utf8_cntrl||5.006000|
+is_utf8_digit||5.006000|
+is_utf8_graph||5.006000|
+is_utf8_idcont||5.008000|
+is_utf8_idfirst||5.006000|
+is_utf8_lower||5.006000|
+is_utf8_mark||5.006000|
+is_utf8_print||5.006000|
+is_utf8_punct||5.006000|
+is_utf8_space||5.006000|
+is_utf8_string_loclen||5.009003|
+is_utf8_string_loc||5.008001|
+is_utf8_string||5.006001|
+is_utf8_upper||5.006000|
+is_utf8_xdigit||5.006000|
+isa_lookup|||
+items|||n
+ix|||n
+jmaybe|||
+keyword|||
+leave_scope|||
+lex_end|||
+lex_start|||
+linklist|||
+listkids|||
+list|||
+load_module_nocontext|||vn
+load_module||5.006000|v
+localize|||
+looks_like_number|||
+lop|||
+mPUSHi|5.009002||p
+mPUSHn|5.009002||p
+mPUSHp|5.009002||p
+mPUSHu|5.009002||p
+mXPUSHi|5.009002||p
+mXPUSHn|5.009002||p
+mXPUSHp|5.009002||p
+mXPUSHu|5.009002||p
+magic_clear_all_env|||
+magic_clearenv|||
+magic_clearpack|||
+magic_clearsig|||
+magic_dump||5.006000|
+magic_existspack|||
+magic_freearylen_p|||
+magic_freeovrld|||
+magic_freeregexp|||
+magic_getarylen|||
+magic_getdefelem|||
+magic_getglob|||
+magic_getnkeys|||
+magic_getpack|||
+magic_getpos|||
+magic_getsig|||
+magic_getsubstr|||
+magic_gettaint|||
+magic_getuvar|||
+magic_getvec|||
+magic_get|||
+magic_killbackrefs|||
+magic_len|||
+magic_methcall|||
+magic_methpack|||
+magic_nextpack|||
+magic_regdata_cnt|||
+magic_regdatum_get|||
+magic_regdatum_set|||
+magic_scalarpack|||
+magic_set_all_env|||
+magic_setamagic|||
+magic_setarylen|||
+magic_setbm|||
+magic_setcollxfrm|||
+magic_setdbline|||
+magic_setdefelem|||
+magic_setenv|||
+magic_setfm|||
+magic_setglob|||
+magic_setisa|||
+magic_setmglob|||
+magic_setnkeys|||
+magic_setpack|||
+magic_setpos|||
+magic_setregexp|||
+magic_setsig|||
+magic_setsubstr|||
+magic_settaint|||
+magic_setutf8|||
+magic_setuvar|||
+magic_setvec|||
+magic_set|||
+magic_sizepack|||
+magic_wipepack|||
+magicname|||
+make_trie|||
+malloced_size|||n
+malloc||5.007002|n
+markstack_grow|||
+measure_struct|||
+memEQ|5.004000||p
+memNE|5.004000||p
+mem_collxfrm|||
+mess_alloc|||
+mess_nocontext|||vn
+mess||5.006000|v
+method_common|||
+mfree||5.007002|n
+mg_clear|||
+mg_copy|||
+mg_dup|||
+mg_find|||
+mg_free|||
+mg_get|||
+mg_length||5.005000|
+mg_localize|||
+mg_magical|||
+mg_set|||
+mg_size||5.005000|
+mini_mktime||5.007002|
+missingterm|||
+mode_from_discipline|||
+modkids|||
+mod|||
+moreswitches|||
+mul128|||
+mulexp10|||n
+my_atof2||5.007002|
+my_atof||5.006000|
+my_attrs|||
+my_bcopy|||n
+my_betoh16|||n
+my_betoh32|||n
+my_betoh64|||n
+my_betohi|||n
+my_betohl|||n
+my_betohs|||n
+my_bzero|||n
+my_chsize|||
+my_exit_jump|||
+my_exit|||
+my_failure_exit||5.004000|
+my_fflush_all||5.006000|
+my_fork||5.007003|n
+my_htobe16|||n
+my_htobe32|||n
+my_htobe64|||n
+my_htobei|||n
+my_htobel|||n
+my_htobes|||n
+my_htole16|||n
+my_htole32|||n
+my_htole64|||n
+my_htolei|||n
+my_htolel|||n
+my_htoles|||n
+my_htonl|||
+my_kid|||
+my_letoh16|||n
+my_letoh32|||n
+my_letoh64|||n
+my_letohi|||n
+my_letohl|||n
+my_letohs|||n
+my_lstat|||
+my_memcmp||5.004000|n
+my_memset|||n
+my_ntohl|||
+my_pclose||5.004000|
+my_popen_list||5.007001|
+my_popen||5.004000|
+my_setenv|||
+my_socketpair||5.007003|n
+my_stat|||
+my_strftime||5.007002|
+my_swabn|||n
+my_swap|||
+my_unexec|||
+my|||
+newANONATTRSUB||5.006000|
+newANONHASH|||
+newANONLIST|||
+newANONSUB|||
+newASSIGNOP|||
+newATTRSUB||5.006000|
+newAVREF|||
+newAV|||
+newBINOP|||
+newCONDOP|||
+newCONSTSUB|5.006000||p
+newCVREF|||
+newDEFSVOP|||
+newFORM|||
+newFOROP|||
+newGVOP|||
+newGVREF|||
+newGVgen|||
+newHVREF|||
+newHVhv||5.005000|
+newHV|||
+newIO|||
+newLISTOP|||
+newLOGOP|||
+newLOOPEX|||
+newLOOPOP|||
+newMYSUB||5.006000|
+newNULLLIST|||
+newOP|||
+newPADOP||5.006000|
+newPMOP|||
+newPROG|||
+newPVOP|||
+newRANGE|||
+newRV_inc|5.004000||p
+newRV_noinc|5.006000||p
+newRV|||
+newSLICEOP|||
+newSTATEOP|||
+newSUB|||
+newSVOP|||
+newSVREF|||
+newSVhek||5.009003|
+newSViv|||
+newSVnv|||
+newSVpvf_nocontext|||vn
+newSVpvf||5.004000|v
+newSVpvn_share||5.007001|
+newSVpvn|5.006000||p
+newSVpv|||
+newSVrv|||
+newSVsv|||
+newSVuv|5.006000||p
+newSV|||
+newUNOP|||
+newWHILEOP||5.009003|
+newXSproto||5.006000|
+newXS||5.006000|
+new_collate||5.006000|
+new_constant|||
+new_ctype||5.006000|
+new_he|||
+new_logop|||
+new_numeric||5.006000|
+new_stackinfo||5.005000|
+new_version||5.009000|
+next_symbol|||
+nextargv|||
+nextchar|||
+ninstr|||
+no_bareword_allowed|||
+no_fh_allowed|||
+no_op|||
+not_a_number|||
+nothreadhook||5.008000|
+nuke_stacks|||
+num_overflow|||n
+oopsAV|||
+oopsCV|||
+oopsHV|||
+op_clear|||
+op_const_sv|||
+op_dump||5.006000|
+op_free|||
+op_null||5.007002|
+op_refcnt_lock||5.009002|
+op_refcnt_unlock||5.009002|
+open_script|||
+pMY_CXT_|5.007003||p
+pMY_CXT|5.007003||p
+pTHX_|5.006000||p
+pTHX|5.006000||p
+pack_cat||5.007003|
+pack_rec|||
+package|||
+packlist||5.008001|
+pad_add_anon|||
+pad_add_name|||
+pad_alloc|||
+pad_block_start|||
+pad_check_dup|||
+pad_compname_type|||
+pad_findlex|||
+pad_findmy|||
+pad_fixup_inner_anons|||
+pad_free|||
+pad_leavemy|||
+pad_new|||
+pad_push|||
+pad_reset|||
+pad_setsv|||
+pad_sv|||
+pad_swipe|||
+pad_tidy|||
+pad_undef|||
+parse_body|||
+parse_unicode_opts|||
+path_is_absolute|||
+peep|||
+pending_ident|||
+perl_alloc_using|||n
+perl_alloc|||n
+perl_clone_using|||n
+perl_clone|||n
+perl_construct|||n
+perl_destruct||5.007003|n
+perl_free|||n
+perl_parse||5.006000|n
+perl_run|||n
+pidgone|||
+pmflag|||
+pmop_dump||5.006000|
+pmruntime|||
+pmtrans|||
+pop_scope|||
+pregcomp|||
+pregexec|||
+pregfree|||
+prepend_elem|||
+printf_nocontext|||vn
+ptr_table_clear|||
+ptr_table_fetch|||
+ptr_table_free|||
+ptr_table_new|||
+ptr_table_split|||
+ptr_table_store|||
+push_scope|||
+put_byte|||
+pv_display||5.006000|
+pv_uni_display||5.007003|
+qerror|||
+re_croak2|||
+re_dup|||
+re_intuit_start||5.006000|
+re_intuit_string||5.006000|
+realloc||5.007002|n
+reentrant_free|||
+reentrant_init|||
+reentrant_retry|||vn
+reentrant_size|||
+refkids|||
+refto|||
+ref|||
+reg_node|||
+reganode|||
+regatom|||
+regbranch|||
+regclass_swash||5.007003|
+regclass|||
+regcp_set_to|||
+regcppop|||
+regcppush|||
+regcurly|||
+regdump||5.005000|
+regexec_flags||5.005000|
+reghop3|||
+reghopmaybe3|||
+reghopmaybe|||
+reghop|||
+reginclass|||
+reginitcolors||5.006000|
+reginsert|||
+regmatch|||
+regnext||5.005000|
+regoptail|||
+regpiece|||
+regpposixcc|||
+regprop|||
+regrepeat_hard|||
+regrepeat|||
+regtail|||
+regtry|||
+reguni|||
+regwhite|||
+reg|||
+repeatcpy|||
+report_evil_fh|||
+report_uninit|||
+require_errno|||
+require_pv||5.006000|
+rninstr|||
+rsignal_restore|||
+rsignal_save|||
+rsignal_state||5.004000|
+rsignal||5.004000|
+run_body|||
+runops_debug||5.005000|
+runops_standard||5.005000|
+rvpv_dup|||
+rxres_free|||
+rxres_restore|||
+rxres_save|||
+safesyscalloc||5.006000|n
+safesysfree||5.006000|n
+safesysmalloc||5.006000|n
+safesysrealloc||5.006000|n
+same_dirent|||
+save_I16||5.004000|
+save_I32|||
+save_I8||5.006000|
+save_aelem||5.004050|
+save_alloc||5.006000|
+save_aptr|||
+save_ary|||
+save_bool||5.008001|
+save_clearsv|||
+save_delete|||
+save_destructor_x||5.006000|
+save_destructor||5.006000|
+save_freeop|||
+save_freepv|||
+save_freesv|||
+save_generic_pvref||5.006001|
+save_generic_svref||5.005030|
+save_gp||5.004000|
+save_hash|||
+save_hek_flags|||
+save_helem||5.004050|
+save_hints||5.005000|
+save_hptr|||
+save_int|||
+save_item|||
+save_iv||5.005000|
+save_lines|||
+save_list|||
+save_long|||
+save_magic|||
+save_mortalizesv||5.007001|
+save_nogv|||
+save_op|||
+save_padsv||5.007001|
+save_pptr|||
+save_re_context||5.006000|
+save_scalar_at|||
+save_scalar|||
+save_set_svflags||5.009000|
+save_shared_pvref||5.007003|
+save_sptr|||
+save_svref|||
+save_threadsv||5.005000|
+save_vptr||5.006000|
+savepvn|||
+savepv|||
+savesharedpv||5.007003|
+savestack_grow_cnt||5.008001|
+savestack_grow|||
+savesvpv||5.009002|
+sawparens|||
+scalar_mod_type|||
+scalarboolean|||
+scalarkids|||
+scalarseq|||
+scalarvoid|||
+scalar|||
+scan_bin||5.006000|
+scan_commit|||
+scan_const|||
+scan_formline|||
+scan_heredoc|||
+scan_hex|||
+scan_ident|||
+scan_inputsymbol|||
+scan_num||5.007001|
+scan_oct|||
+scan_pat|||
+scan_str|||
+scan_subst|||
+scan_trans|||
+scan_version||5.009001|
+scan_vstring||5.008001|
+scan_word|||
+scope|||
+screaminstr||5.005000|
+seed|||
+set_context||5.006000|n
+set_csh|||
+set_numeric_local||5.006000|
+set_numeric_radix||5.006000|
+set_numeric_standard||5.006000|
+setdefout|||
+setenv_getix|||
+share_hek_flags|||
+share_hek|||
+si_dup|||
+sighandler|||n
+simplify_sort|||
+skipspace|||
+sortsv||5.007003|
+ss_dup|||
+stack_grow|||
+start_glob|||
+start_subparse||5.004000|
+stashpv_hvname_match||5.009003|
+stdize_locale|||
+strEQ|||
+strGE|||
+strGT|||
+strLE|||
+strLT|||
+strNE|||
+str_to_version||5.006000|
+strnEQ|||
+strnNE|||
+study_chunk|||
+sub_crush_depth|||
+sublex_done|||
+sublex_push|||
+sublex_start|||
+sv_2bool|||
+sv_2cv|||
+sv_2io|||
+sv_2iuv_non_preserve|||
+sv_2iv_flags||5.009001|
+sv_2iv|||
+sv_2mortal|||
+sv_2nv|||
+sv_2pv_flags||5.007002|
+sv_2pv_nolen|5.006000||p
+sv_2pvbyte_nolen|||
+sv_2pvbyte|5.006000||p
+sv_2pvutf8_nolen||5.006000|
+sv_2pvutf8||5.006000|
+sv_2pv|||
+sv_2uv_flags||5.009001|
+sv_2uv|5.004000||p
+sv_add_arena|||
+sv_add_backref|||
+sv_backoff|||
+sv_bless|||
+sv_cat_decode||5.008001|
+sv_catpv_mg|5.006000||p
+sv_catpvf_mg_nocontext|||pvn
+sv_catpvf_mg|5.006000|5.004000|pv
+sv_catpvf_nocontext|||vn
+sv_catpvf||5.004000|v
+sv_catpvn_flags||5.007002|
+sv_catpvn_mg|5.006000||p
+sv_catpvn_nomg|5.007002||p
+sv_catpvn|||
+sv_catpv|||
+sv_catsv_flags||5.007002|
+sv_catsv_mg|5.006000||p
+sv_catsv_nomg|5.007002||p
+sv_catsv|||
+sv_chop|||
+sv_clean_all|||
+sv_clean_objs|||
+sv_clear|||
+sv_cmp_locale||5.004000|
+sv_cmp|||
+sv_collxfrm|||
+sv_compile_2op||5.008001|
+sv_copypv||5.007003|
+sv_dec|||
+sv_del_backref|||
+sv_derived_from||5.004000|
+sv_dump|||
+sv_dup|||
+sv_eq|||
+sv_force_normal_flags||5.007001|
+sv_force_normal||5.006000|
+sv_free2|||
+sv_free_arenas|||
+sv_free|||
+sv_gets||5.004000|
+sv_grow|||
+sv_inc|||
+sv_insert|||
+sv_isa|||
+sv_isobject|||
+sv_iv||5.005000|
+sv_len_utf8||5.006000|
+sv_len|||
+sv_magicext||5.007003|
+sv_magic|||
+sv_mortalcopy|||
+sv_newmortal|||
+sv_newref|||
+sv_nolocking||5.007003|
+sv_nosharing||5.007003|
+sv_nounlocking||5.007003|
+sv_nv||5.005000|
+sv_peek||5.005000|
+sv_pos_b2u||5.006000|
+sv_pos_u2b||5.006000|
+sv_pvbyten_force||5.006000|
+sv_pvbyten||5.006000|
+sv_pvbyte||5.006000|
+sv_pvn_force_flags||5.007002|
+sv_pvn_force|||p
+sv_pvn_nomg|5.007003||p
+sv_pvn|5.006000||p
+sv_pvutf8n_force||5.006000|
+sv_pvutf8n||5.006000|
+sv_pvutf8||5.006000|
+sv_pv||5.006000|
+sv_recode_to_utf8||5.007003|
+sv_reftype|||
+sv_release_COW|||
+sv_release_IVX|||
+sv_replace|||
+sv_report_used|||
+sv_reset|||
+sv_rvweaken||5.006000|
+sv_setiv_mg|5.006000||p
+sv_setiv|||
+sv_setnv_mg|5.006000||p
+sv_setnv|||
+sv_setpv_mg|5.006000||p
+sv_setpvf_mg_nocontext|||pvn
+sv_setpvf_mg|5.006000|5.004000|pv
+sv_setpvf_nocontext|||vn
+sv_setpvf||5.004000|v
+sv_setpviv_mg||5.008001|
+sv_setpviv||5.008001|
+sv_setpvn_mg|5.006000||p
+sv_setpvn|||
+sv_setpv|||
+sv_setref_iv|||
+sv_setref_nv|||
+sv_setref_pvn|||
+sv_setref_pv|||
+sv_setref_uv||5.007001|
+sv_setsv_cow|||
+sv_setsv_flags||5.007002|
+sv_setsv_mg|5.006000||p
+sv_setsv_nomg|5.007002||p
+sv_setsv|||
+sv_setuv_mg|5.006000||p
+sv_setuv|5.006000||p
+sv_tainted||5.004000|
+sv_taint||5.004000|
+sv_true||5.005000|
+sv_unglob|||
+sv_uni_display||5.007003|
+sv_unmagic|||
+sv_unref_flags||5.007001|
+sv_unref|||
+sv_untaint||5.004000|
+sv_upgrade|||
+sv_usepvn_mg|5.006000||p
+sv_usepvn|||
+sv_utf8_decode||5.006000|
+sv_utf8_downgrade||5.006000|
+sv_utf8_encode||5.006000|
+sv_utf8_upgrade_flags||5.007002|
+sv_utf8_upgrade||5.007001|
+sv_uv|5.006000||p
+sv_vcatpvf_mg|5.006000|5.004000|p
+sv_vcatpvfn||5.004000|
+sv_vcatpvf|5.006000|5.004000|p
+sv_vsetpvf_mg|5.006000|5.004000|p
+sv_vsetpvfn||5.004000|
+sv_vsetpvf|5.006000|5.004000|p
+svtype|||
+swallow_bom|||
+swash_fetch||5.007002|
+swash_init||5.006000|
+sys_intern_clear|||
+sys_intern_dup|||
+sys_intern_init|||
+taint_env|||
+taint_proper|||
+tmps_grow||5.006000|
+toLOWER|||
+toUPPER|||
+to_byte_substr|||
+to_uni_fold||5.007003|
+to_uni_lower_lc||5.006000|
+to_uni_lower||5.007003|
+to_uni_title_lc||5.006000|
+to_uni_title||5.007003|
+to_uni_upper_lc||5.006000|
+to_uni_upper||5.007003|
+to_utf8_case||5.007003|
+to_utf8_fold||5.007003|
+to_utf8_lower||5.007003|
+to_utf8_substr|||
+to_utf8_title||5.007003|
+to_utf8_upper||5.007003|
+tokeq|||
+tokereport|||
+too_few_arguments|||
+too_many_arguments|||
+unlnk|||
+unpack_rec|||
+unpack_str||5.007003|
+unpackstring||5.008001|
+unshare_hek_or_pvn|||
+unshare_hek|||
+unsharepvn||5.004000|
+upg_version||5.009000|
+usage|||
+utf16_textfilter|||
+utf16_to_utf8_reversed||5.006001|
+utf16_to_utf8||5.006001|
+utf16rev_textfilter|||
+utf8_distance||5.006000|
+utf8_hop||5.006000|
+utf8_length||5.007001|
+utf8_mg_pos_init|||
+utf8_mg_pos|||
+utf8_to_bytes||5.006001|
+utf8_to_uvchr||5.007001|
+utf8_to_uvuni||5.007001|
+utf8n_to_uvchr||5.007001|
+utf8n_to_uvuni||5.007001|
+utilize|||
+uvchr_to_utf8_flags||5.007003|
+uvchr_to_utf8||5.007001|
+uvuni_to_utf8_flags||5.007003|
+uvuni_to_utf8||5.007001|
+validate_suid|||
+varname|||
+vcmp||5.009000|
+vcroak||5.006000|
+vdeb||5.007003|
+vdie|||
+vform||5.006000|
+visit|||
+vivify_defelem|||
+vivify_ref|||
+vload_module||5.006000|
+vmess||5.006000|
+vnewSVpvf|5.006000|5.004000|p
+vnormal||5.009002|
+vnumify||5.009000|
+vstringify||5.009000|
+vwarner||5.006000|
+vwarn||5.006000|
+wait4pid|||
+warn_nocontext|||vn
+warner_nocontext|||vn
+warner||5.006000|v
+warn|||v
+watch|||
+whichsig|||
+write_to_stderr|||
+yyerror|||
+yylex|||
+yyparse|||
+yywarn|||
+);
+
+if (exists $opt{'list-unsupported'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{todo};
+ print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
+ }
+ exit 0;
+}
+
+# Scan for possible replacement candidates
+
+my(%replace, %need, %hints, %depends);
+my $replace = 0;
+my $hint = '';
+
+while (<DATA>) {
+ if ($hint) {
+ if (m{^\s*\*\s(.*?)\s*$}) {
+ $hints{$hint} ||= ''; # suppress warning with older perls
+ $hints{$hint} .= "$1\n";
+ }
+ else {
+ $hint = '';
+ }
+ }
+ $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
+
+ $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
+ $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
+ $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
+ $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
+
+ if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
+ push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
+ }
+
+ $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
+}
+
+if (exists $opt{'api-info'}) {
+ my $f;
+ my $count = 0;
+ my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $f =~ /$match/;
+ print "\n=== $f ===\n\n";
+ my $info = 0;
+ if ($API{$f}{base} || $API{$f}{todo}) {
+ my $base = format_version($API{$f}{base} || $API{$f}{todo});
+ print "Supported at least starting from perl-$base.\n";
+ $info++;
+ }
+ if ($API{$f}{provided}) {
+ my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
+ print "Support by $ppport provided back to perl-$todo.\n";
+ print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
+ print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
+ print "$hints{$f}" if exists $hints{$f};
+ $info++;
+ }
+ unless ($info) {
+ print "No portability information available.\n";
+ }
+ $count++;
+ }
+ if ($count > 0) {
+ print "\n";
+ }
+ else {
+ print "Found no API matching '$opt{'api-info'}'.\n";
+ }
+ exit 0;
+}
+
+if (exists $opt{'list-provided'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{provided};
+ my @flags;
+ push @flags, 'explicit' if exists $need{$f};
+ push @flags, 'depend' if exists $depends{$f};
+ push @flags, 'hint' if exists $hints{$f};
+ my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
+ print "$f$flags\n";
+ }
+ exit 0;
+}
+
+my @files;
+my @srcext = qw( xs c h cc cpp );
+my $srcext = join '|', @srcext;
+
+if (@ARGV) {
+ my %seen;
+ @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
+}
+else {
+ eval {
+ require File::Find;
+ File::Find::find(sub {
+ $File::Find::name =~ /\.($srcext)$/i
+ and push @files, $File::Find::name;
+ }, '.');
+ };
+ if ($@) {
+ @files = map { glob "*.$_" } @srcext;
+ }
+}
+
+if (!@ARGV || $opt{filter}) {
+ my(@in, @out);
+ my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
+ for (@files) {
+ my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i;
+ push @{ $out ? \@out : \@in }, $_;
+ }
+ if (@ARGV && @out) {
+ warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
+ }
+ @files = @in;
+}
+
+unless (@files) {
+ die "No input files given!\n";
+}
+
+my(%files, %global, %revreplace);
+%revreplace = reverse %replace;
+my $filename;
+my $patch_opened = 0;
+
+for $filename (@files) {
+ unless (open IN, "<$filename") {
+ warn "Unable to read from $filename: $!\n";
+ next;
+ }
+
+ info("Scanning $filename ...");
+
+ my $c = do { local $/; <IN> };
+ close IN;
+
+ my %file = (orig => $c, changes => 0);
+
+ # temporarily remove C comments from the code
+ my @ccom;
+ $c =~ s{
+ (
+ [^"'/]+
+ |
+ (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
+ |
+ (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
+ )
+ |
+ (/ (?:
+ \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
+ |
+ /[^\r\n]*
+ ))
+ }{
+ defined $2 and push @ccom, $2;
+ defined $1 ? $1 : "$ccs$#ccom$cce";
+ }egsx;
+
+ $file{ccom} = \@ccom;
+ $file{code} = $c;
+ $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
+
+ my $func;
+
+ for $func (keys %API) {
+ my $match = $func;
+ $match .= "|$revreplace{$func}" if exists $revreplace{$func};
+ if ($c =~ /\b(?:Perl_)?($match)\b/) {
+ $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
+ $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
+ if (exists $API{$func}{provided}) {
+ if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
+ $file{uses}{$func}++;
+ my @deps = rec_depend($func);
+ if (@deps) {
+ $file{uses_deps}{$func} = \@deps;
+ for (@deps) {
+ $file{uses}{$_} = 0 unless exists $file{uses}{$_};
+ }
+ }
+ for ($func, @deps) {
+ if (exists $need{$_}) {
+ $file{needs}{$_} = 'static';
+ }
+ }
+ }
+ }
+ if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
+ if ($c =~ /\b$func\b/) {
+ $file{uses_todo}{$func}++;
+ }
+ }
+ }
+ }
+
+ while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
+ if (exists $need{$2}) {
+ $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
+ }
+ else {
+ warning("Possibly wrong #define $1 in $filename");
+ }
+ }
+
+ for (qw(uses needs uses_todo needed_global needed_static)) {
+ for $func (keys %{$file{$_}}) {
+ push @{$global{$_}{$func}}, $filename;
+ }
+ }
+
+ $files{$filename} = \%file;
+}
+
+# Globally resolve NEED_'s
+my $need;
+for $need (keys %{$global{needs}}) {
+ if (@{$global{needs}{$need}} > 1) {
+ my @targets = @{$global{needs}{$need}};
+ my @t = grep $files{$_}{needed_global}{$need}, @targets;
+ @targets = @t if @t;
+ @t = grep /\.xs$/i, @targets;
+ @targets = @t if @t;
+ my $target = shift @targets;
+ $files{$target}{needs}{$need} = 'global';
+ for (@{$global{needs}{$need}}) {
+ $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
+ }
+ }
+}
+
+for $filename (@files) {
+ exists $files{$filename} or next;
+
+ info("=== Analyzing $filename ===");
+
+ my %file = %{$files{$filename}};
+ my $func;
+ my $c = $file{code};
+
+ for $func (sort keys %{$file{uses_Perl}}) {
+ if ($API{$func}{varargs}) {
+ my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
+ { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
+ if ($changes) {
+ warning("Doesn't pass interpreter argument aTHX to Perl_$func");
+ $file{changes} += $changes;
+ }
+ }
+ else {
+ warning("Uses Perl_$func instead of $func");
+ $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
+ {$func$1(}g);
+ }
+ }
+
+ for $func (sort keys %{$file{uses_replace}}) {
+ warning("Uses $func instead of $replace{$func}");
+ $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
+ }
+
+ for $func (sort keys %{$file{uses}}) {
+ next unless $file{uses}{$func}; # if it's only a dependency
+ if (exists $file{uses_deps}{$func}) {
+ diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
+ }
+ elsif (exists $replace{$func}) {
+ warning("Uses $func instead of $replace{$func}");
+ $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
+ }
+ else {
+ diag("Uses $func");
+ }
+ hint($func);
+ }
+
+ for $func (sort keys %{$file{uses_todo}}) {
+ warning("Uses $func, which may not be portable below perl ",
+ format_version($API{$func}{todo}));
+ }
+
+ for $func (sort keys %{$file{needed_static}}) {
+ my $message = '';
+ if (not exists $file{uses}{$func}) {
+ $message = "No need to define NEED_$func if $func is never used";
+ }
+ elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
+ $message = "No need to define NEED_$func when already needed globally";
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
+ }
+ }
+
+ for $func (sort keys %{$file{needed_global}}) {
+ my $message = '';
+ if (not exists $global{uses}{$func}) {
+ $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
+ }
+ elsif (exists $file{needs}{$func}) {
+ if ($file{needs}{$func} eq 'extern') {
+ $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
+ }
+ elsif ($file{needs}{$func} eq 'static') {
+ $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
+ }
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
+ }
+ }
+
+ $file{needs_inc_ppport} = keys %{$file{uses}};
+
+ if ($file{needs_inc_ppport}) {
+ my $pp = '';
+
+ for $func (sort keys %{$file{needs}}) {
+ my $type = $file{needs}{$func};
+ next if $type eq 'extern';
+ my $suffix = $type eq 'global' ? '_GLOBAL' : '';
+ unless (exists $file{"needed_$type"}{$func}) {
+ if ($type eq 'global') {
+ diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
+ }
+ else {
+ diag("File needs $func, adding static request");
+ }
+ $pp .= "#define NEED_$func$suffix\n";
+ }
+ }
+
+ if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
+ $pp = '';
+ $file{changes}++;
+ }
+
+ unless ($file{has_inc_ppport}) {
+ diag("Needs to include '$ppport'");
+ $pp .= qq(#include "$ppport"\n)
+ }
+
+ if ($pp) {
+ $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
+ || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
+ || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
+ || ($c =~ s/^/$pp/);
+ }
+ }
+ else {
+ if ($file{has_inc_ppport}) {
+ diag("No need to include '$ppport'");
+ $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
+ }
+ }
+
+ # put back in our C comments
+ my $ix;
+ my $cppc = 0;
+ my @ccom = @{$file{ccom}};
+ for $ix (0 .. $#ccom) {
+ if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
+ $cppc++;
+ $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
+ }
+ else {
+ $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
+ }
+ }
+
+ if ($cppc) {
+ my $s = $cppc != 1 ? 's' : '';
+ warning("Uses $cppc C++ style comment$s, which is not portable");
+ }
+
+ if ($file{changes}) {
+ if (exists $opt{copy}) {
+ my $newfile = "$filename$opt{copy}";
+ if (-e $newfile) {
+ error("'$newfile' already exists, refusing to write copy of '$filename'");
+ }
+ else {
+ local *F;
+ if (open F, ">$newfile") {
+ info("Writing copy of '$filename' with changes to '$newfile'");
+ print F $c;
+ close F;
+ }
+ else {
+ error("Cannot open '$newfile' for writing: $!");
+ }
+ }
+ }
+ elsif (exists $opt{patch} || $opt{changes}) {
+ if (exists $opt{patch}) {
+ unless ($patch_opened) {
+ if (open PATCH, ">$opt{patch}") {
+ $patch_opened = 1;
+ }
+ else {
+ error("Cannot open '$opt{patch}' for writing: $!");
+ delete $opt{patch};
+ $opt{changes} = 1;
+ goto fallback;
+ }
+ }
+ mydiff(\*PATCH, $filename, $c);
+ }
+ else {
+fallback:
+ info("Suggested changes:");
+ mydiff(\*STDOUT, $filename, $c);
+ }
+ }
+ else {
+ my $s = $file{changes} == 1 ? '' : 's';
+ info("$file{changes} potentially required change$s detected");
+ }
+ }
+ else {
+ info("Looks good");
+ }
+}
+
+close PATCH if $patch_opened;
+
+exit 0;
+
+
+sub mydiff
+{
+ local *F = shift;
+ my($file, $str) = @_;
+ my $diff;
+
+ if (exists $opt{diff}) {
+ $diff = run_diff($opt{diff}, $file, $str);
+ }
+
+ if (!defined $diff and can_use('Text::Diff')) {
+ $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
+ $diff = <<HEADER . $diff;
+--- $file
++++ $file.patched
+HEADER
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff -u', $file, $str);
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff', $file, $str);
+ }
+
+ if (!defined $diff) {
+ error("Cannot generate a diff. Please install Text::Diff or use --copy.");
+ return;
+ }
+
+ print F $diff;
+
+}
+
+sub run_diff
+{
+ my($prog, $file, $str) = @_;
+ my $tmp = 'dppptemp';
+ my $suf = 'aaa';
+ my $diff = '';
+ local *F;
+
+ while (-e "$tmp.$suf") { $suf++ }
+ $tmp = "$tmp.$suf";
+
+ if (open F, ">$tmp") {
+ print F $str;
+ close F;
+
+ if (open F, "$prog $file $tmp |") {
+ while (<F>) {
+ s/\Q$tmp\E/$file.patched/;
+ $diff .= $_;
+ }
+ close F;
+ unlink $tmp;
+ return $diff;
+ }
+
+ unlink $tmp;
+ }
+ else {
+ error("Cannot open '$tmp' for writing: $!");
+ }
+
+ return undef;
+}
+
+sub can_use
+{
+ eval "use @_;";
+ return $@ eq '';
+}
+
+sub rec_depend
+{
+ my $func = shift;
+ my %seen;
+ return () unless exists $depends{$func};
+ grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
+}
+
+sub parse_version
+{
+ my $ver = shift;
+
+ if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
+ return ($1, $2, $3);
+ }
+ elsif ($ver !~ /^\d+\.[\d_]+$/) {
+ die "cannot parse version '$ver'\n";
+ }
+
+ $ver =~ s/_//g;
+ $ver =~ s/$/000000/;
+
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "cannot parse version '$ver'\n";
+ }
+ }
+
+ return ($r, $v, $s);
+}
+
+sub format_version
+{
+ my $ver = shift;
+
+ $ver =~ s/$/000000/;
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "invalid version '$ver'\n";
+ }
+ $s /= 10;
+
+ $ver = sprintf "%d.%03d", $r, $v;
+ $s > 0 and $ver .= sprintf "_%02d", $s;
+
+ return $ver;
+ }
+
+ return sprintf "%d.%d.%d", $r, $v, $s;
+}
+
+sub info
+{
+ $opt{quiet} and return;
+ print @_, "\n";
+}
+
+sub diag
+{
+ $opt{quiet} and return;
+ $opt{diag} and print @_, "\n";
+}
+
+sub warning
+{
+ $opt{quiet} and return;
+ print "*** ", @_, "\n";
+}
+
+sub error
+{
+ print "*** ERROR: ", @_, "\n";
+}
+
+my %given_hints;
+sub hint
+{
+ $opt{quiet} and return;
+ $opt{hints} or return;
+ my $func = shift;
+ exists $hints{$func} or return;
+ $given_hints{$func}++ and return;
+ my $hint = $hints{$func};
+ $hint =~ s/^/ /mg;
+ print " --- hint for $func ---\n", $hint;
+}
+
+sub usage
+{
+ my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
+ my %M = ( 'I' => '*' );
+ $usage =~ s/^\s*perl\s+\S+/$^X $0/;
+ $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
+
+ print <<ENDUSAGE;
+
+Usage: $usage
+
+See perldoc $0 for details.
+
+ENDUSAGE
+
+ exit 2;
+}
+
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef DPPP_NAMESPACE
+# define DPPP_NAMESPACE DPPP_
+#endif
+
+#define DPPP_CAT2(x,y) CAT2(x,y)
+#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
+
+#ifndef PERL_REVISION
+# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
+# define PERL_PATCHLEVEL_H_IMPLICIT
+# include <patchlevel.h>
+# endif
+# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+
+#ifdef I_LIMITS
+# include <limits.h>
+#endif
+
+#ifndef PERL_UCHAR_MIN
+# define PERL_UCHAR_MIN ((unsigned char)0)
+#endif
+
+#ifndef PERL_UCHAR_MAX
+# ifdef UCHAR_MAX
+# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
+# else
+# ifdef MAXUCHAR
+# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
+# else
+# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_USHORT_MIN
+# define PERL_USHORT_MIN ((unsigned short)0)
+#endif
+
+#ifndef PERL_USHORT_MAX
+# ifdef USHORT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
+# else
+# ifdef MAXUSHORT
+# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
+# else
+# ifdef USHRT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
+# else
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MAX
+# ifdef SHORT_MAX
+# define PERL_SHORT_MAX ((short)SHORT_MAX)
+# else
+# ifdef MAXSHORT /* Often used in <values.h> */
+# define PERL_SHORT_MAX ((short)MAXSHORT)
+# else
+# ifdef SHRT_MAX
+# define PERL_SHORT_MAX ((short)SHRT_MAX)
+# else
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MIN
+# ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+# else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# ifdef SHRT_MIN
+# define PERL_SHORT_MIN ((short)SHRT_MIN)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MAX
+# ifdef UINT_MAX
+# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
+# else
+# ifdef MAXUINT
+# define PERL_UINT_MAX ((unsigned int)MAXUINT)
+# else
+# define PERL_UINT_MAX (~(unsigned int)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MIN
+# define PERL_UINT_MIN ((unsigned int)0)
+#endif
+
+#ifndef PERL_INT_MAX
+# ifdef INT_MAX
+# define PERL_INT_MAX ((int)INT_MAX)
+# else
+# ifdef MAXINT /* Often used in <values.h> */
+# define PERL_INT_MAX ((int)MAXINT)
+# else
+# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_INT_MIN
+# ifdef INT_MIN
+# define PERL_INT_MIN ((int)INT_MIN)
+# else
+# ifdef MININT
+# define PERL_INT_MIN ((int)MININT)
+# else
+# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MAX
+# ifdef ULONG_MAX
+# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
+# else
+# ifdef MAXULONG
+# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
+# else
+# define PERL_ULONG_MAX (~(unsigned long)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MIN
+# define PERL_ULONG_MIN ((unsigned long)0L)
+#endif
+
+#ifndef PERL_LONG_MAX
+# ifdef LONG_MAX
+# define PERL_LONG_MAX ((long)LONG_MAX)
+# else
+# ifdef MAXLONG
+# define PERL_LONG_MAX ((long)MAXLONG)
+# else
+# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_LONG_MIN
+# ifdef LONG_MIN
+# define PERL_LONG_MIN ((long)LONG_MIN)
+# else
+# ifdef MINLONG
+# define PERL_LONG_MIN ((long)MINLONG)
+# else
+# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#if defined(HAS_QUAD) && (defined(convex) || defined(uts))
+# ifndef PERL_UQUAD_MAX
+# ifdef ULONGLONG_MAX
+# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
+# else
+# ifdef MAXULONGLONG
+# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
+# else
+# define PERL_UQUAD_MAX (~(unsigned long long)0)
+# endif
+# endif
+# endif
+
+# ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN ((unsigned long long)0L)
+# endif
+
+# ifndef PERL_QUAD_MAX
+# ifdef LONGLONG_MAX
+# define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
+# else
+# ifdef MAXLONGLONG
+# define PERL_QUAD_MAX ((long long)MAXLONGLONG)
+# else
+# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
+# endif
+# endif
+# endif
+
+# ifndef PERL_QUAD_MIN
+# ifdef LONGLONG_MIN
+# define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
+# else
+# ifdef MINLONGLONG
+# define PERL_QUAD_MIN ((long long)MINLONGLONG)
+# else
+# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+/* This is based on code from 5.003 perl.h */
+#ifdef HAS_QUAD
+# ifdef cray
+#ifndef IVTYPE
+# define IVTYPE int
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_INT_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_INT_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UINT_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UINT_MAX
+#endif
+
+# ifdef INTSIZE
+#ifndef IVSIZE
+# define IVSIZE INTSIZE
+#endif
+
+# endif
+# else
+# if defined(convex) || defined(uts)
+#ifndef IVTYPE
+# define IVTYPE long long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_QUAD_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_QUAD_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UQUAD_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UQUAD_MAX
+#endif
+
+# ifdef LONGLONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGLONGSIZE
+#endif
+
+# endif
+# else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+# ifdef LONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGSIZE
+#endif
+
+# endif
+# endif
+# endif
+#ifndef IVSIZE
+# define IVSIZE 8
+#endif
+
+#ifndef PERL_QUAD_MIN
+# define PERL_QUAD_MIN IV_MIN
+#endif
+
+#ifndef PERL_QUAD_MAX
+# define PERL_QUAD_MAX IV_MAX
+#endif
+
+#ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN UV_MIN
+#endif
+
+#ifndef PERL_UQUAD_MAX
+# define PERL_UQUAD_MAX UV_MAX
+#endif
+
+#else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+#endif
+
+#ifndef IVSIZE
+# ifdef LONGSIZE
+# define IVSIZE LONGSIZE
+# else
+# define IVSIZE 4 /* A bold guess, but the best we can make. */
+# endif
+#endif
+#ifndef UVTYPE
+# define UVTYPE unsigned IVTYPE
+#endif
+
+#ifndef UVSIZE
+# define UVSIZE IVSIZE
+#endif
+
+#ifndef sv_setuv
+# define sv_setuv(sv, uv) \
+ STMT_START { \
+ UV TeMpUv = uv; \
+ if (TeMpUv <= IV_MAX) \
+ sv_setiv(sv, TeMpUv); \
+ else \
+ sv_setnv(sv, (double)TeMpUv); \
+ } STMT_END
+#endif
+
+#ifndef newSVuv
+# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
+#endif
+#ifndef sv_2uv
+# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
+#endif
+
+#ifndef SvUVX
+# define SvUVX(sv) ((UV)SvIVX(sv))
+#endif
+
+#ifndef SvUVXx
+# define SvUVXx(sv) SvUVX(sv)
+#endif
+
+#ifndef SvUV
+# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
+#endif
+
+#ifndef SvUVx
+# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
+#endif
+
+/* Hint: sv_uv
+ * Always use the SvUVx() macro instead of sv_uv().
+ */
+#ifndef sv_uv
+# define sv_uv(sv) SvUVx(sv)
+#endif
+#ifndef XST_mUV
+# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
+#endif
+
+#ifndef XSRETURN_UV
+# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
+#endif
+#ifndef PUSHu
+# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
+#endif
+
+#ifndef XPUSHu
+# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_DBsingle DBsingle
+# define PL_DBsub DBsub
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_debstash debstash
+# define PL_defgv defgv
+# define PL_diehook diehook
+# define PL_dirty dirty
+# define PL_dowarn dowarn
+# define PL_errgv errgv
+# define PL_hexdigit hexdigit
+# define PL_hints hints
+# define PL_na na
+# define PL_no_modify no_modify
+# define PL_perl_destruct_level perl_destruct_level
+# define PL_perldb perldb
+# define PL_ppaddr ppaddr
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfp rsfp
+# define PL_stack_base stack_base
+# define PL_stack_sp stack_sp
+# define PL_stdingv stdingv
+# define PL_sv_arenaroot sv_arenaroot
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+# define PL_tainted tainted
+# define PL_tainting tainting
+/* Replace: 0 */
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+#ifndef NOOP
+# define NOOP (void)0
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+
+# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+# else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+# endif
+
+# define NUM2PTR(any,d) (any)(PTRV)(d)
+# define PTR2IV(p) INT2PTR(IV,p)
+# define PTR2UV(p) INT2PTR(UV,p)
+# define PTR2NV(p) NUM2PTR(NV,p)
+
+# if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+# else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+# endif
+
+#endif /* !INT2PTR */
+
+#undef START_EXTERN_C
+#undef END_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C extern
+#endif
+
+#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
+# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# endif
+#endif
+
+#undef STMT_START
+#undef STMT_END
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
+# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
+# define STMT_END )
+#else
+# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
+# define STMT_START if (1)
+# define STMT_END else (void)0
+# else
+# define STMT_START do
+# define STMT_END while (0)
+# endif
+#endif
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+/* Older perls (<=5.003) lack AvFILLp */
+#ifndef AvFILLp
+# define AvFILLp AvFILL
+#endif
+#ifndef ERRSV
+# define ERRSV get_sv("@",FALSE)
+#endif
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((data) \
+ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
+ : newSV(0))
+#endif
+
+/* Hint: gv_stashpvn
+ * This function's backport doesn't support the length parameter, but
+ * rather ignores it. Portability can only be ensured if the length
+ * parameter is used for speed reasons, but the length can always be
+ * correctly computed from the string argument.
+ */
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
+#endif
+
+/* Replace: 1 */
+#ifndef get_cv
+# define get_cv perl_get_cv
+#endif
+
+#ifndef get_sv
+# define get_sv perl_get_sv
+#endif
+
+#ifndef get_av
+# define get_av perl_get_av
+#endif
+
+#ifndef get_hv
+# define get_hv perl_get_hv
+#endif
+
+/* Replace: 0 */
+
+#ifdef HAS_MEMCMP
+#ifndef memNE
+# define memNE(s1,s2,l) (memcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
+#endif
+
+#else
+#ifndef memNE
+# define memNE(s1,s2,l) (bcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
+#endif
+
+#endif
+#ifndef MoveD
+# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifndef CopyD
+# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifdef HAS_MEMSET
+#ifndef ZeroD
+# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
+#endif
+
+#else
+#ifndef ZeroD
+# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
+#endif
+
+#endif
+#ifndef Poison
+# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
+#endif
+#ifndef dUNDERBAR
+# define dUNDERBAR dNOOP
+#endif
+
+#ifndef UNDERBAR
+# define UNDERBAR DEFSV
+#endif
+#ifndef dAX
+# define dAX I32 ax = MARK - PL_stack_base + 1
+#endif
+
+#ifndef dITEMS
+# define dITEMS I32 items = SP - MARK
+#endif
+#ifndef dXSTARG
+# define dXSTARG SV * targ = sv_newmortal()
+#endif
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+#ifndef dTHX
+# define dTHX dNOOP
+#endif
+
+#ifndef dTHXa
+# define dTHXa(x) dNOOP
+#endif
+#ifndef pTHX
+# define pTHX void
+#endif
+
+#ifndef pTHX_
+# define pTHX_
+#endif
+
+#ifndef aTHX
+# define aTHX
+#endif
+
+#ifndef aTHX_
+# define aTHX_
+#endif
+#ifndef dTHXoa
+# define dTHXoa(x) dTHXa(x)
+#endif
+#ifndef PUSHmortal
+# define PUSHmortal PUSHs(sv_newmortal())
+#endif
+
+#ifndef mPUSHp
+# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
+#endif
+
+#ifndef mPUSHn
+# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
+#endif
+
+#ifndef mPUSHi
+# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
+#endif
+
+#ifndef mPUSHu
+# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
+#endif
+#ifndef XPUSHmortal
+# define XPUSHmortal XPUSHs(sv_newmortal())
+#endif
+
+#ifndef mXPUSHp
+# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
+#endif
+
+#ifndef mXPUSHn
+# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
+#endif
+
+#ifndef mXPUSHi
+# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
+#endif
+
+#ifndef mXPUSHu
+# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
+#endif
+
+/* Replace: 1 */
+#ifndef call_sv
+# define call_sv perl_call_sv
+#endif
+
+#ifndef call_pv
+# define call_pv perl_call_pv
+#endif
+
+#ifndef call_argv
+# define call_argv perl_call_argv
+#endif
+
+#ifndef call_method
+# define call_method perl_call_method
+#endif
+#ifndef eval_sv
+# define eval_sv perl_eval_sv
+#endif
+
+/* Replace: 0 */
+
+/* Replace perl_eval_pv with eval_pv */
+/* eval_pv depends on eval_sv */
+
+#ifndef eval_pv
+#if defined(NEED_eval_pv)
+static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
+static
+#else
+extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
+#endif
+
+#ifdef eval_pv
+# undef eval_pv
+#endif
+#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
+#define Perl_eval_pv DPPP_(my_eval_pv)
+
+#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
+
+SV*
+DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
+{
+ dSP;
+ SV* sv = newSVpv(p, 0);
+
+ PUSHMARK(sp);
+ eval_sv(sv, G_SCALAR);
+ SvREFCNT_dec(sv);
+
+ SPAGAIN;
+ sv = POPs;
+ PUTBACK;
+
+ if (croak_on_error && SvTRUE(GvSV(errgv)))
+ croak(SvPVx(GvSV(errgv), na));
+
+ return sv;
+}
+
+#endif
+#endif
+#ifndef newRV_inc
+# define newRV_inc(sv) newRV(sv) /* Replace */
+#endif
+
+#ifndef newRV_noinc
+#if defined(NEED_newRV_noinc)
+static SV * DPPP_(my_newRV_noinc)(SV *sv);
+static
+#else
+extern SV * DPPP_(my_newRV_noinc)(SV *sv);
+#endif
+
+#ifdef newRV_noinc
+# undef newRV_noinc
+#endif
+#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
+#define Perl_newRV_noinc DPPP_(my_newRV_noinc)
+
+#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
+SV *
+DPPP_(my_newRV_noinc)(SV *sv)
+{
+ SV *rv = (SV *)newRV(sv);
+ SvREFCNT_dec(sv);
+ return rv;
+}
+#endif
+#endif
+
+/* Hint: newCONSTSUB
+ * Returns a CV* as of perl-5.7.1. This return value is not supported
+ * by Devel::PPPort.
+ */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
+#if defined(NEED_newCONSTSUB)
+static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
+static
+#else
+extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
+#endif
+
+#ifdef newCONSTSUB
+# undef newCONSTSUB
+#endif
+#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
+#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+
+void
+DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
+ start_subparse(),
+#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
+ start_subparse(0),
+#else /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+#endif
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+#ifndef START_MY_CXT
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#endif /* START_MY_CXT */
+
+#ifndef MY_CXT_CLONE
+/* Clones the per-interpreter data. */
+#define MY_CXT_CLONE \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+#endif
+
+#else /* single interpreter */
+
+#ifndef START_MY_CXT
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif /* START_MY_CXT */
+
+#ifndef MY_CXT_CLONE
+#define MY_CXT_CLONE NOOP
+#endif
+
+#endif
+
+#ifndef IVdf
+# if IVSIZE == LONGSIZE
+# define IVdf "ld"
+# define UVuf "lu"
+# define UVof "lo"
+# define UVxf "lx"
+# define UVXf "lX"
+# else
+# if IVSIZE == INTSIZE
+# define IVdf "d"
+# define UVuf "u"
+# define UVof "o"
+# define UVxf "x"
+# define UVXf "X"
+# endif
+# endif
+#endif
+
+#ifndef NVef
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
+ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
+# define NVef PERL_PRIeldbl
+# define NVff PERL_PRIfldbl
+# define NVgf PERL_PRIgldbl
+# else
+# define NVef "e"
+# define NVff "f"
+# define NVgf "g"
+# endif
+#endif
+
+#ifndef SvPV_nolen
+
+#if defined(NEED_sv_2pv_nolen)
+static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
+static
+#else
+extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
+#endif
+
+#ifdef sv_2pv_nolen
+# undef sv_2pv_nolen
+#endif
+#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
+#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
+
+#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
+
+char *
+DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
+{
+ STRLEN n_a;
+ return sv_2pv(sv, &n_a);
+}
+
+#endif
+
+/* Hint: sv_2pv_nolen
+ * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
+ */
+
+/* SvPV_nolen depends on sv_2pv_nolen */
+#define SvPV_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX(sv) : sv_2pv_nolen(sv))
+
+#endif
+
+#ifdef SvPVbyte
+
+/* Hint: SvPVbyte
+ * Does not work in perl-5.6.1, ppport.h implements a version
+ * borrowed from perl-5.7.3.
+ */
+
+#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
+
+#if defined(NEED_sv_2pvbyte)
+static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
+static
+#else
+extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
+#endif
+
+#ifdef sv_2pvbyte
+# undef sv_2pvbyte
+#endif
+#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
+#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
+
+#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
+
+char *
+DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
+{
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
+}
+
+#endif
+
+/* Hint: sv_2pvbyte
+ * Use the SvPVbyte() macro instead of sv_2pvbyte().
+ */
+
+#undef SvPVbyte
+
+/* SvPVbyte depends on sv_2pvbyte */
+#define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+
+#endif
+
+#else
+
+# define SvPVbyte SvPV
+# define sv_2pvbyte sv_2pv
+
+#endif
+
+/* sv_2pvbyte_nolen depends on sv_2pv_nolen */
+#ifndef sv_2pvbyte_nolen
+# define sv_2pvbyte_nolen sv_2pv_nolen
+#endif
+
+/* Hint: sv_pvn
+ * Always use the SvPV() macro instead of sv_pvn().
+ */
+#ifndef sv_pvn
+# define sv_pvn(sv, len) SvPV(sv, len)
+#endif
+
+/* Hint: sv_pvn_force
+ * Always use the SvPV_force() macro instead of sv_pvn_force().
+ */
+#ifndef sv_pvn_force
+# define sv_pvn_force(sv, len) SvPV_force(sv, len)
+#endif
+
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
+#if defined(NEED_vnewSVpvf)
+static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
+static
+#else
+extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
+#endif
+
+#ifdef vnewSVpvf
+# undef vnewSVpvf
+#endif
+#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
+#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
+
+#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
+
+SV *
+DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
+{
+ register SV *sv = newSV(0);
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ return sv;
+}
+
+#endif
+#endif
+
+/* sv_vcatpvf depends on sv_vcatpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
+# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
+#endif
+
+/* sv_vsetpvf depends on sv_vsetpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
+# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
+#endif
+
+/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
+#if defined(NEED_sv_catpvf_mg)
+static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+#endif
+
+#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
+
+#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
+
+void
+DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+
+/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
+#ifdef PERL_IMPLICIT_CONTEXT
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
+#if defined(NEED_sv_catpvf_mg_nocontext)
+static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+#endif
+
+#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
+#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
+
+#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
+
+void
+DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+#endif
+
+#ifndef sv_catpvf_mg
+# ifdef PERL_IMPLICIT_CONTEXT
+# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
+# else
+# define sv_catpvf_mg Perl_sv_catpvf_mg
+# endif
+#endif
+
+/* sv_vcatpvf_mg depends on sv_vcatpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
+# define sv_vcatpvf_mg(sv, pat, args) \
+ STMT_START { \
+ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
+ SvSETMAGIC(sv); \
+ } STMT_END
+#endif
+
+/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
+#if defined(NEED_sv_setpvf_mg)
+static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+#endif
+
+#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
+
+#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
+
+void
+DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+
+/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
+#ifdef PERL_IMPLICIT_CONTEXT
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
+#if defined(NEED_sv_setpvf_mg_nocontext)
+static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+#endif
+
+#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
+#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
+
+#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
+
+void
+DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+#endif
+
+#ifndef sv_setpvf_mg
+# ifdef PERL_IMPLICIT_CONTEXT
+# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
+# else
+# define sv_setpvf_mg Perl_sv_setpvf_mg
+# endif
+#endif
+
+/* sv_vsetpvf_mg depends on sv_vsetpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
+# define sv_vsetpvf_mg(sv, pat, args) \
+ STMT_START { \
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
+ SvSETMAGIC(sv); \
+ } STMT_END
+#endif
+#ifndef SvGETMAGIC
+# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#endif
+#ifndef PERL_MAGIC_sv
+# define PERL_MAGIC_sv '\0'
+#endif
+
+#ifndef PERL_MAGIC_overload
+# define PERL_MAGIC_overload 'A'
+#endif
+
+#ifndef PERL_MAGIC_overload_elem
+# define PERL_MAGIC_overload_elem 'a'
+#endif
+
+#ifndef PERL_MAGIC_overload_table
+# define PERL_MAGIC_overload_table 'c'
+#endif
+
+#ifndef PERL_MAGIC_bm
+# define PERL_MAGIC_bm 'B'
+#endif
+
+#ifndef PERL_MAGIC_regdata
+# define PERL_MAGIC_regdata 'D'
+#endif
+
+#ifndef PERL_MAGIC_regdatum
+# define PERL_MAGIC_regdatum 'd'
+#endif
+
+#ifndef PERL_MAGIC_env
+# define PERL_MAGIC_env 'E'
+#endif
+
+#ifndef PERL_MAGIC_envelem
+# define PERL_MAGIC_envelem 'e'
+#endif
+
+#ifndef PERL_MAGIC_fm
+# define PERL_MAGIC_fm 'f'
+#endif
+
+#ifndef PERL_MAGIC_regex_global
+# define PERL_MAGIC_regex_global 'g'
+#endif
+
+#ifndef PERL_MAGIC_isa
+# define PERL_MAGIC_isa 'I'
+#endif
+
+#ifndef PERL_MAGIC_isaelem
+# define PERL_MAGIC_isaelem 'i'
+#endif
+
+#ifndef PERL_MAGIC_nkeys
+# define PERL_MAGIC_nkeys 'k'
+#endif
+
+#ifndef PERL_MAGIC_dbfile
+# define PERL_MAGIC_dbfile 'L'
+#endif
+
+#ifndef PERL_MAGIC_dbline
+# define PERL_MAGIC_dbline 'l'
+#endif
+
+#ifndef PERL_MAGIC_mutex
+# define PERL_MAGIC_mutex 'm'
+#endif
+
+#ifndef PERL_MAGIC_shared
+# define PERL_MAGIC_shared 'N'
+#endif
+
+#ifndef PERL_MAGIC_shared_scalar
+# define PERL_MAGIC_shared_scalar 'n'
+#endif
+
+#ifndef PERL_MAGIC_collxfrm
+# define PERL_MAGIC_collxfrm 'o'
+#endif
+
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
+#ifndef PERL_MAGIC_tiedelem
+# define PERL_MAGIC_tiedelem 'p'
+#endif
+
+#ifndef PERL_MAGIC_tiedscalar
+# define PERL_MAGIC_tiedscalar 'q'
+#endif
+
+#ifndef PERL_MAGIC_qr
+# define PERL_MAGIC_qr 'r'
+#endif
+
+#ifndef PERL_MAGIC_sig
+# define PERL_MAGIC_sig 'S'
+#endif
+
+#ifndef PERL_MAGIC_sigelem
+# define PERL_MAGIC_sigelem 's'
+#endif
+
+#ifndef PERL_MAGIC_taint
+# define PERL_MAGIC_taint 't'
+#endif
+
+#ifndef PERL_MAGIC_uvar
+# define PERL_MAGIC_uvar 'U'
+#endif
+
+#ifndef PERL_MAGIC_uvar_elem
+# define PERL_MAGIC_uvar_elem 'u'
+#endif
+
+#ifndef PERL_MAGIC_vstring
+# define PERL_MAGIC_vstring 'V'
+#endif
+
+#ifndef PERL_MAGIC_vec
+# define PERL_MAGIC_vec 'v'
+#endif
+
+#ifndef PERL_MAGIC_utf8
+# define PERL_MAGIC_utf8 'w'
+#endif
+
+#ifndef PERL_MAGIC_substr
+# define PERL_MAGIC_substr 'x'
+#endif
+
+#ifndef PERL_MAGIC_defelem
+# define PERL_MAGIC_defelem 'y'
+#endif
+
+#ifndef PERL_MAGIC_glob
+# define PERL_MAGIC_glob '*'
+#endif
+
+#ifndef PERL_MAGIC_arylen
+# define PERL_MAGIC_arylen '#'
+#endif
+
+#ifndef PERL_MAGIC_pos
+# define PERL_MAGIC_pos '.'
+#endif
+
+#ifndef PERL_MAGIC_backref
+# define PERL_MAGIC_backref '<'
+#endif
+
+#ifndef PERL_MAGIC_ext
+# define PERL_MAGIC_ext '~'
+#endif
+
+/* That's the best we can do... */
+#ifndef SvPV_force_nomg
+# define SvPV_force_nomg SvPV_force
+#endif
+
+#ifndef SvPV_nomg
+# define SvPV_nomg SvPV
+#endif
+
+#ifndef sv_catpvn_nomg
+# define sv_catpvn_nomg sv_catpvn
+#endif
+
+#ifndef sv_catsv_nomg
+# define sv_catsv_nomg sv_catsv
+#endif
+
+#ifndef sv_setsv_nomg
+# define sv_setsv_nomg sv_setsv
+#endif
+
+#ifndef sv_pvn_nomg
+# define sv_pvn_nomg sv_pvn
+#endif
+
+#ifndef SvIV_nomg
+# define SvIV_nomg SvIV
+#endif
+
+#ifndef SvUV_nomg
+# define SvUV_nomg SvUV
+#endif
+
+#ifndef sv_catpv_mg
+# define sv_catpv_mg(sv, ptr) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_catpv(TeMpSv,ptr); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_catpvn_mg
+# define sv_catpvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_catpvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_catsv_mg
+# define sv_catsv_mg(dsv, ssv) \
+ STMT_START { \
+ SV *TeMpSv = dsv; \
+ sv_catsv(TeMpSv,ssv); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setiv_mg
+# define sv_setiv_mg(sv, i) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setiv(TeMpSv,i); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setnv_mg
+# define sv_setnv_mg(sv, num) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setnv(TeMpSv,num); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setpv_mg
+# define sv_setpv_mg(sv, ptr) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setpv(TeMpSv,ptr); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setpvn_mg
+# define sv_setpvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setpvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setsv_mg
+# define sv_setsv_mg(dsv, ssv) \
+ STMT_START { \
+ SV *TeMpSv = dsv; \
+ sv_setsv(TeMpSv,ssv); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setuv_mg
+# define sv_setuv_mg(sv, i) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setuv(TeMpSv,i); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_usepvn_mg
+# define sv_usepvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_usepvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifdef USE_ITHREADS
+#ifndef CopFILE
+# define CopFILE(c) ((c)->cop_file)
+#endif
+
+#ifndef CopFILEGV
+# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
+#endif
+
+#ifndef CopFILE_set
+# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
+#endif
+
+#ifndef CopFILESV
+# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
+#endif
+
+#ifndef CopFILEAV
+# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
+#endif
+
+#ifndef CopSTASHPV
+# define CopSTASHPV(c) ((c)->cop_stashpv)
+#endif
+
+#ifndef CopSTASHPV_set
+# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
+#endif
+
+#ifndef CopSTASH
+# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
+#endif
+
+#ifndef CopSTASH_set
+# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
+#endif
+
+#ifndef CopSTASH_eq
+# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
+ || (CopSTASHPV(c) && HvNAME(hv) \
+ && strEQ(CopSTASHPV(c), HvNAME(hv)))))
+#endif
+
+#else
+#ifndef CopFILEGV
+# define CopFILEGV(c) ((c)->cop_filegv)
+#endif
+
+#ifndef CopFILEGV_set
+# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
+#endif
+
+#ifndef CopFILE_set
+# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
+#endif
+
+#ifndef CopFILESV
+# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
+#endif
+
+#ifndef CopFILEAV
+# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
+#endif
+
+#ifndef CopFILE
+# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
+#endif
+
+#ifndef CopSTASH
+# define CopSTASH(c) ((c)->cop_stash)
+#endif
+
+#ifndef CopSTASH_set
+# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
+#endif
+
+#ifndef CopSTASHPV
+# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
+#endif
+
+#ifndef CopSTASHPV_set
+# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
+#endif
+
+#ifndef CopSTASH_eq
+# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
+#endif
+
+#endif /* USE_ITHREADS */
+#ifndef IN_PERL_COMPILETIME
+# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
+#endif
+
+#ifndef IN_LOCALE_RUNTIME
+# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE_COMPILETIME
+# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE
+# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+#endif
+#ifndef IS_NUMBER_IN_UV
+# define IS_NUMBER_IN_UV 0x01
+#endif
+
+#ifndef IS_NUMBER_GREATER_THAN_UV_MAX
+# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef IS_NUMBER_NOT_INT
+# define IS_NUMBER_NOT_INT 0x04
+#endif
+
+#ifndef IS_NUMBER_NEG
+# define IS_NUMBER_NEG 0x08
+#endif
+
+#ifndef IS_NUMBER_INFINITY
+# define IS_NUMBER_INFINITY 0x10
+#endif
+
+#ifndef IS_NUMBER_NAN
+# define IS_NUMBER_NAN 0x20
+#endif
+
+/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
+#ifndef GROK_NUMERIC_RADIX
+# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
+#endif
+#ifndef PERL_SCAN_GREATER_THAN_UV_MAX
+# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef PERL_SCAN_SILENT_ILLDIGIT
+# define PERL_SCAN_SILENT_ILLDIGIT 0x04
+#endif
+
+#ifndef PERL_SCAN_ALLOW_UNDERSCORES
+# define PERL_SCAN_ALLOW_UNDERSCORES 0x01
+#endif
+
+#ifndef PERL_SCAN_DISALLOW_PREFIX
+# define PERL_SCAN_DISALLOW_PREFIX 0x02
+#endif
+
+#ifndef grok_numeric_radix
+#if defined(NEED_grok_numeric_radix)
+static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
+static
+#else
+extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
+#endif
+
+#ifdef grok_numeric_radix
+# undef grok_numeric_radix
+#endif
+#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
+#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
+
+#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
+bool
+DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
+{
+#ifdef USE_LOCALE_NUMERIC
+#ifdef PL_numeric_radix_sv
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#else
+ /* older perls don't have PL_numeric_radix_sv so the radix
+ * must manually be requested from locale.h
+ */
+#include <locale.h>
+ dTHR; /* needed for older threaded perls */
+ struct lconv *lc = localeconv();
+ char *radix = lc->decimal_point;
+ if (radix && IN_LOCALE) {
+ STRLEN len = strlen(radix);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#endif /* PERL_VERSION */
+#endif /* USE_LOCALE_NUMERIC */
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+#endif
+
+/* grok_number depends on grok_numeric_radix */
+
+#ifndef grok_number
+#if defined(NEED_grok_number)
+static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
+static
+#else
+extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
+#endif
+
+#ifdef grok_number
+# undef grok_number
+#endif
+#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
+#define Perl_grok_number DPPP_(my_grok_number)
+
+#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
+int
+DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10;
+ int numtype = 0;
+ int sawinf = 0;
+ int sawnan = 0;
+
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s == send) {
+ return 0;
+ } else if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ if (s == send)
+ return 0;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ if (++s < send) {
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && digit <= max_mod_10))) {
+ value = value * 10 + digit;
+ if (++s < send)
+ digit = *s - '0';
+ else
+ break;
+ }
+ if (digit >= 0 && digit <= 9
+ && (s < send)) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (s < send && isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
+ /* no digits before the radix means we need digits after it */
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ } else if (*s == 'I' || *s == 'i') {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
+ s++; if (s < send && (*s == 'I' || *s == 'i')) {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
+ s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
+ s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
+ s++;
+ }
+ sawinf = 1;
+ } else if (*s == 'N' || *s == 'n') {
+ /* XXX TODO: There are signaling NaNs and quiet NaNs. */
+ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++;
+ sawnan = 1;
+ } else
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else if (sawnan) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+ } else if (s < send) {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (s < send && (*s == '-' || *s == '+'))
+ s++;
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+}
+#endif
+#endif
+
+/*
+ * The grok_* routines have been modified to use warn() instead of
+ * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
+ * which is why the stack variable has been renamed to 'xdigit'.
+ */
+
+#ifndef grok_bin
+#if defined(NEED_grok_bin)
+static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+static
+#else
+extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+#endif
+
+#ifdef grok_bin
+# undef grok_bin
+#endif
+#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
+#define Perl_grok_bin DPPP_(my_grok_bin)
+
+#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
+UV
+DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_2 = UV_MAX / 2;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading b or 0b.
+ for compatibility silently suffer "b" and "0b" as valid binary
+ numbers. */
+ if (len >= 1) {
+ if (s[0] == 'b') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
+ s+=2;
+ len-=2;
+ }
+ }
+ }
+
+ for (; len-- && *s; s++) {
+ char bit = *s;
+ if (bit == '0' || bit == '1') {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ With gcc seems to be much straighter code than old scan_bin. */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_2) {
+ value = (value << 1) | (bit - '0');
+ continue;
+ }
+ /* Bah. We're just overflowed. */
+ warn("Integer overflow in binary number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 2.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount. */
+ value_nv += (NV)(bit - '0');
+ continue;
+ }
+ if (bit == '_' && len && allow_underscores && (bit = s[1])
+ && (bit == '0' || bit == '1'))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal binary digit '%c' ignored", *s);
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Binary number > 0b11111111111111111111111111111111 non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifndef grok_hex
+#if defined(NEED_grok_hex)
+static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+static
+#else
+extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+#endif
+
+#ifdef grok_hex
+# undef grok_hex
+#endif
+#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
+#define Perl_grok_hex DPPP_(my_grok_hex)
+
+#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
+UV
+DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_16 = UV_MAX / 16;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+ const char *xdigit;
+
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading x or 0x.
+ for compatibility silently suffer "x" and "0x" as valid hex numbers.
+ */
+ if (len >= 1) {
+ if (s[0] == 'x') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
+ s+=2;
+ len-=2;
+ }
+ }
+ }
+
+ for (; len-- && *s; s++) {
+ xdigit = strchr((char *) PL_hexdigit, *s);
+ if (xdigit) {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ With gcc seems to be much straighter code than old scan_hex. */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_16) {
+ value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
+ continue;
+ }
+ warn("Integer overflow in hexadecimal number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 16.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount of 16-tuples. */
+ value_nv += (NV)((xdigit - PL_hexdigit) & 15);
+ continue;
+ }
+ if (*s == '_' && len && allow_underscores && s[1]
+ && (xdigit = strchr((char *) PL_hexdigit, s[1])))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal hexadecimal digit '%c' ignored", *s);
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Hexadecimal number > 0xffffffff non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifndef grok_oct
+#if defined(NEED_grok_oct)
+static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+static
+#else
+extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+#endif
+
+#ifdef grok_oct
+# undef grok_oct
+#endif
+#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
+#define Perl_grok_oct DPPP_(my_grok_oct)
+
+#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
+UV
+DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_8 = UV_MAX / 8;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+
+ for (; len-- && *s; s++) {
+ /* gcc 2.95 optimiser not smart enough to figure that this subtraction
+ out front allows slicker code. */
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 7) {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_8) {
+ value = (value << 3) | digit;
+ continue;
+ }
+ /* Bah. We're just overflowed. */
+ warn("Integer overflow in octal number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 8.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount of 8-tuples. */
+ value_nv += (NV)digit;
+ continue;
+ }
+ if (digit == ('_' - '0') && len && allow_underscores
+ && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ /* Allow \octal to work the DWIM way (that is, stop scanning
+ * as soon as non-octal characters are seen, complain only iff
+ * someone seems to want to use the digits eight and nine). */
+ if (digit == 8 || digit == 9) {
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal octal digit '%c' ignored", *s);
+ }
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Octal number > 037777777777 non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifdef NO_XSLOCKS
+# ifdef dJMPENV
+# define dXCPT dJMPENV; int rEtV = 0
+# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
+# define XCPT_TRY_END JMPENV_POP;
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW JMPENV_JUMP(rEtV)
+# else
+# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
+# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
+# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW Siglongjmp(top_env, rEtV)
+# endif
+#endif
+
+#endif /* _P_P_PORTABILITY_H_ */
+
+/* End of File ppport.h */
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbivport.h b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbivport.h
new file mode 100755
index 00000000000..77dd96b86fb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbivport.h
@@ -0,0 +1,52 @@
+/* dbivport.h
+
+ Provides macros that enable greater portability between DBI versions.
+
+ This file should be *copied* and included in driver distributions
+ and #included into the source, after #include DBIXS.h
+
+ New driver releases should include an updated copy of dbivport.h
+ from the most recent DBI release.
+*/
+
+#ifndef DBI_VPORT_H
+#define DBI_VPORT_H
+
+#ifndef DBIh_SET_ERR_CHAR
+/* Emulate DBIh_SET_ERR_CHAR
+ Only uses the err_i, errstr and state parameters.
+*/
+#define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \
+ sv_setiv(DBIc_ERR(imp_xxh), err_i); \
+ (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \
+ sv_setpv(DBIc_ERRSTR(imp_xxh), errstr)
+#endif
+
+#ifndef DBIcf_Executed
+#define DBIcf_Executed 0x080000
+#endif
+
+#ifndef DBIc_TRACE_LEVEL_MASK
+#define DBIc_TRACE_LEVEL_MASK 0x0000000F
+#define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00
+#define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug)
+#define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK)
+#define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK)
+/* DBIc_TRACE_MATCHES - true if s1 'matches' s2 (c.f. trace_msg())
+ DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp))
+*/
+#define DBIc_TRACE_MATCHES(s1, s2) \
+ ( ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \
+ || ((s1 & DBIc_TRACE_FLAGS_MASK) & (s2 & DBIc_TRACE_FLAGS_MASK)) )
+/* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level
+ DBIc_TRACE(imp, 0, 0, 4) = if level >= 4
+ DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4
+ DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level
+*/
+#define DBIc_TRACE(imp, flags, flaglevel, level) \
+ ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \
+ || (level && DBIc_TRACE_LEVEL(imp) >= level) )
+#endif
+
+
+#endif /* !DBI_VPORT_H */
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbixs_rev.h b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbixs_rev.h
new file mode 100755
index 00000000000..da50f6018c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBI/dbixs_rev.h
@@ -0,0 +1,2 @@
+/* Sat May 2 16:48:00 2009 */
+#define DBIXS_REVISION 12733
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBIx/Simple/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DBIx/Simple/.packlist
new file mode 100755
index 00000000000..f71f69d95e6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBIx/Simple/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\DBIx\Simple.pm
+C:\strawberry\perl\vendor\lib\DBIx\Simple\Comparison.pod
+C:\strawberry\perl\vendor\lib\DBIx\Simple\Examples.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DBM/Deep/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DBM/Deep/.packlist
new file mode 100755
index 00000000000..e357818632c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DBM/Deep/.packlist
@@ -0,0 +1,8 @@
+C:\strawberry\perl\vendor\lib\DBM\Deep.pm
+C:\strawberry\perl\vendor\lib\DBM\Deep.pod
+C:\strawberry\perl\vendor\lib\DBM\Deep\Array.pm
+C:\strawberry\perl\vendor\lib\DBM\Deep\Cookbook.pod
+C:\strawberry\perl\vendor\lib\DBM\Deep\Engine.pm
+C:\strawberry\perl\vendor\lib\DBM\Deep\File.pm
+C:\strawberry\perl\vendor\lib\DBM\Deep\Hash.pm
+C:\strawberry\perl\vendor\lib\DBM\Deep\Internals.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DB_File/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/.packlist
new file mode 100755
index 00000000000..22a8ff47aba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\DB_File.pm
+C:\strawberry\perl\vendor\lib\auto\DB_File\DB_File.bs
+C:\strawberry\perl\vendor\lib\auto\DB_File\DB_File.dll
+C:\strawberry\perl\vendor\lib\auto\DB_File\autosplit.ix
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.bs b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.dll b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.dll
new file mode 100755
index 00000000000..4d8669c4861
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/DB_File.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DB_File/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/autosplit.ix
new file mode 100755
index 00000000000..caa08654e87
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DB_File/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\DB_File.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Data/Buffer/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Data/Buffer/.packlist
new file mode 100755
index 00000000000..d7ad4473176
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Data/Buffer/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Data\Buffer.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Data/Compare/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Data/Compare/.packlist
new file mode 100755
index 00000000000..a378e7d69bf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Data/Compare/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Data\Compare.pm
+C:\strawberry\perl\vendor\lib\Data\Compare\Plugins.pod
+C:\strawberry\perl\vendor\lib\Data\Compare\Plugins\Scalar\Properties.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/.packlist
new file mode 100755
index 00000000000..fdecd9a9d92
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\lib\Data\Dumper.pm
+C:\strawberry\perl\lib\auto\Data\Dumper\Dumper.bs
+C:\strawberry\perl\lib\auto\Data\Dumper\Dumper.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.bs b/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.dll b/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.dll
new file mode 100755
index 00000000000..4f566821c0c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Data/Dumper/Dumper.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Data/Random/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Data/Random/.packlist
new file mode 100755
index 00000000000..21945e52a6b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Data/Random/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Data\Random.pm
+C:\strawberry\perl\vendor\lib\Data\Random\WordList.pm
+C:\strawberry\perl\vendor\lib\Data\Random\dict
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Devel/DProf/DProf.dll b/Master/tlpkg/tlperl.straw/lib/auto/Devel/DProf/DProf.dll
new file mode 100755
index 00000000000..3ef80bf4d4c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Devel/DProf/DProf.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Devel/PPPort/PPPort.dll b/Master/tlpkg/tlperl.straw/lib/auto/Devel/PPPort/PPPort.dll
new file mode 100755
index 00000000000..9d533a2b064
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Devel/PPPort/PPPort.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Devel/Peek/Peek.dll b/Master/tlpkg/tlperl.straw/lib/auto/Devel/Peek/Peek.dll
new file mode 100755
index 00000000000..11b31869de2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Devel/Peek/Peek.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/BubbleBabble/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Digest/BubbleBabble/.packlist
new file mode 100755
index 00000000000..78a2d20fe82
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/BubbleBabble/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Digest\BubbleBabble.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/.packlist
new file mode 100755
index 00000000000..c6ed5aa837f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Digest\MD2.pm
+C:\strawberry\perl\vendor\lib\auto\Digest\MD2\MD2.bs
+C:\strawberry\perl\vendor\lib\auto\Digest\MD2\MD2.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.bs b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.dll b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.dll
new file mode 100755
index 00000000000..19c561e4d25
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD2/MD2.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD5/MD5.dll b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD5/MD5.dll
new file mode 100755
index 00000000000..b7192969cc4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/MD5/MD5.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/.packlist
new file mode 100755
index 00000000000..f1db4cae8da
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/.packlist
@@ -0,0 +1,5 @@
+C:\strawberry\perl\bin\shasum
+C:\strawberry\perl\bin\shasum.bat
+C:\strawberry\perl\lib\Digest\SHA.pm
+C:\strawberry\perl\lib\auto\Digest\SHA\SHA.bs
+C:\strawberry\perl\lib\auto\Digest\SHA\SHA.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.bs b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.dll b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.dll
new file mode 100755
index 00000000000..0763104384a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA/SHA.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/.packlist
new file mode 100755
index 00000000000..4d4a0049a22
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Digest\SHA1.pm
+C:\strawberry\perl\vendor\lib\auto\Digest\SHA1\SHA1.bs
+C:\strawberry\perl\vendor\lib\auto\Digest\SHA1\SHA1.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.bs b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.dll b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.dll
new file mode 100755
index 00000000000..09a65381987
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Digest/SHA1/SHA1.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/autosplit.ix
new file mode 100755
index 00000000000..d7605efa074
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/autosplit.ix
@@ -0,0 +1,8 @@
+# Index created by AutoSplit for ../LIB\DynaLoader.pm
+# (file acts as timestamp)
+package DynaLoader;
+sub dl_findfile ;
+sub dl_expandspec ;
+sub dl_find_symbol_anywhere
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_expandspec.al b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_expandspec.al
new file mode 100755
index 00000000000..0c2e8215d10
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_expandspec.al
@@ -0,0 +1,31 @@
+# NOTE: Derived from ../LIB\DynaLoader.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package DynaLoader;
+
+#line 318 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_expandspec.al)"
+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;
+}
+
+# end of DynaLoader::dl_expandspec
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_find_symbol_anywhere.al b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_find_symbol_anywhere.al
new file mode 100755
index 00000000000..fb182a01ed0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_find_symbol_anywhere.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ../LIB\DynaLoader.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package DynaLoader;
+
+#line 341 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_find_symbol_anywhere.al)"
+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;
+}
+
+1;
+# end of DynaLoader::dl_find_symbol_anywhere
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_findfile.al b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_findfile.al
new file mode 100755
index 00000000000..3f7dfadaf83
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/DynaLoader/dl_findfile.al
@@ -0,0 +1,86 @@
+# NOTE: Derived from ../LIB\DynaLoader.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package DynaLoader;
+
+#line 239 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_findfile.al)"
+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;
+}
+
+# end of DynaLoader::dl_findfile
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Encode/.packlist
new file mode 100755
index 00000000000..364afe9cac4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/.packlist
@@ -0,0 +1,56 @@
+C:\strawberry\perl\bin\enc2xs
+C:\strawberry\perl\bin\enc2xs.bat
+C:\strawberry\perl\bin\piconv
+C:\strawberry\perl\bin\piconv.bat
+C:\strawberry\perl\lib\Encode.pm
+C:\strawberry\perl\lib\Encode\Alias.pm
+C:\strawberry\perl\lib\Encode\Byte.pm
+C:\strawberry\perl\lib\Encode\CJKConstants.pm
+C:\strawberry\perl\lib\Encode\CN.pm
+C:\strawberry\perl\lib\Encode\CN\HZ.pm
+C:\strawberry\perl\lib\Encode\Changes.e2x
+C:\strawberry\perl\lib\Encode\Config.pm
+C:\strawberry\perl\lib\Encode\ConfigLocal_PM.e2x
+C:\strawberry\perl\lib\Encode\EBCDIC.pm
+C:\strawberry\perl\lib\Encode\Encoder.pm
+C:\strawberry\perl\lib\Encode\Encoding.pm
+C:\strawberry\perl\lib\Encode\GSM0338.pm
+C:\strawberry\perl\lib\Encode\Guess.pm
+C:\strawberry\perl\lib\Encode\JP.pm
+C:\strawberry\perl\lib\Encode\JP\H2Z.pm
+C:\strawberry\perl\lib\Encode\JP\JIS7.pm
+C:\strawberry\perl\lib\Encode\KR.pm
+C:\strawberry\perl\lib\Encode\KR\2022_KR.pm
+C:\strawberry\perl\lib\Encode\MIME\Header.pm
+C:\strawberry\perl\lib\Encode\MIME\Header\ISO_2022_JP.pm
+C:\strawberry\perl\lib\Encode\MIME\Name.pm
+C:\strawberry\perl\lib\Encode\Makefile_PL.e2x
+C:\strawberry\perl\lib\Encode\PerlIO.pod
+C:\strawberry\perl\lib\Encode\README.e2x
+C:\strawberry\perl\lib\Encode\Supported.pod
+C:\strawberry\perl\lib\Encode\Symbol.pm
+C:\strawberry\perl\lib\Encode\TW.pm
+C:\strawberry\perl\lib\Encode\Unicode.pm
+C:\strawberry\perl\lib\Encode\Unicode\UTF7.pm
+C:\strawberry\perl\lib\Encode\_PM.e2x
+C:\strawberry\perl\lib\Encode\_T.e2x
+C:\strawberry\perl\lib\Encode\encode.h
+C:\strawberry\perl\lib\auto\Encode\Byte\Byte.bs
+C:\strawberry\perl\lib\auto\Encode\Byte\Byte.dll
+C:\strawberry\perl\lib\auto\Encode\CN\CN.bs
+C:\strawberry\perl\lib\auto\Encode\CN\CN.dll
+C:\strawberry\perl\lib\auto\Encode\EBCDIC\EBCDIC.bs
+C:\strawberry\perl\lib\auto\Encode\EBCDIC\EBCDIC.dll
+C:\strawberry\perl\lib\auto\Encode\Encode.bs
+C:\strawberry\perl\lib\auto\Encode\Encode.dll
+C:\strawberry\perl\lib\auto\Encode\JP\JP.bs
+C:\strawberry\perl\lib\auto\Encode\JP\JP.dll
+C:\strawberry\perl\lib\auto\Encode\KR\KR.bs
+C:\strawberry\perl\lib\auto\Encode\KR\KR.dll
+C:\strawberry\perl\lib\auto\Encode\Symbol\Symbol.bs
+C:\strawberry\perl\lib\auto\Encode\Symbol\Symbol.dll
+C:\strawberry\perl\lib\auto\Encode\TW\TW.bs
+C:\strawberry\perl\lib\auto\Encode\TW\TW.dll
+C:\strawberry\perl\lib\auto\Encode\Unicode\Unicode.bs
+C:\strawberry\perl\lib\auto\Encode\Unicode\Unicode.dll
+C:\strawberry\perl\lib\encoding.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.dll
new file mode 100755
index 00000000000..f16bacb9a28
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Byte/Byte.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.dll
new file mode 100755
index 00000000000..e0ae27afb21
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/CN/CN.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.dll
new file mode 100755
index 00000000000..31b79626541
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/EBCDIC/EBCDIC.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Encode.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Encode.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Encode.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Encode.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Encode.dll
new file mode 100755
index 00000000000..5c2ffbf7b43
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Encode.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.dll
new file mode 100755
index 00000000000..e21bdcc9682
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/JP/JP.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.dll
new file mode 100755
index 00000000000..57f19225d3e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/KR/KR.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.dll
new file mode 100755
index 00000000000..2b45c4b46f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Symbol/Symbol.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.dll
new file mode 100755
index 00000000000..dcae5090e3a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/TW/TW.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.bs b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.dll b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.dll
new file mode 100755
index 00000000000..68aaf072c99
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Encode/Unicode/Unicode.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/CBuilder/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/CBuilder/.packlist
new file mode 100755
index 00000000000..892a0b233f1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/CBuilder/.packlist
@@ -0,0 +1,13 @@
+C:\strawberry\perl\lib\ExtUtils\CBuilder.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Base.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\Unix.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\VMS.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\Windows.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\Windows\BCC.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\Windows\GCC.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\Windows\MSVC.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\aix.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\cygwin.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\darwin.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\dec_osf.pm
+C:\strawberry\perl\lib\ExtUtils\CBuilder\Platform\os2.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/MakeMaker/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/MakeMaker/.packlist
new file mode 100755
index 00000000000..3fb8f839151
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/MakeMaker/.packlist
@@ -0,0 +1,30 @@
+C:\strawberry\perl\bin\instmodsh
+C:\strawberry\perl\bin\instmodsh.bat
+C:\strawberry\perl\lib\ExtUtils\Command\MM.pm
+C:\strawberry\perl\lib\ExtUtils\Liblist.pm
+C:\strawberry\perl\lib\ExtUtils\Liblist\Kid.pm
+C:\strawberry\perl\lib\ExtUtils\MM.pm
+C:\strawberry\perl\lib\ExtUtils\MM_AIX.pm
+C:\strawberry\perl\lib\ExtUtils\MM_Any.pm
+C:\strawberry\perl\lib\ExtUtils\MM_BeOS.pm
+C:\strawberry\perl\lib\ExtUtils\MM_Cygwin.pm
+C:\strawberry\perl\lib\ExtUtils\MM_DOS.pm
+C:\strawberry\perl\lib\ExtUtils\MM_Darwin.pm
+C:\strawberry\perl\lib\ExtUtils\MM_MacOS.pm
+C:\strawberry\perl\lib\ExtUtils\MM_NW5.pm
+C:\strawberry\perl\lib\ExtUtils\MM_OS2.pm
+C:\strawberry\perl\lib\ExtUtils\MM_QNX.pm
+C:\strawberry\perl\lib\ExtUtils\MM_UWIN.pm
+C:\strawberry\perl\lib\ExtUtils\MM_Unix.pm
+C:\strawberry\perl\lib\ExtUtils\MM_VMS.pm
+C:\strawberry\perl\lib\ExtUtils\MM_VOS.pm
+C:\strawberry\perl\lib\ExtUtils\MM_Win32.pm
+C:\strawberry\perl\lib\ExtUtils\MM_Win95.pm
+C:\strawberry\perl\lib\ExtUtils\MY.pm
+C:\strawberry\perl\lib\ExtUtils\MakeMaker.pm
+C:\strawberry\perl\lib\ExtUtils\MakeMaker\Config.pm
+C:\strawberry\perl\lib\ExtUtils\MakeMaker\FAQ.pod
+C:\strawberry\perl\lib\ExtUtils\MakeMaker\Tutorial.pod
+C:\strawberry\perl\lib\ExtUtils\Mkbootstrap.pm
+C:\strawberry\perl\lib\ExtUtils\Mksymlists.pm
+C:\strawberry\perl\lib\ExtUtils\testlib.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/Manifest/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/Manifest/.packlist
new file mode 100755
index 00000000000..a7e4d59a97d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/Manifest/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\lib\ExtUtils\MANIFEST.SKIP
+C:\strawberry\perl\lib\ExtUtils\Manifest.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/ParseXS/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/ParseXS/.packlist
new file mode 100755
index 00000000000..2b62f1cd0d3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/ExtUtils/ParseXS/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\ExtUtils\ParseXS.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/FCGI/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/FCGI/.packlist
new file mode 100755
index 00000000000..9c4d640c909
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/FCGI/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\FCGI.pm
+C:\strawberry\perl\vendor\lib\auto\FCGI\FCGI.bs
+C:\strawberry\perl\vendor\lib\auto\FCGI\FCGI.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.bs b/Master/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.dll b/Master/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.dll
new file mode 100755
index 00000000000..ca6e3172486
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/FCGI/FCGI.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Fcntl/Fcntl.dll b/Master/tlpkg/tlperl.straw/lib/auto/Fcntl/Fcntl.dll
new file mode 100755
index 00000000000..9d4d9e785b1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Fcntl/Fcntl.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/Fetch/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/Fetch/.packlist
new file mode 100755
index 00000000000..4039d3ff87b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/Fetch/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\File\Fetch.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/Find/Rule/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/Find/Rule/.packlist
new file mode 100755
index 00000000000..1ae447043d0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/Find/Rule/.packlist
@@ -0,0 +1,5 @@
+C:\strawberry\perl\bin\findrule
+C:\strawberry\perl\bin\findrule.bat
+C:\strawberry\perl\vendor\lib\File\Find\Rule.pm
+C:\strawberry\perl\vendor\lib\File\Find\Rule\Extending.pod
+C:\strawberry\perl\vendor\lib\File\Find\Rule\Procedural.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/Glob/Glob.dll b/Master/tlpkg/tlperl.straw/lib/auto/File/Glob/Glob.dll
new file mode 100755
index 00000000000..6dd181ca97e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/Glob/Glob.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/HomeDir/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/HomeDir/.packlist
new file mode 100755
index 00000000000..a14b901ef7a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/HomeDir/.packlist
@@ -0,0 +1,8 @@
+C:\strawberry\perl\vendor\lib\File\HomeDir.pm
+C:\strawberry\perl\vendor\lib\File\HomeDir\Darwin.pm
+C:\strawberry\perl\vendor\lib\File\HomeDir\Darwin\Carbon.pm
+C:\strawberry\perl\vendor\lib\File\HomeDir\Darwin\Cocoa.pm
+C:\strawberry\perl\vendor\lib\File\HomeDir\Driver.pm
+C:\strawberry\perl\vendor\lib\File\HomeDir\MacOS9.pm
+C:\strawberry\perl\vendor\lib\File\HomeDir\Unix.pm
+C:\strawberry\perl\vendor\lib\File\HomeDir\Windows.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/Path/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/Path/.packlist
new file mode 100755
index 00000000000..edda80ae65b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/Path/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\File\Path.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/Remove/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/Remove/.packlist
new file mode 100755
index 00000000000..12df10cc0fa
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/Remove/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\File\Remove.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/Which/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/Which/.packlist
new file mode 100755
index 00000000000..9fb782b7ad3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/Which/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\pwhich
+C:\strawberry\perl\bin\pwhich.bat
+C:\strawberry\perl\vendor\lib\File\Which.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/chmod/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/chmod/.packlist
new file mode 100755
index 00000000000..3871660f580
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/chmod/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\File\chmod.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/File/pushd/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/File/pushd/.packlist
new file mode 100755
index 00000000000..648f4304324
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/File/pushd/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\File\pushd.pm
+C:\strawberry\perl\vendor\lib\File\pushd.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Filter/Util/Call/Call.dll b/Master/tlpkg/tlperl.straw/lib/auto/Filter/Util/Call/Call.dll
new file mode 100755
index 00000000000..7079cd5bb97
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Filter/Util/Call/Call.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/GD/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/GD/.packlist
new file mode 100755
index 00000000000..642823ec17e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/GD/.packlist
@@ -0,0 +1,12 @@
+C:\strawberry\perl\bin\bdf2gdfont.bat
+C:\strawberry\perl\bin\bdf2gdfont.pl
+C:\strawberry\perl\vendor\lib\GD.pm
+C:\strawberry\perl\vendor\lib\GD\Group.pm
+C:\strawberry\perl\vendor\lib\GD\Image.pm
+C:\strawberry\perl\vendor\lib\GD\Polygon.pm
+C:\strawberry\perl\vendor\lib\GD\Polyline.pm
+C:\strawberry\perl\vendor\lib\GD\Simple.pm
+C:\strawberry\perl\vendor\lib\auto\GD\GD.bs
+C:\strawberry\perl\vendor\lib\auto\GD\GD.dll
+C:\strawberry\perl\vendor\lib\auto\GD\autosplit.ix
+C:\strawberry\perl\vendor\lib\qd.pl
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/GD/GD.bs b/Master/tlpkg/tlperl.straw/lib/auto/GD/GD.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/GD/GD.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/GD/GD.dll b/Master/tlpkg/tlperl.straw/lib/auto/GD/GD.dll
new file mode 100755
index 00000000000..ca97a739e47
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/GD/GD.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/GD/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/GD/autosplit.ix
new file mode 100755
index 00000000000..08d99792e77
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/GD/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib/GD.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/GDBM_File/GDBM_File.dll b/Master/tlpkg/tlperl.straw/lib/auto/GDBM_File/GDBM_File.dll
new file mode 100755
index 00000000000..a9f16e7e42c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/GDBM_File/GDBM_File.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/.packlist
new file mode 100755
index 00000000000..f218529c9dd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/.packlist
@@ -0,0 +1,9 @@
+C:\strawberry\perl\vendor\lib\HTML\Entities.pm
+C:\strawberry\perl\vendor\lib\HTML\Filter.pm
+C:\strawberry\perl\vendor\lib\HTML\HeadParser.pm
+C:\strawberry\perl\vendor\lib\HTML\LinkExtor.pm
+C:\strawberry\perl\vendor\lib\HTML\Parser.pm
+C:\strawberry\perl\vendor\lib\HTML\PullParser.pm
+C:\strawberry\perl\vendor\lib\HTML\TokeParser.pm
+C:\strawberry\perl\vendor\lib\auto\HTML\Parser\Parser.bs
+C:\strawberry\perl\vendor\lib\auto\HTML\Parser\Parser.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.bs b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.dll b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.dll
new file mode 100755
index 00000000000..98a83952fba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Parser/Parser.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/HTML/Tagset/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Tagset/.packlist
new file mode 100755
index 00000000000..04801efd792
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/HTML/Tagset/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\HTML\Tagset.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Hash/Util/FieldHash/FieldHash.dll b/Master/tlpkg/tlperl.straw/lib/auto/Hash/Util/FieldHash/FieldHash.dll
new file mode 100755
index 00000000000..b83cb307dde
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Hash/Util/FieldHash/FieldHash.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Hash/Util/Util.dll b/Master/tlpkg/tlperl.straw/lib/auto/Hash/Util/Util.dll
new file mode 100755
index 00000000000..46beb4cf7a1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Hash/Util/Util.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/IO/IO.dll b/Master/tlpkg/tlperl.straw/lib/auto/IO/IO.dll
new file mode 100755
index 00000000000..0b6d35fe014
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/IO/IO.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/IO/Socket/SSL/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/IO/Socket/SSL/.packlist
new file mode 100755
index 00000000000..b0e8826ad86
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/IO/Socket/SSL/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\IO\Socket\SSL.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/IO/String/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/IO/String/.packlist
new file mode 100755
index 00000000000..b80eb617ad4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/IO/String/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\IO\String.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/IO/Zlib/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/IO/Zlib/.packlist
new file mode 100755
index 00000000000..e007f0eca0f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/IO/Zlib/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\IO\Zlib.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/IPC/Cmd/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/IPC/Cmd/.packlist
new file mode 100755
index 00000000000..2ffd1d07115
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/IPC/Cmd/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\IPC\Cmd.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/IPC/Run3/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/IPC/Run3/.packlist
new file mode 100755
index 00000000000..d290e8fdc65
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/IPC/Run3/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\vendor\lib\IPC\Run3.pm
+C:\strawberry\perl\vendor\lib\IPC\Run3\ProfArrayBuffer.pm
+C:\strawberry\perl\vendor\lib\IPC\Run3\ProfLogReader.pm
+C:\strawberry\perl\vendor\lib\IPC\Run3\ProfLogger.pm
+C:\strawberry\perl\vendor\lib\IPC\Run3\ProfPP.pm
+C:\strawberry\perl\vendor\lib\IPC\Run3\ProfReporter.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/IPC/System/Simple/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/IPC/System/Simple/.packlist
new file mode 100755
index 00000000000..82cd6c6a7e3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/IPC/System/Simple/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\IPC\System\Simple.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Imager/.packlist
new file mode 100755
index 00000000000..29233b3960c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/.packlist
@@ -0,0 +1,84 @@
+C:\strawberry\perl\vendor\lib\Imager.pm
+C:\strawberry\perl\vendor\lib\Imager\API.pod
+C:\strawberry\perl\vendor\lib\Imager\APIRef.pod
+C:\strawberry\perl\vendor\lib\Imager\Color.pm
+C:\strawberry\perl\vendor\lib\Imager\Color\Float.pm
+C:\strawberry\perl\vendor\lib\Imager\Color\Table.pm
+C:\strawberry\perl\vendor\lib\Imager\Cookbook.pod
+C:\strawberry\perl\vendor\lib\Imager\CountColor.pm
+C:\strawberry\perl\vendor\lib\Imager\Draw.pod
+C:\strawberry\perl\vendor\lib\Imager\Engines.pod
+C:\strawberry\perl\vendor\lib\Imager\Expr.pm
+C:\strawberry\perl\vendor\lib\Imager\Expr\Assem.pm
+C:\strawberry\perl\vendor\lib\Imager\ExtUtils.pm
+C:\strawberry\perl\vendor\lib\Imager\File\CUR.pm
+C:\strawberry\perl\vendor\lib\Imager\File\ICO.pm
+C:\strawberry\perl\vendor\lib\Imager\File\SGI.pm
+C:\strawberry\perl\vendor\lib\Imager\Files.pod
+C:\strawberry\perl\vendor\lib\Imager\Fill.pm
+C:\strawberry\perl\vendor\lib\Imager\Filter\DynTest.pm
+C:\strawberry\perl\vendor\lib\Imager\Filter\Flines.pm
+C:\strawberry\perl\vendor\lib\Imager\Filter\Mandelbrot.pm
+C:\strawberry\perl\vendor\lib\Imager\Filters.pod
+C:\strawberry\perl\vendor\lib\Imager\Font.pm
+C:\strawberry\perl\vendor\lib\Imager\Font\BBox.pm
+C:\strawberry\perl\vendor\lib\Imager\Font\FreeType2.pm
+C:\strawberry\perl\vendor\lib\Imager\Font\Image.pm
+C:\strawberry\perl\vendor\lib\Imager\Font\Truetype.pm
+C:\strawberry\perl\vendor\lib\Imager\Font\Type1.pm
+C:\strawberry\perl\vendor\lib\Imager\Font\Win32.pm
+C:\strawberry\perl\vendor\lib\Imager\Font\Wrap.pm
+C:\strawberry\perl\vendor\lib\Imager\Fountain.pm
+C:\strawberry\perl\vendor\lib\Imager\Handy.pod
+C:\strawberry\perl\vendor\lib\Imager\ImageTypes.pod
+C:\strawberry\perl\vendor\lib\Imager\Inline.pod
+C:\strawberry\perl\vendor\lib\Imager\LargeSamples.pod
+C:\strawberry\perl\vendor\lib\Imager\Matrix2d.pm
+C:\strawberry\perl\vendor\lib\Imager\Preprocess.pm
+C:\strawberry\perl\vendor\lib\Imager\Regops.pm
+C:\strawberry\perl\vendor\lib\Imager\Test.pm
+C:\strawberry\perl\vendor\lib\Imager\Transform.pm
+C:\strawberry\perl\vendor\lib\Imager\Transformations.pod
+C:\strawberry\perl\vendor\lib\Imager\Tutorial.pod
+C:\strawberry\perl\vendor\lib\Imager\include\draw.h
+C:\strawberry\perl\vendor\lib\Imager\include\dynaload.h
+C:\strawberry\perl\vendor\lib\Imager\include\ext.h
+C:\strawberry\perl\vendor\lib\Imager\include\feat.h
+C:\strawberry\perl\vendor\lib\Imager\include\imager.h
+C:\strawberry\perl\vendor\lib\Imager\include\imageri.h
+C:\strawberry\perl\vendor\lib\Imager\include\imconfig.h
+C:\strawberry\perl\vendor\lib\Imager\include\imdatatypes.h
+C:\strawberry\perl\vendor\lib\Imager\include\imerror.h
+C:\strawberry\perl\vendor\lib\Imager\include\imexif.h
+C:\strawberry\perl\vendor\lib\Imager\include\imext.h
+C:\strawberry\perl\vendor\lib\Imager\include\imextdef.h
+C:\strawberry\perl\vendor\lib\Imager\include\imexttypes.h
+C:\strawberry\perl\vendor\lib\Imager\include\imio.h
+C:\strawberry\perl\vendor\lib\Imager\include\immacros.h
+C:\strawberry\perl\vendor\lib\Imager\include\imperl.h
+C:\strawberry\perl\vendor\lib\Imager\include\imrender.h
+C:\strawberry\perl\vendor\lib\Imager\include\iolayer.h
+C:\strawberry\perl\vendor\lib\Imager\include\iolayert.h
+C:\strawberry\perl\vendor\lib\Imager\include\log.h
+C:\strawberry\perl\vendor\lib\Imager\include\plug.h
+C:\strawberry\perl\vendor\lib\Imager\include\ppport.h
+C:\strawberry\perl\vendor\lib\Imager\include\regmach.h
+C:\strawberry\perl\vendor\lib\Imager\include\rendert.h
+C:\strawberry\perl\vendor\lib\Imager\include\stackmach.h
+C:\strawberry\perl\vendor\lib\Imager\interface.pod
+C:\strawberry\perl\vendor\lib\Imager\regmach.pod
+C:\strawberry\perl\vendor\lib\Imager\typemap
+C:\strawberry\perl\vendor\lib\auto\Imager\CountColor\CountColor.bs
+C:\strawberry\perl\vendor\lib\auto\Imager\CountColor\CountColor.dll
+C:\strawberry\perl\vendor\lib\auto\Imager\File\ICO\ICO.bs
+C:\strawberry\perl\vendor\lib\auto\Imager\File\ICO\ICO.dll
+C:\strawberry\perl\vendor\lib\auto\Imager\File\SGI\SGI.bs
+C:\strawberry\perl\vendor\lib\auto\Imager\File\SGI\SGI.dll
+C:\strawberry\perl\vendor\lib\auto\Imager\Filter\DynTest\DynTest.bs
+C:\strawberry\perl\vendor\lib\auto\Imager\Filter\DynTest\DynTest.dll
+C:\strawberry\perl\vendor\lib\auto\Imager\Filter\Flines\Flines.bs
+C:\strawberry\perl\vendor\lib\auto\Imager\Filter\Flines\Flines.dll
+C:\strawberry\perl\vendor\lib\auto\Imager\Filter\Mandelbrot\Mandelbrot.bs
+C:\strawberry\perl\vendor\lib\auto\Imager\Filter\Mandelbrot\Mandelbrot.dll
+C:\strawberry\perl\vendor\lib\auto\Imager\Imager.bs
+C:\strawberry\perl\vendor\lib\auto\Imager\Imager.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.bs b/Master/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.dll b/Master/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.dll
new file mode 100755
index 00000000000..5129ae4d921
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/CountColor/CountColor.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.bs b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.dll b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.dll
new file mode 100755
index 00000000000..5c577825c8c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/ICO/ICO.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.bs b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.dll b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.dll
new file mode 100755
index 00000000000..80139c02021
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/File/SGI/SGI.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.bs b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.dll b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.dll
new file mode 100755
index 00000000000..a4cbfc2f722
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/DynTest/DynTest.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.bs b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.dll b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.dll
new file mode 100755
index 00000000000..095ea83fb2f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Flines/Flines.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.bs b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.dll b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.dll
new file mode 100755
index 00000000000..e7ea0ab0674
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Filter/Mandelbrot/Mandelbrot.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Imager.bs b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Imager.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Imager.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Imager/Imager.dll b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Imager.dll
new file mode 100755
index 00000000000..3a310ea85e6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Imager/Imager.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/JSON/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/JSON/.packlist
new file mode 100755
index 00000000000..ef52c6a14d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/JSON/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\vendor\lib\JSON.pm
+C:\strawberry\perl\vendor\lib\JSON\PP.pm
+C:\strawberry\perl\vendor\lib\JSON\PP5005.pm
+C:\strawberry\perl\vendor\lib\JSON\PP56.pm
+C:\strawberry\perl\vendor\lib\JSON\PP58.pm
+C:\strawberry\perl\vendor\lib\JSON\PP\Boolean.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/.packlist
new file mode 100755
index 00000000000..4ea0033edf5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\bin\json_xs
+C:\strawberry\perl\bin\json_xs.bat
+C:\strawberry\perl\vendor\lib\JSON\XS.pm
+C:\strawberry\perl\vendor\lib\JSON\XS\Boolean.pm
+C:\strawberry\perl\vendor\lib\auto\JSON\XS\XS.bs
+C:\strawberry\perl\vendor\lib\auto\JSON\XS\XS.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.bs b/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.dll b/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.dll
new file mode 100755
index 00000000000..02267b611ae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/JSON/XS/XS.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/LWP/Online/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/LWP/Online/.packlist
new file mode 100755
index 00000000000..3ff84267d10
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/LWP/Online/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\LWP\Online.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/List/Util/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/List/Util/.packlist
new file mode 100755
index 00000000000..710ca31fa4d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/List/Util/.packlist
@@ -0,0 +1,7 @@
+C:\strawberry\perl\lib\List\Util.pm
+C:\strawberry\perl\lib\List\Util\PP.pm
+C:\strawberry\perl\lib\List\Util\XS.pm
+C:\strawberry\perl\lib\Scalar\Util.pm
+C:\strawberry\perl\lib\Scalar\Util\PP.pm
+C:\strawberry\perl\lib\auto\List\Util\Util.bs
+C:\strawberry\perl\lib\auto\List\Util\Util.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/List/Util/Util.bs b/Master/tlpkg/tlperl.straw/lib/auto/List/Util/Util.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/List/Util/Util.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/List/Util/Util.dll b/Master/tlpkg/tlperl.straw/lib/auto/List/Util/Util.dll
new file mode 100755
index 00000000000..01df21ded10
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/List/Util/Util.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Locale/Maketext/Simple/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Locale/Maketext/Simple/.packlist
new file mode 100755
index 00000000000..56e8d678d4e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Locale/Maketext/Simple/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Locale\Maketext\Simple.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Log/Message/Simple/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Log/Message/Simple/.packlist
new file mode 100755
index 00000000000..1d69e2603af
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Log/Message/Simple/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Log\Message\Simple.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/.packlist
new file mode 100755
index 00000000000..280ffc09659
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\lib\MIME\Base64.pm
+C:\strawberry\perl\lib\MIME\QuotedPrint.pm
+C:\strawberry\perl\lib\auto\MIME\Base64\Base64.bs
+C:\strawberry\perl\lib\auto\MIME\Base64\Base64.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.bs b/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.dll b/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.dll
new file mode 100755
index 00000000000..8393983bf01
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/MIME/Base64/Base64.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/FastCalc/FastCalc.dll b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/FastCalc/FastCalc.dll
new file mode 100755
index 00000000000..3063a91466c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/FastCalc/FastCalc.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/.packlist
new file mode 100755
index 00000000000..75f8164a903
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Math\BigInt\GMP.pm
+C:\strawberry\perl\vendor\lib\auto\Math\BigInt\GMP\GMP.bs
+C:\strawberry\perl\vendor\lib\auto\Math\BigInt\GMP\GMP.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.bs b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.dll b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.dll
new file mode 100755
index 00000000000..16db58f1356
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigInt/GMP/GMP.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/BigRat/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigRat/.packlist
new file mode 100755
index 00000000000..82747a6b502
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/BigRat/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Math\BigRat.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/.packlist
new file mode 100755
index 00000000000..f7cd2597c5c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\Math\GMP.pm
+C:\strawberry\perl\vendor\lib\auto\Math\GMP\GMP.bs
+C:\strawberry\perl\vendor\lib\auto\Math\GMP\GMP.dll
+C:\strawberry\perl\vendor\lib\auto\Math\GMP\autosplit.ix
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.bs b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.dll b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.dll
new file mode 100755
index 00000000000..da8ef9d1ae2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/GMP.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/autosplit.ix
new file mode 100755
index 00000000000..c109cc69d26
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/GMP/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Math\GMP.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/.packlist
new file mode 100755
index 00000000000..9f9494114d0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\vendor\lib\Math\Pari.pm
+C:\strawberry\perl\vendor\lib\Math\PariInit.pm
+C:\strawberry\perl\vendor\lib\Math\libPARI.dumb.pod
+C:\strawberry\perl\vendor\lib\Math\libPARI.pod
+C:\strawberry\perl\vendor\lib\auto\Math\Pari\Pari.bs
+C:\strawberry\perl\vendor\lib\auto\Math\Pari\Pari.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.bs b/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.dll b/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.dll
new file mode 100755
index 00000000000..604d4d5be93
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Math/Pari/Pari.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Module/Build/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Module/Build/.packlist
new file mode 100755
index 00000000000..b28356dc56a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Module/Build/.packlist
@@ -0,0 +1,34 @@
+C:\strawberry\perl\bin\config_data
+C:\strawberry\perl\bin\config_data.bat
+C:\strawberry\perl\lib\Module\Build.pm
+C:\strawberry\perl\lib\Module\Build\API.pod
+C:\strawberry\perl\lib\Module\Build\Authoring.pod
+C:\strawberry\perl\lib\Module\Build\Base.pm
+C:\strawberry\perl\lib\Module\Build\Bundling.pod
+C:\strawberry\perl\lib\Module\Build\Compat.pm
+C:\strawberry\perl\lib\Module\Build\Config.pm
+C:\strawberry\perl\lib\Module\Build\ConfigData.pm
+C:\strawberry\perl\lib\Module\Build\Cookbook.pm
+C:\strawberry\perl\lib\Module\Build\Dumper.pm
+C:\strawberry\perl\lib\Module\Build\ModuleInfo.pm
+C:\strawberry\perl\lib\Module\Build\Notes.pm
+C:\strawberry\perl\lib\Module\Build\PPMMaker.pm
+C:\strawberry\perl\lib\Module\Build\Platform\Amiga.pm
+C:\strawberry\perl\lib\Module\Build\Platform\Default.pm
+C:\strawberry\perl\lib\Module\Build\Platform\EBCDIC.pm
+C:\strawberry\perl\lib\Module\Build\Platform\MPEiX.pm
+C:\strawberry\perl\lib\Module\Build\Platform\MacOS.pm
+C:\strawberry\perl\lib\Module\Build\Platform\RiscOS.pm
+C:\strawberry\perl\lib\Module\Build\Platform\Unix.pm
+C:\strawberry\perl\lib\Module\Build\Platform\VMS.pm
+C:\strawberry\perl\lib\Module\Build\Platform\VOS.pm
+C:\strawberry\perl\lib\Module\Build\Platform\Windows.pm
+C:\strawberry\perl\lib\Module\Build\Platform\aix.pm
+C:\strawberry\perl\lib\Module\Build\Platform\cygwin.pm
+C:\strawberry\perl\lib\Module\Build\Platform\darwin.pm
+C:\strawberry\perl\lib\Module\Build\Platform\os2.pm
+C:\strawberry\perl\lib\Module\Build\PodParser.pm
+C:\strawberry\perl\lib\Module\Build\Version.pm
+C:\strawberry\perl\lib\Module\Build\YAML.pm
+C:\strawberry\perl\lib\inc\latest.pm
+C:\strawberry\perl\lib\inc\latest\private.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Module/CoreList/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Module/CoreList/.packlist
new file mode 100755
index 00000000000..1b2d6491ee6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Module/CoreList/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\corelist
+C:\strawberry\perl\bin\corelist.bat
+C:\strawberry\perl\lib\Module\CoreList.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Module/Load/Conditional/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Module/Load/Conditional/.packlist
new file mode 100755
index 00000000000..f8ff2029b01
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Module/Load/Conditional/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Module\Load\Conditional.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Module/Loaded/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Module/Loaded/.packlist
new file mode 100755
index 00000000000..8d2a6bd5cf4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Module/Loaded/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Module\Loaded.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Module/Signature/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Module/Signature/.packlist
new file mode 100755
index 00000000000..8d29426f2b1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Module/Signature/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\cpansign
+C:\strawberry\perl\bin\cpansign.bat
+C:\strawberry\perl\vendor\lib\Module\Signature.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SMTP/TLS/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Net/SMTP/TLS/.packlist
new file mode 100755
index 00000000000..13dcecdb913
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SMTP/TLS/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Net\SMTP\TLS.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/.packlist
new file mode 100755
index 00000000000..9e3886a79cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/.packlist
@@ -0,0 +1,79 @@
+C:\strawberry\perl\vendor\lib\Net\SSLeay.pm
+C:\strawberry\perl\vendor\lib\Net\SSLeay\Handle.pm
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\SSLeay.bs
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\SSLeay.dll
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\autosplit.ix
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\debug_read.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\do_https.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\do_https2.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\do_https3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\do_https4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\do_httpx2.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\do_httpx3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\do_httpx4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\dump_peer_certificate.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_http.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_http3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_http4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_https.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_https3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_https4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_httpx.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_httpx3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\get_httpx4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_http.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_http3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_http4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_https.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_https3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_https4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_httpx.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_httpx3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\head_httpx4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\http_cat.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\https_cat.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\httpx_cat.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\make_form.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\make_headers.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\new_x_ctx.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\open_proxy_tcp_connection.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\open_tcp_connection.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_http.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_http3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_http4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_https.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_https3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_https4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_httpx.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_httpx3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\post_httpx4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_http.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_http3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_http4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_https.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_https3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_https4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_httpx.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_httpx3.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\put_httpx4.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\randomize.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\set_cert_and_key.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\set_proxy.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\set_server_cert_and_key.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\ssl_read_CRLF.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\ssl_read_all.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\ssl_read_until.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\ssl_write_CRLF.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\ssl_write_all.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\sslcat.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\tcp_read_CRLF.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\tcp_read_all.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\tcp_read_until.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\tcp_write_CRLF.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\tcp_write_all.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\tcpcat.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\tcpxcat.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\want_X509_lookup.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\want_nothing.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\want_read.al
+C:\strawberry\perl\vendor\lib\auto\Net\SSLeay\want_write.al
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.bs b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.dll b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.dll
new file mode 100755
index 00000000000..61c88241073
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/SSLeay.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/autosplit.ix
new file mode 100755
index 00000000000..48af6553b06
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/autosplit.ix
@@ -0,0 +1,78 @@
+# Index created by AutoSplit for blib\lib\Net\SSLeay.pm
+# (file acts as timestamp)
+package Net::SSLeay;
+sub want_nothing ;
+sub want_read ;
+sub want_write ;
+sub want_X509_lookup ;
+sub open_tcp_connection ;
+sub open_proxy_tcp_connection ;
+sub debug_read ;
+sub ssl_read_all ;
+sub tcp_read_all ;
+sub ssl_write_all ;
+sub tcp_write_all ;
+sub ssl_read_until ($;$$);
+sub tcp_read_until ;
+sub ssl_read_CRLF ($;$);
+sub tcp_read_CRLF ;
+sub ssl_write_CRLF ($$);
+sub tcp_write_CRLF ;
+sub dump_peer_certificate ($);
+sub randomize (;$$);
+sub new_x_ctx ;
+sub sslcat ;
+sub tcpcat ;
+sub tcpxcat ;
+sub https_cat ;
+sub http_cat ;
+sub httpx_cat ;
+sub set_cert_and_key ($$$);
+sub set_server_cert_and_key ($$$);
+sub set_proxy ($$;**);
+sub make_form ;
+sub make_headers ;
+sub do_httpx3 ;
+sub do_https3 ;
+sub do_httpx2 ;
+sub do_https2 ;
+sub do_httpx4 ;
+sub do_https4 ;
+sub get_https ;
+sub post_https ;
+sub put_https ;
+sub head_https ;
+sub get_https3 ;
+sub post_https3 ;
+sub put_https3 ;
+sub head_https3 ;
+sub get_https4 ;
+sub post_https4 ;
+sub put_https4 ;
+sub head_https4 ;
+sub get_http ;
+sub post_http ;
+sub put_http ;
+sub head_http ;
+sub get_http3 ;
+sub post_http3 ;
+sub put_http3 ;
+sub head_http3 ;
+sub get_http4 ;
+sub post_http4 ;
+sub put_http4 ;
+sub head_http4 ;
+sub get_httpx ;
+sub post_httpx ;
+sub put_httpx ;
+sub head_httpx ;
+sub get_httpx3 ;
+sub post_httpx3 ;
+sub put_httpx3 ;
+sub head_httpx3 ;
+sub get_httpx4 ;
+sub post_httpx4 ;
+sub put_httpx4 ;
+sub head_httpx4 ;
+sub do_https ;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/debug_read.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/debug_read.al
new file mode 100755
index 00000000000..b9a2a73fa9f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/debug_read.al
@@ -0,0 +1,22 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1856 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\debug_read.al)"
+###
+### read and write helpers that block
+###
+
+sub debug_read {
+ my ($replyr, $gotr) = @_;
+ my $vm = $trace>2 && $linux_debug ?
+ (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
+ warn " got " . blength($$gotr) . ':'
+ . blength($$replyr) . " bytes (VM=$vm).\n" if $trace == 3;
+ warn " got `$$gotr' (" . blength($$gotr) . ':'
+ . blength($$replyr) . " bytes, VM=$vm)\n" if $trace>3;
+}
+
+# end of Net::SSLeay::debug_read
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https.al
new file mode 100755
index 00000000000..91a207be120
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2601 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\do_https.al)"
+sub do_https {
+ my ($site, $port, $path, $method, $headers,
+ $content, $mime_type, $crt_path, $key_path) = @_;
+
+ do_https2($method, $site, $port, $path, $headers,
+ $content, $mime_type, $crt_path, $key_path);
+}
+
+1;
+__END__
+1;
+# end of Net::SSLeay::do_https
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https2.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https2.al
new file mode 100755
index 00000000000..192e31a2948
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https2.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2529 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\do_https2.al)"
+sub do_https2 { splice(@_,1,0) = 1; do_httpx2; } # Legacy undocumented
+
+### Returns headers as a hash where multiple instances of same header
+### are handled correctly.
+
+# end of Net::SSLeay::do_https2
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https3.al
new file mode 100755
index 00000000000..c7dc9690d5a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https3.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2514 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\do_https3.al)"
+sub do_https3 { splice(@_,1,0) = 1; do_httpx3; } # Legacy undocumented
+
+### do_https2() is a legacy version in the sense that it is unable
+### to return all instances of duplicate headers.
+
+# end of Net::SSLeay::do_https3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https4.al
new file mode 100755
index 00000000000..55207adad59
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_https4.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2545 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\do_https4.al)"
+sub do_https4 { splice(@_,1,0) = 1; do_httpx4; } # Legacy undocumented
+
+# https
+
+# end of Net::SSLeay::do_https4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx2.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx2.al
new file mode 100755
index 00000000000..e94566d1db2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx2.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2519 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\do_httpx2.al)"
+sub do_httpx2 {
+ my ($page, $response, $headers, $server_cert) = &do_httpx3;
+ X509_free($server_cert) if defined $server_cert;
+ return ($page, $response,
+ map( { ($h,$v)=/^(\S+)\:\s*(.*)$/; (uc($h),$v); }
+ split(/\s?\n/, $headers)
+ )
+ );
+}
+
+# end of Net::SSLeay::do_httpx2
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx3.al
new file mode 100755
index 00000000000..af352036cdc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx3.al
@@ -0,0 +1,43 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2479 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\do_httpx3.al)"
+sub do_httpx3 {
+ my ($method, $usessl, $site, $port, $path, $headers,
+ $content, $mime_type, $crt_path, $key_path) = @_;
+ my ($response, $page, $h,$v);
+
+ if ($content) {
+ $mime_type = "application/x-www-form-urlencoded" unless $mime_type;
+ my $len = blength($content);
+ $content = "Content-Type: $mime_type$CRLF"
+ . "Content-Length: $len$CRLF$CRLF$content";
+ } else {
+ $content = "$CRLF$CRLF";
+ }
+ my $req = "$method $path HTTP/1.0$CRLF";
+ unless (defined $headers && $headers =~ /^Host:/m) {
+ $req .= "Host: $site";
+ unless (($port == 80 && !$usessl) || ($port == 443 && $usessl)) {
+ $req .= ":$port";
+ }
+ $req .= $CRLF;
+ }
+ $req .= (defined $headers ? $headers : '') . "Accept: */*$CRLF$content";
+
+ warn "do_httpx3($method,$usessl,$site:$port)" if $trace;
+ my ($http, $errs, $server_cert)
+ = httpx_cat($usessl, $site, $port, $req, $crt_path, $key_path);
+ return (undef, "HTTP/1.0 900 NET OR SSL ERROR$CRLF$CRLF$errs") if $errs;
+
+ $http = '' if !defined $http;
+ ($headers, $page) = split /\s?\n\s?\n/, $http, 2;
+ warn "headers >$headers< page >>$page<< http >>>$http<<<" if $trace>1;
+ ($response, $headers) = split /\s?\n/, $headers, 2;
+ return ($page, $response, $headers, $server_cert);
+}
+
+# end of Net::SSLeay::do_httpx3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx4.al
new file mode 100755
index 00000000000..c7666531579
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/do_httpx4.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2534 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\do_httpx4.al)"
+sub do_httpx4 {
+ my ($page, $response, $headers, $server_cert) = &do_httpx3;
+ X509_free($server_cert) if defined $server_cert;
+ my %hr = ();
+ for my $hh (split /\s?\n/, $headers) {
+ my ($h,$v)=/^(\S+)\:\s*(.*)$/;
+ push @{$hr{uc($h)}}, $v;
+ }
+ return ($page, $response, \%hr);
+}
+
+# end of Net::SSLeay::do_httpx4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/dump_peer_certificate.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/dump_peer_certificate.al
new file mode 100755
index 00000000000..b37a1eff84b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/dump_peer_certificate.al
@@ -0,0 +1,29 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2114 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\dump_peer_certificate.al)"
+### Quickly print out with whom we're talking
+
+sub dump_peer_certificate ($) {
+ my ($ssl) = @_;
+ my $cert = get_peer_certificate($ssl);
+ return if print_errs('get_peer_certificate');
+ print "no cert defined\n" if !defined($cert);
+ # Cipher=NONE with empty cert fix
+ if (!defined($cert) || ($cert == 0)) {
+ warn "cert = `$cert'\n" if $trace;
+ return "Subject Name: undefined\nIssuer Name: undefined\n";
+ } else {
+ my $x = 'Subject Name: '
+ . X509_NAME_oneline(X509_get_subject_name($cert)) . "\n"
+ . 'Issuer Name: '
+ . X509_NAME_oneline(X509_get_issuer_name($cert)) . "\n";
+ Net::SSLeay::X509_free($cert);
+ return $x;
+ }
+}
+
+# end of Net::SSLeay::dump_peer_certificate
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http.al
new file mode 100755
index 00000000000..91b6882b25a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2566 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_http.al)"
+sub get_http { do_httpx2(GET => 0, @_) }
+# end of Net::SSLeay::get_http
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http3.al
new file mode 100755
index 00000000000..2877134a5c1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2571 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_http3.al)"
+sub get_http3 { do_httpx3(GET => 0, @_) }
+# end of Net::SSLeay::get_http3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http4.al
new file mode 100755
index 00000000000..3b7aeb8bfb3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_http4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2576 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_http4.al)"
+sub get_http4 { do_httpx4(GET => 0, @_) }
+# end of Net::SSLeay::get_http4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https.al
new file mode 100755
index 00000000000..d66a0c1f181
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2549 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_https.al)"
+sub get_https { do_httpx2(GET => 1, @_) }
+# end of Net::SSLeay::get_https
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https3.al
new file mode 100755
index 00000000000..013d6591618
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2554 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_https3.al)"
+sub get_https3 { do_httpx3(GET => 1, @_) }
+# end of Net::SSLeay::get_https3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https4.al
new file mode 100755
index 00000000000..36448f196ee
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_https4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2559 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_https4.al)"
+sub get_https4 { do_httpx4(GET => 1, @_) }
+# end of Net::SSLeay::get_https4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx.al
new file mode 100755
index 00000000000..07a74658149
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2583 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_httpx.al)"
+sub get_httpx { do_httpx2(GET => @_) }
+# end of Net::SSLeay::get_httpx
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx3.al
new file mode 100755
index 00000000000..10307f280fd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2588 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_httpx3.al)"
+sub get_httpx3 { do_httpx3(GET => @_) }
+# end of Net::SSLeay::get_httpx3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx4.al
new file mode 100755
index 00000000000..0f400add2a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/get_httpx4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2593 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\get_httpx4.al)"
+sub get_httpx4 { do_httpx4(GET => @_) }
+# end of Net::SSLeay::get_httpx4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http.al
new file mode 100755
index 00000000000..8f8fc2ea672
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http.al
@@ -0,0 +1,10 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2569 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_http.al)"
+sub head_http { do_httpx2(HEAD => 0, @_) }
+
+# end of Net::SSLeay::head_http
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http3.al
new file mode 100755
index 00000000000..d1cd62e1831
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http3.al
@@ -0,0 +1,10 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2574 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_http3.al)"
+sub head_http3 { do_httpx3(HEAD => 0, @_) }
+
+# end of Net::SSLeay::head_http3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http4.al
new file mode 100755
index 00000000000..9078198a378
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_http4.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2579 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_http4.al)"
+sub head_http4 { do_httpx4(HEAD => 0, @_) }
+
+# Either https or http
+
+# end of Net::SSLeay::head_http4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https.al
new file mode 100755
index 00000000000..98d2739ad6a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https.al
@@ -0,0 +1,10 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2552 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_https.al)"
+sub head_https { do_httpx2(HEAD => 1, @_) }
+
+# end of Net::SSLeay::head_https
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https3.al
new file mode 100755
index 00000000000..f97eb8f9ff5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https3.al
@@ -0,0 +1,10 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2557 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_https3.al)"
+sub head_https3 { do_httpx3(HEAD => 1, @_) }
+
+# end of Net::SSLeay::head_https3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https4.al
new file mode 100755
index 00000000000..f5262f16c21
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_https4.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2562 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_https4.al)"
+sub head_https4 { do_httpx4(HEAD => 1, @_) }
+
+# http
+
+# end of Net::SSLeay::head_https4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx.al
new file mode 100755
index 00000000000..7877cae2e60
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx.al
@@ -0,0 +1,10 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2586 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_httpx.al)"
+sub head_httpx { do_httpx2(HEAD => @_) }
+
+# end of Net::SSLeay::head_httpx
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx3.al
new file mode 100755
index 00000000000..c3759fb0f51
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx3.al
@@ -0,0 +1,10 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2591 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_httpx3.al)"
+sub head_httpx3 { do_httpx3(HEAD => @_) }
+
+# end of Net::SSLeay::head_httpx3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx4.al
new file mode 100755
index 00000000000..9170fabaab4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/head_httpx4.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2596 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\head_httpx4.al)"
+sub head_httpx4 { do_httpx4(HEAD => @_) }
+
+### Legacy, don't use
+# ($page, $respone_or_err, %headers) = do_https(...);
+
+# end of Net::SSLeay::head_httpx4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/http_cat.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/http_cat.al
new file mode 100755
index 00000000000..fc6672e7280
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/http_cat.al
@@ -0,0 +1,34 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2384 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\http_cat.al)"
+sub http_cat { # address, port, message --> returns reply / (reply,errs,cert)
+ my ($dest_serv, $port, $out_message) = @_;
+ my ($got, $errs, $written);
+
+ ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
+ return (wantarray ? (undef, $errs) : undef) unless $got;
+
+ ### Connected. Exchange some data (doing repeated tries if necessary).
+
+ warn "http_cat $$: sending " . blength($out_message) . " bytes...\n"
+ if $trace==3;
+ warn "http_cat $$: sending `$out_message' (" . blength($out_message)
+ . " bytes)...\n" if $trace>3;
+ ($written, $errs) = tcp_write_all($out_message);
+ goto cleanup unless $written;
+
+ warn "waiting for reply...\n" if $trace>2;
+ ($got, $errs) = tcp_read_all(200000);
+ warn "Got " . blength($got) . " bytes.\n" if $trace==3;
+ warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
+
+cleanup:
+ close SSLCAT_S;
+ return wantarray ? ($got, $errs) : $got;
+}
+
+# end of Net::SSLeay::http_cat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/https_cat.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/https_cat.al
new file mode 100755
index 00000000000..33bf8053702
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/https_cat.al
@@ -0,0 +1,97 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2295 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\https_cat.al)"
+###
+### Basic request - response primitive, this is different from sslcat
+### because this does not shutdown the connection.
+###
+
+sub https_cat { # address, port, message --> returns reply / (reply,errs,cert)
+ my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_;
+ my ($ctx, $ssl, $got, $errs, $written);
+
+ ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
+ return (wantarray ? (undef, $errs) : undef) unless $got;
+
+ ### Do SSL negotiation stuff
+
+ warn "Creating SSL $ssl_version context...\n" if $trace>2;
+ load_error_strings(); # Some bloat, but I'm after ease of use
+ SSLeay_add_ssl_algorithms(); # and debuggability.
+ randomize();
+
+ $ctx = new_x_ctx();
+ goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx;
+
+ CTX_set_options($ctx, &OP_ALL);
+ goto cleanup2 if $errs = print_errs('CTX_set_options');
+
+ warn "Cert `$crt_path' given without key" if $crt_path && !$key_path;
+ set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path;
+
+ warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2;
+ $ssl = new($ctx);
+ goto cleanup if $errs = print_errs('SSL_new') or !$ssl;
+
+ warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2;
+ set_fd($ssl, fileno(SSLCAT_S));
+ goto cleanup if $errs = print_errs('set_fd');
+
+ warn "Entering SSL negotiation phase...\n" if $trace>2;
+
+ if ($trace>2) {
+ my $i = 0;
+ my $p = '';
+ my $cipher_list = 'Cipher list: ';
+ $p=Net::SSLeay::get_cipher_list($ssl,$i);
+ $cipher_list .= $p if $p;
+ do {
+ $i++;
+ $cipher_list .= ', ' . $p if $p;
+ $p=Net::SSLeay::get_cipher_list($ssl,$i);
+ } while $p;
+ $cipher_list .= '\n';
+ warn $cipher_list;
+ }
+
+ $got = Net::SSLeay::connect($ssl);
+ warn "SSLeay connect failed" if $trace>2 && $got==0;
+ goto cleanup if $errs = print_errs('SSL_connect');
+
+ my $server_cert = get_peer_certificate($ssl);
+ print_errs('get_peer_certificate');
+ if ($trace>1) {
+ warn "Cipher `" . get_cipher($ssl) . "'\n";
+ print_errs('get_ciper');
+ warn dump_peer_certificate($ssl);
+ }
+
+ ### Connected. Exchange some data (doing repeated tries if necessary).
+
+ warn "https_cat $$: sending " . blength($out_message) . " bytes...\n"
+ if $trace==3;
+ warn "https_cat $$: sending `$out_message' (" . blength($out_message)
+ . " bytes)...\n" if $trace>3;
+ ($written, $errs) = ssl_write_all($ssl, $out_message);
+ goto cleanup unless $written;
+
+ warn "waiting for reply...\n" if $trace>2;
+ ($got, $errs) = ssl_read_all($ssl);
+ warn "Got " . blength($got) . " bytes.\n" if $trace==3;
+ warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
+
+cleanup:
+ free ($ssl);
+ $errs .= print_errs('SSL_free');
+cleanup2:
+ CTX_free ($ctx);
+ $errs .= print_errs('CTX_free');
+ close SSLCAT_S;
+ return wantarray ? ($got, $errs, $server_cert) : $got;
+}
+
+# end of Net::SSLeay::https_cat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/httpx_cat.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/httpx_cat.al
new file mode 100755
index 00000000000..aaa98aeb732
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/httpx_cat.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2410 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\httpx_cat.al)"
+sub httpx_cat {
+ my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_;
+ warn "httpx_cat: usessl=$usessl ($site:$port)" if $trace;
+ if ($usessl) {
+ return https_cat($site, $port, $req, $crt_path, $key_path);
+ } else {
+ return http_cat($site, $port, $req);
+ }
+}
+
+# end of Net::SSLeay::httpx_cat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_form.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_form.al
new file mode 100755
index 00000000000..cdc20a2d49d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_form.al
@@ -0,0 +1,25 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2449 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\make_form.al)"
+###
+### Easy https manipulation routines
+###
+
+sub make_form {
+ my (@fields) = @_;
+ my $form;
+ while (@fields) {
+ my ($name, $data) = (shift(@fields), shift(@fields));
+ $data =~ s/([^\w\-.\@\$ ])/sprintf("%%%2.2x",ord($1))/gse;
+ $data =~ tr[ ][+];
+ $form .= "$name=$data&";
+ }
+ chop $form;
+ return $form;
+}
+
+# end of Net::SSLeay::make_form
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_headers.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_headers.al
new file mode 100755
index 00000000000..171483bc4ae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/make_headers.al
@@ -0,0 +1,21 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2466 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\make_headers.al)"
+sub make_headers {
+ my (@headers) = @_;
+ my $headers;
+ while (@headers) {
+ my $header = shift(@headers);
+ my $value = shift(@headers);
+ $header =~ s/:$//;
+ $value =~ s/\x0d?\x0a$//; # because we add it soon, see below
+ $headers .= "$header: $value$CRLF";
+ }
+ return $headers;
+}
+
+# end of Net::SSLeay::make_headers
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/new_x_ctx.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/new_x_ctx.al
new file mode 100755
index 00000000000..97fa45556ca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/new_x_ctx.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2158 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\new_x_ctx.al)"
+sub new_x_ctx {
+ if ($ssl_version == 2) { $ctx = CTX_v2_new(); }
+ elsif ($ssl_version == 3) { $ctx = CTX_v3_new(); }
+ elsif ($ssl_version == 10) { $ctx = CTX_tlsv1_new(); }
+ else { $ctx = CTX_new(); }
+ return $ctx;
+}
+
+# end of Net::SSLeay::new_x_ctx
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_proxy_tcp_connection.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_proxy_tcp_connection.al
new file mode 100755
index 00000000000..19ce508c465
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_proxy_tcp_connection.al
@@ -0,0 +1,31 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1833 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\open_proxy_tcp_connection.al)"
+### Open connection via standard web proxy, if one was defined
+### using set_proxy().
+
+sub open_proxy_tcp_connection {
+ my ($dest_serv, $port) = @_;
+ return open_tcp_connection($dest_serv, $port) if !$proxyhost;
+
+ warn "Connect via proxy: $proxyhost:$proxyport" if $trace>2;
+ my ($ret, $errs) = open_tcp_connection($proxyhost, $proxyport);
+ return wantarray ? (0, $errs) : 0 if !$ret; # Connection fail
+
+ warn "Asking proxy to connect to $dest_serv:$port" if $trace>2;
+ #print SSLCAT_S "CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF";
+ #my $line = <SSLCAT_S>; # *** bug? Mixing stdio with syscall read?
+ ($ret, $errs) =
+ tcp_write_all("CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF");
+ return wantarray ? (0,$errs) : 0 if $errs;
+ ($line, $errs) = tcp_read_until($CRLF . $CRLF, 1024);
+ warn "Proxy response: $line" if $trace>2;
+ return wantarray ? (0,$errs) : 0 if $errs;
+ return wantarray ? (1,'') : 1; # Success
+}
+
+# end of Net::SSLeay::open_proxy_tcp_connection
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_tcp_connection.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_tcp_connection.al
new file mode 100755
index 00000000000..ddad138f36c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/open_tcp_connection.al
@@ -0,0 +1,40 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1801 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\open_tcp_connection.al)"
+sub open_tcp_connection {
+ my ($dest_serv, $port) = @_;
+ my ($errs);
+
+ $port = getservbyname($port, 'tcp') unless $port =~ /^\d+$/;
+ my $dest_serv_ip = gethostbyname($dest_serv);
+ unless (defined($dest_serv_ip)) {
+ $errs = "$0 $$: open_tcp_connection: destination host not found:"
+ . " `$dest_serv' (port $port) ($!)\n";
+ warn $errs if $trace;
+ return wantarray ? (0, $errs) : 0;
+ }
+ my $sin = sockaddr_in($port, $dest_serv_ip);
+
+ warn "Opening connection to $dest_serv:$port (" .
+ inet_ntoa($dest_serv_ip) . ")" if $trace>2;
+
+ my $proto = getprotobyname('tcp');
+ if (socket (SSLCAT_S, &PF_INET(), &SOCK_STREAM(), $proto)) {
+ warn "next connect" if $trace>3;
+ if (CORE::connect (SSLCAT_S, $sin)) {
+ my $old_out = select (SSLCAT_S); $| = 1; select ($old_out);
+ warn "connected to $dest_serv, $port" if $trace>3;
+ return wantarray ? (1, undef) : 1; # Success
+ }
+ }
+ $errs = "$0 $$: open_tcp_connection: failed `$dest_serv', $port ($!)\n";
+ warn $errs if $trace;
+ close SSLCAT_S;
+ return wantarray ? (0, $errs) : 0; # Fail
+}
+
+# end of Net::SSLeay::open_tcp_connection
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http.al
new file mode 100755
index 00000000000..23dd45dcb95
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2567 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_http.al)"
+sub post_http { do_httpx2(POST => 0, @_) }
+# end of Net::SSLeay::post_http
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http3.al
new file mode 100755
index 00000000000..2b1d62628bb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2572 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_http3.al)"
+sub post_http3 { do_httpx3(POST => 0, @_) }
+# end of Net::SSLeay::post_http3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http4.al
new file mode 100755
index 00000000000..3139b18e5ea
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_http4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2577 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_http4.al)"
+sub post_http4 { do_httpx4(POST => 0, @_) }
+# end of Net::SSLeay::post_http4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https.al
new file mode 100755
index 00000000000..e1506be2ced
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2550 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_https.al)"
+sub post_https { do_httpx2(POST => 1, @_) }
+# end of Net::SSLeay::post_https
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https3.al
new file mode 100755
index 00000000000..a81201b57d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2555 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_https3.al)"
+sub post_https3 { do_httpx3(POST => 1, @_) }
+# end of Net::SSLeay::post_https3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https4.al
new file mode 100755
index 00000000000..f3ad2d7dc72
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_https4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2560 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_https4.al)"
+sub post_https4 { do_httpx4(POST => 1, @_) }
+# end of Net::SSLeay::post_https4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx.al
new file mode 100755
index 00000000000..28a8e56ae9d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2584 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_httpx.al)"
+sub post_httpx { do_httpx2(POST => @_) }
+# end of Net::SSLeay::post_httpx
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx3.al
new file mode 100755
index 00000000000..263f4feb0f9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2589 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_httpx3.al)"
+sub post_httpx3 { do_httpx3(POST => @_) }
+# end of Net::SSLeay::post_httpx3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx4.al
new file mode 100755
index 00000000000..dd022e2d23d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/post_httpx4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2594 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\post_httpx4.al)"
+sub post_httpx4 { do_httpx4(POST => @_) }
+# end of Net::SSLeay::post_httpx4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http.al
new file mode 100755
index 00000000000..ac7bbd648cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2568 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_http.al)"
+sub put_http { do_httpx2(PUT => 0, @_) }
+# end of Net::SSLeay::put_http
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http3.al
new file mode 100755
index 00000000000..42e1a6d35b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2573 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_http3.al)"
+sub put_http3 { do_httpx3(PUT => 0, @_) }
+# end of Net::SSLeay::put_http3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http4.al
new file mode 100755
index 00000000000..c27a2135152
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_http4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2578 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_http4.al)"
+sub put_http4 { do_httpx4(PUT => 0, @_) }
+# end of Net::SSLeay::put_http4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https.al
new file mode 100755
index 00000000000..c2bda1f4e8d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2551 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_https.al)"
+sub put_https { do_httpx2(PUT => 1, @_) }
+# end of Net::SSLeay::put_https
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https3.al
new file mode 100755
index 00000000000..5471ed36331
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2556 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_https3.al)"
+sub put_https3 { do_httpx3(PUT => 1, @_) }
+# end of Net::SSLeay::put_https3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https4.al
new file mode 100755
index 00000000000..0e3ee8addfe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_https4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2561 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_https4.al)"
+sub put_https4 { do_httpx4(PUT => 1, @_) }
+# end of Net::SSLeay::put_https4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx.al
new file mode 100755
index 00000000000..f203c211743
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2585 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_httpx.al)"
+sub put_httpx { do_httpx2(PUT => @_) }
+# end of Net::SSLeay::put_httpx
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx3.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx3.al
new file mode 100755
index 00000000000..1bb34e1cb9f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx3.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2590 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_httpx3.al)"
+sub put_httpx3 { do_httpx3(PUT => @_) }
+# end of Net::SSLeay::put_httpx3
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx4.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx4.al
new file mode 100755
index 00000000000..d85cf654363
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/put_httpx4.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2595 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\put_httpx4.al)"
+sub put_httpx4 { do_httpx4(PUT => @_) }
+# end of Net::SSLeay::put_httpx4
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/randomize.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/randomize.al
new file mode 100755
index 00000000000..7aee1949055
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/randomize.al
@@ -0,0 +1,31 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2135 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\randomize.al)"
+### Arrange some randomness for eay PRNG
+
+sub randomize (;$$) {
+ my ($rn_seed_file, $seed, $egd_path) = @_;
+ my $rnsf = defined($rn_seed_file) && -r $rn_seed_file;
+
+ $egd_path = '';
+ $egd_path = $ENV{'EGD_PATH'} if $ENV{'EGD_PATH'};
+
+ RAND_seed(rand() + $$); # Stir it with time and pid
+
+ unless ($rnsf || -r $Net::SSLeay::random_device || $seed || -S $egd_path) {
+ warn "Random number generator not seeded!!!" if $trace;
+ }
+
+ RAND_load_file($rn_seed_file, -s _) if $rnsf;
+ RAND_seed($seed) if $seed;
+ RAND_seed($ENV{RND_SEED}) if $ENV{RND_SEED};
+ RAND_egd($egd_path) if -e $egd_path && -S _;
+ RAND_load_file($Net::SSLeay::random_device, $Net::SSLeay::how_random/8)
+ if -r $Net::SSLeay::random_device;
+}
+
+# end of Net::SSLeay::randomize
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_cert_and_key.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_cert_and_key.al
new file mode 100755
index 00000000000..c01d81b05ca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_cert_and_key.al
@@ -0,0 +1,23 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2420 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\set_cert_and_key.al)"
+###
+### Easy set up of private key and certificate
+###
+
+sub set_cert_and_key ($$$) {
+ my ($ctx, $cert_path, $key_path) = @_;
+ my $errs = '';
+ # Following will ask password unless private key is not encrypted
+ CTX_use_RSAPrivateKey_file ($ctx, $key_path, &FILETYPE_PEM);
+ $errs .= print_errs("private key `$key_path' ($!)");
+ CTX_use_certificate_file ($ctx, $cert_path, &FILETYPE_PEM);
+ $errs .= print_errs("certificate `$cert_path' ($!)");
+ return wantarray ? (undef, $errs) : ($errs eq '');
+}
+
+# end of Net::SSLeay::set_cert_and_key
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_proxy.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_proxy.al
new file mode 100755
index 00000000000..3488e566e8f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_proxy.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2441 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\set_proxy.al)"
+sub set_proxy ($$;**) {
+ ($proxyhost, $proxyport, $proxyuser, $proxypass) = @_;
+ require MIME::Base64 if $proxyuser;
+ $proxyauth = $CRLF . 'Proxy-authorization: Basic '
+ . MIME::Base64::encode("$proxyuser:$proxypass", '')
+ if $proxyuser;
+}
+
+# end of Net::SSLeay::set_proxy
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_server_cert_and_key.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_server_cert_and_key.al
new file mode 100755
index 00000000000..d0677fee0e4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/set_server_cert_and_key.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2435 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\set_server_cert_and_key.al)"
+### Old deprecated API
+
+sub set_server_cert_and_key ($$$) { &set_cert_and_key }
+
+### Set up to use web proxy
+
+# end of Net::SSLeay::set_server_cert_and_key
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_CRLF.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_CRLF.al
new file mode 100755
index 00000000000..a2e3dcffc47
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_CRLF.al
@@ -0,0 +1,10 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2079 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\ssl_read_CRLF.al)"
+# ssl_read_CRLF($ssl [, $max_length])
+sub ssl_read_CRLF ($;$) { ssl_read_until($_[0], $CRLF, $_[1]) }
+# end of Net::SSLeay::ssl_read_CRLF
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_all.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_all.al
new file mode 100755
index 00000000000..73154b37a6d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_all.al
@@ -0,0 +1,28 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1870 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\ssl_read_all.al)"
+sub ssl_read_all {
+ my ($ssl,$how_much) = @_;
+ $how_much = 2000000000 unless $how_much;
+ my ($got, $errs);
+ my $reply = '';
+
+ while ($how_much > 0) {
+ $got = Net::SSLeay::read($ssl,
+ ($how_much > 32768) ? 32768 : $how_much
+ );
+ last if $errs = print_errs('SSL_read');
+ $how_much -= blength($got);
+ debug_read(\$reply, \$got) if $trace>1;
+ last if $got eq ''; # EOF
+ $reply .= $got;
+ }
+
+ return wantarray ? ($reply, $errs) : $reply;
+}
+
+# end of Net::SSLeay::ssl_read_all
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_until.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_until.al
new file mode 100755
index 00000000000..252b4400516
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_read_until.al
@@ -0,0 +1,95 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1966 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\ssl_read_until.al)"
+### from patch by Clinton Wong <clintdw@netcom.com>
+
+# ssl_read_until($ssl [, $delimit [, $max_length]])
+# if $delimit missing, use $/ if it exists, otherwise use \n
+# read until delimiter reached, up to $max_length chars if defined
+
+sub ssl_read_until ($;$$) {
+ my ($ssl,$delim, $max_length) = @_;
+ local $[;
+
+ # guess the delim string if missing
+ if ( ! defined $delim ) {
+ if ( defined $/ && length $/ ) { $delim = $/ }
+ else { $delim = "\n" } # Note: \n,$/ value depends on the platform
+ }
+ my $len_delim = length $delim;
+
+ my ($got);
+ my $reply = '';
+
+ # If we have OpenSSL 0.9.6a or later, we can use SSL_peek to
+ # speed things up.
+ # N.B. 0.9.6a has security problems, so the support for
+ # anything earlier than 0.9.6e will be dropped soon.
+ if (&Net::SSLeay::OPENSSL_VERSION_NUMBER >= 0x0090601f) {
+ $max_length = 2000000000 unless (defined $max_length);
+ my ($pending, $peek_length, $found, $done);
+ while (blength($reply) < $max_length and !$done) {
+ #Block if necessary until we get some data
+ $got = Net::SSLeay::peek($ssl,1);
+ last if print_errs('SSL_peek');
+
+ $pending = Net::SSLeay::pending($ssl) + blength($reply);
+ $peek_length = ($pending > $max_length) ? $max_length : $pending;
+ $peek_length -= blength($reply);
+ $got = Net::SSLeay::peek($ssl, $peek_length);
+ last if print_errs('SSL_peek');
+ $peek_length = blength($got);
+
+ #$found = index($got, $delim); # Old and broken
+
+ # the delimiter may be split across two gets, so we prepend
+ # a little from the last get onto this one before we check
+ # for a match
+ my $match;
+ if(blength($reply) >= blength($delim) - 1) {
+ #if what we've read so far is greater or equal
+ #in length of what we need to prepatch
+ $match = substr $reply, blength($reply) - blength($delim) + 1;
+ } else {
+ $match = $reply;
+ }
+
+ $match .= $got;
+ $found = index($match, $delim);
+
+ if ($found > -1) {
+ #$got = Net::SSLeay::read($ssl, $found+$len_delim);
+ #read up to the end of the delimiter
+ $got = Net::SSLeay::read($ssl,
+ $found + $len_delim
+ - ((blength $match) - (blength $got)));
+ $done = 1;
+ } else {
+ $got = Net::SSLeay::read($ssl, $peek_length);
+ $done = 1 if ($peek_length == $max_length - blength($reply));
+ }
+
+ last if print_errs('SSL_read');
+ debug_read(\$reply, \$got) if $trace>1;
+ last if $got eq '';
+ $reply .= $got;
+ }
+ } else {
+ while (!defined $max_length || length $reply < $max_length) {
+ $got = Net::SSLeay::read($ssl,1); # one by one
+ last if print_errs('SSL_read');
+ debug_read(\$reply, \$got) if $trace>1;
+ last if $got eq '';
+ $reply .= $got;
+ last if $len_delim
+ && substr($reply, blength($reply)-$len_delim) eq $delim;
+ }
+ }
+ return $reply;
+}
+
+# end of Net::SSLeay::ssl_read_until
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_CRLF.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_CRLF.al
new file mode 100755
index 00000000000..586198b4132
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_CRLF.al
@@ -0,0 +1,23 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2084 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\ssl_write_CRLF.al)"
+sub ssl_write_CRLF ($$) {
+ # the next line uses less memory but might use more network packets
+ return ssl_write_all($_[0], $_[1]) + ssl_write_all($_[0], $CRLF);
+
+ # the next few lines do the same thing at the expense of memory, with
+ # the chance that it will use less packets, since CRLF is in the original
+ # message and won't be sent separately.
+
+ #my $data_ref;
+ #if (ref $_[1]) { $data_ref = $_[1] }
+ # else { $data_ref = \$_[1] }
+ #my $message = $$data_ref . $CRLF;
+ #return ssl_write_all($_[0], \$message);
+}
+
+# end of Net::SSLeay::ssl_write_CRLF
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_all.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_all.al
new file mode 100755
index 00000000000..cf18ffd4eb1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/ssl_write_all.al
@@ -0,0 +1,38 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1908 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\ssl_write_all.al)"
+sub ssl_write_all {
+ my $ssl = $_[0];
+ my ($data_ref, $errs);
+ if (ref $_[1]) {
+ $data_ref = $_[1];
+ } else {
+ $data_ref = \$_[1];
+ }
+ my ($wrote, $written, $to_write) = (0,0, blength($$data_ref));
+ my $vm = $trace>2 && $linux_debug ?
+ (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
+ warn " write_all VM at entry=$vm\n" if $trace>2;
+ while ($to_write) {
+ #sleep 1; # *** DEBUG
+ warn "partial `$$data_ref'\n" if $trace>3;
+ $wrote = write_partial($ssl, $written, $to_write, $$data_ref);
+ if (defined $wrote && ($wrote > 0)) { # write_partial can return -1
+ $written += $wrote;
+ $to_write -= $wrote;
+ }
+ $vm = $trace>2 && $linux_debug ?
+ (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
+ warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2;
+
+ $errs .= print_errs('SSL_write');
+ return (wantarray ? (undef, $errs) : undef) if $errs;
+ }
+ return wantarray ? ($written, $errs) : $written;
+}
+
+# end of Net::SSLeay::ssl_write_all
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/sslcat.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/sslcat.al
new file mode 100755
index 00000000000..9cb18a3a842
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/sslcat.al
@@ -0,0 +1,99 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2166 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\sslcat.al)"
+###
+### Basic request - response primitive (don't use for https)
+###
+
+sub sslcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert)
+ my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_;
+ my ($ctx, $ssl, $got, $errs, $written);
+
+ ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
+ return (wantarray ? (undef, $errs) : undef) unless $got;
+
+ ### Do SSL negotiation stuff
+
+ warn "Creating SSL $ssl_version context...\n" if $trace>2;
+ load_error_strings(); # Some bloat, but I'm after ease of use
+ SSLeay_add_ssl_algorithms(); # and debuggability.
+ randomize();
+
+ $ctx = new_x_ctx();
+ goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx;
+
+ CTX_set_options($ctx, &OP_ALL);
+ goto cleanup2 if $errs = print_errs('CTX_set_options');
+
+ warn "Cert `$crt_path' given without key" if $crt_path && !$key_path;
+ set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path;
+
+ warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2;
+ $ssl = new($ctx);
+ goto cleanup if $errs = print_errs('SSL_new') or !$ssl;
+
+ warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2;
+ set_fd($ssl, fileno(SSLCAT_S));
+ goto cleanup if $errs = print_errs('set_fd');
+
+ warn "Entering SSL negotiation phase...\n" if $trace>2;
+
+ if ($trace>2) {
+ my $i = 0;
+ my $p = '';
+ my $cipher_list = 'Cipher list: ';
+ $p=Net::SSLeay::get_cipher_list($ssl,$i);
+ $cipher_list .= $p if $p;
+ do {
+ $i++;
+ $cipher_list .= ', ' . $p if $p;
+ $p=Net::SSLeay::get_cipher_list($ssl,$i);
+ } while $p;
+ $cipher_list .= '\n';
+ warn $cipher_list;
+ }
+
+ $got = Net::SSLeay::connect($ssl);
+ warn "SSLeay connect returned $got\n" if $trace>2;
+ goto cleanup if $errs = print_errs('SSL_connect');
+
+ my $server_cert = get_peer_certificate($ssl);
+ print_errs('get_peer_certificate');
+ if ($trace>1) {
+ warn "Cipher `" . get_cipher($ssl) . "'\n";
+ print_errs('get_ciper');
+ warn dump_peer_certificate($ssl);
+ }
+
+ ### Connected. Exchange some data (doing repeated tries if necessary).
+
+ warn "sslcat $$: sending " . blength($out_message) . " bytes...\n"
+ if $trace==3;
+ warn "sslcat $$: sending `$out_message' (" . blength($out_message)
+ . " bytes)...\n" if $trace>3;
+ ($written, $errs) = ssl_write_all($ssl, $out_message);
+ goto cleanup unless $written;
+
+ sleep $slowly if $slowly; # Closing too soon can abort broken servers
+ CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server
+
+ warn "waiting for reply...\n" if $trace>2;
+ ($got, $errs) = ssl_read_all($ssl);
+ warn "Got " . blength($got) . " bytes.\n" if $trace==3;
+ warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
+
+cleanup:
+ free ($ssl);
+ $errs .= print_errs('SSL_free');
+cleanup2:
+ CTX_free ($ctx);
+ $errs .= print_errs('CTX_free');
+ close SSLCAT_S;
+ return wantarray ? ($got, $errs, $server_cert) : $got;
+}
+
+# end of Net::SSLeay::sslcat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_CRLF.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_CRLF.al
new file mode 100755
index 00000000000..1cbec66b70f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_CRLF.al
@@ -0,0 +1,11 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2081 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\tcp_read_CRLF.al)"
+sub tcp_read_CRLF { tcp_read_until($CRLF, $_[0]) }
+
+# ssl_write_CRLF($ssl, $message) writes $message and appends CRLF
+# end of Net::SSLeay::tcp_read_CRLF
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_all.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_all.al
new file mode 100755
index 00000000000..4b583610227
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_all.al
@@ -0,0 +1,26 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1890 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\tcp_read_all.al)"
+sub tcp_read_all {
+ my ($how_much) = @_;
+ $how_much = 2000000000 unless $how_much;
+ my ($n, $got, $errs);
+ my $reply = '';
+
+ my $bsize = 0x10000;
+ while ($how_much > 0) {
+ $n = sysread(SSLCAT_S,$got, (($bsize < $how_much) ? $bsize : $how_much));
+ warn "Read error: $! ($n,$how_much)" unless defined $n;
+ last if !$n; # EOF
+ $how_much -= $n;
+ debug_read(\$reply, \$got) if $trace>1;
+ $reply .= $got;
+ }
+ return wantarray ? ($reply, $errs) : $reply;
+}
+
+# end of Net::SSLeay::tcp_read_all
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_until.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_until.al
new file mode 100755
index 00000000000..c6be56ed626
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_read_until.al
@@ -0,0 +1,34 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2053 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\tcp_read_until.al)"
+sub tcp_read_until {
+ my ($delim, $max_length) = @_;
+ local $[;
+
+ # guess the delim string if missing
+ if ( ! defined $delim ) {
+ if ( defined $/ && length $/ ) { $delim = $/ }
+ else { $delim = "\n" } # Note: \n,$/ value depends on the platform
+ }
+ my $len_delim = length $delim;
+
+ my ($n,$got);
+ my $reply = '';
+
+ while (!defined $max_length || length $reply < $max_length) {
+ $n = sysread(SSLCAT_S, $got, 1); # one by one
+ warn "tcp_read_until: $!" if !defined $n;
+ debug_read(\$reply, \$got) if $trace>1;
+ last if !$n; # EOF
+ $reply .= $got;
+ last if $len_delim
+ && substr($reply, blength($reply)-$len_delim) eq $delim;
+ }
+ return $reply;
+}
+
+# end of Net::SSLeay::tcp_read_until
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_CRLF.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_CRLF.al
new file mode 100755
index 00000000000..fc3f04af922
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_CRLF.al
@@ -0,0 +1,23 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2099 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\tcp_write_CRLF.al)"
+sub tcp_write_CRLF {
+ # the next line uses less memory but might use more network packets
+ return tcp_write_all($_[0]) + tcp_write_all($CRLF);
+
+ # the next few lines do the same thing at the expense of memory, with
+ # the chance that it will use less packets, since CRLF is in the original
+ # message and won't be sent separately.
+
+ #my $data_ref;
+ #if (ref $_[1]) { $data_ref = $_[1] }
+ # else { $data_ref = \$_[1] }
+ #my $message = $$data_ref . $CRLF;
+ #return tcp_write_all($_[0], \$message);
+}
+
+# end of Net::SSLeay::tcp_write_CRLF
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_all.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_all.al
new file mode 100755
index 00000000000..0c701728a86
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcp_write_all.al
@@ -0,0 +1,36 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1938 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\tcp_write_all.al)"
+sub tcp_write_all {
+ my ($data_ref, $errs);
+ if (ref $_[0]) {
+ $data_ref = $_[0];
+ } else {
+ $data_ref = \$_[0];
+ }
+ my ($wrote, $written, $to_write) = (0,0, blength($$data_ref));
+ my $vm = $trace>2 && $linux_debug ?
+ (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
+ warn " write_all VM at entry=$vm to_write=$to_write\n" if $trace>2;
+ while ($to_write) {
+ warn "partial `$$data_ref'\n" if $trace>3;
+ $wrote = syswrite(SSLCAT_S, $$data_ref, $to_write, $written);
+ if (defined $wrote && ($wrote > 0)) { # write_partial can return -1
+ $written += $wrote;
+ $to_write -= $wrote;
+ } elsif (!defined($wrote)) {
+ warn "tcp_write_all: $!";
+ return (wantarray ? (undef, "$!") : undef);
+ }
+ $vm = $trace>2 && $linux_debug ?
+ (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
+ warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2;
+ }
+ return wantarray ? ($written, '') : $written;
+}
+
+# end of Net::SSLeay::tcp_write_all
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpcat.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpcat.al
new file mode 100755
index 00000000000..b36faeae7a2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpcat.al
@@ -0,0 +1,37 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2257 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\tcpcat.al)"
+sub tcpcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert)
+ my ($dest_serv, $port, $out_message) = @_;
+ my ($got, $errs, $written);
+
+ ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
+ return (wantarray ? (undef, $errs) : undef) unless $got;
+
+ ### Connected. Exchange some data (doing repeated tries if necessary).
+
+ warn "tcpcat $$: sending " . blength($out_message) . " bytes...\n"
+ if $trace==3;
+ warn "tcpcat $$: sending `$out_message' (" . blength($out_message)
+ . " bytes)...\n" if $trace>3;
+ ($written, $errs) = tcp_write_all($out_message);
+ goto cleanup unless $written;
+
+ sleep $slowly if $slowly; # Closing too soon can abort broken servers
+ CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server
+
+ warn "waiting for reply...\n" if $trace>2;
+ ($got, $errs) = tcp_read_all($ssl);
+ warn "Got " . blength($got) . " bytes.\n" if $trace==3;
+ warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
+
+cleanup:
+ close SSLCAT_S;
+ return wantarray ? ($got, $errs) : $got;
+}
+
+# end of Net::SSLeay::tcpcat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpxcat.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpxcat.al
new file mode 100755
index 00000000000..4e79ce00087
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/tcpxcat.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 2286 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\tcpxcat.al)"
+sub tcpxcat {
+ my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_;
+ if ($usessl) {
+ return sslcat($site, $port, $req, $crt_path, $key_path);
+ } else {
+ return tcpcat($site, $port, $req);
+ }
+}
+
+# end of Net::SSLeay::tcpxcat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_X509_lookup.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_X509_lookup.al
new file mode 100755
index 00000000000..e17c706f565
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_X509_lookup.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1794 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\want_X509_lookup.al)"
+sub want_X509_lookup { want(shift) == 4 }
+
+###
+### Open TCP stream to given host and port, looking up the details
+### from system databases or DNS.
+###
+
+# end of Net::SSLeay::want_X509_lookup
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_nothing.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_nothing.al
new file mode 100755
index 00000000000..df3d1005d24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_nothing.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1784 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\want_nothing.al)"
+# Documentation. Use `perl-root/pod/pod2html SSLeay.pm` to output html
+
+
+# ';
+
+### Some methods that are macros in C
+
+sub want_nothing { want(shift) == 1 }
+# end of Net::SSLeay::want_nothing
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_read.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_read.al
new file mode 100755
index 00000000000..e3a41612772
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_read.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1792 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\want_read.al)"
+sub want_read { want(shift) == 2 }
+# end of Net::SSLeay::want_read
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_write.al b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_write.al
new file mode 100755
index 00000000000..941e1853bbe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Net/SSLeay/want_write.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from blib\lib\Net\SSLeay.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Net::SSLeay;
+
+#line 1793 "blib\lib\Net\SSLeay.pm (autosplit into blib\lib\auto\Net\SSLeay\want_write.al)"
+sub want_write { want(shift) == 3 }
+# end of Net::SSLeay::want_write
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Number/Compare/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Number/Compare/.packlist
new file mode 100755
index 00000000000..81c9a811e0c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Number/Compare/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Number\Compare.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Object/Accessor/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Object/Accessor/.packlist
new file mode 100755
index 00000000000..2602ae2199e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Object/Accessor/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Object\Accessor.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Opcode/Opcode.dll b/Master/tlpkg/tlperl.straw/lib/auto/Opcode/Opcode.dll
new file mode 100755
index 00000000000..89a416de5c3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Opcode/Opcode.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PAR/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/PAR/.packlist
new file mode 100755
index 00000000000..6a263a75cad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PAR/.packlist
@@ -0,0 +1,7 @@
+C:\strawberry\perl\vendor\lib\PAR.pm
+C:\strawberry\perl\vendor\lib\PAR\Environment.pod
+C:\strawberry\perl\vendor\lib\PAR\FAQ.pod
+C:\strawberry\perl\vendor\lib\PAR\Heavy.pm
+C:\strawberry\perl\vendor\lib\PAR\SetupProgname.pm
+C:\strawberry\perl\vendor\lib\PAR\SetupTemp.pm
+C:\strawberry\perl\vendor\lib\PAR\Tutorial.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/.packlist
new file mode 100755
index 00000000000..f58e59ac6a9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\PAR\Dist.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/FromPPD/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/FromPPD/.packlist
new file mode 100755
index 00000000000..82db882d4b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/FromPPD/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\ppd2par
+C:\strawberry\perl\bin\ppd2par.bat
+C:\strawberry\perl\vendor\lib\PAR\Dist\FromPPD.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/InstallPPD/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/InstallPPD/.packlist
new file mode 100755
index 00000000000..e1481a92eca
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Dist/InstallPPD/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\parinstallppd
+C:\strawberry\perl\bin\parinstallppd.bat
+C:\strawberry\perl\vendor\lib\PAR\Dist\InstallPPD.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Client/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Client/.packlist
new file mode 100755
index 00000000000..404e521bacb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Client/.packlist
@@ -0,0 +1,5 @@
+C:\strawberry\perl\vendor\lib\PAR\Repository\Client.pm
+C:\strawberry\perl\vendor\lib\PAR\Repository\Client\DBM.pm
+C:\strawberry\perl\vendor\lib\PAR\Repository\Client\HTTP.pm
+C:\strawberry\perl\vendor\lib\PAR\Repository\Client\Local.pm
+C:\strawberry\perl\vendor\lib\PAR\Repository\Client\Util.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Query/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Query/.packlist
new file mode 100755
index 00000000000..8410ab340d7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PAR/Repository/Query/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\PAR\Repository\Query.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/POSIX.dll b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/POSIX.dll
new file mode 100755
index 00000000000..1af4b64989b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/POSIX.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/flags.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/flags.al
new file mode 100755
index 00000000000..7cbdb7bb920
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/flags.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigAction;
+
+#line 986 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigAction\flags.al)"
+sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} };
+# end of POSIX::SigAction::flags
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/handler.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/handler.al
new file mode 100755
index 00000000000..3d03d1c9a99
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/handler.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigAction;
+
+#line 984 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigAction\handler.al)"
+sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} };
+# end of POSIX::SigAction::handler
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/mask.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/mask.al
new file mode 100755
index 00000000000..bc8bd31e8c0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/mask.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigAction;
+
+#line 985 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigAction\mask.al)"
+sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} };
+# end of POSIX::SigAction::mask
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/new.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/new.al
new file mode 100755
index 00000000000..b74b2d4a4de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/new.al
@@ -0,0 +1,11 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigAction;
+
+#line 981 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigAction\new.al)"
+package POSIX::SigAction;
+
+sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
+# end of POSIX::SigAction::new
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/safe.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/safe.al
new file mode 100755
index 00000000000..a9f21cc5f18
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigAction/safe.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigAction;
+
+#line 987 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigAction\safe.al)"
+sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
+
+package POSIX::SigRt;
+
+
+# end of POSIX::SigRt::safe
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/CLEAR.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/CLEAR.al
new file mode 100755
index 00000000000..78d3d5bb622
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/CLEAR.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1041 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\CLEAR.al)"
+sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } }
+# end of POSIX::SigRt::CLEAR
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/DELETE.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/DELETE.al
new file mode 100755
index 00000000000..6bac474d05b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/DELETE.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1040 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\DELETE.al)"
+sub DELETE { delete $SIG{ &_check } }
+# end of POSIX::SigRt::DELETE
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/EXISTS.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/EXISTS.al
new file mode 100755
index 00000000000..2f2c73d94a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/EXISTS.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1034 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\EXISTS.al)"
+sub EXISTS { &_exist }
+# end of POSIX::SigRt::EXISTS
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/FETCH.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/FETCH.al
new file mode 100755
index 00000000000..ed18ab0d9b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/FETCH.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1035 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\FETCH.al)"
+sub FETCH { my $rtsig = &_check;
+ my $oa = POSIX::SigAction->new();
+ POSIX::sigaction($rtsig, undef, $oa);
+ return $oa->{HANDLER} }
+# end of POSIX::SigRt::FETCH
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/SCALAR.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/SCALAR.al
new file mode 100755
index 00000000000..feec293431c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/SCALAR.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1042 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\SCALAR.al)"
+sub SCALAR { &_croak; $_sigrtn + 1 }
+1;
+# end of POSIX::SigRt::SCALAR
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/STORE.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/STORE.al
new file mode 100755
index 00000000000..f4c6466a06b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/STORE.al
@@ -0,0 +1,9 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1039 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\STORE.al)"
+sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) }
+# end of POSIX::SigRt::STORE
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_check.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_check.al
new file mode 100755
index 00000000000..c1a46c3e6c3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_check.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1018 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\_check.al)"
+sub _check {
+ my ($rtsig, $ok) = &_exist;
+ die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)"
+ unless $ok;
+ return $rtsig;
+}
+
+# end of POSIX::SigRt::_check
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_croak.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_croak.al
new file mode 100755
index 00000000000..742d4e9cd46
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_croak.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 998 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\_croak.al)"
+sub _croak {
+ &_init unless defined $_sigrtn;
+ die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0;
+}
+
+# end of POSIX::SigRt::_croak
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_exist.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_exist.al
new file mode 100755
index 00000000000..075bbed6ab8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_exist.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1012 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\_exist.al)"
+sub _exist {
+ my $rtsig = _getsig($_[1]);
+ my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX;
+ ($rtsig, $ok);
+}
+
+# end of POSIX::SigRt::_exist
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_getsig.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_getsig.al
new file mode 100755
index 00000000000..1cdbfaaf197
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_getsig.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1003 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\_getsig.al)"
+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;
+}
+
+# end of POSIX::SigRt::_getsig
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_init.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_init.al
new file mode 100755
index 00000000000..8ac96299ec6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/_init.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 992 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\_init.al)"
+sub _init {
+ $_SIGRTMIN = &POSIX::SIGRTMIN;
+ $_SIGRTMAX = &POSIX::SIGRTMAX;
+ $_sigrtn = $_SIGRTMAX - $_SIGRTMIN;
+}
+
+# end of POSIX::SigRt::_init
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/new.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/new.al
new file mode 100755
index 00000000000..30b6100a634
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/SigRt/new.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX::SigRt;
+
+#line 1025 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\SigRt\new.al)"
+sub new {
+ my ($rtsig, $handler, $flags) = @_;
+ my $sigset = POSIX::SigSet->new($rtsig);
+ my $sigact = POSIX::SigAction->new($handler,
+ $sigset,
+ $flags);
+ POSIX::sigaction($rtsig, $sigact);
+}
+
+# end of POSIX::SigRt::new
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/abs.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/abs.al
new file mode 100755
index 00000000000..a882e5a0309
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/abs.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 414 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\abs.al)"
+sub abs {
+ usage "abs(x)" if @_ != 1;
+ CORE::abs($_[0]);
+}
+
+# end of POSIX::abs
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/alarm.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/alarm.al
new file mode 100755
index 00000000000..2bf97977aeb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/alarm.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 631 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\alarm.al)"
+sub alarm {
+ usage "alarm(seconds)" if @_ != 1;
+ CORE::alarm($_[0]);
+}
+
+# end of POSIX::alarm
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/assert.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/assert.al
new file mode 100755
index 00000000000..fbeefa8583c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/assert.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 96 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\assert.al)"
+sub assert {
+ usage "assert(expr)" if @_ != 1;
+ if (!$_[0]) {
+ croak "Assertion failed";
+ }
+}
+
+# end of POSIX::assert
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atan2.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atan2.al
new file mode 100755
index 00000000000..41b71fab8e4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atan2.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 161 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\atan2.al)"
+sub atan2 {
+ usage "atan2(x,y)" if @_ != 2;
+ CORE::atan2($_[0], $_[1]);
+}
+
+# end of POSIX::atan2
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atexit.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atexit.al
new file mode 100755
index 00000000000..7df942dfda6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atexit.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 419 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\atexit.al)"
+sub atexit {
+ unimpl "atexit() is C-specific: use END {} instead";
+}
+
+# end of POSIX::atexit
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atof.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atof.al
new file mode 100755
index 00000000000..5f4d2c51bbb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atof.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 423 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\atof.al)"
+sub atof {
+ unimpl "atof() is C-specific, stopped";
+}
+
+# end of POSIX::atof
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atoi.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atoi.al
new file mode 100755
index 00000000000..57b26c01896
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atoi.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 427 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\atoi.al)"
+sub atoi {
+ unimpl "atoi() is C-specific, stopped";
+}
+
+# end of POSIX::atoi
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atol.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atol.al
new file mode 100755
index 00000000000..f5784993845
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/atol.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 431 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\atol.al)"
+sub atol {
+ unimpl "atol() is C-specific, stopped";
+}
+
+# end of POSIX::atol
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/autosplit.ix
new file mode 100755
index 00000000000..cc56f9ada79
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/autosplit.ix
@@ -0,0 +1,173 @@
+# Index created by AutoSplit for ..\..\lib\POSIX.pm
+# (file acts as timestamp)
+package POSIX;
+sub usage ;
+sub redef ;
+sub unimpl ;
+sub assert ;
+sub tolower ;
+sub toupper ;
+sub closedir ;
+sub opendir ;
+sub readdir ;
+sub rewinddir ;
+sub errno ;
+sub creat ;
+sub fcntl ;
+sub getgrgid ;
+sub getgrnam ;
+sub atan2 ;
+sub cos ;
+sub exp ;
+sub fabs ;
+sub log ;
+sub pow ;
+sub sin ;
+sub sqrt ;
+sub getpwnam ;
+sub getpwuid ;
+sub longjmp ;
+sub setjmp ;
+sub siglongjmp ;
+sub sigsetjmp ;
+sub kill ;
+sub raise ;
+sub offsetof ;
+sub clearerr ;
+sub fclose ;
+sub fdopen ;
+sub feof ;
+sub fgetc ;
+sub fgets ;
+sub fileno ;
+sub fopen ;
+sub fprintf ;
+sub fputc ;
+sub fputs ;
+sub fread ;
+sub freopen ;
+sub fscanf ;
+sub fseek ;
+sub fsync ;
+sub ferror ;
+sub fflush ;
+sub fgetpos ;
+sub fsetpos ;
+sub ftell ;
+sub fwrite ;
+sub getc ;
+sub getchar ;
+sub gets ;
+sub perror ;
+sub printf ;
+sub putc ;
+sub putchar ;
+sub puts ;
+sub remove ;
+sub rename ;
+sub rewind ;
+sub scanf ;
+sub sprintf ;
+sub sscanf ;
+sub tmpfile ;
+sub ungetc ;
+sub vfprintf ;
+sub vprintf ;
+sub vsprintf ;
+sub abs ;
+sub atexit ;
+sub atof ;
+sub atoi ;
+sub atol ;
+sub bsearch ;
+sub calloc ;
+sub div ;
+sub exit ;
+sub free ;
+sub getenv ;
+sub labs ;
+sub ldiv ;
+sub malloc ;
+sub qsort ;
+sub rand ;
+sub realloc ;
+sub srand ;
+sub system ;
+sub memchr ;
+sub memcmp ;
+sub memcpy ;
+sub memmove ;
+sub memset ;
+sub strcat ;
+sub strchr ;
+sub strcmp ;
+sub strcpy ;
+sub strcspn ;
+sub strerror ;
+sub strlen ;
+sub strncat ;
+sub strncmp ;
+sub strncpy ;
+sub strpbrk ;
+sub strrchr ;
+sub strspn ;
+sub strstr ;
+sub strtok ;
+sub chmod ;
+sub fstat ;
+sub mkdir ;
+sub stat ;
+sub umask ;
+sub wait ;
+sub waitpid ;
+sub gmtime ;
+sub localtime ;
+sub time ;
+sub alarm ;
+sub chdir ;
+sub chown ;
+sub execl ;
+sub execle ;
+sub execlp ;
+sub execv ;
+sub execve ;
+sub execvp ;
+sub fork ;
+sub getegid ;
+sub geteuid ;
+sub getgid ;
+sub getgroups ;
+sub getlogin ;
+sub getpgrp ;
+sub getpid ;
+sub getppid ;
+sub getuid ;
+sub isatty ;
+sub link ;
+sub rmdir ;
+sub setbuf ;
+sub setvbuf ;
+sub sleep ;
+sub unlink ;
+sub utime ;
+sub load_imports ;
+package POSIX::SigAction;
+sub new ;
+sub handler ;
+sub mask ;
+sub flags ;
+sub safe ;
+package POSIX::SigRt;
+sub _init ;
+sub _croak ;
+sub _getsig ;
+sub _exist ;
+sub _check ;
+sub new ;
+sub EXISTS ;
+sub FETCH ;
+sub STORE ;
+sub DELETE ;
+sub CLEAR ;
+sub SCALAR ;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/bsearch.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/bsearch.al
new file mode 100755
index 00000000000..617c37ee740
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/bsearch.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 435 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\bsearch.al)"
+sub bsearch {
+ unimpl "bsearch() not supplied";
+}
+
+# end of POSIX::bsearch
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/calloc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/calloc.al
new file mode 100755
index 00000000000..01b6db33ae8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/calloc.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 439 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\calloc.al)"
+sub calloc {
+ unimpl "calloc() is C-specific, stopped";
+}
+
+# end of POSIX::calloc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chdir.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chdir.al
new file mode 100755
index 00000000000..9b6b663387d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chdir.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 636 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\chdir.al)"
+sub chdir {
+ usage "chdir(directory)" if @_ != 1;
+ CORE::chdir($_[0]);
+}
+
+# end of POSIX::chdir
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chmod.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chmod.al
new file mode 100755
index 00000000000..86721b2ae61
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chmod.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 577 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\chmod.al)"
+sub chmod {
+ usage "chmod(mode, filename)" if @_ != 2;
+ CORE::chmod($_[0], $_[1]);
+}
+
+# end of POSIX::chmod
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chown.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chown.al
new file mode 100755
index 00000000000..9c12a41fa04
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/chown.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 641 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\chown.al)"
+sub chown {
+ usage "chown(uid, gid, filename)" if @_ != 3;
+ CORE::chown($_[0], $_[1], $_[2]);
+}
+
+# end of POSIX::chown
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/clearerr.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/clearerr.al
new file mode 100755
index 00000000000..bae5e4f2f1d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/clearerr.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 241 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\clearerr.al)"
+sub clearerr {
+ redef "IO::Handle::clearerr()";
+}
+
+# end of POSIX::clearerr
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/closedir.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/closedir.al
new file mode 100755
index 00000000000..425cbd44126
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/closedir.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 113 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\closedir.al)"
+sub closedir {
+ usage "closedir(dirhandle)" if @_ != 1;
+ CORE::closedir($_[0]);
+}
+
+# end of POSIX::closedir
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/cos.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/cos.al
new file mode 100755
index 00000000000..890ef0c2354
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/cos.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 166 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\cos.al)"
+sub cos {
+ usage "cos(x)" if @_ != 1;
+ CORE::cos($_[0]);
+}
+
+# end of POSIX::cos
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/creat.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/creat.al
new file mode 100755
index 00000000000..5ed2f6eee46
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/creat.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 141 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\creat.al)"
+sub creat {
+ usage "creat(filename, mode)" if @_ != 2;
+ &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]);
+}
+
+# end of POSIX::creat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/div.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/div.al
new file mode 100755
index 00000000000..5871ee1b0de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/div.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 443 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\div.al)"
+sub div {
+ unimpl "div() is C-specific, use /, % and int instead";
+}
+
+# end of POSIX::div
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/errno.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/errno.al
new file mode 100755
index 00000000000..e7362909f46
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/errno.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 136 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\errno.al)"
+sub errno {
+ usage "errno()" if @_ != 0;
+ $! + 0;
+}
+
+# end of POSIX::errno
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execl.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execl.al
new file mode 100755
index 00000000000..33e650902bc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execl.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 646 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\execl.al)"
+sub execl {
+ unimpl "execl() is C-specific, stopped";
+}
+
+# end of POSIX::execl
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execle.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execle.al
new file mode 100755
index 00000000000..43d56a3bda1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execle.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 650 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\execle.al)"
+sub execle {
+ unimpl "execle() is C-specific, stopped";
+}
+
+# end of POSIX::execle
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execlp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execlp.al
new file mode 100755
index 00000000000..093719d84bf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execlp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 654 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\execlp.al)"
+sub execlp {
+ unimpl "execlp() is C-specific, stopped";
+}
+
+# end of POSIX::execlp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execv.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execv.al
new file mode 100755
index 00000000000..76273074eb4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execv.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 658 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\execv.al)"
+sub execv {
+ unimpl "execv() is C-specific, stopped";
+}
+
+# end of POSIX::execv
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execve.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execve.al
new file mode 100755
index 00000000000..33105ccd6fb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execve.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 662 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\execve.al)"
+sub execve {
+ unimpl "execve() is C-specific, stopped";
+}
+
+# end of POSIX::execve
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execvp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execvp.al
new file mode 100755
index 00000000000..4a17521841e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/execvp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 666 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\execvp.al)"
+sub execvp {
+ unimpl "execvp() is C-specific, stopped";
+}
+
+# end of POSIX::execvp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/exit.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/exit.al
new file mode 100755
index 00000000000..559dd68b1e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/exit.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 447 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\exit.al)"
+sub exit {
+ usage "exit(status)" if @_ != 1;
+ CORE::exit($_[0]);
+}
+
+# end of POSIX::exit
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/exp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/exp.al
new file mode 100755
index 00000000000..6c278f38250
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/exp.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 171 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\exp.al)"
+sub exp {
+ usage "exp(x)" if @_ != 1;
+ CORE::exp($_[0]);
+}
+
+# end of POSIX::exp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fabs.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fabs.al
new file mode 100755
index 00000000000..7813dc843b5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fabs.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 176 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fabs.al)"
+sub fabs {
+ usage "fabs(x)" if @_ != 1;
+ CORE::abs($_[0]);
+}
+
+# end of POSIX::fabs
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fclose.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fclose.al
new file mode 100755
index 00000000000..1312109c813
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fclose.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 245 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fclose.al)"
+sub fclose {
+ redef "IO::Handle::close()";
+}
+
+# end of POSIX::fclose
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fcntl.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fcntl.al
new file mode 100755
index 00000000000..4ee8654751c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fcntl.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 146 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fcntl.al)"
+sub fcntl {
+ usage "fcntl(filehandle, cmd, arg)" if @_ != 3;
+ CORE::fcntl($_[0], $_[1], $_[2]);
+}
+
+# end of POSIX::fcntl
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fdopen.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fdopen.al
new file mode 100755
index 00000000000..d700c0d834a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fdopen.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 249 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fdopen.al)"
+sub fdopen {
+ redef "IO::Handle::new_from_fd()";
+}
+
+# end of POSIX::fdopen
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/feof.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/feof.al
new file mode 100755
index 00000000000..917afb91354
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/feof.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 253 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\feof.al)"
+sub feof {
+ redef "IO::Handle::eof()";
+}
+
+# end of POSIX::feof
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ferror.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ferror.al
new file mode 100755
index 00000000000..f253b1b7741
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ferror.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 305 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\ferror.al)"
+sub ferror {
+ redef "IO::Handle::error()";
+}
+
+# end of POSIX::ferror
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fflush.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fflush.al
new file mode 100755
index 00000000000..1f874ceaf89
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fflush.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 309 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fflush.al)"
+sub fflush {
+ redef "IO::Handle::flush()";
+}
+
+# end of POSIX::fflush
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgetc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgetc.al
new file mode 100755
index 00000000000..6832ce432af
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgetc.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 257 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fgetc.al)"
+sub fgetc {
+ redef "IO::Handle::getc()";
+}
+
+# end of POSIX::fgetc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgetpos.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgetpos.al
new file mode 100755
index 00000000000..02294ca2b39
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgetpos.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 313 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fgetpos.al)"
+sub fgetpos {
+ redef "IO::Seekable::getpos()";
+}
+
+# end of POSIX::fgetpos
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgets.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgets.al
new file mode 100755
index 00000000000..c845912c726
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fgets.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 261 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fgets.al)"
+sub fgets {
+ redef "IO::Handle::gets()";
+}
+
+# end of POSIX::fgets
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fileno.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fileno.al
new file mode 100755
index 00000000000..31dc7db13ab
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fileno.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 265 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fileno.al)"
+sub fileno {
+ redef "IO::Handle::fileno()";
+}
+
+# end of POSIX::fileno
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fopen.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fopen.al
new file mode 100755
index 00000000000..da5d546422c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fopen.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 269 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fopen.al)"
+sub fopen {
+ redef "IO::File::open()";
+}
+
+# end of POSIX::fopen
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fork.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fork.al
new file mode 100755
index 00000000000..5596e03901d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fork.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 670 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fork.al)"
+sub fork {
+ usage "fork()" if @_ != 0;
+ CORE::fork;
+}
+
+# end of POSIX::fork
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fprintf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fprintf.al
new file mode 100755
index 00000000000..8a10db84339
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fprintf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 273 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fprintf.al)"
+sub fprintf {
+ unimpl "fprintf() is C-specific--use printf instead";
+}
+
+# end of POSIX::fprintf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fputc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fputc.al
new file mode 100755
index 00000000000..37e5c79fe9d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fputc.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 277 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fputc.al)"
+sub fputc {
+ unimpl "fputc() is C-specific--use print instead";
+}
+
+# end of POSIX::fputc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fputs.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fputs.al
new file mode 100755
index 00000000000..6aeb04ee678
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fputs.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 281 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fputs.al)"
+sub fputs {
+ unimpl "fputs() is C-specific--use print instead";
+}
+
+# end of POSIX::fputs
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fread.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fread.al
new file mode 100755
index 00000000000..f2f56c48f5e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fread.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 285 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fread.al)"
+sub fread {
+ unimpl "fread() is C-specific--use read instead";
+}
+
+# end of POSIX::fread
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/free.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/free.al
new file mode 100755
index 00000000000..1fc25d909e2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/free.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 452 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\free.al)"
+sub free {
+ unimpl "free() is C-specific, stopped";
+}
+
+# end of POSIX::free
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/freopen.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/freopen.al
new file mode 100755
index 00000000000..867307d33f3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/freopen.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 289 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\freopen.al)"
+sub freopen {
+ unimpl "freopen() is C-specific--use open instead";
+}
+
+# end of POSIX::freopen
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fscanf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fscanf.al
new file mode 100755
index 00000000000..4b07b50d257
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fscanf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 293 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fscanf.al)"
+sub fscanf {
+ unimpl "fscanf() is C-specific--use <> and regular expressions instead";
+}
+
+# end of POSIX::fscanf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fseek.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fseek.al
new file mode 100755
index 00000000000..5f65bd0e29a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fseek.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 297 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fseek.al)"
+sub fseek {
+ redef "IO::Seekable::seek()";
+}
+
+# end of POSIX::fseek
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fsetpos.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fsetpos.al
new file mode 100755
index 00000000000..e865a66d01c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fsetpos.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 317 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fsetpos.al)"
+sub fsetpos {
+ redef "IO::Seekable::setpos()";
+}
+
+# end of POSIX::fsetpos
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fstat.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fstat.al
new file mode 100755
index 00000000000..c02f89a3f2f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fstat.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 582 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fstat.al)"
+sub fstat {
+ usage "fstat(fd)" if @_ != 1;
+ local *TMP;
+ CORE::open(TMP, "<&$_[0]"); # Gross.
+ my @l = CORE::stat(TMP);
+ CORE::close(TMP);
+ @l;
+}
+
+# end of POSIX::fstat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fsync.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fsync.al
new file mode 100755
index 00000000000..357f178623d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fsync.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 301 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fsync.al)"
+sub fsync {
+ redef "IO::Handle::sync()";
+}
+
+# end of POSIX::fsync
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ftell.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ftell.al
new file mode 100755
index 00000000000..f1f1754637c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ftell.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 321 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\ftell.al)"
+sub ftell {
+ redef "IO::Seekable::tell()";
+}
+
+# end of POSIX::ftell
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fwrite.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fwrite.al
new file mode 100755
index 00000000000..825f8d7e154
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/fwrite.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 325 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\fwrite.al)"
+sub fwrite {
+ unimpl "fwrite() is C-specific--use print instead";
+}
+
+# end of POSIX::fwrite
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getc.al
new file mode 100755
index 00000000000..6dc4bbe38e7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getc.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 329 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getc.al)"
+sub getc {
+ usage "getc(handle)" if @_ != 1;
+ CORE::getc($_[0]);
+}
+
+# end of POSIX::getc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getchar.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getchar.al
new file mode 100755
index 00000000000..b03a3a30708
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getchar.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 334 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getchar.al)"
+sub getchar {
+ usage "getchar()" if @_ != 0;
+ CORE::getc(STDIN);
+}
+
+# end of POSIX::getchar
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getegid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getegid.al
new file mode 100755
index 00000000000..9d9a7404bcc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getegid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 675 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getegid.al)"
+sub getegid {
+ usage "getegid()" if @_ != 0;
+ $) + 0;
+}
+
+# end of POSIX::getegid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getenv.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getenv.al
new file mode 100755
index 00000000000..db932eacaff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getenv.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 456 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getenv.al)"
+sub getenv {
+ usage "getenv(name)" if @_ != 1;
+ $ENV{$_[0]};
+}
+
+# end of POSIX::getenv
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/geteuid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/geteuid.al
new file mode 100755
index 00000000000..ab000a972c9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/geteuid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 680 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\geteuid.al)"
+sub geteuid {
+ usage "geteuid()" if @_ != 0;
+ $> + 0;
+}
+
+# end of POSIX::geteuid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgid.al
new file mode 100755
index 00000000000..484d13bffb3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 685 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getgid.al)"
+sub getgid {
+ usage "getgid()" if @_ != 0;
+ $( + 0;
+}
+
+# end of POSIX::getgid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgrgid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgrgid.al
new file mode 100755
index 00000000000..3afd5b121a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgrgid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 151 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getgrgid.al)"
+sub getgrgid {
+ usage "getgrgid(gid)" if @_ != 1;
+ CORE::getgrgid($_[0]);
+}
+
+# end of POSIX::getgrgid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgrnam.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgrnam.al
new file mode 100755
index 00000000000..8dcc0fb9eb5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgrnam.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 156 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getgrnam.al)"
+sub getgrnam {
+ usage "getgrnam(name)" if @_ != 1;
+ CORE::getgrnam($_[0]);
+}
+
+# end of POSIX::getgrnam
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgroups.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgroups.al
new file mode 100755
index 00000000000..95dca454d01
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getgroups.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 690 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getgroups.al)"
+sub getgroups {
+ usage "getgroups()" if @_ != 0;
+ my %seen;
+ grep(!$seen{$_}++, split(' ', $) ));
+}
+
+# end of POSIX::getgroups
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getlogin.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getlogin.al
new file mode 100755
index 00000000000..3fd23d795d0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getlogin.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 696 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getlogin.al)"
+sub getlogin {
+ usage "getlogin()" if @_ != 0;
+ CORE::getlogin();
+}
+
+# end of POSIX::getlogin
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpgrp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpgrp.al
new file mode 100755
index 00000000000..4f204a60e60
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpgrp.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 701 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getpgrp.al)"
+sub getpgrp {
+ usage "getpgrp()" if @_ != 0;
+ CORE::getpgrp;
+}
+
+# end of POSIX::getpgrp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpid.al
new file mode 100755
index 00000000000..fe5c3c351cf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 706 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getpid.al)"
+sub getpid {
+ usage "getpid()" if @_ != 0;
+ $$;
+}
+
+# end of POSIX::getpid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getppid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getppid.al
new file mode 100755
index 00000000000..583ada5edba
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getppid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 711 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getppid.al)"
+sub getppid {
+ usage "getppid()" if @_ != 0;
+ CORE::getppid;
+}
+
+# end of POSIX::getppid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpwnam.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpwnam.al
new file mode 100755
index 00000000000..00c3c6a7fda
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpwnam.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 201 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getpwnam.al)"
+sub getpwnam {
+ usage "getpwnam(name)" if @_ != 1;
+ CORE::getpwnam($_[0]);
+}
+
+# end of POSIX::getpwnam
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpwuid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpwuid.al
new file mode 100755
index 00000000000..488bc594a04
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getpwuid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 206 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getpwuid.al)"
+sub getpwuid {
+ usage "getpwuid(uid)" if @_ != 1;
+ CORE::getpwuid($_[0]);
+}
+
+# end of POSIX::getpwuid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/gets.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/gets.al
new file mode 100755
index 00000000000..e703a86f8fb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/gets.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 339 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\gets.al)"
+sub gets {
+ usage "gets()" if @_ != 0;
+ scalar <STDIN>;
+}
+
+# end of POSIX::gets
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getuid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getuid.al
new file mode 100755
index 00000000000..8702cbf6bc5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/getuid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 716 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\getuid.al)"
+sub getuid {
+ usage "getuid()" if @_ != 0;
+ $<;
+}
+
+# end of POSIX::getuid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/gmtime.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/gmtime.al
new file mode 100755
index 00000000000..b976b322410
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/gmtime.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 616 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\gmtime.al)"
+sub gmtime {
+ usage "gmtime(time)" if @_ != 1;
+ CORE::gmtime($_[0]);
+}
+
+# end of POSIX::gmtime
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/isatty.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/isatty.al
new file mode 100755
index 00000000000..a5511b672a0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/isatty.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 721 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\isatty.al)"
+sub isatty {
+ usage "isatty(filehandle)" if @_ != 1;
+ -t $_[0];
+}
+
+# end of POSIX::isatty
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/kill.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/kill.al
new file mode 100755
index 00000000000..193d93e845e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/kill.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 227 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\kill.al)"
+sub kill {
+ usage "kill(pid, sig)" if @_ != 2;
+ CORE::kill $_[1], $_[0];
+}
+
+# end of POSIX::kill
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/labs.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/labs.al
new file mode 100755
index 00000000000..04133e79244
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/labs.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 461 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\labs.al)"
+sub labs {
+ unimpl "labs() is C-specific, use abs instead";
+}
+
+# end of POSIX::labs
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ldiv.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ldiv.al
new file mode 100755
index 00000000000..c6679286485
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ldiv.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 465 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\ldiv.al)"
+sub ldiv {
+ unimpl "ldiv() is C-specific, use /, % and int instead";
+}
+
+# end of POSIX::ldiv
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/link.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/link.al
new file mode 100755
index 00000000000..d68d80dcff6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/link.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 726 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\link.al)"
+sub link {
+ usage "link(oldfilename, newfilename)" if @_ != 2;
+ CORE::link($_[0], $_[1]);
+}
+
+# end of POSIX::link
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/load_imports.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/load_imports.al
new file mode 100755
index 00000000000..cf692f646ae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/load_imports.al
@@ -0,0 +1,230 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 759 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\load_imports.al)"
+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;
+}
+
+# end of POSIX::SigAction::load_imports
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/localtime.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/localtime.al
new file mode 100755
index 00000000000..c2d15ad16ae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/localtime.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 621 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\localtime.al)"
+sub localtime {
+ usage "localtime(time)" if @_ != 1;
+ CORE::localtime($_[0]);
+}
+
+# end of POSIX::localtime
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/log.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/log.al
new file mode 100755
index 00000000000..682dea9598f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/log.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 181 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\log.al)"
+sub log {
+ usage "log(x)" if @_ != 1;
+ CORE::log($_[0]);
+}
+
+# end of POSIX::log
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/longjmp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/longjmp.al
new file mode 100755
index 00000000000..b62bd3c94c2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/longjmp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 211 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\longjmp.al)"
+sub longjmp {
+ unimpl "longjmp() is C-specific: use die instead";
+}
+
+# end of POSIX::longjmp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/malloc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/malloc.al
new file mode 100755
index 00000000000..0922d0174b5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/malloc.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 469 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\malloc.al)"
+sub malloc {
+ unimpl "malloc() is C-specific, stopped";
+}
+
+# end of POSIX::malloc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memchr.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memchr.al
new file mode 100755
index 00000000000..7344db15757
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memchr.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 494 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\memchr.al)"
+sub memchr {
+ unimpl "memchr() is C-specific, use index() instead";
+}
+
+# end of POSIX::memchr
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memcmp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memcmp.al
new file mode 100755
index 00000000000..a5c9844ea0d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memcmp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 498 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\memcmp.al)"
+sub memcmp {
+ unimpl "memcmp() is C-specific, use eq instead";
+}
+
+# end of POSIX::memcmp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memcpy.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memcpy.al
new file mode 100755
index 00000000000..53c62d6bb4e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memcpy.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 502 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\memcpy.al)"
+sub memcpy {
+ unimpl "memcpy() is C-specific, use = instead";
+}
+
+# end of POSIX::memcpy
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memmove.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memmove.al
new file mode 100755
index 00000000000..a3cb8905083
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memmove.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 506 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\memmove.al)"
+sub memmove {
+ unimpl "memmove() is C-specific, use = instead";
+}
+
+# end of POSIX::memmove
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memset.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memset.al
new file mode 100755
index 00000000000..b71c7b65ed3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/memset.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 510 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\memset.al)"
+sub memset {
+ unimpl "memset() is C-specific, use x instead";
+}
+
+# end of POSIX::memset
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/mkdir.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/mkdir.al
new file mode 100755
index 00000000000..290a5df0c80
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/mkdir.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 591 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\mkdir.al)"
+sub mkdir {
+ usage "mkdir(directoryname, mode)" if @_ != 2;
+ CORE::mkdir($_[0], $_[1]);
+}
+
+# end of POSIX::mkdir
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/offsetof.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/offsetof.al
new file mode 100755
index 00000000000..94fb579e749
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/offsetof.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 237 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\offsetof.al)"
+sub offsetof {
+ unimpl "offsetof() is C-specific, stopped";
+}
+
+# end of POSIX::offsetof
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/opendir.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/opendir.al
new file mode 100755
index 00000000000..1112e2eaeb5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/opendir.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 118 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\opendir.al)"
+sub opendir {
+ usage "opendir(directory)" if @_ != 1;
+ my $dirhandle;
+ CORE::opendir($dirhandle, $_[0])
+ ? $dirhandle
+ : undef;
+}
+
+# end of POSIX::opendir
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/perror.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/perror.al
new file mode 100755
index 00000000000..c35baf5a47b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/perror.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 344 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\perror.al)"
+sub perror {
+ print STDERR "@_: " if @_;
+ print STDERR $!,"\n";
+}
+
+# end of POSIX::perror
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/pow.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/pow.al
new file mode 100755
index 00000000000..5cc8fb73a39
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/pow.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 186 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\pow.al)"
+sub pow {
+ usage "pow(x,exponent)" if @_ != 2;
+ $_[0] ** $_[1];
+}
+
+# end of POSIX::pow
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/printf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/printf.al
new file mode 100755
index 00000000000..3c0e704371e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/printf.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 349 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\printf.al)"
+sub printf {
+ usage "printf(pattern, args...)" if @_ < 1;
+ CORE::printf STDOUT @_;
+}
+
+# end of POSIX::printf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/putc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/putc.al
new file mode 100755
index 00000000000..561218c6e7c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/putc.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 354 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\putc.al)"
+sub putc {
+ unimpl "putc() is C-specific--use print instead";
+}
+
+# end of POSIX::putc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/putchar.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/putchar.al
new file mode 100755
index 00000000000..90edc4f1dde
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/putchar.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 358 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\putchar.al)"
+sub putchar {
+ unimpl "putchar() is C-specific--use print instead";
+}
+
+# end of POSIX::putchar
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/puts.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/puts.al
new file mode 100755
index 00000000000..b35380c91b2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/puts.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 362 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\puts.al)"
+sub puts {
+ unimpl "puts() is C-specific--use print instead";
+}
+
+# end of POSIX::puts
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/qsort.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/qsort.al
new file mode 100755
index 00000000000..e0e8438d51e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/qsort.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 473 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\qsort.al)"
+sub qsort {
+ unimpl "qsort() is C-specific, use sort instead";
+}
+
+# end of POSIX::qsort
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/raise.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/raise.al
new file mode 100755
index 00000000000..25998d61b6c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/raise.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 232 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\raise.al)"
+sub raise {
+ usage "raise(sig)" if @_ != 1;
+ CORE::kill $_[0], $$; # Is this good enough?
+}
+
+# end of POSIX::raise
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rand.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rand.al
new file mode 100755
index 00000000000..ea6457f00d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rand.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 477 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\rand.al)"
+sub rand {
+ unimpl "rand() is non-portable, use Perl's rand instead";
+}
+
+# end of POSIX::rand
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/readdir.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/readdir.al
new file mode 100755
index 00000000000..458c7cda637
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/readdir.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 126 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\readdir.al)"
+sub readdir {
+ usage "readdir(dirhandle)" if @_ != 1;
+ CORE::readdir($_[0]);
+}
+
+# end of POSIX::readdir
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/realloc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/realloc.al
new file mode 100755
index 00000000000..a7332965b92
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/realloc.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 481 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\realloc.al)"
+sub realloc {
+ unimpl "realloc() is C-specific, stopped";
+}
+
+# end of POSIX::realloc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/redef.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/redef.al
new file mode 100755
index 00000000000..1d6197f7dc3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/redef.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 85 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\redef.al)"
+sub redef {
+ my ($mess) = @_;
+ croak "Use method $mess instead";
+}
+
+# end of POSIX::redef
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/remove.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/remove.al
new file mode 100755
index 00000000000..32665fa8ea8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/remove.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 366 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\remove.al)"
+sub remove {
+ usage "remove(filename)" if @_ != 1;
+ (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0]);
+}
+
+# end of POSIX::remove
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rename.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rename.al
new file mode 100755
index 00000000000..6d04ef039a8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rename.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 371 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\rename.al)"
+sub rename {
+ usage "rename(oldfilename, newfilename)" if @_ != 2;
+ CORE::rename($_[0], $_[1]);
+}
+
+# end of POSIX::rename
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rewind.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rewind.al
new file mode 100755
index 00000000000..0f97af8f961
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rewind.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 376 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\rewind.al)"
+sub rewind {
+ usage "rewind(filehandle)" if @_ != 1;
+ CORE::seek($_[0],0,0);
+}
+
+# end of POSIX::rewind
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rewinddir.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rewinddir.al
new file mode 100755
index 00000000000..1c960662ea9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rewinddir.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 131 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\rewinddir.al)"
+sub rewinddir {
+ usage "rewinddir(dirhandle)" if @_ != 1;
+ CORE::rewinddir($_[0]);
+}
+
+# end of POSIX::rewinddir
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rmdir.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rmdir.al
new file mode 100755
index 00000000000..54af051f17e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/rmdir.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 731 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\rmdir.al)"
+sub rmdir {
+ usage "rmdir(directoryname)" if @_ != 1;
+ CORE::rmdir($_[0]);
+}
+
+# end of POSIX::rmdir
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/scanf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/scanf.al
new file mode 100755
index 00000000000..7b0784b3831
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/scanf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 381 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\scanf.al)"
+sub scanf {
+ unimpl "scanf() is C-specific--use <> and regular expressions instead";
+}
+
+# end of POSIX::scanf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setbuf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setbuf.al
new file mode 100755
index 00000000000..4b56a02e221
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setbuf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 736 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\setbuf.al)"
+sub setbuf {
+ redef "IO::Handle::setbuf()";
+}
+
+# end of POSIX::setbuf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setjmp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setjmp.al
new file mode 100755
index 00000000000..6154bbf8a44
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setjmp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 215 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\setjmp.al)"
+sub setjmp {
+ unimpl "setjmp() is C-specific: use eval {} instead";
+}
+
+# end of POSIX::setjmp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setvbuf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setvbuf.al
new file mode 100755
index 00000000000..bc45457297a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/setvbuf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 740 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\setvbuf.al)"
+sub setvbuf {
+ redef "IO::Handle::setvbuf()";
+}
+
+# end of POSIX::setvbuf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/siglongjmp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/siglongjmp.al
new file mode 100755
index 00000000000..46abe2bdb96
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/siglongjmp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 219 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\siglongjmp.al)"
+sub siglongjmp {
+ unimpl "siglongjmp() is C-specific: use die instead";
+}
+
+# end of POSIX::siglongjmp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sigsetjmp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sigsetjmp.al
new file mode 100755
index 00000000000..3ba63224a31
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sigsetjmp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 223 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\sigsetjmp.al)"
+sub sigsetjmp {
+ unimpl "sigsetjmp() is C-specific: use eval {} instead";
+}
+
+# end of POSIX::sigsetjmp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sin.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sin.al
new file mode 100755
index 00000000000..d9079ba09c4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sin.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 191 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\sin.al)"
+sub sin {
+ usage "sin(x)" if @_ != 1;
+ CORE::sin($_[0]);
+}
+
+# end of POSIX::sin
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sleep.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sleep.al
new file mode 100755
index 00000000000..05cba00f359
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sleep.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 744 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\sleep.al)"
+sub sleep {
+ usage "sleep(seconds)" if @_ != 1;
+ $_[0] - CORE::sleep($_[0]);
+}
+
+# end of POSIX::sleep
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sprintf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sprintf.al
new file mode 100755
index 00000000000..e32b6749d0f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sprintf.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 385 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\sprintf.al)"
+sub sprintf {
+ usage "sprintf(pattern,args)" if @_ == 0;
+ CORE::sprintf(shift,@_);
+}
+
+# end of POSIX::sprintf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sqrt.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sqrt.al
new file mode 100755
index 00000000000..ea41719f675
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sqrt.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 196 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\sqrt.al)"
+sub sqrt {
+ usage "sqrt(x)" if @_ != 1;
+ CORE::sqrt($_[0]);
+}
+
+# end of POSIX::sqrt
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/srand.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/srand.al
new file mode 100755
index 00000000000..9c8cd65ad95
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/srand.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 485 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\srand.al)"
+sub srand {
+ unimpl "srand()";
+}
+
+# end of POSIX::srand
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sscanf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sscanf.al
new file mode 100755
index 00000000000..a9f418536fd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/sscanf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 390 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\sscanf.al)"
+sub sscanf {
+ unimpl "sscanf() is C-specific--use regular expressions instead";
+}
+
+# end of POSIX::sscanf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/stat.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/stat.al
new file mode 100755
index 00000000000..23373a26950
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/stat.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 596 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\stat.al)"
+sub stat {
+ usage "stat(filename)" if @_ != 1;
+ CORE::stat($_[0]);
+}
+
+# end of POSIX::stat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcat.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcat.al
new file mode 100755
index 00000000000..112037d7bb9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcat.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 514 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strcat.al)"
+sub strcat {
+ unimpl "strcat() is C-specific, use .= instead";
+}
+
+# end of POSIX::strcat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strchr.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strchr.al
new file mode 100755
index 00000000000..0e4d59d4d22
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strchr.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 518 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strchr.al)"
+sub strchr {
+ unimpl "strchr() is C-specific, use index() instead";
+}
+
+# end of POSIX::strchr
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcmp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcmp.al
new file mode 100755
index 00000000000..026444d1aa0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcmp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 522 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strcmp.al)"
+sub strcmp {
+ unimpl "strcmp() is C-specific, use eq instead";
+}
+
+# end of POSIX::strcmp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcpy.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcpy.al
new file mode 100755
index 00000000000..41895d60428
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcpy.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 526 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strcpy.al)"
+sub strcpy {
+ unimpl "strcpy() is C-specific, use = instead";
+}
+
+# end of POSIX::strcpy
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcspn.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcspn.al
new file mode 100755
index 00000000000..e3979bf3673
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strcspn.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 530 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strcspn.al)"
+sub strcspn {
+ unimpl "strcspn() is C-specific, use regular expressions instead";
+}
+
+# end of POSIX::strcspn
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strerror.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strerror.al
new file mode 100755
index 00000000000..4364eb48fec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strerror.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 534 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strerror.al)"
+sub strerror {
+ usage "strerror(errno)" if @_ != 1;
+ local $! = $_[0];
+ $! . "";
+}
+
+# end of POSIX::strerror
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strlen.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strlen.al
new file mode 100755
index 00000000000..2f9ee7bf0a2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strlen.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 540 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strlen.al)"
+sub strlen {
+ unimpl "strlen() is C-specific, use length instead";
+}
+
+# end of POSIX::strlen
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncat.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncat.al
new file mode 100755
index 00000000000..b909bd27c25
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncat.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 544 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strncat.al)"
+sub strncat {
+ unimpl "strncat() is C-specific, use .= instead";
+}
+
+# end of POSIX::strncat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncmp.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncmp.al
new file mode 100755
index 00000000000..dde452e3628
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncmp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 548 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strncmp.al)"
+sub strncmp {
+ unimpl "strncmp() is C-specific, use eq instead";
+}
+
+# end of POSIX::strncmp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncpy.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncpy.al
new file mode 100755
index 00000000000..6b2d97f8202
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strncpy.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 552 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strncpy.al)"
+sub strncpy {
+ unimpl "strncpy() is C-specific, use = instead";
+}
+
+# end of POSIX::strncpy
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strpbrk.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strpbrk.al
new file mode 100755
index 00000000000..b3a1f91897b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strpbrk.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 556 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strpbrk.al)"
+sub strpbrk {
+ unimpl "strpbrk() is C-specific, stopped";
+}
+
+# end of POSIX::strpbrk
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strrchr.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strrchr.al
new file mode 100755
index 00000000000..8b11901a304
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strrchr.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 560 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strrchr.al)"
+sub strrchr {
+ unimpl "strrchr() is C-specific, use rindex() instead";
+}
+
+# end of POSIX::strrchr
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strspn.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strspn.al
new file mode 100755
index 00000000000..098bf697de1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strspn.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 564 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strspn.al)"
+sub strspn {
+ unimpl "strspn() is C-specific, stopped";
+}
+
+# end of POSIX::strspn
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strstr.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strstr.al
new file mode 100755
index 00000000000..ecc94a24f2c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strstr.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 568 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strstr.al)"
+sub strstr {
+ usage "strstr(big, little)" if @_ != 2;
+ CORE::index($_[0], $_[1]);
+}
+
+# end of POSIX::strstr
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strtok.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strtok.al
new file mode 100755
index 00000000000..f065d58b27c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/strtok.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 573 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\strtok.al)"
+sub strtok {
+ unimpl "strtok() is C-specific, stopped";
+}
+
+# end of POSIX::strtok
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/system.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/system.al
new file mode 100755
index 00000000000..17d9b552290
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/system.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 489 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\system.al)"
+sub system {
+ usage "system(command)" if @_ != 1;
+ CORE::system($_[0]);
+}
+
+# end of POSIX::system
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/time.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/time.al
new file mode 100755
index 00000000000..f588c89117f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/time.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 626 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\time.al)"
+sub time {
+ usage "time()" if @_ != 0;
+ CORE::time;
+}
+
+# end of POSIX::time
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/tmpfile.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/tmpfile.al
new file mode 100755
index 00000000000..ebc5850baf8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/tmpfile.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 394 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\tmpfile.al)"
+sub tmpfile {
+ redef "IO::File::new_tmpfile()";
+}
+
+# end of POSIX::tmpfile
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/tolower.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/tolower.al
new file mode 100755
index 00000000000..35a40ad5026
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/tolower.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 103 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\tolower.al)"
+sub tolower {
+ usage "tolower(string)" if @_ != 1;
+ lc($_[0]);
+}
+
+# end of POSIX::tolower
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/toupper.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/toupper.al
new file mode 100755
index 00000000000..47f12bd4932
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/toupper.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 108 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\toupper.al)"
+sub toupper {
+ usage "toupper(string)" if @_ != 1;
+ uc($_[0]);
+}
+
+# end of POSIX::toupper
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/umask.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/umask.al
new file mode 100755
index 00000000000..e1c107c8f44
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/umask.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 601 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\umask.al)"
+sub umask {
+ usage "umask(mask)" if @_ != 1;
+ CORE::umask($_[0]);
+}
+
+# end of POSIX::umask
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ungetc.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ungetc.al
new file mode 100755
index 00000000000..ea27e327c46
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/ungetc.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 398 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\ungetc.al)"
+sub ungetc {
+ redef "IO::Handle::ungetc()";
+}
+
+# end of POSIX::ungetc
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/unimpl.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/unimpl.al
new file mode 100755
index 00000000000..bc48d9b3023
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/unimpl.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 90 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\unimpl.al)"
+sub unimpl {
+ my ($mess) = @_;
+ $mess =~ s/xxx//;
+ croak "Unimplemented: POSIX::$mess";
+}
+
+# end of POSIX::unimpl
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/unlink.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/unlink.al
new file mode 100755
index 00000000000..9a9a0b668b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/unlink.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 749 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\unlink.al)"
+sub unlink {
+ usage "unlink(filename)" if @_ != 1;
+ CORE::unlink($_[0]);
+}
+
+# end of POSIX::unlink
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/usage.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/usage.al
new file mode 100755
index 00000000000..83c0cdf9e8a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/usage.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 80 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\usage.al)"
+sub usage {
+ my ($mess) = @_;
+ croak "Usage: POSIX::$mess";
+}
+
+# end of POSIX::usage
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/utime.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/utime.al
new file mode 100755
index 00000000000..07d84838ab3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/utime.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 754 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\utime.al)"
+sub utime {
+ usage "utime(filename, atime, mtime)" if @_ != 3;
+ CORE::utime($_[1], $_[2], $_[0]);
+}
+
+# end of POSIX::utime
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vfprintf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vfprintf.al
new file mode 100755
index 00000000000..461a48fd006
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vfprintf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 402 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\vfprintf.al)"
+sub vfprintf {
+ unimpl "vfprintf() is C-specific";
+}
+
+# end of POSIX::vfprintf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vprintf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vprintf.al
new file mode 100755
index 00000000000..a0d2bd202fd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vprintf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 406 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\vprintf.al)"
+sub vprintf {
+ unimpl "vprintf() is C-specific";
+}
+
+# end of POSIX::vprintf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vsprintf.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vsprintf.al
new file mode 100755
index 00000000000..835cf3de11c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/vsprintf.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 410 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\vsprintf.al)"
+sub vsprintf {
+ unimpl "vsprintf() is C-specific";
+}
+
+# end of POSIX::vsprintf
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/wait.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/wait.al
new file mode 100755
index 00000000000..fb68d776372
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/wait.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 606 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\wait.al)"
+sub wait {
+ usage "wait()" if @_ != 0;
+ CORE::wait();
+}
+
+# end of POSIX::wait
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/POSIX/waitpid.al b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/waitpid.al
new file mode 100755
index 00000000000..a211a453aa0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/POSIX/waitpid.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\..\lib\POSIX.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package POSIX;
+
+#line 611 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\waitpid.al)"
+sub waitpid {
+ usage "waitpid(pid, options)" if @_ != 2;
+ CORE::waitpid($_[0], $_[1]);
+}
+
+# end of POSIX::waitpid
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PPM/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/PPM/.packlist
new file mode 100755
index 00000000000..9d6668fa195
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PPM/.packlist
@@ -0,0 +1,10 @@
+C:\strawberry\perl\bin\ppm.bat
+C:\strawberry\perl\bin\ppm.pl
+C:\strawberry\perl\vendor\lib\PPM.pm
+C:\strawberry\perl\vendor\lib\PPM\RelocPerl.pm
+C:\strawberry\perl\vendor\lib\PPM\XML\Element.pm
+C:\strawberry\perl\vendor\lib\PPM\XML\PPD.pm
+C:\strawberry\perl\vendor\lib\PPM\XML\PPMConfig.pm
+C:\strawberry\perl\vendor\lib\PPM\XML\RepositorySummary.pm
+C:\strawberry\perl\vendor\lib\PPM\XML\ValidatingElement.pm
+C:\strawberry\perl\vendor\lib\ppm.xml
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/.packlist
new file mode 100755
index 00000000000..95f503fbe12
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Params\Util.pm
+C:\strawberry\perl\vendor\lib\auto\Params\Util\Util.bs
+C:\strawberry\perl\vendor\lib\auto\Params\Util\Util.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.bs b/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.dll b/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.dll
new file mode 100755
index 00000000000..f9e1dfefaae
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Params/Util/Util.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Parse/Binary/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Parse/Binary/.packlist
new file mode 100755
index 00000000000..31b6e608c22
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Parse/Binary/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Parse\Binary.pm
+C:\strawberry\perl\vendor\lib\Parse\Binary\FixedFormat.pm
+C:\strawberry\perl\vendor\lib\Parse\Binary\FixedFormat\Variants.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Parse/CPAN/Meta/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Parse/CPAN/Meta/.packlist
new file mode 100755
index 00000000000..7163740efd6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Parse/CPAN/Meta/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Parse\CPAN\Meta.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/encoding/encoding.dll b/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/encoding/encoding.dll
new file mode 100755
index 00000000000..5ad744a28ff
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/encoding/encoding.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/scalar/scalar.dll b/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/scalar/scalar.dll
new file mode 100755
index 00000000000..3281cdcbd7f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/scalar/scalar.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/via/via.dll b/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/via/via.dll
new file mode 100755
index 00000000000..e45fd37929b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/PerlIO/via/via.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Pod/Perldoc/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Pod/Perldoc/.packlist
new file mode 100755
index 00000000000..78a1948d04a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Pod/Perldoc/.packlist
@@ -0,0 +1,14 @@
+C:\strawberry\perl\bin\perldoc
+C:\strawberry\perl\bin\perldoc.bat
+C:\strawberry\perl\lib\Pod\Perldoc.pm
+C:\strawberry\perl\lib\Pod\Perldoc\BaseTo.pm
+C:\strawberry\perl\lib\Pod\Perldoc\GetOptsOO.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToChecker.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToMan.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToNroff.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToPod.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToRtf.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToText.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToTk.pm
+C:\strawberry\perl\lib\Pod\Perldoc\ToXml.pm
+C:\strawberry\perl\lib\perldoc.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Pod/Plainer/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Pod/Plainer/.packlist
new file mode 100755
index 00000000000..ec34ed7d99f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Pod/Plainer/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Pod\Plainer.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Pod/Simple/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Pod/Simple/.packlist
new file mode 100755
index 00000000000..88e62dfd9fc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Pod/Simple/.packlist
@@ -0,0 +1,32 @@
+C:\strawberry\perl\lib\Pod\Simple.pm
+C:\strawberry\perl\lib\Pod\Simple.pod
+C:\strawberry\perl\lib\Pod\Simple\BlackBox.pm
+C:\strawberry\perl\lib\Pod\Simple\Checker.pm
+C:\strawberry\perl\lib\Pod\Simple\Debug.pm
+C:\strawberry\perl\lib\Pod\Simple\DumpAsText.pm
+C:\strawberry\perl\lib\Pod\Simple\DumpAsXML.pm
+C:\strawberry\perl\lib\Pod\Simple\HTML.pm
+C:\strawberry\perl\lib\Pod\Simple\HTMLBatch.pm
+C:\strawberry\perl\lib\Pod\Simple\HTMLLegacy.pm
+C:\strawberry\perl\lib\Pod\Simple\LinkSection.pm
+C:\strawberry\perl\lib\Pod\Simple\Methody.pm
+C:\strawberry\perl\lib\Pod\Simple\Progress.pm
+C:\strawberry\perl\lib\Pod\Simple\PullParser.pm
+C:\strawberry\perl\lib\Pod\Simple\PullParserEndToken.pm
+C:\strawberry\perl\lib\Pod\Simple\PullParserStartToken.pm
+C:\strawberry\perl\lib\Pod\Simple\PullParserTextToken.pm
+C:\strawberry\perl\lib\Pod\Simple\PullParserToken.pm
+C:\strawberry\perl\lib\Pod\Simple\RTF.pm
+C:\strawberry\perl\lib\Pod\Simple\Search.pm
+C:\strawberry\perl\lib\Pod\Simple\SimpleTree.pm
+C:\strawberry\perl\lib\Pod\Simple\Subclassing.pod
+C:\strawberry\perl\lib\Pod\Simple\Text.pm
+C:\strawberry\perl\lib\Pod\Simple\TextContent.pm
+C:\strawberry\perl\lib\Pod\Simple\TiedOutFH.pm
+C:\strawberry\perl\lib\Pod\Simple\Transcode.pm
+C:\strawberry\perl\lib\Pod\Simple\TranscodeDumb.pm
+C:\strawberry\perl\lib\Pod\Simple\TranscodeSmart.pm
+C:\strawberry\perl\lib\Pod\Simple\XHTML.pm
+C:\strawberry\perl\lib\Pod\Simple\XMLOutStream.pm
+C:\strawberry\perl\lib\perlpod.pod
+C:\strawberry\perl\lib\perlpodspec.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Probe/Perl/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Probe/Perl/.packlist
new file mode 100755
index 00000000000..461b0f88164
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Probe/Perl/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Probe\Perl.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/SDBM_File/SDBM_File.dll b/Master/tlpkg/tlperl.straw/lib/auto/SDBM_File/SDBM_File.dll
new file mode 100755
index 00000000000..083a5362c89
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/SDBM_File/SDBM_File.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Safe/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Safe/.packlist
new file mode 100755
index 00000000000..60280ad5fe1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Safe/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Safe.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Socket/Socket.dll b/Master/tlpkg/tlperl.straw/lib/auto/Socket/Socket.dll
new file mode 100755
index 00000000000..359f3dc7f7c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Socket/Socket.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Sort/Versions/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Sort/Versions/.packlist
new file mode 100755
index 00000000000..6adc0f48d25
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Sort/Versions/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Sort\Versions.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Storable/.packlist
new file mode 100755
index 00000000000..71cadc6ec1c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/.packlist
@@ -0,0 +1,28 @@
+C:\strawberry\perl\lib\Storable.pm
+C:\strawberry\perl\lib\auto\Storable\BIN_VERSION_NV.al
+C:\strawberry\perl\lib\auto\Storable\BIN_WRITE_VERSION_NV.al
+C:\strawberry\perl\lib\auto\Storable\CAN_FLOCK.al
+C:\strawberry\perl\lib\auto\Storable\Storable.bs
+C:\strawberry\perl\lib\auto\Storable\Storable.dll
+C:\strawberry\perl\lib\auto\Storable\_freeze.al
+C:\strawberry\perl\lib\auto\Storable\_retrieve.al
+C:\strawberry\perl\lib\auto\Storable\_store.al
+C:\strawberry\perl\lib\auto\Storable\_store_fd.al
+C:\strawberry\perl\lib\auto\Storable\autosplit.ix
+C:\strawberry\perl\lib\auto\Storable\fd_retrieve.al
+C:\strawberry\perl\lib\auto\Storable\file_magic.al
+C:\strawberry\perl\lib\auto\Storable\freeze.al
+C:\strawberry\perl\lib\auto\Storable\lock_nstore.al
+C:\strawberry\perl\lib\auto\Storable\lock_retrieve.al
+C:\strawberry\perl\lib\auto\Storable\lock_store.al
+C:\strawberry\perl\lib\auto\Storable\logcarp.al
+C:\strawberry\perl\lib\auto\Storable\logcroak.al
+C:\strawberry\perl\lib\auto\Storable\nfreeze.al
+C:\strawberry\perl\lib\auto\Storable\nstore.al
+C:\strawberry\perl\lib\auto\Storable\nstore_fd.al
+C:\strawberry\perl\lib\auto\Storable\read_magic.al
+C:\strawberry\perl\lib\auto\Storable\retrieve.al
+C:\strawberry\perl\lib\auto\Storable\show_file_magic.al
+C:\strawberry\perl\lib\auto\Storable\store.al
+C:\strawberry\perl\lib\auto\Storable\store_fd.al
+C:\strawberry\perl\lib\auto\Storable\thaw.al
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/BIN_VERSION_NV.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/BIN_VERSION_NV.al
new file mode 100755
index 00000000000..bd620b054d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/BIN_VERSION_NV.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 192 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\BIN_VERSION_NV.al)"
+sub BIN_VERSION_NV {
+ sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
+}
+
+# end of Storable::BIN_VERSION_NV
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/BIN_WRITE_VERSION_NV.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/BIN_WRITE_VERSION_NV.al
new file mode 100755
index 00000000000..8a20f970983
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/BIN_WRITE_VERSION_NV.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 196 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\BIN_WRITE_VERSION_NV.al)"
+sub BIN_WRITE_VERSION_NV {
+ sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR();
+}
+
+# end of Storable::BIN_WRITE_VERSION_NV
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/CAN_FLOCK.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/CAN_FLOCK.al
new file mode 100755
index 00000000000..de43b1a3c89
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/CAN_FLOCK.al
@@ -0,0 +1,21 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 83 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\CAN_FLOCK.al)"
+#
+# 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'};
+}
+
+# end of Storable::CAN_FLOCK
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/Storable.bs b/Master/tlpkg/tlperl.straw/lib/auto/Storable/Storable.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/Storable.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/Storable.dll b/Master/tlpkg/tlperl.straw/lib/auto/Storable/Storable.dll
new file mode 100755
index 00000000000..75306d3f82f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/Storable.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/_freeze.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_freeze.al
new file mode 100755
index 00000000000..87918bd5b11
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_freeze.al
@@ -0,0 +1,23 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 330 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\_freeze.al)"
+# 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;
+}
+
+# end of Storable::_freeze
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/_retrieve.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_retrieve.al
new file mode 100755
index 00000000000..5a798322ea8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_retrieve.al
@@ -0,0 +1,31 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 364 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\_retrieve.al)"
+# 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;
+}
+
+# end of Storable::_retrieve
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/_store.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_store.al
new file mode 100755
index 00000000000..9eade5dfe86
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_store.al
@@ -0,0 +1,41 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 239 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\_store.al)"
+# 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;
+}
+
+# end of Storable::_store
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/_store_fd.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_store_fd.al
new file mode 100755
index 00000000000..ce3def2cfc8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/_store_fd.al
@@ -0,0 +1,27 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 292 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\_store_fd.al)"
+# 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;
+}
+
+# end of Storable::_store_fd
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Storable/autosplit.ix
new file mode 100755
index 00000000000..04fcedf21c0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/autosplit.ix
@@ -0,0 +1,28 @@
+# Index created by AutoSplit for blib\lib\Storable.pm
+# (file acts as timestamp)
+package Storable;
+sub logcroak ;
+sub logcarp ;
+sub CAN_FLOCK ;
+sub show_file_magic ;
+sub file_magic ;
+sub read_magic ;
+sub BIN_VERSION_NV ;
+sub BIN_WRITE_VERSION_NV ;
+sub store ;
+sub nstore ;
+sub lock_store ;
+sub lock_nstore ;
+sub _store ;
+sub store_fd ;
+sub nstore_fd ;
+sub _store_fd ;
+sub freeze ;
+sub nfreeze ;
+sub _freeze ;
+sub retrieve ;
+sub lock_retrieve ;
+sub _retrieve ;
+sub fd_retrieve ;
+sub thaw ;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/fd_retrieve.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/fd_retrieve.al
new file mode 100755
index 00000000000..93f9f18a835
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/fd_retrieve.al
@@ -0,0 +1,25 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 387 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\fd_retrieve.al)"
+#
+# 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;
+}
+
+# end of Storable::fd_retrieve
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/file_magic.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/file_magic.al
new file mode 100755
index 00000000000..532ab40ba60
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/file_magic.al
@@ -0,0 +1,21 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 118 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\file_magic.al)"
+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);
+}
+
+# end of Storable::file_magic
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/freeze.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/freeze.al
new file mode 100755
index 00000000000..cb95bf29970
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/freeze.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 311 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\freeze.al)"
+#
+# freeze
+#
+# Store oject and its hierarchy in memory and return a scalar
+# containing the result.
+#
+sub freeze {
+ _freeze(\&mstore, @_);
+}
+
+# end of Storable::freeze
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_nstore.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_nstore.al
new file mode 100755
index 00000000000..acd4cde5650
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_nstore.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 230 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\lock_nstore.al)"
+#
+# lock_nstore
+#
+# Same as nstore, but flock the file first (advisory locking).
+#
+sub lock_nstore {
+ return _store(\&net_pstore, @_, 1);
+}
+
+# end of Storable::lock_nstore
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_retrieve.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_retrieve.al
new file mode 100755
index 00000000000..41290bcd00d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_retrieve.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 355 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\lock_retrieve.al)"
+#
+# lock_retrieve
+#
+# Same as retrieve, but with advisory locking.
+#
+sub lock_retrieve {
+ _retrieve($_[0], 1);
+}
+
+# end of Storable::lock_retrieve
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_store.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_store.al
new file mode 100755
index 00000000000..1c94e960fab
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/lock_store.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 221 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\lock_store.al)"
+#
+# lock_store
+#
+# Same as store, but flock the file first (advisory locking).
+#
+sub lock_store {
+ return _store(\&pstore, @_, 1);
+}
+
+# end of Storable::lock_store
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/logcarp.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/logcarp.al
new file mode 100755
index 00000000000..58642b8ba1f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/logcarp.al
@@ -0,0 +1,12 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 79 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\logcarp.al)"
+sub logcarp {
+ Carp::carp(@_);
+}
+
+# end of Storable::logcarp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/logcroak.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/logcroak.al
new file mode 100755
index 00000000000..fd37cfe86e0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/logcroak.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 70 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\logcroak.al)"
+#
+# 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(@_);
+}
+
+# end of Storable::logcroak
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/nfreeze.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/nfreeze.al
new file mode 100755
index 00000000000..c79d3cf3c3d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/nfreeze.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 321 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\nfreeze.al)"
+#
+# nfreeze
+#
+# Same as freeze but in network order.
+#
+sub nfreeze {
+ _freeze(\&net_mstore, @_);
+}
+
+# end of Storable::nfreeze
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/nstore.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/nstore.al
new file mode 100755
index 00000000000..395635f5e2b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/nstore.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 212 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\nstore.al)"
+#
+# nstore
+#
+# Same as store, but in network order.
+#
+sub nstore {
+ return _store(\&net_pstore, @_, 0);
+}
+
+# end of Storable::nstore
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/nstore_fd.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/nstore_fd.al
new file mode 100755
index 00000000000..bf359c31991
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/nstore_fd.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 282 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\nstore_fd.al)"
+#
+# nstore_fd
+#
+# Same as store_fd, but in network order.
+#
+sub nstore_fd {
+ my ($self, $file) = @_;
+ return _store_fd(\&net_pstore, @_);
+}
+
+# end of Storable::nstore_fd
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/read_magic.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/read_magic.al
new file mode 100755
index 00000000000..f98dbb156c7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/read_magic.al
@@ -0,0 +1,69 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 131 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\read_magic.al)"
+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;
+}
+
+# end of Storable::read_magic
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/retrieve.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/retrieve.al
new file mode 100755
index 00000000000..284565257d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/retrieve.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 345 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\retrieve.al)"
+#
+# retrieve
+#
+# Retrieve object hierarchy from disk, returning a reference to the root
+# object of that tree.
+#
+sub retrieve {
+ _retrieve($_[0], 0);
+}
+
+# end of Storable::retrieve
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/show_file_magic.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/show_file_magic.al
new file mode 100755
index 00000000000..2f7abe325c0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/show_file_magic.al
@@ -0,0 +1,30 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 96 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\show_file_magic.al)"
+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
+}
+
+# end of Storable::show_file_magic
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/store.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/store.al
new file mode 100755
index 00000000000..48ed4b12ac3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/store.al
@@ -0,0 +1,20 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 200 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\store.al)"
+#
+# 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);
+}
+
+# end of Storable::store
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/store_fd.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/store_fd.al
new file mode 100755
index 00000000000..01a5ba2aaeb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/store_fd.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 272 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\store_fd.al)"
+#
+# 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, @_);
+}
+
+# end of Storable::store_fd
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Storable/thaw.al b/Master/tlpkg/tlperl.straw/lib/auto/Storable/thaw.al
new file mode 100755
index 00000000000..5349dfcc054
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Storable/thaw.al
@@ -0,0 +1,28 @@
+# NOTE: Derived from blib\lib\Storable.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Storable;
+
+#line 404 "blib\lib\Storable.pm (autosplit into blib\lib\auto\Storable\thaw.al)"
+#
+# 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__
+
+1;
+# end of Storable::thaw
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/.packlist
new file mode 100755
index 00000000000..ef8c86498b0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\String\CRC32.pm
+C:\strawberry\perl\vendor\lib\String\CRC32.pod
+C:\strawberry\perl\vendor\lib\auto\String\CRC32\CRC32.bs
+C:\strawberry\perl\vendor\lib\auto\String\CRC32\CRC32.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.bs b/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.dll b/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.dll
new file mode 100755
index 00000000000..1848288d9e3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/String/CRC32/CRC32.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Sub/Uplevel/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Sub/Uplevel/.packlist
new file mode 100755
index 00000000000..f3d2f75ec82
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Sub/Uplevel/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\Sub\Uplevel.pm
+C:\strawberry\perl\vendor\lib\Sub\Uplevel.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Switch/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Switch/.packlist
new file mode 100755
index 00000000000..069e96659eb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Switch/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Switch.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/Hostname.dll b/Master/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/Hostname.dll
new file mode 100755
index 00000000000..948ff2f4302
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/Hostname.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/autosplit.ix
new file mode 100755
index 00000000000..f7014ea8d84
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Sys/Hostname/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for ..\..\lib\Sys\Hostname.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Term/ANSIColor/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Term/ANSIColor/.packlist
new file mode 100755
index 00000000000..47117b5ad4e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Term/ANSIColor/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Term\ANSIColor.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.bs b/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.dll b/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.dll
new file mode 100755
index 00000000000..64edbb46e18
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/ReadKey.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/autosplit.ix
new file mode 100755
index 00000000000..0d578a2f538
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Term/ReadKey/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Term/ReadKey.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Deep/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Deep/.packlist
new file mode 100755
index 00000000000..3771ae41e2a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Deep/.packlist
@@ -0,0 +1,42 @@
+C:\strawberry\perl\vendor\lib\Test\Deep.pm
+C:\strawberry\perl\vendor\lib\Test\Deep.pod
+C:\strawberry\perl\vendor\lib\Test\Deep\All.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Any.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Array.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\ArrayEach.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\ArrayElementsOnly.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\ArrayLength.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\ArrayLengthOnly.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Blessed.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Boolean.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Cache.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Cache\Simple.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Class.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Cmp.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Code.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Hash.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\HashEach.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\HashElements.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\HashKeys.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\HashKeysOnly.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Ignore.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Isa.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\ListMethods.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\MM.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Methods.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\NoTest.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Number.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Ref.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\RefType.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Regexp.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\RegexpMatches.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\RegexpOnly.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\RegexpRef.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\RegexpRefOnly.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\RegexpVersion.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\ScalarRef.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\ScalarRefOnly.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Set.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Shallow.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\Stack.pm
+C:\strawberry\perl\vendor\lib\Test\Deep\String.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Exception/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Exception/.packlist
new file mode 100755
index 00000000000..a0e803a6fac
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Exception/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Test\Exception.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Harness/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Harness/.packlist
new file mode 100755
index 00000000000..b51d6118dd9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Harness/.packlist
@@ -0,0 +1,52 @@
+C:\strawberry\perl\bin\prove
+C:\strawberry\perl\bin\prove.bat
+C:\strawberry\perl\lib\App\Prove.pm
+C:\strawberry\perl\lib\App\Prove\State.pm
+C:\strawberry\perl\lib\App\Prove\State\Result.pm
+C:\strawberry\perl\lib\App\Prove\State\Result\Test.pm
+C:\strawberry\perl\lib\TAP\Base.pm
+C:\strawberry\perl\lib\TAP\Formatter\Base.pm
+C:\strawberry\perl\lib\TAP\Formatter\Color.pm
+C:\strawberry\perl\lib\TAP\Formatter\Console.pm
+C:\strawberry\perl\lib\TAP\Formatter\Console\ParallelSession.pm
+C:\strawberry\perl\lib\TAP\Formatter\Console\Session.pm
+C:\strawberry\perl\lib\TAP\Formatter\File.pm
+C:\strawberry\perl\lib\TAP\Formatter\File\Session.pm
+C:\strawberry\perl\lib\TAP\Formatter\Session.pm
+C:\strawberry\perl\lib\TAP\Harness.pm
+C:\strawberry\perl\lib\TAP\Harness\Beyond.pod
+C:\strawberry\perl\lib\TAP\Object.pm
+C:\strawberry\perl\lib\TAP\Parser.pm
+C:\strawberry\perl\lib\TAP\Parser\Aggregator.pm
+C:\strawberry\perl\lib\TAP\Parser\Grammar.pm
+C:\strawberry\perl\lib\TAP\Parser\Iterator.pm
+C:\strawberry\perl\lib\TAP\Parser\IteratorFactory.pm
+C:\strawberry\perl\lib\TAP\Parser\Iterator\Array.pm
+C:\strawberry\perl\lib\TAP\Parser\Iterator\Process.pm
+C:\strawberry\perl\lib\TAP\Parser\Iterator\Stream.pm
+C:\strawberry\perl\lib\TAP\Parser\Multiplexer.pm
+C:\strawberry\perl\lib\TAP\Parser\Result.pm
+C:\strawberry\perl\lib\TAP\Parser\ResultFactory.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\Bailout.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\Comment.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\Plan.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\Pragma.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\Test.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\Unknown.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\Version.pm
+C:\strawberry\perl\lib\TAP\Parser\Result\YAML.pm
+C:\strawberry\perl\lib\TAP\Parser\Scheduler.pm
+C:\strawberry\perl\lib\TAP\Parser\Scheduler\Job.pm
+C:\strawberry\perl\lib\TAP\Parser\Scheduler\Spinner.pm
+C:\strawberry\perl\lib\TAP\Parser\Source.pm
+C:\strawberry\perl\lib\TAP\Parser\SourceHandler.pm
+C:\strawberry\perl\lib\TAP\Parser\SourceHandler\Executable.pm
+C:\strawberry\perl\lib\TAP\Parser\SourceHandler\File.pm
+C:\strawberry\perl\lib\TAP\Parser\SourceHandler\Handle.pm
+C:\strawberry\perl\lib\TAP\Parser\SourceHandler\Perl.pm
+C:\strawberry\perl\lib\TAP\Parser\SourceHandler\RawTAP.pm
+C:\strawberry\perl\lib\TAP\Parser\SourceHandler\pgTAP.pm
+C:\strawberry\perl\lib\TAP\Parser\Utils.pm
+C:\strawberry\perl\lib\TAP\Parser\YAMLish\Reader.pm
+C:\strawberry\perl\lib\TAP\Parser\YAMLish\Writer.pm
+C:\strawberry\perl\lib\Test\Harness.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Manifest/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Manifest/.packlist
new file mode 100755
index 00000000000..7812656ee1a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Manifest/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Test\Manifest.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/NoWarnings/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/NoWarnings/.packlist
new file mode 100755
index 00000000000..6235fd4f35a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/NoWarnings/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\Test\NoWarnings.pm
+C:\strawberry\perl\vendor\lib\Test\NoWarnings\Warning.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Script/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Script/.packlist
new file mode 100755
index 00000000000..140e977675e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Script/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Test\Script.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Simple/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Simple/.packlist
new file mode 100755
index 00000000000..b0c56b22f03
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Simple/.packlist
@@ -0,0 +1,8 @@
+C:\strawberry\perl\lib\Test\Builder.pm
+C:\strawberry\perl\lib\Test\Builder\IO\Scalar.pm
+C:\strawberry\perl\lib\Test\Builder\Module.pm
+C:\strawberry\perl\lib\Test\Builder\Tester.pm
+C:\strawberry\perl\lib\Test\Builder\Tester\Color.pm
+C:\strawberry\perl\lib\Test\More.pm
+C:\strawberry\perl\lib\Test\Simple.pm
+C:\strawberry\perl\lib\Test\Tutorial.pod
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Tester/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Tester/.packlist
new file mode 100755
index 00000000000..6e0646f2efb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Tester/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\Test\Tester.pm
+C:\strawberry\perl\vendor\lib\Test\Tester\Capture.pm
+C:\strawberry\perl\vendor\lib\Test\Tester\CaptureRunner.pm
+C:\strawberry\perl\vendor\lib\Test\Tester\Delegate.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Test/Warn/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Test/Warn/.packlist
new file mode 100755
index 00000000000..6377aa01db4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Test/Warn/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Test\Warn.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Text/Balanced/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Text/Balanced/.packlist
new file mode 100755
index 00000000000..1ca3f88d769
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Text/Balanced/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\Text\Balanced.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Text/Diff/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Text/Diff/.packlist
new file mode 100755
index 00000000000..abb4b3a7fdc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Text/Diff/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\Text\Diff.pm
+C:\strawberry\perl\vendor\lib\Text\Diff\Table.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Text/Glob/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Text/Glob/.packlist
new file mode 100755
index 00000000000..a6ffb2200de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Text/Glob/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Text\Glob.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Text/Soundex/Soundex.dll b/Master/tlpkg/tlperl.straw/lib/auto/Text/Soundex/Soundex.dll
new file mode 100755
index 00000000000..b2f84236216
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Text/Soundex/Soundex.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tie/EncryptedHash/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Tie/EncryptedHash/.packlist
new file mode 100755
index 00000000000..f706ebf120c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tie/EncryptedHash/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Tie\EncryptedHash.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Time/HiRes/HiRes.dll b/Master/tlpkg/tlperl.straw/lib/auto/Time/HiRes/HiRes.dll
new file mode 100755
index 00000000000..c83b3eb2fd9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Time/HiRes/HiRes.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/.packlist
new file mode 100755
index 00000000000..ab048cc2a2a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\lib\Time\Piece.pm
+C:\strawberry\perl\lib\Time\Seconds.pm
+C:\strawberry\perl\lib\auto\Time\Piece\Piece.bs
+C:\strawberry\perl\lib\auto\Time\Piece\Piece.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.bs b/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.dll b/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.dll
new file mode 100755
index 00000000000..ea2b2c1dfb6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Time/Piece/Piece.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Tk/.packlist
new file mode 100755
index 00000000000..135d7140fde
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/.packlist
@@ -0,0 +1,664 @@
+C:\strawberry\perl\bin\gedi
+C:\strawberry\perl\bin\gedi.bat
+C:\strawberry\perl\bin\ptked
+C:\strawberry\perl\bin\ptked.bat
+C:\strawberry\perl\bin\ptksh
+C:\strawberry\perl\bin\ptksh.bat
+C:\strawberry\perl\bin\tkjpeg
+C:\strawberry\perl\bin\tkjpeg.bat
+C:\strawberry\perl\bin\widget
+C:\strawberry\perl\bin\widget.bat
+C:\strawberry\perl\site\lib\Tie\Watch.pm
+C:\strawberry\perl\site\lib\Tk.pm
+C:\strawberry\perl\site\lib\Tk.pod
+C:\strawberry\perl\site\lib\Tk\804delta.pod
+C:\strawberry\perl\site\lib\Tk\Adjuster.pm
+C:\strawberry\perl\site\lib\Tk\Adjuster.pod
+C:\strawberry\perl\site\lib\Tk\After.pm
+C:\strawberry\perl\site\lib\Tk\Animation.pm
+C:\strawberry\perl\site\lib\Tk\Animation.pod
+C:\strawberry\perl\site\lib\Tk\Balloon.pm
+C:\strawberry\perl\site\lib\Tk\Balloon.pod
+C:\strawberry\perl\site\lib\Tk\Bitmap.pm
+C:\strawberry\perl\site\lib\Tk\Bitmap.pod
+C:\strawberry\perl\site\lib\Tk\BrowseEntry.pm
+C:\strawberry\perl\site\lib\Tk\BrowseEntry.pod
+C:\strawberry\perl\site\lib\Tk\Button.pm
+C:\strawberry\perl\site\lib\Tk\Button.pod
+C:\strawberry\perl\site\lib\Tk\Camel.xpm
+C:\strawberry\perl\site\lib\Tk\Canvas.pm
+C:\strawberry\perl\site\lib\Tk\Canvas.pod
+C:\strawberry\perl\site\lib\Tk\Checkbutton.pm
+C:\strawberry\perl\site\lib\Tk\Checkbutton.pod
+C:\strawberry\perl\site\lib\Tk\Clipboard.pm
+C:\strawberry\perl\site\lib\Tk\Clipboard.pod
+C:\strawberry\perl\site\lib\Tk\CmdLine.pm
+C:\strawberry\perl\site\lib\Tk\CmdLine.pod
+C:\strawberry\perl\site\lib\Tk\ColorEdit.xpm
+C:\strawberry\perl\site\lib\Tk\ColorEditor.pm
+C:\strawberry\perl\site\lib\Tk\ColorEditor.pod
+C:\strawberry\perl\site\lib\Tk\Common.pod
+C:\strawberry\perl\site\lib\Tk\Compound.pm
+C:\strawberry\perl\site\lib\Tk\Compound.pod
+C:\strawberry\perl\site\lib\Tk\Config.pm
+C:\strawberry\perl\site\lib\Tk\ConfigSpecs.pod
+C:\strawberry\perl\site\lib\Tk\Configure.pm
+C:\strawberry\perl\site\lib\Tk\Credits
+C:\strawberry\perl\site\lib\Tk\DItem.pod
+C:\strawberry\perl\site\lib\Tk\Derived.pm
+C:\strawberry\perl\site\lib\Tk\Derived.pod
+C:\strawberry\perl\site\lib\Tk\Dialog.pm
+C:\strawberry\perl\site\lib\Tk\Dialog.pod
+C:\strawberry\perl\site\lib\Tk\DialogBox.pm
+C:\strawberry\perl\site\lib\Tk\DialogBox.pod
+C:\strawberry\perl\site\lib\Tk\DirTree.pm
+C:\strawberry\perl\site\lib\Tk\DirTree.pod
+C:\strawberry\perl\site\lib\Tk\Dirlist.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\Common.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\LocalDrop.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\Rect.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\SunConst.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\SunDrop.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\SunSite.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\Win32Drop.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\Win32Site.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\XDNDDrop.pm
+C:\strawberry\perl\site\lib\Tk\DragDrop\XDNDSite.pm
+C:\strawberry\perl\site\lib\Tk\DropSite.pm
+C:\strawberry\perl\site\lib\Tk\DropSite.pod
+C:\strawberry\perl\site\lib\Tk\DummyEncode.pm
+C:\strawberry\perl\site\lib\Tk\English.pm
+C:\strawberry\perl\site\lib\Tk\Entry.pm
+C:\strawberry\perl\site\lib\Tk\Entry.pod
+C:\strawberry\perl\site\lib\Tk\Error.pod
+C:\strawberry\perl\site\lib\Tk\ErrorDialog.pm
+C:\strawberry\perl\site\lib\Tk\Event.pm
+C:\strawberry\perl\site\lib\Tk\Event\IO.pm
+C:\strawberry\perl\site\lib\Tk\Eventloop.pod
+C:\strawberry\perl\site\lib\Tk\FBox.pm
+C:\strawberry\perl\site\lib\Tk\FBox.pod
+C:\strawberry\perl\site\lib\Tk\FileSelect.pm
+C:\strawberry\perl\site\lib\Tk\FileSelect.pod
+C:\strawberry\perl\site\lib\Tk\FloatEntry.pm
+C:\strawberry\perl\site\lib\Tk\Font.pm
+C:\strawberry\perl\site\lib\Tk\Font.pod
+C:\strawberry\perl\site\lib\Tk\Frame.pm
+C:\strawberry\perl\site\lib\Tk\Frame.pod
+C:\strawberry\perl\site\lib\Tk\HList.pm
+C:\strawberry\perl\site\lib\Tk\HList.pod
+C:\strawberry\perl\site\lib\Tk\IO.pm
+C:\strawberry\perl\site\lib\Tk\IO.pod
+C:\strawberry\perl\site\lib\Tk\IconList.pm
+C:\strawberry\perl\site\lib\Tk\IconList.pod
+C:\strawberry\perl\site\lib\Tk\Image.pm
+C:\strawberry\perl\site\lib\Tk\Image.pod
+C:\strawberry\perl\site\lib\Tk\InputO.pod
+C:\strawberry\perl\site\lib\Tk\Internals.pod
+C:\strawberry\perl\site\lib\Tk\ItemStyle.pm
+C:\strawberry\perl\site\lib\Tk\JPEG.pm
+C:\strawberry\perl\site\lib\Tk\LabEntry.pm
+C:\strawberry\perl\site\lib\Tk\LabFrame.pm
+C:\strawberry\perl\site\lib\Tk\LabFrame.pod
+C:\strawberry\perl\site\lib\Tk\LabRadio.pm
+C:\strawberry\perl\site\lib\Tk\Label.pm
+C:\strawberry\perl\site\lib\Tk\Label.pod
+C:\strawberry\perl\site\lib\Tk\Labelframe.pm
+C:\strawberry\perl\site\lib\Tk\Labelframe.pod
+C:\strawberry\perl\site\lib\Tk\Listbox.pm
+C:\strawberry\perl\site\lib\Tk\Listbox.pod
+C:\strawberry\perl\site\lib\Tk\MMtry.pm
+C:\strawberry\perl\site\lib\Tk\MMutil.pm
+C:\strawberry\perl\site\lib\Tk\MainWindow.pm
+C:\strawberry\perl\site\lib\Tk\MainWindow.pod
+C:\strawberry\perl\site\lib\Tk\MakeDepend.pm
+C:\strawberry\perl\site\lib\Tk\Menu.pm
+C:\strawberry\perl\site\lib\Tk\Menu.pod
+C:\strawberry\perl\site\lib\Tk\Menu\Item.pm
+C:\strawberry\perl\site\lib\Tk\Menu\Item.pod
+C:\strawberry\perl\site\lib\Tk\Menubar.pm
+C:\strawberry\perl\site\lib\Tk\Menubutton.pm
+C:\strawberry\perl\site\lib\Tk\Menubutton.pod
+C:\strawberry\perl\site\lib\Tk\Message.pm
+C:\strawberry\perl\site\lib\Tk\Message.pod
+C:\strawberry\perl\site\lib\Tk\MsgBox.pm
+C:\strawberry\perl\site\lib\Tk\MsgBox.pod
+C:\strawberry\perl\site\lib\Tk\Mwm.pod
+C:\strawberry\perl\site\lib\Tk\NBFrame.pm
+C:\strawberry\perl\site\lib\Tk\NoteBook.pm
+C:\strawberry\perl\site\lib\Tk\NoteBook.pod
+C:\strawberry\perl\site\lib\Tk\Optionmenu.pm
+C:\strawberry\perl\site\lib\Tk\Optionmenu.pod
+C:\strawberry\perl\site\lib\Tk\PNG.pm
+C:\strawberry\perl\site\lib\Tk\Pane.pm
+C:\strawberry\perl\site\lib\Tk\Panedwindow.pm
+C:\strawberry\perl\site\lib\Tk\Panedwindow.pod
+C:\strawberry\perl\site\lib\Tk\Photo.pm
+C:\strawberry\perl\site\lib\Tk\Photo.pod
+C:\strawberry\perl\site\lib\Tk\Pixmap.pm
+C:\strawberry\perl\site\lib\Tk\Pixmap.pod
+C:\strawberry\perl\site\lib\Tk\Popup.pod
+C:\strawberry\perl\site\lib\Tk\Pretty.pm
+C:\strawberry\perl\site\lib\Tk\ProgressBar.pm
+C:\strawberry\perl\site\lib\Tk\README.Adjust
+C:\strawberry\perl\site\lib\Tk\ROText.pm
+C:\strawberry\perl\site\lib\Tk\ROText.pod
+C:\strawberry\perl\site\lib\Tk\Radiobutton.pm
+C:\strawberry\perl\site\lib\Tk\Radiobutton.pod
+C:\strawberry\perl\site\lib\Tk\Region.pm
+C:\strawberry\perl\site\lib\Tk\Reindex.pm
+C:\strawberry\perl\site\lib\Tk\ReindexedROText.pm
+C:\strawberry\perl\site\lib\Tk\ReindexedText.pm
+C:\strawberry\perl\site\lib\Tk\Scale.pm
+C:\strawberry\perl\site\lib\Tk\Scale.pod
+C:\strawberry\perl\site\lib\Tk\Scrollbar.pm
+C:\strawberry\perl\site\lib\Tk\Scrollbar.pod
+C:\strawberry\perl\site\lib\Tk\Scrolled.pod
+C:\strawberry\perl\site\lib\Tk\Spinbox.pm
+C:\strawberry\perl\site\lib\Tk\Spinbox.pod
+C:\strawberry\perl\site\lib\Tk\Stats.pm
+C:\strawberry\perl\site\lib\Tk\Submethods.pm
+C:\strawberry\perl\site\lib\Tk\Submethods.pod
+C:\strawberry\perl\site\lib\Tk\SunConst.pod
+C:\strawberry\perl\site\lib\Tk\TList.pm
+C:\strawberry\perl\site\lib\Tk\TList.pod
+C:\strawberry\perl\site\lib\Tk\Table.pm
+C:\strawberry\perl\site\lib\Tk\Table.pod
+C:\strawberry\perl\site\lib\Tk\Tcl-perl.pod
+C:\strawberry\perl\site\lib\Tk\Text.pm
+C:\strawberry\perl\site\lib\Tk\Text.pod
+C:\strawberry\perl\site\lib\Tk\TextEdit.pm
+C:\strawberry\perl\site\lib\Tk\TextList.pm
+C:\strawberry\perl\site\lib\Tk\TextUndo.pm
+C:\strawberry\perl\site\lib\Tk\TextUndo.pod
+C:\strawberry\perl\site\lib\Tk\Text\Tag.pm
+C:\strawberry\perl\site\lib\Tk\Tiler.pm
+C:\strawberry\perl\site\lib\Tk\Tiler.pod
+C:\strawberry\perl\site\lib\Tk\TixGrid.pm
+C:\strawberry\perl\site\lib\Tk\TixGrid.pod
+C:\strawberry\perl\site\lib\Tk\Tk.xbm
+C:\strawberry\perl\site\lib\Tk\Tk.xpm
+C:\strawberry\perl\site\lib\Tk\TkXSUB.def
+C:\strawberry\perl\site\lib\Tk\Toplevel.pm
+C:\strawberry\perl\site\lib\Tk\Toplevel.pod
+C:\strawberry\perl\site\lib\Tk\Trace.pm
+C:\strawberry\perl\site\lib\Tk\Tree.pm
+C:\strawberry\perl\site\lib\Tk\Tree.pod
+C:\strawberry\perl\site\lib\Tk\UserGuide.pod
+C:\strawberry\perl\site\lib\Tk\Widget.pm
+C:\strawberry\perl\site\lib\Tk\Widget.pod
+C:\strawberry\perl\site\lib\Tk\WidgetDemo.pod
+C:\strawberry\perl\site\lib\Tk\Wm.pm
+C:\strawberry\perl\site\lib\Tk\Wm.pod
+C:\strawberry\perl\site\lib\Tk\X.pm
+C:\strawberry\perl\site\lib\Tk\X.pod
+C:\strawberry\perl\site\lib\Tk\X11Font.pm
+C:\strawberry\perl\site\lib\Tk\X11Font.pod
+C:\strawberry\perl\site\lib\Tk\X11\X.h
+C:\strawberry\perl\site\lib\Tk\X11\Xatom.h
+C:\strawberry\perl\site\lib\Tk\X11\Xfuncproto.h
+C:\strawberry\perl\site\lib\Tk\X11\Xlib.h
+C:\strawberry\perl\site\lib\Tk\X11\Xutil.h
+C:\strawberry\perl\site\lib\Tk\X11\cursorfont.h
+C:\strawberry\perl\site\lib\Tk\X11\keysym.h
+C:\strawberry\perl\site\lib\Tk\X11\keysymdef.h
+C:\strawberry\perl\site\lib\Tk\X11\license.terms
+C:\strawberry\perl\site\lib\Tk\Xcamel.gif
+C:\strawberry\perl\site\lib\Tk\Xlib.pm
+C:\strawberry\perl\site\lib\Tk\Xrm.pm
+C:\strawberry\perl\site\lib\Tk\Xrm.pod
+C:\strawberry\perl\site\lib\Tk\act_folder.xbm
+C:\strawberry\perl\site\lib\Tk\act_folder.xpm
+C:\strawberry\perl\site\lib\Tk\after.pod
+C:\strawberry\perl\site\lib\Tk\anim.gif
+C:\strawberry\perl\site\lib\Tk\arrowdownwin.xbm
+C:\strawberry\perl\site\lib\Tk\balArrow.xbm
+C:\strawberry\perl\site\lib\Tk\bind.pod
+C:\strawberry\perl\site\lib\Tk\bindtags.pod
+C:\strawberry\perl\site\lib\Tk\callbacks.pod
+C:\strawberry\perl\site\lib\Tk\cbxarrow.xbm
+C:\strawberry\perl\site\lib\Tk\chooseColor.pod
+C:\strawberry\perl\site\lib\Tk\chooseDirectory.pod
+C:\strawberry\perl\site\lib\Tk\composite.pod
+C:\strawberry\perl\site\lib\Tk\demos\LabEnLabRad.pm
+C:\strawberry\perl\site\lib\Tk\demos\images\QuitPB.xpm
+C:\strawberry\perl\site\lib\Tk\demos\images\QuitPBa.xpm
+C:\strawberry\perl\site\lib\Tk\demos\images\c.icon
+C:\strawberry\perl\site\lib\Tk\demos\images\cursor.cur
+C:\strawberry\perl\site\lib\Tk\demos\images\cursor.mask
+C:\strawberry\perl\site\lib\Tk\demos\images\cursor.xbm
+C:\strawberry\perl\site\lib\Tk\demos\images\dir.icon
+C:\strawberry\perl\site\lib\Tk\demos\images\dir.mask
+C:\strawberry\perl\site\lib\Tk\demos\images\earth.gif
+C:\strawberry\perl\site\lib\Tk\demos\images\earthris.gif
+C:\strawberry\perl\site\lib\Tk\demos\images\face
+C:\strawberry\perl\site\lib\Tk\demos\images\flagdown
+C:\strawberry\perl\site\lib\Tk\demos\images\flagup
+C:\strawberry\perl\site\lib\Tk\demos\images\grey.25
+C:\strawberry\perl\site\lib\Tk\demos\images\grey.5
+C:\strawberry\perl\site\lib\Tk\demos\images\letters
+C:\strawberry\perl\site\lib\Tk\demos\images\mickey.gif
+C:\strawberry\perl\site\lib\Tk\demos\images\ned.xpm
+C:\strawberry\perl\site\lib\Tk\demos\images\noletters
+C:\strawberry\perl\site\lib\Tk\demos\images\page.icon
+C:\strawberry\perl\site\lib\Tk\demos\images\page.mask
+C:\strawberry\perl\site\lib\Tk\demos\images\pattern
+C:\strawberry\perl\site\lib\Tk\demos\images\teapot.ppm
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\Ball.pm
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\HList.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\HList2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\Plot.pm
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\WidgetDemo.pm
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\arrows.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\balloon.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\bind.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\bitmaps.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\bounce.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\browseentry.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\browseentry2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\button.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\check.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\choosedir.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\clrpick.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\colors.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\cscroll.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\ctext.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\dialog1.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\dialog2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\dirtree.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\entry1.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\entry2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\entry3.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\filebox.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\floor.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\form.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\form_mgr.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\hello.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\hscale.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\icon.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\image1.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\image2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\items.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\keysyms.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\labelframe.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\labels.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\labframe.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\mega.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\menbut.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\menus.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\menus2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\msgBox.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\notebook.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\paned1.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\paned2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\photo1.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\photo2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\plot.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\progress.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\puzzle.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\radio.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\ruler.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\sayings.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\search.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\showVars.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\slide.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\spin.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\states.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\style.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\texts.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\trace1.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\trace2.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\transtile.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\twind.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\unicodeout.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\virtevents1.pl
+C:\strawberry\perl\site\lib\Tk\demos\widget_lib\vscale.pl
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\Gedi.pl
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\TEMPLATE.pl
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\Tiler.pl
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\all.pl
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\cursor.pl
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\lib\npuz\Xcamel.npuz
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\npuz.pl
+C:\strawberry\perl\site\lib\Tk\demos\widtrib\plop.pl
+C:\strawberry\perl\site\lib\Tk\event.pod
+C:\strawberry\perl\site\lib\Tk\exit.pod
+C:\strawberry\perl\site\lib\Tk\file.xbm
+C:\strawberry\perl\site\lib\Tk\file.xpm
+C:\strawberry\perl\site\lib\Tk\fileevent.pod
+C:\strawberry\perl\site\lib\Tk\focus.pod
+C:\strawberry\perl\site\lib\Tk\folder.xbm
+C:\strawberry\perl\site\lib\Tk\folder.xpm
+C:\strawberry\perl\site\lib\Tk\form.pod
+C:\strawberry\perl\site\lib\Tk\getOpenFile.pod
+C:\strawberry\perl\site\lib\Tk\grab.pod
+C:\strawberry\perl\site\lib\Tk\grid.pod
+C:\strawberry\perl\site\lib\Tk\icon.gif
+C:\strawberry\perl\site\lib\Tk\install.pm
+C:\strawberry\perl\site\lib\Tk\license.terms
+C:\strawberry\perl\site\lib\Tk\mega.pod
+C:\strawberry\perl\site\lib\Tk\messageBox.pod
+C:\strawberry\perl\site\lib\Tk\openfile.xbm
+C:\strawberry\perl\site\lib\Tk\openfolder.xbm
+C:\strawberry\perl\site\lib\Tk\openfolder.xpm
+C:\strawberry\perl\site\lib\Tk\option.pod
+C:\strawberry\perl\site\lib\Tk\options.pod
+C:\strawberry\perl\site\lib\Tk\overview.pod
+C:\strawberry\perl\site\lib\Tk\pTk.pod
+C:\strawberry\perl\site\lib\Tk\pTk\Lang.h
+C:\strawberry\perl\site\lib\Tk\pTk\Lang.m
+C:\strawberry\perl\site\lib\Tk\pTk\Lang.t
+C:\strawberry\perl\site\lib\Tk\pTk\Lang_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\Tcl-pTk
+C:\strawberry\perl\site\lib\Tk\pTk\Xlib.h
+C:\strawberry\perl\site\lib\Tk\pTk\Xlib.m
+C:\strawberry\perl\site\lib\Tk\pTk\Xlib.t
+C:\strawberry\perl\site\lib\Tk\pTk\Xlib_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\compat\limits.h
+C:\strawberry\perl\site\lib\Tk\pTk\compat\stdlib.h
+C:\strawberry\perl\site\lib\Tk\pTk\compat\unistd.h
+C:\strawberry\perl\site\lib\Tk\pTk\default.h
+C:\strawberry\perl\site\lib\Tk\pTk\img.h
+C:\strawberry\perl\site\lib\Tk\pTk\imgInt.h
+C:\strawberry\perl\site\lib\Tk\pTk\imgInt.m
+C:\strawberry\perl\site\lib\Tk\pTk\imgInt.t
+C:\strawberry\perl\site\lib\Tk\pTk\imgInt_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\ks_names.h
+C:\strawberry\perl\site\lib\Tk\pTk\mkVFunc
+C:\strawberry\perl\site\lib\Tk\pTk\moredefs.h
+C:\strawberry\perl\site\lib\Tk\pTk\port.h
+C:\strawberry\perl\site\lib\Tk\pTk\tcl.h
+C:\strawberry\perl\site\lib\Tk\pTk\tclDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tclDecls.m
+C:\strawberry\perl\site\lib\Tk\pTk\tclDecls.t
+C:\strawberry\perl\site\lib\Tk\pTk\tclDecls_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tclIntDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tclIntPlatDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tclMath.h
+C:\strawberry\perl\site\lib\Tk\pTk\tclPlatDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tclWinInt.h
+C:\strawberry\perl\site\lib\Tk\pTk\tix.h
+C:\strawberry\perl\site\lib\Tk\pTk\tix.m
+C:\strawberry\perl\site\lib\Tk\pTk\tix.t
+C:\strawberry\perl\site\lib\Tk\pTk\tixBitmaps.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixDef.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixForm.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixGrData.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixGrid.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixHList.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixImgXpm.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixImgXpm.m
+C:\strawberry\perl\site\lib\Tk\pTk\tixImgXpm.t
+C:\strawberry\perl\site\lib\Tk\pTk\tixImgXpm_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixInt.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixInt.m
+C:\strawberry\perl\site\lib\Tk\pTk\tixInt.t
+C:\strawberry\perl\site\lib\Tk\pTk\tixInt_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixPort.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixTList.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixWinInt.h
+C:\strawberry\perl\site\lib\Tk\pTk\tixWinPort.h
+C:\strawberry\perl\site\lib\Tk\pTk\tix_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tk.h
+C:\strawberry\perl\site\lib\Tk\pTk\tk.m
+C:\strawberry\perl\site\lib\Tk\pTk\tk.t
+C:\strawberry\perl\site\lib\Tk\pTk\tk3d.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkButton.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkCanvas.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkCanvases.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkColor.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkConfig.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkDecls.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkDecls.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkDecls_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkEvent.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkEvent.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkEvent.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkEvent_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkFileFilter.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkFont.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkImgPhoto.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkImgPhoto.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkImgPhoto.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkImgPhoto_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkInitScript.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkInt.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkInt.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkInt.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntDecls.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntDecls.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntDecls_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntPlatDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntPlatDecls.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntPlatDecls.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntPlatDecls_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntXlibDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntXlibDecls.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntXlibDecls.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkIntXlibDecls_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkInt_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkMenu.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkMenubutton.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkOption.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkOption.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkOption.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkOption_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkPlatDecls.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkPlatDecls.m
+C:\strawberry\perl\site\lib\Tk\pTk\tkPlatDecls.t
+C:\strawberry\perl\site\lib\Tk\pTk\tkPlatDecls_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkPort.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkScale.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkScrollbar.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkSelect.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkText.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkUndo.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkVMacro.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkWin.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkWinDefault.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkWinInt.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkWinPort.h
+C:\strawberry\perl\site\lib\Tk\pTk\tkXrm.h
+C:\strawberry\perl\site\lib\Tk\pTk\tk_f.h
+C:\strawberry\perl\site\lib\Tk\pTk\xbytes.h
+C:\strawberry\perl\site\lib\Tk\pack.pod
+C:\strawberry\perl\site\lib\Tk\palette.pod
+C:\strawberry\perl\site\lib\Tk\place.pod
+C:\strawberry\perl\site\lib\Tk\prolog.ps
+C:\strawberry\perl\site\lib\Tk\reindex.pl
+C:\strawberry\perl\site\lib\Tk\selection.pod
+C:\strawberry\perl\site\lib\Tk\send.pod
+C:\strawberry\perl\site\lib\Tk\srcfile.xpm
+C:\strawberry\perl\site\lib\Tk\textfile.xpm
+C:\strawberry\perl\site\lib\Tk\tixWm.pod
+C:\strawberry\perl\site\lib\Tk\tkGlue.def
+C:\strawberry\perl\site\lib\Tk\tkGlue.h
+C:\strawberry\perl\site\lib\Tk\tkGlue.m
+C:\strawberry\perl\site\lib\Tk\tkGlue.t
+C:\strawberry\perl\site\lib\Tk\tkGlue_f.h
+C:\strawberry\perl\site\lib\Tk\tkvars.pod
+C:\strawberry\perl\site\lib\Tk\tranicon.gif
+C:\strawberry\perl\site\lib\Tk\typemap
+C:\strawberry\perl\site\lib\Tk\vtab.def
+C:\strawberry\perl\site\lib\Tk\widgets.pm
+C:\strawberry\perl\site\lib\Tk\widgets.pod
+C:\strawberry\perl\site\lib\Tk\win.xbm
+C:\strawberry\perl\site\lib\Tk\winfolder.xpm
+C:\strawberry\perl\site\lib\Tk\wintext.xpm
+C:\strawberry\perl\site\lib\auto\Tk\CancelRepeat.al
+C:\strawberry\perl\site\lib\auto\Tk\Canvas\Canvas.bs
+C:\strawberry\perl\site\lib\auto\Tk\Canvas\Canvas.dll
+C:\strawberry\perl\site\lib\auto\Tk\Clipboard\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Clipboard\getSelected.al
+C:\strawberry\perl\site\lib\auto\Tk\Compound\Compound.bs
+C:\strawberry\perl\site\lib\auto\Tk\Compound\Compound.dll
+C:\strawberry\perl\site\lib\auto\Tk\DragDrop\Win32Site\Win32Site.bs
+C:\strawberry\perl\site\lib\auto\Tk\DragDrop\Win32Site\Win32Site.dll
+C:\strawberry\perl\site\lib\auto\Tk\EnterFocus.al
+C:\strawberry\perl\site\lib\auto\Tk\Entry\Entry.bs
+C:\strawberry\perl\site\lib\auto\Tk\Entry\Entry.dll
+C:\strawberry\perl\site\lib\auto\Tk\Error.al
+C:\strawberry\perl\site\lib\auto\Tk\Event\Event.bs
+C:\strawberry\perl\site\lib\auto\Tk\Event\Event.dll
+C:\strawberry\perl\site\lib\auto\Tk\FirstMenu.al
+C:\strawberry\perl\site\lib\auto\Tk\FocusChildren.al
+C:\strawberry\perl\site\lib\auto\Tk\FocusOK.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\AddScrollbars.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\FindMenu.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Frame\freeze_on_map.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\label.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\labelPack.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\labelVariable.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\packscrollbars.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\queuePack.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\sbset.al
+C:\strawberry\perl\site\lib\auto\Tk\Frame\scrollbars.al
+C:\strawberry\perl\site\lib\auto\Tk\HList\HList.bs
+C:\strawberry\perl\site\lib\auto\Tk\HList\HList.dll
+C:\strawberry\perl\site\lib\auto\Tk\IO\IO.bs
+C:\strawberry\perl\site\lib\auto\Tk\IO\IO.dll
+C:\strawberry\perl\site\lib\auto\Tk\ImageNames.al
+C:\strawberry\perl\site\lib\auto\Tk\ImageTypes.al
+C:\strawberry\perl\site\lib\auto\Tk\JPEG\JPEG.bs
+C:\strawberry\perl\site\lib\auto\Tk\JPEG\JPEG.dll
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\AutoScan.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\BeginExtend.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\BeginSelect.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\BeginToggle.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\ButtonRelease_1.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\CLEAR.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\Cancel.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\Cntrl_End.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\Cntrl_Home.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\Cntrl_backslash.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\DELETE.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\DataExtend.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\EXISTS.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\EXTEND.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\ExtendUpDown.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\FETCH.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\FETCHSIZE.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\Listbox.bs
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\Listbox.dll
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\Motion.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\POP.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\PUSH.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\SHIFT.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\SPLICE.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\STORE.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\SelectAll.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\SetList.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\TIEARRAY.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\TIESCALAR.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\UNSHIFT.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\UpDown.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\clipboardPaste.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\deleteSelected.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\getSelected.al
+C:\strawberry\perl\site\lib\auto\Tk\Listbox\xyIndex.al
+C:\strawberry\perl\site\lib\auto\Tk\Menubutton\Menubutton.bs
+C:\strawberry\perl\site\lib\auto\Tk\Menubutton\Menubutton.dll
+C:\strawberry\perl\site\lib\auto\Tk\NBFrame\NBFrame.bs
+C:\strawberry\perl\site\lib\auto\Tk\NBFrame\NBFrame.dll
+C:\strawberry\perl\site\lib\auto\Tk\PNG\PNG.bs
+C:\strawberry\perl\site\lib\auto\Tk\PNG\PNG.dll
+C:\strawberry\perl\site\lib\auto\Tk\Pixmap\Pixmap.bs
+C:\strawberry\perl\site\lib\auto\Tk\Pixmap\Pixmap.dll
+C:\strawberry\perl\site\lib\auto\Tk\Receive.al
+C:\strawberry\perl\site\lib\auto\Tk\RepeatId.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\Activate.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\ButtonDown.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\ButtonUp.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\ControlPress.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\Drag.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\EndDrag.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\Enter.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\Increment.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\Leave.al
+C:\strawberry\perl\site\lib\auto\Tk\Scale\Scale.bs
+C:\strawberry\perl\site\lib\auto\Tk\Scale\Scale.dll
+C:\strawberry\perl\site\lib\auto\Tk\Scale\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\ButtonDown.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\ButtonUp.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\Drag.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\EndDrag.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\Enter.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\Leave.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\Motion.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\ScrlByPages.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\ScrlByUnits.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\ScrlToPos.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\ScrlTopBottom.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\Scrollbar.bs
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\Scrollbar.dll
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\Select.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\StartDrag.al
+C:\strawberry\perl\site\lib\auto\Tk\Scrollbar\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Selection.al
+C:\strawberry\perl\site\lib\auto\Tk\TList\TList.bs
+C:\strawberry\perl\site\lib\auto\Tk\TList\TList.dll
+C:\strawberry\perl\site\lib\auto\Tk\Table\Create.al
+C:\strawberry\perl\site\lib\auto\Tk\Table\Posn.al
+C:\strawberry\perl\site\lib\auto\Tk\Table\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Table\see.al
+C:\strawberry\perl\site\lib\auto\Tk\Table\totalColumns.al
+C:\strawberry\perl\site\lib\auto\Tk\Table\totalRows.al
+C:\strawberry\perl\site\lib\auto\Tk\TextEdit\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\TextUndo\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Text\Text.bs
+C:\strawberry\perl\site\lib\auto\Tk\Text\Text.dll
+C:\strawberry\perl\site\lib\auto\Tk\Text\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\TixGrid\TixGrid.bs
+C:\strawberry\perl\site\lib\auto\Tk\TixGrid\TixGrid.dll
+C:\strawberry\perl\site\lib\auto\Tk\Tk.bs
+C:\strawberry\perl\site\lib\auto\Tk\Tk.dll
+C:\strawberry\perl\site\lib\auto\Tk\Toplevel\FG_BindIn.al
+C:\strawberry\perl\site\lib\auto\Tk\Toplevel\FG_BindOut.al
+C:\strawberry\perl\site\lib\auto\Tk\Toplevel\FG_Create.al
+C:\strawberry\perl\site\lib\auto\Tk\Toplevel\FG_Destroy.al
+C:\strawberry\perl\site\lib\auto\Tk\Toplevel\FG_In.al
+C:\strawberry\perl\site\lib\auto\Tk\Toplevel\FG_Out.al
+C:\strawberry\perl\site\lib\auto\Tk\Toplevel\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\TraverseToMenu.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\ASkludge.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\AltKeyInDialog.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\AmpWidget.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\FindAltKeyTarget.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\MasterMenu.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\RestoreFocusGrab.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\SetAmpText.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\SetFocusGrab.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\UnderlineAmpersand.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Widget\bindDump.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\clipboardKeysyms.al
+C:\strawberry\perl\site\lib\auto\Tk\Widget\pathname.al
+C:\strawberry\perl\site\lib\auto\Tk\Wm\AnchorAdjust.al
+C:\strawberry\perl\site\lib\auto\Tk\Wm\FullScreen.al
+C:\strawberry\perl\site\lib\auto\Tk\Wm\Popup.al
+C:\strawberry\perl\site\lib\auto\Tk\Wm\Post.al
+C:\strawberry\perl\site\lib\auto\Tk\Wm\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Wm\iconposition.al
+C:\strawberry\perl\site\lib\auto\Tk\X\X.bs
+C:\strawberry\perl\site\lib\auto\Tk\X\X.dll
+C:\strawberry\perl\site\lib\auto\Tk\X\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\Xlib\Xlib.bs
+C:\strawberry\perl\site\lib\auto\Tk\Xlib\Xlib.dll
+C:\strawberry\perl\site\lib\auto\Tk\autosplit.ix
+C:\strawberry\perl\site\lib\auto\Tk\break.al
+C:\strawberry\perl\site\lib\auto\Tk\focusFollowsMouse.al
+C:\strawberry\perl\site\lib\auto\Tk\focusNext.al
+C:\strawberry\perl\site\lib\auto\Tk\focusPrev.al
+C:\strawberry\perl\site\lib\auto\Tk\getEncoding.al
+C:\strawberry\perl\site\lib\auto\Tk\getNextFocus.al
+C:\strawberry\perl\site\lib\auto\Tk\getPrevFocus.al
+C:\strawberry\perl\site\lib\auto\Tk\interps.al
+C:\strawberry\perl\site\lib\auto\Tk\lsearch.al
+C:\strawberry\perl\site\lib\auto\Tk\pTk\extralibs.ld
+C:\strawberry\perl\site\lib\auto\Tk\tabFocus.al
+C:\strawberry\perl\site\lib\auto\Tk\updateWidgets.al
+C:\strawberry\perl\site\lib\fix_4_os2.pl
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/CancelRepeat.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/CancelRepeat.al
new file mode 100755
index 00000000000..ca82516a200
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/CancelRepeat.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 508 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\CancelRepeat.al)"
+sub CancelRepeat
+{
+ my $w = shift->MainWindow;
+ my $id = delete $w->{_afterId_};
+ $w->after('cancel',$id) if (defined $id);
+}
+
+# end of Tk::CancelRepeat
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.dll
new file mode 100755
index 00000000000..fbf6d021ad5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Canvas/Canvas.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/autosplit.ix
new file mode 100755
index 00000000000..9831f74facb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/autosplit.ix
@@ -0,0 +1,6 @@
+# Index created by AutoSplit for blib\lib\Tk\Clipboard.pm
+# (file acts as timestamp)
+package Tk::Clipboard;
+sub getSelected
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/getSelected.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/getSelected.al
new file mode 100755
index 00000000000..44ba7b74bf0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Clipboard/getSelected.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Tk\Clipboard.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Clipboard;
+
+#line 115 "blib\lib\Tk\Clipboard.pm (autosplit into blib\lib\auto\Tk\Clipboard\getSelected.al)"
+sub getSelected
+{
+ my $w = shift;
+ my $val = Tk::catch { $w->get('sel.first','sel.last') };
+ return $val;
+}
+
+1;
+# end of Tk::Clipboard::getSelected
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.dll
new file mode 100755
index 00000000000..66c510b1724
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Compound/Compound.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll
new file mode 100755
index 00000000000..86fca69122d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/EnterFocus.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/EnterFocus.al
new file mode 100755
index 00000000000..e5a09f65466
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/EnterFocus.al
@@ -0,0 +1,27 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 692 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\EnterFocus.al)"
+# 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');
+}
+
+# end of Tk::EnterFocus
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.dll
new file mode 100755
index 00000000000..aa9476cb0b8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Entry/Entry.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Error.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Error.al
new file mode 100755
index 00000000000..0c1d8218ced
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Error.al
@@ -0,0 +1,20 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 496 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Error.al)"
+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";
+}
+
+# end of Tk::Error
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.dll
new file mode 100755
index 00000000000..caaaca67c35
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Event/Event.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/FirstMenu.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/FirstMenu.al
new file mode 100755
index 00000000000..c2cee5e9f4e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/FirstMenu.al
@@ -0,0 +1,21 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 740 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\FirstMenu.al)"
+# 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('');
+}
+
+# end of Tk::FirstMenu
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/FocusChildren.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/FocusChildren.al
new file mode 100755
index 00000000000..1c3c6b83bbd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/FocusChildren.al
@@ -0,0 +1,35 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 525 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\FocusChildren.al)"
+#----------------------------------------------------------------------------
+# 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.
+# end of Tk::FocusChildren
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/FocusOK.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/FocusOK.al
new file mode 100755
index 00000000000..32da7b795b3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/FocusOK.al
@@ -0,0 +1,36 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 663 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\FocusOK.al)"
+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;
+}
+
+# end of Tk::FocusOK
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/AddScrollbars.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/AddScrollbars.al
new file mode 100755
index 00000000000..aa12259f675
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/AddScrollbars.al
@@ -0,0 +1,52 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 225 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\AddScrollbars.al)"
+sub AddScrollbars
+{
+ require Tk::Scrollbar;
+ my ($cw,$w) = @_;
+ my $def = '';
+ my ($x,$y) = ('','');
+ my $s = 0;
+ my $c;
+ $cw->freeze_on_map;
+ foreach $c ($w->configure)
+ {
+ my $opt = $c->[0];
+ if ($opt eq '-yscrollcommand')
+ {
+ my $slice = Tk::Frame->new($cw,Name => 'ysbslice');
+ my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]);
+ my $size = $ysb->cget('-width');
+ my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised',
+ '-width' => $size, '-height' => $size);
+ $ysb->pack(-side => 'left', -fill => 'y');
+ $cw->Advertise('yscrollbar' => $ysb);
+ $cw->Advertise('corner' => $corner);
+ $cw->Advertise('ysbslice' => $slice);
+ $corner->{'before'} = $ysb->PathName;
+ $slice->{'before'} = $w->PathName;
+ $y = 'w';
+ $s = 1;
+ }
+ elsif ($opt eq '-xscrollcommand')
+ {
+ my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]);
+ $cw->Advertise('xscrollbar' => $xsb);
+ $xsb->{'before'} = $w->PathName;
+ $x = 's';
+ $s = 1;
+ }
+ }
+ if ($s)
+ {
+ $cw->Advertise('scrolled' => $w);
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]);
+ }
+}
+
+# end of Tk::Frame::AddScrollbars
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/FindMenu.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/FindMenu.al
new file mode 100755
index 00000000000..66e71c29b21
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/FindMenu.al
@@ -0,0 +1,22 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 363 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\FindMenu.al)"
+sub FindMenu
+{
+ my ($w,$char) = @_;
+ my $child;
+ my $match;
+ foreach $child ($w->children)
+ {
+ next unless (ref $child);
+ $match = $child->FindMenu($char);
+ return $match if (defined $match);
+ }
+ return undef;
+}
+
+1;
+# end of Tk::Frame::FindMenu
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/autosplit.ix
new file mode 100755
index 00000000000..6e5b939fce1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/autosplit.ix
@@ -0,0 +1,24 @@
+# Index created by AutoSplit for blib\lib\Tk\Frame.pm
+# (file acts as timestamp)
+package Tk::Frame;
+sub labelPack
+;
+sub labelVariable
+;
+sub label
+;
+sub queuePack
+;
+sub sbset
+;
+sub freeze_on_map
+;
+sub AddScrollbars
+;
+sub packscrollbars
+;
+sub scrollbars
+;
+sub FindMenu
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/freeze_on_map.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/freeze_on_map.al
new file mode 100755
index 00000000000..6a8b8a4f96e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/freeze_on_map.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 215 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\freeze_on_map.al)"
+sub freeze_on_map
+{
+ my ($w) = @_;
+ unless ($w->Tk::bind('Freeze','<Map>'))
+ {
+ $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0])
+ }
+ $w->AddBindTag('Freeze');
+}
+
+# end of Tk::Frame::freeze_on_map
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/label.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/label.al
new file mode 100755
index 00000000000..83ec70ed803
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/label.al
@@ -0,0 +1,24 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 182 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\label.al)"
+sub label
+{
+ my ($cw,$val) = @_;
+ my $var = $cw->cget('-labelVariable');
+ if (@_ > 1 && defined $val)
+ {
+ if (!defined $var)
+ {
+ $var = \$cw->{Configure}{'-label'};
+ $cw->labelVariable($var);
+ }
+ $$var = $val;
+ }
+ return (defined $var) ? $$var : undef;;
+}
+
+# end of Tk::Frame::label
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelPack.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelPack.al
new file mode 100755
index 00000000000..0cfa8631c24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelPack.al
@@ -0,0 +1,50 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 121 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\labelPack.al)"
+sub labelPack
+{
+ my ($cw,$val) = @_;
+ my $w = $cw->Subwidget('label');
+ my @result = ();
+ if (@_ > 1)
+ {
+ if (defined($w) && !defined($val))
+ {
+ $w->packForget;
+ }
+ elsif (defined($val) && !defined ($w))
+ {
+ require Tk::Label;
+ $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable);
+ $cw->Advertise('label' => $w);
+ $cw->ConfigDelegate('label',qw(-text -textvariable));
+ }
+ if (defined($val) && defined($w))
+ {
+ my %pack = @$val;
+ unless (exists $pack{-side})
+ {
+ $pack{-side} = 'top' unless (exists $pack{-side});
+ }
+ unless (exists $pack{-fill})
+ {
+ $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/);
+ $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/);
+ }
+ unless (exists($pack{'-before'}) || exists($pack{'-after'}))
+ {
+ my $before = ($cw->packSlaves)[0];
+ $pack{'-before'} = $before if (defined $before);
+ }
+ $w->pack(%pack);
+ }
+ }
+ @result = $w->packInfo if (defined $w);
+ return (wantarray) ? @result : \@result;
+}
+
+# end of Tk::Frame::labelPack
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelVariable.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelVariable.al
new file mode 100755
index 00000000000..ca60cff1288
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/labelVariable.al
@@ -0,0 +1,27 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 163 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\labelVariable.al)"
+sub labelVariable
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-labelVariable'};
+ if (@_ > 1 && defined $val)
+ {
+ $$var = $val;
+ $$val = '' unless (defined $$val);
+ my $w = $cw->Subwidget('label');
+ unless (defined $w)
+ {
+ $cw->labelPack([]);
+ $w = $cw->Subwidget('label');
+ }
+ $w->configure(-textvariable => $val);
+ }
+ return $$var;
+}
+
+# end of Tk::Frame::labelVariable
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/packscrollbars.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/packscrollbars.al
new file mode 100755
index 00000000000..9990eb67b13
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/packscrollbars.al
@@ -0,0 +1,86 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 269 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\packscrollbars.al)"
+sub packscrollbars
+{
+ my ($cw) = @_;
+ my $opt = $cw->cget('-scrollbars');
+ my $slice = $cw->Subwidget('ysbslice');
+ my $xsb = $cw->Subwidget('xscrollbar');
+ my $corner = $cw->Subwidget('corner');
+ my $w = $cw->Subwidget('scrolled');
+ my $xside = (($opt =~ /n/) ? 'top' : 'bottom');
+ my $havex = 0;
+ my $havey = 0;
+ $opt =~ s/r//;
+ $cw->{'pack_pending'} = 0;
+ if (defined $slice)
+ {
+ my $reqy;
+ my $ysb = $cw->Subwidget('yscrollbar');
+ if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed))
+ {
+ my $yside = (($opt =~ /w/) ? 'left' : 'right');
+ $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'});
+ $havey = 1;
+ if ($reqy)
+ {
+ $w->configure(-yscrollcommand => ['set', $ysb]);
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//;
+ $slice->packForget;
+ }
+ $cw->{'packysb'} = $havey;
+ }
+ if (defined $xsb)
+ {
+ my $reqx;
+ if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed))
+ {
+ $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'});
+ $havex = 1;
+ if ($reqx)
+ {
+ $w->configure(-xscrollcommand => ['set', $xsb]);
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//;
+ $xsb->packForget;
+ }
+ $cw->{'packxsb'} = $havex;
+ }
+ if (defined $corner)
+ {
+ if ($havex && $havey && defined $corner->{'before'})
+ {
+ my $anchor = $opt;
+ $anchor =~ s/o//g;
+ $corner->configure(-height => $xsb->ReqHeight);
+ $corner->pack(-before => $corner->{'before'}, -side => $xside,
+ -anchor => $anchor, -fill => 'x');
+ }
+ else
+ {
+ $corner->packForget;
+ }
+ }
+}
+
+# end of Tk::Frame::packscrollbars
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/queuePack.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/queuePack.al
new file mode 100755
index 00000000000..59fe3ee4de0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/queuePack.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 198 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\queuePack.al)"
+sub queuePack
+{
+ my ($cw) = @_;
+ unless ($cw->{'pack_pending'})
+ {
+ $cw->{'pack_pending'} = 1;
+ $cw->afterIdle([$cw,'packscrollbars']);
+ }
+}
+
+# end of Tk::Frame::queuePack
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/sbset.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/sbset.al
new file mode 100755
index 00000000000..cca4f0d642a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/sbset.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 208 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\sbset.al)"
+sub sbset
+{
+ my ($cw,$sb,$ref,@args) = @_;
+ $sb->set(@args);
+ $cw->queuePack if (@args == 2 && $sb->Needed != $$ref);
+}
+
+# end of Tk::Frame::sbset
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/scrollbars.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/scrollbars.al
new file mode 100755
index 00000000000..21eeb53d2b9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Frame/scrollbars.al
@@ -0,0 +1,24 @@
+# NOTE: Derived from blib\lib\Tk\Frame.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Frame;
+
+#line 347 "blib\lib\Tk\Frame.pm (autosplit into blib\lib\auto\Tk\Frame\scrollbars.al)"
+sub scrollbars
+{
+ my ($cw,$opt) = @_;
+ my $var = \$cw->{'-scrollbars'};
+ if (@_ > 1)
+ {
+ my $old = $$var;
+ if (!defined $old || $old ne $opt)
+ {
+ $$var = $opt;
+ $cw->queuePack;
+ }
+ }
+ return $$var;
+}
+
+# end of Tk::Frame::scrollbars
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.dll
new file mode 100755
index 00000000000..5dde82a5ac0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/HList/HList.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.dll
new file mode 100755
index 00000000000..adb1c93f257
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/IO/IO.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/ImageNames.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/ImageNames.al
new file mode 100755
index 00000000000..9e9a7a00d29
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/ImageNames.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 792 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\ImageNames.al)"
+sub ImageNames
+{
+ image('names');
+}
+
+# end of Tk::ImageNames
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/ImageTypes.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/ImageTypes.al
new file mode 100755
index 00000000000..2ab5a66b0de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/ImageTypes.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 797 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\ImageTypes.al)"
+sub ImageTypes
+{
+ image('types');
+}
+
+# end of Tk::ImageTypes
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.dll
new file mode 100755
index 00000000000..ea8966b3b17
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/JPEG/JPEG.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/AutoScan.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/AutoScan.al
new file mode 100755
index 00000000000..89bda0179c6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/AutoScan.al
@@ -0,0 +1,49 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 676 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\AutoScan.al)"
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+# y - The y-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ return if !Tk::Exists($w);
+ my $x = shift;
+ my $y = shift;
+ if ($y >= $w->height)
+ {
+ $w->yview('scroll',1,'units')
+ }
+ elsif ($y < 0)
+ {
+ $w->yview('scroll',-1,'units')
+ }
+ elsif ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->Motion($w->index("@" . $x . ',' . $y));
+ $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
+}
+
+# end of Tk::Listbox::AutoScan
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginExtend.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginExtend.al
new file mode 100755
index 00000000000..afd8f0e9fda
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginExtend.al
@@ -0,0 +1,34 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 620 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\BeginExtend.al)"
+# BeginExtend --
+#
+# This procedure is typically invoked on shift-button-1 presses. It
+# begins the process of extending a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginExtend
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ else
+ {
+ # No selection yet; simulate the begin-select operation.
+ $w->BeginSelect($el);
+ }
+}
+
+# end of Tk::Listbox::BeginExtend
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginSelect.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginSelect.al
new file mode 100755
index 00000000000..304a0afe1e1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginSelect.al
@@ -0,0 +1,46 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 515 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\BeginSelect.al)"
+# BeginSelect --
+#
+# This procedure is typically invoked on button-1 presses. It begins
+# the process of making a selection in the listbox. Its exact behavior
+# depends on the selection mode currently in effect for the listbox;
+# see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginSelect
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'multiple')
+ {
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ }
+ else
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ @Selection = ();
+ $Prev = $el
+ }
+ $w->focus if ($w->cget('-takefocus'));
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+# end of Tk::Listbox::BeginSelect
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginToggle.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginToggle.al
new file mode 100755
index 00000000000..6c70e35d75a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/BeginToggle.al
@@ -0,0 +1,40 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 645 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\BeginToggle.al)"
+# BeginToggle --
+#
+# This procedure is typically invoked on control-button-1 presses. It
+# begins the process of toggling a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginToggle
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended')
+ {
+ @Selection = $w->curselection();
+ $Prev = $el;
+ $w->selectionAnchor($el);
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+
+# end of Tk::Listbox::BeginToggle
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ButtonRelease_1.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ButtonRelease_1.al
new file mode 100755
index 00000000000..ec8fa789fb9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ButtonRelease_1.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 471 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\ButtonRelease_1.al)"
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat;
+ $w->activate($Ev->xy);
+}
+
+# end of Tk::Listbox::ButtonRelease_1
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/CLEAR.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/CLEAR.al
new file mode 100755
index 00000000000..8ed6feba4b5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/CLEAR.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 304 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\CLEAR.al)"
+# CLEAR
+# -----
+# Empty the Listbox of contents if tied to an array
+sub CLEAR {
+ my $class = shift;
+ ${$class->{OBJECT}}->delete(0, 'end');
+}
+
+# end of Tk::Listbox::CLEAR
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cancel.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cancel.al
new file mode 100755
index 00000000000..7ff924756f8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cancel.al
@@ -0,0 +1,42 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 805 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cancel.al)"
+# Cancel
+#
+# This procedure is invoked to cancel an extended selection in
+# progress. If there is an extended selection in progress, it
+# restores all of the items between the active one and the anchor
+# to their previous selection state.
+#
+# Arguments:
+# w - The listbox widget.
+sub Cancel
+{
+ my $w = shift;
+ if ($w->cget('-selectmode') ne 'extended' || !defined $Prev)
+ {
+ return;
+ }
+ my $first = $w->index('anchor');
+ my $last = $Prev;
+ if ($first > $last)
+ {
+ ($first, $last) = ($last, $first);
+ }
+ $w->selectionClear($first,$last);
+ while ($first <= $last)
+ {
+ if (Tk::lsearch(\@Selection,$first) >= 0)
+ {
+ $w->selectionSet($first)
+ }
+ $first++
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+# end of Tk::Listbox::Cancel
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_End.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_End.al
new file mode 100755
index 00000000000..dad5a4bc0d1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_End.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 492 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cntrl_End.al)"
+sub Cntrl_End
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate('end');
+ $w->see('end');
+ $w->selectionClear(0,'end');
+ $w->selectionSet('end');
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+# end of Tk::Listbox::Cntrl_End
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_Home.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_Home.al
new file mode 100755
index 00000000000..08131896da1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_Home.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 480 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cntrl_Home.al)"
+sub Cntrl_Home
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate(0);
+ $w->see(0);
+ $w->selectionClear(0,'end');
+ $w->selectionSet(0);
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+# end of Tk::Listbox::Cntrl_Home
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_backslash.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_backslash.al
new file mode 100755
index 00000000000..402426261a7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Cntrl_backslash.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 504 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cntrl_backslash.al)"
+sub Cntrl_backslash
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if ($w->cget('-selectmode') ne 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+
+# end of Tk::Listbox::Cntrl_backslash
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DELETE.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DELETE.al
new file mode 100755
index 00000000000..3dd81ad40fd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DELETE.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 355 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\DELETE.al)"
+# DELETE
+# ------
+# Delete element at specified index
+sub DELETE {
+ my ( $class, @list ) = @_;
+
+ my $value = ${$class->{OBJECT}}->get(@list);
+ ${$class->{OBJECT}}->delete(@list);
+ return $value;
+}
+
+# end of Tk::Listbox::DELETE
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DataExtend.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DataExtend.al
new file mode 100755
index 00000000000..4240300aa68
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/DataExtend.al
@@ -0,0 +1,39 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 775 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\DataExtend.al)"
+# DataExtend
+#
+# This procedure is called for key-presses such as Shift-KEndData.
+# If the selection mode isn't multiple or extend then it does nothing.
+# Otherwise it moves the active element to el and, if we're in
+# extended mode, extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# el - An integer element number.
+sub DataExtend
+{
+ my $w = shift;
+ my $el = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'extended')
+ {
+ $w->activate($el);
+ $w->see($el);
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->activate($el);
+ $w->see($el)
+ }
+}
+
+# end of Tk::Listbox::DataExtend
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXISTS.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXISTS.al
new file mode 100755
index 00000000000..ae1ed1bc5e6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXISTS.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 366 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\EXISTS.al)"
+# EXISTS
+# ------
+# Returns true if the index exist, and undef if not
+sub EXISTS {
+ my ( $class, $index ) = @_;
+ return undef unless ${$class->{OBJECT}}->get($index);
+}
+
+# end of Tk::Listbox::EXISTS
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXTEND.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXTEND.al
new file mode 100755
index 00000000000..2a483ea08c1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/EXTEND.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 312 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\EXTEND.al)"
+# EXTEND
+# ------
+# Do nothing and be happy about it
+sub EXTEND { }
+
+# PUSH
+# ----
+# Append elements onto the Listbox contents
+# end of Tk::Listbox::EXTEND
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ExtendUpDown.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ExtendUpDown.al
new file mode 100755
index 00000000000..9b72250ea41
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/ExtendUpDown.al
@@ -0,0 +1,36 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 748 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\ExtendUpDown.al)"
+# ExtendUpDown --
+#
+# Does nothing unless we're in extended selection mode; in this
+# case it moves the location cursor (active element) up or down by
+# one element, and extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub ExtendUpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ if ($w->cget('-selectmode') ne 'extended')
+ {
+ return;
+ }
+ my $active = $w->index('active');
+ if (!@Selection)
+ {
+ $w->selectionSet($active);
+ @Selection = $w->curselection;
+ }
+ $w->activate($active + $amount);
+ $w->see('active');
+ $w->Motion($w->index('active'))
+}
+
+# end of Tk::Listbox::ExtendUpDown
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCH.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCH.al
new file mode 100755
index 00000000000..fbbe7a3ce9a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCH.al
@@ -0,0 +1,56 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 176 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\FETCH.al)"
+# FETCH
+# -----
+# Return either the full contents or only the selected items in the
+# box depending on whether we tied it to an array or scalar respectively
+sub FETCH {
+ my $class = shift;
+
+ my $self = ${$class->{OBJECT}};
+ my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
+
+ # Define the return variable
+ my $result;
+
+ # Check whether we are have a tied array or scalar quantity
+ if ( @_ ) {
+ my $i = shift;
+ # The Tk:: Listbox has been tied to an array, we are returning
+ # an array list of the current items in the Listbox
+ $result = $self->get($i);
+ } else {
+ # The Tk::Listbox has been tied to a scalar, we are returning a
+ # reference to an array or hash containing the currently selected items
+ my ( @array, %hash );
+
+ if ( defined $options{ReturnType} ) {
+
+ # THREE-WAY SWITCH
+ if ( $options{ReturnType} eq "index" ) {
+ $result = [$self->curselection];
+ } elsif ( $options{ReturnType} eq "element" ) {
+ foreach my $selection ( $self->curselection ) {
+ push(@array,$self->get($selection)); }
+ $result = \@array;
+ } elsif ( $options{ReturnType} eq "both" ) {
+ foreach my $selection ( $self->curselection ) {
+ %hash = ( %hash, $selection => $self->get($selection)); }
+ $result = \%hash;
+ }
+ } else {
+ # return elements (default)
+ foreach my $selection ( $self->curselection ) {
+ push(@array,$self->get($selection)); }
+ $result = \@array;
+ }
+ }
+ return $result;
+}
+
+# end of Tk::Listbox::FETCH
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCHSIZE.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCHSIZE.al
new file mode 100755
index 00000000000..13b612a26f5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/FETCHSIZE.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 224 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\FETCHSIZE.al)"
+# FETCHSIZE
+# ---------
+# Return the number of elements in the Listbox when tied to an array
+sub FETCHSIZE {
+ my $class = shift;
+ return ${$class->{OBJECT}}->size();
+}
+
+# end of Tk::Listbox::FETCHSIZE
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.dll
new file mode 100755
index 00000000000..e3967f04e10
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Listbox.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Motion.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Motion.al
new file mode 100755
index 00000000000..c1c3cbd978b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/Motion.al
@@ -0,0 +1,77 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 552 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Motion.al)"
+# Motion --
+#
+# This procedure is called to process mouse motion events while
+# button 1 is down. It may move or extend the selection, depending
+# on the listbox's selection mode.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element under the pointer (must be a number).
+sub Motion
+{
+ my $w = shift;
+ my $el = shift;
+ if (defined($Prev) && $el == $Prev)
+ {
+ return;
+ }
+ my $anchor = $w->index('anchor');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $Prev = $el;
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+ elsif ($mode eq 'extended')
+ {
+ my $i = $Prev;
+ if (!defined $i || $i eq '')
+ {
+ $i = $el;
+ $w->selectionSet($el);
+ }
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionSet('anchor',$el)
+ }
+ else
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionClear('anchor',$el)
+ }
+ if (!@Selection)
+ {
+ @Selection = $w->curselection;
+ }
+ while ($i < $el && $i < $anchor)
+ {
+ if (Tk::lsearch(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i++
+ }
+ while ($i > $el && $i > $anchor)
+ {
+ if (Tk::lsearch(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i--
+ }
+ $Prev = $el;
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+
+# end of Tk::Listbox::Motion
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/POP.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/POP.al
new file mode 100755
index 00000000000..db469652447
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/POP.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 325 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\POP.al)"
+# POP
+# ---
+# Remove last element of the array and return it
+sub POP {
+ my $class = shift;
+
+ my $value = ${$class->{OBJECT}}->get('end');
+ ${$class->{OBJECT}}->delete('end');
+ return $value;
+}
+
+# end of Tk::Listbox::POP
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/PUSH.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/PUSH.al
new file mode 100755
index 00000000000..f2168ef46d9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/PUSH.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 320 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\PUSH.al)"
+sub PUSH {
+ my ( $class, @list ) = @_;
+ ${$class->{OBJECT}}->insert('end', @list);
+}
+
+# end of Tk::Listbox::PUSH
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SHIFT.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SHIFT.al
new file mode 100755
index 00000000000..96a41f7d79c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SHIFT.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 336 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\SHIFT.al)"
+# SHIFT
+# -----
+# Removes the first element and returns it
+sub SHIFT {
+ my $class = shift;
+
+ my $value = ${$class->{OBJECT}}->get(0);
+ ${$class->{OBJECT}}->delete(0);
+ return $value
+}
+
+# end of Tk::Listbox::SHIFT
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SPLICE.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SPLICE.al
new file mode 100755
index 00000000000..aeddea8196a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SPLICE.al
@@ -0,0 +1,84 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 374 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\SPLICE.al)"
+# SPLICE
+# ------
+# Performs equivalent of splice on the listbox contents
+sub SPLICE {
+ my $class = shift;
+
+ my $self = ${$class->{OBJECT}};
+
+ # check for arguments
+ my @elements;
+ if ( scalar(@_) == 0 ) {
+ # none
+ @elements = $self->get(0,'end');
+ $self->delete(0,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];;
+
+ } elsif ( scalar(@_) == 1 ) {
+ # $offset
+ my ( $offset ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,'end');
+ $self->delete($start,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,'end');
+ $self->delete($offset,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+
+ } elsif ( scalar(@_) == 2 ) {
+ # $offset and $length
+ my ( $offset, $length ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ my $end = $self->size() + $offset + $length - 1;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,$end);
+ $self->delete($start,$end);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,$offset+$length-1);
+ $self->delete($offset,$offset+$length-1);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+
+ } else {
+ # $offset, $length and @list
+ my ( $offset, $length, @list ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ my $end = $self->size() + $offset + $length - 1;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,$end);
+ $self->delete($start,$end);
+ $self->insert($start,@list);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,$offset+$length-1);
+ $self->delete($offset,$offset+$length-1);
+ $self->insert($offset,@list);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+ }
+}
+
+# end of Tk::Listbox::SPLICE
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/STORE.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/STORE.al
new file mode 100755
index 00000000000..492c32ccc1e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/STORE.al
@@ -0,0 +1,80 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 232 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\STORE.al)"
+# STORE
+# -----
+# If tied to an array we will modify the Listbox contents, while if tied
+# to a scalar we will select and clear elements.
+sub STORE {
+
+ if ( scalar(@_) == 2 ) {
+ # we have a tied scalar
+ my ( $class, $selected ) = @_;
+ my $self = ${$class->{OBJECT}};
+ my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
+
+ # clear currently selected elements
+ $self->selectionClear(0,'end');
+
+ # set selected elements
+ if ( defined $options{ReturnType} ) {
+
+ # THREE-WAY SWITCH
+ if ( $options{ReturnType} eq "index" ) {
+ for ( my $i=0; $i < scalar(@$selected) ; $i++ ) {
+ for ( my $j=0; $j < $self->size() ; $j++ ) {
+ if( $j == $$selected[$i] ) {
+ $self->selectionSet($j); last; }
+ }
+ }
+ } elsif ( $options{ReturnType} eq "element" ) {
+ for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
+ for ( my $l=0; $l < $self->size() ; $l++ ) {
+ if( $self->get($l) eq $$selected[$k] ) {
+ $self->selectionSet($l); last; }
+ }
+ }
+ } elsif ( $options{ReturnType} eq "both" ) {
+ foreach my $key ( keys %$selected ) {
+ $self->selectionSet($key)
+ if $$selected{$key} eq $self->get($key);
+ }
+ }
+ } else {
+ # return elements (default)
+ for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
+ for ( my $l=0; $l < $self->size() ; $l++ ) {
+ if( $self->get($l) eq $$selected[$k] ) {
+ $self->selectionSet($l); last; }
+ }
+ }
+ }
+
+ } else {
+ # we have a tied array
+ my ( $class, $index, $value ) = @_;
+ my $self = ${$class->{OBJECT}};
+
+ # check size of current contents list
+ my $sizeof = $self->size();
+
+ if ( $index <= $sizeof ) {
+ # Change a current listbox entry
+ $self->delete($index);
+ $self->insert($index, $value);
+ } else {
+ # Add a new value
+ if ( defined $index ) {
+ $self->insert($index, $value);
+ } else {
+ $self->insert("end", $value);
+ }
+ }
+ }
+}
+
+# end of Tk::Listbox::STORE
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SelectAll.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SelectAll.al
new file mode 100755
index 00000000000..50569afbe50
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SelectAll.al
@@ -0,0 +1,32 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 838 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\SelectAll.al)"
+# SelectAll
+#
+# This procedure is invoked to handle the "select all" operation.
+# For single and browse mode, it just selects the active element.
+# Otherwise it selects everything in the widget.
+#
+# Arguments:
+# w - The listbox widget.
+sub SelectAll
+{
+ my $w = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ else
+ {
+ $w->selectionSet(0,'end')
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+# end of Tk::Listbox::SelectAll
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SetList.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SetList.al
new file mode 100755
index 00000000000..25e4f596592
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/SetList.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 862 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\SetList.al)"
+# Perl/Tk extensions:
+sub SetList
+{
+ my $w = shift;
+ $w->delete(0,'end');
+ $w->insert('end',@_);
+}
+
+# end of Tk::Listbox::SetList
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIEARRAY.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIEARRAY.al
new file mode 100755
index 00000000000..8c147e8eac8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIEARRAY.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 160 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\TIEARRAY.al)"
+sub TIEARRAY {
+ my ( $class, $obj, %options ) = @_;
+ return bless {
+ OBJECT => \$obj,
+ OPTION => \%options }, $class;
+}
+
+# end of Tk::Listbox::TIEARRAY
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIESCALAR.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIESCALAR.al
new file mode 100755
index 00000000000..9cedf047c7f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/TIESCALAR.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 169 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\TIESCALAR.al)"
+sub TIESCALAR {
+ my ( $class, $obj, %options ) = @_;
+ return bless {
+ OBJECT => \$obj,
+ OPTION => \%options }, $class;
+}
+
+# end of Tk::Listbox::TIESCALAR
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UNSHIFT.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UNSHIFT.al
new file mode 100755
index 00000000000..10d6bae86ec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UNSHIFT.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 347 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\UNSHIFT.al)"
+# UNSHIFT
+# -------
+# Insert elements at the beginning of the Listbox
+sub UNSHIFT {
+ my ( $class, @list ) = @_;
+ ${$class->{OBJECT}}->insert(0, @list);
+}
+
+# end of Tk::Listbox::UNSHIFT
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UpDown.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UpDown.al
new file mode 100755
index 00000000000..7ffbfebf4e1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/UpDown.al
@@ -0,0 +1,41 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 716 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\UpDown.al)"
+# UpDown --
+#
+# Moves the location cursor (active element) up or down by one element,
+# and changes the selection if we're in browse or extended selection
+# mode.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub UpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ $w->activate($w->index('active')+$amount);
+ $w->see('active');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+ elsif ($mode eq 'extended')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->selectionAnchor('active');
+ $Prev = $w->index('active');
+ @Selection = ();
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+
+# end of Tk::Listbox::UpDown
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/autosplit.ix
new file mode 100755
index 00000000000..0cd2e67037c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/autosplit.ix
@@ -0,0 +1,56 @@
+# Index created by AutoSplit for ..\blib\lib\Tk\Listbox.pm
+# (file acts as timestamp)
+package Tk::Listbox;
+sub TIEARRAY ;
+sub TIESCALAR ;
+sub FETCH ;
+sub FETCHSIZE ;
+sub STORE ;
+sub CLEAR ;
+sub EXTEND ;
+sub PUSH ;
+sub POP ;
+sub SHIFT ;
+sub UNSHIFT ;
+sub DELETE ;
+sub EXISTS ;
+sub SPLICE ;
+sub xyIndex
+;
+sub ButtonRelease_1
+;
+sub Cntrl_Home
+;
+sub Cntrl_End
+;
+sub Cntrl_backslash
+;
+sub BeginSelect
+;
+sub Motion
+;
+sub BeginExtend
+;
+sub BeginToggle
+;
+sub AutoScan
+;
+sub UpDown
+;
+sub ExtendUpDown
+;
+sub DataExtend
+;
+sub Cancel
+;
+sub SelectAll
+;
+sub SetList
+;
+sub deleteSelected
+;
+sub clipboardPaste
+;
+sub getSelected
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/clipboardPaste.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/clipboardPaste.al
new file mode 100755
index 00000000000..28f0bd731de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/clipboardPaste.al
@@ -0,0 +1,21 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 880 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\clipboardPaste.al)"
+sub clipboardPaste
+{
+ my $w = shift;
+ my $index = $w->index('active') || $w->index($w->XEvent->xy);
+ my $str;
+ eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
+ return if $@;
+ foreach (split("\n",$str))
+ {
+ $w->insert($index++,$_);
+ }
+}
+
+# end of Tk::Listbox::clipboardPaste
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/deleteSelected.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/deleteSelected.al
new file mode 100755
index 00000000000..45bdfe73221
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/deleteSelected.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 870 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\deleteSelected.al)"
+sub deleteSelected
+{
+ my $w = shift;
+ my $i;
+ foreach $i (reverse $w->curselection)
+ {
+ $w->delete($i);
+ }
+}
+
+# end of Tk::Listbox::deleteSelected
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/getSelected.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/getSelected.al
new file mode 100755
index 00000000000..a729a713d3e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/getSelected.al
@@ -0,0 +1,24 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 893 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\getSelected.al)"
+sub getSelected
+{
+ my ($w) = @_;
+ my $i;
+ my (@result) = ();
+ foreach $i ($w->curselection)
+ {
+ push(@result,$w->get($i));
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+1;
+__END__
+
+
+1;
+# end of Tk::Listbox::getSelected
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/xyIndex.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/xyIndex.al
new file mode 100755
index 00000000000..5689afdb6ef
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Listbox/xyIndex.al
@@ -0,0 +1,29 @@
+# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Listbox;
+
+#line 450 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\xyIndex.al)"
+# ----
+
+#
+# Bind --
+# This procedure is invoked the first time the mouse enters a listbox
+# widget or a listbox widget receives the input focus. It creates
+# all of the class bindings for listboxes.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+
+sub xyIndex
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ return $w->index($Ev->xy);
+}
+
+# end of Tk::Listbox::xyIndex
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.dll
new file mode 100755
index 00000000000..c7df93046c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Menubutton/Menubutton.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.dll
new file mode 100755
index 00000000000..77fc594dfe1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/NBFrame/NBFrame.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.dll
new file mode 100755
index 00000000000..a2e01d50b00
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/PNG/PNG.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.dll
new file mode 100755
index 00000000000..2f1ab5d5781
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Pixmap/Pixmap.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Receive.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Receive.al
new file mode 100755
index 00000000000..b4551cb8ee4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Receive.al
@@ -0,0 +1,23 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 763 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Receive.al)"
+# 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";
+}
+
+# end of Tk::Receive
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/RepeatId.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/RepeatId.al
new file mode 100755
index 00000000000..2f13fee43a1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/RepeatId.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 515 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\RepeatId.al)"
+sub RepeatId
+{
+ my ($w,$id) = @_;
+ $w = $w->MainWindow;
+ $w->CancelRepeat;
+ $w->{_afterId_} = $id;
+}
+
+# end of Tk::RepeatId
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Activate.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Activate.al
new file mode 100755
index 00000000000..500358c8e0e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Activate.al
@@ -0,0 +1,33 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 86 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Activate.al)"
+# Activate --
+# This procedure is invoked to check a given x-y position in the
+# scale and activate the slider if the x-y position falls within
+# the slider.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates.
+sub Activate
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ return if ($w->cget('-state') eq 'disabled');
+ my $ident = $w->identify($x,$y);
+ if (defined($ident) && $ident eq 'slider')
+ {
+ $w->configure(-state => 'active')
+ }
+ else
+ {
+ $w->configure(-state => 'normal')
+ }
+}
+
+# end of Tk::Scale::Activate
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonDown.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonDown.al
new file mode 100755
index 00000000000..61ed6f32c11
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonDown.al
@@ -0,0 +1,40 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 138 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\ButtonDown.al)"
+# ButtonDown --
+# This procedure is invoked when a button is pressed in a scale. It
+# takes different actions depending on where the button was pressed.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates of button press.
+sub ButtonDown
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ $Tk::dragging = 0;
+ $el = $w->identify($x,$y);
+ return unless ($el);
+ if ($el eq 'trough1')
+ {
+ $w->Increment('up','little','initial')
+ }
+ elsif ($el eq 'trough2')
+ {
+ $w->Increment('down','little','initial')
+ }
+ elsif ($el eq 'slider')
+ {
+ $Tk::dragging = 1;
+ my @coords = $w->coords();
+ $Tk::deltaX = $x-$coords[0];
+ $Tk::deltaY = $y-$coords[1];
+ }
+}
+
+# end of Tk::Scale::ButtonDown
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonUp.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonUp.al
new file mode 100755
index 00000000000..d5a22a77a46
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ButtonUp.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 129 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\ButtonUp.al)"
+sub ButtonUp
+{
+ my ($w,$x,$y) = @_;
+ $w->CancelRepeat();
+ $w->EndDrag();
+ $w->Activate($x,$y)
+}
+
+# end of Tk::Scale::ButtonUp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ControlPress.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ControlPress.al
new file mode 100755
index 00000000000..50d7ad8b447
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/ControlPress.al
@@ -0,0 +1,31 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 255 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\ControlPress.al)"
+# ControlPress --
+# This procedure handles button presses that are made with the Control
+# key down. Depending on the mouse position, it adjusts the scale
+# value to one end of the range or the other.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates where the button was pressed.
+sub ControlPress
+{
+ my ($w,$x,$y) = @_;
+ my $el = $w->identify($x,$y);
+ return unless ($el);
+ if ($el eq 'trough1')
+ {
+ $w->set($w->cget('-from'))
+ }
+ elsif ($el eq 'trough2')
+ {
+ $w->set($w->cget('-to'))
+ }
+}
+
+1;
+# end of Tk::Scale::ControlPress
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Drag.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Drag.al
new file mode 100755
index 00000000000..0bc63b12879
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Drag.al
@@ -0,0 +1,29 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 169 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Drag.al)"
+# Drag --
+# This procedure is called when the mouse is dragged with
+# mouse button 1 down. If the drag started inside the slider
+# (i.e. the scale is active) then the scale's value is adjusted
+# to reflect the mouse's position.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates.
+sub Drag
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ if (!$Tk::dragging)
+ {
+ return;
+ }
+ $w->set($w->get($x-$Tk::deltaX,$y-$Tk::deltaY))
+}
+
+# end of Tk::Scale::Drag
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/EndDrag.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/EndDrag.al
new file mode 100755
index 00000000000..86037b86d92
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/EndDrag.al
@@ -0,0 +1,23 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 189 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\EndDrag.al)"
+# EndDrag --
+# This procedure is called to end an interactive drag of the
+# slider. It just marks the drag as over.
+# Arguments:
+# w - The scale widget.
+sub EndDrag
+{
+ my $w = shift;
+ if (!$Tk::dragging)
+ {
+ return;
+ }
+ $Tk::dragging = 0;
+}
+
+# end of Tk::Scale::EndDrag
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Enter.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Enter.al
new file mode 100755
index 00000000000..1326a5ed9a0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Enter.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 118 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Enter.al)"
+sub Enter
+{
+ my ($w,$x,$y) = @_;
+ if ($Tk::strictMotif)
+ {
+ $w->{'activeBg'} = $w->cget('-activebackground');
+ $w->configure('-activebackground',$w->cget('-background'));
+ }
+ $w->Activate($x,$y);
+}
+
+# end of Tk::Scale::Enter
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Increment.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Increment.al
new file mode 100755
index 00000000000..76432eeaf40
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Increment.al
@@ -0,0 +1,61 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 203 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Increment.al)"
+# Increment --
+# This procedure is invoked to increment the value of a scale and
+# to set up auto-repeating of the action if that is desired. The
+# way the value is incremented depends on the "dir" and "big"
+# arguments.
+#
+# Arguments:
+# w - The scale widget.
+# dir - "up" means move value towards -from, "down" means
+# move towards -to.
+# big - Size of increments: "big" or "little".
+# repeat - Whether and how to auto-repeat the action: "noRepeat"
+# means don't auto-repeat, "initial" means this is the
+# first action in an auto-repeat sequence, and "again"
+# means this is the second repetition or later.
+sub Increment
+{
+ my $w = shift;
+ my $dir = shift;
+ my $big = shift;
+ my $repeat = shift;
+ my $inc;
+ if ($big eq 'big')
+ {
+ $inc = $w->cget('-bigincrement');
+ if ($inc == 0)
+ {
+ $inc = abs(($w->cget('-to')-$w->cget('-from')))/10.0
+ }
+ if ($inc < $w->cget('-resolution'))
+ {
+ $inc = $w->cget('-resolution')
+ }
+ }
+ else
+ {
+ $inc = $w->cget('-resolution')
+ }
+ if (($w->cget('-from') > $w->cget('-to')) ^ ($dir eq 'up'))
+ {
+ $inc = -$inc
+ }
+ $w->set($w->get()+$inc);
+ if ($repeat eq 'again')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatinterval'),'Increment',$w,$dir,$big,'again'));
+ }
+ elsif ($repeat eq 'initial')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatdelay'),'Increment',$w,$dir,$big,'again'));
+ }
+}
+
+# end of Tk::Scale::Increment
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Leave.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Leave.al
new file mode 100755
index 00000000000..eb6f7b69f89
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Leave.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scale.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scale;
+
+#line 111 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Leave.al)"
+sub Leave
+{
+ my ($w) = @_;
+ $w->configure('-activebackground',$w->{'activeBg'}) if ($Tk::strictMotif);
+ $w->configure('-state','normal') if ($w->cget('-state') eq 'active');
+}
+
+# end of Tk::Scale::Leave
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.dll
new file mode 100755
index 00000000000..a9dbd0201f7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/Scale.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/autosplit.ix
new file mode 100755
index 00000000000..a5c5d2292f2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scale/autosplit.ix
@@ -0,0 +1,22 @@
+# Index created by AutoSplit for ..\blib\lib\Tk\Scale.pm
+# (file acts as timestamp)
+package Tk::Scale;
+sub Activate
+;
+sub Leave
+;
+sub Enter
+;
+sub ButtonUp
+;
+sub ButtonDown
+;
+sub Drag
+;
+sub EndDrag
+;
+sub Increment
+;
+sub ControlPress
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonDown.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonDown.al
new file mode 100755
index 00000000000..d80e2217abc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonDown.al
@@ -0,0 +1,55 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 116 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ButtonDown.al)"
+# tkScrollButtonDown --
+# This procedure is invoked when a button is pressed in a scrollbar.
+# It changes the way the scrollbar is displayed and takes actions
+# depending on where the mouse is.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates.
+
+sub ButtonDown
+{my $w = shift;
+ my $e = $w->XEvent;
+ my $element = $w->identify($e->x,$e->y);
+ $w->configure('-activerelief' => 'sunken');
+ if ($e->b == 1 and
+ (defined($element) && $element eq 'slider'))
+ {
+ $w->StartDrag($e->x,$e->y);
+ }
+ elsif ($e->b == 2 and
+ (defined($element) && $element =~ /^(trough[12]|slider)$/o))
+ {
+ my $pos = $w->fraction($e->x, $e->y);
+ my($head, $tail) = $w->get;
+ my $len = $tail - $head;
+
+ $head = $pos - $len/2;
+ $tail = $pos + $len/2;
+ if ($head < 0) {
+ $head = 0;
+ $tail = $len;
+ }
+ elsif ($tail > 1) {
+ $head = 1 - $len;
+ $tail = 1;
+ }
+ $w->ScrlToPos($head);
+ $w->set($head, $tail);
+
+ $w->StartDrag($e->x,$e->y);
+ }
+ else
+ {
+ $w->Select($element,'initial');
+ }
+}
+
+# end of Tk::Scrollbar::ButtonDown
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonUp.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonUp.al
new file mode 100755
index 00000000000..68857548755
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ButtonUp.al
@@ -0,0 +1,26 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 163 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ButtonUp.al)"
+# tkScrollButtonUp --
+# This procedure is invoked when a button is released in a scrollbar.
+# It cancels scans and auto-repeats that were in progress, and restores
+# the way the active element is displayed.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates.
+
+sub ButtonUp
+{my $w = shift;
+ my $e = $w->XEvent;
+ $w->CancelRepeat;
+ $w->configure('-activerelief' => 'raised');
+ $w->EndDrag($e->x,$e->y);
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+# end of Tk::Scrollbar::ButtonUp
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Drag.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Drag.al
new file mode 100755
index 00000000000..988f9d4a3ef
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Drag.al
@@ -0,0 +1,43 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 262 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Drag.al)"
+# tkScrollDrag --
+# This procedure is called for each mouse motion even when the slider
+# is being dragged. It notifies the associated widget if we're not
+# jump scrolling, and it just updates the scrollbar if we are jump
+# scrolling.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The current mouse position.
+
+sub Drag
+{
+ my($w,$x,$y) = @_;
+ return if !defined $initPos;
+ my $delta = $w->delta($x-$pressX, $y-$pressY);
+ if ($w->cget('-jump'))
+ {
+ if (@initValues == 2)
+ {
+ $w->set($initValues[0]+$delta, $initValues[1]+$delta);
+ }
+ else
+ {
+ $delta = sprintf "%d", $delta * $initValues[0]; # round()
+ $initValues[2] += $delta;
+ $initValues[3] += $delta;
+ $w->set(@initValues[2,3]);
+ }
+ }
+ else
+ {
+ $w->ScrlToPos($initPos+$delta);
+ }
+}
+
+# end of Tk::Scrollbar::Drag
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/EndDrag.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/EndDrag.al
new file mode 100755
index 00000000000..8c401b6fc31
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/EndDrag.al
@@ -0,0 +1,28 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 297 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\EndDrag.al)"
+# tkScrollEndDrag --
+# This procedure is called to end an interactive drag of the slider.
+# It scrolls the window if we're in jump mode, otherwise it does nothing.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The mouse position at the end of the drag operation.
+
+sub EndDrag
+{
+ my($w,$x,$y) = @_;
+ return if (!defined $initPos);
+ if ($w->cget('-jump'))
+ {
+ my $delta = $w->delta($x-$pressX, $y-$pressY);
+ $w->ScrlToPos($initPos+$delta);
+ }
+ undef $initPos;
+}
+
+# end of Tk::Scrollbar::EndDrag
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Enter.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Enter.al
new file mode 100755
index 00000000000..9584a7fa34c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Enter.al
@@ -0,0 +1,21 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 86 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Enter.al)"
+sub Enter
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ if ($Tk::strictMotif)
+ {
+ my $bg = $w->cget('-background');
+ $activeBg = $w->cget('-activebackground');
+ $w->configure('-activebackground' => $bg);
+ }
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+# end of Tk::Scrollbar::Enter
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Leave.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Leave.al
new file mode 100755
index 00000000000..a6c5e89d91e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Leave.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 99 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Leave.al)"
+sub Leave
+{
+ my $w = shift;
+ if ($Tk::strictMotif)
+ {
+ $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ;
+ }
+ $w->activate('');
+}
+
+# end of Tk::Scrollbar::Leave
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Motion.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Motion.al
new file mode 100755
index 00000000000..46aac656c70
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Motion.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 109 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Motion.al)"
+sub Motion
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+# end of Tk::Scrollbar::Motion
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByPages.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByPages.al
new file mode 100755
index 00000000000..9d4018e9128
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByPages.al
@@ -0,0 +1,38 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 346 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlByPages.al)"
+# tkScrlByPages --
+# This procedure tells the scrollbar's associated widget to scroll up
+# or down by a given number of screenfuls. It notifies the associated
+# widget in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# orient - Which kinds of scrollbars this applies to: "h" for
+# horizontal, "v" for vertical, "hv" for both.
+# amount - How many screens to scroll: typically 1 or -1.
+
+sub ScrlByPages
+{
+ my $w = shift;
+ my $orient = shift;
+ my $amount = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('scroll',$amount,'pages');
+ }
+ else
+ {
+ $cmd->Call($info[2]+$amount*($info[1]-1));
+ }
+}
+
+# end of Tk::Scrollbar::ScrlByPages
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByUnits.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByUnits.al
new file mode 100755
index 00000000000..a364b3e52ce
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlByUnits.al
@@ -0,0 +1,37 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 317 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlByUnits.al)"
+# tkScrlByUnits --
+# This procedure tells the scrollbar's associated widget to scroll up
+# or down by a given number of units. It notifies the associated widget
+# in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# orient - Which kinds of scrollbars this applies to: "h" for
+# horizontal, "v" for vertical, "hv" for both.
+# amount - How many units to scroll: typically 1 or -1.
+
+sub ScrlByUnits
+{my $w = shift;
+ my $orient = shift;
+ my $amount = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('scroll',$amount,'units');
+ }
+ else
+ {
+ $cmd->Call($info[2]+$amount);
+ }
+}
+
+# end of Tk::Scrollbar::ScrlByUnits
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlToPos.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlToPos.al
new file mode 100755
index 00000000000..e277237953e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlToPos.al
@@ -0,0 +1,35 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 376 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlToPos.al)"
+# tkScrlToPos --
+# This procedure tells the scrollbar's associated widget to scroll to
+# a particular location, given by a fraction between 0 and 1. It notifies
+# the associated widget in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# pos - A fraction between 0 and 1 indicating a desired position
+# in the document.
+
+sub ScrlToPos
+{
+ my $w = shift;
+ my $pos = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('moveto',$pos);
+ }
+ else
+ {
+ $cmd->Call(int($info[0]*$pos));
+ }
+}
+
+# end of Tk::Scrollbar::ScrlToPos
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlTopBottom.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlTopBottom.al
new file mode 100755
index 00000000000..7a00efe616f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/ScrlTopBottom.al
@@ -0,0 +1,32 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 403 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlTopBottom.al)"
+# tkScrlTopBottom
+# Scroll to the top or bottom of the document, depending on the mouse
+# position.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates within the widget.
+
+sub ScrlTopBottom
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ my $element = $w->identify($e->x,$e->y);
+ return unless ($element);
+ if ($element =~ /1$/)
+ {
+ $w->ScrlToPos(0);
+ }
+ elsif ($element =~ /2$/)
+ {
+ $w->ScrlToPos(1);
+ }
+}
+
+1;
+# end of Tk::Scrollbar::ScrlTopBottom
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.dll
new file mode 100755
index 00000000000..f069631d631
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Scrollbar.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Select.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Select.al
new file mode 100755
index 00000000000..0da50da443b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/Select.al
@@ -0,0 +1,59 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 181 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Select.al)"
+# tkScrollSelect --
+# This procedure is invoked when button 1 is pressed over the scrollbar.
+# It invokes one of several scrolling actions depending on where in
+# the scrollbar the button was pressed.
+#
+# Arguments:
+# w - The scrollbar widget.
+# element - The element of the scrollbar that was selected, such
+# as "arrow1" or "trough2". Shouldn't be "slider".
+# repeat - Whether and how to auto-repeat the action: "noRepeat"
+# means don't auto-repeat, "initial" means this is the
+# first action in an auto-repeat sequence, and "again"
+# means this is the second repetition or later.
+
+sub Select
+{
+ my $w = shift;
+ my $element = shift;
+ my $repeat = shift;
+ return unless defined ($element);
+ if ($element eq 'arrow1')
+ {
+ $w->ScrlByUnits('hv',-1);
+ }
+ elsif ($element eq 'trough1')
+ {
+ $w->ScrlByPages('hv',-1);
+ }
+ elsif ($element eq 'trough2')
+ {
+ $w->ScrlByPages('hv', 1);
+ }
+ elsif ($element eq 'arrow2')
+ {
+ $w->ScrlByUnits('hv', 1);
+ }
+ else
+ {
+ return;
+ }
+
+ if ($repeat eq 'again')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again']));
+ }
+ elsif ($repeat eq 'initial')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again']));
+ }
+}
+
+# end of Tk::Scrollbar::Select
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/StartDrag.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/StartDrag.al
new file mode 100755
index 00000000000..32edbfdef24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/StartDrag.al
@@ -0,0 +1,38 @@
+# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Scrollbar;
+
+#line 232 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\StartDrag.al)"
+# tkScrollStartDrag --
+# This procedure is called to initiate a drag of the slider. It just
+# remembers the starting position of the slider.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The mouse position at the start of the drag operation.
+
+sub StartDrag
+{
+ my($w,$x,$y) = @_;
+ return unless (defined ($w->cget('-command')));
+ $pressX = $x;
+ $pressY = $y;
+ @initValues = $w->get;
+ my $iv0 = $initValues[0];
+ if (@initValues == 2)
+ {
+ $initPos = $iv0;
+ }
+ elsif ($iv0 == 0)
+ {
+ $initPos = 0;
+ }
+ else
+ {
+ $initPos = $initValues[2]/$initValues[0];
+ }
+}
+
+# end of Tk::Scrollbar::StartDrag
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/autosplit.ix
new file mode 100755
index 00000000000..293d1322dd4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Scrollbar/autosplit.ix
@@ -0,0 +1,30 @@
+# Index created by AutoSplit for ..\blib\lib\Tk\Scrollbar.pm
+# (file acts as timestamp)
+package Tk::Scrollbar;
+sub Enter
+;
+sub Leave
+;
+sub Motion
+;
+sub ButtonDown
+;
+sub ButtonUp
+;
+sub Select
+;
+sub StartDrag
+;
+sub Drag
+;
+sub EndDrag
+;
+sub ScrlByUnits
+;
+sub ScrlByPages
+;
+sub ScrlToPos
+;
+sub ScrlTopBottom
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Selection.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Selection.al
new file mode 100755
index 00000000000..d9be0b224bd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Selection.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 753 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Selection.al)"
+# 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()";
+}
+
+# end of Tk::Selection
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.dll
new file mode 100755
index 00000000000..d6282c14837
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TList/TList.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/Create.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/Create.al
new file mode 100755
index 00000000000..5e4ee32401a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/Create.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Tk\Table.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Table;
+
+#line 535 "blib\lib\Tk\Table.pm (autosplit into blib\lib\auto\Tk\Table\Create.al)"
+sub Create
+{
+ my $t = shift;
+ my $r = shift;
+ my $c = shift;
+ my $kind = shift;
+ $t->put($r,$c,$t->$kind(@_));
+}
+
+# end of Tk::Table::Create
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/Posn.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/Posn.al
new file mode 100755
index 00000000000..b02293300fe
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/Posn.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Tk\Table.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Table;
+
+#line 554 "blib\lib\Tk\Table.pm (autosplit into blib\lib\auto\Tk\Table\Posn.al)"
+sub Posn
+{
+ my ($t,$s) = @_;
+ my $info = $t->{Slave}{$s->PathName};
+ return (wantarray) ? @$info : $info;
+}
+
+# end of Tk::Table::Posn
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/autosplit.ix
new file mode 100755
index 00000000000..1616ae28e83
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/autosplit.ix
@@ -0,0 +1,14 @@
+# Index created by AutoSplit for blib\lib\Tk\Table.pm
+# (file acts as timestamp)
+package Tk::Table;
+sub Create
+;
+sub totalColumns
+;
+sub totalRows
+;
+sub Posn
+;
+sub see
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/see.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/see.al
new file mode 100755
index 00000000000..49b89a219f1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/see.al
@@ -0,0 +1,46 @@
+# NOTE: Derived from blib\lib\Tk\Table.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Table;
+
+#line 561 "blib\lib\Tk\Table.pm (autosplit into blib\lib\auto\Tk\Table\see.al)"
+sub see
+{
+ my $t = shift;
+ my ($row,$col) = (@_ == 2) ? @_ : @{$t->{Slave}{$_[0]->PathName}};
+ my $see = 1;
+ if (($row -= $t->cget('-fixedrows')) >= 0)
+ {
+ if ($row < $t->{Top})
+ {
+ $t->{Top} = $row;
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ elsif ($row >= $t->{Bottom})
+ {
+ $t->{Top} += ($row - $t->{Bottom}+1);
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ }
+ if (($col -= $t->cget('-fixedcolumns')) >= 0)
+ {
+ if ($col < $t->{Left})
+ {
+ $t->{Left} = $col;
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ elsif ($col >= $t->{Right})
+ {
+ $t->{Left} += ($col - $t->{Right}+1);
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ }
+ return $see;
+}
+
+1;
+# end of Tk::Table::see
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalColumns.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalColumns.al
new file mode 100755
index 00000000000..915c55be8c5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalColumns.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Tk\Table.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Table;
+
+#line 544 "blib\lib\Tk\Table.pm (autosplit into blib\lib\auto\Tk\Table\totalColumns.al)"
+sub totalColumns
+{
+ scalar @{shift->{'Width'}};
+}
+
+# end of Tk::Table::totalColumns
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalRows.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalRows.al
new file mode 100755
index 00000000000..358f63e01b8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Table/totalRows.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Tk\Table.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Table;
+
+#line 549 "blib\lib\Tk\Table.pm (autosplit into blib\lib\auto\Tk\Table\totalRows.al)"
+sub totalRows
+{
+ scalar @{shift->{'Height'}};
+}
+
+# end of Tk::Table::totalRows
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.dll
new file mode 100755
index 00000000000..21cfeb1a5f3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/Text.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/autosplit.ix
new file mode 100755
index 00000000000..48a5455c34a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Text/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for ..\blib\lib\Tk\Text.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/TextEdit/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TextEdit/autosplit.ix
new file mode 100755
index 00000000000..d7c2cbff9ec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TextEdit/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Tk\TextEdit.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/TextUndo/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TextUndo/autosplit.ix
new file mode 100755
index 00000000000..3aef3c081a4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TextUndo/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for blib\lib\Tk\TextUndo.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.dll
new file mode 100755
index 00000000000..4cc5280be95
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TixGrid/TixGrid.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Tk.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Tk.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Tk.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Tk.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Tk.dll
new file mode 100755
index 00000000000..59f2b0fee6c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Tk.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindIn.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindIn.al
new file mode 100755
index 00000000000..8a0a0a6c911
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindIn.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from blib\lib\Tk\Toplevel.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Toplevel;
+
+#line 128 "blib\lib\Tk\Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_BindIn.al)"
+# tkFocusGroup_BindIn --
+#
+# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
+# called when the widget is focused on by the user.
+#
+sub FG_BindIn {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd);
+}
+
+# end of Tk::Toplevel::FG_BindIn
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindOut.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindOut.al
new file mode 100755
index 00000000000..d7fb14d40dc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_BindOut.al
@@ -0,0 +1,20 @@
+# NOTE: Derived from blib\lib\Tk\Toplevel.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Toplevel;
+
+#line 139 "blib\lib\Tk\Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_BindOut.al)"
+# tkFocusGroup_BindOut --
+#
+# Add a widget into the "FocusOut" list of the focus group. The
+# $cmd will be called when the widget loses the focus (User
+# types Tab or click on another widget).
+#
+sub FG_BindOut {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd);
+}
+
+# end of Tk::Toplevel::FG_BindOut
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Create.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Create.al
new file mode 100755
index 00000000000..34bb933cfa0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Create.al
@@ -0,0 +1,56 @@
+# NOTE: Derived from blib\lib\Tk\Toplevel.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Toplevel;
+
+#line 80 "blib\lib\Tk\Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_Create.al)"
+#----------------------------------------------------------------------
+#
+# Focus Group
+#
+# Focus groups are used to handle the user's focusing actions inside a
+# toplevel.
+#
+# One example of using focus groups is: when the user focuses on an
+# entry, the text in the entry is highlighted and the cursor is put to
+# the end of the text. When the user changes focus to another widget,
+# the text in the previously focused entry is validated.
+#
+
+#----------------------------------------------------------------------
+# tkFocusGroup_Create --
+#
+# Create a focus group. All the widgets in a focus group must be
+# within the same focus toplevel. Each toplevel can have only
+# one focus group, which is identified by the name of the
+# toplevel widget.
+#
+sub FG_Create {
+ my $t = shift;
+ unless (exists $t->{'_fg'}) {
+ $t->{'_fg'} = 1;
+ $t->bind('<FocusIn>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_In($w, $Ev->d);
+ }
+ );
+ $t->bind('<FocusOut>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Out($w, $Ev->d);
+ }
+ );
+ $t->bind('<Destroy>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Destroy($w);
+ }
+ );
+ # <Destroy> is not sufficient to break loops if never mapped.
+ $t->OnDestroy([$t,'FG_Destroy']);
+ }
+}
+
+# end of Tk::Toplevel::FG_Create
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Destroy.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Destroy.al
new file mode 100755
index 00000000000..e0af457799f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Destroy.al
@@ -0,0 +1,29 @@
+# NOTE: Derived from blib\lib\Tk\Toplevel.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Toplevel;
+
+#line 151 "blib\lib\Tk\Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_Destroy.al)"
+# tkFocusGroup_Destroy --
+#
+# Cleans up when members of the focus group is deleted, or when the
+# toplevel itself gets deleted.
+#
+sub FG_Destroy {
+ my($t, $w) = @_;
+ if (!defined($w) || $t == $w) {
+ delete $t->{'_fg'};
+ delete $t->{'_focus'};
+ delete $t->{'_FocusOut'};
+ delete $t->{'_FocusIn'};
+ } else {
+ if (exists $t->{'_focus'}) {
+ delete $t->{'_focus'} if ($t->{'_focus'} == $w);
+ }
+ delete $t->{'_FocusIn'}{$w};
+ delete $t->{'_FocusOut'}{$w};
+ }
+}
+
+# end of Tk::Toplevel::FG_Destroy
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_In.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_In.al
new file mode 100755
index 00000000000..74cf18b9b9d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_In.al
@@ -0,0 +1,24 @@
+# NOTE: Derived from blib\lib\Tk\Toplevel.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Toplevel;
+
+#line 172 "blib\lib\Tk\Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_In.al)"
+# tkFocusGroup_In --
+#
+# Handles the <FocusIn> event. Calls the FocusIn command for the newly
+# focused widget in the focus group.
+#
+sub FG_In {
+ my($t, $w, $detail) = @_;
+ if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) {
+ # This is already in focus
+ return;
+ } else {
+ $t->{'_focus'} = $w;
+ $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w};
+ }
+}
+
+# end of Tk::Toplevel::FG_In
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Out.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Out.al
new file mode 100755
index 00000000000..9dfaffe9d2e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/FG_Out.al
@@ -0,0 +1,32 @@
+# NOTE: Derived from blib\lib\Tk\Toplevel.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Toplevel;
+
+#line 188 "blib\lib\Tk\Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_Out.al)"
+# tkFocusGroup_Out --
+#
+# Handles the <FocusOut> event. Checks if this is really a lose
+# focus event, not one generated by the mouse moving out of the
+# toplevel window. Calls the FocusOut command for the widget
+# who loses its focus.
+#
+sub FG_Out {
+ my($t, $w, $detail) = @_;
+ if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') {
+ # This is caused by mouse moving out of the window
+ return;
+ }
+ unless (exists $t->{'_FocusOut'}{$w}) {
+ return;
+ } else {
+ $t->{'_FocusOut'}{$w}->Call;
+ delete $t->{'_focus'};
+ }
+}
+
+1;
+
+__END__
+1;
+# end of Tk::Toplevel::FG_Out
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/autosplit.ix
new file mode 100755
index 00000000000..859b90d9a40
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Toplevel/autosplit.ix
@@ -0,0 +1,10 @@
+# Index created by AutoSplit for blib\lib\Tk\Toplevel.pm
+# (file acts as timestamp)
+package Tk::Toplevel;
+sub FG_Create ;
+sub FG_BindIn ;
+sub FG_BindOut ;
+sub FG_Destroy ;
+sub FG_In ;
+sub FG_Out ;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/TraverseToMenu.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TraverseToMenu.al
new file mode 100755
index 00000000000..73412e5dc58
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/TraverseToMenu.al
@@ -0,0 +1,27 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 722 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\TraverseToMenu.al)"
+# 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);
+}
+
+# end of Tk::TraverseToMenu
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/ASkludge.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/ASkludge.al
new file mode 100755
index 00000000000..91c49d8511e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/ASkludge.al
@@ -0,0 +1,30 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1508 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\ASkludge.al)"
+sub ASkludge
+{
+ my ($hash,$sense) = @_;
+ foreach my $key (%$hash)
+ {
+ if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR')
+ {
+ if ($sense)
+ {
+ my $val = ${$hash->{$key}};
+ require Tie::Scalar;
+ tie ${$hash->{$key}},'Tie::StdScalar';
+ ${$hash->{$key}} = $val;
+ }
+ else
+ {
+ untie ${$hash->{$key}};
+ }
+ }
+ }
+}
+
+# end of Tk::Widget::ASkludge
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AltKeyInDialog.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AltKeyInDialog.al
new file mode 100755
index 00000000000..463a8da2c6b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AltKeyInDialog.al
@@ -0,0 +1,20 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1672 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\AltKeyInDialog.al)"
+# ::tk::AltKeyInDialog --
+# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
+# to button or label which has appropriate underlined character
+#
+sub AltKeyInDialog
+{
+ my ($w, $key) = @_;
+ my $target = $w->FindAltKeyTarget($key);
+ return if !$target;
+ $target->eventGenerate('<<AltUnderlined>>');
+}
+
+# end of Tk::Widget::AltKeyInDialog
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AmpWidget.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AmpWidget.al
new file mode 100755
index 00000000000..c98f42d38db
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/AmpWidget.al
@@ -0,0 +1,36 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1614 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\AmpWidget.al)"
+# ::tk::AmpWidget --
+# Creates new widget, turning -text option into -text and
+# -underline options, returned by ::tk::UnderlineAmpersand.
+#
+sub AmpWidget
+{
+ my ($w,$class,%args) = @_;
+ my @options;
+ while(my($opt,$val) = each %args)
+ {
+ if ($opt eq "-text")
+ {
+ my ($newtext,$under) = $w->UnderlineAmpersand($val);
+ push @options, -text => $newtext, -underline => $under;
+ }
+ else
+ {
+ push @options, $opt, $val;
+ }
+ }
+ my $result = $w->$class(@options);
+ if ($result->can('AmpWidgetPostHook'))
+ {
+ $result->AmpWidgetPostHook;
+ }
+ return $result;
+}
+
+# end of Tk::Widget::AmpWidget
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/FindAltKeyTarget.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/FindAltKeyTarget.al
new file mode 100755
index 00000000000..c152adb0347
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/FindAltKeyTarget.al
@@ -0,0 +1,38 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1642 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\FindAltKeyTarget.al)"
+# ::tk::FindAltKeyTarget --
+# search recursively through the hierarchy of visible widgets
+# to find button or label which has $char as underlined character
+#
+sub FindAltKeyTarget
+{
+ my ($w,$char) = @_;
+ $char = lc $char;
+ if ($w->isa('Tk::Button') || $w->isa('Tk::Label'))
+ {
+ if ($char eq lc substr($w->cget(-text), $w->cget(-underline), 1))
+ {
+ return $w;
+ }
+ else
+ {
+ return undef;
+ }
+ }
+ else
+ {
+ for my $cw ($w->gridSlaves, $w->packSlaves, $w->placeSlaves) # Cannot handle $w->formSlaves here?
+ {
+ my $target = $cw->FindAltKeyTarget($char);
+ return $target if ($target);
+ }
+ }
+ undef;
+}
+
+# end of Tk::Widget::FindAltKeyTarget
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/MasterMenu.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/MasterMenu.al
new file mode 100755
index 00000000000..510e8bb6b5c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/MasterMenu.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1765 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\MasterMenu.al)"
+# See http://rt.cpan.org/Ticket/Display.html?id=30929 and
+# http://rt.cpan.org/Ticket/Display.html?id=31016
+sub MasterMenu
+ {
+ }
+
+1;
+# end of Tk::Widget::MasterMenu
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/RestoreFocusGrab.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/RestoreFocusGrab.al
new file mode 100755
index 00000000000..3744f3fcb33
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/RestoreFocusGrab.al
@@ -0,0 +1,59 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1714 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\RestoreFocusGrab.al)"
+# ::tk::RestoreFocusGrab --
+# restore old focus and grab (for dialogs)
+# Arguments:
+# grab window that had taken grab
+# focus window that had taken focus
+# destroy destroy|withdraw - how to handle the old grabbed window
+# Results:
+# Returns nothing
+#
+sub RestoreFocusGrab
+{
+ my ($grab, $focus, $destroy) = @_;
+ $destroy = 'destroy' if !$destroy;
+ my $index = "$grab,$focus";
+ my ($oldFocus, $oldGrab, $oldStatus);
+ if (exists $Tk::FocusGrab{$index})
+ {
+ ($oldFocus, $oldGrab, $oldStatus) = $Tk::FocusGrab{$index};
+ delete $Tk::FocusGrab{$index};
+ }
+ else
+ {
+ $oldGrab = "";
+ }
+
+ Tk::catch { $oldFocus->focus };
+ if (Tk::Exists($grab))
+ {
+ $grab->grabRelease;
+ if ($destroy eq "withdraw")
+ {
+ $grab->withdraw;
+ }
+ else
+ {
+ $grab->destroy;
+ }
+ }
+ if (Tk::Exists($oldGrab) && $oldGrab->ismapped)
+ {
+ if ($oldStatus eq "global")
+ {
+ $oldGrab->grabGlobal;
+ }
+ else
+ {
+ $oldGrab->grab;
+ }
+ }
+}
+
+# end of Tk::Widget::RestoreFocusGrab
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetAmpText.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetAmpText.al
new file mode 100755
index 00000000000..01029718d24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetAmpText.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1603 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\SetAmpText.al)"
+# ::tk::SetAmpText --
+# Given widget path and text with "magic ampersands",
+# sets -text and -underline options for the widget
+#
+sub SetAmpText
+{
+ my ($w,$text) = @_;
+ my ($newtext,$under) = $w->UnderlineAmpersand($text);
+ $w->configure(-text => $newtext, -underline => $under);
+}
+
+# end of Tk::Widget::SetAmpText
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetFocusGrab.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetFocusGrab.al
new file mode 100755
index 00000000000..3aa45d65312
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/SetFocusGrab.al
@@ -0,0 +1,38 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1684 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\SetFocusGrab.al)"
+# ::tk::SetFocusGrab --
+# swap out current focus and grab temporarily (for dialogs)
+# Arguments:
+# grab new window to grab
+# focus window to give focus to
+# Results:
+# Returns nothing
+#
+sub SetFocusGrab
+{
+ my ($grab,$focus) = @_;
+ my $index = "$grab,$focus";
+ $Tk::FocusGrab{$index} ||= [];
+ my $data = $Tk::FocusGrab{$index};
+ push @$data, $grab->focusCurrent;
+ my $oldGrab = $grab->grabCurrent;
+ push @$data, $oldGrab;
+ if (Tk::Exists($oldGrab))
+ {
+ push @$data, $oldGrab->grabStatus;
+ }
+ # The "grab" command will fail if another application
+ # already holds the grab. So catch it.
+ Tk::catch { $grab->grab };
+ if (Tk::Exists($focus))
+ {
+ $focus->focus;
+ }
+}
+
+# end of Tk::Widget::SetFocusGrab
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/UnderlineAmpersand.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/UnderlineAmpersand.al
new file mode 100755
index 00000000000..f1eee316c7a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/UnderlineAmpersand.al
@@ -0,0 +1,29 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1582 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\UnderlineAmpersand.al)"
+# ::tk::UnderlineAmpersand --
+# This procedure takes some text with ampersand and returns
+# text w/o ampersand and position of the ampersand.
+# Double ampersands are converted to single ones.
+# Position returned is -1 when there is no ampersand.
+#
+sub UnderlineAmpersand
+{
+ my (undef,$text) = @_;
+ if ($text =~ m{(?<!&)&(?!&)}g)
+ {
+ my $idx = pos $text;
+ $text =~ s{(?<!&)&(?!&)}{};
+ ($text, $idx);
+ }
+ else
+ {
+ ($text, -1);
+ }
+}
+
+# end of Tk::Widget::UnderlineAmpersand
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/autosplit.ix
new file mode 100755
index 00000000000..7844cc0b25e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/autosplit.ix
@@ -0,0 +1,27 @@
+# Index created by AutoSplit for blib\lib\Tk\Widget.pm
+# (file acts as timestamp)
+package Tk::Widget;
+sub bindDump ;
+sub ASkludge
+;
+sub clipboardKeysyms
+;
+sub pathname
+;
+sub UnderlineAmpersand
+;
+sub SetAmpText
+;
+sub AmpWidget
+;
+sub FindAltKeyTarget
+;
+sub AltKeyInDialog
+;
+sub SetFocusGrab
+;
+sub RestoreFocusGrab
+;
+sub MasterMenu
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/bindDump.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/bindDump.al
new file mode 100755
index 00000000000..b39fac08fc0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/bindDump.al
@@ -0,0 +1,87 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1428 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\bindDump.al)"
+sub bindDump {
+
+ # Dump lots of good binding information. This pretty-print subroutine
+ # is, essentially, the following code in disguise:
+ #
+ # print "Binding information for $w\n";
+ # foreach my $tag ($w->bindtags) {
+ # printf "\n Binding tag '$tag' has these bindings:\n";
+ # foreach my $binding ($w->bind($tag)) {
+ # printf " $binding\n";
+ # }
+ # }
+
+ my ($w) = @_;
+
+ my (@bindtags) = $w->bindtags;
+ my $digits = length( scalar @bindtags );
+ my ($spc1, $spc2) = ($digits + 33, $digits + 35);
+ my $format1 = "%${digits}d.";
+ my $format2 = ' ' x ($digits + 2);
+ my $n = 0;
+
+ my @out;
+ push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w );
+
+ foreach my $tag (@bindtags) {
+ my (@bindings) = $w->bind($tag);
+ $n++; # count this bindtag
+
+ if ($#bindings == -1) {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n );
+ } else {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n );
+
+ foreach my $binding ( @bindings ) {
+ my $callback = $w->bind($tag, $binding);
+ push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback );
+
+ if ($callback =~ /SCALAR/) {
+ if (ref $$callback) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback );
+ }
+ } elsif ($callback =~ /ARRAY/) {
+ if (ref $callback->[0]) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" );
+ }
+ foreach my $arg (@$callback[1 .. $#$callback]) {
+ if (ref $arg) {
+ push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
+ } else {
+ push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
+ }
+
+ if (ref $arg eq 'Tk::Ev') {
+ if ($arg =~ /SCALAR/) {
+ push @out, sprintf( ": '$$arg'" );
+ } else {
+ push @out, sprintf( ": '%s'", join("' '", @$arg) );
+ }
+ }
+
+ push @out, sprintf( "\n" );
+ } # forend callback arguments
+ } # ifend callback
+
+ } # forend all bindings for one tag
+
+ } # ifend have bindings
+
+ } # forend all tags
+ push @out, sprintf( "\n" );
+ return @out;
+
+} # end bindDump
+
+# end of Tk::Widget::bindDump
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/clipboardKeysyms.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/clipboardKeysyms.al
new file mode 100755
index 00000000000..538fa0e42d8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/clipboardKeysyms.al
@@ -0,0 +1,51 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1532 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\clipboardKeysyms.al)"
+# clipboardKeysyms --
+# This procedure is invoked to identify the keys that correspond to
+# the "copy", "cut", and "paste" functions for the clipboard.
+#
+# Arguments:
+# copy - Name of the key (keysym name plus modifiers, if any,
+# such as "Meta-y") used for the copy operation.
+# cut - Name of the key used for the cut operation.
+# paste - Name of the key used for the paste operation.
+#
+# This method is obsolete use clipboardOperations and abstract
+# event types instead. See Clipboard.pm and Mainwindow.pm
+
+sub clipboardKeysyms
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ if (@_)
+ {
+ my $copy = shift;
+ $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy);
+ }
+ if (@_)
+ {
+ my $cut = shift;
+ $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut);
+ }
+ if (@_)
+ {
+ my $paste = shift;
+ $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste);
+ }
+}
+
+# end of Tk::Widget::clipboardKeysyms
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/pathname.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/pathname.al
new file mode 100755
index 00000000000..10ac95fa2c6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Widget/pathname.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Tk\Widget.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Widget;
+
+#line 1575 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\pathname.al)"
+sub pathname
+{
+ my ($w,$id) = @_;
+ my $x = $w->winfo('pathname',-displayof => oct($id));
+ return $x->PathName;
+}
+
+# end of Tk::Widget::pathname
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/AnchorAdjust.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/AnchorAdjust.al
new file mode 100755
index 00000000000..538612878ed
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/AnchorAdjust.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 87 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\AnchorAdjust.al)"
+sub AnchorAdjust
+{
+ my ($anchor,$X,$Y,$w,$h) = @_;
+ $anchor = 'c' unless (defined $anchor);
+ $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
+ $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
+ return ($X,$Y);
+}
+
+# end of Tk::Wm::AnchorAdjust
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/FullScreen.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/FullScreen.al
new file mode 100755
index 00000000000..4d5702cc60d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/FullScreen.al
@@ -0,0 +1,29 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 138 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\FullScreen.al)"
+sub FullScreen
+{
+ my $w = shift;
+ my $over = (@_) ? shift : 0;
+ my $width = $w->screenwidth;
+ my $height = $w->screenheight;
+ $w->GeometryRequest($width,$height);
+ $w->overrideredirect($over & 1);
+ $w->Post(0,0);
+ $w->update;
+ if ($over & 2)
+ {
+ my $x = $w->rootx;
+ my $y = $w->rooty;
+ $width -= 2*$x;
+ $height -= $x + $y;
+ $w->GeometryRequest($width,$height);
+ $w->update;
+ }
+}
+
+# end of Tk::Wm::FullScreen
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Popup.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Popup.al
new file mode 100755
index 00000000000..3f460c5bac6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Popup.al
@@ -0,0 +1,50 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 96 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Popup.al)"
+sub Popup
+{
+ my $w = shift;
+ $w->configure(@_) if @_;
+ $w->idletasks;
+ my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
+ my ($rx,$ry,$rw,$rh) = (0,0,0,0);
+ my $base = $w->cget('-popover');
+ my $outside = 0;
+ if (defined $base)
+ {
+ if ($base eq 'cursor')
+ {
+ ($rx,$ry) = $w->pointerxy;
+ }
+ else
+ {
+ $rx = $base->rootx;
+ $ry = $base->rooty;
+ $rw = $base->Width;
+ $rh = $base->Height;
+ }
+ }
+ else
+ {
+ my $sc = ($w->parent) ? $w->parent->toplevel : $w;
+ $rx = -$sc->vrootx;
+ $ry = -$sc->vrooty;
+ $rw = $w->screenwidth;
+ $rh = $w->screenheight;
+ }
+ my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
+ ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
+ # adjust to not cross screen borders
+ if ($X < 0) { $X = 0 }
+ if ($Y < 0) { $Y = 0 }
+ if ($mw > $w->screenwidth) { $X = 0 }
+ if ($mh > $w->screenheight) { $Y = 0 }
+ $w->Post($X,$Y);
+ $w->waitVisibility;
+}
+
+# end of Tk::Wm::Popup
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Post.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Post.al
new file mode 100755
index 00000000000..f3f5c8e3e08
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/Post.al
@@ -0,0 +1,20 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 75 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Post.al)"
+sub Post
+{
+ my ($w,$X,$Y) = @_;
+ $X = int($X);
+ $Y = int($Y);
+ $w->positionfrom('user');
+ $w->geometry("+$X+$Y");
+ # $w->MoveToplevelWindow($X,$Y);
+ $w->deiconify;
+ $w->raise;
+}
+
+# end of Tk::Wm::Post
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/autosplit.ix
new file mode 100755
index 00000000000..201dbe8ba99
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/autosplit.ix
@@ -0,0 +1,14 @@
+# Index created by AutoSplit for blib\lib\Tk\Wm.pm
+# (file acts as timestamp)
+package Tk::Wm;
+sub Post
+;
+sub AnchorAdjust
+;
+sub Popup
+;
+sub FullScreen
+;
+sub iconposition
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/iconposition.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/iconposition.al
new file mode 100755
index 00000000000..9254968f61c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Wm/iconposition.al
@@ -0,0 +1,24 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 159 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\iconposition.al)"
+sub iconposition
+{
+ my $w = shift;
+ if (@_ == 1)
+ {
+ return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
+ if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
+ {
+ my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
+ my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
+ return $w->wm('iconposition',$x,$y);
+ }
+ }
+ $w->wm('iconposition',@_);
+}
+
+1;
+# end of Tk::Wm::iconposition
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/X.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/X.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/X.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/X.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/X.dll
new file mode 100755
index 00000000000..f99eb5be549
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/X.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/autosplit.ix
new file mode 100755
index 00000000000..e63dbf19b00
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/X/autosplit.ix
@@ -0,0 +1,3 @@
+# Index created by AutoSplit for ..\..\blib\lib\Tk\X.pm
+# (file acts as timestamp)
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.bs b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.dll b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.dll
new file mode 100755
index 00000000000..e2b3a0d1663
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/Xlib/Xlib.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/autosplit.ix b/Master/tlpkg/tlperl.straw/lib/auto/Tk/autosplit.ix
new file mode 100755
index 00000000000..8fb1449e58f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/autosplit.ix
@@ -0,0 +1,49 @@
+# Index created by AutoSplit for blib\lib\Tk.pm
+# (file acts as timestamp)
+package Tk;
+sub Error
+;
+sub CancelRepeat
+;
+sub RepeatId
+;
+sub FocusChildren ;
+sub focusNext
+;
+sub getNextFocus
+;
+sub focusPrev
+;
+sub getPrevFocus
+;
+sub FocusOK
+;
+sub EnterFocus
+;
+sub tabFocus
+;
+sub focusFollowsMouse
+;
+sub TraverseToMenu
+;
+sub FirstMenu
+;
+sub Selection
+;
+sub Receive
+;
+sub break
+;
+sub updateWidgets
+;
+sub ImageNames
+;
+sub ImageTypes
+;
+sub interps
+;
+sub lsearch
+;
+sub getEncoding
+;
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/break.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/break.al
new file mode 100755
index 00000000000..4aa6c220d97
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/break.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 778 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\break.al)"
+sub break
+{
+ die "_TK_BREAK_\n";
+}
+
+# end of Tk::break
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusFollowsMouse.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusFollowsMouse.al
new file mode 100755
index 00000000000..48f2d2552cc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusFollowsMouse.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 716 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\focusFollowsMouse.al)"
+sub focusFollowsMouse
+{
+ my $widget = shift;
+ $widget->bind('all','<Enter>','EnterFocus');
+}
+
+# end of Tk::focusFollowsMouse
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusNext.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusNext.al
new file mode 100755
index 00000000000..a8eeb5fc55f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusNext.al
@@ -0,0 +1,18 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 552 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\focusNext.al)"
+sub focusNext
+{
+ my $w = shift;
+ my $cur = $w->getNextFocus;
+ if ($cur)
+ {
+ $cur->tabFocus;
+ }
+}
+
+# end of Tk::focusNext
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusPrev.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusPrev.al
new file mode 100755
index 00000000000..effc8f75110
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/focusPrev.al
@@ -0,0 +1,28 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 597 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\focusPrev.al)"
+# 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;
+ }
+}
+
+# end of Tk::focusPrev
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/getEncoding.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/getEncoding.al
new file mode 100755
index 00000000000..1ac20ba8d7d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/getEncoding.al
@@ -0,0 +1,43 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 820 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\getEncoding.al)"
+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;
+}
+
+1;
+# end of Tk::getEncoding
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/getNextFocus.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/getNextFocus.al
new file mode 100755
index 00000000000..456c393b3c2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/getNextFocus.al
@@ -0,0 +1,44 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 562 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\getNextFocus.al)"
+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;
+ }
+ }
+}
+
+# end of Tk::getNextFocus
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/getPrevFocus.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/getPrevFocus.al
new file mode 100755
index 00000000000..85912416379
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/getPrevFocus.al
@@ -0,0 +1,54 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 617 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\getPrevFocus.al)"
+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;
+ }
+ }
+
+}
+
+# end of Tk::getPrevFocus
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/interps.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/interps.al
new file mode 100755
index 00000000000..507c66037fd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/interps.al
@@ -0,0 +1,14 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 802 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\interps.al)"
+sub interps
+{
+ my $w = shift;
+ return $w->winfo('interps','-displayof');
+}
+
+# end of Tk::interps
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/lsearch.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/lsearch.al
new file mode 100755
index 00000000000..61c82143f7b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/lsearch.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 808 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\lsearch.al)"
+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;
+}
+
+# end of Tk::lsearch
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/pTk/extralibs.ld b/Master/tlpkg/tlperl.straw/lib/auto/Tk/pTk/extralibs.ld
new file mode 100755
index 00000000000..2977aa9fd7d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/pTk/extralibs.ld
@@ -0,0 +1 @@
+C:\strawberry\c\lib\libcomdlg32.a C:\strawberry\c\lib\libgdi32.a C:\strawberry\c\lib\libmoldname.a C:\strawberry\c\lib\libkernel32.a C:\strawberry\c\lib\libuser32.a C:\strawberry\c\lib\libgdi32.a C:\strawberry\c\lib\libwinspool.a C:\strawberry\c\lib\libcomdlg32.a C:\strawberry\c\lib\libadvapi32.a C:\strawberry\c\lib\libshell32.a C:\strawberry\c\lib\libole32.a C:\strawberry\c\lib\liboleaut32.a C:\strawberry\c\lib\libnetapi32.a C:\strawberry\c\lib\libuuid.a C:\strawberry\c\lib\libws2_32.a C:\strawberry\c\lib\libmpr.a C:\strawberry\c\lib\libwinmm.a C:\strawberry\c\lib\libversion.a C:\strawberry\c\lib\libodbc32.a C:\strawberry\c\lib\libodbccp32.a
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/tabFocus.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/tabFocus.al
new file mode 100755
index 00000000000..c01d6940cf4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/tabFocus.al
@@ -0,0 +1,13 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 711 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\tabFocus.al)"
+sub tabFocus
+{
+ shift->Tk::focus;
+}
+
+# end of Tk::tabFocus
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tk/updateWidgets.al b/Master/tlpkg/tlperl.straw/lib/auto/Tk/updateWidgets.al
new file mode 100755
index 00000000000..980a6bbc632
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tk/updateWidgets.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 783 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\updateWidgets.al)"
+sub updateWidgets
+{
+ my ($w) = @_;
+ while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
+ {
+ }
+ $w;
+}
+
+# end of Tk::updateWidgets
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Tree/DAG_Node/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Tree/DAG_Node/.packlist
new file mode 100755
index 00000000000..6388eb83be1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Tree/DAG_Node/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Tree\DAG_Node.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/URI/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/URI/.packlist
new file mode 100755
index 00000000000..c65e55da5d7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/URI/.packlist
@@ -0,0 +1,52 @@
+C:\strawberry\perl\vendor\lib\URI.pm
+C:\strawberry\perl\vendor\lib\URI\Escape.pm
+C:\strawberry\perl\vendor\lib\URI\Heuristic.pm
+C:\strawberry\perl\vendor\lib\URI\IRI.pm
+C:\strawberry\perl\vendor\lib\URI\QueryParam.pm
+C:\strawberry\perl\vendor\lib\URI\Split.pm
+C:\strawberry\perl\vendor\lib\URI\URL.pm
+C:\strawberry\perl\vendor\lib\URI\WithBase.pm
+C:\strawberry\perl\vendor\lib\URI\_foreign.pm
+C:\strawberry\perl\vendor\lib\URI\_generic.pm
+C:\strawberry\perl\vendor\lib\URI\_idna.pm
+C:\strawberry\perl\vendor\lib\URI\_ldap.pm
+C:\strawberry\perl\vendor\lib\URI\_login.pm
+C:\strawberry\perl\vendor\lib\URI\_punycode.pm
+C:\strawberry\perl\vendor\lib\URI\_query.pm
+C:\strawberry\perl\vendor\lib\URI\_segment.pm
+C:\strawberry\perl\vendor\lib\URI\_server.pm
+C:\strawberry\perl\vendor\lib\URI\_userpass.pm
+C:\strawberry\perl\vendor\lib\URI\data.pm
+C:\strawberry\perl\vendor\lib\URI\file.pm
+C:\strawberry\perl\vendor\lib\URI\file\Base.pm
+C:\strawberry\perl\vendor\lib\URI\file\FAT.pm
+C:\strawberry\perl\vendor\lib\URI\file\Mac.pm
+C:\strawberry\perl\vendor\lib\URI\file\OS2.pm
+C:\strawberry\perl\vendor\lib\URI\file\QNX.pm
+C:\strawberry\perl\vendor\lib\URI\file\Unix.pm
+C:\strawberry\perl\vendor\lib\URI\file\Win32.pm
+C:\strawberry\perl\vendor\lib\URI\ftp.pm
+C:\strawberry\perl\vendor\lib\URI\gopher.pm
+C:\strawberry\perl\vendor\lib\URI\http.pm
+C:\strawberry\perl\vendor\lib\URI\https.pm
+C:\strawberry\perl\vendor\lib\URI\ldap.pm
+C:\strawberry\perl\vendor\lib\URI\ldapi.pm
+C:\strawberry\perl\vendor\lib\URI\ldaps.pm
+C:\strawberry\perl\vendor\lib\URI\mailto.pm
+C:\strawberry\perl\vendor\lib\URI\mms.pm
+C:\strawberry\perl\vendor\lib\URI\news.pm
+C:\strawberry\perl\vendor\lib\URI\nntp.pm
+C:\strawberry\perl\vendor\lib\URI\pop.pm
+C:\strawberry\perl\vendor\lib\URI\rlogin.pm
+C:\strawberry\perl\vendor\lib\URI\rsync.pm
+C:\strawberry\perl\vendor\lib\URI\rtsp.pm
+C:\strawberry\perl\vendor\lib\URI\rtspu.pm
+C:\strawberry\perl\vendor\lib\URI\sip.pm
+C:\strawberry\perl\vendor\lib\URI\sips.pm
+C:\strawberry\perl\vendor\lib\URI\snews.pm
+C:\strawberry\perl\vendor\lib\URI\ssh.pm
+C:\strawberry\perl\vendor\lib\URI\telnet.pm
+C:\strawberry\perl\vendor\lib\URI\tn3270.pm
+C:\strawberry\perl\vendor\lib\URI\urn.pm
+C:\strawberry\perl\vendor\lib\URI\urn\isbn.pm
+C:\strawberry\perl\vendor\lib\URI\urn\oid.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Unicode/Normalize/Normalize.dll b/Master/tlpkg/tlperl.straw/lib/auto/Unicode/Normalize/Normalize.dll
new file mode 100755
index 00000000000..26b18601f3b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Unicode/Normalize/Normalize.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/.packlist
new file mode 100755
index 00000000000..2df7f0622c9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/.packlist
@@ -0,0 +1,9 @@
+C:\strawberry\perl\vendor\lib\Win32\API.pm
+C:\strawberry\perl\vendor\lib\Win32\API\Callback.pm
+C:\strawberry\perl\vendor\lib\Win32\API\Struct.pm
+C:\strawberry\perl\vendor\lib\Win32\API\Test.pm
+C:\strawberry\perl\vendor\lib\Win32\API\Type.pm
+C:\strawberry\perl\vendor\lib\auto\Win32\API\API.bs
+C:\strawberry\perl\vendor\lib\auto\Win32\API\API.dll
+C:\strawberry\perl\vendor\lib\auto\Win32\API\Callback\Callback.bs
+C:\strawberry\perl\vendor\lib\auto\Win32\API\Callback\Callback.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/API.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/API.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/API.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/API.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/API.dll
new file mode 100755
index 00000000000..e8315b61e25
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/API.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.dll
new file mode 100755
index 00000000000..e44e4ee127f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/API/Callback/Callback.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/.packlist
new file mode 100755
index 00000000000..7e7f1416c62
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Win32\EventLog.pm
+C:\strawberry\perl\vendor\lib\auto\Win32\EventLog\EventLog.bs
+C:\strawberry\perl\vendor\lib\auto\Win32\EventLog\EventLog.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.dll
new file mode 100755
index 00000000000..2a7fcd2be9a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/EventLog/EventLog.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Exe/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Exe/.packlist
new file mode 100755
index 00000000000..a3c77e8bb81
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Exe/.packlist
@@ -0,0 +1,28 @@
+C:\strawberry\perl\bin\exe_update.bat
+C:\strawberry\perl\bin\exe_update.pl
+C:\strawberry\perl\vendor\lib\Win32\Exe.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Base.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\DataDirectory.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\DebugDirectory.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\DebugTable.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\IconFile.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\PE.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\PE\Header.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\PE\Header\PE32.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Resource.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\ResourceData.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\ResourceEntry.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\ResourceEntry\Id.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\ResourceEntry\Name.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\ResourceTable.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Resource\GroupIcon.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Resource\Icon.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Resource\Manifest.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Resource\Version.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Section.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Section\Code.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Section\Data.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Section\Debug.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Section\Exports.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Section\Imports.pm
+C:\strawberry\perl\vendor\lib\Win32\Exe\Section\Resources.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/.packlist
new file mode 100755
index 00000000000..ca037534cda
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Win32\File.pm
+C:\strawberry\perl\vendor\lib\auto\Win32\File\File.bs
+C:\strawberry\perl\vendor\lib\auto\Win32\File\File.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/File.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/File.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/File.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/File.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/File.dll
new file mode 100755
index 00000000000..1e5aabc9b58
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/File.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/Object/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/Object/.packlist
new file mode 100755
index 00000000000..7c0fdbc4fe2
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/File/Object/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\Win32\File\Object.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/.packlist
new file mode 100755
index 00000000000..9bbc7669357
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Win32\Process.pm
+C:\strawberry\perl\vendor\lib\auto\Win32\Process\Process.bs
+C:\strawberry\perl\vendor\lib\auto\Win32\Process\Process.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.dll
new file mode 100755
index 00000000000..b2d581f7e90
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Process/Process.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/.packlist
new file mode 100755
index 00000000000..5a7d0e10df4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\site\lib\Win32\Shortcut.pm
+C:\strawberry\perl\site\lib\auto\Win32\Shortcut\Shortcut.bs
+C:\strawberry\perl\site\lib\auto\Win32\Shortcut\Shortcut.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.dll
new file mode 100755
index 00000000000..f42ad0fc380
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Shortcut/Shortcut.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/TieRegistry/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/TieRegistry/.packlist
new file mode 100755
index 00000000000..4c7c0ae0128
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/TieRegistry/.packlist
@@ -0,0 +1,2 @@
+C:\strawberry\perl\vendor\lib\Tie\Registry.pm
+C:\strawberry\perl\vendor\lib\Win32\TieRegistry.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/Win32.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Win32.dll
new file mode 100755
index 00000000000..20a3237eeec
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/Win32.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/.packlist
new file mode 100755
index 00000000000..82415855e81
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\vendor\lib\Win32\WinError.pm
+C:\strawberry\perl\vendor\lib\auto\Win32\WinError\WinError.bs
+C:\strawberry\perl\vendor\lib\auto\Win32\WinError\WinError.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.dll
new file mode 100755
index 00000000000..d031680b972
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32/WinError/WinError.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32API/File/File.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/File/File.dll
new file mode 100755
index 00000000000..c894b41ab9c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/File/File.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/.packlist
new file mode 100755
index 00000000000..2508c196ac0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\Win32API\Registry.pm
+C:\strawberry\perl\vendor\lib\Win32API\Registry\cRegistry.pc
+C:\strawberry\perl\vendor\lib\auto\Win32API\Registry\Registry.bs
+C:\strawberry\perl\vendor\lib\auto\Win32API\Registry\Registry.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.bs b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.dll b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.dll
new file mode 100755
index 00000000000..6bce69614df
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32API/Registry/Registry.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/Win32CORE/extralibs.ld b/Master/tlpkg/tlperl.straw/lib/auto/Win32CORE/extralibs.ld
new file mode 100755
index 00000000000..8b137891791
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/Win32CORE/extralibs.ld
@@ -0,0 +1 @@
+
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/.packlist
new file mode 100755
index 00000000000..76481f2f9bc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/.packlist
@@ -0,0 +1,43 @@
+C:\strawberry\perl\vendor\lib\XML\LibXML.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Attr.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Boolean.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\CDATASection.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Comment.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Common.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\Common.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\DOM.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Document.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\DocumentFragment.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Dtd.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Element.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\ErrNo.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\ErrNo.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Error.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\Error.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\InputCallback.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Literal.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\Namespace.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Node.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\NodeList.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\Number.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\PI.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Parser.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Pattern.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Reader.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\Reader.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\RegExp.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\RelaxNG.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\SAX.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\SAX.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\SAX\Builder.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\SAX\Builder.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\SAX\Generator.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\SAX\Parser.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\Schema.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\Text.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\XPathContext.pm
+C:\strawberry\perl\vendor\lib\XML\LibXML\XPathContext.pod
+C:\strawberry\perl\vendor\lib\XML\LibXML\XPathExpression.pod
+C:\strawberry\perl\vendor\lib\auto\XML\LibXML\LibXML.bs
+C:\strawberry\perl\vendor\lib\auto\XML\LibXML\LibXML.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.bs b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.dll b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.dll
new file mode 100755
index 00000000000..02a3989984e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXML/LibXML.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/.packlist
new file mode 100755
index 00000000000..023ecfe7ce8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/.packlist
@@ -0,0 +1,4 @@
+C:\strawberry\perl\vendor\lib\XML\LibXSLT.pm
+C:\strawberry\perl\vendor\lib\XML\benchmark.pl
+C:\strawberry\perl\vendor\lib\auto\XML\LibXSLT\LibXSLT.bs
+C:\strawberry\perl\vendor\lib\auto\XML\LibXSLT\LibXSLT.xs.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.bs b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.xs.dll b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.xs.dll
new file mode 100755
index 00000000000..da8d9e4a0a0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/LibXSLT/LibXSLT.xs.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/NamespaceSupport/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/XML/NamespaceSupport/.packlist
new file mode 100755
index 00000000000..01e42eadb77
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/NamespaceSupport/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\XML\NamespaceSupport.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/.packlist
new file mode 100755
index 00000000000..30ed036a473
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/.packlist
@@ -0,0 +1,29 @@
+C:\strawberry\perl\vendor\lib\XML\Parser.pm
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\Japanese_Encodings.msg
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\README
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\big5.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\euc-kr.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\iso-8859-2.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\iso-8859-3.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\iso-8859-4.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\iso-8859-5.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\iso-8859-7.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\iso-8859-8.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\iso-8859-9.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\windows-1250.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\windows-1252.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\x-euc-jp-jisx0221.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\x-euc-jp-unicode.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\x-sjis-cp932.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\x-sjis-jdk117.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\x-sjis-jisx0221.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Encodings\x-sjis-unicode.enc
+C:\strawberry\perl\vendor\lib\XML\Parser\Expat.pm
+C:\strawberry\perl\vendor\lib\XML\Parser\LWPExternEnt.pl
+C:\strawberry\perl\vendor\lib\XML\Parser\Style\Debug.pm
+C:\strawberry\perl\vendor\lib\XML\Parser\Style\Objects.pm
+C:\strawberry\perl\vendor\lib\XML\Parser\Style\Stream.pm
+C:\strawberry\perl\vendor\lib\XML\Parser\Style\Subs.pm
+C:\strawberry\perl\vendor\lib\XML\Parser\Style\Tree.pm
+C:\strawberry\perl\vendor\lib\auto\XML\Parser\Expat\Expat.bs
+C:\strawberry\perl\vendor\lib\auto\XML\Parser\Expat\Expat.dll
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.bs b/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.dll b/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.dll
new file mode 100755
index 00000000000..6fc95748ddb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/Parser/Expat/Expat.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/XML/SAX/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/XML/SAX/.packlist
new file mode 100755
index 00000000000..1335aeded91
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/XML/SAX/.packlist
@@ -0,0 +1,23 @@
+C:\strawberry\perl\vendor\lib\XML\SAX.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\Base.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\DocumentLocator.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\Exception.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\Intro.pod
+C:\strawberry\perl\vendor\lib\XML\SAX\ParserFactory.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\DTDDecls.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\DebugHandler.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\DocType.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\EncodingDetect.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Exception.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\NoUnicodeExt.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Productions.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Reader.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Reader\NoUnicodeExt.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Reader\Stream.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Reader\String.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Reader\URI.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\Reader\UnicodeExt.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\UnicodeExt.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\PurePerl\XMLDecl.pm
+C:\strawberry\perl\vendor\lib\XML\SAX\placeholder.pl
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/YAML/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/YAML/.packlist
new file mode 100755
index 00000000000..0534ff663b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/YAML/.packlist
@@ -0,0 +1,13 @@
+C:\strawberry\perl\vendor\lib\Test\YAML.pm
+C:\strawberry\perl\vendor\lib\YAML.pm
+C:\strawberry\perl\vendor\lib\YAML\Any.pm
+C:\strawberry\perl\vendor\lib\YAML\Base.pm
+C:\strawberry\perl\vendor\lib\YAML\Dumper.pm
+C:\strawberry\perl\vendor\lib\YAML\Dumper\Base.pm
+C:\strawberry\perl\vendor\lib\YAML\Error.pm
+C:\strawberry\perl\vendor\lib\YAML\Loader.pm
+C:\strawberry\perl\vendor\lib\YAML\Loader\Base.pm
+C:\strawberry\perl\vendor\lib\YAML\Marshall.pm
+C:\strawberry\perl\vendor\lib\YAML\Node.pm
+C:\strawberry\perl\vendor\lib\YAML\Tag.pm
+C:\strawberry\perl\vendor\lib\YAML\Types.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/YAML/Tiny/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/YAML/Tiny/.packlist
new file mode 100755
index 00000000000..bb09f007d40
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/YAML/Tiny/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\YAML\Tiny.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/attrs/attrs.dll b/Master/tlpkg/tlperl.straw/lib/auto/attrs/attrs.dll
new file mode 100755
index 00000000000..cb71ac5b0f3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/attrs/attrs.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/common/sense/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/common/sense/.packlist
new file mode 100755
index 00000000000..111ba85c562
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/common/sense/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\common\sense.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/constant/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/constant/.packlist
new file mode 100755
index 00000000000..7739844ef19
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/constant/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\constant.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/local/lib/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/local/lib/.packlist
new file mode 100755
index 00000000000..e3a9856157f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/local/lib/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\vendor\lib\local\lib.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/mro/mro.dll b/Master/tlpkg/tlperl.straw/lib/auto/mro/mro.dll
new file mode 100755
index 00000000000..d5e1972db72
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/mro/mro.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/parent/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/parent/.packlist
new file mode 100755
index 00000000000..8e430619fdd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/parent/.packlist
@@ -0,0 +1 @@
+C:\strawberry\perl\lib\parent.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/pip/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/pip/.packlist
new file mode 100755
index 00000000000..b6f6c298872
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/pip/.packlist
@@ -0,0 +1,7 @@
+C:\strawberry\perl\bin\pip
+C:\strawberry\perl\bin\pip.bat
+C:\strawberry\perl\vendor\lib\Module\P5Z.pm
+C:\strawberry\perl\vendor\lib\Module\Plan\Archive.pm
+C:\strawberry\perl\vendor\lib\Module\Plan\Base.pm
+C:\strawberry\perl\vendor\lib\Module\Plan\Lite.pm
+C:\strawberry\perl\vendor\lib\pip.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/pler/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/pler/.packlist
new file mode 100755
index 00000000000..b8f385828d4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/pler/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\bin\pler
+C:\strawberry\perl\bin\pler.bat
+C:\strawberry\perl\vendor\lib\pler.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/re/re.dll b/Master/tlpkg/tlperl.straw/lib/auto/re/re.dll
new file mode 100755
index 00000000000..a42ee9fb3e4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/re/re.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/sdbm/extralibs.ld b/Master/tlpkg/tlperl.straw/lib/auto/sdbm/extralibs.ld
new file mode 100755
index 00000000000..8b137891791
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/sdbm/extralibs.ld
@@ -0,0 +1 @@
+
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/threads/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/threads/.packlist
new file mode 100755
index 00000000000..d9613b5f2ee
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/threads/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\lib\auto\threads\threads.bs
+C:\strawberry\perl\lib\auto\threads\threads.dll
+C:\strawberry\perl\lib\threads.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/.packlist
new file mode 100755
index 00000000000..6342304b14d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/.packlist
@@ -0,0 +1,3 @@
+C:\strawberry\perl\lib\auto\threads\shared\shared.bs
+C:\strawberry\perl\lib\auto\threads\shared\shared.dll
+C:\strawberry\perl\lib\threads\shared.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.bs b/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.dll b/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.dll
new file mode 100755
index 00000000000..5c825fad62e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/threads/shared/shared.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/threads/threads.bs b/Master/tlpkg/tlperl.straw/lib/auto/threads/threads.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/threads/threads.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/threads/threads.dll b/Master/tlpkg/tlperl.straw/lib/auto/threads/threads.dll
new file mode 100755
index 00000000000..ea2c52a7405
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/threads/threads.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/version/.packlist b/Master/tlpkg/tlperl.straw/lib/auto/version/.packlist
new file mode 100755
index 00000000000..ae54b4936d1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/version/.packlist
@@ -0,0 +1,6 @@
+C:\strawberry\perl\lib\auto\version\vxs\vxs.bs
+C:\strawberry\perl\lib\auto\version\vxs\vxs.dll
+C:\strawberry\perl\lib\version.pm
+C:\strawberry\perl\lib\version.pod
+C:\strawberry\perl\lib\version\Internals.pod
+C:\strawberry\perl\lib\version\vxs.pm
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.bs b/Master/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.bs
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.bs
diff --git a/Master/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.dll b/Master/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.dll
new file mode 100755
index 00000000000..d3960230c88
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/auto/version/vxs/vxs.dll
Binary files differ
diff --git a/Master/tlpkg/tlperl.straw/lib/autouse.pm b/Master/tlpkg/tlperl.straw/lib/autouse.pm
new file mode 100755
index 00000000000..cbde3864bf1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/bigfloat.pl b/Master/tlpkg/tlperl.straw/lib/bigfloat.pl
new file mode 100755
index 00000000000..8c28abdcd1d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/bigfloat.pl
@@ -0,0 +1,254 @@
+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.
+#
+# 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.straw/lib/bigint.pm b/Master/tlpkg/tlperl.straw/lib/bigint.pm
new file mode 100755
index 00000000000..e143af61d0a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/blib.pm b/Master/tlpkg/tlperl.straw/lib/blib.pm
new file mode 100755
index 00000000000..f755e29b0de
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/bytes.pm b/Master/tlpkg/tlperl.straw/lib/bytes.pm
new file mode 100755
index 00000000000..b7fabbf359d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/bytes.pm
@@ -0,0 +1,88 @@
+package bytes;
+
+our $VERSION = '1.03';
+
+$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 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.straw/lib/charnames.pm b/Master/tlpkg/tlperl.straw/lib/charnames.pm
new file mode 100755
index 00000000000..0acae61f2ee
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/charnames.pm
@@ -0,0 +1,554 @@
+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)
+
+=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(@_);
+ }
+ }
+
+=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 does not exist, 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.)
+
+=head1 BUGS
+
+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 a 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.straw/lib/common/sense.pm b/Master/tlpkg/tlperl.straw/lib/common/sense.pm
new file mode 100755
index 00000000000..6745b5cdfea
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/common/sense.pm
@@ -0,0 +1,424 @@
+=head1 NAME
+
+common::sense - save a tree AND a kitten, use common::sense!
+
+=head1 SYNOPSIS
+
+ use common::sense;
+
+ # supposed to be the same, with much lower memory usage, as:
+ #
+ # use utf8;
+ # use strict qw(vars subs);
+ # use feature qw(say state switch);
+ # no warnings;
+ # use warnings qw(FATAL closed threads internal debugging pack substr malloc
+ # portable prototype inplace io pipe unpack regexp
+ # deprecated exiting glob digit printf layer
+ # reserved parenthesis taint closure semicolon);
+ # no warnings qw(exec newline unopened);
+
+=head1 DESCRIPTION
+
+This module implements some sane defaults for Perl programs, as defined by
+two typical (or not so typical - use your common sense) specimens of Perl
+coders. In fact, after working out details on which warnings and strict
+modes to enable and make fatal, we found that we (and our code written so
+far, and others) fully agree on every option, even though we never used
+warnings before, so it seems this module indeed reflects a "common" sense
+among some long-time Perl coders.
+
+The basic philosophy behind the choices made in common::sense can be
+summarised as: "enforcing strict policies to catch as many bugs as
+possible, while at the same time, not limiting the expressive power
+available to the programmer".
+
+Two typical examples of this philosophy are uninitialised and malloc
+warnings:
+
+C<undef> is a well-defined feature of perl, and enabling warnings for
+using it rarely catches any bugs, but considerably limits you in what you
+can do, so uninitialised warnings are disabled.
+
+Freeing something twice on the C level is a serious bug, usually causing
+memory corruption. It often leads to side effects much later in the
+program and there are no advantages to not reporting this, so malloc
+warnings are fatal by default.
+
+What follows is a more thorough discussion of what this module does,
+and why it does it, and what the advantages (and disadvantages) of this
+approach are.
+
+=over 4
+
+=item use utf8
+
+While it's not common sense to write your programs in UTF-8, it's quickly
+becoming the most common encoding, and the most convenient encoding
+available (you can do really nice quoting tricks...). Experience has shown
+that our programs were either all pure ascii or utf-8, both of which will
+stay the same.
+
+There are few drawbacks to enabling UTF-8 source code by default (mainly
+some speed hits due to bugs in older versions of perl), so this module
+enables UTF-8 source code encoding by default.
+
+=item use strict qw(subs vars)
+
+Using C<use strict> is definitely common sense, but C<use strict
+'refs'> definitely overshoots its usefulness. After almost two
+decades of Perl hacking, we decided that it does more harm than being
+useful. Specifically, constructs like these:
+
+ @{ $var->[0] }
+
+Must be written like this (or similarly), when C<use strict 'refs'> is in
+scope, and C<$var> can legally be C<undef>:
+
+ @{ $var->[0] || [] }
+
+This is annoying, and doesn't shield against obvious mistakes such as
+using C<"">, so one would even have to write (at least for the time
+being):
+
+ @{ defined $var->[0] ? $var->[0] : [] }
+
+... which nobody with a bit of common sense would consider
+writing: clear code is clearly something else.
+
+Curiously enough, sometimes perl is not so strict, as this works even with
+C<use strict> in scope:
+
+ for (@{ $var->[0] }) { ...
+
+If that isn't hypocrisy! And all that from a mere program!
+
+
+=item use feature qw(say state given)
+
+We found it annoying that we always have to enable extra features. If
+something breaks because it didn't anticipate future changes, so be
+it. 5.10 broke almost all our XS modules and nobody cared either (or at
+least I know of nobody who really complained about gratuitous changes -
+as opposed to bugs).
+
+Few modules that are not actively maintained work with newer versions of
+Perl, regardless of use feature or not, so a new major perl release means
+changes to many modules - new keywords are just the tip of the iceberg.
+
+If your code isn't alive, it's dead, Jim - be an active maintainer.
+
+But nobody forces you to use those extra features in modules meant for
+older versions of perl - common::sense of course works there as well.
+There is also an important other mode where having additional features by
+default is useful: commandline hacks and internal use scripts: See "much
+reduced typing", below.
+
+
+=item no warnings, but a lot of new errors
+
+Ah, the dreaded warnings. Even worse, the horribly dreaded C<-w>
+switch: Even though we don't care if other people use warnings (and
+certainly there are useful ones), a lot of warnings simply go against the
+spirit of Perl.
+
+Most prominently, the warnings related to C<undef>. There is nothing wrong
+with C<undef>: it has well-defined semantics, it is useful, and spitting
+out warnings you never asked for is just evil.
+
+The result was that every one of our modules did C<no warnings> in the
+past, to avoid somebody accidentally using and forcing his bad standards
+on our code. Of course, this switched off all warnings, even the useful
+ones. Not a good situation. Really, the C<-w> switch should only enable
+warnings for the main program only.
+
+Funnily enough, L<perllexwarn> explicitly mentions C<-w> (and not in a
+favourable way, calling it outright "wrong"), but standard utilities, such
+as L<prove>, or MakeMaker when running C<make test>, still enable them
+blindly.
+
+For version 2 of common::sense, we finally sat down a few hours and went
+through I<every single warning message>, identifiying - according to
+common sense - all the useful ones.
+
+This resulted in the rather impressive list in the SYNOPSIS. When we
+weren't sure, we didn't include the warning, so the list might grow in
+the future (we might have made a mistake, too, so the list might shrink
+as well).
+
+Note the presence of C<FATAL> in the list: we do not think that the
+conditions caught by these warnings are worthy of a warning, we I<insist>
+that they are worthy of I<stopping> your program, I<instantly>. They are
+I<bugs>!
+
+Therefore we consider C<common::sense> to be much stricter than C<use
+warnings>, which is good if you are into strict things (we are not,
+actually, but these things tend to be subjective).
+
+After deciding on the list, we ran the module against all of our code that
+uses C<common::sense> (that is almost all of our code), and found only one
+occurence where one of them caused a problem: one of elmex's (unreleased)
+modules contained:
+
+ $fmt =~ s/([^\s\[]*)\[( [^\]]* )\]/\x0$1\x1$2\x0/xgo;
+
+We quickly agreed that indeed the code should be changed, even though it
+happened to do the right thing when the warning was switched off.
+
+
+=item much reduced typing
+
+Especially with version 2.0 of common::sense, the amount of boilerplate
+code you need to add to gte I<this> policy is daunting. Nobody would write
+this out in throwaway scripts, commandline hacks or in quick internal-use
+scripts.
+
+By using common::sense you get a defined set of policies (ours, but maybe
+yours, too, if you accept them), and they are easy to apply to your
+scripts: typing C<use common::sense;> is even shorter than C<use warnings;
+use strict; use feature ...>.
+
+And you can immediately use the features of your installed perl, which
+is more difficult in code you release, but not usually an issue for
+internal-use code (downgrades of your production perl should be rare,
+right?).
+
+
+=item mucho reduced memory usage
+
+Just using all those pragmas mentioned in the SYNOPSIS together wastes
+<blink>I<< B<776> kilobytes >></blink> of precious memory in my perl, for
+I<every single perl process using our code>, which on our machines, is a
+lot. In comparison, this module only uses I<< B<four> >> kilobytes (I even
+had to write it out so it looks like more) of memory on the same platform.
+
+The money/time/effort/electricity invested in these gigabytes (probably
+petabytes globally!) of wasted memory could easily save 42 trees, and a
+kitten!
+
+Unfortunately, until everybods applies more common sense, there will still
+often be modules that pull in the monster pragmas. But one can hope...
+
+=cut
+
+package common::sense;
+
+our $VERSION = '3.0';
+
+# paste this into perl to find bitmask
+
+# no warnings;
+# use warnings qw(FATAL closed threads internal debugging pack substr malloc portable prototype
+# inplace io pipe unpack regexp deprecated exiting glob digit printf
+# layer reserved parenthesis taint closure semicolon);
+# no warnings qw(exec newline unopened);
+# BEGIN { warn join "", map "\\x$_", unpack "(H2)*", ${^WARNING_BITS}; exit 0 };
+
+# overload should be included
+
+sub import {
+ # verified with perl 5.8.0, 5.10.0
+ ${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "\xfc\x3f\x33\x00\x0f\xf3\xcf\xc0\xf3\xfc\x33\x00";
+
+ # use utf8, strict vars subs
+ $^H |= 0x00800600;
+
+ # use feature
+ $^H{feature_switch} =
+ $^H{feature_say} =
+ $^H{feature_state} = 1;
+}
+
+1;
+
+=back
+
+=head1 THERE IS NO 'no common::sense'!!!! !!!! !!
+
+This module doesn't offer an unimport. First of all, it wastes even more
+memory, second, and more importantly, who with even a bit of common sense
+would want no common sense?
+
+=head1 STABILITY AND FUTURE VERSIONS
+
+Future versions might change just about everything in this module. We
+might test our modules and upload new ones working with newer versions of
+this module, and leave you standing in the rain because we didn't tell
+you. In fact, we did so when switching from 1.0 to 2.0, which enabled gobs
+of warnings, and made them FATAL on top.
+
+Maybe we will load some nifty modules that try to emulate C<say> or so
+with perls older than 5.10 (this module, of course, should work with older
+perl versions - supporting 5.8 for example is just common sense at this
+time. Maybe not in the future, but of course you can trust our common
+sense to be consistent with, uhm, our opinion).
+
+=head1 WHAT OTHER PEOPLE HAD TO SAY ABOUT THIS MODULE
+
+apeiron
+
+ "... wow"
+ "I hope common::sense is a joke."
+
+crab
+
+ "i wonder how it would be if joerg schilling wrote perl modules."
+
+Adam Kennedy
+
+ "Very interesting, efficient, and potentially something I'd use all the time."
+ [...]
+ "So no common::sense for me, alas."
+
+H.Merijn Brand
+
+ "Just one more reason to drop JSON::XS from my distribution list"
+
+Pista Palo
+
+ "Something in short supply these days..."
+
+Steffen Schwigon
+
+ "This module is quite for sure *not* just a repetition of all the other
+ 'use strict, use warnings'-approaches, and it's also not the opposite.
+ [...] And for its chosen middle-way it's also not the worst name ever.
+ And everything is documented."
+
+BKB
+
+ "[Deleted - thanks to Steffen Schwigon for pointing out this review was
+ in error.]"
+
+Somni
+
+ "the arrogance of the guy"
+ "I swear he tacked somenoe else's name onto the module
+ just so he could use the royal 'we' in the documentation"
+
+Anonymous Monk
+
+ "You just gotta love this thing, its got META.json!!!"
+
+dngor
+
+ "Heh. '"<elmex at ta-sa.org>"' The quotes are semantic
+ distancing from that e-mail address."
+
+Jerad Pierce
+
+ "Awful name (not a proper pragma), and the SYNOPSIS doesn't tell you
+ anything either. Nor is it clear what features have to do with "common
+ sense" or discipline."
+
+acme
+
+ "THERE IS NO 'no common::sense'!!!! !!!! !!"
+
+apeiron (meta-comment about us commenting^Wquoting his comment)
+
+ "How about quoting this: get a clue, you fucktarded amoeba."
+
+quanth
+
+ "common sense is beautiful, json::xs is fast, Anyevent, EV are fast and
+ furious. I love mlehmannware ;)"
+
+=head1 FREQUQNTLY ASKED QUESTIONS
+
+Or frequently-come-up confusions.
+
+=over 4
+
+=item Is this module meant to be serious?
+
+Yes, we would have put it under the C<Acme::> namespace otherwise.
+
+=item But the manpage is written in a funny/stupid/... way?
+
+This was meant to make it clear that our common sense is a subjective
+thing and other people can use their own notions, taking the steam out
+of anybody who might be offended (as some people are always offended no
+matter what you do).
+
+This was a failure.
+
+But we hope the manpage still is somewhat entertaining even though it
+explains boring rationale.
+
+=item Why do you impose your conventions on my code?
+
+For some reason people keep thinking that C<common::sense> imposes
+process-wide limits, even though the SYNOPSIS makes it clear that it works
+like other similar modules - only on the scope that uses them.
+
+So, no, we don't - nobody is forced to use this module, and using a module
+that relies on common::sense does not impose anything on you.
+
+=item Why do you think only your notion of common::sense is valid?
+
+Well, we don't, and have clearly written this in the documentation to
+every single release. We were just faster than anybody else w.r.t. to
+grabbing the namespace.
+
+=item But everybody knows that you have to use strict and use warnings,
+why do you disable them?
+
+Well, we don't do this either - we selectively disagree with the
+usefulness of some warnings over others. This module is aimed at
+experienced Perl programmers, not people migrating from other languages
+who might be surprised about stuff such as C<undef>. On the other hand,
+this does not exclude the usefulness of this module for total newbies, due
+to its strictness in enforcing policy, while at the same time not limiting
+the expresive power of perl.
+
+This module is considerably I<more> strict than the canonical C<use
+strict; use warnings>, as it makes all its warnings fatal in nature, so
+you can not get away with as many things as with the canonical approach.
+
+This was not implemented in version 1.0 because of the daunting number
+of warning categories and the difficulty in getting exactly the set of
+warnings you wish (i.e. look at the SYNOPSIS in how complicated it is to
+get a specific set of warnings - it is not reasonable to put this into
+every module, the maintainance effort would be enourmous).
+
+=item But many modules C<use strict> or C<use warnings>, so the memory
+savings do not apply?
+
+I am suddenly so sad.
+
+But yes, that's true. Fortunately C<common::sense> still uses only a
+miniscule amount of RAM.
+
+=item But it adds another dependency to your modules!
+
+It's a fact, yeah. But it's trivial to install, most popular modules have
+many more dependencies and we consider dependencies a good thing - it
+leads to better APIs, more thought about interworking of modules and so
+on.
+
+=item Why do you use JSON and not YAML for your META.yml?
+
+This is not true - YAML supports a large subset of JSON, and this subset
+is what META.yml is written in, so it would be correct to say "the
+META.yml is written in a common subset of YAML and JSON".
+
+The META.yml follows the YAML, JSON and META.yml specifications, and is
+correctly parsed by CPAN, so if you have trouble with it, the problem is
+likely on your side.
+
+=item But! But!
+
+Yeah, we know.
+
+=back
+
+=head1 AUTHOR
+
+ Marc Lehmann <schmorp@schmorp.de>
+ http://home.schmorp.de/
+
+ Robin Redeker, "<elmex at ta-sa.org>".
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/complete.pl b/Master/tlpkg/tlperl.straw/lib/complete.pl
new file mode 100755
index 00000000000..925ce86e5da
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/complete.pl
@@ -0,0 +1,120 @@
+;#
+#
+# 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 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.straw/lib/constant.pm b/Master/tlpkg/tlperl.straw/lib/constant.pm
new file mode 100755
index 00000000000..a51ee7f277d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/constant.pm
@@ -0,0 +1,392 @@
+package constant;
+use 5.005;
+use strict;
+use warnings::register;
+
+use vars qw($VERSION %declared);
+$VERSION = '1.19';
+
+#=======================================================================
+
+# 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 {
+ $constants->{+shift} = undef;
+ }
+
+ foreach my $name ( keys %$constants ) {
+ unless (defined $name) {
+ require Carp;
+ Carp::croak("Can't use undef as constant name");
+ }
+
+ # Normal constant name
+ if ($name =~ $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.straw/lib/ctime.pl b/Master/tlpkg/tlperl.straw/lib/ctime.pl
new file mode 100755
index 00000000000..6a3f2959686
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/ctime.pl
@@ -0,0 +1,59 @@
+;# 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.
+#
+# 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.straw/lib/diagnostics.pm b/Master/tlpkg/tlperl.straw/lib/diagnostics.pm
new file mode 100755
index 00000000000..7af5efa1778
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/diagnostics.pm
@@ -0,0 +1,647 @@
+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.17;
+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 $_;
+
+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+)?s)/, $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] eq '%s' ){
+ $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.straw/lib/encoding.pm b/Master/tlpkg/tlperl.straw/lib/encoding.pm
new file mode 100755
index 00000000000..be20a494487
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/fields.pm b/Master/tlpkg/tlperl.straw/lib/fields.pm
new file mode 100755
index 00000000000..c90bc0a16c1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.14';
+
+# constant.pm is slow
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
+
+
+# The %attr hash holds the attributes of the currently assigned fields
+# per class. The hash is indexed by class names and the hash value is
+# an array reference. The first element in the array is the lowest field
+# number not belonging to a base class. The remaining elements' indices
+# are the field numbers. The values are integer bit masks, or undef
+# in the case of base class private fields (which occupy a slot but are
+# otherwise irrelevant to the class).
+
+sub import {
+ my $class = shift;
+ return unless @_;
+ my $package = caller(0);
+ # avoid possible typo warnings
+ %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
+ my $fields = \%{"$package\::FIELDS"};
+ my $fattr = ($attr{$package} ||= [1]);
+ my $next = @$fattr;
+
+ # Quiet pseudo-hash deprecation warning for uses of fields::new.
+ bless \%{"$package\::FIELDS"}, 'pseudohash';
+
+ if ($next > $fattr->[0]
+ and ($fields->{$_[0]} || 0) >= $fattr->[0])
+ {
+ # There are already fields not belonging to base classes.
+ # Looks like a possible module reload...
+ $next = $fattr->[0];
+ }
+ foreach my $f (@_) {
+ my $fno = $fields->{$f};
+
+ # Allow the module to be reloaded so long as field positions
+ # have not changed.
+ if ($fno and $fno != $next) {
+ require Carp;
+ if ($fno < $fattr->[0]) {
+ if ($] < 5.006001) {
+ warn("Hides field '$f' in base class") if $^W;
+ } else {
+ warnings::warnif("Hides field '$f' in base class") ;
+ }
+ } else {
+ Carp::croak("Field name '$f' already in use");
+ }
+ }
+ $fields->{$f} = $next;
+ $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
+ $next += 1;
+ }
+ if (@$fattr > $next) {
+ # Well, we gave them the benefit of the doubt by guessing the
+ # module was reloaded, but they appear to be declaring fields
+ # in more than one place. We can't be sure (without some extra
+ # bookkeeping) that the rest of the fields will be declared or
+ # have the same positions, so punt.
+ require Carp;
+ Carp::croak ("Reloaded module must declare all fields at once");
+ }
+}
+
+sub inherit {
+ require base;
+ goto &base::inherit_fields;
+}
+
+sub _dump # sometimes useful for debugging
+{
+ for my $pkg (sort keys %attr) {
+ print "\n$pkg";
+ if (@{"$pkg\::ISA"}) {
+ print " (", join(", ", @{"$pkg\::ISA"}), ")";
+ }
+ print "\n";
+ my $fields = \%{"$pkg\::FIELDS"};
+ for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
+ my $no = $fields->{$f};
+ print " $no: $f";
+ my $fattr = $attr{$pkg}[$no];
+ if (defined $fattr) {
+ my @a;
+ push(@a, "public") if $fattr & PUBLIC;
+ push(@a, "private") if $fattr & PRIVATE;
+ push(@a, "inherited") if $fattr & INHERITED;
+ print "\t(", join(", ", @a), ")";
+ }
+ print "\n";
+ }
+ }
+}
+
+if ($] < 5.009) {
+ *new = sub {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ return bless [\%{$class . "::FIELDS"}], $class;
+ }
+} else {
+ *new = sub {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ require Hash::Util;
+ my $self = bless {}, $class;
+
+ # The lock_keys() prototype won't work since we require Hash::Util :(
+ &Hash::Util::lock_keys(\%$self, _accessible_keys($class));
+ return $self;
+ }
+}
+
+sub _accessible_keys {
+ my ($class) = @_;
+ return (
+ keys %{$class.'::FIELDS'},
+ map(_accessible_keys($_), @{$class.'::ISA'}),
+ );
+}
+
+sub phash {
+ die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
+ my $h;
+ my $v;
+ if (@_) {
+ if (ref $_[0] eq 'ARRAY') {
+ my $a = shift;
+ @$h{@$a} = 1 .. @$a;
+ if (@_) {
+ $v = shift;
+ unless (! @_ and ref $v eq 'ARRAY') {
+ require Carp;
+ Carp::croak ("Expected at most two array refs\n");
+ }
+ }
+ }
+ else {
+ if (@_ % 2) {
+ require Carp;
+ Carp::croak ("Odd number of elements initializing pseudo-hash\n");
+ }
+ my $i = 0;
+ @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
+ $i = 0;
+ $v = [grep $i++ % 2, @_];
+ }
+ }
+ else {
+ $h = {};
+ $v = [];
+ }
+ [ $h, @$v ];
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+fields - compile-time class fields
+
+=head1 SYNOPSIS
+
+ {
+ package Foo;
+ use fields qw(foo bar _Foo_private);
+ sub new {
+ my Foo $self = shift;
+ unless (ref $self) {
+ $self = fields::new($self);
+ $self->{_Foo_private} = "this is Foo's secret";
+ }
+ $self->{foo} = 10;
+ $self->{bar} = 20;
+ return $self;
+ }
+ }
+
+ my $var = Foo->new;
+ $var->{foo} = 42;
+
+ # this will generate an error
+ $var->{zap} = 42;
+
+ # subclassing
+ {
+ package Bar;
+ use base 'Foo';
+ use fields qw(baz _Bar_private); # not shared with Foo
+ sub new {
+ my $class = shift;
+ my $self = fields::new($class);
+ $self->SUPER::new(); # init base fields
+ $self->{baz} = 10; # init own fields
+ $self->{_Bar_private} = "this is Bar's secret";
+ return $self;
+ }
+ }
+
+=head1 DESCRIPTION
+
+The C<fields> pragma enables compile-time verified class fields.
+
+NOTE: The current implementation keeps the declared fields in the %FIELDS
+hash of the calling package, but this may change in future versions.
+Do B<not> update the %FIELDS hash directly, because it must be created
+at compile-time for it to be fully useful, as is done by this pragma.
+
+B<Only valid for perl before 5.9.0:>
+
+If a typed lexical variable holding a reference is used to access a
+hash element and a package with the same name as the type has
+declared class fields using this pragma, then the operation is
+turned into an array access at compile time.
+
+
+The related C<base> pragma will combine fields from base classes and any
+fields declared using the C<fields> pragma. This enables field
+inheritance to work properly.
+
+Field names that start with an underscore character are made private to
+the class and are not visible to subclasses. Inherited fields can be
+overridden but will generate a warning if used together with the C<-w>
+switch.
+
+B<Only valid for perls before 5.9.0:>
+
+The effect of all this is that you can have objects with named
+fields which are as compact and as fast arrays to access. This only
+works as long as the objects are accessed through properly typed
+variables. If the objects are not typed, access is only checked at
+run time.
+
+
+The following functions are supported:
+
+=over 4
+
+=item new
+
+B< perl before 5.9.0: > fields::new() creates and blesses a
+pseudo-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+B< perl 5.9.0 and higher: > fields::new() creates and blesses a
+restricted-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+This function is usable with or without pseudo-hashes. It is the
+recommended way to construct a fields-based object.
+
+This makes it possible to write a constructor like this:
+
+ package Critter::Sounds;
+ use fields qw(cat dog bird);
+
+ sub new {
+ my $self = shift;
+ $self = fields::new($self) unless ref $self;
+ $self->{cat} = 'meow'; # scalar element
+ @$self{'dog','bird'} = ('bark','tweet'); # slice
+ return $self;
+ }
+
+=item phash
+
+B< before perl 5.9.0: >
+
+fields::phash() can be used to create and initialize a plain (unblessed)
+pseudo-hash. This function should always be used instead of creating
+pseudo-hashes directly.
+
+If the first argument is a reference to an array, the pseudo-hash will
+be created with keys from that array. If a second argument is supplied,
+it must also be a reference to an array whose elements will be used as
+the values. If the second array contains less elements than the first,
+the trailing elements of the pseudo-hash will not be initialized.
+This makes it particularly useful for creating a pseudo-hash from
+subroutine arguments:
+
+ sub dogtag {
+ my $tag = fields::phash([qw(name rank ser_num)], [@_]);
+ }
+
+fields::phash() also accepts a list of key-value pairs that will
+be used to construct the pseudo hash. Examples:
+
+ my $tag = fields::phash(name => "Joe",
+ rank => "captain",
+ ser_num => 42);
+
+ my $pseudohash = fields::phash(%args);
+
+B< perl 5.9.0 and higher: >
+
+Pseudo-hashes have been removed from Perl as of 5.10. Consider using
+restricted hashes or fields::new() instead. Using fields::phash()
+will cause an error.
+
+=back
+
+=head1 SEE ALSO
+
+L<base>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/filetest.pm b/Master/tlpkg/tlperl.straw/lib/filetest.pm
new file mode 100755
index 00000000000..b08f1dc9107
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/finddepth.pl b/Master/tlpkg/tlperl.straw/lib/finddepth.pl
new file mode 100755
index 00000000000..bfa44bb1bc9
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/finddepth.pl
@@ -0,0 +1,46 @@
+# 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.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like 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.straw/lib/fix_4_os2.pl b/Master/tlpkg/tlperl.straw/lib/fix_4_os2.pl
new file mode 100755
index 00000000000..4932fdf17c3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/fix_4_os2.pl
@@ -0,0 +1,61 @@
+sub OS2_massage { # Need to put before BEGIN
+ if (@ARGV) {
+ die <<EOD;
+
+Please start me as one of
+ perl $0 x
+ perl $0 open32
+ perl $0 pm
+EOD
+ }
+ if (not defined $win_arch) {
+ $win_arch = 'pm';
+ print STDERR <<EOP;
+
+No Window architecture specified, building for PM.
+
+Please start me as one of
+ perl $0 x
+ perl $0 open32
+ perl $0 pm
+if you want to specify architecture explicitely.
+
+EOP
+ }
+ if ($win_arch ne 'x' and not -r 'pTk/mTk/open32/tkWinOS2.c' ) {
+ print <<EOD;
+
+Cannot find pTk/mTk/open32/tkWinOS2.c, trying to find Tk-OS2src nearby...
+
+EOD
+ my @zips = <../Tk-OS2src-*/perltk_os2_common.zip>;
+
+ die <<EOD unless @zips;
+
+Cannot find ../Tk-OS2src-*/perltk_os2_common.zip, did you read README.os2?
+
+EOD
+ print 'Extracting OS/2-related files...\nunzip', $zips[-1], "\n";
+ system 'unzip', $zips[-1] and die "Unzip: $!";
+ print "Extracted...\n";
+ }
+ if ($win_arch eq 'pm' and not -r 'pTk/mTk/os2/tkOS2Int.h') {
+ print <<EOD unless @zips;
+
+Cannot find pTk/mTk/os2/tkOS2Int.h, trying to find Tk-OS2src nearby...
+
+EOD
+ my @zips = <../Tk-OS2src-*/perltk_os2_pm.zip>;
+
+ die <<EOD unless @zips;
+
+Cannot find ../Tk-OS2src-*/perltk_os2_pm.zip, did you read README.os2?
+
+EOD
+ print 'Extracting OS/2-related files...\nunzip', $zips[-1], "\n";
+ system 'unzip', $zips[-1] and die "Unzip: $!";
+ }
+ $test_perl = 'perl__.exe' if $win_arch ne 'x';
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/getopt.pl b/Master/tlpkg/tlperl.straw/lib/getopt.pl
new file mode 100755
index 00000000000..77d8d899a4a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/getopt.pl
@@ -0,0 +1,49 @@
+;# $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.
+#
+# 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.straw/lib/if.pm b/Master/tlpkg/tlperl.straw/lib/if.pm
new file mode 100755
index 00000000000..5f6bcc8ae16
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/inc/latest.pm b/Master/tlpkg/tlperl.straw/lib/inc/latest.pm
new file mode 100755
index 00000000000..fc9e2e94bf8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/inc/latest.pm
@@ -0,0 +1,246 @@
+package inc::latest;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.3603';
+$VERSION = eval $VERSION;
+
+use Carp;
+use File::Basename ();
+use File::Spec ();
+use File::Path ();
+use IO::File ();
+use File::Copy ();
+
+# track and return modules loaded by inc::latest
+my @loaded_modules;
+sub loaded_modules {@loaded_modules}
+
+# must ultimately "goto" the import routine of the module to be loaded
+# so that the calling package is correct when $mod->import() runs.
+sub import {
+ my ($package, $mod, @args) = @_;
+ return unless(defined $mod);
+
+ my $private_path = 'inc/latest/private.pm';
+ if(-e $private_path) {
+ # user mode - delegate work to bundled private module
+ require $private_path;
+ splice( @_, 0, 1, 'inc::latest::private');
+ goto \&inc::latest::private::import;
+ }
+
+ # author mode - just record and load the modules
+ push(@loaded_modules, $mod);
+ require inc::latest::private;
+ goto \&inc::latest::private::_load_module;
+}
+
+sub write {
+ my $package = shift;
+ my ($where, @preload) = @_;
+
+ warn "should really be writing in inc/" unless $where =~ /inc$/;
+
+ # write inc/latest.pm
+ File::Path::mkpath( $where );
+ my $fh = IO::File->new( File::Spec->catfile($where,'latest.pm'), "w" );
+ print {$fh} "# This stub created by inc::latest $VERSION\n";
+ print {$fh} <<'HERE';
+package inc::latest;
+use strict;
+use vars '@ISA';
+require inc::latest::private;
+@ISA = qw/inc::latest::private/;
+HERE
+ if (@preload) {
+ print {$fh} "\npackage inc::latest::preload;\n";
+ for my $mod (@preload) {
+ print {$fh} "inc::latest->import('$mod');\n";
+ }
+ }
+ print {$fh} "\n1;\n";
+ close $fh;
+
+ # write inc/latest/private;
+ require inc::latest::private;
+ File::Path::mkpath( File::Spec->catdir( $where, 'latest' ) );
+ my $from = $INC{'inc/latest/private.pm'};
+ my $to = File::Spec->catfile($where,'latest','private.pm');
+ File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
+
+ return 1;
+}
+
+sub bundle_module {
+ my ($package, $module, $where) = @_;
+
+ # create inc/inc_$foo
+ (my $dist = $module) =~ s{::}{-}g;
+ my $inc_lib = File::Spec->catdir($where,"inc_$dist");
+ File::Path::mkpath $inc_lib;
+
+ # get list of files to copy
+ require ExtUtils::Installed;
+ # workaround buggy EU::Installed check of @INC
+ my $inst = ExtUtils::Installed->new(extra_libs => [@INC]);
+ my $packlist = $inst->packlist( $module ) or die "Couldn't find packlist";
+ my @files = grep { /\.pm$/ } keys %$packlist;
+
+
+ # figure out prefix
+ my $mod_path = quotemeta $package->_mod2path( $module );
+ my ($prefix) = grep { /$mod_path$/ } @files;
+ $prefix =~ s{$mod_path$}{};
+
+ # copy files
+ for my $from ( @files ) {
+ next unless $from =~ /\.pm$/;
+ (my $mod_path = $from) =~ s{^\Q$prefix\E}{};
+ my $to = File::Spec->catfile( $inc_lib, $mod_path );
+ File::Path::mkpath(File::Basename::dirname($to));
+ File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
+ }
+ return 1;
+}
+
+# Translate a module name into a directory/file.pm to search for in @INC
+sub _mod2path {
+ my ($self, $mod) = @_;
+ my @parts = split /::/, $mod;
+ $parts[-1] .= '.pm';
+ return $parts[0] if @parts == 1;
+ return File::Spec->catfile(@parts);
+}
+
+1;
+
+
+=head1 NAME
+
+inc::latest - use modules bundled in inc/ if they are newer than installed ones
+
+=head1 SYNOPSIS
+
+ # in Build.PL
+ use inc::latest 'Module::Build';
+
+=head1 DESCRIPTION
+
+The C<inc::latest> module helps bootstrap configure-time dependencies for CPAN
+distributions. These dependencies get bundled into the C<inc> directory within
+a distribution and are used by Build.PL (or Makefile.PL).
+
+Arguments to C<inc::latest> are module names that are checked against both the
+current C<@INC> array and against specially-named directories in C<inc>. If
+the bundled verison is newer than the installed one (or the module isn't
+installed, then, the bundled directory is added to the start of <@INC> and the
+module is loaded from there.
+
+There are actually two variations of C<inc::latest> -- one for authors and one
+for the C<inc> directory. For distribution authors, the C<inc::latest>
+installed in the system will record modules loaded via C<inc::latest> and can
+be used to create the bundled files in C<inc>, including writing the second
+variation as C<inc/latest.pm>.
+
+This second C<inc::latest> is the one that is loaded in a distribution being
+installed (e.g. from Build.PL). This bundled C<inc::latest> is the one
+that determines which module to load.
+
+=head2 Special notes on bundling
+
+The C<inc::latest> module creates bundled directories based on the packlist
+file of an installed distribution. Even though C<inc::latest> takes module
+name arguments, it is better to think of it as bundling and making available
+entire I<distributions>. When a module is loaded through C<inc::latest>,
+it looks in all bundled distributions in C<inc/> for a newer module than
+can be found in the existing C<@INC> array.
+
+Thus, the module-name provided should usually be the "top-level" module name of
+a distribution, though this is not strictly required. For example,
+L<Module::Build> has a number of heuristics to map module names to packlists,
+allowing users to do things like this:
+
+ use inc::latest 'Devel::AssertOS::Unix';
+
+even though Devel::AssertOS::Unix is contained within the Devel-CheckOS
+distribution.
+
+At the current time, packlists are required. Thus, bundling dual-core modules
+may require a 'forced install' over versions in the latest version of perl
+in order to create the necessary packlist for bundling.
+
+=head1 USAGE
+
+When calling C<use>, the bundled C<inc::latest> takes a single module name and
+optional arguments to pass to that module's own import method.
+
+ use 'inc::latest' 'Foo::Bar' qw/foo bar baz/;
+
+=head2 Author-mode
+
+You are in author-mode inc::latest if any of the Author-mode methods are
+available. For example:
+
+ if ( inc::latest->can('write') ) {
+ inc::latest->write('inc');
+ }
+
+=over 4
+
+=item loaded_modules()
+
+ my @list = inc::latest->loaded_modules;
+
+This takes no arguments and always returns a list of module names requested for
+loading via "use inc::latest 'MODULE'", regardless of wether the load was
+successful or not.
+
+=item write()
+
+ inc::latest->write( 'inc' );
+
+This writes the bundled version of inc::latest to the directory name given as an
+argument. It almost all cases, it should be 'C<inc>'.
+
+=item bundle_module()
+
+ for my $mod ( inc::latest->loaded_modules ) {
+ inc::latest->bundle_module($mod, $dir);
+ }
+
+If $mod corresponds to a packlist, then this function creates a specially-named
+directory in $dir and copies all .pm files from the modlist to the new
+directory (which almost always should just be 'inc'). For example, if Foo::Bar
+is the name of the module, and $dir is 'inc', then the directory would be
+'inc/inc_Foo-Bar' and contain files like this:
+
+ inc/inc_Foo-Bar/Foo/Bar.pm
+
+Currently, $mod B<must> have a packlist. If this is not the case (e.g. for a
+dual-core module), then the bundling will fail. You may be able to create a
+packlist by forced installing the module on top of the version that came with
+core Perl.
+
+=back
+
+=head2 As bundled in inc/
+
+All methods are private. Only the C<import> method is public.
+
+=head1 AUTHOR
+
+Eric Wilhelm <ewilhelm@cpan.org>, David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2009 by Eric Wilhelm and David Golden
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Module::Build>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/inc/latest/private.pm b/Master/tlpkg/tlperl.straw/lib/inc/latest/private.pm
new file mode 100755
index 00000000000..572ae8a82cb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/inc/latest/private.pm
@@ -0,0 +1,101 @@
+package inc::latest::private;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.3603';
+$VERSION = eval $VERSION;
+
+use File::Spec;
+use IO::File;
+
+# must ultimately "goto" the import routine of the module to be loaded
+# so that the calling package is correct when $mod->import() runs.
+sub import {
+ my ($package, $mod, @args) = @_;
+ my $file = $package->_mod2path($mod);
+
+ if ($INC{$file}) {
+ # Already loaded, but let _load_module handle import args
+ goto \&_load_module;
+ }
+
+ # A bundled copy must be present
+ my ($bundled, $bundled_dir) = $package->_search_bundled($file)
+ or die "No bundled copy of $mod found";
+
+ my $from_inc = $package->_search_INC($file);
+ unless ($from_inc) {
+ # Only bundled is available
+ unshift(@INC, $bundled_dir);
+ goto \&_load_module;
+ }
+
+ if (_version($from_inc) >= _version($bundled)) {
+ # Ignore the bundled copy
+ goto \&_load_module;
+ }
+
+ # Load the bundled copy
+ unshift(@INC, $bundled_dir);
+ goto \&_load_module;
+}
+
+sub _version {
+ require ExtUtils::MakeMaker;
+ return ExtUtils::MM->parse_version(shift);
+}
+
+# use "goto" for import to preserve caller
+sub _load_module {
+ my $package = shift; # remaining @_ is ready for goto
+ my ($mod, @args) = @_;
+ eval "require $mod; 1" or die $@;
+ if ( my $import = $mod->can('import') ) {
+ goto $import;
+ }
+ return 1;
+}
+
+sub _search_bundled {
+ my ($self, $file) = @_;
+
+ my $mypath = 'inc';
+
+ local *DH; # Maintain 5.005 compatibility
+ opendir DH, $mypath or die "Can't open directory $mypath: $!";
+
+ while (defined(my $e = readdir DH)) {
+ next unless $e =~ /^inc_/;
+ my $try = File::Spec->catfile($mypath, $e, $file);
+
+ return($try, File::Spec->catdir($mypath, $e)) if -e $try;
+ }
+ return;
+}
+
+# Look for the given path in @INC.
+sub _search_INC {
+ # TODO: doesn't handle coderefs or arrayrefs or objects in @INC, but
+ # it probably should
+ my ($self, $file) = @_;
+
+ foreach my $dir (@INC) {
+ next if ref $dir;
+ my $try = File::Spec->catfile($dir, $file);
+ return $try if -e $try;
+ }
+
+ return;
+}
+
+# Translate a module name into a directory/file.pm to search for in @INC
+sub _mod2path {
+ my ($self, $mod) = @_;
+ my @parts = split /::/, $mod;
+ $parts[-1] .= '.pm';
+ return $parts[0] if @parts == 1;
+ return File::Spec->catfile(@parts);
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/local/lib.pm b/Master/tlpkg/tlperl.straw/lib/local/lib.pm
new file mode 100755
index 00000000000..1a961545cf5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/local/lib.pm
@@ -0,0 +1,832 @@
+use strict;
+use warnings;
+
+package local::lib;
+
+use 5.008001; # probably works with earlier versions but I'm not supporting them
+ # (patches would, of course, be welcome)
+
+use File::Spec ();
+use File::Path ();
+use Carp ();
+use Config;
+
+our $VERSION = '1.004009'; # 1.4.9
+my @KNOWN_FLAGS = (qw/--self-contained/);
+
+sub import {
+ my ($class, @args) = @_;
+ @args <= 1 + @KNOWN_FLAGS or die <<'DEATH';
+Please see `perldoc local::lib` for directions on using this module.
+DEATH
+
+ # Remember what PERL5LIB was when we started
+ my $perl5lib = $ENV{PERL5LIB} || '';
+
+ my %arg_store;
+ for my $arg (@args) {
+ # check for lethal dash first to stop processing before causing problems
+ if ($arg =~ /−/) {
+ die <<'DEATH';
+WHOA THERE! It looks like you've got some fancy dashes in your commandline!
+These are *not* the traditional -- dashes that software recognizes. You
+probably got these by copy-pasting from the perldoc for this module as
+rendered by a UTF8-capable formatter. This most typically happens on an OS X
+terminal, but can happen elsewhere too. Please try again after replacing the
+dashes with normal minus signs.
+DEATH
+ }
+ elsif(grep { $arg eq $_ } @KNOWN_FLAGS) {
+ (my $flag = $arg) =~ s/--//;
+ $arg_store{$flag} = 1;
+ }
+ elsif($arg =~ /^--/) {
+ die "Unknown import argument: $arg";
+ }
+ else {
+ # assume that what's left is a path
+ $arg_store{path} = $arg;
+ }
+ }
+
+ if($arg_store{'self-contained'}) {
+ # The only directories that remain are those that we just defined and those
+ # where core modules are stored. We put PERL5LIB first, so it'll be favored
+ # over privlibexp and archlibexp
+
+ @INC = _uniq(
+ $class->install_base_arch_path($arg_store{path}),
+ $class->install_base_perl_path($arg_store{path}),
+ split( $Config{path_sep}, $perl5lib ),
+ $Config::Config{archlibexp},
+ $Config::Config{privlibexp},
+ );
+
+ # We explicitly set PERL5LIB here to the above de-duped list to prevent
+ # @INC from growing with each invocation
+ $ENV{PERL5LIB} = join( $Config{path_sep}, @INC );
+ }
+
+ $arg_store{path} = $class->resolve_path($arg_store{path});
+ $class->setup_local_lib_for($arg_store{path});
+
+ for (@INC) { # Untaint @INC
+ next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc.
+ m/(.*)/ and $_ = $1;
+ }
+}
+
+sub pipeline;
+
+sub pipeline {
+ my @methods = @_;
+ my $last = pop(@methods);
+ if (@methods) {
+ \sub {
+ my ($obj, @args) = @_;
+ $obj->${pipeline @methods}(
+ $obj->$last(@args)
+ );
+ };
+ } else {
+ \sub {
+ shift->$last(@_);
+ };
+ }
+}
+
+=begin testing
+
+#:: test pipeline
+
+package local::lib;
+
+{ package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } }
+my $foo = bless({}, 'Foo');
+Test::More::ok($foo->${pipeline qw(foo bar baz)}(10) == -15);
+
+=end testing
+
+=cut
+
+sub _uniq {
+ my %seen;
+ grep { ! $seen{$_}++ } @_;
+}
+
+sub resolve_path {
+ my ($class, $path) = @_;
+ $class->${pipeline qw(
+ resolve_relative_path
+ resolve_home_path
+ resolve_empty_path
+ )}($path);
+}
+
+sub resolve_empty_path {
+ my ($class, $path) = @_;
+ if (defined $path) {
+ $path;
+ } else {
+ '~/perl5';
+ }
+}
+
+=begin testing
+
+#:: test classmethod setup
+
+my $c = 'local::lib';
+
+=end testing
+
+=begin testing
+
+#:: test classmethod
+
+is($c->resolve_empty_path, '~/perl5');
+is($c->resolve_empty_path('foo'), 'foo');
+
+=end testing
+
+=cut
+
+sub resolve_home_path {
+ my ($class, $path) = @_;
+ return $path unless ($path =~ /^~/);
+ my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us'
+ my $tried_file_homedir;
+ my $homedir = do {
+ if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) {
+ $tried_file_homedir = 1;
+ if (defined $user) {
+ File::HomeDir->users_home($user);
+ } else {
+ File::HomeDir->my_home;
+ }
+ } else {
+ if (defined $user) {
+ (getpwnam $user)[7];
+ } else {
+ if (defined $ENV{HOME}) {
+ $ENV{HOME};
+ } else {
+ (getpwuid $<)[7];
+ }
+ }
+ }
+ };
+ unless (defined $homedir) {
+ Carp::croak(
+ "Couldn't resolve homedir for "
+ .(defined $user ? $user : 'current user')
+ .($tried_file_homedir ? '' : ' - consider installing File::HomeDir')
+ );
+ }
+ $path =~ s/^~[^\/]*/$homedir/;
+ $path;
+}
+
+sub resolve_relative_path {
+ my ($class, $path) = @_;
+ $path = File::Spec->rel2abs($path);
+}
+
+=begin testing
+
+#:: test classmethod
+
+local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; };
+is($c->resolve_relative_path('bar'),'FOObar');
+
+=end testing
+
+=cut
+
+sub setup_local_lib_for {
+ my ($class, $path) = @_;
+ $path = $class->ensure_dir_structure_for($path);
+ if ($0 eq '-') {
+ $class->print_environment_vars_for($path);
+ exit 0;
+ } else {
+ $class->setup_env_hash_for($path);
+ @INC = _uniq(split($Config{path_sep}, $ENV{PERL5LIB}), @INC);
+ }
+}
+
+sub modulebuildrc_path {
+ my ($class, $path) = @_;
+ File::Spec->catfile($path, '.modulebuildrc');
+}
+
+sub install_base_bin_path {
+ my ($class, $path) = @_;
+ File::Spec->catdir($path, 'bin');
+}
+
+sub install_base_perl_path {
+ my ($class, $path) = @_;
+ File::Spec->catdir($path, 'lib', 'perl5');
+}
+
+sub install_base_arch_path {
+ my ($class, $path) = @_;
+ File::Spec->catdir($class->install_base_perl_path($path), $Config{archname});
+}
+
+sub ensure_dir_structure_for {
+ my ($class, $path) = @_;
+ unless (-d $path) {
+ warn "Attempting to create directory ${path}\n";
+ }
+ File::Path::mkpath($path);
+ # Need to have the path exist to make a short name for it, so
+ # converting to a short name here.
+ $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32';
+ my $modulebuildrc_path = $class->modulebuildrc_path($path);
+ if (-e $modulebuildrc_path) {
+ unless (-f _) {
+ Carp::croak("${modulebuildrc_path} exists but is not a plain file");
+ }
+ } else {
+ warn "Attempting to create file ${modulebuildrc_path}\n";
+ open MODULEBUILDRC, '>', $modulebuildrc_path
+ || Carp::croak("Couldn't open ${modulebuildrc_path} for writing: $!");
+ print MODULEBUILDRC qq{install --install_base ${path}\n}
+ || Carp::croak("Couldn't write line to ${modulebuildrc_path}: $!");
+ close MODULEBUILDRC
+ || Carp::croak("Couldn't close file ${modulebuildrc_path}: $@");
+ }
+
+ return $path;
+}
+
+sub INTERPOLATE_ENV () { 1 }
+sub LITERAL_ENV () { 0 }
+
+sub print_environment_vars_for {
+ my ($class, $path) = @_;
+ my @envs = $class->build_environment_vars_for($path, LITERAL_ENV);
+ my $out = '';
+
+ # rather basic csh detection, goes on the assumption that something won't
+ # call itself csh unless it really is. also, default to bourne in the
+ # pathological situation where a user doesn't have $ENV{SHELL} defined.
+ # note also that shells with funny names, like zoid, are assumed to be
+ # bourne.
+ my $shellbin = 'sh';
+ if(defined $ENV{'SHELL'}) {
+ my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'});
+ $shellbin = $shell_bin_path_parts[-1];
+ }
+ my $shelltype = do {
+ local $_ = $shellbin;
+ if(/csh/) {
+ 'csh'
+ } else {
+ 'bourne'
+ }
+ };
+
+ # Both Win32 and Cygwin have $ENV{COMSPEC} set.
+ if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') {
+ my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'});
+ $shellbin = $shell_bin_path_parts[-1];
+ $shelltype = do {
+ local $_ = $shellbin;
+ if(/command\.com/) {
+ 'win32'
+ } elsif(/cmd\.exe/) {
+ 'win32'
+ } elsif(/4nt\.exe/) {
+ 'win32'
+ } else {
+ $shelltype
+ }
+ };
+ }
+
+ while (@envs) {
+ my ($name, $value) = (shift(@envs), shift(@envs));
+ $value =~ s/(\\")/\\$1/g;
+ $out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value);
+ }
+ print $out;
+}
+
+# simple routines that take two arguments: an %ENV key and a value. return
+# strings that are suitable for passing directly to the relevant shell to set
+# said key to said value.
+sub build_bourne_env_declaration {
+ my $class = shift;
+ my($name, $value) = @_;
+ return qq{export ${name}="${value}"\n};
+}
+
+sub build_csh_env_declaration {
+ my $class = shift;
+ my($name, $value) = @_;
+ return qq{setenv ${name} "${value}"\n};
+}
+
+sub build_win32_env_declaration {
+ my $class = shift;
+ my($name, $value) = @_;
+ return qq{set ${name}=${value}\n};
+}
+
+sub setup_env_hash_for {
+ my ($class, $path) = @_;
+ my %envs = $class->build_environment_vars_for($path, INTERPOLATE_ENV);
+ @ENV{keys %envs} = values %envs;
+}
+
+sub build_environment_vars_for {
+ my ($class, $path, $interpolate) = @_;
+ return (
+ MODULEBUILDRC => $class->modulebuildrc_path($path),
+ PERL_MM_OPT => "INSTALL_BASE=${path}",
+ PERL5LIB => join($Config{path_sep},
+ $class->install_base_perl_path($path),
+ $class->install_base_arch_path($path),
+ ($ENV{PERL5LIB} ?
+ ($interpolate == INTERPOLATE_ENV
+ ? ($ENV{PERL5LIB})
+ : (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' ))
+ : ())
+ ),
+ PATH => join($Config{path_sep},
+ $class->install_base_bin_path($path),
+ ($interpolate == INTERPOLATE_ENV
+ ? $ENV{PATH}
+ : (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' ))
+ ),
+ )
+}
+
+=begin testing
+
+#:: test classmethod
+
+File::Path::rmtree('t/var/splat');
+
+$c->ensure_dir_structure_for('t/var/splat');
+
+ok(-d 't/var/splat');
+
+ok(-f 't/var/splat/.modulebuildrc');
+
+=end testing
+
+=head1 NAME
+
+local::lib - create and use a local lib/ for perl modules with PERL5LIB
+
+=head1 SYNOPSIS
+
+In code -
+
+ use local::lib; # sets up a local lib at ~/perl5
+
+ use local::lib '~/foo'; # same, but ~/foo
+
+ # Or...
+ use FindBin;
+ use local::lib "$FindBin::Bin/../support"; # app-local support library
+
+From the shell -
+
+ # Install LWP and it's missing dependencies to the 'my_lwp' directory
+ perl -MCPAN -Mlocal::lib=my_lwp -e 'CPAN::install(LWP)'
+
+ # Install LWP and *all non-core* dependencies to the 'my_lwp' directory
+ perl -MCPAN -Mlocal::lib=--self-contained,my_lwp -e 'CPAN::install(LWP)'
+
+ # Just print out useful shell commands
+ $ perl -Mlocal::lib
+ export MODULEBUILDRC=/home/username/perl/.modulebuildrc
+ export PERL_MM_OPT='INSTALL_BASE=/home/username/perl'
+ export PERL5LIB='/home/username/perl/lib/perl5:/home/username/perl/lib/perl5/i386-linux'
+ export PATH="/home/username/perl/bin:$PATH"
+
+=head2 The bootstrapping technique
+
+A typical way to install local::lib is using what is known as the
+"bootstrapping" technique. You would do this if your system administrator
+hasn't already installed local::lib. In this case, you'll need to install
+local::lib in your home directory.
+
+1. Download and unpack the local::lib tarball from CPAN (search for "Download"
+on the CPAN page about local::lib). Do this as an ordinary user, not as root
+or administrator. Unpack the file in your home directory or in any other
+convenient location.
+
+2. Run this:
+
+ perl Makefile.PL --bootstrap
+
+If the system asks you whether it should automatically configure as much
+as possible, you would typically answer yes.
+
+3. Run this:
+
+ make test && make install
+
+4. Arrange for Perl to use your own packages instead of the system
+packages. If you are using bash, you can do this as follows:
+
+ echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc
+
+If you are using C shell, you can do this as follows:
+
+ /bin/csh
+ echo $SHELL
+ /bin/csh
+ perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc
+
+You can also pass --bootstrap=~/foo to get a different location -
+
+ perl Makefile.PL --bootstrap=~/foo
+ make test && make install
+
+ echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc
+
+After writing your shell configuration file, be sure to re-read it to get the
+changed settings into your current shell's environment.
+
+ . ~/.bashrc
+
+If you are using C shell, you can do this as follows:
+
+ /bin/csh
+ echo $SHELL
+ /bin/csh
+ perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc
+
+ source ~/.cshrc
+
+You can also pass --bootstrap=~/foo to get a different location -
+
+ perl Makefile.PL --bootstrap=~/foo
+ make test && make install
+
+ echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >> ~/.bashrc
+
+ . ~/.bashrc
+
+If you're on a slower machine, or are operating under draconian disk space
+limitations, you can disable the automatic generation of manpages from POD when
+installing modules by using the C<--no-manpages> argument when bootstrapping:
+
+ perl Makefile.PL --bootstrap --no-manpages
+
+If you want to install multiple Perl module environments, say for application evelopment,
+install local::lib globally and then:
+
+ cd ~/mydir1
+ perl -Mlocal::lib=./
+ eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone
+ printenv ### You will see that ~/mydir1 is in the PERL5LIB
+ perl -MCPAN -e install ... ### whatever modules you want
+ cd ../mydir2
+ ... REPEAT ...
+
+For multiple environments for multiple apps you may need to include a modified
+version of the C<< use FindBin >> instructions in the "In code" sample above.
+If you did something like the above, you have a set of Perl modules at C<<
+~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>,
+you need to tell it where to find the modules you installed for it at C<<
+~/mydir1/lib >>.
+
+In C<< ~/mydir1/scripts/myscript.pl >>:
+
+ use strict;
+ use warnings;
+ use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib
+ use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib
+
+Put this before any BEGIN { ... } blocks that require the modules you installed.
+
+=head2 Differences when using this module under Win32
+
+ C:\>perl -Mlocal::lib
+ set MODULEBUILDRC=C:\DOCUME~1\ADMINI~1\perl5\.modulebuildrc
+ set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5
+ set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread
+ set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH%
+
+ ### To set the environment for this shell alone
+ C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat
+ ### instead of $(perl -Mlocal::lib=./)
+
+If you want the environment entries to persist, you'll need to add then to the
+Control Panel's System applet yourself at the moment.
+
+The "~" is translated to the user's profile directory (the directory named for
+the user under "Documents and Settings" (Windows XP or earlier) or "Users"
+(Windows Vista or later) unless $ENV{HOME} exists. After that, the home
+directory is translated to a short name (which means the directory must exist)
+and the subdirectories are created.
+
+=head1 RATIONALE
+
+The version of a Perl package on your machine is not always the version you
+need. Obviously, the best thing to do would be to update to the version you
+need. However, you might be in a situation where you're prevented from doing
+this. Perhaps you don't have system administrator privileges; or perhaps you
+are using a package management system such as Debian, and nobody has yet gotten
+around to packaging up the version you need.
+
+local::lib solves this problem by allowing you to create your own directory of
+Perl packages downloaded from CPAN (in a multi-user system, this would typically
+be within your own home directory). The existing system Perl installation is
+not affected; you simply invoke Perl with special options so that Perl uses the
+packages in your own local package directory rather than the system packages.
+local::lib arranges things so that your locally installed version of the Perl
+packages takes precedence over the system installation.
+
+If you are using a package management system (such as Debian), you don't need to
+worry about Debian and CPAN stepping on each other's toes. Your local version
+of the packages will be written to an entirely separate directory from those
+installed by Debian.
+
+=head1 DESCRIPTION
+
+This module provides a quick, convenient way of bootstrapping a user-local Perl
+module library located within the user's home directory. It also constructs and
+prints out for the user the list of environment variables using the syntax
+appropriate for the user's current shell (as specified by the C<SHELL>
+environment variable), suitable for directly adding to one's shell
+configuration file.
+
+More generally, local::lib allows for the bootstrapping and usage of a
+directory containing Perl modules outside of Perl's C<@INC>. This makes it
+easier to ship an application with an app-specific copy of a Perl module, or
+collection of modules. Useful in cases like when an upstream maintainer hasn't
+applied a patch to a module of theirs that you need for your application.
+
+On import, local::lib sets the following environment variables to appropriate
+values:
+
+=over 4
+
+=item MODULEBUILDRC
+
+=item PERL_MM_OPT
+
+=item PERL5LIB
+
+=item PATH
+
+PATH is appended to, rather than clobbered.
+
+=back
+
+These values are then available for reference by any code after import.
+
+=head1 METHODS
+
+=head2 ensure_directory_structure_for
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Attempts to create the given path, and all required parent directories. Throws
+an exception on failure.
+
+=head2 print_environment_vars_for
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Prints to standard output the variables listed above, properly set to use the
+given path as the base directory.
+
+=head2 setup_env_hash_for
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Constructs the C<%ENV> keys for the given path, by calling
+C<build_environment_vars_for>.
+
+=head2 install_base_perl_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Returns a path describing where to install the Perl modules for this local
+library installation. Appends the directories C<lib> and C<perl5> to the given
+path.
+
+=head2 install_base_arch_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Returns a path describing where to install the architecture-specific Perl
+modules for this local library installation. Based on the
+L</install_base_perl_path> method's return value, and appends the value of
+C<$Config{archname}>.
+
+=head2 install_base_bin_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Returns a path describing where to install the executable programs for this
+local library installation. Based on the L</install_base_perl_path> method's
+return value, and appends the directory C<bin>.
+
+=head2 modulebuildrc_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Returns a path describing where to install the C<.modulebuildrc> file, based on
+the given path.
+
+=head2 resolve_empty_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Builds and returns the base path into which to set up the local module
+installation. Defaults to C<~/perl5>.
+
+=head2 resolve_home_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Attempts to find the user's home directory. If installed, uses C<File::HomeDir>
+for this purpose. If no definite answer is available, throws an exception.
+
+=head2 resolve_relative_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Translates the given path into an absolute path.
+
+=head2 resolve_path
+
+=over 4
+
+=item Arguments: path
+
+=back
+
+Calls the following in a pipeline, passing the result from the previous to the
+next, in an attempt to find where to configure the environment for a local
+library installation: L</resolve_empty_path>, L</resolve_home_path>,
+L</resolve_relative_path>. Passes the given path argument to
+L</resolve_empty_path> which then returns a result that is passed to
+L</resolve_home_path>, which then has its result passed to
+L</resolve_relative_path>. The result of this final call is returned from
+L</resolve_path>.
+
+=head1 A WARNING ABOUT UNINST=1
+
+Be careful about using local::lib in combination with "make install UNINST=1".
+The idea of this feature is that will uninstall an old version of a module
+before installing a new one. However it lacks a safety check that the old
+version and the new version will go in the same directory. Used in combination
+with local::lib, you can potentially delete a globally accessible version of a
+module while installing the new version in a local place. Only combine "make
+install UNINST=1" and local::lib if you understand these possible consequences.
+
+=head1 LIMITATIONS
+
+Rather basic shell detection. Right now anything with csh in its name is
+assumed to be a C shell or something compatible, and everything else is assumed
+to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is
+not set, a Bourne-compatible shell is assumed.
+
+Bootstrap is a hack and will use CPAN.pm for ExtUtils::MakeMaker even if you
+have CPANPLUS installed.
+
+Kills any existing PERL5LIB, PERL_MM_OPT or MODULEBUILDRC.
+
+Should probably auto-fixup CPAN config if not already done.
+
+Patches very much welcome for any of the above.
+
+On Win32 systems, does not have a way to write the created environment variables
+to the registry, so that they can persist through a reboot.
+
+=head1 TROUBLESHOOTING
+
+If you've configured local::lib to install CPAN modules somewhere in to your
+home directory, and at some point later you try to install a module with C<cpan
+-i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
+permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
+/usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an
+error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then
+you've somehow lost your updated ExtUtils::MakeMaker module.
+
+To remedy this situation, rerun the bootstrapping procedure documented above.
+
+Then, run C<rm -r ~/.cpan/build/Foo-Bar*>
+
+Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item SHELL
+
+=item COMSPEC
+
+local::lib looks at the user's C<SHELL> environment variable when printing out
+commands to add to the shell configuration file.
+
+On Win32 systems, C<COMSPEC> is also examined.
+
+=back
+
+=head1 AUTHOR
+
+Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
+
+auto_install fixes kindly sponsored by http://www.takkle.com/
+
+=head1 CONTRIBUTORS
+
+Chris Nehren <apeiron@cpan.org> now oversees maintenance of local::lib, in
+addition to providing doc patches and bootstrap fixes to prevent users from
+shooting themselves in the foot (it's more likely than you think).
+
+Patches to correctly output commands for csh style shells, as well as some
+documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>.
+
+'--self-contained' feature contributed by Mark Stosberg <mark@summersault.com>.
+
+Ability to pass '--self-contained' without a directory inspired by frew on
+irc.perl.org/#catalyst.
+
+Doc patches for a custom local::lib directory contributed by Torsten Raudssus
+<torsten@raudssus.de>.
+
+Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring
+things will install properly, submitted a fix for the bug causing problems with
+writing Makefiles during bootstrapping, contributed an example program, and
+submitted yet another fix to ensure that local::lib can install and bootstrap
+properly. Many, many thanks!
+
+pattern of Freenode IRC contributed the beginnings of the Troubleshooting
+section. Many thanks!
+
+Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>.
+
+kgish/#perl-help@irc.perl.org suggested revamping the section on sourcing the
+shell file to make it clearer to those quickly reading the POD.
+
+t0m and chrisa on #local-lib@irc.perl.org pointed out a PERL5LIB ordering issue
+with C<--self-contained>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007 - 2009 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as
+listed above.
+
+=head1 LICENSE
+
+This library is free software and may be distributed under the same terms
+as perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/lwptut.pod b/Master/tlpkg/tlperl.straw/lib/lwptut.pod
new file mode 100755
index 00000000000..9be09c72e84
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/lwptut.pod
@@ -0,0 +1,837 @@
+=head1 NAME
+
+lwptut -- An LWP Tutorial
+
+=head1 DESCRIPTION
+
+LWP (short for "Library for WWW in Perl") is a very popular group of
+Perl modules for accessing data on the Web. Like most Perl
+module-distributions, each of LWP's component modules comes with
+documentation that is a complete reference to its interface. However,
+there are so many modules in LWP that it's hard to know where to start
+looking for information on how to do even the simplest most common
+things.
+
+Really introducing you to using LWP would require a whole book -- a book
+that just happens to exist, called I<Perl & LWP>. But this article
+should give you a taste of how you can go about some common tasks with
+LWP.
+
+
+=head2 Getting documents with LWP::Simple
+
+If you just want to get what's at a particular URL, the simplest way
+to do it is LWP::Simple's functions.
+
+In a Perl program, you can call its C<get($url)> function. It will try
+getting that URL's content. If it works, then it'll return the
+content; but if there's some error, it'll return undef.
+
+ my $url = 'http://freshair.npr.org/dayFA.cfm?todayDate=current';
+ # Just an example: the URL for the most recent /Fresh Air/ show
+
+ use LWP::Simple;
+ my $content = get $url;
+ die "Couldn't get $url" unless defined $content;
+
+ # Then go do things with $content, like this:
+
+ if($content =~ m/jazz/i) {
+ print "They're talking about jazz today on Fresh Air!\n";
+ }
+ else {
+ print "Fresh Air is apparently jazzless today.\n";
+ }
+
+The handiest variant on C<get> is C<getprint>, which is useful in Perl
+one-liners. If it can get the page whose URL you provide, it sends it
+to STDOUT; otherwise it complains to STDERR.
+
+ % perl -MLWP::Simple -e "getprint 'http://cpan.org/RECENT'"
+
+That is the URL of a plain text file that lists new files in CPAN in
+the past two weeks. You can easily make it part of a tidy little
+shell command, like this one that mails you the list of new
+C<Acme::> modules:
+
+ % perl -MLWP::Simple -e "getprint 'http://cpan.org/RECENT'" \
+ | grep "/by-module/Acme" | mail -s "New Acme modules! Joy!" $USER
+
+There are other useful functions in LWP::Simple, including one function
+for running a HEAD request on a URL (useful for checking links, or
+getting the last-revised time of a URL), and two functions for
+saving/mirroring a URL to a local file. See L<the LWP::Simple
+documentation|LWP::Simple> for the full details, or chapter 2 of I<Perl
+& LWP> for more examples.
+
+
+
+=for comment
+ ##########################################################################
+
+
+
+=head2 The Basics of the LWP Class Model
+
+LWP::Simple's functions are handy for simple cases, but its functions
+don't support cookies or authorization, don't support setting header
+lines in the HTTP request, generally don't support reading header lines
+in the HTTP response (notably the full HTTP error message, in case of an
+error). To get at all those features, you'll have to use the full LWP
+class model.
+
+While LWP consists of dozens of classes, the main two that you have to
+understand are L<LWP::UserAgent> and L<HTTP::Response>. LWP::UserAgent
+is a class for "virtual browsers" which you use for performing requests,
+and L<HTTP::Response> is a class for the responses (or error messages)
+that you get back from those requests.
+
+The basic idiom is C<< $response = $browser->get($url) >>, or more fully
+illustrated:
+
+ # Early in your program:
+
+ use LWP 5.64; # Loads all important LWP classes, and makes
+ # sure your version is reasonably recent.
+
+ my $browser = LWP::UserAgent->new;
+
+ ...
+
+ # Then later, whenever you need to make a get request:
+ my $url = 'http://freshair.npr.org/dayFA.cfm?todayDate=current';
+
+ my $response = $browser->get( $url );
+ die "Can't get $url -- ", $response->status_line
+ unless $response->is_success;
+
+ die "Hey, I was expecting HTML, not ", $response->content_type
+ unless $response->content_type eq 'text/html';
+ # or whatever content-type you're equipped to deal with
+
+ # Otherwise, process the content somehow:
+
+ if($response->decoded_content =~ m/jazz/i) {
+ print "They're talking about jazz today on Fresh Air!\n";
+ }
+ else {
+ print "Fresh Air is apparently jazzless today.\n";
+ }
+
+There are two objects involved: C<$browser>, which holds an object of
+class LWP::UserAgent, and then the C<$response> object, which is of
+class HTTP::Response. You really need only one browser object per
+program; but every time you make a request, you get back a new
+HTTP::Response object, which will have some interesting attributes:
+
+=over
+
+=item *
+
+A status code indicating
+success or failure
+(which you can test with C<< $response->is_success >>).
+
+=item *
+
+An HTTP status
+line that is hopefully informative if there's failure (which you can
+see with C<< $response->status_line >>,
+returning something like "404 Not Found").
+
+=item *
+
+A MIME content-type like "text/html", "image/gif",
+"application/xml", etc., which you can see with
+C<< $response->content_type >>
+
+=item *
+
+The actual content of the response, in C<< $response->decoded_content >>.
+If the response is HTML, that's where the HTML source will be; if
+it's a GIF, then C<< $response->decoded_content >> will be the binary
+GIF data.
+
+=item *
+
+And dozens of other convenient and more specific methods that are
+documented in the docs for L<HTTP::Response>, and its superclasses
+L<HTTP::Message> and L<HTTP::Headers>.
+
+=back
+
+
+
+=for comment
+ ##########################################################################
+
+
+
+=head2 Adding Other HTTP Request Headers
+
+The most commonly used syntax for requests is C<< $response =
+$browser->get($url) >>, but in truth, you can add extra HTTP header
+lines to the request by adding a list of key-value pairs after the URL,
+like so:
+
+ $response = $browser->get( $url, $key1, $value1, $key2, $value2, ... );
+
+For example, here's how to send some more Netscape-like headers, in case
+you're dealing with a site that would otherwise reject your request:
+
+
+ my @ns_headers = (
+ 'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)',
+ 'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*',
+ 'Accept-Charset' => 'iso-8859-1,*,utf-8',
+ 'Accept-Language' => 'en-US',
+ );
+
+ ...
+
+ $response = $browser->get($url, @ns_headers);
+
+If you weren't reusing that array, you could just go ahead and do this:
+
+ $response = $browser->get($url,
+ 'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)',
+ 'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*',
+ 'Accept-Charset' => 'iso-8859-1,*,utf-8',
+ 'Accept-Language' => 'en-US',
+ );
+
+If you were only ever changing the 'User-Agent' line, you could just change
+the C<$browser> object's default line from "libwww-perl/5.65" (or the like)
+to whatever you like, using the LWP::UserAgent C<agent> method:
+
+ $browser->agent('Mozilla/4.76 [en] (Win98; U)');
+
+
+
+=for comment
+ ##########################################################################
+
+
+
+=head2 Enabling Cookies
+
+A default LWP::UserAgent object acts like a browser with its cookies
+support turned off. There are various ways of turning it on, by setting
+its C<cookie_jar> attribute. A "cookie jar" is an object representing
+a little database of all
+the HTTP cookies that a browser can know about. It can correspond to a
+file on disk (the way Netscape uses its F<cookies.txt> file), or it can
+be just an in-memory object that starts out empty, and whose collection of
+cookies will disappear once the program is finished running.
+
+To give a browser an in-memory empty cookie jar, you set its C<cookie_jar>
+attribute like so:
+
+ $browser->cookie_jar({});
+
+To give it a copy that will be read from a file on disk, and will be saved
+to it when the program is finished running, set the C<cookie_jar> attribute
+like this:
+
+ use HTTP::Cookies;
+ $browser->cookie_jar( HTTP::Cookies->new(
+ 'file' => '/some/where/cookies.lwp',
+ # where to read/write cookies
+ 'autosave' => 1,
+ # save it to disk when done
+ ));
+
+That file will be an LWP-specific format. If you want to be access the
+cookies in your Netscape cookies file, you can use the
+HTTP::Cookies::Netscape class:
+
+ use HTTP::Cookies;
+ # yes, loads HTTP::Cookies::Netscape too
+
+ $browser->cookie_jar( HTTP::Cookies::Netscape->new(
+ 'file' => 'c:/Program Files/Netscape/Users/DIR-NAME-HERE/cookies.txt',
+ # where to read cookies
+ ));
+
+You could add an C<< 'autosave' => 1 >> line as further above, but at
+time of writing, it's uncertain whether Netscape might discard some of
+the cookies you could be writing back to disk.
+
+
+
+=for comment
+ ##########################################################################
+
+
+
+=head2 Posting Form Data
+
+Many HTML forms send data to their server using an HTTP POST request, which
+you can send with this syntax:
+
+ $response = $browser->post( $url,
+ [
+ formkey1 => value1,
+ formkey2 => value2,
+ ...
+ ],
+ );
+
+Or if you need to send HTTP headers:
+
+ $response = $browser->post( $url,
+ [
+ formkey1 => value1,
+ formkey2 => value2,
+ ...
+ ],
+ headerkey1 => value1,
+ headerkey2 => value2,
+ );
+
+For example, the following program makes a search request to AltaVista
+(by sending some form data via an HTTP POST request), and extracts from
+the HTML the report of the number of matches:
+
+ use strict;
+ use warnings;
+ use LWP 5.64;
+ my $browser = LWP::UserAgent->new;
+
+ my $word = 'tarragon';
+
+ my $url = 'http://www.altavista.com/sites/search/web';
+ my $response = $browser->post( $url,
+ [ 'q' => $word, # the Altavista query string
+ 'pg' => 'q', 'avkw' => 'tgz', 'kl' => 'XX',
+ ]
+ );
+ die "$url error: ", $response->status_line
+ unless $response->is_success;
+ die "Weird content type at $url -- ", $response->content_type
+ unless $response->content_is_html;
+
+ if( $response->decoded_content =~ m{AltaVista found ([0-9,]+) results} ) {
+ # The substring will be like "AltaVista found 2,345 results"
+ print "$word: $1\n";
+ }
+ else {
+ print "Couldn't find the match-string in the response\n";
+ }
+
+
+
+=for comment
+ ##########################################################################
+
+
+
+=head2 Sending GET Form Data
+
+Some HTML forms convey their form data not by sending the data
+in an HTTP POST request, but by making a normal GET request with
+the data stuck on the end of the URL. For example, if you went to
+C<imdb.com> and ran a search on "Blade Runner", the URL you'd see
+in your browser window would be:
+
+ http://us.imdb.com/Tsearch?title=Blade%20Runner&restrict=Movies+and+TV
+
+To run the same search with LWP, you'd use this idiom, which involves
+the URI class:
+
+ use URI;
+ my $url = URI->new( 'http://us.imdb.com/Tsearch' );
+ # makes an object representing the URL
+
+ $url->query_form( # And here the form data pairs:
+ 'title' => 'Blade Runner',
+ 'restrict' => 'Movies and TV',
+ );
+
+ my $response = $browser->get($url);
+
+See chapter 5 of I<Perl & LWP> for a longer discussion of HTML forms
+and of form data, and chapters 6 through 9 for a longer discussion of
+extracting data from HTML.
+
+
+
+=head2 Absolutizing URLs
+
+The URI class that we just mentioned above provides all sorts of methods
+for accessing and modifying parts of URLs (such as asking sort of URL it
+is with C<< $url->scheme >>, and asking what host it refers to with C<<
+$url->host >>, and so on, as described in L<the docs for the URI
+class|URI>. However, the methods of most immediate interest
+are the C<query_form> method seen above, and now the C<new_abs> method
+for taking a probably-relative URL string (like "../foo.html") and getting
+back an absolute URL (like "http://www.perl.com/stuff/foo.html"), as
+shown here:
+
+ use URI;
+ $abs = URI->new_abs($maybe_relative, $base);
+
+For example, consider this program that matches URLs in the HTML
+list of new modules in CPAN:
+
+ use strict;
+ use warnings;
+ use LWP;
+ my $browser = LWP::UserAgent->new;
+
+ my $url = 'http://www.cpan.org/RECENT.html';
+ my $response = $browser->get($url);
+ die "Can't get $url -- ", $response->status_line
+ unless $response->is_success;
+
+ my $html = $response->decoded_content;
+ while( $html =~ m/<A HREF=\"(.*?)\"/g ) {
+ print "$1\n";
+ }
+
+When run, it emits output that starts out something like this:
+
+ MIRRORING.FROM
+ RECENT
+ RECENT.html
+ authors/00whois.html
+ authors/01mailrc.txt.gz
+ authors/id/A/AA/AASSAD/CHECKSUMS
+ ...
+
+However, if you actually want to have those be absolute URLs, you
+can use the URI module's C<new_abs> method, by changing the C<while>
+loop to this:
+
+ while( $html =~ m/<A HREF=\"(.*?)\"/g ) {
+ print URI->new_abs( $1, $response->base ) ,"\n";
+ }
+
+(The C<< $response->base >> method from L<HTTP::Message|HTTP::Message>
+is for returning what URL
+should be used for resolving relative URLs -- it's usually just
+the same as the URL that you requested.)
+
+That program then emits nicely absolute URLs:
+
+ http://www.cpan.org/MIRRORING.FROM
+ http://www.cpan.org/RECENT
+ http://www.cpan.org/RECENT.html
+ http://www.cpan.org/authors/00whois.html
+ http://www.cpan.org/authors/01mailrc.txt.gz
+ http://www.cpan.org/authors/id/A/AA/AASSAD/CHECKSUMS
+ ...
+
+See chapter 4 of I<Perl & LWP> for a longer discussion of URI objects.
+
+Of course, using a regexp to match hrefs is a bit simplistic, and for
+more robust programs, you'll probably want to use an HTML-parsing module
+like L<HTML::LinkExtor> or L<HTML::TokeParser> or even maybe
+L<HTML::TreeBuilder>.
+
+
+
+
+=for comment
+ ##########################################################################
+
+=head2 Other Browser Attributes
+
+LWP::UserAgent objects have many attributes for controlling how they
+work. Here are a few notable ones:
+
+=over
+
+=item *
+
+C<< $browser->timeout(15); >>
+
+This sets this browser object to give up on requests that don't answer
+within 15 seconds.
+
+
+=item *
+
+C<< $browser->protocols_allowed( [ 'http', 'gopher'] ); >>
+
+This sets this browser object to not speak any protocols other than HTTP
+and gopher. If it tries accessing any other kind of URL (like an "ftp:"
+or "mailto:" or "news:" URL), then it won't actually try connecting, but
+instead will immediately return an error code 500, with a message like
+"Access to 'ftp' URIs has been disabled".
+
+
+=item *
+
+C<< use LWP::ConnCache; $browser->conn_cache(LWP::ConnCache->new()); >>
+
+This tells the browser object to try using the HTTP/1.1 "Keep-Alive"
+feature, which speeds up requests by reusing the same socket connection
+for multiple requests to the same server.
+
+
+=item *
+
+C<< $browser->agent( 'SomeName/1.23 (more info here maybe)' ) >>
+
+This changes how the browser object will identify itself in
+the default "User-Agent" line is its HTTP requests. By default,
+it'll send "libwww-perl/I<versionnumber>", like
+"libwww-perl/5.65". You can change that to something more descriptive
+like this:
+
+ $browser->agent( 'SomeName/3.14 (contact@robotplexus.int)' );
+
+Or if need be, you can go in disguise, like this:
+
+ $browser->agent( 'Mozilla/4.0 (compatible; MSIE 5.12; Mac_PowerPC)' );
+
+
+=item *
+
+C<< push @{ $ua->requests_redirectable }, 'POST'; >>
+
+This tells this browser to obey redirection responses to POST requests
+(like most modern interactive browsers), even though the HTTP RFC says
+that should not normally be done.
+
+
+=back
+
+
+For more options and information, see L<the full documentation for
+LWP::UserAgent|LWP::UserAgent>.
+
+
+
+=for comment
+ ##########################################################################
+
+
+
+=head2 Writing Polite Robots
+
+If you want to make sure that your LWP-based program respects F<robots.txt>
+files and doesn't make too many requests too fast, you can use the LWP::RobotUA
+class instead of the LWP::UserAgent class.
+
+LWP::RobotUA class is just like LWP::UserAgent, and you can use it like so:
+
+ use LWP::RobotUA;
+ my $browser = LWP::RobotUA->new('YourSuperBot/1.34', 'you@yoursite.com');
+ # Your bot's name and your email address
+
+ my $response = $browser->get($url);
+
+But HTTP::RobotUA adds these features:
+
+
+=over
+
+=item *
+
+If the F<robots.txt> on C<$url>'s server forbids you from accessing
+C<$url>, then the C<$browser> object (assuming it's of class LWP::RobotUA)
+won't actually request it, but instead will give you back (in C<$response>) a 403 error
+with a message "Forbidden by robots.txt". That is, if you have this line:
+
+ die "$url -- ", $response->status_line, "\nAborted"
+ unless $response->is_success;
+
+then the program would die with an error message like this:
+
+ http://whatever.site.int/pith/x.html -- 403 Forbidden by robots.txt
+ Aborted at whateverprogram.pl line 1234
+
+=item *
+
+If this C<$browser> object sees that the last time it talked to
+C<$url>'s server was too recently, then it will pause (via C<sleep>) to
+avoid making too many requests too often. How long it will pause for, is
+by default one minute -- but you can control it with the C<<
+$browser->delay( I<minutes> ) >> attribute.
+
+For example, this code:
+
+ $browser->delay( 7/60 );
+
+...means that this browser will pause when it needs to avoid talking to
+any given server more than once every 7 seconds.
+
+=back
+
+For more options and information, see L<the full documentation for
+LWP::RobotUA|LWP::RobotUA>.
+
+
+
+
+
+=for comment
+ ##########################################################################
+
+=head2 Using Proxies
+
+In some cases, you will want to (or will have to) use proxies for
+accessing certain sites and/or using certain protocols. This is most
+commonly the case when your LWP program is running (or could be running)
+on a machine that is behind a firewall.
+
+To make a browser object use proxies that are defined in the usual
+environment variables (C<HTTP_PROXY>, etc.), just call the C<env_proxy>
+on a user-agent object before you go making any requests on it.
+Specifically:
+
+ use LWP::UserAgent;
+ my $browser = LWP::UserAgent->new;
+
+ # And before you go making any requests:
+ $browser->env_proxy;
+
+For more information on proxy parameters, see L<the LWP::UserAgent
+documentation|LWP::UserAgent>, specifically the C<proxy>, C<env_proxy>,
+and C<no_proxy> methods.
+
+
+
+=for comment
+ ##########################################################################
+
+=head2 HTTP Authentication
+
+Many web sites restrict access to documents by using "HTTP
+Authentication". This isn't just any form of "enter your password"
+restriction, but is a specific mechanism where the HTTP server sends the
+browser an HTTP code that says "That document is part of a protected
+'realm', and you can access it only if you re-request it and add some
+special authorization headers to your request".
+
+For example, the Unicode.org admins stop email-harvesting bots from
+harvesting the contents of their mailing list archives, by protecting
+them with HTTP Authentication, and then publicly stating the username
+and password (at C<http://www.unicode.org/mail-arch/>) -- namely
+username "unicode-ml" and password "unicode".
+
+For example, consider this URL, which is part of the protected
+area of the web site:
+
+ http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html
+
+If you access that with a browser, you'll get a prompt
+like
+"Enter username and password for 'Unicode-MailList-Archives' at server
+'www.unicode.org'".
+
+In LWP, if you just request that URL, like this:
+
+ use LWP;
+ my $browser = LWP::UserAgent->new;
+
+ my $url =
+ 'http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html';
+ my $response = $browser->get($url);
+
+ die "Error: ", $response->header('WWW-Authenticate') || 'Error accessing',
+ # ('WWW-Authenticate' is the realm-name)
+ "\n ", $response->status_line, "\n at $url\n Aborting"
+ unless $response->is_success;
+
+Then you'll get this error:
+
+ Error: Basic realm="Unicode-MailList-Archives"
+ 401 Authorization Required
+ at http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html
+ Aborting at auth1.pl line 9. [or wherever]
+
+...because the C<$browser> doesn't know any the username and password
+for that realm ("Unicode-MailList-Archives") at that host
+("www.unicode.org"). The simplest way to let the browser know about this
+is to use the C<credentials> method to let it know about a username and
+password that it can try using for that realm at that host. The syntax is:
+
+ $browser->credentials(
+ 'servername:portnumber',
+ 'realm-name',
+ 'username' => 'password'
+ );
+
+In most cases, the port number is 80, the default TCP/IP port for HTTP; and
+you usually call the C<credentials> method before you make any requests.
+For example:
+
+ $browser->credentials(
+ 'reports.mybazouki.com:80',
+ 'web_server_usage_reports',
+ 'plinky' => 'banjo123'
+ );
+
+So if we add the following to the program above, right after the C<<
+$browser = LWP::UserAgent->new; >> line...
+
+ $browser->credentials( # add this to our $browser 's "key ring"
+ 'www.unicode.org:80',
+ 'Unicode-MailList-Archives',
+ 'unicode-ml' => 'unicode'
+ );
+
+...then when we run it, the request succeeds, instead of causing the
+C<die> to be called.
+
+
+
+=for comment
+ ##########################################################################
+
+=head2 Accessing HTTPS URLs
+
+When you access an HTTPS URL, it'll work for you just like an HTTP URL
+would -- if your LWP installation has HTTPS support (via an appropriate
+Secure Sockets Layer library). For example:
+
+ use LWP;
+ my $url = 'https://www.paypal.com/'; # Yes, HTTPS!
+ my $browser = LWP::UserAgent->new;
+ my $response = $browser->get($url);
+ die "Error at $url\n ", $response->status_line, "\n Aborting"
+ unless $response->is_success;
+ print "Whee, it worked! I got that ",
+ $response->content_type, " document!\n";
+
+If your LWP installation doesn't have HTTPS support set up, then the
+response will be unsuccessful, and you'll get this error message:
+
+ Error at https://www.paypal.com/
+ 501 Protocol scheme 'https' is not supported
+ Aborting at paypal.pl line 7. [or whatever program and line]
+
+If your LWP installation I<does> have HTTPS support installed, then the
+response should be successful, and you should be able to consult
+C<$response> just like with any normal HTTP response.
+
+For information about installing HTTPS support for your LWP
+installation, see the helpful F<README.SSL> file that comes in the
+libwww-perl distribution.
+
+
+=for comment
+ ##########################################################################
+
+
+
+=head2 Getting Large Documents
+
+When you're requesting a large (or at least potentially large) document,
+a problem with the normal way of using the request methods (like C<<
+$response = $browser->get($url) >>) is that the response object in
+memory will have to hold the whole document -- I<in memory>. If the
+response is a thirty megabyte file, this is likely to be quite an
+imposition on this process's memory usage.
+
+A notable alternative is to have LWP save the content to a file on disk,
+instead of saving it up in memory. This is the syntax to use:
+
+ $response = $ua->get($url,
+ ':content_file' => $filespec,
+ );
+
+For example,
+
+ $response = $ua->get('http://search.cpan.org/',
+ ':content_file' => '/tmp/sco.html'
+ );
+
+When you use this C<:content_file> option, the C<$response> will have
+all the normal header lines, but C<< $response->content >> will be
+empty.
+
+Note that this ":content_file" option isn't supported under older
+versions of LWP, so you should consider adding C<use LWP 5.66;> to check
+the LWP version, if you think your program might run on systems with
+older versions.
+
+If you need to be compatible with older LWP versions, then use
+this syntax, which does the same thing:
+
+ use HTTP::Request::Common;
+ $response = $ua->request( GET($url), $filespec );
+
+
+=for comment
+ ##########################################################################
+
+
+=head1 SEE ALSO
+
+Remember, this article is just the most rudimentary introduction to
+LWP -- to learn more about LWP and LWP-related tasks, you really
+must read from the following:
+
+=over
+
+=item *
+
+L<LWP::Simple> -- simple functions for getting/heading/mirroring URLs
+
+=item *
+
+L<LWP> -- overview of the libwww-perl modules
+
+=item *
+
+L<LWP::UserAgent> -- the class for objects that represent "virtual browsers"
+
+=item *
+
+L<HTTP::Response> -- the class for objects that represent the response to
+a LWP response, as in C<< $response = $browser->get(...) >>
+
+=item *
+
+L<HTTP::Message> and L<HTTP::Headers> -- classes that provide more methods
+to HTTP::Response.
+
+=item *
+
+L<URI> -- class for objects that represent absolute or relative URLs
+
+=item *
+
+L<URI::Escape> -- functions for URL-escaping and URL-unescaping strings
+(like turning "this & that" to and from "this%20%26%20that").
+
+=item *
+
+L<HTML::Entities> -- functions for HTML-escaping and HTML-unescaping strings
+(like turning "C. & E. BrontE<euml>" to and from "C. &amp; E. Bront&euml;")
+
+=item *
+
+L<HTML::TokeParser> and L<HTML::TreeBuilder> -- classes for parsing HTML
+
+=item *
+
+L<HTML::LinkExtor> -- class for finding links in HTML documents
+
+=item *
+
+The book I<Perl & LWP> by Sean M. Burke. O'Reilly & Associates, 2002.
+ISBN: 0-596-00178-9. C<http://www.oreilly.com/catalog/perllwp/>
+
+=back
+
+
+=head1 COPYRIGHT
+
+Copyright 2002, Sean M. Burke. You can redistribute this document and/or
+modify it, but only under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=for comment
+ ##########################################################################
+
+=cut
+
+# End of Pod
diff --git a/Master/tlpkg/tlperl.straw/lib/mro.pm b/Master/tlpkg/tlperl.straw/lib/mro.pm
new file mode 100755
index 00000000000..5a193e2c8c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/mro.pm
@@ -0,0 +1,381 @@
+# mro.pm
+#
+# Copyright (c) 2007 Brandon L Black
+# Copyright (c) 2008 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.01';
+
+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 precendence ordering. This essentially
+means that no class will appear before any of its subclasses. Take, for
+instance, the classic diamond inheritance pattern:
+
+ <A>
+ / \
+ <B> <C>
+ \ /
+ <D>
+
+The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A>
+appears before B<C>, even though B<C> is the subclass of B<A>. The C3 MRO
+algorithm however, produces the following order: (D, B, C, A), which does
+not have this issue.
+
+This example is fairly trivial; for more complex cases and a deeper
+explanation, see the links in the L</"SEE ALSO"> section.
+
+=head1 Functions
+
+=head2 mro::get_linear_isa($classname[, $type])
+
+Returns an arrayref which is the linearized MRO of the given class.
+Uses whichever MRO is currently in effect for that class by default,
+or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
+
+The linearized MRO of a class is an ordered array of all of the
+classes one would search when resolving a method on that class,
+starting with the class itself.
+
+If the requested class doesn't yet exist, this function will still
+succeed, and return C<[ $classname ]>
+
+Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
+part of the MRO of a class, even though all classes implicitly inherit
+methods from C<UNIVERSAL> and its parents.
+
+=head2 mro::set_mro($classname, $type)
+
+Sets the MRO of the given class to the C<$type> argument (either
+C<c3> or C<dfs>).
+
+=head2 mro::get_mro($classname)
+
+Returns the MRO of the given class (either C<c3> or C<dfs>).
+
+=head2 mro::get_isarev($classname)
+
+Gets the C<mro_isarev> for this class, returned as an
+arrayref of class names. These are every class that "isa"
+the given class name, even if the isa relationship is
+indirect. This is used internally by the MRO code to
+keep track of method/MRO cache invalidations.
+
+Currently, this list only grows, it never shrinks. This
+was a performance consideration (properly tracking and
+deleting isarev entries when someone removes an entry
+from an C<@ISA> is costly, and it doesn't happen often
+anyways). The fact that a class which no longer truly
+"isa" this class at runtime remains on the list should be
+considered a quirky implementation detail which is subject
+to future change. It shouldn't be an issue as long as
+you're looking at this list for the same reasons the
+core code does: as a performance optimization
+over having to search every class in existence.
+
+As with C<mro::get_mro> above, C<UNIVERSAL> is special.
+C<UNIVERSAL> (and parents') isarev lists do not include
+every class in existence, even though all classes are
+effectively descendants for method inheritance purposes.
+
+=head2 mro::is_universal($classname)
+
+Returns a boolean status indicating whether or not
+the given classname is either C<UNIVERSAL> itself,
+or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
+
+Any class for which this function returns true is
+"universal" in the sense that all classes potentially
+inherit methods from it.
+
+For similar reasons to C<isarev> above, this flag is
+permanent. Once it is set, it does not go away, even
+if the class in question really isn't universal anymore.
+
+=head2 mro::invalidate_all_method_caches()
+
+Increments C<PL_sub_generation>, which invalidates method
+caching in all packages.
+
+=head2 mro::method_changed_in($classname)
+
+Invalidates the method cache of any classes dependent on the
+given class. This is not normally necessary. The only
+known case where pure perl code can confuse the method
+cache is when you manually install a new constant
+subroutine by using a readonly scalar value, like the
+internals of L<constant> do. If you find another case,
+please report it so we can either fix it or document
+the exception here.
+
+=head2 mro::get_pkg_gen($classname)
+
+Returns an integer which is incremented every time a
+real local method in the package C<$classname> changes,
+or the local C<@ISA> of C<$classname> is modified.
+
+This is intended for authors of modules which do lots
+of class introspection, as it allows them to very quickly
+check if anything important about the local properties
+of a given class have changed since the last time they
+looked. It does not increment on method/C<@ISA>
+changes in superclasses.
+
+It's still up to you to seek out the actual changes,
+and there might not actually be any. Perhaps all
+of the changes since you last checked cancelled each
+other out and left the package in the state it was in
+before.
+
+This integer normally starts off at a value of C<1>
+when a package stash is instantiated. Calling it
+on packages whose stashes do not exist at all will
+return C<0>. If a package stash is completely
+deleted (not a normal occurence, but it can happen
+if someone does something like C<undef %PkgName::>),
+the number will be reset to either C<0> or C<1>,
+depending on how completely package was wiped out.
+
+=head2 next::method
+
+This is somewhat like C<SUPER>, but it uses the C3 method
+resolution order to get better consistency in multiple
+inheritance situations. Note that while inheritance in
+general follows whichever MRO is in effect for the
+given class, C<next::method> only uses the C3 MRO.
+
+One generally uses it like so:
+
+ sub some_method {
+ my $self = shift;
+ my $superclass_answer = $self->next::method(@_);
+ return $superclass_answer + 1;
+ }
+
+Note that you don't (re-)specify the method name.
+It forces you to always use the same method name
+as the method you started in.
+
+It can be called on an object or a class, of course.
+
+The way it resolves which actual method to call is:
+
+=over 4
+
+=item 1
+
+First, it determines the linearized C3 MRO of
+the object or class it is being called on.
+
+=item 2
+
+Then, it determines the class and method name
+of the context it was invoked from.
+
+=item 3
+
+Finally, it searches down the C3 MRO list until
+it reaches the contextually enclosing class, then
+searches further down the MRO list for the next
+method with the same name as the contextually
+enclosing method.
+
+=back
+
+Failure to find a next method will result in an
+exception being thrown (see below for alternatives).
+
+This is substantially different than the behavior
+of C<SUPER> under complex multiple inheritance.
+(This becomes obvious when one realizes that the
+common superclasses in the C3 linearizations of
+a given class and one of its parents will not
+always be ordered the same for both.)
+
+B<Caveat>: Calling C<next::method> from methods defined outside the class:
+
+There is an edge case when using C<next::method> from within a subroutine
+which was created in a different module than the one it is called from. It
+sounds complicated, but it really isn't. Here is an example which will not
+work correctly:
+
+ *Foo::foo = sub { (shift)->next::method(@_) };
+
+The problem exists because the anonymous subroutine being assigned to the
+C<*Foo::foo> glob will show up in the call stack as being called
+C<__ANON__> and not C<foo> as you might expect. Since C<next::method> uses
+C<caller> to find the name of the method it was called in, it will fail in
+this case.
+
+But fear not, there's a simple solution. The module C<Sub::Name> will
+reach into the perl internals and assign a name to an anonymous subroutine
+for you. Simply do this:
+
+ use Sub::Name 'subname';
+ *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
+
+and things will Just Work.
+
+=head2 next::can
+
+This is similar to C<next::method>, but just returns either a code
+reference or C<undef> to indicate that no further methods of this name
+exist.
+
+=head2 maybe::next::method
+
+In simple cases, it is equivalent to:
+
+ $self->next::method(@_) if $self->next::can;
+
+But there are some cases where only this solution
+works (like C<goto &maybe::next::method>);
+
+=head1 SEE ALSO
+
+=head2 The original Dylan paper
+
+=over 4
+
+=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
+
+=back
+
+=head2 The prototype Perl 6 Object Model uses C3
+
+=over 4
+
+=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
+
+=back
+
+=head2 Parrot now uses C3
+
+=over 4
+
+=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
+
+=item L<http://use.perl.org/~autrijus/journal/25768>
+
+=back
+
+=head2 Python 2.3 MRO related links
+
+=over 4
+
+=item L<http://www.python.org/2.3/mro.html>
+
+=item L<http://www.python.org/2.2.2/descrintro.html#mro>
+
+=back
+
+=head2 C3 for TinyCLOS
+
+=over 4
+
+=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
+
+=back
+
+=head2 Class::C3
+
+=over 4
+
+=item L<Class::C3>
+
+=back
+
+=head1 AUTHOR
+
+Brandon L. Black, E<lt>blblack@gmail.comE<gt>
+
+Based on Stevan Little's L<Class::C3>
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/newgetopt.pl b/Master/tlpkg/tlperl.straw/lib/newgetopt.pl
new file mode 100755
index 00000000000..1de6a6ebb18
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/newgetopt.pl
@@ -0,0 +1,75 @@
+# $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.
+#
+# 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.straw/lib/open.pm b/Master/tlpkg/tlperl.straw/lib/open.pm
new file mode 100755
index 00000000000..a6b4250e325
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/open3.pl b/Master/tlpkg/tlperl.straw/lib/open3.pl
new file mode 100755
index 00000000000..7fcc9318610
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/open3.pl
@@ -0,0 +1,12 @@
+# 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.straw/lib/ops.pm b/Master/tlpkg/tlperl.straw/lib/ops.pm
new file mode 100755
index 00000000000..4183669eb16
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/overload/numbers.pm b/Master/tlpkg/tlperl.straw/lib/overload/numbers.pm
new file mode 100755
index 00000000000..2e9e9ac1d9a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/overload/numbers.pm
@@ -0,0 +1,159 @@
+# -*- buffer-read-only: t -*-
+#
+# lib/overload/numbers.pm
+#
+# Copyright (C) 2008 by Larry Wall and others
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by overload.pl
+#
+
+package overload::numbers;
+
+our @names = qw#
+ ()
+ (${}
+ (@{}
+ (%{}
+ (*{}
+ (&{}
+ (++
+ (--
+ (bool
+ (0+
+ (""
+ (!
+ (=
+ (abs
+ (neg
+ (<>
+ (int
+ (<
+ (<=
+ (>
+ (>=
+ (==
+ (!=
+ (lt
+ (le
+ (gt
+ (ge
+ (eq
+ (ne
+ (nomethod
+ (+
+ (+=
+ (-
+ (-=
+ (*
+ (*=
+ (/
+ (/=
+ (%
+ (%=
+ (**
+ (**=
+ (<<
+ (<<=
+ (>>
+ (>>=
+ (&
+ (&=
+ (|
+ (|=
+ (^
+ (^=
+ (<=>
+ (cmp
+ (~
+ (atan2
+ (cos
+ (sin
+ (exp
+ (log
+ (sqrt
+ (x
+ (x=
+ (.
+ (.=
+ (~~
+ DESTROY
+#;
+
+our @enums = qw#
+ fallback
+ to_sv
+ to_av
+ to_hv
+ to_gv
+ to_cv
+ inc
+ dec
+ bool_
+ numer
+ string
+ not
+ copy
+ abs
+ neg
+ iter
+ int
+ lt
+ le
+ gt
+ ge
+ eq
+ ne
+ slt
+ sle
+ sgt
+ sge
+ seq
+ sne
+ nomethod
+ add
+ add_ass
+ subtr
+ subtr_ass
+ mult
+ mult_ass
+ div
+ div_ass
+ modulo
+ modulo_ass
+ pow
+ pow_ass
+ lshift
+ lshift_ass
+ rshift
+ rshift_ass
+ band
+ band_ass
+ bor
+ bor_ass
+ bxor
+ bxor_ass
+ ncmp
+ scmp
+ compl
+ atan2
+ cos
+ sin
+ exp
+ log
+ sqrt
+ repeat
+ repeat_ass
+ concat
+ concat_ass
+ smart
+ DESTROY
+#;
+
+{ my $i = 0; our %names = map { $_ => $i++ } @names }
+
+{ my $i = 0; our %enums = map { $_ => $i++ } @enums }
+
diff --git a/Master/tlpkg/tlperl.straw/lib/parent.pm b/Master/tlpkg/tlperl.straw/lib/parent.pm
new file mode 100755
index 00000000000..a18526bb519
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/perl5db.pl b/Master/tlpkg/tlperl.straw/lib/perl5db.pl
new file mode 100755
index 00000000000..ee1708cdc60
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/perl5db.pl
@@ -0,0 +1,9542 @@
+
+=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.32;
+
+$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
+########################################################################
+
+=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;
+
+foreach my $k (keys (%INC)) {
+ &share(\$main::{'_<'.$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 hen 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;
+ eval { require Class::ISA };
+ if ($@) {
+ &warn( $@ =~ /locate/
+ ? "Class::ISA module not found - please install\n"
+ : $@ );
+ }
+ else {
+ ISA:
+ foreach my $isa ( split( /\s+/, $line ) ) {
+ $evalarg = $isa;
+ ($isa) = &eval;
+ no strict 'refs';
+ print join(
+ ', ',
+ map { # snaffled unceremoniously from Class::ISA
+ "$_"
+ . (
+ defined( ${"$_\::VERSION"} )
+ ? ' ' . ${"$_\::VERSION"}
+ : undef )
+ } Class::ISA::self_and_super_path(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
+ machten
+ macos
+ macosx
+ mint
+ modinstall
+ modlib
+ mod
+ modstyle
+ mpeix
+ netware
+ newmod
+ number
+ obj
+ opentut
+ op
+ os2
+ os390
+ os400
+ othrtut
+ 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;
+
+=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
+
+ my @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.straw/lib/perldoc.pod b/Master/tlpkg/tlperl.straw/lib/perldoc.pod
new file mode 100755
index 00000000000..43471c9d8c8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/perldoc.pod
@@ -0,0 +1,267 @@
+
+=head1 NAME
+
+perldoc - Look up Perl documentation in Pod format.
+
+=head1 SYNOPSIS
+
+B<perldoc> [B<-h>] [B<-D>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]
+[B<-i>] [B<-V>] [B<-T>] [B<-r>]
+[B<-dI<destination_file>>]
+[B<-oI<formatname>>]
+[B<-MI<FormatterClassName>>]
+[B<-wI<formatteroption:value>>]
+[B<-n>I<nroff-replacement>]
+[B<-X>]
+[B<-L> I<language_code>]
+PageName|ModuleName|ProgramName
+
+B<perldoc> B<-f> BuiltinFunction
+
+B<perldoc> B<-L> it B<-f> BuiltinFunction
+
+B<perldoc> B<-q> FAQ Keyword
+
+B<perldoc> B<-L> fr B<-q> FAQ Keyword
+
+B<perldoc> B<-v> PerlVariable
+
+See below for more description of the switches.
+
+=head1 DESCRIPTION
+
+I<perldoc> looks up a piece of documentation in .pod format that is embedded
+in the perl installation tree or in a perl script, and displays it via
+C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
+C<col -x> will be used.) This is primarily used for the documentation for
+the perl library modules.
+
+Your system may also have man pages installed for those modules, in
+which case you can probably just use the man(1) command.
+
+If you are looking for a table of contents to the Perl library modules
+documentation, see the L<perltoc> page.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-h>
+
+Prints out a brief B<h>elp message.
+
+=item B<-D>
+
+B<D>escribes search for the item in B<d>etail.
+
+=item B<-t>
+
+Display docs using plain B<t>ext converter, instead of nroff. This may be faster,
+but it probably won't look as nice.
+
+=item B<-u>
+
+Skip the real Pod formatting, and just show the raw Pod source (B<U>nformatted)
+
+=item B<-m> I<module>
+
+Display the entire module: both code and unformatted pod documentation.
+This may be useful if the docs don't explain a function in the detail
+you need, and you'd like to inspect the code directly; perldoc will find
+the file for you and simply hand it off for display.
+
+=item B<-l>
+
+Display onB<l>y the file name of the module found.
+
+=item B<-F>
+
+Consider arguments as file names; no search in directories will be performed.
+
+=item B<-f> I<perlfunc>
+
+The B<-f> option followed by the name of a perl built in function will
+extract the documentation of this function from L<perlfunc>.
+
+Example:
+
+ perldoc -f sprintf
+
+
+=item B<-q> I<perlfaq-search-regexp>
+
+The B<-q> option takes a regular expression as an argument. It will search
+the B<q>uestion headings in perlfaq[1-9] and print the entries matching
+the regular expression.
+
+Example:
+
+ perldoc -q shuffle
+
+
+=item B<-v> I<perlvar>
+
+The B<-v> option followed by the name of a Perl predefined variable will
+extract the documentation of this variable from L<perlvar>.
+
+Examples:
+
+ perldoc -v '$"'
+ perldoc -v @+
+ perldoc -v DATA
+
+
+=item B<-T>
+
+This specifies that the output is not to be sent to a pager, but is to
+be sent right to STDOUT.
+
+=item B<-d> I<destination-filename>
+
+This specifies that the output is to be sent neither to a pager nor
+to STDOUT, but is to be saved to the specified filename. Example:
+C<perldoc -oLaTeX -dtextwrapdocs.tex Text::Wrap>
+
+=item B<-o> I<output-formatname>
+
+This specifies that you want Perldoc to try using a Pod-formatting
+class for the output format that you specify. For example:
+C<-oman>. This is actually just a wrapper around the C<-M> switch;
+using C<-oI<formatname>> just looks for a loadable class by adding
+that format name (with different capitalizations) to the end of
+different classname prefixes.
+
+For example, C<-oLaTeX> currently tries all of the following classes:
+Pod::Perldoc::ToLaTeX Pod::Perldoc::Tolatex Pod::Perldoc::ToLatex
+Pod::Perldoc::ToLATEX Pod::Simple::LaTeX Pod::Simple::latex
+Pod::Simple::Latex Pod::Simple::LATEX Pod::LaTeX Pod::latex Pod::Latex
+Pod::LATEX.
+
+=item B<-M> I<module-name>
+
+This specifies the module that you want to try using for formatting the
+pod. The class must at least provide a C<parse_from_file> method.
+For example: C<perldoc -MPod::Perldoc::ToChecker>.
+
+You can specify several classes to try by joining them with commas
+or semicolons, as in C<-MTk::SuperPod;Tk::Pod>.
+
+=item B<-w> I<option:value> or B<-w> I<option>
+
+This specifies an option to call the formatter B<w>ith. For example,
+C<-w textsize:15> will call
+C<< $formatter->textsize(15) >> on the formatter object before it is
+used to format the object. For this to be valid, the formatter class
+must provide such a method, and the value you pass should be valid.
+(So if C<textsize> expects an integer, and you do C<-w textsize:big>,
+expect trouble.)
+
+You can use C<-w optionname> (without a value) as shorthand for
+C<-w optionname:I<TRUE>>. This is presumably useful in cases of on/off
+features like: C<-w page_numbering>.
+
+You can use a "=" instead of the ":", as in: C<-w textsize=15>. This
+might be more (or less) convenient, depending on what shell you use.
+
+=item B<-X>
+
+Use an index if it is present -- the B<-X> option looks for an entry
+whose basename matches the name given on the command line in the file
+C<$Config{archlib}/pod.idx>. The F<pod.idx> file should contain fully
+qualified filenames, one per line.
+
+=item B<-L> I<language_code>
+
+This allows to specify the I<language code> for desired language translation.
+If C<POD2::E<lt>language_codeE<gt>> package doesn't exist (or isn't installed
+in your system), the switch will be ignored.
+All available translation packages should be found under the C<POD2::>
+namespace. See L<POD2::IT> (or L<POD2::FR>) in order to see how to create and
+integrate new localized C<POD2::*> pod documentation packages in
+L<Pod::Perldoc>.
+
+=item B<PageName|ModuleName|ProgramName>
+
+The item you want to look up. Nested modules (such as C<File::Basename>)
+are specified either as C<File::Basename> or C<File/Basename>. You may also
+give a descriptive name of a page, such as C<perlfunc>.
+
+For simple names like 'foo', when the normal search fails to find
+a matching page, a search with the "perl" prefix is tried as well.
+So "perldoc intro" is enough to find/render "perlintro.pod".
+
+=item B<-n> I<some-formatter>
+
+Specify replacement for nroff
+
+=item B<-r>
+
+Recursive search.
+
+=item B<-i>
+
+Ignore case.
+
+=item B<-V>
+
+Displays the version of perldoc you're running.
+
+=back
+
+
+
+=head1 SECURITY
+
+Because B<perldoc> does not run properly tainted, and is known to
+have security issues, when run as the superuser it will attempt to
+drop privileges by setting the effective and real IDs to nobody's
+or nouser's account, or -2 if unavailable. If it cannot relinquish
+its privileges, it will not run.
+
+
+=head1 ENVIRONMENT
+
+Any switches in the C<PERLDOC> environment variable will be used before the
+command line arguments.
+
+Useful values for C<PERLDOC> include C<-oman>, C<-otext>, C<-otk>, C<-ortf>,
+C<-oxml>, and so on, depending on what modules you have on hand; or
+exactly specify the formatter class with C<-MPod::Perldoc::ToMan>
+or the like.
+
+C<perldoc> also searches directories
+specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
+defined) and C<PATH> environment variables.
+(The latter is so that embedded pods for executables, such as
+C<perldoc> itself, are available.)
+
+C<perldoc> will use, in order of preference, the pager defined in
+C<PERLDOC_PAGER>, C<MANPAGER>, or C<PAGER> before trying to find a pager
+on its own. (C<MANPAGER> is not used if C<perldoc> was told to display
+plain text or unformatted pod.)
+
+One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
+
+Having PERLDOCDEBUG set to a positive integer will make perldoc emit
+even more descriptive output than the C<-v> switch does -- the higher the
+number, the more it emits.
+
+
+=head1 CHANGES
+
+Up to 3.14_05, the switch B<-v> was used to produce verbose
+messages of B<perldoc> operation, which is now enabled by B<-D>.
+
+
+=head1 AUTHOR
+
+Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+
+Past contributors are:
+Sean M. Burke <sburke@cpan.org>,
+Kenneth Albanowski <kjahds@kjahds.com>,
+Andy Dougherty <doughera@lafcol.lafayette.edu>,
+and many others.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/pler.pm b/Master/tlpkg/tlperl.straw/lib/pler.pm
new file mode 100755
index 00000000000..f4830f1558e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/pler.pm
@@ -0,0 +1,482 @@
+package pler;
+
+# See 'sub main' for main functionality
+
+use 5.00503;
+use strict;
+use Config;
+use Carp ();
+use Cwd 3.00 ();
+use File::Which 0.05 ();
+use File::Spec 0.80 ();
+use File::Spec::Functions ':ALL';
+use File::Find::Rule 0.20 ();
+use Getopt::Long 0 ();
+use Probe::Perl 0.01 ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.05';
+}
+
+# Does exec work on this platform
+use constant EXEC_OK => ($^O ne 'MSWin32' and $^O ne 'cygwin');
+
+# Can you overwrite an open file on this platform
+use constant OVERWRITE_OK => !! ( $^O ne 'MSWin32' );
+
+
+
+
+
+
+#####################################################################
+# Resource Locations
+
+sub MakefilePL () {
+ catfile( curdir(), 'Makefile.PL' );
+}
+
+sub BuildPL () {
+ catfile( curdir(), 'Build.PL' );
+}
+
+sub Makefile () {
+ catfile( curdir(), 'Makefile' );
+}
+
+sub Build () {
+ catfile( curdir(), 'Build' );
+}
+
+sub perl () {
+ Probe::Perl->find_perl_interpreter;
+}
+
+# Look for make in $Config
+sub make () {
+ my $make = $Config::Config{make};
+ my $found = File::Which::which( $make );
+ unless ( $found ) {
+ Carp::croak("Failed to find '$make' (as specified by \$Config{make})");
+ }
+ return $found;
+}
+
+sub blib () {
+ catdir( curdir(), 'blib' );
+}
+
+sub inc () {
+ catdir( curdir(), 'inc' );
+}
+
+sub lib () {
+ catdir( curdir(), 'lib' );
+}
+
+sub t () {
+ catdir( curdir(), 't' );
+}
+
+sub xt () {
+ catdir( curdir(), 'xt' );
+}
+
+
+
+
+
+#####################################################################
+# Convenience Logic
+
+sub has_makefilepl () {
+ !! -f MakefilePL;
+}
+
+sub has_buildpl () {
+ !! -f BuildPL;
+}
+
+sub has_makefile () {
+ !! -f Makefile;
+}
+
+sub has_build () {
+ !! -f Build;
+}
+
+sub has_blib () {
+ !! -d blib;
+}
+
+sub blibpm () {
+ eval {
+ require blib;
+ };
+ return ! $@;
+}
+
+sub has_inc () {
+ !! -f inc;
+}
+
+sub has_lib () {
+ !! -d lib;
+}
+
+sub has_t () {
+ !! -d t;
+}
+
+sub has_xt () {
+ !! -d xt;
+}
+
+sub in_distroot () {
+ !! (
+ has_makefilepl or (has_lib and has_t)
+ );
+}
+
+sub in_subdir () {
+ !! (
+ -f catfile( updir(), 'Makefile.PL' )
+ or
+ -d catdir( updir(), 't' )
+ );
+}
+
+sub needs_makefile () {
+ has_makefilepl and ! has_makefile;
+}
+
+sub needs_build () {
+ has_buildpl and ! has_build;
+}
+
+sub mtime ($) {
+ (stat($_[0]))[9];
+}
+
+sub old_makefile () {
+ has_makefile
+ and
+ has_makefilepl
+ and
+ mtime(Makefile) < mtime(MakefilePL);
+}
+
+sub old_build () {
+ has_build
+ and
+ has_buildpl
+ and
+ mtime(Build) < mtime(BuildPL);
+}
+
+
+
+
+
+#####################################################################
+# Utility Functions
+
+# Support verbosity
+use vars qw{$VERBOSE};
+BEGIN {
+ $VERBOSE ||= 0;
+}
+
+sub is_verbose {
+ $VERBOSE;
+}
+
+sub verbose ($) {
+ message( $_[0] ) if $VERBOSE;
+}
+
+sub message ($) {
+ print $_[0];
+}
+
+sub error (@) {
+ print ' ' . join '', map { "$_\n" } ('', @_, '');
+ exit(255);
+}
+
+sub run ($) {
+ my $cmd = shift;
+ verbose( "> $cmd" );
+ system( $cmd );
+}
+
+sub handoff (@) {
+ my $cmd = join ' ', @_;
+ verbose( "> $cmd" );
+ $ENV{HARNESS_ACTIVE} = 1;
+ $ENV{RELEASE_TESTING} = 1;
+ if ( EXEC_OK ) {
+ exec( @_ ) or Carp::croak("Failed to exec '$cmd'");
+ } else {
+ system( @_ );
+ exit(0);
+ }
+}
+
+
+
+
+
+#####################################################################
+# Main Script
+
+my @SWITCHES = ();
+
+sub main {
+ Getopt::Long::Configure('no_ignore_case');
+ Getopt::Long::GetOptions(
+ 'help' => \&help,
+ 'V' => sub { print "pler $VERSION\n"; exit(0) },
+ 'w' => sub { push @SWITCHES, '-w' },
+ );
+
+ # Get the script name
+ my $script = shift @ARGV;
+ unless ( defined $script ) {
+ print "# No file name pattern provided, using 't'...\n";
+ $script = 't';
+ }
+
+ # Abuse the highly mature logic in Cwd to define an $ENV{PWD} value
+ # by chdir'ing to the current directory.
+ # This lets us get the current directory without losing symlinks.
+ Cwd::chdir(curdir());
+ my $orig = $ENV{PWD} or die "Failed to get original directory";
+
+ # Can we locate the distribution root
+ my ($v,$d,$f) = splitpath($ENV{PWD}, 'nofile');
+ my @dirs = splitdir($d);
+ while ( @dirs ) {
+ my $buildpl = catpath(
+ $v, catdir(@dirs), BuildPL,
+ );
+ my $makefilepl = catpath(
+ $v, catdir(@dirs), MakefilePL,
+ );
+ unless ( -f $buildpl or -f $makefilepl ) {
+ pop @dirs;
+ next;
+ }
+
+ # This is a distroot
+ my $distroot = catpath( $v, catdir(@dirs), undef );
+ Cwd::chdir($distroot);
+ last;
+ }
+ unless ( in_distroot ) {
+ error "Failed to locate the distribution root";
+ }
+
+ # Makefile.PL? Or Build.PL?
+ my $BUILD_SYSTEM = has_buildpl ? 'build' : has_makefilepl ? 'make' : '';
+ if ( $BUILD_SYSTEM eq 'build' ) {
+ # Because Module::Build always runs with warnings on,
+ # pler will as well when you use a Build.PL
+ unless ( grep { $_ eq '-w' } @SWITCHES ) {
+ push @SWITCHES, '-w';
+ }
+ }
+
+ # If needed, regenerate the Makefile or Build file
+ # Currently we do not remember Makefile.PL or Build.PL params
+ if ( $BUILD_SYSTEM eq 'make' ) {
+ if ( needs_makefile or (old_makefile and ! OVERWRITE_OK) ) {
+ run( join ' ', perl, MakefilePL );
+ }
+ } elsif ( $BUILD_SYSTEM eq 'build' ) {
+ if ( needs_build or old_build ) {
+ run( join ' ', perl, BuildPL );
+ }
+ }
+
+ # Locate the test script to run
+ if ( $script =~ /\.t$/ ) {
+ # EITHER
+ # 1. They tab-completed the script relative to the original directory (most likely)
+ # OR
+ # 2. They typed the entire name of the test script
+ my $tab_completed = File::Spec->catfile( $orig, $script );
+ if ( -f $tab_completed ) {
+ if ( $orig eq $ENV{PWD} ) {
+ $script = $script; # Included for clarity
+ } else {
+ $script = File::Spec->abs2rel( $tab_completed, $ENV{PWD} );
+ }
+ }
+
+ } else {
+ # Get the list of possible tests
+ my @directory = ( 't', has_xt ? 'xt' : () );
+ my @possible = File::Find::Rule->name('*.t')->file->in(@directory);
+
+ # Filter by the search terms to find matching tests
+ my $matches = filter(
+ [ $script, @ARGV ],
+ [ @possible ],
+ );
+ unless ( @$matches ) {
+ error "No tests match '$script'";
+ }
+ if ( @$matches > 1 ) {
+ error(
+ "More than one possible test",
+ map { " $_" } sort @$matches,
+ );
+ }
+ $script = $matches->[0];
+
+ # Localize the path
+ $script = File::Spec->catfile( split /\//, $script );
+ }
+ unless ( -f $script ) {
+ error "Test script '$script' does not exist";
+ }
+
+ # Rerun make or Build if needed
+ if ( $BUILD_SYSTEM eq 'make' ) {
+ # Do NOT run make if there is no Makefile.PL, because it likely means
+ # there is a hand-written Makefile and NOT one derived from Makefile.PL,
+ # and we have no idea what functionality we might trigger.
+ if ( in_distroot and has_makefile and has_makefilepl ) {
+ run( make );
+ }
+ } elsif ( $BUILD_SYSTEM eq 'build' ) {
+ if ( in_distroot and has_build and has_buildpl ) {
+ run( Build );
+ }
+ }
+
+ # Passing includes via -I params is not good enough
+ # because you can't subshell them, and it's also not
+ # how MakeMaker does it anyway.
+ # We need to hack/extend PERL5LIB instead.
+ my $path_sep = $Config{path_sep};
+ my @PERL5LIB = ();
+
+ # Build the command to execute
+ my @flags = @SWITCHES;
+ if ( has_blib ) {
+ if ( has_inc ) {
+ push @PERL5LIB, inc;
+ }
+ push @PERL5LIB, File::Spec->catdir(
+ blib, 'lib',
+ );
+ push @PERL5LIB, File::Spec->catdir(
+ blib, 'arch',
+ );
+ } elsif ( has_lib ) {
+ push @PERL5LIB, lib;
+ }
+
+ # Hand off to the perl debugger
+ unless ( pler->is_verbose ) {
+ message( "# Debugging $script...\n" );
+ }
+ my @cmd = ( perl, @flags, '-d', $script );
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? join( $path_sep, @PERL5LIB, $ENV{PERL5LIB} )
+ : join( $path_sep, @PERL5LIB );
+ handoff( @cmd );
+}
+
+# Encapsulates the smart filtering as a function
+sub filter {
+ my $terms = shift;
+ my $possible = shift;
+ my @matches = @$possible;
+
+ while ( @$terms ) {
+ my $term = shift @$terms;
+
+ if ( ref $term eq 'Regexp' ) {
+ # If the term is a regexp apply it directly
+ @matches = grep { $_ =~ $term } @matches;
+ } elsif ( $term =~ /^[1-9]\d*$/ ) {
+ # If the search is a pure integer (without leading
+ # zeros) attempt a specialised numeric filter.
+ @matches = grep { /\b0*${term}[^0-9]/ } @matches;
+ } else {
+ # Otherwise treat it as a naive string match
+ $term = quotemeta $term;
+ @matches = grep { /$term/i } @matches;
+ }
+ }
+
+ return \@matches;
+}
+
+sub help { print <<'END_HELP'; exit(0); }
+Usage:
+ pler [options] [file/pattern]
+
+Options:
+ -V Print the pler version
+ -h, --help Display this help
+ -w Run test with the -w warnings flag
+END_HELP
+
+1;
+
+=pod
+
+=head1 NAME
+
+pler - The DWIM Perl Debugger
+
+=head1 DESCRIPTION
+
+B<pler> is a small script which provides a sanity layer for debugging
+test scripts in Perl distributions.
+
+While L<prove> has proven itself to be a highly useful program for
+manually running one or more groups of scripts in a distribution,
+what we also need is something that provides a similar level of
+intelligence in a debugging context.
+
+B<pler> checks that the environment is sound, runs some cleanup tasks
+if needed, makes sure you are in the right directory, and then hands off
+to the perl debugger as normal.
+
+=head1 TO DO
+
+- Tweak some small terminal related issues on Win32
+
+=head1 SUPPORT
+
+All bugs should be filed via the bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=pler>
+
+For other issues, or commercial enhancement and support, contact the author
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<prove>, L<http://ali.as/>
+
+=head1 COPYRIGHT
+
+Copyright 2006 - 2010 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/ppm.xml b/Master/tlpkg/tlperl.straw/lib/ppm.xml
new file mode 100755
index 00000000000..699e94ce759
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/ppm.xml
@@ -0,0 +1,18 @@
+
+<PPMCONFIG>
+
+<PPMVER>0,01_01,0,0</PPMVER>
+
+<PLATFORM CPU="x86" OSVALUE="MSWin32" OSVERSION="4,0,0,0" />
+
+<OPTIONS BUILDDIR="C:\strawberry\ppm" CLEAN="1" CONFIRM="1" DOWNLOADSTATUS="16384" FORCEINSTALL="1" IGNORECASE="1" MORE="24" ROOT="" TRACE="0" TRACEFILE="PPM.LOG" VERBOSE="1" />
+
+
+
+
+
+<REPOSITORY LOCATION="http://ppm.activestate.com/PPMPackages/5.10-windows" NAME="ActiveState" SUMMARYFILE="searchsummary.ppm" />
+<REPOSITORY LOCATION="http://trouchelle.com/ppm10" NAME="Trouchelle" SUMMARYFILE="package.xml" />
+<REPOSITORY LOCATION="http://www.bribes.org/perl/ppm" NAME="Bribes" SUMMARYFILE="searchsummary.ppm" />
+<PPMPRECIOUS>Compress-Zlib;Archive-Tar;Digest-MD5;File-CounterFile;Font-AFM;HTML-Parser;HTML-Tree;MIME-Base64;URI;XML-Element;libwww-perl;XML-Parser;SOAP-Lite;PPM;libnet;libwin32</PPMPRECIOUS>
+</PPMCONFIG> \ No newline at end of file
diff --git a/Master/tlpkg/tlperl.straw/lib/pwd.pl b/Master/tlpkg/tlperl.straw/lib/pwd.pl
new file mode 100755
index 00000000000..6b429eb5a68
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/pwd.pl
@@ -0,0 +1,67 @@
+;# 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.
+#
+# 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.straw/lib/re.pm b/Master/tlpkg/tlperl.straw/lib/re.pm
new file mode 100755
index 00000000000..0c4974645f7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/re.pm
@@ -0,0 +1,514 @@
+package re;
+
+# pragma for controlling the regex engine
+use strict;
+use warnings;
+
+our $VERSION = "0.09";
+our @ISA = qw(Exporter);
+my @XS_FUNCTIONS = qw(regmust);
+my %XS_FUNCTIONS = map { $_ => 1 } @XS_FUNCTIONS;
+our @EXPORT_OK = (@XS_FUNCTIONS,
+ qw(is_regexp regexp_pattern
+ regname regnames regnames_count));
+our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
+
+# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+#
+# If you modify these values see comment below!
+
+my %bitmask = (
+ taint => 0x00100000, # HINT_RE_TAINT
+ eval => 0x00200000, # HINT_RE_EVAL
+);
+
+# - File::Basename contains a literal for 'taint' as a fallback. If
+# taint is changed here, File::Basename must be updated as well.
+#
+# - ExtUtils::ParseXS uses a hardcoded
+# BEGIN { $^H |= 0x00200000 }
+# in it to allow re.xs to be built. So if 'eval' is changed here then
+# ExtUtils::ParseXS must be changed as well.
+#
+# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+
+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,
+);
+$flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
+$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
+$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE};
+$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};
+
+my $installed;
+my $installed_error;
+
+sub _do_install {
+ if ( ! defined($installed) ) {
+ require XSLoader;
+ $installed = eval { XSLoader::load('re', $VERSION) } || 0;
+ $installed_error = $@;
+ }
+}
+
+sub _load_unload {
+ my ($on)= @_;
+ if ($on) {
+ _do_install();
+ if ( ! $installed ) {
+ die "'re' not installed!? ($installed_error)";
+ } else {
+ # 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 regex
+ # 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 ($XS_FUNCTIONS{$s}) {
+ _do_install();
+ if (! $installed) {
+ require Carp;
+ Carp::croak("\"re\" function '$s' not available");
+ }
+ require Exporter;
+ re->export_to_level(2, 're', $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 regex, the regex memories (or values returned by the m// operator
+in list context) are tainted. This feature is useful when regex 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 regex is allowed to contain
+C<(?{ ... })> zero-width assertions even if 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 })>.
+
+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.
+
+=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 regex 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 strigifying 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 consiers 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.straw/lib/sigtrap.pm b/Master/tlpkg/tlperl.straw/lib/sigtrap.pm
new file mode 100755
index 00000000000..8577c728c78
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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.straw/lib/stat.pl b/Master/tlpkg/tlperl.straw/lib/stat.pl
new file mode 100755
index 00000000000..c6682b9df3d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/stat.pl
@@ -0,0 +1,29 @@
+;# 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.straw/lib/termcap.pl b/Master/tlpkg/tlperl.straw/lib/termcap.pl
new file mode 100755
index 00000000000..f295a2d476b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/termcap.pl
@@ -0,0 +1,178 @@
+;# $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.
+#
+# 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.straw/lib/utf8.pm b/Master/tlpkg/tlperl.straw/lib/utf8.pm
new file mode 100755
index 00000000000..a985021f32a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/utf8.pm
@@ -0,0 +1,198 @@
+package utf8;
+
+$utf8::hint_bits = 0x00800000;
+
+our $VERSION = '1.07';
+
+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 a Perl scalar to/from UTF-8.
+ $num_octets = utf8::upgrade($string);
+ $success = utf8::downgrade($string[, FAIL_OK]);
+
+ # Change the native bytes of a Perl scalar to/from UTF-8 bytes.
+ utf8::encode($string);
+ utf8::decode($string);
+
+ $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 octet sequence in the native encoding
+(Latin-1 or EBCDIC) to the equivalent character sequence in I<UTF-X>.
+I<$string> already encoded as characters does no harm. 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 internal octet sequence in I<UTF-X> to the
+equivalent octet sequence in the native encoding (Latin-1 or EBCDIC).
+I<$string> already encoded as native 8 bit does no harm. 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>. The UTF8 flag is turned off, so that after this
+operation, the string is a byte string. Returns nothing.
+
+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. 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.
+
+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.straw/lib/utf8_heavy.pl b/Master/tlpkg/tlperl.straw/lib/utf8_heavy.pl
new file mode 100755
index 00000000000..b6b6b6e215d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/utf8_heavy.pl
@@ -0,0 +1,286 @@
+package utf8;
+use strict;
+use warnings;
+
+sub DEBUG () { 0 }
+
+sub DESTROY {}
+
+my %Cache;
+
+our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map);
+
+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.
+##
+
+sub SWASHNEW {
+ my ($class, $type, $list, $minbits, $none) = @_;
+ local $^D = 0 if $^D;
+
+ print STDERR "SWASHNEW @_\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.
+ ##
+ ## 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;
+
+ if ($type)
+ {
+ $type =~ s/^\s+//;
+ $type =~ s/\s+$//;
+
+ print STDERR "type = $type\n" if DEBUG;
+
+ GETFILE:
+ {
+ ##
+ ## It could be a user-defined property.
+ ##
+
+ my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
+
+ if (defined $caller1 && $type =~ /^(?:\w+)$/) {
+ my $prop = "${caller1}::$type";
+ if (exists &{$prop}) {
+ no strict 'refs';
+
+ $list = &{$prop};
+ last GETFILE;
+ }
+ }
+
+ my $wasIs;
+
+ ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i)
+ or
+ $type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i
+ or
+ $type =~ s/^(?:Script|sc)\s*[:=]\s*//i
+ or
+ $type =~ s/^Block\s*[:=]\s*/In/i;
+
+
+ ##
+ ## See if it's in some enumeration.
+ ##
+ require "unicore/PVA.pl";
+ if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) {
+ my ($enum, $val) = (lc $1, lc $2);
+ $enum =~ tr/ _-//d;
+ $val =~ tr/ _-//d;
+
+ my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum};
+ my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val};
+
+ if ($pa and $f) {
+ $pa = "gc_sc" if $pa eq "gc" or $pa eq "sc";
+ $file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl";
+ last GETFILE;
+ }
+ }
+ else {
+ my $t = lc $type;
+ $t =~ tr/ _-//d;
+
+ if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) {
+ $file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl";
+ last GETFILE;
+ }
+ }
+
+ ##
+ ## See if it's in the direct mapping table.
+ ##
+ require "unicore/Exact.pl";
+ if (my $base = $utf8::Exact{$type}) {
+ $file = "unicore/lib/gc_sc/$base.pl";
+ last GETFILE;
+ }
+
+ ##
+ ## If not there exactly, try the canonical form. The canonical
+ ## form is lowercased, with any separators (\s+|[-_]) removed.
+ ##
+ my $canonical = lc $type;
+ $canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g;
+ print STDERR "canonical = $canonical\n" if DEBUG;
+
+ require "unicore/Canonical.pl";
+ if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) {
+ $file = "unicore/lib/gc_sc/$base.pl";
+ last GETFILE;
+ }
+
+ ##
+ ## 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/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 "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 "Returning cached '$file' for \\p{$type}\n" if DEBUG;
+ return $found;
+ }
+
+ $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;
+ for my $x ($extras) {
+ pos $x = 0;
+ while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
+ my $char = $1;
+ my $name = $2;
+ print STDERR "$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};
+ }
+ }
+ }
+
+ print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG;
+
+ 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.straw/lib/version.pm b/Master/tlpkg/tlperl.straw/lib/version.pm
new file mode 100755
index 00000000000..c200914affc
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/version.pm
@@ -0,0 +1,216 @@
+#!perl -w
+package version;
+
+use 5.005_04;
+use strict;
+
+use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
+
+$VERSION = '0.80';
+$VERSION = eval $VERSION;
+
+$CLASS = 'version';
+
+# Define STRICT version parsing
+
+my $DECIMAL_VERSION = '
+(?:
+ (?: # integer part
+ 0(?=[.]) # 0 but only if followed by a period
+ | # or
+ [1-9] # 1-9 followed by
+ [0-9]* # zero or more digits
+ )
+ (?: # decimal part
+ [.] # literal decimal point
+ [0-9]+ # one or more digits
+ )? # optional
+)';
+
+my $DOTTED_DECIMAL_VERSION = '
+(?:
+ v # leading v required
+ (?: # integer part
+ 0(?=[.]) # 0 but only if followed by a period
+ | # or
+ [1-9] # 1-9 followed by
+ [0-9]* # zero or more digits
+ )
+ (?: # repeated part
+ [.] # literal decimal point
+ [0-9]{1,3} # followed by one to three digits
+ ){2,} # repeating 2 or more times
+)';
+
+$STRICT = qr/(?:${DECIMAL_VERSION}|${DOTTED_DECIMAL_VERSION})/x;
+
+# Define LAX version parsing
+
+my $ALPHA = '
+(?:
+ [_] # literal underscore
+ [0-9]{1,} # followed by one or more digits
+)';
+
+my $LAX_DOTTED_DECIMAL_VERSION = '
+(?:
+ (?:
+ v # leading v required
+ (?: # integer part
+ [0-9]+ # zero or more digits
+ )
+ (?: # repeated part
+ [.] # literal decimal point
+ [0-9]{1,} # followed by one or more digits
+ ){0,} # repeating zero or more times
+ )
+ | # or
+ (?:
+ v # leading v required
+ (?: # integer part
+ [0-9]+ # zero or more digits
+ )
+ (?: # repeated part
+ [.] # literal decimal point
+ [0-9]{1,} # followed by one or more digits
+ ){1,} # repeating one or more times
+ ${ALPHA}* # with trailing optional alpha stanza(s)
+ )
+ | # or
+ (?:
+ (?!v) # no leading v
+ (?: # integer part
+ 0(?=[.]) # 0 but only if followed by a period
+ | # or
+ [1-9] # 1-9 followed by
+ [0-9]* # zero or more digits
+ )
+ (?: # repeated part
+ [.] # literal decimal point
+ [0-9]{1,} # followed by one or more digits
+ ){2,} # repeating two or more times
+ ${ALPHA}* # with trailing optional alpha stanza(s)
+ )
+)
+';
+
+my $LAX_DECIMAL_VERSION = '
+(?:
+ (?:
+ (?: # integer part
+ 0(?=[.]) # 0 but only if followed by a period
+ | # or
+ [1-9] # 1-9 followed by
+ [0-9]* # zero or more digits
+ )
+ (?: # decimal part
+ [.] # literal decimal point
+ [0-9]+ # one or more digits
+ )? # optional
+ )
+ | # or
+ (?:
+ (?: # integer part
+ 0(?=[.]) # 0 but only if followed by a period
+ | # or
+ [1-9] # 1-9 followed by
+ [0-9]* # zero or more digits
+ ) # mantissa required
+ (?: # decimal part
+ [.] # literal decimal point
+ [0-9]+ # one or more digits
+ ) # required
+ ${ALPHA}* # with trailing optional alpha stanza(s)
+ )
+)
+';
+
+$LAX= qr/(?:${LAX_DECIMAL_VERSION}|${LAX_DOTTED_DECIMAL_VERSION})/x;
+
+eval "use version::vxs $VERSION";
+if ( $@ ) { # don't have the XS version installed
+ eval "use version::vpp $VERSION"; # don't tempt fate
+ die "$@" if ( $@ );
+ push @ISA, "version::vpp";
+ local $^W;
+ *version::qv = \&version::vpp::qv;
+ *version::declare = \&version::vpp::declare;
+ *version::_VERSION = \&version::vpp::_VERSION;
+ if ($] > 5.009001 && $] <= 5.010000) {
+ no strict 'refs';
+ *{'version::stringify'} = \*version::vpp::stringify;
+ *{'version::(""'} = \*version::vpp::stringify;
+ *{'version::new'} = \*version::vpp::new;
+ }
+}
+else { # use XS module
+ push @ISA, "version::vxs";
+ local $^W;
+ *version::declare = \&version::vxs::declare;
+ *version::qv = \&version::vxs::qv;
+ *version::_VERSION = \&version::vxs::_VERSION;
+ if ($] > 5.009001 && $] < 5.010000) {
+ no strict 'refs';
+ *{'version::stringify'} = \*version::vxs::stringify;
+ *{'version::(""'} = \*version::vxs::stringify;
+ }
+ elsif ($] == 5.010000) {
+ no strict 'refs';
+ *{'version::stringify'} = \*version::vxs::stringify;
+ *{'version::(""'} = \*version::vxs::stringify;
+ *version::new = \&version::vxs::new;
+ *version::parse = \&version::vxs::parse;
+ }
+
+}
+
+# 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{'UNIVERSAL::VERSION'})) {
+ local $^W;
+ *UNIVERSAL::VERSION
+ = \&version::_VERSION;
+ }
+
+ if (exists($args{'VERSION'})) {
+ *{$callpkg."::VERSION"} = \&version::_VERSION;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/version.pod b/Master/tlpkg/tlperl.straw/lib/version.pod
new file mode 100755
index 00000000000..090b5969ee1
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/version.pod
@@ -0,0 +1,365 @@
+=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!)
+
+ 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 (without
+quotes) into your source file.
+
+=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
+
+See L<VERSION OBJECT DETAILS> for further information.
+
+=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 OBJECT DETAILS> 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 can
+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 OBJECT DETAILS> for more on version number conversion.
+
+=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
+
+=head1 VERSION OBJECT DETAILS
+
+=head2 Equivalence between Decimal and Dotted-Decimal Versions
+
+When Perl 5.6.0 was released, the decision was made to provide a
+transformation between the old-style decimal versions and new-style
+dotted-decimal versions:
+
+ 5.6.0 == 5.006000
+ 5.005_04 == 5.5.40
+
+The floating point number is taken and split first on the single decimal
+place, then each group of three digits to the right of the decimal makes up
+the next digit, and so on until the number of significant digits is exhausted,
+B<plus> enough trailing zeros to reach the next multiple of three.
+
+This was the method that version.pm adopted as well. Some examples may be
+helpful:
+
+ equivalent
+ decimal zero-padded dotted-decimal
+ ------- ----------- --------------
+ 1.2 1.200 v1.200.0
+ 1.02 1.020 v1.20.0
+ 1.002 1.002 v1.2.0
+ 1.0023 1.002300 v1.2.300
+ 1.00203 1.002030 v1.2.30
+ 1.002003 1.002003 v1.2.3
+
+=head2 Quoting rules
+
+Because of the nature of the Perl parsing and tokenizing routines,
+certain initialization values B<must> be quoted in order to correctly
+parse as the intended version, especially when using the L<declare> or
+L<qv> methods. While you do not have to quote decimal numbers when
+creating version objects, it is always safe to quote B<all> initial values
+when using version.pm methods, as this will ensure that what you type is
+what is used.
+
+Additionally, if you quote your initializer, then the quoted value that goes
+B<in> will be be exactly what comes B<out> when your $VERSION is printed
+(stringified). If you do not quote your value, Perl's normal numeric handling
+comes into play and you may not get back what you were expecting.
+
+If you use a mathematic formula that resolves to a floating point number,
+you are dependent on Perl's conversion routines to yield the version you
+expect. You are pretty safe by dividing by a power of 10, for example,
+but other operations are not likely to be what you intend. For example:
+
+ $VERSION = version->new((qw$Revision: 1.4)[1]/10);
+ print $VERSION; # yields 0.14
+ $V2 = version->new(100/9); # Integer overflow in decimal number
+ print $V2; # yields something like 11.111.111.100
+
+Perl 5.8.1 and beyond are able to automatically quote v-strings but
+that is not possible in earlier versions of Perl. In other words:
+
+ $version = version->new("v2.5.4"); # legal in all versions of Perl
+ $newvers = version->new(v2.5.4); # legal only in Perl >= 5.8.1
+
+=head2 What about v-strings?
+
+There are two ways to enter v-strings: a bare number with two or more
+decimal points, or a bare number with one or more decimal points and a
+leading 'v' character (also bare). For example:
+
+ $vs1 = 1.2.3; # encoded as \1\2\3
+ $vs2 = v1.2; # encoded as \1\2
+
+However, the use of bare v-strings to initialize version objects is
+B<strongly> discouraged in all circumstances. Also, bare
+v-strings are not completely supported in any version of Perl prior to
+5.8.1.
+
+If you insist on using bare v-strings with Perl > 5.6.0, be aware of the
+following limitations:
+
+1) For Perl releases 5.6.0 through 5.8.0, the v-string code merely guesses,
+based on some characteristics of v-strings. You B<must> use a three part
+version, e.g. 1.2.3 or v1.2.3 in order for this heuristic to be successful.
+
+2) For Perl releases 5.8.1 and later, v-strings have changed in the Perl
+core to be magical, which means that the version.pm code can automatically
+determine whether the v-string encoding was used.
+
+3) In all cases, a version created using v-strings will have a stringified
+form that has a leading 'v' character, for the simple reason that sometimes
+it is impossible to tell whether one was present initially.
+
+=head2 Alpha versions
+
+For module authors using CPAN, the convention has been to note unstable
+releases with an underscore in the version string. (See L<CPAN>.) version.pm
+follows this convention and alpha releases will test as being newer than the
+more recent stable release, and less than the next stable release. For
+dotted-decimal versions, only the last element may be separated by an
+underscore:
+
+ # Declaring
+ use version 0.77; our $VERSION = version->declare("v1.2_3");
+
+ # Parsing
+ $v1 = version->parse("v1.2_3");
+ $v1 = version->parse("1.002_003");
+
+=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 ();
+
+=head1 AUTHOR
+
+John Peacock E<lt>jpeacock@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<version::Internal>.
+
+L<perl>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/version/Internals.pod b/Master/tlpkg/tlperl.straw/lib/version/Internals.pod
new file mode 100755
index 00000000000..5ff365e2762
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/version/Internals.pod
@@ -0,0 +1,608 @@
+=head1 NAME
+
+version::Internal - Perl extension for Version Objects
+
+=head1 DESCRIPTION
+
+Overloaded version objects for all modern versions of Perl. This documents
+the internal data representation and underlying code for version.pm. See
+L<version.pod> for daily usage. This document is only useful for users
+writing a subclass of version.pm or interested in the gory details.
+
+=head1 What IS a version
+
+For the purposes of this module, a version "number" is a sequence of
+positive integer values separated by one or more decimal points and
+optionally a single underscore. This corresponds to what Perl itself
+uses for a version, as well as extending the "version as number" that
+is discussed in the various editions of the Camel book.
+
+There are actually two distinct kinds of version objects:
+
+=over 4
+
+=item * Decimal Versions
+
+Any version which "looks like a number", see L<Decimal Versions>. This
+also includes versions with a single decimal point and a single embedded
+underscore, see L<Decimal Alpha Versions>, even though these must be quoted
+to preserve the underscore formatting.
+
+=item * Dotted-Decimal Versions
+
+Also referred to as "Dotted-Integer", these contains more than one decimal
+point and may have an optional embedded underscore, see L<Dotted-Decimal
+Versions>. This is what is commonly used in most open source software as
+the "external" version (the one used as part of the tag or tarfile name).
+A leading 'v' character is now required and will warn if it missing.
+
+=back
+
+Both of these methods will produce similar version objects, in that
+the default stringification will yield the version L<Normal Form> only
+if required:
+
+ $v = version->new(1.002); # 1.002, but compares like 1.2.0
+ $v = version->new(1.002003); # 1.002003
+ $v2 = version->new("v1.2.3"); # v1.2.3
+
+In specific, version numbers initialized as L<Decimal Versions> will
+stringify as they were originally created (i.e. the same string that was
+passed to C<new()>. Version numbers initialized as L<Dotted-Decimal Versions>
+will be stringified as L<Normal Form>.
+
+=head2 Decimal Versions
+
+These correspond to historical versions of Perl itself prior to 5.6.0,
+as well as all other modules which follow the Camel rules for the
+$VERSION scalar. A Decimal version is initialized with what looks like
+a floating point number. Leading zeros B<are> significant and trailing
+zeros are implied so that a minimum of three places is maintained
+between subversions. What this means is that any subversion (digits
+to the right of the decimal place) that contains less than three digits
+will have trailing zeros added to make up the difference, but only for
+purposes of comparison with other version objects. For example:
+
+ # Prints Equivalent to
+ $v = version->new( 1.2); # 1.2 v1.200.0
+ $v = version->new( 1.02); # 1.02 v1.20.0
+ $v = version->new( 1.002); # 1.002 v1.2.0
+ $v = version->new( 1.0023); # 1.0023 v1.2.300
+ $v = version->new( 1.00203); # 1.00203 v1.2.30
+ $v = version->new( 1.002003); # 1.002003 v1.2.3
+
+All of the preceding examples are true whether or not the input value is
+quoted. The important feature is that the input value contains only a
+single decimal. See also L<Alpha Versions> for how to handle
+
+IMPORTANT NOTE: As shown above, if your Decimal version contains more
+than 3 significant digits after the decimal place, it will be split on
+each multiple of 3, so 1.0003 is equivalent to v1.0.300, due to the need
+to remain compatible with Perl's own 5.005_03 == 5.5.30 interpretation.
+Any trailing zeros are ignored for mathematical comparison purposes.
+
+=head2 Dotted-Decimal Versions
+
+These are the newest form of versions, and correspond to Perl's own
+version style beginning with 5.6.0. Starting with Perl 5.10.0,
+and most likely Perl 6, this is likely to be the preferred form. This
+method normally requires that the input parameter be quoted, although
+Perl's after 5.8.1 can use v-strings as a special form of quoting, but
+this is highly discouraged.
+
+Unlike L<Decimal Versions>, Dotted-Decimal Versions have more than
+a single decimal point, e.g.:
+
+ # Prints
+ $v = version->new( "v1.200"); # v1.200.0
+ $v = version->new("v1.20.0"); # v1.20.0
+ $v = qv("v1.2.3"); # v1.2.3
+ $v = qv("1.2.3"); # v1.2.3
+ $v = qv("1.20"); # v1.20.0
+
+In general, Dotted-Decimal Versions permit the greatest amount of freedom
+to specify a version, whereas Decimal Versions enforce a certain
+uniformity. See also L<New Operator> for an additional method of
+initializing version objects.
+
+Just like L<Decimal Versions>, Dotted-Decimal Versions can be used as
+L<Alpha Versions>.
+
+=head2 Decimal Alpha Versions
+
+The one time that a Decimal version must be quoted is when a alpha form is
+used with an otherwise Decimal version (i.e. a single decimal point). This
+is commonly used for CPAN releases, where CPAN or CPANPLUS will ignore alpha
+versions for automatic updating purposes. Since some developers have used
+only two significant decimal places for their non-alpha releases, the
+version object will automatically take that into account if the initializer
+is quoted. For example Module::Example was released to CPAN with the
+following sequence of $VERSION's:
+
+ # $VERSION Stringified
+ 0.01 0.01
+ 0.02 0.02
+ 0.02_01 0.02_01
+ 0.02_02 0.02_02
+ 0.03 0.03
+ etc.
+
+The stringified form of Decimal versions will always be the same string
+that was used to initialize the version object.
+
+=head1 High level design
+
+=head2 version objects
+
+version.pm provides an overloaded version object that is designed to both
+encapsulate the author's intended $VERSION assignment as well as make it
+completely natural to use those objects as if they were numbers (e.g. for
+comparisons). To do this, a version object contains both the original
+representation as typed by the author, as well as a parsed representation
+to ease comparisons. Version objects employ L<overload> methods to
+simplify code that needs to compare, print, etc the objects.
+
+The internal structure of version objects is a blessed hash with several
+components:
+
+ bless( {
+ 'original' => 'v1.2.3_4',
+ 'alpha' => 1,
+ 'qv' => 1,
+ 'version' => [
+ 1,
+ 2,
+ 3,
+ 4
+ ]
+ }, 'version' );
+
+=over 4
+
+=item original
+
+A faithful representation of the value used to initialize this version
+object. The only time this will not be precisely the same characters
+that exist in the source file is if a short dotted-decimal version like
+v1.2 was used (in which case it will contain 'v1.2'). This form is
+B<STRONGLY> discouraged, in that it will confuse you and your users.
+
+=item qv
+
+A boolean that denotes whether this is a decimal or dotted-decimal version.
+See L<is_qv>.
+
+=item alpha
+
+A boolean that denotes whether this is an alpha version. NOTE: that the
+underscore can can only appear in the last position. See L<is_alpha>.
+
+=item version
+
+An array of non-negative integers that is used for comparison purposes with
+other version objects.
+
+=back
+
+=head2 Replacement UNIVERSAL::VERSION
+
+In addition to the version objects, this modules also replaces the core
+UNIVERSAL::VERSION function with one that uses version objects for its
+comparisons. The return from this operator is always the stringified form
+as a simple scalar (i.e. not an object), but the warning message generated
+includes either the stringified form or the normal form, depending on how
+it was called.
+
+For example:
+
+ package Foo;
+ $VERSION = 1.2;
+
+ package Bar;
+ $VERSION = "v1.3.5"; # works with all Perl's (since it is quoted)
+
+ package main;
+ use version;
+
+ print $Foo::VERSION; # prints 1.2
+
+ print $Bar::VERSION; # prints 1.003005
+
+ eval "use foo 10";
+ print $@; # prints "foo version 10 required..."
+ eval "use foo 1.3.5; # work in Perl 5.6.1 or better
+ print $@; # prints "foo version 1.3.5 required..."
+
+ eval "use bar 1.3.6";
+ print $@; # prints "bar version 1.3.6 required..."
+ eval "use bar 1.004"; # note Decimal version
+ print $@; # prints "bar version 1.004 required..."
+
+
+IMPORTANT NOTE: This may mean that code which searches for a specific
+string (to determine whether a given module is available) may need to be
+changed. It is always better to use the built-in comparison implicit in
+C<use> or C<require>, rather than manually poking at C<class->VERSION>
+and then doing a comparison yourself.
+
+The replacement UNIVERSAL::VERSION, when used as a function, like this:
+
+ print $module->VERSION;
+
+will also exclusively return the stringified form. See L<Stringification>
+for more details.
+
+=head1 Usage question
+
+=head2 Using modules that use version.pm
+
+As much as possible, the version.pm module remains compatible with all
+current code. However, if your module is using a module that has defined
+C<$VERSION> using the version class, there are a couple of things to be
+aware of. For purposes of discussion, we will assume that we have the
+following module installed:
+
+ package Example;
+ use version; $VERSION = qv('1.2.2');
+ ...module code here...
+ 1;
+
+=over 4
+
+=item Decimal versions always work
+
+Code of the form:
+
+ use Example 1.002003;
+
+will always work correctly. The C<use> will perform an automatic
+C<$VERSION> comparison using the floating point number given as the first
+term after the module name (e.g. above 1.002.003). In this case, the
+installed module is too old for the requested line, so you would see an
+error like:
+
+ Example version 1.002003 (v1.2.3) required--this is only version 1.002002 (v1.2.2)...
+
+=item Dotted-Decimal version work sometimes
+
+With Perl >= 5.6.2, you can also use a line like this:
+
+ use Example 1.2.3;
+
+and it will again work (i.e. give the error message as above), even with
+releases of Perl which do not normally support v-strings (see L<What about
+v-strings> below). This has to do with that fact that C<use> only checks
+to see if the second term I<looks like a number> and passes that to the
+replacement L<UNIVERSAL::VERSION>. This is not true in Perl 5.005_04,
+however, so you are B<strongly encouraged> to always use a Decimal version
+in your code, even for those versions of Perl which support the Dotted-Decimal
+version.
+
+=back
+
+=head2 Object Methods
+
+Overloading has been used with version objects to provide a natural
+interface for their use. All mathematical operations are forbidden,
+since they don't make any sense for base version objects. Consequently,
+there is no overloaded numification available. If you want to use a
+version object in a Decimal context for some reason, see the L<numify>
+object method.
+
+=over 4
+
+=item * New Operator
+
+Like all OO interfaces, the new() operator is used to initialize
+version objects. One way to increment versions when programming is to
+use the CVS variable $Revision, which is automatically incremented by
+CVS every time the file is committed to the repository.
+
+In order to facilitate this feature, the following
+code can be employed:
+
+ $VERSION = version->new(qw$Revision: 2.7 $);
+
+and the version object will be created as if the following code
+were used:
+
+ $VERSION = version->new("v2.7");
+
+In other words, the version will be automatically parsed out of the
+string, and it will be quoted to preserve the meaning CVS normally
+carries for versions. The CVS $Revision$ increments differently from
+Decimal versions (i.e. 1.10 follows 1.9), so it must be handled as if
+it were a L<Dotted-Decimal Version>.
+
+A new version object can be created as a copy of an existing version
+object, either as a class method:
+
+ $v1 = version->new(12.3);
+ $v2 = version->new($v1);
+
+or as an object method:
+
+ $v1 = version->new(12.3);
+ $v2 = $v1->new(12.3);
+
+and in each case, $v1 and $v2 will be identical. NOTE: if you create
+a new object using an existing object like this:
+
+ $v2 = $v1->new();
+
+the new object B<will not> be a clone of the existing object. In the
+example case, $v2 will be an empty object of the same type as $v1.
+
+=back
+
+=over 4
+
+=item * qv()
+
+An alternate way to create a new version object is through the exported
+qv() sub. This is not strictly like other q? operators (like qq, qw),
+in that the only delimiters supported are parentheses (or spaces). It is
+the best way to initialize a short version without triggering the floating
+point interpretation. For example:
+
+ $v1 = qv(1.2); # v1.2.0
+ $v2 = qv("1.2"); # also v1.2.0
+
+As you can see, either a bare number or a quoted string can usually
+be used interchangably, except in the case of a trailing zero, which
+must be quoted to be converted properly. For this reason, it is strongly
+recommended that all initializers to qv() be quoted strings instead of
+bare numbers.
+
+To prevent the C<qv()> function from being exported to the caller's namespace,
+either use version with a null parameter:
+
+ use version ();
+
+or just require version, like this:
+
+ require version;
+
+Both methods will prevent the import() method from firing and exporting the
+C<qv()> sub. This is true of subclasses of version as well, see
+L<SUBCLASSING> for details.
+
+=back
+
+For the subsequent examples, the following three objects will be used:
+
+ $ver = version->new("1.2.3.4"); # see "Quoting" below
+ $alpha = version->new("1.2.3_4"); # see "Alpha versions" below
+ $nver = version->new(1.002); # see "Decimal Versions" above
+
+=over 4
+
+=item * Normal Form
+
+For any version object which is initialized with multiple decimal
+places (either quoted or if possible v-string), or initialized using
+the L<qv()> operator, the stringified representation is returned in
+a normalized or reduced form (no extraneous zeros), and with a leading 'v':
+
+ print $ver->normal; # prints as v1.2.3.4
+ print $ver->stringify; # ditto
+ print $ver; # ditto
+ print $nver->normal; # prints as v1.2.0
+ print $nver->stringify; # prints as 1.002, see "Stringification"
+
+In order to preserve the meaning of the processed version, the
+normalized representation will always contain at least three sub terms.
+In other words, the following is guaranteed to always be true:
+
+ my $newver = version->new($ver->stringify);
+ if ($newver eq $ver ) # always true
+ {...}
+
+=back
+
+=over 4
+
+=item * Numification
+
+Although all mathematical operations on version objects are forbidden
+by default, it is possible to retrieve a number which corresponds
+to the version object through the use of the $obj->numify
+method. For formatting purposes, when displaying a number which
+corresponds a version object, all sub versions are assumed to have
+three decimal places. So for example:
+
+ print $ver->numify; # prints 1.002003004
+ print $nver->numify; # prints 1.002
+
+Unlike the stringification operator, there is never any need to append
+trailing zeros to preserve the correct version value.
+
+=back
+
+=over 4
+
+=item * Stringification
+
+The default stringification for version objects returns exactly the same
+string as was used to create it, whether you used C<new()> or C<qv()>,
+with one exception. The sole exception is if the object was created using
+C<qv()> and the initializer did not have two decimal places or a leading
+'v' (both optional), then the stringified form will have a leading 'v'
+prepended, in order to support round-trip processing.
+
+For example:
+
+ Initialized as Stringifies to
+ ============== ==============
+ version->new("1.2") 1.2
+ version->new("v1.2") v1.2
+ qv("1.2.3") 1.2.3
+ qv("v1.3.5") v1.3.5
+ qv("1.2") v1.2 ### exceptional case
+
+See also L<UNIVERSAL::VERSION>, as this also returns the stringified form
+when used as a class method.
+
+IMPORTANT NOTE: There is one exceptional cases shown in the above table
+where the "initializer" is not stringwise equivalent to the stringified
+representation. If you use the C<qv()> operator on a version without a
+leading 'v' B<and> with only a single decimal place, the stringified output
+will have a leading 'v', to preserve the sense. See the L<qv()> operator
+for more details.
+
+IMPORTANT NOTE 2: Attempting to bypass the normal stringification rules by
+manually applying L<numify()> and L<normal()> will sometimes yield
+surprising results:
+
+ print version->new(version->new("v1.0")->numify)->normal; # v1.0.0
+
+The reason for this is that the L<numify()> operator will turn "v1.0"
+into the equivalent string "1.000000". Forcing the outer version object
+to L<normal()> form will display the mathematically equivalent "v1.0.0".
+
+As the example in L<new()> shows, you can always create a copy of an
+existing version object with the same value by the very compact:
+
+ $v2 = $v1->new($v1);
+
+and be assured that both C<$v1> and C<$v2> will be completely equivalent,
+down to the same internal representation as well as stringification.
+
+=back
+
+=over 4
+
+=item * Comparison operators
+
+Both C<cmp> and C<E<lt>=E<gt>> operators perform the same comparison between
+terms (upgrading to a version object automatically). Perl automatically
+generates all of the other comparison operators based on those two.
+In addition to the obvious equalities listed below, appending a single
+trailing 0 term does not change the value of a version for comparison
+purposes. In other words "v1.2" and "1.2.0" will compare as identical.
+
+For example, the following relations hold:
+
+ As Number As String Truth Value
+ ------------- ---------------- -----------
+ $ver > 1.0 $ver gt "1.0" true
+ $ver < 2.5 $ver lt true
+ $ver != 1.3 $ver ne "1.3" true
+ $ver == 1.2 $ver eq "1.2" false
+ $ver == 1.2.3.4 $ver eq "1.2.3.4" see discussion below
+
+It is probably best to chose either the Decimal notation or the string
+notation and stick with it, to reduce confusion. Perl6 version objects
+B<may> only support Decimal comparisons. See also L<Quoting>.
+
+WARNING: Comparing version with unequal numbers of decimal points (whether
+explicitly or implicitly initialized), may yield unexpected results at
+first glance. For example, the following inequalities hold:
+
+ version->new(0.96) > version->new(0.95); # 0.960.0 > 0.950.0
+ version->new("0.96.1") < version->new(0.95); # 0.096.1 < 0.950.0
+
+For this reason, it is best to use either exclusively L<Decimal Versions> or
+L<Dotted-Decimal Versions> with multiple decimal points.
+
+=back
+
+=over 4
+
+=item * Logical Operators
+
+If you need to test whether a version object
+has been initialized, you can simply test it directly:
+
+ $vobj = version->new($something);
+ if ( $vobj ) # true only if $something was non-blank
+
+You can also test whether a version object is an L<Alpha version>, for
+example to prevent the use of some feature not present in the main
+release:
+
+ $vobj = version->new("1.2_3"); # MUST QUOTE
+ ...later...
+ if ( $vobj->is_alpha ) # True
+
+=back
+
+=head2 Quoting
+
+Because of the nature of the Perl parsing and tokenizing routines,
+certain initialization values B<must> be quoted in order to correctly
+parse as the intended version, especially when using the L<qv()> operator.
+In all cases, a floating point number passed to version->new() will be
+identically converted whether or not the value itself is quoted. This is
+not true for L<qv()>, however, when trailing zeros would be stripped on
+an unquoted input, which would result in a very different version object.
+
+In addition, in order to be compatible with earlier Perl version styles,
+any use of versions of the form 5.006001 will be translated as v5.6.1.
+In other words, a version with a single decimal point will be parsed as
+implicitly having three digits between subversions, but only for internal
+comparison purposes.
+
+The complicating factor is that in bare numbers (i.e. unquoted), the
+underscore is a legal Decimal character and is automatically stripped
+by the Perl tokenizer before the version code is called. However, if
+a number containing one or more decimals and an underscore is quoted, i.e.
+not bare, that is considered a L<Alpha Version> and the underscore is
+significant.
+
+If you use a mathematic formula that resolves to a floating point number,
+you are dependent on Perl's conversion routines to yield the version you
+expect. You are pretty safe by dividing by a power of 10, for example,
+but other operations are not likely to be what you intend. For example:
+
+ $VERSION = version->new((qw$Revision: 1.4)[1]/10);
+ print $VERSION; # yields 0.14
+ $V2 = version->new(100/9); # Integer overflow in decimal number
+ print $V2; # yields something like 11.111.111.100
+
+Perl 5.8.1 and beyond will be able to automatically quote v-strings but
+that is not possible in earlier versions of Perl. In other words:
+
+ $version = version->new("v2.5.4"); # legal in all versions of Perl
+ $newvers = version->new(v2.5.4); # legal only in Perl >= 5.8.1
+
+=head1 SUBCLASSING
+
+This module is specifically designed and tested to be easily subclassed.
+In practice, you only need to override the methods you want to change, but
+you have to take some care when overriding new() (since that is where all
+of the parsing takes place). For example, this is a perfect acceptable
+derived class:
+
+ package myversion;
+ use base version;
+ sub new {
+ my($self,$n)=@_;
+ my $obj;
+ # perform any special input handling here
+ $obj = $self->SUPER::new($n);
+ # and/or add additional hash elements here
+ return $obj;
+ }
+
+See also L<version::AlphaBeta> on CPAN for an alternate representation of
+version strings.
+
+B<NOTE:> Although the L<qv> operator is not a true class method, but rather a
+function exported into the caller's namespace, a subclass of version will
+inherit an import() function which will perform the correct magic on behalf
+of the subclass.
+
+=head1 EXPORT
+
+qv - Dotted-Decimal Version initialization operator
+
+=head1 AUTHOR
+
+John Peacock E<lt>jpeacock@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<perl>.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/version/vxs.pm b/Master/tlpkg/tlperl.straw/lib/version/vxs.pm
new file mode 100755
index 00000000000..ed4337e00ad
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/version/vxs.pm
@@ -0,0 +1,28 @@
+#!perl -w
+package version::vxs;
+
+use 5.005_03;
+use strict;
+
+use vars qw(@ISA $VERSION $CLASS );
+
+$VERSION = '0.80';
+$VERSION = eval $VERSION;
+
+$CLASS = 'version::vxs';
+
+eval {
+ require XSLoader;
+ local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
+ XSLoader::load('version::vxs', $VERSION);
+ 1;
+} or do {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
+ bootstrap version::vxs $VERSION;
+};
+
+# Preloaded methods go here.
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/vmsish.pm b/Master/tlpkg/tlperl.straw/lib/vmsish.pm
new file mode 100755
index 00000000000..30c8eb1656d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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;